*DECK DECK=AMC$CONDITION_CODE_LIMITS EXPAND=FALSE

  CONST
{ The exception conditions in the range amc$min_ecc_validation ..
{ amc$max_ecc_validation are detected while validating file access}
{ permissions and request input parameters. Exception conditions of this}
{ class are due to program error or the failure of the user to}
{ provide proper file permissions. Due to the presumed inability of the}
{ program to deal with these exception conditions, the message content}
{ has been oriented to the user. It is presumed that the}
{ exception conditions of this class are returned directly to the}
{ user. However, the program retains the option of ignoring or interpreting}
{ exception conditions of this class, if it chooses.}
{}
*IF $true(osv$unix)
    amc$min_ecc = (($INTEGER ('A') * 100(16)) + $INTEGER ('M')) * 10000(16),
*ELSE
    amc$min_ecc = (($INTEGER ('A') * 100(16)) + $INTEGER ('M')) * 1000000(16),
*IFEND
    amc$min_ecc_validation = amc$min_ecc,
    amc$max_ecc_validation = amc$min_ecc_validation + 999,
{}
{ The exception conditions in the range amc$min_ecc_program_action ..
{ amc$max_ecc_program_action are detected during the execution of a}
{ validated request. Exception conditions of this class are due to}
{ circumstances beyond the control of the program, such as an unrecovered}
{ read error; or the exception condition may be due to a program error}
{ from which the program may easily recover. It is assumed that the program}
{ will interpret the exception conditions of this class and if recovery is}
{ impossible, issue a more meaningful message to the user.}
{}
    amc$min_ecc_program_action = amc$min_ecc_validation + 1000,
    amc$max_ecc_program_action = amc$min_ecc_program_action + 999,


    amc$access_method_id = 'AM';
*DECK DECK=AMC$MAXIMUM_BLOCK EXPAND=FALSE
 CONST
    amc$maximum_block = osc$max_segment_length - 32;

*copyc osd$virtual_address
*DECK DECK=AMC$MAXIMUM_KEYED_RECORD EXPAND=FALSE
 CONST
    amc$maximum_keyed_record = 65497;
*DECK DECK=AMC$MAX_FAP_LAYERS EXPAND=FALSE
 CONST
    amc$max_fap_layers = 15;
*DECK DECK=AMC$MAX_KEY_POSITION EXPAND=FALSE
 CONST
    amc$max_key_position = amc$maximum_keyed_record - 1;

*copyc amc$maximum_keyed_record
*DECK DECK=AMC$MAX_LINES_PER_INCH EXPAND=FALSE
 CONST
    amc$max_lines_per_inch = 12;
*DECK DECK=AMC$MAX_USER_INFO EXPAND=FALSE

 CONST
    amc$max_user_info = 32;
*DECK DECK=AMC$MAX_VOL_NUMBER EXPAND=TRUE

 CONST
    amc$max_vol_number = 65536;

*DECK DECK=AMD$BLOCK_HEADERS EXPAND=FALSE

  TYPE
    amt$block_header_type = (amc$tapemark_block, amc$data_block),
    amt$block_status = (amc$no_error, amc$unrecovered_error),
    amt$pack_block_header = record
      header_type: amt$block_header_type,
      block_length: amt$max_block_length,
      block_number: amt$block_number,
      unused_bit_count: amt$unused_bit_count,
    recend,
    amt$unpack_block_header = record
      header_type: amt$block_header_type,
      block_length_as_read: amt$max_block_length,
      block_length_as_written: amt$max_block_length,
      block_number: amt$block_number,
      unused_bit_count: amt$unused_bit_count,
      block_status: amt$block_status,
    recend;

*copyc AMT$BLOCK_NUMBER
*copyc AMT$MAX_BLOCK_LENGTH
*copyc AMT$UNUSED_BIT_COUNT
*DECK DECK=AMD$FILE_ATTRIBUTES EXPAND=FALSE
  TYPE
    amt$global_file_position = amt$file_position,
    amt$label_options = set of (amc$vol1, amc$uvl, amc$hdr1, amc$hdr2,
      amc$eov1, amc$eov2, amc$uhl, amc$eof1, amc$eof2, amc$utl),
    amt$return_option = (amc$return_at_close, amc$return_at_task_exit,
      amc$return_at_job_exit);

*copyc amd$open_declarations
*copyc amt$attribute_source
*copyc amt$average_record_length
*copyc amt$block_type
*copyc amt$collate_table
*copyc amt$collation_value
*copyc amt$data_padding
*copyc amt$error_exit_procedure
*copyc amt$error_limit
*copyc amt$estimated_record_count
*copyc amt$file_attribute_keys
*copyc amt$file_byte_address
*copyc amt$file_identifier
*copyc amt$file_length
*copyc amt$file_limit
*copyc amt$file_organization
*copyc amt$file_position
*copyc amt$forced_write
*copyc amt$index_padding
*copyc amt$internal_code
*copyc amt$key_length
*copyc amt$key_position
*copyc amt$key_type
*copyc amt$label_exit_procedure
*copyc amt$label_type
*copyc amt$local_file_name
*copyc amt$mau_length
*copyc amt$max_block_length
*copyc amt$max_record_length
*copyc amt$message_control
*copyc amt$min_block_length
*copyc amt$min_record_length
*copyc amt$padding_character
*copyc amt$record_limit
*copyc amt$record_type
*copyc amt$records_per_block
*copyc amt$user_info
*copyc amt$vertical_print_density
*copyc osd$virtual_address
*copyc ost$status
*DECK DECK=AMD$FILE_CONTENTS EXPAND=FALSE

  CONST
{   Use constants in this deck with amp$open.
{   Use constants in deck fsc$file_contents with fsp$open_file.
    amc$unknown_contents = 'UNKNOWN',
    amc$legible = 'LEGIBLE',
    amc$list = 'LIST',
    amc$object = 'OBJECT',
    amc$screen = 'SCREEN';

*copyc amt$file_contents

*DECK DECK=AMD$FILE_PROCESSOR EXPAND=FALSE

{   Use constants in this deck with amp$open.
{   Use constants in deck fsc$file_processor with fsp$open_file.

  CONST
    amc$unknown_processor = 'UNKNOWN',
    amc$apl = 'APL',
    amc$basic = 'BASIC',
    amc$cobol = 'COBOL',
    amc$cybil = 'CYBIL',
    amc$debugger = 'DEBUGGER',
    amc$fortran = 'FORTRAN',
    amc$pascal = 'PASCAL',
    amc$pli = 'PLI',
    amc$scl = 'SCL',
    amc$scu = 'SCU',
    amc$assembler = 'ASSEMBLER',
    amc$ppu_assembler = 'PPU_ASSEMBLER';

*copyc amt$file_processor
*DECK DECK=AMD$FILE_STRUCTURE EXPAND=FALSE

  CONST

{   Use the following constants with amp$open and other interfaces that
{   externalize a separate file_structure attribute.  Use the constants in
{   deck fsc$file_contents with fsp$open_file and other interfaces that
{   externalize the file_contents attribute and do not externalize
{   file_structure.

    amc$unknown_structure = 'UNKNOWN',
    amc$data = 'DATA',
    amc$library = 'LIBRARY',
    amc$form = 'FORM';

  TYPE
    amt$file_structure = ost$name;

*copyc ost$name
*DECK DECK=AMD$INFORMATION EXPAND=FALSE

*copyc amc$max_vol_number
*copyc amd$skip_declarations
*copyc amt$error_count
*copyc amt$file_byte_address
*copyc amt$last_op_status
*copyc amt$residual_skip_count
*copyc amt$volume_number
*DECK DECK=AMD$MAX_BLOCKS_PER_FILE EXPAND=FALSE
 CONST
    amc$max_blocks_per_file = amc$file_byte_limit DIV amc$mau_length;

*copyc amt$file_byte_address
*copyc amt$mau_length
*DECK DECK=AMD$OPEN_DECLARATIONS EXPAND=FALSE
 TYPE
    amt$file_access_selections = ^array [1 .. * ] of amt$access_selection,

    amt$access_selection = amt$file_item;

*copyc amt$file_attributes
*copyc amt$access_level
*DECK DECK=AMD$OPERATION_DECLARATIONS EXPAND=FALSE
 CONST
{}
{ Codes 1..100 are reserved for operations which are not passed}
{ to file_access_procedures.}
{}
    amc$access_method_req = 1,
    amc$add_to_file_description_req = 3,
    amc$allocate_req = 5,
    amc$change_file_attributes_cmd = 6,
    amc$compare_file_cmd = 7,
    amc$copy_file_cmd = 8,
    amc$copy_file_req = 9,
    amc$copy_partitions_req = 10,
    amc$copy_records_req = 11,
    amc$copy_partial_records_req = 12,
    amc$detach_file_cmd = 17,
    amc$display_file_attributes_cmd = 18,
    amc$display_file_cmd = 19,
    amc$evict_req = 20,
    amc$fetch_fap_pointer_req = 22,
    amc$file_req = 24,
    fmc$store_tape_label_attr_req = 26,
    fmc$fetch_tape_label_attr_req = 27,
    fmc$display_tape_label_attr_cmd = 28,
    fmc$change_tape_label_attr_cmd = 29,
    amc$get_file_attributes_req = 30,
    amc$label_req = 50,
    amc$override_file_attributes = 60,
    amc$rename_req = 72,
    amc$return_req = 74,
    amc$rewind_files_cmd = 75,
    amc$set_local_name_abnormal_req = 76,
    amc$set_file_attributes_cmd = 77,
    amc$set_file_inst_abnormal_req = 78,
    amc$skip_tape_marks_cmd = 81,
    amc$skip_tape_marks_req = 82,
    amc$store_fap_pointer_req = 84,
    fsc$create_file_req = 94,
    amc$validate_caller_privilege = 95,
    fsc$copy_file_req = 96,
    fsc$get_file_attributes_req = 97,
    fsc$get_file_information_req = 98,
    fsc$get_open_attributes_req = 99,
    fsc$get_open_information_req = 100,
{}
{ Codes amc$fap_op_start..(amc$last_access_start-1) are reserved for}
{ operations which are passed to file_access_procedures but which are not}
{ recorded in last_access_operation status.}
{}
    amc$fap_op_start = 101,
    amc$fetch_access_information_rq = 101,
{}
{ Codes amc$last_access_start..amc$max_operation are reserved for operations}
{ which are passed to file_access_procedures.}
{}
    amc$last_access_start = 105,
    amc$abandon_key_definitions = 110,
    amc$abort_file_parcel = 111,
    amc$apply_key_definitions = 112,
    amc$begin_file_parcel = 113,
    amc$check_buffer_req = 114,
    amc$check_nowait_request = 115,
    amc$check_record_req = 116,
    amc$close_req = 117,
    amc$close_volume_req = 118,
    amc$commit_file_parcel = 119,
    amc$create_key_definition = 120,
    amc$create_nested_file = 121,
    amc$delete_direct_req = 122,
    amc$delete_key_definition = 123,
    amc$delete_key_req = 124,
    amc$delete_nested_file = 125,
    amc$delete_req = 126,
    amc$erase_tape_block = 127,
    amc$fetch_req = 128,  { not returned as a last_access_operation }
    amc$find_record_space = 129,
    amc$flush_req = 130,
    amc$get_direct_req = 131,
    amc$get_key_definitions = 132,
    amc$get_key_req = 133,
    amc$get_label_req = 134,
    amc$get_lock_keyed_record = 135,
    amc$get_lock_next_keyed_record = 136,
    amc$get_nested_file_definitions = 137,
    amc$get_next_key_req = 138,
    amc$get_next_primary_key_list = 139,
    amc$get_next_req = 140,
    amc$get_partial_req = 141,
    amc$get_primary_key_count = 142,
    amc$get_segment_pointer_req = 143,
    amc$get_space_used_for_key = 144,
    amc$lock_file = 146,
    amc$lock_file_req = 146,
    amc$lock_key = 147,
    amc$open_req = 148,
    amc$pack_block_req = 149,
    amc$pack_record_req = 150,
    amc$put_direct_req = 151,
    amc$put_key_req = 152,
    amc$put_label_req = 153,
    amc$put_next_req = 154,
    amc$put_partial_req = 155,
    amc$putrep_req = 156,
    amc$read_direct_req = 157,
    amc$read_direct_skip_req = 158,
    amc$read_req = 159,
    amc$read_skip_req = 160,
    amc$replace_direct_req = 161,
    amc$replace_key_req = 162,
    amc$replace_req = 163,
    amc$rewind_req = 164,
    amc$rewind_volume_req = 165,
    amc$seek_direct_req = 166,
    amc$select_key = 167,
    amc$select_nested_file = 168,
    amc$separate_key_groups = 169,
    amc$set_segment_eoi_req = 170,
    amc$set_segment_position_req = 171,
    amc$skip_req = 172,
    amc$start_req = 173,
    amc$store_req = 174,
    amc$unlock_file = 176,
    amc$unlock_file_req = 176,
    amc$unlock_key = 177,
    amc$unpack_block_req = 178,
    amc$unpack_record_req = 179,
    amc$user_defined_access_request = 180,
    amc$write_direct_req = 181,
    amc$write_end_partition_req = 182,
    amc$write_req = 183,
    amc$write_tape_mark_req = 184,
    ifc$fetch_terminal_req = 185,
    ifc$store_terminal_req = 186,

{}
    nac$se_send_data_req = 187,
    nac$se_receive_data_req = 188,
    nac$se_interrupt_req = 189,
    nac$se_synchronize_req = 190,
    nac$se_synchronize_confirm_req = 191,
    nac$await_data_available = 192,
    nac$fetch_attributes = 193,
    nac$store_attributes = 194,
    nac$se_get_avail_byte_count_req = 195,
{}
    amc$fetch_nested_file_attrib = 196,
{}
    amc$open_tape_volume = 197,
    amc$read_tape_labels = 198,
    amc$terminate_tape_volume = 199,
    amc$write_tape_labels = 200,
    amc$enforce_tape_security = 202,
    amc$dismount_current_volume = 203,
    amc$extend_volume_list = 204,
{}
    amc$max_operation = 511;

*copyc amt$fap_operation
*copyc amt$last_access_operation
*copyc amt$last_operation
*DECK DECK=AMD$PAGE_FORMAT_DECLARATIONS EXPAND=FALSE
*copyc amt$page_format
*copyc amt$page_length
*copyc amt$page_width
*DECK DECK=AMD$SKIP_DECLARATIONS EXPAND=FALSE

*copyc amt$skip_count
*copyc amt$skip_direction
*copyc amt$skip_unit
*copyc amt$tape_mark_count
*DECK DECK=AME$ACCESS_VALIDATION_ERRORS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVACC : Access validation      : ''AM'' 5 .. 9', EJECT ??

?? FMT (FORMAT := OFF) ??
   { ame$access_validation_errors }

   CONST
     amc$min_ecc_access_validation   = amc$min_ecc_validation + 5,

     ame$improper_access_attempt     = amc$min_ecc_access_validation + 0,
         {E File +F1 : +P2 requires open with +P8 access.}

     ame$null_set_specified          = amc$min_ecc_access_validation + 1,
         {E File +F1 : Null set +P8 value of +P2 improper.}

     ame$improper_segment_access     = amc$min_ecc_access_validation + 2,
         {E File +F1 : Attempt to access segment with access not..
         { granted - +P2.}

     ame$file_server_terminated      = amc$min_ecc_access_validation + 3,
         {E File +F1 : Access to segment located on terminated..
         { file_server was not granted - +P2.}

     amc$max_ecc_access_validation   = amc$min_ecc_access_validation + 4;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$ALLOCATE_PROGRAM_ACTIONS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'amp$allocate actions    : ''AM'' 1350 .. 1369', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$allocate_program_actions }

   CONST
     amc$min_ecc_allocate_actions    = amc$min_ecc_program_action + 350,

     ame$amount_exceeds_val_limit    = amc$min_ecc_allocate_actions + 5,
         {E File +F1 : AMOUNT parameter of +P2 exceeds member validation..
         { limit on amount of new space.}

     ame$amount_exceeds_file_limit   = amc$min_ecc_allocate_actions + 10,
         {E File +F1 : AMOUNT parameter of +P2 exceeds file limit.}

     amc$max_ecc_allocate_actions    = amc$min_ecc_allocate_actions + 19;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$ALLOCATE_VALIDATION_ERRORS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVALC :amp$allocate validation : ''AM'' 880 .. 899', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$allocate_validation_errors }

   CONST
     amc$min_ecc_alloc_validation   = amc$min_ecc_validation + 880,

     ame$allocate_mode_param_error  = amc$min_ecc_alloc_validation + 5,
         {E File +F1 : MODE parameter of +P2 improper.}

     ame$allocate_amount_error      = amc$min_ecc_alloc_validation + 10,
         {E File +F1 : AMOUNT parameter of +P2 improper.}

     amc$max_ecc_alloc_validation   = amc$min_ecc_alloc_validation + 19;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$ATTRIBUTE_VALIDATION_ERRORS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVFAT :File_attribute Valid    : ''AM'' 60 .. 89', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$attrib_validation_errors }

   CONST
     amc$min_ecc_attrib_validation   = amc$min_ecc_validation + 60,

     ame$improper_file_attrib_key    = amc$min_ecc_attrib_validation + 5,
         {E File +F1 : +P8 parameter of +P2 had improper KEY(S) in..
         {  array element(s): +P9.}

     ame$improper_file_attrib_value  = amc$min_ecc_attrib_validation + 10,
         {E File +F1 : +P8 parameter of +P2 had improper value(s) for ..
         { the following: +P9.}

     ame$not_open_new                = amc$min_ecc_attrib_validation + 15,
         {E File +F1 : +P2 may only be issued during open of a new file.}

     ame$attrib_already_defined      = amc$min_ecc_attrib_validation + 20,
         {E File +F1 : FILE ATTRIBUTES parameter of +P2 attempted..
         { to redefine value of following attribute(s): +P8.}

     ame$not_old_file                = amc$min_ecc_attrib_validation + 21,
         {E +P2: File +F1 must be opened previous to this request.}

     ame$improper_share_selection    = amc$min_ecc_attrib_validation + 22,
         {E +P2:  File +F1 must be attached with..
         { SHARE value of none.}

     ame$improper_new_attrib_value   = amc$min_ecc_attrib_validation + 23,
         {E +P2: New value of +P8 must exceed..
         { preserved value for file +F1.}

     ame$improper_override_attempt   = amc$min_ecc_attrib_validation + 24,
         {E File +F1 : The following file attributes cannot be..
         { overridden using +P2: +P8.}

     ame$damaged_file_attributes     = amc$min_ecc_attrib_validation + 25,
         {E Missing or damaged file attributes. +P1 +E +P2}

     ame$incompatible_attributes     = amc$min_ecc_attrib_validation + 26,
         {E File +F1 : Level +P2 file attributes not +P3 compatible.}

     amc$max_ecc_attrib_validation   = amc$min_ecc_attrib_validation + 29;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$CONDITION_CODES EXPAND=FALSE
?? NEWTITLE := 'AMDECC  : Basic Access Method' ??
*IF $true(osv$unix)
*copyc amc$ecc_range
*copyc ame$file_not_known
*copyc ame$improper_access_level
*copyc ame$improper_file_attrib_key
*copyc ame$improper_file_attrib_value
*copyc ame$improper_file_id
*copyc ame$no_permission_for_access
*copyc ame$input_after_eoi
*copyc ame$improper_wsl_value
*copyc ame$improper_wsa_value
*copyc ame$improper_skip_option
*copyc ame$improper_skip_count
*copyc ame$improper_skip_direction
*copyc ame$improper_skip_unit
*copyc ame$skip_encountered_eoi
*copyc ame$improper_whence_value
*ELSE
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$ACCESS_VALIDATION_ERRORS
*copyc AME$EVICT_VALIDATION_ERRORS
*copyc AME$IMPROPER_RANDOM_ACCESS
*copyc AME$ATTRIBUTE_VALIDATION_ERRORS
*copyc AME$OPEN_VALIDATION_ERRORS
*copyc AME$LABEL_VALIDATION_ERRORS
*copyc AME$DEVICE_CLASS_VALIDATION
*copyc AME$IMPROPER_FILE_ID
*copyc AME$IMPROPER_WSL
*copyc AME$IMPROPER_ACCESS_INFO_KEY
*copyc AME$UNIMPLEMENTED_REQUEST
*copyc AME$CONFLICTING_ACCESS_LEVEL
*copyc AME$GET_VALIDATION_ERRORS
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AME$SKIP_VALIDATION_ERRORS
*copyc AME$WRITE_EOP_VALIDATION_ERRORS
*copyc AME$WTMK_VALIDATION_ERRORS
*copyc AME$SEGMENT_VALIDATION_ERRORS
*copyc AME$FILE_ORGANIZATION_ERRORS
*copyc AME$ALLOCATE_VALIDATION_ERRORS
*copyc AME$TERMINAL_VALIDATION_ERRORS
*copyc AME$FAP_VALIDATION_ERRORS
*copyc AME$EVICT_PROGRAM_ACTIONS
*copyc AME$LFN_PROGRAM_ACTIONS
*copyc AME$RENAME_PROGRAM_ACTIONS
*copyc AME$GET_PROGRAM_ACTIONS
*copyc AME$PUT_PROGRAM_ACTIONS
*copyc AME$SKIP_PROGRAM_ACTIONS
*copyc AME$ALLOCATE_PROGRAM_ACTIONS
*copyc AME$FAP_PROGRAM_ACTIONS
*copyc AME$TAPE_PROGRAM_ACTIONS
*IFEND
?? OLDTITLE ??
*DECK DECK=AME$CONFLICTING_ACCESS_LEVEL EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVCAL :Access_level validation : ''AM'' 440 .. 449', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$conflicting_access_level }

   CONST
     amc$min_ecc_acc_lvl_validation  = amc$min_ecc_validation + 440,

     ame$conflicting_access_level    = amc$min_ecc_acc_lvl_validation + 5,
         {E File +F1 : +P2 issued but opened for +P3 access.}

     amc$max_ecc_acc_lvl_validation  = amc$min_ecc_acc_lvl_validation + 9;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$COPY_VALIDATION_ERRORS EXPAND=FALSE
{ AME$COPY_VALIDATION_ERRORS is actually only a set of conversion
{ constants for those routines that call amp$copy_file.
   CONST
     ame$input_file_at_eoi           = fse$input_file_at_eoi,
     ame$conflicting_file_structures = fse$conflicting_file_contents,
     ame$conflicting_file_contents   = fse$conflicting_file_contents,
     ame$statement_idents_unequal    = fse$statement_idents_unequal,
     ame$line_numbers_unequal        = fse$line_numbers_unequal,
     ame$fap_names_not_identical     = fse$fap_names_not_identical,
     ame$conflicting_file_addresses  = fse$conflicting_file_addresses,
     ame$improper_fo_for_copy        = fse$improper_fo_for_copy,
     ame$copy_device_conflict        = fse$copy_device_conflict,
     ame$conflicting_block_types     = fse$conflicting_block_types,
     ame$conflicting_record_types    = fse$conflicting_record_types;

*copyc fse$copy_validation_errors
*DECK DECK=AME$DEVICE_CLASS_VALIDATION EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVDEV :Device_class validation : ''AM'' 390 .. 399', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$device_class_validation ]

   CONST
     amc$min_ecc_device_validation   = amc$min_ecc_validation + 390,

     ame$improper_device_class       = amc$min_ecc_device_validation    + 5,
         {E File +F1 : +P2 improper with +P8 device class.}

     amc$max_ecc_device_validation   = amc$min_ecc_device_validation    + 9;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$EVICT_PROGRAM_ACTIONS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'amp$evict actions       : ''AM'' 1000 .. 1009', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$evict_program_actions }

   CONST
     amc$min_ecc_evict_actions       = amc$min_ecc_program_action + 0,

     ame$improper_eoi_redefine       = amc$min_ecc_evict_actions + 5,
         {E File +F1 : BYTE ADDRESS parameter of +P2 exceeds end of..
         { information.}

     amc$max_ecc_evict_actions       = amc$min_ecc_evict_actions + 9;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$EVICT_VALIDATION_ERRORS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVEVC :amp$evict validation    : ''AM'' 10 .. 29', EJECT ??

?? FMT (FORMAT := OFF) ??

   { ame$evict_validation_errors }

   CONST
     amc$min_ecc_evict_validation    = amc$min_ecc_validation + 10,

     ame$evict_without_shorten       = amc$min_ecc_evict_validation + 5,
         {E File +F1 : +P2 requires SHORTEN permission.}

     ame$evict_mode_param_error      = amc$min_ecc_evict_validation + 10,
         {E File +F1 : MODE parameter of +P2 was improper.}

     amc$max_ecc_evict_validation    = amc$min_ecc_evict_validation + 19;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$FAP_PROGRAM_ACTIONS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'File_access_procedure   : ''AM'' 1900 .. 1999', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$fap_program_actions }

   CONST
     amc$min_ecc_fap_actions         = amc$min_ecc_program_action + 900,

     ame$nil_structure_pointer       = amc$min_ecc_fap_actions + 5,
         {E File +F1 : NIL STRUCTURE POINTER returned by +P2.}

     amc$max_ecc_fap_actions         = amc$min_ecc_fap_actions + 99;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$FAP_VALIDATION_ERRORS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVFAP :File_access_procedure   : ''AM'' 910 .. 999', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$fap_validation_errors }

   CONST
     amc$min_ecc_fap_validation      = amc$min_ecc_validation + 910,

     ame$improper_fap_operation      = amc$min_ecc_fap_validation + 5,
         {E File +F1 : CALL_BLOCK parameter from file access..
         { procedure had improper OPERATION specification.}

     ame$redundant_structure_pointer = amc$min_ecc_fap_validation + 10,
         {E File +F1 : Redundant +P2 request issued by file access..
         { procedure.}

     ame$improper_layer_number       = amc$min_ecc_fap_validation + 15,
         {E File +F1 : Layer number parameter of +P2 improper.}

     amc$max_ecc_fap_validation      = amc$min_ecc_fap_validation + 89;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$FILE_ORGANIZATION_ERRORS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVFO  :File_organization valid : ''AM'' 870 .. 879', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$file_organization_errors }

   CONST
     amc$min_ecc_fo_validation       = amc$min_ecc_validation + 870,

     ame$file_organization_conflict  = amc$min_ecc_fo_validation + 5,
         {E File +F1 : +P2 is not a +P4 access request.}

     ame$seek_beyond_eoi_fo_conflict = amc$min_ecc_fo_validation + 7,
         {E File +F1 : +P2 beyond EOI requires byte_addressable ..
         {file_organization.}

     amc$max_ecc_fo_validation       = amc$min_ecc_fo_validation + 9;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$GET_PROGRAM_ACTIONS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'GET  requests - actions : ''AM'' 1040 .. 1139', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$get_program_actions }

   CONST
     amc$min_ecc_get_actions         = amc$min_ecc_program_action + 40,

     ame$input_after_eoi             = amc$min_ecc_get_actions + 5,
         {E File +F1 : +P2 attempted at or beyond end of information.}

     ame$unrecovered_read_error      = amc$min_ecc_get_actions + 10,
         {E File +F1 : +P2 terminated due to unrecovered device error.  +P8}

     ame$accept_bad_block            = amc$min_ecc_get_actions + 15,
         {E File +F1 : Data moved to working storage area taken from..
         { block subject to unrecovered device error.  +P8}

     ame$input_block_exceeds_maxbl   = amc$min_ecc_get_actions + 20,
         {E File +F1 : +P6 block on file exceeds max block length of +P8.}

     ame$record_hdr_validation_error = amc$min_ecc_get_actions + 25,
         {E File +F1 : +P2 terminated, unable to validate a record header. +P8}

     ame$block_hdr_validation_error = amc$min_ecc_get_actions + 30,
         {E File +F1 : +P2 terminated, unable to validate a block header.  +P8}

     amc$max_ecc_get_actions     = amc$min_ecc_get_actions + 99;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??


*DECK DECK=AME$GET_VALIDATION_ERRORS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVGET :GET validation          : ''AM'' 450 .. 549', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$get_validation_errors }

   CONST
     amc$min_ecc_get_validation      = amc$min_ecc_validation + 450,

     ame$improper_input_attempt      = amc$min_ecc_get_validation + 5,
         {E File +F1 : +P2 issued but not opened for input.}

     ame$input_after_output          = amc$min_ecc_get_validation + 10,
         {E File +F1 : +P2 attempted after output on +P4 file.}

     ame$improper_skip_option        = amc$min_ecc_get_validation + 15,
         {E File +F1 : SKIP OPTION parameter of +P2 improper.}

     ame$improper_record_address     = amc$min_ecc_get_validation + 20,
         {E File +F1 : BYTE ADDRESS parameter of +P2 not..
         { start of +P5 record.}

     ame$improper_record_header      = amc$min_ecc_get_validation + 25,
         {E File +F1 : +P2 issued but current byte address is not..
         { start of a +P5 record header.}

     amc$max_ecc_get_validation      = amc$min_ecc_get_validation + 99;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$IMPROPER_ACCESS_INFO_KEY EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVFAI :amp$fetch_access_info   : ''AM'' 420 .. 429', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$improper_access_info_key }

   CONST
     amc$min_ecc_info_key_validation = amc$min_ecc_validation + 420,

     ame$improper_access_info_key      = amc$min_ecc_info_key_validation + 5,
         {E File +F1 : ACCESS_INFORMATION parameter of +P2..
         { had improper KEY(S) in array element(s): +P8.}
     amc$max_ecc_info_key_validation = amc$min_ecc_info_key_validation + 9;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$IMPROPER_FILE_ID EXPAND=FALSE
*IF NOT $true(osv$unix)
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVFID :File_identifier valid   : ''AM'' 400 .. 409', EJECT ??
*ELSE
*copyc amc$ecc_range
*IFEND

?? FMT (FORMAT := OFF) ??

     { ame$improper_file_id }

   CONST
*IF NOT $true(osv$unix)
     amc$min_ecc_fid_validation      = amc$min_ecc_validation + 400,

     ame$improper_file_id            = amc$min_ecc_fid_validation + 5,
         {E  +P1 issued but file_identifier parameter value is..
         { improper.}

     amc$max_ecc_fid_validation      = amc$min_ecc_fid_validation + 9;
*ELSE

     ame$improper_file_id            = amc$min_ecc + 1;
     {E  +P1 issued but file_identifier parameter value is..
     { improper.}

*IFEND
?? FMT (FORMAT := ON) ??
*IF NOT $true(osv$unix)
?? OLDTITLE ??
*IFEND
*DECK DECK=AME$IMPROPER_RANDOM_ACCESS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVFBA : File_byte_address Valid: ''AM'' 30 .. 39', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$improper_random_access }

   CONST
     amc$min_ecc_ba_validation       = amc$min_ecc_validation + 30,

     ame$improper_file_byte_address  = amc$min_ecc_ba_validation + 5,
         {E File +F1 : FILE BYTE ADDRESS parameter of +P2..
         { exceeded 2,147,483,647 (2**31 - 1).}

     amc$max_ecc_ba_validation      = amc$min_ecc_ba_validation + 9;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$IMPROPER_WSL EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'Working_storage_length validation: ''AM'' 410 .. 419', EJECT ??
?? FMT (FORMAT := OFF) ??

     { ame$improper_wsl }

   CONST
     amc$min_ecc_wsl_validation      = amc$min_ecc_validation + 410,

     ame$improper_wsl_value          = amc$min_ecc_wsl_validation + 5,
         {E File +F1 : Working_storage_length parameter of +P2 had..
         { improper value specified.}

     amc$max_ecc_wsl_validation      = amc$min_ecc_wsl_validation + 9;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$LABEL_VALIDATION_ERRORS EXPAND=FALSE
*copyc amc$condition_code_limits
?? NEWTITLE := 'AME$LABEL_VALIDATION_ERRORS : ANSI: ''AM'' 350.. 389', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$label_validation_errors }

   CONST
     amc$min_ecc_label_validation     = amc$min_ecc_validation + 350,

     ame$ansi_file_unexpired        = amc$min_ecc_label_validation + 1,
         {F File +F1 : The ANSI file whose labels you attempted to rewrite ..
         {has not yet expired.  Either you must wait for the file to  ..
         {expire, or you must initialize the volume: ..
         {(EXTERNAL_VSN= +P2, RECORDED_VSN= +P3).}

     ame$blank_volume_read           = amc$min_ecc_label_validation + 3,
         {F File +F1 : The volume (RECORDED_VSN=+P2) is a blank labeled ..
         {(i.e. empty) volume.

     ame$hdr1_label_missing          = amc$min_ecc_label_validation + 4,
         {E The +P1 parameter was specified but a HDR1 label is missing from ..
         {the blank label group to be used for volume initialization.

     ame$hdr2_label_missing         = amc$min_ecc_label_validation + 5,
         {E If a volume is being written by NOS/VE, a HDR2 label is required ..
         {in the blank label group to be used for volume initialization.

     ame$ignored_file_accessibility  = amc$min_ecc_label_validation + 6,
         {W File +F1 : The value that was specified for the FILE_ACCESSIBILITY ..
         {field was ignored when labels were rewritten at the beginning of the ..
         {file set.  To change the existing FILE_ACCESSIBILITY, you must first ..
         {initialize the volumes in the file set.}

     ame$ignored_owner_identifier    = amc$min_ecc_label_validation + 7,
         {W File +F1 : The value that was specified for the OWNER_IDENTIFIER ..
         {field was ignored when labels were rewritten at the beginning of the ..
         {file set.  If the existing OWNER_IDENTIFIER is <> SPACE, you must ..
         {first initialize the volumes in the file set to change this field.}

     ame$ignored_rmg                 = amc$min_ecc_label_validation + 8,
         {W File +F1 : The value that was specified for the REMOVABLE_MEDIA_GROUP ..
         {field was ignored when labels were rewritten at the beginning of the ..
         {file set.  If the existing REMOVABLE_MEDIA_GROUP is <> SPACE, you must ..
         {first initialize the volumes in the file set to change this field.}

     ame$ignored_vol_accessibility   = amc$min_ecc_label_validation + 9,
         {W File +F1 : The value that was specified for the VOLUME_ACCESSIBILITY ..
         {field was ignored when labels were rewritten at the beginning of the ..
         {file set.  If the existing VOLUME_ACCESSIBILITY is <> SPACE, you must ..
         {first initialize the volumes in the file set to change this field.}

     ame$improper_block_count        = amc$min_ecc_label_validation + 10,
         {W File +F1 : +P2 field - of an ANSI +P3 label contains ..
         {an improper value: '+P4'.+NThe field has been set to '+P5'.}

     ame$improper_label_field        = amc$min_ecc_label_validation + 11,
         {W File +F1 : +P2 field - of an ANSI +P3 label contains ..
         {an improper value: '+P4'.+NThe field has been set to SPACE.}

     ame$improper_security_change    = amc$min_ecc_label_validation + 12,
         {F File +F1 : Once the FILE_ACCESSIBILITY, OWNER_IDENTIFIER,..
         {and VOLUME_ACCESSIBILITY fields are set to a value other than ..
         {SPACE, this value cannot be changed.+NIt is first necessary ..
         {to initialize the volume: (EXTERNAL_VSN= +P2, RECORDED_VSN= +P3).}

     ame$initial_volume_unexpired    = amc$min_ecc_label_validation + 13,
         {F File +F1 : The volume (EXTERNAL_VSN= +P2, RECORDED_VSN= +P3) is ..
         {unexpired and does not belong to this file set because its ..
         {FILE_SECTION_NUMBER and FILE_SEQUENCE_NUMBER are both 1.+N ..
         {This implies that it is the initial volume of another file set.+N ..
         {If you intend to use this volume, it must first be initialized.}

     ame$insufficient_volume_access  = amc$min_ecc_label_validation + 14,
         {F File +F1 : You are either not validated for the required ..
         {REMOVABLE_MEDIA_ACCESS or your validation does not include ..
         {WRITE access to the volume: (EXTERNAL_VSN= +P2, RECORDED_VSN= +P3).}

     ame$invalid_date_field          = amc$min_ecc_label_validation + 15,
         {W File +F1 : The +P2 field - of an ANSI +P3 label contains ..
         {an invalid date field: '+P4'.+NAn invalid +P5 field is set to +P6.}

     ame$invalid_tape_security_call  = amc$min_ecc_label_validation + 16,
         {W File +F1 : Either the tape security call_block was NIL ..
         {or an invalid operation was requested.}

     ame$label_block_count_mismatch =  amc$min_ecc_label_validation + 17,
          {W File +F1 : The block count from the beginning of the ANSI file or ..}
          {file section does not match the block count in the corresponding ..
          {ANSI trailer label. +N..
          {CALCULATED_BLOCK_COUNT = +P2, +P3 BLOCK_COUNT=+P4.}

     ame$label_field_not_numeric     = amc$min_ecc_label_validation + 18,
         {W File +F1 : The +P2 field - of an ANSI +P3 label contains ..
         {a non-numeric value: '+P4'.+NThe field has been set to SPACE.}

     ame$label_not_in_sequence       = amc$min_ecc_label_validation + 19,
         {W File +F1 : The sought ANSI +P2 label was not found in the label ..
         {sequence.}

     ame$log_ansi1_label             = amc$min_ecc_label_validation + 20,
         {I File: +F1 - ANSI Label Encountered:+N..
         {+X12FILE_IDENTIFIER--FSETI-FSECFSEQGN--GVCDATE-EDATE-..
         {ABLKCNTIMPLEMENT_ID-RESERVD+N..
         {LABEL = +P2}

     ame$log_ansi2_label             = amc$min_ecc_label_validation + 21,
         {I File: +F1 - ANSI Label Encountered:+N..
         {+X12RMAXBLMAXRLBTRBEXREXPSC-----RESERVED-TO-VE----OL..
         {------RESERVED TO ANSI-----+N..
         {LABEL = +P2}

     ame$log_ansix_label             = amc$min_ecc_label_validation + 22,
         {I File: +F1 - ANSI Label Encountered:+N..
         {LABEL = +P2}

     ame$log_eof_block_count         = amc$min_ecc_label_validation + 23,
         {I End of File (EOF) +P1 for file +F2:+N..
         {FILE_SEQUENCE_NUMBER=+P3, FILE_SECTION_NUMBER=+P4, BLOCK_COUNT=+P5}

     ame$log_eov_block_count         = amc$min_ecc_label_validation + 24,
         {I End of Volume (EOV) +P1 for file +F2:+N..
         {FILE_SEQUENCE_NUMBER=+P3, FILE_SECTION_NUMBER=+P4, BLOCK_COUNT=+P5}

     ame$log_error_block             = amc$min_ecc_label_validation + 25,
         {I File: +F1+N..
         {While reading an ANSI label group, a block was read with error:..
         {+N+P2}

     ame$log_non_label_block         = amc$min_ecc_label_validation + 26,
         {I File: +F1+N..
         {While reading an ANSI label group, a non-label block was read:..
         {+N+P2}

     ame$log_vol1_label              = amc$min_ecc_label_validation + 27,
         {I File: +F1 - ANSI Label Encountered:+N..
         {+X12VOL_IDA--RESERVED---IMPLEMENT_ID-OWNER_ID------RES..
         {ERVED--------------------V+N..
         {LABEL = +P2}

     ame$no_removable_media_access   = amc$min_ecc_label_validation + 28,
         {F File +F1 : You either are not validated for the specified ..
         {REMOVABLE_MEDIA_GROUP or the REMOVABLE_MEDIA_ACCESS validation ..
         {denies access.}

     ame$not_initial_volume_of_set   = amc$min_ecc_label_validation + 29,
         {W File: +F1+N..
         {The volume, +P2, is not the first volume of the volume set.+N..
         {The FILE_IDENTIFIER of the initial file on this volume is: +P3.+N..
         {The FILE_SECTION_NUMBER of the initial file on this volume is: +P4.+N..
         {The FILE_SEQUENCE_NUMBER of the initial file on this volume is: +P5.}

     ame$rma_privilege_required      = amc$min_ecc_label_validation + 30,
         {F File +F1 : Execution under the SYSTEM_OPERATOR_UTILITY with ..
         {REMOVABLE_MEDIA_ADMINISTRATION capability active is required ..
         {to access a volume using a file_label_type of non_standard_labeled.}

     ame$rmo_privilege_required      = amc$min_ecc_label_validation + 31,
         {F Execution within the SYSTEM_OPERATOR_UTILITY with ..
         {REMOVABLE_MEDIA_OPERATION capability active is required ..
         {to initialize a volume.}

     ame$unlabeled_privilege_needed  = amc$min_ecc_label_validation + 32,
         {F File +F1 : Either execution within the SYSTEM_OPERATOR_UTILITY with ..
         {REMOVABLE_MEDIA_ADMINISTRATION capability active or a validation ..
         {for UNLABELED_TAPES is required to access a volume using a ..
         {file_label_type of unlabeled.}

     ame$vol1_label_missing          = amc$min_ecc_label_validation + 33,
         {E A VOL1 label is missing from the blank label group to be used for ..
         {volume initialization.

     ame$volume_access_restricted    = amc$min_ecc_label_validation + 34,
         {F File +F1 : The volume, +P2, is damaged.  Access to the volume is ..
         {provided only to a Removable Media Administrator (RMA).  An RMA may ..
         {only request the volume using a FILE_LABEL_TYPE of UNLABELED or  ..
         {NON_STANDARD_LABELED.}

     ame$volume_security_conflict    = amc$min_ecc_label_validation + 35,
         {F File +F1 : The volume (EXTERNAL_VSN= +P2, RECORDED_VSN= +P3) has a ..
         {value for the security fields FILE_ACCESSIBILITY, OWNER_IDENTIFIER, ..
         {and/or VOLUME_ACCESSIBILITY that does not match the value in effect ..
         {for the current file set.+NIf you intend to use this volume it must ..
         {first be initialized.

     ame$wrong_file_set_identifier   = amc$min_ecc_label_validation + 36,
         {F File +F1 : The volume, (EXTERNAL_VSN= +P2, RECORDED_VSN= +P3) has ..
         {a FILE_SET_IDENTIFIER, +P4, which does not match the ..
         {FILE_SET_IDENTIFIER, +P5, of the current volume set.

     ame$insufficient_file_access  = amc$min_ecc_label_validation + 37,
         {F File +F1 : You are not authorized to access this ANSI file.

     amc$max_ecc_label_validation    = amc$min_ecc_label_validation + 389;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$LFN_PROGRAM_ACTIONS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'Local_file_name action  : ''AM'' 1010 .. 1019', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$lfn_program_actions }

   CONST
     amc$min_ecc_lfn_actions         = amc$min_ecc_program_action + 10,

     ame$file_not_closed             = amc$min_ecc_lfn_actions + 5,
         {E +P2 was issued but +F1 is open.}

     ame$file_not_known              = amc$min_ecc_lfn_actions + 6,
         {E +P2 was issued for file, +F1, which either does not exist or is ..
         {not attached to the current job.}

     ame$file_known                  = amc$min_ecc_lfn_actions + 7,
         {E File +F1 is already known within the job.}

     ame$attribute_out_of_range      = amc$min_ecc_lfn_actions + 8,
         {E Value out of range for attribute: +P.}

     amc$max_ecc_lfn_actions         = amc$min_ecc_lfn_actions + 9;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$OPEN_VALIDATION_ERRORS EXPAND=FALSE
*copyc amc$condition_code_limits
?? NEWTITLE := 'AMDVOPN :amp$open validation     : ''AM'' 90 .. 299', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$open_validation_errors }

   CONST
     amc$min_ecc_open_validation     = amc$min_ecc_validation + 90,

     ame$attribute_validation_error  = amc$min_ecc_open_validation + 5,
         {E File +F1 : Structural attribute values specified by +P2..
         { do not match the preserved attribute values for the following:..
         { +P8.}

     ame$incompatible_file_connect   = amc$min_ecc_open_validation  + 6,
         {E Cannot connect +F1 and +F8 because of incompatible ..
         {attributes: +P9.}

     ame$local_file_limit            = amc$min_ecc_open_validation + 10,
         {E File +F1 : Limit of +P8 local files exceeded.}

     ame$concurrent_open_limit       = amc$min_ecc_open_validation + 11,
         {E File +F1 : Limit of +P8 concurrent instances of open..
         { of files in the same task was exceeded.  This limit is..
         { enforced by +P9 Management.}

     ame$improper_access_level       = amc$min_ecc_open_validation + 15,
         {E File +F1 : ACCESS LEVEL parameter of +P2 improper.}

     ame$mbl_less_than_mibl          = amc$min_ecc_open_validation + 20,
         {E File +F1 :  Maximum block length must equal or exceed minimum..
         { block length with user specified blocking.}

     ame$mbl_less_than_mrl           = amc$min_ecc_open_validation + 25,
         {E File +F1 : Maximum block length must equal or exceed the ANSI..
         { fixed (F) record length with user specified blocking.}

     ame$no_permission_for_access    = amc$min_ecc_open_validation + 30,
         {E File +F1 : Access mode of +P8 conflicts with file access..
         { permissions.}

     ame$conflicting_file_access     = amc$min_ecc_open_validation + 31,
         {E File +F1 is already open for +P8 access which conflicts..
         { with the specified +P9 access mode.}

     ame$non_ANSI_blocking           = amc$min_ecc_open_validation + 35,
         {E File +F1 : User specified blocking required for ANSI..
         { variable (D) or ANSI spanned (S) records.}

     ame$improper_record_override    = amc$min_ecc_open_validation + 40,
         {E File +F1 : An undefined (U) or ANSI fixed (F) record type..
         { cannot be overridden by variable (V) record type.}

     ame$improper_override_access    = amc$min_ecc_open_validation + 45,
         {E File +F1 : Overriding block type, file organization or record..
         { type is improper with write access.}

     ame$improper_write_override     = amc$min_ecc_open_validation + 50,
         {E File +F1 : Conditions under which file organization..
         { can be overridden with write access were not met.}

     ame$improper_us_block_override  = amc$min_ecc_open_validation + 51,
         {E File +F1 : Overriding user specified blocking with..
         { system specified blocking is improper with variable (V)..
         {  or ANSFI fixed (F) record type.}

     ame$improper_ss_block_override  = amc$min_ecc_open_validation + 52,
         {E File +F1 : Overriding system specified blocking with..
         { user specified blocking is improper.}

     ame$improper_fo_override        = amc$min_ecc_open_validation + 53,
         {E File +F1 : Sequential and byte addressable file organizations..
         { cannot be overridden by indexed sequential file organization.}

     ame$new_file_requires_append    = amc$min_ecc_open_validation + 60,
         {E File +F1 has not been previously opened.+NThe initial open..
         { request for a file must permit file creation.+NThe initial..
         { attachment of a mass storage file that has never been opened..
         { must also include append in the access modes.}

     ame$improper_append_open        = amc$min_ecc_open_validation + 65,
         {E File +F1 : $EOI open position required for append-only..
         { access.}

     ame$fo_access_level_conflict    = amc$min_ecc_open_validation + 75,
         {E File +F1 : Segment access not allowed with +P8..
         { file organization.}

     ame$fo_device_class_conflict    = amc$min_ecc_open_validation + 85,
         {E File +F1 : +P8 file organization not supported on +P9 device..
         { class.}

     ame$fo_record_type_conflict     = amc$min_ecc_open_validation + 88,
         {E File +F1 : +P8 file_organization is not supported for +P9..
         { records. }

     ame$not_virtual_memory_device   = amc$min_ecc_open_validation + 90,
         {E File +F1 : Segment access not allowed on +P8 device class.}

     ame$not_physical_access_device  = amc$min_ecc_open_validation + 95,
         {E File +F1 : Physical access not allowed on +P8 device class.}

     ame$unable_to_load_fap          = amc$min_ecc_open_validation + 105,
         {E File +F1 : Unable to load file access procedure +P8.}

     ame$keyed_file_fap_missing      = amc$min_ecc_open_validation + 107,
         {E File +F1 : A required module for file organization +P8 could..
         { not be loaded because object library $LOCAL.AAF$44D_LIBRARY..
         { is not in the program library list.  Add object library using..
         { SET_PROGRAM_ATTRIBUTES.}

     ame$unable_to_load_collate_tabl = amc$min_ecc_open_validation + 110,
         {E File +F1 : Unable to load collate table named +P8.}

     ame$unable_to_load_error_exit   = amc$min_ecc_open_validation + 115,
         {E File +F1 : Unable to load error exit procedure named +P8.}

     ame$unable_to_load_label_exit   = amc$min_ecc_open_validation + 120,
         {E File +F1 : Unable to load label exit procedure named +P8.}

     ame$terminal_task_limit         = amc$min_ecc_open_validation + 125,
         {E File +F1 : Limit of +P8 tasks sharing an interactive file..
         { exceeded.}

     ame$concurrent_tape_limit       = amc$min_ecc_open_validation + 130,
         {E File +F1 : Limit of +P8 concurrently used +P9 track,..
         { +P10 cpi density tapes exceeded.}

     ame$multiple_open_of_tape       = amc$min_ecc_open_validation + 131,
         {E File +F1 : Multiple instances of open of tape file are..
         { improper.}

     ame$no_write_ring               = amc$min_ecc_open_validation + 132,
         {E File +F1 : An open for write access to a tape file..
         { requires a write-ring in the reel but none was requested.}

     ame$null_access_mode            = amc$min_ecc_open_validation + 135,
         {E File +F1 : Null set is improper access_mode value.}

     ame$rt_block_type_conflict      = amc$min_ecc_open_validation + 140,
         {E File +F1 : +P8 blocking is not supported for..
         { +P9 records. }

     ame$rt_device_class_conflict    = amc$min_ecc_open_validation + 145,
         {E File +F1 : +P8 device_class is not supported for..
         { +P9 records. }

     ame$unsupported_bt_and_rt       = amc$min_ecc_open_validation + 150,
         {E File +F1 : +P8 blocking and +P9 records is not..
         { supported for MAGNETIC TAPE DEVICE. }

     ame$unsupported_ms_bt_and_rt       = amc$min_ecc_open_validation + 151,
         {E File +F1 : +P8 blocking and +P9 records is not..
         { supported for MASS STORAGE DEVICE. }

     amc$max_ecc_open_validation     = amc$min_ecc_open_validation + 299;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$PUT_PROGRAM_ACTIONS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'PUT requests - actions  : ''AM'' 1140 .. 1239', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$put_program_actions }

   CONST
     amc$min_ecc_put_actions         = amc$min_ecc_program_action + 140,

     ame$space_unavailable           = amc$min_ecc_put_actions + 0,
         {E +F1 : No +P2 space available.}

     ame$unrecovered_write_error     = amc$min_ecc_put_actions + 5,
         {E File +F1 : +P2 terminated due to unrecovered device error.  +P8}

     amc$max_ecc_put_actions         = amc$min_ecc_put_actions + 99;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$PUT_VALIDATION_ERRORS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVPUT :PUT validation          : ''AM'' 550 .. 649', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$put_validation_errors }

   CONST
     amc$min_ecc_put_validation      = amc$min_ecc_validation + 550,

     ame$improper_output_attempt     = amc$min_ecc_put_validation + 5,
         {E File +F1 : +P2 issued but not opened for output.

     ame$record_exceeds_mbl        = amc$min_ecc_put_validation + 10,
         {E File +F1 : Length of +P5 record exceeds maximum block length.}

     ame$improper_term_option        = amc$min_ecc_put_validation + 15,
         {E File +F1 : TERM OPTION parameter of +P2 was improper.}

     ame$improper_continue           = amc$min_ecc_put_validation + 20,
         {E File +F1 : TERM OPTION OF +P2 was CONTINUE but file position..
         { was not mid-record.}

     ame$fo_block_type_conflict      = amc$min_ecc_put_validation + 25,
         {E File +F1 : A user-specified blocked file must be created..
         { and appended sequentially.}

     ame$position_beyond_eoi        = amc$min_ecc_put_validation + 30,
         {E File +F1 : +P2 requires append permission to position..
         { beyond eoi.}

     ame$position_beyond_file_limit = amc$min_ecc_put_validation + 35,
         {E File +F1 : Improper attempt to position beyond the file limit..
         { using +P2.}

     ame$put_beyond_file_limit      = amc$min_ecc_put_validation + 40,
         {E File +F1 : Improper attempt to write beyond the file limit..
         { using +P2.}

     ame$file_space_limit_exceeded  = amc$min_ecc_put_validation + 41,
         {E File +F1 : +P2 file space limit has been exceeded.}

     ame$record_unequal_to_previous = amc$min_ecc_put_validation + 45,
         {E File +F1 : Length of +P5 record must be identical to..
         { the length of the record being replaced by +P2.}

     ame$improper_file_position     = amc$min_ecc_put_validation + 50,
         {E File +F1 : File not positioned at the end of a record..
         { prior to +P2 request.}

     ame$improper_seek_address = amc$min_ecc_put_validation + 55,
         {E File +F1 : BYTE_ADDRESS parameter of +P2 must be the address..
         { of a record boundary.}

     amc$max_ecc_put_validation     = amc$min_ecc_put_validation + 99;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$RENAME_PROGRAM_ACTIONS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'amp$rename actions      : ''AM'' 1020 .. 1039', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$rename_program_actions }

   CONST
     amc$min_ecc_rename_actions      = amc$min_ecc_program_action + 20,

     ame$rename_old_not_local        = amc$min_ecc_rename_actions + 5,
         {E +P2 from +P8 to +P9 failed because +P8 is not local.}

     ame$rename_new_is_local         = amc$min_ecc_rename_actions + 10,
         {E +P2 from +P8 to +P9 failed because +P9 is already local.}

     amc$max_ecc_rename_actions      = amc$min_ecc_rename_actions + 19;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$RING_VALIDATION_ERRORS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVRVE : Ring validation        : ''AM'' 0 .. 4', EJECT ??

?? FMT (FORMAT := OFF) ??
   { ame$ring_validation_errors }

   CONST
     amc$min_ecc_ring_validation     = amc$min_ecc_validation + 0,

     ame$ring_validation_error       = amc$min_ecc_ring_validation + 0,
         {E File +F1 : +P2 failed because the user/task has}
         { insufficient ring privilege.}

     amc$max_ecc_ring_validation     = amc$min_ecc_ring_validation + 4;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$SEGMENT_VALIDATION_ERRORS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVSEG :Segment access requests : ''AM'' 770 .. 869', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$segment_validation_errors }

   CONST
     amc$min_ecc_seg_validation      = amc$min_ecc_validation + 770,

     ame$improper_pointer_kind       = amc$min_ecc_seg_validation + 5,
         {E File +F1 : POINTER KIND parameter of +P2 improper.}

     ame$improper_segment_pointer    = amc$min_ecc_seg_validation + 10,
         {E File +F1 : SEGMENT POINTER parameter of +P2 improper.}

     ame$set_pos_beyond_eoi          = amc$min_ecc_seg_validation + 15,
         {E File +F1 : +P2 attempted beyond end of information.}

     ame$set_eoi_needs_append        = amc$min_ecc_seg_validation + 20,
         {E File +F1 : +P2 requires APPEND permission to..
         { increase the end of information byte address.}

     ame$set_eoi_needs_shorten       = amc$min_ecc_seg_validation + 25,
         {E File +F1 : +P2 requires SHORTEN permission to..
         { decrease the end of information byte address.}

     ame$set_on_adaptable_heap       = amc$min_ecc_seg_validation + 30,
         {E File +F1 : +P2 does not accept an adaptable heap pointer.}

     ame$read_of_empty_segment       = amc$min_ecc_seg_validation + 31,
         {E File +F1 : +P2 issued for empty, read-only segment.}

     ame$write_of_empty_segment      = amc$min_ecc_seg_validation + 32,
         {E File +F1 : +P2 issued but empty,writable segment not..
         { opened for append access mode.}

     ame$improper_segment_number     = amc$min_ecc_seg_validation + 40,
         {E File +F1 : Segment number within the SEGMENT POINTER..
         { parameter of +P2 improper.}

     amc$max_ecc_seg_validation      = amc$min_ecc_seg_validation + 99;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$SKIP_PROGRAM_ACTIONS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'amp$skip actions        : ''AM'' 1240 .. 1339', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$skip_program_actions }

   CONST
     amc$min_ecc_skip_actions        = amc$min_ecc_program_action + 240,

     ame$skip_encountered_boi        = amc$min_ecc_skip_actions + 5,
         {E File +F1 : SKIP backward +P8 encountered beginning of..
         { information before COUNT exhausted.}

     ame$skip_encountered_bop        = amc$min_ecc_skip_actions + 10,
         {E File +F1 : SKIP backward records encountered beginning of..
         { partition before COUNT exhausted.}

     ame$skip_encountered_eop        = amc$min_ecc_skip_actions + 15,
         {E File +F1 : SKIP forward records encountered an end of..
         { partition before COUNT exhausted.}

     ame$skip_encountered_eoi        = amc$min_ecc_skip_actions + 20,
         {E File +F1 : SKIP forward +P8 encountered end of information..
         { before COUNT exhausted.}

     ame$skip_encountered_bov        = amc$min_ecc_skip_actions + 25,
         {E File +F1 : SKIP backward by tapemarks encountered beginning-..
         {of-volume.}

     ame$uncertain_tape_position     = amc$min_ecc_skip_actions + 35,
         {E File +F1 : Tape volume position is uncertain after +P2.  +P8}

     amc$max_ecc_skip_actions        = amc$min_ecc_skip_actions + 99;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$SKIP_VALIDATION_ERRORS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVSKP :amp$skip validation     : ''AM'' 650 .. 749', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$skip_validation_errors }

   CONST
     amc$min_ecc_skip_validation     = amc$min_ecc_validation + 650,

     ame$improper_skip_unit          = amc$min_ecc_skip_validation + 5,
         {E File +F1 : UNIT parameter of +P2 improper.}

     ame$improper_skip_direction     = amc$min_ecc_skip_validation + 10,
         {E File +F1 : DIRECTION parameter of +P2 improper.}

     ame$improper_skip_count         = amc$min_ecc_skip_validation + 15,
         {E File +F1 : COUNT parameter of +P2 improper.}

     ame$skip_requires_read_perm     = amc$min_ecc_skip_validation + 20,
         {E File +F1 : +P2 requires READ permission.}

     ame$unsupported_skip            = amc$min_ecc_skip_validation + 25,
         {E File +F1 : SKIP +P8 +P9 for +P5 records..
         { and +P6 blocking not supported.}

     ame$conflicting_fo              = amc$min_ecc_skip_validation + 30,
         {E File +F1 : A SKIP cannot be performed on a file created..
         { with +P4 file organization.}

     amc$max_ecc_skip_validation     = amc$min_ecc_skip_validation + 99;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$STORE_PROGRAM_ACTIONS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'amp$store actions       : ''AM'' 1340 .. 1349', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$store_program_actions }

   CONST
     amc$min_ecc_store_actions       = amc$min_ecc_program_action + 340,

     ame$file_limit_on_pf            = amc$min_ecc_store_actions + 5,
         {E File +F1 : File limit of permanent file cannot be changed.}

     amc$max_ecc_store_actions       = amc$min_ecc_store_actions + 9;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$TAPE_PROGRAM_ACTIONS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'TAPE  requests - actions : ''AM'' 1450 .. 1549', EJECT ??

?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := OFF) ??

     { ame$tape_program_actions }

   CONST
     amc$min_ecc_tape_actions        = amc$min_ecc_program_action + 450,

     ame$cannot_lock_tape_pages      = amc$min_ecc_tape_actions + 1,
         {E File +F1 : The maximum block length for this request is larger..}
         { than the system can handle at this page size.}

     ame$tape_block_mgr_malfunction  = amc$min_ecc_tape_actions + 2,
         {F File +F1 : Internal tape block manager malfunction. +P8.}

     ame$tape_driver_not_capable     = amc$min_ecc_tape_actions + 3,
         {E File +F1 : The maximum block length for this file is larger than..}
         { the maximum size the tape driver can handle in this configuration.}

     ame$tape_rcd_mgr_malfunction    = amc$min_ecc_tape_actions + 4,
         {F File +F1 : Internal tape record manager malfunction. +P8.}

     ame$end_of_tape_op_completed    = amc$min_ecc_tape_actions + 5,
          {E File +F1 : End of tape encountered - operation completed. }

     ame$end_of_tape_op_inhibited    = amc$min_ecc_tape_actions + 6,
          {E File +F1 : End of tape encountered - operation inhibited. }

     ame$tape_end_of_volume_list     = amc$min_ecc_tape_actions + 7,
         {E File +F1 : +P2 encountered end of volume list.}

     ame$maxbl_exceeds_ws_limit      = amc$min_ecc_tape_actions + 8,
         {E File +F1 : +P2 cannot be performed with a MAX_BLOCK_LENGTH ..}
         {within 20 pages of the job working set limit.}

     ame$tape_density_mismatch       = amc$min_ecc_tape_actions + 9,
         {E File +F1 : Recorded density of tape being read is not ..}
         {recognized or supported on the tape unit on which the tape ..}
         {was mounted.}

     ame$cartridge_tape_erase_limit  = amc$min_ecc_tape_actions + 10,
         {E File +F1 : AMP$ERASE_TAPE_BLOCK has attempted to exceed ..}
         {the erase limit on a cartridge tape file.}

     ame$motion_past_phys_eot        = amc$min_ecc_tape_actions + 11,
         {E File +F1 : +P2 has attempted to position past ..}
         {physical end of tape on a cartridge tape file.}

     ame$unknown_volume              = amc$min_ecc_tape_actions + 20,
         {E Either the volume (EXTERNAL_VSN=+P1, RECORDED_VSN=..
         {+P2) does not exist or you are not authorized to ..
         {access it.}

     ame$improper_file_label_type    = amc$min_ecc_tape_actions + 21,
          {E File +F1 : Access to the unlabeled volume (EXTERNAL_VSN=+P8) ..
          { with a file label type of labeled is not allowed.}

     ame$improper_owner_identifier   = amc$min_ecc_tape_actions + 22,
          {E File +F1 : The specified OWNER_IDENTIFIER, +P8, does not match ..
          {the user name of the current job.

     ame$redundant_file_seq_number   = amc$min_ecc_tape_actions + 25,
          {W File +F1 : The parameter FILE_SEQUENCE_NUMBER is ignored ..
          {because the FILE_SEQUENCE_NUMBER field within the ..
          {FILE_SEQUENCE_POSITION record takes precedence.}

     ame$file_seq_number_ignored     = amc$min_ecc_tape_actions + 26,
          {W File +F1 : Parameter FILE_SEQUENCE_NUMBER is ignored when ..}
          {FILE_SET_POSITION <> FILE_SEQUENCE_POSITION.}

     ame$file_identifier_ignored     = amc$min_ecc_tape_actions + 27,
          {W File +F1 : Parameter FILE_IDENTIFIER is ignored because ..}
          {the FILE_IDENTIFIER field within the FILE_IDENTIFIER_POSITION ..}
          {record was specified and REWRITE_LABELS = FALSE.}

     ame$generation_number_ignored   = amc$min_ecc_tape_actions + 28,
          {W File +F1 : Parameter GENERATION_NUMBER is ignored because ..}
          {the GENERATION_NUMBER field within the FILE_IDENTIFIER_POSITION ..}
          {record was specified and REWRITE_LABELS = FALSE.}

     ame$file_identifier_required    = amc$min_ecc_tape_actions + 29,
          {E File +F1 : A FILE_IDENTIFIER must be specified for ..}
          {FILE_SET_POSITION = FILE_IDENTIFIER_POSITION.}

     ame$file_seq_number_required    = amc$min_ecc_tape_actions + 30,
          {E File +F1 : A FILE_SEQUENCE_NUMBER must be specified for ..}
          {FILE_SET_POSITION = FILE_SEQUENCE_POSITION.}

     ame$file_seq_number_illegal     = amc$min_ecc_tape_actions + 31,
          {E File +F1 : TAPE_FILE_SEQUENCE_NUMBER cannot be specified if ..}
          {TAPE_FILE_SET_POSITION.POSITION = FSC$TAPE_FILE_IDENTIFIER_POSITION.}

     ame$file_identifier_mismatch    = amc$min_ecc_tape_actions + 32,
          {E File +F1 : TAPE_FILE_IDENTIFIER, +P, does not match ..}
          {TAPE_FILE_SET_POSITION.FILE_IDENTIFIER, +P.}

     ame$generation_number_mismatch  = amc$min_ecc_tape_actions + 33,
          {E File +F1 : TAPE_GENERATION_NUMBER, +P, does not match ..}
          {TAPE_FILE_SET_POSITION.GENERATION_NUMBER, +P.}

     ame$file_seq_number_mismatch    = amc$min_ecc_tape_actions + 34,
          {E File +F1 : TAPE_FILE_SEQUENCE_NUMBER, +P, does not match ..}
          {TAPE_FILE_SET_POSITION.FILE_SEQUENCE_NUMBER, +P.}

     ame$unsupported_tape_bt_rt      = amc$min_ecc_tape_actions + 35,
          {E File +F1 : +P8 is not supported for ANSI labeled tape files.}

     ame$unimplemented_tape_bt_rt    = amc$min_ecc_tape_actions + 36,
          {E File +F1 : +P8 is not implemented for ANSI labeled tape files.}

     ame$bt_rt_supp_only_for_labeled = amc$min_ecc_tape_actions + 37,
          {E File +F1 : +P8 is supported only for ANSI labeled tape files.}

     ame$label_content_error         = amc$min_ecc_tape_actions + 51,
          {E File +F1 : Invalid tape label contents.}

     ame$label_sequence_error        = amc$min_ecc_tape_actions + 52,
          {E File +F1 : Tape labels out of sequence.}

     ame$accessibility_conflict      = amc$min_ecc_tape_actions + 53,
          {E File +F1 : Access to tape volume +P8 not allowed.}

     ame$file_not_in_volume_set      = amc$min_ecc_tape_actions + 54,
          {E File +F1 : Specified ANSI file not found on the volume set.}

     ame$file_set_id_conflict        = amc$min_ecc_tape_actions + 55,
          {E File +F1 : Specified file set identifier of +P8 conflicts with ..}
          {HDR1 file set identifier of +P9.}

     ame$fsn_and_fi_not_matching     = amc$min_ecc_tape_actions + 56,
          {E File +F1 : File sequence number not consistent with file ..}
          {identifier for the specified ANSI file.}

     ame$fsn_out_of_sequence         = amc$min_ecc_tape_actions + 57,
          {E File +F1 : Specified file sequence number is less than the file ..}
          {sequence number of the first ANSI file on the tape volume.}

     ame$non_ansi_labels             = amc$min_ecc_tape_actions + 58,
          {E File +F1 : Tape label +P8 does not conform to ANSI standard ..}
          {format.}

     ame$section_out_of_sequence     = amc$min_ecc_tape_actions + 59,
          {E File +F1 : Volume (EXTERNAL_VSN=+P2, RECORDED_VSN=+P3) ..
          {was requested out of sequence.+N ..
          {Expected: FILE_SECTION_NUMBER=+P4, FILE_SEQUENCE_NUMBER=+P5 +N ..
          {Found:    FILE_SECTION_NUMBER=+P6, FILE_SEQUENCE_NUMBER=+P7, ..
          {FILE_SET_IDENTIFIER=+P8.}

     ame$improper_labelled_tape_op   = amc$min_ecc_tape_actions + 60,
          {E File +F1 : +P2 operation not allowed on an ANSI labeled tape ..}
          {file.}

     ame$improper_labelled_skip_unit = amc$min_ecc_tape_actions + 61,
          {E File +F1 : +P2 with SKIP_UNIT of TAPEMARKS not allowed on an ..}
          {ANSI labeled tape file.}

     ame$spec_fsn_out_of_seq         = amc$min_ecc_tape_actions + 62,
          {E File +F1 : Specified file sequence number +P8 is greater ..}
          {than that of the last ANSI file on the volume set plus one.  ..}
          {Use file_set_position of end_of_set to append a file to the ..}
          {volume set.}

     ame$skip_encountered_bot        = amc$min_ecc_tape_actions + 63,
          {E File +F1 : SKIP backward encountered beginning of volume but ..}
          {NOT beginning of information.}

     ame$improper_open_position      = amc$min_ecc_tape_actions + 64,
          {E File +F1 : Improper open position for ANSI labeled tape file.}

     ame$3_contiguous_tapemarks      = amc$min_ecc_tape_actions + 65,
          {E File +F1 : +P2 encountered end of set on an ANSI labeled ..}
          {tape file (more than 2 contiguous tapemarks).}

     ame$unimplemented_buffer_offset = amc$min_ecc_tape_actions + 66,
          {E File +F1 : Non zero buffer offset length not implemented for ..}
          {ANSI labeled tape files.}

     ame$rewrite_labels_conflict     = amc$min_ecc_tape_actions + 67,
          {E File +F1 : +P2 operation on a labeled tape file not originally ..
          {written by NOS/VE is only allowed when you specify ..
          {REWRITE_LABELS=TRUE.}

     ame$improper_unlabelled_tape_op   = amc$min_ecc_tape_actions + 68,
          {E File +F1 : +P2 operation not allowed on an unlabeled tape ..}
          {file.}

     ame$file_attachment_required      = amc$min_ecc_tape_actions + 69,
          {E File +F1 : +P2 requires the file to be attached.}
          {+N3 If the file does not exist, use REQUEST_MAGNETIC_TAPE to ..}
          {create the file; otherwise, use attach_file to make it available.}

     ame$labeled_tape_file_required    = amc$min_ecc_tape_actions + 70,
          {E File +F1 : +P2 requires the FILE_LABEL_TYPE = amc$labeled when ..}
          {FSC$TLA_LAST_ANSI_FILE_ACCESSED or FSC$TLA_NEXT_POSITION is the ..}
          {SOURCE option selected.}

     ame$label_sequence_too_small      = amc$min_ecc_tape_actions + 71,
          {E File +F1: The size of the +P8 LABELS sequence provided to +P2 ..}
          {is smaller than the actual size of the label group.

     ame$only_seq_header_returned      = amc$min_ecc_tape_actions + 72,
          {E File +F1: The size of the +P8 LABELS sequence provided to +P2 ..}
          {is smaller than the actual size of the label group.  However, ..}
          {the sequence header was returned and it contains the required ..}
          {sequence size.

     ame$security_conflict             = amc$min_ecc_tape_actions + 73,
          {E File +F1 : The requested attribute, +P8, may only be requested ..}
          {by a user with REMOVABLE_MEDIA_ADMINISTRATION privilege.}

     ame$unexpected_tape_label         = amc$min_ecc_tape_actions + 74,
          {E File +F1 : A +P10 label was encountered at the beginning of ..}
          {a label group when a +P11 label was expected on the volume  ..}
          {(EXTERNAL_VSN=+P8, RECORDED_VSN=+P9).}

     ame$unexpected_tapemark           = amc$min_ecc_tape_actions + 75,
          {E File +F1 : An unexpected tapemark was encountered when ..}
          {attempting to access a label group on the volume ..}
          {(EXTERNAL_VSN=+P8, RECORDED_VSN=+P9).}

     ame$invalid_tape_label            = amc$min_ecc_tape_actions + 76,
          {E File +F1 : An invalid tape label was encountered at the ..}
          {beginning of a label group on the volume ..}
          {(EXTERNAL_VSN=+P8, RECORDED_VSN=+P9).}

     ame$excessive_tape_labels         = amc$min_ecc_tape_actions + 77,
          {E File +F1 : The number of tape labels in a label group on ..}
          {the volume (EXTERNAL_VSN=+P8, RECORDED_VSN=+P9), exceeded ..}
          {the maximum of +P10.  The remaining +P11 labels were discarded.}

     ame$incorrect_tape_position       = amc$min_ecc_tape_actions + 78,
          {E File +F1 : When attempting to access a tape label group on ..}
          {the volume (EXTERNAL_VSN=+P8, RECORDED_VSN=+P9), the volume ..}
          {was incorrectly positioned at +P10.}

     ame$tape_label_read_error         = amc$min_ecc_tape_actions + 79,
          {E File +F1 : An unrecoverable read error occurred at label number ..}
          {+P10 of the current label group on the volume ..}
          {(EXTERNAL_VSN=+P8, RECORDED_VSN=+P9). +P11}

     ame$tape_label_write_error        = amc$min_ecc_tape_actions + 80,
          {E File +F1 : An unrecoverable write error occurred at label number ..}
          {+P10 of the current label group on the volume ..}
          {(EXTERNAL_VSN=+P8, RECORDED_VSN=+P9). +P11}

     ame$invalid_tape_label_sequence   = amc$min_ecc_tape_actions + 81,
          {E File +F1 : An invalid tape label sequence (+P10) was ..}
          {detected when attempting to +P11 labels on the volume ..}
          {(EXTERNAL_VSN=+P8, RECORDED_VSN=+P9).}

     amc$max_ecc_tape_actions        = amc$min_ecc_tape_actions + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$TERMINAL_VALIDATION_ERRORS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVIAF :Interactive validation  : ''AM'' 900 .. 909', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$terminal_validation_errors }

   CONST
     amc$min_ecc_terminal_validation = amc$min_ecc_validation + 900,

     ame$terminal_disconnected       = amc$min_ecc_terminal_validation + 5,
         {E File +F1 : Terminal device disconnected from job.}

     ame$max_cancellable_input       = amc$min_ecc_terminal_validation + 6,
         {E File +F1 : Maximum cancellable input exceeded.}

     ame$cancel_group_encountered    = amc$min_ecc_terminal_validation + 7,
         {E File +F1 : Cancel group encountered.}

     amc$max_ecc_terminal_validation = amc$min_ecc_terminal_validation + 9;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$UNIMPLEMENTED_REQUEST EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVUIR :Unimplemented request   : ''AM'' 430 .. 439', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$unimplemented_request }

   CONST
     amc$min_ecc_unimp_validation    = amc$min_ecc_validation + 430,

     ame$unsupported_operation       = amc$min_ecc_unimp_validation + 0,
         {E File +F1 : +P2 operation not supported for +P5 record type..
         { and +P6 block type.}

     ame$deleted_bt_rt               = amc$min_ecc_unimp_validation + 3,
         {E File +F1 : +P6 block type/+P5 record type no longer..
         { supported.  Use FAP=AMP$US_BLK_VAR_READ_ONLY_FAP to read file to..
         { another block/record type.}

     ame$unimplemented_request       = amc$min_ecc_unimp_validation + 5,
         {E File +F1 : +P2 not implemented+P8.}

     amc$max_ecc_unimp_validation    = amc$min_ecc_unimp_validation + 9;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$WRITE_EOP_VALIDATION_ERRORS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVWEP :amp$write_end_partition : ''AM'' 750 .. 759', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$write_eop_validation_errors }

   CONST
     amc$min_ecc_weop_validation     = amc$min_ecc_validation + 750,

     ame$partitioning_unsupported    = amc$min_ecc_weop_validation + 5,
         {E File +F1 : +P2 issued but +P5 records do not support..
         { partitioning.}

     amc$max_ecc_weop_validation      = amc$min_ecc_weop_validation + 9;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AME$WTMK_VALIDATION_ERRORS EXPAND=FALSE
*copyc AMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'AMDVWTM :amp$write_tape_mark     : ''AM'' 760 .. 769', EJECT ??

?? FMT (FORMAT := OFF) ??

     { ame$wtmk_validation_errors }

   CONST
     amc$min_ecc_wtmk_validation     = amc$min_ecc_validation + 760,

     ame$improper_ANSI_operation = amc$min_ecc_wtmk_validation + 5,
         {E File +F1 : +P2 for ANSI labelled file not supported.}

     amc$max_ecc_wtmk_validation     = amc$min_ecc_wtmk_validation + 9;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AMH$ABORT_FILE_PARCEL EXPAND=FALSE
{
{ The purpose of this request is to reverse all of the updates of a parcel.
{ The updates that have been performed since the AMP$BEGIN_FILE_PARCEL call
{ that initiated the parcel are removed from the file.  The file is restored
{ to the state that it had at the time of the AMP$BEGIN_FILE_PARCEL.  The
{ file position, key selection and nested file selection are also restored.
{
{
{       AMP$ABORT_FILE_PARCEL (FILE_IDENTIFIER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  aae$parcel_not_found.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$ACCESS_METHOD EXPAND=FALSE
{}
{   The purpose of this request is to transfer control from the}
{ file access procedure (fap) to the access method.}
{   This request is issued whenever a fap wishes to pass an operation through}
{ to the access method. It is also used whenever the fap must issue one or}
{ more access method requests to fulfill the request for which the fap was}
{ originally called.}
{}
{       AMP$ACCESS_METHOD (FILE_IDENTIFIER, CALL_BLOCK, LAYER_NUMBER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access identifier}
{       which was an actual parameter passed to the fap making this request.}
{}
{ CALL_BLOCK: (input) This parameter specifies the access method operation}
{       to be performed.}
{
{ LAYER_NUMBER: (input) This parameter specifies the identity of the fap}
{       making the request; it was an actual parameter passed to the fap.}
{
{ STATUS: (output) This parameter specifies the request status.}
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_id,
{                   ame$improper_layer_number.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$ADD_TO_FILE_DESCRIPTION EXPAND=FALSE
{}
{   The purpose of this request is to establish values for file attributes}
{ which were left undefined by the task. This request is provided}
{ for the writer of a file access procedure (fap). Using this request the fap}
{ is able to provide more pertinent default values than the Basic Access}
{ Method has provided. Attributes explicitly specified by the task cannot}
{ be changed by this request.}
{   This request may be issued repeatedly during the open processing within}
{ the fap. However, multiple requests to intialize the same attribute is not}
{ supported.}
{   The effect of this request is to initialize the preserved attribute}
{ values as well as those associated with this instance of open. Other}
{ instances of open of this file will inherit these attribute values as the}
{ default.}
{   This request is valid only if issued during the open operation of a new}
{ file. It will be rejected at all other times.}
{   If this request is issued for a sequential or byte_addressable file, only}
{ attributes left undefined by the task and which do not affect the}
{ structure of the file may be initialized.}
{ This request cannot be used to define the following attributes for a}
{ sequential or byte-addressable file:}
{       max_block_length
{       max_record_length
{       record_type
{}
{       AMP$ADD_TO_FILE_DESCRIPTION (FILE_IDENTIFIER, FILE_ATTRIBUTES,
{         STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access identifier}
{       which was an actual parameter passed to the fap making this request.}
{}
{ FILE_ATTRIBUTES: (input) This parameter specifies the attribute values to}
{   be added to the file description.}
{
{ STATUS: (output) This parameter specifies the request status.}
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_id,
{                   ame$improper_file_attrib_key,
{                   ame$improper_file_attrib_value,
{                   ame$not_open_new,
{                   ame$attrib_already_defined.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$ALLOCATE EXPAND=FALSE
{
{   The purpose of this request is to assign mass storage space to a file.
{ This request may only be issued by a user who has pfc$append permission}
{ for local_file_name. This request is optional since the system will}
{ dynamically assign space as the file is written. This request is intended}
{ for a user who for performance reasons wishes to pre-allocate space on one}
{ or more mass storage volumes prior to accessing the file.}
{ This request may also be used to expand an existing file.}
{   The rmp$request_mass_storage request or the REQUEST_MASS_STORAGE}
{ command may be used to direct allocation of all or part of the file to}
{ a specific class of mass storage.}
{   If the amc$current_volume mode is specified, additional space will be}
{ obtained from the last volume assigned to an existing file. If the}
{ amc$switch_volumes mode is specified for an existing file, space will be}
{ allocated from another volume selected by the system. The new volume will}
{ be of the same mass storage class as that of the predecessor.}
{   This request will be ignored if the local file is assigned to a terminal.}
{ If the local file is not assigned to mass storage or a terminal, this request}
{ is rejected.}
{
{        AMP$ALLOCATE (LOCAL_FILE_NAME, MODE, AMOUNT, STATUS)
{
{ LOCAL_FILE_NAME: (input) This parameter specifies the local name of the file}
{       for which mass storage space is to be allocated.}
{
{ MODE: (input) This parameter specifies whether the space will be}
{       allocated from the current volume or a new volume.}
{
{ AMOUNT: (input) This parameter specifies the number of bytes of mass}
{       storage space to be assigned to the file.}
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$allocate_mode_param_error,
{                   ame$allocate_amount_error,
{                   ame$improper_device_class,
{                   ame$amount_exceeds_val_limit,
{                   ame$amount_exceeds_file_limit.
{       IDENTIFIER: amc$access_method_id.
*DECK DECK=AMH$ALSO EXPAND=FALSE
{}
{   PURPOSE: }
{     The purpose of this module is to implement one of the access method}
{     program interfaces. This module contains a single [xdcl] procedure}
{     for ease in future maintenance and change of the interface. It is}
{     also a possibility that a procedure[inline] capability will be added}
{     to the CYBIL language. This would allow the contents of this module}
{     to physically be inserted in the user's program at the point of the}
{     user's call to the procedure contained herein. This would avoid the}
{     procedure call. Should CYBIL be changed, having one procedure per module}
{     will allow use of the language feature.}
{}
{   DESIGN: }
{     This module is called by the user of the access method, and it must}
{     execute in the ring of its caller. This module validates the}
{     file_identifier which is the key to the instance of open of the file}
{     to be accessed. Next the values of read parameters and the addresses}
{     of VAR parameters are packaged into a call_block which summarizes the}
{     user's request. Control is then given to the procedure which was}
{     selected when the file was opened. This procedure may be the access}
{     method, a user's file_access_procedure or a system file_access_procedure.}
{}
*DECK DECK=AMH$BEGIN_FILE_PARCEL EXPAND=FALSE
{
{ Permits a user to perform a series of updates to an AAM file, and yet
{ retain the power, until the series is complete, to undo all the updates
{ in the series that have been done so far.  Such a series of updates is
{ called a parcel.  Parcels, at the AAM level, may only be used when the
{ NOS/VE file attribute LOGGING_OPTIONS includes AMC$ENABLE_PARCELS.
{
{ AMP$BEGIN_FILE_PARCEL initiates a parcel, which concerns a specified
{ instance of FSP$OPEN_FILE.  All updates to that instance of open that
{ occur after the BEGIN and before a corresponding parcel COMMIT or ABORT
{ constitute a parcel.  An update during a parcel has the effect of locking
{ the updated record so that no other instance of open can access it until
{ the parcel is terminated.  If the update is a delete, then it is the key
{ rather than the vanished record that is locked, and no other instance of
{ open can insert a record with the same key.  If the parcel is terminated
{ by a COMMIT, the locks are removed and the updates become final.  If the
{ parcel is terminated by an ABORT, the updates are undone and then the
{ locks are removed.  The instance of open that is doing the parcel can
{ access the locked records during the parcel, and it sees them in their
{ updated forms.
{
{ During the operation of a parcel, there is additional processing for each
{ alternate key reference.  Any alternate key reference which accesses a
{ record modified by the parcel, will cause the accessing instance of open
{ to wait for access until the parcel has terminated because the primary
{ key will remain locked for the life of the parcel.  Other references to
{ alternate key values which access records that have not been modified,
{ will complete without interference.  Alternate key values which are
{ deleted or which disappear because of a replace appear to any other
{ instance of open to exist until the end of the parcel.  Another way to
{ describe this behavior is to say that any deletion of a key, primary or
{ alternate, will be deferred until the end of the parcel, but updates will
{ be done immediately.  Other instances of open will see any modified
{ records and all associated primary and alternate keys as locked records,
{ and the parcel user sees them in their updated state.
{
{ If one user updates a record as part of a parcel, and a second user,
{ wanting to read the record, causes expiration of the first user's lock on
{ it, then the second user must abort the first user's parcel.  The
{ processing to expire the lock and abort the parcel will be handled by AAM
{ in a manner that is transparent to the second user.  If the second user
{ had only read permission, this would be impossible.  So if a file has
{ AMC$ENABLE_PARCELS, every concurrent OPEN of that file must have
{ permission that includes MODIFY.  If not, an error diagnostic will be
{ issued and the OPEN will fail.
{
{ Note that in AAM, MODIFY permission alone does not allow changing data
{ records; its purpose is usually to allow statistics to be kept up to
{ date.  Opening with just READ permission is permitted only if the share
{ mode is either READ or NONE.  This will allow the utilities to process
{ files with AMC$ENABLE_PARCELS without any special handling.
{
{ The owner of a parcel must be aware that the parcel could be aborted by a
{ concurrent user at any point in the processing.  When this happens, the
{ next request within the parcel will return a status indicating the abort
{ by the system.  The parcel owner must issue either an
{ AMP$ABORT_FILE_PARCEL request or FSP$CLOSE_FILE request to clear this
{ error indicator.  No further updates can be done on the instance of open
{ having the aborted parcel until the parcel is aborted by the user.
{
{ The parcel feature requires a kind of logging to make it work.  But this
{ is logically separate from the kind of logging that can make recovery
{ possible.  If there is a hardware or software crash in the middle of a
{ parcel, the existence of the parcel does not, of itself, make recovery
{ any more possible.
{
{ A parcel is a set of operations on a file, which may be committed or
{ aborted as a unit.  This allows proper recovery, and the grouping of a
{ set of requests with integrity of the group, without regard to
{ concurrency.  A request late in the parcel will reflect changes made
{ earlier in the parcel.  Aborting the parcel is always allowed because the
{ changes are protected by locks.
{
{ Changes to the file are made immediately, just as if there were no
{ parcel, but the primary keys are locked automatically, so that other
{ users will usually be forced to wait until the parcel is committed or
{ aborted.  The only exceptions are skip and rewind operations, which count
{ records as they exist at the moment, regardless of locks.
{
{ FIFO ordering will not be maintained for alternate keys when parcels are
{ in effect.
{
{ There is a set of AAM requests which are not allowed within the
{ boundaries of a file parcel.  This list includes the following:
{   AMP$ABANDON_KEY_DEFINITIONS   AMP$APPLY_KEY_DEFINITIONS
{   AMP$CREATE_KEY_DEFINITION     AMP$CREATE_NESTED_FILE
{   AMP$DELETE_KEY_DEFINITION     AMP$DELETE_NESTED_FILE
{   AMP$LOCK_FILE                 AMP$UNLOCK_FILE
{   AMP$UNLOCK_KEY                AMP$GET_NEXT_PRIMARY_KEY_LIST
{   AMP$GET_PRIMARY_KEY_COUNT     AMP$BEGIN_QUIET_PERIOD
{   AMP$END_QUIET_PERIOD
{ If any of these requests are issued within a parcel, a diagnostic will be
{ issued and the parcel will be aborted.  If an FSP$CLOSE_FILE is issued
{ within a parcel, the parcel will be aborted and the file will be closed.
{
{ The user may establish explicit locks within the parcel, and they will be
{ automatically unlocked at parcel termination.  Explicit unlocks
{ (AMP$UNLOCK_KEY and AMP$UNLOCK_FILE) cannot be done in the middle of a
{ parcel.
{
{ Key selection and nested file selection are both allowed during a parcel.
{ If a parcel is successfully committed, the key selection, file position,
{ and the nested file in effect at the end of the parcel will remain.  If a
{ parcel is aborted, the nested file selection, the key selection, and the
{ file position will be reset to the values in effect when the parcel was
{ initiated.
{
{ If a file has one instance of open with an active parcel and another
{ instance of open without a parcel, the open without the parcel will not
{ be able to get access to the file to change key definitions or nested
{ file definitions until the parcel terminates.
{
{ Since the modified records are locked out from any other file user,
{ parcels on highly concurrent files should be kept as short as possible to
{ minimize waiting by the other users.
{
{ Parcels that alter a large number of records should not be attempted
{ during periods of high activity on a file.  When one is attempted, it is
{ recommended that the user lock the file before beginning the parcel.
{ This makes locking the individual records unnecessary, and avoids the
{ problem of generating too many locks.  The parcel will function the same,
{ that is, it may be committed or aborted and the records will be handled
{ accordingly.
{
{ The file parcel facility is also designed to serve as a resource manager
{ for the general parcel capability (Available at 1.5.1).  Some optional
{ parameter values are provided for the AMP$BEGIN_FILE_PARCEL and
{ AMP$COMMIT_FILE_PARCEL procedures for when they are used within a general
{ parcel.
{
{ For any given file_identifier, there can be at most one parcel in
{ progress.  This is true whether the parcel is a portion of a general
{ parcel or an individual file parcel.
{
{
{       AMP$BEGIN_FILE_PARCEL (FILE_IDENTIFIER, GENERAL_COMMIT, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ GENERAL_COMMIT: (input) Boolean variant record.  When not used within
{       a general parcel (1.5.1), the value must be FALSE.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  aae$parcel_in_progress,
{                   aae$parcel_not_allowed,
{                   aae$not_while_file_locked,
{                   aae$too_many_parcels,
{                   aae$space_not_available.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$CHECK_BUFFER EXPAND=FALSE
{
{   The purpose of this request is to check for completion of a specific
{ no_wait request issued for a file opened with amc$physical access. The}
{ BUFFER_AREA address used when the no_wait request was submitted is used}
{ to differentiate from among what may be multiple, outstanding requests.}
{   The STATUS variable will be set to abnormal if the request has completed}
{ with a data transfer error or if the request was never issued.}
{   If the request is incomplete, the contents of the transfer_count and}
{ byte_address parameters will be unchanged.}
{   The WAIT parameter may be used to await the completion of a specific}
{ request. If set to osc$nowait this request must be reissued until the}
{ sought after request completes.}
{
{       AMP$CHECK_BUFFER (FILE_IDENTIFIER, BUFFER_AREA, REQUEST_COMPLETE,
{         TRANSFER_COUNT, BYTE_ADDRESS, WAIT, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ BUFFER_AREA: (input) This parameter specifies the user's buffer area
{       associated with the request to be checked.
{
{ REQUEST_COMPLETE: (output) This parameter specifies whether the request
{       defined by the buffer_area address has completed.
{
{ TRANSFER_COUNT: (output) This parameter specifies the number of bytes
{       actually transferred to the buffer_area by the request.
{
{ BYTE_ADDRESS: (output) This parameter specifies the file byte address
{       of the beginning of the transfer which has completed.
{
{ WAIT: (input) This parameter specifies the action to be taken if the
{       indicated physical input/output request on the file is not complete.
{       Options include:
{         wait: Don't return control until the request is complete.
{         nowait: Return control to the user even though the request may
{                 not be complete.  Another CHECK_BUFFER request must be
{                 used to determine completion.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.
{

*DECK DECK=AMH$CLOSE EXPAND=FALSE
{
{   The use of this request is discouraged.  FSP$CLOSE_FILE should be used
{ instead.
{   The purpose of this request is to terminate file access. The}
{ file_identifier is invalidated by this request.
{   For a file associated with tape, the file and volume are terminated}
{ according to convention, if the preceding operation was an output to the}
{ tape. If the label_type is amc$labelled(*), the standard ANSI EOF label}
{ and two tapemarks are written; then the tape volume is positioned by close}
{ between the two tapemarks. For an amc$unlabelled file, two}
{ tapemarks are written to terminate the file and volume; then the volume}
{ is positioned by close prior to the two tapemarks.}
{   If a label_exit_procedure(*) has been specified, control will be passed}
{ to this procedure whenever a standard ANSI label matching the label_options}
{ attribute is processed.}
{
{       AMP$CLOSE (FILE_IDENTIFIER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{
{ STATUS: (output) This parameter specifies the request status
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_id,
{                   ame$unrecovered_write_error.}
{       IDENTIFIER: amc$access_method_id.
{}
*DECK DECK=AMH$CLOSE_VOLUME EXPAND=FALSE
{
{   The purpose of this request is to switch to the next volume of a file.
{ This request has meaning only for files assigned to magnetic tape devices.
{ It is ignored for files assigned to other device types.
{ The identity of the next volume is determined from the ordered list of
{ volumes supplied with a REQUEST_MAGNETIC_TAPE command or rmp$request_tape
{ program interface.
{
{   If the preceding operation was an output and the label_type is
{ amc$labelled, the standard ANSI EOV labels are written.  If a
{ label_exit_procedure(*) was specified, control passes to this procedure for
{ user label processing.  For all label_type values, two tapemarks are then
{ written to terminate the volume.  The next volume is then obtained.  If the
{ label_type is amc$labelled, the standard ANSI VOL and HDR labels are
{ written.  If a label_exit_procedure(*) was specified, control passes to this
{ procedure for user label processing.  A single tapemark is then written
{ after the HDR label group.  For an unlabelled or non standard labelled file,
{ the tape is positioned at the beginning of the volume.
{
{   If the file is being read, the next volume is obtained.  If the label_type
{ is amc$labelled, the standard HDR labels are validated by the access method.
{ If a label_exit_procedure(*) was specified, control passes to this procedure
{ for user label processing.  The file is then positioned after the tapemark
{ following the HDR label group.  For an unlabelled or non standard labelled
{ file, the tape is positioned at the beginning of the volume.
{
{   This request does not invalidate the file_identifier.  Therefore, the file
{ need not be reopened subsequent to this request.
{
{       AMP$CLOSE_VOLUME (FILE_IDENTIFIER, STATUS)
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the file access
{       identifier established when the file was opened.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$accessibility_conflict,
{                   ame$block_type_conflict,
{                   ame$file_set_id_conflict,
{                   ame$fsn_out_of_sequence,
{                   ame$improper_access_level,
{                   ame$non_ansi_labels,
{                   ame$record_type_conflict,
{                   ame$ring_validation_error,
{                   ame$section_out_of_sequence,
{                   ame$tape_end_of_volume_list,
{                   ame$unrecovered_write_error.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$COMMIT_FILE_PARCEL EXPAND=FALSE
{
{ The purpose of this request is to make all of the updates of a parcel
{ permanent.  An AMP$BEGIN_FILE_PARCEL call must have been previously
{ performed for this file identifier.  The updates that are included in the
{ parcel are those that have been performed since the AMP$BEGIN_FILE_PARCEL
{ call that initiated the parcel.
{
{ When the commit is performed successfully, file position, key selection
{ and nested file selection remain unchanged.
{
{
{       AMP$COMMIT_FILE_PARCEL (FILE_IDENTIFIER, COMMIT_PHASE, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ COMMIT_PHASE: (input) One of the following values.
{       amc$simple_commit:
{             This is the value that must be used for a single file parcel.
{       amc$tentative_commit:
{       amc$permanent_commit:
{             These values may be used in conjunction with general parcels.
{             The general parcel capability is to be available at 1.5.1.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  aae$parcel_not_found,
{                   aae$simple_commit_needed,
{                   aae$parcel_must_be_aborted.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$COPY_FILE EXPAND=FALSE
{}
{   The use of this request is discouraged.  FSP$COPY_FILE should be used
{ instead.
{   The purpose of this request is to copy one file to another.}
{   If file attributes are not explicitly specified for the output_file}
{ it will inherit the file attributes of the input_file.}
{   The copy terminates when end of information (EOI) is reached on the}
{ input_file.  If the input_file is an unlabelled tape file, the copy}
{ terminates when a tapemark is encountered on the input_file.  If the}
{ unlabelled tape has embedded single tapemarks prior to the double}
{ tapemark, which signals end-of-information on the tape, then this}
{ request must be issued once for each embedded tapemark to obtain a}
{ complete copy of the information on the input_file.  Note that this request}
{ does not cause embedded tapemarks to be written to the output_file.}
{   The amp$file request may be used to specify the open_position of either}
{ file prior to issuing this request.  The amp$file request may also be issued
{ to specify the attributes of the output file to be created as a result of}
{ this request.}
{}
{     AMP$COPY_FILE (INPUT_FILE, OUTPUT_FILE, STATUS)
{}
{ INPUT_FILE: (input) This parameter specifies the local name of the file}
{     from which data is to be copied.}
{}
{ OUTPUT_FILE: (input) This parameter specifies the local name of the file}
{     to which data is to be copied.}
{}
{ STATUS: (output) This parameter specifies the request status.}
{       CONDITION:  ame$ring_validation_error,
{                   ame$input_file_not_local,
{                   ame$empty_input_file,
{                   ame$fap_names_not_identical,
{                   ame$conflicting_file_addresses,
{                   ame$improper_fo_for_copy,
{                   ame$input_file_at_eoi,
{                   ame$input_after_eoi,
{                   ame$conflicting_file_structures
{                   ame$conflicting_file_contents,
{                   ame$statement_idents_unequal,
{                   ame$input_and_output_same_file,
{                   ame$line_numbers_unequal,
{                   ame$copy_device_conflict,
{                   ame$conflicting_block_types,
{                   ame$conflicting_record_types,
{                   ame$copy_not_supported,
{                   ame$local_file_limit,
{                   ame$mbl_less_than_mibl,
{                   ame$mbl_less_than_mrl,
{                   ame$no_permission_for_access,
{                   ame$non_ANSI_blocking,
{                   ame$improper_record_override,
{                   ame$improper_override_access,
{                   ame$improper_us_block_override,
{                   ame$improper_ss_block_override,
{                   ame$improper_fo_override,
{                   ame$unable_to_load_fap,
{                   ame$unable_to_load_collate_tabl
{                   ame$unable_to_load_error_exit,
{                   ame$terminal_task_limit,
{                   ame$multiple_open_of_tape,
{                   ame$record_exceeds_mbl,
{                   ame$unrecovered_read_error,
{                   ame$unrecovered_write_error,
{                   ame$concurrent_tape_limit,
{                   fse$empty_input_file;
{
{       IDENTIFIER: amc$access_method_id.
{}
*DECK DECK=AMH$COPY_PARTIAL_RECORDS EXPAND=FALSE
{}
{   The purpose of this request is to copy a portion of one or more records}
{ from one file to another.}
{   If the to_file is created as a result of this request, the default}
{ file_attributes will be those which are in effect for the from_file}
{ at the moment this request is issued.}
{   The portion of each record to be copied is the range of bytes}
{ from first_byte to and including the last_byte.}
{   The extent of the copy is determined by a record count, a partition count}
{ or end of information on the from_file, whichever occurs first.}
{   This request does not cause partition delimiters found on the from_file}
{ to be copied to the to_file; partition delimiters only serve the purpose}
{ of controlling the amount of data copied from the from_file.}
{   The amp$file request may be used to determine the open_position of either}
{ file prior to issuing this request.}
{   This request interprets the file_contents attribute of each file to}
{ determine whether special processing is required on the from_file.}
{ If the file_contents attribute of the from_file is not 'LIST' and the same}
{ attribute of the to_file is 'LIST', then each record of the to_file will}
{ be prefixed by a single-space carriage_control character.}
{}
{       AMP$COPY_PARTIAL_RECORDS (FROM_FILE, TO_FILE, EXTENT,
{         FIRST_BYTE, LAST_BYTE, STATUS)
{}
{ FROM_FILE: (input) This parameter specifies the local name of the file}
{       from which data is to be copied.}
{}
{ TO_FILE: (input) This parameter specifies the local name of the file to}
{       which data is to be copied.}
{}
{ EXTENT: (input) This parameter specifies the amount of data which is to}
{       be copied. Options include a count of records, a count of partitions}
{       and the amount of data on the from_file from its current position}
{       until eoi is reached.}
{       If a count of records is specified, copying continues across partition}
{       boundaries until the count is exhausted or until eoi is reached on the}
{       from_file. Partition delimiters encountered on the from_file are}
{       ignored and do not cause the record count to be decremented.}
{       If a count of partitions is specified, copying will continue until the}
{       specified number of partitions have been encountered on the from_file}
{       or until eoi has been reached on the from_file.}
{}
{ FIRST_BYTE: (input) This parameter specifies the starting}
{       byte position with the record.}
{}
{ LAST_BYTE: (input) This parameter specifies the ending}
{       byte position within the record.  Last_byte must be}
{       greater than or equal to first_byte.}
{}
{ STATUS: (output) This parameter specifies the request status.}
{       CONDITION:  ame$ring_validation_error,
{                   ame$copy_from_not_local,
{                   ame$from_file_appears_empty,
{                   ame$local_file_limit,
{                   ame$improper_access_level,
{                   ame$mbl_less_than_mibl,
{                   ame$mbl_less_than_mrl,
{                   ame$no_permission_for_access,
{                   ame$non_ANSI_blocking,
{                   ame$improper_w_override,
{                   ame$improper_s_override,
{                   ame$improper_d_override,
{                   ame$improper_shorten_open,
{                   ame$improper_append_open,
{                   ame$unable_to_load_fap,
{                   ame$record_exceeds_mbl,
{                   ame$unrecovered_read_error,
{                   ame$unrecovered_write_error,
{                   ame$concurrent_tape_limit.
{       IDENTIFIER: amc$access_method_id.
{}
*DECK DECK=AMH$COPY_PARTITIONS EXPAND=FALSE
{}
{   The purpose of this request is to copy one or more partitions of data}
{ from one file to another.}
{   If the to_file is created as a result of this request, the default}
{ file_attributes will be those which are in effect for the from_file}
{ at the moment this request is issued.}
{   The extent of the copy is determined by a record count, a partition}
{ count, or end of information on the from_file, whichever occurs first.}
{   The amp$file request may be used to determine the open_position of either}
{ file prior to issuing this request.}
{   If both files are defined with a record_type which supports}
{ partitioning, any partition delimiters found on the from_file will}
{ be copied to the to_file.}
{   If the to_file is defined with a record_type which supports}
{ partitioning, it will be terminated by a partition delimiter}
{ regardless of the record_type of the from_file.  If repeated}
{ amp$copy_partitions requests are issued to append data to the}
{ same to_file, a partition delimiter will separate the result of}
{ each request. If a partition is the last item copied from the from_file,}
{ this request will suppress writing a redundant partition at eoi.}
{   This request interprets the file_contents attribute of each file to}
{ determine whether special processing is required on the from_file.}
{ If the file_contents attribute of the from_file is not 'LIST' and the same}
{ attribute of the to_file is 'LIST', then each record of the to_file will}
{ be prefixed by a carriage_control character. A single-space carriage-control}
{ character will precede each record and a page-eject carriage-control}
{ character will precede each partition copied.}
{}
{     AMP$COPY_PARTITIONS (FROM_FILE, TO_FILE, EXTENT, STATUS)
{}
{ FROM_FILE: (input) This parameter specifies the local name of the file}
{     from which data is to be copied.}
{}
{ TO_FILE: (input) This parameter specifies the local name of the file}
{     to which data is to be copied.}
{}
{ EXTENT: (input) This parameter specifies the amount of data which is to}
{       be copied. Options include a count of records, a count of partitions}
{       and the amount of data on the from_file from its current position}
{       until eoi is reached.}
{       If a count of records is specified, copying will continue until the}
{       specified number of records have been encountered on the from_file or}
{       until a partition or eoi is encountered on the from_file.}
{       If a count of partitions is specified, copying will continue until the}
{       specified number of partitions have been encountered or until eoi has}
{       been reached on the from_file.}
{}
{ STATUS: (output) This parameter specifies the request status.}
{       CONDITION:  ame$ring_validation_error,
{                   ame$copy_from_not_local,
{                   ame$from_file_appears_empty,
{                   ame$local_file_limit,
{                   ame$improper_access_level,
{                   ame$mbl_less_than_mibl,
{                   ame$mbl_less_than_mrl,
{                   ame$no_permission_for_access,
{                   ame$non_ANSI_blocking,
{                   ame$improper_w_override,
{                   ame$improper_s_override,
{                   ame$improper_d_override,
{                   ame$improper_shorten_open,
{                   ame$improper_append_open,
{                   ame$unable_to_load_fap,
{                   ame$record_exceeds_mbl,
{                   ame$unrecovered_read_error,
{                   ame$unrecovered_write_error,
{                   ame$concurrent_tape_limit.
{       IDENTIFIER: amc$access_method_id.
{}
*DECK DECK=AMH$COPY_RECORDS EXPAND=FALSE
{}
{   The purpose of this request is to copy records from one file to another.}
{   If the to_file is created as a result of this request, the default}
{ file_attributes will be those which are in effect for the from_file}
{ at the moment this request is issued.}
{   The extent of the copy is determined by a record count, a partition}
{ count, or end of information on the from_file whichever occurs first.}
{   This request does not cause partition delimiters found on the from_file}
{ to be copied to the to_file; partition delimiters only serve the purpose}
{ of controlling the amount of data copied from the from_file.}
{   The amp$file request may be used to determine the open_position of either}
{ file prior to issuing this request.}
{   This request interprets the file_contents attribute of each file to}
{ determine whether special processing is required on the from_file.}
{ If the file_contents attribute of the from_file is not 'LIST' and the same}
{ attribute of the to_file is 'LIST', then each record of the to_file will}
{ be prefixed by a single-space carriage_control character.}
{}
{       AMP$COPY_RECORDS (FROM_FILE, TO_FILE, EXTENT, STATUS)
{}
{ FROM_FILE: (input) This parameter specifies the name of the local file}
{       from which data is to be copied.}
{}
{ TO_FILE: (input) This parameter specifies the name of the local file to}
{       which data is to be copied.}
{}
{ EXTENT: (input) This parameter specifies the amount of data which is to}
{       be copied. Options include a count of records, a count of partitions}
{       and the amount of data on the from_file from its current position}
{       until eoi is reached.}
{       If a count of records is specified, copying continues across partition}
{       boundaries until the count is exhausted or until eoi is reached on the}
{       from_file. Partition delimiters encountered on the from_file are}
{       ignored and do not cause the record count to be decremented.}
{       If a count of partitions is specified, copying will continue until the}
{       specified number of partitions have been encountered on the from_file}
{       or until eoi has been reached on the from_file.}
{}
{ STATUS: (output) This parameter specifies the request status.}
{       CONDITION:  ame$ring_validation_error,
{                   ame$copy_from_not_local,
{                   ame$from_file_appears_empty,
{                   ame$local_file_limit,
{                   ame$improper_access_level,
{                   ame$mbl_less_than_mibl,
{                   ame$mbl_less_than_mrl,
{                   ame$no_permission_for_access,
{                   ame$non_ANSI_blocking,
{                   ame$improper_w_override,
{                   ame$improper_s_override,
{                   ame$improper_d_override,
{                   ame$improper_shorten_open,
{                   ame$improper_append_open,
{                   ame$unable_to_load_fap,
{                   ame$record_exceeds_mbl,
{                   ame$unrecovered_read_error,
{                   ame$unrecovered_write_error,
{                   ame$concurrent_tape_limit.
{       IDENTIFIER: amc$access_method_id.
{}
*DECK DECK=AMH$DELETE EXPAND=FALSE
{
{   The purpose of this request is to delete the record obtained through
{ an immediately preceding retrieval request.  The request is only valid
{ for files with record_type of amc$variable.
{   The record is logically deleted. The space that the deleted}
{ record occupied remains a part of the file but is ignored.}
{
{       AMP$DELETE (FILE_IDENTIFIER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.
{

*DECK DECK=AMH$DELETE_DIRECT EXPAND=FALSE
{
{   The purpose of this request is to delete the record identified by a
{ specified byte address.  The request is only valid for byte addressable
{ mass storage files with record_type of amc$variable.
{   The record is logically deleted. The space that the deleted}
{ record occupied remains a part of the file but is ignored.}
{
{       AMP$DELETE_DIRECT (FILE_IDENTIFIER, BYTE_ADDRESS, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ BYTE_ADDRESS: (input) This parameter specifies the file byte address
{       of the record to be deleted.
{
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.

*DECK DECK=AMH$DELETE_PREVIOUS_RECORD EXPAND=FALSE
{
{   The purpose of this request is to delete an entire record.}
{   This request is valid only for mass storage files with}
{ CDC-variable (V) record-type opened for sequential access.}
{   The file position must be at the end of the record to be deleted.}
{   After a successful delete, the file will be positioned: 1) at the}
{ end of the first active record prior to the deleted one or 2) at the}
{ beginning of a partition, if the first record of a partition is deleted}
{ or 3) at the beginning of information, if the first record of the file}
{ is deleted.}
{   If the last record of the file is deleted, the file will be logically}
{ and physically shortened, i.e. the eoi-byte-address of the file will be}
{ decreased by the length of the record deleted and extraneous mass storage}
{ space will be released when the file is closed.}
{   If a record other than the last one is deleted, the record is logically}
{ deleted but the length of the file is not affected, i.e. the eoi-byte-address}
{ remains as before the request.  However, if a record-by-record}
{ file copy operation (amp$copy_file/COPY_FILE) is performed, the resultant}
{ file will be logically shorter, i.e. the deleted record(s) of the input}
{ file will not be in the output file.  If a byte-by-byte copy of the file}
{ is performed, an exact copy, including the deleted record(s), is written}
{ to the output file; this preserves the file_byte_address of non-deleted}
{ records.}
{}
{   This request requires 'shorten' access to the file.}
{
{       AMP$DELETE_PREVIOUS_RECORD (FILE_IDENTIFIER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_id,
{                   ame$improper_access_attempt,
{                   ame$improper_file_position,
{                   ame$unrecovered_write_error,
{                   ame$file_organization_conflict,
{                   ame$improper_device_class,
{                   ame$conflicting_access_level,
{                   ame$unsupported_operation;
{       IDENTIFIER: amc$access_method_id.
{

*DECK DECK=AMH$ERASE_TAPE_BLOCK EXPAND=FALSE
{
{   The purpose of this request is to erase a specified length of tape.  The
{ length of tape to be erased is specifed in bytes which is equivalent to the
{ number of frames on the tape file.
{
{   This request is valid only for a tape file with a FILE_LABEL_TYPE of
{ AMC$UNLABELLED, a BLOCK_TYPE of AMC$USER_SPECIFIED and a RECORD_TYPE of
{ AMC$UNDEFINED.
{
{   This request writes on the tape and therefore unconditionally establishes
{ End of Information (EOI).
{
{       AMP$ERASE_TAPE_BLOCK (FILE_IDENTIFIER, BLOCK_LENGTH, STATUS)
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the file access
{       identifier established when the file was opened.
{
{ BLOCK_LENGTH: (input)  This parameter specifies the length of the block to
{       be erased.  This length is given in bytes.
{
{ STATUS: (output) This parameter specifies the request status.
{
{       CONDITION:  ame$ring_validation_error,
{                   ame$conflicting_access_level,
{                   ame$improper_file_id,
{                   ame$improper_output_attempt,
{                   ame$put_beyond_file_limit,
{                   ame$record_exceeds_mbl,
{                   ame$improper_wsl_value,
{                   ame$unrecovered_write_error,
{                   ame$terminal_disconnected.
{       IDENTIFIER: amc$access_method_id.
*DECK DECK=AMH$EVICT EXPAND=FALSE
{
{   The purpose of this request is to release storage space that is currently
{ allocated to a file.}
{   This request requires that all instances of open of the local_file_name}
{ be closed prior to this request, or this request will be rejected.}
{   This request may be used to shorten an existing file or to release}
{ excess space which had been preallocated. A user who wishes to shorten}
{ the file must have an access_mode which includes pfc$shorten.}
{   If the mode is amc$redefine_eoi, the byte_address specifies a new EOI}
{ for the file. All space beyond this new EOI is released. A byte_address}
{ of zero will release all the space in the file.}
{   If the mode is amc$release_unused, any space which may exist beyond EOI}
{ is released.}
{}
{        AMP$EVICT (LOCAL_FILE_NAME, MODE, BYTE_ADDRESS, STATUS)
{
{ LOCAL_FILE_NAME: (input) This parameter specifies the local name of the file}
{       for which space is to be released.}
{
{ MODE: (input) This parameter specifies whether unused space in the}
{       file is to be released or whether the file is to be made shorter with}
{       this request.}
{
{ BYTE_ADDRESS: (input) This parameter specifies the new EOI byte}
{       address if the mode is amc$redefine_eoi. Otherwise this parameter is}
{       not used.}
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$evict_without_shorten,
{                   ame$evict_mode_param_error,
{                   ame$improper_device_class,
{                   ame$file_not_closed.
{       IDENTIFIER: amc$access_method_id.
*DECK DECK=AMH$FETCH EXPAND=FALSE
{
{   The purpose of this request is to retrieve the value of one or
{ more file attributes subsequent to the file being opened.  This
{ request is similar to amp$get_file_attributes except the file_identifier
{ is used to distinguish from among what may be several instances
{ of open of the same file.
{
{       AMP$FETCH (FILE_IDENTIFIER, FILE_ATTRIBUTES, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ FILE_ATTRIBUTES: (input-output) This parameter specifies one or more
{       attributes whose value is sought.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_attrib_key,
{                   ame$improper_file_id.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$FETCH_ACCESS_INFORMATION EXPAND=FALSE
{
{   The purpose of this request is to retrieve the value of one or
{ more items of file information after the file has been opened.}
{
{       AMP$FETCH_ACCESS_INFORMATION (FILE_IDENTIFIER, ACCESS_INFORMATION,
{         STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ ACCESS_INFORMATION: (input-output) This parameter specifies one or more
{       items of file access information to be returned.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_access_info_key,
{                   ame$improper_file_id.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$FETCH_FAP_POINTER EXPAND=FALSE
{}
{   The purpose of this request is to fetch a pointer to a structure which
{ is owned by a file_access_procedure (FAP).}
{   This request allows the fap to retrieve a pointer to a structure which is}
{ peculiar to the instance of the file being accessed, i.e. peculiar}
{ to a file_identifier.}
{   This request will return abnormal status if the structure pointer for}
{ the fap is NIL.}
{}
{       AMP$FETCH_FAP_POINTER (FILE_IDENTIFIER, LAYER_NUMBER,
{         STRUCTURE_POINTER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file access}
{       identifier established when the file was opened.}
{}
{ LAYER_NUMBER: (input) This parameter specifies the identity of the fap.}
{       This parameter is the same layer_number which was passed to the fap}
{       as an actual parameter.}
{}
{ STRUCTURE_POINTER: (output) This parameter specifies the address of}
{       a structure the fap previously stored using the amp$store_fap_pointer}
{       request.}
{}
{ STATUS: (output) This parameter specifies the request status.}
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_id,
{                   ame$nil_structure_pointer.
{       IDENTIFIER: amc$access_method_id.
{}
*DECK DECK=AMH$FILE EXPAND=FALSE
{}
{   The use of this request is discouraged.  The requested file attribute
{ values should be specified on the call to FSP$OPEN_FILE.
{   The purpose of this request is to provide values for file attributes}
{ when creating a file. This request must be issued prior to the initial}
{ amp$open of the file. Attributes provided by this request are superceded}
{ by the access_selections parameter of amp$open and the SET_FILE_ATTRIBUTES}
{ command.  However, an attribute whose value was not defined by amp$open or}
{ the AMP$SET_FILE_ATTRIBUTES COMMAND but was provided by this request}
{ will be preserved when the file is initially opened.}
{   This request may also be issued prior to opening an old file. An old}
{ file is one which has been previously opened. File attributes which were}
{ preserved with an old file are called structural attributes. If a}
{ structural attribute is specified with this request prior to opening an}
{ old file, then the specified value will be ignored with three exceptions.}
{ The preserved values of file_organization, record_type and block_type may}
{ be temporarily overridden. This permits any file to be read with U records
{ and system_specified blocking regardless of the manner in which it was}
{ originally written.}
{   This request may be used to provide values for temporary attributes}
{ prior to opening a file regardless of whether the file is new or old.}
{ Values provided by the access_selections parameter of amp$open and the}
{ SET_FILE_ATTRIBUTES command supercede values specified by this request.}
{   This request is provided to allow a program to specify default values}
{ for file attributes that are different from the default values which}
{ would be supplied by the access method. This request would typically be}
{ used by utility programs. Such programs are designed to allow the use of}
{ the SET_FILE_ATTRIBUTES command to change the program defaults. Programs}
{ which require control over the values of file attributes should specify}
{ values using the access_selections parameter of the amp$open request.}
{   This request remains in effect for all subsequent instances of open}
{ of the file from within the issuing task until another amp$file request}
{ is issued for the same file, the file is returned or the task terminates.}
{   The effect of multiple amp$file requests  within a}
{ task for the same file is not cumulative; the latest one takes effect}
{ and the previous one is discarded.}
{   The effect of an amp$file request is not retroactive.}
{ An amp$file request does not affect an instance of open}
{ which preceded this request.}
{
{       AMP$FILE (LOCAL_FILE_NAME, FILE_ATTRIBUTES, STATUS)
{
{ LOCAL_FILE_NAME: (input) This parameter specifies the name of the local
{       file for which attribute values are being supplied.
{
{ FILE_ATTRIBUTES: (input) This parameter specifies one or more file
{       attribute values which define the file content and means of access.}
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_attrib_key,
{                   ame$improper_file_attrib_value.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$FILE_ACCESS_PROCEDURE EXPAND=FALSE
{}
{   A file_access_procedure (fap) is a procedure which intervenes in the
{ calling sequence sequence between a task and the access method.  When a}
{ task issues an access method request which is keyed by a file_identifier,}
{ control passes directly to the fap rather than the access method.}
{}
{ Possible reasons for using faps include:
{}
{       .encryption / decryption
{       .modeling the task's i/o behavior
{       .file data conversion
{       .file data compression
{       .logging of change/access to a file
{       .stubbing-off a program's i/o during program debugging
{}
{   When a file is created a fap may be specified by the SET_FILE_ATTRIBUTES}
{ command, the amp$file request or the amp$open request. The}
{ file_access_procedure is specified as a name and that name is preserved}
{ with the file.}
{   The fap is loaded each time the file with which it is associated is}
{ opened.  The association of a fap with a file does not bestow additional}
{ privilege upon the fap. The privilege of the fap is determined by the}
{ privilege of the file from which the fap is loaded, qualified by the ring}
{ of the caller of open.  The fap cannot access the file unless the fap has}
{ the neccessary privilege, but it may simulate file access.}
{ Failure to successfully load the fap will result in abnormal status and}
{ the termination of the amp$open request.}
{   A fap must be coded to accept any and all access method requests which}
{ pass control to a fap. The call_block formal parameter description}
{ describes which access method requests are applicable. With few}
{ exceptions, this list consists of all access method requests which have}
{ file_identifier as a formal parameter. Whenever such a request is issued}
{ by a task, the request is immediately diverted to the fap before}
{ any action is taken by the access method.}
{   The fap may choose to process the request itself, i.e. emulate the}
{ access method, or it may choose to pass the request to the access method.}
{   If the fap chooses to emulate the access method, the fap is responsible}
{ for executing the request in a manner which is functionally compatible}
{ with the access method it replaced. This responsibility extends to}
{ initializing the task's STATUS variable and other actual}
{ parameters, where applicable, in addition to transferring data.}
{   If the fap chooses to pass the OPEN operation to the access method}
{ then it may do more than merely emulate requests. The fap may issue}
{ multiple requests upon the access method to implement the task's}
{ request. However, by choosing to pass the OPEN operation, the fap must}
{ pass the CLOSE operation as well. Any file which is not explicitly closed}
{ by the task will be closed at task termination. The fap will be}
{ given control at that time via the CLOSE operation. As in the explicit}
{ CLOSE, the fap must pass CLOSE to the access method.}
{   If the fap chooses to pass the task's request to the access}
{ method, it does so with the amp$access_method request. This interface may}
{ also be used to issue access method requests other than those issued by}
{ the task. The amp$access_method interface is only to be used to}
{ access the instance of open defined by the file_identifier, which}
{ is an actual parameter to the fap. A fap may access other files using the}
{ 'AMP$' interfaces (provided that it is not the fap for any of them).}
{ A fap which issues 'AMP$' requests to a file for which it is defined as}
{ the fap, will recursively call itself. This will be true for all requests}
{ defined by the amt$fap_operation type declaration.}
{   The file_access_procedure preserved with a file is always the first}
{ process to gain control from whichever 'AMP$' interface was executed}
{ by the task. There may exist other faps defined by the system. These}
{ system faps would be given control if the file_access_procedure were}
{ to pass a request using amp$access_method. To coordinate the order in}
{ which faps are given control, a layer_number is passed to the fap as}
{ a parameter; the layer_number must not be changed by the fap since it is}
{ the key by which the fap is known within the ordering (layering) of faps.}
{ The layer_number given to the fap is the one which is used as an input}
{ to interfaces which support the fap mechanism.}
{   Each layer of fap has the ability and responsibility for interpreting}
{ and providing STATUS for the layers above it.}
{   If the fap detects an exception condition during the OPEN operation,}
{ it must return an initialized status variable rather than trying to}
{ CLOSE the file itself. The amp$open interface will detect the abnormal}
{ status, call the fap with a CLOSE operation, and return the abnormal}
{ status to the task. This allows each layer of fap to see the close.}
{   The following is a description of the formal interface to a fap.}
{ The fap writer should use the amt$fap_pointer type declaration as a guide}
{ to producing the [XDCL] procedure declaration for the fap. The fap}
{ interface must be compatible with the CYBIL language's calling sequence}
{ and data mapping.}
{}
{       FILE_ACCESS_PROCEDURE_NAME (FILE_IDENTIFIER, CALL_BLOCK,
{         LAYER_NUMBER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file access identifier}
{       which was quoted on the task's call to the access method.}
{}
{ CALL_BLOCK: (input) This parameter specifies the identity and the substance}
{       of the operation which the fap is requested to perform.}
{}
{ LAYER_NUMBER: (input) This parameter specifies the identity of the fap.}
{}
{ STATUS: (output) This parameter specifies the request status.}
{}
*DECK DECK=AMH$FLUSH EXPAND=FALSE
{
{   The purpose of this request is to ensure that any modified data}
{ currently in memory is recorded on the device assigned to the file.}
{   This request is intended for a user of a shared file who wants
{ to serialize the data on mass storage before releasing the interlock
{ on the file.  Also this request may be used to ensure a copy of the
{ data has been recorded on mass storage for recovery purposes.}
{   This request applies to all levels of access.}
{   The contents of buffers maintained by the access method for amc$record}
{ access files are flushed by this request.}
{   The contents of any modified pages of an amc$segment access file are}
{ flushed by this request.}
{
{       AMP$FLUSH (FILE_IDENTIFIER, WAIT, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ WAIT: (input) This parameter specifies the action to be taken following}
{       initiation of the flush operation. Options include:}
{         wait: Don't return until the flush is complete.
{         no_wait: Return control to the user even though the request may be}
{           incomplete. The amp$fetch_access_information request must be used}
{           to obtain last_op_status to determine when the flush has}
{           completed.}
{}
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_id,
{       IDENTIFIER: amc$access_method_id,
{                   ame$terminal_disconnected.
{
*DECK DECK=AMH$GET_DIRECT EXPAND=FALSE
{
{   The purpose of this request is to retrieve a record from a file opened
{ with amc$record access and file_organization of amc$byte_addressable or
{ amc$sequential.
{   The location of the record is specified by the byte_address parameter
{ and must be the byte_address of a record boundary (the address specified on
{ an amp$put_direct, or returned in the byte_address parameter of an
{ amp$put_next or amp$put_partial-start).
{   The record is moved from buffers maintained by the access method to the
{ user's working_storage_area. Data movement always begins at a record
{ boundary and continues until either the end of the record or the end of
{ the working_storage_area is encountered, whichever occurs first. If the
{ entire record is not moved, an amc$mid_record file position is returned.
{ In this event, subsequent amp$get_partial requests may be issued to obtain
{ the remainder of the record.
{   If a partition delimiter or EOI is encountered, the working_storage_area
{ is not modified by this request, i.e. no data is transferred.
{   An attempt to input data at a byte address beyond EOI will cause
{ abnormal status to be returned.  An attempt to input data at EOI will
{ cause an amc$eoi file_position to be returned on the initial attempt.
{ Additional attempts by the same task to input at EOI will cause abnormal
{ status to be returned.
{
{       AMP$GET_DIRECT (FILE_IDENTIFIER, WORKING_STORAGE_AREA,
{         WORKING_STORAGE_LENGTH, TRANSFER_COUNT, BYTE_ADDRESS,
{         FILE_POSITION, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ WORKING_STORAGE_AREA: (input) This parameter specifies the address of the
{       first byte of a contiguous area bounded by the working_storage_length
{       into which all or part of a record from the file will be moved.
{       If the length of the record is less than the working storage length
{       the access method does NOT guarantee that the area between the
{       transfer count and the end of the working storage area will be left
{       unmodified.
{
{ WORKING_STORAGE_LENGTH: (input) This parameter specifies the size of the
{       working storage area. The size of the working storage area should
{       equal or exceed the length of the longest record to be input.
{       If a record exceeds the working storage length, subsequent
{       amp$get_partial requests may be issued to obtain the record excess.
{       A zero or negative working_storage_length is improper.
{
{ TRANSFER_COUNT: (output) This parameter specifies the number of bytes
{       of data moved to the working_storage_area by this request.
{
{ BYTE_ADDRESS: (input) This parameter specifies the file byte address
{       of the record to be retrieved.  The byte_address must be that of a
{       record boundary.
{
{ FILE_POSITION: (output) This parameter specifies the position of the file
{       following this request.
{       The following file positions may be returned by this request:
{         amc$mid_record,
{         amc$eor,
{         amc$eop,
{         amc$eoi.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$conflicting_access_level,
{                   ame$improper_file_byte_address,
{                   ame$improper_seek_address,
{                   ame$improper_file_id,
{                   ame$file_organization_conflict,
{                   ame$improper_input_attempt,
{                   ame$improper_record_address,
{                   ame$improper_wsl_value,
{                   ame$input_after_eoi,
{                   ame$unrecovered_read_error,
{                   ame$accept_bad_block,
{                   ame$terminal_disconnected,
{                   ame$max_cancellable_input,
{                   ame$cancel_group_encountered.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$GET_FILE_ATTRIBUTES EXPAND=FALSE
{
{   The purpose of this request is to provide information maintained by the
{ access method for each file.
{
{   If this request is issued for a file which has not been previously opened
{ (FILE_PREVIOUSLY_OPENED is FALSE), the values of structural and temporary
{ attributes are taken from the following sources according to precedence:
{ <file reference> specification, SET_FILE_ATTRIBUTES command and any amp$file
{ request issued by this task. If an attribute has not been defined by one of
{ these sources, the access method will provide a default value for most
{ attributes.  An attribute for which no explicit nor default value has been
{ given will have the source component set to amc$undefined_attribute.
{
{   If this request is issued for a FILE which has been previously opened
{ (FILE_PREVIOUSLY_OPENED is TRUE), the values of structural attributes are
{ those which were preserved when the file was initially opened.  The values of
{ temporary attributes are determined as above for a file that has not been
{ previously opened.
{
{   The access method maintains information, on a file basis, which does not
{ originate from access method requests or a <file reference> specification
{ per se.  However, this information may be vital to the task accessing the
{ file.  Examples of attributes of this class are:  application_info,
{ file_length, global_access_mode, global_file_address, global_file_name,
{ global_file_position, global_share_mode, and permanent_file.  The source
{ component of these 'attributes' is set to amc$local_file_information.
{
{   This request may be issued regardless of whether the file is currently
{ open within the job.
{
{   This request only returns global file positioning information and will
{ not reflect file positioning for a file instance opened for private_read.
{
{   This request does not return values of attributes which result from an
{ amp$store request.  These values apply only to an instance of file access
{ and do not influence a subsequent amp$open request.
{
{       AMP$GET_FILE_ATTRIBUTES (FILE, FILE_ATTRIBUTES, FILE_EXISTS,
{         FILE_PREVIOUSLY_OPENED, CONTAINS_DATA, STATUS)
{
{ FILE: (input)  This parameter specifies the name of the file whose attribute
{       values are sought.
{
{ FILE_ATTRIBUTES: (input, output)  This parameter specifies one or more file
{       attributes whose value is sought.
{
{ FILE_EXISTS: (output)  This parameter specifies whether the file name
{       specified exists.  A file exists if it is in the permanent file
{       or $LOCAL catalog, or a SET_FILE_ATTRIBUTES command has been done
{       on the specified file.
{
{ FILE_PREVIOUSLY_OPENED: (output)  This parameter specifies whether the file
{       has been previously opened.  If file_previously_opened is TRUE, the
{       file's attribute definition is complete.  If file_previously_opened is
{       FALSE, a subsequent open of the file will be the initial open which
{       will result in the completion of the definition of the file's
{       attributes.
{
{ CONTAINS_DATA: (output)  This parameter specifies whether or not a file is
{       non-empty.  If the file is assigned to a terminal or a null device a
{       value of FALSE is always returned.  If the file is assigned to a
{       magnetic tape device a value of TRUE is always returned.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_attrib_key.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$GET_LABEL EXPAND=FALSE
*DECK DECK=AMH$GET_NEXT EXPAND=FALSE
{
{   The purpose of this request is to retrieve the next record from a
{ file opened with access_level of amc$record. The location of the
{ record is the current byte address of the file.
{   The record is moved from buffers maintained by the access method to the
{ user's working_storage_area. Data movement always begins at a record
{ boundary and continues until either the end of the record or the end of
{ the working_storage_area is encountered, whichever occurs first. If the
{ entire record is not moved, amc$mid_record file position will be returned.
{ In this event, subsequent amp$get_partial requests may be issued to
{ obtain the remainder of the record.
{   If the file_position is amc$mid_record when this request is issued, the
{ file will be positioned to the beginning of the next record prior to
{ data movement.
{  If a partition delimiter or EOI is encountered, the working_storage_area
{ is not modified by this request, i.e. no data is transferred.
{  Once an amc$eoi file_position has been reached, further attempts to GET
{ at EOI by this task will cause abnormal status to be returned.
{
{       AMP$GET_NEXT (FILE_IDENTIFIER, WORKING_STORAGE_AREA,
{         WORKING_STORAGE_LENGTH, TRANSFER_COUNT, BYTE_ADDRESS,
{         FILE_POSITION, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ WORKING_STORAGE_AREA: (input) This parameter specifies the address of the
{       first byte of a contiguous area bounded by the working_storage_length
{       into which all or part of a record from the file will be moved.
{       If the length of the record is less than the working storage length
{       the access method does NOT guarantee that the area between the
{       transfer count and the end of the working storage area will be left
{       unmodified.
{
{ WORKING_STORAGE_LENGTH: (input) This parameter specifies the size of the
{       working storage area. The size of the working storage area should
{       equal or exceed the length of the longest record to be input.
{       If a record exceeds the working storage length, subsequent
{       amp$get_partial requests may be issued to obtain the remainder.
{       A zero or negative value for working_storage_length is improper.
{
{ TRANSFER_COUNT: (output) This parameter specifies the number of bytes
{       of data moved to the working_storage_area by this request.
{
{ BYTE_ADDRESS: (output) This parameter specifies the file byte address of
{       the beginning of the record which was moved to the
{       working_storage_area by this request.
{       This parameter is only returned for mass storage files.
{
{ FILE_POSITION: (output) This parameter specifies the position of the file
{       following this request.
{       The following file positions may be returned by this request:
{         amc$mid_record,
{         amc$eor,
{         amc$eop,
{         amc$eoi.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$conflicting_access_level,
{                   ame$improper_file_id,
{                   ame$improper_input_attempt,
{                   ame$improper_record_header,
{                   ame$input_after_output
{                   ame$improper_wsl_value,
{                   ame$input_after_eoi,
{                   ame$unrecovered_read_error,
{                   ame$accept_bad_block,
{                   ame$terminal_disconnected,
{                   ame$max_cancellable_input,
{                   ame$cancel_group_encountered.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$GET_PARTIAL EXPAND=FALSE
{
{   The purpose of this request is to retrieve the next portion of a
{ record from the current location of a file opened with amc$record access.
{   Repeated requests may be required to move the whole record.
{   The data is moved from buffers maintained by the access method to the
{ user's working_storage_area.
{   If a partition delimiter or EOI is encountered, then the working_storage_
{ area is not modified by this request, i.e. no data is transferred.
{   If EOI is encountered, then further attempts to GET data at EOI by this
{ task will cause abnormal status to be returned.
{
{       AMP$GET_PARTIAL (FILE_IDENTIFIER, WORKING_STORAGE_AREA,
{         WORKING_STORAGE_LENGTH, RECORD_LENGTH, TRANSFER_COUNT,
{         BYTE_ADDRESS, FILE_POSITION, SKIP_OPTION, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ WORKING_STORAGE_AREA: (input) This parameter specifies the address of the
{       first byte of a contiguous area bounded by the working_storage_length
{       into which all or part of a record from the file will be moved.
{       If the length of the record is less than the working storage length
{       the access method does NOT guarantee that the area between the
{       transfer count and the end of the working storage area will be left
{       unmodified.
{
{ WORKING_STORAGE_LENGTH: (input) This parameter specifies the number
{       of bytes to be moved into the working storage area.
{       A zero or negative working_storage_length is improper.
{
{ RECORD_LENGTH: (output) This parameter will specify the actual size of
{       the record as it exists on the file when the last data of the
{       record is transferred.  It will be cumulative for a series of
{       partial record operations within a record.
{
{ TRANSFER_COUNT: (output) This parameter specifies the number of bytes
{       of data moved to the working_storage_area by this request.
{
{ BYTE_ADDRESS: (output) This parameter specifies the file byte address
{       of the beginning of the record being processed as a series of
{       partial records.  This value is only returned for files which reside
{       on mass storage devices.  It is not updated to point
{       to the beginning of each partial transfer.
{
{ FILE_POSITION: (output) This parameter specifies the position of the file
{       following this request.
{       The following file positions may be returned by this request:
{         amc$mid_record,
{         amc$eor,
{         amc$eop,
{         amc$eoi.
{
{ SKIP_OPTION: (input) This parameter specifies whether to advance to the
{       beginning of the next record before transferring data
{       (amc$skip_to_eor) or to start the transfer at the current position
{       (amc$no_skip). If the current file_position is not amc$mid_ record
{       then this option has no effect.
{       This option has no effect if the file consists of undefined records
{       with system specified blocking. In this case only the program knows
{       where the next record starts.
{
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$conflicting_access_level,
{                   ame$improper_file_id,
{                   ame$improper_input_attempt,
{                   ame$improper_record_header,
{                   ame$input_after_output
{                   ame$improper_skip_option,
{                   ame$improper_wsl_value,
{                   ame$input_after_eoi,
{                   ame$unrecovered_read_error,
{                   ame$accept_bad_block,
{                   ame$terminal_disconnected,
{                   ame$max_cancellable_input,
{                   ame$cancel_group_encountered.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$GET_SEGMENT_POINTER EXPAND=FALSE
{
{   The purpose of this request is to initialize a pointer to the virtual}
{ memory segment which was assigned by the system when the file}
{ was opened.}
{   It is necessary to obtain a pointer to the segment so that the file}
{ can be accessed as memory using machine instructions.}
{   This request returns a pointer of type cell, adaptable heap, or adaptable}
{ sequence.}
{   The access_mode specified when the file was opened determines the}
{ manner in which the virtual memory segment may be accessed.  If the file}
{ does not contain data, the access_mode must include pfc$append.  If any}
{ combination of pfc$append, pfc$modify or pfc$shorten are specified for a}
{ file, then write access is granted to the virtual memory segment.}
{   NOS/VE does not guarantee that the process segment number that is}
{ associated with the segment will be the same for each task accessing}
{ the segment; therefore process virtual addresses (PVA's) created by one}
{ task should not be used directly by another task. A linked structure that}
{ is to be shared between multiple tasks can be created by only storing the}
{ offset portion of the PVA in the structure and building a full PVA from}
{ it each time the structure is referenced.}
{   The content of the pointer variable is initialized as follows:}
{
{      amc$cell_pointer:}
{        .The byte offset portion of the PVA is set to the}
{         current_byte_address of the file.  The current_byte_address of the}
{         file will be determined based on the value specified for the}
{         private_read file attachment option for this instance of open.}
{         If true was specified, then the current_byte_address will be the}
{         position last attained by this instance of open.  If false was}
{         specified, then the current_byte_address will be the last position}
{         attained by any concurrent instances of open of this file.}
{}
{      amc$heap_pointer - pointer to adaptable heap:}
{        .The byte offset portion of the heap_pointer is set to the}
{         address of the first byte in the segment.}
{        .If the file is null in length, the LIMIT portion of the}
{         heap_pointer is set to the file_limit. The heap must be RESET}
{         by the CYBIL program.}
{        .If the file contains data the LIMIT portion of the heap_pointer}
{         is determined as follows:}
{           .If the file has an access_mode which includes pfc$read,}
{            pfc$modify or pfc$shorten but not pfc$append, the LIMIT}
{            is set to the eoi_byte_address of the file.}
{           .If the file has an access_mode which includes pfc$append,}
{            the LIMIT is set to the file_limit.}
{}
{      amc$sequence_pointer - pointer to adaptable sequence:}
{        .The byte offset portion of the sequence_pointer is set to the}
{         address of the first byte in the segment.}
{        .The NEXT portion of the sequence_pointer is set to the}
{         current_byte_address.}
{        .If the file is null in length, the LIMIT portion of the}
{         sequence_pointer is set to file_limit.}
{        .If the file contains data, the LIMIT portion of the}
{         sequence_pointer is determined as follows:}
{           .If the file has an access_mode which includes pfc$read,}
{            pfc$modify or pfc$shorten but not pfc$append, the LIMIT}
{            is set to the eoi_byte_address of the file.}
{           .If the file has an access_mode which includes pfc$append,}
{            the LIMIT is set to the file_limit.}
{
{   This request does not change the contents of the segment access file.}
{
{       AMP$GET_SEGMENT_POINTER (FILE_IDENTIFIER, POINTER_KIND,
{         SEGMENT_POINTER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ POINTER_KIND: (input) This parameter specifies the type of the pointer}
{       to be returned in the segment_pointer variable.}
{
{ SEGMENT_POINTER: (output) This parameter specifies a pointer to the}
{       segment associated with a file opened for segment access.}
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_id,
{                   ame$improper_pointer_kind,
{                   ame$read_of_empty_segment,
{                   ame$write_of_empty_segment.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$LOCK_FILE EXPAND=FALSE
{
{   The purpose of this request is to enable a task to access a file}
{ in a controlled manner when the possibility exists that the file }
{ may be shared by two or more tasks in the same job or in different jobs.}
{   This request is intended to provide a way for multiple accessors of a }
{ shared file to serialize their modifications to the file. The lock is}
{ stored in a shared space associated with the file which is maintained}
{ by the access method. Users of a shared amc$segment access file may}
{ choose to manage their own lock within the segment. This request is}
{ particularly useful to accessors who have no shared memory in which}
{ to store the lock and who need no finer granularity of lock than the whole}
{ file.}
{   If the file lock can be granted, then it will be set regardless of any}
{ outstanding i/o requests which a sharer or caller may have issued before}
{ the lock attempt. The access method does not prevent a sharer from doing}
{ i/o to a file locked by another task. Sharers must all use the same }
{ discipline to serialize their accesses reliably. The intended discipline}
{ is to obtain the lock, do the i/o and clear the lock.}
{   Any file locks set by a task will be unset at amp$close or task}
{ termination, if not previously cleared with an amp$unlock_file request.}
{
{       AMP$LOCK_FILE (FILE_IDENTIFIER, LOCK, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ LOCK: (output) This parameter specifies the result of the AMP$LOCK
{       request.  The options are:
{         amc$lock_set: the requested file lock has been set.
{         amc$already_set: the requested file lock has already been set
{                      by another job/task and has not been set for
{                      this job/task.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$OPEN EXPAND=FALSE
{}
{   The use of this request is discouraged.  FSP$OPEN_FILE should be used
{ instead.
{   The purpose of this request is to prepare a local file for access.}
{ This request validates access to the file. The caller of this request
{ must have sufficient privilege to access the file for the explicitly
{ specified or default mode(s) of access attempted.
{   The Access_level parameter is used to specify the means by which the
{ file will be accessed. Specification of amc$record access_level means
{ the task will access the file using GET and/or PUT requests.
{ Specification of amc$segment access_level means the task intends to
{ access the file as memory using machine instructions. An initialized
{ pointer to the segment can be obtained by issuing a subsequent}
{ amp$get_segment_pointer request.}
{   The Access_selections parameter performs a slightly different function}
{ depending upon whether a new or old file is opened. When a (new) file is}
{ opened for the first time, any structural attribute specified using this}
{ parameter is preserved with the file. When an old file is opened, any}
{ structural attribute value specified using this parameter must be identical}
{ to the preserved attribute value. A structural attribute is one which is}
{ preserved with the file. Any attribute value specified with this
{ parameter will take precedence over attributes specified using the}
{ SET_FILE_ATTRIBUTES command or the amp$file request. This parameter allows}
{ a task to control the values of preserved attributes for a new file}
{ and to be cautious about the type of file it accesses.}
{   It is recommended that the task specify the access_mode, if known by}
{ the task. Since the default for access_mode is derived from}
{ global_access_mode, the default may be too inclusive. For example,
{ if global_access_mode includes read and write (append,modify and/or shorten)
{ and the task needs only read access, then the default would include write}
{ which may put the file at risk due to a faulty program.}
{   This request returns a file_identifier. If the same file is opened
{ more than once, each instance of open of that file will be assigned a
{ unique file_identifier. The file_identifier is the 'key' by which
{ file access requests are associated with a particular instance of open
{ of a file. The file_identifier is invalidated by an amp$close request.
{ If the task fails to close its files, they are automatically closed
{ by the access method when the task terminates. The use of amp$close
{ is encouraged, but is not required. If the task has no further use for
{ a file, closing the file may allow more efficient usage of system resources.
{   When a file is opened, it may be opened at BOI, EOI, or it may inherit}
{ the position attained by the last accessor of the file. The open_position
{ may be specified using the access_selections parameter of this request,
{ the SET_FILE_ATTRIBUTES comand or the amp$file request.}
{   For any instance of open the amount of data which can be accessed}
{ sequentially is limited to 2,147 megabytes (2**31 bytes).}
{}
{       AMP$OPEN (LOCAL_FILE_NAME, ACCESS_LEVEL, ACCESS_SELECTIONS,
{         FILE_IDENTIFIER, STATUS)
{
{ LOCAL_FILE_NAME: ( input) This parameter specifies the local name of the}
{       file to be opened.}
{
{ ACCESS_LEVEL: (input) This parameter specifies the means by which the}
{       file will be accessed.  Segment access is only supported for mass}
{       storage files.  Record access is required if the file organization}
{       is indexed-sequential or if the file's device class is terminal or}
{       tape.}
{
{ ACCESS_SELECTIONS: (input) This parameter specifies one or more temporary
{       or structural attribute values to describe the file and the}
{       manner of the file access. The value NIL may be used to indicate}
{       that no attribute values have been supplied. The values specified
{       using this parameter take precedence over attribute values specified}
{       using the SET_FILE_ATTRIBUTES command or the amp$file request.}
{       Structural attributes specified for a new file are preserved with the}
{       file. Values of structural attributes specified with this parameter}
{       must match the preserved attribute values when an old file is opened.}
{{ FILE_IDENTIFIER: (output) This parameter specifies the file access}
{       identifier which is assigned to this instance of open of the file.}
{
{ STATUS: (ouput) This parameter specifies the request status.}
{       CONDITION:  ame$ring_validation_error,
{                   ame$attribute_validation_error,
{                   ame$damaged_file_attributes,
{                   ame$incompatible_file_connect,
{                   ame$improper_file_attrib_key,
{                   ame$improper_file_attrib_value,
{                   ame$local_file_limit,
{                   ame$concurrent_open_limit,
{                   ame$improper_access_level,
{                   ame$mbl_less_than_mibl,
{                   ame$mbl_less_than_mrl,
{                   ame$no_permission_for_access,
{                   ame$conflicting_file_access,
{                   ame$null_access_mode,
{                   ame$non_ANSI_blocking,
{                   ame$improper_record_override,
{                   ame$improper_override_access,
{                   ame$improper_write_override,
{                   ame$improper_ss_block_override,
{                   ame$improper_us_block_override,
{                   ame$improper_fo_override,
{                   ame$file_not_known,
{                   ame$new_file_requires_append,
{                   ame$improper_append_open,
{                   ame$fo_access_level_conflict,
{                   ame$fo_device_class_conflict,
{                   ame$not_virtual_memory_device,
{                   ame$not_physical_access_device,
{                   ame$unable_to_load_fap,
{                   ame$keyed_file_fap_missing,
{                   ame$unable_to_load_collate_tabl
{                   ame$unable_to_load_error_exit,
{                   ame$unable_to_load_label_exit,
{                   ame$terminal_task_limit,
{                   ame$concurrent_tape_limit,
{                   ame$multiple_open_of_tape,
{                   ame$no_write_ring.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$PACK_BLOCK_HEADER EXPAND=FALSE
{}
{   The purpose of this request is to build a block header in the}
{ user's buffer_area. The buffer_area may be located within a file opened}
{ with amc$segment access_level or in a space allocated by the program.}
{   The block header built by this request is compatible with one built}
{ by the access method when a amc$user_specified blocked file is created}
{ using amp$put requests. Thus a file created using this request may be}
{ read by a program which uses amp$get requests or amp$unpack_block_}
{ header.}
{   The file must be opened with amc$segment or amc$physical access_level}
{ and amc$user_specified block_type.}
{   If the label_type is amc$labelled, the block header will be recorded}
{ with the data written on a tape volume to aid reliability.  The length}
{ of the block header is fixed for all blocks in the file. The block}
{ header length is stored in the buffer_offset_length field of the}
{ ANSI standard HDR2 label for interchange purposes.}
{   This request performs a NEXT in the buffer_area sequence. When this}
{ request completes, the buffer_area variable contains a pointer to}
{ the first byte beyond the block header in the buffer. If insufficient}
{ space existed in the buffer for the block header, a NIL pointer is}
{ returned in the buffer_area variable along with abnormal status.}
{}
{       AMP$PACK_BLOCK_HEADER (FILE_IDENTIFIER, BUFFER_AREA, HEADER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file access}
{       identifier established when the file was opened.}
{}
{ BUFFER_AREA: (input-output) This parameter specifies the location within}
{       the user buffer at which the block header will be stored. This request}
{       returns the address of the first byte beyond the block header in the}
{       buffer. A NIL pointer and abnormal status are returned if}
{       insufficient space exists in the buffer for the block header. This}
{       request assumes that the block header and the block will be stored}
{       contiguously in the buffer.}
{}
{ HEADER: (input) This parameter specifies the contents of the block}
{       header to be packed into the user's buffer area. This parameter}
{       is a record which includes the following fields: }
{        Header_type - specifies the type of block header to be created.}
{        Block_length - specifies the number of bytes in the data block}
{                       which will follow the block header in the buffer.}
{        Block_number - specifies the ordinal of the block in the file.}
{                       Blocks are numbered beginning with one (1). All}
{                       blocks must be written in numerical order to}
{                       facilitate positioning of tape volumes during}
{                       error recovery.}
{        Unused_bit_count - specifies the number of bits in the last byte}
{                           of data in the block which do not contain valid}
{                           information. This is provided if the unit}
{                           of transfer between memory and the destination}
{                           is not a multiple of 8 bit bytes.}
{}
{ STATUS: (output) This parameter specifies request status.}
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.
{}
*DECK DECK=AMH$PACK_RECORD_HEADER EXPAND=FALSE
{
{   The purpose of this request is to build a record header in the}
{ user's buffer_area. The buffer_area may be located within a file opened}
{ with amc$segment access_level or in a space allocated by the program.}
{   The record header built by this request is compatible with one built}
{ using amp$put requests. Thus a file created using this request may}
{ be read by a program which uses amp$get requests or amp$unpack_record_}
{ header.}
{   This request may only be issued for a file opened with amc$segment or}
{ amc$physical access_level.}
{   If this request is issued for a file which does not have a record}
{ header, normal status is returned and the buffer_area variable is}
{ returned unchanged.}
{   This request performs a NEXT in the buffer_area sequence to allocate}
{ space for the record header in the buffer_area. The buffer_area}
{ variable is updated to point to the first byte beyond the record header}
{ in the buffer. If insufficient space exists in the buffer for the}
{ record header a NIL pointer is returned in the buffer_area variable}
{ and abnormal status is returned.}
{
{       AMP$PACK_RECORD_HEADER (FILE_IDENTIFIER, BUFFER_AREA, HEADER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ BUFFER_AREA: (input-output) This parameter specifies the location within}
{       the user buffer at which the record header will be placed. This}
{       request returns the address of the first byte beyond the record}
{       header in the buffer. A NIL pointer and abnormal status are returned}
{       if insufficient space exists in the buffer for the record header.}
{       This request assumes that the record header and the record will be}
{       stored contiguously in the buffer.}
{}
{ HEADER: (input) This parameter specifies the contents of the record}
{       header to be packed into the user's buffer_area. This parameter}
{       must be supplied but will be ignored if the record_type of the}
{       file is one which does not support  a record header.}
{       Not all fields of this parameter are applicable to record types other}
{       than amc$variable; no indication is given if such fields go unused.}
{       This parameter is a record which includes the following fields:}
{        Header_type - specifies type of record header to be written.}
{        Length - specifies the number of bytes of the record described by}
{                 this header.}
{        Previous_length - specifies the number of bytes in the preceding}
{                          record, exclusive of the previous header.}
{        Unused_bit_count - specifies the number of bits in the last byte of}
{                           this record which do not contain valid data.}
{        User_information - specifies a cell whose value is defined by the}
{                           user. This information is stored in the record}
{                           header but its value may only be obtained with}
{                           the amp$unpack_record_header request, i.e. it}
{                           is not returned if the record is read with}
{                           amp$get requests.}
{}
{ STATUS: (output) this parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$PUT EXPAND=FALSE
{}
{   The purpose of this request is to unpack a block header located in}
{ the user's buffer_area. The buffer_area itself may be located within}
{ a file opened with amc$segment access_level or in a space allocated}
{ by the program.}
{   This request may be used to unpack block headers built by the access}
{ method when an amc$user_specified blocked file was created using}
{ amp$put requests or using amp$pack_block_header.}
{   The file must be opened with amc$segment or amc$physical access_level}
{ and amc$user_specified block_type.}
{   This request performs a NEXT in the buffer_area sequence. When this}
{ request completes, the buffer_area variable contains a pointer to}
{ the first byte beyond the block header in the buffer. If insufficient}
{ space existed in the buffer for the block header, a NIL pointer is}
{ returned in the buffer_area variable along with abnormal status.}
{}
{       AMP$UNPACK_BLOCK_HEADER (FILE_IDENTIFIER, BUFFER_AREA, HEADER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file access}
{       identifier established when the file was opened.}
{}
{ BUFFER_AREA: (input-output) This parameter specifies the location within}
{       the user buffer of the block header which is to be unpacked. This}
{       request returns the address of the first byte beyond the block}
{       header in the buffer. A NIL pointer and abnormal status are}
{       returned if a full block header was not available in the buffer.}
{       This request assumes that the block header and the block have been}
{       contiguously stored in the buffer prior to this request.}
{}
{ HEADER: (output) This parameter specifies the contents of the unpacked}
{       block header. This parameter is a record which includes the}
{       fields: }
{        Header_type - specifies the type of the block header which was}
{                      unpacked.}
{        Block_length_as_read - specifies the number of bytes in the data}
{                               block as reported by the equipment driver.}
{        Block_length_as_written - specifies the number of bytes of data}
{                                  which were originally written to the}
{                                  device in the block. If block headers}
{                                  are not recorded on the tape volume or}
{                                  if this is a mass storage file, this}
{                                  field is set equal to block_length_as_read.}
{                                  It is the user's responsibility to}
{                                  interpret any discrepancy between the}
{                                  block_length_as_written and the block_}
{                                  length_as_read.}
{        Block_number - specifies the ordinal position of this block in}
{                       the file.}
{        Unused_bit_count - specifies the number of bits in the last}
{                           byte of the block which do not contain valid}
{                           information. If block headers are not recorded}
{                           on the tape volume or if this is a mass storage}
{                           file, this field is undefined.}
{        Block_status - specifies if an error was detected while reading}
{                       the block and if so, whether or not the error}
{                       was recoverable.}
{}
{ STATUS: (output) This parameter specifies request status.}
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.
{}
*DECK DECK=AMH$PUT_DIRECT EXPAND=FALSE
{
{   The purpose of this request is to transfer a record from the user's
{ working storage area to a file opened with amc$record access_level
{ and amc$byte_addressable or amc$sequential file_organization.
{   If the record_type is amc$ansi_fixed, the record is padding_character
{ filled, if necessary.
{   This request will establish a new end of information (EOI) if the sum
{ of byte_address and working_storage_length exceeds the current EOI.
{ If the file_organization is sequential then EOI will be affected in the
{ same fashion as by amp$put_next on a sequential file.
{
{ Note: only when the file_organization is sequential can a put operation
{ shorten a file.
{
{ It is the user's responsibility to ensure that a record being
{ replaced  is the same length as the original.
{
{       AMP$PUT_DIRECT (FILE_IDENTIFIER, WORKING_STORAGE_AREA,
{         WORKING_STORAGE_LENGTH, BYTE_ADDRESS, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ WORKING_STORAGE_AREA: (input) This parameter specifies the address of the}
{       record to be output.}
{}
{ WORKING_STORAGE_LENGTH: (input) This parameter specifies the length of the}
{       record to be output.}
{
{ BYTE_ADDRESS: (input) This parameter specifies the file byte address
{       of where the record is to be placed in the file.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$conflicting_access_level,
{                   ame$improper_file_byte_address,
{                   ame$improper_seek_address,
{                   ame$position_beyond_eoi,
{                   ame$position_beyond_file_limit,
{                   ame$put_beyond_file_limit,
{                   ame$improper_file_id,
{                   ame$file_organization_conflict,
{                   ame$fo_block_type_conflict,
{                   ame$improper_output_attempt,
{                   ame$record_exceeds_mbl,
{                   ame$improper_wsl_value,
{                   ame$unrecovered_write_error,
{                   ame$terminal_disconnected.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$PUT_LABEL EXPAND=FALSE
*DECK DECK=AMH$PUT_NEXT EXPAND=FALSE
{
{   The purpose of this request is to transfer a record from the user's
{ working storage area to the "next" location in a file opened with}
{ amc$record access_level.}
{   If the record_type is amc$ansi_fixed, the record is padding_character}
{ filled, if necessary.}
{   This request will unconditionally establish end of information (EOI)}
{ when issued on a file opened with amc$sequential file_organization.}
{   This request will establish a new end of information (EOI) if the sum}
{ of byte_address and working_storage_length exceeds the current EOI.}
{   If the file_position is amc$mid_record when this request is issued, the}
{ preceding partial record is terminated prior to data movement initiated by}
{ this request.}
{}
{       AMP$PUT_NEXT (FILE_IDENTIFIER, WORKING_STORAGE_AREA,
{         WORKING_STORAGE_LENGTH, BYTE_ADDRESS, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ WORKING_STORAGE_AREA: (input) This parameter specifies the address of the}
{       record to be output.}
{}
{ WORKING_STORAGE_LENGTH: (input) This parameter specifies the length of the}
{       record to be output.}
{
{ BYTE_ADDRESS: (output) This parameter specifies the address of the start}
{       of the record which has been output. This address could be saved in a}
{       directory for subsequent random access to the record. This parameter}
{       is only returned for mass storage files.}
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$conflicting_access_level,
{                   ame$improper_file_id,
{                   ame$improper_output_attempt,
{                   ame$put_beyond_file_limit,
{                   ame$record_exceeds_mbl,
{                   ame$improper_wsl_value,
{                   ame$unrecovered_write_error,
{                   ame$terminal_disconnected.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$PUT_PARTIAL EXPAND=FALSE
{
{   The purpose of this request is to transfer a partial record from the
{ user's working storage area to the "next" location in a file opened}
{ with amc$record access_level.}
{   This request is provided for exceedingly long records which would}
{ otherwise require an impractical working storage length.}
{   The output of a complete record occurs as a result of one or more}
{ amp$put_partial requests.  The first portion of the record is output}
{ specifying a term_option of amc$start. Intermediate portions of the}
{ record are output specifying a term_option of amc$continue.  The final}
{ portion of the record is output specifying a term_option of amc$terminate.}
{   A request specifying a term_option of amc$start may be issued regardless}
{ of the current file_position.  If the current file_position is amc$mid_}
{ record, then the previous partially constructed record is terminated}
{ and a new partially constructed record is begun. A request specifying}
{ a term_option of amc$start causes the file_position to be set to}
{ amc$mid_record.}
{   A request specifying a term_option of amc$continue may be issued only}
{ when the current file_position is amc$mid_record.  The file_position}
{ remains amc$mid_record.}
{   A request specifying a term_option of amc$terminate may be issued}
{ regardless of the current file_position.  If the current file_position}
{ is not amc$mid_record, then the request is functionally equivalent to an}
{ amp$put_next; the final portion of the record also happens to be the}
{ initial portion of the record.  If the current file_position is}
{ amc$mid_record, then the final portion of the record is output and}
{ the record is terminated.  A request specifying a term_option of}
{ amc$terminate causes the file_position to be set to amc$eor.}
{}
{       AMP$PUT_PARTIAL (FILE_IDENTIFIER, WORKING_STORAGE_AREA,
{         WORKING_STORAGE_LENGTH, BYTE_ADDRESS, TERM_OPTION, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ WORKING_STORAGE_AREA: (input) This parameter specifies the address of}
{       the full or partial record which is to be output.}
{
{ WORKING_STORAGE_LENGTH: (input) This parameter specifies the number
{       of bytes to be output.
{
{ BYTE_ADDRESS: (output) This parameter specifies the file address of the}
{       start of the record which has been output. This address may be saved}
{       in a directory for subsequent random access to the record. A value
{       is initially returned when the term_option is amc$start; the same}
{       value is returned after subsequent partial outputs of the record.}
{       A value is only returned for mass storage files.}
{
{ TERM_OPTION: (input) This parameter specifies which portion of the record}
{       is being output.}
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$conflicting_access_level,
{                   ame$improper_file_id,
{                   ame$improper_output_attempt,
{                   ame$put_beyond_file_limit,
{                   ame$record_exceeds_mbl,
{                   ame$improper_term_option,
{                   ame$improper_continue,
{                   ame$improper_wsl_value,
{                   ame$unrecovered_write_error,
{                   ame$terminal_disconnected.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$READ EXPAND=FALSE
{
{   The purpose of this request is to retrieve data from the "next"
{ physical position of a file opened with amp$physical access_level.}
{ The operation of this request is device dependent, as follows:}
{}
{ MASS STORAGE:}
{}
{   The intended use of this request is to transfer a full allocation_unit}
{ worth of data. The maximum amount of data which can be transferred}
{ in a single request is constrained by the number of bytes in the}
{ allocation_unit specified for the file.}
{}
{ MAGNETIC TAPE - AMC$SYSTEM_SPECIFIED BLOCK_TYPE:}
{}
{ The transfer will begin and end on a tape block boundary. One or more}
{ consecutive tape blocks may be transferred with a single request. The}
{ buffer_length must be at least the size of one system_specified block}
{ (4096 bytes in length). The number of system_specified blocks which}
{ could fit in the buffer_area is the maximum number of blocks which will}
{ be transferred in a single request. All blocks are the same length, except}
{ the last block is permitted to be shorter than the system_specified}
{ block length.}
{}
{ MAGNETIC TAPE - AMC$USER_SPECIFIED BLOCK_TYPE:}
{}
{ The transfer will begin and end on a tape block boundary. One or more}
{ consecutive tape blocks may be transferred with a single request. Each}
{ block in the buffer will be prefixed by a block header which describes}
{ the block content. This block header is provided by the access method}
{ on a read and provided by the caller on a write. The amp$pack_block_header}
{ and amp$unpack_block_header requests are provided to access the header.}
{ The buffer_length must be at least the size of one user_specified block.}
{ The maximum length of a user_specified block is the sum of the two file}
{ attributes MAX_BLOCK_LENGTH and BLOCK_HEADER_LENGTH.}
{ The result of the division of buffer_length by the maximum length}
{ of the user_specified block is the maximum number of blocks which will}
{ be transferred by this request.}
{ A block header will prefix each block moved into the buffer_area.}
{}
{       AMP$READ (FILE_IDENTIFIER, BUFFER_AREA, BUFFER_LENGTH,
{         BYTE_ADDRESS, TRANSFER_COUNT, WAIT, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ BUFFER_AREA: (input) This parameter specifies the users buffer area into
{       which the data is transferred.
{
{ BUFFER_LENGTH: (input) This parameter specifies the maximum number
{       of bytes to be moved into the buffer.  The buffer length must
{       be a multiple of the MAU size for a mass storage file.  For a
{       tape file the buffer_length must exceed the maximum block_length
{       for the file.
{
{ BYTE_ADDRESS: (output) This parameter indicates the file byte address
{       associated with the beginning of the transfer.  This value is
{       only returned for mass storage devices.
{
{ TRANSFER_COUNT: (output) This parameter specifies the number of
{       bytes actually transferred to the buffer. This parameter is not}
{       modified by BAM if the WAIT parameter is amc$nowait. The}
{       amp$check_buffer request may be used to determine the transfer_count}
{       of a completed amc$nowait request.}
{
{ WAIT: (input) This parameter specifies the action to be taken following
{       initiation of the transfer.  Options include:
{         wait: Don't return control until the operation is complete.
{         nowait: Return control to the user even though the operation
{                 may not be complete.  The AMP$CHECK_BUFFER request
{                 must be used to determine completion.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.
{

*DECK DECK=AMH$READ_DIRECT EXPAND=FALSE
{
{   The purpose of this request is to retrieve data from a mass storage}
{ file opened with amc$physical access_level.}
{   An abnormal STATUS will be generated if the byte_address specified is not}
{ on a disk minimum_addressable_unit (MAU) boundary. The buffer_length}
{ must be a multiple of MAU size or abnormal STATUS will be issued.}
{   The intended use of this request is to transfer a full allocation_unit}
{ worth of data.  The maximum amount of data which can be transferred in}
{ a single request is constrained by the number of bytes in the}
{ allocation_unit specified for the file. The maximum amount of data}
{ which can be transferred in a request is one minimum_addressable_unit}
{ (MAU).}
{
{       AMP$READ_DIRECT (FILE_IDENTIFIER, BUFFER_AREA, BUFFER_LENGTH,
{         BYTE_ADDRESS, TRANSFER_COUNT, WAIT, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ BUFFER_AREA: (input) This parameter specifies the user's buffer area
{       into which the data is transferred.
{
{ BUFFER_LENGTH: (input) This parameter specifies the maximum number
{       of bytes to be moved into the buffer. The buffer_length
{       must be a multiple of the MAU size.
{
{
{ BYTE_ADDRESS: (input) This parameter specifies the byte address at which
{       the transfer is to begin.
{
{ TRANSFER_COUNT: (output) This parameter specifies the number of
{       bytes actually transferred to the buffer. This parameter is not}
{       modified by BAM if the WAIT parameter is amc$nowait. The}
{       amp$check_buffer request may be used to determine the transfer_count}
{       of a completed amc$nowait request.}
{
{ WAIT: (input) This parameter specifies the action to be taken following
{       initiation of the transfer.  Options include:
{         wait: Don't return control until the request is complete.
{         nowait: Return control to the user even though the request
{                 may not be complete.  The AMP$CHECK_BUFFER request must
{                 be used to determine completion.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$READ_DIRECT_SKIP EXPAND=FALSE
{
{   The purpose of this request is to retrieve data from a mass storage}
{ file opened with amc$physical access_level.}
{   An abnormal STATUS will be generated if the byte_address specified is not}
{ on a  minimum addressable unit (MAU) boundary.
{   Unlike the amp$read_direct request, the buffer_length need not be a}
{ multiple of the MAU size.  If it is not a multiple, the excess data}
{ in the last MAU will be skipped. Normal STATUS will be returned in this}
{ event.}
{   This request may be used to transfer a whole allocation_unit. However, the}
{ intended use of this request is to transfer less than an allocation_unit}
{ worth of data.  The maximum amount of data which can be transferred}
{ in a single request is constrained by the number of bytes in the}
{ allocation_unit specified for the file.}
{
{       AMP$READ_DIRECT_SKIP (FILE_IDENTIFIER, BUFFER_AREA, BUFFER_LENGTH,
{         BYTE_ADDRESS, TRANSFER_COUNT, WAIT, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ BUFFER_AREA: (input) This parameter specifies the user's buffer area
{       into which the data is transferred.
{
{ BUFFER_LENGTH: (input) This parameter specifies the maximum number
{       of bytes to be moved into the buffer.
{
{ BYTE_ADDRESS: (input) This parameter specifies the byte address at which
{       the transfer is to begin.
{
{ TRANSFER_COUNT: (output) This parameter specifies the number of
{       bytes actually transferred to the buffer. This parameter is not}
{       modified by BAM if the WAIT parameter is amc$nowait. The}
{       amp$check_buffer request may be used to determine the transfer_count}
{       of a completed amc$nowait request.}
{
{ WAIT: (input) This parameter specifies the action to be taken following
{       initiation of the transfer.  Options include:
{         wait: Don't return control until the request is complete.
{         nowait: Return control to the user even though the request
{                 may not be complete.  The AMP$CHECK_BUFFER request must
{                 be used to determine completion.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$READ_SKIP EXPAND=FALSE
{
{   The purpose of this request is to retrieve data from the "next"}
{ physical position of a file opened with amp$physical access_level.}
{ This request differs from the amp$read request only in that the}
{ buffer_length is not constrained to a multiple of the MAU or tape}
{ block length. If it is not a multiple, the excess data in the last}
{ MAU or tape block will be skipped. Normal STATUS will be returned.}
{ The operation of this request is device dependent, as follows:}
{}
{ MASS STORAGE:}
{}
{   This request may be used to transfer a whole allocation_unit. However, the}
{ intended use of this request is to transfer less than an allocation_unit}
{ worth of data. The maximum amount of data which can be transferred}
{ in a single request is constrained by the number of bytes in the}
{ allocation_unit specified for the file.}
{}
{ MAGNETIC TAPE - AMC$SYSTEM_SPECIFIED BLOCK_TYPE:}
{}
{ The transfer will begin and end on a tape block boundary. One or more}
{ consecutive tape blocks may be transferred with a single request. }
{ The number of system_specified blocks which}
{ could fit in the buffer_area is the maximum number of blocks which will}
{ be accessed by this request. All blocks are the same length, except}
{ the last block is permitted to be shorter than the system_specified}
{ block length.}
{}
{ MAGNETIC TAPE - AMC$USER_SPECIFIED BLOCK_TYPE:}
{}
{ The transfer will begin and end on a tape block boundary. One or more}
{ consecutive tape blocks may be transferred with a single request. Each}
{ block in the buffer will be prefixed by a block header which describes}
{ the block content. This block header is provided by the access method}
{ on a read and provided by the caller on a write. The amp$pack_block_header}
{ and amp$unpack_block_header requests are provided to access the header.}
{ The maximum length of a user_specified block is the sum of the two file}
{ attributes MAX_BLOCK_LENGTH and BLOCK_HEADER_LENGTH.}
{ The result of the division of buffer_length by the maximum length}
{ of the user_specified block is the maximum number of blocks which}
{ will be accessed by this request.}
{ A block header will prefix each block or partial block moved into the}
{ buffer_area.}
{}
{       AMP$READ_SKIP (FILE_IDENTIFIER, BUFFER_AREA, BUFFER_LENGTH,
{         BYTE_ADDRESS, TRANSFER_COUNT, WAIT, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ BUFFER_AREA: (input) This parameter specifies the users buffer area into
{       which the data is transferred.
{
{ BUFFER_LENGTH: (input) This parameter specifies the maximum number
{       of bytes to be moved into the buffer.
{
{ BYTE_ADDRESS: (output) This parameter indicates the file byte address
{       associated with the beginning of the transfer.  This value is
{       only returned for mass storage files.
{
{ TRANSFER_COUNT: (output) This parameter specifies the number of
{       bytes actually transferred to the buffer. This parameter is not}
{       modified by BAM if the WAIT parameter is amc$nowait. The}
{       amp$check_buffer request may be used to determine the transfer_count}
{       of a completed amc$nowait request.}
{
{ WAIT: (input) This parameter specifies the action to be taken following
{       initiation of the transfer.  Options include:
{         wait: Don't return control until the operation is complete.
{         nowait: Return control to the user even though the operation
{                 may not be complete.  The AMP$CHECK_BUFFER request
{                 must be used to determine completion.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.
{

*DECK DECK=AMH$RENAME EXPAND=FALSE
{
{   The purpose of this request is to change the local name of a file.}
{ This request does not change the names by which files are known to the}
{ permanent file system.}
{   This request is rejected if the old_file_name is not the name of a file}
{ local to the job.}
{   This request is rejected if new_file_name is already a local file.}
{   This request requires that all instances of open of the old_file_name}
{ and the new_file_name be closed prior to this request, or this request}
{ will be rejected.}
{}
{       AMP$RENAME (OLD_FILE_NAME, NEW_FILE_NAME, STATUS)
{
{ OLD_FILE_NAME: (input) This parameter specifies the local name which}
{       is to be changed.}
{}
{ NEW_FILE_NAME: (input) This parameter specifies the new local name}
{       of the file.}
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$file_not_closed,
{                   ame$rename_old_not_local,
{                   ame$rename_new_is_local.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$REPLACE EXPAND=FALSE
{
{   The purpose of this request is to replace the record obtained through
{ an immediately preceding retrieval request with the content of the record
{ in a user's working storage area.  The new record must be the same
{ size as the original record.  If the record type is amc$ansi_fixed,
{ then the record will be padding_character filled, if necessary.  The
{ current_byte_address of the record is not changed as a result of this
{ request.  The request is only valid for mass storage files opened with
{ amc$record access_level.
{ An abnormal STATUS will be returned and this request will be ignored
{ if the preceding request was not one of the versions of GET.
{
{       AMP$REPLACE (FILE_IDENTIFIER, WORKING_STORAGE_AREA,
{         WORKING_STORAGE_LENGTH, STATUS)
{
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ WORKING_STORAGE_AREA: (input) This parameter specifies the address of the}
{       record which is to replace an existing record of the file.}
{}
{ WORKING_STORAGE_AREA: (input) This parameter specifies the length of the}
{       record to be output.}
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.
{

*DECK DECK=AMH$REPLACE_DIRECT EXPAND=FALSE
{
{   The purpose of this request is to replace the record identified by the
{ file byte address with the content of a record in a users working
{ storage area.  The new record must be the same size as the
{ original record.  If the record type is fixed length (F), then
{ padding will be performed if necessary.  The file byte address of the
{ record is not changed as a result of this request.  The request is
{ only valid for byte addressable files.
{
{       AMP$REPLACE_DIRECT (FILE_IDENTIFIER, WORKING_STORAGE_AREA,
{         WORKING_STORAGE_LENGTH, BYTE_ADDRESS, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ WORKING_STORAGE_AREA: (input) This parameter specifies the address of the}
{       record which is to replace an existing record of the file.}
{}
{ WORKING_STORAGE_AREA: (input) This parameter specifies the length of the}
{       record to be output.}
{
{ BYTE_ADDRESS: (input) This parameter specifies the file byte
{       address of the record to be replaced.
{
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.
{

*DECK DECK=AMH$REPLACE_PREVIOUS_RECORD EXPAND=FALSE
{
{   The purpose of this request is to replace an entire record.
{   This request is valid only for mass storage files opened for
{ sequential record access.
{   The file position must be at the end of the record to be replaced.
{ The file position remains at the end of the record replaced.
{   The length of the replacement record must be identical to the
{ length of the previous record for a file whose record-type is
{ CDC-variable (V).  Note the length of the previous record is exclusive
{ of V record-headers, i.e. only the logical length of the records must
{ be identical.  Therefore, a record output with a series of partial PUTs
{ can be replaced.
{   For a file whose record-type is ANSI-fixed (F), the replacement
{ record will be truncated to maximum-record-length, if the replacement
{ record exceeds maximum-record-length.
{   The length of the replacement record must be equal to the length of the
{ previous record for a file whose record-type is undefined (U)
{ and whose block-type is user-specified.
{   Note that a record deleted by an amp$delete_previous_record(*) request
{ cannot be replaced because one cannot position to the end of a deleted
{ record.
{   This request is not supported for a file whose record-type is
{ undefined (U) or trailing_character_delimited (T) and whose block-type is
{ system-specified.
{
{   This request requires 'modify' access to the file.
{
{       AMP$REPLACE_PREVIOUS_RECORD (FILE_IDENTIFIER, WORKING_STORAGE_AREA,
{         WORKING_STORAGE_LENGTH, STATUS)
{
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ WORKING_STORAGE_AREA: (input) This parameter specifies the address of the
{       record which is to replace an existing record of the file.
{
{ WORKING_STORAGE_LENGTH: (input) This parameter specifies the length of the
{       record to be output.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_id,
{                   ame$improper_access_attempt,
{                   ame$improper_wsl_value,
{                   ame$improper_file_position,
{                   ame$unrecovered_write_error,
{                   ame$file_organization_conflict,
{                   ame$improper_device_class,
{                   ame$conflicting_access_level,
{                   ame$record_exceeds_mbl,
{                   ame$record_unequal_to_previous,
{                   ame$unsupported_operation;
{       IDENTIFIER: amc$access_method_id.
{

*DECK DECK=AMH$RETURN EXPAND=FALSE
{
{   The purpose of this request is to detach a file from the job.  For a
{ temporary file, this request also deletes the registration of the file in
{ the temporary catalog.
{
{   This request requires that there be no outstanding instances of open of
{ the file within the job.  Otherwise, this request will be rejected.
{
{   If the file is an attached permanent file, the attachment of the file to
{ the job ends with this request.  The space that the permanent file occupies
{ is unaffected by this request.
{
{   If the file is a temporary mass storage file, the file information is
{ destroyed, i.e.  the mass storage space once assigned to the file is
{ returned to the system.
{
{   If the file is a magnetic tape file, the tape storage device currently
{ assigned to file, if any, is detached from the job after the medium is
{ dismounted; information on the tape volume(s) accessed by the job is
{ unaffected by this request.
{
{       AMP$RETURN (FILE, STATUS)
{
{ FILE: (input)  This parameter specifies the name of the file to be returned.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$file_not_closed,
{                   ame$file_not_known.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$REWIND EXPAND=FALSE
{
{   The purpose of this request is to reposition to the beginning of
{ information of the file.  This request has meaning only for files opened
{ with amc$record access_level.
{
{   If the file_instance specified was opened for private_read then only
{ that instance will be repositioned to the the beginning of information.
{ If the file_instance specified was not opened for private_read then all
{ instances of open for the file will be repositioned.
{
{   For a file associated with tape for which the preceding operation was an
{ output, the file and volume are terminated according to convention.  If the
{ label_type is amc$labelled, the standard ANSI EOF labels are written.  If a
{ label_exit_procedure(*) was specified, control passes to this procedure for
{ user label processing.  For all label types, two tapemarks are then written
{ to terminate the file and volume.
{
{   If the label_type is amc$labelled and the HDR1 label corresponding to this
{ instance of open of the tape file is not on the current volume, the current
{ volume is dismounted and the volume containing the HDR1 label is mounted.
{ The HDR1 for the ANSI file is then located and the HDR labels are validated.
{ The file is then positioned after the tapemark following the HDR label
{ group.
{
{   If the label_type is amc$unlabelled or amc$non_standard_labelled, the
{ file is positioned at the beginning of the first volume in the list of
{ volumes associated with the tape file.  Refer to the REQUEST_MAGNETIC_TAPE
{ command and the rmp$request_tape program interface.
{
{   If a label_exit_procedure(*) was specified, control passes to this
{ procedure for user label processing after the system HDR labels have been
{ processed by the access method.
{
{       AMP$REWIND (FILE_IDENTIFIER, WAIT, STATUS)
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the file access
{       identifier established when the file was opened.
{
{ WAIT: (input)  This parameter specifies the action to be taken if the rewind
{       can not be completed without causing a physical I/O operation to be
{       submitted.  wait:  Don't return control until the operation is
{       complete.  nowait:  Return control to the user even though the
{       operation may not be complete.  The AMP$FETCH_ACCESS_INFORMATION
{       request may be used to determine the last_op_status.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$accessibility_conflict,
{                   ame$block_type_conflict,
{                   ame$file_set_id_conflict,
{                   ame$fsn_out_of_sequence,
{                   ame$improper_access_level,
{                   ame$non_ansi_labels,
{                   ame$record_type_conflict,
{                   ame$ring_validation_error,
{                   ame$section_out_of_sequence,
{                   ame$tape_end_of_volume_list,
{                   ame$unrecovered_write_error.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$REWIND_VOLUME EXPAND=FALSE
{
{   The purpose of this request is to reposition to the beginning}
{ of the information on the current volume. This request is intended for}
{ files which span volumes. If the file resides on a single volume, the}
{ effect of this request is the same as amp$rewind. This request has meaning}
{ only for files opened with amc$record or amc$physical access_level.}
{   Any modified data residing in memory is flushed to the current volume.}
{ Any outstanding no_wait requests are completed before the repositioning}
{ is attempted.}
{   If the label_type is amc$labelled and the preceding operation was an}
{ output, a standard ANSI EOF label group is written.}
{   If the label_type is amc$unlabelled and the preceding operation was an}
{ output, the file is terminated with two tapemarks.}
{   The result of this request is that the current volume is rewound}
{ and positioned beyond the label group at the beginning of the volume,}
{ if such a label group exists.}
{   If a label_exit_procedure was specified, control will be passed to this}
{ procedure if labels matching the label_options attribute are encountered}
{ during this process.}
{}
{       AMP$REWIND_VOLUME (FILE_IDENTIFIER, WAIT, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ WAIT: (input) This parameter specifies the action to be taken
{       if the rewind_volume can not be completed without causing
{       a physical I/O operation to be submitted.
{         wait: Don't return control until the operation is complete.
{         nowait: Return control to the user even though the operation
{                 may not be complete.  The AMP$FETCH_ACCESS_INFORMATION
{                 request may be used to determine the last_op_status.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_id,
{                   ame$conflicting_access_level,
{                   ame$unrecovered_write_error.
{       IDENTIFIER: amc$access_method_id.
{

*DECK DECK=AMH$SEEK_DIRECT EXPAND=FALSE
{
{   The purpose of this request is to change the current_byte_address of
{ a file opened with amc$record access_level and amc$byte_addressable or
{ amc$sequential file_organization. This request does nothing to change the
{ physical position of the mass storage device assigned to the file. This
{ request is provided to allow the logical position of the file to be set prior
{ to issuing an amp$get_next or amp$get_partial request. Note that the
{ amp$get_direct request performs an implicit seek_direct prior to record
{ movement.
{
{       AMP$SEEK_DIRECT (FILE_IDENTIFIER, BYTE_ADDRESS, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ BYTE_ADDRESS: (input) This parameter specifies the file byte address of
{       the record to be located.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$conflicting_access_level,
{                   ame$position_beyond_eoi,
{                   ame$position_beyond_file_limit,
{                   ame$improper_access_attempt,
{                   ame$improper_seek_address,
{                   ame$improper_file_id,
{                   ame$file_organization_conflict,
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$SET_FILE_INSTANCE_ABNORMAL EXPAND=FALSE

{}
{   The purpose of this request to set a status variable to represent an}
{ abnormal condition.}
{   This request is provided primarily for the file_access_procedure writer}
{ to enable him/her to initialize the status variable according to access}
{ method conventions.}
{   This request is intended to be used in situations where the detected}
{ condition is peculiar to an instance of open and the file_identifier is}
{ valid. If the file_identifer is invalid then use osp$set_status_abnormal.}
{   If the caller of this request believes that the file_identifier is valid}
{ and this request determines that it is invalid, only fixed parameters}
{ 2 and 8 will be initialized.}
{   Use osp$append_status_parameter to include additional parameters.}
{}
{       AMP$SET_FILE_INSTANCE_ABNORMAL (FILE_IDENTIFIER,
{         EXCEPTION_CONDITION;REQUEST_CODE, TEXT, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the identity of the}
{       instance of open of a file for which an exception condition has}
{       been detected.}
{}
{ EXCEPTION_CONDITION: (input) This parameter specifies the condition}
{       code for the abnormal condition.}
{}
{ REQUEST_CODE: (input) This parameter specifies the access method request}
{       code. This identifies the access method request which detected the}
{       exception_condition.}
{}
{ TEXT: (input) This parameter specifies text to be included in the status}
{       for the exception_condition. By convention this interface}
{       will initialize the first 7 parameters in status.text as follows:}
{         1. Local_file_name.}
{         2. Name of access method request which detected condition.}
{         3. Access_level.}
{         4. File_organization.}
{         5. Record_type.}
{         6. Block_type.}
{         7. Reserved for access method internal use.}
{       The eighth parameter is initialized to the value of this parameter.}
{}
{ STATUS: (output) This parameter specifies the status variable which is}
{       to be initialized by this request.}
{}
*DECK DECK=AMH$SET_LOCAL_NAME_ABNORMAL EXPAND=FALSE

{}
{   The purpose of this request to set a status variable to represent an}
{ abnormal condition.}
{   This request is provided primarily for the file_access_procedure writer}
{ to enable him/her to initialize the status variable according to access}
{ method conventions.}
{   This request is intended to be used in situations where the local name}
{ is known but the error is not peculiar to an instance of open of the file.}
{ To set abnormal status for an instance of open, use}
{ amp$set_file_instance_abnormal. If neither the local_file_name nor the}
{ file_identifier are known use osp$set_status_abnormal.}
{   Use osp$append_status_parameter to include additional parameters.}
{}
{       AMP$SET_LOCAL_NAME_ABNORMAL (LOCAL_FILE_NAME,
{         EXCEPTION_CONDITION, REQUEST_CODE, TEXT, STATUS)
{}
{ LOCAL_FILE_NAME: (input) This parameter specifies the local name of the}
{       file for which an exception condition has been detected.}
{}
{ EXCEPTION_CONDITION: (input) This parameter specifies the condition}
{       code for the abnormal condition.}
{}
{ REQUEST_CODE: (input) This parameter specifies the access method request}
{       code. This identifies the access method request which detected the}
{       condition.}
{}
{ TEXT: (input) This parameter specifies text to be included in the status}
{       for the exception_condition. By convention this interface}
{       will intialize the first 7 parameters in status.text to the following:
{         1. Local_file_name.}
{         2. Name of access method request which detected condition.}
{         3. null string.}
{         4. null string.}
{         5. null string.}
{         6. null string.}
{         7. Reserved for access method internal use.}
{       The eighth parameter is initialized to the value of this parameter.}
{}
{ STATUS: (output) This parameter specifies the status variable which is}
{       to be initialized by this request.}
{}
*DECK DECK=AMH$SET_SEGMENT_EOI EXPAND=FALSE
{
{   The purpose of this request is to preserve the EOI byte address of a file}
{ opened for segment access. This request should be used after writing a new}
{ file or after appending information to an old file. Also this request may}
{ be used to record EOI after shortening an old file. The user must have}
{ pfc$append permission to the file to increase the EOI byte address and}
{ pfc$shorten permission to decrease EOI.}
{   If after appending data to a file this request is omitted, then the
{ NOS/VE system will preserve a default value for the EOI byte address.}
{ However, the default value of EOI will be the address of the page beyond
{ the highest page referenced by the program.  Thus if this request is not}
{ used to preserve the actual EOI, a subsequent reader of the file may obtain}
{ data which is not logically a part of the file.  Because there is no concept}
{ of position wihin a CYBIL heap, EOI is managed by the NOS/VE system.  This}
{ request cannot be used to preserve EOI for a file accessed as a CYBIL heap.}
{   If this request is used to shorten an old file, pages beyond the new
{ EOI byte address are discarded.  If the EOI byte address is within a
{ page, that page is retained; data within the last page and beyond
{ the EOI byte address will remain as before the shorten operation.}
{   This request unconditionally sets the current position of the file to}
{ the EOI byte address.  Specifically, the current_byte_address and the}
{ global_file_address are each set to EOI.}
{   This request may be issued repeatedly throughout the task's use of}
{ the file.}
{
{       AMP$SET_SEGMENT_EOI (FILE_IDENTIFIER, SEGMENT_POINTER,STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{
{ SEGMENT_POINTER: (input) This parameter specifies the address within the
{       segment of the new EOI of the file.
{
{ STATUS: (output) This request specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_id,
{                   ame$improper_segment_number,
{                   ame$improper_segment_pointer,
{                   ame$set_eoi_needs_append,
{                   ame$set_eoi_needs_shorten,
{                   ame$set_on_adaptable_heap.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$SET_SEGMENT_POSITION EXPAND=FALSE
{
{   The purpose of this request is to set the current position of a file}
{ opened for segment access. This request will extract the}
{ byte_offset portion of an amc$cell_pointer or the NEXT portion of an}
{ amc$sequence_pointer and store it as the new current_byte_address of}
{ this instance of open of the file.  The effect of this request depends upon}
{ the value specified by the corresponding instance of open for the}
{ private_read attachment option.  If true was specified, then the request}
{ only affects the position of this instance of open.  If false was}
{ specified, this request affects all concurrent instances of open.}
{   This request may be issued repeatedly throughout a task's use of the}
{ file.}
{   Typically this request would be issued prior to amp$close to set the}
{ current position for a subsequent task which opens the file without}
{ positioning it, i.e. an open_position of amc$open_no_positioning.}
{   Since there is no concept of position within a heap, this request will}
{ be rejected if given a heap pointer.}
{   This request must be preceded by an amp$set_segment_eoi request when}
{ a file is being created.  Note that amp$set_segment_eoi sets the}
{ current position to EOI.}
{
{       AMP$SET_SEGMENT_POSITION (FILE_IDENTIFIER, SEGMENT_POINTER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{
{ SEGMENT_POINTER: (input) This parameter specifies the address within the
{       segment of the current position of the file.
{
{ STATUS: (output) This request specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_id,
{                   ame$improper_segment_number,
{                   ame$improper_segment_pointer,
{                   ame$set_pos_beyond_eoi,
{                   ame$set_on_adaptable_heap.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$SKIP EXPAND=FALSE
{
{   The purpose of this request is to reposition a sequential file which has
{ been opened for record access; read access to the file is required.
{
{   This request does not cause data movement to or from a user
{ working_storage_area.
{
{   Any outstanding no-wait requests are completed before the positioning is
{ attempted.
{
{   If there is buffered data yet to be written to a tape file, the data is
{ first written to the volume then the volume is terminated according to
{ convention or industry standard, as follows:
{
{   If the label type is amc$labelled, the standard ANSI EOF label and two
{ tapemarks are written; then the tape volume is positioned by the access
{ method prior to the EOF label.  Control is then given to a label exit
{ procedure(*), if applicable, for extended label processing.
{
{   If the label type is amc$unlabelled, two tapemarks are written to
{ terminate the file and volume; then the volume is positioned by the access
{ method prior to the two tapemarks.
{
{   The following tables indicate which positioning options are available for
{ a file opened with amc$record access_level:
{
{  |--------------------------------------------------------------------|
{  |                          |  System_specified Block Type            |
{  |                          |_________________________________________|
{  |          Record_type ->  | V | F | U | S | D | T |                 |
{  |                          |   |(5)|   |   |   |   |                 |
{  |--------------------------------------------------------------------|
{  |  Forward  N records      | x | x | 2 | 1 | 1 | x |                 |
{  |  Backward N records      | 4 | x | 2 | 1 | 1 | x |                 |
{  |  Forward  N partitions   | x | 2 | 2 | 1 | 1 | 2 |                 |
{  |  Backward N partitions   | 4 | 2 | 2 | 1 | 1 | 2 |                 |
{  |  Forward  N tape marks   | 3 | 2 | 3 | 1 | 1 | 2 |                 |
{  |  Backward N tape marks   | 3 | 2 | 3 | 1 | 1 | 2 |                 |
{  |--------------------------------------------------------------------|
{
{
{  |--------------------------------------------------------------------|
{  |                          |  User_specified Block Type              |
{  |                          |_________________________________________|
{  |          Record_type ->  | V | F | U | S | D | T |                 |
{  |                          |   |   |   |   |   |   |                 |
{  |--------------------------------------------------------------------|
{  |  Forward  N records      | 1 | x | x | x | x | 1 |                 |
{  |  Backward N records      | 1 | 4 | x | 2 | 2 | 1 |                 |
{  |  Forward  N partitions   | 1 | 2 | 2 | 2 | 2 | 1 |                 |
{  |  Backward N partitions   | 1 | 2 | 2 | 2 | 2 | 1 |                 |
{  |  Forward  N tape marks   | 1 | 3 | 3 | 2 | 2 | 1 |                 |
{  |  Backward N tape marks   | 1 | 3 | 3 | 2 | 2 | 1 |                 |
{  |--------------------------------------------------------------------|
{
{   Notes on preceding tables:
{
{     1.  This combination of record_type and block_type is not supported.
{
{     2.  This is an undefined operation and abnormal status will be returned.
{
{     3.  This operation is only supported for unlabelled and
{         non-standard-labelled tape files.
{
{     4.  This operation is supported for mass storage files.  For magnetic
{     tape
{         files, it is an undefined operation and abnormal status will be
{         returned.
{
{     5.  This combination of record_type and block_type is only supported
{         for mass storage files.
{
{   The final position of the file, assuming no boundary condition was
{ encountered (encountered is interpretted as attempting to skip beyond a
{ boundary such as BOI, EOI, or a partition delimiter) before the COUNT was
{ exhausted, is as follows:
{
{   Skipping by RECORDS
{
{   Skip of UNIT = record, DIRECTION = forward:
{
{   .  If the file_position prior to this request is amc$boi, amc$bop,
{ amc$eop, amc$eor or amc$eoi, a skip of zero records causes no movement.
{ The file_position returned will be the file position prior to the request.
{
{   .  If the file_position prior to this request is amc$mid_record, then a
{ skip forward of zero records positions to the end of the current record.
{
{   .  If the file_position prior to this request is at the end of record N
{ and a skip forward of M records is performed, the final position will be the
{ end of record N+M.
{
{   .  If the file_position prior to this request is amc$mid_record within
{ record N and a skip forward of M records is performed, the final position
{ will be at the end of record N+M.
{
{   Skip of UNIT = record, DIRECTION = backward:
{
{   .  If the file_position prior to this request is amc$boi, amc$bop,
{ amc$eop, amc$eor or amc$eoi, a skip of zero records causes no movement.
{ The file_position returned will be the file position prior to the request.
{
{   .  If the file_position prior to this request is amc$mid_record, then a
{ skip backward of zero records positions to the end of the preceding record.
{
{   .  If the file_position prior to this request is at the end of record N
{ and a skip backward of M records is performed, the final position will be
{ the end of record N-M.
{
{   .  If the file_position prior to this request is amc$mid_record within
{ record N and a backspace of M records is performed, the final position will
{ be at the end of record N-M-1.
{
{   Record skipping BOUNDARY CONDITIONS
{
{   If BOI, EOI or a partition delimiter is encountered before the COUNT is
{ exhausted, an abnormal status will be returned.  The actual number of
{ records skipped in this case may be determined by subtracting the
{ residual_skip_count available via the amp$fetch_access_information request
{ from the original COUNT.
{
{   When either BOI or EOI are encountered, the final position remains at BOI
{ or EOI, whichever was encountered.
{
{   When a skip forward encounters a partition delimiter, the final position
{ is after the delimiter, i.e.  at the beginning of the next partition.
{
{   When a skip backward encounters a partition delimiter the final position
{ is prior to the delimiter, i.e.  at the end of the preceding partition.
{
{   Skipping by PARTITIONS
{
{   .  If a file contains no partition delimiters, then for the purpose of the
{ amp$skip request, the file is said to contain one (1) partition which begins
{ at BOI and ends at EOI.  A file which contains one (1) partition delimiter
{ has two (2) partitions, etc.
{
{   .  If the last record in a file is a partition delimiter which terminates
{ partition N and the current position of the file is after the partition
{ delimiter, then for the purpose of the amp$skip request the file is
{ considered to be positioned at the beginning of partition N+1.
{
{   Skip of UNIT = partition, DIRECTION = forward
{
{   .  If the file_position prior to this request is amc$boi or amc$bop, then
{ a skip of zero partitions causes no movement.  The file_position returned
{ will be the file position prior to the request.
{
{   .  If the file_position prior to this request is beyond the beginning of a
{ partition and a forward skip of zero partitions is performed the final
{ position will be the beginning of the next partition.
{
{   .  If the file_position prior to this request is at the beginning of
{ partition N and a forward skip of M partitions is performed, the final
{ position will be the beginning of partition N+M.
{
{   .  If the file_position prior to this request is beyond the beginning of
{ partition N and a forward skip of M partitions is performed, the final
{ position will be the beginning of partition N+M+1.
{
{   Skip of UNIT = partition, DIRECTION = backward
{
{   .  If the file_position prior to this request is amc$boi or amc$bop, then
{ a skip of zero partitions causes no movement.  The file_position returned
{ will be the file position prior to the request.
{
{   .  If the file_position prior to this request is beyond the beginning of a
{ partition, at EOI, or at EOP, and a backward skip of zero partitions is
{ performed, the final position will be the beginning of the current
{ partition.
{
{   .  If the file_position prior to this request is at the beginning of
{ partition N and a backward skip of M partitions is performed, the final
{ position will be the beginning of partition N-M.
{
{   .  If the file_position prior to this request is beyond the beginning of
{ partition N and a backward skip of M partitions is performed, the final
{ position will be the beginning of partition N-M.
{
{   Partition skipping BOUNDARY CONDITIONS
{
{   If BOI or EOI is encountered before the COUNT is exhausted, an abnormal
{ status is returned and the file remains positioned at BOI or EOI.  The
{ actual number of partitions skipped in this case may be determined by by
{ subtracting the residual_skip_count available via the
{ amp$fetch_access_information request from the original COUNT.
{
{   If BOI or EOI is not reached before the COUNT is exhausted, the file is
{ positioned at the beginning of the requested partition.
{
{   Skipping by TAPE MARKS
{
{   Skipping by tape marks is only supported for a file whose label type is
{ amc$unlabelled or amc$non_standard_labelled.
{
{   Skip of UNIT = tape_mark, DIRECTION = forward:
{
{   .  A forward skip of zero tape markes causes no change in volume or file
{ position, i.e.  no tape motion.  The file_position returned will be the
{ file position prior to the request.
{
{   .  A forward skip by tape marks causes the file to be positioned forward
{ until the number of tape marks indicated by the COUNT parameter have been
{ detected.  If the file spans tape volumes, successive volumes are mounted
{ until the COUNT is exhausted.  The two tapemarks which terminate each volume
{ of an unlabelled file are not counted toward the number of tape marks to
{ skip.  If normal status is returned, then the last volume mounted has been
{ positioned after the last tape mark skipped.
{
{   .  A skip forward of one or more tape marks which terminates normally will
{ return amc$boi as the file_position.
{
{   .  A skip forward will terminate abnormally if the list of volumes
{ associated with the tape file is exhausted (EOI is encountered) prior to the
{ exhaustion of the COUNT.  If a skip terminates abnormally on an unlabelled
{ file, then the last volume will be positioned prior to the two tape marks
{ which terminate it.
{
{
{   Skip of UNIT = tape_mark, DIRECTION = backward:
{
{   .  A backward skip of zero tape markes causes no change in volume or file
{ position, i.e.  no tape motion.  The file_position returned will be the
{ file position prior to the request.
{
{   .  A backward skip by tape marks causes the file to be positioned backward
{ (toward the beginning of the volume) until the number of tape marks
{ indicated by the COUNT parameter have been detected.  If normal status is
{ returned, the current volume has been positioned prior to the last tape mark
{ skipped.
{
{   .  A skip backward of one or more tape marks which terminates normally will
{ return amc$eoi as the file_position.
{
{   .  A skip backward will terminate abnormally if beginning-of-volume is
{ encountered on the current volume; unlike forward tape mark skipping,
{ backward skipping does not cross tape volume boundaries.  If the skip
{ terminates abnormally, the current volume will be positioned at its
{ load-point.
{
{
{       AMP$SKIP (FILE_IDENTIFIER, DIRECTION, UNIT, COUNT, FILE_POSITION,
{         STATUS)
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the file access
{       identifier established when the file was opened.
{
{ DIRECTION: (input)  This parameter specifies the direction of the
{       positioning operation.  Options include:  Forward Backward
{
{ UNIT: (input)  This parameter specifies the type of unit to be skipped.
{       Options include:  Partition Record Tape Mark
{
{ COUNT: (input)  This parameter specifies the number of units to skip.
{
{ FILE_POSITION: (output)  This parameter specifies the position of the file
{       following the request.  Possible file positions resulting from a
{       forward skip in which motion occurred are:
{
{       .  amc$eor - skipping records only
{
{       .  amc$bop - skipping records/partitions only
{
{       .  amc$eoi - any UNIT
{
{       Possible file positions resulting from a backward skip in which
{       motion occurred are:
{
{       .  amc$eor - skipping records only
{
{       .  amc$bop - skipping partitions only
{
{       .  amc$eop - skipping records only
{
{       .  amc$boi - any UNIT
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{                   ame$conflicting_access_level,
{                   ame$conflicting_fo,
{                   ame$improper_ANSI_operation,
{                   ame$improper_device_class,
{                   ame$improper_file_id,
{                   ame$improper_input_attempt,
{                   ame$improper_skip_count,
{                   ame$improper_skip_direction,
{                   ame$improper_skip_unit,
{                   ame$ring_validation_error,
{                   ame$skip_encountered_boi,
{                   ame$skip_encountered_bop,
{                   ame$skip_encountered_bov,
{                   ame$skip_encountered_eoi,
{                   ame$skip_encountered_eop,
{                   ame$skip_requires_read_perm,
{                   ame$uncertain_tape_position,
{                   ame$unrecovered_read_error,
{                   ame$unrecovered_write_error,
{                   ame$unsupported_skip.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$SKIP_TAPE_MARKS EXPAND=FALSE
{
{   The purpose of this request is to position an unlabelled or non-standard
{ labelled tape file forward or backward a specified number of tapemarks.
{ Positioning an ANSI labelled tape file by tapemarks is not supported.
{
{   This request requires that any instance of open of the tape file be closed
{ prior to issuing this request.  Otherwise, this request will be rejected.
{
{   Skip DIRECTION = forward:
{
{   A forward skip by tape marks causes the file to be positioned forward
{ until the number of tape marks indicated by the COUNT parameter have been
{ detected.  If the file spans tape volumes, successive volumes are mounted
{ until the COUNT is exhausted.  The two tapemarks which terminate each volume
{ of an unlabelled file are not counted toward the number of tape marks to
{ skip.  If normal status is returned, then the last volume mounted has been
{ positioned after the last tape mark skipped.
{
{   A skip forward will terminate abnormally if the list of volumes associated
{ with the tape file is exhausted (EOI is encountered) prior to the exhaustion
{ of the COUNT.  If the skip terminates abnormally, then the last volume will
{ be positioned prior to the two tape marks which terminate it.
{
{
{   Skip DIRECTION = backward:
{
{   A backward skip by tape marks causes the file to be positioned backward
{ (toward the beginning of the volume) until the number of tape marks
{ indicated by the COUNT parameter have been detected.  If normal status is
{ returned, the current volume has been positioned prior to the last tape mark
{ skipped.
{
{   A skip backward will terminate abnormally if beginning-of-volume is
{ encountered on the current volume; unlike forward tape mark skipping,
{ backward skipping does not cross tape volume boundaries.  If the skip
{ terminates abnormally, the current volume will be positioned at its
{ load-point.
{
{
{       AMP$SKIP_TAPE_MARKS (FILE, DIRECTION, COUNT, STATUS)
{
{ FILE: (input)  This parameter specifies the name of the file which is
{       associated with the magnetic tape volume to be positioned.
{
{ DIRECTION: (input)  This parameter specifies whether the skip is to be in a
{       forward or backward direction.
{
{ COUNT: (input)  This parameter specifies the number of tapemarks to be
{       skipped.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{                   ame$file_not_closed,
{                   ame$file_not_known,
{                   ame$conflicting_fo,
{                   ame$improper_ANSI_operation,
{                   ame$improper_device_class,
{                   ame$improper_skip_count,
{                   ame$improper_skip_direction,
{                   ame$ring_validation_error,
{                   ame$skip_encountered_bov,
{                   ame$skip_encountered_eoi,
{                   ame$skip_requires_read_perm,
{                   ame$uncertain_tape_position,
{                   ame$unrecovered_read_error,
{                   ame$unsupported_skip.
{       IDENTIFIER: amc$access_method_id.
*DECK DECK=AMH$STORE EXPAND=FALSE
{
{   The purpose of this request is to change the value of one or more
{ temporary file_attributes. Attributes provided by this request are not}
{ preserved with the file.}
{   This request may only be issued after the file has been opened.}
{   The scope of effect of this request is limited to the instance of open}
{ associated with the file_identifier. File_attributes stored by this}
{ request can be retrieved by an amp$fetch request. However an amp$get_file_}
{ attributes request cannot be used to retrieve attributes stored with this}
{ request as they are peculiar to an instance of open of the file.}
{
{       AMP$STORE (FILE_IDENTIFIER, FILE_ATTRIBUTES, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ FILE_ATTRIBUTES: (input) This parameter specifies one or more
{       attribute values to be associated with this instance of open.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_attrib_key,
{                   ame$improper_file_attrib_value,
{                   ame$improper_file_id.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$STORE_FAP_POINTER EXPAND=FALSE
{}
{   The purpose of this request is to store a pointer to a structure which
{ is owned by a file_access_procedure (FAP).}
{    This request allows the fap to allocate a structure which is}
{ peculiar to the instance of the file being accessed, i.e. peculiar}
{ to a file_identifier. The use of this request is optional. A NIL}
{ pointer will be provided as the default by the access method.}
{   This request will be rejected if the existing structure_pointer}
{ within the indicated layer is not NIL.}
{}
{       AMP$STORE_FAP_POINTER (FILE_IDENTIFIER, LAYER_NUMBER,
{         STRUCTURE_POINTER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file access}
{       identifier established when the file was opened.}
{}
{ LAYER_NUMBER: (input) This parameter specifies the identity of the fap.}
{       This parameter is the same layer_number which was passed to the fap}
{       as an actual parameter.}
{}
{ STRUCTURE_POINTER: (input) This parameter specifies the address of}
{       the structure which the fap wishes to associate with this instance}
{       of the file.}
{}
{ STATUS: (output) This parameter specifies the request status.}
{       CONDITION:  ame$ring_validation_error,
{                   ame$redundant_structure_pointer,
{                   ame$improper_file_id.
{       IDENTIFIER: amc$access_method_id.
{}
*DECK DECK=AMH$TERMINATE_FILE EXPAND=FALSE

{ COMMON DECK AMHTERF }

{   The purpose of the inline request is to ensure that the last record
{ in a byte addressable or sequential file is complete.  This means that
{ the file position is end of record, that the record is padded to the
{ minimum block length, and that any record headers are left in a con-
{ sistant state.
{   None of the parameters are validated.
{
{       AMP$TERMINATE_FILE (FILE_IDENTIFIER, FILE_INSTANCE)
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the file access
{       identifier established when the file was opened.
{
{ FILE_INSTANCE: (input)  This parameter specifies the task file table
{       entry associated with the file.
{
*DECK DECK=AMH$UNLOCK_FILE EXPAND=FALSE
{
{   The purpose of this request is to clear the file_lock set by an earlier}
{ amp$lock_file request. This request may only be issued by the task which}
{ issued the amp$lock_file request. Otherwise an abnormal STATUS will be}
{ returned and the request will be ignored.}
{   If the file_lock is not currently set, an abormal STATUS will be returned}
{ and the request will be ignored.}
{
{       AMP$UNLOCK_FILE (FILE_IDENTIFIER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.
{

*DECK DECK=AMH$UNPACK_BLOCK_HEADER EXPAND=FALSE
{}
{   The purpose of this request is to unpack a block header located in}
{ the user's buffer_area. The buffer_area itself may be located within}
{ a file opened with amc$segment access_level or in a space allocated}
{ by the program.}
{   This request may be used to unpack block headers built by the access}
{ method when an amc$user_specified blocked file was created using}
{ amp$put requests or using amp$pack_block_header.}
{   The file must be opened with amc$segment or amc$physical access_level}
{ and amc$user_specified block_type.}
{   This request performs a NEXT in the buffer_area sequence. When this}
{ request completes, the buffer_area variable contains a pointer to}
{ the first byte beyond the block header in the buffer. If insufficient}
{ space existed in the buffer for the block header, a NIL pointer is}
{ returned in the buffer_area variable along with abnormal status.}
{}
{       AMP$UNPACK_BLOCK_HEADER (FILE_IDENTIFIER, BUFFER_AREA, HEADER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file access}
{       identifier established when the file was opened.}
{}
{ BUFFER_AREA: (input-output) This parameter specifies the location within}
{       the user buffer of the block header which is to be unpacked. This}
{       request returns the address of the first byte beyond the block}
{       header in the buffer. A NIL pointer and abnormal status are}
{       returned if a full block header was not available in the buffer.}
{       This request assumes that the block header and the block have been}
{       contiguously stored in the buffer prior to this request.}
{}
{ HEADER: (output) This parameter specifies the contents of the unpacked}
{       block header. This parameter is a record which includes the}
{       fields: }
{        Header_type - specifies the type of the block header which was}
{                      unpacked.}
{        Block_length_as_read - specifies the number of bytes in the data}
{                               block as reported by the equipment driver.}
{        Block_length_as_written - specifies the number of bytes of data}
{                                  which were originally written to the}
{                                  device in the block. If block headers}
{                                  are not recorded on the tape volume or}
{                                  if this is a mass storage file, this}
{                                  field is set equal to block_length_as_read.}
{                                  It is the user's responsibility to}
{                                  interpret any discrepancy between the}
{                                  block_length_as_written and the block_}
{                                  length_as_read.}
{        Block_number - specifies the ordinal position of this block in}
{                       the file.}
{        Unused_bit_count - specifies the number of bits in the last}
{                           byte of the block which do not contain valid}
{                           information. If block headers are not recorded}
{                           on the tape volume or if this is a mass storage}
{                           file, this field is undefined.}
{        Block_status - specifies if an error was detected while reading}
{                       the block and if so, whether or not the error}
{                       was recoverable.}
{}
{ STATUS: (output) This parameter specifies request status.}
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.
{}
*DECK DECK=AMH$UNPACK_RECORD_HEADER EXPAND=FALSE
{
{   The purpose of this request is to unpack a record header located in}
{ the user's buffer_area. The buffer_area itself may be located within}
{ a file opened with amc$segment access_level or in a space allocated}
{ by the program.}
{   This request may be used to unpack record headers built by amp$put}
{ requests or amp$pack_record_header.}
{   This request may only be issued for a file opened with amc$segment or}
{ amc$physical access_level.}
{   If this request is issued for a file which contains records which are}
{ not preceded by a record header, normal status is returned and the}
{ buffer_area variable is returned unchanged.}
{   This request performs a NEXT in the buffer_area sequence. When this}
{ request completes, the buffer_area variable contains a pointer to the}
{ first byte beyond the record header in the buffer. If insufficient}
{ space existed in the buffer for the record header, a NIL pointer is}
{ returned in the buffer_area variable along with abnormal status.}
{
{       AMP$UNPACK_RECORD_HEADER (FILE_IDENTIFIER, BUFFER_AREA, HEADER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ BUFFER_AREA: (input-output) This parameter specifies the location within}
{       the user buffer of the record header which is to be unpacked. This}
{       request returns the address of the first byte beyond the record}
{       header in the buffer. A NIL pointer and abnormal status are returned}
{       if a full record header was not available in the buffer. This request}
{       assumes that the record header and the record have been stored}
{       contiguously in the buffer prior to issuing this request.}
{}
{ HEADER: (output) This parameter specifies the contents of the record}
{       header which has been unpacked form the buffer_area. This parameter}
{       must be supplied but will be ignored if the record_type of the}
{       file is one which does not support a record header.}
{       Not all fields of this parameter are applicable to record types other}
{       than amc$variable; no indication is given if such fields are not}
{       initialized by this request.}
{       This parameter is a record which includes the following fields:}
{        Header_type - specifies the type of record header which has been}
{                      unpacked.}
{        Length - specifies the number of bytes in the record described by}
{                 this header.}
{        Previous_length - specifies the number of bytes in the preceding}
{                          record, exclusive of the previous header.}
{        Unused_bit_count - specifies the number of bits in the last byte of}
{                           this record which do not contain valid data.}
{        User_information - specifies a cell whose value is defined only if}
{                           the record header was created by amp$pack_record_}
{                           header.}
{}
{ STATUS: (output) this parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMH$VALIDATE_CALLER_PRIVILEGE EXPAND=FALSE
{}
{   The purpose of this request is to validate that the caller of}
{ the file_access_procedure (fap) is authorized to perform the requested
{ operation.}
{   This request also returns the current value of the structure_}
{ pointer belonging to the fap.  A NIL pointer will be returned if}
{ the fap has not previously stored a value in the structure_pointer}
{ with the amp$store_fap_pointer request.}
{   The issuance of this request is mandatory for any fap which}
{ is more privileged than its caller.  Otherwise, the caller could}
{ induce the fap to perform an operation which the caller was not}
{ authorized to perform on its own.}
{   For write operations the fap is required to specify the access}
{ privilege neccessary to perform the operation for this instance of}
{ open of the file.  For example, an amp$put_next operation requires}
{ either pfc$append or pfc$shorten privilege for an instance of open}
{ of a sequential file.  Which of the two permissions is required}
{ depends upon whether the current_byte_address is equal to or less}
{ than the current EOI.  In recognition of the fact that each fap}
{ may have its own requirements with respect to access privilege for}
{ a write operation, this parameter has been provided.}
{}
{       AMP$VALIDATE_CALLER_PRIVILEGE (FILE_IDENTIFIER, CALL_BLOCK,
{         LAYER_NUMBER, REQUIRED_WRITE_PRIVILEGE, CALLER_RING_NUMBER,
{         STRUCTURE_POINTER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file access}
{       identifier established when the file was opened.}
{}
{ CALL_BLOCK: (input) This parameter specifies the identity of the}
{       operation which the fap is requested to perform.}
{}
{ LAYER_NUMBER: (input) This parameter specifies the identity of the fap.}
{       This value is the same layer_number which was passed to the fap}
{       as an actual parameter.}
{}
{ REQUIRED_WRITE_PRIVILEGE: (input) This parameter specifies the access}
{       privilege required of this instance of open of the file to}
{       perform a write operation.  This parameter is ignored on non-write
{       operations.  If the required_write_privilege is not a subset of the
{       access_mode associated with this instance of open of the file, then
{       abnormal status will be returned.  The value of this parameter cannot}
{       be the NULL set for a write operation.}
{}
{ CALLER_RING_NUMBER: (input) This parameter specifies the ring of the}
{       caller of the fap.  Each operation is categorized by this request}
{       according to the privilege required.  If the caller does not have}
{       sufficient privilege to perform the operation, then abnormal status}
{       is returned.}
{}
{ STRUCTURE_POINTER: (output) This parameter specifies the address of}
{       a structure the fap previously stored using the amp$store_fap_pointer}
{       request.  A NIL pointer will be returned if the structure_pointer has}
{       not been previously initialized by the fap.}
{}
{ STATUS: (output) This parameter specifies the request status.}
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_id,
{                   ame$improper_access_attempt,
{                   ame$null_set_specified,
{                   ame$improper_fap_operation.
{       IDENTIFIER: amc$access_method_id.
{}
*DECK DECK=AMH$WRITE EXPAND=FALSE
{
{   The purpose of this request is to transfer data to the "next" physical
{ position of a file opened with amc$physical access_level. This request}
{ unconditionally establishes end of information (EOI) on a file.}
{ The operation of this request is device dependent, as follows:}
{}
{ MASS STORAGE:}
{}
{   The intended use of this request is to transfer a full allocation_unit}
{ worth of data. The maximum amount of data which can be transferred in}
{ a single request is constrained by the number of bytes in the}
{ allocation_unit specified for the file. A lesser amount than a full}
{ allocation_unit may be written. It is permissable for the buffer_length}
{ to be other than a multiple of the MAU size.  However successive writes}
{ of partial MAU's will leave gaps in the file which the user is}
{ responsible for ignoring during a later read.}
{}
{ MAGNETIC TAPE - AMC$SYSTEM_SPECIFIED BLOCK_TYPE:}
{}
{ The transfer will begin and end on a tape block boundary. One or more}
{ consecutive tape blocks may be written with a single request. The}
{ buffer_length must be at least the size of one system_specified block}
{ (4096 bytes in length). The number of system_specified blocks which}
{ could fit in the buffer_area is the maximum number of blocks which will}
{ be transferred in a single request. All blocks are the same length, except}
{ the last block is permitted to be shorter than the system_specified}
{ block length.}
{}
{ MAGNETIC TAPE - AMC$USER_SPECIFIED BLOCK_TYPE:}
{}
{ The transfer will begin and end on a tape block boundary. One or more}
{ consecutive tape blocks may be written with a single request. Each}
{ block in the buffer will be prefixed by a block header which describes}
{ the block content. This block header is provided by the access method}
{ on a read and provided by the caller on a write. The amp$pack_block_header}
{ and amp$unpack_block_header requests are provided to access the header.}
{ The buffer_length must be at least the size of one user_specified block.}
{ The maximum length of a user_specified block is the sum of the two file}
{ attributes MAX_BLOCK_LENGTH and BLOCK_HEADER_LENGTH.}
{ The result of the division of buffer_length by the maximum length}
{ of the user_specified block is the maximum number of blocks which will}
{ be transferred by this request.}
{ If the label_type is amc$labelled, the block header will be recorded with}
{ the data on a write to aid reliability. The block_header_length will be}
{ recorded in the HDR2 ANSI standard label for interchange purposes.}
{
{       AMP$WRITE (FILE_IDENTIFIER, BUFFER_AREA, BUFFER_LENGTH,
{         BYTE_ADDRESS, WAIT, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ BUFFER_AREA: (input) This parameter specifies the users buffer area that
{       contains the data to be transferred to the file.
{
{ BUFFER_LENGTH: (input) This parameter specifies the number of bytes to
{       be transferred.
{
{ BYTE_ADDRESS: (output) This parameter indicates the byte address
{       established for the beginning of the transfer.  This value is
{       only returned for mass storage devices.
{
{ WAIT: (input) This parameter specifies the action to be taken following
{       initiation of the transfer.  Options include:
{         wait: Don't return control until the operation is complete.
{         nowait: Return control to the user even though the operation
{                 may not be complete.  The AMP$CHECK_BUFFER request
{                must be used to determine completion.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.
{

*DECK DECK=AMH$WRITE_DIRECT EXPAND=FALSE
{
{   The purpose of this request is to write data to a file opened with}
{ access_level of amc$physical and file_organization of }
{ amc$byte_addressable.}
{   An abnormal STATUS will be generated if the byte_address specified is}
{ not at a disk minimum_addressable_unit (MAU) boundary.}
{   This request, when issued by a user with access_mode of pfc$append,}
{ causes a new end of information (EOI) to be defined if the byte_address}
{ plus buffer_length exceeds the previous EOI.}
{   The buffer_length must be a multiple of MAU size unless a new EOI}
{ is being established or the write is up to the current EOI.  However}
{ successive random writes which are not a multiple of MAU in length}
{ occuring beyond the present EOI may leave gaps in the file which are}
{ the responsibility of the user to ignore during a later record.}
{
{       AMP$WRITE_DIRECT (FILE_IDENTIFIER, BUFFER_AREA, BUFFER_LENGTH,
{         BYTE_ADDRESS, WAIT, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ BUFFER_AREA: (input) This parameter specifies the user's buffer area that
{       contains the data to be transferred to the file.
{
{ BUFFER_LENGTH: (input) This parameter specifies the number of bytes to
{       be transferred.
{
{ BYTE_ADDRESS: (input) This parameter specifies the byte address at
{       which the transfer is to begin.
{
{ WAIT: (input) This parameter specifies the action to be taken following
{       initiation of the transfer.  Options include:
{         wait: Don't return control until the request is complete.
{         nowait: Return control to the user even though the request
{                 may not be complete.  The AMP$CHECK_BUFFER request
{                 must be used to determine completion.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{       IDENTIFIER: amc$access_method_id.
{

*DECK DECK=AMH$WRITE_END_PARTITION EXPAND=FALSE
{   The purpose of this request is to write an end of partition (EOP)
{ delimiter on a file opened with amc$variable record_type.
{
{       AMP$WRITE_END_PARTITION (FILE_IDENTIFIER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{      identifier established when the file was opened.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=AMH$WRITE_TAPE_MARK EXPAND=FALSE
{
{   The purpose of this request is to write a tape mark on an unlabelled}
{ tape volume. This request is not supported for mass storage files.}
{   This request causes the current block to be terminated for a record access}
{ file. Any blocks in memory will be written before the tapemark.}
{   Two consecutive tapemarks encountered during an input operation signal
{ the end of data on the volume.  If two consecutive tapemarks are written
{ using this request and then additional records are written, the data
{ on the volume after the two tapemarks cannot be read by BAM.
{   If this request is issued for a file opened for amc$physical(*) access,
{ any outstanding no_wait requests will be completed before the tapemark}
{ is written.}
{   This request is invalid for an amc$labelled file because such files}
{ are intended for data interchange according to the ANSI standard.}
{   This request is invalid for files opened with amc$segment access_level.}
{
{       AMP$WRITE_TAPE_MARK (FILE_IDENTIFIER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$conflicting_access_level,
{                   ame$improper_file_id,
{                   ame$improper_device_class,
{                   ame$improper_output_attempt,
{                   ame$improper_ANSI_operation,
{                   ame$unrecovered_write_error.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=AMK$ACCESS_METHOD EXPAND=FALSE
{ COMMON DECK amk$access_method }

{  This common deck defines constants for use with keypoints }
{ in AMP$ procedures. }

  CONST
    amk$access_method = amk$base + 1,
    {E 'amp$access_method' }
    {X 'amp$access_method' }

    amk$add_to_file_description = amk$base + 2,
    {E 'amp$add_to_file_description' }
    {X 'amp$add_to_file_description' }

    amk$advanced_access_methods = amk$base + 3,
    {E 'amp$advanced_access_methods' }
    {X 'amp$advanced_access_methods' }

    amk$check_record = amk$base + 4,
    {E 'amp$check_record' }
    {X 'amp$check_record' }

    amk$close = amk$base + 5,
    {E 'fsp$close' }
    {X 'fsp$close' }

    amk$copy_file = amk$base + 8,
    {E 'fsp$copy_file' }
    {X 'fsp$copy_file' }

    amk$delete_key = amk$base + 9,
    {E 'amp$delete_key' }
    {X 'amp$delete_key' }

    amk$fetch = amk$base + 11,
    {E 'amp$fetch' }
    {X 'amp$fetch' }

    amk$fetch_access_information = amk$base + 12,
    {E 'amp$fetch_access_information' }
    {X 'amp$fetch_access_information' }

    amk$fetch_fap_pointer = amk$base + 13,
    {E 'amp$fetch_fap_pointer' }
    {X 'amp$fetch_fap_pointer' }

    amk$file = amk$base + 14,
    {E 'amp$file' }
    {X 'amp$file' }

    amk$flush = amk$base + 15,
    {E 'amp$flush' }
    {X 'amp$flush' }

    amk$get_direct = amk$base + 16,
    {E 'amp$get_direct' }
    {X 'amp$get_direct' }

    amk$get_file_attributes = amk$base + 17,
    {E 'amp$get_file_attributes' }
    {X 'amp$get_file_attributes' }

    amk$get_key = amk$base + 18,
    {E 'amp$get_key' }
    {X 'amp$get_key' }

    amk$get_next = amk$base + 19,
    {E 'amp$get_next' }
    {X 'amp$get_next' }

    amk$get_next_key = amk$base + 20,
    {E 'amp$get_next_key' }
    {X 'amp$get_next_key' }

    amk$get_partial = amk$base + 21,
    {E 'amp$get_partial' }
    {X 'amp$get_partial' }

    amk$get_segment_pointer = amk$base + 22,
    {E 'amp$get_segment_pointer' }
    {X 'amp$get_segment_pointer' }

    amk$open = amk$base + 25,
    {E 'amp$open' }
    {X 'amp$open' }

    amk$putrep = amk$base + 26,
    {E 'amp$putrep' }
    {X 'amp$putrep' }

    amk$put_direct = amk$base + 27,
    {E 'amp$put_direct' }
    {X 'amp$put_direct' }

    amk$put_key = amk$base + 28,
    {E 'amp$put_key' }
    {X 'amp$put_key' }

    amk$put_next = amk$base + 29,
    {E 'amp$put_next' }
    {X 'amp$put_next' }

    amk$put_partial = amk$base + 30,
    {E 'amp$put_partial' }
    {X 'amp$put_partial' }

    amk$replace_key = amk$base + 32,
    {E 'amp$replace_key' }
    {X 'amp$replace_key' }

    amk$return = amk$base + 33,
    {E 'amp$return' }
    {X 'amp$return' }

    amk$rewind = amk$base + 34,
    {E 'amp$rewind' }
    {X 'amp$rewind' }

    amk$seek_direct = amk$base + 35,
    {E 'amp$seek_direct' }
    {X 'amp$seek_direct' }

    amk$set_file_instance_abnormal = amk$base + 37,
    {E 'amp$set_file_instance_abnormal' }
    {X 'amp$set_file_instance_abnormal' }

    amk$set_local_name_abnormal = amk$base + 38,
    {E 'amp$set_local_name_abnormal' }
    {X 'amp$set_local_name_abnormal' }

    amk$set_segment_eoi = amk$base + 39,
    {E 'amp$set_segment_eoi' }
    {X 'amp$set_segment_eoi' }

    amk$set_segment_position = amk$base + 40,
    {E 'amp$set_segment_position' }
    {X 'amp$set_segment_position' }

    amk$skip = amk$base + 42,
    {E 'amp$skip' }
    {X 'amp$skip' }

    amk$skip_tape_marks = amk$base + 43,
    {E 'amp$skip_tape_marks' }
    {X 'amp$skip_tape_marks' }

    amk$start = amk$base + 44,
    {E 'amp$start' }
    {X 'amp$start' }

    amk$store = amk$base + 45,
    {E 'amp$store' }
    {X 'amp$store' }

    amk$store_fap_pointer = amk$base + 46,
    {E 'amp$store_fap_pointer' }
    {X 'amp$store_fap_pointer' }

    amk$validate_caller_privilege = amk$base + 48,
    {E 'amp$validate_caller_privilege' }
    {X 'amp$validate_caller_privilege' }

    amk$write_end_partition = amk$base + 49,
    {E 'amp$write_end_partition' }
    {X 'amp$write_end_partition' }

    amk$write_tape_mark = amk$base + 50,
    {E 'amp$write_tape_mark' }
    {X 'amp$write_tape_mark' }

    amk$abandon_key_definitions = amk$base + 52,
    {E 'amp$abandon_key_definitions' }
    {X 'amp$abandon_key_definitions' }

    amk$abort_file_parcel = amk$base + 53,
    {E 'amp$abort_file_parcel' }
    {X 'amp$abort_file_parcel' }

    amk$apply_key_definitions = amk$base + 54,
    {E 'amp$apply_key_definitions' }
    {X 'amp$apply_key_definitions' }

    amk$begin_file_parcel = amk$base + 55,
    {E 'amp$begin_file_parcel' }
    {X 'amp$begin_file_parcel' }

    amk$check_nowait_request = amk$base + 56,
    {E 'amp$check_nowait_request' }
    {X 'amp$check_nowait_request' }

    amk$commit_file_parcel = amk$base + 57,
    {E 'amp$commit_file_parcel' }
    {X 'amp$commit_file_parcel' }

    amk$create_key_definition = amk$base + 58,
    {E 'amp$create_key_definition' }
    {X 'amp$create_key_definition' }

    amk$create_nested_file = amk$base + 59,
    {E 'amp$create_nested_file' }
    {X 'amp$create_nested_file' }

    amk$delete_key_definition = amk$base + 60,
    {E 'amp$delete_key_definition' }
    {X 'amp$delete_key_definition' }

    amk$delete_nested_file = amk$base + 61,
    {E 'amp$delete_nested_file' }
    {X 'amp$delete_nested_file' }

    amk$find_record_space = amk$base + 62,
    {E 'amp$find_record_space' }
    {X 'amp$find_record_space' }

    amk$get_key_definitions = amk$base + 63,
    {E 'amp$get_key_definitions' }
    {X 'amp$get_key_definitions' }

    amk$get_lock_keyed_record = amk$base + 64,
    {E 'amp$get_lock_keyed_record' }
    {X 'amp$get_lock_keyed_record' }

    amk$get_lock_next_keyed_record = amk$base + 65,
    {E 'amp$get_lock_next_keyed_record' }
    {X 'amp$get_lock_next_keyed_record' }

    amk$get_nested_file_definitions = amk$base + 66,
    {E 'amp$get_nested_file_definitions' }
    {X 'amp$get_nested_file_definitions' }

    amk$get_next_primary_key_list = amk$base + 67,
    {E 'amp$get_next_primary_key_list' }
    {X 'amp$get_next_primary_key_list' }

    amk$get_primary_key_count = amk$base + 68,
    {E 'amp$get_primary_key_count' }
    {X 'amp$get_primary_key_count' }

    amk$get_space_used_for_key = amk$base + 69,
    {E 'amp$get_space_used_for_key' }
    {X 'amp$get_space_used_for_key' }

    amk$lock_file = amk$base + 70,
    {E 'amp$lock_file' }
    {X 'amp$lock_file' }

    amk$lock_key = amk$base + 71,
    {E 'amp$lock_key' }
    {X 'amp$lock_key' }

    amk$select_key = amk$base + 72,
    {E 'amp$select_key' }
    {X 'amp$select_key' }

    amk$select_nested_file = amk$base + 73,
    {E 'amp$select_nested_file' }
    {X 'amp$select_nested_file' }

    amk$separate_key_groups = amk$base + 74,
    {E 'amp$separate_key_groups' }
    {X 'amp$separate_key_groups' }

    amk$unlock_file = amk$base + 75,
    {E 'amp$unlock_file' }
    {X 'amp$unlock_file' }

    amk$unlock_key = amk$base + 76,
    {E 'amp$unlock_key' }
    {X 'amp$unlock_key' }

    amk$replace_previous_record = amk$base + 77,
    {E 'amp$replace_previous_record' }
    {X 'amp$replace_previous_record' }

    amk$get_label = amk$base + 78,
    {E 'amp$get_label' }
    {X 'amp$get_label' }

    amk$put_label = amk$base + 79,
    {E 'amp$put_label' }
    {X 'amp$put_label' }

    amk$close_volume = amk$base + 80,
    {E 'amp$close_volume' }
    {X 'amp$close_volume' }

    amk$erase_tape_block = amk$base + 81,
    {E 'amp$erase_tape_block' }
    {X 'amp$erase_tape_block' }

    amk$fetch_nested_file_attrib = amk$base + 82;
    {E 'amp$fetch_nested_file_attrib' }
    {X 'amp$fetch_nested_file_attrib' }

?? PUSH (LISTEXT := ON) ??
*copyc osk$keypoints
?? POP ??





*DECK DECK=AMK$BASE_KEYPOINT_VALUES EXPAND=FALSE
{This deck defines constants for use with KEYPOINTS.


{Define base keypoint procedure identifiers for each area of the OS.
{ The following should be kept in value order and not alphabetical order.

  CONST
    ptk$performance_base = 0, {0 - 99}
    amk$base = 050, {050 - 149}
    bak$base = 150, {150 - 249}
    clk$base = 250, {250 - 299}
    cmk$base = 300, {300 - 349}
    clk$base_2 = 350, {350 - 399}
    dmk$base = 400, {400 - 549}
    dfk$base = 550, {550 - 599}
    ick$base = 600, {600 - 649}
    ifk$base = 650, {650 - 699}
    iik$base = 700, {700 - 749}
    iik$vt_base = 750, {750 - 799}
{ open 800 - 849}
    lgk$base = 850, {850 - 899}
{ open 900 - 949}
    lok$base = 950, {950 - 999}
    rfk$ai_base = 1000, {1000 - 1049}
    mlk$base = 1050, {1050 - 1099}
    mmk$monitor_base = 1100, {1100 - 1149}
    mmk$job_base = 1150, {1150 - 1199}
    msk$base = 1200, {1200 - 1249}
    mtk$base = 1250, {1250 - 1299}
    ock$base = 1300, {1300 - 1349}
    ofk$base = 1350, {1350 - 1399}
    osk$base = 1400, {1400 - 1449}
    pfk$base = 1500, {1500 - 1599}
    pmk$base = 1600, {1600 - 1749}
    rhk$base = 1750, {1750 - 1799}
    srk$base = 1800, {1800 - 1849}
    stk$base = 1850, {1850 - 1899}
    tmk$monitor_base = 1900, {1900 - 1949}
    tmk$job_base = 1950, {1950 - 1999}
    jsk$base = 2000, {2000 - 2099}
    avk$base = 2100, {2100 - 2149}
    sfk$base = 2150, {2150 - 2199}
    iok$base = 2200, {2200 - 2249}
    nfk$base = 2250, { 2250 - 2299}
    dmk$tape_base = 2300, {2300 - 2349}
    syk$job_base = 2350, {2350 - 2399}
    nak$job_base = 2400, {2400 - 2599}
    nlk$xt_job_base = 2500, {2500 - 2549}
    nlk$gt_job_base = 2550, {2550 - 2599}
    jmk$base = 2600, {2600 - 2699}
    fmk$base = 2700, {2700 - 2799}
    fsk$base = 2800, {2800 - 2899}
    rmk$base = 2900, {2900 - 2999}
    nak$monitor_base = 3000, {3000 - 3049}
    fdk$base = 3050, {3050 - 3099}
    csk$base = 3100, {3100 - 3149}
    mtk$assembly_language_base = 4000; {4000 - 4049}
{   OS assembly language      4000 - 4049}
*copyc OSK$KEYPOINT_CLASS_CODES
*DECK DECK=AMM$ABANDON_KEY_DEFINITIONS EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$abandon_key_definitions;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$ABANDON_KEY_DEFINITIONS' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$abandon_key_definitions (file_identifier:
    amt$file_identifier;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$ABANDON_KEY_DEFINITIONS',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0,
          amk$abandon_key_definitions);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$abandon_key_definitions);
      RETURN;
    IFEND;

    call_block.operation := amc$abandon_key_definitions;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$abandon_key_definitions);
  PROCEND amp$abandon_key_definitions;
MODEND amm$abandon_key_definitions;
*DECK DECK=AMM$ABORT_FILE_PARCEL EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$abort_file_parcel;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$ABORT_FILE_PARCEL' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$abort_file_parcel (file_identifier:
    amt$file_identifier;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$ABORT_FILE_PARCEL',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0,
          amk$abort_file_parcel);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$abort_file_parcel);
      RETURN;
    IFEND;

    call_block.operation := amc$abort_file_parcel;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$abort_file_parcel);
  PROCEND amp$abort_file_parcel;
MODEND amm$abort_file_parcel;
*DECK DECK=AMM$ACCESS_METHOD EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$access_method;

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$ACCESS_METHOD' ??
?? NEWTITLE := '  RING BRACKETS 2DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$fap_validation_errors
*copyc ame$improper_file_id
*copyc amk$access_method
?? POP ??
*copyc bap$fap_control
*copyc bap$mark_fap_layer_closed
*copyc bap$mark_fap_layer_open
*copyc bap$validate_file_identifier
*copyc osp$copy_local_status_to_status
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
*copyc amh$access_method
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$access_method
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    CONST
      interface_name = 'AMP$ACCESS_METHOD';

    VAR
      bam_status: ost$status,
      file_id_is_valid: boolean,
      fap_layer_number: amt$fap_layer_number,
      file_instance: ^bat$task_file_entry;

    bam_status.normal := TRUE;

    #KEYPOINT (osk$entry, 0, amk$access_method);

*copy bai$validate_file_identifier

    IF file_id_is_valid THEN
      IF (file_instance^.fap_control_information.fap_array = NIL) AND
            (layer_number = 0) THEN
        bap$fap_control (file_identifier, call_block, {layer_number} 1,
              bam_status);
      ELSEIF (file_instance^.fap_control_information.fap_array <> NIL) AND
            (layer_number < UPPERBOUND (file_instance^.fap_control_information.
            fap_array^)) THEN
        fap_layer_number := layer_number + 1;
        CASE call_block.operation OF
        = amc$open_req =
          bap$mark_fap_layer_open (file_identifier, fap_layer_number,
                bam_status);
        = amc$close_req =
          bap$mark_fap_layer_closed (file_identifier, fap_layer_number,
                bam_status);
        ELSE
        CASEND;
        file_instance^.fap_control_information.fap_array^ [fap_layer_number].access_method^
              (file_identifier, call_block, fap_layer_number, bam_status);
      ELSEIF (file_instance^.fap_control_information.fap_array <> NIL) AND
            (layer_number = UPPERBOUND (file_instance^.fap_control_information.
            fap_array^)) THEN
        bap$fap_control (file_identifier, call_block, layer_number + 1,
              bam_status);
      ELSE
        osp$set_status_abnormal (amc$access_method_id,
              ame$improper_layer_number, interface_name, bam_status);
      IFEND;

      osp$copy_local_status_to_status (bam_status, status);

    ELSE
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
    IFEND;
    #KEYPOINT (osk$exit, 0, amk$access_method);
  PROCEND amp$access_method;
MODEND amm$access_method;
*DECK DECK=AMM$ADD_TO_FILE_DESCRIPTION EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$add_to_file_description;

{ MODULE DECK AMMATF }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$ADD_TO_FILE_DESCRIPTION' ??
?? NEWTITLE := '  RING BRACKETS 2DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMT$LOG_RESIDENCE
*copyc clp$convert_integer_to_string
*copyc CLP$CONVERT_STRING_TO_FILE_REF
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OSP$SET_STATUS_ABNORMAL
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc AME$ATTRIBUTE_VALIDATION_ERRORS
*copyc BAP$ADD_TO_FILE_DESCRIPTION
*copyc AMK$ACCESS_METHOD
?? POP ??
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$ADD_TO_FILE_DESCRIPTION
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$add_to_file_description ALIAS 'amxatfd'
    (file_identifier: amt$file_identifier;
        file_attributes: amt$add_to_attributes;
    VAR status: ost$status);


*copyc BAV$TASK_FILE_TABLE

    CONST
      interface_name = 'AMP$ADD_TO_FILE_DESCRIPTION';

    VAR
      bam_status: ost$status,
      i: integer,
      text: ost$name,
      str: ost$string,
      ignore_file: fst$parsed_file_reference,
      file_instance: ^bat$task_file_entry;

    status.normal := TRUE;
    bam_status.normal := TRUE;

    #keypoint (osk$entry, 0,
          amk$add_to_file_description);

    IF bav$task_file_table = NIL THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$add_to_file_description);
      RETURN;
    ELSEIF (file_identifier.ordinal < 0) OR (file_identifier.ordinal >
          UPPERBOUND (bav$task_file_table^)) THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$add_to_file_description);
      RETURN;
    IFEND;

    file_instance := ^bav$task_file_table^ [file_identifier.ordinal];

    IF file_instance^.sequence_number <> file_identifier.sequence THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$add_to_file_description);
      RETURN;
    ELSE { all ok }
      text := osc$null_name;

    /verify_loop/
      FOR i := 1 TO UPPERBOUND (file_attributes) DO
        CASE file_attributes [i].key OF
        = amc$character_conversion =
          IF (file_attributes [i].character_conversion < LOWERVALUE (boolean))
          { } OR (file_attributes [i].character_conversion > UPPERVALUE
                (boolean)) THEN
            text := 'CHARACTER_CONVERSION';
          IFEND;
        = amc$file_contents =

        = amc$file_limit =
          IF (file_attributes [i].file_limit < LOWERVALUE (amt$file_limit))
          { } OR (file_attributes [i].file_limit > UPPERVALUE (amt$file_limit))
                THEN
            text := 'FILE_LIMIT';
          IFEND;
        = amc$file_processor =

        = amc$file_structure =

        = amc$forced_write =
          IF (file_attributes [i].forced_write < LOWERVALUE (amt$forced_write))
          { } OR (file_attributes [i].forced_write > UPPERVALUE
                (amt$forced_write)) THEN
            text := 'FORCED_WRITE';
          IFEND;
        = amc$internal_code =
          IF (file_attributes [i].internal_code < LOWERVALUE
                (amt$internal_code))
          { } OR (file_attributes [i].internal_code > UPPERVALUE
                (amt$internal_code)) THEN
            text := 'INTERNAL_CODE';
          IFEND;
        = amc$line_number =
          IF (file_attributes [i].line_number.length < LOWERVALUE
                (amt$line_number_length))
          { } OR (file_attributes [i].line_number.length > UPPERVALUE
                (amt$line_number_length))
          { } OR (file_attributes [i].line_number.location < LOWERVALUE
                (amt$line_number_location))
          { } OR (file_attributes [i].line_number.location > UPPERVALUE
                (amt$line_number_location)) THEN
            text := 'LINE_NUMBER';
          IFEND;
        = amc$max_block_length =
          IF (file_attributes [i].max_block_length < LOWERVALUE
                (amt$max_block_length))
          { } OR (file_attributes [i].max_block_length > UPPERVALUE
                (amt$max_block_length)) THEN
            text := 'MAX_BLOCK_LENGTH';
          IFEND;
        = amc$max_record_length =
          IF (file_attributes [i].max_record_length < LOWERVALUE
                (amt$max_record_length))
          { } OR (file_attributes [i].max_record_length > UPPERVALUE
                (amt$max_record_length)) THEN
            text := 'MAX_RECORD_LENGTH';
          IFEND;
        = amc$min_block_length =
          IF (file_attributes [i].min_block_length < LOWERVALUE
                (amt$min_block_length))
          { } OR (file_attributes [i].min_block_length > UPPERVALUE
                (amt$min_block_length)) THEN
            text := 'MIN_BLOCK_LENGTH';
          IFEND;
        = amc$min_record_length =
          IF (file_attributes [i].min_record_length < LOWERVALUE
                (amt$min_record_length))
          { } OR (file_attributes [i].min_record_length > UPPERVALUE
                (amt$min_record_length)) THEN
            text := 'MIN_RECORD_LENGTH';
          IFEND;
        = amc$null_attribute =
          ;
        = amc$padding_character =
          ;
        = amc$page_format =
          IF (file_attributes [i].page_format < LOWERVALUE (amt$page_format))
          { } OR (file_attributes [i].page_format > UPPERVALUE
                (amt$page_format)) THEN
            text := 'PAGE_FORMAT';
          IFEND;
        = amc$page_length =
          IF (file_attributes [i].page_length < LOWERVALUE (amt$page_length))
          { } OR (file_attributes [i].page_length > UPPERVALUE
                (amt$page_length)) THEN
            text := 'PAGE_LENGTH';
          IFEND;
        = amc$page_width =
          IF (file_attributes [i].page_width < LOWERVALUE (amt$page_width))
          { } OR (file_attributes [i].page_width > UPPERVALUE (amt$page_width))
                THEN
            text := 'PAGE_WIDTH';
          IFEND;
        = amc$record_type =
          IF (file_attributes [i].record_type < LOWERVALUE (amt$record_type))
          { } OR (file_attributes [i].record_type > UPPERVALUE
                (amt$record_type)) THEN
            text := 'RECORD_TYPE';
          IFEND;
        = amc$statement_identifier =
          IF ((file_attributes [i].statement_identifier.length < LOWERVALUE
                (amt$statement_id_length)) OR (file_attributes [i].
                statement_identifier.length > UPPERVALUE
                (amt$statement_id_length)) OR (file_attributes [i].
                statement_identifier.location < LOWERVALUE
                (amt$statement_id_location)) OR (file_attributes [i].
                statement_identifier.location > UPPERVALUE
                (amt$statement_id_location))) THEN
            text := 'STATEMENT_IDENTIFIER';
          IFEND;
        = amc$user_info =
          ;
        = amc$vertical_print_density =
          IF (file_attributes [i].vertical_print_density < LOWERVALUE
                (amt$vertical_print_density))
          { } OR (file_attributes [i].vertical_print_density > UPPERVALUE
                (amt$vertical_print_density)) THEN
            text := 'VERTICAL_PRINT_DENSITY';
          IFEND;

          { aam }

        = amc$average_record_length =
          IF (file_attributes [i].average_record_length < LOWERVALUE
                (amt$average_record_length))
          { } OR (file_attributes [i].average_record_length > UPPERVALUE
                (amt$average_record_length)) THEN
            text := 'AVERAGE_RECORD_LENGTH';
          IFEND;
        = amc$collate_table =
          ;
        = amc$data_padding =
          IF (file_attributes [i].data_padding < LOWERVALUE (amt$data_padding))
          { } OR (file_attributes [i].data_padding > UPPERVALUE
                (amt$data_padding)) THEN
            text := 'DATA_PADDING';
          IFEND;
        = amc$embedded_key =
          IF (file_attributes [i].embedded_key < LOWERVALUE (boolean))
          { } OR (file_attributes [i].embedded_key > UPPERVALUE (boolean)) THEN
            text := 'EMBEDDED_KEY';
          IFEND;
        = amc$estimated_record_count =
          ;
        = amc$index_levels =
          IF (file_attributes [i].index_levels < LOWERVALUE (amt$index_levels))
          { } OR (file_attributes [i].index_levels > UPPERVALUE
                (amt$index_levels)) THEN
            text := 'INDEX_LEVELS';
          IFEND;
        = amc$index_padding =
          IF (file_attributes [i].index_padding < LOWERVALUE
                (amt$index_padding))
          { } OR (file_attributes [i].index_padding > UPPERVALUE
                (amt$index_padding)) THEN
            text := 'INDEX_PADDING';
          IFEND;
        = amc$key_length =
          IF (file_attributes [i].key_length < LOWERVALUE (amt$key_length))
          { } OR (file_attributes [i].key_length > UPPERVALUE (amt$key_length))
                THEN
            text := 'KEY_LENGTH';
          IFEND;
        = amc$key_position =
          IF (file_attributes [i].key_position < LOWERVALUE (amt$key_position))
          { } OR (file_attributes [i].key_position > UPPERVALUE
                (amt$key_position)) THEN
            text := 'KEY_POSITION';
          IFEND;
        = amc$key_type =
          IF (file_attributes [i].key_type < LOWERVALUE (amt$key_type))
          { } OR (file_attributes [i].key_type > UPPERVALUE (amt$key_type))
                THEN
            text := 'KEY_TYPE';
          IFEND;
        = amc$log_residence =
          IF file_attributes [i].log_residence <> NIL THEN
            clp$convert_string_to_file_ref (file_attributes [i].log_residence^,
                  ignore_file, status);
            IF NOT status.normal THEN
              text := 'LOG_RESIDENCE';
            IFEND;
          IFEND;
        = amc$record_limit =
          IF (file_attributes [i].record_limit < LOWERVALUE (amt$record_limit))
          { } OR (file_attributes [i].record_limit > UPPERVALUE
                (amt$record_limit)) THEN
            text := 'RECORD_LIMIT';
          IFEND;
        = amc$records_per_block =
          IF (file_attributes [i].records_per_block < LOWERVALUE
                (amt$records_per_block))
          { } OR (file_attributes [i].records_per_block > UPPERVALUE
                (amt$records_per_block)) THEN
            text := 'RECORDS_PER_BLOCK';
          IFEND;
        ELSE
          clp$convert_integer_to_string (i, 10, FALSE, str, status);
          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_file_attrib_key, amc$add_to_file_description_req,
                'FILE_ATTRIBUTES', bam_status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                  str.value (1, str.size), bam_status);
        CASEND;
        IF text <> osc$null_name THEN
          IF bam_status.normal THEN
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_file_attrib_value,
                  amc$add_to_file_description_req, 'FILE_ATTRIBUTES', bam_status);
            osp$append_status_parameter (osc$status_parameter_delimiter, text,
                  bam_status);
          ELSE
            osp$append_status_parameter (',', text, bam_status);
          IFEND;
          text := osc$null_name;
        IFEND;
      FOREND /verify_loop/;
      IF NOT bam_status.normal THEN
        #keypoint (osk$exit, 0, amk$add_to_file_description);
        status := bam_status;
        RETURN;
      ELSE
        bap$add_to_file_description (file_identifier, ^file_attributes,
              bam_status);
        IF NOT bam_status.normal THEN
          status := bam_status;
        IFEND;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$add_to_file_description);
  PROCEND amp$add_to_file_description;
MODEND amm$add_to_file_description;
*DECK DECK=AMM$ALTERNATE_ENTRY_POINTS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE amm$alternate_entry_points;

{   This module contains alternate entry points for all AM program
{ interface requests.  These entry points allow a BAM developer to
{ run portions of BAM as a user program, and still have available
{ use of the real BAM, albeit under slightly differenet names.
{ These all behave identically to there liked named counterparts.
{
?? PUSH (LISTEXT := ON) ??
*copyc amp$close
*copyc amp$copy_file
*copyc amp$get_file_attributes
*copyc amp$get_partial
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$set_segment_eoi
?? POP ??
?? SKIP := 4 ??

  PROCEDURE [XDCL, #GATE] amp$#close (file_identifier: amt$file_identifier;
    VAR status: ost$status);

    amp$close (file_identifier, status);

  PROCEND amp$#close;
?? SKIP := 4 ??

  PROCEDURE [XDCL, #GATE] amp$#copy_file (input_file: amt$local_file_name;
        output_file: amt$local_file_name;
    VAR status: ost$status);

    amp$copy_file (input_file, output_file, status);

  PROCEND amp$#copy_file;
?? SKIP := 4 ??

  PROCEDURE [XDCL, #GATE] amp$#get_file_attributes (local_file_name:
    amt$local_file_name;
    VAR file_attributes: amt$get_attributes;
    VAR local_file: boolean;
    VAR old_file: boolean;
    VAR contains_data: boolean;
    VAR status: ost$status);
    amp$get_file_attributes (local_file_name, file_attributes, local_file,
          old_file, contains_data, status);


  PROCEND amp$#get_file_attributes;
?? SKIP := 4 ??

  PROCEDURE [XDCL, #GATE] amp$#get_partial (file_identifier:
    amt$file_identifier;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
    VAR record_length: amt$max_record_length;
    VAR transfer_count: amt$transfer_count;
    VAR byte_address: amt$file_byte_address;
    VAR file_position: amt$file_position;
        skip_option: amt$skip_option;
    VAR status: ost$status);
    amp$get_partial (file_identifier, working_storage_area,
          working_storage_length, record_length, transfer_count, byte_address,
          file_position, skip_option, status);


  PROCEND amp$#get_partial;
?? SKIP := 4 ??

  PROCEDURE [XDCL, #GATE] amp$#get_segment_pointer (file_identifier:
    amt$file_identifier;
        pointer_kind: amt$pointer_kind;
    VAR segment_pointer: amt$segment_pointer;
    VAR status: ost$status);
    amp$get_segment_pointer (file_identifier, pointer_kind, segment_pointer,
          status);


  PROCEND amp$#get_segment_pointer;
?? SKIP := 4 ??

  PROCEDURE [XDCL, #GATE] amp$#open (local_file_name: amt$local_file_name;
        access_level: amt$access_level;
        access_selections: amt$file_access_selections;
    VAR file_identifier: amt$file_identifier;
    VAR status: ost$status);
    amp$open (local_file_name, access_level, access_selections,
          file_identifier, status);


  PROCEND amp$#open;
?? SKIP := 4 ??

  PROCEDURE [XDCL, #GATE] amp$#set_segment_eoi (file_identifier:
    amt$file_identifier;
        segment_pointer: amt$segment_pointer;
    VAR status: ost$status);
    amp$set_segment_eoi (file_identifier, segment_pointer, status);


  PROCEND amp$#set_segment_eoi;

MODEND amm$alternate_entry_points;
*DECK DECK=AMM$APPLY_KEY_DEFINITIONS EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$apply_key_definitions;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$APPLY_KEY_DEFINITIONS' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$apply_key_definitions (file_identifier:
    amt$file_identifier;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$APPLY_KEY_DEFINITIONS',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0,
          amk$apply_key_definitions);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$apply_key_definitions);
      RETURN;
    IFEND;

    call_block.operation := amc$apply_key_definitions;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$apply_key_definitions);
  PROCEND amp$apply_key_definitions;
MODEND amm$apply_key_definitions;
*DECK DECK=AMM$BEGIN_FILE_PARCEL EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$begin_file_parcel;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$BEGIN_FILE_PARCEL' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$begin_file_parcel (file_identifier:
    amt$file_identifier;
        general_commit: amt$general_commit;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$BEGIN_FILE_PARCEL',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0,
          amk$begin_file_parcel);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$begin_file_parcel);
      RETURN;
    IFEND;

    call_block.operation := amc$begin_file_parcel;

    call_block.begin_file_parcel.general_commit := general_commit;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$begin_file_parcel);
  PROCEND amp$begin_file_parcel;
MODEND amm$begin_file_parcel;
*DECK DECK=AMM$CHECK_NOWAIT_REQUEST EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$check_nowait_request;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$CHECK_NOWAIT_REQUEST' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$check_nowait_request (file_identifier:
    amt$file_identifier;
    VAR request_complete: boolean;
    VAR returned_parameters: amt$nowait_var_parameters;
    VAR request_status: ost$status;
        wait: ost$wait;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$CHECK_NOWAIT_REQUEST',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0,
          amk$check_nowait_request);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$check_nowait_request);
      RETURN;
    IFEND;

    call_block.operation := amc$check_nowait_request;

    call_block.check_nowait_request.request_complete := ^request_complete;
    call_block.check_nowait_request.returned_parameters :=
          ^returned_parameters;
    call_block.check_nowait_request.request_status := ^request_status;
    call_block.check_nowait_request.wait := wait;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$check_nowait_request);
  PROCEND amp$check_nowait_request;
MODEND amm$check_nowait_request;
*DECK DECK=AMM$CHECK_RECORD EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$check_record;

{ MODULE DECK AMMCKR }

?? TITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$CHECK_RECORD' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
*copyc AMK$ACCESS_METHOD
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$check_record (file_identifier:
    amt$file_identifier;
        working_storage_area: ^cell;
    VAR request_complete: boolean;
    VAR record_length: amt$max_record_length;
    VAR file_position: amt$file_position;
        wait: ost$wait;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$CHECK_RECORD',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$check_record);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$check_record);
      RETURN;
    IFEND;

    call_block.operation := amc$check_record_req;

    call_block.check_record.working_storage_area := working_storage_area;
    call_block.check_record.request_complete := ^request_complete;
    call_block.check_record.record_length := ^record_length;
    call_block.check_record.file_position := ^file_position;
    call_block.check_record.wait := wait;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$check_record);
  PROCEND amp$check_record;
MODEND amm$check_record;
*DECK DECK=AMM$CLOSE_VOLUME EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$close_volume;

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$CLOSE_VOLUME' ??
?? NEWTITLE := '  RING BRACKETS 2DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc AMK$ACCESS_METHOD
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc BAP$MARK_FAP_LAYER_CLOSED
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc AMP$TERMINATE_FILE
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$CLOSE_VOLUME
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$close_volume (file_identifier: amt$file_identifier;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$CLOSE_VOLUME',
      fap_layer_number = 0;

    VAR
      caller_id: ost$caller_identifier,
      bam_status: ost$status,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$close_volume);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$close_volume);
      RETURN;
    IFEND;

    call_block.operation := amc$close_volume_req;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$close_volume);

  PROCEND amp$close_volume;
MODEND amm$close_volume;
*DECK DECK=AMM$COMMIT_FILE_PARCEL EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$commit_file_parcel;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$COMMIT_FILE_PARCEL' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$commit_file_parcel (file_identifier:
    amt$file_identifier;
        phase: amt$commit_phase;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$COMMIT_FILE_PARCEL',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0,
          amk$commit_file_parcel);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$commit_file_parcel);
      RETURN;
    IFEND;

    call_block.operation := amc$commit_file_parcel;

    call_block.commit_file_parcel.phase := phase;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$commit_file_parcel);
  PROCEND amp$commit_file_parcel;
MODEND amm$commit_file_parcel;
*DECK DECK=AMM$CREATE_KEY_DEFINITION EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$create_key_definition;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$CREATE_KEY_DEFINITION' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$create_key_definition (file_identifier:
    amt$file_identifier;
        key_name: amt$key_name;
        key_position: amt$key_position;
        key_length: amt$key_length;
        optional_attributes: ^amt$optional_key_attributes;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$CREATE_KEY_DEFINITION',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0,
          amk$create_key_definition);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0,
            amk$create_key_definition);
      RETURN;
    IFEND;

    call_block.operation := amc$create_key_definition;

    call_block.create_key_definition.key_name := key_name;
    call_block.create_key_definition.key_position := key_position;
    call_block.create_key_definition.key_length := key_length;
    call_block.create_key_definition.optional_attributes :=
          optional_attributes;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$create_key_definition);
  PROCEND amp$create_key_definition;
MODEND amm$create_key_definition;
*DECK DECK=AMM$CREATE_NESTED_FILE EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$create_nested_file;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$CREATE_NESTED_FILE' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$create_nested_file (file_identifier:
    amt$file_identifier;
        definition: amt$nested_file_definition;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$CREATE_NESTED_FILE',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0,
          amk$create_nested_file);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$create_nested_file);
      RETURN;
    IFEND;

    call_block.operation := amc$create_nested_file;

    call_block.create_nested_file.definition := ^definition;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$create_nested_file);
  PROCEND amp$create_nested_file;
MODEND amm$create_nested_file;
*DECK DECK=AMM$DELETE_KEY EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$delete_key;

{ MODULE DECK AMMDKY }

?? TITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$DELETE_KEY' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
*copyc AMK$ACCESS_METHOD
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$delete_key (file_identifier: amt$file_identifier;
        key_location: ^cell;
        wait: ost$wait;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$DELETE_KEY',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$delete_key);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$delete_key);
      RETURN;
    IFEND;

    call_block.operation := amc$delete_key_req;

    call_block.delk.key_location := key_location;
    call_block.delk.wait := wait;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$delete_key);
  PROCEND amp$delete_key;
MODEND amm$delete_key;
*DECK DECK=AMM$DELETE_KEY_DEFINITION EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$delete_key_definition;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$DELETE_KEY_DEFINITION' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$delete_key_definition (file_identifier:
    amt$file_identifier;
        key_name: amt$key_name;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$DELETE_KEY_DEFINITION',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0,
          amk$delete_key_definition);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$delete_key_definition);
      RETURN;
    IFEND;

    call_block.operation := amc$delete_key_definition;
    call_block.delete_key_definition.key_name := key_name;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$delete_key_definition);
  PROCEND amp$delete_key_definition;
MODEND amm$delete_key_definition;
*DECK DECK=AMM$DELETE_NESTED_FILE EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$delete_nested_file;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$DELETE_NESTED_FILE' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$delete_nested_file (file_identifier:
    amt$file_identifier;
        nested_file_name: amt$nested_file_name;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$DELETE_NESTED_FILE',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0,
          amk$delete_nested_file);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$delete_nested_file);
      RETURN;
    IFEND;

    call_block.operation := amc$delete_nested_file;
    call_block.delete_nested_file.nested_file_name := nested_file_name;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$delete_nested_file);
  PROCEND amp$delete_nested_file;
MODEND amm$delete_nested_file;
*DECK DECK=AMM$DISPLAY_BAM_TABLES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Access Methods : Display Bam Tables' ??

MODULE amm$display_bam_tables;

{  PURPOSE:
{    This module contains the command parser for DISPLAY_BAM_TABLES.
{
{  DESIGN:
{    Open the output file, parse the command, and call the
{    appropriate procedures in BAM$DISPLAY_TABLES to display
{    the requested table to the output file.


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc bat$display_tables_indention
*copyc fmt$path_handle
*copyc fst$path_handle_name
*copyc fst$path_table_expansion_limit
*copyc ost$status
?? POP ??
*copyc amp$return
*copyc amp$put_next
*copyc bap$display_art
*copyc bap$display_files
*copyc bap$display_path_table
*copyc bap$display_pde_via_ph
*copyc bap$display_pt_stats
*copyc bap$display_task_file_table
*copyc bap$display_tfte_via_ph
*copyc bap$display_unused_paths
*copyc bap$process_pt_request
*copyc bap$validate_path_table_objects
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc fsp$close_file
*copyc fsp$copy_file
*copyc fsp$open_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc pmp$get_unique_name

*copyc amv$nil_file_identifier

?? TITLE := 'PROCEDURE [XDCL, #GATE] amp$display_bam_tables', EJECT ??

  PROCEDURE [XDCL, #GATE] amp$display_bam_tables
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (amp$disbt) display_bam_tables, disbt (
{   file, f: file = $optional
{   table, tables, t: list of key
{       (path_table_statistics, pts)
{       (path_table_files, ptf)
{       (path_table_unused_paths, ptup)
{       (path_description_entry, pde)
{       (task_file_table_entry, task_file_table_entries, tfte)
{       (auxiliary_request_table, art)
{       (path_table, pt)
{       (task_file_table, tft)
{       all
{     keyend = path_description_entry
{   path_table_expansion_limit, d, depth, ptel: key
{       (path_description_entry, pde)
{       (cycle_description, cd)
{       all
{     keyend = cd
{   task_file_table_expansion, e, expansion, tfte: key
{       (brief, b)
{       (full, f)
{     keyend = brief
{   validate_path_table_objects, vpto: (BY_NAME) boolean = no
{   output, o: (BY_NAME) file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 18] of clt$pdt_parameter_name,
        parameters: array [1 .. 7] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 18] of clt$keyword_specification,
          recend,
          default_value: string (22),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 5] of clt$keyword_specification,
          default_value: string (2),
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
          default_value: string (5),
        recend,
        type5: record
          header: clt$type_specification_header,
          default_value: string (2),
        recend,
        type6: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type7: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 4, 6, 12, 51, 44, 100], clc$command, 18, 7, 0, 0, 0, 0, 7, 'AMP$DISBT'],
            [['D                              ', clc$alias_entry, 3],
            ['DEPTH                          ', clc$alias_entry, 3],
            ['E                              ', clc$alias_entry, 4],
            ['EXPANSION                      ', clc$alias_entry, 4],
            ['F                              ', clc$abbreviation_entry, 1],
            ['FILE                           ', clc$nominal_entry, 1],
            ['O                              ', clc$abbreviation_entry, 6],
            ['OUTPUT                         ', clc$nominal_entry, 6],
            ['PATH_TABLE_EXPANSION_LIMIT     ', clc$nominal_entry, 3],
            ['PTEL                           ', clc$abbreviation_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 7],
            ['T                              ', clc$abbreviation_entry, 2],
            ['TABLE                          ', clc$nominal_entry, 2],
            ['TABLES                         ', clc$alias_entry, 2],
            ['TASK_FILE_TABLE_EXPANSION      ', clc$nominal_entry, 4],
            ['TFTE                           ', clc$abbreviation_entry, 4],
            ['VALIDATE_PATH_TABLE_OBJECTS    ', clc$nominal_entry, 5],
            ['VPTO                           ', clc$abbreviation_entry, 5]], [
{ PARAMETER 1
      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 2
      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 689, clc$optional_default_parameter, 0, 22],
{ PARAMETER 3
      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 192, clc$optional_default_parameter, 0, 2],
{ PARAMETER 4
      [15, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 5],
{ PARAMETER 5
      [17, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 2],
{ PARAMETER 6
      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_default_parameter, 0, 7],
{ PARAMETER 7
      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$file_type]],
{ PARAMETER 2
      [[1, 0, clc$list_type], [673, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [18], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 9], ['ART                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['AUXILIARY_REQUEST_TABLE        ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['PATH_DESCRIPTION_ENTRY         ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['PATH_TABLE                     ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['PATH_TABLE_FILES               ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['PATH_TABLE_STATISTICS          ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['PATH_TABLE_UNUSED_PATHS        ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PDE                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['PT                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['PTF                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['PTS                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['PTUP                           ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['TASK_FILE_TABLE                ', clc$nominal_entry,
            clc$normal_usage_entry, 8], ['TASK_FILE_TABLE_ENTRIES        ', clc$alias_entry,
            clc$normal_usage_entry, 5], ['TASK_FILE_TABLE_ENTRY          ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['TFT                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 8], ['TFTE                           ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5]]], 'path_description_entry'],
{ PARAMETER 3
      [[1, 0, clc$keyword_type], [5], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['CD                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['CYCLE_DESCRIPTION              ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['PATH_DESCRIPTION_ENTRY         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['PDE                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1]], 'cd'],
{ PARAMETER 4
      [[1, 0, clc$keyword_type], [4], [['B                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['BRIEF                          ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['F                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FULL                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]], 'brief'],
{ PARAMETER 5
      [[1, 0, clc$boolean_type], 'no'],
{ PARAMETER 6
      [[1, 0, clc$file_type], '$output'],
{ PARAMETER 7
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$file = 1,
      p$table = 2,
      p$path_table_expansion_limit = 3,
      p$task_file_table_expansion = 4,
      p$validate_path_table_objects = 5,
      p$output = 6,
      p$status = 7;

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

    VAR
      unique_fid: amt$file_identifier,
      ignore_status: ost$status;

?? TITLE := 'PROCEDURE abort_handler', EJECT ??

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

      IF unique_fid <> amv$nil_file_identifier THEN
        fsp$close_file (unique_fid, ignore_status);
        amp$return (unique_name, ignore_status);
      IFEND;

    PROCEND abort_handler;

    TYPE
      table_displays = set of (path_table_statistics, path_table_files, path_table_unused_paths,
            path_description_entry, task_file_table_entry, auxiliary_request_table, path_table,
            task_file_table);

    VAR
      attachment_options: array [1 .. 6] of fst$attachment_option,
      ba: amt$file_byte_address,
      default_creation_attributes: array [1 .. 1] of fst$file_cycle_attribute,
      evaluated_file_reference: fst$evaluated_file_reference,
      expand_task_file_table_entry: boolean,
      list: ^clt$data_value,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      path_table_expansion_limit: fst$path_table_expansion_limit,
      process_pt_results: bat$process_pt_results,
      tables_to_display: table_displays,
      unique_name: ost$name;

    status.normal := TRUE;

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

    unique_fid := amv$nil_file_identifier;
    #SPOIL (unique_fid);
    osp$establish_block_exit_hndlr (^abort_handler);

  /display_tables/
    BEGIN
      default_creation_attributes [1].selector := fsc$file_contents_and_processor;
      default_creation_attributes [1].file_contents := fsc$list;
      default_creation_attributes [1].file_processor := fsc$unknown_processor;
      attachment_options [1].selector := fsc$access_and_share_modes;
      attachment_options [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
      attachment_options [1].share_modes.selector := fsc$specific_share_modes;
      attachment_options [1].share_modes.value := $fst$file_access_options [];
      attachment_options [2].selector := fsc$access_and_share_modes;
      attachment_options [2].access_modes.selector := fsc$specific_access_modes;
      attachment_options [2].access_modes.value := $fst$file_access_options [fsc$append];
      attachment_options [2].share_modes.selector := fsc$specific_share_modes;
      attachment_options [2].share_modes.value := $fst$file_access_options [];
      attachment_options [3].selector := fsc$open_share_modes;
      attachment_options [3].open_share_modes := $fst$file_access_options [];
      attachment_options [4].selector := fsc$open_share_modes;
      attachment_options [4].open_share_modes := $fst$file_access_options
            [fsc$read, fsc$shorten, fsc$append, fsc$modify, fsc$execute];
      attachment_options [5].selector := fsc$sequential_access;
      attachment_options [5].sequential_access := TRUE;
      attachment_options [6].selector := fsc$delete_data;
      attachment_options [6].delete_data := TRUE;

      pmp$get_unique_name (unique_name, status);
      IF NOT status.normal THEN
        EXIT /display_tables/;
      IFEND;

      fsp$open_file (unique_name, amc$record, ^attachment_options, ^default_creation_attributes, NIL, NIL,
            NIL, unique_fid, status);
      IF NOT status.normal THEN
        EXIT /display_tables/;
      IFEND;

      tables_to_display := $table_displays [];
      list := pvt [p$table].value;
      WHILE list <> NIL DO
        IF list^.element_value^.keyword_value = 'ALL' THEN
          tables_to_display := tables_to_display + $table_displays
                [path_table_statistics, path_table_files, path_table_unused_paths, auxiliary_request_table,
                path_table, task_file_table];
        ELSEIF (list^.element_value^.keyword_value = 'PATH_TABLE_STATISTICS') THEN
          tables_to_display := tables_to_display + $table_displays [path_table_statistics];
        ELSEIF (list^.element_value^.keyword_value = 'PATH_TABLE_FILES') THEN
          tables_to_display := tables_to_display + $table_displays [path_table_files];
        ELSEIF (list^.element_value^.keyword_value = 'PATH_TABLE_UNUSED_PATHS') THEN
          tables_to_display := tables_to_display + $table_displays [path_table_unused_paths];
        ELSEIF (list^.element_value^.keyword_value = 'PATH_DESCRIPTION_ENTRY') THEN
          tables_to_display := tables_to_display + $table_displays [path_description_entry];
        ELSEIF (list^.element_value^.keyword_value = 'TASK_FILE_TABLE_ENTRY') THEN
          tables_to_display := tables_to_display + $table_displays [task_file_table_entry];
        ELSEIF (list^.element_value^.keyword_value = 'AUXILIARY_REQUEST_TABLE') THEN
          tables_to_display := tables_to_display + $table_displays [auxiliary_request_table];
        ELSEIF (list^.element_value^.keyword_value = 'PATH_TABLE') THEN
          tables_to_display := tables_to_display + $table_displays [path_table];
        ELSEIF (list^.element_value^.keyword_value = 'TASK_FILE_TABLE') THEN
          tables_to_display := tables_to_display + $table_displays [task_file_table];
        IFEND;
        list := list^.link;
      WHILEND;

      IF (path_table IN tables_to_display) OR (path_description_entry IN tables_to_display) THEN
        IF pvt [p$path_table_expansion_limit].value^.keyword_value = 'PATH_DESCRIPTION_ENTRY' THEN
          path_table_expansion_limit := fsc$disbt_pde;
        ELSEIF pvt [p$path_table_expansion_limit].value^.keyword_value = 'CYCLE_DESCRIPTION' THEN
          path_table_expansion_limit := fsc$disbt_cd;
        ELSE
          path_table_expansion_limit := fsc$disbt_all;
        IFEND;
      IFEND;

      IF (task_file_table IN tables_to_display) OR (task_file_table_entry IN tables_to_display) THEN
        IF pvt [p$task_file_table_expansion].value^.keyword_value = 'FULL' THEN
          expand_task_file_table_entry := TRUE;
        ELSE
          expand_task_file_table_entry := FALSE;
        IFEND;
      IFEND;

      IF (path_description_entry IN tables_to_display) OR (task_file_table_entry IN tables_to_display) THEN
        IF pvt [p$file].specified THEN
          clp$evaluate_file_reference (pvt [p$file].value^.file_value^,
                $clt$file_ref_parsing_options [], {resolve_cycle_number = } FALSE, evaluated_file_reference,
                status);
          IF NOT status.normal THEN
            EXIT /display_tables/;
          IFEND;
          bap$process_pt_request ($bat$process_pt_work_list [bac$resolve_to_catalog, bac$resolve_path],
                {local_file_name = } osc$null_name, evaluated_file_reference, process_pt_results, status);
          IF NOT status.normal THEN
            EXIT /display_tables/;
          IFEND;
          IF NOT evaluated_file_reference.path_handle_info.path_handle_present THEN
            STRINGREP (output_string, output_length, ' ', pvt [p$file].value^.file_value^,
                  ' does not exist in the path table.');
            amp$put_next (unique_fid, ^output_string, output_length, ba, status);
            EXIT /display_tables/;
          IFEND;
        ELSE
          STRINGREP (output_string, output_length, ' ', 'The FILE parameter is required to display an entry.')
                ;
          amp$put_next (unique_fid, ^output_string, output_length, ba, status);
          EXIT /display_tables/;
        IFEND;
      IFEND;

      IF pvt [p$validate_path_table_objects].value^.boolean_value.value THEN
        bap$validate_path_table_objects (unique_fid, status);
        IF NOT status.normal THEN
          EXIT /display_tables/;
        IFEND;
      IFEND;

      IF path_table_statistics IN tables_to_display THEN
        bap$display_pt_stats (unique_fid, status);
        IF NOT status.normal THEN
          EXIT /display_tables/;
        IFEND;
      IFEND;
      IF path_table_files IN tables_to_display THEN
        bap$display_files (unique_fid, status);
        IF NOT status.normal THEN
          EXIT /display_tables/;
        IFEND;
      IFEND;
      IF path_table_unused_paths IN tables_to_display THEN
        bap$display_unused_paths (unique_fid, status);
        IF NOT status.normal THEN
          EXIT /display_tables/;
        IFEND;
      IFEND;
      IF path_description_entry IN tables_to_display THEN
        bap$display_pde_via_ph (unique_fid, evaluated_file_reference.path_handle_info.path_handle,
              path_table_expansion_limit, status);
        IF NOT status.normal THEN
          EXIT /display_tables/;
        IFEND;
      IFEND;
      IF task_file_table_entry IN tables_to_display THEN
        bap$display_tfte_via_ph (unique_fid, evaluated_file_reference.path_handle_info.path_handle,
              expand_task_file_table_entry, status);
        IF NOT status.normal THEN
          EXIT /display_tables/;
        IFEND;
      IFEND;
      IF auxiliary_request_table IN tables_to_display THEN
        bap$display_art (unique_fid, status);
        IF NOT status.normal THEN
          EXIT /display_tables/;
        IFEND;
      IFEND;
      IF path_table IN tables_to_display THEN
        bap$display_path_table (unique_fid, path_table_expansion_limit, status);
        IF NOT status.normal THEN
          EXIT /display_tables/;
        IFEND;
      IFEND;
      IF task_file_table IN tables_to_display THEN
        bap$display_task_file_table (unique_fid, expand_task_file_table_entry, status);
      IFEND;

    END /display_tables/;

    IF unique_fid <> amv$nil_file_identifier THEN
      fsp$close_file (unique_fid, ignore_status);
      IF status.normal AND (NOT ignore_status.normal) THEN
        status := ignore_status;
      IFEND;
    IFEND;

    IF status.normal THEN
      fsp$copy_file (unique_name, pvt [p$output].value^.file_value^, NIL, NIL, NIL, status);
    IFEND;

    amp$return (unique_name, ignore_status);
    IF status.normal AND (NOT ignore_status.normal) THEN
      status := ignore_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND amp$display_bam_tables;

MODEND amm$display_bam_tables;
*DECK DECK=AMM$ERASE_TAPE_BLOCK EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$erase_tape_block;

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$ERASE_TAPE_BLOCK' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$ERASE_TAPE_BLOCK
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$erase_tape_block (file_identifier: amt$file_identifier;
    block_length: amt$max_block_length;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$ERASE_TAPE_BLOCK',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$erase_tape_block);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$erase_tape_block);
      RETURN;
    IFEND;

    call_block.operation := amc$erase_tape_block;
    call_block.erase_tape_block.block_length := block_length;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$erase_tape_block);
  PROCEND amp$erase_tape_block;
MODEND amm$erase_tape_block;

*DECK DECK=AMM$EXCEPTION_CONDITIONS EXPAND=TRUE
{ MODULE DECK AMMECC }
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$exception_conditions;

{}
{ PURPOSE:
{   This module contains the code and message template definitions for }
{   exception conditions detected by the Basic Access Method. These}
{   definitions are actually placed on common decks grouped according to}
{   class of error (validation versus program interpretive) and access}
{   method request.}
*copy AME$CONDITION_CODES
MODEND amm$exception_conditions;
*DECK DECK=AMM$FETCH EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$fetch;

{ MODULE DECK AMMFFA }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$FETCH' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amk$access_method
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
*copyc amh$fetch
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$fetch ALIAS 'amxftch' (file_identifier:
    amt$file_identifier;
    VAR file_attributes: amt$fetch_attributes;
    VAR status: ost$status);

   PROCEDURE get_device_classes(call_block: amt$call_block, file_identifer: amt$file_identifier,
       file_instance: ^bat$task_file_entry);

    VAR
      file_id_is_valid: boolean,
      target_defined: boolean,
      i: integer,
      current_file_identifier: amt$file_identifier,
      current_file_instance: ^bat$task_file_entry;

{ GET_DEVICE_CLASSES will fill the sets INPUT_DEVICE_CLASSES and OUTPUT_
{ DEVICE_CLASSES if the subject file is a connected file.  If INPUT_DEVICE_
{ CLASSES is specified, this procedure will follow the path of most recently
{ connected files.  If OUTPUT_DEVICE_CLASSES is specified, GET_OUTPUT_DEVICE_
{ CLASSES, (defined below) will be called recursivly to find the device class
{ of all files connected directly or indirectly to the subject file.

PROCEDURE get_output_device_classes (file_id: amt$file_identifier);

VAR   file_id_is_valid: boolean,
      current_file_id: amt$file_identifier,
      current_file_instance: ^bat$task_file_entry;


  current_file_id :=file_id;
  WHILE TRUE DO
     bap$validate_file_identifier (current_file_id, current_file_instance,
       file_id_is_valid);
     IF NOT file_id_is_valid THEN
       osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
             interface_name, status);
       RETURN;
     IFEND;

     call_block.fetch.file_attributes^[i].output_device_classes :=
           call_block.fetch.file_attributes^[i].output_device_classes +
           $rmt$device_classes[current_file_instance^.device_class];
     IF (current_file_instance^.device_class = rmc$connected_file_device) AND
           (current_file_instance^.first_target.defined) THEN
       get_output_device_classes(current_file_instance^.first_target.file_identifier);
     IFEND;
     IF NOT current_file_instance^.next_target.defined THEN
       RETURN;
     IFEND;
     current_file_id := current_file_instance^.next_target.file_identifier;
   WHILEND;
PROCEND;

   FOR i := LOWERBOUND(Call_block.fetch.file_attributes^) TO
     UPPERBOUND(Call_block.fetch.file_attributes^) DO
     IF (call_block.fetch.file_attributes^[i].key = amc$output_device_classes) THEN
       call_block.fetch.file_attributes^[i].output_device_classes := $rmt$device_classes[ ];
        get_output_device_classes(file_identifier);
     ELSEIF (call_block.fetch.file_attributes^[i].key = amc$input_device_classes) THEN
       call_block.fetch.file_attributes^[i].input_device_classes := $rmt$device_classes[ ];
       current_file_instance := file_instance;
       current_file_identifier := file_identifier;
       REPEAT
         bap$validate_file_identifier (current_file_identifier, current_file_instance,
           file_id_is_valid);
         IF NOT file_id_is_valid THEN
           osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
                interface_name, status);
           RETURN;
         IFEND;
         call_block.fetch.file_attributes^[i].input_device_classes :=
               call_block.fetch.file_attributes^[i].input_device_classes +
               $rmt$device_classes[current_file_instance^.device_class];
         target_defined := (current_file_instance^.device_class = rmc$connected_file_device) AND
               (current_file_instance^.first_target.defined);
         IF target_defined THEN
           current_file_identifier := current_file_instance^.first_target.file_identifier;
         IFEND;
       UNTIL NOT target_defined;
     ELSEIF call_block.fetch.file_attributes^ [i].key = amc$device_class THEN
       call_block.fetch.file_attributes^ [i].device_class := current_file_instance^.device_class;
     IFEND;
   FOREND;
PROCEND;


    CONST
      interface_name = 'AMP$FETCH',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$fetch);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$fetch);
      RETURN;
    IFEND;

    call_block.operation := amc$fetch_req;
    call_block.fetch.file_attributes := ^file_attributes;

*copy bai$call_fap_control

    IF (file_instance^.device_class = rmc$connected_file_device) THEN
      get_device_classes(call_block, file_identifier, file_instance);
    IFEND;

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$fetch);
  PROCEND amp$fetch;
MODEND amm$fetch;
*DECK DECK=AMM$FETCH_ACCESS_INFORMATION EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$fetch_access_information;

{ MODULE DECK AMMFAI }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$FETCH_ACCESS_INFORMATION' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$FETCH_ACCESS_INFORMATION
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$fetch_access_information ALIAS 'amxfnfo'
    (file_identifier: amt$file_identifier;
    VAR access_information: amt$access_information;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$FETCH_ACCESS_INFORMATION',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0,
          amk$fetch_access_information);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$fetch_access_information);
      RETURN;
    IFEND;

    call_block.operation := amc$fetch_access_information_rq;
    call_block.fai.access_information := ^access_information;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$fetch_access_information);
  PROCEND amp$fetch_access_information;
MODEND amm$fetch_access_information;
*DECK DECK=AMM$FETCH_FAP_POINTER EXPAND=TRUE
*copy osd$default_pragmats
MODULE amm$fetch_fap_pointer;

?? TITLE := 'NOS/VE : BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$FETCH_FAP_POINTER' ??
?? NEWTITLE := '  RING BRACKETS 2DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$fap_program_actions
*copyc ame$fap_validation_errors
*copyc ame$improper_file_id
*copyc ame$ring_validation_errors
*copyc amk$access_method
*copyc amt$fap_declarations
*copyc ost$caller_identifier
?? POP ??
?? EJECT ??
*copyc amh$also
*copyc amh$fetch_fap_pointer
*copyc amp$set_file_instance_abnormal
*copyc bap$validate_file_identifier
*copyc osp$copy_local_status_to_status
*copyc osp$set_status_abnormal

  PROCEDURE [XDCL, #GATE] amp$fetch_fap_pointer
    (    file_identifier: amt$file_identifier;
         layer_number: amt$fap_layer_number;
     VAR structure_pointer: ^cell;
     VAR status: ost$status);

    CONST
      interface_name = 'AMP$FETCH_FAP_POINTER';

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      layer: ^bat$fap_descriptor;

    #CALLER_ID (caller_id);

    bam_status.normal := TRUE;
    structure_pointer := NIL;

    #KEYPOINT (osk$entry, 0, amk$fetch_fap_pointer);

    bap$validate_file_identifier (file_identifier, file_instance,
          file_id_is_valid);
    IF file_id_is_valid THEN

*copyc bai$get_fap_layer

      IF bam_status.normal THEN
        IF caller_id.ring <= layer^.loaded_ring THEN
          structure_pointer := layer^.structure_pointer;
          IF structure_pointer = NIL THEN
            amp$set_file_instance_abnormal (file_identifier,
                  ame$nil_structure_pointer, amc$fetch_fap_pointer_req, ' ',
                  bam_status);
          IFEND;
        ELSE
          amp$set_file_instance_abnormal (file_identifier,
                ame$ring_validation_error, amc$fetch_fap_pointer_req, ' ',
                bam_status);
        IFEND;
      IFEND;
    ELSE
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, bam_status);
    IFEND;

    osp$copy_local_status_to_status (bam_status, status);

    #KEYPOINT (osk$exit, 0, amk$fetch_fap_pointer);

  PROCEND amp$fetch_fap_pointer;

MODEND amm$fetch_fap_pointer;
*DECK DECK=AMM$FETCH_NESTED_FILE_ATTRIB EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$fetch_nested_file_attrib;

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$FETCH_NESTED_FILE_ATTRIB' ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc amk$access_method
*copyc amt$call_block
*copyc amt$keyed_file_attributes
*copyc ost$caller_identifier
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
{*copyc amh$fetch_nested_file_attrib
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$fetch_nested_file_attrib
    (    file_identifier: amt$file_identifier;
         keyed_file_attributes: ^amt$keyed_file_attributes;
     VAR status: ost$status);

    CONST
      interface_name = 'AMP$FETCH_NESTED_FILE_ATTRIB',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;

    #keypoint (osk$entry, 0, amk$fetch_nested_file_attrib);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$fetch_nested_file_attrib);
      RETURN;
    IFEND;

    call_block.operation := amc$fetch_nested_file_attrib;
    call_block.fetch_nested_file_attrib.keyed_file_attributes := keyed_file_attributes;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;

    #keypoint (osk$exit, 0, amk$fetch_nested_file_attrib);
  PROCEND amp$fetch_nested_file_attrib;
MODEND amm$fetch_nested_file_attrib;

*DECK DECK=AMM$FETCH_TAPE_LABEL_ATTRIBUTE EXPAND=TRUE
*DECK DECK=AMM$FILE_STRUCTURE_FUNCTIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Basic Access Method : File Attribute Interfaces' ??

MODULE amm$file_structure_functions;

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc ame$ring_validation_errors
*copyc amk$access_method
*copyc amt$get_attributes
*copyc cle$ecc_lexical
*copyc fmt$file_attribute_keys
*copyc fmt$static_label_header
*copyc fsc$local
*copyc fse$system_conditions
*copyc fst$file_reference
*copyc fst$goi_object_information
*copyc osd$integer_limits
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
?? POP ??
*copyc bap$change_file_attributes
*copyc bap$fetch_art_table_pointer
*copyc bap$get_default_file_attribs
*copyc bap$get_$local_object_info
*copyc bap$merge_static_attributes
*copyc bap$set_file_reference_abnormal
*copyc bap$store_art_table_pointer
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_integer_to_string
*copyc clp$convert_str_to_path_handle
*copyc clp$convert_string_to_file_ref
*copyc clp$get_fs_path_elements
*copyc clp$get_ultimate_connection
*copyc clp$only_validate_name
*copyc clp$trimmed_string_size
*copyc clp$validate_name
*copyc fsp$adjust_tape_defaults
*copyc fsp$close_file
*copyc fsp$determine_access_modes
*copyc fsp$determine_global_access
*copyc fsp$evaluate_file_reference
*copyc fsp$expand_file_label
*copyc osp$file_access_condition
*copyc fsp$file_is_$job_log
*copyc fsp$open_file
*copyc fsp$set_evaluated_file_abnormal
*copyc fsp$set_file_reference_abnormal
*copyc i#current_sequence_position
*copyc ifp$get_page_length_width
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$copy_local_status_to_status
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pfp$r3_get_object_information

*copyc amv$access_mode
*copyc amv$label_options
*copyc amv$message_control
*copyc amv$nil_file_identifier
*copyc amv$valid_ring
*copyc bav$task_file_table
*copyc fmv$global_file_information
*copyc fmv$system_file_attributes
*copyc fsv$default_job_environ_info
*copyc osv$initial_exception_context
*copyc osv$lower_to_upper

?? TITLE := 'PROCEDURE [XDCL, #GATE] amp$change_file_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] amp$change_file_attributes
    (    file: fst$file_reference;
         file_attributes: ^amt$file_attributes;
     VAR status: ost$status);

    CONST
      command_file_reference_allowed = TRUE;

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      open_changed_file: boolean;

?? NEWTITLE := 'PROCEDURE open_and_close_file', EJECT ??

    PROCEDURE open_and_close_file;

      VAR
        attachment_options: array [1 .. 2] of fst$attachment_option,
        file_identifier: amt$file_identifier,
        ignore_status: ost$status,
        local_status: ost$status,
        path: fst$path,
        path_size: fst$path_size;

?? NEWTITLE := 'PROCEDURE block_exit_handler', EJECT ??

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

        VAR
          ignore_status: ost$status;

        IF file_identifier <> amv$nil_file_identifier THEN
          fsp$close_file (file_identifier, ignore_status);
        IFEND;

      PROCEND block_exit_handler;
?? OLDTITLE, EJECT ??

      attachment_options [1].selector := fsc$access_and_share_modes;
      attachment_options [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options [1].access_modes.value := $fst$file_access_options
            [fsc$read, fsc$modify, fsc$append];
      attachment_options [1].share_modes.selector := fsc$specific_share_modes;
      attachment_options [1].share_modes.value := $fst$file_access_options [];
      attachment_options [2].selector := fsc$open_share_modes;
      attachment_options [2].open_share_modes := $fst$file_access_options [];
      clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position =} FALSE, path,
            path_size, local_status);
      osp$establish_block_exit_hndlr (^block_exit_handler);
      fsp$open_file (path (1, path_size), amc$record, ^attachment_options, NIL, NIL, NIL, NIL,
            file_identifier, local_status);
      IF file_identifier <> amv$nil_file_identifier THEN
        fsp$close_file (file_identifier, ignore_status);
      IFEND;
      IF NOT local_status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
      IFEND;
      osp$disestablish_cond_handler;

    PROCEND open_and_close_file;
?? OLDTITLE, EJECT ??
    VAR
      context: ^ost$ecp_exception_context;

    context := NIL;

    IF file_attributes = NIL THEN
      RETURN;
    IFEND;

    fsp$evaluate_file_reference (file, NOT command_file_reference_allowed, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /change_loop/
    REPEAT
      bap$change_file_attributes (file_attributes, evaluated_file_reference, open_changed_file, status);
      IF NOT status.normal THEN
        IF osp$file_access_condition (status) THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_evaluated_file_ref;
            context^.file.evaluated_file_reference := evaluated_file_reference;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        ELSEIF status.condition = pfe$tape_attached_on_client THEN
          CYCLE /change_loop/;
        ELSE
          RETURN;
        IFEND;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    IF open_changed_file THEN
      open_and_close_file;
    IFEND

  PROCEND amp$change_file_attributes;

?? TITLE := '[XDCL, #GATE] amp$file', EJECT ??
*copy amh$file

  PROCEDURE [XDCL, #GATE] amp$file
    (    local_file_name: amt$local_file_name;
         file_attributes: amt$file_attributes;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      name_is_valid: boolean,
      validated_attributes: ^amt$file_attributes,
      validated_name: amt$local_file_name;

    #KEYPOINT (osk$entry, 0, amk$file);
    #CALLER_ID (caller_id);
    status.normal := TRUE;

  /file_request/
    BEGIN
      clp$validate_name (local_file_name, validated_name, name_is_valid);
      IF NOT name_is_valid THEN
        osp$set_status_abnormal (amc$access_method_id, cle$improper_name, local_file_name, status);
      IFEND;

      PUSH validated_attributes: [1 .. UPPERBOUND (file_attributes)];
      validated_attributes^ := file_attributes;

      amp$validate_attributes (validated_name, amc$file_req, caller_id.ring, validated_attributes, status);
      IF NOT status.normal THEN
        EXIT /file_request/;
      IFEND;

      bap$store_art_table_pointer (validated_name, validated_attributes, status);
    END /file_request/;

    #KEYPOINT (osk$exit, 0, amk$file);

  PROCEND amp$file;
?? TITLE := '[XDCL, #GATE] amp$get_file_attributes', EJECT ??
*copy amh$get_file_attributes

  PROCEDURE [XDCL, #GATE] amp$get_file_attributes
    (    file: fst$file_reference;
     VAR file_attributes: {input/output} amt$get_attributes;
     VAR file_exists: boolean;
     VAR file_previously_opened: boolean;
     VAR contains_data: boolean;
     VAR status: ost$status);

    CONST
      added_space_for_max_label_size = 1012,
      command_file_reference_allowed = TRUE,
      estimated_label_size = 240,
      max_connections = 2,  { an optimum estimate for the number of file connections }
      max_volumes = 4096,
      nil_object_info_text = 'NEXT of object_information in work_area resulted in a NIL pointer in ' CAT
            'AMP$GET_FILE_ATTRIBUTES',
      output_path_length = 14;

    VAR
      default_information_request: [oss$job_paged_literal, READ] fst$goi_information_request :=
            [[fsc$specific_depth, 1], [fsc$goi_cycle_size, fsc$goi_file_label]];

    VAR

{ Variables shared with nested procedures

      caller_id: ost$caller_identifier,
      current_status: ost$status,
      cycle_object_p: ^fst$goi_object,
      default_new_retention: fst$retention,
      default_new_retention_specified: boolean,
      device_class: rmt$device_class,
      evaluated_file_reference: fst$evaluated_file_reference,
      file_label_p: ^SEQ ( * ),
      file_object_p: ^fst$goi_object,
      file_request_attributes_p: ^amt$file_attributes,
      information_request: fst$goi_information_request,
      job_environment_information_p: ^fst$job_environment_information,
      number_of_volumes: 1 .. max_volumes,
      object_information_p: ^fst$goi_object_information,
      page_length_width: array [1 .. 2] of ift$terminal_attribute,
      static_label_attributes: bat$static_label_attributes,
      target_device_class: rmt$device_class,
      work_area_p: ^SEQ ( * ),
      work_area_size: integer,

{ Variables local only to the main procedure

      local_file_name: amt$local_file_name,
      name_is_valid: boolean,
      validated_name: amt$local_file_name;

?? NEWTITLE := 'assign_attribute_values', EJECT ??

    PROCEDURE assign_attribute_values;

      VAR
        i: ost$positive_integers,
        i_string: ^ost$string,
        ignore_status: ^ost$status,
        index: ost$non_negative_integers,
        local_status: ^ost$status,
        shared_queue_name: ost$name;

      FOR i := 1 TO UPPERBOUND (file_attributes) DO
        CASE file_attributes [i].key OF
        = amc$access_mode =
          fsp$determine_access_modes (job_environment_information_p, file_object_p,
                file_attributes [i].access_mode, file_attributes [i].source);
          IF (file_attributes [i].source = amc$access_method_default) AND (object_information_p <> NIL) AND
                fsp$file_is_$job_log (object_information_p^.resolved_path) THEN
            file_attributes [i].access_mode := $pft$usage_selections [pfc$read, pfc$append];

{ The following assignment is necessary for the connected file fap to determine the appropriate access modes
{ for $JOB_LOG when it is being opened as the target of a file connection.

            file_attributes [i].source := amc$file_command;
          IFEND;
        = amc$application_info =
          IF (file_object_p = NIL) OR (file_object_p^.applicable_file_permit = NIL) THEN
            file_attributes [i].application_info := ' ';
          ELSE
            file_attributes [i].application_info := file_object_p^.applicable_file_permit^.application_info;
          IFEND;
          file_attributes [i].source := amc$local_file_information;
        = amc$block_type =
          file_attributes [i].block_type := static_label_attributes.block_type;
          file_attributes [i].source := static_label_attributes.block_type_source;
        = amc$character_conversion =
          file_attributes [i].character_conversion := static_label_attributes.character_conversion;
          file_attributes [i].source := static_label_attributes.character_conversion_source;
        = amc$clear_space =
          file_attributes [i].clear_space := static_label_attributes.clear_space;
          file_attributes [i].source := static_label_attributes.clear_space_source;
        = amc$device_class =
          file_attributes [i].device_class := device_class;
          file_attributes [i].source := amc$open_request;
        = amc$error_exit_name =
          IF job_environment_information_p = NIL THEN
            file_attributes [i].error_exit_name := fmv$system_file_attributes.dynamic_label.error_exit_name;
            file_attributes [i].source := fmv$system_file_attributes.dynamic_label.error_exit_name_source;
          ELSE
            file_attributes [i].error_exit_name := job_environment_information_p^.error_exit_procedure_name;
            file_attributes [i].source := job_environment_information_p^.attachment_options_sources.
                  error_exit_name_source;
          IFEND;
        = amc$error_options =
          file_attributes [i].error_options := fmv$system_file_attributes.dynamic_label.error_options;
          file_attributes [i].source := fmv$system_file_attributes.dynamic_label.error_options_source;
          IF file_request_attributes_p <> NIL THEN
            index := 0;
            REPEAT
              index := index + 1;
              IF file_request_attributes_p^ [index].key = amc$error_options THEN
                file_attributes [i].error_options := file_request_attributes_p^ [index].error_options;
                file_attributes [i].source := amc$file_request;
              IFEND;
            UNTIL (file_request_attributes_p^ [index].key = amc$error_options) OR
                  (index = UPPERBOUND (file_request_attributes_p^));
          IFEND;
        = amc$file_access_procedure =
          file_attributes [i].file_access_procedure := static_label_attributes.file_access_procedure;
          file_attributes [i].source := static_label_attributes.file_access_procedure_source;
        = amc$file_contents =
          file_attributes [i].file_contents := static_label_attributes.file_contents;
          file_attributes [i].source := static_label_attributes.file_contents_source;
        = amc$file_length =
          IF (cycle_object_p = NIL) OR (cycle_object_p^.cycle_size = NIL) THEN
            file_attributes [i].file_length := 0;
          ELSE
            file_attributes [i].file_length := cycle_object_p^.cycle_size^;
          IFEND;
          file_attributes [i].source := amc$local_file_information;
        = amc$file_limit =
          file_attributes [i].file_limit := static_label_attributes.file_limit;
          file_attributes [i].source := static_label_attributes.file_limit_source;
        = amc$file_organization =
          file_attributes [i].file_organization := static_label_attributes.file_organization;
          file_attributes [i].source := static_label_attributes.file_organization_source;
        = amc$file_processor =
          file_attributes [i].file_processor := static_label_attributes.file_processor;
          file_attributes [i].source := static_label_attributes.file_processor_source;
        = amc$file_structure =
          file_attributes [i].file_structure := static_label_attributes.file_structure;
          file_attributes [i].source := static_label_attributes.file_structure_source;
        = amc$forced_write =
          file_attributes [i].forced_write := static_label_attributes.forced_write;
          file_attributes [i].source := static_label_attributes.forced_write_source;
        = amc$global_access_mode =
          fsp$determine_global_access (caller_id.ring, job_environment_information_p, file_object_p,
                cycle_object_p, static_label_attributes.ring_attributes,
                file_attributes [i].global_access_mode);
          file_attributes [i].source := amc$local_file_information;
        = amc$global_file_address =
          IF job_environment_information_p = NIL THEN
            file_attributes [i].global_file_address := 0;
          ELSE
            file_attributes [i].global_file_address := job_environment_information_p^.job_file_address;
          IFEND;
          file_attributes [i].source := amc$local_file_information;
        = amc$global_file_name =
          IF cycle_object_p = NIL THEN
            file_attributes [i].global_file_name := fmv$system_file_attributes.descriptive_label.
                  global_file_name;
          ELSE
            file_attributes [i].global_file_name := cycle_object_p^.cycle_global_file_name;
          IFEND;
          file_attributes [i].source := amc$local_file_information;
        = amc$global_file_position =
          IF job_environment_information_p = NIL THEN
            file_attributes [i].global_file_position := amc$boi;
          ELSE
            file_attributes [i].global_file_position := job_environment_information_p^.job_file_position;
          IFEND;
          file_attributes [i].source := amc$local_file_information;
        = amc$global_share_mode =
          IF (job_environment_information_p <> NIL) AND
                job_environment_information_p^.cycle_attached THEN
            #UNCHECKED_CONVERSION (job_environment_information_p^.attached_share_modes,
                  file_attributes [i].global_share_mode);
          ELSEIF (file_object_p <> NIL) AND (file_object_p^.applicable_file_permit <> NIL) THEN
            IF (cycle_object_p <> NIL) AND (cycle_object_p^.cycle_information <> NIL) THEN
              file_attributes [i].global_share_mode := file_object_p^.applicable_file_permit^.
                    share_requirements + cycle_object_p^.cycle_information^.outstanding_access_modes;
            ELSE
              file_attributes [i].global_share_mode := file_object_p^.applicable_file_permit^.
                    share_requirements;
            IFEND;
          ELSE
            file_attributes [i].global_share_mode := fmv$system_file_attributes.descriptive_label.
                  global_share_mode;
          IFEND;
          file_attributes [i].source := amc$local_file_information;
        = amc$internal_code =
          file_attributes [i].internal_code := static_label_attributes.internal_code;
          file_attributes [i].source := static_label_attributes.internal_code_source;
        = amc$label_exit_name =
          IF job_environment_information_p = NIL THEN
            file_attributes [i].label_exit_name := fmv$system_file_attributes.dynamic_label.label_exit_name;
            file_attributes [i].source := fmv$system_file_attributes.dynamic_label.label_exit_name_source;
          ELSE
            file_attributes [i].label_exit_name := job_environment_information_p^.label_exit_procedure_name;
            file_attributes [i].source := job_environment_information_p^.attachment_options_sources.
                  label_exit_name_source;
          IFEND;
        = amc$label_options =
          file_attributes [i].label_options := fmv$system_file_attributes.dynamic_label.label_options;
          file_attributes [i].source := fmv$system_file_attributes.dynamic_label.label_options_source;
        = amc$label_type =
          file_attributes [i].label_type := static_label_attributes.label_type;
          file_attributes [i].source := static_label_attributes.label_type_source;
        = amc$line_number =
          file_attributes [i].line_number := static_label_attributes.line_number;
          file_attributes [i].source := static_label_attributes.line_number_source;
        = amc$max_block_length =
          file_attributes [i].max_block_length := static_label_attributes.max_block_length;
          file_attributes [i].source := static_label_attributes.max_block_length_source;
        = amc$max_record_length =
          file_attributes [i].max_record_length := static_label_attributes.max_record_length;
          file_attributes [i].source := static_label_attributes.max_record_length_source;
        = amc$min_block_length =
          file_attributes [i].min_block_length := static_label_attributes.min_block_length;
          file_attributes [i].source := static_label_attributes.min_block_length_source;
        = amc$min_record_length =
          file_attributes [i].min_record_length := static_label_attributes.min_record_length;
          file_attributes [i].source := static_label_attributes.min_record_length_source;
        = amc$null_attribute =
          ;
        = amc$open_position =
          IF (job_environment_information_p = NIL) OR (job_environment_information_p^.
                attachment_options_sources.open_position_source = amc$access_method_default) THEN
            IF (object_information_p <> NIL) AND (STRLENGTH (object_information_p^.resolved_path^) >=
                  output_path_length) AND (object_information_p^.resolved_path^ (1, 14) = ':$LOCAL.OUTPUT')
                  THEN
              file_attributes [i].open_position := amc$open_at_eoi;
              file_attributes [i].source := amc$access_method_default;
            ELSEIF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
              file_attributes [i].open_position := evaluated_file_reference.path_handle_info.path_handle.
                    open_position.value;
              file_attributes [i].source := amc$file_reference;
            ELSE
              file_attributes [i].open_position := fmv$system_file_attributes.dynamic_label.open_position;
              file_attributes [i].source := amc$access_method_default;
            IFEND;
          ELSEIF evaluated_file_reference.path_handle_info.path_handle.open_position.specified AND
                (job_environment_information_p^.attachment_options_sources.open_position_source >
                amc$file_reference) THEN
            file_attributes [i].open_position := evaluated_file_reference.path_handle_info.path_handle.
                  open_position.value;
            file_attributes [i].source := amc$file_reference;
          ELSE
            file_attributes [i].open_position := job_environment_information_p^.open_position;
            file_attributes [i].source := job_environment_information_p^.attachment_options_sources.
                  open_position_source;
          IFEND;
        = amc$padding_character =
          file_attributes [i].padding_character := static_label_attributes.padding_character;
          file_attributes [i].source := static_label_attributes.padding_character_source;
        = amc$page_format =
          file_attributes [i].page_format := static_label_attributes.page_format;
          file_attributes [i].source := static_label_attributes.page_format_source;
        = amc$page_length =
          IF ((device_class = rmc$terminal_device) OR ((device_class = rmc$connected_file_device) AND
             (target_device_class = rmc$terminal_device))) AND (static_label_attributes.page_length_source =
                amc$access_method_default) THEN
            IF page_length_width [1].page_length = 0 THEN
              file_attributes [i].page_length := UPPERVALUE (amt$page_length);
            ELSE
              file_attributes [i].page_length := page_length_width [1].page_length;
            IFEND;
          ELSE
            file_attributes [i].page_length := static_label_attributes.page_length;
          IFEND;
          file_attributes [i].source := static_label_attributes.page_length_source;
        = amc$page_width =
          IF ((device_class = rmc$terminal_device) OR ((device_class = rmc$connected_file_device) AND
             (target_device_class = rmc$terminal_device))) AND (static_label_attributes.page_width_source =
                amc$access_method_default) THEN
            IF page_length_width [2].page_width = 0 THEN
              file_attributes [i].page_width := amc$max_page_width;
            ELSE
              file_attributes [i].page_width := page_length_width [2].page_width;
            IFEND;
          ELSE
            file_attributes [i].page_width := static_label_attributes.page_width;
          IFEND;
          file_attributes [i].source := static_label_attributes.page_width_source;
        = amc$permanent_file =
          file_attributes [i].permanent_file := fsp$path_element (^evaluated_file_reference, 1) ^ <>
                fsc$local;
          file_attributes [i].source := amc$local_file_information;
        = amc$preset_value =
          file_attributes [i].preset_value := static_label_attributes.preset_value;
          file_attributes [i].source := static_label_attributes.preset_value_source;
        = amc$private_read =
          IF (job_environment_information_p <> NIL) AND job_environment_information_p^.private_read.
                specified_on_attach THEN
            file_attributes [i].private_read := job_environment_information_p^.private_read.value;
            file_attributes [i].source := amc$file_command;
          ELSE
            file_attributes [i].private_read := FALSE;
            file_attributes [i].source := amc$undefined_attribute;
          IFEND;
        = amc$record_delimiting_character =
          file_attributes [i].record_delimiting_character :=
                static_label_attributes.record_delimiting_character;
          file_attributes [i].source := static_label_attributes.record_delimiting_char_source;
        = amc$record_type =
          file_attributes [i].record_type := static_label_attributes.record_type;
          file_attributes [i].source := static_label_attributes.record_type_source;
        = amc$return_option =
          file_attributes [i].return_option := fmv$system_file_attributes.dynamic_label.return_option;
          file_attributes [i].source := fmv$system_file_attributes.dynamic_label.return_option_source;
          IF file_request_attributes_p <> NIL THEN
            index := 0;
            REPEAT
              index := index + 1;
              IF file_request_attributes_p^ [index].key = amc$return_option THEN
                file_attributes [i].return_option := file_request_attributes_p^ [index].return_option;
                file_attributes [i].source := amc$file_request;
              IFEND;
            UNTIL (file_request_attributes_p^ [index].key = amc$return_option) OR
                  (index = UPPERBOUND (file_request_attributes_p^));
          IFEND;
        = amc$ring_attributes =
          file_attributes [i].ring_attributes := static_label_attributes.ring_attributes;
          file_attributes [i].source := static_label_attributes.ring_attributes_source;
        = amc$shared_queue =
          IF (cycle_object_p <> NIL) AND (cycle_object_p^.cycle_device_information <> NIL) AND
                (cycle_object_p^.cycle_device_class = rmc$mass_storage_device) THEN
            file_attributes [i].shared_queue :=
                  cycle_object_p^.cycle_device_information^.mass_storage_device_info.shared_queue;
            file_attributes [i].source := amc$local_file_information;
          ELSE
            file_attributes [i].shared_queue := osc$null_name;
            file_attributes [i].source := amc$undefined_attribute;
          IFEND;
        = amc$statement_identifier =
          file_attributes [i].statement_identifier := static_label_attributes.statement_identifier;
          file_attributes [i].source := static_label_attributes.statement_identifier_source;
        = amc$user_info =
          file_attributes [i].user_info := static_label_attributes.user_info;
          file_attributes [i].source := static_label_attributes.user_info_source;
        = amc$vertical_print_density =
          file_attributes [i].vertical_print_density := static_label_attributes.vertical_print_density;
          file_attributes [i].source := static_label_attributes.vertical_print_density_source;

{ aam

        = amc$average_record_length =
          file_attributes [i].average_record_length := static_label_attributes.average_record_length;
          file_attributes [i].source := static_label_attributes.average_record_length_source;
        = amc$collate_table_name =
          file_attributes [i].collate_table_name := static_label_attributes.collate_table_name;
          file_attributes [i].source := static_label_attributes.collate_table_name_source;
        = amc$compression_procedure_name =
          IF file_attributes [i].compression_procedure_name <> NIL THEN
            file_attributes [i].compression_procedure_name^ :=
                  static_label_attributes.compression_procedure_name;
            file_attributes [i].source := static_label_attributes.compression_proc_name_source;
          IFEND;
        = amc$data_padding =
          file_attributes [i].data_padding := static_label_attributes.data_padding;
          file_attributes [i].source := static_label_attributes.data_padding_source;
        = amc$dynamic_home_block_space =
          file_attributes [i].dynamic_home_block_space := static_label_attributes.dynamic_home_block_space;
          file_attributes [i].source := static_label_attributes.dynamic_home_block_space_source;
        = amc$embedded_key =
          file_attributes [i].embedded_key := static_label_attributes.embedded_key;
          file_attributes [i].source := static_label_attributes.embedded_key_source;
        = amc$error_limit =
          IF job_environment_information_p = NIL THEN
            file_attributes [i].error_limit := fmv$system_file_attributes.dynamic_label.error_limit;
            file_attributes [i].source := fmv$system_file_attributes.dynamic_label.error_limit_source;
          ELSE
            file_attributes [i].error_limit := job_environment_information_p^.error_limit;
            file_attributes [i].source := job_environment_information_p^.attachment_options_sources.
                  error_limit_source;
          IFEND;
        = amc$estimated_record_count =
          file_attributes [i].estimated_record_count := static_label_attributes.estimated_record_count;
          file_attributes [i].source := static_label_attributes.estimated_record_count_source;
        = amc$hashing_procedure_name =
          IF file_attributes [i].hashing_procedure_name <> NIL THEN
            file_attributes [i].hashing_procedure_name^ := static_label_attributes.hashing_procedure_name;
            file_attributes [i].source := static_label_attributes.hashing_procedure_name_source;
          IFEND;
        = amc$index_levels =
          file_attributes [i].index_levels := static_label_attributes.index_levels;
          file_attributes [i].source := static_label_attributes.index_levels_source;
        = amc$index_padding =
          file_attributes [i].index_padding := static_label_attributes.index_padding;
          file_attributes [i].source := static_label_attributes.index_padding_source;
        = amc$initial_home_block_count =
          file_attributes [i].initial_home_block_count := static_label_attributes.initial_home_block_count;
          file_attributes [i].source := static_label_attributes.initial_home_block_count_source;
        = amc$key_length =
          file_attributes [i].key_length := static_label_attributes.key_length;
          file_attributes [i].source := static_label_attributes.key_length_source;
        = amc$key_position =
          file_attributes [i].key_position := static_label_attributes.key_position;
          file_attributes [i].source := static_label_attributes.key_position_source;
        = amc$key_type =
          file_attributes [i].key_type := static_label_attributes.key_type;
          file_attributes [i].source := static_label_attributes.key_type_source;
        = amc$loading_factor =
          file_attributes [i].loading_factor := static_label_attributes.loading_factor;
          file_attributes [i].source := static_label_attributes.loading_factor_source;
        = amc$lock_expiration_time =
          file_attributes [i].lock_expiration_time := static_label_attributes.lock_expiration_time;
          file_attributes [i].source := static_label_attributes.lock_expiration_time_source;
        = amc$logging_options =
          file_attributes [i].logging_options := static_label_attributes.logging_options;
          file_attributes [i].source := static_label_attributes.logging_options_source;
        = amc$log_residence =
          IF file_attributes [i].log_residence <> NIL THEN
            file_attributes [i].log_residence^ := static_label_attributes.log_residence;
            file_attributes [i].source := static_label_attributes.log_residence_source;
          IFEND;
        = amc$message_control =
          IF job_environment_information_p = NIL THEN
            file_attributes [i].message_control := fmv$system_file_attributes.dynamic_label.message_control;
            file_attributes [i].source := fmv$system_file_attributes.dynamic_label.message_control_source;
          ELSE
            file_attributes [i].message_control := job_environment_information_p^.message_control;
            file_attributes [i].source := job_environment_information_p^.attachment_options_sources.
                  message_control_source;
          IFEND;
        = amc$record_limit =
          file_attributes [i].record_limit := static_label_attributes.record_limit;
          file_attributes [i].source := static_label_attributes.record_limit_source;
        = amc$records_per_block =
          file_attributes [i].records_per_block := static_label_attributes.records_per_block;
          file_attributes [i].source := static_label_attributes.records_per_block_source;

        ELSE
          IF current_status.normal THEN
            PUSH ignore_status;
            PUSH i_string;
            clp$convert_integer_to_string (i, 10, FALSE, i_string^, ignore_status^);
            fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_file_attrib_key,
                  amc$get_file_attributes_req, 'FILE_ATTRIBUTES', current_status);
            osp$append_status_parameter (osc$status_parameter_delimiter, i_string^.value (1, i_string^.size),
                  current_status);
          ELSE
            clp$convert_integer_to_string (i, 10, FALSE, i_string^, ignore_status^);
            osp$append_status_parameter (',', i_string^.value (1, i_string^.size), current_status);
          IFEND;
        CASEND;
      FOREND;

    PROCEND assign_attribute_values;

?? TITLE := 'get_connected_file_attributes', EJECT ??

    PROCEDURE get_connected_file_attributes
      (VAR status: ost$status);

      VAR
        path_handle_name: fst$path_handle_name,
        target_handle_name: fst$path_handle_name,
        target_object_information_p: ^fst$goi_object_information;

      clp$convert_str_to_path_handle (object_information_p^.resolved_path^, TRUE {delete_allowed} , FALSE
            {resolve_path} , FALSE {include_open_pos_in_handle} , path_handle_name, evaluated_file_reference,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$get_ultimate_connection (path_handle_name, target_handle_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF path_handle_name <> target_handle_name THEN { target file found }
        clp$get_fs_path_elements (target_handle_name, evaluated_file_reference, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        REPEAT
          get_object_information (status);
          IF NOT status.normal THEN
            IF status.condition = pfe$info_full THEN
              IF ($fst$goi_object_info_requests [fsc$goi_cycle_device_info, fsc$goi_job_environment_info] *
                    information_request.object_information_requests) = $fst$goi_object_info_requests [] THEN
                work_area_size := work_area_size + added_space_for_max_label_size;
              ELSEIF number_of_volumes <= max_volumes THEN
                number_of_volumes := number_of_volumes * 4;
                IF fsc$goi_job_environment_info IN information_request.object_information_requests THEN
                  work_area_size := work_area_size + (2 * number_of_volumes * #SIZE(rmt$volume_descriptor));
                ELSE
                  work_area_size := work_area_size + (number_of_volumes * #SIZE(rmt$volume_descriptor));
                IFEND;
              ELSE
                RETURN;
              IFEND;
              PUSH work_area_p: [[REP work_area_size OF cell]];
            ELSE
              RETURN;
            IFEND;
          IFEND;
        UNTIL status.normal;

        RESET work_area_p;
        NEXT target_object_information_p IN work_area_p;
        IF target_object_information_p = NIL THEN
          osp$set_status_abnormal (amc$access_method_id, fse$system_error, nil_object_info_text, status);
          RETURN;
        IFEND;

        IF target_object_information_p^.object^.object_type = fsc$goi_file_object THEN
          IF target_object_information_p^.object^.cycle_object_list = NIL THEN
            file_label_p := NIL;
          ELSE
            target_device_class := target_object_information_p^.object^.cycle_object_list^ [1].
                  cycle_device_class;
            contains_data := ((target_object_information_p^.object^.cycle_object_list^ [1].
                  cycle_size <> NIL) AND (target_object_information_p^.object^.cycle_object_list^ [1].
                  cycle_size^ > 0)) OR (device_class = rmc$magnetic_tape_device);
            file_label_p := target_object_information_p^.object^.cycle_object_list^ [1].file_label;
          IFEND;
        ELSEIF target_object_information_p^.object^.object_type = fsc$goi_cycle_object THEN
          target_device_class := target_object_information_p^.object^.cycle_device_class;
          contains_data := ((target_object_information_p^.object^.cycle_size <> NIL) AND
                (target_object_information_p^.object^.cycle_size^ > 0)) OR
                (device_class = rmc$magnetic_tape_device);
          file_label_p := target_object_information_p^.object^.file_label;
        IFEND;

      IFEND; {path_handle_name <> target_handle_name}

    PROCEND get_connected_file_attributes;

?? TITLE := 'get_object_information', EJECT ??

    PROCEDURE get_object_information
      (VAR status: ost$status);

      VAR
        context: ^ost$ecp_exception_context;

      context := NIL;

    /getoi_loop/
      REPEAT
        RESET work_area_p;

        IF fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local THEN
          bap$get_$local_object_info (evaluated_file_reference, information_request, work_area_p, status);
        ELSE
          pfp$r3_get_object_information (evaluated_file_reference, information_request, NIL, work_area_p,
                status);
        IFEND;
        IF NOT status.normal THEN
          IF osp$file_access_condition (status) THEN
            IF context = NIL THEN
              PUSH context;
              context^ := osv$initial_exception_context;
              context^.file.selector := osc$ecp_evaluated_file_ref;
              context^.file.evaluated_file_reference := evaluated_file_reference;
            IFEND;
            context^.condition_status := status;
            osp$enforce_exception_policies (context^);
            status := context^.condition_status;
          ELSEIF status.condition = pfe$tape_attached_on_client THEN
            CYCLE /getoi_loop/;
          ELSE
            RETURN;
          IFEND;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    PROCEND get_object_information;

?? TITLE := 'merge_amp$file_requests', EJECT ??

    PROCEDURE merge_amp$file_requests
      (VAR status: ost$status);

      job_environment_information_p^ := fsv$default_job_environ_info;
      merge_dynamic_requests (file_request_attributes_p, job_environment_information_p);
      bap$get_default_file_attribs (static_label_attributes, default_new_retention_specified,
            default_new_retention, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      bap$merge_static_attributes (evaluated_file_reference, file_request_attributes_p,
            static_label_attributes, status);
      IF status.normal THEN
        object_information_p := NIL;
        file_object_p := NIL;
        cycle_object_p := NIL;
        assign_attribute_values;
      IFEND;

    PROCEND merge_amp$file_requests;

?? TITLE := 'preprocess_attribute_requests', EJECT ??

    PROCEDURE preprocess_attribute_requests;

      VAR
        i: ost$positive_integers;

      FOR i := 1 TO UPPERBOUND (file_attributes) DO
        CASE file_attributes [i].key OF
        = amc$access_mode =
          information_request.object_information_requests :=
                information_request.object_information_requests +
                $fst$goi_object_info_requests [fsc$goi_applicable_file_permit, fsc$goi_job_environment_info];

        = amc$application_info =
          information_request.object_information_requests :=
                information_request.object_information_requests +
                $fst$goi_object_info_requests [fsc$goi_applicable_file_permit];

        = amc$error_exit_name, amc$error_limit, amc$label_exit_name, amc$message_control, amc$open_position,
              amc$global_file_address, amc$global_file_position, amc$private_read =
          information_request.object_information_requests :=
                information_request.object_information_requests +
                $fst$goi_object_info_requests [fsc$goi_job_environment_info];

        = amc$global_access_mode, amc$global_share_mode =
          information_request.object_information_requests :=
                information_request.object_information_requests +
                $fst$goi_object_info_requests [fsc$goi_applicable_file_permit, fsc$goi_job_environment_info,
                fsc$goi_cycle_info];

        = amc$global_file_name =
          information_request.object_information_requests :=
                information_request.object_information_requests +
                $fst$goi_object_info_requests [fsc$goi_cycle_identity];

        = amc$label_type, amc$max_block_length, amc$shared_queue =
          information_request.object_information_requests :=
                information_request.object_information_requests +
                $fst$goi_object_info_requests [fsc$goi_cycle_device_info];

        ELSE
        CASEND;
      FOREND;

      IF fsc$goi_applicable_file_permit IN information_request.object_information_requests THEN
        work_area_size := work_area_size + #SIZE (fst$goi_object) + #SIZE (pft$permit_array_entry);
      IFEND;
      IF fsc$goi_cycle_device_info IN information_request.object_information_requests THEN
        work_area_size := work_area_size + #SIZE (fst$device_information) +
              (number_of_volumes * #SIZE(rmt$volume_descriptor));
      IFEND;
      IF fsc$goi_cycle_info IN information_request.object_information_requests THEN
        work_area_size := work_area_size + #SIZE (fst$goi_cycle_information);
      IFEND;
      IF fsc$goi_job_environment_info IN information_request.object_information_requests THEN
        work_area_size := work_area_size + #SIZE (fst$job_environment_information) +
              (max_connections * fsc$max_path_size) + (number_of_volumes * #SIZE(rmt$volume_descriptor));
      IFEND;

    PROCEND preprocess_attribute_requests;

?? OLDTITLE, EJECT ??

    #KEYPOINT (osk$entry, 0, amk$get_file_attributes);
    #CALLER_ID (caller_id);
    status.normal := TRUE;

    file_exists := FALSE;
    file_previously_opened := FALSE;
    contains_data := FALSE;
    device_class := rmc$mass_storage_device;
    number_of_volumes := 4;

  /get_file_attributes/
    BEGIN

{ The following IF/ELSE/IFEND statement is only for amp$file:

      IF clp$trimmed_string_size (file) <= #SIZE (amt$local_file_name) THEN
        local_file_name := file;
        clp$validate_name (local_file_name, validated_name, name_is_valid);
        IF name_is_valid THEN
          bap$fetch_art_table_pointer (validated_name, file_request_attributes_p);
        ELSE
          file_request_attributes_p := NIL;
        IFEND;
      ELSE
        file_request_attributes_p := NIL;
      IFEND;

{ Pfp$get_object_information cannot be called because of compatibility reasons.  It calls
{ clp$evaluate_file_reference which assumes the current working catalog when given only a name.  However,
{ amp$get_file_attributes must continue to assume $LOCAL as the working catalog. The following call
{ accomplishes that.

      fsp$evaluate_file_reference (file, command_file_reference_allowed, evaluated_file_reference,
            current_status);
      IF NOT current_status.normal THEN
        EXIT /get_file_attributes/;
      IFEND;

      information_request := default_information_request;
      IF evaluated_file_reference.number_of_path_elements < 16 THEN
        work_area_size := #SIZE (fst$goi_object_information) +
              ((evaluated_file_reference.number_of_path_elements * (osc$max_name_size + 1))
              + 4{period and cycle number}) + #SIZE (fst$goi_object) + #SIZE (amt$file_byte_address) +
              estimated_label_size;
      ELSE
        work_area_size := #SIZE (fst$goi_object_information) + fsc$max_path_size + #SIZE (fst$goi_object) +
              #SIZE (amt$file_byte_address) + estimated_label_size;
      IFEND;
      preprocess_attribute_requests;

      PUSH work_area_p: [[REP work_area_size OF cell]];

      REPEAT
        get_object_information (current_status);
        IF NOT current_status.normal THEN
          IF current_status.condition = pfe$info_full THEN
            IF ($fst$goi_object_info_requests [fsc$goi_cycle_device_info, fsc$goi_job_environment_info] *
                  information_request.object_information_requests) = $fst$goi_object_info_requests [] THEN
              work_area_size := work_area_size + added_space_for_max_label_size;
            ELSEIF number_of_volumes <= max_volumes THEN
              number_of_volumes := number_of_volumes * 4;
              IF fsc$goi_job_environment_info IN information_request.object_information_requests THEN
                work_area_size := work_area_size + (2 * number_of_volumes * #SIZE(rmt$volume_descriptor));
              ELSE
                work_area_size := work_area_size + (number_of_volumes * #SIZE(rmt$volume_descriptor));
              IFEND;
            ELSE
              EXIT /get_file_attributes/;
            IFEND;
            PUSH work_area_p: [[REP work_area_size OF cell]];
          ELSE
            EXIT /get_file_attributes/;
          IFEND;
        IFEND;
      UNTIL current_status.normal;

      RESET work_area_p;
      NEXT object_information_p IN work_area_p;
      IF object_information_p = NIL THEN
        osp$set_status_abnormal (amc$access_method_id, fse$system_error, nil_object_info_text,
              current_status);
        EXIT /get_file_attributes/;
      IFEND;

      IF object_information_p^.object <> NIL THEN
        IF object_information_p^.object^.object_type = fsc$goi_cycle_object THEN
          file_object_p := NIL;
          cycle_object_p := object_information_p^.object;
        ELSEIF object_information_p^.object^.object_type = fsc$goi_file_object THEN
          file_object_p := object_information_p^.object;
          IF object_information_p^.object^.cycle_object_list = NIL THEN
            get_default_attributes (evaluated_file_reference, device_class, file_attributes, current_status);
            EXIT /get_file_attributes/;
          ELSE
            cycle_object_p := ^object_information_p^.object^.cycle_object_list^ [1];
          IFEND;
        ELSE {catalog_object}
          osp$set_status_condition (pfe$name_not_permanent_file, current_status);
          osp$append_status_file (osc$status_parameter_delimiter, object_information_p^.resolved_path^,
                current_status);
          EXIT /get_file_attributes/;
        IFEND;
      ELSE
        fsp$set_file_reference_abnormal (object_information_p^.resolved_path^, ame$file_not_known,
              amc$get_file_attributes_req, '', current_status);
        EXIT /get_file_attributes/;
      IFEND;

      file_exists := TRUE;
      device_class := cycle_object_p^.cycle_device_class;
      contains_data := ((cycle_object_p^.cycle_size <> NIL) AND
            (cycle_object_p^.cycle_size^ > 0)) OR (device_class = rmc$magnetic_tape_device);
      file_label_p := cycle_object_p^.file_label;

      target_device_class := device_class;
      IF device_class = rmc$connected_file_device THEN

{ More space is needed to get the attributes of the target file.  "Work_area_p"
{ can be reused because the necessary information to which it points has been
{ reassigned to other pointers.

        PUSH work_area_p: [[REP work_area_size OF cell]];
        get_connected_file_attributes (current_status);
        IF NOT current_status.normal THEN
          EXIT /get_file_attributes/;
        IFEND;
      IFEND;

      fsp$expand_file_label (file_label_p, static_label_attributes, file_previously_opened, current_status);
      IF NOT current_status.normal THEN
        EXIT /get_file_attributes/;
      IFEND;

      IF (NOT file_previously_opened) AND (device_class = rmc$magnetic_tape_device) AND
            (cycle_object_p^.cycle_device_information <> NIL) THEN
        fsp$adjust_tape_defaults (cycle_object_p^.cycle_device_information^.magnetic_tape_device_info.density,
              static_label_attributes);
      IFEND;

      job_environment_information_p := cycle_object_p^.job_environment_information;

      IF file_request_attributes_p <> NIL THEN

{ Merge amp$file requests.

        merge_dynamic_requests (file_request_attributes_p, job_environment_information_p);
        IF NOT file_previously_opened THEN
          bap$merge_static_attributes (evaluated_file_reference, file_request_attributes_p,
                static_label_attributes, current_status);
          IF NOT current_status.normal THEN
            EXIT /get_file_attributes/;
          IFEND;
        IFEND;
      IFEND;

      IF (target_device_class = rmc$terminal_device) AND ((static_label_attributes.page_length_source =
            amc$access_method_default) OR (static_label_attributes.page_width_source =
            amc$access_method_default)) THEN
        ifp$get_page_length_width (evaluated_file_reference.path_handle_info.path_handle, page_length_width,
              current_status);
        IF NOT current_status.normal THEN
          EXIT /get_file_attributes/;
        IFEND;
      IFEND;

      assign_attribute_values;
    END /get_file_attributes/;

    IF NOT current_status.normal THEN
      IF (current_status.condition = ame$file_not_known) OR
            (current_status.condition = pfe$unknown_permanent_file) OR
            (current_status.condition = pfe$unknown_cycle) OR (current_status.condition = pfe$unknown_item) OR
            (current_status.condition = pfe$unknown_nth_subcatalog) THEN
        IF file_request_attributes_p <> NIL THEN
          PUSH job_environment_information_p;
          merge_amp$file_requests (status);
        ELSE
          get_default_attributes (evaluated_file_reference, device_class, file_attributes, status);
        IFEND;
      ELSE
        status := current_status;
      IFEND;
    IFEND;

    #KEYPOINT (osk$exit, 0, amk$get_file_attributes);

  PROCEND amp$get_file_attributes;

?? TITLE := '[XDCL] amv$attribute_names', EJECT ??

  VAR
    amv$attribute_names: [XDCL, READ, oss$job_paged_literal] ^array [1 .. * ] of ost$name := ^attribute_names,

    attribute_names: [STATIC, READ, oss$job_paged_literal] array [1 .. 76] of ost$name := [

          {amc$access_level .............. = 001} 'ACCESS_LEVEL                   ',
          {amc$access_mode ............... = 002} 'ACCESS_MODE                    ',
          {amc$application_info .......... = 003} 'APPLICATION_INFORMATION        ',
          {amc$average_record_length ..... = 004} 'AVERAGE_RECORD_LENGTH          ',
          {amc$block_type ................ = 005} 'BLOCK_TYPE                     ',
          {amc$character_conversion ...... = 006} 'CHARACTER_CONVERSION           ',
          {amc$clear_space ............... = 007} 'CLEAR_SPACE                    ',
          {amc$collate_table ............. = 008} 'COLLATE_TABLE                  ',
          {amc$collate_table_name ........ = 009} 'COLLATE_TABLE_NAME             ',
          {............................... = 010} '                               ',
          {............................... = 011} '                               ',
          {amc$data_padding .............. = 012} 'DATA_PADDING                   ',
          {amc$embedded_key .............. = 013} 'EMBEDDED_KEY                   ',
          {amc$error_exit_name ........... = 014} 'ERROR_EXIT_NAME                ',
          {amc$error_exit_procedure ...... = 015} 'ERROR_EXIT_PROCEDURE           ',
          {amc$error_limit ............... = 016} 'ERROR_LIMIT                    ',
          {amc$error_options ............. = 017} 'ERROR_OPTIONS                  ',
          {amc$estimated_record_count .... = 018} 'ESTIMATED_RECORD_COUNT         ',
          {amc$file_access_procedure ..... = 019} 'FILE_ACCESS_PROCEDURE          ',
          {amc$file_contents ............. = 020} 'FILE_CONTENTS                  ',
          {amc$file_length ............... = 021} 'SIZE                           ',
          {amc$file_limit ................ = 022} 'FILE_LIMIT                     ',
          {............................... = 023} '                               ',
          {amc$file_organization ......... = 024} 'FILE_ORGANIZATION              ',
          {amc$file_processor ............ = 025} 'FILE_PROCESSOR                 ',
          {amc$file_structure ............ = 026} 'FILE_STRUCTURE                 ',
          {amc$forced_write .............. = 027} 'FORCED_WRITE                   ',
          {amc$global_access_mode ........ = 028} 'GLOBAL_ACCESS_MODE             ',
          {amc$global_file_address ....... = 029} 'GLOBAL_FILE_ADDRESS            ',
          {amc$global_file_position ...... = 030} 'GLOBAL_FILE_POSITION           ',
          {amc$global_file_name .......... = 031} 'GLOBAL_FILE_NAME               ',
          {amc$global_share_mode ......... = 032} 'GLOBAL_SHARE_MODE              ',
          {amc$index_levels .............. = 033} 'INDEX_LEVELS                   ',
          {amc$index_padding ............. = 034} 'INDEX_PADDING                  ',
          {amc$internal_code ............. = 035} 'INTERNAL_CODE                  ',
          {amc$key_length ................ = 036} 'KEY_LENGTH                     ',
          {amc$key_position .............. = 037} 'KEY_POSITION                   ',
          {amc$key_type .................. = 038} 'KEY_TYPE                       ',
          {amc$label_exit_name ........... = 039} 'LABEL_EXIT_NAME                ',
          {amc$label_exit_procedure ...... = 040} 'LABEL_EXIT_PROCEDURE           ',
          {amc$label_options ............. = 041} 'LABEL_OPTIONS                  ',
          {amc$label_type ................ = 042} 'LABEL_TYPE                     ',
          {............................... = 043} '                               ',
          {amc$line_number ............... = 044} 'LINE_NUMBER                    ',
          {amc$max_block_length .......... = 045} 'MAX_BLOCK_LENGTH               ',
          {amc$max_record_length ......... = 046} 'MAX_RECORD_LENGTH              ',
          {amc$message_control ........... = 047} 'MESSAGE_CONTROL                ',
          {amc$min_block_length .......... = 048} 'MIN_BLOCK_LENGTH               ',
          {amc$min_record_length ......... = 049} 'MIN_RECORD_LENGTH              ',
          {amc$null_attribute ............ = 050} 'NULL_ATTRIBUTE                 ',
          {amc$open_position ............. = 051} 'OPEN_POSITION                  ',
          {amc$padding_character ......... = 052} 'PADDING_CHARACTER              ',
          {amc$page_format ............... = 053} 'PAGE_FORMAT                    ',
          {amc$page_length ............... = 054} 'PAGE_LENGTH                    ',
          {amc$page_width ................ = 055} 'PAGE_WIDTH                     ',
          {amc$permanent_file ............ = 056} 'PERMANENT_FILE                 ',
          {amc$preset_value .............. = 057} 'PRESET_VALUE                   ',
          {............................... = 058} '                               ',
          {amc$record_limit .............. = 059} 'RECORD_LIMIT                   ',
          {amc$record_type ............... = 060} 'RECORD_TYPE                    ',
          {amc$records_per_block ......... = 061} 'RECORDS_PER_BLOCK              ',
          {amc$return_option ............. = 062} 'RETURN_OPTION                  ',
          {amc$ring_attributes ........... = 063} 'RING_ATTRIBUTES                ',
          {amc$statement_identifier ...... = 064} 'STATEMENT_IDENTIFIER           ',
          {............................... = 065} '                               ',
          {amc$user_info ................. = 066} 'USER_INFORMATION               ',
          {amc$vertical_print_density .... = 067} 'VERTICAL_PRINT_DENSITY         ',
          {amc$compression_procedure_name  = 068} 'COMPRESSION_PROCEDURE_NAME     ',
          {amc$dynamic_home_block_space .. = 069} 'DYNAMIC_HOME_BLOCK_SPACE       ',
          {amc$hashing_procedure_name .... = 070} 'HASHING_PROCEDURE_NAME         ',
          {amc$initial_home_block_count .. = 071} 'INITIAL_HOME_BLOCK_COUNT       ',
          {amc$loading_factor ............ = 072} 'LOADING_FACTOR                 ',
          {amc$lock_expiration_time ...... = 073} 'LOCK_EXPIRATION_TIME           ',
          {amc$logging_options ........... = 074} 'LOGGING_OPTIONS                ',
          {amc$log_residence ............. = 075} 'LOG_RESIDENCE                  ',
          {............................... = xxx} '                               '];

?? TITLE := '[XDCL] amp$validate_attributes', EJECT ??

  PROCEDURE [XDCL] amp$validate_attributes
    (    file: fst$file_reference;
         request_code: amt$last_operation;
         validation_ring: ost$valid_ring;
         attributes: ^amt$file_attributes;
     VAR status: ost$status);

?? NEWTITLE := 'validate_program_name', EJECT ??
    PROCEDURE validate_program_name
      (    program_name: string ( * <= osc$max_name_size);
       VAR name_is_valid: boolean);

      TYPE
        char_set = set of char;

      VAR
        ignore_scan_found_char: boolean,
        non_name_chars: char_set,
        scan_index: 1 .. osc$max_name_size + 1;

      CASE program_name (1) OF
      = '#', '$', '@', '0' .. '9', 'A' .. 'Z', 'a' .. 'z', '[', '\', ']', '^', '_', '`', '{',
            '|', '}', '~' =
        non_name_chars := -$char_set ['#', '$', '-', '0', '1', '2', '3', '4', '5',
              '6', '7', '8', '9', '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H',
              'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U',
              'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h',
              'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u',
              'v', 'w', 'x', 'y', 'z', '[', '\', ']', '^', '_', '`', '{', '|',
              '}', '~'];
        #SCAN (non_name_chars, program_name, scan_index,
              ignore_scan_found_char);
        name_is_valid := program_name (scan_index, * ) = '';
      ELSE
        name_is_valid := FALSE;
      CASEND;

    PROCEND validate_program_name;
?? OLDTITLE, EJECT ??

    VAR
      amv$logging_options: [STATIC, READ, oss$job_paged_literal] amt$logging_options :=
            [amc$enable_parcels, amc$enable_media_recovery, amc$enable_request_recovery],
      attribute_key_is_good: boolean,
      attribute_value_is_good: boolean,
      i: integer,
      i_string: ^ost$string,
      ignore_file: fst$parsed_file_reference,
      ignore_status: ^ost$status,
      name_is_valid: boolean,
      parameter_text: string (17);

    CONST
      old_open_req = 'AMP$OPEN';

    status.normal := TRUE;
    IF attributes = NIL THEN
      RETURN;
    IFEND;

    FOR i := 1 TO UPPERBOUND (attributes^) DO
      attribute_key_is_good := TRUE;
      attribute_value_is_good := TRUE;
      CASE attributes^ [i].key OF
      = amc$access_mode =
        IF NOT (attributes^ [i].access_mode <= amv$access_mode) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$block_type =
        IF (attributes^ [i].block_type < LOWERVALUE (amt$block_type)) OR
              (attributes^ [i].block_type > UPPERVALUE (amt$block_type)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$character_conversion =
        IF (attributes^ [i].character_conversion < LOWERVALUE (boolean)) OR
              (attributes^ [i].character_conversion > UPPERVALUE (boolean)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$clear_space =
        IF (attributes^ [i].clear_space < LOWERVALUE (ost$clear_file_space)) OR
              (attributes^ [i].clear_space > UPPERVALUE (ost$clear_file_space)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$error_exit_name =
        IF attributes^ [i].error_exit_name <> osc$null_name THEN
          clp$only_validate_name (attributes^ [i].error_exit_name, attribute_value_is_good);
        IFEND;
      = amc$error_options =
        IF (attributes^ [i].error_options.error_action < LOWERVALUE (amt$tape_error_action)) OR
              (attributes^ [i].error_options.error_action > UPPERVALUE (amt$tape_error_action)) OR
              (attributes^ [i].error_options.perform_failure_recovery < LOWERVALUE (boolean)) OR
              (attributes^ [i].error_options.perform_failure_recovery > UPPERVALUE (boolean)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$file_access_procedure =
        IF attributes^ [i].file_access_procedure <> osc$null_name THEN
          clp$only_validate_name (attributes^ [i].file_access_procedure, attribute_value_is_good);
        IFEND;
      = amc$file_contents =
        clp$only_validate_name (attributes^ [i].file_contents, attribute_value_is_good);
      = amc$file_limit =
        IF (attributes^ [i].file_limit < LOWERVALUE (amt$file_limit)) OR
              (attributes^ [i].file_limit > amc$file_byte_limit) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$file_organization =
        IF (attributes^ [i].file_organization < LOWERVALUE (amt$file_organization)) OR
              (attributes^ [i].file_organization > UPPERVALUE (amt$file_organization)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$file_processor =
        clp$only_validate_name (attributes^ [i].file_processor, attribute_value_is_good);
      = amc$file_structure =
        clp$only_validate_name (attributes^ [i].file_structure, attribute_value_is_good);
      = amc$forced_write =
        IF (attributes^ [i].forced_write < LOWERVALUE (amt$forced_write)) OR
              (attributes^ [i].forced_write > UPPERVALUE (amt$forced_write)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$internal_code =
        IF (attributes^ [i].internal_code < LOWERVALUE (amt$internal_code)) OR
              (attributes^ [i].internal_code > UPPERVALUE (amt$internal_code)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$label_exit_name =
        IF attributes^ [i].label_exit_name <> osc$null_name THEN
          clp$only_validate_name (attributes^ [i].label_exit_name, attribute_value_is_good);
        IFEND;
      = amc$label_options =
        IF NOT (attributes^ [i].label_options <= amv$label_options) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$label_type =
        IF (attributes^ [i].label_type < LOWERVALUE (amt$label_type)) OR
              (attributes^ [i].label_type > UPPERVALUE (amt$label_type)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$line_number =
        IF (attributes^ [i].line_number.length < LOWERVALUE (amt$line_number_length)) OR
              (attributes^ [i].line_number.length > UPPERVALUE (amt$line_number_length)) OR
              (attributes^ [i].line_number.location < LOWERVALUE (amt$line_number_location)) OR
              (attributes^ [i].line_number.location > UPPERVALUE (amt$line_number_location)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$max_block_length =
        IF (attributes^ [i].max_block_length < LOWERVALUE (amt$max_block_length)) OR
              (attributes^ [i].max_block_length > UPPERVALUE (amt$max_block_length)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$max_record_length =
        IF (attributes^ [i].max_record_length < LOWERVALUE (amt$max_record_length)) OR
              (attributes^ [i].max_record_length > UPPERVALUE (amt$max_record_length)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$min_block_length =
        IF (attributes^ [i].min_block_length < LOWERVALUE (amt$min_block_length)) OR
              (attributes^ [i].min_block_length > UPPERVALUE (amt$min_block_length)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$min_record_length =
        IF (attributes^ [i].min_record_length < LOWERVALUE (amt$min_record_length)) OR
              (attributes^ [i].min_record_length > UPPERVALUE (amt$min_record_length)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$null_attribute =
        ;
      = amc$open_position =
        IF (attributes^ [i].open_position < LOWERVALUE (amt$open_position)) OR
              (attributes^ [i].open_position > UPPERVALUE (amt$open_position)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$padding_character =
        ;
      = amc$page_format =
        IF (attributes^ [i].page_format < LOWERVALUE (amt$page_format)) OR
              (attributes^ [i].page_format > UPPERVALUE (amt$page_format)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$page_length =
        IF (attributes^ [i].page_length < LOWERVALUE (amt$page_length)) OR
              (attributes^ [i].page_length > UPPERVALUE (amt$page_length)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$page_width =
        IF (attributes^ [i].page_width < LOWERVALUE (amt$page_width)) OR
              (attributes^ [i].page_width > UPPERVALUE (amt$page_width)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$preset_value =
        ;
      = amc$record_type =
        IF (attributes^ [i].record_type < LOWERVALUE (amt$record_type)) OR
              (attributes^ [i].record_type > UPPERVALUE (amt$record_type)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$return_option =
        IF (attributes^ [i].return_option < LOWERVALUE (amt$return_option)) OR
              (attributes^ [i].return_option > UPPERVALUE (amt$return_option)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$ring_attributes =
        IF request_code = amc$set_file_attributes_cmd THEN
          attribute_key_is_good := FALSE;
        ELSEIF NOT ((1 <= attributes^ [i].ring_attributes.r1) AND
              (attributes^ [i].ring_attributes.r1 <= attributes^ [i].ring_attributes.r2) AND
              (attributes^ [i].ring_attributes.r2 <= attributes^ [i].ring_attributes.r3) AND
              (attributes^ [i].ring_attributes.r3 <= 13)) THEN
          attribute_value_is_good := FALSE;
        ELSE
          CASE request_code OF
          = amc$change_file_attributes_cmd, amc$open_req, amc$override_file_attributes =
            ;
          ELSE
            IF validation_ring > attributes^ [i].ring_attributes.r1 THEN
              fsp$set_file_reference_abnormal (file, ame$ring_validation_error, request_code, '', status);
              RETURN;
            IFEND;
          CASEND;
        IFEND;
      = amc$statement_identifier =
        IF ((attributes^ [i].statement_identifier.length < LOWERVALUE (amt$statement_id_length)) OR
              (attributes^ [i].statement_identifier.length > UPPERVALUE (amt$statement_id_length)) OR
              (attributes^ [i].statement_identifier.location < LOWERVALUE (amt$statement_id_location)) OR
              (attributes^ [i].statement_identifier.location > UPPERVALUE (amt$statement_id_location))) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$user_info =
        ;
      = amc$vertical_print_density =
        IF (attributes^ [i].vertical_print_density < LOWERVALUE (amt$vertical_print_density)) OR
              (attributes^ [i].vertical_print_density > UPPERVALUE (amt$vertical_print_density)) THEN
          attribute_value_is_good := FALSE;
        IFEND;

{ aam

      = amc$average_record_length =
        IF (attributes^ [i].average_record_length < LOWERVALUE (amt$average_record_length)) OR
              (attributes^ [i].average_record_length > UPPERVALUE (amt$average_record_length)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$collate_table_name =
        IF attributes^ [i].collate_table_name <> osc$null_name THEN
          clp$only_validate_name (attributes^ [i].collate_table_name, attribute_value_is_good);
        IFEND;
      = amc$compression_procedure_name =
        IF attributes^ [i].compression_procedure_name <> NIL THEN
          IF attributes^ [i].compression_procedure_name^.name <> osc$null_name THEN
            validate_program_name (attributes^ [i].compression_procedure_name^.name, name_is_valid);
            IF name_is_valid THEN
              attribute_value_is_good := TRUE;
              IF attributes^ [i].compression_procedure_name^.object_library <> osc$null_name THEN
                clp$convert_string_to_file_ref (attributes^ [i].compression_procedure_name^.object_library,
                      ignore_file, status);
                IF NOT status.normal THEN
                  attribute_value_is_good := FALSE;
                IFEND;
              IFEND;
            ELSE
              attribute_value_is_good := FALSE;
            IFEND;
          IFEND;
        IFEND;
      = amc$data_padding =
        IF (attributes^ [i].data_padding < LOWERVALUE (amt$data_padding)) OR
              (attributes^ [i].data_padding > UPPERVALUE (amt$data_padding)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$dynamic_home_block_space =
        IF (attributes^ [i].dynamic_home_block_space < LOWERVALUE (boolean)) OR
              (attributes^ [i].dynamic_home_block_space > UPPERVALUE (boolean)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$embedded_key =
        IF (attributes^ [i].embedded_key < LOWERVALUE (boolean)) OR
              (attributes^ [i].embedded_key > UPPERVALUE (boolean)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$error_limit =
        IF (attributes^ [i].error_limit < LOWERVALUE (amt$error_limit)) OR
              (attributes^ [i].error_limit > UPPERVALUE (amt$error_limit)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$estimated_record_count =
        ;
      = amc$hashing_procedure_name =
        IF attributes^ [i].hashing_procedure_name <> NIL THEN
          IF attributes^ [i].hashing_procedure_name^.name <> osc$null_name THEN
            validate_program_name (attributes^ [i].hashing_procedure_name^.name, name_is_valid);
            IF name_is_valid THEN
              attribute_value_is_good := TRUE;
              IF attributes^ [i].hashing_procedure_name^.object_library <> osc$null_name THEN
                clp$convert_string_to_file_ref (attributes^ [i].hashing_procedure_name^.object_library,
                      ignore_file, status);
                IF NOT status.normal THEN
                  attribute_value_is_good := FALSE;
                IFEND;
              IFEND;
            ELSE
              attribute_value_is_good := FALSE;
            IFEND;
          IFEND;
        IFEND;
      = amc$index_levels =
        IF (attributes^ [i].index_levels < LOWERVALUE (amt$index_levels)) OR
              (attributes^ [i].index_levels > UPPERVALUE (amt$index_levels)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$index_padding =
        IF (attributes^ [i].index_padding < LOWERVALUE (amt$index_padding)) OR
              (attributes^ [i].index_padding > UPPERVALUE (amt$index_padding)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$initial_home_block_count =
        IF (attributes^ [i].initial_home_block_count < LOWERVALUE (amt$initial_home_block_count)) OR
              (attributes^ [i].initial_home_block_count > UPPERVALUE (amt$initial_home_block_count)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$key_length =
        IF (attributes^ [i].key_length < LOWERVALUE (amt$key_length)) OR
              (attributes^ [i].key_length > UPPERVALUE (amt$key_length)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$key_position =
        IF (attributes^ [i].key_position < LOWERVALUE (amt$key_position)) OR
              (attributes^ [i].key_position > UPPERVALUE (amt$key_position)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$key_type =
        IF (attributes^ [i].key_type < LOWERVALUE (amt$key_type)) OR
              (attributes^ [i].key_type > UPPERVALUE (amt$key_type)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$loading_factor =
        IF (attributes^ [i].loading_factor < LOWERVALUE (amt$loading_factor)) OR
              (attributes^ [i].loading_factor > UPPERVALUE (amt$loading_factor)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$lock_expiration_time =
        IF (attributes^ [i].lock_expiration_time < LOWERVALUE (amt$lock_expiration_time)) OR
              (attributes^ [i].lock_expiration_time > UPPERVALUE (amt$lock_expiration_time)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$logging_options =
        IF NOT (attributes^ [i].logging_options <= amv$logging_options) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$log_residence =
        IF attributes^ [i].log_residence <> NIL THEN
          IF attributes^ [i].log_residence^ <> osc$null_name THEN
            clp$convert_string_to_file_ref (attributes^ [i].log_residence^, ignore_file, status);
            IF NOT status.normal THEN
              attribute_value_is_good := FALSE;
            IFEND;
          IFEND;
        IFEND;
      = amc$message_control =
        IF NOT (attributes^ [i].message_control <= amv$message_control) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$record_limit =
        IF (attributes^ [i].record_limit < LOWERVALUE (amt$record_limit)) OR
              (attributes^ [i].record_limit > UPPERVALUE (amt$record_limit)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = amc$records_per_block =
        IF (attributes^ [i].records_per_block < LOWERVALUE (amt$records_per_block)) OR
              (attributes^ [i].records_per_block > UPPERVALUE (amt$records_per_block)) THEN
          attribute_value_is_good := FALSE;
        IFEND;

      ELSE
        attribute_key_is_good := FALSE;
      CASEND;

      IF request_code = amc$open_req THEN
        parameter_text := 'ACCESS_SELECTIONS';
      ELSE
        parameter_text := 'FILE_ATTRIBUTES';
      IFEND;
      IF NOT attribute_key_is_good THEN
        IF status.normal OR (status.condition <> ame$improper_file_attrib_key) THEN
          PUSH ignore_status;
          PUSH i_string;
          clp$convert_integer_to_string (i, 10, FALSE, i_string^, ignore_status^);
          IF request_code <> amc$open_req THEN
            fsp$set_file_reference_abnormal (file, ame$improper_file_attrib_key, request_code, parameter_text,
                  status);
          ELSE
            bap$set_file_reference_abnormal (file, ame$improper_file_attrib_key, old_open_req, parameter_text,
                  status);
          IFEND;
          osp$append_status_parameter (osc$status_parameter_delimiter, i_string^.value (1, i_string^.size),
                status);
        ELSE
          clp$convert_integer_to_string (i, 10, FALSE, i_string^, ignore_status^);
          osp$append_status_parameter (',', i_string^.value (1, i_string^.size), status);
        IFEND;
      ELSEIF NOT attribute_value_is_good THEN
        IF status.normal THEN
          IF request_code <> amc$open_req THEN
            fsp$set_file_reference_abnormal (file, ame$improper_file_attrib_value, request_code,
                  parameter_text, status);
          ELSE
            bap$set_file_reference_abnormal (file, ame$improper_file_attrib_value, old_open_req,
                  parameter_text, status);
          IFEND;
          osp$append_status_parameter (osc$status_parameter_delimiter,
                amv$attribute_names^ [attributes^ [i].key], status);
        ELSEIF status.condition = ame$improper_file_attrib_value THEN
          osp$append_status_parameter (',', amv$attribute_names^ [attributes^ [i].key], status);
        IFEND;
      IFEND;
    FOREND;

  PROCEND amp$validate_attributes;

?? TITLE := 'get_default_attributes', EJECT ??

  PROCEDURE get_default_attributes
    (    evaluated_file_reference: fst$evaluated_file_reference;
         device_class: rmt$device_class;
     VAR file_attributes: amt$get_attributes;
     VAR status: ost$status);

    VAR
      default_file_attributes: bat$static_label_attributes,
      default_new_retention: fst$retention,
      default_new_retention_specified: boolean,
      i: integer,
      i_string: ^ost$string,
      ignore_status: ^ost$status;

    status.normal := TRUE;
    bap$get_default_file_attribs (default_file_attributes, default_new_retention_specified,
          default_new_retention, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO UPPERBOUND (file_attributes) DO
      CASE file_attributes [i].key OF
      = amc$access_mode =
        file_attributes [i].access_mode := fmv$system_file_attributes.dynamic_label.access_mode;
        file_attributes [i].source := fmv$system_file_attributes.dynamic_label.access_mode_source;
      = amc$application_info =
        file_attributes [i].application_info := fmv$system_file_attributes.descriptive_label.application_info;
        file_attributes [i].source := fmv$system_file_attributes.descriptive_label.application_info_source;
      = amc$block_type =
        file_attributes [i].block_type := default_file_attributes.block_type;
        file_attributes [i].source := default_file_attributes.block_type_source;
      = amc$character_conversion =
        file_attributes [i].character_conversion := default_file_attributes.character_conversion;
        file_attributes [i].source := default_file_attributes.character_conversion_source;
      = amc$clear_space =
        file_attributes [i].clear_space := default_file_attributes.clear_space;
        file_attributes [i].source := default_file_attributes.clear_space_source;
      = amc$device_class =
        file_attributes [i].device_class := device_class;
        file_attributes [i].source := amc$open_request;
      = amc$error_exit_name =
        file_attributes [i].error_exit_name := fmv$system_file_attributes.dynamic_label.error_exit_name;
        file_attributes [i].source := fmv$system_file_attributes.dynamic_label.error_exit_name_source;
      = amc$error_options =
        file_attributes [i].error_options := fmv$system_file_attributes.dynamic_label.error_options;
        file_attributes [i].source := fmv$system_file_attributes.dynamic_label.error_options_source;
      = amc$file_access_procedure =
        file_attributes [i].file_access_procedure := default_file_attributes.file_access_procedure;
        file_attributes [i].source := default_file_attributes.file_access_procedure_source;
      = amc$file_contents =
        file_attributes [i].file_contents := default_file_attributes.file_contents;
        file_attributes [i].source := default_file_attributes.file_contents_source;
      = amc$file_length =
        file_attributes [i].file_length := fmv$global_file_information.eoi_byte_address;
        file_attributes [i].source := amc$local_file_information;
      = amc$file_limit =
        file_attributes [i].file_limit := default_file_attributes.file_limit;
        file_attributes [i].source := default_file_attributes.file_limit_source;
      = amc$file_organization =
        file_attributes [i].file_organization := default_file_attributes.file_organization;
        file_attributes [i].source := default_file_attributes.file_organization_source;
      = amc$file_processor =
        file_attributes [i].file_processor := default_file_attributes.file_processor;
        file_attributes [i].source := default_file_attributes.file_processor_source;
      = amc$file_structure =
        file_attributes [i].file_structure := default_file_attributes.file_structure;
        file_attributes [i].source := default_file_attributes.file_structure_source;
      = amc$forced_write =
        file_attributes [i].forced_write := default_file_attributes.forced_write;
        file_attributes [i].source := default_file_attributes.forced_write_source;
      = amc$global_access_mode =
        file_attributes [i].global_access_mode := fmv$system_file_attributes.descriptive_label.
              global_access_mode;
        file_attributes [i].source := fmv$system_file_attributes.descriptive_label.global_access_mode_source;
      = amc$global_file_address =
        file_attributes [i].global_file_address := fmv$global_file_information.positioning_info.record_info.
              current_byte_address;
        file_attributes [i].source := amc$local_file_information;
      = amc$global_file_name =
        file_attributes [i].global_file_name := fmv$system_file_attributes.descriptive_label.global_file_name;
        file_attributes [i].source := fmv$system_file_attributes.descriptive_label.global_file_name_source;
      = amc$global_file_position =
        file_attributes [i].global_file_position := fmv$global_file_information.positioning_info.record_info.
              file_position;
        file_attributes [i].source := amc$local_file_information;
      = amc$global_share_mode =
        file_attributes [i].global_share_mode := fmv$system_file_attributes.descriptive_label.
              global_share_mode;
        file_attributes [i].source := fmv$system_file_attributes.descriptive_label.global_share_mode_source;
      = amc$internal_code =
        file_attributes [i].internal_code := default_file_attributes.internal_code;
        file_attributes [i].source := default_file_attributes.internal_code_source;
      = amc$label_exit_name =
        file_attributes [i].label_exit_name := fmv$system_file_attributes.dynamic_label.label_exit_name;
        file_attributes [i].source := fmv$system_file_attributes.dynamic_label.label_exit_name_source;
      = amc$label_options =
        file_attributes [i].label_options := fmv$system_file_attributes.dynamic_label.label_options;
        file_attributes [i].source := fmv$system_file_attributes.dynamic_label.label_options_source;
      = amc$label_type =
        file_attributes [i].label_type := default_file_attributes.label_type;
        file_attributes [i].source := default_file_attributes.label_type_source;
      = amc$line_number =
        file_attributes [i].line_number := default_file_attributes.line_number;
        file_attributes [i].source := default_file_attributes.line_number_source;
      = amc$max_block_length =
        file_attributes [i].max_block_length := default_file_attributes.max_block_length;
        file_attributes [i].source := default_file_attributes.max_block_length_source;
      = amc$max_record_length =
        file_attributes [i].max_record_length := default_file_attributes.max_record_length;
        file_attributes [i].source := default_file_attributes.max_record_length_source;
      = amc$min_block_length =
        file_attributes [i].min_block_length := default_file_attributes.min_block_length;
        file_attributes [i].source := default_file_attributes.min_block_length_source;
      = amc$min_record_length =
        file_attributes [i].min_record_length := default_file_attributes.min_record_length;
        file_attributes [i].source := default_file_attributes.min_record_length_source;
      = amc$null_attribute =
        ;
      = amc$open_position =
        file_attributes [i].open_position := fmv$system_file_attributes.dynamic_label.open_position;
        file_attributes [i].source := fmv$system_file_attributes.dynamic_label.open_position_source;
      = amc$padding_character =
        file_attributes [i].padding_character := default_file_attributes.padding_character;
        file_attributes [i].source := default_file_attributes.padding_character_source;
      = amc$page_format =
        file_attributes [i].page_format := default_file_attributes.page_format;
        file_attributes [i].source := default_file_attributes.page_format_source;
      = amc$page_length =
        file_attributes [i].page_length := default_file_attributes.page_length;
        file_attributes [i].source := default_file_attributes.page_length_source;
      = amc$page_width =
        file_attributes [i].page_width := default_file_attributes.page_width;
        file_attributes [i].source := default_file_attributes.page_width_source;
      = amc$permanent_file =
        file_attributes [i].permanent_file := fmv$system_file_attributes.descriptive_label.permanent_file;
        file_attributes [i].source := fmv$system_file_attributes.descriptive_label.permanent_file_source;
      = amc$preset_value =
        file_attributes [i].preset_value := default_file_attributes.preset_value;
        file_attributes [i].source := default_file_attributes.preset_value_source;
      = amc$private_read =
        file_attributes [i].private_read := FALSE;
        file_attributes [i].source := amc$undefined_attribute;
      = amc$record_delimiting_character =
        file_attributes [i].record_delimiting_character :=
              default_file_attributes.record_delimiting_character;
        file_attributes [i].source := default_file_attributes.record_delimiting_char_source;
      = amc$record_type =
        file_attributes [i].record_type := default_file_attributes.record_type;
        file_attributes [i].source := default_file_attributes.record_type_source;
      = amc$return_option =
        file_attributes [i].return_option := fmv$system_file_attributes.dynamic_label.return_option;
        file_attributes [i].source := fmv$system_file_attributes.dynamic_label.return_option_source;
      = amc$ring_attributes =
        file_attributes [i].ring_attributes := default_file_attributes.ring_attributes;
        file_attributes [i].source := default_file_attributes.ring_attributes_source;
      = amc$shared_queue =
        file_attributes [i].shared_queue  := osc$null_name;
        file_attributes [i].source := amc$access_method_default;
      = amc$statement_identifier =
        file_attributes [i].statement_identifier := default_file_attributes.statement_identifier;
        file_attributes [i].source := default_file_attributes.statement_identifier_source;
      = amc$user_info =
        file_attributes [i].user_info := default_file_attributes.user_info;
        file_attributes [i].source := default_file_attributes.user_info_source;
      = amc$vertical_print_density =
        file_attributes [i].vertical_print_density := default_file_attributes.
              vertical_print_density;
        file_attributes [i].source := default_file_attributes.vertical_print_density_source;

{ aam

      = amc$average_record_length =
        file_attributes [i].average_record_length := default_file_attributes.average_record_length;
        file_attributes [i].source := default_file_attributes.average_record_length_source;
      = amc$collate_table_name =
        file_attributes [i].collate_table_name := default_file_attributes.collate_table_name;
        file_attributes [i].source := default_file_attributes.collate_table_name_source;
      = amc$compression_procedure_name =
        IF file_attributes [i].compression_procedure_name <> NIL THEN
          file_attributes [i].compression_procedure_name^ :=
                default_file_attributes.compression_procedure_name;
          file_attributes [i].source := default_file_attributes.compression_proc_name_source;
        IFEND;
      = amc$data_padding =
        file_attributes [i].data_padding := default_file_attributes.data_padding;
        file_attributes [i].source := default_file_attributes.data_padding_source;
      = amc$dynamic_home_block_space =
        file_attributes [i].dynamic_home_block_space := default_file_attributes.dynamic_home_block_space;
        file_attributes [i].source := default_file_attributes.dynamic_home_block_space_source;
      = amc$embedded_key =
        file_attributes [i].embedded_key := default_file_attributes.embedded_key;
        file_attributes [i].source := default_file_attributes.embedded_key_source;
      = amc$error_limit =
        file_attributes [i].error_limit := fmv$system_file_attributes.dynamic_label.error_limit;
        file_attributes [i].source := fmv$system_file_attributes.dynamic_label.error_limit_source;
      = amc$estimated_record_count =
        file_attributes [i].estimated_record_count := default_file_attributes.estimated_record_count;
        file_attributes [i].source := default_file_attributes.estimated_record_count_source;
      = amc$hashing_procedure_name =
        IF file_attributes [i].hashing_procedure_name <> NIL THEN
          file_attributes [i].hashing_procedure_name^ := default_file_attributes.hashing_procedure_name;
          file_attributes [i].source := default_file_attributes.hashing_procedure_name_source;
        IFEND;
      = amc$index_levels =
        file_attributes [i].index_levels := default_file_attributes.index_levels;
        file_attributes [i].source := default_file_attributes.index_levels_source;
      = amc$index_padding =
        file_attributes [i].index_padding := default_file_attributes.index_padding;
        file_attributes [i].source := default_file_attributes.index_padding_source;
      = amc$initial_home_block_count =
        file_attributes [i].initial_home_block_count := default_file_attributes.
              initial_home_block_count;
        file_attributes [i].source := default_file_attributes.initial_home_block_count_source;
      = amc$key_length =
        file_attributes [i].key_length := default_file_attributes.key_length;
        file_attributes [i].source := default_file_attributes.key_length_source;
      = amc$key_position =
        file_attributes [i].key_position := default_file_attributes.key_position;
        file_attributes [i].source := default_file_attributes.key_position_source;
      = amc$key_type =
        file_attributes [i].key_type := default_file_attributes.key_type;
        file_attributes [i].source := default_file_attributes.key_type_source;
      = amc$loading_factor =
        file_attributes [i].loading_factor := default_file_attributes.loading_factor;
        file_attributes [i].source := default_file_attributes.loading_factor_source;
      = amc$lock_expiration_time =
        file_attributes [i].lock_expiration_time := default_file_attributes.lock_expiration_time;
        file_attributes [i].source := default_file_attributes.lock_expiration_time_source;
      = amc$logging_options =
        file_attributes [i].logging_options := default_file_attributes.logging_options;
        file_attributes [i].source := default_file_attributes.logging_options_source;
      = amc$log_residence =
        IF file_attributes [i].log_residence <> NIL THEN
          file_attributes [i].log_residence^ := default_file_attributes.log_residence;
          file_attributes [i].source := default_file_attributes.log_residence_source;
        IFEND;
      = amc$message_control =
        file_attributes [i].message_control := fmv$system_file_attributes.dynamic_label.message_control;
        file_attributes [i].source := fmv$system_file_attributes.dynamic_label.message_control_source;
      = amc$record_limit =
        file_attributes [i].record_limit := default_file_attributes.record_limit;
        file_attributes [i].source := default_file_attributes.record_limit_source;
      = amc$records_per_block =
        file_attributes [i].records_per_block := default_file_attributes.records_per_block;
        file_attributes [i].source := default_file_attributes.records_per_block_source;

      ELSE
        IF status.normal THEN
          PUSH ignore_status;
          PUSH i_string;
          clp$convert_integer_to_string (i, 10, FALSE, i_string^, ignore_status^);
          fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_file_attrib_key,
                amc$get_file_attributes_req, 'FILE_ATTRIBUTES', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, i_string^.value (1, i_string^.size),
                status);
        ELSE
          clp$convert_integer_to_string (i, 10, FALSE, i_string^, ignore_status^);
          osp$append_status_parameter (',', i_string^.value (1, i_string^.size), status);
        IFEND;
      CASEND;
    FOREND;

  PROCEND get_default_attributes;

?? TITLE := 'merge_dynamic_requests', EJECT ??

  PROCEDURE merge_dynamic_requests
    (    file_request_attributes: ^amt$file_attributes;
         job_environment_information: {input/output} ^fst$job_environment_information);

    VAR
      index: integer;

    IF job_environment_information <> NIL THEN
      FOR index := 1 TO UPPERBOUND (file_request_attributes^) DO
        CASE file_request_attributes^ [index].key OF
        = amc$access_mode =
          IF job_environment_information^.attachment_options_sources.access_modes_source <>
                amc$file_command THEN
            #UNCHECKED_CONVERSION (file_request_attributes^ [index].access_mode,
                  job_environment_information^.setfa_access_modes);
            job_environment_information^.attachment_options_sources.access_modes_source := amc$file_request;
          IFEND;
        = amc$error_exit_name =
          IF job_environment_information^.attachment_options_sources.error_exit_name_source <>
                amc$file_command THEN
            #TRANSLATE (osv$lower_to_upper, file_request_attributes^ [index].error_exit_name,
                  job_environment_information^.error_exit_procedure_name);
            job_environment_information^.attachment_options_sources.error_exit_name_source :=
                  amc$file_request;
          IFEND;
        = amc$error_limit =
          IF job_environment_information^.attachment_options_sources.error_limit_source <>
                amc$file_command THEN
            job_environment_information^.error_limit := file_request_attributes^ [index].error_limit;
            job_environment_information^.attachment_options_sources.error_limit_source := amc$file_request;
          IFEND;
        = amc$error_options =
          ;
        = amc$label_exit_name =
          IF job_environment_information^.attachment_options_sources.label_exit_name_source <>
                amc$file_command THEN
            #TRANSLATE (osv$lower_to_upper, file_request_attributes^ [index].label_exit_name,
                  job_environment_information^.label_exit_procedure_name);
            job_environment_information^.attachment_options_sources.label_exit_name_source :=
                  amc$file_request;
          IFEND;
        = amc$message_control =
          IF job_environment_information^.attachment_options_sources.message_control_source <>
                amc$file_command THEN
            job_environment_information^.message_control := file_request_attributes^ [index].message_control;
            job_environment_information^.attachment_options_sources.message_control_source :=
                  amc$file_request;
          IFEND;
        = amc$open_position =
          IF job_environment_information^.attachment_options_sources.open_position_source =
                amc$access_method_default THEN

{ Open position was not specified by SETFA or a file_reference.

            job_environment_information^.open_position := file_request_attributes^ [index].open_position;
            job_environment_information^.attachment_options_sources.open_position_source := amc$file_request;
          IFEND;
        ELSE
        CASEND;
      FOREND;
    IFEND;

  PROCEND merge_dynamic_requests;

?? OLDTITLE, EJECT ??
MODEND amm$file_structure_functions;
*DECK DECK=AMM$FIND_RECORD_SPACE EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$find_record_space;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$FIND_RECORD_SPACE' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$find_record_space (file_identifier:
    amt$file_identifier;
        space: amt$file_length;
        where: amt$put_locality;
        wait: ost$wait;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$FIND_RECORD_SPACE',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0,
          amk$find_record_space);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$find_record_space);
      RETURN;
    IFEND;

    call_block.operation := amc$find_record_space;

    call_block.find_record_space.space := space;
    call_block.find_record_space.where := where;
    call_block.find_record_space.wait := wait;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$find_record_space);
  PROCEND amp$find_record_space;
MODEND amm$find_record_space;
*DECK DECK=AMM$FLUSH EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$flush;

{ MODULE DECK AMMFLU }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$FLUSH' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc OSP$SET_STATUS_ABNORMAL
*copyc osv$initial_exception_context
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$FLUSH
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$flush ALIAS 'amxflsh' (file_identifier:
    amt$file_identifier;
        wait: ost$wait;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$FLUSH',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      call_block: amt$call_block,
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$flush);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$flush);
      RETURN;
    IFEND;

    call_block.operation := amc$flush_req;
    call_block.flush.wait := wait;

*copy BAI$FAP_CONTROL

    #keypoint (osk$exit, 0, amk$flush);
  PROCEND amp$flush;
MODEND amm$flush;

*DECK DECK=AMM$GET_DIRECT EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$get_direct;

{ MODULE DECK AMMGTD }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$GET_DIRECT' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc OSP$SET_STATUS_ABNORMAL
*copyc osv$initial_exception_context
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$GET_DIRECT
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$get_direct ALIAS 'amxgetd' (file_identifier:
    amt$file_identifier;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
    VAR transfer_count: amt$transfer_count;
        byte_address: amt$file_byte_address;
    VAR file_position: amt$file_position;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$GET_DIRECT',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      call_block: amt$call_block,
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry;

    #keypoint (osk$entry, 0, amk$get_direct);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$get_direct);
      RETURN;
    IFEND;

    call_block.operation := amc$get_direct_req;

    call_block.getd.working_storage_area := working_storage_area;
    call_block.getd.working_storage_length := working_storage_length;
    call_block.getd.transfer_count := ^transfer_count;
    call_block.getd.byte_address := byte_address;
    call_block.getd.file_position := ^file_position;

*copy BAI$FAP_CONTROL

    #keypoint (osk$exit, 0, amk$get_direct);
  PROCEND amp$get_direct;
MODEND amm$get_direct;
*DECK DECK=AMM$GET_KEY EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$get_key;

{ MODULE DECK AMMGKY }

?? TITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$GET_KEY' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
*copyc AMK$ACCESS_METHOD
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$get_key (file_identifier: amt$file_identifier;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
        key_location: ^cell;
        major_key_length: amt$major_key_length;
        key_relation: amt$key_relation;
    VAR record_length: amt$max_record_length;
    VAR file_position: amt$file_position;
        wait: ost$wait;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$GET_KEY',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$get_key);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$get_key);
      RETURN;
    IFEND;

    call_block.operation := amc$get_key_req;

    call_block.getk.working_storage_area := working_storage_area;
    call_block.getk.working_storage_length := working_storage_length;
    call_block.getk.key_location := key_location;
    call_block.getk.major_key_length := major_key_length;
    call_block.getk.key_relation := key_relation;
    call_block.getk.record_length := ^record_length;
    call_block.getk.file_position := ^file_position;
    call_block.getk.wait := wait;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$get_key);
  PROCEND amp$get_key;
MODEND amm$get_key;
*DECK DECK=AMM$GET_KEY_DEFINITIONS EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$get_key_definitions;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$GET_KEY_DEFINITIONS' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$get_key_definitions (file_identifier:
    amt$file_identifier;
    VAR key_definitions: SEQ ( * );
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$GET_KEY_DEFINITIONS',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0,
          amk$get_key_definitions);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$get_key_definitions);
      RETURN;
    IFEND;

    call_block.operation := amc$get_key_definitions;
    call_block.get_key_definitions.key_definitions := ^key_definitions;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$get_key_definitions);
  PROCEND amp$get_key_definitions;
MODEND amm$get_key_definitions;
*DECK DECK=AMM$GET_LABEL EXPAND=TRUE
*DECK DECK=AMM$GET_LOCK_KEYED_RECORD EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$get_lock_keyed_record;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$GET_LOCK_KEYED_RECORD' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$get_lock_keyed_record (file_identifier:
    amt$file_identifier;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
        key_location: ^cell;
        major_key_length: amt$major_key_length;
        relation: amt$key_relation;
        wait_for_lock: ost$wait_for_lock;
        unlock_control: amt$unlock_control;
        lock_intent: amt$lock_intent;
    VAR record_length: amt$max_record_length;
    VAR file_position: amt$file_position;
        wait: ost$wait;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$GET_LOCK_KEYED_RECORD',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, file_identifier.ordinal * osk$m,
          amk$get_lock_keyed_record);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0,
            amk$get_lock_keyed_record);
      RETURN;
    IFEND;

    call_block.operation := amc$get_lock_keyed_record;

    call_block.get_lock_keyed_record.working_storage_area :=
          working_storage_area;
    call_block.get_lock_keyed_record.working_storage_length :=
          working_storage_length;
    call_block.get_lock_keyed_record.key_location := key_location;
    call_block.get_lock_keyed_record.major_key_length := major_key_length;
    call_block.get_lock_keyed_record.relation := relation;
    call_block.get_lock_keyed_record.wait_for_lock := wait_for_lock;
    call_block.get_lock_keyed_record.unlock_control := unlock_control;
    call_block.get_lock_keyed_record.lock_intent := lock_intent;
    call_block.get_lock_keyed_record.record_length := ^record_length;
    call_block.get_lock_keyed_record.file_position := ^file_position;
    call_block.get_lock_keyed_record.wait := wait;

*copy bai$call_fap_control

    IF bam_status.normal THEN
      #keypoint (osk$exit, 0, amk$get_lock_keyed_record);
    ELSE
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF bam_status.normal THEN
        #keypoint (osk$exit, 0, amk$get_lock_keyed_record);
      ELSE
        status := bam_status;
        #keypoint (osk$exit, 0,
              amk$get_lock_keyed_record);
      IFEND;
    IFEND;
  PROCEND amp$get_lock_keyed_record;
MODEND amm$get_lock_keyed_record;
*DECK DECK=AMM$GET_LOCK_NEXT_KEYED_RECORD EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$get_lock_next_keyed_record;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$GET_LOCK_NEXT_KEYED_RECORD' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$get_lock_next_keyed_record (file_identifier:
    amt$file_identifier;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
        key_location: ^cell;
        wait_for_lock: ost$wait_for_lock;
        unlock_control: amt$unlock_control;
        lock_intent: amt$lock_intent;
    VAR record_length: amt$max_record_length;
    VAR file_position: amt$file_position;
        wait: ost$wait;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$GET_LOCK_NEXT_KEYED_RECORD',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, file_identifier.ordinal * osk$m,
          amk$get_lock_next_keyed_record);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0,
            amk$get_lock_next_keyed_record);
      RETURN;
    IFEND;

    call_block.operation := amc$get_lock_next_keyed_record;

    call_block.get_lock_next_keyed_record.working_storage_area :=
          working_storage_area;
    call_block.get_lock_next_keyed_record.working_storage_length :=
          working_storage_length;
    call_block.get_lock_next_keyed_record.key_location := key_location;
    call_block.get_lock_next_keyed_record.wait_for_lock := wait_for_lock;
    call_block.get_lock_next_keyed_record.unlock_control := unlock_control;
    call_block.get_lock_next_keyed_record.lock_intent := lock_intent;
    call_block.get_lock_next_keyed_record.record_length := ^record_length;
    call_block.get_lock_next_keyed_record.file_position := ^file_position;
    call_block.get_lock_next_keyed_record.wait := wait;

*copy bai$call_fap_control

    IF bam_status.normal THEN
      #keypoint (osk$exit, 0, amk$get_lock_next_keyed_record);
    ELSE
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF bam_status.normal THEN
        #keypoint (osk$exit, 0, amk$get_lock_next_keyed_record);
      ELSE
        status := bam_status;
        #keypoint (osk$exit, 0,
              amk$get_lock_next_keyed_record);
      IFEND;
    IFEND;
  PROCEND amp$get_lock_next_keyed_record;
MODEND amm$get_lock_next_keyed_record;
*DECK DECK=AMM$GET_NESTED_FILE_DEFINITIONS EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$get_nested_file_definitions;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$GET_NESTED_FILE_DEFINITIONS' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$get_nested_file_definitions (file_identifier:
    amt$file_identifier;
    VAR definitions: amt$nested_file_definitions;
    VAR nested_file_count: amt$nested_file_count;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$GET_NESTED_FILE_DEFINITIONS',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, file_identifier.ordinal * osk$m,
          amk$get_nested_file_definitions);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0,
            amk$get_nested_file_definitions);
      RETURN;
    IFEND;

    call_block.operation := amc$get_nested_file_definitions;

    call_block.get_nested_file_definitions.definitions := ^definitions;
    call_block.get_nested_file_definitions.nested_file_count :=
          ^nested_file_count;

*copy bai$call_fap_control

    IF bam_status.normal THEN
      #keypoint (osk$exit, 0, amk$get_nested_file_definitions);
    ELSE
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF bam_status.normal THEN
        #keypoint (osk$exit, 0, amk$get_nested_file_definitions);
      ELSE
        status := bam_status;
        #keypoint (osk$exit, 0,
              amk$get_nested_file_definitions);
      IFEND;
    IFEND;
  PROCEND amp$get_nested_file_definitions;
MODEND amm$get_nested_file_definitions;
*DECK DECK=AMM$GET_NEXT EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$get_next;

{ MODULE DECK AMMGET }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$GET_NEXT' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc OSP$SET_STATUS_ABNORMAL
*copyc osv$initial_exception_context
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$GET_NEXT
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$get_next ALIAS 'amxgetn' (file_identifier:
    amt$file_identifier;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
    VAR transfer_count: amt$transfer_count;
    VAR byte_address: amt$file_byte_address;
    VAR file_position: amt$file_position;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$GET_NEXT',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      call_block: amt$call_block,
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry;

    #keypoint (osk$entry, 0, amk$get_next);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$get_next);
      RETURN;
    IFEND;

    call_block.operation := amc$get_next_req;

    call_block.getn.working_storage_area := working_storage_area;
    call_block.getn.working_storage_length := working_storage_length;
    call_block.getn.transfer_count := ^transfer_count;
    call_block.getn.byte_address := ^byte_address;
    call_block.getn.file_position := ^file_position;

*copy BAI$FAP_CONTROL

    #keypoint (osk$exit, 0, amk$get_next);
  PROCEND amp$get_next;
MODEND amm$get_next;


*DECK DECK=AMM$GET_NEXT_KEY EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$get_next_key;

{ MODULE DECK AMMGNK }

?? TITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$GET_NEXT_KEY' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
*copyc AMK$ACCESS_METHOD
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$get_next_key (file_identifier:
    amt$file_identifier;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
        key_location: ^cell;
    VAR record_length: amt$max_record_length;
    VAR file_position: amt$file_position;
        wait: ost$wait;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$GET_NEXT_KEY',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$get_next_key);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$get_next_key);
      RETURN;
    IFEND;

    call_block.operation := amc$get_next_key_req;

    call_block.getnk.working_storage_area := working_storage_area;
    call_block.getnk.working_storage_length := working_storage_length;
    call_block.getnk.key_location := key_location;
    call_block.getnk.record_length := ^record_length;
    call_block.getnk.file_position := ^file_position;
    call_block.getnk.wait := wait;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$get_next_key);
  PROCEND amp$get_next_key;
MODEND amm$get_next_key;
*DECK DECK=AMM$GET_NEXT_PRIMARY_KEY_LIST EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$get_next_primary_key_list;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$GET_NEXT_PRIMARY_KEY_LIST' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$get_next_primary_key_list (file_identifier:
    amt$file_identifier;
        high_key: ^cell;
        major_high_key: amt$major_key_length;
        high_key_relation: amt$key_relation;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
    VAR end_of_primary_key_list: boolean;
    VAR transferred_byte_count: amt$working_storage_length;
    VAR transferred_key_count: amt$key_count_limit;
    VAR file_position: amt$file_position;
        wait: ost$wait;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$GET_NEXT_PRIMARY_KEY_LIST',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0,
          amk$get_next_primary_key_list);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$get_next_primary_key_list);
      RETURN;
    IFEND;

    call_block.operation := amc$get_next_primary_key_list;

    call_block.get_next_primary_key_list.high_key := high_key;
    call_block.get_next_primary_key_list.major_high_key := major_high_key;
    call_block.get_next_primary_key_list.high_key_relation :=
          high_key_relation;
    call_block.get_next_primary_key_list.working_storage_area :=
          working_storage_area;
    call_block.get_next_primary_key_list.working_storage_length :=
          working_storage_length;
    call_block.get_next_primary_key_list.end_of_primary_key_list :=
          ^end_of_primary_key_list;
    call_block.get_next_primary_key_list.transferred_byte_count :=
          ^transferred_byte_count;
    call_block.get_next_primary_key_list.transferred_key_count :=
          ^transferred_key_count;
    call_block.get_next_primary_key_list.file_position := ^file_position;
    call_block.get_next_primary_key_list.wait := wait;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$get_next_primary_key_list);
  PROCEND amp$get_next_primary_key_list;
MODEND amm$get_next_primary_key_list;
*DECK DECK=AMM$GET_PARTIAL EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$get_partial;

{ MODULE DECK AMMGPR }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$GET_PARTIAL' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc OSP$SET_STATUS_ABNORMAL
*copyc osv$initial_exception_context
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$GET_PARTIAL
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$get_partial ALIAS 'amxgetp' (file_identifier:
    amt$file_identifier;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
    VAR record_length: amt$max_record_length;
    VAR transfer_count: amt$transfer_count;
    VAR byte_address: amt$file_byte_address;
    VAR file_position: amt$file_position;
        skip_option: amt$skip_option;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$GET_PARTIAL',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      call_block: amt$call_block,
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry;

    #keypoint (osk$entry, 0, amk$get_partial);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$get_partial);
      RETURN;
    IFEND;

    call_block.operation := amc$get_partial_req;

    call_block.getp.working_storage_area := working_storage_area;
    call_block.getp.working_storage_length := working_storage_length;
    call_block.getp.record_length := ^record_length;
    call_block.getp.transfer_count := ^transfer_count;
    call_block.getp.byte_address := ^byte_address;
    call_block.getp.file_position := ^file_position;
    call_block.getp.skip_option := skip_option;

*copy BAI$FAP_CONTROL

    #keypoint (osk$exit, 0, amk$get_partial);
  PROCEND amp$get_partial;
MODEND amm$get_partial;
*DECK DECK=AMM$GET_PRIMARY_KEY_COUNT EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$get_primary_key_count;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$GET_PRIMARY_KEY_COUNT' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$get_primary_key_count (file_identifier:
    amt$file_identifier;
        low_key: ^cell;
        major_low_key: amt$major_key_length;
        low_key_relation: amt$key_relation;
        high_key: ^cell;
        major_high_key: amt$major_key_length;
        high_key_relation: amt$key_relation;
        list_count_limit: amt$key_count_limit;
    VAR list_count: amt$key_count_limit;
        wait: ost$wait;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$GET_PRIMARY_KEY_COUNT',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0,
          amk$get_primary_key_count);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0,amk$get_primary_key_count);
      RETURN;
    IFEND;

    call_block.operation := amc$get_primary_key_count;

    call_block.get_primary_key_count.low_key := low_key;
    call_block.get_primary_key_count.major_low_key := major_low_key;
    call_block.get_primary_key_count.low_key_relation := low_key_relation;
    call_block.get_primary_key_count.high_key := high_key;
    call_block.get_primary_key_count.major_high_key := major_high_key;
    call_block.get_primary_key_count.high_key_relation := high_key_relation;
    call_block.get_primary_key_count.list_count_limit := list_count_limit;
    call_block.get_primary_key_count.list_count := ^list_count;
    call_block.get_primary_key_count.wait := wait;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$get_primary_key_count);
  PROCEND amp$get_primary_key_count;
MODEND amm$get_primary_key_count;
*DECK DECK=AMM$GET_SEGMENT_POINTER EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$get_segment_pointer;

{ MODULE DECK AMMGSP }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$GET_SEGMENT_POINTER' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$GET_SEGMENT_POINTER
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$get_segment_pointer ALIAS 'amxgsgp'
    (file_identifier: amt$file_identifier;
        pointer_kind: amt$pointer_kind;
    VAR segment_pointer: amt$segment_pointer;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$GET_SEGMENT_POINTER',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$get_segment_pointer);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$get_segment_pointer);
      RETURN;
    IFEND;

    call_block.operation := amc$get_segment_pointer_req;

    call_block.getsegp.pointer_kind := pointer_kind;
    call_block.getsegp.segment_pointer := ^segment_pointer;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$get_segment_pointer);
  PROCEND amp$get_segment_pointer;
MODEND amm$get_segment_pointer;
*DECK DECK=AMM$GET_SPACE_USED_FOR_KEY EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$get_space_used_for_key;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$GET_SPACE_USED_FOR_KEY' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$get_space_used_for_key (file_identifier:
    amt$file_identifier;
        low_key: ^cell;
        major_low_key: amt$major_key_length;
        low_key_relation: amt$key_relation;
        high_key: ^cell;
        major_high_key: amt$major_key_length;
        high_key_relation: amt$key_relation;
    VAR data_block_count: amt$data_block_count;
    VAR data_block_space: amt$file_length;
        wait: ost$wait;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$GET_SPACE_USED_FOR_KEY',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0,
          amk$get_space_used_for_key);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$get_space_used_for_key);
      RETURN;
    IFEND;

    call_block.operation := amc$get_space_used_for_key;

    call_block.get_space_used_for_key.low_key := low_key;
    call_block.get_space_used_for_key.major_low_key := major_low_key;
    call_block.get_space_used_for_key.low_key_relation := low_key_relation;
    call_block.get_space_used_for_key.high_key := high_key;
    call_block.get_space_used_for_key.major_high_key := major_high_key;
    call_block.get_space_used_for_key.high_key_relation := high_key_relation;
    call_block.get_space_used_for_key.data_block_count := ^data_block_count;
    call_block.get_space_used_for_key.data_block_space := ^data_block_space;
    call_block.get_space_used_for_key.wait := wait;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$get_space_used_for_key);
  PROCEND amp$get_space_used_for_key;
MODEND amm$get_space_used_for_key;
*DECK DECK=AMM$LOCK_FILE EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$lock_file;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$LOCK_FILE' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$lock_file (file_identifier: amt$file_identifier;
        wait_for_lock: ost$wait_for_lock;
        lock_intent: amt$lock_intent;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$LOCK_FILE',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$lock_file);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$lock_file);
      RETURN;
    IFEND;

    call_block.operation := amc$lock_file;

    call_block.lock_file.wait_for_lock := wait_for_lock;
    call_block.lock_file.lock_intent := lock_intent;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$lock_file);
  PROCEND amp$lock_file;
MODEND amm$lock_file;
*DECK DECK=AMM$LOCK_KEY EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$lock_key;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$LOCK_KEY' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$lock_key (file_identifier: amt$file_identifier;
        key_location: ^cell;
        wait_for_lock: ost$wait_for_lock;
        unlock_control: amt$unlock_control;
        lock_intent: amt$lock_intent;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$LOCK_KEY',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$lock_key);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$lock_key);
      RETURN;
    IFEND;

    call_block.operation := amc$lock_key;

    call_block.lock_key.key_location := key_location;
    call_block.lock_key.wait_for_lock := wait_for_lock;
    call_block.lock_key.unlock_control := unlock_control;
    call_block.lock_key.lock_intent := lock_intent;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$lock_key);
  PROCEND amp$lock_key;
MODEND amm$lock_key;
*DECK DECK=AMM$OPEN EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Basic Access Methods : Open' ??
MODULE amm$open;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amd$open_declarations
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc amk$access_method
*copyc cle$ecc_lexical
*copyc fse$get_info_validation_errors
*copyc osd$integer_limits
*copyc ost$caller_identifier
?? POP ??

*copyc amp$validate_attributes
*copyc bap$fetch_art_table_pointer
*copyc bap$get_setfa_dynamic_attrs
*copyc bap$set_local_name_abnormal
*copyc bap$set_return_at_close
*copyc clp$check_name_for_path_handle
*copyc clp$validate_name
*copyc fsp$convert_to_new_contents
*copyc fsp$dtm_structure_from_contents
*copyc fsp$open_file
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal

*copyc bav$task_file_table

?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    access_selections_set = set of amt$file_attribute_keys;

?? TITLE := 'PROCEDURE [XDCL, #GATE] amp$open', EJECT ??
*copyc amh$also
*copyc amh$open
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$open
    (    local_file_name: amt$local_file_name;
         access_level: amt$access_level;
         access_selections: amt$file_access_selections;
     VAR file_identifier: amt$file_identifier;
     VAR status: ost$status);

    CONST
      access_mode_selection = 1,
      local_reference = ':$LOCAL.',
      local_reference_size = 8,
      number_of_supported_attachments = 7; {number of attachment options supported by AMP$OPEN.

    VAR
      attached_permanent_file: boolean,
      attached_share_modes: fst$file_access_options,
      attachment_count: ost$non_negative_integers,
      attachment_options: ^fst$attachment_options,
      attribute_count: ost$non_negative_integers,
      caller_id: ost$caller_identifier,
      cl_path_handle: clt$path_handle,
      default_creation_attributes: ^fst$file_cycle_attributes,
      file_reference: string (local_reference_size + osc$max_name_size),
      file_request_attributes: ^amt$file_attributes,
      iteration: (access_selection, file_request_attribute),
      lfn: amt$local_file_name,
      local_access_selections: amt$file_access_selections,
      mandated_creation_attributes: ^fst$file_cycle_attributes,
      specified_return_option: amt$return_option,
      specified_access_selections: access_selections_set,
      temporary_sequence_pointer: ^SEQ ( * ),
      valid_name: boolean;

?? NEWTITLE := 'PROCEDURE [INLINE] process_selections', EJECT ??

    PROCEDURE [INLINE] process_selections
      (    old_attributes: ^amt$file_attributes;
       VAR attachment_count: {i/o} ost$non_negative_integers;
           attachment_options: {i/o} ^fst$attachment_options;
       VAR specified_access_selections: {i/o} access_selections_set;
       VAR attribute_count: ost$non_negative_integers;
           creation_attributes: {output} ^fst$file_cycle_attributes;
       VAR status: ost$status);

      VAR
        i: ost$non_negative_integers,
        file_contents_truncated: boolean,
        file_processor_index: ost$non_negative_integers,
        specified_file_contents: amt$file_contents,
        specified_file_structure: amt$file_contents;

      status.normal := TRUE;
      attribute_count := 0;

      FOR i := UPPERBOUND (old_attributes^) DOWNTO 1 DO
        IF (old_attributes^ [i].key IN $access_selections_set [amc$collate_table_name, amc$error_exit_name,
              amc$file_access_procedure, amc$label_exit_name]) AND
              (NOT (old_attributes^ [i].key IN specified_access_selections)) THEN
          specified_access_selections := specified_access_selections + $access_selections_set
                [old_attributes^ [i].key];
          CASE old_attributes^ [i].key OF
          = amc$collate_table_name =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$collate_table_name;
            PUSH creation_attributes^ [attribute_count].collate_table_name;
            creation_attributes^ [attribute_count].collate_table_name^.entry_point :=
                  old_attributes^ [i].collate_table_name;
            creation_attributes^ [attribute_count].collate_table_name^.object_library := osc$null_name;
          = amc$error_exit_name =
            attachment_count := attachment_count + 1;
            attachment_options^ [attachment_count].selector := fsc$error_exit_procedure_name;
            PUSH attachment_options^ [attachment_count].error_exit_procedure_name;
            attachment_options^ [attachment_count].error_exit_procedure_name^.entry_point :=
                  old_attributes^ [i].error_exit_name;
            attachment_options^ [attachment_count].error_exit_procedure_name^.object_library := osc$null_name;
          = amc$file_access_procedure =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$file_access_procedure_name;
            PUSH creation_attributes^ [attribute_count].file_access_procedure_name;
            creation_attributes^ [attribute_count].file_access_procedure_name^.entry_point :=
                  old_attributes^ [i].file_access_procedure;
            creation_attributes^ [attribute_count].file_access_procedure_name^.object_library :=
                  osc$null_name;
          = amc$label_exit_name =
            attachment_count := attachment_count + 1;
            attachment_options^ [attachment_count].selector := fsc$label_exit_procedure_name;
            PUSH attachment_options^ [attachment_count].label_exit_procedure_name;
            attachment_options^ [attachment_count].label_exit_procedure_name^.entry_point :=
                  old_attributes^ [i].label_exit_name;
            attachment_options^ [attachment_count].label_exit_procedure_name^.object_library := osc$null_name;
          ELSE
          CASEND;
        IFEND;
      FOREND;

      process_unpushed_selections (old_attributes, attachment_count, attachment_options,
            specified_access_selections, attribute_count, creation_attributes, status);


    PROCEND process_selections;

?? TITLE := 'PROCEDURE process_unpushed_selections', EJECT ??

    PROCEDURE process_unpushed_selections
      (    old_attributes: ^amt$file_attributes;
       VAR attachment_count: {i/o} ost$non_negative_integers;
           attachment_options: {i/o} ^fst$attachment_options;
       VAR specified_access_selections: {i/o} access_selections_set;
       VAR attribute_count: {i/o} ost$non_negative_integers;
           creation_attributes: {i/o} ^fst$file_cycle_attributes;
       VAR status: ost$status);

      VAR
        i: ost$non_negative_integers,
        file_contents_truncated: boolean,
        file_processor_index: ost$non_negative_integers,
        specified_file_contents: amt$file_contents,
        specified_file_structure: amt$file_contents;

      status.normal := TRUE;

      FOR i := UPPERBOUND (old_attributes^) DOWNTO 1 DO
        IF NOT (old_attributes^ [i].key IN specified_access_selections) THEN
          specified_access_selections := specified_access_selections + $access_selections_set
                [old_attributes^ [i].key];
          CASE old_attributes^ [i].key OF
          = amc$access_mode =
            attachment_options^ [access_mode_selection].access_modes.selector :=
                  fsc$specific_access_modes;
            #UNCHECKED_CONVERSION (old_attributes^ [i].access_mode,
                  attachment_options^ [access_mode_selection].access_modes.value);
            IF attachment_options^ [access_mode_selection].access_modes.value =
                  $fst$file_access_options [fsc$shorten, fsc$append] THEN
              attachment_count := attachment_count + 1;
              attachment_options^ [attachment_count].selector := fsc$delete_data;
              attachment_options^ [attachment_count].delete_data := TRUE;
            IFEND;
          = amc$average_record_length =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$average_record_length;
            creation_attributes^ [attribute_count].average_record_length :=
                  old_attributes^ [i].average_record_length;
          = amc$block_type =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$block_type;
            creation_attributes^ [attribute_count].block_type := old_attributes^ [i].block_type;
          = amc$character_conversion =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$character_conversion;
            creation_attributes^ [attribute_count].character_conversion :=
                  old_attributes^ [i].character_conversion;
          = amc$clear_space =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$erase_at_deletion;
            creation_attributes^ [attribute_count].erase_at_deletion := old_attributes^ [i].clear_space;
          = amc$collate_table_name =

{ processed in PROCESS_SELECTIONS because of PUSHs dependency on INLINE.

          = amc$compression_procedure_name =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$compression_procedure_name;
            creation_attributes^ [attribute_count].compression_procedure_name :=
                  old_attributes^ [i].compression_procedure_name;
          = amc$data_padding =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$data_padding;
            creation_attributes^ [attribute_count].data_padding := old_attributes^ [i].data_padding;
          = amc$dynamic_home_block_space =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$dynamic_home_block_space;
            creation_attributes^ [attribute_count].dynamic_home_block_space :=
                  old_attributes^ [i].dynamic_home_block_space;
          = amc$embedded_key =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$embedded_key;
            creation_attributes^ [attribute_count].embedded_key := old_attributes^ [i].embedded_key;
          = amc$error_exit_name =

{ processed in PROCESS_SELECTIONS because of PUSHs dependency on INLINE.

          = amc$error_limit =
            attachment_count := attachment_count + 1;
            attachment_options^ [attachment_count].selector := fsc$error_limit;
            attachment_options^ [attachment_count].error_limit := old_attributes^ [i].error_limit;
          = amc$error_options =
            attachment_count := attachment_count + 1;
            attachment_options^ [attachment_count].selector := fsc$tape_error_options;
            attachment_options^ [attachment_count].tape_error_options := old_attributes^ [i].error_options;
          = amc$estimated_record_count =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$estimated_record_count;
            creation_attributes^ [attribute_count].estimated_record_count :=
                  old_attributes^ [i].estimated_record_count;
          = amc$file_access_procedure =

{ processed in PROCESS_SELECTIONS because of PUSHs dependency on INLINE.

          = amc$file_contents =
            #TRANSLATE (osv$lower_to_upper, old_attributes^ [i].file_contents, specified_file_contents);
          = amc$file_limit =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$file_limit;
            creation_attributes^ [attribute_count].file_limit := old_attributes^ [i].file_limit;
          = amc$file_organization =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$file_organization;
            creation_attributes^ [attribute_count].file_organization := old_attributes^ [i].file_organization;
          = amc$file_processor =
            file_processor_index := i;
          = amc$file_structure =
            #TRANSLATE (osv$lower_to_upper, old_attributes^ [i].file_structure, specified_file_structure);
          = amc$forced_write =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$forced_write;
            creation_attributes^ [attribute_count].forced_write := old_attributes^ [i].forced_write;
          = amc$hashing_procedure_name =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$hashing_procedure_name;
            creation_attributes^ [attribute_count].hashing_procedure_name :=
                  old_attributes^ [i].hashing_procedure_name;
            creation_attributes^ [attribute_count].hashing_procedure_name^.object_library :=
                  old_attributes^ [i].hashing_procedure_name^.object_library;
          = amc$index_levels =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$index_levels;
            creation_attributes^ [attribute_count].index_levels := old_attributes^ [i].index_levels;
          = amc$index_padding =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$index_padding;
            creation_attributes^ [attribute_count].index_padding := old_attributes^ [i].index_padding;
          = amc$initial_home_block_count =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$initial_home_block_count;
            creation_attributes^ [attribute_count].initial_home_block_count :=
                  old_attributes^ [i].initial_home_block_count;
          = amc$internal_code =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$internal_code;
            creation_attributes^ [attribute_count].internal_code := old_attributes^ [i].internal_code;
          = amc$key_length =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$key_length;
            creation_attributes^ [attribute_count].key_length := old_attributes^ [i].key_length;
          = amc$key_position =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$key_position;
            creation_attributes^ [attribute_count].key_position := old_attributes^ [i].key_position;
          = amc$key_type =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$key_type;
            creation_attributes^ [attribute_count].key_type := old_attributes^ [i].key_type;
          = amc$label_exit_name =

{ processed in PROCESS_SELECTIONS because of PUSHs dependency on INLINE.

          = amc$label_options =

{ UNSUPPORTED by AMP$OPEN and can't be specified on FSP$OPEN_FILE.

          = amc$label_type =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$file_label_type;
            creation_attributes^ [attribute_count].file_label_type := old_attributes^ [i].label_type;
          = amc$line_number =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$line_number;
            creation_attributes^ [attribute_count].line_number := old_attributes^ [i].line_number;
          = amc$loading_factor =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$loading_factor;
            creation_attributes^ [attribute_count].loading_factor := old_attributes^ [i].loading_factor;
          = amc$lock_expiration_time =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$lock_expiration_time;
            creation_attributes^ [attribute_count].lock_expiration_time :=
                  old_attributes^ [i].lock_expiration_time;
          = amc$logging_options =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$logging_options;
            creation_attributes^ [attribute_count].logging_options := old_attributes^ [i].logging_options;
          = amc$log_residence =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$log_residence;
            creation_attributes^ [attribute_count].log_residence := old_attributes^ [i].log_residence;
          = amc$max_block_length =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$max_block_length;
            creation_attributes^ [attribute_count].max_block_length := old_attributes^ [i].max_block_length;
          = amc$max_record_length =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$max_record_length;
            creation_attributes^ [attribute_count].max_record_length := old_attributes^ [i].max_record_length;
          = amc$message_control =
            attachment_count := attachment_count + 1;
            attachment_options^ [attachment_count].selector := fsc$message_control;
            attachment_options^ [attachment_count].message_control := old_attributes^ [i].message_control;
          = amc$min_block_length =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$min_block_length;
            creation_attributes^ [attribute_count].min_block_length := old_attributes^ [i].min_block_length;
          = amc$min_record_length =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$min_record_length;
            creation_attributes^ [attribute_count].min_record_length := old_attributes^ [i].min_record_length;
          = amc$null_attribute =
            ;
          = amc$open_position =
            attachment_count := attachment_count + 1;
            attachment_options^ [attachment_count].selector := fsc$open_position;
            attachment_options^ [attachment_count].open_position := old_attributes^ [i].open_position;
          = amc$padding_character =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$padding_character;
            creation_attributes^ [attribute_count].padding_character := old_attributes^ [i].padding_character;
          = amc$page_format =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$page_format;
            creation_attributes^ [attribute_count].page_format := old_attributes^ [i].page_format;
          = amc$page_length =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$page_length;
            creation_attributes^ [attribute_count].page_length := old_attributes^ [i].page_length;
          = amc$page_width =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$page_width;
            creation_attributes^ [attribute_count].page_width := old_attributes^ [i].page_width;
          = amc$preset_value =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$preset_value;
            creation_attributes^ [attribute_count].preset_value := old_attributes^ [i].preset_value;
          = amc$record_limit =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$record_limit;
            creation_attributes^ [attribute_count].record_limit := old_attributes^ [i].record_limit;
          = amc$record_type =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$record_type;
            creation_attributes^ [attribute_count].record_type := old_attributes^ [i].record_type;
          = amc$records_per_block =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$records_per_block;
            creation_attributes^ [attribute_count].records_per_block := old_attributes^ [i].records_per_block;
          = amc$return_option =
            specified_return_option := old_attributes^ [i].return_option;
          = amc$ring_attributes =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$ring_attributes;
            creation_attributes^ [attribute_count].ring_attributes := old_attributes^ [i].ring_attributes;
          = amc$statement_identifier =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$statement_identifier;
            creation_attributes^ [attribute_count].statement_identifier :=
                  old_attributes^ [i].statement_identifier;
          = amc$user_info =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$user_information;
            creation_attributes^ [attribute_count].user_information := old_attributes^ [i].user_info;
          = amc$vertical_print_density =
            attribute_count := attribute_count + 1;
            creation_attributes^ [attribute_count].selector := fsc$vertical_print_density;
            creation_attributes^ [attribute_count].vertical_print_density :=
                  old_attributes^ [i].vertical_print_density;
          ELSE
          CASEND;
        IFEND;
      FOREND;

{ The following block of code is dependent on file_contents, file_structure, and file_processor
{ being removed once the block is finished.

      IF ($access_selections_set [amc$file_contents, amc$file_structure,
            amc$file_processor] * specified_access_selections) <> $access_selections_set [] THEN
        attribute_count := attribute_count + 1;
        creation_attributes^ [attribute_count].selector := fsc$file_contents_and_processor;
        IF amc$file_processor IN specified_access_selections THEN
          creation_attributes^ [attribute_count].file_processor :=
                old_attributes^ [file_processor_index].file_processor;
        ELSE
          creation_attributes^ [attribute_count].file_processor := osc$null_name;
        IFEND;
        IF ($access_selections_set [amc$file_contents, amc$file_structure] * specified_access_selections) <>
              $access_selections_set [] THEN
          IF NOT (amc$file_contents IN specified_access_selections) THEN
            specified_file_contents := amc$unknown_contents;
          ELSEIF NOT (amc$file_structure IN specified_access_selections) THEN
            fsp$dtm_structure_from_contents (specified_file_contents, specified_file_structure);
          IFEND;
          fsp$convert_to_new_contents (specified_file_contents, specified_file_structure,
                creation_attributes^ [attribute_count].file_contents, file_contents_truncated);
          IF file_contents_truncated THEN
            IF iteration = access_selection THEN
              bap$set_local_name_abnormal (lfn, fse$file_contents_truncated, 'AMP$OPEN',
                    specified_file_contents (1, clp$trimmed_string_size (specified_file_contents)), status);
            ELSE
              bap$set_local_name_abnormal (lfn, fse$file_contents_truncated, 'AMP$FILE',
                    specified_file_contents (1, clp$trimmed_string_size (specified_file_contents)), status);
            IFEND;
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  specified_file_structure (1, clp$trimmed_string_size (specified_file_structure)), status);
          IFEND;

        ELSE
          creation_attributes^ [attribute_count].file_contents := osc$null_name;
        IFEND;

{ File_contents, file_structure, and file_processor are removed because amp$open could specify
{ a file_processor and amp$file could specify file_contents and file_structure so both need to
{ be specified.

        specified_access_selections := specified_access_selections - $access_selections_set
              [amc$file_contents, amc$file_processor, amc$file_structure];
      IFEND;

    PROCEND process_unpushed_selections;

?? TITLE := 'PROCEDURE [INLINE] process_setfa_attachments', EJECT ??

    PROCEDURE [INLINE] process_setfa_attachments
      (    lfn: amt$local_file_name;
       VAR attachment_count: {i/o} ost$non_negative_integers;
           attachment_options: {i/o} ^fst$attachment_options;
       VAR specified_access_selections: {i/o} access_selections_set;
       VAR attached_permanent_file: boolean;
       VAR attached_share_modes: fst$file_access_options;
       VAR status: ost$status);

      VAR
        dynamic_attributes: fst$setfa_attachment_options,
        setfa_specified: boolean;

      status.normal := TRUE;

      bap$get_setfa_dynamic_attrs (lfn, attached_permanent_file, attached_share_modes, setfa_specified,
            dynamic_attributes, status);
      IF NOT (status.normal AND setfa_specified) THEN
        RETURN;
      IFEND;

      IF dynamic_attributes.access_modes_specified THEN
        IF NOT (amc$access_mode IN specified_access_selections) THEN
          specified_access_selections := specified_access_selections + $access_selections_set
                [amc$access_mode];
          attachment_options^ [access_mode_selection].access_modes.selector :=
                fsc$specific_access_modes;
          attachment_options^ [access_mode_selection].access_modes.value := dynamic_attributes.access_modes;
          IF attachment_options^ [access_mode_selection].access_modes.value =
                $fst$file_access_options [fsc$shorten, fsc$append] THEN
            attachment_count := attachment_count + 1;
            attachment_options^ [attachment_count].selector := fsc$delete_data;
            attachment_options^ [attachment_count].delete_data := TRUE;
          IFEND;
        IFEND;
      IFEND;
      IF dynamic_attributes.error_exit_name_specified THEN
        IF NOT (amc$error_exit_name IN specified_access_selections) THEN
          specified_access_selections := specified_access_selections +
                $access_selections_set [amc$error_exit_name];
          attachment_count := attachment_count + 1;
          attachment_options^ [attachment_count].selector := fsc$error_exit_procedure_name;
          PUSH attachment_options^ [attachment_count].error_exit_procedure_name;
          attachment_options^ [attachment_count].error_exit_procedure_name^.entry_point :=
                dynamic_attributes.error_exit_name;
          attachment_options^ [attachment_count].error_exit_procedure_name^.object_library := osc$null_name;
        IFEND;
      IFEND;
      IF dynamic_attributes.error_limit_specified THEN
        IF NOT (amc$error_limit IN specified_access_selections) THEN
          specified_access_selections := specified_access_selections + $access_selections_set
                [amc$error_limit];
          attachment_count := attachment_count + 1;
          attachment_options^ [attachment_count].selector := fsc$error_limit;
          attachment_options^ [attachment_count].error_limit := dynamic_attributes.error_limit;
        IFEND;
      IFEND;
      IF dynamic_attributes.label_exit_name_specified THEN
        IF NOT (amc$label_exit_name IN specified_access_selections) THEN
          specified_access_selections := specified_access_selections +
                $access_selections_set [amc$label_exit_name];
          attachment_count := attachment_count + 1;
          attachment_options^ [attachment_count].selector := fsc$label_exit_procedure_name;
          PUSH attachment_options^ [attachment_count].label_exit_procedure_name;
          attachment_options^ [attachment_count].label_exit_procedure_name^.entry_point :=
                dynamic_attributes.label_exit_name;
          attachment_options^ [attachment_count].label_exit_procedure_name^.object_library := osc$null_name;
        IFEND;
      IFEND;
      IF dynamic_attributes.message_control_specified THEN
        IF NOT (amc$message_control IN specified_access_selections) THEN
          specified_access_selections := specified_access_selections +
                $access_selections_set [amc$message_control];
          attachment_count := attachment_count + 1;
          attachment_options^ [attachment_count].selector := fsc$message_control;
          attachment_options^ [attachment_count].message_control := dynamic_attributes.message_control;
        IFEND;
      IFEND;
      IF dynamic_attributes.open_position_specified THEN
        IF NOT (amc$open_position IN specified_access_selections) THEN
          specified_access_selections := specified_access_selections +
                $access_selections_set [amc$open_position];
          attachment_count := attachment_count + 1;
          attachment_options^ [attachment_count].selector := fsc$open_position;
          attachment_options^ [attachment_count].open_position := dynamic_attributes.open_position;
        IFEND;
      IFEND;

    PROCEND process_setfa_attachments;

?? OLDTITLE, EJECT ??

  /open/
    BEGIN

      #KEYPOINT (osk$entry, 0, amk$open);
      status.normal := TRUE;
      #CALLER_ID (caller_id);

      mandated_creation_attributes := NIL;
      default_creation_attributes := NIL;
      specified_return_option := amc$return_at_job_exit;

      clp$validate_name (local_file_name, lfn, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal (amc$access_method_id, cle$improper_name, local_file_name, status);
        EXIT /open/;
      IFEND;

      IF access_selections <> NIL THEN
        PUSH local_access_selections: [1 .. UPPERBOUND (access_selections^)];
        local_access_selections^ := access_selections^;
        amp$validate_attributes (lfn, amc$open_req, caller_id.ring, local_access_selections, status);
        IF NOT status.normal THEN
          EXIT /open/;
        IFEND;
      ELSE
        local_access_selections := NIL;
      IFEND;

      bap$fetch_art_table_pointer (lfn, file_request_attributes);

{
{ The previous implementation of AMP$OPEN handled access and share modes in th following manner:
{   1) If the file was not currently attached, fsc$determine_from_access_modes was either explicitly or
{      implicitly specified on the attachment of the file.
{   2) If the file was currently attached, no share validation was done.  This is essentially the same as
{      specifying fsc$required_share_modes.
{ With FSP$OPEN_FILE whether or not the file is attached has no affect on share mode validation.
{   (ie. If access_and_share_modes is not specified, fsc$determine_from_access_modes is used.)
{ In order to replicate AMP$OPENs behavior using FSP$OPEN_FILE access_and_share_modes are always specified
{ in the following manner:
{   1) access_modes of fsc$permitted_access_modes - this is the default value if no access modes are
{      specified.  IF access_modes are specified by amp$file, set_file_attributes, or on the call to
{      amp$open, the appropriate value is used.
{   2) share_modes of fsc$determine_from_access_modes is used for the first selection in order to be
{      compatible with the way AMP$OPEN handled a file that was not currently attached.
{   3) share_modes of the attachment are used for the second selection if the file is currently attached.
{ These choices of share_modes will make the new implementation of AMP$OPEN replicate the old implementation.
{

      PUSH attachment_options: [1 .. number_of_supported_attachments + 2];

{ + 2 is for delete_data specification and double access_mode specification.

      attachment_options^ [access_mode_selection].selector := fsc$access_and_share_modes;
      attachment_options^ [access_mode_selection].access_modes.selector := fsc$permitted_access_modes;
      attachment_options^ [access_mode_selection].share_modes.selector :=
            fsc$determine_from_access_modes;

      attachment_count := access_mode_selection;
      specified_access_selections := $access_selections_set [];

      IF (local_access_selections <> NIL) THEN
        PUSH mandated_creation_attributes: [1 .. UPPERBOUND (local_access_selections^)];
        process_selections (local_access_selections, attachment_count, attachment_options,
              specified_access_selections, attribute_count, mandated_creation_attributes, status);
        IF NOT status.normal THEN
          EXIT /open/;
        IFEND;
        IF attribute_count = 0 THEN
          mandated_creation_attributes := NIL;
        ELSE
          temporary_sequence_pointer := #SEQ (mandated_creation_attributes^);
          RESET temporary_sequence_pointer;
          NEXT mandated_creation_attributes: [1 .. attribute_count] IN temporary_sequence_pointer;
        IFEND;
      IFEND;

{ Prevent SETFA or AMP$FILE from overriding file_reference specification of open_position.

      clp$check_name_for_path_handle (lfn, cl_path_handle);
      IF (cl_path_handle.kind = clc$regular_path_handle) AND
            (cl_path_handle.regular_handle.open_position.specified) THEN
        specified_access_selections := specified_access_selections + $access_selections_set
              [amc$open_position];
      IFEND;

      process_setfa_attachments (lfn, attachment_count, attachment_options, specified_access_selections,
            attached_permanent_file, attached_share_modes, status);
      IF NOT status.normal THEN
        EXIT /open/;
      IFEND;

      IF (file_request_attributes <> NIL) THEN
        PUSH default_creation_attributes: [1 .. UPPERBOUND (file_request_attributes^)];
        process_selections (file_request_attributes, attachment_count, attachment_options,
              specified_access_selections, attribute_count, default_creation_attributes, status);
        IF NOT status.normal THEN
          EXIT /open/;
        IFEND;
        IF attribute_count = 0 THEN
          default_creation_attributes := NIL;
        ELSE
          temporary_sequence_pointer := #SEQ (default_creation_attributes^);
          RESET temporary_sequence_pointer;
          NEXT default_creation_attributes: [1 .. attribute_count] IN temporary_sequence_pointer;
        IFEND;
      IFEND;

      IF attached_permanent_file THEN
        attachment_count := attachment_count + 1;
        attachment_options^ [attachment_count] := attachment_options^ [access_mode_selection];
        attachment_options^ [attachment_count].share_modes.selector := fsc$specific_share_modes;
        attachment_options^ [attachment_count].share_modes.value := attached_share_modes;
      IFEND;
      temporary_sequence_pointer := #SEQ (attachment_options^);
      RESET temporary_sequence_pointer;
      NEXT attachment_options: [1 .. attachment_count] IN temporary_sequence_pointer;

{ Prefix local_file_name with ':$LOCAL.' to prevent the local_file_name from being treated as a
{ file variable.

      IF cl_path_handle.kind = clc$not_a_path_handle THEN
        file_reference := local_reference;
        file_reference (local_reference_size + 1, osc$max_name_size) := lfn;
      ELSE
        file_reference := lfn;
      IFEND;

      fsp$open_file (file_reference, access_level, attachment_options, default_creation_attributes,
            mandated_creation_attributes, {attribute_validation=} mandated_creation_attributes,
            {attribute_override=} NIL, file_identifier, status);

      IF status.normal AND (specified_return_option = amc$return_at_close) THEN
        bap$set_return_at_close (file_identifier);
      IFEND;

    END /open/;

    #KEYPOINT (osk$exit, 0, amk$open);

  PROCEND amp$open;

MODEND amm$open;
*DECK DECK=AMM$PUTREP EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$putrep;

{ MODULE DECK AMMPRP }

?? TITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$PUTREP' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
*copyc AMK$ACCESS_METHOD
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$putrep (file_identifier: amt$file_identifier;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
        key_location: ^cell;
        wait: ost$wait;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$PUTREP',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$putrep);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$putrep);
      RETURN;
    IFEND;

    call_block.operation := amc$putrep_req;

    call_block.putrep.working_storage_area := working_storage_area;
    call_block.putrep.working_storage_length := working_storage_length;
    call_block.putrep.key_location := key_location;
    call_block.putrep.wait := wait;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$putrep);
  PROCEND amp$putrep;
MODEND amm$putrep;
*DECK DECK=AMM$PUT_DIRECT EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$put_direct;

{ MODULE DECK AMMPTD }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$PUT_DIRECT' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc OSP$SET_STATUS_ABNORMAL
*copyc osv$initial_exception_context
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$PUT_DIRECT
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$put_direct ALIAS 'amxputd' (file_identifier:
    amt$file_identifier;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
        byte_address: amt$file_byte_address;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$PUT_DIRECT',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      call_block: amt$call_block,
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry;

    #keypoint (osk$entry, 0, amk$put_direct);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$put_direct);
      RETURN;
    IFEND;

    call_block.operation := amc$put_direct_req;

    call_block.putd.working_storage_area := working_storage_area;
    call_block.putd.working_storage_length := working_storage_length;
    call_block.putd.byte_address := byte_address;

*copy BAI$FAP_CONTROL

    #keypoint (osk$exit, 0, amk$put_direct);
  PROCEND amp$put_direct;
MODEND amm$put_direct;
*DECK DECK=AMM$PUT_KEY EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$put_key;

{ MODULE DECK AMMPKY }

?? TITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$PUT_KEY' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
*copyc AMK$ACCESS_METHOD
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$put_key (file_identifier: amt$file_identifier;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
        key_location: ^cell;
        wait: ost$wait;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$PUT_KEY',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$put_key);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$put_key);
      RETURN;
    IFEND;

    call_block.operation := amc$put_key_req;

    call_block.putk.working_storage_area := working_storage_area;
    call_block.putk.working_storage_length := working_storage_length;
    call_block.putk.key_location := key_location;
    call_block.putk.wait := wait;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$put_key);
  PROCEND amp$put_key;
MODEND amm$put_key;
*DECK DECK=AMM$PUT_LABEL EXPAND=TRUE
*DECK DECK=AMM$PUT_NEXT EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$put_next;

{ MODULE DECK AMMPUT }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$PUT_NEXT' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc OSP$SET_STATUS_ABNORMAL
*copyc osv$initial_exception_context
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$PUT_NEXT
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$put_next ALIAS 'amxputn' (file_identifier:
    amt$file_identifier;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
    VAR byte_address: amt$file_byte_address;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$PUT_NEXT',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry,
      context: ^ost$ecp_exception_context;

    #keypoint (osk$entry, 0, amk$put_next);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$put_next);
      RETURN;
    IFEND;

    call_block.operation := amc$put_next_req;

    call_block.putn.working_storage_area := working_storage_area;
    call_block.putn.working_storage_length := working_storage_length;
    call_block.putn.byte_address := ^byte_address;

*copy BAI$FAP_CONTROL

    #keypoint (osk$exit, 0, amk$put_next);
  PROCEND amp$put_next;
MODEND amm$put_next;
*DECK DECK=AMM$PUT_PARTIAL EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$put_partial;

{ MODULE DECK AMMPPR }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$PUT_PARTIAL' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc OSP$SET_STATUS_ABNORMAL
*copyc osv$initial_exception_context
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$PUT_PARTIAL
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$put_partial ALIAS 'amxputp' (file_identifier:
    amt$file_identifier;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
    VAR byte_address: amt$file_byte_address;
        term_option: amt$term_option;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$PUT_PARTIAL',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      call_block: amt$call_block,
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry;

    #keypoint (osk$entry, 0, amk$put_partial);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$put_partial);
      RETURN;
    IFEND;
    call_block.operation := amc$put_partial_req;

    call_block.putp.working_storage_area := working_storage_area;
    call_block.putp.working_storage_length := working_storage_length;
    call_block.putp.byte_address := ^byte_address;
    call_block.putp.term_option := term_option;

*copy BAI$FAP_CONTROL

    #keypoint (osk$exit, 0, amk$put_partial);
  PROCEND amp$put_partial;
MODEND amm$put_partial;
*DECK DECK=AMM$REPLACE_KEY EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$replace_key;

{ MODULE DECK AMMRKY }

?? TITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$REPLACE_KEY' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
*copyc AMK$ACCESS_METHOD
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$replace_key (file_identifier:
    amt$file_identifier;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
        key_location: ^cell;
        wait: ost$wait;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$REPLACE_KEY',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$replace_key);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$replace_key);
      RETURN;
    IFEND;

    call_block.operation := amc$replace_key_req;

    call_block.repk.working_storage_area := working_storage_area;
    call_block.repk.working_storage_length := working_storage_length;
    call_block.repk.key_location := key_location;
    call_block.repk.wait := wait;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$replace_key);
  PROCEND amp$replace_key;
MODEND amm$replace_key;
*DECK DECK=AMM$REPLACE_PREVIOUS_RECORD EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$replace_previous_record;

{ MODULE DECK AMM$REPLACE_PREVIOUS_RECORD }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$REPLACE_PREVIOUS_RECORD' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc OSP$SET_STATUS_ABNORMAL
*copyc osv$initial_exception_context
?? EJECT ??
*copyc AMH$ALSO
{*copyc AMH$REPLACE_PREVIOUS_RECORD}
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$replace_previous_record (file_identifier:
    amt$file_identifier;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$REPLACE_PREVIOUS_RECORD',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      call_block: amt$call_block,
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry;

    #keypoint (osk$entry, 0, amk$replace_previous_record);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            'AMP$REPLACE_PREVIOUS_RECORD', status);
      #keypoint (osk$exit, 0, amk$replace_previous_record);
      RETURN;
    IFEND;

    call_block.operation := amc$replace_req;

    call_block.putn.working_storage_area := working_storage_area;
    call_block.putn.working_storage_length := working_storage_length;

*copy BAI$FAP_CONTROL

    #keypoint (osk$exit, 0, amk$replace_previous_record);
  PROCEND amp$replace_previous_record;
MODEND amm$replace_previous_record;
*DECK DECK=AMM$RETURN EXPAND=TRUE
?? RIGHT := 110 ??
MODULE amm$return;

{ MODULE DECK AMMRTN

?? TITLE := 'NOS/VE : BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$RETURN' ??
?? NEWTITLE := '  RING BRACKETS 2DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$condition_codes
*copyc ame$lfn_program_actions
*copyc amk$access_method
*copyc amt$local_file_name
*copyc fst$file_reference
*copyc ost$status
?? POP ??

*copyc bap$delete_art_entry
*copyc bap$return
*copyc clp$evaluate_file_reference
*copyc clp$trimmed_string_size
*copyc clp$validate_local_file_name
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition

*copyc fsv$evaluated_file_reference
*copyc osv$initial_exception_context
?? EJECT ??
*copyc amh$return

  PROCEDURE [XDCL, #GATE] amp$return
    (    file: fst$file_reference;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context,
      evaluated_file_reference: fst$evaluated_file_reference,
      ignore_status: ost$status,
      local_file_name: amt$local_file_name,
      name_is_path_handle: boolean,
      name_is_valid: boolean,
      path_handle: fmt$path_handle;


    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, amk$return);

    context := NIL;

  /return_file/
    BEGIN
      clp$validate_local_file_name (file, local_file_name, path_handle, name_is_path_handle, name_is_valid);
      IF name_is_path_handle THEN

{       The call to clp$validate_local_file_name and this path_handle check is
{       here because clp$evaluate_file_reference returns the full path for an
{       alias path handle.

        evaluated_file_reference := fsv$evaluated_file_reference;
        evaluated_file_reference.path_handle_info.path_handle_present := TRUE;
        evaluated_file_reference.path_handle_info.path_handle := path_handle;
      ELSE
        clp$evaluate_file_reference (file, $clt$file_ref_parsing_options [clc$use_$local_as_working_cat],
              {resolve_cycle_number=} FALSE, evaluated_file_reference, status);
        IF NOT status.normal THEN
          EXIT /return_file/;
        IFEND;
      IFEND;

      REPEAT
        bap$return (evaluated_file_reference, {detachment_options} NIL, status);
        IF NOT status.normal THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_evaluated_file_ref;
            context^.file.evaluated_file_reference := evaluated_file_reference;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

      IF (status.normal OR (status.condition = ame$file_not_known)) AND name_is_valid THEN
        bap$delete_art_entry (local_file_name, ignore_status);
      IFEND;

    END /return_file/;

    #KEYPOINT (osk$exit, 0, amk$return);

  PROCEND amp$return;

MODEND amm$return;

*DECK DECK=AMM$REWIND EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$rewind;

{ MODULE DECK AMMRWD }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$REWIND' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc AMP$TERMINATE_FILE
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$REWIND
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$rewind ALIAS 'amxrewd' (file_identifier:
    amt$file_identifier;
        wait: ost$wait;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$REWIND',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$rewind);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$rewind);
      RETURN;
    IFEND;

    amp$terminate_file (file_identifier, file_instance^);

    call_block.operation := amc$rewind_req;
    call_block.rewind.wait := wait;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$rewind);
  PROCEND amp$rewind;
MODEND amm$rewind;
*DECK DECK=AMM$SEEK_DIRECT EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$seek_direct;

{ MODULE DECK AMMSKD }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$SEEK_DIRECT' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$SEEK_DIRECT
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$seek_direct ALIAS 'amxseek' (file_identifier:
    amt$file_identifier;
        byte_address: amt$file_byte_address;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$SEEK_DIRECT',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$seek_direct);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$seek_direct);
      RETURN;
    IFEND;

    call_block.operation := amc$seek_direct_req;
    call_block.seekd.byte_address := byte_address;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$seek_direct);
  PROCEND amp$seek_direct;
MODEND amm$seek_direct;
*DECK DECK=AMM$SELECT_KEY EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$select_key;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$SELECT_KEY' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$select_key (file_identifier: amt$file_identifier;
        key_name: amt$key_name;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$SELECT_KEY',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$select_key);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$select_key);
      RETURN;
    IFEND;

    call_block.operation := amc$select_key;
    call_block.select_key.key_name := key_name;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$select_key);
  PROCEND amp$select_key;
MODEND amm$select_key;
*DECK DECK=AMM$SELECT_NESTED_FILE EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$select_nested_file;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$SELECT_NESTED_FILE' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$select_nested_file (file_identifier:
    amt$file_identifier;
        nested_file_name: amt$nested_file_name;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$SELECT_NESTED_FILE',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$select_nested_file);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$select_nested_file);
      RETURN;
    IFEND;

    call_block.operation := amc$select_nested_file;
    call_block.select_nested_file.nested_file_name := nested_file_name;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$select_nested_file);
  PROCEND amp$select_nested_file;
MODEND amm$select_nested_file;
*DECK DECK=AMM$SEPARATE_KEY_GROUPS EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$separate_key_groups;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$SEPARATE_KEY_GROUPS' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$separate_key_groups (file_identifier:
    amt$file_identifier;
        group: amt$group_name;
        parallel_group: amt$group_name;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$SEPARATE_KEY_GROUPS',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$separate_key_groups);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$separate_key_groups);
      RETURN;
    IFEND;

    call_block.operation := amc$separate_key_groups;
    call_block.separate_key_groups.group := group;
    call_block.separate_key_groups.parallel_group := parallel_group;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$separate_key_groups);
  PROCEND amp$separate_key_groups;
MODEND amm$separate_key_groups;
*DECK DECK=AMM$SET_FILE_INSTANCE_ABNORMAL EXPAND=TRUE
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE : Basic Access Methods : Set File Instance Abnormal' ??

MODULE amm$set_file_instance_abnormal;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc amd$operation_declarations
*copyc ame$improper_file_id
*copyc amk$access_method
*copyc amt$file_identifier
*copyc bac$unused_request_table_entry
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc bap$set_local_name_abnormal
*copyc bap$validate_file_identifier
*copyc clp$get_fs_path_string
*copyc clp$trimmed_string_size
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc amv$access_level_names
*copyc amv$block_type_names
*copyc amv$file_organization_names
*copyc amv$record_type_names
*copyc bav$request_name_table_ptr

?? EJECT ??
*copyc amh$set_file_instance_abnormal
?? TITLE := 'PROCEDURE [XDCL, #GATE] amp$set_file_instance_abnormal', EJECT ??

  PROCEDURE [XDCL, #GATE] amp$set_file_instance_abnormal
    (    file_identifier: amt$file_identifier;
         condition: ost$status_condition;
         request_code: amt$last_operation;
         text: string ( * );
     VAR status: ost$status);

    #keypoint (osk$entry, 0, amk$set_file_instance_abnormal);

    IF (request_code >= LOWERBOUND (bav$request_name_table_ptr^)) AND
          (request_code <= UPPERBOUND (bav$request_name_table_ptr^)) AND
          (bav$request_name_table_ptr^ [request_code].name <>
          bac$unused_request_table_entry) THEN
      bap$set_file_instance_abnormal (file_identifier, condition,
            bav$request_name_table_ptr^ [request_code].name, text, status);
    ELSE
      bap$set_file_instance_abnormal (file_identifier, condition,
            osc$null_name, text, status);
    IFEND;

    #keypoint (osk$exit, 0, amk$set_file_instance_abnormal);

  PROCEND amp$set_file_instance_abnormal;

?? EJECT ??
*copyc bah$set_file_instance_abnormal

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$set_file_instance_abnormal', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$set_file_instance_abnormal
    (    file_identifier: amt$file_identifier;
         condition: ost$status_condition;
         request_name: string ( * <= osc$max_name_size);
         text: string ( * );
     VAR status: ost$status);

    CONST
      error_size = 4,
      error_text = '____';

    VAR
      error_name: amt$local_file_name,
      file_instance: ^bat$task_file_entry,
      ignore_path_handle: fmt$path_handle,
      local_status: ost$status,
      path: fst$path,
      path_size: fst$path_size,
      status_text: string (osc$max_string_size),
      status_text_index: ost$string_index,
      text_length: ost$string_size,
      valid_fid: boolean;

    bap$validate_file_identifier (file_identifier, file_instance, valid_fid);

    IF valid_fid THEN
      osp$set_status_abnormal (amc$access_method_id, condition, '', status);

{FILE NAME
      clp$get_fs_path_string (file_instance^.local_file_name, path, path_size,
            ignore_path_handle, local_status);
      IF (NOT local_status.normal) OR (path_size = 0) THEN
        path := error_text;
        path_size := error_size;
      IFEND;
      osp$append_status_file (osc$status_parameter_delimiter,
            path (1, path_size), status);

{REQUEST NAME
      IF request_name = osc$null_name THEN
        text_length := error_size;
        status_text (1, text_length) := error_text;
      ELSE
        text_length := clp$trimmed_string_size (request_name);
        IF text_length > osc$max_name_size THEN
          text_length := osc$max_name_size;
        IFEND;
        status_text (1, text_length) :=
              request_name (1, text_length);
      IFEND;

{ACCESS LEVEL
      status_text_index := text_length + 1;
      status_text (status_text_index) := osc$status_parameter_delimiter;
      text_length := amv$access_level_names [file_instance^.access_level].size;
      status_text (status_text_index + 1, text_length) :=
            amv$access_level_names [file_instance^.access_level].name
            (1, text_length);

{FILE ORGANIZATION
      status_text_index := status_text_index + text_length + 1;
      status_text (status_text_index) := osc$status_parameter_delimiter;
      text_length := amv$file_organization_names [file_instance^.
            instance_attributes.static_label.file_organization].size;
      status_text (status_text_index + 1, text_length) :=
            amv$file_organization_names [file_instance^.
            instance_attributes.static_label.file_organization].name
            (1, text_length);

{RECORD TYPE
      status_text_index := status_text_index + text_length + 1;
      status_text (status_text_index) := osc$status_parameter_delimiter;
      text_length := amv$record_type_names [file_instance^.
            instance_attributes.static_label.record_type].size;
      status_text (status_text_index + 1, text_length) :=
            amv$record_type_names [file_instance^.
            instance_attributes.static_label.record_type].name
            (1, text_length);

{BLOCK TYPE
      status_text_index := status_text_index + text_length + 1;
      status_text (status_text_index) := osc$status_parameter_delimiter;
      text_length := amv$block_type_names [file_instance^.
            instance_attributes.static_label.block_type].size;
      status_text (status_text_index + 1, text_length) :=
            amv$block_type_names [file_instance^.
            instance_attributes.static_label.block_type].name
            (1, text_length);

{EXTRA
      status_text_index := status_text_index + text_length + 1;
      status_text (status_text_index) := osc$status_parameter_delimiter;
      status_text (status_text_index + 1, error_size) := error_text;

{TEXT
      status_text_index := status_text_index + error_size + 1;
      status_text (status_text_index) := osc$status_parameter_delimiter;
      text_length := clp$trimmed_string_size (text);
      IF text_length > (osc$max_string_size - status_text_index) THEN
        text_length := (osc$max_string_size - status_text_index);
      IFEND;
      status_text (status_text_index + 1, text_length) :=
            text (1, text_length);

      osp$append_status_parameter (osc$status_parameter_delimiter,
            status_text (1, status_text_index + text_length), status);

    ELSE {invalid file identifier
      error_name := error_text;
      bap$set_local_name_abnormal (error_name, condition, request_name, text,
            status);
    IFEND;

  PROCEND bap$set_file_instance_abnormal;

?? OLDTITLE ??

MODEND amm$set_file_instance_abnormal;


*DECK DECK=AMM$SET_LOCAL_NAME_ABNORMAL EXPAND=TRUE
*copy osd$default_pragmats
?? NEWTITLE := 'NOS/VE : Basic Access Methods : Set Local Name Abnormal' ??

MODULE amm$set_local_name_abnormal;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc amd$operation_declarations
*copyc amk$access_method
*copyc amt$local_file_name
*copyc bac$unused_request_table_entry
*copyc bat$request_name_table_entry
*copyc oss$job_paged_literal
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc clp$trimmed_string_size
*copyc clp$validate_name
*copyc osp$set_status_abnormal

*copyc osv$lower_to_upper

?? TITLE := 'bav$request_name_table', EJECT ??

?? FMT (FORMAT := OFF) ??
  VAR
    bav$request_name_table: [READ, oss$job_paged_literal]
          array [amc$access_method_req .. ifc$store_terminal_req] of
          bat$request_name_table_entry := [
[ amc$access_method_req           , 'AMP$ACCESS_METHOD_REQ          '],
[ 2                               , bac$unused_request_table_entry],
[ amc$add_to_file_description_req , 'AMP$ADD_TO_FILE_DESCRIPTION    '],
[ 4                               , bac$unused_request_table_entry],
[ amc$allocate_req                , 'AMP$ALLOCATE                   '],
[ amc$change_file_attributes_cmd  , 'CHANGE_FILE_ATTRIBUTES         '],
[ amc$compare_file_cmd            , 'COMPARE_FILE                   '],
[ amc$copy_file_cmd               , 'COPY_FILE                      '],
[ amc$copy_file_req               , 'AMP$COPY_FILE                  '],
[ amc$copy_partitions_req         , 'AMP$COPY_PARTITIONS            '],
[ amc$copy_records_req            , 'AMP$COPY_RECORDS               '],
[ amc$copy_partial_records_req    , 'AMP$COPY_PARTIAL_RECORDS       '],
[ 13                              , bac$unused_request_table_entry],
[ 14                              , bac$unused_request_table_entry],
[ 15                              , bac$unused_request_table_entry],
[ 16                              , bac$unused_request_table_entry],
[ amc$detach_file_cmd             , 'DETACH_FILES                   '],
[ amc$display_file_attributes_cmd , 'DISPLAY_FILE_ATTRIBUTES        '],
[ amc$display_file_cmd            , 'DISPLAY_FILE                   '],
[ amc$evict_req                   , 'AMP$EVICT                      '],
[ 21                              , bac$unused_request_table_entry],
[ amc$fetch_fap_pointer_req       , 'AMP$FETCH_FAP_POINTER          '],
[ 23                              , bac$unused_request_table_entry],
[ amc$file_req                    , 'AMP$FILE                       '],
[ 25                              , bac$unused_request_table_entry],
[ fmc$store_tape_label_attr_req   , 'FMP$STORE_TAPE_LABEL_ATTRIBUTES'],
[ fmc$fetch_tape_label_attr_req   , 'FMP$FETCH_TAPE_LABEL_ATTRIBUTES'],
[ fmc$display_tape_label_attr_cmd , 'DISPLAY_TAPE_LABEL_ATTRIBUTES  '],
[ fmc$change_tape_label_attr_cmd  , 'CHANGE_TAPE_LABEL_ATTRIBUTES   '],
[ amc$get_file_attributes_req     , 'AMP$GET_FILE_ATTRIBUTES        '],
[ 31                              , bac$unused_request_table_entry],
[ 32                              , bac$unused_request_table_entry],
[ 33                              , bac$unused_request_table_entry],
[ 34                              , bac$unused_request_table_entry],
[ 35                              , bac$unused_request_table_entry],
[ 36                              , bac$unused_request_table_entry],
[ 37                              , bac$unused_request_table_entry],
[ 38                              , bac$unused_request_table_entry],
[ 39                              , bac$unused_request_table_entry],
[ 40                              , bac$unused_request_table_entry],
[ 41                              , bac$unused_request_table_entry],
[ 42                              , bac$unused_request_table_entry],
[ 43                              , bac$unused_request_table_entry],
[ 44                              , bac$unused_request_table_entry],
[ 45                              , bac$unused_request_table_entry],
[ 46                              , bac$unused_request_table_entry],
[ 47                              , bac$unused_request_table_entry],
[ 48                              , bac$unused_request_table_entry],
[ 49                              , bac$unused_request_table_entry],
[ amc$label_req                   , 'AMP$LABEL                      '],
[ 51                              , bac$unused_request_table_entry],
[ 52                              , bac$unused_request_table_entry],
[ 53                              , bac$unused_request_table_entry],
[ 54                              , bac$unused_request_table_entry],
[ 55                              , bac$unused_request_table_entry],
[ 56                              , bac$unused_request_table_entry],
[ 57                              , bac$unused_request_table_entry],
[ 58                              , bac$unused_request_table_entry],
[ 59                              , bac$unused_request_table_entry],
[ amc$override_file_attributes    , 'AMP$OVERRIDE_FILE_ATTRIBUTES   '],
[ 61                              , bac$unused_request_table_entry],
[ 62                              , bac$unused_request_table_entry],
[ 63                              , bac$unused_request_table_entry],
[ 64                              , bac$unused_request_table_entry],
[ 65                              , bac$unused_request_table_entry],
[ 66                              , bac$unused_request_table_entry],
[ 67                              , bac$unused_request_table_entry],
[ 68                              , bac$unused_request_table_entry],
[ 69                              , bac$unused_request_table_entry],
[ 70                              , bac$unused_request_table_entry],
[ 71                              , bac$unused_request_table_entry],
[ amc$rename_req                  , 'AMP$RENAME                     '],
[ 73                              , bac$unused_request_table_entry],
[ amc$return_req                  , 'AMP$RETURN                     '],
[ amc$rewind_files_cmd            , 'REWIND_FILES                   '],
[ amc$set_local_name_abnormal_req , 'AMP$SET_LOCAL_NAME_ABNORMAL    '],
[ amc$set_file_attributes_cmd     , 'SET_FILE_ATTRIBUTES            '],
[ amc$set_file_inst_abnormal_req  , 'AMP$SET_FILE_INSTANCE_ABNORMAL '],
[ 79                              , bac$unused_request_table_entry],
[ 80                              , bac$unused_request_table_entry],
[ amc$skip_tape_marks_cmd         , 'SKIP_TAPE_MARKS                '],
[ amc$skip_tape_marks_req         , 'AMP$SKIP_TAPE_MARKS            '],
[ 83                              , bac$unused_request_table_entry],
[ amc$store_fap_pointer_req       , 'AMP$STORE_FAP_POINTER          '],
[ 85                              , bac$unused_request_table_entry],
[ 86                              , bac$unused_request_table_entry],
[ 87                              , bac$unused_request_table_entry],
[ 88                              , bac$unused_request_table_entry],
[ 89                              , bac$unused_request_table_entry],
[ 90                              , bac$unused_request_table_entry],
[ 91                              , bac$unused_request_table_entry],
[ 92                              , bac$unused_request_table_entry],
[ 93                              , bac$unused_request_table_entry],
[ fsc$create_file_req             , 'FSP$CREATE_FILE                '],
[ amc$validate_caller_privilege   , 'AMP$VALIDATE_CALLER_PRIVILEGE  '],
[ fsc$copy_file_req               , 'FSP$COPY_FILE                  '],
[ fsc$get_file_attributes_req     , 'FSP$GET_FILE_ATTRIBUTES        '],
[ fsc$get_file_information_req    , 'FSP$GET_FILE_INFORMATION       '],
[ fsc$get_open_attributes_req     , 'FSP$GET_OPEN_ATTRIBUTES        '],
[ fsc$get_open_information_req    , 'FSP$GET_OPEN_INFORMATION       '],
[ amc$fetch_access_information_rq , 'AMP$FETCH_ACCESS_INFORMATION   '],
[ 102                             , bac$unused_request_table_entry],
[ 103                             , bac$unused_request_table_entry],
[ 104                             , bac$unused_request_table_entry],
[ 105                             , bac$unused_request_table_entry],
[ 106                             , bac$unused_request_table_entry],
[ 107                             , bac$unused_request_table_entry],
[ 108                             , bac$unused_request_table_entry],
[ 109                             , bac$unused_request_table_entry],
[ amc$abandon_key_definitions     , 'AMP$ABANDON_KEY_DEFINITIONS    '],
[ amc$abort_file_parcel           , 'AMP$ABORT_FILE_PARCEL          '],
[ amc$apply_key_definitions       , 'AMP$APPLY_KEY_DEFINITIONS      '],
[ amc$begin_file_parcel           , 'AMP$BEGIN_FILE_PARCEL          '],
[ amc$check_buffer_req            , 'AMP$CHECK_BUFFER               '],
[ amc$check_nowait_request        , 'AMP$CHECK_NOWAIT_REQUEST       '],
[ amc$check_record_req            , 'AMP$CHECK_RECORD               '],
[ amc$close_req                   , 'FSP$CLOSE_FILE                 '],
[ amc$close_volume_req            , 'AMP$CLOSE_VOLUME               '],
[ amc$commit_file_parcel          , 'AMP$COMMIT_FILE_PARCEL         '],
[ amc$create_key_definition       , 'AMP$CREATE_KEY_DEFINITION      '],
[ amc$create_nested_file          , 'AMP$CREATE_NESTED_FILE         '],
[ amc$delete_direct_req           , 'AMP$DELETE_DIRECT              '],
[ amc$delete_key_definition       , 'AMP$DELETE_KEY_DEFINITION      '],
[ amc$delete_key_req              , 'AMP$DELETE_KEY                 '],
[ amc$delete_nested_file          , 'AMP$DELETE_NESTED_FILE         '],
[ amc$delete_req                  , 'AMP$DELETE                     '],
[ amc$erase_tape_block            , 'AMP$ERASE_TAPE_BLOCK           '],
[ amc$fetch_req                   , 'AMP$FETCH                      '],
[ amc$find_record_space           , 'AMP$FIND_RECORD_SPACE          '],
[ amc$flush_req                   , 'AMP$FLUSH                      '],
[ amc$get_direct_req              , 'AMP$GET_DIRECT                 '],
[ amc$get_key_definitions         , 'AMP$GET_KEY_DEFINITIONS        '],
[ amc$get_key_req                 , 'AMP$GET_KEY                    '],
[ amc$get_label_req               , 'AMP$GET_LABEL                  '],
[ amc$get_lock_keyed_record       , 'AMP$GET_LOCK_KEYED_RECORD      '],
[ amc$get_lock_next_keyed_record  , 'AMP$GET_LOCK_NEXT_KEYED_RECORD '],
[ amc$get_nested_file_definitions , 'AMP$GET_NESTED_FILE_DEFINITIONS'],
[ amc$get_next_key_req            , 'AMP$GET_NEXT_KEY               '],
[ amc$get_next_primary_key_list   , 'AMP$GET_NEXT_PRIMARY_KEY_LIST  '],
[ amc$get_next_req                , 'AMP$GET_NEXT                   '],
[ amc$get_partial_req             , 'AMP$GET_PARTIAL                '],
[ amc$get_primary_key_count       , 'AMP$GET_PRIMARY_KEY_COUNT      '],
[ amc$get_segment_pointer_req     , 'AMP$GET_SEGMENT_POINTER        '],
[ amc$get_space_used_for_key      , 'AMP$GET_SPACE_USED_FOR_KEY     '],
[ 145                             , bac$unused_request_table_entry],
[ amc$lock_file_req               , 'AMP$LOCK_FILE                  '],
[ amc$lock_key                    , 'AMP$LOCK_KEY                   '],
[ amc$open_req                    , 'FSP$OPEN_FILE                  '],
[ amc$pack_block_req              , 'AMP$PACK_BLOCK                 '],
[ amc$pack_record_req             , 'AMP$PACK_RECORD                '],
[ amc$put_direct_req              , 'AMP$PUT_DIRECT                 '],
[ amc$put_key_req                 , 'AMP$PUT_KEY                    '],
[ amc$put_label_req               , 'AMP$PUT_LABEL                  '],
[ amc$put_next_req                , 'AMP$PUT_NEXT                   '],
[ amc$put_partial_req             , 'AMP$PUT_PARTIAL                '],
[ amc$putrep_req                  , 'AMP$PUTREP                     '],
[ amc$read_direct_req             , 'AMP$READ_DIRECT                '],
[ amc$read_direct_skip_req        , 'AMP$READ_DIRECT_SKIP           '],
[ amc$read_req                    , 'AMP$READ                       '],
[ amc$read_skip_req               , 'AMP$READ_SKIP                  '],
[ amc$replace_direct_req          , 'AMP$REPLACE_DIRECT             '],
[ amc$replace_key_req             , 'AMP$REPLACE_KEY                '],
[ amc$replace_req                 , 'AMP$REPLACE_PREVIOUS_RECORD    '],
[ amc$rewind_req                  , 'AMP$REWIND                     '],
[ amc$rewind_volume_req           , 'AMP$REWIND_VOLUME              '],
[ amc$seek_direct_req             , 'AMP$SEEK_DIRECT                '],
[ amc$select_key                  , 'AMP$SELECT_KEY                 '],
[ amc$select_nested_file          , 'AMP$SELECT_NESTED_FILE         '],
[ amc$separate_key_groups         , 'AMP$SEPARATE_KEY_GROUPS        '],
[ amc$set_segment_eoi_req         , 'AMP$SET_SEGMENT_EOI            '],
[ amc$set_segment_position_req    , 'AMP$SET_SEGMENT_POSITION       '],
[ amc$skip_req                    , 'AMP$SKIP                       '],
[ amc$start_req                   , 'AMP$START                      '],
[ amc$store_req                   , 'AMP$STORE                      '],
[ 175                             , bac$unused_request_table_entry],
[ amc$unlock_file_req             , 'AMP$UNLOCK_FILE                '],
[ amc$unlock_key                  , 'AMP$UNLOCK_KEY                 '],
[ amc$unpack_block_req            , 'AMP$UNPACK_BLOCK               '],
[ amc$unpack_record_req           , 'AMP$UNPACK_RECORD              '],
[ amc$user_defined_access_request , 'AMP$USER_DEFINED_ACCESS_REQUEST'],
[ amc$write_direct_req            , 'AMP$WRITE_DIRECT               '],
[ amc$write_end_partition_req     , 'AMP$WRITE_END_PARTITION        '],
[ amc$write_req                   , 'AMP$WRITE                      '],
[ amc$write_tape_mark_req         , 'AMP$WRITE_TAPE_MARK            '],
[ ifc$fetch_terminal_req          , 'IFP$FETCH_TERMINAL             '],
[ ifc$store_terminal_req          , 'IFP$STORE_TERMINAL             ']];

?? FMT (FORMAT := ON) ??

  VAR
    bav$request_name_table_ptr: [XDCL, #GATE, READ, oss$job_paged_literal]
          ^array [1 .. * ] of bat$request_name_table_entry :=
          ^bav$request_name_table;

?? EJECT ??
*copyc amh$set_local_name_abnormal
?? TITLE := 'PROCEDURE [XDCL, #GATE] amp$set_local_name_abnormal', EJECT ??

  PROCEDURE [XDCL, #GATE] amp$set_local_name_abnormal
    (    local_file_name: amt$local_file_name;
         condition: ost$status_condition;
         request_code: amt$last_operation;
         text: string ( * );
     VAR status: ost$status);

    CONST
      error_size = 4,
      error_text = '____';

    VAR
      name: amt$local_file_name,
      request_name: ost$name,
      valid_name: boolean;

    #keypoint (osk$entry, 0, amk$set_local_name_abnormal);

    clp$validate_name (local_file_name, name, valid_name);

    IF NOT valid_name THEN
      name := error_text;
    IFEND;

    IF (request_code >= LOWERBOUND (bav$request_name_table)) AND
          (request_code <= UPPERBOUND (bav$request_name_table)) AND
          (bav$request_name_table [request_code].name <>
          bac$unused_request_table_entry) THEN
      request_name := bav$request_name_table [request_code].name;
    ELSE
      request_name := osc$null_name;
    IFEND;

    set_local_name_abnormal (name, condition, request_name, text, status);

    #keypoint (osk$exit, 0, amk$set_local_name_abnormal);

  PROCEND amp$set_local_name_abnormal;

?? EJECT ??
*copyc bah$set_local_name_abnormal
?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$set_local_name_abnormal', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$set_local_name_abnormal
    (    local_file_name: amt$local_file_name;
         condition: ost$status_condition;
         request_name: string ( * <= osc$max_name_size);
         text: string ( * );
     VAR status: ost$status);

    VAR
      name: amt$local_file_name;

    #keypoint (osk$entry, 0, amk$set_local_name_abnormal);

    #translate (osv$lower_to_upper, local_file_name, name);

    set_local_name_abnormal (name, condition, request_name, text, status);

    #keypoint (osk$exit, 0, amk$set_local_name_abnormal);

  PROCEND bap$set_local_name_abnormal;

?? TITLE := 'PROCEDURE [INLINE] set_local_name_abnormal', EJECT ??

  PROCEDURE [INLINE] set_local_name_abnormal
    (    local_file_name: amt$local_file_name;
         condition: ost$status_condition;
         request_name: string ( * <= osc$max_name_size);
         text: string ( * );
     VAR status: ost$status);

    CONST
      error_size = 4,
      error_text = '____';

    VAR
      status_text: string (osc$max_string_size),
      status_text_index: ost$string_index,
      text_length: ost$string_size;

{LOCAL FILE NAME
    text_length := clp$trimmed_string_size (local_file_name);
    status_text (1, text_length) := local_file_name (1, text_length);

{REQUEST NAME
    status_text_index := text_length + 1;
    status_text (status_text_index) := osc$status_parameter_delimiter;
    IF request_name = osc$null_name THEN
      text_length := error_size;
      status_text (status_text_index + 1, text_length) := error_text;
    ELSE
      text_length := clp$trimmed_string_size (request_name);
      IF text_length > osc$max_name_size THEN
        text_length := osc$max_name_size;
      IFEND;
      status_text (status_text_index + 1, text_length) :=
            request_name (1, text_length);
    IFEND;

{Fill in null parameters for access level, file organization, record type,
{block type, & the error position}
    status_text_index := status_text_index + text_length + 1;
    status_text (status_text_index) := osc$status_parameter_delimiter;
    status_text (status_text_index + 1) := osc$status_parameter_delimiter;
    status_text (status_text_index + 2) := osc$status_parameter_delimiter;
    status_text (status_text_index + 3) := osc$status_parameter_delimiter;
    status_text (status_text_index + 4) := osc$status_parameter_delimiter;

{TEXT
    status_text_index := status_text_index + 5;
    status_text (status_text_index) := osc$status_parameter_delimiter;
    text_length := clp$trimmed_string_size (text);
    IF text_length > (osc$max_string_size - status_text_index) THEN
      text_length := (osc$max_string_size - status_text_index);
    IFEND;
    status_text (status_text_index + 1, text_length) :=
          text (1, text_length);

    osp$set_status_abnormal (amc$access_method_id, condition,
           status_text (1, status_text_index + text_length), status);

  PROCEND set_local_name_abnormal;

?? OLDTITLE ??

MODEND amm$set_local_name_abnormal;
*DECK DECK=AMM$SET_SEGMENT_EOI EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$set_segment_eoi;

{ MODULE DECK AMMSSE }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$SET_SEGMENT_EOI' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$SET_SEGMENT_EOI
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$set_segment_eoi ALIAS 'amxsete' (file_identifier:
    amt$file_identifier;
        segment_pointer: amt$segment_pointer;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$SET_SEGMENT_EOI',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$set_segment_eoi);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$set_segment_eoi);
      RETURN;
    IFEND;

    call_block.operation := amc$set_segment_eoi_req;
    call_block.segeoi.segment_pointer := segment_pointer;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$set_segment_eoi);
  PROCEND amp$set_segment_eoi;
MODEND amm$set_segment_eoi;
*DECK DECK=AMM$SET_SEGMENT_POSITION EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$set_segment_position;

{ MODULE DECK AMMSSP }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$SET_SEGMENT_POSITION' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$SET_SEGMENT_POSITION
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$set_segment_position ALIAS 'amxsetp'
    (file_identifier: amt$file_identifier;
        segment_pointer: amt$segment_pointer;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$SET_SEGMENT_POSITION',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$set_segment_position);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$set_segment_position);
      RETURN;
    IFEND;

    call_block.operation := amc$set_segment_position_req;
    call_block.segpos.segment_pointer := segment_pointer;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$set_segment_position);
  PROCEND amp$set_segment_position;
MODEND amm$set_segment_position;
*DECK DECK=AMM$SKIP EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$skip;

{ MODULE DECK AMMSKP }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$SKIP' ??
*IF NOT $true(osv$unix)
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc AMP$TERMINATE_FILE
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*IFEND
*copyc OSP$SET_STATUS_ABNORMAL
*IF NOT $true(osv$unix)
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$SKIP
?? EJECT ??
*ELSE
*copyc amt_c_whence
*copyc amt$file_identifier
*copyc amt$skip_direction
*copyc amt$skip_unit
*copyc amt$skip_count
*copyc amt$file_position
*copyc ame$improper_file_id
*copyc ame$improper_whence_value
*copyc ame$improper_skip_count
*copyc ame$improper_skip_direction
*copyc ame$improper_skip_option
*copyc ame$improper_skip_unit
*copyc ame$skip_encountered_eoi
*copyc amp_skip
*copyc clp$trimmed_string_size
*copyc osp$set_status_condition
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc ose$unix_system_error
*IFEND

  PROCEDURE [XDCL, #GATE] amp$skip ALIAS 'amxskip' (file_identifier:
    amt$file_identifier;
        direction: amt$skip_direction;
        unit: amt$skip_unit;
        count: amt$skip_count;
    VAR file_position: amt$file_position;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$SKIP',
      fap_layer_number = 0;

    VAR
*IF NOT $true(osv$unix)
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$skip);
    #caller_id (caller_id);
*ELSE
      file_pos: ost_c_integer,
      i: amt$skip_count,
      stat: integer,
      syserrlist_message: string (256);

*IFEND
    status.normal := TRUE;
*IF NOT $true(osv$unix)
    bam_status.normal := TRUE;
*IFEND

*copy BAI$VALIDATE_FILE_IDENTIFIER

*IF NOT $true(osv$unix)
    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$skip);
      RETURN;
    IFEND;

    amp$terminate_file (file_identifier, file_instance^);

    call_block.operation := amc$skip_req;
    call_block.skp.direction := direction;
    call_block.skp.unit := unit;
    call_block.skp.count := count;
    call_block.skp.file_position := ^file_position;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$skip);
*ELSE
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Validate parameters

    IF direction <> amc$forward THEN
      osp$set_status_abnormal ('AM', ame$improper_skip_direction, interface_name, status);
      RETURN;
    IFEND;

    IF unit <> amc$skip_record THEN
      osp$set_status_abnormal ('AM', ame$improper_skip_unit, interface_name, status);
      RETURN;
    IFEND;

    IF (count < 0) OR (count > amc$file_byte_limit) THEN
      osp$set_status_abnormal ('AM', ame$improper_skip_count, interface_name, status);
      RETURN;
    IFEND;

    stat := 0;
    syserrlist_message := ' ';

    FOR i:= 1 to count DO
      amp_skip (file_identifier, file_pos, syserrlist_message, stat);
      IF stat <> 0 THEN
        osp$set_status_condition (ose$unix_system_error, status);
        osp$append_status_integer (osc$status_parameter_delimiter, stat, 10, FALSE,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'SKIP', status);
        IF syserrlist_message <> ' ' THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, syserrlist_message (1,
                clp$trimmed_string_size (syserrlist_message)), status);
        IFEND;
        RETURN;
      IFEND;

      CASE file_pos OF
      = 0 =
        file_position := amc$mid_record;
      = 1 =
        file_position := amc$eor;
      = 2 =
        file_position := amc$eoi;
      CASEND;

{ return error if encountered EOI before COUNT exhausted.

      IF (file_position = amc$eoi) AND (i < count) THEN
        osp$set_status_condition (ame$skip_encountered_eoi, status);
        RETURN;
      IFEND;
    FOREND;
*IFEND

  PROCEND amp$skip;

MODEND amm$skip;
*DECK DECK=AMM$SKIP_TAPE_MARKS EXPAND=TRUE

MODULE amm$skip_tape_marks;
?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc AMT$LOCAL_FILE_NAME
*copyc AMK$ACCESS_METHOD
*copyc AMD$OPERATION_DECLARATIONS
*copyc AMD$SKIP_DECLARATIONS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$DEVICE_CLASS_VALIDATION
*copyc ame$lfn_program_actions
*copyc AME$SKIP_VALIDATION_ERRORS
*copyc AME$WTMK_VALIDATION_ERRORS
*copyc AME$SKIP_PROGRAM_ACTIONS
*copyc ame$tape_program_actions
*copyc CLP$VALIDATE_NAME
*copyc CLE$ECC_LEXICAL
*copyc fst$file_reference
*copyc OST$STATUS
*copyc OSP$SET_STATUS_ABNORMAL
?? SET (LIST := ON) ??
?? OLDTITLE ??
?? NEWTITLE := 'XREF Declarations ' ??
*copyc AMP$GET_FILE_ATTRIBUTES
*copyc amp$skip
*copyc amv$nil_file_identifier
*copyc fsp$close_file
*copyc fsp$evaluate_file_reference
*copyc fsp$open_file
*copyc fsp$set_evaluated_file_abnormal
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
*copyc RMP$GET_DEVICE_CLASS
?? TITLE := 'PROCEDURE AMP$SKIP_TAPE_MARKS ' ??
?? EJECT ??
*copyc AMH$SKIP_TAPE_MARKS
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$skip_tape_marks (
        file: fst$file_reference;
        direction: amt$skip_direction;
        count: amt$tape_mark_count;
    VAR status: ost$status);

    VAR
      bam_status: ost$status,
      contains_data: boolean,
      device_assigned: boolean,
      device_class: rmt$device_class,
      file_attachment: array [1 .. 2] of fst$attachment_option,
      file_attr: array [1 .. 2] of amt$get_item,
      file_exists: boolean,
      file_id: amt$file_identifier,
      file_position: amt$file_position,
      file_previously_opened: boolean;

?? EJECT ??
  PROCEDURE process_error (
        file: fst$file_reference;
        exception_condition: ost$status_condition;
        request_code: amt$last_operation;
        text: string ( * <= osc$max_string_size);
    VAR status: ost$status);

    VAR
      evaluated_file_reference: fst$evaluated_file_reference;

    fsp$evaluate_file_reference (file, TRUE, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$set_evaluated_file_abnormal (evaluated_file_reference, exception_condition,
          request_code, text, status);

  PROCEND process_error;





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

    IF file_id <> amv$nil_file_identifier THEN
      fsp$close_file (file_id, handler_status);
    IFEND;
    handler_status.normal := TRUE;

  PROCEND abort_handler;
?? EJECT ??
    #keypoint (osk$entry, 0, amk$skip_tape_marks);

    status.normal := TRUE;

    IF (direction < LOWERVALUE (amt$skip_direction)) OR (direction > UPPERVALUE (amt$skip_direction)) THEN
      process_error (file, ame$improper_skip_direction, amc$skip_tape_marks_req,
            'AMP$SKIP_TAPE_MARKS', status);
      #keypoint (osk$exit, 0, amk$skip_tape_marks);
      RETURN;
    IFEND;

    IF (count < LOWERVALUE (amt$tape_mark_count)) OR (count > UPPERVALUE (amt$tape_mark_count)) THEN
      process_error (file, ame$improper_skip_count, amc$skip_tape_marks_req,
            'AMP$SKIP_TAPE_MARKS', status);
      #keypoint (osk$exit, 0, amk$skip_tape_marks);
      RETURN;
    IFEND;


    file_attr [1].key := amc$global_access_mode;
    file_attr [2].key := amc$label_type;

    amp$get_file_attributes (file, file_attr, file_exists, file_previously_opened,
          contains_data, status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, 0, amk$skip_tape_marks);
      RETURN;
    IFEND;

    IF NOT file_exists THEN
      process_error (file, ame$file_not_known,
            amc$skip_tape_marks_req, ' ', status);
      #keypoint (osk$exit, 0, amk$skip_tape_marks);
      RETURN;
    IFEND;

    rmp$get_device_class (file, device_assigned, device_class, status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, 0, amk$skip_tape_marks);
      RETURN;
    IFEND;

    IF device_class <> rmc$magnetic_tape_device THEN
      process_error (file, ame$improper_device_class,
            amc$skip_tape_marks_req, 'MASS_STORAGE/NULL/TERMINAL', status);
      #keypoint (osk$exit, 0, amk$skip_tape_marks);
      RETURN;
    IFEND;

    IF file_attr [2].label_type = amc$labelled THEN
      process_error (file, ame$improper_labelled_skip_unit,
            amc$skip_tape_marks_req, ' ', status);
      #keypoint (osk$exit, 0, amk$skip_tape_marks);
      RETURN;
    IFEND;

    IF NOT (pfc$read IN file_attr [1].global_access_mode) THEN
      process_error (file, ame$skip_requires_read_perm,
            amc$skip_tape_marks_req, ' ', status);
      #keypoint (osk$exit, 0, amk$skip_tape_marks);
      RETURN;
    IFEND;

    file_attachment [1].selector := fsc$create_file;
    file_attachment [1].create_file := FALSE;
    file_attachment [2].selector := fsc$open_position;
    file_attachment [2].open_position := amc$open_no_positioning;
    file_id := amv$nil_file_identifier;

    osp$establish_block_exit_hndlr (^abort_handler);

    fsp$open_file (file, amc$record, ^file_attachment, NIL, NIL, NIL, NIL,
          file_id, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      #keypoint (osk$exit, 0, amk$skip_tape_marks);
      RETURN;
    IFEND;

    amp$skip (file_id, direction, amc$skip_tape_mark, count, file_position, bam_status);

    fsp$close_file (file_id, status);
    IF NOT bam_status.normal THEN
      status := bam_status;
    IFEND;

    osp$disestablish_cond_handler;

    #keypoint (osk$exit, 0, amk$skip_tape_marks);
  PROCEND amp$skip_tape_marks;
MODEND amm$skip_tape_marks;
*DECK DECK=AMM$START EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$start;

{ MODULE DECK AMMSTA }

?? TITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$START' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
*copyc AMK$ACCESS_METHOD
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$start (file_identifier: amt$file_identifier;
        key_location: ^cell;
        major_key_length: amt$major_key_length;
        key_relation: amt$key_relation;
    VAR file_position: amt$file_position;
        wait: ost$wait;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$START',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$start);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$start);
      RETURN;
    IFEND;

    call_block.operation := amc$start_req;
    call_block.start.key_location := key_location;
    call_block.start.major_key_length := major_key_length;
    call_block.start.key_relation := key_relation;
    call_block.start.file_position := ^file_position;
    call_block.start.wait := wait;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$start);
  PROCEND amp$start;
MODEND amm$start;
*DECK DECK=AMM$STORE EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$store;

{ MODULE DECK AMMSTR }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$STORE' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$STORE
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$store ALIAS 'amxstor' (file_identifier:
    amt$file_identifier;
        file_attributes: amt$store_attributes;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$STORE',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry,
      store_attributes: ^amt$store_attributes;


    #keypoint (osk$entry, 0, amk$store);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$store);
      RETURN;
    IFEND;

    call_block.operation := amc$store_req;

    PUSH store_attributes: [LOWERBOUND (file_attributes) .. UPPERBOUND
          (file_attributes)];
    store_attributes^ := file_attributes;
    call_block.store.file_attributes := store_attributes;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$store);
  PROCEND amp$store;
MODEND amm$store;
*DECK DECK=AMM$STORE_FAP_POINTER EXPAND=TRUE
*copy osd$default_pragmats
MODULE amm$store_fap_pointer;

?? TITLE := 'NOS/VE : BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$STORE_FAP_PPOINTER' ??
?? NEWTITLE := '  RING BRACKETS 23D' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amk$access_method
*copyc amt$fap_declarations
*copyc ame$fap_validation_errors
*copyc ame$improper_file_id
*copyc ame$ring_validation_errors
*copyc ost$caller_identifier
*copyc ost$status
*copyc ost$name
?? POP ??

*copyc amh$also
*copyc amh$store_fap_pointer
*copyc amp$set_file_instance_abnormal
*copyc bap$validate_file_identifier
*copyc osp$copy_local_status_to_status
*copyc osp$set_status_abnormal

  PROCEDURE [XDCL, #GATE] amp$store_fap_pointer
    (    file_identifier: amt$file_identifier;
         layer_number: amt$fap_layer_number;
         structure_pointer: ^cell;
     VAR status: ost$status);

    CONST
      interface_name = 'AMP$STORE_FAP_POINTER';

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      layer: ^bat$fap_descriptor;

    bam_status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, amk$store_fap_pointer);
    #CALLER_ID (caller_id);

    bap$validate_file_identifier (file_identifier, file_instance,
          file_id_is_valid);

    IF file_id_is_valid THEN

*copyc bai$get_fap_layer

      IF bam_status.normal THEN
        IF caller_id.ring <= layer^.loaded_ring THEN
          IF layer^.structure_pointer = NIL THEN
            layer^.structure_pointer := structure_pointer;
          ELSE
            amp$set_file_instance_abnormal (file_identifier,
                  ame$redundant_structure_pointer, amc$store_fap_pointer_req,
                  interface_name, bam_status);
          IFEND;
        ELSE
          amp$set_file_instance_abnormal (file_identifier,
                ame$ring_validation_error, amc$store_fap_pointer_req, ' ',
                bam_status);
        IFEND;
      IFEND;
    ELSE
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, bam_status);
    IFEND;

    osp$copy_local_status_to_status (bam_status, status);

    #KEYPOINT (osk$exit, 0, amk$store_fap_pointer);

  PROCEND amp$store_fap_pointer;

MODEND amm$store_fap_pointer;
*DECK DECK=AMM$TABLES EXPAND=TRUE
MODULE amm$tables;
?? TITLE := 'NOS/VE :  Basic Access Method', EJECT ??
?? NEWTITLE := '  [XDCL] COMMON VARIABLE DECLARATIONS' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$access_level
*copyc amt$access_level_name
*copyc amt$block_type
*copyc amt$block_type_name
*copyc amt$device_class_name
*copyc amd$file_attributes
*copyc amt$file_organization
*copyc amt$file_organization_name
*copyc amt$file_organization_set
*copyc amt$record_type
*copyc amt$record_type_name
*copyc amt$usage_option_name
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc pfd$permanent_file_attributes
*copyc rmt$device_class
?? POP ??
?? NEWTITLE := '[XDCL] amv$access_mode', EJECT ??

  VAR
    amv$access_mode: [STATIC, READ, XDCL, oss$job_paged_literal]
          pft$usage_selections := [pfc$read, pfc$shorten, pfc$append,
          pfc$modify, pfc$execute];

?? TITLE := '[XDCL] amv$label_options', EJECT ??

  VAR
    amv$label_options: [STATIC, READ, XDCL, oss$job_paged_literal]
          amt$label_options := [amc$vol1, amc$uvl, amc$hdr1, amc$hdr2,
          amc$eov1, amc$eov2, amc$uhl, amc$eof1, amc$eof2, amc$utl];

?? TITLE := '[XDCL] amv$valid_ring', EJECT ??

  VAR
    amv$valid_ring: [STATIC, READ, XDCL, oss$job_paged_literal] set of
          ost$valid_ring := [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
          15];

?? TITLE := '[XDCL] amv$message_control', EJECT ??

  VAR
    amv$message_control: [STATIC, READ, XDCL, oss$job_paged_literal]
          amt$message_control := [amc$trivial_errors, amc$messages,
          amc$statistics];

?? TITLE := '[XDCL, #GATE] amv$aam_file_organizations', EJECT ??

  VAR
    amv$aam_file_organizations: [XDCL, #GATE, READ, oss$job_paged_literal]
          amt$file_organization_set := $amt$file_organization_set
          [amc$indexed_sequential, amc$direct_access, amc$system_key];

?? TITLE := '[XDCL, #GATE] amv$access_level_names', EJECT ??

  VAR
    amv$access_level_names: [XDCL, #GATE, READ,
          oss$job_paged_literal] array [amt$access_level] of
          amt$access_level_name := [['PHYSICAL', 8], ['RECORD', 6],
          ['SEGMENT', 7]];

?? TITLE := '[XDCL, #GATE] amv$block_type_names', EJECT ??

  VAR
    amv$block_type_names: [XDCL, #GATE, READ,
          oss$job_paged_literal] array [amt$block_type] of
          amt$block_type_name := [['SYSTEM SPECIFIED (SS)', 21],
          ['USER SPECIFIED (US)', 19]];

?? TITLE := '[XDCL, #GATE] bav$device_class_names', EJECT ??

  VAR
    amv$device_class_names: [XDCL, #GATE, READ,
          oss$job_paged_literal] array [rmt$device_class] of
          amt$device_class_name := [['CONNECTED FILE DEVICE', 21],
          ['INTERSTATE LINK DEVICE', 22], ['LOCAL QUEUE DEVICE', 18],
          ['LOG DEVICE', 10], ['MAGNETIC TAPE DEVICE', 20],
          ['MASS STORAGE DEVICE', 19], ['MEMORY RESIDENT DEVICE', 22],
          ['NETWORK DEVICE', 14], ['NULL DEVICE', 11], ['PIPELINE DEVICE', 15],
          ['RHFAM DEVICE', 12], ['TERMINAL DEVICE', 15]];

?? TITLE := '[XDCL, #GATE] amv$file_organization_names', EJECT ??

  VAR
    amv$file_organization_names: [XDCL, #GATE, READ, oss$job_paged_literal]
          array [amt$file_organization] of amt$file_organization_name :=
          [['SEQUENTIAL', 10], ['BYTE ADDRESSABLE', 16],
          ['INDEXED SEQUENTIAL', 18], ['DIRECT ACCESS', 13],
          ['SYSTEM KEY', 10]];

?? TITLE := '[XDCL, #GATE] amv$record_type_names', EJECT ??

  VAR
    amv$record_type_names: [XDCL, #GATE, READ,
          oss$job_paged_literal] array [amt$record_type] of
          amt$record_type_name := [['VARIABLE (V)', 12], ['UNDEFINED (U)', 13],
          ['ANSI FIXED (F)', 14], ['ANSI SPANNED (S)', 16],
          ['ANSI VARIABLE (D)', 17], ['TRAILING CHARACTER DELIMITED (T)', 32]];

?? TITLE := '[XDCL, #GATE] amv$usage_option_names', EJECT ??

  VAR
    amv$usage_option_names: [XDCL, #GATE, READ,
          oss$job_paged_literal] array [pft$usage_options] of
          amt$usage_option_name := [['READ', 4], ['SHORTEN', 7], ['APPEND', 6],
          ['MODIFY', 6], ['EXECUTE', 7]];

?? OLDTITLE ??

MODEND amm$tables;




*DECK DECK=AMM$TEST_OUTPUT_AIDS EXPAND=TRUE
?? SET (LISTCTS := OFF) ??
MODULE amm$test_output_aids;

*copyc AMT$FAP_DECLARATIONS
*copyc AMT$FILE_ATTRIBUTES
*copyc AMT$GET_ATTRIBUTES
*copyc AMT$FETCH_ATTRIBUTES
*copyc AMT$ACCESS_INFORMATION
*copyc CLP$PUT_JOB_OUTPUT
*copyc OST$STATUS

?? TITLE := 'PROCEDURE [XDCL, #GATE] amp$tst_fid_out ' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$tst_fid_out (identifier: string (15);
        fid: amt$file_identifier;
    VAR status: ost$status);

    VAR
      out_string: string (80),
      len: integer;

    status.normal := TRUE;
    out_string := identifier;
    out_string (17, 14) := 'fid.ordinal = ';
    STRINGREP (out_string (31, 10), len, fid.ordinal);
    out_string (43, 15) := 'fid.sequence = ';
    STRINGREP (out_string (58, 10), len, fid.sequence);
    clp$put_job_output (out_string, status);

  PROCEND amp$tst_fid_out;
?? TITLE := 'PROCEDURE [XDCL, #GATE] amp$tst_status_out' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$tst_status_out (identifier: string (15);
        status_out: ost$status;
    VAR status: ost$status);
?? SET (LIST := OFF) ??
*copy OSP$FORMAT_MESSAGE
*copy OSP$APPEND_STATUS_PARAMETER
?? SET (LIST := ON) ??

    CONST
      status_is_normal = 'STATUS IS NORMAL';

    VAR
      delimeter: char,
      stat: ost$status,
      out_string: ost$string;

    status.normal := TRUE;
    delimeter := ' ';
    stat := status_out;
    IF stat.normal THEN
      out_string.value (1, 16) := status_is_normal;
      out_string.size := 16;
    ELSE
      out_string := stat.text;
    IFEND;
    clp$put_job_output (out_string.value (1, out_string.size), status);

  PROCEND amp$tst_status_out;
?? TITLE := 'PROCEDURE [XDCL, #GATE] amp$tst_putn_out' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$tst_putn_out (id: string (15);
        fid: amt$file_identifier;
        wsl: amt$working_storage_length;
        byte_address: amt$file_byte_address;
    VAR status: ost$status);
?? SET (LIST := OFF) ??
*copy AMP$TST_FID_OUT
*copy AMP$TST_BA_OUT
*copy AMP$TST_WSL_OUT
?? SET (LIST := ON) ??
    status.normal := TRUE;
    amp$tst_fid_out (id, fid, status);
    amp$tst_wsl_out (id, wsl, status);
    amp$tst_ba_out (id, byte_address, status);
  PROCEND amp$tst_putn_out;
?? TITLE := 'PROCEDURE [XDCL, #GATE] amp$tst_getn_out' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$tst_getn_out (id: string (15);
        fid: amt$file_identifier;
        wsl: amt$working_storage_length;
        record_length: amt$max_record_length;
        transfer_count: amt$transfer_count;
        byte_address: amt$file_byte_address;
        file_position: amt$file_position;
    VAR status: ost$status);
?? SET (LIST := OFF) ??
*copy AMP$TST_FID_OUT
*copy AMP$TST_RL_OUT
*copy AMP$TST_TC_OUT
*copy AMP$TST_BA_OUT
*copy AMP$TST_FP_OUT
*copy AMP$TST_WSL_OUT
?? SET (LIST := ON) ??
    status.normal := TRUE;
    amp$tst_fid_out (id, fid, status);
    amp$tst_wsl_out (id, wsl, status);
    amp$tst_rl_out (id, record_length, status);
    amp$tst_tc_out (id, transfer_count, status);
    amp$tst_ba_out (id, byte_address, status);
    amp$tst_fp_out (id, file_position, status);
  PROCEND amp$tst_getn_out;
?? TITLE := 'PROCEDURE [XDCL, #GATE] amp$tst_rl_out' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$tst_rl_out (id: string (15);
        record_length: amt$max_record_length;
    VAR status: ost$status);

    VAR
      out_string: string (80),
      len: integer;

    status.normal := TRUE;
    out_string := id;
    out_string (17, 16) := 'record_length =';
    STRINGREP (out_string (33, 10), len, record_length);
    clp$put_job_output (out_string, status);
  PROCEND amp$tst_rl_out;
?? TITLE := 'PROCEDURE [XDCL, #GATE] amp$tst_tc_out' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$tst_tc_out (id: string (15);
        transfer_count: amt$transfer_count;
    VAR status: ost$status);

    VAR
      out_string: string (80),
      len: integer;

    status.normal := TRUE;
    out_string := id;
    out_string (17, 17) := 'transfer_count = ';
    STRINGREP (out_string (34, 10), len, transfer_count);
    clp$put_job_output (out_string, status);
  PROCEND amp$tst_tc_out;
?? TITLE := 'PROCEDURE [XDCL, #GATE] amp$tst_ba_out' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$tst_ba_out (id: string (15);
        byte_address: amt$file_byte_address;
    VAR status: ost$status);

    VAR
      out_string: string (80),
      len: integer;

    status.normal := TRUE;
    out_string := id;
    out_string (17, 15) := 'byte_address = ';
    STRINGREP (out_string (32, 10), len, byte_address);
    clp$put_job_output (out_string, status);
  PROCEND amp$tst_ba_out;
?? TITLE := 'PROCEDURE [XDCL, #GATE] amp$tst_fp_out' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$tst_fp_out (id: string (15);
        file_position: amt$file_position;
    VAR status: ost$status);

    VAR
      out_string: string (80);

    status.normal := TRUE;
    out_string := id;
    out_string (17, 16) := 'file_position = ';
    CASE file_position OF
    = amc$boi =
      out_string (33, 7) := 'amc$boi';
    = amc$bop =
      out_string (33, 7) := 'amc$bop';
    = amc$mid_record =
      out_string (33, 14) := 'amc$mid_record';
    = amc$eor =
      out_string (33, 7) := 'amc$eor';
    = amc$eop =
      out_string (33, 7) := 'amc$eop';
    = amc$eoi =
      out_string (33, 7) := 'amc$eoi';
    ELSE
      out_string (33, 15) := 'unknown ordinal';
    CASEND;
    clp$put_job_output (out_string, status);
  PROCEND amp$tst_fp_out;
?? TITLE := 'PROCEDURE [XDCL, #GATE] amp$tst_wsl_out' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$tst_wsl_out (id: string (15);
        wsl: amt$working_storage_length;
    VAR status: ost$status);

    VAR
      out_string: string (80),
      len: integer;

    status.normal := TRUE;
    out_string := id;
    out_string (17, 6) := 'wsl = ';
    STRINGREP (out_string (23, 10), len, wsl);
    clp$put_job_output (out_string, status);
  PROCEND amp$tst_wsl_out;

?? TITLE := 'PROCEDURE [XDCL, #GATE] amp$tst_rec_type_out' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$tst_rec_type_out (id: string (15);
        record_type: amt$record_type;
    VAR status: ost$status);

    VAR
      out_string: string (80),
      len: integer;

    status.normal := TRUE;
    out_string := id;
    out_string (17, 14) := 'record type =';
    CASE record_type OF
    = amc$variable =
      out_string (33, 12) := 'amc$variable';
    = amc$undefined =
      out_string (33, 13) := 'amc$undefined';
    = amc$ansi_fixed =
      out_string (33, 14) := 'amc$ansi_fixed';
    = amc$ansi_spanned =
      out_string (33, 16) := 'amc$ansi_spanned';
    = amc$ansi_variable =
      out_string (33, 17) := 'amc$ansi_variable';
    ELSE
      out_string (33, 23) := 'UNKNOWN! ordinal is =';
      STRINGREP (out_string (58, 10), len, record_type);
    CASEND;
    clp$put_job_output (out_string, status);
  PROCEND amp$tst_rec_type_out;

  PROCEDURE [XDCL, #GATE] amp$tst_source_out (source: amt$attribute_source;
    VAR status: ost$status);

    VAR
      out_string: string (80);

    out_string := '                                                           '
      CAT '                     ';
    out_string (17, 19) := 'attribute source = ';

    CASE source OF
    = amc$undefined_attribute =
      out_string (19, 9) := 'UNDEFINED';
    = amc$file_command =
      out_string (19, 12) := 'FILE COMMAND';
    = amc$file_request =
      out_string (19, 12) := 'FILE REQUEST';
    = amc$access_method_default =
      out_string (19, 21) := 'ACCESS METHOD DEFAULT';
    = amc$add_to_file_description =
      out_string (19, 23) := 'add_to_file_description';
    = amc$open_request =
      out_string (19, 12) := 'open_request';
    = amc$store_request =
      out_string (19, 13) := 'STORE REQUEST';
    CASEND;

    clp$put_job_output (out_string, status);
  PROCEND amp$tst_source_out;
?? TITLE := 'Procedure [xdcl]  amp$tst_file_attr_out' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$tst_file_attr_out (id: string (15);
        fa: amt$get_attributes;
    VAR status: ost$status);

    VAR
      i: integer,
      out_string: string (80),
      len: integer,
      stat: ost$status;

    status.normal := TRUE;
    stat.normal := TRUE;
    out_string := id;
    out_string (17, 50) :=
      '                                                  ';

    FOR i := LOWERBOUND (fa) TO UPPERBOUND (fa) DO
      out_string (17, 63) :=
        '                                                               ';
      CASE fa [i].key OF
      = amc$access_mode =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 14) := 'access_mode = ';
          IF pfc$read IN fa [i].access_mode THEN
            out_string (31, 8) := 'PFC$READ';
            clp$put_job_output (out_string, stat);
          IFEND;
          IF pfc$shorten IN fa [i].access_mode THEN
            out_string (31, 11) := 'PFC$SHORTEN';
            clp$put_job_output (out_string, stat);
          IFEND;
          IF pfc$append IN fa [i].access_mode THEN
            out_string (31, 10) := 'PFC$APPEND';
            clp$put_job_output (out_string, stat);
          IFEND;
          IF pfc$modify IN fa [i].access_mode THEN
            out_string (31, 10) := 'PFC$MODIFY';
            clp$put_job_output (out_string, stat);
          IFEND;
          IF pfc$execute IN fa [i].access_mode THEN
            out_string (31, 11) := 'PFC$EXECUTE';
            clp$put_job_output (out_string, stat);
          IFEND;
          out_string (17, 25) := '                         ';
        IFEND;

      = amc$block_type =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 13) := 'block_type = ';
          CASE fa [i].block_type OF
          = amc$system_specified =
            out_string (30, 20) := 'AMC$SYSTEM_SPECIFIED';
          = amc$user_specified =
            out_string (30, 18) := 'AMC$USER_SPECIFIED';
          CASEND;

        IFEND;

      = amc$character_conversion =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 23) := 'character_conversion = ';
          CASE fa [i].character_conversion OF
          = TRUE =
            out_string (30, 4) := 'TRUE';
          = FALSE =
            out_string (30, 5) := 'FALSE';
          CASEND;
        IFEND;

      = amc$clear_space =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 14) := 'clear_space = ';
          CASE fa [i].clear_space OF
          = TRUE =
            out_string (31, 4) := 'TRUE';
          = FALSE =
            out_string (31, 5) := 'FALSE';
          CASEND;
        IFEND;

      = amc$error_exit_procedure =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 23) := 'error_exit_procedure = ';
        IFEND;

      = amc$error_options =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 16) := 'error_options = ';
          CASE fa [i].error_options OF
          = amc$terminate_file =
            out_string (33, 18) := 'AMC$TERMINATE_FILE';
          = amc$drop_block =
            out_string (33, 14) := 'AMC$DROP_BLOCK';
          = amc$accept_record =
            out_string (33, 17) := 'AMC$ACCEPT_RECORD';
          CASEND;
        IFEND;

      = amc$file_access_procedure =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 25) := 'file_access_procedure = ';
          out_string (42, 31) := fa [i].file_access_procedure;
        IFEND;

      = amc$file_contents =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 16) := 'file_contents = ';
          out_string (33, 31) := fa [i].file_contents;
        IFEND;

      = amc$file_length =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 14) := 'file_length = ';
          STRINGREP (out_string (31, 10), len, fa [i].file_length);
        IFEND;

      = amc$file_limit =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 13) := 'file_limit = ';
          STRINGREP (out_string (30, 10), len, fa [i].file_limit);
        IFEND;


      = amc$file_organization =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 20) := 'file_organization = ';
          CASE fa [i].file_organization OF
          = amc$sequential =
            out_string (37, 14) := 'AMC$SEQUENTIAL';
          = amc$byte_addressable =
            out_string (37, 20) := 'AMC$BYTE_ADDRESSABLE';
          = amc$indexed_sequential =
            out_string (37, 22) := 'AMC$INDEXED_SEQUENTIAL';
          CASEND;
        IFEND;

      = amc$file_processor =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 17) := 'file_processor = ';
          out_string (34, 31) := fa [i].file_processor;
        IFEND;

      = amc$file_structure =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 17) := 'file_structure = ';
          out_string (34, 31) := fa [i].file_structure;
        ELSE
          out_string (17, 40) := '                                        ';
        IFEND;

      = amc$forced_write =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 15) := 'forced_write = ';
          CASE fa [i].forced_write OF
          = amc$forced =
            out_string (32, 10) := 'AMC$FORCED';
          = amc$forced_if_structure_change =
            out_string (32, 29) := 'AMC$FORCED_IF_STRUCTURE_CHANGE';
          = amc$unforced =
            out_string (32, 12) := 'AMC$UNFORCED';
          CASEND;
        ELSE
          out_string (17, 40) := '                                        ';
        IFEND;
      = amc$global_access_mode =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 21) := 'global_access_mode = ';
          IF pfc$read IN fa [i].global_access_mode THEN
            out_string (38, 8) := 'PFC$READ';
            clp$put_job_output (out_string, status);
          IFEND;
          IF pfc$shorten IN fa [i].global_access_mode THEN
            out_string (38, 11) := 'PFC$SHORTEN';
            clp$put_job_output (out_string, status);
          IFEND;
          IF pfc$append IN fa [i].global_access_mode THEN
            out_string (38, 11) := 'PFC$APPEND ';
            clp$put_job_output (out_string, status);
          IFEND;
          IF pfc$modify IN fa [i].global_access_mode THEN
            out_string (38, 11) := 'PFC$MODIFY ';
            clp$put_job_output (out_string, stat);
          IFEND;
          IF pfc$execute IN fa [i].global_access_mode THEN
            out_string (38, 11) := 'PFC$EXECUTE';
            clp$put_job_output (out_string, stat);
          IFEND;
          out_string (17, 32) := '                               ';
        IFEND;
      = amc$global_file_name =
        amp$tst_source_out (fa [i].source, stat);
      = amc$global_file_position =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 23) := 'global_file_position = ';
          CASE fa [i].global_file_position OF
          = amc$boi =
            out_string (40, 7) := 'AMC$BOI';
          = amc$bop =
            out_string (40, 7) := 'AMC$BOP';
          = amc$mid_record =
            out_string (40, 14) := 'AMC$MID_RECORD';
          = amc$eor =
            out_string (40, 7) := 'AMC$EOR';
          = amc$eop =
            out_string (40, 7) := 'AMC$EOP';
          = amc$eoi =
            out_string (40, 7) := 'AMC$EOI';
          ELSE
            out_string (40, 21) := 'INVALID FILE POSITION';
          CASEND;
        IFEND;
      = amc$global_share_mode =
        amp$tst_source_out (fa [i].source, stat);
      = amc$internal_code =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 16) := 'internal_code = ';
          CASE fa [i].internal_code OF
          = amc$as6 =
            out_string (33, 7) := 'AMC$AS6';
          = amc$as8 =
            out_string (33, 7) := 'AMC$AS8';
          = amc$ascii =
            out_string (33, 9) := 'AMC$ASCII';
          = amc$d64 =
            out_string (33, 8) := 'AMC$D64';
          = amc$ebcdic =
            out_string (33, 10) := 'AMC$EBCDIC';
          = amc$bcd =
            out_string (33, 7) := 'AMC$BCD';
          = amc$ftam1_ia5 =
            out_string (33, 13) := 'AMC$FTAM1_IA5';
          = amc$ftam1_visible =
            out_string (33, 17) := 'AMC$FTAM1_VISIBLE';
          = amc$ftam1_graphic =
            out_string (33, 17) := 'AMC$FTAM1_GRAPHIC';
          = amc$ftam1_general =
            out_string (33, 17) := 'AMC$FTAM1_GENERAL';
          = amc$ftam2_ia5 =
            out_string (33, 13) := 'AMC$FTAM2_IA5';
          = amc$ftam2_visible =
            out_string (33, 17) := 'AMC$FTAM2_VISIBLE';
          = amc$ftam2_graphic =
            out_string (33, 17) := 'AMC$FTAM2_GRAPHIC';
          = amc$ftam2_general =
            out_string (33, 17) := 'AMC$FTAM2_GENERAL';
          ELSE
          CASEND;
        IFEND;
      = amc$label_exit_procedure =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 23) := 'label_exit_procedure = ';
        IFEND;
      = amc$label_options =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 16) := 'label_options = ';
        IFEND;
      = amc$label_type =
      = amc$line_number =
      = amc$max_block_length =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 19) := 'max_block_length = ';
          STRINGREP (out_string (36, 10), len, fa [i].max_block_length);
        IFEND;
      = amc$max_record_length =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 20) := 'max_record_length = ';
          STRINGREP (out_string (37, 10), len, fa [i].max_record_length);
        IFEND;
      = amc$min_block_length =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 19) := 'min_block_length = ';
          STRINGREP (out_string (36, 10), len, fa [i].min_block_length);
        IFEND;
      = amc$min_record_length =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 20) := 'min_record_length = ';
          STRINGREP (out_string (37, 10), len, fa [i].min_record_length);
        IFEND;
      = amc$open_position =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 16) := 'open_position = ';
          CASE fa [i].open_position OF
          = amc$open_no_positioning =
            out_string (33, 23) := 'AMC$OPEN_NO_POSITIONING';
          = amc$open_at_boi =
            out_string (33, 15) := 'AMC$OPEN_AT_BOI';
          = amc$open_at_bop =
            out_string (33, 15) := 'AMC$OPEN_AT_BOP';
          = amc$open_at_eoi =
            out_string (33, 15) := 'AMC$OPEN_AT_EOI';
          ELSE
          CASEND;
        IFEND;
      = amc$padding_character =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 20) := 'padding_character = ';
          STRINGREP (out_string (37, 1), len, fa [i].padding_character);
        IFEND;
      = amc$page_format =
      = amc$page_length =
      = amc$page_width =
      = amc$permanent_file =
      = amc$preset_value =
      = amc$record_type =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 14) := 'record_type = ';
          CASE fa [i].record_type OF
          = amc$variable =
            out_string (31, 12) := 'AMC$VARIABLE';
          = amc$undefined =
            out_string (31, 13) := 'AMC$UNDEFINED';
          = amc$ansi_fixed =
            out_string (31, 14) := 'AMC$ANSI_FIXED';
          = amc$ansi_spanned =
            out_string (31, 16) := 'AMC$ANSI_SPANNED';
          = amc$ansi_variable =
            out_string (31, 17) := 'AMC$ANSI_VARIABLE';
          ELSE
          CASEND;
        IFEND;
      = amc$return_option =
      = amc$ring_attributes =
      = amc$user_info =
        amp$tst_source_out (fa [i].source, stat);
        IF fa [i].source <> amc$undefined_attribute THEN
          out_string (17, 12) := 'user_info = ';
          out_string (29, 32) := fa [i].user_info;
        IFEND;
      ELSE
        out_string (17, 21) := 'UNKNOWN ATTRIBUTE KEY';
      CASEND;

      clp$put_job_output (out_string, status);
    FOREND;
  PROCEND amp$tst_file_attr_out;
?? TITLE := 'procedure [xdcl] amp$tst_access_info_out' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$tst_access_info_out (id: string (15);
        ai: amt$access_information;
    VAR status: ost$status);

    VAR
      len: integer,
      i: integer,
      out_string: string (80);

    out_string := id;

    FOR i := LOWERBOUND (ai) TO UPPERBOUND (ai) DO
      out_string (17, 63) :=
        '                                                               ';
      CASE ai [i].key OF
      = amc$block_number =
        IF ai [i].item_returned = TRUE THEN
          out_string (17, 15) := 'block_number = ';
          STRINGREP (out_string (30, 10), len, ai [i].block_number);
        ELSE
          out_string (17, 25) := 'block_number not returned';
        IFEND;

      = amc$current_byte_address =
        IF ai [i].item_returned = TRUE THEN
          out_string (17, 23) := 'current_byte_address = ';
          STRINGREP (out_string (40, 10), len, ai [i].current_byte_address);
        ELSE
          out_string (17, 36) := 'current_byte_address not returned';
        IFEND;
      = amc$eoi_byte_address =
        IF ai [i].item_returned = TRUE THEN
          out_string (17, 19) := 'eoi_byte_address = ';
          STRINGREP (out_string (36, 10), len, ai [i].eoi_byte_address);
        ELSE
          out_string (17, 28) := 'eoi_byte_address not returned';
        IFEND;
      = amc$error_count =
        IF ai [i].item_returned = TRUE THEN
          out_string (17, 14) := 'error_count = ';
          STRINGREP (out_string (31, 10), len, ai [i].error_count);
        ELSE
          out_string (17, 24) := 'error_count not returned';
        IFEND;
      = amc$error_status =
        IF ai [i].item_returned = TRUE THEN
          out_string (17, 15) := 'error_status = ';
          STRINGREP (out_string (32, 10), len, ai [i].error_status);
        ELSE
          out_string (17, 25) := 'error_status not returned';
        IFEND;
      = amc$file_position =
        IF ai [i].item_returned = TRUE THEN
          out_string (17, 16) := 'file_position = ';
          CASE ai [i].file_position OF
          = amc$boi =
            out_string (33, 7) := 'AMC$BOI';
          = amc$bop =
            out_string (33, 7) := 'AMC$BOP';
          = amc$mid_record =
            out_string (33, 10) := 'AMC$MID_RECORD';
          = amc$eor =
            out_string (33, 7) := 'AMC$EOR';
          = amc$eop =
            out_string (33, 7) := 'AMC$EOP';
          = amc$eoi =
            out_string (33, 7) := 'AMC$EOI';
          ELSE
          CASEND;
        IFEND;
      = amc$last_access_operation =
        IF ai [i].item_returned = TRUE THEN
          out_string (17, 24) := 'last_access_operation = ';
          CASE ai [i].last_access_operation OF
          = amc$close_req =
            out_string (41, 9) := 'CLOSE_REQ';
          = amc$fetch_req =
            out_string (41, 9) := 'FETCH_REQ';
          = amc$get_next_req =
            out_string (41, 12) := 'GET_NEXT_REQ';
          = amc$get_partial_req =
            out_string (41, 15) := 'GET_PARTIAL_REQ';
          = amc$get_segment_pointer_req =
            out_string (41, 16) := 'GET_SEGMENT_POINTER_REQ';
          = amc$open_req =
            out_string (41, 8) := 'OPEN_REQ';
          = amc$put_next_req =
            out_string (41, 12) := 'PUT_NEXT_REQ';
          = amc$put_partial_req =
            out_string (41, 15) := 'PUT_PARTIAL_REQ';
          = amc$rewind_req =
            out_string (41, 10) := 'REWIND_REQ';
          = amc$set_segment_eoi_req =
            out_string (41, 19) := 'SET_SEGMENT_EOI_REQ';
          = amc$set_segment_position_req =
            out_string (41, 24) := 'SET_SEGEMENT_POSITION_REQ';
          = amc$store_req =
            out_string (41, 9) := 'STORE_REQ';
          ELSE
          CASEND;
        IFEND;
      = amc$last_op_status =
        IF ai [i].item_returned = TRUE THEN
          out_string (17, 17) := 'last_op_statue = ';
          CASE ai [i].last_op_status OF
          = amc$active =
            out_string (34, 10) := 'AMC$ACTIVE';
          = amc$complete =
            out_string (34, 12) := 'AMC$COMPLETE';
          ELSE
          CASEND;
        IFEND;
      = amc$levels_of_indexing =
        IF ai [i].item_returned = TRUE THEN
          out_string (17, 21) := 'levels_of_indexing = ';
          STRINGREP (out_string (38, 10), len, ai [i].levels_of_indexing);
        IFEND;
      = amc$previous_record_length =
        IF ai [i].item_returned = TRUE THEN
          out_string (17, 25) := 'previous_record_length = ';
          STRINGREP (out_string (26, 10), len, ai [i].previous_record_length);
        IFEND;
      = amc$residual_skip_count =
        IF ai [i].item_returned = TRUE THEN
          out_string (17, 22) := 'residual_skip_count = ';
          STRINGREP (out_string (39, 10), len, ai [i].residual_skip_count);
        IFEND;
      = amc$volume_number =
        IF ai [i].item_returned = TRUE THEN
          out_string (17, 16) := 'volume_number = ';
          STRINGREP (out_string (33, 10), len, ai [i].volume_number);
        IFEND;
      ELSE
        out_string (17, 23) := 'invalid access info key';
      CASEND;

      clp$put_job_output (out_string, status);
    FOREND;
    status.normal := TRUE;
  PROCEND amp$tst_access_info_out;
?? TITLE := 'procedure amp$tst_offset_out' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$tst_offset_out (id: string (15);
        pva: ^cell;
    VAR status: ost$status);

    VAR
      len: integer,
      out_string: string (80),
      p: integer;


    out_string := id;

    p := #offset (pva);

    STRINGREP (out_string (17, 10), len, p);

    clp$put_job_output (out_string, status);
  PROCEND amp$tst_offset_out;
MODEND amm$test_output_aids;
*DECK DECK=AMM$TRACE_ROUTINES EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$trace_routines;
{
{  This module contains file access procedures, and error exit procedures
{ that allow obtaining a trace of file access for a particular file,
{ in a task.   All output is written to $am_trace, which may not have
{ one of these faps associated with it.  The following are available:
{ ERROR_EXIT_PROCEDURES:
{    (set_file_attributes een=    )
{ -  amp$full_table_eep_trace
{       Along with the error all of BAMs tables are displayed.
{ FILE_ACCESS_PROCEDURES:
{    (set_file_attributes fap=   )
{ -  amp$full_table_fap_trace
{        In addition to the call_block trace, all of bam tables are displayed
{        after each operation.
{ -  amp$trace_calls
{        Displays the operation that is occuring, and the ring.
{ -  amp$trace_call_blocks
{        Displays the operation, data input to the operation, and the result
{        of the operation.
{ -  amp$trace_timings
{        In addition to the call_block trace, provides data on timing of the
{        operation.
{

?? PUSH (LISTEXT := ON) ??
*copyc ame$improper_file_id
*copyc amt$display_tft_options
*copyc amt$fap_declarations
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc bat$display_tables_indention
*copyc cle$ecc_connected_file
*copyc clt$display_control
*copyc fmc$entry_assigned
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc ost$caller_identifier
*copyc ost$status
*copyc pfd$permanent_file_attributes
?? POP ??

*copyc amp$access_method
*copyc amp$put_next
*copyc bap$display_tft_entry
*copyc bap$validate_file_identifier
*copyc clp$get_fs_path_string
*copyc clp$convert_str_to_path_handle
*copyc fsp$close_file
*copyc fsp$open_file
*copyc i#current_sequence_position
*copyc osp$append_status_parameter
*copyc osp$format_message
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pmp$get_task_cp_time

*copyc amv$access_level_names
*copyc amv$block_type_names
*copyc amv$file_organization_names
*copyc amv$record_type_names
*copyc amv$usage_option_names
*copyc bav$file_positions
*copyc bav$task_file_table
*copyc bav$tft_entry_assignment
*copyc bav$request_name_table_ptr

  PROCEDURE [XREF] bap$fetch_trace_control
    (VAR trace_file_open: boolean;
     VAR trace_file_id: amt$file_identifier);

  PROCEDURE [XREF] bap$store_trace_control
    (    trace_file_open: boolean;
         trace_file_id: amt$file_identifier);

?? TITLE := 'setup_trace', EJECT ??

  PROCEDURE [INLINE] setup_trace
    (    file_identifier: amt$file_identifier;
     VAR trace_file_id: amt$file_identifier;
     VAR status: ost$status);

    CONST
      trace_file = ':$LOCAL.$AM_TRACE.1';

    VAR
      ba: amt$file_byte_address,
      evaluated_file_reference: fst$evaluated_file_reference,
      file_instance: ^bat$task_file_entry,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      path_handle_name: fst$path_handle_name,
      trace_file_attachment_options: array [1..5] of fst$attachment_option,
      trace_file_open: boolean,
      file_id_is_valid: boolean;

    status.normal := TRUE;

    bap$validate_file_identifier (file_identifier, file_instance,
          file_id_is_valid);
    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
         'AMM$TRACE_ROUTINES', status);
      RETURN;
    IFEND;

    bap$fetch_trace_control (trace_file_open, trace_file_id);

    IF NOT trace_file_open THEN

      clp$convert_str_to_path_handle (trace_file, {delete_allowed=} TRUE,
            {resolve_path=} TRUE, {include_open_position=} FALSE, path_handle_name,
            evaluated_file_reference, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF file_instance^.local_file_name = path_handle_name THEN
        osp$set_status_abnormal (amc$access_method_id,
              cle$circular_file_connection, file_instance^.local_file_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              file_instance^.local_file_name, status);
        RETURN;
      IFEND;

      trace_file_attachment_options [1].selector :=
            fsc$access_and_share_modes;
      trace_file_attachment_options [1].access_modes.selector :=
            fsc$specific_access_modes;
      trace_file_attachment_options [1].access_modes.value :=
            $fst$file_access_options
            [fsc$read, fsc$shorten, fsc$append, fsc$modify, fsc$execute];
      trace_file_attachment_options [1].share_modes.selector :=
            fsc$specific_share_modes;
      trace_file_attachment_options [1].share_modes.value :=
            $fst$file_access_options [];
      trace_file_attachment_options [2].selector := fsc$open_share_modes;
      trace_file_attachment_options [2].open_share_modes :=
            $fst$file_access_options
            [fsc$read, fsc$shorten, fsc$append, fsc$modify, fsc$execute];
      trace_file_attachment_options [3].selector := fsc$sequential_access;
      trace_file_attachment_options [3].sequential_access := TRUE;
      trace_file_attachment_options [4].selector := fsc$delete_data;
      trace_file_attachment_options [4].delete_data := FALSE;
      trace_file_attachment_options [5].selector := fsc$open_position;
      trace_file_attachment_options [5].open_position := amc$open_at_eoi;

      fsp$open_file (trace_file, amc$record,
            ^trace_file_attachment_options,
            NIL, NIL, NIL, NIL, trace_file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      trace_file_open := TRUE;
      bap$store_trace_control (trace_file_open, trace_file_id);

    IFEND;

  PROCEND setup_trace;

?? TITLE := 'close_trace', EJECT ??

  PROCEDURE [INLINE] close_trace
    (VAR trace_file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      trace_file_open: boolean;

    status.normal := TRUE;

    trace_file_open := FALSE;
    bap$store_trace_control (trace_file_open, trace_file_id);
    fsp$close_file (trace_file_id, status);

  PROCEND close_trace;


?? TITLE := '  amp$full_table_eep_trace', EJECT ??

  PROCEDURE [XDCL, #GATE] amp$full_table_eep_trace
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      trace_status: ost$status,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      ba: amt$file_byte_address,
      caller_id: ost$caller_identifier,
      trace_file_open: boolean,
      trace_file_id: amt$file_identifier;

    #CALLER_ID (caller_id);

    setup_trace (file_identifier, trace_file_id, trace_status);
    IF NOT trace_status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
            trace_status, ignore_status);
      RETURN;
    IFEND;

    output_status (trace_file_id, status, trace_status);
    IF NOT trace_status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
            trace_status, ignore_status);
    IFEND;

    bap$display_tft_entry (trace_file_id, file_identifier, trace_status);
    IF NOT trace_status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
            trace_status, ignore_status);
    IFEND;

    close_trace (trace_file_id, trace_status);
    IF NOT trace_status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
            trace_status, ignore_status);
    IFEND;

  PROCEND amp$full_table_eep_trace;

?? TITLE := 'amp$full_table_fap_trace', EJECT ??

  PROCEDURE [XDCL, #GATE] amp$full_table_fap_trace
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      trace_status: ost$status,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      ba: amt$file_byte_address,
      caller_id: ost$caller_identifier,
      trace_file_id: amt$file_identifier;

    #CALLER_ID (caller_id);
    status.normal := TRUE;

    setup_trace (file_identifier, trace_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_initial_line (file_identifier, call_block.operation, caller_id.ring,
          2 {indent}, trace_file_id, trace_status);
    IF NOT trace_status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
            trace_status, ignore_status);
    IFEND;

    amp$access_method (file_identifier, call_block, layer_number, status);
    IF NOT status.normal THEN
      output_status (trace_file_id, status, trace_status);
      IF NOT trace_status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
              trace_status, ignore_status);
      IFEND;
    IFEND;

    output_operation_info (call_block, file_identifier, 6 {indent},
          trace_file_id, trace_status);
    IF NOT trace_status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
            trace_status, ignore_status);
    IFEND;

    IF call_block.operation <> amc$close_req THEN
      bap$display_tft_entry (trace_file_id, file_identifier, trace_status);
      IF NOT trace_status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
              trace_status, ignore_status);
      IFEND;
    IFEND;

    IF (call_block.operation = amc$close_req) OR (NOT status.normal)
         OR (NOT trace_status.normal) THEN
      close_trace (trace_file_id, trace_status);
      IF NOT trace_status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
              trace_status, ignore_status);
      IFEND;
    IFEND;

  PROCEND amp$full_table_fap_trace;
?? TITLE := 'amp$trace_calls', EJECT ??

  PROCEDURE [XDCL, #GATE] amp$trace_calls
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      trace_status: ost$status,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      ba: amt$file_byte_address,
      caller_id: ost$caller_identifier,
      trace_file_id: amt$file_identifier;

    status.normal := TRUE;
    #CALLER_ID (caller_id);

    setup_trace (file_identifier, trace_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_initial_line (file_identifier, call_block.operation,
          caller_id.ring, 2 {indent}, trace_file_id, trace_status);
    IF NOT trace_status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
            trace_status, ignore_status);
    IFEND;

    amp$access_method (file_identifier, call_block, layer_number, status);
    IF NOT status.normal THEN
      output_status (trace_file_id, status, trace_status);
      IF NOT trace_status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
              trace_status, ignore_status);
      IFEND;
    IFEND;

    IF (call_block.operation = amc$close_req) OR (NOT status.normal)
         OR (NOT trace_status.normal) THEN
      close_trace (trace_file_id, trace_status);
      IF NOT trace_status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
              trace_status, ignore_status);
      IFEND;
    IFEND;

  PROCEND amp$trace_calls;

?? TITLE := 'amp$trace_call_blocks', EJECT ??

  PROCEDURE [XDCL, #GATE] amp$trace_call_blocks
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      trace_status: ost$status,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      ba: amt$file_byte_address,
      caller_id: ost$caller_identifier,
      trace_file_id: amt$file_identifier;

    #CALLER_ID (caller_id);
    status.normal := TRUE;

    setup_trace (file_identifier, trace_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_initial_line (file_identifier, call_block.operation, caller_id.ring,
          2 {indent}, trace_file_id, trace_status);
    IF NOT trace_status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
            trace_status, ignore_status);
    IFEND;

    amp$access_method (file_identifier, call_block, layer_number, status);
    IF NOT status.normal THEN
      output_status (trace_file_id, status, trace_status);
      IF NOT trace_status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
              trace_status, ignore_status);
      IFEND;
    IFEND;

    output_operation_info (call_block, file_identifier, 6 {indent},
          trace_file_id, trace_status);
    IF NOT trace_status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
            trace_status, ignore_status);
    IFEND;

    IF (call_block.operation = amc$close_req) OR (NOT status.normal)
         OR (NOT trace_status.normal) THEN
      close_trace (trace_file_id, trace_status);
      IF NOT trace_status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
              trace_status, ignore_status);
      IFEND;
    IFEND;

  PROCEND amp$trace_call_blocks;

?? TITLE := 'amp$trace_timings', EJECT ??

  PROCEDURE [XDCL, #GATE] amp$trace_timings
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      trace_status: ost$status,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      ba: amt$file_byte_address,
      caller_id: ost$caller_identifier,
      start_time: pmt$task_cp_time,
      stop_time: pmt$task_cp_time,
      trace_file_id: amt$file_identifier;

    #CALLER_ID (caller_id);
    status.normal := TRUE;

    setup_trace (file_identifier, trace_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_initial_line (file_identifier, call_block.operation, caller_id.ring,
          2 {indent}, trace_file_id, trace_status);
    IF NOT trace_status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
            trace_status, ignore_status);
    IFEND;

    pmp$get_task_cp_time (start_time, ignore_status);
    amp$access_method (file_identifier, call_block, layer_number, status);
    pmp$get_task_cp_time (stop_time, ignore_status);
    IF NOT status.normal THEN
      output_status (trace_file_id, status, trace_status);
      IF NOT trace_status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
              trace_status, ignore_status);
      IFEND;
    IFEND;

    output_operation_info (call_block, file_identifier, 6 {indent},
          trace_file_id, trace_status);
    IF NOT trace_status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
            trace_status, ignore_status);
    IFEND;

    output_timing_info (start_time, stop_time, 6 {indent}, trace_file_id,
          trace_status);
    IF NOT trace_status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
            trace_status, ignore_status);
    IFEND;

    IF (call_block.operation = amc$close_req) OR (NOT status.normal) THEN
      close_trace (trace_file_id, trace_status);
      IF NOT trace_status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
              trace_status, ignore_status);
      IFEND;
    IFEND;

  PROCEND amp$trace_timings;

?? TITLE := 'PROCEDURE output_status', EJECT ??

  PROCEDURE output_status
    (    output_fid: amt$file_identifier;
         message_status: ost$status;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      j: integer,
      line_count:   ^ost$status_message_line_count,
      line_length:  ^ost$status_message_line_size,
      line_text:    ^string(*),
      message: ost$status_message,
      p_message: ^ost$status_message;

    status.normal := TRUE;

    osp$format_message (message_status, osc$full_message_level, 78,
          message, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_message := ^message;
    RESET p_message;

    NEXT line_count IN p_message;
    FOR j := 1 TO line_count^ DO
      NEXT line_length IN p_message;
      NEXT line_text: [line_length^] IN p_message;
      amp$put_next(output_fid, line_text, line_length^,
            ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND output_status;

?? TITLE := 'output_operation_info', EJECT ??

  PROCEDURE output_operation_info
    (    call_block: amt$call_block;
         file_identifier: amt$file_identifier;
         indent: bat$display_tables_indention;
     VAR trace_file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      ba: amt$file_byte_address;

    status.normal := TRUE;

    CASE call_block.operation OF
    = amc$get_segment_pointer_req =
      output_segment_info (call_block.getsegp.segment_pointer^,
            amc$get_segment_pointer_req, indent + 4, trace_file_id, status);
    = amc$open_req =
      IF call_block.open.existing_file THEN
        STRINGREP (output_string, output_length, ' ': indent, 'OPEN OLD FILE');
        amp$put_next (trace_file_id, ^output_string, output_length, ba,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        STRINGREP (output_string, output_length, ' ': indent, 'OPEN NEW FILE');
        amp$put_next (trace_file_id, ^output_string, output_length, ba,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      output_instance_of_open_info (file_identifier, indent, trace_file_id,
            status);
    = amc$set_segment_eoi_req =
      output_segment_info (call_block.segeoi.segment_pointer,
            amc$set_segment_eoi_req, indent + 4, trace_file_id, status);
    = amc$set_segment_position_req =
      output_segment_info (call_block.segpos.segment_pointer,
            amc$set_segment_position_req, indent + 4, trace_file_id, status);
    = amc$skip_req =
      output_skip_info (call_block.skp, indent, trace_file_id, status);
    = amc$get_direct_req, amc$get_key_req,
          amc$get_next_req .. amc$get_partial_req, amc$put_direct_req,
          amc$put_key_req, amc$put_next_req .. amc$putrep_req =
      output_working_storage (call_block, indent, trace_file_id, status);
      output_tc_and_fp (call_block, indent, trace_file_id, status);
      output_byte_address (call_block, indent, trace_file_id, status);
      output_term_option (call_block, indent, trace_file_id, status);
    ELSE
    CASEND;

  PROCEND output_operation_info;

?? TITLE := 'output_segment_info', EJECT ??

  PROCEDURE output_segment_info
    (    pointer: amt$segment_pointer;
         operation: amt$fap_operation;
         indent: bat$display_tables_indention;
     VAR trace_file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      ba: amt$file_byte_address,
      cell_pointer: ^cell,
      length: 6 .. 14,
      limit: ost$segment_length,
      position: ost$segment_length,
      segment_pointer_kind: [READ, STATIC, oss$job_paged_literal] array [amt$pointer_kind] of string (11) :=
            ['^CELL      ', '^HEAP ( * )', '^SEQ ( * ) '],
      segment_pointer: string (14);

    status.normal := TRUE;

    CASE pointer.kind OF
    = amc$cell_pointer =
      cell_pointer := pointer.cell_pointer;
      position := #OFFSET (cell_pointer);
    = amc$heap_pointer =
      cell_pointer := pointer.heap_pointer;
    = amc$sequence_pointer =
      cell_pointer := pointer.sequence_pointer;
      position := i#current_sequence_position (pointer.sequence_pointer);
    ELSE
    CASEND;

    STRINGREP (output_string, output_length, ' ': indent - 4,
          segment_pointer_kind [pointer.kind], ' : ', cell_pointer);
    amp$put_next (trace_file_id, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pointer.kind <> amc$heap_pointer THEN
      IF operation = amc$set_segment_eoi_req THEN
        STRINGREP (output_string, output_length, ' ': indent, 'segment eoi : ',
              position);
        amp$put_next (trace_file_id, ^output_string, output_length, ba,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        STRINGREP (output_string, output_length, ' ': indent,
              'segment position : ', position);
        amp$put_next (trace_file_id, ^output_string, output_length, ba,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    IF pointer.kind <> amc$cell_pointer THEN
      IF pointer.kind = amc$heap_pointer THEN
        limit := #SIZE (pointer.heap_pointer^);
      ELSE
        limit := #SIZE (pointer.sequence_pointer^);
      IFEND;
      STRINGREP (output_string, output_length, ' ': indent, 'segment limit : ',
            limit);
      amp$put_next (trace_file_id, ^output_string, output_length, ba, status);
    IFEND;

  PROCEND output_segment_info;

?? TITLE := 'output_initial_line', EJECT ??

  PROCEDURE output_initial_line
    (    file_identifier: amt$file_identifier;
         operation: amt$fap_operation;
         ring_number: ost$valid_ring;
         indent: bat$display_tables_indention;
     VAR trace_file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      local_status: ost$status,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      path: fst$path,
      path_handle: fmt$path_handle,
      path_size: fst$path_size;

    status.normal := TRUE;

    clp$get_fs_path_string (bav$task_file_table^
          [file_identifier.ordinal].local_file_name, path, path_size,
          path_handle, local_status);

    STRINGREP (output_string, output_length, ' ': indent,
          bav$request_name_table_ptr^ [operation].name,
          ' issued from ring ', ring_number);
    amp$put_next (trace_file_id, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, '  for : ',
          path (1, path_size));
    amp$put_next (trace_file_id, ^output_string, output_length, ba, status);

  PROCEND output_initial_line;

?? TITLE := ' PROCEDURE append_usage_selections ', EJECT ??

  PROCEDURE append_usage_selections
    (    access_or_share_modes: pft$usage_selections;
     VAR str: {i/o} string (bat$display_tables_str_length);
     VAR str_length: {i/o} integer);

    VAR
      usage_option: pft$usage_options;

    IF access_or_share_modes = $pft$usage_selections [] THEN
      STRINGREP (str, str_length, str (1, str_length), 'NONE');
    ELSE
      STRINGREP (str, str_length, str (1, str_length), '(');
      FOR usage_option := LOWERVALUE (pft$usage_options) TO
             UPPERVALUE (pft$usage_options) DO
        IF usage_option IN access_or_share_modes THEN
          STRINGREP (str, str_length, str (1, str_length),
                amv$usage_option_names [usage_option].name
               (1, amv$usage_option_names [usage_option].size));
          STRINGREP (str, str_length, str (1, str_length), ', ');
        IFEND;
      FOREND;
      str_length := str_length - 1;
      str (str_length) := ')';
    IFEND;

  PROCEND append_usage_selections;

?? TITLE := 'output_instance_of_open_info', EJECT ??

  PROCEDURE output_instance_of_open_info
    (    file_identifier: amt$file_identifier;
         indent: bat$display_tables_indention;
     VAR trace_file_id: amt$file_identifier;
     VAR status: ost$status);

    CONST
      error_text = 'INVALID';

    VAR
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      ba: amt$file_byte_address,
      file_instance: ^bat$task_file_entry,
      ignore_status: ost$status,
      valid_fid: boolean;

    status.normal := TRUE;
    bap$validate_file_identifier (file_identifier, file_instance, valid_fid);

    IF valid_fid THEN

      STRINGREP (output_string, output_length, ' ': indent, 'Access_level : ',
            amv$access_level_names [file_instance^.access_level].name);
      amp$put_next (trace_file_id, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent,
            'File_organization : ', amv$file_organization_names [
            file_instance^.instance_attributes.static_label.file_organization].
            name);
      amp$put_next (trace_file_id, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'Block_type : ',
            amv$block_type_names [file_instance^.instance_attributes.
            static_label.block_type].name);
      amp$put_next (trace_file_id, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'Record_type : ',
            amv$record_type_names [file_instance^.instance_attributes.
            static_label.record_type].name);
      amp$put_next (trace_file_id, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent,
            'Access_mode : ');
      append_usage_selections (file_instance^.instance_attributes.dynamic_label.
            access_mode, output_string, output_length);
      amp$put_next (trace_file_id, ^output_string, output_length, ba, status);

    IFEND; {IF valid_fid}

  PROCEND output_instance_of_open_info;

?? TITLE := 'output_working_storage', EJECT ??

  PROCEDURE output_working_storage
    (    call_block: amt$call_block;
         indent: bat$display_tables_indention;
     VAR trace_file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      ba: amt$file_byte_address,
      wsa: ^cell,
      wsl: amt$working_storage_length;

    status.normal := TRUE;
    CASE call_block.operation OF
    = amc$get_direct_req =
      wsa := call_block.getd.working_storage_area;
      wsl := call_block.getd.working_storage_length;
    = amc$get_key_req =
      wsa := call_block.getk.working_storage_area;
      wsl := call_block.getk.working_storage_length;
    = amc$get_next_req =
      wsa := call_block.getn.working_storage_area;
      wsl := call_block.getn.working_storage_length;
    = amc$get_next_key_req =
      wsa := call_block.getnk.working_storage_area;
      wsl := call_block.getnk.working_storage_length;
    = amc$get_partial_req =
      wsa := call_block.getp.working_storage_area;
      wsl := call_block.getp.working_storage_length;
    = amc$put_direct_req =
      wsa := call_block.putd.working_storage_area;
      wsl := call_block.putd.working_storage_length;
    = amc$put_key_req =
      wsa := call_block.putk.working_storage_area;
      wsl := call_block.putk.working_storage_length;
    = amc$put_next_req =
      wsa := call_block.putn.working_storage_area;
      wsl := call_block.putn.working_storage_length;
    = amc$put_partial_req =
      wsa := call_block.putp.working_storage_area;
      wsl := call_block.putp.working_storage_length;
    = amc$putrep_req =
      wsa := call_block.putrep.working_storage_area;
      wsl := call_block.putrep.working_storage_length;
    = amc$replace_req =
      wsa := call_block.replace.working_storage_area;
      wsl := call_block.replace.working_storage_length;
    = amc$replace_direct_req =
      wsa := call_block.repld.working_storage_area;
      wsl := call_block.repld.working_storage_length;
    = amc$replace_key_req =
      wsa := call_block.repk.working_storage_area;
      wsl := call_block.repk.working_storage_length;
    ELSE
      RETURN;
    CASEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'Working storage area : ', wsa);
    amp$put_next (trace_file_id, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'Working_storage_length : ', wsl);
    amp$put_next (trace_file_id, ^output_string, output_length, ba, status);

  PROCEND output_working_storage;

?? TITLE := 'output_tc_and_fp', EJECT ??

  PROCEDURE output_tc_and_fp
    (    call_block: amt$call_block;
         indent: bat$display_tables_indention;
     VAR trace_file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      ba: amt$file_byte_address,
      fp: ^amt$file_position,
      tc: ^amt$transfer_count;


    status.normal := TRUE;

    CASE call_block.operation OF
    = amc$get_direct_req =
      tc := call_block.getd.transfer_count;
      fp := call_block.getd.file_position;
    = amc$get_next_req =
      tc := call_block.getn.transfer_count;
      fp := call_block.getn.file_position;
    = amc$get_partial_req =
      tc := call_block.getp.transfer_count;
      fp := call_block.getp.file_position;
    ELSE
      RETURN;
    CASEND;

    STRINGREP (output_string, output_length, ' ': indent, 'File_position : ',
          bav$file_positions [fp^]);
    amp$put_next (trace_file_id, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'Transfer_count : ',
          tc^);
    amp$put_next (trace_file_id, ^output_string, output_length, ba, status);

  PROCEND output_tc_and_fp;


?? TITLE := 'output_byte_address', EJECT ??

  PROCEDURE output_byte_address
    (    call_block: amt$call_block;
         indent: bat$display_tables_indention;
     VAR trace_file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      ba: amt$file_byte_address,
      byte_address: amt$file_byte_address;

    status.normal := TRUE;

    CASE call_block.operation OF
    = amc$get_direct_req =
      byte_address := call_block.getd.byte_address;
    = amc$get_next_req =
      byte_address := call_block.getn.byte_address^;
    = amc$get_partial_req =
      byte_address := call_block.getp.byte_address^;
    = amc$put_direct_req =
      byte_address := call_block.putd.byte_address;
    = amc$put_next_req =
      byte_address := call_block.putn.byte_address^;
    = amc$put_partial_req =
      byte_address := call_block.putp.byte_address^;
    = amc$replace_direct_req =
      byte_address := call_block.repld.byte_address;
    ELSE
      RETURN;
    CASEND;

    STRINGREP (output_string, output_length, ' ': indent, 'Byte_address : ',
          byte_address, '(10)   ', byte_address: #(16), '(16)');
    amp$put_next (trace_file_id, ^output_string, output_length, ba, status);

  PROCEND output_byte_address;

?? TITLE := 'output_term_option', EJECT ??

  PROCEDURE output_term_option
    (    call_block: amt$call_block;
         indent: bat$display_tables_indention;
     VAR trace_file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      ba: amt$file_byte_address,
      skip_options: [READ, oss$job_paged_literal] array [amt$skip_option] of
            string (7) := ['to_eor ', 'no_skip'],
      term_options: [READ, oss$job_paged_literal] array [amt$term_option] of
            string (9) := ['start    ', 'continue ', 'terminate'],
      term_text: string (9);

    status.normal := TRUE;

    CASE call_block.operation OF
    = amc$put_partial_req =
      IF (call_block.putp.term_option < LOWERVALUE (amt$term_option)) OR
            (call_block.putp.term_option > UPPERVALUE (amt$term_option)) THEN
        term_text := 'INVALID  ';
      ELSE
        term_text := term_options [call_block.putp.term_option];
      IFEND;
      STRINGREP (output_string, output_length, ' ': indent, 'Term_option : ',
            term_text);
    = amc$get_partial_req =
      IF (call_block.getp.skip_option < LOWERVALUE (amt$skip_option)) OR
            (call_block.getp.skip_option > UPPERVALUE (amt$skip_option)) THEN
        term_text := 'INVALID  ';
      ELSE
        term_text := skip_options [call_block.getp.skip_option];
      IFEND;
      STRINGREP (output_string, output_length, ' ': indent, 'Skip_option : ',
            term_text);
    ELSE
      RETURN;
    CASEND;

    amp$put_next (trace_file_id, ^output_string, output_length, ba, status);

  PROCEND output_term_option;

?? TITLE := 'output_skip_info', EJECT ??

  PROCEDURE output_skip_info
    (    skip: amt$skip_req;
         indent: bat$display_tables_indention;
     VAR trace_file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      ba: amt$file_byte_address,
      count: amt$skip_count,
      direction: string (8),
      unit: string (9);

    status.normal := TRUE;

    IF skip.direction = amc$forward THEN
      direction := 'forward';
    ELSEIF skip.direction = amc$backward THEN
      direction := 'backward';
    ELSE
      direction := 'INVALID';
    IFEND;
    IF skip.unit = amc$skip_record THEN
      unit := 'record';
    ELSEIF skip.unit = amc$skip_partition THEN
      unit := 'partition';
    ELSE
      unit := 'INVALID';
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'Skip_direction : ',
          direction);
    amp$put_next (trace_file_id, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'Skip_count : ',
          skip.count);
    amp$put_next (trace_file_id, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'Skip_unit : ',
          unit);
    amp$put_next (trace_file_id, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'File_position : ',
          bav$file_positions [skip.file_position^]);
    amp$put_next (trace_file_id, ^output_string, output_length, ba, status);

  PROCEND output_skip_info;

?? TITLE := 'output_timing_info', EJECT ??

  PROCEDURE output_timing_info
    (    start_time: pmt$task_cp_time;
         stop_time: pmt$task_cp_time;
         indent: bat$display_tables_indention;
     VAR trace_file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      ba: amt$file_byte_address,
      elapsed_time: pmt$task_cp_time,
      message: ost$status,
      elpased_time: pmt$task_cp_time;

    status.normal := TRUE;

    elapsed_time.task_time := stop_time.task_time - start_time.task_time;
    elapsed_time.monitor_time := stop_time.monitor_time -
          start_time.monitor_time;

    STRINGREP (output_string, output_length, ' ': indent,
          'Starting task time    = ', start_time.task_time);
    amp$put_next (trace_file_id, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'Starting monitor time = ', start_time.monitor_time);
    amp$put_next (trace_file_id, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'Elapsed task time     = ', elapsed_time.task_time);
    amp$put_next (trace_file_id, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'Elapsed monitor time  = ', elapsed_time.monitor_time);
    amp$put_next (trace_file_id, ^output_string, output_length, ba, status);

  PROCEND output_timing_info;

MODEND amm$trace_routines;

*DECK DECK=AMM$UNLOCK_FILE EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$unlock_file;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$UNLOCK_FILE' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$unlock_file (file_identifier:
    amt$file_identifier;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$UNLOCK_FILE',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$unlock_file);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$unlock_file);
      RETURN;
    IFEND;

    call_block.operation := amc$unlock_file;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$unlock_file);
  PROCEND amp$unlock_file;
MODEND amm$unlock_file;
*DECK DECK=AMM$UNLOCK_KEY EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$unlock_key;


?? NEWTITLE := 'NOS/VE :  ADVANCED ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$UNLOCK_KEY' ??
?? NEWTITLE := '  RING BRACKETS 4DD' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ost$caller_identifier
*copyc amk$access_method
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??


  PROCEDURE [XDCL, #GATE] amp$unlock_key (file_identifier: amt$file_identifier;
        unlock_all_keys: boolean;
        key_location: ^cell;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$UNLOCK_KEY',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$unlock_key);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$unlock_key);
      RETURN;
    IFEND;

    call_block.operation := amc$unlock_key;
    call_block.unlock_key.unlock_all_keys := unlock_all_keys;
    call_block.unlock_key.key_location := key_location;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$unlock_key);
  PROCEND amp$unlock_key;
MODEND amm$unlock_key;
*DECK DECK=AMM$US_BLK_VAR_READ_ONLY_FAP EXPAND=TRUE
?? RIGHT := 80 ??
*copyc osd$default_pragmats
?? TITLE := 'AMM$US_BLK_VAR_READ_ONLY_FAP' ??
MODULE amm$us_blk_var_read_only_fap;
*copyc amt$fap_declarations
*copyc bap$us_blk_var_read_only_fap

?? TITLE := 'PROCEDURE [XDCL, #GATE] AMP$US_BLK_VAR_READ_ONLY_FAP', EJECT ??

{ This procedure is provided to allow copying of a file whose block_type is
{ User_Specified and whose record_type is Variable.  This block_type,
{ record_type combination was deleted in 1.63.01.  This procedure is to be
{ used as a user fap that will allow only for copying of the file which is
{ no longer supported to a block_type record_type combination which is
{ supported.

   PROCEDURE [XDCL, #GATE] amp$us_blk_var_read_only_fap
     (    file_identifier: amt$file_identifier;
          call_block: amt$call_block;
          layer_number: amt$fap_layer_number;
     VAR status: ost$status);

  bap$us_blk_var_read_only_fap (file_identifier, call_block, layer_number,
        status);

  PROCEND amp$us_blk_var_read_only_fap;
MODEND amm$us_blk_var_read_only_fap;

*DECK DECK=AMM$VALIDATE_CALLER_PRIVILEGE EXPAND=TRUE
*copyc osd$default_pragmats
MODULE amm$validate_caller_privilege;

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$VALIDATE_CALLER_PRIVILEGE' ??
?? NEWTITLE := '  RING BRACKETS 23D' ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc amt$fap_declarations
*copyc ost$caller_identifier
*copyc amk$access_method
*copyc amt$file_identifier
*copyc ame$access_validation_errors
*copyc ame$fap_validation_errors
*copyc ame$improper_file_id
*copyc ame$ring_validation_errors
*copyc pfd$permanent_file_attributes
*copyc osd$virtual_address
*copyc ost$caller_identifier
*copyc amh$validate_caller_privilege
?? POP ??
*copyc amp$set_file_instance_abnormal
*copyc bap$validate_file_identifier
*copyc osp$append_status_parameter
*copyc osp$copy_local_status_to_status
*copyc osp$set_status_abnormal
*copy amh$validate_caller_privilege
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$validate_caller_privilege ALIAS 'amxvcp'
    (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
        required_write_privilege: pft$usage_selections;
        caller_ring_number: ost$ring;
    VAR structure_pointer: ^cell;
    VAR status: ost$status);

    CONST
      interface_name = 'AMP$VALIDATE_CALLER_PRIVILEGE';

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      i: pft$usage_options,
      delimiter: char,
      file_id_is_valid: boolean,
      layer: ^bat$fap_descriptor,
      previous_append: boolean,
      validation_ring: ost$ring,
      write_permission: array [pfc$shorten .. pfc$modify] of string (7),
      file_instance: ^bat$task_file_entry;

    #keypoint (osk$entry, 0, amk$validate_caller_privilege);
    #caller_id (caller_id);

    status.normal := TRUE;
    bam_status.normal := TRUE;
    structure_pointer := NIL;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$validate_caller_privilege);
      RETURN;
    IFEND;

    IF caller_id.ring > caller_ring_number THEN
      amp$set_file_instance_abnormal (file_identifier,
            ame$ring_validation_error, call_block.operation, '', status);
      #keypoint (osk$exit, 0, amk$validate_caller_privilege);
      RETURN;
    IFEND;

    validation_ring := caller_ring_number;

    CASE call_block.operation OF
    = amc$close_req, amc$close_volume_req, amc$open_req =
      IF validation_ring > file_instance^.open_ring THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, call_block.operation, '', status);
        #keypoint (osk$exit, 0, amk$validate_caller_privilege);
        RETURN;
      IFEND;
    = amc$delete_req, amc$delete_direct_req, amc$delete_key_req, amc$flush_req,
          amc$pack_block_req, amc$pack_record_req, amc$put_direct_req,
            amc$put_key_req, amc$put_label_req, amc$put_next_req,
            amc$put_partial_req, amc$putrep_req, amc$replace_req,
            amc$replace_direct_req, amc$replace_key_req,
            amc$set_segment_eoi_req, amc$write_req, amc$write_direct_req,
            amc$write_end_partition_req, amc$write_tape_mark_req,
            amc$abandon_key_definitions, amc$apply_key_definitions,
            amc$create_key_definition, amc$create_nested_file,
            amc$delete_key_definition, amc$delete_nested_file,
            amc$find_record_space, amc$separate_key_groups, nac$se_send_data_req =

      IF required_write_privilege = $pft$usage_selections [] THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$null_set_specified, call_block.operation,
          'REQUIRED_WRITE_PRIVILEGE', status);
        #keypoint (osk$exit, 0, amk$validate_caller_privilege);
        RETURN;
      IFEND;

      IF validation_ring > file_instance^.instance_attributes.static_label.
            ring_attributes.r1 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, call_block.operation, '', status);
        #keypoint (osk$exit, 0, amk$validate_caller_privilege);
        RETURN;
      IFEND;

      IF NOT (required_write_privilege <= file_instance^.instance_attributes.
            dynamic_label.access_mode) THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_access_attempt, call_block.operation, '', status);
        previous_append := FALSE;
        write_permission [pfc$shorten] := 'SHORTEN';
        write_permission [pfc$append] := 'APPEND';
        write_permission [pfc$modify] := 'MODIFY';
        FOR i := LOWERBOUND (write_permission) TO UPPERBOUND (write_permission)
              DO
          IF i IN required_write_privilege THEN
            IF previous_append THEN
              delimiter := ',';
            ELSE
              delimiter := ' ';
            IFEND;
            osp$append_status_parameter (delimiter, write_permission [i],
                  status);
            previous_append := TRUE;
          IFEND;
        FOREND;
        #keypoint (osk$exit, 0, amk$validate_caller_privilege);
        RETURN;
      IFEND;
    = amc$check_buffer_req, amc$check_record_req, amc$get_direct_req,
          amc$get_key_req, amc$get_label_req, amc$get_next_req,
            amc$get_next_key_req, amc$get_partial_req,
            amc$get_segment_pointer_req, amc$read_req, amc$read_direct_req,
            amc$read_direct_skip_req, amc$read_skip_req,
            amc$set_segment_position_req, amc$start_req, amc$unpack_block_req,
            amc$unpack_record_req, amc$get_lock_keyed_record,
            amc$get_lock_next_keyed_record, amc$get_next_primary_key_list,
            amc$get_primary_key_count, amc$get_space_used_for_key, nac$se_receive_data_req=
      IF validation_ring > file_instance^.instance_attributes.static_label.
            ring_attributes.r2 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, call_block.operation, '', status);
        #keypoint (osk$exit, 0, amk$validate_caller_privilege);
        RETURN;
      IFEND;

      IF NOT (pfc$read IN file_instance^.instance_attributes.dynamic_label.
            access_mode) THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_access_attempt, call_block.operation, ' READ',
              status);
        #keypoint (osk$exit, 0, amk$validate_caller_privilege);
        RETURN;
      IFEND;
    = ifc$fetch_terminal_req =
      IF validation_ring > file_instance^.instance_attributes.static_label.
            ring_attributes.r2 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, call_block.operation, '', status);
        #keypoint (osk$exit, 0, amk$validate_caller_privilege);
        RETURN;
      IFEND;

    = amc$fetch_access_information_rq, amc$fetch_req, nac$fetch_attributes =
      IF validation_ring > file_instance^.instance_attributes.static_label.
            ring_attributes.r3 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, call_block.operation, '', status);
        #keypoint (osk$exit, 0, amk$validate_caller_privilege);
        RETURN;
      IFEND;
    = amc$rewind_req, amc$rewind_volume_req, amc$skip_req, amc$seek_direct_req,
          amc$abort_file_parcel, amc$begin_file_parcel,
            amc$check_nowait_request, amc$commit_file_parcel,
            amc$get_key_definitions, amc$get_nested_file_definitions,
            amc$lock_file, amc$lock_key, amc$select_key,
            amc$select_nested_file, amc$unlock_file, amc$unlock_key =
      IF validation_ring > file_instance^.instance_attributes.static_label.
            ring_attributes.r2 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, call_block.operation, '', status);
        #keypoint (osk$exit, 0, amk$validate_caller_privilege);
        RETURN;
      IFEND;

      IF ($pft$usage_selections [pfc$read, pfc$append, pfc$modify, pfc$shorten]
            * file_instance^.instance_attributes.dynamic_label.access_mode) =
            $pft$usage_selections [] THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_access_attempt, call_block.operation,
          ' READ or WRITE', status);
        #keypoint (osk$exit, 0, amk$validate_caller_privilege);
        RETURN;
      IFEND;
    = amc$store_req, ifc$store_terminal_req, nac$store_attributes =
      IF validation_ring > file_instance^.instance_attributes.static_label.
            ring_attributes.r1 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, call_block.operation, '', status);
        #keypoint (osk$exit, 0, amk$validate_caller_privilege);
        RETURN;
      IFEND;
    ELSE
      amp$set_file_instance_abnormal (file_identifier,
            ame$improper_fap_operation, amc$validate_caller_privilege, '',
            status);
      #keypoint (osk$exit, 0, amk$validate_caller_privilege);
      RETURN;
    CASEND;

*copyc bai$get_fap_layer

    osp$copy_local_status_to_status (bam_status, status);
    IF layer^.structure_pointer  <> NIL then
      IF caller_id.ring <= layer^.loaded_ring THEN
        structure_pointer := layer^.structure_pointer;
      ELSE
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, amc$validate_caller_privilege, '',
              status);
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$validate_caller_privilege);
  PROCEND amp$validate_caller_privilege;
MODEND amm$validate_caller_privilege;
*DECK DECK=AMM$WRITE_END_PARTITION EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$write_end_partition;

{ MODULE DECK AMMEOP }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$WRITE_END_PARTITION' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$WRITE_END_PARTITION
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$write_end_partition ALIAS 'amxendp'
    (file_identifier: amt$file_identifier;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$WRITE_END_PARTITION',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0, amk$write_end_partition);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$write_end_partition);
      RETURN;
    IFEND;

    call_block.operation := amc$write_end_partition_req;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, amk$write_end_partition);
  PROCEND amp$write_end_partition;
MODEND amm$write_end_partition;
*DECK DECK=AMM$WRITE_TAPE_MARK EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE amm$write_tape_mark;

{ MODULE DECK AMMWTM }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] AMP$WRITE_TAPE_MARK' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
*copyc AMH$WRITE_TAPE_MARK
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$write_tape_mark ALIAS 'amxwtmk' (file_identifier:
    amt$file_identifier;
    VAR status: ost$status);


    CONST
      interface_name = 'AMP$WRITE_TAPE_MARK',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, 0,
          amk$write_tape_mark);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, 0, amk$write_tape_mark);
      RETURN;
    IFEND;

    call_block.operation := amc$write_tape_mark_req;

*copy bai$call_fap_control

    IF bam_status.normal THEN
      #keypoint (osk$exit, 0, amk$write_tape_mark);
    ELSE
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF bam_status.normal THEN
        #keypoint (osk$exit, 0, amk$write_tape_mark);
      ELSE
        status := bam_status;
        #keypoint (osk$exit, 0, amk$write_tape_mark);
      IFEND;
    IFEND;
  PROCEND amp$write_tape_mark;
MODEND amm$write_tape_mark;
*DECK DECK=AMP$#CLOSE EXPAND=FALSE

  PROCEDURE [XREF] amp$#close ALIAS 'amxclse' (file_identifier:
    amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$PUT_PROGRAM_ACTIONS
?? POP ??
*DECK DECK=AMP$#COPY_FILE EXPAND=FALSE

  PROCEDURE [XREF] amp$#copy_file ALIAS 'amxcpyf' (input_file:
    amt$local_file_name;
        output_file: amt$local_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$ACCESS_VALIDATION_ERRORS
*copyc AME$OPEN_VALIDATION_ERRORS
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$GET_PROGRAM_ACTIONS
*copyc AME$PUT_PROGRAM_ACTIONS
?? POP ??
*DECK DECK=AMP$#GET_FILE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] amp$#get_file_attributes ALIAS 'amxgfat' (local_file_name:
    amt$local_file_name;
    VAR file_attributes: amt$get_attributes;
    VAR local_file: boolean;
    VAR old_file: boolean;
    VAR contains_data: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$GET_ATTRIBUTES
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$ATTRIBUTE_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
?? POP ??
*DECK DECK=AMP$#GET_PARTIAL EXPAND=FALSE

  PROCEDURE [XREF] amp$#get_partial ALIAS 'amxgetp' (file_identifier:
    amt$file_identifier;
    working_storage_area: ^cell;
    working_storage_length: amt$working_storage_length;
    VAR record_length: amt$max_record_length;
    VAR transfer_count: amt$transfer_count;
    VAR byte_address: amt$file_byte_address;
    VAR file_position: amt$file_position;
    skip_option: amt$skip_option;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FILE_POSITION
*copyc AMT$SKIP_OPTION
*copyc AMT$MAX_RECORD_LENGTH
*copyc AMT$TRANSFER_COUNT
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$CONFLICTING_ACCESS_LEVEL
*copyc AME$IMPROPER_FILE_ID
*copyc AME$GET_VALIDATION_ERRORS
*copyc AME$TERMINAL_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$IMPROPER_WSL
*copyc AME$GET_PROGRAM_ACTIONS
?? POP ??
*DECK DECK=AMP$#GET_SEGMENT_POINTER EXPAND=FALSE

  PROCEDURE [XREF] amp$#get_segment_pointer ALIAS 'amxgsgp' (file_identifier:
    amt$file_identifier;
        pointer_kind: amt$pointer_kind;
    VAR segment_pointer: amt$segment_pointer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$SEGMENT_POINTER
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$ACCESS_VALIDATION_ERRORS
*copyc AME$IMPROPER_FILE_ID
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$SEGMENT_VALIDATION_ERRORS
?? POP ??
*DECK DECK=AMP$#OPEN EXPAND=FALSE

  PROCEDURE [XREF] amp$#open ALIAS 'amxopen' (local_file_name:
    amt$local_file_name;
        access_level: amt$access_level;
        access_selections: amt$file_access_selections;
    VAR file_identifier: amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$LOCAL_FILE_NAME
*copyc AMD$OPEN_DECLARATIONS
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$OPEN_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$LFN_PROGRAM_ACTIONS
?? POP ??
*DECK DECK=AMP$#SET_SEGMENT_EOI EXPAND=FALSE

  PROCEDURE [XREF] amp$#set_segment_eoi ALIAS 'amxsete' (file_identifier:
    amt$file_identifier;
        segment_pointer: amt$segment_pointer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$SEGMENT_POINTER
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$SEGMENT_VALIDATION_ERRORS
?? POP ??
*DECK DECK=AMP$ABANDON_KEY_DEFINITIONS EXPAND=FALSE
 PROCEDURE [XREF] amp$abandon_key_definitions (file_identifier:
  amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=AMP$ABORT_FILE_PARCEL EXPAND=FALSE
 PROCEDURE [XREF] amp$abort_file_parcel (file_identifier: amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=AMP$ACCESS_METHOD EXPAND=FALSE

  PROCEDURE [XREF] amp$access_method ALIAS 'amxaccm' (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FAP_DECLARATIONS
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$FAP_VALIDATION_ERRORS
*copyc AME$IMPROPER_FILE_ID
?? POP ??
*DECK DECK=AMP$ADD_TO_FILE_DESCRIPTION EXPAND=FALSE

  PROCEDURE [XREF] amp$add_to_file_description ALIAS 'amxatfd'
    (file_identifier: amt$file_identifier;
        file_attributes: amt$add_to_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$ADD_TO_ATTRIBUTES
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$ATTRIBUTE_VALIDATION_ERRORS
*copyc AME$IMPROPER_FILE_ID
*copyc AME$RING_VALIDATION_ERRORS
?? POP ??
*DECK DECK=AMP$ALLOCATE EXPAND=FALSE

  PROCEDURE [XREF] amp$allocate ALIAS 'amxaloc' (local_file_name:
    amt$local_file_name;
    mode: amt$allocation_mode;
    amount: amt$allocation_amount;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

*copyc AMT$ALLOCATION_MODE
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$ALLOCATE_VALIDATION_ERRORS
*copyc AME$DEVICE_CLASS_VALIDATION

*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$ALLOCATE_PROGRAM_ACTIONS
?? POP ??
*DECK DECK=AMP$APPLY_KEY_DEFINITIONS EXPAND=FALSE
 PROCEDURE [XREF] amp$apply_key_definitions (file_identifier:
  amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=AMP$BEGIN_FILE_PARCEL EXPAND=FALSE
 PROCEDURE [XREF] amp$begin_file_parcel (file_identifier: amt$file_identifier;
        general_commit: amt$general_commit;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$general_commit
*copyc ost$status
?? POP ??
*DECK DECK=AMP$CHANGE_FILE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] amp$change_file_attributes
    (    file: fst$file_reference;
         file_attributes: ^amt$file_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_attributes
*copyc amt$local_file_name
*copyc fst$file_reference
*copyc ost$status
?? POP ??

*DECK DECK=AMP$CHECK_BUFFER EXPAND=FALSE

  PROCEDURE [XREF] amp$check_buffer ALIAS 'amxchkb' (file_identifier:
    amt$file_identifier;
    buffer_area: ^cell;
    VAR request_complete: boolean;
    VAR transfer_count: amt$physical_transfer_count;
    VAR byte_address: amt$file_byte_address;
    wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$PHYSICAL_TRANSFER_COUNT
*copyc OST$WAIT
*copyc OST$STATUS

?? POP ??
*DECK DECK=AMP$CHECK_NOWAIT_REQUEST EXPAND=FALSE
 PROCEDURE [XREF] amp$check_nowait_request (file_identifier:
  amt$file_identifier;
    VAR request_complete: boolean;
    VAR returned_parameters: amt$nowait_var_parameters;
    VAR request_status: ost$status;
        wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$nowait_var_parameters
*copyc ost$status
*copyc ost$wait
*copyc ost$status
?? POP ??
*DECK DECK=AMP$CLOSE EXPAND=FALSE

  PROCEDURE [XREF] amp$close ALIAS 'amxclse' (file_identifier:
    amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$PUT_PROGRAM_ACTIONS
?? POP ??
*DECK DECK=AMP$CLOSE_VOLUME EXPAND=FALSE

  PROCEDURE [XREF] amp$close_volume (file_identifier: amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$conflicting_access_level
*copyc ame$improper_file_id
*copyc ame$put_program_actions
*copyc ame$ring_validation_errors
*copyc ame$tape_program_actions
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=AMP$COMMIT_FILE_PARCEL EXPAND=FALSE
 PROCEDURE [XREF] amp$commit_file_parcel (file_identifier: amt$file_identifier;
        phase: amt$commit_phase;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$commit_phase
*copyc ost$status
?? POP ??
*DECK DECK=AMP$CONSOLE_FAP EXPAND=FALSE

{ COMMON DECK BAXTCF }

  PROCEDURE [XREF] amp$console_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=AMP$COPY_FILE EXPAND=FALSE

  PROCEDURE [XREF] amp$copy_file ALIAS 'amxcpyf' (input_file:
    amt$local_file_name;
        output_file: amt$local_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$ACCESS_VALIDATION_ERRORS
*copyc AME$COPY_VALIDATION_ERRORS
*copyc FSE$COPY_VALIDATION_ERRORS
*copyc AME$OPEN_VALIDATION_ERRORS
*copyc FSE$OPEN_VALIDATION_ERRORS
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$GET_PROGRAM_ACTIONS
*copyc AME$PUT_PROGRAM_ACTIONS
*copyc AME$LFN_PROGRAM_ACTIONS
?? POP ??
*DECK DECK=AMP$COPY_PARTIAL_RECORDS EXPAND=FALSE

  PROCEDURE [XREF] amp$copy_partial_records ALIAS 'amxcpys' (from_file:
    amt$local_file_name;
    to_file: amt$local_file_name;
    extent: amt$copy_extent;
    first_byte: amt$copy_byte_ordinal;
    last_byte: amt$copy_byte_ordinal;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$COPY_EXTENT
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$OPEN_VALIDATION_ERRORS
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$GET_PROGRAM_ACTIONS
*copyc AME$PUT_PROGRAM_ACTIONS
?? POP ??
*DECK DECK=AMP$COPY_PARTITIONS EXPAND=FALSE

  PROCEDURE [XREF] amp$copy_partitions ALIAS 'amxcpyp' (from_file:
    amt$local_file_name;
    to_file: amt$local_file_name;
    extent: amt$copy_extent;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$COPY_EXTENT
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$OPEN_VALIDATION_ERRORS
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$GET_PROGRAM_ACTIONS
*copyc AME$PUT_PROGRAM_ACTIONS
?? POP ??
*DECK DECK=AMP$COPY_RECORDS EXPAND=FALSE

  PROCEDURE [XREF] amp$copy_records ALIAS 'amxcpyr' (from_file:
    amt$local_file_name;
    to_file: amt$local_file_name;
    extent: amt$copy_extent;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$COPY_EXTENT
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$OPEN_VALIDATION_ERRORS
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$GET_PROGRAM_ACTIONS
*copyc AME$PUT_PROGRAM_ACTIONS
?? POP ??
*DECK DECK=AMP$CRACK_DISPLAY_TFT_OPTIONS EXPAND=FALSE
  PROCEDURE [XREF] amp$crack_display_tft_options (parameter_name: string ( * );
    VAR display_options: amt$display_tft_option_list;
    VAR status: ost$status);
*DECK DECK=AMP$CREATE_KEY_DEFINITION EXPAND=FALSE
 PROCEDURE [XREF] amp$create_key_definition (file_identifier:
  amt$file_identifier;
        key_name: amt$key_name;
        key_position: amt$key_position;
        key_length: amt$key_length;
        optional_attributes: ^amt$optional_key_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$key_length
*copyc amt$key_name
*copyc amt$key_position
*copyc amt$optional_key_attributes
*copyc ost$status
?? POP ??
*DECK DECK=AMP$CREATE_NESTED_FILE EXPAND=FALSE
 PROCEDURE [XREF] amp$create_nested_file (file_identifier: amt$file_identifier;
        definition: amt$nested_file_definition;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$nested_file_definition
*copyc ost$status
?? POP ??
*DECK DECK=AMP$DELETE EXPAND=FALSE

  PROCEDURE [XREF] amp$delete ALIAS 'amxdel' (file_identifier:
    amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$DELETE_DIRECT EXPAND=FALSE

  PROCEDURE [XREF] amp$delete_direct ALIAS 'amxdeld' (file_identifier:
    amt$file_identifier;
    byte_address: amt$file_byte_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$DELETE_KEY_DEFINITION EXPAND=FALSE
 PROCEDURE [XREF] amp$delete_key_definition (file_identifier:
  amt$file_identifier;
        key_name: amt$key_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$key_name
*copyc ost$status
?? POP ??
*DECK DECK=AMP$DELETE_NESTED_FILE EXPAND=FALSE
 PROCEDURE [XREF] amp$delete_nested_file (file_identifier: amt$file_identifier;
        nested_file_name: amt$nested_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$nested_file_name
*copyc ost$status
?? POP ??
*DECK DECK=AMP$DISPLAY_FILE_ID_LIST EXPAND=FALSE

  PROCEDURE [XREF] amp$display_file_id_list (file_id_list: array [1 .. * ] OF
    amt$file_identifier;
        display_options: amt$display_tft_option_list;
        list_file: amt$local_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$display_tft_options
*copyc amt$local_file_name
*copyc ost$status
?? POP ??
*DECK DECK=AMP$DISPLAY_FULL_TFT EXPAND=FALSE

  PROCEDURE [XREF] amp$display_full_tft (display_options:
    amt$display_tft_option_list;
        list_file: amt$local_file_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$display_tft_options
*copyc amt$local_file_name
*copyc ost$status
?? POP ??
*DECK DECK=AMP$DISPLAY_LNT_ENTRIES EXPAND=FALSE

   PROCEDURE [XREF] amp$display_lnt_entries (p_file_list: array [1..*] of
      amt$local_file_name;
      display_options: amt$display_lnt_option_list;
      list_file: amt$local_file_name;
   VAR status: ost$status);

?? push (listext := on) ??
*copyc amt$local_file_name
*copyc amt$display_lnt_options
*copyc ost$status
??POP??
*DECK DECK=AMP$DISPLAY_TFT_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] amp$display_tft_entry (file_instance: ^bat$task_file_entry;
        file_identifier: amt$file_identifier;
        display_options: amt$display_tft_option_list;
    VAR display_control {input,output} : clt$display_control;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc clt$display_control
*copyc amt$file_identifier
*copyc amt$display_tft_options
*copyc bat$task_file_table
?? POP ??
*DECK DECK=AMP$ERASE_TAPE_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] amp$erase_tape_block (file_identifier: amt$file_identifier;
    block_length: amt$max_block_length;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$put_program_actions
*copyc ame$ring_validation_errors
*copyc amt$file_identifier
*copyc amt$max_block_length
*copyc ost$status
?? POP ??

*DECK DECK=AMP$EVICT EXPAND=FALSE

  PROCEDURE [XREF] amp$evict ALIAS 'amxevct' (local_file_name:
    amt$local_file_name;
    mode: amt$evict_mode;
    byte_address: amt$file_byte_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$EVICT_MODE
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$DEVICE_CLASS_VALIDATION
*copyc AME$EVICT_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$LFN_PROGRAM_ACTIONS
?? POP ??
*DECK DECK=AMP$FETCH EXPAND=FALSE

  PROCEDURE [XREF] amp$fetch ALIAS 'amxftch' (file_identifier:
    amt$file_identifier;
    VAR file_attributes: amt$fetch_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FETCH_ATTRIBUTES
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$ATTRIBUTE_VALIDATION_ERRORS
*copyc AME$IMPROPER_FILE_ID
*copyc AME$RING_VALIDATION_ERRORS
?? POP ??
*DECK DECK=AMP$FETCH_ACCESS_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] amp$fetch_access_information ALIAS 'amxfnfo'
    (file_identifier: amt$file_identifier;
    VAR access_information: amt$access_information;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$ACCESS_INFORMATION
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_ACCESS_INFO_KEY
*copyc AME$IMPROPER_FILE_ID
*copyc AME$RING_VALIDATION_ERRORS
  ?? POP ??
*DECK DECK=AMP$FETCH_FAP_POINTER EXPAND=FALSE

  PROCEDURE [XREF] amp$fetch_fap_pointer ALIAS 'amxffap' (file_identifier:
    amt$file_identifier;
    layer_number: amt$fap_layer_number;
    VAR structure_pointer: ^cell;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FAP_DECLARATIONS
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$FAP_PROGRAM_ACTIONS
?? POP ??
*DECK DECK=AMP$FETCH_NESTED_FILE_ATTRIB EXPAND=FALSE

  PROCEDURE [XREF] amp$fetch_nested_file_attrib (
    file_identifier: amt$file_identifier;
    keyed_file_attributes: ^amt$keyed_file_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$keyed_file_attributes
*copyc ost$status
?? POP ??
*DECK DECK=AMP$FILE EXPAND=FALSE

  PROCEDURE [XREF] amp$file ALIAS 'amxfile' (local_file_name:
    amt$local_file_name;
    file_attributes: amt$file_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_ATTRIBUTES
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$ATTRIBUTE_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
?? POP ??
*DECK DECK=AMP$FIND_RECORD_SPACE EXPAND=FALSE
 PROCEDURE [XREF] amp$find_record_space (file_identifier: amt$file_identifier;
        space: amt$file_length;
        where: amt$put_locality;
        wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$file_length
*copyc amt$put_locality
*copyc ost$wait
*copyc ost$status
?? POP ??
*DECK DECK=AMP$FLUSH EXPAND=FALSE

  PROCEDURE [XREF] amp$flush ALIAS 'amxflsh' (file_identifier:
    amt$file_identifier;
    wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc OST$WAIT
*copyc AME$IMPROPER_FILE_ID
*copyc AME$TERMINAL_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
?? POP ??
*DECK DECK=AMP$GENERATE_FULL_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] amp$generate_full_message (message_status: ost$status;
    VAR display_control: clt$display_control;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=AMP$GENERATE_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] amp$generate_message (message_status: ost$status;
    VAR display_control: clt$display_control;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=AMP$GET_DIRECT EXPAND=FALSE

  PROCEDURE [XREF] amp$get_direct ALIAS 'amxgetd' (file_identifier:
    amt$file_identifier;
    working_storage_area: ^cell;
    working_storage_length: amt$working_storage_length;
    VAR transfer_count: amt$transfer_count;
    byte_address: amt$file_byte_address;
    VAR file_position: amt$file_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FILE_POSITION
*copyc AMT$TRANSFER_COUNT
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$CONFLICTING_ACCESS_LEVEL
*copyc AME$IMPROPER_RANDOM_ACCESS
*copyc AME$IMPROPER_FILE_ID
*copyc AME$FILE_ORGANIZATION_ERRORS
*copyc AME$GET_VALIDATION_ERRORS
*copyc AME$TERMINAL_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$IMPROPER_WSL
*copyc AME$GET_PROGRAM_ACTIONS
?? POP ??
*DECK DECK=AMP$GET_FILE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] amp$get_file_attributes
    (    file: fst$file_reference;
     VAR file_attributes: amt$get_attributes;
     VAR file_exists: boolean;
     VAR file_previously_opened: boolean;
     VAR contains_data: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$attribute_validation_errors
*copyc ame$ring_validation_errors
*copyc amt$file_identifier
*copyc amt$get_attributes
*copyc amt$local_file_name
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=AMP$GET_FILE_LFN EXPAND=FALSE
  PROCEDURE [XREF] amp$get_file_lfn (file_id: amt$file_identifier;
    VAR lfn: amt$local_file_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc ost$status
?? POP ??
*DECK DECK=AMP$GET_KEY_DEFINITIONS EXPAND=FALSE
 PROCEDURE [XREF] amp$get_key_definitions (file_identifier:
        amt$file_identifier;
    VAR key_definitions: SEQ ( * );
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$basic_key_definition
*copyc amt$optional_key_attributes
*copyc ost$status
?? POP ??
*DECK DECK=AMP$GET_LABEL EXPAND=FALSE

  PROCEDURE [XREF] amp$get_label (file_identifier: amt$file_identifier;
    label: ^SEQ(*);
    VAR transfer_count: amt$transfer_count;
    VAR volume_position: amt$volume_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$get_program_actions
*copyc ame$ring_validation_errors
*copyc amt$file_identifier
*copyc amt$transfer_count
*copyc amt$volume_position
*copyc ost$status
?? POP ??
*DECK DECK=AMP$GET_LOCK_KEYED_RECORD EXPAND=FALSE
 PROCEDURE [XREF] amp$get_lock_keyed_record (file_identifier:
  amt$file_identifier;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
        key_location: ^cell;
        major_key_length: amt$major_key_length;
        relation: amt$key_relation;
        wait_for_lock: ost$wait_for_lock;
        unlock_control: amt$unlock_control;
        lock_intent: amt$lock_intent;
    VAR record_length: amt$max_record_length;
    VAR file_position: amt$file_position;
        wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$file_position
*copyc amt$key_relation
*copyc amt$lock_intent
*copyc amt$major_key_length
*copyc amt$max_record_length
*copyc ost$wait_for_lock
*copyc amt$working_storage_length
*copyc amt$unlock_control
*copyc ost$wait
*copyc ost$status
?? POP ??
*DECK DECK=AMP$GET_LOCK_NEXT_KEYED_RECORD EXPAND=FALSE
 PROCEDURE [XREF] amp$get_lock_next_keyed_record (file_identifier:
  amt$file_identifier;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
        key_location: ^cell;
        wait_for_lock: ost$wait_for_lock;
        unlock_control: amt$unlock_control;
        lock_intent: amt$lock_intent;
    VAR record_length: amt$max_record_length;
    VAR file_position: amt$file_position;
        wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$file_position
*copyc amt$lock_intent
*copyc amt$max_record_length
*copyc ost$wait_for_lock
*copyc amt$working_storage_length
*copyc amt$unlock_control
*copyc ost$wait
*copyc ost$status
?? POP ??
*DECK DECK=AMP$GET_NESTED_FILE_DEFINITIONS EXPAND=FALSE
 PROCEDURE [XREF] amp$get_nested_file_definitions (file_identifier:
  amt$file_identifier;
    VAR definitions: amt$nested_file_definitions;
    VAR nested_file_count: amt$nested_file_count;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$nested_file_count
*copyc amt$nested_file_definitions
*copyc ost$status
?? POP ??
*DECK DECK=AMP$GET_NEXT EXPAND=FALSE

  PROCEDURE [XREF] amp$get_next ALIAS 'amxgetn' (file_identifier:
    amt$file_identifier;
*IF NOT $true(osv$unix)
    working_storage_area: ^cell;
*ELSE
    working_storage_area: ^string(*);
*IFEND
    working_storage_length: amt$working_storage_length;
    VAR transfer_count: amt$transfer_count;
    VAR byte_address: amt$file_byte_address;
    VAR file_position: amt$file_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FILE_POSITION
*copyc AMT$TRANSFER_COUNT
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc OST$STATUS
*IF NOT $true(osv$unix)
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$CONFLICTING_ACCESS_LEVEL
*copyc AME$IMPROPER_FILE_ID
*copyc AME$GET_VALIDATION_ERRORS
*copyc AME$TERMINAL_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$IMPROPER_WSL
*copyc AME$GET_PROGRAM_ACTIONS
*ELSE
*copyc ame$condition_codes
*IFEND
?? POP ??
*DECK DECK=AMP$GET_NEXT_PRIMARY_KEY_LIST EXPAND=FALSE
 PROCEDURE [XREF] amp$get_next_primary_key_list (file_identifier:
  amt$file_identifier;
        high_key: ^cell;
        major_high_key: amt$major_key_length;
        high_key_relation: amt$key_relation;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
    VAR end_of_primary_key_list: boolean;
    VAR transferred_byte_count: amt$working_storage_length;
    VAR transferred_key_count: amt$key_count_limit;
    VAR file_position: amt$file_position;
        wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$file_position
*copyc amt$key_relation
*copyc amt$key_count_limit
*copyc amt$major_key_length
*copyc amt$working_storage_length
*copyc ost$wait
*copyc ost$status
?? POP ??
*DECK DECK=AMP$GET_PARTIAL EXPAND=FALSE

  PROCEDURE [XREF] amp$get_partial ALIAS 'amxgetp' (file_identifier:
    amt$file_identifier;
*IF NOT $true(osv$unix)
    working_storage_area: ^cell;
*ELSE
    working_storage_area: ^string(*);
*IFEND
    working_storage_length: amt$working_storage_length;
    VAR record_length: amt$max_record_length;
    VAR transfer_count: amt$transfer_count;
    VAR byte_address: amt$file_byte_address;
    VAR file_position: amt$file_position;
    skip_option: amt$skip_option;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FILE_POSITION
*copyc AMT$SKIP_OPTION
*copyc AMT$MAX_RECORD_LENGTH
*copyc AMT$TRANSFER_COUNT
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc OST$STATUS
*IF NOT $true(osv$unix)
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$CONFLICTING_ACCESS_LEVEL
*copyc AME$IMPROPER_FILE_ID
*copyc AME$GET_VALIDATION_ERRORS
*copyc AME$TERMINAL_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$IMPROPER_WSL
*copyc AME$GET_PROGRAM_ACTIONS
*ELSE
*copyc ame$condition_codes
*IFEND
?? POP ??
*DECK DECK=AMP$GET_PRIMARY_KEY_COUNT EXPAND=FALSE
 PROCEDURE [XREF] amp$get_primary_key_count (file_identifier:
  amt$file_identifier;
        low_key: ^cell;
        major_low_key: amt$major_key_length;
        low_key_relation: amt$key_relation;
        high_key: ^cell;
        major_high_key: amt$major_key_length;
        high_key_relation: amt$key_relation;
        list_count_limit: amt$key_count_limit;
    VAR list_count: amt$key_count_limit;
        wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$key_count_limit
*copyc amt$key_relation
*copyc amt$major_key_length
*copyc ost$wait
*copyc ost$status
?? POP ??
*DECK DECK=AMP$GET_SEGMENT_POINTER EXPAND=FALSE

  PROCEDURE [XREF] amp$get_segment_pointer ALIAS 'amxgsgp' (file_identifier:
    amt$file_identifier;
        pointer_kind: amt$pointer_kind;
    VAR segment_pointer: amt$segment_pointer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$SEGMENT_POINTER
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$ACCESS_VALIDATION_ERRORS
*copyc AME$IMPROPER_FILE_ID
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$SEGMENT_VALIDATION_ERRORS
?? POP ??
*DECK DECK=AMP$GET_SPACE_USED_FOR_KEY EXPAND=FALSE
 PROCEDURE [XREF] amp$get_space_used_for_key (file_identifier:
  amt$file_identifier;
        low_key: ^cell;
        major_low_key: amt$major_key_length;
        low_key_relation: amt$key_relation;
        high_key: ^cell;
        major_high_key: amt$major_key_length;
        high_key_relation: amt$key_relation;
    VAR data_block_count: amt$data_block_count;
    VAR data_block_space: amt$file_length;
        wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$data_block_count
*copyc amt$file_length
*copyc amt$key_relation
*copyc amt$major_key_length
*copyc ost$wait
*copyc ost$status
?? POP ??
*DECK DECK=AMP$K_DISPLAY_FAP EXPAND=FALSE

{ COMMON DECK BAXTSF }

  PROCEDURE [XREF] amp$k_display_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=AMP$LIST_LNT_ENTRY EXPAND=FALSE
  PROCEDURE [XREF] amp$list_lnt_entry (local_file_name:
    amt$local_file_name;
        display_options: amt$display_lnt_option_list;
    VAR output_control: clt$display_control;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ost$status
*copyc clt$display_control
*copyc amt$display_lnt_options
?? POP ??
*DECK DECK=AMP$LIST_TFT_ENTRIES EXPAND=FALSE

  PROCEDURE [XREF] amp$list_tft_entries (file_list: array [1 .. * ] OF
    amt$local_file_name;
        display_control: amt$display_tft_option_list;
        list_file: amt$local_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc amt$display_tft_options
*copyc ost$status
?? POP ??
*DECK DECK=AMP$LIST_TFT_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] amp$list_tft_entry (file_instance: ^bat$task_file_entry;
        file_identifier: amt$file_identifier;
    VAR display_control {input,output} : clt$display_control;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc bat$task_file_table
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=AMP$LOCK_FILE EXPAND=FALSE
 PROCEDURE [XREF] amp$lock_file (file_identifier: amt$file_identifier;
        wait_for_lock: ost$wait_for_lock;
        lock_intent: amt$lock_intent;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$lock_intent
*copyc ost$wait_for_lock
*copyc ost$status
?? POP ??
*DECK DECK=AMP$LOCK_KEY EXPAND=FALSE
 PROCEDURE [XREF] amp$lock_key (file_identifier: amt$file_identifier;
        key_location: ^cell;
        wait_for_lock: ost$wait_for_lock;
        unlock_control: amt$unlock_control;
        lock_intent: amt$lock_intent;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$lock_intent
*copyc amt$unlock_control
*copyc ost$wait_for_lock
*copyc ost$status
?? POP ??
*DECK DECK=AMP$LOG_KEYED_FILE_BACKUP EXPAND=FALSE
PROCEDURE [XREF] amp$log_keyed_file_backup(
    saved_file_path: fst$path;
    password: pft$password;
    saved_file_global_name: ost$binary_unique_name;
    backup_information: amt$backup_information;
    volume_list: rmt$volume_list;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$path
*copyc amt$backup_information
*copyc osd$unique_name
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc rmt$volume_list
?? POP ??

*DECK DECK=AMP$OPEN EXPAND=FALSE

  PROCEDURE [XREF] amp$open ALIAS 'amxopen' (local_file_name:
    amt$local_file_name;
        access_level: amt$access_level;
        access_selections: amt$file_access_selections;
    VAR file_identifier: amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$LOCAL_FILE_NAME
*copyc AMD$OPEN_DECLARATIONS
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$OPEN_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$LFN_PROGRAM_ACTIONS
*copyc FSE$ATTACH_VALIDATION_ERRORS
*copyc FSE$OPEN_VALIDATION_ERRORS
*copyc PFE$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=AMP$PACK_BLOCK_HEADER EXPAND=FALSE

  PROCEDURE [XREF] amp$pack_block_header ALIAS 'amxpckb' (file_identifier:
    amt$file_identifier;
    VAR buffer_area: amt$buffer_area;
    header: amt$pack_block_header;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMD$BLOCK_HEADERS
*copyc AMT$BUFFER_AREA
*copyc AMT$FILE_IDENTIFIER
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$PACK_RECORD_HEADER EXPAND=FALSE

  PROCEDURE [XREF] amp$pack_record_header ALIAS 'amxpckr' (file_identifier:
    amt$file_identifier;
    VAR buffer_area: amt$buffer_area;
    header: amt$record_header;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$BUFFER_AREA
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$RECORD_HEADER
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$PUT_DIRECT EXPAND=FALSE

  PROCEDURE [XREF] amp$put_direct ALIAS 'amxputd' (file_identifier:
    amt$file_identifier;
    working_storage_area: ^cell;
    working_storage_length: amt$working_storage_length;
    byte_address: amt$file_byte_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$CONFLICTING_ACCESS_LEVEL
*copyc AME$IMPROPER_RANDOM_ACCESS
*copyc AME$IMPROPER_FILE_ID
*copyc AME$FILE_ORGANIZATION_ERRORS
*copyc AME$TERMINAL_VALIDATION_ERRORS
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$IMPROPER_WSL
*copyc AME$PUT_PROGRAM_ACTIONS
?? POP ??
*DECK DECK=AMP$PUT_LABEL EXPAND=FALSE

  PROCEDURE [XREF] amp$put_label (file_identifier: amt$file_identifier;
    label: ^SEQ(*);
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$put_program_actions
*copyc ame$ring_validation_errors
*copyc amt$file_identifier
*copyc ost$status
?? POP ??

*DECK DECK=AMP$PUT_NEXT EXPAND=FALSE

  PROCEDURE [XREF] amp$put_next ALIAS 'amxputn' (file_identifier:
    amt$file_identifier;
*IF NOT $true(osv$unix)
    working_storage_area: ^cell;
*ELSE
    working_storage_area: ^string (*);
*IFEND
    working_storage_length: amt$working_storage_length;
    VAR byte_address: amt$file_byte_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc amc$condition_code_limits
*copyc ame$access_validation_errors
*copyc ame$conflicting_access_level
*copyc ame$improper_file_id
*copyc ame$improper_wsl
*copyc ame$put_program_actions
*copyc ame$put_validation_errors
*copyc ame$ring_validation_errors
*copyc ame$terminal_validation_errors
*ELSE
*copyc ame$condition_codes
*IFEND
*copyc amt$file_byte_address
*copyc amt$file_identifier
*copyc amt$working_storage_length
*copyc ost$status
?? POP ??
*DECK DECK=AMP$PUT_PARTIAL EXPAND=FALSE

  PROCEDURE [XREF] amp$put_partial ALIAS 'amxputp' (file_identifier:
    amt$file_identifier;
*IF NOT $true(osv$unix)
    working_storage_area: ^cell;
*ELSE
    working_storage_area: ^string (*);
*IFEND
    working_storage_length: amt$working_storage_length;
    VAR byte_address: amt$file_byte_address;
    term_option: amt$term_option;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$TERM_OPTION
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc OST$STATUS
*IF NOT $true(osv$unix)
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$CONFLICTING_ACCESS_LEVEL
*copyc AME$IMPROPER_FILE_ID
*copyc AME$TERMINAL_VALIDATION_ERRORS
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$IMPROPER_WSL
*copyc AME$PUT_PROGRAM_ACTIONS
*ELSE
*copyc ame$condition_codes
*IFEND
?? POP ??
*DECK DECK=AMP$READ EXPAND=FALSE

  PROCEDURE [XREF] amp$read ALIAS 'amxrsq' (file_identifier:
    amt$file_identifier;
    buffer_area: ^cell;
    buffer_length: amt$buffer_length;
    VAR byte_address: amt$file_byte_address;
    VAR transfer_count: amt$physical_transfer_count;
    wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$BUFFER_LENGTH
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$PHYSICAL_TRANSFER_COUNT
*copyc OST$WAIT
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$READ_DIRECT EXPAND=FALSE

  PROCEDURE [XREF] amp$read_direct ALIAS 'amxrba' (file_identifier:
    amt$file_identifier;
    buffer_area: ^cell;
    buffer_length: amt$buffer_length;
    byte_address: amt$file_byte_address;
    VAR transfer_count: amt$physical_transfer_count;
    wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$BUFFER_LENGTH
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$PHYSICAL_TRANSFER_COUNT
*copyc OST$WAIT
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$READ_DIRECT_SKIP EXPAND=FALSE

  PROCEDURE [XREF] amp$read_direct_skip ALIAS 'amxrbas' (file_identifier:
    amt$file_identifier;
    buffer_area: ^cell;
    buffer_length: amt$skip_buffer_length;
    byte_address: amt$file_byte_address;
    VAR transfer_count: amt$physical_transfer_count;
    wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$BUFFER_LENGTH
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$PHYSICAL_TRANSFER_COUNT
*copyc OST$WAIT
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$READ_SKIP EXPAND=FALSE

  PROCEDURE [XREF] amp$read_skip ALIAS 'amxrsqs' (file_identifier:
    amt$file_identifier;
    buffer_area: ^cell;
    buffer_length: amt$skip_buffer_length;
    VAR byte_address: amt$file_byte_address;
    VAR transfer_count: amt$physical_transfer_count;
    wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$BUFFER_LENGTH
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$PHYSICAL_TRANSFER_COUNT
*copyc OST$WAIT
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$REPLACE EXPAND=FALSE

  PROCEDURE [XREF] amp$replace ALIAS 'amxrep' (file_identifier:
    amt$file_identifier;
    working_storage_area: ^cell;
    working_storage_length: amt$working_storage_length;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$REPLACE_DIRECT EXPAND=FALSE

  PROCEDURE [XREF] amp$replace_direct ALIAS 'amxrepd' (file_identifier:
    amt$file_identifier;
    working_storage_area: ^cell;
    working_storage_length: amt$working_storage_length;
    byte_address: amt$file_byte_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$REPLACE_PREVIOUS_RECORD EXPAND=FALSE

  PROCEDURE [XREF] amp$replace_previous_record (file_identifier:
    amt$file_identifier;
    working_storage_area: ^cell;
    working_storage_length: amt$working_storage_length;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$CONFLICTING_ACCESS_LEVEL
*copyc AME$IMPROPER_FILE_ID
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AME$TERMINAL_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$IMPROPER_WSL
*copyc AME$PUT_PROGRAM_ACTIONS
?? POP ??
*DECK DECK=AMP$RETURN EXPAND=FALSE

  PROCEDURE [XREF] amp$return (file: fst$file_reference;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc fst$file_reference
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$LFN_PROGRAM_ACTIONS
?? POP ??
*DECK DECK=AMP$REWIND EXPAND=FALSE

  PROCEDURE [XREF] amp$rewind (file_identifier: amt$file_identifier;
    wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$conflicting_access_level
*copyc ame$improper_file_id
*copyc ame$put_program_actions
*copyc ame$ring_validation_errors
*copyc ame$tape_program_actions
*copyc amt$file_identifier
*copyc ost$status
*copyc ost$wait
?? POP ??
*DECK DECK=AMP$REWIND_VOLUME EXPAND=FALSE

  PROCEDURE [XREF] amp$rewind_volume ALIAS 'amxrvol' (file_identifier:
    amt$file_identifier;
    wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AME$CONFLICTING_ACCESS_LEVEL
*copyc AME$IMPROPER_FILE_ID
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$PUT_PROGRAM_ACTIONS
*copyc OST$WAIT
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$SEEK_DIRECT EXPAND=FALSE

  PROCEDURE [XREF] amp$seek_direct ALIAS 'amxseek' (file_identifier:
    amt$file_identifier;
        byte_address: amt$file_byte_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$ACCESS_VALIDATION_ERRORS
*copyc AME$CONFLICTING_ACCESS_LEVEL
*copyc AME$IMPROPER_FILE_ID
*copyc AME$FILE_ORGANIZATION_ERRORS
*copyc AME$GET_VALIDATION_ERRORS
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
?? POP ??
*DECK DECK=AMP$SELECT_KEY EXPAND=FALSE
 PROCEDURE [XREF] amp$select_key (file_identifier: amt$file_identifier;
        key_name: amt$key_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$key_name
*copyc ost$status
?? POP ??
*DECK DECK=AMP$SELECT_NESTED_FILE EXPAND=FALSE
 PROCEDURE [XREF] amp$select_nested_file (file_identifier: amt$file_identifier;
        nested_file_name: amt$nested_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$nested_file_name
*copyc ost$status
?? POP ??
*DECK DECK=AMP$SEPARATE_KEY_GROUPS EXPAND=FALSE
 PROCEDURE [XREF] amp$separate_key_groups (file_identifier: amt$file_identifier;
        group: amt$group_name;
        parallel_group: amt$group_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$group_name
*copyc ost$status
?? POP ??
*DECK DECK=AMP$SET_FILE_INSTANCE_ABNORMAL EXPAND=FALSE


  PROCEDURE [XREF] amp$set_file_instance_abnormal (file_identifier:
    amt$file_identifier;
    exception_condition: ost$status_condition;
    request_code: amt$last_operation;
    text: string ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AMD$OPERATION_DECLARATIONS
?? POP ??
*DECK DECK=AMP$SET_LOCAL_NAME_ABNORMAL EXPAND=FALSE


  PROCEDURE [XREF] amp$set_local_name_abnormal (local_file_name:
    amt$local_file_name;
    exception_condition: ost$status_condition;
    request_code: amt$last_operation;
    text: string ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AMD$OPERATION_DECLARATIONS
?? POP ??
*DECK DECK=AMP$SET_SEGMENT_EOI EXPAND=FALSE

  PROCEDURE [XREF] amp$set_segment_eoi ALIAS 'amxsete' (file_identifier:
    amt$file_identifier;
        segment_pointer: amt$segment_pointer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$SEGMENT_POINTER
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$SEGMENT_VALIDATION_ERRORS
?? POP ??
*DECK DECK=AMP$SET_SEGMENT_POSITION EXPAND=FALSE

  PROCEDURE [XREF] amp$set_segment_position ALIAS 'amxsetp' (file_identifier:
    amt$file_identifier;
        segment_pointer: amt$segment_pointer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$SEGMENT_POINTER
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$SEGMENT_VALIDATION_ERRORS
?? POP ??
*DECK DECK=AMP$SIMULATOR_FAP EXPAND=FALSE

{ COMMON DECK BAXTSF }

  PROCEDURE [XREF] amp$simulator_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=AMP$SKIP EXPAND=FALSE

  PROCEDURE [XREF] amp$skip (file_identifier: amt$file_identifier;
        direction: amt$skip_direction;
        unit: amt$skip_unit;
        count: amt$skip_count;
    VAR file_position: amt$file_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc amc$condition_code_limits
*copyc amd$skip_declarations
*copyc ame$conflicting_access_level
*copyc ame$get_validation_errors
*copyc ame$improper_file_id
*copyc ame$put_program_actions
*copyc ame$ring_validation_errors
*copyc ame$skip_program_actions
*copyc ame$skip_validation_errors
*ELSE
*copyc ame$improper_skip_count
*copyc ame$improper_skip_direction
*copyc ame$improper_skip_unit
*copyc ame$skip_encountered_eoi
*IFEND
*copyc amt$file_identifier
*copyc amt$file_position
*copyc amt$skip_count
*copyc amt$skip_direction
*copyc amt$skip_unit
*copyc ost$status
?? POP ??
*DECK DECK=AMP$SKIP_TAPE_MARKS EXPAND=FALSE

  PROCEDURE [XREF] amp$skip_tape_marks (file: fst$file_reference;
        direction: amt$skip_direction;
        count: amt$tape_mark_count;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$device_class_validation
*copyc ame$lfn_program_actions
*copyc ame$skip_program_actions
*copyc ame$skip_validation_errors
*copyc ame$wtmk_validation_errors
*copyc amt$local_file_name
*copyc amt$skip_direction
*copyc amt$tape_mark_count
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=AMP$STORE EXPAND=FALSE

  PROCEDURE [XREF] amp$store ALIAS 'amxstor' (file_identifier:
    amt$file_identifier;
    file_attributes: amt$store_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$STORE_ATTRIBUTES
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$ATTRIBUTE_VALIDATION_ERRORS
*copyc AME$IMPROPER_FILE_ID
*copyc AME$RING_VALIDATION_ERRORS
?? POP ??
*DECK DECK=AMP$STORE_FAP_POINTER EXPAND=FALSE

  PROCEDURE [XREF] amp$store_fap_pointer ALIAS 'amxsfap' (file_identifier:
    amt$file_identifier;
    layer_number: amt$fap_layer_number;
    structure_pointer: ^cell;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FAP_DECLARATIONS
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$FAP_VALIDATION_ERRORS
*copyc AME$IMPROPER_FILE_ID
*copyc AME$RING_VALIDATION_ERRORS
?? POP ??
*DECK DECK=AMP$TERMINATE_FILE EXPAND=FALSE

{ COMMON DECK AMXTERF }

?? PUSH (LISTEXT := ON) ??
*copyc AMP$PUT_PARTIAL
?? POP ??

  PROCEDURE [INLINE] amp$terminate_file (file_identifier: amt$file_identifier;
        file_instance: bat$task_file_entry);

?? PUSH (LISTEXT := ON) ??

    VAR
      dummy_area: cell,
      ignore_byte_address: amt$file_byte_address,
      ignore_status: ost$status;

    CASE file_instance.instance_attributes.static_label.file_organization OF

    = amc$sequential, amc$byte_addressable =

      IF (file_instance.fap_control_information.fap_array <> NIL) AND
            (file_instance.private_read_information = NIL) AND
            (file_instance.global_file_information^.positioning_info.record_info.
            current_byte_address = file_instance.global_file_information^.
            eoi_byte_address) AND (file_instance.global_file_information^.
            positioning_info.record_info.file_position = amc$mid_record) AND
            (file_instance.global_file_information^.last_access_operation =
            amc$put_partial_req) THEN

            { terminate the file. }

            amp$put_partial (file_identifier, ^dummy_area, 0,
                  ignore_byte_address, amc$terminate, ignore_status);

      IFEND;

    ELSE
    CASEND;

  PROCEND amp$terminate_file;
?? POP ??
*DECK DECK=AMP$TST_ACCESS_INFO_OUT EXPAND=FALSE

  PROCEDURE [XREF] amp$tst_access_info_out (id: string (15);
    ai: amt$access_information;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$ACCESS_INFORMATION
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$TST_BA_OUT EXPAND=FALSE
{ common deck amxtbao }

  PROCEDURE [XREF] amp$tst_ba_out (id: string (15);
    byte_address: amt$file_byte_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc AMT$FILE_BYTE_ADDRESS
?? POP ??
*DECK DECK=AMP$TST_FID_OUT EXPAND=FALSE
{ common deck amxtfo }

  PROCEDURE [XREF] amp$tst_fid_out (identifier: string (15);
    fid: amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc AMT$FILE_IDENTIFIER
?? POP ??
*DECK DECK=AMP$TST_FILE_ATTR_OUT EXPAND=FALSE

  PROCEDURE [XREF] amp$tst_file_attr_out (id: string (15);
    ga: amt$get_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$GET_ATTRIBUTES
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$TST_FP_OUT EXPAND=FALSE
{ common deck amxtfpo }

  PROCEDURE [XREF] amp$tst_fp_out (id: string (15);
    file_position: amt$file_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc AMT$FILE_POSITION
?? POP ??
*DECK DECK=AMP$TST_GETN_OUT EXPAND=FALSE
{ common deck amxtgno }

  PROCEDURE [XREF] amp$tst_getn_out (id: string (15);
    fid: amt$file_identifier;
    wsl: amt$working_storage_length;
    record_length: amt$max_record_length;
    transfer_count: amt$transfer_count;
    byte_address: amt$file_byte_address;
    file_position: amt$file_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_POSITION
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc AMT$TRANSFER_COUNT
*copyc AMT$MAX_RECORD_LENGTH
?? POP ??
*DECK DECK=AMP$TST_OFFSET_OUT EXPAND=FALSE

  PROCEDURE [XREF] amp$tst_offset_out (id: string (15);
    pva: ^cell;
    VAR status: ost$status);
*DECK DECK=AMP$TST_PUTN_OUT EXPAND=FALSE
{ common deck amxtpno }

  PROCEDURE [XREF] amp$tst_putn_out (id: string (15);
    fid: amt$file_identifier;
    wsl: amt$working_storage_length;
    byte_address: amt$file_byte_address;
    VAR status: ost$status);

*copyc OST$STATUS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc AMT$FILE_BYTE_ADDRESS
*DECK DECK=AMP$TST_REC_TYPE_OUT EXPAND=FALSE

{ COMMON DECK AMXTRTO }

  PROCEDURE [XREF] amp$tst_rec_type_out (id: string (15);
    record_type: amt$record_type;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_ATTRIBUTES
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$TST_RL_OUT EXPAND=FALSE
{ common deck amxtrlo }

  PROCEDURE [XREF] amp$tst_rl_out (id: string (15);
    record_length: amt$max_record_length;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc AMT$MAX_RECORD_LENGTH
?? POP ??
*DECK DECK=AMP$TST_STATUS_OUT EXPAND=FALSE
{ common deck amxtso }

  PROCEDURE [XREF] amp$tst_status_out (identifier: string (15);
    status_out: ost$status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$TST_TC_OUT EXPAND=FALSE
{ common deck amxttco }

  PROCEDURE [XREF] amp$tst_tc_out (id: string (15);
    transfer_count: amt$transfer_count;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc AMT$TRANSFER_COUNT
?? POP ??
*DECK DECK=AMP$TST_WSL_OUT EXPAND=FALSE
{ common deck amxtwsl }

  PROCEDURE [XREF] amp$tst_wsl_out (id: string (15);
    wsl: amt$working_storage_length;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc AMT$WORKING_STORAGE_LENGTH
?? POP ??
*DECK DECK=AMP$UNLOCK_FILE EXPAND=FALSE
 PROCEDURE [XREF] amp$unlock_file (file_identifier: amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=AMP$UNLOCK_KEY EXPAND=FALSE
 PROCEDURE [XREF] amp$unlock_key (file_identifier: amt$file_identifier;
        unlock_all_keys: boolean;
        key_location: ^cell;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=AMP$UNPACK_BLOCK_HEADER EXPAND=FALSE

  PROCEDURE [XREF] amp$unpack_block_header ALIAS 'amxupkb' (file_identifier:
    amt$file_identifier;
    VAR buffer_area: amt$buffer_area;
    VAR header: amt$unpack_block_header;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMD$BLOCK_HEADERS
*copyc AMT$BUFFER_AREA
*copyc AMT$FILE_IDENTIFIER
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$UNPACK_RECORD_HEADER EXPAND=FALSE

  PROCEDURE [XREF] amp$unpack_record_header ALIAS 'amxupkr' (file_identifier:
    amt$file_identifier;
    VAR buffer_area: amt$buffer_area;
    VAR header: amt$record_header;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$BUFFER_AREA
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$RECORD_HEADER
*copyc AMT$SEGMENT_POINTER
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$VALIDATE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] amp$validate_attributes
    (    file: fst$file_reference;
         request_code: amt$last_operation;
         validation_ring: ost$valid_ring;
         attributes: ^amt$file_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_attributes
*copyc amd$operation_declarations
*copyc amt$local_file_name
*copyc fst$file_reference
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=AMP$VALIDATE_CALLER_PRIVILEGE EXPAND=FALSE

  PROCEDURE [XREF] amp$validate_caller_privilege ALIAS 'amxvcp'
    (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
        required_write_privilege: pft$usage_selections;
        caller_ring_number: ost$ring;
    VAR structure_pointer: ^cell;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FAP_DECLARATIONS
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$ACCESS_VALIDATION_ERRORS
*copyc AME$IMPROPER_FILE_ID
?? POP ??
*DECK DECK=AMP$WRITE EXPAND=FALSE

  PROCEDURE [XREF] amp$write ALIAS 'amxwsq' (file_identifier:
    amt$file_identifier;
    buffer_area: ^cell;
    buffer_length: amt$buffer_length;
    VAR byte_address: amt$file_byte_address;
    wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$BUFFER_LENGTH
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc OST$WAIT
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$WRITE_DIRECT EXPAND=FALSE

  PROCEDURE [XREF] amp$write_direct ALIAS 'amxwba' (file_identifier:
    amt$file_identifier;
    buffer_area: ^cell;
    buffer_length: amt$buffer_length;
    byte_address: amt$file_byte_address;
    wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$BUFFER_LENGTH
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc OST$WAIT
*copyc OST$STATUS
?? POP ??
*DECK DECK=AMP$WRITE_END_PARTITION EXPAND=FALSE

  PROCEDURE [XREF] amp$write_end_partition ALIAS 'amxendp' (file_identifier:
    amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$CONFLICTING_ACCESS_LEVEL
*copyc AME$IMPROPER_FILE_ID
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$WRITE_EOP_VALIDATION_ERRORS
?? POP ??
*DECK DECK=AMP$WRITE_TAPE_MARK EXPAND=FALSE

  PROCEDURE [XREF] amp$write_tape_mark ALIAS 'amxwtmk' (file_identifier:
    amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc OST$STATUS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$CONFLICTING_ACCESS_LEVEL
*copyc AME$DEVICE_CLASS_VALIDATION
*copyc AME$IMPROPER_FILE_ID
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$WTMK_VALIDATION_ERRORS
*copyc AME$PUT_PROGRAM_ACTIONS
?? POP ??
*DECK DECK=AMT$ACCESS_INFO EXPAND=FALSE
 TYPE
    amt$access_info = record
      item_returned {output} : boolean,
      case key {input} : amt$access_info_keys of {output}
      = amc$altered_not_closed  =
        altered_not_closed: boolean,
      = amc$block_number =
        block_number: amt$block_number,
      = amc$current_byte_address =
        current_byte_address: amt$file_byte_address,
      = amc$duplicate_value_inserted =
        duplicate_value_inserted: boolean,
      = amc$eoi_byte_address =
        eoi_byte_address: amt$file_byte_address,
      = amc$error_count =
        error_count: amt$error_count,
      = amc$error_status =
        error_status: ost$status_condition,
      = amc$file_position =
        file_position: amt$file_position,
      = amc$last_access_operation =
        last_access_operation: amt$last_access_operation,
      = amc$last_op_status =
        last_op_status: amt$last_op_status,
      = amc$levels_of_indexing =
        levels_of_indexing: amt$index_levels,
      = amc$lock_file_residence =
        lock_file_scope: amt$lock_file_scope,
        lock_file_path: ^fst$path,
      = amc$null_item =
        ,
      = amc$number_of_nested_files =
        number_of_nested_files: amt$nested_file_count,
      = amc$number_of_volumes =
        number_of_volumes: amt$volume_number,
      = amc$physical_volume_position =
        physical_volume_position: amt$physical_volume_position,
      = amc$previous_record_address =
        previous_record_address: amt$file_byte_address,
      = amc$previous_record_length =
        previous_record_length: amt$max_record_length,
      = amc$primary_key =
        primary_key: amt$primary_key,
      = amc$residual_skip_count =
        residual_skip_count: amt$residual_skip_count,
      = amc$segment_count =
        segment_count: ost$segment,
      = amc$segment_information =
        segment_information: ^array [ 1 .. * ] of
          amt$keyed_file_segment_info,
      = amc$selected_key_name =
        selected_key_name: amt$selected_key_name,
      = amc$selected_nested_file =
        selected_nested_file: amt$selected_nested_file,
      = amc$size_in_blocks =
        size_in_blocks: 1 .. amc$file_byte_limit,
      = amc$tape_element_name =
        tape_element_name: ost$name,
      = amc$tape_failure_isolation =
        tape_failure_isolation: amt$tape_failure_isolation,
      = amc$volume_description =
        volume_index {input} : amt$volume_number,
        volume_description {output} : rmt$volume_descriptor,
      = amc$volume_number =
        volume_number: amt$volume_number,
      = amc$volume_position =
        volume_position: amt$volume_position,
      casend
    recend;

*copyc amd$information
*copyc amd$operation_declarations
*copyc amd$page_format_declarations
*copyc amt$access_info_keys
*copyc amt$block_number
*copyc amt$file_byte_address
*copyc amt$file_position
*copyc amt$index_levels
*copyc amt$keyed_file_segment_info
*copyc amt$last_access_operation
*copyc amt$lock_file_scope
*copyc amt$max_record_length
*copyc amt$nested_file_count
*copyc amt$physical_volume_position
*copyc amt$primary_key
*copyc amt$selected_key_name
*copyc amt$selected_nested_file
*copyc amt$tape_failure_isolation
*copyc amt$volume_position
*copyc fst$path
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
*copyc rmd$volume_declarations
*DECK DECK=AMT$ACCESS_INFORMATION EXPAND=FALSE
 TYPE
    amt$access_information = array [1 .. * ] of amt$access_info;

*copyc amt$access_info
*DECK DECK=AMT$ACCESS_INFO_KEYS EXPAND=FALSE
 CONST
    amc$block_number = 1,
    amc$current_byte_address = 2,
    amc$duplicate_value_inserted = 3,
    amc$eoi_byte_address = 4,
    amc$error_count = 5, {Supported only for indexed_sequential files}
    amc$error_status = 6,
    amc$file_position = 7,
    amc$last_access_operation = 8,
    amc$last_op_status = 9,
    amc$levels_of_indexing = 10, {Supported only for indexed_sequential files}
    amc$null_item = 11,
    amc$number_of_nested_files = 12,
    amc$number_of_volumes = 13,
    amc$previous_record_address = 14,
    amc$previous_record_length = 15,
    amc$primary_key = 16,
    amc$residual_skip_count = 17,
    amc$selected_key_name = 18,
    amc$selected_nested_file = 19,
    amc$tape_failure_isolation = 20,
    amc$volume_description = 21,
    amc$volume_number = 22,
    amc$volume_position = 23,
    amc$lock_file_residence = 24,
    amc$altered_not_closed = 25,
    amc$segment_count = 26,
    amc$segment_information = 27,
    amc$size_in_blocks = 28,
    amc$physical_volume_position = 29,
    amc$tape_element_name = 30,
{}
    amc$max_info = 01ff(16);

  TYPE
    amt$access_info_keys = 1 .. amc$max_info;
*DECK DECK=AMT$ACCESS_LEVEL EXPAND=FALSE
 TYPE
    amt$access_level = (amc$physical, amc$record, amc$segment);
*DECK DECK=AMT$ACCESS_LEVEL_NAME EXPAND=FALSE

  TYPE
    amt$access_level_name = record
      name: string (8),
      size: 6 .. 8,
    recend;

*DECK DECK=AMT$ADD_TO_ATTRIBUTES EXPAND=FALSE


  TYPE
    amt$add_to_attributes = array [1 .. * ] of amt$add_to_item,
    amt$add_to_item = record
      case key {input} : amt$file_attribute_keys of {input}

{
{ The caller of amp$add_to_file_description must initialize the tag field
{ selector
{ (key) and store the indicated attribute value into this record before
{ calling amp$add_to_file_description.
{

      = amc$character_conversion =
        character_conversion: boolean,
      = amc$file_contents =
        file_contents: amt$file_contents,
      = amc$file_limit =
        file_limit: amt$file_limit,
      = amc$file_processor =
        file_processor: amt$file_processor,
      = amc$file_structure =
        file_structure: amt$file_structure,
      = amc$forced_write =
        forced_write: amt$forced_write,
      = amc$internal_code =
        internal_code: amt$internal_code,
      = amc$line_number =
        line_number: amt$line_number,
      = amc$max_block_length =
        max_block_length: amt$max_block_length,
      = amc$max_record_length =
        max_record_length: amt$max_record_length,
      = amc$min_block_length =
        min_block_length: amt$min_block_length,
      = amc$min_record_length =
        min_record_length: amt$min_record_length,
      = amc$null_attribute =
        ,
      = amc$padding_character =
        padding_character: amt$padding_character,
      = amc$page_format =
        page_format: amt$page_format,
      = amc$page_length =
        page_length: amt$page_length,
      = amc$page_width =
        page_width: amt$page_width,
      = amc$record_type =
        record_type: amt$record_type,
      = amc$statement_identifier =
        statement_identifier: amt$statement_identifier,
      = amc$user_info =
        user_info: amt$user_info,
      = amc$vertical_print_density =
        vertical_print_density: amt$vertical_print_density,

{
{ The following attributes are only used to describe files which
{ are accessed with the Advanced Access Method (AAM). The
{ documentation of the AAM attributes are found in the AAM ERS.
{

      = amc$average_record_length =
        average_record_length: amt$average_record_length,
      = amc$collate_table =
        collate_table: ^amt$collate_table,
      = amc$data_padding =
        data_padding: amt$data_padding,
      = amc$embedded_key =
        embedded_key: boolean,
      = amc$estimated_record_count =
        estimated_record_count: amt$estimated_record_count,
      = amc$index_levels =
        index_levels: amt$index_levels,
      = amc$index_padding =
        index_padding: amt$index_padding,
      = amc$key_length =
        key_length: amt$key_length,
      = amc$key_position =
        key_position: amt$key_position,
      = amc$key_type =
        key_type: amt$key_type,
      = amc$log_residence =
        log_residence: ^amt$log_residence,
      = amc$record_limit =
        record_limit: amt$record_limit,
      = amc$records_per_block =
        records_per_block: amt$records_per_block,
      casend
    recend;

*copyc amd$file_attributes
*copyc amt$log_residence
*copyc amd$block_headers
*copyc amd$file_contents
*copyc amd$file_processor
*copyc amd$file_structure
*copyc amt$index_levels
*copyc amt$line_number
*copyc amt$max_block_length
*copyc amt$max_record_length
*copyc amd$page_format_declarations
*copyc amt$statement_identifier
*copyc pmt$program_name
*copyc ost$clear_file_space
*DECK DECK=AMT$ALLOCATION_MODE EXPAND=FALSE

  TYPE
    amt$allocation_amount = 1 .. amc$file_byte_limit,
    amt$allocation_mode = (amc$current_volume, amc$switch_volumes);

*copyc AMT$FILE_BYTE_ADDRESS
*DECK DECK=AMT$ATTRIBUTE_SOURCE EXPAND=FALSE

  TYPE
    amt$attribute_source = (amc$undefined_attribute,
      amc$local_file_information, amc$change_file_attributes, amc$open_request,
      amc$file_reference, amc$file_command, amc$file_request,
      amc$add_to_file_description, amc$access_method_default,
      amc$store_request);
*DECK DECK=AMT$AVERAGE_RECORD_LENGTH EXPAND=FALSE
 TYPE
    amt$average_record_length = 1 .. amc$maximum_record;

*copyc amt$max_record_length
*DECK DECK=AMT$BACKUP_INFORMATION EXPAND=FALSE
 { AMT$BACKUP_INFORMATION }

  TYPE
    amt$backup_information = RECORD
      CASE media: rmt$device_class OF
      = rmc$magnetic_tape_device =
        class: rmt$tape_class,
        density: rmt$density,
      = rmc$mass_storage_device =
        file_path : fst$path,
      CASEND,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc fst$path
*copyc rmt$density
*copyc rmt$device_class
*copyc rmt$tape_class
?? POP ??
*DECK DECK=AMT$BASIC_KEY_DEFINITION EXPAND=FALSE
 TYPE
    amt$basic_key_definition = record
      case definition_returned: boolean of
      = TRUE =
        key_name: amt$key_name,
        key_position: amt$key_position,
        key_length: amt$key_length,
        number_of_optional_attributes: amt$max_optional_attributes,
      casend,
    recend;

*copyc amt$key_length
*copyc amt$key_name
*copyc amt$key_position
*copyc amt$max_optional_attributes
*DECK DECK=AMT$BEGIN_FILE_PARCEL EXPAND=FALSE
 TYPE
    amt$begin_file_parcel = record
      general_commit: amt$general_commit,
    recend;

*copyc amt$general_commit
*DECK DECK=AMT$BLOCK_NUMBER EXPAND=FALSE

  CONST
*IF NOT $true(osv$unix)
    amc$max_block_number = 0ffffffff(16);
*ELSE
    amc$max_block_number = 7fffffff(16);
*IFEND

  TYPE
    amt$block_number = 1 .. amc$max_block_number;
*DECK DECK=AMT$BLOCK_TYPE EXPAND=FALSE
 TYPE
    amt$block_type = (amc$system_specified, amc$user_specified);
*DECK DECK=AMT$BLOCK_TYPE_NAME EXPAND=FALSE

  TYPE
    amt$block_type_name = record
      name: string (21),
      size: 19 .. 21,
    recend;

*DECK DECK=AMT$BUFFER_AREA EXPAND=FALSE

  TYPE
    amt$buffer_area = ^SEQ ( * );
*DECK DECK=AMT$BUFFER_LENGTH EXPAND=FALSE


  CONST
    amc$max_buffer_length = 16777215 {2**24 - 1 bytes} ;

  TYPE
    amt$buffer_length = amc$mau_length .. amc$max_buffer_length,
    amt$skip_buffer_length = 1 .. amc$max_buffer_length;

*copyc AMT$MAU_LENGTH
*DECK DECK=AMT$CALL_BLOCK EXPAND=FALSE
 TYPE
    amt$call_block = record
      case operation: amt$fap_operation of
      = amc$abandon_key_definitions =
        ,
      = amc$abort_file_parcel =
        ,
      = amc$apply_key_definitions =
        ,
      = amc$begin_file_parcel =
        begin_file_parcel: amt$begin_file_parcel,
      = amc$check_buffer_req =
        check_buffer: amt$check_buffer_req,
      = amc$check_nowait_request =
        check_nowait_request: amt$check_nowait_request,
      = amc$check_record_req =
        check_record: amt$check_record_req,
      = amc$close_req =
        ,
      = amc$close_volume_req =
        ,
      = amc$commit_file_parcel =
        commit_file_parcel: amt$commit_file_parcel,
      = amc$create_key_definition =
        create_key_definition: amt$create_key_definition,
      = amc$create_nested_file =
        create_nested_file: amt$create_nested_file,
      = amc$delete_req =
        ,
      = amc$delete_direct_req =
        deld: amt$delete_direct_req,
      = amc$delete_key_req =
        delk: amt$delete_key_req,
      = amc$delete_key_definition =
        delete_key_definition: amt$delete_key_definition,
      = amc$delete_nested_file =
        delete_nested_file: amt$delete_nested_file,
      = amc$erase_tape_block =
        erase_tape_block: amt$erase_tape_block,
      = amc$fetch_req =
        fetch: amt$fetch_req,
      = amc$fetch_access_information_rq =
        fai: amt$fetch_access_information_rq,
      = amc$fetch_nested_file_attrib =
        fetch_nested_file_attrib: amt$fetch_nested_file_attrib_rq,
      = amc$find_record_space =
        find_record_space: amt$find_record_space,
      = amc$flush_req =
        flush: amt$flush_req,
      = amc$get_direct_req =
        getd: amt$get_direct_req,
      = amc$get_key_req =
        getk: amt$get_key_req,
      = amc$get_key_definitions =
        get_key_definitions: amt$get_key_definitions,
      = amc$get_lock_keyed_record =
        get_lock_keyed_record: amt$get_lock_keyed_record,
      = amc$get_lock_next_keyed_record =
        get_lock_next_keyed_record: amt$get_lock_next_keyed_record,
      = amc$get_nested_file_definitions =
        get_nested_file_definitions: amt$get_nested_file_definitions,
      = amc$get_next_req =
        getn: amt$get_next_req,
      = amc$get_next_key_req =
        getnk: amt$get_next_key_req,
      = amc$get_next_primary_key_list =
        get_next_primary_key_list: amt$get_next_primary_key_list,
      = amc$get_partial_req =
        getp: amt$get_partial_req,
      = amc$get_primary_key_count =
        get_primary_key_count: amt$get_primary_key_count,
      = amc$get_segment_pointer_req =
        getsegp: amt$get_segment_pointer_req,
      = amc$get_space_used_for_key =
        get_space_used_for_key: amt$get_space_used_for_key,
      = amc$lock_file_req =
        lock_file: amt$lock_file,
      = amc$lock_key =
        lock_key: amt$lock_key,
      = amc$open_req =
        open: amt$open_req,
      = amc$pack_block_req =
        packb: amt$pack_block_req,
      = amc$pack_record_req =
        packr: amt$pack_record_req,
      = amc$put_direct_req =
        putd: amt$put_direct_req,
      = amc$put_key_req =
        putk: amt$put_key_req,
      = amc$put_next_req =
        putn: amt$put_next_req,
      = amc$put_partial_req =
        putp: amt$put_partial_req,
      = amc$putrep_req =
        putrep: amt$putrep_req,
      = amc$read_req =
        rsq: amt$read_req,
      = amc$read_direct_req =
        rba: amt$read_direct_req,
      = amc$read_direct_skip_req =
        rbaskp: amt$read_direct_skip_req,
      = amc$read_skip_req =
        rsqskp: amt$read_skip_req,
      = amc$replace_req =
        replace: amt$replace_req,
      = amc$replace_direct_req =
        repld: amt$replace_direct_req,
      = amc$replace_key_req =
        repk: amt$replace_key_req,
      = amc$rewind_req =
        rewind: amt$rewind_req,
      = amc$rewind_volume_req =
        rewvol: amt$rewind_volume_req,
      = amc$seek_direct_req =
        seekd: amt$seek_direct_req,
      = amc$select_key =
        select_key: amt$select_key,
      = amc$select_nested_file =
        select_nested_file: amt$select_nested_file,
      = amc$separate_key_groups =
        separate_key_groups: amt$separate_key_groups,
      = amc$set_segment_eoi_req =
        segeoi: amt$set_segment_eoi_req,
      = amc$set_segment_position_req =
        segpos: amt$set_segment_position_req,
      = amc$skip_req =
        skp: amt$skip_req,
      = amc$start_req =
        start: amt$start_req,
      = amc$store_req =
        store: amt$store_req,
      = amc$unlock_file_req =
        ,
      = amc$unlock_key =
        unlock_key: amt$unlock_key,
      = amc$unpack_block_req =
        unpackb: amt$unpack_block_req,
      = amc$unpack_record_req =
        unpackr: amt$unpack_record_req,
      = amc$user_defined_access_request =
        user_defined_access_request: amt$user_defined_access_request,
      = amc$write_req =
        wsq: amt$write_req,
      = amc$write_direct_req =
        wba: amt$write_direct_req,
      = amc$write_end_partition_req =
        ,
      = amc$write_tape_mark_req =
        ,
      = ifc$fetch_terminal_req =
        fetch_terminal: ift$fetch_terminal_req,
      = ifc$store_terminal_req =
        store_terminal: ift$store_terminal_req,
      = nac$se_send_data_req =
        se_send_data_req: nat$se_send_data_req,
      = nac$se_receive_data_req =
        se_receive_data_req: nat$se_receive_data_req,
      = nac$se_interrupt_req =
        se_interrupt_data: ^SEQ (*),
      = nac$se_synchronize_req =
        se_synchronize_req: nat$se_synchronize_req,
      = nac$se_synchronize_confirm_req =
        ,
      = nac$await_data_available =
        await_data_available: nat$await_data_available,
      = nac$fetch_attributes =
        fetch_attributes: ^nat$get_attributes,
      = nac$store_attributes =
        store_attributes: ^nat$change_attributes,
      = nac$se_get_avail_byte_count_req =
        se_get_available_byte_count: ^nat$data_length,

{ The following call block requests are only available to writers
{ of system faps. These call blocks may not be used by the users
{ of the system.

      = amc$enforce_tape_security =
        enforce_tape_security: ^SEQ ( * ),
      = amc$extend_volume_list =
        extend_volume_list: ^amt$open_tape_volume,
      = amc$dismount_current_volume =
        ,
      = amc$open_tape_volume =
        open_tape_volume: ^amt$open_tape_volume,
      = amc$read_tape_labels =
        read_tape_labels: ^amt$read_tape_labels,
      = amc$terminate_tape_volume =
        terminate_tape_volume: ^amt$terminate_tape_volume,
      = amc$write_tape_labels =
        write_tape_labels: ^SEQ ( * ),
      casend,
    recend,

    amt$check_buffer_req = record
      buffer_area: ^cell,
      request_complete: ^boolean,
      byte_address: ^amt$file_byte_address,
      transfer_count: ^amt$physical_transfer_count,
      wait: ost$wait,
    recend,
    amt$check_record_req = record
      working_storage_area: ^cell,
      request_complete: ^boolean,
      record_length: ^amt$max_record_length,
      file_position: ^amt$file_position,
      wait: ost$wait,
    recend,
    amt$delete_direct_req = record
      byte_address: amt$file_byte_address,
    recend,
    amt$delete_key_req = record
      key_location: ^cell,
      wait: ost$wait,
    recend,
    amt$fetch_access_information_rq = record
      access_information: ^amt$access_information,
    recend,
    amt$fetch_nested_file_attrib_rq = record
      keyed_file_attributes: ^amt$keyed_file_attributes,
    recend,
    amt$fetch_req = record
      file_attributes: ^amt$fetch_attributes,
    recend,
    amt$flush_req = record
      wait: ost$wait,
    recend,
    amt$get_direct_req = record
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length,
      transfer_count: ^amt$transfer_count,
      byte_address: amt$file_byte_address,
      file_position: ^amt$file_position,
    recend,
    amt$get_key_req = record
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length,
      key_location: ^cell,
      major_key_length: amt$major_key_length,
      key_relation: amt$key_relation,
      record_length: ^amt$max_record_length,
      file_position: ^amt$file_position,
      wait: ost$wait,
    recend,
    amt$get_next_req = record
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length,
      transfer_count: ^amt$transfer_count,
      byte_address: ^amt$file_byte_address,
      file_position: ^amt$file_position,
    recend,
    amt$get_next_key_req = record
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length,
      key_location: ^cell,
      record_length: ^amt$max_record_length,
      file_position: ^amt$file_position,
      wait: ost$wait,
    recend,
    amt$get_partial_req = record
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length,
      record_length: ^amt$max_record_length,
      transfer_count: ^amt$transfer_count,
      byte_address: ^amt$file_byte_address,
      file_position: ^amt$file_position,
      skip_option: amt$skip_option,
    recend,
    amt$get_segment_pointer_req = record
      pointer_kind: amt$pointer_kind,
      segment_pointer: ^amt$segment_pointer,
    recend,
    amt$open_req = record
      local_file_name: amt$local_file_name,
      access_level: amt$access_level,
      existing_file: boolean,
      contains_data: boolean,
    recend,
    amt$pack_block_req = record
      buffer_area: amt$buffer_area,
      header: amt$pack_block_header,
    recend,
    amt$pack_record_req = record
      buffer_area: amt$buffer_area,
      header: amt$record_header,
    recend,
    amt$put_direct_req = record
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length,
      byte_address: amt$file_byte_address,
    recend,
    amt$put_key_req = record
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length,
      key_location: ^cell,
      wait: ost$wait,
    recend,
    amt$put_next_req = record
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length,
      byte_address: ^amt$file_byte_address,
    recend,
    amt$put_partial_req = record
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length,
      byte_address: ^amt$file_byte_address,
      term_option: amt$term_option,
    recend,
    amt$putrep_req = record
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length,
      key_location: ^cell,
      wait: ost$wait,
    recend,
    amt$read_req = record
      buffer_area: ^cell,
      buffer_length: amt$buffer_length,
      byte_address: ^amt$file_byte_address,
      transfer_count: ^amt$physical_transfer_count,
      wait: ost$wait,
    recend,
    amt$read_direct_req = record
      buffer_area: ^cell,
      buffer_length: amt$buffer_length,
      byte_address: amt$file_byte_address,
      transfer_count: ^amt$physical_transfer_count,
      wait: ost$wait,
    recend,
    amt$read_direct_skip_req = record
      buffer_area: ^cell,
      buffer_length: amt$buffer_length,
      byte_address: amt$file_byte_address,
      transfer_count: ^amt$physical_transfer_count,
      wait: ost$wait,
    recend,
    amt$read_skip_req = record
      buffer_area: ^cell,
      buffer_length: amt$buffer_length,
      byte_address: ^amt$file_byte_address,
      transfer_count: ^amt$physical_transfer_count,
      wait: ost$wait,
    recend,
    amt$replace_req = record
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length,
    recend,
    amt$replace_direct_req = record
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length,
      byte_address: amt$file_byte_address,
    recend,
    amt$replace_key_req = record
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length,
      key_location: ^cell,
      wait: ost$wait,
    recend,
    amt$rewind_req = record
      wait: ost$wait,
    recend,
    amt$rewind_volume_req = record
      wait: ost$wait,
    recend,
    amt$seek_direct_req = record
      byte_address: amt$file_byte_address,
    recend,
    amt$set_segment_eoi_req = record
      segment_pointer: amt$segment_pointer,
    recend,
    amt$set_segment_position_req = record
      segment_pointer: amt$segment_pointer,
    recend,
    amt$skip_req = record
      direction: amt$skip_direction,
      unit: amt$skip_unit,
      count: amt$skip_count,
      file_position: ^amt$file_position,
    recend,
    amt$start_req = record
      key_location: ^cell,
      major_key_length: amt$major_key_length,
      key_relation: amt$key_relation,
      file_position: ^amt$file_position,
      wait: ost$wait,
    recend,
    amt$store_req = record
      file_attributes: ^amt$store_attributes,
    recend,
    amt$unpack_block_req = record
      buffer_area: amt$buffer_area,
      header: ^amt$unpack_block_header,
    recend,
    amt$unpack_record_req = record
      buffer_area: amt$buffer_area,
      header: ^amt$record_header,
    recend,
    amt$write_req = record
      buffer_area: ^cell,
      buffer_length: amt$buffer_length,
      byte_address: ^amt$file_byte_address,
      wait: ost$wait,
    recend,
    amt$write_direct_req = record
      buffer_area: ^cell,
      buffer_length: amt$buffer_length,
      byte_address: amt$file_byte_address,
      wait: ost$wait,
    recend,
    ift$fetch_terminal_req = record
      terminal_attributes: ^ift$get_connection_attributes,
    recend,
    ift$store_terminal_req = record
      terminal_attributes: ^ift$connection_attributes,
    recend;

*copyc amd$block_headers
*copyc amd$file_attributes
*copyc amd$open_declarations
*copyc amd$operation_declarations
*copyc amd$skip_declarations
*copyc amt$access_information
*copyc amt$begin_file_parcel
*copyc amt$buffer_area
*copyc amt$buffer_length
*copyc amt$check_nowait_request
*copyc amt$commit_file_parcel
*copyc amt$create_key_definition
*copyc amt$create_nested_file
*copyc amt$delete_key_definition
*copyc amt$delete_nested_file
*copyc amt$erase_tape_block
*copyc amt$fap_operation
*copyc amt$fetch_attributes
*copyc amt$file_byte_address
*copyc amt$file_identifier
*copyc amt$file_position
*copyc amt$find_record_space
*copyc amt$get_key_definitions
*copyc amt$get_lock_keyed_record
*copyc amt$get_lock_next_keyed_record
*copyc amt$get_nested_file_definitions
*copyc amt$get_next_primary_key_list
*copyc amt$get_primary_key_count
*copyc amt$get_space_used_for_key
*copyc amt$key_relation
*copyc amt$keyed_file_attributes
*copyc amt$last_access_operation
*copyc amt$local_file_name
*copyc amt$lock_file
*copyc amt$lock_key
*copyc amt$major_key_length
*copyc amt$max_record_length
*copyc amt$open_tape_volume
*copyc amt$physical_transfer_count
*copyc amt$read_tape_labels
*copyc amt$record_header
*copyc amt$segment_pointer
*copyc amt$select_key
*copyc amt$select_nested_file
*copyc amt$separate_key_groups
*copyc amt$skip_option
*copyc amt$store_attributes
*copyc amt$terminate_tape_volume
*copyc amt$term_option
*copyc amt$transfer_count
*copyc amt$unlock_key
*copyc amt$user_defined_access_request
*copyc amt$working_storage_length
*copyc ift$get_connection_attributes
*copyc ift$connection_attributes
*copyc nat$await_data_available
*copyc nat$change_attributes
*copyc nat$data_length
*copyc nat$get_attributes
*copyc nat$se_receive_data_req
*copyc nat$se_send_data_req
*copyc nat$se_synchronize_req
*copyc ost$activity_status
*copyc ost$status
*copyc ost$wait
*DECK DECK=AMT$CHECK_NOWAIT_REQUEST EXPAND=FALSE
 TYPE
    amt$check_nowait_request = record
      request_complete: ^boolean,
      returned_parameters: ^amt$nowait_var_parameters,
      request_status: ^ost$status,
      wait: ost$wait,
    recend;

*copyc amt$nowait_var_parameters
*copyc ost$status
*copyc ost$wait
*DECK DECK=AMT$COLLATE_TABLE EXPAND=FALSE
 TYPE
    amt$collate_table = array [char] of amt$collation_value;

*copyc amt$collation_value
*DECK DECK=AMT$COLLATION_VALUE EXPAND=FALSE
 TYPE
    amt$collation_value = 0 .. 255;
*DECK DECK=AMT$COMMIT_FILE_PARCEL EXPAND=FALSE
 TYPE
    amt$commit_file_parcel = record
      phase: amt$commit_phase,
    recend;

*copyc amt$commit_phase
*DECK DECK=AMT$COMMIT_PHASE EXPAND=FALSE
 TYPE
    amt$commit_phase = (amc$simple_commit, amc$tentative_commit,
      amc$permanent_commit);
*DECK DECK=AMT$COMPRESSION_EFFECT EXPAND=FALSE
 TYPE
    amt$compression_effect = (amc$compress, amc$decompress);
*DECK DECK=AMT$COMPRESSION_PROCEDURE EXPAND=FALSE
 TYPE
    amt$compression_procedure = ^procedure (effect: amt$compression_effect;
      input_working_storage_area: ^cell;
      input_working_storage_length: amt$max_record_length;
      output_working_storage_area: ^cell;
      VAR output_working_storage_length: amt$max_record_length;
      VAR record_left_uncompressed: boolean;
      VAR status: ost$status);

*copyc amt$compression_effect
*copyc amt$max_record_length
*copyc ost$status
*DECK DECK=AMT$COMPRESSION_PROCEDURE_NAME EXPAND=FALSE
 TYPE
    amt$compression_procedure_name = amt$entry_point_reference;

*copyc amt$entry_point_reference
*DECK DECK=AMT$COPY_EXTENT EXPAND=FALSE

  CONST
    amc$max_partition_count = 0ffff(16);

  TYPE
    amt$copy_extent = record
      case extent: amt$copy_extent_options of
      = amc$partition_count_delimited =
        partition_count: amt$copy_partition_count,
      = amc$record_count_delimited =
        record_count: amt$copy_record_count,
      casend,
    recend,
    amt$copy_extent_options = (amc$record_count_delimited,
      amc$partition_count_delimited, amc$eoi_delimited),
    amt$copy_partition_count = 0 .. amc$max_partition_count,
    amt$copy_record_count = 0 .. amc$file_byte_limit,
    amt$copy_byte_ordinal = 1 .. amc$maximum_record;

*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$MAX_RECORD_LENGTH
*DECK DECK=AMT$CREATE_KEY_DEFINITION EXPAND=FALSE
 TYPE
    amt$create_key_definition = record
      key_name: amt$key_name,
      key_position: amt$key_position,
      key_length: amt$key_length,
      optional_attributes: ^amt$optional_key_attributes,
    recend;

*copyc amt$key_length
*copyc amt$key_name
*copyc amt$key_position
*copyc amt$optional_key_attributes
*DECK DECK=AMT$CREATE_NESTED_FILE EXPAND=FALSE
 TYPE
    amt$create_nested_file = record
      definition: ^amt$nested_file_definition,
    recend;

*copyc amt$nested_file_definition
*DECK DECK=AMT$DATA_BLOCK_COUNT EXPAND=FALSE
 TYPE
    amt$data_block_count = 1 .. amc$max_blocks_per_file;

*copyc amd$max_blocks_per_file
*DECK DECK=AMT$DATA_PADDING EXPAND=FALSE
 TYPE

    amt$data_padding = 0 .. 99 {expressed as a percentage} ;
*DECK DECK=AMT$DELETE_KEY_DEFINITION EXPAND=FALSE
 TYPE
    amt$delete_key_definition = record
      key_name: amt$key_name,
    recend;

*copyc amt$key_name
*DECK DECK=AMT$DELETE_NESTED_FILE EXPAND=FALSE
 TYPE
    amt$delete_nested_file = record
      nested_file_name: amt$nested_file_name,
    recend;

*copyc amt$nested_file_name
*DECK DECK=AMT$DEVICE_CLASS_NAME EXPAND=FALSE

  TYPE
    amt$device_class_name = record
      name: string (22),
      size: 10 .. 22,
    recend;

*DECK DECK=AMT$DISPLAY_LNT_OPTIONS EXPAND=FALSE

  TYPE
    amt$display_lnt_options = (amc$display_lnt_entry, amc$display_lnt_lfd,
      amc$display_lnt_gfi, amc$display_lnt_jft_entry, amc$display_lnt_tsd),

    amt$display_lnt_option_list = set of amt$display_lnt_options;

  TYPE
    amt$selection_criteria = (amc$select_all_lnt_entry, amc$select_all_lfd,
      amc$select_all_local_file, amc$select_all_attached_files,
      amc$select_all_tapes, amc$select_all_null, amc$select_all_terminal,
      amc$select_all_ms, amc$select_all_pf, amc$select_all_with_label_cat);
*DECK DECK=AMT$DISPLAY_TFT_OPTIONS EXPAND=FALSE

TYPE
  amt$display_tft_options = (amc$display_tft_file_ident,
    amc$display_tft_entry, amc$display_tft_fap_info,
    amc$display_tft_ftd, amc$display_tft_buf_descriptor,
    amc$display_tft_tape_bd, amc$display_tft_gfi),

  amt$display_tft_option_list = set of amt$display_tft_options;
*DECK DECK=AMT$DUPLICATE_KEY_CONTROL EXPAND=FALSE
 TYPE
    amt$duplicate_key_control = (amc$no_duplicates_allowed,
      amc$first_in_first_out, amc$ordered_by_primary_key, amc$bit_map);
*DECK DECK=AMT$DUPLICATE_VALUE_INSERTED EXPAND=FALSE
 TYPE
    amt$duplicate_value_inserted = boolean;
*DECK DECK=AMT$DYNAMIC_HOME_BLOCK_SPACE EXPAND=FALSE
 TYPE
    amt$dynamic_home_block_space = boolean;
*DECK DECK=AMT$ENTRY_POINT_REFERENCE EXPAND=FALSE
 TYPE
    amt$entry_point_reference = record
      name: pmt$program_name,
      object_library: amt$path_name,
    recend;

*copyc amt$path_name
*copyc pmt$program_name
*DECK DECK=AMT$ERASE_TAPE_BLOCK EXPAND=FALSE
 TYPE
    amt$erase_tape_block = record
      block_length: amt$max_block_length,
    recend;

*copyc amt$max_block_length
*DECK DECK=AMT$ERROR_COUNT EXPAND=FALSE

  CONST
    amc$max_error_count = 0ffff(16);

  TYPE
    amt$error_count = 0 .. amc$max_error_count;
*DECK DECK=AMT$ERROR_EXIT_PROCEDURE EXPAND=FALSE
 TYPE
    amt$error_exit_procedure = ^procedure (file_identifier:
      amt$file_identifier;
      VAR status: ost$status);

*copyc amt$file_identifier
*copyc ost$status
*DECK DECK=AMT$ERROR_LIMIT EXPAND=FALSE

  TYPE
    amt$error_limit = 0 .. 0ffff(16);

*copyc amt$error_count
*DECK DECK=AMT$ESTIMATED_RECORD_COUNT EXPAND=FALSE
 TYPE
    amt$estimated_record_count = integer;
*DECK DECK=AMT$EVICT_MODE EXPAND=FALSE

  TYPE
    amt$evict_mode = (amc$release_unused, amc$redefine_eoi);
*DECK DECK=AMT$FAP_DECLARATIONS EXPAND=FALSE
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc amt$fap_pointer



*DECK DECK=AMT$FAP_LAYER_NUMBER EXPAND=FALSE
 TYPE
    amt$fap_layer_number = 0 .. amc$max_fap_layers;

*copyc amc$max_fap_layers


*DECK DECK=AMT$FAP_OPERATION EXPAND=FALSE
 TYPE
    amt$fap_operation = amc$fap_op_start .. amc$max_operation;

*copyc amd$operation_declarations
*DECK DECK=AMT$FAP_POINTER EXPAND=FALSE
 TYPE
    amt$fap_pointer = ^procedure (file_identifier: amt$file_identifier;
      call_block: amt$call_block;
      layer_number: amt$fap_layer_number;
      VAR status: ost$status);

*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc amt$file_identifier
*copyc ost$status


*DECK DECK=AMT$FETCH_ATTRIBUTES EXPAND=FALSE
 TYPE
    amt$fetch_attributes = array [1 .. * ] of amt$fetch_item,
    amt$fetch_item = record
      source {output} : amt$attribute_source,
      case key {input} : amt$file_attribute_keys of {output}
{}
{ The caller of amp$fetch must initialize the tag field selector (key) }
{ of this variant record to identify the attribute whose value is}
{ desired. The source field of this record is initialized by}
{ amp$fetch. The value of source indicates whether the item sought}
{ was returned.}
{}
      = amc$access_level =
        access_level: amt$access_level,
      = amc$access_mode =
        access_mode: pft$usage_selections,
      = amc$application_info =
        application_info: pft$application_info,
      = amc$block_type =
        block_type: amt$block_type,
      = amc$character_conversion =
        character_conversion: boolean,
      = amc$clear_space =
        clear_space: ost$clear_file_space,
      = amc$device_class =
        device_class: rmt$device_class,
      = amc$error_exit_name =
        error_exit_name: pmt$program_name,
      = amc$error_exit_procedure =
        error_exit_procedure: amt$error_exit_procedure,
      = amc$error_options =
        error_options: amt$tape_error_options,
      = amc$file_access_procedure =
        file_access_procedure: pmt$program_name,
      = amc$file_contents =
        file_contents: amt$file_contents,
      = amc$file_limit =
        file_limit: amt$file_limit,
      = amc$file_organization =
        file_organization: amt$file_organization,
      = amc$file_processor =
        file_processor: amt$file_processor,
      = amc$file_structure =
        file_structure: amt$file_structure,
      = amc$forced_write =
        forced_write: amt$forced_write,
      = amc$global_access_mode =
        global_access_mode: pft$usage_selections,
      = amc$global_file_address =
        global_file_address: amt$file_byte_address,
      = amc$global_file_name =
        global_file_name: ost$binary_unique_name,
      = amc$global_file_position =
        global_file_position: amt$global_file_position,
      = amc$global_share_mode =
        global_share_mode: pft$share_selections,
      = amc$initial_open =
        initial_open: boolean,
      = amc$input_device_classes =
        input_device_classes: rmt$device_classes,
      = amc$internal_code =
        internal_code: amt$internal_code,
      = amc$label_exit_name =
        label_exit_name: pmt$program_name,
      = amc$label_exit_procedure =
        label_exit_procedure: amt$label_exit_procedure,
      = amc$label_options =
        label_options: amt$label_options,
      = amc$label_type =
        label_type: amt$label_type,
      = amc$line_number =
        line_number: amt$line_number,
      = amc$max_block_length =
        max_block_length: amt$max_block_length,
      = amc$max_record_length =
        max_record_length: amt$max_record_length,
      = amc$min_block_length =
        min_block_length: amt$min_block_length,
      = amc$min_record_length =
        min_record_length: amt$min_record_length,
      = amc$null_attribute =
        ,
      = amc$open_attached_file =
        open_attached_file: boolean,
      = amc$open_created_file =
        open_created_file: boolean,
      = amc$open_deleted_data =
        open_deleted_data: boolean,
      = amc$open_position =
        open_position: amt$open_position,
      = amc$open_share_modes =
        open_share_modes: fst$file_access_options,
      = amc$output_device_classes =
        output_device_classes: rmt$device_classes,
      = amc$padding_character =
        padding_character: amt$padding_character,
      = amc$page_format =
        page_format: amt$page_format,
      = amc$page_length =
        page_length: amt$page_length,
      = amc$page_width =
        page_width: amt$page_width,
      = amc$permanent_file =
        permanent_file: boolean,
      = amc$preset_value =
        preset_value: amt$preset_value,
      = amc$private_read =
        private_read: boolean,
      = amc$record_delimiting_character =
        record_delimiting_character: char,
      = amc$record_type =
        record_type: amt$record_type,
      = amc$requested_tape_density =
        requested_tape_density: rmt$density,
      = amc$resolved_file_reference =
        resolved_file_reference: ^fst$resolved_file_reference,
      = amc$ring_attributes =
        ring_attributes: amt$ring_attributes,
      = amc$statement_identifier =
        statement_identifier: amt$statement_identifier,
      = amc$user_info =
        user_info: amt$user_info,
      = amc$vertical_print_density =
        vertical_print_density: amt$vertical_print_density,
{}
{ The following attributes are only used to describe files which}
{ are accessed with the Advanced Access Method (AAM). The}
{ documentation of the AAM attributes are found in the AAM ERS.}
{}
      = amc$actual_block_length =
        actual_block_length: amt$max_block_length,
      = amc$average_record_length =
        average_record_length: amt$average_record_length,
      = amc$collate_table =
        collate_table: {input,output} ^amt$collate_table,
      = amc$collate_table_name =
        collate_table_name: pmt$program_name,
      = amc$compression_procedure_name =
        compression_procedure_name: {input,output}
        ^ amt$compression_procedure_name,
      = amc$data_padding =
        data_padding: amt$data_padding,
      = amc$dynamic_home_block_space =
        dynamic_home_block_space: amt$dynamic_home_block_space,
      = amc$embedded_key =
        embedded_key: boolean,
      = amc$error_limit =
        error_limit: amt$error_limit,
      = amc$estimated_record_count =
        estimated_record_count: amt$estimated_record_count,
      = amc$hashing_procedure_name =
        hashing_procedure_name: {input,output} ^amt$hashing_procedure_name,
      = amc$index_levels =
        index_levels: amt$index_levels,
      = amc$index_padding =
        index_padding: amt$index_padding,
      = amc$initial_home_block_count =
        initial_home_block_count: amt$initial_home_block_count,
      = amc$key_length =
        key_length: amt$key_length,
      = amc$key_position =
        key_position: amt$key_position,
      = amc$key_type =
        key_type: amt$key_type,
      = amc$keyed_file_bkup_for_logging =
        keyed_file_bkup_for_logging: ost$date_time,
      = amc$loading_factor =
        loading_factor: amt$loading_factor,
      = amc$lock_expiration_time =
        lock_expiration_time: amt$lock_expiration_time,
      = amc$logging_options =
        logging_options: amt$logging_options,
      = amc$log_residence =
        log_residence: {input,output} ^amt$log_residence,
      = amc$message_control =
        message_control: amt$message_control,
      = amc$record_limit =
        record_limit: amt$record_limit,
      = amc$records_per_block =
        records_per_block: amt$records_per_block,
      casend
    recend;

*copyc amd$block_headers
*copyc amd$file_attributes
*copyc amd$file_contents
*copyc amd$file_processor
*copyc amd$file_structure
*copyc amd$page_format_declarations
*copyc amt$compression_procedure_name
*copyc amt$dynamic_home_block_space
*copyc amt$file_byte_address
*copyc amt$hashing_procedure_name
*copyc amt$index_levels
*copyc amt$initial_home_block_count
*copyc amt$line_number
*copyc amt$loading_factor
*copyc amt$lock_expiration_time
*copyc amt$log_residence
*copyc amt$logging_options
*copyc amt$max_block_length
*copyc amt$max_record_length
*copyc amt$open_position
*copyc amt$preset_value
*copyc amt$ring_attributes
*copyc amt$statement_identifier
*copyc amt$tape_error_options
*copyc fst$file_access_options
*copyc fst$resolved_file_reference
*copyc osd$unique_name
*copyc ost$clear_file_space
*copyc ost$date_time
*copyc ost$string
*copyc pfd$permanent_file_attributes
*copyc pmt$program_name
*copyc rmt$density
*copyc rmt$device_classes
*DECK DECK=AMT$FILE_ATTRIBUTES EXPAND=FALSE
 TYPE
    amt$file_attributes = array [1 .. * ] of amt$file_item,
    amt$file_item = record
      case key {input} : amt$file_attribute_keys of {input}
{}
{ The caller of amp$file must initialize the tag field selector (key) }
{ and store the indicated attribute value into this record before}
{ calling amp$file.}
{}
      = amc$access_mode =
        access_mode: pft$usage_selections,
      = amc$block_type =
        block_type: amt$block_type,
      = amc$character_conversion =
        character_conversion: boolean,
      = amc$clear_space =
        clear_space: ost$clear_file_space,
      = amc$error_exit_name =
        error_exit_name: pmt$program_name,
      = amc$error_options =
        error_options: amt$tape_error_options,
      = amc$file_access_procedure =
        file_access_procedure: pmt$program_name,
      = amc$file_contents =
        file_contents: amt$file_contents,
      = amc$file_limit =
        file_limit: amt$file_limit,
      = amc$file_organization =
        file_organization: amt$file_organization,
      = amc$file_processor =
        file_processor: amt$file_processor,
      = amc$file_structure =
        file_structure: amt$file_structure,
      = amc$forced_write =
        forced_write: amt$forced_write,
      = amc$internal_code =
        internal_code: amt$internal_code,
      = amc$label_exit_name =
        label_exit_name: pmt$program_name,
      = amc$label_options =
        label_options: amt$label_options,
      = amc$label_type =
        label_type: amt$label_type,
      = amc$line_number =
        line_number: amt$line_number,
      = amc$max_block_length =
        max_block_length: amt$max_block_length,
      = amc$max_record_length =
        max_record_length: amt$max_record_length,
      = amc$min_block_length =
        min_block_length: amt$min_block_length,
      = amc$min_record_length =
        min_record_length: amt$min_record_length,
      = amc$null_attribute =
        ,
      = amc$open_position =
        open_position: amt$open_position,
      = amc$padding_character =
        padding_character: amt$padding_character,
      = amc$page_format =
        page_format: amt$page_format,
      = amc$page_length =
        page_length: amt$page_length,
      = amc$page_width =
        page_width: amt$page_width,
      = amc$preset_value =
        preset_value: amt$preset_value,
      = amc$record_type =
        record_type: amt$record_type,
      = amc$return_option =
        return_option: amt$return_option,
      = amc$ring_attributes =
        ring_attributes: amt$ring_attributes,
      = amc$statement_identifier =
        statement_identifier: amt$statement_identifier,
      = amc$user_info =
        user_info: amt$user_info,
      = amc$vertical_print_density =
        vertical_print_density: amt$vertical_print_density,
{}
{ The following attributes are only used to describe files which}
{ are accessed with the Advanced Access Method (AAM). The}
{ documentation of the AAM attributes are found in the AAM ERS.}
{}
      = amc$average_record_length =
        average_record_length: amt$average_record_length,
      = amc$collate_table_name =
        collate_table_name: pmt$program_name,
      = amc$compression_procedure_name =
        compression_procedure_name: {input,output}
          ^amt$compression_procedure_name,
      = amc$data_padding =
        data_padding: amt$data_padding,
      = amc$dynamic_home_block_space =
        dynamic_home_block_space: amt$dynamic_home_block_space,
      = amc$embedded_key =
        embedded_key: boolean,
      = amc$error_limit =
        error_limit: amt$error_limit,
      = amc$estimated_record_count =
        estimated_record_count: amt$estimated_record_count,
      = amc$hashing_procedure_name =
        hashing_procedure_name: {input,output} ^amt$hashing_procedure_name,
      = amc$index_levels =
        index_levels: amt$index_levels,
      = amc$index_padding =
        index_padding: amt$index_padding,
      = amc$initial_home_block_count =
        initial_home_block_count: amt$initial_home_block_count,
      = amc$key_length =
        key_length: amt$key_length,
      = amc$key_position =
        key_position: amt$key_position,
      = amc$key_type =
        key_type: amt$key_type,
      = amc$loading_factor =
        loading_factor: amt$loading_factor,
      = amc$lock_expiration_time =
        lock_expiration_time: amt$lock_expiration_time,
      = amc$logging_options =
        logging_options: amt$logging_options,
      = amc$log_residence =
        log_residence: {input,output} ^amt$log_residence,
      = amc$message_control =
        message_control: amt$message_control,
      = amc$record_limit =
        record_limit: amt$record_limit,
      = amc$records_per_block =
        records_per_block: amt$records_per_block,
      casend
    recend;

*copyc amd$block_headers
*copyc amd$file_attributes
*copyc amd$file_contents
*copyc amd$file_processor
*copyc amd$file_structure
*copyc amd$page_format_declarations
*copyc amt$compression_procedure_name
*copyc amt$dynamic_home_block_space
*copyc amt$hashing_procedure_name
*copyc amt$index_levels
*copyc amt$initial_home_block_count
*copyc amt$line_number
*copyc amt$loading_factor
*copyc amt$lock_expiration_time
*copyc amt$log_residence
*copyc amt$logging_options
*copyc amt$max_block_length
*copyc amt$max_record_length
*copyc amt$open_position
*copyc amt$preset_value
*copyc amt$ring_attributes
*copyc amt$statement_identifier
*copyc amt$tape_error_options
*copyc ost$clear_file_space
*copyc pfd$permanent_file_attributes
*copyc pmt$program_name
*DECK DECK=AMT$FILE_ATTRIBUTE_KEYS EXPAND=FALSE
 CONST
    amc$access_level = 1,
    amc$access_mode = 2,
    amc$application_info = 3,
    amc$average_record_length = 4,
    amc$block_type = 5,
    amc$character_conversion = 6,
    amc$clear_space = 7,
    amc$collate_table = 8,
    amc$collate_table_name = 9,
    amc$data_padding = 12,
    amc$embedded_key = 13,
    amc$error_exit_name = 14,
    amc$error_exit_procedure = 15,
    amc$error_limit = 16,
    amc$error_options = 17,
    amc$estimated_record_count = 18,
    amc$file_access_procedure = 19,
    amc$file_contents = 20,
    amc$file_length = 21,
    amc$file_limit = 22,
    amc$file_organization = 24,
    amc$file_processor = 25,
    amc$file_structure = 26,
    amc$forced_write = 27,
    amc$global_access_mode = 28,
    amc$global_file_address = 29,
    amc$global_file_position = 30,
    amc$global_file_name = 31,
    amc$global_share_mode = 32,
    amc$index_levels = 33,
    amc$index_padding = 34,
    amc$internal_code = 35,
    amc$key_length = 36,
    amc$key_position = 37,
    amc$key_type = 38,
    amc$label_exit_name = 39,
    amc$label_exit_procedure = 40,
    amc$label_options = 41,
    amc$label_type = 42,
    amc$line_number = 44,
    amc$max_block_length = 45,
    amc$max_record_length = 46,
    amc$message_control = 47,
    amc$min_block_length = 48,
    amc$min_record_length = 49,
    amc$null_attribute = 50,
    amc$open_position = 51,
    amc$padding_character = 52,
    amc$page_format = 53,
    amc$page_length = 54,
    amc$page_width = 55,
    amc$permanent_file = 56,
    amc$preset_value = 57,
    amc$record_limit = 59,
    amc$record_type = 60,
    amc$records_per_block = 61,
    amc$return_option = 62,
    amc$ring_attributes = 63,
    amc$statement_identifier = 64,
    amc$user_info = 66,
    amc$vertical_print_density = 67,
    amc$compression_procedure_name = 68,
    amc$dynamic_home_block_space = 69,
    amc$hashing_procedure_name = 70,
    amc$initial_home_block_count = 71,
    amc$loading_factor = 72,
    amc$lock_expiration_time = 73,
    amc$logging_options = 74,
    amc$log_residence = 75,
    amc$input_device_classes = 76,
    amc$output_device_classes = 77,
    amc$device_class = 78,
    amc$initial_open = 79,
    amc$private_read = 80,
    amc$record_delimiting_character = 81,
    amc$open_attached_file = 82,
    amc$open_created_file = 83,
    amc$open_deleted_data = 84,
    amc$open_share_modes = 85,
    amc$resolved_file_reference = 86,
    amc$requested_tape_density = 87,
    amc$shared_queue = 88,


{}
    amc$concatenated_key_portion = 100,
    amc$duplicate_keys = 101,
    amc$group_name = 102,
    amc$null_suppression = 103,
    amc$repeating_group = 104,
    amc$sparse_keys = 105,
    amc$variable_length_key = 106,
    amc$actual_block_length = 107,
    amc$keyed_file_bkup_for_logging = 108,

    amc$alternate_key_count = 129,
    amc$alternate_key_information = 130,
    amc$block_count = 131,
    amc$creation_date = 132,
    amc$record_count = 133,
    amc$delete_count = 134,
    amc$get_count = 135,
    amc$get_next_count = 136,
    amc$open_count = 137,
    amc$put_count = 138,
    amc$putrep_count = 139,
    amc$replace_count = 140,
    amc$index_level_overflow = 141,
    amc$home_block_count = 142,
    amc$overflow_block_count = 143,
    amc$overflow_record_count = 144,
{}
    amc$max_attribute = 511 {01ff(16)} ;


  TYPE
    amt$file_attribute_keys = 1 .. amc$max_attribute;
*DECK DECK=AMT$FILE_BYTE_ADDRESS EXPAND=FALSE


  CONST
*IF NOT $true(osv$unix)
    amc$file_byte_limit = 4398046511103 {2**42 - 1 bytes} ;
*ELSE
    amc$file_byte_limit = 7fffffff(16) {2**31 - 1 bytes} ;
*IFEND

  TYPE
    amt$file_byte_address = 0 .. amc$file_byte_limit;
*DECK DECK=AMT$FILE_CONTENTS EXPAND=FALSE

  TYPE
    amt$file_contents = ost$name;

{   Use constants in deck amd$file_contents with amp$open}
{   Use constants in deck fsc$file_contents with fsp$open_file}

*copyc fsc$file_contents
*copyc ost$name

*DECK DECK=AMT$FILE_IDENTIFIER EXPAND=FALSE

  CONST
*IF NOT $true(osv$unix)
    amc$max_file_id_ordinal = 4095;
*ELSE
    amc$max_file_id_ordinal = 100; {maximum number of open files per process}
*IFEND

  TYPE
*IF NOT $true(osv$unix)
    amt$file_identifier = record
      ordinal: amt$file_id_ordinal,
      sequence: amt$file_id_sequence,
    recend,
    amt$file_id_ordinal = 0 .. amc$max_file_id_ordinal,
    amt$file_id_sequence = 1 .. 4095;
*ELSE
    amt$file_identifier = ost_c_integer; { -1 .. amc$max_file_id_ordinal}

?? PUSH (LISTEXT := ON) ??
*copyc ost_c_integer
?? POP ??
*IFEND
*DECK DECK=AMT$FILE_LABEL_TYPE EXPAND=FALSE
 TYPE
    amt$file_label_type = amt$label_type;

*copyc amt$label_type
*DECK DECK=AMT$FILE_LENGTH EXPAND=FALSE
 TYPE
    amt$file_length = 0 .. amc$file_byte_limit;

*copyc amt$file_byte_address
*DECK DECK=AMT$FILE_LIMIT EXPAND=FALSE
 TYPE
    amt$file_limit = 0 .. amc$file_byte_limit;

*copyc amt$file_byte_address
*DECK DECK=AMT$FILE_ORGANIZATION EXPAND=FALSE
 TYPE

    amt$file_organization = (amc$sequential, amc$byte_addressable,
      amc$indexed_sequential, amc$direct_access, amc$system_key);
*DECK DECK=AMT$FILE_ORGANIZATION_NAME EXPAND=FALSE

  TYPE
    amt$file_organization_name = record
      name: string (18),
      size: 10 .. 18,
    recend;

*DECK DECK=AMT$FILE_ORGANIZATION_SET EXPAND=FALSE

  TYPE
    amt$file_organization_set = set of amt$file_organization;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_organization
?? POP ??

*DECK DECK=AMT$FILE_POSITION EXPAND=FALSE
 TYPE
    amt$file_position = (amc$boi, amc$bop, amc$mid_record, amc$eor, amc$eop,
      amc$eoi, amc$end_of_key_list);
*DECK DECK=AMT$FILE_PROCESSOR EXPAND=FALSE

  TYPE
    amt$file_processor = ost$name;

{   Use constants in deck amd$file_processor with amp$open}
{   Use constants in deck fsc$file_processor with fsp$open_file}

*copyc fsc$file_processor
*copyc ost$name
*DECK DECK=AMT$FILE_REFERENCE EXPAND=FALSE
 TYPE
    amt$file_reference = string ( * <= amc$max_path_name_size);

*copyc amt$path_name
*DECK DECK=AMT$FIND_RECORD_SPACE EXPAND=FALSE
 TYPE
    amt$find_record_space = record
      space: amt$file_length,
      where: amt$put_locality,
      wait: ost$wait,
    recend;

*copyc amt$file_length
*copyc amt$put_locality
*copyc ost$wait
*DECK DECK=AMT$FORCED_WRITE EXPAND=FALSE
 TYPE
    amt$forced_write = (amc$forced, amc$forced_if_structure_change,
      amc$unforced);
*DECK DECK=AMT$GENERAL_COMMIT EXPAND=FALSE
 TYPE
    amt$general_commit = record
      case general_commit_in_use: boolean of
      = TRUE =
        general_commit_name: ost$name,
      casend,
    recend;

*copyc ost$name
*DECK DECK=AMT$GET_ATTRIBUTES EXPAND=FALSE
 TYPE
    amt$get_attributes = array [1 .. * ] of amt$get_item,
    amt$get_item = record
      source {output} : amc$undefined_attribute .. amc$access_method_default,
      case key {input} : amt$file_attribute_keys of {output}
{}
{ The caller of amp$get_file_attributes must initialize the case selector (key)
{ of this variant record to identify the attribute whose value is}
{ desired. The source field of this record is initialized by}
{ amp$get_file_attributes. The value of source indicates whether}
{ the item sought was returned and how the value of the item became defined.}
{}
      = amc$access_mode =
        access_mode: pft$usage_selections,
      = amc$application_info =
        application_info: pft$application_info,
      = amc$block_type =
        block_type: amt$block_type,
      = amc$character_conversion =
        character_conversion: boolean,
      = amc$clear_space =
        clear_space: ost$clear_file_space,
      = amc$device_class =
        device_class: rmt$device_class,
      = amc$error_exit_name =
        error_exit_name: pmt$program_name,
      = amc$error_options =
        error_options: amt$tape_error_options,
      = amc$file_access_procedure =
        file_access_procedure: pmt$program_name,
      = amc$file_contents =
        file_contents: amt$file_contents,
      = amc$file_length =
        file_length: amt$file_length,
      = amc$file_limit =
        file_limit: amt$file_limit,
      = amc$file_organization =
        file_organization: amt$file_organization,
      = amc$file_processor =
        file_processor: amt$file_processor,
      = amc$file_structure =
        file_structure: amt$file_structure,
      = amc$forced_write =
        forced_write: amt$forced_write,
      = amc$global_access_mode =
        global_access_mode: pft$usage_selections,
      = amc$global_file_address =
        global_file_address: amt$file_byte_address,
      = amc$global_file_name =
        global_file_name: ost$binary_unique_name,
      = amc$global_file_position =
        global_file_position: amt$global_file_position,
      = amc$global_share_mode =
        global_share_mode: pft$share_selections,
      = amc$internal_code =
        internal_code: amt$internal_code,
      = amc$label_exit_name =
        label_exit_name: pmt$program_name,
      = amc$label_options =
        label_options: amt$label_options,
      = amc$label_type =
        label_type: amt$label_type,
      = amc$line_number =
        line_number: amt$line_number,
      = amc$max_block_length =
        max_block_length: amt$max_block_length,
      = amc$max_record_length =
        max_record_length: amt$max_record_length,
      = amc$min_block_length =
        min_block_length: amt$min_block_length,
      = amc$min_record_length =
        min_record_length: amt$min_record_length,
      = amc$null_attribute =
        ,
      = amc$open_position =
        open_position: amt$open_position,
      = amc$padding_character =
        padding_character: amt$padding_character,
      = amc$page_format =
        page_format: amt$page_format,
      = amc$page_length =
        page_length: amt$page_length,
      = amc$page_width =
        page_width: amt$page_width,
      = amc$permanent_file =
        permanent_file: boolean,
      = amc$preset_value =
        preset_value: amt$preset_value,
      = amc$private_read =
        private_read: boolean,
      = amc$record_delimiting_character =
        record_delimiting_character: char,
      = amc$record_type =
        record_type: amt$record_type,
      = amc$return_option =
        return_option: amt$return_option,
      = amc$ring_attributes =
        ring_attributes: amt$ring_attributes,
      = amc$shared_queue =
        shared_queue: ost$name,
      = amc$statement_identifier =
        statement_identifier: amt$statement_identifier,
      = amc$user_info =
        user_info: amt$user_info,
      = amc$vertical_print_density =
        vertical_print_density: amt$vertical_print_density,
{}
{ The following attributes are only used to describe files which}
{ are accessed with the Advanced Access Method (AAM). The}
{ documentation of the AAM attributes are found in the AAM ERS.}
{}
      = amc$average_record_length =
        average_record_length: amt$average_record_length,
      = amc$collate_table_name =
        collate_table_name: pmt$program_name,
      = amc$compression_procedure_name =
        compression_procedure_name: {input,output}
          ^amt$compression_procedure_name,
      = amc$data_padding =
        data_padding: amt$data_padding,
      = amc$dynamic_home_block_space =
        dynamic_home_block_space: amt$dynamic_home_block_space,
      = amc$embedded_key =
        embedded_key: boolean,
      = amc$error_limit =
        error_limit: amt$error_limit,
      = amc$estimated_record_count =
        estimated_record_count: amt$estimated_record_count,
      = amc$hashing_procedure_name =
        hashing_procedure_name: {input,output} ^amt$hashing_procedure_name,
      = amc$index_levels =
        index_levels: amt$index_levels,
      = amc$index_padding =
        index_padding: amt$index_padding,
      = amc$initial_home_block_count =
        initial_home_block_count: amt$initial_home_block_count,
      = amc$key_length =
        key_length: amt$key_length,
      = amc$key_position =
        key_position: amt$key_position,
      = amc$key_type =
        key_type: amt$key_type,
      = amc$loading_factor =
        loading_factor: amt$loading_factor,
      = amc$lock_expiration_time =
        lock_expiration_time: amt$lock_expiration_time,
      = amc$logging_options =
        logging_options: amt$logging_options,
      = amc$log_residence =
        log_residence: {input,output} ^amt$log_residence,
      = amc$message_control =
        message_control: amt$message_control,
      = amc$record_limit =
        record_limit: amt$record_limit,
      = amc$records_per_block =
        records_per_block: amt$records_per_block,
      casend
    recend;

*copyc amd$block_headers
*copyc amd$file_attributes
*copyc amd$file_contents
*copyc amd$file_processor
*copyc amd$file_structure
*copyc amd$page_format_declarations
*copyc amt$compression_procedure_name
*copyc amt$dynamic_home_block_space
*copyc amt$file_byte_address
*copyc amt$file_position
*copyc amt$hashing_procedure_name
*copyc amt$index_levels
*copyc amt$initial_home_block_count
*copyc amt$line_number
*copyc amt$loading_factor
*copyc amt$lock_expiration_time
*copyc amt$log_residence
*copyc amt$logging_options
*copyc amt$max_block_length
*copyc amt$max_record_length
*copyc amt$open_position
*copyc amt$preset_value
*copyc amt$ring_attributes
*copyc amt$statement_identifier
*copyc amt$tape_error_options
*copyc osd$unique_name
*copyc ost$clear_file_space
*copyc ost$name
*copyc pfd$permanent_file_attributes
*copyc pmt$program_name
*copyc rmt$device_class

*DECK DECK=AMT$GET_KEY_DEFINITIONS EXPAND=FALSE
 TYPE
    amt$get_key_definitions = record
      key_definitions: ^SEQ ( * ),
    recend;
*DECK DECK=AMT$GET_LABEL EXPAND=FALSE
*DECK DECK=AMT$GET_LOCK_KEYED_RECORD EXPAND=FALSE
 TYPE
    amt$get_lock_keyed_record = record
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length,
      key_location: ^cell,
      major_key_length: amt$major_key_length,
      relation: amt$key_relation,
      wait_for_lock: ost$wait_for_lock,
      unlock_control: amt$unlock_control,
      lock_intent: amt$lock_intent,
      record_length: ^amt$max_record_length,
      file_position: ^amt$file_position,
      wait: ost$wait,
    recend;

*copyc amt$file_position
*copyc amt$key_relation
*copyc amt$lock_intent
*copyc amt$major_key_length
*copyc amt$max_record_length
*copyc ost$wait_for_lock
*copyc amt$working_storage_length
*copyc amt$unlock_control
*copyc ost$wait
*DECK DECK=AMT$GET_LOCK_NEXT_KEYED_RECORD EXPAND=FALSE
 TYPE
    amt$get_lock_next_keyed_record = record
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length,
      key_location: ^cell,
      wait_for_lock: ost$wait_for_lock,
      unlock_control: amt$unlock_control,
      lock_intent: amt$lock_intent,
      record_length: ^amt$max_record_length,
      file_position: ^amt$file_position,
      wait: ost$wait,
    recend;

*copyc amt$file_position
*copyc amt$lock_intent
*copyc amt$max_record_length
*copyc ost$wait_for_lock
*copyc amt$working_storage_length
*copyc amt$unlock_control
*copyc ost$wait
*DECK DECK=AMT$GET_NESTED_FILE_DEFINITIONS EXPAND=FALSE
 TYPE
    amt$get_nested_file_definitions = record
      definitions: ^amt$nested_file_definitions,
      nested_file_count: ^amt$nested_file_count,
    recend;

*copyc amt$nested_file_count
*copyc amt$nested_file_definitions
*DECK DECK=AMT$GET_NEXT_PRIMARY_KEY_LIST EXPAND=FALSE
 TYPE
    amt$get_next_primary_key_list = record
      high_key: ^cell,
      major_high_key: amt$major_key_length,
      high_key_relation: amt$key_relation,
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length,
      end_of_primary_key_list: ^boolean,
      transferred_byte_count: ^amt$working_storage_length,
      transferred_key_count: ^amt$key_count_limit,
      file_position: ^amt$file_position,
      wait: ost$wait,
    recend;

*copyc amt$file_position
*copyc amt$key_relation
*copyc amt$key_count_limit
*copyc amt$major_key_length
*copyc amt$working_storage_length
*copyc ost$wait
*DECK DECK=AMT$GET_PRIMARY_KEY_COUNT EXPAND=FALSE
 TYPE
    amt$get_primary_key_count = record
      low_key: ^cell,
      major_low_key: amt$major_key_length,
      low_key_relation: amt$key_relation,
      high_key: ^cell,
      major_high_key: amt$major_key_length,
      high_key_relation: amt$key_relation,
      list_count_limit: amt$key_count_limit,
      list_count: ^amt$key_count_limit,
      wait: ost$wait,
    recend;

*copyc amt$key_count_limit
*copyc amt$key_relation
*copyc amt$major_key_length
*copyc ost$wait
*DECK DECK=AMT$GET_SPACE_USED_FOR_KEY EXPAND=FALSE
 TYPE
    amt$get_space_used_for_key = record
      low_key: ^cell,
      major_low_key: amt$major_key_length,
      low_key_relation: amt$key_relation,
      high_key: ^cell,
      major_high_key: amt$major_key_length,
      high_key_relation: amt$key_relation,
      data_block_count: ^amt$data_block_count,
      data_block_space: ^amt$file_length,
      wait: ost$wait,
    recend;

*copyc amt$data_block_count
*copyc amt$file_length
*copyc amt$key_relation
*copyc amt$major_key_length
*copyc ost$wait
*DECK DECK=AMT$GROUP_NAME EXPAND=FALSE
 TYPE
    amt$group_name = amt$key_name;

*copyc amt$key_name
*DECK DECK=AMT$HASHING_PROCEDURE EXPAND=FALSE
 TYPE
    amt$hashing_procedure = ^procedure (old_key: ^cell;
      key_length: amt$key_length;
      VAR hashed_key: integer;
      VAR status: ost$status);

*copyc amt$key_length
*copyc ost$status
*DECK DECK=AMT$HASHING_PROCEDURE_NAME EXPAND=FALSE
 TYPE
    amt$hashing_procedure_name = amt$entry_point_reference;

*copyc amt$entry_point_reference
*DECK DECK=AMT$INDEX_LEVELS EXPAND=FALSE

  CONST
    amc$max_index_level = 15;

  TYPE
    amt$index_levels = 0 .. amc$max_index_level;
*DECK DECK=AMT$INDEX_PADDING EXPAND=FALSE
 TYPE

    amt$index_padding = 0 .. 99 {expressed as a percentage} ;
*DECK DECK=AMT$INITIAL_HOME_BLOCK_COUNT EXPAND=FALSE
 CONST
    amc$max_home_blocks = amc$file_byte_limit;

  TYPE
    amt$initial_home_block_count = 1 .. amc$max_home_blocks;

*copyc amt$file_byte_address
*DECK DECK=AMT$INTERNAL_CODE EXPAND=FALSE
 TYPE
    amt$internal_code = (amc$as6, amc$as8, amc$ascii, amc$d64,
      amc$ebcdic, amc$bcd, amc$d63, amc$ftam1_ia5, amc$ftam1_visible,
      amc$ftam1_graphic, amc$ftam1_general, amc$ftam2_ia5, amc$ftam2_visible,
      amc$ftam2_graphic, amc$ftam2_general);
*DECK DECK=AMT$INT_FILE_BYTE_ADDRESS EXPAND=FALSE

  CONST
    amc$int_file_byte_limit = 2147483648, { 2** 31 bytes}
    amc$int_max_files = 2000,
    amc$int_maximum_record = amc$int_file_byte_limit - 1;

  TYPE
    amt$int_file_byte_address = 0 .. amc$int_file_byte_limit - 1,
    amt$file_name = string ( * ),
    amt$interim_file_identifier = record
      ordinal: amt$int_file_id_ordinal,
      sequence: amt$int_file_id_sequence,
      prim_ptr: amt$owncode_pointer,
      sec_ptr: amt$owncode_pointer,
    recend,
    amt$int_file_id_ordinal = 1 .. amc$int_max_files,
    amt$int_file_id_sequence = 0 .. 4095,
    amt$int_file_position = (int$bov, int$boi, int$mid_record, int$eor,
      int$prior_to_eop, int$eop, int$eoi, int$eov),
    amt$owncode_pointer = ^procedure (file_id: amt$interim_file_identifier;
      call_block: amt$call_block_seq;
      access_method_pointer: amt$owncode_pointer;
      VAR status: ost$status),
    amt$call_block_seq = SEQ (REP 320 of cell),
    amt$int_transfer_count = 0 .. amc$int_maximum_record,
    amt$int_working_storage_length = 0 .. amc$int_maximum_record;
*DECK DECK=AMT$KEYED_FILE_ATTRIBUTE EXPAND=FALSE

    TYPE
        amt$keyed_file_attribute = RECORD
          returned {output} : BOOLEAN,
          CASE selector {input} : amt$file_attribute_keys OF {output)

{}
{ The caller of amp$fetch_nested_file_attrib must }
{ initialize the tag field (selector) of this        }
{ variant record to identify the attribute whose     }
{ value is desired. The RETURNED field indicates     }
{ whether a valid value was found for the attribute. }
{}

{}
{ The following attributes pertain to all nested files. }
{}

          = amc$alternate_key_count =
            alternate_key_count: 0..4294967295,
          = amc$alternate_key_information =
            altkey_block_count: 0 .. amc$file_byte_limit,
            altkey_creation_date: ost$date_time,
            altkey_parts_count: 0 .. 64,
          = amc$block_count =
            block_count: 0 .. amc$file_byte_limit,
          = amc$creation_date =
            creation_date: ost$date_time,
          = amc$collate_table_name =
            collate_table_name: pmt$program_name,
          = amc$collate_table =
            collate_table: amt$collate_table,
          = amc$compression_procedure_name =
            compression_procedure_name:
              ^amt$compression_procedure_name,
          = amc$embedded_key =
            embedded_key: BOOLEAN,
          = amc$file_organization =
            file_organization: amt$file_organization,
          = amc$key_length =
            key_length: amt$key_length,
          = amc$key_position =
            key_position: amt$key_position,
          = amc$key_type =
            key_type: amt$key_type,
          = amc$max_record_length =
            max_record_length: amt$max_record_length,
          = amc$min_record_length =
            min_record_length: amt$min_record_length,
          = amc$null_attribute =
            ,
          = amc$record_count =
            record_count: 0 .. amc$file_byte_limit,
          = amc$record_type =
            record_type: amt$record_type,

{}
{ The following items are statistics maintained }
{ separately for each nested file. }
{}

          = amc$delete_count =
            delete_count: INTEGER,
          = amc$get_count =
            get_count: INTEGER,
          = amc$get_next_count =
            get_next_count: INTEGER,
          = amc$open_count =
            open_count: INTEGER,
          = amc$put_count =
            put_count: INTEGER,
          = amc$putrep_count =
            putrep_count: INTEGER,
          = amc$replace_count =
            replace_count: INTEGER,

{}
{ The following attributes pertain only to indexed }
{ sequential nested files. }
{}

          = amc$data_padding =
            data_padding: amt$data_padding,
          = amc$index_levels =
            index_levels: amt$index_levels,
          = amc$index_level_overflow =
            index_level_overflow: BOOLEAN,
          = amc$index_padding =
            index_padding: amt$index_padding,
{}
{ The following attributes pertain only to direct }
{ access nested files. }
{}

          = amc$dynamic_home_block_space =
            dynamic_home_block_space: amt$dynamic_home_block_space,
          = amc$hashing_procedure_name =
            hashing_procedure_name:
              ^amt$hashing_procedure_name,
          = amc$home_block_count =
            home_block_count: amt$initial_home_block_count,
          = amc$loading_factor =
            loading_factor: amt$loading_factor,
          = amc$overflow_block_count =
            overflow_block_count: 0 .. amc$file_byte_limit,
          = amc$overflow_record_count =
            overflow_record_count: 0 .. amc$file_byte_limit,
          CASEND
        RECEND;

*copyc amt$collate_table
*copyc amt$compression_procedure_name
*copyc amt$data_padding
*copyc amt$dynamic_home_block_space
*copyc amt$file_attribute_keys
*copyc amt$file_organization
*copyc amt$hashing_procedure_name
*copyc amt$index_levels
*copyc amt$index_padding
*copyc amt$initial_home_block_count
*copyc amt$key_length
*copyc amt$key_name
*copyc amt$key_position
*copyc amt$key_type
*copyc amt$loading_factor
*copyc amt$max_record_length
*copyc amt$min_record_length
*copyc amt$record_type
*copyc ost$date_time
*copyc osd$virtual_address
*copyc pmt$program_name
*DECK DECK=AMT$KEYED_FILE_ATTRIBUTES EXPAND=FALSE

  TYPE
    amt$keyed_file_attributes = ARRAY [ 1 .. * ] OF
      amt$keyed_file_attribute;

?? PUSH (LISTEXT := ON) ??
*copyc amt$keyed_file_attribute
?? POP ??

*DECK DECK=AMT$KEYED_FILE_SEGMENT_INFO EXPAND=FALSE

 TYPE
   amt$keyed_file_segment_info = RECORD
     segment_in_use: BOOLEAN,
     blocks_in_use: 0 .. amc$file_byte_limit,
     empty_block_count: 0 .. amc$file_byte_limit,
     last_flush: ost$date_time,
   RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc ost$date_time
?? POP ??
*DECK DECK=AMT$KEY_COUNT_LIMIT EXPAND=FALSE
 TYPE
    amt$key_count_limit = 0 .. amc$file_byte_limit;

*copyc amt$file_byte_address
*DECK DECK=AMT$KEY_LENGTH EXPAND=FALSE
 CONST
    amc$max_key_length = 255;

  TYPE

    amt$key_length = 1 .. amc$max_key_length;
*DECK DECK=AMT$KEY_NAME EXPAND=FALSE
 TYPE
    amt$key_name = ost$name;

*copyc ost$name
*DECK DECK=AMT$KEY_POSITION EXPAND=FALSE
 TYPE
    amt$key_position = 0 .. amc$max_key_position;

*copyc amc$max_key_position
*DECK DECK=AMT$KEY_RELATION EXPAND=FALSE

  TYPE
    amt$key_relation = (amc$equal_key, amc$greater_or_equal_key,
      amc$greater_key);
*DECK DECK=AMT$KEY_TYPE EXPAND=FALSE
 TYPE

    amt$key_type = (amc$collated_key, amc$integer_key, amc$uncollated_key);
*DECK DECK=AMT$LABEL_EXIT_PROCEDURE EXPAND=FALSE
 TYPE
    amt$label_exit_procedure = ^procedure (file_identifier:
      amt$file_identifier;
      VAR status: ost$status);

*copyc amt$file_identifier
*copyc ost$status
*DECK DECK=AMT$LABEL_TYPE EXPAND=FALSE
 TYPE
    amt$label_type = (amc$labeled, amc$non_standard_labeled, amc$unlabeled);

 CONST
    amc$labelled = amc$labeled,
    amc$non_standard_labelled = amc$non_standard_labeled,
    amc$unlabelled = amc$unlabeled;
*DECK DECK=AMT$LAST_ACCESS_OPERATION EXPAND=FALSE
 TYPE
    amt$last_access_operation = amc$last_access_start .. amc$max_operation;

*copyc amd$operation_declarations




*DECK DECK=AMT$LAST_OPERATION EXPAND=FALSE
 TYPE
    amt$last_operation = 1 .. amc$max_operation;

*copyc amd$operation_declarations





*DECK DECK=AMT$LAST_OP_STATUS EXPAND=TRUE

  TYPE
    amt$last_op_status = (amc$active, amc$complete);
*DECK DECK=AMT$LINE_NUMBER EXPAND=FALSE

  TYPE
    amt$line_number = record
      length: amt$line_number_length,
      location: amt$line_number_location,
    recend;

*copyc amt$line_number_length
*copyc amt$line_number_location
*DECK DECK=AMT$LINE_NUMBER_LENGTH EXPAND=FALSE
 CONST
    amc$max_line_number = 6;

  TYPE
    amt$line_number_length = 1 .. amc$max_line_number;
*DECK DECK=AMT$LINE_NUMBER_LOCATION EXPAND=FALSE
 TYPE
    amt$line_number_location = amt$page_width;

*copyc amt$page_width
*DECK DECK=AMT$LOADING_FACTOR EXPAND=FALSE
 TYPE
    amt$loading_factor = 0 .. 100;
*DECK DECK=AMT$LOCAL_FILE_NAME EXPAND=FALSE

  TYPE
    amt$local_file_name = ost$name;

*copyc OST$NAME
*DECK DECK=AMT$LOCK EXPAND=FALSE

  TYPE
    amt$file_lock = (amc$lock_set, amc$already_set);

*DECK DECK=AMT$LOCK_EXPIRATION_TIME EXPAND=FALSE
 TYPE
    amt$lock_expiration_time = 0 .. 604800000 {milliseconds} ;
*DECK DECK=AMT$LOCK_FILE EXPAND=FALSE
 TYPE
    amt$lock_file = record
      wait_for_lock: ost$wait_for_lock,
      lock_intent: amt$lock_intent,
    recend;

*copyc amt$lock_intent
*copyc ost$wait_for_lock
*DECK DECK=AMT$LOCK_FILE_SCOPE EXPAND=FALSE

  TYPE
    amt$lock_file_scope = (amc$private_lock_file, amc$public_lock_file);

*DECK DECK=AMT$LOCK_INTENT EXPAND=FALSE
 TYPE
    amt$lock_intent = (amc$exclusive_access, amc$preserve_access_and_content,
      amc$preserve_content);
*DECK DECK=AMT$LOCK_KEY EXPAND=FALSE
 TYPE
    amt$lock_key = record
      key_location: ^cell,
      wait_for_lock: ost$wait_for_lock,
      unlock_control: amt$unlock_control,
      lock_intent: amt$lock_intent,
    recend;

*copyc amt$lock_intent
*copyc amt$unlock_control
*copyc ost$wait_for_lock
*DECK DECK=AMT$LOGGING_OPTIONS EXPAND=FALSE
 TYPE
    amt$logging_options = set of amt$logging_possibilities;

*copyc amt$logging_possibilities
*DECK DECK=AMT$LOGGING_POSSIBILITIES EXPAND=FALSE
 TYPE
    amt$logging_possibilities = (amc$enable_parcels, amc$enable_media_recovery,
      amc$enable_request_recovery);
*DECK DECK=AMT$LOG_RESIDENCE EXPAND=FALSE
 TYPE
    amt$log_residence = amt$path_name;

*copyc amt$path_name
*DECK DECK=AMT$MAJOR_KEY_LENGTH EXPAND=FALSE

  TYPE
    amt$major_key_length = 0 .. amc$max_key_length;

*copyc AMT$FILE_ATTRIBUTES
*DECK DECK=AMT$MAU_LENGTH EXPAND=FALSE

  CONST
    amc$mau_length = 2048 {bytes} ;
*DECK DECK=AMT$MAX_BLOCK_LENGTH EXPAND=FALSE
 TYPE
    amt$max_block_length = 1 .. amc$maximum_block;

*copyc amc$maximum_block
*DECK DECK=AMT$MAX_OPTIONAL_ATTRIBUTES EXPAND=FALSE
 CONST
    amc$max_optional_attributes = 72;


  TYPE
    amt$max_optional_attributes = 1 .. amc$max_optional_attributes;
*DECK DECK=AMT$MAX_RECORD_LENGTH EXPAND=FALSE


  CONST
    amc$maximum_record = amc$file_byte_limit;

  TYPE
    amt$max_record_length = 0 .. amc$maximum_record;

*copyc AMT$FILE_BYTE_ADDRESS
*DECK DECK=AMT$MAX_REPEATING_GROUP_COUNT EXPAND=FALSE
 TYPE
    amt$max_repeating_group_count = amt$max_record_length;

*copyc amt$max_record_length
*DECK DECK=AMT$MESSAGE_CONTROL EXPAND=FALSE
 TYPE
    amt$message_control = set of (amc$trivial_errors, amc$messages,
      amc$statistics);
*DECK DECK=AMT$MIN_BLOCK_LENGTH EXPAND=FALSE
 TYPE
    amt$min_block_length = 1 .. amc$maximum_block;

*copyc amc$maximum_block
*DECK DECK=AMT$MIN_RECORD_LENGTH EXPAND=FALSE
 TYPE

    amt$min_record_length = 0 .. amc$maximum_record;

*copyc amt$max_record_length
*DECK DECK=AMT$NESTED_FILE_COUNT EXPAND=FALSE
 TYPE
    amt$nested_file_count = 1 .. amc$max_blocks_per_file;

*copyc amd$max_blocks_per_file
*DECK DECK=AMT$NESTED_FILE_DEFINITION EXPAND=FALSE
 TYPE
    amt$nested_file_definition = record
      nested_file_name: amt$nested_file_name,
      embedded_key: boolean,
      key_position: amt$key_position,
      key_length: amt$key_length,
      maximum_record: amt$max_record_length,
      minimum_record: amt$min_record_length,
      record_type: amt$record_type,
      compression_procedure_name: amt$compression_procedure_name,
      case file_organization: amt$file_organization of
      = amc$indexed_sequential =
        key_type: amt$key_type,
        collate_table_name: pmt$program_name,
        data_padding: amt$data_padding,
        index_padding: amt$index_padding,
      = amc$direct_access =
        home_block_count: amt$initial_home_block_count,
        dynamic_home_block_space: amt$dynamic_home_block_space,
        loading_factor: amt$loading_factor,
        hashing_procedure: amt$hashing_procedure_name,
      = amc$system_key =
        records_per_block: amt$records_per_block,
      casend,
    recend;

*copyc amt$compression_procedure_name
*copyc amt$data_padding
*copyc amt$dynamic_home_block_space
*copyc amt$file_organization
*copyc amt$hashing_procedure_name
*copyc amt$index_padding
*copyc amt$initial_home_block_count
*copyc amt$key_length
*copyc amt$key_position
*copyc amt$key_type
*copyc amt$loading_factor
*copyc amt$max_record_length
*copyc amt$min_record_length
*copyc amt$nested_file_name
*copyc amt$records_per_block
*copyc amt$record_type
*copyc pmt$program_name
*DECK DECK=AMT$NESTED_FILE_DEFINITIONS EXPAND=FALSE
 TYPE
    amt$nested_file_definitions = array [1 .. * ] of
      amt$nested_file_definition;

*copyc amt$nested_file_definition
*DECK DECK=AMT$NESTED_FILE_NAME EXPAND=FALSE
 TYPE
    amt$nested_file_name = ost$name;

*copyc ost$name
*DECK DECK=AMT$NOWAIT_VAR_PARAMETERS EXPAND=FALSE
 TYPE
    amt$nowait_var_parameters = SEQ (REP 10 of integer);
*DECK DECK=AMT$OPEN_POSITION EXPAND=FALSE

  TYPE
    amt$open_position = (amc$open_no_positioning, amc$open_at_boi,
      amc$open_at_bop, amc$open_at_eoi);
*DECK DECK=AMT$OPEN_TAPE_VOLUME EXPAND=FALSE
  TYPE
    amt$open_tape_volume = RECORD
      tape_density: rmt$density,
      write_ring: rmt$write_ring,
      file_label_type: amt$file_label_type,
      access_mode: pft$usage_selections,
      initial_assignment: BOOLEAN,
      opening_volume_number: amt$volume_number,
      opening_volume: rmt$volume_descriptor,
      removable_media_location: ost$name,
      removable_media_group: ost$name,
      account: avt$account_name,
      family: ost$family_name,
      project: avt$project_name,
      slot: ost$name,
      source_pool: ost$name,
      source_pool_location: ost$name,
      user: ost$user_name,
    RECEND;

*copyc amt$file_label_type
*copyc amt$volume_number
*copyc avt$account_name
*copyc avt$project_name
*copyc ost$name
*copyc ost$user_identification
*copyc pfd$permanent_file_attributes
*copyc rmt$density
*copyc rmt$volume_descriptor
*copyc rmt$write_ring

*DECK DECK=AMT$OPTIONAL_KEY_ATTRIBUTE EXPAND=FALSE
 TYPE
    amt$optional_key_attribute = record
      case selector: amt$file_attribute_keys of
      = amc$key_type =
        key_type: amt$key_type,
      = amc$collate_table_name =
        collate_table_name: pmt$program_name,
      = amc$duplicate_keys =
        duplicate_key_control: amt$duplicate_key_control,
      = amc$null_suppression =
        null_suppression: boolean,
      = amc$sparse_keys =
        sparse_key_control_position: amt$key_position,
        sparse_key_control_characters: set of char,
        sparse_key_control_effect: amt$sparse_key_control_effect,
      = amc$repeating_group =
        repeating_group_length: amt$max_record_length,
        repetition_control: amt$repetition_control,
      = amc$concatenated_key_portion =
        concatenated_key_position: amt$key_position,
        concatenated_key_length: amt$key_length,
        concatenated_key_type: amt$key_type,
      = amc$group_name =
        group_name: amt$group_name,
      = amc$variable_length_key =
        key_delimiter_characters: set of char,
      casend,
    recend;

*copyc amt$duplicate_key_control
*copyc amt$file_attribute_keys
*copyc amt$key_length
*copyc amt$key_position
*copyc amt$key_type
*copyc amt$group_name
*copyc amt$max_record_length
*copyc amt$repetition_control
*copyc amt$sparse_key_control_effect
*copyc pmt$program_name
*DECK DECK=AMT$OPTIONAL_KEY_ATTRIBUTES EXPAND=FALSE
 TYPE
    amt$optional_key_attributes = array [1 .. * ] of
      amt$optional_key_attribute;

*copyc amt$optional_key_attribute
*DECK DECK=AMT$PADDING_CHARACTER EXPAND=FALSE
 TYPE
    amt$padding_character = char;
*DECK DECK=AMT$PAGE_FORMAT EXPAND=FALSE
 TYPE
    amt$page_format = (amc$continuous_form, amc$burstable_form,
      amc$non_burstable_form, amc$untitled_form);

*DECK DECK=AMT$PAGE_LENGTH EXPAND=FALSE
 TYPE
    amt$page_length = 1 .. amc$file_byte_limit;

*copyc amt$file_byte_address
*DECK DECK=AMT$PAGE_WIDTH EXPAND=FALSE
 CONST
    amc$max_page_width = 65535;

  TYPE
    amt$page_width = 1 .. amc$max_page_width;
*DECK DECK=AMT$PATH_NAME EXPAND=FALSE
 CONST
    amc$max_path_name_size = 256;

  TYPE
    amt$path_name = string (amc$max_path_name_size);
*DECK DECK=AMT$PHYSICAL_TRANSFER_COUNT EXPAND=FALSE


  TYPE
    amt$physical_transfer_count = 0 .. amc$max_buffer_length;

*copyc AMT$BUFFER_LENGTH
*DECK DECK=AMT$PHYSICAL_VOLUME_POSITION EXPAND=FALSE
TYPE
  amt$physical_volume_position = record
    block_number: ost$non_negative_integers,
    tapemark_number: ost$non_negative_integers,
  recend;

*copyc osd$integer_limits

*DECK DECK=AMT$PRESET_VALUE EXPAND=FALSE

  TYPE
    amt$preset_value = integer;
*DECK DECK=AMT$PRIMARY_KEY EXPAND=FALSE
 TYPE
    amt$primary_key = ^cell;
*DECK DECK=AMT$PUT_LABEL EXPAND=FALSE
*DECK DECK=AMT$PUT_LOCALITY EXPAND=FALSE
 TYPE
    amt$put_locality = (amc$put_near_anywhere, amc$put_near_get,
      amc$put_near_update);
*DECK DECK=AMT$READ_TAPE_LABELS EXPAND=FALSE
  TYPE
    amt$read_tape_labels = record
      label_kinds: fst$ansi_label_kinds,
    recend;

*copyc fst$ansi_label_kinds
*DECK DECK=AMT$RECORDS_PER_BLOCK EXPAND=FALSE
 CONST
    amc$max_records_per_block = 0ffff(16);

  TYPE

    amt$records_per_block = 1 .. amc$max_records_per_block;
*DECK DECK=AMT$RECORD_HEADER EXPAND=FALSE


  CONST
    amc$max_record_header = 16;

  TYPE
    amt$record_header = record
      header_type: amt$record_header_type,
      length: amt$max_record_length,
      previous_length: amt$max_record_length,
      unused_bit_count: amt$unused_bit_count,
      user_information: cell,
    recend,
    amt$record_header_length = 0 .. amc$max_record_header,
    amt$record_header_type = (amc$full_record, amc$start_record,
      amc$continued_record, amc$end_record, amc$partition, amc$deleted_record);

*copyc AMT$MAX_RECORD_LENGTH
*copyc AMT$UNUSED_BIT_COUNT

*DECK DECK=AMT$RECORD_LIMIT EXPAND=FALSE
 TYPE
    amt$record_limit = 1 .. amc$file_byte_limit;

*copyc amt$file_byte_address
*DECK DECK=AMT$RECORD_TYPE EXPAND=FALSE
 TYPE

    amt$record_type = (amc$variable {V} , amc$undefined {U} ,
      amc$ansi_fixed {F} , amc$ansi_spanned {S} , amc$ansi_variable {D} ,
      amc$trailing_char_delimited {T} );
*DECK DECK=AMT$RECORD_TYPE_NAME EXPAND=FALSE

  TYPE
    amt$record_type_name = record
      name: string (32),
      size: 12 .. 32,
    recend;

*DECK DECK=AMT$REPETITION_CONTROL EXPAND=FALSE
 TYPE
    amt$repetition_control = record
      case repeat_to_end_of_record: boolean of
      = FALSE =
        repeating_group_count: amt$max_repeating_group_count,
      casend,
    recend;

*copyc amt$max_repeating_group_count
*DECK DECK=AMT$RESIDUAL_SKIP_COUNT EXPAND=FALSE

  TYPE
    amt$residual_skip_count = amt$skip_count;

*copyc amt$skip_count
*DECK DECK=AMT$RING_ATTRIBUTES EXPAND=FALSE

  TYPE
    amt$ring_attributes = record
      r1: ost$valid_ring,
      r2: ost$valid_ring,
      r3: ost$valid_ring,
    recend;

*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=AMT$SEGMENT_POINTER EXPAND=FALSE


  TYPE
    amt$pointer_kind = (amc$cell_pointer, amc$heap_pointer,
      amc$sequence_pointer),
    amt$segment_pointer = record
      case kind: amt$pointer_kind of
      =amc$cell_pointer=
        cell_pointer: ^cell,
      =amc$heap_pointer=
        heap_pointer: ^HEAP ( * ),
      =amc$sequence_pointer=
        sequence_pointer: ^SEQ ( * ),
      casend,
    recend;

*DECK DECK=AMT$SELECTED_KEY_NAME EXPAND=FALSE
 TYPE
    amt$selected_key_name = amt$key_name;

*copyc amt$key_name
*DECK DECK=AMT$SELECTED_NESTED_FILE EXPAND=FALSE
 TYPE
    amt$selected_nested_file = amt$nested_file_name;

*copyc amt$nested_file_name
*DECK DECK=AMT$SELECT_KEY EXPAND=FALSE
 TYPE
    amt$select_key = record
      key_name: amt$key_name,
    recend;

*copyc amt$key_name
*DECK DECK=AMT$SELECT_NESTED_FILE EXPAND=FALSE
 TYPE
    amt$select_nested_file = record
      nested_file_name: amt$nested_file_name,
    recend;

*copyc amt$nested_file_name
*DECK DECK=AMT$SEPARATE_KEY_GROUPS EXPAND=FALSE
 TYPE
    amt$separate_key_groups = record
      group: amt$group_name,
      parallel_group: amt$group_name,
    recend;

*copyc amt$group_name
*DECK DECK=AMT$SKIP_COUNT EXPAND=FALSE
 TYPE
    amt$skip_count = 0 .. amc$file_byte_limit;

*copyc amt$file_byte_address
*DECK DECK=AMT$SKIP_DIRECTION EXPAND=FALSE
 TYPE
    amt$skip_direction = (amc$forward, amc$backward);
*DECK DECK=AMT$SKIP_OPTION EXPAND=FALSE


  TYPE
    amt$skip_option = (amc$skip_to_eor, amc$no_skip);
*DECK DECK=AMT$SKIP_UNIT EXPAND=FALSE
 TYPE
    amt$skip_unit = (amc$skip_record, amc$skip_tape_mark, amc$skip_partition);
*DECK DECK=AMT$SPARSE_KEY_CONTROL_EFFECT EXPAND=FALSE
 TYPE
    amt$sparse_key_control_effect = (amc$include_key_value,
      amc$exclude_key_value);
*DECK DECK=AMT$STATEMENT_IDENTIFIER EXPAND=FALSE
 TYPE
    amt$statement_identifier = record
      length: amt$statement_id_length,
      location: amt$statement_id_location,
    recend;

*copyc amt$statement_id_length
*copyc amt$statement_id_location
*DECK DECK=AMT$STATEMENT_ID_LENGTH EXPAND=FALSE
 CONST
    amc$max_statement_id_length = 17;

  TYPE
    amt$statement_id_length = 1 .. amc$max_statement_id_length;
*DECK DECK=AMT$STATEMENT_ID_LOCATION EXPAND=FALSE
 TYPE
    amt$statement_id_location = amt$page_width;

*copyc amt$page_width
*DECK DECK=AMT$STORE_ATTRIBUTES EXPAND=FALSE


  TYPE
    amt$store_attributes = array [1 .. * ] of amt$store_item,
    amt$store_item = record
      case key: amt$file_attribute_keys of
      = amc$error_exit_procedure =
        error_exit_procedure: amt$error_exit_procedure,
      = amc$error_options =
        error_options: amt$tape_error_options,
      = amc$label_exit_procedure =
        label_exit_procedure: amt$label_exit_procedure,
      = amc$label_options =
        label_options: amt$label_options,
      = amc$null_attribute =
        ,
{}
{ The following attributes are only used to describe files which}
{ are accessed with the Advanced Access Method (AAM). The}
{ documentation of the AAM attributes are found in the AAM ERS.}
{}
      = amc$error_limit =
        error_limit: amt$error_limit,
      = amc$message_control =
        message_control: amt$message_control,
      casend,
    recend;

*copyc amd$file_attributes
*copyc amt$error_exit_procedure
*copyc amt$error_limit
*copyc amt$label_exit_procedure
*copyc amt$message_control
*copyc amt$tape_error_options
*DECK DECK=AMT$TAPE_ERROR_ACTION EXPAND=FALSE

  TYPE
    amt$tape_error_action = (amc$accept_erroneous_block,
      amc$ignore_erroneous_block, amc$terminate_file_access);
*DECK DECK=AMT$TAPE_ERROR_OPTIONS EXPAND=FALSE
 TYPE
    amt$tape_error_options = record
      perform_failure_recovery: boolean,
      error_action: amt$tape_error_action,
    recend;

*copyc  amt$tape_error_action

*DECK DECK=AMT$TAPE_FAILURE_ISOLATION EXPAND=FALSE
 TYPE
    amt$tape_failure_isolation = record
      failed_at_current_position: boolean,
      failure_modes: amt$tape_failure_modes,
    recend;

*copyc amt$tape_failure_modes
*DECK DECK=AMT$TAPE_FAILURE_MODE EXPAND=FALSE
 TYPE
    amt$tape_failure_mode = (amc$tfm_agc_gains_not_set, amc$tfm_bad_id_burst,
      amc$tfm_blank_tape_read, amc$tfm_data_parity_error,
      amc$tfm_device_not_ready, amc$tfm_erase_error, amc$tfm_record_fragment,
      amc$tfm_hardware_failure);
*DECK DECK=AMT$TAPE_FAILURE_MODES EXPAND=FALSE
 TYPE
    amt$tape_failure_modes = set of amt$tape_failure_mode;

*copyc amt$tape_failure_mode

*DECK DECK=AMT$TAPE_MARK_COUNT EXPAND=FALSE
 CONST
    amc$max_tape_mark_count = 40000;


  TYPE
    amt$tape_mark_count = 1 .. amc$max_tape_mark_count;
*DECK DECK=AMT$TERMINATE_TAPE_VOLUME EXPAND=FALSE

  TYPE
    amt$terminate_tape_volume = RECORD
      tape_density: rmt$density,
      terminating_volume_number: amt$volume_number,
      terminating_volume: rmt$volume_descriptor,
      removable_media_location: ost$name,
      removable_media_group: ost$name,
    RECEND;

*copyc amt$volume_number
*copyc ost$name
*copyc rmt$density
*copyc rmt$tape_class
*copyc rmt$volume_descriptor

*DECK DECK=AMT$TERM_OPTION EXPAND=FALSE


  TYPE
    amt$term_option = (amc$start, amc$continue, amc$terminate);
*DECK DECK=AMT$TRANSFER_COUNT EXPAND=FALSE


  TYPE
    amt$transfer_count = amt$working_storage_length;

*copyc AMT$WORKING_STORAGE_LENGTH
*DECK DECK=AMT$TRANSFER_UNIT EXPAND=FALSE

{ COMMON DECK BADTU }

  TYPE
    amt$transfer_unit = (amc$t, amc$t1, amc$t2, amc$t4, amc$t8, amc$t16,
      amc$t32, amc$t64, amc$t128, amc$t256, amc$t512);
*DECK DECK=AMT$UNLOCK_CONTROL EXPAND=FALSE
 TYPE
    amt$unlock_control = (amc$automatic, amc$wait_for_unlock);
*DECK DECK=AMT$UNLOCK_KEY EXPAND=FALSE
 TYPE
    amt$unlock_key = record
      unlock_all_keys: boolean,
      key_location: ^cell,
    recend;
*DECK DECK=AMT$UNUSED_BIT_COUNT EXPAND=FALSE


  TYPE
    amt$unused_bit_count = 0 .. 7;
*DECK DECK=AMT$USAGE_OPTION_NAME EXPAND=FALSE

  TYPE
    amt$usage_option_name = record
      name: string (7),
      size: 4 .. 7,
    recend;

*DECK DECK=AMT$USER_DEFINED_ACCESS_REQUEST EXPAND=FALSE
 TYPE
    amt$user_defined_access_request = record
      request_identifier: 0 .. 0ffffffffff(16),
      request_parameters: ^SEQ ( * ),
    recend;
*DECK DECK=AMT$USER_INFO EXPAND=FALSE

  TYPE
    amt$user_info = string (amc$max_user_info);

*copyc amc$max_user_info
*DECK DECK=AMT$VERTICAL_PRINT_DENSITY EXPAND=FALSE
 TYPE
    amt$vertical_print_density = 6 .. amc$max_lines_per_inch;

*copyc amc$max_lines_per_inch
*DECK DECK=AMT$VOLUME_NUMBER EXPAND=TRUE

  TYPE
    amt$volume_number = 1 .. amc$max_vol_number;

*copyc amc$max_vol_number
*DECK DECK=AMT$VOLUME_POSITION EXPAND=FALSE
 TYPE
    amt$volume_position = (amc$after_data_block, amc$after_tapemark,
      amc$before_tapemark, amc$bov, amc$eov, amc$mid_bov_label_group,
      amc$mid_eof_label_group, amc$mid_eov_label_group,
      amc$mid_hdr_label_group, amc$position_uncertain);
*DECK DECK=AMT$WORKING_STORAGE_LENGTH EXPAND=FALSE


  TYPE
    amt$working_storage_length = ost$segment_length;

*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=AMT$WRITE_TAPE_LABELS EXPAND=FALSE
*DECK DECK=AMV$AAM_FILE_ORGANIZATIONS EXPAND=FALSE
{XDCL is in amm$tables.

  VAR
    amv$aam_file_organizations: [XREF, READ, oss$job_paged_literal]
          amt$file_organization_set;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_organization_set
*copyc oss$job_paged_literal
?? POP ??

*DECK DECK=AMV$ACCESS_LEVEL_NAMES EXPAND=FALSE
{XDCL is in amm$tables.

  VAR
    amv$access_level_names: [XREF, READ, oss$job_paged_literal]
          array [amt$access_level] of amt$access_level_name;

?? PUSH (LISTEXT := ON) ??
*copyc amt$access_level
*copyc amt$access_level_name
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=AMV$ACCESS_MODE EXPAND=FALSE

{ COMMON DECK AMXAMDE }

  VAR
    amv$access_mode: [STATIC, READ, XREF, oss$job_paged_literal]
      pft$usage_selections;

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=AMV$ATTRIBUTE_NAMES EXPAND=FALSE

  VAR
    amv$attribute_names: [XREF, READ, oss$job_paged_literal] ^array [1 .. * ]
      of ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc OSS$JOB_PAGED_LITERAL
*copyc OST$NAME
?? POP ??
*DECK DECK=AMV$BLOCK_TYPE_NAMES EXPAND=FALSE
{XDCL is in amm$tables.

  VAR
    amv$block_type_names: [XREF, READ, oss$job_paged_literal]
          array [amt$block_type] of amt$block_type_name;

?? PUSH (LISTEXT := ON) ??
*copyc amt$block_type
*copyc amt$block_type_name
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=AMV$DEVICE_CLASS_NAMES EXPAND=FALSE
{XDCL is in amm$tables.

  VAR
    amv$device_class_names: [XREF, READ, oss$job_paged_literal]
          array [rmt$device_class] of amt$device_class_name;

?? PUSH (LISTEXT := ON) ??
*copyc amt$device_class_name
*copyc oss$job_paged_literal
*copyc rmt$device_class
?? POP ??
*DECK DECK=AMV$FILE_ORGANIZATION_NAMES EXPAND=FALSE
{XDCL is in amm$tables.

  VAR
    amv$file_organization_names: [XREF, READ,
          oss$job_paged_literal] array [amt$file_organization] of
          amt$file_organization_name;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_organization
*copyc amt$file_organization_name
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=AMV$LABEL_OPTIONS EXPAND=FALSE

{ COMMON DECK AMXLOPT }

  VAR
    amv$label_options: [STATIC, READ, XREF, oss$job_paged_literal]
      amt$label_options;

?? PUSH (LISTEXT := ON) ??
*copyc AMD$FILE_ATTRIBUTES
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=AMV$MESSAGE_CONTROL EXPAND=FALSE

{ COMMON DECK AMXMESG }

  VAR
    amv$message_control: [STATIC, READ, XREF, oss$job_paged_literal]
      amt$message_control;

?? PUSH (LISTEXT := ON) ??
*copyc AMD$FILE_ATTRIBUTES
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=AMV$NIL_FILE_IDENTIFIER EXPAND=FALSE

{ This variable is intended to be used in a procedure/program that opens a
{ file and establishes some form of condition handler which attempts to
{ close the file.  The recommended usage of this variable is as follows:
{
{ 1) Before establishing the condition handler, the file_identifier variable
{    should be initialized to this value.
{ 2) The condition handler need only call fsp$close_file if the file_identifier
{    variable does not equal amv$nil_file_identifier.
{
{ Usage of this variable can solve and/or prevent a couple of problems which
{ can exist when a boolean is used to determine whether or not the file needs
{ to be close:
{
{ 1) Accidental closing of the wrong file if the condition handler is invoked
{    before to the call to fsp$open_file, but after a boolean had been set
{    to flag that the file is open.  An uninitialized file_identifier may
{    contain a valid file_identifier from a previous open.  This problem
{    can also occur if the file is close unconditionally.
{ 2) Leaving the file open if the condition handler is invoked after the call
{    to fsp$open_file, but before a boolean can be set to flag that the file
{    is open.

  VAR
    amv$nil_file_identifier: [XREF] amt$file_identifier;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
?? POP ??
*DECK DECK=AMV$RECORD_TYPE_NAMES EXPAND=FALSE
{XDCL is in amm$tables.

  VAR
    amv$record_type_names: [XREF, READ, oss$job_paged_literal]
          array [amt$record_type] of amt$record_type_name;

?? PUSH (LISTEXT := ON) ??
*copyc amt$record_type
*copyc amt$record_type_name
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=AMV$USAGE_OPTION_NAMES EXPAND=FALSE
{XDCL is in amm$tables.

  VAR
    amv$usage_option_names: [XREF, READ, oss$job_paged_literal]
          array [pft$usage_options] of amt$usage_option_name;

?? PUSH (LISTEXT := ON) ??
*copyc amt$usage_option_name
*copyc oss$job_paged_literal
*copyc pfd$permanent_file_attributes
?? POP ??
*DECK DECK=AMV$VALID_RING EXPAND=FALSE

{ COMMON DECK AMXVRNG }

  VAR
    amv$valid_ring: [STATIC, READ, XREF, oss$job_paged_literal] set of
      ost$valid_ring;

?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=ASMBCOM EXPAND=FALSE
................ begin common deck ASMBCOM ........................
.
.
.
.  Define constants for sizes of CYBIL tables - OS tables whose
.       sizes must be known by assembly language modules. Unless
.       otherwise stated, the sizes given here can be larger than
.       the actual size.
.
xcbsize  equ      1048            .Size of XCB.
sdtxsize equ      40              .Size of SDTX entry.
statsize equ      280             .Size of OST$STATUS.
ajllen   equ      100             .Max number of AJL entries - this constant
.                                  is used to set the size of the monitor
.                                  seg tbl. The actual size of the AJL can
.                                  be less than or equal to this value.
jrootsiz   equ      256          .Length of JMT$JOB_CONTROL_BLOCK
.
.
.
.
.   Define monitor constants
.
mstksize  equ      6500          .Length of monitor stack
mstkfram  equ      32            .Length of monitor stack frame
jstksiz1  equ      1024           .Length of job stack for ring 1
jstksiz2  equ      2048          .Length of job stack for ring 2
jstksiz3  equ      512          .Length of job stack for ring 3
jstkfram  equ      32            .Length of job stack frame
jstlen    equ      100           .Number of segments in Job Segtll
mstlen    equ      20            .Number of segments in Monitor Segtll
a170_stl  equ      6             . Number of segments in a170 seg table
.
.
.   Define 'magic' segment numbers. These equates MUST agree with
.   the actual segment numbers assigned during system generation.
.   WARNING: in most cases, no run time checks are made to see if
.   the constants defined here are correct.
.
snptmtr   equ      0             .Page table seg num in monitor.
sneimtr   equ      4             .EI segment number in MTR mode.
sneiemtr  equ      5             .EIE segment number in MTR mode.
snnosmtr  equ      3             .NOS segment number in MTR mode.
.
snjfjob   equ      3             .Job fixed in job mode.
.
.   Define a170 segment numbers for NOS, EI and EIE.
.
snnos170  equ    0           .Nos segment number
snei170   equ    4           .EI segment number
sneie170  equ    5           .EIE segment number
.
.
.   Define operating system constants
.
.
.
m_mtrmsk  equ      x'fffc'       .Monitor mode MM
j_mtrmsk  equ      x'fffc'       .Job mode MM
m_usrmsk  equ      x'ff7f'       .Monitor mode UM
j_usrmsk  equ      x'ff77'       .Job mode UM
m_usrabt  equ      x'edff'       .Fatal UCR conditions, monitor
j_usrabt  equ      x'cc00'       .Fatal UCR conditions, job
m_mcrhlt  equ      x'fb6c'       .MCR conditions that cause halt, monitor.
j_mcrhlt  equ      x'e000'       .MCR conditions that cause halt, job.
m_mcrasy  equ      x'0490'       .MCR conditions that are asynchronous.
j_mcrusr  equ      x'1b0c'       .MCR conditions that are normally
.                                 processed by the job trap handler.
.
.
.   Define offsets for referencing fields in the job table segments
.
jr_mxcb   equ       jrootsiz       .XCB for Job Monitor.
.
          page
.
.
.   Hardware Defined Constants - (it's unlikely that these will
.       ever be changed)
.
sfsa_mcr  equ      48            .Offset to MCR in Stk Frame Save Area
sfsa_ucr  equ      40            .Offset to UCR in Stk Frame Save Area
xpsize    equ      416           .Exchange package size (bytes)
xptp      equ      282           .XP offset to Trap Pointer
xpdlp     equ      290           .XP offset to Debug list pointer.
xpstau    equ      272           .XP offset to seg Table Adr upper
xpstal    equ      280           .XP offset to seg Table Adr lower
xputp     equ      274           .XP offset to UTP
xpflgte   equ      16            .XP offset to FLAGS and TE
xpmcr     equ      48            .XP offset to MCR field
xpucr     equ      40            .XP offset to UCR field
xp170mf   equ      43            .XP offset to byte containing 170 mtr flag
xpvmid    equ      8             .XP offset to VMID field
xpfdesc   equ      16            .XP offset to SFSA frame descriptor.
xpcff     equ      16            .XP offset to CFF flag.
xpstl     equ      128           .XP offset to Seg Table Len
xpum      equ      24            .XP offset to User Mask
xpmm      equ      32            .XP offset to Monitor Mask
xpkm      equ      64            .XP offset to Keypoint Mask
xppit     equ      88            .XP offset to PIT (upper)
xpbc1     equ      104           .XP offset to Base Constant (upper)
xpbc2     equ      112           .XP offset to Base Constant (lower)
xplrn     equ      296           .XP offset to LRN
xpxregs   equ      136          .XP offset to first X register
xptos     equ      298           .XP offset to Top of Stack
m_mcrsit  equ      x'0010'       .MCR masks
m_mcrexs  equ      x'0090'       .EXT INT and SIT
m_mcrhdw  equ      x'a000'       .DUE and SHORT WARNING
m_mcrsrw  equ      x'2000'
m_mcrdue  equ      x'8000'
m_mcrei   equ      x'0080'
m_mcrexc  equ      x'0400'
m_mcrpf   equ      x'0040'
m_mcrmcl  equ      x'0020'
m_mcrsel  equ      x'0002'
m_mcrtrx equ       x'0001'
m_mcrelt equ       x'0003'     .SOFT ERROR LOG and TRAP EXCEPTION.
m_ucrff   equ      x'2000'
m_ucrcff  equ      x'0400'
m_ucrkp   equ      x'0200'
m_ucrdb   equ      x'0080'
r_eid     equ      x'10'         .Element id
r_psm     equ      x'4a'         .Page size mask.
r_te      equ      x'c2'         .Trap enable
r_td      equ      x'c0'         .Trap disabled
r_ted     equ      x'c3'         .Trap enable delay
r_cff_c   equ      x'e0'         .Critical frame flag
r_jps     equ      x'61'         .Job Process State
r_sit     equ      x'62'         .System Interval Timer
r_pit     equ      x'c9'         .Process interval timer.
r_stl     equ      x'45'         .Segment Table Length
r_mcr     equ      x'42'         .Monitor condition register
r_bc      equ      x'47'         .Base constant.
r_um      equ      x'e6'         .User mask.
r_mm      equ      x'60'         .Monitor mask.
r_dlp     equ      x'c5'         .Debug list pointer.
.
.
.
.
.    PROC Definitions for initializing exchange packages
.
          PROC
xpareg    pname
          do  sn:(f:(2,2))=sn:(nil)
            org  f:(2,0)+f:(2,1)*8+10
            vfd,16,32  x'ffff',x'80000000'
          else
            org   f:(2,0)+f:(2,1)*8+10
            address  r,f:(2,2)+f:(2,3)
          dend
          PEND
          PROC
xpa       pname
          do  sn:(f:(2,2))=sn:(nil)
            org  f:(2,0)+f:(2,1)
            vfd,16,32  x'ffff',x'80000000'
          else
            org   f:(2,0)+f:(2,1)
            address  r,f:(2,2)+f:(2,3)
          dend
          PEND
          PROC
xpv       pname
          org   f:(2,0)+f:(2,1)
          vfd,f:(2,3) f:(2,2)
          PEND
.
.   Proc definition for creating equipment table entries
.
          PROC
eqdef     pname
          vfd,16,12,12,12,12  f:(2,0),1,f:(2,1),f:(2,2),f:(2,3)
          PEND
.
.
.
................ end common deck ASMBCOM ..........................
*DECK DECK=ASMINTF EXPAND=FALSE
.............. begin common deck ASMINTF .........................
          proc
procedur  pname
xxxploc   set       0,0,0,0
          align     0,8
f:(0,0)   bss       0
          def       f:(0,0)
          pend
.
         proc
function pname
         do       sn:(f:(2,0))=sn:(integer)
xxxploc    set    0,1,1,8
yyyploc    set    0
         else
           do     sn:(f:(2,0))=sn:(subrange)
xxxploc      set  0,1,3,f:(2,1)
yyyploc      set  0
           else
             do   sn:(f:(2,0))=sn:(boolean)
xxxploc        set 0,1,4,1
yyyploc        set 0
             else
               do  sn:(f:(2,0))=sn:(pointer)
xxxploc          set 0,1,2,6
yyyploc          set 1
               else
               flag fatal  .unknown return type
               dend
             dend
           dend
         dend
         align    0,8
f:(0,0)  bss      0
         def      f:(0,0)
         pend
.
         proc
freturnx pname
          do     xxxploc(1)=1
          do     yyyploc=0
            do   #regtyp(f:(2,0))=#xreg
              do   f:(2,0)=15
                return
              else
                cpyxx  xf,f:(2,0)
              dend
            else
              flag fatal       .Incorrect register usage
            dend
          else
            do   #regtyp(f:(2,0))=#areg
              do f:(2,0)=15
                return
              else
                cpyaa  af,f:(2,0)
              dend
            else
              cpyxa     af,f:(2,0)
            dend
          dend
          return
          else
            flag fatal       .not in a function
          dend
         pend
.
          proc
param     pname
          local  data_t,param_t,param_l,field_l,offset
param_l   set    0
offset    set    0
          do     sn:(f:(2,1))=sn:(integer)
data_t    set    1
field_l   set    8
          dend
          do     sn:(f:(2,1))=sn:(pointer)
data_t    set    2
field_l   set    6
offset    set    2
          dend
          do     sn:(f:(2,1))=sn:(subrange)
data_t    set    3
field_l   set    f:(2,2)(0)
offset    set    8-f:(2,2)(0)
          dend
          do     sn:(f:(2,1))=sn:(boolean)
data_t    set    4
field_l   set    1
offset    set    7
          dend
          do     sn:(f:(2,1))=sn:(string)
            do     f:(2,2)<=8
data_t    set    5
field_l   set    f:(2,2)(0)
offset    set    8-f:(2,2)(0)
            dend
            do     f:(2,2)>8
data_t    set    6
field_l   set    6
param_l   set    f:(2,2)(0)
            dend
          dend
           do     sn:(f:(2,1))=sn:(astring)
data_t    set    7
field_l   set    8
          dend
.
          do     sn:(f:(2,0))=sn:(ref)
            do     data_t<=5
param_t   set    1
param_l   set    field_l
field_l   set    6
offset    set    0
            dend
          else
param_t   set    2
          dend
.
f:(0,0)   set    xxxploc(0)+offset,data_t,param_t,field_l,param_l
xxxploc(0)  set    xxxploc(0)+8
          pend
.
.
          proc
ploada    pname
          do     f:(2,1)(1)=6
f:(0,0)   la     f:(2,0),a_plist,f:(2,1)(0)
          else
            do     f:(2,1)(2)=1
              do     f:(2,1)(1)=2
f:(0,0)       la     amacsr,a_plist,f:(2,1)(0)
              la     f:(2,0),amacsr,0
              else
f:(0,0)         la     f:(2,0),a_plist,f:(2,1)(0)
              dend
            else
              do     f:(2,1)(1)=2
f:(0,0)       la     f:(2,0),a_plist,f:(2,1)(0)
              else
                flag  fatal    .Wrong macro usage
              dend
            dend
          dend
          pend
.
.
          proc
ploadx    pname
          do     f:(2,1)(1)=2
          flag   fatal       .Wrong macro usage
          else
            do     f:(2,1)(1)=6
            flag   fatal     .Wrong macro usage
            else
              do     f:(2,1)(1)=7
              flag   fatal    .Wrong macro usage
              dend
            dend
          dend
          do     f:(2,1)(2)=1
f:(0,0)   la     amacsr,a_plist,f:(2,1)(0)
          lbyts,f:(2,1)(4)  f:(2,0),amacsr,x0,0
          else
f:(0,0)   lbyts,f:(2,1)(3)  f:(2,0),a_plist,x0,f:(2,1)(0)
          dend
          pend
.
.    PSTRING  This macro is used only for adaptable strings.
.
          proc
pstring   pname
          do     f:(2,2)(1)=7
f:(0,0)   la     f:(2,0),a_plist,f:(2,2)(0)
          lbyts,2  f:(2,1),a_plist,x0,f:(2,2)(0)+6
          else
            flag   fatal    .Wrong macro usage
          dend
          pend
.
.
          proc
pstorxp   pname
          do        f:(2,1)(2)=1
f:(0,0)     la      amacscr,a_plist,f:(2,1)(0)
            sbyts,f:(2,1)(4)  f:(2,0),amacscr,x0,0
          else
            flag    fatal  .must be pointer type
          dend
          pend
.
          proc
pstorap   pname
          do        f:(2,1)(1)=2
            do f:(2,1)(4)=6
f:(0,0)       la    amacscr,a_plist,f:(2,1)(0)
              sa    f:(2,0),amacscr,0
            else
              flag   fatal  .param length must be 6
             dend
          else
            flag    fatal  .must be pointer type
          dend
          pend
.
................end common deck ASMINTF ..........................
*DECK DECK=ASMREGS EXPAND=FALSE
.....................  begin common deck ASMREGS ................
.
.
.  Define Macros for definning X and A register equates.
.
          PROC
xreg      pname
f:(0,0)   equ    f:(2,0)
f:(0,0)   atrib  #regtyp,#xreg
          PEND
          PROC
areg      pname
f:(0,0)   equ    f:(2,0)
f:(0,0)   atrib  #regtyp,#areg
          PEND
.
.  Define A and X register usage
.
a_tos     areg     0
a_dsp     areg     0
a_csf     areg     1
a_psa     areg     2
a_bindin  areg     3
a_plist   areg     4
.
.
.
.....................  end common deck ASMREGS ....................
*DECK DECK=ASMXOFS EXPAND=FALSE
................................begin common deck ASMXOFS.....................
.
.     Define byte offsets for the various fields in a 180 version
.     of a 170 XP.
.
.
a0_180    equ    10          .Offset to A0
a2_180    equ    26          .Offset to A2
x_180     equ    25          .Offset to first X reg
a_180     equ    76          .Offset to first A reg
b_180     equ    144         .Offset to first B reg
b2_ofs    equ    152         .Offset to B2
b3_ofs    equ    160         .Offset to B3
rac_180   equ    36          .Offset to RAc
flc_180   equ    44          .Offset to FLc
em_180    equ    34          .Offset to EM
rae_180   equ    60          .Offset to RAe
fle_180   equ    68          .Offset to FLe
ma_180    equ    52          .Offset to MA
a0_170    equ    72+4        . 170 A0
a1_170    equ    80+4        . 170 A1
b1_170    equ    144+4       . 170 B1
.
.
.     Define offsets for the various fields in a 170 XP.
.
.
x_170     equ    8          .Offset to first X reg
a_170     equ    0           .Word offset to first A reg
.................................end common deck ASMXOFS.......................
*DECK DECK=AVC$ACCOUNTING_STATISTICS EXPAND=FALSE

?? NEWTITLE := 'avc$accounting_statistics' ??
?? FMT (FORMAT := OFF) ??
*copyc ave$scc_range

  CONST
    avc$cp_time = avc$min_scc,
    avc$page_faults = avc$min_scc + 1,
    avc$working_set_size = avc$min_scc + 2,
    avc$ready_task_count = avc$min_scc + 3,
    avc$job_login = avc$min_scc + 4,
    avc$job_logout = avc$min_scc + 5,
    avc$begin_account = avc$min_scc + 6,
    avc$end_account = avc$min_scc + 7,
    avc$system_resource_units = avc$min_scc + 8,
    avc$begin_application = avc$min_scc + 9,
    avc$end_application = avc$min_scc + 10,
    avc$application_units = avc$min_scc + 11,
    avc$begin_emit_space_statistics = avc$min_scc + 12,
    avc$catalog = avc$min_scc + 13,
    avc$cycle = avc$min_scc + 14,
    avc$project_member_catalog = avc$min_scc + 15,
    avc$project_member_cycle = avc$min_scc + 16,
    avc$user_catalog = avc$min_scc + 17,
    avc$user_cycle = avc$min_scc + 18,
    avc$end_emit_space_statistics = avc$min_scc + 19,
    avc$anajal_error = avc$min_scc + 20,
    avc$detach_job = avc$min_scc + 21,
    avc$attach_job = avc$min_scc + 22,
    avc$applic_accounting_error = avc$min_scc + 23,
    avc$account_member_catalog = avc$min_scc + 24,
    avc$account_member_cycle = avc$min_scc + 25,
    avc$invalid_access_error = avc$min_scc + 26,
    avc$ca_input_file = avc$min_scc + 27,
    avc$ca_output_file = avc$min_scc + 28,
    avc$ca_output_queue_residency = avc$min_scc + 29,
    avc$ca_print_file = avc$min_scc + 30,
    avc$ca_submit_job = avc$min_scc + 31,
    avc$ca_standard_output_file = avc$min_scc + 32,
    avc$ca_request_pf_transfer = avc$min_scc + 33,
    avc$ca_target_pf_transfer = avc$min_scc + 34,
    avc$ca_origin_qf_transfer = avc$min_scc + 35,
    avc$ca_dest_qf_transfer = avc$min_scc + 36,
    avc$ca_interactive_interval = avc$min_scc + 37,
    avc$ca_ftp_client_ctrl_connect = avc$min_scc + 38,
    avc$ca_ftp_client_data_connect = avc$min_scc + 39,
    avc$ca_ftp_server_ctrl_connect = avc$min_scc + 40,
    avc$ca_ftp_server_data_connect = avc$min_scc + 41;

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

*DECK DECK=AVC$COMPILE_KEYPOINTS EXPAND=FALSE
  ?VAR
*IF ($variable(avv$compile_keypoints, declared) = 'LOCAL') AND avv$compile_keypoints
    avc$compile_keypoints: boolean := TRUE ?;
*ELSE
    avc$compile_keypoints: boolean := FALSE ?;
*IFEND
*DECK DECK=AVC$COMPILE_TEST_CODE EXPAND=FALSE

  ?VAR
*IF ($variable(avv$compile_test_code, declared) = 'LOCAL') AND avv$compile_test_code
    avc$compile_test_code: boolean := TRUE ?;
*ELSE
    avc$compile_test_code: boolean := FALSE ?;
*IFEND
*DECK DECK=AVC$DATE_TIME_DISPLAY_FORMATS EXPAND=FALSE

{ Constants that correspond to the various date/time display formats supported
{ by the template file manager.

  CONST
    avc$ampm_time_format = 'AMPM',
    avc$dmy_date_format = 'D2.M2.Y2',
    avc$hms_time_format = 'HMS',
    avc$iso_date_format = 'Y4-M2-D2',
    avc$iso_time_format = 'ISOT',
    avc$millisecond_time_format = 'MS',
    avc$month_date_format = 'MN D2, Y4',
    avc$mdy_date_format = 'M2/D2/Y2',
    avc$ordinal_date_format = 'Y4J3';

*DECK DECK=AVC$DATE_TIME_TYPE_DEFAULTS EXPAND=FALSE

{ Default value for the fields of a date_time type specification

  CONST
    avc$date_applies_default = TRUE,
    avc$date_format_default = avc$month_date_format,
    avc$date_time_range_default = FALSE,
    avc$time_applies_default = TRUE,
    avc$time_format_default = avc$ampm_time_format;

*copyc avc$date_time_display_formats
*DECK DECK=AVC$HIGH_VALUE_NAME EXPAND=FALSE

  CONST
    avc$high_value_name = '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~';
*DECK DECK=AVC$INTEGER_TYPE_DEFAULTS EXPAND=FALSE

{ Default values for the fields in an integer type specification.

  CONST
    avc$display_radix_default = FALSE,
    avc$integer_field_size_default = 10,
    avc$max_integer_value_default = 1000000,
    avc$min_integer_value_default = 0,
    avc$radix_default = 10;
*DECK DECK=AVC$KEYWORD_TYPE_DEFAULTS EXPAND=FALSE

{ Default valus for the fields in a keyword type specification.

  CONST
    avc$maximum_keywords_default = 1,
    avc$minimum_keywords_default = 1;
*DECK DECK=AVC$LIMIT_TYPE_DEFAULTS EXPAND=FALSE

{ Default values for field in a limit type specification.

  CONST
    avc$total_limit_applies_default = TRUE,
    avc$job_limits_apply_default = TRUE,
    avc$limit_stops_login_default = TRUE;
*DECK DECK=AVC$MAXIMUM_DESC_RECORD_COUNT EXPAND=FALSE

{ Maximum number of description records that can be defined in a template file.

  CONST
    avc$maximum_desc_record_count = 15;
*DECK DECK=AVC$MAXIMUM_FIELD_COUNT EXPAND=FALSE

{ Maximum number of fields that can be defined in a description record for a
{ template file.

  CONST
    avc$maximum_field_count = 512;
*DECK DECK=AVC$MAXIMUM_INDEX_DEPTH EXPAND=FALSE

{ Maximum number of index levels allowed in a template file.

  CONST
    avc$maximum_index_depth = 15;

*DECK DECK=AVC$MAXIMUM_NAME_LIST_SIZE EXPAND=FALSE

{ Maximum size of a name list in a template file.

  CONST
    avc$maximum_name_list_size = 256;
*DECK DECK=AVC$MAX_NUMBER_OF_FAMILIES EXPAND=FALSE

  CONST
    avc$max_number_of_families = 999;
*DECK DECK=AVC$MAX_TEMPLATE_FILE_KEY_SIZE EXPAND=FALSE

{ Maximum size of a key for a record in a template file.

  CONST
    avc$max_template_file_key_size = 3 * osc$max_name_size;

*copyc ost$name
*DECK DECK=AVC$MAX_TEMPLATE_INDEX_KEYS EXPAND=FALSE

{ Maximum number of keys that will be stored in an index block of a template
{ file.

  CONST
    avc$max_template_index_keys = 32;

*DECK DECK=AVC$MAX_TEMPLATE_RECORD_SIZE EXPAND=FALSE

{ Maximum size of a record stored in a template file.

  CONST
    avc$max_template_record_size = 0ffff(16);
*DECK DECK=AVC$MIN_ECC EXPAND=FALSE

  CONST
*IF $true(osv$unix)
    avc$min_ecc = (($INTEGER ('A') * 100(16)) + $INTEGER ('V')) * 10000(16);
*ELSE
    avc$min_ecc = (($INTEGER ('A') * 100(16)) + $INTEGER ('V')) * 1000000(16);
*IFEND
*DECK DECK=AVC$MONITOR_STATISTICS_FLAG EXPAND=FALSE
*DECK DECK=AVC$NAME_TYPE_DEFAULTS EXPAND=FALSE

{ Default valus for the fields in a name type specification.

  CONST
    avc$maximum_names_default = 1,
    avc$minimum_names_default = 1;
*DECK DECK=AVC$NO_EXPIRATION_DATE EXPAND=FALSE

  CONST
    avc$no_expiration_date = 255;

*copyc ost$date_time
*DECK DECK=AVC$REAL_TYPE_DEFAULTS EXPAND=FALSE

{ Default values for the fields in a real type specification.

  CONST
    avc$maximum_real_value_default = 1000000.0,
    avc$minimum_real_value_default = 0.0,
    avc$real_field_size_default = 13,
    avc$real_format_kind_default = avc$fixed_point_format,
    avc$real_fraction_size_default = 2;

*copyc avt$numeric_display_fmt_kind
*DECK DECK=AVC$STRING_TYPE_DEFAULTS EXPAND=FALSE

{ Default values for fields in a string type specification.

  CONST
    avc$maximum_string_size_default = osc$max_string_size,
    avc$minimum_string_size_default = 0;

*copyc ost$string
*DECK DECK=AVC$SYSTEM_DEFINED_LIMIT_NAMES EXPAND=FALSE

  CONST
    avc$magnetic_tape_limit_name = 'MAGNETIC_TAPE                  ',
    avc$cpu_time_limit_name = 'CPU_TIME                       ',
    avc$task_limit_name = 'TASK                           ',
    avc$sru_limit_name = 'SRU                            ',
    avc$pfs_limit_name = 'PERMANENT_FILE_SPACE           ',
    avc$tfs_limit_name = 'TEMPORARY_FILE_SPACE           ';

{ The following constant defines the old (pre 1.5.1) name for the CPU time limit.
{ It has been left to provide compatibility with existing programs.  Any uses of
{ this constant should be changed to reference AVC$CPU_TIME_LIMIT_NAME.

  CONST
    avc$cp_time_limit_name = 'CP_TIME                        ';
*DECK DECK=AVC$SYSTEM_EPILOG EXPAND=FALSE

  CONST
    avc$system_epilog = '$SYSTEM.PROLOGS_AND_EPILOGS.SYSTEM_EPILOG';
*DECK DECK=AVC$SYSTEM_PROLOG EXPAND=FALSE

  CONST
    avc$system_prolog = '$SYSTEM.PROLOGS_AND_EPILOGS.SYSTEM_PROLOG';

*DECK DECK=AVC$TEMPLATE_FILE_HEAP_SIZE EXPAND=FALSE

{ Size of the heap allocated in a template file to hold description and data
{ records.

  CONST
    avc$template_file_heap_size = 6ffffff(16);
*DECK DECK=AVC$TEMPLATE_FILE_VERSION EXPAND=FALSE

{ Template file manager version identifier.

  CONST
    avc$template_file_version = 'AVM$TEMPLATE_FILE_MANAGER 1.0  ';
*DECK DECK=AVC$TYPE_SPECIFICATION_DEFAULTS EXPAND=FALSE
*copyc avc$date_time_type_defaults
*copyc avc$integer_type_defaults
*copyc avc$keyword_type_defaults
*copyc avc$limit_type_defaults
*copyc avc$name_type_defaults
*copyc avc$real_type_defaults
*copyc avc$string_type_defaults
*DECK DECK=AVC$UNLIMITED_EXP_INTERVAL EXPAND=FALSE

  CONST
    avc$unlimited_exp_interval = osc$max_integer;

*copyc osd$integer_limits
*DECK DECK=AVC$VALIDATION_DEFAULT_VALUES EXPAND=FALSE

{ Account field - Account Epilog

  CONST
    avc$account_epilog_default = '$NULL',
    avc$account_epilog_description = 'File containing the account epilog.';

  VAR
    avc$account_epilog_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['CHANGE_ACCOUNT_EPILOG', 'CHAAE'],
    avc$account_epilog_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['DISPLAY_ACCOUNT_EPILOG', 'DISAE'];

{ Account field - Account Prolog

  CONST
    avc$account_prolog_default = '$NULL',
    avc$account_prolog_description = 'File containing the account prolog.';

  VAR
    avc$account_prolog_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['CHANGE_ACCOUNT_PROLOG', 'CHAAP'],
    avc$account_prolog_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['DISPLAY_ACCOUNT_PROLOG', 'DISAP'];

{ Member field - Account Administration

  CONST
    avc$account_admin_default = FALSE,
    avc$account_admin_description =
          'Allows the member to perform account administration functions.';

{ Member field - Project Administration

  CONST
    avc$project_admin_default = FALSE,
    avc$project_admin_description =
          'Allows the member to perform project administration functions.';

{ Member field - User Administration

  CONST
    avc$user_admin_acct_descr =
          'Allows the member to create, change, display, and delete users.',
    avc$user_admin_default = FALSE,
    avc$user_admin_proj_descr =
          'Allows the member to create, change, display, and delete users.';

{ Project field - Project Epilog

  CONST
    avc$project_epilog_default = '$NULL',
    avc$project_epilog_description = 'File containing the project epilog.';

  VAR
    avc$project_epilog_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['CHANGE_PROJECT_EPILOG', 'CHAPE'],
    avc$project_epilog_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['DISPLAY_PROJECT_EPILOG', 'DISPE'];

{ Project field - Project Prolog

  CONST
    avc$project_prolog_default = '$NULL',
    avc$project_prolog_description = 'File containing the project prolog.';

  VAR
    avc$project_prolog_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['CHANGE_PROJECT_PROLOG', 'CHAPP'],
    avc$project_prolog_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['DISPLAY_PROJECT_PROLOG', 'DISPP'];

{ User field - Accounting Administration

  CONST
    avc$accounting_admin_default = FALSE,
    avc$accounting_admin_descr =
          'Allows the user to perform accounting administration functions.';

{ User field - Application Administration

  CONST
    avc$application_admin_default = FALSE,
    avc$application_admin_descr =
          'Allows the user to perform application administration functions.';

{ User field - Configuration Administration

  CONST
    avc$configuration_admin_default = FALSE,
    avc$configuration_admin_descr =
          'Allows the user to manipulate configuration parameters.';

{ User field - CPU Time Limit

  CONST
    avc$cpu_job_limits_apply_def = TRUE,
    avc$cpu_limit_name_default = avc$cp_time_limit_name,
    avc$cpu_time_limit_description =
          'Limits the combined job and monitor CPU seconds.',
    avc$cpu_tot_lim_stops_login_def = TRUE,
    avc$cpu_total_limit_applies_def = FALSE,
    avc$maximum_cpu_default = sfc$unlimited,
    avc$minimum_cpu_default = 1;

  VAR
    avc$cpu_time_limit_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['CHANGE_CPU_TIME_LIMIT', 'CHACTL'],
    avc$cpu_time_limit_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['DISPLAY_CPU_TIME_LIMIT', 'DISCTL'];

{ User field - Creation Account Project

  CONST
    avc$creation_acct_proj_descr = 'Execution account and project of the a' CAT
          'dministrator who created the user.';

  VAR
    avc$creation_acct_proj_chg_cmd: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 2] of ost$name := ['CHANGE_CREATION_ACCOUNT_PROJECT',
          'CHACAP'],
    avc$creation_acct_proj_dis_cmd: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 2] of ost$name := ['DISPLAY_CREATION_ACCT_PROJ',
          'DISCAP'];

{ User field - Default Account Project

  CONST
    avc$default_account_default = 'NONE                           ',
    avc$default_acct_proj_descr = 'Default login account and project.',
    avc$default_project_default = 'NONE                           ';

  VAR
    avc$default_acct_proj_chg_cmd: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 2] of ost$name := ['CHANGE_DEFAULT_ACCOUNT_PROJECT',
          'CHADAP'],
    avc$default_acct_proj_dis_cmd: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 2] of ost$name := ['DISPLAY_DEFAULT_ACCOUNT_PROJECT',
          'DISDAP'];

{ User field - Dual State Link Attribute

  CONST
    avc$link_attrib_charge_descr =
          'Default account for interstate communication.',
    avc$link_attrib_family_descr =
          'Default family for interstate communication.',
    avc$link_attrib_password_descr =
          'Default password for interstate communication.',
    avc$link_attrib_project_descr =
          'Default project for interstate communication.',
    avc$link_attrib_user_descr = 'Default user for interstate communication.',
    avc$link_attribute_maximum_size = 31,
    avc$link_attribute_minimum_size = 0;

  VAR
    avc$link_attribute_default: [STATIC, READ, oss$job_paged_literal]
          ost$string := [0, ''],
    avc$link_attrib_charge_chg_cmd: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 2] of ost$name := ['CHANGE_LINK_ATTRIBUTE_CHARGE',
          'CHALAC'],
    avc$link_attrib_family_chg_cmd: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 2] of ost$name := ['CHANGE_LINK_ATTRIBUTE_FAMILY',
          'CHALAF'],
    avc$link_attrib_pw_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['CHANGE_LINK_ATTRIBUTE_PASSWORD',
          'CHALAPW'],
    avc$link_attrib_project_chg_cmd: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 2] of ost$name := ['CHANGE_LINK_ATTRIBUTE_PROJECT',
          'CHALAP'],
    avc$link_attrib_user_chg_cmd: [STATIC, READ,
          oss$job_paged_literal] array [1 .. 2] of ost$name :=
          ['CHANGE_LINK_ATTRIBUTE_USER', 'CHALAU'],
    avc$link_attrib_charge_dis_cmd: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 2] of ost$name := ['DISPLAY_LINK_ATTRIBUTE_CHARGE',
          'DISLAC'],
    avc$link_attrib_family_dis_cmd: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 2] of ost$name := ['DISPLAY_LINK_ATTRIBUTE_FAMILY',
          'DISLAF'],
    avc$link_attrib_pw_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['DISPLAY_LINK_ATTRIBUTE_PASSWORD',
          'DISLAPW'],
    avc$link_attrib_project_dis_cmd: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 2] of ost$name := ['DISPLAY_LINK_ATTRIBUTE_PROJECT',
          'DISLAP'],
    avc$link_attrib_user_dis_cmd: [STATIC, READ,
          oss$job_paged_literal] array [1 .. 2] of ost$name :=
          ['DISPLAY_LINK_ATTRIBUTE_USER', 'DISLAU'];

{ User field - Dual State Prompt

  CONST
    avc$dual_state_prompt_default = FALSE,
    avc$dual_state_prompt_descr = 'Forces prompting for account and projec' CAT
          't during a dual state login.';

{ User field - Engineering Administration

  CONST
    avc$engineering_operation_def = FALSE,
    avc$engineering_operation_descr =
          'Allow the user to perform system maintenance functions.';

{ User field - Explicit Remote File

  CONST
    avc$explicit_remote_file_def = TRUE,
    avc$explicit_remote_file_descr = 'Allows the user to transfer remote f' CAT
          'iles using the MANAGE_REMOTE_FILE utility.';

{ User field - Family Administration

  CONST
    avc$family_admin_default = FALSE,
    avc$family_admin_description =
          'Allows the user to perform family administration functions.';

{ User field - Implicit remote file

  CONST
    avc$implicit_remote_file_def = TRUE,
    avc$implicit_remote_file_descr =
          'Allows the user to transfer remote files using implicit routing.';

{ User field - Job Class

  CONST
    avc$$sys_$sys_job_class_bat_def = 'BATCH                          ',
    avc$$sys_$sys_job_class_def = 'ALL                            ',
    avc$$sys_$sys_job_class_int_def = 'INTERACTIVE                    ',
    avc$$sys_user_job_class_bat_def = 'NONE                           ',
    avc$$sys_user_job_class_def = 'NONE                           ',
    avc$$sys_user_job_class_int_def = 'NONE                           ',
    avc$batch_job_class_default = 'BATCH                          ',
    avc$interactive_job_class_def = 'INTERACTIVE                    ',
    avc$job_class_description =
          'Defines the user''s available and default job classes.';

  VAR
    avc$common_job_class_defaults: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 3] of ost$name := ['BATCH', 'INTERACTIVE',
          'SYSTEM_DEFAULT'],
    avc$job_class_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 3] of ost$name := ['CHANGE_JOB_CLASS', 'CHANGE_JOB_CLASSES',
          'CHAJC'],
    avc$job_class_defaults: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 3] of ost$name := ['BATCH', 'INTERACTIVE', 'SYSTEM_DEFAULT'],
    avc$job_class_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 3] of ost$name := ['DISPLAY_JOB_CLASS', 'DISPLAY_JOB_CLASSES',
          'DISJC'];

{ User field - Job destination usages.

  CONST
    avc$jdu_min_number_of_names = 1,
    avc$jdu_max_number_of_names = 256,
    avc$job_dest_usages_descr =
          'Allows the user access to the specified job destination usages.';

  VAR
    avc$job_destination_usages_def: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 5] of ost$name := ['NTF', 'QTF', 'VE', 'VE_LOCAL',
          'VE_QTF'],
    avc$job_dest_usages_names_def: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 1] of ost$name := ['NONE'],
    avc$job_dest_usages_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['CHANGE_JOB_DESTINATION_USAGES', 'CHAJDU'],
    avc$job_dest_usages_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['DISPLAY_JOB_DESTINATION_USAGES', 'DISJDU'];

{ User field - Login Password

  CONST
    avc$login_password_description =
          'Contains the user''s login password information.';

  VAR
    avc$exp_chg_interval_default: [STATIC, READ, oss$job_paged_literal]
          pmt$time_increment := [0, 0, 0, 0, 0, 0, 0],
    avc$exp_interval_default: [STATIC, READ, oss$job_paged_literal]
          pmt$time_increment := [0, 0, avc$unlimited_exp_interval, 0, 0, 0, 0],
    avc$exp_warning_default: [STATIC, READ, oss$job_paged_literal]
          pmt$time_increment := [0, 0, avc$unlimited_exp_interval, 0, 0, 0, 0],
    avc$expiration_date_default: [STATIC, READ, oss$job_paged_literal]
          ost$date_time := [avc$no_expiration_date, 12, 31, 23, 59, 59, 999],
    avc$login_pass_attribute_def: [STATIC, READ,
          oss$job_paged_literal] array [1 .. 1] of ost$name := ['NONE'],
    avc$login_password_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['CHANGE_LOGIN_PASSWORD', 'CHALPW'],
    avc$login_password_default: [STATIC, READ, oss$job_paged_literal]
          avt$login_password := [FALSE, 'PLEASE_CHANGE_THIS_PASSWORD_NOW'],
    avc$login_password_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['DISPLAY_LOGIN_PASSWORD', 'DISLPW'],
    avc$max_exp_interval_default: [STATIC, READ, oss$job_paged_literal]
          pmt$time_increment := [0, 0, avc$unlimited_exp_interval, 0, 0, 0, 0];

{ User field - Magnetic Tape Limit

  CONST
    avc$mt_limit_name_default = avc$magnetic_tape_limit_name,
    avc$mt_job_limits_apply_def = TRUE,
    avc$mt_tot_lim_stops_login_def = TRUE,
    avc$mt_total_limit_applies_def = FALSE,
    avc$magnetic_tape_min_default = 0,
    avc$magnetic_tape_limit_default = sfc$unlimited,
    avc$magnetic_tape_max_default = sfc$unlimited,
    avc$magnetic_tape_limit_descr =
          'Limits the number of tapes that a user''s job may have mounted ' CAT
          'concurrently.';

  VAR
    avc$magnetic_tape_limit_chg_cmd: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 2] of ost$name := ['CHANGE_MAGNETIC_TAPE_LIMIT',
          'CHAMTL'],
    avc$magnetic_tape_limit_dis_cmd: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 2] of ost$name := ['DISPLAY_MAGNETIC_TAPE_LIMIT',
          'DISMTL'];

{ User field - MAIL/VE Administration

  CONST
    avc$mailve_administration_descr =
          'Controls the level of access of the user to MAILVE.',
    avc$mailve_max_number_of_names = 1,
    avc$mailve_min_number_of_names = 1;

  VAR
    avc$$sys_$sys_mailve_admin_def: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 1] of ost$name := ['ANALYST'],
    avc$mailve_admin_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['CHANGE_MAILVE_ADMINISTRATION', 'CHAMA'],
    avc$mailve_admin_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['DISPLAY_MAILVE_ADMINISTRATION', 'DISMA'],
    avc$mailve_admin_names_def: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 1] of ost$name := ['NONE'],
    avc$mailve_common_names_def: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 4] of ost$name := ['ANALYST', 'SYSTEM', 'FAMILY', 'SELF'];

{ User field - MAIL/VE Distribution List Limit

  CONST
    avc$mailve_dist_list_limit_def = 25,
    avc$mailve_dist_list_limit_desc =
          'Limits the number of MAILVE distribution lists.',
    avc$mailve_dist_list_max_def = 256,
    avc$mailve_dist_list_min_def = 0;

  VAR
    avc$mailve_dist_list_chg_cmd: [STATIC, READ,
          oss$job_paged_literal] array [1 .. 2] of ost$name :=
          ['CHANGE_MAILVE_DIST_LIST_LIMIT', 'CHAMDLL'],
    avc$mailve_dist_list_dis_cmd: [STATIC, READ,
          oss$job_paged_literal] array [1 .. 2] of ost$name :=
          ['DISPLAY_MAILVE_DIST_LIST_LIMIT', 'DISMDLL'];

{ User field - MAIL/VE Mailbox Limit

  CONST
    avc$mailve_mailbox_lim_max_def = 256,
    avc$mailve_mailbox_lim_min_def = 0,
    avc$mailve_mailbox_limit_def = 1,
    avc$mailve_mailbox_limit_descr = 'Limits the number of MAILVE mailboxes.';

  VAR
    avc$mailve_mailbox_lim_chg_cmd: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 2] of ost$name := ['CHANGE_MAILVE_MAILBOX_LIMIT',
          'CHAMML'],
    avc$mailve_mailbox_lim_dis_cmd: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 2] of ost$name := ['DISPLAY_MAILVE_MAILBOX_LIMIT',
          'DISMML'];

{ User field - MAIL/VE Retention Limit

  CONST
    avc$mailve_retention_limit_def = 14,
    avc$mailve_retention_limit_desc =
          'Specifies the maximum retention period for a MAILVE mailbox.',
    avc$mailve_retention_max_def = sfc$unlimited,
    avc$mailve_retention_min_def = 1;

  VAR
    avc$mailve_retention_chg_cmd: [STATIC, READ,
          oss$job_paged_literal] array [1 .. 2] of ost$name :=
          ['CHANGE_MAILVE_RETENTION_LIMIT', 'CHAMRL'],
    avc$mailve_retention_dis_cmd: [STATIC, READ,
          oss$job_paged_literal] array [1 .. 2] of ost$name :=
          ['DISPLAY_MAILVE_RETENTION_LIMIT', 'DISMRL'];

{ User field - Network Application Management

  CONST
    avc$network_applic_mgmt_def = FALSE,
    avc$network_applic_mgmt_descr =
          'Allows the user to access the MANAGE_NETWORK_APPLICATION utility.';

{ User field - Network Operation

  CONST
    avc$network_operation_default = FALSE,
    avc$network_operation_descr =
          'Allows the user to access the CDCNET NETWORK_OPERATOR utility.';

{ User field - NTF Operation

  CONST
    avc$ntf_operation_default = FALSE,
    avc$ntf_operation_description =
          'Allows the user to access the OPERATE_NTF utility.';

{ User field - Output destination usages.

  CONST
    avc$odu_min_number_of_names = 1,
    avc$odu_max_number_of_names = 256,
    avc$output_dest_usages_descr =
          'Allows the user access to the specified output destination usages.';

  VAR
    avc$output_dest_usages_def: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 5] of ost$name := ['DUAL_STATE', 'NTF', 'PRIVATE', 'PUBLIC',
          'QTF'],
    avc$output_dest_usage_names_def: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 1] of ost$name := ['NONE'],
    avc$output_dest_usages_chg_cmd: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 2] of ost$name := ['CHANGE_OUTPUT_DEST_USAGES',
          'CHAODU'],
    avc$output_dest_usages_dis_cmd: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 2] of ost$name := ['DISPLAY_OUTPUT_DEST_USAGES',
          'DISODU'];

{ User field - Permanent File Space Limit

  CONST
    avc$maximum_pfs_default = sfc$unlimited,
    avc$minimum_pfs_default = 0,
    avc$perm_file_space_limit_descr =
          'Limits the number of bytes of permanent file space.',
    avc$pfs_job_limits_apply_def = FALSE,
    avc$pfs_limit_name_default = avc$pfs_limit_name,
    avc$pfs_tot_lim_stops_login_def = FALSE,
    avc$pfs_total_limit_applies_def = TRUE;

  VAR
    avc$perm_file_space_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['CHANGE_PERM_FILE_SPACE_LIMIT', 'CHAPFSL'],
    avc$perm_file_space_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['DISPLAY_PERM_FILE_SPACE_LIMIT', 'DISPFSL'];

{ User field - Permit Level

  CONST
    avc$permit_level_default = 'PUBLIC                         ',
    avc$permit_level_description =
          'Controls the user''s permit creation domain.',
    avc$pl_max_number_of_names = 1,
    avc$pl_min_number_of_names = 1;

  VAR
    avc$permit_level_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['CHANGE_PERMIT_LEVEL', 'CHAPL'],
    avc$permit_level_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['DISPLAY_PERMIT_LEVEL', 'DISPL'],
    avc$permit_level_names_def: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 1] of ost$name := ['PUBLIC'],
    avc$permit_level_com_names_def: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 6] of ost$name := ['PUBLIC', 'FAMILY', 'ACCOUNT',
          'PROJECT', 'USER', 'OWNER'];

{ User field - Removable Media Access

  CONST
    avc$removable_media_access_desc =
          'Allows the user access to the specified removable media.';

  VAR
    avc$$sys_$sys_rma_default: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 1] of avt$labeled_names :=
          [[^avc$$sys_rma_groups_default, ^avc$$sys_rma_access_modes_def]],
    avc$$sys_rma_groups_default: [STATIC, READ, oss$job_paged_literal]
          ost$name := 'ALL',
    avc$$sys_rma_access_modes_def: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 1] of ost$name := ['ALL'],
    avc$rma_groups_default: [STATIC, READ, oss$job_paged_literal]
          ost$name := 'NONE',
    avc$rma_access_modes_default: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 1] of ost$name := ['NONE'],
    avc$removable_media_access_def: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 1] of avt$labeled_names :=
          [[^avc$rma_groups_default, ^avc$rma_access_modes_default]],
    avc$rma_valid_groups_default: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 1] of ost$name := ['NONE'],
    avc$rma_valid_access_modes_def: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 1] of ost$name := ['NONE'],
    avc$rma_change_commands: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['CHANGE_REMOVABLE_MEDIA_ACCESS', 'CHARMA'],
    avc$rma_display_commands: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['DISPLAY_REMOVABLE_MEDIA_ACCESS', 'DISRMA'];

{ User field - Removable Media Operation

  CONST
    avc$removable_media_oper_def = FALSE,
    avc$removable_media_oper_descr = 'Allows the user to operate removable' CAT
          ' media peripherals.';

{ User field - Removable Media Administration

  CONST
    avc$removable_media_admin_def = FALSE,
    avc$removable_media_admin_descr = 'Allows the user to operate and admin' CAT
          'ister removable media peripherals.';

{ User field - Ring Privileges

  CONST
    avc$$sys_$sys_minimum_ring_def = osc$sj_ring_1,
    avc$$sys_$sys_nominal_ring_def = osc$user_ring,
    avc$minimum_ring_default = osc$user_ring,
    avc$nominal_ring_default = osc$user_ring,
    avc$ring_privilege_description =
          'Defines the user''s nominal and minimum rings.';

  VAR
    avc$ring_privilege_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 3] of ost$name := ['CHANGE_RING_PRIVILEGE',
          'CHANGE_RING_PRIVILEGES', 'CHARP'],
    avc$ring_privilege_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 3] of ost$name := ['DISPLAY_RING_PRIVILEGE',
          'DISPLAY_RING_PRIVILEGES', 'DISRP'];

{ User field - Scheduling Administration

  CONST
    avc$scheduling_admin_default = FALSE,
    avc$scheduling_admin_descr =
          'Allows the user to perform scheduling administration functions.';

{ User field - SRU Limit

  CONST
    avc$maximum_sru_default = sfc$unlimited,
    avc$minimum_sru_default = 1,
    avc$sru_job_limits_apply_def = TRUE,
    avc$sru_limit_description =
          'Limits the number of system resource units (SRUs).',
    avc$sru_limit_name_default = avc$sru_limit_name,
    avc$sru_tot_lim_stops_login_def = TRUE,
    avc$sru_total_limit_applies_def = FALSE;

  VAR
    avc$sru_limit_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['CHANGE_SRU_LIMIT', 'CHASL'],
    avc$sru_limit_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['DISPLAY_SRU_LIMIT', 'DISSL'];

{ User field - Station Operation

  CONST
    avc$station_operation_default = FALSE,
    avc$station_operation_descr =
          'Allows the user to access the OPERATE_STATION utility.';

{ User field - System Administration

  CONST
    avc$system_admin_default = FALSE,
    avc$system_admin_description =
          'Allows the user to perform system administration functions.';

{ User field - System Displays

  CONST
    avc$system_displays_default = FALSE,
    avc$system_displays_description = 'Allows the user to display informat' CAT
          'ion relevant to system operation.';

{ User field - System Operation

  CONST
    avc$system_operation_default = FALSE,
    avc$system_operation_descr =
          'Allows the user to perform actions relevant to system operation.';

{ User field - Task Limit

  CONST
    avc$default_task_default = 20,
    avc$maximum_task_default = 256,
    avc$minimum_task_default = 3,
    avc$tas_tot_lim_stops_login_def = TRUE,
    avc$tas_total_limit_applies_def = FALSE,
    avc$task_job_limits_apply_def = TRUE,
    avc$task_limit_description = 'Limits the number of concurrent tasks.',
    avc$task_limit_name_default = avc$task_limit_name;

  VAR
    avc$task_limit_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['CHANGE_TASK_LIMIT', 'CHATL'],
    avc$task_limit_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['DISPLAY_TASK_LIMIT', 'DISTL'];


{ User field - Temporary File Space Limit

  CONST
    avc$tfs_limit_name_default = avc$tfs_limit_name,
    avc$tfs_job_limits_apply_def = TRUE,
    avc$tfs_total_limit_applies_def = FALSE,
    avc$tfs_tot_lim_stops_login_def = TRUE,
    avc$minimum_tfs_default = 0,
    avc$maximum_tfs_default = sfc$unlimited,
    avc$temp_file_space_limit_descr =
          'Limits the number of bytes of temporary file space.';

  VAR
    avc$temp_file_space_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['CHANGE_TEMP_FILE_SPACE_LIMIT', 'CHATFSL'],
    avc$temp_file_space_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['DISPLAY_TEMP_FILE_SPACE_LIMIT', 'DISTFSL'];

{ User field - Terminal Timeout Limit

  CONST
    avc$terminal_timeout_min_def = 1,
    avc$terminal_timeout_limit_def = sfc$unlimited,
    avc$terminal_timeout_max_def = sfc$unlimited,
    avc$terminal_timeout_limit_desc =
          'Limits the number of minutes an interactive job may be inactive' CAT
          ' before a timeout disconnect of the job will occur.';

  VAR
    avc$terminal_timeout_chg_cmd: [STATIC, READ,
          oss$job_paged_literal] array [1 .. 2] of ost$name :=
          ['CHANGE_TERMINAL_TIMEOUT_LIMIT', 'CHATTL'],
    avc$terminal_timeout_dis_cmd: [STATIC, READ,
          oss$job_paged_literal] array [1 .. 2] of ost$name :=
          ['DISPLAY_TERMINAL_TIMEOUT_LIMIT', 'DISTTL'];

{ User field - Timesharing

  CONST
    avc$timesharing_default = TRUE,
    avc$timesharing_description =
          'Allows the user to access the system in interactive mode.';

{ User field - User Epilog

  CONST
    avc$$sys_$sys_epilog_default = '$NULL',
    avc$$sys_user_epilog_default = '$NULL',
    avc$user_epilog_default = '$USER.EPILOG',
    avc$user_epilog_description = 'File containing the user epilog.';

  VAR
    avc$user_epilog_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['CHANGE_USER_EPILOG', 'CHAUE'],
    avc$user_epilog_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['DISPLAY_USER_EPILOG', 'DISUE'];

{ User field - User Prolog

  CONST
    avc$$sys_$sys_prolog_default = '$NULL',
    avc$$sys_user_prolog_default = '$NULL',
    avc$user_prolog_default = '$USER.PROLOG',
    avc$user_prolog_description = 'File containing the user prolog.';

  VAR
    avc$user_prolog_chg_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['CHANGE_USER_PROLOG', 'CHAUP'],
    avc$user_prolog_dis_cmd: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of ost$name := ['DISPLAY_USER_PROLOG', 'DISUP'];

{ Capability definition values

  CONST
    avc$$sys_$sys_capability_def = TRUE,
    avc$$sys_user_capability_def = FALSE,
    avc$cap_cmd_table_field_name = 'CAPABILITY                     ';

{ Validation file command table processor names.

  CONST
    avc$change_acct_proj_command = 'AVP$CHANGE_ACCT_PROJ_COMMAND   ',
    avc$change_accum_limit_command = 'AVP$CHANGE_ACCUM_LIMIT_COMMAND ',
    avc$change_capability_command = 'AVP$CHANGE_CAPABILITY_COMMAND  ',
    avc$change_date_time_command = 'AVP$CHANGE_DATE_TIME_COMMAND   ',
    avc$change_file_command = 'AVP$CHANGE_FILE_COMMAND        ',
    avc$change_integer_command = 'AVP$CHANGE_INTEGER_COMMAND     ',
    avc$change_job_class_command = 'AVP$CHANGE_JOB_CLASS_COMMAND   ',
    avc$change_labeled_names_cmd = 'AVP$CHANGE_LABELED_NAMES_CMD   ',
    avc$change_limit_command = 'AVP$CHANGE_LIMIT_COMMAND       ',
    avc$change_login_password_cmd = 'AVP$CHANGE_LOGIN_PASSWORD_CMD  ',
    avc$change_name_command = 'AVP$CHANGE_NAME_COMMAND        ',
    avc$change_real_command = 'AVP$CHANGE_REAL_COMMAND        ',
    avc$change_restriction_command = 'AVP$CHANGE_RESTRICTION_COMMAND ',
    avc$change_ring_privilege_cmd = 'AVP$CHANGE_RING_PRIVILEGE_CMD  ',
    avc$change_string_command = 'AVP$CHANGE_STRING_COMMAND      ',
    avc$display_acct_proj_command = 'AVP$DISPLAY_ACCT_PROJ_COMMAND  ',
    avc$display_field_description = 'AVP$DISPLAY_FIELD_DESCRIPTION  ',
    avc$display_field_names = 'AVP$DISPLAY_FIELD_NAMES        ',
    avc$display_field_value = 'AVP$DISPLAY_FIELD_VALUE        ',
    avc$end_subutility_command = 'AVP$END_SUBUTILITY_COMMAND     ';

{ Command table entry procedure names for standard commands.

  VAR
    avc$end_change_user_commands: [STATIC, READ,
          oss$job_paged_literal] array [1 .. 4] of ost$name :=
          ['END_CHANGE_USER', 'ENDCU', 'QUIT', 'QUI'],
    avc$end_change_acct_commands: [STATIC, READ,
          oss$job_paged_literal] array [1 .. 4] of ost$name :=
          ['END_CHANGE_ACCOUNT', 'ENDCA', 'QUIT', 'QUI'],
    avc$end_change_acct_mem_cmds: [STATIC, READ,
          oss$job_paged_literal] array [1 .. 4] of ost$name :=
          ['END_CHANGE_ACCOUNT_MEMBER', 'ENDCAM', 'QUIT', 'QUI'],
    avc$end_change_proj_commands: [STATIC, READ,
          oss$job_paged_literal] array [1 .. 4] of ost$name :=
          ['END_CHANGE_PROJECT', 'ENDCP', 'QUIT', 'QUI'],
    avc$end_change_proj_mem_cmds: [STATIC, READ,
          oss$job_paged_literal] array [1 .. 4] of ost$name :=
          ['END_CHANGE_PROJECT_MEMBER', 'ENDCPM', 'QUIT', 'QUI'],
    avc$display_field_descr_cmds: [STATIC, READ,
          oss$job_paged_literal] array [1 .. 3] of ost$name :=
          ['DISPLAY_FIELD_DESCRIPTION', 'DISPLAY_FIELD_DESCRIPTIONS', 'DISFD'],
    avc$display_field_names_cmds: [STATIC, READ,
          oss$job_paged_literal] array [1 .. 2] of ost$name :=
          ['DISPLAY_FIELD_NAMES', 'DISFN'],
    avc$change_capability_commands: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 3] of ost$name := ['CHANGE_CAPABILITY',
          'CHANGE_CAPABILITIES', 'CHAC'],
    avc$display_capability_commands: [STATIC, READ, oss$job_paged_literal]
          array [1 .. 3] of ost$name := ['DISPLAY_CAPABILITY',
          'DISPLAY_CAPABILITIES', 'DISC'];

*copyc avc$system_defined_limit_names
*copyc avc$unlimited_exp_interval
*copyc avc$no_expiration_date
*copyc avt$login_password
*copyc avt$name_list_size
*copyc sft$counter
*copyc ost$date_time
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc ost$name
*copyc pmt$time_increment
*DECK DECK=AVC$VALIDATION_FIELD_NAMES EXPAND=FALSE

?? FMT (FORMAT := OFF) ??
  CONST
    avc$account_administration      = 'ACCOUNT_ADMINISTRATION         ',
    avc$account_epilog              = 'ACCOUNT_EPILOG                 ',
    avc$account_prolog              = 'ACCOUNT_PROLOG                 ',
    avc$accounting_administration   = 'ACCOUNTING_ADMINISTRATION      ',
    avc$application_administration  = 'APPLICATION_ADMINISTRATION     ',
    avc$configuration_admin         = 'CONFIGURATION_ADMINISTRATION   ',
    avc$copy_output_files           = 'COPY_OUTPUT_FILES              ',
    avc$cpu_time_limit              = 'CPU_TIME_LIMIT                 ',
    avc$creation_account_project    = 'CREATION_ACCOUNT_PROJECT       ',
    avc$default_account_project     = 'DEFAULT_ACCOUNT_PROJECT        ',
    avc$dual_state_prompt           = 'DUAL_STATE_PROMPT              ',
    avc$engineering_administration  = 'ENGINEERING_ADMINISTRATION     ', {Deleted at 1.5.1}
    avc$engineering_operation       = 'ENGINEERING_OPERATION          ',
    avc$explicit_remote_file        = 'EXPLICIT_REMOTE_FILE           ',
    avc$family_administration       = 'FAMILY_ADMINISTRATION          ',
    avc$implicit_remote_file        = 'IMPLICIT_REMOTE_FILE           ',
    avc$interrupt_epilogs           = 'INTERRUPT_EPILOGS              ', {Site Defined}
    avc$interrupt_prologs           = 'INTERRUPT_PROLOGS              ', {Site Defined}
    avc$invalid_login_attempts      = 'INVALID_LOGIN_ATTEMPTS         ', {Site Defined}
    avc$job_class                   = 'JOB_CLASS                      ',
    avc$job_destination_usages      = 'JOB_DESTINATION_USAGES         ',
    avc$link_attribute_charge       = 'LINK_ATTRIBUTE_CHARGE          ',
    avc$link_attribute_family       = 'LINK_ATTRIBUTE_FAMILY          ',
    avc$link_attribute_password     = 'LINK_ATTRIBUTE_PASSWORD        ',
    avc$link_attribute_project      = 'LINK_ATTRIBUTE_PROJECT         ',
    avc$link_attribute_user         = 'LINK_ATTRIBUTE_USER            ',
    avc$login_password              = 'LOGIN_PASSWORD                 ',
    avc$magnetic_tape_limit         = 'MAGNETIC_TAPE_LIMIT            ',
    avc$mailve_administration       = 'MAILVE_ADMINISTRATION          ',
    avc$mailve_dist_list_limit      = 'MAILVE_DISTRIBUTION_LIST_LIMIT ',
    avc$mailve_mailbox_limit        = 'MAILVE_MAILBOX_LIMIT           ',
    avc$mailve_retention_limit      = 'MAILVE_RETENTION_LIMIT         ',
    avc$network_applic_management   = 'NETWORK_APPLICATION_MANAGEMENT ',
    avc$network_operation           = 'NETWORK_OPERATION              ',
    avc$nqs_queue_name              = 'NQS_QUEUE_NAME                 ', {Site Defined}
    avc$ntf_operation               = 'NTF_OPERATION                  ',
    avc$batch_io_station_list       = 'OPERABLE_STATIONS              ',
    avc$output_destination_usages   = 'OUTPUT_DESTINATION_USAGES      ',
    avc$permanent_file_space_limit  = 'PERMANENT_FILE_SPACE_LIMIT     ',
    avc$permit_level                = 'PERMIT_LEVEL                   ',
    avc$project_administration      = 'PROJECT_ADMINISTRATION         ',
    avc$project_epilog              = 'PROJECT_EPILOG                 ',
    avc$project_prolog              = 'PROJECT_PROLOG                 ',

{ READ_SYSTEM_MEMORY is a site defined capability field to control
{ access to system memory using the Analyze_system utility.

    avc$read_system_memory          = 'READ_SYSTEM_MEMORY             ', {Site Defined}
    avc$read_unlabeled_tapes        = 'READ_UNLABELLED_TAPES          ', {Deleted at 1.5.1}
    avc$remote_print_administration = 'REMOTE_PRINT_ADMINISTRATION    ', {Site Defined}
    avc$removable_media_access      = 'REMOVABLE_MEDIA_ACCESS         ',
    avc$removable_media_admin       = 'REMOVABLE_MEDIA_ADMINISTRATION ',
    avc$removable_media_operation   = 'REMOVABLE_MEDIA_OPERATION      ',
    avc$ring_privileges             = 'RING_PRIVILEGES                ',
    avc$scheduling_administration   = 'SCHEDULING_ADMINISTRATION      ',
    avc$scheduling_displays         = 'SCHEDULING_DISPLAYS            ', {Site Defined}
    avc$sru_limit                   = 'SRU_LIMIT                      ',
    avc$station_operation           = 'STATION_OPERATION              ',
    avc$submit_detached_jobs        = 'SUBMIT_DETACHED_JOBS           ', {Site Defined}
    avc$system_administration       = 'SYSTEM_ADMINISTRATION          ',
    avc$system_displays             = 'SYSTEM_DISPLAYS                ',
    avc$system_operation            = 'SYSTEM_OPERATION               ',
    avc$task_limit                  = 'TASK_LIMIT                     ',
    avc$temporary_file_space_limit  = 'TEMPORARY_FILE_SPACE_LIMIT     ',
    avc$terminal_timeout_limit      = 'TERMINAL_TIMEOUT_LIMIT         ',
    avc$timesharing                 = 'TIMESHARING                    ',
    avc$unix_uid                    = 'UNIX_UID                       ', {Site Defined}
    avc$unix_user_name              = 'UNIX_USER_NAME                 ', {Site Defined}
    avc$user_administration         = 'USER_ADMINISTRATION            ',
    avc$user_epilog                 = 'USER_EPILOG                    ',
    avc$user_prolog                 = 'USER_PROLOG                    ',
    avc$write_unlabeled_tapes       = 'WRITE_UNLABELLED_TAPES         '; {Deleted at 1.5.1}
?? FMT (FORMAT := ON) ??

*DECK DECK=AVC$VALIDATION_FILE_NAME EXPAND=FALSE

  CONST
    avc$validation_file_name = '$VALIDATIONS                   ';
*DECK DECK=AVC$VALIDATION_FILE_VERSION EXPAND=FALSE

  CONST
    avc$validation_file_version_131 = 'Version 1.0                    ',
    avc$validation_file_version_141 = 'Version 1.1                    ',
    avc$validation_file_version_142 = 'Version 1.2                    ',
    avc$validation_file_version_151 = 'Version 1.3                    ',
    avc$validation_file_version = avc$validation_file_version_151;

*DECK DECK=AVC$VALIDATION_LEVEL_CONST_NAME EXPAND=FALSE

  CONST
    avc$validation_level_const_name = '* VALIDATION_LEVEL *';






*DECK DECK=AVC$VALIDATION_LEVEL_NAMES EXPAND=FALSE

  CONST
    avc$user_level_name    = 'USER                           ',
    avc$account_level_name = 'ACCOUNT                        ',
    avc$project_level_name = 'PROJECT                        ';
*DECK DECK=AVC$VALIDATION_RECORD_NAMES EXPAND=FALSE

  CONST
    avc$user_record_name            = 'USER                           ',
    avc$account_record_name         = 'ACCOUNT                        ',
    avc$account_member_record_name  = 'ACCOUNT_MEMBER                 ',
    avc$project_record_name         = 'PROJECT                        ',
    avc$project_member_record_name  = 'PROJECT_MEMBER                 ';

*DECK DECK=AVE$ACCOUNT_PROJECT_MESSAGES EXPAND=FALSE

{ Common deck ave$account_project_messages.}

*copyc AVC$MIN_ECC

?? FMT (FORMAT := OFF) ??
  CONST
    avc$min_ecc_account_project = avc$min_ecc + 500;

  CONST
    ave$enter_account = avc$min_ecc_account_project + 0,
{I Enter Account name:}

    ave$user_requests_logout = avc$min_ecc_account_project + 2,
{I User requested logout during account/project entry.}

    ave$enter_project = avc$min_ecc_account_project + 7;
{I Enter Project name:}

?? FMT (FORMAT := ON) ??
*DECK DECK=AVE$ADMIN_VALIDATIONS_ERRORS EXPAND=FALSE
*copyc avc$min_ecc
?? NEWTITLE := '  ADMINISTER_VALIDATIONS Error Conditions', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    avc$min_ecc_admin_validations = avc$min_ecc + 1000,

    ave$changing_account = avc$min_ecc_admin_validations + 0,
    {I Changing account +P.}

    ave$changing_account_member = avc$min_ecc_admin_validations + 1,
    {I Changing account member +P in account +P.}

    ave$changing_project = avc$min_ecc_admin_validations + 2,
    {I Changing project +P in account +P}

    ave$changing_project_member = avc$min_ecc_admin_validations + 3,
    {I Changing project member +P in project +P of account +P.}

    ave$changing_user = avc$min_ecc_admin_validations + 4,
    {I Changing user +P.}

    ave$creating_account = avc$min_ecc_admin_validations + 5,
    {I Creating account +P.}

    ave$creating_account_member = avc$min_ecc_admin_validations + 6,
    {I Creating account member +P in account +P.}

    ave$creating_project = avc$min_ecc_admin_validations + 7,
    {I Creating project +P in account +P}

    ave$creating_project_member = avc$min_ecc_admin_validations + 8,
    {I Creating project member +P in project +P of account +P.}

    ave$creating_user = avc$min_ecc_admin_validations + 9,
    {I Creating user +P.}

    ave$cannot_change_capability = avc$min_ecc_admin_validations + 10,
    {W The user does not have enough authority to add or delete the following..
    { capabilities: +P.}

    ave$cannot_delete_all = avc$min_ecc_admin_validations + 15,
    {E Deletion of all +P is not allowed.}

    ave$cannot_supply_old_or_new_pw = avc$min_ecc_admin_validations + 20,
    {E The OLD_PASSWORD and NEW_PASSWORD parameters cannot be used if a value..
    { is specified for the ENCRYPTED_PASSWORD parameter.}

    ave$conflicting_operation = avc$min_ecc_admin_validations + 30,
    {E The requested operation conflicts with an active +P subutility within..
    { this ADMV session.}

    ave$name_not_allowed = avc$min_ecc_admin_validations + 53,
    {E The name +P may not be specified for parameter +P.}

    ave$not_allowed_from_subutility = avc$min_ecc_admin_validations + 55,
    {E +P cannot be used when an ADMINISTER_VALIDATIONS subutility is active.}

    ave$must_be_used_alone = avc$min_ecc_admin_validations + 60,
    {E The keyword value +P must be used alone for parameter +P.}

    ave$must_execute_usevf_cmd = avc$min_ecc_admin_validations + 65,
    {W System and family administrators must use the USE_VALIDATION_FILE..
    { command, specifying the correct password, in order to access the..
    { validation file for this family.}

    ave$must_specify_new_password = avc$min_ecc_admin_validations + 70,
    {E A value must be specified for the NEW_PASSWORD parameter if a value is..
    { specified for the OLD_PASSWORD parameter.}

    ave$no_accounts = avc$min_ecc_admin_validations + 71,
    {I There are no account validations.}

    ave$no_account_members = avc$min_ecc_admin_validations + 72,
    {I There are no account members for account +P.}

    ave$no_projects = avc$min_ecc_admin_validations + 73,
    {I There are no projects for account +P.}

    ave$no_project_members = avc$min_ecc_admin_validations + 74,
    {I There are no project members for project +P in account +P.}

    ave$no_validation_file_open = avc$min_ecc_admin_validations + 75,
    {E A validation file must be opened by executing the USE_VALIDATION_FILE..
    { command.}

    ave$unknown_capability = avc$min_ecc_admin_validations + 85,
    {E +P is not a defined capability.}

    ave$unknown_display_option = avc$min_ecc_admin_validations + 90,
    {E +P is not a recognized display option.}

    avc$max_ecc_admin_validations = avc$min_ecc_admin_validations + 99;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=AVE$CONDITION_CODES EXPAND=FALSE

?? NEWTITLE := 'ave$condition_codes', EJECT ??
*copyc avc$min_ecc
*copyc ave$account_project_messages
*copyc ave$admin_validations_errors
*copyc ave$family_errors
*copyc ave$initialize_errors           "AV 700 .. 709
*copyc ave$template_file_damaged       "AV 710
*copyc ave$template_file_mgr_errors
*copyc ave$validation_interface_errors

*copyc ave$unknown_security_option     "AV 200
*copyc ave$duplicate_setso_command     "AV 201
*copyc ave$console_operation_only      "AV 202
?? OLDTITLE ??
*DECK DECK=AVE$CONSOLE_OPERATION_ONLY EXPAND=FALSE

?? FMT (FORMAT := OFF) ??
  CONST
    ave$console_operation_only = avc$min_ecc + 202;
    {E +P1 may only be activated in the system job.}

?? FMT (FORMAT := ON) ??
*copyc avc$min_ecc
*DECK DECK=AVE$DUPLICATE_SETSO_COMMAND EXPAND=FALSE

?? FMT (FORMAT := OFF) ??
  CONST
    ave$duplicate_setso_command = avc$min_ecc + 201;
    {E SET_SECURITY_OPTION has already been issued for +p.}

?? FMT (FORMAT := ON) ??
*copyc avc$min_ecc
*DECK DECK=AVE$FAMILY_ERRORS EXPAND=FALSE

*copyc AVC$MIN_ECC

?? FMT (FORMAT := OFF) ??
  CONST
    avc$min_ecc_family = avc$min_ecc + 300;

  CONST

    ave$catalog_already_exists = avc$min_ecc_family + 11,
{W The master catalog for user +P in family +P already exists.}

    ave$user_validation_info_exists = avc$min_ecc_family + 12,
{W Validation information for user +P in family +P already exists.}

    ave$cannot_change_family = avc$min_ecc_family + 13;
{E The name of family +P cannot be changed.}

?? FMT (FORMAT := OFF) ??
*DECK DECK=AVE$INITIALIZE_ERRORS EXPAND=FALSE

*copyc avc$min_ecc

  CONST
    avc$min_ecc_initialize = avc$min_ecc + 700;

?? FMT (FORMAT := OFF) ??
  CONST
    ave$nil_segment = avc$min_ecc_initialize + 1,
{E Segment pointer specified is NIL. (+P request) }

    ave$segment_too_small = avc$min_ecc_initialize + 2,
{E Specified segment to small for Data Base Manager. (+P request) }

    ave$unknown_val_file_version = avc$min_ecc_initialize + 3,
{E Version +P of the $FAMILY_USERS file is unknown.}

    ave$open_val_file_error = avc$min_ecc_initialize + 4,
{W An error occurred while opening the validation file for family +P.}

    ave$access_user_rec_error = avc$min_ecc_initialize + 5,
{W An error occurred while reading a user record for family +P.}

    ave$cannot_create_system_user = avc$min_ecc_initialize + 6,
{W An error occurred while creating user $SYSTEM for family +P.}

    ave$cannot_convert_val_file = avc$min_ecc_initialize + 7,
{W An error occurred while converting the validation file for family +P.}

    ave$cannot_update_val_version = avc$min_ecc_initialize + 8,
{W An error occurred while updating the validation file version for family +P.}

    ave$recreating_system_family = avc$min_ecc_initialize + 9;
{W The validation file for family +P is being recreated.}
*DECK DECK=AVE$SCC_RANGE EXPAND=FALSE
*copyc avc$min_ecc

  CONST
    avc$min_scc = avc$min_ecc,
    avc$max_scc = avc$min_scc + 9999;

*DECK DECK=AVE$TEMPLATE_FILE_DAMAGED EXPAND=FALSE
*copyc avc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    ave$template_file_damaged       = avc$min_ecc + 710;
    {F The validation template file for the family +P is damaged and must be
{ reloaded or recreated.
?? FMT (FORMAT := ON) ??
*DECK DECK=AVE$TEMPLATE_FILE_MGR_ERRORS EXPAND=FALSE
*copyc avc$min_ecc
?? NEWTITLE := '  Template File Manager Error Conditions', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    avc$min_ecc_template_file_mgr = avc$min_ecc + 0,

    ave$account_must_be_specified = avc$min_ecc_template_file_mgr + 1,
    {E An account name must be specified when a project name is specified.}

    ave$conflicting_lock = avc$min_ecc_template_file_mgr + 3,
    {E +P was called when the file was locked for read access.}

    ave$corrupted_index_record = avc$min_ecc_template_file_mgr + 5,
    {E An internal error was detected in the index records for the template..
    { file.}

    ave$corrupted_sequence = avc$min_ecc_template_file_mgr + 7,
    {E An internal error prevented +P from retrieving the value of the..
    { variable +P from the sequence +P.}

    ave$date_not_allowed = avc$min_ecc_template_file_mgr + 9,
    {E Only a time may be specified.}

    ave$date_required = avc$min_ecc_template_file_mgr + 11,
    {E A date must be specified.}

    ave$date_time_range_not_allowed = avc$min_ecc_template_file_mgr + 13,
    {E A date time range is not allowed.}

    ave$date_time_range_required = avc$min_ecc_template_file_mgr + 15,
    {E A date time range is required.}

    ave$desc_record_already_exists = avc$min_ecc_template_file_mgr + 17,
    {E A description record with the name +P already exists.}

    ave$desc_record_directory_full = avc$min_ecc_template_file_mgr + 19,
    {E The description record directory is full.}

    ave$end_of_template_file = avc$min_ecc_template_file_mgr + 21,
    {E The end of the file was encountered.}

    ave$field_already_exists = avc$min_ecc_template_file_mgr + 23,
    {E A field with the name +P already exists in description record +P.}

    ave$field_directory_full = avc$min_ecc_template_file_mgr + 25,
    {E The field directory is full for description record +P.}

    ave$field_was_deleted = avc$min_ecc_template_file_mgr + 27,
    {E A field with the name +P was deleted at +P.}

    ave$incorrect_depth = avc$min_ecc_template_file_mgr + 29,
    {E The value specified for the DEPTH parameter (+P) is greater..
    {  than the index depth of the file (+P).}

    ave$incorrect_exp_interval = avc$min_ecc_template_file_mgr + 31,
    {E The password expiration interval must be less than or equal to the..
    { maximum expiration interval.}

    ave$incorrect_expiration_date = avc$min_ecc_template_file_mgr + 33,
    {E The password expiration date is beyond the maximum expiration interval.}

    ave$incorrect_file_reference = avc$min_ecc_template_file_mgr + 35,
    {E "+P" is not a correct file reference.}

    ave$incorrect_job_limits = avc$min_ecc_template_file_mgr + 37,
    {E The job warning limit must be less than or equal to the job maximum..
    { limit.}

    ave$incorrect_ring_privileges = avc$min_ecc_template_file_mgr + 39,
    {E The minimum ring must be less than or equal to the nominal ring.}

    ave$kind_not_implemented = avc$min_ecc_template_file_mgr + 41,
    {E +P fields have not been implemented yet.}

    ave$kinds_do_not_match = avc$min_ecc_template_file_mgr + 43,
    {E The +P kind does not match the +P kind.}

    ave$name_list_too_small = avc$min_ecc_template_file_mgr + 45,
    {E The +P parameter passed on the call to +P is too small.}

    ave$no_work_area = avc$min_ecc_template_file_mgr + 47,
    {E The WORK_AREA parameter passed on the call to +P is NIL.}

    ave$not_a_deleted_field = avc$min_ecc_template_file_mgr + 49,
    {E +P cannot be restored because it is not a deleted field.}

    ave$not_a_template_file = avc$min_ecc_template_file_mgr + 51,
    {E +F is not a template file.}

    ave$not_validated_for_default = avc$min_ecc_template_file_mgr + 53,
    {E The default +P job class must appear in the list of valid job classes.}

    ave$out_of_range = avc$min_ecc_template_file_mgr + 55,
    {E +P is not in the range +P to +P.}

    ave$record_already_exists = avc$min_ecc_template_file_mgr + 57,
    {E A record with the key +P already exists.}

    ave$record_too_large = avc$min_ecc_template_file_mgr + 59,
    {E An attempt was made to construct a record that is too large.}

    ave$string_too_long = avc$min_ecc_template_file_mgr + 61,
    {E The string length must be less than or equal to +P.}

    ave$string_too_short = avc$min_ecc_template_file_mgr + 63,
    {E The string length must be greater than or equal to +P.}

    ave$template_file_full = avc$min_ecc_template_file_mgr + 65,
    {E The template file is full.}

    ave$time_not_allowed = avc$min_ecc_template_file_mgr + 67,
    {E Only a date may be specified.}

    ave$time_required = avc$min_ecc_template_file_mgr + 69,
    {E A time must be specified.}

    ave$too_few_names = avc$min_ecc_template_file_mgr + 71,
    {E At least +P names must be specified.}

    ave$too_many_names = avc$min_ecc_template_file_mgr + 73,
    {E Only +P names may be specified.}

    ave$unexpected_nil_pointer = avc$min_ecc_template_file_mgr + 75,
    {E The +P pointer in the value for field +P is NIL.}

    ave$unknown_description_record = avc$min_ecc_template_file_mgr + 77,
    {E A description record with the name +P could not be found.}

    ave$unknown_field = avc$min_ecc_template_file_mgr + 79,
    {E A field with the name +P could not be found.}

    ave$unknown_field_kind = avc$min_ecc_template_file_mgr + 81,
    {E An unknown field kind was detected by procedure +P.}

    ave$unknown_record = avc$min_ecc_template_file_mgr + 83,
    {E A record with the key +P could not be found.}

    ave$update_lock_required = avc$min_ecc_template_file_mgr + 85,
    {E The file must be locked for update access before calling +P.}

    ave$utility_info_too_small = avc$min_ecc_template_file_mgr + 87,
    {E The utility information sequence passed on the call to +P is too small.}

    ave$value_is_not_a_name = avc$min_ecc_template_file_mgr + 89,
    {E +P is not a name.}

    ave$work_area_full = avc$min_ecc_template_file_mgr + 91,
    {E The work area provided on the call to +P is full.}

    avc$max_ecc_template_file_mgr = avc$min_ecc+99;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??

*DECK DECK=AVE$UNKNOWN_SECURITY_OPTION EXPAND=FALSE

?? FMT (FORMAT := OFF) ??
  CONST
    ave$unknown_security_option = avc$min_ecc + 200;
    {E +P1 is not a valid security option.}

?? FMT (FORMAT := ON) ??
*copyc avc$min_ecc
*DECK DECK=AVE$VALIDATION_INTERFACE_ERRORS EXPAND=FALSE

*copyc avc$min_ecc

  CONST
    avc$min_ecc_interfaces = avc$min_ecc + 100;

?? FMT (FORMAT := OFF) ??

  CONST
    ave$account_already_exists = avc$min_ecc_interfaces + 1,
{E The account +P already exists. }

    ave$account_does_not_exist = avc$min_ecc_interfaces + 3,
{E The account +P does not exist. }

    ave$account_does_not_exist_warn = avc$min_ecc_interfaces + 4,
{W The account +P does not exist. }

    ave$account_info_not_found = avc$min_ecc_interfaces + 6,
{E The login validation information for the current executing account is..
{ unavailable. }

    ave$acct_member_already_exists = avc$min_ecc_interfaces + 9,
{E The user +P is already a member of account +P. }

    ave$acct_member_does_not_exist = avc$min_ecc_interfaces + 12,
{E The user +P is not a member of account +P. }

    ave$acc_mem_does_not_exist_warn = avc$min_ecc_interfaces + 13,
{W The user +P is not a member of account +P. }

    ave$acct_member_info_not_found = avc$min_ecc_interfaces + 15,
{E The login validation information for the current executing account member..
{ is unavailable. }

    ave$bad_job_class = avc$min_ecc_interfaces + 18,
{E User not valid for job class +P. }

    ave$bad_ring = avc$min_ecc_interfaces + 21,
{E User not valid for access to ring +P. }

    ave$bad_user_specified_job_max = avc$min_ecc_interfaces + 24,
{E User specified a +P job maximum limit that is greater than the user's..
{ validation. }

    ave$bad_user_validation_info = avc$min_ecc_interfaces + 27,
{E Incorrect user validation.}

    ave$call_invalid_too_many_tasks = avc$min_ecc_interfaces + 28,
{E Activate or Deactivate administrator can not be called when more than 1..
{ task is active for the job. }

    ave$can_not_delete_current = avc$min_ecc_interfaces + 30,
{E Deletion of the currently executing +P is not allowed. }

    ave$cannot_add_name_to_all = avc$min_ecc_interfaces + 31,
{E A specific entry cannot be added to a list which currently contains..
{ the value ALL. }

    ave$cannot_add_all_to_name = avc$min_ecc_interfaces + 32,
{E ALL cannot be added to a list which currently contains a specific value.}

    ave$cannot_delete_name_from_all = avc$min_ecc_interfaces + 33,
{E A specific entry cannot be deleted from a list which currently contains..
{ the value ALL. }

    ave$capability_not_supported = avc$min_ecc_interfaces + 34,
{E +P is not a capability or is not supported for this command at this time. }

   ave$can_not_set_new_without_old = avc$min_ecc_interfaces + 36,
{E Only a system administrator may set a new password without supplying the..
{ current password.}

   ave$call_not_valid_from_sys_job = avc$min_ecc_interfaces + 37,
{E Activate or Deactivate administrator not be executed from within the..
{ system job.}

    ave$cmd_already_in_cmd_table = avc$min_ecc_interfaces + 38,
{E The command +P already exists for field +p. }

    ave$encrypted_pw_not_allowed = avc$min_ecc_interfaces + 39,
{E An encrypted password value may only be specified on a source run. }

    ave$delete_files_not_allowed = avc$min_ecc_interfaces + 40,
{E Deletion of files is not allowed when deleting a user from a local..
{ validation file.}

    ave$incorrect_cmd_table_size = avc$min_ecc_interfaces + 42,
{E The command table array supplied (+P entries) is not big enough to..
{ receive the command table (+P entries).}

    ave$incorrect_kind = avc$min_ecc_interfaces + 45,
{E Field +P is not a +P type field.}

    ave$insufficient_authority = avc$min_ecc_interfaces + 48,
{E User does not have the required authority to perform this request. +P }

    ave$invalid_password_from_hook = avc$min_ecc_interfaces + 51,
{E The password returned by AVP$PROCESS_PASSWORD_ATTRIBUTES can not be a null..
{ name. }

    ave$master_catalog_exists = avc$min_ecc_interfaces + 53,
{W A master catalog for +P already exists. }

    ave$member_does_not_exist = avc$min_ecc_interfaces + 54,
{E The user +P is neither a member of account +P nor a member of project +P..
{ within account +P. }

    ave$member_does_not_exist_warn = avc$min_ecc_interfaces + 55,
{W The user +P is neither a member of account +P nor a member of project +P..
{ within account +P. }

    ave$missing_required_capability = avc$min_ecc_interfaces + 57,
{E User does not have required capability +P. }

    ave$missing_val_record_info = avc$min_ecc_interfaces + 60,
{E Unable to find validation record information for +P. }

    ave$must_specify_password = avc$min_ecc_interfaces + 63,
{E System and/or family administrators must specify a password to access this..
{ validation file. }

    ave$new_file_same_as_old_file = avc$min_ecc_interfaces + 64,
{E The new_validation_file cannot be the same as the old_validation_file.}

    ave$no_password_on_file = avc$min_ecc_interfaces + 66,
{E No password exists. }

    ave$not_allowed_on_client = avc$min_ecc_interfaces + 67,
{E +P is not allowed on the client mainframe. }

    ave$old_password_not_valid = avc$min_ecc_interfaces + 69,
{E The password specified does not match the current password for this +P.}

    ave$proj_member_already_exists = avc$min_ecc_interfaces + 72,
{E The user +P is already a member of project +P within account +P. }

    ave$proj_member_does_not_exist = avc$min_ecc_interfaces + 75,
{E The user +P is not a member of project +P within account +P. }

    ave$proj_member_info_not_found = avc$min_ecc_interfaces + 78,
{E The login validation information for the current executing project member..
{ is unavailable. }

    ave$project_already_exists = avc$min_ecc_interfaces + 80,
{E The project +P within account +P already exists. }

    ave$project_does_not_exist = avc$min_ecc_interfaces + 82,
{E The project +P within account +P does not exist. }

    ave$project_does_not_exist_warn = avc$min_ecc_interfaces + 83,
{W The project +P within account +P does not exist. }

    ave$project_info_not_found = avc$min_ecc_interfaces + 84,
{E The login validation information for the current executing project is..
{ unavailable. }

    ave$reserved_name_not_valid = avc$min_ecc_interfaces + 87,
{E The reserved name +P is not a valid name for creation of a +P.}

    ave$unable_to_find_field_name = avc$min_ecc_interfaces + 93,
{E Unable to find field name for command +P. }

    ave$unknown_validation_record = avc$min_ecc_interfaces + 94,
{E An unknown validation record was specified on a request for validation..
{ information.}

    ave$user_already_exists = avc$min_ecc_interfaces + 95,
{E The user +P already exists. }

    ave$user_does_not_exist = avc$min_ecc_interfaces + 97,
{E The user +P does not exist. }

    ave$user_info_not_found = avc$min_ecc_interfaces + 99;
{E The login validation information for the current executing user is..
{ unavailable. }

?? FMT (FORMAT := OFF) ??

*DECK DECK=AVH$BEGIN_ACCOUNT EXPAND=FALSE

{
{   The purpose of this request is to begin the period of accountability
{ for a job.  Those System Resource Unit statistics required for this
{ established.  Also, the family_name, user_name, account name, project_name,
{ user_supplied_job_name and the job_class name are registered in the account
{ logs.  Both of the account logs which are the $JOB_ACCOUNT_LOG and the
{ $ACCOUNT_LOG.
{
{        AVP$BEGIN_ACCOUNT (FAMILY_NAME, USER_NAME, ACCOUNT_NAME, PROJECT_NAME,
{              USER_SUPPLIED_JOB_NAME, JOB_CLASS, STATUS)
{
{ FAMILY_NAME: (input) This parameter specifies the name of the family
{        associated with this period of accountability.
{
{ USER_NAME:  (input) This parameter specifies the name of the user to be
{        associated with this period of accountability.
{
{ ACCOUNT_NAME: (input) This parameter specifies the name of the account
{        to be associated with this period of accountability.
{
{ PROJECT_NAME: (input) This parameter specifies the name of the project
{        to be associated with this period of accountability.
{
{ USER_SUPPLIED_JOB_NAME: (input) This parameter specifies the user supplied job
{        name to be associated with this period of accountability.
{
{ JOB_CLASS:  (input) This parameter specifies the name of the job_class to
{        be associated with this period of accountability.
{
{ STATUS: (output) This parameter specifies the request status.
{      IDENTIFIER: avc$validation_id
*DECK DECK=AVH$CALCULATE_APPLICATION_SRUS EXPAND=FALSE
{    The purpose of this request is to calculate the SRUs used by an
{ application for which application accounting is done.  The resulting
{ accumulated_srus returned by this request is used as the SRU counter for the
{ AV10 statistic.
{
{       AVP$CALCULATE_APPLICATION_SRUS (CPU_TIME, PAGING_STATISTICS,
{             ACCUMULATED_SRUS, STATUS);
{
{ CPU_TIME: (input)  This is the amount of CPU time used by the application.
{
{ PAGING_STATISTICS: (input)  This is the paging statistics for the application.
{       The paging statistics for working_set_max_used and
{       incremental_max_ws may be misleading since they are job wide, versus
{       application wide.  They have been included for completeness.
{
{ ACCUMULATED_SRUS: (output)  This is the amount of SRUs to be charged in the
{       AV10 statistic.  This does NOT represent the new SRU accumulator value
{       as with avp$calculate_srus.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{           none.
*DECK DECK=AVH$CALCULATE_SRUS EXPAND=FALSE
{
{   This procedure calculates a new total for the SRU accumulator.
{
{      AVP$CALCULATE_SRUS (JOB_STATISTICS, SRU_LIMIT, ACCUMULATED_SRUS,
{        CALCULATION_INTERVAL, STATUS);
{
{ JOB_STATISTICS: (input) Record containing CP time and page fault information
{        about the job.
{
{ SRU_LIMIT: (input) A copy of the SRU limit information
{
{ ACCUMULATED_SRUS: (output) New value for the SRU accumulator (in micro SRUs).
{
{ CALCULATION_INTERVAL: (output) Maximum number of CP seconds that can elapse
{        before CP time and SRU are updated again.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: None.
*DECK DECK=AVH$CAPABILITY_ACTIVE EXPAND=FALSE
{
{  PURPOSE:
{
{    The purpose of this request is to determine if a specific
{  capability is currently active.
{
{       AVP$CAPABILITY_ACTIVE (CAPABILITY): BOOLEAN
{
{ CAPABILITY: (input) This parameter specifies the capability
{       that is to be checked.
{
{ AVP$CAPABILITY_ACTIVE:  (output) This parameter specifies
{       whether or not the specified capability is active.
{
*DECK DECK=AVH$CHANGE_DESC_UTILITY_INFO EXPAND=FALSE
{
{    Changes the utility information for a description record.
{
{       AVP$CHANGE_DESC_UTILITY_INFO (DESCRIPTION_RECORD_NAME,
{             UTILITY_INFORMATION, FILE_INFORMATION, STATUS);
{
{ DESCRIPTION_RECORD_NAME: (input) Name of the description record.
{
{ UTILITY_INFORMATION: (input) Pointer to the new utility information for the
{       description record.
{
{ FILE_INFORMATION: (input, output) Record being used by the template file
{       manager to hold information about the template file.
{
{ STATUS:  (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$conflicting_lock
{             ave$template_file_full
{             ave$unknown_description_record
{
*DECK DECK=AVH$CHANGE_FAMILY_INTERFACE EXPAND=FALSE
{
{    The purpose of this procedure is to change the name of a family.
{
{       AVP$CHANGE_FAMILY_INTERFACE (FAMILY_NAME, NEW_FAMILY_NAME, STATUS)
{
{ FAMILY_NAME: (input)  This parameter specifies the name of the family to be
{       changed from.
{
{ NEW_FAMILY_NAME: (input)  This parameter specifies the name that the family
{       is to be changed to.
{
{ STATUS: (output) This parameter specifies the request status.
{
{      CONDITION: ave$insufficient_authority
{
*DECK DECK=AVH$CHANGE_FIELD EXPAND=FALSE
{
{    This interface is used to change an existing field in a template file.
{
{       AVP$CHANGE_FIELD (FIELD_NAME, DESCRIPTION_RECORD_NAME,
{             TYPE_SPECIFICATION, DEFAULT_VALUE, DESCRIPTIVE_TEXT,
{              UTILITY_INFORMATION, FILE_INFORMATION, STATUS);
{
{ FIELD_NAME: (input) Name of the field to be changed.
{
{ DESCRIPTION_RECORD_NAME: (input) Name of the description record containing
{       field to be changed.
{
{ TYPE_SPECIFICATION: (input) Type specification for the field.
{
{ DEFAULT_VALUE: (input) Default value for the field.
{
{ DESCRIPTIVE_TEXT: (input) Descriptive text for the field.
{
{ UTILITY_INFORMATION: (input) Pointer to utility information for the field.
{
{ FILE_INFORMATION: (input, output) Record used by the template file manager to
{       hold information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{              ave$conflicting_lock
{              ave$file_full
{              ave$record_too_large
{              ave$unknown_description_record
{              ave$unknown_field
{
*DECK DECK=AVH$CHANGE_FIELD_NAME EXPAND=FALSE
{
{    This interface is used to change the name of an existing field in a
{ template file.
{
{       AVP$CHANGE_FIELD_NAME (FIELD_NAME, DESCRIPTION_RECORD_NAME,
{             NEW_FIELD_NAME, FILE_INFORMATION, STATUS);
{
{ FIELD_NAME: (input) Name of the field to be changed.
{
{ DESCRIPTION_RECORD_NAME: (input) Name of the description record containing
{       field to be changed.
{
{ NEW_FIELD_NAME: (input) New name for the field.
{
{ FILE_INFORMATION: (input, output) Record used by the template file manager to
{       hold information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{              ave$conflicting_lock
{              ave$field_already_exists
{              ave$field_was_deleted
{              ave$unknown_description_record
{              ave$unknown_field
{
*DECK DECK=AVH$CHANGE_FILE_UTILITY_INFO EXPAND=FALSE
{
{    This interface is used to update the utility information for a template
{ file.
{
{       AVP$CHANGE_FILE_UTILITY_INFO (UTILITY_INFORMATION, FILE_INFORMATION,
{             STATUS)
{
{ UTILITY_INFORMATION: (input) Pointer to the new utility information.
{
{ FILE_INFORMATION: (input, output) The record used by the template file manager
{       to hold information about the file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$conflicting_lock
{             ave$template_file_full
{
*DECK DECK=AVH$CHANGE_PASSWORD EXPAND=FALSE

{
{   The purpose of this request is to change the current password of the
{ caller.  If the current password does not equal the old_password specified
{ in the request, then an error condition is returned and the password is
{ not changed.  Otherwise, the current password is changed to the new_password
{ specified in the request.
{
{        AVP$CHANGE_PASSWORD (OLD_PASSWORD, NEW_PASSWORD,
{              UPDATE_BATCH_JOB_PASSWORDS, STATUS)
{
{ OLD_PASSWORD: (input) This parameter specifies what the caller believes
{        is the current password for the user name under which the caller is
{        executing.
{
{ NEW_PASSWORD: (input) This parameter specifies the new password to be
{        associated with the user name under which the caller is executing.
{
{ UPDATE_BATCH_JOB_PASSWORDS: (input) This parameter specifies whether to
{        change the password in queued batch jobs belonging to the user.
{
{ STATUS: (output) This parameter specifies the request status.
{      CONDITION: ave$old_password_incorrect
{      IDENTIFIER: avc$validation_id
{
*DECK DECK=AVH$CLOSE_TEMPLATE_FILE EXPAND=FALSE
{
{    This interface is used to close a template file after processing.
{
{       AVP$CLOSE_TEMPLATE_FILE (FILE_INFORMATION, STATUS)
{
{ FILE_INFORMATION: (input, output) The record used by the template file manager
{       to hold information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             None
{
*DECK DECK=AVH$CREATE_DATA_RECORD EXPAND=FALSE
{
{    Create a new data record.
{
{       AVP$CREATE_DATA_RECORD (KEY, DESCRIPTION_RECORD_NAME, FIELD_VALUE_LIST
{             FILE_INFORMATION, STATUS)
{
{ KEY: (input) Key for the record being created.
{
{ DESCRIPTION_RECORD_NAME: (input) Name of the field description record that
{       contains the field definitions for the data record.
{
{ FIELD_VALUE_LIST: (input) Pointer to the field value list for the record
{       being created.  Values for fields that are to be defaulted do not need
{       to be specified.  A NIL value for this parameter implies that all of
{       the fields for this record are defaulted.
{
{ FILE_INFORMATION: (input, output) Record being used by the template file
{       manager to hold information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$conflicting_lock
{             ave$record_already_exists
{             ave$record_too_large
{             ave$unknown_description_record
{             ave$unknown_field
{             ave$template_file_full
{
*DECK DECK=AVH$CREATE_DESCRIPTION_RECORD EXPAND=FALSE
{
{    Create a new field description record in a template file.
{
{       AVP$CREATE_DESCRIPTION_RECORD (DESCRIPTION_RECORD_NAME,
{             UTILITY_INFORMATION, FILE_INFORMATION, STATUS)
{
{ DESCRIPTION_RECORD_NAME: (input) Name of the description record to be created.
{
{ UTILITY_INFORMATION: (input) Pointer to utility information for the
{       description record.
{
{ FILE_INFORMATION: (input, output) Record used by the template file manager to
{       hold information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$desc_record_already_exists
{             ave$desc_record_directory_full
{             ave$template_file_full
{
*DECK DECK=AVH$CREATE_FAMILY_INTERFACE EXPAND=FALSE
{
{    The purpose of this procedure is to create a new family.
{
{       AVP$CREATE_FAMILY_INTERFACE (FAMILY_NAME, FAMILY_ADMINISTRATOR,
{             ACCOUNT_NAME, PROJECT_NAME, PASSWORD, PERMANENT_FILE_SET, STATUS)
{
{ FAMILY_NAME: (input)  This parameter specifies the name of the family to be
{       changed.
{
{ FAMILY_ADMINISTRATOR: (input)  This parameter specifies the family
{       administrator user name for the family.
{
{ ACCOUNT_NAME: (input)  This parameter specifies the account name to be
{       assigned to the specified family administrator.
{
{ PROJECT_NAME: (input)  This parameter specifies the project name to be
{       assigned to the specified family administrator.
{
{ PASSWORD:  (Input) This parameter specifies the password to be assigned to
{       the specified family administrator.
{
{ PERMANENT_FILE_SET: (input)  This parameter specifies the set of permanent
{       file devices on which the family will reside.  Specifying a null name
{       will cause the system default set to be used.
{
{ STATUS: (output) This parameter specifies the request status.
{
{      CONDITION: ave$insufficient_authority

*DECK DECK=AVH$CREATE_FIELD EXPAND=FALSE
{
{    Creates a new field in a template file.
{
{       AVP$CREATE_FIELD (FIELD_NAME, DESCRIPTION_RECORD_NAME,
{             TYPE_SPECIFICATION, DEFAULT_VALUE, DESCRIPTIVE_TEXT,
{             UTILITY_INFORMATION, FILE_INFORMATION, STATUS)
{
{ FIELD_NAME: (input) Name of the template field to be created.
{
{ DESCRIPTION_RECORD_NAME: (input) Name of the description record where the
{       field should be created.
{
{ TYPE_SPECIFICATION: (input) Type specification for the field being created.
{
{ DEFAULT_VALUE: (input) Default value for the field being created.
{
{ DESCRIPTIIVE_TEXT: (input) Descriptive text for the field.
{
{ UTILITY_INFO: (input) Pointer to the utility information for the field.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$field_already_exists
{             ave$field_directory_full
{             ave$unknown_description_record
{             ave$template_file_full
{
*DECK DECK=AVH$DELETE_DATA_RECORD EXPAND=FALSE
{
{    Delete a data record.
{
{       AVP$DELETE_DATA_RECORD (KEY, FILE_INFORMATION, STATUS)
{
{ KEY: (input) Key for the record being deleted.
{
{ FILE_INFORMATION: (input, output) Record being used by the template file
{       manager to hold information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$unknown_record
{
*DECK DECK=AVH$DELETE_DATA_RECORDS EXPAND=FALSE
{
{    Delete all of the data records between (and including) the specified keys
{ that have the specified description record name.
{
{       AVP$DELETE_DATA_RECORDS (STARTING_KEY, ENDING_KEY,
{             DESCRIPTION_RECORD_NAME, FILE_INFORMATION, STATUS);
{
{ STARTING_KEY: (input) First key to be deleted.  The key need not exist.
{
{ ENDING_KEY: (input) Last key to be deleted. The key need not exist.
{
{ DESCRIPTION_RECORD_NAME: (input) Name of the description record for the
{       records to be deleted.
{
{ FILE_INFORMATION: (input, output) Record being used by the template file
{       manager to hold information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             none
{
*DECK DECK=AVH$DELETE_FIELD EXPAND=FALSE
{
{    Delete an existing field.
{
{       AVP$DELETE_FIELD (FIELD_NAME, DESCRIPTION_RECORD_NAME,
{             FILE_INFORMATION, STATUS)
{
{ FIELD_NAME: (input) Name of the field to be deleted.
{
{ DESCRIPTION_RECORD_NAME: (input) Name of the description record containing
{       the field to be deleted.
{
{ FILE_INFORMATION: (input, output) Record used by the template file manager
{       to hold information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$field_was_deleted
{             ave$unknown_description_record
{             ave$unknown_field
{
*DECK DECK=AVH$DETERMINE_IF_KEY_EXISTS EXPAND=FALSE
{
{    Determines if the specified kety exists in the template file.
{
{       AVP$DETERMINE_IF_KEY_EXISTS (KEY, KEY_EXISTS, FILE_INFORMATION, STATUS)
{
{ KEY: (input) Key to be checked.
{
{ KEY_EXISTS: (output) Boolean value that specifies whether the specified key
{       was found in the template file.
{
{ FILE_INFORMATION: (output) Record used by the template file manager to hold
{       information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             None
{
*DECK DECK=AVH$EMIT_PERMANENT_FILE_STATS EXPAND=FALSE
{   This command collects permanent file billing information and emits it to
{   the binary logs.  It also produces a file of fixed format text records that
{   contain the same information emitted to the logs.
{
{   The command format is:
{
{        EMIT_PERMANENT_FILE_STATS (EMIPFS)
{          FAMILY_NAME = list of name or key all
{          UPON = file
{          STATUS = status variable
{
{      FAMILY_NAME:  This parameter specifies the list of names of the families
{        to process.  The default is ALL.
{
{      UPON: Specifies the name of the file to receive the fixed format
{        text records.  The default is $NULL.
{
{      STATUS: (output) This parameter receives the termination status.
{
{   EMIPFS can be executed by the system administrator for any family on
{   the system.
*DECK DECK=AVH$END_ACCOUNT EXPAND=FALSE

{
{   The purpose of this request is to end a period of accountability for the
{ current job.  The total number of System Resource Units expended during
{ this period is computed and recorded in the Account Log.
{
{     AVP$END_ACCOUNT (STATUS)
{
{ STATUS: (output) This parameter specifies the request status.
{      IDENTIFIER: avc$validation_id
{
*DECK DECK=AVH$GET_ACCOUNT_PROJECT_VALUE EXPAND=FALSE
{
{    The purpose of this request is to get the value of an account project
{ type of validation field for the currently executing job.
{
{       AVP$GET_ACCOUNT_PROJECT_VALUE (FIELD_NAME, RECORD_LEVEL,
{             ACCOUNT, PROJECT, STATUS)
{
{ FIELD_NAME: (input)  Specifies the name of the field.
{
{ RECORD_LEVEL: (input)  Specifies which validation record the validation field
{       resides in.
{
{ ACCOUNT: (output)  Variable to receive the account value for the validation
{       field.
{
{ PROJECT: (output)  Variable to receive the project value for the validation
{       field.
{
{ STATUS: (output)  This parameter specifies the request status.
{

*DECK DECK=AVH$GET_ACCUM_LIMIT_VALUE EXPAND=FALSE
{
{    The purpose of this request is to get the value of an accumulating limit
{ type of validation field for the currently executing job.
{
{       AVP$GET_ACCUM_LIMIT_VALUE (FIELD_NAME, RECORD_LEVEL,
{             JOB_LIMIT_INFORMATION, TOTAL_LIMIT_INFORMATION, DISPLAY_FORMAT,
{             STATUS)
{
{ FIELD_NAME: (input)  Specifies the name of the field.
{
{ RECORD_LEVEL: (input)  Specifies which validation record the validation field
{       resides in.
{
{ JOB_LIMIT_INFORMATION: (output)  Variable to receive information about job
{       limit values.
{
{ TOTAL_LIMIT_INFORMATION: (output)  Variable to receive information about
{       total limit values.
{
{ DISPLAY_FORMAT: (output) Variable to receive the display format to use when
{       displaying limit values.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=AVH$GET_CAPABILITY EXPAND=FALSE
{
{    The purpose of this request is to get the value of a capability type of
{ validation field for the currently executing job.
{
{       AVP$GET_CAPABILITY (FIELD_NAME, RECORD_LEVEL, CAPABILITY, STATUS)
{
{ FIELD_NAME: (input)  Specifies the name of the capability validation field.
{
{ RECORD_LEVEL: (input)  Specifies which validation record the capability
{       resides in.
{
{ CAPABILITY: (output)  Variable to receive the value of the capability.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=AVH$GET_DATA_RECORD_STATISTICS EXPAND=FALSE
{
{    Retrieves statistical information about the data records in a template file.,
{
{       AVP$GET_DATA_RECORD_STATISTICS (SPACE_USED_BY_DATA_RECORDS,
{             DATA_RECORD_COUNT, FILE_INFORMATION, STATUS);
{
{ SPACE_USED_BY_DATA_RECORDS: (output) Totl amount of space occupied by data
{       records in a template file (in bytes).
{
{ DATA_RECORD_COUNT: (output) Total number of data records in the template file.
{
{ FILE_INFORMATION: (output) Record used by the template file manager to hold
{       information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             None
{
*DECK DECK=AVH$GET_DATE_TIME_VALUE EXPAND=FALSE
{
{    The purpose of this request is to get value of a date time type of
{ validation field for the currently executing job.
{
{       AVP$GET_DATE_TIME_VALUE (FIELD_NAME, RECORD_LEVEL, DATE_TIME,
{             DATE_DISPLAY_FORMAT, TIME_DISPLAY_FORMAT, STATUS)
{
{ FIELD_NAME: (input)  Specifies the name of the validation field.
{
{ RECORD_LEVEL: (input)  Specifies which validation record contains the
{       validation field.
{
{ DATE_TIME: (output)  Variable to receive the value of the validation field.
{
{ DATE_DISPLAY_FORMAT: (output)  Variable to receive the date display format.
{
{ TIME_DISPLAY_FORMAT: (output)  Variable to receive the time display format.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=AVH$GET_DESCRIPTION_RECORD EXPAND=FALSE
{
{    This interface is used to retrieve a copy of a specified description
{ record.
{
{       AVP$GET_DESCRIPTION_RECORD (DESCRIPTION_RECORD_NAME,
{              DESCRIPTION_RECORD, FILE_INFORMATION, STATUS)
{
{ DESCRIPTION_RECORD_NAME: (input) Name of the description record.
{
{ DESCRIPTION_RECORD: (input, output) Pointer to a sequence in which a copy of
{       the description will be stored.  The sequence will be positioned after
{       the copy of the description record when the request completes.
{
{ FILE_INFORMATION: (input, output) The record used by the template file manager
{       to hold information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$unknown_description_record
{             ave$work_area_full
{
*DECK DECK=AVH$GET_DESC_UTILITY_INFO EXPAND=FALSE
{
{    This interface is used to retrieve a copy of the utility information
{ for a description record.
{
{       AVP$GET_DESC_UTILITY_INFO (DESCRIPTION_RECORD_NAME,
{              UTILITY_INFORMATION, FILE_INFORMATION, STATUS)
{
{ DESCRIPTION_RECORD_NAME: (input) Name of the description record.
{
{ UTILITY_INFORMATION: (input, output) Pointer to a sequence in which a copy of
{       the utility information will be stored.  The sequence will be positioned
{       after the utility information when the request completes.
{
{ FILE_INFORMATION: (input, output) The record used by the template file manager
{       to hold information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$unknown_description_record
{             ave$work_area_full
{
*DECK DECK=AVH$GET_DESC_UTILITY_INFO_SIZE EXPAND=FALSE
{
{    This interface is used to determine the size of the utility information
{ for a description record.
{
{       AVP$GET_DESC_UTILITY_INFO (DESCRIPTION_RECORD_NAME,
{              UTILITY_INFORMATION_SIZE, FILE_INFORMATION, STATUS)
{
{ DESCRIPTION_RECORD_NAME: (input) Name of the description record.
{
{ UTILITY_INFORMATION_SIZE: (output) Size of the utility information field for
{       the specified description record.
{
{ FILE_INFORMATION: (input, output) The record used by the template file manager
{       to hold information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$unknown_description_record
{
*DECK DECK=AVH$GET_FIELD EXPAND=FALSE
{
{    Retrieves the value for a specified field.
{
{       AVP$GET_FIELD (FIELD_NAME, DATA_RECORD, DESCRIPTION_RECORD, FIELD_VALUE,
{             TYPE_SPECIFICATION, DEFAULT_VALUE, DESCRIPTIVE_TEXT,
{             UTILITY_INFORMATION, STATUS)
{
{ FIELD_NAME: (input) Name of the field.
{
{ DATA_RECORD: (input) Pointer to the data record containing the field.
{
{ DESCRIPTION_RECORD: (input) Pointer to the description record containing the
{       field.
{
{ FIELD_VALUE: (output) Value of the specified field.
{
{ TYPE_SPECIFICATION: (output) Type specification of the specified field.
{
{ DEFAULT_VALUE: (output) Default value for the specified field.
{
{ DESCRIPTIVE_TEXT: (output) Pointer to the descriptive text for the specified
{       field.
{
{ UTILITY_INFORMATION: (output) Pointer to the utility information for the
{       specified field.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$unknown_field
{
*DECK DECK=AVH$GET_FIELD_DESCRIPTION EXPAND=FALSE
{
{    Retrieves information about a template field.
{
{       AVP$GET_FIELD_DESCRIPTION (FIELD_NAME, DESCRIPTION_RECORD,
{             TYPE_SPECIFICATION, DEFAULT_VALUE, DESCRIPTIVE_TEXT,
{             UTILITY_INFORMATION, STATUS)
{
{ FIELD_NAME: (input) Name of the template field.
{
{ DESCRIPTION_RECORD: (input) Pointer to the description record containing
{       the field.
{
{ TYPE_SPECIFICATION: (output) Type specification of the field
{
{ DEFAULT_VALUE: (output) Default value of the field.
{
{ DESCRIPTIVE_TEXT: (output) Pointer to the descriptive text for the field.
{
{ UTILITY_INFORMATION: (output) Pointer to the utility information for the
{       field.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$field_was_deleted
{             ave$unknown_field
{
*DECK DECK=AVH$GET_FIELD_NAMES EXPAND=FALSE
{
{    Retrieves the names of selected template fields in the specified
{  description record.
{
{       AVP$GET_FIELD_NAMES (DESIRED_FIELD_TYPES, RETURN_DELETED_NAMES,
{             DESCRIPTION_RECORD, FIELD_NAMES, FIELD_COUNT, STATUS)
{
{ DESIRED_FIELD_TYPES: (input) Set of field types that the list of field names
{       should be restricted to.
{
{ RETURN_DELETED_NAMES: (input) Boolean value that specifies whether the request
{       will return a list of the delete fields (TRUE) or active fields (FALSE).
{
{ DESCRIPTION_RECORD: (input) Pointer to the description record.
{
{ FIELD_NAMES: (output) An array to receive the names of the selected fields.
{
{ FIELD_COUNT: (output) Number of fields defined in the specified description
{       record.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$name_list_too_small
{
*DECK DECK=AVH$GET_FIELD_NAME_LIST EXPAND=FALSE
{
{    The purpose of this request is to retrieve the names of selected
{ validation fields for the specified validation record.
{
{       AVP$GET_FIELD_NAME_LIST (RECORD_LEVEL, DESIRED_FIELD_TYPES,
{             FIELD_NAMES, FIELD_COUNT, STATUS)
{
{ RECORD_LEVEL: (input)  Specifies which validation record the list should be
{       retrieved from.
{
{ DESIRED_FIELD_TYPES: (input)  Specifies the set of field types that the list
{       of field names should be restricted to.
{
{ FIELD_NAMES: (output)  An array to receive the names of the selected fields.
{       If the array is not large enough to hold all of the field names, only
{       as many names as will fit, will be returned.
{
{ FIELD_COUNT: (output)  Variable to receive the actual number of validation
{       fields.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=AVH$GET_FILE_UTILITY_INFO EXPAND=FALSE
{
{    This interface is used to retrieve a copy of the template file utility
{ information.
{
{       AVP$GET_FILE_UTILITY_INFO (UTILITY_INFORMATION, FILE_INFORMATION, STATUS)
{
{ UTILITY_INFORMATION: (input, output) Pointer to a sequence in which a copy of
{       the utility information for the file will be stored.  The sequence will
{       be positioned after the utility information when the request completes.
{
{ FILE_INFORMATION: (input, output) The record used by the template file manager
{       to hold information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$work_area_full
{
*DECK DECK=AVH$GET_FILE_UTILITY_INFO_SIZE EXPAND=FALSE
{
{    This interface is used to determine the size of the utility information
{ field for the file.
{
{       AVP$GET_FILE_UTILITY_INFO_SIZE (UTILITY_INFORMATION_SIZE,
{             FILE_INFORMATION, STATUS)
{
{ UTILITY_INFORMATION_SIZE: (output) Size of the template file utility
{       information field.
{
{ FILE_INFORMATION: (input, output) The record used by the template file manager
{       to hold information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             none
{
*DECK DECK=AVH$GET_FILE_VALUE EXPAND=FALSE
{
{    The purpose of this request is to get the value of a file type of
{ validation field for the currently executing job.
{
{       AVP$GET_FILE_VALUE (FIELD_NAME, RECORD_LEVEL, FILE, STATUS)
{
{ FIELD_NAME: (input)  Specifies the name of the validation field.
{
{ RECORD_LEVEL: (input)  Specifies which validation record contains the
{       validation field.
{
{ FILE: (output)  Variable to receive the value of the validation field.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=AVH$GET_INDEX_RECORD_STATISTICS EXPAND=FALSE
{
{    Retrieves statistical information about the index records in a template file.
{
{       AVP$GET_INDEX_RECORD_STATISTICS (DEPTH, SPACE_USED_BY_INDEX_RECORDS,
{             INDEX_RECORD_COUNT, TOTAL_KEY_COUNT, MINIMUM_KEY_COUNT,
{             MAXIMUM_KEY_COUNT, FILE_INFORMATION, STATUS)
{
{ DEPTH: (input) Specifies which index level is examined.
{
{ SPACE_USED_BY_INDEX_RECORDS: (output) Total amount of space used by index
{       records (in bytes) at the specified depth.
{
{ INDEX_RECORD_COUNT: (ouptut) Number of index records at the specified depth.
{
{ TOTAL_KEY_COUNT: (output) Total number of keys at the specified depth.
{
{ MINIMUM_KEY_COUNT: (output) Minimum number of keys in an index record at the
{       specified depth.
{
{ MAXIMUM_KEY_COUNT: (output) Maximum number of keys in an index record at the
{       specified depth.
{
{ FILE_INFORMATION: (output) Record used by the template file manager to hold
{       information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             None
{
*DECK DECK=AVH$GET_INTEGER_VALUE EXPAND=FALSE
{
{    The purpose of this request is to get the value of an integer type of
{ validation field for the current executing job.
{
{       AVP$GET_INTEGER_VALUE (FIELD_NAME, RECORD_LEVEL, INTEGER_VALUE,
{             INTEGER_DISPLAY_FORMAT, STATUS)
{
{ FIELD_NAME: (input)  Specifies the name of the validation field.
{
{ RECORD_LEVEL: (input)  Specifies which validation record contains the
{       validation field.
{
{ INTEGER_VALUE: (output)  Variable to receive the value of the validation
{       field.
{
{ INTEGER_DISPLAY_FORMAT: (output)  Variable to receive the display format.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=AVH$GET_JOB_CLASS_VALUE EXPAND=FALSE
{
{    The purpose of this request is to get the value of a job class type
{ validation field for the current executing job.
{
{       AVP$GET_JOB_CLASS_VALUE (FIELD_NAME, RECORD_LEVEL, JOB_CLASSES,
{             NUMBER_OF_JOB_CLASSES, BATCH_JOB_CLASS_DEFAULT,
{             INTERACTIVE_JOB_CLASS_DEFAULT, STATUS)
{
{ FIELD_NAME: (input)  Specifies the name of the validation field.
{
{ RECORD_LEVEL: (input)  Specifies which validation record contains the
{       validation field.
{
{ JOB_CLASSES: (output)  An array of names to receive the list of job classes.
{       If the specified array is not large enough to hold all of the job
{       classes only as many as will fit are returned.
{
{ NUMBER_OF_JOB_CLASSES: (output)  Variable to receive the actual number of job
{       classes.  The number returned is always the actual number of job
{       classes for the field NOT the number returned in the previous job
{       classes parameter.
{
{ BATCH_JOB_CLASS_DEFAULT: (output)  Variable to receive the default batch job
{       class.
{
{ INTERACTIVE_JOB_CLASS_DEFAULT: (output)  Variable to receive the default
{       interactive job class.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=AVH$GET_LABELED_NAMES_VALUE EXPAND=FALSE
{
{    The purpose of this request is to get the value of a labeled names type of
{ validation field for the currently executing job.
{
{       AVP$GET_NAME_VALUE (FIELD_NAME, RECORD_LEVEL, WORK_AREA, LABELED_NAMES,
{             STATUS)
{
{ FIELD_NAME: (input)  Specifies the name of the validation field.
{
{ RECORD_LEVEL: (input)  Specifies which validation record contains the
{       validation field.
{
{ WORK_AREA: (input)  Specifies a pointer to the work area in which the labeled
{       names value will be returned.
{
{ LABELED_NAMES: (output)  A pointer to the labeled names returned in the work
{       area.  The specified work area must be big enough to hold all of the
{       labeled names.
{
{ STATUS: (output)  This parameter specifies the request status.
{
{ CONDITIONS: ave$incorrect_kind
{
*DECK DECK=AVH$GET_LIMIT_VALUE EXPAND=FALSE
{
{    The purpose of this request is to get the value of a limit type of
{ validation field for the currently executing job.
{
{       AVP$GET_LIMIT_VALUE (FIELD_NAME, RECORD_LEVEL, LIMIT_VALUE,
{             DISPLAY_FORMAT, STATUS)
{
{ FIELD_NAME: (input)  Specifies the name of the validation field.
{
{ RECORD_LEVEL: (input)  Specifies which validation record contains the
{       validation field.
{
{ LIMIT_VALUE: (output)  Variable to receive the value of the validation field.
{
{ DISPLAY_FORMAT: (output)  Variable to receive the display format to be used
{       when displaying the limit value.
{
{ STATUS: (output)  This parameter specifies the request status.
{
{
*DECK DECK=AVH$GET_LOGIN_PASSWORD_VALUE EXPAND=FALSE
{
{    The purpose of this request is to get information about the login password
{ for the current executing job.  The encrypted password is not returned by
{ this interface for security reasons.
{
{       AVP$GET_LOGIN_PASSWORD_VALUE (FIELD_NAME, RECORD_LEVEL,
{             EXPIRATION_DATE, EXPIRATION_INTERVAL,
{             MAXIMUM_EXPIRATION_INTERVAL, EXPIRATION_WARNING_INTERVAL,
{             EXPIRED_PW_CHANGE_INTERVAL, CHANGE_DATE, ATTRIBUTES,
{             NUMBER_ATTRIBUTES, STATUS)
{
{ FIELD_NAME: (input)  Specifies the name of the validation field.
{
{ RECORD_LEVEL: (input)  Specifies which validation record contains the
{       validation field.
{
{ EXPIRATION_DATE: (output)  Variable to receive the password expiration date.
{
{ EXPIRATION_INTERVAL: (output)  Variable to receive the password expiration
{       interval.
{
{ MAXIMUM_EXPIRATION_INTERVAL: (output)  Variable to receive the maximum
{       password expiration interval.
{
{ EXPIRATION_WARNING_INTERVAL: (output)  Variable to receive the password
{       expiration warning interval.
{
{ EXPIRED_PW_CHANGE_INTERVAL: (output)  Variable to receive the expiraed
{       password change interval.
{
{ CHANGE_DATE: (output)  Variable to receive the date of the most recent
{       password change.
{
{ ATTRIBUTES: (output)  An array of names to receive the list of password
{       attributes.  If the specified array is not big enough to hold all of
{       the attributes, only as many as will fit in the array are returned.
{
{ NUMBER_ATTRIBUTES: (output)  Variable to receive the acual number of password
{       attributes.  The number returned is always the actual number of
{       attributes, not the number returned in the previous attributes
{       parameter.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=AVH$GET_NAME_VALUE EXPAND=FALSE
{
{    The purpose of this request is to get the value of a name type of
{ validation field for the currently executing job.
{
{       AVP$GET_NAME_VALUE (FIELD_NAME, RECORD_LEVEL, NAMES, NUMBER_OF_NAMES,
{             STATUS)
{
{ FIELD_NAME: (input)  Specifies the name of the validation field.
{
{ RECORD_LEVEL: (input)  Specifies which validation record contains the
{       validation field.
{
{ NAMES: (output)  An array to receive the list of names.  If the specified
{       array is not big enough to hold all of the names only as many as will
{       fit are returned.
{
{ NUMBER_OF_NAMES: (output)  Variable to receive the actual number of names.
{       The number returned is always the actual number of names, not the
{       number returned in the previous names parameter.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=AVH$GET_REAL_VALUE EXPAND=FALSE
{
{    The purpose of this request is to get the value of a real type of
{ validation field for the currently executing job.
{
{       AVP$GET_REAL_VALUE (FIELD_NAME, RECORD_LEVEL, REAL_VALUE,
{             REAL_DISPLAY_FORMAT, STATUS)
{
{ FIELD_NAME: (input)  Specifies the name of the validation field.
{
{ RECORD_LEVEL: (input)  Specifies which validation record contains the
{       validation field.
{
{ REAL_VALUE: (output)  Variable to receive the value of the validation field.
{
{ REAL_DISPLAY_FORMAT: (output)  Variable to receive the display format.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=AVH$GET_REMOVABLE_MEDIA_ACCESS EXPAND=FALSE
{
{    The purpose of this procedure is to determine whether or not a user is
{ validated for a particular REMOVABLE_MEDIA_ACCESS and to return the modes of
{ access for which the user is validated.  If there is no
{ REMOVABLE_MEDIA_ACCESS validation defined that matches the specified name,
{ abnormal status is returned.
{
{       AVP$GET_REMOVABLE_MEDIA_ACCESS ( USER, FAMILY,
{             REMOVABLE_MEDIA_ACCESS_NAME, ACCESS, STATUS)
{
{    user: (input)  This parameter identifies the name of the user whose
{          validation is to be interrogated.
{
{    family: (input)  This parameter identifies the name of the family whose
{          validation is to be interrogated.  The family may be a file served
{          family.
{
{    removable_media_access_name: (input)  This parameter identifies the name
{          of the removable media access validation.  The
{          REMOVABLE_MEDIA_ACCESS validation consists of a name and an access.
{          The access may be ALL, NONE, READ, WRITE, or READ and WRITE.
{
{    access: (output)  This parameter returns the access to which the user is
{          validated by the REMOVABLE_MEDIA_ACCESS.
{
{          If the value ALL is in the validation, the full set [fsc$append,
{          fsc$execute, fsc$modify, fsc$read, fsc$shorten] is returned.
{
{          If the value NONE is in the validation, an empty set is returned.
{
{          If the value READ is in the validation, the set [fsc$execute,
{          fsc$read] is returned.
{
{          If the value WRITE is in the validation, the set [fsc$append,
{          fsc$modify, fsc$shorten] is returned.
{
{    status: (output)  The status of the request.
*DECK DECK=AVH$GET_SET_NAME EXPAND=FALSE
{
{    The purpose of this procedure is to get the set name for a family.
{
{       AVP$GET_SET_NAME (FAMILY_NAME, SET_NAME, STATUS)
{
{ FAMILY_NAME: (input)  This parameter specifies the name of the family to be
{       changed.
{
{ SET_NAME: (output)  This parameter returns the name of the set of permanent
{       file devices that this family resides on.
{
{ STATUS: (output) This parameter specifies the request status.
{
{      CONDITION: ave$insufficient_authority
{
*DECK DECK=AVH$GET_STRING_VALUE EXPAND=FALSE
{
{    The purpose of this request is to get the value of a string type of
{ validation field for the currently executing job.
{
{       AVP$GET_STRING_VALUE (FIELD_NAME, RECORD_LEVEL, STRING_VALUE, STATUS)
{
{ FIELD_NAME: (input)  Specifies the name of the validation field.
{
{ RECORD_LEVEL: (input)  Specifies which validation record contains the
{       validation field.
{
{ STRING_VALUE: (output)  Variable to receive the value of the validation
{       field.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=AVH$GET_TEMPLATE_FILE_HEADER EXPAND=FALSE
{
{    This interface is used to retrieve a copy of the header record for the
{ template file.
{
{       AVP$GET_TEMPLATE_FILE_HEADER (HEADER, FILE_INFORMATION, STATUS);
{
{ HEADER: (output) Variable to recieve a copy of the header for the template
{       file.
{
{ FILE_INFORMATION: (input, output) The record used by the template file manager
{       to hold information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             None
{
*DECK DECK=AVH$INITIALIZE EXPAND=FALSE
{
{   The purpose of this procedure is to initialize the Accounting and Validation
{ Facility.  The call to this procedure should be made once at deadstart from
{ the system job to insure proper initialization.
{
{       AVP$INITIALIZE (STATUS)
{
{ STATUS: (output) This parameter returns the request status.
*DECK DECK=AVH$INITIALIZE_FAMILY EXPAND=FALSE
{
{    The purpose of this procedure is to initialize the validation file for an
{ existing family as it is being brought on line.  This procedure opens the
{ validation file, checks to make sure required user names exist on it and
{ converts the validation file if necessary.
{
{       AVP$INITIALIZE_FAMILY (FAMILY_NAME, STATUS)
{
{ FAMILY_NAME: (input)  This parameter specifies the name of the family to be
{       initialized.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=AVH$LOCK_TEMPLATE_FILE EXPAND=FALSE
{
{    This interface is used to set a lock on the template file.
{
{       AVP$LOCK_TEMPLATE_FILE (DESIRED_LOCK_TYPE, LOCK_SET_BY_THIS_PROCEDURE,
{            TEMPLATE_FILE_HEADER, TEMPLATE_FILE_HEAP, FILE_INFORMATION, STATUS);
{
{ DESIRED_LOCK_TYPE: (input) Kind of lock to be placed on the template file.
{       AVC$UPDATE_ACCESS - The entire template file is locked to allow
{             updating; prevents reading and updating of the template file by
{             other instances of open.
{       AVC$READ_ACCESS - The entire template file is locked to prevent
{             updating of the template file by other instances of open.
{             Other instances of open may read the template file while this
{             lock is in effect.
{
{ LOCK_SET_BY_THIS_PROCEDURE: (output) Returns a boolean value that specifies
{       whether this call resulted in the file being locked.  TRUE means that
{       this call locked the template file.  FALSE means the template file was
{       already locked with a compatible lock type and the operation can be
{       performed, but the caller should not unlock the file when finished.
{
{ TEMPLATE_FILE_HEADER: (output) Pointer to the template file header record.
{
{ TEMPLATE_FILE_HEAP: (output) Pointer to the template file heap.
{
{ FILE_INFORMATION: (input, output) The record used by the template file
{       manager to hold information about the template file.
{
{ STATUS:  (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$conflicting_locks
{
*DECK DECK=AVH$MONITOR_STATISTICS_FLAG EXPAND=FALSE

{
{   The purpose of this flag handler is to process flags whose flag_id is
{ avp$monitor_statistics_flag (= 1).  This flag handler is called
{ periodically to update job accounting statistics collected by monitor,
{ and to update System Resource Units.
{
{        AVP$MONITOR_STATISTICS_HANDLER (FLAG_ID)
{
{ FLAG_ID: (input) This parameter specifies the system flag which was set.
{
*DECK DECK=AVH$OPEN_TEMPLATE_FILE EXPAND=FALSE
{
{    This interface is used to open an existing template file or create a new
{  template file.
{
{       AVP$OPEN_TEMPLATE_FILE (FILE_NAME, CREATE_FILE, FILE_INFORMATION,
{             STATUS)
{
{ FILE_NAME: (input) File reference for the template file to be opened.
{
{ CREATE_FILE: (input) Specifies if the template file should be created.
{
{ FILE_INFORMATION: (output) The record that the template file manager will
{       use to hold information about the template file.  This record is
{       passed to other template file manager interfaces when accessing the
{       template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$not_a_template_file
{             ave$template_file_full
{
*DECK DECK=AVH$PREVALIDATE_JOB EXPAND=FALSE
{
{   This interface is used to prevalidate a job for access to NOS/VE.
{
{       AVP$PREVALIDATE_JOB (USER_NAME, FAMILY_NAME, VALIDATION_ATTRIBUTES,
{             DEFAULT_ATTRIBUTES, STATUS)
{
{ USER_NAME: (input) This parameter specifies the name of the user to be
{        prevalidated.
{
{ FAMILY_NAME: (input) This parameter specifies the name of the family
{        the user is to be prevalidated.
{
{ VALIDATION_ATTRIBUTES: (input) This parameter specifies the validation
{        items to be prevalidated.
{
{ DEFAULT_ATTRIBUTES: (output) This parameter specifies the validation
{        items to be returned to the caller.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=AVH$PROCESS_PASSWORD_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to intercept and possibly alter password
{ change requests.
{
{       AVP$PROCESS_PASSWORD_ATTRIBUTES (VALIDATION_AUTHORITY, USER_NAME,
{             LAST_PASSWORD_CHANGE_DATE, OLD_ENCRYPTED_PASSWORD,
{             NEW_ENCRYPTED_PASSWORD, OLD_PASSWORD, NEW_PASSWORD,
{             LOGIN_PASSWORD_ATTRIBUTES, NUMBER_OF_PASSWORD_ATTRIBUTES, STATUS)
{
{ VALIDATION_AUTHORITY: (input)  This parameter specifies the authority of the
{       user making the request.
{
{ USER_NAME: (input)  This parameter specifies the user name that the password
{       belongs to.
{
{ LAST_PASSWORD_CHANGE_DATE: (input)  This parameter specifies the date and
{       time of the last password change for this user.
{
{ OLD_ENCRYPTED_PASSWORD: (input)  This parameter specifies the encrypted value
{       for the old password.
{
{ NEW_ENCRYPTED_PASSWORD: (input)  This parameter specifies the encrypted value
{       for the supplied new password.
{
{ OLD_PASSWORD: (input)  This parameter specifies the old password value.
{
{ NEW_PASSWORD: (input, output)  This parameter specifies the new password
{       value.  If the value of this parameter is changed by this procedure,
{       the changed value will be encrypted and stored in the validation file
{       as the new password for the user.
{
{ LOGIN_PASSWORD_ATTRIBUTES: (input, output)  This parameter specifies the list
{       of password attributes to be stored with the password.  The contents of
{       this list will be stored with the password in the validation file.
{
{ NUMBER_OF_PASSWORD_ATTRIBUTES: (input, output)  This parameter specifies the
{       actual number of password attributes.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=AVH$READ_DATA_RECORD EXPAND=FALSE
{
{    Reads a data record.
{
{       AVP$READ_DATA_RECORD (KEY, LOCK_TYPE, AUTOMATICALLY_UNLOCK,
{             DATA_RECORD, DESCRIPTION_RECORD, DESCRIPTION_RECORD_NAME,
{             FIELD_COUNT, FILE_INFORMATION, STATUS)
{
{ KEY: (input) Key for the data record to be read.
{
{ LOCK_TYPE: (input) Kind of lock to be placed on the template file.
{       AVC$UPDATE_ACCESS - The entire template file is locked to allow
{             updating; prevents reading and updating of the template file by
{             other instances of open.
{       AVC$READ_ACCESS - The entire template file is locked to prevent
{             updating of the template file by other instances of open.
{             Other instances of open may read the template file while this
{             lock is in effect.
{
{ AUTOMATICALLY_UNLOCK: (input) Boolean value that specifies whether the lock
{       is automatically released after the read is completed.
{
{ DATA_RECORD: (input, output) Pointer to a sequence in which a copy of the data
{       record will be stored.  The sequence will be positioned after the copy
{       of the data record when the request completes.
{
{ DESCRIPTION_RECORD: (input, output) Pointer to a sequence in which a copy of
{       the description will be stored.  The sequence will be positioned after
{       the copy of the description record when the request completes.
{
{ DESCRIPTION_RECORD_NAME: (output) Name of the description record
{       associated with the data record.
{
{ FIELD_COUNT: (output) Returns the number of fields defined in the data record.
{
{ FILE_INFORMATION: (output) Record used by the template file manager to hold
{       information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$unknown_record
{             ave$work_area_full
{
*DECK DECK=AVH$READ_NEXT_DATA_RECORD EXPAND=FALSE
{
{    Reads the next data record.
{
{       AVP$READ_NEXT_DATA_RECORD (LOCK_TYPE, AUTOMATICALLY_UNLOCK, KEY,
{             DATA_RECORD, DESCRIPTION_RECORD, DESCRIPTION_RECORD_NAME,
{             FIELD_COUNT, FILE_INFORMATION, STATUS)
{
{ LOCK_TYPE: (input) Kind of lock to be placed on the template file.
{       AVC$UPDATE_ACCESS - The entire template file is locked to allow
{             updating; prevents reading and updating of the template file by
{             other instances of open.
{       AVC$READ_ACCESS - The entire template file is locked to prevent
{             updating of the template file by other instances of open.
{             Other instances of open may read the template file while this
{             lock is in effect.
{
{ AUTOMATICALLY_UNLOCK: (input) Boolean value that specifies whether the lock
{       is automatically released after the read is completed.
{
{ KEY: (output) Key for the data record to be read.
{
{ DATA_RECORD: (input, output) Pointer to a sequence in which a copy of the data
{       record will be stored.  The sequence will be positioned after the copy
{       of the data record when the request completes.
{
{ DESCRIPTION_RECORD: (input, output) Pointer to a sequence in which a copy of
{       the description will be stored.  The sequence will be positioned after
{       the copy of the description record when the request completes.
{
{ DESCRIPTION_RECORD_NAME: (output) Name of the description record
{       associated with the data record.
{
{ FIELD_COUNT: (output) Returns the number of fields defined in the data record.
{
{ FILE_INFORMATION: (output) Record used by the template file manager to hold
{       information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$end_of_template_file
{             ave$work_area_full
{
*DECK DECK=AVH$REORGANIZE_VALIDATION_FILE EXPAND=FALSE
{
{    This interface is used to copy the contents of a template file to
{  another file.  During this process, the file is cleaned up by eliminating
{  unused space (the result of deleting records) and reorganizing the index
{  structure for the file.
{
{       AVP$REORGANIZE_VALIDATION_FILE (OLD_FILE_NAME, NEW_FILE_NAME, STATUS)
{
{ OLD_FILE_NAME: (input) Specifies the file reference for the template file to
{       be restructured.
{
{ NEW_FILE_NAME: (input) Specifies the file reference for the restructured
{       template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{
*DECK DECK=AVH$RESTORE_FIELD EXPAND=FALSE
{
{    This interface is used to restore ("undelete") a field.
{
{       AVP$RESTORE_FIELD (FIELD_NAME, DESCRIPTION_RECORD_NAME,
{             FILE_INFORMATION, STATUS)
{
{ FIELD_NAME: (input) Name of the field to be restored.
{
{ DESCRIPTION_RECORD_NAME: (input) Name of the description record containing
{       the field.
{
{ FILE_INFORMATION: (input, output) The record used by the template file manager
{       to hold information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$not_a_deleted_field
{             ave$unknown_field
{             ave$unknown_description_record
{
*DECK DECK=AVH$RESTRUCTURE_TEMPLATE_FILE EXPAND=FALSE
{
{    This interface is used to copy the contents of a template file to
{  another file.  During this process, the file is cleaned up by eliminating
{  unused space (the result of deleting records) and reorganizing the index
{  structure for the file.
{
{       AVP$RESTRUCTURE_TEMPLATE_FILE (OLD_FILE_NAME, NEW_FILE_NAME, STATUS)
{
{ OLD_FILE_NAME: (input) Specifies the file reference for the template file to
{       be restructured.
{
{ NEW_FILE_NAME: (input) Specifies the file reference for the restructured
{       template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$corrupted_sequence
{             ave$template_file_full
{             ave$not_a_template_file
{
*DECK DECK=AVH$REWRITE_DATA_RECORD EXPAND=FALSE
{
{    Rewrites a data record.
{
{       AVP$REWRITE_DATA_RECORD (KEY, AUTOMATICALLY_UNLOCK, DATA_RECORD,
{             DESCRIPTION_RECORD< FIELD_VALUE_LIST, FILE_INFORMATION, STATUS)
{
{ KEY: (input) Key for the data record to be rewritten.
{
{ AUTOMATICALLY_UNLOCK: (input) Specifies whether or not the lock on the
{       template file is automatically released after the rewrite has
{       completed.
{
{ DATA_RECORD: (input) Pointer to the data record to be rewritten.
{
{ DESCRIPTION_RECORD: (input) Pointer to the description record associated with
{       the data record being rewritten.
{
{ FIELD_VALUE_LIST: (input) Pointer to a field value list for the data record
{       being rewritten.
{
{ FILE_INFORMATION: (input, output) Record being used by the template file
{       manager to hold information about the template file.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$template_file_full
{             ave$update_lock_required
{
*DECK DECK=AVH$RING_MIN EXPAND=FALSE

{
{   The purpose of this request is to get the minimum ring number of the
{ current executing job.
{
{  NOTE: When this interface is called by a system administrator the
{        minimum ring value returned is always the value of the
{        task services ring.
{
{        AVP$RING_MIN : RING_MIN
{
{ RING_MIN: (output) This function specifies the minimum ring number of the
{        current executing job.
{
*DECK DECK=AVH$RING_NOMINAL EXPAND=FALSE

{
{   The purpose of this request is to get the nominal ring number of the
{ current executing job.
{
{        AVP$RING_NOMINAL : RING_NOMINAL
{
{ RING_NOMINAL: (output) This function specifies the nominal ring number of
{        the current executing job.
{
*DECK DECK=AVH$UNLOCK_TEMPLATE_FILE EXPAND=FALSE
{
{    Clears a template file lock.
{
{       AVP$UNLOCK_TEMPLATE_FILE (FILE_INFORMATION, STATUS)
{
{ FILE_INFORMATION: (input, output) Record being used by the template file
{       manager to hold information about the template file.
{
{ STATUS:  (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             None
{
*DECK DECK=AVH$VALIDATE_JOB EXPAND=FALSE
{
{   This interface is used to validate a job for access to NOS/VE
{ at login, and retrieves job limits from the validation file.
{
{       AVP$VALIDATE_JOB (USER_NAME, FAMILY_NAME, ACCOUNT, PROJECT,
{             VALIDATION_ATTRIBUTES, STATUS)
{
{ USER_NAME: (input) This parameter specifies the name of the user to be
{        validated.
{
{ FAMILY_NAME: (input) This parameter specifies the name of the family
{        the user is to be validated.
{
{ ACCOUNT: (input) This parameter identifies the account specified by the
{        user on the login statement.  If a null account is specified the
{        user's default will be used.
{
{ PROJECT: (input) This parameter identifies the project specified by the
{        user on the login statement.  It a null project is specified the
{        user's default will be used.
{
{ VALIDATION_ATTRIBUTES: (input) This parameter specifies the validation
{        items to be validated.
{
{ STATUS: (output) This parameter specifies the request status.
{

*DECK DECK=AVH$VALIDATE_NQS_USER EXPAND=TRUE
{
{    This interface validates a family user account project unix_username ring
{ combination.
{
{       AVP$VALIDATE_NQS_USER (USER, FAMILY, ACCOUNT, PROJECT, UNIX_USERNAME,
{             RING, STATUS)
{
{   USER: (input)  NOS/VE user name.
{
{   FAMILY: (input)  NOS/VE family name.
{
{   ACCOUNT: (input)  Account name.
{
{   PROJECT: (input)  Project name.
{
{   UNIX_USERNAME: (input)  Unix user equivalent to the NOS/VE user and family.
{
{   RING: (input)  The ring access requested.
{
{   STATUS: (output) The standard status variable.
*DECK DECK=AVH$VERIFY_TEMPLATE_HEAP EXPAND=FALSE
{    The purpose of this request is to attempt to validate that the validation
{ template file has a valid heap.  If the heap is invalid, NOS/VE could have
{ serious problems, such as not deadstarting, or crashing unexpectedly.
{
{       AVP$VERIFY_TEMPLATE_HEAP (FAMILY_NAME, FILE_INFORMATION, STATUS);
{
{ FAMILY_NAME: (input)  This is the family name of the template file being
{       validated.
{
{ FILE_INFORMATION: (input, output)  This is the information created when the
{       template file was opened.
{
{ STATUS: (output) This is the status of the request.
{      CONDITION:
{            ave$template_file_damaged
*DECK DECK=AVH$VERIFY_TYPE_CONFORMANCE EXPAND=FALSE
{
{    This interface is used to verify that a field value conforms to the
{ type specification for the field
{
{       AVP$VERIFY_TYPE_CONFORMANCE (FIELD_NAME, FIELD_VALUE,
{              TYPE_SPECIFICATION, STATUS)
{
{ FIELD_NAME: (input) Name of the field being checked.
{
{ FIELD_VALUE: (input) Field value to be checked.
{
{ TYPE_SPECIFICATION: (input) Type specification for the field being checked.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             ave$date_not_allowed
{             ave$date_required
{             ave$incorrect_exp_interval
{             ave$incorrect_expiration_date
{             ave$incorrect_file_reference
{             ave$incorrect_job_limits
{             ave$incorrect_ring_privileges
{             ave$kind_not_implemented
{             ave$kinds_do_not_match
{             ave$not_validated_for_default
{             ave$out_of_range
{             ave$string_too_short
{             ave$string_too_long
{             ave$time_not_allowed
{             ave$time_required
{             ave$too_few_names
{             ave$too_many_names
{             ave$unexpected_nil_pointer
{             ave$unknown_field_kind
{             ave$value_is_not_a_name
{
*DECK DECK=AVH$VERIFY_VALIDATION_NAME EXPAND=FALSE
{
{    The purpose of this request is verify that a name being used for a
{ validaition value is within the specifications decided upon by the site.
{
{       AVP$VERIFY_VALIDATION_NAME (VALIDATION_NAME, STATUS)
{
{ VALIDATION_NAME: (input)  This parameter specifies a record which contains
{       the type of name and the name specified by the user.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=AVK$MONITOR_STATISTICS_HANDLER EXPAND=FALSE

  CONST
    avk$monitor_statistics_handler = avk$base + 1,
    {E  'avp$monitor_statistics_handler' 'flag' I22 }
    {X  'avp$monitor_statistics_handler' }

    avk$begin_account = avk$base + 2,
    {E  'avp$begin_account' }
    {X  'avp$begin_account' }

    avk$end_account = avk$base + 3,
    {E  'avp$end_account' }
    {X  'avp$end_account' }

    avk$create_user = avk$base + 4,
    {E  'avp$create_user' }
    {X  'avp$create_user' }

    avk$change_user = avk$base + 5,
    {E  'avp$change_user' }
    {X  'avp$change_user' }

    avk$read_user = avk$base + 6,
    {E  'avp$read_user' }
    {X  'avp$read_user' }

    avk$delete_user = avk$base + 7,
    {E  'avp$delete_user' }
    {X  'avp$delete_user' }

    avk$get_next_user = avk$base + 8,
    {E  'avp$get_next_user' }
    {X  'avp$get_next_user' }

    avk$login_user = avk$base + 9,
    {E  'avp$login_user' }
    {X  'avp$login_user' }

    avk$get_user_set = avk$base + 10,
    {E  'avp$get_user_set' }
    {X  'avp$get_user_set' }

    avk$ring_min = avk$base + 11,
    {E  'avp$ring_min' }
    {X  'avp$ring_min' }

    avk$ring_nominal = avk$base + 12,
    {E  'avp$ring_nominal' }
    {X  'avp$ring_nominal' }

    avk$get_scratch_sets = avk$base + 13,
    {E  'avp$get_scratch_sets' }
    {X  'avp$get_scratch_sets' }

    avk$get_prologs = avk$base + 14,
    {E  'avp$get_prologs' }
    {X  'avp$get_prologs' }

    avk$get_epilogs = avk$base + 15,
    {E  'avp$get_epilogs' }
    {X  'avp$get_epilogs' }

    avk$register_family = avk$base + 16,
    {E  'avp$register_family' }
    {X  'avp$register_family' }

    avk$remove_family = avk$base + 17,
    {E  'avp$remove_family' }
    {X  'avp$remove_family' }

    avk$get_family_administrator = avk$base + 18,
    {E  'avp$get_family_administrator' }
    {X  'avp$get_family_administrator' }

    avk$get_administrator_status = avk$base + 19,
    {E  'avp$get_administrator_status' }
    {X  'avp$get_administrator_status' }

    avk$change_password = avk$base + 20,
    {E  'avp$change_password' }
    {X  'avp$change_password' }

    avk$change_family_interface = avk$base + 21,
    {E  'avp$change_family_interface' }
    {X  'avp$change_family_interface' }

    avk$retrieve_family_entry = avk$base + 22;
    {E  'avp$retrieve_family_entry' }
    {X  'avp$retrieve_family_entry' }

?? PUSH (LISTEXT := ON) ??
*copyc OSK$KEYPOINTS
?? POP ??
*DECK DECK=AVK$TEMPLATE_FILE_MANAGER EXPAND=FALSE

  CONST
    avk$change_desc_utility_info = avk$base + 1,
    {E  'avp$change_desc_utility_info' }
    {X  'avp$change_desc_utility_info' }

    avk$change_field = avk$base + 2,
    {E  'avp$change_field' }
    {X  'avp$change_field' }

    avk$avp$change_field_name = avk$base + 3,
    {E  'avp$change_field_name' }
    {X  'avp$change_field_name' }

    avk$change_file_utility_info = avk$base + 4,
    {E  'avp$change_file_utility_info' }
    {X  'avp$change_file_utility_info' }

    avk$close_template_file = avk$base + 5,
    {E  'avp$close_template_file' }
    {X  'avp$close_template_file' }

    avk$create_data_record = avk$base + 6,
    {E  'avp$create_data_record' }
    {X  'avp$create_data_record' }

    avk$create_description_record = avk$base + 7,
    {E  'avp$create_description_record' }
    {X  'avp$create_description_record' }

    avk$create_field = avk$base + 8,
    {E  'avp$create_field' }
    {X  'avp$create_field' }

    avk$delete_data_record = avk$base + 9,
    {E  'avp$delete_data_record' }
    {X  'avp$delete_data_record' }

    avk$delete_field = avk$base + 11,
    {E  'avp$delete_field' }
    {X  'avp$delete_field' }

    avk$determine_if_key_exists = avk$base + 12,
    {E  'avp$determine_if_key_exists' }
    {X  'avp$determine_if_key_exists' }

    avk$get_data_record_statistics = avk$base + 13,
    {E  'avp$get_data_record_statistics' }
    {X  'avp$get_data_record_statistics' }

    avk$get_desc_utility_info = avk$base + 14,
    {E  'avp$get_desc_utility_info' }
    {X  'avp$get_desc_utility_info' }

    avk$get_desc_utility_info_size = avk$base + 15,
    {E  'avp$get_desc_utility_info_size' }
    {X  'avp$get_desc_utility_info_size' }

    avk$get_description_record = avk$base + 16,
    {E  'avp$get_description_record' }
    {X  'avp$get_description_record' }

    avk$get_field = avk$base + 17,
    {E  'avp$get_field' }
    {X  'avp$get_field' }

    avk$get_field_description = avk$base + 18,
    {E  'avp$get_field_description' }
    {X  'avp$get_field_description' }

    avk$get_field_names = avk$base + 19,
    {E  'avp$get_field_names' }
    {X  'avp$get_field_names' }

    avk$get_file_utility_info = avk$base + 20,
    {E  'avp$get_file_utility_info' }
    {X  'avp$get_file_utility_info' }

    avk$get_file_utility_info_size = avk$base + 21,
    {E  'avp$get_file_utility_info_size' }
    {X  'avp$get_file_utility_info_size' }

    avk$get_index_record_statistics = avk$base + 22,
    {E  'avp$get_index_record_statistics' }
    {X  'avp$get_index_record_statistics' }

    avk$get_template_file_header = avk$base + 23,
    {E  'avp$get_template_file_header' }
    {X  'avp$get_template_file_header' }

    avk$lock_template_file = avk$base + 24,
    {E  'avp$lock_template_file' }
    {X  'avp$lock_template_file' }

    avk$open_template_file = avk$base + 25,
    {E  'avp$open_template_file' }
    {X  'avp$open_template_file' }

    avk$read_data_record = avk$base + 26,
    {E  'avp$read_data_record' }
    {X  'avp$read_data_record' }

    avk$read_next_data_record = avk$base + 27,
    {E  'avp$read_next_data_record' }
    {X  'avp$read_next_data_record' }

    avk$restore_field = avk$base + 28,
    {E  'avp$restore_field' }
    {X  'avp$restore_field' }

    avk$restructure_template_file = avk$base + 29,
    {E  'avp$restructure_template_file' }
    {X  'avp$restructure_template_file' }

    avk$rewrite_data_record = avk$base + 30,
    {E  'avp$rewrite_data_record' }

    avk$unlock_template_file = avk$base + 31,
    {E  'avp$unlock_template_file' }
    {X  'avp$unlock_template_file' }
    {X  'avp$rewrite_data_record' }

    avk$verify_type_conformance = avk$base + 32;
    {E  'avp$verify_type_conformance' }
    {X  'avp$verify_type_conformance' }

*copyc osk$keypoints

*DECK DECK=AVM$ACCOUNTING_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Accounting Interfaces' ??
MODULE avm$accounting_interfaces;
{
{ PURPOSE:
{   This module contains the interfaces for privileged accounting routines.

?? NEWTITLE := 'Global declarations referenced by this module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc osc$timesharing
*copyc osc$timesharing_terminal_file
*copyc osd$integer_limits
?? POP ??
*copyc avp$begin_account
*copyc clp$get_processing_phase
*copyc jmp$emit_communication_stat
*copyc osp$set_status_abnormal
*copyc pmp$get_job_mode
*copyc jmv$job_attributes
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$begin_job_account', EJECT ??

  PROCEDURE [XDCL, #GATE] avp$begin_job_account
    (    family_name: ost$family_name;
         user_name: ost$user_name;
         account_name: avt$account_name;
         project_name: avt$project_name;
         user_supplied_job_name: ost$name;
         job_class: jmt$job_class;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      processing_phase: clt$processing_phase;

    status.normal := TRUE;

    clp$get_processing_phase (processing_phase, ignore_status);
    IF (processing_phase <> clc$job_begin_phase) THEN
      osp$set_status_abnormal ('AV', cle$unexpected_call_to, 'avp$begin_job_account', status);
      RETURN;
    IFEND;

    avp$begin_account (family_name, user_name, account_name, project_name, user_supplied_job_name, job_class,
          status);

  PROCEND avp$begin_job_account;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$emit_interactive_interval', EJECT ??

{ PURPOSE
{   This procedure is used to emit the interactive interval statistic,
{   when needed by the accounting analysis system.

  PROCEDURE [XDCL, #GATE] avp$emit_interactive_interval;

    VAR
      ignore_status: ost$status,
      job_mode: jmt$job_mode,
      statistic_data: jmt$comm_acct_statistic_data;

    pmp$get_job_mode (job_mode, ignore_status);

    IF job_mode = jmc$interactive_connected THEN
      statistic_data.statistic_id := jmc$ca_interactive_interval;
      jmp$emit_communication_stat (statistic_data);
    IFEND;

  PROCEND avp$emit_interactive_interval;
?? OLDTITLE ??
MODEND avm$accounting_interfaces;
*DECK DECK=AVM$ADMINISTER_VALIDATIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Administer Validations' ??
MODULE avm$administer_validations;
*copyc avc$compile_test_code
?? NEWTITLE := 'Global Declarations referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$condition_codes
*copyc avc$validation_record_names
*copyc ave$admin_validations_errors
*copyc ave$template_file_mgr_errors
*copyc avt$validation_key
*copyc avv$field_kind_names
?? POP ??
*copyc avp$change_account_record
*copyc avp$change_account_member_rec
*copyc avp$change_acct_proj_field
*copyc avp$change_acct_proj_value
*copyc avp$change_accum_limit_field
*copyc avp$change_accum_limit_value
*copyc avp$change_capability_field
*copyc avp$change_capability_value
*copyc avp$change_date_time_field
*copyc avp$change_date_time_value
*copyc avp$change_file_field
*copyc avp$change_file_value
*copyc avp$change_integer_field
*copyc avp$change_integer_value
*copyc avp$change_job_class_field
*copyc avp$change_job_class_value
*copyc avp$change_labeled_names_field
*copyc avp$change_labeled_names_value
*copyc avp$change_limit_field
*copyc avp$change_limit_value
*copyc avp$change_login_password_field
*copyc avp$change_login_password_value
*copyc avp$change_name_field
*copyc avp$change_name_value
*copyc avp$change_project_record
*copyc avp$change_project_member_rec
*copyc avp$change_real_field
*copyc avp$change_real_value
*copyc avp$change_ring_privilege_field
*copyc avp$change_ring_privilege_value
*copyc avp$change_string_field
*copyc avp$change_string_value
*copyc avp$change_user_record
*copyc avp$change_val_field_name
*copyc avp$check_for_served_family
*copyc avp$close_validation_file
*copyc avp$create_account_member_rec
*copyc avp$create_account_record
*copyc avp$create_accum_limit_field
*copyc avp$create_capability_field
*copyc avp$create_date_time_field
*copyc avp$create_file_field
*copyc avp$create_integer_field
*copyc avp$create_limit_field
*copyc avp$create_name_field
*copyc avp$create_project_member_rec
*copyc avp$create_project_record
*copyc avp$create_real_field
*copyc avp$create_string_field
*copyc avp$create_user_record
*copyc avp$delete_account_record
*copyc avp$delete_account_member_rec
*copyc avp$delete_project_record
*copyc avp$delete_project_member_rec
*copyc avp$delete_user_record
*copyc avp$delete_validation_field
*copyc avp$end_subutility_session
*copyc avp$family_administrator
*copyc avp$get_acct_proj_display_value
*copyc avp$get_acct_proj_field_desc
*copyc avp$get_accum_limit_display_val
*copyc avp$get_accum_limit_field_desc
*copyc avp$get_capabil_display_value
*copyc avp$get_capability
*copyc avp$get_capability_field_desc
*copyc avp$get_command_table
*copyc avp$get_date_time_display_value
*copyc avp$get_date_time_field_desc
*copyc avp$get_field_name
*copyc avp$get_file_display_value
*copyc avp$get_file_field_desc
*copyc avp$get_integer_display_value
*copyc avp$get_integer_field_desc
*copyc avp$get_job_class_display_value
*copyc avp$get_job_class_field_desc
*copyc avp$get_labeled_names_dis_value
*copyc avp$get_labeled_names_field_des
*copyc avp$get_limit_display_value
*copyc avp$get_limit_field_desc
*copyc avp$get_login_pw_display_value
*copyc avp$get_login_pw_field_desc
*copyc avp$get_name_display_value
*copyc avp$get_name_field_desc
*copyc avp$get_real_display_value
*copyc avp$get_real_field_desc
*copyc avp$get_ring_priv_display_value
*copyc avp$get_ring_priv_field_desc
*copyc avp$get_string_display_value
*copyc avp$get_string_field_desc
*copyc avp$get_validation_field_kind
*copyc avp$get_validation_field_names
*copyc avp$make_acct_proj_scl_value
*copyc avp$make_accum_limit_scl_value
*copyc avp$make_capability_scl_value
*copyc avp$make_date_time_scl_value
*copyc avp$make_integer_scl_value
*copyc avp$make_job_class_scl_value
*copyc avp$make_labeled_names_scl_valu
*copyc avp$make_limit_scl_value
*copyc avp$make_login_pw_scl_value
*copyc avp$make_name_scl_value
*copyc avp$make_real_scl_value
*copyc avp$make_ring_priv_scl_value
*copyc avp$make_string_scl_value
*copyc avp$open_validation_file
*copyc avp$read_account_member_record
*copyc avp$read_account_record
*copyc avp$read_project_member_record
*copyc avp$read_project_record
*copyc avp$read_user_record
*copyc avp$release_record_id
*copyc avp$restore_validation_field
*copyc avp$system_administrator
*copyc avp$verify_validation_name
*copyc clp$begin_utility
?? NEWTITLE := 'Dummy title' ??
*copyc clp$build_standard_title
*copyc clp$change_pdt
*copyc clp$close_display
*copyc clp$convert_date_time_to_string
*copyc clp$convert_integer_to_string
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_string_to_integer
*copyc clp$convert_string_to_name
*copyc clp$convert_value_to_string
*copyc clp$count_list_elements
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc clp$get_command_origin
*copyc clp$get_path_description
*copyc clp$include_file
*copyc clp$make_list_value
*copyc clp$make_name_value
*copyc clp$make_record_value
*copyc clp$make_unspecified_value
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$new_page_procedure
*copyc clp$only_validate_name
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$trimmed_string_size
*copyc fsp$build_file_ref_from_elems
*copyc fsp$path_element
*copyc jmc$system_family
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_message
*copyc osp$generate_output_message
*copyc osp$set_status_abnormal
*copyc pmp$get_account_project
*copyc pmp$get_default_date_time_form
*copyc pmp$get_family_names
*copyc pmp$get_user_identification
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc sfp$convert_stat_code_to_name
*copyc sfp$convert_stat_name_to_code
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations declared by this module', EJECT ??

{ The following type is used to keep track of information about each ADMINISTER_VALIDATIONS subutility that
{ gets invoked.  The information is kept in a "last in first out" chain.

  TYPE
    avt$subutility_session_info = record
      id: ost$name,
      rewrite_record: boolean,
      key: avt$validation_key,
      previous_account_default: avt$account_name,
      previous_project_default: avt$project_name,
      previous_user_default: ost$user_name,
      validation_record_name: ost$name,
      subutility_name: ost$name,
      subutility_prompt: string (osc$max_name_size),
      previous_session_information: ^avt$subutility_session_info,
    recend;

{ The following constants define the utility names and prompts for ADMINISTER_VALIDATIONS and its
{ subutilities.

  CONST
    avc$admv_utility_name = 'ADMINISTER_VALIDATIONS         ',
    avc$admv_utility_prompt = 'ADMV',
    avc$chaa_utility_name = 'CHANGE_ACCOUNT                 ',
    avc$chaa_utility_prompt = 'CHAA',
    avc$chaam_utility_name = 'CHANGE_ACCOUNT_MEMBER          ',
    avc$chaam_utility_prompt = 'CHAAM',
    avc$chap_utility_name = 'CHANGE_PROJECT                 ',
    avc$chap_utility_prompt = 'CHAP',
    avc$chapm_utility_name = 'CHANGE_PROJECT_MEMBER          ',
    avc$chapm_utility_prompt = 'CHAPM',
    avc$chau_utility_name = 'CHANGE_USER                    ',
    avc$chau_utility_prompt = 'CHAU',
    avc$crea_utility_name = 'CREATE_ACCOUNT                 ',
    avc$crea_utility_prompt = 'CREA',
    avc$cream_utility_name = 'CREATE_ACCOUNT_MEMBER          ',
    avc$cream_utility_prompt = 'CREAM',
    avc$crep_utility_name = 'CREATE_PROJECT                 ',
    avc$crep_utility_prompt = 'CREP',
    avc$crepm_utility_name = 'CREATE_PROJECT_MEMBER          ',
    avc$crepm_utility_prompt = 'CREPM',
    avc$creu_utility_name = 'CREATE_USER                    ',
    avc$creu_utility_prompt = 'CREU',
    avc$manaf_utility_name = 'MANAGE_ACCOUNT_FIELDS          ',
    avc$manaf_utility_prompt = 'MANAF',
    avc$manamf_utility_name = 'MANAGE_ACCOUNT_MEMBER_FIELDS   ',
    avc$manamf_utility_prompt = 'MANAMF',
    avc$manpf_utility_name = 'MANAGE_PROJECT_FIELDS          ',
    avc$manpf_utility_prompt = 'MANPF',
    avc$manpmf_utility_name = 'MANAGE_PROJECT_MEMBER_FIELDS   ',
    avc$manpmf_utility_prompt = 'MANPMF',
    avc$manuf_utility_name = 'MANAGE_USER_FIELDS             ',
    avc$manuf_utility_prompt = 'MANUF';

  VAR
    avv$unlimited_date_time: [STATIC, READ] ost$date_time := [255, 12, 31, 23, 59, 59, 999];

  VAR
    avv$unlimited_time_increment: [STATIC, READ] pmt$time_increment :=
          [osc$max_integer, osc$max_integer, osc$max_integer, osc$max_integer, osc$max_integer,
          osc$max_integer, osc$max_integer];

  VAR
    avv$zero_time_increment: [STATIC, READ] pmt$time_increment := [0, 0, 0, 0, 0, 0, 0];

{ Function table used in ADMV subutilities.

{ table admv_subutil_func_table type=function
{ function ($current_object, $co)                        p=avp$$current_object          a=hidden
{ function ($validation_field_names, $vfn)               p=avp$$validation_field_names  a=hidden
{ function ($validation, $validation_field, $vf)         p=avp$$validation
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  admv_subutil_func_table: [STATIC, READ] ^clt$function_processor_table := ^admv_subutil_func_table_entries,

  admv_subutil_func_table_entries: [STATIC, READ] array [1 .. 7] of clt$function_proc_table_entry := [
  {} ['$CO                            ', clc$abbreviation_entry, clc$hidden_entry, 1, clc$linked_call,
        ^avp$$current_object],
  {} ['$CURRENT_OBJECT                ', clc$nominal_entry, clc$hidden_entry, 1, clc$linked_call,
        ^avp$$current_object],
  {} ['$VALIDATION                    ', clc$nominal_entry, clc$normal_usage_entry, 3, clc$linked_call,
         ^avp$$validation],
  {} ['$VALIDATION_FIELD              ', clc$alias_entry, clc$normal_usage_entry, 3, clc$linked_call,
        ^avp$$validation],
  {} ['$VALIDATION_FIELD_NAMES        ', clc$nominal_entry, clc$hidden_entry, 2, clc$linked_call,
        ^avp$$validation_field_names],
  {} ['$VF                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$linked_call, ^avp$$validation],
  {} ['$VFN                           ', clc$abbreviation_entry, clc$hidden_entry, 2, clc$linked_call,
        ^avp$$validation_field_names]];

?? POP ??

  VAR
    account_administrator: boolean,
    current_subutility_session_info: ^avt$subutility_session_info := NIL,
    default_account: avt$account_name,
    default_project: avt$project_name,
    default_user: ost$user_name,
    executing_account: avt$account_name,
    executing_family: ost$family_name,
    executing_project: avt$project_name,
    executing_user: ost$user_name,
    project_administrator: boolean,
    user_administrator: boolean,
    validation_file_information: avt$template_file_information,
    validation_file_open: boolean := FALSE,
    validation_file_path: fst$path;

*copyc clv$display_variables
?? OLDTITLE ??
?? NEWTITLE := 'avp$administer_validations', EJECT ??

{ PURPOSE:
{   This is the starting point for the ADMINISTER_VALIDATIONS utility.  ADMINISTER_VALIDATIONS is used to
{   create and maintain user, account, account member, project, and project member validations.

  PROCEDURE [XDCL] avp$administer_validations
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
    ?IF avc$compile_test_code THEN
?? POP ??

{ PROCEDURE (osm$admv) administer_validations, admv (
{   validation_level, vl: key
{       (user, u)
{       (account, a)
{       (project, p)
{     keyend = user
{   administrator, a: key
{       (system, s)
{       (family, f)
{       none
{     keyend = family
{   status)

?? PUSH (LISTEXT := ON) ??

      VAR
        pdt: [STATIC, READ, cls$declaration_section] record
          header: clt$pdt_header,
          names: array [1 .. 5] of clt$pdt_parameter_name,
          parameters: array [1 .. 3] of clt$pdt_parameter,
          type1: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 6] of clt$keyword_specification,
            default_value: string (4),
          recend,
          type2: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 5] of clt$keyword_specification,
            default_value: string (6),
          recend,
          type3: record
            header: clt$type_specification_header,
          recend,
        recend := [[1, [88, 4, 21, 13, 55, 13, 534], clc$command, 5, 3, 0, 0, 0, 0, 3, 'OSM$ADMV'],
              [['A                              ', clc$abbreviation_entry, 2],
              ['ADMINISTRATOR                  ', clc$nominal_entry, 2],
              ['STATUS                         ', clc$nominal_entry, 3],
              ['VALIDATION_LEVEL               ', clc$nominal_entry, 1],
              ['VL                             ', clc$abbreviation_entry, 1]], [

{ PARAMETER 1

        [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
              clc$standard_parameter_checking, 229, clc$optional_default_parameter, 0, 4],

{ PARAMETER 2

        [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
              clc$standard_parameter_checking, 192, clc$optional_default_parameter, 0, 6],

{ PARAMETER 3

        [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
              clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

        [[1, 0, clc$keyword_type], [6], [['A                              ', clc$abbreviation_entry,
              clc$normal_usage_entry, 2], ['ACCOUNT                        ', clc$nominal_entry,
              clc$normal_usage_entry, 2], ['P                              ', clc$abbreviation_entry,
              clc$normal_usage_entry, 3], ['PROJECT                        ', clc$nominal_entry,
              clc$normal_usage_entry, 3], ['U                              ', clc$abbreviation_entry,
              clc$normal_usage_entry, 1], ['USER                           ', clc$nominal_entry,
              clc$normal_usage_entry, 1]], 'user'],

{ PARAMETER 2

        [[1, 0, clc$keyword_type], [5], [['F                              ', clc$abbreviation_entry,
              clc$normal_usage_entry, 2], ['FAMILY                         ', clc$nominal_entry,
              clc$normal_usage_entry, 2], ['NONE                           ', clc$nominal_entry,
              clc$normal_usage_entry, 3], ['S                              ', clc$abbreviation_entry,
              clc$normal_usage_entry, 1], ['SYSTEM                         ', clc$nominal_entry,
              clc$normal_usage_entry, 1]], 'family'],

{ PARAMETER 3

        [[1, 0, clc$status_type]]];

?? POP ??

      CONST
        p$validation_level = 1,
        p$administrator = 2,
        p$status = 3;

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

?? PUSH (LISTEXT := ON) ??
    ?ELSE
?? POP ??

{ PROCEDURE (osm$admv) administer_validations, admv (
{   status)

?? PUSH (LISTEXT := ON) ??

      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,
          recend,
        recend := [[1, [88, 4, 21, 13, 56, 4, 303], clc$command, 1, 1, 0, 0, 0, 0, 1, 'OSM$ADMV'],
              [['STATUS                         ', clc$nominal_entry, 1]], [

{ PARAMETER 1

        [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
              clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

        [[1, 0, clc$status_type]]];

?? POP ??

      CONST
        p$status = 1;

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

?? PUSH (LISTEXT := ON) ??
    ?IFEND
?? POP ??
?? EJECT ??

{ The following command table has been manually modified to remove the section and read attributes in order
{ to allow it to be altered at run time.  If the command table is rebuilt, the section and read attributes
{ must be removed.

{ table admv_command_table type=command
{ command (change_account, chaa)                                   p=change_account
{ command (change_account_member, chaam)                           p=change_account_member
{ command (change_default_value, change_default_values, chadv)     p=change_default_values
{ command (change_project, chap)                                   p=change_project
{ command (change_project_member, chapm)                           p=change_project_member
{ command (change_user, chau)                                      p=change_user
{ command (create_account, crea)                                   p=create_account
{ command (create_account_member, cream)                           p=create_account_member
{ command (create_project, crep)                                   p=create_project
{ command (create_project_member, crepm)                           p=create_project_member
{ command (create_user, creu)                                      p=create_user
{ command (delete_account, delete_accounts, dela)                  p=delete_accounts
{ command (delete_account_member, delete_account_members, delam)   p=delete_account_members
{ command (delete_project, delete_projects, delp)                  p=delete_projects
{ command (delete_project_member, delete_project_members, delpm)   p=delete_project_members
{ command (delete_user, delete_users, delu)                        p=delete_users
{ command (display_account, display_accounts, disa)                p=avp$display_account_command
{ command (display_account_member, display_account_members, disam) p=avp$display_acct_member_command
{ command (display_project, display_projects, disp)                p=avp$display_project_command
{ command (display_project_member, display_project_members, dispm) p=avp$display_proj_member_command
{ command (display_user, display_users, disu)                      p=avp$display_user_command
{ command (quit, end_administer_validations, endav, qui)           p=end_administer_validations
{ command (manage_account_fields, manaf)                           p=manage_account_fields
{ command (manage_account_member_fields, manamf)                   p=manage_account_member_fields
{ command (manage_project_fields, manpf)                           p=manage_project_fields
{ command (manage_project_member_fields, manpmf)                   p=manage_project_member_fields
{ command (manage_user_fields, manuf)                              p=manage_user_fields
{ command (use_validation_file, usevf)                             p=use_validation_file l=manual
{ tablend

?? PUSH (LISTEXT := ON) ??

    VAR
      admv_command_table: [STATIC] ^clt$command_table := ^admv_command_table_entries,

      admv_command_table_entries: [STATIC] array [1 .. 69] of clt$command_table_entry := [
            {} ['CHAA                           ', clc$abbreviation_entry, clc$advertised_entry, 1,
            clc$automatically_log, clc$linked_call, ^change_account],
            {} ['CHAAM                          ', clc$abbreviation_entry, clc$advertised_entry, 2,
            clc$automatically_log, clc$linked_call, ^change_account_member],
            {} ['CHADV                          ', clc$abbreviation_entry, clc$advertised_entry, 3,
            clc$automatically_log, clc$linked_call, ^change_default_values],
            {} ['CHANGE_ACCOUNT                 ', clc$nominal_entry, clc$advertised_entry, 1,
            clc$automatically_log, clc$linked_call, ^change_account],
            {} ['CHANGE_ACCOUNT_MEMBER          ', clc$nominal_entry, clc$advertised_entry, 2,
            clc$automatically_log, clc$linked_call, ^change_account_member],
            {} ['CHANGE_DEFAULT_VALUE           ', clc$nominal_entry, clc$advertised_entry, 3,
            clc$automatically_log, clc$linked_call, ^change_default_values],
            {} ['CHANGE_DEFAULT_VALUES          ', clc$alias_entry, clc$advertised_entry, 3,
            clc$automatically_log, clc$linked_call, ^change_default_values],
            {} ['CHANGE_PROJECT                 ', clc$nominal_entry, clc$advertised_entry, 4,
            clc$automatically_log, clc$linked_call, ^change_project],
            {} ['CHANGE_PROJECT_MEMBER          ', clc$nominal_entry, clc$advertised_entry, 5,
            clc$automatically_log, clc$linked_call, ^change_project_member],
            {} ['CHANGE_USER                    ', clc$nominal_entry, clc$advertised_entry, 6,
            clc$automatically_log, clc$linked_call, ^change_user],
            {} ['CHAP                           ', clc$abbreviation_entry, clc$advertised_entry, 4,
            clc$automatically_log, clc$linked_call, ^change_project],
            {} ['CHAPM                          ', clc$abbreviation_entry, clc$advertised_entry, 5,
            clc$automatically_log, clc$linked_call, ^change_project_member],
            {} ['CHAU                           ', clc$abbreviation_entry, clc$advertised_entry, 6,
            clc$automatically_log, clc$linked_call, ^change_user],
            {} ['CREA                           ', clc$abbreviation_entry, clc$advertised_entry, 7,
            clc$automatically_log, clc$linked_call, ^create_account],
            {} ['CREAM                          ', clc$abbreviation_entry, clc$advertised_entry, 8,
            clc$automatically_log, clc$linked_call, ^create_account_member],
            {} ['CREATE_ACCOUNT                 ', clc$nominal_entry, clc$advertised_entry, 7,
            clc$automatically_log, clc$linked_call, ^create_account],
            {} ['CREATE_ACCOUNT_MEMBER          ', clc$nominal_entry, clc$advertised_entry, 8,
            clc$automatically_log, clc$linked_call, ^create_account_member],
            {} ['CREATE_PROJECT                 ', clc$nominal_entry, clc$advertised_entry, 9,
            clc$automatically_log, clc$linked_call, ^create_project],
            {} ['CREATE_PROJECT_MEMBER          ', clc$nominal_entry, clc$advertised_entry, 10,
            clc$automatically_log, clc$linked_call, ^create_project_member],
            {} ['CREATE_USER                    ', clc$nominal_entry, clc$advertised_entry, 11,
            clc$automatically_log, clc$linked_call, ^create_user],
            {} ['CREP                           ', clc$abbreviation_entry, clc$advertised_entry, 9,
            clc$automatically_log, clc$linked_call, ^create_project],
            {} ['CREPM                          ', clc$abbreviation_entry, clc$advertised_entry, 10,
            clc$automatically_log, clc$linked_call, ^create_project_member],
            {} ['CREU                           ', clc$abbreviation_entry, clc$advertised_entry, 11,
            clc$automatically_log, clc$linked_call, ^create_user],
            {} ['DELA                           ', clc$abbreviation_entry, clc$advertised_entry, 12,
            clc$automatically_log, clc$linked_call, ^delete_accounts],
            {} ['DELAM                          ', clc$abbreviation_entry, clc$advertised_entry, 13,
            clc$automatically_log, clc$linked_call, ^delete_account_members],
            {} ['DELETE_ACCOUNT                 ', clc$nominal_entry, clc$advertised_entry, 12,
            clc$automatically_log, clc$linked_call, ^delete_accounts],
            {} ['DELETE_ACCOUNTS                ', clc$alias_entry, clc$advertised_entry, 12,
            clc$automatically_log, clc$linked_call, ^delete_accounts],
            {} ['DELETE_ACCOUNT_MEMBER          ', clc$nominal_entry, clc$advertised_entry, 13,
            clc$automatically_log, clc$linked_call, ^delete_account_members],
            {} ['DELETE_ACCOUNT_MEMBERS         ', clc$alias_entry, clc$advertised_entry, 13,
            clc$automatically_log, clc$linked_call, ^delete_account_members],
            {} ['DELETE_PROJECT                 ', clc$nominal_entry, clc$advertised_entry, 14,
            clc$automatically_log, clc$linked_call, ^delete_projects],
            {} ['DELETE_PROJECTS                ', clc$alias_entry, clc$advertised_entry, 14,
            clc$automatically_log, clc$linked_call, ^delete_projects],
            {} ['DELETE_PROJECT_MEMBER          ', clc$nominal_entry, clc$advertised_entry, 15,
            clc$automatically_log, clc$linked_call, ^delete_project_members],
            {} ['DELETE_PROJECT_MEMBERS         ', clc$alias_entry, clc$advertised_entry, 15,
            clc$automatically_log, clc$linked_call, ^delete_project_members],
            {} ['DELETE_USER                    ', clc$nominal_entry, clc$advertised_entry, 16,
            clc$automatically_log, clc$linked_call, ^delete_users],
            {} ['DELETE_USERS                   ', clc$alias_entry, clc$advertised_entry, 16,
            clc$automatically_log, clc$linked_call, ^delete_users],
            {} ['DELP                           ', clc$abbreviation_entry, clc$advertised_entry, 14,
            clc$automatically_log, clc$linked_call, ^delete_projects],
            {} ['DELPM                          ', clc$abbreviation_entry, clc$advertised_entry, 15,
            clc$automatically_log, clc$linked_call, ^delete_project_members],
            {} ['DELU                           ', clc$abbreviation_entry, clc$advertised_entry, 16,
            clc$automatically_log, clc$linked_call, ^delete_users],
            {} ['DISA                           ', clc$abbreviation_entry, clc$advertised_entry, 17,
            clc$automatically_log, clc$linked_call, ^avp$display_account_command],
            {} ['DISAM                          ', clc$abbreviation_entry, clc$advertised_entry, 18,
            clc$automatically_log, clc$linked_call, ^avp$display_acct_member_command],
            {} ['DISP                           ', clc$abbreviation_entry, clc$advertised_entry, 19,
            clc$automatically_log, clc$linked_call, ^avp$display_project_command],
            {} ['DISPLAY_ACCOUNT                ', clc$nominal_entry, clc$advertised_entry, 17,
            clc$automatically_log, clc$linked_call, ^avp$display_account_command],
            {} ['DISPLAY_ACCOUNTS               ', clc$alias_entry, clc$advertised_entry, 17,
            clc$automatically_log, clc$linked_call, ^avp$display_account_command],
            {} ['DISPLAY_ACCOUNT_MEMBER         ', clc$nominal_entry, clc$advertised_entry, 18,
            clc$automatically_log, clc$linked_call, ^avp$display_acct_member_command],
            {} ['DISPLAY_ACCOUNT_MEMBERS        ', clc$alias_entry, clc$advertised_entry, 18,
            clc$automatically_log, clc$linked_call, ^avp$display_acct_member_command],
            {} ['DISPLAY_PROJECT                ', clc$nominal_entry, clc$advertised_entry, 19,
            clc$automatically_log, clc$linked_call, ^avp$display_project_command],
            {} ['DISPLAY_PROJECTS               ', clc$alias_entry, clc$advertised_entry, 19,
            clc$automatically_log, clc$linked_call, ^avp$display_project_command],
            {} ['DISPLAY_PROJECT_MEMBER         ', clc$nominal_entry, clc$advertised_entry, 20,
            clc$automatically_log, clc$linked_call, ^avp$display_proj_member_command],
            {} ['DISPLAY_PROJECT_MEMBERS        ', clc$alias_entry, clc$advertised_entry, 20,
            clc$automatically_log, clc$linked_call, ^avp$display_proj_member_command],
            {} ['DISPLAY_USER                   ', clc$nominal_entry, clc$advertised_entry, 21,
            clc$automatically_log, clc$linked_call, ^avp$display_user_command],
            {} ['DISPLAY_USERS                  ', clc$alias_entry, clc$advertised_entry, 21,
            clc$automatically_log, clc$linked_call, ^avp$display_user_command],
            {} ['DISPM                          ', clc$abbreviation_entry, clc$advertised_entry, 20,
            clc$automatically_log, clc$linked_call, ^avp$display_proj_member_command],
            {} ['DISU                           ', clc$abbreviation_entry, clc$advertised_entry, 21,
            clc$automatically_log, clc$linked_call, ^avp$display_user_command],
            {} ['ENDAV                          ', clc$alias_entry, clc$advertised_entry, 22,
            clc$automatically_log, clc$linked_call, ^end_administer_validations],
            {} ['END_ADMINISTER_VALIDATIONS     ', clc$alias_entry, clc$advertised_entry, 22,
            clc$automatically_log, clc$linked_call, ^end_administer_validations],
            {} ['MANAF                          ', clc$abbreviation_entry, clc$advertised_entry, 23,
            clc$automatically_log, clc$linked_call, ^manage_account_fields],
            {} ['MANAGE_ACCOUNT_FIELDS          ', clc$nominal_entry, clc$advertised_entry, 23,
            clc$automatically_log, clc$linked_call, ^manage_account_fields],
            {} ['MANAGE_ACCOUNT_MEMBER_FIELDS   ', clc$nominal_entry, clc$advertised_entry, 24,
            clc$automatically_log, clc$linked_call, ^manage_account_member_fields],
            {} ['MANAGE_PROJECT_FIELDS          ', clc$nominal_entry, clc$advertised_entry, 25,
            clc$automatically_log, clc$linked_call, ^manage_project_fields],
            {} ['MANAGE_PROJECT_MEMBER_FIELDS   ', clc$nominal_entry, clc$advertised_entry, 26,
            clc$automatically_log, clc$linked_call, ^manage_project_member_fields],
            {} ['MANAGE_USER_FIELDS             ', clc$nominal_entry, clc$advertised_entry, 27,
            clc$automatically_log, clc$linked_call, ^manage_user_fields],
            {} ['MANAMF                         ', clc$abbreviation_entry, clc$advertised_entry, 24,
            clc$automatically_log, clc$linked_call, ^manage_account_member_fields],
            {} ['MANPF                          ', clc$abbreviation_entry, clc$advertised_entry, 25,
            clc$automatically_log, clc$linked_call, ^manage_project_fields],
            {} ['MANPMF                         ', clc$abbreviation_entry, clc$advertised_entry, 26,
            clc$automatically_log, clc$linked_call, ^manage_project_member_fields],
            {} ['MANUF                          ', clc$abbreviation_entry, clc$advertised_entry, 27,
            clc$automatically_log, clc$linked_call, ^manage_user_fields],
            {} ['QUI                            ', clc$abbreviation_entry, clc$advertised_entry, 22,
            clc$automatically_log, clc$linked_call, ^end_administer_validations],
            {} ['QUIT                           ', clc$nominal_entry, clc$advertised_entry, 22,
            clc$automatically_log, clc$linked_call, ^end_administer_validations],
            {} ['USEVF                          ', clc$abbreviation_entry, clc$advertised_entry, 28,
            clc$manually_log, clc$linked_call, ^use_validation_file],
            {} ['USE_VALIDATION_FILE            ', clc$nominal_entry, clc$advertised_entry, 28,
            clc$manually_log, clc$linked_call, ^use_validation_file]];

?? POP ??

{ table admv_function_table type=function
{ function ($account_list, $al)                                    p=avp$$account_list
{ function ($account_member_list, $aml)                            p=avp$$account_member_list
{ function ($current_default, $cd)                                 p=avp$$current_default      a=hidden
{ function ($family_list, $fl)                                     p=avp$$family_list
{ function ($project_list, $pl)                                    p=avp$$project_list
{ function ($project_member_list, $pml)                            p=avp$$project_member_list
{ function ($user_list, $ul)                                       p=avp$$user_list
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  admv_function_table: [STATIC, READ] ^clt$function_processor_table := ^admv_function_table_entries,

  admv_function_table_entries: [STATIC, READ] array [1 .. 14] of clt$function_proc_table_entry := [
  {} ['$ACCOUNT_LIST                  ', clc$nominal_entry, clc$normal_usage_entry, 1, clc$linked_call,
         ^avp$$account_list],
  {} ['$ACCOUNT_MEMBER_LIST           ', clc$nominal_entry, clc$normal_usage_entry, 2, clc$linked_call,
         ^avp$$account_member_list],
  {} ['$AL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
        clc$linked_call, ^avp$$account_list],
  {} ['$AML                           ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
        clc$linked_call, ^avp$$account_member_list],
  {} ['$CD                            ', clc$abbreviation_entry, clc$hidden_entry, 3, clc$linked_call,
        ^avp$$current_default],
  {} ['$CURRENT_DEFAULT               ', clc$nominal_entry, clc$hidden_entry, 3, clc$linked_call,
        ^avp$$current_default],
  {} ['$FAMILY_LIST                   ', clc$nominal_entry, clc$normal_usage_entry, 4, clc$linked_call,
         ^avp$$family_list],
  {} ['$FL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
        clc$linked_call, ^avp$$family_list],
  {} ['$PL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
        clc$linked_call, ^avp$$project_list],
  {} ['$PML                           ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
        clc$linked_call, ^avp$$project_member_list],
  {} ['$PROJECT_LIST                  ', clc$nominal_entry, clc$normal_usage_entry, 5, clc$linked_call,
         ^avp$$project_list],
  {} ['$PROJECT_MEMBER_LIST           ', clc$nominal_entry, clc$normal_usage_entry, 6, clc$linked_call,
         ^avp$$project_member_list],
  {} ['$UL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
        clc$linked_call, ^avp$$user_list],
  {} ['$USER_LIST                     ', clc$nominal_entry, clc$normal_usage_entry, 7, clc$linked_call,
         ^avp$$user_list]];

?? POP ??

    VAR
      admv_utility_attributes: ^clt$utility_attributes,
      ignore_status: ost$status,
      path: ^array [1 .. * ] of pft$name,
      served_family: boolean,
      user_identification: ost$user_identification,
      validation_file: clt$file;

?? PUSH (LISTEXT := ON) ??
    ?IF avc$compile_test_code THEN
*copyc avt$validation_level

      VAR
        family_administrator: boolean,
        parameter: clt$value,
        system_administrator: boolean,
        validation_level: avt$validation_level;

      PROCEDURE [XREF] initialize
        (    validation_level: avt$validation_level;
             system_admin: boolean;
             family_admin: boolean;
         VAR status: ost$status);

*copyc mmp$delete_scratch_segment
*copyc ost$heap

      VAR
        osv$job_pageable_heap: [XREF] ^ost$heap,
        osv$task_shared_heap: [XREF] ^ost$heap,
        osv$task_private_heap: [XREF] ^ost$heap;
    ?IFEND
?? POP ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that the
{   validation file is closed.

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

      VAR
        ignore_status: ost$status;

      ?IF avc$compile_test_code THEN
        VAR
          segment_pointer: amt$segment_pointer;

        segment_pointer.kind := amc$heap_pointer;
        segment_pointer.heap_pointer := osv$task_private_heap;
        mmp$delete_scratch_segment (segment_pointer, ignore_status);
        segment_pointer.heap_pointer := osv$task_shared_heap;
        mmp$delete_scratch_segment (segment_pointer, ignore_status);
        segment_pointer.heap_pointer := osv$job_pageable_heap;
        mmp$delete_scratch_segment (segment_pointer, ignore_status);
      ?IFEND

      IF validation_file_open THEN
        avp$close_validation_file (validation_file_information, ignore_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'hide_unnecessary_commands', EJECT ??

{ PURPOSE:
{   This procedure is used to hide commands that the user would not be able to use because of the user's
{   authority.
{ NOTES:
{   Any form of the command name may be passed to this routine and all forms of that command will be hidden.

    PROCEDURE hide_unnecessary_commands
      (VAR command_table: ^clt$command_table);

?? NEWTITLE := 'change_command_availability', EJECT ??

{ PURPOSE:
{   This procedure changes the availability entry for the specified command.
{ NOTES:
{   Any form of the command name may be passed to this routine and all forms of that command will be hidden.

      PROCEDURE change_command_availability
        (    command_name: string ( * <= osc$max_name_size);
             availability: clt$named_entry_availability;
         VAR command_table: ^clt$command_table);

        VAR
          command_ordinal: clt$named_entry_ordinal,
          index: integer;

      /find_command_ordinal/
        BEGIN
          FOR index := LOWERBOUND (command_table^) TO UPPERBOUND (command_table^) DO
            IF command_table^ [index].name = command_name THEN
              command_ordinal := command_table^ [index].ordinal;
              EXIT /find_command_ordinal/;
            IFEND;
          FOREND;
          RETURN;
        END /find_command_ordinal/;

        FOR index := LOWERBOUND (command_table^) TO UPPERBOUND (command_table^) DO
          IF command_table^ [index].ordinal = command_ordinal THEN
            command_table^ [index].availability := availability;
          IFEND;
        FOREND;

      PROCEND change_command_availability;
?? OLDTITLE, EJECT ??

{ Hide the commands that the user would not be able to use anyway.

      IF NOT (avp$system_administrator () OR avp$family_administrator ()) THEN
        change_command_availability ('CREATE_ACCOUNT', clc$advanced_usage_entry, command_table);
        change_command_availability ('DELETE_ACCOUNT', clc$advanced_usage_entry, command_table);
        change_command_availability ('MANAGE_ACCOUNT_FIELDS', clc$advanced_usage_entry, command_table);
        change_command_availability ('MANAGE_ACCOUNT_MEMBER_FIELDS', clc$advanced_usage_entry, command_table);
        change_command_availability ('MANAGE_PROJECT_FIELDS', clc$advanced_usage_entry, command_table);
        change_command_availability ('MANAGE_PROJECT_MEMBER_FIELDS', clc$advanced_usage_entry, command_table);
        change_command_availability ('MANAGE_USER_FIELDS', clc$advanced_usage_entry, command_table);
        change_command_availability ('USE_VALIDATION_FILE', clc$advanced_usage_entry, command_table);

        IF NOT user_administrator THEN
          change_command_availability ('CREATE_USER', clc$advanced_usage_entry, command_table);
          change_command_availability ('DELETE_USER', clc$advanced_usage_entry, command_table);
        IFEND;

        IF NOT account_administrator THEN
          change_command_availability ('CHANGE_ACCOUNT', clc$advanced_usage_entry, command_table);
          change_command_availability ('CHANGE_ACCOUNT_MEMBER', clc$advanced_usage_entry, command_table);
          change_command_availability ('CREATE_ACCOUNT_MEMBER', clc$advanced_usage_entry, command_table);
          change_command_availability ('CREATE_PROJECT', clc$advanced_usage_entry, command_table);
          change_command_availability ('DELETE_ACCOUNT_MEMBER', clc$advanced_usage_entry, command_table);
          change_command_availability ('DELETE_PROJECT', clc$advanced_usage_entry, command_table);
          change_command_availability ('DISPLAY_ACCOUNT', clc$advanced_usage_entry, command_table);
          change_command_availability ('DISPLAY_ACCOUNT_MEMBER', clc$advanced_usage_entry, command_table);

          IF NOT project_administrator THEN
            change_command_availability ('CHANGE_DEFAULT_VALUE', clc$advanced_usage_entry, command_table);
            change_command_availability ('CHANGE_PROJECT', clc$advanced_usage_entry, command_table);
            change_command_availability ('CHANGE_PROJECT_MEMBER', clc$advanced_usage_entry, command_table);
            change_command_availability ('CREATE_PROJECT_MEMBER', clc$advanced_usage_entry, command_table);
            change_command_availability ('DELETE_PROJECT_MEMBER', clc$advanced_usage_entry, command_table);
            change_command_availability ('DISPLAY_PROJECT', clc$advanced_usage_entry, command_table);
            change_command_availability ('DISPLAY_PROJECT_MEMBER', clc$advanced_usage_entry, command_table);
          IFEND;
        IFEND;
      IFEND;
    PROCEND hide_unnecessary_commands;
?? OLDTITLE ??
?? NEWTITLE := 'get_executing_user_information', EJECT ??

{ PURPOSE:
{   This procedure is used to retrieve information about the user that is executing ADMINISTER_VALIDATIONS.

    PROCEDURE get_executing_user_information
      (VAR family: ost$family_name;
       VAR user: ost$user_name;
       VAR account: avt$account_name;
       VAR project: avt$project_name;
       VAR account_administrator: boolean;
       VAR project_administrator: boolean;
       VAR user_administrator: boolean;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status,
        user_identification: ost$user_identification;

      status.normal := TRUE;

{ Get executing user's identification.

      pmp$get_user_identification (user_identification, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      family := user_identification.family;
      user := user_identification.user;

      pmp$get_account_project (account, project, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Determine if the user is an account administrator.

      account_administrator := FALSE;
      avp$get_capability (avc$account_administration, avc$account_member, account_administrator,
            ignore_status);

{ Determine if the user is a project administrator.

      project_administrator := FALSE;
      avp$get_capability (avc$project_administration, avc$project_member, project_administrator,
            ignore_status);

{ Determine if the user has user administration capability.

      user_administrator := FALSE;
      avp$get_capability (avc$user_administration, avc$account_member, user_administrator, ignore_status);
      IF NOT user_administrator THEN
        avp$get_capability (avc$user_administration, avc$project_member, user_administrator, ignore_status);
      IFEND;

    PROCEND get_executing_user_information;
?? OLDTITLE ??
?? NEWTITLE := 'open_default_validation_file', EJECT ??

{ PURPOSE:
{   This procedure is used to open the validation file for the family the user is logged into.

    PROCEDURE open_default_validation_file
      (VAR status: ost$status);

      VAR
        default_validation_file: fst$path;

      status.normal := TRUE;

      ?IF avc$compile_test_code THEN
        default_validation_file := '$USER.$VALIDATIONS';
      ?ELSE
        default_validation_file := '$FAMILY.$SYSTEM.$VALIDATIONS';
      ?IFEND

      avp$open_validation_file (default_validation_file, NIL, NIL, FALSE, validation_file_information,
            status);
      IF NOT status.normal THEN
        IF status.condition = ave$must_specify_password THEN

{ If the validation file has a security password and the executing user is a family or system administrator,
{ the security password must be specified to open the validation file.  The family or system administrator
{ must execute the USE_VALIDATON_FILE command, specifying the correct password, in order to open the
{ validation file.

          osp$set_status_abnormal ('AV', ave$must_execute_usevf_cmd, '', status);
        IFEND;
      IFEND;

    PROCEND open_default_validation_file;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

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

    ?IF avc$compile_test_code THEN
      IF pvt [p$validation_level].value^.keyword_value = 'USER' THEN
        validation_level := avc$user_level;
      ELSEIF pvt [p$validation_level].value^.keyword_value = 'ACCOUNT' THEN
        validation_level := avc$account_level;
      ELSE
        validation_level := avc$project_level;
      IFEND;

      IF pvt [p$administrator].value^.keyword_value = 'SYSTEM' THEN
        system_administrator := TRUE;
        family_administrator := FALSE;
      ELSEIF pvt [p$administrator].value^.keyword_value = 'FAMILY' THEN
        system_administrator := FALSE;
        family_administrator := TRUE;
      ELSE
        system_administrator := FALSE;
        family_administrator := FALSE;
      IFEND;

      initialize (validation_level, system_administrator, family_administrator, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ?IFEND
    osp$establish_block_exit_hndlr (^condition_handler);

{ Get executing user's identity and relevent capabilities.

    get_executing_user_information (executing_family, executing_user, executing_account, executing_project,
          account_administrator, project_administrator, user_administrator, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Do not allow ADMINISTER_VALIDATIONS on a file server client.

    avp$check_for_served_family (executing_family, served_family);
    IF served_family THEN
      osp$set_status_abnormal ('AV', ave$not_allowed_on_client, 'ADMINISTER_VALIDATIONS', status);
      RETURN;
    IFEND;

{ Set defaults to executing values.

    default_account := executing_account;
    default_project := executing_project;
    default_user := executing_user;

{ Open the validation file for the family the use is executing on.

    open_default_validation_file (status);
    IF status.normal THEN
      validation_file_open := TRUE;
      #SPOIL (validation_file_open);
    ELSE
      validation_file_open := FALSE;
      #SPOIL (validation_file_open);
      osp$generate_message (status, ignore_status);
      status.normal := TRUE;
    IFEND;

{ Hide the commands that the user is not allowed to use.

    hide_unnecessary_commands (admv_command_table);

{ Start up the ADMV utility.

    PUSH admv_utility_attributes: [1 .. 3];
    admv_utility_attributes^ [1].key := clc$utility_prompt;
    admv_utility_attributes^ [1].prompt.value := avc$admv_utility_prompt;
    admv_utility_attributes^ [1].prompt.size := clp$trimmed_string_size
          (admv_utility_attributes^ [1].prompt.value);
    admv_utility_attributes^ [2].key := clc$utility_command_table;
    admv_utility_attributes^ [2].command_table := admv_command_table;
    admv_utility_attributes^ [3].key := clc$utility_function_proc_table;
    admv_utility_attributes^ [3].function_processor_table := admv_function_table;
    clp$begin_utility (avc$admv_utility_name, admv_utility_attributes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, '', avc$admv_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (avc$admv_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF validation_file_open THEN
      IF NOT status.normal THEN
        avp$close_validation_file (validation_file_information, ignore_status);
      ELSE
        avp$close_validation_file (validation_file_information, status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND avp$administer_validations;
?? OLDTITLE ??
?? NEWTITLE := 'ADMINISTER_VALIDATIONS Subcommand Processors', EJECT ??
?? NEWTITLE := 'change_account', EJECT ??

{ PURPOSE:
{   This procedure initates the CHANGE_ACCOUNT subutility.

  PROCEDURE change_account
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chaa) change_account, chaa (
{   account, a: name = default__31__character__account
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          default_value: string (31),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 10, 12, 10, 3, 131], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMV_CHAA'],
            [['A                              ', clc$abbreviation_entry, 1],
            ['ACCOUNT                        ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 2]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 31],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size], 'default__31__character__account'],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$account = 1,
      p$status = 2;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      command_table_size: integer,
      key: avt$validation_key,
      pdt_changes: ^clt$pdt_changes,
      record_id: ost$name,
      rewrite_record: boolean;

    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the ACCOUNT parameter.

    PUSH pdt_changes: [1 .. 1];
    pdt_changes^ [1].number := p$account;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_account;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

{ Make sure a validation file has been opened.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

    key.account_name := pvt [p$account].value^.name_value;
    key.project_name := osc$null_name;
    key.user_name := osc$null_name;

{ Bring in a copy of the account validation record and set up to start changing
{ validation field values.

    avp$change_account_record (key.account_name, record_id, command_table_size, validation_file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_change_subutility (avc$chaa_utility_name, avc$chaa_utility_prompt, avc$account_record_name, key,
          record_id, command_table_size, rewrite_record, status);

  PROCEND change_account;
?? OLDTITLE ??
?? NEWTITLE := 'change_account_member', EJECT ??

{ PURPOSE:
{   This procedure initates the CHANGE_ACCOUNT_MEMBER subutility.

  PROCEDURE change_account_member
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chaam) change_account_member, chaam (
{   user, u: any of
{       key
{         public
{       keyend
{       name
{     anyend = default___31___character___user
{   account, a: name = default__31__character__account
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] 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$name_type_qualifier,
          recend,
          default_value: string (31),
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          default_value: string (31),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 10, 13, 12, 11, 586], clc$command, 5, 3, 0, 0, 0, 0, 3, 'OSM$ADMV_CHAAM'],
            [['A                              ', clc$abbreviation_entry, 2],
            ['ACCOUNT                        ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3],
            ['U                              ', clc$abbreviation_entry, 1],
            ['USER                           ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 69, clc$optional_default_parameter, 0, 31],

{ PARAMETER 2

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 31],

{ PARAMETER 3

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['PUBLIC                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
            'default___31___character___user'],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size], 'default__31__character__account'],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$user = 1,
      p$account = 2,
      p$status = 3;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      command_table_size: integer,
      key: avt$validation_key,
      pdt_changes: ^clt$pdt_changes,
      record_id: ost$name,
      rewrite_record: boolean;

    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the USER and ACCOUNT parameters.

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$user;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_user;
    pdt_changes^ [2].number := p$account;
    pdt_changes^ [2].kind := clc$pdtc_default_value;
    pdt_changes^ [2].default_value := ^default_account;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

    key.account_name := pvt [p$account].value^.name_value;
    key.project_name := osc$null_name;
    IF pvt [p$user].value^.kind = clc$keyword THEN
      key.user_name := pvt [p$user].value^.keyword_value;
    ELSE
      key.user_name := pvt [p$user].value^.name_value;
    IFEND;

{ Bring in a copy of the account member validation record and set up to start
{ changing validation field values.

    avp$change_account_member_rec (key.account_name, key.user_name, record_id, command_table_size,
          validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_change_subutility (avc$chaam_utility_name, avc$chaam_utility_prompt,
          avc$account_member_record_name, key, record_id, command_table_size, rewrite_record, status);

  PROCEND change_account_member;
?? OLDTITLE ??
?? NEWTITLE := 'change_default_values', EJECT ??

{ PURPOSE:
{   This is the command processor for the CHANGE_DEFAULT_VALUE subcommand.

  PROCEDURE change_default_values
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chadv) change_default_value, chadv (
{   account, a: (BY_NAME) name = $optional
{   project, p: (BY_NAME) name = $optional
{   user, u: (BY_NAME) name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 12, 15, 5, 54, 238], clc$command, 7, 4, 0, 0, 0, 0, 4, 'OSM$ADMV_CHADV'],
            [['A                              ', clc$abbreviation_entry, 1],
            ['ACCOUNT                        ', clc$nominal_entry, 1],
            ['P                              ', clc$abbreviation_entry, 2],
            ['PROJECT                        ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 4],
            ['U                              ', clc$abbreviation_entry, 3],
            ['USER                           ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
            clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
            clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
            clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 3

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$account = 1,
      p$project = 2,
      p$user = 3,
      p$status = 4;

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

    status.normal := TRUE;

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

    IF pvt [p$account].specified THEN
      default_account := pvt [p$account].value^.name_value;
    IFEND;

    IF pvt [p$project].specified THEN
      default_project := pvt [p$project].value^.name_value;
    IFEND;

    IF pvt [p$user].specified THEN
      default_user := pvt [p$user].value^.name_value;
    IFEND;

  PROCEND change_default_values;
?? OLDTITLE ??
?? NEWTITLE := 'change_project', EJECT ??

{ PURPOSE:
{   This procedure initates the CHANGE_PROJECT subutility.

  PROCEDURE change_project
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chap) change_project, chap (
{   project, p: name = default__31__character__project
{   account, a: name = default__31__character__account
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          default_value: string (31),
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          default_value: string (31),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 10, 13, 14, 33, 409], clc$command, 5, 3, 0, 0, 0, 0, 3, 'OSM$ADMV_CHAP'],
            [['A                              ', clc$abbreviation_entry, 2],
            ['ACCOUNT                        ', clc$nominal_entry, 2],
            ['P                              ', clc$abbreviation_entry, 1],
            ['PROJECT                        ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 31],

{ PARAMETER 2

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 31],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size], 'default__31__character__project'],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size], 'default__31__character__account'],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$project = 1,
      p$account = 2,
      p$status = 3;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      command_table_size: integer,
      key: avt$validation_key,
      pdt_changes: ^clt$pdt_changes,
      scription_table,
      record_id: ost$name,
      rewrite_record: boolean;

    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the PROJECT and ACCOUNT parameters.

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$project;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_project;
    pdt_changes^ [2].number := p$account;
    pdt_changes^ [2].kind := clc$pdtc_default_value;
    pdt_changes^ [2].default_value := ^default_account;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

{ Make sure the validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

    key.account_name := pvt [p$account].value^.name_value;
    key.project_name := pvt [p$project].value^.name_value;
    key.user_name := osc$null_name;

{ Bring in a copy of the project validation record and set up to start changing
{ validation field values.

    avp$change_project_record (key.account_name, key.project_name, record_id, command_table_size,
          validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_change_subutility (avc$chap_utility_name, avc$chap_utility_prompt, avc$project_record_name, key,
          record_id, command_table_size, rewrite_record, status);

  PROCEND change_project;
?? OLDTITLE ??
?? NEWTITLE := 'change_project_member', EJECT ??

{ PURPOSE:
{   This procedure initates the CHANGE_PROJECT_MEMBER subutility.

  PROCEDURE change_project_member
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chapm) change_project_member, chapm (
{   user, u: any of
{       key
{         public
{       keyend
{       name
{     anyend = default___31___character___user
{   account, a: name = default__31__character__account
{   project, p: name = default__31__character__project
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] 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$name_type_qualifier,
          recend,
          default_value: string (31),
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          default_value: string (31),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          default_value: string (31),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 10, 13, 17, 24, 338], clc$command, 7, 4, 0, 0, 0, 0, 4, 'OSM$ADMV_CHAPM'],
            [['A                              ', clc$abbreviation_entry, 2],
            ['ACCOUNT                        ', clc$nominal_entry, 2],
            ['P                              ', clc$abbreviation_entry, 3],
            ['PROJECT                        ', clc$nominal_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 4],
            ['U                              ', clc$abbreviation_entry, 1],
            ['USER                           ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 69, clc$optional_default_parameter, 0, 31],

{ PARAMETER 2

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 31],

{ PARAMETER 3

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 31],

{ PARAMETER 4

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['PUBLIC                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
            'default___31___character___user'],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size], 'default__31__character__account'],

{ PARAMETER 3

      [[1, 0, clc$name_type], [1, osc$max_name_size], 'default__31__character__project'],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$user = 1,
      p$account = 2,
      p$project = 3,
      p$status = 4;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      command_table_size: integer,
      key: avt$validation_key,
      pdt_changes: ^clt$pdt_changes,
      record_id: ost$name,
      rewrite_record: boolean;

    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the USER, ACCOUNT and PROJECT parameters.

    PUSH pdt_changes: [1 .. 3];
    pdt_changes^ [1].number := p$user;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_user;
    pdt_changes^ [2].number := p$account;
    pdt_changes^ [2].kind := clc$pdtc_default_value;
    pdt_changes^ [2].default_value := ^default_account;
    pdt_changes^ [3].number := p$project;
    pdt_changes^ [3].kind := clc$pdtc_default_value;
    pdt_changes^ [3].default_value := ^default_project;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

    key.account_name := pvt [p$account].value^.name_value;
    key.project_name := pvt [p$project].value^.name_value;
    IF pvt [p$user].value^.kind = clc$keyword THEN
      key.user_name := pvt [p$user].value^.keyword_value;
    ELSE
      key.user_name := pvt [p$user].value^.name_value;
    IFEND;

{ Bring in a copy of the project member validation record and set up to start
{ changing validation field values.

    avp$change_project_member_rec (key.account_name, key.project_name, key.user_name, record_id,
          command_table_size, validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_change_subutility (avc$chapm_utility_name, avc$chapm_utility_prompt,
          avc$project_member_record_name, key, record_id, command_table_size, rewrite_record, status);

  PROCEND change_project_member;
?? OLDTITLE ??
?? NEWTITLE := 'change_user', EJECT ??

{ PURPOSE:
{   This procedure initates the CHANGE_USER subutility.

  PROCEDURE change_user
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chau) change_user, chau (
{   user, u: name = default___31___character___user
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          default_value: string (31),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 10, 13, 19, 34, 769], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMV_CHAU'],
            [['STATUS                         ', clc$nominal_entry, 2],
            ['U                              ', clc$abbreviation_entry, 1],
            ['USER                           ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 31],

{ PARAMETER 2

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size], 'default___31___character___user'],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$user = 1,
      p$status = 2;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      command_table_size: integer,
      key: avt$validation_key,
      pdt_changes: ^clt$pdt_changes,
      record_id: ost$name,
      rewrite_record: boolean;

    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the USER parameter.

    PUSH pdt_changes: [1 .. 1];
    pdt_changes^ [1].number := p$user;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_user;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

    key.account_name := avc$high_value_name;
    key.project_name := avc$high_value_name;
    key.user_name := pvt [p$user].value^.name_value;

{ Bring in a copy of the user validation record and set up to start changing validation field values.

    avp$change_user_record (key.user_name, record_id, command_table_size, validation_file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_change_subutility (avc$chau_utility_name, avc$chau_utility_prompt, avc$user_record_name, key,
          record_id, command_table_size, rewrite_record, status);

  PROCEND change_user;
?? OLDTITLE ??
?? NEWTITLE := 'create_account', EJECT ??

{ PURPOSE:
{   This procedure initates the CREATE_ACCOUNT subutility.

  PROCEDURE create_account
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_crea) create_account, crea (
{   account, a: (CHECK) name = default__31__character__account
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (31),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 30, 10, 6, 17, 511],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMV_CREA'], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['ACCOUNT                        ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5,
  clc$optional_default_parameter, 0, 31],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'default__31__character__account'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

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

    CONST
      p$account = 1,
      p$status = 2;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      command_table_size: integer,
      ignore_status: ost$status,
      key: avt$validation_key,
      pdt_changes: ^clt$pdt_changes,
      record_id: ost$name,
      rewrite_record: boolean;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
       validation_name: avt$validation_name;

      status.normal := TRUE;

      IF (which_parameter.specific) AND (which_parameter.number = p$account) THEN
        validation_name.kind := avc$vnk_account;
        validation_name.account_name := parameter_value_table^ [p$account].value^.name_value;
        avp$verify_validation_name (validation_name, status);
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the ACCOUNT parameter.

    PUSH pdt_changes: [1 .. 1];
    pdt_changes^ [1].number := p$account;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_account;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, altered_pdt, ^check_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

    key.account_name := pvt [p$account].value^.name_value;
    key.project_name := osc$null_name;
    key.user_name := osc$null_name;

{ Create the account record, bring in a copy of it and set up to start changing
{ validation field values.

    avp$create_account_record (key.account_name, record_id, command_table_size, validation_file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_change_subutility (avc$crea_utility_name, avc$crea_utility_prompt, avc$account_record_name, key,
          record_id, command_table_size, rewrite_record, status);

    IF NOT rewrite_record THEN
      avp$delete_account_record (key.account_name, validation_file_information, ignore_status);
    IFEND;

  PROCEND create_account;
?? OLDTITLE ??
?? NEWTITLE := 'create_account_member', EJECT ??

{ PURPOSE:
{   This procedure initates the CREATE_ACCOUNT_MEMBER subutility.

  PROCEDURE create_account_member
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_cream) create_account_member, cream (
{   user, u: (CHECK) any of
{       key
{         public
{       keyend
{       name
{     anyend = default___31___character___user
{   account, a: (CHECK) name = default__31__character__account
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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$name_type_qualifier,
        recend,
        default_value: string (31),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (31),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 30, 10, 7, 3, 64],
    clc$command, 5, 3, 0, 0, 0, 0, 3, 'OSM$ADMV_CREAM'], [
    ['A                              ',clc$abbreviation_entry, 2],
    ['ACCOUNT                        ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['U                              ',clc$abbreviation_entry, 1],
    ['USER                           ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 69,
  clc$optional_default_parameter, 0, 31],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5,
  clc$optional_default_parameter, 0, 31],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['PUBLIC                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'default___31___character___user'],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'default__31__character__account'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

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

    CONST
      p$user = 1,
      p$account = 2,
      p$status = 3;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      command_table_size: integer,
      ignore_status: ost$status,
      key: avt$validation_key,
      pdt_changes: ^clt$pdt_changes,
      record_id: ost$name,
      rewrite_record: boolean;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
       validation_name: avt$validation_name;

      status.normal := TRUE;

      IF (which_parameter.specific) AND (which_parameter.number = p$account) THEN
        validation_name.kind := avc$vnk_account;
        validation_name.account_name := parameter_value_table^ [p$account].value^.name_value;
        avp$verify_validation_name (validation_name, status);
      IFEND;

      IF (which_parameter.specific) AND (which_parameter.number = p$user) THEN
        validation_name.kind := avc$vnk_user;
        validation_name.user_name := parameter_value_table^ [p$user].value^.name_value;
        avp$verify_validation_name (validation_name, status);
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the USER and ACCOUNT parameters.

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$user;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_user;
    pdt_changes^ [2].number := p$account;
    pdt_changes^ [2].kind := clc$pdtc_default_value;
    pdt_changes^ [2].default_value := ^default_account;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, altered_pdt, ^check_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

    key.account_name := pvt [p$account].value^.name_value;
    key.project_name := osc$null_name;
    IF pvt [p$user].value^.kind = clc$keyword THEN
      key.user_name := pvt [p$user].value^.keyword_value;
    ELSE
      key.user_name := pvt [p$user].value^.name_value;
    IFEND;

{ Create the account member record, bring in a copy of it and set up to start
{ changing validation field values.

    avp$create_account_member_rec (key.account_name, key.user_name, record_id, command_table_size,
          validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_change_subutility (avc$cream_utility_name, avc$cream_utility_prompt,
          avc$account_member_record_name, key, record_id, command_table_size, rewrite_record, status);

    IF NOT rewrite_record THEN
      avp$delete_account_member_rec (key.account_name, key.user_name, validation_file_information,
            ignore_status);
    IFEND;

  PROCEND create_account_member;
?? OLDTITLE ??
?? NEWTITLE := 'create_project', EJECT ??

{ PURPOSE:
{   This procedure initates the CREATE_PROJECT subutility.

  PROCEDURE create_project
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_crep) create_project, crep (
{   project, p: (CHECK) name = default__31__character__project
{   account, a: (CHECK) name = default__31__character__account
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (31),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (31),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 30, 10, 7, 32, 114],
    clc$command, 5, 3, 0, 0, 0, 0, 3, 'OSM$ADMV_CREP'], [
    ['A                              ',clc$abbreviation_entry, 2],
    ['ACCOUNT                        ',clc$nominal_entry, 2],
    ['P                              ',clc$abbreviation_entry, 1],
    ['PROJECT                        ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5,
  clc$optional_default_parameter, 0, 31],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5,
  clc$optional_default_parameter, 0, 31],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'default__31__character__project'],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'default__31__character__account'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

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

    CONST
      p$project = 1,
      p$account = 2,
      p$status = 3;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      command_table_size: integer,
      ignore_status: ost$status,
      interactive: boolean,
      key: avt$validation_key,
      message_status: ost$status,
      pdt_changes: ^clt$pdt_changes,
      record_id: ost$name,
      rewrite_record: boolean;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
       validation_name: avt$validation_name;

      status.normal := TRUE;

      IF (which_parameter.specific) AND (which_parameter.number = p$account) THEN
        validation_name.kind := avc$vnk_account;
        validation_name.account_name := parameter_value_table^ [p$account].value^.name_value;
        avp$verify_validation_name (validation_name, status);
      IFEND;

      IF (which_parameter.specific) AND (which_parameter.number = p$project) THEN
        validation_name.kind := avc$vnk_project;
        validation_name.project_name := parameter_value_table^ [p$project].value^.name_value;
        avp$verify_validation_name (validation_name, status);
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the PROJECT and ACCOUNT parameters.

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$project;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_project;
    pdt_changes^ [2].number := p$account;
    pdt_changes^ [2].kind := clc$pdtc_default_value;
    pdt_changes^ [2].default_value := ^default_account;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, altered_pdt, ^check_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

    key.account_name := pvt [p$account].value^.name_value;
    key.project_name := pvt [p$project].value^.name_value;
    key.user_name := osc$null_name;

{ Create the project record, bring in a copy of it and set up to start
{ changing validation field values.

    avp$create_project_record (key.account_name, key.project_name, record_id, command_table_size,
          validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_change_subutility (avc$crep_utility_name, avc$crep_utility_prompt, avc$project_record_name, key,
          record_id, command_table_size, rewrite_record, status);

    IF NOT rewrite_record THEN
      avp$delete_project_record (key.account_name, key.project_name, validation_file_information,
            ignore_status);
    IFEND;

  PROCEND create_project;
?? OLDTITLE ??
?? NEWTITLE := 'create_project_member', EJECT ??

{ PURPOSE:
{   This procedure initates the CREATE_PROJECT_MEMBER subutility.

  PROCEDURE create_project_member
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_crepm) create_project_member, crepm (
{   user, u: (CHECK) any of
{       key
{         public
{       keyend
{       name
{     anyend = default___31___character___user
{   account, a: (CHECK) name = default__31__character__account
{   project, p: (CHECK) name = default__31__character__project
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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$name_type_qualifier,
        recend,
        default_value: string (31),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (31),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (31),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 30, 10, 8, 11, 421],
    clc$command, 7, 4, 0, 0, 0, 0, 4, 'OSM$ADMV_CREPM'], [
    ['A                              ',clc$abbreviation_entry, 2],
    ['ACCOUNT                        ',clc$nominal_entry, 2],
    ['P                              ',clc$abbreviation_entry, 3],
    ['PROJECT                        ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['U                              ',clc$abbreviation_entry, 1],
    ['USER                           ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 69,
  clc$optional_default_parameter, 0, 31],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5,
  clc$optional_default_parameter, 0, 31],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5,
  clc$optional_default_parameter, 0, 31],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['PUBLIC                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'default___31___character___user'],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'default__31__character__account'],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'default__31__character__project'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

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

    CONST
      p$user = 1,
      p$account = 2,
      p$project = 3,
      p$status = 4;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      command_table_size: integer,
      ignore_status: ost$status,
      key: avt$validation_key,
      pdt_changes: ^clt$pdt_changes,
      record_id: ost$name,
      rewrite_record: boolean;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
       validation_name: avt$validation_name;

      status.normal := TRUE;

      IF (which_parameter.specific) AND (which_parameter.number = p$account) THEN
        validation_name.kind := avc$vnk_account;
        validation_name.account_name := parameter_value_table^ [p$account].value^.name_value;
        avp$verify_validation_name (validation_name, status);
      IFEND;

      IF (which_parameter.specific) AND (which_parameter.number = p$project) THEN
        validation_name.kind := avc$vnk_project;
        validation_name.project_name := parameter_value_table^ [p$project].value^.name_value;
        avp$verify_validation_name (validation_name, status);
      IFEND;

      IF (which_parameter.specific) AND (which_parameter.number = p$user) THEN
        validation_name.kind := avc$vnk_user;
        validation_name.user_name := parameter_value_table^ [p$user].value^.name_value;
        avp$verify_validation_name (validation_name, status);
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the USER, ACCOUNT and PROJECT parameters.

    PUSH pdt_changes: [1 .. 3];
    pdt_changes^ [1].number := p$user;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_user;
    pdt_changes^ [2].number := p$account;
    pdt_changes^ [2].kind := clc$pdtc_default_value;
    pdt_changes^ [2].default_value := ^default_account;
    pdt_changes^ [3].number := p$project;
    pdt_changes^ [3].kind := clc$pdtc_default_value;
    pdt_changes^ [3].default_value := ^default_project;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, altered_pdt, ^check_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

    key.account_name := pvt [p$account].value^.name_value;
    key.project_name := pvt [p$project].value^.name_value;
    IF pvt [p$user].value^.kind = clc$keyword THEN
      key.user_name := pvt [p$user].value^.keyword_value;
    ELSE
      key.user_name := pvt [p$user].value^.name_value;
    IFEND;

{ Create the project member record, bring in a copy of it and set up to start
{ changing validation field values.

    avp$create_project_member_rec (key.account_name, key.project_name, key.user_name, record_id,
          command_table_size, validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_change_subutility (avc$crepm_utility_name, avc$crepm_utility_prompt,
          avc$project_member_record_name, key, record_id, command_table_size, rewrite_record, status);

    IF NOT rewrite_record THEN
      avp$delete_project_member_rec (key.account_name, key.project_name, key.user_name,
            validation_file_information, ignore_status);
    IFEND;

  PROCEND create_project_member;
?? OLDTITLE ??
?? NEWTITLE := 'create_user', EJECT ??

{ PURPOSE:
{   This procedure initates the CREATE_USER subutility.

  PROCEDURE create_user
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_creu) create_user, creu (
{   user, u: (CHECK) name = default___31___character___user
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (31),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 30, 10, 5, 4, 247],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMV_CREU'], [
    ['STATUS                         ',clc$nominal_entry, 2],
    ['U                              ',clc$abbreviation_entry, 1],
    ['USER                           ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5,
  clc$optional_default_parameter, 0, 31],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'default___31___character___user'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

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

    CONST
      p$user = 1,
      p$status = 2;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      command_table_size: integer,
      create_status: ost$status,
      ignore_status: ost$status,
      interactive: boolean,
      key: avt$validation_key,
      pdt_changes: ^clt$pdt_changes,
      record_id: ost$name,
      rewrite_record: boolean;


?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
       validation_name: avt$validation_name;

      status.normal := TRUE;

      IF (which_parameter.specific) AND (which_parameter.number = p$user) THEN
        validation_name.kind := avc$vnk_user;
        validation_name.user_name := parameter_value_table^ [p$user].value^.name_value;
        avp$verify_validation_name (validation_name, status);
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the USER parameter.

    PUSH pdt_changes: [1 .. 1];
    pdt_changes^ [1].number := p$user;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_user;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, altered_pdt, ^check_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

    key.account_name := avc$high_value_name;
    key.project_name := avc$high_value_name;
    key.user_name := pvt [p$user].value^.name_value;

{ Create the user record, bring in a copy of it and set up to start
{ changing validation field values.

    avp$create_user_record (key.user_name, record_id, command_table_size, validation_file_information,
          create_status);
    IF NOT create_status.normal THEN
      IF create_status.condition = ave$master_catalog_exists THEN
        interactive := FALSE;
        clp$get_command_origin (interactive, ignore_status);
        IF interactive THEN
          osp$generate_output_message (create_status, ignore_status);
        IFEND;
      ELSE
        status := create_status;
        RETURN;
      IFEND;
    IFEND;

    create_change_subutility (avc$creu_utility_name, avc$creu_utility_prompt, avc$user_record_name, key,
          record_id, command_table_size, rewrite_record, status);

    IF NOT rewrite_record THEN
      avp$delete_user_record (key.user_name, FALSE, validation_file_information, ignore_status);
    IFEND;

{ Report the status from the create.  This is used report the
{ ave$master_catalog_exists error.

    IF status.normal THEN
      status := create_status;
    IFEND;

  PROCEND create_user;
?? OLDTITLE ??
?? NEWTITLE := 'delete_accounts', EJECT ??

{ PURPOSE:
{   This is the command processor for the DELETE_ACCOUNT subcommand.

  PROCEDURE delete_accounts
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_dela) delete_account, delete_accounts, dela (
{   account, accounts, a: (CHECK) any of
{       key
{         all
{       keyend
{       list of name
{     anyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 4] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 4, 21, 14, 15, 17, 831], clc$command, 4, 2, 1, 0, 0, 0, 2, 'OSM$ADMV_DELA'],
            [['A                              ', clc$abbreviation_entry, 1],
            ['ACCOUNT                        ', clc$nominal_entry, 1],
            ['ACCOUNTS                       ', clc$alias_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 2]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$extended_parameter_checking, 85, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ 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]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$account = 1,
      p$status = 2;

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

    VAR
      account_parameter_value: ^clt$data_value,
      session_info: ^avt$subutility_session_info;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF (which_parameter.specific) AND (which_parameter.number = p$account) THEN
        verify_list_of_names_value ('ACCOUNT', parameter_value_table^ [p$account].value, status);
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

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

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

{ Make sure no subutility is currently active referencing any of the specified accounts.

    session_info := current_subutility_session_info;
    WHILE session_info <> NIL DO
      IF pvt [p$account].value^.kind = clc$list THEN
        account_parameter_value := pvt [p$account].value;
        WHILE account_parameter_value <> NIL DO
          IF account_parameter_value^.element_value^.name_value = session_info^.key.account_name THEN
            osp$set_status_abnormal ('AV', ave$conflicting_operation, session_info^.subutility_name, status);
            RETURN;
          IFEND;
          account_parameter_value := account_parameter_value^.link;
        WHILEND;
      ELSE { keyword ALL was specified}
        IF (session_info^.validation_record_name = avc$account_record_name) OR
              (session_info^.validation_record_name = avc$account_member_record_name) OR
              (session_info^.validation_record_name = avc$project_record_name) OR
              (session_info^.validation_record_name = avc$project_member_record_name) THEN
          osp$set_status_abnormal ('AV', ave$conflicting_operation, session_info^.subutility_name, status);
          RETURN;
        IFEND;
      IFEND;
      session_info := session_info^.previous_session_information;
    WHILEND;

{ Attempt to delete each account in the list.

    account_parameter_value := pvt [p$account].value;
    IF account_parameter_value^.kind = clc$keyword THEN
      avp$delete_account_record (account_parameter_value^.keyword_value, validation_file_information, status);
    ELSE
      REPEAT
        avp$delete_account_record (account_parameter_value^.element_value^.name_value,
              validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        account_parameter_value := account_parameter_value^.link;
      UNTIL account_parameter_value = NIL;
    IFEND;

  PROCEND delete_accounts;
?? OLDTITLE ??
?? NEWTITLE := 'delete_account_members', EJECT ??

{ PURPOSE:
{   This is the command processor for the DELETE_ACCOUNT_MEMBERS subcommand.

  PROCEDURE delete_account_members
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_delam) delete_account_member, delete_account_members, delam (
{   user, users, u: (CHECK) any of
{       key
{         all
{       keyend
{       list of name
{     anyend = $required
{   account, a: name = default__31__character__account
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 6] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          default_value: string (31),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 10, 13, 27, 52, 49], clc$command, 6, 3, 1, 0, 0, 0, 3, 'OSM$ADMV_DELAM'],
            [['A                              ', clc$abbreviation_entry, 2],
            ['ACCOUNT                        ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3],
            ['U                              ', clc$abbreviation_entry, 1],
            ['USER                           ', clc$nominal_entry, 1],
            ['USERS                          ', clc$alias_entry, 1]], [

{ PARAMETER 1

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$extended_parameter_checking, 85, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 31],

{ PARAMETER 3

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ 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]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size], 'default__31__character__account'],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$user = 1,
      p$account = 2,
      p$status = 3;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      pdt_changes: ^clt$pdt_changes,
      session_info: ^avt$subutility_session_info,
      user_parameter_value: ^clt$data_value;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF (which_parameter.specific) AND (which_parameter.number = p$user) THEN
        verify_list_of_names_value ('USER', parameter_value_table^ [p$user].value, status);
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value the ACCOUNT parameter.

    PUSH pdt_changes: [1 .. 1];
    pdt_changes^ [1].number := p$account;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_account;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

{ Make sure no subutility is currently active referencing any of the specified account members.

    session_info := current_subutility_session_info;
    WHILE session_info <> NIL DO
      IF (session_info^.validation_record_name = avc$account_member_record_name) AND
            (session_info^.key.account_name = pvt [p$account].value^.name_value) THEN
        IF pvt [p$user].value^.kind = clc$list THEN
          user_parameter_value := pvt [p$user].value;
          WHILE user_parameter_value <> NIL DO
            IF session_info^.key.user_name = user_parameter_value^.element_value^.name_value THEN
              osp$set_status_abnormal ('AV', ave$conflicting_operation, session_info^.subutility_name,
                    status);
              RETURN;
            IFEND;
            user_parameter_value := user_parameter_value^.link;
          WHILEND;
        ELSE { keyword ALL was specified}
          osp$set_status_abnormal ('AV', ave$conflicting_operation, session_info^.subutility_name, status);
          RETURN;
        IFEND;
      IFEND;
      session_info := session_info^.previous_session_information;
    WHILEND;

{ Attempt to delete each member in the list.

    user_parameter_value := pvt [p$user].value;
    IF user_parameter_value^.kind = clc$keyword THEN
      avp$delete_account_member_rec (pvt [p$account].value^.name_value, user_parameter_value^.keyword_value,
            validation_file_information, status);
    ELSE
      REPEAT
        avp$delete_account_member_rec (pvt [p$account].value^.name_value,
              user_parameter_value^.element_value^.name_value, validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        user_parameter_value := user_parameter_value^.link;
      UNTIL user_parameter_value = NIL;
    IFEND;

  PROCEND delete_account_members;
?? OLDTITLE ??
?? NEWTITLE := 'delete_projects', EJECT ??

{ PURPOSE:
{   This is the command processor for the DELETE_PROJECTS subcommand.

  PROCEDURE delete_projects
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_delp) delete_project, delete_projects, delp (
{   project, projects, p: (CHECK) any of
{       key
{         all
{       keyend
{       list of name
{     anyend = $required
{   account, a: name = default__31__character__account
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 6] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          default_value: string (31),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 10, 13, 29, 24, 572], clc$command, 6, 3, 1, 0, 0, 0, 3, 'OSM$ADMV_DELP'],
            [['A                              ', clc$abbreviation_entry, 2],
            ['ACCOUNT                        ', clc$nominal_entry, 2],
            ['P                              ', clc$abbreviation_entry, 1],
            ['PROJECT                        ', clc$nominal_entry, 1],
            ['PROJECTS                       ', clc$alias_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$extended_parameter_checking, 85, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 31],

{ PARAMETER 3

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ 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]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size], 'default__31__character__account'],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$project = 1,
      p$account = 2,
      p$status = 3;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      pdt_changes: ^clt$pdt_changes,
      project_parameter_value: ^clt$data_value,
      session_info: ^avt$subutility_session_info;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF (which_parameter.specific) AND (which_parameter.number = p$project) THEN
        verify_list_of_names_value ('PROJECT', parameter_value_table^ [p$project].value, status);
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the ACCOUNT parameter.

    PUSH pdt_changes: [1 .. 1];
    pdt_changes^ [1].number := p$account;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_account;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

{ Make sure no subutility is currently active referencing any of the specified projects.

    session_info := current_subutility_session_info;
    WHILE session_info <> NIL DO
      IF ((session_info^.validation_record_name = avc$project_record_name) OR
            (session_info^.validation_record_name = avc$project_member_record_name)) AND
            (session_info^.key.account_name = pvt [p$account].value^.name_value) THEN
        IF pvt [p$project].value^.kind = clc$list THEN
          project_parameter_value := pvt [p$project].value;
          WHILE project_parameter_value <> NIL DO
            IF session_info^.key.project_name = project_parameter_value^.element_value^.name_value THEN
              osp$set_status_abnormal ('AV', ave$conflicting_operation, session_info^.subutility_name,
                    status);
              RETURN;
            IFEND;
            project_parameter_value := project_parameter_value^.link;
          WHILEND;
        ELSE { keyword ALL was specified}
          osp$set_status_abnormal ('AV', ave$conflicting_operation, session_info^.subutility_name, status);
          RETURN;
        IFEND;
      IFEND;
      session_info := session_info^.previous_session_information;
    WHILEND;

{ Attempt to delete each project in the list.

    project_parameter_value := pvt [p$project].value;
    IF project_parameter_value^.kind = clc$keyword THEN
      avp$delete_project_record (pvt [p$account].value^.name_value, project_parameter_value^.keyword_value,
            validation_file_information, status);
    ELSE
      REPEAT
        avp$delete_project_record (pvt [p$account].value^.name_value,
              project_parameter_value^.element_value^.name_value, validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        project_parameter_value := project_parameter_value^.link;
      UNTIL project_parameter_value = NIL;
    IFEND;

  PROCEND delete_projects;
?? OLDTITLE ??
?? NEWTITLE := 'delete_project_members', EJECT ??

{ PURPOSE:
{   This is the command processor for the DELETE_PROJECT_MEMBERS subcommand.

  PROCEDURE delete_project_members
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_delpm) delete_project_member, delete_project_members, delpm (
{   user, users, u: (CHECK) any of
{       key
{         all
{       keyend
{       list of name
{     anyend = $required
{   account, a: name = default__31__character__account
{   project, p: name = default__31__character__project
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 8] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          default_value: string (31),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          default_value: string (31),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 10, 13, 30, 38, 469], clc$command, 8, 4, 1, 0, 0, 0, 4, 'OSM$ADMV_DELPM'],
            [['A                              ', clc$abbreviation_entry, 2],
            ['ACCOUNT                        ', clc$nominal_entry, 2],
            ['P                              ', clc$abbreviation_entry, 3],
            ['PROJECT                        ', clc$nominal_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 4],
            ['U                              ', clc$abbreviation_entry, 1],
            ['USER                           ', clc$nominal_entry, 1],
            ['USERS                          ', clc$alias_entry, 1]], [

{ PARAMETER 1

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$extended_parameter_checking, 85, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 31],

{ PARAMETER 3

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 31],

{ PARAMETER 4

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ 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]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size], 'default__31__character__account'],

{ PARAMETER 3

      [[1, 0, clc$name_type], [1, osc$max_name_size], 'default__31__character__project'],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$user = 1,
      p$account = 2,
      p$project = 3,
      p$status = 4;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      pdt_changes: ^clt$pdt_changes,
      session_info: ^avt$subutility_session_info,
      user_parameter_value: ^clt$data_value;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF (which_parameter.specific) AND (which_parameter.number = p$user) THEN
        verify_list_of_names_value ('USER', parameter_value_table^ [p$user].value, status);
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the ACCOUNT and PROJECT parameters.

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$account;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_account;
    pdt_changes^ [2].number := p$project;
    pdt_changes^ [2].kind := clc$pdtc_default_value;
    pdt_changes^ [2].default_value := ^default_project;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

{ Make sure no subutility is currently active referencing any of the specified project members.

    session_info := current_subutility_session_info;
    WHILE session_info <> NIL DO
      IF (session_info^.validation_record_name = avc$project_member_record_name) AND
            (session_info^.key.account_name = pvt [p$account].value^.name_value) AND
            (session_info^.key.project_name = pvt [p$project].value^.name_value) THEN
        IF pvt [p$user].value^.kind = clc$list THEN
          user_parameter_value := pvt [p$user].value;
          WHILE user_parameter_value <> NIL DO
            IF session_info^.key.user_name = user_parameter_value^.element_value^.name_value THEN
              osp$set_status_abnormal ('AV', ave$conflicting_operation, session_info^.subutility_name,
                    status);
              RETURN;
            IFEND;
            user_parameter_value := user_parameter_value^.link;
          WHILEND;
        ELSE { keyword ALL was specified}
          osp$set_status_abnormal ('AV', ave$conflicting_operation, session_info^.subutility_name, status);
          RETURN;
        IFEND;
      IFEND;
      session_info := session_info^.previous_session_information;
    WHILEND;

{ Attempt to delete each member in the list.

    user_parameter_value := pvt [p$user].value;
    IF user_parameter_value^.kind = clc$keyword THEN
      avp$delete_project_member_rec (pvt [p$account].value^.name_value, pvt [p$project].value^.name_value,
            user_parameter_value^.keyword_value, validation_file_information, status);
    ELSE
      REPEAT
        avp$delete_project_member_rec (pvt [p$account].value^.name_value, pvt [p$project].value^.name_value,
              user_parameter_value^.element_value^.name_value, validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        user_parameter_value := user_parameter_value^.link;
      UNTIL user_parameter_value = NIL;
    IFEND;

  PROCEND delete_project_members;
?? OLDTITLE ??
?? NEWTITLE := 'delete_users', EJECT ??

{ PURPOSE:
{   This is the command processor for the DELETE_USER subcommand.

  PROCEDURE delete_users
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_delu) delete_user, delete_users, delu (
{   user, users, u: (CHECK) list of name = $required
{   delete_files, df: boolean = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC] record
        header: clt$pdt_header,
        names: array [1 .. 6] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 4, 21, 14, 21, 32, 596], clc$command, 6, 3, 2, 0, 0, 0, 3, 'OSM$ADMV_DELU'],
            [['DELETE_FILES                   ', clc$nominal_entry, 2],
            ['DF                             ', clc$abbreviation_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3],
            ['U                              ', clc$abbreviation_entry, 1],
            ['USER                           ', clc$nominal_entry, 1],
            ['USERS                          ', clc$alias_entry, 1]], [

{ PARAMETER 1

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$extended_parameter_checking, 21, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 3

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 2

      [[1, 0, clc$boolean_type]],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$user = 1,
      p$delete_files = 2,
      p$status = 3;

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

    VAR
      session_info: ^avt$subutility_session_info,
      user_parameter_value: ^clt$data_value;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
        user_parameter_value: ^clt$data_value;

      status.normal := TRUE;

      IF (which_parameter.specific) AND (which_parameter.number = p$user) THEN

{ Make sure the user has not specified ALL.

        user_parameter_value := parameter_value_table^ [p$user].value;
        REPEAT
          IF user_parameter_value^.element_value^.name_value = 'ALL' THEN
            osp$set_status_abnormal ('AV', ave$cannot_delete_all, 'users', status);
            RETURN;
          IFEND;
          user_parameter_value := user_parameter_value^.link;
        UNTIL user_parameter_value = NIL;
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

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

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

{ Make sure no subutility is currently active referencing any of the specified users.

    session_info := current_subutility_session_info;
    WHILE session_info <> NIL DO
      IF session_info^.validation_record_name = avc$user_record_name THEN
        user_parameter_value := pvt [p$user].value;
        WHILE user_parameter_value <> NIL DO
          IF session_info^.key.user_name = user_parameter_value^.element_value^.name_value THEN
            osp$set_status_abnormal ('AV', ave$conflicting_operation, session_info^.subutility_name, status);
            RETURN;
          IFEND;
          user_parameter_value := user_parameter_value^.link;
        WHILEND;
      IFEND;
      session_info := session_info^.previous_session_information;
    WHILEND;

{ Attempt to delete each user in the list.

    user_parameter_value := pvt [p$user].value;
    REPEAT
      avp$delete_user_record (user_parameter_value^.element_value^.name_value,
            pvt [p$delete_files].value^.boolean_value.value, validation_file_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      user_parameter_value := user_parameter_value^.link;
    UNTIL user_parameter_value = NIL;

  PROCEND delete_users;
?? OLDTITLE ??
?? NEWTITLE := 'avp$display_account_command', EJECT ??

{ PURPOSE:
{   This is the command processor for the DISPLAY_ACCOUNT subcommand.

  PROCEDURE [XDCL] avp$display_account_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_disa) display_account, display_accounts, disa (
{   account, accounts, a: (CHECK) any of
{       key
{         all
{       keyend
{       list of name
{     anyend = default__31__character__account
{   output, o: file = $output
{   display_option, display_options, do: (BY_NAME, CHECK) any of
{       key
{         all, none
{       keyend
{       list of name
{     anyend = all
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 9] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (31),
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type3: 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 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (3),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 12, 15, 6, 37, 271], clc$command, 9, 4, 0, 0, 0, 0, 4, 'OSM$ADMV_DISA'],
            [['A                              ', clc$abbreviation_entry, 1],
            ['ACCOUNT                        ', clc$nominal_entry, 1],
            ['ACCOUNTS                       ', clc$alias_entry, 1],
            ['DISPLAY_OPTION                 ', clc$nominal_entry, 3],
            ['DISPLAY_OPTIONS                ', clc$alias_entry, 3],
            ['DO                             ', clc$abbreviation_entry, 3],
            ['O                              ', clc$abbreviation_entry, 2],
            ['OUTPUT                         ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$extended_parameter_checking, 85, clc$optional_default_parameter, 0, 31],

{ PARAMETER 2

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 3

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 122,
            clc$optional_default_parameter, 0, 3],

{ PARAMETER 4

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ 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]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            'default__31__character__account'],

{ PARAMETER 2

      [[1, 0, clc$file_type], '$output'],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'all'],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$account = 1,
      p$output = 2,
      p$display_option = 3,
      p$status = 4;

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

?? POP ??

    VAR
      account_parameter_value: ^clt$data_value,
      altered_pdt: ^clt$parameter_description_table,
      assigned_record_id: ost$name,
      display_control: clt$display_control,
      display_option_list: ^avt$name_list,
      display_option_work_area: ^SEQ ( * ),
      file_contents: amt$file_contents,
      ignore_status: ost$status,
      local_account_name: avt$account_name,
      output: clt$value,
      pdt_changes: ^clt$pdt_changes,
      ring_attributes: amt$ring_attributes;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        IF which_parameter.number = p$account THEN
          verify_list_of_names_value ('ACCOUNT', parameter_value_table^ [p$account].value, status);
        ELSEIF which_parameter.number = p$display_option THEN
          verify_list_of_names_value ('DISPLAY_OPTION', parameter_value_table^ [p$display_option].value,
                status);
        ELSE

{ Ignore the parameter.

        IFEND;
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that the output
{   file is closed in case of an abnormal exit.

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

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'currently_changing', EJECT ??

{ PURPOSE:
{   This function is used to determine if the account to be displayed is the
{   object of the currently active ADMINISTER_VALIDATIONS subutility.

    FUNCTION currently_changing
      (    account_name: avt$account_name): boolean;

      currently_changing := (current_subutility_session_info <> NIL) AND
            (current_subutility_session_info^.validation_record_name = avc$account_record_name) AND
            (current_subutility_session_info^.key.account_name = account_name);

    FUNCEND currently_changing;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the ACCOUNT parameter.

    PUSH pdt_changes: [1 .. 1];
    pdt_changes^ [1].number := p$account;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_account;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

{ Get the list of display options and verify that they are valid field names.

    PUSH display_option_work_area: [[REP avc$maximum_field_count OF ost$name]];
    RESET display_option_work_area;
    get_data_record_display_options (avc$account_record_name, pvt [p$display_option].value,
          display_option_work_area, display_option_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Open the output file.

    clv$titles_built := FALSE;
    clv$command_name := 'display_accounts';
    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    file_contents := amc$list;

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, file_contents,
          ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

  /display/
    BEGIN

{ Display the specified accounts.

      IF pvt [p$account].value^.kind = clc$keyword THEN

{ Set up the validation file information so that the next record to be read
{ sequentially from the file will be the first account record.

        validation_file_information.last_key_accessed (1, 31) := osc$null_name {account_name} ;
        validation_file_information.last_key_accessed (32, 31) := osc$null_name {project_name} ;
        validation_file_information.last_key_accessed (63, 31) := osc$null_name {user_name} ;

{ Read the first account record.

        local_account_name := osc$null_name;
        avp$read_account_record (local_account_name, assigned_record_id, validation_file_information, status);
        IF (NOT status.normal) AND (status.condition = ave$end_of_template_file) THEN
          osp$set_status_abnormal ('AV', ave$no_accounts, '', status);
          RETURN;
        IFEND;

{ As long as there are account records, keep displaying them.

        WHILE status.normal DO
          IF currently_changing (local_account_name) THEN

{ Display the record as it appears with the changes so far.

            display_selected_fields (local_account_name, display_option_list, avc$account_record_name,
                  current_subutility_session_info^.id, display_control, status);
          ELSE

{ Display the record as it appears in the validation file.

            display_selected_fields (local_account_name, display_option_list, avc$account_record_name,
                  assigned_record_id, display_control, status);
          IFEND;
          IF NOT status.normal THEN
            EXIT /display/;
          IFEND;

{ Release the space used to hold the account record.

          avp$release_record_id (assigned_record_id, status);
          IF status.normal THEN
            assigned_record_id := osc$null_name;
          ELSE
            EXIT /display/;
          IFEND;

{ Read the next account record.

          local_account_name := osc$null_name;
          avp$read_account_record (local_account_name, assigned_record_id, validation_file_information,
                status);
        WHILEND;
        IF status.condition = ave$end_of_template_file THEN
          status.normal := TRUE;
        IFEND;
      ELSE
        account_parameter_value := pvt [p$account].value;
        REPEAT
          IF currently_changing (account_parameter_value^.element_value^.name_value) THEN

{ Display the record as it appears with the changes so far.

            display_selected_fields (account_parameter_value^.element_value^.name_value, display_option_list,
                  avc$account_record_name, current_subutility_session_info^.id, display_control, status);
          ELSE

{ Read the record from the validation file and display it as it appears on the
{ file.

            local_account_name := account_parameter_value^.element_value^.name_value;
            avp$read_account_record (local_account_name, assigned_record_id, validation_file_information,
                  status);
            IF NOT status.normal THEN
              EXIT /display/;
            IFEND;

            display_selected_fields (local_account_name, display_option_list, avc$account_record_name,
                  assigned_record_id, display_control, status);
            IF NOT status.normal THEN
              EXIT /display/;
            IFEND;

{ Release the space used to hold the account record.

            avp$release_record_id (assigned_record_id, status);
            IF status.normal THEN
              assigned_record_id := osc$null_name;
            ELSE
              EXIT /display/;
            IFEND;
          IFEND;
          account_parameter_value := account_parameter_value^.link;
        UNTIL account_parameter_value = NIL;
      IFEND;
    END /display/;

    IF NOT status.normal THEN
      IF assigned_record_id <> osc$null_name THEN
        avp$release_record_id (assigned_record_id, ignore_status);
      IFEND;
      clp$close_display (display_control, ignore_status);
    ELSE
      clp$close_display (display_control, status);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND avp$display_account_command;
?? OLDTITLE ??
?? NEWTITLE := 'avp$display_acct_member_command', EJECT ??

{ PURPOSE:
{   This is the command processor for the DISPLAY_ACCOUNT_MEMBER subcommand.

  PROCEDURE [XDCL] avp$display_acct_member_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_disam) display_account_member, display_account_members, disam (
{   user, users, u: (CHECK) any of
{       key
{         all
{       keyend
{       list of name
{     anyend = default___31___character___user
{   account, a: name = default__31__character__account
{   output, o: file = $output
{   display_option, display_options, do: (BY_NAME, CHECK) any of
{       key
{         all, none
{       keyend
{       list of name
{     anyend = all
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 11] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (31),
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          default_value: string (31),
        recend,
        type3: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type4: 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 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (3),
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 12, 15, 7, 15, 97], clc$command, 11, 5, 0, 0, 0, 0, 5, 'OSM$ADMV_DISAM'],
            [['A                              ', clc$abbreviation_entry, 2],
            ['ACCOUNT                        ', clc$nominal_entry, 2],
            ['DISPLAY_OPTION                 ', clc$nominal_entry, 4],
            ['DISPLAY_OPTIONS                ', clc$alias_entry, 4],
            ['DO                             ', clc$abbreviation_entry, 4],
            ['O                              ', clc$abbreviation_entry, 3],
            ['OUTPUT                         ', clc$nominal_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 5],
            ['U                              ', clc$abbreviation_entry, 1],
            ['USER                           ', clc$nominal_entry, 1],
            ['USERS                          ', clc$alias_entry, 1]], [

{ PARAMETER 1

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$extended_parameter_checking, 85, clc$optional_default_parameter, 0, 31],

{ PARAMETER 2

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 31],

{ PARAMETER 3

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 4

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 122,
            clc$optional_default_parameter, 0, 3],

{ PARAMETER 5

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ 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]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            'default___31___character___user'],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size], 'default__31__character__account'],

{ PARAMETER 3

      [[1, 0, clc$file_type], '$output'],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'all'],

{ PARAMETER 5

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$user = 1,
      p$account = 2,
      p$output = 3,
      p$display_option = 4,
      p$status = 5;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      assigned_record_id: ost$name,
      display_control: clt$display_control,
      display_option_list: ^avt$name_list,
      display_option_work_area: ^SEQ ( * ),
      file_contents: amt$file_contents,
      ignore_status: ost$status,
      local_account_name: avt$account_name,
      local_member_name: ost$user_name,
      pdt_changes: ^clt$pdt_changes,
      ring_attributes: amt$ring_attributes,
      user_parameter_value: ^clt$data_value;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        IF which_parameter.number = p$user THEN
          verify_list_of_names_value ('USER', parameter_value_table^ [p$user].value, status);
        ELSEIF which_parameter.number = p$display_option THEN
          verify_list_of_names_value ('DISPLAY_OPTION', parameter_value_table^ [p$display_option].value,
                status);
        ELSE

{ Ignore the parameter.

        IFEND;
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that the output
{   file is closed in case of an abnormal exit.

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

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'currently_changing', EJECT ??

{ PURPOSE:
{   This function is used to determine if the account member to be displayed is
{   the object of the currently active ADMINISTER_VALIDATIONS subutility.

    FUNCTION currently_changing
      (    account_name: avt$account_name;
           user_name: ost$user_name): boolean;

      currently_changing := (current_subutility_session_info <> NIL) AND
            (current_subutility_session_info^.validation_record_name = avc$account_member_record_name) AND
            (current_subutility_session_info^.key.account_name = account_name) AND
            (current_subutility_session_info^.key.user_name = user_name);

    FUNCEND currently_changing;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the USER and ACCOUNT parameters.

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$user;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_user;
    pdt_changes^ [2].number := p$account;
    pdt_changes^ [2].kind := clc$pdtc_default_value;
    pdt_changes^ [2].default_value := ^default_account;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

{ Get the list of display options and verify that they are valid field names.

    PUSH display_option_work_area: [[REP avc$maximum_field_count OF ost$name]];
    RESET display_option_work_area;
    get_data_record_display_options (avc$account_member_record_name, pvt [p$display_option].value,
          display_option_work_area, display_option_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Open the output file.

    clv$titles_built := FALSE;
    clv$command_name := 'display_account_members';
    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    file_contents := amc$list;

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, file_contents,
          ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

  /display/
    BEGIN

{ Display the specified account members.

      IF pvt [p$user].value^.kind = clc$keyword THEN

{ Set up the validation file information so that the next record to be read
{ sequentially from the file will be the first account member record for the
{ specified account.

        validation_file_information.last_key_accessed (1, 31) := pvt [p$account].value^.name_value;
        validation_file_information.last_key_accessed (32, 31) := osc$null_name {project_name} ;
        validation_file_information.last_key_accessed (63, 31) := osc$null_name {user_name} ;

{ Read the first account member record.

        local_account_name := pvt [p$account].value^.name_value;
        local_member_name := osc$null_name;
        avp$read_account_member_record (local_account_name, local_member_name, assigned_record_id,
              validation_file_information, status);
        IF ((NOT status.normal) AND (status.condition = ave$end_of_template_file)) OR
              (local_account_name <> pvt [p$account].value^.name_value) THEN
          osp$set_status_abnormal ('AV', ave$no_account_members, pvt [p$account].value^.name_value, status);
          RETURN;
        IFEND;

{ As long as there are account member records, keep displaying them.

        WHILE (status.normal) AND (local_account_name = pvt [p$account].value^.name_value) DO
          IF currently_changing (local_account_name, local_member_name) THEN

{ Display the record as it appears with the changes so far.

            display_selected_fields (local_member_name, display_option_list, avc$account_member_record_name,
                  current_subutility_session_info^.id, display_control, status);
          ELSE

{ Display the record as it appears in the validation file.

            display_selected_fields (local_member_name, display_option_list, avc$account_member_record_name,
                  assigned_record_id, display_control, status);
          IFEND;
          IF NOT status.normal THEN
            EXIT /display/;
          IFEND;

{ Release the space used to hold the account member record.

          avp$release_record_id (assigned_record_id, status);
          IF status.normal THEN
            assigned_record_id := osc$null_name;
          ELSE
            EXIT /display/;
          IFEND;

{ Read the next account member record.

          local_account_name := pvt [p$account].value^.name_value;
          local_member_name := osc$null_name;
          avp$read_account_member_record (local_account_name, local_member_name, assigned_record_id,
                validation_file_information, status);
        WHILEND;
        IF status.condition = ave$end_of_template_file THEN
          status.normal := TRUE;
        IFEND;
      ELSE
        local_account_name := pvt [p$account].value^.name_value;
        user_parameter_value := pvt [p$user].value;
        REPEAT
          local_member_name := user_parameter_value^.element_value^.name_value;
          IF currently_changing (local_account_name, local_member_name) THEN

{ Display the record as it appears with the changes so far.

            display_selected_fields (local_member_name, display_option_list, avc$account_member_record_name,
                  current_subutility_session_info^.id, display_control, status);
          ELSE

{ Read the record from the validation file and display it as it appears on the
{ file.

            avp$read_account_member_record (local_account_name, local_member_name, assigned_record_id,
                  validation_file_information, status);
            IF NOT status.normal THEN
              EXIT /display/;
            IFEND;

            display_selected_fields (local_member_name, display_option_list, avc$account_member_record_name,
                  assigned_record_id, display_control, status);
            IF NOT status.normal THEN
              EXIT /display/;
            IFEND;

{ Release the space used to hold the account member record.

            avp$release_record_id (assigned_record_id, status);
            IF status.normal THEN
              assigned_record_id := osc$null_name;
            ELSE
              EXIT /display/;
            IFEND;
          IFEND;
          user_parameter_value := user_parameter_value^.link;
        UNTIL user_parameter_value = NIL;
      IFEND;
    END /display/;

    IF NOT status.normal THEN
      IF assigned_record_id <> osc$null_name THEN
        avp$release_record_id (assigned_record_id, ignore_status);
      IFEND;
      clp$close_display (display_control, ignore_status);
    ELSE
      clp$close_display (display_control, status);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND avp$display_acct_member_command;
?? OLDTITLE ??
?? NEWTITLE := 'avp$display_project_command', EJECT ??

{ PURPOSE:
{   This is the command processor for the DISPLAY_PROJECT subcommand.

  PROCEDURE [XDCL] avp$display_project_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_disp) display_project, display_projects, disp (
{   project, projects, p: (CHECK) any of
{       key
{         all
{       keyend
{       list of name
{     anyend = default__31__character__project
{   account, a: name = default__31__character__account
{   output, o: file = $output
{   display_option, display_options, do: (BY_NAME, CHECK) any of
{       key
{         all, none
{       keyend
{       list of name
{     anyend = all
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 11] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (31),
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          default_value: string (31),
        recend,
        type3: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type4: 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 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (3),
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 12, 15, 8, 17, 561], clc$command, 11, 5, 0, 0, 0, 0, 5, 'OSM$ADMV_DISP'],
            [['A                              ', clc$abbreviation_entry, 2],
            ['ACCOUNT                        ', clc$nominal_entry, 2],
            ['DISPLAY_OPTION                 ', clc$nominal_entry, 4],
            ['DISPLAY_OPTIONS                ', clc$alias_entry, 4],
            ['DO                             ', clc$abbreviation_entry, 4],
            ['O                              ', clc$abbreviation_entry, 3],
            ['OUTPUT                         ', clc$nominal_entry, 3],
            ['P                              ', clc$abbreviation_entry, 1],
            ['PROJECT                        ', clc$nominal_entry, 1],
            ['PROJECTS                       ', clc$alias_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 5]], [

{ PARAMETER 1

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$extended_parameter_checking, 85, clc$optional_default_parameter, 0, 31],

{ PARAMETER 2

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 31],

{ PARAMETER 3

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 4

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 122,
            clc$optional_default_parameter, 0, 3],

{ PARAMETER 5

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            'default__31__character__project'],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size], 'default__31__character__account'],

{ PARAMETER 3

      [[1, 0, clc$file_type], '$output'],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'all'],

{ PARAMETER 5

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$project = 1,
      p$account = 2,
      p$output = 3,
      p$display_option = 4,
      p$status = 5;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      assigned_record_id: ost$name,
      display_control: clt$display_control,
      display_option_list: ^avt$name_list,
      display_option_work_area: ^SEQ ( * ),
      file_contents: amt$file_contents,
      ignore_status: ost$status,
      local_account_name: avt$account_name,
      local_project_name: avt$project_name,
      pdt_changes: ^clt$pdt_changes,
      project_parameter_value: ^clt$data_value,
      ring_attributes: amt$ring_attributes;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        IF which_parameter.number = p$project THEN
          verify_list_of_names_value ('PROJECT', parameter_value_table^ [p$project].value, status);
        ELSEIF which_parameter.number = p$display_option THEN
          verify_list_of_names_value ('DISPLAY_OPTION', parameter_value_table^ [p$display_option].value,
                status);
        ELSE

{ Ignore the parameter.

        IFEND;
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that the output
{   file is closed in case of an abnormal exit.

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

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'currently_changing', EJECT ??

{ PURPOSE:
{   This function is used to determine if the project to be displayed is
{   the object of the currently active ADMINISTER_VALIDATIONS subutility.

    FUNCTION currently_changing
      (    account_name: avt$account_name;
           project_name: avt$project_name): boolean;

      currently_changing := (current_subutility_session_info <> NIL) AND
            (current_subutility_session_info^.validation_record_name = avc$project_record_name) AND
            (current_subutility_session_info^.key.account_name = account_name) AND
            (current_subutility_session_info^.key.project_name = project_name);

    FUNCEND currently_changing;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the PROJECT and ACCOUNT parameters.

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$project;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_project;
    pdt_changes^ [2].number := p$account;
    pdt_changes^ [2].kind := clc$pdtc_default_value;
    pdt_changes^ [2].default_value := ^default_account;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

{ Get the list of display options and verify that they are valid field names.

    PUSH display_option_work_area: [[REP avc$maximum_field_count OF ost$name]];
    RESET display_option_work_area;
    get_data_record_display_options (avc$project_record_name, pvt [p$display_option].value,
          display_option_work_area, display_option_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Open the output file.

    clv$titles_built := FALSE;
    clv$command_name := 'display_projects';
    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    file_contents := amc$list;

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, file_contents,
          ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

  /display/
    BEGIN

{ Display the specified projects.

      IF pvt [p$project].value^.kind = clc$keyword THEN

{ Set up the validation file information so that the next record to be read
{ sequentially from the file will be the first project record for the
{ specified account.

        validation_file_information.last_key_accessed (1, 31) := pvt [p$account].value^.name_value;
        validation_file_information.last_key_accessed (32, 31) := osc$null_name {project_name} ;
        validation_file_information.last_key_accessed (63, 31) := osc$null_name {user_name} ;

{ Read the first project record.

        local_account_name := pvt [p$account].value^.name_value;
        local_project_name := osc$null_name;
        avp$read_project_record (local_account_name, local_project_name, assigned_record_id,
              validation_file_information, status);
        IF ((NOT status.normal) AND (status.condition = ave$end_of_template_file)) OR
              (local_account_name <> pvt [p$account].value^.name_value) THEN
          osp$set_status_abnormal ('AV', ave$no_projects, pvt [p$account].value^.name_value, status);
          RETURN;
        IFEND;

{ As long as there are project records, keep displaying them.

        WHILE (status.normal) AND (local_account_name = pvt [p$account].value^.name_value) DO
          IF currently_changing (local_account_name, local_project_name) THEN

{ Display the record as it appears with the changes so far.

            display_selected_fields (local_project_name, display_option_list, avc$project_record_name,
                  current_subutility_session_info^.id, display_control, status);
          ELSE

{ Display the record as it appears in the validation file.

            display_selected_fields (local_project_name, display_option_list, avc$project_record_name,
                  assigned_record_id, display_control, status);
          IFEND;
          IF NOT status.normal THEN
            EXIT /display/;
          IFEND;

{ Release the space used to hold the project record.

          avp$release_record_id (assigned_record_id, status);
          IF status.normal THEN
            assigned_record_id := osc$null_name;
          ELSE
            EXIT /display/;
          IFEND;

{ Read the next project record.

          local_account_name := pvt [p$account].value^.name_value;
          local_project_name := osc$null_name;
          avp$read_project_record (local_account_name, local_project_name, assigned_record_id,
                validation_file_information, status);
        WHILEND;
        IF status.condition = ave$end_of_template_file THEN
          status.normal := TRUE;
        IFEND;
      ELSE
        local_account_name := pvt [p$account].value^.name_value;
        project_parameter_value := pvt [p$project].value;
        REPEAT
          local_project_name := project_parameter_value^.element_value^.name_value;
          IF currently_changing (local_account_name, local_project_name) THEN

{ Display the record as it appears with the changes so far.

            display_selected_fields (local_project_name, display_option_list, avc$project_record_name,
                  current_subutility_session_info^.id, display_control, status);
          ELSE

{ Read the record from the validation file and display it as it appears on the
{ file.

            avp$read_project_record (local_account_name, local_project_name, assigned_record_id,
                  validation_file_information, status);
            IF NOT status.normal THEN
              EXIT /display/;
            IFEND;

            display_selected_fields (local_project_name, display_option_list, avc$project_record_name,
                  assigned_record_id, display_control, status);
            IF NOT status.normal THEN
              EXIT /display/;
            IFEND;

{ Release the space used to hold the project record.

            avp$release_record_id (assigned_record_id, status);
            IF status.normal THEN
              assigned_record_id := osc$null_name;
            ELSE
              EXIT /display/;
            IFEND;
          IFEND;
          project_parameter_value := project_parameter_value^.link;
        UNTIL project_parameter_value = NIL;
      IFEND;
    END /display/;

    IF NOT status.normal THEN
      IF assigned_record_id <> osc$null_name THEN
        avp$release_record_id (assigned_record_id, ignore_status);
      IFEND;
      clp$close_display (display_control, ignore_status);
    ELSE
      clp$close_display (display_control, status);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND avp$display_project_command;
?? OLDTITLE ??
?? NEWTITLE := 'avp$display_proj_member_command', EJECT ??

{ PURPOSE:
{   This is the command processor for the DISPLAY_PROJECT_MEMBER subcommand.

  PROCEDURE [XDCL] avp$display_proj_member_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_dispm) display_project_member, display_project_members, dispm (
{   user, users, u: (CHECK) any of
{       key
{         all
{       keyend
{       list of name
{     anyend = default___31___character___user
{   account, a: name = default__31__character__account
{   project, p: name = default__31__character__project
{   output, o: file = $output
{   display_option, display_options, do: (BY_NAME, CHECK) any of
{       key
{         all, none
{       keyend
{       list of name
{     anyend = all
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 13] of clt$pdt_parameter_name,
        parameters: array [1 .. 6] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (31),
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          default_value: string (31),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          default_value: string (31),
        recend,
        type4: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type5: 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 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (3),
        recend,
        type6: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 12, 15, 8, 51, 634], clc$command, 13, 6, 0, 0, 0, 0, 6, 'OSM$ADMV_DISPM'],
            [['A                              ', clc$abbreviation_entry, 2],
            ['ACCOUNT                        ', clc$nominal_entry, 2],
            ['DISPLAY_OPTION                 ', clc$nominal_entry, 5],
            ['DISPLAY_OPTIONS                ', clc$alias_entry, 5],
            ['DO                             ', clc$abbreviation_entry, 5],
            ['O                              ', clc$abbreviation_entry, 4],
            ['OUTPUT                         ', clc$nominal_entry, 4],
            ['P                              ', clc$abbreviation_entry, 3],
            ['PROJECT                        ', clc$nominal_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 6],
            ['U                              ', clc$abbreviation_entry, 1],
            ['USER                           ', clc$nominal_entry, 1],
            ['USERS                          ', clc$alias_entry, 1]], [

{ PARAMETER 1

      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$extended_parameter_checking, 85, clc$optional_default_parameter, 0, 31],

{ PARAMETER 2

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 31],

{ PARAMETER 3

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 31],

{ PARAMETER 4

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 5

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 122,
            clc$optional_default_parameter, 0, 3],

{ PARAMETER 6

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            'default___31___character___user'],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size], 'default__31__character__account'],

{ PARAMETER 3

      [[1, 0, clc$name_type], [1, osc$max_name_size], 'default__31__character__project'],

{ PARAMETER 4

      [[1, 0, clc$file_type], '$output'],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'all'],

{ PARAMETER 6

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$user = 1,
      p$account = 2,
      p$project = 3,
      p$output = 4,
      p$display_option = 5,
      p$status = 6;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      assigned_record_id: ost$name,
      display_control: clt$display_control,
      display_option_list: ^avt$name_list,
      display_option_work_area: ^SEQ ( * ),
      file_contents: amt$file_contents,
      ignore_status: ost$status,
      local_account_name: avt$account_name,
      local_member_name: ost$user_name,
      local_project_name: avt$project_name,
      members_to_display: ^avt$name_list,
      pdt_changes: ^clt$pdt_changes,
      ring_attributes: amt$ring_attributes,
      user_parameter_value: ^clt$data_value;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        IF which_parameter.number = p$user THEN
          verify_list_of_names_value ('USER', parameter_value_table^ [p$user].value, status);
        ELSEIF which_parameter.number = p$display_option THEN
          verify_list_of_names_value ('DISPLAY_OPTION', parameter_value_table^ [p$display_option].value,
                status);
        ELSE

{ Ignore the parameter.

        IFEND;
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that the output
{   file is closed in case of an abnormal exit.

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

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'currently_changing', EJECT ??

{ PURPOSE:
{   This function is used to determine if the project member to be displayed is
{   the object of the currently active ADMINISTER_VALIDATIONS subutility.

    FUNCTION currently_changing
      (    account_name: avt$account_name;
           project_name: avt$project_name;
           user_name: ost$user_name): boolean;

      currently_changing := (current_subutility_session_info <> NIL) AND
            (current_subutility_session_info^.validation_record_name = avc$project_member_record_name) AND
            (current_subutility_session_info^.key.account_name = account_name) AND
            (current_subutility_session_info^.key.project_name = project_name) AND
            (current_subutility_session_info^.key.user_name = user_name);

    FUNCEND currently_changing;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the USER, ACCOUNT and PROJECT parameters.

    PUSH pdt_changes: [1 .. 3];
    pdt_changes^ [1].number := p$user;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_user;
    pdt_changes^ [2].number := p$account;
    pdt_changes^ [2].kind := clc$pdtc_default_value;
    pdt_changes^ [2].default_value := ^default_account;
    pdt_changes^ [3].number := p$project;
    pdt_changes^ [3].kind := clc$pdtc_default_value;
    pdt_changes^ [3].default_value := ^default_project;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

{ Get the list of display options and verify that they are valid field names.

    PUSH display_option_work_area: [[REP avc$maximum_field_count OF ost$name]];
    RESET display_option_work_area;
    get_data_record_display_options (avc$project_member_record_name, pvt [p$display_option].value,
          display_option_work_area, display_option_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Open the output file.

    clv$titles_built := FALSE;
    clv$command_name := 'display_project_members';
    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    file_contents := amc$list;

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, file_contents,
          ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

  /display/
    BEGIN

{ Display the specified project members.

      IF pvt [p$user].value^.kind = clc$keyword THEN

{ Set up the validation file information so that the next record to be read
{ sequentially from the file will be the first project member record for the
{ specified account and project.

        validation_file_information.last_key_accessed (1, 31) := pvt [p$account].value^.name_value;
        validation_file_information.last_key_accessed (32, 31) := pvt [p$project].value^.name_value;
        validation_file_information.last_key_accessed (63, 31) := osc$null_name {user_name} ;

{ Read the first project member record.

        local_account_name := pvt [p$account].value^.name_value;
        local_project_name := pvt [p$project].value^.name_value;
        local_member_name := osc$null_name;
        avp$read_project_member_record (local_account_name, local_project_name, local_member_name,
              assigned_record_id, validation_file_information, status);
        IF ((NOT status.normal) AND (status.condition = ave$end_of_template_file)) OR
              (local_account_name <> pvt [p$account].value^.name_value) OR
              (local_project_name <> pvt [p$project].value^.name_value) THEN
          osp$set_status_abnormal ('AV', ave$no_project_members, pvt [p$project].value^.name_value, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, pvt [p$account].value^.name_value,
                status);
          RETURN;
        IFEND;

{ As long as there are project member records, keep displaying them.

        WHILE (status.normal) AND (local_account_name = pvt [p$account].value^.name_value) AND
              (local_project_name = pvt [p$project].value^.name_value) DO
          IF currently_changing (local_account_name, local_project_name, local_member_name) THEN

{ Display the record as it appears with the changes so far.

            display_selected_fields (local_member_name, display_option_list, avc$project_member_record_name,
                  current_subutility_session_info^.id, display_control, status);
          ELSE

{ Display the record as it appears in the validation file.

            display_selected_fields (local_member_name, display_option_list, avc$project_member_record_name,
                  assigned_record_id, display_control, status);
          IFEND;
          IF NOT status.normal THEN
            EXIT /display/;
          IFEND;

{ Release the space used to hold the project member record.

          avp$release_record_id (assigned_record_id, status);
          IF status.normal THEN
            assigned_record_id := osc$null_name;
          ELSE
            EXIT /display/;
          IFEND;

{ Read the next project member record.

          local_account_name := pvt [p$account].value^.name_value;
          local_project_name := pvt [p$project].value^.name_value;
          local_member_name := osc$null_name;
          avp$read_project_member_record (local_account_name, local_project_name, local_member_name,
                assigned_record_id, validation_file_information, status);
        WHILEND;
        IF status.condition = ave$end_of_template_file THEN
          status.normal := TRUE;
        IFEND;
      ELSE
        local_account_name := pvt [p$account].value^.name_value;
        local_project_name := pvt [p$project].value^.name_value;
        user_parameter_value := pvt [p$user].value;
        REPEAT
          local_member_name := user_parameter_value^.element_value^.name_value;
          IF currently_changing (local_account_name, local_project_name, local_member_name) THEN

{ Display the record as it appears with the changes so far.

            display_selected_fields (local_member_name, display_option_list, avc$project_member_record_name,
                  current_subutility_session_info^.id, display_control, status);
          ELSE

{ Read the record from the validation file and display it as it appears on the
{ file.

            avp$read_project_member_record (local_account_name, local_project_name, local_member_name,
                  assigned_record_id, validation_file_information, status);
            IF NOT status.normal THEN
              EXIT /display/;
            IFEND;

            display_selected_fields (local_member_name, display_option_list, avc$project_member_record_name,
                  assigned_record_id, display_control, status);
            IF NOT status.normal THEN
              EXIT /display/;
            IFEND;

{ Release the space used to hold the project member record.

            avp$release_record_id (assigned_record_id, status);
            IF status.normal THEN
              assigned_record_id := osc$null_name;
            ELSE
              EXIT /display/;
            IFEND;
          IFEND;
          user_parameter_value := user_parameter_value^.link;
        UNTIL user_parameter_value = NIL;
      IFEND;
    END /display/;

    osp$disestablish_cond_handler;

    IF NOT status.normal THEN
      IF assigned_record_id <> osc$null_name THEN
        avp$release_record_id (assigned_record_id, ignore_status);
      IFEND;
      clp$close_display (display_control, ignore_status);
    ELSE
      clp$close_display (display_control, status);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND avp$display_proj_member_command;
?? OLDTITLE ??
?? NEWTITLE := 'avp$display_user_command', EJECT ??

{ PURPOSE:
{   This is the command processor for the DISPLAY_USER subcommand.

  PROCEDURE [XDCL] avp$display_user_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_disu) display_user, display_users, disu (
{   user, users, u: (CHECK) any of
{       key
{         all
{       keyend
{       list of name
{     anyend = default___31___character___user
{   output, o: file = $output
{   display_option, display_options, do: (BY_NAME, CHECK) any of
{       key
{         all, none
{       keyend
{       list of name
{     anyend = all
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 9] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (31),
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type3: 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 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (3),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 12, 15, 9, 26, 652], clc$command, 9, 4, 0, 0, 0, 0, 4, 'OSM$ADMV_DISU'],
            [['DISPLAY_OPTION                 ', clc$nominal_entry, 3],
            ['DISPLAY_OPTIONS                ', clc$alias_entry, 3],
            ['DO                             ', clc$abbreviation_entry, 3],
            ['O                              ', clc$abbreviation_entry, 2],
            ['OUTPUT                         ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 4],
            ['U                              ', clc$abbreviation_entry, 1],
            ['USER                           ', clc$nominal_entry, 1],
            ['USERS                          ', clc$alias_entry, 1]], [

{ PARAMETER 1

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$extended_parameter_checking, 85, clc$optional_default_parameter, 0, 31],

{ PARAMETER 2

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 3

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 122,
            clc$optional_default_parameter, 0, 3],

{ PARAMETER 4

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ 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]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            'default___31___character___user'],

{ PARAMETER 2

      [[1, 0, clc$file_type], '$output'],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'all'],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$user = 1,
      p$output = 2,
      p$display_option = 3,
      p$status = 4;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      assigned_record_id: ost$name,
      display_control: clt$display_control,
      display_option_list: ^avt$name_list,
      display_option_work_area: ^SEQ ( * ),
      file_contents: amt$file_contents,
      ignore_status: ost$status,
      local_user_name: ost$user_name,
      pdt_changes: ^clt$pdt_changes,
      ring_attributes: amt$ring_attributes,
      user_parameter_value: ^clt$data_value;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF (which_parameter.specific) AND (which_parameter.number = p$user) THEN
        verify_list_of_names_value ('USER', parameter_value_table^ [p$user].value, status);
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that the output
{   file is closed in case of an abnormal exit.

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

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'currently_changing', EJECT ??

{ PURPOSE:
{   This function is used to determine if the user to be displayed is the
{   object of the currently active ADMINISTER_VALIDATIONS subutility.

    FUNCTION currently_changing
      (    user_name: ost$user_name): boolean;

      currently_changing := (current_subutility_session_info <> NIL) AND
            (current_subutility_session_info^.validation_record_name = avc$user_record_name) AND
            (current_subutility_session_info^.key.user_name = user_name);

    FUNCEND currently_changing;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the USER parameter.

    PUSH pdt_changes: [1 .. 1];
    pdt_changes^ [1].number := p$user;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_user;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

{ Get the list of display options and verify that they are valid field names.

    PUSH display_option_work_area: [[REP avc$maximum_field_count OF ost$name]];
    RESET display_option_work_area;
    get_data_record_display_options (avc$user_record_name, pvt [p$display_option].value,
          display_option_work_area, display_option_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Open the output file.

    clv$titles_built := FALSE;
    clv$command_name := 'display_users';
    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    file_contents := amc$list;

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, file_contents,
          ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

  /display/
    BEGIN

{ Display the specified users.

      IF pvt [p$user].value^.kind = clc$keyword THEN

{ Set up the validation file information so that the next record to be read
{ sequentially from the file will be the first user record.

        validation_file_information.last_key_accessed (1, 31) := avc$high_value_name {account_name} ;
        validation_file_information.last_key_accessed (32, 31) := avc$high_value_name {project_name} ;
        validation_file_information.last_key_accessed (63, 31) := osc$null_name {user_name} ;

{ Read user records starting with the first one until a user record that can be displayed is found.

        REPEAT
          local_user_name := osc$null_name;
          avp$read_user_record (local_user_name, assigned_record_id, validation_file_information, status);
        UNTIL (status.normal) OR (status.condition <> ave$insufficient_authority);

{ As long as there are user records, keep displaying them.

        WHILE status.normal DO
          IF currently_changing (local_user_name) THEN

{ Display the record as it appears with the changes so far.

            display_selected_fields (local_user_name, display_option_list, avc$user_record_name,
                  current_subutility_session_info^.id, display_control, status);
          ELSE

{ Display the record as it appears in the validation file.

            display_selected_fields (local_user_name, display_option_list, avc$user_record_name,
                  assigned_record_id, display_control, status);
          IFEND;
          IF NOT status.normal THEN
            EXIT /display/;
          IFEND;

{ Release the space used to hold the user record.

          avp$release_record_id (assigned_record_id, status);
          IF status.normal THEN
            assigned_record_id := osc$null_name;
          ELSE
            EXIT /display/;
          IFEND;

{ Read user records until the next one that can be displayed is found.

          REPEAT
            local_user_name := osc$null_name;
            avp$read_user_record (local_user_name, assigned_record_id, validation_file_information, status);
          UNTIL (status.normal) OR (status.condition <> ave$insufficient_authority);
        WHILEND;
        IF status.condition = ave$end_of_template_file THEN
          status.normal := TRUE;
        IFEND;
      ELSE
        user_parameter_value := pvt [p$user].value;
        REPEAT
          local_user_name := user_parameter_value^.element_value^.name_value;
          IF currently_changing (local_user_name) THEN

{ Display the record as it appears with the changes so far.

            display_selected_fields (local_user_name, display_option_list, avc$user_record_name,
                  current_subutility_session_info^.id, display_control, status);
          ELSE

{ Read the record from the validation file and display it as it appears on the
{ file.

            avp$read_user_record (local_user_name, assigned_record_id, validation_file_information, status);
            IF NOT status.normal THEN
              EXIT /display/;
            IFEND;

            display_selected_fields (local_user_name, display_option_list, avc$user_record_name,
                  assigned_record_id, display_control, status);
            IF NOT status.normal THEN
              EXIT /display/;
            IFEND;

{ Release the space used to hold the user record.

            avp$release_record_id (assigned_record_id, status);
            IF status.normal THEN
              assigned_record_id := osc$null_name;
            ELSE
              EXIT /display/;
            IFEND;
          IFEND;
          user_parameter_value := user_parameter_value^.link;
        UNTIL user_parameter_value = NIL;
      IFEND;
    END /display/;

    osp$disestablish_cond_handler;

    IF NOT status.normal THEN
      IF assigned_record_id <> osc$null_name THEN
        avp$release_record_id (assigned_record_id, ignore_status);
      IFEND;
      clp$close_display (display_control, ignore_status);
    ELSE
      clp$close_display (display_control, status);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND avp$display_user_command;
?? OLDTITLE ??
?? NEWTITLE := 'end_administer_validations', EJECT ??

{ PURPOSE:
{   This is the command processor for the END_ADMINISTER_VALIDATIONS subcommand.

  PROCEDURE end_administer_validations
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_endav) end_administer_validations, quit, qui, endav

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [88, 5, 13, 21, 49, 44, 706], clc$command, 0, 0, 0, 0, 0, 0, 0, 'OSM$ADMV_ENDAV']];

?? POP ??

    status.normal := TRUE;

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

    clp$end_include (avc$admv_utility_name, status);

  PROCEND end_administer_validations;
?? OLDTITLE ??
?? NEWTITLE := 'manage_account_fields', EJECT ??

{ PURPOSE:
{   This procedure initiates the MANAGE_ACCOUNT_FIELDS subutility.

  PROCEDURE manage_account_fields
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_manaf) manage_account_fields, manaf (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 4, 21, 14, 23, 17, 644], clc$command, 1, 1, 0, 0, 0, 0, 1, 'OSM$ADMV_MANAF'],
            [['STATUS                         ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

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

{ table manaf_command_table type=command
{ command (change_accumulating_limit_field, chaalf)                      p=change_accumulating_limit_field
{ command (change_capability_field, chacf)                               p=change_capability_field
{ command (change_date_time_field, chadtf)                               p=change_date_time_field
{ command (change_field_name, chafn)                                     p=change_field_name
{ command (change_file_field, chaff)                                     p=change_file_field
{ command (change_integer_field, chaif)                                  p=change_integer_field
{ command (change_limit_field, chalf)                                    p=change_limit_field
{ command (change_name_field, chanf)                                     p=change_name_field
{ command (change_real_field, charf)                                     p=change_real_field
{ command (change_string_field, chasf)                                   p=change_string_field
{ command (create_accumulating_limit_field, crealf)                      p=create_accumulating_limit_field
{ command (create_capability_field, crecf)                               p=create_capability_field
{ command (create_date_time_field, credtf)                               p=create_date_time_field
{ command (create_file_field, creff)                                     p=create_file_field
{ command (create_integer_field, creif)                                  p=create_integer_field
{ command (create_limit_field, crelf)                                    p=create_limit_field
{ command (create_name_field, crenf)                                     p=create_name_field
{ command (create_real_field, crerf)                                     p=create_real_field
{ command (create_string_field, cresf)                                   p=create_string_field
{ command (delete_field, delf)                                           p=delete_field
{ command (display_field_description, display_field_descriptions, disfd) p=avp$display_field_description
{ command (display_field_names, disfn)                                   p=avp$display_field_names
{ command (end_manage_account_fields, quit, qui, endmaf)                 p=end_manage_subutility
{ command (restore_field, resf)                                          p=restore_field
{ tablend

?? PUSH (LISTEXT := ON) ??

    VAR
      manaf_command_table: [STATIC, READ] ^clt$command_table := ^manaf_command_table_entries,

      manaf_command_table_entries: [STATIC, READ] array [1 .. 51] of clt$command_table_entry := [
            {} ['CHAALF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^change_accumulating_limit_field],
            {} ['CHACF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^change_capability_field],
            {} ['CHADTF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^change_date_time_field],
            {} ['CHAFF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^change_file_field],
            {} ['CHAFN                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^change_field_name],
            {} ['CHAIF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^change_integer_field],
            {} ['CHALF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^change_limit_field],
            {} ['CHANF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
            clc$automatically_log, clc$linked_call, ^change_name_field],
            {} ['CHANGE_ACCUMULATING_LIMIT_FIELD', clc$nominal_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^change_accumulating_limit_field],
            {} ['CHANGE_CAPABILITY_FIELD        ', clc$nominal_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^change_capability_field],
            {} ['CHANGE_DATE_TIME_FIELD         ', clc$nominal_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^change_date_time_field],
            {} ['CHANGE_FIELD_NAME              ', clc$nominal_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^change_field_name],
            {} ['CHANGE_FILE_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^change_file_field],
            {} ['CHANGE_INTEGER_FIELD           ', clc$nominal_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^change_integer_field],
            {} ['CHANGE_LIMIT_FIELD             ', clc$nominal_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^change_limit_field],
            {} ['CHANGE_NAME_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 8,
            clc$automatically_log, clc$linked_call, ^change_name_field],
            {} ['CHANGE_REAL_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 9,
            clc$automatically_log, clc$linked_call, ^change_real_field],
            {} ['CHANGE_STRING_FIELD            ', clc$nominal_entry, clc$normal_usage_entry, 10,
            clc$automatically_log, clc$linked_call, ^change_string_field],
            {} ['CHARF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
            clc$automatically_log, clc$linked_call, ^change_real_field],
            {} ['CHASF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
            clc$automatically_log, clc$linked_call, ^change_string_field],
            {} ['CREALF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 11,
            clc$automatically_log, clc$linked_call, ^create_accumulating_limit_field],
            {} ['CREATE_ACCUMULATING_LIMIT_FIELD', clc$nominal_entry, clc$normal_usage_entry, 11,
            clc$automatically_log, clc$linked_call, ^create_accumulating_limit_field],
            {} ['CREATE_CAPABILITY_FIELD        ', clc$nominal_entry, clc$normal_usage_entry, 12,
            clc$automatically_log, clc$linked_call, ^create_capability_field],
            {} ['CREATE_DATE_TIME_FIELD         ', clc$nominal_entry, clc$normal_usage_entry, 13,
            clc$automatically_log, clc$linked_call, ^create_date_time_field],
            {} ['CREATE_FILE_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 14,
            clc$automatically_log, clc$linked_call, ^create_file_field],
            {} ['CREATE_INTEGER_FIELD           ', clc$nominal_entry, clc$normal_usage_entry, 15,
            clc$automatically_log, clc$linked_call, ^create_integer_field],
            {} ['CREATE_LIMIT_FIELD             ', clc$nominal_entry, clc$normal_usage_entry, 16,
            clc$automatically_log, clc$linked_call, ^create_limit_field],
            {} ['CREATE_NAME_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 17,
            clc$automatically_log, clc$linked_call, ^create_name_field],
            {} ['CREATE_REAL_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 18,
            clc$automatically_log, clc$linked_call, ^create_real_field],
            {} ['CREATE_STRING_FIELD            ', clc$nominal_entry, clc$normal_usage_entry, 19,
            clc$automatically_log, clc$linked_call, ^create_string_field],
            {} ['CRECF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
            clc$automatically_log, clc$linked_call, ^create_capability_field],
            {} ['CREDTF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 13,
            clc$automatically_log, clc$linked_call, ^create_date_time_field],
            {} ['CREFF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 14,
            clc$automatically_log, clc$linked_call, ^create_file_field],
            {} ['CREIF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 15,
            clc$automatically_log, clc$linked_call, ^create_integer_field],
            {} ['CRELF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 16,
            clc$automatically_log, clc$linked_call, ^create_limit_field],
            {} ['CRENF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 17,
            clc$automatically_log, clc$linked_call, ^create_name_field],
            {} ['CRERF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 18,
            clc$automatically_log, clc$linked_call, ^create_real_field],
            {} ['CRESF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 19,
            clc$automatically_log, clc$linked_call, ^create_string_field],
            {} ['DELETE_FIELD                   ', clc$nominal_entry, clc$normal_usage_entry, 20,
            clc$automatically_log, clc$linked_call, ^delete_field],
            {} ['DELF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 20,
            clc$automatically_log, clc$linked_call, ^delete_field],
            {} ['DISFD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 21,
            clc$automatically_log, clc$linked_call, ^avp$display_field_description],
            {} ['DISFN                          ', clc$abbreviation_entry, clc$normal_usage_entry, 22,
            clc$automatically_log, clc$linked_call, ^avp$display_field_names],
            {} ['DISPLAY_FIELD_DESCRIPTION      ', clc$nominal_entry, clc$normal_usage_entry, 21,
            clc$automatically_log, clc$linked_call, ^avp$display_field_description],
            {} ['DISPLAY_FIELD_DESCRIPTIONS     ', clc$alias_entry, clc$normal_usage_entry, 21,
            clc$automatically_log, clc$linked_call, ^avp$display_field_description],
            {} ['DISPLAY_FIELD_NAMES            ', clc$nominal_entry, clc$normal_usage_entry, 22,
            clc$automatically_log, clc$linked_call, ^avp$display_field_names],
            {} ['ENDMAF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^end_manage_subutility],
            {} ['END_MANAGE_ACCOUNT_FIELDS      ', clc$nominal_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^end_manage_subutility],
            {} ['QUI                            ', clc$alias_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^end_manage_subutility],
            {} ['QUIT                           ', clc$alias_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^end_manage_subutility],
            {} ['RESF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 24,
            clc$automatically_log, clc$linked_call, ^restore_field],
            {} ['RESTORE_FIELD                  ', clc$nominal_entry, clc$normal_usage_entry, 24,
            clc$automatically_log, clc$linked_call, ^restore_field]];

?? POP ??

    status.normal := TRUE;

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

    manage_fields_subutility (avc$manaf_utility_name, avc$manaf_utility_prompt, avc$account_record_name,
          manaf_command_table, status);

  PROCEND manage_account_fields;
?? OLDTITLE ??
?? NEWTITLE := 'manage_account_member_fields', EJECT ??

{ PURPOSE:
{   This procedure initiates the MANAGE_ACCOUNT_MEMBER_FIELDS subutility.

  PROCEDURE manage_account_member_fields
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_manamf) manage_account_member_fields, manamf (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 4, 21, 14, 24, 4, 144], clc$command, 1, 1, 0, 0, 0, 0, 1, 'OSM$ADMV_MANAMF'],
            [['STATUS                         ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

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

{ table manamf_command_table type=command
{ command (change_accumulating_limit_field, chaalf)                      p=change_accumulating_limit_field
{ command (change_capability_field, chacf)                               p=change_capability_field
{ command (change_date_time_field, chadtf)                               p=change_date_time_field
{ command (change_field_name, chafn)                                     p=change_field_name
{ command (change_file_field, chaff)                                     p=change_file_field
{ command (change_integer_field, chaif)                                  p=change_integer_field
{ command (change_limit_field, chalf)                                    p=change_limit_field
{ command (change_name_field, chanf)                                     p=change_name_field
{ command (change_real_field, charf)                                     p=change_real_field
{ command (change_string_field, chasf)                                   p=change_string_field
{ command (create_accumulating_limit_field, crealf)                      p=create_accumulating_limit_field
{ command (create_capability_field, crecf)                               p=create_capability_field
{ command (create_date_time_field, credtf)                               p=create_date_time_field
{ command (create_file_field, creff)                                     p=create_file_field
{ command (create_integer_field, creif)                                  p=create_integer_field
{ command (create_limit_field, crelf)                                    p=create_limit_field
{ command (create_name_field, crenf)                                     p=create_name_field
{ command (create_real_field, crerf)                                     p=create_real_field
{ command (create_string_field, cresf)                                   p=create_string_field
{ command (delete_field, delf)                                           p=delete_field
{ command (display_field_description, display_field_descriptions, disfd) p=avp$display_field_description
{ command (display_field_names, disfn)                                   p=avp$display_field_names
{ command (end_manage_acct_member_fields, quit, qui, endmamf)            p=end_manage_subutility
{ command (restore_field, resf)                                          p=restore_field
{ tablend

?? PUSH (LISTEXT := ON) ??

    VAR
      manamf_command_table: [STATIC, READ] ^clt$command_table := ^manamf_command_table_entries,

      manamf_command_table_entries: [STATIC, READ] array [1 .. 51] of clt$command_table_entry := [
            {} ['CHAALF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^change_accumulating_limit_field],
            {} ['CHACF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^change_capability_field],
            {} ['CHADTF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^change_date_time_field],
            {} ['CHAFF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^change_file_field],
            {} ['CHAFN                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^change_field_name],
            {} ['CHAIF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^change_integer_field],
            {} ['CHALF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^change_limit_field],
            {} ['CHANF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
            clc$automatically_log, clc$linked_call, ^change_name_field],
            {} ['CHANGE_ACCUMULATING_LIMIT_FIELD', clc$nominal_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^change_accumulating_limit_field],
            {} ['CHANGE_CAPABILITY_FIELD        ', clc$nominal_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^change_capability_field],
            {} ['CHANGE_DATE_TIME_FIELD         ', clc$nominal_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^change_date_time_field],
            {} ['CHANGE_FIELD_NAME              ', clc$nominal_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^change_field_name],
            {} ['CHANGE_FILE_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^change_file_field],
            {} ['CHANGE_INTEGER_FIELD           ', clc$nominal_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^change_integer_field],
            {} ['CHANGE_LIMIT_FIELD             ', clc$nominal_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^change_limit_field],
            {} ['CHANGE_NAME_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 8,
            clc$automatically_log, clc$linked_call, ^change_name_field],
            {} ['CHANGE_REAL_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 9,
            clc$automatically_log, clc$linked_call, ^change_real_field],
            {} ['CHANGE_STRING_FIELD            ', clc$nominal_entry, clc$normal_usage_entry, 10,
            clc$automatically_log, clc$linked_call, ^change_string_field],
            {} ['CHARF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
            clc$automatically_log, clc$linked_call, ^change_real_field],
            {} ['CHASF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
            clc$automatically_log, clc$linked_call, ^change_string_field],
            {} ['CREALF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 11,
            clc$automatically_log, clc$linked_call, ^create_accumulating_limit_field],
            {} ['CREATE_ACCUMULATING_LIMIT_FIELD', clc$nominal_entry, clc$normal_usage_entry, 11,
            clc$automatically_log, clc$linked_call, ^create_accumulating_limit_field],
            {} ['CREATE_CAPABILITY_FIELD        ', clc$nominal_entry, clc$normal_usage_entry, 12,
            clc$automatically_log, clc$linked_call, ^create_capability_field],
            {} ['CREATE_DATE_TIME_FIELD         ', clc$nominal_entry, clc$normal_usage_entry, 13,
            clc$automatically_log, clc$linked_call, ^create_date_time_field],
            {} ['CREATE_FILE_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 14,
            clc$automatically_log, clc$linked_call, ^create_file_field],
            {} ['CREATE_INTEGER_FIELD           ', clc$nominal_entry, clc$normal_usage_entry, 15,
            clc$automatically_log, clc$linked_call, ^create_integer_field],
            {} ['CREATE_LIMIT_FIELD             ', clc$nominal_entry, clc$normal_usage_entry, 16,
            clc$automatically_log, clc$linked_call, ^create_limit_field],
            {} ['CREATE_NAME_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 17,
            clc$automatically_log, clc$linked_call, ^create_name_field],
            {} ['CREATE_REAL_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 18,
            clc$automatically_log, clc$linked_call, ^create_real_field],
            {} ['CREATE_STRING_FIELD            ', clc$nominal_entry, clc$normal_usage_entry, 19,
            clc$automatically_log, clc$linked_call, ^create_string_field],
            {} ['CRECF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
            clc$automatically_log, clc$linked_call, ^create_capability_field],
            {} ['CREDTF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 13,
            clc$automatically_log, clc$linked_call, ^create_date_time_field],
            {} ['CREFF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 14,
            clc$automatically_log, clc$linked_call, ^create_file_field],
            {} ['CREIF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 15,
            clc$automatically_log, clc$linked_call, ^create_integer_field],
            {} ['CRELF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 16,
            clc$automatically_log, clc$linked_call, ^create_limit_field],
            {} ['CRENF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 17,
            clc$automatically_log, clc$linked_call, ^create_name_field],
            {} ['CRERF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 18,
            clc$automatically_log, clc$linked_call, ^create_real_field],
            {} ['CRESF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 19,
            clc$automatically_log, clc$linked_call, ^create_string_field],
            {} ['DELETE_FIELD                   ', clc$nominal_entry, clc$normal_usage_entry, 20,
            clc$automatically_log, clc$linked_call, ^delete_field],
            {} ['DELF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 20,
            clc$automatically_log, clc$linked_call, ^delete_field],
            {} ['DISFD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 21,
            clc$automatically_log, clc$linked_call, ^avp$display_field_description],
            {} ['DISFN                          ', clc$abbreviation_entry, clc$normal_usage_entry, 22,
            clc$automatically_log, clc$linked_call, ^avp$display_field_names],
            {} ['DISPLAY_FIELD_DESCRIPTION      ', clc$nominal_entry, clc$normal_usage_entry, 21,
            clc$automatically_log, clc$linked_call, ^avp$display_field_description],
            {} ['DISPLAY_FIELD_DESCRIPTIONS     ', clc$alias_entry, clc$normal_usage_entry, 21,
            clc$automatically_log, clc$linked_call, ^avp$display_field_description],
            {} ['DISPLAY_FIELD_NAMES            ', clc$nominal_entry, clc$normal_usage_entry, 22,
            clc$automatically_log, clc$linked_call, ^avp$display_field_names],
            {} ['ENDMAMF                        ', clc$abbreviation_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^end_manage_subutility],
            {} ['END_MANAGE_ACCT_MEMBER_FIELDS  ', clc$nominal_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^end_manage_subutility],
            {} ['QUI                            ', clc$alias_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^end_manage_subutility],
            {} ['QUIT                           ', clc$alias_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^end_manage_subutility],
            {} ['RESF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 24,
            clc$automatically_log, clc$linked_call, ^restore_field],
            {} ['RESTORE_FIELD                  ', clc$nominal_entry, clc$normal_usage_entry, 24,
            clc$automatically_log, clc$linked_call, ^restore_field]];

?? POP ??

    status.normal := TRUE;

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

    manage_fields_subutility (avc$manamf_utility_name, avc$manamf_utility_prompt,
          avc$account_member_record_name, manamf_command_table, status);

  PROCEND manage_account_member_fields;
?? OLDTITLE ??
?? NEWTITLE := 'manage_project_fields', EJECT ??

{ PURPOSE:
{   This procedure initiates the MANAGE_PROJECT_FIELDS subutility.

  PROCEDURE manage_project_fields
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_manpf) manage_project_fields, manpf (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 4, 21, 14, 24, 55, 155], clc$command, 1, 1, 0, 0, 0, 0, 1, 'OSM$ADMV_MANPF'],
            [['STATUS                         ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

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

{ table manpf_command_table type=command
{ command (change_accumulating_limit_field, chaalf)                      p=change_accumulating_limit_field
{ command (change_capability_field, chacf)                               p=change_capability_field
{ command (change_date_time_field, chadtf)                               p=change_date_time_field
{ command (change_field_name, chafn)                                     p=change_field_name
{ command (change_file_field, chaff)                                     p=change_file_field
{ command (change_integer_field, chaif)                                  p=change_integer_field
{ command (change_limit_field, chalf)                                    p=change_limit_field
{ command (change_name_field, chanf)                                     p=change_name_field
{ command (change_real_field, charf)                                     p=change_real_field
{ command (change_string_field, chasf)                                   p=change_string_field
{ command (create_accumulating_limit_field, crealf)                      p=create_accumulating_limit_field
{ command (create_capability_field, crecf)                               p=create_capability_field
{ command (create_date_time_field, credtf)                               p=create_date_time_field
{ command (create_file_field, creff)                                     p=create_file_field
{ command (create_integer_field, creif)                                  p=create_integer_field
{ command (create_limit_field, crelf)                                    p=create_limit_field
{ command (create_name_field, crenf)                                     p=create_name_field
{ command (create_real_field, crerf)                                     p=create_real_field
{ command (create_string_field, cresf)                                   p=create_string_field
{ command (delete_field, delf)                                           p=delete_field
{ command (display_field_description, display_field_descriptions, disfd) p=avp$display_field_description
{ command (display_field_names, disfn)                                   p=avp$display_field_names
{ command (end_manage_project_fields, quit, qui, endmpf)                 p=end_manage_subutility
{ command (restore_field, resf)                                          p=restore_field
{ tablend

?? PUSH (LISTEXT := ON) ??

    VAR
      manpf_command_table: [STATIC, READ] ^clt$command_table := ^manpf_command_table_entries,

      manpf_command_table_entries: [STATIC, READ] array [1 .. 51] of clt$command_table_entry := [
            {} ['CHAALF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^change_accumulating_limit_field],
            {} ['CHACF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^change_capability_field],
            {} ['CHADTF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^change_date_time_field],
            {} ['CHAFF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^change_file_field],
            {} ['CHAFN                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^change_field_name],
            {} ['CHAIF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^change_integer_field],
            {} ['CHALF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^change_limit_field],
            {} ['CHANF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
            clc$automatically_log, clc$linked_call, ^change_name_field],
            {} ['CHANGE_ACCUMULATING_LIMIT_FIELD', clc$nominal_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^change_accumulating_limit_field],
            {} ['CHANGE_CAPABILITY_FIELD        ', clc$nominal_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^change_capability_field],
            {} ['CHANGE_DATE_TIME_FIELD         ', clc$nominal_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^change_date_time_field],
            {} ['CHANGE_FIELD_NAME              ', clc$nominal_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^change_field_name],
            {} ['CHANGE_FILE_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^change_file_field],
            {} ['CHANGE_INTEGER_FIELD           ', clc$nominal_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^change_integer_field],
            {} ['CHANGE_LIMIT_FIELD             ', clc$nominal_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^change_limit_field],
            {} ['CHANGE_NAME_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 8,
            clc$automatically_log, clc$linked_call, ^change_name_field],
            {} ['CHANGE_REAL_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 9,
            clc$automatically_log, clc$linked_call, ^change_real_field],
            {} ['CHANGE_STRING_FIELD            ', clc$nominal_entry, clc$normal_usage_entry, 10,
            clc$automatically_log, clc$linked_call, ^change_string_field],
            {} ['CHARF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
            clc$automatically_log, clc$linked_call, ^change_real_field],
            {} ['CHASF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
            clc$automatically_log, clc$linked_call, ^change_string_field],
            {} ['CREALF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 11,
            clc$automatically_log, clc$linked_call, ^create_accumulating_limit_field],
            {} ['CREATE_ACCUMULATING_LIMIT_FIELD', clc$nominal_entry, clc$normal_usage_entry, 11,
            clc$automatically_log, clc$linked_call, ^create_accumulating_limit_field],
            {} ['CREATE_CAPABILITY_FIELD        ', clc$nominal_entry, clc$normal_usage_entry, 12,
            clc$automatically_log, clc$linked_call, ^create_capability_field],
            {} ['CREATE_DATE_TIME_FIELD         ', clc$nominal_entry, clc$normal_usage_entry, 13,
            clc$automatically_log, clc$linked_call, ^create_date_time_field],
            {} ['CREATE_FILE_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 14,
            clc$automatically_log, clc$linked_call, ^create_file_field],
            {} ['CREATE_INTEGER_FIELD           ', clc$nominal_entry, clc$normal_usage_entry, 15,
            clc$automatically_log, clc$linked_call, ^create_integer_field],
            {} ['CREATE_LIMIT_FIELD             ', clc$nominal_entry, clc$normal_usage_entry, 16,
            clc$automatically_log, clc$linked_call, ^create_limit_field],
            {} ['CREATE_NAME_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 17,
            clc$automatically_log, clc$linked_call, ^create_name_field],
            {} ['CREATE_REAL_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 18,
            clc$automatically_log, clc$linked_call, ^create_real_field],
            {} ['CREATE_STRING_FIELD            ', clc$nominal_entry, clc$normal_usage_entry, 19,
            clc$automatically_log, clc$linked_call, ^create_string_field],
            {} ['CRECF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
            clc$automatically_log, clc$linked_call, ^create_capability_field],
            {} ['CREDTF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 13,
            clc$automatically_log, clc$linked_call, ^create_date_time_field],
            {} ['CREFF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 14,
            clc$automatically_log, clc$linked_call, ^create_file_field],
            {} ['CREIF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 15,
            clc$automatically_log, clc$linked_call, ^create_integer_field],
            {} ['CRELF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 16,
            clc$automatically_log, clc$linked_call, ^create_limit_field],
            {} ['CRENF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 17,
            clc$automatically_log, clc$linked_call, ^create_name_field],
            {} ['CRERF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 18,
            clc$automatically_log, clc$linked_call, ^create_real_field],
            {} ['CRESF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 19,
            clc$automatically_log, clc$linked_call, ^create_string_field],
            {} ['DELETE_FIELD                   ', clc$nominal_entry, clc$normal_usage_entry, 20,
            clc$automatically_log, clc$linked_call, ^delete_field],
            {} ['DELF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 20,
            clc$automatically_log, clc$linked_call, ^delete_field],
            {} ['DISFD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 21,
            clc$automatically_log, clc$linked_call, ^avp$display_field_description],
            {} ['DISFN                          ', clc$abbreviation_entry, clc$normal_usage_entry, 22,
            clc$automatically_log, clc$linked_call, ^avp$display_field_names],
            {} ['DISPLAY_FIELD_DESCRIPTION      ', clc$nominal_entry, clc$normal_usage_entry, 21,
            clc$automatically_log, clc$linked_call, ^avp$display_field_description],
            {} ['DISPLAY_FIELD_DESCRIPTIONS     ', clc$alias_entry, clc$normal_usage_entry, 21,
            clc$automatically_log, clc$linked_call, ^avp$display_field_description],
            {} ['DISPLAY_FIELD_NAMES            ', clc$nominal_entry, clc$normal_usage_entry, 22,
            clc$automatically_log, clc$linked_call, ^avp$display_field_names],
            {} ['ENDMPF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^end_manage_subutility],
            {} ['END_MANAGE_PROJECT_FIELDS      ', clc$nominal_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^end_manage_subutility],
            {} ['QUI                            ', clc$alias_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^end_manage_subutility],
            {} ['QUIT                           ', clc$alias_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^end_manage_subutility],
            {} ['RESF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 24,
            clc$automatically_log, clc$linked_call, ^restore_field],
            {} ['RESTORE_FIELD                  ', clc$nominal_entry, clc$normal_usage_entry, 24,
            clc$automatically_log, clc$linked_call, ^restore_field]];

?? POP ??

    status.normal := TRUE;

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

    manage_fields_subutility (avc$manpf_utility_name, avc$manpf_utility_prompt, avc$project_record_name,
          manpf_command_table, status);

  PROCEND manage_project_fields;
?? OLDTITLE ??
?? NEWTITLE := 'manage_project_member_fields', EJECT ??

{ PURPOSE:
{   This procedure initiates the MANAGE_PROJECT_MEMBER_FIELDS subutility.

  PROCEDURE manage_project_member_fields
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_manpmf) manage_project_member_fields, manpmf (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 4, 21, 14, 25, 24, 480], clc$command, 1, 1, 0, 0, 0, 0, 1, 'OSM$ADMV_MANPMF'],
            [['STATUS                         ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

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

{ table manpmf_command_table type=command
{ command (change_accumulating_limit_field, chaalf)                      p=change_accumulating_limit_field
{ command (change_capability_field, chacf)                               p=change_capability_field
{ command (change_date_time_field, chadtf)                               p=change_date_time_field
{ command (change_field_name, chafn)                                     p=change_field_name
{ command (change_file_field, chaff)                                     p=change_file_field
{ command (change_integer_field, chaif)                                  p=change_integer_field
{ command (change_limit_field, chalf)                                    p=change_limit_field
{ command (change_name_field, chanf)                                     p=change_name_field
{ command (change_real_field, charf)                                     p=change_real_field
{ command (change_string_field, chasf)                                   p=change_string_field
{ command (create_accumulating_limit_field, crealf)                      p=create_accumulating_limit_field
{ command (create_capability_field, crecf)                               p=create_capability_field
{ command (create_date_time_field, credtf)                               p=create_date_time_field
{ command (create_file_field, creff)                                     p=create_file_field
{ command (create_integer_field, creif)                                  p=create_integer_field
{ command (create_limit_field, crelf)                                    p=create_limit_field
{ command (create_name_field, crenf)                                     p=create_name_field
{ command (create_real_field, crerf)                                     p=create_real_field
{ command (create_string_field, cresf)                                   p=create_string_field
{ command (delete_field, delf)                                           p=delete_field
{ command (display_field_description, display_field_descriptions, disfd) p=avp$display_field_description
{ command (display_field_names, disfn)                                   p=avp$display_field_names
{ command (end_manage_proj_member_fields, quit, qui, endmpmf)            p=end_manage_subutility
{ command (restore_field, resf)                                          p=restore_field
{ tablend

?? PUSH (LISTEXT := ON) ??

    VAR
      manpmf_command_table: [STATIC, READ] ^clt$command_table := ^manpmf_command_table_entries,

      manpmf_command_table_entries: [STATIC, READ] array [1 .. 51] of clt$command_table_entry := [
            {} ['CHAALF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^change_accumulating_limit_field],
            {} ['CHACF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^change_capability_field],
            {} ['CHADTF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^change_date_time_field],
            {} ['CHAFF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^change_file_field],
            {} ['CHAFN                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^change_field_name],
            {} ['CHAIF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^change_integer_field],
            {} ['CHALF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^change_limit_field],
            {} ['CHANF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
            clc$automatically_log, clc$linked_call, ^change_name_field],
            {} ['CHANGE_ACCUMULATING_LIMIT_FIELD', clc$nominal_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^change_accumulating_limit_field],
            {} ['CHANGE_CAPABILITY_FIELD        ', clc$nominal_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^change_capability_field],
            {} ['CHANGE_DATE_TIME_FIELD         ', clc$nominal_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^change_date_time_field],
            {} ['CHANGE_FIELD_NAME              ', clc$nominal_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^change_field_name],
            {} ['CHANGE_FILE_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^change_file_field],
            {} ['CHANGE_INTEGER_FIELD           ', clc$nominal_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^change_integer_field],
            {} ['CHANGE_LIMIT_FIELD             ', clc$nominal_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^change_limit_field],
            {} ['CHANGE_NAME_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 8,
            clc$automatically_log, clc$linked_call, ^change_name_field],
            {} ['CHANGE_REAL_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 9,
            clc$automatically_log, clc$linked_call, ^change_real_field],
            {} ['CHANGE_STRING_FIELD            ', clc$nominal_entry, clc$normal_usage_entry, 10,
            clc$automatically_log, clc$linked_call, ^change_string_field],
            {} ['CHARF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
            clc$automatically_log, clc$linked_call, ^change_real_field],
            {} ['CHASF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
            clc$automatically_log, clc$linked_call, ^change_string_field],
            {} ['CREALF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 11,
            clc$automatically_log, clc$linked_call, ^create_accumulating_limit_field],
            {} ['CREATE_ACCUMULATING_LIMIT_FIELD', clc$nominal_entry, clc$normal_usage_entry, 11,
            clc$automatically_log, clc$linked_call, ^create_accumulating_limit_field],
            {} ['CREATE_CAPABILITY_FIELD        ', clc$nominal_entry, clc$normal_usage_entry, 12,
            clc$automatically_log, clc$linked_call, ^create_capability_field],
            {} ['CREATE_DATE_TIME_FIELD         ', clc$nominal_entry, clc$normal_usage_entry, 13,
            clc$automatically_log, clc$linked_call, ^create_date_time_field],
            {} ['CREATE_FILE_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 14,
            clc$automatically_log, clc$linked_call, ^create_file_field],
            {} ['CREATE_INTEGER_FIELD           ', clc$nominal_entry, clc$normal_usage_entry, 15,
            clc$automatically_log, clc$linked_call, ^create_integer_field],
            {} ['CREATE_LIMIT_FIELD             ', clc$nominal_entry, clc$normal_usage_entry, 16,
            clc$automatically_log, clc$linked_call, ^create_limit_field],
            {} ['CREATE_NAME_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 17,
            clc$automatically_log, clc$linked_call, ^create_name_field],
            {} ['CREATE_REAL_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 18,
            clc$automatically_log, clc$linked_call, ^create_real_field],
            {} ['CREATE_STRING_FIELD            ', clc$nominal_entry, clc$normal_usage_entry, 19,
            clc$automatically_log, clc$linked_call, ^create_string_field],
            {} ['CRECF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
            clc$automatically_log, clc$linked_call, ^create_capability_field],
            {} ['CREDTF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 13,
            clc$automatically_log, clc$linked_call, ^create_date_time_field],
            {} ['CREFF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 14,
            clc$automatically_log, clc$linked_call, ^create_file_field],
            {} ['CREIF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 15,
            clc$automatically_log, clc$linked_call, ^create_integer_field],
            {} ['CRELF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 16,
            clc$automatically_log, clc$linked_call, ^create_limit_field],
            {} ['CRENF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 17,
            clc$automatically_log, clc$linked_call, ^create_name_field],
            {} ['CRERF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 18,
            clc$automatically_log, clc$linked_call, ^create_real_field],
            {} ['CRESF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 19,
            clc$automatically_log, clc$linked_call, ^create_string_field],
            {} ['DELETE_FIELD                   ', clc$nominal_entry, clc$normal_usage_entry, 20,
            clc$automatically_log, clc$linked_call, ^delete_field],
            {} ['DELF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 20,
            clc$automatically_log, clc$linked_call, ^delete_field],
            {} ['DISFD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 21,
            clc$automatically_log, clc$linked_call, ^avp$display_field_description],
            {} ['DISFN                          ', clc$abbreviation_entry, clc$normal_usage_entry, 22,
            clc$automatically_log, clc$linked_call, ^avp$display_field_names],
            {} ['DISPLAY_FIELD_DESCRIPTION      ', clc$nominal_entry, clc$normal_usage_entry, 21,
            clc$automatically_log, clc$linked_call, ^avp$display_field_description],
            {} ['DISPLAY_FIELD_DESCRIPTIONS     ', clc$alias_entry, clc$normal_usage_entry, 21,
            clc$automatically_log, clc$linked_call, ^avp$display_field_description],
            {} ['DISPLAY_FIELD_NAMES            ', clc$nominal_entry, clc$normal_usage_entry, 22,
            clc$automatically_log, clc$linked_call, ^avp$display_field_names],
            {} ['ENDMPMF                        ', clc$abbreviation_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^end_manage_subutility],
            {} ['END_MANAGE_PROJ_MEMBER_FIELDS  ', clc$nominal_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^end_manage_subutility],
            {} ['QUI                            ', clc$alias_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^end_manage_subutility],
            {} ['QUIT                           ', clc$alias_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^end_manage_subutility],
            {} ['RESF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 24,
            clc$automatically_log, clc$linked_call, ^restore_field],
            {} ['RESTORE_FIELD                  ', clc$nominal_entry, clc$normal_usage_entry, 24,
            clc$automatically_log, clc$linked_call, ^restore_field]];

?? POP ??

    status.normal := TRUE;

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

    manage_fields_subutility (avc$manpmf_utility_name, avc$manpmf_utility_prompt,
          avc$project_member_record_name, manpmf_command_table, status);

  PROCEND manage_project_member_fields;
?? OLDTITLE ??
?? NEWTITLE := 'manage_user_fields', EJECT ??

{ PURPOSE:
{   This procedure initiates the MANAGE_USER_FIELDS subutility.

  PROCEDURE manage_user_fields
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_manuf) manage_user_fields, manuf (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 4, 21, 14, 25, 59, 119], clc$command, 1, 1, 0, 0, 0, 0, 1, 'OSM$ADMV_MANUF'],
            [['STATUS                         ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

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

{ table manuf_command_table type=command
{ command (change_account_project_field, chaapf)                         p=change_account_project_field
{ command (change_accumulating_limit_field, chaalf)                      p=change_accumulating_limit_field
{ command (change_capability_field, chacf)                               p=change_capability_field
{ command (change_date_time_field, chadtf)                               p=change_date_time_field
{ command (change_field_name, chafn)                                     p=change_field_name
{ command (change_file_field, chaff)                                     p=change_file_field
{ command (change_integer_field, chaif)                                  p=change_integer_field
{ command (change_job_class_field, chajcf)                               p=change_job_class_field
{ command (change_labeled_names_field, chalnf)                           p=change_labeled_names_field
{ command (change_limit_field, chalf)                                    p=change_limit_field
{ command (change_login_password_field, chalpwf)                         p=change_login_password_field
{ command (change_name_field, chanf)                                     p=change_name_field
{ command (change_real_field, charf)                                     p=change_real_field
{ command (change_ring_privilege_field, charpf)                          p=change_ring_privilege_field
{ command (change_string_field, chasf)                                   p=change_string_field
{ command (create_accumulating_limit_field, crealf)                      p=create_accumulating_limit_field
{ command (create_capability_field, crecf)                               p=create_capability_field
{ command (create_date_time_field, credtf)                               p=create_date_time_field
{ command (create_file_field, creff)                                     p=create_file_field
{ command (create_integer_field, creif)                                  p=create_integer_field
{ command (create_limit_field, crelf)                                    p=create_limit_field
{ command (create_name_field, crenf)                                     p=create_name_field
{ command (create_real_field, crerf)                                     p=create_real_field
{ command (create_string_field, cresf)                                   p=create_string_field
{ command (delete_field, delf)                                           p=delete_field
{ command (display_field_description, display_field_descriptions, disfd) p=avp$display_field_description
{ command (display_field_names, disfn)                                   p=avp$display_field_names
{ command (end_manage_user_fields, quit, qui, endmuf)                    p=end_manage_subutility
{ command (restore_field, resf)                                          p=restore_field
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  manuf_command_table: [STATIC, READ] ^clt$command_table := ^manuf_command_table_entries,

  manuf_command_table_entries: [STATIC, READ] array [1 .. 61] of clt$command_table_entry := [
  {} ['CHAALF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^change_accumulating_limit_field],
  {} ['CHAAPF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^change_account_project_field],
  {} ['CHACF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^change_capability_field],
  {} ['CHADTF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^change_date_time_field],
  {} ['CHAFF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^change_file_field],
  {} ['CHAFN                          ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^change_field_name],
  {} ['CHAIF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^change_integer_field],
  {} ['CHAJCF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^change_job_class_field],
  {} ['CHALF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^change_limit_field],
  {} ['CHALNF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^change_labeled_names_field],
  {} ['CHALPWF                        ', clc$abbreviation_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^change_login_password_field],
  {} ['CHANF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^change_name_field],
  {} ['CHANGE_ACCOUNT_PROJECT_FIELD   ', clc$nominal_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^change_account_project_field],
  {} ['CHANGE_ACCUMULATING_LIMIT_FIELD', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^change_accumulating_limit_field],
  {} ['CHANGE_CAPABILITY_FIELD        ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^change_capability_field],
  {} ['CHANGE_DATE_TIME_FIELD         ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^change_date_time_field],
  {} ['CHANGE_FIELD_NAME              ', clc$nominal_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^change_field_name],
  {} ['CHANGE_FILE_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^change_file_field],
  {} ['CHANGE_INTEGER_FIELD           ', clc$nominal_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^change_integer_field],
  {} ['CHANGE_JOB_CLASS_FIELD         ', clc$nominal_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^change_job_class_field],
  {} ['CHANGE_LABELED_NAMES_FIELD     ', clc$nominal_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^change_labeled_names_field],
  {} ['CHANGE_LIMIT_FIELD             ', clc$nominal_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^change_limit_field],
  {} ['CHANGE_LOGIN_PASSWORD_FIELD    ', clc$nominal_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^change_login_password_field],
  {} ['CHANGE_NAME_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^change_name_field],
  {} ['CHANGE_REAL_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^change_real_field],
  {} ['CHANGE_RING_PRIVILEGE_FIELD    ', clc$nominal_entry, clc$normal_usage_entry, 14,
        clc$automatically_log, clc$linked_call, ^change_ring_privilege_field],
  {} ['CHANGE_STRING_FIELD            ', clc$nominal_entry, clc$normal_usage_entry, 15,
        clc$automatically_log, clc$linked_call, ^change_string_field],
  {} ['CHARF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^change_real_field],
  {} ['CHARPF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 14,
        clc$automatically_log, clc$linked_call, ^change_ring_privilege_field],
  {} ['CHASF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 15,
        clc$automatically_log, clc$linked_call, ^change_string_field],
  {} ['CREALF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 16,
        clc$automatically_log, clc$linked_call, ^create_accumulating_limit_field],
  {} ['CREATE_ACCUMULATING_LIMIT_FIELD', clc$nominal_entry, clc$normal_usage_entry, 16,
        clc$automatically_log, clc$linked_call, ^create_accumulating_limit_field],
  {} ['CREATE_CAPABILITY_FIELD        ', clc$nominal_entry, clc$normal_usage_entry, 17,
        clc$automatically_log, clc$linked_call, ^create_capability_field],
  {} ['CREATE_DATE_TIME_FIELD         ', clc$nominal_entry, clc$normal_usage_entry, 18,
        clc$automatically_log, clc$linked_call, ^create_date_time_field],
  {} ['CREATE_FILE_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 19,
        clc$automatically_log, clc$linked_call, ^create_file_field],
  {} ['CREATE_INTEGER_FIELD           ', clc$nominal_entry, clc$normal_usage_entry, 20,
        clc$automatically_log, clc$linked_call, ^create_integer_field],
  {} ['CREATE_LIMIT_FIELD             ', clc$nominal_entry, clc$normal_usage_entry, 21,
        clc$automatically_log, clc$linked_call, ^create_limit_field],
  {} ['CREATE_NAME_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 22,
        clc$automatically_log, clc$linked_call, ^create_name_field],
  {} ['CREATE_REAL_FIELD              ', clc$nominal_entry, clc$normal_usage_entry, 23,
        clc$automatically_log, clc$linked_call, ^create_real_field],
  {} ['CREATE_STRING_FIELD            ', clc$nominal_entry, clc$normal_usage_entry, 24,
        clc$automatically_log, clc$linked_call, ^create_string_field],
  {} ['CRECF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 17,
        clc$automatically_log, clc$linked_call, ^create_capability_field],
  {} ['CREDTF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 18,
        clc$automatically_log, clc$linked_call, ^create_date_time_field],
  {} ['CREFF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 19,
        clc$automatically_log, clc$linked_call, ^create_file_field],
  {} ['CREIF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 20,
        clc$automatically_log, clc$linked_call, ^create_integer_field],
  {} ['CRELF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 21,
        clc$automatically_log, clc$linked_call, ^create_limit_field],
  {} ['CRENF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 22,
        clc$automatically_log, clc$linked_call, ^create_name_field],
  {} ['CRERF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 23,
        clc$automatically_log, clc$linked_call, ^create_real_field],
  {} ['CRESF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 24,
        clc$automatically_log, clc$linked_call, ^create_string_field],
  {} ['DELETE_FIELD                   ', clc$nominal_entry, clc$normal_usage_entry, 25,
        clc$automatically_log, clc$linked_call, ^delete_field],
  {} ['DELF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 25,
        clc$automatically_log, clc$linked_call, ^delete_field],
  {} ['DISFD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 26,
        clc$automatically_log, clc$linked_call, ^avp$display_field_description],
  {} ['DISFN                          ', clc$abbreviation_entry, clc$normal_usage_entry, 27,
        clc$automatically_log, clc$linked_call, ^avp$display_field_names],
  {} ['DISPLAY_FIELD_DESCRIPTION      ', clc$nominal_entry, clc$normal_usage_entry, 26,
        clc$automatically_log, clc$linked_call, ^avp$display_field_description],
  {} ['DISPLAY_FIELD_DESCRIPTIONS     ', clc$alias_entry, clc$normal_usage_entry, 26,
        clc$automatically_log, clc$linked_call, ^avp$display_field_description],
  {} ['DISPLAY_FIELD_NAMES            ', clc$nominal_entry, clc$normal_usage_entry, 27,
        clc$automatically_log, clc$linked_call, ^avp$display_field_names],
  {} ['ENDMUF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 28,
        clc$automatically_log, clc$linked_call, ^end_manage_subutility],
  {} ['END_MANAGE_USER_FIELDS         ', clc$nominal_entry, clc$normal_usage_entry, 28,
        clc$automatically_log, clc$linked_call, ^end_manage_subutility],
  {} ['QUI                            ', clc$alias_entry, clc$normal_usage_entry, 28,
        clc$automatically_log, clc$linked_call, ^end_manage_subutility],
  {} ['QUIT                           ', clc$alias_entry, clc$normal_usage_entry, 28,
        clc$automatically_log, clc$linked_call, ^end_manage_subutility],
  {} ['RESF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 29,
        clc$automatically_log, clc$linked_call, ^restore_field],
  {} ['RESTORE_FIELD                  ', clc$nominal_entry, clc$normal_usage_entry, 29,
        clc$automatically_log, clc$linked_call, ^restore_field]];

?? POP ??

    status.normal := TRUE;

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

    manage_fields_subutility (avc$manuf_utility_name, avc$manuf_utility_prompt, avc$user_record_name,
          manuf_command_table, status);

  PROCEND manage_user_fields;
?? OLDTITLE ??
?? NEWTITLE := 'use_validation_file', EJECT ??

{ PURPOSE:
{   This is the command processor for the USE_VALIDATION_FILE subcommand.

  PROCEDURE use_validation_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_usevf) use_validation_field, usevf (
{   validation_file, vf: file = $family.$system.$validations
{   password, pw: (SECURE) any of
{       key
{         none
{       keyend
{       name
{     anyend = none
{   new_password, npw: (BY_NAME, SECURE) any of
{       key
{         none
{       keyend
{       name
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          default_value: string (28),
        recend,
        type2: 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$name_type_qualifier,
          recend,
          default_value: string (4),
        recend,
        type3: 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$name_type_qualifier,
          recend,
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 12, 15, 10, 39, 372], clc$command, 7, 4, 0, 0, 0, 0, 4, 'OSM$ADMV_USEVF'],
            [['NEW_PASSWORD                   ', clc$nominal_entry, 3],
            ['NPW                            ', clc$abbreviation_entry, 3],
            ['PASSWORD                       ', clc$nominal_entry, 2],
            ['PW                             ', clc$abbreviation_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 4],
            ['VALIDATION_FILE                ', clc$nominal_entry, 1],
            ['VF                             ', clc$abbreviation_entry, 1]], [

{ PARAMETER 1

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 28],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 69, clc$optional_default_parameter, 0, 4],

{ PARAMETER 3

      [1, clc$normal_usage_entry, clc$secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
            clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type], '$family.$system.$validations'],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]], 'none'],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$validation_file = 1,
      p$password = 2,
      p$new_password = 3,
      p$status = 4;

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

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      new_password: ^ost$name,
      password: ^ost$name,
      served_family: boolean;

    status.normal := TRUE;

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

    IF pvt [p$password].value^.kind = clc$keyword THEN
      password := NIL;
    ELSE
      PUSH password;
      password^ := pvt [p$password].value^.name_value;
    IFEND;

    IF pvt [p$new_password].specified THEN
      PUSH new_password;
      IF pvt [p$new_password].value^.kind = clc$keyword THEN
        new_password^ := osc$null_name;
      ELSE
        new_password^ := pvt [p$new_password].value^.name_value;
      IFEND;
    ELSE
      new_password := NIL;
    IFEND;

{ Determine the family name from the specified path.

    clp$evaluate_file_reference (pvt [p$validation_file].value^.file_value^,
          $clt$file_ref_parsing_options[], TRUE, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Don't allow ADMINISTER_VALIDATIONS on the client.

    avp$check_for_served_family (fsp$path_element (^evaluated_file_reference, 1)^, served_family);
    IF served_family THEN
      osp$set_status_abnormal ('AV', ave$not_allowed_on_client, 'ADMINISTER_VALIDATIONS', status);
      RETURN;
    IFEND;

    IF validation_file_open THEN
      validation_file_open := FALSE;
      #SPOIL (validation_file_open);
      avp$close_validation_file (validation_file_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    avp$open_validation_file (pvt [p$validation_file].value^.file_value^, password, new_password, TRUE,
          validation_file_information, status);
    IF status.normal THEN
      validation_file_open := TRUE;
      #SPOIL (validation_file_open);
    IFEND;

  PROCEND use_validation_file;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'ADMINISTER_VALIDATIONS Function Processors', EJECT ??
?? NEWTITLE := 'avp$$account_list', EJECT ??

{ PURPOSE:
{   Return a list containing the names of the accounts that the executing user has control of.

  PROCEDURE avp$$account_list
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$admv_al) $account_list

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [88, 12, 15, 12, 7, 42, 319],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$ADMV_AL']];

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

    VAR
      account_name: avt$account_name,
      assigned_record_id: ost$name,
      list_element: ^clt$data_value,
      previous_list_element: ^clt$data_value,
      read_status: ost$status;

    status.normal := TRUE;

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

{ Make sure a validation file has been opened.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

    result := NIL;

    IF avp$system_administrator () OR avp$family_administrator () THEN

{ Return a list of all accounts in the family.  Set up the validation file information so that the next record
{ to be read sequentially from the file will be the first account record.

      validation_file_information.last_key_accessed (1, 31) := osc$null_name {account_name} ;
      validation_file_information.last_key_accessed (32, 31) := osc$null_name {project_name} ;
      validation_file_information.last_key_accessed (63, 31) := osc$null_name {user_name} ;

{ Read through the account records making a list of all accounts.

      REPEAT
        account_name := osc$null_name;
        avp$read_account_record (account_name, assigned_record_id, validation_file_information, read_status);
        IF read_status.normal THEN
          make_scl_name_list_element (account_name, work_area, list_element, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF result = NIL THEN
            result := list_element;
          ELSE
            previous_list_element^.link := list_element;
          IFEND;
          previous_list_element := list_element;
        IFEND;
      UNTIL (NOT read_status.normal) AND (read_status.condition <> ave$insufficient_authority);
      IF (NOT read_status.normal) AND (read_status.condition <> ave$end_of_template_file) THEN
        status := read_status;
      IFEND;
    ELSEIF account_administrator THEN

{ Return the executing account name if the user is the account administrator.

      make_scl_name_list_element (executing_account, work_area, result, status);
    ELSE

{ Return an error if any other user attempts to use the function.

      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
    IFEND;

{ If the list has not been created, make an empty list.

    IF result = NIL THEN
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
    IFEND;

  PROCEND avp$$account_list;
?? OLDTITLE ??
?? NEWTITLE := 'avp$$account_member_list', EJECT ??

{ PURPOSE:
{   Return a list containing the names of the account members for the specified account.

  PROCEDURE avp$$account_member_list
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$admv_aml) $account_member_list (
{   account: name = default__31__character__account
{   )

?? 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$name_type_qualifier,
        default_value: string (31),
      recend,
    recend := [
    [1,
    [88, 12, 15, 12, 6, 58, 879],
    clc$function, 1, 1, 0, 0, 0, 0, 0, 'OSM$$ADMV_AML'], [
    ['ACCOUNT                        ',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, 5,
  clc$optional_default_parameter, 0, 31]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'default__31__character__account']];

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

    CONST
      p$account = 1;

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

    VAR
      account_name: avt$account_name,
      altered_pdt: ^clt$parameter_description_table,
      assigned_record_id: ost$name,
      list_element: ^clt$data_value,
      member_name: ost$user_name,
      pdt_changes: ^clt$pdt_changes,
      previous_list_element: ^clt$data_value,
      read_status: ost$status;

    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the ACCOUNT parameter.

    PUSH pdt_changes: [1 .. 1];
    pdt_changes^ [1].number := p$account;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_account;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

{ Make sure a validation file has been opened.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

    result := NIL;

    IF NOT (avp$system_administrator () OR avp$family_administrator ()) THEN
      IF (NOT account_administrator) OR (executing_account <> pvt [p$account].value^.name_value) THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        RETURN;
      IFEND;
    IFEND;

{ Return a list of all account members in the account.  Set up the validation file information so that the
{ next record to be read sequentially from the file will be the first account member record.

    validation_file_information.last_key_accessed (1, 31) := pvt [p$account].value^.name_value;
    validation_file_information.last_key_accessed (32, 31) := osc$null_name {project_name} ;
    validation_file_information.last_key_accessed (63, 31) := osc$null_name {user_name} ;

{ Read through the account member records making a list of all account member names.

    REPEAT
      account_name := pvt [p$account].value^.name_value;
      member_name := osc$null_name;
      avp$read_account_member_record (account_name, member_name, assigned_record_id,
            validation_file_information, read_status);
      IF (read_status.normal) AND (account_name = pvt [p$account].value^.name_value) THEN
        make_scl_name_list_element (member_name, work_area, list_element, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF result = NIL THEN
          result := list_element;
        ELSE
          previous_list_element^.link := list_element;
        IFEND;
        previous_list_element := list_element;
      IFEND;
    UNTIL ((NOT read_status.normal) AND (read_status.condition <> ave$insufficient_authority)) OR
          (account_name <> pvt [p$account].value^.name_value);

    IF (NOT read_status.normal) AND (read_status.condition <> ave$end_of_template_file) THEN
      status := read_status;
    IFEND;

{ If the list has not been created, make an empty list.

    IF result = NIL THEN
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
    IFEND;

  PROCEND avp$$account_member_list;
?? OLDTITLE ??
?? NEWTITLE := 'avp$$current_default', EJECT ??

{ PURPOSE:
{   Return the current ADMV devault value for the ACCOUNT, PROJECT or USER parameter.

  PROCEDURE avp$$current_default
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$admv_cd) $current_default (
{   option: key
{       account, project, user
{     keyend = $required
{   )

?? 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$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
    recend := [
    [1,
    [89, 1, 5, 15, 59, 2, 60],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$ADMV_CD'], [
    ['OPTION                         ',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, 118,
  clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [3], [
    ['ACCOUNT                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['PROJECT                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['USER                           ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ]];

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

    CONST
      p$option = 1;

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

    status.normal := TRUE;

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

    IF pvt [p$option].value^.keyword_value = 'ACCOUNT' THEN
      clp$make_name_value (default_account, work_area, result);
    ELSEIF pvt [p$option].value^.keyword_value = 'PROJECT' THEN
      clp$make_name_value (default_project, work_area, result);
    ELSE { USER }
      clp$make_name_value (default_user, work_area, result);
    IFEND;
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;

  PROCEND avp$$current_default;
?? OLDTITLE ??
?? NEWTITLE := 'avp$$family_list', EJECT ??

{ PURPOSE:
{   Return a list containing the names of the families on this system.

  PROCEDURE avp$$family_list
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$admv_fl) $family_list

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [88, 12, 15, 12, 9, 16, 686],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$ADMV_FL']];

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

    VAR
      active_family_list: ^array [1 .. * ] of ost$name,
      index: pmt$family_name_count,
      list_element: ^clt$data_value,
      previous_list_element: ^clt$data_value,
      number_of_families: pmt$family_name_count;

    status.normal := TRUE;

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

    number_of_families := 100;
    REPEAT
      PUSH active_family_list: [1 .. number_of_families];
      pmp$get_family_names (active_family_list^, number_of_families, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    UNTIL number_of_families <= UPPERBOUND (active_family_list^);

    result := NIL;

    FOR index := 1 TO number_of_families DO
      make_scl_name_list_element (active_family_list^ [index], work_area, list_element, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF result = NIL THEN
        result := list_element;
      ELSE
        previous_list_element^.link := list_element;
      IFEND;
      previous_list_element := list_element;
    FOREND;

  PROCEND avp$$family_list;
?? OLDTITLE ??
?? NEWTITLE := 'avp$$project_list', EJECT ??

{ PURPOSE:
{   Return a list containing the names of the projects for the specified account.

  PROCEDURE avp$$project_list
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$admv_pl) $project_list (
{   account: name = default__31__character__account
{   )

?? 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$name_type_qualifier,
        default_value: string (31),
      recend,
    recend := [
    [1,
    [88, 12, 15, 12, 9, 45, 193],
    clc$function, 1, 1, 0, 0, 0, 0, 0, 'OSM$$ADMV_PL'], [
    ['ACCOUNT                        ',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, 5,
  clc$optional_default_parameter, 0, 31]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'default__31__character__account']];

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

    CONST
      p$account = 1;

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

    VAR
      account_name: avt$account_name,
      altered_pdt: ^clt$parameter_description_table,
      assigned_record_id: ost$name,
      list_element: ^clt$data_value,
      pdt_changes: ^clt$pdt_changes,
      previous_list_element: ^clt$data_value,
      project_name: avt$project_name,
      read_status: ost$status;

    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the ACCOUNT parameter.

    PUSH pdt_changes: [1 .. 1];
    pdt_changes^ [1].number := p$account;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_account;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

{ Make sure a validation file has been opened.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

    result := NIL;

    IF NOT (avp$system_administrator () OR avp$family_administrator ()) THEN
      IF (NOT account_administrator) OR (executing_account <> pvt [p$account].value^.name_value) THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        RETURN;
      IFEND;
    IFEND;

{ Return a list of all projects in the account.  Set up the validation file information so that the next
{ record to be read sequentially from the file will be the first project record for the specified account.

    validation_file_information.last_key_accessed (1, 31) := pvt [p$account].value^.name_value;
    validation_file_information.last_key_accessed (32, 31) := osc$null_name {project_name} ;
    validation_file_information.last_key_accessed (63, 31) := osc$null_name {user_name} ;

{ Read through the project records making a list of all project names.

    REPEAT
      account_name := pvt [p$account].value^.name_value;
      project_name := osc$null_name;
      avp$read_project_record (account_name, project_name, assigned_record_id, validation_file_information,
            read_status);
      IF (read_status.normal) AND (account_name = pvt [p$account].value^.name_value) THEN
        make_scl_name_list_element (project_name, work_area, list_element, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF result = NIL THEN
          result := list_element;
        ELSE
          previous_list_element^.link := list_element;
        IFEND;
        previous_list_element := list_element;
      IFEND;
    UNTIL ((NOT read_status.normal) AND (read_status.condition <> ave$insufficient_authority)) OR
          (account_name <> pvt [p$account].value^.name_value);

    IF (NOT read_status.normal) AND (read_status.condition <> ave$end_of_template_file) THEN
      status := read_status;
    IFEND;

{ If the list has not been created, make an empty list.

    IF result = NIL THEN
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
    IFEND;

  PROCEND avp$$project_list;
?? OLDTITLE ??
?? NEWTITLE := 'avp$$project_member_list', EJECT ??

{ PURPOSE:
{   Return a list containing the names of the project members for the specified account and project.

  PROCEDURE avp$$project_member_list
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$admv_pml) $project_member_list (
{   account: name = default__31__character__account
{   project: name = default__31__character__project
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (31),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (31),
      recend,
    recend := [
    [1,
    [88, 12, 15, 12, 10, 13, 126],
    clc$function, 2, 2, 0, 0, 0, 0, 0, 'OSM$$ADMV_PML'], [
    ['ACCOUNT                        ',clc$nominal_entry, 1],
    ['PROJECT                        ',clc$nominal_entry, 2]],
    [
{ 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, 5,
  clc$optional_default_parameter, 0, 31],
{ PARAMETER 2
    [2, 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, 5,
  clc$optional_default_parameter, 0, 31]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'default__31__character__account'],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'default__31__character__project']];

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

    CONST
      p$account = 1,
      p$project = 2;

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

    VAR
      account_name: avt$account_name,
      altered_pdt: ^clt$parameter_description_table,
      assigned_record_id: ost$name,
      list_element: ^clt$data_value,
      member_name: ost$user_name,
      pdt_changes: ^clt$pdt_changes,
      previous_list_element: ^clt$data_value,
      project_name: avt$project_name,
      read_status: ost$status;

    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the default value for the ACCOUNT parameter.

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$account;
    pdt_changes^ [1].kind := clc$pdtc_default_value;
    pdt_changes^ [1].default_value := ^default_account;
    pdt_changes^ [2].number := p$project;
    pdt_changes^ [2].kind := clc$pdtc_default_value;
    pdt_changes^ [2].default_value := ^default_project;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

{ Make sure a validation file has been opened.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

    result := NIL;

    IF NOT (avp$system_administrator () OR avp$family_administrator ()) THEN
      IF (NOT (account_administrator OR project_administrator)) OR
            (executing_account <> pvt [p$account].value^.name_value) OR
            (executing_project <> pvt [p$project].value^.name_value) THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        RETURN;
      IFEND;
    IFEND;

{ Return a list of all project members in the project.  Set up the validation file information so that the
{ next record to be read sequentially from the file will be the first project member record.

    validation_file_information.last_key_accessed (1, 31) := pvt [p$account].value^.name_value;
    validation_file_information.last_key_accessed (32, 31) := pvt [p$project].value^.name_value;
    validation_file_information.last_key_accessed (63, 31) := osc$null_name {user_name} ;

{ Read through the project member records making a list of all project member names.

    REPEAT
      account_name := pvt [p$account].value^.name_value;
      project_name := pvt [p$project].value^.name_value;
      member_name := osc$null_name;
      avp$read_project_member_record (account_name, project_name, member_name, assigned_record_id,
            validation_file_information, read_status);
      IF (read_status.normal) AND (account_name = pvt [p$account].value^.name_value) AND
            (project_name = pvt [p$project].value^.name_value) THEN
        make_scl_name_list_element (member_name, work_area, list_element, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF result = NIL THEN
          result := list_element;
        ELSE
          previous_list_element^.link := list_element;
        IFEND;
        previous_list_element := list_element;
      IFEND;
    UNTIL ((NOT read_status.normal) AND (read_status.condition <> ave$insufficient_authority)) OR
          ((account_name <> pvt [p$account].value^.name_value) OR
          (project_name <> pvt [p$project].value^.name_value));

    IF (NOT read_status.normal) AND (read_status.condition <> ave$end_of_template_file) THEN
      status := read_status;
    IFEND;

{ If the list has not been created, make an empty list.

    IF result = NIL THEN
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
    IFEND;

  PROCEND avp$$project_member_list;
?? OLDTITLE ??
?? NEWTITLE := 'avp$$user_list', EJECT ??

{ PURPOSE:
{   Return a list containing the names of the users that the executing user has control of.

  PROCEDURE avp$$user_list
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$admv_user_list) $user_list

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [88, 11, 29, 12, 25, 22, 338],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$ADMV_USER_LIST']];

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

    VAR
      assigned_record_id: ost$name,
      list_element: ^clt$data_value,
      previous_list_element: ^clt$data_value,
      read_user_status: ost$status,
      user_name: ost$user_name;

    status.normal := TRUE;

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

{ Make sure a validation file has been opened.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

    result := NIL;

{ Set up the validation file information so that the next record to be read sequentially from the file will be
{ the first user record.

    validation_file_information.last_key_accessed (1, 31) := avc$high_value_name {account_name} ;
    validation_file_information.last_key_accessed (32, 31) := avc$high_value_name {project_name} ;
    validation_file_information.last_key_accessed (63, 31) := osc$null_name {user_name} ;

{ Read through the user records making a list of the user names the executing user has control of.

    REPEAT
      user_name := osc$null_name;
      avp$read_user_record (user_name, assigned_record_id, validation_file_information, read_user_status);
      IF read_user_status.normal THEN

{ Release the space used by the avp$read_user_record call.

        avp$release_record_id (assigned_record_id, status);
        make_scl_name_list_element (user_name, work_area, list_element, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF result = NIL THEN
          result := list_element;
        ELSE
          previous_list_element^.link := list_element;
        IFEND;
        previous_list_element := list_element;
      IFEND;
    UNTIL (NOT read_user_status.normal) AND (read_user_status.condition <> ave$insufficient_authority);
    IF (NOT read_user_status.normal) AND (read_user_status.condition <> ave$end_of_template_file) THEN
      status := read_user_status;
    IFEND;

{ If the list has not been created, make an empty list.

    IF result = NIL THEN
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
    IFEND;

  PROCEND avp$$user_list;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'ADMINISTER_VALIDATIONS Subutility Function Processors', EJECT ??
?? NEWTITLE := 'avp$$current_object', EJECT ??

{ PURPOSE:
{   Return a record identifying the current object of an ADMV subutility session.

  PROCEDURE avp$$current_object
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$admv_co) $current_object

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 1, 5, 15, 59, 39, 912],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$ADMV_CO']];

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

    status.normal := TRUE;

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

    clp$make_record_value (4, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.field_values^ [1].name := 'TYPE';
    result^.field_values^ [2].name := 'USER';
    result^.field_values^ [3].name := 'ACCOUNT';
    result^.field_values^ [4].name := 'PROJECT';

    clp$make_name_value (current_subutility_session_info^.validation_record_name, work_area,
            result^.field_values^ [1].value);
    IF result^.field_values^ [1].value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

{ Fill in the user name for user, account member and project member records.

    IF (current_subutility_session_info^.validation_record_name = avc$user_record_name) OR
          (current_subutility_session_info^.validation_record_name = avc$account_member_record_name) OR
          (current_subutility_session_info^.validation_record_name = avc$project_member_record_name) THEN
      clp$make_name_value (current_subutility_session_info^.key.user_name, work_area,
            result^.field_values^ [2].value);
      IF result^.field_values^ [2].value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    ELSE
      clp$make_unspecified_value (work_area, result^.field_values^ [2].value);
      IF result^.field_values^ [2].value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

{ Fill in the account name for account, account member, project and project member records.

    IF (current_subutility_session_info^.validation_record_name = avc$account_record_name) OR
          (current_subutility_session_info^.validation_record_name = avc$account_member_record_name) OR
          (current_subutility_session_info^.validation_record_name = avc$project_record_name) OR
          (current_subutility_session_info^.validation_record_name = avc$project_member_record_name) THEN
      clp$make_name_value (current_subutility_session_info^.key.account_name, work_area,
            result^.field_values^ [3].value);
      IF result^.field_values^ [3].value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    ELSE
      clp$make_unspecified_value (work_area, result^.field_values^ [3].value);
      IF result^.field_values^ [3].value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

{ Fill in the project name for project and project member records.

    IF (current_subutility_session_info^.validation_record_name = avc$project_record_name) OR
          (current_subutility_session_info^.validation_record_name = avc$project_member_record_name) THEN
      clp$make_name_value (current_subutility_session_info^.key.project_name, work_area,
            result^.field_values^ [4].value);
      IF result^.field_values^ [4].value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    ELSE
      clp$make_unspecified_value (work_area, result^.field_values^ [4].value);
      IF result^.field_values^ [4].value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

  PROCEND avp$$current_object;
?? OLDTITLE ??
?? NEWTITLE := 'avp$$validation', EJECT ??

{ PURPOSE:
{   Return information about a specified validation field.

  PROCEDURE avp$$validation
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$admv_validation) $validation (
{   field_name: name = $required
{   option: key
{       (declared, d)
{       (type, t)
{       (value, v)
{     keyend = value
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (5),
      recend,
    recend := [
    [1,
    [88, 12, 14, 13, 47, 53, 379],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$ADMV_VALIDATION'], [
    ['FIELD_NAME                     ',clc$nominal_entry, 1],
    ['OPTION                         ',clc$nominal_entry, 2]],
    [
{ 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, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, 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, 229,
  clc$optional_default_parameter, 0, 5]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [6], [
    ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['DECLARED                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TYPE                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['V                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['VALUE                          ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ,
    'value']];

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

    CONST
      p$field_name = 1,
      p$option = 2;

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

    VAR
      account: avt$account_name,
      altered_pdt: ^clt$parameter_description_table,
      batch_default: ost$name,
      capability: boolean,
      change_date: ost$date_time,
      date_display_format: string(clc$max_date_time_form_string),
      date_time: avt$date_time,
      declared: ost$name,
      expiration_date: ost$date_time,
      expiration_interval: pmt$time_increment,
      expiration_warning_interval: pmt$time_increment,
      expired_password_chg_interval: pmt$time_increment,
      field_kind: avt$field_kind,
      field_work_area: ^seq (*),
      file_reference: fst$path,
      integer_value: integer,
      interactive_default: ost$name,
      job_limit_information: avt$job_limit_information,
      labeled_names: ^avt$labeled_names_list,
      keyword_type_changes: ^clt$type_changes,
      limit_value: avt$limit_value,
      local_status: ost$status,
      maximum_expiration_interval: pmt$time_increment,
      minimum_ring: ost$ring,
      name_list: ^avt$name_list,
      name_list_size: avt$name_list_size,
      nominal_ring: ost$ring,
      numeric_display_format: avt$numeric_display_format,
      pdt_changes: ^clt$pdt_changes,
      project: avt$project_name,
      real_value: real,
      string_value: ost$string,
      time_display_format: string(clc$max_date_time_form_string),
      total_limit_information: avt$total_limit_information;

    status.normal := TRUE;

{ Hide the VALUE keyword option if this is a field management subutility.

    IF current_subutility_session_info^.id = osc$null_name THEN

{ Make a copy of the PDT so it can be altered.

      PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
      RESET altered_pdt;
      altered_pdt^ := #SEQ(pdt)^;

      PUSH keyword_type_changes: [1 .. 1];
      keyword_type_changes^ [1].kind := clc$tc_keyword_availability;
      keyword_type_changes^ [1].keyword := 'VALUE                          ';
      keyword_type_changes^ [1].availability := clc$hidden_entry;

      PUSH pdt_changes: [1 .. 1];
      pdt_changes^ [1].number := p$option;
      pdt_changes^ [1].kind := clc$pdtc_type;
      pdt_changes^ [1].type_changes := keyword_type_changes;

      clp$change_pdt (altered_pdt, pdt_changes^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

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

    avp$get_validation_field_kind (pvt [p$field_name].value^.name_value,
          current_subutility_session_info^.validation_record_name, field_kind, validation_file_information,
          local_status);
    IF (NOT local_status.normal) AND (pvt [p$option].value^.keyword_value <> 'DECLARED') THEN
      status := local_status;
      RETURN;
    IFEND;

    IF (pvt [p$option].value^.keyword_value = 'DECLARED') THEN
      IF local_status.normal THEN
        declared := 'ACTIVE';
      ELSEIF local_status.condition = ave$field_was_deleted THEN
        declared := 'DELETED';
      ELSE
        declared := 'UNKNOWN';
      IFEND;
      clp$make_name_value (declared, work_area, result);
    ELSEIF pvt [p$option].value^.keyword_value = 'TYPE' THEN
      clp$make_name_value (avv$field_kind_names [field_kind], work_area, result);
    ELSE { VALUE }
      CASE field_kind OF
      = avc$account_project_kind =
        avp$get_acct_proj_display_value (pvt [p$field_name].value^.name_value,
              current_subutility_session_info^.id, account, project, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_acct_proj_scl_value (account, project, work_area, result, status);
      = avc$accumulating_limit_kind =
        avp$get_accum_limit_display_val (pvt [p$field_name].value^.name_value,
              current_subutility_session_info^.id, job_limit_information, total_limit_information,
              numeric_display_format, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_accum_limit_scl_value (job_limit_information, total_limit_information,
              numeric_display_format, work_area, result, status);
      = avc$capability_kind =
        avp$get_capabil_display_value (pvt [p$field_name].value^.name_value,
              current_subutility_session_info^.id, capability, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_capability_scl_value (capability, work_area, result, status);
      = avc$date_time_kind =
        avp$get_date_time_display_value (pvt [p$field_name].value^.name_value,
              current_subutility_session_info^.id, date_time, date_display_format, time_display_format,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_date_time_scl_value (date_time, work_area, result, status);
      = avc$file_kind =
        avp$get_file_display_value (pvt [p$field_name].value^.name_value,
              current_subutility_session_info^.id, file_reference, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ A file type validation field is returned as a string to avoid evaluation of the file reference.

        string_value.value := file_reference;
        string_value.size := clp$trimmed_string_size(file_reference);
        avp$make_string_scl_value (string_value, work_area, result, status);
      = avc$integer_kind =
        avp$get_integer_display_value (pvt [p$field_name].value^.name_value,
              current_subutility_session_info^.id, integer_value, numeric_display_format, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_integer_scl_value (integer_value, numeric_display_format, work_area, result, status);
      = avc$job_class_kind =
        PUSH name_list: [1 .. avc$maximum_name_list_size];
        avp$get_job_class_display_value (pvt [p$field_name].value^.name_value,
              current_subutility_session_info^.id, name_list^, name_list_size, batch_default,
              interactive_default, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_job_class_scl_value (batch_default, interactive_default, name_list^, name_list_size,
              work_area, result, status);
      = avc$keyword_kind =

{ Keywords are not implemented yet.

      = avc$labeled_names_kind =
        PUSH field_work_area: [[REP avc$max_template_record_size OF cell]];
        RESET field_work_area;
        avp$get_labeled_names_dis_value (pvt [p$field_name].value^.name_value,
              current_subutility_session_info^.id, field_work_area, labeled_names, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_labeled_names_scl_valu (labeled_names, work_area, result, status);
      = avc$limit_kind =
        avp$get_limit_display_value (pvt [p$field_name].value^.name_value,
              current_subutility_session_info^.id, limit_value, numeric_display_format, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_limit_scl_value (limit_value, numeric_display_format, work_area, result, status);
      = avc$login_password_kind =
        PUSH name_list: [1 .. avc$maximum_name_list_size];
        avp$get_login_pw_display_value (pvt [p$field_name].value^.name_value,
              current_subutility_session_info^.id, expiration_date, expiration_interval,
              maximum_expiration_interval, expiration_warning_interval, expired_password_chg_interval,
              change_date, name_list^, name_list_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_login_pw_scl_value (expiration_date, expiration_interval, maximum_expiration_interval,
              expiration_warning_interval, expired_password_chg_interval, change_date, name_list^,
              name_list_size, work_area, result, status);
      = avc$name_kind =
        PUSH name_list: [1 .. avc$maximum_name_list_size];
        avp$get_name_display_value (pvt [p$field_name].value^.name_value,
              current_subutility_session_info^.id, name_list^, name_list_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_name_scl_value (name_list^, name_list_size, work_area, result, status);
      = avc$real_kind =
        avp$get_real_display_value (pvt [p$field_name].value^.name_value,
              current_subutility_session_info^.id, real_value, numeric_display_format, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_real_scl_value (real_value, work_area, result, status);
      = avc$ring_privilege_kind =
        avp$get_ring_priv_display_value (pvt [p$field_name].value^.name_value,
              current_subutility_session_info^.id, minimum_ring, nominal_ring, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_ring_priv_scl_value (minimum_ring, nominal_ring, work_area, result, status);
      = avc$string_kind =
        avp$get_string_display_value (pvt [p$field_name].value^.name_value,
              current_subutility_session_info^.id, string_value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_string_scl_value (string_value, work_area, result, status);
      CASEND;
    IFEND;

  PROCEND avp$$validation;
?? OLDTITLE ??
?? NEWTITLE := 'avp$$validation_field_names', EJECT ??

{ PURPOSE:
{   Return a list containing the names of the families on this system.

  PROCEDURE avp$$validation_field_names
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$admv_vfn) $field_names, $fn (
{   option: key
{       (active, a)
{       (deleted, d)
{     keyend = active
{   type: key
{       (account_project, ap)
{       (accumulating_limit, al)
{       (capability, capabilities, c)
{       (date_time, dt)
{       (file, f)
{       (integer, i)
{       (job_class, jc)
{       (labeled_names, ln)
{       (limit, l)
{       (login_password, lpw)
{       (name, n)
{       (real, r)
{       (ring_privilege, rp)
{       (string, s)
{       all
{     keyend = all
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (6),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 30] of clt$keyword_specification,
        default_value: string (3),
      recend,
    recend := [
    [1,
    [89, 5, 11, 14, 31, 7, 544],
    clc$function, 2, 2, 0, 0, 0, 0, 0, 'OSM$$ADMV_VFN'], [
    ['OPTION                         ',clc$nominal_entry, 1],
    ['TYPE                           ',clc$nominal_entry, 2]],
    [
{ 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, 155,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 2
    [2, 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, 1117,
  clc$optional_default_parameter, 0, 3]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [4], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['DELETED                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'active'],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [30], [
    ['ACCOUNT_PROJECT                ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ACCUMULATING_LIMIT             ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['AL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 15],
    ['AP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['CAPABILITIES                   ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['CAPABILITY                     ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['DATE_TIME                      ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['DT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['FILE                           ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['INTEGER                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['JC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
    ['JOB_CLASS                      ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
    ['LABELED_NAMES                  ', clc$nominal_entry, clc$normal_usage_entry, 8],
    ['LIMIT                          ', clc$nominal_entry, clc$normal_usage_entry, 9],
    ['LN                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
    ['LOGIN_PASSWORD                 ', clc$nominal_entry, clc$normal_usage_entry, 10],
    ['LPW                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
    ['NAME                           ', clc$nominal_entry, clc$normal_usage_entry, 11],
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
    ['REAL                           ', clc$nominal_entry, clc$normal_usage_entry, 12],
    ['RING_PRIVILEGE                 ', clc$nominal_entry, clc$normal_usage_entry, 13],
    ['RP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
    ['STRING                         ', clc$nominal_entry, clc$normal_usage_entry, 14]]
    ,
    'all']];

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

    CONST
      p$option = 1,
      p$type = 2;

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

    VAR
      field_names: ^array [1 .. * ] of ost$name,
      field_kind: avt$field_kind,
      field_kind_set: avt$field_kind_set,
      index: avt$field_count,
      list_element: ^clt$data_value,
      number_of_fields: avt$field_count,
      previous_list_element: ^clt$data_value,
      return_deleted_fields: boolean;

    status.normal := TRUE;

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

    return_deleted_fields :=  pvt [p$option].value^.keyword_value = 'DELETED';

{ Select specified type.

    IF pvt [p$type].value^.keyword_value = 'ALL' THEN
      field_kind_set := -$avt$field_kind_set [];
    ELSE
      field_kind_set := $avt$field_kind_set [];
    /get_field_kind/
      FOR field_kind := LOWERVALUE(field_kind) TO UPPERVALUE(field_kind) DO
        IF pvt [p$type].value^.keyword_value = avv$field_kind_names [field_kind] THEN
          field_kind_set := $avt$field_kind_set [field_kind];
          EXIT /get_field_kind/;
        IFEND;
      FOREND /get_field_kind/;
    IFEND;

    number_of_fields := 50;
    REPEAT
      PUSH field_names: [1 .. number_of_fields];
        avp$get_validation_field_names (current_subutility_session_info^.validation_record_name,
              field_kind_set, return_deleted_fields, field_names^, number_of_fields,
              validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
    UNTIL number_of_fields <= UPPERBOUND (field_names^);

    result := NIL;

    FOR index := 1 TO number_of_fields DO
      make_scl_name_list_element (field_names^ [index], work_area, list_element, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF result = NIL THEN
        result := list_element;
      ELSE
        previous_list_element^.link := list_element;
      IFEND;
      previous_list_element := list_element;
    FOREND;

{ If the list has not been created, make an empty list.

    IF result = NIL THEN
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
    IFEND;

  PROCEND avp$$validation_field_names;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'Create/Change Subutility Commands', EJECT ??
?? NEWTITLE := 'avp$change_acct_proj_command', EJECT ??

{ PURPOSE:
{   This is the command processor used to change the value of any
{   ACCOUNT_PROJECT fields.

  PROCEDURE [XDCL] avp$change_acct_proj_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chaapc) change_account_project_command, chaapc (
{   account, a: any of
{       key
{         current, default, none
{       keyend
{       name
{     anyend = $optional
{   project, p: any of
{       key
{         current, default, none
{       keyend
{       name
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] 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 .. 3] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type2: 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 .. 3] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 4, 21, 14, 30, 1, 235], clc$command, 5, 3, 0, 0, 0, 0, 3, 'OSM$ADMV_CHAAPC'],
            [['A                              ', clc$abbreviation_entry, 1],
            ['ACCOUNT                        ', clc$nominal_entry, 1],
            ['P                              ', clc$abbreviation_entry, 2],
            ['PROJECT                        ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 143, clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 143, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 118,
            [[1, 0, clc$keyword_type], [3], [['CURRENT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 3]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 118,
            [[1, 0, clc$keyword_type], [3], [['CURRENT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 3]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$account = 1,
      p$project = 2,
      p$status = 3;

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

    VAR
      account: ^avt$account_name,
      altered_pdt: ^clt$parameter_description_table,
      change_authority: avt$validation_authority,
      command_name: ost$name,
      default_account: avt$account_name,
      default_project: avt$project_name,
      delete_authority: avt$validation_authority,
      description: ost$string,
      display_authority: avt$validation_authority,
      field_name: ost$name,
      manage_authority: avt$validation_authority,
      pdt_changes: ^clt$pdt_changes,
      project: ^avt$project_name;

    status.normal := TRUE;

{ Determine what field to change and get its field description.

    avp$get_field_name (current_subutility_session_info^.id, field_name, command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$get_acct_proj_field_desc (field_name, current_subutility_session_info^.validation_record_name,
          current_subutility_session_info^.id, default_account, default_project, description,
          change_authority, delete_authority, display_authority, manage_authority,
          validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Set the SECURE attribute if necessary.

    IF display_authority = avc$system_authority THEN

{ Make a copy of the PDT so it can be altered.

      PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
      RESET altered_pdt;
      altered_pdt^ := #SEQ (pdt) ^;

      PUSH pdt_changes: [1 .. 2];
      pdt_changes^ [1].number := p$account;
      pdt_changes^ [1].kind := clc$pdtc_security;
      pdt_changes^ [1].security := clc$secure_parameter;
      pdt_changes^ [2].number := p$project;
      pdt_changes^ [2].kind := clc$pdtc_security;
      pdt_changes^ [2].security := clc$secure_parameter;

      clp$change_pdt (altered_pdt, pdt_changes^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

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

    IF pvt [p$account].specified THEN
      IF pvt [p$account].value^.kind = clc$keyword THEN
        IF pvt [p$account].value^.keyword_value = 'CURRENT' THEN
          account := ^executing_account;
        ELSEIF pvt [p$account].value^.keyword_value = 'DEFAULT' THEN
          account := ^default_account;
        ELSE
          account := ^pvt [p$account].value^.keyword_value;
        IFEND;
      ELSE
        account := ^pvt [p$account].value^.name_value;
      IFEND;
    ELSE
      account := NIL;
    IFEND;

    IF pvt [p$project].specified THEN
      IF pvt [p$project].value^.kind = clc$keyword THEN
        IF pvt [p$project].value^.keyword_value = 'CURRENT' THEN
          project := ^executing_project;
        ELSEIF pvt [p$project].value^.keyword_value = 'DEFAULT' THEN
          project := ^default_project;
        ELSE
          project := ^pvt [p$project].value^.keyword_value;
        IFEND;
      ELSE
        project := ^pvt [p$project].value^.name_value;
      IFEND;
    ELSE
      project := NIL;
    IFEND;

    avp$change_acct_proj_value (field_name, account, project, current_subutility_session_info^.id,
          validation_file_information, status);

  PROCEND avp$change_acct_proj_command;
?? OLDTITLE ??
?? NEWTITLE := 'avp$change_accum_limit_command', EJECT ??

{ PURPOSE:
{   This is the command processor used to change the value of any
{   ACCUMULATING_LIMIT fields.

  PROCEDURE [XDCL] avp$change_accum_limit_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chaalc) change_accum_limit_command, chaalc (
{   job_warning_limit, jwl: (BY_NAME) any of
{       key
{         default, unlimited
{       keyend
{       integer 0..osc$max_integer
{     anyend = $optional
{   job_maximum_limit, jmaxl: (BY_NAME) any of
{       key
{         default, unlimited
{       keyend
{       integer 0..osc$max_integer
{     anyend = $optional
{   total_limit, tl: (BY_NAME) any of
{       key
{         default, unlimited
{       keyend
{       integer 0..osc$max_integer
{     anyend = $optional
{   total_accumulation, ta: (BY_NAME) integer 0..osc$max_integer = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 9] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type2: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type3: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 12, 15, 11, 48, 946], clc$command, 9, 5, 0, 0, 0, 0, 5, 'OSM$ADMV_CHAALC'],
            [['JMAXL                          ', clc$abbreviation_entry, 2],
            ['JOB_MAXIMUM_LIMIT              ', clc$nominal_entry, 2],
            ['JOB_WARNING_LIMIT              ', clc$nominal_entry, 1],
            ['JWL                            ', clc$abbreviation_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 5],
            ['TA                             ', clc$abbreviation_entry, 4],
            ['TL                             ', clc$abbreviation_entry, 3],
            ['TOTAL_ACCUMULATION             ', clc$nominal_entry, 4],
            ['TOTAL_LIMIT                    ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
            clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
            clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
            clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
            clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 20, [[1, 0, clc$integer_type], [0, osc$max_integer, 10]]],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 20, [[1, 0, clc$integer_type], [0, osc$max_integer, 10]]],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 20, [[1, 0, clc$integer_type], [0, osc$max_integer, 10]]],

{ PARAMETER 4

      [[1, 0, clc$integer_type], [0, osc$max_integer, 10]],

{ PARAMETER 5

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$job_warning_limit = 1,
      p$job_maximum_limit = 2,
      p$total_limit = 3,
      p$total_accumulation = 4,
      p$status = 5;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: avt$validation_authority,
      command_name: ost$name,
      default_job_warning_limit: avt$limit_value,
      default_job_maximum_limit: avt$limit_value,
      default_total_limit: avt$limit_value,
      default_total_accumulation: avt$limit_value,
      delete_authority: avt$validation_authority,
      description: ost$string,
      display_authority: avt$validation_authority,
      field_name: ost$name,
      job_limit_type_changes: ^clt$type_changes,
      job_limits_apply: boolean,
      job_maximum_limit: ^avt$limit_value,
      job_warning_limit: ^avt$limit_value,
      limit_name: ost$name,
      limit_update_statistics: ^sft$limit_update_statistics,
      manage_authority: avt$validation_authority,
      maximum_job_limit_value: avt$limit_value,
      minimum_job_limit_value: avt$limit_value,
      number_of_limit_update_stats: avt$name_list_size,
      pdt_changes: ^clt$pdt_changes,
      total_accumulation: ^avt$limit_value,
      total_limit: ^avt$limit_value,
      total_limit_applies: boolean,
      total_limit_stops_login: boolean;


    status.normal := TRUE;

{ Determine what field to change and get its field description.

    avp$get_field_name (current_subutility_session_info^.id, field_name, command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH limit_update_statistics: [1 .. avc$maximum_name_list_size];

    avp$get_accum_limit_field_desc (field_name, current_subutility_session_info^.validation_record_name,
          current_subutility_session_info^.id, default_job_warning_limit, default_job_maximum_limit,
          default_total_limit, default_total_accumulation, limit_name, job_limits_apply,
          minimum_job_limit_value, maximum_job_limit_value, number_of_limit_update_stats,
          limit_update_statistics, total_limit_applies, total_limit_stops_login, description,
          change_authority, delete_authority, display_authority, manage_authority,
          validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Change the PDT to hide parameters and keywords that should not be used.  Also set the minimum and maximum
{ values for the job warning and job maximum values.

    PUSH pdt_changes: [1 .. 8];
    IF job_limits_apply THEN
      PUSH job_limit_type_changes: [1 .. 2];
      job_limit_type_changes^ [1].kind := clc$tc_integer_subrange;
      job_limit_type_changes^ [1].min_integer_value := minimum_job_limit_value;
      job_limit_type_changes^ [1].max_integer_value := maximum_job_limit_value;
      job_limit_type_changes^ [2].kind := clc$tc_keyword_availability;
      job_limit_type_changes^ [2].keyword := 'UNLIMITED';
      IF maximum_job_limit_value = sfc$unlimited THEN
        job_limit_type_changes^ [2].availability := clc$normal_usage_entry;
      ELSE
        job_limit_type_changes^ [2].availability := clc$hidden_entry;
      IFEND;

      pdt_changes^ [1].number := p$job_warning_limit;
      pdt_changes^ [1].kind := clc$pdtc_type;
      pdt_changes^ [1].type_changes := job_limit_type_changes;
      pdt_changes^ [2].number := p$job_maximum_limit;
      pdt_changes^ [2].kind := clc$pdtc_type;
      pdt_changes^ [2].type_changes := job_limit_type_changes;
    ELSE
      pdt_changes^ [1].number := p$job_warning_limit;
      pdt_changes^ [1].kind := clc$pdtc_availability;
      pdt_changes^ [1].availability := clc$hidden_entry;
      pdt_changes^ [2].number := p$job_maximum_limit;
      pdt_changes^ [2].kind := clc$pdtc_availability;
      pdt_changes^ [2].availability := clc$hidden_entry;
    IFEND;
    IF total_limit_applies THEN
      pdt_changes^ [3].number := p$total_limit;
      pdt_changes^ [3].kind := clc$pdtc_null;
      pdt_changes^ [4].number := p$total_accumulation;
      pdt_changes^ [4].kind := clc$pdtc_null;
    ELSE
      pdt_changes^ [3].number := p$total_limit;
      pdt_changes^ [3].kind := clc$pdtc_availability;
      pdt_changes^ [3].availability := clc$hidden_entry;
      pdt_changes^ [4].number := p$total_accumulation;
      pdt_changes^ [4].kind := clc$pdtc_availability;
      pdt_changes^ [4].availability := clc$hidden_entry;
    IFEND;

{ Set the SECURE attribute if necessary.

    pdt_changes^ [5].number := p$job_warning_limit;
    pdt_changes^ [5].kind := clc$pdtc_security;
    pdt_changes^ [6].number := p$job_maximum_limit;
    pdt_changes^ [6].kind := clc$pdtc_security;
    pdt_changes^ [7].number := p$total_limit;
    pdt_changes^ [7].kind := clc$pdtc_security;
    pdt_changes^ [8].number := p$total_accumulation;
    pdt_changes^ [8].kind := clc$pdtc_security;
    IF display_authority = avc$system_authority THEN
      pdt_changes^ [5].security := clc$secure_parameter;
      pdt_changes^ [6].security := clc$secure_parameter;
      pdt_changes^ [7].security := clc$secure_parameter;
      pdt_changes^ [8].security := clc$secure_parameter;
    ELSE
      pdt_changes^ [5].security := clc$non_secure_parameter;
      pdt_changes^ [6].security := clc$non_secure_parameter;
      pdt_changes^ [7].security := clc$non_secure_parameter;
      pdt_changes^ [8].security := clc$non_secure_parameter;
    IFEND;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    IF job_limits_apply THEN
      process_limit_parameter (pvt [p$job_warning_limit].value, ^default_job_warning_limit,
            job_warning_limit);

      process_limit_parameter (pvt [p$job_maximum_limit].value, ^default_job_maximum_limit,
            job_maximum_limit);
    ELSE
      job_warning_limit := NIL;
      job_maximum_limit := NIL;
    IFEND;

    IF total_limit_applies THEN
      process_limit_parameter (pvt [p$total_limit].value, ^default_total_limit, total_limit);

      process_limit_parameter (pvt [p$total_accumulation].value, ^default_total_accumulation,
            total_accumulation);
    ELSE
      total_limit := NIL;
      total_accumulation := NIL;
    IFEND;

    avp$change_accum_limit_value (field_name, job_warning_limit, job_maximum_limit, total_limit,
          total_accumulation, current_subutility_session_info^.id, validation_file_information, status);

  PROCEND avp$change_accum_limit_command;
?? OLDTITLE ??
?? NEWTITLE := 'avp$change_capability_command', EJECT ??

{ PURPOSE:
{   This is the command processor used to change the value of any
{   CAPABILITY fields.
{
{ NOTES:
{   Each capability is stored in the validation file as a separate field.

  PROCEDURE [XDCL] avp$change_capability_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chacc) change_capability, change_capabilities, chac (
{   add, a: (BY_NAME, CHECK) any of
{       key
{         all, none
{       keyend
{       list of name
{     anyend = none
{   delete, d: (BY_NAME, CHECK) any of
{       key
{         all, none
{       keyend
{       list of name
{     anyend = none
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] 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 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (4),
        recend,
        type2: 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 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (4),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 12, 15, 14, 22, 297], clc$command, 5, 3, 0, 0, 0, 0, 3, 'OSM$ADMV_CHACC'],
            [['A                              ', clc$abbreviation_entry, 1],
            ['ADD                            ', clc$nominal_entry, 1],
            ['D                              ', clc$abbreviation_entry, 2],
            ['DELETE                         ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 122,
            clc$optional_default_parameter, 0, 4],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 122,
            clc$optional_default_parameter, 0, 4],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'none'],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'none'],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$add = 1,
      p$delete = 2,
      p$status = 3;

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

    VAR
      capability_field_count: avt$field_count,
      capability_field_names: ^array [1 .. * ] of ost$name,
      capability_value: boolean,
      change_status: ost$status,
      current_parameter_value: ^clt$data_value,
      ignore_status: ost$status,
      index: avt$field_count;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        IF which_parameter.number = p$add THEN
          verify_field_names_value ('ADD', parameter_value_table^ [p$add].value,
                current_subutility_session_info^.validation_record_name,
                $avt$field_kind_set [avc$capability_kind], status);
        ELSEIF which_parameter.number = p$delete THEN
          verify_field_names_value ('DELETE', parameter_value_table^ [p$delete].value,
                current_subutility_session_info^.validation_record_name,
                $avt$field_kind_set [avc$capability_kind], status);
        ELSE

{ Ignore the parameter.

        IFEND;
      IFEND;

      IF (NOT status.normal) AND (status.condition = ave$unknown_field) THEN
        status.condition := ave$unknown_capability;
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

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

    change_status.normal := TRUE;
    capability_field_names := NIL;

{ Delete any specified capabilities.

    capability_value := FALSE;
    IF pvt [p$delete].value^.kind = clc$keyword THEN
      IF pvt [p$delete].value^.keyword_value = 'ALL' THEN
        PUSH capability_field_names: [1 .. avc$maximum_field_count];
        avp$get_validation_field_names (current_subutility_session_info^.validation_record_name,
              $avt$field_kind_set [avc$capability_kind], FALSE, capability_field_names^,
              capability_field_count, validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        FOR index := 1 TO capability_field_count DO
          avp$change_capability_value (capability_field_names^ [index], ^capability_value,
                current_subutility_session_info^.id, validation_file_information, ignore_status);
        FOREND;
      IFEND;
    ELSE { list of names}
      current_parameter_value := pvt [p$delete].value;
      REPEAT
        avp$change_capability_value (current_parameter_value^.element_value^.name_value, ^capability_value,
              current_subutility_session_info^.id, validation_file_information, status);
        IF NOT status.normal THEN
          IF (status.condition = ave$insufficient_authority) THEN
            status.normal := TRUE;
            IF change_status.normal THEN
              osp$set_status_abnormal ('AV', ave$cannot_change_capability,
                    current_parameter_value^.element_value^.name_value, change_status);
            ELSE
              osp$append_status_parameter (',', current_parameter_value^.element_value^.name_value,
                    change_status);
            IFEND;
          ELSE
            RETURN;
          IFEND;
        IFEND;
        current_parameter_value := current_parameter_value^.link;
      UNTIL current_parameter_value = NIL;
    IFEND;

{ Add any specified capabilities.

    capability_value := TRUE;
    IF pvt [p$add].value^.kind = clc$keyword THEN
      IF pvt [p$add].value^.keyword_value = 'ALL' THEN
        IF capability_field_names = NIL THEN
          PUSH capability_field_names: [1 .. avc$maximum_field_count];
          avp$get_validation_field_names (current_subutility_session_info^.validation_record_name,
                $avt$field_kind_set [avc$capability_kind], FALSE, capability_field_names^,
                capability_field_count, validation_file_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        FOR index := 1 TO capability_field_count DO
          avp$change_capability_value (capability_field_names^ [index], ^capability_value,
                current_subutility_session_info^.id, validation_file_information, ignore_status);
        FOREND;
      IFEND;
    ELSE { list of names}
      current_parameter_value := pvt [p$add].value;
      REPEAT
        avp$change_capability_value (current_parameter_value^.element_value^.name_value, ^capability_value,
              current_subutility_session_info^.id, validation_file_information, status);
        IF NOT status.normal THEN
          IF (status.condition = ave$insufficient_authority) THEN
            status.normal := TRUE;
            IF change_status.normal THEN
              osp$set_status_abnormal ('AV', ave$cannot_change_capability,
                    current_parameter_value^.element_value^.name_value, change_status);
            ELSE
              osp$append_status_parameter (',', current_parameter_value^.element_value^.name_value,
                    change_status);
            IFEND;
          ELSE
            RETURN;
          IFEND;
        IFEND;
        current_parameter_value := current_parameter_value^.link;
      UNTIL current_parameter_value = NIL;
    IFEND;

    status := change_status;

  PROCEND avp$change_capability_command;
?? OLDTITLE ??
?? NEWTITLE := 'avp$change_date_time_command', EJECT ??

{ PURPOSE:
{   This is the command processor used to change the value of any
{   DATE_TIME fields.

  PROCEDURE [XDCL] avp$change_date_time_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      change_authority: avt$validation_authority,
      command_name: ost$name,
      date_applies: boolean,
      date_display_format: string (clc$max_date_time_form_string),
      date_time_range: boolean,
      date_time_value: ^avt$date_time,
      default_value: avt$date_time,
      delete_authority: avt$validation_authority,
      description: ost$string,
      display_authority: avt$validation_authority,
      field_name: ost$name,
      manage_authority: avt$validation_authority,
      parameter_value: ^clt$data_value,
      time_applies: boolean,
      time_display_format: string (clc$max_date_time_form_string);

?? NEWTITLE := 'change_date_range_value', EJECT ??

{ PURPOSE:
{   This procedure contains the code used to define and parse the parameters
{   for the change_date_time command when a range is required and dates apply.

    PROCEDURE change_date_range_value
      (    parameter_list: clt$parameter_list;
       VAR parameter_value: ^clt$data_value;
       VAR status: ost$status);

{ PROCEDURE (osm$admv_chadrc) change_date_range_command, chadrc (
{   value, v: any of
{       key
{         default
{       keyend
{       range of date
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

      VAR
        pdt: [STATIC, READ, cls$declaration_section] record
          header: clt$pdt_header,
          names: array [1 .. 3] of clt$pdt_parameter_name,
          parameters: array [1 .. 2] 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$range_type_qualifier,
              element_type_spec: record
                header: clt$type_specification_header,
                qualifier: clt$date_time_type_qualifier,
              recend,
            recend,
          recend,
          type2: record
            header: clt$type_specification_header,
          recend,
        recend := [[1, [88, 5, 2, 10, 30, 45, 725], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMV_CHADRC'],
              [['STATUS                         ', clc$nominal_entry, 2],
              ['V                              ', clc$abbreviation_entry, 1],
              ['VALUE                          ', clc$nominal_entry, 1]], [

{ PARAMETER 1

        [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
              clc$standard_parameter_checking, 76, clc$optional_parameter, 0, 0],

{ PARAMETER 2

        [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
              clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

        [[1, 0, clc$union_type], [[clc$keyword_type, clc$range_type], FALSE, 2], 44,
              [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
              clc$normal_usage_entry, 1]]], 12, [[1, 0, clc$range_type], [5], [[1, 0, clc$date_time_type],
              [$clt$date_and_or_time [clc$date], $clt$date_time_tenses
              [clc$past, clc$present, clc$future]]]]],

{ PARAMETER 2

        [[1, 0, clc$status_type]]];

?? POP ??

      CONST
        p$value = 1,
        p$status = 2;

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

      VAR
        altered_pdt: ^clt$parameter_description_table,
        pdt_changes: ^clt$pdt_changes;

      status.normal := TRUE;

{ Set the SECURE attribute if necessary.

      IF display_authority = avc$system_authority THEN

{ Make a copy of the PDT so it can be altered.

        PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
        RESET altered_pdt;
        altered_pdt^ := #SEQ (pdt) ^;

        PUSH pdt_changes: [1 .. 1];
        pdt_changes^ [1].number := p$value;
        pdt_changes^ [1].kind := clc$pdtc_security;
        pdt_changes^ [1].security := clc$secure_parameter;

        clp$change_pdt (altered_pdt, pdt_changes^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

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

{ Get the new value if one was specified.

      parameter_value := pvt [p$value].value;

    PROCEND change_date_range_value;
?? OLDTITLE ??
?? NEWTITLE := 'change_date_value', EJECT ??

{ PURPOSE:
{   This procedure contains the code used to define and parse the parameters
{   for the change_date_time command when a range is not allowed and dates apply.

    PROCEDURE change_date_value
      (    parameter_list: clt$parameter_list;
       VAR parameter_value: ^clt$data_value;
       VAR status: ost$status);

{ PROCEDURE (osm$admv_chadc) change_date_command, chadc (
{   value, v: any of
{       key
{         default
{       keyend
{       date
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

      VAR
        pdt: [STATIC, READ, cls$declaration_section] record
          header: clt$pdt_header,
          names: array [1 .. 3] of clt$pdt_parameter_name,
          parameters: array [1 .. 2] 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$date_time_type_qualifier,
            recend,
          recend,
          type2: record
            header: clt$type_specification_header,
          recend,
        recend := [[1, [88, 5, 2, 10, 38, 38, 978], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMV_CHADC'],
              [['STATUS                         ', clc$nominal_entry, 2],
              ['V                              ', clc$abbreviation_entry, 1],
              ['VALUE                          ', clc$nominal_entry, 1]], [

{ PARAMETER 1

        [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
              clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],

{ PARAMETER 2

        [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
              clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

        [[1, 0, clc$union_type], [[clc$date_time_type, clc$keyword_type], FALSE, 2], 44,
              [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
              clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$date_time_type],
              [$clt$date_and_or_time [clc$date], $clt$date_time_tenses [clc$past, clc$present, clc$future]]]],

{ PARAMETER 2

        [[1, 0, clc$status_type]]];

?? POP ??

      CONST
        p$value = 1,
        p$status = 2;

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

      VAR
        altered_pdt: ^clt$parameter_description_table,
        pdt_changes: ^clt$pdt_changes;

      status.normal := TRUE;

{ Set the SECURE attribute if necessary.

      IF display_authority = avc$system_authority THEN

{ Make a copy of the PDT so it can be altered.

        PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
        RESET altered_pdt;
        altered_pdt^ := #SEQ (pdt) ^;

        PUSH pdt_changes: [1 .. 1];
        pdt_changes^ [1].number := p$value;
        pdt_changes^ [1].kind := clc$pdtc_security;
        pdt_changes^ [1].security := clc$secure_parameter;

        clp$change_pdt (altered_pdt, pdt_changes^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

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

{ Get the new value if one was specified.

      parameter_value := pvt [p$value].value;

    PROCEND change_date_value;
?? OLDTITLE ??
?? NEWTITLE := 'change_date_time_range_value', EJECT ??

{ PURPOSE:
{   This procedure contains the code used to define and parse the parameters
{   for the change_date_time command when a range is required and dates and
{   times apply.

    PROCEDURE change_date_time_range_value
      (    parameter_list: clt$parameter_list;
       VAR parameter_value: ^clt$data_value;
       VAR status: ost$status);

{ PROCEDURE (osm$admv_chadtrc) change_date_time_range_command, chadtrc (
{   value, v: any of
{       key
{         default
{       keyend
{       range of date_time
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

      VAR
        pdt: [STATIC, READ, cls$declaration_section] record
          header: clt$pdt_header,
          names: array [1 .. 3] of clt$pdt_parameter_name,
          parameters: array [1 .. 2] 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$range_type_qualifier,
              element_type_spec: record
                header: clt$type_specification_header,
                qualifier: clt$date_time_type_qualifier,
              recend,
            recend,
          recend,
          type2: record
            header: clt$type_specification_header,
          recend,
        recend := [[1, [88, 5, 2, 10, 20, 16, 471], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMV_CHADTRC'],
              [['STATUS                         ', clc$nominal_entry, 2],
              ['V                              ', clc$abbreviation_entry, 1],
              ['VALUE                          ', clc$nominal_entry, 1]], [

{ PARAMETER 1

        [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
              clc$standard_parameter_checking, 76, clc$optional_parameter, 0, 0],

{ PARAMETER 2

        [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
              clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

        [[1, 0, clc$union_type], [[clc$keyword_type, clc$range_type], FALSE, 2], 44,
              [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
              clc$normal_usage_entry, 1]]], 12, [[1, 0, clc$range_type], [5], [[1, 0, clc$date_time_type],
              [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses
              [clc$past, clc$present, clc$future]]]]],

{ PARAMETER 2

        [[1, 0, clc$status_type]]];

?? POP ??

      CONST
        p$value = 1,
        p$status = 2;

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

      VAR
        altered_pdt: ^clt$parameter_description_table,
        pdt_changes: ^clt$pdt_changes;

      status.normal := TRUE;

{ Set the SECURE attribute if necessary.

      IF display_authority = avc$system_authority THEN

{ Make a copy of the PDT so it can be altered.

        PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
        RESET altered_pdt;
        altered_pdt^ := #SEQ (pdt) ^;

        PUSH pdt_changes: [1 .. 1];
        pdt_changes^ [1].number := p$value;
        pdt_changes^ [1].kind := clc$pdtc_security;
        pdt_changes^ [1].security := clc$secure_parameter;

        clp$change_pdt (altered_pdt, pdt_changes^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

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

{ Get the new value if one was specified.

      parameter_value := pvt [p$value].value;

    PROCEND change_date_time_range_value;
?? OLDTITLE ??
?? NEWTITLE := 'change_date_time_value', EJECT ??

{ PURPOSE:
{   This procedure contains the code used to define and parse the parameters
{   for the change_date_time command when a range is not allowed and dates and
{   times apply.

    PROCEDURE change_date_time_value
      (    parameter_list: clt$parameter_list;
       VAR parameter_value: ^clt$data_value;
       VAR status: ost$status);

{ PROCEDURE (osm$admv_chadtc) change_date_time_command, chadtc (
{   value, v: any of
{       key
{         default
{       keyend
{       date_time
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

      VAR
        pdt: [STATIC, READ, cls$declaration_section] record
          header: clt$pdt_header,
          names: array [1 .. 3] of clt$pdt_parameter_name,
          parameters: array [1 .. 2] 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$date_time_type_qualifier,
            recend,
          recend,
          type2: record
            header: clt$type_specification_header,
          recend,
        recend := [[1, [88, 5, 2, 10, 28, 22, 191], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMV_CHADTC'],
              [['STATUS                         ', clc$nominal_entry, 2],
              ['V                              ', clc$abbreviation_entry, 1],
              ['VALUE                          ', clc$nominal_entry, 1]], [

{ PARAMETER 1

        [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
              clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],

{ PARAMETER 2

        [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
              clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

        [[1, 0, clc$union_type], [[clc$date_time_type, clc$keyword_type], FALSE, 2], 44,
              [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
              clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$date_time_type],
              [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses
              [clc$past, clc$present, clc$future]]]],

{ PARAMETER 2

        [[1, 0, clc$status_type]]];

?? POP ??

      CONST
        p$value = 1,
        p$status = 2;

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

      VAR
        altered_pdt: ^clt$parameter_description_table,
        pdt_changes: ^clt$pdt_changes;

      status.normal := TRUE;

{ Set the SECURE attribute if necessary.

      IF display_authority = avc$system_authority THEN

{ Make a copy of the PDT so it can be altered.

        PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
        RESET altered_pdt;
        altered_pdt^ := #SEQ (pdt) ^;

        PUSH pdt_changes: [1 .. 1];
        pdt_changes^ [1].number := p$value;
        pdt_changes^ [1].kind := clc$pdtc_security;
        pdt_changes^ [1].security := clc$secure_parameter;

        clp$change_pdt (altered_pdt, pdt_changes^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

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

{ Get the new value if one was specified.

      parameter_value := pvt [p$value].value;

    PROCEND change_date_time_value;
?? OLDTITLE ??
?? NEWTITLE := 'change_time_range_value', EJECT ??

{ PURPOSE:
{   This procedure contains the code used to define and parse the parameters
{   for the change_date_time command when a range is required and times apply.

    PROCEDURE change_time_range_value
      (    parameter_list: clt$parameter_list;
       VAR parameter_value: ^clt$data_value;
       VAR status: ost$status);

{ PROCEDURE (osm$admv_chatrc) change_time_range_command, chatrc (
{   value, v: any of
{       key
{         default
{       keyend
{       range of time
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

      VAR
        pdt: [STATIC, READ, cls$declaration_section] record
          header: clt$pdt_header,
          names: array [1 .. 3] of clt$pdt_parameter_name,
          parameters: array [1 .. 2] 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$range_type_qualifier,
              element_type_spec: record
                header: clt$type_specification_header,
                qualifier: clt$date_time_type_qualifier,
              recend,
            recend,
          recend,
          type2: record
            header: clt$type_specification_header,
          recend,
        recend := [[1, [88, 5, 2, 10, 34, 4, 242], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMV_CHATRC'],
              [['STATUS                         ', clc$nominal_entry, 2],
              ['V                              ', clc$abbreviation_entry, 1],
              ['VALUE                          ', clc$nominal_entry, 1]], [

{ PARAMETER 1

        [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
              clc$standard_parameter_checking, 76, clc$optional_parameter, 0, 0],

{ PARAMETER 2

        [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
              clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

        [[1, 0, clc$union_type], [[clc$keyword_type, clc$range_type], FALSE, 2], 44,
              [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
              clc$normal_usage_entry, 1]]], 12, [[1, 0, clc$range_type], [5], [[1, 0, clc$date_time_type],
              [$clt$date_and_or_time [clc$time], $clt$date_time_tenses
              [clc$past, clc$present, clc$future]]]]],

{ PARAMETER 2

        [[1, 0, clc$status_type]]];

?? POP ??

      CONST
        p$value = 1,
        p$status = 2;

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

      VAR
        altered_pdt: ^clt$parameter_description_table,
        pdt_changes: ^clt$pdt_changes;

      status.normal := TRUE;

{ Set the SECURE attribute if necessary.

      IF display_authority = avc$system_authority THEN

{ Make a copy of the PDT so it can be altered.

        PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
        RESET altered_pdt;
        altered_pdt^ := #SEQ (pdt) ^;

        PUSH pdt_changes: [1 .. 1];
        pdt_changes^ [1].number := p$value;
        pdt_changes^ [1].kind := clc$pdtc_security;
        pdt_changes^ [1].security := clc$secure_parameter;

        clp$change_pdt (altered_pdt, pdt_changes^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

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

{ Get the new value if one was specified.

      parameter_value := pvt [p$value].value;

    PROCEND change_time_range_value;
?? OLDTITLE ??
?? NEWTITLE := 'change_time_value', EJECT ??

{ PURPOSE:
{   This procedure contains the code used to define and parse the parameters
{   for the change_date_time command when a range is not allowed and times apply.

    PROCEDURE change_time_value
      (    parameter_list: clt$parameter_list;
       VAR parameter_value: ^clt$data_value;
       VAR status: ost$status);

{ PROCEDURE (osm$admv_chatc) change_time_command, chatc (
{   value, v: any of
{       key
{         default
{       keyend
{       time
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

      VAR
        pdt: [STATIC, READ, cls$declaration_section] record
          header: clt$pdt_header,
          names: array [1 .. 3] of clt$pdt_parameter_name,
          parameters: array [1 .. 2] 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$date_time_type_qualifier,
            recend,
          recend,
          type2: record
            header: clt$type_specification_header,
          recend,
        recend := [[1, [88, 5, 2, 10, 35, 9, 954], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMV_CHATC'],
              [['STATUS                         ', clc$nominal_entry, 2],
              ['V                              ', clc$abbreviation_entry, 1],
              ['VALUE                          ', clc$nominal_entry, 1]], [

{ PARAMETER 1

        [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
              clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],

{ PARAMETER 2

        [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
              clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

        [[1, 0, clc$union_type], [[clc$date_time_type, clc$keyword_type], FALSE, 2], 44,
              [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
              clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$date_time_type],
              [$clt$date_and_or_time [clc$time], $clt$date_time_tenses [clc$past, clc$present, clc$future]]]],

{ PARAMETER 2

        [[1, 0, clc$status_type]]];

?? POP ??

      CONST
        p$value = 1,
        p$status = 2;

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

      VAR
        altered_pdt: ^clt$parameter_description_table,
        pdt_changes: ^clt$pdt_changes;

      status.normal := TRUE;

{ Set the SECURE attribute if necessary.

      IF display_authority = avc$system_authority THEN

{ Make a copy of the PDT so it can be altered.

        PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
        RESET altered_pdt;
        altered_pdt^ := #SEQ (pdt) ^;

        PUSH pdt_changes: [1 .. 1];
        pdt_changes^ [1].number := p$value;
        pdt_changes^ [1].kind := clc$pdtc_security;
        pdt_changes^ [1].security := clc$secure_parameter;

        clp$change_pdt (altered_pdt, pdt_changes^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

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

{ Get the new value if one was specified.

      parameter_value := pvt [p$value].value;

    PROCEND change_time_value;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Determine what field to change and get its field description.

    avp$get_field_name (current_subutility_session_info^.id, field_name, command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$get_date_time_field_desc (field_name, current_subutility_session_info^.validation_record_name,
          current_subutility_session_info^.id, default_value, date_time_range, date_applies, time_applies,
          date_display_format, time_display_format, description, change_authority, delete_authority,
          display_authority, manage_authority, validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Use the appropriate PDT based on whether the field is a range and whether dates
{ apply, times apply or both dates and times apply.

    IF date_time_range THEN
      IF date_applies AND time_applies THEN
        change_date_time_range_value (parameter_list, parameter_value, status);
      ELSEIF date_applies THEN
        change_date_range_value (parameter_list, parameter_value, status);
      ELSE {time_applies}
        change_time_range_value (parameter_list, parameter_value, status);
      IFEND;
    ELSE
      IF date_applies AND time_applies THEN
        change_date_time_value (parameter_list, parameter_value, status);
      ELSEIF date_applies THEN
        change_date_value (parameter_list, parameter_value, status);
      ELSE {time_applies}
        change_time_value (parameter_list, parameter_value, status);
      IFEND;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter_value <> NIL THEN
      PUSH date_time_value;
      IF parameter_value^.kind = clc$keyword THEN
        date_time_value^ := default_value;
      ELSEIF parameter_value^.kind = clc$range THEN
        date_time_value^.range := TRUE;
        date_time_value^.date_specified := parameter_value^.low_value^.date_time_value.date_specified;
        date_time_value^.time_specified := parameter_value^.low_value^.date_time_value.time_specified;
        date_time_value^.starting_value := parameter_value^.low_value^.date_time_value.value;
        date_time_value^.ending_value := parameter_value^.high_value^.date_time_value.value;
      ELSE
        date_time_value^.range := FALSE;
        date_time_value^.date_specified := parameter_value^.date_time_value.date_specified;
        date_time_value^.time_specified := parameter_value^.date_time_value.time_specified;
        date_time_value^.value := parameter_value^.date_time_value.value;
      IFEND;

      avp$change_date_time_value (field_name, date_time_value, current_subutility_session_info^.id,
            validation_file_information, status);
    IFEND;

  PROCEND avp$change_date_time_command;
?? OLDTITLE ??
?? NEWTITLE := 'avp$change_file_command', EJECT ??

{ PURPOSE:
{   This is the command processor used to change the value of any FILE fields.

  PROCEDURE [XDCL] avp$change_file_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chafc) change_file_command, chafc (
{   value, v: (CHECK) any of
{       key
{         default, none
{       keyend
{       file
{       string
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
          type_size_3: clt$type_specification_size,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 2, 12, 17, 49, 861], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMV_CHAFC'],
            [['STATUS                         ', clc$nominal_entry, 2],
            ['V                              ', clc$abbreviation_entry, 1],
            ['VALUE                          ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$extended_parameter_checking, 116, clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type, clc$string_type], FALSE, 3], 81,
            [[1, 0, clc$keyword_type], [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 3, [[1, 0, clc$file_type]], 8,
            [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$value = 1,
      p$status = 2;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: avt$validation_authority,
      command_name: ost$name,
      default_value: string (fsc$max_path_size),
      delete_authority: avt$validation_authority,
      description: ost$string,
      display_authority: avt$validation_authority,
      field_name: ost$name,
      file_reference: ^fst$file_reference,
      manage_authority: avt$validation_authority,
      pdt_changes: ^clt$pdt_changes;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
        evaluated_file_reference: fst$evaluated_file_reference;

      status.normal := TRUE;

      IF (which_parameter.specific) AND (which_parameter.number = p$value) THEN

{ If a string value was specified, verify that it is a correctly formed file reference.

        IF parameter_value_table^ [p$value].value^.kind = clc$string THEN
          clp$evaluate_file_reference (parameter_value_table^ [p$value].value^.file_value^,
                $clt$file_ref_parsing_options[], TRUE, evaluated_file_reference, status);
        IFEND;
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Determine what field to change and get its field description.

    avp$get_field_name (current_subutility_session_info^.id, field_name, command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$get_file_field_desc (field_name, current_subutility_session_info^.validation_record_name,
          current_subutility_session_info^.id, default_value, description, change_authority, delete_authority,
          display_authority, manage_authority, validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Set the SECURE attribute if necessary.

    IF display_authority = avc$system_authority THEN

{ Make a copy of the PDT so it can be altered.

      PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
      RESET altered_pdt;
      altered_pdt^ := #SEQ (pdt) ^;

      PUSH pdt_changes: [1 .. 1];
      pdt_changes^ [1].number := p$value;
      pdt_changes^ [1].kind := clc$pdtc_security;
      pdt_changes^ [1].security := clc$secure_parameter;

      clp$change_pdt (altered_pdt, pdt_changes^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

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

    process_file_parameter (pvt [p$value].value, ^default_value, file_reference);

    avp$change_file_value (field_name, file_reference, current_subutility_session_info^.id,
          validation_file_information, status);

  PROCEND avp$change_file_command;
?? OLDTITLE ??
?? NEWTITLE := 'avp$change_integer_command', EJECT ??

{ PURPOSE:
{   This is the command processor used to change the value of any INTEGER fields.

  PROCEDURE [XDCL] avp$change_integer_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chaic) change_integer_command, chaic (
{   value, v: any of
{       key
{         default
{       keyend
{       integer
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] 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$integer_type_qualifier,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 10, 15, 6, 43, 610], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMV_CHAIC'],
            [['STATUS                         ', clc$nominal_entry, 2],
            ['V                              ', clc$abbreviation_entry, 1],
            ['VALUE                          ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type],
            [clc$min_integer, clc$max_integer, 10]]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$value = 1,
      p$status = 2;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: avt$validation_authority,
      command_name: ost$name,
      default_value: integer,
      delete_authority: avt$validation_authority,
      description: ost$string,
      display_authority: avt$validation_authority,
      display_format: avt$numeric_display_format,
      field_name: ost$name,
      integer_type_changes: ^clt$type_changes,
      integer_value: ^integer,
      manage_authority: avt$validation_authority,
      maximum_value: integer,
      minimum_value: integer,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

{ Determine what field to change and get its field description.

    avp$get_field_name (current_subutility_session_info^.id, field_name, command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$get_integer_field_desc (field_name, current_subutility_session_info^.validation_record_name,
          current_subutility_session_info^.id, default_value, minimum_value, maximum_value, display_format,
          description, change_authority, delete_authority, display_authority, manage_authority,
          validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the minimum and maximum values.

    PUSH integer_type_changes: [1 .. 1];
    integer_type_changes^ [1].kind := clc$tc_integer_subrange;
    integer_type_changes^ [1].min_integer_value := minimum_value;
    integer_type_changes^ [1].max_integer_value := maximum_value;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$value;
    pdt_changes^ [1].kind := clc$pdtc_type;
    pdt_changes^ [1].type_changes := integer_type_changes;
    pdt_changes^ [2].number := p$value;
    pdt_changes^ [2].kind := clc$pdtc_security;
    IF display_authority = avc$system_authority THEN
      pdt_changes^ [2].security := clc$secure_parameter;
    ELSE
      pdt_changes^ [2].security := clc$non_secure_parameter;
    IFEND;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    IF pvt [p$value].specified THEN
      IF pvt [p$value].value^.kind = clc$keyword THEN
        integer_value := ^default_value;
      ELSE
        integer_value := ^pvt [p$value].value^.integer_value.value;
      IFEND;

      avp$change_integer_value (field_name, integer_value, current_subutility_session_info^.id,
            validation_file_information, status);
    IFEND;

  PROCEND avp$change_integer_command;
?? OLDTITLE ??
?? NEWTITLE := 'avp$change_job_class_command', EJECT ??

{ PURPOSE:
{   This is the command processor used to change the value of the JOB_CLASS
{   field.

  PROCEDURE [XDCL] avp$change_job_class_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chajcc) change_job_class_command, chajcc (
{   add, a: (BY_NAME, CHECK) any of
{       key
{         all, default, none
{       keyend
{       list 1..256 of name
{     anyend = none
{   delete, d: (BY_NAME, CHECK) any of
{       key
{         all, default, none
{       keyend
{       list 1..256 of name
{     anyend = none
{   interactive_default, id: (BY_NAME) any of
{       key
{         default, none
{       keyend
{       name
{     anyend = $optional
{   batch_default, bd: (BY_NAME) any of
{       key
{         default, none
{       keyend
{       name
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 9] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] 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 .. 3] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (4),
        recend,
        type2: 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 .. 3] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (4),
        recend,
        type3: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type4: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 16, 11, 58, 38, 534], clc$command, 9, 5, 0, 0, 0, 0, 5, 'OSM$ADMV_CHAJCC'],
            [['A                              ', clc$abbreviation_entry, 1],
            ['ADD                            ', clc$nominal_entry, 1],
            ['BATCH_DEFAULT                  ', clc$nominal_entry, 4],
            ['BD                             ', clc$abbreviation_entry, 4],
            ['D                              ', clc$abbreviation_entry, 2],
            ['DELETE                         ', clc$nominal_entry, 2],
            ['ID                             ', clc$abbreviation_entry, 3],
            ['INTERACTIVE_DEFAULT            ', clc$nominal_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 5]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 159,
            clc$optional_default_parameter, 0, 4],

{ PARAMETER 2

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 159,
            clc$optional_default_parameter, 0, 4],

{ PARAMETER 3

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 106,
            clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 106,
            clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 118,
            [[1, 0, clc$keyword_type], [3], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 3]]], 21, [[1, 0, clc$list_type],
            [5, 1, 256, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'none'],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 118,
            [[1, 0, clc$keyword_type], [3], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 3]]], 21, [[1, 0, clc$list_type],
            [5, 1, 256, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'none'],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 5

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$add = 1,
      p$delete = 2,
      p$interactive_default = 3,
      p$batch_default = 4,
      p$status = 5;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      batch_default: ^ost$name,
      batch_job_class_default: ost$name,
      change_authority: avt$validation_authority,
      command_name: ost$name,
      common_job_classes: ^avt$name_list,
      current_parameter_value: ^clt$data_value,
      default_job_classes: ^avt$name_list,
      delete_authority: avt$validation_authority,
      description: ost$string,
      display_authority: avt$validation_authority,
      field_name: ost$name,
      index: avt$name_list_size,
      interactive_default: ^ost$name,
      interactive_job_class_default: ost$name,
      job_classes_to_add: ^avt$name_list,
      job_classes_to_delete: ^avt$name_list,
      manage_authority: avt$validation_authority,
      name_list_size: avt$name_list_size,
      number_of_common_job_classes: avt$name_list_size,
      number_of_default_job_classes: avt$name_list_size,
      pdt_changes: ^clt$pdt_changes;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        IF which_parameter.number = p$add THEN
          verify_list_of_names_value ('ADD', parameter_value_table^ [p$add].value, status);
        ELSEIF which_parameter.number = p$delete THEN
          verify_list_of_names_value ('DELETE', parameter_value_table^ [p$delete].value, status);
        ELSE

{ ignore the parameter.

        IFEND;
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Determine what field to change and get its field description.

    avp$get_field_name (current_subutility_session_info^.id, field_name, command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH common_job_classes: [1 .. avc$maximum_name_list_size];
    PUSH default_job_classes: [1 .. avc$maximum_name_list_size];
    FOR index := 1 TO avc$maximum_name_list_size DO
      common_job_classes^ [index] := osc$null_name;
      default_job_classes^ [index] := osc$null_name;
    FOREND;

    avp$get_job_class_field_desc (field_name, current_subutility_session_info^.validation_record_name,
          current_subutility_session_info^.id, number_of_default_job_classes, default_job_classes,
          batch_job_class_default, interactive_job_class_default, number_of_common_job_classes,
          common_job_classes, description, change_authority, delete_authority, display_authority,
          manage_authority, validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Set the SECURE attribute if necessary.

    IF display_authority = avc$system_authority THEN

{ Make a copy of the PDT so it can be altered.

      PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
      RESET altered_pdt;
      altered_pdt^ := #SEQ (pdt) ^;

      PUSH pdt_changes: [1 .. 4];
      pdt_changes^ [1].number := p$add;
      pdt_changes^ [1].kind := clc$pdtc_security;
      pdt_changes^ [1].security := clc$secure_parameter;
      pdt_changes^ [2].number := p$delete;
      pdt_changes^ [2].kind := clc$pdtc_security;
      pdt_changes^ [2].security := clc$secure_parameter;
      pdt_changes^ [3].number := p$interactive_default;
      pdt_changes^ [3].kind := clc$pdtc_security;
      pdt_changes^ [3].security := clc$secure_parameter;
      pdt_changes^ [4].number := p$batch_default;
      pdt_changes^ [4].kind := clc$pdtc_security;
      pdt_changes^ [4].security := clc$secure_parameter;

      clp$change_pdt (altered_pdt, pdt_changes^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

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

    process_name_list_parameter (pvt [p$add].value, default_job_classes, job_classes_to_add);

    process_name_list_parameter (pvt [p$delete].value, default_job_classes, job_classes_to_delete);

    IF pvt [p$interactive_default].specified THEN
      IF pvt [p$interactive_default].value^.kind = clc$keyword THEN
        IF pvt [p$interactive_default].value^.keyword_value = 'DEFAULT' THEN
          interactive_default := ^interactive_job_class_default;
        ELSE
          interactive_default := ^pvt [p$interactive_default].value^.keyword_value;
        IFEND;
      ELSE
        interactive_default := ^pvt [p$interactive_default].value^.name_value;
      IFEND;
    ELSE
      interactive_default := NIL;
    IFEND;

    IF pvt [p$batch_default].specified THEN
      IF pvt [p$batch_default].value^.kind = clc$keyword THEN
        IF pvt [p$batch_default].value^.keyword_value = 'DEFAULT' THEN
          batch_default := ^batch_job_class_default;
        ELSE
          batch_default := ^pvt [p$batch_default].value^.keyword_value;
        IFEND;
      ELSE
        batch_default := ^pvt [p$batch_default].value^.name_value;
      IFEND;
    ELSE
      batch_default := NIL;
    IFEND;

    avp$change_job_class_value (field_name, job_classes_to_add, job_classes_to_delete, batch_default,
          interactive_default, current_subutility_session_info^.id, validation_file_information, status);

  PROCEND avp$change_job_class_command;
?? OLDTITLE ??
?? NEWTITLE := 'avp$change_labeled_names_cmd', EJECT ??

{ PURPOSE:
{   This is the command processor used to change the value of any LABELED_NAMES fields.

  PROCEDURE [XDCL] avp$change_labeled_names_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      add_parameter_value: ^clt$data_value,
      change_authority: avt$validation_authority,
      command_name: ost$name,
      current_parameter_value: ^clt$data_value,
      default_labeled_names: ^avt$labeled_names_list,
      delete_authority: avt$validation_authority,
      delete_parameter_value: ^clt$data_value,
      description: ost$string,
      display_authority: avt$validation_authority,
      field_name: ost$name,
      index: avt$name_list_size,
      labeled_names_to_add: ^avt$labeled_names_list,
      labeled_names_to_delete: ^avt$labeled_names_list,
      manage_authority: avt$validation_authority,
      number_of_valid_labels: avt$name_list_size,
      number_of_valid_names: avt$name_list_size,
      valid_labels: ^avt$name_list,
      valid_names: ^avt$name_list,
      work_area: ^seq (*);

?? NEWTITLE := 'change_labeled_names_value', EJECT ??

    PROCEDURE change_labeled_names_value
      (    parameter_list: clt$parameter_list;
       VAR add_parameter_value: ^clt$data_value;
       VAR delete_parameter_list: ^clt$data_value;
       VAR status: ost$status);

{ PROCEDURE (osm$admv_chalnc) change_labeled_names_command, chalnc (
{   add, a: (BY_NAME, CHECK) any of
{       key
{         default
{       keyend
{       list 1..256 of record
{         label: any of
{           key
{             all, none
{           keyend
{           name
{         anyend
{         names: any of
{           key
{             all, none
{           keyend
{           list of name
{         anyend = $optional
{       recend
{     anyend = ((none))
{   delete, d: (BY_NAME, CHECK) any of
{       key
{         default
{       keyend
{       list 1..256 of record
{         label: any of
{           key
{             all, none
{           keyend
{           name
{         anyend
{         names: any of
{           key
{             all, none
{           keyend
{           list of name
{         anyend = $optional
{       recend
{     anyend = ((none))
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: 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 .. 2] of clt$keyword_specification,
              recend,
              type_size_2: clt$type_specification_size,
              element_type_spec_2: record
                header: clt$type_specification_header,
                qualifier: clt$name_type_qualifier,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: 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 .. 2] 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,
                element_type_spec: record
                  header: clt$type_specification_header,
                  qualifier: clt$name_type_qualifier,
                recend,
              recend,
            recend,
          recend,
        recend,
        default_value: string (8),
      recend,
      type2: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: 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 .. 2] of clt$keyword_specification,
              recend,
              type_size_2: clt$type_specification_size,
              element_type_spec_2: record
                header: clt$type_specification_header,
                qualifier: clt$name_type_qualifier,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: 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 .. 2] 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,
                element_type_spec: record
                  header: clt$type_specification_header,
                  qualifier: clt$name_type_qualifier,
                recend,
              recend,
            recend,
          recend,
        recend,
        default_value: string (8),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 30, 12, 6, 26, 618],
    clc$command, 5, 3, 0, 0, 0, 0, 3, 'OSM$ADMV_CHALNC'], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['ADD                            ',clc$nominal_entry, 1],
    ['D                              ',clc$abbreviation_entry, 2],
    ['DELETE                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 387,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 387,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    323, [[1, 0, clc$list_type], [307, 1, 256, FALSE],
        [[1, 0, clc$record_type], [2],
        ['LABEL                          ', clc$required_field, 106], [[1, 0, clc$union_type], [[
          clc$keyword_type, clc$name_type],
          FALSE, 2],
          81, [[1, 0, clc$keyword_type], [2], [
            ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
            ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
            ],
          5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
          ],
        ['NAMES                          ', clc$optional_field, 122], [[1, 0, clc$union_type], [[
          clc$keyword_type, clc$list_type],
          FALSE, 2],
          81, [[1, 0, clc$keyword_type], [2], [
            ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
            ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
            ],
          21, [[1, 0, clc$list_type], [5, 0, clc$max_list_size, FALSE],
              [[1, 0, clc$name_type], [1, osc$max_name_size]]
            ]
          ]
        ]
      ]
    ,
    '((none))'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    323, [[1, 0, clc$list_type], [307, 1, 256, FALSE],
        [[1, 0, clc$record_type], [2],
        ['LABEL                          ', clc$required_field, 106], [[1, 0, clc$union_type], [[
          clc$keyword_type, clc$name_type],
          FALSE, 2],
          81, [[1, 0, clc$keyword_type], [2], [
            ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
            ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
            ],
          5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
          ],
        ['NAMES                          ', clc$optional_field, 122], [[1, 0, clc$union_type], [[
          clc$keyword_type, clc$list_type],
          FALSE, 2],
          81, [[1, 0, clc$keyword_type], [2], [
            ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
            ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
            ],
          21, [[1, 0, clc$list_type], [5, 0, clc$max_list_size, FALSE],
              [[1, 0, clc$name_type], [1, osc$max_name_size]]
            ]
          ]
        ]
      ]
    ,
    '((none))'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

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

    CONST
      p$add = 1,
      p$delete = 2,
      p$status = 3;

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

?? NEWTITLE := 'check_parameters', EJECT ??

      PROCEDURE check_parameters
        (    parameter_value_table: ^clt$parameter_value_table;
             which_parameter: clt$which_parameter;
         VAR status: ost$status);

        status.normal := TRUE;

        IF which_parameter.specific THEN
          IF which_parameter.number = p$add THEN
            verify_labeled_names_value ('ADD', parameter_value_table^ [p$add].value, status);
          ELSEIF which_parameter.number = p$delete THEN
            verify_labeled_names_value ('DELETE', parameter_value_table^ [p$delete].value, status);
          ELSE

{ ignore the parameter.

          IFEND;
        IFEND;

      PROCEND check_parameters;
?? OLDTITLE, EJECT ??
      status.normal := TRUE;

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

      add_parameter_value := pvt [p$add].value;
      delete_parameter_value := pvt [p$delete].value;

    PROCEND change_labeled_names_value;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Determine what field to change and get its field description.

    avp$get_field_name (current_subutility_session_info^.id, field_name, command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH valid_labels: [1 .. avc$maximum_name_list_size];
    PUSH valid_names: [1 .. avc$maximum_name_list_size];
    PUSH work_area: [[REP avc$max_template_record_size OF cell]];
    RESET work_area;
    FOR index := 1 TO avc$maximum_name_list_size DO
      valid_labels^ [index] := osc$null_name;
      valid_names^ [index] := osc$null_name;
    FOREND;

    avp$get_labeled_names_field_des (field_name, current_subutility_session_info^.validation_record_name,
          current_subutility_session_info^.id, work_area,
          default_labeled_names, number_of_valid_labels, valid_labels, number_of_valid_names, valid_names,
          description, change_authority, delete_authority, display_authority, manage_authority,
          validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    change_labeled_names_value (parameter_list, add_parameter_value, delete_parameter_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_labeled_names_parameter (add_parameter_value, default_labeled_names, labeled_names_to_add);

    process_labeled_names_parameter (delete_parameter_value, default_labeled_names, labeled_names_to_delete);

    avp$change_labeled_names_value (field_name, labeled_names_to_add, labeled_names_to_delete,
          current_subutility_session_info^.id, validation_file_information, status);

  PROCEND avp$change_labeled_names_cmd;
?? OLDTITLE ??
?? NEWTITLE := 'avp$change_limit_command', EJECT ??

{ PURPOSE:
{   This is the command processor used to change the value of any LIMIT fields.

  PROCEDURE [XDCL] avp$change_limit_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chalc) change_limit_command, chalc (
{   value, v: any of
{       key
{         default, unlimited
{       keyend
{       integer 0..osc$max_integer
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 10, 15, 10, 21, 764], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMV_CHALC'],
            [['STATUS                         ', clc$nominal_entry, 2],
            ['V                              ', clc$abbreviation_entry, 1],
            ['VALUE                          ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 121, clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 20, [[1, 0, clc$integer_type], [0, osc$max_integer, 10]]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$value = 1,
      p$status = 2;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: avt$validation_authority,
      command_name: ost$name,
      default_value: avt$limit_value,
      delete_authority: avt$validation_authority,
      description: ost$string,
      display_authority: avt$validation_authority,
      field_name: ost$name,
      limit_name: ost$name,
      limit_value: ^avt$limit_value,
      limit_type_changes: ^clt$type_changes,
      manage_authority: avt$validation_authority,
      maximum_limit_value: avt$limit_value,
      minimum_limit_value: avt$limit_value,
      parameter: clt$value,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

{ Determine what field to change and get its field description.

    avp$get_field_name (current_subutility_session_info^.id, field_name, command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$get_limit_field_desc (field_name, current_subutility_session_info^.validation_record_name,
          current_subutility_session_info^.id, default_value, minimum_limit_value, maximum_limit_value,
          description, change_authority, delete_authority, display_authority, manage_authority,
          validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the minimum and maximum values.  Also hide the keyword unlimited if necessary.

    PUSH limit_type_changes: [1 .. 2];
    limit_type_changes^ [1].kind := clc$tc_integer_subrange;
    limit_type_changes^ [1].min_integer_value := minimum_limit_value;
    limit_type_changes^ [1].max_integer_value := maximum_limit_value;
    limit_type_changes^ [2].kind := clc$tc_keyword_availability;
    limit_type_changes^ [2].keyword := 'UNLIMITED';
    IF maximum_limit_value = sfc$unlimited THEN
      limit_type_changes^ [2].availability := clc$normal_usage_entry;
    ELSE
      limit_type_changes^ [2].availability := clc$hidden_entry;
    IFEND;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$value;
    pdt_changes^ [1].kind := clc$pdtc_type;
    pdt_changes^ [1].type_changes := limit_type_changes;
    pdt_changes^ [2].number := p$value;
    pdt_changes^ [2].kind := clc$pdtc_security;
    IF display_authority = avc$system_authority THEN
      pdt_changes^ [2].security := clc$secure_parameter;
    ELSE
      pdt_changes^ [2].security := clc$non_secure_parameter;
    IFEND;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    process_limit_parameter (pvt [p$value].value, ^default_value, limit_value);

    avp$change_limit_value (field_name, limit_value, current_subutility_session_info^.id,
          validation_file_information, status);

  PROCEND avp$change_limit_command;
?? OLDTITLE ??
?? NEWTITLE := 'avp$change_login_password_cmd', EJECT ??

{ PURPOSE:
{   This is the command processor used to change the value of the
{   LOGIN_PASSWORD field.

  PROCEDURE [XDCL] avp$change_login_password_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chalpw) change_login_password, chalpw (
{   old_password, opw: (SECURE) name = $optional
{   new_password, npw: (SECURE) name = $optional
{   expiration_date, ed: (BY_NAME) any of
{       key
{         default, none
{       keyend
{       date_time
{     anyend = $optional
{   expiration_interval, ei: (BY_NAME) any of
{       key
{         default, unlimited
{       keyend
{       integer 1..365
{     anyend = $optional
{   expiration_warning_interval, ewi: (BY_NAME) any of
{       key
{         default, unlimited
{       keyend
{       integer 0..365
{     anyend = $optional
{   maximum_expiration_interval, maxei: (BY_NAME) any of
{       key
{         default, unlimited
{       keyend
{       integer 1..365
{     anyend = $optional
{   add_attributes, aa: (BY_NAME, CHECK) any of
{       key
{         all, default, none
{       keyend
{       list 1..256 of name
{     anyend = none
{   delete_attributes, da: (BY_NAME, CHECK) any of
{       key
{         all, default, none
{       keyend
{       list 1..256 of name
{     anyend = none
{   update_batch_job_passwords, ubjpw: (BY_NAME) boolean = osd$admv_chalpw_ubjpw,..
{      TRUE
{   encrypted_password, epw: (BY_NAME, HIDDEN, SECURE) string 31 = $optional
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 21] of clt$pdt_parameter_name,
      parameters: array [1 .. 11] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$date_time_type_qualifier,
        recend,
      recend,
      type4: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type5: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type6: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type7: 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 .. 3] 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (4),
      recend,
      type8: 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 .. 3] 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (4),
      recend,
      type9: record
        header: clt$type_specification_header,
        default_name: string (21),
        default_value: string (4),
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type11: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 6, 1, 17, 9, 52, 398],
    clc$command, 21, 11, 0, 0, 1, 0, 11, 'OSM$ADMV_CHALPW'], [
    ['AA                             ',clc$abbreviation_entry, 7],
    ['ADD_ATTRIBUTES                 ',clc$nominal_entry, 7],
    ['DA                             ',clc$abbreviation_entry, 8],
    ['DELETE_ATTRIBUTES              ',clc$nominal_entry, 8],
    ['ED                             ',clc$abbreviation_entry, 3],
    ['EI                             ',clc$abbreviation_entry, 4],
    ['ENCRYPTED_PASSWORD             ',clc$nominal_entry, 10],
    ['EPW                            ',clc$abbreviation_entry, 10],
    ['EWI                            ',clc$abbreviation_entry, 5],
    ['EXPIRATION_DATE                ',clc$nominal_entry, 3],
    ['EXPIRATION_INTERVAL            ',clc$nominal_entry, 4],
    ['EXPIRATION_WARNING_INTERVAL    ',clc$nominal_entry, 5],
    ['MAXEI                          ',clc$abbreviation_entry, 6],
    ['MAXIMUM_EXPIRATION_INTERVAL    ',clc$nominal_entry, 6],
    ['NEW_PASSWORD                   ',clc$nominal_entry, 2],
    ['NPW                            ',clc$abbreviation_entry, 2],
    ['OLD_PASSWORD                   ',clc$nominal_entry, 1],
    ['OPW                            ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 11],
    ['UBJPW                          ',clc$abbreviation_entry, 9],
    ['UPDATE_BATCH_JOB_PASSWORDS     ',clc$nominal_entry, 9]],
    [
{ PARAMETER 1
    [17, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [15, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 106, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 121, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 121, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 121, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$extended_parameter_checking, 159, clc$optional_default_parameter, 0, 4],
{ PARAMETER 8
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$extended_parameter_checking, 159, clc$optional_default_parameter, 0, 4],
{ PARAMETER 9
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 21, 4],
{ PARAMETER 10
    [7, clc$hidden_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$date_time_type,
    clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time
  ], $clt$date_time_tenses [clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [1, 365, 10]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [0, 365, 10]]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [1, 365, 10]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, 256, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'none'],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, 256, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'none'],
{ PARAMETER 9
    [[1, 0, clc$boolean_type],
    'OSD$ADMV_CHALPW_UBJPW',
    'TRUE'],
{ PARAMETER 10
    [[1, 0, clc$string_type], [31, 31, FALSE]],
{ PARAMETER 11
    [[1, 0, clc$status_type]]];

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

    CONST
      p$old_password = 1,
      p$new_password = 2,
      p$expiration_date = 3,
      p$expiration_interval = 4,
      p$expiration_warning_interval = 5,
      p$maximum_expiration_interval = 6,
      p$add_attributes = 7,
      p$delete_attributes = 8,
      p$update_batch_job_passwords = 9,
      p$encrypted_password = 10,
      p$status = 11;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      attributes_to_add: ^avt$name_list,
      attributes_to_delete: ^avt$name_list,
      change_authority: avt$validation_authority,
      command_name: ost$name,
      current_parameter_value: ^clt$data_value,
      default_attributes: ^avt$name_list,
      default_expiration_date: ost$date_time,
      default_expiration_interval: pmt$time_increment,
      default_exp_pw_chg_interval: pmt$time_increment,
      default_exp_warning_interval: pmt$time_increment,
      default_max_expiration_interval: pmt$time_increment,
      default_password: avt$login_password,
      delete_authority: avt$validation_authority,
      description: ost$string,
      display_authority: avt$validation_authority,
      expiration_date: ^ost$date_time,
      expiration_interval: ^pmt$time_increment,
      expiration_warning_interval: ^pmt$time_increment,
      index: avt$name_list_size,
      manage_authority: avt$validation_authority,
      maximum_expiration_interval: ^pmt$time_increment,
      new_password: ^avt$login_password,
      number_of_default_attributes: avt$name_list_size,
      old_password: ^ost$name,
      pdt_changes: ^clt$pdt_changes;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        IF which_parameter.number = p$add_attributes THEN
          verify_list_of_names_value ('ADD_ATTRIBUTES', parameter_value_table^ [p$add_attributes].value,
                status);
        ELSEIF which_parameter.number = p$delete_attributes THEN
          verify_list_of_names_value ('DELETE_ATTRIBUTES', parameter_value_table^ [p$delete_attributes].value,
                status);
        ELSE

{ ignore the parameter.

        IFEND;
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Hide the  MAXIMUM_EXPIRATION_INTERVAL, ADD_ATTRIBUTES and DELETE_ATTRIBUTES
{ parameters if the user is not able to use them.

    PUSH pdt_changes: [1 .. 9];
    pdt_changes^ [1].number := p$maximum_expiration_interval;
    pdt_changes^ [1].kind := clc$pdtc_availability;
    pdt_changes^ [2].number := p$add_attributes;
    pdt_changes^ [2].kind := clc$pdtc_availability;
    pdt_changes^ [3].number := p$delete_attributes;
    pdt_changes^ [3].kind := clc$pdtc_availability;
    IF NOT (avp$system_administrator () OR avp$family_administrator () OR user_administrator) THEN
      pdt_changes^ [1].availability := clc$advanced_usage_entry;
      pdt_changes^ [2].availability := clc$advanced_usage_entry;
      pdt_changes^ [3].availability := clc$advanced_usage_entry;
    ELSE
      pdt_changes^ [1].availability := clc$normal_usage_entry;
      pdt_changes^ [2].availability := clc$normal_usage_entry;
      pdt_changes^ [3].availability := clc$normal_usage_entry;
    IFEND;
    pdt_changes^ [4].number := p$expiration_date;
    pdt_changes^ [4].kind := clc$pdtc_security;
    pdt_changes^ [5].number := p$expiration_interval;
    pdt_changes^ [5].kind := clc$pdtc_security;
    pdt_changes^ [6].number := p$expiration_warning_interval;
    pdt_changes^ [6].kind := clc$pdtc_security;
    pdt_changes^ [7].number := p$maximum_expiration_interval;
    pdt_changes^ [7].kind := clc$pdtc_security;
    pdt_changes^ [8].number := p$add_attributes;
    pdt_changes^ [8].kind := clc$pdtc_security;
    pdt_changes^ [9].number := p$delete_attributes;
    pdt_changes^ [9].kind := clc$pdtc_security;
    IF display_authority = avc$system_authority THEN
      pdt_changes^ [4].security := clc$secure_parameter;
      pdt_changes^ [5].security := clc$secure_parameter;
      pdt_changes^ [6].security := clc$secure_parameter;
      pdt_changes^ [7].security := clc$secure_parameter;
      pdt_changes^ [8].security := clc$secure_parameter;
      pdt_changes^ [9].security := clc$secure_parameter;
    ELSE
      pdt_changes^ [4].security := clc$non_secure_parameter;
      pdt_changes^ [5].security := clc$non_secure_parameter;
      pdt_changes^ [6].security := clc$non_secure_parameter;
      pdt_changes^ [7].security := clc$non_secure_parameter;
      pdt_changes^ [8].security := clc$non_secure_parameter;
      pdt_changes^ [9].security := clc$non_secure_parameter;
    IFEND;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, altered_pdt, ^check_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Get the field description for the login password validation field.

    PUSH default_attributes: [1 .. avc$maximum_name_list_size];
    FOR index := 1 TO avc$maximum_name_list_size DO
      default_attributes^ [index] := osc$null_name;
    FOREND;

    avp$get_login_pw_field_desc (avc$login_password, current_subutility_session_info^.validation_record_name,
          current_subutility_session_info^.id, default_password, default_expiration_date,
          default_expiration_interval, default_max_expiration_interval, default_exp_warning_interval,
          default_exp_pw_chg_interval, number_of_default_attributes, default_attributes, description,
          change_authority, delete_authority, display_authority, manage_authority,
          validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    old_password := NIL;
    new_password := NIL;

{ Get the value(s) for the appropriate password parameters.

    IF pvt [p$encrypted_password].specified THEN
      IF pvt [p$old_password].specified OR pvt [p$new_password].specified THEN
        osp$set_status_abnormal ('AV', ave$cannot_supply_old_or_new_pw, '', status);
        RETURN;
      ELSE
        PUSH new_password;
        new_password^.encrypted := TRUE;
        new_password^.value := pvt [p$encrypted_password].value^.string_value^;
      IFEND;
    ELSE
      IF pvt [p$old_password].specified THEN
        old_password := ^pvt [p$old_password].value^.name_value;
      IFEND;

      IF pvt [p$new_password].specified THEN
        PUSH new_password;
        new_password^.encrypted := FALSE;
        new_password^.value := pvt [p$new_password].value^.name_value
      IFEND;

      IF pvt [p$old_password].specified AND (NOT pvt [p$new_password].specified) THEN
        osp$set_status_abnormal ('AV', ave$must_specify_new_password, '', status);
        RETURN;
      IFEND;
    IFEND;

{ Get the new value for the expiration interval if one was specified.

    IF pvt [p$expiration_interval].specified THEN
      IF pvt [p$expiration_interval].value^.kind = clc$keyword THEN
        IF pvt [p$expiration_interval].value^.keyword_value = 'DEFAULT' THEN
          expiration_interval := ^default_expiration_interval;
        ELSE {UNLIMITED}
          PUSH expiration_interval;
          expiration_interval^ := avv$unlimited_time_increment;
        IFEND;
      ELSE { clc$integer}
        PUSH expiration_interval;
        expiration_interval^ := avv$zero_time_increment;
        expiration_interval^.day := pvt [p$expiration_interval].value^.integer_value.value;
      IFEND;
    ELSE
      expiration_interval := NIL;
    IFEND;

{ Get the new value for the expiration date if one was specified.

    IF pvt [p$expiration_date].specified THEN
      IF pvt [p$expiration_date].value^.kind = clc$keyword THEN
        IF pvt [p$expiration_date].value^.keyword_value = 'NONE' THEN
          PUSH expiration_date;
          expiration_date^ := avv$unlimited_date_time;
        ELSE
          expiration_date := ^default_expiration_date;
        IFEND;
      ELSE {clc$date_time}
        expiration_date := ^pvt [p$expiration_date].value^.date_time_value.value;
      IFEND;
    ELSE
      expiration_date := NIL;
    IFEND;

{ Get the new value for the expiration warning interval if one was specified.

    IF pvt [p$expiration_warning_interval].specified THEN
      IF pvt [p$expiration_warning_interval].value^.kind = clc$keyword THEN
        IF pvt [p$expiration_warning_interval].value^.keyword_value = 'DEFAULT' THEN
          expiration_warning_interval := ^default_exp_warning_interval;
        ELSE {UNLIMITED}
          PUSH expiration_warning_interval;
          expiration_warning_interval^ := avv$unlimited_time_increment;
        IFEND;
      ELSE { clc$integer}
        PUSH expiration_warning_interval;
        expiration_warning_interval^ := avv$zero_time_increment;
        expiration_warning_interval^.day := -pvt [p$expiration_warning_interval].value^.integer_value.value;
      IFEND;
    ELSE
      expiration_warning_interval := NIL;
    IFEND;

{ The MAXIMUM_EXPIRATION_INTERVAL, ADD_ATTRIBUTES and DELETE_ATTRIBUTES parameters are only processed if the
{ user has the ability to set them.

    IF avp$system_administrator () OR avp$family_administrator () OR user_administrator THEN

{ Get the new value for the maximum expiration interval if one was specified.

      IF pvt [p$maximum_expiration_interval].specified THEN
        IF pvt [p$maximum_expiration_interval].value^.kind = clc$keyword THEN
          IF pvt [p$maximum_expiration_interval].value^.keyword_value = 'DEFAULT' THEN
            maximum_expiration_interval := ^default_max_expiration_interval;
          ELSE {UNLIMITED}
            PUSH maximum_expiration_interval;
            maximum_expiration_interval^ := avv$unlimited_time_increment;
          IFEND;
        ELSE { clc$integer}
          PUSH maximum_expiration_interval;
          maximum_expiration_interval^ := avv$zero_time_increment;
          maximum_expiration_interval^.day := pvt [p$maximum_expiration_interval].value^.integer_value.value;
        IFEND;
      ELSE
        maximum_expiration_interval := NIL;
      IFEND;

      process_name_list_parameter (pvt [p$add_attributes].value, default_attributes, attributes_to_add);

      process_name_list_parameter (pvt [p$delete_attributes].value, default_attributes, attributes_to_delete);
    ELSE
      maximum_expiration_interval := NIL;
      attributes_to_add := NIL;
      attributes_to_delete := NIL;
    IFEND;

    avp$change_login_password_value (avc$login_password, old_password, new_password, expiration_date,
          expiration_interval, maximum_expiration_interval, expiration_warning_interval, NIL,
          attributes_to_add, attributes_to_delete, current_subutility_session_info^.id,
          pvt [p$update_batch_job_passwords].value^.boolean_value.value, validation_file_information, status);

  PROCEND avp$change_login_password_cmd;
?? OLDTITLE ??
?? NEWTITLE := 'avp$change_name_command', EJECT ??

{ PURPOSE:
{   This is the command processor used to change the value of any NAME fields.

  PROCEDURE [XDCL] avp$change_name_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      add_parameter_value: ^clt$data_value,
      change_authority: avt$validation_authority,
      command_name: ost$name,
      common_names: ^avt$name_list,
      current_parameter_value: ^clt$data_value,
      default_names: ^avt$name_list,
      delete_authority: avt$validation_authority,
      delete_parameter_value: ^clt$data_value,
      description: ost$string,
      display_authority: avt$validation_authority,
      field_name: ost$name,
      index: avt$name_list_size,
      manage_authority: avt$validation_authority,
      maximum_number_of_names: avt$name_list_size,
      minimum_number_of_names: avt$name_list_size,
      names_to_add: ^avt$name_list,
      names_to_delete: ^avt$name_list,
      number_of_common_names: avt$name_list_size,
      number_of_default_names: avt$name_list_size;

?? NEWTITLE := 'change_name_list_value', EJECT ??

    PROCEDURE change_name_list_value
      (    parameter_list: clt$parameter_list;
           minimum_number_of_names: avt$name_list_size;
           maximum_number_of_names: avt$name_list_size;
       VAR add_parameter_value: ^clt$data_value;
       VAR delete_parameter_list: ^clt$data_value;
       VAR status: ost$status);

{ PROCEDURE (osm$admv_chanlc) change_name_list_command, chanlc (
{   add, a: (BY_NAME, CHECK) any of
{       key
{         all, default, none
{       keyend
{       list 1..256 of name
{     anyend = none
{   delete, d: (BY_NAME, CHECK) any of
{       key
{         all, default, none
{       keyend
{       list 1..256 of name
{     anyend = none
{   status)

?? PUSH (LISTEXT := ON) ??

      VAR
        pdt: [STATIC, READ, cls$declaration_section] record
          header: clt$pdt_header,
          names: array [1 .. 5] of clt$pdt_parameter_name,
          parameters: array [1 .. 3] 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 .. 3] 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,
              element_type_spec: record
                header: clt$type_specification_header,
                qualifier: clt$name_type_qualifier,
              recend,
            recend,
            default_value: string (4),
          recend,
          type2: 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 .. 3] 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,
              element_type_spec: record
                header: clt$type_specification_header,
                qualifier: clt$name_type_qualifier,
              recend,
            recend,
            default_value: string (4),
          recend,
          type3: record
            header: clt$type_specification_header,
          recend,
        recend := [[1, [88, 5, 12, 15, 22, 24, 533], clc$command, 5, 3, 0, 0, 0, 0, 3, 'OSM$ADMV_CHANLC'],
              [['A                              ', clc$abbreviation_entry, 1],
              ['ADD                            ', clc$nominal_entry, 1],
              ['D                              ', clc$abbreviation_entry, 2],
              ['DELETE                         ', clc$nominal_entry, 2],
              ['STATUS                         ', clc$nominal_entry, 3]], [

{ PARAMETER 1

        [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
              clc$extended_parameter_checking, 159, clc$optional_default_parameter, 0, 4],

{ PARAMETER 2

        [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
              clc$extended_parameter_checking, 159, clc$optional_default_parameter, 0, 4],

{ PARAMETER 3

        [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
              clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

        [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 118,
              [[1, 0, clc$keyword_type], [3], [['ALL                            ', clc$nominal_entry,
              clc$normal_usage_entry, 1], ['DEFAULT                        ', clc$nominal_entry,
              clc$normal_usage_entry, 2], ['NONE                           ', clc$nominal_entry,
              clc$normal_usage_entry, 3]]], 21, [[1, 0, clc$list_type],
              [5, 1, 256, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'none'],

{ PARAMETER 2

        [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 118,
              [[1, 0, clc$keyword_type], [3], [['ALL                            ', clc$nominal_entry,
              clc$normal_usage_entry, 1], ['DEFAULT                        ', clc$nominal_entry,
              clc$normal_usage_entry, 2], ['NONE                           ', clc$nominal_entry,
              clc$normal_usage_entry, 3]]], 21, [[1, 0, clc$list_type],
              [5, 1, 256, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'none'],

{ PARAMETER 3

        [[1, 0, clc$status_type]]];

?? POP ??

      CONST
        p$add = 1,
        p$delete = 2,
        p$status = 3;

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

      VAR
        altered_pdt: ^clt$parameter_description_table,
        name_list_type_changes: ^clt$type_changes,
        pdt_changes: ^clt$pdt_changes;

?? NEWTITLE := 'check_parameters', EJECT ??

      PROCEDURE check_parameters
        (    parameter_value_table: ^clt$parameter_value_table;
             which_parameter: clt$which_parameter;
         VAR status: ost$status);

        status.normal := TRUE;

        IF which_parameter.specific THEN
          IF which_parameter.number = p$add THEN
            verify_list_of_names_value ('ADD', parameter_value_table^ [p$add].value, status);
          ELSEIF which_parameter.number = p$delete THEN
            verify_list_of_names_value ('DELETE', parameter_value_table^ [p$delete].value, status);
          ELSE

{ ignore the parameter.

          IFEND;
        IFEND;

      PROCEND check_parameters;
?? OLDTITLE, EJECT ??
      status.normal := TRUE;

{ Make a copy of the PDT so it can be altered.

      PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
      RESET altered_pdt;
      altered_pdt^ := #SEQ (pdt) ^;

{ Set the minimum and maximum number of list elements.

      PUSH name_list_type_changes: [1 .. 1];
      name_list_type_changes^ [1].kind := clc$tc_list_size;
      name_list_type_changes^ [1].min_list_size := minimum_number_of_names;
      name_list_type_changes^ [1].max_list_size := maximum_number_of_names;

      PUSH pdt_changes: [1 .. 4];
      pdt_changes^ [1].number := p$add;
      pdt_changes^ [1].kind := clc$pdtc_type;
      pdt_changes^ [1].type_changes := name_list_type_changes;
      pdt_changes^ [2].number := p$delete;
      pdt_changes^ [2].kind := clc$pdtc_type;
      pdt_changes^ [2].type_changes := name_list_type_changes;
      pdt_changes^ [3].number := p$add;
      pdt_changes^ [3].kind := clc$pdtc_security;
      pdt_changes^ [4].number := p$delete;
      pdt_changes^ [4].kind := clc$pdtc_security;
      IF display_authority = avc$system_authority THEN
        pdt_changes^ [3].security := clc$secure_parameter;
        pdt_changes^ [4].security := clc$secure_parameter;
      ELSE
        pdt_changes^ [3].security := clc$non_secure_parameter;
        pdt_changes^ [4].security := clc$non_secure_parameter;
      IFEND;

      clp$change_pdt (altered_pdt, pdt_changes^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$evaluate_parameters (parameter_list, altered_pdt, ^check_parameters, ^pvt, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      add_parameter_value := pvt [p$add].value;
      delete_parameter_value := pvt [p$delete].value;

    PROCEND change_name_list_value;
?? OLDTITLE ??
?? NEWTITLE := 'change_name_value', EJECT ??

    PROCEDURE change_name_value
      (    parameter_list: clt$parameter_list;
       VAR add_parameter_value: ^clt$data_value;
       VAR status: ost$status);

{ PROCEDURE (osm$admv_chanc) change_name_command, chanc (
{   value, v: any of
{       key
{         default, none
{       keyend
{       name
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

      VAR
        pdt: [STATIC, READ, cls$declaration_section] record
          header: clt$pdt_header,
          names: array [1 .. 3] of clt$pdt_parameter_name,
          parameters: array [1 .. 2] 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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          type2: record
            header: clt$type_specification_header,
          recend,
        recend := [[1, [88, 5, 3, 13, 13, 5, 264], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMV_CHANC'],
              [['STATUS                         ', clc$nominal_entry, 2],
              ['V                              ', clc$abbreviation_entry, 1],
              ['VALUE                          ', clc$nominal_entry, 1]], [

{ PARAMETER 1

        [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
              clc$standard_parameter_checking, 106, clc$optional_parameter, 0, 0],

{ PARAMETER 2

        [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
              [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
              clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

        [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 81,
              [[1, 0, clc$keyword_type], [2], [['DEFAULT                        ', clc$nominal_entry,
              clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
              clc$normal_usage_entry, 2]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 2

        [[1, 0, clc$status_type]]];

?? POP ??

      CONST
        p$value = 1,
        p$status = 2;

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

      VAR
        altered_pdt: ^clt$parameter_description_table,
        pdt_changes: ^clt$pdt_changes;

      status.normal := TRUE;

{ Set the SECURE attribute if necessary.

      IF display_authority = avc$system_authority THEN

{ Make a copy of the PDT so it can be altered.

        PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
        RESET altered_pdt;
        altered_pdt^ := #SEQ (pdt) ^;

        PUSH pdt_changes: [1 .. 1];
        pdt_changes^ [1].number := p$value;
        pdt_changes^ [1].kind := clc$pdtc_security;
        pdt_changes^ [1].security := clc$secure_parameter;

        clp$change_pdt (altered_pdt, pdt_changes^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

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

      IF pvt [p$value].specified THEN
        add_parameter_value := pvt [p$value].value;
      ELSE
        add_parameter_value := NIL;
      IFEND;

    PROCEND change_name_value;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Determine what field to change and get its field description.

    avp$get_field_name (current_subutility_session_info^.id, field_name, command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH common_names: [1 .. avc$maximum_name_list_size];
    PUSH default_names: [1 .. avc$maximum_name_list_size];
    FOR index := 1 TO avc$maximum_name_list_size DO
      common_names^ [index] := osc$null_name;
      default_names^ [index] := osc$null_name;
    FOREND;

    avp$get_name_field_desc (field_name, current_subutility_session_info^.validation_record_name,
          current_subutility_session_info^.id, number_of_default_names, default_names,
          minimum_number_of_names, maximum_number_of_names, number_of_common_names, common_names, description,
          change_authority, delete_authority, display_authority, manage_authority,
          validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Use the appropriate PDT and process the parameters

    IF maximum_number_of_names = 1 THEN
      PUSH delete_parameter_value;
      delete_parameter_value^.kind := clc$keyword;
      delete_parameter_value^.keyword_value := 'ALL';
      change_name_value (parameter_list, add_parameter_value, status);
      IF (NOT status.normal) OR (add_parameter_value = NIL) THEN
        RETURN;
      IFEND;
    ELSE
      change_name_list_value (parameter_list, minimum_number_of_names, maximum_number_of_names,
            add_parameter_value, delete_parameter_value, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_name_list_parameter (add_parameter_value, default_names, names_to_add);

    process_name_list_parameter (delete_parameter_value, default_names, names_to_delete);

    avp$change_name_value (field_name, names_to_add, names_to_delete, current_subutility_session_info^.id,
          validation_file_information, status);

  PROCEND avp$change_name_command;
?? OLDTITLE ??
?? NEWTITLE := 'avp$change_real_command', EJECT ??

{ PURPOSE:
{   This is the command processor used to change the value of any REAL fields.

  PROCEDURE [XDCL] avp$change_real_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_charc) change_real_command, charc (
{   value, v: any of
{       key
{         default
{       keyend
{       real
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] 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$real_type_qualifier,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 4, 9, 16, 3, 649], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMV_CHARC'],
            [['STATUS                         ', clc$nominal_entry, 2],
            ['V                              ', clc$abbreviation_entry, 1],
            ['VALUE                          ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 99, clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$real_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 35, [[1, 0, clc$real_type],
            [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
            [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]]]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$value = 1,
      p$status = 2;

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

    TYPE
      long_real_type = record
        first: real,
        second: real,
      recend;

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: avt$validation_authority,
      command_name: ost$name,
      default_value: real,
      delete_authority: avt$validation_authority,
      description: ost$string,
      display_authority: avt$validation_authority,
      display_format: avt$numeric_display_format,
      field_name: ost$name,
      long_real_value: long_real_type,
      manage_authority: avt$validation_authority,
      maximum_value: real,
      minimum_value: real,
      parameter: clt$value,
      real_type_changes: ^clt$type_changes,
      real_value: ^real,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

{ Determine what field to change and get its field description.

    avp$get_field_name (current_subutility_session_info^.id, field_name, command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$get_real_field_desc (field_name, current_subutility_session_info^.validation_record_name,
          current_subutility_session_info^.id, default_value, minimum_value, maximum_value, display_format,
          description, change_authority, delete_authority, display_authority, manage_authority,
          validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the minimum and maximum values.

    PUSH real_type_changes: [1 .. 1];
    real_type_changes^ [1].kind := clc$tc_integer_subrange;
    long_real_value.first := minimum_value;
    long_real_value.second := 0.0;
    #UNCHECKED_CONVERSION (long_real_value, real_type_changes^ [1].min_real_value);
    long_real_value.first := maximum_value;
    long_real_value.second := 0.0;
    #UNCHECKED_CONVERSION (long_real_value, real_type_changes^ [1].max_real_value);

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$value;
    pdt_changes^ [1].kind := clc$pdtc_type;
    pdt_changes^ [1].type_changes := real_type_changes;
    pdt_changes^ [2].number := p$value;
    pdt_changes^ [2].kind := clc$pdtc_security;
    IF display_authority = avc$system_authority THEN
      pdt_changes^ [2].security := clc$secure_parameter;
    ELSE
      pdt_changes^ [2].security := clc$non_secure_parameter;
    IFEND;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    IF pvt [p$value].specified THEN
      IF pvt [p$value].value^.kind = clc$keyword THEN
        real_value := ^default_value;
      ELSE
        #UNCHECKED_CONVERSION (pvt [p$value].value^.real_value.value, long_real_value);
        PUSH real_value;
        real_value^ := long_real_value.first;
      IFEND;

      avp$change_real_value (field_name, real_value, current_subutility_session_info^.id,
            validation_file_information, status);
    IFEND;

  PROCEND avp$change_real_command;
?? OLDTITLE ??
?? NEWTITLE := 'avp$change_ring_privilege_cmd', EJECT ??

{ PURPOSE:
{   This is the command processor used to change the value of the
{   RING_PRIVILEGE field.

  PROCEDURE [XDCL] avp$change_ring_privilege_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_charp) change_ring_privilege, change_ring_privileges, charp (
{   minimum_ring, minr: (BY_NAME) any of
{       key
{         default
{       keyend
{       integer 4..13
{     anyend = $optional
{   nominal_ring, nr: (BY_NAME) any of
{       key
{         default
{       keyend
{       integer 4..13
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] 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$integer_type_qualifier,
          recend,
        recend,
        type2: 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$integer_type_qualifier,
          recend,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 31, 14, 43, 49, 275], clc$command, 5, 3, 0, 0, 0, 0, 3, 'OSM$ADMV_CHARP'],
            [['MINIMUM_RING                   ', clc$nominal_entry, 1],
            ['MINR                           ', clc$abbreviation_entry, 1],
            ['NOMINAL_RING                   ', clc$nominal_entry, 2],
            ['NR                             ', clc$abbreviation_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
            clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
            clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type], [4, 13, 10]]],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type], [4, 13, 10]]],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$minimum_ring = 1,
      p$nominal_ring = 2,
      p$status = 3;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: avt$validation_authority,
      command_name: ost$name,
      default_minimum_ring: ost$ring,
      default_nominal_ring: ost$ring,
      delete_authority: avt$validation_authority,
      description: ost$string,
      display_authority: avt$validation_authority,
      manage_authority: avt$validation_authority,
      minimum_ring: ^ost$ring,
      minimum_ring_parameter: clt$value,
      nominal_ring: ^ost$ring,
      nominal_ring_parameter: clt$value,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

{ Set the SECURE attribute if necessary.

    IF display_authority = avc$system_authority THEN

{ Make a copy of the PDT so it can be altered.

      PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
      RESET altered_pdt;
      altered_pdt^ := #SEQ (pdt) ^;

      PUSH pdt_changes: [1 .. 1];
      pdt_changes^ [1].number := p$minimum_ring;
      pdt_changes^ [1].kind := clc$pdtc_security;
      pdt_changes^ [1].security := clc$secure_parameter;
      pdt_changes^ [2].number := p$nominal_ring;
      pdt_changes^ [2].kind := clc$pdtc_security;
      pdt_changes^ [2].security := clc$secure_parameter;

      clp$change_pdt (altered_pdt, pdt_changes^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

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

    avp$get_ring_priv_field_desc (avc$ring_privileges, current_subutility_session_info^.
          validation_record_name, current_subutility_session_info^.id, default_minimum_ring,
          default_nominal_ring, description, change_authority, delete_authority, display_authority,
          manage_authority, validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$minimum_ring].specified THEN
      IF pvt [p$minimum_ring].value^.kind = clc$keyword THEN
        minimum_ring := ^default_minimum_ring;
      ELSE
        PUSH minimum_ring;
        minimum_ring^ := pvt [p$minimum_ring].value^.integer_value.value;
      IFEND;
    ELSE
      minimum_ring := NIL;
    IFEND;

    IF pvt [p$nominal_ring].specified THEN
      IF pvt [p$nominal_ring].value^.kind = clc$keyword THEN
        nominal_ring := ^default_nominal_ring;
      ELSE
        PUSH nominal_ring;
        nominal_ring^ := pvt [p$nominal_ring].value^.integer_value.value;
      IFEND;
    ELSE
      nominal_ring := NIL;
    IFEND;

    avp$change_ring_privilege_value (avc$ring_privileges, minimum_ring, nominal_ring,
          current_subutility_session_info^.id, validation_file_information, status);

  PROCEND avp$change_ring_privilege_cmd;
?? OLDTITLE ??
?? NEWTITLE := 'avp$change_string_command', EJECT ??

{ PURPOSE:
{   This is the command processor used to change the value of any STRING fields.

  PROCEDURE [XDCL] avp$change_string_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chasc) change_string_command, chasc (
{   value, v: any of
{       key
{         default
{       keyend
{       string
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] 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$string_type_qualifier,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 15, 14, 38, 40, 432], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMV_CHASC'],
            [['STATUS                         ', clc$nominal_entry, 2],
            ['V                              ', clc$abbreviation_entry, 1],
            ['VALUE                          ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 72, clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$string_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$value = 1,
      p$status = 2;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: avt$validation_authority,
      command_name: ost$name,
      default_value: ost$string,
      delete_authority: avt$validation_authority,
      description: ost$string,
      display_authority: avt$validation_authority,
      field_name: ost$name,
      manage_authority: avt$validation_authority,
      maximum_string_size: ost$string_size,
      minimum_string_size: ost$string_size,
      pdt_changes: ^clt$pdt_changes,
      string_type_changes: ^clt$type_changes,
      string_value: ^ost$string;

    status.normal := TRUE;

{ Determine what field to change and get its field description.

    avp$get_field_name (current_subutility_session_info^.id, field_name, command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$get_string_field_desc (field_name, current_subutility_session_info^.validation_record_name,
          current_subutility_session_info^.id, default_value, minimum_string_size, maximum_string_size,
          description, change_authority, delete_authority, display_authority, manage_authority,
          validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := #SEQ (pdt) ^;

{ Set the minimum and maximum number of list elements.

    PUSH string_type_changes: [1 .. 1];
    string_type_changes^ [1].kind := clc$tc_string_size;
    string_type_changes^ [1].min_string_size := minimum_string_size;
    string_type_changes^ [1].max_string_size := maximum_string_size;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$value;
    pdt_changes^ [1].kind := clc$pdtc_type;
    pdt_changes^ [1].type_changes := string_type_changes;
    pdt_changes^ [2].number := p$value;
    pdt_changes^ [2].kind := clc$pdtc_security;
    IF display_authority = avc$system_authority THEN
      pdt_changes^ [2].security := clc$secure_parameter;
    ELSE
      pdt_changes^ [2].security := clc$non_secure_parameter;
    IFEND;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    IF pvt [p$value].specified THEN
      IF pvt [p$value].value^.kind = clc$keyword THEN
        string_value := ^default_value;
      ELSE
        PUSH string_value;
        string_value^.value := pvt [p$value].value^.string_value^;
        string_value^.size := #SIZE (pvt [p$value].value^.string_value^);
      IFEND;

      avp$change_string_value (field_name, string_value, current_subutility_session_info^.id,
            validation_file_information, status);
    IFEND;

  PROCEND avp$change_string_command;
?? OLDTITLE ??
?? NEWTITLE := 'avp$display_field_value', EJECT ??

{ PURPOSE:
{   This is the command processor used to display the value of any field.

  PROCEDURE [XDCL] avp$display_field_value
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_disfv) display_field_value, disfv (
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 4, 10, 3, 28, 369], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMV_DISFV'],
            [['O                              ', clc$abbreviation_entry, 1],
            ['OUTPUT                         ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 2]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type], '$output'],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

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

    VAR
      display_control: clt$display_control,
      field_name: ^array [1 .. * ] of ost$name,
      file_contents: amt$file_contents,
      ignore_status: ost$status,
      ring_attributes: amt$ring_attributes,
      title: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that the output
{   file is closed in case of an abnormal exit.

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

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

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

{ Determine what field to display.

    PUSH field_name: [1 .. 1];
    avp$get_field_name (current_subutility_session_info^.id, field_name^ [1], clv$command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clv$titles_built := FALSE;

    IF current_subutility_session_info^.validation_record_name = avc$user_record_name THEN
      title := current_subutility_session_info^.key.user_name;
    ELSEIF current_subutility_session_info^.validation_record_name = avc$account_record_name THEN
      title := current_subutility_session_info^.key.account_name;
    ELSEIF current_subutility_session_info^.validation_record_name = avc$account_member_record_name THEN
      title := current_subutility_session_info^.key.user_name;
    ELSEIF current_subutility_session_info^.validation_record_name = avc$project_record_name THEN
      title := current_subutility_session_info^.key.project_name;
    ELSEIF current_subutility_session_info^.validation_record_name = avc$project_member_record_name THEN
      title := current_subutility_session_info^.key.user_name;
    IFEND;

    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    file_contents := amc$list;

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, file_contents,
          ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

    display_selected_fields (title, field_name, current_subutility_session_info^.validation_record_name,
          current_subutility_session_info^.id, display_control, status);

    osp$disestablish_cond_handler;

    IF status.normal THEN
      clp$close_display (display_control, status);
    ELSE
      clp$close_display (display_control, ignore_status);
    IFEND;

  PROCEND avp$display_field_value;
?? OLDTITLE ??
?? NEWTITLE := 'avp$end_subutility_command', EJECT ??

{ PURPOSE:
{   This is the command processor used to end any of the create or change
{   subutilities.

  PROCEDURE [XDCL] avp$end_subutility_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_endccs) end_create_change_subutility, endccs (
{   write_changes, wc: boolean = true
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 1] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          default_value: string (4),
        recend,
      recend := [[1, [88, 5, 16, 12, 19, 50, 687], clc$command, 2, 1, 0, 0, 0, 0, 0, 'OSM$ADMV_ENDCCS'],
            [['WC                             ', clc$abbreviation_entry, 1],
            ['WRITE_CHANGES                  ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 4]],

{ PARAMETER 1

      [[1, 0, clc$boolean_type], 'true']];

?? POP ??

    CONST
      p$write_changes = 1;

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

    status.normal := TRUE;

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

{ Set the rewrite flag for the record.

    current_subutility_session_info^.rewrite_record := pvt [p$write_changes].value^.boolean_value.value;

    clp$end_include (current_subutility_session_info^.subutility_name, status);

  PROCEND avp$end_subutility_command;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'Manage Fields Subcommands', EJECT ??
?? NEWTITLE := 'change_account_project_field', EJECT ??

{ PURPOSE:
{   This is the command processor used to alter the definition of an
{   ACCOUNT_PROJECT field.

  PROCEDURE change_account_project_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chaapf) change_account_project_field, chaapf (
{   field_name, fn: name = $required
{   default_account, defa: (BY_NAME) any of
{       key
{         current, none
{       keyend
{       name
{     anyend = $optional
{   default_project, defp: (BY_NAME) any of
{       key
{         current, none
{       keyend
{       name
{     anyend = $optional
{   description, d: (BY_NAME) string 0..256 = $optional
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 19] of clt$pdt_parameter_name,
        parameters: array [1 .. 10] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type3: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type5: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type6: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type7: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type9: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type10: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 23, 35, 646], clc$command, 19, 10, 1, 0, 0, 0, 10, 'OSM$ADMV_CHAAPF'],
            [['CA                             ', clc$abbreviation_entry, 7],
            ['CCN                            ', clc$abbreviation_entry, 5],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 7],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 5],
            ['D                              ', clc$abbreviation_entry, 4],
            ['DA                             ', clc$abbreviation_entry, 8],
            ['DCN                            ', clc$abbreviation_entry, 6],
            ['DEFA                           ', clc$abbreviation_entry, 2],
            ['DEFAULT_ACCOUNT                ', clc$nominal_entry, 2],
            ['DEFAULT_PROJECT                ', clc$nominal_entry, 3],
            ['DEFP                           ', clc$abbreviation_entry, 3],
            ['DESCRIPTION                    ', clc$nominal_entry, 4],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 8],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 6],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['MA                             ', clc$abbreviation_entry, 9],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 9],
            ['STATUS                         ', clc$nominal_entry, 10]], [

{ PARAMETER 1

      [15, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 106,
            clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 106, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [14, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [18, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 10

      [19, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['CURRENT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['CURRENT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 4

      [[1, 0, clc$string_type], [0, 256, FALSE]],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 6

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 7

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 8

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 9

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 10

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$default_account = 2,
      p$default_project = 3,
      p$description = 4,
      p$change_command_names = 5,
      p$display_command_names = 6,
      p$change_authority = 7,
      p$display_authority = 8,
      p$manage_authority = 9,
      p$status = 10;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      current_parameter_value: ^clt$data_value,
      default_account: ^avt$account_name,
      default_project: ^avt$project_name,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

    field_name := pvt [p$field_name].value^.name_value;

    IF pvt [p$default_account].specified THEN
      PUSH default_account;
      IF pvt [p$default_account].value^.kind = clc$keyword THEN
        IF pvt [p$default_account].value^.keyword_value = 'CURRENT' THEN
          default_account^ := executing_account;
        ELSE
          default_account^ := pvt [p$default_account].value^.keyword_value;
        IFEND;
      ELSE { clc$name }
        default_account^ := pvt [p$default_account].value^.name_value;
      IFEND;
    ELSE
      default_account := NIL;
    IFEND;

    IF pvt [p$default_project].specified THEN
      PUSH default_project;
      IF pvt [p$default_project].value^.kind = clc$keyword THEN
        IF pvt [p$default_project].value^.keyword_value = 'CURRENT' THEN
          default_project^ := executing_project;
        ELSE
          default_project^ := pvt [p$default_project].value^.keyword_value;
        IFEND;
      ELSE { clc$name }
        default_project^ := pvt [p$default_project].value^.name_value;
      IFEND;
    ELSE
      default_project := NIL;
    IFEND;

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);

    process_authority_parameter (pvt [p$change_authority].value, change_authority);

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);

    avp$change_acct_proj_field (pvt [p$field_name].value^.name_value,
          current_subutility_session_info^.validation_record_name, default_account, default_project,
          change_command_names, display_command_names, description, display_authority, change_authority,
          manage_authority, NIL, validation_file_information, status);

  PROCEND change_account_project_field;
?? OLDTITLE ??
?? NEWTITLE := 'change_accumulating_limit_field', EJECT ??

{ PURPOSE:
{   This is the command processor used to alter the definition of an
{   ACCUMULATING_LIMIT field.

  PROCEDURE change_accumulating_limit_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chaalf) change_accumulating_limit_field, chaalf (
{   field_name, fn: name = $required
{   limit_name, ln: (BY_NAME) name = $optional
{   default_job_maximum_limit, djmaxl: (BY_NAME) any of
{       key
{         unlimited
{       keyend
{       integer 0..osc$max_integer
{     anyend = $optional
{   default_job_warning_limit, djwl: (BY_NAME) any of
{       key
{         unlimited
{       keyend
{       integer 0..osc$max_integer
{     anyend = $optional
{   default_total_limit, dtl: (BY_NAME) any of
{       key
{         unlimited
{       keyend
{       integer 0..osc$max_integer
{     anyend = $optional
{   limit_application, la: (BY_NAME) key
{       (job_limits_apply, jla)
{       (total_limit_applies, tla)
{       (job_and_total_limits_apply, jatla)
{     keyend = $optional
{   update_statistic, update_statistics, us: (BY_NAME, CHECK) any of
{       key
{         none
{       keyend
{       list of statistic_code
{     anyend = $optional
{   total_limit_prevents_login, tlpl: (BY_NAME) boolean = $optional
{   description, d: (BY_NAME) string 0..256 = $optional
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 30] of clt$pdt_parameter_name,
        parameters: array [1 .. 15] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type3: 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$integer_type_qualifier,
          recend,
        recend,
        type4: 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$integer_type_qualifier,
          recend,
        recend,
        type5: 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$integer_type_qualifier,
          recend,
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 6] of clt$keyword_specification,
        recend,
        type7: 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,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
        type8: record
          header: clt$type_specification_header,
        recend,
        type9: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type10: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type11: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type12: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type13: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type14: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type15: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 18, 15, 55, 42, 166], clc$command, 30, 15, 1, 0, 0, 0, 15, 'OSM$ADMV_CHAALF'],
            [['CA                             ', clc$abbreviation_entry, 12],
            ['CCN                            ', clc$abbreviation_entry, 10],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 12],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 10],
            ['D                              ', clc$abbreviation_entry, 9],
            ['DA                             ', clc$abbreviation_entry, 13],
            ['DCN                            ', clc$abbreviation_entry, 11],
            ['DEFAULT_JOB_MAXIMUM_LIMIT      ', clc$nominal_entry, 3],
            ['DEFAULT_JOB_WARNING_LIMIT      ', clc$nominal_entry, 4],
            ['DEFAULT_TOTAL_LIMIT            ', clc$nominal_entry, 5],
            ['DESCRIPTION                    ', clc$nominal_entry, 9],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 13],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 11],
            ['DJMAXL                         ', clc$abbreviation_entry, 3],
            ['DJWL                           ', clc$abbreviation_entry, 4],
            ['DTL                            ', clc$abbreviation_entry, 5],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['LA                             ', clc$abbreviation_entry, 6],
            ['LIMIT_APPLICATION              ', clc$nominal_entry, 6],
            ['LIMIT_NAME                     ', clc$nominal_entry, 2],
            ['LN                             ', clc$abbreviation_entry, 2],
            ['MA                             ', clc$abbreviation_entry, 14],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 14],
            ['STATUS                         ', clc$nominal_entry, 15],
            ['TLPL                           ', clc$abbreviation_entry, 8],
            ['TOTAL_LIMIT_PREVENTS_LOGIN     ', clc$nominal_entry, 8],
            ['UPDATE_STATISTIC               ', clc$nominal_entry, 7],
            ['UPDATE_STATISTICS              ', clc$alias_entry, 7],
            ['US                             ', clc$abbreviation_entry, 7]], [

{ PARAMETER 1

      [17, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [21, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
            clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
            clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [20, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 229, clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [28, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$extended_parameter_checking, 83, clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [27, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],

{ PARAMETER 10

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_parameter, 0, 0],

{ PARAMETER 11

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 12

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 13

      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 14

      [24, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 15

      [25, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type], [0, osc$max_integer, 10]]],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type], [0, osc$max_integer, 10]]],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type], [0, osc$max_integer, 10]]],

{ PARAMETER 6

      [[1, 0, clc$keyword_type], [6], [['JATLA                          ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['JLA                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['JOB_AND_TOTAL_LIMITS_APPLY     ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['JOB_LIMITS_APPLY               ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['TLA                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['TOTAL_LIMIT_APPLIES            ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]],

{ PARAMETER 7

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 19, [[1, 0, clc$list_type],
            [3, 1, clc$max_list_size, FALSE], [[1, 0, clc$statistic_code_type]]]],

{ PARAMETER 8

      [[1, 0, clc$boolean_type]],

{ PARAMETER 9

      [[1, 0, clc$string_type], [0, 256, FALSE]],

{ PARAMETER 10

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 11

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 12

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 13

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 14

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 15

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$limit_name = 2,
      p$default_job_maximum_limit = 3,
      p$default_job_warning_limit = 4,
      p$default_total_limit = 5,
      p$limit_application = 6,
      p$update_statistic = 7,
      p$total_limit_prevents_login = 8,
      p$description = 9,
      p$change_command_names = 10,
      p$display_command_names = 11,
      p$change_authority = 12,
      p$display_authority = 13,
      p$manage_authority = 14,
      p$status = 15;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      common_job_classes: ^avt$name_list,
      current_parameter_value: ^clt$data_value,
      default_job_warning_limit: ^avt$limit_value,
      default_job_maximum_limit: ^avt$limit_value,
      default_total_limit: ^avt$limit_value,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      field_name: ost$name,
      index: integer,
      job_limits_apply: ^boolean,
      limit_name: ^ost$name,
      limit_update_statistics: ^sft$limit_update_statistics,
      manage_authority: ^avt$validation_authority,
      pdt_changes: ^clt$pdt_changes,
      total_limit_applies: ^boolean,
      total_limit_stops_login: ^boolean;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF (which_parameter.specific) AND (which_parameter.number = p$update_statistic) THEN
        verify_statistic_code_value ('UPDATE_STATISTIC', parameter_value_table^ [p$update_statistic].value,
              status);
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF current_subutility_session_info^.validation_record_name <> avc$user_record_name THEN

{ Hide parameters dealing with job limits.

      PUSH pdt_changes: [1 .. 5];
      pdt_changes^ [1].number := p$default_job_maximum_limit;
      pdt_changes^ [1].kind := clc$pdtc_availability;
      pdt_changes^ [1].availability := clc$hidden_entry;
      pdt_changes^ [2].number := p$default_job_warning_limit;
      pdt_changes^ [2].kind := clc$pdtc_availability;
      pdt_changes^ [2].availability := clc$hidden_entry;
      pdt_changes^ [3].number := p$limit_name;
      pdt_changes^ [3].kind := clc$pdtc_availability;
      pdt_changes^ [3].availability := clc$hidden_entry;
      pdt_changes^ [4].number := p$limit_application;
      pdt_changes^ [4].kind := clc$pdtc_availability;
      pdt_changes^ [4].availability := clc$hidden_entry;
      pdt_changes^ [5].number := p$update_statistic;
      pdt_changes^ [5].kind := clc$pdtc_availability;
      pdt_changes^ [5].availability := clc$hidden_entry;

      clp$change_pdt (altered_pdt, pdt_changes^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    clp$evaluate_parameters (parameter_list, altered_pdt, ^check_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    field_name := pvt [p$field_name].value^.name_value;

    IF (current_subutility_session_info^.validation_record_name = avc$user_record_name) AND
          (pvt [p$limit_name].value <> NIL) THEN
      limit_name := ^pvt [p$limit_name].value^.name_value;
    ELSE
      limit_name := NIL;
    IFEND;

    IF (current_subutility_session_info^.validation_record_name = avc$user_record_name) THEN
      process_limit_appl_parameter (pvt [p$limit_application].value, job_limits_apply, total_limit_applies);
    ELSE
      job_limits_apply := NIL;
      total_limit_applies := NIL;
    IFEND;

    IF (current_subutility_session_info^.validation_record_name = avc$user_record_name) THEN
      process_limit_parameter (pvt [p$default_job_maximum_limit].value, NIL, default_job_maximum_limit);
      process_limit_parameter (pvt [p$default_job_warning_limit].value, NIL, default_job_warning_limit);
    ELSE
      default_job_maximum_limit := NIL;
      default_job_warning_limit := NIL;
    IFEND;

    process_limit_parameter (pvt [p$default_total_limit].value, NIL, default_total_limit);

    IF pvt [p$total_limit_prevents_login].value <> NIL THEN
      total_limit_stops_login := ^pvt [p$total_limit_prevents_login].value^.boolean_value.value;
    ELSE
      total_limit_stops_login := NIL;
    IFEND;

    IF (current_subutility_session_info^.validation_record_name = avc$user_record_name) AND
          (pvt [p$update_statistic].value <> NIL) THEN
      IF pvt [p$update_statistic].value^.kind = clc$keyword THEN

{ If the keyword value NONE was specified, pass a zero statistic code to cause the current list of
{ statistics to be removed.

        PUSH limit_update_statistics: [1 .. 1];
        limit_update_statistics^ [1].statistic_code := 0;
      ELSE { list of statistic_code }
        PUSH limit_update_statistics: [1 .. clp$count_list_elements (pvt [p$update_statistic].value)];
        current_parameter_value := pvt [p$update_statistic].value;
        index := 0;
        REPEAT
          index := index + 1;
          limit_update_statistics^ [index].statistic_code :=
                current_parameter_value^.element_value^.statistic_code_value;
          limit_update_statistics^ [index].update_kind := sfc$update_based_on_counter;
          limit_update_statistics^ [index].counter := 1;
          current_parameter_value := current_parameter_value^.link;
        UNTIL current_parameter_value = NIL;
      IFEND;
    ELSE
      limit_update_statistics := NIL;
    IFEND;

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);

    process_authority_parameter (pvt [p$change_authority].value, change_authority);

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);

    avp$change_accum_limit_field (field_name, current_subutility_session_info^.validation_record_name,
          default_job_warning_limit, default_job_maximum_limit, default_total_limit, limit_name,
          job_limits_apply, limit_update_statistics, NIL, NIL, total_limit_applies, total_limit_stops_login,
          change_command_names, display_command_names, description, display_authority, change_authority,
          manage_authority, NIL, validation_file_information, status);

  PROCEND change_accumulating_limit_field;
?? OLDTITLE ??
?? NEWTITLE := 'change_capability_field', EJECT ??

{ PURPOSE:
{   This is the command processor used to alter the definition of a CAPABILITY field.

  PROCEDURE change_capability_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chacf) change_capability_field, chacf (
{   field_name, fn: name = $required
{   default_value, dv: (BY_NAME) key
{       (exclude, e)
{       (include, i)
{     keyend = $optional
{   description, d: (BY_NAME) string 0..256 = $optional
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 11] of clt$pdt_parameter_name,
        parameters: array [1 .. 6] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type5: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type6: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 27, 11, 927], clc$command, 11, 6, 1, 0, 0, 0, 6, 'OSM$ADMV_CHACF'],
            [['CA                             ', clc$abbreviation_entry, 4],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 4],
            ['D                              ', clc$abbreviation_entry, 3],
            ['DEFAULT_VALUE                  ', clc$nominal_entry, 2],
            ['DESCRIPTION                    ', clc$nominal_entry, 3],
            ['DV                             ', clc$abbreviation_entry, 2],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['MA                             ', clc$abbreviation_entry, 5],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 5],
            ['STATUS                         ', clc$nominal_entry, 6]], [

{ PARAMETER 1

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
            clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [4], [['E                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['EXCLUDE                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['I                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['INCLUDE                        ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]],

{ PARAMETER 3

      [[1, 0, clc$string_type], [0, 256, FALSE]],

{ PARAMETER 4

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 5

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 6

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$default_value = 2,
      p$description = 3,
      p$change_authority = 4,
      p$manage_authority = 5,
      p$status = 6;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      default_value: ^boolean,
      description: ^ost$string,
      field_name: clt$value,
      manage_authority: ^avt$validation_authority,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 1];
    pdt_changes^ [1].number := p$change_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    IF pvt [p$default_value].specified THEN
      PUSH default_value;
      IF pvt [p$default_value].value^.keyword_value = 'INCLUDE' THEN
        default_value^ := TRUE;
      ELSE
        default_value^ := FALSE;
      IFEND;
    ELSE
      default_value := NIL;
    IFEND;

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$change_authority].value, change_authority);

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);

    avp$change_capability_field (pvt [p$field_name].value^.name_value,
          current_subutility_session_info^.validation_record_name, default_value, description, NIL,
          change_authority, manage_authority, NIL, validation_file_information, status);

  PROCEND change_capability_field;
?? OLDTITLE ??
?? NEWTITLE := 'change_date_time_field', EJECT ??

{ PURPOSE:
{   This is the command processor used to alter the definition of a DATE_TIME field.

  PROCEDURE change_date_time_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chadtf) change_date_time_field, chadtf (
{   field_name, fn: name = $required
{   default_value, dv: (BY_NAME) range of date_time = $optional
{   date_display_format, ddf: (BY_NAME) key
{       (day_month_year, dmy)
{       (iso_date, iso, isod, id)
{       (month, m)
{       (month_day_year, mdy)
{       (ordinal, o), default
{     keyend = $optional
{   time_display_format, tdf: (BY_NAME) key
{       (ampm, a)
{       (hour_minute_second, hms)
{       (iso_time, iso, isot, it)
{       (millisecond, ms), default
{     keyend = $optional
{   description, d: (BY_NAME) string 0..256 = $optional
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 21] of clt$pdt_parameter_name,
        parameters: array [1 .. 11] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$range_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$date_time_type_qualifier,
          recend,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 13] of clt$keyword_specification,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 11] of clt$keyword_specification,
        recend,
        type5: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type6: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type7: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type9: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type10: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type11: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 31, 15, 23, 24, 735], clc$command, 21, 11, 1, 0, 0, 0, 11, 'OSM$ADMV_CHADTF'],
            [['CA                             ', clc$abbreviation_entry, 8],
            ['CCN                            ', clc$abbreviation_entry, 6],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 8],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 6],
            ['D                              ', clc$abbreviation_entry, 5],
            ['DA                             ', clc$abbreviation_entry, 9],
            ['DATE_DISPLAY_FORMAT            ', clc$nominal_entry, 3],
            ['DCN                            ', clc$abbreviation_entry, 7],
            ['DDF                            ', clc$abbreviation_entry, 3],
            ['DEFAULT_VALUE                  ', clc$nominal_entry, 2],
            ['DESCRIPTION                    ', clc$nominal_entry, 5],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 9],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 7],
            ['DV                             ', clc$abbreviation_entry, 2],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['MA                             ', clc$abbreviation_entry, 10],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 10],
            ['STATUS                         ', clc$nominal_entry, 11],
            ['TDF                            ', clc$abbreviation_entry, 4],
            ['TIME_DISPLAY_FORMAT            ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [15, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 12, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 488,
            clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [21, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 414, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 10

      [18, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 11

      [19, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$range_type], [5], [[1, 0, clc$date_time_type],
            [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses
            [clc$past, clc$present, clc$future]]]],

{ PARAMETER 3

      [[1, 0, clc$keyword_type], [13], [['DAY_MONTH_YEAR                 ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['DMY                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['ID                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['ISO                            ', clc$alias_entry,
            clc$normal_usage_entry, 2], ['ISOD                           ', clc$alias_entry,
            clc$normal_usage_entry, 2], ['ISO_DATE                       ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['M                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['MDY                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['MONTH                          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['MONTH_DAY_YEAR                 ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['O                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ORDINAL                        ', clc$nominal_entry,
            clc$normal_usage_entry, 5]]],

{ PARAMETER 4

      [[1, 0, clc$keyword_type], [11], [['A                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['AMPM                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['HMS                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['HOUR_MINUTE_SECOND             ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['ISO                            ', clc$alias_entry,
            clc$normal_usage_entry, 3], ['ISOT                           ', clc$alias_entry,
            clc$normal_usage_entry, 3], ['ISO_TIME                       ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['IT                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['MILLISECOND                    ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['MS                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 5

      [[1, 0, clc$string_type], [0, 256, FALSE]],

{ PARAMETER 6

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 7

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 8

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 9

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 10

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 11

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$default_value = 2,
      p$date_display_format = 3,
      p$time_display_format = 4,
      p$description = 5,
      p$change_command_names = 6,
      p$display_command_names = 7,
      p$change_authority = 8,
      p$display_authority = 9,
      p$manage_authority = 10,
      p$status = 11;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      current_parameter_value: ^clt$data_value,
      date_applies: boolean,
      date_display_format: ^clt$date_time_form_string,
      date_time_range: boolean,
      default_value: ^avt$date_time,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      display_format: ost$string,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      old_change_authority: avt$validation_authority,
      old_date_display_format: string (clc$max_date_time_form_string),
      old_default_value: avt$date_time,
      old_delete_authority: avt$validation_authority,
      old_description: ost$string,
      old_display_authority: avt$validation_authority,
      old_manage_authority: avt$validation_authority,
      old_time_display_format: string (clc$max_date_time_form_string),
      pdt_changes: ^clt$pdt_changes,
      time_applies: boolean,
      time_display_format: ^clt$date_time_form_string;

    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    field_name := pvt [p$field_name].value^.name_value;

    IF pvt [p$default_value].specified THEN
      avp$get_date_time_field_desc (field_name, current_subutility_session_info^.validation_record_name,
            osc$null_name, old_default_value, date_time_range, date_applies, time_applies,
            old_date_display_format, old_time_display_format, old_description, old_change_authority,
            old_delete_authority, old_display_authority, old_manage_authority, validation_file_information,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      PUSH default_value;
      default_value^.range := date_time_range;
      default_value^.date_specified := date_applies;
      default_value^.time_specified := time_applies;
      IF date_time_range THEN
        default_value^.starting_value := pvt [p$default_value].value^.low_value^.date_time_value.value;
        default_value^.ending_value := pvt [p$default_value].value^.high_value^.date_time_value.value;
      ELSE
        default_value^.value := pvt [p$default_value].value^.low_value^.date_time_value.value;
      IFEND;
    ELSE
      default_value := NIL;
    IFEND;

    IF pvt [p$date_display_format].specified THEN
      translate_date_display_format (pvt [p$date_display_format].value^.keyword_value, display_format);
      PUSH date_display_format: [display_format.size];
      date_display_format^ := display_format.value;
    ELSE
      date_display_format := NIL;
    IFEND;

    IF pvt [p$time_display_format].specified THEN
      translate_time_display_format (pvt [p$time_display_format].value^.keyword_value, display_format);
      PUSH time_display_format: [display_format.size];
      time_display_format^ := display_format.value;
    ELSE
      time_display_format := NIL;
    IFEND;

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);

    process_authority_parameter (pvt [p$change_authority].value, change_authority);

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);

    avp$change_date_time_field (field_name, current_subutility_session_info^.validation_record_name,
          default_value, NIL, NIL, date_display_format, time_display_format, change_command_names,
          display_command_names, description, display_authority, change_authority, manage_authority, NIL,
          validation_file_information, status);

  PROCEND change_date_time_field;
?? OLDTITLE ??
?? NEWTITLE := 'change_file_field', EJECT ??

{ PURPOSE:
{   This is the command processor used to alter the definition of a FILE field.

  PROCEDURE change_file_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chaff) change_file_field, chaff (
{   field_name, fn: name = $required
{   default_value, dv: (BY_NAME) any of
{       key
{         none
{       keyend
{       file
{       string
{     anyend = $optional
{   description, d: (BY_NAME) string 0..256 = $optional
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 17] of clt$pdt_parameter_name,
        parameters: array [1 .. 9] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: 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,
          recend,
          type_size_3: clt$type_specification_size,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type4: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type5: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type7: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type9: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 33, 30, 319], clc$command, 17, 9, 1, 0, 0, 0, 9, 'OSM$ADMV_CHAFF'],
            [['CA                             ', clc$abbreviation_entry, 6],
            ['CCN                            ', clc$abbreviation_entry, 4],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 6],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 4],
            ['D                              ', clc$abbreviation_entry, 3],
            ['DA                             ', clc$abbreviation_entry, 7],
            ['DCN                            ', clc$abbreviation_entry, 5],
            ['DEFAULT_VALUE                  ', clc$nominal_entry, 2],
            ['DESCRIPTION                    ', clc$nominal_entry, 3],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 7],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 5],
            ['DV                             ', clc$abbreviation_entry, 2],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['MA                             ', clc$abbreviation_entry, 8],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 8],
            ['STATUS                         ', clc$nominal_entry, 9]], [

{ PARAMETER 1

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 79,
            clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [16, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [17, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type, clc$string_type], FALSE, 3], 44,
            [[1, 0, clc$keyword_type], [1], [['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 3, [[1, 0, clc$file_type]], 8,
            [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]],

{ PARAMETER 3

      [[1, 0, clc$string_type], [0, 256, FALSE]],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 6

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 7

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 8

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 9

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$default_value = 2,
      p$description = 3,
      p$change_command_names = 4,
      p$display_command_names = 5,
      p$change_authority = 6,
      p$display_authority = 7,
      p$manage_authority = 8,
      p$status = 9;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      current_parameter_value: ^clt$data_value,
      default_value: ^fst$file_reference,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    field_name := pvt [p$field_name].value^.name_value;

    process_file_parameter (pvt [p$default_value].value, NIL, default_value);

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);

    process_authority_parameter (pvt [p$change_authority].value, change_authority);

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);

    avp$change_file_field (pvt [p$field_name].value^.name_value,
          current_subutility_session_info^.validation_record_name, default_value, change_command_names,
          display_command_names, description, display_authority, change_authority, manage_authority, NIL,
          validation_file_information, status);

  PROCEND change_file_field;
?? OLDTITLE ??
?? NEWTITLE := 'change_integer_field', EJECT ??

{ PURPOSE:
{   This is the command processor used to alter the definition of an INTEGER field.

  PROCEDURE change_integer_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chaif) change_integer_field, chaif (
{   field_name, fn: name = $required
{   default_value, dv: (BY_NAME) integer = $optional
{   display_field_width, dfw: (BY_NAME) integer 1..25 = $optional
{   radix, r: (BY_NAME) integer 2..16 = $optional
{   display_radix, dr: (BY_NAME) boolean = $optional
{   description, d: (BY_NAME) string 0..256 = $optional
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 23] of clt$pdt_parameter_name,
        parameters: array [1 .. 12] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type7: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type8: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type9: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type10: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type11: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type12: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 34, 2, 980], clc$command, 23, 12, 1, 0, 0, 0, 12, 'OSM$ADMV_CHAIF'],
            [['CA                             ', clc$abbreviation_entry, 9],
            ['CCN                            ', clc$abbreviation_entry, 7],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 9],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 7],
            ['D                              ', clc$abbreviation_entry, 6],
            ['DA                             ', clc$abbreviation_entry, 10],
            ['DCN                            ', clc$abbreviation_entry, 8],
            ['DEFAULT_VALUE                  ', clc$nominal_entry, 2],
            ['DESCRIPTION                    ', clc$nominal_entry, 6],
            ['DFW                            ', clc$abbreviation_entry, 3],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 10],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 8],
            ['DISPLAY_FIELD_WIDTH            ', clc$nominal_entry, 3],
            ['DISPLAY_RADIX                  ', clc$nominal_entry, 5],
            ['DR                             ', clc$abbreviation_entry, 5],
            ['DV                             ', clc$abbreviation_entry, 2],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['MA                             ', clc$abbreviation_entry, 11],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 11],
            ['R                              ', clc$abbreviation_entry, 4],
            ['RADIX                          ', clc$nominal_entry, 4],
            ['STATUS                         ', clc$nominal_entry, 12]], [

{ PARAMETER 1

      [17, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
            clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [22, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [14, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 10

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 11

      [20, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 12

      [23, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],

{ PARAMETER 3

      [[1, 0, clc$integer_type], [1, 25, 10]],

{ PARAMETER 4

      [[1, 0, clc$integer_type], [2, 16, 10]],

{ PARAMETER 5

      [[1, 0, clc$boolean_type]],

{ PARAMETER 6

      [[1, 0, clc$string_type], [0, 256, FALSE]],

{ PARAMETER 7

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 8

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 9

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 10

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 11

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 12

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$default_value = 2,
      p$display_field_width = 3,
      p$radix = 4,
      p$display_radix = 5,
      p$description = 6,
      p$change_command_names = 7,
      p$display_command_names = 8,
      p$change_authority = 9,
      p$display_authority = 10,
      p$manage_authority = 11,
      p$status = 12;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      current_parameter_value: ^clt$data_value,
      default_value: ^integer,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      display_format: ^avt$numeric_display_format,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      old_change_authority: avt$validation_authority,
      old_default_value: integer,
      old_description: ost$string,
      old_delete_authority: avt$validation_authority,
      old_display_authority: avt$validation_authority,
      old_display_format: avt$numeric_display_format,
      old_manage_authority: avt$validation_authority,
      old_maximum_value: integer,
      old_minimum_value: integer,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    avp$get_integer_field_desc (pvt [p$field_name].value^.name_value,
          current_subutility_session_info^.validation_record_name, current_subutility_session_info^.id,
          old_default_value, old_minimum_value, old_maximum_value, old_display_format, old_description,
          old_change_authority, old_delete_authority, old_display_authority, old_manage_authority,
          validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    field_name := pvt [p$field_name].value^.name_value;

    IF pvt [p$default_value].specified THEN
      default_value := ^pvt [p$default_value].value^.integer_value.value;
    ELSE
      default_value := NIL;
    IFEND;

    PUSH display_format;
    display_format^ := old_display_format;

    IF pvt [p$display_field_width].specified THEN
      display_format^.field_size := pvt [p$display_field_width].value^.integer_value.value;
    IFEND;

    IF pvt [p$radix].specified THEN
      display_format^.radix := pvt [p$radix].value^.integer_value.value;
    IFEND;

    IF pvt [p$display_radix].specified THEN
      display_format^.display_radix := pvt [p$display_radix].value^.boolean_value.value;
    IFEND;

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);

    process_authority_parameter (pvt [p$change_authority].value, change_authority);

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);

    avp$change_integer_field (pvt [p$field_name].value^.name_value,
          current_subutility_session_info^.validation_record_name, default_value, NIL, NIL, display_format,
          change_command_names, display_command_names, description, display_authority, change_authority,
          manage_authority, NIL, validation_file_information, status);

  PROCEND change_integer_field;
?? OLDTITLE ??
?? NEWTITLE := 'change_job_class_field', EJECT ??

{ PURPOSE:
{   This is the command processor used to alter the definition of the JOB_CLASS
{   field.

  PROCEDURE change_job_class_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chajcf) change_job_class_field, chajcf (
{   add_default, ad: (BY_NAME, CHECK) any of
{       key
{         all, none
{       keyend
{       list 1..256 of name
{     anyend = none
{   delete_default, dd: (BY_NAME, CHECK) any of
{       key
{         all, none
{       keyend
{       list 1..256 of name
{     anyend = none
{   interactive_default, id: (BY_NAME) any of
{       key
{         none
{       keyend
{       name
{     anyend = $optional
{   batch_default, bd: (BY_NAME) any of
{       key
{         none
{       keyend
{       name
{     anyend = $optional
{   description, d: (BY_NAME) string 0..256 = $optional
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 21] of clt$pdt_parameter_name,
        parameters: array [1 .. 11] 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 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (4),
        recend,
        type2: 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 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (4),
        recend,
        type3: 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$name_type_qualifier,
          recend,
        recend,
        type4: 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$name_type_qualifier,
          recend,
        recend,
        type5: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type6: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type7: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type9: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type10: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type11: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 34, 31, 604], clc$command, 21, 11, 0, 0, 0, 0, 11, 'OSM$ADMV_CHAJCF'],
            [['AD                             ', clc$abbreviation_entry, 1],
            ['ADD_DEFAULT                    ', clc$nominal_entry, 1],
            ['BATCH_DEFAULT                  ', clc$nominal_entry, 4],
            ['BD                             ', clc$abbreviation_entry, 4],
            ['CA                             ', clc$abbreviation_entry, 8],
            ['CCN                            ', clc$abbreviation_entry, 6],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 8],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 6],
            ['D                              ', clc$abbreviation_entry, 5],
            ['DA                             ', clc$abbreviation_entry, 9],
            ['DCN                            ', clc$abbreviation_entry, 7],
            ['DD                             ', clc$abbreviation_entry, 2],
            ['DELETE_DEFAULT                 ', clc$nominal_entry, 2],
            ['DESCRIPTION                    ', clc$nominal_entry, 5],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 9],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 7],
            ['ID                             ', clc$abbreviation_entry, 3],
            ['INTERACTIVE_DEFAULT            ', clc$nominal_entry, 3],
            ['MA                             ', clc$abbreviation_entry, 10],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 10],
            ['STATUS                         ', clc$nominal_entry, 11]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 122,
            clc$optional_default_parameter, 0, 4],

{ PARAMETER 2

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$extended_parameter_checking, 122, clc$optional_default_parameter, 0, 4],

{ PARAMETER 3

      [18, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
            clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [14, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [16, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [15, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 10

      [20, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 11

      [21, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 21, [[1, 0, clc$list_type],
            [5, 1, 256, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'none'],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 21, [[1, 0, clc$list_type],
            [5, 1, 256, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'none'],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 5

      [[1, 0, clc$string_type], [0, 256, FALSE]],

{ PARAMETER 6

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 7

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 8

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 9

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 10

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 11

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$add_default = 1,
      p$delete_default = 2,
      p$interactive_default = 3,
      p$batch_default = 4,
      p$description = 5,
      p$change_command_names = 6,
      p$display_command_names = 7,
      p$change_authority = 8,
      p$display_authority = 9,
      p$manage_authority = 10,
      p$status = 11;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      current_parameter_value: ^clt$data_value,
      default_batch_job_class: ^ost$name,
      default_interactive_job_class: ^ost$name,
      default_job_classes_to_add: ^avt$name_list,
      default_job_classes_to_delete: ^avt$name_list,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      pdt_changes: ^clt$pdt_changes;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        IF which_parameter.number = p$add_default THEN
          verify_list_of_names_value ('ADD_DEFAULT', parameter_value_table^ [p$add_default].value, status);
        ELSEIF which_parameter.number = p$delete_default THEN
          verify_list_of_names_value ('DELETE_DEFAULT', parameter_value_table^ [p$delete_default].value,
                status);
        ELSE

{ ignore the parameter.

        IFEND;
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, altered_pdt, ^check_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    field_name := avc$job_class;

    process_name_list_parameter (pvt [p$add_default].value, NIL, default_job_classes_to_add);

    process_name_list_parameter (pvt [p$delete_default].value, NIL, default_job_classes_to_delete);

    IF pvt [p$batch_default].specified THEN
      IF pvt [p$batch_default].value^.kind = clc$keyword THEN
        default_batch_job_class := ^pvt [p$batch_default].value^.keyword_value;
      ELSE
        default_batch_job_class := ^pvt [p$batch_default].value^.name_value;
      IFEND;
    ELSE
      default_batch_job_class := NIL;
    IFEND;

    IF pvt [p$interactive_default].specified THEN
      IF pvt [p$interactive_default].value^.kind = clc$keyword THEN
        default_interactive_job_class := ^pvt [p$interactive_default].value^.keyword_value;
      ELSE
        default_interactive_job_class := ^pvt [p$interactive_default].value^.name_value;
      IFEND;
    ELSE
      default_interactive_job_class := NIL;
    IFEND;

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);

    process_authority_parameter (pvt [p$change_authority].value, change_authority);

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);

    avp$change_job_class_field (field_name, current_subutility_session_info^.validation_record_name,
          default_job_classes_to_add, default_job_classes_to_delete, default_batch_job_class,
          default_interactive_job_class, NIL, NIL, change_command_names, display_command_names, description,
          display_authority, change_authority, manage_authority, NIL, validation_file_information, status);

  PROCEND change_job_class_field;
?? OLDTITLE ??
?? NEWTITLE := 'change_labeled_names_field', EJECT ??

{ PURPOSE:
{   This is the command processor used to alter the definition of a LABELED_NAMES field.

  PROCEDURE change_labeled_names_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chalnf) change_labeled_names_field, chalnf (
{   field_name, fn: name = $required
{   add_defaults, ad: (BY_NAME, CHECK) list 1..256 of record
{       label: any of
{         key
{           all, none
{         keyend
{         name
{       anyend
{       names: any of
{         key
{           all, none
{         keyend
{         list of name
{       anyend = $optional
{     recend = ((none))
{   delete_defaults, dd: (BY_NAME, CHECK) list 1..256 of record
{       label: any of
{         key
{           all, none
{         keyend
{         name
{       anyend
{       names: any of
{         key
{           all, none
{         keyend
{         list of name
{       anyend = $optional
{     recend = ((none))
{   description, d: (BY_NAME) string 0..256 = $optional
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 19] of clt$pdt_parameter_name,
      parameters: array [1 .. 10] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: 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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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 .. 2] 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,
              element_type_spec: record
                header: clt$type_specification_header,
                qualifier: clt$name_type_qualifier,
              recend,
            recend,
          recend,
        recend,
        default_value: string (8),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: 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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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 .. 2] 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,
              element_type_spec: record
                header: clt$type_specification_header,
                qualifier: clt$name_type_qualifier,
              recend,
            recend,
          recend,
        recend,
        default_value: string (8),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type5: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type6: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 14] of clt$keyword_specification,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 14] of clt$keyword_specification,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 22, 12, 59, 53, 861],
    clc$command, 19, 10, 1, 0, 0, 0, 10, 'OSM$ADMV_CHALNF'], [
    ['AD                             ',clc$abbreviation_entry, 2],
    ['ADD_DEFAULTS                   ',clc$nominal_entry, 2],
    ['CA                             ',clc$abbreviation_entry, 7],
    ['CCN                            ',clc$abbreviation_entry, 5],
    ['CHANGE_AUTHORITY               ',clc$nominal_entry, 7],
    ['CHANGE_COMMAND_NAMES           ',clc$nominal_entry, 5],
    ['D                              ',clc$abbreviation_entry, 4],
    ['DA                             ',clc$abbreviation_entry, 8],
    ['DCN                            ',clc$abbreviation_entry, 6],
    ['DD                             ',clc$abbreviation_entry, 3],
    ['DELETE_DEFAULTS                ',clc$nominal_entry, 3],
    ['DESCRIPTION                    ',clc$nominal_entry, 4],
    ['DISPLAY_AUTHORITY              ',clc$nominal_entry, 8],
    ['DISPLAY_COMMAND_NAMES          ',clc$nominal_entry, 6],
    ['FIELD_NAME                     ',clc$nominal_entry, 1],
    ['FN                             ',clc$abbreviation_entry, 1],
    ['MA                             ',clc$abbreviation_entry, 9],
    ['MANAGE_AUTHORITY               ',clc$nominal_entry, 9],
    ['STATUS                         ',clc$nominal_entry, 10]],
    [
{ PARAMETER 1
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 323,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 3
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 323,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 4
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$optional_parameter,
  0, 0],
{ PARAMETER 7
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
  clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [307, 1, 256, FALSE],
      [[1, 0, clc$record_type], [2],
      ['LABEL                          ', clc$required_field, 106], [[1, 0, clc$union_type], [[
        clc$keyword_type, clc$name_type],
        FALSE, 2],
        81, [[1, 0, clc$keyword_type], [2], [
          ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
          ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
          ],
        5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
        ],
      ['NAMES                          ', clc$optional_field, 122], [[1, 0, clc$union_type], [[
        clc$keyword_type, clc$list_type],
        FALSE, 2],
        81, [[1, 0, clc$keyword_type], [2], [
          ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
          ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
          ],
        21, [[1, 0, clc$list_type], [5, 0, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]
          ]
        ]
      ]
    ,
    '((none))'],
{ PARAMETER 3
    [[1, 0, clc$list_type], [307, 1, 256, FALSE],
      [[1, 0, clc$record_type], [2],
      ['LABEL                          ', clc$required_field, 106], [[1, 0, clc$union_type], [[
        clc$keyword_type, clc$name_type],
        FALSE, 2],
        81, [[1, 0, clc$keyword_type], [2], [
          ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
          ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
          ],
        5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
        ],
      ['NAMES                          ', clc$optional_field, 122], [[1, 0, clc$union_type], [[
        clc$keyword_type, clc$list_type],
        FALSE, 2],
        81, [[1, 0, clc$keyword_type], [2], [
          ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
          ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
          ],
        21, [[1, 0, clc$list_type], [5, 0, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]
          ]
        ]
      ]
    ,
    '((none))'],
{ PARAMETER 4
    [[1, 0, clc$string_type], [0, 256, FALSE]],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 7
    [[1, 0, clc$keyword_type], [14], [
    ['AA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['FA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FAMILY_ADMINISTRATION          ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['PA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['PROJECT_ADMINISTRATION         ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
    ['UA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['USER                           ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['USER_ADMINISTRATION            ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ],
{ PARAMETER 8
    [[1, 0, clc$keyword_type], [14], [
    ['AA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['FA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FAMILY_ADMINISTRATION          ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['PA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['PROJECT_ADMINISTRATION         ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
    ['UA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['USER                           ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['USER_ADMINISTRATION            ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ],
{ PARAMETER 9
    [[1, 0, clc$keyword_type], [4], [
    ['FA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FAMILY_ADMINISTRATION          ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['SA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 10
    [[1, 0, clc$status_type]]];

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

    CONST
      p$field_name = 1,
      p$add_defaults = 2,
      p$delete_defaults = 3,
      p$description = 4,
      p$change_command_names = 5,
      p$display_command_names = 6,
      p$change_authority = 7,
      p$display_authority = 8,
      p$manage_authority = 9,
      p$status = 10;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      defaults_to_add: ^avt$labeled_names_list,
      defaults_to_delete: ^avt$labeled_names_list,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      pdt_changes: ^clt$pdt_changes;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        IF which_parameter.number = p$add_defaults THEN
          verify_labeled_names_value ('ADD_DEFAULTS', parameter_value_table^ [p$add_defaults].value, status);
        ELSEIF which_parameter.number = p$delete_defaults THEN
          verify_labeled_names_value ('DELETE_DEFAULTS', parameter_value_table^ [p$delete_defaults].value,
                status);
        ELSE

{ ignore the parameter.

        IFEND;
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, altered_pdt, ^check_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    field_name := pvt [p$field_name].value^.name_value;

    process_labeled_names_parameter (pvt [p$add_defaults].value, NIL, defaults_to_add);

    process_labeled_names_parameter (pvt [p$delete_defaults].value, NIL, defaults_to_delete);

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);

    process_authority_parameter (pvt [p$change_authority].value, change_authority);

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);

    avp$change_labeled_names_field (field_name, current_subutility_session_info^.validation_record_name,
          defaults_to_add, defaults_to_delete, NIL, NIL, NIL, NIL, change_command_names,
          display_command_names, description, display_authority, change_authority, manage_authority, NIL,
          validation_file_information, status);

  PROCEND change_labeled_names_field;
?? OLDTITLE ??
?? NEWTITLE := 'change_limit_field', EJECT ??

{ PURPOSE:
{   This is the command processor used to alter the definition of a LIMIT field.

  PROCEDURE change_limit_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chalf) change_limit_field, chalf (
{   field_name, fn: name = $required
{   default_value, dv: (BY_NAME) any of
{       key
{         unlimited
{       keyend
{       integer 0..osc$max_integer
{     anyend = $optional
{   description, d: (BY_NAME) string 0..256 = $optional
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 17] of clt$pdt_parameter_name,
        parameters: array [1 .. 9] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: 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$integer_type_qualifier,
          recend,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type4: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type5: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type7: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type9: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 35, 18, 975], clc$command, 17, 9, 1, 0, 0, 0, 9, 'OSM$ADMV_CHALF'],
            [['CA                             ', clc$abbreviation_entry, 6],
            ['CCN                            ', clc$abbreviation_entry, 4],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 6],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 4],
            ['D                              ', clc$abbreviation_entry, 3],
            ['DA                             ', clc$abbreviation_entry, 7],
            ['DCN                            ', clc$abbreviation_entry, 5],
            ['DEFAULT_VALUE                  ', clc$nominal_entry, 2],
            ['DESCRIPTION                    ', clc$nominal_entry, 3],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 7],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 5],
            ['DV                             ', clc$abbreviation_entry, 2],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['MA                             ', clc$abbreviation_entry, 8],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 8],
            ['STATUS                         ', clc$nominal_entry, 9]], [

{ PARAMETER 1

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
            clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [16, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [17, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type], [0, osc$max_integer, 10]]],

{ PARAMETER 3

      [[1, 0, clc$string_type], [0, 256, FALSE]],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 6

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 7

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 8

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 9

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$default_value = 2,
      p$description = 3,
      p$change_command_names = 4,
      p$display_command_names = 5,
      p$change_authority = 6,
      p$display_authority = 7,
      p$manage_authority = 8,
      p$status = 9;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      current_parameter_value: ^clt$data_value,
      default_value: ^avt$limit_value,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    field_name := pvt [p$field_name].value^.name_value;

    IF pvt [p$default_value].specified THEN
      IF pvt [p$default_value].value^.kind = clc$keyword THEN
        PUSH default_value;
        default_value^ := sfc$unlimited;
      ELSE
        default_value := ^pvt [p$default_value].value^.integer_value.value;
      IFEND;
    IFEND;

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);

    process_authority_parameter (pvt [p$change_authority].value, change_authority);

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);

    avp$change_limit_field (pvt [p$field_name].value^.name_value,
          current_subutility_session_info^.validation_record_name, default_value, NIL, NIL,
          change_command_names, display_command_names, description, display_authority, change_authority,
          manage_authority, NIL, validation_file_information, status);

  PROCEND change_limit_field;
?? OLDTITLE ??
?? NEWTITLE := 'change_login_password_field', EJECT ??

{ PURPOSE:
{   This is the command processor used to alter the definition of the LOGIN_PASSWORD
{   field.

  PROCEDURE change_login_password_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chalpwf) change_login_password_field, chalpwf (
{   default_password, dpw: (BY_NAME, SECURE) name = $optional
{   default_expiration_date, ded: (BY_NAME) any of
{       key
{         none
{       keyend
{       date_time
{     anyend = $optional
{   default_expiration_interval, dei: (BY_NAME) any of
{       key
{         unlimited
{       keyend
{       integer 1..365
{     anyend = $optional
{   default_max_expiration_interval, dmaxei: (BY_NAME) any of
{       key
{         unlimited
{       keyend
{       integer 1..365
{     anyend = $optional
{   default_exp_warning_interval, dewi: (BY_NAME) any of
{       key
{         unlimited
{       keyend
{       integer 0..365
{     anyend = $optional
{   add_default_attributes, ada: (BY_NAME) any of
{       key
{         all, none
{       keyend
{       list 1..256 of name
{     anyend = none
{   delete_default_attributes, dda: (BY_NAME) any of
{       key
{         all, none
{       keyend
{       list 1..256 of name
{     anyend = none
{   description, d: (BY_NAME) string 0..256 = $optional
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 27] of clt$pdt_parameter_name,
        parameters: array [1 .. 14] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: 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$date_time_type_qualifier,
          recend,
        recend,
        type3: 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$integer_type_qualifier,
          recend,
        recend,
        type4: 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$integer_type_qualifier,
          recend,
        recend,
        type5: 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$integer_type_qualifier,
          recend,
        recend,
        type6: 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 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (4),
        recend,
        type7: 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 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (4),
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type9: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type10: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type11: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type12: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type13: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type14: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 35, 47, 692], clc$command, 27, 14, 0, 0, 0, 0, 14, 'OSM$ADMV_CHALPWF'],
            [['ADA                            ', clc$abbreviation_entry, 6],
            ['ADD_DEFAULT_ATTRIBUTES         ', clc$nominal_entry, 6],
            ['CA                             ', clc$abbreviation_entry, 11],
            ['CCN                            ', clc$abbreviation_entry, 9],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 11],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 9],
            ['D                              ', clc$abbreviation_entry, 8],
            ['DA                             ', clc$abbreviation_entry, 12],
            ['DCN                            ', clc$abbreviation_entry, 10],
            ['DDA                            ', clc$abbreviation_entry, 7],
            ['DED                            ', clc$abbreviation_entry, 2],
            ['DEFAULT_EXPIRATION_DATE        ', clc$nominal_entry, 2],
            ['DEFAULT_EXPIRATION_INTERVAL    ', clc$nominal_entry, 3],
            ['DEFAULT_EXP_WARNING_INTERVAL   ', clc$nominal_entry, 5],
            ['DEFAULT_MAX_EXPIRATION_INTERVAL', clc$nominal_entry, 4],
            ['DEFAULT_PASSWORD               ', clc$nominal_entry, 1],
            ['DEI                            ', clc$abbreviation_entry, 3],
            ['DELETE_DEFAULT_ATTRIBUTES      ', clc$nominal_entry, 7],
            ['DESCRIPTION                    ', clc$nominal_entry, 8],
            ['DEWI                           ', clc$abbreviation_entry, 5],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 12],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 10],
            ['DMAXEI                         ', clc$abbreviation_entry, 4],
            ['DPW                            ', clc$abbreviation_entry, 1],
            ['MA                             ', clc$abbreviation_entry, 13],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 13],
            ['STATUS                         ', clc$nominal_entry, 14]], [

{ PARAMETER 1

      [16, clc$normal_usage_entry, clc$secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
            clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [15, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [14, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 122,
            clc$optional_default_parameter, 0, 4],

{ PARAMETER 7

      [18, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 122, clc$optional_default_parameter, 0, 4],

{ PARAMETER 8

      [19, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_parameter, 0, 0],

{ PARAMETER 10

      [22, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 11

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 12

      [21, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 13

      [26, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 14

      [27, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$date_time_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$date_time_type],
            [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses
            [clc$past, clc$present, clc$future]]]],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type], [1, 365, 10]]],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type], [1, 365, 10]]],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type], [0, 365, 10]]],

{ PARAMETER 6

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 21, [[1, 0, clc$list_type],
            [5, 1, 256, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'none'],

{ PARAMETER 7

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 21, [[1, 0, clc$list_type],
            [5, 1, 256, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'none'],

{ PARAMETER 8

      [[1, 0, clc$string_type], [0, 256, FALSE]],

{ PARAMETER 9

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 10

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 11

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 12

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 13

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 14

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$default_password = 1,
      p$default_expiration_date = 2,
      p$default_expiration_interval = 3,
      p$default_max_expiration_interv = 4 {DEFAULT_MAX_EXPIRATION_INTERVAL} ,
      p$default_exp_warning_interval = 5,
      p$add_default_attributes = 6,
      p$delete_default_attributes = 7,
      p$description = 8,
      p$change_command_names = 9,
      p$display_command_names = 10,
      p$change_authority = 11,
      p$display_authority = 12,
      p$manage_authority = 13,
      p$status = 14;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      current_parameter_value: ^clt$data_value,
      default_attributes_to_add: ^avt$name_list,
      default_attributes_to_delete: ^avt$name_list,
      default_expiration_date: ^ost$date_time,
      default_expiration_interval: ^pmt$time_increment,
      default_exp_pw_chg_interval: ^pmt$time_increment,
      default_exp_warning_interval: ^pmt$time_increment,
      default_max_expiration_interval: ^pmt$time_increment,
      default_password: ^avt$login_password,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      expiration_date_param_value: ^avt$date_time,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      pdt_changes: ^clt$pdt_changes;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        IF which_parameter.number = p$add_default_attributes THEN
          verify_list_of_names_value ('ADD_DEFAULT_ATTRIBUTES',
                parameter_value_table^ [p$add_default_attributes].value, status);
        ELSEIF which_parameter.number = p$delete_default_attributes THEN
          verify_list_of_names_value ('DELETE_DEFAULT_ATTRIBUTES',
                parameter_value_table^ [p$delete_default_attributes].value, status);
        ELSE

{ ignore the parameter.

        IFEND;
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, altered_pdt, ^check_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    field_name := avc$login_password;

    IF pvt [p$default_password].specified THEN
      PUSH default_password;
      default_password^.encrypted := FALSE;
      default_password^.value := pvt [p$default_password].value^.name_value;
    ELSE
      default_password := NIL;
    IFEND;

    IF pvt [p$default_expiration_date].specified THEN
      PUSH default_expiration_date;
      IF pvt [p$default_expiration_date].value^.kind = clc$keyword THEN
        default_expiration_date^ := avv$unlimited_date_time;
      ELSE { clc$date_time }
        default_expiration_date^ := pvt [p$default_expiration_date].value^.date_time_value.value;
      IFEND;
    ELSE
      default_expiration_date := NIL;
    IFEND;

    IF pvt [p$default_expiration_interval].specified THEN
      PUSH default_expiration_interval;
      IF pvt [p$default_expiration_interval].value^.kind = clc$keyword THEN
        default_expiration_interval^ := avv$unlimited_time_increment;
      ELSE { clc$integer}
        default_expiration_interval^ := avv$zero_time_increment;
        default_expiration_interval^.day := pvt [p$default_expiration_interval].value^.integer_value.value;
      IFEND;
    ELSE
      default_expiration_interval := NIL;
    IFEND;

    IF pvt [p$default_max_expiration_interv].specified THEN
      PUSH default_max_expiration_interval;
      IF pvt [p$default_max_expiration_interv].value^.kind = clc$keyword THEN
        default_max_expiration_interval^ := avv$unlimited_time_increment;
      ELSE { clc$integer}
        default_max_expiration_interval^ := avv$zero_time_increment;
        default_max_expiration_interval^.day := pvt [p$default_max_expiration_interv].value^.integer_value.
              value;
      IFEND;
    ELSE
      default_max_expiration_interval := NIL;
    IFEND;

    IF pvt [p$default_exp_warning_interval].specified THEN
      PUSH default_exp_warning_interval;
      IF pvt [p$default_exp_warning_interval].value^.kind = clc$keyword THEN
        default_exp_warning_interval^ := avv$unlimited_time_increment;
      ELSE { clc$integer}
        default_exp_warning_interval^ := avv$zero_time_increment;
        default_exp_warning_interval^.day := -pvt [p$default_exp_warning_interval].value^.integer_value.value;
      IFEND;
    ELSE
      default_exp_warning_interval := NIL;
    IFEND;

    process_name_list_parameter (pvt [p$add_default_attributes].value, NIL, default_attributes_to_add);

    process_name_list_parameter (pvt [p$delete_default_attributes].value, NIL, default_attributes_to_delete);

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);

    process_authority_parameter (pvt [p$change_authority].value, change_authority);

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);

    avp$change_login_password_field (field_name, current_subutility_session_info^.validation_record_name,
          default_password, default_expiration_date, default_expiration_interval,
          default_max_expiration_interval, default_exp_warning_interval, NIL, default_attributes_to_add,
          default_attributes_to_delete, change_command_names, display_command_names, description,
          display_authority, change_authority, manage_authority, NIL, validation_file_information, status);

  PROCEND change_login_password_field;
?? OLDTITLE ??
?? NEWTITLE := 'change_name_field', EJECT ??

{ PURPOSE:
{   This is the command processor used to alter the definition of a NAME field.

  PROCEDURE change_name_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chanf) change_name_field, chanf (
{   field_name, fn: name = $required
{   add_default_names, adn: (BY_NAME, CHECK) any of
{       key
{         all, none
{       keyend
{       list 1..256 of name
{     anyend = none
{   delete_default_names, ddn: (BY_NAME, CHECK) any of
{       key
{         all, none
{       keyend
{       list 1..256 of name
{     anyend = none
{   description, d: (BY_NAME) string 0..256 = $optional
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 19] of clt$pdt_parameter_name,
        parameters: array [1 .. 10] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: 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 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (4),
        recend,
        type3: 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 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (4),
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type5: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type6: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type7: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type9: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type10: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 36, 23, 169], clc$command, 19, 10, 1, 0, 0, 0, 10, 'OSM$ADMV_CHANF'],
            [['ADD_DEFAULT_NAMES              ', clc$nominal_entry, 2],
            ['ADN                            ', clc$abbreviation_entry, 2],
            ['CA                             ', clc$abbreviation_entry, 7],
            ['CCN                            ', clc$abbreviation_entry, 5],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 7],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 5],
            ['D                              ', clc$abbreviation_entry, 4],
            ['DA                             ', clc$abbreviation_entry, 8],
            ['DCN                            ', clc$abbreviation_entry, 6],
            ['DDN                            ', clc$abbreviation_entry, 3],
            ['DELETE_DEFAULT_NAMES           ', clc$nominal_entry, 3],
            ['DESCRIPTION                    ', clc$nominal_entry, 4],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 8],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 6],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['MA                             ', clc$abbreviation_entry, 9],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 9],
            ['STATUS                         ', clc$nominal_entry, 10]], [

{ PARAMETER 1

      [15, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 122,
            clc$optional_default_parameter, 0, 4],

{ PARAMETER 3

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$extended_parameter_checking, 122, clc$optional_default_parameter, 0, 4],

{ PARAMETER 4

      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [14, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [18, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 10

      [19, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 21, [[1, 0, clc$list_type],
            [5, 1, 256, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'none'],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 21, [[1, 0, clc$list_type],
            [5, 1, 256, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'none'],

{ PARAMETER 4

      [[1, 0, clc$string_type], [0, 256, FALSE]],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 6

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 7

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 8

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 9

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 10

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$add_default_names = 2,
      p$delete_default_names = 3,
      p$description = 4,
      p$change_command_names = 5,
      p$display_command_names = 6,
      p$change_authority = 7,
      p$display_authority = 8,
      p$manage_authority = 9,
      p$status = 10;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      default_names_to_add: ^avt$name_list,
      default_names_to_delete: ^avt$name_list,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      pdt_changes: ^clt$pdt_changes;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        IF which_parameter.number = p$add_default_names THEN
          verify_list_of_names_value ('ADD_DEFAULT_NAMES', parameter_value_table^ [p$add_default_names].value,
                status);
        ELSEIF which_parameter.number = p$delete_default_names THEN
          verify_list_of_names_value ('DELETE_DEFAULT_NAMES',
                parameter_value_table^ [p$delete_default_names].value, status);
        ELSE

{ ignore the parameter.

        IFEND;
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, altered_pdt, ^check_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    field_name := pvt [p$field_name].value^.name_value;

    process_name_list_parameter (pvt [p$add_default_names].value, NIL, default_names_to_add);

    process_name_list_parameter (pvt [p$delete_default_names].value, NIL, default_names_to_delete);

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);

    process_authority_parameter (pvt [p$change_authority].value, change_authority);

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);

    avp$change_name_field (field_name, current_subutility_session_info^.validation_record_name,
          default_names_to_add, default_names_to_delete, NIL, NIL, NIL, NIL, change_command_names,
          display_command_names, description, display_authority, change_authority, manage_authority, NIL,
          validation_file_information, status);

  PROCEND change_name_field;
?? OLDTITLE ??
?? NEWTITLE := 'change_real_field', EJECT ??

{ PURPOSE:
{   This is the command processor used to alter the definition of a REAL field.

  PROCEDURE change_real_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_charf) change_real_field, charf (
{   field_name, fn: name = $required
{   default_value, dv: (BY_NAME) real = $optional
{   display_field_width, dfw: (BY_NAME) list 1..2 of integer 1..25 = $optional
{   description, d: (BY_NAME) string 0..256 = $optional
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 19] of clt$pdt_parameter_name,
        parameters: array [1 .. 10] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$real_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type5: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type6: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type7: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type9: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type10: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 37, 3, 669], clc$command, 19, 10, 1, 0, 0, 0, 10, 'OSM$ADMV_CHARF'],
            [['CA                             ', clc$abbreviation_entry, 7],
            ['CCN                            ', clc$abbreviation_entry, 5],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 7],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 5],
            ['D                              ', clc$abbreviation_entry, 4],
            ['DA                             ', clc$abbreviation_entry, 8],
            ['DCN                            ', clc$abbreviation_entry, 6],
            ['DEFAULT_VALUE                  ', clc$nominal_entry, 2],
            ['DESCRIPTION                    ', clc$nominal_entry, 4],
            ['DFW                            ', clc$abbreviation_entry, 3],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 8],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 6],
            ['DISPLAY_FIELD_WIDTH            ', clc$nominal_entry, 3],
            ['DV                             ', clc$abbreviation_entry, 2],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['MA                             ', clc$abbreviation_entry, 9],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 9],
            ['STATUS                         ', clc$nominal_entry, 10]], [

{ PARAMETER 1

      [15, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 35,
            clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 36, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [18, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 10

      [19, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$real_type], [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
            [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]]],

{ PARAMETER 3

      [[1, 0, clc$list_type], [20, 1, 2, FALSE], [[1, 0, clc$integer_type], [1, 25, 10]]],

{ PARAMETER 4

      [[1, 0, clc$string_type], [0, 256, FALSE]],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 6

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 7

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 8

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 9

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 10

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$default_value = 2,
      p$display_field_width = 3,
      p$description = 4,
      p$change_command_names = 5,
      p$display_command_names = 6,
      p$change_authority = 7,
      p$display_authority = 8,
      p$manage_authority = 9,
      p$status = 10;

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

    TYPE
      long_real_type = record
        first: real,
        second: real,
      recend;

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      default_long_real_value: long_real_type,
      default_value: ^real,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      display_format: ^avt$numeric_display_format,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    field_name := pvt [p$field_name].value^.name_value;

    IF pvt [p$default_value].specified THEN
      #UNCHECKED_CONVERSION (pvt [p$default_value].value^.real_value.value, default_long_real_value);
      PUSH default_value;
      default_value^ := default_long_real_value.first;
    ELSE
      default_value := NIL;
    IFEND;

    IF pvt [p$display_field_width].specified THEN
      PUSH display_format;
      IF clp$count_list_elements (pvt [p$display_field_width].value) = 1 THEN
        display_format^.kind := avc$floating_point_format;
        display_format^.field_size := pvt [p$display_field_width].value^.element_value^.integer_value.value;
      ELSE
        display_format^.kind := avc$fixed_point_format;
        display_format^.field_size := pvt [p$display_field_width].value^.element_value^.integer_value.value;
        display_format^.fraction_size := pvt [p$display_field_width].value^.link^.element_value^.
              integer_value.value;
      IFEND;
    ELSE
      display_format := NIL;
    IFEND;

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);

    process_authority_parameter (pvt [p$change_authority].value, change_authority);

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);

    avp$change_real_field (field_name, current_subutility_session_info^.validation_record_name, default_value,
          NIL, NIL, display_format, change_command_names, display_command_names, description,
          display_authority, change_authority, manage_authority, NIL, validation_file_information, status);

  PROCEND change_real_field;
?? OLDTITLE ??
?? NEWTITLE := 'change_ring_privilege_field', EJECT ??

{ PURPOSE:
{   This is the command processor used to alter the definition of the RING_PRIVILEGE
{   field.

  PROCEDURE change_ring_privilege_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_charpf) change_ring_privilege_field, charpf (
{   default_minimum_ring, dminr: (BY_NAME) integer 4..13 = $optional
{   default_nominal_ring, dnr: (BY_NAME) integer 4..13 = $optional
{   description, d: (BY_NAME) string 0..256 = $optional
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 17] of clt$pdt_parameter_name,
        parameters: array [1 .. 9] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type4: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type5: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type7: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type9: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 37, 32, 505], clc$command, 17, 9, 0, 0, 0, 0, 9, 'OSM$ADMV_CHARPF'],
            [['CA                             ', clc$abbreviation_entry, 6],
            ['CCN                            ', clc$abbreviation_entry, 4],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 6],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 4],
            ['D                              ', clc$abbreviation_entry, 3],
            ['DA                             ', clc$abbreviation_entry, 7],
            ['DCN                            ', clc$abbreviation_entry, 5],
            ['DEFAULT_MINIMUM_RING           ', clc$nominal_entry, 1],
            ['DEFAULT_NOMINAL_RING           ', clc$nominal_entry, 2],
            ['DESCRIPTION                    ', clc$nominal_entry, 3],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 7],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 5],
            ['DMINR                          ', clc$abbreviation_entry, 1],
            ['DNR                            ', clc$abbreviation_entry, 2],
            ['MA                             ', clc$abbreviation_entry, 8],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 8],
            ['STATUS                         ', clc$nominal_entry, 9]], [

{ PARAMETER 1

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
            clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
            clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [16, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [17, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$integer_type], [4, 13, 10]],

{ PARAMETER 2

      [[1, 0, clc$integer_type], [4, 13, 10]],

{ PARAMETER 3

      [[1, 0, clc$string_type], [0, 256, FALSE]],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 6

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 7

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 8

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 9

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$default_minimum_ring = 1,
      p$default_nominal_ring = 2,
      p$description = 3,
      p$change_command_names = 4,
      p$display_command_names = 5,
      p$change_authority = 6,
      p$display_authority = 7,
      p$manage_authority = 8,
      p$status = 9;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      default_minimum_ring: ^ost$ring,
      default_nominal_ring: ^ost$ring,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    field_name := avc$ring_privileges;

    IF pvt [p$default_minimum_ring].specified THEN
      PUSH default_minimum_ring;
      default_minimum_ring^ := pvt [p$default_minimum_ring].value^.integer_value.value;
    ELSE
      default_minimum_ring := NIL;
    IFEND;

    IF pvt [p$default_nominal_ring].specified THEN
      PUSH default_nominal_ring;
      default_nominal_ring^ := pvt [p$default_nominal_ring].value^.integer_value.value;
    ELSE
      default_nominal_ring := NIL;
    IFEND;

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);

    process_authority_parameter (pvt [p$change_authority].value, change_authority);

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);

    avp$change_ring_privilege_field (field_name, current_subutility_session_info^.validation_record_name,
          default_minimum_ring, default_nominal_ring, change_command_names, display_command_names,
          description, display_authority, change_authority, manage_authority, NIL,
          validation_file_information, status);

  PROCEND change_ring_privilege_field;
?? OLDTITLE ??
?? NEWTITLE := 'change_string_field', EJECT ??

{ PURPOSE:
{   This is the command processor used to alter the definition of a STRING field.

  PROCEDURE change_string_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chasf) change_string_field, chasf (
{   field_name, fn: name = $required
{   default_value, dv: (BY_NAME) string 0..256 = $optional
{   description, d: (BY_NAME) string 0..256 = $optional
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = $optional
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 17] of clt$pdt_parameter_name,
        parameters: array [1 .. 9] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type4: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type5: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type7: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type9: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 37, 59, 313], clc$command, 17, 9, 1, 0, 0, 0, 9, 'OSM$ADMV_CHASF'],
            [['CA                             ', clc$abbreviation_entry, 6],
            ['CCN                            ', clc$abbreviation_entry, 4],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 6],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 4],
            ['D                              ', clc$abbreviation_entry, 3],
            ['DA                             ', clc$abbreviation_entry, 7],
            ['DCN                            ', clc$abbreviation_entry, 5],
            ['DEFAULT_VALUE                  ', clc$nominal_entry, 2],
            ['DESCRIPTION                    ', clc$nominal_entry, 3],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 7],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 5],
            ['DV                             ', clc$abbreviation_entry, 2],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['MA                             ', clc$abbreviation_entry, 8],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 8],
            ['STATUS                         ', clc$nominal_entry, 9]], [

{ PARAMETER 1

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [16, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [17, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$string_type], [0, 256, FALSE]],

{ PARAMETER 3

      [[1, 0, clc$string_type], [0, 256, FALSE]],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 6

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 7

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 8

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 9

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$default_value = 2,
      p$description = 3,
      p$change_command_names = 4,
      p$display_command_names = 5,
      p$change_authority = 6,
      p$display_authority = 7,
      p$manage_authority = 8,
      p$status = 9;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      default_value: ^ost$string,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    field_name := pvt [p$field_name].value^.name_value;

    IF pvt [p$default_value].specified THEN
      PUSH default_value;
      default_value^.value := pvt [p$default_value].value^.string_value^;
      default_value^.size := #SIZE (pvt [p$default_value].value^.string_value^);
    ELSE
      default_value := NIL;
    IFEND;

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);

    process_authority_parameter (pvt [p$change_authority].value, change_authority);

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);

    avp$change_string_field (field_name, current_subutility_session_info^.validation_record_name,
          default_value, NIL, NIL, change_command_names, display_command_names, description,
          display_authority, change_authority, manage_authority, NIL, validation_file_information, status);

  PROCEND change_string_field;
?? OLDTITLE ??
?? NEWTITLE := 'create_accumulating_limit_field', EJECT ??

{ PURPOSE:
{   This is the command processor used create an ACCUMULATING_LIMIT field.

  PROCEDURE create_accumulating_limit_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_crealf) create_accumulating_limit_field, crealf (
{   field_name, fn: name = $required
{   limit_name, ln: (BY_NAME) name = $optional
{   default_job_maximum_limit, djmaxl: (BY_NAME) any of
{       key
{         unlimited
{       keyend
{       integer 0..osc$max_integer
{     anyend = unlimited
{   default_job_warning_limit, djwl: (BY_NAME) any of
{       key
{         unlimited
{       keyend
{       integer 0..osc$max_integer
{     anyend = unlimited
{   default_total_limit, dtl: (BY_NAME) any of
{       key
{         unlimited
{       keyend
{       integer 0..osc$max_integer
{     anyend = unlimited
{   limit_application, la: (BY_NAME) key
{       (job_limits_apply, jla)
{       (total_limit_applies, tla)
{       (job_and_total_limits_apply, jatla)
{     keyend = job_and_total_limits_apply
{   job_limit_value_range, jlvr: (BY_NAME) range of any of
{       key
{         unlimited
{       keyend
{       integer 0..osc$max_integer
{     anyend = (0  .. unlimited)
{   update_statistic, update_statistics, us: (BY_NAME, CHECK) any of
{       key
{         none
{       keyend
{       list of statistic_code
{     anyend = none
{   total_limit_prevents_login, tlpl: (BY_NAME) boolean = true
{   description, d: (BY_NAME) string 0..256 = ''
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 32] of clt$pdt_parameter_name,
        parameters: array [1 .. 16] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type3: 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$integer_type_qualifier,
          recend,
          default_value: string (9),
        recend,
        type4: 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$integer_type_qualifier,
          recend,
          default_value: string (9),
        recend,
        type5: 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$integer_type_qualifier,
          recend,
          default_value: string (9),
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 6] of clt$keyword_specification,
          default_value: string (26),
        recend,
        type7: record
          header: clt$type_specification_header,
          qualifier: clt$range_type_qualifier,
          element_type_spec: 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$integer_type_qualifier,
            recend,
          recend,
          default_value: string (17),
        recend,
        type8: 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,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
          default_value: string (4),
        recend,
        type9: record
          header: clt$type_specification_header,
          default_value: string (4),
        recend,
        type10: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
          default_value: string (2),
        recend,
        type11: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (7),
        recend,
        type12: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (7),
        recend,
        type13: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type14: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type15: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type16: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 18, 15, 59, 37, 832], clc$command, 32, 16, 1, 0, 0, 0, 16, 'OSM$ADMV_CREALF'],
            [['CA                             ', clc$abbreviation_entry, 13],
            ['CCN                            ', clc$abbreviation_entry, 11],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 13],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 11],
            ['D                              ', clc$abbreviation_entry, 10],
            ['DA                             ', clc$abbreviation_entry, 14],
            ['DCN                            ', clc$abbreviation_entry, 12],
            ['DEFAULT_JOB_MAXIMUM_LIMIT      ', clc$nominal_entry, 3],
            ['DEFAULT_JOB_WARNING_LIMIT      ', clc$nominal_entry, 4],
            ['DEFAULT_TOTAL_LIMIT            ', clc$nominal_entry, 5],
            ['DESCRIPTION                    ', clc$nominal_entry, 10],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 14],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 12],
            ['DJMAXL                         ', clc$abbreviation_entry, 3],
            ['DJWL                           ', clc$abbreviation_entry, 4],
            ['DTL                            ', clc$abbreviation_entry, 5],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['JLVR                           ', clc$abbreviation_entry, 7],
            ['JOB_LIMIT_VALUE_RANGE          ', clc$nominal_entry, 7],
            ['LA                             ', clc$abbreviation_entry, 6],
            ['LIMIT_APPLICATION              ', clc$nominal_entry, 6],
            ['LIMIT_NAME                     ', clc$nominal_entry, 2],
            ['LN                             ', clc$abbreviation_entry, 2],
            ['MA                             ', clc$abbreviation_entry, 15],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 15],
            ['STATUS                         ', clc$nominal_entry, 16],
            ['TLPL                           ', clc$abbreviation_entry, 9],
            ['TOTAL_LIMIT_PREVENTS_LOGIN     ', clc$nominal_entry, 9],
            ['UPDATE_STATISTIC               ', clc$nominal_entry, 8],
            ['UPDATE_STATISTICS              ', clc$alias_entry, 8],
            ['US                             ', clc$abbreviation_entry, 8]], [

{ PARAMETER 1

      [17, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [23, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
            clc$optional_default_parameter, 0, 9],

{ PARAMETER 4

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
            clc$optional_default_parameter, 0, 9],

{ PARAMETER 5

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 84, clc$optional_default_parameter, 0, 9],

{ PARAMETER 6

      [22, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 229, clc$optional_default_parameter, 0, 26],

{ PARAMETER 7

      [20, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 91, clc$optional_default_parameter, 0, 17],

{ PARAMETER 8

      [30, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$extended_parameter_checking, 83, clc$optional_default_parameter, 0, 4],

{ PARAMETER 9

      [29, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 4],

{ PARAMETER 10

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 2],

{ PARAMETER 11

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 7],

{ PARAMETER 12

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 7],

{ PARAMETER 13

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 14

      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 15

      [26, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 16

      [27, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type], [0, osc$max_integer, 10]],
            'unlimited'],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type], [0, osc$max_integer, 10]],
            'unlimited'],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type], [0, osc$max_integer, 10]],
            'unlimited'],

{ PARAMETER 6

      [[1, 0, clc$keyword_type], [6], [['JATLA                          ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['JLA                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['JOB_AND_TOTAL_LIMITS_APPLY     ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['JOB_LIMITS_APPLY               ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['TLA                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['TOTAL_LIMIT_APPLIES            ', clc$nominal_entry,
            clc$normal_usage_entry, 2]], 'job_and_total_limits_apply'],

{ PARAMETER 7

      [[1, 0, clc$range_type], [84], [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 44, [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type], [0, osc$max_integer, 10]]],
            '(0  .. unlimited)'],

{ PARAMETER 8

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 19, [[1, 0, clc$list_type],
            [3, 1, clc$max_list_size, FALSE], [[1, 0, clc$statistic_code_type]]], 'none'],

{ PARAMETER 9

      [[1, 0, clc$boolean_type], 'true'],

{ PARAMETER 10

      [[1, 0, clc$string_type], [0, 256, FALSE], ''''''],

{ PARAMETER 11

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'default'],

{ PARAMETER 12

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'default'],

{ PARAMETER 13

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 14

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 15

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 16

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$limit_name = 2,
      p$default_job_maximum_limit = 3,
      p$default_job_warning_limit = 4,
      p$default_total_limit = 5,
      p$limit_application = 6,
      p$job_limit_value_range = 7,
      p$update_statistic = 8,
      p$total_limit_prevents_login = 9,
      p$description = 10,
      p$change_command_names = 11,
      p$display_command_names = 12,
      p$change_authority = 13,
      p$display_authority = 14,
      p$manage_authority = 15,
      p$status = 16;

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

    VAR
      total_limit_applies: ^boolean,
      total_limit_stops_login: ^boolean,
      change_command_names: ^avt$name_list,
      change_authority: ^avt$validation_authority,
      common_job_classes: ^avt$name_list,
      current_parameter_value: ^clt$data_value,
      altered_pdt: ^clt$parameter_description_table,
      pdt_changes: ^clt$pdt_changes,
      default_job_warning_limit: ^avt$limit_value,
      default_job_maximum_limit: ^avt$limit_value,
      default_total_limit: ^avt$limit_value,
      delete_authority: ^avt$validation_authority,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      field_name: ost$name,
      index: integer,
      job_limits_apply: ^boolean,
      limit_name: ^ost$name,
      limit_update_statistics: ^sft$limit_update_statistics,
      manage_authority: ^avt$validation_authority,
      maximum_job_limit_value: ^avt$limit_value,
      minimum_job_limit_value: ^avt$limit_value;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF (which_parameter.specific) AND (which_parameter.number = p$update_statistic) THEN
        verify_statistic_code_value ('UPDATE_STATISTIC', parameter_value_table^ [p$update_statistic].value,
              status);
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF current_subutility_session_info^.validation_record_name <> avc$user_record_name THEN

{ Hide parameters dealing with job limits.

      PUSH pdt_changes: [1 .. 6];
      pdt_changes^ [1].number := p$default_job_maximum_limit;
      pdt_changes^ [1].kind := clc$pdtc_availability;
      pdt_changes^ [1].availability := clc$hidden_entry;
      pdt_changes^ [2].number := p$default_job_warning_limit;
      pdt_changes^ [2].kind := clc$pdtc_availability;
      pdt_changes^ [2].availability := clc$hidden_entry;
      pdt_changes^ [3].number := p$limit_name;
      pdt_changes^ [3].kind := clc$pdtc_availability;
      pdt_changes^ [3].availability := clc$hidden_entry;
      pdt_changes^ [4].number := p$limit_application;
      pdt_changes^ [4].kind := clc$pdtc_availability;
      pdt_changes^ [4].availability := clc$hidden_entry;
      pdt_changes^ [5].number := p$update_statistic;
      pdt_changes^ [5].kind := clc$pdtc_availability;
      pdt_changes^ [5].availability := clc$hidden_entry;
      pdt_changes^ [6].number := p$job_limit_value_range;
      pdt_changes^ [6].kind := clc$pdtc_availability;
      pdt_changes^ [6].availability := clc$hidden_entry;

      clp$change_pdt (altered_pdt, pdt_changes^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    clp$evaluate_parameters (parameter_list, altered_pdt, ^check_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    field_name := pvt [p$field_name].value^.name_value;

    PUSH limit_name;
    IF current_subutility_session_info^.validation_record_name = avc$user_record_name THEN
      IF pvt [p$limit_name].specified THEN
        limit_name^ := pvt [p$limit_name].value^.name_value;
      ELSE
        limit_name^ := field_name;
      IFEND;
    ELSE
      limit_name^ := osc$null_name;
    IFEND;

{ Determine limit application.  If creating the limit in a user record, use the
{ values specified on the command, otherwise only allow total limits.

    IF current_subutility_session_info^.validation_record_name = avc$user_record_name THEN
      process_limit_appl_parameter (pvt [p$limit_application].value, job_limits_apply, total_limit_applies);
    ELSE
      PUSH job_limits_apply;
      job_limits_apply^ := FALSE;
      PUSH total_limit_applies;
      total_limit_applies^ := TRUE;
    IFEND;

    IF current_subutility_session_info^.validation_record_name = avc$user_record_name THEN
      process_limit_parameter (pvt [p$default_job_maximum_limit].value, NIL, default_job_maximum_limit);
      process_limit_parameter (pvt [p$default_job_warning_limit].value, NIL, default_job_warning_limit);
    ELSE
      PUSH default_job_warning_limit;
      default_job_warning_limit^ := sfc$unlimited;
      PUSH default_job_maximum_limit;
      default_job_maximum_limit^ := sfc$unlimited;
    IFEND;

    process_limit_parameter (pvt [p$default_total_limit].value, NIL, default_total_limit);

    total_limit_stops_login := ^pvt [p$total_limit_prevents_login].value^.boolean_value.value;

    IF current_subutility_session_info^.validation_record_name = avc$user_record_name THEN
      process_limit_range_parameter (pvt [p$job_limit_value_range].value, minimum_job_limit_value,
            maximum_job_limit_value);
    ELSE
      PUSH minimum_job_limit_value;
      PUSH maximum_job_limit_value;
      minimum_job_limit_value^ := 0;
      maximum_job_limit_value^ := sfc$unlimited;
    IFEND;

    IF current_subutility_session_info^.validation_record_name = avc$user_record_name THEN
      IF pvt [p$update_statistic].value^.kind = clc$keyword THEN
        limit_update_statistics := NIL;
      ELSE { list of statistic_code }
        PUSH limit_update_statistics: [1 .. clp$count_list_elements (pvt [p$update_statistic].value)];
        current_parameter_value := pvt [p$update_statistic].value;
        index := 0;
        REPEAT
          index := index + 1;
          limit_update_statistics^ [index].statistic_code :=
                current_parameter_value^.element_value^.statistic_code_value;
          limit_update_statistics^ [index].update_kind := sfc$update_based_on_counter;
          limit_update_statistics^ [index].counter := 1;
          current_parameter_value := current_parameter_value^.link;
        UNTIL current_parameter_value = NIL;
      IFEND;
    ELSE
      limit_update_statistics := NIL;
    IFEND;

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);
    IF (display_authority = NIL) THEN
      PUSH display_authority;
      IF current_subutility_session_info^.validation_record_name = avc$user_record_name THEN
        display_authority^ := avc$user_authority;
      ELSEIF (current_subutility_session_info^.validation_record_name = avc$account_record_name) OR
            (current_subutility_session_info^.validation_record_name = avc$account_member_record_name) THEN
        display_authority^ := avc$account_admin_authority;
      ELSE
        display_authority^ := avc$project_admin_authority;
      IFEND;
    IFEND;

    process_authority_parameter (pvt [p$change_authority].value, change_authority);
    IF change_authority = NIL THEN
      PUSH change_authority;
      IF avp$system_administrator () THEN
        change_authority^ := avc$system_admin_authority;
      ELSE
        change_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);
    IF manage_authority = NIL THEN
      PUSH manage_authority;
      IF avp$system_administrator () THEN
        manage_authority^ := avc$system_admin_authority;
      ELSE
        manage_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    PUSH delete_authority;
    IF avp$system_administrator () THEN
      delete_authority^ := avc$system_admin_authority;
    ELSE
      delete_authority^ := avc$family_admin_authority;
    IFEND;

    avp$create_accum_limit_field (field_name, current_subutility_session_info^.validation_record_name,
          default_job_warning_limit^, default_job_maximum_limit^, default_total_limit^, limit_name^,
          job_limits_apply^, limit_update_statistics, minimum_job_limit_value^, maximum_job_limit_value^,
          total_limit_applies^, total_limit_stops_login^, change_command_names^, display_command_names^,
          description^, display_authority^, change_authority^, manage_authority^, delete_authority^,
          validation_file_information, status);

  PROCEND create_accumulating_limit_field;
?? OLDTITLE ??
?? NEWTITLE := 'create_capability_field', EJECT ??

{ PURPOSE:
{   This is the command processor used create a CAPABILITY field.

  PROCEDURE create_capability_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_crecf) create_capability_field, crecf (
{   field_name, fn: name = $required
{   default_value, dv: (BY_NAME) key
{       (exclude, e)
{       (include, i)
{     keyend = exclude
{   description, d: (BY_NAME) string 0..256 = ''
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 11] of clt$pdt_parameter_name,
        parameters: array [1 .. 6] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
          default_value: string (7),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
          default_value: string (2),
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type5: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type6: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 39, 35, 797], clc$command, 11, 6, 1, 0, 0, 0, 6, 'OSM$ADMV_CRECF'],
            [['CA                             ', clc$abbreviation_entry, 4],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 4],
            ['D                              ', clc$abbreviation_entry, 3],
            ['DEFAULT_VALUE                  ', clc$nominal_entry, 2],
            ['DESCRIPTION                    ', clc$nominal_entry, 3],
            ['DV                             ', clc$abbreviation_entry, 2],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['MA                             ', clc$abbreviation_entry, 5],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 5],
            ['STATUS                         ', clc$nominal_entry, 6]], [

{ PARAMETER 1

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
            clc$optional_default_parameter, 0, 7],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$optional_default_parameter, 0, 2],

{ PARAMETER 4

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [4], [['E                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['EXCLUDE                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['I                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['INCLUDE                        ', clc$nominal_entry,
            clc$normal_usage_entry, 2]], 'exclude'],

{ PARAMETER 3

      [[1, 0, clc$string_type], [0, 256, FALSE], ''''''],

{ PARAMETER 4

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 5

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 6

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$default_value = 2,
      p$description = 3,
      p$change_authority = 4,
      p$manage_authority = 5,
      p$status = 6;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      default_value: ^boolean,
      delete_authority: ^avt$validation_authority,
      description: ^ost$string,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 1];
    pdt_changes^ [1].number := p$change_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    field_name := pvt [p$field_name].value^.name_value;

    PUSH default_value;
    IF pvt [p$default_value].value^.keyword_value = 'INCLUDE' THEN
      default_value^ := TRUE;
    ELSE
      default_value^ := FALSE;
    IFEND;

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$change_authority].value, change_authority);
    IF change_authority = NIL THEN
      PUSH change_authority;
      IF avp$system_administrator () THEN
        change_authority^ := avc$system_admin_authority;
      ELSE
        change_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);
    IF manage_authority = NIL THEN
      PUSH manage_authority;
      IF avp$system_administrator () THEN
        manage_authority^ := avc$system_admin_authority;
      ELSE
        manage_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    PUSH delete_authority;
    IF avp$system_administrator () THEN
      delete_authority^ := avc$system_admin_authority;
    ELSE
      delete_authority^ := avc$family_admin_authority;
    IFEND;

    avp$create_capability_field (field_name, current_subutility_session_info^.validation_record_name,
          default_value^, description^, avc$user_authority, change_authority^, manage_authority^,
          delete_authority^, validation_file_information, status);

  PROCEND create_capability_field;
?? OLDTITLE ??
?? NEWTITLE := 'create_date_time_field', EJECT ??

{ PURPOSE:
{   This is the command processor used create a DATE_TIME field.

  PROCEDURE create_date_time_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_credtf) create_date_time_field, credtf (
{   field_name, fn: name = $required
{   default_value, dv: range of date_time = $required
{   range, r: (BY_NAME) boolean = false
{   date_time_application, dta: (BY_NAME) key
{       (date_and_time_apply, data)
{       (date_applies, da)
{       (time_applies, ta)
{     keyend = date_and_time_apply
{   date_display_format, ddf: (BY_NAME) key
{       (day_month_year, dmy)
{       (iso_date, iso, isod, id)
{       (month, m)
{       (month_day_year, mdy)
{       (ordinal, o), default
{     keyend = default
{   time_display_format, tdf: (BY_NAME) key
{       (ampm, a)
{       (hour_minute_second, hms)
{       (iso_time, iso, isot, it)
{       (millisecond, ms), default
{     keyend = default
{   description, d: (BY_NAME) string 0..256 = ''
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 25] of clt$pdt_parameter_name,
      parameters: array [1 .. 13] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$range_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$date_time_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (19),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 13] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 11] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (2),
      recend,
      type8: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (7),
      recend,
      type9: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (7),
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 14] of clt$keyword_specification,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 14] of clt$keyword_specification,
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type13: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 6, 3, 12, 33, 31, 390],
    clc$command, 25, 13, 2, 0, 0, 0, 13, 'OSM$ADMV_CREDTF'], [
    ['CA                             ',clc$abbreviation_entry, 10],
    ['CCN                            ',clc$abbreviation_entry, 8],
    ['CHANGE_AUTHORITY               ',clc$nominal_entry, 10],
    ['CHANGE_COMMAND_NAMES           ',clc$nominal_entry, 8],
    ['D                              ',clc$abbreviation_entry, 7],
    ['DA                             ',clc$abbreviation_entry, 11],
    ['DATE_DISPLAY_FORMAT            ',clc$nominal_entry, 5],
    ['DATE_TIME_APPLICATION          ',clc$nominal_entry, 4],
    ['DCN                            ',clc$abbreviation_entry, 9],
    ['DDF                            ',clc$abbreviation_entry, 5],
    ['DEFAULT_VALUE                  ',clc$nominal_entry, 2],
    ['DESCRIPTION                    ',clc$nominal_entry, 7],
    ['DISPLAY_AUTHORITY              ',clc$nominal_entry, 11],
    ['DISPLAY_COMMAND_NAMES          ',clc$nominal_entry, 9],
    ['DTA                            ',clc$abbreviation_entry, 4],
    ['DV                             ',clc$abbreviation_entry, 2],
    ['FIELD_NAME                     ',clc$nominal_entry, 1],
    ['FN                             ',clc$abbreviation_entry, 1],
    ['MA                             ',clc$abbreviation_entry, 12],
    ['MANAGE_AUTHORITY               ',clc$nominal_entry, 12],
    ['R                              ',clc$abbreviation_entry, 3],
    ['RANGE                          ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 13],
    ['TDF                            ',clc$abbreviation_entry, 6],
    ['TIME_DISPLAY_FORMAT            ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 12, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 19],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 488,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 6
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 414,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 7
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 8
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 9
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 10
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
  clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
  clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 13
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$range_type], [5],
      [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [
  clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [6], [
    ['DA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['DATA                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['DATE_AND_TIME_APPLY            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['DATE_APPLIES                   ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['TA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['TIME_APPLIES                   ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ,
    'date_and_time_apply'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [13], [
    ['DAY_MONTH_YEAR                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['DMY                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ID                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['ISO                            ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['ISOD                           ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['ISO_DATE                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['MDY                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['MONTH                          ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['MONTH_DAY_YEAR                 ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['O                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['ORDINAL                        ', clc$nominal_entry, clc$normal_usage_entry, 5]]
    ,
    'default'],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [11], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['AMPM                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['HMS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['HOUR_MINUTE_SECOND             ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['ISO                            ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['ISOT                           ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['ISO_TIME                       ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['IT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['MILLISECOND                    ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['MS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4]]
    ,
    'default'],
{ PARAMETER 7
    [[1, 0, clc$string_type], [0, 256, FALSE],
    ''''''],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'default'],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'default'],
{ PARAMETER 10
    [[1, 0, clc$keyword_type], [14], [
    ['AA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['FA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FAMILY_ADMINISTRATION          ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['PA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['PROJECT_ADMINISTRATION         ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
    ['UA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['USER                           ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['USER_ADMINISTRATION            ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ],
{ PARAMETER 11
    [[1, 0, clc$keyword_type], [14], [
    ['AA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['FA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FAMILY_ADMINISTRATION          ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['PA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['PROJECT_ADMINISTRATION         ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
    ['UA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['USER                           ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['USER_ADMINISTRATION            ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ],
{ PARAMETER 12
    [[1, 0, clc$keyword_type], [4], [
    ['FA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FAMILY_ADMINISTRATION          ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['SA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 13
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$field_name = 1,
    p$default_value = 2,
    p$range = 3,
    p$date_time_application = 4,
    p$date_display_format = 5,
    p$time_display_format = 6,
    p$description = 7,
    p$change_command_names = 8,
    p$display_command_names = 9,
    p$change_authority = 10,
    p$display_authority = 11,
    p$manage_authority = 12,
    p$status = 13;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      date_applies: ^boolean,
      date_display_format: ^clt$date_time_form_string,
      default_value: ^avt$date_time,
      delete_authority: ^avt$validation_authority,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      display_format: ost$string,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      pdt_changes: ^clt$pdt_changes,
      time_applies: ^boolean,
      time_display_format: ^clt$date_time_form_string;

    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    field_name := pvt [p$field_name].value^.name_value;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH date_applies;
    PUSH time_applies;
    IF pvt [p$date_time_application].value^.keyword_value = 'DATE_AND_TIME_APPLY' THEN
      date_applies^ := TRUE;
      time_applies^ := TRUE;
    ELSEIF pvt [p$date_time_application].value^.keyword_value = 'DATE_APPLIES' THEN
      date_applies^ := TRUE;
      time_applies^ := FALSE;
    ELSE
      date_applies^ := FALSE;
      time_applies^ := TRUE;
    IFEND;

    PUSH default_value;
    default_value^.range := pvt [p$range].value^.boolean_value.value;
    default_value^.date_specified := date_applies^;
    default_value^.time_specified := time_applies^;
    IF default_value^.range THEN
      default_value^.starting_value := pvt [p$default_value].value^.low_value^.date_time_value.value;
      default_value^.ending_value := pvt [p$default_value].value^.high_value^.date_time_value.value;
    ELSE
      default_value^.value := pvt [p$default_value].value^.low_value^.date_time_value.value;
    IFEND;

    translate_date_display_format (pvt [p$date_display_format].value^.keyword_value, display_format);
    PUSH date_display_format: [display_format.size];
    date_display_format^ := display_format.value;

    translate_time_display_format (pvt [p$time_display_format].value^.keyword_value, display_format);
    PUSH time_display_format: [display_format.size];
    time_display_format^ := display_format.value;

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);
    IF (display_authority = NIL) THEN
      PUSH display_authority;
      IF current_subutility_session_info^.validation_record_name = avc$user_record_name THEN
        display_authority^ := avc$user_authority;
      ELSEIF (current_subutility_session_info^.validation_record_name = avc$account_record_name) OR
            (current_subutility_session_info^.validation_record_name = avc$account_member_record_name) THEN
        display_authority^ := avc$account_admin_authority;
      ELSE
        display_authority^ := avc$project_admin_authority;
      IFEND;
    IFEND;

    process_authority_parameter (pvt [p$change_authority].value, change_authority);
    IF change_authority = NIL THEN
      PUSH change_authority;
      IF avp$system_administrator () THEN
        change_authority^ := avc$system_admin_authority;
      ELSE
        change_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);
    IF manage_authority = NIL THEN
      PUSH manage_authority;
      IF avp$system_administrator () THEN
        manage_authority^ := avc$system_admin_authority;
      ELSE
        manage_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    PUSH delete_authority;
    IF avp$system_administrator () THEN
      delete_authority^ := avc$system_admin_authority;
    ELSE
      delete_authority^ := avc$family_admin_authority;
    IFEND;

    avp$create_date_time_field (field_name, current_subutility_session_info^.validation_record_name,
          default_value^, default_value^.range, date_applies^, time_applies^, date_display_format^,
          time_display_format^, change_command_names^, display_command_names^, description^,
          display_authority^, change_authority^, manage_authority^, delete_authority^,
          validation_file_information, status);

  PROCEND create_date_time_field;
?? OLDTITLE ??
?? NEWTITLE := 'create_file_field', EJECT ??

{ PURPOSE:
{   This is the command processor used create a FILE field.

  PROCEDURE create_file_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_creff) create_file_field, creff (
{   field_name, fn: name = $required
{   default_value, dv: (BY_NAME) any of
{       key
{         none
{       keyend
{       file
{       string
{     anyend = none
{   description, d: (BY_NAME) string 0..256 = ''
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 17] of clt$pdt_parameter_name,
        parameters: array [1 .. 9] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: 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,
          recend,
          type_size_3: clt$type_specification_size,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
          default_value: string (4),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
          default_value: string (2),
        recend,
        type4: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (7),
        recend,
        type5: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (7),
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type7: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type9: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 40, 10, 458], clc$command, 17, 9, 1, 0, 0, 0, 9, 'OSM$ADMV_CREFF'],
            [['CA                             ', clc$abbreviation_entry, 6],
            ['CCN                            ', clc$abbreviation_entry, 4],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 6],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 4],
            ['D                              ', clc$abbreviation_entry, 3],
            ['DA                             ', clc$abbreviation_entry, 7],
            ['DCN                            ', clc$abbreviation_entry, 5],
            ['DEFAULT_VALUE                  ', clc$nominal_entry, 2],
            ['DESCRIPTION                    ', clc$nominal_entry, 3],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 7],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 5],
            ['DV                             ', clc$abbreviation_entry, 2],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['MA                             ', clc$abbreviation_entry, 8],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 8],
            ['STATUS                         ', clc$nominal_entry, 9]], [

{ PARAMETER 1

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 79,
            clc$optional_default_parameter, 0, 4],

{ PARAMETER 3

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$optional_default_parameter, 0, 2],

{ PARAMETER 4

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 7],

{ PARAMETER 5

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 7],

{ PARAMETER 6

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [16, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [17, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type, clc$string_type], FALSE, 3], 44,
            [[1, 0, clc$keyword_type], [1], [['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 3, [[1, 0, clc$file_type]], 8,
            [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]], 'none'],

{ PARAMETER 3

      [[1, 0, clc$string_type], [0, 256, FALSE], ''''''],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'default'],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'default'],

{ PARAMETER 6

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 7

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 8

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 9

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$default_value = 2,
      p$description = 3,
      p$change_command_names = 4,
      p$display_command_names = 5,
      p$change_authority = 6,
      p$display_authority = 7,
      p$manage_authority = 8,
      p$status = 9;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      default_value: ^fst$file_reference,
      delete_authority: ^avt$validation_authority,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      field_name: ost$name,
      file_reference: ^clt$file_reference,
      manage_authority: ^avt$validation_authority,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    field_name := pvt [p$field_name].value^.name_value;

    process_file_parameter (pvt [p$default_value].value, NIL, default_value);

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);
    IF (display_authority = NIL) THEN
      PUSH display_authority;
      IF current_subutility_session_info^.validation_record_name = avc$user_record_name THEN
        display_authority^ := avc$user_authority;
      ELSEIF (current_subutility_session_info^.validation_record_name = avc$account_record_name) OR
            (current_subutility_session_info^.validation_record_name = avc$account_member_record_name) THEN
        display_authority^ := avc$account_admin_authority;
      ELSE
        display_authority^ := avc$project_admin_authority;
      IFEND;
    IFEND;

    process_authority_parameter (pvt [p$change_authority].value, change_authority);
    IF change_authority = NIL THEN
      PUSH change_authority;
      IF avp$system_administrator () THEN
        change_authority^ := avc$system_admin_authority;
      ELSE
        change_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);
    IF manage_authority = NIL THEN
      PUSH manage_authority;
      IF avp$system_administrator () THEN
        manage_authority^ := avc$system_admin_authority;
      ELSE
        manage_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    PUSH delete_authority;
    IF avp$system_administrator () THEN
      delete_authority^ := avc$system_admin_authority;
    ELSE
      delete_authority^ := avc$family_admin_authority;
    IFEND;

    avp$create_file_field (field_name, current_subutility_session_info^.validation_record_name,
          default_value^, change_command_names^, display_command_names^, description^, display_authority^,
          change_authority^, manage_authority^, delete_authority^, validation_file_information, status);

  PROCEND create_file_field;
?? OLDTITLE ??
?? NEWTITLE := 'create_integer_field', EJECT ??

{ PURPOSE:
{   This is the command processor used create an INTEGER field.

  PROCEDURE create_integer_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_creif) create_integer_field, creif (
{   field_name, fn: name = $required
{   default_value, dv: (BY_NAME) integer = 0
{   display_field_width, dfw: (BY_NAME) integer 1..25 = 20
{   radix, r: (BY_NAME) integer 2..16 = 10
{   display_radix, dr: (BY_NAME) boolean = false
{   value_range, vr: (BY_NAME) range of integer = (0 .. $max_integer)
{   description, d: (BY_NAME) string 0..256 = ''
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 25] of clt$pdt_parameter_name,
        parameters: array [1 .. 13] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (1),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (2),
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (2),
        recend,
        type5: record
          header: clt$type_specification_header,
          default_value: string (5),
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$range_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          default_value: string (19),
        recend,
        type7: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
          default_value: string (2),
        recend,
        type8: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (7),
        recend,
        type9: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (7),
        recend,
        type10: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type11: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type12: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type13: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 40, 27, 679], clc$command, 25, 13, 1, 0, 0, 0, 13, 'OSM$ADMV_CREIF'],
            [['CA                             ', clc$abbreviation_entry, 10],
            ['CCN                            ', clc$abbreviation_entry, 8],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 10],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 8],
            ['D                              ', clc$abbreviation_entry, 7],
            ['DA                             ', clc$abbreviation_entry, 11],
            ['DCN                            ', clc$abbreviation_entry, 9],
            ['DEFAULT_VALUE                  ', clc$nominal_entry, 2],
            ['DESCRIPTION                    ', clc$nominal_entry, 7],
            ['DFW                            ', clc$abbreviation_entry, 3],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 11],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 9],
            ['DISPLAY_FIELD_WIDTH            ', clc$nominal_entry, 3],
            ['DISPLAY_RADIX                  ', clc$nominal_entry, 5],
            ['DR                             ', clc$abbreviation_entry, 5],
            ['DV                             ', clc$abbreviation_entry, 2],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['MA                             ', clc$abbreviation_entry, 12],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 12],
            ['R                              ', clc$abbreviation_entry, 4],
            ['RADIX                          ', clc$nominal_entry, 4],
            ['STATUS                         ', clc$nominal_entry, 13],
            ['VALUE_RANGE                    ', clc$nominal_entry, 6],
            ['VR                             ', clc$abbreviation_entry, 6]], [

{ PARAMETER 1

      [17, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
            clc$optional_default_parameter, 0, 1],

{ PARAMETER 3

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 2],

{ PARAMETER 4

      [22, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 2],

{ PARAMETER 5

      [14, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 5],

{ PARAMETER 6

      [24, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 27, clc$optional_default_parameter, 0, 19],

{ PARAMETER 7

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$optional_default_parameter, 0, 2],

{ PARAMETER 8

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 7],

{ PARAMETER 9

      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 7],

{ PARAMETER 10

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 11

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 12

      [20, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 13

      [23, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10], '0'],

{ PARAMETER 3

      [[1, 0, clc$integer_type], [1, 25, 10], '20'],

{ PARAMETER 4

      [[1, 0, clc$integer_type], [2, 16, 10], '10'],

{ PARAMETER 5

      [[1, 0, clc$boolean_type], 'false'],

{ PARAMETER 6

      [[1, 0, clc$range_type], [20], [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
            '(0 .. $max_integer)'],

{ PARAMETER 7

      [[1, 0, clc$string_type], [0, 256, FALSE], ''''''],

{ PARAMETER 8

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'default'],

{ PARAMETER 9

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'default'],

{ PARAMETER 10

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 11

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 12

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 13

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$default_value = 2,
      p$display_field_width = 3,
      p$radix = 4,
      p$display_radix = 5,
      p$value_range = 6,
      p$description = 7,
      p$change_command_names = 8,
      p$display_command_names = 9,
      p$change_authority = 10,
      p$display_authority = 11,
      p$manage_authority = 12,
      p$status = 13;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      default_value: ^integer,
      delete_authority: ^avt$validation_authority,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      display_format: ^avt$numeric_display_format,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      maximum_value: ^integer,
      minimum_value: ^integer,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    field_name := pvt [p$field_name].value^.name_value;

    default_value := ^pvt [p$default_value].value^.integer_value.value;

    PUSH display_format;
    display_format^.kind := avc$integer_format;
    display_format^.field_size := pvt [p$display_field_width].value^.integer_value.value;
    display_format^.radix := pvt [p$radix].value^.integer_value.value;
    display_format^.display_radix := pvt [p$display_radix].value^.boolean_value.value;

    minimum_value := ^pvt [p$value_range].value^.low_value^.integer_value.value;
    maximum_value := ^pvt [p$value_range].value^.high_value^.integer_value.value;

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);
    IF (display_authority = NIL) THEN
      PUSH display_authority;
      IF current_subutility_session_info^.validation_record_name = avc$user_record_name THEN
        display_authority^ := avc$user_authority;
      ELSEIF (current_subutility_session_info^.validation_record_name = avc$account_record_name) OR
            (current_subutility_session_info^.validation_record_name = avc$account_member_record_name) THEN
        display_authority^ := avc$account_admin_authority;
      ELSE
        display_authority^ := avc$project_admin_authority;
      IFEND;
    IFEND;

    process_authority_parameter (pvt [p$change_authority].value, change_authority);
    IF change_authority = NIL THEN
      PUSH change_authority;
      IF avp$system_administrator () THEN
        change_authority^ := avc$system_admin_authority;
      ELSE
        change_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);
    IF manage_authority = NIL THEN
      PUSH manage_authority;
      IF avp$system_administrator () THEN
        manage_authority^ := avc$system_admin_authority;
      ELSE
        manage_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    PUSH delete_authority;
    IF avp$system_administrator () THEN
      delete_authority^ := avc$system_admin_authority;
    ELSE
      delete_authority^ := avc$family_admin_authority;
    IFEND;

    avp$create_integer_field (field_name, current_subutility_session_info^.validation_record_name,
          default_value^, minimum_value^, maximum_value^, display_format^, change_command_names^,
          display_command_names^, description^, display_authority^, change_authority^, manage_authority^,
          delete_authority^, validation_file_information, status);

  PROCEND create_integer_field;
?? OLDTITLE ??
?? NEWTITLE := 'create_limit_field', EJECT ??

{ PURPOSE:
{   This is the command processor used create a LIMIT field.

  PROCEDURE create_limit_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_crelf) create_limit_field, crelf (
{   field_name, fn: name = $required
{   default_value, dv: (BY_NAME) any of
{       key
{         unlimited
{       keyend
{       integer 0..osc$max_integer
{     anyend = unlimited
{   value_range, vr: (BY_NAME) range of any of
{       key
{         unlimited
{       keyend
{       integer 0..osc$max_integer
{     anyend = (0 .. unlimited)
{   description, d: (BY_NAME) string 0..256 = ''
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 19] of clt$pdt_parameter_name,
        parameters: array [1 .. 10] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: 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$integer_type_qualifier,
          recend,
          default_value: string (9),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$range_type_qualifier,
          element_type_spec: 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$integer_type_qualifier,
            recend,
          recend,
          default_value: string (16),
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
          default_value: string (2),
        recend,
        type5: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (7),
        recend,
        type6: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (7),
        recend,
        type7: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type9: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type10: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 40, 40, 981], clc$command, 19, 10, 1, 0, 0, 0, 10, 'OSM$ADMV_CRELF'],
            [['CA                             ', clc$abbreviation_entry, 7],
            ['CCN                            ', clc$abbreviation_entry, 5],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 7],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 5],
            ['D                              ', clc$abbreviation_entry, 4],
            ['DA                             ', clc$abbreviation_entry, 8],
            ['DCN                            ', clc$abbreviation_entry, 6],
            ['DEFAULT_VALUE                  ', clc$nominal_entry, 2],
            ['DESCRIPTION                    ', clc$nominal_entry, 4],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 8],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 6],
            ['DV                             ', clc$abbreviation_entry, 2],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['MA                             ', clc$abbreviation_entry, 9],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 9],
            ['STATUS                         ', clc$nominal_entry, 10],
            ['VALUE_RANGE                    ', clc$nominal_entry, 3],
            ['VR                             ', clc$abbreviation_entry, 3]], [

{ PARAMETER 1

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
            clc$optional_default_parameter, 0, 9],

{ PARAMETER 3

      [18, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 91, clc$optional_default_parameter, 0, 16],

{ PARAMETER 4

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$optional_default_parameter, 0, 2],

{ PARAMETER 5

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 7],

{ PARAMETER 6

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 7],

{ PARAMETER 7

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [16, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 10

      [17, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type], [0, osc$max_integer, 10]],
            'unlimited'],

{ PARAMETER 3

      [[1, 0, clc$range_type], [84], [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 44, [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type], [0, osc$max_integer, 10]]],
            '(0 .. unlimited)'],

{ PARAMETER 4

      [[1, 0, clc$string_type], [0, 256, FALSE], ''''''],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'default'],

{ PARAMETER 6

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'default'],

{ PARAMETER 7

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 8

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 9

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 10

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$default_value = 2,
      p$value_range = 3,
      p$description = 4,
      p$change_command_names = 5,
      p$display_command_names = 6,
      p$change_authority = 7,
      p$display_authority = 8,
      p$manage_authority = 9,
      p$status = 10;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      default_value: ^avt$limit_value,
      delete_authority: ^avt$validation_authority,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      maximum_value: ^avt$limit_value,
      minimum_value: ^avt$limit_value,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    field_name := pvt [p$field_name].value^.name_value;

    process_limit_parameter (pvt [p$default_value].value, NIL, default_value);

    process_limit_range_parameter (pvt [p$value_range].value, minimum_value, maximum_value);

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);
    IF (display_authority = NIL) THEN
      PUSH display_authority;
      IF current_subutility_session_info^.validation_record_name = avc$user_record_name THEN
        display_authority^ := avc$user_authority;
      ELSEIF (current_subutility_session_info^.validation_record_name = avc$account_record_name) OR
            (current_subutility_session_info^.validation_record_name = avc$account_member_record_name) THEN
        display_authority^ := avc$account_admin_authority;
      ELSE
        display_authority^ := avc$project_admin_authority;
      IFEND;
    IFEND;

    process_authority_parameter (pvt [p$change_authority].value, change_authority);
    IF change_authority = NIL THEN
      PUSH change_authority;
      IF avp$system_administrator () THEN
        change_authority^ := avc$system_admin_authority;
      ELSE
        change_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);
    IF manage_authority = NIL THEN
      PUSH manage_authority;
      IF avp$system_administrator () THEN
        manage_authority^ := avc$system_admin_authority;
      ELSE
        manage_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    PUSH delete_authority;
    IF avp$system_administrator () THEN
      delete_authority^ := avc$system_admin_authority;
    ELSE
      delete_authority^ := avc$family_admin_authority;
    IFEND;

    avp$create_limit_field (field_name, current_subutility_session_info^.validation_record_name,
          default_value^, minimum_value^, maximum_value^, change_command_names^, display_command_names^,
          description^, display_authority^, change_authority^, manage_authority^, delete_authority^,
          validation_file_information, status);

  PROCEND create_limit_field;
?? OLDTITLE ??
?? NEWTITLE := 'create_name_field', EJECT ??

{ PURPOSE:
{   This is the command processor used create a NAME field.

  PROCEDURE create_name_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_crenf) create_name_field, crenf (
{   field_name, fn: name = $required
{   default_value, dv: (BY_NAME, CHECK) any of
{       key
{         all, none
{       keyend
{       list 1..256 of name
{     anyend = none
{   number_of_names, non: (BY_NAME) range of integer 1..256 = (1 .. 1)
{   description, d: (BY_NAME) string 0..256 = ''
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 19] of clt$pdt_parameter_name,
        parameters: array [1 .. 10] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: 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 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (4),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$range_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          default_value: string (8),
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
          default_value: string (2),
        recend,
        type5: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (7),
        recend,
        type6: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (7),
        recend,
        type7: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type9: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type10: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 40, 54, 470], clc$command, 19, 10, 1, 0, 0, 0, 10, 'OSM$ADMV_CRENF'],
            [['CA                             ', clc$abbreviation_entry, 7],
            ['CCN                            ', clc$abbreviation_entry, 5],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 7],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 5],
            ['D                              ', clc$abbreviation_entry, 4],
            ['DA                             ', clc$abbreviation_entry, 8],
            ['DCN                            ', clc$abbreviation_entry, 6],
            ['DEFAULT_VALUE                  ', clc$nominal_entry, 2],
            ['DESCRIPTION                    ', clc$nominal_entry, 4],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 8],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 6],
            ['DV                             ', clc$abbreviation_entry, 2],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['MA                             ', clc$abbreviation_entry, 9],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 9],
            ['NON                            ', clc$abbreviation_entry, 3],
            ['NUMBER_OF_NAMES                ', clc$nominal_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 10]], [

{ PARAMETER 1

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 122,
            clc$optional_default_parameter, 0, 4],

{ PARAMETER 3

      [18, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 27, clc$optional_default_parameter, 0, 8],

{ PARAMETER 4

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$optional_default_parameter, 0, 2],

{ PARAMETER 5

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 7],

{ PARAMETER 6

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 7],

{ PARAMETER 7

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [16, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 10

      [19, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 21, [[1, 0, clc$list_type],
            [5, 1, 256, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'none'],

{ PARAMETER 3

      [[1, 0, clc$range_type], [20], [[1, 0, clc$integer_type], [1, 256, 10]], '(1 .. 1)'],

{ PARAMETER 4

      [[1, 0, clc$string_type], [0, 256, FALSE], ''''''],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'default'],

{ PARAMETER 6

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'default'],

{ PARAMETER 7

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 8

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 9

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 10

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$default_value = 2,
      p$number_of_names = 3,
      p$description = 4,
      p$change_command_names = 5,
      p$display_command_names = 6,
      p$change_authority = 7,
      p$display_authority = 8,
      p$manage_authority = 9,
      p$status = 10;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      common_names: ^avt$name_list,
      default_names: ^avt$name_list,
      delete_authority: ^avt$validation_authority,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      minimum_number_of_names: ^avt$name_list_size,
      maximum_number_of_names: ^avt$name_list_size,
      pdt_changes: ^clt$pdt_changes;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF (which_parameter.specific) AND (which_parameter.number = p$default_value) THEN
        verify_list_of_names_value ('DEFAULT_VALUE', parameter_value_table^ [p$default_value].value, status);
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, altered_pdt, ^check_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    field_name := pvt [p$field_name].value^.name_value;

    process_name_list_parameter (pvt [p$default_value].value, NIL, default_names);

    PUSH common_names: [1 .. 1];
    common_names^ [1] := 'NONE';

    PUSH minimum_number_of_names;
    minimum_number_of_names^ := pvt [p$number_of_names].value^.low_value^.integer_value.value;
    PUSH maximum_number_of_names;
    maximum_number_of_names^ := pvt [p$number_of_names].value^.high_value^.integer_value.value;

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);
    IF (display_authority = NIL) THEN
      PUSH display_authority;
      IF current_subutility_session_info^.validation_record_name = avc$user_record_name THEN
        display_authority^ := avc$user_authority;
      ELSEIF (current_subutility_session_info^.validation_record_name = avc$account_record_name) OR
            (current_subutility_session_info^.validation_record_name = avc$account_member_record_name) THEN
        display_authority^ := avc$account_admin_authority;
      ELSE
        display_authority^ := avc$project_admin_authority;
      IFEND;
    IFEND;

    process_authority_parameter (pvt [p$change_authority].value, change_authority);
    IF change_authority = NIL THEN
      PUSH change_authority;
      IF avp$system_administrator () THEN
        change_authority^ := avc$system_admin_authority;
      ELSE
        change_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);
    IF manage_authority = NIL THEN
      PUSH manage_authority;
      IF avp$system_administrator () THEN
        manage_authority^ := avc$system_admin_authority;
      ELSE
        manage_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    PUSH delete_authority;
    IF avp$system_administrator () THEN
      delete_authority^ := avc$system_admin_authority;
    ELSE
      delete_authority^ := avc$family_admin_authority;
    IFEND;

    avp$create_name_field (field_name, current_subutility_session_info^.validation_record_name,
          default_names^, minimum_number_of_names^, maximum_number_of_names^, common_names^,
          change_command_names^, display_command_names^, description^, display_authority^, change_authority^,
          manage_authority^, delete_authority^, validation_file_information, status);

  PROCEND create_name_field;
?? OLDTITLE ??
?? NEWTITLE := 'create_real_field', EJECT ??

{ PURPOSE:
{   This is the command processor used create a REAL field.

  PROCEDURE create_real_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_crerf) create_real_field, crerf (
{   field_name, fn: name = $required
{   default_value, dv: (BY_NAME) real = 0.0
{   display_field_width, dfw: (BY_NAME) list 1..2 of integer 1..25 = (16, 2)
{   value_range, vr: (BY_NAME) range of real = (0.0 .. 100000000000.0)
{   description, d: (BY_NAME) string 0..256 = ''
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 21] of clt$pdt_parameter_name,
        parameters: array [1 .. 11] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$real_type_qualifier,
          default_value: string (3),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          default_value: string (7),
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$range_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$real_type_qualifier,
          recend,
          default_value: string (23),
        recend,
        type5: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
          default_value: string (2),
        recend,
        type6: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (7),
        recend,
        type7: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (7),
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type9: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type10: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type11: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 41, 39, 368], clc$command, 21, 11, 1, 0, 0, 0, 11, 'OSM$ADMV_CRERF'],
            [['CA                             ', clc$abbreviation_entry, 8],
            ['CCN                            ', clc$abbreviation_entry, 6],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 8],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 6],
            ['D                              ', clc$abbreviation_entry, 5],
            ['DA                             ', clc$abbreviation_entry, 9],
            ['DCN                            ', clc$abbreviation_entry, 7],
            ['DEFAULT_VALUE                  ', clc$nominal_entry, 2],
            ['DESCRIPTION                    ', clc$nominal_entry, 5],
            ['DFW                            ', clc$abbreviation_entry, 3],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 9],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 7],
            ['DISPLAY_FIELD_WIDTH            ', clc$nominal_entry, 3],
            ['DV                             ', clc$abbreviation_entry, 2],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['MA                             ', clc$abbreviation_entry, 10],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 10],
            ['STATUS                         ', clc$nominal_entry, 11],
            ['VALUE_RANGE                    ', clc$nominal_entry, 4],
            ['VR                             ', clc$abbreviation_entry, 4]], [

{ PARAMETER 1

      [15, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 35,
            clc$optional_default_parameter, 0, 3],

{ PARAMETER 3

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 36, clc$optional_default_parameter, 0, 7],

{ PARAMETER 4

      [20, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 42, clc$optional_default_parameter, 0, 23],

{ PARAMETER 5

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$optional_default_parameter, 0, 2],

{ PARAMETER 6

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 7],

{ PARAMETER 7

      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 7],

{ PARAMETER 8

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 10

      [18, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 11

      [19, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$real_type], [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
            [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]], '0.0'],

{ PARAMETER 3

      [[1, 0, clc$list_type], [20, 1, 2, FALSE], [[1, 0, clc$integer_type], [1, 25, 10]], '(16, 2)'],

{ PARAMETER 4

      [[1, 0, clc$range_type], [35], [[1, 0, clc$real_type], [[{-$INFINITY} 3,
            [[0D000(16), 0(16)], [0D000(16), 0(16)]]], [{$INFINITY} 3, [[5000(16), 0(16)],
            [5000(16), 0(16)]]]]], '(0.0 .. 100000000000.0)'],

{ PARAMETER 5

      [[1, 0, clc$string_type], [0, 256, FALSE], ''''''],

{ PARAMETER 6

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'default'],

{ PARAMETER 7

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'default'],

{ PARAMETER 8

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 9

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 10

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 11

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$default_value = 2,
      p$display_field_width = 3,
      p$value_range = 4,
      p$description = 5,
      p$change_command_names = 6,
      p$display_command_names = 7,
      p$change_authority = 8,
      p$display_authority = 9,
      p$manage_authority = 10,
      p$status = 11;

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

    TYPE
      long_real_type = record
        first: real,
        second: real,
      recend;

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      default_value: ^real,
      delete_authority: ^avt$validation_authority,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      display_format: ^avt$numeric_display_format,
      field_name: ost$name,
      long_real_value: long_real_type,
      manage_authority: ^avt$validation_authority,
      maximum_value: ^real,
      minimum_value: ^real,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    field_name := pvt [p$field_name].value^.name_value;

    #UNCHECKED_CONVERSION (pvt [p$default_value].value^.real_value.value, long_real_value);
    PUSH default_value;
    default_value^ := long_real_value.first;

    PUSH display_format;
    IF clp$count_list_elements (pvt [p$display_field_width].value) = 1 THEN
      display_format^.kind := avc$floating_point_format;
      display_format^.field_size := pvt [p$display_field_width].value^.element_value^.integer_value.value;
    ELSE
      display_format^.kind := avc$fixed_point_format;
      display_format^.field_size := pvt [p$display_field_width].value^.element_value^.integer_value.value;
      display_format^.fraction_size := pvt [p$display_field_width].value^.link^.element_value^.integer_value.
            value;
    IFEND;

    #UNCHECKED_CONVERSION (pvt [p$value_range].value^.low_value^.real_value.value, long_real_value);
    PUSH minimum_value;
    minimum_value^ := long_real_value.first;
    #UNCHECKED_CONVERSION (pvt [p$value_range].value^.high_value^.real_value.value, long_real_value);
    PUSH maximum_value;
    maximum_value^ := long_real_value.first;

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);
    IF (display_authority = NIL) THEN
      PUSH display_authority;
      IF current_subutility_session_info^.validation_record_name = avc$user_record_name THEN
        display_authority^ := avc$user_authority;
      ELSEIF (current_subutility_session_info^.validation_record_name = avc$account_record_name) OR
            (current_subutility_session_info^.validation_record_name = avc$account_member_record_name) THEN
        display_authority^ := avc$account_admin_authority;
      ELSE
        display_authority^ := avc$project_admin_authority;
      IFEND;
    IFEND;

    process_authority_parameter (pvt [p$change_authority].value, change_authority);
    IF change_authority = NIL THEN
      PUSH change_authority;
      IF avp$system_administrator () THEN
        change_authority^ := avc$system_admin_authority;
      ELSE
        change_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);
    IF manage_authority = NIL THEN
      PUSH manage_authority;
      IF avp$system_administrator () THEN
        manage_authority^ := avc$system_admin_authority;
      ELSE
        manage_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    PUSH delete_authority;
    IF avp$system_administrator () THEN
      delete_authority^ := avc$system_admin_authority;
    ELSE
      delete_authority^ := avc$family_admin_authority;
    IFEND;

    avp$create_real_field (field_name, current_subutility_session_info^.validation_record_name,
          default_value^, minimum_value^, maximum_value^, display_format^, change_command_names^,
          display_command_names^, description^, display_authority^, change_authority^, manage_authority^,
          delete_authority^, validation_file_information, status);

  PROCEND create_real_field;
?? OLDTITLE ??
?? NEWTITLE := 'create_string_field', EJECT ??

{ PURPOSE:
{   This is the command processor used create a STRING field.

  PROCEDURE create_string_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_cresf) create_string_field, cresf (
{   field_name, fn: name = $required
{   default_value, dv: (BY_NAME) string 0..256 = ''
{   size, s: (BY_NAME) range of integer 0..256 = (0 .. 256)
{   description, d: (BY_NAME) string 0..256 = ''
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   change_authority, ca: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   display_authority, da: (BY_NAME) key
{       (system, s)
{       (system_administration, sa)
{       (family_administration, fa)
{       (user_administration, ua)
{       (account_administration, aa)
{       (project_administration, pa)
{       (user, u)
{     keyend = $optional
{   manage_authority, ma: (BY_NAME) key
{       (system_administration, sa)
{       (family_administration, fa)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 19] of clt$pdt_parameter_name,
        parameters: array [1 .. 10] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
          default_value: string (2),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$range_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          default_value: string (10),
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
          default_value: string (2),
        recend,
        type5: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (7),
        recend,
        type6: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (7),
        recend,
        type7: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        type9: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        type10: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 42, 2, 442], clc$command, 19, 10, 1, 0, 0, 0, 10, 'OSM$ADMV_CRESF'],
            [['CA                             ', clc$abbreviation_entry, 7],
            ['CCN                            ', clc$abbreviation_entry, 5],
            ['CHANGE_AUTHORITY               ', clc$nominal_entry, 7],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 5],
            ['D                              ', clc$abbreviation_entry, 4],
            ['DA                             ', clc$abbreviation_entry, 8],
            ['DCN                            ', clc$abbreviation_entry, 6],
            ['DEFAULT_VALUE                  ', clc$nominal_entry, 2],
            ['DESCRIPTION                    ', clc$nominal_entry, 4],
            ['DISPLAY_AUTHORITY              ', clc$nominal_entry, 8],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 6],
            ['DV                             ', clc$abbreviation_entry, 2],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['MA                             ', clc$abbreviation_entry, 9],
            ['MANAGE_AUTHORITY               ', clc$nominal_entry, 9],
            ['S                              ', clc$abbreviation_entry, 3],
            ['SIZE                           ', clc$nominal_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 10]], [

{ PARAMETER 1

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$optional_default_parameter, 0, 2],

{ PARAMETER 3

      [18, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 27, clc$optional_default_parameter, 0, 10],

{ PARAMETER 4

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$optional_default_parameter, 0, 2],

{ PARAMETER 5

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 7],

{ PARAMETER 6

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 7],

{ PARAMETER 7

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
            clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 525, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [16, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],

{ PARAMETER 10

      [19, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$string_type], [0, 256, FALSE], ''''''],

{ PARAMETER 3

      [[1, 0, clc$range_type], [20], [[1, 0, clc$integer_type], [0, 256, 10]], '(0 .. 256)'],

{ PARAMETER 4

      [[1, 0, clc$string_type], [0, 256, FALSE], ''''''],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'default'],

{ PARAMETER 6

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'default'],

{ PARAMETER 7

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 8

      [[1, 0, clc$keyword_type], [14], [['AA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ACCOUNT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['PA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['PROJECT_ADMINISTRATION         ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SYSTEM                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['UA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['USER_ADMINISTRATION            ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],

{ PARAMETER 9

      [[1, 0, clc$keyword_type], [4], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 10

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$default_value = 2,
      p$size = 3,
      p$description = 4,
      p$change_command_names = 5,
      p$display_command_names = 6,
      p$change_authority = 7,
      p$display_authority = 8,
      p$manage_authority = 9,
      p$status = 10;

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

    VAR
      altered_pdt: ^clt$parameter_description_table,
      change_authority: ^avt$validation_authority,
      change_command_names: ^avt$name_list,
      default_value: ^ost$string,
      delete_authority: ^avt$validation_authority,
      description: ^ost$string,
      display_authority: ^avt$validation_authority,
      display_command_names: ^avt$name_list,
      field_name: ost$name,
      manage_authority: ^avt$validation_authority,
      maximum_size: ost$string_size,
      minimum_size: ost$string_size,
      pdt_changes: ^clt$pdt_changes;

    status.normal := TRUE;

    PUSH pdt_changes: [1 .. 2];
    pdt_changes^ [1].number := p$change_authority;
    pdt_changes^ [2].number := p$display_authority;

    hide_authority_keywords (#SEQ (pdt), pdt_changes, current_subutility_session_info^.validation_record_name,
          altered_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

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

    field_name := pvt [p$field_name].value^.name_value;

    PUSH default_value;
    default_value^.value := pvt [p$default_value].value^.string_value^;
    default_value^.size := #SIZE (pvt [p$default_value].value^.string_value^);

    minimum_size := pvt [p$size].value^.low_value^.integer_value.value;
    maximum_size := pvt [p$size].value^.high_value^.integer_value.value;

    process_command_names_parameter (pvt [p$change_command_names].value, field_name, 'CHANGE',
          change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, field_name, 'DISPLAY',
          display_command_names);

    process_description_parameter (pvt [p$description].value, description);

    process_authority_parameter (pvt [p$display_authority].value, display_authority);
    IF (display_authority = NIL) THEN
      PUSH display_authority;
      IF current_subutility_session_info^.validation_record_name = avc$user_record_name THEN
        display_authority^ := avc$user_authority;
      ELSEIF (current_subutility_session_info^.validation_record_name = avc$account_record_name) OR
            (current_subutility_session_info^.validation_record_name = avc$account_member_record_name) THEN
        display_authority^ := avc$account_admin_authority;
      ELSE
        display_authority^ := avc$project_admin_authority;
      IFEND;
    IFEND;

    process_authority_parameter (pvt [p$change_authority].value, change_authority);
    IF change_authority = NIL THEN
      PUSH change_authority;
      IF avp$system_administrator () THEN
        change_authority^ := avc$system_admin_authority;
      ELSE
        change_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    process_authority_parameter (pvt [p$manage_authority].value, manage_authority);
    IF manage_authority = NIL THEN
      PUSH manage_authority;
      IF avp$system_administrator () THEN
        manage_authority^ := avc$system_admin_authority;
      ELSE
        manage_authority^ := avc$family_admin_authority;
      IFEND;
    IFEND;

    PUSH delete_authority;
    IF avp$system_administrator () THEN
      delete_authority^ := avc$system_admin_authority;
    ELSE
      delete_authority^ := avc$family_admin_authority;
    IFEND;

    avp$create_string_field (field_name, current_subutility_session_info^.validation_record_name,
          default_value^, minimum_size, maximum_size, change_command_names^, display_command_names^,
          description^, display_authority^, change_authority^, manage_authority^, delete_authority^,
          validation_file_information, status);

  PROCEND create_string_field;
?? OLDTITLE ??
?? NEWTITLE := 'change_field_name', EJECT ??

{ PURPOSE:
{   This is the command processor for the CHANGE_FIELD_NAME subcommand

  PROCEDURE change_field_name
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_chafn) change_field_name, chafn (
{   field_name, fn: name = $required
{   new_field_name, nfn: name = $required
{   change_command_names, ccn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   display_command_names, dcn: (BY_NAME) any of
{       key
{         default
{       keyend
{       list of name
{     anyend = default
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 9] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type3: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (7),
        recend,
        type4: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (7),
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 11, 43, 0, 336], clc$command, 9, 5, 2, 0, 0, 0, 5, 'OSM$ADMV_CHAFN'],
            [['CCN                            ', clc$abbreviation_entry, 3],
            ['CHANGE_COMMAND_NAMES           ', clc$nominal_entry, 3],
            ['DCN                            ', clc$abbreviation_entry, 4],
            ['DISPLAY_COMMAND_NAMES          ', clc$nominal_entry, 4],
            ['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['NEW_FIELD_NAME                 ', clc$nominal_entry, 2],
            ['NFN                            ', clc$abbreviation_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 5]], [

{ PARAMETER 1

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 3

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 7],

{ PARAMETER 4

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 7],

{ PARAMETER 5

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'default'],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'default'],

{ PARAMETER 5

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$new_field_name = 2,
      p$change_command_names = 3,
      p$display_command_names = 4,
      p$status = 5;

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

    VAR
      change_command_names: ^avt$name_list,
      display_command_names: ^avt$name_list,
      ignore_status: ost$status;

    status.normal := TRUE;

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

    process_command_names_parameter (pvt [p$change_command_names].value, pvt [p$new_field_name].
          value^.name_value, 'CHANGE', change_command_names);

    process_command_names_parameter (pvt [p$display_command_names].value, pvt [p$new_field_name].
          value^.name_value, 'DISPLAY', display_command_names);

{ Change the name of the field.

    avp$change_val_field_name (pvt [p$field_name].value^.name_value,
          current_subutility_session_info^.validation_record_name, pvt [p$new_field_name].value^.name_value,
          change_command_names, display_command_names, validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND change_field_name;
?? OLDTITLE ??
?? NEWTITLE := 'delete_field', EJECT ??

{ PURPOSE:
{   This is the command processor for the DELETE_FIELD subcommand.

  PROCEDURE delete_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_delf) delete_field, delf (
{   field_name, fn: name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 16, 0, 7, 14, 3], clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$ADMV_DELF'],
            [['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 2]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$status = 2;

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

    status.normal := TRUE;

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

    avp$delete_validation_field (pvt [p$field_name].value^.name_value,
          current_subutility_session_info^.validation_record_name, validation_file_information, status);

  PROCEND delete_field;
?? OLDTITLE ??
?? NEWTITLE := 'avp$display_field_description', EJECT ??

{ PURPOSE:
{   This is the command processor for the DISPLAY_FIELD_DESCRIPTION subcommand.

  PROCEDURE [XDCL] avp$display_field_description
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_disfd) display_field_description, disfd (
{   field_name, field_names, fn: (CHECK) any of
{       key
{         all
{       keyend
{       list 1..clc$max_list_size of name
{     anyend = all
{   output, o: file = $output
{   display_option, display_options, do: (BY_NAME) list of key
{       (type, k, kind, t)
{       (default_value, dv)
{       (description, d)
{       (change_authority, ca)
{       (display_authority, da)
{       (manage_authority, ma)
{       delete_authority, all, none
{     keyend = (type, default_value, description)
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 17] of clt$keyword_specification,
        recend,
        default_value: string (34),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 29, 11, 0, 51, 152],
    clc$command, 9, 4, 0, 0, 0, 0, 4, 'OSM$ADMV_DISFD'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 3],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 3],
    ['DO                             ',clc$abbreviation_entry, 3],
    ['FIELD_NAME                     ',clc$nominal_entry, 1],
    ['FIELD_NAMES                    ',clc$alias_entry, 1],
    ['FN                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 85,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 652,
  clc$optional_default_parameter, 0, 34],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$list_type], [636, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [17], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['CA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['CHANGE_AUTHORITY               ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['DA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['DEFAULT_VALUE                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['DELETE_AUTHORITY               ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['DESCRIPTION                    ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['DISPLAY_AUTHORITY              ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['DV                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['K                              ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['KIND                           ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['MA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['MANAGE_AUTHORITY               ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['TYPE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    '(type, default_value, description)'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$field_name = 1,
    p$output = 2,
    p$display_option = 3,
    p$status = 4;

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

    TYPE
      avt$display_option = (avc$field_kind, avc$default_value, avc$description, avc$change_authority,
            avc$display_authority, avc$manage_authority, avc$delete_authority);

    TYPE
      avt$display_option_set = set of avt$display_option;

    VAR
      current_parameter_value: ^clt$data_value,
      display_control: clt$display_control,
      display_options: avt$display_option_set,
      field_name_count: 0 .. avc$maximum_field_count,
      field_name_list: ^array [1 .. * ] of ost$name,
      field_name_work_area: ^SEQ ( * ),
      file_contents: amt$file_contents,
      ignore_status: ost$status,
      index: avt$name_list_size,
      ring_attributes: amt$ring_attributes;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF (which_parameter.specific) AND (which_parameter.number = p$field_name) THEN
        verify_field_names_value ('FIELD_NAME', parameter_value_table^ [p$field_name].value,
              current_subutility_session_info^.validation_record_name, -$avt$field_kind_set [], status);
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   This block exit condition handler is used to insure that the output file
{   is closed if an error occurs.

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

      VAR
        ignore_status: ost$status;

{ This condition handler is used to close the display file in case of an abnormal termination.

      clp$close_display (display_control, ignore_status);

    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'display_field', EJECT ??

{ PURPOSE:
{   This procedure is used to display the field description for a specified
{   field name.

    PROCEDURE display_field
      (    field_name: ost$name;
           validation_record_name: ost$name;
           display_options: avt$display_option_set;
       VAR display_control: clt$display_control;
       VAR validation_file_information: avt$template_file_information;
       VAR status: ost$status);

      VAR
        field_kind: avt$field_kind;

?? NEWTITLE := 'display_account_project_field', EJECT ??

      PROCEDURE display_field_kind
        (    field_kind: avt$field_kind;
         VAR display_control: clt$display_control;
         VAR status: ost$status);

        status.normal := TRUE;

        clp$put_partial_display (display_control, '    Field type: ', clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, avv$field_kind_names [field_kind], clc$trim, amc$terminate,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      PROCEND display_field_kind;
?? OLDTITLE ??
?? NEWTITLE := 'display_account_project_field', EJECT ??

      PROCEDURE display_account_project_field
        (    field_name: ost$name;
             validation_record_name: ost$name;
             display_options: avt$display_option_set;
         VAR display_control: clt$display_control;
         VAR validation_file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          change_authority: avt$validation_authority,
          default_account: avt$account_name,
          default_project: avt$project_name,
          description: ost$string,
          delete_authority: avt$validation_authority,
          display_authority: avt$validation_authority,
          manage_authority: avt$validation_authority;

        status.normal := TRUE;

        avp$get_acct_proj_field_desc (field_name, validation_record_name, osc$null_name, default_account,
              default_project, description, change_authority, delete_authority, display_authority,
              manage_authority, validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF avc$field_kind IN display_options THEN
          display_field_kind (avc$account_project_kind, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$default_value IN display_options THEN
          clp$put_partial_display (display_control, '    Default account: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, default_account, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, '    Default project: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, default_project, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$description IN display_options THEN
          clp$put_partial_display (display_control, '    Description: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, description.value, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$change_authority IN display_options THEN
          display_authority_value ('    Change authority:  ', change_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$display_authority IN display_options THEN
          display_authority_value ('    Display authority: ', display_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$manage_authority IN display_options THEN
          display_authority_value ('    Manage authority:  ', manage_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$delete_authority IN display_options THEN
          display_authority_value ('    Delete authority:  ', delete_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      PROCEND display_account_project_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_accum_limit_field', EJECT ??

      PROCEDURE display_accum_limit_field
        (    field_name: ost$name;
             validation_record_name: ost$name;
             display_options: avt$display_option_set;
         VAR display_control: clt$display_control;
         VAR validation_file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          total_limit_applies: boolean,
          total_limit_stops_login: boolean,
          change_authority: avt$validation_authority,
          default_job_maximum_limit: avt$limit_value,
          default_job_warning_limit: avt$limit_value,
          default_total_limit: avt$limit_value,
          default_total_accumulation: avt$limit_value,
          description: ost$string,
          delete_authority: avt$validation_authority,
          display_authority: avt$validation_authority,
          job_limits_apply: boolean,
          limit_name: ost$name,
          manage_authority: avt$validation_authority,
          maximum_job_limit_value: avt$limit_value,
          minimum_job_limit_value: avt$limit_value,
          number_of_update_statistics: avt$name_list_size,
          statistic_name: ost$name,
          update_statistics: ^sft$limit_update_statistics,
          update_statistics_count: integer;

        status.normal := TRUE;

        PUSH update_statistics: [1 .. avc$maximum_name_list_size];

        avp$get_accum_limit_field_desc (field_name, validation_record_name, osc$null_name,
              default_job_warning_limit, default_job_maximum_limit, default_total_limit,
              default_total_accumulation, limit_name, job_limits_apply, minimum_job_limit_value,
              maximum_job_limit_value, number_of_update_statistics, update_statistics, total_limit_applies,
              total_limit_stops_login, description, change_authority, delete_authority, display_authority,
              manage_authority, validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF avc$field_kind IN display_options THEN
          display_field_kind (avc$accumulating_limit_kind, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF job_limits_apply AND total_limit_applies THEN
            clp$put_display (display_control, '      Job and total limits apply.', clc$trim, status);
          ELSEIF job_limits_apply THEN
            clp$put_display (display_control, '      Job limits apply.', clc$trim, status);
          ELSE
            clp$put_display (display_control, '      Total limits apply.', clc$trim, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF job_limits_apply THEN
            clp$put_partial_display (display_control, '      Limit name: ', clc$no_trim, amc$start, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            clp$put_partial_display (display_control, limit_name, clc$trim, amc$terminate, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            display_limit_value ('      Minimum job limit value: ', minimum_job_limit_value, display_control,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            display_limit_value ('      Maximum job limit value: ', maximum_job_limit_value, display_control,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, '      Limit update statistics: ', clc$no_trim,
                  amc$start, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF number_of_update_statistics = 0 THEN
              clp$put_partial_display (display_control, ' ', clc$no_trim, amc$terminate, status);
            ELSE
              FOR update_statistics_count := 1 TO number_of_update_statistics DO
                sfp$convert_stat_code_to_name (update_statistics^ [update_statistics_count].statistic_code,
                      statistic_name, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                clp$put_partial_display (display_control, statistic_name, clc$trim, amc$terminate, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                IF update_statistics_count <> number_of_update_statistics THEN
                  clp$put_partial_display (display_control, '                               ', clc$no_trim,
                        amc$start, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;
                IFEND;
              FOREND;
            IFEND;
          IFEND;

          IF total_limit_applies THEN
            IF total_limit_stops_login THEN
              clp$put_display (display_control, '      Total limit prevents login.', clc$trim, status);
            ELSE
              clp$put_display (display_control, '      Total limit does not prevent login.', clc$trim,
                    status);
            IFEND;
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;

        IF avc$default_value IN display_options THEN
          IF job_limits_apply THEN
            display_limit_value ('    Default job warning limit:   ', default_job_warning_limit,
                  display_control, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            display_limit_value ('    Default job maximum limit:   ', default_job_maximum_limit,
                  display_control, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

          IF total_limit_applies THEN
            display_limit_value ('    Default total limit:         ', default_total_limit, display_control,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;

        IF avc$description IN display_options THEN
          clp$put_partial_display (display_control, '    Description: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, description.value, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$change_authority IN display_options THEN
          display_authority_value ('    Change authority:  ', change_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$display_authority IN display_options THEN
          display_authority_value ('    Display authority: ', display_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$manage_authority IN display_options THEN
          display_authority_value ('    Manage authority:  ', manage_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$delete_authority IN display_options THEN
          display_authority_value ('    Delete authority:  ', delete_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      PROCEND display_accum_limit_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_authority_value', EJECT ??

      PROCEDURE display_authority_value
        (    title: string ( * <= osc$max_string_size);
             authority: avt$validation_authority;
         VAR display_control: clt$display_control;
         VAR status: ost$status);

        status.normal := TRUE;

        clp$put_partial_display (display_control, title, clc$no_trim, amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        CASE authority OF
        = avc$system_authority =
          clp$put_partial_display (display_control, 'System', clc$trim, amc$terminate, status);
        = avc$system_admin_authority =
          clp$put_partial_display (display_control, 'System administration', clc$trim, amc$terminate, status);
        = avc$family_admin_authority =
          clp$put_partial_display (display_control, 'Family administration', clc$trim, amc$terminate, status);
        = avc$user_admin_authority =
          clp$put_partial_display (display_control, 'User administration', clc$trim, amc$terminate, status);
        = avc$account_admin_authority =
          clp$put_partial_display (display_control, 'Account administration', clc$trim, amc$terminate,
                status);
        = avc$project_admin_authority =
          clp$put_partial_display (display_control, 'Project administration', clc$trim, amc$terminate,
                status);
        = avc$user_authority =
          clp$put_partial_display (display_control, 'User', clc$trim, amc$terminate, status);
        = avc$any_authority =
          clp$put_partial_display (display_control, 'Any', clc$trim, amc$terminate, status);
        ELSE
          clp$put_partial_display (display_control, 'unknown', clc$trim, amc$terminate, status);
        CASEND;

      PROCEND display_authority_value;
?? OLDTITLE ??
?? NEWTITLE := 'display_capability_field', EJECT ??

      PROCEDURE display_capability_field
        (    field_name: ost$name;
             validation_record_name: ost$name;
             display_options: avt$display_option_set;
         VAR display_control: clt$display_control;
         VAR validation_file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          change_authority: avt$validation_authority,
          default_value: boolean,
          description: ost$string,
          delete_authority: avt$validation_authority,
          display_authority: avt$validation_authority,
          manage_authority: avt$validation_authority;

        status.normal := TRUE;

        avp$get_capability_field_desc (field_name, validation_record_name, osc$null_name, default_value,
              description, change_authority, delete_authority, display_authority, manage_authority,
              validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF avc$field_kind IN display_options THEN
          display_field_kind (avc$capability_kind, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$default_value IN display_options THEN
          IF default_value THEN
            clp$put_partial_display (display_control, '    Default value: INCLUDE', clc$no_trim, amc$start,
                  status);
          ELSE
            clp$put_partial_display (display_control, '    Default value: EXCLUDE', clc$no_trim, amc$start,
                  status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$description IN display_options THEN
          clp$put_partial_display (display_control, '    Description: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, description.value, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$change_authority IN display_options THEN
          display_authority_value ('    Change authority:  ', change_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$display_authority IN display_options THEN
          display_authority_value ('    Display authority: ', display_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$manage_authority IN display_options THEN
          display_authority_value ('    Manage authority:  ', manage_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$delete_authority IN display_options THEN
          display_authority_value ('    Delete authority:  ', delete_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      PROCEND display_capability_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_date_time_field', EJECT ??

      PROCEDURE display_date_time_field
        (    field_name: ost$name;
             validation_record_name: ost$name;
             display_options: avt$display_option_set;
         VAR display_control: clt$display_control;
         VAR validation_file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          change_authority: avt$validation_authority,
          date_applies: boolean,
          date_display_format: string (clc$max_date_time_form_string),
          date_time_range: boolean,
          default_date_time: avt$date_time,
          description: ost$string,
          delete_authority: avt$validation_authority,
          display_authority: avt$validation_authority,
          formatted_date_time: ost$string,
          manage_authority: avt$validation_authority,
          time_applies: boolean,
          time_display_format: string (clc$max_date_time_form_string);

        status.normal := TRUE;

        avp$get_date_time_field_desc (field_name, validation_record_name, osc$null_name, default_date_time,
              date_time_range, date_applies, time_applies, date_display_format, time_display_format,
              description, change_authority, delete_authority, display_authority, manage_authority,
              validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF avc$field_kind IN display_options THEN
          display_field_kind (avc$date_time_kind, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF date_time_range THEN
            clp$put_display (display_control, '      Range can be specified.', clc$no_trim, status);
          ELSE
            clp$put_display (display_control, '      Range cannot be specified.', clc$no_trim, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF date_applies AND time_applies THEN
            clp$put_display (display_control, '      A date and time may be specified.', clc$no_trim, status);
          ELSEIF date_applies THEN
            clp$put_display (display_control, '      Only a date may be specified.', clc$no_trim, status);
          ELSE
            clp$put_display (display_control, '      Only a time may be specified.', clc$no_trim, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF date_applies THEN
            clp$put_partial_display (display_control, '      Date will be displayed in ', clc$no_trim,
                  amc$start, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF date_display_format = ' ' THEN
              clp$put_partial_display (display_control, 'DEFAULT', clc$trim, amc$continue, status);
            ELSEIF date_display_format = avc$dmy_date_format THEN
              clp$put_partial_display (display_control, 'DAY_MONTH_YEAR', clc$trim, amc$continue, status);
            ELSEIF date_display_format = avc$iso_date_format THEN
              clp$put_partial_display (display_control, 'ISO_DATE', clc$trim, amc$continue, status);
            ELSEIF date_display_format = avc$mdy_date_format THEN
              clp$put_partial_display (display_control, 'MONTH_DAY_YEAR', clc$trim, amc$continue, status);
            ELSEIF date_display_format = avc$month_date_format THEN
              clp$put_partial_display (display_control, 'MONTH', clc$trim, amc$continue, status);
            ELSEIF date_display_format = avc$ordinal_date_format THEN
              clp$put_partial_display (display_control, 'ORDINAL', clc$trim, amc$continue, status);
            ELSE
              clp$put_partial_display (display_control, date_display_format, clc$trim, amc$continue, status);
            IFEND;
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            clp$put_partial_display (display_control, ' format.', clc$no_trim, amc$terminate, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

          IF time_applies THEN
            clp$put_partial_display (display_control, '      Time will be displayed in ', clc$no_trim,
                  amc$start, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF time_display_format = ' ' THEN
              clp$put_partial_display (display_control, 'DEFAULT', clc$trim, amc$continue, status);
            ELSEIF time_display_format = avc$ampm_time_format THEN
              clp$put_partial_display (display_control, 'AMPM', clc$trim, amc$continue, status);
            ELSEIF time_display_format = avc$hms_time_format THEN
              clp$put_partial_display (display_control, 'HOUR_MINUTE_SECOND', clc$trim, amc$continue, status);
            ELSEIF time_display_format = avc$iso_time_format THEN
              clp$put_partial_display (display_control, 'ISO_TIME', clc$trim, amc$continue, status);
            ELSEIF time_display_format = avc$millisecond_time_format THEN
              clp$put_partial_display (display_control, 'MILLISECOND', clc$trim, amc$continue, status);
            ELSE
              clp$put_partial_display (display_control, time_display_format, clc$trim, amc$continue, status);
            IFEND;
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            clp$put_partial_display (display_control, ' format.', clc$no_trim, amc$terminate, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;

        IF avc$default_value IN display_options THEN
          clp$put_partial_display (display_control, '    Default value: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF date_time_range THEN
            format_date_time (default_date_time.starting_value, date_applies, date_display_format,
                  time_applies, time_display_format, formatted_date_time, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, formatted_date_time.value, clc$trim, amc$continue,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, ' .. ', clc$no_trim, amc$continue, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            format_date_time (default_date_time.ending_value, date_applies, date_display_format, time_applies,
                  time_display_format, formatted_date_time, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, formatted_date_time.value, clc$trim, amc$continue,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSE
            format_date_time (default_date_time.value, date_applies, date_display_format, time_applies,
                  time_display_format, formatted_date_time, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, formatted_date_time.value, clc$trim, amc$continue,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;

        IF avc$description IN display_options THEN
          clp$put_partial_display (display_control, '    Description: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, description.value, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$change_authority IN display_options THEN
          display_authority_value ('    Change authority:  ', change_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$display_authority IN display_options THEN
          display_authority_value ('    Display authority: ', display_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$manage_authority IN display_options THEN
          display_authority_value ('    Manage authority:  ', manage_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$delete_authority IN display_options THEN
          display_authority_value ('    Delete authority:  ', delete_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      PROCEND display_date_time_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_file_field', EJECT ??

      PROCEDURE display_file_field
        (    field_name: ost$name;
             validation_record_name: ost$name;
             display_options: avt$display_option_set;
         VAR display_control: clt$display_control;
         VAR validation_file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          change_authority: avt$validation_authority,
          default_value: string (fsc$max_path_size),
          description: ost$string,
          delete_authority: avt$validation_authority,
          display_authority: avt$validation_authority,
          manage_authority: avt$validation_authority;

        status.normal := TRUE;

        avp$get_file_field_desc (field_name, validation_record_name, osc$null_name, default_value,
              description, change_authority, delete_authority, display_authority, manage_authority,
              validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF avc$field_kind IN display_options THEN
          display_field_kind (avc$file_kind, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$default_value IN display_options THEN
          clp$put_partial_display (display_control, '    Default value: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, default_value, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$description IN display_options THEN
          clp$put_partial_display (display_control, '    Description: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, description.value, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$change_authority IN display_options THEN
          display_authority_value ('    Change authority:  ', change_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$display_authority IN display_options THEN
          display_authority_value ('    Display authority: ', display_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$manage_authority IN display_options THEN
          display_authority_value ('    Manage authority:  ', manage_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$delete_authority IN display_options THEN
          display_authority_value ('    Delete authority:  ', delete_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      PROCEND display_file_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_integer_field', EJECT ??

      PROCEDURE display_integer_field
        (    field_name: ost$name;
             validation_record_name: ost$name;
             display_options: avt$display_option_set;
         VAR display_control: clt$display_control;
         VAR validation_file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          change_authority: avt$validation_authority,
          default_value: integer,
          description: ost$string,
          delete_authority: avt$validation_authority,
          display_authority: avt$validation_authority,
          display_format: avt$numeric_display_format,
          integer_value: integer,
          manage_authority: avt$validation_authority,
          maximum_value: integer,
          minimum_value: integer;

        status.normal := TRUE;

        avp$get_integer_field_desc (field_name, validation_record_name, osc$null_name, default_value,
              minimum_value, maximum_value, display_format, description, change_authority, delete_authority,
              display_authority, manage_authority, validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF avc$field_kind IN display_options THEN
          display_field_kind (avc$integer_kind, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          integer_value := display_format.field_size;
          display_integer ('      Display field width: ', integer_value, 3, 10, FALSE, display_control,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          integer_value := display_format.radix;
          display_integer ('      Radix used for display: ', integer_value, 3, 10, FALSE, display_control,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF display_format.display_radix THEN
            clp$put_display (display_control, '      Radix will be displayed.', clc$no_trim, status);
          ELSE
            clp$put_display (display_control, '      Radix will not be displayed.', clc$no_trim, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          display_integer ('      Minimum value: ', minimum_value, display_format.field_size,
                display_format.radix, display_format.display_radix, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          display_integer ('      Maximum value: ', maximum_value, display_format.field_size,
                display_format.radix, display_format.display_radix, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$default_value IN display_options THEN
          display_integer ('    Default value: ', default_value, display_format.field_size,
                display_format.radix, display_format.display_radix, display_control, status);
        IFEND;

        IF avc$description IN display_options THEN
          clp$put_partial_display (display_control, '    Description: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, description.value, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$change_authority IN display_options THEN
          display_authority_value ('    Change authority:  ', change_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$display_authority IN display_options THEN
          display_authority_value ('    Display authority: ', display_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$manage_authority IN display_options THEN
          display_authority_value ('    Manage authority:  ', manage_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$delete_authority IN display_options THEN
          display_authority_value ('    Delete authority:  ', delete_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      PROCEND display_integer_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_job_class_field', EJECT ??

      PROCEDURE display_job_class_field
        (    field_name: ost$name;
             validation_record_name: ost$name;
             display_options: avt$display_option_set;
         VAR display_control: clt$display_control;
         VAR validation_file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          batch_job_class_default: ost$name,
          change_authority: avt$validation_authority,
          common_job_classes: ^avt$name_list,
          default_job_classes: ^avt$name_list,
          description: ost$string,
          delete_authority: avt$validation_authority,
          display_authority: avt$validation_authority,
          interactive_job_class_default: ost$name,
          manage_authority: avt$validation_authority,
          number_of_common_job_classes: avt$name_list_size,
          number_of_default_job_classes: avt$name_list_size;

        status.normal := TRUE;

        PUSH default_job_classes: [1 .. avc$maximum_name_list_size];
        PUSH common_job_classes: [1 .. avc$maximum_name_list_size];

        avp$get_job_class_field_desc (field_name, validation_record_name, osc$null_name,
              number_of_default_job_classes, default_job_classes, batch_job_class_default,
              interactive_job_class_default, number_of_common_job_classes, common_job_classes, description,
              change_authority, delete_authority, display_authority, manage_authority,
              validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF avc$field_kind IN display_options THEN
          display_field_kind (avc$job_class_kind, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$default_value IN display_options THEN
          display_list_of_names ('    Default job classes', number_of_default_job_classes,
                default_job_classes, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, '    Interactive default: ', clc$no_trim, amc$start,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, interactive_job_class_default, clc$trim, amc$terminate,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, '    Batch default: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, batch_job_class_default, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$description IN display_options THEN
          clp$put_partial_display (display_control, '    Description: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, description.value, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$change_authority IN display_options THEN
          display_authority_value ('    Change authority:  ', change_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$display_authority IN display_options THEN
          display_authority_value ('    Display authority: ', display_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$manage_authority IN display_options THEN
          display_authority_value ('    Manage authority:  ', manage_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$delete_authority IN display_options THEN
          display_authority_value ('    Delete authority:  ', delete_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      PROCEND display_job_class_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_labeled_names_field', EJECT ??

      PROCEDURE display_labeled_names_field
        (    field_name: ost$name;
             validation_record_name: ost$name;
             display_options: avt$display_option_set;
         VAR display_control: clt$display_control;
         VAR validation_file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          change_authority: avt$validation_authority,
          valid_labels: ^avt$name_list,
          valid_names: ^avt$name_list,
          default_labeled_names: ^avt$labeled_names_list,
          description: ost$string,
          delete_authority: avt$validation_authority,
          display_authority: avt$validation_authority,
          manage_authority: avt$validation_authority,
          number_of_valid_labels: avt$name_list_size,
          number_of_valid_names: avt$name_list_size,
          numeric_string: ost$string,
          work_area: ^seq (*);

        status.normal := TRUE;

        PUSH valid_labels: [1 .. avc$maximum_name_list_size];
        PUSH valid_names: [1 .. avc$maximum_name_list_size];
        PUSH work_area: [[REP avc$max_template_record_size OF cell]];
        RESET work_area;

        avp$get_labeled_names_field_des (field_name, validation_record_name, osc$null_name, work_area,
              default_labeled_names,
              number_of_valid_labels, valid_labels, number_of_valid_names, valid_names,
              description, change_authority, delete_authority, display_authority,
              manage_authority, validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF avc$field_kind IN display_options THEN
          display_field_kind (avc$labeled_names_kind, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$default_value IN display_options THEN
          display_labeled_names ('    Default value', default_labeled_names, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$description IN display_options THEN
          clp$put_partial_display (display_control, '    Description: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, description.value, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$change_authority IN display_options THEN
          display_authority_value ('    Change authority:  ', change_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$display_authority IN display_options THEN
          display_authority_value ('    Display authority: ', display_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$manage_authority IN display_options THEN
          display_authority_value ('    Manage authority:  ', manage_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$delete_authority IN display_options THEN
          display_authority_value ('    Delete authority:  ', delete_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      PROCEND display_labeled_names_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_limit_field', EJECT ??

      PROCEDURE display_limit_field
        (    field_name: ost$name;
             validation_record_name: ost$name;
             display_options: avt$display_option_set;
         VAR display_control: clt$display_control;
         VAR validation_file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          change_authority: avt$validation_authority,
          default_value: avt$limit_value,
          description: ost$string,
          delete_authority: avt$validation_authority,
          display_authority: avt$validation_authority,
          manage_authority: avt$validation_authority,
          maximum_limit_value: avt$limit_value,
          minimum_limit_value: avt$limit_value;

        status.normal := TRUE;

        avp$get_limit_field_desc (field_name, validation_record_name, osc$null_name, default_value,
              minimum_limit_value, maximum_limit_value, description, change_authority, delete_authority,
              display_authority, manage_authority, validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF avc$field_kind IN display_options THEN
          display_field_kind (avc$limit_kind, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          display_limit_value ('      Minimum limit value: ', minimum_limit_value, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          display_limit_value ('      Maximum limit value: ', maximum_limit_value, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$default_value IN display_options THEN
          display_limit_value ('    Default value:   ', default_value, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$description IN display_options THEN
          clp$put_partial_display (display_control, '    Description: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, description.value, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$change_authority IN display_options THEN
          display_authority_value ('    Change authority:  ', change_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$display_authority IN display_options THEN
          display_authority_value ('    Display authority: ', display_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$manage_authority IN display_options THEN
          display_authority_value ('    Manage authority:  ', manage_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$delete_authority IN display_options THEN
          display_authority_value ('    Delete authority:  ', delete_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      PROCEND display_limit_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_login_password_field', EJECT ??

      PROCEDURE display_login_password_field
        (    field_name: ost$name;
             validation_record_name: ost$name;
             display_options: avt$display_option_set;
         VAR display_control: clt$display_control;
         VAR validation_file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          change_authority: avt$validation_authority,
          date_time_to_format: clt$date_time,
          default_attributes: ^avt$name_list,
          default_expiration_date: ost$date_time,
          default_expiration_interval: pmt$time_increment,
          default_exp_pw_chg_interval: pmt$time_increment,
          default_exp_warning_interval: pmt$time_increment,
          default_max_expiration_interval: pmt$time_increment,
          default_password: avt$login_password,
          description: ost$string,
          delete_authority: avt$validation_authority,
          display_authority: avt$validation_authority,
          display_format: ^clt$date_time_form_string,
          formatted_date_time: ost$string,
          manage_authority: avt$validation_authority,
          number_of_default_attributes: avt$name_list_size;

        status.normal := TRUE;

        PUSH default_attributes: [1 .. avc$maximum_name_list_size];

        avp$get_login_pw_field_desc (field_name, validation_record_name, osc$null_name, default_password,
              default_expiration_date, default_expiration_interval, default_max_expiration_interval,
              default_exp_warning_interval, default_exp_pw_chg_interval, number_of_default_attributes,
              default_attributes, description, change_authority, delete_authority, display_authority,
              manage_authority, validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF avc$field_kind IN display_options THEN
          display_field_kind (avc$login_password_kind, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$default_value IN display_options THEN
          IF avp$system_administrator () OR avp$family_administrator () THEN
            clp$put_partial_display (display_control, '    Default password: ', clc$no_trim, amc$start,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            clp$put_partial_display (display_control, default_password.value, clc$trim, amc$terminate,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

          clp$put_partial_display (display_control, '    Default expiration date: ', clc$no_trim, amc$start,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF default_expiration_date.year = UPPERVALUE (default_expiration_date.year) THEN
            clp$put_partial_display (display_control, 'None', clc$trim, amc$terminate, status);
          ELSE
            date_time_to_format.value := default_expiration_date;
            date_time_to_format.date_specified := TRUE;
            date_time_to_format.time_specified := TRUE;


            PUSH display_format: [clc$max_date_time_form_string];
            display_format^ := avc$iso_date_format;
            display_format^ (clp$trimmed_string_size (display_format^) + 1, * ) := '.';
            display_format^ (clp$trimmed_string_size (display_format^) + 1, * ) := avc$hms_time_format;

            clp$convert_date_time_to_string (date_time_to_format, display_format^, formatted_date_time,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, formatted_date_time.value (1, formatted_date_time.size),
                  clc$trim, amc$terminate, status);
          IFEND;

          display_time_increment ('    Default expiration interval: ', default_expiration_interval,
                display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          display_time_increment ('    Default maximum expiration interval: ',
                default_max_expiration_interval, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          display_time_increment ('    Default expiration warning interval: ', default_exp_warning_interval,
                display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          display_list_of_names ('    Default password attributes', number_of_default_attributes,
                default_attributes, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$description IN display_options THEN
          clp$put_partial_display (display_control, '    Description: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, description.value, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$change_authority IN display_options THEN
          display_authority_value ('    Change authority:  ', change_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$display_authority IN display_options THEN
          display_authority_value ('    Display authority: ', display_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$manage_authority IN display_options THEN
          display_authority_value ('    Manage authority:  ', manage_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$delete_authority IN display_options THEN
          display_authority_value ('    Delete authority:  ', delete_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      PROCEND display_login_password_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_name_field', EJECT ??

      PROCEDURE display_name_field
        (    field_name: ost$name;
             validation_record_name: ost$name;
             display_options: avt$display_option_set;
         VAR display_control: clt$display_control;
         VAR validation_file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          change_authority: avt$validation_authority,
          common_names: ^avt$name_list,
          default_names: ^avt$name_list,
          description: ost$string,
          delete_authority: avt$validation_authority,
          display_authority: avt$validation_authority,
          manage_authority: avt$validation_authority,
          maximum_number_of_names: avt$name_list_size,
          minimum_number_of_names: avt$name_list_size,
          number_of_common_names: avt$name_list_size,
          number_of_default_names: avt$name_list_size,
          numeric_string: ost$string;

        status.normal := TRUE;

        PUSH common_names: [1 .. avc$maximum_name_list_size];
        PUSH default_names: [1 .. avc$maximum_name_list_size];

        avp$get_name_field_desc (field_name, validation_record_name, osc$null_name, number_of_default_names,
              default_names, minimum_number_of_names, maximum_number_of_names, number_of_common_names,
              common_names, description, change_authority, delete_authority, display_authority,
              manage_authority, validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF avc$field_kind IN display_options THEN
          display_field_kind (avc$name_kind, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, '      Number of names allowed: ', clc$no_trim, amc$start,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$convert_integer_to_string (minimum_number_of_names, 10, FALSE, numeric_string, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF minimum_number_of_names = maximum_number_of_names THEN
            clp$put_partial_display (display_control, numeric_string.value (1, numeric_string.size), clc$trim,
                  amc$terminate, status);
          ELSE
            clp$put_partial_display (display_control, numeric_string.value (1, numeric_string.size), clc$trim,
                  amc$continue, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            clp$put_partial_display (display_control, ' .. ', clc$no_trim, amc$continue, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            clp$convert_integer_to_string (maximum_number_of_names, 10, FALSE, numeric_string, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            clp$put_partial_display (display_control, numeric_string.value (1, numeric_string.size), clc$trim,
                  amc$terminate, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$default_value IN display_options THEN
          display_list_of_names ('    Default value', number_of_default_names, default_names, display_control,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$description IN display_options THEN
          clp$put_partial_display (display_control, '    Description: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, description.value, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$change_authority IN display_options THEN
          display_authority_value ('    Change authority:  ', change_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$display_authority IN display_options THEN
          display_authority_value ('    Display authority: ', display_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$manage_authority IN display_options THEN
          display_authority_value ('    Manage authority:  ', manage_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$delete_authority IN display_options THEN
          display_authority_value ('    Delete authority:  ', delete_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      PROCEND display_name_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_real_field', EJECT ??

      PROCEDURE display_real_field
        (    field_name: ost$name;
             validation_record_name: ost$name;
             display_options: avt$display_option_set;
         VAR display_control: clt$display_control;
         VAR validation_file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          change_authority: avt$validation_authority,
          default_value: real,
          description: ost$string,
          delete_authority: avt$validation_authority,
          display_authority: avt$validation_authority,
          display_format: avt$numeric_display_format,
          field_size_string: ost$string,
          integer_value: integer,
          manage_authority: avt$validation_authority,
          maximum_value: real,
          minimum_value: real,
          numeric_string: string (osc$max_string_size),
          numeric_string_size: integer;

        status.normal := TRUE;

        avp$get_real_field_desc (field_name, validation_record_name, osc$null_name, default_value,
              minimum_value, maximum_value, display_format, description, change_authority, delete_authority,
              display_authority, manage_authority, validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF avc$field_kind IN display_options THEN
          display_field_kind (avc$real_kind, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          CASE display_format.kind OF
          = avc$fixed_point_format =
            clp$put_display (display_control, '      Values will be displayed in fixed point format.',
                  clc$no_trim, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            integer_value := display_format.field_size;
            display_integer ('      Display field width: ', integer_value, 3, 10, FALSE, display_control,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            integer_value := display_format.fraction_size;
            display_integer ('      Number of decimal places: ', integer_value, 3, 10, FALSE, display_control,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, '      Minimum value: ', clc$no_trim, amc$start,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            STRINGREP (numeric_string, numeric_string_size, minimum_value: display_format.
                  field_size: display_format.fraction_size);
            clp$put_partial_display (display_control, numeric_string (1, numeric_string_size), clc$trim,
                  amc$terminate, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, '      Maximum value: ', clc$no_trim, amc$start,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            STRINGREP (numeric_string, numeric_string_size, maximum_value: display_format.
                  field_size: display_format.fraction_size);
            clp$put_partial_display (display_control, numeric_string (1, numeric_string_size), clc$trim,
                  amc$terminate, status);
          = avc$floating_point_format =
            clp$put_display (display_control, '      Values will be displayed in floating point format.',
                  clc$no_trim, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            integer_value := display_format.field_size;
            display_integer ('      Display field width: ', integer_value, 3, 10, FALSE, display_control,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, '      Minimum value: ', clc$no_trim, amc$start,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            STRINGREP (numeric_string, numeric_string_size, minimum_value: display_format.field_size);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            clp$put_partial_display (display_control, numeric_string (1, numeric_string_size), clc$trim,
                  amc$terminate, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, '      Maximum value: ', clc$no_trim, amc$start,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            STRINGREP (numeric_string, numeric_string_size, maximum_value: display_format.field_size);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            clp$put_partial_display (display_control, numeric_string (1, numeric_string_size), clc$trim,
                  amc$terminate, status);
          CASEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$default_value IN display_options THEN
          clp$put_partial_display (display_control, '    Default value: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          CASE display_format.kind OF
          = avc$fixed_point_format =
            STRINGREP (numeric_string, numeric_string_size, default_value: display_format.
                  field_size: display_format.fraction_size);
            clp$put_partial_display (display_control, numeric_string (1, numeric_string_size), clc$trim,
                  amc$terminate, status);
          = avc$floating_point_format =
            STRINGREP (numeric_string, numeric_string_size, default_value: display_format.field_size);
            clp$put_partial_display (display_control, numeric_string (1, numeric_string_size), clc$trim,
                  amc$terminate, status);
          CASEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$description IN display_options THEN
          clp$put_partial_display (display_control, '    Description: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, description.value, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$change_authority IN display_options THEN
          display_authority_value ('    Change authority:  ', change_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$display_authority IN display_options THEN
          display_authority_value ('    Display authority: ', display_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$manage_authority IN display_options THEN
          display_authority_value ('    Manage authority:  ', manage_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$delete_authority IN display_options THEN
          display_authority_value ('    Delete authority:  ', delete_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      PROCEND display_real_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_ring_privilege_field', EJECT ??

      PROCEDURE display_ring_privilege_field
        (    field_name: ost$name;
             validation_record_name: ost$name;
             display_options: avt$display_option_set;
         VAR display_control: clt$display_control;
         VAR validation_file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          change_authority: avt$validation_authority,
          default_minimum_ring: ost$ring,
          default_nominal_ring: ost$ring,
          description: ost$string,
          delete_authority: avt$validation_authority,
          display_authority: avt$validation_authority,
          integer_value: integer,
          manage_authority: avt$validation_authority;

        status.normal := TRUE;

        avp$get_ring_priv_field_desc (field_name, validation_record_name, osc$null_name, default_minimum_ring,
              default_nominal_ring, description, change_authority, delete_authority, display_authority,
              manage_authority, validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF avc$field_kind IN display_options THEN
          display_field_kind (avc$ring_privilege_kind, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$default_value IN display_options THEN
          integer_value := default_minimum_ring;
          display_integer ('    Default minimum ring: ', integer_value, 3, 10, FALSE, display_control,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          integer_value := default_nominal_ring;
          display_integer ('    Default nominal ring: ', integer_value, 3, 10, FALSE, display_control,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$description IN display_options THEN
          clp$put_partial_display (display_control, '    Description: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, description.value, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$change_authority IN display_options THEN
          display_authority_value ('    Change authority:  ', change_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$display_authority IN display_options THEN
          display_authority_value ('    Display authority: ', display_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$manage_authority IN display_options THEN
          display_authority_value ('    Manage authority:  ', manage_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$delete_authority IN display_options THEN
          display_authority_value ('    Delete authority:  ', delete_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      PROCEND display_ring_privilege_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_string_field', EJECT ??

      PROCEDURE display_string_field
        (    field_name: ost$name;
             validation_record_name: ost$name;
             display_options: avt$display_option_set;
         VAR display_control: clt$display_control;
         VAR validation_file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          change_authority: avt$validation_authority,
          default_value: ost$string,
          description: ost$string,
          delete_authority: avt$validation_authority,
          display_authority: avt$validation_authority,
          integer_value: integer,
          manage_authority: avt$validation_authority,
          maximum_size: ost$string_size,
          minimum_size: ost$string_size;

        status.normal := TRUE;

        avp$get_string_field_desc (field_name, validation_record_name, osc$null_name, default_value,
              minimum_size, maximum_size, description, change_authority, delete_authority, display_authority,
              manage_authority, validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF avc$field_kind IN display_options THEN
          display_field_kind (avc$string_kind, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          integer_value := minimum_size;
          display_integer ('      Minimum size: ', integer_value, 4, 10, FALSE, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          integer_value := maximum_size;
          display_integer ('      Maximum size: ', integer_value, 4, 10, FALSE, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$default_value IN display_options THEN
          clp$put_partial_display (display_control, '    Default value: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, '''', clc$trim, amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, default_value.value (1, default_value.size), clc$no_trim,
                amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, '''', clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$description IN display_options THEN
          clp$put_partial_display (display_control, '    Description: ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, description.value, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$change_authority IN display_options THEN
          display_authority_value ('    Change authority:  ', change_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$display_authority IN display_options THEN
          display_authority_value ('    Display authority: ', display_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$manage_authority IN display_options THEN
          display_authority_value ('    Manage authority:  ', manage_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF avc$delete_authority IN display_options THEN
          display_authority_value ('    Delete authority:  ', delete_authority, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      PROCEND display_string_field;
?? OLDTITLE, EJECT ??
      status.normal := TRUE;

      clp$put_display (display_control, ' ', clc$no_trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_display (display_control, field_name, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF display_options <> $avt$display_option_set [] THEN
        avp$get_validation_field_kind (field_name, validation_record_name, field_kind,
              validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        CASE field_kind OF
        = avc$account_project_kind =
          display_account_project_field (field_name, validation_record_name, display_options, display_control,
                validation_file_information, status);
        = avc$accumulating_limit_kind =
          display_accum_limit_field (field_name, validation_record_name, display_options, display_control,
                validation_file_information, status);
        = avc$capability_kind =
          display_capability_field (field_name, validation_record_name, display_options, display_control,
                validation_file_information, status);
        = avc$date_time_kind =
          display_date_time_field (field_name, validation_record_name, display_options, display_control,
                validation_file_information, status);
        = avc$file_kind =
          display_file_field (field_name, validation_record_name, display_options, display_control,
                validation_file_information, status);
        = avc$integer_kind =
          display_integer_field (field_name, validation_record_name, display_options, display_control,
                validation_file_information, status);
        = avc$job_class_kind =
          display_job_class_field (field_name, validation_record_name, display_options, display_control,
                validation_file_information, status);
        = avc$keyword_kind =

{ keywords are not implemented yet.

        = avc$labeled_names_kind =
          display_labeled_names_field (field_name, validation_record_name, display_options, display_control,
                validation_file_information, status);
        = avc$limit_kind =
          display_limit_field (field_name, validation_record_name, display_options, display_control,
                validation_file_information, status);
        = avc$login_password_kind =
          display_login_password_field (field_name, validation_record_name, display_options, display_control,
                validation_file_information, status);
        = avc$name_kind =
          display_name_field (field_name, validation_record_name, display_options, display_control,
                validation_file_information, status);
        = avc$real_kind =
          display_real_field (field_name, validation_record_name, display_options, display_control,
                validation_file_information, status);
        = avc$ring_privilege_kind =
          display_ring_privilege_field (field_name, validation_record_name, display_options, display_control,
                validation_file_information, status);
        = avc$string_kind =
          display_string_field (field_name, validation_record_name, display_options, display_control,
                validation_file_information, status);
        ELSE
          clp$put_partial_display (display_control, '    Field type: unknown', clc$no_trim, amc$start,
                status);
        CASEND;
      IFEND;

    PROCEND display_field;
?? OLDTITLE ??
?? NEWTITLE := 'get_display_options', EJECT ??

    PROCEDURE get_display_options
      (VAR display_options: avt$display_option_set;
       VAR status: ost$status);

      VAR
        current_parameter_value: ^clt$data_value;

      status.normal := TRUE;

      display_options := $avt$display_option_set [];

      current_parameter_value := pvt [p$display_option].value;
      REPEAT
        IF (current_parameter_value^.element_value^.keyword_value = 'TYPE') THEN
          display_options := display_options + $avt$display_option_set [avc$field_kind];
        ELSEIF (current_parameter_value^.element_value^.keyword_value = 'DEFAULT_VALUE') THEN
          display_options := display_options + $avt$display_option_set [avc$default_value];
        ELSEIF (current_parameter_value^.element_value^.keyword_value = 'DESCRIPTION') THEN
          display_options := display_options + $avt$display_option_set [avc$description];
        ELSEIF (current_parameter_value^.element_value^.keyword_value = 'CHANGE_AUTHORITY') THEN
          display_options := display_options + $avt$display_option_set [avc$change_authority];
        ELSEIF (current_parameter_value^.element_value^.keyword_value = 'DISPLAY_AUTHORITY') THEN
          display_options := display_options + $avt$display_option_set [avc$display_authority];
        ELSEIF (current_parameter_value^.element_value^.keyword_value = 'MANAGE_AUTHORITY') THEN
          display_options := display_options + $avt$display_option_set [avc$manage_authority];
        ELSEIF (current_parameter_value^.element_value^.keyword_value = 'DELETE_AUTHORITY') THEN
          display_options := display_options + $avt$display_option_set [avc$delete_authority];
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'ALL' THEN
          IF clp$count_list_elements (pvt [p$display_option].value) <> 1 THEN
            osp$set_status_abnormal ('AV', ave$must_be_used_alone, 'ALL', status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'DISPLAY_OPTION', status);
            RETURN;
          ELSE
            display_options := -$avt$display_option_set [];
            RETURN;
          IFEND;
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'NONE' THEN
          IF clp$count_list_elements (pvt [p$display_option].value) <> 1 THEN
            osp$set_status_abnormal ('AV', ave$must_be_used_alone, 'NONE', status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'DISPLAY_OPTION', status);
            RETURN;
          ELSE
            display_options := $avt$display_option_set [];
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal ('AV', ave$unknown_display_option,
                current_parameter_value^.element_value^.keyword_value, status);
          RETURN;
        IFEND;
        current_parameter_value := current_parameter_value^.link;
      UNTIL current_parameter_value = NIL;

    PROCEND get_display_options;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

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

    get_display_options (display_options, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$field_name].value^.kind = clc$list THEN
      PUSH field_name_list: [1 .. clp$count_list_elements (pvt [p$field_name].value)];
      current_parameter_value := pvt [p$field_name].value;
      index := 0;
      REPEAT
        index := index + 1;
        field_name_list^ [index] := current_parameter_value^.element_value^.name_value;
        current_parameter_value := current_parameter_value^.link;
      UNTIL current_parameter_value = NIL;
    ELSE { clc$keyword }
      PUSH field_name_work_area: [[REP avc$maximum_field_count OF ost$name]];
      RESET field_name_work_area;
      NEXT field_name_list: [1 .. avc$maximum_field_count] IN field_name_work_area;
      avp$get_validation_field_names (current_subutility_session_info^.validation_record_name,
            -$avt$field_kind_set [], FALSE, field_name_list^, field_name_count, validation_file_information,
            status);
      RESET field_name_work_area;
      NEXT field_name_list: [1 .. field_name_count] IN field_name_work_area;
    IFEND;

    clv$titles_built := FALSE;
    clv$command_name := 'display_field_description';
    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    file_contents := amc$list;

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, file_contents,
          ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

  /display/
    FOR index := 1 TO UPPERBOUND (field_name_list^) DO
      display_field (field_name_list^ [index], current_subutility_session_info^.validation_record_name,
            display_options, display_control, validation_file_information, status);
      IF NOT status.normal THEN
        EXIT /display/;
      IFEND;
    FOREND /display/;

    osp$disestablish_cond_handler;

    IF NOT status.normal THEN
      clp$close_display (display_control, ignore_status);
    ELSE
      clp$close_display (display_control, status);
    IFEND;

  PROCEND avp$display_field_description;
?? OLDTITLE ??
?? NEWTITLE := 'avp$display_field_names', EJECT ??

{ PURPOSE:
{   This is the command processor for the DISPLAY_FIELD_NAMES subcommand.

  PROCEDURE [XDCL] avp$display_field_names
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_disfn) display_field_names, disfn (
{   output, o: file = $output
{   display_option, display_options, do: (BY_NAME) key
{       (active, a)
{       all
{       (deleted, d)
{     keyend = active
{   type, t: (BY_NAME) key
{       (account_project, ap)
{       (accumulating_limit, al)
{       (capability, capabilities, c)
{       (date_time, dt)
{       (file, f)
{       (integer, i)
{       (job_class, jc)
{       (labeled_names, ln)
{       (limit, l)
{       (login_password, lpw)
{       (name, n)
{       (real, r)
{       (ring_privilege, rp)
{       (string, s)
{       all
{     keyend = all
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
        default_value: string (6),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 30] of clt$keyword_specification,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 11, 14, 45, 52, 635],
    clc$command, 8, 4, 0, 0, 0, 0, 4, 'OSM$ADMV_DISFN'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['T                              ',clc$abbreviation_entry, 3],
    ['TYPE                           ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1117,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [5], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['DELETED                        ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ,
    'active'],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [30], [
    ['ACCOUNT_PROJECT                ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ACCUMULATING_LIMIT             ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['AL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 15],
    ['AP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['CAPABILITIES                   ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['CAPABILITY                     ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['DATE_TIME                      ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['DT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['FILE                           ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['INTEGER                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['JC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
    ['JOB_CLASS                      ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
    ['LABELED_NAMES                  ', clc$nominal_entry, clc$normal_usage_entry, 8],
    ['LIMIT                          ', clc$nominal_entry, clc$normal_usage_entry, 9],
    ['LN                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
    ['LOGIN_PASSWORD                 ', clc$nominal_entry, clc$normal_usage_entry, 10],
    ['LPW                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
    ['NAME                           ', clc$nominal_entry, clc$normal_usage_entry, 11],
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
    ['REAL                           ', clc$nominal_entry, clc$normal_usage_entry, 12],
    ['RING_PRIVILEGE                 ', clc$nominal_entry, clc$normal_usage_entry, 13],
    ['RP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
    ['STRING                         ', clc$nominal_entry, clc$normal_usage_entry, 14]]
    ,
    'all'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

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

    CONST
      p$output = 1,
      p$display_option = 2,
      p$type = 3,
      p$status = 4;

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

    VAR
      display_control: clt$display_control,
      field_count: 0 .. avc$maximum_field_count,
      field_names: array [1 .. avc$maximum_field_count] of ost$name,
      field_kind: avt$field_kind,
      field_kind_set: avt$field_kind_set,
      file_contents: amt$file_contents,
      ignore_status: ost$status,
      index: 1 .. avc$maximum_field_count,
      name_list: ^avt$name_list,
      ring_attributes: amt$ring_attributes;

?? NEWTITLE := 'condition_handler', EJECT ??

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

      VAR
        ignore_status: ost$status;

{ This condition handler is used to close the display file in case of an abnormal termination.

      clp$close_display (display_control, ignore_status);

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

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

    IF pvt [p$type].value^.keyword_value = 'ALL' THEN
      field_kind_set := -$avt$field_kind_set [];
    ELSE
      field_kind_set := $avt$field_kind_set [];
    /get_field_kind/
      FOR field_kind := LOWERVALUE(field_kind) TO UPPERVALUE(field_kind) DO
        IF pvt [p$type].value^.keyword_value = avv$field_kind_names [field_kind] THEN
          field_kind_set := $avt$field_kind_set [field_kind];
          EXIT /get_field_kind/;
        IFEND;
      FOREND /get_field_kind/;
    IFEND;

    clv$titles_built := FALSE;
    clv$command_name := 'display_field_names';
    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    file_contents := amc$list;

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, file_contents,
          ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

  /display/
    BEGIN

      IF (pvt [p$display_option].value^.keyword_value = 'ACTIVE') OR
            (pvt [p$display_option].value^.keyword_value = 'ALL') THEN
        avp$get_validation_field_names (current_subutility_session_info^.validation_record_name,
              field_kind_set, FALSE, field_names, field_count, validation_file_information, status);
        IF NOT status.normal THEN
          EXIT /display/;
        IFEND;

        IF field_count <> 0 THEN
          PUSH name_list: [1 .. field_count];
          FOR index := 1 TO field_count DO
            name_list^ [index] := field_names [index];
          FOREND;
        ELSE
          name_list := NIL;
        IFEND;

        IF name_list <> NIL THEN
          display_list_of_names ('Active field names ', field_count, name_list, display_control, status);
          IF NOT status.normal THEN
            EXIT /display/;
          IFEND;
        IFEND;
      IFEND;

      IF (pvt [p$display_option].value^.keyword_value = 'DELETED') OR
            (pvt [p$display_option].value^.keyword_value = 'ALL') THEN
        avp$get_validation_field_names (current_subutility_session_info^.validation_record_name,
              field_kind_set, TRUE, field_names, field_count, validation_file_information, status);
        IF NOT status.normal THEN
          EXIT /display/;
        IFEND;

        IF field_count <> 0 THEN
          PUSH name_list: [1 .. field_count];
          FOR index := 1 TO field_count DO
            name_list^ [index] := field_names [index];
          FOREND;
        ELSE
          name_list := NIL;
        IFEND;

        IF name_list <> NIL THEN
          display_list_of_names ('Deleted field names', field_count, name_list, display_control, status);
          IF NOT status.normal THEN
            EXIT /display/;
          IFEND;
        IFEND;
      IFEND;
    END /display/;

    osp$disestablish_cond_handler;

    IF NOT status.normal THEN
      clp$close_display (display_control, ignore_status);
    ELSE
      clp$close_display (display_control, status);
    IFEND;

  PROCEND avp$display_field_names;
?? OLDTITLE ??
?? NEWTITLE := 'end_manage_subutility', EJECT ??

{ PURPOSE:
{   This is the command processor for the END_MANAGE_ACCOUNT_FIELDS,
{   END_MANAGE_ACCT_MEMBER_FIELDS, END_MANAGE_PROJECT_FIELDS,
{   END_MANAGE_PROJ_MEMBER_FIELDS, and END_MANAGE_USER_FIELDS subcommands.

  PROCEDURE [XDCL] end_manage_subutility
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_endmf) end_manage_fields, endmf

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [88, 5, 16, 0, 59, 53, 272], clc$command, 0, 0, 0, 0, 0, 0, 0, 'OSM$ADMV_ENDMF']];

?? POP ??

    status.normal := TRUE;

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

    clp$end_include (current_subutility_session_info^.subutility_name, status);

  PROCEND end_manage_subutility;
?? OLDTITLE ??
?? NEWTITLE := 'restore_field', EJECT ??

{ PURPOSE:
{   This is the command processor for the RESTORE_FIELD subcommand.

  PROCEDURE restore_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admv_resf) restore_field, resf (
{   field_name, fn: name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 16, 1, 1, 7, 425], clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$ADMV_RESF'],
            [['FIELD_NAME                     ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 2]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$field_name = 1,
      p$status = 2;

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

    status.normal := TRUE;

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

    avp$restore_validation_field (pvt [p$field_name].value^.name_value,
          current_subutility_session_info^.validation_record_name, validation_file_information, status);

  PROCEND restore_field;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'Helper Procedures', EJECT ??
?? NEWTITLE := 'create_change_subutility', EJECT ??

{ PURPOSE:
{   This procedure performs the bulk of the processing for the create and change ADMV subutilities.

  PROCEDURE create_change_subutility
    (    subutility_name: string ( * <= osc$max_name_size);
         subutility_prompt: string ( * <= osc$max_name_size);
         validation_record_name: ost$name;
         validation_record_key: avt$validation_key;
         record_id: ost$name;
         command_table_size: integer;
     VAR rewrite_record: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'display_subutility_message', EJECT ??

{ PURPOSE:
{   This procedure displays a message, when the subutility is entered interactivly, to inform the user
{   what is being done.

    PROCEDURE display_subutility_message
      (    current_subutility_session_info: ^avt$subutility_session_info);

      VAR
        interactive: boolean,
        message_status: ost$status;

      clp$get_command_origin (interactive, ignore_status);
      IF (interactive) AND (current_subutility_session_info <> NIL) THEN
        IF current_subutility_session_info^.validation_record_name = avc$account_record_name THEN
          IF current_subutility_session_info^.subutility_name = avc$chaa_utility_name THEN
            osp$set_status_abnormal ('AV', ave$changing_account,
                  current_subutility_session_info^.key.account_name, message_status);
          ELSE
            osp$set_status_abnormal ('AV', ave$creating_account,
                  current_subutility_session_info^.key.account_name, message_status);
          IFEND;
        ELSEIF current_subutility_session_info^.validation_record_name = avc$account_member_record_name THEN
          IF current_subutility_session_info^.subutility_name = avc$chaam_utility_name THEN
            osp$set_status_abnormal ('AV', ave$changing_account_member,
                  current_subutility_session_info^.key.user_name, message_status);
          ELSE
            osp$set_status_abnormal ('AV', ave$creating_account_member,
                  current_subutility_session_info^.key.user_name, message_status);
          IFEND;
          osp$append_status_parameter (osc$status_parameter_delimiter,
                current_subutility_session_info^.key.account_name, message_status);
        ELSEIF current_subutility_session_info^.validation_record_name = avc$project_record_name THEN
          IF current_subutility_session_info^.subutility_name = avc$chap_utility_name THEN
            osp$set_status_abnormal ('AV', ave$changing_project,
                  current_subutility_session_info^.key.project_name, message_status);
          ELSE
            osp$set_status_abnormal ('AV', ave$creating_project,
                  current_subutility_session_info^.key.project_name, message_status);
          IFEND;
          osp$append_status_parameter (osc$status_parameter_delimiter,
                current_subutility_session_info^.key.account_name, message_status);
        ELSEIF current_subutility_session_info^.validation_record_name = avc$project_member_record_name THEN
          IF current_subutility_session_info^.subutility_name = avc$chapm_utility_name THEN
            osp$set_status_abnormal ('AV', ave$changing_project_member,
                  current_subutility_session_info^.key.user_name, message_status);
          ELSE
            osp$set_status_abnormal ('AV', ave$creating_project_member,
                  current_subutility_session_info^.key.user_name, message_status);
          IFEND;
          osp$append_status_parameter (osc$status_parameter_delimiter,
                current_subutility_session_info^.key.project_name, message_status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                current_subutility_session_info^.key.account_name, message_status);
        ELSE
          IF current_subutility_session_info^.subutility_name = avc$chau_utility_name THEN
            osp$set_status_abnormal ('AV', ave$changing_user, current_subutility_session_info^.key.user_name,
                  message_status);
          ELSE
            osp$set_status_abnormal ('AV', ave$creating_user, current_subutility_session_info^.key.user_name,
                  message_status);
          IFEND;
        IFEND;
        osp$generate_output_message (message_status, ignore_status);
      IFEND;

    PROCEND display_subutility_message;
?? OLDTITLE, EJECT ??

    VAR
      command_table: ^clt$command_table,
      command_table_work_area: ^SEQ ( * ),
      end_change_command: ost$name,
      end_create_command: ost$name,
      ignore_status: ost$status,
      index: integer,
      new_subutility_session_info: ^avt$subutility_session_info,
      previous_session_information: ^avt$subutility_session_info,
      session_info: ^avt$subutility_session_info,
      subutility_attributes: ^clt$utility_attributes;

    status.normal := TRUE;

{ Make sure no subutility is currently active referencing the specified key.

    session_info := current_subutility_session_info;
    WHILE session_info <> NIL DO
      IF session_info^.key.value = validation_record_key.value THEN
        osp$set_status_abnormal ('AV', ave$conflicting_operation, session_info^.subutility_name, status);
        RETURN;
      IFEND;
      session_info := session_info^.previous_session_information;
    WHILEND;

{ Add an entry to the subutility information chain.

    ALLOCATE new_subutility_session_info;
    new_subutility_session_info^.id := record_id;
    new_subutility_session_info^.rewrite_record := FALSE;
    new_subutility_session_info^.key := validation_record_key;
    new_subutility_session_info^.previous_account_default := default_account;
    new_subutility_session_info^.previous_project_default := default_project;
    new_subutility_session_info^.previous_user_default := default_user;
    new_subutility_session_info^.validation_record_name := validation_record_name;
    new_subutility_session_info^.subutility_name := subutility_name;
    new_subutility_session_info^.subutility_prompt := subutility_prompt;
    new_subutility_session_info^.previous_session_information := current_subutility_session_info;

    current_subutility_session_info := new_subutility_session_info;

{ Update the default values.

    IF (validation_record_key.account_name <> osc$null_name) AND
          (validation_record_key.account_name <> avc$high_value_name) THEN
      default_account := validation_record_key.account_name;
    IFEND;

    IF (validation_record_key.project_name <> osc$null_name) AND
          (validation_record_key.project_name <> avc$high_value_name) THEN
      default_project := validation_record_key.project_name;
    IFEND;

    IF (validation_record_key.user_name <> osc$null_name) THEN
      default_user := validation_record_key.user_name;
    IFEND;

{ Get the subutility command table from the validation file.

    PUSH command_table_work_area: [[REP command_table_size OF clt$command_table_entry]];
    RESET command_table_work_area;
    avp$get_command_table (current_subutility_session_info^.id, command_table_work_area, command_table,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Adjust the command name used to exit the subutility if necessary.

    end_change_command := osc$null_name;
    end_create_command := osc$null_name;
    IF (subutility_name = avc$creu_utility_name) THEN
      end_change_command := 'END_CHANGE_USER';
      end_create_command := 'END_CREATE_USER';
    ELSEIF (subutility_name = avc$crea_utility_name) THEN
      end_change_command := 'END_CHANGE_ACCOUNT';
      end_create_command := 'END_CREATE_ACCOUNT';
    ELSEIF (subutility_name = avc$cream_utility_name) THEN
      end_change_command := 'END_CHANGE_ACCOUNT_MEMBER';
      end_create_command := 'END_CREATE_ACCOUNT_MEMBER';
    ELSEIF (subutility_name = avc$crep_utility_name) THEN
      end_change_command := 'END_CHANGE_PROJECT';
      end_create_command := 'END_CREATE_PROJECT';
    ELSEIF (subutility_name = avc$crepm_utility_name) THEN
      end_change_command := 'END_CHANGE_PROJECT_MEMBER';
      end_create_command := 'END_CREATE_PROJECT_MEMBER';
    IFEND;

    IF end_create_command <> osc$null_name THEN

    /set_end_command_name/
      FOR index := 1 TO UPPERBOUND (command_table^) DO
        IF command_table^ [index].name = end_change_command THEN
          command_table^ [index].name := end_create_command;
          EXIT /set_end_command_name/;
        IFEND;
      FOREND /set_end_command_name/;
    IFEND;

{ Process the subutility subcommands.

    PUSH subutility_attributes: [1 .. 3];
    subutility_attributes^ [1].key := clc$utility_prompt;
    subutility_attributes^ [1].prompt.value := subutility_prompt;
    subutility_attributes^ [1].prompt.size := clp$trimmed_string_size
          (subutility_attributes^ [1].prompt.value);
    subutility_attributes^ [2].key := clc$utility_command_table;
    subutility_attributes^ [2].command_table := command_table;
    subutility_attributes^ [3].key := clc$utility_function_proc_table;
    subutility_attributes^ [3].function_processor_table := admv_subutil_func_table;
    clp$begin_utility (subutility_name, subutility_attributes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_subutility_message (current_subutility_session_info);

    clp$include_file (clc$current_command_input, '', subutility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (subutility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rewrite_record := current_subutility_session_info^.rewrite_record;

{ Finish processing.  The validation record is rewritten with any changes made
{ during the subutility session if the rewrite record flag is TRUE.  If the rewrite
{ record flag is false, the record is not rewritten.  IF the rewrite fails because
{ the record does not exist, ignore the error.

    IF status.normal THEN
      avp$end_subutility_session (record_id, rewrite_record, validation_file_information, status);
      IF (NOT status.normal) AND (status.condition = ave$unknown_record) THEN
        status.normal := TRUE;
      IFEND;
    ELSE
      avp$end_subutility_session (record_id, rewrite_record, validation_file_information, ignore_status);
    IFEND;

{ Restore default values.

    default_account := current_subutility_session_info^.previous_account_default;
    default_project := current_subutility_session_info^.previous_project_default;
    default_user := current_subutility_session_info^.previous_user_default;

{ Release the subutility session information.

    previous_session_information := current_subutility_session_info^.previous_session_information;
    FREE current_subutility_session_info;
    current_subutility_session_info := previous_session_information;

    display_subutility_message (current_subutility_session_info);

  PROCEND create_change_subutility;
?? OLDTITLE ??
?? NEWTITLE := 'display_integer', EJECT ??

{ PURPOSE:
{   This procedure is used to format an integer for display and write it to a
{   report along with a specified title.

  PROCEDURE display_integer
    (    title: string ( * <= osc$max_string_size);
         integer_value: integer;
         field_size: ost$string_size;
         radix: 2 .. 16;
         display_radix: boolean;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      index: ost$string_size,
      integer_string: ^string ( * );

    status.normal := TRUE;

    PUSH integer_string: [field_size];

    clp$put_partial_display (display_control, title, clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (integer_value, radix, display_radix, ' ', integer_string^, status);
    IF NOT status.normal THEN
      IF status.condition = cle$string_too_short THEN

{ If the number will not fit in the specified field width, fill the field with
{ asterisks.

        status.normal := TRUE;
        FOR index := 1 TO #SIZE (integer_string^) DO
          integer_string^ (index) := '*';
        FOREND;
      ELSE
        RETURN;
      IFEND;
    IFEND;
    clp$put_partial_display (display_control, integer_string^, clc$trim, amc$terminate, status);

  PROCEND display_integer;
?? OLDTITLE ??
?? NEWTITLE := 'display_labeled_names', EJECT ??

{ PURPOSE:
{   This procedure is used to format a list of names for display and write it to
{   a report along with a specified title.

  PROCEDURE display_labeled_names
    (    title: string ( *  <= osc$max_string_size);
         labeled_names: ^avt$labeled_names_list;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      index: avt$name_list_size,
      index2: avt$name_list_size,
      title_filler: ^string ( * );

    status.normal := TRUE;

    FOR index := 1 TO UPPERBOUND (labeled_names^) DO
      IF index = 1 THEN
        clp$put_partial_display (display_control, title, clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, ': (', clc$no_trim, amc$continue, status);
      ELSE
        PUSH title_filler: [#SIZE (title) + 3];
        title_filler^ := ' ';
        clp$put_partial_display (display_control, title_filler^, clc$no_trim, amc$start, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '(', clc$no_trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, labeled_names^ [index].label^, clc$trim, amc$continue,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      PUSH title_filler: [#SIZE (title) + clp$trimmed_string_size (labeled_names^ [index].label^) + 6];
      title_filler^ := ' ';

      clp$put_partial_display (display_control, ' (', clc$no_trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      FOR index2 := 1 TO UPPERBOUND (labeled_names^ [index].names^) DO
        clp$put_partial_display (display_control, labeled_names^ [index].names^ [index2], clc$trim,
              amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF index2 < UPPERBOUND (labeled_names^ [index].names^) THEN
          clp$put_partial_display (display_control, ' ..', clc$no_trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, title_filler^, clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          clp$put_partial_display (display_control, '))', clc$no_trim, amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF index < UPPERBOUND (labeled_names^) THEN
            clp$put_partial_display (display_control, ' ..', clc$no_trim, amc$terminate, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      FOREND;
    FOREND;
    clp$put_partial_display (display_control, ')', clc$trim, amc$terminate, status);

  PROCEND display_labeled_names;
?? OLDTITLE ??
?? NEWTITLE := 'display_limit_value', EJECT ??

{ PURPOSE:
{   This procedure is used to format a limit value for display and write it to a
{   report along with a specified title.

  PROCEDURE display_limit_value
    (    title: string ( * <= osc$max_string_size);
         limit_value: avt$limit_value;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    status.normal := TRUE;

    IF limit_value = sfc$unlimited THEN
      clp$put_partial_display (display_control, title, clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_partial_display (display_control, ' UNLIMITED', clc$no_trim, amc$terminate, status);
    ELSE
      IF limit_value < 10000000000 THEN
        display_integer (title, limit_value, 10, 10, FALSE, display_control, status);
      ELSE
        display_integer (title, limit_value, 20, 10, FALSE, display_control, status);
      IFEND;
    IFEND;

  PROCEND display_limit_value;
?? OLDTITLE ??
?? NEWTITLE := 'display_list_of_names', EJECT ??

{ PURPOSE:
{   This procedure is used to format a list of names for display and write it to
{   a report along with a specified title.

  PROCEDURE display_list_of_names
    (    title: string ( * <= osc$max_string_size);
         number_of_names: avt$name_list_size;
         name_list: ^avt$name_list;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      index: avt$name_list_size,
      title_filler: ^string ( * );

    status.normal := TRUE;

    PUSH title_filler: [#SIZE (title) + 3];
    title_filler^ := ' ';

    clp$put_partial_display (display_control, title, clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF number_of_names > 1 THEN
      clp$put_partial_display (display_control, ': (', clc$no_trim, amc$continue, status);
    ELSE
      clp$put_partial_display (display_control, ':  ', clc$no_trim, amc$continue, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR index := 1 TO number_of_names DO
      clp$put_partial_display (display_control, name_list^ [index], clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF index < number_of_names THEN
        clp$put_partial_display (display_control, ' ..', clc$no_trim, amc$terminate, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, title_filler^, clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;
    IF number_of_names > 1 THEN
      clp$put_partial_display (display_control, ')', clc$trim, amc$terminate, status);
    IFEND

  PROCEND display_list_of_names;
?? OLDTITLE ??
?? NEWTITLE := 'display_selected_fields', EJECT ??

{ PURPOSE:
{   This procedure displays the values of the specified fields.
{
{ NOTES:
{   If the field name list contains the name 'CAPABILITIES', all of the
{   all of the capabilities included in the data record will be displayed
{   as a list of names.

  PROCEDURE display_selected_fields
    (    title: string ( * <= osc$max_string_size);
         field_names: ^array [1 .. * ] of ost$name;
         validation_record_name: ost$name;
         record_id: ost$name;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      capability: boolean,
      capability_field_count: avt$field_count,
      capability_field_index: avt$field_count,
      capability_field_names: array [1 .. avc$maximum_field_count] of ost$name,
      capability_name: ^ost$name,
      capability_name_list: ^avt$name_list,
      capability_name_list_size: avt$name_list_size,
      field_kind: avt$field_kind,
      field_names_index: 1 .. avc$maximum_field_count,
      ignore_status: ost$status,
      name_list_work_area: ^SEQ ( * );

?? NEWTITLE := 'display_account_project_field', EJECT ??

    PROCEDURE display_account_project_field
      (    field_name: ost$name;
           record_id: ost$name;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      VAR
        account: avt$account_name,
        project: avt$project_name;

      status.normal := TRUE;

      avp$get_acct_proj_display_value (field_name, record_id, account, project, status);
      IF status.normal THEN
        clp$put_partial_display (display_control, '    Account: ', clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, account, clc$trim, amc$terminate, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_partial_display (display_control, '    Project: ', clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, project, clc$trim, amc$terminate, status);
      ELSEIF status.condition = ave$insufficient_authority THEN
        status.normal := TRUE;
        clp$put_display (display_control, '    Not authorized to display value.', clc$trim, status);
      IFEND;

    PROCEND display_account_project_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_accum_limit_field', EJECT ??

    PROCEDURE display_accum_limit_field
      (    field_name: ost$name;
           record_id: ost$name;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      VAR
        display_format: avt$numeric_display_format,
        job_limit_information: avt$job_limit_information,
        total_limit_information: avt$total_limit_information;

      status.normal := TRUE;

      avp$get_accum_limit_display_val (field_name, record_id, job_limit_information, total_limit_information,
            display_format, status);
      IF status.normal THEN
        IF job_limit_information.job_limits_apply THEN
          display_limit_value ('    Job warning limit:  ', job_limit_information.job_warning_limit,
                display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          display_limit_value ('    Job maximum limit:  ', job_limit_information.job_maximum_limit,
                display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF total_limit_information.total_limit_applies THEN
          display_limit_value ('    Total limit:        ', total_limit_information.total_limit,
                display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          display_limit_value ('    Total accumulation: ', total_limit_information.total_accumulation,
                display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      ELSEIF status.condition = ave$insufficient_authority THEN
        status.normal := TRUE;
        clp$put_display (display_control, '    Not authorized to display value.', clc$trim, status);
      IFEND;

    PROCEND display_accum_limit_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_capability_field', EJECT ??

    PROCEDURE display_capability_field
      (    field_name: ost$name;
           record_id: ost$name;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      VAR
        value: boolean;

      status.normal := TRUE;

      avp$get_capabil_display_value (field_name, record_id, value, status);
      IF status.normal THEN
        IF value THEN
          clp$put_partial_display (display_control, '    Value: INCLUDE', clc$no_trim, amc$start, status);
        ELSE
          clp$put_partial_display (display_control, '    Value: EXCLUDE', clc$no_trim, amc$start, status);
        IFEND;
      ELSEIF status.condition = ave$insufficient_authority THEN
        status.normal := TRUE;
        clp$put_display (display_control, '    Not authorized to display value.', clc$trim, status);
      IFEND;

    PROCEND display_capability_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_date_time_field', EJECT ??

    PROCEDURE display_date_time_field
      (    field_name: ost$name;
           record_id: ost$name;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      VAR
        date_display_format: string (clc$max_date_time_form_string),
        date_time: avt$date_time,
        formatted_date_time: ost$string,
        time_display_format: string (clc$max_date_time_form_string);

      status.normal := TRUE;

      avp$get_date_time_display_value (field_name, record_id, date_time, date_display_format,
            time_display_format, status);
      IF status.normal THEN
        clp$put_partial_display (display_control, '   Value: ', clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF date_time.range THEN
          format_date_time (date_time.starting_value, date_time.date_specified, date_display_format,
                date_time.time_specified, time_display_format, formatted_date_time, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, formatted_date_time.value, clc$trim, amc$continue,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, ' .. ', clc$no_trim, amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          format_date_time (date_time.ending_value, date_time.date_specified, date_display_format,
                date_time.time_specified, time_display_format, formatted_date_time, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, formatted_date_time.value, clc$trim, amc$continue,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          format_date_time (date_time.value, date_time.date_specified, date_display_format,
                date_time.time_specified, time_display_format, formatted_date_time, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, formatted_date_time.value, clc$trim, amc$continue,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      ELSEIF status.condition = ave$insufficient_authority THEN
        status.normal := TRUE;
        clp$put_display (display_control, '    Not authorized to display value.', clc$trim, status);
      IFEND;

    PROCEND display_date_time_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_file_field', EJECT ??

    PROCEDURE display_file_field
      (    field_name: ost$name;
           record_id: ost$name;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      VAR
        value: string (fsc$max_path_size);

      status.normal := TRUE;

      avp$get_file_display_value (field_name, record_id, value, status);
      IF status.normal THEN
        clp$put_partial_display (display_control, '    Value: ', clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, value, clc$trim, amc$terminate, status);
      ELSEIF status.condition = ave$insufficient_authority THEN
        status.normal := TRUE;
        clp$put_display (display_control, '    Not authorized to display value.', clc$trim, status);
      IFEND;

    PROCEND display_file_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_integer_field', EJECT ??

    PROCEDURE display_integer_field
      (    field_name: ost$name;
           record_id: ost$name;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      VAR
        value: integer,
        display_format: avt$numeric_display_format;

      status.normal := TRUE;

      avp$get_integer_display_value (field_name, record_id, value, display_format, status);
      IF status.normal THEN
        display_integer ('    Value: ', value, display_format.field_size, display_format.radix,
              display_format.display_radix, display_control, status);
      ELSEIF status.condition = ave$insufficient_authority THEN
        status.normal := TRUE;
        clp$put_display (display_control, '    Not authorized to display value.', clc$trim, status);
      IFEND;

    PROCEND display_integer_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_job_class_field', EJECT ??

    PROCEDURE display_job_class_field
      (    field_name: ost$name;
           record_id: ost$name;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      VAR
        batch_job_class_default: ost$name,
        job_classes: ^avt$name_list,
        interactive_job_class_default: ost$name,
        number_of_job_classes: avt$name_list_size;

      status.normal := TRUE;

      PUSH job_classes: [1 .. avc$maximum_name_list_size];

      avp$get_job_class_display_value (field_name, record_id, job_classes^, number_of_job_classes,
            batch_job_class_default, interactive_job_class_default, status);
      IF status.normal THEN
        display_list_of_names ('    Job classes', number_of_job_classes, job_classes, display_control,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_partial_display (display_control, '    Interactive default: ', clc$no_trim, amc$start,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_partial_display (display_control, interactive_job_class_default, clc$trim, amc$terminate,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_partial_display (display_control, '    Batch default: ', clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_partial_display (display_control, batch_job_class_default, clc$trim, amc$terminate, status);
      ELSEIF status.condition = ave$insufficient_authority THEN
        status.normal := TRUE;
        clp$put_display (display_control, '    Not authorized to display value.', clc$trim, status);
      IFEND;

    PROCEND display_job_class_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_labeled_names_field', EJECT ??

    PROCEDURE display_labeled_names_field
      (    field_name: ost$name;
           record_id: ost$name;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      VAR
        labeled_names: ^avt$labeled_names_list,
        work_area: ^seq (*);

      status.normal := TRUE;

      PUSH work_area: [[REP avc$max_template_record_size OF cell]];
      RESET work_area;
      avp$get_labeled_names_dis_value (field_name, record_id, work_area, labeled_names, status);
      IF status.normal THEN
        display_labeled_names ('    Value', labeled_names, display_control, status);
      ELSEIF status.condition = ave$insufficient_authority THEN
        status.normal := TRUE;
        clp$put_display (display_control, '    Not authorized to display value.', clc$trim, status);
      IFEND;

    PROCEND display_labeled_names_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_limit_field', EJECT ??

    PROCEDURE display_limit_field
      (    field_name: ost$name;
           record_id: ost$name;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      VAR
        display_format: avt$numeric_display_format,
        limit_value: avt$limit_value;

      status.normal := TRUE;

      avp$get_limit_display_value (field_name, record_id, limit_value, display_format, status);
      IF status.normal THEN
        display_limit_value ('    Value:  ', limit_value, display_control, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSEIF status.condition = ave$insufficient_authority THEN
        status.normal := TRUE;
        clp$put_display (display_control, '    Not authorized to display value.', clc$trim, status);
      IFEND;

    PROCEND display_limit_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_login_password_field', EJECT ??

    PROCEDURE display_login_password_field
      (    field_name: ost$name;
           record_id: ost$name;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      VAR
        attributes: ^avt$name_list,
        change_date: ost$date_time,
        date_time_to_format: clt$date_time,
        display_format: ^clt$date_time_form_string,
        expiration_date: ost$date_time,
        expiration_interval: pmt$time_increment,
        expiration_warning_interval: pmt$time_increment,
        exp_password_change_interval: pmt$time_increment,
        formatted_date_time: ost$string,
        max_expiration_interval: pmt$time_increment,
        number_of_attributes: avt$name_list_size;

      status.normal := TRUE;

      PUSH attributes: [1 .. avc$maximum_name_list_size];

      avp$get_login_pw_display_value (field_name, record_id, expiration_date, expiration_interval,
            max_expiration_interval, expiration_warning_interval, exp_password_change_interval, change_date,
            attributes^, number_of_attributes, status);
      IF status.normal THEN
        clp$put_partial_display (display_control, '    Expiration date: ', clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF expiration_date.year = UPPERVALUE (expiration_date.year) THEN
          clp$put_partial_display (display_control, 'None', clc$trim, amc$terminate, status);
        ELSE
          date_time_to_format.value := expiration_date;
          date_time_to_format.date_specified := TRUE;
          date_time_to_format.time_specified := TRUE;


          PUSH display_format: [clc$max_date_time_form_string];
          display_format^ := avc$iso_date_format;
          display_format^ (clp$trimmed_string_size (display_format^) + 1, * ) := '.';
          display_format^ (clp$trimmed_string_size (display_format^) + 1, * ) := avc$hms_time_format;

          clp$convert_date_time_to_string (date_time_to_format, display_format^, formatted_date_time, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, formatted_date_time.value (1, formatted_date_time.size),
                clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        display_time_increment ('    Expiration interval: ', expiration_interval, display_control, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        display_time_increment ('    Maximum expiration interval: ', max_expiration_interval, display_control,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        display_time_increment ('    Expiration warning interval: ', expiration_warning_interval,
              display_control, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_partial_display (display_control, '    Change date: ', clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF change_date.year = LOWERVALUE (change_date.year) THEN
          clp$put_partial_display (display_control, 'Unknown', clc$trim, amc$terminate, status);
        ELSE
          date_time_to_format.value := change_date;
          date_time_to_format.date_specified := TRUE;
          date_time_to_format.time_specified := TRUE;


          PUSH display_format: [clc$max_date_time_form_string];
          display_format^ := avc$iso_date_format;
          display_format^ (clp$trimmed_string_size (display_format^) + 1, * ) := '.';
          display_format^ (clp$trimmed_string_size (display_format^) + 1, * ) := avc$hms_time_format;

          clp$convert_date_time_to_string (date_time_to_format, display_format^, formatted_date_time, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, formatted_date_time.value (1, formatted_date_time.size),
                clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        display_list_of_names ('    Password attributes', number_of_attributes, attributes, display_control,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSEIF status.condition = ave$insufficient_authority THEN
        status.normal := TRUE;
        clp$put_display (display_control, '    Not authorized to display value.', clc$trim, status);
      IFEND;

    PROCEND display_login_password_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_name_field', EJECT ??

    PROCEDURE display_name_field
      (    field_name: ost$name;
           record_id: ost$name;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      VAR
        names: ^avt$name_list,
        number_of_names: avt$name_list_size;

      status.normal := TRUE;

      PUSH names: [1 .. avc$maximum_name_list_size];

      avp$get_name_display_value (field_name, record_id, names^, number_of_names, status);
      IF status.normal THEN
        display_list_of_names ('    Value', number_of_names, names, display_control, status);
      ELSEIF status.condition = ave$insufficient_authority THEN
        status.normal := TRUE;
        clp$put_display (display_control, '    Not authorized to display value.', clc$trim, status);
      IFEND;

    PROCEND display_name_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_real_field', EJECT ??

    PROCEDURE display_real_field
      (    field_name: ost$name;
           record_id: ost$name;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      VAR
        value: real,
        display_format: avt$numeric_display_format,
        numeric_string: string (osc$max_string_size),
        numeric_string_size: integer;

      status.normal := TRUE;

      avp$get_real_display_value (field_name, record_id, value, display_format, status);
      IF status.normal THEN
        clp$put_partial_display (display_control, '    Value: ', clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        CASE display_format.kind OF
        = avc$fixed_point_format =
          STRINGREP (numeric_string, numeric_string_size, value: display_format.field_size: display_format.
                fraction_size);
          clp$put_partial_display (display_control, numeric_string (1, numeric_string_size), clc$trim,
                amc$terminate, status);
        = avc$floating_point_format =
          STRINGREP (numeric_string, numeric_string_size, value: display_format.field_size);
          clp$put_partial_display (display_control, numeric_string (1, numeric_string_size), clc$trim,
                amc$terminate, status);
        CASEND;
      ELSEIF status.condition = ave$insufficient_authority THEN
        status.normal := TRUE;
        clp$put_display (display_control, '    Not authorized to display value.', clc$trim, status);
      IFEND;

    PROCEND display_real_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_ring_privilege_field', EJECT ??

    PROCEDURE display_ring_privilege_field
      (    field_name: ost$name;
           record_id: ost$name;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      VAR
        minimum_ring: ost$ring,
        nominal_ring: ost$ring,
        integer_value: integer;

      status.normal := TRUE;

      avp$get_ring_priv_display_value (field_name, record_id, minimum_ring, nominal_ring, status);
      IF status.normal THEN
        integer_value := minimum_ring;
        display_integer ('    Minimum ring: ', integer_value, 3, 10, FALSE, display_control, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        integer_value := nominal_ring;
        display_integer ('    Nominal ring: ', integer_value, 3, 10, FALSE, display_control, status);
      ELSEIF status.condition = ave$insufficient_authority THEN
        status.normal := TRUE;
        clp$put_display (display_control, '    Not authorized to display value.', clc$trim, status);
      IFEND;

    PROCEND display_ring_privilege_field;
?? OLDTITLE ??
?? NEWTITLE := 'display_string_field', EJECT ??

    PROCEDURE display_string_field
      (    field_name: ost$name;
           record_id: ost$name;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      VAR
        string_value: ost$string;

      status.normal := TRUE;

      avp$get_string_display_value (field_name, record_id, string_value, status);
      IF status.normal THEN
        clp$put_partial_display (display_control, '    Value: ', clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_partial_display (display_control, '''', clc$trim, amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, string_value.value (1, string_value.size), clc$no_trim,
              amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, '''', clc$trim, amc$terminate, status);
      ELSEIF status.condition = ave$insufficient_authority THEN
        status.normal := TRUE;
        clp$put_display (display_control, '    Not authorized to display value.', clc$trim, status);
      IFEND;

    PROCEND display_string_field;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    IF field_names <> NIL THEN
      clp$put_display (display_control, ' ', clc$no_trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    clp$put_display (display_control, title, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF field_names <> NIL THEN
      FOR field_names_index := 1 TO UPPERBOUND (field_names^) DO
        IF (field_names^ [field_names_index] <> 'CAPABILITIES') AND (field_names^ [field_names_index] <>
              'CAPABILITY') THEN
          clp$put_partial_display (display_control, '  ', clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, field_names^ [field_names_index], clc$trim, amc$terminate,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          avp$get_validation_field_kind (field_names^ [field_names_index], validation_record_name, field_kind,
                validation_file_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          CASE field_kind OF
          = avc$account_project_kind =
            display_account_project_field (field_names^ [field_names_index], record_id, display_control,
                  status);
          = avc$accumulating_limit_kind =
            display_accum_limit_field (field_names^ [field_names_index], record_id, display_control, status);
          = avc$capability_kind =
            display_capability_field (field_names^ [field_names_index], record_id, display_control, status);
          = avc$date_time_kind =
            display_date_time_field (field_names^ [field_names_index], record_id, display_control, status);
          = avc$file_kind =
            display_file_field (field_names^ [field_names_index], record_id, display_control, status);
          = avc$integer_kind =
            display_integer_field (field_names^ [field_names_index], record_id, display_control, status);
          = avc$job_class_kind =
            display_job_class_field (field_names^ [field_names_index], record_id, display_control, status);
          = avc$keyword_kind =

{ keywords are not implemented yet.

          = avc$labeled_names_kind =
            display_labeled_names_field (field_names^ [field_names_index], record_id, display_control,
                  status);
          = avc$limit_kind =
            display_limit_field (field_names^ [field_names_index], record_id, display_control, status);
          = avc$login_password_kind =
            display_login_password_field (field_names^ [field_names_index], record_id, display_control,
                  status);
          = avc$name_kind =
            display_name_field (field_names^ [field_names_index], record_id, display_control, status);
          = avc$real_kind =
            display_real_field (field_names^ [field_names_index], record_id, display_control, status);
          = avc$ring_privilege_kind =
            display_ring_privilege_field (field_names^ [field_names_index], record_id, display_control,
                  status);
          = avc$string_kind =
            display_string_field (field_names^ [field_names_index], record_id, display_control, status);
          ELSE
            clp$put_partial_display (display_control, '    Field type: unknown', clc$no_trim, amc$start,
                  status);
          CASEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          clp$put_display (display_control, '  CAPABILITIES', clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          avp$get_validation_field_names (validation_record_name, $avt$field_kind_set [avc$capability_kind],
                FALSE, capability_field_names, capability_field_count, validation_file_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          PUSH name_list_work_area: [[REP avc$maximum_field_count OF ost$name]];
          RESET name_list_work_area;
          capability_name_list_size := 0;

          FOR capability_field_index := 1 TO capability_field_count DO
            avp$get_capabil_display_value (capability_field_names [capability_field_index], record_id,
                  capability, status);
            IF NOT status.normal THEN
              IF status.condition = ave$insufficient_authority THEN
                status.normal := TRUE;
                capability := FALSE;
              ELSE
                RETURN;
              IFEND;
            IFEND;

            IF capability THEN
              NEXT capability_name IN name_list_work_area;
              capability_name^ := capability_field_names [capability_field_index];
              capability_name_list_size := capability_name_list_size + 1;
            IFEND;
          FOREND;
          IF capability_name_list_size <> 0 THEN
            RESET name_list_work_area;
            NEXT capability_name_list: [1 .. capability_name_list_size] IN name_list_work_area;
          ELSE
            capability_name_list := NIL;
          IFEND;
          display_list_of_names ('    Value', capability_name_list_size, capability_name_list,
                display_control, status);
        IFEND;
      FOREND;
    IFEND;

  PROCEND display_selected_fields;
?? OLDTITLE ??
?? NEWTITLE := 'display_time_increment', EJECT ??

{ PURPOSE:
{   This procedure is used to format a time increment for display and write it
{   to a report along with a specified title.

  PROCEDURE display_time_increment
    (    title: string ( * <= osc$max_string_size);
         time_increment: pmt$time_increment;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      numeric_string: ost$string;

    status.normal := TRUE;

    clp$put_partial_display (display_control, title, clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF time_increment.day = UPPERVALUE (time_increment.day) THEN
      clp$put_partial_display (display_control, 'Unlimited', clc$trim, amc$terminate, status);
    ELSE
      IF time_increment.day < 0 THEN
        clp$convert_integer_to_string (-time_increment.day, 10, FALSE, numeric_string, status);
      ELSE
        clp$convert_integer_to_string (time_increment.day, 10, FALSE, numeric_string, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_partial_display (display_control, numeric_string.value (1, numeric_string.size), clc$trim,
            amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_partial_display (display_control, ' days', clc$trim, amc$terminate, status);
    IFEND;

  PROCEND display_time_increment;
?? OLDTITLE ??
?? NEWTITLE := 'format_date_time', EJECT ??

{ PURPOSE:
{   This procedure is used to format a date time value for display.

  PROCEDURE format_date_time
    (    date_time: ost$date_time;
         date_specified: boolean;
         date_display_format: clt$date_time_form_string;
         time_specified: boolean;
         time_display_format: clt$date_time_form_string;
     VAR formatted_date_time: ost$string;
     VAR status: ost$status);

    VAR
      date_time_to_format: clt$date_time,
      default_date_display_format: ost$default_date_format,
      default_time_display_format: ost$default_time_format,
      display_format: string (clc$max_date_time_form_string);

    status.normal := TRUE;

    date_time_to_format.value := date_time;
    date_time_to_format.date_specified := date_specified;
    date_time_to_format.time_specified := time_specified;

    IF (date_display_format = ' ') OR (time_display_format = ' ') THEN
      pmp$get_default_date_time_form (default_date_display_format, default_time_display_format);
    IFEND;

    IF date_specified AND time_specified THEN
      IF date_display_format = ' ' THEN
        display_format := default_date_display_format.format_string;
      ELSE
        display_format := date_display_format;
      IFEND;
      IF time_display_format = ' ' THEN
        display_format (clp$trimmed_string_size (display_format) + 2, * ) :=
              default_time_display_format.format_string;
      ELSE
        display_format (clp$trimmed_string_size (display_format) + 2, * ) := time_display_format;
      IFEND;
    ELSEIF date_specified THEN
      IF date_display_format = ' ' THEN
        display_format := default_date_display_format.format_string;
      ELSE
        display_format := date_display_format;
      IFEND;
    ELSE
      IF time_display_format = ' ' THEN
        display_format := default_time_display_format.format_string;
      ELSE
        display_format := time_display_format;
      IFEND;
    IFEND;

    clp$convert_date_time_to_string (date_time_to_format,
          display_format (1, clp$trimmed_string_size(display_format)), formatted_date_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND format_date_time;
?? OLDTITLE ??
?? NEWTITLE := 'get_data_record_display_options', EJECT ??

{ PURPOSE:
{   This procedure returns a list of display options based the value of the
{   DISPLAY_OPTIONS parameter on all of the data record display commands.  It
{   also verifies that the specified display options are correct.

  PROCEDURE get_data_record_display_options
    (    validation_record_name: ost$name;
         parameter_value: ^clt$data_value;
     VAR display_option_work_area: ^SEQ ( * );
     VAR display_option_list: ^array [1 .. * ] of ost$name;
     VAR status: ost$status);

    VAR
      display_option: ^ost$name,
      display_option_count: avt$field_count,
      display_option_index: avt$field_count,
      display_option_parameter_value: ^clt$data_value,
      field_name_count: avt$field_count,
      field_name_index: avt$field_count,
      field_name_list: array [1 .. avc$maximum_field_count] of ost$name,
      first_display_option: ^ost$name,
      ignore_status: ost$status;

    status.normal := TRUE;

{ Get the list of field names excluding capabilitiy fields.

    avp$get_validation_field_names (validation_record_name, -$avt$field_kind_set [avc$capability_kind], FALSE,
          field_name_list, field_name_count, validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Go through the list of fields that were specified.

    IF parameter_value^.kind = clc$keyword THEN
      IF parameter_value^.keyword_value = 'NONE' THEN
        display_option_count := 0;
        display_option_list := NIL;
      ELSE { ALL }

{ Return a list composed of all the field names retieved earlier and insert the CAPABILITIES into the
{ appropriate place.

        NEXT display_option_list: [1 .. field_name_count + 1] IN display_option_work_area;
        IF display_option_list = NIL THEN
          osp$set_status_abnormal ('AV', ave$work_area_full, 'DISPLAY_OPTION_WORK_AREA', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'GET_DISPLAY_OPTIONS', status);
          RETURN;
        IFEND;
        display_option_count := field_name_count + 1;
        display_option_index := 1;
        FOR field_name_index := 1 TO field_name_count DO
          IF (display_option_index = field_name_index) AND (field_name_list [field_name_index] >
                'CAPABILITIES') THEN
            display_option_list^ [display_option_index] := 'CAPABILITIES';
            display_option_index := display_option_index + 1;
          IFEND;
          display_option_list^ [display_option_index] := field_name_list [field_name_index];
          display_option_index := display_option_index + 1;
        FOREND;
        IF display_option_index = display_option_count THEN
          display_option_list^ [display_option_index] := 'CAPABILITIES';
        IFEND;
      IFEND;
    ELSE

{ Build an array containing each of the specified field names and check that the specified field
{ name exist.

      display_option_parameter_value := parameter_value;
      first_display_option := NIL;
      display_option_count := 0;
      REPEAT
        NEXT display_option IN display_option_work_area;
        IF display_option = NIL THEN
          osp$set_status_abnormal ('AV', ave$work_area_full, 'DISPLAY_OPTION_WORK_AREA', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'GET_DISPLAY_OPTIONS', status);
          RETURN;
        IFEND;
        IF first_display_option = NIL THEN
          first_display_option := display_option;
        IFEND;
        display_option_count := display_option_count + 1;
        display_option^ := display_option_parameter_value^.element_value^.name_value;

        IF (display_option^ <> 'CAPABILITIES') AND (display_option^ <> 'CAPABILITY') THEN
          osp$set_status_abnormal ('AV', ave$unknown_display_option, display_option^, status);

        /check_display_option/
          FOR field_name_index := 1 TO field_name_count DO
            IF field_name_list [field_name_index] = display_option^ THEN
              status.normal := TRUE;
              EXIT /check_display_option/;
            IFEND;
          FOREND /check_display_option/;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        display_option_parameter_value := display_option_parameter_value^.link;
      UNTIL display_option_parameter_value = NIL;

      RESET display_option_work_area TO first_display_option;
      NEXT display_option_list: [1 .. display_option_count] IN display_option_work_area;
      IF display_option_list = NIL THEN
        osp$set_status_abnormal ('AV', ave$work_area_full, 'DISPLAY_OPTION_WORK_AREA', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'GET_DISPLAY_OPTIONS', status);
        RETURN;
      IFEND;
    IFEND;

  PROCEND get_data_record_display_options;
?? OLDTITLE ??
?? NEWTITLE := 'hide_authority_keywords', EJECT ??

  PROCEDURE [INLINE] hide_authority_keywords
    (    pdt: ^clt$parameter_description_table;
         pdt_changes: ^clt$pdt_changes;
         validation_record_name: ost$name;
     VAR altered_pdt: ^clt$parameter_description_table;
     VAR status: ost$status);

    VAR
      index: integer,
      keyword_type_changes: ^clt$type_changes;

{ Make a copy of the PDT so it can be altered.

    PUSH altered_pdt: [[REP #SIZE (pdt^) OF cell]];
    RESET altered_pdt;
    altered_pdt^ := pdt^;

    PUSH keyword_type_changes: [1 .. 4];
    keyword_type_changes^ [1].kind := clc$tc_keyword_availability;
    keyword_type_changes^ [1].keyword := 'USER_ADMINISTRATION            ';
    keyword_type_changes^ [2].kind := clc$tc_keyword_availability;
    keyword_type_changes^ [2].keyword := 'ACCOUNT_ADMINISTRATION         ';
    keyword_type_changes^ [3].kind := clc$tc_keyword_availability;
    keyword_type_changes^ [3].keyword := 'PROJECT_ADMINISTRATION         ';
    keyword_type_changes^ [4].kind := clc$tc_keyword_availability;
    keyword_type_changes^ [4].keyword := 'USER                           ';
    IF validation_record_name = avc$user_record_name THEN
      keyword_type_changes^ [1].availability := clc$normal_usage_entry;
      keyword_type_changes^ [2].availability := clc$hidden_entry;
      keyword_type_changes^ [3].availability := clc$hidden_entry;
      keyword_type_changes^ [4].availability := clc$normal_usage_entry;
    ELSEIF (validation_record_name = avc$account_record_name) OR
          (validation_record_name = avc$account_member_record_name) THEN
      keyword_type_changes^ [1].availability := clc$hidden_entry;
      keyword_type_changes^ [2].availability := clc$normal_usage_entry;
      keyword_type_changes^ [3].availability := clc$hidden_entry;
      keyword_type_changes^ [4].availability := clc$hidden_entry;
    ELSE
      keyword_type_changes^ [1].availability := clc$hidden_entry;
      keyword_type_changes^ [2].availability := clc$normal_usage_entry;
      keyword_type_changes^ [3].availability := clc$normal_usage_entry;
      keyword_type_changes^ [4].availability := clc$hidden_entry;
    IFEND;

    FOR index := 1 TO UPPERBOUND (pdt_changes^) DO
      pdt_changes^ [index].kind := clc$pdtc_type;
      pdt_changes^ [index].type_changes := keyword_type_changes;
    FOREND;

    clp$change_pdt (altered_pdt, pdt_changes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND hide_authority_keywords;
?? OLDTITLE ??
?? NEWTITLE := 'make_scl_name_list_element', EJECT ??

{ PURPOSE:
{   This procedure is used to construct an entry in an SCL list of names.

  PROCEDURE make_scl_name_list_element
    (    name_value: ost$name;
     VAR work_area: ^clt$work_area;
     VAR list_element: ^clt$data_value;
     VAR status: ost$status);

    status.normal := TRUE;

    clp$make_list_value (work_area, list_element);
    IF list_element = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;

    clp$make_name_value (name_value, work_area, list_element^.element_value);
    IF list_element^.element_value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;

  PROCEND make_scl_name_list_element;
?? OLDTITLE ??
?? NEWTITLE := 'manage_fields_subutility', EJECT ??

{ PURPOSE:
{   This procedure contains the common code used by the manage subutilites.

  PROCEDURE manage_fields_subutility
    (    subutility_name: string ( * <= osc$max_name_size);
         subutility_prompt: string ( * <= osc$max_name_size);
         validation_record_name: ost$name;
         command_table: ^clt$command_table;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      new_subutility_session_info: ^avt$subutility_session_info,
      previous_session_information: ^avt$subutility_session_info,
      subutility_attributes: ^clt$utility_attributes;

    status.normal := TRUE;

{ Field management subutilities may only be used by system or family administrators.

    IF NOT (avp$system_administrator () OR avp$family_administrator ()) THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Make sure a validation file is open.

    IF NOT validation_file_open THEN
      osp$set_status_abnormal ('AV', ave$no_validation_file_open, '', status);
      RETURN;
    IFEND;

{ Field management subutilities may not be used if any other ADMINISTER_VALIDATIONS subutility is currently
{ active.  This prevents the confusion that could result from changing the names of fields or deleting fields
{ while a data record change is going on.

    IF current_subutility_session_info <> NIL THEN
      osp$set_status_abnormal ('AV', ave$not_allowed_from_subutility, subutility_name, status);
      RETURN;
    IFEND;

{ Add an entry to the subutility information chain.

    ALLOCATE new_subutility_session_info;
    new_subutility_session_info^.id := osc$null_name;
    new_subutility_session_info^.rewrite_record := FALSE;
    new_subutility_session_info^.key.account_name := osc$null_name;
    new_subutility_session_info^.key.project_name := osc$null_name;
    new_subutility_session_info^.key.user_name := osc$null_name;
    new_subutility_session_info^.validation_record_name := validation_record_name;
    new_subutility_session_info^.subutility_name := subutility_name;
    new_subutility_session_info^.subutility_prompt := subutility_prompt;
    new_subutility_session_info^.previous_session_information := current_subutility_session_info;

    current_subutility_session_info := new_subutility_session_info;

{ Process the subutility subcommands.

    PUSH subutility_attributes: [1 .. 3];
    subutility_attributes^ [1].key := clc$utility_prompt;
    subutility_attributes^ [1].prompt.value := subutility_prompt;
    subutility_attributes^ [1].prompt.size := clp$trimmed_string_size
          (subutility_attributes^ [1].prompt.value);
    subutility_attributes^ [2].key := clc$utility_command_table;
    subutility_attributes^ [2].command_table := command_table;
    subutility_attributes^ [3].key := clc$utility_function_proc_table;
    subutility_attributes^ [3].function_processor_table := admv_subutil_func_table;
    clp$begin_utility (subutility_name, subutility_attributes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, '', subutility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (subutility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Release the subutility session information.

    previous_session_information := current_subutility_session_info^.previous_session_information;
    FREE current_subutility_session_info;
    current_subutility_session_info := previous_session_information;

  PROCEND manage_fields_subutility;
?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle', EJECT ??

{ PURPOSE:
{   This is a dummy subtitle procedure used by the display formatting procedures.

  PROCEDURE put_subtitle
    (VAR display_control: clt$display_control;
     VAR status: ost$status);

    status.normal := TRUE;

  PROCEND put_subtitle;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] process_authority_parameter', EJECT ??

{ PURPOSE:
{   This procedure is used to translate the value specified for a authority parameter.

  PROCEDURE [INLINE] process_authority_parameter
    (    parameter_value: ^clt$data_value;
     VAR authority: ^avt$validation_authority);

    IF parameter_value <> NIL THEN
      PUSH authority;
      IF (parameter_value^.keyword_value = 'SYSTEM') THEN
        authority^ := avc$system_authority;
      ELSEIF (parameter_value^.keyword_value = 'SYSTEM_ADMINISTRATION') THEN
        authority^ := avc$system_admin_authority;
      ELSEIF (parameter_value^.keyword_value = 'FAMILY_ADMINISTRATION') THEN
        authority^ := avc$family_admin_authority;
      ELSEIF (parameter_value^.keyword_value = 'USER_ADMINISTRATION') THEN
        authority^ := avc$user_admin_authority;
      ELSEIF (parameter_value^.keyword_value = 'ACCOUNT_ADMINISTRATION') THEN
        authority^ := avc$account_admin_authority;
      ELSEIF (parameter_value^.keyword_value = 'PROJECT_ADMINISTRATION') THEN
        authority^ := avc$project_admin_authority;
      ELSEIF (parameter_value^.keyword_value = 'USER') THEN
        authority^ := avc$user_authority;
      ELSE
        authority^ := avc$any_authority;
      IFEND;
    ELSE
      authority := NIL;
    IFEND;

  PROCEND process_authority_parameter;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] process_command_names_parameter', EJECT ??

{ PURPOSE:
{   This procedure is used to translate the value specified for a command names parameter.

  PROCEDURE [INLINE] process_command_names_parameter
    (    parameter_value: ^clt$data_value;
         field_name: ost$name;
         verb: string ( * <= osc$max_name_size);
     VAR command_names: ^avt$name_list);

    VAR
      command_name_size: ost$string_size,
      current_parameter_value: ^clt$data_value,
      field_name_size: ost$string_size,
      index: integer,
      position: ost$string_size;

    IF parameter_value <> NIL THEN
      IF parameter_value^.kind = clc$keyword THEN
        PUSH command_names: [1 .. 2];

{ Build the nominal command name by concatenating the verb with the field name (inserting an underscore
{ between them and truncating the result to match the maximum name size.

        command_names^ [1] := verb;
        command_name_size := clp$trimmed_string_size (verb);
        command_names^ [1] (command_name_size + 1, 1) := '_';
        command_names^ [1] (command_name_size + 2, * ) := field_name;

{ Build the alias for the command by concatenating the first three characters of the verb with the
{ first letter of each word in the field name.

        command_names^ [2] := verb;
        command_names^ [2] := command_names^ [2] (1, 3);
        field_name_size := clp$trimmed_string_size (field_name);
        command_name_size := clp$trimmed_string_size (command_names^ [2]);
        IF field_name (1, 1) <> '_' THEN
          command_names^ [2] (command_name_size + 1, 1) := field_name (1, 1);
          command_name_size := command_name_size + 1;
        IFEND;
        position := 2;
        WHILE position < field_name_size DO
          IF (field_name (position, 1) = '_') AND (field_name (position + 1, 1) <> '_') THEN
            command_names^ [2] (command_name_size + 1, 1) := field_name (position + 1, 1);
            command_name_size := command_name_size + 1;
            position := position + 2;
          ELSE
            position := position + 1;
          IFEND;
        WHILEND;
      ELSE { list of name }
        PUSH command_names: [1 .. clp$count_list_elements (parameter_value)];
        current_parameter_value := parameter_value;
        index := 0;
        REPEAT
          index := index + 1;
          command_names^ [index] := current_parameter_value^.element_value^.name_value;
          current_parameter_value := current_parameter_value^.link;
        UNTIL current_parameter_value = NIL;
      IFEND;
    ELSE
      command_names := NIL;
    IFEND;

  PROCEND process_command_names_parameter;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] process_description_parameter', EJECT ??

{ PURPOSE:
{   This procedure is used to translate the value specified for a description parameter.

  PROCEDURE [INLINE] process_description_parameter
    (    parameter_value: ^clt$data_value;
     VAR description: ^ost$string);

    IF parameter_value <> NIL THEN
      PUSH description;
      description^.value := parameter_value^.string_value^;
      description^.size := clp$trimmed_string_size (description^.value);
    ELSE
      description := NIL;
    IFEND;

  PROCEND process_description_parameter;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] process_file_parameter', EJECT ??

{ PURPOSE:
{   This procedure is used to translate the value specified for a file parameter.

  PROCEDURE [INLINE] process_file_parameter
    (    parameter_value: ^clt$data_value;
         default_value: ^fst$file_reference;
     VAR file_reference: ^fst$file_reference);

    IF parameter_value <> NIL THEN
      CASE parameter_value^.kind OF
      = clc$file =
        file_reference := parameter_value^.file_value;
      = clc$keyword =
        IF parameter_value^.keyword_value = 'DEFAULT' THEN
          file_reference := default_value;
        ELSE
          PUSH file_reference: [clp$trimmed_string_size (clc$null_file)];
          file_reference^ := clc$null_file;
        IFEND;
      = clc$string =
        file_reference := parameter_value^.string_value;
      CASEND;
    ELSE
      file_reference := NIL;
    IFEND;

  PROCEND process_file_parameter;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] process_labeled_names_parameter', EJECT ??

{ PURPOSE:
{   This procedure is used to translate the value specified for a labeled names parameter.

  PROCEDURE [INLINE] process_labeled_names_parameter
    (    parameter_value: ^clt$data_value;
         default_labeled_names: ^avt$labeled_names_list;
     VAR labeled_names: ^avt$labeled_names_list);

    VAR
      current_parameter_value: ^clt$data_value,
      current_names_value: ^clt$data_value,
      index: avt$name_list_size,
      index2: avt$name_list_size;

    IF parameter_value <> NIL THEN
      IF parameter_value^.kind = clc$keyword THEN
        IF (parameter_value^.keyword_value = 'DEFAULT') THEN
          labeled_names := default_labeled_names;
        IFEND;
      ELSE {IF parameter_value^.kind = clc$list THEN}
        PUSH labeled_names: [1 .. clp$count_list_elements (parameter_value)];
        current_parameter_value := parameter_value;
        index := 0;
        REPEAT
          index := index + 1;
          PUSH labeled_names^ [index].label;
          labeled_names^ [index].label^ :=
                current_parameter_value^.element_value^.field_values^ [1].value^.name_value;
          current_names_value := current_parameter_value^.element_value^.field_values^ [2].value;
          IF current_names_value <> NIL THEN
            IF current_names_value^.kind = clc$keyword THEN
              PUSH labeled_names^ [index].names: [1 .. 1];
              labeled_names^ [index].names^ [1] := current_names_value^.keyword_value;
            ELSE {IF current_names_value^.kind = clc$list THEN}
              PUSH labeled_names^ [index].names: [1 .. clp$count_list_elements (current_names_value)];
              index2 := 0;
              REPEAT
                index2 := index2 + 1;
                labeled_names^ [index].names^ [index2] := current_names_value^.element_value^.name_value;
                current_names_value := current_names_value^.link;
              UNTIL current_names_value = NIL;
            IFEND;
          ELSE
            labeled_names^ [index].names := NIL;
          IFEND;
          current_parameter_value := current_parameter_value^.link;
        UNTIL current_parameter_value = NIL;
      IFEND;
    IFEND;

  PROCEND process_labeled_names_parameter;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] process_limit_appl_parameter', EJECT ??

{ PURPOSE:
{   This procedure is used to translate the value specified for a limit application parameter.

  PROCEDURE [INLINE] process_limit_appl_parameter
    (    parameter_value: ^clt$data_value;
     VAR job_limits_apply: ^boolean;
     VAR total_limit_applies: ^boolean);

    IF parameter_value <> NIL THEN
      PUSH job_limits_apply;
      PUSH total_limit_applies;
      IF parameter_value^.keyword_value = 'JOB_AND_TOTAL_LIMITS_APPLY' THEN
        job_limits_apply^ := TRUE;
        total_limit_applies^ := TRUE;
      ELSEIF parameter_value^.keyword_value = 'JOB_LIMITS_APPLY' THEN
        job_limits_apply^ := TRUE;
        total_limit_applies^ := FALSE;
      ELSE
        job_limits_apply^ := FALSE;
        total_limit_applies^ := TRUE;
      IFEND;
    ELSE
      job_limits_apply := NIL;
      total_limit_applies := NIL;
    IFEND;

  PROCEND process_limit_appl_parameter;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] process_limit_parameter', EJECT ??

{ PURPOSE:
{   This procedure is used to translate the value specified for a limit parameter.

  PROCEDURE [INLINE] process_limit_parameter
    (    parameter_value: ^clt$data_value;
         default_value: ^avt$limit_value;
     VAR limit_value: ^avt$limit_value);

    IF parameter_value <> NIL THEN
      PUSH limit_value;
      IF parameter_value^.kind = clc$keyword THEN
        IF parameter_value^.keyword_value = 'DEFAULT' THEN
          IF default_value <> NIL THEN
            limit_value^ := default_value^;
          ELSE
            limit_value := NIL;
          IFEND;
        ELSE { UNLIMITED }
          limit_value^ := sfc$unlimited;
        IFEND;
      ELSE { clc$integer }
        limit_value^ := parameter_value^.integer_value.value;
      IFEND;
    ELSE
      limit_value := NIL;
    IFEND;

  PROCEND process_limit_parameter;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] process_limit_range_parameter', EJECT ??

{ PURPOSE:
{   This procedure is used to translate the value specified for a limit value range parameter.

  PROCEDURE [INLINE] process_limit_range_parameter
    (    parameter_value: ^clt$data_value;
     VAR minimum_value: ^avt$limit_value;
     VAR maximum_value: ^avt$limit_value);

    IF parameter_value <> NIL THEN
      PUSH minimum_value;
      PUSH maximum_value;
      IF parameter_value^.low_value^.kind = clc$keyword THEN
        minimum_value^ := sfc$unlimited;
      ELSE
        minimum_value^ := parameter_value^.low_value^.integer_value.value;
      IFEND;
      IF parameter_value^.high_value^.kind = clc$keyword THEN
        maximum_value^ := sfc$unlimited;
      ELSE
        maximum_value^ := parameter_value^.high_value^.integer_value.value;
      IFEND;
    ELSE
      minimum_value := NIL;
      maximum_value := NIL;
    IFEND;

  PROCEND process_limit_range_parameter;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] process_name_list_parameter', EJECT ??

{ PURPOSE:
{   This procedure is used to translate the value specified for a list of names parameter.

  PROCEDURE [INLINE] process_name_list_parameter
    (    parameter_value: ^clt$data_value;
         default_names: ^avt$name_list;
     VAR name_list: ^avt$name_list);

    VAR
      current_parameter_value: ^clt$data_value,
      index: avt$name_list_size,
      number_of_default_names: avt$name_list_size;

    IF parameter_value <> NIL THEN
      IF parameter_value^.kind = clc$keyword THEN
        IF (parameter_value^.keyword_value = 'DEFAULT') AND (default_names <> NIL) THEN
          number_of_default_names := UPPERBOUND (default_names^);
          WHILE default_names^ [number_of_default_names] = osc$null_name DO
            number_of_default_names := number_of_default_names - 1;
          WHILEND;
          PUSH name_list: [1 .. number_of_default_names];
          FOR index := 1 TO number_of_default_names DO
            name_list^ [index] := default_names^ [index];
          FOREND;
        ELSE
          PUSH name_list: [1 .. 1];
          name_list^ [1] := parameter_value^.keyword_value;
        IFEND;
      ELSEIF parameter_value^.kind = clc$name THEN
        PUSH name_list: [1 .. 1];
        name_list^ [1] := parameter_value^.name_value;
      ELSE { list of name}
        PUSH name_list: [1 .. clp$count_list_elements (parameter_value)];
        current_parameter_value := parameter_value;
        index := 0;
        REPEAT
          index := index + 1;
          name_list^ [index] := current_parameter_value^.element_value^.name_value;
          current_parameter_value := current_parameter_value^.link;
        UNTIL current_parameter_value = NIL;
      IFEND;
    IFEND;

  PROCEND process_name_list_parameter;
?? OLDTITLE ??
?? NEWTITLE := 'translate_date_display_format', EJECT ??

{ PURPOSE:
{   This procedure translates the keyword for a date display format into an
{   actual date display format string.

  PROCEDURE translate_date_display_format
    (    date_display_format_keyword: clt$keyword;
     VAR date_display_format: ost$string);

    IF (date_display_format_keyword = 'DEFAULT') THEN
      date_display_format.value := ' ';
    ELSEIF (date_display_format_keyword = 'MONTH') THEN
      date_display_format.value := avc$month_date_format;
    ELSEIF (date_display_format_keyword = 'MONTH_DAY_YEAR') THEN
      date_display_format.value := avc$mdy_date_format;
    ELSEIF (date_display_format_keyword = 'DAY_MONTH_YEAR') THEN
      date_display_format.value := avc$dmy_date_format;
    ELSEIF (date_display_format_keyword = 'ISO_DATE') THEN
      date_display_format.value := avc$iso_date_format;
    ELSEIF (date_display_format_keyword = 'ORDINAL') THEN
      date_display_format.value := avc$ordinal_date_format;
    ELSE
      date_display_format.value := avc$mdy_date_format;
    IFEND;

    IF date_display_format.value <> ' ' THEN
      date_display_format.size := clp$trimmed_string_size (date_display_format.value);
    ELSE
      date_display_format.size := 1;
    IFEND;

  PROCEND translate_date_display_format;
?? OLDTITLE ??
?? NEWTITLE := 'translate_time_display_format', EJECT ??

{ PURPOSE:
{   This procedure translates a time display format keyword into an actual
{   time display format string.

  PROCEDURE translate_time_display_format
    (    time_display_format_keyword: clt$keyword;
     VAR time_display_format: ost$string);

    IF (time_display_format_keyword = 'DEFAULT') THEN
      time_display_format.value := ' ';
    ELSEIF (time_display_format_keyword = 'AMPM') THEN
      time_display_format.value := avc$ampm_time_format;
    ELSEIF (time_display_format_keyword = 'HOUR_MINUTE_SECOND') THEN
      time_display_format.value := avc$hms_time_format;
    ELSEIF (time_display_format_keyword = 'MILLISECOND') THEN
      time_display_format.value := avc$millisecond_time_format;
    ELSEIF (time_display_format_keyword = 'ISO_TIME') THEN
      time_display_format.value := avc$iso_time_format;
    ELSE
      time_display_format.value := avc$ampm_time_format;
    IFEND;

    IF time_display_format.value <> ' ' THEN
      time_display_format.size := clp$trimmed_string_size (time_display_format.value);
    ELSE
      time_display_format.size := 1;
    IFEND;

  PROCEND translate_time_display_format;
?? OLDTITLE ??
?? NEWTITLE := 'verify_field_names_value', EJECT ??

{ PURPOSE:
{   This procedure scans the values that were specified for a parameter that
{   is declared to be a list of names to insure that the keyword values ALL
{   and NONE are not specified with other values.  It also verifiies that the
{   names that are specified are actually the names of validation fields.

  PROCEDURE verify_field_names_value
    (    parameter_name: string ( * <= osc$max_name_size);
         parameter_value: ^clt$data_value;
         validation_record_name: ost$name;
         allowed_types: avt$field_kind_set;
     VAR status: ost$status);

    VAR
      active_field_names: ^array [1 .. * ] of ost$name,
      active_field_count: avt$field_count,
      current_parameter_value: ^clt$data_value,
      index: avt$field_count;

    status.normal := TRUE;

    IF parameter_value^.kind = clc$list THEN
      current_parameter_value := parameter_value;

{ Get the list of possible validation field names.

      PUSH active_field_names: [1 .. avc$maximum_field_count];
      avp$get_validation_field_names (validation_record_name, allowed_types, FALSE, active_field_names^,
            active_field_count, validation_file_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      REPEAT
        IF current_parameter_value^.element_value^.kind = clc$keyword THEN
          osp$set_status_abnormal ('AV', ave$must_be_used_alone,
                current_parameter_value^.element_value^.keyword_value, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, parameter_name, status);
          RETURN;
        ELSEIF current_parameter_value^.element_value^.kind = clc$name THEN
          IF (current_parameter_value^.element_value^.name_value = 'ALL') OR
                (current_parameter_value^.element_value^.name_value = 'NONE') THEN
            osp$set_status_abnormal ('AV', ave$must_be_used_alone,
                  current_parameter_value^.element_value^.name_value, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, parameter_name, status);
            RETURN;
          ELSE

          /verify_field_name/
            BEGIN
              FOR index := 1 TO active_field_count DO
                IF current_parameter_value^.element_value^.name_value = active_field_names^ [index] THEN
                  EXIT /verify_field_name/;
                IFEND;
              FOREND;
              osp$set_status_abnormal ('AV', ave$unknown_field,
                    current_parameter_value^.element_value^.name_value, status);
              RETURN;
            END /verify_field_name/
          IFEND;
        IFEND;
        current_parameter_value := current_parameter_value^.link;
      UNTIL current_parameter_value = NIL;
    IFEND;

  PROCEND verify_field_names_value;
?? OLDTITLE ??
?? NEWTITLE := 'verify_labeled_names_value', EJECT ??

{ PURPOSE:
{   This procedure scans the values that were specified for a parameter that
{   is declared to be a list of labeled names to insure that the keyword values ALL,
{   DEFAULT, and NONE are not specified with other values.

  PROCEDURE verify_labeled_names_value
    (    parameter_name: string ( * <= osc$max_name_size);
         parameter_value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      current_parameter_value: ^clt$data_value,
      list_size: clt$list_size;

    status.normal := TRUE;

    IF (parameter_value^.kind = clc$list) THEN
      list_size := clp$count_list_elements (parameter_value);
      current_parameter_value := parameter_value;
      REPEAT
        IF ((current_parameter_value^.element_value^.field_values^ [1].value^.name_value = 'ALL') OR
              (current_parameter_value^.element_value^.field_values^ [1].value^.name_value = 'NONE')) AND
              (list_size > 1) THEN
            osp$set_status_abnormal ('AV', ave$must_be_used_alone,
                  current_parameter_value^.element_value^.field_values^ [1].value^.name_value, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, parameter_name, status);
            RETURN;
        IFEND;
        IF current_parameter_value^.element_value^.field_values^ [2].value <> NIL THEN
          verify_list_of_names_value (parameter_name,
                current_parameter_value^.element_value^.field_values^ [2].value, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        current_parameter_value := current_parameter_value^.link;
      UNTIL current_parameter_value = NIL;
    IFEND;

  PROCEND verify_labeled_names_value;
?? OLDTITLE ??
?? NEWTITLE := 'verify_list_of_names_value', EJECT ??

{ PURPOSE:
{   This procedure scans the values that were specified for a parameter that
{   is declared to be a list of names to insure that the keyword values ALL,
{   DEFAULT, and NONE are not specified with other values.

  PROCEDURE verify_list_of_names_value
    (    parameter_name: string ( * <= osc$max_name_size);
         parameter_value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      current_parameter_value: ^clt$data_value,
      list_size: clt$list_size;

    status.normal := TRUE;

    IF (parameter_value^.kind = clc$list) THEN
      list_size := clp$count_list_elements (parameter_value);
      current_parameter_value := parameter_value;
      REPEAT
        IF current_parameter_value^.element_value^.kind = clc$keyword THEN
          osp$set_status_abnormal ('AV', ave$must_be_used_alone,
                current_parameter_value^.element_value^.keyword_value, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, parameter_name, status);
          RETURN;
        ELSEIF current_parameter_value^.element_value^.kind = clc$name THEN
          IF ((current_parameter_value^.element_value^.name_value = 'ALL') OR
                (current_parameter_value^.element_value^.name_value = 'DEFAULT') OR
                (current_parameter_value^.element_value^.name_value = 'NONE')) AND (list_size > 1) THEN
            osp$set_status_abnormal ('AV', ave$must_be_used_alone,
                  current_parameter_value^.element_value^.name_value, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, parameter_name, status);
            RETURN;
          IFEND;
        IFEND;
        current_parameter_value := current_parameter_value^.link;
      UNTIL current_parameter_value = NIL;
    IFEND;

  PROCEND verify_list_of_names_value;
?? OLDTITLE ??
?? NEWTITLE := 'verify_statistic_code_value', EJECT ??

{ PURPOSE:
{   This procedure scans the values that were specified for an update statitics
{   parameter to insure that the values are all correctly formed statistic codes
{   and that the keyword value NONE is not specified with other values.

  PROCEDURE verify_statistic_code_value
    (    parameter_name: string ( * <= osc$max_name_size);
         parameter_value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      current_parameter_value: ^clt$data_value,
      statistic_name: ost$name,
      valid_name: boolean;

    status.normal := TRUE;

    IF (parameter_value^.kind = clc$list) THEN
      current_parameter_value := parameter_value;
      REPEAT
        IF current_parameter_value^.element_value^.kind = clc$keyword THEN
          osp$set_status_abnormal ('AV', ave$must_be_used_alone,
                current_parameter_value^.element_value^.keyword_value, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, parameter_name, status);
          RETURN;
        ELSE { clc$statistic_code }
          sfp$convert_stat_code_to_name (current_parameter_value^.element_value^.statistic_code_value,
                statistic_name, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        current_parameter_value := current_parameter_value^.link;
      UNTIL current_parameter_value = NIL;
    IFEND;

  PROCEND verify_statistic_code_value;
?? OLDTITLE ??
?? OLDTITLE ??
MODEND avm$administer_validations;
*DECK DECK=AVM$CALCULATE_SRUS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: SRU calculation' ??
MODULE avm$calculate_srus;

{ PURPOSE:
{   This module contains the procedure used to periodically calculate a new
{   total SRU accumulator value for a job.
{
{ DESIGN:
{   The SRU calculation has been placed in a separate module to facilitate a
{   site defined SRU algorithm.  The source for this module should be released
{   with NOS/VE so sites have a sample SRU calculation procedure to use when
{   developing their own.

?? NEWTITLE := 'Global declarations referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avt$sru_calculation_interval
*copyc jmt$job_statistics
*copyc ost$status
*copyc pmt$task_cp_time
*copyc sfc$unlimited
*copyc sft$limit
*copyc sft$counter
?? POP ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$calculate_application_srus', EJECT ??
*copyc avh$calculate_application_srus

  PROCEDURE [XDCL, #GATE] avp$calculate_application_srus
    (    cpu_time: pmt$task_cp_time;
         paging_statistics: ost$paging_statistics;
     VAR accumulated_srus: sft$counter;
     VAR status: ost$status);

{ NOTES:
{   This is the default SRU calculation formula for APPLICATION SRUS.
{     (CP time = SRUS).
{
{ DESIGN:
{   The accumulated SRUs are calculated by adding the job mode and monitor mode
{   CP time from the cpu_time record together.  CPU time is kept in micro
{   seconds and SRUs are reported in micro SRUs (e.g., in order to return a value
{   of 1 SRU, the accumulated sru parameter should be returned with a value of
{   1000000).
{
{   Unlike, avp$calculate_srus, this procedure does not calculate or alter the
{   SRU calculation interval.

    status.normal := TRUE;

{ SRUs = job mode cp time + monitor mode cp time

    accumulated_srus := cpu_time.task_time + cpu_time.monitor_time;
  PROCEND avp$calculate_application_srus;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$calculate_srus', EJECT ??
*copyc avh$calculate_srus

  PROCEDURE [XDCL, #GATE] avp$calculate_srus
    (    job_statistics: jmt$job_statistics;
         sru_limit: sft$limit;
     VAR accumulated_srus: sft$counter;
     VAR calculation_interval: avt$sru_calculation_interval;
     VAR status: ost$status);

{ NOTES:
{   This is the default SRU calculation formula (CP time = SRUS).
{
{ DESIGN:
{   The accumulated SRUs are calculated by adding the job mode and monitor mode
{   CP time from the job statistics record together.  CP time is kept in micro
{   seconds and SRUs are reported in micro SRUs (e.g., in order to return a value
{   of 1 SRU, the accumulated sru parameter should be returned with a value of
{   1000000).
{
{   The calculation interval that is returned will be the smaller of:
{
{           - maximum calculation interval
{           - One half of the remaining SRUs (the calculation interval is in
{             seconds and 1 SRU = 1 CP second) -- down to the minimum calculation
{             interval.

    VAR
      remaining_srus: sft$counter;

    status.normal := TRUE;

{ SRUs = job mode cp time + monitor mode cp time

    accumulated_srus := job_statistics.cp_time.time_spent_in_job_mode +
          job_statistics.cp_time.time_spent_in_mtr_mode;

{ Determine how many SRUs are left before the job will hit the SRU resource limit.
{ Then set the calculation interval to the smaller of the maximum calculation
{ interval or one half of the remaing SRUs (to a minimum of the smallest
{ calculation interval.
{
{ The SRU limit is kept in whole SRUs -- NOT micro SRUs.

    IF sru_limit.job_resource_limit = sfc$unlimited THEN
      remaining_srus := sfc$unlimited;
    ELSE
      remaining_srus := sru_limit.job_resource_limit - (accumulated_srus DIV 1000000);
    IFEND;

    IF (remaining_srus DIV 2) >= UPPERVALUE (calculation_interval) THEN
      calculation_interval := UPPERVALUE (calculation_interval);
    ELSEIF (remaining_srus DIV 2) <= LOWERVALUE (calculation_interval) THEN
      calculation_interval := LOWERVALUE (calculation_interval);
    ELSE
      calculation_interval := remaining_srus DIV 2;
    IFEND;

  PROCEND avp$calculate_srus;
?? OLDTITLE ??
MODEND avm$calculate_srus;
*DECK DECK=AVM$COMPRESS_VALIDATION_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Compress Validation File' ??
MODULE avm$compress_validation_file;

?? NEWTITLE := 'Global Declarations referenced by this module', EJECT ??
*copyc ave$validation_interface_errors
*copyc avp$check_for_served_family
*copyc avp$family_administrator
*copyc avp$reorganize_validation_file
*copyc avp$system_administrator
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc clv$user_identification
*copyc fsp$path_element
*copyc ofe$error_codes
*copyc osp$set_status_abnormal

?? NEWTITLE := 'avp$compress_validation_file', EJECT ??

{ PURPOSE:
{   This procedure compresses the validation file.

  PROCEDURE [XDCL, #GATE] avp$compress_validation_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{     PROCEDURE (osm$comvf) compress_validation_file, comvf (
{       old_validation_file, ovf: file = $optional
{       new_validation_file, nvf: file = $optional
{       status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 12, 18, 14, 20, 26, 155],
    clc$command, 5, 3, 0, 0, 0, 0, 3, 'OSM$COMVF'], [
    ['NEW_VALIDATION_FILE            ',clc$nominal_entry, 2],
    ['NVF                            ',clc$abbreviation_entry, 2],
    ['OLD_VALIDATION_FILE            ',clc$nominal_entry, 1],
    ['OVF                            ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

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

    CONST
      p$old_validation_file = 1,
      p$new_validation_file = 2,
      p$status = 3;

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

    VAR
      new_evaluated_file_reference: fst$evaluated_file_reference,
      new_validation_file: string (fsc$max_path_size),
      old_evaluated_file_reference: fst$evaluated_file_reference,
      old_validation_file: string (fsc$max_path_size),
      served_family: boolean;

    status.normal := TRUE;

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

    IF NOT avp$system_administrator () AND NOT avp$family_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_administration or family_administration',
            status);
      RETURN;
    IFEND;

    old_validation_file := ' ';
    new_validation_file := ' ';
    IF pvt [p$old_validation_file].specified THEN

{ Determine the family name from the specified path.

      clp$evaluate_file_reference (pvt [p$old_validation_file].value^.file_value^,
            $clt$file_ref_parsing_options [], TRUE, old_evaluated_file_reference, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Verify that a family administrator is only changing the family in which it is in.

      IF NOT avp$system_administrator () THEN
        IF fsp$path_element (^old_evaluated_file_reference, 1) ^ (1,
              clp$trimmed_string_size(fsp$path_element (^old_evaluated_file_reference, 1) ^)) <>
              clv$user_identification.family.value (1, clv$user_identification.family.size) THEN
          osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
          RETURN;
        IFEND;
      IFEND;

{ Don't allow COMPRESS_VALIDATON_FILE on the client.

      avp$check_for_served_family (fsp$path_element (^old_evaluated_file_reference, 1) ^, served_family);
      IF served_family THEN
        osp$set_status_abnormal ('AV', ave$not_allowed_on_client, 'COMPRESS_VALIDATION_FILE', status);
        RETURN;
      IFEND;

      old_validation_file := pvt [p$old_validation_file].value^.file_value^;
    ELSE

{ Don't allow COMPRESS_VALIDATON_FILE on the client.

      avp$check_for_served_family (clv$user_identification.family.
            value (1, clv$user_identification.family.size), served_family);
      IF served_family THEN
        osp$set_status_abnormal ('AV', ave$not_allowed_on_client, 'COMPRESS_VALIDATION_FILE', status);
        RETURN;
      IFEND;
      old_validation_file := ':';
      old_validation_file (2, clv$user_identification.family.size) :=
            clv$user_identification.family.value (1, clv$user_identification.family.size);
      old_validation_file (2 + clv$user_identification.family.size, 21) := '.$SYSTEM.$VALIDATIONS';
    IFEND;

    IF pvt [p$new_validation_file].specified THEN

{ Determine the family name from the specified path.

      clp$evaluate_file_reference (pvt [p$new_validation_file].value^.file_value^,
            $clt$file_ref_parsing_options [], TRUE, new_evaluated_file_reference, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Verify that a family administrator is only changing the family in which it is in.

      IF NOT avp$system_administrator () THEN
        IF fsp$path_element (^new_evaluated_file_reference, 1) ^ (1,
              clp$trimmed_string_size(fsp$path_element (^new_evaluated_file_reference, 1) ^)) <>
              clv$user_identification.family.value (1, clv$user_identification.family.size) THEN
          osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
          RETURN;
        IFEND;
      IFEND;

{ Don't allow COMPRESS_VALIDATON_FILE on the client.

      avp$check_for_served_family (fsp$path_element (^new_evaluated_file_reference, 1) ^, served_family);
      IF served_family THEN
        osp$set_status_abnormal ('AV', ave$not_allowed_on_client, 'COMPRESS_VALIDATION_FILE', status);
        RETURN;
      IFEND;

      new_validation_file := pvt [p$new_validation_file].value^.file_value^;
    ELSE

      new_validation_file := ':';
      new_validation_file (2, clv$user_identification.family.size) :=
            clv$user_identification.family.value (1, clv$user_identification.family.size);
      new_validation_file (2 + clv$user_identification.family.size, 27) := '.$SYSTEM.$VALIDATIONS.$NEXT';
    IFEND;

    IF new_validation_file = old_validation_file THEN
      osp$set_status_abnormal ('AV', ave$new_file_same_as_old_file, '', status);
      RETURN;
    IFEND;
    avp$reorganize_validation_file (old_validation_file, new_validation_file, status);

  PROCEND avp$compress_validation_file;

MODEND avm$compress_validation_file;
*DECK DECK=AVM$DUAL_STATE_PROMPT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Dual State Prompting' ??
MODULE avm$dual_state_prompt;
*copyc avc$compile_test_code
?? PUSH (LISTEXT := ON) ??
?? NEWTITLE := 'Global Declarations referenced by this module', EJECT ??
*copyc ave$condition_codes
*copyc cle$ecc_command_processing
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc ost$caller_identifier
*copyc ost$user_identification
?? POP ??
*copyc amp$get_next
*copyc amp$put_next
*copyc amp$return
*copyc avp$prevalidate_job
*copyc clp$convert_string_to_name
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc pmp$get_unique_name
*copyc rmp$request_terminal
*copyc avv$account_name
*copyc avv$project_name
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] avp$dual_state_prompt', EJECT ??
  PROCEDURE [XDCL] avp$dual_state_prompt
    (    user_name: ost$user_name;
         family_name: ost$family_name;
     VAR status: ost$status);

    VAR
      account_name: avt$account_name,
      project_name: avt$project_name,
      ignore_status: ost$status,
      input_file_id: amt$file_identifier,
      input_file_name: amt$local_file_name,
      prompt_file_id: amt$file_identifier,
      prompt_file_name: amt$local_file_name,
      validation_attributes: ^avt$validation_items;
?? NEWTITLE := 'read_account_project', EJECT ??
    PROCEDURE read_account_project
      (VAR account_name: avt$account_name;
       VAR project_name: avt$project_name;
       VAR status: ost$status);

      VAR
        account_valid: boolean,
        in_message: ost$string,
        ignore_status: ost$status,
        project_valid: boolean,
        prompt_message: ost$status,
        valid_name: clt$name;
?? NEWTITLE := 'put_prompt_get_reply', EJECT ??
      PROCEDURE put_prompt_get_reply
        (    prompt_message_status: ost$status;
             input_file_id: amt$file_identifier;
         VAR line: ost$string;
         VAR status: ost$status);

        VAR
          temp_line: ost$string;
?? NEWTITLE := 'get_parameter_input', EJECT ??
        PROCEDURE get_parameter_input
          (    input_file_id: amt$file_identifier;
           VAR line: ost$string;
           VAR status: ost$status);

          VAR
            continuation_line: ost$string,
            file_position: amt$file_position,
            ignore_byte_address: amt$file_byte_address,
            line_continued: boolean,
            transfer_count: amt$transfer_count;

          status.normal := TRUE;

          line.value := '  ';
          amp$get_next (input_file_id, ^line.value, osc$max_string_size, transfer_count,
                ignore_byte_address, file_position, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          line.size := clp$trimmed_string_size (line.value (1, transfer_count));

        PROCEND get_parameter_input;
?? OLDTITLE, EJECT ??
        status.normal := TRUE;
        line.size := 0;
        line.value := '';

        generate_output_message (prompt_message_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        get_parameter_input (input_file_id, temp_line, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line.size := temp_line.size;

        WHILE (line.size > 0) AND (temp_line.value (temp_line.size - line.size + 1) = ' ') DO
          line.size := line.size - 1;
        WHILEND;

        IF line.size = 0 THEN
          RETURN;
        IFEND;

        line.value (1, line.size) := temp_line.value (temp_line.size - line.size + 1, line.size);

      PROCEND put_prompt_get_reply;
?? OLDTITLE, EJECT ??
      status.normal := TRUE;

      account_valid := FALSE;
      osp$set_status_abnormal ('AV', ave$enter_account, '', prompt_message);
      WHILE NOT account_valid DO
        account_name := osc$null_name;
        put_prompt_get_reply (prompt_message, input_file_id, in_message, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF in_message.size = 0 THEN
          account_valid := TRUE;
        ELSEIF in_message.size <= osc$max_name_size THEN
          clp$convert_string_to_name (in_message.value (1, in_message.size), valid_name, status);
          IF status.normal THEN
            account_name := valid_name.value;
            account_valid := TRUE;
          IFEND;
        IFEND;
        IF account_name = 'LOGOUT' THEN
          osp$set_status_abnormal ('AV', ave$user_requests_logout, '', status);
          generate_output_message (status, ignore_status);
          RETURN;
        IFEND;
      WHILEND;

      project_valid := FALSE;
      osp$set_status_abnormal ('AV', ave$enter_project, '', prompt_message);
      WHILE NOT project_valid DO
        project_name := osc$null_name;
        put_prompt_get_reply (prompt_message, input_file_id, in_message, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF in_message.size = 0 THEN
          project_valid := TRUE;
        ELSEIF in_message.size <= osc$max_name_size THEN
          clp$convert_string_to_name (in_message.value (1, in_message.size), valid_name, status);
          IF status.normal THEN
            project_name := valid_name.value;
            project_valid := TRUE;
          IFEND;
        IFEND;
        IF project_name = 'LOGOUT' THEN
          osp$set_status_abnormal ('AV', ave$user_requests_logout, '', status);
          generate_output_message (status, ignore_status);
          RETURN;
        IFEND;
      WHILEND;

    PROCEND read_account_project;
?? OLDTITLE ??
?? NEWTITLE := 'open_interactive_files', EJECT ??
      PROCEDURE open_interactive_files
        (VAR input_file_id: amt$file_identifier;
         VAR status: ost$status);

        VAR
          file_attachment: ^fst$attachment_options,
          ignore_status: ost$status,
          mandated_creation_attributes: ^fst$file_cycle_attributes,
          connection_attribute: array [1 .. 2] of ift$connection_attribute;

        status.normal := TRUE;

        pmp$get_unique_name (input_file_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        pmp$get_unique_name (prompt_file_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        connection_attribute [1].key := ifc$null_connection_attribute;
        connection_attribute [2].key := ifc$null_connection_attribute;
        rmp$request_terminal (prompt_file_name, NIL, connection_attribute, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        connection_attribute [1].key := ifc$prompt_file;
        connection_attribute [1].prompt_file := prompt_file_name;
        connection_attribute [2].key := ifc$prompt_string;
        connection_attribute [2].prompt_string.value := ', ';
        connection_attribute [2].prompt_string.size := 2;
        rmp$request_terminal (input_file_name, NIL, connection_attribute, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        PUSH file_attachment: [1 .. 1];
        file_attachment^[1].selector := fsc$access_and_share_modes;
        file_attachment^[1].access_modes.selector := fsc$specific_access_modes;
        file_attachment^[1].access_modes.value := $fst$file_access_options [fsc$append];
        file_attachment^[1].share_modes.selector := fsc$specific_share_modes;
        file_attachment^[1].share_modes.value := $fst$file_access_options [];
        PUSH mandated_creation_attributes: [1 .. 1];
        mandated_creation_attributes^[1].selector := fsc$file_contents_and_processor;
        mandated_creation_attributes^[1].file_contents := fsc$list;
        mandated_creation_attributes^[1].file_processor := fsc$unknown_processor;
        fsp$open_file (prompt_file_name, amc$record, file_attachment, {default_creation_attributes} NIL,
              mandated_creation_attributes, {attribute_validation} NIL, {attribute_override} NIL,
              prompt_file_id, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        PUSH file_attachment: [1 .. 1];
        file_attachment^[1].selector := fsc$access_and_share_modes;
        file_attachment^[1].access_modes.selector := fsc$specific_access_modes;
        file_attachment^[1].access_modes.value := $fst$file_access_options [fsc$read];
        file_attachment^[1].share_modes.selector := fsc$specific_share_modes;
        file_attachment^[1].share_modes.value := $fst$file_access_options [];
        fsp$open_file (input_file_name, amc$record, file_attachment, {default_creation_attributes} NIL,
              {mandated_creation_attributes} NIL, {attribute_validation} NIL, {attribute_override} NIL,
              input_file_id, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      PROCEND open_interactive_files;
?? OLDTITLE ??
?? NEWTITLE := 'genereate_output_message', EJECT ??
      PROCEDURE generate_output_message
        (    message_status: ost$status;
         VAR status: ost$status);

    VAR
      current_byte_address: amt$file_byte_address,
      line_count: ^ost$status_message_line_count,
      message: ^ost$status_message,
      message_size: ^ost$status_message_line_size,
      message_text: ^string (*);

        PUSH message;
        RESET message;
        osp$format_message (message_status, osc$brief_message_level, osc$max_status_message_line, message^,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        RESET message;
        NEXT line_count IN message;
        WHILE line_count^ > 0 DO
          NEXT message_size IN message;
          NEXT message_text: [message_size^] IN message;
          amp$put_next (prompt_file_id, message_text, message_size^, current_byte_address, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          line_count^ := line_count^ - 1;
        WHILEND;
      PROCEND generate_output_message;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    open_interactive_files (input_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /dual_state_prompt/

    WHILE TRUE DO
      read_account_project (account_name, project_name, status);
      IF NOT status.normal THEN
        EXIT /dual_state_prompt/;
      IFEND;

      PUSH validation_attributes: [1 .. 1];
      validation_attributes^ [1].key := avc$account_project_key;
      validation_attributes^ [1].account_name := account_name;
      validation_attributes^ [1].project_name := project_name;

      avp$prevalidate_job (user_name, family_name, validation_attributes, NIL, status);
      IF status.normal THEN
        avv$account_name := account_name;
        avv$project_name := project_name;
        EXIT /dual_state_prompt/;
      ELSE
        IF (status.condition = ave$account_does_not_exist) OR
              (status.condition = ave$acct_member_does_not_exist) OR
              (status.condition = ave$project_does_not_exist) OR
              (status.condition = ave$member_does_not_exist) THEN
          generate_output_message (status, ignore_status);
          status.normal := TRUE;
          CYCLE /dual_state_prompt/;
        ELSE
          EXIT /dual_state_prompt/;
        IFEND;
      IFEND;

    WHILEND /dual_state_prompt/;

    IF status.normal THEN
      fsp$close_file (input_file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      amp$return (input_file_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      fsp$close_file (prompt_file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      amp$return (prompt_file_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      fsp$close_file (input_file_id, ignore_status);
      amp$return (input_file_name, ignore_status);
      fsp$close_file (prompt_file_id, ignore_status);
      amp$return (prompt_file_name, ignore_status);
    IFEND;

  PROCEND avp$dual_state_prompt;
?? OLDTITLE ??
MODEND avm$dual_state_prompt;
*DECK DECK=AVM$ENCRYPT EXPAND=TRUE
AVM$ENCRYPT IDENT

. This module contains the double precision arithmetic used to encrypt
. passwords on NOS/VE.
.
. The code for this module was generated by compiling the following FORTRAN
. subroutine and editing the object listing that was produced.
.
.     SUBROUTINE ENCRYPT (base, expon, coefi, prime, result)
.
.     INTEGER base, expon, coefi, prime, result
.     DOUBLE PRECISION rcoefi, rprime, rexpbas, rbase
.
.     rbase = base
.     rcoefi = coefi
.     rprime = prime
.
.     rexpbas = 1
.100  IF (expon.EQ.0) GO TO 200
.       IF (MOD(expon, 2).NE.0) THEN
.         rexpbas = DMOD ((rbase * rexpbas), rprime)
.       END IF
.       IF (expon.GT.1) THEN
.         rbase = DMOD ((rbase * rbase), rprime)
.       END IF
.       expon = expon / 2
.       GO TO 100
.200  CONTINUE
.     result = DMOD ((rcoefi * rexpbas), rprime)
.     END

AVP$ENCRYPT ALIGN           0,8
            DEF             AVP$ENCRYPT
            ADDAQ           A0,A0,72
            LA              A6,A4,8
            LA              A7,A4,0
            LA              A8,A4,16
            LA              A9,A4,24
            LA              AA,A4,32
            ENTE            XF,0E6(16)           .Deselect floating point loss of significance
            ENTE            X2,0FE87(16)
            CPYXS           X2,XF
            LX              XF,A7,0              .Get the base
            CNIF            X2,XF                .Convert to double precision
            CNFI            XD,X2
            ISOM            X3,X0,0,15
            ANDX            X3,X2
            BRXEQ           XD,XF,IL_1
            CPYXX           XE,XF
            SUBX            XE,XD
            CNIF            XD,XE
            ENTP            XE,0
            ADDD            X2,XD
IL_1        LX              XF,A8,0              .Get the coefficient
            CNIF            XD,XF                .Convert to double precision
            CNFI            XB,XD
            ISOM            XE,X0,0,15
            ANDX            XE,XD
            BRXEQ           XB,XF,IL_2
            CPYXX           XC,XF
            SUBX            XC,XB
            CNIF            XB,XC
            ENTP            XC,0
            ADDD            XD,XB
IL_2        SX              XD,A1,1*8            .Store the double precision coefficient
            SX              XE,A1,2*8
            LX              XF,A9,0              .Get the prime number
            CNIF            X4,XF                .Convert to double precision
            CNFI            XD,X4
            ISOM            X5,X0,0,15
            ANDX            X5,X4
            BRXEQ           XD,XF,IL_3
            CPYXX           XE,XF
            SUBX            XE,XD
            CNIF            XD,XE
            ENTP            XE,0
            ADDD            X4,XD
IL_3        SX              X4,A1,3*8            .Store the double precision prime
            SX              X5,A1,4*8
            LBYTP,8         X6,MAGIC_1           .Get the constant used to convert to integer
            LBYTP,8         X7,MAGIC_1+8
            LX              XA,A6,0              .Get the exponent
            LBYTP,8         X8,DP_ONE            .Initialize rexpbas to 1
            LBYTP,8         X9,DP_ONE+8
            ENTP            XB,2
            ENTP            XC,1
L100        BRXEQ           X0,XA,L200           .If the exponent is zero
            CPYXX           XF,XA                .Compute (exponent MOD 2)
            DIVX            XF,XB
            ADDX            XF,XF
            CPYXX           XE,XA
            SUBX            XE,XF
            BRXEQ           X0,XE,GL_2           .IF (exponent MOD 2) is zero
            MULD            X8,X2                .Compute ((rbase * rexpbas) DMOD rprime
            CPYXX           XE,X8
            CPYXX           XF,X9
            DIVD            XE,X4
            ADDD            XE,X6
            MULD            XE,X4
            SUBD            X8,XE
GL_2        BRXGE           XC,XA,GL_4
            MULD            X2,X2                .Compute ((rbase * rbase) DMOD rprime)
            CPYXX           XE,X2
            CPYXX           XF,X3
            DIVD            XE,X4
            ADDD            XE,X6
            MULD            XE,X4
            SUBD            X2,XE
GL_4        DIVX            XA,XB                .Compute (exponent / 2)
            BRXEQ           X0,X0,L100           .Continue the loop
L200        SX              XA,A6,0*8            .Store the exponent
            SX              X8,A1,5*8            .Store the double precision expanded base
            SX              X9,A1,6*8
            LX              XE,A1,1*8            .Get the double precision coefficient
            LX              XF,A1,2*8            .Compute ((rcoefi * rexpbas) DMOD rprime
            MULD            XE,X8
            LX              XC,A1,3*8            .Get the double precision prime
            LX              XD,A1,4*8
            CPYXX           XA,XE
            CPYXX           XB,XF
            DIVD            XA,XC
            LBYTP,8         X8,MAGIC_1
            LBYTP,8         X9,MAGIC_1+8
            ADDD            X8,XA
            MULD            X8,XC
            SUBD            XE,X8
            CPYXX           XD,XE
            CNFI            XD,XD
            LBYTP,8         XE,MAGIC_2
            MULF            XE,XF
            CNFI            XE,XE
            ADDX            XE,XD
            SX              XE,AA,0             .Store the result
            BRCR            12,4,EXIT           .Clear floating point loss of significance
EXIT        RETURN
dp_one      vfd,64    4001800000000000(16)      .Double precision one
            vfd,64    4001000000000000(16)
magic_1     vfd,64    4060000000000000(16)      .Double percision integer zero - used to remove the fraction
            vfd,64    4060000000000000(16)      .from a double precision number during DMOD function
magic_2     vfd,64    3fd1800000000000(16)      .Real number used to convert double precision to integer
            END

*DECK DECK=AVM$ENCRYPT_PASSWORD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Login Password Encryption ' ??
MODULE avm$encrypt_password;

{ PURPOSE:
{
{   This module contains the procedures used to encrypt a validation password.
{
{ DESIGN:
{
{   The Password Encryption algorithms have been placed in a separate module
{ to facilitate a site defined Password Encryption algorithm.
{
{   This module contains two procedures that are used to encrypt passwords.  The
{ primary encryption procedure (AVP$ENCRYPT_PASSWORD) contains the current
{ password encryption algorithm.  The secondary encryption procedure
{ (AVP$OLD_ENCRYPT_PASSWORD) contains the previous version of the password
{ encryption algorithm.  Both procedures are identical when NOS/VE is released.
{
{   Whenever the system is verifying a password, it will first call
{ AVP$ENCRYPT_PASSWORD, to determine the encrypted value of the supplied
{ password, and compare the encrypted result with the desired encrypted value.
{ If the two do not match, AVP$OLD_ENCRYPT_PASSWORD is called the the result is
{ compared again.  Whenever the system is updating an encrypted password,
{ AVP$ENCRYPT_PASSWORD is used.
{
{   This process allows a site to move from one password encryption algorithm
{ to another by replacing the code in AVP$OLD_ENCRYPT_PASSWORD with a copy of
{ the code in AVP$ENCRYPT_PASSWORD.  AVP$ENCRYPT_PASSWORD is then modified to
{ implement the new encryption algorithm.  After this has been done, any
{ changes made to passwords will be encrypted with the new algorithm.  After
{ an appropriate amount of time, AVP$OLD_ENCRYPT_PASSWORD should be modified
{ to match AVP$ENCRYPT_PASSWORD to remove support for the old encryption
{ algorithm.
{

?? PUSH (LISTEXT := ON) ??
?? NEWTITLE := '  Declarations', EJECT ??

*copyc avt$password

*copyc ost$status
*copyc ost$user_identification

?? POP ??
?? NEWTITLE := '  [XREF] Procedures', EJECT ??

*copyc avp$encrypt

*copyc clp$trimmed_string_size
?? TITLE := '  [XDCL] avp$encrypt_password', EJECT ??

  PROCEDURE [XDCL] avp$encrypt_password
    (    user_name: ost$user_name;
         unencrypted_password: ost$name;
     VAR encrypted_password: avt$password;
     VAR status: ost$status);

{
{ NOTES:
{ 1.  This algorithm may be customized by any or all of the following methods. -
{
{     A.  Changing the value of the prime modulus, maintaining the correct range.
{
{     B.  Changing the values of the first two large non prime exponents.
{
{     C.  Changing the values of the large coefficients.
{
{   A table that may be used to determine values for the above factors can be found in:
{     Knuth, D. E. "The Art of Computer Programming Volume 2".
{
{ DESIGN:
{
{  This procedure takes as input a PASSWORD and USER_NAME.  These values are merged into
{  a single string of 62 characters which is then converted to a 48 bit integer by
{  folding the ASCII values of each character. The folding algorithm works as follows:
{
{  |-------|-------|-------|-------|-------|-------|  <-- 62-character string
{  1  add 12  sub 23  add 35  sub 46  add 58  sub 62
{
{  The integer value of each character in the string is multiplied by a power of 26 (0-11),
{  then added to or subtracted from the base depending on its position in the string.
{  The number 26 was chosen so that duplicate passwords cannot be easily generated using
{  letters of the alphabet. More values are added than subtracted so it is not easy for the
{  characters to cancel each other out, resulting in zero.
{
{  The resulting 48 bit FOLDED_RESULT is then
{  used as a factor in the following encryption algorithm.
{
{  The encryption algorithm used is a polynomial expansion, modulus a large prime
{  number, of the form -
{
{      ENCRYPTED_RESULT = SUM (COEFFICIENT(N) * FOLDED_RESULT**EXPONENT(N)) MOD PRIME
{
{      WHERE -
{              ENCRYPTED_RESULT         is the encrypted result
{              FOLDED_RESULT            is the unencrypted folded result from above
{              COEFFICIENT              is an array of integer expansion coefficients
{              EXPONENT                 is an array of integer expansion exponents
{              PRIME                    is a 48 bit prime integer
{              N                        index = 1..6
{
{      THUS  -
{              ENCRYPTED_RESULT will end up being a 48 bit integer or less.
{          The ENCRYPTED_PASSWORD is then returned as a string containing the decimal
{          representation of the ENCRYPTED_RESULT.
{
    CONST
      two_to_the_48th = 1000000000000(16);

    VAR
      base: integer,
      coefficient_table: array [1 .. 6] of integer,
      encrypted_result: integer,
      encryption_string: ost$string,
      exponent_table: array [1 .. 6] of integer,
      index: 1 .. 6,
      integer_factor: integer,
      length: integer,
      prime: integer,
      plus_or_minus_one: -1 .. 1,
      result: integer,
      string_index: integer;

    status.normal := TRUE;

    exponent_table [1] := 33554319; {(2**25) - 113}
    exponent_table [2] := 8388577; {(2**23) - 31}
    exponent_table [3] := 3;
    exponent_table [4] := 2;
    exponent_table [5] := 1;
    exponent_table [6] := 0;

    coefficient_table [1] := 1;
    coefficient_table [2] := 281474976710501; {2**48-155}
    coefficient_table [3] := 281474976710485; {2**48-171}
    coefficient_table [4] := 281474976710465; {2**48-191}
    coefficient_table [5] := 281474976710419; {2**48-237}
    coefficient_table [6] := 281474976710407; {2**48-249}

    prime := 281474976710509; {(2**48) - 147}
    base := 0;
    encrypted_result := 0;

    encryption_string.value := ' ';
    STRINGREP (encryption_string.value, length, unencrypted_password
          (1, clp$trimmed_string_size (unencrypted_password)),
          user_name (1, clp$trimmed_string_size (user_name)));
    encryption_string.size := length;

    integer_factor := 1;
    plus_or_minus_one := 1;
    FOR string_index := 1 TO encryption_string.size DO
      base := base + (plus_or_minus_one * (($INTEGER (encryption_string.value (string_index, 1)))
            * integer_factor));
      IF base < 0 THEN
        base := -base;
      IFEND;
      IF (string_index = 12) OR (string_index = 23) OR (string_index = 35) OR
            (string_index = 46) OR (string_index = 58) THEN
        integer_factor := 1;
        plus_or_minus_one := -plus_or_minus_one;
      ELSE
        integer_factor := integer_factor * 26;
      IFEND;
    FOREND;
    encryption_string.value := ' ';
    encryption_string.size := 0;

    base := base MOD two_to_the_48th;

    FOR index := 1 TO 6 DO

      avp$encrypt (base, exponent_table [index], coefficient_table [index], prime, result);
      encrypted_result := (encrypted_result + result) MOD prime;

    FOREND;

    STRINGREP (encrypted_password, length, encrypted_result: #SIZE (encrypted_password));

    base := 0;

  PROCEND avp$encrypt_password;
?? TITLE := '  [XDCL] avp$old_encrypt_password', EJECT ??

  PROCEDURE [XDCL] avp$old_encrypt_password
    (    user_name: ost$user_name;
         unencrypted_password: ost$name;
     VAR encrypted_password: avt$password;
     VAR status: ost$status);

{
{ NOTES:
{ 1.  This algorithm may be customized by any or all of the following methods. -
{
{     A.  Changing the value of the prime modulus, maintaining the correct range.
{
{     B.  Changing the values of the first two large non prime exponents.
{
{     C.  Changing the values of the large coefficients.
{
{   A table that may be used to determine values for the above factors can be found in:
{     Knuth, D. E. "The Art of Computer Programming Volume 2".
{
{ DESIGN:
{
{  This procedure takes as input a PASSWORD and USER_NAME.  These values are merged into
{  a single string of 62 characters which is then converted to a 48 bit integer by
{  folding the ASCII values of each character. The folding algorithm works as follows:
{
{  |-------|-------|-------|-------|-------|-------|  <-- 62-character string
{  1  add 12  sub 23  add 35  sub 46  add 58  sub 62
{
{  The integer value of each character in the string is multiplied by a power of 26 (0-11),
{  then added to or subtracted from the base depending on its position in the string.
{  The number 26 was chosen so that duplicate passwords cannot be easily generated using
{  letters of the alphabet. More values are added than subtracted so it is not easy for the
{  characters to cancel each other out, resulting in zero.
{
{  The resulting 48 bit FOLDED_RESULT is then
{  used as a factor in the following encryption algorithm.
{
{  The encryption algorithm used is a polynomial expansion, modulus a large prime
{  number, of the form -
{
{      ENCRYPTED_RESULT = SUM (COEFFICIENT(N) * FOLDED_RESULT**EXPONENT(N)) MOD PRIME
{
{      WHERE -
{              ENCRYPTED_RESULT         is the encrypted result
{              FOLDED_RESULT            is the unencrypted folded result from above
{              COEFFICIENT              is an array of integer expansion coefficients
{              EXPONENT                 is an array of integer expansion exponents
{              PRIME                    is a 48 bit prime integer
{              N                        index = 1..6
{
{      THUS  -
{              ENCRYPTED_RESULT will end up being a 48 bit integer or less.
{          The ENCRYPTED_PASSWORD is then returned as a string containing the decimal
{          representation of the ENCRYPTED_RESULT.
{
    CONST
      two_to_the_48th = 1000000000000(16);

    VAR
      base: integer,
      coefficient_table: array [1 .. 6] of integer,
      encrypted_result: integer,
      encryption_string: ost$string,
      exponent_table: array [1 .. 6] of integer,
      index: 1 .. 6,
      integer_factor: integer,
      length: integer,
      prime: integer,
      plus_or_minus_one: -1 .. 1,
      result: integer,
      string_index: integer;

    status.normal := TRUE;

    exponent_table [1] := 33554319; {(2**25) - 113}
    exponent_table [2] := 8388577; {(2**23) - 31}
    exponent_table [3] := 3;
    exponent_table [4] := 2;
    exponent_table [5] := 1;
    exponent_table [6] := 0;

    coefficient_table [1] := 1;
    coefficient_table [2] := 281474976710501; {2**48-155}
    coefficient_table [3] := 281474976710485; {2**48-171}
    coefficient_table [4] := 281474976710465; {2**48-191}
    coefficient_table [5] := 281474976710419; {2**48-237}
    coefficient_table [6] := 281474976710407; {2**48-249}

    prime := 281474976710509; {(2**48) - 147}
    base := 0;
    encrypted_result := 0;

    encryption_string.value := ' ';
    STRINGREP (encryption_string.value, length, unencrypted_password
          (1, clp$trimmed_string_size (unencrypted_password)),
          user_name (1, clp$trimmed_string_size (user_name)));
    encryption_string.size := length;

    integer_factor := 1;
    plus_or_minus_one := 1;
    FOR string_index := 1 TO encryption_string.size DO
      base := base + (plus_or_minus_one * (($INTEGER (encryption_string.value (string_index, 1)))
            * integer_factor));
      IF base < 0 THEN
        base := -base;
      IFEND;
      IF (string_index = 12) OR (string_index = 23) OR (string_index = 35) OR
            (string_index = 46) OR (string_index = 58) THEN
        integer_factor := 1;
        plus_or_minus_one := -plus_or_minus_one;
      ELSE
        integer_factor := integer_factor * 26;
      IFEND;
    FOREND;
    encryption_string.value := ' ';
    encryption_string.size := 0;

    base := base MOD two_to_the_48th;

    FOR index := 1 TO 6 DO

      avp$encrypt (base, exponent_table [index], coefficient_table [index], prime, result);
      encrypted_result := (encrypted_result + result) MOD prime;

    FOREND;

    STRINGREP (encrypted_password, length, encrypted_result: #SIZE (encrypted_password));

    base := 0;

  PROCEND avp$old_encrypt_password;
?? OLDTITLE, EJECT ??

{ Here is the previous version of avp$old_encrypt_password.

{ PROCEDURE [XDCL] avp$old_encrypt_password
{   (    user_name: ost$user_name;
{        unencrypted_password: ost$name;
{    VAR encrypted_password: avt$password;
{    VAR status: ost$status);
{
{
{ NOTES:
{ 1.  This algorithm may be customized by any or all of the following methods. -
{
{     A.  Changing the value of the prime modulus, maintaining the correct range.
{
{     B.  Changing the values of the first two large non prime exponents.
{
{     C.  Changing the values of the large coefficients.
{
{   A table that may be used to determine values for the above factors can be found in:
{     Knuth, D. E. "The Art of Computer Programming Volume 2".
{
{ DESIGN:
{
{  This procedure takes as input a PASSWORD and USER_NAME.  These values are merged into
{  a single string of 62 characters which is then converted to a 48 bit integer by
{  folding the ascii values of each character. The resulting 48 bit FOLDED_RESULT is then
{  used as a factor in the following encryption algorithm.
{
{  The encryption algorithm used is a polynomial expansion, modulus a large prime
{  number, of the form -
{
{      ENCRYPTED_RESULT = SUM (COEFFICIENT(N) * FOLDED_RESULT**EXPONENT(N)) MOD PRIME
{
{      WHERE -
{              ENCRYPTED_RESULT         is the encrypted result
{              FOLDED_RESULT            is the unecrypted folded result from above
{              COEFFICIENT              is an array of integer expansion coefficients
{              EXPONENT                 is an array of integer expansion exponents
{              PRIME                    is a 48 bit prime integer
{              N                        index = 1..6
{
{      THUS  -
{              ENCRYPTED_RESULT will end up being a 48 bit integer or less.
{          The ENCRYPTED_PASSWORD is then returned as a string containing the decimal
{          representation of the ENCRYPTED_RESULT.
{
{   CONST
{     two_to_the_48th = 1000000000000(16);
{
{   VAR
{     base: integer,
{     coefficient_table: array [1 .. 6] of integer,
{     encrypted_result: integer,
{     encryption_string: ost$string,
{     exponent_table: array [1 .. 6] of integer,
{     factor_counter: 1 .. 7,
{     index: 1 .. 6,
{     integer_factor: integer,
{     length: integer,
{     prime: integer,
{     result: integer,
{     string_index: integer;
{
{   status.normal := TRUE;
{
{   exponent_table [1] := 33554319; {(2**25) - 113}
{   exponent_table [2] := 8388577; {(2**23) - 31}
{   exponent_table [3] := 3;
{   exponent_table [4] := 2;
{   exponent_table [5] := 1;
{   exponent_table [6] := 0;
{
{   coefficient_table [1] := 1;
{   coefficient_table [2] := 281474976710501; {2**48-155}
{   coefficient_table [3] := 281474976710485; {2**48-171}
{   coefficient_table [4] := 281474976710465; {2**48-191}
{   coefficient_table [5] := 281474976710419; {2**48-237}
{   coefficient_table [6] := 281474976710407; {2**48-249}
{
{   prime := 281474976710509; {(2**48) - 147}
{   base := 0;
{   encrypted_result := 0;
{
{   encryption_string.value := ' ';
{   STRINGREP (encryption_string.value, length, unencrypted_password
{         (1, clp$trimmed_string_size (unencrypted_password)),
{         user_name (1, clp$trimmed_string_size (user_name)));
{   encryption_string.size := length;
{
{   integer_factor := 1;
{   factor_counter := 1;
{   FOR string_index := 1 TO encryption_string.size DO
{     base := base + (($INTEGER (encryption_string.value (string_index, 1))) * integer_factor);
{     IF factor_counter < 6 THEN
{       integer_factor := integer_factor * 256;
{       factor_counter := factor_counter + 1;
{     ELSE
{       integer_factor := 1;
{       factor_counter := 1;
{     IFEND;
{   FOREND;
{   encryption_string.value := ' ';
{   encryption_string.size := 0;
{
{   base := base MOD two_to_the_48th;
{
{   FOR index := 1 TO 6 DO
{
{     avp$encrypt (base, exponent_table [index], coefficient_table [index], prime, result);
{     encrypted_result := (encrypted_result + result) MOD prime;
{
{   FOREND;
{
{   STRINGREP (encrypted_password, length, encrypted_result: #SIZE (encrypted_password));
{
{   base := 0;
{
{ PROCEND avp$old_encrypt_password;

MODEND avm$encrypt_password;
*DECK DECK=AVM$FAMILY_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Family Commands' ??
MODULE avm$family_commands;

{ PURPOSE:
{   This module contains the command processors for the commands used to
{   create, change, and display families.

{ DESIGN:
{   The command processors in this module simply convert the parameter values
{   specified on the command into their internal formats (when necessary) and call
{   the appropriate family program interface.(In AVM$FAMILY_INTERFACES)

?? PUSH (LISTEXT := ON) ??
?? NEWTITLE := 'Declarations', EJECT ??
*copyc avc$max_number_of_families
*copyc ave$family_errors
*copyc cle$all_must_be_used_alone
*copyc jmc$system_family
*copyc pme$program_services_exceptions
?? POP ??
?? OLDTITLE ??
?? NEWTITLE := 'XREF Procedures', EJECT ??
*copyc avp$change_family_interface
*copyc avp$create_family_interface
*copyc avp$system_administrator
*copyc avp$get_set_name
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc dfp$get_served_family_names
*copyc dfp$get_server_state_string
*copyc dfp$locate_served_family
*copyc osp$set_status_abnormal
*copyc pmp$convert_binary_mainframe_id
*copyc pmp$get_family_names
?? OLDTITLE ??
?? NEWTITLE := 'avp$change_family_command', EJECT ??

{ PURPOSE:
{   This procedure is the command processor for the CHANGE_FAMILY command.

  PROCEDURE [XDCL,#GATE] avp$change_family_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$change_family) change_family, chaf (
{   family_name, fn: name = $required
{   new_family_name, nfn: name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 18, 12, 21, 34, 978], clc$command, 5, 3, 2, 0, 0, 0, 3, 'OSM$CHANGE_FAMILY'],
            [['FAMILY_NAME                    ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['NEW_FAMILY_NAME                ', clc$nominal_entry, 2],
            ['NFN                            ', clc$abbreviation_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$family_name = 1,
      p$new_family_name = 2,
      p$status = 3;

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

    status.normal := TRUE;

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

    IF pvt [p$family_name].value^.name_value <> jmc$system_family THEN
      avp$change_family_interface (pvt [p$family_name].value^.name_value,
            pvt [p$new_family_name].value^.name_value, status);
    ELSE
      osp$set_status_abnormal ('AV', ave$cannot_change_family, jmc$system_family, status);
    IFEND;

  PROCEND avp$change_family_command;
?? OLDTITLE ??
?? NEWTITLE := 'avp$create_family_command', EJECT ??

{ PURPOSE:
{   This procedure is the command processor for the CREATE_FAMILY command.

  PROCEDURE [XDCL,#GATE] avp$create_family_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$create_family) create_family, cref (
{   family_name, fn: name = $required
{   family_administrator, family_user_administrator, fua, fa: name = $required
{   account, account_name, an, a: name = ACCOUNT
{   project, pn, project_name, p: name = PROJECT
{   password, pw: (SECURE) name = PLEASE_CHANGE_THIS_PASSWORD_NOW
{   permanent_file_set, pfs: name = $optional
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 19] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (31),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 1, 31, 13, 51, 50, 525],
    clc$command, 19, 7, 2, 0, 0, 0, 7, 'OSM$CREATE_FAMILY'], [
    ['A                              ',clc$abbreviation_entry, 3],
    ['ACCOUNT                        ',clc$nominal_entry, 3],
    ['ACCOUNT_NAME                   ',clc$alias_entry, 3],
    ['AN                             ',clc$alias_entry, 3],
    ['FA                             ',clc$abbreviation_entry, 2],
    ['FAMILY_ADMINISTRATOR           ',clc$nominal_entry, 2],
    ['FAMILY_NAME                    ',clc$nominal_entry, 1],
    ['FAMILY_USER_ADMINISTRATOR      ',clc$alias_entry, 2],
    ['FN                             ',clc$abbreviation_entry, 1],
    ['FUA                            ',clc$alias_entry, 2],
    ['P                              ',clc$abbreviation_entry, 4],
    ['PASSWORD                       ',clc$nominal_entry, 5],
    ['PERMANENT_FILE_SET             ',clc$nominal_entry, 6],
    ['PFS                            ',clc$abbreviation_entry, 6],
    ['PN                             ',clc$alias_entry, 4],
    ['PROJECT                        ',clc$nominal_entry, 4],
    ['PROJECT_NAME                   ',clc$alias_entry, 4],
    ['PW                             ',clc$abbreviation_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 7]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [12, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 31],
{ PARAMETER 6
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'ACCOUNT'],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'PROJECT'],
{ PARAMETER 5
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'PLEASE_CHANGE_THIS_PASSWORD_NOW'],
{ PARAMETER 6
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

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

    CONST
      p$family_name = 1,
      p$family_administrator = 2,
      p$account = 3,
      p$project = 4,
      p$password = 5,
      p$permanent_file_set = 6,
      p$status = 7;

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

    VAR
      permanent_file_set: ost$name;

    status.normal := TRUE;

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

    IF pvt [p$permanent_file_set].specified THEN
      permanent_file_set := pvt [p$permanent_file_set].value^.name_value;
    ELSE

{ A null permanent file set value specifes that the create family interface
{ should use the system default set name.

      permanent_file_set := osc$null_name;
    IFEND;

    avp$create_family_interface (pvt [p$family_name].value^.name_value,
          pvt [p$family_administrator].value^.name_value, pvt [p$account].value^.name_value,
          pvt [p$project].value^.name_value, pvt [p$password].value^.name_value, permanent_file_set, status);
    pvt [p$password].value^.name_value := osc$null_name;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND avp$create_family_command;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] avp$display_family_command', EJECT ??

{ PURPOSE:
{   This procedure is the command processor for the DISPLAY_FAMILY command.

  PROCEDURE [XDCL, #GATE] avp$display_family_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (osm$display_family) display_family, display_families, disf (
{   family_name, fn: (CHECK) any of
{       key
{         all
{       keyend
{       list 1..999 of name
{     anyend = all
{   output, o: file = $output
{   display_option, display_options, do: key
{       (brief, b)
{       (full, f)
{     keyend = brief
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 8] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (3),
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
          default_value: string (5),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 18, 14, 20, 30, 675], clc$command, 8, 4, 0, 0, 0, 0, 4, 'OSM$DISPLAY_FAMILY'],
            [['DISPLAY_OPTION                 ', clc$nominal_entry, 3],
            ['DISPLAY_OPTIONS                ', clc$alias_entry, 3],
            ['DO                             ', clc$abbreviation_entry, 3],
            ['FAMILY_NAME                    ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 1],
            ['O                              ', clc$abbreviation_entry, 2],
            ['OUTPUT                         ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$extended_parameter_checking, 85, clc$optional_default_parameter, 0, 3],

{ PARAMETER 2

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 3

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 5],

{ PARAMETER 4

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ 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]]], 21, [[1, 0, clc$list_type],
            [5, 1, 999, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'all'],

{ PARAMETER 2

      [[1, 0, clc$file_type], '$output'],

{ PARAMETER 3

      [[1, 0, clc$keyword_type], [4], [['B                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['BRIEF                          ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['F                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FULL                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]], 'brief'],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$family_name = 1,
      p$output = 2,
      p$display_option = 3,
      p$status = 4;

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

    VAR
      active_family_list: ^pmt$family_name_list,
      current_parameter_value: ^clt$data_value,
      display_control: clt$display_control,
      display_options_brief: boolean,
      family_counter: integer,
      file_contents: amt$file_contents,
      number_of_families: pmt$family_name_count,
      ring_attributes: amt$ring_attributes,
      served_family_found: boolean,
      server_mainframe_id: pmt$binary_mainframe_id,
      server_state: dft$server_state,
      set_name: stt$set_name;

*copy clv$display_variables
?? NEWTITLE := 'Dummy title because of error in clp$new_page_procedure' ??
*copyc clp$new_page_procedure

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

{ Dummy subtitle procedure

      status.normal := TRUE;

    PROCEND put_subtitle;
?? OLDTITLE ??
?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
        current_parameter_value: ^clt$data_value,
        family_found: boolean,
        unused_smid: pmt$binary_mainframe_id,
        unused_ss: dft$server_state,
        set_name: stt$set_name;

      status.normal := TRUE;

{ Make sure the user has not specified ALL along with specific family names.

      IF (which_parameter.specific) AND (which_parameter.number = p$family_name) THEN
        IF parameter_value_table^ [p$family_name].value^.kind = clc$list THEN
          current_parameter_value := parameter_value_table^ [p$family_name].value;
          REPEAT
            IF current_parameter_value^.element_value^.name_value = 'ALL' THEN
              osp$set_status_abnormal ('AV', cle$all_must_be_used_alone, 'FAMILY_NAME', status);
              RETURN;
            ELSE
              avp$get_set_name (current_parameter_value^.element_value^.name_value, set_name, status);
              IF NOT status.normal THEN
                get_served_family_state (current_parameter_value^.element_value^.name_value,
                       family_found, unused_smid, unused_ss);
                IF NOT family_found THEN
                  RETURN;
                IFEND;
                status.normal := TRUE;
              IFEND;
            IFEND;
            current_parameter_value := current_parameter_value^.link;
          UNTIL current_parameter_value = NIL;
        IFEND;
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE ??
?? NEWTITLE := 'display_family', EJECT ??

{ PURPOSE:
{   This procedure displays a specified family.

    PROCEDURE display_family
      (    display_options_brief: boolean;
           family_name: ost$family_name;
           set_name: stt$set_name;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      VAR
        first: boolean;

      status.normal := TRUE;

      clp$put_partial_display (display_control, ' Family name:  ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_partial_display (display_control, family_name, clc$no_trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT display_options_brief THEN
        clp$put_partial_display (display_control, '    Set Name:  ', clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, set_name, clc$no_trim, amc$terminate, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    PROCEND display_family;
?? OLDTITLE ??
?? NEWTITLE := 'display_served_family', EJECT ??

{ PURPOSE:
{   This procedure displays a specified served family.

    PROCEDURE display_served_family
      (    display_options_brief: boolean;
           family_name: ost$family_name;
           server_mainframe_id: pmt$binary_mainframe_id;
           server_state: dft$server_state;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      VAR
        mainframe_id: pmt$mainframe_id,
        server_state_string: string (17);

      status.normal := TRUE;

      clp$put_partial_display (display_control, ' Served Family Name:  ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_partial_display (display_control, family_name, clc$no_trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF NOT display_options_brief THEN
        clp$put_partial_display (display_control, '    Mainframe Name:  ', clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        pmp$convert_binary_mainframe_id (server_mainframe_id, mainframe_id, status);
        clp$put_partial_display (display_control, mainframe_id, clc$no_trim, amc$terminate, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        dfp$get_server_state_string (server_state, server_state_string);
        clp$put_partial_display (display_control, '    Server State:  ', clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, server_state_string, clc$no_trim, amc$terminate, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      IFEND;

    PROCEND display_served_family;
?? OLDTITLE ??
?? NEWTITLE := 'get_served_family_state', EJECT ??

    PROCEDURE get_served_family_state
      (    family_name: ost$family_name;
       VAR family_found: boolean;
       VAR server_mainframe_id: pmt$binary_mainframe_id;
       VAR server_state: dft$server_state);

      VAR
        served_family_table_index: dft$served_family_table_index,
        p_queue_interface_table: dft$p_queue_interface_table,
        queue_index: dft$queue_index;

      family_found := FALSE;
      dfp$locate_served_family (family_name, family_found, served_family_table_index,
             server_mainframe_id, p_queue_interface_table, queue_index, server_state);
    PROCEND get_served_family_state;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

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

    IF (pvt [p$display_option].value^.keyword_value = 'BRIEF') THEN
      display_options_brief := TRUE;
    ELSE
      display_options_brief := FALSE;
    IFEND;

{ Open the output file.

    clv$titles_built := FALSE;
    clv$command_name := 'display_family';
    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    file_contents := amc$list;

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, file_contents,
          ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ If ALL families specifed retrieve a list of all families then display them.

    IF pvt [p$family_name].value^.kind = clc$keyword THEN {ALL specified}

{ Allocate space to hold a reasonable number of family names.
{ Try to place the current families into this list.
{ If they do not fit allocate space for the actual number of families
{ returned by the get family names call and retry.

      number_of_families := 100;
      REPEAT
        PUSH active_family_list: [1 .. number_of_families];
        pmp$get_family_names (active_family_list^, number_of_families, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      UNTIL number_of_families <= UPPERBOUND (active_family_list^);

      FOR family_counter := 1 TO number_of_families DO
        avp$get_set_name (active_family_list^ [family_counter], set_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        display_family (display_options_brief, active_family_list^ [family_counter], set_name,
              display_control, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

      /get_served_families/
      REPEAT
        dfp$get_served_family_names (active_family_list^, number_of_families, status);
        IF NOT status.normal THEN
          IF status.condition = pme$result_array_too_small THEN
            PUSH active_family_list: [1 .. number_of_families];
            CYCLE /get_served_families/;
          ELSE
            RETURN;
          IFEND;
        IFEND;
      UNTIL number_of_families <= UPPERBOUND (active_family_list^);

      /display_served_families/
      FOR family_counter := 1 TO number_of_families DO
        get_served_family_state (active_family_list^ [family_counter],
               served_family_found, server_mainframe_id, server_state);
        IF NOT served_family_found THEN
          CYCLE /display_served_families/;
        IFEND;
        display_served_family (display_options_brief, active_family_list^ [family_counter],
               server_mainframe_id, server_state, display_control, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND /display_served_families/;

    ELSE

{ Display the specified families.

      current_parameter_value := pvt [p$family_name].value;
      REPEAT
        avp$get_set_name (current_parameter_value^.element_value^.name_value, set_name, status);
        IF NOT status.normal THEN
          get_served_family_state (current_parameter_value^.element_value^.name_value,
                 served_family_found, server_mainframe_id, server_state);
          IF served_family_found THEN
            display_served_family (display_options_brief,
                   current_parameter_value^.element_value^.name_value,
                   server_mainframe_id, server_state, display_control, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSE
            RETURN;
          IFEND;
        ELSE
          display_family (display_options_brief, current_parameter_value^.element_value^.name_value, set_name,
                display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        current_parameter_value := current_parameter_value^.link;
      UNTIL current_parameter_value = NIL;
    IFEND;

    clp$close_display (display_control, status);

  PROCEND avp$display_family_command;
?? OLDTITLE ??
MODEND avm$family_commands;

*DECK DECK=AVM$FAMILY_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Family Interfaces' ??
MODULE avm$family_interfaces;

{ PURPOSE:
{
{   This module contains the external interfaces used to create and change a
{ family, and to get the set name for a family.
{
{  DESIGN:
{
{   The interfaces in this module validate the caller before performing the
{ requested functions.

?? PUSH (LISTEXT := ON) ??
?? NEWTITLE := 'Declarations', EJECT ??
*copyc ave$family_errors
*copyc fst$path
*copyc jmc$system_family
?? POP ??
?? OLDTITLE ??
?? NEWTITLE := 'XREF Procedures', EJECT ??
*copyc amp$return
*copyc avp$change_acct_proj_value
*copyc avp$change_capability_value
*copyc avp$change_login_password_value
*copyc avp$close_validation_file
*copyc avp$create_$system_user
*copyc avp$create_account_member_rec
*copyc avp$create_account_record
*copyc avp$create_project_record
*copyc avp$create_user_record
*copyc avp$end_subutility_session
*copyc avp$open_validation_file
*copyc avp$system_administrator
*copyc fsp$build_file_ref_from_elems
*copyc osp$append_status_parameter
*copyc osp$generate_log_message
*copyc osp$get_set_name
*copyc osp$set_status_abnormal
*copyc pfp$change_family_name
*copyc pfp$define_master_catalog
?? OLDTITLE ??
?? NEWTITLE := 'Static Variables', EJECT ??
*copyc stv$system_set_name
?? OLDTITLE ??
?? NEWTITLE := 'avp$change_family_interface', EJECT ??
*copyc avh$change_family_interface
  PROCEDURE [XDCL, #GATE] avp$change_family_interface
    (    family_name: ost$family_name;
         new_family_name: ost$family_name;
     VAR status: ost$status);

    VAR
      set_name: stt$set_name,
      system_administrator: boolean;

    status.normal := TRUE;

    IF NOT avp$system_administrator() THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

    osp$get_set_name (family_name, set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$change_family_name (set_name, family_name, new_family_name, status);

  PROCEND avp$change_family_interface;
?? OLDTITLE ??
?? NEWTITLE := 'avp$create_family_interface', EJECT ??
*copyc avh$create_family_interface
  PROCEDURE [XDCL, #GATE] avp$create_family_interface
    (    family_name: ost$family_name;
         family_administrator: ost$user_name;
         account_name: avt$account_name;
         project_name: avt$project_name;
         password: ost$name;
         permanent_file_set: stt$set_name;
     VAR status: ost$status);

    VAR
      capability: boolean,
      charge_id: pft$charge_id,
      command_table_size: integer,
      file_information: avt$template_file_information,
      local_status: ost$status,
      login_password: avt$login_password,
      path: ^array [1 .. * ] of pft$name,
      set_name: stt$set_name,
      record_id: ost$name,
      system_administrator: boolean,
      validation_file_path: fst$path;

    status.normal := TRUE;

    IF NOT avp$system_administrator() THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ If the set name specifed is a null name then use the system default set name.

    set_name := permanent_file_set;
    IF set_name = osc$null_name THEN
      set_name := stv$system_set_name;
    IFEND;

{ Define the master catalog for the $SYSTEM user for this family so
{ the validation file may be placed on it.

    charge_id.account := osc$null_name;
    charge_id.project := osc$null_name;
    pfp$define_master_catalog (set_name, family_name, jmc$system_user, charge_id, status);
    IF NOT status.normal THEN
      IF status.condition = pfe$duplicate_master_catalog THEN
        osp$set_status_abnormal ('AV', ave$catalog_already_exists, jmc$system_user, local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, family_name, local_status);
        osp$generate_log_message ($pmt$ascii_logset [pmc$system_log, pmc$job_log], local_status,
              {ignore} status);
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

{ Build the path to the validation file for this family.

    PUSH path: [1 .. 3];
    path^ [1] := family_name;
    path^ [2] := jmc$system_user;
    path^ [3] := avc$validation_file_name;
    fsp$build_file_ref_from_elems (path, validation_file_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Create the validation file.

    avp$open_validation_file (validation_file_path, NIL, NIL, TRUE, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /validation_file_open/
    BEGIN

{ Add the validations for the $SYSTEM user to the validation file.

      avp$create_$system_user (family_name, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$user_already_exists THEN
          osp$set_status_abnormal ('AV', ave$user_validation_info_exists, jmc$system_user, local_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, family_name, local_status);
          osp$generate_log_message ($pmt$ascii_logset [pmc$system_log, pmc$job_log], local_status,
                {ignore} status);
          osp$set_status_abnormal ('PF', pfe$family_already_exists, family_name, status);
        IFEND;
        EXIT /validation_file_open/;
      IFEND;

{ Add the validations for the specified family administrator to the validation file.

      avp$create_user_record (family_administrator, record_id, command_table_size, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$master_catalog_exists THEN
          osp$set_status_abnormal ('AV', ave$catalog_already_exists, family_administrator, local_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, family_name, local_status);
          osp$generate_log_message ($pmt$ascii_logset [pmc$system_log, pmc$job_log], local_status,
                {ignore} status);
          status.normal := TRUE;
        ELSEIF status.condition = ave$user_already_exists THEN
          osp$set_status_abnormal ('AV', ave$user_validation_info_exists, family_administrator,
                local_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, family_name, local_status);
          osp$generate_log_message ($pmt$ascii_logset [pmc$system_log, pmc$job_log], local_status,
                {ignore} status);
          status.normal := TRUE;
          EXIT /validation_file_open/;
        ELSE
          EXIT /validation_file_open/;
        IFEND;
      IFEND;

{ Assign the specifed validations to the specified family administrator.

      login_password.encrypted := FALSE;
      login_password.value := password;
      avp$change_login_password_value (avc$login_password, NIL, ^login_password, NIL, NIL, NIL, NIL, NIL, NIL,
            NIL, record_id, { update_batch_job_passwords = } FALSE, file_information, {ignore} status);
      login_password.value := osc$null_name;

      capability := TRUE;
      avp$change_capability_value (avc$family_administration, ^capability, record_id, file_information,
            {ignore} status);

      avp$change_acct_proj_value (avc$default_account_project, ^account_name, ^project_name, record_id,
            file_information, {ignore} status);

      avp$end_subutility_session (record_id, TRUE, file_information, {ignore} status);
      status.normal := TRUE;

{ Create the account validation record.

      avp$create_account_record (account_name, record_id, command_table_size, file_information, status);
      IF status.normal THEN
        avp$end_subutility_session (record_id, TRUE, file_information, {ignore} status);
      IFEND;
      status.normal := TRUE;

{ Create the project validation record.

      avp$create_project_record (account_name, project_name, record_id, command_table_size, file_information,
            status);
      IF status.normal THEN
        avp$end_subutility_session (record_id, TRUE, file_information, {ignore} status);
      IFEND;
      status.normal := TRUE;

{ Create the account member validation record for the family administrator.

      avp$create_account_member_rec (account_name, family_administrator, record_id, command_table_size,
            file_information, status);
      IF status.normal THEN
        avp$end_subutility_session (record_id, TRUE, file_information, {ignore} status);
      IFEND;
      status.normal := TRUE;
    END /validation_file_open/;

    IF status.normal THEN
      avp$close_validation_file (file_information, status);
    ELSE
      avp$close_validation_file (file_information, local_status);
    IFEND;
    amp$return (validation_file_path, local_status);

  PROCEND avp$create_family_interface;
?? OLDTITLE ??
?? NEWTITLE := '  avp$get_set_name', EJECT ??
*copyc avh$get_set_name
  PROCEDURE [XDCL, #GATE] avp$get_set_name
    (    family: ost$family_name;
     VAR set_name: stt$set_name;
     VAR status: ost$status);

    status.normal := TRUE;

    osp$get_set_name (family, set_name, status);

  PROCEND avp$get_set_name;
?? OLDTITLE ??
MODEND avm$family_interfaces;

*DECK DECK=AVM$INITIALIZE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Validation Initialization' ??
MODULE avm$initialize;

{ PURPOSE:
{   This module contains the procedures to be called at deadstart to initialize families and initialize
{   accounting and validation.  This includes the validation file conversion routines.

*copyc avc$compile_test_code
?? NEWTITLE := 'Global Declarations referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_default_values
*copyc avc$validation_field_names
*copyc avc$validation_file_name
*copyc avc$validation_record_names
*copyc ave$initialize_errors
*copyc avt$file_utility_information
*copyc fst$path
*copyc jmc$system_family
*copyc pfe$error_condition_codes
?? POP ??
*copyc amp$return
*copyc avp$change_account_member_rec
*copyc avp$change_account_record
*copyc avp$change_accum_limit_field
*copyc avp$change_capability_field
*copyc avp$change_capability_value
*copyc avp$change_file_utility_info
*copyc avp$change_file_value
*copyc avp$change_job_class_field
*copyc avp$change_job_class_value
*copyc avp$change_labeled_names_field
*copyc avp$change_labeled_names_value
*copyc avp$change_limit_field
*copyc avp$change_login_password_field
*copyc avp$change_login_password_value
*copyc avp$change_name_field
*copyc avp$change_name_value
*copyc avp$change_project_member_rec
*copyc avp$change_project_record
*copyc avp$change_ring_privilege_value
*copyc avp$change_user_record
*copyc avp$change_util_info_cmd_name
*copyc avp$change_val_field_name
*copyc avp$close_validation_file
*copyc avp$create_accum_limit_field
*copyc avp$create_capability_field
*copyc avp$create_labeled_names_field
*copyc avp$create_limit_field
*copyc avp$create_name_field
*copyc avp$create_user_record
*copyc avp$delete_validation_field
*copyc avp$end_subutility_session
*copyc avp$get_accum_limit_field_desc
*copyc avp$get_capabil_display_value
*copyc avp$get_capability_field_desc
*copyc avp$get_file_utility_info
*copyc avp$get_labeled_names_field_des
*copyc avp$get_limit_field_desc
*copyc avp$get_name_field_desc
*copyc avp$get_validation_field_names
*copyc avp$open_system_validation_file
*copyc avp$open_validation_file
*copyc avp$release_record_id
*copyc avp$verify_template_heap
*copyc avp$verify_user_exists
*copyc clp$trimmed_string_size
*copyc fsp$build_file_ref_from_elems
*copyc osp$append_status_parameter
*copyc osp$generate_output_message
*copyc osp$press_return_to_continue
*copyc osp$set_status_abnormal
*copyc pfp$define_master_catalog
*copyc pfp$purge
*copyc pmp$get_unique_name
*copyc pmp$get_user_identification
*copyc osv$deadstart_phase
*copyc stv$system_set_name
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] avp$initialize', EJECT ??
*copyc avh$initialize

  PROCEDURE [XDCL] avp$initialize
    (VAR status: ost$status);

    VAR
      charge_id: pft$charge_id,
      file_information: avt$template_file_information,
      ignore_status: ost$status,
      new_path: ^array [1 .. * ] of pft$name,
      validation_file_path: fst$path;

    status.normal := TRUE;

{ Action is only neccessary if this is an installation deadstart.

    IF (osv$deadstart_phase = osc$installation_deadstart) THEN

{ Define the master catalog for the :$SYSTEM.$SYSTEM user.

      charge_id.account := osc$null_name;
      charge_id.project := osc$null_name;
      pfp$define_master_catalog (stv$system_set_name, jmc$system_family, jmc$system_user, charge_id, status);
      IF NOT status.normal THEN
        IF status.condition = pfe$duplicate_master_catalog THEN
          status.normal := TRUE;
        ELSE
          RETURN;
        IFEND;
      IFEND;

{ Create the validation file for the $SYSTEM family.

      PUSH new_path: [1 .. 3];
      new_path^ [1] := jmc$system_family;
      new_path^ [2] := jmc$system_user;
      new_path^ [3] := avc$validation_file_name;
      fsp$build_file_ref_from_elems (new_path, validation_file_path, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      avp$open_validation_file (validation_file_path, NIL, NIL, TRUE, file_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Add the $SYSTEM user to the validation file.

      avp$create_$system_user (jmc$system_family, file_information, status);

      avp$close_validation_file (file_information, ignore_status);
      amp$return (validation_file_path, ignore_status);
    IFEND;

  PROCEND avp$initialize;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] avp$initialize_family', EJECT ??

{ PURPOSE:
{   This procedure is called at set activation time to initialize a family.  It verifies the integrity of the
{   validation file for the family and converts it if necessary.

  PROCEDURE [XDCL] avp$initialize_family
    (    family_name: ost$family_name;
     VAR status: ost$status);

    VAR
      cycle_selector: pft$cycle_selector,
      file_information: avt$template_file_information,
      file_utility_information: ^avt$file_utility_information,
      ignore_status: ost$status,
      message_length: integer,
      message_status: ost$status,
      new_path: ^array [1 .. * ] of pft$name,
      system_user_exists: boolean,
      test_user_id: ost$user_identification,
      utility_information: ^avt$utility_information,
      validation_file_path: fst$path;

?? NEWTITLE := 'convert_validation_file', EJECT ??

{ PURPOSE:
{   This procedure converts a validation file to the latest version.

    PROCEDURE convert_validation_file
      (    family_name: ost$family_name;
           validation_file_version: ost$name;
       VAR file_information: avt$template_file_information;
       VAR status: ost$status);

      VAR
        description: ost$string,
        ignore_status: ost$status,
        prefix_length: ost$name_size;

      CONST
        prefix = '$OLD_';

?? NEWTITLE := 'add_accum_limit_field', EJECT ??

{ PURPOSE:
{   This procedure creates a new accumulating limit type validation field.

      PROCEDURE add_accum_limit_field
        (    field_name: ost$name;
             record_name: ost$name;
             job_warning_limit: avt$limit_value;
             job_maximum_limit: avt$limit_value;
             total_limit: avt$limit_value;
             limit_name: ost$name;
             job_limits_apply: boolean;
             limit_update_statistics: ^sft$limit_update_statistics;
             minimum_job_limit_value: avt$limit_value;
             maximum_job_limit_value: avt$limit_value;
             total_limit_applies: boolean;
             total_limit_stops_login: boolean;
             change_commands: avt$name_list;
             display_commands: avt$name_list;
             description: string ( * <= osc$max_string_size);
             display_authority: avt$validation_authority;
             change_authority: avt$validation_authority;
             manage_authority: avt$validation_authority;
             delete_authority: avt$validation_authority;
         VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          description_string: ost$string,
          get_change_authority: avt$validation_authority,
          get_delete_authority: avt$validation_authority,
          get_description: ost$string,
          get_display_authority: avt$validation_authority,
          get_job_limits_apply: boolean,
          get_job_maximum_limit: avt$limit_value,
          get_job_warning_limit: avt$limit_value,
          get_limit_name: ost$name,
          get_limit_update_statistics: ^sft$limit_update_statistics,
          get_manage_authority: avt$validation_authority,
          get_maximum_job_limit_value: avt$limit_value,
          get_minimum_job_limit_value: avt$limit_value,
          get_no_of_limit_update_stats: avt$name_list_size,
          get_total_accumulation: avt$limit_value,
          get_total_limit: avt$limit_value,
          get_total_limit_applies: boolean,
          get_total_limit_stops_login: boolean,
          new_field_name: ost$name;

        status.normal := TRUE;

        get_limit_update_statistics := NIL;
        description_string.value := description;
        description_string.size := #SIZE (description);

{ Determine if a field with this name already exists and is the correct type.

        avp$get_accum_limit_field_desc (field_name, record_name, {record_id=} osc$null_name,
              get_job_warning_limit, get_job_maximum_limit, get_total_limit, get_total_accumulation,
              get_limit_name, get_job_limits_apply, get_minimum_job_limit_value, get_maximum_job_limit_value,
              get_no_of_limit_update_stats, get_limit_update_statistics, get_total_limit_applies,
              get_total_limit_stops_login, get_description, get_change_authority, get_delete_authority,
              get_display_authority, get_manage_authority, file_information, status);
        IF status.normal THEN

{ If it does exist and it is the correct type then unconditionally change it to guarantee that the field is
{ set up correctly.

          avp$change_accum_limit_field (field_name, record_name, {job_warning_limit=} NIL,
                {job_maximum_limit=} NIL, {total_limit=} NIL, ^limit_name, {job_limits_apply=} NIL,
                {limit_update_statistics=} NIL, ^minimum_job_limit_value, ^maximum_job_limit_value,
                {total_limit_applies=} NIL, {total_limit_stops_login=} NIL, {change_command_names=} NIL,
                {display_command_names=} NIL, ^description_string, {display_authority=} NIL,
                {change_authority=} NIL, {manage_authority=} NIL, ^delete_authority, file_information,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          IF (status.condition <> ave$incorrect_kind) AND (status.condition <> ave$unknown_field) AND
                (status.condition <> ave$field_was_deleted) THEN
            RETURN;
          IFEND;

{ If it is not the correct type or has been deleted then the name of the field is changed so that the new
{ field can be created.

          IF (status.condition = ave$incorrect_kind) OR (status.condition = ave$field_was_deleted) THEN
            status.normal := TRUE;
            change_field_name (field_name, record_name, new_field_name, file_information, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

{ Make sure that no command table collisions can occur.

          prevalidate_command_table (record_name, change_commands, display_commands, file_information,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Create the new field.

          avp$create_accum_limit_field (field_name, record_name, job_warning_limit, job_maximum_limit,
                total_limit, limit_name, job_limits_apply, limit_update_statistics, minimum_job_limit_value,
                maximum_job_limit_value, total_limit_applies, total_limit_stops_login, change_commands,
                display_commands, description_string, display_authority, change_authority, manage_authority,
                delete_authority, file_information, status);
        IFEND;

      PROCEND add_accum_limit_field;
?? OLDTITLE ??
?? NEWTITLE := 'add_capability_field', EJECT ??

{ PURPOSE:
{   This procedure creates a new capability type validation field.

      PROCEDURE add_capability_field
        (    field_name: ost$name;
             record_name: ost$name;
             capability: boolean;
             description: string ( * <= osc$max_string_size);
             display_authority: avt$validation_authority;
             change_authority: avt$validation_authority;
             manage_authority: avt$validation_authority;
             delete_authority: avt$validation_authority;
         VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          description_string: ost$string,
          get_change_authority: avt$validation_authority,
          get_capability: boolean,
          get_delete_authority: avt$validation_authority,
          get_description: ost$string,
          get_display_authority: avt$validation_authority,
          get_manage_authority: avt$validation_authority,
          new_field_name: ost$name;

        status.normal := TRUE;
        description_string.value := description;
        description_string.size := #SIZE (description);

{ Determine if a field with this name already exists and is the correct type.

        avp$get_capability_field_desc (field_name, record_name, {record_id=} osc$null_name, get_capability,
              get_description, get_change_authority, get_delete_authority, get_display_authority,
              get_manage_authority, file_information, status);
        IF status.normal THEN

{ If it does exist and it is the correct type then unconditionally change it to guarantee that the field is
{ set up correctly.

          avp$change_capability_field (field_name, record_name, {capability=} NIL, ^description_string,
                {display_authority=} NIL, {change_authority=} NIL, {manage_authority=} NIL, ^delete_authority,
                file_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          IF (status.condition <> ave$incorrect_kind) AND (status.condition <> ave$unknown_field) AND
                (status.condition <> ave$field_was_deleted) THEN
            RETURN;
          IFEND;

{ If it is not the correct type or has been deleted then the name of the field is changed so that the new
{ field can be created.

          IF (status.condition = ave$incorrect_kind) OR (status.condition = ave$field_was_deleted) THEN
            status.normal := TRUE;
            change_field_name (field_name, record_name, new_field_name, file_information, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

{ Create the new field.

          avp$create_capability_field (field_name, record_name, capability, description_string,
                display_authority, change_authority, manage_authority, delete_authority, file_information,
                status);
        IFEND;

      PROCEND add_capability_field;
?? OLDTITLE ??
?? NEWTITLE := 'add_labeled_names_field', EJECT ??

{ PURPOSE:
{   This procedure creates a new labeled names type validation field.

      PROCEDURE add_labeled_names_field
        (    field_name: ost$name;
             record_name: ost$name;
             labeled_names: avt$labeled_names_list;
             valid_labels: avt$name_list;
             valid_names: avt$name_list;
             change_commands: avt$name_list;
             display_commands: avt$name_list;
             description: string ( * <= osc$max_string_size);
             display_authority: avt$validation_authority;
             change_authority: avt$validation_authority;
             manage_authority: avt$validation_authority;
             delete_authority: avt$validation_authority;
         VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          description_string: ost$string,
          get_change_authority: avt$validation_authority,
          get_delete_authority: avt$validation_authority,
          get_description: ost$string,
          get_display_authority: avt$validation_authority,
          get_labeled_names: ^avt$labeled_names_list,
          get_manage_authority: avt$validation_authority,
          get_number_of_valid_labels: avt$name_list_size,
          get_number_of_valid_names: avt$name_list_size,
          get_valid_labels: ^avt$name_list,
          get_valid_names: ^avt$name_list,
          new_field_name: ost$name,
          work_area: ^seq (*);

        status.normal := TRUE;
        description_string.value := description;
        description_string.size := #SIZE (description);

        get_labeled_names := NIL;
        get_valid_labels := NIL;
        get_valid_names := NIL;

{ Determine if a field with this name already exists and is the correct type.

        PUSH work_area: [[REP avc$max_template_record_size OF cell]];
        RESET work_area;
        avp$get_labeled_names_field_des (field_name, record_name, {record_id=} osc$null_name, work_area,
              get_labeled_names, get_number_of_valid_labels, get_valid_labels, get_number_of_valid_names,
              get_valid_names, get_description, get_change_authority, get_delete_authority,
              get_display_authority, get_manage_authority, file_information, status);
        IF status.normal THEN

{ If it does exist and it is the correct type then unconditionally change it to guarantee that the field is
{ set up correctly.

          avp$change_labeled_names_field (field_name, record_name, {add_labeled_names=} NIL,
                {delete_labeled_names=} NIL, {add_valid_labels=} NIL,  {delete_valid_labels=} NIL,
                {add_valid_names=} NIL,  {delete_valid_names=} NIL,
                {change_command_names=} NIL, {display_command_names=} NIL, ^description_string,
                {display_authority=} NIL, {change_authority=} NIL, {manage_authority=} NIL, ^delete_authority,
                file_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          IF (status.condition <> ave$incorrect_kind) AND (status.condition <> ave$unknown_field) AND
                (status.condition <> ave$field_was_deleted) THEN
            RETURN;
          IFEND;

{ If it is not the correct type or has been deleted then the name of the field is changed so that the new
{ field can be created.

          IF (status.condition = ave$incorrect_kind) OR (status.condition = ave$field_was_deleted) THEN
            status.normal := TRUE;
            change_field_name (field_name, record_name, new_field_name, file_information, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

{ Make sure that no command table collisions can occur.

          prevalidate_command_table (record_name, change_commands, display_commands, file_information,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Create the new field.

          avp$create_labeled_names_field (field_name, record_name, labeled_names, valid_labels,
                valid_names, change_commands, display_commands, description_string,
                display_authority, change_authority, manage_authority, delete_authority, file_information,
                status);
        IFEND;

      PROCEND add_labeled_names_field;
?? OLDTITLE ??
?? NEWTITLE := 'add_limit_field', EJECT ??

{ PURPOSE:
{   This procedure creates a new limit type validation field.

      PROCEDURE add_limit_field
        (    field_name: ost$name;
             record_name: ost$name;
             limit_value: avt$limit_value;
             minimum_limit_value: avt$limit_value;
             maximum_limit_value: avt$limit_value;
             change_commands: avt$name_list;
             display_commands: avt$name_list;
             description: string ( * <= osc$max_string_size);
             display_authority: avt$validation_authority;
             change_authority: avt$validation_authority;
             manage_authority: avt$validation_authority;
             delete_authority: avt$validation_authority;
         VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          description_string: ost$string,
          get_change_authority: avt$validation_authority,
          get_delete_authority: avt$validation_authority,
          get_description: ost$string,
          get_display_authority: avt$validation_authority,
          get_limit_value: avt$limit_value,
          get_minimum_limit_value: avt$limit_value,
          get_maximum_limit_value: avt$limit_value,
          get_manage_authority: avt$validation_authority,
          new_field_name: ost$name;

        status.normal := TRUE;
        description_string.value := description;
        description_string.size := #SIZE (description);

{ Determine if a field with this name already exists and is the correct type.

        avp$get_limit_field_desc (field_name, record_name, {record_id=} osc$null_name, get_limit_value,
              get_minimum_limit_value, get_maximum_limit_value, get_description, get_change_authority,
              get_delete_authority, get_display_authority, get_manage_authority, file_information, status);
        IF status.normal THEN

{ If it does exist and it is the correct type then unconditionally change it to guarantee that the field is
{ set up correctly.

          avp$change_limit_field (field_name, record_name, {limit_value =} NIL, ^minimum_limit_value,
                ^maximum_limit_value, {change_command_names=} NIL, {display_command_names=} NIL,
                ^description_string, {display_authority=} NIL, {change_authority=} NIL,
                {manage_authority=} NIL, ^delete_authority, file_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          IF (status.condition <> ave$incorrect_kind) AND (status.condition <> ave$unknown_field) AND
                (status.condition <> ave$field_was_deleted) THEN
            RETURN;
          IFEND;

{ If it is not the correct type or has been deleted then the name of the field is changed so that the new
{ field can be created.

          IF (status.condition = ave$incorrect_kind) OR (status.condition = ave$field_was_deleted) THEN
            status.normal := TRUE;
            change_field_name (field_name, record_name, new_field_name, file_information, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

{ Make sure that no command table collisions can occur.

          prevalidate_command_table (record_name, change_commands, display_commands, file_information,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Create the new field.

          avp$create_limit_field (field_name, record_name, limit_value, minimum_limit_value,
                maximum_limit_value, change_commands, display_commands, description_string, display_authority,
                change_authority, manage_authority, delete_authority, file_information, status);
        IFEND;

      PROCEND add_limit_field;
?? OLDTITLE ??
?? NEWTITLE := 'add_name_field', EJECT ??

{ PURPOSE:
{   This procedure creates a new name type validation field.

      PROCEDURE add_name_field
        (    field_name: ost$name;
             record_name: ost$name;
             names: avt$name_list;
             minimum_number_of_names: avt$name_list_size;
             maximum_number_of_names: avt$name_list_size;
             common_names: avt$name_list;
             change_commands: avt$name_list;
             display_commands: avt$name_list;
             description: string ( * <= osc$max_string_size);
             display_authority: avt$validation_authority;
             change_authority: avt$validation_authority;
             manage_authority: avt$validation_authority;
             delete_authority: avt$validation_authority;
         VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          description_string: ost$string,
          get_change_authority: avt$validation_authority,
          get_common_names: ^avt$name_list,
          get_delete_authority: avt$validation_authority,
          get_description: ost$string,
          get_display_authority: avt$validation_authority,
          get_manage_authority: avt$validation_authority,
          get_maximum_number_of_names: avt$name_list_size,
          get_minimum_number_of_names: avt$name_list_size,
          get_names: ^avt$name_list,
          get_number_of_common_names: avt$name_list_size,
          get_number_of_names: avt$name_list_size,
          new_field_name: ost$name;

        status.normal := TRUE;
        description_string.value := description;
        description_string.size := #SIZE (description);

        get_names := NIL;
        get_common_names := NIL;

{ Determine if a field with this name already exists and is the correct type.

        avp$get_name_field_desc (field_name, record_name, {record_id=} osc$null_name, get_number_of_names,
              get_names, get_minimum_number_of_names, get_maximum_number_of_names, get_number_of_common_names,
              get_common_names, get_description, get_change_authority, get_delete_authority,
              get_display_authority, get_manage_authority, file_information, status);
        IF status.normal THEN

{ If it does exist and it is the correct type then unconditionally change it to guarantee that the field is
{ set up correctly.

          avp$change_name_field (field_name, record_name, {add_names=} NIL, {delete_names=} NIL,
                ^minimum_number_of_names, ^maximum_number_of_names, ^common_names, {delete_common_names=} NIL,
                {change_command_names=} NIL, {display_command_names=} NIL, ^description_string,
                {display_authority=} NIL, {change_authority=} NIL, {manage_authority=} NIL, ^delete_authority,
                file_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          IF (status.condition <> ave$incorrect_kind) AND (status.condition <> ave$unknown_field) AND
                (status.condition <> ave$field_was_deleted) THEN
            RETURN;
          IFEND;

{ If it is not the correct type or has been deleted then the name of the field is changed so that the new
{ field can be created.

          IF (status.condition = ave$incorrect_kind) OR (status.condition = ave$field_was_deleted) THEN
            status.normal := TRUE;
            change_field_name (field_name, record_name, new_field_name, file_information, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

{ Make sure that no command table collisions can occur.

          prevalidate_command_table (record_name, change_commands, display_commands, file_information,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Create the new field.

          avp$create_name_field (field_name, record_name, names, minimum_number_of_names,
                maximum_number_of_names, common_names, change_commands, display_commands, description_string,
                display_authority, change_authority, manage_authority, delete_authority, file_information,
                status);
        IFEND;

      PROCEND add_name_field;
?? OLDTITLE ??
?? NEWTITLE := 'add_141_fields', EJECT ??

{ PURPOSE:
{   This procedure adds the 1.4.1 validation fields to this family's validation file.

      PROCEDURE add_141_fields
        (    family_name: ost$family_name;
             validation_file_version: ost$name;
         VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        status.normal := TRUE;

{ Add the temporary file space limit field.

        add_accum_limit_field (avc$temporary_file_space_limit, avc$user_record_name, avc$maximum_tfs_default,
              avc$maximum_tfs_default, avc$maximum_tfs_default, avc$tfs_limit_name_default,
              avc$tfs_job_limits_apply_def, NIL, avc$minimum_tfs_default, avc$maximum_tfs_default,
              avc$tfs_total_limit_applies_def, avc$tfs_tot_lim_stops_login_def, avc$temp_file_space_chg_cmd,
              avc$temp_file_space_dis_cmd, avc$temp_file_space_limit_descr, avc$user_authority,
              avc$family_admin_authority, avc$family_admin_authority, avc$system_authority, file_information,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Add the configuration administration field.

        add_capability_field (avc$configuration_admin, avc$user_record_name, avc$configuration_admin_default,
              avc$configuration_admin_descr, avc$user_authority, avc$system_admin_authority,
              avc$system_admin_authority, avc$system_authority, file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Add the removable media operation field.

        add_capability_field (avc$removable_media_operation, avc$user_record_name,
              avc$removable_media_oper_def, avc$removable_media_oper_descr, avc$user_authority,
              avc$system_admin_authority, avc$system_admin_authority, avc$system_authority, file_information,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Add the system operation field.

        add_capability_field (avc$system_operation, avc$user_record_name, avc$system_operation_default,
              avc$system_operation_descr, avc$user_authority, avc$system_admin_authority,
              avc$system_admin_authority, avc$system_authority, file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Add the magnetic tape limits field.

        add_accum_limit_field (avc$magnetic_tape_limit, avc$user_record_name, avc$magnetic_tape_max_default,
              avc$magnetic_tape_max_default, avc$magnetic_tape_max_default, avc$mt_limit_name_default,
              avc$mt_job_limits_apply_def, NIL, avc$magnetic_tape_min_default, avc$magnetic_tape_max_default,
              avc$mt_total_limit_applies_def, avc$mt_tot_lim_stops_login_def, avc$magnetic_tape_limit_chg_cmd,
              avc$magnetic_tape_limit_dis_cmd, avc$magnetic_tape_limit_descr, avc$user_authority,
              avc$family_admin_authority, avc$family_admin_authority, avc$system_authority, file_information,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Add the terminal timeout limit field.

        add_limit_field (avc$terminal_timeout_limit, avc$user_record_name, avc$terminal_timeout_limit_def,
              avc$terminal_timeout_min_def, avc$terminal_timeout_max_def, avc$terminal_timeout_chg_cmd,
              avc$terminal_timeout_dis_cmd, avc$terminal_timeout_limit_desc, avc$user_authority,
              avc$family_admin_authority, avc$family_admin_authority, avc$system_authority, file_information,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Add the job destination usages field.

        add_name_field (avc$job_destination_usages, avc$user_record_name, avc$job_destination_usages_def,
              avc$jdu_min_number_of_names, avc$jdu_max_number_of_names, avc$job_dest_usages_names_def,
              avc$job_dest_usages_chg_cmd, avc$job_dest_usages_dis_cmd, avc$job_dest_usages_descr,
              avc$user_authority, avc$family_admin_authority, avc$family_admin_authority,
              avc$system_authority, file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Add the output destination usages field.

        add_name_field (avc$output_destination_usages, avc$user_record_name, avc$output_dest_usages_def,
              avc$odu_min_number_of_names, avc$odu_max_number_of_names, avc$output_dest_usage_names_def,
              avc$output_dest_usages_chg_cmd, avc$output_dest_usages_dis_cmd, avc$output_dest_usages_descr,
              avc$user_authority, avc$family_admin_authority, avc$family_admin_authority,
              avc$system_authority, file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      PROCEND add_141_fields;
?? OLDTITLE ??
?? NEWTITLE := 'add_142_fields', EJECT ??

{ PURPOSE:
{   This procedure adds the 1.4.2 validation fields to this family's validation file.

      PROCEDURE add_142_fields
        (    family_name: ost$family_name;
             validation_file_version: ost$name;
         VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          delete_authority: avt$validation_authority,
          terminal_timeout_min_def: integer;

        status.normal := TRUE;
        delete_authority := avc$system_authority;
        terminal_timeout_min_def := avc$terminal_timeout_min_def;

{ Ensure the delete authority is system for these fields added at 1.4.1.  It may be wrong because of a 1.4.1
{ bug.

        avp$change_accum_limit_field (avc$temporary_file_space_limit, avc$user_record_name, NIL, NIL, NIL,
              NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, ^delete_authority,
              file_information, {ignored} status);
        avp$change_capability_field (avc$configuration_admin, avc$user_record_name, NIL, NIL, NIL, NIL, NIL,
              ^delete_authority, file_information, {ignored} status);
        avp$change_capability_field (avc$removable_media_operation, avc$user_record_name, NIL, NIL, NIL, NIL,
              NIL, ^delete_authority, file_information, {ignored} status);
        avp$change_accum_limit_field (avc$magnetic_tape_limit, avc$user_record_name, NIL, NIL, NIL, NIL, NIL,
              NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, ^delete_authority, file_information,
              {ignored} status);
        avp$change_name_field (avc$job_destination_usages, avc$user_record_name, NIL, NIL, NIL, NIL, NIL, NIL,
              NIL, NIL, NIL, NIL, NIL, NIL, ^delete_authority, file_information, {ignored} status);
        avp$change_name_field (avc$output_destination_usages, avc$user_record_name, NIL, NIL, NIL, NIL, NIL,
              NIL, NIL, NIL, NIL, NIL, NIL, NIL, ^delete_authority, file_information, {ignored} status);
        status.normal := TRUE;

{ Change the terminal timeout limit field.  The terminal timeout limit field should already be defined but
{ this call will change the minimum value from 5 minutes to 1 minute.

        avp$change_limit_field (avc$terminal_timeout_limit, avc$user_record_name, NIL,
              ^terminal_timeout_min_def, NIL, NIL, NIL, NIL, NIL, NIL, NIL, ^delete_authority,
              file_information, {ignored} status);
        status.normal := TRUE;

{ Add the permit level field.

        add_name_field (avc$permit_level, avc$user_record_name, avc$permit_level_names_def,
              avc$pl_min_number_of_names, avc$pl_max_number_of_names, avc$permit_level_com_names_def,
              avc$permit_level_chg_cmd, avc$permit_level_dis_cmd, avc$permit_level_description,
              avc$user_authority, avc$family_admin_authority, avc$family_admin_authority,
              avc$system_authority, file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      PROCEND add_142_fields;
?? OLDTITLE ??
?? NEWTITLE := 'add_151_fields', EJECT ??

{ PURPOSE:
{   This procedure adds the 1.5.1 validation fields to this family's validation file.

      PROCEDURE add_151_fields
        (    family_name: ost$family_name;
             validation_file_version: ost$name;
         VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          total_limit_stops_login: boolean;

        status.normal := TRUE;

{ Add the engineering operation field.

        add_capability_field (avc$engineering_operation, avc$user_record_name,
              avc$engineering_operation_def, avc$engineering_operation_descr, avc$user_authority,
              avc$system_admin_authority, avc$system_admin_authority, avc$system_authority, file_information,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Add the removable media administration field.

        add_capability_field (avc$removable_media_admin, avc$user_record_name,
              avc$removable_media_admin_def, avc$removable_media_admin_descr, avc$user_authority,
              avc$system_admin_authority, avc$system_admin_authority, avc$system_authority, file_information,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Add the removable media access field.

        add_labeled_names_field (avc$removable_media_access, avc$user_record_name,
              avc$removable_media_access_def, avc$rma_valid_groups_default, avc$rma_valid_access_modes_def,
              avc$rma_change_commands, avc$rma_display_commands,
              avc$removable_media_access_desc, avc$user_authority, avc$family_admin_authority,
              avc$family_admin_authority, avc$system_authority, file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Change the permanent file space limit field.  The permanent file space limit field should already be defined
{ but this call will change the limit to default to not preventing login if the limit has been exceeded.

        total_limit_stops_login := FALSE;
        avp$change_accum_limit_field (avc$permanent_file_space_limit, avc$user_record_name, NIL, NIL, NIL,
              NIL, NIL, NIL, NIL, NIL, NIL, ^total_limit_stops_login, NIL, NIL, NIL, NIL, NIL, NIL, NIL,
              file_information, {ignored} status);
        status.normal := TRUE;

      PROCEND add_151_fields;
?? OLDTITLE ??
?? NEWTITLE := 'change_field_name', EJECT ??

{ PURPOSE:
{   This procedure changes the name of an existing site defined field to a resonable new name, or if unable to
{   do that to a unique name.

      PROCEDURE change_field_name
        (    field_name: ost$name;
             record_name: ost$name;
         VAR new_field_name: ost$name;
         VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        status.normal := TRUE;

{ Build a new name from the old one and a prefix.

        new_field_name := field_name;
        new_field_name (prefix_length + 1, (osc$max_name_size - prefix_length)) :=
              new_field_name (1, (osc$max_name_size - prefix_length));
        new_field_name (1, prefix_length) := prefix;

{ Try to change the name to this new name.

        avp$change_val_field_name (field_name, record_name, new_field_name, NIL, NIL, file_information,
              status);
        IF NOT status.normal THEN
          IF status.condition = ave$field_already_exists THEN
            status.normal := TRUE;

{ If a field by that name already exists change the name to a unique name.

            pmp$get_unique_name (new_field_name, status);
            avp$change_val_field_name (field_name, record_name, new_field_name, NIL, NIL, file_information,
                  status);
          IFEND;
        IFEND;
      PROCEND change_field_name;
?? OLDTITLE ??
?? NEWTITLE := 'convert_user_fields_to_141', EJECT ??

{ PURPOSE:
{   This procedure reads each user record and converts any old validation information for the user into the
{   new validation information.

      PROCEDURE convert_user_fields_to_141
        (VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          command_table_size: integer,
          record_id: ost$name,
          user_name: ost$user_name;

        VAR
          capability: boolean;

        status.normal := TRUE;

{ Set up the validation file information so that the next record to be read sequentially from the file will be
{ the first user record.

        file_information.last_key_accessed (1, 31) := avc$high_value_name {account_name} ;
        file_information.last_key_accessed (32, 31) := avc$high_value_name {project_name} ;
        file_information.last_key_accessed (63, 31) := osc$null_name {user_name} ;

{ Read the first user record.

        user_name := osc$null_name;
        avp$change_user_record (user_name, record_id, command_table_size, file_information, status);

{ As long as there are user records, keep converting them.

        WHILE status.normal DO

{ Change the :$SYSTEM.$SYSTEM user.

          IF (family_name = jmc$system_family) AND (user_name = jmc$system_user) THEN

{ Add Remote operator capabilities.

            capability := TRUE;
            avp$change_capability_value (avc$configuration_admin, ^capability, record_id, file_information,
                  ignore_status);
            avp$change_capability_value (avc$removable_media_operation, ^capability, record_id,
                  file_information, ignore_status);
            avp$change_capability_value (avc$system_operation, ^capability, record_id, file_information,
                  ignore_status);

          IFEND;

{ Release the space used to hold the user record.

          avp$end_subutility_session (record_id, TRUE, file_information, status);
          IF status.normal THEN
            record_id := osc$null_name;
          ELSE
            RETURN;
          IFEND;

{ Read the next user record.

          user_name := osc$null_name;
          avp$change_user_record (user_name, record_id, command_table_size, file_information, status);
        WHILEND;
        IF status.condition = ave$end_of_template_file THEN
          status.normal := TRUE;
        IFEND;

      PROCEND convert_user_fields_to_141;
?? OLDTITLE ??
?? NEWTITLE := 'convert_user_fields_to_151', EJECT ??

{ PURPOSE:
{   This procedure reads each user record and converts any old validation information for the user into the
{   new validation information.

      PROCEDURE convert_user_fields_to_151
        (VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          add_labeled_names: ^avt$labeled_names_list,
          capability: boolean,
          command_table_size: integer,
          engineer: boolean,
          index: avt$field_count,
          name_field_count: avt$field_count,
          name_field_names: array [1 .. avc$maximum_field_count] of ost$name,
          record_id: ost$name,
          user_name: ost$user_name;

        status.normal := TRUE;

{ This call will cause the default job class list to be sorted.

        avp$change_job_class_field (avc$job_class, avc$user_record_name,
              NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL,
              file_information, {ignore} status);
        status.normal := TRUE;

{ This call will cause the default login password attributes list to be sorted.

        avp$change_login_password_field (avc$login_password, avc$user_record_name,
              NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL,
              file_information, {ignore} status);
        status.normal := TRUE;

{ This loop will cause all list of name type fields default values to be sorted.

        avp$get_validation_field_names (avc$user_record_name, $avt$field_kind_set [avc$name_kind],
                FALSE, name_field_names, name_field_count, file_information, {ignore} status);
        status.normal := TRUE;

        FOR index := 1 TO name_field_count DO
          avp$change_name_field (name_field_names [index], avc$user_record_name, NIL, NIL, NIL, NIL, NIL, NIL,
                NIL, NIL, NIL, NIL, NIL, NIL, NIL, file_information, {ignore} status);
          status.normal := TRUE;
        FOREND;

{ Set up the validation file information so that the next record to be read sequentially from the file will be
{ the first user record.

        file_information.last_key_accessed (1, 31) := avc$high_value_name {account_name} ;
        file_information.last_key_accessed (32, 31) := avc$high_value_name {project_name} ;
        file_information.last_key_accessed (63, 31) := osc$null_name {user_name} ;

{ Read the first user record.

        user_name := osc$null_name;
        avp$change_user_record (user_name, record_id, command_table_size, file_information, status);

{ As long as there are user records, keep converting them.

        WHILE status.normal DO

{ Change the :$SYSTEM.$SYSTEM user.

          IF (family_name = jmc$system_family) AND (user_name = jmc$system_user) THEN

{ Add removable media administation capability.

            capability := TRUE;
            avp$change_capability_value (avc$removable_media_admin, ^capability, record_id,
                  file_information, {ignore} status);
            status.normal := TRUE;

{ Add access to ALL removable media.

            PUSH add_labeled_names: [1 .. 1];
            add_labeled_names^ := avc$$sys_$sys_rma_default;
            avp$change_labeled_names_value (avc$removable_media_access, add_labeled_names,
                  {delete_labeled_names=} NIL, record_id, file_information, {ignore} status);
            status.normal := TRUE;

          IFEND;

{ Assign each user that currently has engineering administration the new engineering operation capability.

          engineer := FALSE;
          avp$get_capabil_display_value (avc$engineering_administration, record_id, engineer,
                {ignore} status);
          status.normal := TRUE;
          avp$change_capability_value (avc$engineering_operation, ^engineer, record_id,
                file_information, {ignore} status);
          status.normal := TRUE;

{ This call will cause the user's job class list to be sorted.

          avp$change_job_class_value (avc$job_class, NIL, NIL, NIL, NIL, record_id, file_information,
                {ignore} status);
          status.normal := TRUE;

{ This call will cause the user's login password attributes list to be sorted.

          avp$change_login_password_value (avc$login_password, NIL, NIL,  NIL, NIL, NIL, NIL, NIL, NIL, NIL,
                record_id, { update_batch_job_passwords = } FALSE, file_information, {ignore} status);
          status.normal := TRUE;

{ This loop will cause all of the user's list of name type field values to be sorted.

          FOR index := 1 TO name_field_count DO
            avp$change_name_value (name_field_names [index], NIL, NIL, record_id, file_information,
                  {ignore} status);
          FOREND;
          status.normal := TRUE;

{ Release the space used to hold the user record.

          avp$end_subutility_session (record_id, TRUE, file_information, status);
          IF status.normal THEN
            record_id := osc$null_name;
          ELSE
            RETURN;
          IFEND;

{ Read the next user record.

          user_name := osc$null_name;
          avp$change_user_record (user_name, record_id, command_table_size, file_information, status);
        WHILEND;
        IF status.condition = ave$end_of_template_file THEN
          status.normal := TRUE;
        IFEND;

      PROCEND convert_user_fields_to_151;
?? OLDTITLE ??
?? NEWTITLE := 'convert_account_fields_to_151', EJECT ??

{ PURPOSE:
{   This procedure reads each account record and converts any old validation information for the account into
{   the new validation information.

      PROCEDURE convert_account_fields_to_151
        (VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          command_table_size: integer,
          index: avt$field_count,
          name_field_count: avt$field_count,
          name_field_names: array [1 .. avc$maximum_field_count] of ost$name,
          record_id: ost$name,
          account_name: avt$account_name;

        status.normal := TRUE;

{ This loop will cause all list of name type fields default values to be sorted.

        avp$get_validation_field_names (avc$account_record_name, $avt$field_kind_set [avc$name_kind],
                FALSE, name_field_names, name_field_count, file_information, {ignore} status);
        status.normal := TRUE;

        IF name_field_count = 0 THEN
          RETURN;
        IFEND;

        FOR index := 1 TO name_field_count DO
          avp$change_name_field (name_field_names [index], avc$account_record_name, NIL, NIL, NIL, NIL, NIL,
                NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, file_information, {ignore} status);
          status.normal := TRUE;
        FOREND;

{ Set up the validation file information so that the next record to be read sequentially from the file will be
{ the first account record.

        file_information.last_key_accessed (1, 31) := osc$null_name {account_name} ;
        file_information.last_key_accessed (32, 31) := osc$null_name {project_name} ;
        file_information.last_key_accessed (63, 31) := osc$null_name {user_name} ;

{ Read the first account record.

        account_name := osc$null_name;
        avp$change_account_record (account_name, record_id, command_table_size, file_information, status);

{ As long as there are account records, keep converting them.

        WHILE status.normal DO

{ This loop will cause all of the account's list of name type field values to be sorted.

          FOR index := 1 TO name_field_count DO
            avp$change_name_value (name_field_names [index], NIL, NIL, record_id, file_information,
                  {ignore} status);
          FOREND;
          status.normal := TRUE;

{ Release the space used to hold the account record.

          avp$end_subutility_session (record_id, TRUE, file_information, status);
          IF status.normal THEN
            record_id := osc$null_name;
          ELSE
            RETURN;
          IFEND;

{ Read the next account record.

          account_name := osc$null_name;
          avp$change_account_record (account_name, record_id, command_table_size, file_information, status);
        WHILEND;
        IF status.condition = ave$end_of_template_file THEN
          status.normal := TRUE;
        IFEND;

      PROCEND convert_account_fields_to_151;
?? OLDTITLE ??
?? NEWTITLE := 'convert_project_fields_to_151', EJECT ??

{ PURPOSE:
{   This procedure reads each project record and converts any old validation information for the project into
{   the new validation information.

      PROCEDURE convert_project_fields_to_151
        (VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          account_name: avt$account_name,
          command_table_size: integer,
          index: avt$field_count,
          name_field_count: avt$field_count,
          name_field_names: array [1 .. avc$maximum_field_count] of ost$name,
          project_name: avt$project_name,
          record_id: ost$name;

        status.normal := TRUE;

{ This loop will cause all list of name type fields default values to be sorted.

        avp$get_validation_field_names (avc$project_record_name, $avt$field_kind_set [avc$name_kind],
                FALSE, name_field_names, name_field_count, file_information, {ignore} status);
        status.normal := TRUE;

        IF name_field_count = 0 THEN
          RETURN;
        IFEND;

        FOR index := 1 TO name_field_count DO
          avp$change_name_field (name_field_names [index], avc$project_record_name, NIL, NIL, NIL, NIL, NIL,
                NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, file_information, {ignore} status);
          status.normal := TRUE;
        FOREND;

{ Set up the validation file information so that the next record to be read sequentially from the file will be
{ the first project record.

        file_information.last_key_accessed (1, 31) := osc$null_name {account_name} ;
        file_information.last_key_accessed (32, 31) := osc$null_name {project_name} ;
        file_information.last_key_accessed (63, 31) := osc$null_name {user_name} ;

{ Read the first project record.

        account_name := osc$null_name;
        project_name := osc$null_name;
        avp$change_project_record (account_name, project_name, record_id, command_table_size,
              file_information, status);

{ As long as there are project records, keep converting them.

        WHILE status.normal DO

{ This loop will cause all of the project's list of name type field values to be sorted.

          FOR index := 1 TO name_field_count DO
            avp$change_name_value (name_field_names [index], NIL, NIL, record_id, file_information,
                  {ignore} status);
          FOREND;
          status.normal := TRUE;

{ Release the space used to hold the project record.

          avp$end_subutility_session (record_id, TRUE, file_information, status);
          IF status.normal THEN
            record_id := osc$null_name;
          ELSE
            RETURN;
          IFEND;

{ Read the next project record.

          account_name := osc$null_name;
          project_name := osc$null_name;
          avp$change_project_record (account_name, project_name, record_id, command_table_size,
                file_information, status);
        WHILEND;
        IF status.condition = ave$end_of_template_file THEN
          status.normal := TRUE;
        IFEND;

      PROCEND convert_project_fields_to_151;
?? OLDTITLE ??
?? NEWTITLE := 'convert_acct_mem_fields_to_151', EJECT ??

{ PURPOSE:
{   This procedure reads each account_member record and converts any old validation information for the
{   account_member into the new validation information.

      PROCEDURE convert_acct_mem_fields_to_151
        (VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          account_name: avt$account_name,
          command_table_size: integer,
          index: avt$field_count,
          name_field_count: avt$field_count,
          name_field_names: array [1 .. avc$maximum_field_count] of ost$name,
          project_name: avt$project_name,
          record_id: ost$name,
          user_name: ost$user_name;

        status.normal := TRUE;

{ This loop will cause all list of name type fields default values to be sorted.

        avp$get_validation_field_names (avc$account_member_record_name, $avt$field_kind_set [avc$name_kind],
                FALSE, name_field_names, name_field_count, file_information, {ignore} status);
        status.normal := TRUE;

        IF name_field_count = 0 THEN
          RETURN;
        IFEND;

        FOR index := 1 TO name_field_count DO
          avp$change_name_field (name_field_names [index], avc$account_member_record_name, NIL, NIL, NIL, NIL,
                NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, file_information, {ignore} status);
          status.normal := TRUE;
        FOREND;

{ Set up the validation file information so that the next record to be read sequentially from the file will be
{ the first account_member record.

        file_information.last_key_accessed (1, 31) := osc$null_name {account_member_name} ;
        file_information.last_key_accessed (32, 31) := osc$null_name {project_name} ;
        file_information.last_key_accessed (63, 31) := osc$null_name {user_member_name} ;

{ Read the first account_member record.

        account_name := osc$null_name;
        user_name := osc$null_name;
        avp$change_account_member_rec (account_name, user_name, record_id, command_table_size,
              file_information, status);

{ As long as there are account_member records, keep converting them.

        WHILE status.normal DO

{ This loop will cause all of the account_member's list of name type field values to be sorted.

          FOR index := 1 TO name_field_count DO
            avp$change_name_value (name_field_names [index], NIL, NIL, record_id, file_information,
                  {ignore} status);
          FOREND;
          status.normal := TRUE;

{ Release the space used to hold the account_member record.

          avp$end_subutility_session (record_id, TRUE, file_information, status);
          IF status.normal THEN
            record_id := osc$null_name;
          ELSE
            RETURN;
          IFEND;

{ Read the next account_member record.

          account_name := osc$null_name;
          user_name := osc$null_name;
          avp$change_account_member_rec (account_name, user_name, record_id, command_table_size,
                file_information, status);
        WHILEND;
        IF status.condition = ave$end_of_template_file THEN
          status.normal := TRUE;
        IFEND;

      PROCEND convert_acct_mem_fields_to_151;
?? OLDTITLE ??
?? NEWTITLE := 'convert_proj_mem_fields_to_151', EJECT ??

{ PURPOSE:
{   This procedure reads each project_member record and converts any old validation information for the
{   project_member into the new validation information.

      PROCEDURE convert_proj_mem_fields_to_151
        (VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          account_name: avt$account_name,
          command_table_size: integer,
          index: avt$field_count,
          name_field_count: avt$field_count,
          name_field_names: array [1 .. avc$maximum_field_count] of ost$name,
          project_name: avt$project_name,
          record_id: ost$name,
          user_name: ost$user_name;

        status.normal := TRUE;

{ This loop will cause all list of name type fields default values to be sorted.

        avp$get_validation_field_names (avc$project_member_record_name, $avt$field_kind_set [avc$name_kind],
                FALSE, name_field_names, name_field_count, file_information, {ignore} status);
        status.normal := TRUE;

        IF name_field_count = 0 THEN
          RETURN;
        IFEND;

        FOR index := 1 TO name_field_count DO
          avp$change_name_field (name_field_names [index], avc$project_member_record_name, NIL, NIL, NIL, NIL,
                NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, NIL, file_information, {ignore} status);
          status.normal := TRUE;
        FOREND;

{ Set up the validation file information so that the next record to be read sequentially from the file will be
{ the first project_member record.

        file_information.last_key_accessed (1, 31) := osc$null_name {account_member_name} ;
        file_information.last_key_accessed (32, 31) := osc$null_name {project_name} ;
        file_information.last_key_accessed (63, 31) := osc$null_name {user_member_name} ;

{ Read the first project_member record.

        account_name := osc$null_name;
        project_name := osc$null_name;
        user_name := osc$null_name;
        avp$change_project_member_rec (account_name, project_name, user_name, record_id,
              command_table_size, file_information, status);

{ As long as there are project_member records, keep converting them.

        WHILE status.normal DO

{ This loop will cause all of the project_member's list of name type field values to be sorted.

          FOR index := 1 TO name_field_count DO
            avp$change_name_value (name_field_names [index], NIL, NIL, record_id, file_information,
                  {ignore} status);
          FOREND;
          status.normal := TRUE;

{ Release the space used to hold the project_member record.

          avp$end_subutility_session (record_id, TRUE, file_information, status);
          IF status.normal THEN
            record_id := osc$null_name;
          ELSE
            RETURN;
          IFEND;

{ Read the next project_member record.

          account_name := osc$null_name;
          project_name := osc$null_name;
          user_name := osc$null_name;
          avp$change_project_member_rec (account_name, project_name, user_name, record_id,
                command_table_size, file_information, status);
        WHILEND;
        IF status.condition = ave$end_of_template_file THEN
          status.normal := TRUE;
        IFEND;

      PROCEND convert_proj_mem_fields_to_151;
?? OLDTITLE ??
?? NEWTITLE := 'delete_151_fields', EJECT ??

{ PURPOSE:
{   This procedure deletes the validation fields from this family's validation file,
{   which are removed from the 1.5.1 system.

      PROCEDURE delete_151_fields
        (VAR file_information: avt$template_file_information);

        VAR
          ignore_status: ost$status,
          total_limit_stops_login: boolean;

{ Delete the engineering administration field.

        avp$delete_validation_field (avc$engineering_administration, avc$user_record_name,
              file_information, ignore_status);

{ Delete the read unlabeled tapes field.

        avp$delete_validation_field (avc$read_unlabeled_tapes, avc$user_record_name,
              file_information, ignore_status);

{ Delete the write unlabeled tapes field.

        avp$delete_validation_field (avc$write_unlabeled_tapes, avc$user_record_name,
              file_information, ignore_status);

      PROCEND delete_151_fields;
?? OLDTITLE ??
?? NEWTITLE := 'prevalidate_command_table', EJECT ??

{ PURPOSE:
{   This procedure makes sure that the command table kept in the validation file does not conflict with
{   entries for new validation fields.  If a conflict is found the site defined field's name is changed to a
{   new name.  If the name it is being changed to already exists the field is changed to a unique name as a
{   fail safe mechanism.

      PROCEDURE prevalidate_command_table
        (    record_name: ost$name;
             change_commands: avt$name_list;
             display_commands: avt$name_list;
         VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          ignore_status: ost$status,
          index: integer,
          new_command_name: ost$name,
          new_field_name: ost$name;

        status.normal := TRUE;

{ Check each change command being added to verify that it is not already in the comand table.

        FOR index := 1 TO UPPERBOUND (change_commands) DO

{ Build the new command name.

          new_command_name (prefix_length + 1, (osc$max_name_size - prefix_length)) :=
                change_commands [index] (1, (osc$max_name_size - prefix_length));
          new_command_name (1, prefix_length) := prefix;

{ Change the name of the command that conflicts if any.

          avp$change_util_info_cmd_name (change_commands [index], new_command_name, record_name,
                file_information, status);
          IF NOT status.normal THEN

{ If the new command name already exists then use a unique name.

            IF status.condition = ave$cmd_already_in_cmd_table THEN
              pmp$get_unique_name (new_command_name, status);
              avp$change_util_info_cmd_name (change_commands [index], new_command_name, record_name,
                    file_information, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            ELSE
              RETURN;
            IFEND;
          IFEND;
        FOREND;

{ Check each display command being added to verify that it is not already in the comand table.

        FOR index := 1 TO UPPERBOUND (display_commands) DO

{ Build the new command name.

          new_command_name (prefix_length + 1, (osc$max_name_size - prefix_length)) :=
                display_commands [index] (1, (osc$max_name_size - prefix_length));
          new_command_name (1, prefix_length) := prefix;

{ Change the name of the command that conflicts if any.

          avp$change_util_info_cmd_name (display_commands [index], new_command_name, record_name,
                file_information, status);
          IF NOT status.normal THEN

{ If the new command name already exists then use a unique name.

            IF status.condition = ave$cmd_already_in_cmd_table THEN
              pmp$get_unique_name (new_command_name, status);
              avp$change_util_info_cmd_name (change_commands [index], new_command_name, record_name,
                    file_information, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            ELSE
              RETURN;
            IFEND;
          IFEND;
        FOREND;
      PROCEND prevalidate_command_table;
?? OLDTITLE, EJECT ??
      status.normal := TRUE;

      prefix_length := clp$trimmed_string_size (prefix);

{ Make 1.4.1 changes if needed.

      IF validation_file_version < avc$validation_file_version_141 THEN
        add_141_fields (family_name, validation_file_version, file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        convert_user_fields_to_141 (file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

{ Make 1.4.2 changes if needed.

      IF validation_file_version < avc$validation_file_version_142 THEN
        add_142_fields (family_name, validation_file_version, file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

{ Make 1.5.1 changes if needed.

      IF validation_file_version < avc$validation_file_version_151 THEN
        add_151_fields (family_name, validation_file_version, file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        convert_user_fields_to_151 (file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        convert_account_fields_to_151 (file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        convert_project_fields_to_151 (file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        convert_acct_mem_fields_to_151 (file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        convert_proj_mem_fields_to_151 (file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        delete_151_fields (file_information);
      IFEND;

    PROCEND convert_validation_file;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;


{ Open the validation file.

    avp$open_system_validation_file (family_name, file_information, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal ('AV', ave$open_val_file_error, family_name, message_status);
      osp$generate_output_message (message_status, ignore_status);
    ELSE

    /initialize_family/
      BEGIN

{ Verify that the heap is intact.

        avp$verify_template_heap (family_name, file_information, status);
        IF NOT status.normal THEN
          osp$generate_output_message (status, ignore_status);
          EXIT /initialize_family/;
        IFEND;

{ Verify that the $SYSTEM user is defined.

        avp$verify_user_exists (jmc$system_user, system_user_exists, file_information, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal ('AV', ave$access_user_rec_error, family_name, message_status);
          osp$generate_output_message (message_status, ignore_status);
          EXIT /initialize_family/;
        IFEND;

{ Get the validation file version number

        PUSH utility_information: [[REP 1 OF avt$file_utility_information]];
        RESET utility_information;
        avp$get_file_utility_info (utility_information, file_information, status);
        RESET utility_information;
        NEXT file_utility_information IN utility_information;
        IF file_utility_information = NIL THEN
          corrupted_sequence ('AVP$INITIALIZE_FAMILY', 'VERSION', 'FILE_UTILITY_INFORMATION', status);
          EXIT /initialize_family/;
        IFEND;

{ If the version is not equal to the current version then convert the validation file.

        IF file_utility_information^.version <> avc$validation_file_version THEN
          convert_validation_file (family_name, file_utility_information^.version, file_information, status);
          IF NOT status.normal THEN
            osp$set_status_abnormal ('AV', ave$cannot_convert_val_file, family_name, message_status);
            osp$generate_output_message (message_status, ignore_status);
            EXIT /initialize_family/;
          ELSE
            file_utility_information^.version := avc$validation_file_version;
            avp$change_file_utility_info (#SEQ (file_utility_information^), file_information, status);
            IF NOT status.normal THEN
              osp$set_status_abnormal ('AV', ave$cannot_update_val_version, family_name, message_status);
              osp$generate_output_message (message_status, ignore_status);
              EXIT /initialize_family/;
            IFEND;
          IFEND;
        IFEND;

{ If the $SYSTEM user is not defined, create one.

        IF NOT system_user_exists THEN
          avp$create_$system_user (family_name, file_information, status);
          IF NOT status.normal THEN
            osp$set_status_abnormal ('AV', ave$cannot_create_system_user, family_name, message_status);
            osp$generate_output_message (message_status, ignore_status);
          IFEND;
        IFEND;

      END /initialize_family/;

      avp$close_validation_file (file_information, ignore_status);

    IFEND;

{ If an error occured for the $SYSTEM family's validation file then recreate the validation file.

    IF NOT status.normal THEN
      IF family_name = jmc$system_family THEN
        status.normal := TRUE;
        osp$set_status_abnormal ('AV', ave$recreating_system_family, family_name, message_status);
        osp$generate_output_message (message_status, ignore_status);
        osp$press_return_to_continue (ignore_status);

        PUSH new_path: [1 .. 3];
        new_path^ [1] := jmc$system_family;
        new_path^ [2] := jmc$system_user;
        new_path^ [3] := avc$validation_file_name;
        cycle_selector.cycle_option := pfc$highest_cycle;
        pfp$purge (new_path^, cycle_selector, osc$null_name, ignore_status);

        PUSH new_path: [1 .. 4];
        new_path^ [1] := jmc$system_family;
        new_path^ [2] := jmc$system_user;
        new_path^ [3] := avc$validation_file_name;
        new_path^ [4] := '$NEXT';
        fsp$build_file_ref_from_elems (new_path, validation_file_path, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$open_validation_file (validation_file_path, NIL, NIL, TRUE, file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$create_$system_user (jmc$system_family, file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$close_validation_file (file_information, ignore_status);
        amp$return (validation_file_path, ignore_status);
      IFEND;
    IFEND;

  PROCEND avp$initialize_family;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] avp$create_$system_user', EJECT ??

{ PURPOSE:
{   This procedure adds the $SYSTEM user name into the validation file for a family.

  PROCEDURE [XDCL] avp$create_$system_user
    (    family_name: ost$family_name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      add_job_classes: array [1 .. 1] of ost$name,
      add_labeled_names: array [1 .. 1] of avt$labeled_names,
      add_names: array [1 .. 1] of ost$name,
      batch_job_class_default: ost$name,
      capability_field_count: avt$field_count,
      capability_field_names: array [1 .. avc$maximum_field_count] of ost$name,
      capability: boolean,
      command_table_size: integer,
      delete_job_classes: array [1 .. 1] of ost$name,
      index: integer,
      interactive_job_class_default: ost$name,
      login_password: avt$login_password,
      minimum_ring: ost$ring,
      nominal_ring: ost$ring,
      record_id: ost$name,
      user_epilog: ^fst$file_reference,
      user_prolog: ^fst$file_reference;

    status.normal := TRUE;

{ Create the $SYSTEM user.

    avp$create_user_record (jmc$system_user, record_id, command_table_size, file_information, status);
    IF NOT status.normal THEN
      IF status.condition = ave$master_catalog_exists THEN
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

{ Assign a unique password.

    login_password.encrypted := FALSE;
    pmp$get_unique_name (login_password.value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$change_login_password_value (avc$login_password, NIL, ^login_password, NIL, NIL, NIL, NIL, NIL, NIL,
          NIL, record_id, { update_batch_job_passwords = } FALSE, file_information, status);
    login_password.value := osc$null_name;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Assign special values if it is for family $SYSTEM.

    IF family_name = jmc$system_family THEN
      add_names := avc$$sys_$sys_mailve_admin_def;
      avp$change_name_value (avc$mailve_administration, ^add_names, {delete_names} NIL, record_id,
            file_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      minimum_ring := avc$$sys_$sys_minimum_ring_def;
      nominal_ring := avc$$sys_$sys_nominal_ring_def;
      avp$change_ring_privilege_value (avc$ring_privileges, ^minimum_ring, ^nominal_ring, record_id,
            file_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      add_labeled_names := avc$$sys_$sys_rma_default;
      avp$change_labeled_names_value (avc$removable_media_access, ^add_labeled_names,
            {delete_labeled_names=} NIL, record_id, file_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      add_job_classes [1] := avc$$sys_$sys_job_class_def;
      delete_job_classes [1] := 'ALL';
      batch_job_class_default := avc$$sys_$sys_job_class_bat_def;
      interactive_job_class_default := avc$$sys_$sys_job_class_int_def;
      capability := avc$$sys_$sys_capability_def;
      PUSH user_prolog: [clp$trimmed_string_size (avc$$sys_$sys_prolog_default)];
      user_prolog^ := avc$$sys_$sys_prolog_default;
      PUSH user_epilog: [clp$trimmed_string_size (avc$$sys_$sys_epilog_default)];
      user_epilog^ := avc$$sys_$sys_epilog_default;
    ELSE

{ Assign values for the $SYSTEM user on any other family than $SYSTEM.

      add_job_classes [1] := avc$$sys_user_job_class_def;
      delete_job_classes [1] := 'ALL';
      batch_job_class_default := avc$$sys_user_job_class_bat_def;
      interactive_job_class_default := avc$$sys_user_job_class_int_def;
      capability := avc$$sys_user_capability_def;
      PUSH user_prolog: [clp$trimmed_string_size (avc$$sys_user_prolog_default)];
      user_prolog^ := avc$$sys_user_prolog_default;
      PUSH user_epilog: [clp$trimmed_string_size (avc$$sys_user_epilog_default)];
      user_epilog^ := avc$$sys_user_epilog_default;
    IFEND;

{ Enter job class validations.

    avp$change_job_class_value (avc$job_class, ^add_job_classes, ^delete_job_classes,
          ^batch_job_class_default, ^interactive_job_class_default, record_id, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Enter user prolog validations.

    avp$change_file_value (avc$user_prolog, user_prolog, record_id, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Enter user epilog validations.

    avp$change_file_value (avc$user_epilog, user_epilog, record_id, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Retrieve the names of all capabilities.

    avp$get_validation_field_names (avc$user_record_name, $avt$field_kind_set [avc$capability_kind], FALSE,
          capability_field_names, capability_field_count, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Enter the validations for all capabilities.

    FOR index := 1 TO capability_field_count DO
      avp$change_capability_value (capability_field_names [index], ^capability, record_id, file_information,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    avp$end_subutility_session (record_id, TRUE, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND avp$create_$system_user;
?? OLDTITLE ??
?? NEWTITLE := 'corrupted_sequence', EJECT ??

{ PURPOSE:
{   This procedure builds an abnormal status variable used to report a problem when accessing a sequence
{   within the validation file.

  PROCEDURE corrupted_sequence
    (    procedure_name: string ( * );
         variable_name: string ( * );
         sequence_name: string ( * );
     VAR status: ost$status);

    osp$set_status_abnormal ('AV', ave$corrupted_sequence, procedure_name, status);
    osp$append_status_parameter (osc$status_parameter_delimiter, variable_name, status);
    osp$append_status_parameter (osc$status_parameter_delimiter, sequence_name, status);

  PROCEND corrupted_sequence;
?? OLDTITLE ??
MODEND avm$initialize;
*DECK DECK=AVM$JOB_ACCOUNTING_KERNEL EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Job Accounting Kernel' ??
MODULE avm$job_accounting_kernel;

{ PURPOSE:
{   The purpose of this module is to provide accounting for job usage of system
{   resource units, and to update statistics accumulated by MONITOR regarding the
{   currently executing job.  This module executes in ring 2.
{
{ DESIGN:
{   This module contains three main procedures which are called during the three
{   phases of a job.  The first procedure is called to initiate a new period of
{   accountability, and establish those statistics used to calculate system
{   resource units.  The second procedure is a flag handler which is executed
{   intermittently during the job to update the CP time and SRU accumulators for
{   the job.  The third procedure is called to end the current period of
{   accountability.

?? NEWTITLE := 'Global Declarations referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avc$accounting_statistics
*copyc avc$system_defined_limit_names
*copyc avk$monitor_statistics_handler
*copyc avt$account_name
*copyc avt$sru_calculation_interval
*copyc avt$project_name
*copyc oss$job_pageable
*copyc ost$name
*copyc ost$status
*copyc ost$system_flag
*copyc ost$user_identification
*copyc sfc$unlimited
*copyc sfc$warning_grace_period
?? POP ??
*copyc avp$calculate_srus
*copyc avp$update_eoj_total_limits
*copyc clp$trimmed_string_size
*copyc jmp$determine_job_class_name
*copyc jmp$system_job
*copyc osp$clear_job_signature_lock
*copyc osp$initialize_sig_lock
*copyc osp$set_job_signature_lock
*copyc osp$test_signature_lock
*copyc sfp$change_file_space_limit
*copyc sfp$create_job_limit
*copyc sfp$emit_statistic
*copyc sfp$initiate_resource_condition
*copyc sfp$job_limit_chain_entry
*copyc sfp$update_job_limit_accum
*copyc tmp$fetch_job_statistics
*copyc tmp$set_flag_interval
*copyc avv$validated_limits
*copyc jmv$jcb
*copyc sfv$dynamic_file_space_limits
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations declared by this module', EJECT ??

  VAR
    avv$monitor_statistics_lock: [XDCL, STATIC, oss$job_pageable] ost$signature_lock,
    avv$accumulated_srus: [XDCL, #GATE, STATIC, oss$job_pageable] sft$counter := 0,
    end_account_called: [STATIC, oss$job_pageable] boolean := FALSE;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$begin_account', EJECT ??
*copyc avh$begin_account

  PROCEDURE [XDCL, #GATE] avp$begin_account
    (    family_name: ost$family_name;
         user_name: ost$user_name;
         account_name: avt$account_name;
         project_name: avt$project_name;
         user_supplied_job_name: ost$name;
         job_class: jmt$job_class;
     VAR status: ost$status);

    VAR
      descriptive_data: string (osc$max_string_size),
      descriptive_data_size: integer,
      index: integer,
      job_class_name: jmt$job_class_name,
      statistic_codes: ^array [1 .. * ] of sft$statistic_code,
      validated_limit: ^avt$validated_limit;

    status.normal := TRUE;

    #KEYPOINT (osk$entry, 0, avk$begin_account);

  /begin_account/
    BEGIN
      osp$initialize_sig_lock (avv$monitor_statistics_lock);

{ Set the interval used to trigger SRU calulation to unlimited.

      tmp$set_flag_interval (0ffffffff(16));

{ Emit the begin account statistic.

      jmp$determine_job_class_name (job_class, job_class_name, status);
      IF NOT status.normal THEN
        EXIT /begin_account/;
      IFEND;

      STRINGREP (descriptive_data, descriptive_data_size, family_name
            (1, clp$trimmed_string_size (family_name)), ', ',
            user_name (1, clp$trimmed_string_size (user_name)),
            ', ', account_name (1, clp$trimmed_string_size (account_name)),
            ', ', project_name (1, clp$trimmed_string_size (project_name)),
            ', ', user_supplied_job_name (1, clp$trimmed_string_size (user_supplied_job_name)), ', ',
            job_class_name (1, clp$trimmed_string_size (job_class_name)));

      sfp$emit_statistic (avc$begin_account, descriptive_data (1, descriptive_data_size), NIL, status);
      IF NOT status.normal THEN
        EXIT /begin_account/;
      IFEND;

{ Set up the limits for the job based on the limit information determined by validation.

      validated_limit := avv$validated_limits;
      WHILE validated_limit <> NIL DO
        IF validated_limit^.kind = avc$accumulating_limit_kind THEN
          IF validated_limit^.statistic_codes = NIL THEN
            statistic_codes := NIL;
          ELSE
            PUSH statistic_codes: [1 .. UPPERBOUND (validated_limit^.statistic_codes^)];
            FOR index := 1 TO UPPERBOUND (validated_limit^.statistic_codes^) DO
              statistic_codes^ [index] := validated_limit^.statistic_codes^ [index].statistic_code;
            FOREND;
          IFEND;
          sfp$create_job_limit (validated_limit^.limit_name, statistic_codes, validated_limit^.initial_value,
                validated_limit^.job_warning_limit, validated_limit^.job_maximum_limit,
                validated_limit^.enforcement, status);
          IF NOT status.normal THEN
            EXIT /begin_account/;
          IFEND;

{ If the limit being set up is either the permanent file space or temporary file space limits, initialize the
{ associated limit values and counters.

          IF validated_limit^.limit_name = avc$pfs_limit_name THEN
            sfp$change_file_space_limit (sfc$perm_file_space_limit, ^validated_limit^.job_warning_limit,
                  ^validated_limit^.job_maximum_limit, ^validated_limit^.initial_value,
                  {Job warning checking} NIL);
          ELSEIF validated_limit^.limit_name = avc$tfs_limit_name THEN
            sfp$change_file_space_limit (sfc$temp_file_space_limit, ^validated_limit^.job_warning_limit,
                  ^validated_limit^.job_maximum_limit, ^validated_limit^.initial_value,
                  {Job warning checking} NIL);
          IFEND;
        IFEND;
        validated_limit := validated_limit^.forward;
      WHILEND;

{ Update the CPU time and SRU accumulators.  This will reset the interval timer used to trigger the next SRU
{ calculation.

      avp$monitor_statistics_handler (avc$monitor_statistics_flag);

    END /begin_account/;

    #KEYPOINT (osk$exit, 0, avk$begin_account);

  PROCEND avp$begin_account;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$end_account', EJECT ??
*copyc avh$end_account

  PROCEDURE [XDCL, #GATE] avp$end_account
    (VAR status: ost$status);

    VAR
      cpu_time: sft$counter,
      end_account_counters: array [1 .. 9] of sft$counter,
      ignore_status: ost$status,
      job_statistics: jmt$job_statistics,
      sru_calculation_interval: avt$sru_calculation_interval,
      sru_limit: ^sft$limit_chain_entry,
      srus: sft$counter;

    status.normal := TRUE;

    #KEYPOINT (osk$entry, 0, avk$end_account);

  /end_account/
    BEGIN

{ Get the latest CPU time and page fault statistics for the job.

      tmp$fetch_job_statistics (job_statistics, status);
      IF NOT status.normal THEN
        EXIT /end_account/;
      IFEND;

      cpu_time := job_statistics.cp_time.time_spent_in_job_mode +
            job_statistics.cp_time.time_spent_in_mtr_mode;

{ Update the CPU time limit accumulator.

      sfp$update_job_limit_accum (avc$cpu_time_limit_name, (cpu_time DIV 1000000), sfc$replacement_update,
            status);
      IF NOT status.normal THEN
        EXIT /end_account/;
      IFEND;

{ Calculate a new total for the SRU accumulator.

      sru_limit := sfp$job_limit_chain_entry (avc$sru_limit_name);
      IF sru_limit = NIL THEN
        EXIT /end_account/;
      IFEND;

      avp$calculate_srus (job_statistics, sru_limit^.limit, avv$accumulated_srus, sru_calculation_interval,
            status);
      IF NOT status.normal THEN
        EXIT /end_account/;
      IFEND;

{ Update the SRU limit accumulator.

      sfp$update_job_limit_accum (avc$sru_limit_name, (avv$accumulated_srus DIV 1000000),
            sfc$replacement_update, status);
      IF NOT status.normal THEN
        EXIT /end_account/;
      IFEND;

{ Turn off monitor statistics handler so that accounting and limits match 100%.

      end_account_called := TRUE;

{ Emit the end account statistic.

      end_account_counters [1] := avv$accumulated_srus;
      end_account_counters [2] := job_statistics.cp_time.time_spent_in_job_mode;
      end_account_counters [3] := job_statistics.cp_time.time_spent_in_mtr_mode;
      end_account_counters [4] := job_statistics.paging_statistics.page_fault_count;
      end_account_counters [5] := job_statistics.paging_statistics.page_in_count;
      end_account_counters [6] := job_statistics.paging_statistics.pages_reclaimed_from_queue;
      end_account_counters [7] := job_statistics.paging_statistics.new_pages_assigned;
      end_account_counters [8] := job_statistics.paging_statistics.pages_from_server;
      end_account_counters [9] := job_statistics.paging_statistics.working_set_max_used;

      sfp$emit_statistic (avc$end_account, '', ^end_account_counters, status);
      IF NOT status.normal THEN
        EXIT /end_account/;
      IFEND;

{ Update any total limit accumulators in the validation file.

      avp$update_eoj_total_limits (status);

    END /end_account/;

    #KEYPOINT (osk$exit, 0, avk$end_account);

  PROCEND avp$end_account;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$monitor_statistics_handler', EJECT ??
*copyc avh$monitor_statistics_flag

  PROCEDURE [XDCL, #GATE] avp$monitor_statistics_handler
    (    flag_id: ost$system_flag);

    VAR
      calculation_interval: avt$sru_calculation_interval,
      cpu_time: sft$counter,
      cpu_time_limit: ^sft$limit_chain_entry,
      fake_sru_limit: sft$limit,
      ignore_status: ost$status,
      job_statistics: jmt$job_statistics,
      limit_chain_entry: ^sft$limit_chain_entry,
      local_status: ost$status,
      lock_status: ost$signature_lock_status,
      remaining_cpu_time: sft$counter,
      sru_calculation_interval: avt$sru_calculation_interval,
      srus: sft$counter,
      sru_limit: ^sft$limit_chain_entry,
      warning: boolean;

{ No action is necessary once end account has been called.

    IF end_account_called THEN
      RETURN;
    IFEND;

    local_status.normal := TRUE;

{ Check if this routine is already running somewhere else in the job.

    osp$test_signature_lock (avv$monitor_statistics_lock, lock_status, local_status);
    IF (NOT local_status.normal) OR (lock_status <> osc$sls_not_locked) THEN
      RETURN;
    IFEND;

{ Set the lock to prevent other occurrences of this routine from running somewhere else in the job.

    osp$set_job_signature_lock (avv$monitor_statistics_lock);

    #KEYPOINT (osk$entry, osk$m * $INTEGER (flag_id), avk$monitor_statistics_handler);

  /monitor_statistics_handler/
    BEGIN

{ Get the latest CPU time and page fault statistics for the job.

      tmp$fetch_job_statistics (job_statistics, local_status);
      IF NOT local_status.normal THEN
        EXIT /monitor_statistics_handler/;
      IFEND;

      IF jmp$system_job () THEN

{ The system job does not have any limits, so this routine calls AVP$CALCULATE_SRUS
{ (with fake SRU limit information) so that the variable AVV$ACCUMULATED_SRUS is
{ updated.

        fake_sru_limit.name := avc$sru_limit_name;
        fake_sru_limit.condition_identifier := 0;
        fake_sru_limit.accumulator := avv$accumulated_srus DIV 1000000;
        fake_sru_limit.job_resource_limit := sfc$unlimited;
        fake_sru_limit.job_abort_limit := sfc$unlimited;
        fake_sru_limit.enforcement := sfc$accumulation_enforcement;

        avp$calculate_srus (job_statistics, fake_sru_limit, avv$accumulated_srus, sru_calculation_interval,
              local_status);
        IF NOT local_status.normal THEN
          EXIT /monitor_statistics_handler/;
        IFEND;

        IF sru_calculation_interval < UPPERVALUE (calculation_interval) THEN
          calculation_interval := sru_calculation_interval;
        ELSE
          calculation_interval := UPPERVALUE (calculation_interval);
        IFEND;
      ELSE

{ If not executing in the system job, CP_TIME and SRU limits should exist and must be updated.  A new flag
{ interval is selected to insure that the CP_TIME limit and the SRU limit are not over run before the next
{ call to this routine.

        cpu_time_limit := sfp$job_limit_chain_entry (avc$cpu_time_limit_name);
        IF cpu_time_limit = NIL THEN
          EXIT /monitor_statistics_handler/;
        IFEND;

        sru_limit := sfp$job_limit_chain_entry (avc$sru_limit_name);
        IF sru_limit = NIL THEN
          EXIT /monitor_statistics_handler/;
        IFEND;

{ Calculate a new value for the CP_TIME limit accumulator -- fractions of a CP second
{ are ignore.

        cpu_time := (job_statistics.cp_time.time_spent_in_job_mode +
              job_statistics.cp_time.time_spent_in_mtr_mode) DIV 1000000;

{ Update the CPU_TIME accumulator.

        sfp$update_job_limit_accum (avc$cpu_time_limit_name, cpu_time, sfc$replacement_update, ignore_status);

{ Calculate a new total for the SRU accumulator.

        avp$calculate_srus (job_statistics, sru_limit^.limit, avv$accumulated_srus, sru_calculation_interval,
              local_status);
        IF NOT local_status.normal THEN
          EXIT /monitor_statistics_handler/;
        IFEND;

{ Update the SRU accumulator.

        sfp$update_job_limit_accum (avc$sru_limit_name, (avv$accumulated_srus DIV 1000000),
              sfc$replacement_update, ignore_status);

{ Compute a new calculation interval.

        remaining_cpu_time := cpu_time_limit^.limit.job_resource_limit - cpu_time;

        IF remaining_cpu_time < 0 THEN

{ The job has exceeded its job warning limit for CPU time.  Compute a new calculation interval that is the
{ smaller of the remining time until the job maximum limit is hit or the resource warning grace period (making
{ sure that the computed interval is not less than the minimum calculation interval).

          remaining_cpu_time := cpu_time_limit^.limit.job_abort_limit - cpu_time;
          IF remaining_cpu_time <= LOWERVALUE (calculation_interval) THEN
            calculation_interval := LOWERVALUE (calculation_interval);
          ELSEIF remaining_cpu_time >= sfc$warning_grace_period THEN
            calculation_interval := sfc$warning_grace_period;
          ELSE
            calculation_interval := remaining_cpu_time;
          IFEND;
        ELSE

{ Compute a calculation interval that is one half of the remaining time until the job hits the job warning
{ limit (making sure that the computed value is in the allowed range for the calculation interval).

          IF (remaining_cpu_time DIV 2) >= UPPERVALUE (calculation_interval) THEN
            calculation_interval := UPPERVALUE (calculation_interval);
          ELSEIF (remaining_cpu_time DIV 2) <= LOWERVALUE (calculation_interval) THEN
            calculation_interval := LOWERVALUE (calculation_interval);
          ELSE
            calculation_interval := remaining_cpu_time DIV 2;
          IFEND;
        IFEND;

{ Select the smaller of the SRU calculation interval or the CPU time calculation interval.

        IF sru_calculation_interval < calculation_interval THEN
          calculation_interval := sru_calculation_interval;
        IFEND;

{ Check permanent and temporary file space warning limits.

        IF sfv$dynamic_file_space_limits THEN
          IF (jmv$jcb.ijle_p^.statistics.perm_file_space >= jmv$jcb.perm_file_job_warning_limit) AND
                jmv$jcb.perm_file_job_warning_checking THEN
            warning := FALSE;
            sfp$change_file_space_limit (sfc$perm_file_space_limit, {warning_limit = } NIL,
                  {job_maximum_limit = } NIL, {accumulator = } NIL, {job_warning_checking = } ^warning);
            limit_chain_entry := sfp$job_limit_chain_entry (avc$pfs_limit_name);
            IF limit_chain_entry <> NIL THEN
              sfp$initiate_resource_condition (limit_chain_entry, ignore_status);
            IFEND;
          ELSEIF (jmv$jcb.ijle_p^.statistics.temp_file_space >= jmv$jcb.temp_file_job_warning_limit) AND
                jmv$jcb.temp_file_job_warning_checking THEN
            warning := FALSE;
            sfp$change_file_space_limit (sfc$temp_file_space_limit, {warning_limit = } NIL,
                  {job_maximum_limit = } NIL, {accumulator = } NIL, {job_warning_checking = } ^warning);
            limit_chain_entry := sfp$job_limit_chain_entry (avc$tfs_limit_name);
            IF limit_chain_entry <> NIL THEN
              sfp$initiate_resource_condition (limit_chain_entry, ignore_status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;

{ Reset the interval used to trigger the next SRU calculation.
{ Guarantee a non-zero value.

      tmp$set_flag_interval ((calculation_interval * 1000000) + 1000);

    END /monitor_statistics_handler/;

    osp$clear_job_signature_lock (avv$monitor_statistics_lock);

    #KEYPOINT (osk$exit, 0, avk$monitor_statistics_handler);

  PROCEND avp$monitor_statistics_handler;
?? OLDTITLE ??
MODEND avm$job_accounting_kernel;
*DECK DECK=AVM$MAKE_SCL_DATA_VALUES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Make SCL data values.' ??
MODULE avm$make_scl_data_values;

{ PURPOSE:
{   This module contains the code used to construct the SCL data values for SCL function processors that
{   return the values for validation fields.
?? NEWTITLE := 'Global declarations referenced by this module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avt$account_name
*copyc avt$date_time
*copyc avt$job_limit_information
*copyc avt$labeled_names_list
*copyc avt$name_list
*copyc avt$numeric_display_format
*copyc avt$project_name
*copyc avt$total_limit_information
*copyc cle$work_area_overflow
*copyc clt$work_area
*copyc osd$virtual_address
?? POP ??
*copyc clp$convert_string_to_file_ref
*copyc clp$make_boolean_value
*copyc clp$make_date_time_value
*copyc clp$make_file_value
*copyc clp$make_integer_value
*copyc clp$make_list_value
*copyc clp$make_name_value
*copyc clp$make_range_value
*copyc clp$make_real_value
*copyc clp$make_record_value
*copyc clp$make_string_value
*copyc clp$make_unspecified_value
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$make_acct_proj_scl_value', EJECT ??
{ PURPOSE:
{  Constructs an SCL data value for an account project validation field.

  PROCEDURE [XDCL, #GATE] avp$make_acct_proj_scl_value
    (    account: avt$account_name;
         project: avt$project_name;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    status.normal := TRUE;

    clp$make_record_value (2, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.field_values^ [1].name := 'ACCOUNT';
    clp$make_name_value (account, work_area, result^.field_values^ [1].value);
    IF result^.field_values^ [1].value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.field_values^ [2].name := 'PROJECT';
    clp$make_name_value (project, work_area, result^.field_values^ [2].value);
    IF result^.field_values^ [2].value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND avp$make_acct_proj_scl_value;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$make_accum_limit_scl_value', EJECT ??
{ PURPOSE:
{  Constructs an SCL data value for an accumulating limit validation field.

  PROCEDURE [XDCL, #GATE] avp$make_accum_limit_scl_value
    (    job_limit_information: avt$job_limit_information;
         total_limit_information: avt$total_limit_information;
         numeric_display_format: avt$numeric_display_format;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    VAR
      display_radix: boolean,
      radix: 2 .. 16;

    status.normal := TRUE;

    IF numeric_display_format.kind = avc$integer_format THEN
      radix := numeric_display_format.radix;
      display_radix := numeric_display_format.display_radix;
    ELSE
      radix := 10;
      display_radix := FALSE;
    IFEND;

    clp$make_record_value (4, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.field_values^ [1].name := 'JOB_WARNING_LIMIT';
    result^.field_values^ [2].name := 'JOB_MAXIMUM_LIMIT';
    result^.field_values^ [3].name := 'TOTAL_LIMIT';
    result^.field_values^ [4].name := 'TOTAL_ACCUMULATION';

    IF job_limit_information.job_limits_apply THEN
      clp$make_integer_value (job_limit_information.job_warning_limit, radix, display_radix, work_area,
            result^.field_values^ [1].value);
      IF result^.field_values^ [1].value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;

      clp$make_integer_value (job_limit_information.job_maximum_limit, radix, display_radix, work_area,
            result^.field_values^ [2].value);
      IF result^.field_values^ [2].value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    ELSE
      clp$make_unspecified_value (work_area, result^.field_values^ [1].value);
      IF result^.field_values^ [1].value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;

      clp$make_unspecified_value (work_area, result^.field_values^ [2].value);
      IF result^.field_values^ [2].value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

    IF total_limit_information.total_limit_applies THEN
      clp$make_integer_value (total_limit_information.total_limit, radix, display_radix, work_area,
            result^.field_values^ [3].value);
      IF result^.field_values^ [3].value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;

      clp$make_integer_value (total_limit_information.total_accumulation, radix, display_radix, work_area,
            result^.field_values^ [4].value);
      IF result^.field_values^ [4].value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    ELSE
      clp$make_unspecified_value (work_area, result^.field_values^ [3].value);
      IF result^.field_values^ [3].value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;

      clp$make_unspecified_value (work_area, result^.field_values^ [4].value);
      IF result^.field_values^ [4].value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

  PROCEND avp$make_accum_limit_scl_value;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$make_capability_scl_value', EJECT ??
{ PURPOSE:
{  Constructs an SCL data value for a capability validation field.

  PROCEDURE [XDCL, #GATE] avp$make_capability_scl_value
    (    capability: boolean;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    status.normal := TRUE;

    clp$make_boolean_value (capability, clc$true_false_boolean, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND avp$make_capability_scl_value;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$make_date_time_scl_value', EJECT ??
{ PURPOSE:
{  Constructs an SCL data value for a date_time validation field.

  PROCEDURE [XDCL, #GATE] avp$make_date_time_scl_value
    (    date_time: avt$date_time;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    VAR
      scl_date_time: clt$date_time;

    status.normal := TRUE;

    IF date_time.range THEN
      clp$make_range_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;

      scl_date_time.value := date_time.starting_value;
      scl_date_time.date_specified := date_time.date_specified;
      scl_date_time.time_specified := date_time.time_specified;
      clp$make_date_time_value (scl_date_time, work_area, result^.low_value);
      IF result^.low_value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;

      scl_date_time.value := date_time.ending_value;
      clp$make_date_time_value (scl_date_time, work_area, result^.high_value);
      IF result^.high_value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    ELSE
      scl_date_time.value := date_time.value;
      scl_date_time.date_specified := date_time.date_specified;
      scl_date_time.time_specified := date_time.time_specified;
      clp$make_date_time_value (scl_date_time, work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

  PROCEND avp$make_date_time_scl_value;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$make_file_scl_value', EJECT ??
{ PURPOSE:
{  Constructs an SCL data value for a file validation field.

  PROCEDURE [XDCL, #GATE] avp$make_file_scl_value
    (    file_reference: fst$file_reference;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    VAR
      parsed_file_reference: fst$parsed_file_reference;

    status.normal := TRUE;

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

    clp$make_file_value (parsed_file_reference.path (1, parsed_file_reference.complete_path_size), work_area,
          result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;

  PROCEND avp$make_file_scl_value;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$make_integer_scl_value', EJECT ??
{ PURPOSE:
{  Constructs an SCL data value for an integer validation field.

  PROCEDURE [XDCL, #GATE] avp$make_integer_scl_value
    (    integer_value: integer;
         numeric_display_format: avt$numeric_display_format;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    VAR
      display_radix: boolean,
      radix: 2 .. 16;

    status.normal := TRUE;

    IF numeric_display_format.kind = avc$integer_format THEN
      radix := numeric_display_format.radix;
      display_radix := numeric_display_format.display_radix;
    ELSE
      radix := 10;
      display_radix := FALSE;
    IFEND;

    clp$make_integer_value (integer_value, radix, display_radix, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;

  PROCEND avp$make_integer_scl_value;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$make_job_class_scl_value', EJECT ??
{ PURPOSE:
{  Constructs an SCL data value for a job class validation field.

  PROCEDURE [XDCL, #GATE] avp$make_job_class_scl_value
    (    batch_default: ost$name;
         interactive_default: ost$name;
         job_class_list: avt$name_list;
         job_class_list_size: avt$name_list_size;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    VAR
      index: avt$name_list_size,
      new_list_entry: ^clt$data_value,
      previous_list_entry: ^clt$data_value;

    status.normal := TRUE;

    clp$make_record_value (3, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.field_values^ [1].name := 'BATCH_DEFAULT';
    clp$make_name_value (batch_default, work_area, result^.field_values^ [1].value);
    IF result^.field_values^ [1].value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.field_values^ [2].name := 'INTERACTIVE_DEFAULT';
    clp$make_name_value (interactive_default, work_area, result^.field_values^ [2].value);
    IF result^.field_values^ [2].value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.field_values^ [3].name := 'JOB_CLASSES';
    FOR index := 1 TO job_class_list_size DO
      clp$make_list_value (work_area, new_list_entry);
      IF new_list_entry = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;

      clp$make_name_value (job_class_list [index], work_area, new_list_entry^.element_value);
      IF new_list_entry^.element_value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;

      IF index = 1 THEN
        result^.field_values^ [3].value := new_list_entry;
        previous_list_entry := new_list_entry;
      ELSE
        previous_list_entry^.link := new_list_entry;
        previous_list_entry := new_list_entry;
      IFEND;
    FOREND;

  PROCEND avp$make_job_class_scl_value;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$make_labeled_names_scl_valu', EJECT ??
{ PURPOSE:
{  Constructs an SCL data value for a labeled names validation field.

  PROCEDURE [XDCL, #GATE] avp$make_labeled_names_scl_valu
    (    labeled_names: ^avt$labeled_names_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    VAR
      index: avt$name_list_size,
      new_list_entry: ^clt$data_value,
      previous_list_entry: ^clt$data_value;

    status.normal := TRUE;

    FOR index := 1 TO UPPERBOUND (labeled_names^) DO
      clp$make_list_value (work_area, new_list_entry);
      IF new_list_entry = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;

      clp$make_record_value (2, work_area, new_list_entry^.element_value);
      IF new_list_entry^.element_value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;

      new_list_entry^.element_value^.field_values^ [1].name := 'LABEL';
      clp$make_name_value (labeled_names^ [index].label^, work_area,
            new_list_entry^.element_value^.field_values^ [1].value);
      IF new_list_entry^.element_value^.field_values^ [1].value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;

      new_list_entry^.element_value^.field_values^ [2].name := 'NAMES';
      avp$make_name_scl_value (labeled_names^ [index].names^,
            UPPERBOUND (labeled_names^ [index].names^), work_area,
            new_list_entry^.element_value^.field_values^ [2].value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF index = 1 THEN
        result := new_list_entry;
      ELSE
        previous_list_entry^.link := new_list_entry;
      IFEND;
      previous_list_entry := new_list_entry;

    FOREND;

  PROCEND avp$make_labeled_names_scl_valu;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$make_limit_scl_value', EJECT ??
{ PURPOSE:
{  Constructs an SCL data value for a limit validation field.

  PROCEDURE [XDCL, #GATE] avp$make_limit_scl_value
    (    limit_value: integer;
         numeric_display_format: avt$numeric_display_format;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    VAR
      display_radix: boolean,
      radix: 2 .. 16;

    status.normal := TRUE;

    IF numeric_display_format.kind = avc$integer_format THEN
      radix := numeric_display_format.radix;
      display_radix := numeric_display_format.display_radix;
    ELSE
      radix := 10;
      display_radix := FALSE;
    IFEND;

    clp$make_integer_value (limit_value, radix, display_radix, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;

  PROCEND avp$make_limit_scl_value;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$make_login_pw_scl_value', EJECT ??
{ PURPOSE:
{  Constructs an SCL data value for a login password validation field.

  PROCEDURE [XDCL, #GATE] avp$make_login_pw_scl_value
    (    expiration_date: ost$date_time;
         expiration_interval: pmt$time_increment;
         maximum_expiration_interval: pmt$time_increment;
         expiration_warning_interval: pmt$time_increment;
         expired_password_chg_interval: pmt$time_increment;
         change_date: ost$date_time;
         attribute_list: avt$name_list;
         attribute_list_size: avt$name_list_size;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    VAR
      date_time: clt$date_time,
      index: avt$name_list_size,
      new_list_entry: ^clt$data_value,
      previous_list_entry: ^clt$data_value;

    status.normal := TRUE;

    clp$make_record_value (7, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.field_values^ [1].name := 'EXPIRATION_DATE';
    date_time.value := expiration_date;
    date_time.date_specified := TRUE;
    date_time.time_specified := TRUE;
    clp$make_date_time_value (date_time, work_area, result^.field_values^ [1].value);
    IF result^.field_values^ [1].value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.field_values^ [2].name := 'EXPIRATION_INTERVAL';
    clp$make_integer_value (expiration_interval.day, 10, FALSE, work_area, result^.field_values^ [2].value);
    IF result^.field_values^ [2].value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.field_values^ [3].name := 'MAXIMUM_EXPIRATION_INTERVAL';
    clp$make_integer_value (maximum_expiration_interval.day, 10, FALSE, work_area,
          result^.field_values^ [3].value);
    IF result^.field_values^ [3].value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.field_values^ [4].name := 'EXPIRATION_WARNING_INTERVAL';
    clp$make_integer_value (expiration_warning_interval.day, 10, FALSE, work_area,
          result^.field_values^ [4].value);
    IF result^.field_values^ [4].value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.field_values^ [5].name := 'EXPIRED_PASSWORD_CHG_INTERVAL';
    clp$make_integer_value (expired_password_chg_interval.day, 10, FALSE, work_area, result^.
          field_values^ [5].value);
    IF result^.field_values^ [5].value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.field_values^ [6].name := 'CHANGE_DATE';
    date_time.value := change_date;
    date_time.date_specified := TRUE;
    date_time.time_specified := TRUE;
    clp$make_date_time_value (date_time, work_area, result^.field_values^ [6].value);
    IF result^.field_values^ [6].value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.field_values^ [7].name := 'ATTRIBUTES';
    FOR index := 1 TO attribute_list_size DO
      clp$make_list_value (work_area, new_list_entry);
      IF new_list_entry = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;

      clp$make_name_value (attribute_list [index], work_area, new_list_entry^.element_value);
      IF new_list_entry^.element_value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;

      IF index = 1 THEN
        result^.field_values^ [7].value := new_list_entry;
        previous_list_entry := new_list_entry;
      ELSE
        previous_list_entry^.link := new_list_entry;
        previous_list_entry := new_list_entry;
      IFEND;
    FOREND;

  PROCEND avp$make_login_pw_scl_value;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$make_name_scl_value', EJECT ??
{ PURPOSE:
{  Constructs an SCL data value for a name validation field.

  PROCEDURE [XDCL, #GATE] avp$make_name_scl_value
    (    name_list: avt$name_list;
         name_list_size: avt$name_list_size;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    VAR
      index: avt$name_list_size,
      new_list_entry: ^clt$data_value,
      previous_list_entry: ^clt$data_value;

    status.normal := TRUE;

    FOR index := 1 TO name_list_size DO
      clp$make_list_value (work_area, new_list_entry);
      IF new_list_entry = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;

      clp$make_name_value (name_list [index], work_area, new_list_entry^.element_value);
      IF new_list_entry^.element_value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;

      IF index = 1 THEN
        result := new_list_entry;
        previous_list_entry := new_list_entry;
      ELSE
        previous_list_entry^.link := new_list_entry;
        previous_list_entry := new_list_entry;
      IFEND;
    FOREND;

  PROCEND avp$make_name_scl_value;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$make_real_scl_value', EJECT ??
{ PURPOSE:
{  Constructs an SCL data value for a real validation field.

  PROCEDURE [XDCL, #GATE] avp$make_real_scl_value
    (    real_value: real;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    status.normal := TRUE;

    clp$make_real_value ($LONGREAL (real_value), UPPERVALUE (clt$real_number_digit_count), work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;

  PROCEND avp$make_real_scl_value;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$make_ring_priv_scl_value', EJECT ??
{ PURPOSE:
{  Constructs an SCL data value for a ring privilege validation field.

  PROCEDURE [XDCL, #GATE] avp$make_ring_priv_scl_value
    (    minimum_ring: ost$ring;
         nominal_ring: ost$ring;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    status.normal := TRUE;

    clp$make_record_value (2, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.field_values^ [1].name := 'MINIMUM_RING';
    clp$make_integer_value (minimum_ring, 10, FALSE, work_area, result^.field_values^ [1].value);
    IF result^.field_values^ [1].value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.field_values^ [2].name := 'NOMINAL_RING';
    clp$make_integer_value (nominal_ring, 10, FALSE, work_area, result^.field_values^ [2].value);
    IF result^.field_values^ [2].value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND avp$make_ring_priv_scl_value;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$make_string_scl_value', EJECT ??
{ PURPOSE:
{  Constructs an SCL data value for a string validation field.

  PROCEDURE [XDCL, #GATE] avp$make_string_scl_value
    (    string_value: ost$string;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    status.normal := TRUE;

    clp$make_string_value (string_value.value (1, string_value.size), work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;

  PROCEND avp$make_string_scl_value;
?? OLDTITLE ??
MODEND avm$make_scl_data_values;


*DECK DECK=AVM$PROCESS_PASSWORD_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Login Password Encryption ' ??
MODULE avm$process_password_attributes;

{ PURPOSE:
{   This module contains the procedure which is called whenever the password
{   for a user is changed.
{ DESIGN:
{   The released version of the AVP$PROCESS_PASSWORD_ATTRIBUTES procedure simply
{   returns a normal status to the caller.  Sites may modify this procedure to
{   alter password change requests.
{
{   The password attributes have been provided to allow sites the ability to
{   specify information, on a user by user basis, that can be used to control
{   the processing done by AVP$PROCESS_PASSWORD_ATTRIBUTES.
{
{   The following list contains some examples of the use of this procedure:
{
{     *  Prevent passwords that match the user name.
{     *  Prevent reuse of the old password.
{     *  Set a minimum length for passwords.
{     *  Prevent the use of easily guessed passwords.
?? NEWTITLE := 'Global declarations referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avt$login_password
*copyc avt$name_list_size
*copyc avt$validation_authority
*copyc ost$date_time
*copyc ost$status
*copyc ost$user_identification
?? POP ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] avp$process_password_attributes', EJECT ??
*copyc avh$process_password_attributes

  PROCEDURE [XDCL] avp$process_password_attributes
    (    validation_authority: avt$validation_authority;
         user_name: ost$user_name;
         last_password_change_date: ost$date_time;
         old_encrypted_password: avt$login_password;
         new_encrypted_password: avt$login_password;
         old_password: string(osc$max_name_size);
     VAR new_password: string(osc$max_name_size);
     VAR login_password_attributes: array [1 .. avc$maximum_name_list_size] OF ost$name;
     VAR number_of_password_attributes: 1 .. avc$maximum_name_list_size;
     VAR status: ost$status);

  status.normal := TRUE;

  PROCEND avp$process_password_attributes;

MODEND avm$process_password_attributes;
*DECK DECK=AVM$SECURITY_CMDS_AND_FUNCTIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Validation Commands' ??
MODULE avm$security_cmds_and_functions;

{ PURPOSE:
{   This module contains the command and function processors used to enforce secure operation.
{
{ DESIGN:
{   The command processors in this module convert the parameter values specified on the command into their
{   internal formats (when necessary) and call the appropriate security program interface.

?? NEWTITLE := 'Global declarations referenced by this module.', EJECT ??
*copyc avp$security_option
*copyc clp$evaluate_parameters
*copyc clp$make_boolean_value
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] avp$$security_option', EJECT ??

{ PURPOSE:
{   This is the function processor for $SECURITY_OPTION.
{
{ DESIGN:
{   AVP$SECURITY_OPTION is called to determine if the option is active.

  PROCEDURE [XDCL] avp$$security_option
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $security_option (
{   name: key
{       console_operation_only, secure_analysis, security_audit
{     keyend = $required
{   option: key
{       (active, a)
{     keyend = active
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (6),
      recend,
    recend := [
    [1,
    [89, 2, 28, 10, 2, 50, 44],
    clc$function, 2, 2, 1, 0, 0, 0, 0, ''], [
    ['NAME                           ',clc$nominal_entry, 1],
    ['OPTION                         ',clc$nominal_entry, 2]],
    [
{ 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, 118,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, 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, 81,
  clc$optional_default_parameter, 0, 6]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [3], [
    ['CONSOLE_OPERATION_ONLY         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['SECURE_ANALYSIS                ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['SECURITY_AUDIT                 ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [2], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'active']];

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

    CONST
      p$name = 1,
      p$option = 2;

    VAR
      option_value: boolean,
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;

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

    avp$security_option (pvt [p$name].value^.keyword_value, option_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_boolean_value (option_value, clc$true_false_boolean, work_area, result);

  PROCEND avp$$security_option;
?? OLDTITLE ??
MODEND avm$security_cmds_and_functions;

*DECK DECK=AVM$SECURITY_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Security interfaces' ??
MODULE avm$security_interfaces;

{ PURPOSE:
{   This module contains interfaces used for secure operation.

?? NEWTITLE := 'Glodal Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avc$max_template_record_size
*copyc ave$validation_interface_errors
*copyc ave$unknown_security_option
*copyc fst$file_access_options
*copyc osd$integer_limits
*copyc ost$caller_identifier
?? POP ??
*copyc avp$security_option_active
*copyc avp$configuration_administrator
*copyc avp$prevalidate_job
*copyc avp$system_administrator
*copyc avp$system_displays
*copyc avp$system_operator
*copyc clp$convert_string_to_name
*copyc osp$set_status_abnormal
*copyc osp$verify_system_privilege
*copyc oss$mainframe_paged_literal
*copyc avv$security_option_names
*copyc osv$lower_to_upper
?? OLDTITLE ??
?? NEWTITLE := 'avp$get_removable_media_access', EJECT ??
{
{ PURPOSE:
{   This interface returns the access to a removable media group for which a
{   user is validated.
{
  PROCEDURE [XDCL, #GATE] avp$get_removable_media_access
    (    user: ost$user_name;
         family: ost$family_name;
         removable_media_access_name: ost$name;
     VAR access: fst$file_access_options;
     VAR status: ost$status);

    VAR
      default_attributes: ^avt$validation_items,
      group_index: ost$positive_integers,
      name_index: ost$positive_integers,
      removable_media_group: ost$name;

    status.normal := TRUE;
    osp$verify_system_privilege;
    #translate (osv$lower_to_upper, user, user);
    #translate (osv$lower_to_upper, family, family);
    #translate (osv$lower_to_upper, removable_media_access_name, removable_media_group);
    access := $fst$file_access_options [];

    PUSH default_attributes: [1 .. 1];
    default_attributes^ [1].key := avc$labeled_names_key;
    default_attributes^ [1].labeled_names_field := avc$removable_media_access;
    PUSH default_attributes^ [1].work_area: [[REP avc$max_template_record_size OF cell]];
    RESET default_attributes^ [1].work_area;

    avp$prevalidate_job (user, family, { validation_attributes } NIL, default_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR group_index := 1 TO UPPERBOUND (default_attributes^ [1].labeled_names^) DO
      IF (default_attributes^ [1].labeled_names^ [group_index].label^ = removable_media_group) OR
            (default_attributes^ [1].labeled_names^ [group_index].label^ = 'ALL') THEN
        FOR name_index := 1 TO UPPERBOUND (default_attributes^ [1].labeled_names^ [group_index].names^) DO
          IF default_attributes^ [1].labeled_names^ [group_index].names^ [name_index] <> 'NONE' THEN
            IF default_attributes^ [1].labeled_names^ [group_index].names^ [name_index] = 'ALL' THEN
              access := -$fst$file_access_options [];
            ELSEIF default_attributes^ [1].labeled_names^ [group_index].names^ [name_index] = 'READ' THEN
              access := access + $fst$file_access_options [fsc$read, fsc$execute];
            ELSEIF default_attributes^ [1].labeled_names^ [group_index].names^ [name_index] = 'WRITE' THEN
              access := access + $fst$file_access_options [fsc$shorten, fsc$append, fsc$modify];
            IFEND;
          IFEND;
        FOREND;
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal ('AV', ave$missing_required_capability, 'REMOVABLE_MEDIA_ACCESS', status);

  PROCEND avp$get_removable_media_access;
?? OLDTITLE ??
?? NEWTITLE := 'avp$security_option', EJECT ??
{
{ PURPOSE:
{   This interface returns the current state of the specifed security option.
{

  PROCEDURE [XDCL, #GATE] avp$security_option
    (    option: avt$security_option_name;
     VAR active: boolean;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      security_option: avt$valid_security_options,
      verified_option_name: clt$name;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Verify that the caller has authority to get this information.

    IF ((caller_id.ring > osc$sj_ring_3) AND (NOT (avp$system_displays () OR avp$system_administrator () OR
          avp$system_operator () OR avp$configuration_administrator () ))) THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Verify that the string being passed in is a "name".

    clp$convert_string_to_name (option, verified_option_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR security_option := LOWERVALUE (security_option) TO UPPERVALUE (security_option) DO
      IF avv$security_option_names [security_option] = verified_option_name.value THEN
        active := avp$security_option_active (security_option);
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal ('AV', ave$unknown_security_option, verified_option_name.value, status);

  PROCEND avp$security_option;
?? OLDTITLE ??
MODEND avm$security_interfaces;
*DECK DECK=AVM$SECURITY_OPTIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Security Options' ??
MODULE avm$security_options;

{ PURPOSE:
{   This module contains the array of variables used to hold the security options.

  VAR
    avv$security_options: [XDCL, #GATE, oss$mainframe_wired] array [avt$valid_security_options] of
          avt$security_option := [[FALSE, FALSE], [FALSE, FALSE], [FALSE, FALSE]];

*copyc avt$security_option
*copyc avt$valid_security_options
*copyc oss$mainframe_wired

MODEND avm$security_options;
*DECK DECK=AVM$STORE_VALIDATION_INFO EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Store Validation Information' ??
MODULE avm$store_validation_info;
{
{ PURPOSE:
{   This module contains the interfaces used to store validation information
{ into job pageable at login.
{
{ DESIGN:
{   This module contains only the procedure AVP$STORE_VALIDATION_INFO.
{
*copyc avc$compile_test_code
*copyc dft$procedure_address_ordinal
?? PUSH (LISTEXT := ON) ??
?? NEWTITLE := '  Declarations', EJECT ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc avt$template_file_record
*copyc avt$validation_key
*copyc i#current_sequence_position
*copyc jmc$system_family
*copyc osp$get_set_name
*copyc ost$user_identification

  TYPE
    avt$server_get_val_info_input = record
      validation_level: avt$validation_level,
      family_name: ost$family_name,
      user_name: ost$user_name,
      account_name: avt$account_name,
      project_name: avt$project_name,
    recend;

  TYPE
    avt$server_get_val_info_output = record
      account_name: avt$account_name,
      project_name: avt$project_name,
    recend;

?? POP ??
?? OLDTITLE ??
?? NEWTITLE := '  XREF Procedures', EJECT ??
*copyc avp$close_validation_file
*copyc avp$get_field
*copyc avp$open_system_validation_file
*copyc avp$read_data_record
*copyc avp$validation_level
*copyc dfp$send_remote_procedure_call
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pfp$define_master_catalog
?? OLDTITLE ??
?? NEWTITLE := '  Static Variables', EJECT ??
*copyc oss$job_pageable
*copyc ost$heap
  ?IF avc$compile_test_code THEN

    VAR
      osv$job_pageable_heap: [XREF] ^ost$heap;

  ?ELSE
*copyc osv$job_pageable_heap
  ?IFEND

{ Varibles used to hold pointers to the validation information for a job.

  VAR
    avv$user_data_record: [XDCL, #GATE, oss$job_pageable] ^avt$template_file_record := NIL,
    avv$account_data_record: [XDCL, #GATE, oss$job_pageable] ^avt$template_file_record := NIL,
    avv$account_member_data_record: [XDCL, #GATE, oss$job_pageable] ^avt$template_file_record := NIL,
    avv$project_data_record: [XDCL, #GATE, oss$job_pageable] ^avt$template_file_record := NIL,
    avv$project_member_data_record: [XDCL, #GATE, oss$job_pageable] ^avt$template_file_record := NIL,
    avv$user_description_record: [XDCL, #GATE, oss$job_pageable] ^avt$template_file_record := NIL,
    avv$account_description_record: [XDCL, #GATE, oss$job_pageable] ^avt$template_file_record := NIL,
    avv$account_member_desc_record: [XDCL, #GATE, oss$job_pageable] ^avt$template_file_record := NIL,
    avv$project_description_record: [XDCL, #GATE, oss$job_pageable] ^avt$template_file_record := NIL,
    avv$project_member_desc_record: [XDCL, #GATE, oss$job_pageable] ^avt$template_file_record := NIL;

?? OLDTITLE ??
?? NEWTITLE := '  avp$store_validation_info', EJECT ??
{
{ PURPOSE:
{
{   This interfaces is used to store validation information for a job
{ into job pageable at login.
{
{ DESIGN:
{
{   The XDCLed variables used to hold pointers to the validation information
{ for the job are all initialized to NIL.
{
{   The validation file is opened.
{
{   The user validation information is placed into memory, and the pointer
{ variables to the information is set.
{
{   The system validation level determines whether account and project and
{ member information for this job is placed into memory, and if they are
{ the pointer variables to them are set.
{
{   The validation file is closed.
{

  PROCEDURE [XDCL, #GATE] avp$store_validation_info
    (    family_name: ost$family_name;
         user_name: ost$user_name;
     VAR account_name: avt$account_name;
     VAR project_name: avt$project_name;
     VAR status: ost$status);

    VAR
      data_size_to_send_to_server: dft$send_data_size,
      ignore_status: ost$status,
      p_data_received_from_server: dft$p_receive_data,
      p_data_to_send_to_server: dft$p_send_data,
      p_params_received_from_server: dft$p_receive_parameters,
      p_params_to_send_to_server: dft$p_send_parameters,
      params_size_to_send_to_server: dft$send_parameter_size,
      queue_entry_location: dft$rpc_queue_entry_location,
      server_locator: dft$server_location,
      set_name: stt$set_name,
      temporary_charge_id: pft$charge_id,
      validation_level: avt$validation_level;

?? NEWTITLE := '    client_store_validation_info' , EJECT ??

    PROCEDURE client_store_validation_info
      (    validation_level: avt$validation_level;
           family_name: ost$family_name;
           user_name: ost$user_name;
       VAR account_name: avt$account_name;
       VAR project_name: avt$project_name;
       VAR queue_entry_location: dft$rpc_queue_entry_location;
       VAR p_params_to_send_to_server: dft$p_send_parameters;
       VAR p_data_to_send_to_server: dft$p_send_data;
       VAR params_size_to_send_to_server: dft$send_parameter_size;
       VAR data_size_to_send_to_server: dft$send_data_size;
       VAR p_params_received_from_server: dft$p_receive_parameters;
       VAR p_data_received_from_server: dft$p_receive_data;
       VAR status: ost$status);

?? NEWTITLE := '      build_info_to_send_to_server', EJECT ??

      PROCEDURE build_info_to_send_to_server
        (    validation_level: avt$validation_level;
             family_name: ost$family_name;
             user_name: ost$user_name;
         VAR account_name: avt$account_name;
         VAR project_name: avt$project_name;
         VAR p_params_to_send_to_server: dft$p_send_parameters;
         VAR p_data_to_send_to_server: dft$p_send_data;
         VAR params_size_to_send_to_server: dft$send_parameter_size;
         VAR data_size_to_send_to_server: dft$send_data_size);

        VAR
          server_get_val_info_input: ^avt$server_get_val_info_input;

        params_size_to_send_to_server := 0;
        data_size_to_send_to_server := 0;

        NEXT server_get_val_info_input IN p_params_to_send_to_server;
        server_get_val_info_input^.validation_level := validation_level;
        server_get_val_info_input^.family_name := family_name;
        server_get_val_info_input^.user_name := user_name;
        server_get_val_info_input^.account_name := account_name;
        server_get_val_info_input^.project_name := project_name;

        params_size_to_send_to_server := i#current_sequence_position (p_params_to_send_to_server);

      PROCEND build_info_to_send_to_server;
?? OLDTITLE ??
?? NEWTITLE := '      extract_info_sent_from_server', EJECT ??

      PROCEDURE extract_info_sent_from_server
        (    validation_level: avt$validation_level;
         VAR p_params_received_from_server: dft$p_receive_parameters;
         VAR p_data_received_from_server: dft$p_receive_data;
         VAR account_name: avt$account_name;
         VAR project_name: avt$project_name);

        VAR
          server_get_val_info_output: ^avt$server_get_val_info_output;

?? NEWTITLE := '        retrieve_validation_info', EJECT ??

        PROCEDURE retrieve_validation_info
          (VAR p_data_received_from_server: dft$p_receive_data;
           VAR data_record: ^avt$template_file_record;
           VAR description_record: ^avt$template_file_record);

          VAR
            data_record_size: ^integer,
            description_record_size: ^integer,
            temp_data_record: ^avt$template_file_record,
            temp_description_record: ^avt$template_file_record;

{ Retrieve data record information.

          NEXT data_record_size IN p_data_received_from_server;
          IF data_record_size^ <> 0 THEN
            NEXT temp_data_record: [[REP data_record_size^ OF cell]] IN p_data_received_from_server;
            RESET temp_data_record;
            ALLOCATE data_record: [[REP data_record_size^ OF cell]] IN osv$job_pageable_heap^;
            RESET data_record;
            data_record^ := temp_data_record^;
          ELSE
            data_record := NIL;
          IFEND;

{ Retrieve description record information.

          NEXT description_record_size IN p_data_received_from_server;
          IF description_record_size^ <> 0 THEN
            NEXT temp_description_record: [[REP description_record_size^ OF cell]] IN
                  p_data_received_from_server;
            RESET temp_description_record;
            ALLOCATE description_record: [[REP description_record_size^ OF cell]] IN osv$job_pageable_heap^;
            RESET description_record;
            description_record^ := temp_description_record^;
          ELSE
            description_record := NIL;
          IFEND;

        PROCEND retrieve_validation_info;
?? OLDTITLE, EJECT ??
{ Retrieve the account and project information.

        NEXT server_get_val_info_output IN p_params_received_from_server;
        account_name := server_get_val_info_output^.account_name;
        project_name := server_get_val_info_output^.project_name;

{ Retrieve user information.

        retrieve_validation_info (p_data_received_from_server, avv$user_data_record,
              avv$user_description_record);

        IF validation_level > avc$user_level THEN

{ Retrieve account information.

          retrieve_validation_info (p_data_received_from_server, avv$account_data_record,
                avv$account_description_record);

{ Retrieve account member information.

          retrieve_validation_info (p_data_received_from_server, avv$account_member_data_record,
                avv$account_member_desc_record);

        IFEND;
        IF validation_level > avc$account_level THEN

{ Retrieve project information.

          retrieve_validation_info (p_data_received_from_server, avv$project_data_record,
                avv$project_description_record);

{ Retrieve project member information.

          retrieve_validation_info (p_data_received_from_server, avv$project_member_data_record,
                avv$project_member_desc_record);

        IFEND;

      PROCEND extract_info_sent_from_server;
?? OLDTITLE, EJECT ??
      status.normal := TRUE;

      build_info_to_send_to_server (validation_level, family_name, user_name, account_name, project_name,
            p_params_to_send_to_server, p_data_to_send_to_server, params_size_to_send_to_server,
            data_size_to_send_to_server);

      dfp$send_remote_procedure_call (queue_entry_location, dfc$get_validation_info,
            params_size_to_send_to_server, data_size_to_send_to_server, p_params_received_from_server,
            p_data_received_from_server, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      extract_info_sent_from_server (validation_level, p_params_received_from_server,
            p_data_received_from_server, account_name, project_name);

    PROCEND client_store_validation_info;
?? OLDTITLE ??
?? NEWTITLE := '    store_validation_info', EJECT ??

    PROCEDURE store_validation_info
      (    validation_level: avt$validation_level;
           family_name: ost$family_name;
           user_name: ost$user_name;
       VAR account_name: avt$account_name;
       VAR project_name: avt$project_name;
       VAR status: ost$status);

      VAR
        data_record_size: 0 .. avc$max_template_record_size,
        default_value: avt$field_value,
        description_record_name: ost$name,
        description_record_size: 0 .. avc$max_template_record_size,
        descriptive_text: ^avt$descriptive_text,
        field_value: avt$field_value,
        file_information: avt$template_file_information,
        ignore_status: ost$status,
        key: avt$validation_key,
        type_specification: avt$type_specification,
        utility_information: ^avt$utility_information;
?? NEWTITLE := '      read_data_record', EJECT ??
      PROCEDURE read_data_record
        (    key: avt$validation_key;
         VAR data_record: ^avt$template_file_record;
         VAR description_record: ^avt$template_file_record;
         VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          data_record_size: 0 .. avc$max_template_record_size,
          description_record_size: 0 .. avc$max_template_record_size,
          description_record_name: ost$name,
          field_count: avt$field_count;

{ Retrieve the size of the data and description record.

        data_record := NIL;
        description_record := NIL;
        avp$read_data_record (key.value, avc$read_access, TRUE, data_record, data_record_size,
              description_record, description_record_size, description_record_name, field_count,
              file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Allocate and read space until the data and description records are obtained.

        REPEAT
          ALLOCATE data_record: [[REP data_record_size OF cell]] IN osv$job_pageable_heap^;
          RESET data_record;
          ALLOCATE description_record: [[REP description_record_size OF cell]] IN osv$job_pageable_heap^;
          RESET description_record;
          avp$read_data_record (key.value, avc$read_access, TRUE, data_record, data_record_size,
                description_record, description_record_size, description_record_name, field_count,
                file_information, status);
          IF NOT status.normal THEN
            FREE data_record IN osv$job_pageable_heap^;
            FREE description_record IN osv$job_pageable_heap^;
            IF status.condition <> ave$work_area_full THEN
              RETURN;
            IFEND;
          IFEND;
        UNTIL status.normal;

      PROCEND read_data_record;
?? OLDTITLE, EJECT ??
      status.normal := TRUE;

{ Open the validation file.

      avp$open_system_validation_file (family_name, file_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    /get_validation_information/
      BEGIN

        key.account_name := avc$high_value_name;
        key.project_name := avc$high_value_name;
        key.user_name := user_name;
        read_data_record (key, avv$user_data_record, avv$user_description_record, file_information, status);
        IF NOT status.normal THEN
          IF status.condition = ave$unknown_record THEN

{ If the user specified does not exist on the validation file then return
{ a message that gives no information to the caller. (for security.)

            osp$set_status_abnormal ('AV', ave$bad_user_validation_info, '', status);
          IFEND;
          EXIT /get_validation_information/;
        IFEND;

{ If no account and/or project were specified get the defaults from the user
{ record.

        IF ((account_name = osc$null_name) OR (project_name = osc$null_name)) THEN
          avp$get_field (avc$default_account_project, avv$user_data_record, avv$user_description_record,
                {work_area=} NIL, field_value, type_specification, default_value, descriptive_text,
                utility_information, status);
          IF NOT status.normal THEN
            EXIT /get_validation_information/;
          IFEND;
          IF account_name = osc$null_name THEN
            account_name := field_value.account_name^;
          IFEND;
          IF project_name = osc$null_name THEN
            project_name := field_value.project_name^;
          IFEND;
        IFEND;

        IF validation_level > avc$user_level THEN

{ If running at account level or above get the account and account member
{ validation information.

{ Read the account record.

          key.account_name := account_name;
          key.project_name := osc$null_name;
          key.user_name := osc$null_name;
          read_data_record (key, avv$account_data_record, avv$account_description_record, file_information,
                status);
          IF NOT status.normal THEN
            IF status.condition = ave$unknown_record THEN
              osp$set_status_abnormal ('AV', ave$bad_user_validation_info, '', status);
            IFEND;
            EXIT /get_validation_information/;
          IFEND;

{ Read the account member record.

          key.account_name := account_name;
          key.project_name := osc$null_name;
          key.user_name := user_name;
          read_data_record (key, avv$account_member_data_record, avv$account_member_desc_record,
                file_information, status);
          IF NOT status.normal THEN
            IF status.condition = ave$unknown_record THEN
              status.normal := TRUE;
              key.account_name := account_name;
              key.project_name := osc$null_name;
              key.user_name := 'PUBLIC';
              read_data_record (key, avv$account_member_data_record, avv$account_member_desc_record,
                    file_information, status);
              IF NOT status.normal THEN
                IF status.condition = ave$unknown_record THEN
                  status.normal := TRUE;
                ELSE
                  EXIT /get_validation_information/;
                IFEND;
              IFEND;
            ELSE
              EXIT /get_validation_information/;
            IFEND;
          IFEND;
        IFEND;

        IF validation_level > avc$account_level THEN

{ If running at project level get the project, and project member
{ validation information.

{ Read the project record.

          key.account_name := account_name;
          key.project_name := project_name;
          key.user_name := osc$null_name;
          read_data_record (key, avv$project_data_record, avv$project_description_record, file_information,
                status);
          IF NOT status.normal THEN
            IF status.condition = ave$unknown_record THEN
              osp$set_status_abnormal ('AV', ave$bad_user_validation_info, '', status);
            IFEND;
            EXIT /get_validation_information/;
          IFEND;

{ Read the project member information if available.

          key.account_name := account_name;
          key.project_name := project_name;
          key.user_name := user_name;
          read_data_record (key, avv$project_member_data_record, avv$project_member_desc_record,
                file_information, status);
          IF NOT status.normal THEN
            IF status.condition = ave$unknown_record THEN
              status.normal := TRUE;
              key.account_name := account_name;
              key.project_name := project_name;
              key.user_name := 'PUBLIC';
              read_data_record (key, avv$project_member_data_record, avv$project_member_desc_record,
                    file_information, status);
              IF NOT status.normal THEN
                IF status.condition = ave$unknown_record THEN
                  status.normal := TRUE;
                ELSE
                  EXIT /get_validation_information/;
                IFEND;
              IFEND;
            ELSE
              EXIT /get_validation_information/;
            IFEND;
          IFEND;
        IFEND;

{ The specified user must be a member of the account at account level.

        IF validation_level = avc$account_level THEN
          IF avv$account_member_data_record = NIL THEN
            osp$set_status_abnormal ('AV', ave$bad_user_validation_info, '', status);
          IFEND;

{ The specified user must be a member of the account OR a member of the
{ project at project level.

        ELSEIF validation_level = avc$project_level THEN
          IF (avv$account_member_data_record = NIL) AND (avv$project_member_data_record = NIL) THEN
            osp$set_status_abnormal ('AV', ave$bad_user_validation_info, '', status);
          IFEND;
        IFEND;

      END /get_validation_information/;

      IF status.normal THEN
        avp$close_validation_file (file_information, status);
      ELSE
        avp$close_validation_file (file_information, ignore_status);
      IFEND;

    PROCEND store_validation_info;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT avp$store_validation_info;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    validation_level := avp$validation_level ();

    server_locator.server_location_selector := dfc$family_name;
    server_locator.family_name := family_name;
    ?IF avc$compile_test_code THEN
      status.normal := FALSE;
      status.condition := dfe$family_not_served;
    ?ELSE
    dfp$begin_ch_remote_proc_call (server_locator, FALSE, queue_entry_location, p_params_to_send_to_server,
          p_data_to_send_to_server, status);
    ?IFEND
    IF status.normal THEN

    /remote_procedure_active/
      BEGIN
        client_store_validation_info (validation_level, family_name, user_name, account_name, project_name,
              queue_entry_location, p_params_to_send_to_server, p_data_to_send_to_server,
              params_size_to_send_to_server, data_size_to_send_to_server, p_params_received_from_server,
              p_data_received_from_server, status);
        IF NOT status.normal THEN
          EXIT /remote_procedure_active/;
        IFEND;

      END /remote_procedure_active/;

      IF status.normal THEN
        dfp$end_ch_remote_proc_call (queue_entry_location, status);
      ELSE
        dfp$end_ch_remote_proc_call (queue_entry_location, ignore_status);
      IFEND;

    ELSEIF status.condition = dfe$family_not_served THEN
      status.normal := TRUE;

{ Get the validation info from the local validation file.

      store_validation_info (validation_level, family_name, user_name, account_name, project_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Create the master catalog if it does not currently exist.

      IF status.normal THEN
        ?IF NOT avc$compile_test_code THEN
          temporary_charge_id.account := account_name;
          temporary_charge_id.project := project_name;
          osp$get_set_name (family_name, set_name, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          pfp$define_master_catalog (set_name, family_name, user_name, temporary_charge_id, status);
          IF NOT status.normal THEN
            IF status.condition = pfe$duplicate_master_catalog THEN
              status.normal := TRUE;
            ELSE
              RETURN;
            IFEND;
          IFEND;
        ?IFEND
      IFEND;

    IFEND;

  PROCEND avp$store_validation_info;
?? OLDTITLE ??
?? NEWTITLE := '  avp$server_get_val_info', EJECT ??
{
{ PURPOSE:
{
{   This interfaces is used to get validation information for a job
{ from the server and send it back to the client.
{

  PROCEDURE [XDCL, #GATE] avp$server_get_val_info
    (VAR p_params_received_from_client: dft$p_receive_parameters;
     VAR p_data_received_from_client: dft$p_receive_data;
     VAR p_params_to_send_to_client: dft$p_send_parameters;
     VAR p_data_to_send_to_client: dft$p_send_data;
     VAR params_size_to_send_to_client: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      account_name: avt$account_name,
      family_name: ost$family_name,
      project_name: avt$project_name,
      set_name: stt$set_name,
      temporary_charge_id: pft$charge_id,
      user_name: ost$user_name,
      validation_level: avt$validation_level;
?? NEWTITLE := '    extract_info_sent_from_client', EJECT ??
    PROCEDURE extract_info_sent_from_client
      (VAR p_params_received_from_client: dft$p_receive_parameters;
       VAR p_data_received_from_client: dft$p_receive_data;
       VAR validation_level: avt$validation_level;
       VAR family_name: ost$family_name;
       VAR user_name: ost$user_name;
       VAR account_name: avt$account_name;
       VAR project_name: avt$project_name);

      VAR
        server_get_val_info_input: ^avt$server_get_val_info_input;

      NEXT server_get_val_info_input IN p_params_received_from_client;
      validation_level := server_get_val_info_input^.validation_level;
      family_name := server_get_val_info_input^.family_name;
      user_name := server_get_val_info_input^.user_name;
      account_name := server_get_val_info_input^.account_name;
      project_name := server_get_val_info_input^.project_name;

    PROCEND extract_info_sent_from_client;
?? OLDTITLE ??
?? NEWTITLE := '    build_info_to_send_to_client', EJECT ??

    PROCEDURE build_info_to_send_to_client
      (    validation_level: avt$validation_level;
           family_name: ost$family_name;
           user_name: ost$user_name;
       VAR account_name: avt$account_name;
       VAR project_name: avt$project_name;
       VAR p_params_to_send_to_client: dft$p_send_parameters;
       VAR p_data_to_send_to_client: dft$p_send_data;
       VAR params_size_to_send_to_client: dft$send_parameter_size;
       VAR data_size_to_send_to_client: dft$send_data_size;
       VAR status: ost$status);

      VAR
        server_get_val_info_output: ^avt$server_get_val_info_output;

      VAR
        account_data_record: ^avt$template_file_record,
        account_description_record: ^avt$template_file_record,
        account_member_data_record: ^avt$template_file_record,
        account_member_desc_record: ^avt$template_file_record,
        default_value: avt$field_value,
        description_record_name: ost$name,
        descriptive_text: ^avt$descriptive_text,
        field_value: avt$field_value,
        file_information: avt$template_file_information,
        ignore_status: ost$status,
        key: avt$validation_key,
        project_data_record: ^avt$template_file_record,
        project_description_record: ^avt$template_file_record,
        project_member_data_record: ^avt$template_file_record,
        project_member_desc_record: ^avt$template_file_record,
        save_sequence_position: dft$p_send_data,
        type_specification: avt$type_specification,
        user_data_record: ^avt$template_file_record,
        user_description_record: ^avt$template_file_record,
        utility_information: ^avt$utility_information;
?? NEWTITLE := '      read_data_record', EJECT ??
      PROCEDURE read_data_record
        (    key: avt$validation_key;
         VAR data_record: ^avt$template_file_record;
         VAR description_record: ^avt$template_file_record;
         VAR p_data_to_send_to_client: dft$p_send_data;
         VAR file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          data_record_size: ^integer,
          data_size: 0 .. avc$max_template_record_size,
          description_record_size: ^integer,
          description_size: 0 .. avc$max_template_record_size,
          description_record_name: ost$name,
          field_count: avt$field_count;

        status.normal := TRUE;

{ Retrieve the size of the data and description record.

        data_record := NIL;
        description_record := NIL;
        avp$read_data_record (key.value, avc$read_access, TRUE, data_record, data_size,
              description_record, description_size, description_record_name, field_count,
              file_information, status);
        IF NOT status.normal THEN
          NEXT data_record_size IN p_data_to_send_to_client;
          data_record_size^ := 0;
          NEXT description_record_size IN p_data_to_send_to_client;
          description_record_size^ := 0;
          data_record := NIL;
          description_record := NIL;
          RETURN;
        IFEND;

        REPEAT
          NEXT data_record_size IN p_data_to_send_to_client;
          data_record_size^ := data_size;
          NEXT data_record: [[REP data_size OF cell]] IN p_data_to_send_to_client;
          RESET data_record;
          NEXT description_record_size IN p_data_to_send_to_client;
          description_record_size^ := description_size;
          NEXT description_record: [[REP description_size OF cell]] IN p_data_to_send_to_client;
          RESET description_record;
          avp$read_data_record (key.value, avc$read_access, TRUE, data_record, data_size,
                description_record, description_size, description_record_name, field_count,
                file_information, status);
          IF NOT status.normal THEN
            IF status.condition <> ave$work_area_full THEN
              RETURN;
            ELSE
              RESET p_data_to_send_to_client TO data_record_size;
            IFEND;
          IFEND;
        UNTIL status.normal;

      PROCEND read_data_record;
?? OLDTITLE, EJECT ??
      status.normal := TRUE;

      params_size_to_send_to_client := 0;
      data_size_to_send_to_client := 0;

{ Return the account and project in case the defaults were used.

      NEXT server_get_val_info_output IN p_params_to_send_to_client;
      server_get_val_info_output^.account_name := account_name;
      server_get_val_info_output^.project_name := project_name;
      params_size_to_send_to_client := i#current_sequence_position (p_params_to_send_to_client);

{ Open the validation file.

      avp$open_system_validation_file (family_name, file_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    /get_validation_information/
      BEGIN

        key.account_name := avc$high_value_name;
        key.project_name := avc$high_value_name;
        key.user_name := user_name;
        read_data_record (key, user_data_record, user_description_record, p_data_to_send_to_client,
              file_information, status);
        IF NOT status.normal THEN
          IF status.condition = ave$unknown_record THEN

{ If the user specified does not exist on the validation file then return
{ a message that gives no information to the caller. (for security.)

            osp$set_status_abnormal ('AV', ave$bad_user_validation_info, '', status);
          IFEND;
          EXIT /get_validation_information/;
        IFEND;

{ If no account and/or project were specified get the defaults from the user
{ record.

        IF ((account_name = osc$null_name) OR (project_name = osc$null_name)) THEN
          avp$get_field (avc$default_account_project, user_data_record, user_description_record,
                {work_area=} NIL, field_value, type_specification, default_value, descriptive_text,
                utility_information, status);
          IF NOT status.normal THEN
            EXIT /get_validation_information/;
          IFEND;
          IF account_name = osc$null_name THEN
            account_name := field_value.account_name^;
            server_get_val_info_output^.account_name := account_name;
          IFEND;
          IF project_name = osc$null_name THEN
            project_name := field_value.project_name^;
            server_get_val_info_output^.project_name := project_name;
          IFEND;
        IFEND;

        IF validation_level > avc$user_level THEN

{ If running at account level or above get the account and account member
{ validation information.

{ Read the account record.

          key.account_name := account_name;
          key.project_name := osc$null_name;
          key.user_name := osc$null_name;
          read_data_record (key, account_data_record, account_description_record, p_data_to_send_to_client,
                file_information, status);
          IF NOT status.normal THEN
            IF status.condition = ave$unknown_record THEN
              osp$set_status_abnormal ('AV', ave$bad_user_validation_info, '', status);
            IFEND;
            EXIT /get_validation_information/;
          IFEND;

{ Read the account member record.

          key.account_name := account_name;
          key.project_name := osc$null_name;
          key.user_name := user_name;
          save_sequence_position := p_data_to_send_to_client;
          read_data_record (key, account_member_data_record, account_member_desc_record,
                p_data_to_send_to_client, file_information, status);
          IF NOT status.normal THEN
            IF status.condition = ave$unknown_record THEN
              status.normal := TRUE;
              key.account_name := account_name;
              key.project_name := osc$null_name;
              key.user_name := 'PUBLIC';
              p_data_to_send_to_client := save_sequence_position;
              read_data_record (key, account_member_data_record, account_member_desc_record,
                    p_data_to_send_to_client, file_information, status);
              IF NOT status.normal THEN
                IF status.condition = ave$unknown_record THEN
                  status.normal := TRUE;
                ELSE
                  EXIT /get_validation_information/;
                IFEND;
              IFEND;
            ELSE
              EXIT /get_validation_information/;
            IFEND;
          IFEND;
        IFEND;

        IF validation_level > avc$account_level THEN

{ If running at project level get the project, and project member
{ validation information.

{ Read the project record.

          key.account_name := account_name;
          key.project_name := project_name;
          key.user_name := osc$null_name;
          read_data_record (key, project_data_record, project_description_record, p_data_to_send_to_client,
                file_information, status);
          IF NOT status.normal THEN
            IF status.condition = ave$unknown_record THEN
              osp$set_status_abnormal ('AV', ave$bad_user_validation_info, '', status);
            IFEND;
            EXIT /get_validation_information/;
          IFEND;

{ Read the project member information if available.

          key.account_name := account_name;
          key.project_name := project_name;
          key.user_name := user_name;
          save_sequence_position := p_data_to_send_to_client;
          read_data_record (key, project_member_data_record, project_member_desc_record,
                p_data_to_send_to_client, file_information, status);
          IF NOT status.normal THEN
            IF status.condition = ave$unknown_record THEN
              status.normal := TRUE;
              key.account_name := account_name;
              key.project_name := project_name;
              key.user_name := 'PUBLIC';
              p_data_to_send_to_client := save_sequence_position;
              read_data_record (key, project_member_data_record, project_member_desc_record,
                    p_data_to_send_to_client, file_information, status);
              IF NOT status.normal THEN
                IF status.condition = ave$unknown_record THEN
                  status.normal := TRUE;
                ELSE
                  EXIT /get_validation_information/;
                IFEND;
              IFEND;
            ELSE
              EXIT /get_validation_information/;
            IFEND;
          IFEND;
        IFEND;

{ The specified user must be a member of the account at account level.

        IF validation_level = avc$account_level THEN
          IF account_member_data_record = NIL THEN
            osp$set_status_abnormal ('AV', ave$bad_user_validation_info, '', status);
          IFEND;

{ The specified user must be a member of the account OR a member of the
{ project at project level.

        ELSEIF validation_level = avc$project_level THEN
          IF (account_member_data_record = NIL) AND (project_member_data_record = NIL) THEN
            osp$set_status_abnormal ('AV', ave$bad_user_validation_info, '', status);
          IFEND;
        IFEND;

      END /get_validation_information/;

      IF status.normal THEN
        avp$close_validation_file (file_information, status);
      ELSE
        avp$close_validation_file (file_information, ignore_status);
      IFEND;

    PROCEND build_info_to_send_to_client;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Extract the information sent from the client.

    extract_info_sent_from_client (p_params_received_from_client, p_data_received_from_client,
          validation_level, family_name, user_name, account_name, project_name);

{ Store the validation information for the client.

    build_info_to_send_to_client (validation_level, family_name, user_name, account_name, project_name,
          p_params_to_send_to_client, p_data_to_send_to_client, params_size_to_send_to_client,
          data_size_to_send_to_client, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    data_size_to_send_to_client := i#current_sequence_position (p_data_to_send_to_client);

{ Create the master catalog if it does not currently exist.

    IF status.normal THEN
      ?IF NOT avc$compile_test_code THEN
        temporary_charge_id.account := account_name;
        temporary_charge_id.project := project_name;
        osp$get_set_name (family_name, set_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        pfp$define_master_catalog (set_name, family_name, user_name, temporary_charge_id, status);
        IF NOT status.normal THEN
          IF status.condition = pfe$duplicate_master_catalog THEN
            status.normal := TRUE;
          ELSE
            RETURN;
          IFEND;
        IFEND;
      ?IFEND
    IFEND;

  PROCEND avp$server_get_val_info;
?? OLDTITLE ??
MODEND avm$store_validation_info;
*DECK DECK=AVM$SYNCACC EXPAND=TRUE
.PROC,SYNCACC*I,\
  UN"NOS/VE FAMILY ADMINISTRATOR'S USERNAME" = (*F,*N=ADMINUN),
  PW"NOS/VE FAMILY ADMINISTRATOR'S PASSWORD" = (*F,*N=ADMINPW),
  FM"NOS/VE FAMILY"                          = (*F,*N=NVE),
  LID"NOS/VE LID"                            = (*F,*N=NVE),
  NOSFM"NOS FAMILY"                          = (*F,*N=),
.ENDPARM.
.HELP.
   SYNCACC GENERATES A PROFILE SOURCE FILE FOR THE DEFAULT FAMILY
   AND SUBMITS A JOB TO NOS/VE THAT SYNCHRONIZES NOS/VE PROJECT
   VALIDATIONS WITH NOS.
.HELP,UN.
   SPECIFIES THE USERNAME FOR NOS/VE'S FAMILY ADMINISTRATOR.
.HELP,PW.
   SPECIFIES THE PASSWORD FOR NOS/VE'S FAMILY ADMINISTRATOR.
.HELP,FM.
   SPECIFIES THE NOS/VE FAMILY FOR WHICH SYNCACC IS BEING RUN.  FM DEFAULTS
   TO THE NOS/VE FAMILY NVE.
.HELP,LID.
   SPECIFIES THE LID FOR NOS/VE.  THE DEFAULT LID IS NVE.
.HELP,NOSFM.
   SPECIFIES THE NOS FAMILY.  NOSFM DEFAULTS TO THE NOS DEFAULT FAMILY AND
   HAS NO EFFECT WHEN SYNCACC IS NOT RUN FROM SYSTEM ORIGIN.
.ENDHELP.
.IFE,OT.EQ.SYO,ISSUEUSER.
  USER,UN,PW,NOSFM.
.ENDIF,ISSUEUSER.
RETURN,SOURCE,NVEJOB.
PROFILE,OP=S.
REWIND,SOURCE,NVEJOB,FRONT,BACK.
COPY,FRONT,NVEJOB.
COMPASS,I=SQUASH,L=0,S,S=PSSTEXT.
LGO,SOURCE,NVEJOB.
COPY,BACK,NVEJOB.
PACK,NVEJOB.
ROUTE,NVEJOB,DC=IN,ST=LID,UJN=SYNCACC.
REVERT. NVE JOB SUBMITTED
.DATA,FRONT.
LOGIN USER=UN PASSWORD=PW FAMILY#_NAME=FM JOB#_CLASS=BATCH JOB#_NAME=SYNCACC
SET#_WORKING#_CATALOG $LOCAL
COLLECT#_TEXT PROFILE#_SOURCE UNTIL='**END SOURCE**'
.DATA,BACK.
**END SOURCE**
$SYSTEM.ACCOUNTING#_AND#_VALIDATION.COMMAND#_LIBRARY.GENERATE#_PROJECT#_UPDATES ..
      PS=PROFILE#_SOURCE AD=ADMV#_DIRECTIVES
SYSTEM#_OPERATOR#_UTILITY
  ADMINISTER#_VALIDATIONS
    INCLUDE#_FILE F=ADMV#_DIRECTIVES
  END#_ADMINISTER#_VALIDATIONS
QUIT
LOGOUT
.DATA,SQUASH
SQUASH
          IDENT  SQUASH
          ENTRY  SQUASH
          SST
          SYSCOM B1
          SPACE  4,10
****      SQUASH READS THE SOURCE OUTPUT FROM PROFILE AND PRODUCES AND
*         OUTPUT FILE THAT CONTAINS ONLY THE PROFILE DIRECTIVES NEEDED
*         BY THE NOS/VE GENERATE_PROJECT_UPDATES PROGRAM.
          SPACE  4,10
***       CALLING SEQUENCE.
*
*         SQUASH,SOURCE,NSOURCE.
*
*         SOURCE IS THE NAME OF THE PROFILE SOURCE FILE, SOURCE IS THE
*         DEFAULT NAME.
*
*         NSOURCE IS THE NAME OF THE SQAUSH OUTPUT, NSOURCE IS THE
*         DEFAULT NAME.
          SPACE  4,10
 BUFL     EQU    1001B
          SPACE  4,10
**        FETS.

 SOURCE   FILEB  IBUF,BUFL
 NSOURCE  FILEB  OBUF,BUFL
          SPACE  4,10
**        MAIN PROGRAM.
 SQUASH   SB1    1
          SA1    ARGR
          MX0    42
          BX7    X0*X1
          ZR     X7,SQU1     IF DEFAULT SOURCE FILE NAME
          SETFET SOURCE,(LFN=X7)
 SQU1     SA1    ARGR+1
          BX7    X0*X1
          ZR     X7,SQU2     IF DEFAULT NSOURCE FILE NAME
          SETFET NSOURCE,(LFN=X7)
 SQU2     READ   SOURCE
          WRITE  NSOURCE,*
 SQU3     READC  SOURCE,WBUF,8
          NZ     X1,SQU7     IF EOR/EOF/EOI
          SA1    WBUF
          SA2    SQUA        LIST OF VALID KEYWORDS
          MX3    60          KEYWORD MASK
 SQU4     BX6    X1-X2
          BX6    X3*X6
          ZR     X6,SQU6     IF KEYWORD MATCH
          SA2    A2+1
          ZR     X2,SQU5     IF END OF LIST
          EQ     SQU4        CHECK NEXT KEYWORD

 SQU5     MX4    -6          MASK FOR ACCUMULATOR/LIMIT NUMBER
          LX4    3*6
          BX6    X3-X4
          LX3    X4
          ZR     X6,SQU3     IF ACCUMULATOR/LIMITS CHECKED
          SA2    SQUB        ACCUMULATOR/LIMIT KEYWORDS
          EQ     SQU4        PERFORM KEYWORD MATCH

 SQU6     WRITEC NSOURCE,WBUF
          EQ     SQU3        READ NEXT SOURCE LINE

 SQU7     WRITER NSOURCE,R
          MESSAGE  (=C* PROFILE SOURCE SQUASHED.*),1
          ENDRUN

 SQUA     CON    10H    ACN =
          CON    10H    APN =
          CON    10H    AUN =
          CON    10H    MU  =
          CON    10H    SML =
          CON    10H    SMA =
          CON    10H    SIL =
          CON    10H    SIA =
          CON    0

 SQUB     CON    10H    AR* =
          CON    10H    LR* =
          CON    0
          SPACE  4,10
**        BUFFERS.


 WBUF     BSS    8
 IBUF     BSS    BUFL
 OBUF     BSS    BUFL
          END    SQUASH
/EOR
*DECK DECK=AVM$SYNCVAL EXPAND=TRUE
.PROC,SYNCVAL*I,\
  UN"NOS/VE FAMILY ADMINISTRATOR'S USERNAME" = (*F,*N=ADMINUN),
  PW"NOS/VE FAMILY ADMINISTRATOR'S PASSWORD" = (*F,*N=ADMINPW),
  FM"NOS/VE FAMILY"                          = (*F,*N=NVE),
  LID"NOS/VE LID"                            = (*F,*N=NVE),
  NOSFM"NOS FAMILY"                          = (*F,*N=),
.ENDPARM.
.HELP.
   SYNCVAL GENERATES A MODVAL SOURCE FILE FOR THE DEFAULT FAMILY (NVE)
   AND SUBMITS A JOB TO NOS/VE THAT SYNCHRONIZES THE VE VALIDATION
   FILE WITH THE NOS VALIDATION FILE.
.HELP,UN.
   SPECIFIES THE USERNAME FOR NOS/VE'S FAMILY ADMINISTRATOR.
.HELP,PW.
   SPECIFIES THE PASSWORD FOR NOS/VE'S FAMILY ADMINISTRATOR.
.HELP,FM.
   SPECIFIES THE NOS/VE FAMILY FOR WHICH SYNCVAL IS BEING RUN.  FM DEFAULTS
   TO THE NOS/VE FAMILY NVE.
.HELP,LID.
   SPECIFIES THE LID FOR NOS/VE.  THE DEFAULT LID IS NVE.
.HELP,NOSFM.
   SPECIFIES THE NOS FAMILY.  NOSFM DEFAULTS TO THE NOS DEFAULT FAMILY AND
   HAS NO EFFECT WHEN SYNCVAL IS NOT RUN FROM SYSTEM ORIGIN.
.ENDHELP.
.IFE,OT.EQ.SYO,ISSUEUSER.
  USER,UN,PW,NOSFM.
.ENDIF,ISSUEUSER.
RETURN,SOURCE,NVEJOB.
MODVAL,OP=S,FA.
REWIND,SOURCE,NVEJOB,FRONT,BACK.
COPY,FRONT,NVEJOB.
COMPASS,I=SQUASH,L=0,S,S=PSSTEXT.
LGO,SOURCE,NVEJOB.
COPY,BACK,NVEJOB.
PACK,NVEJOB.
ROUTE,NVEJOB,DC=IN,ST=LID,UJN=SYNCVAL.
REVERT. NVE JOB SUBMITTED
.DATA,FRONT.
LOGIN USER=UN PASSWORD=PW FAMILY#_NAME=FM JOB#_CLASS=BATCH JOB#_NAME=SYNCVAL
SET#_WORKING#_CATALOG $LOCAL
COLLECT#_TEXT MODVAL#_SOURCE UNTIL='**END SOURCE**'
.DATA,BACK.
**END SOURCE**
SET#_FILE#_ATTRIBUTES VE#_USERS OP=$BOI FC=LEGIBLE PF=CONTINUOUS
SET#_FILE#_ATTRIBUTES SORTED#_VE#_USERS OP=$BOI FC=LEGIBLE PF=CONTINUOUS
SYSTEM#_OPERATOR#_UTILITY
  ADMINISTER#_VALIDATIONS
    DISPLAY#_USER USER=ALL DO=NONE O=VE#_USERS
  END#_ADMINISTER#_VALIDATIONS
QUIT
COLLECT#_TEXT $LOCAL.SORT#_DIR
  SORT FROM=VE#_USERS
  SORT KEY=((1..31, MODVAL#_SEQUENCE))
  SORT SEQN=MODVAL#_SEQUENCE
  SORT SEQS=(' ')
  SORT SEQS=('A'..'Z')
  SORT SEQS=('0'..'9')
  SORT SEQS=('*')
  SORT TO=SORTED#_VE#_USERS
**
SORT DIR=$LOCAL.SORT#_DIR
$SYSTEM.ACCOUNTING#_AND#_VALIDATION.COMMAND#_LIBRARY.GENERATE#_USER#_UPDATES ..
      MS=MODVAL#_SOURCE VUL=SORTED#_VE#_USERS AD=ADMV#_DIRECTIVES
SYSTEM#_OPERATOR#_UTILITY
  ADMINISTER#_VALIDATIONS
    INCLUDE#_FILE F=ADMV#_DIRECTIVES
  END#_ADMINISTER#_VALIDATIONS
QUIT
LOGOUT
.DATA,SQUASH
SQUASH
          IDENT  SQUASH
          ENTRY  SQUASH
          SST
          SYSCOM B1
          SPACE  4,10
****      SQUASH READS THE SOURCE OUTPUT FROM MODVAL AND PRODUCES AND
*         OUTPUT FILE THAT CONTAINS ONLY THE MODVAL DIRECTIVES NEEDED
*         BY THE NOS/VE GENERATE_USER_UPDATES PROGRAM.
          SPACE  4,10
***       CALLING SEQUENCE.
*
*         SQUASH,SOURCE,NSOURCE.
*
*         SOURCE IS THE NAME OF THE MODVAL SOURCE FILE, SOURCE IS THE
*         DEFAULT NAME.
*
*         NSOURCE IS THE NAME OF THE SQAUSH OUTPUT, NSOURCE IS THE
*         DEFAULT NAME.
          SPACE  4,10
 BUFL     EQU    1001B
          SPACE  4,10
**        FETS.

 SOURCE   FILEB  IBUF,BUFL
 NSOURCE  FILEB  OBUF,BUFL
          SPACE  4,10
**        MAIN PROGRAM.
 SQUASH   SB1    1
          SA1    ARGR
          MX0    42
          BX7    X0*X1
          ZR     X7,SQU1     IF DEFAULT SOURCE FILE NAME
          SETFET SOURCE,(LFN=X7)
 SQU1     SA1    ARGR+1
          BX7    X0*X1
          ZR     X7,SQU2     IF DEFAULT NSOURCE FILE NAME
          SETFET NSOURCE,(LFN=X7)
 SQU2     READ   SOURCE
          WRITE  NSOURCE,*
 SQU3     READC  SOURCE,WBUF,8
          NZ     X1,SQU7     IF EOR/EOF/EOI
          SA1    WBUF
          MX0    -6
          LX1    6
          BX6    -X0*X1
          LX1    -6
          SX6    X6-1R/
          ZR     X6,SQU5     IF USERNAME
          SA2    SQUA        LIST OF VALID KEYWORDS
          BX6    X1-X2
          NZ     X6,SQU4     IF NOT *AW* KEYWORD
          SA1    WBUF+1      AW VALUE
          SA2    SQUC        AW VALUE LIST
 SQU4     BX6    X1-X2
          ZR     X6,SQU5     IF KEYWORD MATCH
          SA2    A2+B1
          ZR     X2,SQU3     IF END OF LIST
          EQ     SQU4        CHECK NEXT KEYWORD

 SQU5     SA2    SQUB
          BX6    X1-X2
          SA1    A1+B1
          NZ     X6,SQU6     IF NOT *AP*
          SA2    =10H_VEIAF
          BX6    X1-X2
          NZ     X6,SQU3     IF NOT *VEIAF* APPLICATION
 SQU6     WRITEC NSOURCE,WBUF
          EQ     SQU3        READ NEXT SOURCE LINE

 SQU7     WRITER NSOURCE,R
          MESSAGE  (=C* MODVAL SOURCE SQUASHED.*),1
          ENDRUN

*         MODVAL SOURCE KEYWORDS.

 SQUA     CON    10H     AW =           *AW* MUST BE FIRST
 SQUB     CON    10H     AP =
          CON    10H    VEW =
          CON    10H     CN =
          CON    10H     PN =
          CON    10H     UC =
          CON    10H     VM =
          CON    0

 SQUC     CON    10HCNVE                *AW* VALUES
          CON    10HCUCP
          CON    10HCCNR
          CON    0

          SPACE  4,10
**        BUFFERS.

 WBUF     BSS    8
 IBUF     BSS    BUFL
 OBUF     BSS    BUFL
          END    SQUASH
/EOR
*DECK DECK=AVM$TEMPLATE_FILE_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Template: Template File Manager' ??
MODULE avm$template_file_manager;

{ PURPOSE
{   This module contains the procedures used to create and maintain template
{   files.
{
{ DESIGN
{   The template file manager is a special purpose indexed sequential file
{   processor that was designed to manage validation information.  A template
{   file has two major components, a header and a heap.
{
{   The header is the first thing on the file and contains information about
{   the file and pointers to information stored in the heap.  Examples of the
{   kinds of information stored in the header are: the template file manager
{   version, index depth, relative pointer to the root index record, and a
{   directory of description records.
{
{   The heap is used to store the description records, data records, and index
{   records for the template file.
{
{   The template file manager can store up to 15 different kinds of data
{   records in a single template file.  Each kind of data record has a
{   description record associated with it.  The description record contains
{   the definitions of the fields that make up a particular kind of data
{   record.  For example, the description record associated with user
{   validation records would define all of the fields that appear in a user
{   validation record (e.g., user's prolog, user's SRU limit, and user's job
{   class validations).  While the description record for the account validation
{   records would contain the definition of the fields that appear in an
{   account validation record (e.g., account prolog, permanent file space limit
{   for the account and the SRU limit for the account).
{
{   Index records are used to find data records based on keys.  The pointers to
{   data records are always located in the last index record level.
{
{   The procedures in this module are grouped according to the object being
{   manipulated. The following objects are used for this grouping:
{
{            Template file
{            Description records and fields
{            Data records
{            Indexing structure
{            Miscellaneous helper procedures
{
?? NEWTITLE := '  Global declarations', EJECT ??
*copyc avc$compile_keypoints
*copyc avc$compile_test_code
?? PUSH (LISTEXT := ON) ??
*copyc avc$template_file_version
*copyc avc$type_specification_defaults
*copyc avc$unlimited_exp_interval
*copyc ave$template_file_damaged
*copyc ave$template_file_mgr_errors
*copyc avk$template_file_manager
*copyc avt$field_count
*copyc avt$field_kind_set
*copyc avt$field_value
*copyc avt$field_value_list
*copyc avt$type_specification
*copyc avt$template_file
*copyc avt$template_file_information
*copyc amp$get_segment_pointer
*copyc clp$convert_string_to_name
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc i#build_adaptable_seq_pointer
*copyc i#current_sequence_position
*copyc i#move
*copyc mmp$lock_segment
*copyc mmp$unlock_segment
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$append_status_real
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$reset_heap
*copyc osp$set_status_abnormal
*copyc osp$verify_heap
*copyc osp$verify_system_privilege
*copyc osv$lower_to_upper
*copyc pmp$compute_date_time
*copyc pmp$compute_date_time_increment
*copyc pmp$continue_to_cause
*copyc pmp$get_compact_date_time
*copyc pmp$get_os_version
?? POP ??
?? TITLE := '  Template File Interfaces', EJECT ??
?? NEWTITLE := '    [XDCL] avp$change_file_utility_info', EJECT ??
*copy avh$change_file_utility_info

  PROCEDURE [XDCL] avp$change_file_utility_info
    (    utility_information: ^avt$utility_information;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      ignored_status: ost$status,
      new_utility_information: ^avt$utility_information,
      original_utility_information: ^avt$utility_information,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$change_file_utility_info);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    osp$establish_block_exit_hndlr (^condition_handler);

  /change_utility_information/
    BEGIN
      avp$lock_template_file (avc$update_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$conflicting_lock THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'AVP$CHANGE_FILE_UTILITY_INFO',
                status);
        IFEND;
        EXIT /change_utility_information/;
      IFEND;

      original_utility_information := #PTR (template_file_header^.utility_information, template_file_heap^);

      IF utility_information = NIL THEN
        IF original_utility_information <> NIL THEN
          FREE original_utility_information IN template_file_heap^;
          template_file_header^.utility_information := NIL;
        IFEND;
      ELSEIF (original_utility_information = NIL) OR (#SIZE (original_utility_information^) <>
            #SIZE (utility_information^)) THEN
        ALLOCATE new_utility_information: [[REP #SIZE (utility_information^) OF cell]] IN template_file_heap^;
        IF new_utility_information = NIL THEN
          osp$set_status_abnormal ('AV', ave$template_file_full, '', status);
          EXIT /change_utility_information/
        IFEND;
        new_utility_information^ := utility_information^;
        template_file_header^.utility_information := #REL (new_utility_information, template_file_heap^);
        IF original_utility_information <> NIL THEN
          FREE original_utility_information IN template_file_heap^;
        IFEND;
      ELSE
        original_utility_information^ := utility_information^;
      IFEND;
    END /change_utility_information/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$change_file_utility_info);
    ?IFEND

  PROCEND avp$change_file_utility_info;
?? TITLE := '    [XDCL] avp$close_template_file', EJECT ??
*copy avh$close_template_file

  PROCEDURE [XDCL] avp$close_template_file
    (VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      ignored_status: ost$status;

    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$close_template_file);
    ?IFEND

    IF file_information.locked THEN
      avp$unlock_template_file (file_information, ignored_status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    fsp$close_file (file_information.file_id, status);

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$close_template_file);
    ?IFEND

  PROCEND avp$close_template_file;
?? TITLE := '    [XDCL] avp$get_template_file_header', EJECT ??
*copy avh$get_template_file_header

  PROCEDURE [XDCL] avp$get_template_file_header
    (VAR header: avt$template_file_header;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      ignored_status: ost$status,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$get_template_file_header);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    osp$establish_block_exit_hndlr (^condition_handler);

    avp$lock_template_file (avc$read_access, lock_set_by_this_procedure, template_file_header,
          template_file_heap, file_information, status);
    IF status.normal THEN
      header := template_file_header^;
    IFEND;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$get_template_file_header);
    ?IFEND

  PROCEND avp$get_template_file_header;
?? TITLE := '    [XDCL] avp$get_file_utility_info', EJECT ??
*copy avh$get_file_utility_info

  PROCEDURE [XDCL] avp$get_file_utility_info
    (VAR utility_information: ^avt$utility_information;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      ignored_status: ost$status,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap,
      utility_information_in_file: ^avt$utility_information,
      utility_information_pointer: ^avt$utility_information;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$get_file_utility_info);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    osp$establish_block_exit_hndlr (^condition_handler);

  /get_file_utility_info/
    BEGIN
      avp$lock_template_file (avc$read_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        EXIT /get_file_utility_info/;
      IFEND;

      utility_information_in_file := #PTR (template_file_header^.utility_information, template_file_heap^);

      IF utility_information_in_file <> NIL THEN
        NEXT utility_information_pointer: [[REP #SIZE (utility_information_in_file^) OF cell]] IN
              utility_information;
        IF utility_information_pointer = NIL THEN
          osp$set_status_abnormal ('AV', ave$work_area_full, 'AVP$GET_FILE_UTILITY_INFO', status);
          EXIT /get_file_utility_info/;
        IFEND;
        utility_information_pointer^ := utility_information_in_file^;
      IFEND;
    END /get_file_utility_info/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$get_file_utility_info);
    ?IFEND

  PROCEND avp$get_file_utility_info;
?? TITLE := '    [XDCL] avp$get_file_utility_info_size', EJECT ??
*copy avh$get_file_utility_info_size

  PROCEDURE [XDCL] avp$get_file_utility_info_size
    (VAR utility_information_size: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      file_utility_information: ^avt$utility_information,
      ignored_status: ost$status,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$get_file_utility_info_size);
    ?IFEND

    lock_set_by_this_procedure := TRUE;
    #SPOIL (lock_set_by_this_procedure);

    osp$establish_block_exit_hndlr (^condition_handler);

  /get_file_utility_info_size/
    BEGIN
      avp$lock_template_file (avc$read_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        EXIT /get_file_utility_info_size/;
      IFEND;

      file_utility_information := #PTR (template_file_header^.utility_information, template_file_heap^);

      IF file_utility_information = NIL THEN
        utility_information_size := 0;
      ELSE
        utility_information_size := #SIZE (file_utility_information^);
      IFEND;
    END /get_file_utility_info_size/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$get_file_utility_info_size);
    ?IFEND

  PROCEND avp$get_file_utility_info_size;
?? TITLE := '    [XDCL] avp$lock_template_file', EJECT ??
*copy avh$lock_template_file

  PROCEDURE [XDCL] avp$lock_template_file
    (    desired_lock_type: avt$template_file_lock_type;
     VAR lock_set_by_this_procedure: boolean;
     VAR template_file_header: ^avt$template_file_header;
     VAR template_file_heap: ^avt$template_file_heap;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a condition handler that is used to ignore interactive, job resource
{   and user defined conditions while setting a lock on the template file.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      CASE condition.selector OF
      = ifc$interactive_condition =
        RETURN;
      = jmc$job_resource_condition =
        RETURN;
      = pmc$user_defined_condition =
        RETURN;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$lock_template_file);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    osp$establish_condition_handler (^condition_handler, FALSE);

  /lock/
    BEGIN
      IF file_information.locked THEN
        IF (desired_lock_type = avc$update_access) AND (file_information.lock_type <> avc$update_access) THEN
          osp$set_status_abnormal ('AV', ave$conflicting_lock, '', status);
          EXIT /lock/;
        ELSE
          build_template_pointers (file_information, template_file_header, template_file_heap, status);
        IFEND;
      ELSE
        build_template_pointers (file_information, template_file_header, template_file_heap, status);
        IF NOT status.normal THEN
          EXIT /lock/;
        IFEND;

        ?IF NOT avc$compile_test_code THEN
          IF desired_lock_type = avc$read_access THEN
            mmp$lock_segment (template_file_heap, mmc$lus_lock_for_read, osc$wait, status);
          ELSE
            mmp$lock_segment (template_file_heap, mmc$lus_lock_for_write, osc$wait, status);
          IFEND;
          IF NOT status.normal THEN
            EXIT /lock/;
          IFEND;
        ?IFEND

        file_information.locked := TRUE;
        file_information.lock_type := desired_lock_type;
        lock_set_by_this_procedure := TRUE;
        #SPOIL (lock_set_by_this_procedure);
      IFEND;
    END /lock/;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$lock_template_file);
    ?IFEND

  PROCEND avp$lock_template_file;
?? TITLE := '    [XDCL] avp$open_template_file', EJECT ??
*copy avh$open_template_file

  PROCEDURE [XDCL] avp$open_template_file
    (    file_name: fst$file_reference;
         create_file: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      attachment_options: ^fst$attachment_options,
      ignored_status: ost$status,
      index: 1 .. avc$maximum_desc_record_count,
      segment_pointer: amt$segment_pointer,
      template_file: ^avt$template_file,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file is closed if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      fsp$close_file (file_information.file_id, ignored_status);

    PROCEND condition_handler;
?? TITLE := '      initialize_template_file', EJECT ??

{ PURPOSE:
{   This procedure is used to initialize a template file that was created as a
{   result of the open request.

    PROCEDURE initialize_template_file
      (VAR template_file: ^avt$template_file;
       VAR template_file_header: ^avt$template_file_header;
       VAR template_file_heap: ^avt$template_file_heap;
       VAR status: ost$status);

      status.normal := TRUE;

      NEXT template_file_header IN template_file;
      IF template_file_header = NIL THEN
        osp$set_status_abnormal ('AV', ave$template_file_full, ' ', status);
        RETURN;
      IFEND;

      template_file_header^.version_identifier := avc$template_file_version;
      template_file_header^.utility_information := NIL;
      template_file_header^.next_system_supplied_field_id := 1;
      template_file_header^.root_index_record := NIL;
      template_file_header^.first_index_record := NIL;
      template_file_header^.index_depth := 0;
      template_file_header^.description_record_count := 0;
      FOR index := 1 TO avc$maximum_desc_record_count DO
        template_file_header^.description_directory [index].name := osc$null_name;
        template_file_header^.description_directory [index].record_pointer := NIL;
        template_file_header^.description_directory [index].utility_information := NIL;
      FOREND;

      NEXT template_file_heap IN template_file;
      IF template_file_heap = NIL THEN
        osp$set_status_abnormal ('AV', ave$template_file_full, '', status);
        RETURN;
      IFEND;
      ?IF avc$compile_test_code THEN
        RESET template_file_heap^;
      ?ELSE
        osp$reset_heap (template_file_heap, #SIZE (template_file_heap^), FALSE, 0);
      ?IFEND

    PROCEND initialize_template_file;
?? TITLE := '      verify_template_file', EJECT ??

{ PURPOSE:
{   This procedure is used to check if the file that has been opened looks like
{   a template file.

    PROCEDURE verify_template_file
      (VAR template_file: ^avt$template_file;
       VAR template_file_header: ^avt$template_file_header;
       VAR template_file_heap: ^avt$template_file_heap;
       VAR status: ost$status);

      status.normal := TRUE;

      NEXT template_file_header IN template_file;
      IF template_file_header = NIL THEN
        osp$set_status_abnormal ('AV', ave$not_a_template_file, '', status);
        RETURN;
      IFEND;

      IF template_file_header^.version_identifier <> avc$template_file_version THEN
        osp$set_status_abnormal ('AV', ave$not_a_template_file, '', status);
        RETURN;
      IFEND;

      NEXT template_file_heap IN template_file;
      IF template_file_heap = NIL THEN
        osp$set_status_abnormal ('AV', ave$not_a_template_file, '', status);
        RETURN;
      IFEND;

    PROCEND verify_template_file;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$open_template_file);
    ?IFEND

    PUSH attachment_options: [1 .. 3];
    attachment_options^ [1].selector := fsc$create_file;
    attachment_options^ [1].create_file := create_file;
    attachment_options^ [2].selector := fsc$access_and_share_modes;
    attachment_options^ [2].access_modes.selector := fsc$specific_access_modes;
    attachment_options^ [2].access_modes.value := $fst$file_access_options
          [fsc$append, fsc$modify, fsc$shorten, fsc$read];
    IF create_file THEN
      attachment_options^ [2].share_modes.selector := fsc$determine_from_access_modes;
    ELSE
      attachment_options^ [2].share_modes.selector := fsc$specific_share_modes;
      attachment_options^ [2].share_modes.value := $fst$file_access_options
            [fsc$append, fsc$modify, fsc$shorten, fsc$read, fsc$execute];
    IFEND;
    attachment_options^ [3].selector := fsc$wait_for_attachment;
    attachment_options^ [3].wait_for_attachment.wait := osc$wait;
    attachment_options^ [3].wait_for_attachment.wait_time := fsc$longest_wait_time;

    fsp$open_file (file_name, amc$segment, attachment_options, NIL, NIL, NIL, NIL, file_information.file_id,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

  /open/
    BEGIN
      amp$get_segment_pointer (file_information.file_id, amc$sequence_pointer, segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /open/;
      IFEND;

      RESET segment_pointer.sequence_pointer;
      template_file := segment_pointer.sequence_pointer;

      IF create_file THEN
        initialize_template_file (template_file, template_file_header, template_file_heap, status);
      ELSE
        verify_template_file (template_file, template_file_header, template_file_heap, status);
        IF NOT status.normal THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, file_name, status);
        IFEND;
      IFEND;
      IF NOT status.normal THEN
        EXIT /open/;
      IFEND;

      file_information.file_name := file_name;
      file_information.last_key_accessed := ' ';
      file_information.locked := FALSE;
      file_information.segment_number := #SEGMENT (template_file);
      file_information.size := #SIZE (template_file^);
      file_information.template_file_header := #REL (template_file_header, template_file^);
      file_information.template_file_heap := #REL (template_file_heap, template_file^);
    END /open/;

    IF NOT status.normal THEN
      fsp$close_file (file_information.file_id, ignored_status);
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$open_template_file);
    ?IFEND

  PROCEND avp$open_template_file;
?? TITLE := '    [XDCL] avp$restructure_template_file', EJECT ??
*copy avh$restructure_template_file

  PROCEDURE [XDCL] avp$restructure_template_file
    (    old_file_name: fst$file_reference;
         new_file_name: fst$file_reference;
     VAR status: ost$status);

    VAR
      ignored_status: ost$status,
      lock_set_by_this_procedure: boolean,
      new_file_header: ^avt$template_file_header,
      new_file_heap: ^avt$template_file_heap,
      new_file_information: avt$template_file_information,
      old_file_header: ^avt$template_file_header,
      old_file_heap: ^avt$template_file_heap,
      old_file_information: avt$template_file_information;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This condition handler is used to close the template files if an error
{   occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      avp$close_template_file (old_file_information, ignored_status);
      avp$close_template_file (new_file_information, ignored_status);

    PROCEND condition_handler;
?? TITLE := '      copy_data_records', EJECT ??

{ PURPOSE:
{   This procedure is used to copy all of the data records from the old file
{   onto the new file.

    PROCEDURE copy_data_records
      (    old_file_header: ^avt$template_file_header;
           old_file_heap: ^avt$template_file_heap;
       VAR new_file_header: ^avt$template_file_header;
       VAR new_file_heap: ^avt$template_file_heap;
       VAR status: ost$status);

      VAR
        data_record_header: ^avt$template_file_record_header,
        data_record_in_old_file: ^avt$template_file_record,
        data_record_work_area: ^avt$template_file_record,
        description_record: ^avt$template_file_record,
        new_data_record: ^avt$template_file_record,
        new_data_record_size: 0 .. avc$max_template_record_size,
        old_file_index: ^avt$template_file_index,
        old_file_index_record: ^avt$template_file_record,
        old_file_index_record_header: ^avt$template_file_record_header,
        position: avt$template_index_key_count;

      status.normal := TRUE;

      old_file_index_record := #PTR (old_file_header^.first_index_record, old_file_heap^);

      PUSH data_record_work_area: [[REP avc$max_template_record_size OF cell]];

      WHILE old_file_index_record <> NIL DO
        build_index_record_pointers (old_file_index_record, old_file_index_record_header, old_file_index,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        FOR position := 1 TO old_file_index_record_header^.keys_in_use DO
          data_record_in_old_file := #PTR (old_file_index^ [position].record_pointer, old_file_heap^);

          get_record_header (data_record_in_old_file, data_record_header, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          RESET data_record_work_area;

          description_record := #PTR (old_file_header^.description_directory
                [data_record_header^.description_record_index].record_pointer, old_file_heap^);

          rebuild_data_record (data_record_in_old_file, NIL, data_record_header^.description_record_index,
                description_record, data_record_work_area, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          new_data_record_size := i#current_sequence_position (data_record_work_area);

          RESET data_record_work_area;

          NEXT new_data_record: [[REP new_data_record_size OF cell]] IN data_record_work_area;
          IF new_data_record = NIL THEN
            corrupted_sequence ('AVP$RESTRUCTURE_FILE', 'NEW_DATA_RECORD', 'DATA_RECORD_WORK_AREA', status);
            RETURN;
          IFEND;

          insert_key (old_file_index^ [position].key, new_data_record, new_file_header, new_file_heap,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
        old_file_index_record := #PTR (old_file_index_record_header^.next_index_record, old_file_heap^);
      WHILEND;

    PROCEND copy_data_records;
?? TITLE := '      copy_description_records', EJECT ??

{ PURPOSE:
{   This procedure copies all of the description records and thier associated
{   utility information fields from the old file to the new file.

    PROCEDURE copy_description_records
      (    old_file_header: ^avt$template_file_header;
           old_file_heap: ^avt$template_file_heap;
       VAR new_file_header: ^avt$template_file_header;
       VAR new_file_heap: ^avt$template_file_heap;
       VAR status: ost$status);

      VAR
        description_record_count: 0 .. avc$maximum_desc_record_count,
        new_description_record: ^avt$template_file_record,
        new_desc_record_utility_info: ^avt$utility_information,
        old_description_record: ^avt$template_file_record,
        old_desc_record_utility_info: ^avt$utility_information;

      status.normal := TRUE;
      new_file_header^.description_record_count := old_file_header^.description_record_count;

      FOR description_record_count := 1 TO old_file_header^.description_record_count DO
        new_file_header^.description_directory [description_record_count].name :=
              old_file_header^.description_directory [description_record_count].name;
        old_description_record := #PTR (old_file_header^.description_directory [description_record_count].
              record_pointer, old_file_heap^);

        ALLOCATE new_description_record: [[REP #SIZE (old_description_record^) OF cell]] IN new_file_heap^;
        IF new_description_record = NIL THEN
          osp$set_status_abnormal ('AV', ave$template_file_full, '', status);
          RETURN;
        IFEND;
        new_description_record^ := old_description_record^;
        new_file_header^.description_directory [description_record_count].
              record_pointer := #REL (new_description_record, new_file_heap^);

        old_desc_record_utility_info := #PTR (old_file_header^.
              description_directory [description_record_count].utility_information, old_file_heap^);
        IF old_desc_record_utility_info <> NIL THEN
          ALLOCATE new_desc_record_utility_info: [[REP #SIZE (old_desc_record_utility_info^) OF cell]] IN
                new_file_heap^;
          IF new_desc_record_utility_info = NIL THEN
            osp$set_status_abnormal ('AV', ave$template_file_full, '', status);
            RETURN;
          IFEND;
          new_desc_record_utility_info^ := old_desc_record_utility_info^;
          new_file_header^.description_directory [description_record_count].
                utility_information := #REL (new_desc_record_utility_info, new_file_heap^);
        IFEND;
      FOREND;

    PROCEND copy_description_records;
?? TITLE := '      copy_file_utility_information', EJECT ??

{ PURPOSE:
{   This procedure copies the utility information field from the old file to
{   the new file.

    PROCEDURE copy_file_utility_information
      (    old_file_header: ^avt$template_file_header;
           old_file_heap: ^avt$template_file_heap;
       VAR new_file_header: ^avt$template_file_header;
       VAR new_file_heap: ^avt$template_file_heap;
       VAR status: ost$status);

      VAR
        new_file_utility_information: ^avt$utility_information,
        old_file_utility_information: ^avt$utility_information;

      status.normal := TRUE;

      old_file_utility_information := #PTR (old_file_header^.utility_information, old_file_heap^);

      IF old_file_utility_information <> NIL THEN
        ALLOCATE new_file_utility_information: [[REP #SIZE (old_file_utility_information^) OF cell]] IN
              new_file_heap^;
        IF new_file_utility_information = NIL THEN
          osp$set_status_abnormal ('AV', ave$template_file_full, '', status);
          RETURN;
        IFEND;

        new_file_utility_information^ := old_file_utility_information^;
        new_file_header^.utility_information := #REL (new_file_utility_information, new_file_heap^);
      IFEND;

    PROCEND copy_file_utility_information;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$restructure_template_file);
    ?IFEND

    osp$verify_system_privilege;

    avp$open_template_file (old_file_name, FALSE, old_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$open_template_file (new_file_name, TRUE, new_file_information, status);
    IF NOT status.normal THEN
      avp$close_template_file (old_file_information, ignored_status);
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

  /restructure_template_file/
    BEGIN
      avp$lock_template_file (avc$read_access, lock_set_by_this_procedure, old_file_header, old_file_heap,
            old_file_information, status);
      IF NOT status.normal THEN
        EXIT /restructure_template_file/;
      IFEND;

      avp$lock_template_file (avc$update_access, lock_set_by_this_procedure, new_file_header, new_file_heap,
            new_file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$conflicting_lock THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'AVP$RESTRUCTURE_TEMPLATE_FILE',
                status);
        IFEND;
        EXIT /restructure_template_file/;
      IFEND;

      new_file_header^.next_system_supplied_field_id := old_file_header^.next_system_supplied_field_id;

      copy_file_utility_information (old_file_header, old_file_heap, new_file_header, new_file_heap, status);
      IF NOT status.normal THEN
        EXIT /restructure_template_file/;
      IFEND;

      copy_description_records (old_file_header, old_file_heap, new_file_header, new_file_heap, status);
      IF NOT status.normal THEN
        EXIT /restructure_template_file/;
      IFEND;

      copy_data_records (old_file_header, old_file_heap, new_file_header, new_file_heap, status);
    END /restructure_template_file/;

    IF status.normal THEN
      avp$close_template_file (old_file_information, status);
    ELSE
      avp$close_template_file (old_file_information, ignored_status);
    IFEND;

    IF status.normal THEN
      avp$close_template_file (new_file_information, status);
    ELSE
      avp$close_template_file (new_file_information, ignored_status);
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$restructure_template_file);
    ?IFEND

  PROCEND avp$restructure_template_file;
?? TITLE := '    [XDCL] avp$unlock_template_file', EJECT ??
*copy avh$unlock_template_file

  PROCEDURE [XDCL] avp$unlock_template_file
    (VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a condition handler that is used to ignore interactive, job resource
{   and user defined conditions while clearing a lock on the template file.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      CASE condition.selector OF
      = ifc$interactive_condition =
        RETURN;
      = jmc$job_resource_condition =
        RETURN;
      = pmc$user_defined_condition =
        RETURN;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$unlock_template_file);
    ?IFEND

    osp$establish_condition_handler (^condition_handler, FALSE);

  /unlock/
    BEGIN
      IF file_information.locked THEN
        build_template_pointers (file_information, template_file_header, template_file_heap, status);
        IF NOT status.normal THEN
          EXIT /unlock/;
        IFEND;

        ?IF NOT avc$compile_test_code THEN
          mmp$unlock_segment (template_file_heap, mmc$lus_none, osc$nowait, status);
        ?IFEND
        IF status.normal THEN
          file_information.locked := FALSE;
        IFEND;
      IFEND;
    END /unlock/;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$unlock_template_file);
    ?IFEND

  PROCEND avp$unlock_template_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] avp$verify_template_heap', EJECT ??
*copy avh$verify_template_heap

  PROCEDURE [XDCL] avp$verify_template_heap
    (    family_name: ost$name;
     VAR file_information: {input, output} avt$template_file_information;
     VAR status: ost$status);

    VAR
      heap_okay: boolean,
      ignore_status: ost$status,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignore_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    heap_okay := FALSE;
    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    osp$establish_block_exit_hndlr (^condition_handler);

  /verify_template_heap/
    BEGIN
      avp$lock_template_file (avc$update_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$conflicting_lock THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'AVP$VERIFY_TEMPLATE_HEAP',
                status);
        IFEND;
        EXIT /verify_template_heap/;
      IFEND;

      osp$verify_heap (template_file_heap, heap_okay);
      IF NOT heap_okay THEN
        osp$set_status_abnormal ('AV', ave$template_file_damaged, family_name, status);
      IFEND;
    END /verify_template_heap/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignore_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;
  PROCEND avp$verify_template_heap;
?? OLDTITLE ??
?? TITLE := '  Description record and field interfaces', EJECT ??
?? NEWTITLE := '    [XDCL] avp$change_desc_utility_info', EJECT ??
*copy avh$change_desc_utility_info

  PROCEDURE [XDCL] avp$change_desc_utility_info
    (    description_record_name: ost$name;
         utility_information: ^avt$utility_information;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      description_directory_entry: ^avt$description_directory_entry,
      ignored_status: ost$status,
      new_utility_information: ^avt$utility_information,
      original_utility_information: ^avt$utility_information,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap,
      verified_desc_record_name: clt$name;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$change_desc_utility_info);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    clp$convert_string_to_name (description_record_name, verified_desc_record_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

  /change_utility_information/
    BEGIN
      avp$lock_template_file (avc$update_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$conflicting_lock THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'AVP$CHANGE_DESC_UTILITY_INFO',
                status);
        IFEND;
        EXIT /change_utility_information/;
      IFEND;

      get_description_directory_entry (verified_desc_record_name.value, template_file_header,
            template_file_heap, description_directory_entry, status);
      IF NOT status.normal THEN
        EXIT /change_utility_information/;
      IFEND;

      original_utility_information := #PTR (description_directory_entry^.utility_information,
            template_file_heap^);

      IF utility_information = NIL THEN
        IF original_utility_information <> NIL THEN
          FREE original_utility_information IN template_file_heap^;
          description_directory_entry^.utility_information := NIL;
        IFEND;
      ELSEIF (original_utility_information = NIL) OR (#SIZE (original_utility_information^) <>
            #SIZE (utility_information^)) THEN
        ALLOCATE new_utility_information: [[REP #SIZE (utility_information^) OF cell]] IN template_file_heap^;
        IF new_utility_information = NIL THEN
          osp$set_status_abnormal ('AV', ave$template_file_full, '', status);
          EXIT /change_utility_information/
        IFEND;
        new_utility_information^ := utility_information^;
        description_directory_entry^.utility_information :=
              #REL (new_utility_information, template_file_heap^);
        IF original_utility_information <> NIL THEN
          FREE original_utility_information IN template_file_heap^;
        IFEND;
      ELSE
        original_utility_information^ := utility_information^;
      IFEND;
    END /change_utility_information/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$change_desc_utility_info);
    ?IFEND

  PROCEND avp$change_desc_utility_info;
?? TITLE := '    [XDCL] avp$change_field', EJECT ??
*copy avh$change_field

  PROCEDURE [XDCL] avp$change_field
    (    field_name: ost$name;
         description_record_name: ost$name;
         type_specification: avt$type_specification;
         default_value: avt$field_value;
         descriptive_text: ^avt$descriptive_text;
         utility_information: ^avt$utility_information;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      deleted_field: boolean,
      description_directory_entry: ^avt$description_directory_entry,
      ignored_status: ost$status,
      index: 0 .. avc$maximum_field_count,
      lock_set_by_this_procedure: boolean,
      new_description_record_header: ^avt$template_file_record_header,
      new_description_record: ^avt$template_file_record,
      new_field_description: ^avt$field_description,
      new_field_directory: ^avt$field_directory,
      original_desc_record_header: ^avt$template_file_record_header,
      original_description_record: ^avt$template_file_record,
      original_field_description: ^avt$field_description,
      original_field_directory: ^avt$field_directory,
      original_field_directory_entry: ^avt$field_directory_entry,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap,
      verified_desc_record_name: clt$name,
      verified_field_name: clt$name,
      description_record_work_area: ^avt$template_file_record;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$change_field);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    clp$convert_string_to_name (description_record_name, verified_desc_record_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_string_to_name (field_name, verified_field_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH description_record_work_area: [[REP avc$max_template_record_size OF cell]];
    RESET description_record_work_area;

    osp$establish_block_exit_hndlr (^condition_handler);

  /change_field/
    BEGIN
      avp$lock_template_file (avc$update_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$conflicting_lock THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'AVP$CHANGE_FIELD', status);
        IFEND;
        EXIT /change_field/;
      IFEND;

      get_description_directory_entry (verified_desc_record_name.value, template_file_header,
            template_file_heap, description_directory_entry, status);
      IF NOT status.normal THEN
        EXIT /change_field/;
      IFEND;
      original_description_record := #PTR (description_directory_entry^.record_pointer, template_file_heap^);

      get_record_header (original_description_record, original_desc_record_header, status);
      IF NOT status.normal THEN
        EXIT /change_field/;
      IFEND;

      get_field_directory (original_description_record, original_field_directory, status);
      IF NOT status.normal THEN
        EXIT /change_field/;
      IFEND;

      get_field_directory_entry (verified_field_name.value, original_field_directory,
            original_field_directory_entry, deleted_field, status);
      IF NOT status.normal THEN
        EXIT /change_field/;
      IFEND;

      NEXT new_description_record_header IN description_record_work_area;
      IF new_description_record_header = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        EXIT /change_field/;
      IFEND;

      new_description_record_header^.kind := avc$description_record;
      new_description_record_header^.name := original_desc_record_header^.name;

      NEXT new_field_directory: [1 .. UPPERBOUND (original_field_directory^)] IN description_record_work_area;
      IF new_field_directory = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        EXIT /change_field/;
      IFEND;
      new_description_record_header^.field_directory_pointer :=
            #REL (new_field_directory, description_record_work_area^);

      FOR index := 1 TO UPPERBOUND (original_field_directory^) DO
        new_field_directory^ [index] := original_field_directory^ [index];
        IF verified_field_name.value = original_field_directory^ [index].name THEN
          build_field_description (type_specification, default_value, descriptive_text, utility_information,
                new_field_description, description_record_work_area, status);
          IF NOT status.normal THEN
            IF status.condition = ave$work_area_full THEN
              osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
            IFEND;
            EXIT /change_field/;
          IFEND;
          new_field_directory^ [index].description := #REL (new_field_description,
                description_record_work_area^);
        ELSE
          original_field_description := #PTR (original_field_directory^ [index].description,
                original_description_record^);
          NEXT new_field_description: [[REP #SIZE (original_field_description^) OF cell]] IN
                description_record_work_area;
          IF new_field_description = NIL THEN
            osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
            EXIT /change_field/;
          IFEND;
          new_field_description^ := original_field_description^;
          new_field_directory^ [index].description := #REL (new_field_description,
                description_record_work_area^);
        IFEND;
      FOREND;

      ALLOCATE new_description_record: [[REP i#current_sequence_position (description_record_work_area) OF
            cell]] IN template_file_heap^;
      IF new_description_record = NIL THEN
        osp$set_status_abnormal ('AV', ave$template_file_full, '', status);
        EXIT /change_field/
      IFEND;

      RESET new_description_record;
      i#move (description_record_work_area, new_description_record,
            i#current_sequence_position (description_record_work_area));
      description_directory_entry^.record_pointer := #REL (new_description_record, template_file_heap^);
      FREE original_description_record IN template_file_heap^;
    END /change_field/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$change_field);
    ?IFEND

  PROCEND avp$change_field;
?? TITLE := '    [XDCL] avp$change_field_name', EJECT ??
*copy avh$change_field_name

  PROCEDURE [XDCL] avp$change_field_name
    (    field_name: ost$name;
         description_record_name: ost$name;
         new_field_name: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      deleted_field: boolean,
      description_record: ^avt$template_file_record,
      field_directory: ^avt$field_directory,
      field_directory_entry: ^avt$field_directory_entry,
      ignored_status: ost$status,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap,
      verified_desc_record_name: clt$name,
      verified_field_name: clt$name,
      verified_new_field_name: clt$name;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$change_field_name);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    clp$convert_string_to_name (description_record_name, verified_desc_record_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_string_to_name (field_name, verified_field_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_string_to_name (new_field_name, verified_new_field_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

  /change_field_name/
    BEGIN
      avp$lock_template_file (avc$update_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$conflicting_lock THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'AVP$CHANGE_FIELD_NAME', status);
        IFEND;
        EXIT /change_field_name/;
      IFEND;

      get_description_record (verified_desc_record_name.value, template_file_header, template_file_heap,
            description_record, status);
      IF NOT status.normal THEN
        EXIT /change_field_name/;
      IFEND;

      get_field_directory (description_record, field_directory, status);
      IF NOT status.normal THEN
        EXIT /change_field_name/;
      IFEND;

      get_field_directory_entry (verified_new_field_name.value, field_directory, field_directory_entry,
            deleted_field, status);
      IF status.normal THEN
        IF deleted_field THEN
          osp$set_status_abnormal ('AV', ave$field_was_deleted, verified_new_field_name.value, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                field_directory_entry^.delete_status.os_version_when_deleted, status);
        ELSE
          osp$set_status_abnormal ('AV', ave$field_already_exists, verified_new_field_name.value, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, verified_desc_record_name.value,
                status);
        IFEND;
        EXIT /change_field_name/;
      ELSEIF status.condition <> ave$unknown_field THEN
        EXIT /change_field_name/;
      ELSE
        status.normal := TRUE;
      IFEND;

      get_field_directory_entry (verified_field_name.value, field_directory, field_directory_entry,
            deleted_field, status);
      IF NOT status.normal THEN
        EXIT /change_field_name/;
      IFEND;

      field_directory_entry^.name := verified_new_field_name.value;

      sort_field_directory (field_directory^);
    END /change_field_name/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$change_field_name);
    ?IFEND

  PROCEND avp$change_field_name;
?? TITLE := '    [XDCL] avp$create_description_record', EJECT ??
*copy avh$create_description_record

  PROCEDURE [XDCL] avp$create_description_record
    (    description_record_name: ost$name;
         utility_information: ^avt$utility_information;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      description_record: ^avt$template_file_record,
      description_record_header: ^avt$template_file_record_header,
      description_record_index: 1 .. avc$maximum_desc_record_count,
      description_record_utility_info: ^avt$utility_information,
      ignored_status: ost$status,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap,
      verified_desc_record_name: clt$name;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$create_description_record);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    clp$convert_string_to_name (description_record_name, verified_desc_record_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

  /create_description_record/
    BEGIN
      avp$lock_template_file (avc$update_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$conflicting_lock THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'AVP$CREATE_DESCRIPTION_RECORD',
                status);
        IFEND;
        EXIT /create_description_record/;
      IFEND;

      IF template_file_header^.description_record_count = avc$maximum_desc_record_count THEN
        osp$set_status_abnormal ('AV', ave$desc_record_directory_full, '', status);
        EXIT /create_description_record/;
      IFEND;

      get_description_record_index (verified_desc_record_name.value, template_file_header,
            description_record_index, status);
      IF status.normal THEN
        osp$set_status_abnormal ('AV', ave$desc_record_already_exists, description_record_name, status);
        EXIT /create_description_record/;
      ELSEIF status.condition = ave$unknown_description_record THEN
        status.normal := TRUE;
      ELSE
        EXIT /create_description_record/;
      IFEND;

      ALLOCATE description_record: [[REP #SIZE (avt$template_file_record_header) OF cell]] IN
            template_file_heap^;
      IF description_record = NIL THEN
        osp$set_status_abnormal ('AV', ave$template_file_full, '', status);
        EXIT /create_description_record/;
      IFEND;

      RESET description_record;

      NEXT description_record_header IN description_record;
      IF description_record_header = NIL THEN
        osp$set_status_abnormal ('AV', ave$template_file_full, '', status);
        EXIT /create_description_record/;
      IFEND;

      description_record_header^.kind := avc$description_record;
      description_record_header^.name := description_record_name;
      description_record_header^.field_directory_pointer := NIL;

      template_file_header^.description_record_count := template_file_header^.description_record_count + 1;
      template_file_header^.description_directory [template_file_header^.description_record_count].name :=
            verified_desc_record_name.value;
      template_file_header^.description_directory [template_file_header^.description_record_count].
            record_pointer := #REL (description_record, template_file_heap^);
      template_file_header^.description_directory [template_file_header^.description_record_count].
            utility_information := NIL;

      IF utility_information <> NIL THEN
        ALLOCATE description_record_utility_info: [[REP #SIZE (utility_information^) OF cell]] IN
              template_file_heap^;
        IF description_record_utility_info = NIL THEN
          osp$set_status_abnormal ('AV', ave$template_file_full, '', status);
          EXIT /create_description_record/;
        IFEND;

        template_file_header^.description_directory [template_file_header^.description_record_count].
              utility_information := #REL (description_record_utility_info, template_file_heap^);
        RESET description_record_utility_info;
        description_record_utility_info^ := utility_information^;
      IFEND;
    END /create_description_record/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$create_description_record);
    ?IFEND

  PROCEND avp$create_description_record;
?? TITLE := '    [XDCL] avp$create_field', EJECT ??
*copy avh$create_field

  PROCEDURE [XDCL] avp$create_field
    (    field_name: ost$name;
         description_record_name: ost$name;
         type_specification: avt$type_specification;
         default_value: avt$field_value;
         descriptive_text: ^avt$descriptive_text;
         utility_information: ^avt$utility_information;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      description_directory_entry: ^avt$description_directory_entry,
      description_record_work_area: ^avt$template_file_record,
      ignored_status: ost$status,
      index: 0 .. avc$maximum_field_count,
      lock_set_by_this_procedure: boolean,
      new_description_record_header: ^avt$template_file_record_header,
      new_description_record: ^avt$template_file_record,
      new_field_description: ^avt$field_description,
      new_field_directory: ^avt$field_directory,
      original_desc_record_header: ^avt$template_file_record_header,
      original_description_record: ^avt$template_file_record,
      original_field_description: ^avt$field_description,
      original_field_directory: ^avt$field_directory,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap,
      verified_desc_record_name: clt$name,
      verified_field_name: clt$name;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$create_field);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    clp$convert_string_to_name (description_record_name, verified_desc_record_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_string_to_name (field_name, verified_field_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH description_record_work_area: [[REP avc$max_template_record_size OF cell]];
    RESET description_record_work_area;

    osp$establish_block_exit_hndlr (^condition_handler);

  /create_field/
    BEGIN
      avp$lock_template_file (avc$update_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$conflicting_lock THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'AVP$CREATE_FIELD', status);
        IFEND;
        EXIT /create_field/;
      IFEND;

      get_description_directory_entry (verified_desc_record_name.value, template_file_header,
            template_file_heap, description_directory_entry, status);
      IF NOT status.normal THEN
        EXIT /create_field/;
      IFEND;
      original_description_record := #PTR (description_directory_entry^.record_pointer, template_file_heap^);

      get_record_header (original_description_record, original_desc_record_header, status);
      IF NOT status.normal THEN
        EXIT /create_field/;
      IFEND;

      get_field_directory (original_description_record, original_field_directory, status);
      IF NOT status.normal THEN
        EXIT /create_field/;
      IFEND;

      NEXT new_description_record_header IN description_record_work_area;
      IF new_description_record_header = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        EXIT /create_field/;
      IFEND;

      new_description_record_header^.kind := avc$description_record;
      new_description_record_header^.name := original_desc_record_header^.name;

      IF original_field_directory <> NIL THEN
        NEXT new_field_directory: [1 .. UPPERBOUND (original_field_directory^) + 1] IN
              description_record_work_area;
        IF new_field_directory = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          EXIT /create_field/;
        IFEND;

        FOR index := 1 TO UPPERBOUND (original_field_directory^) DO
          IF verified_field_name.value = original_field_directory^ [index].name THEN
            osp$set_status_abnormal ('AV', ave$field_already_exists, verified_field_name.value, status);
            EXIT /create_field/;
          ELSE
            new_field_directory^ [index] := original_field_directory^ [index];
            original_field_description := #PTR (original_field_directory^ [index].description,
                  original_description_record^);
            NEXT new_field_description: [[REP #SIZE (original_field_description^) OF cell]] IN
                  description_record_work_area;
            IF new_field_description = NIL THEN
              osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
              EXIT /create_field/;
            IFEND;
            new_field_description^ := original_field_description^;
            new_field_directory^ [index].description := #REL (new_field_description,
                  description_record_work_area^);
          IFEND;
        FOREND;
      ELSE
        NEXT new_field_directory: [1 .. 1] IN description_record_work_area;
        IF new_field_directory = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          EXIT /create_field/;
        IFEND;
      IFEND;

      index := UPPERBOUND (new_field_directory^);
      new_field_directory^ [index].name := verified_field_name.value;
      new_field_directory^ [index].kind := avc$nominal_entry;
      new_field_directory^ [index].system_supplied_field_id :=
            template_file_header^.next_system_supplied_field_id;
      new_field_directory^ [index].delete_status.deleted := FALSE;

      build_field_description (type_specification, default_value, descriptive_text, utility_information,
            new_field_description, description_record_work_area, status);
      IF NOT status.normal THEN
        IF status.condition = ave$work_area_full THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        IFEND;
        EXIT /create_field/;
      IFEND;
      new_field_directory^ [index].description := #REL (new_field_description, description_record_work_area^);

      template_file_header^.next_system_supplied_field_id :=
            template_file_header^.next_system_supplied_field_id + 1;

      sort_field_directory (new_field_directory^);

      new_description_record_header^.field_directory_pointer :=
            #REL (new_field_directory, description_record_work_area^);

      ALLOCATE new_description_record: [[REP i#current_sequence_position (description_record_work_area) OF
            cell]] IN template_file_heap^;
      IF new_description_record = NIL THEN
        osp$set_status_abnormal ('AV', ave$template_file_full, '', status);
        EXIT /create_field/
      IFEND;

      RESET new_description_record;

      i#move (description_record_work_area, new_description_record,
            i#current_sequence_position (description_record_work_area));

      description_directory_entry^.record_pointer := #REL (new_description_record, template_file_heap^);

      IF original_description_record <> NIL THEN
        FREE original_description_record IN template_file_heap^;
      IFEND;
    END /create_field/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$create_field);
    ?IFEND

  PROCEND avp$create_field;
?? TITLE := '    [XDCL] avp$delete_field', EJECT ??
*copy avh$delete_field

  PROCEDURE [XDCL] avp$delete_field
    (    field_name: ost$name;
         description_record_name: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      deleted_field: boolean,
      description_record: ^avt$template_file_record,
      field_directory: ^avt$field_directory,
      field_directory_entry: ^avt$field_directory_entry,
      ignored_status: ost$status,
      lock_set_by_this_procedure: boolean,
      os_version: pmt$os_name,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap,
      verified_desc_record_name: clt$name,
      verified_field_name: clt$name;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$delete_field);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    clp$convert_string_to_name (description_record_name, verified_desc_record_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_string_to_name (field_name, verified_field_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_os_version (os_version, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

  /delete_field/
    BEGIN
      avp$lock_template_file (avc$update_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$conflicting_lock THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'AVP$DELETE_FIELD', status);
        IFEND;
        EXIT /delete_field/;
      IFEND;

      get_description_record (verified_desc_record_name.value, template_file_header, template_file_heap,
            description_record, status);
      IF NOT status.normal THEN
        EXIT /delete_field/;
      IFEND;

      get_field_directory (description_record, field_directory, status);
      IF NOT status.normal THEN
        EXIT /delete_field/;
      IFEND;

      get_field_directory_entry (verified_field_name.value, field_directory, field_directory_entry,
            deleted_field, status);
      IF NOT status.normal THEN
        EXIT /delete_field/;
      IFEND;

      IF deleted_field THEN
        osp$set_status_abnormal ('AV', ave$field_was_deleted, verified_field_name.value, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              field_directory_entry^.delete_status.os_version_when_deleted, status);
      ELSE
        field_directory_entry^.delete_status.deleted := TRUE;
        field_directory_entry^.delete_status.os_version_when_deleted := os_version;
      IFEND;
    END /delete_field/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$delete_field);
    ?IFEND

  PROCEND avp$delete_field;
?? TITLE := '    [XDCL] avp$get_desc_utility_info', EJECT ??
*copy avh$get_desc_utility_info

  PROCEDURE [XDCL] avp$get_desc_utility_info
    (    description_record_name: ost$name;
     VAR utility_information: ^avt$utility_information;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      description_directory_entry: ^avt$description_directory_entry,
      ignored_status: ost$status,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap,
      utility_information_in_file: ^avt$utility_information,
      utility_information_pointer: ^avt$utility_information,
      verified_desc_record_name: clt$name;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$get_desc_utility_info);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    clp$convert_string_to_name (description_record_name, verified_desc_record_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

  /get_desc_utility_info/
    BEGIN
      avp$lock_template_file (avc$read_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        EXIT /get_desc_utility_info/;
      IFEND;

      get_description_directory_entry (verified_desc_record_name.value, template_file_header,
            template_file_heap, description_directory_entry, status);
      IF NOT status.normal THEN
        EXIT /get_desc_utility_info/;
      IFEND;

      utility_information_in_file := #PTR (description_directory_entry^.utility_information,
            template_file_heap^);

      IF utility_information_in_file <> NIL THEN
        NEXT utility_information_pointer: [[REP #SIZE (utility_information_in_file^) OF cell]] IN
              utility_information;
        IF utility_information_pointer = NIL THEN
          osp$set_status_abnormal ('AV', ave$work_area_full, 'AVP$GET_DESC_UTILITY_INFO', status);
          EXIT /get_desc_utility_info/;
        IFEND;
        utility_information_pointer^ := utility_information_in_file^;
      IFEND;
    END /get_desc_utility_info/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$get_desc_utility_info);
    ?IFEND

  PROCEND avp$get_desc_utility_info;
?? TITLE := '    [XDCL] avp$get_desc_utility_info_size', EJECT ??
*copy avh$get_desc_utility_info_size

  PROCEDURE [XDCL] avp$get_desc_utility_info_size
    (    description_record_name: ost$name;
     VAR utility_information_size: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      description_directory_entry: ^avt$description_directory_entry,
      ignored_status: ost$status,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap,
      utility_information_in_file: ^avt$utility_information,
      verified_desc_record_name: clt$name;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$get_desc_utility_info_size);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    clp$convert_string_to_name (description_record_name, verified_desc_record_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

  /get_desc_utility_info_size/
    BEGIN
      avp$lock_template_file (avc$read_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        EXIT /get_desc_utility_info_size/;
      IFEND;

      get_description_directory_entry (verified_desc_record_name.value, template_file_header,
            template_file_heap, description_directory_entry, status);
      IF NOT status.normal THEN
        EXIT /get_desc_utility_info_size/;
      IFEND;

      utility_information_in_file := #PTR (description_directory_entry^.utility_information,
            template_file_heap^);

      IF utility_information_in_file = NIL THEN
        utility_information_size := 0;
      ELSE
        utility_information_size := #SIZE (utility_information_in_file^);
      IFEND;
    END /get_desc_utility_info_size/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$get_desc_utility_info_size);
    ?IFEND

  PROCEND avp$get_desc_utility_info_size;
?? TITLE := '    [XDCL] avp$get_description_record', EJECT ??
*copy avh$get_description_record

  PROCEDURE [XDCL] avp$get_description_record
    (    description_record_name: ost$name;
     VAR description_record: ^avt$template_file_record;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      description_record_in_file: ^avt$template_file_record,
      description_record_pointer: ^avt$template_file_record,
      ignored_status: ost$status,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap,
      verified_desc_record_name: clt$name;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$get_description_record);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    clp$convert_string_to_name (description_record_name, verified_desc_record_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

  /get_desc_record/
    BEGIN
      avp$lock_template_file (avc$read_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        EXIT /get_desc_record/;
      IFEND;

      get_description_record (verified_desc_record_name.value, template_file_header, template_file_heap,
            description_record_in_file, status);
      IF NOT status.normal THEN
        EXIT /get_desc_record/;
      IFEND;

      NEXT description_record_pointer: [[REP #SIZE (description_record_in_file^) OF cell]] IN
            description_record;
      IF description_record_pointer = NIL THEN
        osp$set_status_abnormal ('AV', ave$work_area_full, 'AVP$GET_DESCRIPTION_RECORD', status);
        EXIT /get_desc_record/;
      IFEND;
      description_record_pointer^ := description_record_in_file^;
    END /get_desc_record/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$get_description_record);
    ?IFEND

  PROCEND avp$get_description_record;
?? TITLE := '    [XDCL] avp$get_field_description', EJECT ??
*copy avh$get_field_description

  PROCEDURE [XDCL] avp$get_field_description
    (    field_name: ost$name;
         description_record: ^avt$template_file_record;
         work_area: ^seq (*);
     VAR type_specification: avt$type_specification;
     VAR default_value: avt$field_value;
     VAR descriptive_text: ^avt$descriptive_text;
     VAR utility_information: ^avt$utility_information;
     VAR status: ost$status);

    VAR
      field_directory: ^avt$field_directory,
      system_supplied_field_id: avt$system_supplied_field_id,
      verified_field_name: clt$name,
      work_area_ptr: ^seq (*);

    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$get_field_description);
    ?IFEND

  /get_description/
    BEGIN
      clp$convert_string_to_name (field_name, verified_field_name, status);
      IF NOT status.normal THEN
        EXIT /get_description/;
      IFEND;

      get_field_directory (description_record, field_directory, status);
      IF NOT status.normal THEN
        EXIT /get_description/;
      IFEND;

      work_area_ptr := work_area;
      get_field_description (verified_field_name.value, field_directory, description_record, work_area_ptr,
            system_supplied_field_id, type_specification, default_value, descriptive_text,
            utility_information, status);
    END /get_description/;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$get_field_description);
    ?IFEND

  PROCEND avp$get_field_description;
?? TITLE := '    [XDCL] avp$get_field_names', EJECT ??
*copy avh$get_field_names

  PROCEDURE [XDCL] avp$get_field_names
    (    desired_field_types: avt$field_kind_set;
         return_deleted_names: boolean;
         description_record: ^avt$template_file_record;
     VAR field_names: array [1 .. * ] of ost$name;
     VAR field_count: avt$field_count;
     VAR status: ost$status);

    VAR
      deleted_field: boolean,
      field_description: ^avt$field_description,
      field_description_header: ^avt$field_description_header,
      field_directory: ^avt$field_directory,
      field_directory_entry: ^avt$field_directory_entry,
      index: 1 .. avc$maximum_field_count,
      internal_type_specification: ^avt$internal_type_specification,
      kind: ^avt$field_kind;

    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$get_field_names);
    ?IFEND

  /get_field_names/
    BEGIN
      get_field_directory (description_record, field_directory, status);
      IF NOT status.normal THEN
        EXIT /get_field_names/;
      IFEND;

      field_count := 0;
      IF field_directory <> NIL THEN
        FOR index := 1 TO UPPERBOUND (field_directory^) DO
          field_description := #PTR (field_directory^ [index].description, description_record^);

          get_field_description_header (field_description, field_description_header, status);
          IF NOT status.normal THEN
            EXIT /get_field_names/;
          IFEND;

          internal_type_specification := #PTR (field_description_header^.type_specification,
                field_description^);
          RESET internal_type_specification;

          NEXT kind IN internal_type_specification;
          IF kind = NIL THEN
            corrupted_sequence ('AVP$GET_FIELD_NAMES', 'KIND', 'INTERNAL_TYPE_SPECIFICATION', status);
            EXIT /get_field_names/;
          IFEND;

          IF kind^ IN desired_field_types THEN
            check_if_field_deleted (field_directory^ [index].delete_status, deleted_field, status);
            IF NOT status.normal THEN
              EXIT /get_field_names/;
            IFEND;

            IF deleted_field = return_deleted_names THEN
              field_count := field_count + 1;
              IF field_count <= UPPERBOUND (field_names) THEN
                field_names [field_count] := field_directory^ [index].name;
              IFEND;
            IFEND;
          IFEND;
        FOREND;
      IFEND;
    END /get_field_names/;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$get_field_names);
    ?IFEND

  PROCEND avp$get_field_names;
?? TITLE := '    [XDCL] avp$restore_field', EJECT ??
*copy avh$restore_field

  PROCEDURE [XDCL] avp$restore_field
    (    field_name: ost$name;
         description_record_name: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      deleted_field: boolean,
      description_record: ^avt$template_file_record,
      field_directory: ^avt$field_directory,
      field_directory_entry: ^avt$field_directory_entry,
      ignored_status: ost$status,
      lock_set_by_this_procedure: boolean,
      os_version: pmt$os_name,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap,
      verified_desc_record_name: clt$name,
      verified_field_name: clt$name;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$restore_field);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    clp$convert_string_to_name (description_record_name, verified_desc_record_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_string_to_name (field_name, verified_field_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

  /restore_field/
    BEGIN
      avp$lock_template_file (avc$update_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$conflicting_lock THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'AVP$RESTORE_FIELD', status);
        IFEND;
        EXIT /restore_field/;
      IFEND;

      get_description_record (verified_desc_record_name.value, template_file_header, template_file_heap,
            description_record, status);
      IF NOT status.normal THEN
        EXIT /restore_field/;
      IFEND;

      get_field_directory (description_record, field_directory, status);
      IF NOT status.normal THEN
        EXIT /restore_field/;
      IFEND;

      get_field_directory_entry (field_name, field_directory, field_directory_entry, deleted_field, status);
      IF NOT status.normal THEN
        EXIT /restore_field/;
      IFEND;

      IF deleted_field THEN
        field_directory_entry^.delete_status.deleted := FALSE;
      ELSE
        osp$set_status_abnormal ('AV', ave$not_a_deleted_field, verified_field_name.value, status);
      IFEND;
    END /restore_field/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$restore_field);
    ?IFEND

  PROCEND avp$restore_field;
?? TITLE := '    [XDCL] avp$verify_type_conformance', EJECT ??
*copy avh$verify_type_conformance

  PROCEDURE [XDCL] avp$verify_type_conformance
    (    field_name: ost$name;
         field_value: avt$field_value;
         type_specification: avt$type_specification;
     VAR status: ost$status);

    VAR
      verified_name: clt$name;


?? NEWTITLE := '      verify_account_project', EJECT ??

    PROCEDURE verify_account_project
      (    field_name: ost$name;
           field_value: avt$field_value;
           type_specification: avt$type_specification;
       VAR status: ost$status);

      VAR
        verified_name: clt$name;

      status.normal := TRUE;

      IF field_value.account_name = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'account name', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      ELSEIF field_value.account_name^ <> osc$null_name THEN
        clp$convert_string_to_name (field_value.account_name^, verified_name, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal ('AV', ave$value_is_not_a_name, field_value.account_name^, status);
          RETURN;
        IFEND;
        field_value.account_name^ := verified_name.value;
      IFEND;

      IF field_value.project_name = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'project name', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      ELSEIF field_value.project_name^ <> osc$null_name THEN
        clp$convert_string_to_name (field_value.project_name^, verified_name, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal ('AV', ave$value_is_not_a_name, field_value.project_name^, status);
          RETURN;
        IFEND;
        field_value.project_name^ := verified_name.value;

        IF field_value.account_name^ = osc$null_name THEN
          osp$set_status_abnormal ('AV', ave$account_must_be_specified, '', status);
          RETURN;
        IFEND;
      IFEND;

    PROCEND verify_account_project;
?? TITLE := '      verify_accumulating_limit', EJECT ??

    PROCEDURE verify_accumulating_limit
      (    field_name: ost$name;
           field_value: avt$field_value;
           type_specification: avt$type_specification;
       VAR status: ost$status);

      status.normal := TRUE;

      IF field_value.job_warning_limit = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'job warning limit', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

      IF field_value.job_maximum_limit = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'job maximum limit', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

      IF field_value.total_limit = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'total limit', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

      IF field_value.total_accumulation = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'total accumulation', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

      IF field_value.job_warning_limit^ > field_value.job_maximum_limit^ THEN
        osp$set_status_abnormal ('AV', ave$incorrect_job_limits, '', status);
        RETURN;
      IFEND;

      IF (field_value.job_warning_limit^ < type_specification.minimum_job_limit_value^) OR
            (field_value.job_warning_limit^ > type_specification.maximum_job_limit_value^) THEN
        osp$set_status_abnormal ('AV', ave$out_of_range, '', status);
        IF field_value.job_warning_limit^ = sfc$unlimited THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'UNLIMITED', status);
        ELSE
          osp$append_status_integer (osc$status_parameter_delimiter, field_value.job_warning_limit^, 10,
                FALSE, status);
        IFEND;
        osp$append_status_integer (osc$status_parameter_delimiter,
              type_specification.minimum_job_limit_value^, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              type_specification.maximum_job_limit_value^, 10, FALSE, status);
        RETURN;
      IFEND;

      IF (field_value.job_maximum_limit^ < type_specification.minimum_job_limit_value^) OR
            (field_value.job_maximum_limit^ > type_specification.maximum_job_limit_value^) THEN
        osp$set_status_abnormal ('AV', ave$out_of_range, '', status);
        IF field_value.job_maximum_limit^ = sfc$unlimited THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'UNLIMITED', status);
        ELSE
          osp$append_status_integer (osc$status_parameter_delimiter, field_value.job_maximum_limit^, 10,
                FALSE, status);
        IFEND;
        osp$append_status_integer (osc$status_parameter_delimiter,
              type_specification.minimum_job_limit_value^, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              type_specification.maximum_job_limit_value^, 10, FALSE, status);
        RETURN;
      IFEND;

      IF field_value.total_accumulation^ < 0 THEN
        osp$set_status_abnormal ('AV', ave$out_of_range, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, field_value.total_accumulation^, 10,
                FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, 0, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, osc$max_integer, 10, FALSE, status);
        RETURN;
      IFEND;

    PROCEND verify_accumulating_limit;
?? TITLE := '      verify_capability', EJECT ??

    PROCEDURE verify_capability
      (    field_name: ost$name;
           field_value: avt$field_value;
           type_specification: avt$type_specification;
       VAR status: ost$status);

      status.normal := TRUE;

      IF field_value.capability = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'capability', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

    PROCEND verify_capability;
?? TITLE := '      verify_date_time', EJECT ??

    PROCEDURE verify_date_time
      (    field_name: ost$name;
           field_value: avt$field_value;
           type_specification: avt$type_specification;
       VAR status: ost$status);

      status.normal := TRUE;

      IF field_value.date_time = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'date time', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

      IF (field_value.date_time^.range) AND (NOT type_specification.date_time_range^) THEN
        osp$set_status_abnormal ('AV', ave$date_time_range_not_allowed, '', status);
        RETURN;
      ELSEIF (NOT field_value.date_time^.range) AND (type_specification.date_time_range^) THEN
        osp$set_status_abnormal ('AV', ave$date_time_range_required, '', status);
        RETURN;
      IFEND;

      IF (field_value.date_time^.date_specified) AND (NOT type_specification.date_applies^) THEN
        osp$set_status_abnormal ('AV', ave$date_not_allowed, '', status);
        RETURN;
      ELSEIF (NOT field_value.date_time^.date_specified) AND (type_specification.date_applies^) THEN
        osp$set_status_abnormal ('AV', ave$date_required, '', status);
        RETURN;
      IFEND;

      IF (field_value.date_time^.time_specified) AND (NOT type_specification.time_applies^) THEN
        osp$set_status_abnormal ('AV', ave$time_not_allowed, '', status);
        RETURN;
      ELSEIF (NOT field_value.date_time^.time_specified) AND (type_specification.time_applies^) THEN
        osp$set_status_abnormal ('AV', ave$time_required, '', status);
        RETURN;
      IFEND;

    PROCEND verify_date_time;
?? TITLE := '      verify_file', EJECT ??

    PROCEDURE verify_file
      (    field_name: ost$name;
           field_value: avt$field_value;
           type_specification: avt$type_specification;
       VAR status: ost$status);

      status.normal := TRUE;

      IF field_value.file = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'file', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

      IF #SIZE (field_value.file^) = 0 THEN
        osp$set_status_abnormal ('AV', ave$incorrect_file_reference, '', status);
        RETURN;
      IFEND;

      #TRANSLATE (osv$lower_to_upper, field_value.file^, field_value.file^);

    PROCEND verify_file;
?? TITLE := '      verify_integer', EJECT ??

    PROCEDURE verify_integer
      (    field_name: ost$name;
           field_value: avt$field_value;
           type_specification: avt$type_specification;
       VAR status: ost$status);

      status.normal := TRUE;

      IF field_value.integer_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'integer value', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

      IF (field_value.integer_value^ < type_specification.minimum_integer_value^) OR
            (field_value.integer_value^ > type_specification.maximum_integer_value^) THEN
        osp$set_status_abnormal ('AV', ave$out_of_range, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, field_value.integer_value^, 10, FALSE,
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, type_specification.minimum_integer_value^,
              10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, type_specification.maximum_integer_value^,
              10, FALSE, status);
        RETURN;
      IFEND;

    PROCEND verify_integer;
?? TITLE := '      verify_job_class', EJECT ??

    PROCEDURE verify_job_class
      (    field_name: ost$name;
           field_value: avt$field_value;
           type_specification: avt$type_specification;
       VAR status: ost$status);

      VAR
        found_batch_default: boolean,
        found_interactive_default: boolean,
        index: avt$name_list_size,
        verified_name: clt$name;

      status.normal := TRUE;

      IF field_value.batch_job_class_default = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'batch job class default', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

      clp$convert_string_to_name (field_value.batch_job_class_default^, verified_name, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal ('AV', ave$value_is_not_a_name, field_value.batch_job_class_default^, status);
        RETURN;
      IFEND;
      field_value.batch_job_class_default^ := verified_name.value;

      IF field_value.interactive_job_class_default = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'interactive job class default', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

      clp$convert_string_to_name (field_value.interactive_job_class_default^, verified_name, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal ('AV', ave$value_is_not_a_name, field_value.interactive_job_class_default^,
              status);
        RETURN;
      IFEND;
      field_value.interactive_job_class_default^ := verified_name.value;

      IF field_value.job_classes = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'job classes', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      ELSE
        sort_name_list (field_value.job_classes^);
      IFEND;

      found_batch_default := field_value.batch_job_class_default^ = 'NONE';
      found_interactive_default := field_value.interactive_job_class_default^ = 'NONE';
      FOR index := 1 TO UPPERBOUND (field_value.job_classes^) DO
        clp$convert_string_to_name (field_value.job_classes^ [index], verified_name, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal ('AV', ave$value_is_not_a_name, field_value.job_classes^ [index], status);
          RETURN;
        IFEND;
        field_value.job_classes^ [index] := verified_name.value;
        IF NOT (found_interactive_default AND found_batch_default) THEN
          IF field_value.job_classes^ [index] = 'ALL' THEN
            found_batch_default := TRUE;
            found_interactive_default := TRUE;
          IFEND;
          IF field_value.job_classes^ [index] = field_value.batch_job_class_default^ THEN
            found_batch_default := TRUE;
          IFEND;
          IF field_value.job_classes^ [index] = field_value.interactive_job_class_default^ THEN
            found_interactive_default := TRUE;
          IFEND;
        IFEND;
      FOREND;

      IF NOT found_batch_default THEN
        osp$set_status_abnormal ('AV', ave$not_validated_for_default, 'batch', status);
        RETURN;
      IFEND;

      IF NOT found_interactive_default THEN
        osp$set_status_abnormal ('AV', ave$not_validated_for_default, 'interactive', status);
        RETURN;
      IFEND;

    PROCEND verify_job_class;
?? TITLE := '      verify_labeled_names', EJECT ??

    PROCEDURE verify_labeled_names
      (    field_name: ost$name;
           field_value: avt$field_value;
           type_specification: avt$type_specification;
       VAR status: ost$status);

      VAR
        index1: avt$name_list_size,
        index2: avt$name_list_size,
        name_list_size: avt$name_list_size,
        verified_name: clt$name;

      status.normal := TRUE;

      IF field_value.labeled_names <> NIL THEN
        sort_labeled_names (field_value.labeled_names^);
        FOR index1 := 1 TO UPPERBOUND (field_value.labeled_names^) DO
          clp$convert_string_to_name (field_value.labeled_names^ [index1].label^, verified_name, status);
          IF NOT status.normal THEN
            osp$set_status_abnormal ('AV', ave$value_is_not_a_name,
                  field_value.labeled_names^ [index1].label^, status);
            RETURN;
          IFEND;
          field_value.labeled_names^ [index1].label^ := verified_name.value;
          FOR index2 := 1 TO UPPERBOUND (field_value.labeled_names^ [index1].names^) DO
            clp$convert_string_to_name (field_value.labeled_names^ [index1].names^ [index2],
                  verified_name, status);
            IF NOT status.normal THEN
              osp$set_status_abnormal ('AV', ave$value_is_not_a_name,
                    field_value.labeled_names^ [index1].names^ [index2], status);
              RETURN;
            IFEND;
            field_value.labeled_names^ [index1].names^ [index2] := verified_name.value;
          FOREND;
        FOREND;
      IFEND;

    PROCEND verify_labeled_names;
?? TITLE := '      verify_limit', EJECT ??

    PROCEDURE verify_limit
      (    field_name: ost$name;
           field_value: avt$field_value;
           type_specification: avt$type_specification;
       VAR status: ost$status);

      status.normal := TRUE;

      IF field_value.limit_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'limit value', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

      IF (field_value.limit_value^ < type_specification.minimum_limit_value^) OR
            (field_value.limit_value^ > type_specification.maximum_limit_value^) THEN
        osp$set_status_abnormal ('AV', ave$out_of_range, '', status);
        IF field_value.limit_value^ = sfc$unlimited THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'UNLIMITED', status);
        ELSE
          osp$append_status_integer (osc$status_parameter_delimiter, field_value.limit_value^, 10,
                FALSE, status);
        IFEND;
        osp$append_status_integer (osc$status_parameter_delimiter, type_specification.minimum_limit_value^,
              10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, type_specification.maximum_limit_value^,
              10, FALSE, status);
        RETURN;
      IFEND;

    PROCEND verify_limit;
?? TITLE := '      verify_login_password', EJECT ??

    PROCEDURE verify_login_password
      (    field_name: ost$name;
           field_value: avt$field_value;
           type_specification: avt$type_specification;
       VAR status: ost$status);

      VAR
        current_date_time: ost$date_time,
        increment: pmt$time_increment,
        index: avt$name_list_size,
        maximum_expiration_date: ost$date_time,
        verified_name: clt$name;

      status.normal := TRUE;

      IF field_value.login_password = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'login password', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

      IF field_value.login_password_exp_date = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'login password expiration date', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

      IF field_value.login_password_exp_interval = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'login password expiration interval',
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

      IF field_value.login_password_max_exp_interval = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer,
              'logion password maximum expiration interval', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

      IF field_value.login_password_exp_interval^.day > field_value.login_password_max_exp_interval^.day THEN
        osp$set_status_abnormal ('AV', ave$incorrect_exp_interval, '', status);
        RETURN;
      IFEND;


      IF field_value.login_password_max_exp_interval^.day <> avc$unlimited_exp_interval THEN
        pmp$get_compact_date_time (current_date_time, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        pmp$compute_date_time (current_date_time, field_value.login_password_max_exp_interval^,
              maximum_expiration_date, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        pmp$compute_date_time_increment (field_value.login_password_exp_date^, maximum_expiration_date,
              increment, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF (increment.year < 0) OR (increment.month < 0) OR (increment.day < 0) OR (increment.hour < 0) OR
              (increment.minute < 0) OR (increment.second < 0) OR (increment.millisecond < 0) THEN
          osp$set_status_abnormal ('AV', ave$incorrect_expiration_date, '', status);
          RETURN;
        IFEND;
      IFEND;

      IF field_value.login_password_attributes = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'login password attributes', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      ELSE;
        sort_name_list (field_value.login_password_attributes^);
      IFEND;

      FOR index := 1 TO UPPERBOUND (field_value.login_password_attributes^) DO
        clp$convert_string_to_name (field_value.login_password_attributes^ [index], verified_name, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal ('AV', ave$value_is_not_a_name, field_value.
                login_password_attributes^ [index], status);
          RETURN;
        IFEND;
        field_value.login_password_attributes^ [index] := verified_name.value;
      FOREND;

    PROCEND verify_login_password;
?? TITLE := '      verify_name', EJECT ??

    PROCEDURE verify_name
      (    field_name: ost$name;
           field_value: avt$field_value;
           type_specification: avt$type_specification;
       VAR status: ost$status);

      VAR
        index: avt$name_list_size,
        name_list_size: avt$name_list_size,
        verified_name: clt$name;

      status.normal := TRUE;

      IF field_value.names = NIL THEN
        name_list_size := 0;
      ELSE
        sort_name_list (field_value.names^);
        name_list_size := UPPERBOUND (field_value.names^);
      IFEND;

      IF name_list_size < type_specification.minimum_number_of_names^ THEN
        osp$set_status_abnormal ('AV', ave$too_few_names, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              type_specification.minimum_number_of_names^, 10, FALSE, status);
        RETURN;
      ELSEIF name_list_size > type_specification.maximum_number_of_names^ THEN
        osp$set_status_abnormal ('AV', ave$too_many_names, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              type_specification.maximum_number_of_names^, 10, FALSE, status);
        RETURN;
      IFEND;

      FOR index := 1 TO UPPERBOUND (field_value.names^) DO
        clp$convert_string_to_name (field_value.names^ [index], verified_name, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal ('AV', ave$value_is_not_a_name, field_value.names^ [index], status);
          RETURN;
        IFEND;
        field_value.names^ [index] := verified_name.value;
      FOREND;

    PROCEND verify_name;
?? TITLE := '      verify_real', EJECT ??

    PROCEDURE verify_real
      (    field_name: ost$name;
           field_value: avt$field_value;
           type_specification: avt$type_specification;
       VAR status: ost$status);

?? NEWTITLE := '       append_status_real', EJECT ??

      PROCEDURE append_status_real
        (    delimiter: char;
             real_number: real;
             number_of_digits: clt$real_number_digit_count;
         VAR status: ost$status);

        TYPE
          long_real_type = record
            first: real,
            second: real,
          recend;

        VAR
          long_real_value: long_real_type,
          real_value: longreal;

        long_real_value.first := real_number;
        long_real_value.second := 0.0;

        #UNCHECKED_CONVERSION (long_real_value, real_value);

        osp$append_status_real (delimiter, real_value, number_of_digits, status);

      PROCEND append_status_real;
?? OLDTITLE, EJECT ??
      status.normal := TRUE;

      IF field_value.real_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'real value', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

      IF (field_value.real_value^ < type_specification.minimum_real_value^) OR
            (field_value.real_value^ > type_specification.maximum_real_value^) THEN
        osp$set_status_abnormal ('AV', ave$out_of_range, '', status);
        append_status_real (osc$status_parameter_delimiter, field_value.real_value^, 20, status);
        append_status_real (osc$status_parameter_delimiter, type_specification.minimum_real_value^, 20,
              status);
        append_status_real (osc$status_parameter_delimiter, type_specification.maximum_real_value^, 20,
              status);
        RETURN;
      IFEND;

    PROCEND verify_real;
?? TITLE := '      verify_restriction', EJECT ??

    PROCEDURE verify_restriction
      (    field_name: ost$name;
           field_value: avt$field_value;
           type_specification: avt$type_specification;
       VAR status: ost$status);

      status.normal := TRUE;

      IF field_value.restriction = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'restriction', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

    PROCEND verify_restriction;
?? TITLE := '      verify_ring_privilege', EJECT ??

    PROCEDURE verify_ring_privilege
      (    field_name: ost$name;
           field_value: avt$field_value;
           type_specification: avt$type_specification;
       VAR status: ost$status);

      status.normal := TRUE;

      IF field_value.minimum_ring = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'minimum ring', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

      IF field_value.nominal_ring = NIL THEN
        osp$set_status_abnormal ('AV', ave$unexpected_nil_pointer, 'nominal ring', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        RETURN;
      IFEND;

      IF (field_value.minimum_ring^ < osc$sj_ring_1) OR (field_value.minimum_ring^ > osc$max_ring) THEN
        osp$set_status_abnormal ('AV', ave$out_of_range, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, field_value.minimum_ring^, 10, FALSE,
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, osc$sj_ring_1, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, osc$max_ring, 10, FALSE, status);
        RETURN;
      IFEND;

      IF (field_value.nominal_ring^ < osc$sj_ring_1) OR (field_value.nominal_ring^ > osc$max_ring) THEN
        osp$set_status_abnormal ('AV', ave$out_of_range, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, field_value.nominal_ring^, 10, FALSE,
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, osc$sj_ring_1, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, osc$max_ring, 10, FALSE, status);
        RETURN;
      IFEND;

      IF field_value.nominal_ring^ < field_value.minimum_ring^ THEN
        osp$set_status_abnormal ('AV', ave$incorrect_ring_privileges, '', status);
        RETURN;
      IFEND;

    PROCEND verify_ring_privilege;
?? TITLE := '      verify_string', EJECT ??

    PROCEDURE verify_string
      (    field_name: ost$name;
           field_value: avt$field_value;
           type_specification: avt$type_specification;
       VAR status: ost$status);

      status.normal := TRUE;

      IF (field_value.string_value = NIL) THEN
        IF type_specification.minimum_string_size^ <> 0 THEN
          osp$set_status_abnormal ('AV', ave$string_too_short, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, type_specification.minimum_string_size^,
                10, FALSE, status);
          RETURN;
        IFEND;
      ELSEIF #SIZE (field_value.string_value^) < type_specification.minimum_string_size^ THEN
        osp$set_status_abnormal ('AV', ave$string_too_short, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, type_specification.minimum_string_size^,
              10, FALSE, status);
        RETURN;
      ELSEIF #SIZE (field_value.string_value^) > type_specification.maximum_string_size^ THEN
        osp$set_status_abnormal ('AV', ave$string_too_long, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, type_specification.maximum_string_size^,
              10, FALSE, status);
        RETURN;
      IFEND;

    PROCEND verify_string;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    IF field_value.kind <> type_specification.kind THEN
      osp$set_status_abnormal ('AV', ave$kinds_do_not_match, 'field', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'type specification', status);
      RETURN;
    IFEND;

    clp$convert_string_to_name (field_name, verified_name, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal ('AV', ave$value_is_not_a_name, field_name, status);
      RETURN;
    IFEND;

    CASE field_value.kind OF
    = avc$account_project_kind =
      verify_account_project (field_name, field_value, type_specification, status);
    = avc$accumulating_limit_kind =
      verify_accumulating_limit (field_name, field_value, type_specification, status);
    = avc$capability_kind =
      verify_capability (field_name, field_value, type_specification, status);
    = avc$date_time_kind =
      verify_date_time (field_name, field_value, type_specification, status);
    = avc$file_kind =
      verify_file (field_name, field_value, type_specification, status);
    = avc$integer_kind =
      verify_integer (field_name, field_value, type_specification, status);
    = avc$job_class_kind =
      verify_job_class (field_name, field_value, type_specification, status);
    = avc$keyword_kind =
      osp$set_status_abnormal ('AV', ave$kind_not_implemented, 'KEYWORD', status);
    = avc$labeled_names_kind =
      verify_labeled_names (field_name, field_value, type_specification, status);
    = avc$limit_kind =
      verify_limit (field_name, field_value, type_specification, status);
    = avc$login_password_kind =
      verify_login_password (field_name, field_value, type_specification, status);
    = avc$name_kind =
      verify_name (field_name, field_value, type_specification, status);
    = avc$real_kind =
      verify_real (field_name, field_value, type_specification, status);
    = avc$restriction_kind =
      verify_restriction (field_name, field_value, type_specification, status);
    = avc$ring_privilege_kind =
      verify_ring_privilege (field_name, field_value, type_specification, status);
    = avc$string_kind =
      verify_string (field_name, field_value, type_specification, status);
    ELSE
      osp$set_status_abnormal ('AV', ave$unknown_field_kind, 'AVP$VERIFY_TYPE_CONFORMANCE', status);
    CASEND;

  PROCEND avp$verify_type_conformance;
?? OLDTITLE ??
?? TITLE := '  Template Data Record Interfaces', EJECT ??
?? NEWTITLE := '    [XDCL] avp$create_data_record', EJECT ??
*copy avh$create_data_record

  PROCEDURE [XDCL] avp$create_data_record
    (    key: avt$template_file_key;
         description_record_name: ost$name;
         field_value_list: avt$field_value_list;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      data_record: ^avt$template_file_record,
      data_record_header: ^avt$template_file_record_header,
      data_record_size: 0 .. avc$max_template_record_size,
      description_record: ^avt$template_file_record,
      description_record_index: 1 .. avc$maximum_desc_record_count,
      ignored_status: ost$status,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap,
      verified_desc_record_name: clt$name,
      work_area: ^avt$template_file_record;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$create_data_record);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    clp$convert_string_to_name (description_record_name, verified_desc_record_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH work_area: [[REP avc$max_template_record_size OF cell]];
    RESET work_area;

    osp$establish_block_exit_hndlr (^condition_handler);

  /create_data_record/
    BEGIN
      avp$lock_template_file (avc$update_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$conflicting_lock THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'AVP$CREATE_DATA_RECORD', status);
        IFEND;
        EXIT /create_data_record/;
      IFEND;

      get_description_record_index (verified_desc_record_name.value, template_file_header,
            description_record_index, status);
      IF NOT status.normal THEN
        EXIT /create_data_record/;
      IFEND;
      description_record := #PTR (template_file_header^.description_directory [description_record_index].
            record_pointer, template_file_heap^);

      rebuild_data_record (NIL, field_value_list, description_record_index, description_record, work_area,
            status);
      IF NOT status.normal THEN
        EXIT /create_data_record/;
      IFEND;

      data_record_size := i#current_sequence_position (work_area);

      RESET work_area;

      NEXT data_record: [[REP data_record_size OF cell]] IN work_area;
      IF data_record = NIL THEN
        corrupted_sequence ('AVP$CREATE_DATA_RECORD', 'DATA_RECORD', 'WORK_AREA', status);
        EXIT /create_data_record/;
      IFEND;

      insert_key (key, data_record, template_file_header, template_file_heap, status);

      file_information.last_key_accessed := key;
    END /create_data_record/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$create_data_record);
    ?IFEND

  PROCEND avp$create_data_record;
?? TITLE := '    [XDCL] avp$delete_data_record', EJECT ??
*copy avh$delete_data_record

  PROCEDURE [XDCL] avp$delete_data_record
    (    key: avt$template_file_key;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      ignored_status: ost$status,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap,
      data_record: ^avt$template_file_record;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$delete_data_record);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    osp$establish_block_exit_hndlr (^condition_handler);

    avp$lock_template_file (avc$update_access, lock_set_by_this_procedure, template_file_header,
          template_file_heap, file_information, status);
    IF status.normal THEN
      delete_key (key, template_file_header, template_file_heap, status);
      file_information.last_key_accessed := key;
    ELSEIF status.condition = ave$conflicting_lock THEN
      osp$append_status_parameter (osc$status_parameter_delimiter, 'AVP$DELETE_DATA_RECORD', status);
    IFEND;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$delete_data_record);
    ?IFEND

  PROCEND avp$delete_data_record;
?? TITLE := '    [XDCL] avp$delete_data_records', EJECT ??
*copy avh$delete_data_records

  PROCEDURE [XDCL] avp$delete_data_records
    (    starting_key: avt$template_file_key;
         ending_key: avt$template_file_key;
         description_record_name: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      ignored_status: ost$status,
      data_record: ^avt$template_file_record,
      data_record_header: ^avt$template_file_record_header,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$delete_data_records);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    osp$establish_block_exit_hndlr (^condition_handler);

  /delete_data_records/
    BEGIN
      avp$lock_template_file (avc$update_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'AVP$DELETE_DATA_RECORD', status);
        EXIT /delete_data_records/;
      IFEND;

      find_key (starting_key, template_file_header, template_file_heap, data_record, status);
      file_information.last_key_accessed := starting_key;
      IF NOT status.normal THEN
        IF status.condition = ave$unknown_record THEN
          status.normal := TRUE;
          data_record := NIL;
        ELSE
          EXIT /delete_data_records/;
        IFEND;
      IFEND;

      REPEAT
        IF data_record <> NIL THEN
          get_record_header (data_record, data_record_header, status);
          IF NOT status.normal THEN
            EXIT /delete_data_records/;
          IFEND;

          IF template_file_header^.description_directory [data_record_header^.description_record_index].name =
                description_record_name THEN
            delete_key (file_information.last_key_accessed, template_file_header, template_file_heap, status);
            IF NOT status.normal THEN
              EXIT /delete_data_records/;
            IFEND;
          IFEND;
        IFEND;

        find_next_key (file_information.last_key_accessed, template_file_header, template_file_heap,
              file_information.last_key_accessed, data_record, status);
        IF NOT status.normal THEN
          IF status.condition <> ave$end_of_template_file THEN
            status.normal := TRUE;
          IFEND;
          EXIT /delete_data_records/;
        IFEND;
      UNTIL (file_information.last_key_accessed > ending_key);
    END /delete_data_records/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$delete_data_records);
    ?IFEND

  PROCEND avp$delete_data_records;
?? TITLE := '    [XDCL] avp$get_field', EJECT ??
*copy avh$get_field

  PROCEDURE [XDCL] avp$get_field
    (    field_name: ost$name;
         data_record: ^avt$template_file_record;
         description_record: ^avt$template_file_record;
         work_area: ^seq (*);
     VAR field_value: avt$field_value;
     VAR type_specification: avt$type_specification;
     VAR default_value: avt$field_value;
     VAR descriptive_text: ^avt$descriptive_text;
     VAR utility_information: ^avt$utility_information;
     VAR status: ost$status);

    VAR
      field_directory: ^avt$field_directory,
      system_supplied_field_id: avt$system_supplied_field_id,
      verified_field_name: clt$name,
      work_area_ptr: ^seq (*);

    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$get_field);
    ?IFEND

  /get_field/
    BEGIN
      clp$convert_string_to_name (field_name, verified_field_name, status);
      IF NOT status.normal THEN
        EXIT /get_field/;
      IFEND;

      get_field_directory (description_record, field_directory, status);
      IF NOT status.normal THEN
        EXIT /get_field/;
      IFEND;

      work_area_ptr := work_area;
      get_field_description (verified_field_name.value, field_directory, description_record, work_area_ptr,
            system_supplied_field_id, type_specification, default_value, descriptive_text,
            utility_information, status);
      IF NOT status.normal THEN
        EXIT /get_field/;
      IFEND;

      get_field_value (system_supplied_field_id, data_record, default_value, work_area_ptr, field_value,
            status);
    END /get_field/;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$get_field);
    ?IFEND

  PROCEND avp$get_field;
?? TITLE := '    [XDCL] avp$read_data_record', EJECT ??
*copy avh$read_data_record

  PROCEDURE [XDCL] avp$read_data_record
    (    key: avt$template_file_key;
         lock_type: avt$template_file_lock_type;
         automatically_unlock: boolean;
     VAR data_record: ^avt$template_file_record;
     VAR data_record_size: 0 .. avc$max_template_record_size;
     VAR description_record: ^avt$template_file_record;
     VAR description_record_size: 0 .. avc$max_template_record_size;
     VAR description_record_name: ost$name;
     VAR field_count: avt$field_count;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      data_record_header: ^avt$template_file_record_header,
      data_record_in_file: ^avt$template_file_record,
      data_record_pointer: ^avt$template_file_record,
      description_record_header: ^avt$template_file_record_header,
      description_record_in_file: ^avt$template_file_record,
      description_record_pointer: ^avt$template_file_record,
      field_directory: ^avt$field_directory,
      ignored_status: ost$status,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$read_data_record);
    ?IFEND

    data_record_pointer := NIL;
    description_record_pointer := NIL;

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    osp$establish_block_exit_hndlr (^condition_handler);

  /read_data_record/
    BEGIN
      avp$lock_template_file (lock_type, lock_set_by_this_procedure, template_file_header, template_file_heap,
            file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$conflicting_lock THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'AVP$READ_DATA_RECORD', status);
        IFEND;
        EXIT /read_data_record/;
      IFEND;

      find_key (key, template_file_header, template_file_heap, data_record_in_file, status);
      IF NOT status.normal THEN
        EXIT /read_data_record/;
      IFEND;

      data_record_size := #SIZE (data_record_in_file^);
      IF data_record <> NIL THEN
        NEXT data_record_pointer: [[REP data_record_size OF cell]] IN data_record;
        IF data_record_pointer <> NIL THEN
          data_record_pointer^ := data_record_in_file^;
        IFEND;
      IFEND;

      get_record_header (data_record_in_file, data_record_header, status);
      IF NOT status.normal THEN
        EXIT /read_data_record/;
      IFEND;

      description_record_in_file := #PTR (template_file_header^.
            description_directory [data_record_header^.description_record_index].record_pointer,
            template_file_heap^);

      get_record_header (description_record_in_file, description_record_header, status);
      IF NOT status.normal THEN
        EXIT /read_data_record/;
      IFEND;

      description_record_name := description_record_header^.name;

      field_directory := #PTR (description_record_header^.field_directory_pointer,
            description_record_in_file^);

      IF field_directory = NIL THEN
        field_count := 0;
      ELSE
        field_count := UPPERBOUND (field_directory^);
      IFEND;

      description_record_size := #SIZE (description_record_in_file^);
      IF description_record <> NIL THEN
        NEXT description_record_pointer: [[REP description_record_size OF cell]] IN description_record;
        IF description_record_pointer <> NIL THEN
          description_record_pointer^ := description_record_in_file^;
        IFEND;
      IFEND;

      file_information.last_key_accessed := key;

      IF ((data_record <> NIL) AND (data_record_pointer = NIL)) OR
         ((description_record <> NIL) AND (description_record_pointer = NIL)) THEN
        osp$set_status_abnormal ('AV', ave$work_area_full, 'AVP$READ_DATA_RECORD', status);
      IFEND;

    END /read_data_record/;

    IF lock_set_by_this_procedure THEN
      IF NOT status.normal THEN
        avp$unlock_template_file (file_information, ignored_status);
      ELSEIF automatically_unlock THEN
        avp$unlock_template_file (file_information, status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$read_data_record);
    ?IFEND

  PROCEND avp$read_data_record;
?? TITLE := '    [XDCL] avp$read_next_data_record', EJECT ??
*copy avh$read_next_data_record

  PROCEDURE [XDCL] avp$read_next_data_record
    (    lock_type: avt$template_file_lock_type;
         automatically_unlock: boolean;
     VAR key: avt$template_file_key;
     VAR data_record: ^avt$template_file_record;
     VAR description_record: ^avt$template_file_record;
     VAR description_record_name: ost$name;
     VAR field_count: avt$field_count;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      data_record_header: ^avt$template_file_record_header,
      data_record_in_file: ^avt$template_file_record,
      data_record_pointer: ^avt$template_file_record,
      description_record_header: ^avt$template_file_record_header,
      description_record_in_file: ^avt$template_file_record,
      description_record_pointer: ^avt$template_file_record,
      field_directory: ^avt$field_directory,
      ignored_status: ost$status,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$read_next_data_record);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    osp$establish_block_exit_hndlr (^condition_handler);

  /read_next_data_record/
    BEGIN
      avp$lock_template_file (lock_type, lock_set_by_this_procedure, template_file_header, template_file_heap,
            file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$conflicting_lock THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'AVP$READ_NEXT_DATA_RECORD', status);
        IFEND;
        EXIT /read_next_data_record/;
      IFEND;

      find_next_key (file_information.last_key_accessed, template_file_header, template_file_heap, key,
            data_record_in_file, status);
      IF NOT status.normal THEN
        EXIT /read_next_data_record/;
      IFEND;

      NEXT data_record_pointer: [[REP #SIZE (data_record_in_file^) OF cell]] IN data_record;
      IF data_record_pointer = NIL THEN
        osp$set_status_abnormal ('AV', ave$work_area_full, 'AVP$READ_DATA_RECORD', status);
        EXIT /read_next_data_record/;
      IFEND;
      data_record_pointer^ := data_record_in_file^;

      get_record_header (data_record, data_record_header, status);
      IF NOT status.normal THEN
        EXIT /read_next_data_record/;
      IFEND;

      description_record_in_file := #PTR (template_file_header^.
            description_directory [data_record_header^.description_record_index].record_pointer,
            template_file_heap^);

      get_record_header (description_record_in_file, description_record_header, status);
      IF NOT status.normal THEN
        EXIT /read_next_data_record/;
      IFEND;

      description_record_name := description_record_header^.name;

      field_directory := #PTR (description_record_header^.field_directory_pointer,
            description_record_in_file^);

      IF field_directory = NIL THEN
        field_count := 0;
      ELSE
        field_count := UPPERBOUND (field_directory^);
      IFEND;

      NEXT description_record_pointer: [[REP #SIZE (description_record_in_file^) OF cell]] IN
            description_record;
      IF description_record_pointer = NIL THEN
        osp$set_status_abnormal ('AV', ave$work_area_full, 'AVP$READ_DATA_RECORD', status);
        EXIT /read_next_data_record/;
      IFEND;
      description_record_pointer^ := description_record_in_file^;

      file_information.last_key_accessed := key;
    END /read_next_data_record/;

    IF lock_set_by_this_procedure THEN
      IF NOT status.normal THEN
        avp$unlock_template_file (file_information, ignored_status);
      ELSEIF automatically_unlock THEN
        avp$unlock_template_file (file_information, status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$read_next_data_record);
    ?IFEND

  PROCEND avp$read_next_data_record;
?? TITLE := '    [XDCL] avp$rewrite_data_record', EJECT ??
*copy avh$rewrite_data_record

  PROCEDURE [XDCL] avp$rewrite_data_record
    (    key: avt$template_file_key;
         automatically_unlock: boolean;
         data_record: ^avt$template_file_record;
         description_record: ^avt$template_file_record;
         field_value_list: avt$field_value_list;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      description_record_header: ^avt$template_file_record_header,
      description_record_index: 1 .. avc$maximum_desc_record_count,
      new_data_record: ^avt$template_file_record,
      new_data_record_size: 0 .. avc$max_template_record_size,
      ignored_status: ost$status,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap,
      work_area: ^avt$template_file_record;

    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$rewrite_data_record);
    ?IFEND

    IF (NOT file_information.locked) OR (file_information.lock_type <> avc$update_access) THEN
      osp$set_status_abnormal ('AV', ave$update_lock_required, 'AVP$REWRITE_DATA_RECORD', status);
      RETURN;
    IFEND;

    PUSH work_area: [[REP avc$max_template_record_size OF cell]];
    RESET work_area;

  /rewrite_data_record/
    BEGIN
      build_template_pointers (file_information, template_file_header, template_file_heap, status);
      IF NOT status.normal THEN
        EXIT /rewrite_data_record/;
      IFEND;

      get_record_header (description_record, description_record_header, status);
      IF NOT status.normal THEN
        EXIT /rewrite_data_record/;
      IFEND;

      get_description_record_index (description_record_header^.name, template_file_header,
            description_record_index, status);
      IF NOT status.normal THEN
        EXIT /rewrite_data_record/;
      IFEND;

      rebuild_data_record (data_record, field_value_list, description_record_index, description_record,
            work_area, status);
      IF NOT status.normal THEN
        EXIT /rewrite_data_record/;
      IFEND;

      new_data_record_size := i#current_sequence_position (work_area);

      RESET work_area;

      NEXT new_data_record: [[REP new_data_record_size OF cell]] IN work_area;
      IF new_data_record = NIL THEN
        corrupted_sequence ('AVP$REWRITE_DATA_RECORD', 'NEW_DATA_RECORD', 'WORK_AREA', status);
        EXIT /rewrite_data_record/;
      IFEND;

      replace_key (key, new_data_record, template_file_header, template_file_heap, status);
      file_information.last_key_accessed := key;
    END /rewrite_data_record/;

    IF NOT status.normal THEN
      avp$unlock_template_file (file_information, ignored_status);
    ELSEIF automatically_unlock THEN
      avp$unlock_template_file (file_information, status);
    IFEND;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$rewrite_data_record);
    ?IFEND

  PROCEND avp$rewrite_data_record;
?? OLDTITLE ??
?? TITLE := '  File Indexing Structure', EJECT ??
?? NEWTITLE := '    [XDCL] avp$determine_if_key_exists', EJECT ??
*copy avh$determine_if_key_exists

  PROCEDURE [XDCL] avp$determine_if_key_exists
    (    key: avt$template_file_key;
     VAR key_exists: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      data_record_in_file: ^avt$template_file_record,
      ignored_status: ost$status,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$determine_if_key_exists);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    osp$establish_block_exit_hndlr (^condition_handler);

  /determine_if_key_exists/
    BEGIN
      avp$lock_template_file (avc$read_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        EXIT /determine_if_key_exists/;
      IFEND;

      find_key (key, template_file_header, template_file_heap, data_record_in_file, status);
      IF status.normal THEN
        key_exists := TRUE;
      ELSEIF status.condition = ave$unknown_record THEN
        key_exists := FALSE;
        status.normal := TRUE;
      IFEND;
    END /determine_if_key_exists/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$determine_if_key_exists);
    ?IFEND

  PROCEND avp$determine_if_key_exists;
?? TITLE := '    [XDCL] avp$get_data_record_statistics', EJECT ??
*copy avh$get_data_record_statistics

  PROCEDURE [XDCL] avp$get_data_record_statistics
    (VAR space_used_by_data_records: integer;
     VAR data_record_count: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      data_record: ^avt$template_file_record,
      ignored_status: ost$status,
      index: ^avt$template_file_index,
      index_record: ^avt$template_file_record,
      index_record_header: ^avt$template_file_record_header,
      lock_set_by_this_procedure: boolean,
      position: avt$template_index_key_count,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$get_data_record_statistics);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    space_used_by_data_records := 0;
    data_record_count := 0;

    osp$establish_block_exit_hndlr (^condition_handler);

  /get_data_record_statistics/
    BEGIN
      avp$lock_template_file (avc$read_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        EXIT /get_data_record_statistics/;
      IFEND;

      index_record := #PTR (template_file_header^.first_index_record, template_file_heap^);

      WHILE index_record <> NIL DO
        build_index_record_pointers (index_record, index_record_header, index, status);
        IF NOT status.normal THEN
          EXIT /get_data_record_statistics/;
        IFEND;

        FOR position := 1 TO index_record_header^.keys_in_use DO
          data_record := #PTR (index^ [position].record_pointer, template_file_heap^);
          space_used_by_data_records := space_used_by_data_records + #SIZE (data_record^);
          data_record_count := data_record_count + 1;
        FOREND;

        index_record := #PTR (index_record_header^.next_index_record, template_file_heap^);
      WHILEND;
    END /get_data_record_statistics/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$get_data_record_statistics);
    ?IFEND

  PROCEND avp$get_data_record_statistics;
?? TITLE := '    [XDCL] avp$get_index_record_statistics', EJECT ??
*copy avh$get_index_record_statistics

  PROCEDURE [XDCL] avp$get_index_record_statistics
    (    depth: avt$template_file_index_depth;
     VAR space_used_by_index_records: integer;
     VAR index_record_count: integer;
     VAR total_key_count: integer;
     VAR minimum_key_count: integer;
     VAR maximum_key_count: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      ignored_status: ost$status,
      lock_set_by_this_procedure: boolean,
      template_file_header: ^avt$template_file_header,
      template_file_heap: ^avt$template_file_heap;

?? NEWTITLE := '      condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set by a template file manager procedure is released
{   if an error occurs.

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

      VAR
        ignored_status: ost$status;

      handler_status.normal := TRUE;

      IF lock_set_by_this_procedure THEN
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;

    PROCEND condition_handler;
?? TITLE := '      process_index_record', EJECT ??

{ PURPOSE:
{   This procedure is used to recursively to scan the index tree and collect
{   the statistical information about the index structure at the desired depth.

    PROCEDURE process_index_record
      (    current_depth: avt$template_file_index_depth;
           desired_depth: avt$template_file_index_depth;
           index_record: ^avt$template_file_record;
           template_file_heap: ^avt$template_file_heap;
       VAR space_used_by_index_records: integer;
       VAR index_record_count: integer;
       VAR total_key_count: integer;
       VAR minimum_key_count: integer;
       VAR maximum_key_count: integer;
       VAR status: ost$status);

      VAR
        index: ^avt$template_file_index,
        index_record_header: ^avt$template_file_record_header,
        position: avt$template_index_key_count;

      IF index_record <> NIL THEN
        build_index_record_pointers (index_record, index_record_header, index, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF current_depth = desired_depth THEN
          space_used_by_index_records := space_used_by_index_records + #SIZE (index_record^);
          index_record_count := index_record_count + 1;
          total_key_count := total_key_count + index_record_header^.keys_in_use;
          IF index_record_header^.keys_in_use < minimum_key_count THEN
            minimum_key_count := index_record_header^.keys_in_use;
          IFEND;
          IF index_record_header^.keys_in_use > maximum_key_count THEN
            maximum_key_count := index_record_header^.keys_in_use;
          IFEND;
        ELSE
          FOR position := 1 TO index_record_header^.keys_in_use DO
            process_index_record (current_depth + 1, desired_depth,
                  #PTR (index^ [position].record_pointer, template_file_heap^), template_file_heap,
                  space_used_by_index_records, index_record_count, total_key_count, minimum_key_count,
                  maximum_key_count, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND;
        IFEND;
      IFEND;

    PROCEND process_index_record;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$entry, 0, avk$get_index_record_statistics);
    ?IFEND

    lock_set_by_this_procedure := FALSE;
    #SPOIL (lock_set_by_this_procedure);

    space_used_by_index_records := 0;
    index_record_count := 0;
    total_key_count := 0;
    minimum_key_count := UPPERVALUE (minimum_key_count);
    maximum_key_count := LOWERVALUE (maximum_key_count);

    osp$establish_block_exit_hndlr (^condition_handler);

  /get_index_record_statistics/
    BEGIN
      avp$lock_template_file (avc$read_access, lock_set_by_this_procedure, template_file_header,
            template_file_heap, file_information, status);
      IF NOT status.normal THEN
        EXIT /get_index_record_statistics/;
      IFEND;

      IF depth > template_file_header^.index_depth THEN
        osp$set_status_abnormal ('AV', ave$incorrect_depth, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, depth, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, template_file_header^.index_depth, 10,
              FALSE, status);
        EXIT /get_index_record_statistics/
      IFEND;

      process_index_record (1, depth, #PTR (template_file_header^.root_index_record, template_file_heap^),
            template_file_heap, space_used_by_index_records, index_record_count, total_key_count,
            minimum_key_count, maximum_key_count, status);
    END /get_index_record_statistics/;

    IF lock_set_by_this_procedure THEN
      IF status.normal THEN
        avp$unlock_template_file (file_information, status);
      ELSE
        avp$unlock_template_file (file_information, ignored_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    ?IF avc$compile_keypoints THEN
      #KEYPOINT (osk$exit, 0, avk$get_index_record_statistics);
    ?IFEND

  PROCEND avp$get_index_record_statistics;
?? TITLE := '    binary_search_index', EJECT ??

{ PURPOSE:
{   This procedure is used to search an index array for the specified key.
{
{ NOTES:
{   If the key is found in the index array, the position of the key is
{   returned.  If the key is not found, the postion returned will be the
{   position of the closest key that is less than the specified key.
{
{   For example, assume the index contains the keys A, B, and D. The
{   desired key is C. This routine would return with postion set to 2 and
{   found key set to FALSE.

  PROCEDURE binary_search_index
    (    index: ^avt$template_file_index;
         keys_in_use: avt$template_index_key_count;
         key: avt$template_file_key;
     VAR found_key: boolean;
     VAR position: avt$template_index_key_count);

    VAR
      temp: integer,
      first_entry: 0 .. avc$max_template_index_keys + 1,
      last_entry: avt$template_index_key_count,
      middle_entry: avt$template_index_key_count;

    first_entry := 1;
    last_entry := keys_in_use;
    found_key := FALSE;

  /binary_search/
    WHILE (NOT found_key) AND (first_entry <= last_entry) DO

      temp := first_entry + last_entry;
      middle_entry := temp DIV 2;

      IF key < index^ [middle_entry].key THEN
        last_entry := middle_entry - 1;
      ELSEIF key > index^ [middle_entry].key THEN
        first_entry := middle_entry + 1;
      ELSE
        found_key := TRUE;
      IFEND;
    WHILEND /binary_search/;

    IF found_key THEN
      position := middle_entry;
    ELSE
      position := last_entry;
    IFEND;

  PROCEND binary_search_index;
?? TITLE := '    build_index_record_pointers', EJECT ??

{ PURPOSE:
{   This procedure returns pointers to the header and index array for an
{   index record.

  PROCEDURE build_index_record_pointers
    (    index_record: ^avt$template_file_record;
     VAR index_record_header: ^avt$template_file_record_header;
     VAR index: ^avt$template_file_index;
     VAR status: ost$status);

    VAR
      local_index_record: ^avt$template_file_record;

    status.normal := TRUE;

    local_index_record := index_record;
    RESET local_index_record;

    NEXT index_record_header IN local_index_record;
    IF index_record_header = NIL THEN
      corrupted_sequence ('BUILD_INDEX_RECORD_POINTERS', 'INDEX_RECORD_HEADER', 'LOCAL_INDEX_RECORD', status);
      RETURN;
    IFEND;

    NEXT index IN local_index_record;
    IF index = NIL THEN
      corrupted_sequence ('BUILD_INDEX_RECORD_POINTERS', 'INDEX', 'LOCAL_INDEX_RECORD', status);
      RETURN;
    IFEND;

  PROCEND build_index_record_pointers;
?? TITLE := '    delete_key', EJECT ??

{ PURPOSE:
{   This procedure removes the specified key for the index structure and
{   frees the space occupied by its correponding data record.

  PROCEDURE delete_key
    (    key: avt$template_file_key;
     VAR template_file_header: ^avt$template_file_header;
     VAR template_file_heap: ^avt$template_file_heap;
     VAR status: ost$status);

    VAR
      root_index: ^avt$template_file_index,
      root_index_record: ^avt$template_file_record,
      root_index_record_header: ^avt$template_file_record_header;

?? NEWTITLE := '      delete', EJECT ??

{ PURPOSE:
{   This procedure removes the specified index entry from an index array.

    PROCEDURE delete
      (    delete_position: avt$template_index_key_count;
       VAR keys_in_use: avt$template_index_key_count;
       VAR index: ^avt$template_file_index);

      VAR
        index_position: avt$template_index_key_count;

      FOR index_position := delete_position TO keys_in_use - 1 DO
        index^ [index_position] := index^ [index_position + 1];
      FOREND;
      index^ [keys_in_use].key := ' ';
      index^ [keys_in_use].record_pointer := NIL;
      keys_in_use := keys_in_use - 1;

    PROCEND delete;
?? TITLE := '      process_index_record', EJECT ??

{ PURPOSE:
{   This procedure recursively scans the index tree and removes the specified
{   key and frees the space used by its correponding data record.

    PROCEDURE process_index_record
      (    key: avt$template_file_key;
           current_depth: avt$template_file_index_depth;
           index_depth: avt$template_file_index_depth;
       VAR index_record_header: ^avt$template_file_record_header;
       VAR index: ^avt$template_file_index;
       VAR template_file_header: ^avt$template_file_header;
       VAR template_file_heap: ^avt$template_file_heap;
       VAR status: ost$status);

      VAR
        data_record_in_file: ^avt$template_file_record,
        found_key: boolean,
        index_position: avt$template_index_key_count,
        key_position: avt$template_index_key_count,
        left_sibling: ^avt$template_file_record,
        left_sibling_header: ^avt$template_file_record_header,
        left_sibling_index: ^avt$template_file_index,
        next_index: ^avt$template_file_index,
        next_index_record: ^avt$template_file_record,
        next_index_record_header: ^avt$template_file_record_header,
        right_sibling: ^avt$template_file_record,
        right_sibling_header: ^avt$template_file_record_header,
        right_sibling_index: ^avt$template_file_index;

      status.normal := TRUE;

      binary_search_index (index, index_record_header^.keys_in_use, key, found_key, key_position);
      IF key_position = 0 THEN
        osp$set_status_abnormal ('AV', ave$unknown_record, key, status);
        RETURN;
      IFEND;

      IF current_depth < index_depth THEN
        next_index_record := #PTR (index^ [key_position].record_pointer, template_file_heap^);

        build_index_record_pointers (next_index_record, next_index_record_header, next_index, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        process_index_record (key, current_depth + 1, index_depth, next_index_record_header, next_index,
              template_file_header, template_file_heap, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF next_index_record_header^.keys_in_use = 0 THEN
          left_sibling := #PTR (next_index_record_header^.previous_index_record, template_file_heap^);
          IF left_sibling <> NIL THEN
            build_index_record_pointers (left_sibling, left_sibling_header, left_sibling_index, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            left_sibling_header^.next_index_record := next_index_record_header^.next_index_record;
          ELSEIF current_depth = (index_depth - 1) THEN
            template_file_header^.first_index_record := next_index_record_header^.next_index_record;
          IFEND;

          right_sibling := #PTR (next_index_record_header^.next_index_record, template_file_heap^);
          IF right_sibling <> NIL THEN
            build_index_record_pointers (right_sibling, right_sibling_header, right_sibling_index, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            right_sibling_header^.previous_index_record := next_index_record_header^.previous_index_record;
          IFEND;

          delete (key_position, index_record_header^.keys_in_use, index);

          FREE next_index_record IN template_file_heap^;
        ELSE
          index^ [key_position].key := next_index^ [1].key;
        IFEND;
      ELSE
        IF found_key THEN
          data_record_in_file := #PTR (index^ [key_position].record_pointer, template_file_heap^);

          delete (key_position, index_record_header^.keys_in_use, index);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          FREE data_record_in_file IN template_file_heap^;
        ELSE
          osp$set_status_abnormal ('AV', ave$unknown_record, key, status);
          RETURN;
        IFEND;
      IFEND;

    PROCEND process_index_record;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

  /scan_index_tree/
    BEGIN
      root_index_record := #PTR (template_file_header^.root_index_record, template_file_heap^);

      IF root_index_record = NIL THEN
        osp$set_status_abnormal ('AV', ave$unknown_record, key, status);
        EXIT /scan_index_tree/;
      ELSE
        build_index_record_pointers (root_index_record, root_index_record_header, root_index, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        process_index_record (key, 1, template_file_header^.index_depth, root_index_record_header, root_index,
              template_file_header, template_file_heap, status);
        IF NOT status.normal THEN
          EXIT /scan_index_tree/;
        IFEND;

        IF root_index_record_header^.keys_in_use = 0 THEN
          template_file_header^.root_index_record := NIL;
          template_file_header^.first_index_record := NIL;
          template_file_header^.index_depth := 0;
          FREE root_index_record IN template_file_heap^;
        IFEND;
      IFEND;
    END /scan_index_tree/;

  PROCEND delete_key;
?? TITLE := '    find_key', EJECT ??

{ PURPOSE:
{   This procedure returns a pointer to the data record associated with the
{   specified key.

  PROCEDURE find_key
    (    key: avt$template_file_key;
         template_file_header: ^avt$template_file_header;
         template_file_heap: ^avt$template_file_heap;
     VAR data_record: ^avt$template_file_record;
     VAR status: ost$status);

    VAR
      current_depth: avt$template_file_index_depth,
      found_key: boolean,
      index_record_header: ^avt$template_file_record_header,
      index: ^avt$template_file_index,
      position: avt$template_index_key_count,
      template_file_record: ^avt$template_file_record;

    status.normal := TRUE;

    found_key := FALSE;

    template_file_record := #PTR (template_file_header^.root_index_record, template_file_heap^);
    IF template_file_record = NIL THEN
      osp$set_status_abnormal ('AV', ave$unknown_record, key, status);
      RETURN;
    IFEND;

    FOR current_depth := 1 TO template_file_header^.index_depth DO
      build_index_record_pointers (template_file_record, index_record_header, index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      binary_search_index (index, index_record_header^.keys_in_use, key, found_key, position);
      IF position <> 0 THEN
        template_file_record := #PTR (index^ [position].record_pointer, template_file_heap^);
      ELSE
        osp$set_status_abnormal ('AV', ave$unknown_record, key, status);
        RETURN;
      IFEND;
    FOREND;

    IF found_key THEN
      data_record := template_file_record;
    ELSE
      osp$set_status_abnormal ('AV', ave$unknown_record, key, status);
    IFEND;

  PROCEND find_key;
?? TITLE := '    find_next_key', EJECT ??

{ PURPOSE:
{   This procedure returns a pointer to the data record that follows a
{   specified key.

  PROCEDURE find_next_key
    (    previous_key: avt$template_file_key;
         template_file_header: ^avt$template_file_header;
         template_file_heap: ^avt$template_file_heap;
     VAR next_key: avt$template_file_key;
     VAR data_record: ^avt$template_file_record;
     VAR status: ost$status);

    VAR
      current_depth: avt$template_file_index_depth,
      found_key: boolean,
      index_record_header: ^avt$template_file_record_header,
      index: ^avt$template_file_index,
      position: avt$template_index_key_count,
      template_file_record: ^avt$template_file_record;

    status.normal := TRUE;

    template_file_record := #PTR (template_file_header^.root_index_record, template_file_heap^);
    IF template_file_record = NIL THEN
      osp$set_status_abnormal ('AV', ave$end_of_template_file, '', status);
      RETURN;
    IFEND;

    FOR current_depth := 1 TO template_file_header^.index_depth DO
      build_index_record_pointers (template_file_record, index_record_header, index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      binary_search_index (index, index_record_header^.keys_in_use, previous_key, found_key, position);
      IF position = 0 THEN
        template_file_record := #PTR (index^ [1].record_pointer, template_file_heap^);
      ELSE
        template_file_record := #PTR (index^ [position].record_pointer, template_file_heap^);
      IFEND;
    FOREND;

    position := position + 1;

    IF position <= index_record_header^.keys_in_use THEN
      next_key := index^ [position].key;
      data_record := #PTR (index^ [position].record_pointer, template_file_heap^);
    ELSE
      template_file_record := #PTR (index_record_header^.next_index_record, template_file_heap^);
      IF template_file_record = NIL THEN
        osp$set_status_abnormal ('AV', ave$end_of_template_file, '', status);
        RETURN;
      IFEND;
      build_index_record_pointers (template_file_record, index_record_header, index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      next_key := index^ [1].key;
      data_record := #PTR (index^ [1].record_pointer, template_file_heap^);
    IFEND;

  PROCEND find_next_key;
?? TITLE := '    insert_key', EJECT ??

{ PURPOSE:
{   This procedure inserts the specified key and copies its associated data record
{   to the template file.

  PROCEDURE insert_key
    (    key: avt$template_file_key;
         data_record: ^avt$template_file_record;
     VAR template_file_header: ^avt$template_file_header;
     VAR template_file_heap: ^avt$template_file_heap;
     VAR status: ost$status);

    VAR
      data_record_in_file: ^avt$template_file_record,
      data_record_pointer: avt$template_file_record_ptr,
      new_root_index: ^avt$template_file_index,
      new_root_index_record: ^avt$template_file_record,
      new_root_index_record_header: ^avt$template_file_record_header,
      next_level_inserted_at_end: boolean,
      root_index: ^avt$template_file_index,
      root_index_record: ^avt$template_file_record,
      root_index_record_header: ^avt$template_file_record_header,
      sibling_index: ^avt$template_file_index,
      sibling_index_record: ^avt$template_file_record,
      sibling_index_record_header: ^avt$template_file_record_header,
      work_area: ^SEQ ( * );

?? NEWTITLE := '      create_index_record', EJECT ??

{ PURPOSE:
{   This procedure allocates and initalizes a new index record.

    PROCEDURE create_index_record
      (VAR template_file_heap: ^avt$template_file_heap;
       VAR template_file_header: ^avt$template_file_header;
       VAR index_record: ^avt$template_file_record;
       VAR index_record_header: ^avt$template_file_record_header;
       VAR index: ^avt$template_file_index;
       VAR status: ost$status);

      VAR
        position: avt$template_index_key_count;

      ALLOCATE index_record: [[REP 1 OF avt$template_file_record_header,
            REP 1 OF avt$template_file_index]] IN template_file_heap^;
      IF index_record = NIL THEN
        osp$set_status_abnormal ('AV', ave$template_file_full, '', status);
        RETURN;
      IFEND;

      RESET index_record;

      NEXT index_record_header IN index_record;
      IF index_record_header = NIL THEN
        corrupted_sequence ('CREATE_INDEX_RECORD', 'INDEX_RECORD_HEADER', 'INDEX_RECORD', status);
        RETURN;
      IFEND;
      index_record_header^.kind := avc$index_record;
      index_record_header^.keys_in_use := 0;
      index_record_header^.previous_index_record := NIL;
      index_record_header^.next_index_record := NIL;

      NEXT index IN index_record;
      IF index = NIL THEN
        corrupted_sequence ('CREATE_INDEX_RECORD', 'INDEX', 'INDEX_RECORD', status);
        RETURN;
      IFEND;

      FOR position := 1 TO avc$max_template_index_keys DO
        index^ [position].key := ' ';
        index^ [position].record_pointer := NIL;
      FOREND;

    PROCEND create_index_record;
?? TITLE := '      insert', EJECT ??

{ PURPOSE:
{   This procedure inserts an index entry at the specified position in an
{   index array.

    PROCEDURE insert
      (    key: avt$template_file_key;
           record_pointer: avt$template_file_record_ptr;
           insert_position: avt$template_index_key_count;
       VAR keys_in_use: avt$template_index_key_count;
       VAR index: ^avt$template_file_index;
       VAR status: ost$status);

      VAR
        index_position: avt$template_index_key_count;

      IF keys_in_use < avc$max_template_index_keys THEN
        FOR index_position := keys_in_use DOWNTO insert_position DO
          index^ [index_position + 1] := index^ [index_position];
        FOREND;
        index^ [insert_position].key := key;
        index^ [insert_position].record_pointer := record_pointer;
        keys_in_use := keys_in_use + 1;
      ELSE
        osp$set_status_abnormal ('AV', ave$corrupted_index_record, '', status);
      IFEND;

    PROCEND insert;
?? TITLE := '      process_index_record', EJECT ??

{ PURPOSE:
{   This procedure recursively scans the index tree to insert the specified
{   key and pointer to its corresponding data record.

    PROCEDURE process_index_record
      (    key: avt$template_file_key;
           data_record_pointer: avt$template_file_record_ptr;
           current_depth: avt$template_file_index_depth;
           index_depth: avt$template_file_index_depth;
       VAR index_record_header: ^avt$template_file_record_header;
       VAR index: ^avt$template_file_index;
       VAR template_file_heap: ^avt$template_file_heap;
       VAR inserted_at_end: boolean;
       VAR status: ost$status);

      VAR
        found_key: boolean,
        index_position: avt$template_index_key_count,
        key_position: avt$template_index_key_count,
        next_index: ^avt$template_file_index,
        next_index_record: ^avt$template_file_record,
        next_index_record_header: ^avt$template_file_record_header,
        next_level_inserted_at_end: boolean,
        new_sibling_index: ^avt$template_file_index,
        new_sibling_index_record: ^avt$template_file_record,
        new_sibling_index_record_header: ^avt$template_file_record_header;

      status.normal := TRUE;

{ Look for the key in this index.

      binary_search_index (index, index_record_header^.keys_in_use, key, found_key, key_position);
      IF found_key THEN
        osp$set_status_abnormal ('AV', ave$record_already_exists, key, status);
        RETURN;
      IFEND;

      inserted_at_end := key_position = index_record_header^.keys_in_use;

      IF current_depth < index_depth THEN

{ If attempting to insert a key before the first key in the file, point at the
{ first index entry.

        IF key_position = 0 THEN
          key_position := 1;
        IFEND;

{ Get the pointers to the desired index record at the next level.

        next_index_record := #PTR (index^ [key_position].record_pointer, template_file_heap^);
        build_index_record_pointers (next_index_record, next_index_record_header, next_index, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        process_index_record (key, data_record_pointer, current_depth + 1, index_depth,
              next_index_record_header, next_index, template_file_heap, next_level_inserted_at_end, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Make sure the key recorded for the index record at the next level is the
{ first key in the index record at the next level.

        index^ [key_position].key := next_index^ [1].key;

{ If the index record at the next level is full, split it.

        IF next_index_record_header^.keys_in_use = avc$max_template_index_keys THEN
          split_index_record (next_level_inserted_at_end, next_index_record, next_index_record_header,
                next_index, new_sibling_index_record, new_sibling_index_record_header, new_sibling_index,
                template_file_header, template_file_heap, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          insert (new_sibling_index^ [1].key, #REL (new_sibling_index_record, template_file_heap^),
                (key_position + 1), index_record_header^.keys_in_use, index, status);
        IFEND;
      ELSE

{ Insert the key and data record pointer into the index record.

        IF index_record_header^.keys_in_use < avc$max_template_index_keys THEN
          insert (key, data_record_pointer, (key_position + 1), index_record_header^.keys_in_use, index,
                status);
        ELSE
          osp$set_status_abnormal ('AV', ave$corrupted_index_record, '', status);
        IFEND;
      IFEND;

    PROCEND process_index_record;
?? TITLE := '      split_index_record', EJECT ??

{ PURPOSE:
{   This procedure is used to split a full index record into two index
{   records.
{
{ NOTES:
{   In order to avoid wasting a large number of the index entries when a file when
{   entries are being made in alphbetical order (e.g., a validation file source run),
{   the block is split with 90% of the entries remaining in what was the full index
{   record and 10% of the entries in the new index record whenever the insertion that
{   caused the record to become full occured at the end of the index record.
{   Otherwise, the entries are divided equally between the two index records.

    PROCEDURE split_index_record
      (    last_insert_at_end: boolean;
       VAR index_record: ^avt$template_file_record;
       VAR index_record_header: ^avt$template_file_record_header;
       VAR index: ^avt$template_file_index;
       VAR new_sibling_index_record: ^avt$template_file_record;
       VAR new_sibling_index_record_header: ^avt$template_file_record_header;
       VAR new_sibling_index: ^avt$template_file_index;
       VAR template_file_header: ^avt$template_file_header;
       VAR template_file_heap: ^avt$template_file_heap;
       VAR status: ost$status);

      VAR
        index_position: avt$template_index_key_count,
        old_sibling_index_record: ^avt$template_file_record,
        old_sibling_index_record_header: ^avt$template_file_record_header,
        old_sibling_index: ^avt$template_file_index,
        split_position: avt$template_index_key_count;

      create_index_record (template_file_heap, template_file_header, new_sibling_index_record,
            new_sibling_index_record_header, new_sibling_index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF last_insert_at_end THEN
        split_position := (avc$max_template_index_keys * 90) DIV 100;
      ELSE
        split_position := avc$max_template_index_keys DIV 2;
      IFEND;

      FOR index_position := 1 TO (avc$max_template_index_keys - split_position) DO
        new_sibling_index^ [index_position] := index^ [index_position + split_position];
        index^ [index_position + split_position].key := ' ';
        index^ [index_position + split_position].record_pointer := NIL;
      FOREND;

      new_sibling_index_record_header^.keys_in_use := avc$max_template_index_keys - split_position;
      new_sibling_index_record_header^.previous_index_record := #REL (index_record, template_file_heap^);
      new_sibling_index_record_header^.next_index_record := index_record_header^.next_index_record;

      old_sibling_index_record := #PTR (index_record_header^.next_index_record, template_file_heap^);
      IF old_sibling_index_record <> NIL THEN
        build_index_record_pointers (old_sibling_index_record, old_sibling_index_record_header,
              old_sibling_index, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        old_sibling_index_record_header^.previous_index_record :=
              #REL (new_sibling_index_record, template_file_heap^);
      IFEND;

      index_record_header^.keys_in_use := split_position;
      index_record_header^.next_index_record := #REL (new_sibling_index_record, template_file_heap^);

    PROCEND split_index_record;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    ALLOCATE data_record_in_file: [[REP #SIZE (data_record^) OF cell]] IN template_file_heap^;
    IF data_record_in_file = NIL THEN
      osp$set_status_abnormal ('AV', ave$template_file_full, '', status);
      RETURN;
    IFEND;

    data_record_in_file^ := data_record^;
    data_record_pointer := #REL (data_record_in_file, template_file_heap^);

  /scan_index_tree/
    BEGIN
      root_index_record := #PTR (template_file_header^.root_index_record, template_file_heap^);

      IF root_index_record = NIL THEN
        create_index_record (template_file_heap, template_file_header, new_root_index_record,
              new_root_index_record_header, new_root_index, status);
        IF NOT status.normal THEN
          EXIT /scan_index_tree/;
        IFEND;

        new_root_index^ [1].key := key;
        new_root_index^ [1].record_pointer := data_record_pointer;
        new_root_index_record_header^.keys_in_use := 1;

        template_file_header^.root_index_record := #REL (new_root_index_record, template_file_heap^);
        template_file_header^.first_index_record := #REL (new_root_index_record, template_file_heap^);
        template_file_header^.index_depth := template_file_header^.index_depth + 1;
      ELSE
        build_index_record_pointers (root_index_record, root_index_record_header, root_index, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        process_index_record (key, data_record_pointer, 1, template_file_header^.index_depth,
              root_index_record_header, root_index, template_file_heap, next_level_inserted_at_end, status);
        IF NOT status.normal THEN
          EXIT /scan_index_tree/;
        IFEND;

        IF root_index_record_header^.keys_in_use = avc$max_template_index_keys THEN
          create_index_record (template_file_heap, template_file_header, new_root_index_record,
                new_root_index_record_header, new_root_index, status);
          IF NOT status.normal THEN
            EXIT /scan_index_tree/;
          IFEND;

          split_index_record (next_level_inserted_at_end, root_index_record, root_index_record_header,
                root_index, sibling_index_record, sibling_index_record_header, sibling_index,
                template_file_header, template_file_heap, status);
          IF NOT status.normal THEN
            EXIT /scan_index_tree/;
          IFEND;

          new_root_index^ [1].key := root_index^ [1].key;
          new_root_index^ [1].record_pointer := #REL (root_index_record, template_file_heap^);
          new_root_index^ [2].key := sibling_index^ [1].key;
          new_root_index^ [2].record_pointer := #REL (sibling_index_record, template_file_heap^);
          new_root_index_record_header^.keys_in_use := 2;

          template_file_header^.root_index_record := #REL (new_root_index_record, template_file_heap^);
          template_file_header^.index_depth := template_file_header^.index_depth + 1;
        IFEND;
      IFEND;
    END /scan_index_tree/;

    IF NOT status.normal THEN
      FREE data_record_in_file IN template_file_heap^;
    IFEND;

  PROCEND insert_key;
?? TITLE := '    replace_key', EJECT ??

{ PURPOSE:
{   This procedure is used to replace the data record associated with
{   the specified key.

  PROCEDURE replace_key
    (    key: avt$template_file_key;
         data_record: ^avt$template_file_record;
         template_file_header: ^avt$template_file_header;
         template_file_heap: ^avt$template_file_heap;
     VAR status: ost$status);

    VAR
      current_depth: avt$template_file_index_depth,
      found_key: boolean,
      index_record_header: ^avt$template_file_record_header,
      index: ^avt$template_file_index,
      new_data_record_in_file: ^avt$template_file_record,
      old_data_record_in_file: ^avt$template_file_record,
      position: avt$template_index_key_count,
      template_file_record: ^avt$template_file_record;

    status.normal := TRUE;

    found_key := FALSE;

    template_file_record := #PTR (template_file_header^.root_index_record, template_file_heap^);
    IF template_file_record = NIL THEN
      osp$set_status_abnormal ('AV', ave$unknown_record, key, status);
      RETURN;
    IFEND;

    FOR current_depth := 1 TO template_file_header^.index_depth DO
      build_index_record_pointers (template_file_record, index_record_header, index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      binary_search_index (index, index_record_header^.keys_in_use, key, found_key, position);
      IF position <> 0 THEN
        template_file_record := #PTR (index^ [position].record_pointer, template_file_heap^);
      ELSE
        osp$set_status_abnormal ('AV', ave$unknown_record, key, status);
        RETURN;
      IFEND;
    FOREND;

    IF found_key THEN
      old_data_record_in_file := template_file_record;
      IF #SIZE (old_data_record_in_file^) = #SIZE (data_record^) THEN
        old_data_record_in_file^ := data_record^;
      ELSE
        ALLOCATE new_data_record_in_file: [[REP #SIZE (data_record^) OF cell]] IN template_file_heap^;
        IF new_data_record_in_file = NIL THEN
          osp$set_status_abnormal ('AV', ave$template_file_full, '', status);
          RETURN;
        IFEND;
        new_data_record_in_file^ := data_record^;
        index^ [position].record_pointer := #REL (new_data_record_in_file, template_file_heap^);
        FREE old_data_record_in_file IN template_file_heap^;
      IFEND;
    ELSE
      osp$set_status_abnormal ('AV', ave$unknown_record, key, status);
    IFEND;

  PROCEND replace_key;
?? OLDTITLE ??
?? TITLE := '  Helper Routines' ??
?? NEWTITLE := '    binary_search_field_directory', EJECT ??

{ PURPOSE:
{   This procedure is used to search a field directory for a field with the
{   specified name.

  PROCEDURE binary_search_field_directory
    (    field_name: ost$name;
         field_directory: ^avt$field_directory;
     VAR found_field: boolean;
     VAR entry: avt$field_count);

    VAR
      temp: integer,
      first_entry: 0 .. avc$maximum_field_count + 1,
      last_entry: avt$field_count,
      middle_entry: avt$field_count;

    first_entry := 1;
    last_entry := UPPERBOUND (field_directory^);
    found_field := FALSE;

  /binary_search/
    WHILE (NOT found_field) AND (first_entry <= last_entry) DO
      temp := first_entry + last_entry;
      middle_entry := temp DIV 2;

      IF field_name < field_directory^ [middle_entry].name THEN
        last_entry := middle_entry - 1;
      ELSEIF field_name > field_directory^ [middle_entry].name THEN
        first_entry := middle_entry + 1;
      ELSE
        found_field := TRUE;
      IFEND;
    WHILEND /binary_search/;

    IF found_field THEN
      entry := middle_entry;
    ELSE
      entry := last_entry;
    IFEND;

  PROCEND binary_search_field_directory;
?? TITLE := '    binary_search_value_directory', EJECT ??

{ PURPOSE:
{   This procedure is used to search a value directory for a field with the
{   specified system supplied field id.

  PROCEDURE binary_search_value_directory
    (    system_supplied_field_id: avt$system_supplied_field_id;
         value_directory: ^avt$value_directory;
     VAR found_field: boolean;
     VAR entry: avt$field_count);

    VAR
      temp: integer,
      first_entry: 0 .. avc$maximum_field_count + 1,
      last_entry: avt$field_count,
      middle_entry: avt$field_count;

    first_entry := 1;
    last_entry := UPPERBOUND (value_directory^);
    found_field := FALSE;

  /binary_search/
    WHILE (NOT found_field) AND (first_entry <= last_entry) DO
      temp := first_entry + last_entry;
      middle_entry := temp DIV 2;

      IF system_supplied_field_id < value_directory^ [middle_entry].system_supplied_field_id THEN
        last_entry := middle_entry - 1;
      ELSEIF system_supplied_field_id > value_directory^ [middle_entry].system_supplied_field_id THEN
        first_entry := middle_entry + 1;
      ELSE
        found_field := TRUE;
      IFEND;
    WHILEND /binary_search/;

    IF found_field THEN
      entry := middle_entry;
    ELSE
      entry := last_entry;
    IFEND;

  PROCEND binary_search_value_directory;
?? TITLE := '    build_field_description', EJECT ??

{ PURPOSE:
{   This procedure is used build a field description in a description
{   record.

  PROCEDURE build_field_description
    (    type_specification: avt$type_specification;
         default_value: avt$field_value;
         description: ^avt$descriptive_text;
         utility_information: ^avt$utility_information;
     VAR field_description: ^avt$field_description;
     VAR template_file_record: ^avt$template_file_record;
     VAR status: ost$status);

    VAR
      field_description_header: ^avt$field_description_header,
      field_description_size: integer,
      field_desc_default_value: ^avt$internal_field_value,
      field_desc_descriptive_text: ^avt$descriptive_text,
      field_desc_type_specification: ^avt$internal_type_specification,
      field_desc_utility_information: ^avt$utility_information,
      starting_position: integer;

    status.normal := TRUE;

    starting_position := i#current_sequence_position (template_file_record);

    NEXT field_description_header IN template_file_record;
    IF field_description_header = NIL THEN
      osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
      RETURN;
    IFEND;

    convert_ext_type_spec_to_int (type_specification, field_desc_type_specification, template_file_record,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    convert_ext_field_value_to_int (NIL, default_value, field_desc_default_value, template_file_record,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF description = NIL THEN
      field_desc_descriptive_text := NIL;
    ELSE
      NEXT field_desc_descriptive_text: [#SIZE (description^)] IN template_file_record;
      field_desc_descriptive_text^ := description^;
    IFEND;

    IF utility_information = NIL THEN
      field_desc_utility_information := NIL;
    ELSE
      NEXT field_desc_utility_information: [[REP #SIZE (utility_information^) OF cell]] IN
            template_file_record;
      field_desc_utility_information^ := utility_information^;
    IFEND;

    field_description_size := i#current_sequence_position (template_file_record) - starting_position;

    RESET template_file_record TO field_description_header;

    NEXT field_description: [[REP field_description_size OF cell]] IN template_file_record;
    IF field_description = NIL THEN
      corrupted_sequence ('BUILD_FIELD_DESCRIPTION', 'FIELD_DESCRIPTION', 'TEMPLATE_FILE_WORK_AREA', status);
      RETURN;
    IFEND;

    RESET field_description;

    field_description_header^.type_specification := #REL (field_desc_type_specification, field_description^);
    field_description_header^.default_value := #REL (field_desc_default_value, field_description^);
    field_description_header^.descriptive_text := #REL (field_desc_descriptive_text, field_description^);
    field_description_header^.utility_information := #REL (field_desc_utility_information,
          field_description^);

  PROCEND build_field_description;
?? TITLE := '    build_template_pointers', EJECT ??

{ PURPOSE:
{   This procedure is used to construct the pointers to the template
{   file header and template file heap based on the information in
{   the file information record.

  PROCEDURE build_template_pointers
    (    file_information: avt$template_file_information;
     VAR template_file_header: ^avt$template_file_header;
     VAR template_file_heap: ^avt$template_file_heap;
     VAR status: ost$status);

    VAR
      template_file: ^avt$template_file;

    i#build_adaptable_seq_pointer (#RING (^template_file_header), file_information.segment_number, 0,
          file_information.size, 0, template_file);
    template_file_header := #PTR (file_information.template_file_header, template_file^);
    template_file_heap := #PTR (file_information.template_file_heap, template_file^);

  PROCEND build_template_pointers;
?? TITLE := '    check_if_field_deleted', EJECT ??

{ PURPOSE:
{   This procedure is used to check if a field is deleted.
{
{ NOTES:
{   Fields are only logically deleted and the operating system level
{   at the time the field is deleted is recorded.  If a previous
{   version of the operating system is deadstarted, the the deleted
{   fields reappear.

  PROCEDURE check_if_field_deleted
    (    delete_status: avt$field_delete_status;
     VAR deleted: boolean;
     VAR status: ost$status);

    VAR
      os_version: pmt$os_name;

    status.normal := TRUE;

    deleted := delete_status.deleted;

    IF deleted THEN
      pmp$get_os_version (os_version, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF os_version < delete_status.os_version_when_deleted THEN
        deleted := FALSE;
      IFEND;
    IFEND;

  PROCEND check_if_field_deleted;
?? TITLE := '    corrupted_sequence', EJECT ??

{ PURPOSE:
{   This procedure is used to set an abnormal status when the template
{   file manager is not able to retieve information from an internal data
{   structure.

  PROCEDURE corrupted_sequence
    (    procedure_name: string ( * );
         variable_name: string ( * );
         sequence_name: string ( * );
     VAR status: ost$status);

    osp$set_status_abnormal ('AV', ave$corrupted_sequence, procedure_name, status);
    osp$append_status_parameter (osc$status_parameter_delimiter, variable_name, status);
    osp$append_status_parameter (osc$status_parameter_delimiter, sequence_name, status);

  PROCEND corrupted_sequence;
?? TITLE := '    convert_ext_field_value_to_int', EJECT ??

{ PURPOSE:
{   This procedure compares a field value with its default value and if the
{   field value is different than the default value, translates the field value
{   into its internal format and stores it in a template file record.
{
{ NOTES:
{   If the field value matches its default value, a NIL pointer is returned for
{   the internal field value and the the internal format is not stored in the
{   template file record.

  PROCEDURE convert_ext_field_value_to_int
    (    default_value: ^avt$field_value;
         field_value: avt$field_value;
     VAR internal_field_value: ^avt$internal_field_value;
     VAR template_file_record: ^avt$template_file_record;
     VAR status: ost$status);

    VAR
      internal_field_value_size: integer,
      internal_unknown_value: ^avt$internal_field_value,
      kind: ^avt$field_kind,
      starting_position: integer;

?? NEWTITLE := '      convert_account_project', EJECT ??

    PROCEDURE convert_account_project
      (    default_value: ^avt$field_value;
           field_value: avt$field_value;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        account_name: ^avt$account_name,
        project_name: ^avt$project_name;

      status.normal := TRUE;

      IF (default_value = NIL) OR (field_value.account_name^ <> default_value^.account_name^) OR
            (field_value.project_name^ <> default_value^.project_name^) THEN
        NEXT account_name IN template_file_record;
        IF account_name = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        account_name^ := field_value.account_name^;

        NEXT project_name IN template_file_record;
        IF project_name = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        project_name^ := field_value.project_name^;
      IFEND;

    PROCEND convert_account_project;
?? TITLE := '      convert_accumulating_limit', EJECT ??

    PROCEDURE convert_accumulating_limit
      (    default_value: ^avt$field_value;
           field_value: avt$field_value;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        limit_value: ^avt$limit_value,
        use_default_value: ^boolean;

      status.normal := TRUE;

      NEXT use_default_value IN template_file_record;
      IF use_default_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF (default_value = NIL) OR (field_value.job_warning_limit^ <> default_value^.job_warning_limit^) THEN
        use_default_value^ := FALSE;
        NEXT limit_value IN template_file_record;
        IF limit_value = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        limit_value^ := field_value.job_warning_limit^;
      ELSE
        use_default_value^ := TRUE;
      IFEND;

      NEXT use_default_value IN template_file_record;
      IF use_default_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF (default_value = NIL) OR (field_value.job_maximum_limit^ <> default_value^.job_maximum_limit^) THEN
        use_default_value^ := FALSE;
        NEXT limit_value IN template_file_record;
        IF limit_value = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        limit_value^ := field_value.job_maximum_limit^;
      ELSE
        use_default_value^ := TRUE;
      IFEND;

      NEXT use_default_value IN template_file_record;
      IF use_default_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF (default_value = NIL) OR (field_value.total_limit^ <> default_value^.total_limit^) THEN
        use_default_value^ := FALSE;
        NEXT limit_value IN template_file_record;
        IF limit_value = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        limit_value^ := field_value.total_limit^;
      ELSE
        use_default_value^ := TRUE;
      IFEND;

      NEXT limit_value IN template_file_record;
      IF limit_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      limit_value^ := field_value.total_accumulation^;

    PROCEND convert_accumulating_limit;
?? TITLE := '      convert_capability', EJECT ??

    PROCEDURE convert_capability
      (    default_value: ^avt$field_value;
           field_value: avt$field_value;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        capability: ^boolean;

      status.normal := TRUE;

      IF (default_value = NIL) OR (field_value.capability^ <> default_value^.capability^) THEN
        NEXT capability IN template_file_record;
        IF capability = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        capability^ := field_value.capability^;
      IFEND;

    PROCEND convert_capability;
?? TITLE := '      convert_date_time', EJECT ??

    PROCEDURE convert_date_time
      (    default_value: ^avt$field_value;
           field_value: avt$field_value;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        date_time: ^avt$date_time;

      status.normal := TRUE;

      IF default_value <> NIL THEN
        IF field_value.date_time^.range THEN
          IF (field_value.date_time^.starting_value = default_value^.date_time^.starting_value) AND
                (field_value.date_time^.ending_value = default_value^.date_time^.ending_value) THEN
            RETURN;
          IFEND;
        ELSE
          IF field_value.date_time^.value = default_value^.date_time^.value THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;

      NEXT date_time IN template_file_record;
      IF date_time = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      date_time^ := field_value.date_time^;

    PROCEND convert_date_time;
?? TITLE := '      convert_file', EJECT ??

    PROCEDURE convert_file
      (    default_value: ^avt$field_value;
           field_value: avt$field_value;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        file_reference: ^fst$file_reference,
        file_reference_size: ^fst$path_size;

      status.normal := TRUE;

      IF default_value <> NIL THEN
        IF field_value.file = default_value^.file THEN
          RETURN;
        ELSEIF (field_value.file <> NIL) AND (default_value^.file <> NIL) AND
              (field_value.file^ = default_value^.file^) THEN
          RETURN;
        IFEND;
      IFEND;

      NEXT file_reference_size IN template_file_record;
      IF file_reference_size = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF field_value.file = NIL THEN
        file_reference_size^ := 0;
      ELSE
        file_reference_size^ := #SIZE (field_value.file^);
        NEXT file_reference: [file_reference_size^] IN template_file_record;
        IF file_reference = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        #TRANSLATE (osv$lower_to_upper, field_value.file^, file_reference^);
      IFEND;

    PROCEND convert_file;
?? TITLE := '      convert_integer', EJECT ??

    PROCEDURE convert_integer
      (    default_value: ^avt$field_value;
           field_value: avt$field_value;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        integer_value: ^integer;

      status.normal := TRUE;

      IF (default_value = NIL) OR (field_value.integer_value^ <> default_value^.integer_value^) THEN
        NEXT integer_value IN template_file_record;
        IF integer_value = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        integer_value^ := field_value.integer_value^;
      IFEND;

    PROCEND convert_integer;
?? TITLE := '      convert_job_class', EJECT ??

    PROCEDURE convert_job_class
      (    default_value: ^avt$field_value;
           field_value: avt$field_value;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        batch_default: ^ost$name,
        interactive_default: ^ost$name,
        job_class_list: ^avt$name_list,
        job_class_list_size: ^avt$name_list_size,
        use_default_value: ^boolean;

      status.normal := TRUE;

      NEXT use_default_value IN template_file_record;
      IF use_default_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF default_value = NIL THEN
        use_default_value^ := FALSE;
      ELSE
        determine_if_name_lists_match (field_value.job_classes, default_value^.job_classes,
              use_default_value^);
      IFEND;

      IF NOT use_default_value^ THEN
        NEXT job_class_list_size IN template_file_record;
        IF job_class_list_size = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;

        IF field_value.job_classes = NIL THEN
          job_class_list_size^ := 0;
        ELSE
          NEXT job_class_list: [1 .. UPPERBOUND (field_value.job_classes^)] IN template_file_record;
          IF job_class_list = NIL THEN
            osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
            RETURN;
          IFEND;
          job_class_list^ := field_value.job_classes^;
          job_class_list_size^ := UPPERBOUND (field_value.job_classes^);
        IFEND;
      IFEND;

      NEXT use_default_value IN template_file_record;
      IF use_default_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF (default_value = NIL) OR (field_value.batch_job_class_default^ <>
            default_value^.batch_job_class_default^) THEN
        use_default_value^ := FALSE;
        NEXT batch_default IN template_file_record;
        IF batch_default = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        batch_default^ := field_value.batch_job_class_default^;
      ELSE
        use_default_value^ := TRUE;
      IFEND;

      NEXT use_default_value IN template_file_record;
      IF use_default_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF (default_value = NIL) OR (field_value.interactive_job_class_default^ <>
            default_value^.interactive_job_class_default^) THEN
        use_default_value^ := FALSE;
        NEXT interactive_default IN template_file_record;
        IF interactive_default = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        interactive_default^ := field_value.interactive_job_class_default^;
      ELSE
        use_default_value^ := TRUE;
      IFEND;

    PROCEND convert_job_class;
?? TITLE := '      convert_labeled_names', EJECT ??

    PROCEDURE convert_labeled_names
      (    default_value: ^avt$field_value;
           field_value: avt$field_value;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        index: avt$name_list_size,
        label: ^ost$name,
        lists_match: boolean,
        name_list: ^avt$name_list,
        name_list_size: ^avt$name_list_size,
        number_of_labels: ^avt$name_list_size;

      status.normal := TRUE;

      IF default_value <> NIL THEN
        determine_if_labeled_names_matc (field_value.labeled_names, default_value^.labeled_names,
              lists_match);
        IF lists_match THEN
          RETURN;
        IFEND;
      IFEND;

      NEXT number_of_labels IN template_file_record;
      IF number_of_labels = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF field_value.labeled_names = NIL THEN
        number_of_labels^ := 0;
      ELSE
        number_of_labels^ := UPPERBOUND (field_value.labeled_names^);
        FOR index := 1 TO number_of_labels^ DO
          NEXT label IN template_file_record;
          IF label = NIL THEN
            osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
            RETURN;
          IFEND;
          label^ := field_value.labeled_names^ [index].label^;
          NEXT name_list_size IN template_file_record;
          IF name_list_size = NIL THEN
            osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
            RETURN;
          IFEND;
          name_list_size^ := UPPERBOUND (field_value.labeled_names^ [index].names^);
          NEXT name_list: [1 .. name_list_size^] IN template_file_record;
          IF name_list = NIL THEN
            osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
            RETURN;
          IFEND;
          name_list^ := field_value.labeled_names^ [index].names^;
        FOREND;
      IFEND;

    PROCEND convert_labeled_names;
?? TITLE := '      convert_limit', EJECT ??

    PROCEDURE convert_limit
      (    default_value: ^avt$field_value;
           field_value: avt$field_value;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        limit_value: ^avt$limit_value;

      status.normal := TRUE;

      IF (default_value = NIL) OR (field_value.limit_value^ <> default_value^.limit_value^) THEN
        NEXT limit_value IN template_file_record;
        IF limit_value = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        limit_value^ := field_value.limit_value^;
      IFEND;

    PROCEND convert_limit;
?? TITLE := '      convert_login_password', EJECT ??

    PROCEDURE convert_login_password
      (    default_value: ^avt$field_value;
           field_value: avt$field_value;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        change_date: ^ost$date_time,
        expiration_date: ^ost$date_time,
        expiration_interval: ^pmt$time_increment,
        expiration_warning_interval: ^pmt$time_increment,
        exp_password_change_interval: ^pmt$time_increment,
        login_password: ^avt$login_password,
        no_expiration_date: ^boolean,
        password_attributes: ^avt$name_list,
        password_attributes_size: ^avt$name_list_size,
        unlimited_expiration_interval: ^boolean,
        use_default_value: ^boolean;

      status.normal := TRUE;

      NEXT use_default_value IN template_file_record;
      IF use_default_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF (default_value = NIL) OR (field_value.login_password^.value <> default_value^.login_password^.value)
            THEN
        use_default_value^ := FALSE;
        NEXT login_password IN template_file_record;
        IF login_password = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        login_password^ := field_value.login_password^;
      ELSE
        use_default_value^ := TRUE;
      IFEND;

      NEXT use_default_value IN template_file_record;
      IF use_default_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF (default_value = NIL) OR (default_value^.login_password_exp_date^ <>
            field_value.login_password_exp_date^) THEN
        use_default_value^ := FALSE;
        NEXT expiration_date IN template_file_record;
        IF expiration_date = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        expiration_date^ := field_value.login_password_exp_date^;
      ELSE
        use_default_value^ := TRUE;
      IFEND;

      NEXT use_default_value IN template_file_record;
      IF use_default_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF (default_value = NIL) OR (default_value^.login_password_exp_interval^ <>
            field_value.login_password_exp_interval^) THEN
        use_default_value^ := FALSE;
        NEXT expiration_interval IN template_file_record;
        IF expiration_interval = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        expiration_interval^ := field_value.login_password_exp_interval^;
      ELSE
        use_default_value^ := TRUE;
      IFEND;

      NEXT use_default_value IN template_file_record;
      IF use_default_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF (default_value = NIL) OR (default_value^.login_password_max_exp_interval^ <>
            field_value.login_password_max_exp_interval^) THEN
        use_default_value^ := FALSE;
        NEXT expiration_interval IN template_file_record;
        IF expiration_interval = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        expiration_interval^ := field_value.login_password_max_exp_interval^;
      ELSE
        use_default_value^ := TRUE;
      IFEND;

      NEXT use_default_value IN template_file_record;
      IF use_default_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF (default_value = NIL) OR (default_value^.login_password_exp_warning^ <>
            field_value.login_password_exp_warning^) THEN
        use_default_value^ := FALSE;
        NEXT expiration_warning_interval IN template_file_record;
        IF expiration_warning_interval = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        expiration_warning_interval^ := field_value.login_password_exp_warning^;
      ELSE
        use_default_value^ := TRUE;
      IFEND;

      NEXT use_default_value IN template_file_record;
      IF use_default_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF (default_value = NIL) OR (default_value^.login_password_exp_chg_interval^ <>
            field_value.login_password_exp_chg_interval^) THEN
        use_default_value^ := FALSE;
        NEXT exp_password_change_interval IN template_file_record;
        IF exp_password_change_interval = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        exp_password_change_interval^ := field_value.login_password_exp_chg_interval^;
      ELSE
        use_default_value^ := TRUE;
      IFEND;

      NEXT use_default_value IN template_file_record;
      IF use_default_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF default_value <> NIL THEN
        determine_if_name_lists_match (field_value.login_password_attributes,
              default_value^.login_password_attributes, use_default_value^);
      ELSE
        use_default_value^ := FALSE;
      IFEND;

      IF NOT use_default_value^ THEN
        NEXT password_attributes_size IN template_file_record;
        IF password_attributes_size = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;

        IF field_value.login_password_attributes = NIL THEN
          password_attributes_size^ := 0;
        ELSE
          NEXT password_attributes: [1 .. UPPERBOUND (field_value.login_password_attributes^)] IN
                template_file_record;
          IF password_attributes = NIL THEN
            osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
            RETURN;
          IFEND;
          password_attributes^ := field_value.login_password_attributes^;
          password_attributes_size^ := UPPERBOUND (field_value.login_password_attributes^);
        IFEND;
      IFEND;

      NEXT change_date IN template_file_record;
      IF change_date = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      IF field_value.login_password_change_date = NIL THEN
        change_date^.year := LOWERVALUE (change_date^.year);
        change_date^.month := LOWERVALUE (change_date^.month);
        change_date^.day := LOWERVALUE (change_date^.day);
        change_date^.hour := LOWERVALUE (change_date^.hour);
        change_date^.minute := LOWERVALUE (change_date^.minute);
        change_date^.second := LOWERVALUE (change_date^.second);
        change_date^.millisecond := LOWERVALUE (change_date^.millisecond);
      ELSE
        change_date^ := field_value.login_password_change_date^;
      IFEND;

    PROCEND convert_login_password;
?? TITLE := '      convert_name', EJECT ??

    PROCEDURE convert_name
      (    default_value: ^avt$field_value;
           field_value: avt$field_value;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        lists_match: boolean,
        name_list: ^avt$name_list,
        name_list_size: ^avt$name_list_size;

      status.normal := TRUE;

      IF default_value <> NIL THEN
        determine_if_name_lists_match (field_value.names, default_value^.names, lists_match);
        IF lists_match THEN
          RETURN;
        IFEND;
      IFEND;

      NEXT name_list_size IN template_file_record;
      IF name_list_size = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF field_value.names = NIL THEN
        name_list_size^ := 0;
      ELSE
        NEXT name_list: [1 .. UPPERBOUND (field_value.names^)] IN template_file_record;
        IF name_list = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        name_list^ := field_value.names^;
        name_list_size^ := UPPERBOUND (field_value.names^);
      IFEND;

    PROCEND convert_name;
?? TITLE := '      convert_real', EJECT ??

    PROCEDURE convert_real
      (    default_value: ^avt$field_value;
           field_value: avt$field_value;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        real_value: ^real;

      status.normal := TRUE;

      IF (default_value <> NIL) AND (field_value.real_value^ = default_value^.real_value^) THEN
        RETURN;
      IFEND;

      NEXT real_value IN template_file_record;
      IF real_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      real_value^ := field_value.real_value^;

    PROCEND convert_real;
?? TITLE := '      convert_restriction', EJECT ??

    PROCEDURE convert_restriction
      (    default_value: ^avt$field_value;
           field_value: avt$field_value;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        restriction: ^boolean;

      status.normal := TRUE;

      IF (default_value <> NIL) AND (field_value.restriction^ = default_value^.restriction^) THEN
        RETURN;
      IFEND;

      NEXT restriction IN template_file_record;
      IF restriction = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      restriction^ := field_value.restriction^;

    PROCEND convert_restriction;
?? TITLE := '      convert_ring_privilege', EJECT ??

    PROCEDURE convert_ring_privilege
      (    default_value: ^avt$field_value;
           field_value: avt$field_value;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        ring: ^ost$ring,
        use_default_value: ^boolean;

      status.normal := TRUE;

      NEXT use_default_value IN template_file_record;
      IF use_default_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF (default_value = NIL) OR (field_value.minimum_ring^ <> default_value^.minimum_ring^) THEN
        use_default_value^ := FALSE;
        NEXT ring IN template_file_record;
        IF ring = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        ring^ := field_value.minimum_ring^;
      ELSE
        use_default_value^ := TRUE;
      IFEND;

      NEXT use_default_value IN template_file_record;
      IF use_default_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF (default_value = NIL) OR (field_value.nominal_ring^ <> default_value^.nominal_ring^) THEN
        use_default_value^ := FALSE;
        NEXT ring IN template_file_record;
        IF ring = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        ring^ := field_value.nominal_ring^;
      ELSE
        use_default_value^ := TRUE;
      IFEND;

    PROCEND convert_ring_privilege;
?? TITLE := '      convert_string', EJECT ??

    PROCEDURE convert_string
      (    default_value: ^avt$field_value;
           field_value: avt$field_value;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        string_value: ^string ( * ),
        string_size: ^ost$string_size;

      status.normal := TRUE;

      IF default_value <> NIL THEN
        IF field_value.string_value = default_value^.string_value THEN
          RETURN;
        ELSEIF (field_value.string_value <> NIL) AND (default_value^.string_value <> NIL) AND
              (field_value.string_value^ = default_value^.string_value^) THEN
          RETURN;
        IFEND;
      IFEND;

      NEXT string_size IN template_file_record;
      IF string_size = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF field_value.string_value = NIL THEN
        string_size^ := 0;
      ELSE
        NEXT string_value: [#SIZE (field_value.string_value^)] IN template_file_record;
        IF string_value = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        string_value^ := field_value.string_value^;
        string_size^ := #SIZE (field_value.string_value^);
      IFEND;

    PROCEND convert_string;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    IF default_value <> NIL THEN
      IF field_value.kind <> default_value^.kind THEN
        osp$set_status_abnormal ('AV', ave$kinds_do_not_match, 'default value', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'field value', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'CONVERT_EXT_FIELD_VALUE_TO_INT',
              status);
        RETURN;
      IFEND;
    IFEND;

    starting_position := i#current_sequence_position (template_file_record);

    NEXT kind IN template_file_record;
    IF kind = NIL THEN
      osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
      RETURN;
    IFEND;

    kind^ := field_value.kind;

    CASE field_value.kind OF
    = avc$account_project_kind =
      convert_account_project (default_value, field_value, template_file_record, status);
    = avc$accumulating_limit_kind =
      convert_accumulating_limit (default_value, field_value, template_file_record, status);
    = avc$capability_kind =
      convert_capability (default_value, field_value, template_file_record, status);
    = avc$date_time_kind =
      convert_date_time (default_value, field_value, template_file_record, status);
    = avc$file_kind =
      convert_file (default_value, field_value, template_file_record, status);
    = avc$integer_kind =
      convert_integer (default_value, field_value, template_file_record, status);
    = avc$job_class_kind =
      convert_job_class (default_value, field_value, template_file_record, status);
    = avc$keyword_kind =
      osp$set_status_abnormal ('AV', ave$kind_not_implemented, 'KEYWORD', status);
    = avc$labeled_names_kind =
      convert_labeled_names (default_value, field_value, template_file_record, status);
    = avc$limit_kind =
      convert_limit (default_value, field_value, template_file_record, status);
    = avc$login_password_kind =
      convert_login_password (default_value, field_value, template_file_record, status);
    = avc$name_kind =
      convert_name (default_value, field_value, template_file_record, status);
    = avc$real_kind =
      convert_real (default_value, field_value, template_file_record, status);
    = avc$restriction_kind =
      convert_restriction (default_value, field_value, template_file_record, status);
    = avc$ring_privilege_kind =
      convert_ring_privilege (default_value, field_value, template_file_record, status);
    = avc$string_kind =
      convert_string (default_value, field_value, template_file_record, status);
    = avc$first_unused_kind .. avc$last_unused_kind =
      RESET template_file_record TO kind;
      NEXT internal_unknown_value: [[REP #size(field_value.unknown_value^) OF cell]] IN
            template_file_record;
      IF internal_unknown_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      internal_unknown_value^ := field_value.unknown_value^;
    ELSE
      osp$set_status_abnormal ('AV', ave$unknown_field_kind, 'CONVERT_EXT_FIELD_VALUE_TO_INT', status);
    CASEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    internal_field_value_size := i#current_sequence_position (template_file_record) - starting_position;

    RESET template_file_record TO kind;

    IF internal_field_value_size <> #SIZE (avt$field_kind) THEN
      NEXT internal_field_value: [[REP internal_field_value_size OF cell]] IN template_file_record;
      IF internal_field_value = NIL THEN
        corrupted_sequence ('CONVERT_EXT_FIELD_VALUE_TO_INT', 'INTERNAL_FIELD_VALUE', 'TEMPLATE_FILE_RECORD',
              status);
        RETURN;
      IFEND;
    ELSE
      internal_field_value := NIL;
    IFEND;

  PROCEND convert_ext_field_value_to_int;
?? TITLE := '    convert_ext_type_spec_to_int', EJECT ??

{ PURPOSE:
{   This converts a type specification to its internal format and stores it in
{   a template file record.

  PROCEDURE convert_ext_type_spec_to_int
    (    type_specification: avt$type_specification;
     VAR internal_type_specification: ^avt$internal_type_specification;
     VAR template_file_record: ^avt$template_file_record;
     VAR status: ost$status);

    VAR
      internal_type_spec_size: integer,
      internal_unknown_type: ^avt$internal_type_specification,
      kind: ^avt$field_kind,
      starting_position: integer;

?? NEWTITLE := '      convert_accumulating_limit', EJECT ??

    PROCEDURE convert_accumulating_limit
      (    limit_name: ^ost$name;
           job_limits_apply: ^boolean;
           minimum_job_limit_value: ^avt$limit_value;
           maximum_job_limit_value: ^avt$limit_value;
           limit_update_statistics: ^sft$limit_update_statistics;
           total_limit_applies: ^boolean;
           total_limit_stops_login: ^boolean;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);


      VAR
        apply_total_limit: ^boolean,
        apply_job_limits: ^boolean,
        limit_display_format: ^avt$numeric_display_format,
        limit_stops_login: ^boolean,
        limit_value: ^avt$limit_value,
        name: ^ost$name,
        update_statistics: ^sft$limit_update_statistics,
        update_statistics_count: ^integer;

      status.normal := TRUE;

      NEXT name IN template_file_record;
      IF name = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      name^ := limit_name^;

      NEXT apply_job_limits IN template_file_record;
      IF apply_job_limits = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      IF job_limits_apply = NIL THEN
        apply_job_limits^ := avc$job_limits_apply_default;
      ELSE
        apply_job_limits^ := job_limits_apply^;
      IFEND;

      NEXT limit_value IN template_file_record;
      IF limit_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      limit_value^ := minimum_job_limit_value^;

      NEXT limit_value IN template_file_record;
      IF limit_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      limit_value^ := maximum_job_limit_value^;

      NEXT update_statistics_count IN template_file_record;
      IF update_statistics_count = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      IF limit_update_statistics = NIL THEN
        update_statistics_count^ := 0;
      ELSE
        update_statistics_count^ := UPPERBOUND (limit_update_statistics^);
        NEXT update_statistics: [1 .. update_statistics_count^] IN template_file_record;
        IF update_statistics = NIL THEN
          ;
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        update_statistics^ := limit_update_statistics^;
      IFEND;

      NEXT apply_total_limit IN template_file_record;
      IF apply_total_limit = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      IF total_limit_applies = NIL THEN
        apply_total_limit^ := avc$total_limit_applies_default;
      ELSE
        apply_total_limit^ := total_limit_applies^;
      IFEND;

      NEXT limit_stops_login IN template_file_record;
      IF limit_stops_login = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      IF total_limit_stops_login = NIL THEN
        limit_stops_login^ := avc$limit_stops_login_default;
      ELSE
        limit_stops_login^ := total_limit_stops_login^;
      IFEND;

{ The following code allocates space for a limit display format specification.
{ At the present time, this display format is not used, but it is still set up
{ with an appropriate value.

      NEXT limit_display_format IN template_file_record;
      IF limit_display_format = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      limit_display_format^.field_size := 10;
      limit_display_format^.kind := avc$integer_format;
      limit_display_format^.radix := 10;
      limit_display_format^.display_radix := FALSE;

    PROCEND convert_accumulating_limit;
?? TITLE := '      convert_date_time', EJECT ??

    PROCEDURE convert_date_time
      (    date_time_range: ^boolean;
           date_applies: ^boolean;
           date_display_format: ^clt$date_time_form_string;
           time_applies: ^boolean;
           time_display_format: ^clt$date_time_form_string;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        boolean_pointer: ^boolean,
        display_format: ^clt$date_time_form_string,
        display_format_size: ^0 .. clc$max_date_time_form_string;

      status.normal := TRUE;

      NEXT boolean_pointer IN template_file_record;
      IF boolean_pointer = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
      IFEND;
      IF date_time_range = NIL THEN
        boolean_pointer^ := avc$date_time_range_default;
      ELSE
        boolean_pointer^ := date_time_range^;
      IFEND;

      NEXT boolean_pointer IN template_file_record;
      IF boolean_pointer = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
      IFEND;
      IF date_applies = NIL THEN
        boolean_pointer^ := avc$date_applies_default;
      ELSE
        boolean_pointer^ := date_applies^;
      IFEND;

      IF boolean_pointer^ THEN
        NEXT display_format_size IN template_file_record;
        IF display_format_size = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        IFEND;

        IF date_display_format = NIL THEN
          display_format_size^ := clp$trimmed_string_size (avc$date_format_default);
        ELSE
          display_format_size^ := #SIZE (date_display_format^);
        IFEND;

        NEXT display_format: [display_format_size^] IN template_file_record;
        IF display_format = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;

        IF date_display_format = NIL THEN
          display_format^ := avc$date_format_default;
        ELSE
          display_format^ := date_display_format^;
        IFEND;
      IFEND;

      NEXT boolean_pointer IN template_file_record;
      IF boolean_pointer = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
      IFEND;
      IF time_applies = NIL THEN
        boolean_pointer^ := avc$time_applies_default;
      ELSE
        boolean_pointer^ := time_applies^;
      IFEND;

      IF boolean_pointer^ THEN
        NEXT display_format_size IN template_file_record;
        IF display_format_size = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        IFEND;

        IF time_display_format = NIL THEN
          display_format_size^ := clp$trimmed_string_size (avc$time_format_default);
        ELSE
          display_format_size^ := #SIZE (time_display_format^);
        IFEND;

        NEXT display_format: [display_format_size^] IN template_file_record;
        IF display_format = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;

        IF time_display_format = NIL THEN
          display_format^ := avc$time_format_default;
        ELSE
          display_format^ := time_display_format^;
        IFEND;
      IFEND;

    PROCEND convert_date_time;
?? TITLE := '      convert_integer', EJECT ??

    PROCEDURE convert_integer
      (    minimum_integer_value: ^integer;
           maximum_integer_value: ^integer;
           integer_display_format: ^avt$numeric_display_format;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        display_format: ^avt$numeric_display_format,
        maximum_value: ^integer,
        minimum_value: ^integer;

      status.normal := TRUE;

      NEXT minimum_value IN template_file_record;
      IF minimum_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      IF minimum_integer_value = NIL THEN
        minimum_value^ := avc$min_integer_value_default;
      ELSE
        minimum_value^ := minimum_integer_value^;
      IFEND;

      NEXT maximum_value IN template_file_record;
      IF maximum_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      IF maximum_integer_value = NIL THEN
        maximum_value^ := avc$max_integer_value_default;
      ELSE
        maximum_value^ := maximum_integer_value^;
      IFEND;

      NEXT display_format IN template_file_record;
      IF display_format = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      IF integer_display_format = NIL THEN
        display_format^.field_size := avc$integer_field_size_default;
        display_format^.kind := avc$integer_format;
        display_format^.radix := avc$radix_default;
        display_format^.display_radix := avc$display_radix_default;
      ELSE
        display_format^ := integer_display_format^;
      IFEND;

    PROCEND convert_integer;
?? TITLE := '      convert_job_class', EJECT ??

    PROCEDURE convert_job_class
      (    common_job_classes: ^avt$name_list;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        job_class_list: ^avt$name_list,
        job_class_list_size: ^avt$name_list_size;

      status.normal := TRUE;

      NEXT job_class_list_size IN template_file_record;
      IF job_class_list_size = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF common_job_classes = NIL THEN
        job_class_list_size^ := 0;
      ELSE
        job_class_list_size^ := UPPERBOUND (common_job_classes^);
        NEXT job_class_list: [1 .. UPPERBOUND (common_job_classes^)] IN template_file_record;
        IF job_class_list = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        job_class_list^ := common_job_classes^;
      IFEND;

    PROCEND convert_job_class;
?? TITLE := '      convert_labeled_names', EJECT ??

    PROCEDURE convert_labeled_names
      (    valid_labels: ^avt$name_list;
           valid_names: ^avt$name_list;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        valid_label_list: ^avt$name_list,
        valid_label_list_size: ^avt$name_list_size,
        valid_name_list_entry: ^avt$name_list,
        valid_name_list_entry_size: ^avt$name_list_size;

      status.normal := TRUE;

      NEXT valid_label_list_size IN template_file_record;
      IF valid_label_list_size = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF valid_labels = NIL THEN
        valid_label_list_size^ := 0;
      ELSE
        NEXT valid_label_list: [1 .. UPPERBOUND (valid_labels^)] IN template_file_record;
        IF valid_label_list = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        valid_label_list^ := valid_labels^;
        valid_label_list_size^ := UPPERBOUND (valid_label_list^);
      IFEND;

      NEXT valid_name_list_entry_size IN template_file_record;
      IF valid_name_list_entry_size = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF valid_names = NIL THEN
        valid_name_list_entry_size^ := 0;
      ELSE
        NEXT valid_name_list_entry: [1 .. UPPERBOUND (valid_names^)] IN template_file_record;
        IF valid_name_list_entry = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        valid_name_list_entry^ := valid_names^;
        valid_name_list_entry_size^ := UPPERBOUND (valid_name_list_entry^);
      IFEND;

    PROCEND convert_labeled_names;
?? TITLE := '      convert_limit', EJECT ??

    PROCEDURE convert_limit
      (    minimum_limit_value: ^avt$limit_value;
           maximum_limit_value: ^avt$limit_value;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);


      VAR
        limit_display_format: ^avt$numeric_display_format,
        limit_value: ^avt$limit_value;

      status.normal := TRUE;

      NEXT limit_value IN template_file_record;
      IF limit_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      limit_value^ := minimum_limit_value^;

      NEXT limit_value IN template_file_record;
      IF limit_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      limit_value^ := maximum_limit_value^;

{ The following code allocates space for a limit display format specification.
{ At the present time, this display format is not used, but it is still set up
{ with an appropriate value.

      NEXT limit_display_format IN template_file_record;
      IF limit_display_format = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      limit_display_format^.field_size := 10;
      limit_display_format^.kind := avc$integer_format;
      limit_display_format^.radix := 10;
      limit_display_format^.display_radix := FALSE;

    PROCEND convert_limit;
?? TITLE := '      convert_name', EJECT ??

    PROCEDURE convert_name
      (    minimum_number_of_names: ^avt$name_list_size;
           maximum_number_of_names: ^avt$name_list_size;
           common_names: ^avt$name_list;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        common_name_list: ^avt$name_list,
        common_name_list_size: ^avt$name_list_size,
        maximum_size: ^avt$name_list_size,
        minimum_size: ^avt$name_list_size;

      status.normal := TRUE;

      NEXT common_name_list_size IN template_file_record;
      IF common_name_list_size = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;

      IF common_names = NIL THEN
        common_name_list_size^ := 0;
      ELSE
        NEXT common_name_list: [1 .. UPPERBOUND (common_names^)] IN template_file_record;
        IF common_name_list = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        common_name_list^ := common_names^;
        common_name_list_size^ := UPPERBOUND (common_name_list^);
      IFEND;

      NEXT minimum_size IN template_file_record;
      IF minimum_size = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      IF minimum_number_of_names = NIL THEN
        minimum_size^ := avc$minimum_names_default;
      ELSE
        minimum_size^ := minimum_number_of_names^;
      IFEND;

      NEXT maximum_size IN template_file_record;
      IF maximum_size = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      IF maximum_number_of_names = NIL THEN
        maximum_size^ := avc$maximum_names_default;
      ELSE
        maximum_size^ := maximum_number_of_names^;
      IFEND;

    PROCEND convert_name;
?? TITLE := '      convert_real', EJECT ??

    PROCEDURE convert_real
      (    minimum_real_value: ^real;
           maximum_real_value: ^real;
           real_display_format: ^avt$numeric_display_format;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        display_format: ^avt$numeric_display_format,
        maximum_value: ^real,
        minimum_value: ^real;

      status.normal := TRUE;

      NEXT minimum_value IN template_file_record;
      IF minimum_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      IF minimum_real_value = NIL THEN
        minimum_value^ := avc$minimum_real_value_default;
      ELSE
        minimum_value^ := minimum_real_value^;
      IFEND;

      NEXT maximum_value IN template_file_record;
      IF maximum_value = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      IF maximum_real_value = NIL THEN
        maximum_value^ := avc$maximum_real_value_default;
      ELSE
        maximum_value^ := maximum_real_value^;
      IFEND;

      NEXT display_format IN template_file_record;
      IF display_format = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      IF real_display_format = NIL THEN
        display_format^.field_size := avc$real_field_size_default;
        display_format^.kind := avc$real_format_kind_default;
        display_format^.fraction_size := avc$real_fraction_size_default;
      ELSE
        display_format^ := real_display_format^;
        IF display_format^.kind = avc$fixed_point_format THEN
          IF display_format^.fraction_size > display_format^.field_size - 2 THEN
            display_format^.fraction_size := display_format^.field_size - 2;
          IFEND;
        ELSE
          IF display_format^.field_size < 9 THEN
            display_format^.field_size := 9;
          IFEND;
        IFEND;
      IFEND;

    PROCEND convert_real;
?? TITLE := '      convert_string', EJECT ??

    PROCEDURE convert_string
      (    minimum_string_size: ^ost$string_size;
           maximum_string_size: ^ost$string_size;
       VAR template_file_record: ^avt$template_file_record;
       VAR status: ost$status);

      VAR
        maximum_size: ^ost$string_size,
        minimum_size: ^ost$string_size;

      status.normal := TRUE;

      NEXT minimum_size IN template_file_record;
      IF minimum_size = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      IF minimum_string_size = NIL THEN
        minimum_size^ := avc$minimum_string_size_default;
      ELSE
        minimum_size^ := minimum_string_size^;
      IFEND;

      NEXT maximum_size IN template_file_record;
      IF maximum_size = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      IF maximum_string_size = NIL THEN
        maximum_size^ := avc$maximum_string_size_default;
      ELSE
        maximum_size^ := maximum_string_size^;
      IFEND;

    PROCEND convert_string;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    starting_position := i#current_sequence_position (template_file_record);

    NEXT kind IN template_file_record;
    IF kind = NIL THEN
      osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
      RETURN;
    IFEND;
    kind^ := type_specification.kind;

    CASE type_specification.kind OF
    = avc$account_project_kind =
      ;
    = avc$accumulating_limit_kind =
      convert_accumulating_limit (type_specification.limit_name, type_specification.job_limits_apply,
            type_specification.minimum_job_limit_value, type_specification.maximum_job_limit_value,
            type_specification.limit_update_statistics, type_specification.total_limit_applies,
            type_specification.total_limit_stops_login, template_file_record, status);
    = avc$capability_kind =
      ;
    = avc$date_time_kind =
      convert_date_time (type_specification.date_time_range, type_specification.date_applies,
            type_specification.date_display_format, type_specification.time_applies,
            type_specification.time_display_format, template_file_record, status);
    = avc$file_kind =
      ;
    = avc$integer_kind =
      convert_integer (type_specification.minimum_integer_value, type_specification.maximum_integer_value,
            type_specification.integer_display_format, template_file_record, status);
    = avc$job_class_kind =
      convert_job_class (type_specification.common_job_classes, template_file_record, status);
    = avc$keyword_kind =
      osp$set_status_abnormal ('AV', ave$kind_not_implemented, 'KEYWORD', status);
    = avc$labeled_names_kind =
      convert_labeled_names (type_specification.valid_labels, type_specification.valid_names,
            template_file_record, status);
    = avc$limit_kind =
      convert_limit (type_specification.minimum_limit_value, type_specification.maximum_limit_value,
            template_file_record, status);
    = avc$login_password_kind =
      ;
    = avc$name_kind =
      convert_name (type_specification.minimum_number_of_names, type_specification.maximum_number_of_names,
            type_specification.common_names, template_file_record, status);
    = avc$real_kind =
      convert_real (type_specification.minimum_real_value, type_specification.maximum_real_value,
            type_specification.real_display_format, template_file_record, status);
    = avc$restriction_kind =
      ;
    = avc$ring_privilege_kind =
      ;
    = avc$string_kind =
      convert_string (type_specification.minimum_string_size, type_specification.maximum_string_size,
            template_file_record, status);
    = avc$first_unused_kind .. avc$last_unused_kind =
      RESET template_file_record TO kind;
      NEXT internal_unknown_type: [[REP #size(type_specification.unknown_type^) OF cell]] IN
            template_file_record;
      IF internal_unknown_type = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      internal_unknown_type^ := type_specification.unknown_type^;
    ELSE
      osp$set_status_abnormal ('AV', ave$unknown_field_kind, '', status);
    CASEND;
    IF NOT status.normal THEN
      osp$append_status_parameter (osc$status_parameter_delimiter, 'CONVERT_EXT_TYPE_SPEC_TO_INT', status);
      RETURN;
    IFEND;

    internal_type_spec_size := i#current_sequence_position (template_file_record) - starting_position;

    RESET template_file_record TO kind;
    NEXT internal_type_specification: [[REP internal_type_spec_size OF cell]] IN template_file_record;
    IF internal_type_specification = NIL THEN
      corrupted_sequence ('CONVERT_EXT_TYPE_SPEC_TO_INT', 'INTERNAL_TYPE_SPECIFICATION',
            'TEMPLATE_FILE_RECORD', status);
    IFEND;

  PROCEND convert_ext_type_spec_to_int;
?? TITLE := '    convert_int_field_value_to_ext', EJECT ??

{ PURPOSE:
{   This procedure is used convert an internal field value to its external
{   format.

  PROCEDURE convert_int_field_value_to_ext
    (    default_value: ^avt$field_value;
     VAR work_area: ^seq (*);
     VAR internal_field_value: ^avt$internal_field_value;
     VAR field_value: avt$field_value;
     VAR status: ost$status);

    VAR
      kind: ^avt$field_kind;

?? NEWTITLE := '      convert_account_project', EJECT ??

    PROCEDURE convert_account_project
      (    default_value: ^avt$field_value;
       VAR internal_field_value: ^avt$internal_field_value;
       VAR field_value: avt$field_value;
       VAR status: ost$status);

      status.normal := TRUE;

      NEXT field_value.account_name IN internal_field_value;
      IF field_value.account_name = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.ACCOUNT_NAME',
              'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

      NEXT field_value.project_name IN internal_field_value;
      IF field_value.project_name = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.PROJECT_NAME',
              'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

    PROCEND convert_account_project;
?? TITLE := '      convert_accumulating_limit', EJECT ??

    PROCEDURE convert_accumulating_limit
      (    default_value: ^avt$field_value;
       VAR internal_field_value: ^avt$internal_field_value;
       VAR field_value: avt$field_value;
       VAR status: ost$status);

      VAR
        use_default_value: ^boolean;

      status.normal := TRUE;

      NEXT use_default_value IN internal_field_value;
      IF use_default_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'USE_DEFAULT_VALUE (job resource limit)',
              'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

      IF use_default_value^ THEN
        field_value.job_warning_limit := default_value^.job_warning_limit;
      ELSE
        NEXT field_value.job_warning_limit IN internal_field_value;
        IF field_value.job_warning_limit = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.JOB_RESOURCE_LIMIT',
                'INTERNAL_FIELD_VALUE', status);
          RETURN;
        IFEND;
      IFEND;

      NEXT use_default_value IN internal_field_value;
      IF use_default_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'USE_DEFAULT_VALUE (job abort limit)',
              'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

      IF use_default_value^ THEN
        field_value.job_maximum_limit := default_value^.job_maximum_limit;
      ELSE
        NEXT field_value.job_maximum_limit IN internal_field_value;
        IF field_value.job_maximum_limit = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.JOB_ABORT_LIMIT',
                'INTERNAL_FIELD_VALUE', status);
          RETURN;
        IFEND;
      IFEND;

      NEXT use_default_value IN internal_field_value;
      IF use_default_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'USE_DEFAULT_VALUE (total access limit)',
              'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

      IF use_default_value^ THEN
        field_value.total_limit := default_value^.total_limit;
      ELSE
        NEXT field_value.total_limit IN internal_field_value;
        IF field_value.total_limit = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.TOTAL_LIMIT',
                'INTERNAL_FIELD_VALUE', status);
          RETURN;
        IFEND;
      IFEND;

      NEXT field_value.total_accumulation IN internal_field_value;
      IF field_value.total_accumulation = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.TOTAL_ACCUMULATION',
              'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

    PROCEND convert_accumulating_limit;
?? TITLE := '      convert_capability', EJECT ??

    PROCEDURE convert_capability
      (    default_value: ^avt$field_value;
       VAR internal_field_value: ^avt$internal_field_value;
       VAR field_value: avt$field_value;
       VAR status: ost$status);

      status.normal := TRUE;

      NEXT field_value.capability IN internal_field_value;
      IF field_value.capability = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.CAPABILITY',
              'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

    PROCEND convert_capability;
?? TITLE := '      convert_date_time', EJECT ??

    PROCEDURE convert_date_time
      (    default_value: ^avt$field_value;
       VAR internal_field_value: ^avt$internal_field_value;
       VAR field_value: avt$field_value;
       VAR status: ost$status);

      status.normal := TRUE;

      NEXT field_value.date_time IN internal_field_value;
      IF field_value.date_time = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.DATE_TIME', 'INTERNAL_FIELD_VALUE',
              status);
        RETURN;
      IFEND;

    PROCEND convert_date_time;
?? TITLE := '      convert_file', EJECT ??

    PROCEDURE convert_file
      (    default_value: ^avt$field_value;
       VAR internal_field_value: ^avt$internal_field_value;
       VAR field_value: avt$field_value;
       VAR status: ost$status);

      VAR
        file_reference_size: ^fst$path_size;

      status.normal := TRUE;

      NEXT file_reference_size IN internal_field_value;
      IF file_reference_size = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FILE_REFERNECE_SIZE', 'INTERNAL_FIELD_VALUE',
              status);
        RETURN;
      IFEND;

      IF file_reference_size^ = 0 THEN
        field_value.file := NIL;
      ELSE
        NEXT field_value.file: [file_reference_size^] IN internal_field_value;
        IF field_value.file = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.FILE', 'INTERNAL_FIELD_VALUE',
                status);
          RETURN;
        IFEND;
      IFEND;

    PROCEND convert_file;
?? TITLE := '      convert_integer', EJECT ??

    PROCEDURE convert_integer
      (    default_value: ^avt$field_value;
       VAR internal_field_value: ^avt$internal_field_value;
       VAR field_value: avt$field_value;
       VAR status: ost$status);

      status.normal := TRUE;

      NEXT field_value.integer_value IN internal_field_value;
      IF field_value.integer_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.INTEGER', 'INTERNAL_FIELD_VALUE',
              status);
        RETURN;
      IFEND;

    PROCEND convert_integer;
?? TITLE := '      convert_job_class', EJECT ??

    PROCEDURE convert_job_class
      (    default_value: ^avt$field_value;
       VAR internal_field_value: ^avt$internal_field_value;
       VAR field_value: avt$field_value;
       VAR status: ost$status);

      VAR
        job_class_list_size: ^avt$name_list_size,
        use_default_value: ^boolean;

      status.normal := TRUE;

      NEXT use_default_value IN internal_field_value;
      IF use_default_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'USE_DEFAULT_VALUE (job classes)',
              'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

      IF use_default_value^ THEN
        field_value.job_classes := default_value^.job_classes;
      ELSE
        NEXT job_class_list_size IN internal_field_value;
        IF job_class_list_size = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'JOB_CLASS_LIST_SIZE', 'INTERNAL_FIELD_VALUE',
                status);
          RETURN;
        IFEND;

        IF job_class_list_size^ = 0 THEN
          field_value.job_classes := NIL;
        ELSE
          NEXT field_value.job_classes: [1 .. job_class_list_size^] IN internal_field_value;
          IF field_value.job_classes = NIL THEN
            corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.JOB_CLASSES',
                  'INTERNAL_FIELD_VALUE', status);
            RETURN;
          IFEND;
        IFEND;
      IFEND;

      NEXT use_default_value IN internal_field_value;
      IF use_default_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'USE_DEFAULT_VALUE (batch job class default)',
              'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

      IF use_default_value^ THEN
        field_value.batch_job_class_default := default_value^.batch_job_class_default;
      ELSE
        NEXT field_value.batch_job_class_default IN internal_field_value;
        IF field_value.batch_job_class_default = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.BATCH_JOB_CLASS_DEFAULT',
                'INTERNAL_FIELD_VALUE', status);
          RETURN;
        IFEND;
      IFEND;

      NEXT use_default_value IN internal_field_value;
      IF use_default_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT',
              'USE_DEFAULT_VALUE (interactive job class default)', 'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

      IF use_default_value^ THEN
        field_value.interactive_job_class_default := default_value^.interactive_job_class_default;
      ELSE
        NEXT field_value.interactive_job_class_default IN internal_field_value;
        IF field_value.interactive_job_class_default = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.INTERACTIVE_JOB_CLASS_DEFAULT',
                'INTERNAL_FIELD_VALUE', status);
          RETURN;
        IFEND;
      IFEND;

    PROCEND convert_job_class;
?? TITLE := '      convert_labeled_names', EJECT ??

    PROCEDURE convert_labeled_names
      (    default_value: ^avt$field_value;
       VAR work_area: ^seq (*);
       VAR internal_field_value: ^avt$internal_field_value;
       VAR field_value: avt$field_value;
       VAR status: ost$status);

      VAR
        index: avt$name_list_size,
        label: ^ost$name,
        name_list_size: ^avt$name_list_size,
        number_of_labels: ^avt$name_list_size,
        names: ^avt$name_list;

      status.normal := TRUE;

      NEXT number_of_labels IN internal_field_value;
      IF number_of_labels = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'NUMBER_OF_LABELS', 'INTERNAL_FIELD_VALUE',
              status);
        RETURN;
      IFEND;

      IF number_of_labels^ = 0 THEN
        field_value.labeled_names := NIL;
      ELSE
        NEXT field_value.labeled_names: [1 .. number_of_labels^] IN work_area;
        IF field_value.labeled_names = NIL THEN
          osp$set_status_abnormal ('AV', ave$work_area_full, 'CONVERT_LABELED_NAMES', status);
          RETURN;
        IFEND;

        FOR index := 1 TO number_of_labels^ DO
          NEXT field_value.labeled_names^ [index].label IN internal_field_value;
          IF field_value.labeled_names^ [index].label = NIL THEN
            corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'LABELED_NAMES.LABEL',
                 'INTERNAL_FIELD_VALUE', status);
            RETURN;
          IFEND;

          NEXT name_list_size IN internal_field_value;
          IF name_list_size = NIL THEN
            corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'NAME_LIST_SIZE',
                  'INTERNAL_FIELD_VALUE', status);
            RETURN;
          IFEND;
          NEXT field_value.labeled_names^ [index].names: [1 .. name_list_size^] IN internal_field_value;
          IF field_value.labeled_names^ [index].names = NIL THEN
            corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'LABELED_NAMES.NAMES',
                  'INTERNAL_FIELD_VALUE', status);
            RETURN;
          IFEND;
        FOREND;
      IFEND;

    PROCEND convert_labeled_names;
?? TITLE := '      convert_limit', EJECT ??

    PROCEDURE convert_limit
      (    default_value: ^avt$field_value;
       VAR internal_field_value: ^avt$internal_field_value;
       VAR field_value: avt$field_value;
       VAR status: ost$status);

      status.normal := TRUE;

      NEXT field_value.limit_value IN internal_field_value;
      IF field_value.limit_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.LIMIT_VALUE',
              'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

    PROCEND convert_limit;
?? TITLE := '      convert_login_password', EJECT ??

    PROCEDURE convert_login_password
      (    default_value: ^avt$field_value;
       VAR internal_field_value: ^avt$internal_field_value;
       VAR field_value: avt$field_value;
       VAR status: ost$status);

      VAR
        password_attributes_size: ^avt$name_list_size,
        use_default_value: ^boolean;

      NEXT use_default_value IN internal_field_value;
      IF use_default_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'USE_DEFAULT_VALUE (login password)',
              'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

      IF use_default_value^ THEN
        field_value.login_password := default_value^.login_password;
      ELSE
        NEXT field_value.login_password IN internal_field_value;
        IF field_value.login_password = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.LOGIN_PASSWORD',
                'INTERNAL_FIELD_VALUE', status);
          RETURN;
        IFEND;
      IFEND;

      NEXT use_default_value IN internal_field_value;
      IF use_default_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT',
              'USE_DEFAULT_VALUE (login password expiration date)', 'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

      IF use_default_value^ THEN
        field_value.login_password_exp_date := default_value^.login_password_exp_date;
      ELSE
        NEXT field_value.login_password_exp_date IN internal_field_value;
        IF field_value.login_password_exp_date = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.LOGIN_PASSWORD_EXP_DATE',
                'INTERNAL_FIELD_VALUE', status);
          RETURN;
        IFEND;
      IFEND;

      NEXT use_default_value IN internal_field_value;
      IF use_default_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT',
              'USE_DEFAULT_VALUE (login password expiration interval)', 'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

      IF use_default_value^ THEN
        field_value.login_password_exp_interval := default_value^.login_password_exp_interval;
      ELSE
        NEXT field_value.login_password_exp_interval IN internal_field_value;
        IF field_value.login_password_exp_interval = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.LOGIN_PASSWORD_EXP_INTERVAL',
                'INTERNAL_FIELD_VALUE', status);
          RETURN;
        IFEND;
      IFEND;

      NEXT use_default_value IN internal_field_value;
      IF use_default_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT',
              'USE_DEFAULT_VALUE (login password maximum expiration interval)', 'INTERNAL_FIELD_VALUE',
              status);
        RETURN;
      IFEND;

      IF use_default_value^ THEN
        field_value.login_password_max_exp_interval := default_value^.login_password_max_exp_interval;
      ELSE
        NEXT field_value.login_password_max_exp_interval IN internal_field_value;
        IF field_value.login_password_max_exp_interval = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.LOGIN_PASSWORD_MAX_EXP_INTERVAL',
                'INTERNAL_FIELD_VALUE', status);
          RETURN;
        IFEND;
      IFEND;

      NEXT use_default_value IN internal_field_value;
      IF use_default_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT',
              'USE_DEFAULT_VALUE (login password expiration warning interval)', 'INTERNAL_FIELD_VALUE',
              status);
        RETURN;
      IFEND;

      IF use_default_value^ THEN
        field_value.login_password_exp_warning := default_value^.login_password_exp_warning;
      ELSE
        NEXT field_value.login_password_exp_warning IN internal_field_value;
        IF field_value.login_password_exp_warning = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.LOGIN_PASSWORD_EXP_WARNING',
                'INTERNAL_FIELD_VALUE', status);
          RETURN;
        IFEND;
      IFEND;

      NEXT use_default_value IN internal_field_value;
      IF use_default_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT',
              'USE_DEFAULT_VALUE (expired password change interval)', 'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

      IF use_default_value^ THEN
        field_value.login_password_exp_chg_interval := default_value^.login_password_exp_chg_interval;
      ELSE
        NEXT field_value.login_password_exp_chg_interval IN internal_field_value;
        IF field_value.login_password_exp_chg_interval = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.LOGIN_PASSWORD_EXP_CHG_INTERVAL',
                'INTERNAL_FIELD_VALUE', status);
          RETURN;
        IFEND;
      IFEND;

      NEXT use_default_value IN internal_field_value;
      IF use_default_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'USE_DEFAULT_VALUE (login password attributes)',
              'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

      IF use_default_value^ THEN
        field_value.login_password_attributes := default_value^.login_password_attributes;
      ELSE
        NEXT password_attributes_size IN internal_field_value;
        IF password_attributes_size = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'PASSWORD_ATTRIBUTES_SIZE',
                'INTERNAL_FIELD_VALUE', status);
          RETURN;
        IFEND;

        IF password_attributes_size^ = 0 THEN
          field_value.login_password_attributes := NIL;
        ELSE
          NEXT field_value.login_password_attributes: [1 .. password_attributes_size^] IN
                internal_field_value;
          IF field_value.login_password_attributes = NIL THEN
            corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.LOGIN_PASSWORD_ATTRIBUTES',
                  'INTERNAL_FIELD_VALUE', status);
            RETURN;
          IFEND;
        IFEND;
      IFEND;

{ Attempt to get the last change date.  This field may not exist in the internal field value.

      NEXT field_value.login_password_change_date IN internal_field_value;

    PROCEND convert_login_password;
?? TITLE := '      convert_name', EJECT ??

    PROCEDURE convert_name
      (    default_value: ^avt$field_value;
       VAR internal_field_value: ^avt$internal_field_value;
       VAR field_value: avt$field_value;
       VAR status: ost$status);

      VAR
        name_list_size: ^avt$name_list_size;

      status.normal := TRUE;

      NEXT name_list_size IN internal_field_value;
      IF name_list_size = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'NAME_LIST_SIZE', 'INTERNAL_FIELD_VALUE',
              status);
        RETURN;
      IFEND;

      IF name_list_size^ = 0 THEN
        field_value.names := NIL;
      ELSE
        NEXT field_value.names: [1 .. name_list_size^] IN internal_field_value;
        IF field_value.names = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.NAMES', 'INTERNAL_FIELD_VALUE',
                status);
          RETURN;
        IFEND;
      IFEND;

    PROCEND convert_name;
?? TITLE := '      convert_real', EJECT ??

    PROCEDURE convert_real
      (    default_value: ^avt$field_value;
       VAR internal_field_value: ^avt$internal_field_value;
       VAR field_value: avt$field_value;
       VAR status: ost$status);

      status.normal := TRUE;

      NEXT field_value.real_value IN internal_field_value;
      IF field_value.real_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.REAL_VALUE',
              'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

    PROCEND convert_real;
?? TITLE := '      convert_restriction', EJECT ??

    PROCEDURE convert_restriction
      (    default_value: ^avt$field_value;
       VAR internal_field_value: ^avt$internal_field_value;
       VAR field_value: avt$field_value;
       VAR status: ost$status);

      status.normal := TRUE;

      NEXT field_value.restriction IN internal_field_value;
      IF field_value.restriction = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.RESTRICTION',
              'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

    PROCEND convert_restriction;
?? TITLE := '      convert_ring_privilege', EJECT ??

    PROCEDURE convert_ring_privilege
      (    default_value: ^avt$field_value;
       VAR internal_field_value: ^avt$internal_field_value;
       VAR field_value: avt$field_value;
       VAR status: ost$status);

      VAR
        use_default_value: ^boolean;

      status.normal := TRUE;

      NEXT use_default_value IN internal_field_value;
      IF use_default_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'USE_DEFAULT_VALUE (minimum_ring)',
              'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

      IF use_default_value^ THEN
        field_value.minimum_ring := default_value^.minimum_ring;
      ELSE
        NEXT field_value.minimum_ring IN internal_field_value;
        IF field_value.minimum_ring = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.MINIMUM_RING',
                'INTERNAL_FIELD_VALUE', status);
          RETURN;
        IFEND;
      IFEND;

      NEXT use_default_value IN internal_field_value;
      IF use_default_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'USE_DEFAULT_VALUE (nominal_ring)',
              'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

      IF use_default_value^ THEN
        field_value.nominal_ring := default_value^.nominal_ring;
      ELSE
        NEXT field_value.nominal_ring IN internal_field_value;
        IF field_value.nominal_ring = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.NOMINAL_RING',
                'INTERNAL_FIELD_VALUE', status);
          RETURN;
        IFEND;
      IFEND;

    PROCEND convert_ring_privilege;
?? TITLE := '      convert_string', EJECT ??

    PROCEDURE convert_string
      (    default_value: ^avt$field_value;
       VAR internal_field_value: ^avt$internal_field_value;
       VAR field_value: avt$field_value;
       VAR status: ost$status);

      VAR
        string_size: ^ost$string_size;

      status.normal := TRUE;

      NEXT string_size IN internal_field_value;
      IF string_size = NIL THEN
        corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'STRING_SIZE', 'INTERNAL_FIELD_VALUE', status);
        RETURN;
      IFEND;

      IF string_size^ = 0 THEN
        field_value.string_value := NIL;
      ELSE
        NEXT field_value.string_value: [string_size^] IN internal_field_value;
        IF field_value.string_value = NIL THEN
          corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'FIELD_VALUE.STRING_VALUE',
                'INTERNAL_FIELD_VALUE', status);
          RETURN;
        IFEND;
      IFEND;

    PROCEND convert_string;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    RESET internal_field_value;

    NEXT kind IN internal_field_value;
    IF kind = NIL THEN
      corrupted_sequence ('CONVERT_INT_FIELD_VALUE_TO_EXT', 'KIND', 'INTERNAL_FIELD_VALUE', status);
      RETURN;
    IFEND;

    field_value.kind := kind^;

    CASE field_value.kind OF
    = avc$account_project_kind =
      convert_account_project (default_value, internal_field_value, field_value, status);
    = avc$accumulating_limit_kind =
      convert_accumulating_limit (default_value, internal_field_value, field_value, status);
    = avc$capability_kind =
      convert_capability (default_value, internal_field_value, field_value, status);
    = avc$date_time_kind =
      convert_date_time (default_value, internal_field_value, field_value, status);
    = avc$file_kind =
      convert_file (default_value, internal_field_value, field_value, status);
    = avc$integer_kind =
      convert_integer (default_value, internal_field_value, field_value, status);
    = avc$job_class_kind =
      convert_job_class (default_value, internal_field_value, field_value, status);
    = avc$keyword_kind =
      osp$set_status_abnormal ('AV', ave$kind_not_implemented, 'KEYWORD', status);
    = avc$labeled_names_kind =
      convert_labeled_names (default_value, work_area, internal_field_value, field_value, status);
    = avc$limit_kind =
      convert_limit (default_value, internal_field_value, field_value, status);
    = avc$login_password_kind =
      convert_login_password (default_value, internal_field_value, field_value, status);
    = avc$name_kind =
      convert_name (default_value, internal_field_value, field_value, status);
    = avc$real_kind =
      convert_real (default_value, internal_field_value, field_value, status);
    = avc$restriction_kind =
      convert_restriction (default_value, internal_field_value, field_value, status);
    = avc$ring_privilege_kind =
      convert_ring_privilege (default_value, internal_field_value, field_value, status);
    = avc$string_kind =
      convert_string (default_value, internal_field_value, field_value, status);
    = avc$first_unused_kind .. avc$last_unused_kind =
      field_value.unknown_value := internal_field_value;
    ELSE
      osp$set_status_abnormal ('AV', ave$unknown_field_kind, '', status);
    CASEND;

  PROCEND convert_int_field_value_to_ext;
?? TITLE := '    convert_int_type_spec_to_ext', EJECT ??

{ PURPOSE:
{   This procedure converts a type specification from its internal format to
{   its external format.

  PROCEDURE convert_int_type_spec_to_ext
    (VAR internal_type_specification: ^avt$internal_type_specification;
     VAR type_specification: avt$type_specification;
     VAR status: ost$status);

    VAR
      kind: ^avt$field_kind;

?? NEWTITLE := '      convert_accumulating_limit', EJECT ??

    PROCEDURE convert_accumulating_limit
      (VAR limit_name: ^ost$name;
       VAR job_limits_apply: ^boolean;
       VAR minimum_job_limit_value: ^avt$limit_value;
       VAR maximum_job_limit_value: ^avt$limit_value;
       VAR limit_update_statistics: ^sft$limit_update_statistics;
       VAR total_limit_applies: ^boolean;
       VAR total_limit_stops_login: ^boolean;
       VAR internal_type_specification: ^avt$internal_type_specification;
       VAR status: ost$status);

      VAR
        update_statistics_count: ^integer;

      status.normal := TRUE;

      NEXT limit_name IN internal_type_specification;
      IF limit_name = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'LIMIT_NAME', 'INTERNAL_TYPE_SPECIFICATION',
              status);
        RETURN;
      IFEND;

      NEXT job_limits_apply IN internal_type_specification;
      IF job_limits_apply = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'JOB_LIMITS_APPLY', 'INTERNAL_TYPE_SPECIFICATION',
              status);
        RETURN;
      IFEND;

      NEXT minimum_job_limit_value IN internal_type_specification;
      IF minimum_job_limit_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'MINIMUM_JOB_LIMIT_VALUE',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;

      NEXT maximum_job_limit_value IN internal_type_specification;
      IF maximum_job_limit_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'MAXIMUM_JOB_LIMIT_VALUE',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;

      NEXT update_statistics_count IN internal_type_specification;
      IF update_statistics_count = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'UPDATE_STATISTICS_COUNT',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;
      IF update_statistics_count^ = 0 THEN
        limit_update_statistics := NIL;
      ELSE
        NEXT limit_update_statistics: [1 .. update_statistics_count^] IN internal_type_specification;
        IF limit_update_statistics = NIL THEN
          ;
          corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'LIMIT_UPDATE_STATISTICS',
                'INTERNAL_TYPE_SPECIFICATION', status);
          RETURN;
        IFEND;
      IFEND;

      NEXT total_limit_applies IN internal_type_specification;
      IF total_limit_applies = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'TOTAL_LIMIT_APPLIES',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;

      NEXT total_limit_stops_login IN internal_type_specification;
      IF total_limit_stops_login = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'TOTAL_LIMIT_STOPS_LOGIN',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;

    PROCEND convert_accumulating_limit;
?? TITLE := '      convert_date_time', EJECT ??

    PROCEDURE convert_date_time
      (VAR date_time_range: ^boolean;
       VAR date_applies: ^boolean;
       VAR date_display_format: ^clt$date_time_form_string;
       VAR time_applies: ^boolean;
       VAR time_display_format: ^clt$date_time_form_string;
       VAR internal_type_specification: ^avt$internal_type_specification;
       VAR status: ost$status);

      VAR
        display_format_size: ^0 .. clc$max_date_time_form_string;

      status.normal := TRUE;

      NEXT date_time_range IN internal_type_specification;
      IF date_time_range = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'DATE_TIME_RANGE', 'INTERNAL_TYPE_SPECIFICATION',
              status);
        RETURN;
      IFEND;

      NEXT date_applies IN internal_type_specification;
      IF date_applies = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'DATE_APPLIES', 'INTERNAL_TYPE_SPECIFICATION',
              status);
        RETURN;
      IFEND;

      IF date_applies^ THEN
        NEXT display_format_size IN internal_type_specification;
        IF display_format_size = NIL THEN
          corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'DISPLAY_FORMAT_SIZE (date display format)',
                'INTERNAL_TYPE_SPECIFICATION', status);
          RETURN;
        IFEND;

        IF display_format_size^ <> 0 THEN
          NEXT date_display_format: [display_format_size^] IN internal_type_specification;
          IF date_display_format = NIL THEN
            corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'DATE_DISPLAY_FORMAT',
                  'INTERNAL_TYPE_SPECIFICATION', status);
            RETURN;
          IFEND;
        IFEND;
      ELSE
        date_display_format := NIL;
      IFEND;

      NEXT time_applies IN internal_type_specification;
      IF time_applies = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'TIME_APPLIES', 'INTERNAL_TYPE_SPECIFICATION',
              status);
        RETURN;
      IFEND;

      IF time_applies^ THEN
        NEXT display_format_size IN internal_type_specification;
        IF display_format_size = NIL THEN
          corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'DISPLAY_FORMAT_SIZE',
                'INTERNAL_TYPE_SPECIFICATION', status);
          RETURN;
        IFEND;

        IF display_format_size^ <> 0 THEN
          NEXT time_display_format: [display_format_size^] IN internal_type_specification;
          IF time_display_format = NIL THEN
            corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'TIME_DISPLAY_FORMAT',
                  'INTERNAL_TYPE_SPECIFICATION', status);
            RETURN;
          IFEND;
        IFEND;
      ELSE
        time_display_format := NIL;
      IFEND;

    PROCEND convert_date_time;
?? TITLE := '      convert_integer', EJECT ??

    PROCEDURE convert_integer
      (VAR minimum_integer_value: ^integer;
       VAR maximum_integer_value: ^integer;
       VAR integer_display_format: ^avt$numeric_display_format;
       VAR internal_type_specification: ^avt$internal_type_specification;
       VAR status: ost$status);

      status.normal := TRUE;

      NEXT minimum_integer_value IN internal_type_specification;
      IF minimum_integer_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'MINIMUM_INTEGER_VALUE',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;

      NEXT maximum_integer_value IN internal_type_specification;
      IF maximum_integer_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'MAXIMUM_INTEGER_VALUE',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;

      NEXT integer_display_format IN internal_type_specification;
      IF integer_display_format = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'INTEGER_DISPLAY_FORMAT',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;

    PROCEND convert_integer;
?? TITLE := '      convert_job_class', EJECT ??

    PROCEDURE convert_job_class
      (VAR common_job_classes: ^avt$name_list;
       VAR internal_type_specification: ^avt$internal_type_specification;
       VAR status: ost$status);

      VAR
        job_class_list_size: ^avt$name_list_size;

      status.normal := TRUE;

      NEXT job_class_list_size IN internal_type_specification;
      IF job_class_list_size = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'JOB_CLASS_LIST_SIZE',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;

      IF job_class_list_size^ <> 0 THEN
        NEXT common_job_classes: [1 .. job_class_list_size^] IN internal_type_specification;
        IF common_job_classes = NIL THEN
          corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'COMMON_JOB_CLASSES',
                'INTERNAL_TYPE_SPECIFICATION', status);
          RETURN;
        IFEND;
      ELSE
        common_job_classes := NIL;
      IFEND;

    PROCEND convert_job_class;
?? TITLE := '      convert_labeled_names', EJECT ??

    PROCEDURE convert_labeled_names
      (VAR valid_labels: ^avt$name_list;
       VAR valid_names: ^avt$name_list;
       VAR internal_type_specification: ^avt$internal_type_specification;
       VAR status: ost$status);

      VAR
        label_list_size: ^avt$name_list_size,
        name_list_size: ^avt$name_list_size;

      status.normal := TRUE;

      NEXT label_list_size IN internal_type_specification;
      IF label_list_size = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'LABEL_LIST_SIZE', 'INTERNAL_TYPE_SPECIFICATION',
              status);
        RETURN;
      IFEND;

      IF label_list_size^ <> 0 THEN
        NEXT valid_labels: [1 .. label_list_size^] IN internal_type_specification;
        IF valid_labels = NIL THEN
          corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'VALID_LABELS', 'INTERNAL_TYPE_SPECIFICATION',
                status);
          RETURN;
        IFEND;
      ELSE
        valid_labels := NIL;
      IFEND;

      NEXT name_list_size IN internal_type_specification;
      IF name_list_size = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'NAME_LIST_SIZE', 'INTERNAL_TYPE_SPECIFICATION',
              status);
        RETURN;
      IFEND;

      IF name_list_size^ <> 0 THEN
        NEXT valid_names: [1 .. name_list_size^] IN internal_type_specification;
        IF valid_names = NIL THEN
          corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'NAME_LIST', 'INTERNAL_TYPE_SPECIFICATION',
                status);
          RETURN;
        IFEND;
      ELSE
        valid_names := NIL;
      IFEND;

    PROCEND convert_labeled_names;
?? TITLE := '      convert_limit', EJECT ??

    PROCEDURE convert_limit
      (VAR minimum_limit_value: ^avt$limit_value;
       VAR maximum_limit_value: ^avt$limit_value;
       VAR internal_type_specification: ^avt$internal_type_specification;
       VAR status: ost$status);

      status.normal := TRUE;

      NEXT minimum_limit_value IN internal_type_specification;
      IF minimum_limit_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'MINIMUM_LIMIT_VALUE',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;

      NEXT maximum_limit_value IN internal_type_specification;
      IF maximum_limit_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'MAXIMUM_LIMIT_VALUE',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;

    PROCEND convert_limit;
?? TITLE := '      convert_name', EJECT ??

    PROCEDURE convert_name
      (VAR minimum_number_of_names: ^avt$name_list_size;
       VAR maximum_number_of_names: ^avt$name_list_size;
       VAR common_names: ^avt$name_list;
       VAR internal_type_specification: ^avt$internal_type_specification;
       VAR status: ost$status);

      VAR
        name_list_size: ^avt$name_list_size;

      status.normal := TRUE;

      NEXT name_list_size IN internal_type_specification;
      IF name_list_size = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'NAME_LIST_SIZE', 'INTERNAL_TYPE_SPECIFICATION',
              status);
        RETURN;
      IFEND;

      IF name_list_size^ <> 0 THEN
        NEXT common_names: [1 .. name_list_size^] IN internal_type_specification;
        IF common_names = NIL THEN
          corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'COMMON_NAMES', 'INTERNAL_TYPE_SPECIFICATION',
                status);
          RETURN;
        IFEND;
      ELSE
        common_names := NIL;
      IFEND;

      NEXT minimum_number_of_names IN internal_type_specification;
      IF minimum_number_of_names = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'MINIMUM_NUMBER_OF_NAMES',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;

      NEXT maximum_number_of_names IN internal_type_specification;
      IF maximum_number_of_names = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'MAXIMUM_NUMBER_OF_KEYWORDS',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;

    PROCEND convert_name;
?? TITLE := '      convert_real', EJECT ??

    PROCEDURE convert_real
      (VAR minimum_real_value: ^real;
       VAR maximum_real_value: ^real;
       VAR real_display_format: ^avt$numeric_display_format;
       VAR internal_type_specification: ^avt$internal_type_specification;
       VAR status: ost$status);

      status.normal := TRUE;

      NEXT minimum_real_value IN internal_type_specification;
      IF minimum_real_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'MINIMUM_REAL_VALUE',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;

      NEXT maximum_real_value IN internal_type_specification;
      IF maximum_real_value = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'MAXIMUM_REAL_VALUE',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;

      NEXT real_display_format IN internal_type_specification;
      IF real_display_format = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'REAL_DISPLAY_FORMAT',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;

    PROCEND convert_real;
?? TITLE := '      convert_string', EJECT ??

    PROCEDURE convert_string
      (VAR minimum_string_size: ^ost$string_size;
       VAR maximum_string_size: ^ost$string_size;
       VAR internal_type_specification: ^avt$internal_type_specification;
       VAR status: ost$status);

      status.normal := TRUE;

      NEXT minimum_string_size IN internal_type_specification;
      IF minimum_string_size = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'MINIMUM_STRING_SIZE',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;

      NEXT maximum_string_size IN internal_type_specification;
      IF maximum_string_size = NIL THEN
        corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'MAXIMUM_STRING_SIZE',
              'INTERNAL_TYPE_SPECIFICATION', status);
        RETURN;
      IFEND;

    PROCEND convert_string;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    RESET internal_type_specification;

    NEXT kind IN internal_type_specification;
    IF kind = NIL THEN
      corrupted_sequence ('CONVERT_INT_TYPE_SPEC_TO_EXT', 'KIND', 'INTERNAL_TYPE_SPECIFICATION', status);
      RETURN;
    IFEND;
    type_specification.kind := kind^;

    CASE type_specification.kind OF
    = avc$account_project_kind =
      ;
    = avc$accumulating_limit_kind =
      convert_accumulating_limit (type_specification.limit_name, type_specification.job_limits_apply,
            type_specification.minimum_job_limit_value, type_specification.maximum_job_limit_value,
            type_specification.limit_update_statistics, type_specification.total_limit_applies,
            type_specification.total_limit_stops_login, internal_type_specification, status);
    = avc$capability_kind =
      ;
    = avc$date_time_kind =
      convert_date_time (type_specification.date_time_range, type_specification.date_applies,
            type_specification.date_display_format, type_specification.time_applies,
            type_specification.time_display_format, internal_type_specification, status);
    = avc$file_kind =
      ;
    = avc$integer_kind =
      convert_integer (type_specification.minimum_integer_value, type_specification.maximum_integer_value,
            type_specification.integer_display_format, internal_type_specification, status);
    = avc$job_class_kind =
      convert_job_class (type_specification.common_job_classes, internal_type_specification, status);
    = avc$keyword_kind =
      osp$set_status_abnormal ('AV', ave$kind_not_implemented, 'KEYWORD', status);
    = avc$labeled_names_kind =
      convert_labeled_names (type_specification.valid_labels, type_specification.valid_names,
            internal_type_specification, status);
    = avc$limit_kind =
      convert_limit (type_specification.minimum_limit_value, type_specification.maximum_limit_value,
            internal_type_specification, status);
    = avc$login_password_kind =
      ;
    = avc$name_kind =
      convert_name (type_specification.minimum_number_of_names, type_specification.maximum_number_of_names,
            type_specification.common_names, internal_type_specification, status);
    = avc$real_kind =
      convert_real (type_specification.minimum_real_value, type_specification.maximum_real_value,
            type_specification.real_display_format, internal_type_specification, status);
    = avc$restriction_kind =
      ;
    = avc$ring_privilege_kind =
      ;
    = avc$string_kind =
      convert_string (type_specification.minimum_string_size, type_specification.maximum_string_size,
            internal_type_specification, status);
    = avc$first_unused_kind .. avc$last_unused_kind =
      type_specification.unknown_type := internal_type_specification;
    ELSE
      osp$set_status_abnormal ('AV', ave$unknown_field_kind, '', status);
    CASEND;
    IF NOT status.normal THEN
      osp$append_status_parameter (osc$status_parameter_delimiter, 'CONVERT_INT_TYPE_SPEC_TO_EXT', status);
      RETURN;
    IFEND;

  PROCEND convert_int_type_spec_to_ext;
?? TITLE := '    determine_if_labeled_names_matc', EJECT ??

{ PURPOSE:
{   This procedure compares two sorted labeled name lists and determines if they match (i.e., have the same
{   number of entries and the same values.

  PROCEDURE determine_if_labeled_names_matc
    (    labeled_names1: ^avt$labeled_names_list;
         labeled_names2: ^avt$labeled_names_list;
     VAR match: boolean);

    VAR
      index: avt$name_list_size;

    IF (labeled_names1 = NIL) AND (labeled_names2 = NIL) THEN
      match := TRUE;
    ELSEIF ((labeled_names1 <> NIL) AND (labeled_names2 <> NIL)) AND
          (UPPERBOUND (labeled_names1^) = UPPERBOUND (labeled_names2^)) THEN
      FOR index := 1 TO UPPERBOUND (labeled_names1^) DO
        IF labeled_names1^ [index].label^ <> labeled_names2^ [index].label^ THEN
          match := FALSE;
          RETURN;
        ELSE
          determine_if_name_lists_match (labeled_names1^ [index].names, labeled_names2^ [index].names, match);
          IF NOT match THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND;
      match := TRUE;
    ELSE
      match := FALSE;
    IFEND;



  PROCEND determine_if_labeled_names_matc;
?? TITLE := '    determine_if_name_lists_match', EJECT ??

{ PURPOSE:
{   This procedure compares to sorted name lists and determines if they match (i.e., have the same number of
{   entries and the same values.

  PROCEDURE determine_if_name_lists_match
    (    name_list1: ^avt$name_list;
         name_list2: ^avt$name_list;
     VAR match: boolean);

    VAR
      index: avt$name_list_size;

    IF (name_list1 = NIL) AND (name_list2 = NIL) THEN
      match := TRUE;
    ELSEIF ((name_list1 <> NIL) AND (name_list2 <> NIL)) AND
          (UPPERBOUND (name_list1^) = UPPERBOUND (name_list2^)) THEN
      FOR index := 1 TO UPPERBOUND (name_list1^) DO
        IF name_list1^ [index] <> name_list2^ [index] THEN
          match := FALSE;
          RETURN;
        IFEND;
      FOREND;
      match := TRUE;
    ELSE
      match := FALSE;
    IFEND;

  PROCEND determine_if_name_lists_match;
?? TITLE := '    get_description_directory_entry', EJECT ??

{ PURPOSE:
{   This procedure returns a pointer to the description directory entry
{   for the specified description record.

  PROCEDURE get_description_directory_entry
    (    description_record_name: ost$name;
         template_file_header: ^avt$template_file_header;
         template_file_heap: ^avt$template_file_heap;
     VAR description_directory_entry: ^avt$description_directory_entry;
     VAR status: ost$status);

    VAR
      index: 1 .. avc$maximum_desc_record_count;

    status.normal := TRUE;

    get_description_record_index (description_record_name, template_file_header, index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_directory_entry := ^template_file_header^.description_directory [index];

  PROCEND get_description_directory_entry;
?? TITLE := '    get_description_record', EJECT ??

{ PURPOSE:
{   This procedure returns a pointer to the specified description record.

  PROCEDURE get_description_record
    (    description_record_name: ost$name;
         template_file_header: ^avt$template_file_header;
         template_file_heap: ^avt$template_file_heap;
     VAR description_record: ^avt$template_file_record;
     VAR status: ost$status);

    VAR
      index: 1 .. avc$maximum_desc_record_count;

    status.normal := TRUE;

    get_description_record_index (description_record_name, template_file_header, index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_record := #PTR (template_file_header^.description_directory [index].record_pointer,
          template_file_heap^);

    RESET description_record;

  PROCEND get_description_record;
?? TITLE := '    get_description_record_index', EJECT ??

{ PURPOSE:
{   This procedure returns the description directory index for the specified
{   description record.

  PROCEDURE get_description_record_index
    (    description_record_name: ost$name;
         template_file_header: ^avt$template_file_header;
     VAR description_record_index: 1 .. avc$maximum_desc_record_count;
     VAR status: ost$status);

    status.normal := TRUE;

    FOR description_record_index := 1 TO template_file_header^.description_record_count DO
      IF (template_file_header^.description_directory [description_record_index].name =
            description_record_name) THEN
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal ('AV', ave$unknown_description_record, description_record_name, status);

  PROCEND get_description_record_index;
?? TITLE := '    get_field_description', EJECT ??

{ PURPOSE:
{   This procedure returns field description information for the specified
{   field.

  PROCEDURE get_field_description
    (    field_name: ost$name;
         field_directory: ^avt$field_directory;
         description_record: ^avt$template_file_record;
     VAR work_area: ^seq (*);
     VAR system_supplied_field_id: avt$system_supplied_field_id;
     VAR type_specification: avt$type_specification;
     VAR default_value: avt$field_value;
     VAR descriptive_text: ^avt$descriptive_text;
     VAR utility_information: ^avt$utility_information;
     VAR status: ost$status);

    VAR
      deleted_field: boolean,
      field_description: ^avt$field_description,
      field_description_header: ^avt$field_description_header,
      field_directory_entry: ^avt$field_directory_entry,
      internal_default_value: ^avt$internal_field_value,
      internal_type_specification: ^avt$internal_type_specification;

    status.normal := TRUE;

    get_field_directory_entry (field_name, field_directory, field_directory_entry, deleted_field, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    system_supplied_field_id := field_directory_entry^.system_supplied_field_id;

    field_description := #PTR (field_directory_entry^.description, description_record^);

    get_field_description_header (field_description, field_description_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    internal_type_specification := #PTR (field_description_header^.type_specification, field_description^);
    convert_int_type_spec_to_ext (internal_type_specification, type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    internal_default_value := #PTR (field_description_header^.default_value, field_description^);
    convert_int_field_value_to_ext (NIL, work_area, internal_default_value, default_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    descriptive_text := #PTR (field_description_header^.descriptive_text, field_description^);

    utility_information := #PTR (field_description_header^.utility_information, field_description^);

    IF deleted_field THEN
      osp$set_status_abnormal ('AV', ave$field_was_deleted, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            field_directory_entry^.delete_status.os_version_when_deleted, status);
      RETURN;
    IFEND;

  PROCEND get_field_description;
?? TITLE := '    get_field_description_header', EJECT ??

{ PURPOSE:
{   This procedure returns a pointer to the field description header.

  PROCEDURE get_field_description_header
    (    field_description: ^avt$field_description;
     VAR field_description_header: ^avt$field_description_header;
     VAR status: ost$status);

    VAR
      local_field_description: ^avt$field_description;

    status.normal := TRUE;

    local_field_description := field_description;
    RESET local_field_description;

    NEXT field_description_header IN local_field_description;
    IF field_description_header = NIL THEN
      corrupted_sequence ('GET_FIELD_DESCRIPTION_HEADER', 'FIELD_DESCRIPOTON_HEADER',
            'LOCAL_FIELD_DESCRIPTION', status);
    IFEND;

  PROCEND get_field_description_header;
?? TITLE := '    get_field_directory', EJECT ??

{ PURPOSE:
{   This procedure returns a pointer to the field directory in a description
{   record.

  PROCEDURE get_field_directory
    (    description_record: ^avt$template_file_record;
     VAR field_directory: ^avt$field_directory;
     VAR status: ost$status);

    VAR
      description_record_header: ^avt$template_file_record_header;

    status.normal := TRUE;

    get_record_header (description_record, description_record_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    field_directory := #PTR (description_record_header^.field_directory_pointer, description_record^);

  PROCEND get_field_directory;
?? TITLE := '    get_field_directory_entry', EJECT ??

{ PURPOSE:
{   This procedure returns a pointer to the field directory entry
{   for the specified field.

  PROCEDURE get_field_directory_entry
    (    field_name: ost$name;
         field_directory: ^avt$field_directory;
     VAR field_directory_entry: ^avt$field_directory_entry;
     VAR deleted_field: boolean;
     VAR status: ost$status);

    VAR
      index: avt$field_count,
      found_field: boolean,
      os_version: pmt$os_name;

    status.normal := TRUE;
    deleted_field := FALSE;

    IF field_directory <> NIL THEN
      binary_search_field_directory (field_name, field_directory, found_field, index);
    ELSE
      found_field := FALSE;
    IFEND;
    IF NOT found_field THEN
      osp$set_status_abnormal ('AV', ave$unknown_field, field_name, status);
      RETURN;
    IFEND;

    field_directory_entry := ^field_directory^ [index];

    check_if_field_deleted (field_directory_entry^.delete_status, deleted_field, status);

  PROCEND get_field_directory_entry;
?? TITLE := '    get_field_value', EJECT ??

{ PURPOSE:
{   This procedure returns the value for the specified field.

  PROCEDURE get_field_value
    (    system_supplied_field_id: avt$system_supplied_field_id;
         data_record: ^avt$template_file_record;
         default_value: avt$field_value;
     VAR work_area: ^seq (*);
     VAR field_value: avt$field_value;
     VAR status: ost$status);

    VAR
      data_record_header: ^avt$template_file_record_header,
      entry: avt$field_count,
      found_field: boolean,
      internal_field_value: ^avt$internal_field_value,
      value_directory: ^avt$value_directory;

    status.normal := TRUE;

    get_record_header (data_record, data_record_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    value_directory := #PTR (data_record_header^.value_directory_pointer, data_record^);

    IF value_directory <> NIL THEN
      binary_search_value_directory (system_supplied_field_id, value_directory, found_field, entry);
    ELSE
      found_field := FALSE;
    IFEND;
    IF found_field THEN
      internal_field_value := #PTR (value_directory^ [entry].value, data_record^);
      convert_int_field_value_to_ext (^default_value, work_area, internal_field_value, field_value, status);
    ELSE
      field_value := default_value;
    IFEND;

  PROCEND get_field_value;
?? TITLE := '    get_record_header', EJECT ??

{ PURPOSE:
{   This procedure returns a pointer to the header for a template file record.

  PROCEDURE get_record_header
    (    template_file_record: ^avt$template_file_record;
     VAR template_file_record_header: ^avt$template_file_record_header;
     VAR status: ost$status);

    VAR
      local_template_file_record: ^avt$template_file_record;

    status.normal := TRUE;
    local_template_file_record := template_file_record;

    RESET local_template_file_record;

    NEXT template_file_record_header IN local_template_file_record;
    IF template_file_record_header = NIL THEN
      corrupted_sequence ('FIND_RECORD_HEADER', 'TEMPLATE_FILE_RECORD_HEADER', 'LOCAL_TEMPLATE_FILE_RECORD',
            status);
      RETURN;
    IFEND;

  PROCEND get_record_header;
?? TITLE := '    get_value_directory', EJECT ??

{ PURPOSE:
{   This procedure returns a pointer to the value directory in a data record.

  PROCEDURE get_value_directory
    (    data_record: ^avt$template_file_record;
     VAR value_directory: ^avt$value_directory;
     VAR status: ost$status);

    VAR
      data_record_header: ^avt$template_file_record_header;

    status.normal := TRUE;

    get_record_header (data_record, data_record_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    value_directory := #PTR (data_record_header^.value_directory_pointer, data_record^);

  PROCEND get_value_directory;
?? TITLE := '    rebuild_data_record', EJECT ??

{ PURPOSE:
{   This procedure rebuilds a data record by merging the original data record
{   with information from an optional field value list (i.e., the field value list
{   may be NIL).

  PROCEDURE rebuild_data_record
    (    original_data_record: ^avt$template_file_record;
         field_value_list: avt$field_value_list;
         description_record_index: 1 .. avc$maximum_desc_record_count;
         description_record: ^avt$template_file_record;
     VAR new_data_record_work_area: ^avt$template_file_record;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      field_description: ^avt$field_description,
      field_description_header: ^avt$field_description_header,
      field_directory: ^avt$field_directory,
      field_directory_index: avt$field_count,
      field_value: avt$field_value,
      field_value_list_entry: ^avt$field_value_list_entry,
      found_field: boolean,
      internal_default_value: ^avt$internal_field_value,
      internal_field_value: ^avt$internal_field_value,
      new_data_record_header: ^avt$template_file_record_header,
      new_internal_field_value: ^avt$internal_field_value,
      new_value_directory: ^avt$value_directory,
      new_value_directory_index: avt$field_count,
      original_value_directory: ^avt$value_directory,
      original_value_directory_index: avt$field_count,
      temporary_value_directory: ^avt$value_directory,
      temporary_value_directory_index: avt$field_count,
      work_area: ^seq (*);

    status.normal := TRUE;

    PUSH work_area: [[REP avc$maximum_name_list_size OF avt$labeled_names]];

    PUSH temporary_value_directory: [1 .. avc$maximum_field_count];
    temporary_value_directory_index := 0;

    IF original_data_record <> NIL THEN
      get_value_directory (original_data_record, original_value_directory, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      original_value_directory := NIL;
    IFEND;

    RESET new_data_record_work_area;

    NEXT new_data_record_header IN new_data_record_work_area;
    IF new_data_record_header = NIL THEN
      osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
      RETURN;
    IFEND;
    new_data_record_header^.kind := avc$data_record;
    new_data_record_header^.value_directory_pointer := NIL;
    new_data_record_header^.description_record_index := description_record_index;

    get_field_directory (description_record, field_directory, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF field_directory <> NIL THEN
      FOR field_directory_index := 1 TO UPPERBOUND (field_directory^) DO
        RESET work_area;
        found_field := FALSE;
        internal_field_value := NIL;
        field_value_list_entry := field_value_list;

      /search_field_value_list/
        WHILE field_value_list_entry <> NIL DO
          IF field_value_list_entry^.field_name = field_directory^ [field_directory_index].name THEN
            field_value := field_value_list_entry^.field_value;
            found_field := TRUE;
            EXIT /search_field_value_list/;
          IFEND;
          field_value_list_entry := field_value_list_entry^.forward;
        WHILEND /search_field_value_list/;

        IF (NOT found_field) AND (original_value_directory <> NIL) THEN
          binary_search_value_directory (field_directory^ [field_directory_index].system_supplied_field_id,
                original_value_directory, found_field, original_value_directory_index);
          IF found_field THEN

{ Pick up the value from the data record.

            internal_field_value := #PTR (original_value_directory^ [original_value_directory_index].value,
                  original_data_record^);
          IFEND;
        IFEND;

{ A value was found for the field in either the field value list or the original data record.

        IF found_field THEN

{ Get the default value and convert it to it's external format.

          field_description := #PTR (field_directory^ [field_directory_index].description,
                description_record^);
          get_field_description_header (field_description, field_description_header, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          internal_default_value := #PTR (field_description_header^.default_value, field_description^);
          convert_int_field_value_to_ext (NIL, work_area, internal_default_value, default_value, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{  Use the field value from the data record if the field did not appear in the field value list.

          IF internal_field_value <> NIL THEN
            convert_int_field_value_to_ext (^default_value, work_area, internal_field_value, field_value,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

{ Convert either value to it's internal format.

          convert_ext_field_value_to_int (^default_value, field_value, new_internal_field_value,
                new_data_record_work_area, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ If the value does not match the default add it to the value directory.

          IF new_internal_field_value <> NIL THEN
            temporary_value_directory_index := temporary_value_directory_index + 1;
            temporary_value_directory^ [temporary_value_directory_index].system_supplied_field_id :=
                  field_directory^ [field_directory_index].system_supplied_field_id;
            temporary_value_directory^ [temporary_value_directory_index].
                  value := #REL (new_internal_field_value, new_data_record_work_area^);
          IFEND;
        IFEND;
      FOREND;

{ If the value directory has anything in it put a copy of it in the data record.

      IF temporary_value_directory_index <> 0 THEN
        NEXT new_value_directory: [1 .. temporary_value_directory_index] IN new_data_record_work_area;
        IF new_value_directory = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        new_data_record_header^.value_directory_pointer := #REL (new_value_directory,
              new_data_record_work_area^);

        FOR new_value_directory_index := 1 TO temporary_value_directory_index DO
          new_value_directory^ [new_value_directory_index] :=
                temporary_value_directory^ [new_value_directory_index];
        FOREND;

        sort_value_directory (new_value_directory^);
      IFEND;
    IFEND;

  PROCEND rebuild_data_record;
?? TITLE := '    sort_field_directory', EJECT ??

{ PURPOSE:
{   This procedure sorts the field directory into alphbetical order.

  PROCEDURE sort_field_directory
    (VAR field_directory: avt$field_directory);

    VAR
      index: avt$field_count,
      swapped_entries: boolean,
      temporary_directory_entry: avt$field_directory_entry;

    REPEAT
      swapped_entries := FALSE;
      FOR index := 1 TO UPPERBOUND (field_directory) - 1 DO
        IF field_directory [index].name > field_directory [index + 1].name THEN
          temporary_directory_entry := field_directory [index];
          field_directory [index] := field_directory [index + 1];
          field_directory [index + 1] := temporary_directory_entry;
          swapped_entries := TRUE;
        IFEND;
      FOREND;
    UNTIL NOT swapped_entries;

  PROCEND sort_field_directory;
?? TITLE := '    sort_labeled_names', EJECT ??

{ PURPOSE:
{   This procedure sorts a list of labeled names into alphbetical order.

  PROCEDURE sort_labeled_names
    (VAR labeled_names: avt$labeled_names_list);

    VAR
      index: avt$field_count,
      swapped_entries: boolean,
      temporary_labeled_name_entry: avt$labeled_names;

    REPEAT
      swapped_entries := FALSE;
      FOR index := 1 TO UPPERBOUND (labeled_names) - 1 DO
        IF labeled_names [index].label^ > labeled_names [index + 1].label^ THEN
          temporary_labeled_name_entry := labeled_names [index];
          labeled_names [index] := labeled_names [index + 1];
          labeled_names [index + 1] := temporary_labeled_name_entry;
          swapped_entries := TRUE;
        IFEND;
      FOREND;
    UNTIL NOT swapped_entries;

    FOR index := 1 TO UPPERBOUND (labeled_names) DO
      IF labeled_names [index].names <> NIL THEN
        sort_name_list (labeled_names [index].names^);
      IFEND;
    FOREND;

  PROCEND sort_labeled_names;
?? TITLE := '    sort_name_list', EJECT ??

{ PURPOSE:
{   This procedure sorts a list of names into alphbetical order.

  PROCEDURE sort_name_list
    (VAR name_list: avt$name_list);

    VAR
      index: avt$field_count,
      swapped_entries: boolean,
      temporary_name_entry: ost$name;

    REPEAT
      swapped_entries := FALSE;
      FOR index := 1 TO UPPERBOUND (name_list) - 1 DO
        IF name_list [index] > name_list [index + 1] THEN
          temporary_name_entry := name_list [index];
          name_list [index] := name_list [index + 1];
          name_list [index + 1] := temporary_name_entry;
          swapped_entries := TRUE;
        IFEND;
      FOREND;
    UNTIL NOT swapped_entries;

  PROCEND sort_name_list;
?? TITLE := '    sort_value_directory', EJECT ??

{ PURPOSE:
{   This procedure sorts a value directory into ascending order by system
{   supplied field id.

  PROCEDURE sort_value_directory
    (VAR value_directory: avt$value_directory);

    VAR
      index: avt$field_count,
      swapped_entries: boolean,
      temporary_directory_entry: avt$value_directory_entry;

    REPEAT
      swapped_entries := FALSE;
      FOR index := 1 TO UPPERBOUND (value_directory) - 1 DO
        IF value_directory [index].system_supplied_field_id >
              value_directory [index + 1].system_supplied_field_id THEN
          temporary_directory_entry := value_directory [index];
          value_directory [index] := value_directory [index + 1];
          value_directory [index + 1] := temporary_directory_entry;
          swapped_entries := TRUE;
        IFEND;
      FOREND;
    UNTIL NOT swapped_entries;

  PROCEND sort_value_directory;
?? OLDTITLE ??
?? OLDTITLE ??

MODEND avm$template_file_manager;
*DECK DECK=AVM$VALIDATION_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Validation Commands' ??
MODULE avm$validation_commands;

{ PURPOSE:
{   This module contains the command and function processors used to control system and user access to NOS/VE.
{
{ DESIGN:
{   The command processors in this module convert the parameter values specified on the command into their
{   internal formats (when necessary) and call the appropriate validation program interface.

*copyc avc$compile_test_code
?IF avc$compile_test_code THEN
  PROCEDURE [XREF] initialize
    (    validation_level: avt$validation_level;
         system_administrator: boolean;
         family_administrator: boolean;
     VAR status: ost$status);
?IFEND

?? NEWTITLE := 'Global declarations referenced by this module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avc$max_template_record_size
*copyc cle$work_area_overflow
*copyc clt$work_area
*copyc fst$path
*copyc oss$job_paged_literal
?? POP ??
*copyc avp$change_password
*copyc avp$get_account_project_value
*copyc avp$get_accum_limit_value
*copyc avp$get_capability
*copyc avp$get_date_time_value
*copyc avp$get_field_type
*copyc avp$get_file_value
*copyc avp$get_integer_value
*copyc avp$get_job_class_value
*copyc avp$get_labeled_names_value
*copyc avp$get_limit_value
*copyc avp$get_login_password_value
*copyc avp$get_name_value
*copyc avp$get_real_value
*copyc avp$get_string_value
*copyc avp$make_acct_proj_scl_value
*copyc avp$make_accum_limit_scl_value
*copyc avp$make_capability_scl_value
*copyc avp$make_date_time_scl_value
*copyc avp$make_file_scl_value
*copyc avp$make_integer_scl_value
*copyc avp$make_job_class_scl_value
*copyc avp$make_labeled_names_scl_valu
*copyc avp$make_limit_scl_value
*copyc avp$make_login_pw_scl_value
*copyc avp$make_name_scl_value
*copyc avp$make_real_scl_value
*copyc avp$make_ring_priv_scl_value
*copyc avp$make_string_scl_value
*copyc avp$ring_min
*copyc avp$ring_nominal
*copyc avp$set_validation_level
*copyc avp$validation_level
*copyc clp$evaluate_parameters
*copyc clp$make_name_value
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := 'Global declarations declared by this module.', EJECT ??
?? FMT (FORMAT := OFF) ??
  VAR
    avv$field_kind_names: [#GATE, XDCL, READ, oss$job_paged_literal] array [avt$field_kind] of ost$name :=
          ['ACCOUNT_PROJECT                ', 'ACCUMULATING_LIMIT             ',
          'CAPABILITY                     ', 'DATE_TIME                      ',
          'FILE                           ', 'INTEGER                        ',
          'JOB_CLASS                      ', 'KEYWORD                        ',
          'LIMIT                          ', 'LOGIN_PASSWORD                 ',
          'NAME                           ', 'REAL                           ',
          'RESTRICTION                    ', 'RING_PRIVILEGE                 ',
          'STRING                         ', 'LABELED_NAMES                  ',
          'UNUSED                         ', 'UNUSED                         ',
          'UNUSED                         ', 'UNUSED                         ',
          'UNUSED                         ', 'UNUSED                         ',
          'UNUSED                         ', 'UNUSED                         ',
          'UNUSED                         ', 'UNUSED                         ',
          'UNUSED                         ', 'UNUSED                         ',
          'UNUSED                         ', 'UNUSED                         ',
          'UNUSED                         ', 'UNUSED                         '];
?? FMT (FORMAT := ON) ??

?? NEWTITLE := '[XDCL] avp$change_password_command', EJECT ??
{ PURPOSE:
{   This is the command processor for CHANGE_LOGIN_PASSWORD.
{
{ DESIGN:
{   AVP$CHANGE_PASSWORD is called to update the currently executing user's login
{   password.

  PROCEDURE [XDCL] avp$change_password_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$chalpw) change_login_password, set_password, setpw, chalpw (
{   old_password, f, from, opw: (SECURE) name = $required
{   new_password, t, to, npw: (SECURE) name = $required
{   expiration_interval, ei: any of
{       key
{         unlimited
{       keyend
{       integer 1..365
{     anyend = $optional
{   expiration_date, ed: any of
{       key
{         none
{       keyend
{       date_time
{     anyend = $optional
{   update_batch_job_passwords, ubjpw: (BY_NAME) boolean = osd$chalpw_ubjpw, ..
{ TRUE
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 15] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: 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$integer_type_qualifier,
        recend,
      recend,
      type4: 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$date_time_type_qualifier,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
        default_name: string (16),
        default_value: string (4),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 5, 29, 9, 27, 36, 693],
    clc$command, 15, 6, 2, 0, 0, 0, 6, 'OSM$CHALPW'], [
    ['ED                             ',clc$abbreviation_entry, 4],
    ['EI                             ',clc$abbreviation_entry, 3],
    ['EXPIRATION_DATE                ',clc$nominal_entry, 4],
    ['EXPIRATION_INTERVAL            ',clc$nominal_entry, 3],
    ['F                              ',clc$alias_entry, 1],
    ['FROM                           ',clc$alias_entry, 1],
    ['NEW_PASSWORD                   ',clc$nominal_entry, 2],
    ['NPW                            ',clc$abbreviation_entry, 2],
    ['OLD_PASSWORD                   ',clc$nominal_entry, 1],
    ['OPW                            ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 6],
    ['T                              ',clc$alias_entry, 2],
    ['TO                             ',clc$alias_entry, 2],
    ['UBJPW                          ',clc$abbreviation_entry, 5],
    ['UPDATE_BATCH_JOB_PASSWORDS     ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [9, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 16, 4],
{ PARAMETER 6
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, 365, 10]]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$date_time_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time
  ], $clt$date_time_tenses [clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 5
    [[1, 0, clc$boolean_type],
    'OSD$CHALPW_UBJPW',
    'TRUE'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

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

    CONST
      p$old_password = 1,
      p$new_password = 2,
      p$expiration_interval = 3,
      p$expiration_date = 4,
      p$update_batch_job_passwords = 5,
      p$status = 6;

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

    VAR
      expiration_date: ^ost$date_time,
      expiration_interval: ^pmt$time_increment,
      new_password: avt$password,
      old_password: avt$password;

    ?IF avc$compile_test_code THEN
      initialize (avc$user_level, FALSE, FALSE, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ?IFEND

    status.normal := TRUE;

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

    IF pvt [p$expiration_interval].specified THEN
      PUSH expiration_interval;
      IF pvt [p$expiration_interval].value^.kind = clc$keyword THEN
        expiration_interval^.year := UPPERVALUE (expiration_interval^.year);
        expiration_interval^.month := UPPERVALUE (expiration_interval^.month);
        expiration_interval^.day := UPPERVALUE (expiration_interval^.day);
        expiration_interval^.hour := UPPERVALUE (expiration_interval^.hour);
        expiration_interval^.minute := UPPERVALUE (expiration_interval^.minute);
        expiration_interval^.second := UPPERVALUE (expiration_interval^.second);
        expiration_interval^.millisecond := UPPERVALUE (expiration_interval^.millisecond);
      ELSE { clc$integer}
        expiration_interval^.year := 0;
        expiration_interval^.month := 0;
        expiration_interval^.day := pvt [p$expiration_interval].value^.integer_value.value;
        expiration_interval^.hour := 0;
        expiration_interval^.minute := 0;
        expiration_interval^.second := 0;
        expiration_interval^.millisecond := 0;
      IFEND;
    ELSE
      expiration_interval := NIL;
    IFEND;

    IF pvt [p$expiration_date].specified THEN
      PUSH expiration_date;
      IF pvt [p$expiration_date].value^.kind = clc$keyword THEN
        expiration_date^.year := UPPERVALUE (expiration_date^.year);
        expiration_date^.month := UPPERVALUE (expiration_date^.month);
        expiration_date^.day := UPPERVALUE (expiration_date^.day);
        expiration_date^.hour := UPPERVALUE (expiration_date^.hour);
        expiration_date^.minute := UPPERVALUE (expiration_date^.minute);
        expiration_date^.second := UPPERVALUE (expiration_date^.second);
        expiration_date^.millisecond := UPPERVALUE (expiration_date^.millisecond);
      ELSE {clc$date_time}
        expiration_date^ := pvt [p$expiration_date].value^.date_time_value.value;
      IFEND;
    ELSE
      expiration_date := NIL;
    IFEND;

    old_password := pvt [p$old_password].value^.name_value;
    new_password := pvt [p$new_password].value^.name_value;

    avp$change_password (old_password, new_password, expiration_date, expiration_interval,
          pvt [p$update_batch_job_passwords].value^.boolean_value.value, status);

    old_password := ' ';
    new_password := ' ';
    pvt [p$old_password].value^.name_value := ' ';
    pvt [p$new_password].value^.name_value := ' ';

  PROCEND avp$change_password_command;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] avp$change_validation_level', EJECT ??
{ PURPOSE:
{   This is the command processor for the CHANGE_VALIDATION_LEVEL command.
{
{ DESIGN:
{   AVP$SET_VALIDATION_LEVEL is called with the specified validation level.

  PROCEDURE [XDCL] avp$change_validation_level
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$chavl) change_validation_level (
{   validation_level, vl: key
{       user, account, project
{     keyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 29, 11, 56, 39, 344],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$CHAVL'], [
    ['STATUS                         ',clc$nominal_entry, 2],
    ['VALIDATION_LEVEL               ',clc$nominal_entry, 1],
    ['VL                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [3], [
    ['ACCOUNT                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['PROJECT                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['USER                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$validation_level = 1,
    p$status = 2;

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

    VAR
      level: avt$validation_level;

    status.normal := TRUE;

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

    IF pvt [p$validation_level].value^.keyword_value = 'USER' THEN
      level := avc$user_level;
    ELSEIF pvt [p$validation_level].value^.keyword_value = 'ACCOUNT' THEN
      level := avc$account_level;
    ELSE
      level := avc$project_level;
    IFEND;

    avp$set_validation_level (level, status);

  PROCEND avp$change_validation_level;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] avp$$job_validation', EJECT ??

{ PURPOSE:
{   Return information about a specified validation field for the executing job.

  PROCEDURE [XDCL] avp$$job_validation
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$job_validation) $job_validation (
{   field_name: name = $required
{   option: key
{       (declared, d)
{       (type, t)
{       (value, v)
{     keyend = value
{   validation_record: key
{       (account, a)
{       (account_member, am)
{       (project, p)
{       (project_member, pm)
{       (user, u)
{     keyend = user
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 10] of clt$keyword_specification,
        default_value: string (4),
      recend,
    recend := [
    [1,
    [88, 12, 14, 13, 57, 8, 847],
    clc$function, 3, 3, 1, 0, 0, 0, 0, 'OSM$$JOB_VALIDATION'], [
    ['FIELD_NAME                     ',clc$nominal_entry, 1],
    ['OPTION                         ',clc$nominal_entry, 2],
    ['VALIDATION_RECORD              ',clc$nominal_entry, 3]],
    [
{ 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, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, 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, 229,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
    [3, 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, 377,
  clc$optional_default_parameter, 0, 4]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [6], [
    ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['DECLARED                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TYPE                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['V                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['VALUE                          ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ,
    'value'],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [10], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ACCOUNT                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ACCOUNT_MEMBER                 ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['AM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['PM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['PROJECT                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['PROJECT_MEMBER                 ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['USER                           ', clc$nominal_entry, clc$normal_usage_entry, 5]]
    ,
    'user']];

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

    CONST
      p$field_name = 1,
      p$option = 2,
      p$validation_record = 3;

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

    VAR
      account: avt$account_name,
      batch_default: ost$name,
      capability: boolean,
      change_date: ost$date_time,
      date_display_format: string(clc$max_date_time_form_string),
      date_time: avt$date_time,
      declared: ost$name,
      expiration_date: ost$date_time,
      expiration_interval: pmt$time_increment,
      expiration_warning_interval: pmt$time_increment,
      expired_password_chg_interval: pmt$time_increment,
      field_kind: avt$field_kind,
      field_work_area: ^seq (*),
      file_reference: fst$path,
      integer_value: integer,
      interactive_default: ost$name,
      job_limit_information: avt$job_limit_information,
      labeled_names: ^avt$labeled_names_list,
      limit_value: avt$limit_value,
      local_status: ost$status,
      maximum_expiration_interval: pmt$time_increment,
      name_list: ^avt$name_list,
      name_list_size: avt$name_list_size,
      numeric_display_format: avt$numeric_display_format,
      project: avt$project_name,
      real_value: real,
      string_value: ost$string,
      time_display_format: string(clc$max_date_time_form_string),
      total_limit_information: avt$total_limit_information,
      validation_record: avt$validation_record;

    status.normal := TRUE;

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

{ Determine which validation record to retrieve information from.

    IF pvt [p$validation_record].value^.keyword_value = 'USER' THEN
      validation_record := avc$user;
    ELSEIF pvt [p$validation_record].value^.keyword_value = 'ACCOUNT' THEN
      validation_record := avc$account;
    ELSEIF pvt [p$validation_record].value^.keyword_value = 'ACCOUNT_MEMBER' THEN
      validation_record := avc$account_member;
    ELSEIF pvt [p$validation_record].value^.keyword_value = 'PROJECT' THEN
      validation_record := avc$project;
    ELSE { PROJECT_MEMBER }
      validation_record := avc$project_member;
    IFEND;

{ Determine the type of the specified field.

    avp$get_field_type (pvt [p$field_name].value^.name_value, validation_record, field_kind, local_status);
    IF (NOT local_status.normal) AND (pvt [p$option].value^.keyword_value <> 'DECLARED') THEN
      status := local_status;
      RETURN;
    IFEND;

    IF (pvt [p$option].value^.keyword_value = 'DECLARED') THEN
      IF local_status.normal THEN
        declared := 'ACTIVE';
      ELSEIF local_status.condition = ave$field_was_deleted THEN
        declared := 'DELETED';
      ELSE
        declared := 'UNKNOWN';
      IFEND;

      clp$make_name_value (declared, work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
    ELSEIF (pvt [p$option].value^.keyword_value = 'TYPE') THEN
      clp$make_name_value (avv$field_kind_names [field_kind], work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
    ELSE { VALUE }
      CASE field_kind OF
      = avc$account_project_kind =
        avp$get_account_project_value (pvt [p$field_name].value^.name_value, validation_record, account,
              project, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_acct_proj_scl_value (account, project, work_area, result, status);
      = avc$accumulating_limit_kind =
        avp$get_accum_limit_value (pvt [p$field_name].value^.name_value, validation_record,
              job_limit_information, total_limit_information, numeric_display_format, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_accum_limit_scl_value (job_limit_information, total_limit_information,
              numeric_display_format, work_area, result, status);
      = avc$capability_kind =
        avp$get_capability (pvt [p$field_name].value^.name_value, validation_record, capability, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_capability_scl_value (capability, work_area, result, status);
      = avc$date_time_kind =
        avp$get_date_time_value (pvt [p$field_name].value^.name_value, validation_record, date_time,
              date_display_format, time_display_format, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_date_time_scl_value (date_time, work_area, result, status);
      = avc$file_kind =
        avp$get_file_value (pvt [p$field_name].value^.name_value, validation_record, file_reference,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_file_scl_value (file_reference, work_area, result, status);
      = avc$integer_kind =
        avp$get_integer_value (pvt [p$field_name].value^.name_value, validation_record, integer_value,
              numeric_display_format, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_integer_scl_value (integer_value, numeric_display_format, work_area, result, status);
      = avc$job_class_kind =
        PUSH name_list: [1 .. avc$maximum_name_list_size];
        avp$get_job_class_value (pvt [p$field_name].value^.name_value, validation_record, name_list^,
              name_list_size, batch_default, interactive_default, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_job_class_scl_value (batch_default, interactive_default, name_list^, name_list_size,
              work_area, result, status);
      = avc$keyword_kind =

{ Keywords are not implemented yet.

      = avc$labeled_names_kind =
        PUSH field_work_area: [[REP avc$max_template_record_size OF cell]];
        RESET field_work_area;
        avp$get_labeled_names_value (pvt [p$field_name].value^.name_value, validation_record,
              field_work_area, labeled_names, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_labeled_names_scl_valu (labeled_names, work_area, result, status);
      = avc$limit_kind =
        avp$get_limit_value (pvt [p$field_name].value^.name_value, validation_record, limit_value,
              numeric_display_format, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_limit_scl_value (limit_value, numeric_display_format, work_area, result, status);
      = avc$login_password_kind =
        PUSH name_list: [1 .. avc$maximum_name_list_size];
        avp$get_login_password_value (pvt [p$field_name].value^.name_value, validation_record,
              expiration_date, expiration_interval, maximum_expiration_interval,
              expiration_warning_interval, expired_password_chg_interval, change_date, name_list^,
              name_list_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_login_pw_scl_value (expiration_date, expiration_interval, maximum_expiration_interval,
              expiration_warning_interval, expired_password_chg_interval, change_date, name_list^,
              name_list_size, work_area, result, status);
      = avc$name_kind =
        PUSH name_list: [1 .. avc$maximum_name_list_size];
        avp$get_name_value (pvt [p$field_name].value^.name_value, validation_record, name_list^,
              name_list_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_name_scl_value (name_list^, name_list_size, work_area, result, status);
      = avc$real_kind =
        avp$get_real_value (pvt [p$field_name].value^.name_value, validation_record, real_value,
              numeric_display_format, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_real_scl_value (real_value, work_area, result, status);
      = avc$ring_privilege_kind =
        avp$make_ring_priv_scl_value (avp$ring_min (), avp$ring_nominal (), work_area, result, status);
      = avc$string_kind =
        avp$get_string_value (pvt [p$field_name].value^.name_value, validation_record, string_value,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        avp$make_string_scl_value (string_value, work_area, result, status);
      CASEND;
    IFEND;

  PROCEND avp$$job_validation;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] avp$$validation_level', EJECT ??
{ PURPOSE:
{   This is the function processor for $VALIDATION_LEVEL
{
{ DESIGN:
{   AVP$VALIDATION_LEVEL is called to get the validation_level.

  PROCEDURE [XDCL] avp$$validation_level
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $validation_level

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [88, 5, 25, 11, 53, 54, 150],
    clc$function, 0, 0, 0, 0, 0, 0, 0, '$VALIDATION_LEVEL']];

?? POP ??

    status.normal := TRUE;

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

    NEXT result IN work_area;
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;

    result^.kind := clc$name;

    CASE avp$validation_level () OF
    = avc$user_level =
      result^.name_value := avc$user_level_name;
    = avc$account_level =
      result^.name_value := avc$account_level_name;
    ELSE { project level }
      result^.name_value := avc$project_level_name;
    CASEND;

  PROCEND avp$$validation_level;
?? OLDTITLE ??
MODEND avm$validation_commands;

*DECK DECK=AVM$VALIDATION_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Validation Interfaces' ??
MODULE avm$validation_interfaces;

{ PURPOSE:
{   This module contains external interfaces used to manage a validation file.  It contains interfaces to
{   create, update and read validation information for users, accounts, and projects.

{ DESIGN:
{   The interfaces in this module protect the information in a validation file from update or retrieval by
{   unprivileged users.
{
{   The interfaces in this module are grouped into the following catagories.
{
{   General Purpose Interfaces
{   Interfaces to create validation records
{   Interfaces to read validation records
{   Interfaces to change validation records
{   Interfaces to delete validation records
{   Interfaces to verify validation records exist
{
{   Interfaces to create field descriptions
{   Interfaces to read field descriptions
{   Interfaces to change field descriptions
{   Interfaces to change field names, delete fields, and restore fields.
{
{   Interfaces to change field values
{   Interfaces to read field display values
{   Interfaces to read field values for the current executing job
{
{   Helper procedures
{
*copyc avc$compile_test_code
*copyc dft$procedure_address_ordinal
?? NEWTITLE := 'Global Declarations referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$condition_codes
*copyc avc$accounting_statistics
*copyc avc$system_defined_limit_names
*copyc avc$validation_default_values
*copyc avc$validation_field_names
*copyc avc$validation_file_name
*copyc avc$validation_file_version
*copyc avc$validation_level_const_name
*copyc avc$validation_level_names
*copyc avc$validation_record_names
*copyc ave$admin_validations_errors
*copyc ave$template_file_mgr_errors
*copyc ave$validation_interface_errors
*copyc avt$conditional_capabilities
*copyc avt$field_utility_information
*copyc avt$file_utility_information
*copyc avt$validation_file_type
*copyc avt$job_limit_information
*copyc avt$total_limit_information
*copyc avt$total_limit_update_record
*copyc avt$record_utility_info_entry
*copyc avt$record_utility_info_header
*copyc avt$validation_record_info
*copyc avt$validated_limit
*copyc avt$validation_authority
*copyc avt$validation_items
*copyc avt$validation_key
*copyc avt$validation_level
*copyc avt$validation_record
*copyc clc$standard_file_names
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_messages_and_prompts
*copyc cle$ecc_utilities
*copyc clt$block
*copyc clt$utility_name
*copyc i#current_sequence_position
*copyc i#move
*copyc jmc$system_family
*copyc jme$input_is_initiated
*copyc jme$no_jobs_were_found
*copyc jme$queued_file_conditions
*copyc jmt$job_class
*copyc ofe$error_codes
*copyc ost$caller_identifier
*copyc ost$status
*copyc pme$system_time_exceptions
*copyc sfc$unlimited

   TYPE
     avt$server_prevalidate_job_in = record
       validation_level: avt$validation_level,
       user_name: ost$user_name,
       family_name: ost$family_name,
       number_of_val_attributes: integer,
       number_of_def_attributes: integer,
     recend;

?? POP ??
PROCEDURE [INLINE] dummy;

{  Prevent XREF for avp$capability_active from interfering with
{  the procedure that is defined in this module.
{
{  The avp$system_administrator and avp$family_administrator decks
{  contain '*copyc avp$capability_active'.
*copyc avp$capability_active

PROCEND dummy;
*copyc avp$change_desc_utility_info
*copyc avp$change_field
*copyc avp$change_field_name
*copyc avp$change_file_utility_info
*copyc avp$close_template_file
*copyc avp$create_data_record
*copyc avp$create_description_record
*copyc avp$create_field
*copyc avp$delete_data_record
*copyc avp$delete_data_records
*copyc avp$delete_field
*copyc avp$determine_if_key_exists
*copyc avp$check_for_console_operation
*copyc avp$encrypt_password
*copyc avp$family_administrator
*copyc avp$get_desc_utility_info
*copyc avp$get_desc_utility_info_size
*copyc avp$get_description_record
*copyc avp$get_field
*copyc avp$get_field_description
*copyc avp$get_field_names
*copyc avp$get_file_utility_info
*copyc avp$old_encrypt_password
*copyc avp$open_template_file
*copyc avp$process_password_attributes
*copyc avp$read_data_record
*copyc avp$read_next_data_record
*copyc avp$restore_field
*copyc avp$restructure_template_file
*copyc avp$rewrite_data_record
*copyc avp$security_option_active
*copyc avp$store_validation_info
*copyc avp$system_administrator
*copyc avp$unlock_template_file
*copyc avp$verify_type_conformance
*copyc avv$debug_accounting_validation
*copyc avv$job_pageable_val_info
*copyc avv$security_options
*copyc avv$validation_level
*copyc clp$convert_date_time_to_string
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$delete_file_from_cmnd_list
*copyc clp$evaluate_file_reference
*copyc clp$find_current_block
*copyc clp$find_task_block
*copyc clp$find_utility_block
*copyc clp$validate_name
*copyc clp$get_path_description
*copyc clp$get_path_name
*copyc clp$get_processing_phase
*copyc clp$trimmed_string_size
*copyc dfp$check_job_recovery
*copyc dfp$locate_served_family
*copyc dfp$send_remote_procedure_call
*copyc fsp$path_element
*copyc ifp$get_terminal_attributes
*copyc jmp$change_input_attributes
*copyc jmp$get_job_status
*copyc jmp$get_result_size
*copyc jmp$system_job
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$check_for_desired_mf_class
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_log_message
*copyc osp$generate_output_message
*copyc osp$get_set_name
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc oss$job_paged_literal
*copyc osp$set_status_condition
*copyc osp$verify_system_privilege
*copyc oss$task_private
*copyc oss$task_shared
*copyc ost$heap
*copyc pfp$permit
*copyc pfp$purge_catalog_contents
*copyc pfp$purge_master_catalog
*copyc pfp$reset_administrator_status
*copyc pfp$set_family_administrator
*copyc pfp$utility_attach
*copyc pmp$compute_date_time
*copyc pmp$compute_date_time_increment
*copyc pmp$get_compact_date_time
*copyc pmp$get_default_date_time_form
*copyc pmp$get_job_mode
*copyc pmp$get_unique_name
*copyc pmp$get_user_identification
*copyc rmp$request_mass_storage
*copyc sfp$convert_stat_code_to_name
*copyc sfp$emit_audit_statistic
*copyc sfp$emit_statistic
*copyc sfp$get_job_limit
*copyc syp$store_system_constant
*copyc osv$upper_to_lower
  ?IF avc$compile_test_code THEN

    VAR
      osv$job_pageable_heap: [XDCL] ^ost$heap := NIL;

    VAR
      osv$task_shared_heap: [XDCL] ^ost$heap := NIL;

    VAR
      osv$task_private_heap: [XDCL] ^ost$heap := NIL;

  ?ELSE
*copyc osv$task_shared_heap
*copyc osv$task_private_heap
  ?IFEND
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations declared by this module', EJECT ??

{ Variables used to hold static login validation information for a job

  VAR
    avv$account_name: [XDCL, oss$task_shared] avt$account_name := osc$null_name,
    avv$minimum_ring: [STATIC, oss$task_shared] ost$ring := osc$user_ring,
    avv$nominal_ring: [STATIC, oss$task_shared] ost$ring := osc$user_ring,
    avv$project_name: [XDCL, oss$task_shared] avt$project_name := osc$null_name,
    avv$validated_limits: [XDCL, #GATE, oss$task_shared] ^avt$validated_limit := NIL,
    avv$validation_record_info: [STATIC, oss$task_private] ^avt$validation_record_info := NIL;

{ Variable used to indicate which system_operator_utility capabilities are
{ active in the job synchronous task of the system job.  This information is used
{ to condition the content of (refreshing) displays written to window A or window B.

  VAR
    avv$active_sou_capabilities: [XDCL, oss$task_shared] avt$conditional_capabilities
      := -$avt$conditional_capabilities[];

{ Variable used to indicate which system_operator_utility capabilities the system
{ job is validated for.  This information is used to determine what conditions
{ should cause an alarm indication to be presented at the system console.

  VAR
    avv$validated_sou_capabilities: [XDCL, oss$task_shared] avt$conditional_capabilities
      := -$avt$conditional_capabilities[];

{ Variable used to indicate whether the begin_production_environment command
{ has been executed.  This variable is used only by the system job.

  VAR
    avv$production_environ_begun: [XDCL, oss$task_shared] boolean := FALSE;

{ Names of conditional capability validation fields.

  VAR
    avv$cond_capability_names: [XDCL, READ, oss$job_paged_literal] array [avt$conditional_capability] of
          ost$name := [avc$accounting_administration, avc$configuration_admin, avc$family_administration,
          avc$removable_media_admin, avc$removable_media_operation, avc$system_administration,
          avc$system_displays, avc$system_operation];

?? TITLE := '  avp$activate_capabilities', EJECT ??
{
{ PURPOSE:
{
{   This interface is used to activate one or more conditional capabilities.
{ Activating a conditional capability allows the functions validated by the
{ capability to be performed.
{
{ DESIGN:
{
{   The system job is always permited to activate the system_administration
{ capability.  In all other cases, the login user of the executing job must be
{ validated for each capability to be activated.
{
{   The set of active conditional capabilities is stored on the block stack.
{ The active capabilities are either stored in the current block stack entry or
{ in the block stack entry of a specified utility and all child blocks, depending
{ on the value of the utility parameter.
{
{ NOTE:
{   If system_administration or family_administration is activated in a block
{ associated with tasks other than the executing task, then the
{ privileges associated with these capabilities will NOT be in effect unless
{ the PF subsystem re-evaluates its (task private) administrator status within
{ those tasks.
{

  PROCEDURE [XDCL, #GATE] avp$activate_capabilities (
         capabilities: avt$conditional_capabilities;
         utility: clt$utility_name;
    VAR status: ost$status);

    VAR
      audit_information: sft$audit_information,
      block: ^clt$block,
      block_in_current_task: boolean,
      capability: boolean,
      conditional_capability: avt$conditional_capability,
      current_block: ^clt$block,
      name_is_valid: boolean,
      restricted_mainframe: boolean,
      user_id: ost$user_identification,
      utility_block: ^clt$block,
      validated_utility_name: ost$name;

    status.normal := TRUE;

  /activate_capabilities/
    BEGIN

{ Verify that the console operation only security option is enforced if on.

    avp$check_for_console_operation ('Conditional capabilities', status);
    IF NOT status.normal THEN
      EXIT /activate_capabilities/;
    IFEND;

    { Check for system_administration validation.  If this is the system job, we don't
    { need to check the validation unless we are running on a Soviet or China system.

    osp$check_for_desired_mf_class (osc$mc_china_or_soviet_class, restricted_mainframe);

    IF ( (avc$cc_system_admin IN capabilities) AND (NOT (jmp$system_job ()) OR
          (restricted_mainframe))) THEN
      avp$get_capability (avc$system_administration, avc$user, capability, status);
      IF NOT status.normal THEN
        EXIT /activate_capabilities/;
      ELSEIF NOT capability THEN
        osp$set_status_abnormal ('AV', ave$missing_required_capability, 'system_administration', status);
        EXIT /activate_capabilities/;
      IFEND;
    IFEND;

{ Check for family_administration validation.

    IF (avc$cc_family_admin IN capabilities) THEN
      avp$get_capability (avc$family_administration, avc$user, capability, status);
      IF NOT status.normal THEN
        EXIT /activate_capabilities/;
      ELSEIF NOT capability THEN
        osp$set_status_abnormal ('AV', ave$missing_required_capability, 'family_administration', status);
        EXIT /activate_capabilities/;
      IFEND;
    IFEND;

{ Check for accounting_administration validation.

    IF (avc$cc_accounting_admin IN capabilities) THEN
      avp$get_capability (avc$accounting_administration, avc$user, capability, status);
      IF NOT status.normal THEN
        EXIT /activate_capabilities/;
      ELSEIF NOT capability THEN
        osp$set_status_abnormal ('AV', ave$missing_required_capability, 'accounting_administration', status);
        EXIT /activate_capabilities/;
      IFEND;
    IFEND;

{ Check for configuration_administration validation.

    IF (avc$cc_configuration_admin IN capabilities) THEN
      avp$get_capability (avc$configuration_admin, avc$user, capability, status);
      IF NOT status.normal THEN
        EXIT /activate_capabilities/;
      ELSEIF NOT capability THEN
        osp$set_status_abnormal ('AV', ave$missing_required_capability,
            'configuration_administration', status);
        EXIT /activate_capabilities/;
      IFEND;
    IFEND;

{ Check for removable_media_administration validation.

    IF (avc$cc_removable_media_admin IN capabilities) THEN
      avp$get_capability (avc$removable_media_admin, avc$user, capability, status);
      IF NOT status.normal THEN
        EXIT /activate_capabilities/;
      ELSEIF NOT capability THEN
        osp$set_status_abnormal ('AV', ave$missing_required_capability, 'removable_media_administration',
              status);
        EXIT /activate_capabilities/;
      IFEND;
    IFEND;

{ Check for removable_media_operation validation.

    IF (avc$cc_removable_media_operator IN capabilities) THEN
      avp$get_capability (avc$removable_media_operation, avc$user, capability, status);
      IF NOT status.normal THEN
        EXIT /activate_capabilities/;
      ELSEIF NOT capability THEN
        osp$set_status_abnormal ('AV', ave$missing_required_capability, 'removable_media_operation', status);
        EXIT /activate_capabilities/;
      IFEND;
    IFEND;

{ Check for system_displays validation.

    IF (avc$cc_system_displays IN capabilities) THEN
      avp$get_capability (avc$system_displays, avc$user, capability, status);
      IF NOT status.normal THEN
        EXIT /activate_capabilities/;
      ELSEIF NOT capability THEN
        osp$set_status_abnormal ('AV', ave$missing_required_capability, 'system_displays', status);
        EXIT /activate_capabilities/;
      IFEND;
    IFEND;

{ Check for system_operation validation.

    IF (avc$cc_system_operator IN capabilities) THEN
      avp$get_capability (avc$system_operation, avc$user, capability, status);
      IF NOT status.normal THEN
        EXIT /activate_capabilities/;
      ELSEIF NOT capability THEN
        osp$set_status_abnormal ('AV', ave$missing_required_capability, 'system_operation', status);
        EXIT /activate_capabilities/;
      IFEND;
    IFEND;

{ Activate capabilities in appropriate blocks.

    clp$find_current_block (current_block);

    IF (utility = osc$null_name) THEN
      current_block^.active_capabilities :=  current_block^.active_capabilities + capabilities;
      validated_utility_name := osc$null_name;
    ELSE
      clp$validate_name (utility, validated_utility_name, name_is_valid);
      IF NOT name_is_valid THEN
        osp$set_status_abnormal ('CL', cle$improper_utility_name,  utility, status);
        EXIT /activate_capabilities/;
      IFEND;
      clp$find_utility_block (validated_utility_name, utility_block, block_in_current_task);
      IF utility_block <> NIL THEN
        utility_block^.active_capabilities := utility_block^.active_capabilities + capabilities;
        WHILE current_block <> utility_block DO
          current_block^.active_capabilities := current_block^.active_capabilities + capabilities;
          current_block := current_block^.previous_block;
        WHILEND;
      ELSE
        osp$set_status_abnormal ('CL', cle$unknown_utility, validated_utility_name, status);
        EXIT /activate_capabilities/;
      IFEND;
    IFEND;

{ If system_administration or family_administration has been activated, then
{ re-evaluate the PF subsystem's administrator status for the executing task.

    IF (avc$cc_system_admin IN capabilities) OR (avc$cc_family_admin  IN capabilities) THEN
      pfp$reset_administrator_status;
    IFEND;


{ If activating capabilities for the System Operator Utility in the system job
{ and the executing task is the job synchronous task, then "push" the activated
{ capabilities into avv$active_sou_capabilities.  The "old" avv$active_sou_capabilities
{ value is saved in the SOU utility block and will be restored when the block is popped
{ off the block stack.

    IF jmp$system_job () AND (validated_utility_name = 'SYSTEM_OPERATOR_UTILITY') THEN
      clp$find_task_block (block, status);
      IF block^.synchronous_with_job THEN
        utility_block^.active_sou_capabilities.saved := TRUE;
        utility_block^.active_sou_capabilities.value := avv$active_sou_capabilities;
        avv$active_sou_capabilities := utility_block^.active_capabilities;
      IFEND;
    IFEND;
    END /activate_capabilities/;

{ Emit audit statistics for activated capabilities.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_information.audited_operation := sfc$ao_val_activate_capability;
      FOR conditional_capability := LOWERVALUE (conditional_capability) TO
            UPPERVALUE (conditional_capability) DO
        IF conditional_capability IN capabilities THEN
          audit_information.activate_capability.field_name_p :=
                ^avv$cond_capability_names [conditional_capability];
          sfp$emit_audit_statistic (audit_information, status);
        IFEND;
      FOREND;
    IFEND;

  PROCEND avp$activate_capabilities;
?? TITLE := '  avp$begin_production_environ', EJECT ??
{
{ PURPOSE:
{
{   This interface is used to record the completion of the deadstart process in
{ the system job.  At the completion of deadstart, the active_capabilities field
{ is cleared in all blocks preceding the current block on the block stack,
{ except the job monitor task block which retains all capabilities.
{

  PROCEDURE [XDCL, #GATE] avp$begin_production_environ
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      file: clt$command_list_entry_file,
      file_name: [READ, oss$job_paged_literal] string (23) := '$system.osf$sou_library';

    status.normal := TRUE;
    IF NOT jmp$system_job () THEN
      osp$set_status_abnormal ('JM', jme$must_be_system_job, 'avp$begin_production_environ', status);
      RETURN;
    IFEND;

    IF avv$production_environ_begun THEN
      RETURN;
    IFEND;

    clp$find_current_block (block);

    WHILE block <> NIL DO
      IF NOT ((block^.kind=clc$task_block) AND (block^.task_kind=clc$job_monitor_task)) THEN
        block^.active_capabilities := $avt$conditional_capabilities [];
      IFEND;
      block := block^.previous_block;
    WHILEND;

{ Delete $system.osf$sou_library from the system job command list.  The commands
{ in this library must now be accessed through the SYSTEM_OPERATOR_UTILITY.

    file.kind := clc$command_list_entry_path;
    file.path := ^file_name;
    clp$delete_file_from_cmnd_list (file, {ignore} status);
    status.normal := TRUE;

    avv$production_environ_begun := TRUE;

    avv$active_sou_capabilities := $avt$conditional_capabilities [];

  PROCEND avp$begin_production_environ;
?? TITLE := '    avp$change_password', EJECT ??
{ PURPOSE:
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used by the change login password SCL command to change the value of the login password
{   on the validation file for a user.

  PROCEDURE [XDCL, #GATE] avp$change_password
    (    old_password: avt$password;
         new_password: avt$password;
         expiration_date: ^ost$date_time;
         expiration_interval: ^pmt$time_increment;
         update_batch_job_passwords: boolean;
     VAR status: ost$status);

    VAR
      command_table_size: integer,
      default_value: avt$field_value,
      descriptive_text: ^avt$descriptive_text,
      field_utility_info_ptr: ^avt$field_utility_information,
      ignore_status: ost$status,
      login_password: ^avt$login_password,
      record_id: ost$name,
      served_family: boolean,
      type_specification: avt$type_specification,
      user_identification: ost$user_identification,
      utility_information: ^avt$utility_information,
      validation_file_information: avt$template_file_information,
      validation_record_info: ^avt$validation_record_info;

?? NEWTITLE := '      change_pw_condition_handler', EJECT ??
{ PURPOSE:
{   This is a block exit condition handler to ensure that the validation file is closed on an abnormal exit
{   from the change password interface.

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

      VAR
        ignore_status: ost$status;

      handler_status.normal := TRUE;

      avp$end_subutility_session (record_id, FALSE, validation_file_information, ignore_status);
      avp$close_validation_file (validation_file_information, ignore_status);

    PROCEND change_pw_condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Get executing user identification.

    pmp$get_user_identification (user_identification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Don't allow a password change on the client.

    avp$check_for_served_family (user_identification.family, served_family);
    IF served_family THEN
      osp$set_status_abnormal ('AV', ave$not_allowed_on_client, 'CHANGE_PASSWORD', status);
      RETURN;
    IFEND;

{ Open the validation file for the executing family.

    avp$open_system_validation_file (user_identification.family, validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    osp$establish_block_exit_hndlr (^change_pw_condition_handler);

  /change/
    BEGIN

{ Begin change user utility session.

      avp$change_user_record (user_identification.user, record_id, command_table_size,
            validation_file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ Find the information for this subutility session within the validation record information chain.

      find_validation_record_info (record_id, validation_record_info, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ This interface is only used to change the users own password so always set the authority to user.

      validation_record_info^.caller_authority := avc$user_authority;

{ Change the login password value using the input information.

      PUSH login_password;
      login_password^.encrypted := FALSE;
      login_password^.value := new_password;
      avp$change_login_password_value (avc$login_password, ^old_password, login_password, expiration_date,
            expiration_interval, NIL, NIL, NIL, NIL, NIL, record_id, update_batch_job_passwords,
            validation_file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ End the change user utility session.

      avp$end_subutility_session (record_id, TRUE, validation_file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      avp$close_validation_file (validation_file_information, status);
    END /change/;
    IF NOT status.normal THEN

{ NOTE: If the subutility session has already been ended this call will do nothing.

      avp$end_subutility_session (record_id, FALSE, validation_file_information, ignore_status);
      avp$close_validation_file (validation_file_information, ignore_status);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND avp$change_password;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$change_user_pf_space_limit', EJECT ??
{ PURPOSE:
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change the value of the permanent file space limit accumulator
{   on the validation file for a user.

  PROCEDURE [XDCL, #GATE] avp$change_user_pf_space_limit
    (    family_name: ost$family_name;
         total_accumulation: ^avt$limit_value;
     VAR user_name: ost$user_name;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      number_of_command_entries: integer,
      record_id: ost$name,
      validation_file_information: avt$template_file_information;

?? NEWTITLE := 'change_pfsl_condition_handler', EJECT ??
{ PURPOSE:
{   This is a block exit condition handler to ensure that the validation file is closed on an
{   abnormal exit.

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

      VAR
        ignore_status: ost$status;

      avp$end_subutility_session (record_id, FALSE, validation_file_information, ignore_status);
      avp$close_validation_file (validation_file_information, ignore_status);

    PROCEND change_pfsl_condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Validate that we were called from within the system.

    osp$verify_system_privilege;

{ Open the validation file for the executing family.

    avp$open_system_validation_file (family_name, validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    osp$establish_block_exit_hndlr (^change_pfsl_condition_handler);

{ Begin change user utility session.

    avp$change_user_record (user_name, record_id, number_of_command_entries,
          validation_file_information, status);
    IF NOT status.normal THEN
      avp$end_subutility_session (record_id, FALSE, validation_file_information, ignore_status);
      avp$close_validation_file (validation_file_information, ignore_status);
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

{ Change the permanent_file_space_limit accumulator.

    avp$change_accum_limit_value (avc$permanent_file_space_limit, NIL, NIL, NIL, total_accumulation,
          record_id, validation_file_information, status);
    IF NOT status.normal THEN
      avp$end_subutility_session (record_id, FALSE, validation_file_information, ignore_status);
      avp$close_validation_file (validation_file_information, ignore_status);
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

{ End the change user utility session.

    avp$end_subutility_session (record_id, TRUE, validation_file_information, status);
    IF NOT status.normal THEN
      avp$close_validation_file (validation_file_information, ignore_status);
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

    avp$close_validation_file (validation_file_information, status);

    osp$disestablish_cond_handler;

  PROCEND avp$change_user_pf_space_limit;
?? TITLE := '    avp$check_for_served_family', EJECT ??
{ PURPOSE:
{   This interface is an internal interface for use by the AV project only.
{
{   This interfaces is used to determine if a family is served by another mainframe.

  PROCEDURE [XDCL, #GATE] avp$check_for_served_family
    (    family_name: string (* <= osc$max_name_size);
     VAR served_family: boolean);

     VAR
       local_family_name: ost$name,
       p_queue_interface_table: dft$p_queue_interface_table,
       queue_index: dft$queue_index,
       served_family_table_index: dft$served_family_table_index,
       server_mainframe_id: pmt$binary_mainframe_id,
       server_state: dft$server_state;

    local_family_name := family_name;
    ?IF NOT avc$compile_test_code THEN
      dfp$locate_served_family (local_family_name, served_family, served_family_table_index,
            server_mainframe_id, p_queue_interface_table,
            queue_index, server_state);
    ?ELSE
      served_family := FALSE;
    ?IFEND

  PROCEND avp$check_for_served_family;
?? TITLE := '[XDCL, #GATE] avp$clear_active_capabilities', EJECT ??

{ PURPOSE:
{   The purpose of this request is to deactivate all conditional capabilities
{   that are active for the current block in the block stack.

  PROCEDURE [XDCL, #GATE] avp$clear_active_capabilities
    (VAR status: ost$status);

    VAR
      current_block: ^clt$block;

    status.normal := TRUE;
    IF NOT jmp$system_job () THEN
      osp$set_status_abnormal ('JM', jme$must_be_system_job, 'avp$clear_active_capabilities', status);
      RETURN;
    IFEND;

    clp$find_current_block (current_block);
    current_block^.active_capabilities := $avt$conditional_capabilities [];

{ Re-evaluate the PF subsystem's administrator status for the executing task.

    pfp$reset_administrator_status;

  PROCEND avp$clear_active_capabilities;
?? TITLE := '    avp$close_validation_file', EJECT ??
{ PURPOSE:
{   This interface is an internal interface for use by the AV project only.
{
{   This interfaces is used to close a validation file.
{
{ NOTES:
{   The file utility information NEW_FILE field is updated to contain the value FALSE each time a validation
{   file is closed.
{
{   The NEW_FILE field is used to allow or disallow specification of encrypted passwords as input to a login
{   password update.  Encrypted passwords as input are allowed only on recreation from source.  (i.e.  When
{   recreating a validation file from source a new validation file is opened and the NEW_FILE field is TRUE so
{   encrypted passwords are accepted.  As soon as that validation file is closed encrypted passwords will no
{   longer be accepted.)

  PROCEDURE [XDCL, #GATE] avp$close_validation_file
    (VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      file_utility_information: ^avt$file_utility_information,
      ignore_status: ost$status,
      utility_information: ^avt$utility_information;

    status.normal := TRUE;

  /close_validation_file/
    BEGIN

{ Get the current file utility information.

      PUSH utility_information: [[REP 1 OF avt$file_utility_information]];
      RESET utility_information;
      avp$get_file_utility_info (utility_information, file_information, status);
      IF NOT status.normal THEN
        EXIT /close_validation_file/;
      IFEND;
      RESET utility_information;
      NEXT file_utility_information IN utility_information;
      IF file_utility_information = NIL THEN
        corrupted_sequence ('AVP$CLOSE_VALIDATION_FILE', 'NEW_FILE', 'FILE_UTILITY_INFORMATION', status);
        EXIT /close_validation_file/;
      IFEND;

{ Assign the new_file field a FALSE value

      IF file_utility_information^.new_file THEN
        file_utility_information^.new_file := FALSE;
        avp$change_file_utility_info (#SEQ (file_utility_information^), file_information, status);
      IFEND;
    END /close_validation_file/;

{ Close the validation file.

    IF status.normal THEN
      avp$close_template_file (file_information, status);
    ELSE
      avp$close_template_file (file_information, ignore_status);
    IFEND;

  PROCEND avp$close_validation_file;
?? TITLE := '    avp$display_pw_exp_warning', EJECT ??
{ PURPOSE:
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is called at login to display a warning message stating when the user's password will
{   expire.

  PROCEDURE [XDCL, #GATE] avp$display_pw_exp_warning
    (VAR status: ost$status);

    VAR
      change_date: ost$date_time,
      current_date_time: ost$date_time,
      date_format: ost$default_date_format,
      date_time: ost$date_time,
      date_time_to_format: clt$date_time,
      date_string: ost$string,
      increment: pmt$time_increment,
      job_mode: jmt$job_mode,
      login_password_attributes: array [1..1] of ost$name,
      login_password_exp_date: ost$date_time,
      login_password_exp_interval: pmt$time_increment,
      login_password_max_exp_interval: pmt$time_increment,
      login_password_exp_warning: pmt$time_increment,
      login_password_exp_chg_interval: pmt$time_increment,
      message_status: ost$status,
      number_of_login_password_attrib: avt$name_list_size,
      time_format: ost$default_time_format,
      time_string: ost$string;

    status.normal := TRUE;

{ Get the login password value for the current executing user.

    avp$get_login_password_value (avc$login_password, avc$user, login_password_exp_date,
          login_password_exp_interval, login_password_max_exp_interval, login_password_exp_warning,
          login_password_exp_chg_interval, change_date, login_password_attributes,
          number_of_login_password_attrib, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF login_password_exp_date.year <> avc$no_expiration_date THEN

{ If the password has an expiration date.

      IF login_password_exp_warning.day <> avc$unlimited_exp_interval THEN

{ If the expiration warning interval is not unlimited (always display) then calculate to determine the date
{ and time that expiration warning should start.

{ Get the current date and time.

        pmp$get_compact_date_time (current_date_time, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ The date and time that expiration warning should start is determined by subtracting the expiration warning
{ interval from the expiration date.
{ NOTE:  The expiration warning interval is stored as a negative date time increment.

        pmp$compute_date_time (login_password_exp_date, login_password_exp_warning, date_time, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ The time difference between the current date time and the date time to start displaying the exipration
{ warning is calculated.

        pmp$compute_date_time_increment (current_date_time, date_time, increment, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

{ If the expiration warning interval is unlimited (always display) OR it is at or past the date time to start
{ displaying the warning message (i.e.  the time difference calculated above is negative) then display the
{ message.

      IF ((login_password_exp_warning.day = avc$unlimited_exp_interval)) OR
            ((increment.year < 0) OR (increment.month < 0) OR (increment.day < 0) OR (increment.hour < 0) OR
            (increment.minute < 0) OR (increment.second < 0) OR (increment.millisecond < 0)) THEN
        osp$set_status_abnormal ('CL', cle$password_expiration_warning, '', message_status);
        pmp$get_default_date_time_form (date_format, time_format);
        date_time_to_format.value := login_password_exp_date;
        date_time_to_format.date_specified := TRUE;
        date_time_to_format.time_specified := TRUE;
        clp$convert_date_time_to_string (date_time_to_format, date_format.format_string, date_string, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        osp$append_status_parameter (osc$status_parameter_delimiter, date_string.value (1, date_string.size),
              message_status);
        clp$convert_date_time_to_string (date_time_to_format, time_format.format_string, time_string, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        osp$append_status_parameter (osc$status_parameter_delimiter, time_string.value (1, time_string.size),
              message_status);
        osp$generate_log_message ($pmt$ascii_logset[pmc$job_log], message_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        pmp$get_job_mode (job_mode, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF job_mode = jmc$interactive_connected THEN
          osp$generate_output_message (message_status, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND avp$display_pw_exp_warning;
?? TITLE := '    avp$end_subutility_session', EJECT ??
{ PURPOSE:
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to end an ADMINISTER_VALIDATIONS subutility session.

  PROCEDURE [XDCL, #GATE] avp$end_subutility_session
    (    record_id: ost$name;
         rewrite_record: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      data_record: ^avt$template_file_record,
      data_record_size: 0 .. avc$max_template_record_size,
      description_record: ^avt$template_file_record,
      description_record_size: 0 .. avc$max_template_record_size,
      description_record_name: ost$name,
      field_count: avt$field_count,
      field_value_list_entry: ^avt$field_value_list_entry,
      validation_record_info: ^avt$validation_record_info;

    status.normal := TRUE;

{ Find the information for this subutility session within the validation record information chain.

    find_validation_record_info (record_id, validation_record_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Update the validation file if specified.

    IF rewrite_record THEN
      PUSH data_record: [[REP avc$max_template_record_size OF cell]];
      RESET data_record;
      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;
      avp$read_data_record (validation_record_info^.key.value, avc$update_access, FALSE, data_record,
            data_record_size, description_record, description_record_size, description_record_name,
            field_count, file_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      avp$rewrite_data_record (validation_record_info^.key.value, TRUE, data_record, description_record,
            validation_record_info^.field_value_list, file_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Emit audit statistics for changed fields.

      IF avp$security_option_active (avc$vso_security_audit) THEN
        field_value_list_entry := validation_record_info^.field_value_list;
        WHILE field_value_list_entry <> NIL DO
          emit_chg_value_audit_statistic (description_record_name, file_information.file_name,
                validation_record_info^.key, field_value_list_entry^.field_name, status);
          field_value_list_entry := field_value_list_entry^.forward;
        WHILEND
      IFEND;
    IFEND;

{ Release the validation record information from the subuility information chain.

    avp$release_record_id (record_id, status);

  PROCEND avp$end_subutility_session;
?? TITLE := '    PMP$GET_ACCOUNT_PROJECT', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_account_project (VAR account: avt$account_name;
    VAR project: avt$project_name;
    VAR status: ost$status);

    status.normal := TRUE;

    account := avv$account_name;
    project := avv$project_name;

  PROCEND pmp$get_account_project;

?? TITLE := '    avp$get_command_table', EJECT ??
{ PURPOSE:
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used by ADMINISTER_VALIDATIONS to get the command table information stored in the record
{   utility information of the validation file.

  PROCEDURE [XDCL, #GATE] avp$get_command_table
    (    record_id: ost$name;
     VAR command_table_work_area: ^SEQ ( * );
     VAR command_table: ^clt$command_table;
     VAR status: ost$status);

    VAR
      command_table_entry: ^clt$command_table_entry,
      deleted_field_count: avt$field_count,
      deleted_field_names: ^array [1 .. * ] of ost$name,
      index: integer,
      number_of_entries: integer,
      record_utility_info_array: ^array [1 .. * ] of avt$record_utility_info_entry,
      validation_record_info: ^avt$validation_record_info,
      record_utility_info_header: ^avt$record_utility_info_header;

?? NEWTITLE := 'deleted_field', EJECT ??
{ PURPOSE
{   This function is used to determine if a field is a deleted field.

    FUNCTION deleted_field
      (    field_name: ost$name;
           deleted_field_names: ^array [1 .. * ] of ost$name;
           deleted_field_count: avt$field_count): boolean;

      VAR
        deleted_field_index: integer;

      deleted_field := FALSE;

    /find_deleted_field/
      FOR deleted_field_index := 1 TO deleted_field_count DO
        IF field_name < deleted_field_names^ [deleted_field_index] THEN
          EXIT /find_deleted_field/;
        ELSEIF field_name = deleted_field_names^ [deleted_field_index] THEN
          deleted_field := TRUE;
          EXIT /find_deleted_field/;
        IFEND;
      FOREND /find_deleted_field/;

    FUNCEND deleted_field;
?? OLDTITLE ??
?? NEWTITLE := 'hide_unnecessary_commands', EJECT ??
{ PURPOSE
{   This procedure is used to change the availability of a subcommand based on the executing user's authority
{   relative to the authority values of the validation field.

    PROCEDURE hide_unnecessary_commands
      (    field_name: ost$name;
           caller_authority: avt$validation_authority;
           description_record: ^avt$template_file_record;
       VAR command_table_entry: clt$command_table_entry);

      VAR
        default_value: avt$field_value,
        descriptive_text: ^avt$descriptive_text,
        field_utility_information: ^avt$field_utility_information,
        field_work_area: ^seq (*),
        local_status: ost$status,
        type_specification: avt$type_specification,
        utility_information: ^avt$utility_information;

      IF field_name <> osc$null_name THEN
        local_status.normal := TRUE;

{ Get the field description from the description record.

        PUSH field_work_area: [[REP 2 * avc$maximum_name_list_size OF avt$labeled_names]];
        RESET field_work_area;
        avp$get_field_description (field_name, description_record, field_work_area, type_specification,
              default_value, descriptive_text, utility_information, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;

{ Access the field utility information.

        RESET utility_information;
        NEXT field_utility_information IN utility_information;
        IF field_utility_information = NIL THEN
          RETURN;
        IFEND;

        IF command_table_entry.procedure_name = avc$display_field_value THEN
          IF field_utility_information^.display_authority > caller_authority THEN
            command_table_entry.availability := clc$advanced_usage_entry;
          IFEND;
        ELSE
          IF field_utility_information^.change_authority > caller_authority THEN
            command_table_entry.availability := clc$advanced_usage_entry;
          IFEND;
        IFEND;
      IFEND;

    PROCEND hide_unnecessary_commands;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Find the information for this subutility session within the validation record information chain.

    find_validation_record_info (record_id, validation_record_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Access the command table information within the record utility information.

    RESET validation_record_info^.record_utility_information;
    NEXT record_utility_info_header IN validation_record_info^.record_utility_information;
    IF record_utility_info_header = NIL THEN
      corrupted_sequence ('AVP$GET_COMMAND_TABLE', 'HEADER', 'RECORD_UTILITY_INFORMATION', status);
      RETURN;
    IFEND;
    NEXT record_utility_info_array: [1 .. record_utility_info_header^.number_of_entries] IN
          validation_record_info^.record_utility_information;
    IF record_utility_info_array = NIL THEN
      corrupted_sequence ('AVP$GET_COMMAND_TABLE', 'COMMAND_TABLE', 'RECORD_UTILITY_INFORMATION', status);
      RETURN;
    IFEND;

{ Retrieve a list of all deleted fields if there are any.

    PUSH deleted_field_names: [1 .. avc$maximum_field_count];
    avp$get_field_names (-$avt$field_kind_set [], TRUE, validation_record_info^.description_record,
          deleted_field_names^, deleted_field_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Build the command table to pass back to the caller

    RESET command_table_work_area;
    number_of_entries := 0;
    FOR index := 1 TO record_utility_info_header^.number_of_entries DO

{ Skip any deleted fields.

      IF NOT deleted_field (record_utility_info_array^ [index].field_name, deleted_field_names,
            deleted_field_count) THEN
        NEXT command_table_entry IN command_table_work_area;
        IF command_table_entry = NIL THEN
          corrupted_sequence ('AVP$GET_COMMAND_TABLE', 'COMMAND_TABLE', 'RECORD_UTILITY_INFORMATION', status);
          osp$set_status_abnormal ('AV', ave$corrupted_sequence, '', status);
          RETURN;
        IFEND;
        command_table_entry^ := record_utility_info_array^ [index].command_table_entry;
        hide_unnecessary_commands (record_utility_info_array^ [index].field_name,
              validation_record_info^.caller_authority, validation_record_info^.description_record,
              command_table_entry^);
        number_of_entries := number_of_entries + 1;
      IFEND;
    FOREND;

{ Allocate the correct size sequence in the command table work area.

    RESET command_table_work_area;
    NEXT command_table: [1 .. number_of_entries] IN command_table_work_area;
    IF command_table = NIL THEN
      corrupted_sequence ('AVP$GET_COMMAND_TABLE', 'COMMAND_TABLE', 'RECORD_UTILITY_INFORMATION', status);
      osp$set_status_abnormal ('AV', ave$corrupted_sequence, '', status);
      RETURN;
    IFEND;

  PROCEND avp$get_command_table;
?? TITLE := '    avp$get_field_name', EJECT ??
{ PURPOSE:
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used by ADMINISTER_VALIDATIONS for the purpose of determining the field name that is
{   associated with the subcommand that the user has entered.

  PROCEDURE [XDCL, #GATE] avp$get_field_name
    (    record_id: ost$name;
     VAR field_name: ost$name;
     VAR command_name: ost$name;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      index: integer,
      record_utility_info_array: ^array [1 .. * ] of avt$record_utility_info_entry,
      validation_record_info: ^avt$validation_record_info,
      record_utility_info_header: ^avt$record_utility_info_header;

    status.normal := TRUE;

{ Find the information for this subutility session within the validation record information chain.

    find_validation_record_info (record_id, validation_record_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Access the command table information within the record utility information.

    RESET validation_record_info^.record_utility_information;
    NEXT record_utility_info_header IN validation_record_info^.record_utility_information;
    IF record_utility_info_header = NIL THEN
      corrupted_sequence ('AVP$GET_FIELD_NAME', 'HEADER', 'RECORD_UTILITY_INFORMATION', status);
      osp$set_status_abnormal ('AV', ave$corrupted_sequence, '', status);
      RETURN;
    IFEND;
    NEXT record_utility_info_array: [1 .. record_utility_info_header^.number_of_entries] IN
          validation_record_info^.record_utility_information;
    IF record_utility_info_array = NIL THEN
      corrupted_sequence ('AVP$GET_COMMAND_TABLE', 'COMMAND_TABLE', 'RECORD_UTILITY_INFORMATION', status);
      RETURN;
    IFEND;

{ Retrieve the last command entered by the user.

    clp$find_current_block (block);

    command_name := block^.label;
    field_name := osc$null_name;

{ Find the field name associated with this command.

  /find_field_name/
    FOR index := 1 TO record_utility_info_header^.number_of_entries DO
      IF command_name = record_utility_info_array^ [index].command_table_entry.name THEN
        field_name := record_utility_info_array^ [index].field_name;
        EXIT /find_field_name/;
      IFEND;
    FOREND /find_field_name/;

    IF field_name = osc$null_name THEN
      osp$set_status_abnormal ('AV', ave$unable_to_find_field_name, command_name, status);
      RETURN;
    IFEND;

  PROCEND avp$get_field_name;
?? TITLE := '    avp$get_validation_field_kind', EJECT ??
{ PURPOSE:
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to return the field kind of a specified validation field name.

  PROCEDURE [XDCL, #GATE] avp$get_validation_field_kind
    (    field_name: ost$name;
         validation_record_name: ost$name;
     VAR field_kind: avt$field_kind;
     VAR validation_file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      descriptive_text: ^avt$descriptive_text,
      field_work_area: ^seq (*),
      type_specification: avt$type_specification,
      utility_information: ^avt$utility_information;

    status.normal := TRUE;

{ Push a work area to hold the description record.

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;

{ Retrieve the description record.

    avp$get_description_record (validation_record_name, description_record, validation_file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Retrieve the field description for the specified field from the description record.

    PUSH field_work_area: [[REP 2 * avc$maximum_name_list_size OF avt$labeled_names]];
    RESET field_work_area;
    avp$get_field_description (field_name, description_record, field_work_area, type_specification,
          default_value, descriptive_text, utility_information, status);
    IF status.normal OR (status.condition = ave$field_was_deleted) THEN
      field_kind := type_specification.kind;
    IFEND;

  PROCEND avp$get_validation_field_kind;
?? TITLE := '    avp$get_validation_field_names', EJECT ??
{ PURPOSE:
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to retrieve a list of active fields within a validation record, or a list of
{   inactive fields within a validation record.

  PROCEDURE [XDCL, #GATE] avp$get_validation_field_names
    (    validation_record_name: ost$name;
         desired_field_kinds: avt$field_kind_set;
         return_deleted_fields: boolean;
     VAR field_names: avt$name_list;
     VAR field_count: avt$field_count;
     VAR validation_file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      description_record: ^avt$template_file_record;

    status.normal := TRUE;

{ Push a work area to hold the description record.

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;

{ Retrieve the description record.

    avp$get_description_record (validation_record_name, description_record, validation_file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Extract the desired field names from the validation record.

    avp$get_field_names (desired_field_kinds, return_deleted_fields, description_record, field_names,
          field_count, status);

  PROCEND avp$get_validation_field_names;
?? TITLE := '    avp$open_validation_file', EJECT ??
{ PURPOSE:
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to open a validation file.  If the validation file does not previously exist an
{   empty one will be created.  If the validation file exists and has a password then the password is
{   verified.  If a new password is specified the new password is updated.  (if the caller has the required
{   authority)

  PROCEDURE [XDCL, #GATE] avp$open_validation_file
    (    file_reference: fst$file_reference;
         old_password: ^ost$name;
         new_password: ^ost$name;
         create_file: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      validation_file_type: avt$validation_file_type,
      caller_id: ost$caller_identifier,
      family_from_path: ost$family_name,
      file_path: fst$path,
      file_path_size: fst$path_size,
      ignore_status: ost$status;

?? NEWTITLE := 'get_val_file_path_info', EJECT ??

{ PURPOSE:
{   This procedure creates a new validation file.

    PROCEDURE get_val_file_path_info
      (    file_reference: fst$file_reference;
       VAR family_from_path: ost$family_name;
       VAR validation_file_type: avt$validation_file_type;
       VAR file_path: fst$path;
       VAR file_path_size: fst$path_size;
       VAR status: ost$status);

      VAR
        evaluated_file_reference: fst$evaluated_file_reference,
        executing_id: ost$user_identification;

      status.normal := TRUE;

      validation_file_type := avc$vft_other;

{ Determine the family name and user name from the specified path.

      clp$evaluate_file_reference (file_reference, $clt$file_ref_parsing_options[], TRUE,
            evaluated_file_reference, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_file_ref_to_string (evaluated_file_reference, FALSE, file_path, file_path_size, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF evaluated_file_reference.number_of_path_elements >= 3 THEN
        family_from_path := fsp$path_element (^evaluated_file_reference, 1)^;
      ELSE
        family_from_path := osc$null_name;
      IFEND;

      IF (evaluated_file_reference.number_of_path_elements = 3) AND
            (fsp$path_element (^evaluated_file_reference, 2)^ = jmc$system_user) AND
            (fsp$path_element (^evaluated_file_reference, 3)^ = avc$validation_file_name) THEN
        pmp$get_user_identification (executing_id, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF executing_id.family = family_from_path THEN
          validation_file_type := avc$vft_active_system;
        ELSE
          validation_file_type := avc$vft_system;
        IFEND;
      IFEND;

      PROCEND get_val_file_path_info;
?? OLDTITLE ??
?? NEWTITLE := 'create_validation_file', EJECT ??

{ PURPOSE:
{   This procedure creates a new validation file.

    PROCEDURE create_validation_file
      (    file_reference: fst$file_reference;
           new_password: ^ost$name;
           family_from_path: ost$family_name;
           validation_file_type: avt$validation_file_type;
       VAR file_information: avt$template_file_information;
       VAR status: ost$status);

      VAR
        audit_information: sft$audit_information,
        evaluated_file_reference: fst$evaluated_file_reference,
        file_utility_information: ^avt$file_utility_information,
        group: pft$group,
        ignore_status: ost$status,
        new_validation_file_password: avt$password,
        path: ^pft$path;

        status.normal := TRUE;

{ Create the validation file.

        avp$open_template_file (file_reference, TRUE, file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      /new_file_open/
        BEGIN

{ If it is a system validation file put a permit on it.

          IF validation_file_type >= avc$vft_system THEN
            PUSH path: [1 .. 3];
            path^ [1] := family_from_path;
            path^ [2] := jmc$system_user;
            path^ [3] := avc$validation_file_name;
            group.group_type := pfc$public;
            pfp$permit (path^, group, $pft$permit_selections [pfc$read, pfc$shorten, pfc$append, pfc$modify],
                  $pft$share_selections [pfc$read, pfc$shorten, pfc$append, pfc$modify], osc$null_name,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

{ Initialize the file utility information.

          PUSH file_utility_information;
          file_utility_information^.new_file := TRUE;
          IF (new_password = NIL) OR (new_password^ = osc$null_name) THEN
            file_utility_information^.password := osc$null_name;
          ELSE
            avp$encrypt_password (osc$null_name, new_password^, new_validation_file_password, status);
            IF NOT status.normal THEN
              EXIT /new_file_open/;
            IFEND;
            file_utility_information^.password := new_validation_file_password;
          IFEND;
          file_utility_information^.version := avc$validation_file_version;
          avp$change_file_utility_info (#SEQ (file_utility_information^), file_information, status);
          IF NOT status.normal THEN
            EXIT /new_file_open/;
          IFEND;

{ Initialize the system defined validation records.

          initialize_validation_records (file_information, status);
          IF NOT status.normal THEN
            EXIT /new_file_open/;
          IFEND;

{ Initialize the system defined validation fields.

          initialize_validation_fields (family_from_path, file_information, status);
          IF NOT status.normal THEN
            EXIT /new_file_open/;
          IFEND;
        END /new_file_open/;

{ Emit an audit statistic if a security password was assigned to the new validation file.

        IF (avp$security_option_active (avc$vso_security_audit)) AND
              (file_utility_information^.password <> osc$null_name) THEN
          audit_information.audited_operation := sfc$ao_val_change_security_pw;
          audit_information.change_security_password.validation_file_p := ^file_information.file_name;
          sfp$emit_audit_statistic (audit_information, status);
        IFEND;

        IF NOT status.normal THEN
          avp$close_template_file (file_information, ignore_status);
          RETURN;
        IFEND;
      PROCEND create_validation_file;
?? OLDTITLE ??
?? NEWTITLE := 'verify_security_password', EJECT ??

{ PURPOSE:
{   This procedure verifies and updates the password on a validation file.

      PROCEDURE verify_security_password
        (    old_password: ^ost$name;
             new_password: ^ost$name;
         VAR file_information: avt$template_file_information;
         VAR status: ost$status);

      VAR
        audit_information: sft$audit_information,
        file_utility_information: ^avt$file_utility_information,
        new_validation_file_password: avt$password,
        old_validation_file_password: avt$password,
        temp_validation_file_password: avt$password,
        utility_information: ^avt$utility_information;

        status.normal := TRUE;

{ Retrieve the current password from the file utility information.

        PUSH utility_information: [[REP 1 OF avt$file_utility_information]];
        RESET utility_information;
        avp$get_file_utility_info (utility_information, file_information, status);
        RESET utility_information;
        NEXT file_utility_information IN utility_information;
        IF file_utility_information = NIL THEN
          corrupted_sequence ('AVP$OPEN_VALIDATION_FILE', 'PASSWORD', 'FILE_UTILITY_INFORMATION', status);
          RETURN;
        IFEND;

{ If a password exists for the file verify the caller has specified the correct password.

      /verify_password/
        BEGIN
          IF file_utility_information^.password <> osc$null_name THEN
            IF old_password <> NIL THEN
              avp$encrypt_password (osc$null_name, old_password^, old_validation_file_password, status);
              IF NOT status.normal THEN
                EXIT /verify_password/;
              IFEND;
              IF old_validation_file_password <> file_utility_information^.password THEN
                temp_validation_file_password := old_validation_file_password;
                avp$old_encrypt_password (osc$null_name, old_password^, old_validation_file_password, status);
                IF NOT status.normal THEN
                  EXIT /verify_password/;
                IFEND;
                IF old_validation_file_password <> file_utility_information^.password THEN
                  osp$set_status_abnormal ('AV', ave$old_password_not_valid, 'validation file', status);
                  EXIT /verify_password/;
                IFEND;

{ If the current password was not encrypted with the current algorithm and a new password was not
{ specified, then encrypt the current password with the current algorithm.

                IF new_password = NIL THEN
                  file_utility_information^.password := temp_validation_file_password;
                  avp$change_file_utility_info (#SEQ(file_utility_information^), file_information, status);
                  IF NOT status.normal THEN
                    EXIT /verify_password/;
                  IFEND;
                IFEND;
              IFEND;
            ELSEIF new_password = NIL THEN
              osp$set_status_abnormal ('AV', ave$must_specify_password, '', status);
              EXIT /verify_password/;
            ELSEIF NOT avp$system_administrator () THEN
              osp$set_status_abnormal ('AV', ave$can_not_set_new_without_old, '', status);
              EXIT /verify_password/;
            IFEND;
          ELSE
            IF old_password <> NIL THEN
              osp$set_status_abnormal ('AV', ave$no_password_on_file, '', status);
              EXIT /verify_password/;
            IFEND;
          IFEND;

{ If a new password was specified update it.

          IF new_password <> NIL THEN
            IF new_password^ = osc$null_name THEN
              file_utility_information^.password := osc$null_name;
            ELSE
              avp$encrypt_password (osc$null_name, new_password^, new_validation_file_password, status);
              IF NOT status.normal THEN
                EXIT /verify_password/;
              IFEND;
              file_utility_information^.password := new_validation_file_password;
            IFEND;
            avp$change_file_utility_info (#SEQ (file_utility_information^), file_information, status);
          IFEND;
         END /verify_password/;

{ Emit audit statistic if the security password was changed.

         IF (avp$security_option_active (avc$vso_security_audit)) AND (new_password <> NIL) THEN
           IF old_password = NIL THEN
             audit_information.audited_operation := sfc$ao_val_force_security_pw;
             audit_information.force_security_password.validation_file_p := ^file_information.file_name;
           ELSE
             audit_information.audited_operation := sfc$ao_val_change_security_pw;
             audit_information.change_security_password.validation_file_p := ^file_information.file_name;
           IFEND;
           sfp$emit_audit_statistic (audit_information, status);
         IFEND;

      PROCEND verify_security_password;
?? OLDTITLE, EJECT ??
    #CALLER_ID (caller_id);

    status.normal := TRUE;

    get_val_file_path_info (file_reference, family_from_path, validation_file_type, file_path, file_path_size,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify ability to access an alternate family's validation file.

    ?IF NOT avc$compile_test_code THEN
    IF (caller_id.ring > osc$tsrv_ring) AND (NOT avp$system_administrator ()) AND
          (validation_file_type <> avc$vft_active_system) THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;
    ?IFEND

    avp$open_template_file (file_path (1, file_path_size), FALSE, file_information, status);
    IF (NOT status.normal) THEN
      IF ((status.condition = ame$file_not_known) OR (status.condition = pfe$unknown_permanent_file) OR
            (status.condition = pfe$unknown_cycle)) AND (create_file) THEN
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;

      ?IF NOT avc$compile_test_code THEN
      IF (caller_id.ring > osc$tsrv_ring) AND (NOT avp$system_administrator ()) THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        RETURN;
      IFEND;
      ?IFEND

      create_validation_file (file_path (1, file_path_size), new_password, family_from_path,
            validation_file_type, file_information, status);
    ELSE

{ If the call was made by a system or family administrator, from above ring 3, check the security password.

      IF (caller_id.ring > osc$tsrv_ring) AND
            (avp$system_administrator () OR avp$family_administrator ()) THEN
        verify_security_password (old_password, new_password, file_information, status);
        IF NOT status.normal THEN
          avp$close_template_file (file_information, ignore_status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND avp$open_validation_file;
?? TITLE := '    avp$open_system_validation_file', EJECT ??
{ PURPOSE:
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to open a validation file.  This interface may only be used to open an existing
{   validation file.

  PROCEDURE [XDCL] avp$open_system_validation_file
    (    family: ost$family_name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      family_name_size: 0 .. osc$max_name_size,
      file_path: fst$path;

    status.normal := TRUE;

    family_name_size := clp$trimmed_string_size (family);
    file_path := ':';
    file_path (2, *) := family;
    ?IF NOT avc$compile_test_code THEN
      file_path (family_name_size + 2, *) := '.$SYSTEM.$VALIDATIONS';
    ?ELSE
      file_path := '$USER.$VALIDATIONS';
    ?IFEND
    avp$open_template_file (file_path (1, family_name_size + 23), FALSE, file_information, status);

  PROCEND avp$open_system_validation_file;
?? TITLE := '    avp$prevalidate_job', EJECT ??
*copyc avh$prevalidate_job
{ NOTES:
{
{   The following items are always validated:
{     The user is validated for access to the family.
{     The user's password is checked for expiration.
{
{   The following items are optional validations:
{     Password. (In it's unecrypted form)
{     Account membership if running at account level.
{     Account or Project membership if running at project level.
{     Job Class.
{     Job execution ring.
{     Job limits.
{     Required capabilites.
{
{   The following items may be returned:
{     Job class batch and interactive defaults.
{     The list of valid job classes.
{     Job limit values.
{     Capabilities.
{     Encrypted Password.
{
{   This interface must never be GATED above ring 3 because of the security problem that would
{   result from the feature of returning the encrypted password.

  PROCEDURE [XDCL] avp$prevalidate_job
    (    user_name: ost$user_name;
         family_name: ost$family_name;
         validation_attributes: ^avt$validation_items;
         default_attributes: ^avt$validation_items;
     VAR status: ost$status);

    VAR
      data_size_to_send_to_server: dft$send_data_size,
      p_data_received_from_server: dft$p_receive_data,
      p_data_to_send_to_server: dft$p_send_data,
      p_params_received_from_server: dft$p_receive_parameters,
      p_params_to_send_to_server: dft$p_send_parameters,
      params_size_to_send_to_server: dft$send_parameter_size,
      queue_entry_location: dft$rpc_queue_entry_location,
      server_locator: dft$server_location,
      ignore_status: ost$status,
      validation_level: avt$validation_level;

?? TITLE := '      client_prevalidate_job', EJECT ??
    PROCEDURE client_prevalidate_job
      (    validation_level: avt$validation_level;
           user_name: ost$user_name;
           family_name: ost$family_name;
           validation_attributes: ^avt$validation_items;
           default_attributes: ^avt$validation_items;
       VAR p_params_to_send_to_server: dft$p_send_parameters;
       VAR p_data_to_send_to_server: dft$p_send_data;
       VAR params_size_to_send_to_server: dft$send_parameter_size;
       VAR data_size_to_send_to_server: dft$send_data_size;
       VAR p_params_received_from_server: dft$p_receive_parameters;
       VAR p_data_received_from_server: dft$p_receive_data;
       VAR status: ost$status);

       VAR
           ignore_recovery_occured: boolean;

?? TITLE := '        build_info_to_send_to_server', EJECT ??
      PROCEDURE build_info_to_send_to_server
        (    validation_level: avt$validation_level;
             user_name: ost$user_name;
             family_name: ost$family_name;
             validation_attributes: ^avt$validation_items;
             default_attributes: ^avt$validation_items;
         VAR p_params_to_send_to_server: dft$p_send_parameters;
         VAR p_data_to_send_to_server: dft$p_send_data;
         VAR params_size_to_send_to_server: dft$send_parameter_size;
         VAR data_size_to_send_to_server: dft$send_data_size);

        VAR
          send_default_attributes: ^avt$validation_items,
          send_validation_attributes: ^avt$validation_items,
          server_prevalidate_job_input: ^avt$server_prevalidate_job_in;

        params_size_to_send_to_server := 0;
        data_size_to_send_to_server := 0;

  { Copy the parameters to be used.

        NEXT server_prevalidate_job_input IN p_params_to_send_to_server;
        server_prevalidate_job_input^.validation_level := validation_level;
        server_prevalidate_job_input^.user_name := user_name;
        server_prevalidate_job_input^.family_name := family_name;

  { Copy the validation attributes to be used.

        IF validation_attributes = NIL THEN
          server_prevalidate_job_input^.number_of_val_attributes := 0;
        ELSE
          server_prevalidate_job_input^.number_of_val_attributes := UPPERBOUND (validation_attributes^);
          NEXT send_validation_attributes: [1 .. UPPERBOUND (validation_attributes^)] IN
                p_params_to_send_to_server;
          send_validation_attributes^ := validation_attributes^;
        IFEND;

  { Copy the default attributes requested.

        IF default_attributes = NIL THEN
          server_prevalidate_job_input^.number_of_def_attributes := 0;
        ELSE
          server_prevalidate_job_input^.number_of_def_attributes := UPPERBOUND (default_attributes^);
          NEXT send_default_attributes: [1 .. UPPERBOUND (default_attributes^)] IN
                p_params_to_send_to_server;
          send_default_attributes^ := default_attributes^;
        IFEND;

        params_size_to_send_to_server := i#current_sequence_position (p_params_to_send_to_server);

      PROCEND build_info_to_send_to_server;
  ?? TITLE := '        extract_info_sent_from_server', EJECT ??
      PROCEDURE extract_info_sent_from_server
        (    default_attributes: ^avt$validation_items;
         VAR p_params_received_from_server: dft$p_receive_parameters;
         VAR p_data_received_from_server: dft$p_receive_data);

        VAR
          get_default_attributes: ^avt$validation_items,
          get_valid_job_classes: ^array [1 .. * ] of ost$name,
          index: integer,
          index2: integer,
          item_index: integer,
          label: ^ost$name,
          name: ^ost$name,
          number_of_labeled_names: ^integer,
          number_of_names: ^integer;

        IF default_attributes <> NIL THEN
          NEXT get_default_attributes: [1 .. UPPERBOUND (default_attributes^)]
                IN p_params_received_from_server;
          FOR item_index := 1 TO UPPERBOUND (get_default_attributes^) DO
            IF get_default_attributes^ [item_index].key = avc$valid_job_classes_key THEN
              get_default_attributes^ [item_index].job_classes :=
                    default_attributes^ [item_index].job_classes;
              NEXT get_valid_job_classes: [1 .. UPPERBOUND (default_attributes^ [item_index].
                    job_classes^)] IN p_data_received_from_server;
              FOR index := 1 TO  UPPERBOUND (default_attributes^ [item_index].job_classes^) DO
                default_attributes^ [item_index].job_classes^ [index] := get_valid_job_classes^ [index];
              FOREND;
            ELSEIF get_default_attributes^ [item_index].key = avc$labeled_names_key THEN
              get_default_attributes^ [item_index].work_area:=
                    default_attributes^ [item_index].work_area;

              NEXT number_of_labeled_names IN p_data_received_from_server;
              NEXT get_default_attributes^ [item_index].labeled_names: [1 .. number_of_labeled_names^] IN
                    get_default_attributes^ [item_index].work_area;
              FOR index := 1 TO number_of_labeled_names^ DO
                NEXT label IN p_data_received_from_server;
                NEXT get_default_attributes^ [item_index].labeled_names^ [index].label IN
                    get_default_attributes^ [item_index].work_area;
                get_default_attributes^ [item_index].labeled_names^ [index].label^ := label^;
                NEXT number_of_names IN p_data_received_from_server;
                NEXT get_default_attributes^ [item_index].labeled_names^ [index].names:
                      [1 .. number_of_names^] IN get_default_attributes^ [item_index].work_area;
                FOR index2 := 1 TO number_of_names^ DO
                  NEXT name IN p_data_received_from_server;
                  get_default_attributes^ [item_index].labeled_names^ [index].names^ [index2] := name^;
                FOREND;
              FOREND;
            IFEND;
            default_attributes^ [item_index] := get_default_attributes^ [item_index];
          FOREND;
        IFEND;

      PROCEND extract_info_sent_from_server;
  ?? OLDTITLE, EJECT ??

{ Build the parameters to send to the server.
{ This repeat loop will execute at most twice.

    REPEAT
      build_info_to_send_to_server (validation_level, user_name, family_name, validation_attributes,
            default_attributes, p_params_to_send_to_server, p_data_to_send_to_server,
            params_size_to_send_to_server, data_size_to_send_to_server);

{ Make the remote procedure call.

      dfp$send_remote_procedure_call (queue_entry_location, dfc$prevalidate_job,
            params_size_to_send_to_server, data_size_to_send_to_server, p_params_received_from_server,
            p_data_received_from_server, status);
      IF NOT status.normal AND (status.condition = dfe$job_needs_recovery) THEN
        dfp$end_ch_remote_proc_call (queue_entry_location, ignore_status);
        dfp$check_job_recovery (ignore_recovery_occured);
        dfp$begin_ch_remote_proc_call (server_locator, FALSE, queue_entry_location,
            p_params_to_send_to_server, p_data_to_send_to_server, ignore_status);
        IF NOT ignore_status.normal THEN
          status := ignore_status;
        IFEND;
      IFEND;

{ Extract the information sent by the server.

     IF status.normal THEN
        extract_info_sent_from_server (default_attributes, p_params_received_from_server,
              p_data_received_from_server);
     IFEND;
    UNTIL status.normal OR (status.condition <> dfe$job_needs_recovery);

    PROCEND client_prevalidate_job;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT avp$prevalidate_job;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    validation_level := avp$validation_level ();

    server_locator.server_location_selector := dfc$family_name;
    server_locator.family_name := family_name;
    ?IF avc$compile_test_code THEN
      status.normal := FALSE;
      status.condition := dfe$family_not_served;
    ?ELSE
    dfp$begin_ch_remote_proc_call (server_locator, FALSE, queue_entry_location, p_params_to_send_to_server,
          p_data_to_send_to_server, status);
    ?IFEND
    IF status.normal THEN

      client_prevalidate_job (validation_level, user_name, family_name, validation_attributes,
            default_attributes, p_params_to_send_to_server, p_data_to_send_to_server,
            params_size_to_send_to_server, data_size_to_send_to_server, p_params_received_from_server,
            p_data_received_from_server, status);

      IF status.normal THEN
        dfp$end_ch_remote_proc_call (queue_entry_location, status);
      ELSE
        dfp$end_ch_remote_proc_call (queue_entry_location, ignore_status);
      IFEND;

{ Prevalidate was done on the server so return.

      RETURN;
    ELSEIF status.condition = dfe$family_not_served THEN
      status.normal := TRUE;
      prevalidate_job (validation_level, user_name, family_name, validation_attributes,
            default_attributes, status);
    IFEND;

  PROCEND avp$prevalidate_job;
?? TITLE := '    avp$release_record_id', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to clear a validation record information entry
{ from the chain.
{
{ DESIGN:
{
{   The RECORD_ID is used to search the chain and when a match is found the
{ task private data is FREEed and the associated temporary scratch segment is
{ released.
{

  PROCEDURE [XDCL, #GATE] avp$release_record_id
    (    record_id: ost$name;
     VAR status: ost$status);

    VAR
      validation_record_info: ^avt$validation_record_info;

    status.normal := TRUE;

{ Find the information within the validation record information chain.

    find_validation_record_info (record_id, validation_record_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Remove the entry from the validation record information chain.

    IF validation_record_info^.backward <> NIL THEN
      validation_record_info^.backward^.forward := validation_record_info^.forward;
    ELSE
      avv$validation_record_info := validation_record_info^.forward;
    IFEND;
    IF validation_record_info^.forward <> NIL THEN
      validation_record_info^.forward^.backward := validation_record_info^.backward;
    IFEND;

{ If a scratch segment was created then delete it.

    IF validation_record_info^.work_area.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (validation_record_info^.work_area, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Free the data record work area in task private.

    IF validation_record_info^.data_record <> NIL THEN
      FREE validation_record_info^.data_record IN osv$task_private_heap^;
    IFEND;

{ Free the description record work area in task private.

    IF validation_record_info^.description_record <> NIL THEN
      FREE validation_record_info^.description_record IN osv$task_private_heap^;
    IFEND;

{ Free the validation record info work area in task private.

    FREE validation_record_info IN osv$task_private_heap^;

  PROCEND avp$release_record_id;
?? TITLE := '    avp$reorganize_validation_file', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to restructure the validation file.
{
*copyc avh$reorganize_validation_file
  PROCEDURE [XDCL, #GATE] avp$reorganize_validation_file
    (    old_file_name: fst$file_reference;
         new_file_name: fst$file_reference;
     VAR status: ost$status);

    status.normal := TRUE;
    osp$verify_system_privilege;
    avp$restructure_template_file (old_file_name, new_file_name, status);

  PROCEND avp$reorganize_validation_file;
?? TITLE := '    avp$ring_min', EJECT ??
*copyc avh$ring_min

  FUNCTION [XDCL, #GATE] avp$ring_min: ost$ring;

    IF (avp$system_administrator()) THEN
      avp$ring_min := osc$tsrv_ring;
    ELSE
      avp$ring_min := avv$minimum_ring;
    IFEND;

  FUNCEND avp$ring_min;
?? TITLE := '    avp$ring_nominal', EJECT ??
*copyc avh$ring_nominal

  FUNCTION [XDCL, #GATE] avp$ring_nominal: ost$ring;

    avp$ring_nominal := avv$nominal_ring;

  FUNCEND avp$ring_nominal;
?? TITLE := '    avp$set_validation_level', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to set the system wide validation level.
{
{ DESIGN:
{
{   This interface may only be called by a system administrator.
{
{   The validation level is stored in a system constant.
{

  PROCEDURE [XDCL, #GATE] avp$set_validation_level
    (    validation_level: avt$validation_level;
     VAR status: ost$status);

    status.normal := TRUE;

{ Verify system administration capability.

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Store the specified validation level in the system constant.

    ?IF avc$compile_test_code THEN
      avv$validation_level := $INTEGER (validation_level);
    ?ELSE
      syp$store_system_constant (avc$validation_level_const_name, 0, $INTEGER (validation_level), status);
    ?IFEND

  PROCEND avp$set_validation_level;
?? TITLE := '    avp$capability_active', EJECT ??
*copyc avh$capability_active

  FUNCTION [XDCL, #GATE, UNSAFE] avp$capability_active
    (    capability: avt$conditional_capability) : boolean;

    VAR
      current_block: ^clt$block;

    ?IF avc$compile_test_code THEN
      avp$capability_active := capability IN avv$active_sou_capabilities;
    ?ELSE
      clp$find_current_block (current_block);
      avp$capability_active := capability IN current_block^.active_capabilities;
    ?IFEND

  FUNCEND avp$capability_active;
?? TITLE := '    avp$replace_total_limits', EJECT ??
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to replace the values for total limit for a given
{ accumulating limit type field.
{
{ DESIGN:

  PROCEDURE [XDCL, #GATE] avp$replace_total_limits
    (    accum_limit_field_name: ost$name;
     VAR limit_update_info_array: ^array [1 .. * ] of avt$total_limit_update_record;
     VAR status: ost$status);

    VAR
      account_limit_applies: boolean,
      account_member_limit_applies: boolean,
      current_entry: integer,
      data_record: ^avt$template_file_record,
      default_value: avt$field_value,
      description: ost$string,
      description_record: ^avt$template_file_record,
      family_name: ost$family_name,
      field_utility_information: avt$field_utility_information,
      field_value_list: avt$field_value_list_entry,
      high_value_key: avt$validation_key,
      ignore_status: ost$status,
      limit_update_key: avt$validation_key,
      previous_family_name: ost$family_name,
      project_limit_applies: boolean,
      project_member_limit_applies: boolean,
      served_family: boolean,
      size: integer,
      type_specification: avt$type_specification,
      user_limit_applies: boolean,
      validation_file_information: avt$template_file_information,
      validation_file_key: avt$validation_key,
      validation_level: avt$validation_level;

?? NEWTITLE := 'sort_total_limit_update_info', EJECT ??

{ PURPOSE:
{   This procedure sorts the limit update records into the same order as the validation file.
{
{ DESIGN:
{   This sort is the "quick sort" algorithm described in:
{     The Art of Computer Programing, Volumne 3, by Knuth, published by Addison Wesley.

    PROCEDURE sort_total_limit_update_info
      (    total_limit_update_info_array: ^array [1 .. * ] of avt$total_limit_update_record;
       VAR status: ost$status);

      TYPE
        sort_stack_entry = record
          left_index: integer,
          right_index: integer,
          next_entry: ^sort_stack_entry,
        recend;

      VAR
        current_sort_stack_entry: ^sort_stack_entry,
        number_of_records: integer,
        right_index: integer,
        left_index: integer,
        forward_index: integer,
        record_to_insert: avt$total_limit_update_record;
?? EJECT ??

{ PURPOSE:
{   This procedure partitions the subfile being sorted into two subfiles. One which is all less than
{   a given entry in the file and one which is all greater than that entry.  These subfiles are
{   placed on the stack to be sorted later.

      PROCEDURE [INLINE] partition_into_subfiles
        (    left_index: integer;
             right_index: integer;
         VAR current_sort_stack_entry: ^sort_stack_entry);

        VAR
          current_left_index: integer,
          current_right_index: integer,
          subfile_partitioned: boolean;

        subfile_partitioned := FALSE;
        current_left_index := left_index;
        current_right_index := right_index;

{ An entry from within the subfile is picked, and its correct position is searched for within the file.
{ The midpoint entry within the subfile is picked to guard against the worst case condition of the file
{ already being in order.

        record_to_insert := total_limit_update_info_array^ [((right_index - left_index) DIV 2) + left_index];
        total_limit_update_info_array^ [((right_index - left_index) DIV 2) + left_index] :=
              total_limit_update_info_array^ [left_index];

        REPEAT
          WHILE (current_right_index >= 1) AND
                ((record_to_insert.family_name < total_limit_update_info_array^ [current_right_index].
                family_name) OR ((record_to_insert.family_name =
                total_limit_update_info_array^ [current_right_index].family_name) AND
                (record_to_insert.validation_key.value < total_limit_update_info_array^ [current_right_index].
                validation_key.value))) DO
            current_right_index := current_right_index - 1;
          WHILEND;
          IF current_right_index <= current_left_index THEN
            total_limit_update_info_array^ [current_left_index] := record_to_insert;
            put_on_stack (left_index, current_left_index, right_index, current_sort_stack_entry);
            subfile_partitioned := TRUE;
          ELSE
            total_limit_update_info_array^ [current_left_index] :=
                  total_limit_update_info_array^ [current_right_index];
            current_left_index := current_left_index + 1;
            WHILE (current_left_index <= number_of_records) AND
                  ((total_limit_update_info_array^ [current_left_index].family_name <
                  record_to_insert.family_name) OR ((total_limit_update_info_array^ [current_left_index].
                  family_name = record_to_insert.family_name) AND
                  (total_limit_update_info_array^ [current_left_index].validation_key.value <
                  record_to_insert.validation_key.value))) DO
              current_left_index := current_left_index + 1;
            WHILEND;
            IF current_right_index <= current_left_index THEN
              total_limit_update_info_array^ [current_right_index] := record_to_insert;
              put_on_stack (left_index, current_right_index, right_index, current_sort_stack_entry);
              subfile_partitioned := TRUE;
            ELSE
              total_limit_update_info_array^ [current_right_index] :=
                    total_limit_update_info_array^ [current_left_index];
              current_right_index := current_right_index - 1;
            IFEND;
          IFEND;
        UNTIL subfile_partitioned;

      PROCEND partition_into_subfiles;
?? EJECT ??

{ PURPOSE:
{   This procedure places an entry of left and right indices for a subfile on to a stack so that the
{   subfile can be sorted later.

      PROCEDURE [INLINE] put_on_stack
        (    left_index: integer;
             insert_index: integer;
             right_index: integer;
         VAR current_sort_stack_entry: ^sort_stack_entry);

        VAR
          new_sort_stack_entry: ^sort_stack_entry;

{ If the subfile is of less than 2 elements (1 or 0) then don't bother putting it on the stack.

        IF (right_index - insert_index) > 1 THEN
          PUSH new_sort_stack_entry;
          new_sort_stack_entry^.left_index := insert_index + 1;
          new_sort_stack_entry^.right_index := right_index;
          new_sort_stack_entry^.next_entry := current_sort_stack_entry;
          current_sort_stack_entry := new_sort_stack_entry;
        IFEND;

        IF (insert_index - left_index) > 1 THEN
          PUSH new_sort_stack_entry;
          new_sort_stack_entry^.left_index := left_index;
          new_sort_stack_entry^.right_index := insert_index - 1;
          new_sort_stack_entry^.next_entry := current_sort_stack_entry;
          current_sort_stack_entry := new_sort_stack_entry;
        IFEND;

      PROCEND put_on_stack;
?? EJECT ??

{ PURPOSE:
{   This procedure is used sort a subfile of M (9 for this implementation) or less records.  This is done
{   because straight insertion is faster than "quick sorting" for small subfiles.

      PROCEDURE insertion_sort_subfile
        (    left_index: integer;
             right_index: integer);

        FUNCTION insert_here: boolean;

          insert_here := (total_limit_update_info_array^ [backward_index].family_name <
                record_to_insert.family_name) OR ((total_limit_update_info_array^ [backward_index].
                family_name = record_to_insert.family_name) AND
                (total_limit_update_info_array^ [backward_index].validation_key.value <
                record_to_insert.validation_key.value));
        FUNCEND insert_here;

        VAR
          forward_index: integer,
          backward_index: integer,
          record_to_insert: avt$total_limit_update_record;

        FOR forward_index := (left_index + 1) TO right_index DO
          backward_index := forward_index - 1;
          record_to_insert := total_limit_update_info_array^ [forward_index];

        /find_insert_position/
          REPEAT
            IF insert_here () THEN
              EXIT /find_insert_position/;
            ELSE
              total_limit_update_info_array^ [backward_index + 1] :=
                    total_limit_update_info_array^ [backward_index];
              backward_index := backward_index - 1;
            IFEND;
          UNTIL backward_index = (left_index - 1);
          total_limit_update_info_array^ [backward_index + 1] := record_to_insert;

        FOREND;
      PROCEND insertion_sort_subfile;
?? EJECT ??
      status.normal := TRUE;

      number_of_records := UPPERBOUND (total_limit_update_info_array^);
      PUSH current_sort_stack_entry;
      current_sort_stack_entry^.left_index := 1;
      current_sort_stack_entry^.right_index := number_of_records;
      current_sort_stack_entry^.next_entry := NIL;

      WHILE current_sort_stack_entry <> NIL DO
        left_index := current_sort_stack_entry^.left_index;
        right_index := current_sort_stack_entry^.right_index;
        current_sort_stack_entry := current_sort_stack_entry^.next_entry;

        IF (right_index - left_index) < 9 THEN
          insertion_sort_subfile (left_index, right_index);
        ELSE
          partition_into_subfiles (left_index, right_index, current_sort_stack_entry);
        IFEND;
      WHILEND;

    PROCEND sort_total_limit_update_info;
?? OLDTITLE ??
?? NEWTITLE := '      get_next_update_entry', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used to get a summarized record of all of the
{ update records starting at a given entry in the array whose keys
{ are the same.  The size that is returned is the total summed size from those
{ records.
{
{ DESIGN:
{
{   The current entry parameter returns the position of the last entry in the
{ array that has the returned key value.
{
{   If a family break occurs a high value key is returned to signify that an
{ "end of information" for that family has been found.  In which case the
{ current entry parameter is unchanged so that the next entry found will be the
{ first entry for the new family.
{
{   If the end of the array entries is found a null family name is returned
{ to signify that no more update information is available.
{

    PROCEDURE get_next_update_entry
      (    limit_update_info_array: ^array [1 .. * ] of avt$total_limit_update_record;
       VAR previous_family_name: ost$family_name;
       VAR family_name: ost$family_name;
       VAR key: avt$validation_key;
       VAR size: integer;
       VAR current_entry: integer);

      VAR
        next_entry: integer,
        type_specification: avt$type_specification;

      size := 0;

      IF (current_entry + 1) <= UPPERBOUND (limit_update_info_array^) THEN
        IF limit_update_info_array^ [current_entry + 1].family_name <> previous_family_name THEN

{ The end of the updates for the current family has been reached.

          key.value := high_value_key.value;

{ Reset the previous family flag for the next time through.

          previous_family_name := limit_update_info_array^ [current_entry + 1].family_name;
          RETURN;
        ELSE
          current_entry := current_entry + 1;
        IFEND;

{ Assign the values to return.

        family_name := limit_update_info_array^ [current_entry].family_name;
        key.value := limit_update_info_array^ [current_entry].validation_key.value;
        size := limit_update_info_array^ [current_entry].size;

{ Summarize the size for any records with like keys.

        next_entry := current_entry + 1;
        WHILE ((next_entry <= UPPERBOUND (limit_update_info_array^)) AND
              (limit_update_info_array^ [current_entry].family_name =
              limit_update_info_array^ [next_entry].family_name) AND
              (limit_update_info_array^ [current_entry].validation_key.value =
              limit_update_info_array^ [next_entry].validation_key.value)) DO
          size := size + limit_update_info_array^ [next_entry].size;
          current_entry := next_entry;
          next_entry := next_entry + 1;
        WHILEND;
      ELSE

{ The end of the update info array has been reached.

        family_name := osc$null_name;
        key.value := high_value_key.value;
      IFEND;

    PROCEND get_next_update_entry;
?? TITLE := '      get_next_validation_file_entry', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used to get the next record from a validation file
{ that has a matching limit field and whose record type is within
{ the system validation level.
{
{   That is:  If the system is running at user level then the only user records
{                   are selected.
{             If the system is running at account level then the next account,
{                   account member, or user records are selected.
{             If the system is running at project level then any record may be
{                   selected.
{

    PROCEDURE get_next_validation_file_entry
      (    accum_limit_field_name: ost$name;
       VAR data_record: ^avt$template_file_record;
       VAR description_record: ^avt$template_file_record;
       VAR key: avt$validation_key;
       VAR field_value: avt$field_value;
       VAR file_information: avt$template_file_information;
       VAR status: ost$status);

      VAR
        default_value: avt$field_value,
        description_record_name: ost$name,
        descriptive_text: ^avt$descriptive_text,
        field_count: avt$field_count,
        record_to_update_found: boolean,
        type_specification: avt$type_specification,
        utility_information: ^avt$utility_information;

      status.normal := TRUE;

{ Read validation records until a record within the system validation level
{ is found.

      REPEAT
        RESET data_record;
        RESET description_record;

{ Get the next validation record.

        avp$read_next_data_record (avc$update_access, FALSE, key.value, data_record, description_record,
              description_record_name, field_count, file_information, status);
        IF NOT status.normal THEN
          IF status.condition = ave$end_of_template_file THEN
            key.value := high_value_key.value;
            status.normal := TRUE;
          IFEND;
          RETURN;
        IFEND;

{ Determine if the record read should be updated.

        record_to_update_found := FALSE;
        IF description_record_name = avc$user_record_name THEN
          IF user_limit_applies THEN
            record_to_update_found := TRUE;
          IFEND;
        ELSEIF description_record_name = avc$account_record_name THEN
          IF ((account_limit_applies) AND (validation_level > avc$user_level)) THEN
            record_to_update_found := TRUE;
          IFEND;
        ELSEIF description_record_name = avc$account_member_record_name THEN
          IF ((account_member_limit_applies) AND (validation_level > avc$user_level)) THEN
            record_to_update_found := TRUE;
          IFEND;
        ELSEIF description_record_name = avc$project_record_name THEN
          IF ((project_limit_applies) AND (validation_level > avc$account_level)) THEN
            record_to_update_found := TRUE;
          IFEND;
        ELSE
          IF ((project_member_limit_applies) AND (validation_level > avc$account_level)) THEN
            record_to_update_found := TRUE;
          IFEND;
        IFEND;

{ Unlock the record if will not be used.

        IF NOT record_to_update_found THEN
          avp$unlock_template_file (file_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      UNTIL record_to_update_found;

{ Get the specified limit field from the record.

      avp$get_field (accum_limit_field_name, data_record, description_record, {work_area=} NIL, field_value,
            type_specification, default_value, descriptive_text, utility_information, status);

    PROCEND get_next_validation_file_entry;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

    IF UPPERBOUND (limit_update_info_array^) > 0 THEN
      sort_total_limit_update_info (limit_update_info_array, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      previous_family_name := limit_update_info_array^ [1].family_name;
    ELSE

{ No limit update information is available so return.

      RETURN;
    IFEND;

    current_entry := 0;
    validation_level := avp$validation_level ();

    high_value_key.account_name := avc$high_value_name;
    high_value_key.project_name := avc$high_value_name;
    high_value_key.user_name := avc$high_value_name;

    field_value_list.field_name := accum_limit_field_name;
    field_value_list.forward := NIL;

    PUSH data_record: [[REP avc$max_template_record_size OF cell]];
    PUSH description_record: [[REP avc$max_template_record_size OF cell]];

{ Process entries until the end of BOTH input sources is found.

    REPEAT

{ Get an entry from the limit update information.

      get_next_update_entry (limit_update_info_array, previous_family_name, family_name, limit_update_key,
            size, current_entry);

{ Don't allow limit updates on the client.

      avp$check_for_served_family (family_name, served_family);
      IF served_family THEN
        osp$set_status_abnormal ('AV', ave$not_allowed_on_client, 'LIMIT UPDATING', status);
        RETURN;
      IFEND;

{ Open the validation file for the family found on the update record.

      avp$open_system_validation_file (family_name, validation_file_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    /validation_file_open/

      BEGIN

{ Find out which validation records contain the specified limit.

{ Check the user description record.

        get_field_description (accum_limit_field_name, avc$user_record_name, osc$null_name,
              {field_work_area=} NIL, description_record, default_value, type_specification, description,
              field_utility_information, validation_file_information, status);
        IF status.normal THEN
          user_limit_applies := TRUE;
        ELSE
          IF (status.condition = ave$unknown_field) OR (status.condition = ave$field_was_deleted) THEN
            user_limit_applies := FALSE;
            status.normal := TRUE;
          ELSE
            EXIT /validation_file_open/;
          IFEND;
        IFEND;

{ Check the account description record.

        get_field_description (accum_limit_field_name, avc$account_record_name, osc$null_name,
              {field_work_area=} NIL, description_record, default_value, type_specification, description,
              field_utility_information, validation_file_information, status);
        IF status.normal THEN
          account_limit_applies := TRUE;
        ELSE
          IF (status.condition = ave$unknown_field) OR (status.condition = ave$field_was_deleted) THEN
            account_limit_applies := FALSE;
            status.normal := TRUE;
          ELSE
            EXIT /validation_file_open/;
          IFEND;
        IFEND;

{ Check the account member description record.

        get_field_description (accum_limit_field_name, avc$account_member_record_name, osc$null_name,
              {field_work_area=} NIL, description_record, default_value, type_specification, description,
              field_utility_information, validation_file_information, status);
        IF status.normal THEN
          account_member_limit_applies := TRUE;
        ELSE
          IF (status.condition = ave$unknown_field) OR (status.condition = ave$field_was_deleted) THEN
            account_member_limit_applies := FALSE;
            status.normal := TRUE;
          ELSE
            EXIT /validation_file_open/;
          IFEND;
        IFEND;

{ Check the project description record.

        get_field_description (accum_limit_field_name, avc$project_record_name, osc$null_name,
              {field_work_area=} NIL, description_record, default_value, type_specification, description,
              field_utility_information, validation_file_information, status);
        IF status.normal THEN
          project_limit_applies := TRUE;
        ELSE
          IF (status.condition = ave$unknown_field) OR (status.condition = ave$field_was_deleted) THEN
            project_limit_applies := FALSE;
            status.normal := TRUE;
          ELSE
            EXIT /validation_file_open/;
          IFEND;
        IFEND;

{ Check the project member description record.

        get_field_description (accum_limit_field_name, avc$project_member_record_name, osc$null_name,
              {field_work_area=} NIL, description_record, default_value, type_specification, description,
              field_utility_information, validation_file_information, status);
        IF status.normal THEN
          project_member_limit_applies := TRUE;
        ELSE
          IF (status.condition = ave$unknown_field) OR (status.condition = ave$field_was_deleted) THEN
            project_member_limit_applies := FALSE;
            status.normal := TRUE;
          ELSE
            EXIT /validation_file_open/;
          IFEND;
        IFEND;

        IF NOT (user_limit_applies OR account_limit_applies OR account_member_limit_applies OR
              project_limit_applies OR project_member_limit_applies) THEN

{ If the specified limit does not exist on this validation file then start
{ at the end so no updates are attempted.

          validation_file_information.last_key_accessed (1, 31) := avc$high_value_name {account_name} ;
          validation_file_information.last_key_accessed (32, 31) := avc$high_value_name {project_name} ;
          validation_file_information.last_key_accessed (63, 31) := avc$high_value_name {user_name} ;
        ELSEIF ((validation_level = avc$user_level) OR NOT (account_limit_applies OR
              account_member_limit_applies OR project_limit_applies OR project_member_limit_applies)) THEN

{ If the system is running at user level OR the specified limit only applies
{ to user records then start at the first user record.

          validation_file_information.last_key_accessed (1, 31) := avc$high_value_name {account_name} ;
          validation_file_information.last_key_accessed (32, 31) := avc$high_value_name {project_name} ;
          validation_file_information.last_key_accessed (63, 31) := osc$null_name {user_name} ;
        ELSE

{ Otherwise start at the first record on the file.

          validation_file_information.last_key_accessed (1, 31) := osc$null_name {account_name} ;
          validation_file_information.last_key_accessed (32, 31) := osc$null_name {project_name} ;
          validation_file_information.last_key_accessed (63, 31) := osc$null_name {user_name} ;
        IFEND;

{ Get the first validation file entry.

        get_next_validation_file_entry (accum_limit_field_name, data_record, description_record,
              validation_file_key, field_value_list.field_value, validation_file_information, status);
        IF NOT status.normal THEN
          EXIT /validation_file_open/;
        IFEND;

{ Process each validation validation record found until the end of the validation file,
{ Synchronizing the validation file with the updates as each record is processed.

        REPEAT

{ If no update information exists for the validation record then zero out the
{ accumulator for the record and rewrite it.

          IF validation_file_key.value < limit_update_key.value THEN
            field_value_list.field_value.total_accumulation^ := 0;
            avp$rewrite_data_record (validation_file_key.value, TRUE, data_record, description_record,
                  ^field_value_list, validation_file_information, status);
            IF NOT status.normal THEN
              EXIT /validation_file_open/;
            IFEND;

{ Get the next entry from the validation file.


            get_next_validation_file_entry (accum_limit_field_name, data_record, description_record,
                  validation_file_key, field_value_list.field_value, validation_file_information, status);
            IF NOT status.normal THEN
              EXIT /validation_file_open/;
            IFEND;
          ELSEIF validation_file_key.value > limit_update_key.value THEN

{ No validation record exists for this update information.
{ This may be a normal situation (i.e. The file was created by a user from a
{ different family using an account and/or project that do not exist on this
{ family.), or it may be an abnormal situation (i.e. The file may belong to
{ a user who has been deleted from the validation file but his files still
{ exist.).

{ What do we do in this situation.  I guess we emit an error statistic but
{ tell the site that they can deactivate the statistic if they are not
{ concerned with this problem.

{ Get the next entry from the updates.

            get_next_update_entry (limit_update_info_array, previous_family_name, family_name,
                  limit_update_key, size, current_entry);

          ELSE

{ Update the accumulator for the validation record with
{ the amount found on the matching update entry.

            field_value_list.field_value.total_accumulation^ := size;
            avp$rewrite_data_record (validation_file_key.value, TRUE, data_record, description_record,
                  ^field_value_list, validation_file_information, status);
            IF NOT status.normal THEN
              EXIT /validation_file_open/;
            IFEND;

{ Get the next entry from the validation file.

            get_next_validation_file_entry (accum_limit_field_name, data_record, description_record,
                  validation_file_key, field_value_list.field_value, validation_file_information, status);
            IF NOT status.normal THEN
              EXIT /validation_file_open/;
            IFEND;

{ Get the next entry from the updates.

            get_next_update_entry (limit_update_info_array, previous_family_name, family_name,
                  limit_update_key, size, current_entry);

          IFEND;

        UNTIL (limit_update_key.value = high_value_key.value) AND
              (validation_file_key.value = high_value_key.value);

{ The end of the validation file, and the end of the updates
{ for this family have been reached.

      END /validation_file_open/;
      IF NOT status.normal THEN
        avp$close_validation_file (validation_file_information, ignore_status);
        RETURN;
      ELSE
        avp$close_validation_file (validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

{ family name is set to null name when the end of the update entries is found.

    UNTIL family_name = osc$null_name;

  PROCEND avp$replace_total_limits;
?? TITLE := '    avp$update_eoj_total_limits', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is called at end of job to update the total access limits in the
{ validation file from the statistics facility limit chain information.
{
{ DESIGN:
{
{ To be supplied.
{

  PROCEDURE [XDCL] avp$update_eoj_total_limits
    (VAR status: ost$status);

    VAR
      account_name: avt$account_name,
      ignore_status: ost$status,
      project_name: avt$project_name,
      served_family: boolean,
      user_identification: ost$user_identification,
      validation_file_information: avt$template_file_information,
      validation_level: avt$validation_level,
      validated_limit: ^avt$validated_limit;

?? NEWTITLE := '      update_total_limit', EJECT ??
{
{ PURPOSE:
{
{   This procedure used to update the total access limits in the
{ validation file for the specified limit chain item.
{

    PROCEDURE update_total_limits
      (    validated_limits: ^avt$validated_limit;
           user_name: ost$user_name;
           account_name: avt$account_name;
           project_name: avt$project_name;
       VAR validation_file_information: avt$template_file_information;
       VAR status: ost$status);

      VAR
        key: avt$validation_key;

?? NEWTITLE := '        update_validation_record', EJECT ??
{
{ PURPOSE:
{
{   This procedure used to update the total access limit in the
{ specified validation record for the specified limit chain item.
{

      PROCEDURE update_validation_record
        (    validated_limits: ^avt$validated_limit;
         VAR key: avt$validation_key;
         VAR validation_file_information: avt$template_file_information;
         VAR status: ost$status);

        VAR
          current_field_value_entry: ^avt$field_value_list_entry,
          current_validated_limit: ^avt$validated_limit,
          data_record: ^avt$template_file_record,
          data_record_size: 0 .. avc$max_template_record_size,
          default_value: avt$field_value,
          description_record: ^avt$template_file_record,
          description_record_size: 0 .. avc$max_template_record_size,
          descriptive_text: ^avt$descriptive_text,
          description_record_name: ost$name,
          field_count: avt$field_count,
          utility_information: ^avt$utility_information,
          field_value: avt$field_value,
          field_value_list: ^avt$field_value_list_entry,
          limit: sft$limit,
          type_specification: avt$type_specification;

        status.normal := TRUE;

        PUSH data_record: [[REP avc$max_template_record_size OF cell]];
        RESET data_record;
        PUSH description_record: [[REP avc$max_template_record_size OF cell]];
        RESET description_record;

        field_value_list := NIL;

        avp$read_data_record (key.value, avc$update_access, FALSE, data_record, data_record_size,
              description_record, description_record_size, description_record_name, field_count,
              validation_file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        current_validated_limit := validated_limits;

      /process_validated_limits/

        WHILE current_validated_limit <> NIL DO

{ Get the current field value.

          IF (current_validated_limit^.kind = avc$accumulating_limit_kind) AND
                current_validated_limit^.total_limit_applies THEN
            avp$get_field (current_validated_limit^.field_name, data_record, description_record,
                  {work_area=} NIL, field_value, type_specification, default_value, descriptive_text,
                  utility_information, status);
            IF NOT status.normal THEN
              IF (status.condition = ave$unknown_field) OR (status.condition = ave$field_was_deleted) THEN
                status.normal := TRUE;
                current_validated_limit := current_validated_limit^.forward;
                CYCLE /process_validated_limits/;
              IFEND;
              EXIT /process_validated_limits/;
            IFEND;

            IF type_specification.total_limit_applies^ THEN
              sfp$get_job_limit (current_validated_limit^.limit_name, limit, status);
              IF NOT status.normal THEN
                EXIT /process_validated_limits/;
              IFEND;
              IF field_value_list = NIL THEN
                PUSH field_value_list;
                current_field_value_entry := field_value_list;
              ELSE
                PUSH current_field_value_entry^.forward;
                current_field_value_entry := current_field_value_entry^.forward;
              IFEND;
              current_field_value_entry^.forward := NIL;
              current_field_value_entry^.field_name := current_validated_limit^.field_name;
              current_field_value_entry^.field_value := field_value;
              current_field_value_entry^.field_value.total_accumulation^ :=
                    current_field_value_entry^.field_value.total_accumulation^ +
                    (limit.accumulator - current_validated_limit^.initial_value);
              IF current_field_value_entry^.field_value.total_accumulation^ < 0 THEN
                current_field_value_entry^.field_value.total_accumulation^ := 0;
              IFEND;
            IFEND;
          IFEND;

          current_validated_limit := current_validated_limit^.forward;
        WHILEND /process_validated_limits/;

        IF status.normal AND (field_value_list <> NIL) THEN
          avp$rewrite_data_record (key.value, TRUE, data_record, description_record, field_value_list,
                validation_file_information, status);
        ELSE
          avp$unlock_template_file (validation_file_information, ignore_status);
        IFEND;

      PROCEND update_validation_record;
?? OLDTITLE, EJECT ??
      status.normal := TRUE;

      key.account_name := avc$high_value_name;
      key.project_name := avc$high_value_name;
      key.user_name := user_name;

      update_validation_record (validated_limits, key, validation_file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$unknown_record THEN
          status.normal := TRUE;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      IF validation_level > avc$user_level THEN

{ Update the account limit information.

        key.account_name := account_name;
        key.project_name := osc$null_name;
        key.user_name := osc$null_name;
        update_validation_record (validated_limits, key, validation_file_information, status);
        IF NOT status.normal THEN
          IF status.condition = ave$unknown_record THEN
            status.normal := TRUE;
          ELSE
            RETURN;
          IFEND;
        IFEND;

{ Update the account member limit information.

        key.account_name := account_name;
        key.project_name := osc$null_name;
        key.user_name := user_name;
        update_validation_record (validated_limits, key, validation_file_information, status);
        IF NOT status.normal THEN
          IF status.condition = ave$unknown_record THEN
            key.user_name := '$PUBLIC                        ';
            update_validation_record (validated_limits, key, validation_file_information, status);
            IF status.condition = ave$unknown_record THEN
              status.normal := TRUE;
            IFEND;
          ELSE
            RETURN;
          IFEND;
        IFEND;
      IFEND;

      IF validation_level > avc$account_level THEN

{ Update the project limit information.

        key.account_name := account_name;
        key.project_name := project_name;
        key.user_name := osc$null_name;
        update_validation_record (validated_limits, key, validation_file_information, status);
        IF NOT status.normal THEN
          IF status.condition = ave$unknown_record THEN
            status.normal := TRUE;
          ELSE
            RETURN;
          IFEND;
        IFEND;

{ Update the project member limit information.

        key.account_name := account_name;
        key.project_name := project_name;
        key.user_name := user_name;
        update_validation_record (validated_limits, key, validation_file_information, status);
        IF NOT status.normal THEN
          IF status.condition = ave$unknown_record THEN
            key.user_name := '$PUBLIC                        ';
            update_validation_record (validated_limits, key, validation_file_information, status);
            IF NOT status.normal THEN
              IF status.condition = ave$unknown_record THEN
                status.normal := TRUE;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

    PROCEND update_total_limits;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    validation_level := avp$validation_level ();

{ Get executing user identification.

    pmp$get_user_identification (user_identification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Get executing account and project names.

    pmp$get_account_project (account_name, project_name, status);

{ Don't update the validation file if this is a served family.

    avp$check_for_served_family (user_identification.family, served_family);
    IF served_family THEN
      RETURN;
    IFEND;

    avp$open_system_validation_file (user_identification.family, validation_file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    update_total_limits (avv$validated_limits, user_identification.user, account_name, project_name,
          validation_file_information, status);
    IF NOT status.normal THEN
      avp$close_validation_file (validation_file_information, ignore_status);
    ELSE
      avp$close_validation_file (validation_file_information, status);
    IFEND;

  PROCEND avp$update_eoj_total_limits;

?? TITLE := '    avp$validate_job', EJECT ??
*copyc avh$validate_job
{ DESIGN:
{
{   This interface opens the validation file and then verifies access for the
{ specified user.  An optional list of items to validate is input.
{
{ The following items are always validated:
{   The user is validated for access to the family.
{   Account membership if running at account level.
{   Account or Project membership if running at project level.
{ The following items are optional validations:
{   Password. (In it's encrypted form)
{   Job Class.
{   Job execution ring.
{   Job limits.
{   Required capabilites.
{
{   The master catalog for the user is created if it does not already exist.
{
{   Job limits from the validation file are extracted and stored in memory
{ for later use by the statistics facility for limit setup, and logout for
{ total limit updates.

  PROCEDURE [XDCL] avp$validate_job
    (    user_name: ost$user_name;
         family_name: ost$family_name;
         account: avt$account_name;
         project: avt$project_name;
         validation_attributes: ^avt$validation_items;
     VAR status: ost$status);

    TYPE
      limit_item = record
        limit_name: ost$name,
        user_specified: boolean,
        job_maximum_limit: sft$counter,
        forward: ^limit_item,
      recend;

    VAR
      account_member_exists: boolean,
      account_name: avt$account_name,
      block: ^clt$block,
      caller_authority: avt$validation_authority,
      capability: boolean,
      current_date_time: ost$date_time,
      current_limit_item: ^limit_item,
      default_value: avt$field_value,
      description_record_name: ost$name,
      descriptive_text: ^avt$descriptive_text,
      default_name: jmt$job_class_name,
      field_count: avt$field_count,
      field_value: avt$field_value,
      file_information: avt$template_file_information,
      found_job_class: boolean,
      ignore_status: ost$status,
      increment: pmt$time_increment,
      index: integer,
      item_index: integer,
      job_class: jmt$job_class,
      job_maximum: sft$counter,
      key: avt$validation_key,
      limit_field_names: ^array [1 .. * ] of ost$name,
      limit_item_list: ^limit_item,
      path: array [1 .. 4] of pft$name,
      project_exists: boolean,
      project_member_exists: boolean,
      project_name: avt$project_name,
      temp_login_password: avt$password,
      type_specification: avt$type_specification,
      utility_information: ^avt$utility_information,
      validated_limit_item: ^avt$validated_limit;

?? NEWTITLE := '      create_validated_limit', EJECT ??
{
{ PURPOSE:
{
{   This procedure adds a limit from the validation file to a validated limit
{ chain.
{

    PROCEDURE create_validated_limit
      (    field_name: ost$name;
       VAR type_specification: avt$type_specification;
       VAR field_value: avt$field_value);

      VAR
        current_limit: ^avt$validated_limit,
        job_maximum: sft$counter,
        validated_limit: ^avt$validated_limit;

{ Retrieve the job maximum limit value.  If total limits apply for this limit
{ and the amount of resource left before hitting the total limit is less than
{ the job maximum then set the job maximum to the amount of resource left.

      IF field_name = avc$permanent_file_space_limit THEN
        PUSH type_specification.job_limits_apply;
        type_specification.job_limits_apply^ := TRUE;
        PUSH field_value.job_maximum_limit;
        PUSH field_value.job_warning_limit;
        field_value.job_maximum_limit^ := field_value.total_limit^;
        field_value.job_warning_limit^ := field_value.total_limit^;
      IFEND;

      IF (((type_specification.kind = avc$accumulating_limit_kind) AND
            (type_specification.job_limits_apply^)) OR (type_specification.kind = avc$limit_kind)) THEN
        IF type_specification.kind = avc$accumulating_limit_kind THEN
          job_maximum := field_value.job_maximum_limit^;
          IF ((type_specification.total_limit_applies^) AND (type_specification.total_limit_stops_login^) AND
                (field_value.total_limit^ <> sfc$unlimited)) THEN
            IF ((field_value.total_limit^) - (field_value.total_accumulation^)) < job_maximum THEN
              job_maximum := ((field_value.total_limit^) - (field_value.total_accumulation^));
            IFEND;
          IFEND;
        IFEND;

{ Allocate space for the limit and place it in the beginning of the limit
{ chain.

        ALLOCATE validated_limit IN osv$task_shared_heap^;

        validated_limit^.kind := type_specification.kind;
        validated_limit^.field_name := field_name;
        validated_limit^.limit_name := type_specification.limit_name^;
        IF validated_limit^.limit_name = avc$cp_time_limit_name THEN
          validated_limit^.limit_name := avc$cpu_time_limit_name;
        IFEND;
        validated_limit^.forward := NIL;

        CASE field_value.kind OF

{ Assign limit values to the limit chain entry.

        = avc$accumulating_limit_kind =
          validated_limit^.statistic_codes := type_specification.limit_update_statistics;
          validated_limit^.job_warning_limit := field_value.job_warning_limit^;
          validated_limit^.job_maximum_limit := field_value.job_maximum_limit^;
          IF (type_specification.limit_update_statistics <> NIL) OR
             (validated_limit^.limit_name = avc$cpu_time_limit_name) OR
             (validated_limit^.limit_name = avc$sru_limit_name) THEN
            validated_limit^.enforcement := sfc$accumulation_enforcement;
          ELSE
            validated_limit^.enforcement := sfc$other_enforcement;
          IFEND;
          validated_limit^.initial_value := 0;
          IF validated_limit^.limit_name = avc$task_limit_name THEN
            validated_limit^.initial_value := 1;
          IFEND;
          IF validated_limit^.limit_name = avc$pfs_limit_name THEN
            validated_limit^.initial_value := field_value.total_accumulation^;
            IF validated_limit^.initial_value < 0 THEN
              validated_limit^.initial_value := 0;
            IFEND;
          ELSE
            IF job_maximum < field_value.job_warning_limit^ THEN
              validated_limit^.job_warning_limit := job_maximum;
            IFEND;
            IF job_maximum < field_value.job_maximum_limit^ THEN
              validated_limit^.job_maximum_limit := job_maximum;
            IFEND;
          IFEND;
          validated_limit^.total_limit_applies := type_specification.total_limit_applies^;
        = avc$limit_kind =
          validated_limit^.job_maximum_limit := field_value.limit_value^;
        ELSE
          ;
        CASEND;

{ Insert the limit entry at the front of the limit chain.

        IF avv$validated_limits = NIL THEN
          avv$validated_limits := validated_limit;
        ELSE
          current_limit := avv$validated_limits;
          WHILE current_limit^.forward <> NIL DO
            current_limit := current_limit^.forward;
          WHILEND;
          current_limit^.forward := validated_limit;
        IFEND;
      IFEND;

    PROCEND create_validated_limit;

?? TITLE := '      change_validated_limit', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used to to vote down the allowed limit value with limits
{ from the account and project level validation records.
{

    PROCEDURE change_validated_limit
      (    field_name: ost$name;
           field_value: avt$field_value;
           type_specification: avt$type_specification);

      VAR
        current_limit: ^avt$validated_limit,
        job_maximum: sft$counter,
        validated_limit: ^avt$validated_limit;

{ Permanent file space limits are not voted down.

      IF field_name = avc$permanent_file_space_limit THEN
        RETURN;
      IFEND;

{ If the total limit stops login for this limit then get the amount
{ of resource left before hitting the total limit.

      IF (type_specification.total_limit_stops_login^) AND (field_value.total_limit^ <> sfc$unlimited) THEN
        job_maximum := ((field_value.total_limit^) - (field_value.total_accumulation^));

        current_limit := avv$validated_limits;

{ If a user level limit does not exist for this limit then the lower level
{ limit is ignored.

      /find_validated_limit/
        WHILE current_limit <> NIL DO
          IF current_limit^.field_name = field_name THEN
            CASE current_limit^.kind OF

{ Reassign the job limit values if lower than the current value.

            = avc$accumulating_limit_kind =
              IF job_maximum < current_limit^.job_warning_limit THEN
                current_limit^.job_warning_limit := job_maximum;
              IFEND;
              IF job_maximum < current_limit^.job_maximum_limit THEN
                current_limit^.job_maximum_limit := job_maximum;
              IFEND;
              IF type_specification.total_limit_applies^ THEN
                current_limit^.total_limit_applies := TRUE;
              IFEND;
              EXIT /find_validated_limit/;
            ELSE
              ;
            CASEND;
          IFEND;
          current_limit := current_limit^.forward;
        WHILEND /find_validated_limit/;
      IFEND;

    PROCEND change_validated_limit;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    avv$validated_limits := NIL;
    limit_item_list := NIL;

{ Store the validation information for this user in memory.

    account_name := account;
    project_name := project;
    avp$store_validation_info (family_name, user_name, account_name, project_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Store the account and project.

    avv$account_name := account_name;
    avv$project_name := project_name;

{ Skip the check for an expired password in the system job.

    IF NOT jmp$system_job () THEN

{ Retrieve the login password value for this user.

      avp$get_field (avc$login_password, avv$user_data_record, avv$user_description_record, {work_area=} NIL,
            field_value, type_specification, default_value, descriptive_text, utility_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Verify that the user's password has not expired.

      IF field_value.login_password_exp_date^.year <> avc$no_expiration_date THEN
        pmp$get_compact_date_time (current_date_time, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        pmp$compute_date_time_increment (current_date_time, field_value.login_password_exp_date^, increment,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF (increment.year < 0) OR (increment.month < 0) OR (increment.day < 0) OR (increment.hour < 0) OR
              (increment.minute < 0) OR (increment.second < 0) OR (increment.millisecond < 0) THEN
          osp$set_status_condition (ave$bad_user_validation_info, status);
          RETURN;
        IFEND;
      IFEND;
    IFEND;

{ If executing in the system job, then determine whether the job has been
{ validated for system_operation or removable_media_operation.

    IF jmp$system_job () THEN
      avv$validated_sou_capabilities := $avt$conditional_capabilities [];

      avp$get_capability (avc$removable_media_operation, avc$user, capability, status);
      IF status.normal THEN
        IF capability THEN
          avv$validated_sou_capabilities := avv$validated_sou_capabilities
                + $avt$conditional_capabilities [avc$cc_removable_media_operator];
        IFEND;
      ELSEIF status.condition <> ave$unknown_field THEN
        RETURN;
      IFEND;

      avp$get_capability (avc$system_operation, avc$user, capability, status);
      IF status.normal THEN
        IF capability THEN
          avv$validated_sou_capabilities := avv$validated_sou_capabilities
                + $avt$conditional_capabilities [avc$cc_system_operator];
        IFEND;
      ELSEIF status.condition <> ave$unknown_field THEN
        RETURN;
      IFEND;

{ Otherwise, clear the active_capabilities field in all blocks on the block
{ stack and re-evaluate the PF subsystem's administrator status for the
{ executing task.

    ELSE
      clp$find_current_block (block);
      WHILE block <> NIL DO
        block^.active_capabilities := $avt$conditional_capabilities [];
        block := block^.previous_block;
      WHILEND;
      pfp$reset_administrator_status;
    IFEND;

    avp$get_field (avc$ring_privileges, avv$user_data_record, avv$user_description_record, {work_area=} NIL,
      field_value, type_specification, default_value, descriptive_text, utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    avv$minimum_ring := field_value.minimum_ring^;
    avv$nominal_ring := field_value.nominal_ring^;

    IF validation_attributes <> NIL THEN
      FOR item_index := 1 TO UPPERBOUND (validation_attributes^) DO
        CASE validation_attributes^ [item_index].key OF

{ Validate the specified job class.

        = avc$job_class_name_key =

{ Retrieve the user's valid job class list.

          avp$get_field (avc$job_class, avv$user_data_record, avv$user_description_record, {work_area=} NIL,
                field_value, type_specification, default_value, descriptive_text, utility_information,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Verify that the user is valid for the requested job class.

          validate_job_class (field_value, validation_attributes^ [item_index].job_class_name,
                found_job_class);
          IF NOT found_job_class THEN
            osp$set_status_abnormal ('AV', ave$bad_job_class,
                  validation_attributes^ [item_index].job_class_name, status);
            RETURN;
          IFEND;

{ Validate the specified job execution ring.

        = avc$job_execution_ring_key =

{ Verify that the user is valid to run at the specified ring.

          IF validation_attributes^ [item_index].job_execution_ring < avv$minimum_ring THEN
            osp$set_status_abnormal ('AV', ave$bad_ring, '', status);
            RETURN;
          IFEND;

{ Validate the specified job limit.

        = avc$job_limit_key =

{ Save the specified job limit for later validation.

          IF limit_item_list = NIL THEN
            PUSH current_limit_item;
            limit_item_list := current_limit_item;
          ELSE
            PUSH current_limit_item^.forward;
            current_limit_item := current_limit_item^.forward;
          IFEND;
          current_limit_item^.limit_name := validation_attributes^ [item_index].limit_name;
          current_limit_item^.user_specified := validation_attributes^ [item_index].user_specified;
          current_limit_item^.job_maximum_limit := validation_attributes^ [item_index].job_maximum;
          current_limit_item^.forward := NIL;

{ Validate the specified password.

        = avc$password_key =

{ Retrieve the user's login password value.

          avp$get_field (avc$login_password, avv$user_data_record, avv$user_description_record,
                {work_area=} NIL, field_value, type_specification, default_value, descriptive_text,
                utility_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Verify the specfied login password value.

          IF field_value.login_password^.value <> validation_attributes^ [item_index].password THEN
            osp$set_status_condition (ave$bad_user_validation_info, status);
            RETURN;
          IFEND;

{ Validate the specified required capability.

        = avc$required_capability_key =

{ Retrieve the specified capability.

          avp$get_field (validation_attributes^ [item_index].required_capability, avv$user_data_record,
                avv$user_description_record, {work_area=} NIL, field_value, type_specification, default_value,
                descriptive_text, utility_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Verify that the user has the specified required capability.

          IF NOT field_value.capability^ THEN
            osp$set_status_abnormal ('AV', ave$missing_required_capability,
                  validation_attributes^ [item_index].required_capability, status);
            RETURN;
          IFEND;
        ELSE
          ;
        CASEND;
      FOREND;
    IFEND;

{ Check limits if not in the system job.

    IF NOT jmp$system_job () THEN

{ User Limit Checking

{ Retrieve a list of all accumulating limit and limit type fields from the user record.

      PUSH limit_field_names: [1 .. avc$maximum_field_count];
      avp$get_field_names ($avt$field_kind_set [avc$accumulating_limit_kind, avc$limit_kind], FALSE,
            avv$user_description_record, limit_field_names^, field_count, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Check each user limit.

      FOR index := 1 TO field_count DO
        avp$get_field (limit_field_names^ [index], avv$user_data_record, avv$user_description_record,
              {work_area=} NIL, field_value, type_specification, default_value, descriptive_text,
              utility_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Verify that the user's total limit has not been exceeded.

        IF ((type_specification.kind = avc$accumulating_limit_kind) AND
              (type_specification.total_limit_applies^) AND (type_specification.total_limit_stops_login^) AND
              (field_value.total_limit^ <> sfc$unlimited) AND (field_value.total_accumulation^ >=
              field_value.total_limit^)) THEN
          osp$set_status_condition (ave$bad_user_validation_info, status);
          RETURN;
        IFEND;

{ Add the limit to the validated limit chain.

        create_validated_limit (limit_field_names^ [index], type_specification, field_value);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

{ Account Limit Checking (only if validation level is account or project)

      IF avv$account_data_record <> NIL THEN

{ Retrieve a list of all accumulating limit fields from the account record.

        PUSH limit_field_names: [1 .. avc$maximum_field_count];
        avp$get_field_names ($avt$field_kind_set [avc$accumulating_limit_kind], FALSE,
              avv$account_description_record, limit_field_names^, field_count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Check each account limit.

        FOR index := 1 TO field_count DO
          avp$get_field (limit_field_names^ [index], avv$account_data_record, avv$account_description_record,
                {work_area=} NIL, field_value, type_specification, default_value, descriptive_text,
                utility_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Verify that the account's total limit has not been exceeded.

          IF ((type_specification.kind = avc$accumulating_limit_kind) AND
                (type_specification.total_limit_applies^) AND (type_specification.
                total_limit_stops_login^) AND (field_value.total_limit^ <> sfc$unlimited) AND
                (field_value.total_accumulation^ >= field_value.total_limit^)) THEN
            osp$set_status_condition (ave$bad_user_validation_info, status);
            RETURN;
          IFEND;

{ Vote down the user job limit values with those from the account.

          change_validated_limit (limit_field_names^ [index], field_value, type_specification);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
      IFEND;

{ Account Member Limit Checking (only if validation level is account or project)

      IF avv$account_member_data_record <> NIL THEN

{ Retrieve a list of all accumulating limit fields from the account member record.

        PUSH limit_field_names: [1 .. avc$maximum_field_count];
        avp$get_field_names ($avt$field_kind_set [avc$accumulating_limit_kind], FALSE,
              avv$account_member_desc_record, limit_field_names^, field_count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Check each account member limit.

        FOR index := 1 TO field_count DO
          avp$get_field (limit_field_names^ [index], avv$account_member_data_record,
                avv$account_member_desc_record, {work_area=} NIL, field_value, type_specification,
                default_value, descriptive_text, utility_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Verify that the account member's total limit has not been exceeded.

          IF ((type_specification.kind = avc$accumulating_limit_kind) AND
                (type_specification.total_limit_applies^) AND (type_specification.
                total_limit_stops_login^) AND (field_value.total_limit^ <> sfc$unlimited) AND
                (field_value.total_accumulation^ >= field_value.total_limit^)) THEN
            osp$set_status_condition (ave$bad_user_validation_info, status);
            RETURN;
          IFEND;

{ Vote down the user job limit values with those from the account member.

          change_validated_limit (limit_field_names^ [index], field_value, type_specification);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
      IFEND;

{ Project Limit Checking (only if validation level is project)

      IF avv$project_data_record <> NIL THEN

{ Retrieve a list of all accumulating limit fields from the project record.

        PUSH limit_field_names: [1 .. avc$maximum_field_count];
        avp$get_field_names ($avt$field_kind_set [avc$accumulating_limit_kind], FALSE,
              avv$project_description_record, limit_field_names^, field_count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Check each project limit.

        FOR index := 1 TO field_count DO
          avp$get_field (limit_field_names^ [index], avv$project_data_record, avv$project_description_record,
                {work_area=} NIL, field_value, type_specification, default_value, descriptive_text,
                utility_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Verify that the project's total limit has not been exceeded.

          IF ((type_specification.kind = avc$accumulating_limit_kind) AND
                (type_specification.total_limit_applies^) AND (type_specification.
                total_limit_stops_login^) AND (field_value.total_limit^ <> sfc$unlimited) AND
                (field_value.total_accumulation^ >= field_value.total_limit^)) THEN
            osp$set_status_condition (ave$bad_user_validation_info, status);
            RETURN;
          IFEND;

{ Vote down the user job limit values with those from the project.

          change_validated_limit (limit_field_names^ [index], field_value, type_specification);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
      IFEND;

{ Project Member Limit Checking (only if validation level is project)

      IF avv$project_member_data_record <> NIL THEN

{ Retrieve a list of all accumulating limit fields from the project member record.

        PUSH limit_field_names: [1 .. avc$maximum_field_count];
        avp$get_field_names ($avt$field_kind_set [avc$accumulating_limit_kind], FALSE,
              avv$project_member_desc_record, limit_field_names^, field_count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Check each project member limit.

        FOR index := 1 TO field_count DO
          avp$get_field (limit_field_names^ [index], avv$project_member_data_record,
                avv$project_member_desc_record, {work_area=} NIL, field_value, type_specification,
                default_value, descriptive_text, utility_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Verify that the project member's total limit has not been exceeded.

          IF ((type_specification.kind = avc$accumulating_limit_kind) AND
                (type_specification.total_limit_applies^) AND (type_specification.
                total_limit_stops_login^) AND (field_value.total_limit^ <> sfc$unlimited) AND
                (field_value.total_accumulation^ >= field_value.total_limit^)) THEN
            osp$set_status_condition (ave$bad_user_validation_info, status);
            RETURN;
          IFEND;

{ Vote down the user job limit values with those from the project member.

          change_validated_limit (limit_field_names^ [index], field_value, type_specification);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
      IFEND;

{ Check to see if the user has specified a job maximum for any limits.

      current_limit_item := limit_item_list;

    /find_specified_job_maximum/
      WHILE current_limit_item <> NIL DO

        validated_limit_item := avv$validated_limits;

      /find_validated_job_maximum/
        WHILE validated_limit_item <> NIL DO

{ The user may not specify a job maximum that is greater than validated for.

          IF current_limit_item^.limit_name = validated_limit_item^.limit_name THEN
            IF ((current_limit_item^.user_specified) AND (validated_limit_item^.job_maximum_limit <
                  current_limit_item^.job_maximum_limit)) THEN
              osp$set_status_abnormal ('AV', ave$bad_user_specified_job_max, current_limit_item^.limit_name,
                    status);
              RETURN;

{ If the specified job maximum is less than current reset it.

            ELSEIF current_limit_item^.job_maximum_limit < validated_limit_item^.job_maximum_limit THEN
              validated_limit_item^.job_maximum_limit := current_limit_item^.job_maximum_limit;
              IF ((validated_limit_item^.kind = avc$accumulating_limit_kind) AND
                    (current_limit_item^.job_maximum_limit < validated_limit_item^.job_warning_limit)) THEN
                validated_limit_item^.job_warning_limit := current_limit_item^.job_maximum_limit;
              IFEND;
            IFEND;
            EXIT /find_validated_job_maximum/;
          IFEND;

          validated_limit_item := validated_limit_item^.forward;
        WHILEND /find_validated_job_maximum/;

        current_limit_item := current_limit_item^.forward;
      WHILEND /find_specified_job_maximum/;
    IFEND;

  PROCEND avp$validate_job;
?? OLDTITLE ??
?? NEWTITLE := 'avp$validate_nqs_user', EJECT ??
*copyc avh$validate_nqs_user

  PROCEDURE [XDCL, #GATE] avp$validate_nqs_user
    (    user: ost$user_name;
         family: ost$family_name;
         account: avt$account_name;
         project: avt$project_name;
         unix_username: string (* <= 15);
         ring: ost$ring;
     VAR status: ost$status);

    VAR
      validation_attributes: ^avt$validation_items;

    status.normal := TRUE;

    PUSH validation_attributes: [1 .. 3];
    validation_attributes^ [1].key := avc$unix_username_key;
    validation_attributes^ [1].unix_username := unix_username;
    validation_attributes^ [2].key := avc$account_project_key;
    validation_attributes^ [2].account_name := account;
    validation_attributes^ [2].project_name := project;
    validation_attributes^ [3].key := avc$job_execution_ring_key;
    validation_attributes^ [3].job_execution_ring := ring;

    avp$prevalidate_job (user, family, validation_attributes, {default_attributes =} NIL, status);

  PROCEND avp$validate_nqs_user;

?? OLDTITLE ??
?? NEWTITLE := 'avp$validate_user', EJECT ??

{
{ PURPOSE:
{
{   This interface validates a family user password account project combination.
{
  PROCEDURE [XDCL, #GATE] avp$validate_user
    (    user: ost$user_name;
         family: ost$family_name;
         password: avt$password;
         account: avt$account_name;
         project: avt$project_name;
     VAR status: ost$status);

    VAR
      validation_attributes: ^avt$validation_items;

    status.normal := TRUE;

    PUSH validation_attributes: [1 .. 2];
    validation_attributes^ [1].key := avc$password_key;
    validation_attributes^ [1].password := password;
    validation_attributes^ [2].key := avc$account_project_key;
    validation_attributes^ [2].account_name := account;
    validation_attributes^ [2].project_name := project;

    avp$prevalidate_job (user, family, validation_attributes, {default_attributes =} NIL, status);

  PROCEND avp$validate_user;

?? TITLE := '    avp$validation_level', EJECT ??
{
{ PURPOSE:
{
{   This interface returns the current system validation level.
{
  FUNCTION [XDCL, #GATE] avp$validation_level: avt$validation_level;

    IF avv$validation_level = $INTEGER (avc$user_level) THEN
      avp$validation_level := avc$user_level;
    ELSEIF avv$validation_level = $INTEGER (avc$account_level) THEN
      avp$validation_level := avc$account_level;
    ELSE
      avp$validation_level := avc$project_level;
    IFEND;

  FUNCEND avp$validation_level;
?? OLDTITLE ??
?? TITLE := '  File server interfaces' ??
?? NEWTITLE := '    avp$server_prevalidate_job', EJECT ??
{
{ PURPOSE:
{
{   This interfaces is used to prevalidate a job for access to NOS/VE
{ on the server on behalf of a client.
{
  PROCEDURE [XDCL] avp$server_prevalidate_job
    (VAR p_params_received_from_client: dft$p_receive_parameters;
     VAR p_data_received_from_client: dft$p_receive_data;
     VAR p_params_to_send_to_client: dft$p_send_parameters;
     VAR p_data_to_send_to_client: dft$p_send_data;
     VAR params_size_to_send_to_client: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      default_attributes: ^avt$validation_items,
      family_name: ost$family_name,
      job_class_list: ^avt$name_list,
      labeled_names_work_area: ^seq (*),
      user_name: ost$user_name,
      validation_attributes: ^avt$validation_items,
      validation_level: avt$validation_level;

?? NEWTITLE := '      extract_info_sent_from_client', EJECT ??
    PROCEDURE extract_info_sent_from_client
      (VAR p_params_received_from_client: dft$p_receive_parameters;
       VAR p_data_received_from_client: dft$p_receive_data;
       VAR validation_level: avt$validation_level;
       VAR user_name: ost$user_name;
       VAR family_name: ost$family_name;
       VAR validation_attributes: ^avt$validation_items;
       VAR default_attributes: ^avt$validation_items;
       VAR job_class_list: ^avt$name_list;
       VAR labeled_names_work_area: ^seq (*));

      VAR
        item_index: integer,
        server_prevalidate_job_input: ^avt$server_prevalidate_job_in;

      NEXT server_prevalidate_job_input IN p_params_received_from_client;
      validation_level := server_prevalidate_job_input^.validation_level;
      user_name := server_prevalidate_job_input^.user_name;
      family_name := server_prevalidate_job_input^.family_name;
      IF server_prevalidate_job_input^.number_of_val_attributes > 0 THEN
        NEXT validation_attributes: [1 .. server_prevalidate_job_input^.number_of_val_attributes]
              IN p_params_received_from_client;
      ELSE
        validation_attributes := NIL;
      IFEND;
      IF server_prevalidate_job_input^.number_of_def_attributes > 0 THEN
        NEXT default_attributes: [1 .. server_prevalidate_job_input^.number_of_def_attributes]
              IN p_params_received_from_client;
        FOR item_index := 1 TO server_prevalidate_job_input^.number_of_def_attributes DO
          IF default_attributes^ [item_index].key = avc$valid_job_classes_key THEN
            default_attributes^ [item_index].job_classes := job_class_list;
          ELSEIF default_attributes^ [item_index].key = avc$labeled_names_key THEN
            default_attributes^ [item_index].work_area := labeled_names_work_area;
          IFEND;
        FOREND;
      ELSE
        default_attributes := NIL;
      IFEND;

    PROCEND extract_info_sent_from_client;
?? TITLE := '      build_info_to_send_to_client', EJECT ??
    PROCEDURE build_info_to_send_to_client
      (    default_attributes: ^avt$validation_items;
       VAR p_params_to_send_to_client: dft$p_send_parameters;
       VAR p_data_to_send_to_client: dft$p_send_data;
       VAR params_size_to_send_to_client: dft$send_parameter_size;
       VAR data_size_to_send_to_client: dft$send_data_size);

    VAR
      index: integer,
      index2: integer,
      item_index: integer,
      label: ^ost$name,
      name: ^ost$name,
      number_of_def_attributes: integer,
      number_of_labeled_names: ^integer,
      number_of_names: ^integer,
      send_default_attributes: ^avt$validation_items,
      send_valid_job_classes: ^array [1 .. * ] of ost$name;

    params_size_to_send_to_client := 0;
    data_size_to_send_to_client := 0;

{ Return the default attributes.

    IF default_attributes <> NIL THEN
      number_of_def_attributes := UPPERBOUND (default_attributes^);
      IF number_of_def_attributes > 0 THEN
        NEXT send_default_attributes: [1 .. number_of_def_attributes] IN p_params_to_send_to_client;
        FOR item_index := 1 TO number_of_def_attributes DO
          send_default_attributes^ [item_index] := default_attributes^ [item_index];
          IF send_default_attributes^ [item_index].key = avc$valid_job_classes_key THEN
            NEXT send_valid_job_classes: [1 .. UPPERBOUND (send_default_attributes^ [item_index].
                  job_classes^)] IN p_data_to_send_to_client;
            FOR index := 1 TO UPPERBOUND (send_valid_job_classes^) DO
              send_valid_job_classes^ [index] := default_attributes^ [item_index].job_classes^ [index];
            FOREND;
          ELSEIF send_default_attributes^ [item_index].key = avc$labeled_names_key THEN
            NEXT number_of_labeled_names IN p_data_to_send_to_client;
            number_of_labeled_names^ := UPPERBOUND (default_attributes^ [item_index].labeled_names^);
            FOR index := 1 TO number_of_labeled_names^ DO
              NEXT label IN p_data_to_send_to_client;
              label^ := default_attributes^ [item_index].labeled_names^ [index].label^;
              NEXT number_of_names IN p_data_to_send_to_client;
              number_of_names^ := UPPERBOUND (default_attributes^ [item_index].labeled_names^ [index].names^);
              FOR index2 := 1 TO number_of_names^ DO
                NEXT name IN p_data_to_send_to_client;
                name^ := default_attributes^ [item_index].labeled_names^ [index].names^ [index2];
              FOREND;
            FOREND;
          IFEND;
        FOREND;
      IFEND;
    IFEND;

    params_size_to_send_to_client := i#current_sequence_position (p_params_to_send_to_client);
    data_size_to_send_to_client := i#current_sequence_position (p_data_to_send_to_client);

  PROCEND build_info_to_send_to_client;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    PUSH job_class_list: [1 .. avc$maximum_name_list_size];
    PUSH labeled_names_work_area: [[REP avc$max_template_record_size OF cell]];
    RESET labeled_names_work_area;
    extract_info_sent_from_client (p_params_received_from_client, p_data_received_from_client,
          validation_level, user_name, family_name, validation_attributes, default_attributes,
          job_class_list, labeled_names_work_area);

    prevalidate_job (validation_level, user_name, family_name, validation_attributes, default_attributes,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    build_info_to_send_to_client (default_attributes, p_params_to_send_to_client, p_data_to_send_to_client,
          params_size_to_send_to_client, data_size_to_send_to_client);

  PROCEND avp$server_prevalidate_job;
?? OLDTITLE ??
?? TITLE := '  Interfaces to create validation records' ??
?? NEWTITLE := '    avp$create_account_member_rec', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to put an account member record into the validation
{ file, and stores the record for subsequent changing of the field values
{ within the record.
{
{ DESIGN:
{
{ This interface is only callable by family administrators or above.
{
{   A validation record is put into the validation file and the record is
{ stored into the validation record information chain.  The record_id for this
{ validation record information entry is returned to the caller.
{
{   The number of command entries in the record utility information for this
{ record is returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$create_account_member_rec
    (    account_name: avt$account_name;
         user_name: ost$user_name;
     VAR record_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      account_exists: boolean,
      audit_information: sft$audit_information,
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      description_record_name: ost$name,
      ignore_status: ost$status,
      key: avt$validation_key,
      local_account_name: avt$account_name,
      local_user_name: ost$user_name,
      record_utility_info_header: ^avt$record_utility_info_header,
      record_utility_info_size: integer,
      validation_record_info: ^avt$validation_record_info;

    status.normal := TRUE;
    record_id := osc$null_name;
    #CALLER_ID (caller_id);

  /create_account_member/
    BEGIN

{ Verify caller authority.

    determine_caller_authority (caller_id, ^account_name, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$account_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      EXIT /create_account_member/;
    IFEND;

{ Verify that a matching account exists for this account member.

    avp$verify_account_exists (account_name, account_exists, file_information, status);
    IF NOT status.normal THEN
      EXIT /create_account_member/;
    IFEND;
    IF NOT account_exists THEN
      osp$set_status_abnormal ('AV', ave$account_does_not_exist, account_name, status);
      EXIT /create_account_member/;
    IFEND;

{ Verify that reserved names are not being used.

    IF ((user_name = 'ALL') OR (user_name = 'NONE') OR (user_name = 'DEFAULT')) THEN
      osp$set_status_abnormal ('AV', ave$reserved_name_not_valid, user_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'account member', status);
      EXIT /create_account_member/;
    IFEND;

{ Create the account member record.

    key.account_name := account_name;
    key.project_name := osc$null_name;
    key.user_name := user_name;
    avp$create_data_record (key.value, avc$account_member_record_name, NIL, file_information, status);
    IF NOT status.normal THEN
      IF status.condition = ave$record_already_exists THEN
        osp$set_status_abnormal ('AV', ave$acct_member_already_exists, user_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, account_name, status);
      IFEND;
      EXIT /create_account_member/;
    IFEND;

{ Read the account member record info and store it for later processing.

    local_account_name := account_name;
    local_user_name := user_name;
    read_account_member_record (caller_id, local_account_name, local_user_name, validation_record_info,
          file_information, status);
    IF NOT status.normal THEN
      EXIT /create_account_member/;
    IFEND;

    record_id := validation_record_info^.record_id;

{ Create a scratch segment to hold the field value changes.

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, validation_record_info^.work_area,
            status);
      IF NOT status.normal THEN
        EXIT /create_account_member/;
      IFEND;
      RESET validation_record_info^.work_area.sequence_pointer;

{ Retrieve the record utility information so that the number of
{ subcommand entries may be returned.

      avp$get_desc_utility_info (avc$account_member_record_name,
            validation_record_info^.work_area.sequence_pointer, file_information, status);
      IF NOT status.normal THEN
        EXIT /create_account_member/;
      IFEND;

      record_utility_info_size := i#current_sequence_position
            (validation_record_info^.work_area.sequence_pointer);
      RESET validation_record_info^.work_area.sequence_pointer;

      NEXT validation_record_info^.record_utility_information: [[REP record_utility_info_size OF cell]] IN
            validation_record_info^.work_area.sequence_pointer;
      RESET validation_record_info^.record_utility_information;
      NEXT record_utility_info_header IN validation_record_info^.record_utility_information;
      IF record_utility_info_header = NIL THEN
        corrupted_sequence ('AVP$CREATE_ACCOUNT_MEMBER_REC', 'RECORD_UTILITY_INFO_HEADER',
              'RECORD_UTILITY_INFORMATION', status);
        EXIT /create_account_member/;
      IFEND;
      number_of_command_entries := record_utility_info_header^.number_of_entries;

    END /create_account_member/;

    IF (NOT status.normal) AND (record_id <> osc$null_name) THEN
      avp$release_record_id (record_id, ignore_status);
      record_id := osc$null_name;
    IFEND;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_information.audited_operation := sfc$ao_val_create_record;
      description_record_name := avc$account_member_record_name;
      audit_information.create_validation_record.description_record_name_p := ^description_record_name;
      audit_information.create_validation_record.validation_file_p := ^file_information.file_name;
      audit_information.create_validation_record.user_name_p := ^user_name;
      audit_information.create_validation_record.account_name_p := ^account_name;
      audit_information.create_validation_record.project_name_p := NIL;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;

  PROCEND avp$create_account_member_rec;
?? TITLE := '    avp$create_account_record', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to put an account record into the validation
{ file, and stores the record for subsequent changing of the field values
{ within the record.
{
{ DESIGN:
{
{ This interface is only callable by family administrators or above.
{
{   A validation record is put into the validation file and the record is
{ stored into the validation record information chain.  The record_id for this
{ validation record information entry is passed to the caller.
{
{   The number of command entries in the record utility information for this
{ record is returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$create_account_record
    (    account_name: avt$account_name;
     VAR record_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      audit_information: sft$audit_information,
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      description_record_name: ost$name,
      ignore_status: ost$status,
      key: avt$validation_key,
      local_account_name: avt$account_name,
      record_utility_info_header: ^avt$record_utility_info_header,
      record_utility_info_size: integer,
      utility_information: ^avt$utility_information,
      validation_record_info: ^avt$validation_record_info;

    status.normal := TRUE;
    record_id := osc$null_name;
    #CALLER_ID (caller_id);

  /create_account/
    BEGIN

{ Verify caller authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$family_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      EXIT /create_account/;
    IFEND;

{ Verify that reserved names are not being used.

    IF ((account_name = 'ALL') OR (account_name = 'NONE') OR (account_name = 'DEFAULT') OR (account_name =
          'PUBLIC')) THEN
      osp$set_status_abnormal ('AV', ave$reserved_name_not_valid, account_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'account', status);
      EXIT /create_account/;
    IFEND;

{ Create the account record.

    key.account_name := account_name;
    key.project_name := osc$null_name;
    key.user_name := osc$null_name;
    avp$create_data_record (key.value, avc$account_record_name, NIL, file_information, status);
    IF NOT status.normal THEN
      IF status.condition = ave$record_already_exists THEN
        osp$set_status_abnormal ('AV', ave$account_already_exists, account_name, status);
      IFEND;
      EXIT /create_account/;
    IFEND;

{ Read the account record info and store it for later processing.

    local_account_name := account_name;
    read_account_record (caller_id, local_account_name, validation_record_info, file_information, status);
    IF NOT status.normal THEN
      EXIT /create_account/;
    IFEND;

    record_id := validation_record_info^.record_id;

{ Create a scratch segment to hold the field value changes.

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, validation_record_info^.work_area,
            status);
      IF NOT status.normal THEN
        EXIT /create_account/;
      IFEND;
      RESET validation_record_info^.work_area.sequence_pointer;

{ Retrieve the record utility information so that the number of
{ subcommand entries may be returned.

      avp$get_desc_utility_info (avc$account_record_name, validation_record_info^.work_area.sequence_pointer,
            file_information, status);
      IF NOT status.normal THEN
        EXIT /create_account/;
      IFEND;

      record_utility_info_size := i#current_sequence_position
            (validation_record_info^.work_area.sequence_pointer);
      RESET validation_record_info^.work_area.sequence_pointer;

      NEXT validation_record_info^.record_utility_information: [[REP record_utility_info_size OF cell]] IN
            validation_record_info^.work_area.sequence_pointer;
      RESET validation_record_info^.record_utility_information;
      NEXT record_utility_info_header IN validation_record_info^.record_utility_information;
      IF record_utility_info_header = NIL THEN
        corrupted_sequence ('AVP$CREATE_ACCOUNT_RECORD', 'RECORD_UTILITY_INFO_HEADER',
              'RECORD_UTILITY_INFORMATION', status);
        EXIT /create_account/;
      IFEND;
      number_of_command_entries := record_utility_info_header^.number_of_entries;

    END /create_account/;

    IF (NOT status.normal) AND (record_id <> osc$null_name) THEN
      avp$release_record_id (record_id, ignore_status);
      record_id := osc$null_name;
    IFEND;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_information.audited_operation := sfc$ao_val_create_record;
      description_record_name := avc$account_record_name;
      audit_information.create_validation_record.description_record_name_p := ^description_record_name;
      audit_information.create_validation_record.validation_file_p := ^file_information.file_name;
      audit_information.create_validation_record.user_name_p := NIL;
      audit_information.create_validation_record.account_name_p := ^account_name;
      audit_information.create_validation_record.project_name_p := NIL;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;

  PROCEND avp$create_account_record;
?? TITLE := '    avp$create_project_member_rec', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to put a project member record into the validation
{ file, and stores the record for subsequent changing of the field values
{ within the record.
{
{ DESIGN:
{
{ This interface is only callable by project administrators or above.
{
{   A validation record is put into the validation file and the record is
{ stored into the validation record information chain.  The record_id for this
{ validation record information entry is passed to the caller.
{
{   The number of command entries in the record utility information for this
{ record is returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$create_project_member_rec
    (    account_name: avt$account_name;
         project_name: avt$project_name;
         user_name: ost$user_name;
     VAR record_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      audit_information: sft$audit_information,
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      description_record_name: ost$name,
      ignore_status: ost$status,
      key: avt$validation_key,
      local_account_name: avt$account_name,
      local_project_name: avt$project_name,
      local_user_name: ost$user_name,
      project_exists: boolean,
      record_utility_info_header: ^avt$record_utility_info_header,
      record_utility_info_size: integer,
      validation_record_info: ^avt$validation_record_info;

    status.normal := TRUE;
    record_id := osc$null_name;
    #CALLER_ID (caller_id);

  /create_project_member/
    BEGIN

{ Verify caller authority.

    determine_caller_authority (caller_id, ^account_name, ^project_name, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$project_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      EXIT /create_project_member/;
    IFEND;

{ Verify that a matching project exists for this project member.

    avp$verify_project_exists (account_name, project_name, project_exists, file_information, status);
    IF NOT status.normal THEN
      EXIT /create_project_member/;
    IFEND;
    IF NOT project_exists THEN
      osp$set_status_abnormal ('AV', ave$project_does_not_exist, project_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, account_name, status);
      EXIT /create_project_member/;
    IFEND;

{ Verify that reserved names are not being used.

    IF ((user_name = 'ALL') OR (user_name = 'NONE') OR (user_name = 'DEFAULT')) THEN
      osp$set_status_abnormal ('AV', ave$reserved_name_not_valid, user_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'project member', status);
      EXIT /create_project_member/;
    IFEND;

{ Create the project member record.

    key.account_name := account_name;
    key.project_name := project_name;
    key.user_name := user_name;
    avp$create_data_record (key.value, avc$project_member_record_name, NIL, file_information, status);
    IF NOT status.normal THEN
      IF status.condition = ave$record_already_exists THEN
        osp$set_status_abnormal ('AV', ave$proj_member_already_exists, user_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, project_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, account_name, status);
      IFEND;
      EXIT /create_project_member/;
    IFEND;

{ Read the project member record info and store it for later processing.

    local_account_name := account_name;
    local_project_name := project_name;
    local_user_name := user_name;
    read_project_member_record (caller_id, local_account_name, local_project_name, local_user_name,
          validation_record_info, file_information, status);
    IF NOT status.normal THEN
      EXIT /create_project_member/;
    IFEND;

    record_id := validation_record_info^.record_id;

{ Create a scratch segment to hold the field value changes.

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, validation_record_info^.work_area,
            status);
      IF NOT status.normal THEN
        EXIT /create_project_member/;
      IFEND;
      RESET validation_record_info^.work_area.sequence_pointer;

{ Retrieve the record utility information so that the number of
{ subcommand entries may be returned.

      avp$get_desc_utility_info (avc$project_member_record_name,
            validation_record_info^.work_area.sequence_pointer, file_information, status);
      IF NOT status.normal THEN
        EXIT /create_project_member/;
      IFEND;

      record_utility_info_size := i#current_sequence_position
            (validation_record_info^.work_area.sequence_pointer);
      RESET validation_record_info^.work_area.sequence_pointer;

      NEXT validation_record_info^.record_utility_information: [[REP record_utility_info_size OF cell]] IN
            validation_record_info^.work_area.sequence_pointer;
      RESET validation_record_info^.record_utility_information;
      NEXT record_utility_info_header IN validation_record_info^.record_utility_information;
      IF record_utility_info_header = NIL THEN
        corrupted_sequence ('AVP$CREATE_PROJECT_MEMBER_REC', 'RECORD_UTILITY_INFO_HEADER',
              'RECORD_UTILITY_INFORMATION', status);
        EXIT /create_project_member/;
      IFEND;
      number_of_command_entries := record_utility_info_header^.number_of_entries;

    END /create_project_member/;

    IF (NOT status.normal) AND (record_id <> osc$null_name) THEN
      avp$release_record_id (record_id, ignore_status);
      record_id := osc$null_name;
    IFEND;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_information.audited_operation := sfc$ao_val_create_record;
      description_record_name := avc$project_member_record_name;
      audit_information.create_validation_record.description_record_name_p := ^description_record_name;
      audit_information.create_validation_record.validation_file_p := ^file_information.file_name;
      audit_information.create_validation_record.user_name_p := ^user_name;
      audit_information.create_validation_record.account_name_p := ^account_name;
      audit_information.create_validation_record.project_name_p := ^project_name;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;

  PROCEND avp$create_project_member_rec;
?? TITLE := '    avp$create_project_record', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to put a project record into the validation
{ file, and stores the record for subsequent changing of the field values
{ within the record.
{
{ DESIGN:
{
{ This interface is only callable by account administrators or above.
{
{   A validation record is put into the validation file and the record is
{ stored into the validation record information chain.  The record_id for this
{ validation record information entry is passed to the caller.
{
{   The number of command entries in the record utility information for this
{ record is returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$create_project_record
    (    account_name: avt$account_name;
         project_name: avt$project_name;
     VAR record_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      account_exists: boolean,
      audit_information: sft$audit_information,
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      description_record_name: ost$name,
      ignore_status: ost$status,
      local_account_name: avt$account_name,
      local_project_name: avt$project_name,
      key: avt$validation_key,
      record_utility_info_header: ^avt$record_utility_info_header,
      record_utility_info_size: integer,
      validation_record_info: ^avt$validation_record_info;

    status.normal := TRUE;
    record_id := osc$null_name;
    #CALLER_ID (caller_id);

  /create_project/
    BEGIN

{ Verify caller authority.

    determine_caller_authority (caller_id, ^account_name, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$account_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      EXIT /create_project/;
    IFEND;

{ Verify that a matching account exists for this project.

    key.account_name := account_name;
    key.project_name := osc$null_name;
    key.user_name := osc$null_name;
    account_exists := FALSE;
    avp$determine_if_key_exists (key.value, account_exists, file_information, ignore_status);
    IF NOT account_exists THEN
      osp$set_status_abnormal ('AV', ave$account_does_not_exist, account_name, status);
      EXIT /create_project/;
    IFEND;

{ Verify that reserved names are not being used.

    IF ((project_name = 'ALL') OR (project_name = 'NONE') OR (project_name = 'DEFAULT') OR (project_name =
          'PUBLIC')) THEN
      osp$set_status_abnormal ('AV', ave$reserved_name_not_valid, project_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'project', status);
      EXIT /create_project/;
    IFEND;

{ Create the project record.

    key.project_name := project_name;
    avp$create_data_record (key.value, avc$project_record_name, NIL, file_information, status);
    IF NOT status.normal THEN
      IF status.condition = ave$record_already_exists THEN
        osp$set_status_abnormal ('AV', ave$project_already_exists, project_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, account_name, status);
      IFEND;
      EXIT /create_project/;
    IFEND;

{ Read the project record info and store it for later processing.

    local_account_name := account_name;
    local_project_name := project_name;
    read_project_record (caller_id, local_account_name, local_project_name, validation_record_info,
          file_information, status);
    IF NOT status.normal THEN
      EXIT /create_project/;
    IFEND;

    record_id := validation_record_info^.record_id;

{ Create a scratch segment to hold the field value changes.

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, validation_record_info^.work_area,
            status);
      IF NOT status.normal THEN
        EXIT /create_project/;
      IFEND;
      RESET validation_record_info^.work_area.sequence_pointer;

{ Retrieve the record utility information so that the number of
{ subcommand entries may be returned.

      avp$get_desc_utility_info (avc$project_record_name, validation_record_info^.work_area.sequence_pointer,
            file_information, status);
      IF NOT status.normal THEN
        EXIT /create_project/;
      IFEND;

      record_utility_info_size := i#current_sequence_position
            (validation_record_info^.work_area.sequence_pointer);
      RESET validation_record_info^.work_area.sequence_pointer;

      NEXT validation_record_info^.record_utility_information: [[REP record_utility_info_size OF cell]] IN
            validation_record_info^.work_area.sequence_pointer;
      RESET validation_record_info^.record_utility_information;
      NEXT record_utility_info_header IN validation_record_info^.record_utility_information;
      IF record_utility_info_header = NIL THEN
        corrupted_sequence ('AVP$CREATE_PROJECT_RECORD', 'RECORD_UTILITY_INFO_HEADER',
              'RECORD_UTILITY_INFORMATION', status);
        EXIT /create_project/;
      IFEND;
      number_of_command_entries := record_utility_info_header^.number_of_entries;

    END /create_project/;

    IF (NOT status.normal) AND (record_id <> osc$null_name) THEN
      avp$release_record_id (record_id, ignore_status);
      record_id := osc$null_name;
    IFEND;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_information.audited_operation := sfc$ao_val_create_record;
      description_record_name := avc$project_record_name;
      audit_information.create_validation_record.description_record_name_p := ^description_record_name;
      audit_information.create_validation_record.validation_file_p := ^file_information.file_name;
      audit_information.create_validation_record.user_name_p := NIL;
      audit_information.create_validation_record.account_name_p := ^account_name;
      audit_information.create_validation_record.project_name_p := ^project_name;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;

  PROCEND avp$create_project_record;
?? TITLE := '    avp$create_user_record', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to put a user record into the validation
{ file, and stores the record for subsequent changing of the field values
{ within the record.
{
{ DESIGN:
{
{ This interface is only callable by user administrators or above.
{
{   A validation record is put into the validation file and the record is
{ stored into the validation record information chain.  The record_id for this
{ validation record information entry is passed to the caller.
{
{   The number of command entries in the record utility information for this
{ record is returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$create_user_record
    (    user_name: ost$user_name;
     VAR record_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      audit_information: sft$audit_information,
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      cycle_selection: pft$cycle_selector,
      cycle_no: pft$cycle_number,
      default_value: avt$field_value,
      descriptive_text: ^avt$descriptive_text,
      description_record_name: ost$name,
      evaluated_file_reference: fst$evaluated_file_reference,
      executing_account_name: avt$account_name,
      executing_project_name: avt$project_name,
      field_value_list_entry: ^avt$field_value_list_entry,
      ignore_status: ost$status,
      key: avt$validation_key,
      local_status: ost$status,
      local_user_name: ost$user_name,
      path: ^pft$path,
      record_utility_info_header: ^avt$record_utility_info_header,
      record_utility_info_size: integer,
      type_specification: avt$type_specification,
      string_value: ost$string,
      symptoms_out: fst$cycle_damage_symptoms,
      utility_information: ^avt$utility_information,
      validation_record_info: ^avt$validation_record_info;

    status.normal := TRUE;
    record_id := osc$null_name;
    #CALLER_ID (caller_id);

  /create_user/
    BEGIN

{ Verify caller authority.

    executing_account_name := osc$null_name;
    executing_project_name := osc$null_name;
    pmp$get_account_project (executing_account_name, executing_project_name, ignore_status);
    determine_caller_authority (caller_id, NIL, NIL, NIL, ^executing_account_name, ^executing_project_name,
          caller_authority);
    IF caller_authority < avc$user_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      EXIT /create_user/;
    IFEND;

{ Record the creation account and project if this is a user administrator.

    IF caller_authority < avc$family_admin_authority THEN
      PUSH field_value_list_entry;
      field_value_list_entry^.field_name := avc$creation_account_project;
      field_value_list_entry^.field_value.kind := avc$account_project_kind;
      field_value_list_entry^.field_value.account_name := ^executing_account_name;
      field_value_list_entry^.field_value.project_name := ^executing_project_name;
      field_value_list_entry^.forward := NIL;
    ELSE
      field_value_list_entry := NIL;
    IFEND;

{ Verify that reserved names are not being used.

    IF ((user_name = 'ALL') OR (user_name = 'NONE') OR (user_name = 'DEFAULT') OR (user_name = 'PUBLIC')) THEN
      osp$set_status_abnormal ('AV', ave$reserved_name_not_valid, user_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'user', status);
      EXIT /create_user/;
    IFEND;

{ Create the user record.

    key.account_name := avc$high_value_name;
    key.project_name := avc$high_value_name;
    key.user_name := user_name;
    avp$create_data_record (key.value, avc$user_record_name, field_value_list_entry, file_information,
          status);
    IF NOT status.normal THEN
      IF status.condition = ave$record_already_exists THEN
        osp$set_status_abnormal ('AV', ave$user_already_exists, user_name, status);
      IFEND;
      EXIT /create_user/;
    IFEND;

{ Read the user record info and store it for later processing.

    local_user_name := user_name;
    read_user_record (caller_id, local_user_name, validation_record_info, file_information, status);
    IF NOT status.normal THEN
      EXIT /create_user/;
    IFEND;

    record_id := validation_record_info^.record_id;

{ Create a scratch segment to hold the field value changes.

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, validation_record_info^.work_area,
            status);
      IF NOT status.normal THEN
        EXIT /create_user/;
      IFEND;
      RESET validation_record_info^.work_area.sequence_pointer;

{ Retrieve the record utility information so that the number of
{ subcommand entries may be returned.

      avp$get_desc_utility_info (avc$user_record_name, validation_record_info^.work_area.sequence_pointer,
            file_information, status);
      IF NOT status.normal THEN
        EXIT /create_user/;
      IFEND;

      record_utility_info_size := i#current_sequence_position
            (validation_record_info^.work_area.sequence_pointer);
      RESET validation_record_info^.work_area.sequence_pointer;

      NEXT validation_record_info^.record_utility_information: [[REP record_utility_info_size OF cell]] IN
            validation_record_info^.work_area.sequence_pointer;
      RESET validation_record_info^.record_utility_information;
      NEXT record_utility_info_header IN validation_record_info^.record_utility_information;
      IF record_utility_info_header = NIL THEN
        corrupted_sequence ('AVP$CREATE_USER_RECORD', 'RECORD_UTILITY_INFO_HEADER',
              'RECORD_UTILITY_INFORMATION', status);
        EXIT /create_user/;
      IFEND;
      number_of_command_entries := record_utility_info_header^.number_of_entries;

{ Get the default login password.

      avp$get_field_description (avc$login_password, validation_record_info^.description_record,
            {field_work_area=} NIL, type_specification, default_value, descriptive_text, utility_information,
            status);
      IF NOT status.normal THEN
        EXIT /create_user/;
      IFEND;

{ Change the login password to the default. (This will cause it to be encrypted)

      avp$change_login_password_value (avc$login_password, NIL, default_value.login_password, NIL, NIL, NIL,
            NIL, NIL, NIL, NIL, record_id, { update_batch_job_passwords = } FALSE, file_information, status);
      IF NOT status.normal THEN
        EXIT /create_user/;
      IFEND;

{ Set up the dual state link attribute user to default to the user.

      string_value.size := clp$trimmed_string_size (user_name);
      string_value.value := user_name;
      avp$change_string_value (avc$link_attribute_user, ^string_value, record_id, file_information, status);

    END /create_user/;

    IF NOT status.normal THEN
      IF record_id <> osc$null_name THEN
        avp$release_record_id (record_id, ignore_status);
        record_id := osc$null_name;
      IFEND;
    ELSE

{ Issue a warning if the master catalog already exists for this user.

      clp$evaluate_file_reference (file_information.file_name, $clt$file_ref_parsing_options[], TRUE,
            evaluated_file_reference, status);
      IF status.normal THEN
        IF (evaluated_file_reference.number_of_path_elements = 3) AND
          (fsp$path_element (^evaluated_file_reference, 2)^ = jmc$system_user) AND
          (fsp$path_element (^evaluated_file_reference, 3)^ = avc$validation_file_name) THEN

          PUSH path: [1 .. 3];
          path^ [1] := fsp$path_element (^evaluated_file_reference, 1)^;
          path^ [2] := user_name;
          pmp$get_unique_name (path^ [3], status);
          IF status.normal THEN
            cycle_selection.cycle_option := pfc$highest_cycle;
            pfp$utility_attach (path^ [3], path^, cycle_selection, osc$null_name, $pft$usage_selections [],
                  $pft$share_selections [], pfc$no_wait, $fst$cycle_damage_symptoms [], symptoms_out,
                  cycle_no, local_status);
            IF NOT local_status.normal THEN
              IF local_status.condition <> pfe$unknown_master_catalog THEN
                osp$set_status_abnormal ('AV', ave$master_catalog_exists, user_name, status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_information.audited_operation := sfc$ao_val_create_record;
      description_record_name := avc$user_record_name;
      audit_information.create_validation_record.description_record_name_p := ^description_record_name;
      audit_information.create_validation_record.validation_file_p := ^file_information.file_name;
      audit_information.create_validation_record.user_name_p := ^user_name;
      audit_information.create_validation_record.account_name_p := NIL;
      audit_information.create_validation_record.project_name_p := NIL;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;

  PROCEND avp$create_user_record;
?? OLDTITLE ??
?? TITLE := '  Interfaces to read validation records' ??
?? NEWTITLE := '    avp$read_account_member_record', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to read an account member record and store it
{ so that the field values within the record can be displayed by
{ authorized callers.
{
{ DESIGN:
{
{   This interface verifies that a matching account exists for the requested
{ account member and then calls a local procedure to read the account member
{ record into memory.
{
{   The assigned record id is returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$read_account_member_record
    (VAR account_name: avt$account_name;
     VAR user_name: ost$user_name;
     VAR record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      account_exists: boolean,
      caller_id: ost$caller_identifier,
      validation_record_info: ^avt$validation_record_info;

    #CALLER_ID (caller_id);

    status.normal := TRUE;

{ Verify a matching account record exists for the requested account member.

    avp$verify_account_exists (account_name, account_exists, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF account_exists THEN

{ Read the account member record and store it for later processing.

      read_account_member_record (caller_id, account_name, user_name, validation_record_info,
            file_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      record_id := validation_record_info^.record_id;
    ELSE
      osp$set_status_abnormal ('AV', ave$account_does_not_exist, account_name, status);
    IFEND;

  PROCEND avp$read_account_member_record;
?? TITLE := '    avp$read_account_record', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to read an account record and store it so that
{ the field values within the record can be displayed by authorized callers.
{
{ DESIGN:
{
{   This interface calls a local procedure to read the account record into
{ memory.
{
{   The assigned record id is returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$read_account_record
    (VAR account_name: avt$account_name;
     VAR record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      validation_record_info: ^avt$validation_record_info;

    #CALLER_ID (caller_id);

    status.normal := TRUE;

{ Read the account record and store it for later processing.

    read_account_record (caller_id, account_name, validation_record_info, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    record_id := validation_record_info^.record_id;

  PROCEND avp$read_account_record;
?? TITLE := '    avp$read_project_member_record', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to read a project member record and store it so
{ that the field values within the record can be displayed by authorized callers.
{
{ DESIGN:
{
{   This interface verifies that a matching account and project exist for the
{ requested project member and then calls a local procedure to read the project
{ member record into memory.
{
{   The assigned record id is returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$read_project_member_record
    (VAR account_name: avt$account_name;
     VAR project_name: avt$project_name;
     VAR user_name: ost$user_name;
     VAR record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      account_exists: boolean,
      caller_id: ost$caller_identifier,
      project_exists: boolean,
      validation_record_info: ^avt$validation_record_info;

    #CALLER_ID (caller_id);

    status.normal := TRUE;

{ Verify a matching account record exists for the requested project member.

    avp$verify_account_exists (account_name, account_exists, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF account_exists THEN

{ Verify a matching project record exists for the requested project member.

      avp$verify_project_exists (account_name, project_name, project_exists, file_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF project_exists THEN

{ Read the project member record and store it for later processing.

        read_project_member_record (caller_id, account_name, project_name, user_name, validation_record_info,
              file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        record_id := validation_record_info^.record_id;
      ELSE
        osp$set_status_abnormal ('AV', ave$project_does_not_exist, project_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, account_name, status);
      IFEND;
    ELSE
      osp$set_status_abnormal ('AV', ave$account_does_not_exist, account_name, status);
    IFEND;

  PROCEND avp$read_project_member_record;
?? TITLE := '    avp$read_project_record', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to read a project record and store it so that
{ the field values within the record can be displayed by authorized callers.
{
{ DESIGN:
{
{   This interface verifies that a matching account exists for the requested
{ project and then calls a local procedure to read the project
{ record into memory.
{
{   The assigned record id is returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$read_project_record
    (VAR account_name: avt$account_name;
     VAR project_name: avt$project_name;
     VAR record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      account_exists: boolean,
      caller_id: ost$caller_identifier,
      validation_record_info: ^avt$validation_record_info;

    #CALLER_ID (caller_id);

    status.normal := TRUE;

{ Verify a matching account record exists for the requested project.

    avp$verify_account_exists (account_name, account_exists, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF account_exists THEN

{ Read the project record and store it for later processing.

      read_project_record (caller_id, account_name, project_name, validation_record_info, file_information,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      record_id := validation_record_info^.record_id;
    ELSE
      osp$set_status_abnormal ('AV', ave$account_does_not_exist, account_name, status);
    IFEND;

  PROCEND avp$read_project_record;
?? TITLE := '    avp$read_user_record', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to read a user record and store it so that
{ the field values within the record can be displayed by authorized callers.
{
{ DESIGN:
{
{   This interface calls a local procedure to read the user into
{ memory.
{
{   The assigned record id is returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$read_user_record
    (VAR user_name: ost$user_name;
     VAR record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      validation_record_info: ^avt$validation_record_info;

    #CALLER_ID (caller_id);

    status.normal := TRUE;

{ Read the user record and store it for later processing.

    read_user_record (caller_id, user_name, validation_record_info, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    record_id := validation_record_info^.record_id;

  PROCEND avp$read_user_record;
?? OLDTITLE ??
?? TITLE := '  Interfaces to change validation records' ??
?? NEWTITLE := '    avp$change_account_member_rec', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to read an account member record and store it so that
{ the field values within the record can be changed by authorized callers.
{
{ DESIGN:
{
{   This interface calls a local procedure to read the account member record into
{ memory.
{
{   The number of command entries in the record utility information for this
{ record is returned to the caller.
{
{   The assigned record id is returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$change_account_member_rec
    (    account_name: avt$account_name;
         user_name: ost$user_name;
     VAR record_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      ignore_status: ost$status,
      key: avt$validation_key,
      local_account_name: avt$account_name,
      local_user_name: ost$user_name,
      record_utility_info_header: ^avt$record_utility_info_header,
      record_utility_info_size: integer,
      validation_record_info: ^avt$validation_record_info;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Read the account member to be changed and store it for later processing.

    local_account_name := account_name;
    local_user_name := user_name;
    read_account_member_record (caller_id, local_account_name, local_user_name, validation_record_info,
          file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    record_id := validation_record_info^.record_id;

  /change_account_member/
    BEGIN

{ Create a scratch segment to hold the field value changes.

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, validation_record_info^.work_area,
            status);
      IF NOT status.normal THEN
        EXIT /change_account_member/;
      IFEND;
      RESET validation_record_info^.work_area.sequence_pointer;

{ Retrieve the record utility information so that the number of
{ subcommand entries may be returned.

      avp$get_desc_utility_info (avc$account_member_record_name,
            validation_record_info^.work_area.sequence_pointer, file_information, status);
      IF NOT status.normal THEN
        EXIT /change_account_member/;
      IFEND;

      record_utility_info_size := i#current_sequence_position
            (validation_record_info^.work_area.sequence_pointer);
      RESET validation_record_info^.work_area.sequence_pointer;

      NEXT validation_record_info^.record_utility_information: [[REP record_utility_info_size OF cell]] IN
            validation_record_info^.work_area.sequence_pointer;
      RESET validation_record_info^.record_utility_information;
      NEXT record_utility_info_header IN validation_record_info^.record_utility_information;
      IF record_utility_info_header = NIL THEN
        corrupted_sequence ('AVP$CHANGE_ACCOUNT_MEMBER_REC', 'RECORD_UTILITY_INFO_HEADER',
              'RECORD_UTILITY_INFORMATION', status);
        EXIT /change_account_member/;
      IFEND;
      number_of_command_entries := record_utility_info_header^.number_of_entries;

    END /change_account_member/;

    IF NOT status.normal THEN
      avp$release_record_id (record_id, ignore_status);
      record_id := osc$null_name;
    IFEND;

  PROCEND avp$change_account_member_rec;
?? TITLE := '    avp$change_account_record', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to read an account record and store it so that
{ the field values within the record can be changed by authorized callers.
{
{ DESIGN:
{
{   This interface calls a local procedure to read the account record into
{ memory.
{
{   The number of command entries in the record utility information for this
{ record is returned to the caller.
{
{   The assigned record id is returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$change_account_record
    (    account_name: avt$account_name;
     VAR record_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      ignore_status: ost$status,
      key: avt$validation_key,
      local_account_name: avt$account_name,
      record_utility_info_header: ^avt$record_utility_info_header,
      record_utility_info_size: integer,
      validation_record_info: ^avt$validation_record_info;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Read the account to be changed and store it for later processing.

    local_account_name := account_name;
    read_account_record (caller_id, local_account_name, validation_record_info, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    record_id := validation_record_info^.record_id;

  /change_account/
    BEGIN

{ Create a scratch segment to hold the field value changes.

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, validation_record_info^.work_area,
            status);
      IF NOT status.normal THEN
        EXIT /change_account/;
      IFEND;
      RESET validation_record_info^.work_area.sequence_pointer;

{ Retrieve the record utility information so that the number of
{ subcommand entries may be returned.

      avp$get_desc_utility_info (avc$account_record_name, validation_record_info^.work_area.sequence_pointer,
            file_information, status);
      IF NOT status.normal THEN
        EXIT /change_account/;
      IFEND;

      record_utility_info_size := i#current_sequence_position
            (validation_record_info^.work_area.sequence_pointer);
      RESET validation_record_info^.work_area.sequence_pointer;

      NEXT validation_record_info^.record_utility_information: [[REP record_utility_info_size OF cell]] IN
            validation_record_info^.work_area.sequence_pointer;
      RESET validation_record_info^.record_utility_information;
      NEXT record_utility_info_header IN validation_record_info^.record_utility_information;
      IF record_utility_info_header = NIL THEN
        corrupted_sequence ('AVP$CHANGE_ACCOUNT_RECORD', 'RECORD_UTILITY_INFO_HEADER',
              'RECORD_UTILITY_INFORMATION', status);
        EXIT /change_account/;
      IFEND;
      number_of_command_entries := record_utility_info_header^.number_of_entries;

    END /change_account/;

    IF NOT status.normal THEN
      avp$release_record_id (record_id, ignore_status);
      record_id := osc$null_name;
    IFEND;

  PROCEND avp$change_account_record;
?? TITLE := '    avp$change_project_member_rec', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to read a project member record and store it so
{ that the field values within the record can be changed by authorized callers.
{
{ DESIGN:
{
{   This interface calls a local procedure to read the project member record into
{ memory.
{
{   The number of command entries in the record utility information for this
{ record is returned to the caller.
{
{   The assigned record id is returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$change_project_member_rec
    (    account_name: avt$account_name;
         project_name: avt$project_name;
         user_name: ost$user_name;
     VAR record_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      ignore_status: ost$status,
      key: avt$validation_key,
      local_account_name: avt$account_name,
      local_project_name: avt$project_name,
      local_user_name: ost$user_name,
      record_utility_info_header: ^avt$record_utility_info_header,
      record_utility_info_size: integer,
      validation_record_info: ^avt$validation_record_info;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Read the project member to be changed and store it for later processing.

    local_account_name := account_name;
    local_project_name := project_name;
    local_user_name := user_name;
    read_project_member_record (caller_id, local_account_name, local_project_name, local_user_name,
          validation_record_info, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    record_id := validation_record_info^.record_id;

  /change_project_member/
    BEGIN

{ Create a scratch segment to hold the field value changes.

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, validation_record_info^.work_area,
            status);
      IF NOT status.normal THEN
        EXIT /change_project_member/;
      IFEND;
      RESET validation_record_info^.work_area.sequence_pointer;

{ Retrieve the record utility information so that the number of
{ subcommand entries may be returned.

      avp$get_desc_utility_info (avc$project_member_record_name,
            validation_record_info^.work_area.sequence_pointer, file_information, status);
      IF NOT status.normal THEN
        EXIT /change_project_member/;
      IFEND;

      record_utility_info_size := i#current_sequence_position
            (validation_record_info^.work_area.sequence_pointer);
      RESET validation_record_info^.work_area.sequence_pointer;

      NEXT validation_record_info^.record_utility_information: [[REP record_utility_info_size OF cell]] IN
            validation_record_info^.work_area.sequence_pointer;
      RESET validation_record_info^.record_utility_information;
      NEXT record_utility_info_header IN validation_record_info^.record_utility_information;
      IF record_utility_info_header = NIL THEN
        corrupted_sequence ('AVP$CHANGE_PROJECT_MEMBER_REC', 'RECORD_UTILITY_INFO_HEADER',
              'RECORD_UTILITY_INFORMATION', status);
        EXIT /change_project_member/;
      IFEND;
      number_of_command_entries := record_utility_info_header^.number_of_entries;

    END /change_project_member/;

    IF NOT status.normal THEN
      avp$release_record_id (record_id, ignore_status);
      record_id := osc$null_name;
    IFEND;

  PROCEND avp$change_project_member_rec;
?? TITLE := '    avp$change_project_record', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to read a project record and store it so that
{ the field values within the record can be changed by authorized callers.
{
{ DESIGN:
{
{   This interface calls a local procedure to read the project record into
{ memory.
{
{   The number of command entries in the record utility information for this
{ record is returned to the caller.
{
{   The assigned record id is returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$change_project_record
    (    account_name: avt$account_name;
         project_name: avt$project_name;
     VAR record_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      ignore_status: ost$status,
      key: avt$validation_key,
      local_account_name: avt$account_name,
      local_project_name: avt$project_name,
      record_utility_info_header: ^avt$record_utility_info_header,
      record_utility_info_size: integer,
      validation_record_info: ^avt$validation_record_info;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Read the project to be changed and store it for later processing.

    local_account_name := account_name;
    local_project_name := project_name;
    read_project_record (caller_id, local_account_name, local_project_name, validation_record_info,
          file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    record_id := validation_record_info^.record_id;

  /change_project/
    BEGIN

{ Create a scratch segment to hold the field value changes.

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, validation_record_info^.work_area,
            status);
      IF NOT status.normal THEN
        EXIT /change_project/;
      IFEND;
      RESET validation_record_info^.work_area.sequence_pointer;

{ Retrieve the record utility information so that the number of
{ subcommand entries may be returned.

      avp$get_desc_utility_info (avc$project_record_name, validation_record_info^.work_area.sequence_pointer,
            file_information, status);
      IF NOT status.normal THEN
        EXIT /change_project/;
      IFEND;

      record_utility_info_size := i#current_sequence_position
            (validation_record_info^.work_area.sequence_pointer);
      RESET validation_record_info^.work_area.sequence_pointer;

      NEXT validation_record_info^.record_utility_information: [[REP record_utility_info_size OF cell]] IN
            validation_record_info^.work_area.sequence_pointer;
      RESET validation_record_info^.record_utility_information;
      NEXT record_utility_info_header IN validation_record_info^.record_utility_information;
      IF record_utility_info_header = NIL THEN
        corrupted_sequence ('AVP$CHANGE_PROJECT_RECORD', 'RECORD_UTILITY_INFO_HEADER',
              'RECORD_UTILITY_INFORMATION', status);
        EXIT /change_project/;
      IFEND;
      number_of_command_entries := record_utility_info_header^.number_of_entries;

    END /change_project/;

    IF NOT status.normal THEN
      avp$release_record_id (record_id, ignore_status);
      record_id := osc$null_name;
    IFEND;

  PROCEND avp$change_project_record;
?? TITLE := '    avp$change_user_record', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to read a user record and store it so that
{ the field values within the record can be changed by authorized callers.
{
{ DESIGN:
{
{   A less privileged user can not change the values of a more privileged user.
{
{   This interface calls a local procedure to read the user record into
{ memory.
{
{   The number of command entries in the record utility information for this
{ record is returned to the caller.
{
{   The assigned record id is returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$change_user_record
    (VAR user_name: ost$user_name;
     VAR record_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      default_value: avt$field_value,
      descriptive_text: ^avt$descriptive_text,
      family_admin_value: avt$field_value,
      field_value: avt$field_value,
      ignore_status: ost$status,
      key: avt$validation_key,
      record_utility_info_header: ^avt$record_utility_info_header,
      record_utility_info_size: integer,
      system_admin_value: avt$field_value,
      type_specification: avt$type_specification,
      user_identification: ost$user_identification,
      utility_information: ^avt$utility_information,
      validation_record_info: ^avt$validation_record_info;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Read the user to be changed and store it for later processing.

    read_user_record (caller_id, user_name, validation_record_info, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    record_id := validation_record_info^.record_id;

  /change_user/
    BEGIN

{ Determine if a system administrator is being changed.

      avp$get_field (avc$system_administration, validation_record_info^.data_record,
            validation_record_info^.description_record, validation_record_info^.work_area.sequence_pointer,
            system_admin_value, type_specification, default_value, descriptive_text, utility_information,
            status);
      IF NOT status.normal THEN
        EXIT /change_user/;
      IFEND;

{ Determine if a family administrator is being changed.

      avp$get_field (avc$family_administration, validation_record_info^.data_record,
            validation_record_info^.description_record, validation_record_info^.work_area.sequence_pointer,
            family_admin_value, type_specification, default_value, descriptive_text, utility_information,
            status);
      IF NOT status.normal THEN
        EXIT /change_user/;
      IFEND;

{ Verify that a less privileged user is not changing a more privileged user.

      IF ((system_admin_value.capability^) AND (validation_record_info^.caller_authority <
            avc$system_admin_authority)) OR ((family_admin_value.capability^) AND
            (validation_record_info^.caller_authority < avc$family_admin_authority)) THEN
        pmp$get_user_identification (user_identification, ignore_status);
        IF user_identification.user <> user_name THEN
          osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
          EXIT /change_user/;
        IFEND;
      IFEND;

{ Create a scratch segment to hold the field value changes.

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, validation_record_info^.work_area,
            status);
      IF NOT status.normal THEN
        EXIT /change_user/;
      IFEND;
      RESET validation_record_info^.work_area.sequence_pointer;

{ Retrieve the record utility information so that the number of
{ subcommand entries may be returned.

      avp$get_desc_utility_info (avc$user_record_name, validation_record_info^.work_area.sequence_pointer,
            file_information, status);
      IF NOT status.normal THEN
        EXIT /change_user/;
      IFEND;

      record_utility_info_size := i#current_sequence_position
            (validation_record_info^.work_area.sequence_pointer);
      RESET validation_record_info^.work_area.sequence_pointer;

      NEXT validation_record_info^.record_utility_information: [[REP record_utility_info_size OF cell]] IN
            validation_record_info^.work_area.sequence_pointer;
      RESET validation_record_info^.record_utility_information;
      NEXT record_utility_info_header IN validation_record_info^.record_utility_information;
      IF record_utility_info_header = NIL THEN
        corrupted_sequence ('AVP$CHANGE_USER_RECORD', 'RECORD_UTILITY_INFO_HEADER',
              'RECORD_UTILITY_INFORMATION', status);
        EXIT /change_user/;
      IFEND;
      number_of_command_entries := record_utility_info_header^.number_of_entries;

    END /change_user/;

    IF NOT status.normal THEN
      avp$release_record_id (record_id, ignore_status);
      record_id := osc$null_name;
    IFEND;

  PROCEND avp$change_user_record;
?? OLDTITLE ??
?? TITLE := '  Interfaces to delete validation records' ??
?? NEWTITLE := '    avp$delete_account_member_rec', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to delete a specified account member record, or all
{ account members of a specified account, from a validation file .
{
{ DESIGN:
{
{   This interface is only callable by account administrators or above.
{

  PROCEDURE [XDCL, #GATE] avp$delete_account_member_rec
    (    account_name: avt$account_name;
         user_name: ost$user_name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      account_administrator: boolean,
      audit_information: sft$audit_information,
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      description_record_name: ost$name,
      ending_key: avt$validation_key,
      executing_account_name: avt$account_name,
      executing_project_name: avt$project_name,
      ignore_status: ost$status,
      key: avt$validation_key,
      required_authority: avt$validation_authority,
      starting_key: avt$validation_key,
      type_specification: avt$type_specification,
      utility_information: ^avt$utility_information;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

  /delete_account_member/
    BEGIN

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, ^account_name, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$account_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      EXIT /delete_account_member/;
    IFEND;

{ Delete all members from the specified account if requested.

    IF user_name = 'ALL' THEN
      starting_key.account_name := account_name;
      starting_key.project_name := osc$null_name;
      starting_key.user_name := osc$null_name;
      ending_key.account_name := account_name;
      ending_key.project_name := osc$null_name;
      ending_key.user_name := avc$high_value_name;
      avp$delete_data_records (starting_key.value, ending_key.value, avc$account_member_record_name,
            file_information, status);
    ELSE

{ Delete the specified account member.

      key.account_name := account_name;
      key.project_name := osc$null_name;
      key.user_name := user_name;
      avp$delete_data_record (key.value, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$unknown_record THEN
          osp$set_status_abnormal ('AV', ave$acct_member_does_not_exist, user_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, account_name, status);
        IFEND;
      IFEND;
    IFEND;
    END /delete_account_member/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_information.audited_operation := sfc$ao_val_delete_record;
      description_record_name := avc$account_member_record_name;
      audit_information.delete_validation_record.description_record_name_p := ^description_record_name;
      audit_information.delete_validation_record.validation_file_p := ^file_information.file_name;
      audit_information.delete_validation_record.user_name_p := ^user_name;
      audit_information.delete_validation_record.account_name_p := ^account_name;
      audit_information.delete_validation_record.project_name_p := NIL;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;

  PROCEND avp$delete_account_member_rec;
?? TITLE := '    avp$delete_account_record', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to delete a specified account record, or all account
{ records, from a validation file.
{
{ DESIGN:
{
{   This interface is only callable by family administrators or above.
{
{   A specified account or all accounts may be deleted.
{
{   When any account is deleted all projects within the account (and
{ project members of those projects) are deleted, as well as all
{ account members of the account.
{

  PROCEDURE [XDCL, #GATE] avp$delete_account_record
    (    account_name: avt$account_name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      audit_information: sft$audit_information,
      ending_key: avt$validation_key,
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      description_record_name: ost$name,
      ignore_status: ost$status,
      key: avt$validation_key,
      starting_key: avt$validation_key;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

  /delete_account/
    BEGIN

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, ^account_name, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$family_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      EXIT /delete_account/;
    IFEND;

{ Delete all account information if specified.

    IF account_name = 'ALL' THEN
      starting_key.account_name := osc$null_name;
      starting_key.project_name := osc$null_name;
      starting_key.user_name := osc$null_name;
      ending_key.account_name := avc$high_value_name;
      ending_key.project_name := osc$null_name;
      ending_key.user_name := osc$null_name;

{ Delete all project members.

      avp$delete_data_records (starting_key.value, ending_key.value, avc$project_member_record_name,
            file_information, status);
      IF NOT status.normal THEN
        EXIT /delete_account/;
      IFEND;

{ Delete all projects.

      avp$delete_data_records (starting_key.value, ending_key.value, avc$project_record_name,
            file_information, status);
      IF NOT status.normal THEN
        EXIT /delete_account/;
      IFEND;

{ Delete all account members.

      avp$delete_data_records (starting_key.value, ending_key.value, avc$account_member_record_name,
            file_information, status);
      IF NOT status.normal THEN
        EXIT /delete_account/;
      IFEND;

{ Delete all accounts.

      avp$delete_data_records (starting_key.value, ending_key.value, avc$account_record_name,
            file_information, status);
    ELSE

{ Delete the specified accounts information.

      starting_key.account_name := account_name;
      starting_key.project_name := osc$null_name;
      starting_key.user_name := osc$null_name;
      ending_key.account_name := account_name;
      ending_key.project_name := avc$high_value_name;
      ending_key.user_name := avc$high_value_name;

{ Delete the project members within the specified account.

      avp$delete_data_records (starting_key.value, ending_key.value, avc$project_member_record_name,
            file_information, status);
      IF NOT status.normal THEN
        EXIT /delete_account/;
      IFEND;

{ Delete the projects within the specified account.

      avp$delete_data_records (starting_key.value, ending_key.value, avc$project_record_name,
            file_information, status);
      IF NOT status.normal THEN
        EXIT /delete_account/;
      IFEND;

{ Delete the account members within the specified account.

      avp$delete_data_records (starting_key.value, ending_key.value, avc$account_member_record_name,
            file_information, status);
      IF NOT status.normal THEN
        EXIT /delete_account/;
      IFEND;

{ Delete the specified account.

      key.account_name := account_name;
      key.project_name := osc$null_name;
      key.user_name := osc$null_name;

      avp$delete_data_record (key.value, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$unknown_record THEN
          osp$set_status_abnormal ('AV', ave$account_does_not_exist, account_name, status);
        IFEND;
      IFEND;
    IFEND;
    END /delete_account/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_information.audited_operation := sfc$ao_val_delete_record;
      description_record_name := avc$account_record_name;
      audit_information.delete_validation_record.description_record_name_p := ^description_record_name;
      audit_information.delete_validation_record.validation_file_p := ^file_information.file_name;
      audit_information.delete_validation_record.user_name_p := NIL;
      audit_information.delete_validation_record.account_name_p := ^account_name;
      audit_information.delete_validation_record.project_name_p := NIL;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;

  PROCEND avp$delete_account_record;
?? TITLE := '    avp$delete_project_member_rec', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to delete a specified project member record from a
{ validation file, or all project members of a specified account.
{
{ DESIGN:
{
{   This interface is only callable by project administrators or above.
{

  PROCEDURE [XDCL, #GATE] avp$delete_project_member_rec
    (    account_name: avt$account_name;
         project_name: avt$project_name;
         user_name: ost$user_name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      account_administrator: boolean,
      audit_information: sft$audit_information,
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      description_record_name: ost$name,
      ending_key: avt$validation_key,
      executing_account_name: avt$account_name,
      executing_project_name: avt$project_name,
      ignore_status: ost$status,
      key: avt$validation_key,
      required_authority: avt$validation_authority,
      starting_key: avt$validation_key,
      type_specification: avt$type_specification,
      utility_information: ^avt$utility_information;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

  /delete_project_member/
    BEGIN

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, ^account_name, ^project_name, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$project_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      EXIT /delete_project_member/;
    IFEND;

{ Delete all project member information for the specified account if specified.

    IF user_name = 'ALL' THEN
      starting_key.account_name := account_name;
      starting_key.project_name := project_name;
      starting_key.user_name := osc$null_name;
      ending_key.account_name := account_name;
      ending_key.project_name := project_name;
      ending_key.user_name := avc$high_value_name;

{ Delete all project members for the specified account.

      avp$delete_data_records (starting_key.value, ending_key.value, avc$project_member_record_name,
            file_information, status);
    ELSE

{ Delete the specified project member.

      key.account_name := account_name;
      key.project_name := project_name;
      key.user_name := user_name;
      avp$delete_data_record (key.value, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$unknown_record THEN
          osp$set_status_abnormal ('AV', ave$proj_member_does_not_exist, user_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, project_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, account_name, status);
        IFEND;
      IFEND;
    IFEND;
    END /delete_project_member/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_information.audited_operation := sfc$ao_val_delete_record;
      description_record_name := avc$project_member_record_name;
      audit_information.delete_validation_record.description_record_name_p := ^description_record_name;
      audit_information.delete_validation_record.validation_file_p := ^file_information.file_name;
      audit_information.delete_validation_record.user_name_p := ^user_name;
      audit_information.delete_validation_record.account_name_p := ^account_name;
      audit_information.delete_validation_record.project_name_p := ^project_name;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;

  PROCEND avp$delete_project_member_rec;
?? TITLE := '    avp$delete_project_record', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to delete a specified project record, or all project
{ records of a specified account, from a validation file.
{
{ DESIGN:
{
{   This interface is only callable by account administrators or above.
{

  PROCEDURE [XDCL, #GATE] avp$delete_project_record
    (    account_name: avt$account_name;
         project_name: avt$project_name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      account_administrator: boolean,
      audit_information: sft$audit_information,
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      description_record_name: ost$name,
      ending_key: avt$validation_key,
      executing_account_name: avt$account_name,
      executing_project_name: avt$project_name,
      key: avt$validation_key,
      ignore_status: ost$status,
      starting_key: avt$validation_key;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

  /delete_project/
    BEGIN

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, ^account_name, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$account_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      EXIT /delete_project/;
    IFEND;

{ Delete all project information for the specified account if specified.

    IF project_name = 'ALL' THEN
      starting_key.account_name := account_name;
      starting_key.project_name := osc$null_name;
      starting_key.user_name := osc$null_name;
      ending_key.account_name := account_name;
      ending_key.project_name := avc$high_value_name;
      ending_key.user_name := avc$high_value_name;

{ Delete project member records for the specified account.

      avp$delete_data_records (starting_key.value, ending_key.value, avc$project_member_record_name,
            file_information, status);
      IF NOT status.normal THEN
        EXIT /delete_project/;
      IFEND;

{ Delete project records for the specified account.

      avp$delete_data_records (starting_key.value, ending_key.value, avc$project_record_name,
            file_information, status);
    ELSE

{ delete all project members for the specified project.

      starting_key.account_name := account_name;
      starting_key.project_name := project_name;
      starting_key.user_name := osc$null_name;
      ending_key.account_name := account_name;
      ending_key.project_name := project_name;
      ending_key.user_name := avc$high_value_name;
      avp$delete_data_records (starting_key.value, ending_key.value, avc$project_member_record_name,
            file_information, status);
      IF NOT status.normal THEN
        EXIT /delete_project/;
      IFEND;

{ Delete the specified project.

      key.account_name := account_name;
      key.project_name := project_name;
      key.user_name := osc$null_name;
      avp$delete_data_record (key.value, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$unknown_record THEN
          osp$set_status_abnormal ('AV', ave$project_does_not_exist, project_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, account_name, status);
        IFEND;
      IFEND;
    IFEND;
    END /delete_project/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_information.audited_operation := sfc$ao_val_delete_record;
      description_record_name := avc$project_record_name;
      audit_information.delete_validation_record.description_record_name_p := ^description_record_name;
      audit_information.delete_validation_record.validation_file_p := ^file_information.file_name;
      audit_information.delete_validation_record.user_name_p := NIL;
      audit_information.delete_validation_record.account_name_p := ^account_name;
      audit_information.delete_validation_record.project_name_p := ^project_name;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;

  PROCEND avp$delete_project_record;
?? TITLE := '    avp$delete_user_record', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to delete a specified user record from a validation file.
{
{ DESIGN:
{
{   This interface is only callable by user administrators or above.
{
{   Deletion of the current executing user is not allowed.
{
{   A less privileged user can not delete a more privileged user.
{

  PROCEDURE [XDCL, #GATE] avp$delete_user_record
    (    user_name: ost$user_name;
         delete_files: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      audit_information: sft$audit_information,
      caller_id: ost$caller_identifier,
      default_value: avt$field_value,
      description_record_name: ost$name,
      descriptive_text: ^avt$descriptive_text,
      evaluated_file_reference: fst$evaluated_file_reference,
      executing_id: ost$user_identification,
      family_admin_value: avt$field_value,
      field_value: avt$field_value,
      ignore_status: ost$status,
      key: avt$validation_key,
      local_user_name: ost$user_name,
      number_of_command_entries: integer,
      path: ^pft$path,
      record_id: ost$name,
      set_name: stt$set_name,
      system_admin_value: avt$field_value,
      type_specification: avt$type_specification,
      user_path: ^pft$path,
      utility_information: ^avt$utility_information,
      validation_record_info: ^avt$validation_record_info;

?? NEWTITLE := '      block_exit_handler', EJECT ??
{
{ PURPOSE:
{
{   This block exit condition handler ensures that the family administration
{   flag used by permanent files is reset to the appropriate value if it has
{   been temporarily changed to allow a user administrator to delete the master
{   catalog for a user under the control of the user administrator.
{

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

      handler_status.normal := TRUE;

      pfp$set_family_administrator (FALSE);

    PROCEND block_exit_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    #CALLER_ID (caller_id);

  /delete_user/
    BEGIN

{ Verify that the current executing user is not being deleted.

    pmp$get_user_identification (executing_id, status);
    IF NOT status.normal THEN
      EXIT /delete_user/;
    IFEND;
    IF executing_id.user = user_name THEN
      osp$set_status_abnormal ('AV', ave$can_not_delete_current, 'USER', status);
      EXIT /delete_user/;
    IFEND;

    key.account_name := avc$high_value_name;
    key.project_name := avc$high_value_name;
    key.user_name := user_name;

{ Read the user being deleted to determine his administration privileges.
{ NOTE: This call will validate that the caller has user administration authority or above.

    local_user_name := user_name;
    read_user_record (caller_id, local_user_name, validation_record_info, file_information, status);
    IF NOT status.normal THEN
      EXIT /delete_user/;
    IFEND;

    record_id := validation_record_info^.record_id;

  /validation_record_read/
    BEGIN

{ Determine if the user being deleted is a system administrator.

      avp$get_field (avc$system_administration, validation_record_info^.data_record,
            validation_record_info^.description_record, validation_record_info^.work_area.sequence_pointer,
            system_admin_value, type_specification, default_value, descriptive_text, utility_information,
            status);
      IF NOT status.normal THEN
        EXIT /validation_record_read/;
      IFEND;

{ Determine if the user being deleted is a family administrator.

      avp$get_field (avc$family_administration, validation_record_info^.data_record,
            validation_record_info^.description_record, validation_record_info^.work_area.sequence_pointer,
            family_admin_value, type_specification, default_value, descriptive_text, utility_information,
            status);
      IF NOT status.normal THEN
        EXIT /validation_record_read/;
      IFEND;

{ Verify that a less privileged user is not deleting a more privileged user.

      IF ((system_admin_value.capability^) AND (validation_record_info^.caller_authority <
            avc$system_admin_authority)) OR ((family_admin_value.capability^) AND
            (validation_record_info^.caller_authority < avc$family_admin_authority)) THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /validation_record_read/;
      IFEND;

{ Delete all of the users files if requested.

      IF delete_files THEN

{ Determine if this is a system validation file.  If not, return an error.

        clp$evaluate_file_reference (file_information.file_name, $clt$file_ref_parsing_options[], TRUE,
              evaluated_file_reference, status);
        IF NOT status.normal THEN
          EXIT /validation_record_read/;
        IFEND;

        IF NOT ((evaluated_file_reference.number_of_path_elements = 3) AND
              (fsp$path_element (^evaluated_file_reference, 2)^ = jmc$system_user) AND
              (fsp$path_element (^evaluated_file_reference, 3)^ = avc$validation_file_name)) THEN
          osp$set_status_abnormal ('AV', ave$delete_files_not_allowed, '', status);
          EXIT /validation_record_read/;
        IFEND;

        PUSH user_path: [1 .. 2];
        user_path^ [1] := fsp$path_element (^evaluated_file_reference, 1)^;
        user_path^ [2] := user_name;

{ If the user doing the delete is a user administrator, temporarily make the user
{ look like a family administrator so that the permanent files may be deleted.

        IF validation_record_info^.caller_authority = avc$user_admin_authority THEN
          osp$establish_block_exit_hndlr (^block_exit_handler);
          pfp$set_family_administrator (TRUE);
        IFEND;

        pfp$purge_catalog_contents (user_path^, FALSE, status);
        IF NOT status.normal THEN
          IF status.condition = pfe$unknown_master_catalog THEN
            status.normal := TRUE;
          ELSE
            EXIT /validation_record_read/;
          IFEND;
        IFEND;

        osp$get_set_name (user_path^ [1], set_name, status);
        IF NOT status.normal THEN
          EXIT /validation_record_read/;
        IFEND;
        pfp$purge_master_catalog (set_name, user_path^ [1], user_name, status);
        IF NOT status.normal THEN
          IF status.condition = pfe$unknown_master_catalog THEN
            status.normal := TRUE;
          ELSE
            EXIT /validation_record_read/;
          IFEND;
        IFEND;

        IF validation_record_info^.caller_authority = avc$user_admin_authority THEN
          pfp$set_family_administrator (FALSE);
          osp$disestablish_cond_handler;
        IFEND;
      IFEND;

{ Delete the user record.

      avp$delete_data_record (key.value, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$unknown_record THEN
          osp$set_status_abnormal ('AV', ave$user_does_not_exist, user_name, status);
        IFEND;
        EXIT /validation_record_read/;
      IFEND;

    END /validation_record_read/;

    IF status.normal THEN
      avp$release_record_id (record_id, status);
    ELSE
      avp$release_record_id (record_id, ignore_status);
    IFEND;
    END /delete_user/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_information.audited_operation := sfc$ao_val_delete_record;
      description_record_name := avc$user_record_name;
      audit_information.delete_validation_record.description_record_name_p := ^description_record_name;
      audit_information.delete_validation_record.validation_file_p := ^file_information.file_name;
      audit_information.delete_validation_record.user_name_p := ^user_name;
      audit_information.delete_validation_record.account_name_p := NIL;
      audit_information.delete_validation_record.project_name_p := NIL;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;

  PROCEND avp$delete_user_record;
?? OLDTITLE ??
?? TITLE := '  Interfaces to verify validation records exist' ??
?? NEWTITLE := '    avp$verify_acct_member_exists', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to determine whether or not a specified account
{ member record exists on a validation file.
{
{ DESIGN:
{
{   This interface is only callable by account administrators or above.
{

  PROCEDURE [XDCL, #GATE] avp$verify_acct_member_exists
    (    account_name: avt$account_name;
         user_name: ost$user_name;
     VAR account_member_exists: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      account_exists: boolean,
      account_administrator: boolean,
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      executing_account_name: avt$account_name,
      executing_project_name: avt$project_name,
      ignore_status: ost$status,
      key: avt$validation_key;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, ^account_name, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$account_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Determine if a record for the specified account member exists on the
{ validation file.

    key.account_name := account_name;
    key.project_name := osc$null_name;
    key.user_name := user_name;
    avp$determine_if_key_exists (key.value, account_member_exists, file_information, status);
    IF NOT account_member_exists THEN

{ Reset the status if the account does not exist.

      account_exists := FALSE;
      avp$verify_account_exists (account_name, account_exists, file_information, ignore_status);
      IF NOT account_exists THEN
        osp$set_status_abnormal ('AV', ave$account_does_not_exist, account_name, status);
      IFEND;
    IFEND;

  PROCEND avp$verify_acct_member_exists;
?? TITLE := '    avp$verify_account_exists', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to determine whether or not a specified account
{ record exists on a validation file.
{
{ DESIGN:
{
{   This interface is not protected.
{

  PROCEDURE [XDCL, #GATE] avp$verify_account_exists
    (    account_name: avt$account_name;
     VAR account_exists: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      key: avt$validation_key;

    status.normal := TRUE;

{ Determine if a record for the specified account exists on the
{ validation file.

    key.account_name := account_name;
    key.project_name := osc$null_name;
    key.user_name := osc$null_name;
    avp$determine_if_key_exists (key.value, account_exists, file_information, status);

  PROCEND avp$verify_account_exists;
?? TITLE := '    avp$verify_project_exists', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to determine whether or not a specified project
{ record exists on a validation file.
{
{ DESIGN:
{
{   This interface is not protected.
{

  PROCEDURE [XDCL, #GATE] avp$verify_project_exists
    (    account_name: avt$account_name;
         project_name: avt$project_name;
     VAR project_exists: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      account_exists: boolean,
      ignore_status: ost$status,
      key: avt$validation_key;

    status.normal := TRUE;

{ Determine if a record for the specified project exists on the
{ validation file.

    key.account_name := account_name;
    key.project_name := project_name;
    key.user_name := osc$null_name;
    avp$determine_if_key_exists (key.value, project_exists, file_information, status);
    IF NOT project_exists THEN

{ Reset the status if the account does not exist.

      account_exists := FALSE;
      avp$verify_account_exists (account_name, account_exists, file_information, ignore_status);
      IF NOT account_exists THEN
        osp$set_status_abnormal ('AV', ave$account_does_not_exist, account_name, status);
      IFEND;
    IFEND;

  PROCEND avp$verify_project_exists;
?? TITLE := '    avp$verify_proj_member_exists', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to determine whether or not a specified project
{ member record exists on a validation file.
{
{ DESIGN:
{
{   This interface is only callable by project administrators or above.
{

  PROCEDURE [XDCL, #GATE] avp$verify_proj_member_exists
    (    account_name: avt$account_name;
         project_name: avt$project_name;
         user_name: ost$user_name;
     VAR project_member_exists: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      account_exists: boolean,
      account_administrator: boolean,
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      project_administrator: boolean,
      project_exists: boolean,
      executing_account_name: avt$account_name,
      executing_project_name: avt$project_name,
      ignore_status: ost$status,
      key: avt$validation_key;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, ^account_name, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$project_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Determine if a record for the specified project member exists on the
{ validation file.

    key.account_name := account_name;
    key.project_name := project_name;
    key.user_name := user_name;
    avp$determine_if_key_exists (key.value, project_member_exists, file_information, status);
    IF NOT project_member_exists THEN

      { Reset the status if the project does not exist.

      project_exists := FALSE;
      avp$verify_project_exists (account_name, project_name, project_exists, file_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF NOT project_exists THEN
        osp$set_status_abnormal ('AV', ave$project_does_not_exist, project_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, account_name, status);
      IFEND;

    IFEND;

  PROCEND avp$verify_proj_member_exists;
?? TITLE := '    avp$verify_user_exists', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to determine whether or not a specified user
{ record exists on a validation file.
{
{ DESIGN:
{
{   This interface is only callable by user administrators or above.
{

  PROCEDURE [XDCL, #GATE] avp$verify_user_exists
    (    user_name: ost$user_name;
     VAR user_exists: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      account_administrator: boolean,
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      creation_account_name: avt$account_name,
      creation_project_name: avt$project_name,
      data_record: ^avt$template_file_record,
      data_record_size: 0 .. avc$max_template_record_size,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      description_record_name: ost$name,
      description_record_size: 0 .. avc$max_template_record_size,
      descriptive_text: ^avt$descriptive_text,
      executing_account_name: avt$account_name,
      executing_project_name: avt$project_name,
      executing_user_name: ost$user_identification,
      field_count: avt$field_count,
      field_value: avt$field_value,
      ignore_status: ost$status,
      key: avt$validation_key,
      type_specification: avt$type_specification,
      utility_information: ^avt$utility_information;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$user_authority THEN

{ Determine if caller has user administration authority for this user.

      key.account_name := avc$high_value_name;
      key.project_name := avc$high_value_name;
      key.user_name := user_name;
      PUSH data_record: [[REP avc$max_template_record_size OF cell]];
      RESET data_record;
      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;

{ Read the user record to get the creation account and project.

      avp$read_data_record (key.value, avc$read_access, TRUE, data_record, data_record_size,
            description_record, description_record_size, description_record_name, field_count,
            file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$unknown_record THEN
          osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        IFEND;
        RETURN;
      IFEND;
      avp$get_field (avc$creation_account_project, data_record, description_record, {work_area=} NIL,
            field_value, type_specification, default_value, descriptive_text, utility_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      creation_account_name := field_value.account_name^;
      creation_project_name := field_value.project_name^;

{ Verify that the caller has the required authority.

      determine_caller_authority (caller_id, NIL, NIL, NIL, ^creation_account_name, ^creation_project_name,
            caller_authority);
      IF caller_authority < avc$user_admin_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        RETURN;
      IFEND;
    IFEND;

{ Determine if a record for the specified user exists on the
{ validation file.

    key.account_name := avc$high_value_name;
    key.project_name := avc$high_value_name;
    key.user_name := user_name;
    avp$determine_if_key_exists (key.value, user_exists, file_information, status);

  PROCEND avp$verify_user_exists;
?? OLDTITLE ??
?? TITLE := '  Interfaces to create field descriptions' ??
?? NEWTITLE := '    avp$create_acct_proj_field', EJECT ??
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to create a new account project type validation
{ field within a validation record.
{
{ DESIGN:
{
{   This interface is only callable by family administrators or above.
{
{   The default values and type specification values are assigned from
{ the input parameters.
{
{   Then, an internal procedure is called that:
{    - initializes the record utility information for the description record
{    - initializes the description for the field
{    - initializes the field utility information for the field
{    - verifies the field for type conformance
{    - creates the field.
{
{   A warning status is returned if the account and/or project do not exist in
{ the validation file and the system validation level is currently account or
{ project.
{

  PROCEDURE [XDCL, #GATE] avp$create_acct_proj_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         account_name: avt$account_name;
         project_name: avt$project_name;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      account_exists: boolean,
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      default_value: avt$field_value,
      key: avt$validation_key,
      ignore_status: ost$status,
      project_exists: boolean,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$family_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Initialize the default values.

    default_value.kind := avc$account_project_kind;
    default_value.account_name := ^account_name;
    default_value.project_name := ^project_name;

{ Initialize the type specification values.

    type_specification.kind := avc$account_project_kind;

{ Create the field.

    create_field (field_name, validation_record_name, ^change_commands, ^display_commands, description,
          display_authority, change_authority, manage_authority, delete_authority,
          avc$change_acct_proj_command, default_value, type_specification, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND avp$create_acct_proj_field;
?? TITLE := '    avp$create_accum_limit_field', EJECT ??
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to create a new accumulating limit type validation
{ field within a validation record.
{
{ DESIGN:
{
{   This interface is only callable by family administrators or above.
{
{   The default values and type specification values are assigned from
{ the input parameters, then, an internal procedure is called that:
{    - initializes the record utility information for the description record
{    - initializes the description for the field
{    - initializes the field utility information for the field
{    - verifies the field for type conformance
{    - creates the field.
{

  PROCEDURE [XDCL, #GATE] avp$create_accum_limit_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         job_warning_limit: avt$limit_value;
         job_maximum_limit: avt$limit_value;
         total_limit: avt$limit_value;
         limit_name: ost$name;
         job_limits_apply: boolean;
         limit_update_statistics: ^sft$limit_update_statistics;
         minimum_job_limit_value: avt$limit_value;
         maximum_job_limit_value: avt$limit_value;
         total_limit_applies: boolean;
         total_limit_stops_login: boolean;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      default_value: avt$field_value,
      type_specification: avt$type_specification,
      zero_value: integer;

    status.normal := TRUE;
    zero_value := 0;

    #CALLER_ID (caller_id);

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$family_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Initialize the default values.

    default_value.kind := avc$accumulating_limit_kind;
    default_value.job_warning_limit := ^job_warning_limit;
    default_value.job_maximum_limit := ^job_maximum_limit;
    default_value.total_limit := ^total_limit;
    default_value.total_accumulation := ^zero_value;

{ Initialize the type specification values.

    type_specification.kind := avc$accumulating_limit_kind;
    type_specification.limit_name := ^limit_name;
    type_specification.job_limits_apply := ^job_limits_apply;
    type_specification.limit_update_statistics := limit_update_statistics;
    type_specification.minimum_job_limit_value := ^minimum_job_limit_value;
    type_specification.maximum_job_limit_value := ^maximum_job_limit_value;
    type_specification.total_limit_applies := ^total_limit_applies;
    type_specification.total_limit_stops_login := ^total_limit_stops_login;

{ Create the field.

    create_field (field_name, validation_record_name, ^change_commands, ^display_commands, description,
          display_authority, change_authority, manage_authority, delete_authority,
          avc$change_accum_limit_command, default_value, type_specification, file_information, status);

  PROCEND avp$create_accum_limit_field;
?? TITLE := '    avp$create_capability_field', EJECT ??
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to create a new capability type validation
{ field within a validation record.
{
{ DESIGN:
{
{   This interface is only callable by family administrators or above.
{
{   The default values and type specification values are assigned from
{ the input parameters, then, an internal procedure is called that:
{    - initializes the record utility information for the description record
{    - initializes the description for the field
{    - initializes the field utility information for the field
{    - verifies the field for type conformance
{    - creates the field.
{

  PROCEDURE [XDCL, #GATE] avp$create_capability_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         capability: boolean;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      default_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$family_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Initialize the default values.

    default_value.kind := avc$capability_kind;
    default_value.capability := ^capability;

{ Initialize the type specification values.

    type_specification.kind := avc$capability_kind;

{ Create the field.

    create_field (field_name, validation_record_name, NIL, NIL, description, display_authority,
          change_authority, manage_authority, delete_authority, osc$null_name, default_value,
          type_specification, file_information, status);

  PROCEND avp$create_capability_field;
?? TITLE := '    avp$create_date_time_field', EJECT ??
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to create a new date time type validation
{ field within a validation record.
{
{ DESIGN:
{
{   This interface is only callable by family administrators or above.
{
{   The default values and type specification values are assigned from
{ the input parameters, then, an internal procedure is called that:
{    - initializes the record utility information for the description record
{    - initializes the description for the field
{    - initializes the field utility information for the field
{    - verifies the field for type conformance
{    - creates the field.
{

  PROCEDURE [XDCL, #GATE] avp$create_date_time_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         date_time: avt$date_time;
         date_time_range: boolean;
         date_applies: boolean;
         time_applies: boolean;
         date_display_format: clt$date_time_form_string;
         time_display_format: clt$date_time_form_string;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      default_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$family_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Initialize the default values.

    default_value.kind := avc$date_time_kind;
    default_value.date_time := ^date_time;

{ Initialize the type specification values.

    type_specification.kind := avc$date_time_kind;
    type_specification.date_time_range := ^date_time_range;
    type_specification.date_applies := ^date_applies;
    type_specification.time_applies := ^time_applies;
    type_specification.date_display_format := ^date_display_format;
    type_specification.time_display_format := ^time_display_format;

{ Create the field.

    create_field (field_name, validation_record_name, ^change_commands, ^display_commands, description,
          display_authority, change_authority, manage_authority, delete_authority,
          avc$change_date_time_command, default_value, type_specification, file_information, status);

  PROCEND avp$create_date_time_field;
?? TITLE := '    avp$create_file_field', EJECT ??
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to create a new file type validation
{ field within a validation record.
{
{ DESIGN:
{
{   This interface is only callable by family administrators or above.
{
{   The default values and type specification values are assigned from
{ the input parameters, then, an internal procedure is called that:
{    - initializes the record utility information for the description record
{    - initializes the description for the field
{    - initializes the field utility information for the field
{    - verifies the field for type conformance
{    - creates the field.
{

  PROCEDURE [XDCL, #GATE] avp$create_file_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         file: fst$file_reference;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      default_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$family_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Initialize the default values.

    default_value.kind := avc$file_kind;
    default_value.file := ^file;

{ Initialize the type specification values.

    type_specification.kind := avc$file_kind;

{ Create the field.

    create_field (field_name, validation_record_name, ^change_commands, ^display_commands, description,
          display_authority, change_authority, manage_authority, delete_authority, avc$change_file_command,
          default_value, type_specification, file_information, status);

  PROCEND avp$create_file_field;
?? TITLE := '    avp$create_integer_field', EJECT ??
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to create a new integer type validation
{ field within a validation record.
{
{ DESIGN:
{
{   This interface is only callable by family administrators or above.
{
{   The default values and type specification values are assigned from
{ the input parameters, then, an internal procedure is called that:
{    - initializes the record utility information for the description record
{    - initializes the description for the field
{    - initializes the field utility information for the field
{    - verifies the field for type conformance
{    - creates the field.
{

  PROCEDURE [XDCL, #GATE] avp$create_integer_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         integer_value: integer;
         minimum_integer_value: integer;
         maximum_integer_value: integer;
         integer_display_format: avt$numeric_display_format;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      default_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$family_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Initialize the default values.

    default_value.kind := avc$integer_kind;
    default_value.integer_value := ^integer_value;

{ Initialize the type specification values.

    type_specification.kind := avc$integer_kind;
    type_specification.minimum_integer_value := ^minimum_integer_value;
    type_specification.maximum_integer_value := ^maximum_integer_value;
    type_specification.integer_display_format := ^integer_display_format;

{ Create the field.

    create_field (field_name, validation_record_name, ^change_commands, ^display_commands, description,
          display_authority, change_authority, manage_authority, delete_authority, avc$change_integer_command,
          default_value, type_specification, file_information, status);

  PROCEND avp$create_integer_field;
?? TITLE := '    avp$create_job_class_field', EJECT ??
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to create a new job class type validation
{ field within a validation record.
{
{ DESIGN:
{
{   This interface is only callable by family administrators or above.
{
{   The default values and type specification values are assigned from
{ the input parameters, then, an internal procedure is called that:
{    - initializes the record utility information for the description record
{    - initializes the description for the field
{    - initializes the field utility information for the field
{    - verifies the field for type conformance
{    - creates the field.
{

  PROCEDURE [XDCL, #GATE] avp$create_job_class_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         job_classes: avt$name_list;
         batch_job_class_default: ost$name;
         interactive_job_class_default: ost$name;
         common_job_classes: avt$name_list;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      default_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$family_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Initialize the default values.

    default_value.kind := avc$job_class_kind;
    default_value.job_classes := ^job_classes;
    default_value.batch_job_class_default := ^batch_job_class_default;
    default_value.interactive_job_class_default := ^interactive_job_class_default;

{ Initialize the type specification values.

    type_specification.kind := avc$job_class_kind;
    type_specification.common_job_classes := ^common_job_classes;

{ Create the field.

    create_field (field_name, validation_record_name, ^change_commands, ^display_commands, description,
          display_authority, change_authority, manage_authority, delete_authority,
          avc$change_job_class_command, default_value, type_specification, file_information, status);

  PROCEND avp$create_job_class_field;
?? TITLE := '    avp$create_labeled_names_field', EJECT ??
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to create a new labeled names type validation field within a validation record.
{
{ DESIGN:
{
{   This interface is only callable by family administrators or above.
{
{   The default values and type specification values are assigned from
{ the input parameters, then, an internal procedure is called that:
{    - initializes the record utility information for the description record
{    - initializes the description for the field
{    - initializes the field utility information for the field
{    - verifies the field for type conformance
{    - creates the field.
{

  PROCEDURE [XDCL, #GATE] avp$create_labeled_names_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         labeled_names: avt$labeled_names_list;
         valid_labels: avt$name_list;
         valid_names: avt$name_list;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      default_value: avt$field_value,
      index: avt$name_list_size,
      labeled_names_default: ^array [1 .. *] of avt$labeled_names,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$family_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Initialize the default values.

    PUSH labeled_names_default: [1 .. UPPERBOUND (labeled_names)];
    FOR index := 1 to UPPERBOUND (labeled_names) DO
      PUSH labeled_names_default^ [index].label;
      labeled_names_default^ [index].label^ := labeled_names [index].label^;
      PUSH labeled_names_default^ [index].names: [1 .. UPPERBOUND (labeled_names [index].names^)];
      labeled_names_default^ [index].names^ := labeled_names [index].names^;
    FOREND;

    default_value.kind := avc$labeled_names_kind;
    default_value.labeled_names := labeled_names_default;

{ Initialize the type specification values.

    type_specification.kind := avc$labeled_names_kind;
    type_specification.valid_labels := ^valid_labels;
    type_specification.valid_names := ^valid_names;

{ Create the field.

    create_field (field_name, validation_record_name, ^change_commands, ^display_commands, description,
          display_authority, change_authority, manage_authority, delete_authority,
          avc$change_labeled_names_cmd, default_value, type_specification, file_information, status);

  PROCEND avp$create_labeled_names_field;
?? TITLE := '    avp$create_limit_field', EJECT ??
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to create a new limit type validation
{ field within a validation record.
{
{ DESIGN:
{
{   This interface is only callable by family administrators or above.
{
{   The default values and type specification values are assigned from
{ the input parameters, then, an internal procedure is called that:
{    - initializes the record utility information for the description record
{    - initializes the description for the field
{    - initializes the field utility information for the field
{    - verifies the field for type conformance
{    - creates the field.
{

  PROCEDURE [XDCL, #GATE] avp$create_limit_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         limit_value: avt$limit_value;
         minimum_limit_value: avt$limit_value;
         maximum_limit_value: avt$limit_value;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      default_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$family_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Initialize the default values.

    default_value.kind := avc$limit_kind;
    default_value.limit_value := ^limit_value;

{ Initialize the type specification values.

    type_specification.kind := avc$limit_kind;
    type_specification.minimum_limit_value := ^minimum_limit_value;
    type_specification.maximum_limit_value := ^maximum_limit_value;

{ Create the field.

    create_field (field_name, validation_record_name, ^change_commands, ^display_commands, description,
          display_authority, change_authority, manage_authority, delete_authority, avc$change_limit_command,
          default_value, type_specification, file_information, status);

  PROCEND avp$create_limit_field;
?? TITLE := '    avp$create_login_password_field', EJECT ??
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to create a new login password type validation
{ field within a validation record.
{
{ DESIGN:
{
{   This interface is only callable by family administrators or above.
{
{   The default values and type specification values are assigned from
{ the input parameters, then, an internal procedure is called that:
{    - initializes the record utility information for the description record
{    - initializes the description for the field
{    - initializes the field utility information for the field
{    - verifies the field for type conformance
{    - creates the field.
{

  PROCEDURE [XDCL, #GATE] avp$create_login_password_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         login_password: avt$login_password;
         login_password_exp_date: ost$date_time;
         login_password_exp_interval: pmt$time_increment;
         login_password_max_exp_interval: pmt$time_increment;
         login_password_exp_warning: pmt$time_increment;
         login_password_exp_chg_interval: pmt$time_increment;
         login_password_attributes: avt$name_list;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      default_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$family_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Initialize the default values.

    default_value.kind := avc$login_password_kind;
    default_value.login_password := ^login_password;
    default_value.login_password_exp_date := ^login_password_exp_date;
    default_value.login_password_exp_interval := ^login_password_exp_interval;
    default_value.login_password_max_exp_interval := ^login_password_max_exp_interval;
    default_value.login_password_exp_warning := ^login_password_exp_warning;
    default_value.login_password_exp_chg_interval := ^login_password_exp_chg_interval;
    default_value.login_password_change_date := NIL;
    default_value.login_password_attributes := ^login_password_attributes;

{ Initialize the type specification values.

    type_specification.kind := avc$login_password_kind;

{ Create the field.

    create_field (field_name, validation_record_name, ^change_commands, ^display_commands, description,
          display_authority, change_authority, manage_authority, delete_authority,
          avc$change_login_password_cmd, default_value, type_specification, file_information, status);

  PROCEND avp$create_login_password_field;
?? TITLE := '    avp$create_name_field', EJECT ??
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to create a new name type validation
{ field within a validation record.
{
{ DESIGN:
{
{   This interface is only callable by family administrators or above.
{
{   The default values and type specification values are assigned from
{ the input parameters, then, an internal procedure is called that:
{    - initializes the record utility information for the description record
{    - initializes the description for the field
{    - initializes the field utility information for the field
{    - verifies the field for type conformance
{    - creates the field.
{

  PROCEDURE [XDCL, #GATE] avp$create_name_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         names: avt$name_list;
         minimum_number_of_names: avt$name_list_size;
         maximum_number_of_names: avt$name_list_size;
         common_names: avt$name_list;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      default_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$family_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Initialize the default values.

    default_value.kind := avc$name_kind;
    default_value.names := ^names;

{ Initialize the type specification values.

    type_specification.kind := avc$name_kind;
    type_specification.minimum_number_of_names := ^minimum_number_of_names;
    type_specification.maximum_number_of_names := ^maximum_number_of_names;
    type_specification.common_names := ^common_names;

{ Create the field.

    create_field (field_name, validation_record_name, ^change_commands, ^display_commands, description,
          display_authority, change_authority, manage_authority, delete_authority, avc$change_name_command,
          default_value, type_specification, file_information, status);

  PROCEND avp$create_name_field;
?? TITLE := '    avp$create_real_field', EJECT ??
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to create a new real type validation
{ field within a validation record.
{
{ DESIGN:
{
{   This interface is only callable by family administrators or above.
{
{   The default values and type specification values are assigned from
{ the input parameters, then, an internal procedure is called that:
{    - initializes the record utility information for the description record
{    - initializes the description for the field
{    - initializes the field utility information for the field
{    - verifies the field for type conformance
{    - creates the field.
{

  PROCEDURE [XDCL, #GATE] avp$create_real_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         real_value: real;
         minimum_real_value: real;
         maximum_real_value: real;
         integer_display_format: avt$numeric_display_format;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      default_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$family_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Initialize the default values.

    default_value.kind := avc$real_kind;
    default_value.real_value := ^real_value;

{ Initialize the type specification values.

    type_specification.kind := avc$real_kind;
    type_specification.minimum_real_value := ^minimum_real_value;
    type_specification.maximum_real_value := ^maximum_real_value;
    type_specification.real_display_format := ^integer_display_format;

{ Create the field.

    create_field (field_name, validation_record_name, ^change_commands, ^display_commands, description,
          display_authority, change_authority, manage_authority, delete_authority, avc$change_real_command,
          default_value, type_specification, file_information, status);

  PROCEND avp$create_real_field;
?? TITLE := '    avp$create_ring_privilege_field', EJECT ??
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to create a new ring privilege type validation
{ field within a validation record.
{
{ DESIGN:
{
{   This interface is only callable by family administrators or above.
{
{   The default values and type specification values are assigned from
{ the input parameters, then, an internal procedure is called that:
{    - initializes the record utility information for the description record
{    - initializes the description for the field
{    - initializes the field utility information for the field
{    - verifies the field for type conformance
{    - creates the field.
{

  PROCEDURE [XDCL, #GATE] avp$create_ring_privilege_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         minimum_ring: ost$ring;
         nominal_ring: ost$ring;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      default_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$family_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Initialize the default values.

    default_value.kind := avc$ring_privilege_kind;
    default_value.minimum_ring := ^minimum_ring;
    default_value.nominal_ring := ^nominal_ring;

{ Initialize the type specification values.

    type_specification.kind := avc$ring_privilege_kind;

{ Create the field.

    create_field (field_name, validation_record_name, ^change_commands, ^display_commands, description,
          display_authority, change_authority, manage_authority, delete_authority,
          avc$change_ring_privilege_cmd, default_value, type_specification, file_information, status);

  PROCEND avp$create_ring_privilege_field;
?? TITLE := '    avp$create_string_field', EJECT ??
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to create a new string type validation
{ field within a validation record.
{
{ DESIGN:
{
{   This interface is only callable by family administrators or above.
{
{   The default values and type specification values are assigned from
{ the input parameters, then, an internal procedure is called that:
{    - initializes the record utility information for the description record
{    - initializes the description for the field
{    - initializes the field utility information for the field
{    - verifies the field for type conformance
{    - creates the field.
{

  PROCEDURE [XDCL, #GATE] avp$create_string_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         string_value: ost$string;
         minimum_string_size: ost$string_size;
         maximum_string_size: ost$string_size;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      default_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < avc$family_admin_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Initialize the default values.

    default_value.kind := avc$string_kind;
    default_value.string_value := ^string_value.value (1, string_value.size);

{ Initialize the type specification values.

    type_specification.kind := avc$string_kind;
    type_specification.minimum_string_size := ^minimum_string_size;
    type_specification.maximum_string_size := ^maximum_string_size;

{ Create the field.

    create_field (field_name, validation_record_name, ^change_commands, ^display_commands, description,
          display_authority, change_authority, manage_authority, delete_authority, avc$change_string_command,
          default_value, type_specification, file_information, status);

  PROCEND avp$create_string_field;
?? TITLE := '    create_field', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used by the various field creation interfaces to
{ set up the common field information and create the requested field.
{

  PROCEDURE create_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
         procedure_name: ost$name;
         default_value: avt$field_value;
         type_specification: avt$type_specification;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      audit_information: sft$audit_information,
      descriptive_text: ^avt$descriptive_text,
      field_kind: avt$field_kind,
      field_utility_information: avt$field_utility_information,
      record_utility_information: ^avt$utility_information,
      utility_information: ^avt$utility_information,
      utility_information_size: integer;

    status.normal := TRUE;

  /create/
    BEGIN

{ Make sure the field doesn't already exist.

    avp$get_validation_field_kind (field_name, validation_record_name, field_kind, file_information, status);
    IF status.normal THEN
      osp$set_status_abnormal ('AV', ave$field_already_exists, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, validation_record_name, status);
      EXIT /create/;
    ELSEIF status.condition <> ave$unknown_field THEN
      EXIT /create/;
    IFEND;
    status.normal := TRUE;

{ Initialize the record utility information change and display commands.

{ The pointers for change and display commands will only be NIL if
{ a capability field is being created (i.e. one standard command is used for
{ all capabilities.

    IF ((change_commands <> NIL) OR (display_commands <> NIL)) THEN

{ Get the current command table information.

      avp$get_desc_utility_info_size (validation_record_name, utility_information_size, file_information,
            status);
      IF NOT status.normal THEN
        EXIT /create/;
      IFEND;
      PUSH record_utility_information: [[REP utility_information_size OF cell,
            REP avc$maximum_name_list_size OF avt$record_utility_info_entry]];
      RESET record_utility_information;
      utility_information_size := #SIZE (record_utility_information^);
      avp$get_desc_utility_info (validation_record_name, record_utility_information, file_information,
            status);
      IF NOT status.normal THEN
        EXIT /create/;
      IFEND;

{ Add the specified change commands to the command table information.

      add_new_record_utility_info_cmd (change_commands^, field_name, procedure_name,
            record_utility_information, status);
      IF NOT status.normal THEN
        EXIT /create/;
      IFEND;

{ Add the specified display commands to the command table information.

      add_new_record_utility_info_cmd (display_commands^, field_name, avc$display_field_value,
            record_utility_information, status);
      IF NOT status.normal THEN
        EXIT /create/;
      IFEND;
    IFEND;

{ Initialize the description.

    descriptive_text := ^description.value (1, description.size);

{ Initialize the field utility information authorities.

    field_utility_information.display_authority := display_authority;
    field_utility_information.change_authority := change_authority;
    field_utility_information.manage_authority := manage_authority;
    field_utility_information.delete_authority := delete_authority;
    field_utility_information.hidden_field := FALSE;

{ Verify values are valid for this type.

    avp$verify_type_conformance (field_name, default_value, type_specification, status);
    IF NOT status.normal THEN
      EXIT /create/;
    IFEND;

{ Sort the record utility information.
{ Note: The sort is after verify type conformance because it
{       will return an error if a duplicate entry is found and
{       any errors from verify type conformance should be first.

    IF ((change_commands <> NIL) OR (display_commands <> NIL)) THEN
      sort_record_utility_information (record_utility_information, utility_information, status);
      IF NOT status.normal THEN
        EXIT /create/;
      IFEND;
    IFEND;

{ Create the field.

    avp$create_field (field_name, validation_record_name, type_specification, default_value,
          descriptive_text, #SEQ (field_utility_information), file_information, status);
    IF NOT status.normal THEN
      EXIT /create/;
    IFEND;

{ Update the record utility command table information.

    IF ((change_commands <> NIL) OR (display_commands <> NIL)) THEN
      avp$change_desc_utility_info (validation_record_name, utility_information, file_information, status);
    IFEND;
    END /create/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_information.audited_operation := sfc$ao_val_create_field;
      audit_information.create_validation_field.description_record_name_p := ^validation_record_name;
      audit_information.create_validation_field.validation_file_p := ^file_information.file_name;
      audit_information.create_validation_field.field_name_p := ^field_name;
      audit_information.create_validation_field.field_kind := type_specification.kind;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;

  PROCEND create_field;
?? OLDTITLE ??
?? TITLE := '  Interfaces to read field descriptions' ??
?? NEWTITLE := '    avp$get_acct_proj_field_desc', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get an integer type field's field
{ description values.
{
{ DESIGN:
{
{   This is not a protected interface.
{
{   This interface retrieves the default value and type specification information
{ from the description record which contains the field and the authority information
{ from the field utility information.
{

  PROCEDURE [XDCL, #GATE] avp$get_acct_proj_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR default_account_name: avt$account_name;
     VAR default_project_name: avt$project_name;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      field_utility_information: avt$field_utility_information,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Retrieve the description record that contains the field description for the specified field.

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;
    get_field_description (field_name, record_name, record_id, {field_work_area=} NIL, description_record,
          default_value, type_specification, description, field_utility_information, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field being retrieved is of the type specified.

    IF type_specification.kind <> avc$account_project_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'account project', status);
      RETURN;
    IFEND;

{ Get the default values from the field description.

    default_account_name := default_value.account_name^;
    default_project_name := default_value.project_name^;

{ Get the field utility information values.

    change_authority := field_utility_information.change_authority;
    delete_authority := field_utility_information.delete_authority;
    display_authority := field_utility_information.display_authority;
    manage_authority := field_utility_information.manage_authority;

  PROCEND avp$get_acct_proj_field_desc;
?? TITLE := '    avp$get_accum_limit_field_desc', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get an accumulating limit type field's field
{ description values.
{
{ DESIGN:
{
{   This is not a protected interface.
{
{   This interface retrieves the default value and type specification information
{ from the description record which contains the field and the authority information
{ from the field utility information.
{

  PROCEDURE [XDCL, #GATE] avp$get_accum_limit_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR job_warning_limit: avt$limit_value;
     VAR job_maximum_limit: avt$limit_value;
     VAR total_limit: avt$limit_value;
     VAR total_accumulation: avt$limit_value;
     VAR limit_name: ost$name;
     VAR job_limits_apply: boolean;
     VAR minimum_job_limit_value: avt$limit_value;
     VAR maximum_job_limit_value: avt$limit_value;
     VAR number_of_limit_update_stats: avt$name_list_size;
     VAR limit_update_statistics: ^sft$limit_update_statistics;
     VAR total_limit_applies: boolean;
     VAR total_limit_stops_login: boolean;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      field_utility_information: avt$field_utility_information,
      index: avt$name_list_size,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;
    get_field_description (field_name, record_name, record_id, {field_work_area=} NIL, description_record,
          default_value, type_specification, description, field_utility_information, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field being retrieved is of the type specified.

    IF type_specification.kind <> avc$accumulating_limit_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'accumulating limit', status);
      RETURN;
    IFEND;

{ Get the default values from the field description.

    job_warning_limit := default_value.job_warning_limit^;
    job_maximum_limit := default_value.job_maximum_limit^;
    total_limit := default_value.total_limit^;
    total_accumulation := default_value.total_accumulation^;

{ Get the type specification values.

    limit_name := type_specification.limit_name^;
    IF limit_name = avc$cp_time_limit_name THEN
      limit_name := avc$cpu_time_limit_name;
    IFEND;
    job_limits_apply := type_specification.job_limits_apply^;

    IF type_specification.limit_update_statistics = NIL THEN
      number_of_limit_update_stats := 0;
    ELSE
      number_of_limit_update_stats := UPPERBOUND (type_specification.limit_update_statistics^);
    IFEND;
    IF limit_update_statistics <> NIL THEN
      index := 1;
      WHILE (index <= UPPERBOUND (limit_update_statistics^)) AND (index <= number_of_limit_update_stats) DO
        limit_update_statistics^ [index] := type_specification.limit_update_statistics^ [index];
        index := index + 1;
      WHILEND;
    IFEND;

    minimum_job_limit_value := type_specification.minimum_job_limit_value^;
    maximum_job_limit_value := type_specification.maximum_job_limit_value^;
    total_limit_applies := type_specification.total_limit_applies^;
    total_limit_stops_login := type_specification.total_limit_stops_login^;

{ Get the field utility information values.

    change_authority := field_utility_information.change_authority;
    delete_authority := field_utility_information.delete_authority;
    display_authority := field_utility_information.display_authority;
    manage_authority := field_utility_information.manage_authority;

  PROCEND avp$get_accum_limit_field_desc;
?? TITLE := '    avp$get_capability_field_desc', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a capability type field's field
{ description values.
{
{ DESIGN:
{
{   This is not a protected interface.
{
{   This interface retrieves the default value and type specification information
{ from the description record which contains the field and the authority information
{ from the field utility information.
{

  PROCEDURE [XDCL, #GATE] avp$get_capability_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR capability: boolean;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      field_utility_information: avt$field_utility_information,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;
    get_field_description (field_name, record_name, record_id, {field_work_area=} NIL, description_record,
          default_value, type_specification, description, field_utility_information, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field being retrieved is of the type specified.

    IF type_specification.kind <> avc$capability_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'capability', status);
      RETURN;
    IFEND;

{ Get the default values from the field description.

    capability := default_value.capability^;

{ Get the field utility information values.

    change_authority := field_utility_information.change_authority;
    delete_authority := field_utility_information.delete_authority;
    display_authority := field_utility_information.display_authority;
    manage_authority := field_utility_information.manage_authority;

  PROCEND avp$get_capability_field_desc;
?? TITLE := '    avp$get_date_time_field_desc', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a date time type field's field
{ description values.
{
{ DESIGN:
{
{   This is not a protected interface.
{
{   This interface retrieves the default value and type specification information
{ from the description record which contains the field and the authority information
{ from the field utility information.
{

  PROCEDURE [XDCL, #GATE] avp$get_date_time_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR date_time: avt$date_time;
     VAR date_time_range: boolean;
     VAR date_applies: boolean;
     VAR time_applies: boolean;
     VAR date_display_format: clt$date_time_form_string;
     VAR time_display_format: clt$date_time_form_string;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      field_utility_information: avt$field_utility_information,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;
    get_field_description (field_name, record_name, record_id, {field_work_area=} NIL, description_record,
          default_value, type_specification, description, field_utility_information, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field being retrieved is of the type specified.

    IF type_specification.kind <> avc$date_time_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'date_time', status);
      RETURN;
    IFEND;

{ Get the default values from the field description.

    date_time := default_value.date_time^;

{ Get the type specification values.

    date_time_range := type_specification.date_time_range^;
    date_applies := type_specification.date_applies^;
    time_applies := type_specification.time_applies^;
    IF date_applies THEN
      date_display_format := type_specification.date_display_format^;
    ELSE
      date_display_format := '';
    IFEND;
    IF time_applies THEN
      time_display_format := type_specification.time_display_format^;
    ELSE
      time_display_format := '';
    IFEND;

{ Get the field utility information values.

    change_authority := field_utility_information.change_authority;
    delete_authority := field_utility_information.delete_authority;
    display_authority := field_utility_information.display_authority;
    manage_authority := field_utility_information.manage_authority;

  PROCEND avp$get_date_time_field_desc;
?? TITLE := '    avp$get_file_field_desc', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a file type field's field
{ description values.
{
{ DESIGN:
{
{   This is not a protected interface.
{
{   This interface retrieves the default value and type specification information
{ from the description record which contains the field and the authority information
{ from the field utility information.
{

  PROCEDURE [XDCL, #GATE] avp$get_file_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR file: string (fsc$max_path_size);
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      field_utility_information: avt$field_utility_information,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;
    get_field_description (field_name, record_name, record_id, {field_work_area=} NIL, description_record,
          default_value, type_specification, description, field_utility_information, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field being retrieved is of the type specified.

    IF type_specification.kind <> avc$file_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'file', status);
      RETURN;
    IFEND;

{ Get the default values from the field description.

    file := default_value.file^;

{ Get the field utility information values.

    change_authority := field_utility_information.change_authority;
    delete_authority := field_utility_information.delete_authority;
    display_authority := field_utility_information.display_authority;
    manage_authority := field_utility_information.manage_authority;

  PROCEND avp$get_file_field_desc;

?? TITLE := '    avp$get_integer_field_desc', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a integer type field's field
{ description values.
{
{ DESIGN:
{
{   This is not a protected interface.
{
{   This interface retrieves the default value and type specification information
{ from the description record which contains the field and the authority information
{ from the field utility information.
{

  PROCEDURE [XDCL, #GATE] avp$get_integer_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR integer_value: integer;
     VAR minimum_integer_value: integer;
     VAR maximum_integer_value: integer;
     VAR integer_display_format: avt$numeric_display_format;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      field_utility_information: avt$field_utility_information,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;
    get_field_description (field_name, record_name, record_id, {field_work_area=} NIL, description_record,
          default_value, type_specification, description, field_utility_information, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field being retrieved is of the type specified.

    IF type_specification.kind <> avc$integer_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'integer', status);
      RETURN;
    IFEND;

{ Get the default values from the field description.

    integer_value := default_value.integer_value^;

{ Get the type specification values.

    minimum_integer_value := type_specification.minimum_integer_value^;
    maximum_integer_value := type_specification.maximum_integer_value^;
    integer_display_format := type_specification.integer_display_format^;

{ Get the field utility information values.

    change_authority := field_utility_information.change_authority;
    delete_authority := field_utility_information.delete_authority;
    display_authority := field_utility_information.display_authority;
    manage_authority := field_utility_information.manage_authority;

  PROCEND avp$get_integer_field_desc;

?? TITLE := '    avp$get_job_class_field_desc', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a job class type field's field
{ description values.
{
{ DESIGN:
{
{   This is not a protected interface.
{
{   This interface retrieves the default value and type specification information
{ from the description record which contains the field and the authority information
{ from the field utility information.
{

  PROCEDURE [XDCL, #GATE] avp$get_job_class_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR number_of_job_classes: avt$name_list_size;
     VAR job_classes: ^avt$name_list;
     VAR batch_job_class_default: ost$name;
     VAR interactive_job_class_default: ost$name;
     VAR number_of_common_job_classes: avt$name_list_size;
     VAR common_job_classes: ^avt$name_list;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      field_utility_information: avt$field_utility_information,
      index: avt$name_list_size,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;
    get_field_description (field_name, record_name, record_id, {field_work_area=} NIL, description_record,
          default_value, type_specification, description, field_utility_information, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field being retrieved is of the type specified.

    IF type_specification.kind <> avc$job_class_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'job class', status);
      RETURN;
    IFEND;

{ Get the default values from the field description.

    number_of_job_classes := UPPERBOUND (default_value.job_classes^);
    IF job_classes <> NIL THEN
      index := 1;
      WHILE (index <= UPPERBOUND (job_classes^)) AND (index <= number_of_job_classes) DO
        job_classes^ [index] := default_value.job_classes^ [index];
        index := index + 1;
      WHILEND;
    IFEND;

    batch_job_class_default := default_value.batch_job_class_default^;
    interactive_job_class_default := default_value.interactive_job_class_default^;

    number_of_common_job_classes := UPPERBOUND (type_specification.common_job_classes^);
    IF common_job_classes <> NIL THEN
      index := 1;
      WHILE (index <= UPPERBOUND (common_job_classes^)) AND (index <= number_of_common_job_classes) DO
        common_job_classes^ [index] := type_specification.common_job_classes^ [index];
        index := index + 1;
      WHILEND;
    IFEND;

{ Get the field utility information values.

    change_authority := field_utility_information.change_authority;
    delete_authority := field_utility_information.delete_authority;
    display_authority := field_utility_information.display_authority;
    manage_authority := field_utility_information.manage_authority;

  PROCEND avp$get_job_class_field_desc;
?? TITLE := '    avp$get_labeled_names_field_des', EJECT ??
{ PURPOSE:
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a labeled_names type field's field description values.
{
{ DESIGN:
{   This is not a protected interface.
{
{   This interface retrieves the default value and type specification information
{ from the description record which contains the field, and the authority information
{ from the field utility information.

  PROCEDURE [XDCL, #GATE] avp$get_labeled_names_field_des
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
         work_area: ^seq (*);
     VAR labeled_names: ^avt$labeled_names_list;
     VAR number_of_valid_labels: avt$name_list_size;
     VAR valid_labels: ^avt$name_list;
     VAR number_of_valid_names: avt$name_list_size;
     VAR valid_names: ^avt$name_list;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      field_utility_information: avt$field_utility_information,
      field_work_area: ^seq (*),
      index: avt$name_list_size,
      type_specification: avt$type_specification,
      work_area_ptr: ^seq (*);

    status.normal := TRUE;

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;
    PUSH field_work_area: [[REP 2 * avc$maximum_name_list_size OF avt$labeled_names]];
    RESET field_work_area;
    get_field_description (field_name, record_name, record_id, field_work_area, description_record,
          default_value, type_specification, description, field_utility_information, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field being retrieved is of the type specified.

    IF type_specification.kind <> avc$labeled_names_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'labeled names', status);
      RETURN;
    IFEND;

{ Get the default values from the field description.

    IF default_value.labeled_names <> NIL THEN
      work_area_ptr := work_area;
      NEXT labeled_names: [1 .. UPPERBOUND (default_value.labeled_names^)] IN work_area_ptr;
      FOR index := 1 TO UPPERBOUND (default_value.labeled_names^) DO
        NEXT labeled_names^ [index].label IN work_area_ptr;
        labeled_names^ [index].label^ := default_value.labeled_names^ [index].label^;

        NEXT labeled_names^ [index].names: [1 .. UPPERBOUND (default_value.labeled_names^ [index].names^)] IN
              work_area_ptr;
        labeled_names^ [index].names^ := default_value.labeled_names^ [index].names^;
      FOREND;
    ELSE
      labeled_names := NIL;
    IFEND;

{ Get the type specification values.

    IF type_specification.valid_labels = NIL THEN
      number_of_valid_labels := 0;
    ELSE
      number_of_valid_labels := UPPERBOUND (type_specification.valid_labels^);
    IFEND;
    IF valid_labels <> NIL THEN
      index := 1;
      WHILE (index <= UPPERBOUND (valid_labels^)) AND (index <= number_of_valid_labels) DO
        valid_labels^ [index] := type_specification.valid_labels^ [index];
        index := index + 1;
      WHILEND;
    IFEND;

    IF type_specification.valid_names = NIL THEN
      number_of_valid_names := 0;
    ELSE
      number_of_valid_names := UPPERBOUND (type_specification.valid_names^);
    IFEND;
    IF valid_names <> NIL THEN
      index := 1;
      WHILE (index <= UPPERBOUND (valid_names^)) AND (index <= number_of_valid_names) DO
        valid_names^ [index] := type_specification.valid_names^ [index];
        index := index + 1;
      WHILEND;
    IFEND;

{ Get the field utility information values.

    change_authority := field_utility_information.change_authority;
    delete_authority := field_utility_information.delete_authority;
    display_authority := field_utility_information.display_authority;
    manage_authority := field_utility_information.manage_authority;

  PROCEND avp$get_labeled_names_field_des;
?? TITLE := '    avp$get_limit_field_desc', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a limit type field's field
{ description values.
{
{ DESIGN:
{
{   This is not a protected interface.
{
{   This interface retrieves the default value and type specification information
{ from the description record which contains the field and the authority information
{ from the field utility information.
{

  PROCEDURE [XDCL, #GATE] avp$get_limit_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR limit_value: avt$limit_value;
     VAR minimum_limit_value: avt$limit_value;
     VAR maximum_limit_value: avt$limit_value;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      field_utility_information: avt$field_utility_information,
      index: avt$name_list_size,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;
    get_field_description (field_name, record_name, record_id, {field_work_area=} NIL, description_record,
          default_value, type_specification, description, field_utility_information, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field being retrieved is of the type specified.

    IF type_specification.kind <> avc$limit_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'limit', status);
      RETURN;
    IFEND;

{ Get the default values from the field description.

    limit_value := default_value.limit_value^;

{ Get the type specification values.

    minimum_limit_value := type_specification.minimum_limit_value^;
    maximum_limit_value := type_specification.maximum_limit_value^;

{ Get the field utility information values.

    change_authority := field_utility_information.change_authority;
    delete_authority := field_utility_information.delete_authority;
    display_authority := field_utility_information.display_authority;
    manage_authority := field_utility_information.manage_authority;

  PROCEND avp$get_limit_field_desc;
?? TITLE := '    avp$get_login_pw_field_desc', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a login password type field's field
{ description values.
{
{ DESIGN:
{
{   This is not a protected interface.
{
{   This interface retrieves the default value and type specification information
{ from the description record which contains the field and the authority information
{ from the field utility information.
{

  PROCEDURE [XDCL, #GATE] avp$get_login_pw_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR password: avt$login_password;
     VAR expiration_date: ost$date_time;
     VAR expiration_interval: pmt$time_increment;
     VAR maximum_expiration_interval: pmt$time_increment;
     VAR expiration_warning: pmt$time_increment;
     VAR expiration_change_interval: pmt$time_increment;
     VAR number_of_attributes: avt$name_list_size;
     VAR attributes: ^avt$name_list;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      field_utility_information: avt$field_utility_information,
      index: avt$name_list_size,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;
    get_field_description (field_name, record_name, record_id, {field_work_area=} NIL, description_record,
          default_value, type_specification, description, field_utility_information, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field being retrieved is of the type specified.

    IF type_specification.kind <> avc$login_password_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'login password', status);
      RETURN;
    IFEND;

{ Get the default values from the field description.

    password := default_value.login_password^;
    expiration_date := default_value.login_password_exp_date^;
    expiration_interval := default_value.login_password_exp_interval^;
    maximum_expiration_interval := default_value.login_password_max_exp_interval^;
    expiration_warning := default_value.login_password_exp_warning^;
    expiration_change_interval := default_value.login_password_exp_chg_interval^;

    IF default_value.login_password_attributes = NIL THEN
      number_of_attributes := 0;
    ELSE
      number_of_attributes := UPPERBOUND (default_value.login_password_attributes^);
    IFEND;
    IF attributes <> NIL THEN
      index := 1;
      WHILE (index <= UPPERBOUND (attributes^)) AND (index <= number_of_attributes) DO
        attributes^ [index] := default_value.login_password_attributes^ [index];
        index := index + 1;
      WHILEND;
    IFEND;

{ Get the field utility information values.

    change_authority := field_utility_information.change_authority;
    delete_authority := field_utility_information.delete_authority;
    display_authority := field_utility_information.display_authority;
    manage_authority := field_utility_information.manage_authority;

  PROCEND avp$get_login_pw_field_desc;

?? TITLE := '    avp$get_name_field_desc', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a name type field's field
{ description values.
{
{ DESIGN:
{
{   This is not a protected interface.
{
{   This interface retrieves the default value and type specification information
{ from the description record which contains the field and the authority information
{ from the field utility information.
{

  PROCEDURE [XDCL, #GATE] avp$get_name_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR number_of_names: avt$name_list_size;
     VAR names: ^avt$name_list;
     VAR minimum_number_of_names: avt$name_list_size;
     VAR maximum_number_of_names: avt$name_list_size;
     VAR number_of_common_names: avt$name_list_size;
     VAR common_names: ^avt$name_list;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      field_utility_information: avt$field_utility_information,
      index: avt$name_list_size,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;
    get_field_description (field_name, record_name, record_id, {field_work_area=} NIL, description_record,
          default_value, type_specification, description, field_utility_information, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field being retrieved is of the type specified.

    IF type_specification.kind <> avc$name_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'name', status);
      RETURN;
    IFEND;

{ Get the default values from the field description.

    IF default_value.names = NIL THEN
      number_of_names := 0;
    ELSE
      number_of_names := UPPERBOUND (default_value.names^);
    IFEND;
    IF names <> NIL THEN
      index := 1;
      WHILE (index <= UPPERBOUND (names^)) AND (index <= number_of_names) DO
        names^ [index] := default_value.names^ [index];
        index := index + 1;
      WHILEND;
    IFEND;

{ Get the type specification values.

    minimum_number_of_names := type_specification.minimum_number_of_names^;
    maximum_number_of_names := type_specification.maximum_number_of_names^;

    IF type_specification.common_names = NIL THEN
      number_of_common_names := 0;
    ELSE
      number_of_common_names := UPPERBOUND (type_specification.common_names^);
    IFEND;
    IF common_names <> NIL THEN
      index := 1;
      WHILE (index <= UPPERBOUND (common_names^)) AND (index <= number_of_common_names) DO
        common_names^ [index] := type_specification.common_names^ [index];
        index := index + 1;
      WHILEND;
    IFEND;

{ Get the field utility information values.

    change_authority := field_utility_information.change_authority;
    delete_authority := field_utility_information.delete_authority;
    display_authority := field_utility_information.display_authority;
    manage_authority := field_utility_information.manage_authority;

  PROCEND avp$get_name_field_desc;

?? TITLE := '    avp$get_real_field_desc', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a real type field's field
{ description values.
{
{ DESIGN:
{
{   This is not a protected interface.
{
{   This interface retrieves the default value and type specification information
{ from the description record which contains the field and the authority information
{ from the field utility information.
{

  PROCEDURE [XDCL, #GATE] avp$get_real_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR real_value: real;
     VAR minimum_real_value: real;
     VAR maximum_real_value: real;
     VAR integer_display_format: avt$numeric_display_format;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      field_utility_information: avt$field_utility_information,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;
    get_field_description (field_name, record_name, record_id, {field_work_area=} NIL, description_record,
          default_value, type_specification, description, field_utility_information, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field being retrieved is of the type specified.

    IF type_specification.kind <> avc$real_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'real', status);
      RETURN;
    IFEND;

{ Get the default values from the field description.

    real_value := default_value.real_value^;

{ Get the type specification values.

    minimum_real_value := type_specification.minimum_real_value^;
    maximum_real_value := type_specification.maximum_real_value^;
    integer_display_format := type_specification.integer_display_format^;

{ Get the field utility information values.

    change_authority := field_utility_information.change_authority;
    delete_authority := field_utility_information.delete_authority;
    display_authority := field_utility_information.display_authority;
    manage_authority := field_utility_information.manage_authority;

  PROCEND avp$get_real_field_desc;
?? TITLE := '    avp$get_ring_priv_field_desc', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a ring privilege type field's field
{ description values.
{
{ DESIGN:
{
{   This is not a protected interface.
{
{   This interface retrieves the default value and type specification information
{ from the description record which contains the field and the authority information
{ from the field utility information.
{

  PROCEDURE [XDCL, #GATE] avp$get_ring_priv_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR minimum_ring: ost$ring;
     VAR nominal_ring: ost$ring;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      field_utility_information: avt$field_utility_information,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;
    get_field_description (field_name, record_name, record_id, {field_work_area=} NIL, description_record,
          default_value, type_specification, description, field_utility_information, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field being retrieved is of the type specified.

    IF type_specification.kind <> avc$ring_privilege_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'ring privilege', status);
      RETURN;
    IFEND;

{ Get the default values from the field description.

    minimum_ring := default_value.minimum_ring^;
    nominal_ring := default_value.nominal_ring^;

{ Get the field utility information values.

    change_authority := field_utility_information.change_authority;
    delete_authority := field_utility_information.delete_authority;
    display_authority := field_utility_information.display_authority;
    manage_authority := field_utility_information.manage_authority;

  PROCEND avp$get_ring_priv_field_desc;
?? TITLE := '    avp$get_string_field_desc', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a string type field's field
{ description values.
{
{ DESIGN:
{
{   This is not a protected interface.
{
{   This interface retrieves the default value and type specification information
{ from the description record which contains the field and the authority information
{ from the field utility information.
{

  PROCEDURE [XDCL, #GATE] avp$get_string_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR string_value: ost$string;
     VAR minimum_string_size: ost$string_size;
     VAR maximum_string_size: ost$string_size;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      field_utility_information: avt$field_utility_information,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;
    get_field_description (field_name, record_name, record_id, {field_work_area=} NIL, description_record,
          default_value, type_specification, description, field_utility_information, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field being retrieved is of the type specified.

    IF type_specification.kind <> avc$string_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'string', status);
      RETURN;
    IFEND;

{ Get the default values from the field description.

    IF default_value.string_value = NIL THEN
      string_value.value := ' ';
      string_value.size := 0;
    ELSE
      string_value.value := default_value.string_value^;
      string_value.size := #SIZE (default_value.string_value^);
    IFEND;

{ Get the type specification values.

    minimum_string_size := type_specification.minimum_string_size^;
    maximum_string_size := type_specification.maximum_string_size^;

{ Get the field utility information values.

    change_authority := field_utility_information.change_authority;
    delete_authority := field_utility_information.delete_authority;
    display_authority := field_utility_information.display_authority;
    manage_authority := field_utility_information.manage_authority;

  PROCEND avp$get_string_field_desc;
?? OLDTITLE ??
?? TITLE := '  Interfaces to change field descriptions' ??
?? NEWTITLE := '    avp$change_acct_proj_field', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change an existing validation field's field
{ definition values.
{
{ DESIGN:
{
{   This interface is only callable by callers with authority equal to or above
{ the manage authority for the specified field.
{
{   The field being changed is verified to be of the type specified.
{
{   The default values and type specification values are updated.
{
{   A local procedure is called that:
{    - updates the record utility information for the description record
{    - updates the description for the field
{    - updates the field utility information for the field
{    - verifies the field for type conformance
{    - changes the field.
{

  PROCEDURE [XDCL, #GATE] avp$change_acct_proj_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         account_name: ^avt$account_name;
         project_name: ^avt$project_name;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      account_exists: boolean,
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      changed_default_value: boolean,
      current_description: ost$string,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      field_utility_information: avt$field_utility_information,
      ignore_status: ost$status,
      key: avt$validation_key,
      member_exists: boolean,
      project_exists: boolean,
      type_specification: avt$type_specification;

    status.normal := TRUE;
    changed_default_value := (account_name <> NIL) OR (project_name <> NIL);

    #CALLER_ID (caller_id);

{ Retrieve the description record that contains the field description for the specified field.

  /change/
    BEGIN
      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;
      get_field_description (field_name, validation_record_name, osc$null_name, {field_work_area=} NIL,
            description_record, default_value, type_specification, current_description,
            field_utility_information, file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ Verify that the field being changed is of the type specified.

      IF type_specification.kind <> avc$account_project_kind THEN
        osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'account project', status);
        EXIT /change/;
      IFEND;

{ Verify that the caller has the required authority.

      determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
      IF caller_authority < field_utility_information.manage_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /change/;
      IFEND;

{ Change the account name default value if specified.

      IF account_name <> NIL THEN
        default_value.account_name := account_name;
      IFEND;

{ Change the project name default value if specified.

      IF project_name <> NIL THEN
        default_value.project_name := project_name;
      IFEND;

      change_field (field_name, validation_record_name, change_commands, display_commands, description,
            current_description, display_authority, change_authority, manage_authority, delete_authority,
            avc$change_acct_proj_command, default_value, type_specification, field_utility_information,
            file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ Determine if the account and project exist.

      verify_acct_proj_membership (avp$validation_level (), default_value.account_name^,
            default_value.project_name^, osc$null_name, account_exists, project_exists, member_exists,
            file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;
    END /change/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      emit_chg_field_audit_statistic (validation_record_name, file_information.file_name, field_name,
            changed_default_value, change_authority, display_authority, manage_authority, status);
    IFEND;

{ Return a warning if the default account and or project do not exist.

    IF NOT account_exists THEN
      osp$set_status_abnormal ('AV', ave$account_does_not_exist_warn, default_value.account_name^, status);
    ELSEIF (NOT project_exists) AND (avp$validation_level () = avc$project_level) THEN
      osp$set_status_abnormal ('AV', ave$project_does_not_exist_warn, default_value.project_name^, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, default_value.account_name^, status);
    IFEND;

  PROCEND avp$change_acct_proj_field;
?? TITLE := '    avp$change_accum_limit_field', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change an existing validation field's field
{ definition values.
{
{ DESIGN:
{
{   This interface is only callable by callers with authority equal to or above
{ the manage authority for the specified field.
{
{   The field being changed is verified to be of the type specified.
{
{   The default values and type specification values are updated.
{
{   A local procedure is called that:
{    - updates the record utility information for the description record
{    - updates the description for the field
{    - updates the field utility information for the field
{    - verifies the field for type conformance
{    - changes the field.
{

  PROCEDURE [XDCL, #GATE] avp$change_accum_limit_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         job_warning_limit: ^avt$limit_value;
         job_maximum_limit: ^avt$limit_value;
         total_limit: ^avt$limit_value;
         limit_name: ^ost$name;
         job_limits_apply: ^boolean;
         limit_update_statistics: ^sft$limit_update_statistics;
         minimum_job_limit_value: ^avt$limit_value;
         maximum_job_limit_value: ^avt$limit_value;
         total_limit_applies: ^boolean;
         total_limit_stops_login: ^boolean;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      changed_default_value: boolean,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      current_description: ost$string,
      descriptive_text: ^avt$descriptive_text,
      field_utility_information: avt$field_utility_information,
      type_specification: avt$type_specification;

    status.normal := TRUE;
    changed_default_value := (job_warning_limit <> NIL) OR (job_maximum_limit <> NIL) OR (total_limit <> NIL);

    #CALLER_ID (caller_id);

{ Retrieve the description record that contains the field description for the specified field.

  /change/
    BEGIN
      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;
      get_field_description (field_name, validation_record_name, osc$null_name, {field_work_area=} NIL,
            description_record, default_value, type_specification, current_description,
            field_utility_information, file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ Verify that the field being changed is of the type specified.

      IF type_specification.kind <> avc$accumulating_limit_kind THEN
        osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'limit', status);
        EXIT /change/;
      IFEND;

{ Verify that the caller has the required authority.

      determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
      IF caller_authority < field_utility_information.manage_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /change/;
      IFEND;

{ Change the job warning limit if specified.

      IF job_warning_limit <> NIL THEN
        default_value.job_warning_limit := job_warning_limit;
      IFEND;

{ Change the job maximum limit if specified.

      IF job_maximum_limit <> NIL THEN
        default_value.job_maximum_limit := job_maximum_limit;
      IFEND;

{ Change the total limit if specified.

      IF total_limit <> NIL THEN
        default_value.total_limit := total_limit;
      IFEND;

{ Change the limit name if specified.
{ The limit name for system defined limits may not be changed.

      IF limit_name <> NIL THEN
        IF field_utility_information.delete_authority <> avc$system_authority THEN
          type_specification.limit_name := limit_name;
        ELSE
          IF limit_name^ <> type_specification.limit_name^ THEN
            osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
            EXIT /change/;
          IFEND;
        IFEND;
      IFEND;

{ Change the job limits apply value if specified.
{ The job limits apply value of system defined limits may not be changed.

      IF job_limits_apply <> NIL THEN
        IF field_utility_information.delete_authority <> avc$system_authority THEN
          type_specification.job_limits_apply := job_limits_apply;
        ELSE
          IF job_limits_apply^ <> type_specification.job_limits_apply^ THEN
            osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
            EXIT /change/;
          IFEND;
        IFEND;
      IFEND;

{ Change the limit update statistics values if specified.

      IF limit_update_statistics <> NIL THEN

{ A statistic code of zero signifies that the current list should be removed.

        IF limit_update_statistics^ [1].statistic_code = 0 THEN
          type_specification.limit_update_statistics := NIL;
        ELSEIF field_utility_information.delete_authority <> avc$system_authority THEN
          type_specification.limit_update_statistics := limit_update_statistics;
        ELSE
          osp$set_status_condition (ave$insufficient_authority, status);
          EXIT /change/;
        IFEND;
      IFEND;

{ Change the minimum job limit value if specified.

      IF minimum_job_limit_value <> NIL THEN
        type_specification.minimum_job_limit_value := minimum_job_limit_value;
      IFEND;

{ Change the maximum job limit value if specified.

      IF maximum_job_limit_value <> NIL THEN
        type_specification.maximum_job_limit_value := maximum_job_limit_value;
      IFEND;

{ Change the total limit applies value if specified.

      IF total_limit_applies <> NIL THEN
        type_specification.total_limit_applies := total_limit_applies;
      IFEND;

{ Change the total limit stops login value if specified.

      IF total_limit_stops_login <> NIL THEN
        type_specification.total_limit_stops_login := total_limit_stops_login;
      IFEND;

      change_field (field_name, validation_record_name, change_commands, display_commands, description,
            current_description, display_authority, change_authority, manage_authority, delete_authority,
            avc$change_accum_limit_command, default_value, type_specification, field_utility_information,
            file_information, status);
    END /change/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      emit_chg_field_audit_statistic (validation_record_name, file_information.file_name, field_name,
            changed_default_value, change_authority, display_authority, manage_authority, status);
    IFEND;

  PROCEND avp$change_accum_limit_field;
?? TITLE := '    avp$change_capability_field', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change an existing validation field's field
{ definition values.
{
{ DESIGN:
{
{   This interface is only callable by callers with authority equal to or above
{ the manage authority for the specified field.
{
{   The field being changed is verified to be of the type specified.
{
{   The default values and type specification values are updated.
{
{   A local procedure is called that:
{    - updates the record utility information for the description record
{    - updates the description for the field
{    - updates the field utility information for the field
{    - verifies the field for type conformance
{    - changes the field.
{

  PROCEDURE [XDCL, #GATE] avp$change_capability_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         capability: ^boolean;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      changed_default_value: boolean,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      current_description: ost$string,
      descriptive_text: ^avt$descriptive_text,
      field_utility_information: avt$field_utility_information,
      type_specification: avt$type_specification;

    status.normal := TRUE;
    changed_default_value := (capability <> NIL);

    #CALLER_ID (caller_id);

{ Retrieve the description record that contains the field description for the specified field.

  /change/
    BEGIN
      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;
      get_field_description (field_name, validation_record_name, osc$null_name, {field_work_area=} NIL,
            description_record, default_value, type_specification, current_description,
            field_utility_information, file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ Verify that the field being changed is of the type specified.

      IF type_specification.kind <> avc$capability_kind THEN
        osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'capability', status);
        EXIT /change/;
      IFEND;

{ Verify that the caller has the required authority.

      determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
      IF caller_authority < field_utility_information.manage_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /change/;
      IFEND;

{ Change the capability value if specified.

      IF capability <> NIL THEN
        default_value.capability := capability;
      IFEND;

      change_field (field_name, validation_record_name, NIL, NIL, description, current_description,
            display_authority, change_authority, manage_authority, delete_authority,
            avc$change_capability_command, default_value, type_specification, field_utility_information,
            file_information, status);
    END /change/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      emit_chg_field_audit_statistic (validation_record_name, file_information.file_name, field_name,
            changed_default_value, change_authority, display_authority, manage_authority, status);
    IFEND;

  PROCEND avp$change_capability_field;
?? TITLE := '    avp$change_date_time_field', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change an existing validation field's field
{ definition values.
{
{ DESIGN:
{
{   This interface is only callable by callers with authority equal to or above
{ the manage authority for the specified field.
{
{   The field being changed is verified to be of the type specified.
{
{   The default values and type specification values are updated.
{
{   A local procedure is called that:
{    - updates the record utility information for the description record
{    - updates the description for the field
{    - updates the field utility information for the field
{    - verifies the field for type conformance
{    - changes the field.
{

  PROCEDURE [XDCL, #GATE] avp$change_date_time_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         date_time: ^avt$date_time;
         date_applies: ^boolean;
         time_applies: ^boolean;
         date_display_format: ^clt$date_time_form_string;
         time_display_format: ^clt$date_time_form_string;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      changed_default_value: boolean,
      current_description: ost$string,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      descriptive_text: ^avt$descriptive_text,
      field_utility_information: avt$field_utility_information,
      type_specification: avt$type_specification;

    status.normal := TRUE;
    changed_default_value := (date_time <> NIL);

    #CALLER_ID (caller_id);

{ Retrieve the description record that contains the field description for the specified field.

  /change/
    BEGIN
      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;
      get_field_description (field_name, validation_record_name, osc$null_name, {field_work_area=} NIL,
            description_record, default_value, type_specification, current_description,
            field_utility_information, file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ Verify that the field being changed is of the type specified.

      IF type_specification.kind <> avc$date_time_kind THEN
        osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'date time', status);
        EXIT /change/;
      IFEND;

{ Verify that the caller has the required authority.

      determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
      IF caller_authority < field_utility_information.manage_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /change/;
      IFEND;

{ Change the date time value if specified.

      IF date_time <> NIL THEN
        default_value.date_time := date_time;
      IFEND;

{ Change the date applies value if specified.

      IF date_applies <> NIL THEN
        type_specification.date_applies := date_applies;
      IFEND;

{ Change the time applies value if specified.

      IF time_applies <> NIL THEN
        type_specification.time_applies := time_applies;
      IFEND;

{ Change the date display format value if specified.

      IF date_display_format <> NIL THEN
        type_specification.date_display_format := date_display_format;
      IFEND;

{ Change the time display format if specified.

      IF time_display_format <> NIL THEN
        type_specification.time_display_format := time_display_format;
      IFEND;

      change_field (field_name, validation_record_name, change_commands, display_commands, description,
            current_description, display_authority, change_authority, manage_authority, delete_authority,
            avc$change_date_time_command, default_value, type_specification, field_utility_information,
            file_information, status);
    END /change/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      emit_chg_field_audit_statistic (validation_record_name, file_information.file_name, field_name,
            changed_default_value, change_authority, display_authority, manage_authority, status);
    IFEND;

  PROCEND avp$change_date_time_field;
?? TITLE := '    avp$change_file_field', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change an existing validation field's field
{ definition values.
{
{ DESIGN:
{
{   This interface is only callable by callers with authority equal to or above
{ the manage authority for the specified field.
{
{   The field being changed is verified to be of the type specified.
{
{   The default values and type specification values are updated.
{
{   A local procedure is called that:
{    - updates the record utility information for the description record
{    - updates the description for the field
{    - updates the field utility information for the field
{    - verifies the field for type conformance
{    - changes the field.
{

  PROCEDURE [XDCL, #GATE] avp$change_file_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         file: ^fst$file_reference;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      changed_default_value: boolean,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      current_description: ost$string,
      descriptive_text: ^avt$descriptive_text,
      field_utility_information: avt$field_utility_information,
      type_specification: avt$type_specification;

    status.normal := TRUE;
    changed_default_value := (file <> NIL);

    #CALLER_ID (caller_id);

{ Retrieve the description record that contains the field description for the specified field.

  /change/
    BEGIN
      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;
      get_field_description (field_name, validation_record_name, osc$null_name, {field_work_area=} NIL,
            description_record, default_value, type_specification, current_description,
            field_utility_information, file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ Verify that the field being changed is of the type specified.

      IF type_specification.kind <> avc$file_kind THEN
        osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'file', status);
        EXIT /change/;
      IFEND;

{ Verify that the caller has the required authority.

      determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
      IF caller_authority < field_utility_information.manage_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /change/;
      IFEND;

{ Change the file value if specified.

      IF file <> NIL THEN
        default_value.file := file;
      IFEND;

      change_field (field_name, validation_record_name, change_commands, display_commands, description,
            current_description, display_authority, change_authority, manage_authority, delete_authority,
            avc$change_file_command, default_value, type_specification, field_utility_information,
            file_information, status);
    END /change/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      emit_chg_field_audit_statistic (validation_record_name, file_information.file_name, field_name,
            changed_default_value, change_authority, display_authority, manage_authority, status);
    IFEND;

  PROCEND avp$change_file_field;
?? TITLE := '    avp$change_integer_field', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change an existing validation field's field
{ definition values.
{
{ DESIGN:
{
{   This interface is only callable by callers with authority equal to or above
{ the manage authority for the specified field.
{
{   The field being changed is verified to be of the type specified.
{
{   The default values and type specification values are updated.
{
{   A local procedure is called that:
{    - updates the record utility information for the description record
{    - updates the description for the field
{    - updates the field utility information for the field
{    - verifies the field for type conformance
{    - changes the field.
{

  PROCEDURE [XDCL, #GATE] avp$change_integer_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         integer_value: ^integer;
         minimum_integer_value: ^integer;
         maximum_integer_value: ^integer;
         integer_display_format: ^avt$numeric_display_format;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      changed_default_value: boolean,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      current_description: ost$string,
      descriptive_text: ^avt$descriptive_text,
      field_utility_information: avt$field_utility_information,
      type_specification: avt$type_specification;

    status.normal := TRUE;
    changed_default_value := (integer_value <> NIL);

    #CALLER_ID (caller_id);

{ Retrieve the description record that contains the field description for the specified field.

  /change/
    BEGIN
      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;
      get_field_description (field_name, validation_record_name, osc$null_name, {field_work_area=} NIL,
            description_record, default_value, type_specification, current_description,
            field_utility_information, file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ Verify that the field being changed is of the type specified.

      IF type_specification.kind <> avc$integer_kind THEN
        osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'integer', status);
        EXIT /change/;
      IFEND;

{ Verify that the caller has the required authority.

      determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
      IF caller_authority < field_utility_information.manage_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /change/;
      IFEND;

{ Change the integer value if specified.

      IF integer_value <> NIL THEN
        default_value.integer_value := integer_value;
      IFEND;

{ Change the minimum integer value if specified.

      IF minimum_integer_value <> NIL THEN
        type_specification.minimum_integer_value := minimum_integer_value;
      IFEND;

{ Change the maximum integer value if specified.

      IF maximum_integer_value <> NIL THEN
        type_specification.maximum_integer_value := maximum_integer_value;
      IFEND;

{ Change the integer display format value if specified.

      IF integer_display_format <> NIL THEN
        type_specification.integer_display_format := integer_display_format;
      IFEND;

      change_field (field_name, validation_record_name, change_commands, display_commands, description,
           current_description, display_authority, change_authority, manage_authority, delete_authority,
            avc$change_integer_command, default_value, type_specification, field_utility_information,
            file_information, status);
    END /change/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      emit_chg_field_audit_statistic (validation_record_name, file_information.file_name, field_name,
            changed_default_value, change_authority, display_authority, manage_authority, status);
    IFEND;

  PROCEND avp$change_integer_field;
?? TITLE := '    avp$change_job_class_field', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change an existing validation field's field
{ definition values.
{
{ DESIGN:
{
{   This interface is only callable by callers with authority equal to or above
{ the manage authority for the specified field.
{
{   The field being changed is verified to be of the type specified.
{
{   The default values and type specification values are updated.
{
{   A local procedure is called that:
{    - updates the record utility information for the description record
{    - updates the description for the field
{    - updates the field utility information for the field
{    - verifies the field for type conformance
{    - changes the field.
{

  PROCEDURE [XDCL, #GATE] avp$change_job_class_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         add_job_classes: ^avt$name_list;
         delete_job_classes: ^avt$name_list;
         batch_job_class_default: ^ost$name;
         interactive_job_class_default: ^ost$name;
         add_common_job_classes: ^avt$name_list;
         delete_common_job_classes: ^avt$name_list;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      changed_default_value: boolean,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      current_description: ost$string,
      descriptive_text: ^avt$descriptive_text,
      field_utility_information: avt$field_utility_information,
      index: 1 .. avc$maximum_name_list_size,
      job_class_list: array [1 .. avc$maximum_name_list_size] of ost$name,
      number_of_job_classes: 1 .. avc$maximum_name_list_size,
      type_specification: avt$type_specification;

    status.normal := TRUE;
    changed_default_value := (add_job_classes <> NIL) OR (delete_job_classes <> NIL) OR
          (batch_job_class_default <> NIL) OR (interactive_job_class_default <> NIL);

    #CALLER_ID (caller_id);

{ Retrieve the description record that contains the field description for the specified field.

  /change/
    BEGIN
      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;
      get_field_description (field_name, validation_record_name, osc$null_name, {field_work_area=} NIL,
            description_record, default_value, type_specification, current_description,
            field_utility_information, file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ Verify that the field being changed is of the type specified.

      IF type_specification.kind <> avc$job_class_kind THEN
        osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'job class', status);
        EXIT /change/;
      IFEND;

{ Verify that the caller has the required authority.

      determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
      IF caller_authority < field_utility_information.manage_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /change/;
      IFEND;

{ Initialize a temporary array for holding the new list of job classes.

      FOR index := 1 TO avc$maximum_name_list_size DO
        job_class_list [index] := osc$null_name;
      FOREND;

{ Copy the current list of job classes to the temporary array.

      FOR index := 1 TO UPPERBOUND (default_value.job_classes^) DO
        job_class_list [index] := default_value.job_classes^ [index];
      FOREND;
      number_of_job_classes := UPPERBOUND (default_value.job_classes^);

{ Delete any specified job classes from the temporary array.

      IF delete_job_classes <> NIL THEN
        delete_names_from_name_list (delete_job_classes, 'delete_job_classes', job_class_list,
              number_of_job_classes, status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
      IFEND;

{ Add any specified job classes to the temporary array.

      IF add_job_classes <> NIL THEN
        add_names_to_name_list (add_job_classes, 'add_job_classes', job_class_list, number_of_job_classes,
              status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
      IFEND;

{ Move the temporary array to the job classes field.

      PUSH default_value.job_classes: [1 .. number_of_job_classes];
      FOR index := 1 TO number_of_job_classes DO
        default_value.job_classes^ [index] := job_class_list [index];
      FOREND;

{ Change the batch job class default value if specified.

      IF batch_job_class_default <> NIL THEN
        default_value.batch_job_class_default := batch_job_class_default;
      IFEND;

{ Change the interactive job class default value if specified.

      IF interactive_job_class_default <> NIL THEN
        default_value.interactive_job_class_default := interactive_job_class_default;
      IFEND;

{ Initialize a temporary array for holding the new list of common job classes.

      FOR index := 1 TO avc$maximum_name_list_size DO
        job_class_list [index] := osc$null_name;
      FOREND;

{ Copy the current list of common job classes to the temporary array.

      FOR index := 1 TO UPPERBOUND (type_specification.common_job_classes^) DO
        job_class_list [index] := type_specification.common_job_classes^ [index];
      FOREND;
      number_of_job_classes := UPPERBOUND (type_specification.common_job_classes^);

{ Delete any specified job classes from the temporary array.

      IF delete_common_job_classes <> NIL THEN
        delete_names_from_name_list (delete_common_job_classes, 'delete_common_job_classes', job_class_list,
              number_of_job_classes, status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
      IFEND;

{ Add any specified job classes to the temporary array.

      IF add_common_job_classes <> NIL THEN
        add_names_to_name_list (add_common_job_classes, 'add_common_job_classes', job_class_list,
              number_of_job_classes, status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
      IFEND;

{ Move the temporary array to the common job classes field.

      PUSH type_specification.common_job_classes: [1 .. number_of_job_classes];
      FOR index := 1 TO number_of_job_classes DO
        type_specification.common_job_classes^ [index] := job_class_list [index];
      FOREND;

      change_field (field_name, validation_record_name, change_commands, display_commands, description,
            current_description, display_authority, change_authority, manage_authority, delete_authority,
            avc$change_job_class_command, default_value, type_specification, field_utility_information,
            file_information, status);
    END /change/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      emit_chg_field_audit_statistic (validation_record_name, file_information.file_name, field_name,
            changed_default_value, change_authority, display_authority, manage_authority, status);
    IFEND;

  PROCEND avp$change_job_class_field;
?? TITLE := '    avp$change_labeled_names_field', EJECT ??
{ PURPOSE:
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change an existing validation field's field
{ definition values.
{
{ DESIGN:
{   This interface is only callable by callers with authority equal to or above
{ the manage authority for the specified field.
{
{   The field being changed is verified to be of the type specified.
{
{   The default values and type specification values are updated.
{
{   A local procedure is called that:
{    - updates the record utility information for the description record
{    - updates the description for the field
{    - updates the field utility information for the field
{    - verifies the field for type conformance
{    - changes the field.
{

  PROCEDURE [XDCL, #GATE] avp$change_labeled_names_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         add_labeled_names: ^avt$labeled_names_list;
         delete_labeled_names: ^avt$labeled_names_list;
         add_valid_labels: ^avt$name_list;
         delete_valid_labels: ^avt$name_list;
         add_valid_names: ^avt$name_list;
         delete_valid_names: ^avt$name_list;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      changed_default_value: boolean,
      current_description: ost$string,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      descriptive_text: ^avt$descriptive_text,
      field_utility_information: avt$field_utility_information,
      index1: 1 .. avc$maximum_name_list_size,
      labeled_names: ^avt$labeled_names_list,
      name_list: ^avt$name_list,
      number_of_names: 1 .. avc$maximum_name_list_size,
      type_specification: avt$type_specification,
      field_work_area: ^seq (*),
      work_area: ^seq (*);

    status.normal := TRUE;
    changed_default_value := (add_labeled_names <> NIL) OR (delete_labeled_names <> NIL);

    #CALLER_ID (caller_id);

{ Retrieve the description record that contains the field description for the specified field.

  /change/
    BEGIN
      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;
      PUSH field_work_area: [[REP 2 * avc$maximum_name_list_size OF avt$labeled_names]];
      RESET field_work_area;
      get_field_description (field_name, validation_record_name, osc$null_name, field_work_area,
            description_record, default_value, type_specification, current_description,
            field_utility_information, file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

  { Verify that the field being changed is of the type specified.

      IF type_specification.kind <> avc$labeled_names_kind THEN
        osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'labeled names', status);
        EXIT /change/;
      IFEND;

  { Verify that the caller has the required authority.

      determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
      IF caller_authority < field_utility_information.manage_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /change/;
      IFEND;

  { Change the labeled names default value.

      PUSH work_area: [[REP avc$max_template_record_size OF cell]];
      RESET work_area;
      change_labeled_names (add_labeled_names, delete_labeled_names, default_value, work_area,
            labeled_names, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

  { Move the temporary labeled names array to the labeled names field.

      PUSH default_value.labeled_names: [1 .. UPPERBOUND (labeled_names^)];
      FOR index1 := 1 TO UPPERBOUND (labeled_names^) DO
        default_value.labeled_names^ [index1] := labeled_names^ [index1];
      FOREND;

  { Initialize a temporary array for holding the new list of valid labels.

      PUSH name_list: [1 .. avc$maximum_name_list_size];
      FOR index1 := 1 TO avc$maximum_name_list_size DO
        name_list^ [index1] := osc$null_name;
      FOREND;

  { Copy the current list of valid labels to the temporary array.

      FOR index1 := 1 TO UPPERBOUND (type_specification.valid_labels^) DO
        name_list^ [index1] := type_specification.valid_labels^ [index1];
      FOREND;
      number_of_names := UPPERBOUND (type_specification.valid_labels^);

  { Delete any specified valid labels from the temporary array.

      IF delete_valid_labels <> NIL THEN
        delete_names_from_name_list (delete_valid_labels, 'delete_valid_labels', name_list^,
              number_of_names, status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
      IFEND;

  { Add any specified valid labels to the temporary array.

      IF add_valid_labels <> NIL THEN
        add_names_to_name_list (add_valid_labels, 'add_valid_labels', name_list^, number_of_names,
              status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
      IFEND;

  { Move the temporary array to the valid labels field.

      PUSH type_specification.valid_labels: [1 .. number_of_names];
      FOR index1 := 1 TO number_of_names DO
        type_specification.valid_labels^ [index1] := name_list^ [index1];
      FOREND;

  { Initialize a temporary array for holding the new list of valid labels.

      FOR index1 := 1 TO avc$maximum_name_list_size DO
        name_list^ [index1] := osc$null_name;
      FOREND;

  { Copy the current list of valid names to the temporary array.

      FOR index1 := 1 TO UPPERBOUND (type_specification.valid_names^) DO
        name_list^ [index1] := type_specification.valid_names^ [index1];
      FOREND;
      number_of_names := UPPERBOUND (type_specification.valid_names^);

  { Delete any specified valid names from the temporary array.

      IF delete_valid_names <> NIL THEN
        delete_names_from_name_list (delete_valid_names, 'delete_valid_names', name_list^,
              number_of_names, status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
      IFEND;

  { Add any specified valid names to the temporary array.

      IF add_valid_names <> NIL THEN
        add_names_to_name_list (add_valid_names, 'add_valid_names', name_list^, number_of_names,
              status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
      IFEND;

  { Move the temporary array to the valid names field.

      PUSH type_specification.valid_names: [1 .. number_of_names];
      FOR index1 := 1 TO number_of_names DO
        type_specification.valid_names^ [index1] := name_list^ [index1];
      FOREND;

      change_field (field_name, validation_record_name, change_commands, display_commands, description,
            current_description, display_authority, change_authority, manage_authority, delete_authority,
            avc$change_labeled_names_cmd, default_value, type_specification, field_utility_information,
            file_information, status);
    END /change/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      emit_chg_field_audit_statistic (validation_record_name, file_information.file_name, field_name,
            changed_default_value, change_authority, display_authority, manage_authority, status);
    IFEND;

  PROCEND avp$change_labeled_names_field;
?? TITLE := '    avp$change_limit_field', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change an existing validation field's field
{ definition values.
{
{ DESIGN:
{
{   This interface is only callable by callers with authority equal to or above
{ the manage authority for the specified field.
{
{   The field being changed is verified to be of the type specified.
{
{   The default values and type specification values are updated.
{
{   A local procedure is called that:
{    - updates the record utility information for the description record
{    - updates the description for the field
{    - updates the field utility information for the field
{    - verifies the field for type conformance
{    - changes the field.
{

  PROCEDURE [XDCL, #GATE] avp$change_limit_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         limit_value: ^avt$limit_value;
         minimum_limit_value: ^avt$limit_value;
         maximum_limit_value: ^avt$limit_value;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      changed_default_value: boolean,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      current_description: ost$string,
      descriptive_text: ^avt$descriptive_text,
      field_utility_information: avt$field_utility_information,
      type_specification: avt$type_specification;

    status.normal := TRUE;
    changed_default_value := (limit_value <> NIL);

    #CALLER_ID (caller_id);

{ Retrieve the description record that contains the field description for the specified field.

  /change/
    BEGIN
      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;
      get_field_description (field_name, validation_record_name, osc$null_name, {field_work_area=} NIL,
            description_record, default_value, type_specification, current_description,
            field_utility_information, file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ Verify that the field being changed is of the type specified.

      IF type_specification.kind <> avc$limit_kind THEN
        osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'limit', status);
        EXIT /change/;
      IFEND;

{ Verify that the caller has the required authority.

      determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
      IF caller_authority < field_utility_information.manage_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /change/;
      IFEND;

{ Change the limit value if specified.

      IF limit_value <> NIL THEN
        default_value.limit_value := limit_value;
      IFEND;

{ Change the minimum limit value if specified.

      IF minimum_limit_value <> NIL THEN
        type_specification.minimum_limit_value := minimum_limit_value;
      IFEND;

{ Change the maximum limit value if specified.

      IF maximum_limit_value <> NIL THEN
        type_specification.maximum_limit_value := maximum_limit_value;
      IFEND;

      change_field (field_name, validation_record_name, change_commands, display_commands, description,
            current_description, display_authority, change_authority, manage_authority, delete_authority,
            avc$change_limit_command, default_value, type_specification, field_utility_information,
            file_information, status);
    END /change/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      emit_chg_field_audit_statistic (validation_record_name, file_information.file_name, field_name,
            changed_default_value, change_authority, display_authority, manage_authority, status);
    IFEND;

  PROCEND avp$change_limit_field;
?? TITLE := '    avp$change_login_password_field', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change an existing validation field's field
{ definition values.
{
{ DESIGN:
{
{   This interface is only callable by callers with authority equal to or above
{ the manage authority for the specified field.
{
{   The field being changed is verified to be of the type specified.
{
{   The default values and type specification values are updated.
{
{   A local procedure is called that:
{    - updates the record utility information for the description record
{    - updates the description for the field
{    - updates the field utility information for the field
{    - verifies the field for type conformance
{    - changes the field.
{

  PROCEDURE [XDCL, #GATE] avp$change_login_password_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         login_password: ^avt$login_password;
         login_password_exp_date: ^ost$date_time;
         login_password_exp_interval: ^pmt$time_increment;
         login_password_max_exp_interval: ^pmt$time_increment;
         login_password_exp_warning: ^pmt$time_increment;
         login_password_exp_chg_interval: ^pmt$time_increment;
         add_password_attributes: ^avt$name_list;
         delete_password_attributes: ^avt$name_list;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      changed_default_value: boolean,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      current_description: ost$string,
      descriptive_text: ^avt$descriptive_text,
      field_utility_information: avt$field_utility_information,
      index: 1 .. avc$maximum_name_list_size,
      number_of_password_attributes: 1 .. avc$maximum_name_list_size,
      password_attribute_list: array [1 .. avc$maximum_name_list_size] of ost$name,
      type_specification: avt$type_specification;

    status.normal := TRUE;
    changed_default_value := (login_password <> NIL) OR (login_password_exp_date <> NIL) OR
          (login_password_exp_interval <> NIL) OR (login_password_max_exp_interval <> NIL) OR
          (login_password_exp_warning <> NIL) OR (login_password_exp_chg_interval <> NIL) OR
          (add_password_attributes <> NIL) OR (delete_password_attributes <> NIL);

    #CALLER_ID (caller_id);

{ Retrieve the description record that contains the field description for the specified field.

  /change/
    BEGIN
      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;
      get_field_description (field_name, validation_record_name, osc$null_name, {field_work_area=} NIL,
            description_record, default_value, type_specification, current_description,
            field_utility_information, file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ Verify that the field being changed is of the type specified.

      IF type_specification.kind <> avc$login_password_kind THEN
        osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'login password', status);
        EXIT /change/;
      IFEND;

{ Verify that the caller has the required authority.

      determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
      IF caller_authority < field_utility_information.manage_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /change/;
      IFEND;

{ Change the login password value if specified.

      IF login_password <> NIL THEN
        default_value.login_password := login_password;
      IFEND;

{ Change the expiration date value if specified.

      IF login_password_exp_date <> NIL THEN
        default_value.login_password_exp_date := login_password_exp_date;
      IFEND;

{ Change the expiration interval if specified.

      IF login_password_exp_interval <> NIL THEN
        default_value.login_password_exp_interval := login_password_exp_interval;
      IFEND;

{ Change the maximum expiration interval if specified.

      IF login_password_max_exp_interval <> NIL THEN
        default_value.login_password_max_exp_interval := login_password_max_exp_interval;
      IFEND;

{ Change the expiration warning interval if specified.

      IF login_password_exp_warning <> NIL THEN
        default_value.login_password_exp_warning := login_password_exp_warning;
      IFEND;

{ Change the expired password change interval if specified.

      IF login_password_exp_chg_interval <> NIL THEN
        default_value.login_password_exp_chg_interval := login_password_exp_chg_interval;
      IFEND;

{ Initialize a temporary array for holding the new list of password attributes.

      FOR index := 1 TO avc$maximum_name_list_size DO
        password_attribute_list [index] := osc$null_name;
      FOREND;

{ Copy the current list of password attributes to the temporary array.

      FOR index := 1 TO UPPERBOUND (default_value.login_password_attributes^) DO
        password_attribute_list [index] := default_value.login_password_attributes^ [index];
      FOREND;
      number_of_password_attributes := UPPERBOUND (default_value.login_password_attributes^);

{ Delete any specified password attributes from the temporary array.

      IF delete_password_attributes <> NIL THEN
        delete_names_from_name_list (delete_password_attributes, 'delete_password_attributes',
              password_attribute_list, number_of_password_attributes, status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
      IFEND;

{ Add any specified password attributes to the temporary array.

      IF add_password_attributes <> NIL THEN
        add_names_to_name_list (add_password_attributes, 'add_password_attributes', password_attribute_list,
              number_of_password_attributes, status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
      IFEND;

{ Move the temparary array to the password attributes field.

      PUSH default_value.login_password_attributes: [1 .. number_of_password_attributes];
      FOR index := 1 TO number_of_password_attributes DO
        default_value.login_password_attributes^ [index] := password_attribute_list [index];
      FOREND;

      change_field (field_name, validation_record_name, change_commands, display_commands, description,
            current_description, display_authority, change_authority, manage_authority, delete_authority,
            avc$change_login_password_cmd, default_value, type_specification, field_utility_information,
            file_information, status);
    END /change/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      emit_chg_field_audit_statistic (validation_record_name, file_information.file_name, field_name,
            changed_default_value, change_authority, display_authority, manage_authority, status);
    IFEND;

  PROCEND avp$change_login_password_field;
?? TITLE := '    avp$change_name_field', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change an existing validation field's field
{ definition values.
{
{ DESIGN:
{
{   This interface is only callable by callers with authority equal to or above
{ the manage authority for the specified field.
{
{   The field being changed is verified to be of the type specified.
{
{   The default values and type specification values are updated.
{
{   A local procedure is called that:
{    - updates the record utility information for the description record
{    - updates the description for the field
{    - updates the field utility information for the field
{    - verifies the field for type conformance
{    - changes the field.
{

  PROCEDURE [XDCL, #GATE] avp$change_name_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         add_names: ^avt$name_list;
         delete_names: ^avt$name_list;
         minimum_number_of_names: ^avt$name_list_size;
         maximum_number_of_names: ^avt$name_list_size;
         add_common_names: ^avt$name_list;
         delete_common_names: ^avt$name_list;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      changed_default_value: boolean,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      current_description: ost$string,
      descriptive_text: ^avt$descriptive_text,
      field_utility_information: avt$field_utility_information,
      index: 1 .. avc$maximum_name_list_size,
      number_of_common_names: 1 .. avc$maximum_name_list_size,
      number_of_names: 1 .. avc$maximum_name_list_size,
      name_list: array [1 .. avc$maximum_name_list_size] of ost$name,
      type_specification: avt$type_specification;

    status.normal := TRUE;
    changed_default_value := (add_names <> NIL) OR (delete_names<> NIL);

    #CALLER_ID (caller_id);

{ Retrieve the description record that contains the field description for the specified field.

  /change/
    BEGIN
      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;
      get_field_description (field_name, validation_record_name, osc$null_name, {field_work_area=} NIL,
            description_record, default_value, type_specification, current_description,
            field_utility_information, file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ Verify that the field being changed is of the type specified.

    IF type_specification.kind <> avc$name_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'name', status);
      EXIT /change/;
    IFEND;

{ Verify that the caller has the required authority.

      determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
      IF caller_authority < field_utility_information.manage_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /change/;
      IFEND;

{ Initialize a temporary array for holding the new list of names.

      FOR index := 1 TO avc$maximum_name_list_size DO
        name_list [index] := osc$null_name;
      FOREND;

{ Copy the current list of names to the temporary array.

      FOR index := 1 TO UPPERBOUND (default_value.names^) DO
        name_list [index] := default_value.names^ [index];
      FOREND;
      number_of_names := UPPERBOUND (default_value.names^);

{ Delete any specified names from the temporary array.

      IF delete_names <> NIL THEN
        delete_names_from_name_list (delete_names, 'delete_names', name_list, number_of_names, status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
      IFEND;

{ Add any specified names to the temporary array.

      IF add_names <> NIL THEN
        add_names_to_name_list (add_names, 'add_names', name_list, number_of_names, status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
      IFEND;

{ Move the temporary array to the name field.

      PUSH default_value.names: [1 .. number_of_names];
      FOR index := 1 TO number_of_names DO
        default_value.names^ [index] := name_list [index];
      FOREND;

{ Change the minimum number of names value if specified.

      IF minimum_number_of_names <> NIL THEN
        type_specification.minimum_number_of_names := minimum_number_of_names;
      IFEND;

{ Change the maximum number of names if specified.

      IF maximum_number_of_names <> NIL THEN
        type_specification.maximum_number_of_names := maximum_number_of_names;
      IFEND;

{ Initialize a temporary array for holding the new list of common names.

      FOR index := 1 TO avc$maximum_name_list_size DO
        name_list [index] := osc$null_name;
      FOREND;

{ Copy the current list of common names to the temporary array.

      FOR index := 1 TO UPPERBOUND (type_specification.common_names^) DO
        name_list [index] := type_specification.common_names^ [index];
      FOREND;
      number_of_common_names := UPPERBOUND (type_specification.common_names^);

{ Delete any specified common names from the temporary array.

      IF delete_common_names <> NIL THEN
        delete_names_from_name_list (delete_common_names, 'delete_common_names', name_list,
              number_of_common_names, status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
      IFEND;

{ Add any specified common names to the temporary array.

      IF add_common_names <> NIL THEN
        add_names_to_name_list (add_common_names, 'add_common_names', name_list, number_of_common_names,
              status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
      IFEND;

{ Move the temporary array to the common names field.

      PUSH type_specification.common_names: [1 .. number_of_common_names];
      FOR index := 1 TO number_of_common_names DO
        type_specification.common_names^ [index] := name_list [index];
      FOREND;

      change_field (field_name, validation_record_name, change_commands, display_commands, description,
            current_description, display_authority, change_authority, manage_authority, delete_authority,
            avc$change_name_command, default_value, type_specification, field_utility_information,
            file_information, status);
    END /change/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      emit_chg_field_audit_statistic (validation_record_name, file_information.file_name, field_name,
            changed_default_value, change_authority, display_authority, manage_authority, status);
    IFEND;

  PROCEND avp$change_name_field;
?? TITLE := '    avp$change_real_field', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change an existing validation field's field
{ definition values.
{
{ DESIGN:
{
{   This interface is only callable by callers with authority equal to or above
{ the manage authority for the specified field.
{
{   The field being changed is verified to be of the type specified.
{
{   The default values and type specification values are updated.
{
{   A local procedure is called that:
{    - updates the record utility information for the description record
{    - updates the description for the field
{    - updates the field utility information for the field
{    - verifies the field for type conformance
{    - changes the field.
{

  PROCEDURE [XDCL, #GATE] avp$change_real_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         real_value: ^real;
         minimum_real_value: ^real;
         maximum_real_value: ^real;
         real_display_format: ^avt$numeric_display_format;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      changed_default_value: boolean,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      current_description: ost$string,
      descriptive_text: ^avt$descriptive_text,
      field_utility_information: avt$field_utility_information,
      type_specification: avt$type_specification;

    status.normal := TRUE;
    changed_default_value := (real_value <> NIL);

    #CALLER_ID (caller_id);

{ Retrieve the description record that contains the field description for the specified field.

  /change/
    BEGIN
      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;
      get_field_description (field_name, validation_record_name, osc$null_name, {field_work_area=} NIL,
            description_record, default_value, type_specification, current_description,
            field_utility_information, file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ Verify that the field being changed is of the type specified.

      IF type_specification.kind <> avc$real_kind THEN
        osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'real', status);
        EXIT /change/;
      IFEND;

{ Verify that the caller has the required authority.

      determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
      IF caller_authority < field_utility_information.manage_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /change/;
      IFEND;

{ Change the real value if specified.

      IF real_value <> NIL THEN
        default_value.real_value := real_value;
      IFEND;

{ Change the minimum real value if specified.

      IF minimum_real_value <> NIL THEN
        type_specification.minimum_real_value := minimum_real_value;
      IFEND;

{ Change the maximum real value if specified.

      IF maximum_real_value <> NIL THEN
        type_specification.maximum_real_value := maximum_real_value;
      IFEND;

{ Change the real display format if specified.

      IF real_display_format <> NIL THEN
        type_specification.real_display_format := real_display_format;
      IFEND;

      change_field (field_name, validation_record_name, change_commands, display_commands, description,
            current_description, display_authority, change_authority, manage_authority, delete_authority,
            avc$change_real_command, default_value, type_specification, field_utility_information,
            file_information, status);
    END /change/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      emit_chg_field_audit_statistic (validation_record_name, file_information.file_name, field_name,
            changed_default_value, change_authority, display_authority, manage_authority, status);
    IFEND;

  PROCEND avp$change_real_field;
?? TITLE := '    avp$change_ring_privilege_field', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change an existing validation field's field
{ definition values.
{
{ DESIGN:
{
{   This interface is only callable by callers with authority equal to or above
{ the manage authority for the specified field.
{
{   The field being changed is verified to be of the type specified.
{
{   The default values and type specification values are updated.
{
{   A local procedure is called that:
{    - updates the record utility information for the description record
{    - updates the description for the field
{    - updates the field utility information for the field
{    - verifies the field for type conformance
{    - changes the field.
{

  PROCEDURE [XDCL, #GATE] avp$change_ring_privilege_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         minimum_ring: ^ost$ring;
         nominal_ring: ^ost$ring;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      changed_default_value: boolean,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      current_description: ost$string,
      descriptive_text: ^avt$descriptive_text,
      field_utility_information: avt$field_utility_information,
      type_specification: avt$type_specification;

    status.normal := TRUE;
    changed_default_value := (minimum_ring <> NIL) OR (nominal_ring <> NIL);

    #CALLER_ID (caller_id);

{ Retrieve the description record that contains the field description for the specified field.

  /change/
    BEGIN
      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;
      get_field_description (field_name, validation_record_name, osc$null_name, {field_work_area=} NIL,
            description_record, default_value, type_specification, current_description,
            field_utility_information, file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ Verify that the field being changed is of the type specified.

      IF type_specification.kind <> avc$ring_privilege_kind THEN
        osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'ring privilege', status);
        EXIT /change/;
      IFEND;

{ Verify that the caller has the required authority.

      determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
      IF caller_authority < field_utility_information.manage_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /change/;
      IFEND;

{ Change the minimum ring value if specified.

      IF minimum_ring <> NIL THEN
        default_value.minimum_ring := minimum_ring;
      IFEND;

{ Change the nominal ring value if specified.

      IF nominal_ring <> NIL THEN
        default_value.nominal_ring := nominal_ring;
      IFEND;

      change_field (field_name, validation_record_name, change_commands, display_commands, description,
            current_description, display_authority, change_authority, manage_authority, delete_authority,
            avc$change_ring_privilege_cmd, default_value, type_specification, field_utility_information,
            file_information, status);
    END /change/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      emit_chg_field_audit_statistic (validation_record_name, file_information.file_name, field_name,
            changed_default_value, change_authority, display_authority, manage_authority, status);
    IFEND;

  PROCEND avp$change_ring_privilege_field;
?? TITLE := '    avp$change_string_field', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change an existing validation field's field
{ definition values.
{
{ DESIGN:
{
{   This interface is only callable by callers with authority equal to or above
{ the manage authority for the specified field.
{
{   The field being changed is verified to be of the type specified.
{
{   The default values and type specification values are updated.
{
{   A local procedure is called that:
{    - updates the record utility information for the description record
{    - updates the description for the field
{    - updates the field utility information for the field
{    - verifies the field for type conformance
{    - changes the field.
{

  PROCEDURE [XDCL, #GATE] avp$change_string_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         string_value: ^ost$string;
         minimum_string_size: ^ost$string_size;
         maximum_string_size: ^ost$string_size;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      changed_default_value: boolean,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      current_description: ost$string,
      descriptive_text: ^avt$descriptive_text,
      field_utility_information: avt$field_utility_information,
      type_specification: avt$type_specification;

    status.normal := TRUE;
    changed_default_value := (string_value <> NIL);

    #CALLER_ID (caller_id);

{ Retrieve the description record that contains the field description for the specified field.

  /change/
    BEGIN
      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;
      get_field_description (field_name, validation_record_name, osc$null_name, {field_work_area=} NIL,
            description_record, default_value, type_specification, current_description,
            field_utility_information, file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ Verify that the field being changed is of the type specified.

      IF type_specification.kind <> avc$string_kind THEN
        osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'string', status);
        EXIT /change/;
      IFEND;

{ Verify that the caller has the required authority.

      determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
      IF caller_authority < field_utility_information.manage_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /change/;
      IFEND;

{ Change the string value if specified.

      IF string_value <> NIL THEN
        default_value.string_value := ^string_value^.value (1, string_value^.size);
      IFEND;

{ Change the minimum string size if specified.

      IF minimum_string_size <> NIL THEN
        type_specification.minimum_string_size := minimum_string_size;
      IFEND;

{ Change the maximum string size if specified.

      IF maximum_string_size <> NIL THEN
        type_specification.maximum_string_size := maximum_string_size;
      IFEND;

      change_field (field_name, validation_record_name, change_commands, display_commands, description,
            current_description, display_authority, change_authority, manage_authority, delete_authority,
            avc$change_string_command, default_value, type_specification, field_utility_information,
            file_information, status);
    END /change/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      emit_chg_field_audit_statistic (validation_record_name, file_information.file_name, field_name,
            changed_default_value, change_authority, display_authority, manage_authority, status);
    IFEND;

  PROCEND avp$change_string_field;
?? TITLE := '    change_field', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used by the previous field change interfaces to
{ change the common field information and update the requested field.
{

  PROCEDURE change_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         current_description: ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
         procedure_name: ost$name;
         default_value: avt$field_value;
         type_specification: avt$type_specification;
     VAR field_utility_information: avt$field_utility_information;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      descriptive_text: ^avt$descriptive_text,
      record_utility_information: ^avt$utility_information,
      utility_information: ^avt$utility_information,
      utility_information_size: integer;

    status.normal := TRUE;

{ Retrieve the change and display command information from the record
{ utility information if specified.

    IF ((change_commands <> NIL) OR (display_commands <> NIL)) THEN
      avp$get_desc_utility_info_size (validation_record_name, utility_information_size, file_information,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      PUSH record_utility_information: [[REP utility_information_size OF cell,
            REP avc$maximum_name_list_size OF avt$record_utility_info_entry]];
      RESET record_utility_information;
      utility_information_size := #SIZE (record_utility_information^);
      avp$get_desc_utility_info (validation_record_name, record_utility_information, file_information,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Change the change commands if specified.

    IF change_commands <> NIL THEN
      delete_record_utility_info_cmd (field_name, procedure_name, record_utility_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      add_new_record_utility_info_cmd (change_commands^, field_name, procedure_name,
            record_utility_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Change the display commands if specified.

    IF display_commands <> NIL THEN
      delete_record_utility_info_cmd (field_name, avc$display_field_value, record_utility_information,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      add_new_record_utility_info_cmd (display_commands^, field_name, avc$display_field_value,
            record_utility_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Change the description if specified.

    IF description <> NIL THEN
      descriptive_text := ^description^.value (1, description^.size);
    ELSE
      descriptive_text := ^current_description.value (1, current_description.size);
    IFEND;

{ Change the display authority if specified.

    IF display_authority <> NIL THEN
      field_utility_information.display_authority := display_authority^;
    IFEND;

{ Change the change authority if specified.

    IF change_authority <> NIL THEN
      field_utility_information.change_authority := change_authority^;
    IFEND;

{ Change the manage authority if specified.

    IF manage_authority <> NIL THEN
      field_utility_information.manage_authority := manage_authority^;
    IFEND;

{ Change the delete authority if specified.

    IF delete_authority <> NIL THEN
      field_utility_information.delete_authority := delete_authority^;
    IFEND;

{ Verify values are valid for this type.

    avp$verify_type_conformance (field_name, default_value, type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Sort the record utility information.
{ Note: The sort is after verify type conformance because it
{       will return an error if a duplicate entry is found and
{       any errors from verify type conformance should be first.

    IF ((change_commands <> NIL) OR (display_commands <> NIL)) THEN
      sort_record_utility_information (record_utility_information, utility_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Change the field.

    avp$change_field (field_name, validation_record_name, type_specification, default_value,
          descriptive_text, #SEQ (field_utility_information), file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Update the record utility command table information.

    IF ((change_commands <> NIL) OR (display_commands <> NIL)) THEN
      avp$change_desc_utility_info (validation_record_name, utility_information, file_information, status);
    IFEND;

  PROCEND change_field;
?? OLDTITLE ??
?? TITLE := '  Interfaces to delete, restore and change the name of validation fields' ??
?? NEWTITLE := '    avp$change_val_field_name', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change the name of a validation field.
{
{ DESIGN:
{
{   This interface is only callable by callers with authority equal to or above
{ the delete authority for the specified field.  The delete authority is used
{ instead of the manage authority because changing the name of a field is
{ essentially equivalent to deleting the field.
{
{   The command table information in the record utility information is update
{ along with the field name change.
{

  PROCEDURE [XDCL, #GATE] avp$change_val_field_name
    (    field_name: ost$name;
         validation_record_name: ost$name;
         new_field_name: ost$name;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      audit_information: sft$audit_information,
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      change_command_processor: ost$name,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      current_description: ost$string,
      field_utility_information: avt$field_utility_information,
      field_work_area: ^seq (*),
      record_utility_information: ^avt$utility_information,
      type_specification: avt$type_specification,
      utility_information: ^avt$utility_information,
      utility_information_size: integer;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

  /change_field_name/
    BEGIN

{ Retrieve the delete authority from the field utility information.

      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;
      PUSH field_work_area: [[REP 2 * avc$maximum_name_list_size OF avt$labeled_names]];
      RESET field_work_area;
      get_field_description (field_name, validation_record_name, osc$null_name, field_work_area,
            description_record, default_value, type_specification, current_description,
            field_utility_information, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$field_was_deleted THEN
          status.normal := TRUE;
        ELSE
          EXIT /change_field_name/;
        IFEND;
      IFEND;

{ Verify that the caller has the required authority.

      determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
      IF caller_authority < field_utility_information.delete_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /change_field_name/;
      IFEND;

{ Get the record utility information command table information.

      avp$get_desc_utility_info_size (validation_record_name, utility_information_size, file_information,
            status);
      IF NOT status.normal THEN
        EXIT /change_field_name/;
      IFEND;
      PUSH record_utility_information: [[REP utility_information_size OF cell,
            REP avc$maximum_name_list_size OF avt$record_utility_info_entry]];
      RESET record_utility_information;
      utility_information_size := #SIZE (record_utility_information^);
      avp$get_desc_utility_info (validation_record_name, record_utility_information, file_information,
            status);
      IF NOT status.normal THEN
        EXIT /change_field_name/;
      IFEND;

      IF (change_commands <> NIL) AND (display_commands <> NIL) THEN
        IF type_specification.kind <> avc$capability_kind THEN

{ Remove the command table entries related to the old field name.

          delete_record_utility_info_cmd (field_name, avc$display_field_value, record_utility_information,
                status);
          IF NOT status.normal THEN
            EXIT /change_field_name/;
          IFEND;

          CASE type_specification.kind OF
          = avc$account_project_kind =
           change_command_processor :=  avc$change_acct_proj_command;
          = avc$accumulating_limit_kind =
            change_command_processor :=  avc$change_accum_limit_command;
          = avc$date_time_kind =
            change_command_processor :=  avc$change_date_time_command;
          = avc$file_kind =
            change_command_processor :=  avc$change_file_command;
          = avc$integer_kind =
            change_command_processor :=  avc$change_integer_command;
          = avc$job_class_kind =
            change_command_processor :=  avc$change_job_class_command;
          = avc$limit_kind =
            change_command_processor :=  avc$change_limit_command;
          = avc$login_password_kind =
            change_command_processor :=  avc$change_login_password_cmd;
          = avc$name_kind =
            change_command_processor :=  avc$change_name_command;
          = avc$real_kind =
            change_command_processor :=  avc$change_real_command;
          = avc$ring_privilege_kind =
            change_command_processor :=  avc$change_ring_privilege_cmd;
          = avc$string_kind =
            change_command_processor :=  avc$change_string_command;
          ELSE
            change_command_processor := osc$null_name;
          CASEND;

          delete_record_utility_info_cmd (field_name, change_command_processor, record_utility_information,
                status);
          IF NOT status.normal THEN
            EXIT /change_field_name/;
          IFEND;

{ Add command table entries for the new field name.

          add_new_record_utility_info_cmd (display_commands^, new_field_name, avc$display_field_value,
                record_utility_information, status);
          IF NOT status.normal THEN
            EXIT /change_field_name/;
          IFEND;

          add_new_record_utility_info_cmd (change_commands^, new_field_name, change_command_processor,
                record_utility_information, status);
          IF NOT status.normal THEN
            EXIT /change_field_name/;
          IFEND;
        IFEND;
      ELSE

{ Change the field name within the command table information.

        change_utility_info_field_name (field_name, new_field_name, record_utility_information, status);
        IF NOT status.normal THEN
          EXIT /change_field_name/;
        IFEND;
      IFEND;

{ Sort the updated command table.

      sort_record_utility_information (record_utility_information, utility_information, status);
      IF NOT status.normal THEN
        EXIT /change_field_name/;
      IFEND;

{ NOTE: The order of the remaining code must not be changed so
{       that the command table remains in synch with the fields.

{ Change the validation field name.

      avp$change_field_name (field_name, validation_record_name, new_field_name, file_information, status);
      IF NOT status.normal THEN
        EXIT /change_field_name/;
      IFEND;

{ Rewrite the record utility information command table information.

      avp$change_desc_utility_info (validation_record_name, utility_information, file_information,
          status);
    END /change_field_name/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_information.audited_operation := sfc$ao_val_change_field_name;
      audit_information.change_val_field_name.description_record_name_p := ^validation_record_name;
      audit_information.change_val_field_name.validation_file_p := ^file_information.file_name;
      audit_information.change_val_field_name.original_field_name_p := ^field_name;
      audit_information.change_val_field_name.new_field_name_p := ^new_field_name;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;

  PROCEND avp$change_val_field_name;
?? TITLE := '    avp$delete_validation_field', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to logically delete a validation field.
{
{ DESIGN:
{
{    This interface is only callable by callers with authority equal to or
{ above the delete authority for the specified field.
{

  PROCEDURE [XDCL, #GATE] avp$delete_validation_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      audit_information: sft$audit_information,
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      current_description: ost$string,
      field_utility_information: avt$field_utility_information,
      field_work_area: ^seq (*),
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

  /delete_field/
    BEGIN

{ Retrieve the delete authority from the field utility information.

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;
    PUSH field_work_area: [[REP 2 * avc$maximum_name_list_size OF avt$labeled_names]];
    RESET field_work_area;
    get_field_description (field_name, validation_record_name, osc$null_name, {field_work_area=} NIL,
          description_record, default_value, type_specification, current_description,
          field_utility_information, file_information, status);
    IF NOT status.normal THEN
      EXIT /delete_field/;
    IFEND;

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < field_utility_information.delete_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      EXIT /delete_field/;
    IFEND;

    avp$delete_field (field_name, validation_record_name, file_information, status);
    END /delete_field/;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_information.audited_operation := sfc$ao_val_delete_field;
      audit_information.delete_validation_field.description_record_name_p := ^validation_record_name;
      audit_information.delete_validation_field.validation_file_p := ^file_information.file_name;
      audit_information.delete_validation_field.field_name_p := ^field_name;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;

  PROCEND avp$delete_validation_field;
?? TITLE := '    avp$restore_validation_field', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to restore a previously deleted validation field.
{
{ DESIGN:
{
{    This interface is only callable by callers with authority equal to or
{ above the delete authority for the specified field.
{

  PROCEDURE [XDCL, #GATE] avp$restore_validation_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      current_description: ost$string,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      field_utility_information: avt$field_utility_information,
      field_work_area: ^seq (*),
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Retrieve the delete authority from the field utility information.

    PUSH description_record: [[REP avc$max_template_record_size OF cell]];
    RESET description_record;
    PUSH field_work_area: [[REP 2 * avc$maximum_name_list_size OF avt$labeled_names]];
    RESET field_work_area;
    get_field_description (field_name, validation_record_name, osc$null_name, {field_work_area=} NIL,
          description_record, default_value, type_specification, current_description,
          field_utility_information, file_information, status);
    IF NOT status.normal THEN
      IF status.condition = ave$field_was_deleted THEN
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

{ Verify that the caller has the required authority.

    determine_caller_authority (caller_id, NIL, NIL, NIL, NIL, NIL, caller_authority);
    IF caller_authority < field_utility_information.delete_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Restore the field.

    avp$restore_field (field_name, validation_record_name, file_information, status);

  PROCEND avp$restore_validation_field;
?? OLDTITLE ??
?? TITLE := '  Interfaces to change field values' ??
?? NEWTITLE := '    avp$change_acct_proj_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change the value of an account project type
{ validation field within a validation record that has been previously
{ stored by a separate validation interface.
{
{ DESIGN:
{
{   This interface first calls a local procedure which, verifies that the
{ caller has the required authority to change the field requested, gets
{ pointers to the requested validation record information in memory, and
{ retrieves the current value for the field being changed.
{
{   The current values for the field being changed are replaced by any values
{ specified on the input parameters, and the resulting field value is
{ verified for type conformance.
{
{   A warning status is returned if the account and/or project do not exist in
{ the validation file or if the user is not a member of the account or project,
{ when the system validation level is set to account or project.
{

  PROCEDURE [XDCL, #GATE] avp$change_acct_proj_value
    (    field_name: ost$name;
         account_name: ^avt$account_name;
         project_name: ^avt$project_name;
         record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      account_exists: boolean,
      field_value_info: avt$field_value,
      field_value_list_entry: ^avt$field_value_list_entry,
      ignore_status: ost$status,
      key: avt$validation_key,
      project_exists: boolean,
      validation_record_info: ^avt$validation_record_info,
      type_specification: avt$type_specification,
      valid_account: boolean,
      valid_member: boolean,
      valid_project: boolean;

    status.normal := TRUE;

{ Set up for changing a field value.

  /change/
    BEGIN
      initialize_change_value_info (field_name, record_id, {work_area=} NIL, type_specification,
            field_value_list_entry, validation_record_info, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_info := field_value_list_entry^.field_value;

{ Change account name if specified.

      IF account_name <> NIL THEN
        NEXT field_value_info.account_name IN validation_record_info^.work_area.sequence_pointer;
        field_value_info.account_name^ := account_name^;
      IFEND;

{ Change project name if specified.

      IF project_name <> NIL THEN
        NEXT field_value_info.project_name IN validation_record_info^.work_area.sequence_pointer;
        field_value_info.project_name^ := project_name^;
      IFEND;

{ Verify values are valid for this type.

      avp$verify_type_conformance (field_name, field_value_info, type_specification, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_list_entry^.field_value := field_value_info;

{ Verify that the user is a member of the account and/or project.

      verify_acct_proj_membership (avp$validation_level (), field_value_info.account_name^,
            field_value_info.project_name^, validation_record_info^.key.user_name, valid_account,
            valid_project, valid_member, file_information, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      IF NOT valid_member THEN
        IF NOT valid_account THEN
          osp$set_status_abnormal ('AV', ave$account_does_not_exist_warn, field_value_info.account_name^,
                status);
        ELSEIF NOT valid_project THEN
          osp$set_status_abnormal ('AV', ave$project_does_not_exist_warn, field_value_info.project_name^,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, field_value_info.account_name^,
                status);
        ELSEIF avp$validation_level () = avc$account_level THEN
          osp$set_status_abnormal ('AV', ave$acc_mem_does_not_exist_warn,
                validation_record_info^.key.user_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, field_value_info.account_name^,
                status);
        ELSE
          osp$set_status_abnormal ('AV', ave$member_does_not_exist_warn,
                validation_record_info^.key.user_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, field_value_info.account_name^,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, field_value_info.project_name^,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, field_value_info.account_name^,
                status);
        IFEND;
      IFEND;
    END /change/;

{ Emit the audit statistic for unsuccessful changes (successful changes are audited when the subutility ends).

    IF (avp$security_option_active (avc$vso_security_audit)) AND (NOT status.normal) THEN
      emit_chg_value_audit_statistic (validation_record_info^.description_record_name,
            file_information.file_name, validation_record_info^.key, field_name, status);
    IFEND;

  PROCEND avp$change_acct_proj_value;
?? TITLE := '    avp$change_accum_limit_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change the value of an accumulating limit type
{ validation field within a validation record that has been previously
{ stored by a separate validation interface.
{
{ DESIGN:
{
{   This interface first calls a local procedure which, verifies that the
{ caller has the required authority to change the field requested, gets
{ pointers to the requested validation record information in memory, and
{ retrieves the current value for the field being changed.
{
{   The current values for the field being changed are replaced by any values
{ specified on the input parameters, and the resulting field value is
{ verified for type conformance.
{

  PROCEDURE [XDCL, #GATE] avp$change_accum_limit_value
    (    field_name: ost$name;
         job_warning_limit: ^avt$limit_value;
         job_maximum_limit: ^avt$limit_value;
         total_limit: ^avt$limit_value;
         total_accumulation: ^avt$limit_value;
         record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      field_value_info: avt$field_value,
      field_value_list_entry: ^avt$field_value_list_entry,
      validation_record_info: ^avt$validation_record_info,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Set up for changing a field value.

  /change/
    BEGIN
      initialize_change_value_info (field_name, record_id, {work_area=} NIL, type_specification,
            field_value_list_entry, validation_record_info, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_info := field_value_list_entry^.field_value;

{ Change job warning if specified.

      IF job_warning_limit <> NIL THEN
        NEXT field_value_info.job_warning_limit IN validation_record_info^.work_area.sequence_pointer;
        field_value_info.job_warning_limit^ := job_warning_limit^;
      IFEND;

{ Change job maximum limit if specified.

      IF job_maximum_limit <> NIL THEN
        NEXT field_value_info.job_maximum_limit IN validation_record_info^.work_area.sequence_pointer;
        field_value_info.job_maximum_limit^ := job_maximum_limit^;
      IFEND;

{ Change total limit if specified.

      IF total_limit <> NIL THEN
        NEXT field_value_info.total_limit IN validation_record_info^.work_area.sequence_pointer;
        field_value_info.total_limit^ := total_limit^;
      IFEND;

{ Change total accumulation if specified.

      IF total_accumulation <> NIL THEN
        NEXT field_value_info.total_accumulation IN validation_record_info^.work_area.sequence_pointer;
        field_value_info.total_accumulation^ := total_accumulation^;
      IFEND;

{ Verify values are valid for this type.

      avp$verify_type_conformance (field_name, field_value_info, type_specification, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_list_entry^.field_value := field_value_info;
    END /change/;

{ Emit the audit statistic for unsuccessful changes (successful changes are audited when the subutility ends).

    IF (avp$security_option_active (avc$vso_security_audit)) AND (NOT status.normal) THEN
      emit_chg_value_audit_statistic (validation_record_info^.description_record_name,
            file_information.file_name, validation_record_info^.key, field_name, status);
    IFEND;

  PROCEND avp$change_accum_limit_value;
?? TITLE := '    avp$change_capability_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change the value of a capability type
{ validation field within a validation record that has been previously
{ stored by a separate validation interface.
{
{ DESIGN:
{
{   This interface first calls a local procedure which, verifies that the
{ caller has the required authority to change the field requested, gets
{ pointers to the requested validation record information in memory, and
{ retrieves the current value for the field being changed.
{
{   The current values for the field being changed are replaced by any values
{ specified on the input parameters, and the resulting field value is
{ verified for type conformance.
{

  PROCEDURE [XDCL, #GATE] avp$change_capability_value
    (    field_name: ost$name;
         capability: ^boolean;
         record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      field_value_info: avt$field_value,
      field_value_list_entry: ^avt$field_value_list_entry,
      validation_record_info: ^avt$validation_record_info,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Set up for changing a field value.

  /change/
    BEGIN
      initialize_change_value_info (field_name, record_id, {work_area=} NIL, type_specification,
            field_value_list_entry, validation_record_info, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_info := field_value_list_entry^.field_value;

{ Change capability value if specified.

      IF capability <> NIL THEN
        NEXT field_value_info.capability IN validation_record_info^.work_area.sequence_pointer;
        field_value_info.capability^ := capability^;
      IFEND;

{ Verify values are valid for this type.

      avp$verify_type_conformance (field_name, field_value_info, type_specification, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_list_entry^.field_value := field_value_info;
    END /change/;

{ Emit the audit statistic for unsuccessful changes (successful changes are audited when the subutility ends).

    IF (avp$security_option_active (avc$vso_security_audit)) AND (NOT status.normal) THEN
      emit_chg_value_audit_statistic (validation_record_info^.description_record_name,
            file_information.file_name, validation_record_info^.key, field_name, status);
    IFEND;

  PROCEND avp$change_capability_value;
?? TITLE := '    avp$change_date_time_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change the value of a date time type
{ validation field within a validation record that has been previously
{ stored by a separate validation interface.
{
{ DESIGN:
{
{   This interface first calls a local procedure which, verifies that the
{ caller has the required authority to change the field requested, gets
{ pointers to the requested validation record information in memory, and
{ retrieves the current value for the field being changed.
{
{   The current values for the field being changed are replaced by any values
{ specified on the input parameters, and the resulting field value is
{ verified for type conformance.
{

  PROCEDURE [XDCL, #GATE] avp$change_date_time_value
    (    field_name: ost$name;
         date_time: ^avt$date_time;
         record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      field_value_info: avt$field_value,
      field_value_list_entry: ^avt$field_value_list_entry,
      validation_record_info: ^avt$validation_record_info,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Set up for changing a field value.

  /change/
    BEGIN
      initialize_change_value_info (field_name, record_id, {work_area=} NIL, type_specification,
            field_value_list_entry, validation_record_info, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_info := field_value_list_entry^.field_value;

{ Change date time value if specified.

      IF date_time <> NIL THEN
        NEXT field_value_info.date_time IN validation_record_info^.work_area.sequence_pointer;
        field_value_info.date_time^ := date_time^;
      IFEND;

{ Verify values are valid for this type.

      avp$verify_type_conformance (field_name, field_value_info, type_specification, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_list_entry^.field_value := field_value_info;
    END /change/;

{ Emit the audit statistic for unsuccessful changes (successful changes are audited when the subutility ends).

    IF (avp$security_option_active (avc$vso_security_audit)) AND (NOT status.normal) THEN
      emit_chg_value_audit_statistic (validation_record_info^.description_record_name,
            file_information.file_name, validation_record_info^.key, field_name, status);
    IFEND;

  PROCEND avp$change_date_time_value;
?? TITLE := '    avp$change_file_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change the value of a file type
{ validation field within a validation record that has been previously
{ stored by a separate validation interface.
{
{ DESIGN:
{
{   This interface first calls a local procedure which, verifies that the
{ caller has the required authority to change the field requested, gets
{ pointers to the requested validation record information in memory, and
{ retrieves the current value for the field being changed.
{
{   The current values for the field being changed are replaced by any values
{ specified on the input parameters, and the resulting field value is
{ verified for type conformance.
{

  PROCEDURE [XDCL, #GATE] avp$change_file_value
    (    field_name: ost$name;
         file: ^fst$file_reference;
         record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      field_value_info: avt$field_value,
      field_value_list_entry: ^avt$field_value_list_entry,
      validation_record_info: ^avt$validation_record_info,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Set up for changing a field value.

  /change/
    BEGIN
      initialize_change_value_info (field_name, record_id, {work_area=} NIL, type_specification,
            field_value_list_entry, validation_record_info, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_info := field_value_list_entry^.field_value;

{ Change file value if specified.

      IF file <> NIL THEN
        NEXT field_value_info.file: [clp$trimmed_string_size (file^)] IN
              validation_record_info^.work_area.sequence_pointer;
        field_value_info.file^ := file^;
      IFEND;

{ Verify values are valid for this type.

      avp$verify_type_conformance (field_name, field_value_info, type_specification, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_list_entry^.field_value := field_value_info;
    END /change/;

{ Emit the audit statistic for unsuccessful changes (successful changes are audited when the subutility ends).

    IF (avp$security_option_active (avc$vso_security_audit)) AND (NOT status.normal) THEN
      emit_chg_value_audit_statistic (validation_record_info^.description_record_name,
            file_information.file_name, validation_record_info^.key, field_name, status);
    IFEND;

  PROCEND avp$change_file_value;
?? TITLE := '    avp$change_integer_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change the value of an integer type
{ validation field within a validation record that has been previously
{ stored by a separate validation interface.
{
{ DESIGN:
{
{   This interface first calls a local procedure which, verifies that the
{ caller has the required authority to change the field requested, gets
{ pointers to the requested validation record information in memory, and
{ retrieves the current value for the field being changed.
{
{   The current values for the field being changed are replaced by any values
{ specified on the input parameters, and the resulting field value is
{ verified for type conformance.
{

  PROCEDURE [XDCL, #GATE] avp$change_integer_value
    (    field_name: ost$name;
         integer_value: ^integer;
         record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      field_value_info: avt$field_value,
      field_value_list_entry: ^avt$field_value_list_entry,
      validation_record_info: ^avt$validation_record_info,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Set up for changing a field value.

  /change/
    BEGIN
      initialize_change_value_info (field_name, record_id, {work_area=} NIL, type_specification,
            field_value_list_entry, validation_record_info, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_info := field_value_list_entry^.field_value;

{ Change integer value if specified.

      IF integer_value <> NIL THEN
        NEXT field_value_info.integer_value IN validation_record_info^.work_area.sequence_pointer;
        field_value_info.integer_value^ := integer_value^;
      IFEND;

{ Verify values are valid for this type.

      avp$verify_type_conformance (field_name, field_value_info, type_specification, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_list_entry^.field_value := field_value_info;
    END /change/;

{ Emit the audit statistic for unsuccessful changes (successful changes are audited when the subutility ends).

    IF (avp$security_option_active (avc$vso_security_audit)) AND (NOT status.normal) THEN
      emit_chg_value_audit_statistic (validation_record_info^.description_record_name,
            file_information.file_name, validation_record_info^.key, field_name, status);
    IFEND;

  PROCEND avp$change_integer_value;
?? TITLE := '    avp$change_job_class_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change the value of a job class type
{ validation field within a validation record that has been previously
{ stored by a separate validation interface.
{
{ DESIGN:
{
{   This interface first calls a local procedure which, verifies that the
{ caller has the required authority to change the field requested, gets
{ pointers to the requested validation record information in memory, and
{ retrieves the current value for the field being changed.
{
{   The current values for the field being changed are replaced by any values
{ specified on the input parameters, and the resulting field value is
{ verified for type conformance.
{

  PROCEDURE [XDCL, #GATE] avp$change_job_class_value
    (    field_name: ost$name;
         add_job_classes: ^avt$name_list;
         delete_job_classes: ^avt$name_list;
         batch_job_class_default: ^ost$name;
         interactive_job_class_default: ^ost$name;
         record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      field_value_info: avt$field_value,
      field_value_list_entry: ^avt$field_value_list_entry,
      index: 1 .. avc$maximum_name_list_size,
      job_class_list: array [1 .. avc$maximum_name_list_size] of ost$name,
      number_of_job_classes: 1 .. avc$maximum_name_list_size,
      validation_record_info: ^avt$validation_record_info,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Set up for changing a field value.

  /change/
    BEGIN
      initialize_change_value_info (field_name, record_id, {work_area=} NIL, type_specification,
            field_value_list_entry, validation_record_info, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_info := field_value_list_entry^.field_value;

{ Initialize a temporary array for holding the new list of job classes.

      FOR index := 1 TO avc$maximum_name_list_size DO
        job_class_list [index] := osc$null_name;
      FOREND;

{ Copy the current list of job classes to the temporary array.

      FOR index := 1 TO UPPERBOUND (field_value_list_entry^.field_value.job_classes^) DO
        job_class_list [index] := field_value_list_entry^.field_value.job_classes^ [index];
      FOREND;
      number_of_job_classes := UPPERBOUND (field_value_list_entry^.field_value.job_classes^);

{ Delete any specified job classes from the temporary array.

      IF delete_job_classes <> NIL THEN
        delete_names_from_name_list (delete_job_classes, 'delete_job_classes', job_class_list,
              number_of_job_classes, status);
      IFEND;

{ Add any specified job classes to the temporary array.

      IF add_job_classes <> NIL THEN
        add_names_to_name_list (add_job_classes, 'add_job_classes', job_class_list, number_of_job_classes,
              status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
      IFEND;

{ Move the temporary array to the job classes field.

      NEXT field_value_info.job_classes: [1 .. number_of_job_classes] IN
            validation_record_info^.work_area.sequence_pointer;
      FOR index := 1 TO number_of_job_classes DO
        field_value_info.job_classes^ [index] := job_class_list [index];
      FOREND;

{ Change the batch job class default value if specified.

      IF batch_job_class_default <> NIL THEN
        NEXT field_value_info.batch_job_class_default IN validation_record_info^.work_area.sequence_pointer;
        field_value_info.batch_job_class_default^ := batch_job_class_default^;
      IFEND;

{ Change the interactive job class default value if specified.

      IF interactive_job_class_default <> NIL THEN
        NEXT field_value_info.interactive_job_class_default IN
              validation_record_info^.work_area.sequence_pointer;
        field_value_info.interactive_job_class_default^ := interactive_job_class_default^;
      IFEND;

{ Verify values are valid for this type.

      avp$verify_type_conformance (field_name, field_value_info, type_specification, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_list_entry^.field_value := field_value_info;
    END /change/;

{ Emit the audit statistic for unsuccessful changes (successful changes are audited when the subutility ends).

    IF (avp$security_option_active (avc$vso_security_audit)) AND (NOT status.normal) THEN
      emit_chg_value_audit_statistic (validation_record_info^.description_record_name,
            file_information.file_name, validation_record_info^.key, field_name, status);
    IFEND;

  PROCEND avp$change_job_class_value;
?? TITLE := '    avp$change_labeled_names_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change the value of a name type
{ validation field within a validation record that has been previously
{ stored by a separate validation interface.
{
{ DESIGN:
{
{   This interface first calls a local procedure which, verifies that the
{ caller has the required authority to change the field requested, gets
{ pointers to the requested validation record information in memory, and
{ retrieves the current value for the field being changed.
{
{   The current values for the field being changed are replaced by any values
{ specified on the input parameters, and the resulting field value is
{ verified for type conformance.
{

  PROCEDURE [XDCL, #GATE] avp$change_labeled_names_value
    (    field_name: ost$name;
         add_labeled_names: ^avt$labeled_names_list;
         delete_labeled_names: ^avt$labeled_names_list;
         record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      field_value_info: avt$field_value,
      field_value_list_entry: ^avt$field_value_list_entry,
      field_work_area: ^seq (*),
      index: 1 .. avc$maximum_name_list_size,
      labeled_names: ^avt$labeled_names_list,
      name_list: array [1 .. avc$maximum_name_list_size] of ost$name,
      number_of_names: 1 .. avc$maximum_name_list_size,
      validation_record_info: ^avt$validation_record_info,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Set up for changing a field value.

  /change/
    BEGIN
      find_validation_record_info (record_id, validation_record_info, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      NEXT field_work_area: [[REP 2 * avc$maximum_name_list_size OF avt$labeled_names]] IN
            validation_record_info^.work_area.sequence_pointer;
      RESET field_work_area;

      initialize_change_value_info (field_name, record_id, field_work_area, type_specification,
            field_value_list_entry, validation_record_info, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_info := field_value_list_entry^.field_value;

  { Change the labeled names field value.

      change_labeled_names (add_labeled_names, delete_labeled_names, field_value_info,
            validation_record_info^.work_area.sequence_pointer, labeled_names, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

  { Move the temporary labeled names array to the labeled names field.

      NEXT field_value_info.labeled_names: [1 .. UPPERBOUND (labeled_names^)] IN
            validation_record_info^.work_area.sequence_pointer;
      FOR index := 1 TO UPPERBOUND (labeled_names^) DO
        field_value_info.labeled_names^ [index] := labeled_names^ [index];
      FOREND;

  { Verify values are valid for this type.

      avp$verify_type_conformance (field_name, field_value_info, type_specification, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_list_entry^.field_value := field_value_info;
    END /change/;

{ Emit the audit statistic for unsuccessful changes (successful changes are audited when the subutility ends).

    IF (avp$security_option_active (avc$vso_security_audit)) AND (NOT status.normal) THEN
      emit_chg_value_audit_statistic (validation_record_info^.description_record_name,
            file_information.file_name, validation_record_info^.key, field_name, status);
    IFEND;

  PROCEND avp$change_labeled_names_value;
?? TITLE := '    avp$change_limit_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change the value of a limit type
{ validation field within a validation record that has been previously
{ stored by a separate validation interface.
{
{ DESIGN:
{
{   This interface first calls a local procedure which, verifies that the
{ caller has the required authority to change the field requested, gets
{ pointers to the requested validation record information in memory, and
{ retrieves the current value for the field being changed.
{
{   The current values for the field being changed are replaced by any values
{ specified on the input parameters, and the resulting field value is
{ verified for type conformance.
{

  PROCEDURE [XDCL, #GATE] avp$change_limit_value
    (    field_name: ost$name;
         limit_value: ^avt$limit_value;
         record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      field_value_info: avt$field_value,
      field_value_list_entry: ^avt$field_value_list_entry,
      validation_record_info: ^avt$validation_record_info,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Set up for changing a field value.

  /change/
    BEGIN
      initialize_change_value_info (field_name, record_id, {work_area=} NIL, type_specification,
            field_value_list_entry, validation_record_info, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_info := field_value_list_entry^.field_value;

{ Change limit value if specified.

      IF limit_value <> NIL THEN
        NEXT field_value_info.limit_value IN validation_record_info^.work_area.sequence_pointer;
        field_value_info.limit_value^ := limit_value^;
      IFEND;

{ Verify values are valid for this type.

      avp$verify_type_conformance (field_name, field_value_info, type_specification, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_list_entry^.field_value := field_value_info;
    END /change/;

{ Emit the audit statistic for unsuccessful changes (successful changes are audited when the subutility ends).

    IF (avp$security_option_active (avc$vso_security_audit)) AND (NOT status.normal) THEN
      emit_chg_value_audit_statistic (validation_record_info^.description_record_name,
            file_information.file_name, validation_record_info^.key, field_name, status);
    IFEND;

  PROCEND avp$change_limit_value;
?? TITLE := '    avp$change_login_password_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change the value of a login password type
{ validation field within a validation record that has been previously
{ stored by a separate validation interface.
{
{ DESIGN:
{
{   This interface first calls a local procedure which, verifies that the
{ caller has the required authority to change the field requested, gets
{ pointers to the requested validation record information in memory, and
{ retrieves the current value for the field being changed.
{
{   The maximum expiration interval and password attributes fields are
{ changeable only by user administrators or above even if the change
{ authority for the field is below user administrator.
{
{   Specifying an expiration date without specifying a new password may only be
{ done by user administrators or above even if the change authority for the
{ field is below user administrator.
{
{   The current values for the field being changed are replaced by any values
{ specified on the input parameters, and the resulting field value is
{ verified for type conformance.
{
{   If update_batch_job_passwords = TRUE, then update the login_password in queued
{ and deferred batch jobs belonging to the user to the new value.

  PROCEDURE [XDCL, #GATE] avp$change_login_password_value
    (    field_name: ost$name;
         old_password: ^string (osc$max_name_size);
         login_password: ^avt$login_password;
         login_password_exp_date: ^ost$date_time;
         login_password_exp_interval: ^pmt$time_increment;
         login_password_max_exp_interval: ^pmt$time_increment;
         login_password_exp_warning: ^pmt$time_increment;
         login_password_exp_chg_interval: ^pmt$time_increment;
         add_password_attributes: ^avt$name_list;
         delete_password_attributes: ^avt$name_list;
         record_id: ost$name;
         update_batch_job_passwords: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      current_date_time: ost$date_time,
      evaluated_file_reference: fst$evaluated_file_reference,
      field_value_info: avt$field_value,
      field_value_list_entry: ^avt$field_value_list_entry,
      file_utility_information: ^avt$file_utility_information,
      index: 1 .. avc$maximum_name_list_size,
      input_attribute_changes_p: ^jmt$input_attribute_changes,
      job_index: jmt$job_status_count,
      job_name: jmt$name,
      job_status_options_p: ^jmt$job_status_options,
      job_status_results_keys_p: ^jmt$results_keys,
      job_status_results_p: ^jmt$job_status_results,
      login_password_attribute_list: array [1 .. avc$maximum_name_list_size] of ost$name,
      new_password: string (osc$max_name_size),
      number_of_jobs_found: jmt$job_status_count,
      number_of_password_attributes: 1 .. avc$maximum_name_list_size,
      old_login_password: avt$login_password,
      result_size: ost$segment_length,
      type_specification: avt$type_specification,
      user_name: ost$user_name,
      utility_information: ^avt$utility_information,
      validation_record_info: ^avt$validation_record_info,
      verified_old_password: string (osc$max_name_size),
      verified_old_login_password: avt$login_password,
      work_area_p: ^jmt$work_area;

    status.normal := TRUE;

{ Set up for changing a field value.

  /change/
    BEGIN
      initialize_change_value_info (field_name, record_id, {work_area=} NIL, type_specification,
            field_value_list_entry, validation_record_info, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

{ Get the current date and time.

      pmp$get_compact_date_time (current_date_time, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      old_login_password := field_value_list_entry^.field_value.login_password^;
      field_value_info := field_value_list_entry^.field_value;

{ Unconditional allocation of all of the fields is done up front in this procedure because
{ the password attribute change hook may assign new values which must be stored in the work area heap.

      NEXT field_value_info.login_password IN validation_record_info^.work_area.sequence_pointer;
      field_value_info.login_password^ := field_value_list_entry^.field_value.login_password^;

      NEXT field_value_info.login_password_exp_date IN validation_record_info^.work_area.sequence_pointer;
      field_value_info.login_password_exp_date^ :=
            field_value_list_entry^.field_value.login_password_exp_date^;

      NEXT field_value_info.login_password_exp_interval IN validation_record_info^.work_area.sequence_pointer;
      field_value_info.login_password_exp_interval^ := field_value_list_entry^.field_value.
            login_password_exp_interval^;

      NEXT field_value_info.login_password_exp_warning IN validation_record_info^.work_area.sequence_pointer;
      field_value_info.login_password_exp_warning^ := field_value_list_entry^.field_value.
            login_password_exp_warning^;

      NEXT field_value_info.login_password_exp_chg_interval IN
            validation_record_info^.work_area.sequence_pointer;
      field_value_info.login_password_exp_chg_interval^ := field_value_list_entry^.field_value.
            login_password_exp_chg_interval^;

      NEXT field_value_info.login_password_change_date IN
            validation_record_info^.work_area.sequence_pointer;
      IF field_value_list_entry^.field_value.login_password_change_date = NIL THEN
          field_value_info.login_password_change_date^.year :=
                LOWERVALUE (field_value_info.login_password_change_date^.year);
          field_value_info.login_password_change_date^.month :=
                LOWERVALUE (field_value_info.login_password_change_date^.month);
          field_value_info.login_password_change_date^.day :=
                LOWERVALUE (field_value_info.login_password_change_date^.day);
          field_value_info.login_password_change_date^.hour :=
                LOWERVALUE (field_value_info.login_password_change_date^.hour);
          field_value_info.login_password_change_date^.minute :=
                LOWERVALUE (field_value_info.login_password_change_date^.minute);
          field_value_info.login_password_change_date^.second :=
                LOWERVALUE (field_value_info.login_password_change_date^.second);
          field_value_info.login_password_change_date^.millisecond :=
                LOWERVALUE (field_value_info.login_password_change_date^.millisecond);
      ELSE
        field_value_info.login_password_change_date^ := field_value_list_entry^.field_value.
              login_password_change_date^;
      IFEND;

      NEXT field_value_info.login_password_max_exp_interval IN
            validation_record_info^.work_area.sequence_pointer;
      field_value_info.login_password_max_exp_interval^ := field_value_list_entry^.field_value.
            login_password_max_exp_interval^;

{ Change the maximum expiration interval if specified.
{ The caller must have user administration authority or above to change this value.

      IF login_password_max_exp_interval <> NIL THEN
        IF validation_record_info^.caller_authority < avc$user_admin_authority THEN
          osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
          EXIT /change/;
        IFEND;
        field_value_info.login_password_max_exp_interval^ := login_password_max_exp_interval^;
      IFEND;

{ Change the expiration date if specified.
{ Only user administrators or above may specify an expiration date
{ without specifying a new password.

      IF login_password_exp_date <> NIL THEN
        IF ((login_password = NIL) AND (validation_record_info^.caller_authority < avc$user_admin_authority))
              THEN
          osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
          EXIT /change/;
        IFEND;
        field_value_info.login_password_exp_date^ := login_password_exp_date^;
      IFEND;

{ Change the expiration interval value if specified.

      IF login_password_exp_interval <> NIL THEN
        field_value_info.login_password_exp_interval^ := login_password_exp_interval^;
      IFEND;

{ Change the expiration warning interval if specified.

      IF login_password_exp_warning <> NIL THEN
        field_value_info.login_password_exp_warning^ := login_password_exp_warning^;
      IFEND;

{ Change the expired password change interval if specified.

      IF login_password_exp_chg_interval <> NIL THEN
        field_value_info.login_password_exp_chg_interval^ := login_password_exp_chg_interval^;
      IFEND;

{ Initialize a temporary array for holding the new list of password attributes.

      FOR index := 1 TO avc$maximum_name_list_size DO
        login_password_attribute_list [index] := osc$null_name;
      FOREND;

{ Copy the current list of password attributes to the temporary array.

      FOR index := 1 TO UPPERBOUND (field_value_list_entry^.field_value.login_password_attributes^) DO
        login_password_attribute_list [index] := field_value_list_entry^.field_value.
              login_password_attributes^ [index];
      FOREND;
      number_of_password_attributes := UPPERBOUND (field_value_list_entry^.field_value.
            login_password_attributes^);

{ Delete any specified password attributes from the temporary array.

      IF delete_password_attributes <> NIL THEN
        IF validation_record_info^.caller_authority < avc$user_admin_authority THEN
          osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
          EXIT /change/;
        ELSE
          delete_names_from_name_list (delete_password_attributes, 'delete_password_attributes',
                login_password_attribute_list, number_of_password_attributes, status);
          IF NOT status.normal THEN
            EXIT /change/;
          IFEND;
        IFEND;
      IFEND;

{ Add any specified password attributes to the temporary array.

      IF add_password_attributes <> NIL THEN
        IF validation_record_info^.caller_authority < avc$user_admin_authority THEN
          osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
          EXIT /change/;
        ELSE
          add_names_to_name_list (add_password_attributes, 'add_password_attributes',
                login_password_attribute_list, number_of_password_attributes, status);
          IF NOT status.normal THEN
            EXIT /change/;
          IFEND;
        IFEND;
      IFEND;

      field_value_info.login_password_attributes := ^login_password_attribute_list;

{ Change the login password value if specified.

      IF login_password <> NIL THEN
        IF old_password = NIL THEN

{ Only user administrators or above may specify a new password without specifying the old.

          IF ((validation_record_info^.caller_authority < avc$user_admin_authority) AND
                (NOT login_password^.encrypted)) THEN
            osp$set_status_abnormal ('AV', ave$old_password_not_valid, 'user', status);
            EXIT /change/;
          IFEND;
          verified_old_password := osc$null_name;
        ELSE

{ Encrypt the old password value.

          verified_old_login_password.encrypted := TRUE;
          avp$encrypt_password (validation_record_info^.key.user_name, old_password^,
                verified_old_login_password.value, status);
          IF NOT status.normal THEN
            EXIT /change/;
          IFEND;

{ Verify that the correct old password value was specified.

          IF verified_old_login_password.value <> old_login_password.value THEN
            avp$old_encrypt_password (validation_record_info^.key.user_name, old_password^,
                verified_old_login_password.value, status);
            IF NOT status.normal THEN
              EXIT /change/;
            IFEND;
            IF verified_old_login_password.value <> old_login_password.value THEN
              osp$set_status_abnormal ('AV', ave$old_password_not_valid, 'user', status);
              EXIT /change/;
            IFEND;
          IFEND;
          verified_old_login_password.value := osc$null_name;
          verified_old_password := old_password^;
        IFEND;

{ Calculate a new expiration date if one wasn't specified.

        IF login_password_exp_date = NIL THEN
          IF field_value_info.login_password_exp_interval^.day <> avc$unlimited_exp_interval THEN
            pmp$compute_date_time (current_date_time, field_value_info.login_password_exp_interval^,
                  field_value_info.login_password_exp_date^, status);
            IF NOT status.normal THEN
              IF ((status.condition = pme$compute_overflow) OR (status.condition =
                    pme$computed_year_out_of_range)) THEN
                field_value_info.login_password_exp_date^.year := avc$no_expiration_date;
                status.normal := TRUE;
              ELSE
                EXIT /change/;
              IFEND;
            IFEND;
          ELSE
            field_value_info.login_password_exp_date^.year := avc$no_expiration_date;
          IFEND;
        IFEND;

{ Encrypted passwords are allowed only if this is a new validation file.
{ This is to facilitate recreation from source.

        IF login_password^.encrypted THEN
          PUSH utility_information: [[REP 1 OF avt$file_utility_information]];
          RESET utility_information;
          avp$get_file_utility_info (utility_information, file_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          RESET utility_information;
          NEXT file_utility_information IN utility_information;
          IF file_utility_information = NIL THEN
            corrupted_sequence ('AVP$CHANGE_LOGIN_PASSWORD_VALUE', 'NEW_FILE', 'FILE_UTILITY_INFORMATION',
                  status);
            EXIT /change/;
          IFEND;
          IF NOT file_utility_information^.new_file THEN
            osp$set_status_abnormal ('AV', ave$encrypted_pw_not_allowed, '', status);
            EXIT /change/;
          IFEND;
          field_value_info.login_password^ := login_password^;
        ELSE

{ Encrypt the new password.

          field_value_info.login_password^.encrypted := TRUE;
          avp$encrypt_password (validation_record_info^.key.user_name, login_password^.value,
                field_value_info.login_password^.value, status);
          IF NOT status.normal THEN
            EXIT /change/;
          IFEND;
          new_password := login_password^.value;

{ Call the password attribute site hook.

          avp$process_password_attributes (validation_record_info^.caller_authority,
                validation_record_info^.key.user_name,
                field_value_info.login_password_change_date^, old_login_password,
                field_value_info.login_password^, verified_old_password, new_password,
                field_value_info.login_password_attributes^, number_of_password_attributes, status);
          IF NOT status.normal THEN
            EXIT /change/;
          IFEND;

{ The site hook must not return a blank new password.

          IF new_password = osc$null_name THEN
            osp$set_status_abnormal ('AV', ave$invalid_password_from_hook, '', status);
            EXIT /change/;
          IFEND;
          field_value_info.login_password^.encrypted := TRUE;

{ Encrypt the new password returned by the site hook.

          avp$encrypt_password (validation_record_info^.key.user_name, new_password,
                field_value_info.login_password^.value, status);
          IF NOT status.normal THEN
            EXIT /change/;
          IFEND;
          new_password := osc$null_name;
        IFEND;

        field_value_info.login_password_change_date^ := current_date_time;

      IFEND;

{ Move the temporary array to the password attributes field.

      NEXT field_value_info.login_password_attributes: [1 .. number_of_password_attributes] IN
            validation_record_info^.work_area.sequence_pointer;
      FOR index := 1 TO number_of_password_attributes DO
        field_value_info.login_password_attributes^ [index] := login_password_attribute_list [index];
      FOREND;

{ Verify values are valid for this type.

      avp$verify_type_conformance (field_name, field_value_info, type_specification, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_list_entry^.field_value := field_value_info;
    END /change/;

{ Update passwords in queued and deferred jobs, if caller requested it.

  /update_jobs/
    BEGIN
      IF status.normal AND update_batch_job_passwords THEN

{ Get the family name.

        clp$evaluate_file_reference (file_information.file_name, $clt$file_ref_parsing_options [],
              FALSE, evaluated_file_reference, status);
        IF NOT status.normal THEN
          EXIT /update_jobs/;
        IFEND;

{ Find the user's jobs.

        PUSH job_status_options_p: [1 .. 4];
        job_status_options_p^ [1].key := jmc$login_family;
        job_status_options_p^ [1].login_family := fsp$path_element (^evaluated_file_reference, 1)^;
        job_status_options_p^ [2].key := jmc$login_user;
        job_status_options_p^ [2].login_user := validation_record_info^.key.user_name;
        job_status_options_p^ [3].key := jmc$job_state_set;
        job_status_options_p^ [3].job_state_set := $jmt$job_state_set [jmc$deferred_job, jmc$queued_job,
              jmc$completed_job];
        job_status_options_p^ [4].key := jmc$continue_request_to_servers;
        job_status_options_p^ [4].continue_request_to_servers := TRUE;

        PUSH job_status_results_keys_p: [1 .. 1];
        job_status_results_keys_p^ [1] := jmc$system_job_name;

{ Guess how many jobs might be found.  If the number is too few, it will be incremented below.

        jmp$get_result_size ( { number_of_items } 5, #SEQ (job_status_results_keys_p^), result_size);
        PUSH work_area_p: [[REP result_size OF cell]];
        RESET work_area_p;
        jmp$get_job_status (job_status_options_p, job_status_results_keys_p, work_area_p,
              job_status_results_p, number_of_jobs_found, status);

        WHILE (NOT status.normal) AND (status.condition = jme$work_area_too_small) DO
          status.normal := TRUE;
          jmp$get_result_size (number_of_jobs_found + 1, #SEQ (job_status_results_keys_p^), result_size);
          PUSH work_area_p: [[REP result_size OF cell]];
          RESET work_area_p;
          jmp$get_job_status (job_status_options_p, job_status_results_keys_p, work_area_p,
                job_status_results_p, number_of_jobs_found, status);
        WHILEND;

        IF NOT status.normal THEN
          IF status.condition = jme$no_jobs_were_found THEN
            status.normal := TRUE;
          IFEND;
          EXIT /update_jobs/;
        IFEND;


{ Change the login password for the jobs that were found.

        PUSH input_attribute_changes_p: [1 .. 1];
        input_attribute_changes_p^ [1].key := jmc$encrypted_password;
        input_attribute_changes_p^ [1].encrypted_password := field_value_info.login_password^.value;
        job_name.kind := jmc$system_supplied_name;

        FOR job_index := 1 TO number_of_jobs_found DO
          job_name.system_supplied_name := job_status_results_p^ [job_index]^ [1].system_job_name;
          jmp$change_input_attributes (job_name, input_attribute_changes_p, status);
          IF NOT status.normal THEN
            IF (status.condition = jme$input_is_initiated) OR (status.condition = jme$name_not_found) THEN
              status.normal := TRUE;
            ELSE
              EXIT /update_jobs/;
            IFEND;
          IFEND;
        FOREND;
      IFEND;
    END /update_jobs/;

{ Emit the audit statistic for unsuccessful changes (successful changes are audited when the subutility ends).

    IF (avp$security_option_active (avc$vso_security_audit)) AND (NOT status.normal) THEN
      emit_chg_value_audit_statistic (validation_record_info^.description_record_name,
            file_information.file_name, validation_record_info^.key, field_name, status);
    IFEND;

  PROCEND avp$change_login_password_value;
?? TITLE := '    avp$change_name_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change the value of a name type
{ validation field within a validation record that has been previously
{ stored by a separate validation interface.
{
{ DESIGN:
{
{   This interface first calls a local procedure which, verifies that the
{ caller has the required authority to change the field requested, gets
{ pointers to the requested validation record information in memory, and
{ retrieves the current value for the field being changed.
{
{   The current values for the field being changed are replaced by any values
{ specified on the input parameters, and the resulting field value is
{ verified for type conformance.
{

  PROCEDURE [XDCL, #GATE] avp$change_name_value
    (    field_name: ost$name;
         add_names: ^avt$name_list;
         delete_names: ^avt$name_list;
         record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      field_value_info: avt$field_value,
      field_value_list_entry: ^avt$field_value_list_entry,
      index: 1 .. avc$maximum_name_list_size,
      name_list: array [1 .. avc$maximum_name_list_size] of ost$name,
      number_of_names: 1 .. avc$maximum_name_list_size,
      validation_record_info: ^avt$validation_record_info,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Set up for changing a field value.

  /change/
    BEGIN
      initialize_change_value_info (field_name, record_id, {work_area=} NIL, type_specification,
            field_value_list_entry, validation_record_info, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_info := field_value_list_entry^.field_value;

{ Initialize a temporary array for holding the new list of names.

      FOR index := 1 TO avc$maximum_name_list_size DO
        name_list [index] := osc$null_name;
      FOREND;

{ Copy the current list of names to the temporary array.

      FOR index := 1 TO UPPERBOUND (field_value_list_entry^.field_value.names^) DO
        name_list [index] := field_value_list_entry^.field_value.names^ [index];
      FOREND;
      number_of_names := UPPERBOUND (field_value_list_entry^.field_value.names^);

{ Delete any specified names from the temporary array.

      IF delete_names <> NIL THEN
        delete_names_from_name_list (delete_names, 'delete_names', name_list, number_of_names, status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
      IFEND;

{ Add any specified names to the temporary array.

      IF add_names <> NIL THEN
        add_names_to_name_list (add_names, 'add_names', name_list, number_of_names, status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
      IFEND;

{ Move the temporary array to the name field.

      NEXT field_value_info.names: [1 .. number_of_names] IN
            validation_record_info^.work_area.sequence_pointer;
      FOR index := 1 TO number_of_names DO
        field_value_info.names^ [index] := name_list [index];
      FOREND;

{ Verify values are valid for this type.

      avp$verify_type_conformance (field_name, field_value_info, type_specification, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_list_entry^.field_value := field_value_info;
    END /change/;

{ Emit the audit statistic for unsuccessful changes (successful changes are audited when the subutility ends).

    IF (avp$security_option_active (avc$vso_security_audit)) AND (NOT status.normal) THEN
      emit_chg_value_audit_statistic (validation_record_info^.description_record_name,
            file_information.file_name, validation_record_info^.key, field_name, status);
    IFEND;

  PROCEND avp$change_name_value;
?? TITLE := '    avp$change_real_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change the value of a real type
{ validation field within a validation record that has been previously
{ stored by a separate validation interface.
{
{ DESIGN:
{
{   This interface first calls a local procedure which, verifies that the
{ caller has the required authority to change the field requested, gets
{ pointers to the requested validation record information in memory, and
{ retrieves the current value for the field being changed.
{
{   The current values for the field being changed are replaced by any values
{ specified on the input parameters, and the resulting field value is
{ verified for type conformance.
{

  PROCEDURE [XDCL, #GATE] avp$change_real_value
    (    field_name: ost$name;
         real_value: ^real;
         record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      field_value_info: avt$field_value,
      field_value_list_entry: ^avt$field_value_list_entry,
      validation_record_info: ^avt$validation_record_info,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Set up for changing a field value.

  /change/
    BEGIN
      initialize_change_value_info (field_name, record_id, {work_area=} NIL, type_specification,
            field_value_list_entry, validation_record_info, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_info := field_value_list_entry^.field_value;

{ Change the real value if specified.

      IF real_value <> NIL THEN
        NEXT field_value_info.real_value IN validation_record_info^.work_area.sequence_pointer;
        field_value_info.real_value^ := real_value^;
      IFEND;

{ Verify values are valid for this type.

      avp$verify_type_conformance (field_name, field_value_info, type_specification, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_list_entry^.field_value := field_value_info;
    END /change/;

{ Emit the audit statistic for unsuccessful changes (successful changes are audited when the subutility ends).

    IF (avp$security_option_active (avc$vso_security_audit)) AND (NOT status.normal) THEN
      emit_chg_value_audit_statistic (validation_record_info^.description_record_name,
            file_information.file_name, validation_record_info^.key, field_name, status);
    IFEND;

  PROCEND avp$change_real_value;
?? TITLE := '    avp$change_ring_privilege_value', EJECT ??
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change the value of a ring privilege type
{ validation field within a validation record that has been previously
{ stored by a separate validation interface.
{
{ DESIGN:
{
{   This interface first calls a local procedure which, verifies that the
{ caller has the required authority to change the field requested, gets
{ pointers to the requested validation record information in memory, and
{ retrieves the current value for the field being changed.
{
{   The current values for the field being changed are replaced by any values
{ specified on the input parameters, and the resulting field value is
{ verified for type conformance.
{

  PROCEDURE [XDCL, #GATE] avp$change_ring_privilege_value
    (    field_name: ost$name;
         minimum_ring: ^ost$ring;
         nominal_ring: ^ost$ring;
         record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      field_value_info: avt$field_value,
      field_value_list_entry: ^avt$field_value_list_entry,
      validation_record_info: ^avt$validation_record_info,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Set up for changing a field value.

  /change/
    BEGIN
      initialize_change_value_info (field_name, record_id, {work_area=} NIL, type_specification,
            field_value_list_entry, validation_record_info, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_info := field_value_list_entry^.field_value;

{ Change minimum ring value if specified.

      IF minimum_ring <> NIL THEN
        NEXT field_value_info.minimum_ring IN validation_record_info^.work_area.sequence_pointer;
        field_value_info.minimum_ring^ := minimum_ring^;
      IFEND;

{ Change nominal ring value if specified.

      IF nominal_ring <> NIL THEN
        NEXT field_value_info.nominal_ring IN validation_record_info^.work_area.sequence_pointer;
        field_value_info.nominal_ring^ := nominal_ring^;
      IFEND;

{ Verify values are valid for this type.

      avp$verify_type_conformance (field_name, field_value_info, type_specification, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_list_entry^.field_value := field_value_info;
    END /change/;

{ Emit the audit statistic for unsuccessful changes (successful changes are audited when the subutility ends).

    IF (avp$security_option_active (avc$vso_security_audit)) AND (NOT status.normal) THEN
      emit_chg_value_audit_statistic (validation_record_info^.description_record_name,
            file_information.file_name, validation_record_info^.key, field_name, status);
    IFEND;

  PROCEND avp$change_ring_privilege_value;
?? TITLE := '    avp$change_string_value', EJECT ??
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to change the value of a string type
{ validation field within a validation record that has been previously
{ stored by a separate validation interface.
{
{ DESIGN:
{
{   This interface first calls a local procedure which, verifies that the
{ caller has the required authority to change the field requested, gets
{ pointers to the requested validation record information in memory, and
{ retrieves the current value for the field being changed.
{
{   The current values for the field being changed are replaced by any values
{ specified on the input parameters, and the resulting field value is
{ verified for type conformance.
{

  PROCEDURE [XDCL, #GATE] avp$change_string_value
    (    field_name: ost$name;
         string_value: ^ost$string;
         record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      field_value_info: avt$field_value,
      field_value_list_entry: ^avt$field_value_list_entry,
      validation_record_info: ^avt$validation_record_info,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Set up for changing a field value.

  /change/
    BEGIN
      initialize_change_value_info (field_name, record_id, {work_area=} NIL, type_specification,
            field_value_list_entry, validation_record_info, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_info := field_value_list_entry^.field_value;

{ Change the string value if specified.

      IF string_value <> NIL THEN
        NEXT field_value_info.string_value: [string_value^.size] IN
              validation_record_info^.work_area.sequence_pointer;
        field_value_info.string_value^ := string_value^.value;
      IFEND;

{ Verify values are valid for this type.

      avp$verify_type_conformance (field_name, field_value_info, type_specification, status);
      IF NOT status.normal THEN
        EXIT /change/;
      IFEND;

      field_value_list_entry^.field_value := field_value_info;
    END /change/;

{ Emit the audit statistic for unsuccessful changes (successful changes are audited when the subutility ends).

    IF (avp$security_option_active (avc$vso_security_audit)) AND (NOT status.normal) THEN
      emit_chg_value_audit_statistic (validation_record_info^.description_record_name,
            file_information.file_name, validation_record_info^.key, field_name, status);
    IFEND;

  PROCEND avp$change_string_value;
?? OLDTITLE ??
?? TITLE := '  Interfaces to read field display values' ??
?? NEWTITLE := '    avp$get_acct_proj_display_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get an account project type field's current values
{ from the validation record information currently stored for a subutility session.
{
{ DESIGN:
{
{   This interface calls a local procedure which:
{     - Verifies that the caller has authority to display the value.
{     - Finds the current field value in the validation record information chain.
{   Then the field values are returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$get_acct_proj_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR account_name: avt$account_name;
     VAR project_name: avt$project_name;
     VAR status: ost$status);

    VAR
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Validate the caller and get the field value to display.

    init_get_display_value_info (field_name, record_id, {work_area=} NIL, field_value, type_specification,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$account_project_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'account project', status);
      RETURN;
    IFEND;

{ Return the current field values.

    account_name := field_value.account_name^;
    project_name := field_value.project_name^;

  PROCEND avp$get_acct_proj_display_value;
?? TITLE := '    avp$get_accum_limit_display_val', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a accum limit type field's current values
{ from the validation record information currently stored for a subutility session.
{
{ DESIGN:
{
{   This interface calls a local procedure which:
{     - Verifies that the caller has authority to display the value.
{     - Finds the current field value in the validation record information chain.
{   Then the field values are returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$get_accum_limit_display_val
    (    field_name: ost$name;
         record_id: ost$name;
     VAR job_limit_information: avt$job_limit_information;
     VAR total_limit_information: avt$total_limit_information;
     VAR display_format: avt$numeric_display_format;
     VAR status: ost$status);

    VAR
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Validate the caller and get the field value to display.

    init_get_display_value_info (field_name, record_id, {work_area=} NIL, field_value, type_specification,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$accumulating_limit_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'accumulating limit', status);
      RETURN;
    IFEND;

{ Return the job limit information if job limits apply.

    job_limit_information.job_limits_apply := type_specification.job_limits_apply^;
    IF job_limit_information.job_limits_apply THEN
      job_limit_information.job_warning_limit := field_value.job_warning_limit^;
      job_limit_information.job_maximum_limit := field_value.job_maximum_limit^;
    IFEND;

{ Return total limit information if total limits apply.

    total_limit_information.total_limit_applies := type_specification.total_limit_applies^;
    IF total_limit_information.total_limit_applies THEN
      total_limit_information.total_limit := field_value.total_limit^;
      total_limit_information.total_accumulation := field_value.total_accumulation^;
    IFEND;

{ The following code is temporary.  It will be replaced when limit display
{ formats are taken from the type specifiation (in a future release).

    display_format.field_size := 10;
    display_format.kind := avc$integer_format;
    display_format.radix := 10;
    display_format.display_radix := FALSE;

  PROCEND avp$get_accum_limit_display_val;
?? TITLE := '    avp$get_capabil_display_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a capability type field's current values
{ from the validation record information currently stored for a subutility session.
{
{ DESIGN:
{
{   This interface calls a local procedure which:
{     - Verifies that the caller has authority to display the value.
{     - Finds the current field value in the validation record information chain.
{   Then the field values are returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$get_capabil_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR capability: boolean;
     VAR status: ost$status);

    VAR
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Validate the caller and get the field value to display.

    init_get_display_value_info (field_name, record_id, {work_area=} NIL, field_value, type_specification,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$capability_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'capability', status);
      RETURN;
    IFEND;

{ Return the current field values.

    capability := field_value.capability^;

  PROCEND avp$get_capabil_display_value;
?? TITLE := '    avp$get_date_time_display_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a date time type field's current values
{ from the validation record information currently stored for a subutility session.
{
{ DESIGN:
{
{   This interface calls a local procedure which:
{     - Verifies that the caller has authority to display the value.
{     - Finds the current field value in the validation record information chain.
{   Then the field values are returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$get_date_time_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR date_time: avt$date_time;
     VAR date_display_format: clt$date_time_form_string;
     VAR time_display_format: clt$date_time_form_string;
     VAR status: ost$status);

    VAR
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Validate the caller and get the field value to display.

    init_get_display_value_info (field_name, record_id, {work_area=} NIL, field_value, type_specification,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$date_time_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'date time', status);
      RETURN;
    IFEND;

{ Return the current field values.

    date_time := field_value.date_time^;

{ Return the date display format if dates apply.

    IF type_specification.date_applies^ THEN
      date_display_format := type_specification.date_display_format^;
    ELSE
      date_display_format := ' ';
    IFEND;

{ Return the time display format if times apply.

    IF type_specification.time_applies^ THEN
      time_display_format := type_specification.time_display_format^;
    ELSE
      time_display_format := ' ';
    IFEND;

  PROCEND avp$get_date_time_display_value;
?? TITLE := '    avp$get_file_display_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a file type field's current values
{ from the validation record information currently stored for a subutility session.
{
{ DESIGN:
{
{   This interface calls a local procedure which:
{     - Verifies that the caller has authority to display the value.
{     - Finds the current field value in the validation record information chain.
{   Then the field values are returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$get_file_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR file: string (fsc$max_path_size);
     VAR status: ost$status);

    VAR
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Validate the caller and get the field value to display.

    init_get_display_value_info (field_name, record_id, {work_area=} NIL, field_value, type_specification,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$file_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'file', status);
      RETURN;
    IFEND;

{ Return the current field value.

    file := field_value.file^;

  PROCEND avp$get_file_display_value;
?? TITLE := '    avp$get_integer_display_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get an integer type field's current values
{ from the validation record information currently stored for a subutility session.
{
{ DESIGN:
{
{   This interface calls a local procedure which:
{     - Verifies that the caller has authority to display the value.
{     - Finds the current field value in the validation record information chain.
{   Then the field values are returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$get_integer_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR integer_value: integer;
     VAR display_format: avt$numeric_display_format;
     VAR status: ost$status);

    VAR
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Validate the caller and get the field value to display.

    init_get_display_value_info (field_name, record_id, {work_area=} NIL, field_value, type_specification,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$integer_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'integer', status);
      RETURN;
    IFEND;

{ Return the current field value.

    integer_value := field_value.integer_value^;

{ Return the display format.

    display_format := type_specification.integer_display_format^;

  PROCEND avp$get_integer_display_value;
?? TITLE := '    avp$get_job_class_display_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a job class type field's current values
{ from the validation record information currently stored for a subutility session.
{
{ DESIGN:
{
{   This interface calls a local procedure which:
{     - Verifies that the caller has authority to display the value.
{     - Finds the current field value in the validation record information chain.
{   Then the field values are returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$get_job_class_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR job_classes: avt$name_list;
     VAR number_of_job_classes: avt$name_list_size;
     VAR batch_job_class_default: ost$name;
     VAR interactive_job_class_default: ost$name;
     VAR status: ost$status);

    VAR
      field_value: avt$field_value,
      index: avt$name_list_size,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Validate the caller and get the field value to display.

    init_get_display_value_info (field_name, record_id, {work_area=} NIL, field_value, type_specification,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$job_class_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'job class', status);
      RETURN;
    IFEND;

{ Return as many of the job class validation values as will fit.

    FOR index := 1 TO UPPERBOUND (job_classes) DO
      IF index <= UPPERBOUND (field_value.job_classes^) THEN
        job_classes [index] := field_value.job_classes^ [index];
      ELSE
        job_classes [index] := osc$null_name;
      IFEND;
    FOREND;

{ Return the actual number of job classes.

    number_of_job_classes := UPPERBOUND (field_value.job_classes^);

{ Return the batch and interactive job class defaults.

    batch_job_class_default := field_value.batch_job_class_default^;
    interactive_job_class_default := field_value.interactive_job_class_default^;

  PROCEND avp$get_job_class_display_value;
?? TITLE := '    avp$get_labeled_names_dis_value', EJECT ??
{ PURPOSE:
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a labeled names type field's current values
{ from the validation record information currently stored for a subutility session.
{
{ DESIGN:
{   This interface calls a local procedure which:
{     - Verifies that the caller has authority to display the value.
{     - Finds the current field value in the validation record information chain.
{   Then the field values are returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$get_labeled_names_dis_value
    (    field_name: ost$name;
         record_id: ost$name;
         work_area: ^seq (*);
     VAR labeled_names:  ^avt$labeled_names_list;
     VAR status: ost$status);

    VAR
      field_value: avt$field_value,
      field_work_area: ^seq (*),
      index: avt$name_list_size,
      type_specification: avt$type_specification,
      work_area_ptr: ^seq (*);

    status.normal := TRUE;

{ Validate the caller and get the field value to display.

    PUSH field_work_area: [[REP 2 * avc$maximum_name_list_size OF avt$labeled_names]];
    RESET field_work_area;
    init_get_display_value_info (field_name, record_id, field_work_area, field_value, type_specification,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$labeled_names_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'labeled name', status);
      RETURN;
    IFEND;

{ Return the labeled names field value.

    IF field_value.labeled_names <> NIL THEN
      work_area_ptr := work_area;
      NEXT labeled_names: [1 .. UPPERBOUND (field_value.labeled_names^)] IN work_area_ptr;
      FOR index := 1 TO UPPERBOUND (field_value.labeled_names^) DO
        NEXT labeled_names^ [index].label IN work_area_ptr;
        labeled_names^ [index].label^ := field_value.labeled_names^ [index].label^;

        NEXT labeled_names^ [index].names: [1 .. UPPERBOUND (field_value.labeled_names^ [index].names^)] IN
              work_area_ptr;
        labeled_names^ [index].names^ := field_value.labeled_names^ [index].names^;
      FOREND;
    ELSE
      labeled_names := NIL;
    IFEND;

  PROCEND avp$get_labeled_names_dis_value;
?? TITLE := '    avp$get_limit_display_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a limit type field's current values
{ from the validation record information currently stored for a subutility session.
{
{ DESIGN:
{
{   This interface calls a local procedure which:
{     - Verifies that the caller has authority to display the value.
{     - Finds the current field value in the validation record information chain.
{   Then the field values are returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$get_limit_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR limit_value: avt$limit_value;
     VAR display_format: avt$numeric_display_format;
     VAR status: ost$status);

    VAR
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Validate the caller and get the field value to display.

    init_get_display_value_info (field_name, record_id, {work_area=} NIL, field_value, type_specification,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$limit_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'limit', status);
      RETURN;
    IFEND;

{ Return the value of the validation field.

    limit_value := field_value.limit_value^;

{ The following code is temporary.  It will be replaced when limit display
{ formats are taken from the type specifiation (in a future release).

    display_format.field_size := 10;
    display_format.kind := avc$integer_format;
    display_format.radix := 10;
    display_format.display_radix := FALSE;

  PROCEND avp$get_limit_display_value;
?? TITLE := '    avp$get_login_pw_display_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a login password type field's current values
{ from the validation record information currently stored for a subutility session.
{
{ DESIGN:
{
{   This interface calls a local procedure which:
{     - Verifies that the caller has authority to display the value.
{     - Finds the current field value in the validation record information chain.
{   Then the field values are returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$get_login_pw_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR expiration_date: ost$date_time;
     VAR expiration_interval: pmt$time_increment;
     VAR maximum_expiration_interval: pmt$time_increment;
     VAR expiration_warning_interval: pmt$time_increment;
     VAR expired_password_chg_interval: pmt$time_increment;
     VAR change_date: ost$date_time;
     VAR attributes: avt$name_list;
     VAR number_of_attributes: avt$name_list_size;
     VAR status: ost$status);

    VAR
      field_value: avt$field_value,
      index: avt$name_list_size,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Validate the caller and get the field value to display.

    init_get_display_value_info (field_name, record_id, {work_area=} NIL, field_value, type_specification,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$login_password_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'login password', status);
      RETURN;
    IFEND;

{ Return the values for the validation field.  The encrypted password value is
{ not returned for security reasons.

    expiration_date := field_value.login_password_exp_date^;
    expiration_interval := field_value.login_password_exp_interval^;
    maximum_expiration_interval := field_value.login_password_max_exp_interval^;
    expiration_warning_interval := field_value.login_password_exp_warning^;
    expired_password_chg_interval := field_value.login_password_exp_chg_interval^;
    IF field_value.login_password_change_date = NIL THEN
      change_date.year := LOWERVALUE (change_date.year);
      change_date.month := LOWERVALUE (change_date.month);
      change_date.day := LOWERVALUE (change_date.day);
      change_date.hour := LOWERVALUE (change_date.hour);
      change_date.minute := LOWERVALUE (change_date.minute);
      change_date.second := LOWERVALUE (change_date.second);
      change_date.millisecond := LOWERVALUE (change_date.millisecond);
    ELSE
      change_date := field_value.login_password_change_date^;
    IFEND;

{ Return as many password attributes as will fit.

    FOR index := 1 TO UPPERBOUND (attributes) DO
      IF index <= UPPERBOUND (field_value.login_password_attributes^) THEN
        attributes [index] := field_value.login_password_attributes^ [index];
      ELSE
        attributes [index] := osc$null_name;
      IFEND;
    FOREND;

{ Return the actual number of password attributes.

    number_of_attributes := UPPERBOUND (field_value.login_password_attributes^);

  PROCEND avp$get_login_pw_display_value;
?? TITLE := '    avp$get_name_display_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a name type field's current values
{ from the validation record information currently stored for a subutility session.
{
{ DESIGN:
{
{   This interface calls a local procedure which:
{     - Verifies that the caller has authority to display the value.
{     - Finds the current field value in the validation record information chain.
{   Then the field values are returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$get_name_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR names: avt$name_list;
     VAR number_of_names: avt$name_list_size;
     VAR status: ost$status);

    VAR
      field_value: avt$field_value,
      index: avt$name_list_size,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Validate the caller and get the field value to display.

    init_get_display_value_info (field_name, record_id, {work_area=} NIL, field_value, type_specification,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$name_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'name', status);
      RETURN;
    IFEND;

{ Return as many names as will fit.

    FOR index := 1 TO UPPERBOUND (names) DO
      IF index <= UPPERBOUND (field_value.names^) THEN
        names [index] := field_value.names^ [index];
      ELSE
        names [index] := osc$null_name;
      IFEND;
    FOREND;

{ Return the actual number of names.

    number_of_names := UPPERBOUND (field_value.names^);

  PROCEND avp$get_name_display_value;
?? TITLE := '    avp$get_real_display_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a real type field's current values
{ from the validation record information currently stored for a subutility session.
{
{ DESIGN:
{
{   This interface calls a local procedure which:
{     - Verifies that the caller has authority to display the value.
{     - Finds the current field value in the validation record information chain.
{   Then the field values are returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$get_real_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR real_value: real;
     VAR display_format: avt$numeric_display_format;
     VAR status: ost$status);

    VAR
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Validate the caller and get the field value to display.

    init_get_display_value_info (field_name, record_id, {work_area=} NIL, field_value, type_specification,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$real_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'real', status);
      RETURN;
    IFEND;

{ Return the current field values.

    real_value := field_value.real_value^;

{ Return the display format.

    display_format := type_specification.real_display_format^;

  PROCEND avp$get_real_display_value;
?? TITLE := '    avp$get_ring_priv_display_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a ring privilege type field's current values
{ from the validation record information currently stored for a subutility session.
{
{ DESIGN:
{
{   This interface calls a local procedure which:
{     - Verifies that the caller has authority to display the value.
{     - Finds the current field value in the validation record information chain.
{   Then the field values are returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$get_ring_priv_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR minimum_ring: ost$ring;
     VAR nominal_ring: ost$ring;
     VAR status: ost$status);

    VAR
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Validate the caller and get the field value to display.

    init_get_display_value_info (field_name, record_id, {work_area=} NIL, field_value, type_specification,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$ring_privilege_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'ring privilege', status);
      RETURN;
    IFEND;

{ Return the current field values.

    minimum_ring := field_value.minimum_ring^;
    nominal_ring := field_value.nominal_ring^;

  PROCEND avp$get_ring_priv_display_value;
?? TITLE := '    avp$get_string_display_value', EJECT ??
{
{ PURPOSE:
{
{   This interface is an internal interface for use by the AV project only.
{
{   This interface is used to get a string type field's current values
{ from the validation record information currently stored for a subutility session.
{
{ DESIGN:
{
{   This interface calls a local procedure which:
{     - Verifies that the caller has authority to display the value.
{     - Finds the current field value in the validation record information chain.
{   Then the field values are returned to the caller.
{

  PROCEDURE [XDCL, #GATE] avp$get_string_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR string_value: ost$string;
     VAR status: ost$status);

    VAR
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ Validate the caller and get the field value to display.

    init_get_display_value_info (field_name, record_id, {work_area=} NIL, field_value, type_specification,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$string_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'string', status);
      RETURN;
    IFEND;

{ Return the current field values.

    IF field_value.string_value = NIL THEN
      string_value.value := ' ';
      string_value.size := 0;
    ELSE
      string_value.value := field_value.string_value^;
      string_value.size := #SIZE (field_value.string_value^);
    IFEND;

  PROCEND avp$get_string_display_value;
?? OLDTITLE ??
?? TITLE := '  Interfaces to read field values for the currently executing job' ??
?? NEWTITLE := '    avp$get_field_type', EJECT ??

{ PURPOSE:
{
{   This interface is used to return the field kind of a specified validation
{ field name.
{
{ DESIGN:
{
{   The field kind is retrieved from the type specification within the description
{ record.
{

  PROCEDURE [XDCL, #GATE] avp$get_field_type
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR field_kind: avt$field_kind;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      data_record: ^avt$template_file_record,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      descriptive_text: ^avt$descriptive_text,
      field_work_area: ^seq (*),
      type_specification: avt$type_specification,
      utility_information: ^avt$utility_information;

    status.normal := TRUE;
    #CALLER_ID (caller_id);

{ Get pointers to the specified job validation records.

    get_job_validation_record (caller_id, record_level, caller_authority, data_record, description_record,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Retrieve the field description for the specified field from the description record.

    PUSH field_work_area: [[REP 2 * avc$maximum_name_list_size OF avt$labeled_names]];
    RESET field_work_area;
    avp$get_field_description (field_name, description_record, field_work_area, type_specification,
          default_value, descriptive_text, utility_information, status);
    IF status.normal OR (status.condition = ave$field_was_deleted) THEN
      field_kind := type_specification.kind;
    IFEND;

  PROCEND avp$get_field_type;
?? OLDTITLE ??
?? NEWTITLE := '    avp$get_account_project_value', EJECT ??

*copyc avh$get_account_project_value

  PROCEDURE [XDCL, #GATE] avp$get_account_project_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR account: avt$account_name;
     VAR project: avt$project_name;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Get the field value and the type specification for the specified field.  Also
{ verify that the caller has suficient authority to read the value.

    get_job_validation_field (caller_id, field_name, record_level, {work_area=} NIL, field_value,
          type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$account_project_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'account project', status);
      RETURN;
    IFEND;

{ Return the value of the validation field.

    account := field_value.account_name^;
    project := field_value.project_name^;

  PROCEND avp$get_account_project_value;
?? TITLE := '    avp$get_accum_limit_value', EJECT ??
*copyc avh$get_accum_limit_value

  PROCEDURE [XDCL, #GATE] avp$get_accum_limit_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR job_limit_information: avt$job_limit_information;
     VAR total_limit_information: avt$total_limit_information;
     VAR display_format: avt$numeric_display_format;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Get the field value and the type specification for the specified field.  Also
{ verify that the caller has suficient authority to read the value.

    get_job_validation_field (caller_id, field_name, record_level, {work_area=} NIL, field_value,
          type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$accumulating_limit_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'accumulating limit', status);
      RETURN;
    IFEND;

{ Return the job limit information if job limits apply.

    job_limit_information.job_limits_apply := type_specification.job_limits_apply^;
    IF job_limit_information.job_limits_apply THEN
      job_limit_information.job_warning_limit := field_value.job_warning_limit^;
      job_limit_information.job_maximum_limit := field_value.job_maximum_limit^;
    IFEND;

{ Return total limit information if total limits apply.

    total_limit_information.total_limit_applies := type_specification.total_limit_applies^;
    IF total_limit_information.total_limit_applies THEN
      total_limit_information.total_limit := field_value.total_limit^;
      total_limit_information.total_accumulation := field_value.total_accumulation^;
    IFEND;

{ The following code is temporary.  It will be replaced when limit display
{ formats are taken from the type specifiation (in a future release).

    display_format.field_size := 10;
    display_format.kind := avc$integer_format;
    display_format.radix := 10;
    display_format.display_radix := FALSE;

  PROCEND avp$get_accum_limit_value;
?? TITLE := '    avp$get_capability', EJECT ??
*copyc avh$get_capability

  PROCEDURE [XDCL, #GATE] avp$get_capability
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR capability: boolean;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

    capability := FALSE;

{ Get the field value and the type specification for the specified field.  Also
{ verify that the caller has suficient authority to read the value.

    get_job_validation_field (caller_id, field_name, record_level, {work_area=} NIL, field_value,
          type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$capability_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'capability', status);
      RETURN;
    IFEND;

{ Return the value of the validation field.

    capability := field_value.capability^;

  PROCEND avp$get_capability;
?? TITLE := '    avp$get_date_time_value', EJECT ??
*copyc avh$get_date_time_value

  PROCEDURE [XDCL, #GATE] avp$get_date_time_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR date_time: avt$date_time;
     VAR date_display_format: clt$date_time_form_string;
     VAR time_display_format: clt$date_time_form_string;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Get the field value and the type specification for the specified field.  Also verify that the caller has
{ sufficient authority to read the value.

    get_job_validation_field (caller_id, field_name, record_level, {work_area=} NIL, field_value,
          type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$date_time_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'date time', status);
      RETURN;
    IFEND;

{ Return the value of the validation field.

    date_time := field_value.date_time^;

{ Return the date display format if dates apply.

    IF type_specification.date_applies^ THEN
      date_display_format := type_specification.date_display_format^;
    ELSE
      date_display_format := ' ';
    IFEND;

{ Return the time display format if times apply.

    IF type_specification.time_applies^ THEN
      time_display_format := type_specification.time_display_format^;
    ELSE
      time_display_format := ' ';
    IFEND;

  PROCEND avp$get_date_time_value;
?? TITLE := '    avp$get_field_name_list', EJECT ??
*copy avh$get_field_name_list

  PROCEDURE [XDCL, #GATE] avp$get_field_name_list
    (    record_level: avt$validation_record;
         desired_field_kinds: avt$field_kind_set;
     VAR field_names: avt$name_list;
     VAR field_count: avt$field_count;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      caller_id: ost$caller_identifier,
      data_record: ^avt$template_file_record,
      description_record: ^avt$template_file_record;

    status.normal := TRUE;
    #CALLER_ID (caller_id);

{ Get pointers to the specified validation information.

    get_job_validation_record (caller_id, record_level, caller_authority, data_record, description_record,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Extract the desired field names from the validation record.

    avp$get_field_names (desired_field_kinds, {deleted_fields =} FALSE, description_record, field_names,
          field_count, status);

  PROCEND avp$get_field_name_list;
?? TITLE := '    avp$get_file_value', EJECT ??
*copyc avh$get_file_value

  PROCEDURE [XDCL, #GATE] avp$get_file_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR file: string (fsc$max_path_size);
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Get the field value and the type specification for the specified field.  Also
{ verify that the caller has suficient authority to read the value.

    get_job_validation_field (caller_id, field_name, record_level, {work_area=} NIL, field_value,
          type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$file_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'file', status);
      RETURN;
    IFEND;

{ Return value of the validation field.

    file := field_value.file^;

  PROCEND avp$get_file_value;
?? TITLE := '    avp$get_integer_value', EJECT ??
*copyc avh$get_integer_value

  PROCEDURE [XDCL, #GATE] avp$get_integer_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR integer_value: integer;
     VAR integer_display_format: avt$numeric_display_format;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Get the field value and the type specification for the specified field.  Also
{ verify that the caller has suficient authority to read the value.

    get_job_validation_field (caller_id, field_name, record_level, {work_area=} NIL, field_value,
          type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$integer_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'integer', status);
      RETURN;
    IFEND;

{ Return the value of the validation field.

    integer_value := field_value.integer_value^;

{ Return the display format.

    integer_display_format := type_specification.integer_display_format^;

  PROCEND avp$get_integer_value;
?? TITLE := '    avp$get_job_class_value', EJECT ??
*copyc avh$get_job_class_value

  PROCEDURE [XDCL, #GATE] avp$get_job_class_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR job_classes: avt$name_list;
     VAR number_of_job_classes: avt$name_list_size;
     VAR batch_job_class_default: ost$name;
     VAR interactive_job_class_default: ost$name;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      field_value: avt$field_value,
      index: avt$name_list_size,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Get the field value and the type specification for the specified field.  Also
{ verify that the caller has suficient authority to read the value.

    get_job_validation_field (caller_id, field_name, record_level, {work_area=} NIL, field_value,
          type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$job_class_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'job class', status);
      RETURN;
    IFEND;

{ Return as many of the job class validation values as will fit.

    FOR index := 1 TO UPPERBOUND (job_classes) DO
      IF index <= UPPERBOUND (field_value.job_classes^) THEN
        job_classes [index] := field_value.job_classes^ [index];
      ELSE
        job_classes [index] := osc$null_name;
      IFEND;
    FOREND;

{ Return the actual number of job classes.

    number_of_job_classes := UPPERBOUND (field_value.job_classes^);

{ Return the batch and interactive job class defaults.

    batch_job_class_default := field_value.batch_job_class_default^;
    interactive_job_class_default := field_value.interactive_job_class_default^;

  PROCEND avp$get_job_class_value;
?? TITLE := '    avp$get_labeled_names_value', EJECT ??
*copyc avh$get_labeled_names_value

  PROCEDURE [XDCL, #GATE] avp$get_labeled_names_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
         work_area: ^seq (*);
     VAR labeled_names:  ^avt$labeled_names_list;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      field_value: avt$field_value,
      field_work_area: ^seq (*),
      index: avt$name_list_size,
      type_specification: avt$type_specification,
      work_area_ptr: ^seq (*);

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Get the field value and the type specification for the specified field.  Also
{ verify that the caller has suficient authority to read the value.

    PUSH field_work_area: [[REP 2 * avc$maximum_name_list_size OF avt$labeled_names]];
    RESET field_work_area;
    get_job_validation_field (caller_id, field_name, record_level, field_work_area, field_value,
          type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$labeled_names_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'labeled name', status);
      RETURN;
    IFEND;

{ Return the labeled names field value.

    IF field_value.labeled_names <> NIL THEN
      work_area_ptr := work_area;
      NEXT labeled_names: [1 .. UPPERBOUND (field_value.labeled_names^)] IN work_area_ptr;
      FOR index := 1 TO UPPERBOUND (field_value.labeled_names^) DO
        NEXT labeled_names^ [index].label IN work_area_ptr;
        labeled_names^ [index].label^ := field_value.labeled_names^ [index].label^;

        NEXT labeled_names^ [index].names: [1 .. UPPERBOUND (field_value.labeled_names^ [index].names^)] IN
              work_area_ptr;
        labeled_names^ [index].names^ := field_value.labeled_names^ [index].names^;
      FOREND;
    ELSE
      labeled_names := NIL;
    IFEND;

  PROCEND avp$get_labeled_names_value;
?? TITLE := '    avp$get_limit_value', EJECT ??
*copyc avh$get_limit_value

  PROCEDURE [XDCL, #GATE] avp$get_limit_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR limit_value: avt$limit_value;
     VAR display_format: avt$numeric_display_format;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Get the field value and the type specification for the specified field.  Also
{ verify that the caller has suficient authority to read the value.

    get_job_validation_field (caller_id, field_name, record_level, {work_area=} NIL, field_value,
          type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$limit_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'limit', status);
      RETURN;
    IFEND;

{ Return the value of the validation field.

    limit_value := field_value.limit_value^;

{ The following code is temporary.  It will be replaced when limit display
{ formats are taken from the type specifiation (in a future release).

    display_format.field_size := 10;
    display_format.kind := avc$integer_format;
    display_format.radix := 10;
    display_format.display_radix := FALSE;

  PROCEND avp$get_limit_value;
?? TITLE := '    avp$get_login_password_value', EJECT ??
*copyc avh$get_login_password_value

  PROCEDURE [XDCL, #GATE] avp$get_login_password_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR expiration_date: ost$date_time;
     VAR expiration_interval: pmt$time_increment;
     VAR maximum_expiration_interval: pmt$time_increment;
     VAR expiration_warning_interval: pmt$time_increment;
     VAR expired_password_chg_interval: pmt$time_increment;
     VAR change_date: ost$date_time;
     VAR attributes: avt$name_list;
     VAR number_of_attributes: avt$name_list_size;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      field_value: avt$field_value,
      index: avt$name_list_size,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Get the field value and the type specification for the specified field.  Also
{ verify that the caller has suficient authority to read the value.

    get_job_validation_field (caller_id, field_name, record_level, {work_area=} NIL, field_value,
          type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$login_password_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'login password', status);
      RETURN;
    IFEND;

{ Return the values for the validation field.  The encrypted password value is
{ not returned for security reasons.

    expiration_date := field_value.login_password_exp_date^;
    expiration_interval := field_value.login_password_exp_interval^;
    maximum_expiration_interval := field_value.login_password_max_exp_interval^;
    expiration_warning_interval := field_value.login_password_exp_warning^;
    expired_password_chg_interval := field_value.login_password_exp_chg_interval^;
    IF field_value.login_password_change_date = NIL THEN
      change_date.year := LOWERVALUE (change_date.year);
      change_date.month := LOWERVALUE (change_date.month);
      change_date.day := LOWERVALUE (change_date.day);
      change_date.hour := LOWERVALUE (change_date.hour);
      change_date.minute := LOWERVALUE (change_date.minute);
      change_date.second := LOWERVALUE (change_date.second);
      change_date.millisecond := LOWERVALUE (change_date.millisecond);
    ELSE
      change_date := field_value.login_password_change_date^;
    IFEND;

{ Return as many password attributes as will fit.

    FOR index := 1 TO UPPERBOUND (attributes) DO
      IF index <= UPPERBOUND (field_value.login_password_attributes^) THEN
        attributes [index] := field_value.login_password_attributes^ [index];
      ELSE
        attributes [index] := osc$null_name;
      IFEND;
    FOREND;

{ Return the actual number of password attributes.

    number_of_attributes := UPPERBOUND (field_value.login_password_attributes^);

  PROCEND avp$get_login_password_value;
?? TITLE := '    avp$get_name_value', EJECT ??
*copyc avh$get_name_value

  PROCEDURE [XDCL, #GATE] avp$get_name_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR names: avt$name_list;
     VAR number_of_names: avt$name_list_size;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      field_value: avt$field_value,
      index: avt$name_list_size,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Get the field value and the type specification for the specified field.  Also
{ verify that the caller has suficient authority to read the value.

    get_job_validation_field (caller_id, field_name, record_level, {work_area=} NIL, field_value,
          type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$name_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'name', status);
      RETURN;
    IFEND;

{ Return as many names as will fit.

    FOR index := 1 TO UPPERBOUND (names) DO
      IF index <= UPPERBOUND (field_value.names^) THEN
        names [index] := field_value.names^ [index];
      ELSE
        names [index] := osc$null_name;
      IFEND;
    FOREND;

{ Return the actual number of names.

    number_of_names := UPPERBOUND (field_value.names^);

  PROCEND avp$get_name_value;
?? TITLE := '    avp$get_real_value', EJECT ??
*copyc avh$get_real_value

  PROCEDURE [XDCL, #GATE] avp$get_real_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR real_value: real;
     VAR display_format: avt$numeric_display_format;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Get the field value and the type specification for the specified field.  Also
{ verify that the caller has suficient authority to read the value.

    get_job_validation_field (caller_id, field_name, record_level, {work_area=} NIL, field_value,
          type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$real_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'real', status);
      RETURN;
    IFEND;

{ Return the current field values.

    real_value := field_value.real_value^;

{ Return the display format.

    display_format := type_specification.real_display_format^;

  PROCEND avp$get_real_value;
?? TITLE := '    avp$get_string_value', EJECT ??
*copyc avh$get_string_value

  PROCEDURE [XDCL, #GATE] avp$get_string_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR string_value: ost$string;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      field_value: avt$field_value,
      type_specification: avt$type_specification;

    status.normal := TRUE;

    #CALLER_ID (caller_id);

{ Get the field value and the type specification for the specified field.  Also
{ verify that the caller has suficient authority to read the value.

    get_job_validation_field (caller_id, field_name, record_level, {work_area=} NIL, field_value,
          type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the field is the correct type.

    IF type_specification.kind <> avc$string_kind THEN
      osp$set_status_abnormal ('AV', ave$incorrect_kind, field_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'string', status);
      RETURN;
    IFEND;

{ Return the value of the validation field.

    IF field_value.string_value <> NIL THEN
      string_value.value := field_value.string_value^;
      string_value.size := #SIZE (field_value.string_value^);
    ELSE
      string_value.value := ' ';
      string_value.size := 0;
    IFEND;

  PROCEND avp$get_string_value;
?? OLDTITLE ??
?? TITLE := '  Helper procedures' ??
?? NEWTITLE := '    delete_record_utility_info_cmd', EJECT ??
{
{ PURPOSE:
{
{   This procedure deletes the entries for a specified field and command name
{ pair from the command table information stored in the record utility
{ information for a validation record.
{

  PROCEDURE delete_record_utility_info_cmd
    (    field_name: ost$name;
         procedure_name: ost$name;
     VAR record_utility_information: ^avt$utility_information;
     VAR status: ost$status);

    VAR
      command_index: integer,
      index: integer,
      new_index: integer,
      number_of_entries: integer,
      ordinal_to_delete: integer,
      record_utility_info_array: ^array [1 .. * ] of avt$record_utility_info_entry,
      record_utility_info_entry: ^avt$record_utility_info_entry,
      record_utility_info_header: ^avt$record_utility_info_header;

    status.normal := TRUE;

{ Extract the header from the record utility information.

    RESET record_utility_information;
    NEXT record_utility_info_header IN record_utility_information;
    IF record_utility_info_header = NIL THEN
      corrupted_sequence ('ADD_NEW_RECORD_UTILITY_INFO_CMD', 'RECORD_UTILITY_INFO_HEADER',
            'RECORD_UTILITY_INFORMATION', status);
      RETURN;
    IFEND;

{ Extract the command table information from the record utility information.

    NEXT record_utility_info_array: [1 .. record_utility_info_header^.number_of_entries] IN
          record_utility_information;
    IF record_utility_info_array = NIL THEN
      corrupted_sequence ('ADD_NEW_RECORD_UTILITY_INFO_CMD', 'RECORD_UTILITY_INFORMATION',
            'RECORD_UTILITY_INFORMATION', status);
      RETURN;
    IFEND;

{ Search the command table to find the ordinal number for an entry
{ that matches the specified field name and procedure name.

    ordinal_to_delete := 0;

  /find_ordinal_number/
    FOR index := 1 TO record_utility_info_header^.number_of_entries DO
      IF ((field_name = record_utility_info_array^ [index].field_name) AND
            (procedure_name = record_utility_info_array^ [index].command_table_entry.procedure_name)) THEN
        ordinal_to_delete := record_utility_info_array^ [index].command_table_entry.ordinal;
        EXIT /find_ordinal_number/;
      IFEND;
    FOREND /find_ordinal_number/;

{ If a match is found delete all entries with the matching ordinal
{ and reduce the ordinal of all higher ordinal entries by one so
{ that the ordinals remain sequential.

    IF ordinal_to_delete <> 0 THEN
      record_utility_info_header^.number_of_commands := record_utility_info_header^.number_of_commands - 1;
      number_of_entries := record_utility_info_header^.number_of_entries;
      new_index := 1;
      FOR index := 1 TO number_of_entries DO
        IF record_utility_info_array^ [index].command_table_entry.ordinal = ordinal_to_delete THEN
          record_utility_info_header^.number_of_entries := record_utility_info_header^.number_of_entries - 1;
        ELSE
          IF record_utility_info_array^ [index].command_table_entry.ordinal > ordinal_to_delete THEN
            record_utility_info_array^ [index].command_table_entry.ordinal :=
                  record_utility_info_array^ [index].command_table_entry.ordinal - 1;
          IFEND;
          record_utility_info_array^ [new_index] := record_utility_info_array^ [index];
          new_index := new_index + 1;
        IFEND;
      FOREND;
    IFEND;

  PROCEND delete_record_utility_info_cmd;
?? TITLE := '    add_new_record_utility_info_cmd', EJECT ??
{
{ PURPOSE:
{
{   This procedure adds a command and its aliases to the command table
{ information stored in the record utility information for a validation record.
{

  PROCEDURE add_new_record_utility_info_cmd
    (    add_commands: avt$name_list;
         field_name: ost$name;
         procedure_name: ost$name;
     VAR record_utility_information: ^avt$utility_information;
     VAR status: ost$status);

    VAR
      command_index: integer,
      index: integer,
      record_utility_info_array: ^array [1 .. * ] of avt$record_utility_info_entry,
      record_utility_info_entry: ^avt$record_utility_info_entry,
      record_utility_info_header: ^avt$record_utility_info_header;

    status.normal := TRUE;

{ Extract the header from the record utility information.

    RESET record_utility_information;
    NEXT record_utility_info_header IN record_utility_information;
    IF record_utility_info_header = NIL THEN
      corrupted_sequence ('ADD_NEW_RECORD_UTILITY_INFO_CMD', 'RECORD_UTILITY_INFO_HEADER',
            'RECORD_UTILITY_INFORMATION', status);
      RETURN;
    IFEND;
    IF record_utility_info_header^.number_of_entries > 0 THEN

{ Extract the command table information from the record utility information.

      NEXT record_utility_info_array: [1 .. record_utility_info_header^.number_of_entries] IN
            record_utility_information;
      IF record_utility_info_array = NIL THEN
        corrupted_sequence ('ADD_NEW_RECORD_UTILITY_INFO_CMD', 'RECORD_UTILITY_INFORMATION',
              'RECORD_UTILITY_INFORMATION', status);
        RETURN;
      IFEND;
    IFEND;

{ Add the new entries to the end of the command table information.

    record_utility_info_header^.number_of_commands := record_utility_info_header^.number_of_commands + 1;
    FOR command_index := 1 TO UPPERBOUND (add_commands) DO
      NEXT record_utility_info_entry IN record_utility_information;
      IF record_utility_info_entry = NIL THEN
        corrupted_sequence ('ADD_NEW_RECORD_UTILITY_INFO_CMD', 'RECORD_UTILITY_INFORMATION',
              'RECORD_UTILITY_INFORMATION', status);
        RETURN;
      IFEND;
      record_utility_info_entry^.field_name := field_name;
      record_utility_info_entry^.command_table_entry.name := add_commands [command_index];
      IF command_index = 1 THEN
        record_utility_info_entry^.command_table_entry.class := clc$nominal_entry;
      ELSEIF command_index = UPPERBOUND (add_commands) THEN
        record_utility_info_entry^.command_table_entry.class := clc$abbreviation_entry;
      ELSE
        record_utility_info_entry^.command_table_entry.class := clc$alias_entry;
      IFEND;
      record_utility_info_entry^.command_table_entry.availability := clc$advertised_entry;
      record_utility_info_entry^.command_table_entry.ordinal :=
            record_utility_info_header^.number_of_commands;
      record_utility_info_entry^.command_table_entry.log_option := clc$manually_log;
      record_utility_info_entry^.command_table_entry.call_method := clc$unlinked_call;
      record_utility_info_entry^.command_table_entry.procedure_name := procedure_name;
      record_utility_info_header^.number_of_entries := record_utility_info_header^.number_of_entries + 1;
    FOREND;

  PROCEND add_new_record_utility_info_cmd;
?? TITLE := '    add_names_to_name_list', EJECT ??
{
{ PURPOSE:
{
{   This procedure adds a list of names to a fixed size array of names.
{

  PROCEDURE add_names_to_name_list
    (    names: ^array [1 .. * ] of ost$name;
         parameter_name: string ( * <= osc$max_name_size);
     VAR name_list: array [1 .. avc$maximum_name_list_size] of ost$name;
     VAR number_of_names: 1 .. avc$maximum_name_list_size;
     VAR status: ost$status);

    VAR
      index: 1 .. avc$maximum_name_list_size,
      name_list_index: 1 .. avc$maximum_name_list_size;

    IF UPPERBOUND (names^) > 1 THEN
      FOR index := 1 TO UPPERBOUND (names^) DO
        IF names^ [index] = 'ALL' THEN
          osp$set_status_abnormal ('AV', cle$all_must_be_used_alone, parameter_name, status);
          RETURN;
        ELSEIF names^ [index] = 'NONE' THEN
          osp$set_status_abnormal ('AV', cle$none_must_be_used_alone, parameter_name, status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;

  /add_name_to_name_list/
    FOR index := 1 TO UPPERBOUND (names^) DO

{ If the name to add is ALL make ALL the only entry in the name list.

      IF names^ [index] = 'ALL' THEN
        name_list [1] := 'ALL';
        number_of_names := 1;
        RETURN;
      ELSEIF names^ [index] = 'NONE' THEN

{ If the name to add is NONE then no action is necessary.

        RETURN;
      ELSEIF (number_of_names = 1) AND (name_list [1] = 'ALL') THEN

{ If the list already contains ALL then no action is necessary.

        RETURN;
      ELSEIF (number_of_names = 1) AND (name_list [1] = 'NONE') THEN

{ If the list contains NONE then put it as the only entry in the list.

        name_list [1] := names^ [index];
      ELSE

{ If the list already contains the name specified then no action is necessary.

        FOR name_list_index := 1 TO number_of_names DO
          IF name_list [name_list_index] = names^ [index] THEN
            CYCLE /add_name_to_name_list/;
          IFEND;
        FOREND;

{ Else add the new name to the next avialable spot in the list.

        number_of_names := number_of_names + 1;
        name_list [number_of_names] := names^ [index];
      IFEND;
    FOREND /add_name_to_name_list/;

  PROCEND add_names_to_name_list;
?? TITLE := '    change_labeled_names', EJECT ??
{
{ PURPOSE:
{
{   This procedure adds a list of labeled names to an existing list of labeled names.
{

  PROCEDURE change_labeled_names
    (    add_labeled_names: ^avt$labeled_names_list;
         delete_labeled_names: ^avt$labeled_names_list;
         field_value: avt$field_value;
     VAR work_area: ^seq (*);
     VAR labeled_names: ^avt$labeled_names_list;
     VAR status: ost$status);

    VAR
      add_entry_processed: ^array [1 .. *] of boolean,
      index1: 1 .. avc$maximum_name_list_size,
      index2: 1 .. avc$maximum_name_list_size,
      local_work_area: ^seq (*),
      name_list: ^avt$name_list,
      number_of_labeled_names: 0 .. avc$maximum_name_list_size,
      number_of_names: 1 .. avc$maximum_name_list_size;

    status.normal := TRUE;

{ Make an array to keep track of which adds have been processed.

    IF add_labeled_names <> NIL THEN
      PUSH add_entry_processed: [1 .. UPPERBOUND (add_labeled_names^)];
      FOR index1 := 1 TO UPPERBOUND (add_labeled_names^) DO
        add_entry_processed^ [index1] := FALSE;
      FOREND;
    IFEND;

{ Allocate a temporary array for holding a name list.

    PUSH name_list: [1 .. avc$maximum_name_list_size];

{ Initialize an array for holding the new list of labeled names.

    NEXT labeled_names: [1 .. avc$maximum_name_list_size] IN work_area;
    IF labeled_names = NIL THEN
      osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
      RETURN;
    IFEND;
    FOR index1 := 1 TO avc$maximum_name_list_size DO
      labeled_names^ [index1].label := NIL;
      labeled_names^ [index1].names := NIL;
    FOREND;

{ Process each labeled name in the field value list.

    number_of_labeled_names := 0;
    IF (field_value.labeled_names <> NIL) AND (field_value.labeled_names^ [1].label^ <> 'NONE') THEN

    /process_entry/
      FOR index1 := 1 TO UPPERBOUND (field_value.labeled_names^) DO

{ Copy the current list of names to the temporary array.

        FOR index2 := 1 TO avc$maximum_name_list_size DO
          IF index2 <= UPPERBOUND (field_value.labeled_names^ [index1].names^) THEN
            name_list^ [index2] := field_value.labeled_names^ [index1].names^ [index2];
          ELSE
            name_list^ [index2] := osc$null_name;
          IFEND;
        FOREND;
        number_of_names := UPPERBOUND (field_value.labeled_names^ [index1].names^);

{ Delete any specified names from the temporary array.

        IF (delete_labeled_names <> NIL) AND (delete_labeled_names^ [1].label^ <> 'NONE') THEN
          FOR index2 := 1 TO UPPERBOUND (delete_labeled_names^) DO

{ If the field value is currently ALL then make sure specifics are not being deleted.

            IF (field_value.labeled_names^ [1].label^ = 'ALL') AND
                 (delete_labeled_names^ [index2].label^ <> 'ALL') THEN
              osp$set_status_condition (ave$cannot_delete_name_from_all, status);
              RETURN;
            IFEND;
            IF (delete_labeled_names^ [index2].label^ = field_value.labeled_names^ [index1].label^) OR
                  (delete_labeled_names^ [index2].label^ = 'ALL') THEN
              IF delete_labeled_names^ [index2].names <> NIL THEN
                delete_names_from_name_list (delete_labeled_names^ [index2].names, 'delete_labeled_names',
                    name_list^, number_of_names, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              ELSE
                CYCLE /process_entry/; {Delete the label}
              IFEND;
            IFEND;
          FOREND;
        IFEND;

{ Add any specified names to the temporary array.

        IF add_labeled_names <> NIL THEN
          FOR index2 := 1 TO UPPERBOUND (add_labeled_names^) DO
            IF add_labeled_names^ [index2].label^ = field_value.labeled_names^ [index1].label^ THEN
              IF add_labeled_names^ [index2].names = NIL THEN
                number_of_names := 1;
                name_list^ [1] := 'ALL';
              ELSE
                add_names_to_name_list (add_labeled_names^ [index2].names, 'add_labeled_names', name_list^,
                      number_of_names, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              IFEND;
              add_entry_processed^ [index2] := TRUE;
            IFEND;
          FOREND;
        IFEND;

{ Move the names temporary array to the labeled names temporary array;

        number_of_labeled_names := number_of_labeled_names + 1;
        NEXT labeled_names^ [number_of_labeled_names].label IN work_area;
        IF labeled_names^ [number_of_labeled_names].label = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        labeled_names^ [number_of_labeled_names].label^ := field_value.labeled_names^ [index1].label^;
        NEXT labeled_names^ [number_of_labeled_names].names: [1 .. number_of_names] IN work_area;
        IF labeled_names^ [number_of_labeled_names].names = NIL THEN
          osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
          RETURN;
        IFEND;
        FOR index2 := 1 TO number_of_names DO
          labeled_names^ [number_of_labeled_names].names^ [index2] := name_list^ [index2];
        FOREND;
      FOREND /process_entry/;
    IFEND;

{ Put the adds that did not have a match in the field value list into the temporary labeled names list.

    IF add_labeled_names <> NIL THEN

      FOR index1 := 1 TO UPPERBOUND (add_labeled_names^) DO
        IF (NOT add_entry_processed^ [index1]) AND
              (add_labeled_names^ [index1].label^ <> 'NONE') THEN

{ If the result value is currently ALL then make sure specifics are not being added to ALL.

          IF (number_of_labeled_names = 1) AND (labeled_names^ [1].label^ = 'ALL') AND
                ((UPPERBOUND (add_labeled_names^) > 1) OR (add_labeled_names^ [1].label^ <> 'ALL')) THEN
            osp$set_status_condition (ave$cannot_add_name_to_all, status);
            RETURN;
          IFEND;

{ If the result value is not currently ALL then make sure 'ALL' is not being added to a specific.

          IF (number_of_labeled_names >= 1) AND (labeled_names^ [1].label^ <> 'ALL') AND
                (add_labeled_names^ [1].label^ = 'ALL') THEN
            osp$set_status_condition (ave$cannot_add_all_to_name, status);
            RETURN;
          IFEND;

{ Null out the temporary name array, then use add names to name list to insure no duplicate names
{ were specified.

          FOR index2 := 1 TO avc$maximum_name_list_size DO
            name_list^ [index2] := osc$null_name;
          FOREND;
          name_list^ [1] := 'NONE';
          number_of_names := 1;
          FOR index2 := index1 TO UPPERBOUND (add_labeled_names^) DO
            IF add_labeled_names^ [index2].label^ = add_labeled_names^ [index1].label^ THEN
              IF add_labeled_names^ [index2].names = NIL THEN
                number_of_names := 1;
                name_list^ [1] := 'ALL';
              ELSE
                add_names_to_name_list (add_labeled_names^ [index2].names, 'add_labeled_names',
                      name_list^, number_of_names, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              IFEND;
              add_entry_processed^ [index2] := TRUE;
            IFEND;
          FOREND;

{ Move the result to the output parameter.

          number_of_labeled_names := number_of_labeled_names + 1;
          NEXT labeled_names^ [number_of_labeled_names].label IN work_area;
          IF labeled_names^ [number_of_labeled_names].label = NIL THEN
            osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
            RETURN;
          IFEND;
          labeled_names^ [number_of_labeled_names].label^ := add_labeled_names^ [index1].label^;
          NEXT labeled_names^ [number_of_labeled_names].names: [1 .. number_of_names] IN work_area;
          IF labeled_names^ [number_of_labeled_names].names = NIL THEN
            osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
            RETURN;
          IFEND;
          FOR index2 := 1 TO number_of_names DO
            labeled_names^ [number_of_labeled_names].names^ [index2] := name_list^ [index2];
          FOREND;
        IFEND;
      FOREND;
    IFEND;

    IF number_of_labeled_names = 0 THEN
      number_of_labeled_names := 1;
      NEXT labeled_names^ [1].label IN work_area;
      IF labeled_names^ [1].label = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      labeled_names^ [1].label^ := 'NONE';
      NEXT labeled_names^ [1].names: [1 .. 1] IN work_area;
      IF labeled_names^ [1].names = NIL THEN
        osp$set_status_abnormal ('AV', ave$record_too_large, '', status);
        RETURN;
      IFEND;
      labeled_names^ [1].names^ [1] := 'NONE';
    IFEND;

    local_work_area := work_area;
    RESET local_work_area TO labeled_names;
    NEXT labeled_names: [1 .. number_of_labeled_names] IN local_work_area;

  PROCEND change_labeled_names;

?? TITLE := '    avp$change_util_info_cmd_name', EJECT ??
{
{ PURPOSE:
{
{   This procedure changes the name of a command in the command table
{ information stored in the record utility information for a validation record.
{

  PROCEDURE [XDCL] avp$change_util_info_cmd_name
    (    command_name: ost$name;
         new_command_name: ost$name;
         validation_record_name: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      index: integer,
      record_utility_information: ^avt$utility_information,
      record_utility_info_array: ^array [1 .. * ] of avt$record_utility_info_entry,
      record_utility_info_entry: ^avt$record_utility_info_entry,
      record_utility_info_header: ^avt$record_utility_info_header,
      utility_information: ^avt$utility_information,
      utility_information_size: integer;

    status.normal := TRUE;

{ Get the record utility information command table information.

    avp$get_desc_utility_info_size (validation_record_name, utility_information_size, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    PUSH record_utility_information: [[REP utility_information_size OF cell]];
    RESET record_utility_information;
    utility_information_size := #SIZE (record_utility_information^);
    avp$get_desc_utility_info (validation_record_name, record_utility_information, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Extract the header from the record utility information.

    RESET record_utility_information;
    NEXT record_utility_info_header IN record_utility_information;
    IF record_utility_info_header = NIL THEN
      corrupted_sequence ('CHANGE_UTILITY_INFO_FIELD_NAME', 'RECORD_UTILITY_INFO_HEADER',
            'RECORD_UTILITY_INFORMATION', status);
      RETURN;
    IFEND;
    IF record_utility_info_header^.number_of_entries > 0 THEN

{ Extract the command table information from the record utility information.

      NEXT record_utility_info_array: [1 .. record_utility_info_header^.number_of_entries] IN
            record_utility_information;
      IF record_utility_info_array = NIL THEN
        corrupted_sequence ('CHANGE_UTILITY_INFO_FIELD_NAME', 'RECORD_UTILITY_INFORMATION',
              'RECORD_UTILITY_INFORMATION', status);
        RETURN;
      IFEND;
    IFEND;

{ Change all entries with a matching command name.

    FOR index := 1 TO record_utility_info_header^.number_of_entries DO
      IF record_utility_info_array^ [index].command_table_entry.name = command_name THEN
        record_utility_info_array^ [index].command_table_entry.name := new_command_name;
      IFEND;
    FOREND;

{ Verify that a duplicate entry is not being added.

    sort_record_utility_information (record_utility_information, utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Rewrite the record utility information command table information.

    avp$change_desc_utility_info (validation_record_name, utility_information, file_information,
          status);

  PROCEND avp$change_util_info_cmd_name;

?? TITLE := '    change_utility_info_field_name', EJECT ??
{
{ PURPOSE:
{
{   This procedure changes the name of a field in the command table
{ information stored in the record utility information for a validation record.
{

  PROCEDURE change_utility_info_field_name
    (    field_name: ost$name;
         new_field_name: ost$name;
     VAR record_utility_information: ^avt$utility_information;
     VAR status: ost$status);

    VAR
      index: integer,
      record_utility_info_array: ^array [1 .. * ] of avt$record_utility_info_entry,
      record_utility_info_entry: ^avt$record_utility_info_entry,
      record_utility_info_header: ^avt$record_utility_info_header;

    status.normal := TRUE;

{ Extract the header from the record utility information.

    RESET record_utility_information;
    NEXT record_utility_info_header IN record_utility_information;
    IF record_utility_info_header = NIL THEN
      corrupted_sequence ('CHANGE_UTILITY_INFO_FIELD_NAME', 'RECORD_UTILITY_INFO_HEADER',
            'RECORD_UTILITY_INFORMATION', status);
      RETURN;
    IFEND;
    IF record_utility_info_header^.number_of_entries > 0 THEN

{ Extract the command table information from the record utility information.

      NEXT record_utility_info_array: [1 .. record_utility_info_header^.number_of_entries] IN
            record_utility_information;
      IF record_utility_info_array = NIL THEN
        corrupted_sequence ('CHANGE_UTILITY_INFO_FIELD_NAME', 'RECORD_UTILITY_INFORMATION',
              'RECORD_UTILITY_INFORMATION', status);
        RETURN;
      IFEND;
    IFEND;

{ Change all entries with a matching field name.

    FOR index := 1 TO record_utility_info_header^.number_of_entries DO
      IF record_utility_info_array^ [index].field_name = field_name THEN
        record_utility_info_array^ [index].field_name := new_field_name;
      IFEND;
    FOREND;

  PROCEND change_utility_info_field_name;
?? TITLE := '    corrupted_sequence', EJECT ??
{
{ PURPOSE:
{
{   This procedure builds an abnormal status variable used to report a
{ problem when accessing a sequence within the validation file.
{

  PROCEDURE corrupted_sequence
    (    procedure_name: string ( * );
         variable_name: string ( * );
         sequence_name: string ( * );
     VAR status: ost$status);

    osp$set_status_abnormal ('AV', ave$corrupted_sequence, procedure_name, status);
    osp$append_status_parameter (osc$status_parameter_delimiter, variable_name, status);
    osp$append_status_parameter (osc$status_parameter_delimiter, sequence_name, status);

  PROCEND corrupted_sequence;
?? TITLE := '    delete_names_from_name_list', EJECT ??
{
{ PURPOSE:
{
{   This procedure deletes a name from a fixed size array of names.
{

  PROCEDURE delete_names_from_name_list
    (    names: ^array [1 .. * ] of ost$name;
         parameter_name: string ( * <= osc$max_name_size);
     VAR name_list: array [1 .. avc$maximum_name_list_size] of ost$name;
     VAR number_of_names: 1 .. avc$maximum_name_list_size;
     VAR status: ost$status);

    VAR
      new_number_of_names: 0 .. avc$maximum_name_list_size,
      index: 1 .. avc$maximum_name_list_size,
      name_list_index: 1 .. avc$maximum_name_list_size;

    status.normal := TRUE;

    IF UPPERBOUND (names^) > 1 THEN
      FOR index := 1 TO UPPERBOUND (names^) DO
        IF names^ [index] = 'ALL' THEN
          osp$set_status_abnormal ('AV', cle$all_must_be_used_alone, parameter_name, status);
          RETURN;
        ELSEIF names^ [index] = 'NONE' THEN
          osp$set_status_abnormal ('AV', cle$none_must_be_used_alone, parameter_name, status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    FOR index := 1 TO UPPERBOUND (names^) DO

{ If the name to delete is ALL make NONE the only entry in the name list.

      IF names^ [index] = 'ALL' THEN
        name_list [1] := 'NONE';
        number_of_names := 1;
        RETURN;
      ELSEIF names^ [index] = 'NONE' THEN

{ If the name to delete is NONE then no action is necessary.

        RETURN;
      ELSEIF (number_of_names = 1) AND (name_list [1] = 'ALL') AND (names^ [index] <> 'ALL') THEN

{ A specific name can not be deleted from a list containing ALL.

        osp$set_status_abnormal ('AV', ave$cannot_delete_name_from_all, '', status);
        RETURN;
      ELSE

{ Else delete the name from the list if it is found in the list.

        new_number_of_names := 0;
        FOR name_list_index := 1 TO number_of_names DO
          IF name_list [name_list_index] <> names^ [index] THEN
            new_number_of_names := new_number_of_names + 1;
            name_list [new_number_of_names] := name_list [name_list_index];
          IFEND;
        FOREND;

{ If the only entry in the list was deleted put NONE in the list.

        IF new_number_of_names = 0 THEN
          name_list [1] := 'NONE';
          new_number_of_names := 1;
        IFEND;

        number_of_names := new_number_of_names;
      IFEND;
    FOREND;

  PROCEND delete_names_from_name_list;
?? TITLE := '    determine_caller_authority', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used to determine the authority of a caller of an
{ interface.
{

  PROCEDURE determine_caller_authority
    (    caller_id: ost$caller_identifier;
         account_name: ^avt$account_name;
         project_name: ^avt$project_name;
         user_name: ^ost$user_name;
         creation_account_name: ^avt$account_name;
         creation_project_name: ^avt$project_name;
     VAR caller_authority: avt$validation_authority);

    VAR
      account_administrator: boolean,
      executing_account_name: avt$account_name,
      executing_project_name: avt$project_name,
      executing_user_name: ost$user_identification,
      ignore_status: ost$status,
      processing_phase: clt$processing_phase,
      project_administrator: boolean,
      restricted_mainframe: boolean,
      user_administration_capability: boolean;

{ Caller authority is initialize to the least privileged authority possible.

    caller_authority := avc$any_authority;

{ If The caller is running in ring 3 or below system authority is assigned.

    IF caller_id.ring < osc$sj_ring_1 THEN
      caller_authority := avc$system_authority;
      RETURN;
    IFEND;

    processing_phase := clc$command_phase;
    clp$get_processing_phase (processing_phase, ignore_status);

    { If the caller is a system administrator or running in the system prolog or epilog and not on a
    { Soviet Nuclear Safety or China Weather machine, system administration authority is assigned.

    osp$check_for_desired_mf_class (osc$mc_china_or_soviet_class, restricted_mainframe);

    IF avp$system_administrator () OR (((processing_phase = clc$system_prolog_phase) OR
          (processing_phase = clc$system_epilog_phase)) AND (NOT restricted_mainframe)) THEN
      caller_authority := avc$system_admin_authority;
      RETURN;
    IFEND;

{ If the caller is a family administrator, family administrator authority is assigned.

    IF avp$family_administrator () THEN
      caller_authority := avc$family_admin_authority;
      RETURN;
    IFEND;

{ If an account name is supplied and the caller is an account administrator
{ for the specified account and running under the specified account then
{ account administrator authority is assigned.

    IF account_name <> NIL THEN
      executing_account_name := osc$null_name;
      pmp$get_account_project (executing_account_name, executing_project_name, ignore_status);
      account_administrator := FALSE;
      avp$get_capability (avc$account_administration, avc$account_member, account_administrator,
            ignore_status);
      IF (account_name^ = executing_account_name) AND (account_administrator OR
            (processing_phase <= clc$account_prolog_phase) OR (processing_phase = clc$account_epilog_phase))
            THEN
        caller_authority := avc$account_admin_authority;
        RETURN;
      IFEND;
      IF project_name <> NIL THEN

{ If a project name is supplied and the caller is a project administrator
{ for the specified project and running under the specified project then
{ project administrator authority is assigned.

        project_administrator := FALSE;
        avp$get_capability (avc$project_administration, avc$project_member, project_administrator,
              ignore_status);
        IF (account_name^ = executing_account_name) AND (project_name^ = executing_project_name) AND
              (project_administrator OR (processing_phase <= clc$project_prolog_phase) OR
              (processing_phase = clc$project_epilog_phase)) THEN
          caller_authority := avc$project_admin_authority;
          RETURN;
        IFEND;
      IFEND;
    IFEND;

{ If a creation account name is supplied and the caller is executing under the specified
{ account and is a user administrator for that account then user administration authority
{ is assigned.

    IF creation_account_name <> NIL THEN
      executing_account_name := osc$null_name;
      executing_project_name := osc$null_name;
      pmp$get_account_project (executing_account_name, executing_project_name, ignore_status);
      user_administration_capability := FALSE;
      avp$get_capability (avc$user_administration, avc$account_member, user_administration_capability,
            ignore_status);
      IF ((creation_account_name^ = executing_account_name) AND user_administration_capability) THEN
        caller_authority := avc$user_admin_authority;
        RETURN;
      IFEND;

{ If a creation project name is supplied and the caller is executing under the specified
{ project and is a user administrator for that project then user administration authority
{ is assigned.

      IF creation_project_name <> NIL THEN
        user_administration_capability := FALSE;
        avp$get_capability (avc$user_administration, avc$project_member, user_administration_capability,
              ignore_status);
        IF ((creation_account_name^ = executing_account_name) AND
              (creation_project_name^ = executing_project_name) AND user_administration_capability) THEN
          caller_authority := avc$user_admin_authority;
          RETURN;
        IFEND;
      IFEND;
    IFEND;

{ If a user name is supplied and the caller is running under the specified
{ user then user authority is assigned.

    IF user_name <> NIL THEN
      executing_user_name.user := osc$null_name;
      pmp$get_user_identification (executing_user_name, ignore_status);
      IF executing_user_name.user = user_name^ THEN
        caller_authority := avc$user_authority;
        RETURN;
      IFEND;
    IFEND;

  PROCEND determine_caller_authority;
?? TITLE := '    emit_chg_field_audit_statistic', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used to emit the change field audit statistic.
{

  PROCEDURE emit_chg_field_audit_statistic
    (    description_record_name: ost$name;
         validation_file_reference: fst$file_reference;
         field_name: ost$name;
         changed_default_value: boolean;
         change_authority_p: ^avt$validation_authority;
         display_authority_p: ^avt$validation_authority;
         manage_authority_p: ^avt$validation_authority;
         status: ost$status);

    VAR
      audit_information: sft$audit_information;

    audit_information.audited_operation := sfc$ao_val_change_field;
    audit_information.change_validation_field.description_record_name_p := ^description_record_name;
    audit_information.change_validation_field.validation_file_p := ^validation_file_reference;
    audit_information.change_validation_field.field_name_p := ^field_name;
    IF changed_default_value THEN
      audit_information.change_validation_field.attribute := sfc$avfa_default_value;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;
    IF change_authority_p <> NIL THEN
      audit_information.change_validation_field.attribute := sfc$avfa_change_authority;
      audit_information.change_validation_field.new_authority := change_authority_p^;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;
    IF display_authority_p <> NIL THEN
      audit_information.change_validation_field.attribute := sfc$avfa_display_authority;
      audit_information.change_validation_field.new_authority := display_authority_p^;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;
    IF manage_authority_p <> NIL THEN
      audit_information.change_validation_field.attribute := sfc$avfa_manage_authority;
      audit_information.change_validation_field.new_authority := manage_authority_p^;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;

  PROCEND emit_chg_field_audit_statistic;
?? TITLE := '    emit_chg_value_audit_statistic', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used to emit the change value audit statistic.
{

  PROCEDURE emit_chg_value_audit_statistic
    (    description_record_name: ost$name;
         validation_file_reference: fst$file_reference;
         key: avt$validation_key;
         field_name: ost$name;
         status: ost$status);

    VAR
      audit_information: sft$audit_information;

    audit_information.audited_operation := sfc$ao_val_change_record;
    audit_information.change_val_record.description_record_name_p := ^description_record_name;
    audit_information.change_val_record.validation_file_p := ^validation_file_reference;
    audit_information.change_val_record.user_name_p := ^key.user_name;
    IF key.account_name = avc$high_value_name THEN
      audit_information.change_val_record.account_name_p := NIL;
    ELSE
      audit_information.change_val_record.account_name_p := ^key.account_name;
    IFEND;
    IF key.project_name = avc$high_value_name THEN
      audit_information.change_val_record.project_name_p := NIL;
    ELSE
      audit_information.change_val_record.project_name_p := ^key.project_name;
    IFEND;
    audit_information.change_val_record.field_name_p := ^field_name;
    sfp$emit_audit_statistic (audit_information, status);

  PROCEND emit_chg_value_audit_statistic;
?? TITLE := '    find_validation_record_info', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used to find the validation record information
{ stored for a subutility session.
{

  PROCEDURE find_validation_record_info
    (    record_id: ost$name;
     VAR validation_record_info: ^avt$validation_record_info;
     VAR status: ost$status);

    status.normal := TRUE;

{ Start at the begining of the validation record information chain.

    validation_record_info := avv$validation_record_info;

{ Search for a matching record id.

  /find_record_info/
    WHILE validation_record_info <> NIL DO
      IF validation_record_info^.record_id = record_id THEN
        EXIT /find_record_info/;
      IFEND;
      validation_record_info := validation_record_info^.forward;
    WHILEND /find_record_info/;

    IF validation_record_info = NIL THEN
      osp$set_status_abnormal ('AV', ave$missing_val_record_info, record_id, status);
    IFEND;

  PROCEND find_validation_record_info;
?? TITLE := '    get_field_description', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used to get validation field description record
{ information from the validation record information chain if available, or directly
{ from the validation file.
{

  PROCEDURE get_field_description
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
         work_area: ^seq (*);
         description_record: ^avt$template_file_record;
     VAR default_value: avt$field_value;
     VAR type_specification: avt$type_specification;
     VAR description: ost$string;
     VAR field_utility_information: avt$field_utility_information;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      field_utility_info_ptr: ^avt$field_utility_information,
      description_record_ptr: ^avt$template_file_record,
      descriptive_text: ^avt$descriptive_text,
      validation_record_info: ^avt$validation_record_info,
      utility_information: ^avt$utility_information,
      work_area_ptr: ^seq (*);

    status.normal := TRUE;

    IF record_id <> osc$null_name THEN

{ Get the description record from the previously stored validation record info.

      find_validation_record_info (record_id, validation_record_info, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      description_record_ptr := validation_record_info^.description_record;
    ELSE

{ Get the description record from the validation file.

      description_record_ptr := description_record;
      avp$get_description_record (record_name, description_record_ptr, file_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Get the field description from the description record.

    work_area_ptr := work_area;
    avp$get_field_description (field_name, description_record_ptr, work_area_ptr, type_specification,
          default_value, descriptive_text, utility_information, status);
    IF status.normal OR (status.condition = ave$field_was_deleted) THEN

{ Access the field utility information.

      RESET utility_information;
      NEXT field_utility_info_ptr IN utility_information;
      IF field_utility_info_ptr = NIL THEN
        corrupted_sequence ('GET_FIELD_DESCRIPTION', 'FIELD_UTILITY_INFORMATION', 'UTILITY_INFORMATION',
              status);
        RETURN;
      IFEND;
      field_utility_information := field_utility_info_ptr^;

{ Access the field description.

      IF descriptive_text = NIL THEN
        description.value := ' ';
        description.size := 0;
      ELSE
        description.value := descriptive_text^;
        description.size := #SIZE (descriptive_text^);
      IFEND;
    IFEND;

  PROCEND get_field_description;
?? TITLE := '    get_job_validation_field', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used by the get the value of a validation field for the currently
{ executing job.
{

  PROCEDURE get_job_validation_field
    (    caller_id: ost$caller_identifier;
         field_name: ost$name;
         record_level: avt$validation_record;
         work_area: ^seq (*);
     VAR field_value: avt$field_value;
     VAR type_specification: avt$type_specification;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      data_record: ^avt$template_file_record,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      descriptive_text: ^avt$descriptive_text,
      executing_account_name: avt$account_name,
      executing_project_name: avt$project_name,
      field_utility_info_ptr: ^avt$field_utility_information,
      utility_information: ^avt$utility_information,
      work_area_ptr: ^seq (*);

    status.normal := TRUE;

{ Get pointers to the specified validation information.

    get_job_validation_record (caller_id, record_level, caller_authority, data_record, description_record,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Retrieve the field information for the specified field.

    work_area_ptr := work_area;
    avp$get_field (field_name, data_record, description_record, work_area_ptr, field_value,
          type_specification, default_value, descriptive_text, utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Extract the display authority from the field utility information.

    NEXT field_utility_info_ptr IN utility_information;
    IF field_utility_info_ptr = NIL THEN
      corrupted_sequence ('INITIALIZE_GET_VALUE_INFO', 'DISPLAY_AUTHORITY', 'FIELD_UTILITY_INFORMATION',
            status);
      RETURN;
    IFEND;

{ Verify that the caller has the required authority.

    IF caller_authority < field_utility_info_ptr^.display_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

  PROCEND get_job_validation_field;
?? TITLE := '    get_job_validation_record', EJECT ??

{ PURPOSE:
{   This procedure returns pointers to the specified validation record for the currently executing job.

  PROCEDURE get_job_validation_record
    (    caller_id: ost$caller_identifier;
         record_level: avt$validation_record;
     VAR caller_authority: avt$validation_authority;
     VAR data_record: ^avt$template_file_record;
     VAR description_record: ^avt$template_file_record;
     VAR status: ost$status);

    VAR
      executing_account_name: avt$account_name,
      executing_project_name: avt$project_name;

    status.normal := TRUE;

{ Retrieve the executing job's account and project.

    pmp$get_account_project (executing_account_name, executing_project_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE record_level OF
    = avc$user =

{ Find the user record stored in memory for the job.

      IF ((avv$user_data_record = NIL) OR (avv$user_description_record = NIL)) THEN
        osp$set_status_abnormal ('AV', ave$user_info_not_found, '', status);
        RETURN;
      IFEND;
      data_record := avv$user_data_record;
      description_record := avv$user_description_record;

      determine_caller_authority (caller_id, NIL, NIL, NIL, ^executing_account_name, ^executing_project_name,
            caller_authority);

{ Minimum authority is always set to user because the only option is to get the executing user's information.

      IF caller_authority < avc$user_authority THEN
        caller_authority := avc$user_authority;
      IFEND;

    = avc$account =

{ Find the account record stored in memory for the job.

      IF ((avv$account_data_record = NIL) OR (avv$account_description_record = NIL)) THEN
        osp$set_status_abnormal ('AV', ave$account_info_not_found, '', status);
        RETURN;
      IFEND;
      data_record := avv$account_data_record;
      description_record := avv$account_description_record;

      determine_caller_authority (caller_id, ^executing_account_name, NIL, NIL, NIL, NIL, caller_authority);

    = avc$account_member =

{ Find the account member record stored in memory for the job.

      IF ((avv$account_member_data_record = NIL) OR (avv$account_member_desc_record = NIL)) THEN
        osp$set_status_abnormal ('AV', ave$acct_member_info_not_found, '', status);
        RETURN;
      IFEND;
      data_record := avv$account_member_data_record;
      description_record := avv$account_member_desc_record;

      determine_caller_authority (caller_id, ^executing_account_name, NIL, NIL, NIL, NIL, caller_authority);

    = avc$project =

{ Find the project record stored in memory for the job.

      IF ((avv$project_data_record = NIL) OR (avv$project_description_record = NIL)) THEN
        osp$set_status_abnormal ('AV', ave$project_info_not_found, '', status);
        RETURN;
      IFEND;
      data_record := avv$project_data_record;
      description_record := avv$project_description_record;

      determine_caller_authority (caller_id, ^executing_account_name, ^executing_project_name, NIL, NIL, NIL,
            caller_authority);

    = avc$project_member =

{ Find the project member record stored in memory for the job.

      IF ((avv$project_member_data_record = NIL) OR (avv$project_member_desc_record = NIL)) THEN
        osp$set_status_abnormal ('AV', ave$proj_member_info_not_found, '', status);
        RETURN;
      IFEND;
      data_record := avv$project_member_data_record;
      description_record := avv$project_member_desc_record;

      determine_caller_authority (caller_id, ^executing_account_name, ^executing_project_name, NIL, NIL, NIL,
            caller_authority);
    ELSE
      osp$set_status_abnormal ('AV', ave$unknown_validation_record, '', status);
      RETURN;
    CASEND;

  PROCEND get_job_validation_record;
?? TITLE := '    init_get_display_value_info', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used by the get field display value interfaces to
{ perform common routines.
{
  PROCEDURE init_get_display_value_info
    (    field_name: ost$name;
         record_id: ost$name;
         work_area: ^seq (*);
     VAR field_value: avt$field_value;
     VAR type_specification: avt$type_specification;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      descriptive_text: ^avt$descriptive_text,
      field_utility_info_ptr: ^avt$field_utility_information,
      field_value_list_entry: ^avt$field_value_list_entry,
      utility_information: ^avt$utility_information,
      validation_record_info: ^avt$validation_record_info,
      work_area_ptr: ^seq (*);

    status.normal := TRUE;

{ Find the information for this subutility session within the validation
{ record information chain.

    find_validation_record_info (record_id, validation_record_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Retrieve the current field value of the specified field from the validation record.

    work_area_ptr := work_area;
    avp$get_field (field_name, validation_record_info^.data_record,
          validation_record_info^.description_record, work_area, field_value, type_specification,
          default_value, descriptive_text, utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Get the display authority for the field.

    RESET utility_information;
    NEXT field_utility_info_ptr IN utility_information;
    IF field_utility_info_ptr = NIL THEN
      corrupted_sequence ('INITIALIZE_CHANGE_VALUE_INFO', 'CHANGE_AUTHORITY', 'FIELD_UTILITY_INFORMATION',
            status);
      RETURN;
    IFEND;

{ Verify that the caller has the required authority.

    IF validation_record_info^.caller_authority < field_utility_info_ptr^.display_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Reset the field value to the last value specified by any subutility
{ session updates for this field.

    field_value_list_entry := validation_record_info^.field_value_list;

  /find_existing_field_value/
    WHILE field_value_list_entry <> NIL DO
      IF field_value_list_entry^.field_name = field_name THEN
        field_value := field_value_list_entry^.field_value;
        EXIT /find_existing_field_value/;
      IFEND;
      field_value_list_entry := field_value_list_entry^.forward;
    WHILEND /find_existing_field_value/;

  PROCEND init_get_display_value_info;
?? TITLE := '    initialize_change_value_info', EJECT ??
{
{ PURPOSE:
{   This procedure is used by the change field value interfaces to
{ perform common routines.
{

  PROCEDURE initialize_change_value_info
    (    field_name: ost$name;
         record_id: ost$name;
         work_area: ^seq (*);
     VAR type_specification: avt$type_specification;
     VAR field_value_list_entry: ^avt$field_value_list_entry;
     VAR validation_record_info: ^avt$validation_record_info;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      descriptive_text: ^avt$descriptive_text,
      field_utility_info_ptr: ^avt$field_utility_information,
      field_value: avt$field_value,
      found_existing_field_value: boolean,
      utility_information: ^avt$utility_information,
      work_area_ptr: ^seq (*);

    status.normal := TRUE;

{ Find the information for this subutility session within the validation
{ record information chain.

    find_validation_record_info (record_id, validation_record_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Get the current field values.

    work_area_ptr := work_area;
    avp$get_field (field_name, validation_record_info^.data_record,
          validation_record_info^.description_record, work_area_ptr, field_value, type_specification,
          default_value, descriptive_text, utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Retrieve the change authority from the field utility information.

    RESET utility_information;
    NEXT field_utility_info_ptr IN utility_information;
    IF field_utility_info_ptr = NIL THEN
      corrupted_sequence ('INITIALIZE_CHANGE_VALUE_INFO', 'CHANGE_AUTHORITY', 'FIELD_UTILITY_INFORMATION',
            status);
      RETURN;
    IFEND;
    IF validation_record_info^.caller_authority < field_utility_info_ptr^.change_authority THEN
      osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
      RETURN;
    IFEND;

{ Find any previous changes to this field for this subutility session.

    field_value_list_entry := validation_record_info^.field_value_list;
    found_existing_field_value := FALSE;

  /find_existing_field_value/
    WHILE field_value_list_entry <> NIL DO
      IF field_value_list_entry^.field_name = field_name THEN
        found_existing_field_value := TRUE;
        EXIT /find_existing_field_value/;
      IFEND;
      field_value_list_entry := field_value_list_entry^.forward;
    WHILEND /find_existing_field_value/;

{ Initialize a field value list entry with the current value if one was not found.

    IF NOT found_existing_field_value THEN
      NEXT field_value_list_entry IN validation_record_info^.work_area.sequence_pointer;
      field_value_list_entry^.field_name := field_name;
      field_value_list_entry^.field_value := field_value;
      field_value_list_entry^.forward := validation_record_info^.field_value_list;
      validation_record_info^.field_value_list := field_value_list_entry;
    IFEND;

  PROCEND initialize_change_value_info;
?? TITLE := '    initialize_validation_fields', EJECT ??
{
{ PURPOSE:
{
{   This procedure is called when opening a new validation file to create the
{ system defined validation fields.
{

  PROCEDURE initialize_validation_fields
    (    family_name: ost$family_name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      description: ^avt$descriptive_text,
      description_string: ost$string,
      field_utility_information: avt$field_utility_information,
      string_value: ost$string,
      type_specification: avt$type_specification;

    status.normal := TRUE;

{ User fields.

    description_string.value := avc$accounting_admin_descr;
    description_string.size := clp$trimmed_string_size (avc$accounting_admin_descr);
    avp$create_capability_field (avc$accounting_administration, avc$user_record_name,
          avc$accounting_admin_default, description_string, avc$user_authority, avc$system_admin_authority,
          avc$system_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$application_admin_descr;
    description_string.size := clp$trimmed_string_size (avc$application_admin_descr);
    avp$create_capability_field (avc$application_administration, avc$user_record_name,
          avc$application_admin_default, description_string, avc$user_authority, avc$system_admin_authority,
          avc$system_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$configuration_admin_descr;
    description_string.size := clp$trimmed_string_size (avc$configuration_admin_descr);
    avp$create_capability_field (avc$configuration_admin, avc$user_record_name,
          avc$configuration_admin_default, description_string, avc$user_authority,
          avc$system_admin_authority, avc$system_admin_authority, avc$system_authority, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$cpu_time_limit_description;
    description_string.size := clp$trimmed_string_size (avc$cpu_time_limit_description);
    avp$create_accum_limit_field (avc$cpu_time_limit, avc$user_record_name, avc$maximum_cpu_default,
          avc$maximum_cpu_default, avc$maximum_cpu_default, avc$cpu_limit_name_default,
          avc$cpu_job_limits_apply_def, NIL, avc$minimum_cpu_default, avc$maximum_cpu_default,
          avc$cpu_total_limit_applies_def, avc$cpu_tot_lim_stops_login_def, avc$cpu_time_limit_chg_cmd,
          avc$cpu_time_limit_dis_cmd, description_string, avc$user_authority, avc$family_admin_authority,
          avc$family_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$creation_acct_proj_descr;
    description_string.size := clp$trimmed_string_size (avc$creation_acct_proj_descr);
    avp$create_acct_proj_field (avc$creation_account_project, avc$user_record_name,
          avc$default_account_default, avc$default_project_default, avc$creation_acct_proj_chg_cmd,
          avc$creation_acct_proj_dis_cmd, description_string, avc$user_admin_authority,
          avc$user_admin_authority, avc$family_admin_authority, avc$system_authority, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$default_acct_proj_descr;
    description_string.size := clp$trimmed_string_size (avc$default_acct_proj_descr);
    avp$create_acct_proj_field (avc$default_account_project, avc$user_record_name,
          avc$default_account_default, avc$default_project_default, avc$default_acct_proj_chg_cmd,
          avc$default_acct_proj_dis_cmd, description_string, avc$user_authority, avc$user_authority,
          avc$family_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$dual_state_prompt_descr;
    description_string.size := clp$trimmed_string_size (avc$dual_state_prompt_descr);
    avp$create_capability_field (avc$dual_state_prompt, avc$user_record_name, avc$dual_state_prompt_default,
          description_string, avc$user_authority, avc$user_authority, avc$family_admin_authority,
          avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$engineering_operation_descr;
    description_string.size := clp$trimmed_string_size (avc$engineering_operation_descr);
    avp$create_capability_field (avc$engineering_operation, avc$user_record_name,
          avc$engineering_operation_def, description_string, avc$user_authority,
          avc$system_admin_authority, avc$system_admin_authority, avc$system_authority, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$explicit_remote_file_descr;
    description_string.size := clp$trimmed_string_size (avc$explicit_remote_file_descr);
    avp$create_capability_field (avc$explicit_remote_file, avc$user_record_name, avc$explicit_remote_file_def,
          description_string, avc$user_authority, avc$family_admin_authority, avc$family_admin_authority,
          avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$family_admin_description;
    description_string.size := clp$trimmed_string_size (avc$family_admin_description);
    avp$create_capability_field (avc$family_administration, avc$user_record_name, avc$family_admin_default,
          description_string, avc$user_authority, avc$family_admin_authority, avc$system_authority,
          avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$implicit_remote_file_descr;
    description_string.size := clp$trimmed_string_size (avc$implicit_remote_file_descr);
    avp$create_capability_field (avc$implicit_remote_file, avc$user_record_name, avc$implicit_remote_file_def,
          description_string, avc$user_authority, avc$family_admin_authority, avc$family_admin_authority,
          avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$job_class_description;
    description_string.size := clp$trimmed_string_size (avc$job_class_description);
    avp$create_job_class_field (avc$job_class, avc$user_record_name, avc$job_class_defaults,
          avc$batch_job_class_default, avc$interactive_job_class_def, avc$common_job_class_defaults,
          avc$job_class_chg_cmd, avc$job_class_dis_cmd, description_string, avc$user_authority,
          avc$family_admin_authority, avc$family_admin_authority, avc$system_authority, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$job_dest_usages_descr;
    description_string.size := clp$trimmed_string_size (avc$job_dest_usages_descr);
    avp$create_name_field (avc$job_destination_usages, avc$user_record_name, avc$job_destination_usages_def,
          avc$jdu_min_number_of_names, avc$jdu_max_number_of_names, avc$job_dest_usages_names_def,
          avc$job_dest_usages_chg_cmd, avc$job_dest_usages_dis_cmd, description_string, avc$user_authority,
          avc$family_admin_authority, avc$family_admin_authority, avc$system_authority, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$link_attrib_charge_descr;
    description_string.size := clp$trimmed_string_size (avc$link_attrib_charge_descr);
    avp$create_string_field (avc$link_attribute_charge, avc$user_record_name, avc$link_attribute_default,
          avc$link_attribute_minimum_size, avc$link_attribute_maximum_size, avc$link_attrib_charge_chg_cmd,
          avc$link_attrib_charge_dis_cmd, description_string, avc$user_authority, avc$user_authority,
          avc$family_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    string_value.value := family_name;
    string_value.size := clp$trimmed_string_size (family_name);
    description_string.value := avc$link_attrib_family_descr;
    description_string.size := clp$trimmed_string_size (avc$link_attrib_family_descr);
    avp$create_string_field (avc$link_attribute_family, avc$user_record_name, string_value,
          avc$link_attribute_minimum_size, avc$link_attribute_maximum_size, avc$link_attrib_family_chg_cmd,
          avc$link_attrib_family_dis_cmd, description_string, avc$user_authority, avc$user_authority,
          avc$family_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$link_attrib_password_descr;
    description_string.size := clp$trimmed_string_size (avc$link_attrib_password_descr);
    avp$create_string_field (avc$link_attribute_password, avc$user_record_name, avc$link_attribute_default,
          avc$link_attribute_minimum_size, avc$link_attribute_maximum_size, avc$link_attrib_pw_chg_cmd,
          avc$link_attrib_pw_dis_cmd, description_string, avc$system_authority, avc$user_authority,
          avc$family_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$link_attrib_project_descr;
    description_string.size := clp$trimmed_string_size (avc$link_attrib_project_descr);
    avp$create_string_field (avc$link_attribute_project, avc$user_record_name, avc$link_attribute_default,
          avc$link_attribute_minimum_size, avc$link_attribute_maximum_size, avc$link_attrib_project_chg_cmd,
          avc$link_attrib_project_dis_cmd, description_string, avc$user_authority, avc$user_authority,
          avc$family_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$link_attrib_user_descr;
    description_string.size := clp$trimmed_string_size (avc$link_attrib_user_descr);
    avp$create_string_field (avc$link_attribute_user, avc$user_record_name, avc$link_attribute_default,
          avc$link_attribute_minimum_size, avc$link_attribute_maximum_size, avc$link_attrib_user_chg_cmd,
          avc$link_attrib_user_dis_cmd, description_string, avc$user_authority, avc$user_authority,
          avc$family_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$login_password_description;
    description_string.size := clp$trimmed_string_size (avc$login_password_description);
    avp$create_login_password_field (avc$login_password, avc$user_record_name, avc$login_password_default,
          avc$expiration_date_default, avc$exp_interval_default, avc$max_exp_interval_default,
          avc$exp_warning_default, avc$exp_chg_interval_default, avc$login_pass_attribute_def,
          avc$login_password_chg_cmd, avc$login_password_dis_cmd, description_string, avc$user_authority,
          avc$user_authority, avc$family_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$magnetic_tape_limit_descr;
    description_string.size := clp$trimmed_string_size (avc$magnetic_tape_limit_descr);
    avp$create_accum_limit_field (avc$magnetic_tape_limit, avc$user_record_name,
          avc$magnetic_tape_max_default, avc$magnetic_tape_max_default, avc$magnetic_tape_max_default,
          avc$mt_limit_name_default,
          avc$mt_job_limits_apply_def, NIL, avc$magnetic_tape_min_default, avc$magnetic_tape_max_default,
          avc$mt_total_limit_applies_def, avc$mt_tot_lim_stops_login_def, avc$magnetic_tape_limit_chg_cmd,
          avc$magnetic_tape_limit_dis_cmd, description_string, avc$user_authority, avc$family_admin_authority,
          avc$family_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$mailve_administration_descr;
    description_string.size := clp$trimmed_string_size (avc$mailve_administration_descr);
    avp$create_name_field (avc$mailve_administration, avc$user_record_name, avc$mailve_admin_names_def,
          avc$mailve_min_number_of_names, avc$mailve_max_number_of_names, avc$mailve_common_names_def,
          avc$mailve_admin_chg_cmd, avc$mailve_admin_dis_cmd, description_string, avc$user_authority,
          avc$system_admin_authority, avc$system_admin_authority, avc$system_authority, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$mailve_dist_list_limit_desc;
    description_string.size := clp$trimmed_string_size (avc$mailve_dist_list_limit_desc);
    avp$create_limit_field (avc$mailve_dist_list_limit, avc$user_record_name,
          avc$mailve_dist_list_limit_def, avc$mailve_dist_list_min_def, avc$mailve_dist_list_max_def,
          avc$mailve_dist_list_chg_cmd, avc$mailve_dist_list_dis_cmd, description_string,
          avc$user_authority, avc$family_admin_authority, avc$family_admin_authority, avc$system_authority,
          file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$mailve_mailbox_limit_descr;
    description_string.size := clp$trimmed_string_size (avc$mailve_mailbox_limit_descr);
    avp$create_limit_field (avc$mailve_mailbox_limit, avc$user_record_name,
          avc$mailve_mailbox_limit_def, avc$mailve_mailbox_lim_min_def, avc$mailve_mailbox_lim_max_def,
          avc$mailve_mailbox_lim_chg_cmd, avc$mailve_mailbox_lim_dis_cmd, description_string,
          avc$user_authority, avc$family_admin_authority, avc$family_admin_authority, avc$system_authority,
          file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$mailve_retention_limit_desc;
    description_string.size := clp$trimmed_string_size (avc$mailve_retention_limit_desc);
    avp$create_limit_field (avc$mailve_retention_limit, avc$user_record_name,
          avc$mailve_retention_limit_def, avc$mailve_retention_min_def, avc$mailve_retention_max_def,
          avc$mailve_retention_chg_cmd, avc$mailve_retention_dis_cmd, description_string,
          avc$user_authority, avc$family_admin_authority, avc$family_admin_authority, avc$system_authority,
          file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$network_applic_mgmt_descr;
    description_string.size := clp$trimmed_string_size (avc$network_applic_mgmt_descr);
    avp$create_capability_field (avc$network_applic_management, avc$user_record_name,
          avc$network_applic_mgmt_def, description_string, avc$user_authority, avc$system_admin_authority,
          avc$system_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$network_operation_descr;
    description_string.size := clp$trimmed_string_size (avc$network_operation_descr);
    avp$create_capability_field (avc$network_operation, avc$user_record_name, avc$network_operation_default,
          description_string, avc$user_authority, avc$system_admin_authority, avc$system_admin_authority,
          avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$ntf_operation_description;
    description_string.size := clp$trimmed_string_size (avc$ntf_operation_description);
    avp$create_capability_field (avc$ntf_operation, avc$user_record_name, avc$ntf_operation_default,
          description_string, avc$user_authority, avc$system_admin_authority, avc$system_admin_authority,
          avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$output_dest_usages_descr;
    description_string.size := clp$trimmed_string_size (avc$output_dest_usages_descr);
    avp$create_name_field (avc$output_destination_usages, avc$user_record_name, avc$output_dest_usages_def,
          avc$odu_min_number_of_names, avc$odu_max_number_of_names, avc$output_dest_usage_names_def,
          avc$output_dest_usages_chg_cmd, avc$output_dest_usages_dis_cmd, description_string,
          avc$user_authority, avc$family_admin_authority, avc$family_admin_authority, avc$system_authority,
          file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$removable_media_access_desc;
    description_string.size := clp$trimmed_string_size (avc$removable_media_access_desc);
    avp$create_labeled_names_field (avc$removable_media_access, avc$user_record_name,
          avc$removable_media_access_def, avc$rma_valid_groups_default, avc$rma_valid_access_modes_def,
          avc$rma_change_commands, avc$rma_display_commands,
          description_string, avc$user_authority, avc$family_admin_authority,
          avc$family_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$removable_media_admin_descr;
    description_string.size := clp$trimmed_string_size (avc$removable_media_admin_descr);
    avp$create_capability_field (avc$removable_media_admin, avc$user_record_name,
          avc$removable_media_admin_def, description_string, avc$user_authority, avc$system_admin_authority,
          avc$system_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$removable_media_oper_descr;
    description_string.size := clp$trimmed_string_size (avc$removable_media_oper_descr);
    avp$create_capability_field (avc$removable_media_operation, avc$user_record_name,
          avc$removable_media_oper_def, description_string, avc$user_authority, avc$system_admin_authority,
          avc$system_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$perm_file_space_limit_descr;
    description_string.size := clp$trimmed_string_size (avc$perm_file_space_limit_descr);
    avp$create_accum_limit_field (avc$permanent_file_space_limit, avc$user_record_name,
          avc$maximum_pfs_default, avc$maximum_pfs_default, avc$maximum_pfs_default,
          avc$pfs_limit_name_default, avc$pfs_job_limits_apply_def, NIL, avc$minimum_pfs_default,
          avc$maximum_pfs_default, avc$pfs_total_limit_applies_def, avc$pfs_tot_lim_stops_login_def,
          avc$perm_file_space_chg_cmd, avc$perm_file_space_dis_cmd, description_string, avc$user_authority,
          avc$family_admin_authority, avc$family_admin_authority, avc$system_authority, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$permit_level_description;
    description_string.size := clp$trimmed_string_size (avc$permit_level_description);
    avp$create_name_field (avc$permit_level, avc$user_record_name, avc$permit_level_names_def,
          avc$pl_min_number_of_names, avc$pl_max_number_of_names, avc$permit_level_com_names_def,
          avc$permit_level_chg_cmd, avc$permit_level_dis_cmd, description_string, avc$user_authority,
          avc$family_admin_authority, avc$family_admin_authority, avc$system_authority, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$ring_privilege_description;
    description_string.size := clp$trimmed_string_size (avc$ring_privilege_description);
    avp$create_ring_privilege_field (avc$ring_privileges, avc$user_record_name, avc$minimum_ring_default,
          avc$nominal_ring_default, avc$ring_privilege_chg_cmd, avc$ring_privilege_dis_cmd,
          description_string, avc$user_authority, avc$system_admin_authority, avc$system_admin_authority,
          avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$scheduling_admin_descr;
    description_string.size := clp$trimmed_string_size (avc$scheduling_admin_descr);
    avp$create_capability_field (avc$scheduling_administration, avc$user_record_name,
          avc$scheduling_admin_default, description_string, avc$user_authority, avc$system_admin_authority,
          avc$system_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$sru_limit_description;
    description_string.size := clp$trimmed_string_size (avc$sru_limit_description);
    avp$create_accum_limit_field (avc$sru_limit, avc$user_record_name, avc$maximum_sru_default,
          avc$maximum_sru_default, avc$maximum_sru_default, avc$sru_limit_name_default,
          avc$sru_job_limits_apply_def, NIL, avc$minimum_sru_default, avc$maximum_sru_default,
          avc$sru_total_limit_applies_def, avc$sru_tot_lim_stops_login_def, avc$sru_limit_chg_cmd,
          avc$sru_limit_dis_cmd, description_string, avc$user_authority, avc$family_admin_authority,
          avc$family_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$station_operation_descr;
    description_string.size := clp$trimmed_string_size (avc$station_operation_descr);
    avp$create_capability_field (avc$station_operation, avc$user_record_name, avc$station_operation_default,
          description_string, avc$user_authority, avc$family_admin_authority, avc$family_admin_authority,
          avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$system_admin_description;
    description_string.size := clp$trimmed_string_size (avc$system_admin_description);
    avp$create_capability_field (avc$system_administration, avc$user_record_name, avc$system_admin_default,
          description_string, avc$user_authority, avc$system_admin_authority, avc$system_authority,
          avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$system_displays_description;
    description_string.size := clp$trimmed_string_size (avc$system_displays_description);
    avp$create_capability_field (avc$system_displays, avc$user_record_name, avc$system_displays_default,
          description_string, avc$user_authority, avc$system_admin_authority, avc$system_admin_authority,
          avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$system_operation_descr;
    description_string.size := clp$trimmed_string_size (avc$system_operation_descr);
    avp$create_capability_field (avc$system_operation, avc$user_record_name, avc$system_operation_default,
          description_string, avc$user_authority, avc$system_admin_authority, avc$system_admin_authority,
          avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$task_limit_description;
    description_string.size := clp$trimmed_string_size (avc$task_limit_description);
    avp$create_accum_limit_field (avc$task_limit, avc$user_record_name, avc$default_task_default,
          avc$default_task_default, avc$maximum_task_default, avc$task_limit_name_default,
          avc$task_job_limits_apply_def, NIL, avc$minimum_task_default, avc$maximum_task_default,
          avc$tas_total_limit_applies_def, avc$tas_tot_lim_stops_login_def, avc$task_limit_chg_cmd,
          avc$task_limit_dis_cmd, description_string, avc$user_authority, avc$family_admin_authority,
          avc$family_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$temp_file_space_limit_descr;
    description_string.size := clp$trimmed_string_size (avc$temp_file_space_limit_descr);
    avp$create_accum_limit_field (avc$temporary_file_space_limit, avc$user_record_name,
          avc$maximum_tfs_default, avc$maximum_tfs_default, avc$maximum_tfs_default,
          avc$tfs_limit_name_default, avc$tfs_job_limits_apply_def, NIL, avc$minimum_tfs_default,
          avc$maximum_tfs_default, avc$tfs_total_limit_applies_def, avc$tfs_tot_lim_stops_login_def,
          avc$temp_file_space_chg_cmd, avc$temp_file_space_dis_cmd, description_string, avc$user_authority,
          avc$family_admin_authority, avc$family_admin_authority, avc$system_authority, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$terminal_timeout_limit_desc;
    description_string.size := clp$trimmed_string_size (avc$terminal_timeout_limit_desc);
    avp$create_limit_field (avc$terminal_timeout_limit, avc$user_record_name,
          avc$terminal_timeout_limit_def, avc$terminal_timeout_min_def, avc$terminal_timeout_max_def,
          avc$terminal_timeout_chg_cmd, avc$terminal_timeout_dis_cmd, description_string,
          avc$user_authority, avc$family_admin_authority, avc$family_admin_authority, avc$system_authority,
          file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$timesharing_description;
    description_string.size := clp$trimmed_string_size (avc$timesharing_description);
    avp$create_capability_field (avc$timesharing, avc$user_record_name, avc$timesharing_default,
          description_string, avc$user_authority, avc$family_admin_authority, avc$family_admin_authority,
          avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$user_epilog_description;
    description_string.size := clp$trimmed_string_size (avc$user_epilog_description);
    avp$create_file_field (avc$user_epilog, avc$user_record_name, avc$user_epilog_default,
          avc$user_epilog_chg_cmd, avc$user_epilog_dis_cmd, description_string, avc$user_authority,
          avc$user_authority, avc$family_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$user_prolog_description;
    description_string.size := clp$trimmed_string_size (avc$user_prolog_description);
    avp$create_file_field (avc$user_prolog, avc$user_record_name, avc$user_prolog_default,
          avc$user_prolog_chg_cmd, avc$user_prolog_dis_cmd, description_string, avc$user_authority,
          avc$user_authority, avc$family_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Account fields.

    description_string.value := avc$account_epilog_description;
    description_string.size := clp$trimmed_string_size (avc$account_epilog_description);
    avp$create_file_field (avc$account_epilog, avc$account_record_name, avc$account_epilog_default,
          avc$account_epilog_chg_cmd, avc$account_epilog_dis_cmd, description_string,
          avc$account_admin_authority, avc$account_admin_authority, avc$family_admin_authority,
          avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$account_prolog_description;
    description_string.size := clp$trimmed_string_size (avc$account_prolog_description);
    avp$create_file_field (avc$account_prolog, avc$account_record_name, avc$account_prolog_default,
          avc$account_prolog_chg_cmd, avc$account_prolog_dis_cmd, description_string,
          avc$account_admin_authority, avc$account_admin_authority, avc$family_admin_authority,
          avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Project fields.

    description_string.value := avc$project_epilog_description;
    description_string.size := clp$trimmed_string_size (avc$project_epilog_description);
    avp$create_file_field (avc$project_epilog, avc$project_record_name, avc$project_epilog_default,
          avc$project_epilog_chg_cmd, avc$project_epilog_dis_cmd, description_string,
          avc$project_admin_authority, avc$project_admin_authority, avc$family_admin_authority,
          avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$project_prolog_description;
    description_string.size := clp$trimmed_string_size (avc$project_prolog_description);
    avp$create_file_field (avc$project_prolog, avc$project_record_name, avc$project_prolog_default,
          avc$project_prolog_chg_cmd, avc$project_prolog_dis_cmd, description_string,
          avc$project_admin_authority, avc$project_admin_authority, avc$family_admin_authority,
          avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Account member fields.

    description_string.value := avc$account_admin_description;
    description_string.size := clp$trimmed_string_size (avc$account_admin_description);
    avp$create_capability_field (avc$account_administration, avc$account_member_record_name,
          avc$account_admin_default, description_string, avc$account_admin_authority,
          avc$account_admin_authority, avc$family_admin_authority, avc$system_authority, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$user_admin_acct_descr;
    description_string.size := clp$trimmed_string_size (avc$user_admin_acct_descr);
    avp$create_capability_field (avc$user_administration, avc$account_member_record_name,
          avc$user_admin_default, description_string, avc$account_admin_authority, avc$family_admin_authority,
          avc$family_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Project member fields.

    description_string.value := avc$project_admin_description;
    description_string.size := clp$trimmed_string_size (avc$project_admin_description);
    avp$create_capability_field (avc$project_administration, avc$project_member_record_name,
          avc$project_admin_default, description_string, avc$project_admin_authority,
          avc$project_admin_authority, avc$family_admin_authority, avc$system_authority, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    description_string.value := avc$user_admin_proj_descr;
    description_string.size := clp$trimmed_string_size (avc$user_admin_proj_descr);
    avp$create_capability_field (avc$user_administration, avc$project_member_record_name,
          avc$user_admin_default, description_string, avc$project_admin_authority, avc$family_admin_authority,
          avc$family_admin_authority, avc$system_authority, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND initialize_validation_fields;
?? TITLE := '    initialize_validation_records', EJECT ??
{
{ PURPOSE:
{
{   This procedure is called when opening a new validation file to create the
{ system defined validation records.
{

  PROCEDURE initialize_validation_records
    (VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      record_utility_info_array: ^array [1 .. * ] of avt$record_utility_info_entry,
      record_utility_info_header: ^avt$record_utility_info_header,
      record_utility_information: ^avt$utility_information,
      utility_information: ^avt$utility_information;

    status.normal := TRUE;

{ Build User description record.

    PUSH record_utility_information: [[REP 1 OF avt$record_utility_info_header, REP
          (avc$maximum_field_count * 2) OF avt$record_utility_info_entry]];
    RESET record_utility_information;
    NEXT record_utility_info_header IN record_utility_information;
    IF record_utility_info_header = NIL THEN
      corrupted_sequence ('INITIALIZE_VALIDATION_RECORDS', 'HEADER', 'RECORD_UTILITY_INFORMATION', status);
      RETURN;
    IFEND;
    record_utility_info_header^.number_of_commands := 0;
    record_utility_info_header^.number_of_entries := 0;

    add_new_record_utility_info_cmd (avc$end_change_user_commands, osc$null_name, avc$end_subutility_command,
          record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$display_field_descr_cmds, osc$null_name,
          avc$display_field_description, record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$display_field_names_cmds, osc$null_name, avc$display_field_names,
          record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$change_capability_commands, avc$cap_cmd_table_field_name,
          avc$change_capability_command, record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$display_capability_commands, avc$cap_cmd_table_field_name,
          avc$display_field_value, record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sort_record_utility_information (record_utility_information, utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    avp$create_description_record (avc$user_record_name, utility_information, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Build Account description record.

    RESET record_utility_information;
    NEXT record_utility_info_header IN record_utility_information;
    IF record_utility_info_header = NIL THEN
      corrupted_sequence ('INITIALIZE_VALIDATION_RECORDS', 'HEADER', 'RECORD_UTILITY_INFORMATION', status);
      RETURN;
    IFEND;
    record_utility_info_header^.number_of_entries := 0;
    record_utility_info_header^.number_of_commands := 0;

    add_new_record_utility_info_cmd (avc$end_change_acct_commands, osc$null_name, avc$end_subutility_command,
          record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$display_field_descr_cmds, osc$null_name,
          avc$display_field_description, record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$display_field_names_cmds, osc$null_name, avc$display_field_names,
          record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$change_capability_commands, avc$cap_cmd_table_field_name,
          avc$change_capability_command, record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$display_capability_commands, avc$cap_cmd_table_field_name,
          avc$display_field_value, record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sort_record_utility_information (record_utility_information, utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$create_description_record (avc$account_record_name, utility_information, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Build Account Member description record.

    RESET record_utility_information;
    NEXT record_utility_info_header IN record_utility_information;
    IF record_utility_info_header = NIL THEN
      corrupted_sequence ('INITIALIZE_VALIDATION_RECORDS', 'HEADER', 'RECORD_UTILITY_INFORMATION', status);
      RETURN;
    IFEND;
    record_utility_info_header^.number_of_commands := 0;
    record_utility_info_header^.number_of_entries := 0;

    add_new_record_utility_info_cmd (avc$end_change_acct_mem_cmds, osc$null_name, avc$end_subutility_command,
          record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$display_field_descr_cmds, osc$null_name,
          avc$display_field_description, record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$display_field_names_cmds, osc$null_name, avc$display_field_names,
          record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$change_capability_commands, avc$cap_cmd_table_field_name,
          avc$change_capability_command, record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$display_capability_commands, avc$cap_cmd_table_field_name,
          avc$display_field_value, record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sort_record_utility_information (record_utility_information, utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$create_description_record (avc$account_member_record_name, utility_information, file_information,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Build Project description record.

    RESET record_utility_information;
    NEXT record_utility_info_header IN record_utility_information;
    IF record_utility_info_header = NIL THEN
      corrupted_sequence ('INITIALIZE_VALIDATION_RECORDS', 'HEADER', 'RECORD_UTILITY_INFORMATION', status);
      RETURN;
    IFEND;
    record_utility_info_header^.number_of_commands := 0;
    record_utility_info_header^.number_of_entries := 0;

    add_new_record_utility_info_cmd (avc$end_change_proj_commands, osc$null_name, avc$end_subutility_command,
          record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$display_field_descr_cmds, osc$null_name,
          avc$display_field_description, record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$display_field_names_cmds, osc$null_name, avc$display_field_names,
          record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$change_capability_commands, avc$cap_cmd_table_field_name,
          avc$change_capability_command, record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$display_capability_commands, avc$cap_cmd_table_field_name,
          avc$display_field_value, record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sort_record_utility_information (record_utility_information, utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$create_description_record (avc$project_record_name, utility_information, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Build Project Member description record.

    RESET record_utility_information;
    NEXT record_utility_info_header IN record_utility_information;
    IF record_utility_info_header = NIL THEN
      corrupted_sequence ('INITIALIZE_VALIDATION_RECORDS', 'HEADER', 'RECORD_UTILITY_INFORMATION', status);
      RETURN;
    IFEND;
    record_utility_info_header^.number_of_commands := 0;
    record_utility_info_header^.number_of_entries := 0;

    add_new_record_utility_info_cmd (avc$end_change_proj_mem_cmds, osc$null_name, avc$end_subutility_command,
          record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$display_field_descr_cmds, osc$null_name,
          avc$display_field_description, record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$display_field_names_cmds, osc$null_name, avc$display_field_names,
          record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$change_capability_commands, avc$cap_cmd_table_field_name,
          avc$change_capability_command, record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_new_record_utility_info_cmd (avc$display_capability_commands, avc$cap_cmd_table_field_name,
          avc$display_field_value, record_utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sort_record_utility_information (record_utility_information, utility_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$create_description_record (avc$project_member_record_name, utility_information, file_information,
          status);

  PROCEND initialize_validation_records;
?? TITLE := '    prevalidate_job', EJECT ??
  PROCEDURE prevalidate_job
    (    validation_level: avt$validation_level;
         user_name: ost$user_name;
         family_name: ost$family_name;
         validation_attributes: ^avt$validation_items;
         default_attributes: ^avt$validation_items;
     VAR status: ost$status);

    TYPE
      limit_item = record
        limit_name: ost$name,
        user_specified: boolean,
        job_maximum_limit: sft$counter,
        forward: ^limit_item,
      recend;

    VAR
      account_exists: boolean,
      account_name: avt$account_name,
      account_member_exists: boolean,
      audit_information: sft$audit_information,
      caller_authority: avt$validation_authority,
      current_date_time: ost$date_time,
      current_limit_item: ^limit_item,
      data_record: ^avt$template_file_record,
      data_record_size: 0 .. avc$max_template_record_size,
      default_value: avt$field_value,
      description_record: ^avt$template_file_record,
      description_record_name: ost$name,
      description_record_size: 0 .. avc$max_template_record_size,
      descriptive_text: ^avt$descriptive_text,
      default_name: jmt$job_class_name,
      field_count: avt$field_count,
      field_value: avt$field_value,
      field_value_list: avt$field_value_list,
      file_information: avt$template_file_information,
      found_job_class: boolean,
      ignore_status: ost$status,
      increment: pmt$time_increment,
      index: integer,
      item_index: integer,
      job_class: jmt$job_class,
      job_maximum: sft$counter,
      key: avt$validation_key,
      limit_field_names: ^array [1 .. * ] of ost$name,
      limit_item_list: ^limit_item,
      local_limit_name: ost$name,
      local_status: ost$status,
      login_password: avt$login_password,
      project_exists: boolean,
      project_member_exists: boolean,
      project_name: avt$project_name,
      temp_password: avt$password,
      terminal_name_p: ^ift$terminal_name,
      type_specification: avt$type_specification,
      unix_username: string (15),
      utility_information: ^avt$utility_information,
      valid_member: boolean;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that a
{   template file lock set is released if an error occurs.

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

      VAR
        ignore_status: ost$status;

      avp$unlock_template_file (file_information, ignore_status);

    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := '      emit_invalid_access_statistic', EJECT ??
{ PURPOSE
{   This procedure is used to emit a statistic to record a possible security violation.

    PROCEDURE emit_invalid_access_statistic
      (    family_name: ost$family_name,
           user_name: ost$user_name;
           terminal_name_p: ^ift$terminal_name);

      VAR
        ignore_status: ost$status,
        statistic_descriptive_data: ost$string;

      statistic_descriptive_data.value := family_name;
      statistic_descriptive_data.size := clp$trimmed_string_size (statistic_descriptive_data.value);

      statistic_descriptive_data.value (statistic_descriptive_data.size + 1, 2) := ', ';
      statistic_descriptive_data.size := statistic_descriptive_data.size + 2;

      statistic_descriptive_data.value (statistic_descriptive_data.size + 1,
            clp$trimmed_string_size (user_name)) := user_name (1, clp$trimmed_string_size (user_name));
      statistic_descriptive_data.size := statistic_descriptive_data.size +
            clp$trimmed_string_size (user_name);

      statistic_descriptive_data.value (statistic_descriptive_data.size + 1, 2) := ', ';
      statistic_descriptive_data.size := statistic_descriptive_data.size + 2;

      IF terminal_name_p <> NIL THEN
        statistic_descriptive_data.value (statistic_descriptive_data.size + 1,
              clp$trimmed_string_size (terminal_name_p^)) := terminal_name_p^ (1, clp$trimmed_string_size
              (terminal_name_p^));
        statistic_descriptive_data.size := statistic_descriptive_data.size +
              clp$trimmed_string_size (terminal_name_p^);
      IFEND;

      sfp$emit_statistic (avc$invalid_access_error, statistic_descriptive_data.
            value (1, statistic_descriptive_data.size), NIL, ignore_status);

    PROCEND emit_invalid_access_statistic;
?? OLDTITLE, EJECT ??
    limit_item_list := NIL;
    account_name := osc$null_name;
    project_name := osc$null_name;
    terminal_name_p := NIL;

{ Get the terminal name from the validation attributes (if it was specified).

    IF validation_attributes <> NIL THEN
    / get_terminal_name /
      FOR item_index := 1 TO UPPERBOUND (validation_attributes^) DO
        IF validation_attributes^ [item_index].key = avc$terminal_name THEN
          terminal_name_p := ^validation_attributes^ [item_index].terminal_name;
          EXIT /get_terminal_name/;
        IFEND;
      FOREND /get_terminal_name/;
    IFEND;

{ Open the validation file.

    avp$open_system_validation_file (family_name, file_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /prevalidate/
    BEGIN

{ Push a work area to hold the user data and description record.

      PUSH data_record: [[REP avc$max_template_record_size OF cell]];
      RESET data_record;
      PUSH description_record: [[REP avc$max_template_record_size OF cell]];
      RESET description_record;

{ Read the user information.

      key.account_name := avc$high_value_name;
      key.project_name := avc$high_value_name;
      key.user_name := user_name;
      osp$establish_block_exit_hndlr (^condition_handler);
      avp$read_data_record (key.value, avc$update_access, FALSE, data_record, data_record_size,
            description_record, description_record_size, description_record_name, field_count,
            file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$unknown_record THEN

{ Set the status we want to exit with.

          osp$set_status_condition (ave$bad_user_validation_info, status);
          emit_invalid_access_statistic (family_name, user_name, terminal_name_p);
        IFEND;
        EXIT /prevalidate/;
      IFEND;

{ Get the login password field value.

      avp$get_field (avc$login_password, data_record, description_record, {work_area=} NIL, field_value,
            type_specification, default_value, descriptive_text, utility_information, status);
      IF NOT status.normal THEN
        EXIT /prevalidate/;
      IFEND;

{ Check the login password for expiration.

      IF field_value.login_password_exp_date^.year <> avc$no_expiration_date THEN
        pmp$get_compact_date_time (current_date_time, status);
        IF NOT status.normal THEN
          EXIT /prevalidate/;
        IFEND;
        pmp$compute_date_time_increment (current_date_time, field_value.login_password_exp_date^, increment,
              status);
        IF NOT status.normal THEN
          EXIT /prevalidate/;
        IFEND;
        IF (increment.year < 0) OR (increment.month < 0) OR (increment.day < 0) OR (increment.hour < 0) OR
              (increment.minute < 0) OR (increment.second < 0) OR (increment.millisecond < 0) THEN

{ Set the status we want to exit with.

          osp$set_status_condition (ave$bad_user_validation_info, status);
          emit_invalid_access_statistic (family_name, user_name, terminal_name_p);
          EXIT /prevalidate/;
        IFEND;
      IFEND;

{ Validate the requested items.

      IF validation_attributes <> NIL THEN
        FOR item_index := 1 TO UPPERBOUND (validation_attributes^) DO
          CASE validation_attributes^ [item_index].key OF

{ Validate the specified account and project.

          = avc$account_project_key =

            account_name := validation_attributes^ [item_index].account_name;
            project_name := validation_attributes^ [item_index].project_name;

{ Get the user's default account and project if blanks were specified.

            IF ((account_name = osc$null_name) OR (project_name = osc$null_name)) THEN
              avp$get_field (avc$default_account_project, data_record, description_record, {work_area=} NIL,
                    field_value, type_specification, default_value, descriptive_text, utility_information,
                    status);
              IF NOT status.normal THEN
                EXIT /prevalidate/;
              IFEND;
              IF account_name = osc$null_name THEN
                account_name := field_value.account_name^;
              IFEND;
              IF project_name = osc$null_name THEN
                project_name := field_value.project_name^;
              IFEND;
            IFEND;

{ Verify that the user is a valid member.

            verify_acct_proj_membership (validation_level, account_name, project_name, user_name,
                  account_exists, project_exists, valid_member, file_information, status);
            IF NOT status.normal THEN
              EXIT /prevalidate/;
            IFEND;

            IF NOT valid_member THEN
              IF NOT account_exists THEN
                osp$set_status_abnormal ('AV', ave$account_does_not_exist, account_name, status);
              ELSEIF NOT project_exists THEN
                osp$set_status_abnormal ('AV', ave$project_does_not_exist, project_name, status);
                osp$append_status_parameter (osc$status_parameter_delimiter, account_name, status);
              ELSEIF validation_level = avc$account_level THEN
                  osp$set_status_abnormal ('AV', ave$acct_member_does_not_exist, user_name, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, account_name, status);
              ELSE
                  osp$set_status_abnormal ('AV', ave$member_does_not_exist, user_name, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, account_name, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, project_name, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, account_name, status);
              IFEND;
              EXIT /prevalidate/;
            IFEND;

{ Validate the specified job class.

          = avc$job_class_name_key =

{ Retrieve the user's valid job class list.

            avp$get_field (avc$job_class, data_record, description_record, {work_area=} NIL , field_value,
                  type_specification, default_value, descriptive_text, utility_information, status);
            IF NOT status.normal THEN
              EXIT /prevalidate/;
            IFEND;

{ Verify that the user is valid for the requested job class.

            validate_job_class (field_value, validation_attributes^ [item_index].job_class_name,
                  found_job_class);
            IF NOT found_job_class THEN
              osp$set_status_abnormal ('AV', ave$bad_job_class,
                    validation_attributes^ [item_index].job_class_name, status);
              EXIT /prevalidate/;
            IFEND;

{ Validate the specified job execution ring.

          = avc$job_execution_ring_key =

{ Retrieve the user's ring privileges.

            avp$get_field (avc$ring_privileges, data_record, description_record, {work_area=} NIL,
                  field_value, type_specification, default_value, descriptive_text, utility_information,
                  status);
            IF NOT status.normal THEN
              EXIT /prevalidate/;
            IFEND;

{ Verify that the user is valid to run at the specified ring.

            IF validation_attributes^ [item_index].job_execution_ring < field_value.minimum_ring^ THEN
              osp$set_status_abnormal ('AV', ave$bad_ring, '', status);
              EXIT /prevalidate/;
            IFEND;

{ Validate the specified job limit.

          = avc$job_limit_key =

{ Save the specified job limit for later validation.

            IF limit_item_list = NIL THEN
              PUSH current_limit_item;
              limit_item_list := current_limit_item;
            ELSE
              PUSH current_limit_item^.forward;
              current_limit_item := current_limit_item^.forward;
            IFEND;
            current_limit_item^.limit_name := validation_attributes^ [item_index].limit_name;
            current_limit_item^.user_specified := validation_attributes^ [item_index].user_specified;
            current_limit_item^.job_maximum_limit := validation_attributes^ [item_index].job_maximum;
            current_limit_item^.forward := NIL;

{ Validate the specified password.

          = avc$password_key =

{ Don't allow login to the $SYSTEM user.

            IF user_name = jmc$system_user THEN

{ Set the status we want to exit with.

              osp$set_status_condition (ave$bad_user_validation_info, status);
              emit_invalid_access_statistic (family_name, user_name, terminal_name_p);
              EXIT /prevalidate/;
            IFEND;

{ Retrieve the user's login password value.

            avp$get_field (avc$login_password, data_record, description_record, {work_area=} NIL, field_value,
                  type_specification, default_value, descriptive_text, utility_information, status);
            IF NOT status.normal THEN
              EXIT /prevalidate/;
            IFEND;

{ Encrypt the specified login password value.

            login_password.encrypted := TRUE;
            avp$encrypt_password (user_name, validation_attributes^ [item_index].password,
                  login_password.value, status);
            IF NOT status.normal THEN
              EXIT /prevalidate/;
            IFEND;

{ Verify the specfied login password value.

            IF field_value.login_password^.value <> login_password.value THEN
              temp_password := login_password.value;
              avp$old_encrypt_password (user_name, validation_attributes^ [item_index].password,
                    login_password.value, status);
              IF NOT status.normal THEN
                EXIT /prevalidate/;
              IFEND;
              IF field_value.login_password^.value <> login_password.value THEN

{ Set the status we want to exit with.

                osp$set_status_condition (ave$bad_user_validation_info, status);
                emit_invalid_access_statistic (family_name, user_name, terminal_name_p);
                avp$get_field (avc$invalid_login_attempts, data_record, description_record,
                      { work_area = } NIL, field_value, type_specification, default_value, descriptive_text,
                      utility_information, local_status);
                IF NOT local_status.normal THEN
                  EXIT /prevalidate/;
                IFEND;
                IF (type_specification.kind = avc$accumulating_limit_kind) THEN
                  PUSH field_value_list;
                  field_value_list^.forward := NIL;
                  field_value_list^.field_name := avc$invalid_login_attempts;
                  field_value_list^.field_value := field_value;
                  field_value_list^.field_value.total_accumulation^ := field_value.total_accumulation^ + 1;
                  avp$rewrite_data_record (key.value, { automatically_unlock = } TRUE, data_record,
                        description_record, field_value_list, file_information, ignore_status);
                IFEND;
                EXIT /prevalidate/;
              ELSE

{ Save the current password value encrypted with the current algorithm on the validation file.

                PUSH field_value_list;
                field_value_list^.forward := NIL;
                field_value_list^.field_name := avc$login_password;
                field_value_list^.field_value := field_value;
                field_value_list^.field_value.login_password^.value := temp_password;
                avp$rewrite_data_record (key.value, { automatically_unlock = } FALSE, data_record,
                      description_record, field_value_list, file_information, status);
                IF NOT status.normal THEN
                  EXIT /prevalidate/;
                IFEND;
              IFEND;
            IFEND;

{ Validate the specified required capability.

          = avc$required_capability_key =

{ Retrieve the specified capability.

            avp$get_field (validation_attributes^ [item_index].required_capability, data_record,
                  description_record, {work_area=} NIL, field_value, type_specification, default_value,
                  descriptive_text, utility_information, status);
            IF NOT status.normal THEN
              EXIT /prevalidate/;
            IFEND;

{ Verify that the user has the specified required capability.

            IF NOT field_value.capability^ THEN
              osp$set_status_abnormal ('AV', ave$missing_required_capability,
                    validation_attributes^ [item_index].required_capability, status);
              EXIT /prevalidate/;
            IFEND;

{ Verify the unix username matches.

          = avc$unix_username_key =
            avp$get_field (avc$unix_user_name, data_record, description_record, {work_area=} NIL, field_value,
                  type_specification, default_value, descriptive_text, utility_information, status);
            IF NOT status.normal THEN
              EXIT /prevalidate/;
            IFEND;

            IF field_value.kind <> avc$string_kind THEN
              osp$set_status_abnormal ('AV', ave$incorrect_kind, avc$unix_user_name, status);
              EXIT /prevalidate/;
            IFEND;

            #TRANSLATE (osv$upper_to_lower, field_value.string_value^, unix_username);
            IF unix_username = '$translate' THEN
              #TRANSLATE (osv$upper_to_lower, user_name, unix_username);
            ELSE
              unix_username := field_value.string_value^;
            IFEND;
            IF validation_attributes^ [item_index].unix_username <> unix_username THEN
              osp$set_status_condition (ave$bad_user_validation_info, status);
              EXIT /prevalidate/;
            IFEND;

          = avc$terminal_name =
            terminal_name_p := ^validation_attributes^ [item_index].terminal_name;
          ELSE
            ;
          CASEND;
        FOREND;
      IFEND;

{ Limit Checking

{ Retrieve a list of all accumulating limit and limit type fields from the user record.

      PUSH limit_field_names: [1 .. avc$maximum_field_count];
      avp$get_field_names ($avt$field_kind_set [avc$accumulating_limit_kind, avc$limit_kind], FALSE,
            description_record, limit_field_names^, field_count, status);
      IF NOT status.normal THEN
        EXIT /prevalidate/;
      IFEND;

{ Check each user limit.

      FOR index := 1 TO field_count DO
        avp$get_field (limit_field_names^ [index], data_record, description_record, {work_area=} NIL,
              field_value, type_specification, default_value, descriptive_text, utility_information, status);
        IF NOT status.normal THEN
          EXIT /prevalidate/;
        IFEND;

{ Verify that the total limit has not been exceeded.

        IF ((type_specification.kind = avc$accumulating_limit_kind) AND
              (type_specification.total_limit_applies^) AND (type_specification.total_limit_stops_login^) AND
              (field_value.total_limit^ <> sfc$unlimited) AND (field_value.total_accumulation^ >=
              field_value.total_limit^)) THEN
          osp$set_status_condition (ave$bad_user_validation_info, status);
          EXIT /prevalidate/;
        IFEND;

{ Determine the job maximum limit.

        IF (((type_specification.kind = avc$limit_kind) AND (field_value.limit_value^ <> sfc$unlimited)) OR
              ((type_specification.kind = avc$accumulating_limit_kind) AND
              (type_specification.job_limits_apply^) AND (field_value.job_maximum_limit^ <> sfc$unlimited)))
              THEN
          IF (type_specification.kind = avc$accumulating_limit_kind) THEN
            job_maximum := field_value.job_maximum_limit^;
            IF ((type_specification.total_limit_applies^) AND
                  (type_specification.total_limit_stops_login^) AND
                  (field_value.total_limit^ <> sfc$unlimited)) THEN
              IF ((field_value.total_limit^) - (field_value.total_accumulation^)) < job_maximum THEN
                job_maximum := ((field_value.total_limit^) - (field_value.total_accumulation^));
              IFEND;
            IFEND;
          ELSE
            job_maximum := field_value.limit_value^;
          IFEND;

          current_limit_item := limit_item_list;

{ Check to see if the user has specified a job maximum for this limit.

        /find_specified_job_maximum/
          WHILE current_limit_item <> NIL DO

{ The user may not specify a job maximum that is greater than he is validated for.

            local_limit_name := type_specification.limit_name^;
            IF local_limit_name = avc$cp_time_limit_name THEN
              local_limit_name := avc$cpu_time_limit_name;
            IFEND;
            IF current_limit_item^.limit_name = local_limit_name THEN
              IF ((current_limit_item^.user_specified) AND (job_maximum <
                    current_limit_item^.job_maximum_limit)) THEN
                osp$set_status_abnormal ('AV', ave$bad_user_specified_job_max, local_limit_name,  status);
                EXIT /prevalidate/;

{ If the job maximum specified is less than current reset it.

              ELSEIF job_maximum < current_limit_item^.job_maximum_limit THEN
                current_limit_item^.job_maximum_limit := job_maximum;
              IFEND;
              EXIT /find_specified_job_maximum/;
            ELSE
              current_limit_item := current_limit_item^.forward;
            IFEND;
          WHILEND /find_specified_job_maximum/;

{ If the user did not specify a job maximum for this limit then create an entry
{ in the job limit chain so that the job maximum limit can be found for return
{ to the caller if requested.

          IF current_limit_item = NIL THEN
            PUSH current_limit_item;
            current_limit_item^.limit_name := type_specification.limit_name^;
            IF current_limit_item^.limit_name = avc$cp_time_limit_name THEN
              current_limit_item^.limit_name := avc$cpu_time_limit_name;
            IFEND;
            current_limit_item^.user_specified := FALSE;
            current_limit_item^.job_maximum_limit := job_maximum;
            current_limit_item^.forward := limit_item_list;
            limit_item_list := current_limit_item;
          IFEND;
        IFEND;
      FOREND;

{ Retrieve requested validation items for return to caller.

      IF default_attributes <> NIL THEN
        FOR item_index := 1 TO UPPERBOUND (default_attributes^) DO
          CASE default_attributes^ [item_index].key OF

{ Return the requested default batch and interactive job class for the user.

          = avc$job_class_defaults_key =

{ Retrieve the user's job class validation values.

            avp$get_field (avc$job_class, data_record, description_record, {work_area=} NIL, field_value,
                  type_specification, default_value, descriptive_text, utility_information, status);
            IF NOT status.normal THEN
              EXIT /prevalidate/;
            IFEND;
            default_attributes^ [item_index].batch_job_class_default := field_value.batch_job_class_default^;
            default_attributes^ [item_index].interactive_job_class_default :=
                  field_value.interactive_job_class_default^;

{ Return the requested limit values for the user.

          = avc$job_limit_key =

{ Search the previously built job limit chain for the limit value to return.

            current_limit_item := limit_item_list;

          /find_limit_to_return/
            WHILE current_limit_item <> NIL DO

              IF current_limit_item^.limit_name = default_attributes^ [item_index].limit_name THEN
                default_attributes^ [item_index].user_specified := current_limit_item^.user_specified;
                default_attributes^ [item_index].job_maximum := current_limit_item^.job_maximum_limit;
                EXIT /find_limit_to_return/;
              ELSE
                current_limit_item := current_limit_item^.forward;
              IFEND;
            WHILEND /find_limit_to_return/;
            IF current_limit_item = NIL THEN
              default_attributes^ [item_index].user_specified := FALSE;
              default_attributes^ [item_index].job_maximum := sfc$unlimited;
            IFEND;

{ Return the requested labeled names value for the user.

          = avc$labeled_names_key =

            avp$get_field (default_attributes^ [item_index].labeled_names_field, data_record,
                  description_record, default_attributes^ [item_index].work_area, field_value,
                  type_specification, default_value, descriptive_text, utility_information, status);
            IF NOT status.normal THEN
              EXIT /prevalidate/;
            IFEND;
            default_attributes^ [item_index].labeled_names := field_value.labeled_names;

{ Return the requested capability value for the user.

          = avc$optional_capability_key =

{ If the user has the requested capability then the capability name is returned.
{ If the user does not have the requested capability then a null capability name is returned.

            avp$get_field (default_attributes^ [item_index].optional_capability, data_record,
                  description_record, {work_area=} NIL, field_value, type_specification, default_value,
                  descriptive_text, utility_information, status);
            IF NOT status.normal THEN
              EXIT /prevalidate/;
            IFEND;
            IF field_value.capability^ <> TRUE THEN
              default_attributes^ [item_index].optional_capability := osc$null_name;
            IFEND;

{ Return the requested encrypted password value for the user.

          = avc$password_key =

{ Retrieve the encrypted login password value for the user.

            avp$get_field (avc$login_password, data_record, description_record, {work_area=} NIL, field_value,
                  type_specification, default_value, descriptive_text, utility_information, status);
            IF NOT status.normal THEN
              EXIT /prevalidate/;
            IFEND;
            default_attributes^ [item_index].password := field_value.login_password^.value;

{ Return the requested list of valid job classes for the user.

          = avc$valid_job_classes_key =

{ Retrieve the valid job classes for the user.

            avp$get_field (avc$job_class, data_record, description_record, {work_area=} NIL, field_value,
                  type_specification, default_value, descriptive_text, utility_information, status);
            IF NOT status.normal THEN
              EXIT /prevalidate/;
            IFEND;

{ Copy as many entries from the list of valid job classes to the specified
{ array that will fit.  The count of job classes is always the number that
{ exists on the validation file not the number that was returned.

          /process_valid_job_classes/
            FOR index := 1 TO UPPERBOUND (field_value.job_classes^) DO
              IF index <= UPPERBOUND (default_attributes^ [item_index].job_classes^) THEN
                default_attributes^ [item_index].job_classes^ [index] := field_value.job_classes^ [index];
              ELSE
                EXIT /process_valid_job_classes/;
              IFEND;
            FOREND /process_valid_job_classes/;
            default_attributes^ [item_index].count := UPPERBOUND (field_value.job_classes^);

          ELSE
            ;
          CASEND;
        FOREND;
      IFEND;

    END /prevalidate/;
    avp$unlock_template_file (file_information, ignore_status);
    osp$disestablish_cond_handler;

{ Emit the audit statistic.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_information.audited_operation := sfc$ao_val_prevalidate_user;
      audit_information.prevalidate_user.family_name_p := ^family_name;
      audit_information.prevalidate_user.user_name_p := ^user_name;
      audit_information.prevalidate_user.account_name_p := ^account_name;
      audit_information.prevalidate_user.project_name_p := ^project_name;
      audit_information.prevalidate_user.terminal_name_p := terminal_name_p;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;

    avp$close_template_file (file_information, ignore_status);

  PROCEND prevalidate_job;
?? TITLE := '    read_account_member_record', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used by the create, change, and display account member
{ record interfaces to store an account member record for later processing
{ by those interfaces.
{

  PROCEDURE read_account_member_record
    (    caller_id: ost$caller_identifier;
     VAR account_name: avt$account_name;
     VAR user_name: ost$user_name;
     VAR validation_record_info: ^avt$validation_record_info;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      ignore_status: ost$status,
      key: avt$validation_key;

    status.normal := TRUE;

    validation_record_info := NIL;

{ If the user name specified is a blank name then seqentially access the next
{ account member record.

    IF user_name <> osc$null_name THEN
      key.account_name := account_name;
      key.project_name := osc$null_name;
      key.user_name := user_name;
    ELSE
      key.value := ' ';
    IFEND;

    determine_caller_authority (caller_id, ^account_name, NIL, NIL, NIL, NIL, caller_authority);

  /read_account_member/
    BEGIN
      read_validation_record (avc$account_member_record_name, key, validation_record_info, file_information,
            status);
      IF NOT status.normal THEN
        IF status.condition = ave$unknown_record THEN
          IF caller_authority < avc$account_admin_authority THEN
            osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
          ELSE
            osp$set_status_abnormal ('AV', ave$acct_member_does_not_exist, user_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, account_name, status);
          IFEND;
        IFEND;
        EXIT /read_account_member/;
      IFEND;
      account_name := key.account_name;
      user_name := key.user_name;
      validation_record_info^.caller_authority := caller_authority;

{ Verify that the caller has the required authority.

      IF caller_authority < avc$account_admin_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /read_account_member/;
      IFEND;

    END /read_account_member/;

    IF (NOT status.normal) AND (validation_record_info <> NIL) THEN
      avp$release_record_id (validation_record_info^.record_id, ignore_status);
    IFEND;

  PROCEND read_account_member_record;
?? TITLE := '    read_account_record', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used by the create, change, and display account
{ record interfaces to store an account record for later processing
{ by those interfaces.
{

  PROCEDURE read_account_record
    (    caller_id: ost$caller_identifier;
     VAR account_name: avt$account_name;
     VAR validation_record_info: ^avt$validation_record_info;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      ignore_status: ost$status,
      key: avt$validation_key;

    status.normal := TRUE;

    validation_record_info := NIL;

{ If the account name specified is a blank name then seqentially access the next
{ account record.

    IF account_name <> osc$null_name THEN
      key.account_name := account_name;
      key.project_name := osc$null_name;
      key.user_name := osc$null_name;
    ELSE
      key.value := ' ';
    IFEND;

    determine_caller_authority (caller_id, ^account_name, NIL, NIL, NIL, NIL, caller_authority);

  /read_account/
    BEGIN
      read_validation_record (avc$account_record_name, key, validation_record_info, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$unknown_record THEN
          IF caller_authority < avc$account_admin_authority THEN
            osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
          ELSE
            osp$set_status_abnormal ('AV', ave$account_does_not_exist, account_name, status);
          IFEND;
        IFEND;
        EXIT /read_account/;
      IFEND;
      account_name := key.account_name;
      validation_record_info^.caller_authority := caller_authority;

{ Verify that the caller has the required authority.

      IF caller_authority < avc$account_admin_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /read_account/;
      IFEND;

    END /read_account/;

    IF (NOT status.normal) AND (validation_record_info <> NIL) THEN
      avp$release_record_id (validation_record_info^.record_id, ignore_status);
    IFEND;

  PROCEND read_account_record;
?? TITLE := '    read_project_member_record', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used by the create, change, and display project member
{ record interfaces to store a project member record for later processing
{ by those interfaces.
{

  PROCEDURE read_project_member_record
    (    caller_id: ost$caller_identifier;
     VAR account_name: avt$account_name;
     VAR project_name: avt$project_name;
     VAR user_name: ost$user_name;
     VAR validation_record_info: ^avt$validation_record_info;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      ignore_status: ost$status,
      key: avt$validation_key;

    status.normal := TRUE;

    validation_record_info := NIL;

{ If the user name specified is a blank name then seqentially access the next
{ project member record.

    IF user_name <> osc$null_name THEN
      key.account_name := account_name;
      key.project_name := project_name;
      key.user_name := user_name;
    ELSE
      key.value := ' ';
    IFEND;

    determine_caller_authority (caller_id, ^account_name, ^project_name, NIL, NIL, NIL, caller_authority);

  /read_project_member/
    BEGIN
      read_validation_record (avc$project_member_record_name, key, validation_record_info, file_information,
            status);
      IF NOT status.normal THEN
        IF status.condition = ave$unknown_record THEN
          IF caller_authority < avc$project_admin_authority THEN
            osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
          ELSE
            osp$set_status_abnormal ('AV', ave$proj_member_does_not_exist, user_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, project_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, account_name, status);
          IFEND;
        IFEND;
        EXIT /read_project_member/;
      IFEND;
      account_name := key.account_name;
      project_name := key.project_name;
      user_name := key.user_name;
      validation_record_info^.caller_authority := caller_authority;

{ Verify that the caller has the required authority.

      IF caller_authority < avc$project_admin_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /read_project_member/;
      IFEND;

    END /read_project_member/;

    IF (NOT status.normal) AND (validation_record_info <> NIL) THEN
      avp$release_record_id (validation_record_info^.record_id, ignore_status);
    IFEND;

  PROCEND read_project_member_record;
?? TITLE := '    read_project_record', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used by the create, change, and display project
{ record interfaces to store a project record for later processing
{ by those interfaces.
{

  PROCEDURE read_project_record
    (    caller_id: ost$caller_identifier;
     VAR account_name: avt$account_name;
     VAR project_name: avt$project_name;
     VAR validation_record_info: ^avt$validation_record_info;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      caller_authority: avt$validation_authority,
      ignore_status: ost$status,
      key: avt$validation_key;

    status.normal := TRUE;

    validation_record_info := NIL;

{ If the project name specified is a blank name then seqentially access the next
{ project record.

    IF project_name <> osc$null_name THEN
      key.account_name := account_name;
      key.project_name := project_name;
      key.user_name := osc$null_name;
    ELSE
      key.value := ' ';
    IFEND;

    determine_caller_authority (caller_id, ^account_name, ^project_name, NIL, NIL, NIL, caller_authority);

  /read_project/
    BEGIN
      read_validation_record (avc$project_record_name, key, validation_record_info, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$unknown_record THEN
          IF caller_authority < avc$project_admin_authority THEN
            osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
          ELSE
            osp$set_status_abnormal ('AV', ave$project_does_not_exist, project_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, account_name, status);
          IFEND;
        IFEND;
        EXIT /read_project/;
      IFEND;
      account_name := key.account_name;
      project_name := key.project_name;
      validation_record_info^.caller_authority := caller_authority;

{ Verify that the caller has the required authority.

      IF caller_authority < avc$project_admin_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /read_project/;
      IFEND;

    END /read_project/;

    IF (NOT status.normal) AND (validation_record_info <> NIL) THEN
      avp$release_record_id (validation_record_info^.record_id, ignore_status);
    IFEND;

  PROCEND read_project_record;
?? TITLE := '    read_user_record', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used by the create, change, and display project
{ record interfaces to read a user record and store it for processing
{ by those interfaces.
{

  PROCEDURE read_user_record
    (    caller_id: ost$caller_identifier;
     VAR user_name: ost$user_name;
     VAR validation_record_info: ^avt$validation_record_info;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      default_value: avt$field_value,
      descriptive_text: ^avt$descriptive_text,
      field_value: avt$field_value,
      ignore_status: ost$status,
      key: avt$validation_key,
      type_specification: avt$type_specification,
      user_identification: ost$user_identification,
      utility_information: ^avt$utility_information;

    status.normal := TRUE;

    validation_record_info := NIL;

{ If the user name specified is a blank name then seqentially access the next
{ user record.

    IF user_name <> osc$null_name THEN
      key.account_name := avc$high_value_name;
      key.project_name := avc$high_value_name;
      key.user_name := user_name;
    ELSE
      key.value := ' ';
    IFEND;

  /read_user/
    BEGIN
      read_validation_record (avc$user_record_name, key, validation_record_info, file_information, status);
      IF NOT status.normal THEN
        IF status.condition = ave$unknown_record THEN
          IF avp$system_administrator () OR avp$family_administrator () THEN
            osp$set_status_abnormal ('AV', ave$user_does_not_exist, user_name, status);
          ELSE
            osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
          IFEND;
        IFEND;
        EXIT /read_user/;
      IFEND;
      user_name := key.user_name;

      avp$get_field (avc$creation_account_project, validation_record_info^.data_record,
            validation_record_info^.description_record, validation_record_info^.work_area.sequence_pointer,
            field_value, type_specification, default_value, descriptive_text, utility_information, status);
      IF NOT status.normal THEN
        EXIT /read_user/;
      IFEND;

{ Verify that the caller has the required authority.

      determine_caller_authority (caller_id, NIL, NIL, ^key.user_name, field_value.account_name,
            field_value.project_name, validation_record_info^.caller_authority);
      IF validation_record_info^.caller_authority < avc$user_authority THEN
        osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
        EXIT /read_user/;
      IFEND;

      IF validation_record_info^.caller_authority < avc$system_admin_authority THEN
        pmp$get_user_identification (user_identification, status);
        IF NOT status.normal THEN
          EXIT /read_user/;
        IFEND;

{ If the user is not reading his own user validation record, make sure he is not reading someone with more
{ authority.

        IF user_identification.user <> key.user_name THEN
          avp$get_field (avc$system_administration, validation_record_info^.data_record,
              validation_record_info^.description_record, validation_record_info^.work_area.sequence_pointer,
              field_value, type_specification, default_value, descriptive_text, utility_information, status);
          IF NOT status.normal THEN
            EXIT /read_user/;
          IFEND;

          IF field_value.capability^ THEN
            osp$set_status_abnormal ('AV', ave$insufficient_authority, '', status);
            EXIT /read_user/;
          IFEND;
        IFEND;
      IFEND;

    END /read_user/;

    IF (NOT status.normal) AND (validation_record_info <> NIL) THEN
      avp$release_record_id (validation_record_info^.record_id, ignore_status);
    IFEND;

  PROCEND read_user_record;
?? TITLE := '    read_validation_record', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used by the previous read record procedures to
{ perform common routines needed to store a validation record for
{ later access by separate validation interfaces.
{

  PROCEDURE read_validation_record
    (    validation_record_name: ost$name;
     VAR key: avt$validation_key;
     VAR validation_record_info: ^avt$validation_record_info;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

    VAR
      data_record: ^avt$template_file_record,
      data_record_size: 0 .. avc$max_template_record_size,
      description_record: ^avt$template_file_record,
      description_record_size: 0 .. avc$max_template_record_size,
      description_record_name: ost$name,
      field_count: avt$field_count,
      ignore_status: ost$status,
      temp_data_record: ^avt$template_file_record,
      temp_description_record: ^avt$template_file_record;

    status.normal := TRUE;
    description_record := NIL;
    data_record := NIL;
    validation_record_info := NIL;

{ Allocate a work area to hold the a maximum sized data and description record.

    PUSH temp_data_record: [[REP avc$max_template_record_size OF cell]];
    RESET temp_data_record;
    PUSH temp_description_record: [[REP avc$max_template_record_size OF cell]];
    RESET temp_description_record;

  /read_record/
    BEGIN
      IF key.value <> ' ' THEN

{ Read the specified validation record.

        avp$read_data_record (key.value, avc$read_access, TRUE, temp_data_record, data_record_size,
              temp_description_record, description_record_size, description_record_name, field_count,
              file_information, status);
        IF NOT status.normal THEN
          EXIT /read_record/;
        IFEND;

      ELSE

{ If a null key is specified sequentially read the next validation record,
{ of the type requested.

        REPEAT
          RESET temp_data_record;
          RESET temp_description_record;
          avp$read_next_data_record (avc$read_access, TRUE, key.value, temp_data_record,
                temp_description_record, description_record_name, field_count, file_information, status);
        UNTIL (NOT status.normal) OR (description_record_name = validation_record_name);
        IF NOT status.normal THEN
          EXIT /read_record/;
        IFEND;
      IFEND;

{ Allocate space to hold the validation record read.

      data_record_size := i#current_sequence_position (temp_data_record);
      description_record_size := i#current_sequence_position (temp_description_record);
      ALLOCATE data_record: [[REP data_record_size OF cell]] IN osv$task_private_heap^;
      RESET data_record;
      ALLOCATE description_record: [[REP description_record_size OF cell]] IN osv$task_private_heap^;
      RESET description_record;
      i#move (temp_data_record, data_record, data_record_size);
      i#move (temp_description_record, description_record, description_record_size);

{ Allocate a new validation record information entry in task private.

      ALLOCATE validation_record_info IN osv$task_private_heap^;

{ Assign a record identifier for the validation record information entry.

      pmp$get_unique_name (validation_record_info^.record_id, status);
      IF NOT status.normal THEN
        EXIT /read_record/;
      IFEND;

{ Initialize the validation record information entry.

      validation_record_info^.work_area.sequence_pointer := NIL;
      validation_record_info^.key := key;
      validation_record_info^.description_record_name := description_record_name;
      validation_record_info^.data_record := data_record;
      validation_record_info^.description_record := description_record;
      validation_record_info^.caller_authority := avc$any_authority;
      validation_record_info^.field_value_list := NIL;

{ Put the validation record information entry in the front of the chain.

      validation_record_info^.backward := NIL;
      validation_record_info^.forward := avv$validation_record_info;
      IF validation_record_info^.forward <> NIL THEN
        validation_record_info^.forward^.backward := validation_record_info;
      IFEND;
      avv$validation_record_info := validation_record_info;
    END /read_record/;

    IF NOT status.normal THEN
      IF validation_record_info <> NIL THEN
        FREE validation_record_info IN osv$task_private_heap^;
      IFEND;
    IFEND;

  PROCEND read_validation_record;
?? TITLE := '    sort_record_utility_info', EJECT ??
{
{ PURPOSE:
{
{   This procedure sorts the command table information within the record utility
{ information.
{

  PROCEDURE sort_record_utility_information
    (VAR record_utility_information: ^avt$utility_information;
     VAR utility_information: ^avt$utility_information;
     VAR status: ost$status);

    VAR
      index: 1 .. avc$maximum_field_count,
      record_utility_info_header: ^avt$record_utility_info_header,
      record_utility_info_array: ^array [1 .. * ] of avt$record_utility_info_entry,
      swapped_entries: boolean,
      temporary_directory_entry: avt$record_utility_info_entry;

    status.normal := TRUE;

{ Retrieve the header information from the record utility information.

    RESET record_utility_information;
    NEXT record_utility_info_header IN record_utility_information;
    IF record_utility_info_header = NIL THEN
      corrupted_sequence ('SORT_RECORD_UTILITY_INFO', 'HEADER', 'RECORD_UTILITY_INFORMATION', status);
      RETURN;
    IFEND;

{ Retrieve the command table information from the record utility information.

    NEXT record_utility_info_array: [1 .. record_utility_info_header^.number_of_entries] IN
          record_utility_information;
    IF record_utility_info_array = NIL THEN
      corrupted_sequence ('SORT_RECORD_UTILITY_INFO', 'COMMAND_TABLE', 'RECORD_UTILITY_INFORMATION', status);
      RETURN;
    IFEND;

{ Sort the command table entries.

    REPEAT
      swapped_entries := FALSE;
      FOR index := 1 TO UPPERBOUND (record_utility_info_array^) - 1 DO
        IF record_utility_info_array^ [index].command_table_entry.name >
              record_utility_info_array^ [index + 1].command_table_entry.name THEN
          temporary_directory_entry := record_utility_info_array^ [index];
          record_utility_info_array^ [index] := record_utility_info_array^ [index + 1];
          record_utility_info_array^ [index + 1] := temporary_directory_entry;
          swapped_entries := TRUE;
        ELSEIF record_utility_info_array^ [index].command_table_entry.name =
              record_utility_info_array^ [index + 1].command_table_entry.name THEN
          osp$set_status_abnormal ('AV', ave$cmd_already_in_cmd_table,
                record_utility_info_array^ [index].command_table_entry.name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                record_utility_info_array^ [index].field_name, status);
          RETURN;
        IFEND;
      FOREND;

    UNTIL NOT swapped_entries;

{ Return a pointer to a sequence containing the record utility infomation
{ of the exact size.

    RESET record_utility_information;
    NEXT utility_information: [[REP 1 OF avt$record_utility_info_header,
          REP record_utility_info_header^.number_of_entries OF avt$record_utility_info_entry]] IN
          record_utility_information;
    IF utility_information = NIL THEN
      corrupted_sequence ('SORT_RECORD_UTILITY_INFO', 'UTILITY_INFO', 'RECORD_UTILITY_INFORMATION', status);
      RETURN;
    IFEND;
    RESET utility_information;

  PROCEND sort_record_utility_information;

?? TITLE := '    validate_job_class', EJECT ??
{
{ PURPOSE:
{
{   This procedure is used to verify that a user is valid to access a
{ specified job class.
{

  PROCEDURE validate_job_class
    (    field_value: avt$field_value;
         job_class_name: jmt$job_class_name;
     VAR found_job_class: boolean);

    VAR
      index: integer;

    found_job_class := FALSE;

{ If the list contains NONE then no job classes can be valid.

    IF (field_value.job_classes^ [1] <> 'NONE') THEN

{ If the list contains ALL then any job class will be valid.

      IF field_value.job_classes^ [1] = 'ALL' THEN
        found_job_class := TRUE;
      ELSE

{ Else search for the specified job class.

      /find_job_class/
        FOR index := 1 TO UPPERBOUND (field_value.job_classes^) DO
          IF field_value.job_classes^ [index] = job_class_name THEN
            found_job_class := TRUE;
            EXIT /find_job_class/;
          IFEND;
        FOREND /find_job_class/;
      IFEND;
    IFEND;

  PROCEND validate_job_class;
?? TITLE := '    verify_acct_proj_membership', EJECT ??
    PROCEDURE verify_acct_proj_membership
      (    validation_level: avt$validation_level;
           account: avt$account_name;
           project: avt$project_name;
           user: ost$user_name;
       VAR valid_account: boolean;
       VAR valid_project: boolean;
       VAR valid_member: boolean;
       VAR file_information: avt$template_file_information;
       VAR status: ost$status);

      VAR
        validation_key: avt$validation_key;

      status.normal := TRUE;

      valid_member := TRUE;
      valid_account := TRUE;
      valid_project := TRUE;

      IF validation_level = avc$account_level THEN

{ Check for specific account member record.

        validation_key.account_name := account;
        validation_key.project_name := osc$null_name;
        validation_key.user_name := user;
        avp$determine_if_key_exists (validation_key.value, valid_member, file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ If not a member of the account, check if the account exists.

        IF NOT valid_member THEN
          validation_key.account_name := account;
          validation_key.project_name := osc$null_name;
          validation_key.user_name := osc$null_name;
          avp$determine_if_key_exists (validation_key.value, valid_account, file_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

{ If the account exists and the user is not a member, check for a public account.

        IF valid_account AND (NOT valid_member) THEN
          validation_key.account_name := account;
          validation_key.project_name := osc$null_name;
          validation_key.user_name := 'PUBLIC';
          avp$determine_if_key_exists (validation_key.value, valid_member, file_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      ELSEIF validation_level = avc$project_level THEN

{ Check for specific project member record.

        validation_key.account_name := account;
        validation_key.project_name := project;
        validation_key.user_name := user;
        avp$determine_if_key_exists (validation_key.value, valid_member, file_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ If no specific project member record is found, check if the project exists.

        IF NOT valid_member THEN
          validation_key.account_name := account;
          validation_key.project_name := project;
          validation_key.user_name := osc$null_name;
          avp$determine_if_key_exists (validation_key.value, valid_project, file_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

{ If the project does not exist, check if the account exists.

        IF NOT valid_project THEN
          validation_key.account_name := account;
          validation_key.project_name := osc$null_name;
          validation_key.user_name := osc$null_name;
          avp$determine_if_key_exists (validation_key.value, valid_account, file_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

{ If the project exists and the user is not a project member, continue checking.

        IF valid_project AND (NOT valid_member) THEN

{ Check for a specific account member record.

          IF NOT valid_member THEN
            validation_key.account_name := account;
            validation_key.project_name := osc$null_name;
            validation_key.user_name := user;
            avp$determine_if_key_exists (validation_key.value, valid_member, file_information, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

{ If not a specific account member, check for a public project.

          IF NOT valid_member THEN
            validation_key.account_name := account;
            validation_key.project_name := project;
            validation_key.user_name := 'PUBLIC';
            avp$determine_if_key_exists (validation_key.value, valid_member, file_information, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

{ If not a public project, check for a public account.

          IF NOT valid_member THEN
            validation_key.account_name := account;
            validation_key.project_name := osc$null_name;
            validation_key.user_name := 'PUBLIC';
            avp$determine_if_key_exists (validation_key.value, valid_member, file_information, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

    PROCEND verify_acct_proj_membership;
?? OLDTITLE ??
?? TITLE := '  Validation Interface Miscellaneous Support Routines' ??
  ?IF avc$compile_test_code THEN
?? NEWTITLE := '    initalize', EJECT ??

    PROCEDURE [XDCL] initialize
      (    validation_level: avt$validation_level;
           system_administrator: boolean;
           family_administrator: boolean;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status,
        jp_segment_pointer: amt$segment_pointer,
        task_shared_file_id: amt$file_identifier,
        task_private_file_id: amt$file_identifier,
        tp_segment_pointer: amt$segment_pointer,
        ts_segment_pointer: amt$segment_pointer;

      status.normal := TRUE;


{  Add/delete system_administrator and family_administration validation from the set of validations.

      IF system_administrator THEN
        avv$active_sou_capabilities := avv$active_sou_capabilities
                                     + $avt$conditional_capabilities [avc$cc_system_admin];
      ELSE
        avv$active_sou_capabilities := avv$active_sou_capabilities
                                     - $avt$conditional_capabilities [avc$cc_system_admin];
      IFEND;

      IF family_administrator THEN
        avv$active_sou_capabilities := avv$active_sou_capabilities
                                     + $avt$conditional_capabilities [avc$cc_family_admin];
      ELSE
        avv$active_sou_capabilities := avv$active_sou_capabilities
                                     - $avt$conditional_capabilities [avc$cc_family_admin];
      IFEND;

      avv$validation_level := $INTEGER (validation_level);

      mmp$create_scratch_segment (amc$heap_pointer, mmc$as_random, ts_segment_pointer, status);
      IF status.normal THEN
        RESET ts_segment_pointer.heap_pointer^;
        osv$task_shared_heap := ts_segment_pointer.heap_pointer;
        mmp$create_scratch_segment (amc$heap_pointer, mmc$as_random, tp_segment_pointer, status);
        IF status.normal THEN
          RESET tp_segment_pointer.heap_pointer^;
          osv$task_private_heap := tp_segment_pointer.heap_pointer;
          mmp$create_scratch_segment (amc$heap_pointer, mmc$as_random, jp_segment_pointer, status);
          IF status.normal THEN
            RESET jp_segment_pointer.heap_pointer^;
            osv$job_pageable_heap := jp_segment_pointer.heap_pointer;
          ELSE
            mmp$delete_scratch_segment (tp_segment_pointer, ignore_status);
            mmp$delete_scratch_segment (ts_segment_pointer, ignore_status);
          IFEND;
        ELSE
          mmp$delete_scratch_segment (ts_segment_pointer, ignore_status);
        IFEND;
      IFEND;

    PROCEND initialize;
?? OLDTITLE ??
  ?IFEND

MODEND avm$validation_interfaces;
*DECK DECK=AVM$VERIFY_VALIDATION_NAME EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Accounting and Validation: Verify Validation Name' ??
MODULE avm$verify_validation_name;

{ PURPOSE:
{   This module contains the procedure used to verify that a name specified for
{   a user, account, or project when creating validation records, is a name
{   that is allowed by the site.

?? NEWTITLE := 'Global declarations referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ave$admin_validations_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc avt$validation_name
*copyc ost$user_identification
?? POP ??
*copyc avp$family_administrator
*copyc avp$get_capability
*copyc avp$system_administrator
*copyc clp$trimmed_string_size
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] avp$verify_validation_name', EJECT ??
*copyc avh$verify_validation_name

  PROCEDURE [XDCL, #GATE] avp$verify_validation_name
    (    validation_name: avt$validation_name;
     VAR status: ost$status);

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

    PROCEDURE verify_account_name
      (    account_name: avt$account_name;
       VAR status: ost$status);

      status.normal := TRUE;

{ This is an example of code that allows a system administrator to specify any account name and any other user
{ to only specify account names that are seven characters or less.

{     IF (NOT avp$system_administrator ()) AND (clp$trimmed_string_size (account_name) > 7) THEN
{       osp$set_status_abnormal ('AV', ave$name_not_allowed, account_name, status);
{       osp$append_status_parameter (osc$status_parameter_delimiter, 'ACCOUNT', status);
{     IFEND;

      IF ((account_name = 'ALL') OR (account_name = 'NONE') OR (account_name = 'DEFAULT') OR
            (account_name = 'PUBLIC')) THEN
        osp$set_status_abnormal ('AV', ave$name_not_allowed, account_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'ACCOUNT', status);
      IFEND;

    PROCEND verify_account_name;
?? OLDTITLE ??
?? NEWTITLE := 'verify_project_name', EJECT ??

    PROCEDURE verify_project_name
      (    project_name: avt$project_name;
       VAR status: ost$status);

      status.normal := TRUE;

{ This is an example of code that allows a system administrator to specify any project name, and any other user
{ to only specify project names that are seven characters or less.

{     IF (NOT avp$system_administrator ()) AND (clp$trimmed_string_size (project_name) > 7) THEN
{       osp$set_status_abnormal ('AV', ave$name_not_allowed, project_name, status);
{       osp$append_status_parameter (osc$status_parameter_delimiter, 'PROJECT', status);
{     IFEND;

      IF ((project_name = 'ALL') OR (project_name = 'NONE') OR (project_name = 'DEFAULT') OR
            (project_name = 'PUBLIC')) THEN
        osp$set_status_abnormal ('AV', ave$name_not_allowed, project_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'PROJECT', status);
      IFEND;

    PROCEND verify_project_name;
?? OLDTITLE ??
?? NEWTITLE := 'verify_user_name', EJECT ??

    PROCEDURE verify_user_name
      (    user_name: ost$user_name;
       VAR status: ost$status);

      status.normal := TRUE;

{ This is an example of code that allows a system administrator to specify any user name, and any other user
{ to only specify user names that are seven characters or less.

{     IF (NOT avp$system_administrator ()) AND (clp$trimmed_string_size (user_name) > 7) THEN
{       osp$set_status_abnormal ('AV', ave$name_not_allowed, user_name, status);
{       osp$append_status_parameter (osc$status_parameter_delimiter, 'USER', status);
{     IFEND;

{ The user name FTAM is reserved.

      IF ((user_name = 'ALL') OR (user_name = 'NONE') OR (user_name = 'DEFAULT') OR
            (user_name = 'FTAM')) THEN
        osp$set_status_abnormal ('AV', ave$name_not_allowed, user_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'USER', status);
      IFEND;

    PROCEND verify_user_name;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    CASE validation_name.kind OF
    = avc$vnk_account =
      verify_account_name (validation_name.account_name, status);
    = avc$vnk_project =
      verify_project_name (validation_name.project_name, status);
    = avc$vnk_user =
      verify_user_name (validation_name.user_name, status);
    ELSE

{ Unknown type of validation name.

    CASEND;

  PROCEND avp$verify_validation_name;
?? OLDTITLE ??
MODEND avm$verify_validation_name;
*DECK DECK=AVP$ACCOUNTING_ADMINISTRATOR EXPAND=FALSE

  FUNCTION [INLINE] avp$accounting_administrator: boolean;

?? PUSH (LISTEXT := ON) ??

{
{   The purpose of this request is to determine if the current job is
{ currently executing with accounting administration capability.
{
{       AVP$ACCOUNTING_ADMINISTRATOR  : ACCOUNTING_ADMINISTRATOR
{
{ ACCOUNTING_ADMINISTRATOR:  (output) This parameter specifies whether or not
{       the current job is currently executing with accounting administration
{       capability.
{

    avp$accounting_administrator := avp$capability_active (
          avc$cc_accounting_admin);

  FUNCEND avp$accounting_administrator;

*copyc avp$capability_active
?? POP ??
*DECK DECK=AVP$ACTIVATE_CAPABILITIES EXPAND=TRUE

  PROCEDURE [XREF] avp$activate_capabilities
    (   capabilities: avt$conditional_capabilities;
        utility: clt$utility_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc avt$conditional_capabilities
*copyc clt$utility_name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$BEGIN_ACCOUNT EXPAND=FALSE

  PROCEDURE [XREF] avp$begin_account
    (    family_name: ost$family_name;
         user_name: ost$user_name;
         account_name: avt$account_name;
         project_name: avt$project_name;
         user_supplied_job_name: ost$name;
         job_class: jmt$job_class;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$account_name
*copyc avt$project_name
*copyc jmt$job_class
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$BEGIN_JOB_ACCOUNT EXPAND=FALSE

  PROCEDURE [XREF] avp$begin_job_account
    (    family_name: ost$family_name;
         user_name: ost$user_name;
         account_name: avt$account_name;
         project_name: avt$project_name;
         user_supplied_job_name: ost$name;
         job_class: jmt$job_class;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$account_name
*copyc avt$project_name
*copyc jmt$job_class
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$BEGIN_PRODUCTION_ENVIRON EXPAND=FALSE

  PROCEDURE [XREF] avp$begin_production_environ
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CALCULATE_APPLICATION_SRUS EXPAND=FALSE
  PROCEDURE [XREF] avp$calculate_application_srus
    (    cpu_time: pmt$task_cp_time;
         paging_statistics: ost$paging_statistics;
     VAR accumulated_srus: sft$counter;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$paging_statistics
*copyc ost$status
*copyc pmt$task_cp_time
*copyc sft$counter
?? POP ??
*DECK DECK=AVP$CALCULATE_SRUS EXPAND=FALSE

  PROCEDURE [XREF] avp$calculate_srus
    (    job_statistics: jmt$job_statistics;
         sru_limit: sft$limit;
     VAR accumulated_srus: sft$counter;
     VAR calculation_interval: avt$sru_calculation_interval;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$sru_calculation_interval
*copyc jmt$job_statistics
*copyc sft$counter
*copyc sft$limit
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CAPABILITY_ACTIVE EXPAND=FALSE

  FUNCTION [XREF, UNSAFE] avp$capability_active
    (   capability: avt$conditional_capability) : boolean;
?? PUSH (LISTEXT := ON) ??
*copyc avt$conditional_capabilities
?? POP ??
*DECK DECK=AVP$CHANGE_ACCOUNT_MEMBER_REC EXPAND=FALSE

  PROCEDURE [XREF] avp$change_account_member_rec
    (    account_name: avt$account_name;
         user_name: ost$user_name;
     VAR record_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$CHANGE_ACCOUNT_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_account_record
    (    account_name: avt$account_name;
     VAR session_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_ACCT_PROJ_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_acct_proj_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         account_name: ^avt$account_name;
         project_name: ^avt$project_name;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$name_list
*copyc avt$project_name
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CHANGE_ACCT_PROJ_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$change_acct_proj_value
    (    field_name: ost$name;
         account_name: ^avt$account_name;
         project_name: ^avt$project_name;
         session_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_ACCUM_LIMIT_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_accum_limit_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         job_warning_limit: ^avt$limit_value;
         job_maximum_limit: ^avt$limit_value;
         total_limit: ^avt$limit_value;
         limit_name: ^ost$name;
         job_limits_apply: ^boolean;
         limit_update_statistics: ^sft$limit_update_statistics;
         minimum_job_limit_value: ^avt$limit_value;
         maximum_job_limit_value: ^avt$limit_value;
         total_limit_applies: ^boolean;
         total_limit_stops_login: ^boolean;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$limit_value
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CHANGE_ACCUM_LIMIT_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$change_accum_limit_value
    (    field_name: ost$name;
         job_warning_limit: ^avt$limit_value;
         job_maximum_limit: ^avt$limit_value;
         total_limit: ^avt$limit_value;
         total_accumulation: ^avt$limit_value;
         session_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avc$validation_field_names
*copyc avt$limit_value
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_CAPABILITY_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_capability_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         capability: ^boolean;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CHANGE_CAPABILITY_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$change_capability_value
    (    field_name: ost$name;
         capability: ^boolean;
         session_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_DATE_TIME_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_date_time_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         date_time: ^avt$date_time;
         date_applies: ^boolean;
         time_applies: ^boolean;
         date_display_format: ^clt$date_time_form_string;
         time_display_format: ^clt$date_time_form_string;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$date_time
*copyc avt$name_list
*copyc clt$date_time_form_string
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CHANGE_DATE_TIME_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$change_date_time_value
    (    field_name: ost$name;
         date_time: ^avt$date_time;
         session_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$date_time
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_DESC_UTILITY_INFO EXPAND=FALSE

  PROCEDURE [XREF] avp$change_desc_utility_info
    (    description_record_name: ost$name;
         utility_information: ^avt$utility_information;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$template_file_information
*copyc avt$utility_information
*copyc ost$name
*copyc ost$status
?? POP ??

*DECK DECK=AVP$CHANGE_FAMILY_INTERFACE EXPAND=FALSE

  PROCEDURE [XREF] avp$change_family_interface
    (    family_name: ost$family_name;
         new_family_name: ost$family_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$user_identification
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_field
    (    field_name: ost$name;
         description_record_name: ost$name;
         type_specification: avt$type_specification;
         default_value: avt$field_value;
         descriptive_text: ^avt$descriptive_text;
         utility_information: ^avt$utility_information;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$descriptive_text
*copyc avt$field_value
*copyc avt$type_specification
*copyc avt$utility_information
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_FIELD_NAME EXPAND=FALSE

  PROCEDURE [XREF] avp$change_field_name
    (    field_name: ost$name;
         description_record_name: ost$name;
         new_field_name: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_FILE_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_file_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         file: ^fst$file_reference;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc fst$file_reference
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CHANGE_FILE_UTILITY_INFO EXPAND=FALSE

  PROCEDURE [XREF] avp$change_file_utility_info
    (    utility_information: ^avt$utility_information;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$utility_information
*copyc avt$template_file_information
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_FILE_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$change_file_value
    (    field_name: ost$name;
         file: ^fst$file_reference;
         session_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc fst$file_reference
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_INTEGER_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_integer_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         integer_value: ^integer;
         minimum_integer_value: ^integer;
         maximum_integer_value: ^integer;
         integer_display_format: ^avt$numeric_display_format;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$numeric_display_format
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CHANGE_INTEGER_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$change_integer_value
    (    field_name: ost$name;
         int: ^integer;
         session_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_JOB_CLASS_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_job_class_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         add_job_classes: ^avt$name_list;
         delete_job_classes: ^avt$name_list;
         batch_job_class_default: ^ost$name;
         interactive_job_class_default: ^ost$name;
         add_common_job_classes: ^avt$name_list;
         delete_common_job_classes: ^avt$name_list;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CHANGE_JOB_CLASS_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$change_job_class_value
    (    field_name: ost$name;
         add_job_classes: ^avt$name_list;
         delete_job_classes: ^avt$name_list;
         batch_job_class_default: ^ost$name;
         interactive_job_class_default: ^ost$name;
         session_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_LABELED_NAMES_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_labeled_names_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         add_labeled_names: ^avt$labeled_names_list;
         delete_labeled_names: ^avt$labeled_names_list;
         add_valid_labels: ^avt$name_list;
         delete_valid_labels: ^avt$name_list;
         add_valid_names: ^avt$name_list;
         delete_valid_names: ^avt$name_list;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$labeled_names_list
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
*copyc pmt$time_increment
?? POP ??
*DECK DECK=AVP$CHANGE_LABELED_NAMES_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$change_labeled_names_value
    (    field_name: ost$name;
         add_labeled_names: ^avt$labeled_names_list;
         delete_labeled_names: ^avt$labeled_names_list;
         record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$labeled_names_list
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_LIMIT_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_limit_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         limit_value: ^avt$limit_value;
         minimum_limit_value: ^avt$limit_value;
         maximum_limit_value: ^avt$limit_value;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$limit_value
*copyc avt$name_list
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_LIMIT_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$change_limit_value
    (    field_name: ost$name;
         limit_value: ^avt$limit_value;
         record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$limit_value
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_LOGIN_PASSWORD_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_login_password_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         login_password: ^avt$login_password;
         login_password_exp_date: ^ost$date_time;
         login_password_exp_interval: ^pmt$time_increment;
         login_password_max_exp_interval: ^pmt$time_increment;
         login_password_exp_warning: ^pmt$time_increment;
         login_password_exp_chg_interval: ^pmt$time_increment;
         add_password_attributes: ^avt$name_list;
         delete_password_attributes: ^avt$name_list;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$login_password
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$date_time
*copyc ost$status
*copyc pmt$time_increment
?? POP ??
*DECK DECK=AVP$CHANGE_LOGIN_PASSWORD_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$change_login_password_value
    (    field_name: ost$name;
         old_password: ^string(osc$max_name_size);
         login_password: ^avt$login_password;
         login_password_exp_date: ^ost$date_time;
         login_password_exp_interval: ^pmt$time_increment;
         login_password_max_exp_interval: ^pmt$time_increment;
         login_password_exp_warning: ^pmt$time_increment;
         login_password_exp_chg_interval: ^pmt$time_increment;
         add_password_attributes: ^avt$name_list;
         delete_password_attributes: ^avt$name_list;
         session_id: ost$name;
         update_batch_job_passwords: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc avc$unlimited_exp_interval
*copyc avc$no_expiration_date
*copyc ave$validation_interface_errors
*copyc avt$login_password
*copyc avt$name_list
*copyc avt$template_file_information
*copyc ost$date_time
*copyc ost$name
*copyc ost$status
*copyc pmt$time_increment
?? POP ??
*DECK DECK=AVP$CHANGE_NAME_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_name_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         add_names: ^avt$name_list;
         delete_names: ^avt$name_list;
         minimum_number_of_names: ^avt$name_list_size;
         maximum_number_of_names: ^avt$name_list_size;
         add_common_names: ^avt$name_list;
         delete_common_names: ^avt$name_list;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
*copyc pmt$time_increment
?? POP ??
*DECK DECK=AVP$CHANGE_NAME_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$change_name_value
    (    field_name: ost$name;
         add_names: ^avt$name_list;
         delete_names: ^avt$name_list;
         session_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_PASSWORD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_password
    (    old_password: avt$password;
         new_password: avt$password;
         expiration_date: ^ost$date_time;
         expiration_interval: ^pmt$time_increment;
         update_batch_job_passwords: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$password
*copyc ost$date_time
*copyc ost$status
*copyc pmt$time_increment
?? POP ??
*DECK DECK=AVP$CHANGE_PROJECT_MEMBER_REC EXPAND=FALSE

  PROCEDURE [XREF] avp$change_project_member_rec
    (    account_name: avt$account_name;
         project_name: avt$project_name;
         user_name: ost$user_name;
     VAR record_id: ost$name;
     VAR command_table_size: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$user_identification
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_PROJECT_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_project_record
    (    account_name: avt$account_name;
         project_name: avt$project_name;
     VAR record_id: ost$name;
     VAR command_table_size: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_REAL_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_real_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         real_value: ^real;
         minimum_real_value: ^real;
         maximum_real_value: ^real;
         real_display_format: ^avt$numeric_display_format;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$numeric_display_format
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
*copyc pmt$time_increment
?? POP ??
*DECK DECK=AVP$CHANGE_REAL_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$change_real_value
    (    field_name: ost$name;
         real_value: ^real;
         session_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_RING_PRIVILEGE_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_ring_privilege_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         minimum_ring: ^ost$ring;
         maximum_ring: ^ost$ring;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CHANGE_RING_PRIVILEGE_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$change_ring_privilege_value
    (    field_name: ost$name;
         minimum_ring: ^ost$ring;
         nominal_ring: ^ost$ring;
         session_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_STRING_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_string_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         string_value: ^ost$string;
         minimum_string_size: ^ost$string_size;
         maximum_string_size: ^ost$string_size;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
         description: ^ost$string;
         display_authority: ^avt$validation_authority;
         change_authority: ^avt$validation_authority;
         manage_authority: ^avt$validation_authority;
         delete_authority: ^avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CHANGE_STRING_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$change_string_value
    (    field_name: ost$name;
         string_value: ^ost$string;
         session_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$string
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_USER_PF_SPACE_LIMIT EXPAND=FALSE

  PROCEDURE [XREF] avp$change_user_pf_space_limit
    (    family_name: ost$family_name;
         total_accumulation: ^avt$limit_value;
     VAR user_name: ost$user_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$limit_value
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$CHANGE_USER_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$change_user_record
    (VAR user_name: ost$user_name;
     VAR session_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$CHANGE_UTIL_INFO_CMD_NAME EXPAND=FALSE

  PROCEDURE [XREF] avp$change_util_info_cmd_name
    (    command_name: ost$name;
         new_command_name: ost$name;
         validation_record_name: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHANGE_VAL_FIELD_NAME EXPAND=FALSE

  PROCEDURE [XREF] avp$change_val_field_name
    (    field_name: ost$name;
         validation_record_name: ost$name;
         new_field_name: ost$name;
         change_commands: ^avt$name_list;
         display_commands: ^avt$name_list;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CHECK_FOR_CONSOLE_OPERATION EXPAND=FALSE

  PROCEDURE [INLINE] avp$check_for_console_operation
    (    message_text: string (* <= osc$max_string_size);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

  VAR
    user_id: ost$user_identification;

{ Verify that the console operation only security option is enforced if on.

    IF avv$security_options [avc$vso_console_operation_only].active THEN
      pmp$get_user_identification (user_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Return an abnormal status if this is not the system job or any JOB/JOBEND
{ from the system job.  Those are the only possible ways to be executing under
{ the $SYSTEM user.

      IF NOT ((user_id.family = jmc$system_family) AND (user_id.user = jmc$system_user)) THEN
        osp$set_status_abnormal ('AV', ave$console_operation_only, message_text, status);
        RETURN;
      IFEND;
    IFEND;

  PROCEND avp$check_for_console_operation;

*copyc ave$console_operation_only
*copyc avt$valid_security_options
*copyc avv$security_options
*copyc jmc$system_family
*copyc osp$set_status_abnormal
*copyc pmp$get_user_identification
?? POP ??

*DECK DECK=AVP$CHECK_FOR_SERVED_FAMILY EXPAND=FALSE

  PROCEDURE [XREF] avp$check_for_served_family
    (    family_name: string (* <= osc$max_name_size);
     VAR served_family: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$CLEAR_ACTIVE_CAPABILITIES EXPAND=TRUE

  PROCEDURE [XREF] avp$clear_active_capabilities
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CLOSE_TEMPLATE_FILE EXPAND=FALSE

  PROCEDURE [XREF] avp$close_template_file
    (VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$template_file_information
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CLOSE_VALIDATION_FILE EXPAND=FALSE

  PROCEDURE [XREF] avp$close_validation_file
    (VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_file_name
*copyc avc$validation_file_version
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc ost$status
?? POP ??
*DECK DECK=AVP$COMPRESS_VALIDATION_FILE EXPAND=TRUE
create_command_description name=(compress_validation_file, comvf) sp=avp$compress_validation_file
*DECK DECK=AVP$CONFIGURATION_ADMINISTRATOR EXPAND=FALSE

  FUNCTION [INLINE] avp$configuration_administrator: boolean;

?? PUSH (LISTEXT := ON) ??

{
{   The purpose of this request is to determine if the current job is
{ currently executing with configuration administration capability.
{
{       AVP$CONFIGURATION_ADMINISTRATOR  : CONFIGURATION_ADMINISTRATOR
{
{ CONFIGURATION_ADMINISTRATOR:  (output) This parameter specifies whether or
{       not the current job is currently executing with configuration
{       administration capability.
{

    avp$configuration_administrator := avp$capability_active (
          avc$cc_configuration_admin);

  FUNCEND avp$configuration_administrator;

*copyc avp$capability_active
?? POP ??
*DECK DECK=AVP$CREATE_$SYSTEM_USER EXPAND=FALSE

  PROCEDURE [XREF] avp$create_$system_user
    (    family_name: ost$family_name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$CREATE_ACCOUNT_MEMBER_REC EXPAND=FALSE

  PROCEDURE [XREF] avp$create_account_member_rec
    (    account_name: avt$account_name;
         user_name: ost$user_name;
     VAR session_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$CREATE_ACCOUNT_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_account_record
    (    account_name: avt$account_name;
     VAR session_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CREATE_ACCT_PROJ_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_acct_proj_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         account_name: avt$account_name;
         project_name: avt$project_name;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$name_list
*copyc avt$project_name
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CREATE_ACCUM_LIMIT_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_accum_limit_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         job_warning_limit: avt$limit_value;
         job_maximum_limit: avt$limit_value;
         total_limit: avt$limit_value;
         limit_name: ost$name;
         job_limits_apply: boolean;
         limit_update_statistics: ^sft$limit_update_statistics;
         minimum_job_limit_value: avt$limit_value;
         maximum_job_limit_value: avt$limit_value;
         total_limit_applies: boolean;
         total_limit_stops_login: boolean;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$limit_value
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
*copyc sft$limit_update_statistics
?? POP ??

*DECK DECK=AVP$CREATE_CAPABILITY_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_capability_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         capability: boolean;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CREATE_DATA_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_data_record
    (    key: avt$template_file_key;
         description_record_name: ost$name;
         field_value_list: avt$field_value_list;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$field_value_list
*copyc avt$template_file_information
*copyc avt$template_file_key
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CREATE_DATE_TIME_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_date_time_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         date_time: avt$date_time;
         date_time_range: boolean;
         date_applies: boolean;
         time_applies: boolean;
         date_display_format: clt$date_time_form_string;
         time_display_format: clt$date_time_form_string;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$date_time
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc clt$date_time_form_string
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CREATE_DESCRIPTION_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_description_record
    (    description_record_name: ost$name;
         utility_information: ^avt$utility_information;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CREATE_FAMILY_INTERFACE EXPAND=FALSE

  PROCEDURE [XREF] avp$create_family_interface
    (    family_name: ost$family_name;
         family_administrator: ost$user_name;
         account_name: avt$account_name;
         project_name: avt$project_name;
         password: ost$name;
         permanent_file_set: stt$set_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$account_name
*copyc avt$project_name
*copyc ost$name
*copyc ost$status
*copyc ost$user_identification
*copyc std$set_name
?? POP ??
*DECK DECK=AVP$CREATE_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_field
    (    field_name: ost$name;
         description_record_name: ost$name;
         type_specification: avt$type_specification;
         default_value: avt$field_value;
         description: ^avt$descriptive_text;
         utility_information: ^avt$utility_information;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$descriptive_text
*copyc avt$field_value
*copyc avt$type_specification
*copyc avt$utility_information
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CREATE_FILE_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_file_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         file: fst$file_reference;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc fst$file_reference
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CREATE_INTEGER_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_integer_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         integer_value: integer;
         minimum_integer_value: integer;
         maximum_integer_value: integer;
         integer_display_format: avt$numeric_display_format;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$numeric_display_format
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CREATE_JOB_CLASS_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_job_class_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         job_classes: avt$name_list;
         batch_job_class_default: ost$name;
         interactive_job_class_default: ost$name;
         common_job_classes: avt$name_list;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CREATE_LABELED_NAMES_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_labeled_names_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         labeled_names: avt$labeled_names_list;
         valid_labels: avt$name_list;
         valid_names: avt$name_list;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$labeled_names_list
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CREATE_LIMIT_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_limit_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         limit_value: avt$limit_value;
         minimum_limit_value: avt$limit_value;
         maximum_limit_value: avt$limit_value;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$limit_value
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CREATE_LOGIN_PASSWORD_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_login_password_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         login_password: avt$login_password;
         login_password_exp_date: ost$date_time;
         login_password_exp_interval: pmt$time_increment;
         login_password_max_exp_interval: pmt$time_increment;
         login_password_exp_warning: pmt$time_increment;
         login_password_exp_chg_interval: pmt$time_increment;
         login_password_attributes: avt$name_list;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$login_password
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$date_time
*copyc ost$name
*copyc ost$status
*copyc ost$string
*copyc pmt$time_increment
?? POP ??
*DECK DECK=AVP$CREATE_NAME_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_name_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         names: avt$name_list;
         minimum_number_of_names: avt$name_list_size;
         maximum_number_of_names: avt$name_list_size;
         common_names: avt$name_list;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CREATE_PROJECT_MEMBER_REC EXPAND=FALSE

  PROCEDURE [XREF] avp$create_project_member_rec
    (    account_name: avt$account_name;
         project_name: avt$project_name;
         user_name: ost$user_name;
     VAR session_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$CREATE_PROJECT_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_project_record
    (    account_name: avt$account_name;
         project_name: avt$project_name;
     VAR session_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$CREATE_REAL_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_real_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         real_value: real;
         minimum_real_value: real;
         maximum_real_value: real;
         real_display_format: avt$numeric_display_format;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$numeric_display_format
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CREATE_RESTRICTION_FIELD EXPAND=FALSE


























                                                                                                                                   E
*DECK DECK=AVP$CREATE_RING_PRIVILEGE_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_ring_privilege_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         minimum_ring: ost$ring;
         nominal_ring: ost$ring;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CREATE_STRING_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_string_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
         string_value: ost$string;
         minimum_string_size: ost$string_size;
         maximum_string_size: ost$string_size;
         change_commands: avt$name_list;
         display_commands: avt$name_list;
         description: ost$string;
         display_authority: avt$validation_authority;
         change_authority: avt$validation_authority;
         manage_authority: avt$validation_authority;
         delete_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$CREATE_USER_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$create_user_record
    (    user_name: ost$user_name;
     VAR session_id: ost$name;
     VAR number_of_command_entries: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
*copyc ost$user_identification
?? POP ??

*DECK DECK=AVP$DELETE_ACCOUNT_MEMBER_REC EXPAND=FALSE

  PROCEDURE [XREF] avp$delete_account_member_rec
    (    account_name: avt$account_name;
         user_name: ost$user_name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$template_file_information
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$DELETE_ACCOUNT_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$delete_account_record
    (    account_name: avt$account_name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$template_file_information
*copyc ost$status
?? POP ??
*DECK DECK=AVP$DELETE_DATA_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$delete_data_record
    (    key: avt$template_file_key;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$template_file_information
*copyc avt$template_file_key
*copyc ost$status
?? POP ??
*DECK DECK=AVP$DELETE_DATA_RECORDS EXPAND=FALSE

  PROCEDURE [XREF] avp$delete_data_records
    (    starting_key: avt$template_file_key;
         ending_key: avt$template_file_key;
         description_record_name: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$template_file_information
*copyc avt$template_file_key
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$DELETE_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$delete_field
    (    field_name: ost$name;
         description_record_name: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$DELETE_PROJECT_MEMBER_REC EXPAND=FALSE

  PROCEDURE [XREF] avp$delete_project_member_rec
    (    account_name: avt$account_name;
         project_name: avt$project_name;
         user_name: ost$user_name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc avt$template_file_information
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$DELETE_PROJECT_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$delete_project_record
    (    account_name: avt$account_name;
         project_name: avt$project_name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc avt$template_file_information
*copyc ost$status
?? POP ??
*DECK DECK=AVP$DELETE_USER_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$delete_user_record
    (    user_name: ost$user_name;
         delete_files: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$DELETE_VALIDATION_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$delete_validation_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$DETERMINE_IF_KEY_EXISTS EXPAND=FALSE

  PROCEDURE [XREF] avp$determine_if_key_exists
    (    key: avt$template_file_key;
     VAR key_exists: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (listext := on) ??
*copyc ave$template_file_mgr_errors
*copyc avt$template_file_information
*copyc avt$template_file_key
*copyc ost$status
?? POP ??
*DECK DECK=AVP$DISPLAY_FIELD_DESCRIPTIONS EXPAND=FALSE

  PROCEDURE [XREF] avp$display_field_descriptions
    (    validation_record_name: ost$name;
         display_option_list: ^array [1 .. * ] of ost$name;
     VAR display_control: clt$display_control;
     VAR validation_file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc clt$display_control
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$DISPLAY_PW_EXP_WARNING EXPAND=FALSE

  PROCEDURE [XREF] avp$display_pw_exp_warning
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=AVP$DUAL_STATE_PROMPT EXPAND=FALSE

  PROCEDURE [XREF] avp$dual_state_prompt
    (    user_name: ost$user_name;
         family_name: ost$family_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$EMIT_INTERACTIVE_INTERVAL EXPAND=FALSE

  PROCEDURE [XREF] avp$emit_interactive_interval;
*DECK DECK=AVP$ENCRYPT EXPAND=FALSE

  PROCEDURE [XREF] avp$encrypt
    (VAR base: integer;
     VAR exponent: integer;
     VAR coefficient: integer;
     VAR prime: integer;
     VAR result: integer);

*DECK DECK=AVP$ENCRYPT_PASSWORD EXPAND=FALSE

  PROCEDURE [XREF] avp$encrypt_password
    (    user_name: ost$user_name;
         unencrypted_password: ost$name;
     VAR encrypted_password: avt$password;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$validation_interface_errors
*copyc avt$password
*copyc ost$name
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$END_ACCOUNT EXPAND=FALSE

  PROCEDURE [XREF] avp$end_account
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=AVP$END_SUBUTILITY_SESSION EXPAND=FALSE

  PROCEDURE [XREF] avp$end_subutility_session
    (    record_id: ost$name;
         rewrite_record: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$FAMILY_ADMINISTRATOR EXPAND=FALSE

  FUNCTION [INLINE] avp$family_administrator: boolean;

?? PUSH (LISTEXT := ON) ??

{
{   The purpose of this request is to determine if the current job is
{ currently executing with family administration capability.
{
{       AVP$FAMILY_ADMINISTRATOR  : FAMILY_ADMINISTRATOR
{
{ FAMILY_ADMINISTRATOR:  (output) This parameter specifies whether or not the
{       current job is currently executing with family administration capability.
{

    avp$family_administrator := avp$capability_active (avc$cc_family_admin);

  FUNCEND avp$family_administrator;

*copyc avp$capability_active
?? POP ??
*DECK DECK=AVP$GET_ACCOUNT_PROJECT_SPECIF EXPAND=FALSE

  FUNCTION [INLINE] avp$get_account_project_specif: boolean;

    avp$get_account_project_specif := TRUE;

  FUNCEND avp$get_account_project_specif;
*DECK DECK=AVP$GET_ACCOUNT_PROJECT_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_account_project_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR account: avt$account_name;
     VAR project: avt$project_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$template_file_mgr_errors
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc avt$validation_record
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_ACCT_PROJ_DISPLAY_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_acct_proj_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR account_name: avt$account_name;
     VAR project_name: avt$project_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_ACCT_PROJ_FIELD_DESC EXPAND=FALSE
  PROCEDURE [XREF] avp$get_acct_proj_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR default_account_name: avt$account_name;
     VAR default_project_name: avt$project_name;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$GET_ACCUM_LIMIT_DISPLAY_VAL EXPAND=FALSE

  PROCEDURE [XREF] avp$get_accum_limit_display_val
    (    field_name: ost$name;
         record_id: ost$name;
     VAR job_limit_information: avt$job_limit_information;
     VAR total_limit_information: avt$total_limit_information;
     VAR display_format: avt$numeric_display_format;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$job_limit_information
*copyc avt$numeric_display_format
*copyc avt$total_limit_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_ACCUM_LIMIT_FIELD_DESC EXPAND=FALSE

  PROCEDURE [XREF] avp$get_accum_limit_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR job_warning_limit: avt$limit_value;
     VAR job_maximum_limit: avt$limit_value;
     VAR total_limit: avt$limit_value;
     VAR total_accumulation: avt$limit_value;
     VAR limit_name: ost$name;
     VAR job_limits_apply: boolean;
     VAR minimum_job_limit_value: avt$limit_value;
     VAR maximum_job_limit_value: avt$limit_value;
     VAR number_of_limit_update_stats: avt$name_list_size;
     VAR limit_update_statistics: ^sft$limit_update_statistics;
     VAR total_limit_applies: boolean;
     VAR total_limit_stops_login: boolean;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$limit_value
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
*copyc sft$limit_update_statistics
?? POP ??
*DECK DECK=AVP$GET_ACCUM_LIMIT_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_accum_limit_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR job_limit_information: avt$job_limit_information;
     VAR total_limit_information: avt$total_limit_information;
     VAR display_format: avt$numeric_display_format;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$template_file_mgr_errors
*copyc ave$validation_interface_errors
*copyc avt$job_limit_information
*copyc avt$numeric_display_format
*copyc avt$total_limit_information
*copyc avt$validation_record
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_CAPABILITY EXPAND=FALSE

  PROCEDURE [XREF] avp$get_capability
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR capability: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$template_file_mgr_errors
*copyc ave$validation_interface_errors
*copyc avt$validation_record
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_CAPABILITY_FIELD_DESC EXPAND=FALSE

  PROCEDURE [XREF] avp$get_capability_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR capability: boolean;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$GET_CAPABIL_DISPLAY_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_capabil_display_value
    (    capability_name: ost$name;
         record_id: ost$name;
     VAR capability: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_COMMAND_TABLE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_command_table
    (    session_id: ost$name;
     VAR command_table_work_area: ^seq (*);
     VAR command_table: ^clt$command_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$validation_interface_errors
*copyc clt$command_table
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_DATA_RECORD_STATISTICS EXPAND=FALSE

  PROCEDURE [XREF] avp$get_data_record_statistics
    (VAR space_used_by_data_records: integer;
     VAR data_record_count: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$template_file_information
*copyc ost$status
?? POP ??

*DECK DECK=AVP$GET_DATE_TIME_DISPLAY_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_date_time_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR date_time: avt$date_time;
     VAR date_display_format: clt$date_time_form_string;
     VAR time_display_format: clt$date_time_form_string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$date_time
*copyc clt$date_time_form_string
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_DATE_TIME_FIELD_DESC EXPAND=FALSE

  PROCEDURE [XREF] avp$get_date_time_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR date_time: avt$date_time;
     VAR date_time_range: boolean;
     VAR date_applies: boolean;
     VAR time_applies: boolean;
     VAR date_display_format: clt$date_time_form_string;
     VAR time_display_format: clt$date_time_form_string;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc avc$date_time_display_formats
*copyc ave$validation_interface_errors
*copyc avt$date_time
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc clt$date_time_form_string
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$GET_DATE_TIME_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_date_time_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR date_time: avt$date_time;
     VAR date_display_format: clt$date_time_form_string;
     VAR time_display_format: clt$date_time_form_string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$template_file_mgr_errors
*copyc ave$validation_interface_errors
*copyc avt$date_time
*copyc avt$validation_record
*copyc clt$date_time_form_string
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_DESCRIPTION_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$get_description_record
    (    description_record_name: ost$name;
     VAR description_record: ^avt$template_file_record;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := on) ??
*copyc ave$template_file_mgr_errors
*copyc avt$template_file_information
*copyc avt$template_file_record
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_DESC_UTILITY_INFO EXPAND=FALSE

  PROCEDURE [XREF] avp$get_desc_utility_info
    (    description_record_name: ost$name;
     VAR utility_information: ^avt$utility_information;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$template_file_information
*copyc avt$utility_information
*copyc ost$name
*copyc ost$status
?? POP ??

*DECK DECK=AVP$GET_DESC_UTILITY_INFO_SIZE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_desc_utility_info_size
    (    description_record_name: ost$name;
     VAR utility_information_size: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$get_field
    (    field_name: ost$name;
         data_record: ^avt$template_file_record;
         description_record: ^avt$template_file_record;
         work_area: ^seq ( * );
     VAR field_value: avt$field_value;
     VAR type_specification: avt$type_specification;
     VAR default_value: avt$field_value;
     VAR descriptive_text: ^avt$descriptive_text;
     VAR utility_information: ^avt$utility_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$descriptive_text
*copyc avt$field_value
*copyc avt$template_file_record
*copyc avt$type_specification
*copyc avt$utility_information
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_FIELD_DESCRIPTION EXPAND=FALSE

  PROCEDURE [XREF] avp$get_field_description
    (    field_name: ost$name;
         description_record: ^avt$template_file_record;
         work_area: ^seq ( * );
     VAR type_specification: avt$type_specification;
     VAR default_value: avt$field_value;
     VAR description: ^avt$descriptive_text;
     VAR utility_information: ^avt$utility_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$descriptive_text
*copyc avt$field_value
*copyc avt$utility_information
*copyc avt$template_file_record
*copyc avt$type_specification
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_FIELD_NAME EXPAND=FALSE

  PROCEDURE [XREF] avp$get_field_name
    (    session_id: ost$name;
     VAR field_name: ost$name;
     VAR command_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_FIELD_NAMES EXPAND=FALSE

  PROCEDURE [XREF] avp$get_field_names
    (    desired_field_types: avt$field_kind_set;
         return_deleted_names: boolean;
         description_record: ^avt$template_file_record;
     VAR field_names: array [ 1 .. * ] of ost$name;
     VAR field_count: avt$field_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$field_count
*copyc avt$field_kind_set
*copyc avt$name_list
*copyc avt$template_file_record
*copyc ost$status
?? POP ??

*DECK DECK=AVP$GET_FIELD_NAME_LIST EXPAND=FALSE
  PROCEDURE [XREF] avp$get_field_name_list
    (    record_level: avt$validation_record;
         desired_field_types: avt$field_kind_set;
     VAR field_names: avt$name_list;
     VAR field_count: avt$field_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$field_count
*copyc avt$field_kind_set
*copyc avt$name_list
*copyc avt$validation_record
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_FIELD_TYPE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_field_type
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR field_kind: avt$field_kind;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$template_file_mgr_errors
*copyc ave$validation_interface_errors
*copyc avt$field_kind
*copyc avt$validation_record
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_FILE_DISPLAY_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_file_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR file: string (fsc$max_path_size);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc fst$file_reference
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_FILE_FIELD_DESC EXPAND=FALSE

  PROCEDURE [XREF] avp$get_file_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR file: string (fsc$max_path_size);
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc fst$file_reference
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$GET_FILE_UTILITY_INFO EXPAND=FALSE

  PROCEDURE [XREF] avp$get_file_utility_info
    (VAR utility_information: ^avt$utility_information;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$utility_information
*copyc avt$template_file_information
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_FILE_UTILITY_INFO_SIZE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_file_utility_info_size
    (VAR utility_information_size: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$template_file_information
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_FILE_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_file_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR file: string (fsc$max_path_size);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$template_file_mgr_errors
*copyc ave$validation_interface_errors
*copyc avt$validation_record
*copyc fst$file_reference
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_INDEX_RECORD_STATISTICS EXPAND=FALSE

  PROCEDURE [XREF] avp$get_index_record_statistics
    (    depth: avt$template_file_index_depth;
     VAR space_used_by_index_records: integer;
     VAR index_record_count: integer;
     VAR total_key_count: integer;
     VAR minimum_key_count: integer;
     VAR maximum_key_count: integer;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$template_file_index_depth
*copyc avt$template_file_information
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_INTEGER_DISPLAY_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_integer_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR integer_value: integer;
     VAR display_format: avt$numeric_display_format;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$numeric_display_format
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_INTEGER_FIELD_DESC EXPAND=FALSE

  PROCEDURE [XREF] avp$get_integer_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR integer_value: integer;
     VAR minimum_integer_value: integer;
     VAR maximum_integer_value: integer;
     VAR integer_display_format: avt$numeric_display_format;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$numeric_display_format
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$GET_INTEGER_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_integer_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR integer_value: integer;
     VAR integer_display_format: avt$numeric_display_format;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$template_file_mgr_errors
*copyc ave$validation_interface_errors
*copyc avt$numeric_display_format
*copyc avt$validation_record
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_JOB_CLASS_DISPLAY_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_job_class_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR job_classes: avt$name_list;
     VAR number_of_job_classes: avt$name_list_size;
     VAR batch_job_class_default: ost$name;
     VAR interactive_job_class_default: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$name_list_size
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_JOB_CLASS_FIELD_DESC EXPAND=FALSE

  PROCEDURE [XREF] avp$get_job_class_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR number_of_job_classes: avt$name_list_size;
     VAR job_classes: ^avt$name_list;
     VAR batch_job_class_default: ost$name;
     VAR interactive_job_class_default: ost$name;
     VAR number_of_common_job_classes: avt$name_list_size;
     VAR common_job_classes: ^avt$name_list;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$GET_JOB_CLASS_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_job_class_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR job_classes: avt$name_list;
     VAR number_of_job_classes: avt$name_list_size;
     VAR batch_job_class_default: ost$name;
     VAR interactive_job_class_defalut: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$template_file_mgr_errors
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$validation_record
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_LABELED_NAMES_DIS_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_labeled_names_dis_value
    (    field_name: ost$name;
         record_id: ost$name;
         work_area: ^seq (*);
     VAR labeled_names:  ^avt$labeled_names_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$labeled_names_list
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_LABELED_NAMES_FIELD_DES EXPAND=FALSE

  PROCEDURE [XREF] avp$get_labeled_names_field_des
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
         work_area: ^seq (*);
     VAR labeled_names: ^avt$labeled_names_list;
     VAR number_of_valid_labels: avt$name_list_size;
     VAR valid_labels: ^avt$name_list;
     VAR number_of_valid_names: avt$name_list_size;
     VAR valid_names: ^avt$name_list;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$labeled_names_list
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$GET_LABELED_NAMES_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_labeled_names_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
         work_area: ^seq (*);
     VAR labeled_names:  ^avt$labeled_names_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$template_file_mgr_errors
*copyc ave$validation_interface_errors
*copyc avt$labeled_names_list
*copyc avt$validation_record
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_LIMIT_DISPLAY_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_limit_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR limit_value: avt$limit_value;
     VAR display_format: avt$numeric_display_format;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$limit_value
*copyc avt$numeric_display_format
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_LIMIT_FIELD_DESC EXPAND=FALSE

  PROCEDURE [XREF] avp$get_limit_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR limit_value: avt$limit_value;
     VAR minimum_limit_value: avt$limit_value;
     VAR maximum_limit_value: avt$limit_value;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc avt$validation_authority
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$limit_value
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$GET_LIMIT_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_limit_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR limit_value: avt$limit_value;
     VAR display_format: avt$numeric_display_format;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$template_file_mgr_errors
*copyc ave$validation_interface_errors
*copyc avt$limit_value
*copyc avt$numeric_display_format
*copyc avt$validation_record
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_LOGIN_PASSWORD_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_login_password_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR expiration_date: ost$date_time;
     VAR expiration_interval: pmt$time_increment;
     VAR maximum_expiration_interval: pmt$time_increment;
     VAR expiration_warning_interval: pmt$time_increment;
     VAR expired_password_chg_interval: pmt$time_increment;
     VAR change_date: ost$date_time;
     VAR attributes: avt$name_list;
     VAR number_of_attributes: avt$name_list_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$template_file_mgr_errors
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$validation_record
*copyc ost$date_time
*copyc ost$name
*copyc ost$status
*copyc pmt$time_increment
?? POP ??
*DECK DECK=AVP$GET_LOGIN_PW_DISPLAY_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_login_pw_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR expiration_date: ost$date_time;
     VAR expiration_interval: pmt$time_increment;
     VAR maximum_expiration_interval: pmt$time_increment;
     VAR expiration_warning_interval: pmt$time_increment;
     VAR expired_password_chg_interval: pmt$time_increment;
     VAR change_date: ost$date_time;
     VAR attributes: avt$name_list;
     VAR number_of_attributes: avt$name_list_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$login_password
*copyc avt$name_list
*copyc avt$name_list_size
*copyc ost$date_time
*copyc ost$name
*copyc ost$status
*copyc pmt$time_increment
?? POP ??
*DECK DECK=AVP$GET_LOGIN_PW_FIELD_DESC EXPAND=FALSE

  PROCEDURE [XREF] avp$get_login_pw_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR password: avt$login_password;
     VAR expiration_date: ost$date_time;
     VAR expiration_interval: pmt$time_increment;
     VAR maximum_expiration_interval: pmt$time_increment;
     VAR expiration_warning: pmt$time_increment;
     VAR expiration_change_interval: pmt$time_increment;
     VAR number_of_attributes: avt$name_list_size;
     VAR attributes: ^avt$name_list;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$login_password
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$date_time
*copyc ost$name
*copyc ost$status
*copyc ost$string
*copyc pmt$time_increment
?? POP ??
*DECK DECK=AVP$GET_NAME_DISPLAY_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_name_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR names: avt$name_list;
     VAR number_of_names: avt$name_list_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$name_list_size
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_NAME_FIELD_DESC EXPAND=FALSE

  PROCEDURE [XREF] avp$get_name_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR number_of_names: avt$name_list_size;
     VAR names: ^avt$name_list;
     VAR minimum_number_of_names: avt$name_list_size;
     VAR maximum_number_of_names: avt$name_list_size;
     VAR number_of_common_names: avt$name_list_size;
     VAR common_names: ^avt$name_list;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$GET_NAME_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_name_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR names: avt$name_list;
     VAR number_of_names: avt$name_list_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$template_file_mgr_errors
*copyc ave$validation_interface_errors
*copyc avt$name_list
*copyc avt$validation_record
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_REAL_DISPLAY_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_real_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR real_value: real;
     VAR display_format: avt$numeric_display_format;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$numeric_display_format
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_REAL_FIELD_DESC EXPAND=FALSE

  PROCEDURE [XREF] avp$get_real_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR real_value: real;
     VAR minimum_real_value: real;
     VAR maximum_real_value: real;
     VAR real_display_format: avt$numeric_display_format;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$numeric_display_format
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$GET_REAL_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_real_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR real_value: real;
     VAR display_format: avt$numeric_display_format;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$template_file_mgr_errors
*copyc ave$validation_interface_errors
*copyc avt$numeric_display_format
*copyc avt$validation_record
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_REMOVABLE_MEDIA_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] avp$get_removable_media_access
    (    user: ost$user_name;
         family: ost$family_name;
         removable_media_acess_name: ost$name;
     VAR access: fst$file_access_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_access_options
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$GET_RING_PRIV_DISPLAY_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_ring_priv_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR minimum_ring: ost$ring;
     VAR nominal_ring: ost$ring;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_RING_PRIV_FIELD_DESC EXPAND=FALSE

  PROCEDURE [XREF] avp$get_ring_priv_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR minimum_ring: ost$ring;
     VAR nominal_ring: ost$ring;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc osd$virtual_address
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$GET_SET_NAME EXPAND=FALSE

  PROCEDURE [XREF] avp$get_set_name
    (    family: ost$family_name;
     VAR set_name: stt$set_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc std$set_name
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$GET_STRING_DISPLAY_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_string_display_value
    (    field_name: ost$name;
         record_id: ost$name;
     VAR string_value: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$GET_STRING_FIELD_DESC EXPAND=FALSE

  PROCEDURE [XREF] avp$get_string_field_desc
    (    field_name: ost$name;
         record_name: ost$name;
         record_id: ost$name;
     VAR string_value: ost$string;
     VAR minimum_string_size: ost$string_size;
     VAR maximum_string_size: ost$string_size;
     VAR description: ost$string;
     VAR change_authority: avt$validation_authority;
     VAR delete_authority: avt$validation_authority;
     VAR display_authority: avt$validation_authority;
     VAR manage_authority: avt$validation_authority;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc avt$validation_authority
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$GET_STRING_VALUE EXPAND=FALSE

  PROCEDURE [XREF] avp$get_string_value
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR string_value: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$template_file_mgr_errors
*copyc ave$validation_interface_errors
*copyc avt$validation_record
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$GET_TEMPLATE_FILE_HEADER EXPAND=FALSE

  PROCEDURE [XREF] avp$get_template_file_header
    (VAR header: avt$template_file_header;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$template_file_header
*copyc avt$template_file_information
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_VALIDATION_FIELD_KIND EXPAND=FALSE

  PROCEDURE [XREF] avp$get_validation_field_kind
    (    field_name: ost$name;
         validation_record_name: ost$name;
     VAR field_kind: avt$field_kind;
     VAR validation_file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$field_kind
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$GET_VALIDATION_FIELD_NAMES EXPAND=FALSE

  PROCEDURE [XREF] avp$get_validation_field_names
    (    validation_record_name: ost$name;
         desired_field_kinds: avt$field_kind_set;
         return_deleted_fields: boolean;
     VAR field_names: avt$name_list;
     VAR field_count: avt$field_count;
     VAR validation_file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$field_kind_set
*copyc avt$name_list
*copyc avt$field_count
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$INITIALIZE EXPAND=FALSE

  PROCEDURE [XREF] avp$initialize
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=AVP$INITIALIZE_FAMILY EXPAND=FALSE

  PROCEDURE [XREF] avp$initialize_family
    (    family_name: ost$family_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$LOCK_TEMPLATE_FILE EXPAND=FALSE

  PROCEDURE [XREF] avp$lock_template_file
    (    desired_lock_type: avt$template_file_lock_type;
     VAR lock_set_by_this_procedure: boolean;
     VAR template_file_header: ^avt$template_file_header;
     VAR template_file_heap: ^avt$template_file_heap;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$template_file_header
*copyc avt$template_file_heap
*copyc avt$template_file_information
*copyc avt$template_file_lock_type
*copyc ost$status
?? POP ??

*DECK DECK=AVP$MAKE_ACCT_PROJ_SCL_VALUE EXPAND=FALSE
  PROCEDURE [XREF] avp$make_acct_proj_scl_value
    (    account: avt$account_name;
         project: avt$project_name;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc avt$account_name
*copyc avt$project_name
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=AVP$MAKE_ACCUM_LIMIT_SCL_VALUE EXPAND=FALSE
  PROCEDURE [XREF] avp$make_accum_limit_scl_value
    (    job_limit_information: avt$job_limit_information;
         total_limit_information: avt$total_limit_information;
         numeric_display_format: avt$numeric_display_format;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc avt$job_limit_information
*copyc avt$numeric_display_format
*copyc avt$total_limit_information
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=AVP$MAKE_CAPABILITY_SCL_VALUE EXPAND=FALSE
  PROCEDURE [XREF] avp$make_capability_scl_value
    (    capability: boolean;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=AVP$MAKE_DATE_TIME_SCL_VALUE EXPAND=FALSE
  PROCEDURE [XREF] avp$make_date_time_scl_value
    (    date_time: avt$date_time;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc avt$date_time
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=AVP$MAKE_FILE_SCL_VALUE EXPAND=FALSE
  PROCEDURE [XREF] avp$make_file_scl_value
    (    file_reference: fst$file_reference;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$work_area
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=AVP$MAKE_INTEGER_SCL_VALUE EXPAND=FALSE
  PROCEDURE [XREF] avp$make_integer_scl_value
    (    integer_value: integer;
         numeric_display_format: avt$numeric_display_format;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc avt$numeric_display_format
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=AVP$MAKE_JOB_CLASS_SCL_VALUE EXPAND=FALSE
  PROCEDURE [XREF] avp$make_job_class_scl_value
    (    batch_default: ost$name;
         interactive_default: ost$name;
         job_class_list: avt$name_list;
         job_class_list_size: avt$name_list_size;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc avt$name_list
*copyc avt$name_list_size
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$MAKE_LABELED_NAMES_SCL_VALU EXPAND=FALSE

  PROCEDURE [XREF] avp$make_labeled_names_scl_valu
    (    labeled_names_list: ^avt$labeled_names_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc avt$labeled_names_list
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=AVP$MAKE_LIMIT_SCL_VALUE EXPAND=FALSE
  PROCEDURE [XREF] avp$make_limit_scl_value
    (    limit_value: integer;
         numeric_display_format: avt$numeric_display_format;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc avt$numeric_display_format
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=AVP$MAKE_LOGIN_PW_SCL_VALUE EXPAND=FALSE
  PROCEDURE [XREF] avp$make_login_pw_scl_value
    (    expiration_date: ost$date_time;
         expiration_interval: pmt$time_increment;
         maximum_expiration_interval: pmt$time_increment;
         expiration_warning_interval: pmt$time_increment;
         expired_password_chg_interval: pmt$time_increment;
         change_date: ost$date_time;
         attribute_list: avt$name_list;
         attribute_list_size: avt$name_list_size;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc avt$name_list
*copyc avt$name_list_size
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$date_time
*copyc ost$status
*copyc pmt$time_increment
?? POP ??
*DECK DECK=AVP$MAKE_NAME_SCL_VALUE EXPAND=FALSE
  PROCEDURE [XREF] avp$make_name_scl_value
    (    name_list: avt$name_list;
         name_list_size: avt$name_list_size;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc avt$name_list
*copyc avt$name_list_size
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=AVP$MAKE_REAL_SCL_VALUE EXPAND=FALSE
  PROCEDURE [XREF] avp$make_real_scl_value
    (    real_value: real;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=AVP$MAKE_RING_PRIV_SCL_VALUE EXPAND=FALSE
  PROCEDURE [XREF] avp$make_ring_priv_scl_value
    (    minimum_ring: ost$ring;
         nominal_ring: ost$ring;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$work_area
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=AVP$MAKE_STRING_SCL_VALUE EXPAND=FALSE
  PROCEDURE [XREF] avp$make_string_scl_value
    (    string_value: ost$string;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=AVP$MONITOR_STATISTICS_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] avp$monitor_statistics_handler (flag_id: ost$system_flag);

?? PUSH (LISTEXT := ON) ??
*copyc OST$SYSTEM_FLAG
?? POP ??
*DECK DECK=AVP$OLD_ENCRYPT_PASSWORD EXPAND=FALSE

  PROCEDURE [XREF] avp$old_encrypt_password
    (    user_name: ost$user_name;
         unencrypted_password: ost$name;
     VAR encrypted_password: avt$password;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$validation_interface_errors
*copyc avt$password
*copyc ost$name
*copyc ost$status
*copyc ost$user_identification
?? POP ??

*DECK DECK=AVP$OPEN_SYSTEM_VALIDATION_FILE EXPAND=FALSE

  PROCEDURE [XREF] avp$open_system_validation_file
    (    family: ost$family_name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc avt$template_file_information
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$OPEN_TEMPLATE_FILE EXPAND=FALSE

  PROCEDURE [XREF] avp$open_template_file
    (    file_name: fst$file_reference;
         create_file: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$template_file_information
*copyc fst$file_reference
*copyc ost$status
?? POP ??

*DECK DECK=AVP$OPEN_VALIDATION_FILE EXPAND=FALSE

  PROCEDURE [XREF] avp$open_validation_file
    (    file_reference: fst$file_reference;
         old_password: ^ost$name;
         new_password: ^ost$name;
         create_file: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_file_name
*copyc avc$validation_file_version
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc avt$validation_key
*copyc fst$file_reference
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$PREVALIDATE_JOB EXPAND=FALSE

  PROCEDURE [XREF] avp$prevalidate_job
    (    user_name: ost$user_name;
         family_name: ost$family_name;
         validation_attributes: ^avt$validation_items;
         default_attributes: ^avt$validation_items;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc avc$validation_level_names
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$validation_items
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$PROCESS_PASSWORD_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] avp$process_password_attributes
    (    validation_authority: avt$validation_authority;
         user_name: ost$user_name;
         last_password_change_date: ost$date_time;
         old_encrypted_password: avt$login_password;
         new_encrypted_password: avt$login_password;
         old_password: string(osc$max_name_size);
     VAR new_password: string(osc$max_name_size);
     VAR login_password_attributes: array [1 .. avc$maximum_name_list_size] OF ost$name;
     VAR number_of_password_attributes: 1 .. avc$maximum_name_list_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$maximum_name_list_size
*copyc avt$login_password
*copyc avt$validation_authority
*copyc ost$date_time
*copyc ost$name
*copyc ost$status
*copyc ost$user_identification
?? POP ??

*DECK DECK=AVP$READ_ACCOUNT_MEMBER_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$read_account_member_record
    (VAR account_name: avt$account_name;
     VAR user_name: ost$name;
     VAR record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$account_name
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$READ_ACCOUNT_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$read_account_record
    (VAR account_name: avt$account_name;
     VAR record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$account_name
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$READ_DATA_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$read_data_record
    (    key: avt$template_file_key;
         lock_type: avt$template_file_lock_type;
         automatically_unlock: boolean;
     VAR data_record: ^avt$template_file_record;
     VAR data_record_size: 0 .. avc$max_template_record_size;
     VAR description_record: ^avt$template_file_record;
     VAR description_record_size: 0 .. avc$max_template_record_size;
     VAR description_record_name: ost$name;
     VAR field_count: avt$field_count;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$field_count
*copyc avt$template_file_information
*copyc avt$template_file_key
*copyc avt$template_file_lock_type
*copyc ost$status
?? POP ??
*DECK DECK=AVP$READ_NEXT_DATA_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$read_next_data_record
    (    lock_type: avt$template_file_lock_type;
         automatically_unlock: boolean;
     VAR key: avt$template_file_key;
     VAR data_record: ^avt$template_file_record;
     VAR description_record: ^avt$template_file_record;
     VAR description_record_name: ost$name;
     VAR field_count: avt$field_count;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$field_count
*copyc avt$template_file_information
*copyc avt$template_file_key
*copyc avt$template_file_lock_type
*copyc ost$status
?? POP ??
*DECK DECK=AVP$READ_PROJECT_MEMBER_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$read_project_member_record
    (VAR account_name: avt$account_name;
     VAR project_name: avt$project_name;
     VAR user_name: ost$name;
     VAR record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$account_name
*copyc avt$project_name
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$READ_PROJECT_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$read_project_record
    (VAR account_name: avt$account_name;
     VAR project_name: avt$project_name;
     VAR record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$account_name
*copyc avt$project_name
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$READ_USER_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$read_user_record
    (VAR user_name: ost$name;
     VAR record_id: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$RELEASE_RECORD_ID EXPAND=FALSE

  PROCEDURE [XREF] avp$release_record_id
    (    record_id: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$REMOVABLE_MEDIA_ADMIN EXPAND=TRUE

  FUNCTION [INLINE] avp$removable_media_admin: boolean;

?? PUSH (LISTEXT := ON) ??

{
{   The purpose of this request is to determine if the current job is
{ currently executing with removable media administration capability.
{
{       AVP$REMOVABLE_MEDIA_ADMIN : REMOVABLE_MEDIA_ADMINISTRATOR
{
{ REMOVABLE_MEDIA_ADMINISTRATOR:  (output) This parameter specifies whether or not
{       the current job is currently executing with removable media administration
{       capability.
{

    avp$removable_media_admin := avp$capability_active (
          avc$cc_removable_media_admin);

   FUNCEND avp$removable_media_admin;

*copyc avp$capability_active
?? POP ??
*DECK DECK=AVP$REMOVABLE_MEDIA_OPERATOR EXPAND=TRUE

  FUNCTION [INLINE] avp$removable_media_operator: boolean;

?? PUSH (LISTEXT := ON) ??

{
{   The purpose of this request is to determine if the current job is
{ currently executing with removable media operation capability.
{
{       AVP$REMOVABLE_MEDIA_OPERATOR  : REMOVABLE_MEDIA_OPERATOR
{
{ REMOVABLE_MEDIA_OPERATOR:  (output) This parameter specifies whether or not
{       the current job is currently executing with removable media operation
{       capability.
{

    avp$removable_media_operator := avp$capability_active (
          avc$cc_removable_media_operator);

  FUNCEND avp$removable_media_operator;

*copyc avp$capability_active
?? POP ??
*DECK DECK=AVP$REORGANIZE_VALIDATION_FILE EXPAND=FALSE

  PROCEDURE [XREF] avp$reorganize_validation_file
    (    old_file_name: fst$file_reference;
         new_file_name: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??

*DECK DECK=AVP$REPLACE_TOTAL_LIMITS EXPAND=FALSE

  PROCEDURE [XREF] avp$replace_total_limits
    (    accum_limit_field_name: ost$name;
     VAR limit_update_info_array: ^array [1 .. * ] of avt$total_limit_update_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$total_limit_update_record
*copyc ost$status
?? POP ??
*DECK DECK=AVP$RESTORE_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$restore_field
    (    field_name: ost$name;
         description_record_name: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$RESTORE_VALIDATION_FIELD EXPAND=FALSE

  PROCEDURE [XREF] avp$restore_validation_field
    (    field_name: ost$name;
         validation_record_name: ost$name;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$RESTRUCTURE_TEMPLATE_FILE EXPAND=FALSE

  PROCEDURE [XREF] avp$restructure_template_file
    (    old_file_name: fst$file_reference;
         new_file_name: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??

*DECK DECK=AVP$REWRITE_DATA_RECORD EXPAND=FALSE

  PROCEDURE [XREF] avp$rewrite_data_record
    (    key: avt$template_file_key;
         automatically_unlock: boolean;
         data_record: ^avt$template_file_record;
         description_record: ^avt$template_file_record;
         field_value_list: avt$field_value_list;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$field_value_list
*copyc avt$template_file_information
*copyc avt$template_file_key
*copyc avt$template_file_record
*copyc ost$status
?? POP ??

*DECK DECK=AVP$RING_MIN EXPAND=FALSE

  FUNCTION [XREF] avp$ring_min: ost$ring;

?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
?? POP ??
*DECK DECK=AVP$RING_NOMINAL EXPAND=FALSE

  FUNCTION [XREF] avp$ring_nominal: ost$ring;

?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
?? POP ??
*DECK DECK=AVP$SECURITY_OPTION EXPAND=FALSE

  PROCEDURE [XREF] avp$security_option
    (    option: avt$security_option_name;
     VAR active: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$security_option_name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$SECURITY_OPTION_ACTIVE EXPAND=FALSE

  FUNCTION [INLINE] avp$security_option_active
    (    option: avt$valid_security_options): boolean;

?? PUSH (LISTEXT := ON) ??
    CASE option OF
    = avc$vso_console_operation_only =
      avp$security_option_active := avv$security_options [
            avc$vso_console_operation_only].active;
    = avc$vso_secure_analysis =
      avp$security_option_active := avv$security_options [
            avc$vso_secure_analysis].active;
    = avc$vso_security_audit =
      avp$security_option_active := avv$security_options [
            avc$vso_security_audit].active;
    ELSE

{ Only way to get here is if someone put in a new security option without
{ adding it to this function.

      avp$security_option_active := FALSE;
    CASEND;

  FUNCEND avp$security_option_active;

*copyc avt$valid_security_options
*copyc avv$security_options
?? POP ??
*DECK DECK=AVP$SET_VALIDATION_LEVEL EXPAND=FALSE

  PROCEDURE [XREF] avp$set_validation_level
    (    level: avt$validation_level;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_level_names
*copyc ave$validation_interface_errors
*copyc avt$validation_level
*copyc ost$status
?? POP ??

*DECK DECK=AVP$STORE_VALIDATION_INFO EXPAND=FALSE

  PROCEDURE [XREF] avp$store_validation_info
    (    family_name: ost$family_name;
         user_name: ost$user_name;
     VAR account_name: avt$account_name;
     VAR project_name: avt$project_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc ost$user_identification
*copyc ost$status
?? POP ??
*DECK DECK=AVP$SYSTEM_ADMINISTRATOR EXPAND=FALSE

  FUNCTION [INLINE] avp$system_administrator: boolean;

?? PUSH (LISTEXT := ON) ??

{
{   The purpose of this request is to determine if the current job is
{ currently executing with system administration capability.
{
{       AVP$SYSTEM_ADMINISTRATOR  : SYSTEM_ADMINISTRATOR
{
{ SYSTEM_ADMINISTRATOR:  (output) This parameter specifies whether or not the
{       current job is currently executing with system administration capability.
{

    avp$system_administrator :=  avp$capability_active (avc$cc_system_admin);

  FUNCEND avp$system_administrator;

*copyc avp$capability_active
?? POP ??
*DECK DECK=AVP$SYSTEM_DISPLAYS EXPAND=TRUE

  FUNCTION [INLINE] avp$system_displays: boolean;

?? PUSH (LISTEXT := ON) ??

{
{   The purpose of this request is to determine if the current job is
{ currently executing with system displays capability.
{
{       AVP$SYSTEM_DISPLAYS  : SYSTEM_DISPLAYS
{
{ SYSTEM_DISPLAYS:  (output) This parameter specifies whether or not the
{       current job is currently executing with system displays capability.
{

    avp$system_displays := avp$capability_active (avc$cc_system_displays);

  FUNCEND avp$system_displays;

*copyc avp$capability_active
?? POP ??
*DECK DECK=AVP$SYSTEM_OPERATOR EXPAND=TRUE

  FUNCTION [INLINE] avp$system_operator: boolean;

?? PUSH (LISTEXT := ON) ??

{
{   The purpose of this request is to determine if the current job is
{ currently executing with system operation capability.
{
{       AVP$SYSTEM_OPERATOR  : SYSTEM_OPERATOR
{
{ SYSTEM_OPERATOR:  (output) This parameter specifies whether or not the
{       current job is currently executing with system operation capability.
{

    avp$system_operator := avp$capability_active (avc$cc_system_operator);

  FUNCEND avp$system_operator;

*copyc avp$capability_active
?? POP ??
*DECK DECK=AVP$UNLOCK_TEMPLATE_FILE EXPAND=FALSE

  PROCEDURE [XREF] avp$unlock_template_file
    (VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_mgr_errors
*copyc avt$template_file_information
*copyc ost$status
?? POP ??

*DECK DECK=AVP$UPDATE_EOJ_TOTAL_LIMITS EXPAND=FALSE

  PROCEDURE [XREF] avp$update_eoj_total_limits
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc avc$validation_field_names
*copyc ave$validation_interface_errors
*copyc ost$status
?? POP ??

*DECK DECK=AVP$VALIDATE_JOB EXPAND=FALSE

  PROCEDURE [XREF] avp$validate_job
    (    user_name: ost$user_name;
         family_name: ost$family_name;
         account: avt$account_name;
         project: avt$project_name;
         validation_attributes: ^avt$validation_items;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc avc$validation_level_names
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc avt$validation_items
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$VALIDATE_NQS_USER EXPAND=FALSE
  PROCEDURE [XREF] avp$validate_nqs_user
    (    user: ost$user_name;
         family: ost$family_name;
         account: avt$account_name;
         project: avt$project_name;
         unix_username: string (* <= 15);
         ring: ost$ring;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc avc$validation_level_names
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc osd$virtual_address
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$VALIDATE_USER EXPAND=FALSE

  PROCEDURE [XREF] avp$validate_user
    (    user: ost$user_name;
         family: ost$family_name;
         password: avt$password;
         account: avt$account_name;
         project: avt$project_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc avc$validation_level_names
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$password
*copyc avt$project_name
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$VALIDATION_LEVEL EXPAND=FALSE

  FUNCTION [XREF] avp$validation_level: avt$validation_level;

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_level_names
*copyc avt$validation_level
?? POP ??
*DECK DECK=AVP$VERIFY_ACCOUNT_EXISTS EXPAND=FALSE

  PROCEDURE [XREF] avp$verify_account_exists
    (    account_name: avt$account_name;
     VAR account_exists: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$template_file_information
*copyc ost$status
?? POP ??
*DECK DECK=AVP$VERIFY_ACCT_MEMBER_EXISTS EXPAND=FALSE

  PROCEDURE [XREF] avp$verify_acct_member_exists
    (    account_name: avt$account_name;
         user_name: ost$user_name;
     VAR account_member_exists: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$template_file_information
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$VERIFY_PROJECT_EXISTS EXPAND=FALSE

  PROCEDURE [XREF] avp$verify_project_exists
    (    account_name: avt$account_name;
         project_name: avt$project_name;
     VAR project_exists: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc avt$template_file_information
*copyc ost$status
?? POP ??
*DECK DECK=AVP$VERIFY_PROJ_MEMBER_EXISTS EXPAND=FALSE

  PROCEDURE [XREF] avp$verify_proj_member_exists
    (    account_name: avt$account_name;
         project_name: avt$project_name;
         user_name: ost$user_name;
     VAR project_member_exists: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$account_name
*copyc avt$project_name
*copyc avt$template_file_information
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$VERIFY_TEMPLATE_HEAP EXPAND=FALSE
  PROCEDURE [XREF] avp$verify_template_heap
    (    family_name: ost$name;
     VAR file_information: {input, output} avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$template_file_damaged
*copyc avt$template_file_information
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$VERIFY_TYPE_CONFORMANCE EXPAND=FALSE
  PROCEDURE [XREF] avp$verify_type_conformance
    (    field_name: ost$name;
         field_value: avt$field_value;
         type_specification: avt$type_specification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$field_value
*copyc avt$type_specification
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=AVP$VERIFY_USER_EXISTS EXPAND=FALSE

  PROCEDURE [XREF] avp$verify_user_exists
    (    user_name: ost$user_name;
     VAR user_exists: boolean;
     VAR file_information: avt$template_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_record_names
*copyc ave$validation_interface_errors
*copyc avt$template_file_information
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=AVP$VERIFY_VALIDATION_NAME EXPAND=FALSE

  PROCEDURE [XREF] avp$verify_validation_name
    (    validation_name: avt$validation_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$validation_name
*copyc ost$status
?? POP ??
*DECK DECK=AVT$ACCOUNT_NAME EXPAND=FALSE

  TYPE
    avt$account_name = ost$name;

*copyc OST$NAME
*DECK DECK=AVT$CONDITIONAL_CAPABILITIES EXPAND=FALSE

 TYPE
   avt$conditional_capabilities = SET OF avt$conditional_capability,

{ Important!  Any time a capability is added to this list the
{ procedure avp$activate_capability in avm$validation_interfaces
{ must be updated accordingly.

   avt$conditional_capability =
     (avc$cc_accounting_admin,
      avc$cc_configuration_admin,
      avc$cc_family_admin,
      avc$cc_removable_media_admin,
      avc$cc_removable_media_operator,
      avc$cc_system_admin,
      avc$cc_system_displays,
      avc$cc_system_operator);

*DECK DECK=AVT$DATE_TIME EXPAND=FALSE

  TYPE
    avt$date_time = record
      date_specified: boolean,
      time_specified: boolean,
      case range: boolean of
      = TRUE =
        starting_value: ost$date_time,
        ending_value: ost$date_time,
      = FALSE =
        value: ost$date_time,
      casend,
    recend;

*copyc ost$date_time
*DECK DECK=AVT$DESCRIPTION_DIRECTORY EXPAND=FALSE

{ Directory, stored in the template file header, used to find description
{ records.  Entries are kept in first in - first out order.  Unused entries
{ have their name field set to OSC$NULL_NAME.

  TYPE
    avt$description_directory = array [1 .. avc$maximum_desc_record_count] of
          avt$description_directory_entry;

*copyc avc$maximum_desc_record_count
*copyc avt$description_directory_entry
*DECK DECK=AVT$DESCRIPTION_DIRECTORY_ENTRY EXPAND=FALSE

  TYPE
    avt$description_directory_entry = record
      name: ost$name,
      record_pointer: avt$template_file_record_ptr,
      utility_information: REL (avt$template_file_heap)
            ^avt$utility_information,
    recend;


*copyc avt$template_file_heap
*copyc avt$template_file_record_ptr
*copyc avt$utility_information
*copyc ost$name
*DECK DECK=AVT$DESCRIPTIVE_TEXT EXPAND=FALSE

  TYPE
    avt$descriptive_text = string ( * <= osc$max_string_size);

*copyc ost$string
*DECK DECK=AVT$FIELD_COUNT EXPAND=FALSE

  TYPE
    avt$field_count = 0 .. avc$maximum_field_count;

*copyc avc$maximum_field_count
*DECK DECK=AVT$FIELD_DELETE_STATUS EXPAND=FALSE

  TYPE
    avt$field_delete_status = record
      case deleted: boolean of
      = TRUE =
        os_version_when_deleted: pmt$os_name,
      = FALSE =
        ,
      casend,
    recend;

*copyc pmt$os_name
*DECK DECK=AVT$FIELD_DESCRIPTION EXPAND=FALSE

{ The field description is an adaptable sequence containing:
{
{       avt$field_description_header
{       avt$internal_type_specification
{       avt$internal_field_value (default value)
{       avt$descriptive_text
{
{ The avt$internal_field_value and avt$descriptive_text fields appear in the
{ sequence only if their corresponding pointers in the description header are
{ not NIL.

  TYPE
    avt$field_description = SEQ ( * );

*copyc avt$descriptive_text
*copyc avt$field_description_header
*copyc avt$internal_type_specification
*copyc avt$internal_field_value
*DECK DECK=AVT$FIELD_DESCRIPTION_HEADER EXPAND=FALSE

  TYPE
    avt$field_description_header = record
      type_specification: REL (avt$field_description)
            ^avt$internal_type_specification,
      default_value: REL (avt$field_description) ^avt$internal_field_value,
      descriptive_text: REL (avt$field_description) ^avt$descriptive_text,
      utility_information: REL (avt$field_description)
            ^avt$utility_information,
    recend;

*copyc avt$descriptive_text
*copyc avt$field_description
*copyc avt$internal_field_value
*copyc avt$internal_type_specification
*copyc avt$utility_information
*DECK DECK=AVT$FIELD_DIRECTORY EXPAND=FALSE

{ Directory, stored in a description record, that is used to find field
{ descriptions.  The directory is kept in alphabetical order by field name.

  TYPE
    avt$field_directory = array [1 .. * ] of avt$field_directory_entry;

*copyc avt$field_directory_entry
*DECK DECK=AVT$FIELD_DIRECTORY_ENTRY EXPAND=FALSE

  TYPE
    avt$field_directory_entry = record
      name: ost$name,
      kind: avt$field_directory_entry_kind,
      system_supplied_field_id: avt$system_supplied_field_id,
      delete_status: avt$field_delete_status,
      description: REL (avt$template_file_record) ^avt$field_description,
    recend;

*copyc ost$name
*copyc avt$field_delete_status
*copyc avt$field_description
*copyc avt$field_directory_entry_kind
*copyc avt$system_supplied_field_id
*copyc avt$template_file_record
*DECK DECK=AVT$FIELD_DIRECTORY_ENTRY_KIND EXPAND=FALSE

  TYPE
    avt$field_directory_entry_kind = (avc$nominal_entry, avc$alias_entry);

*DECK DECK=AVT$FIELD_DIRECTORY_SIZE EXPAND=FALSE

  TYPE
    avt$field_directory_size = 0 .. avc$maximum_field_count;

*copyc avc$maximum_field_count
*DECK DECK=AVT$FIELD_KIND EXPAND=FALSE

  TYPE
    avt$field_kind = 0 .. 31;

  CONST
   avc$account_project_kind = 0,
   avc$accumulating_limit_kind = 1,
   avc$capability_kind = 2,
   avc$date_time_kind = 3,
   avc$file_kind = 4,
   avc$integer_kind = 5,
   avc$job_class_kind = 6,
   avc$keyword_kind = 7,
   avc$limit_kind = 8,
   avc$login_password_kind = 9,
   avc$name_kind = 10,
   avc$real_kind = 11,
   avc$restriction_kind = 12,
   avc$ring_privilege_kind = 13,
   avc$string_kind = 14,
   avc$labeled_names_kind = 15,
   avc$first_unused_kind = 16,
   avc$last_unused_kind = 31;
*DECK DECK=AVT$FIELD_KIND_SET EXPAND=FALSE

  TYPE
    avt$field_kind_set = set of avt$field_kind;

*copyc avt$field_kind
*DECK DECK=AVT$FIELD_UTILITY_INFORMATION EXPAND=FALSE

  TYPE
    avt$field_utility_information = RECORD
      change_authority: avt$validation_authority,
      display_authority: avt$validation_authority,
      manage_authority: avt$validation_authority,
      delete_authority: avt$validation_authority,
      hidden_field: boolean,
    RECEND;

*copyc avt$validation_authority
*DECK DECK=AVT$FIELD_VALUE EXPAND=FALSE

  TYPE
    avt$field_value = record
      case kind: avt$field_kind of
      = avc$account_project_kind =
        account_name: ^avt$account_name,
        project_name: ^avt$project_name,
      = avc$accumulating_limit_kind =
        job_warning_limit: ^avt$limit_value,
        job_maximum_limit: ^avt$limit_value,
        total_limit: ^avt$limit_value,
        total_accumulation: ^avt$limit_value,
      = avc$capability_kind =
        capability: ^boolean,
      = avc$date_time_kind =
        date_time: ^avt$date_time,
      = avc$file_kind =
        file: ^fst$file_reference,
      = avc$integer_kind =
        integer_value: ^integer,
      = avc$job_class_kind =
        job_classes: ^avt$name_list,
        batch_job_class_default: ^ost$name,
        interactive_job_class_default: ^ost$name,
      = avc$keyword_kind =
        ,
      = avc$labeled_names_kind =
        labeled_names: ^avt$labeled_names_list,
      = avc$limit_kind =
        limit_value: ^avt$limit_value,
      = avc$login_password_kind =
        login_password: ^avt$login_password,
        login_password_exp_date: ^ost$date_time,
        login_password_exp_interval: ^pmt$time_increment,
        login_password_max_exp_interval: ^pmt$time_increment,
        login_password_exp_warning: ^pmt$time_increment,
        login_password_exp_chg_interval: ^pmt$time_increment,
        login_password_change_date: ^ost$date_time,
        login_password_attributes: ^avt$name_list,
      = avc$name_kind =
        names: ^avt$name_list,
      = avc$real_kind =
        real_value: ^real,
      = avc$restriction_kind =
        restriction: ^boolean,
      = avc$ring_privilege_kind =
        minimum_ring: ^ost$ring,
        nominal_ring: ^ost$ring,
      = avc$string_kind =
        string_value: ^string ( * <= osc$max_string_size),
      = avc$first_unused_kind .. avc$last_unused_kind =
        unknown_value: ^seq (*),
      casend,
    recend;

*copyc avt$account_name
*copyc avt$date_time
*copyc avt$field_kind
*copyc avt$labeled_names_list
*copyc avt$limit_value
*copyc avt$login_password
*copyc avt$name_list
*copyc avt$project_name
*copyc fst$file_reference
*copyc osd$virtual_address
*copyc ost$date_time
*copyc ost$name
*copyc ost$string
*copyc pmt$time_increment
*DECK DECK=AVT$FIELD_VALUE_LIST EXPAND=FALSE

  TYPE
    avt$field_value_list = ^ avt$field_value_list_entry;

*copyc avt$field_value_list_entry

*DECK DECK=AVT$FIELD_VALUE_LIST_ENTRY EXPAND=FALSE

  TYPE
    avt$field_value_list_entry = record
      field_name: ost$name,
      field_value: avt$field_value,
      forward: ^avt$field_value_list_entry,
    recend;

*copyc ost$name
*copyc avt$field_value
*DECK DECK=AVT$FILE_UTILITY_INFORMATION EXPAND=FALSE


  TYPE
    avt$file_utility_information = record
      new_file: boolean,
      password: string (osc$max_name_size),
      version: avt$version_identifier,
    recend;

*copyc avt$version_identifier
*DECK DECK=AVT$INTERNAL_FIELD_VALUE EXPAND=FALSE

{ The internal field value sequence is used to hold a value for a
{ field in a data record and it is also used to hold the default value for a
{ field in the field description.  The first item in the sequence specifies the
{ kind of the field (avt$field_kind).  The remaining contents vary depending on
{ the field kind.  The following list shows each field kind and what is stored
{ in the remainder of the sequence for each kind of field.
{
{       FIELD KIND                  SEQUENCE CONTAINS
{       avc$account_project_kind    ost$name (account name)
{                                   ost$name (project name)
{       avc$accumulating_limit_kind BOOLEAN (use default job resource limit)
{                                   avt$limit_value(job resource limit)
{                                   BOOLEAN (use default job abort limit)
{                                   avt$limit_value (job abort limit)
{                                   BOOLEAN (total limits apply)
{                                   BOOLEAN (use default totallimit)
{                                   avt$limit_value (total limit)
{                                   avt$limit_value (total accumulation)
{       avc$capability_kind         BOOLEAN
{       avc$date_time_kind          avt$date_time
{       avc$file_kind               fst$path_size
{                                   fst$file_reference
{       avc$integer_kind            INTEGER
{       avc$job_class_kind          BOOLEAN (use default job class list)
{                                   avt$name_list_size
{                                   avt$name_list
{                                   BOOLEAN (use default batch default)
{                                   ost$name (batch default)
{                                   BOOLEAN (use default interactive default)
{                                   ost$name (interactive default)
{       avc$keyword_kind            (not implemented yet)
{       avc$labeled_names_kind      avt$name_list_size (number of labeled names)
{                                   ost$name (label)
{                                   avt$name_list_size (number of names)
{                                   avt$name_list (names)
{       avc$limit_kind              avt$limit_value
{       avc$login_password_kind     avt$login_password
{                                   ost$date_time (expiration date)
{                                   BOOLEAN (use default exp interval default)
{                                   pmt$time_increment (default exp int)
{                                   BOOLEAN (use default max exp int default)
{                                   pmt$time_increment (max exp interval)
{                                   BOOLEAN (use default exp warning interval)
{                                   pmt$time_increment (exp warning_interval)
{                                   BOOLEAN (use default exp pw chg interval)
{                                   pmt$time_increment (exp pw change interval)
{                                   BOOLEAN (use default attributes)
{                                   avt$name_list_size (password attributes)
{                                   avt$name_list
{                                   ost$date_time (last password change date)
{       avc$name_kind               avt$name_list_size
{                                   avt$name_list
{       avc$real_kind               REAL
{       avc$restriction_kind        BOOLEAN
{       avc$ring_privilege_kind     BOOLEAN (use default minimum ring)
{                                   ost$ring (minimum ring)
{                                   BOOLEAN (use default nominal ring)
{                                   ost$ring (nominal ring)
{       avc$string_kind             ost$string_size
{                                   STRING(* <= osc$max_string_size)

  TYPE
    avt$internal_field_value = SEQ ( * );

*copyc avt$date_time
*copyc avt$limit_value
*copyc avt$login_password
*copyc avt$name_list
*copyc avt$name_list_size
*copyc fst$file_reference
*copyc fst$path_size
*copyc osd$virtual_address
*copyc ost$date_time
*copyc ost$name
*copyc ost$string
*copyc pmt$time_increment
*DECK DECK=AVT$INTERNAL_TYPE_SPECIFICATION EXPAND=FALSE

{ The internal type specification sequence is used to hold information about
{ the type for a field in the description record.  The first item in the
{ sequence specifies the kind of the field (avt$field_kind).  The remaining
{ contents vary depending on the field kind.  The following list shows each
{ field kind and what is stored in the remainder of the sequence for each kind
{ of field (if anything).
{
{       FIELD KIND                  SEQUENCE CONTAINS
{       avc$account_project_kind    nothing
{       avc$accumulating_limit_kind ost$name (limit name)
{                                   BOOLEAN (job limits apply)
{                                   avt$limit_value (minimum job limit value)
{                                   avt$limit_value (maximum job limit value)
{                                   INTEGER (update statistic count)
{                                   sft$limit_update_statistics (update stats)
{                                   BOOLEAN (total limits apply)
{                                   BOOLEAN (total limit stops login)
{                                   avt$numeric_display_format (for future use)
{       avc$capability_kind         nothing
{       avc$date_time_kind          boolean (date time range)
{                                   boolean (date applies)
{                                   clt$date_time_form_string(date display format)
{                                   boolean (time applies)
{                                   clt$date_time_form_string(time display format)
{       avc$file_kind               nothing
{       avc$integer_kind            INTEGER (minimum value)
{                                   INTEGER (maximum value)
{                                   avt$numeric_display_format
{       avc$job_class_kind          avt$name_list_size
{                                   avt$name_list (common job classes)
{       avc$keyword_kind            (not implemented yet)
{       avc$labeled_names_kind      avt$name_list_size
{                                   avt$name_list (valid labels)
{                                   avt$name_list_size
{                                   avt$name_list (valid names)
{       avc$limit_kind              INTEGER (minimum value)
{                                   INTEGER (maximum value)
{                                   avt$numeric_display_format (for future use)
{       avc$login_password_kind     nothing
{       avc$name_kind               avt$name_list_size
{                                   avt$name_list (common names)
{                                   avt$name_list_size (min number names)
{                                   avt$name_list_size (max number names)
{       avc$real_kind               REAL (minimum value)
{                                   REAL (maximum value)
{                                   avt$numeric_display_format
{       avc$restriction_kind        nothing
{       avc$ring_privilege_kind     nothing
{       avc$string_kind             ost$string_size (minimum size)
{                                   ost$string_size (maximum size)

  TYPE
    avt$internal_type_specification = SEQ ( * );

*copyc avt$name_list
*copyc avt$name_list_size
*copyc avt$numeric_display_format
*copyc clt$date_time_form_string
*copyc ost$date
*copyc ost$string
*copyc ost$time
*copyc sft$limit_update_statistics
*DECK DECK=AVT$JOB_LIMIT_INFORMATION EXPAND=FALSE

  TYPE
    avt$job_limit_information = record
      case job_limits_apply: boolean of
      = TRUE =
        job_warning_limit: avt$limit_value,
        job_maximum_limit: avt$limit_value,
      = FALSE =
        ,
      casend,
    recend;

*copyc avt$limit_value



*DECK DECK=AVT$LABELED_NAMES EXPAND=FALSE

  TYPE
    avt$labeled_names = record
      label: ^ost$name,
      names: ^avt$name_list,
    recend;

*copyc avt$name_list
*copyc ost$name
*DECK DECK=AVT$LABELED_NAMES_LIST EXPAND=FALSE

  TYPE
    avt$labeled_names_list = array [1 .. * ] of avt$labeled_names;

*copyc avt$labeled_names

*DECK DECK=AVT$LIMIT_VALUE EXPAND=FALSE

  TYPE
    avt$limit_value = sft$counter;

*copyc sfc$unlimited
*copyc sft$counter
*DECK DECK=AVT$LOGIN_PASSWORD EXPAND=FALSE

  TYPE
    avt$login_password = record
      encrypted: boolean,
      value: avt$password,
    recend;

*copyc avt$password
*DECK DECK=AVT$NAME_LIST EXPAND=FALSE

  TYPE
    avt$name_list = array [1 .. * ] of ost$name;

*copyc avt$name_list_size
*copyc ost$name
*DECK DECK=AVT$NAME_LIST_SIZE EXPAND=FALSE

  TYPE
    avt$name_list_size = 0 .. avc$maximum_name_list_size;

*copyc avc$maximum_name_list_size
*DECK DECK=AVT$NUMERIC_DISPLAY_FMT_KIND EXPAND=FALSE

  TYPE
    avt$numeric_display_fmt_kind = (avc$integer_format,
          avc$fixed_point_format, avc$floating_point_format,
          avc$report_style_format);

*DECK DECK=AVT$NUMERIC_DISPLAY_FORMAT EXPAND=FALSE

  TYPE
    avt$numeric_display_format = record
      field_size: ost$string_size,
      case kind : avt$numeric_display_fmt_kind of
      = avc$integer_format =
        radix: 2 .. 16,
        display_radix: boolean,
      = avc$floating_point_format =
        ,
      = avc$fixed_point_format =
        fraction_size: ost$string_size,
      = avc$report_style_format =
        value: string (31),
      casend,
    recend;

*copyc avt$numeric_display_fmt_kind
*copyc ost$string
*DECK DECK=AVT$PASSWORD EXPAND=FALSE

  TYPE
    avt$password = string (osc$max_name_size);

*copyc ost$name
*DECK DECK=AVT$PROJECT_NAME EXPAND=FALSE

  TYPE
    avt$project_name = ost$name;

*copyc OST$NAME
*DECK DECK=AVT$RECORD_UTILITY_INFO_ENTRY EXPAND=FALSE

  TYPE
    avt$record_utility_info_entry = record
      field_name: ost$name,
      command_table_entry: clt$command_table_entry,
    recend;

*copyc ost$name
*copyc clt$command_table
*DECK DECK=AVT$RECORD_UTILITY_INFO_HEADER EXPAND=FALSE

  TYPE
    avt$record_utility_info_header = record
      number_of_commands: integer,
      number_of_entries: integer,
    recend;
*DECK DECK=AVT$SECURITY_OPTION EXPAND=FALSE

  TYPE
    avt$security_option = record
      active: boolean,
      specified: boolean,
    recend;




*DECK DECK=AVT$SECURITY_OPTION_NAME EXPAND=FALSE

  TYPE
    avt$security_option_name = ost$name;

{ Constant names for security options.

?? FMT (FORMAT := OFF) ??
  CONST
    avc$console_operation_only      = 'CONSOLE_OPERATION_ONLY         ',
    avc$secure_analysis             = 'SECURE_ANALYSIS                ',
    avc$security_audit              = 'SECURITY_AUDIT                 ';
?? FMT (FORMAT := ON) ??

*copyc ost$name
*DECK DECK=AVT$SRU_CALCULATION_INTERVAL EXPAND=FALSE

  TYPE
    avt$sru_calculation_interval = 1 .. 100;
*DECK DECK=AVT$SYSTEM_SUPPLIED_FIELD_ID EXPAND=FALSE

  TYPE
    avt$system_supplied_field_id = 0 .. 0ffff(16);
*DECK DECK=AVT$TEMPLATE_FILE EXPAND=FALSE

{ A template file is a sequence that contains a template file header followed
{ by a template file heap.

  TYPE
    avt$template_file = SEQ ( * );

*copyc avt$template_file_header
*copyc avt$template_file_heap
*DECK DECK=AVT$TEMPLATE_FILE_HEADER EXPAND=FALSE

  TYPE
    avt$template_file_header = record
      version_identifier: avt$version_identifier,
      utility_information: REL (avt$template_file_heap)
            ^avt$utility_information,
      next_system_supplied_field_id: avt$system_supplied_field_id,
      root_index_record: avt$template_file_record_ptr,
      first_index_record: avt$template_file_record_ptr,
      index_depth: avt$template_file_index_depth,
      description_record_count: 0 .. avc$maximum_desc_record_count,
      description_directory: avt$description_directory,
    recend;

*copyc avt$description_directory
*copyc avt$system_supplied_field_id
*copyc avt$template_file_heap
*copyc avt$template_file_index_depth
*copyc avt$template_file_record_ptr
*copyc avt$utility_information
*copyc avt$version_identifier
*DECK DECK=AVT$TEMPLATE_FILE_HEAP EXPAND=FALSE

{ Heap used to store index records, description records, file level utility
{ information and data records in the template file.

  TYPE
    avt$template_file_heap = ost$heap;

*copyc ost$heap
*DECK DECK=AVT$TEMPLATE_FILE_INDEX EXPAND=FALSE

  TYPE
    avt$template_file_index = array [1 .. avc$max_template_index_keys] of
          avt$template_file_index_entry;

*copyc avc$max_template_index_keys
*copyc avt$template_file_index_entry
*DECK DECK=AVT$TEMPLATE_FILE_INDEX_DEPTH EXPAND=FALSE

  TYPE
    avt$template_file_index_depth = 0 .. avc$maximum_index_depth;

*copyc avc$maximum_index_depth
*DECK DECK=AVT$TEMPLATE_FILE_INDEX_ENTRY EXPAND=FALSE

  TYPE
    avt$template_file_index_entry = record
      key: avt$template_file_key,
      record_pointer: avt$template_file_record_ptr,
    recend;

*copyc avt$template_file_key
*copyc avt$template_file_record_ptr
*DECK DECK=AVT$TEMPLATE_FILE_INFORMATION EXPAND=FALSE

  TYPE
    avt$template_file_information = record
      file_name: string (fsc$max_path_size),
      file_id: amt$file_identifier,
      last_key_accessed: avt$template_file_key,
      segment_number: ost$segment,
      size: ost$segment_length,
      template_file_header: REL (avt$template_file) ^avt$template_file_header,
      template_file_heap: REL (avt$template_file) ^avt$template_file_heap,
      case locked: boolean of
      = TRUE =
        lock_type: avt$template_file_lock_type,
      = FALSE =
        ,
      casend,
    recend;

*copyc amt$file_identifier
*copyc avt$template_file
*copyc avt$template_file_header
*copyc avt$template_file_heap
*copyc avt$template_file_key
*copyc avt$template_file_lock_type
*copyc fsc$max_path_size
*copyc osd$virtual_address
*DECK DECK=AVT$TEMPLATE_FILE_KEY EXPAND=FALSE

  TYPE
    avt$template_file_key = string (avc$max_template_file_key_size);

*copyc avc$max_template_file_key_size
*DECK DECK=AVT$TEMPLATE_FILE_LOCK_TYPE EXPAND=FALSE

  TYPE
    avt$template_file_lock_type = (avc$update_access, avc$read_access);

*DECK DECK=AVT$TEMPLATE_FILE_RECORD EXPAND=FALSE

{ This is the type used to store information in the template file heap.
{ Three kinds of records can be stored in the heap:  data records, index
{ records, and description records.

  TYPE
    avt$template_file_record = SEQ ( * );

*copyc avc$max_template_record_size
*copyc avt$template_file_index
*copyc avt$template_file_record_header
*DECK DECK=AVT$TEMPLATE_FILE_RECORD_HEADER EXPAND=FALSE

  TYPE
    avt$template_file_record_header = record
      case kind: avt$template_file_record_kind of
      = avc$data_record =
        description_record_index: 1 .. avc$maximum_desc_record_count,
        value_directory_pointer: REL (avt$template_file_record)
              ^avt$value_directory,
      = avc$description_record =
        name: ost$name,
        field_directory_pointer: REL (avt$template_file_record)
              ^avt$field_directory,
      = avc$index_record =
        keys_in_use: avt$template_index_key_count,
        previous_index_record: avt$template_file_record_ptr,
        next_index_record: avt$template_file_record_ptr,
        { avt$template_file_index follows header}
      casend,
    recend;

*copyc avc$maximum_desc_record_count
*copyc avt$field_directory
*copyc avt$template_file_index
*copyc avt$template_file_record
*copyc avt$template_file_record_kind
*copyc avt$template_file_record_ptr
*copyc avt$template_index_key_count
*copyc avt$value_directory
*copyc ost$name
*DECK DECK=AVT$TEMPLATE_FILE_RECORD_KIND EXPAND=FALSE

  TYPE
    avt$template_file_record_kind = (avc$data_record, avc$description_record,
          avc$index_record);

*DECK DECK=AVT$TEMPLATE_FILE_RECORD_PTR EXPAND=FALSE

  TYPE
    avt$template_file_record_ptr = REL (avt$template_file_heap)
          ^avt$template_file_record;

*copyc avt$template_file_heap
*copyc avt$template_file_record
*DECK DECK=AVT$TEMPLATE_INDEX_KEY_COUNT EXPAND=FALSE

  TYPE
    avt$template_index_key_count = 0 .. avc$max_template_index_keys;

*copyc avc$max_template_index_keys
*DECK DECK=AVT$TOTAL_LIMIT_INFORMATION EXPAND=FALSE

  TYPE
    avt$total_limit_information = record
      case total_limit_applies: boolean of
      = TRUE =
        total_limit: avt$limit_value,
        total_accumulation: avt$limit_value,
      = FALSE =
        ,
      casend,
    recend;

*copyc avt$limit_value

*DECK DECK=AVT$TOTAL_LIMIT_UPDATE_RECORD EXPAND=FALSE

  TYPE
    avt$total_limit_update_record = record
      family_name: ost$family_name,
      validation_key: avt$validation_key,
      size: integer,
    recend;

*copyc avt$validation_key
*copyc ost$user_identification
*DECK DECK=AVT$TYPE_SPECIFICATION EXPAND=FALSE

  TYPE
    avt$type_specification = record
      case kind: avt$field_kind of
      = avc$account_project_kind =
        ,
      = avc$accumulating_limit_kind =
        limit_name: ^ost$name,
        job_limits_apply: ^boolean,
        limit_update_statistics: ^sft$limit_update_statistics,
        minimum_job_limit_value: ^avt$limit_value,
        maximum_job_limit_value: ^avt$limit_value,
        total_limit_applies: ^boolean,
        total_limit_stops_login: ^boolean,
      = avc$capability_kind =
        ,
      = avc$date_time_kind =
        date_time_range: ^boolean,
        date_applies: ^boolean,
        date_display_format: ^clt$date_time_form_string,
        time_applies: ^boolean,
        time_display_format: ^clt$date_time_form_string,
      = avc$file_kind =
        ,
      = avc$integer_kind =
        minimum_integer_value: ^integer,
        maximum_integer_value: ^integer,
        integer_display_format: ^avt$numeric_display_format,
      = avc$job_class_kind =
        common_job_classes: ^avt$name_list,
      = avc$keyword_kind =
        ,
      = avc$labeled_names_kind =
        valid_labels: ^avt$name_list,
        valid_names: ^avt$name_list,
      = avc$limit_kind =
        minimum_limit_value: ^avt$limit_value,
        maximum_limit_value: ^avt$limit_value,
      = avc$login_password_kind =
        ,
      = avc$name_kind =
        minimum_number_of_names: ^avt$name_list_size,
        maximum_number_of_names: ^avt$name_list_size,
        common_names: ^avt$name_list,
      = avc$real_kind =
        minimum_real_value: ^real,
        maximum_real_value: ^real,
        real_display_format: ^avt$numeric_display_format,
      = avc$restriction_kind =
        ,
      = avc$ring_privilege_kind =
        ,
      = avc$string_kind =
        minimum_string_size: ^ost$string_size,
        maximum_string_size: ^ost$string_size,
      = avc$first_unused_kind .. avc$last_unused_kind =
        unknown_type: ^seq (*),
      casend,
    recend;

*copyc avc$date_time_display_formats
*copyc avt$field_kind
*copyc avt$limit_value
*copyc avt$name_list
*copyc avt$name_list_size
*copyc avt$numeric_display_format
*copyc clt$date_time_form_string
*copyc ost$string
*copyc sft$limit_update_statistics
*DECK DECK=AVT$UTILITY_INFORMATION EXPAND=FALSE

{ This is a sequence that can be used to store utility specific information
{ at the template file, description record and field description levels.

  TYPE
    avt$utility_information = SEQ ( * );

*DECK DECK=AVT$VALIDATED_LIMIT EXPAND=FALSE

  TYPE
    avt$validated_limit = record
      field_name: ost$name,
      limit_name: ost$name,
      job_maximum_limit: avt$limit_value,
      forward: ^avt$validated_limit,
      case kind: avt$field_kind of
      = avc$accumulating_limit_kind =
        initial_value: avt$limit_value,
        job_warning_limit: avt$limit_value,
        statistic_codes: ^sft$limit_update_statistics,
        enforcement: sft$enforcement,
        total_limit_applies: boolean,
      = avc$limit_kind =
        ,
      casend,
    recend;

*copyc ost$name
*copyc avt$field_kind
*copyc avt$limit_value
*copyc sft$enforcement
*copyc sft$limit_update_statistics
*copyc sft$statistic_code
*DECK DECK=AVT$VALIDATION_AUTHORITY EXPAND=FALSE

  TYPE
    avt$validation_authority = 0 .. 255;

  CONST
    avc$any_authority = 16,
    avc$user_authority = 48,
    avc$project_admin_authority = 80,
    avc$account_admin_authority = 112,
    avc$user_admin_authority = 144,
    avc$family_admin_authority = 176,
    avc$system_admin_authority = 208,
    avc$system_authority = 240;


*DECK DECK=AVT$VALIDATION_FILE_TYPE EXPAND=FALSE

  TYPE
    avt$validation_file_type = (avc$vft_other, avc$vft_system, avc$vft_active_system);
*DECK DECK=AVT$VALIDATION_ITEMS EXPAND=FALSE

  TYPE
    avt$validation_items = array [1 .. * ] of avt$validation_item;

  TYPE
    avt$validation_item = record
      case key: avt$validation_keys of
      = avc$account_project_key =
        account_name: avt$account_name,
        project_name: avt$project_name,
      = avc$job_class_name_key =
        job_class_name: jmt$job_class_name,
      = avc$job_class_defaults_key =
        batch_job_class_default: ost$name,
        interactive_job_class_default: ost$name,
      = avc$job_execution_ring_key =
        job_execution_ring: ost$ring,
      = avc$job_limit_key =
        limit_name: ost$name,
        user_specified: boolean,
        job_maximum: sft$counter,
      = avc$labeled_names_key =
        labeled_names_field: ost$name,
        work_area: ^seq (*),
        labeled_names: ^avt$labeled_names_list,
      = avc$null_validation_key =
        ,
      = avc$optional_capability_key =
        optional_capability: ost$name,
      = avc$password_key =
        password: avt$password,
      = avc$required_capability_key =
        required_capability: ost$name,
      = avc$terminal_name =
        terminal_name: ift$terminal_name,
      = avc$unix_username_key =
        unix_username: string (15),
      = avc$valid_job_classes_key =
        job_classes: ^array [1 .. * ] of ost$name,
        count: integer,
      casend,
    recend;

*copyc avt$account_name
*copyc avt$labeled_names_list
*copyc avt$project_name
*copyc avt$password
*copyc avt$validation_keys
*copyc ift$terminal_name
*copyc jmt$job_class_name
*copyc osd$virtual_address
*copyc ost$name
*copyc sft$counter
*DECK DECK=AVT$VALIDATION_KEY EXPAND=FALSE

  TYPE
    avt$validation_key = record
      case boolean of
      = TRUE =
        value: avt$template_file_key,
      = FALSE =
        account_name: avt$account_name,
        project_name: avt$project_name,
        user_name: ost$user_name,
      casend,
    recend;

*copyc avc$high_value_name
*copyc avt$template_file_key
*copyc ost$user_identification
*copyc avt$account_name
*copyc avt$project_name
*DECK DECK=AVT$VALIDATION_KEYS EXPAND=FALSE

  TYPE
    avt$validation_keys = (avc$account_project_key, avc$job_class_name_key,
          avc$job_class_defaults_key, avc$job_execution_ring_key,
          avc$job_limit_key, avc$job_mode_key, avc$labeled_names_key,
          avc$null_validation_key, avc$optional_capability_key,
          avc$password_key, avc$required_capability_key, avc$terminal_name,
          avc$unix_username_key, avc$valid_job_classes_key);

*DECK DECK=AVT$VALIDATION_LEVEL EXPAND=FALSE

  TYPE
    avt$validation_level = (avc$user_level, avc$account_level, avc$project_level);

*DECK DECK=AVT$VALIDATION_NAME EXPAND=FALSE

  TYPE
    avt$validation_name = record
      case kind: avt$validation_name_kind of
      = avc$vnk_account =
        account_name: avt$account_name,
      = avc$vnk_project =
        project_name: avt$project_name,
      = avc$vnk_user =
        user_name: ost$user_name,
      casend,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc avt$validation_name_kind
*copyc ost$user_identification

*DECK DECK=AVT$VALIDATION_NAME_KIND EXPAND=FALSE

  TYPE
    avt$validation_name_kind = (avc$vnk_account, avc$vnk_project,
          avc$vnk_user);

*DECK DECK=AVT$VALIDATION_RECORD EXPAND=FALSE

  TYPE
    avt$validation_record = 0 .. avc$maximum_desc_record_count;

  CONST
    avc$user = 0,
    avc$account = 1,
    avc$project = 2,
    avc$account_member = 3,
    avc$project_member = 4;

*copyc avc$maximum_desc_record_count
*DECK DECK=AVT$VALIDATION_RECORD_INFO EXPAND=FALSE

  TYPE
    avt$validation_record_info = record
      record_id: ost$name,
      work_area: amt$segment_pointer,
      key: avt$validation_key,
      description_record_name: ost$name,
      data_record: ^avt$template_file_record,
      description_record: ^avt$template_file_record,
      record_utility_information: ^avt$utility_information,
      caller_authority: avt$validation_authority,
      field_value_list: avt$field_value_list,
      backward: ^avt$validation_record_info,
      forward: ^avt$validation_record_info,
    recend;

*copyc amt$segment_pointer
*copyc avt$field_value_list
*copyc avt$utility_information
*copyc avt$template_file_record
*copyc avt$validation_key
*copyc ost$name
*DECK DECK=AVT$VALID_SECURITY_OPTIONS EXPAND=FALSE

  TYPE
    avt$valid_security_options = (avc$vso_console_operation_only,
          avc$vso_secure_analysis, avc$vso_security_audit);
*DECK DECK=AVT$VALUE_DIRECTORY EXPAND=FALSE

  TYPE
    avt$value_directory = array [1 .. * ] of avt$value_directory_entry;

*copyc avt$value_directory_entry
*DECK DECK=AVT$VALUE_DIRECTORY_ENTRY EXPAND=FALSE

  TYPE
    avt$value_directory_entry = record
      system_supplied_field_id: avt$system_supplied_field_id,
      value: REL (avt$template_file_record) ^avt$internal_field_value,
    recend;

*copyc avt$internal_field_value
*copyc avt$system_supplied_field_id
*copyc avt$template_file_record
*DECK DECK=AVT$VERSION_IDENTIFIER EXPAND=FALSE

  TYPE
    avt$version_identifier = ost$name;

*copyc ost$name
*DECK DECK=AVT$WORKING_SET_SIZE EXPAND=FALSE

  CONST
    avc$min_working_set_size = 0,
    avc$max_working_set_size = 65535;

  TYPE
    avt$working_set_size = 0 .. avc$max_working_set_size;
*DECK DECK=AVV$ACCOUNT_NAME EXPAND=FALSE

  VAR
    avv$account_name: [XREF] avt$account_name;

*copyc avt$account_name
*DECK DECK=AVV$ACCUMULATED_SRUS EXPAND=FALSE

  VAR
    avv$accumulated_srus: [XREF] sft$counter;
*DECK DECK=AVV$ACTIVE_SOU_CAPABILITIES EXPAND=TRUE
  VAR
    avv$active_sou_capabilities: [XREF, oss$task_shared]
      avt$conditional_capabilities;

?? PUSH (LISTEXT := ON) ??
*copyc avt$conditional_capabilities
*copyc oss$task_shared
?? POP ??
*DECK DECK=AVV$COND_CAPABILITY_NAMES EXPAND=FALSE

  VAR
    avv$cond_capability_names: [XREF] array [avt$conditional_capability] of ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc avt$conditional_capabilities
*copyc ost$Name
?? POP ??
*DECK DECK=AVV$DEBUG_ACCOUNTING_VALIDATION EXPAND=TRUE
  VAR
    avv$debug_accounting_validation: [XREF, READ] boolean;

*DECK DECK=AVV$FIELD_KIND_NAMES EXPAND=FALSE

  VAR
    avv$field_kind_names: [XREF] array [avt$field_kind] of ost$name;

*copyc avt$field_kind
*copyc ost$name
*DECK DECK=AVV$JOB_PAGEABLE_VAL_INFO EXPAND=FALSE

  VAR
    avv$user_data_record: [XREF] ^avt$template_file_record,
    avv$account_data_record: [XREF] ^avt$template_file_record,
    avv$account_member_data_record: [XREF] ^avt$template_file_record,
    avv$project_data_record: [XREF] ^avt$template_file_record,
    avv$project_member_data_record: [XREF] ^avt$template_file_record,
    avv$user_description_record: [XREF] ^avt$template_file_record,
    avv$account_description_record: [XREF] ^avt$template_file_record,
    avv$account_member_desc_record: [XREF] ^avt$template_file_record,
    avv$project_description_record: [XREF] ^avt$template_file_record,
    avv$project_member_desc_record: [XREF] ^avt$template_file_record;

?? PUSH (LISTEXT := ON) ??
*copyc avt$template_file_record
?? POP ??
*DECK DECK=AVV$MONITOR_STATISTICS_LOCK EXPAND=FALSE

  VAR
    avv$monitor_statistics_lock: [XREF] ost$signature_lock;

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??
*DECK DECK=AVV$PRODUCTION_ENVIRON_BEGUN EXPAND=TRUE
  VAR
    avv$production_environ_begun: [XREF, oss$task_shared] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc oss$task_shared
?? POP ??
*DECK DECK=AVV$PROJECT_NAME EXPAND=FALSE

  VAR
    avv$project_name: [XREF] avt$project_name;

*copyc avt$project_name
*DECK DECK=AVV$SECURITY_OPTIONS EXPAND=FALSE

  VAR
    avv$security_options: [XREF] array [avt$valid_security_options] of
          avt$security_option;

?? PUSH (LISTEXT := ON) ??
*copyc avt$security_option
*copyc avt$valid_security_options
?? POP ??
*DECK DECK=AVV$SECURITY_OPTION_NAMES EXPAND=FALSE

  VAR
    avv$security_option_names: [STATIC, READ, oss$mainframe_paged_literal]
          array [avt$valid_security_options] of avt$security_option_name :=
          [avc$console_operation_only, avc$secure_analysis,
          avc$security_audit];

*copyc avt$security_option_name
*copyc avt$valid_security_options
*copyc oss$job_paged_literal
*DECK DECK=AVV$VALIDATED_LIMITS EXPAND=FALSE

  VAR
    avv$validated_limits: [XREF] ^avt$validated_limit;

?? PUSH (LISTEXT := ON) ??
*copyc avt$validated_limit
?? POP ??
*DECK DECK=AVV$VALIDATED_SOU_CAPABILITIES EXPAND=TRUE

  VAR
    avv$validated_sou_capabilities: [XREF, oss$task_shared]
      avt$conditional_capabilities;

?? PUSH (LISTEXT := ON) ??
*copyc avt$conditional_capabilities
*copyc oss$task_shared
?? POP ??
*DECK DECK=AVV$VALIDATION_LEVEL EXPAND=FALSE

  VAR
?IF avc$compile_test_code THEN
    avv$validation_level: [XDCL] 0 .. 255;
?ELSE
    avv$validation_level: [XREF] 0 .. 255;
?IFEND
*DECK DECK=BAC$MAX_TAPE_BUFFER_GROUP_SIZE EXPAND=FALSE
  CONST
    bac$max_tape_buffer_group_size = ioc$max_tape_blocks_to_process + 1;
*DECK DECK=BAC$MINIMUM_OPEN_RING EXPAND=FALSE
{ This constant specifies the minimum ring at which a file can be opened.
{ This constant is used as the validation ring on some memory management calls.

  CONST
    bac$minimum_open_ring = 2;
*DECK DECK=BAC$OTHER_REQUESTS EXPAND=FALSE

{
{ These are fap requests that are neither read nor write orientated.
{

    = amc$fetch_access_information_rq, amc$last_access_start,
          amc$abandon_key_definitions, amc$abort_file_parcel, amc$apply_key_definitions,
          amc$begin_file_parcel, amc$check_buffer_req, amc$check_nowait_request,
          amc$check_record_req, amc$close_req, amc$close_volume_req, amc$commit_file_parcel,
          amc$create_key_definition, amc$create_nested_file, amc$delete_key_definition,
          amc$delete_key_req, amc$delete_nested_file, amc$delete_req, amc$fetch_req,
          amc$find_record_space, amc$get_key_definitions, amc$get_key_req, amc$get_label_req,
          amc$get_lock_keyed_record, amc$get_lock_next_keyed_record, amc$get_nested_file_definitions,
          amc$get_next_key_req, amc$get_next_primary_key_list, amc$get_primary_key_count,
          amc$get_segment_pointer_req, amc$get_space_used_for_key, {amc$lock_file,} amc$lock_file_req,
          amc$lock_key, amc$open_req, amc$pack_block_req, amc$pack_record_req, amc$put_key_req,
          amc$put_label_req, amc$read_direct_req, amc$read_direct_skip_req, amc$read_req,
          amc$read_skip_req, amc$replace_key_req, amc$rewind_req, amc$rewind_volume_req,
          amc$seek_direct_req, amc$select_key, amc$select_nested_file, amc$separate_key_groups,
          amc$set_segment_eoi_req, amc$set_segment_position_req, amc$start_req,
          amc$store_req, {amc$unlock_file,} amc$unlock_file_req, amc$unlock_key, amc$unpack_block_req,
          amc$unpack_record_req, amc$user_defined_access_request, amc$write_direct_req,
          amc$write_req, ifc$fetch_terminal_req, ifc$store_terminal_req =
*DECK DECK=BAC$READ_REQUESTS EXPAND=FALSE

{
{ Read requests.
{

    = amc$get_direct_req, amc$get_next_req, amc$get_partial_req, amc$skip_req =

*DECK DECK=BAC$UNUSED_REQUEST_TABLE_ENTRY EXPAND=FALSE

  CONST
    bac$unused_request_table_entry = 'UNUSED_REQUEST_NAME_TABLE_ENTRY';
*DECK DECK=BAC$WRITE_REQUESTS EXPAND=FALSE

{
{ Write requests.
{

    = amc$delete_direct_req, amc$erase_tape_block, amc$flush_req, amc$put_direct_req,
          amc$put_next_req, amc$put_partial_req, amc$putrep_req, amc$replace_direct_req,
          amc$replace_req, amc$write_end_partition_req, amc$write_tape_mark_req =

*DECK DECK=BAE$TAPE_BM_ERROR_CODES EXPAND=FALSE
*copyc amc$condition_code_limits
?? NEWTITLE := 'TAPE_BM  requests - actions : ''AM'' 3000 .. 3099', EJECT ??

?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := OFF) ??

     { ame$tape_program_actions }


  CONST
    bac$basic_access_id = 'BA',
    amc$min_ecc_tape_bm_actions = amc$min_ecc_program_action + 2000,


    bae$block_truncated = amc$min_ecc_tape_bm_actions + 0,
    bae$block_larger_than_maxbl = amc$min_ecc_tape_bm_actions + 1,
    bae$unreserved_buffer_used = amc$min_ecc_tape_bm_actions + 2,
    bae$read_error_this_block = amc$min_ecc_tape_bm_actions + 4,
    bae$write_error_this_block = amc$min_ecc_tape_bm_actions + 5,
    bae$write_error_previous_block = amc$min_ecc_tape_bm_actions + 6,
    bae$vol_end_operation_inhibited = amc$min_ecc_tape_bm_actions + 7,
    bae$vol_end_operation_completed = amc$min_ecc_tape_bm_actions + 8,
    bae$too_many_reserved_buffers = amc$min_ecc_tape_bm_actions + 9,
    bae$input_after_output = amc$min_ecc_tape_bm_actions + 11,
    bae$unimplemented_request = amc$min_ecc_tape_bm_actions + 12,
    bae$uncertain_tape_position = amc$min_ecc_tape_bm_actions + 13,
    bae$skip_encountered_bov = amc$min_ecc_tape_bm_actions + 14,
    bae$tape_block_mgr_malfunction = amc$min_ecc_tape_bm_actions + 15,
    bae$multiple_open_of_tape = amc$min_ecc_tape_bm_actions + 16,
    bae$improper_file_id = amc$min_ecc_tape_bm_actions + 17,
    bae$no_tape_write_ring = amc$min_ecc_tape_bm_actions + 18,
    bae$ring_validation_error = amc$min_ecc_tape_bm_actions + 19,
    bae$improper_input_attempt = amc$min_ecc_tape_bm_actions + 20,
    bae$improper_access_attempt = amc$min_ecc_tape_bm_actions + 21,
    bae$tape_driver_not_capable = amc$min_ecc_tape_bm_actions + 22, {maxbl > tape driver capability}
    bae$cannot_lock_tape_pages = amc$min_ecc_tape_bm_actions + 23,  {maxbl > amount of memory which }
    {                                                                can be locked down and have the }
    {                                                                RMA list fit in one page }
    bae$maxbl_exceeds_ws_limit = amc$min_ecc_tape_bm_actions + 24,  {MAXBL too close to working set limit}
    bae$density_mismatch = amc$min_ecc_tape_bm_actions + 25,
    bae$cartridge_tape_erase_limit = amc$min_ecc_tape_bm_actions + 26,
    bae$motion_past_phys_eot = amc$min_ecc_tape_bm_actions + 27,

    amc$max_ecc_tape_bm_actions = amc$min_ecc_tape_bm_actions + 999;
*DECK DECK=BAH$ADD_TO_FILE_DESCRIPTION EXPAND=FALSE

{ COMMON DECK BAHATFD }

{   The purpose of this request is to provide the ring 3 interface for
{ amp$add_to_file_description.
{
{       BAP$ADD_TO_FILE_DESCRIPTION (FILE_IDENTIFIER, FILE_ATTRIBUTES,
{         STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access identifier
{       which was an actual parameter passed to the fap making this request.
{
{ FILE_ATTRIBUTES: (input) This parameter specifies the attribute values to
{       be added to the file description.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=BAH$ASSIGN_SB EXPAND=FALSE
{
{
{     This request is used to assign a system buffer and associated
{     system buffer descriptor to a file.  The system buffer descriptor
{     will be linked into the files system buffer descriptor chain.
{
{ BAP$ASSIGN_SB (KFT_DESCRIPTOR,SBD_PTR,BYTE_ADDRESS,STATUS)
{
{    KFT_DESCRIPTOR : (input) this parameter specifies the known file
{                      table descriptor.
{
{    SBD_PTR : (output) this parameter specifies a pointer to a system
{              buffer descriptor. NIL will be returned if a system buffer
{              was not assigned.
{
{    BYTE_ADDRESS : (input) this parameter specifies the starting address
{                    of the system buffer address range.
{
{    STATUS : (output) this parameter specifies request status.
{
*DECK DECK=BAH$AVAILABLE_BUFFER_SPACE EXPAND=FALSE
{
{
{     This request will return the amount of space remaining in a
{     system buffer.
{
{ BAP$AVAILABLE_BUFFER_SPACE (KFT_DESCRIPTOR,SBD_PTR,AVAILABLE_SPACE,
{                               PVA,START_INDEX,STATUS)
{
{   KFT_DESCRIPTOR : (input) this parameter specifies the known file
{                     name table entry.
{
{   SBD_PTR : (input) this parameter specifies a pointer to the system
{            buffer descriptor of the system buffer to interogate.
{
{   AVAILABLE_SPACE : (output) this parameter specifies the amount of
{                    space remaining in the current system buffer.
{
{   PVA : (output) this parameter specifies a pointer to an adaptable
{          array.
{
{   START_INDEX : (output) this parameter specifies the starting index
{                  to the adaptable array pva.
{
{   STATUS : (output) this parmeter specifies request status.
{
{
*DECK DECK=BAH$BLOCK_MANAGEMENT_FUNCTIONS EXPAND=FALSE
{}
{ COMMON DECK BAH$BLOCK_MANAGEMENT_FUNCTIONS}
{}
{    These inline procedures are for use with  faps which process blocked files.
{ The procedures do generalized functions for basic blocking.
{}
{}
*DECK DECK=BAH$BYTE_MOVE EXPAND=FALSE

{ COMMON DECK BAHBMV
{
{ The purpose of this procedure is to perform byte moves using i#move
{ from an input file to an output file. NOTE: This procedure is intended
{ for use only by amp$copy_file.  To use this procedure both files must
{ be positioned at the same offset.  The maximum single transfer of data
{ is 500,000 bytes (this allows condition handlers in amp$copy_file to
{ regain control).
{
{  BAP$BYTE_MOVE (FROM_FID, TO_FID, MOVE, LAST_MOVE, BYTE_OFFSET,
{     STATUS)
{
{ FROM_FID: (input) This parameter specifies the file_identifier of the
{   file data will be taken from.
{
{ TO_FID: (input) This parameter specifies the file_identifier of the
{   file to which data will be moved.
{
{ MOVE: (input) This parameter is an integer value specifying the number
{   of bytes of data to be moved.
{
{ LAST_MOVE: (input) This parameter is a boolean used to tell byte_move if
{   this call is the last call required to complete the copy.  If true
{   then bap$byte_move will complete updating of file positioning
{   information to reflect eoi.
{
{ BYTE_OFFSET: (input, output) This parameter specifies the byte offset
{   into the files at which the transfer of data is to start, and returns
{   the byte offset into the files after the data transfer is complete.
{
{ STATUS: (output) This parameter specifies the request status.
*DECK DECK=BAH$CKECK_FILE_TABLE EXPAND=FALSE

{ HEADER DECK BAHCKFT }

{   This procedure updates file transfer descriptor fields that have been
{ changed by amp$file requests.  If a request to update a field that does
{ not exist in the ftd occurs, a bad status is returned.  The entries that
{ are changed in the ftd are then deleted from the file table list.
{
{ BAP$CKECK_FILE_TABLE (FTD, FILE_TABLE, STATUS)
{
{      FTD : (input) This parameter specifies a pointer to the file transfer
{                    descriptor.
{
{      FILE_TABLE : (input, output) This parameter specifies a pointer to the
{                    file table.
{
{      STATUS : (output) This parameter specifies the request status.
{
*DECK DECK=BAH$CLOSE EXPAND=FALSE

{
{    the purpose of this request is to provide a method to close
{     a local file.
{
{  BAP$CLOSE (FILE_IDENTIFIER, STATUS)}
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access}
{        identifier established when the file was opened.}
{
{ STATUS: (output) This parameter specifies the request status.}
{

*DECK DECK=BAH$CONNECTED_FILE_DEVICE EXPAND=FALSE
{
{   This is the file access procedure (fap) for files that are the subject  of
{ file  connections.   Only  record  level access is supported.  The following
{ notes descirbe the processing involved for various requests.
{
{   1.  If the subject file is not  connected  to  any  target  files  or  no
{       descriptor can be found for the subject file, the request is  passed
{       to the "null device" fap.
{   2.  Output requests are passed on to all connected target files.
{   3.  Input  requests  are  passed  on  only  to the most recently connected
{       target file.
{   4.  The amc$fetch_access_information_rq is passed on to the most  recently
{       connected  target  file  if  the  last_access_operation  was  an input
{       request, otherwise it is passed on to  the  least  recently  connected
{       target file.
{   5.  The amc$fetch_req and amc$store_req requests are passed on only to the
{       least recently connected target file.  Store is also processed for the
{       subject file itself.
{   6.  The  ifp$fetch_terminal  and ifp$store_terminal requests are passed on
{       to the most recently connected target  file  that  is  assigned  to  a
{       terminal.
{
{   The first error detected during the processing of a request is reported as
{ the completion status  of  the  request.   For  requests  other  than  open,
{ processing  continues  in  order to allow the effect of the request to reach
{ all possible target files (errors other than the first are ignored).
{
{
{       BAP$CONNECTED_FILE_DEVICE (FILE_IDENTIFIER, CALL_BLOCK, LAYER_NUMBER,
{         STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access identifier
{       established when the file was opened.
{
{ CALL_BLOCK:  (input)  This parameter specifies the call block that describes
{       the request to be performed.
{
{ LAYER_NUMBER: (input) This  parameter  specifies  the  index  into  the  fap
{       control information for this layer.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=BAH$CREATE_SUB_DESCRIPTORS EXPAND=FALSE
{
{
{         This request creates and initializes subbuffer descriptors
{      for a sysytem buffer descriptor.  The number of subbuffers
{      created is based on a base subbuffer size and the system buffer
{      size.
{
{ BAP$CREATE_SUB_DESCRIPTORS(sbd_ptr)
{
{      SBD_PTR : (input) this parameter specifies a pointer to a system
{                 buffer descriptor.
{
*DECK DECK=BAH$DELETE_ART_ENTRY EXPAND=FALSE

{ COMMON DECK BAHDART }

{   The purpose of this request is to delete the entry in the auxiliary
{ request table associated with the local file name.
{
{       BAP$DELETE_ART_ENTRY (LOCAL_FILE_NAME, STATUS)
{
{ LOCAL_FILE_NAME: (input) This parameter specifies the local file name of
{       the entry to be deleted.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=BAH$DELETE_DATA EXPAND=FALSE

{      The purpose of this request is to delete the data in a file.
{  This was created for use by fsp$copy_file so that the data in
{  the output file is deleted only if all the requirements of fsp$copy_file
{  and delete_data (as defined by fsp$open_file) have been meet.
{  This routine is needed because global_file_information can only be modified
{  by a ring 3 routine.
{
{        BAP$DELETE_DATA (FILE_IDENTIFIER, STATUS)
{
{  FILE_IDENTIFIER: (input)
{
{
{
{
{
*DECK DECK=BAH$DELETE_PATH_DESCRIPTION EXPAND=FALSE
{
{   The purpose of this procedure is to attempt to delete a
{ path_description_entry if it meets deletion requirements, and then to
{ continue to delete parent path_description_entries that meet deletion
{ requirements.  Deletion requirements are that delete_allowed be true, and
{ the active_participation_count equal to 0.
{
{      BAP$DELETE_PATH_DESCRIPTION (PATH_HANDLE, DELETED, STATUS)
{
{ PATH_HANDLE: (input) This parameter specifies the path_handle to use to
{      find the path_description_entry to delete.
{
{ DELETED: (output) This parameter specifies whether or not the
{      path_description_entry was successfully deleted.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=BAH$DETERMINE_FILE_ACTIVE EXPAND=FALSE

{
{  The purpose of this request is determine if a file has I/O active.  The file
{ must be OPEN, otherwise, abnormal status will be returned.
{
{       BAP$DETERMINE_FILE_ACTIVE (FILE_IDENTIFIER, ACTIVE, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ ACTIVE: (output) This parameter specifies whether I/O is active.
{       true: I/O is active.
{       false: no I/O is presently active.
{
{ STATUS: (output) This parameter specifies request status.
{

*DECK DECK=BAH$EMPTY_SB EXPAND=FALSE
{
{        This request empties a system buffer.
{
{  BAP$EMPTY_SB (KFT_DESCRIPTOR,SBD_PTR,STATUS)
{
{    KFT_DESCRIPTOR : (input) this parameter specifies the known
{                      file name table entry.
{
{    SBD_PTR : (input) this parameter specifies a pointer to the system
{               buffer descriptor of the system buffer to empty.
{
{    STATUS : (output) this parameter specifies request status.
{
*DECK DECK=BAH$ENABLE_CLOSE_OF_TARGET EXPAND=FALSE
{
{   This request is called by the connected file device file access  procedure
{ (fap)  to  prepare a target file for closing.  This consists of removing the
{ target file instance from the subject file instance's list of  targets,  and
{ setting the close_allowed field of the target file instance to true.
{
{       BAP$ENABLE_CLOSE_OF_TARGET (SUBJECT_FILE_IDENTIFIER,
{         TARGET_FILE_IDENTIFIER)
{
{ SUBJECT_FILE_IDENTIFIER:  (input)  This parameter specifies the subject file
{       instance of open.
{
{ TARGET_FILE_IDENTIFIER: (input) This parameter  specifies  the  target  file
{       instance of open.
{
*DECK DECK=BAH$END_OPEN_NEW_PROCESSING EXPAND=FALSE
{
{   The purpose of this request is to complete the opening processing on a new
{ file.  A new file is defined as one not previously opened.   Currently  this
{ interface  only  forces  the  label  to be written out to the permanent file
{ catalog if the file is a permanent file.
{
{       BAP$END_OPEN_NEW_PROCESSING (LOCAL_FILE_NAME, WRITE_LABEL, STATUS)
{
{ LOCAL_FILE_NAME: (input) This parameter specifies the  local  name  for  the
{       file whose open processing is to be terminated.
{
{ WRITE_LABEL:  (input)  This  parameter  specifies whether the label is to be
{       written to the permanent file catalog.  Currently no matter what  this
{       is set to the label will be written.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: amc$access_method_id
{
*DECK DECK=BAH$FETCH EXPAND=FALSE
{
{   The purpose of this request is to retrieve the value of one or
{ more file attributes subsequent to the file being opened.  This
{ request is similar to bap$get_file_attributes except the file_identifier
{ is used to distinguish from among what may be several instances
{ of open of the same file.
{
{       BAP$FETCH (FILE_IDENTIFIER, CALL_BLOCK, FAP_LAYER_NUMBER,
{         STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ CALL_BLOCK: (input) This parameter specifies the call block
{       used by this request.
{
{ FAP_LAYER_NUMBER: (input) This parameter specifies the fap layer number.
{
{ STATUS: (output) This parameter specifies the request status.
{

*DECK DECK=BAH$FETCH_ACCESS_INFORMATION EXPAND=FALSE
{
{   The purpose of this request is to retrieve the value of one or
{ more items of file information subsequent to the file being opened.
{
{       BAP$FETCH_ACCESS_INFORMATION (FILE_IDENTIFIER, CALL_BLOCK,
{         FAP_LAYER_NUMBER, STATUS))
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ CALL_BLOCK: (input) This parameter specifies the call block
{       used by this request.
{
{ FAP_LAYER_NUMBER: (input) This parameter specifies the fap layer number.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=BAH$FETCH_TABLE EXPAND=FALSE

{
{  The purpose of this request is to return a pointer to tables
{ associated with the basic access methods routines.
{
{      BAP$FETCH_TABLE (TABLE_CALL_BLOCK, STATUS)}
{
{ TABLE_CALL_BLOCK: (input, output) This parameter specifies the table}
{      call block needed for this request.}
{
{ STATUS: (output) This parameter specifies the request status.}
{

*DECK DECK=BAH$FILE EXPAND=FALSE
{
{   The purpose of this request is to describe a file prior to access.
{ The description of the file consists of one or more file attributes.
{ Each file attribute has an appropriate default value depending upon
{ the type of file to be accessed. File attributes are preserved with
{ the file. Therefore, file attributes need only be specified when the
{ file is created, and then only if the default is not desired.
{   If the user has control permission on an existing file, this request
{ may be used to permanently change the file's attributes. The change
{ will not take place until the file is successfully opened.
{   If the user does not have control permission on an existing file,
{ this request may be used to override the file's attributes until the
{ task terminates. These changes are not preserved with the file.
{   Repeated bap$file requests may be made against the same local file.
{ The requests are additive. When two requests redefine the same
{ attribute, the most recent definition is used.
{   File attributes defined on a preceding FILE command will override
{ those specified on this request. However, the task can prevent
{ FILE command processing by quoting the file_command_processing
{ attribute on this request.
{
{       BAP$FILE (LOCAL_FILE_NAME, FILE_ATTRIBUTES, STATUS)
{
{ LOCAL_FILE_NAME: (input) This parameter specifies the name of the local
{       file for which attribute values are being supplied.
{
{ FILE_ATTRIBUTES: (input) This parameter specifies one or more file
{       attribute-value pairs.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=BAH$FILE_COMMAND EXPAND=FALSE
{
{   The purpose  of  this  request  is  to  implement  the SET_FILE_ATTRIBUTES
{ command.  This may be used to specify  initial  attributes  or  to  override
{ those  attributes  that  can  be  changed  when  a file is used.  Attributes
{ specified on this command always take precedence over any amp$file  request.
{ Multiple  commands  are  cumulative.   The attributes specified here are job
{ global.
{
{       BAP$FILE_COMMAND (LOCAL_FILE_NAME, FILE_ATTRIBUTES, STATUS)
{
{ LOCAL_FILE_NAME: (input) This parameter specifies the file whose  attributes
{       are being defined.
{
{ FILE_ATTRIBUTES:  (input) This parameter specifies the file attributes to be
{       defined.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: amc$access_method_id
{
*DECK DECK=BAH$FILL_SB EXPAND=FALSE
{
{
{        This request will fill a system buffer from the source file.
{
{  BAP$FILL_SB (KFT_DESCRIPTOR,SBD_PTR,STATUS)
{
{    KFT_DESCRIPTOR : (input) this parameter specifies the known file
{                      table entry.
{
{    SBD_PTR : (input) this parameter specifies a pointer to the system
{               buffer descriptor of the system buffer to fill.
{
{    STATUS : (output) this parameter specifies request status.
*DECK DECK=BAH$FORMAT_SEGMENT_CONDITION EXPAND=FALSE
{
{   The purpose of this request is to emit the appropiate exception
{ condition whenever a segment access condition occurs for a segment
{ opened via BAM interfaces.
{
{         BAP$SET_STATUS_FROM_CONDITION (IDENTIFIER, SEGMENT_ACCESS_CONDITION,
{           CONDITION_STATUS)
{
{ IDENTIFIER: (input) This parameter specifies the product identifier to be
{         inserted in the condition_status variable, if the segment is found
{         to have been opened by a BAM request.
{
{ SEGMENT_ACCESS_CONDITION: (input) This parameter specifies the condition
{         which occurred.  The condition may or may not be associated with
{         a segment which was opened via BAM.
{
{ CONDITION_STATUS: (output) This parameter specifies the condition_status
{         deduced from the reported segment access condition, if applicable.
{         If the segment involved in the condition was not opened by BAM,
{         condition_status will be normal; otherwise an appropriate BAM
{         exception is returned.
{
*DECK DECK=BAH$GET_BLOCK EXPAND=FALSE

{   the purpose of this procedure is to ensure that the caller
{ is provided with sufficient block space on output to accommodate
{ the record being written, or sufficient block space on input
{ to cover the record being read.
{
{ this procedure call may result in the addition or deletion of
{ block control header (BCH) information to/from the file.
{
{        BAP$GET_BLOCK (FILE_IDENTIFIER,BLOCK_LENGTH,CURRENT_BYTE_ADDRESS,
{                       BLOCK_TRANSFER_DESCRIPTOR,TRANSFER_LENGTH,STATUS)
{
{ FILE_IDENTIFIER : (input) this parameter specifies the file access
{                    identifier established when the file was opened.
{
{ BLOCK_LENGTH : (input) this parameter specifies the total block
{                length required to satisfy a transfer.
{
{ CURRENT_BYTE_ADDRESS : (input) this parameter specifies the current
{                         byte offset into the file.
{
{ BLOCK_TRANSFER_DESCRIPTOR : (output) this parameter points to a
{                              sequence of block fragments necessary
{                              to satisfy the BLOCK_LENGTH request.
{                              each fragment would consist of a base
{                              pointer and a fragment length.
{
{ TRANSFER_LENGTH : (output) this parameter specifies the actual block
{                   length retrieved or allocated. this length equals
{                  the BLOCK_LENGTH during normal operations
{                  with abnormal status it indicates the length actually
{                  available.
{
{ STATUS : (output) this parameter specifies request status.
*DECK DECK=BAH$GET_BUFFER_SPACE EXPAND=FALSE
{
{
{        This request is used to obtain space from system buffers.
{     The space may be split among system buffers therefore a list of
{     buffer space descriptors will be returned.
{
{  BAP$GET_BUFFER_SPACE ( KFT_DESCRIPTOR,LIST_PTR,BYTE_ADDRESS,
{                           REQUESTED_LENGTH,STATUS)
{
{    KFT_DESCRIPTOR : (input ) this parameter specifies the known file
{                      table entry.
{
{    LIST_PTR : (input) this parameter specifies a pointer to a list of
{                buffer space descriptors.
{                 (output) this parameter specifies a pointer to a list
{                  of buffer descriptors.
{
{    BYTE_ADDRESS : (input) this parameter specifies the file byte address
{                    that corresponds to the start of the space.
{
{    REQUESTED_LENGTH : (input) this parameter specifies the number of
{                        bytes of buffer space required.
{
{    STATUS : (output) this parameter specifies request status.
{
*DECK DECK=BAH$GET_DEFAULT_ATTRIBUTES EXPAND=FALSE
{
{   The purpose of this request is retrieve the systems default file attributes
{   in a form usable by fsp$get_open_information and fsp$copy_file.
{
{     BAP$GET_DEFAULT_ATTRIBUTES(CATALOG_INFORMATION, CYCLE_ATTRIBUTE_SOURCES,
{        CYCLE_ATTRIBUTE_VALUES, STATUS)
{
{ CATALOG_INFORMATION: (output) This parameter returns the catalog information defaults
{     of the system.
{
{ CYCLE_ATTRIBUTE_SOURCES: (output) This parameter returns the file cycle attribute source defaults
{     of the system.
{
{ CYCLE_ATTRIBUTE_VALUES: (output) This parameter returns the file cycle attribute value defaults
{     of the system.
{
{ A NIL pointer can be specified on any of the above requests if that information is not desired.
{
{ STATUS: (output) This parameter specifies the request status.
*DECK DECK=BAH$GET_DIRECT EXPAND=FALSE

{
{   The purpose of this procedure is to provide a get direct record}
{ level access to the record manager.}
{
{        BAP$GET_DIRECT (FILE_IDENTIFIER, CALL_BLOCK, FAP_LAYER_NUMBER, STATUS)}
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access}
{        identifier established when the file was opened.}
{
{ CALL_BLOCK: (input, output) This parameter specifies the call block}
{        used by the procedure.}
{
{ FAP_LAYER_NUMBER: (input) This parameter specifies the fap layer number.}
{
{ STATUS: (output) This parameter specifies the request status.}
{
*DECK DECK=BAH$GET_FILE_ATTRIBUTES EXPAND=FALSE
{
{     The purpose of this request is to allow a user to interrogate
{ file attributes maintained by the access method for a local file.
{ This interface is the ring 3 building block for amp$get_file_attributes.
{
{       BAP$GET_FILE_ATTRIBUTES (LOCAL_FILE_NAME, FILE_DESCRIPTOR,
{         SYSTEM_FILE_ATTRIBUTES, POSITION_INFO, LOCAL_FILE,
{         EXISTING_FILE, CONTAINS_DATA, STATUS)
{
{ LOCAL_FILE_NAME: (input) This parameter specifies the name of the local
{       file whose attribute values are sought.
{
{ FILE_DESCRIPTOR: (input)  This parameter specifies the file_descriptor
{      currently in effect for the file.
{
{ SYSTEM_FILE_ATTRIBUTES: (input-output) This parameter specifies zero or more
{       file attributes whose value is sought.
{
{ POSITION_INFO: (output) This parameter specifies the position information.
{
{ LOCAL_FILE: (output) This parameter specifies whether the file is
{       local to the task. A file is said to be local if a preceding command,
{       or request, has been issued naming the file.
{
{ EXISTING_FILE: (output) This parameter specifies whether the local file
{         has ever been opened.
{
{ CONTAINS_DATA: (output) This parameter specifies whether an existing
{       file has data (non null in length).
{
{ STATUS: (output) This parameter specifies the request status.
{

*DECK DECK=BAH$GET_NEXT EXPAND=FALSE

{
{   The purpose of this procedure is to provide a get next record}
{ level access to the record manager.}
{
{        BAP$GET_NEXT (FILE_IDENTIFIER, CALL_BLOCK, FAP_LAYER_NUMBER, STATUS)}
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access}
{        identifier established when the file was opened.}
{
{ CALL_BLOCK: (input, output) This parameter specifies the call block}
{        used by the procedure.}
{
{ FAP_LAYER_NUMBER: (input) This parameter specifies the fap layer number.}
{
{ STATUS: (output) This parameter specifies the request status.}
{

*DECK DECK=BAH$GET_NEXT_SUBBUFFER EXPAND=FALSE
{
{      This request is used to control the subbuffer positioning
{     within a system buffer.  If the subbuffer position equals a 'trigger
{     read ahead' subbuffer position, the read ahead of the next system
{     buffer will be initiated if necessary.  If all subbuffers are used,
{     either a switch will be made to the next system buffer or the task
{     will be suspended until the next system buffer becomes available.
{
{  BAP$GET_NEXT_SUBBUFFER (FTD_PTR,SBD_PTR,LENGTH,STATUS)
{
{    KFT_DESCRIPTOR : (input) this parameter specifies the known
{                      file table entry associated with the file.
{
{    SBD_PTR : (input) this parameter specifies a pointer to the
{               system buffer descriptor of the system buffer to
{               position.
{
{               (output) this parameter specifies the new system
{                system buffer descriptor if a change in system
{                buffers occured.
{
{    LENGTH : (input) this parameter specifies the amount of space
{              to position within the buffer.
{
{    STATUS : (output) this parameter specifies request status.
*DECK DECK=BAH$GET_OPEN_INFORMATION EXPAND=FALSE

{
{   The purpose of this request is to retrieve all the information which is
{ available for a particular file cycle.
{   One is not required to retrieve all the possible information for the file.
{ In fact, one is encouraged to retrieve only that information which is actually
{ required.  All the output parameters except user_defined_attribute_size accept
{ a NIL pointer to indicate that the parameter is not to be returned.  Refer to
{ the description of the catalog_information parameter for an additional caution.
{
{       BAP$GET_OPEN_INFORMATION (FILE_IDENTIFIER, ATTACHMENT_INFORMATION,
{         CATALOG_INFORMATION, CYCLE_ATTRIBUTE_SOURCES,
{         CYCLE_ATTRIBUTE_VALUES, INSTANCE_INFORMATION,
{         RESOLVED_FILE_REFERENCE, USER_DEFINED_ATTRIBUTES,
{         USER_DEFINED_ATTRIBUTE_SIZE, STATUS)
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the file access
{       identifier established when the file was opened.
{
{ ATTACHMENT_INFORMATION: (output)  This parameter specifies information about
{       the attachment of the file to the job.
{
{ CATALOG_INFORMATION: (output)  This parameter specifies file and file-cycle
{       catalog registration information.  If a non-NIL value is specified,
{       a catalog access will occur to retrieve this information; therefore,
{       there is a significant cost associated with returning this particular
{       parameter.
{
{ CYCLE_ATTRIBUTE_SOURCES: (output)  This parameter specifies the origination
{       of the values of all of the file-cycle attributes.
{
{ CYCLE_ATTRIBUTE_VALUES: (output)  This parameter specifies the values of all
{       of the file-cycle attributes.
{
{ INSTANCE_INFORMATION: (output)  This parameter specifies information which
{       may be unique to an instance of open of a file.  This information
{       includes the values of file-cycle attributes which were overridden
{       using the fsp$open_file request which established this instance of
{       open and the values of "attachment" options specified either by the
{       fsp$open_file request or an amp$store request.  If an attribute was
{       not overridden by the fsp$open_file request, the permanent value of
{       the attribute will be returned.
{
{ RESOLVED_FILE_REFERENCE: (output)  This parameter specifies the complete
{       path name of the file cycle, including the open position, if
{       specified.
{
{ USER_DEFINED_ATTRIBUTES: (output)  This parameter specifies the values of
{       all the user-defined attributes of the file.  The caller is
{       responsible for providing an area large enough to contain the sequence
{       of user-defined attributes.  If the area provided is not large enough,
{       abnormal status will be returned; in addition the request will return
{       the actual size of the area which will be required in the parameter
{       user_defined_attribute_size.  This will allow the caller to repeat the
{       request successfully.  If a NIL value is provided for this parameter,
{       no user-defined attributes will be returned.
{
{       Each user-defined attribute in the sequence consists of a header of
{       type fst$user_attribute_descriptor followed by the value of the
{       attribute.  One performs a NEXT for the header, determines the type of
{       user-defined attribute which follows and then does another NEXT to
{       obtain the attribute value; this continues until a NIL pointer is
{       returned by the NEXT or a header is found in which the
{       user_attribute_name field is equal to osc$null_name.
{
{       The user-defined-attribute sequence is RESET by this request.
{
{ USER_DEFINED_ATTRIBUTE_SIZE: (output)  This parameter specifies the exact
{       size of the user-defined attribute information.  This parameter is
{       initialized whether or not this request terminates normally.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_id.
{       IDENTIFIER: amc$access_method_id.
{
{
*DECK DECK=BAH$GET_PARTIAL EXPAND=FALSE
{
{   The purpose of this procedure is to provide a get partial record}
{ level access to the record manager.}
{
{        BAP$GET_PARTIAL (FILE_IDENTIFIER, CALL_BLOCK, FAP_LAYER_NUMBER, STATUS)}
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access}
{        identifier established when the file was opened.}
{
{ CALL_BLOCK: (input, output) This parameter specifies the call block}
{        used by the procedure.}
{
{ FAP_LAYER_NUMBER: (input) This parameter specifies the fap layer number.}
{
{ STATUS: (output) This parameter specifies the request status.}
{
*DECK DECK=BAH$GET_ROUTE_INFO EXPAND=FALSE
{
{ the purpose of this request is to provide a mechanism for
{ retrieving routing information from the system file label
{
{        BAP$GET_ROUTE_INFO (FILE_IDENTIFIER,QLABEL,STATUS)
{
{ FILE_IDENTIFIER: (input) this parameter specifies the file
{     access identifier established when the file was opened
{
{ QLABEL: (output) this parameter specifies a array in the
{     calling tasks address space into which routing information
{     will be placed. the size of this array is assumed to be
{     400 bytes.
{
{ STATUS: (output) this parameter specifies the request status.
*DECK DECK=BAH$GET_SEGMENT_POINTER EXPAND=FALSE
{
{   The purpose of this request is to initialize a pointer to the virtual}
{ memory segment which was assigned by the system when the file}
{ was opened.}
{   It is necessary to obtain a pointer to the segment so that the file}
{ can be accessed as memory using machine instructions.}
{   As a convenience this request returns a pointer of type cell, adaptable}
{ heap or adaptable sequence.}
{}
{   The content of the pointer variable is initialized as follows:}
{
{      amc$cell_pointer:}
{        .The byte offset portion of the PVA is set to the}
{         current_byte_address of the file.}
{}
{      amc$heap_pointer - pointer to adaptable heap:}
{        .The byte offset portion of the heap_pointer is set to the}
{         address of the first byte in the segment.}
{        .If the file is null in length, the LIMIT portion of the}
{         heap_pointer is set to the file_limit. The heap must be RESET}
{         by the CYBIL application.}
{        .If the file contains data the LIMIT portion of the heap_pointer}
{         is determined as follows:}
{           .If the file has an access_mode which includes pfc$read,}
{            pfc$modify or pfc$shorten but not pfc$append, the LIMIT}
{            is set to the eoi_byte_address of the file.}
{           .If the file has an access_mode which includes pfc$append,}
{            the LIMIT is set to the file_limit.}
{}
{      amc$sequence_pointer - pointer to adaptable sequence:}
{        .The byte offset portion of the sequence_pointer is set to the}
{         address of the first byte in the segment.}
{        .The NEXT portion of the sequence_pointer is set to the}
{         current_byte_address.}
{        .If the file is null in length, the LIMIT portion of the}
{         sequence_pointer is set to file_limit.}
{        .If the file contains data, the LIMIT portion of the}
{         sequence_pointer is determined as follows:}
{           .If the file has an access_mode which includes pfc$read,}
{            pfc$modify or pfc$shorten but not pfc$append, the LIMIT}
{            is set to the eoi_byte_address of the file.}
{           .If the file has an access_mode which includes pfc$append,}
{            the LIMIT is set to the file_limit.}
{
{   This request does not change the contents of the segment access file. The}
{ user must follow the language conventions surrounding usage of heaps and}
{ sequences.}
{
{       BAP$GET_SEGMENT_POINTER (FILE_IDENTIFIER, CALL_BLOCK,
{        FAP_CONTROL_INFORMATION, FAP_LAYER_NUMBER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ CALL_BLOCK: (input) This paramter specifies the call block
{        used by this request.
{
{ FAP_CONTROL_INFORMATION: (input) This paramter specifies control
{        information necessary for orderly transfer of control from
{        the fap the the access method and from one access method
{        layer to another.
{
{ FAP_LAYER_NUMBER: (input) This parameter specifies the index into the
{        fap_control_information for this layer.
{
{ STATUS: (output) This parameter specifies the request status. THis is
{        the application's status variable.
{
*DECK DECK=BAH$GET_STRUCTURE_POINTER EXPAND=FALSE
{}
{   The purpose of this module is to implement an internal program interface
{ that allows retrieval of a pointer to a structure which is owned by a file
{ access procedure (FAP).
{   This request allows the fap to retrieve a pointer to a structure which is
{ peculiar to the instance of the file being accessed, i.e. peculiar to a
{ file identifier.
{   This request will return abnormal status if the structure pointer for the
{ fap is NIL.
{}
{       BAP$GET_STRUCTURE_POINTER (FILE_IDENTIFIER, VALIDATION_PROC,
{         STRUCTURE_POINTER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file access identifier
{       established when the file was opened.
{}
{ VALIDATION_PROC: (input) This parameter specifies the address of the fap.
{       This parameter is used to identify the fap that owns the structure
{       whose address is being retrieved.
{}
{ STRUCTURE_POINTER: (output) This parameter specifies the address of a
{       structure the fap previously stored using the amp$store_fap_pointer
{       request.
{}
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION: ame$ring_validation_error,
{                  ame$improper_file_id,
{                  ame$nil_structure_pointer.
{       IDENTIFIER:amc$access_method_id.
{}
*DECK DECK=BAH$GET_SYSYTEM_LABEL EXPAND=FALSE
{
{
{ this procedure will return the system file label and associated
{ attributes.
{
{
{  PROCEDURE BAP$GET_SYSTEM_LABEL (LOCAL_FILE_NAME, SYSTEM_FILE_LABEL,
{                                  STATUS)
{
{
{  LOCAL_FILE_NAME (input) this parameter specifies the name by
{                          wich the file is known to the system.
{
{
{  SYSTEM_FILE_LABEL (output): this parameter specifies an array
{                              to which the system file label will
{                              be returned.
{
{
{  STATUS (output): this parameter specifies request status.
{
{
*DECK DECK=BAH$GET_TERMINAL_ATTRIBUTES EXPAND=FALSE
{
{   The purpose  of  this  request is to obtain terminal attributes previously
{ associated  with  a  file  by  a  rmp$request_terminal   request.    If   no
{ rmp$request_terminal  was  done  for  the  specified file, or the attributes
{ requested  on  this   interface   were   not   specified   on   a   previous
{ rmp$request_terminal then the value of the source for the attribute returned
{ is set to ifc$undefined_attribute.
{
{       BAP$GET_TERMINAL_ATTRIBUTES (LOCAL_FILE_NAME, TERMINAL_ATTRIBUTES,
{         STATUS)
{
{ LOCAL_FILE_NAME:  (input)  This  parameter  specifies the local file for who
{       terminal attributes are to be obtained for.
{
{ TERMINAL_ATTRIBUTES: (input, output) As an input  this  parameter  specifies
{       the attributes for which information is to be returned for.  As output
{       this parameter  returns  the  source  and  value  for  each  attribute
{       specified.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: amc$access_method_id
{
*DECK DECK=BAH$INLINE_PROC_DOCUMENTATION EXPAND=FALSE

{
{ This procedure requires one or more of the following globally defined and
{ initialized variables that correspond to the current operation:
{
{   file_instance: ^bat$task_file_entry,
{   gfi: ^bat$global_file_information,
{   tape_descriptor: ^bat$tape_descriptor,
{   block_info: ^bat$block_info,
{   global_layer_number: amt$fap_layer_number,
{   operation: amt$fap_operation,
{   dossier: ^bat$sl_tape_dossier_rec.

{
{ This procedure uses the global variables instead of a parameter because
{ inline procedures generate more efficient code with fewer parameters and
{ fewer local variables.  This method also allows faster access to the bam
{ tables.
{
*DECK DECK=BAH$IS_FILE_REGISTERED EXPAND=FALSE
{
{   The purpose of this request is to determine whether a specified file is
{ registered in the requesting job.
{
{       BAP$IS_FILE_REGISTERED (PATH_HANDLE, REGISTERED, STATUS)
{
{ PATH_HANDLE: (input) This parameter specifies the file.
{
{ REGISTERED: (output) This parameter specifies whether the file is registered.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=BAH$IS_PATH_REGISTERED EXPAND=FALSE
{
{   The purpose of this procedure is to determine whether the path specified
{ by the path_elements and cycle_reference is already registered in the
{ path_table.  If the path is registered a path_handle is returned.
{
{      BAP$IS_PATH_REGISTERED (PATH_ELEMENTS, CYCLE_REFERENCE,
{        REGISTERED, PATH_HANDLE_NAME, STATUS)
{
{ PATH_ELEMENTS: (input) This parameter specifies the path_elements portion
{      of a path.
{
{ CYCLE_REFERENCE: (input) This parameter specifies the cycle portion of a
{      path.
{
{ REGISTERED: (output) This parameter specifies whether the path is registered
{      in the path_table.
{
{ PATH_HANDLE_NAME: (output) This parameter specifies the path_handle_name for
{      a path if it was registered.
{
{ STATUS: (output) This parameter specifies the status of the request.
{

*DECK DECK=BAH$LOADED_RING_CLEANUP EXPAND=FALSE
{}
{   The purpose of this request is to close all files associated with
{ a task no matter what ring the file was loaded.
{}
{     BAP$LOADED_RING_CLEANUP
{}
*DECK DECK=BAH$LOCATE_SB EXPAND=FALSE
{
{
{      This request will locate a given byte address. The files system
{     buffers are searched first.  If the byte address is found, the
{     system buffer is positioned to the byte address.  If the byte
{     address is not found in the systen buffer descriptor chain, a
{     system buffer is assigned to contain the byte address and the
{     associated system buffer descriptor is linked into the system
{     buffer desriptor chain.
{
{  BAP$LOCATE_SB ( KFT_DESCRIPTOR,BYTE_ADDRESS,SBD_PTR,STATUS)
{
{    KFT_DESCRIPTOR : (input) this parameter specifies the known file
{                      table entry.
{
{    BYTE_ADDRESS : (input) this parameter specifies the byte address to
{                    which to locate.
{
{    SBD_PTR : (input) this parameter specifies a pointer to the system
{               buffer descriptor that can be released if necessary. if
{               NIL, the current system buffer will be released if nec-
{               essary.
{
{             (output) this parameter specifies a pointer to the system
{              buffer descriptor of the system buffer containing the byte
{              address.
{
{    STATUS : (output) this parameter specifies request status.
{
*DECK DECK=BAH$LOCATE_SFL EXPAND=FALSE

{ description of bap$locate_sfl goes here }
*DECK DECK=BAH$LOG_DEVICE EXPAND=FALSE
{
{   The purpose of this procedure is to provide file access to logs.
{
{   Only record level access is supported.  Append access to  ascii  logs  and
{ read  access  to  all  logs  are supported.  The fap (file access procedure)
{ allows opens of log files for either append only (for ascii  logs  only)  or
{ read  only; no other access modes are allowed, and reading and appending can
{ not be done  by  the  same  instance  of  open.   Positioning  requests  are
{ processed  if  the  open was for read access and are ignored if the open was
{ for append access.
{
{       BAP$LOG_DEVICE (FILE_IDENTIFIER, CALL_BLOCK, LAYER_NUMBER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access identifier
{       established when the file was opened.
{
{ CALL_BLOCK:  (input)  This parameter specifies the call block that describes
{       the request to be performed.
{
{ LAYER_NUMBER: (input) This  parameter  specifies  the  index  into  the  fap
{       control information for this layer.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=BAH$LOW_LEVEL_IO_OPEN EXPAND=FALSE

{ COMMON DECK BAHLLOP }
{}
{   The purpose of this procedure is to provide access to low level}
{ input/output operations.  The procedure allocates the known file}
{ table entry, the file transfer descriptor, the buffer manager des-}
{ criptor, and the block descriptor.  It also initializes the known}
{ file table.}
{}
{        BAP$LOW_LEVEL_IO_OPEN (LOCAL_FILE_NAME, CALL_BLOCK, KFT_ENTRY,}
{                STATUS)}
{}
{ LOCAL_FILE_NAME: (input) This parameter specifies the local file name}
{        of the file to be opened.}
{}
{ CALL_BLOCK: (input) This parameter specifies a pointer to the call block}
{        associated with this request.}
{}
{ KFT_ENTRY: (output) This parameter specifies the known file table entry}
{}
{ STATUS: (output) This parameter specifies the request status.}
{}
*DECK DECK=BAH$MARK_FAP_LAYER_CLOSED EXPAND=FALSE
{
{   The purpose  of  this request is to indicate that a particular file access
{ procedure is no longer opened.  This indicates that this fap  is  no  longer
{ active.
{
{       BAP$MARK_FAP_LAYER_CLOSED (FILE_IDENTIFIER, LAYER_NUMBER, STATUS)
{
{ FILE_IDENTIFIER:  (input)  This  parameter specifies the file identifier for
{       the instance of open for which the fap layer is to be marked.
{
{ LAYER_NUMBER: (input) This parameter indicated  the  file  access  procedure
{       layer number that is to be marked close.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: amc$access_method_id
{
*DECK DECK=BAH$MARK_FAP_LAYER_OPEN EXPAND=FALSE
{
{   The purpose  of  this request is to indicate that a particular file access
{ procedure is now opened and active.
{
{       BAP$MARK_FAP_LAYER_OPEN (FILE_IDENTIFIER, LAYER_NUMBER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the  file  identifier  for
{       the instance of open for which the fap layer is to be marked.
{
{ LAYER_NUMBER:  (input)  This  parameter  indicated the file access procedure
{       layer number that is to be marked open.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: amc$access_method_id
{
*DECK DECK=BAH$MERGE_DYNAMIC_ATTRIBUTES EXPAND=FALSE
{}
{ COMMON DECK BAHMDA }
{}
{   The purpose of this request is to merge a file's dynamic attributes.
{}
{     BAP$MERGE_DYNAMIC_ATTRIBUTES (LOCAL_FILE_NAME, GLOBAL_ACCESS_MODE,
{         FILE_REQUEST_DESCRIPTOR, OPEN_POSITION, ACCESS_SELECTIONS,
{         VALIDATION_RING, DYNAMIC_LABEL, STATUS)
{}
{ LOCAL_FILE_NAME: (input) This parameter specifies the local file name of
{   the file for which the dynamic file attributes are to be merged.
{
{ GLOBAL_ACCESS_MODE: (input) This parameter specifies the global access
{   mode associated with the specified local file name.
{
{ FILE_REQUEST_DESCRIPTOR: (input) This parameter specifies a pointer to
{   a file request descriptor that has been associated with the specified
{   local file name.
{
{ OPEN_POSITION: (input) This parameter specifies the open
{   position and its source to be used for determining the merged open
{   position attribute.
{
{ ACCESS_SELECTIONS: (input) This parameter specifies the access selection
{   attributes specified on an open.
{
{ VALIDATION_RING: (input) This parameter specifies the ring number to be
{   used for ring validation.
{
{ DYNAMIC_LABEL: (input, output) This parameter specifies the existing or
{   default dynamic label attributes that are to be used as a base upon
{   which to merge the requested attributes.  This parameter returns the
{   resulting merged dynamic label attributes.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=BAH$MERGE_DYNAMIC_ATTR_SOURCE EXPAND=FALSE
{}
{ COMMON DECK BAHMDAS }
{}
{   The purpose of this request is to merge a file's existing or default
{ dynamic attributes with requested file attributes according to source
{ precedence.
{}
{     BAP$MERGE_DYNAMIC_ATTR_SOURCE (LOCAL_FILE_NAME, ATTRIBUTES, SOURCE,
{         DYNAMIC_LABEL, STATUS)
{}
{ LOCAL_FILE_NAME: (input) This parameter specifies the local file name
{   of the file for which the dynamic attributes are to be merged.
{
{ ATTRIBUTES: (input) This parameter specifies the requested file
{   attributes to be merged with the dynamic file attributes.
{
{ SOURCE: (input) This parameter specifies the source of the above
{   attributes.
{
{ DYNAMIC_LABEL: (input, output) This parameter specifies the existing
{   or default dynamic label attributes which are to be used as a base
{   for merging the requested attributes.  This parameter returns the
{   merged dynamic file attributes.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=BAH$MERGE_STATIC_ATTRIBUTES EXPAND=FALSE
{}
{ COMMON DECK BAHMSA }
{}
{   The purpose of this request is to merge a file's static attributes.
{}
{     BAP$MERGE_STATIC_ATTRIBUTES (LOCAL_FILE_NAME, FILE_REQUEST_DESCRIPTOR,
{         ACCESS_SELECTIONS, VALIDATION_RING, STATIC_LABEL, STATUS)
{}
{ LOCAL_FILE_NAME: (input) This parameter specifies the local file name of
{   the file for which the static file attributes are to be merged.
{
{ FILE_REQUEST_DESCRIPTOR: (input) This parameter specifies a pointer to
{   a file request descriptor that has been associated with the specified
{   local file name.
{
{ ACCESS_SELECTIONS: (input) This parameter specifies the access selection
{   attributes specified on an open.
{
{ VALIDATION_RING: (input) This parameter specifies the ring number to be
{   used for ring validation.
{
{ STATIC_LABEL: (input, output) This parameter specifies the existing or
{   default static label attributes that are to be used as a base upon
{   which to merge the requested attributes.  This parameter returns the
{   resulting merged static label attributes.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=BAH$MERGE_STATIC_ATTR_SOURCE EXPAND=FALSE
{}
{ COMMON DECK BAHMSAS }
{}
{   The purpose of this request is to merge a file's existing or default
{ static attributes with requested file attributes according to source
{ precedence.
{}
{     BAP$MERGE_STATIC_ATTR_SOURCE (LOCAL_FILE_NAME, ATTRIBUTES, SOURCE,
{         STATIC_LABEL, STATUS)
{}
{ LOCAL_FILE_NAME: (input) This parameter specifies the local file name
{   of the file for which the static attributes are to be merged.
{
{ ATTRIBUTES: (input) This parameter specifies the requested file
{   attributes to be merged with the static file attributes.
{
{ SOURCE: (input) This parameter specifies the source of the above
{   attributes.
{
{ STATIC_LABEL: (input, output) This parameter specifies the existing
{   or default static label attributes which are to be used as a base
{   for merging the requested attributes.  This parameter returns the
{   merged static file attributes.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=BAH$MERGE_STATIC_FILE_CMD_ATTR EXPAND=FALSE
{}
{ COMMON DECK BAHMSFC }
{}
{   The purpose of this request is to merge a file's static attributes
{ with attributes requested by a FILE command.
{}
{     BAP$MERGE_STATIC_FILE_CMD_ATTR (LOCAL_FILE_NAME, FILE_CMD_LIST,
{         VALIDATION_RING, STATIC_LABEL, STATUS)
{}
{ LOCAL_FILE_NAME: (input) This parameter specifies the local file name
{   of the file for which the requested file command attributes are to
{   be merged with the static attributes.
{
{ FILE_CMD_LIST: (input) This parameter specifies a pointer to a list of
{   attributes specified by a FILE command.
{
{ VALIDATION_RING: (input) This parameter specifies the ring number to be
{   used for ring validation.
{
{ STATIC_LABEL: (input, output) This parameter specifies the existing or
{   or default static label attributes which are to be used as a base
{   for merging the requested attributes.  This parameter returns the
{   merged static file attributes.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=BAH$NULL_DEVICE EXPAND=FALSE
{}
{   This is the file access procedure (FAP) that processes requests for files
{ that are associated with a null device.
{   GET and PUT calls can be issued to a null file that has been opened for
{ record access.  The result of performing a GET on a file assigned to a null
{ device will be the return of normal status but no data.  The file position
{ returned after a GET call is always AMC$EOI.  Any PUT performed on such a
{ file will cause the data to be discarded and normal status is returned.  A
{ full record PUT call returns a file position of AMC$EOR; a partial record
{ PUT call to write the beginning or middle part of a record returns
{ AMC$MID_RECORD; a partial record PUT call to write the end of a record returns
{ AMC$EOR.
{   An AMP$GET_SEGMENT_POINTER call to a null file that was opened for segment
{ access returns a NIL pointer because the system does not assign a segment to
{ the file.
{}
{        BAP$NULL_DEVICE ( FILE_IDENTIFIER, CALL_BLOCK, LAYER_NUMBER,
{                          STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{}
{ CALL_BLOCK: (input) This parameter specifies the call block used
{       by this request.
{}
{ LAYER_NUMBER: (input) This parameter specifies the index into the
{       fap_control_information for this layer.
{}
{ STATUS: (output) This parameter specifies the request status.}
{}
*DECK DECK=BAH$OPEN EXPAND=FALSE
{
{   The purpose of this request is to prepare a local file for access.
{ Functions as described for amp$open are performed.  These functions include
{ validation of access to a file, allowing segment or record access to a file,
{ and specification of attributes for a file.
{
{       BAP$OPEN (LOCAL_FILE_NAME, ACCESS_LEVEL, ACCESS_SELECTIONS,
{         FILE_PREVIOUSLY_OPENED, CONTAINS_DATA, FILE_IDENTIFIER, WORK_RESULT,
{         EVALUATED_FILE_REFERENCE, STATUS)
{
{ LOCAL_FILE_NAME: (input)  This parameter specifies the local file name.
{
{ ACCESS_LEVEL: (input)  This parameter specifies the means by which this file
{       will be accessed.
{
{ ACCESS_SELECTIONS: (input)  This parameter specifies one or more temporary or
{       structural attribute values to describe the file and the manner of file
{       access.
{
{ FILE_PREVIOUSLY_OPENED: (output)  This parameter returns whether the file had
{       ever previously been opened.
{
{ CONTAINS_DATA: (output)  This parameter indicates whether there has been any
{       data written to the file (that is, is EOI > 0?).
{
{ FILE_IDENTIFIER: (output)  This parameter specifies the file access
{       identifier which is assigned to this instance of open for the file.
{
{ WORK_RESULT NOT CURRENTLY SUPPORTED
{ WORK_RESULT: (output) This parameter returns whether the open resulted
{       in an implicit permanent file creation, implicit permanent file
{       attachment, or merely a local file create.
{       BAC$FILE_NOT_CREATED.  No new file was created as a result of this
{         request.
{       BAC$IMPLICIT_PF_CREATE. A permanent file was created as a result
{         of the open.
{       BAC$IMPLICIT_PF_ATTACH. A permanent file was attached as a result
{         of the open.
{       BAC$TEMPORARY_FILE_CREATE. A temporary file was created as a result
{         of the open.
{
{ EVALUATED_FILE_REFERENCE: (output)  This parameter specifies the file
{       reference of the file which has been opened.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=BAH$OPEN_FILE EXPAND=FALSE
{
{   The purpose of this request is to prepare a local file for access.
{ Functions as described for fsp$open_file are performed.  These functions
{ include validation of access to a file, allowing segment or record access to
{ a file, and specification of attributes for a file.
{
{       BAP$OPEN_FILE (ACCESS_LEVEL, FILE_ATTACHMENT,
{         DEFAULT_CREATION_ATTRIBUTES, MANDATED_CREATION_ATTRIBUTES,
{         ATTRIBUTE_VALIDATION, ATTRIBUTE_OVERRIDE, EVALUATED_FILE_REFERENCE,
{         FILE_PREVIOUSLY_OPENED, CONTAINS_DATA, FILE_IDENTIFIER, WAIT,
{         WAIT_TIME, WORK_RESULT, ARCHIVE_CYCLE_NUMBER, STATUS)
{
{ ACCESS_LEVEL: (input)  This parameter specifies the means by which this file
{       will be accessed.
{
{ FILE_ATTACHMENT: (input)  This parameter specifies the attachment options to
{       be in effect for this instance of open.
{
{ DEFAULT_CREATION_ATTRIBUTES: (input)  This parameter specifies file attribute
{       values which are to be used in the absence of a CREATE_FILE command or
{       program request specification.
{
{ MANDATED_CREATION_ATTRIBUTES: (input)  This parameter specifies file
{       attribute values which must be used to describe the file, if it is to
{       be initially opened by this request.
{
{ ATTRIBUTE_VALIDATION: (input)  This parameter specifies the desired attribute
{       values of the file.  This parameter allows alternatives to be specified
{       for each attribute to be validated.
{
{ ATTRIBUTE_OVERRIDE: (input)  This parameter specifies an attribute value to
{       be used only for this instance of open of the file or file cycle.
{
{ EVALUATED_FILE_REFERENCE: (input, output)  This parameter specifies the file
{       reference of the file to be opened.
{
{ FILE_PREVIOUSLY_OPENED: (output)  This parameter returns whether the file had
{       ever previously been opened.
{
{ CONTAINS_DATA: (output)  This parameter indicates whether there has been any
{       data written to the file (that is, is EOI > 0?).
{
{ FILE_IDENTIFIER: (output)  This parameter specifies the file access
{       identifier which is assigned to this instance of open for the file.
{
{ WAIT: (output)  This parameter specifies whether or not to wait for
{       attachment if the file is busy.
{
{ WAIT_TIME: (output)  This parameter specifies the length of time to wait for
{       attachment if the file is busy.
{
{ WORK_RESULT NOT CURRENTLY SUPPORTED
{ WORK_RESULT: (output) This parameter returns whether the open resulted
{       in an implicit permanent file creation, implicit permanent file
{       attachment, or merely a local file create.
{       BAC$FILE_NOT_CREATED.  No new file was created as a result of this
{         request.
{       BAC$IMPLICIT_PF_CREATE. A permanent file was created as a result
{         of the open.
{       BAC$IMPLICIT_PF_ATTACH. A permanent file was attached as a result
{         of the open.
{       BAC$TEMPORARY_FILE_CREATE. A temporary file was created as a result
{         of the open.
{
{ ARCHIVE_CYCLE_NUMBER: (output)  This parameter specifies the cycle number of
{       the file that is being opened.  It is used on retrieval of an archived
{       file to identify the cycle of the file that is to be restored to mass
{       storage.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=BAH$PAD_RECORD EXPAND=FALSE

{ COMMON DECK BAHPADR }

{   The purpose of this request is to pad a record with a padding character.
{
{       BAP$PAD_RECORD (WORKING_STORAGE_AREA, PAD_LENGTH, PADDING_CHARACTER)
{
{ WORKING_STORAGE_AREA: (input)  This parameter specifies a pointer to the
{      area to be padded.
{
{ PAD_LENGTH: (input) This parameter specifies the length in bytes of data to
{      be padded.
{
{ PADDING_CHARACTER: (input) This parameter specifies the padding character.
{
*DECK DECK=BAH$PAD_TO_MINBL EXPAND=FALSE

{ COMMON DECK BAHPMPL }

{   The purpose of this request is to pad the current block from eoi up to
{ the minimum block length.  If the eoi is positioned past the minimum
{ block length for that block, nothing is done.  Otherwise, the block
{ padding character is written in the file up to the minimum block length.
{
{       BAP$PAD_TO_MINBL (FILE_INSTANCE)
{
{ FILE_INSTANCE: (input)  This parameter describes the task file table
{       entry for this instance of open.
{
*DECK DECK=BAH$PROCEDURE EXPAND=FALSE
{
{
{ this procedure will store the system file label and associated
{ attributes.
{
{
{  PROCEDURE BAP$PUT_SYSTEM_LABEL (LOCAL_FILE_NAME, SYSTEM_FILE_LABEL,
{                                  STATUS)
{
{
{  LOCAL_FILE_NAME (input) this parameter specifies the name by
{                          wich the file is known to the system.
{
{
{  SYSTEM_FILE_LABEL (output): this parameter specifies an array
{                              from which the system file label will
{                              be written.
{
{
{  STATUS (output): this parameter specifies request status.
{
{
*DECK DECK=BAH$PROCESS_PT_REQUEST EXPAND=FALSE
{
{    The purpose of this procedure is to process the requests specified in the
{ work_list against the path described in the evaluated_file_reference and
{ return a "handle" to the resulting path.
{
{       BAP$PROCESS_PT_REQUEST (PROCESS_PT_WORK_LIST, LOCAL_FILE_NAME,
{         EVALUATED_FILE_REFERENCE, PROCESS_PT_RESULTS, STATUS)
{
{ PROCESS_PT_WORK_LIST: (input) This parameter specifies how the path is to be
{       resolved, and what other actions must be taken.  The items in the work
{       list and what they indicate are as follows:
{         bac$create_cycle_description:  Create a cycle description for the
{                                        given path if it does not exist.
{         bac$externalize_path_handle:  Mark entry as externalize.
{                                       (ie. Do not delete the entry.)
{         bac$inhibit_locking_pt:  Do not lock the path table.
{         bac$leave_aliases_unresolved:  Do not resolve the path if it is an
{                                        alias.
{         bac$record_path:  Record the path if it does not exist.
{         bac$resolve_path:  Resolve the path.
{         bac$resolve_pf_in_pt:  Resolve a permanent file using the path table.
{         bac$resolve_to_catalog:  Resolve a permanent file in the catalog.
{         bac$return_path_if_alias:  Return the full permanent file path if
{                                    the alias is passed in.
{         bac$return_cycle_description:  Return the cycle_description for a
{                                        resolved path.
{
{ LOCAL_FILE_NAME: (input) This parameter specifies a local_file_name to be
{       associated with the path.
{
{ EVALUATED_FILE_REFERENCE: (input/output) This parameter describes the path
{       to be processed.
{
{ PROCESS_PT_RESULTS: (output) This parameter specifies the results of this
{       request.  The following are the possible results:
{         bac$cycle_description_exists
{         bac$cycle_description_created
{
{ STATUS: (output) This parameter specifies the request status.
{

*DECK DECK=BAH$PUT_DIRECT EXPAND=FALSE
{
{   The purpose of this procedure is to provide a put direct record}
{ level access to the record manager.}
{
{        BAP$PUT_DIRECT (FILE_IDENTIFIER, CALL_BLOCK, FAP_LAYER_NUMBER, STATUS)}
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access}
{        identifier established when the file was opened.}
{
{ CALL_BLOCK: (input, output) This parameter specifies the call block}
{        used by the procedure.}
{
{ FAP_LAYER_NUMBER: (input) This parameter specifies the fap layer number.}
{
{ STATUS: (output) This parameter specifies the request status.}
{
*DECK DECK=BAH$PUT_NEXT EXPAND=FALSE
{
{   The purpose of this procedure is to provide a put next record}
{ level access to the record manager.}
{
{        BAP$PUT_NEXT (FILE_IDENTIFIER, CALL_BLOCK, FAP_LAYER_NUMBER, STATUS)}
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access}
{        identifier established when the file was opened.}
{
{ CALL_BLOCK: (input, output) This parameter specifies the call block}
{        used by the procedure.}
{
{ FAP_LAYER_NUMBER: (input) This parameter specifies the fap layer number.}
{
{ STATUS: (output) This parameter specifies the request status.}
{
*DECK DECK=BAH$PUT_PARTIAL EXPAND=FALSE
{
{   The purpose of this procedure is to provide a put partial record}
{ level access to the record manager.}
{
{        BAP$PUT_PARTIAL (FILE_IDENTIFIER, CALL_BLOCK, FAP_LAYER_NUMBER, STATUS)}
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access}
{        identifier established when the file was opened.}
{
{ CALL_BLOCK: (input, output) This parameter specifies the call block}
{        used by the procedure.}
{
{ FAP_LAYER_NUMBER: (input) This parameter specifies the fap layer number.}
{
{ STATUS: (output) This parameter specifies the request status.}
{
*DECK DECK=BAH$PUT_ROUTE_INFO EXPAND=FALSE
{
{ the purpose of this request is to provide a mechanism for saving
{ routing information in the system file label.
{
{        BAP$PUT_ROUTE_INFO (FILE_IDENTIFIER,QLABEL,STATUS)
{
{ FILE_IDENTIFIER: (input) this parameter specifies the file access
{        identifier established when the file was opened.
{
{ QLABEL: (input) this parameter specifies an array in the calling
{        programs address space from which the routing information label
{        is to be retrieved. the size of the array is assumed to be 400
{        bytes.
{
{ STATUS: (output) this parameter specifies the request status
*DECK DECK=BAH$RECORD_MANAGEMENT_FUNCTIONS EXPAND=FALSE
{}
{ COMMON DECK BAH$RECORD_MANAGEMENT_FUNCTIONS}
{}
{    These inline procedures are for use with all BAM faps.
{ These procedures perform generalized functions for all record types.
{}
*DECK DECK=BAH$RECORD_OPENED_FILE_TARGET EXPAND=FALSE
{
{   This request is called by the connected file device file access  procedure
{ (fap)  to  add  a  target file instance to a subject file instance's list of
{ targets.  Also, the target file instance's close_allowed  field  is  set  to
{ false  to prevent closing of the target file instance other than via closing
{ the subject file instance.
{
{       BAP$RECORD_OPENED_FILE_TARGET (SUBJECT_FILE_IDENTIFIER,
{         TARGET_FILE_INDEX, TARGET_FILE_IDENTIFIER, CONNECTION_LEVEL)
{
{ SUBJECT_FILE_IDENTIFIER: (input) This parameter specified the  subject  file
{       instance of open.
{
{ TARGET_FILE_INDEX:  (input) This parameter specifies the position in list of
{       targets to be occupied by the target file.
{
{ TARGET_FILE_IDENTIFIER: (input) This parameter  specified  the  target  file
{       instance of open.
{
{ CONNECTION_LEVEL:  (input) This parameter specifies the connection_level of
{       the target.
{
*DECK DECK=BAH$RECORD_OPENED_SUBJECT_FILE EXPAND=FALSE
{
{   This request is called by the connected file device file access  procedure
{ (fap)  to  initialize  the  subject file instance's fields that describe the
{ state of the subject's connections.
{
{       BAP$RECORD_OPENED_SUBJECT_FILE (SUBJECT_FILE_IDENTIFIER)
{
{ SUBJECT_FILE_IDENTIFIER: (input) This parameter specifies the  subject  file
{       instance of open.
{
*DECK DECK=BAH$RECORD_SUBJECT_FILE_OP EXPAND=FALSE
{
{   This request is called by the connected file device file access  procedure
{ (fap)  to  record the completion of an operation on a subject file instance.
{ It also updates the subject file instance's connection_level field.
{
{       BAP$RECORD_SUBJECT_FILE_OP (SUBJECT_FILE_IDENTIFIER, OPERATION,
{         FILE_POSITION)
{
{ SUBJECT_FILE_IDENTIFIER: (input) This parameter specifies the  subject  file
{       instance of open.
{
{ OPERATION: (input) This parameter specifies the operation to be recorded.
{
{ FILE_POSITION:  (input)  This  parameter  specifies  the  file_position that
{       resulted from processing the operation.
{
*DECK DECK=BAH$RELEASE_RESOURCE_COMMAND EXPAND=FALSE
{
{   The purpose of  this request is to implement the RESERVE_RESOURCE command.
{ This  allows  release  of  resources   previously   established   with   the
{ RESERVE_RESOURCE  command  or by implicit reservation.  Resources may not be
{ released if there is currently  a  tape  assigned  to  a  transport  of  the
{ resource class.   Resources are also released implicitly at job termination.
{
{       BAP$RELEASE_RESOURCE_COMMAND (RELEASE_REQUEST, STATUS)
{
{ RELEASE_REQUEST:  This  parameter  specifies  the number of nine track tapes
{       with 800, 1600, or 6250 cpi to be releases by the job.  To release all
{       of  a  given  density  a  value of UPPERVALUE of that particular field
{       should be used.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: amc$access_method_id
{
*DECK DECK=BAH$RELEASE_SB EXPAND=FALSE
{
{
{     This request will release a system buffer and its associated
{     system buffer descriptor.
{
{  BAP$RELEASE_SB (KFT_DESCRIPTOR,SBD_PTR,STATUS)
{
{    KFT_DESCRIPTOR : (input) this parameter specifies the known
{                      file table entry.
{
{    SBD_PTR : (input) this parameter specifies a pointer to the system
{               buffer descriptor ordinal to be released.
{
{    STATUS : (output) this parameter specifies request status.
{
*DECK DECK=BAH$RENAME EXPAND=FALSE
{
{ the purpose of this request is to change the local file
{ name of a file . this request does not change the permanent
{ name of the file.
{
{
{        BAP$RENAME (OLD_FILE_NAME,NEW_FILE_NAME,STATUS)
{
{ OLD_FILE_NAME : (input) this parameter specifies the
{        name of a local file currently known to the system.
{
{ NEW_FILE_NAME : (input) this parameter specifies the
{        name by which the file will now be known.
{
{STATUS : (output) this parameter specifies the request status.
*DECK DECK=BAH$REQUEST_TERMINAL_COMMAND EXPAND=FALSE
{
{   The purpose of  this request is to implement the REQUEST_TERMINAL command.
{ This directs assignment of the file to the terminal.  If this  interface  is
{ called  in  batch  mode  an  error  status is returned.  For release one the
{ terminal attributes specified on this request are not honored.
{
{       BAP$REQUEST_TERMINAL_COMMAND (LOCAL_FILE_NAME, TERMINAL_ATTRIBUTES,
{         STATUS)
{
{ LOCAL_FILE_NAME:  This  parameter specifies the file to be associated with a
{       terminal.
{
{ TERMINAL_ATTRIBUTES:  (input)  This   parameter   specifies   the   terminal
{       attributes associated with the file.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: rme$improper_term_attrib_value
{                   ife$current_job_not_interactive
{
{       IDENTIFIER: amc$access_method_id
{
*DECK DECK=BAH$RESERVE_RESOURCE_COMMAND EXPAND=FALSE
{
{   The purpose of  this request is to implement the RESERVE_RESOURCE command.
{ This can be used to inform NOS/VE of the number of  tape  transports  a  job
{ needs to use concurrently.  Actual assignment of the transport to the job is
{ not made until a tape file is opened for access.  This command is needed  if
{ the job requires the concurrent use of more than one tape transport.
{
{       BAP$RESERVE_RESOURCE_COMMAND (RESERVE_REQUEST, STATUS)
{
{ RESERVE_REQUEST:  (input)  This parameter specifies the number of nine track
{       drives of density 800, 1600, or 6250 that are required by the job.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: amc$access_method_id
{
*DECK DECK=BAH$REWIND EXPAND=FALSE

{ COMMON DECK BAHREWD }

{   The purpose of this request is to reposition to the beginning of information
{ of the file.  This is the ring 3 interface that is used by amp$rewind.
{
{       BAP$REWIND (FILE_IDENTIFIER, CALL_BLOCK, FAP_LAYER_NUMBER, STATUS)
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the file access identifier
{       established when the file was opened.
{
{ CALL_BLOCK: (input) This parameter specifies the call block for the request.
{
{ FAP_LAYER_NUMBER: (input) This parameter specifies the fap layer number.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=BAH$SEARCH_FOR_SB_DESCRIPTOR EXPAND=FALSE
{
{     This request searches a files system buffer descriptor chain
{     for a byte address.
{
{  BAP$SEARCH_FOR_SB_DESCRIPTOR (KFT_DESCRIPTOR,BYTE_ADDRESS,SBD_PTR,STATUS)
{
{    KFT_DESCRIPTOR : (input) this parameter specifies the known file
{                      table entry.
{
{    BYTE_ADDRESS : (input) this parameter specifies the byte address to
{                    search for.
{
{    SBD_PTR : (output) this parameter specifies the system buffer descriptor
{               ordinal containing the byte address or NIL.
{               if NIL then the byte addess is not in the current system
{               buffer descriptor chain.
{
{    STATUS : (output) this parameter specifies request status.
*DECK DECK=BAH$SEEK_DIRECT EXPAND=FALSE

{ COMMON DECK BAHSEEK }

{   The purpose of this request is to provide the ring 3 interface to
{ amp$seek_direct.
{ It will position the file to the byte address specified in the call block.
{ Record and block manager tables are updated to reflect the new file
{ position.
{
{       BAP$SEEK_DIRECT (FILE_IDENTIFIER, CALL_BLOCK, FAP_LAYER_NUMBER,
{         STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access identifier
{       established when the file was opened.
{
{ CALL_BLOCK: (input)  This parameter specifies the call block which carries
{       the file byte address.
{
{ FAP_LAYER_NUMBER: (input) This parameter specifies the fap layer number.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=BAH$SET_FILE_INSTANCE_ABNORMAL EXPAND=FALSE

{}
{   The purpose of this request to set a status variable to represent an}
{ abnormal condition.}
{   This request is intended to be used in situations where the detected}
{ condition is peculiar to an instance of open and the file_identifier is}
{ valid. If the file_identifer is invalid then use osp$set_status_abnormal.}
{   If the caller of this request believes that the file_identifier is valid}
{ and this request determines that it is invalid, only fixed parameters}
{ 2 and 8 will be initialized.}
{   Use osp$append_status_parameter to include additional parameters.}
{}
{       BAP$SET_FILE_INSTANCE_ABNORMAL (FILE_IDENTIFIER,
{         EXCEPTION_CONDITION, REQUEST_NAME, TEXT, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the identity of the}
{       instance of open of a file for which an exception condition has}
{       been detected.}
{}
{ EXCEPTION_CONDITION: (input) This parameter specifies the condition}
{       code for the abnormal condition.}
{}
{ REQUEST_NAME: (input) This parameter specifies the request name which}
{       detected the condition.}
{}
{ TEXT: (input) This parameter specifies text to be included in the status}
{       for the exception_condition. By convention this interface}
{       will initialize the first 7 parameters in status.text as follows:}
{         1. Local_file_name.}
{         2. Name of the request which detected condition.}
{         3. Access_level.}
{         4. File_organization.}
{         5. Record_type.}
{         6. Block_type.}
{         7. Reserved for access method internal use.}
{       The eighth parameter is initialized to the value of this parameter.}
{}
{ STATUS: (output) This parameter specifies the status variable which is}
{       to be initialized by this request.}
{}
*DECK DECK=BAH$SET_LOCAL_NAME_ABNORMAL EXPAND=FALSE

{}
{   The purpose of this request to set a status variable to represent an}
{ abnormal condition.}
{   This request is intended to be used in situations where the local name}
{ is known but the error is not peculiar to an instance of open of the file.}
{ To set abnormal status for an instance of open, use}
{ amp$set_file_instance_abnormal. If neither the local_file_name nor the}
{ file_identifier are known use osp$set_status_abnormal.}
{   Use osp$append_status_parameter to include additional parameters.}
{}
{       BAP$SET_LOCAL_NAME_ABNORMAL (LOCAL_FILE_NAME,
{         EXCEPTION_CONDITION, REQUEST_NAME, TEXT, STATUS)
{}
{ LOCAL_FILE_NAME: (input) This parameter specifies the local name of the}
{       file for which an exception condition has been detected.}
{}
{ EXCEPTION_CONDITION: (input) This parameter specifies the condition}
{       code for the abnormal condition.}
{}
{ REQUEST_NAME: (input) This parameter specifies the request name which}
{       detected the condition.}
{}
{ TEXT: (input) This parameter specifies text to be included in the status}
{       for the exception_condition. By convention this interface}
{       will intialize the first 7 parameters in status.text to the following:
{         1. Local_file_name.}
{         2. Name of the request which detected condition.}
{         3. null string.}
{         4. null string.}
{         5. null string.}
{         6. null string.}
{         7. Reserved for access method internal use.}
{       The eighth parameter is initialized to the value of this parameter.}
{}
{ STATUS: (output) This parameter specifies the status variable which is}
{       to be initialized by this request.}
{}
*DECK DECK=BAH$SET_SEGMENT_EOI EXPAND=FALSE
{
{   The purpose of this request is to preserve the EOI byte address of a file}
{ opened for segment access. The effect of this request is to extract the}
{ byte_offset portion of the input pointer variable and store as the}
{ EOI byte address of the file. This request may be issued repeatedly}
{ throughout the task's usage of the file. Typically this request would be}
{ used prior to amp$close or task termination to define EOI for a newly}
{ created file. The user must have appropriate access privilege to redefine}
{ the EOI byte address of a pre-existant file.}
{   At close or task termination, pages and mass storage allocation beyond the}
{ newly defined EOI are released from the file. The pages and mass storage are}
{ cleared if the clear_space file attribute was specified at file creation.}
{   If this request is not issued for a newly created file, the EOI byte}
{ address will be determined from the highest virtual memory page referenced}
{ Thus EOI is rounded up to the nearest page boundary and may be imprecise.}
{
{       BAP$SET_SEGMENT_EOI (FILE_IDENTIFIER, CALL_BLOCK,
{        FAP_CONTROL_INFORMATION, FAP_LAYER_NUMBER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{
{ CALL_BLOCK: (input) This paramter specifies the call block
{        used by this request.
{
{ FAP_CONTROL_INFORMATION: (input) This paramter specifies control
{        information necessary for orderly transfer of control from
{        the fap the the access method and from one access method
{        layer to another.
{
{ FAP_LAYER_NUMBER: (input) This parameter specifies the index into the
{        fap_control_information for this layer.
{
{ STATUS: (output) This parameter specifies the request status. THis is
{        the application's status variable.
{
*DECK DECK=BAH$SET_SEGMENT_POSITION EXPAND=FALSE
{
{   The purpose of this request is to preserve the current position of a file}
{ opened for segment access. The effect of this request is to extract the}
{ byte_offset portion of the input pointer variable and store as the}
{ current_byte_address of the file. This request may be issued repeatedly}
{ throughout a task's usage of the file. Typically this request would be}
{ used prior to amp$close or task termination to pass the current position}
{ within the segment to a subsequent task. However, this request may be used}
{ with amp$get_segment_pointer to alternately save and retrieve the file}
{ position across application interfaces.}
{
{       BAP$SET_SEGMENT_POSITION (FILE_IDENTIFIER, CALL_BLOCK,
{         FAP_CONTROL_INFORMATION, FAP_LAYER_NUMBER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{
{ CALL_BLOCK: (input) This paramter specifies the call block
{        used by this request.
{
{ FAP_CONTROL_INFORMATION: (input) This paramter specifies control
{        information necessary for orderly transfer of control from
{        the fap the the access method and from one access method
{        layer to another.
{
{ FAP_LAYER_NUMBER: (input) This parameter specifies the index into the
{        fap_control_information for this layer.
{
{ STATUS: (output) This parameter specifies the request status. THis is
{        the application's status variable.
{
*DECK DECK=BAH$SET_STD_FILES_DEFAULT_AM EXPAND=FALSE
{
{   This request is called by the connected file device file access procedure
{ (fap) to default the access_modes of a standard file that is the subject of a
{ file connection and whose access_modes were not specified on the open.
{ The access_modes of $ECHO, $ERRORS, $LIST, $OUTPUT, and $RESPONSE will default
{ to [append, shorten] and $INPUT to [read].
{
{       BAP$SET_STD_FILES_DEFAULT_AM (SUBJECT_FILE_IDENTIFIER)
{
{ SUBJECT_FILE_IDENTIFIER: (input) This parameter specifies the subject file
{       instance of open.
{
*DECK DECK=BAH$SKIP EXPAND=FALSE
{
{   The purpose of this request is to reposition a file which was created}
{ sequentially and opened for amc$record access.}
{   This request does not cause data movement to or from a user}
{ working_storage_area.}
{   For a file associated with tape, the file and volume are terminated}
{ according to convention, if the preceding operation was an output to the}
{ tape. If the label_type is amc$labelled(*), the standard ANSI EOF label}
{ and two tapemarks are written; then the tape volume is positioned by the}
{ access method prior to the EOF label. For an amc$unlabelled file, two}
{ tapemarks are written to terminate the file and volume; then the volume}
{ is positioned by the access method prior to the two tapemarks.}
{   The following table indicates which positioning options are available}
{ for a file opened with amc$record access_level: }
{}
{  |--------------------------------------------------------------------|  }
{  |          Block_type ->   |  System_specified  ||  User_specified   |  }
{  |                          |____________________||___________________|  }
{  |          Record_type ->  | V | F | U | S | D  || V | F | U | S | D |  }
{  |                          |   |   |   |(*)|(*) ||   |   |   |(*)|(*)|  }
{  |--------------------------------------------------------------------|  }
{  |  Forward  N records      | x | x | 2 | 1 | 1  || x | x | x | x | x |  }
{  |  Backward N records      | x | x | 2 | 1 | 1  || x | x | x | 2 | 2 |  }
{  |  Forward  N partitions   | x | 2 | 2 | 1 | 1  || x | 2 | 2 | 2 | 2 |  }
{  |  Backward N partitions   | x | 2 | 2 | 1 | 1  || x | 2 | 2 | 2 | 2 |  }
{  |--------------------------------------------------------------------|  }
{}
{   Notes on preceding table: }
{     1. This combination of record_type and block_type is not supported.}
{     2. This is an undefined operation and abnormal status will be returned.}
{}
{   The final position of the file, assuming no boundary condition was}
{ encountered before the COUNT was exhausted, is as follows:}
{}
{   Skip of UNIT = record:
{}
{     . If the file is positioned before RECORD N and}
{       a forward skip of M RECORDs is performed, the final position will}
{       be at the end of RECORD N+M-1.}
{     . If the file is positioned within or at the end of RECORD N and}
{       a forward skip of M RECORDs is performed, the final position will}
{       be at the end of RECORD N+M.}
{     . If the file is positioned before RECORD N and}
{       a backward skip of M RECORDs is performed, the final position}
{       will be at the end of RECORD N-M-1.}
{     . If the file is positioned within or at the end of RECORD N and}
{       a backward skip of M RECORDs is performed, the final position}
{       will be at the end of RECORD N-M-1.}
{}
{   Skip of UNIT = partition:
{}
{     . If the file is positioned somewhere within PARTITION N and}
{       a forward skip of M PARTITIONs is performed, the final position will}
{       be at the beginning of PARTITION N+M. A count of zero (M=0) is}
{       treated the same as if a count of one had been given (M=1).}
{     . If the file is positioned somewhere within PARTITION N and}
{       a backward skip of M PARTITIONs is performed, the final position}
{       will be at the beginning of PARTITION N-M.}
{     . If N amp$write_end_partition requests have been performed on a}
{       sequential file and the file is positioned after the Nth partition}
{       delimiter, then by definition the file is positioned within}
{       partition N+1. Therefore from this position (EOI), a backward skip}
{       of one partition would position the file at the beginning of}
{       partition N.}
{}
{   If a boundary condition is detected before the skip COUNT is
{ exhausted, then control will return to the caller with an abnormal}
{ STATUS. The actual number of UNITs skipped in this case may be}
{ determined by subtracting the residual_skip_count available via the}
{ amp$fetch_access_information request from the original skip COUNT.}
{ When a skip forward by records encounters a partition boundary condition,}
{ the final position is beyond the boundary, i.e. at the beginning of}
{ the next partition.}
{ When a skip backward by records encounters a partition boundary condition,}
{ the final position is prior to the boundary, i.e. at the end of the}
{ preceding partition.}
{}
{}
{ Boundary conditions: }
{}
{ .   Skip forward by records encounters partition/EOI.
{}
{ .   Skip forward by partitions encounters EOI.
{}
{ .   Skip backward by records encounters partition/BOI.
{}
{ .   Skip backward by partitions encounters BOI.
{}
{       Possible file positions resulting from a forward skip are: }
{         . amc$eor - skipping records only}
{         . amc$bop - skipping records/partitions only}
{         . amc$eoi - any UNIT}
{       Possible file positions resulting from a backward skip are: }
{         . amc$eor - skipping records only}
{         . amc$bop - skipping partitions only}
{         . amc$eop - skipping records only}
{         . amc$boi - any UNIT}
{}
{    BAP$SKIP ( FILE_IDENTIFIER, CALL_BLOCK, FAP_LAYER_NUMBER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ CALL_BLOCK: ( input ) This parameter specifies the call block
{       used by this request.
{
{ FAP_LAYER_NUMBER: (input) This parameter specifies the index into the
{        fap_control_information for this layer.
{
{
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=BAH$STORE EXPAND=FALSE

{ COMMON DECK BAHSTOR }

{    The purpose of this request is to store the value of one or
{ more file attributes subsequent to the file being opened.
{ Attribute values provided with this request are not preserved with
{ the file as they are peculiar to an instance of open of the file.
{
{        BAP$STORE (FILE_IDENTIFIER, CALL_BLOCK, FAP_LAYER_NUMBER,
{                   STATUS)
{
{ FILE_IDENTIFIER: ( input) THis parameter specifies the file access
{        identifier established when the file was opened.
{
{ CALL_BLOCK: (input) This parameter specifies the call block
{        used by this request.
{
{ FAP_LAYER_NUMBER: (input) This parameter specifies the fap layer number.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=BAH$SYS_BLK_FIXED_REC_FAP EXPAND=FALSE
{}
{ COMMON DECK BAH$SYS_BLK_FIXED_REC_FAP }
{}
{   The purpose of this procedure is to perform record access functions via
{ the file access procedure mechanism.  This file access procedure is
{ associated with a file at open time if the file is a system specified
{ blocked, record access level, fixed record type file and is assigned
{ to a mass storage device.
{}
{     BAP$SYS_BLK_FIXED_REC_FAP (FILE_IDENTIFIER, CALL_BLOCK,
{         LAYER_NUMBER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file identifier
{   ordinal for an instance of open of a file.
{
{ CALL_BLOCK: (input, output) This parameter specifies the operation to be
{   performed.  This parameter returns file position, transfer count, and
{   byte address via pointer reference.
{
{ LAYER_NUMBER: (input) This parameter specifies the layer number of this
{   file access procedure.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=BAH$SYS_BLK_FIXED_REC_TAPE_FAP EXPAND=FALSE
{}
{ COMMON DECK BAH$SYS_BLK_FIXED_REC_TAPE_FAP }
{}
{   The purpose of this procedure is to perform record access functions via
{ the file access procedure mechanism.  This file access procedure is
{ associated with a file at open time if the file is a system specified
{ blocked, record access level, fixed record type file and is assigned
{ to a tape device.
{}
{     BAP$SYS_BLK_FIXED_REC_TAPE_FAP (FILE_IDENTIFIER, CALL_BLOCK,
{         LAYER_NUMBER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file identifier
{   ordinal for an instance of open of a file.
{
{ CALL_BLOCK: (input, output) This parameter specifies the operation to be
{   performed.  This parameter returns file position, transfer count, and
{   byte address via pointer reference.
{
{ LAYER_NUMBER: (input) This parameter specifies the layer number of this
{   file access procedure.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=BAH$SYS_BLK_UNDEFINED_REC_FAP EXPAND=FALSE
{}
{ COMMON DECK BAH$SYS_BLK_UNDEFINED_REC_FAP }
{}
{   The purpose of this procedure is to perform record access functions via
{ the file access procedure mechanism.  This file access procedure is
{ associated with a file at open time if the file is a system specified
{ blocked, record access level, undefined record type file and is assigned
{ to a mass storage device.
{}
{     BAP$SYS_BLK_UNDEFINED_REC_FAP (FILE_IDENTIFIER, CALL_BLOCK,
{         LAYER_NUMBER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file identifier
{   ordinal for an instance of open of a file.
{
{ CALL_BLOCK: (input, output) This parameter specifies the operation to be
{   performed.  This parameter returns file position, transfer count, and
{   byte address via pointer reference.
{
{ LAYER_NUMBER: (input) This parameter specifies the layer number of this
{   file access procedure.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=BAH$SYS_BLK_UNDEF_REC_TAPE_FAP EXPAND=FALSE
{}
{ COMMON DECK BAH$SYS_BLK_UNDEF_REC_TAPE_FAP }
{}
{   The purpose of this procedure is to perform record access functions via
{ the file access procedure mechanism.  This file access procedure is
{ associated with a file at open time if the file is a system specified
{ blocked, record access level, undefined record type file and is assigned
{ to a tape device.  All access to this file will then go
{ through this file access procedure.
{}
{     BAP$SYS_BLK_UNDEFINED_REC_TAPE_FAP (FILE_IDENTIFIER, CALL_BLOCK,
{         LAYER_NUMBER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file identifier
{   ordinal for an instance of open of a file.
{
{ CALL_BLOCK: (input, output) This parameter specifies the operation to be
{   performed.  This parameter returns file position, transfer count, and
{   byte address via pointer reference.
{
{ LAYER_NUMBER: (input) This parameter specifies the layer number of this
{   file access procedure.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=BAH$SYS_BLK_VARIABLE_REC_FAP EXPAND=FALSE
{}
{ COMMON DECK BAH$SYS_BLK_VARIABLE_REC_FAP }
{}
{   The purpose of this procedure is to perform record access functions via
{ the file access procedure mechanism.  This file access procedure is
{ associated with a file at open time if the file is a system specified
{ blocked, record access level, variable record type file and is assigned
{ to a mass storage device.
{}
{     BAP$SYS_BLK_VARIABLE_REC_FAP (FILE_IDENTIFIER, CALL_BLOCK,
{         LAYER_NUMBER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file identifier
{   ordinal for an instance of open of a file.
{
{ CALL_BLOCK: (input, output) This parameter specifies the operation to be
{   performed.  This parameter returns file position, transfer count, and
{   byte address via pointer reference.
{
{ LAYER_NUMBER: (input) This parameter specifies the layer number of this
{   file access procedure.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=BAH$SYS_BLK_VAR_REC_TAPE_FAP EXPAND=FALSE
{}
{ COMMON DECK BAH$SYS_BLK_VAR_REC_TAPE_FAP }
{}
{   The purpose of this procedure is to perform record access functions via
{ the file access procedure mechanism.  This file access procedure is
{ associated with a file at open time if the file is a system specified
{ blocked, record access level, variable record type file and is assigned
{ to a tape device.
{}
{     BAP$SYS_BLK_VAR_REC_TAPE_FAP (FILE_IDENTIFIER, CALL_BLOCK,
{         LAYER_NUMBER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file identifier
{   ordinal for an instance of open of a file.
{
{ CALL_BLOCK: (input, output) This parameter specifies the operation to be
{   performed.  This parameter returns file position, transfer count, and
{   byte address via pointer reference.
{
{ LAYER_NUMBER: (input) This parameter specifies the layer number of this
{   file access procedure.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=BAH$TAPE_BM_ADVANCE_VOLUME EXPAND=FALSE
{   This procedure is called to advance to the next volume of a tape file.
{
{   If the last operation on the current volume was a write, the volume will
{ be terminated by writing two tape marks before the new volume is assigned.
{
{   Note that for labeled tapes the caller must ensure that all labels have
{ been written before calling this procedure.
{
{   BAP$TAPE_BM_ADVANCE_VOLUME(FILE_IDENTIFIER, FAILURE_MODES, STATUS)
{
{   FILE_IDENTIFIER (Input):  The file identifier for the file.
{
{   ALLOW_SCRATCH_VOLUMES_ON_WRITE (Input): TRUE to allow scratch volumes
{        to be mounted after the VSN list is exausted.  FALSE to inhibit
{        assignment of scratch volumes.
{
{   FAILURE_MODES:  (Output):  Tape failure modes.
{
{   STATUS: (Output) Request status.
*DECK DECK=BAH$TAPE_BM_ALIGN_POSITION EXPAND=FALSE
{   This procedure is called to reposition the tape so that the tape is
{ physically positioned at the same place as it is logically positioned.  This
{ procedure is generally called only as part of file close processing.
{
{       BAP$TAPE_BM_ALIGN_POSITION (FILE_IDENTIFIER, FAILURE_MODES, STATUS)
{
{  FILE_IDENTIFIER:  (Input) The file_identifier for the instance of open to
{        be aligned.
{
{  FAILURE_MODES:  (Output) Detailed information on any tape I/O error.
{
{  STATUS: (output) Request status.
*DECK DECK=BAH$TAPE_BM_CLOSE EXPAND=FALSE
{   This procedure is called to close a tape file.
{
{   If the last operation was a write, the volume will be
{ terminated by writing two tape marks.
{
{   To ensure that all user data is written to tape and that the
{ tape is correctly positioned the caller of this procedure
{ must first complete a call to BAP$TAPE_BM_ALIGN_POSITION.
{
{   Note that for labeled tapes the caller must ensure that all file
{ labels have been written before calling this procedure.
{
{   Recommended algorithm for normal closing of a tape file:
{
{ /close_tape_file/
{   BEGIN
{   /flush_data_to_tape/
{     BEGIN
{       REPEAT
{         bap$tape_bm_align_position(file_id,failure_modes,
{               internal_status);
{         IF NOT internal_status.normal THEN
{           CASE internal_status.condition OF
{             = bae$vol_end_operation_inhibited =
{               <write volume end labels>
{               bap$tape_bm_advance_volume(file_id,internal_status);
{               IF NOT internal_status.normal THEN
{                 EXIT flush_data_to_tape;
{               IFEND;
{               <write volume begin labels>
{             = bae$vol_end_operation_complete =
{               <write volume end labels>
{           ELSE
{           CASEND;
{         IFEND;
{       UNTIL internal_status.normal OR internal_status.condition <>
{            bae$vol_end_operation_inhibited;
{     END flush_data_to_tape;
{     bap$tape_bm_close(file_id,status);
{     IF status.normal THEN
{       status := internal_status;
{     IFEND;
{   END close_tape_file;
{
{   This sequence ensures that all user data gets flushed to tape,
{ even if additional volumes are required.
{
{   To close a tape file after a fatal error the flush process should be
{ omitted.  The close will consist of a simple call to bap$tape_bm_close.
{
{     BAP$TAPE_BM_CLOSE(FILE_IDENTIFIER, FAILURE_MODES, STATUS)
{
{  FILE_IDENTIFIER: (Input) The file_identifier for the instance of
{      open to be closed.
{
{  FAILURE_MODES:  (Output) Detailed information on any tape I/O error.
{
{  STATUS: (output) Request status.
*DECK DECK=BAH$TAPE_BM_ERASE_BLOCK EXPAND=FALSE
{   This procedure is called to erase an arbitrary length of tape.
{
{ NOTE:  Due to hardware restrictions, tape can only be erased in multiples of
{       approximately three inches.  This procedure will erase the minimum
{       number of 3-inch areas necessary to erase the length specified.
{
{       BAP$TAPE_BM_ERASE_BLOCK(FILE_IDENTIFIER, BLOCK_LENGTH, FAILURE_MODES,
{       STATUS)
{
{  FILE_IDENTIFIER (Input):  The file identifier for the file.
{
{  BLOCK_LENGTH:  (Input) The number of bytes which correspond to the desired
{        erased length.
{
{  FAILURE_MODES:  (Output) Detailed information on any tape I/O error.
{
{  STATUS: (Output) Request status.
*DECK DECK=BAH$TAPE_BM_FLUSH EXPAND=FALSE
{   This procedure is called to force all unwritten data tape data out onto
{ the physical tape.
{
{   If no data exists which has not been written to tape this interface takes
{ no action and returns normal status.
{
{       BAP$TAPE_BM_FLUSH (FILE_IDENTIFIER, FAILURE_MODES, STATUS)
{
{  FILE_IDENTIFIER:  (Input) The file_identifier for the instance of open to
{        be flushed.
{
{  FAILURE_MODES:  (Output) Detailed information on any tape I/O error.
{
{  STATUS: (output) Request status.
*DECK DECK=BAH$TAPE_BM_OPEN EXPAND=FALSE
{   This procedure is called to open a tape file.
{
{ NOTE:  Open positioning is not supported by this interface.  Open
{       positioning must be implemented by the caller.
{
{       BAP$TAPE_BM_OPEN(FILE_IDENTIFIER, MAXBL, STATUS)
{
{  FILE_IDENTIFIER (Input):  The file identifier for the file.
{
{  MAXBL:  (Input) The maximum block length (in bytes) to be supported for
{        this tape.
{
{  STATUS: (Output) Request status.
{
*DECK DECK=BAH$TAPE_BM_READ_NEXT_BLOCK EXPAND=FALSE
{   This procedure is called to read the next block from a tape.
{
{   The caller may, if desired, volunteer a buffer to be used to read the
{ block.  Block Management may or may not choose to use the volunteered
{ buffer.  The caller may determine whether or not the volunteered buffer was
{ used by comparing the returned block pointer with a pointer to the
{ volunteered area.
{
{   The intention of this mechanism is to allow User-blocked, Undefined record
{ type tape to be read directly into the user's buffer when blocks are large,
{ and to avoid locking down unnecessarily large amounts of memory when the
{ application knows how large a block to expect.  Accordingly, block
{ management will attempt to use the volunteered buffer whenever it does not
{ already have the block buffered and the volunteered buffer is properly word
{ aligned.  This will occur even if the volunteered buffer is smaller than the
{ actual block on tape.
{
{   If the actual block read is longer than the buffer area volunteered as
{ much as possible of the block will be placed in the volunteered area and
{ status of BAE$BLOCK_TRUNCATED will be returned.  If the caller desires to
{ receive the complete block BAP$TAPE_BM_SKIP should be called to reposition
{ the tape one block backwards and another call made to
{ BAP$TAPE_BM_READ_NEXT_BLOCK specifying either a larger volunteered buffer or
{ no volunteered buffer.
{
{   Tape read errors are indicated by both an abnormal status and a value in
{ the tape_failure_isolation.  The status condition will be
{ BAE$UNRECOVERABLE_READ_ERROR.  The data read, if any, is returned to the
{ caller even if a read error occurs.  The tape is left positioned after the
{ bad block.  If the caller was reading without system media error recovery
{ and wishes to have system error recovery attempted BAP$TAPE_BM_SKIP should
{ be called to reposition before the block and another call made to
{ BAP$TAPE_BM_READ_NEXT_BLOCK which specifies media_recovery as TRUE.
{
{   BAP$TAPE_BM_READ_NEXT_BLOCK(FILE_IDENTIFIER, VOLUNTEERED_BUFFER,
{ VOLUNTEERED_LENGTH, MEDIA_RECOVERY, BLOCK_PTR, BLOCK_TYPE, BLOCK_LENGTH,
{ FAILURE_MODES, STATUS)
{
{       FILE_IDENTIFIER (Input):  The file identifier for the file.
{
{  VOLUNTEERED_BUFFER:  (Input) A pointer to the volunteered buffer area, or
{        NIL if no buffer is volunteered.
{
{  VOLUNTEERED_LENGTH:  (Input) The length of the volunteered buffer.
{        (Ignored if no buffer is volunteered.)
{
{  MEDIA_RECOVERY:  (Input) TRUE to have the system attempt recovery from
{        media errors encountered while reading this block from tape.  FALSE
{        to suppress any attempt by the system to recover from media errors.
{
{  BLOCK_PTR:  (Output) A pointer to the block which was read.
{
{  BLOCK_TYPE:  (Output) The type of block read.  (Good data block, error data
{        block, or tapemark.)
{
{  BLOCK_LENGTH:  The length of the block read.
{
{  FAILURE_MODES:  (Output) Detailed information on any tape I/O error.
{
{  STATUS: (output) Request status.
*DECK DECK=BAH$TAPE_BM_RESERVE_BLK_BUFFER EXPAND=FALSE
{ This procedure is called to reserve a tape block buffer.
{
{ A pointer to the tape block buffer is returned to the caller.
{ The buffer may then be filled with data and passed to
{ BAP$TAPE_BM_WRITE_NEXT_BLOCK for eventual writing to tape.
{
{ Calling this procedure reserves the returned buffer to the caller.
{ Calling BAP$TAPE_BM_WRITE_NEXT_BLOCK releases the reservation, and
{ that buffer may no longer be used.  (A new buffer should be acquired
{ by calling this procedure.)
{
{ Only one block buffer may be reserved at a time.  Any attempt to
{ reserve a buffer when a buffer is already reserved will be rejected
{ with status BAE$TOO_MANY_RESERVED_BUFFERS.
{
{ In addition to the release of reservations by calling
{ BAP$TAPE_BM_WRITE_NEXT_BLOCK, any outstanding reservation is implicitly
{ released by a call to any of the following procedures:
{
{     BAP$TAPE_BM_WRITE_TAPE_MARK
{     BAP$TAPE_BM_SKIP
{     BAP$TAPE_BM_ERASE_BLOCK
{     BAP$TAPE_BM_REWIND
{
{ To continue writing after calling one of these procedures you should
{ call this procedure again to reserve a new block buffer.
{
{     BAP$TAPE_BM_RESERVE_BLK_BUFFER(FILE_IDENTIFIER,
{         BUFFER_POINTER, FAILURE_MODES, STATUS)
{
{ FILE_IDENTIFIER (Input): The file identifier for the file.
{
{  BUFFER_POINTER: (Output) A pointer to the tape block buffer.
{
{  FAILURE_MODES:  (Output) Detailed information on any tape I/O error.
{
{  STATUS: (Output) Request status.
*DECK DECK=BAH$TAPE_BM_REWIND EXPAND=FALSE
{   This procedure is called to reset a tape file to the beginning of the
{ first reel.
{
{   If the last operation on the current volume was a write, the volume will
{ be terminated by writing two tape marks before the rewind is performed.
{
{   Note that for labeled tapes the caller must ensure that all labels have
{ been written before calling this procedure.
{
{ NOTE:  Calling this procedure implicitly releases any tape block buffer
{       reservation.
{
{       BAP$TAPE_BM_REWIND(FILE_IDENTIFIER, FAILURE_MODES, STATUS)
{
{   FILE_IDENTIFIER (Input):  The file identifier for the file.
{
{  FAILURE_MODES:  (Output) Detailed information on any tape I/O error.
{
{  STATUS: (Output) Request status.
*DECK DECK=BAH$TAPE_BM_SKIP_BLOCKS EXPAND=FALSE
{   This procedure is called to reposition the tape without moving data.
{ Blocks may be skipped either forward or backward.
{
{   The skip terminates if a tape mark or the end of the volume is
{ encountered, or when the requested number of blocks have been skipped.
{
{ NOTE:  Calling this procedure implicitly releases any tape block buffer
{       reservation.
{
{       BAP$TAPE_BM_SKIP_BLOCKS(FILE_IDENTIFIER, DIRECTION, COUNT,
{       RESIDUAL_COUNT, FAILURE_MODES, STATUS)
{
{   FILE_IDENTIFIER (Input):  The file identifier for the file.
{
{  DIRECTION:  (Input) Direction of skipping.  Either amc$forward or
{        amc$backward.
{
{  COUNT:  (Input) The number of blocks or tape marks to be skipped.
{
{  RESIDUAL_COUNT:  (Output) The number of blocks or tape marks that remained
{        to be skipped after the skip terminated.  This will be non-zero if
{        the skip terminates because a boundary was encountered.  (Such as the
{        end of the reel.)
{
{  FAILURE_MODES:  (Output) Detailed information on any tape I/O error.
{
{  STATUS: (Output) Request status.
*DECK DECK=BAH$TAPE_BM_SKIP_TAPEMARK EXPAND=FALSE
{   This procedure is called to reposition the tape without moving data.  A
{ single tapemark may be skipped either forward or backward.
{
{ NOTE:  Calling this procedure implicitly releases any tape block buffer
{       reservation.
{
{       BAP$TAPE_BM_SKIP_TAPEMARK(FILE_IDENTIFIER, DIRECTION, FAILURE_MODES,
{       STATUS)
{
{   FILE_IDENTIFIER (Input):  The file identifier for the file.
{
{  DIRECTION:  (Input) Direction of skipping.  Either amc$forward or
{        amc$backward.
{
{  FAILURE_MODES:  (Output) Detailed information on any tape I/O error.
{
{  STATUS: (Output) Request status.
*DECK DECK=BAH$TAPE_BM_TAPEMARK_CHECK EXPAND=FALSE
{   This procedure checks whether or not a tapemark is the next thing on the
{ tape, without actually reading the block via bap$tape_bm_read_next_block.
{ This allows determination of end of volume on unlabelled tapes.
{
{ NOTE:  If necessary, this procedure will read ahead on the tape.  This can
{       impact performance for extremely large blocks.  This procedure should
{       be called only when necessary, NOT after every
{       bap$tape_bm_read_next_block call.
{
{       BAP$TAPE_BM_TAPEMARK_CHECK(FILE_IDENTIFIER, TAPEMARK_NEXT, STATUS)
{
{   FILE_IDENTIFIER (Input):  The file identifier for the file.
{
{ TAPEMARK_NEXT: (output)  TRUE if the next block is a tapemark.  FALSE if it
{       is anything else, including a read error.
{
{ STATUS: (Output) Request status.
*DECK DECK=BAH$TAPE_BM_UNWRITTEN_BLK_COUNT EXPAND=FALSE
{   This procedure returns a count of tape blocks which have been passed to
{ tape block management (by calling bap$tape_bm_write_next_block) but have not
{ yet been written to the tape.
{
{       BAP$TAPE_BM_UNWRITTEN_BLK_COUNT (FILE_IDENTIFIER, COUNT, STATUS)
{
{  FILE_IDENTIFIER (Input):  The file identifier for the file.
{
{  COUNT (Output):  The number of unwritten tape blocks.
{
{  STATUS: (Output) Request status.
*DECK DECK=BAH$TAPE_BM_WRITE_LABEL EXPAND=FALSE
{   This procedure is called to write labels on a tape.
{
{   It allows writing of tape labels after the end of volume has been
{ encountered.  This procedure bypasses data buffered by block management
{ which occurs when forced_write is not being used on calls to
{ BAP$TAPE_BM_WRITE_NEXT_BLOCK and BAP$TAPE_BM_WRITE_TAPE_MARK.
{
{   No buffering is done for this label writing - the label is written to tape
{ before this procedure returns.  This allows the error information returned
{ by this procedure to refer to the label specifed on the call.
{
{   Tape I/O errors are indicated by both an abnormal status and a value in
{ the tape_failure_isolation.  (The status returned is
{ BAE$WRITE_ERROR_THIS_BLOCK.) IF media_recovery is TRUE, the tape will be
{ positioned just bfore the block which was just (improperly) written.  If
{ media recovery is FALSE, the tape will be positioned after the bad block.
{
{   If the I/O operation completed successfully with an End of Tape condition
{ present a BAE$VOL_END_OPERATION_COMPLETED condition will be returned.
{
{   BAP$TAPE_BM_WRITE_EOV_LABEL(FILE_IDENTIFIER, LABEL_PTR, LENGTH,
{ MEDIA_RECOVERY, FAILURE_MODES, STATUS)
{
{   FILE_IDENTIFIER (Input):  The file identifier for the file.
{
{  LABEL_PTR:  (Input) A pointer to the label to be written.
{
{  LENGTH:  (Input) The length of the label in bytes.
{
{  MEDIA_RECOVERY:  (Input) TRUE to have the system attempt recovery from
{        media errors encountered when writing this label to tape.  FALSE to
{        suppress any attempt by the system to recover from media errors.
{
{  FAILURE_MODES:  (Output) Detailed information on any tape I/O error.
{
{  STATUS: (output) Request status.
{
*DECK DECK=BAH$TAPE_BM_WRITE_LABEL_MARK EXPAND=FALSE
{   This procedure is called to write tapemarks which delimit label groups on
{ a tape.
{
{   It allows writing of tapemarks after the end of volume has been
{ encountered.  This procedure bypasses data buffered by block management
{ which occurs when forced_write is not being used on calls to
{ BAP$TAPE_BM_WRITE_NEXT_BLOCK and BAP$TAPE_BM_WRITE_TAPE_MARK.
{
{   No buffering is done for this tapemark writing - the tapemark is written
{ to tape before this procedure returns.  This allows the error information
{ returned by this procedure to refer to the tapemark currently being written.
{
{   Tape I/O errors are indicated by both an abnormal status and a value in
{ the tape_failure_isolation.  (The status returned is
{ BAE$WRITE_ERROR_THIS_BLOCK.) IF media_recovery is TRUE, the tape will be
{ positioned just bfore the tapemark which was just (improperly) written.  If
{ media recovery is FALSE, the tape will be positioned after the bad tapemark.
{
{   If the I/O operation completed successfully with an End of Tape condition
{ present a BAE$VOL_END_OPERATION_COMPLETED condition will be returned.
{
{   BAP$TAPE_BM_WRITE_LABEL_MARK(FILE_IDENTIFIER, MEDIA_RECOVERY,
{ FAILURE_ISOLATION, STATUS)
{
{   FILE_IDENTIFIER (Input):  The file identifier for the file.
{
{  MEDIA_RECOVERY:  (Input) TRUE to have the system attempt recovery from
{        media errors encountered when writing this label to tape.  FALSE to
{        suppress any attempt by the system to recover from media errors.
{
{  FAILURE_ISOLATION:  (Output) Detailed information on any tape I/O error.
{
{  STATUS: (output) Request status.
{
*DECK DECK=BAH$TAPE_BM_WRITE_NEXT_BLOCK EXPAND=FALSE
{   This procedure is called to write a block to a tape file.
{
{   The block passed may be contained in a buffer reserved by a call to
{ BAP$TAPE_BM_RESERVE_BLK_BUFFER, or it may be in some other buffer.
{
{   If the block is in a reserved buffer, that buffer must be the one reserved
{ by the most recent call to BAP$TAPE_BM_RESERVE_BLK_BUFFER.  If it is not the
{ most recent block reserved, an error status condition of
{ BAE$UNRESERVED_BUFFER_USED will be returned.
{
{   If the block is not in a reserved buffer the call implicitly releases all
{ reserved buffers.  A new block reservations must be acquired by calling
{ BAE$TAPE_BM_RESERVE_BLK_BUFFER.
{
{   Tape I/O errors are indicated by both an abnormal status and a value in
{ the tape_failure_isolation.  If an error is detected on a block other than
{ the one being WRITE_NEXTed a status condition of
{ BAE$WRITE_ERROR_PREVIOUS_BLOCK will be returned.  If the error is detected
{ on the block being written by this call the condition is
{ BAE$WRITE_ERROR_THIS_BLOCK.  If media_recovery is TRUE, the tape will be
{ positioned before after the block just (improperly) written.  If
{ media_recovery is FALSE, the tape will be positioned after the bad block.
{
{   Recovery from a write error depends upon when the error is detected.  If
{ the error occured on the block just written the caller may be able to take
{ action to avoid the error (such as a backspace and a call to
{ BAP$TAPE_BM_ERASE_BLOCK) and re-write the block.  It may also be reasonable
{ to retry the write with system_media_recovery.  If the error occured on some
{ previous block there is nothing that can be done to correct just the one
{ block.  If an error free tape is desired the tape must be rewound (or
{ skipped backwards to some place that the caller knows is before any error,
{ such as the location the tape was opened at) and begin again from there.
{
{   BAP$TAPE_BM_WRITE_NEXT_BLOCK(FILE_IDENTIFIER, BLOCK_PTR, LENGTH,
{ MEDIA_RECOVERY, FORCE_WRITE, FAILURE_MODES, STATUS)
{
{   FILE_IDENTIFIER (Input):  The file identifier for the file.
{
{  BLOCK_PTR:  (Input) A pointer to the block to be written.
{
{  LENGTH:  (Input) The length of the block in bytes.
{
{  MEDIA_RECOVERY:  (Input) TRUE to have the system attempt recovery from
{        media errors encountered when writing this block to tape.  FALSE to
{        suppress any attempt by the system to recover from media errors.
{
{  FORCE_WRITE:  (Input) TRUE forces the tape mark and any buffered blocks or
{        tape marks to be written to tape before the procedure returns.  FALSE
{        allows block management to buffer the write to allow greater
{        efficiency.
{
{  FAILURE_ISOLATION:  (Output) Detailed information on any tape I/O error.
{
{  STATUS: (output) Request status.
{
{
{
{
{
{
*DECK DECK=BAH$TAPE_BM_WRITE_TAPE_MARK EXPAND=FALSE
{   This procedure is called to write a tape mark on a tape file.
{
{   Tape I/O errors are indicated by both an abnormal status and a value in
{ the tape_failure_isolation.  If an error is detected on a previously written
{ block which was buffered, a status condition of
{ BAE$WRITE_ERROR_PREVIOUS_BLOCK will be returned.  If the error is detected
{ on the block being written by this call the condition is
{ BAE$WRITE_ERROR_THIS_BLOCK.  If media_recovery is TRUE, the tape will be
{ positioned just before the tapemark just (improperly) written.  IF
{ media_recovery is FALSE, the tape will be left positioned after the bad
{ tapemark.
{
{   Recovery from a write error depends upon when the error is detected.  If
{ the error occured on the block just written the caller may be able to take
{ action to avoid the error (such as a backspace and a call to
{ BAP$TAPE_BM_ERASE_BLOCK) and re-write the tapemark.  It may also be
{ reasonable to retry the write with system_media_recovery.  If the error
{ occured on some previous block there is very little that can be done to
{ correct just the one block.  If an error free tape is desired the tape must
{ be rewound (or repositioned to some place that the caller knows is before
{ any error, such as the location where the tape was opened) and begin again
{ from there.
{
{ NOTE:  Calling this procedure implicitly releases any tape block buffer
{       reservation.
{
{       BAP$TAPE_BM_WRITE_TAPE_MARK(FILE_IDENTIFIER, MEDIA_RECOVERY,
{       FORCED_WRITE, FAILURE_MODES, STATUS)
{
{   FILE_IDENTIFIER (Input):  The file identifier for the file.
{
{  MEDIA_RECOVERY:  (Input) TRUE to have the system attempt recovery from
{        media errors encountered when writing this tape mark.  FALSE to
{        suppress any attempt by the system to recover from media errors.
{
{  FORCE_WRITE:  (Input) TRUE forces the tape mark and any buffered blocks or
{        tape marks to be written to tape before the procedure returns.  FALSE
{        allows block management to buffer the write to allow greater
{        efficiency.
{
{  FAILURE_ISOLATION:  (Output) Detailed information on any tape I/O error.
{
{  STATUS: (output) Request status.
*DECK DECK=BAH$TAPE_FAP EXPAND=FALSE
{
{   The purpose  of  this procedure is to provide a file access procedure that
{ will intervene on all access method requests  to  a  tape  file.   This  fap
{ intervenes   on  all  amp$get_partial,  amp$get_next,  amp$put_partial,  and
{ amp$put_next requests to divide the working storage  length  into  a  length
{ that  can  be  more  easily  and  efficiently  handled.  No change in record
{ structure is visible.
{
{       BAP$TAPE_FAP (FILE_IDENTIFIER, CALL_BLOCK, LAYER_NUMBER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access identifier
{       established when the tape file was opened.
{
{ CALL_BLOCK:  (input, This parameter specifies the access method operation to
{       be performed.
{
{ LAYER_NUMBER: (input) This parameter  specifies  the  identity  of  the  fap
{       making the request.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: amc$access_method_id
{
*DECK DECK=BAH$TAPE_MANAGEMENT_FUNCTIONS EXPAND=FALSE
{}
{ COMMON DECK BAH$TAPE_MANAGEMENT_FUNCTIONS }
{}
{    These inline procedures are for use with tape_related faps.
{ These procedures perform generalized functions for tape.
{}
*DECK DECK=BAH$TASK_TERMINATION_CLEANUP EXPAND=FALSE
{
{   The purpose  of  this procedure is to close any files which remain open at
{ task termination.  Note that all files should have previously been closed by
{ the  bap$loaded_ring_cleanup procedure, therefore this procedure should find
{ files open only in the event of some abnormal situation.
{
{       BAP$TASK_TERMINATION_CLEANUP
{
*DECK DECK=BAH$TERMINATE_FILE EXPAND=FALSE

{ COMMON DECK BAHTERF }

{   The purpose of the inline request is to ensure that the last record
{ in a byte addressable or sequential file is complete.  This means that
{ the file position is end of record, that the record is padded to the
{ minimum block length, and that any record headers are left in a con-
{ sistant state.
{   This request should only be called from ring 3, and should only be
{ required in the case where a user fap did not allow the file to be
{ terminated at ring 11.
{   None of the parameters are validated.
{
{       BAP$TERMINATE_FILE (FILE_IDENTIFIER, FILE_INSTANCE)
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the file access
{       identifier established when the file was opened.
{
{ FILE_INSTANCE: (input)  This parameter specifies the task file table
{       entry associated with the file.
{
*DECK DECK=BAH$UPDATE_OPENED_SUBJECT_FILE EXPAND=FALSE

{
{   This request is called by the connected file device file access  procedure
{ (fap)  to  update  the  subject file instance's fields that describe the
{ state of the subject's connections.  Specifically, this resets the
{ pointer to the current tree of file connections and sets the subject file instance's
{ connection level to the value of the corresponding subject entry in the
{ current connected_files tree.
{
{       BAP$UPDATE_OPENED_SUBJECT_FILE (SUBJECT_FILE_IDENTIFIER)
{
{ SUBJECT_FILE_IDENTIFIER: (input) This parameter specifies the  subject  file
{       instance of open.
{
*DECK DECK=BAH$US_BLK_FIXED_REC_FAP EXPAND=FALSE
{}
{ COMMON DECK BAH$US_BLK_FIXED_REC_FAP }
{}
{   The purpose of this procedure is to perform record access functions via
{ the file access procedure mechanism.  This file access procedure is
{ associated with a file at open time if the file is a user specified
{ blocked, record access level, fixed record type file and is assigned
{ to a mass storage device.
{}
{     BAP$US_BLK_FIXED_REC_FAP (FILE_IDENTIFIER, CALL_BLOCK,
{         LAYER_NUMBER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file identifier
{   ordinal for an instance of open of a file.
{
{ CALL_BLOCK: (input, output) This parameter specifies the operation to be
{   performed.  This parameter returns file position, transfer count, and
{   byte address via pointer reference.
{
{ LAYER_NUMBER: (input) This parameter specifies the layer number of this
{   file access procedure.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=BAH$US_BLK_FIXED_REC_TAPE_FAP EXPAND=FALSE
{}
{ COMMON DECK BAH$US_BLK_FIXED_REC_TAPE_FAP }
{}
{   The purpose of this procedure is to perform record access functions via
{ the file access procedure mechanism.  This file access procedure is
{ associated with a file at open time if the file is a user specified
{ blocked, record access level, fixed record type file and is assigned
{ to a tape device.
{}
{     BAP$US_BLK_FIXED_REC_TAPE_FAP (FILE_IDENTIFIER, CALL_BLOCK,
{         LAYER_NUMBER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file identifier
{   ordinal for an instance of open of a file.
{
{ CALL_BLOCK: (input, output) This parameter specifies the operation to be
{   performed.  This parameter returns file position, transfer count, and
{   byte address via pointer reference.
{
{ LAYER_NUMBER: (input) This parameter specifies the layer number of this
{   file access procedure.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=BAH$US_BLK_UNDEFINED_REC_FAP EXPAND=FALSE
{}
{ COMMON DECK BAH$US_BLK_UNDEFINED_REC_FAP }
{}
{   The purpose of this procedure is to perform record access functions via
{ the file access procedure mechanism.  This file access procedure is
{ associated with a file at open time if the file is a user specified
{ blocked, record access level, undefined record type file and is assigned
{ to a mass storage device.
{}
{     BAP$US_BLK_UNDEFINED_REC_FAP (FILE_IDENTIFIER, CALL_BLOCK,
{         LAYER_NUMBER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file identifier
{   ordinal for an instance of open of a file.
{
{ CALL_BLOCK: (input, output) This parameter specifies the operation to be
{   performed.  This parameter returns file position, transfer count, and
{   byte address via pointer reference.
{
{ LAYER_NUMBER: (input) This parameter specifies the layer number of this
{   file access procedure.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=BAH$US_BLK_UNDEF_REC_TAPE_FAP EXPAND=FALSE
{}
{ COMMON DECK BAH$US_BLK_UNDEF_REC_TAPE_FAP }
{}
{   The purpose of this procedure is to perform record access functions via
{ the file access procedure mechanism.  This file access procedure is
{ associated with a file at open time if the file is a user specified
{ blocked, record access level, undefined record type file and is assigned
{ to a tape device.  All access to this file will then go
{ through this file access procedure.
{}
{     BAP$US_BLK_UNDEF_REC_TAPE_FAP (FILE_IDENTIFIER, CALL_BLOCK,
{         LAYER_NUMBER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file identifier
{   ordinal for an instance of open of a file.
{
{ CALL_BLOCK: (input, output) This parameter specifies the operation to be
{   performed.  This parameter returns file position, transfer count, and
{   byte address via pointer reference.
{
{ LAYER_NUMBER: (input) This parameter specifies the layer number of this
{   file access procedure.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=BAH$US_BLK_VARIABLE_REC_FAP EXPAND=FALSE
{}
{ COMMON DECK BAH$US_BLK_VARIABLE_REC_FAP }
{}
{   The purpose of this procedure is to perform record access functions via
{ the file access procedure mechanism.  This file access procedure is
{ associated with a file at open time if the file is a user specified
{ blocked, record access level, variable record type file and is assigned
{ to a mass storage device.
{}
{     BAP$US_BLK_VARIABLE_REC_FAP (FILE_IDENTIFIER, CALL_BLOCK,
{         LAYER_NUMBER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file identifier
{   ordinal for an instance of open of a file.
{
{ CALL_BLOCK: (input, output) This parameter specifies the operation to be
{   performed.  This parameter returns file position, transfer count, and
{   byte address via pointer reference.
{
{ LAYER_NUMBER: (input) This parameter specifies the layer number of this
{   file access procedure.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=BAH$US_BLK_VAR_REC_TAPE_FAP EXPAND=FALSE
{}
{ COMMON DECK BAH$US_BLK_VAR_REC_TAPE_FAP }
{}
{   The purpose of this procedure is to perform record access functions via
{ the file access procedure mechanism.  This file access procedure is
{ associated with a file at open time if the file is a user specified
{ blocked, record access level, variable record type file and is assigned
{ to a tape device.
{}
{     BAP$US_BLK_VAR_REC_TAPE_FAP (FILE_IDENTIFIER, CALL_BLOCK,
{         LAYER_NUMBER, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file identifier
{   ordinal for an instance of open of a file.
{
{ CALL_BLOCK: (input, output) This parameter specifies the operation to be
{   performed.  This parameter returns file position, transfer count, and
{   byte address via pointer reference.
{
{ LAYER_NUMBER: (input) This parameter specifies the layer number of this
{   file access procedure.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=BAH$VARIABLE_BLOCK_PROCEDURES EXPAND=FALSE
{}
{ COMMON DECK BAH$VARIABLE_BLOCK_PROCEDURES }
{}
{     These inline procedures are for use with variable record type, blocked faps.
{ These procedures perform generalized functions for blocking on variable records.
{}
*DECK DECK=BAH$VARIABLE_RECORD_PROCEDURES EXPAND=FALSE
{}
{ COMMON DECK BAH$VARIABLE_RECORD_PROCEDURES}
{}
{      These inline procedures are for use with variable record faps.
{ These procedures perform generalized functions for variable records.
{}
*DECK DECK=BAH$WORK_STATION_DEVICE EXPAND=FALSE
{
{   The purpose of this procedure is to make a work station file behave  as  a
{ local  mass storage file. When a work station file is used as an input file,
{ this procedure first copies the file from the work station to a  local  mass
{ storage  file,  and then diverts amp$get requests to that local file. When a
{ work station file is used as an output file, this procedure creates a  local
{ mass storage file and diverts amp$put requests to that local file. Then when
{ that output file is closed, this procedure copies that local file out to the
{ work station.
{
{   The command language recognizes (by analyzing the path name) when  a  file
{ reference  refers  to a work station file. For such files, a device class is
{ established such that the code in this procedure is  executed  whenever  the
{ file is referenced via calls to amp$ bam procedures.
{
{
{       BAP$WORK_STATION_DEVICE (FILE_IDENTIFIER, CALL_BLOCK, LAYER_NUMBER,
{         STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access identifier
{       established when the file was opened.
{
{ CALL_BLOCK:  (input)  This parameter specifies the call block that describes
{       the request to be performed.
{
{ LAYER_NUMBER: (input) This  parameter  specifies  the  index  into  the  fap
{       control information for this layer.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=BAH$WRITE_END_PARTITION EXPAND=FALSE
{   The purpose of this request is to write an end of partition (EOP)
{ delimiter on a file opened with amc$variable record_type.
{
{       BAP$WRITE_END_PARTITION (FILE_IDENTIFIER, CALL_BLOCK,
{        FAP_LAYER_NUMBER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{      identifier established when the file was opened.
{
{ CALL_BLOCK: (input) This paramter specifies the call block
{        used by this request.
{
{ FAP_LAYER_NUMBER: (input) This parameter specifies the index into the
{        fap_control_information for this layer.
{
{ STATUS: (output) This parameter specifies the request status. THis is
{        the application's status variable.
{
*DECK DECK=BAHLLEB EXPAND=FALSE


{ PURPOSE:
{         The purpose of this procedure is to return a flag which
{   tells whether a file is entered in the local_name_table.  THe
{   flag is returned TRUE if the entry is in the  lnt,  otherwise
{   it is returned FALSE.

*DECK DECK=BAHRNME EXPAND=FALSE
{
{  The purpose of this request is to change the local file
{ name of a file . This request does not change the permanent
{ name of the file.
{
{
{        BAP$RENAME (OLD_FILE_NAME, NEW_FILE_NAME, VALIDATION_RING, STATUS)
{
{ OLD_FILE_NAME: (input) this parameter specifies the
{        name of a local file currently known to the system.
{
{ NEW_FILE_NAME: (input) this parameter specifies the
{        name by which the file will now be known.
{
{ VALIDATION_RING: (input) This parameter specifies the ring number of
{        the procedure issuing the rename request.
{
{ STATUS: (output) this parameter specifies the request status.
{
*DECK DECK=BAHSKP EXPAND=FALSE
{
{ COMMON DECK BAHSKP }
{}
{   The purpose of this request is to reposition a file which was created}
{ sequentially and opened for amc$record access.}
{   This request does not cause data movement to or from a user}
{ working_storage_area.}
{   For a file associated with tape, the file and volume are terminated}
{ according to convention, if the preceding operation was an output to the}
{ tape. If the label_type is amc$labelled(*), the standard ANSI EOF label}
{ and two tapemarks are written; then the tape volume is positioned by the}
{ access method prior to the EOF label. For an amc$unlabelled file, two}
{ tapemarks are written to terminate the file and volume; then the volume}
{ is positioned by the access method prior to the two tapemarks.}
{   The following table indicates which positioning options are available}
{ for a file opened with amc$record access_level: }
{}
{  |--------------------------------------------------------------------|  }
{  |          Block_type ->   |  System_specified  ||  User_specified   |  }
{  |                          |____________________||___________________|  }
{  |          Record_type ->  | V | F | U | S | D  || V | F | U | S | D |  }
{  |                          |   |   |   |(*)|(*) ||   |   |   |(*)|(*)|  }
{  |--------------------------------------------------------------------|  }
{  |  Forward  N records      | x | x | 2 | 1 | 1  || x | x | x | x | x |  }
{  |  Backward N records      | x | x | 2 | 1 | 1  || x | x | x | 2 | 2 |  }
{  |  Forward  N partitions   | x | 2 | 2 | 1 | 1  || x | 2 | 2 | 2 | 2 |  }
{  |  Backward N partitions   | x | 2 | 2 | 1 | 1  || x | 2 | 2 | 2 | 2 |  }
{  |--------------------------------------------------------------------|  }
{}
{   Notes on preceding table: }
{     1. This combination of record_type and block_type is not supported.}
{     2. This is an undefined operation and abnormal status will be returned.}
{}
{   The final position of the file, assuming no boundary condition was}
{ encountered before the COUNT was exhausted, is as follows:}
{}
{   Skip of UNIT = record:
{}
{     . If the file is positioned before RECORD N and}
{       a forward skip of M RECORDs is performed, the final position will}
{       be at the end of RECORD N+M-1.}
{     . If the file is positioned within or at the end of RECORD N and}
{       a forward skip of M RECORDs is performed, the final position will}
{       be at the end of RECORD N+M.}
{     . If the file is positioned before RECORD N and}
{       a backward skip of M RECORDs is performed, the final position}
{       will be at the end of RECORD N-M-1.}
{     . If the file is positioned within or at the end of RECORD N and}
{       a backward skip of M RECORDs is performed, the final position}
{       will be at the end of RECORD N-M-1.}
{}
{   Skip of UNIT = partition:
{}
{     . If the file is positioned somewhere within PARTITION N and}
{       a forward skip of M PARTITIONs is performed, the final position will}
{       be at the beginning of PARTITION N+M. A count of zero (M=0) is}
{       treated the same as if a count of one had been given (M=1).}
{     . If the file is positioned somewhere within PARTITION N and}
{       a backward skip of M PARTITIONs is performed, the final position}
{       will be at the beginning of PARTITION N-M.}
{     . If N amp$write_end_partition requests have been performed on a}
{       sequential file and the file is positioned after the Nth partition}
{       delimiter, then by definition the file is positioned within}
{       partition N+1. Therefore from this position (EOI), a backward skip}
{       of one partition would position the file at the beginning of}
{       partition N.}
{}
{   If a boundary condition is detected before the skip COUNT is
{ exhausted, then control will return to the caller with an abnormal}
{ STATUS. The actual number of UNITs skipped in this case may be}
{ determined by subtracting the residual_skip_count available via the}
{ amp$fetch_access_information request from the original skip COUNT.}
{ When a skip forward by records encounters a partition boundary condition,}
{ the final position is beyond the boundary, i.e. at the beginning of}
{ the next partition.}
{ When a skip backward by records encounters a partition boundary condition,}
{ the final position is prior to the boundary, i.e. at the end of the}
{ preceding partition.}
{}
{}
{ Boundary conditions: }
{}
{ .   Skip forward by records encounters partition/EOI.
{}
{ .   Skip forward by partitions encounters EOI.
{}
{ .   Skip backward by records encounters partition/BOI.
{}
{ .   Skip backward by partitions encounters BOI.
{}
{
{     BAP$SKIP (FILE_IDENTIFIER, CALL_BLOCK, LAYER_NUMBER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ CALL_BLOCK: (input, output) This parameter is a record specifying
{       values controlling the type of skip and returning a resultant
{       file position.
{
{     OPERATION: (input) This field identifies a call to this request
{           as a skip request.
{
{
{     DIRECTION: (input) This field specifies the direction of the
{           positioning operation.  Options include:
{             Forward
{             Backward
{
{     UNIT: (input) This field specifies the type of unit to be
{           skipped.  Options include:
{             Record
{             Partition
{
{     COUNT: (input) This field specifies the number of units to skip.}
{
{     FILE_POSITION: (output) This field specifies the position of the}
{           file following the request.}
{           Possible file positions resulting from a forward skip are: }
{             . amc$eor - skipping records only}
{             . amc$bop - skipping records/partitions only}
{             . amc$eoi - any UNIT}
{           Possible file positions resulting from a backward skip are: }
{             . amc$eor - skipping records only}
{             . amc$bop - skipping partitions only}
{             . amc$eop - skipping records only}
{             . amc$boi - any UNIT}
{
{ LAYER_NUMBER: (input) This parameter specifies the index into the
{   fap control information for this layer.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$conflicting_access_level,
{                   ame$conflicting_fo,
{                   ame$improper_file_id,
{                   ame$improper_input_attempt,
{                   ame$improper_skip_unit,
{                   ame$improper_skip_direction,
{                   ame$improper_skip_count,
{                   ame$skip_requires_read_perm,
{                   ame$unsupported_skip,
{                   ame$skip_encountered_boi,
{                   ame$skip_encountered_bop,
{                   ame$skip_encountered_eop,
{                   ame$skip_encountered_eoi,
{                   ame$unrecovered_write_error,
{                   ame$uncertain_tape_position.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=BAI$ADVANCE_VOLUME EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bap$tape_bm_advance_volume
*copyc bap$tape_bm_unwritten_blk_count
*copyc bai$label_type
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
*copyc dme$tape_errors
?? POP ??

{
{ The purpose of this request is to issue a tape_bm_advance_volume request.
{ The two possible results of this request are:
{   1) The volume was advanced and the volume position = amc$bov.
{   2) There are no more volumes in the volume list and the volume_position
{      = amc$eov, and an abnormal status is returned.
{

  PROCEDURE bai$advance_volume
    (    file_identifier: amt$file_identifier;
     VAR volume_position: amt$volume_position;
     VAR status: ost$status);

    PROCEDURE bai$advance_vol_blk_xt_hndlr
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_stack: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

{
{ The purpose of this condition handler is to handle all block
{ exit occurances that may occur while trying to advance to
{ another volume.  The assumptions is that appropriate actions
{ for the various conditions occur elsewhere.  If a block exit
{ is attempted at this level, the necessary action is to close
{ the file and get out.
{

      VAR
        ignore_status: ost$status;

      condition_status.normal := TRUE;
      sl_tape_abnormal_termination (file_identifier);
      bap$close (file_identifier, ignore_status);

    PROCEND bai$advance_vol_blk_xt_hndlr;

    VAR
      blocks_currently_buffered: bat$tape_block_buffer_count,
      error_action: bat$error_actions,
      tape_failure_modes: amt$tape_failure_modes,
      request_status: ost$status;

    bap$tape_bm_unwritten_blk_count (file_identifier,
          blocks_currently_buffered, request_status);
    tape_failure_modes := $amt$tape_failure_modes [];
    bai$process_request_status (file_identifier, amc$max_operation,
          request_status, tape_failure_modes, error_action, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^bai$advance_vol_blk_xt_hndlr);

      /main_program/ BEGIN
      bap$tape_bm_advance_volume (file_identifier, tape_failure_modes, request_status);
      bai$process_request_status (file_identifier, operation,
            request_status, tape_failure_modes, error_action, status);
      IF NOT status.normal THEN
        volume_position := amc$eov;
        EXIT /main_program/;
      ELSEIF NOT request_status.normal AND (request_status.condition = dme$volume_list_exhausted) THEN
        volume_position := amc$eov;
        EXIT /main_program/;
      ELSE
        volume_position := amc$bov;
        tape_descriptor^.volume_number := tape_descriptor^.volume_number + 1;
        tape_descriptor^.initial_volume.initial_read_labels_attempt := TRUE;
        block_info^.block_number := max
              (blocks_currently_buffered, LOWERVALUE (block_info^.
              block_number));
      IFEND;
    END /main_program/;
    osp$disestablish_cond_handler;

    IF NOT status.normal AND (status.condition <> ame$tape_end_of_volume_list) THEN
      sl_tape_abnormal_termination (file_identifier);
    IFEND;

  PROCEND bai$advance_volume;


  FUNCTION [INLINE] max
    (    n1: integer;
         n2: integer): integer;

    IF n1 < n2 THEN
      max := n2;
    ELSE
      max := n1;
    IFEND;

  FUNCEND max;
*DECK DECK=BAI$AMT_VOLUME_POSITION EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bat$tape_volume_position
*copyc amt$volume_position
?? POP ??

{
{ The purpose of this request is to convert a ordinal of type
{ bat$tape_volume_position to a similar ordinal of type
{ amt$volume_position.
{

  FUNCTION [INLINE] bai$amt_volume_position (volume_position:
    bat$tape_volume_position): amt$volume_position;

    CASE volume_position OF

    = bac$after_data_block =
      bai$amt_volume_position := amc$after_data_block;
    = bac$after_tapemark =
      bai$amt_volume_position := amc$after_tapemark;
    = bac$bov =
      bai$amt_volume_position := amc$bov;
    = bac$eov =
      bai$amt_volume_position := amc$eov;
    ELSE
      bai$amt_volume_position := amc$position_uncertain;
    CASEND;

  FUNCEND bai$amt_volume_position;
*DECK DECK=BAI$APPEND_TAPE_ERROR EXPAND=FALSE
?? RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$tape_failure_isolation
*copyc bat$tape_descriptor
*copyc osp$append_status_parameter
?? POP ??

  PROCEDURE {[INLINE]} bai$append_tape_error (file_identifier: amt$file_identifier;
        tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    VAR
      delimiter: char,
      found_error: boolean,
      error_text: string (255),
      error_index: integer,
      tape_error: amt$tape_failure_mode;

    found_error := FALSE;

    IF status.normal THEN
      RETURN;
    IFEND;

    error_text := '';
    error_index := 1;
    delimiter := '[';

    FOR tape_error := LOWERVALUE (amt$tape_failure_mode) TO UPPERVALUE (amt$tape_failure_mode) DO
      IF tape_error IN tape_failure_modes THEN
        found_error := TRUE;
        CASE tape_error OF
        = amc$tfm_agc_gains_not_set =
          append_text (delimiter, ' agc_gains_not_set', error_text, error_index);
        = amc$tfm_bad_id_burst =
          append_text (delimiter, ' bad_id_burst', error_text, error_index);
        = amc$tfm_blank_tape_read =
          append_text (delimiter, ' blank_tape_read', error_text, error_index);
        = amc$tfm_data_parity_error =
          append_text (delimiter, ' data_parity_error', error_text, error_index);
        = amc$tfm_device_not_ready =
          append_text (delimiter, ' device_not_ready', error_text, error_index);
        = amc$tfm_erase_error =
          append_text (delimiter, ' erase_error', error_text, error_index);
        = amc$tfm_record_fragment =
          append_text (delimiter, ' record_fragment', error_text, error_index);
        = amc$tfm_hardware_failure =
          append_text (delimiter, ' hardware_failure', error_text, error_index);
        ELSE
          append_text (delimiter, ' unknown failure mode', error_text, error_index);
        CASEND;
        delimiter := ',';
      IFEND;
    FOREND;
    IF found_error THEN
      append_text (' ', ']', error_text, error_index);
      osp$append_status_parameter (' ', error_text, status);
    IFEND;

  PROCEND bai$append_tape_error;


  PROCEDURE [INLINE] append_text (delimiter: char;
        text: string ( * );
    VAR error_text: string ( * );
    VAR error_index: integer);

    error_text (error_index) := delimiter;
    error_index := error_index + 1;
    error_text (error_index, * ) := text;
    error_index := error_index + STRLENGTH (text);

  PROCEND append_text;
*DECK DECK=BAI$BAT_VOLUME_POSITION EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bat$tape_volume_position
*copyc amt$volume_position
?? POP ??

{
{ The purpose of this request is to convert a ordinal of type
{ amt$volume_position to a similar ordinal of type
{ bat$tape_volume_position.
{

  FUNCTION [INLINE] bai$bat_volume_position (volume_position:
    amt$volume_position): bat$tape_volume_position;

    CASE volume_position OF

    = amc$after_data_block =
      bai$bat_volume_position := bac$after_data_block;
    = amc$after_tapemark =
      bai$bat_volume_position := bac$after_tapemark;
    = amc$bov =
      bai$bat_volume_position := bac$bov;
    = amc$eov =
      bai$bat_volume_position := bac$eov;
    ELSE
      bai$bat_volume_position := bac$position_uncertain;
    CASEND;

  FUNCEND bai$bat_volume_position;
*DECK DECK=BAI$BLK_OPEN_POSITIONING EXPAND=FALSE
    { initialize positioning information }
    CASE file_instance^.instance_attributes.dynamic_label.open_position OF
    = amc$open_at_boi =
        file_byte_address := 0;
        { initialize file_transfer_descriptor }
        file_instance^.file_transfer_descriptor.bor_address := 0;
        file_instance^.file_transfer_descriptor.current_byte_address := 0;
        file_instance^.file_transfer_descriptor.eoi_byte_address :=
              file_instance^.global_file_information^.eoi_byte_address;
        file_instance^.file_transfer_descriptor.file_position := amc$boi;
        file_instance^.file_transfer_descriptor.record_header_fba := 0;

        { initialize file_transfer_descriptor.file_information }
        file_instance^.file_transfer_descriptor.file_info.current_record_byte_address := 0;
        file_instance^.file_transfer_descriptor.file_info.rch_file_byte_address := 0;
        file_instance^.file_transfer_descriptor.file_info.rch_previous_length := 0;
        file_instance^.file_transfer_descriptor.file_info.record_length := 0;
        file_instance^.file_transfer_descriptor.file_info.residual_record_length := 0;
        file_instance^.file_transfer_descriptor.file_info.residual_skip_count := 0;
        file_instance^.file_transfer_descriptor.file_info.requested_record_length := 0;
        file_instance^.file_transfer_descriptor.file_info.transfer_count := 0;

        { initialize file_transfer_descriptor.block_descriptor }
        file_instance^.file_transfer_descriptor.block_descriptor^.block_number := 1;
        file_instance^.file_transfer_descriptor.block_descriptor^.block_position := bac$beginning_of_block;
        file_instance^.file_transfer_descriptor.block_descriptor^.current_block_byte_address := 0;
        file_instance^.file_transfer_descriptor.block_descriptor^.previous_block_header_fba := 0;
        file_instance^.file_transfer_descriptor.block_descriptor^.residual_block_length := 0;
        file_instance^.file_transfer_descriptor.block_descriptor^.
              current_block_length := 0;
        osp$fetch_locked_variable (file_instance^.global_file_information^.open_count, x);
        { x = open_count }
        IF x = 1 THEN
        file_instance^.global_file_information^.record_length := 0;
        file_instance^.global_file_information^.residual_record_length := 0;
        file_instance^.global_file_information^.transfer_count := 0;
        file_instance^.global_file_information^.bor_address := 0;
        file_instance^.global_file_information^.block_number := 1;
        file_instance^.global_file_information^.record_header_fba := 0;
        file_instance^.global_file_information^.file_position := amc$boi;
        file_instance^.global_file_information^.block_position := bac$beginning_of_block;
        file_instance^.global_file_information^.block_header_fba := 0;
        file_instance^.global_file_information^.current_byte_address := 0;
        file_instance^.global_file_information^.file_position := amc$boi;
        file_instance^.global_file_information^.previous_block_header_fba := 0;
        file_instance^.global_file_information^.record_header_fba := 0;
        file_instance^.global_file_information^.residual_block_length := 0;

      IFEND;
    = amc$open_no_positioning, amc$open_at_bop =
        file_byte_address := file_instance^.global_file_information^.current_byte_address;
        { initialize file_transfer_descriptor }
        bai$update_ftd_from_gfi;

        { initialize file_transfer_descriptor.block_descriptor }
        bai$update_ftd_blk_from_gfi;

    = amc$open_at_eoi =
        file_byte_address := file_instance^.global_file_information^.eoi_byte_address;
        { initialize file_transfer_descriptor }
        file_instance^.file_transfer_descriptor.bor_address := 0;
          { bor_address should be recalculated if necessary in each fap }
        file_instance^.file_transfer_descriptor.current_byte_address := file_byte_address;
        file_instance^.file_transfer_descriptor.eoi_byte_address := file_byte_address;
        file_instance^.file_transfer_descriptor.file_position := amc$eoi;
        file_instance^.file_transfer_descriptor.record_header_fba := 0;
          { record_header_fba should be recalculated in variable record faps }

        { initialize file_transfer_descriptor.file_information }
        file_instance^.file_transfer_descriptor.file_info.current_record_byte_address := 0;
          { crba should be recalculated in each fap }
        file_instance^.file_transfer_descriptor.file_info.rch_file_byte_address := 0;
        file_instance^.file_transfer_descriptor.file_info.rch_previous_length := 0;
        file_instance^.file_transfer_descriptor.file_info.record_length := 0;
        file_instance^.file_transfer_descriptor.file_info.residual_record_length := 0;
        file_instance^.file_transfer_descriptor.file_info.residual_skip_count := 0;
        file_instance^.file_transfer_descriptor.file_info.requested_record_length := 0;
        file_instance^.file_transfer_descriptor.file_info.transfer_count := 0;

        { initialize file_transfer_descriptor.block_descriptor }
        bai$update_ftd_blk_from_fba;
        bai$update_gfi_from_ftd;
        bai$update_gfi_blk_from_ftd;
          { each fap must set current_block_length after validating block_header }
    CASEND;

*DECK DECK=BAI$BLOCK_INFO EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bat$task_file_table
?? POP ??

{
{ The purpose of this request is to return a pointer to the
{ file block info for the current instance of open
{ of the file.
{

  FUNCTION [INLINE] bai$block_info (file_instance: ^bat$task_file_entry):
    ^bat$block_info;

    bai$block_info := ^file_instance^.global_file_information^.positioning_info.
          block_info;

  FUNCEND bai$block_info;
*DECK DECK=BAI$BLOCK_REWIND EXPAND=FALSE
{
{ BAI$BLOCK_REWIND

*copy bai$get_positioning_info

    record_info := bav$default_record_info;
    block_info := bav$default_block_info;

*copyc bai$save_positioning_info

{ end of BAI$BLOCK_REWIND
{
*DECK DECK=BAI$CALL_FAP_CONTROL EXPAND=FALSE
  file_instance^.fap_control_information.first_fap.access_method^
        (file_identifier, call_block, fap_layer_number, bam_status);
*DECK DECK=BAI$CHECK_ACCESS_MODE EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bai$gfi
*copyc bai$static_label
*copyc amp$set_file_instance_abnormal
*copyc bat$task_file_table
*copyc ost$status
*copyc pfd$permanent_file_attributes
*copyc ame$access_validation_errors
?? POP ??

  PROCEDURE [INLINE] bai$check_access_mode (file_identifier:
    amt$file_identifier;
        static_label: ^bat$instance_static_attributes;
        access_mode: pft$usage_selections;
        operation: amt$fap_operation;
    VAR status: ost$status);

    CASE operation OF

*copy bac$read_requests

      IF operation <> amc$skip_req THEN
        IF NOT (pfc$read IN access_mode) THEN
          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_access_attempt, operation, ' READ', status);
        IFEND;
      IFEND;

*copy bac$write_requests

      IF operation <> amc$replace_req THEN
        IF (gfi^.positioning_info.record_info.current_byte_address < gfi^.eoi_byte_address) THEN
          IF NOT (pfc$shorten IN access_mode) THEN
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_access_attempt, operation, ' SHORTEN', status);
          ELSE
{           update_segment_length := TRUE;
          IFEND;
        ELSE
          IF NOT (pfc$append IN access_mode) THEN
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_access_attempt, operation, ' APPEND', status);
          IFEND;
        IFEND;
      ELSE { replace_previous_record }
        IF NOT (pfc$modify IN access_mode) THEN
          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_access_attempt, operation, ' MODIFY', status);
        IFEND;
      IFEND;

    ELSE
    CASEND;

  PROCEND bai$check_access_mode;
*DECK DECK=BAI$CHECK_CALLER_ID EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc amp$set_file_instance_abnormal
*copyc amt$ring_attributes
*copyc ame$fap_validation_errors
*copyc ame$ring_validation_errors
*copyc ost$caller_identifier
?? POP ??

{
{ The purpose of this request is to validate the callers ring attributes
{ against the proposed operation.
{

  PROCEDURE [INLINE] bai$check_caller_id (file_identifier: amt$file_identifier;
        ring_attributes: amt$ring_attributes;
        operation: amt$fap_operation;
        caller_id: ost$caller_identifier;
    VAR status: ost$status);

    status.normal := TRUE;
    CASE operation OF

*copy bac$read_requests

      IF caller_id.ring > ring_attributes.r2 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, operation, ' ', status);
      IFEND;

*copy bac$write_requests

      IF caller_id.ring > ring_attributes.r1 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, operation, ' ', status);
      IFEND;

*copy bac$other_requests

{
{ For these requests, validation is the same as for read requests.
{

      IF caller_id.ring > ring_attributes.r2 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, operation, ' ', status);
      IFEND;

    ELSE
      amp$set_file_instance_abnormal (file_identifier,
            ame$improper_fap_operation, operation, 'Unknown operation.', status);
    CASEND;

  PROCEND bai$check_caller_id;
*DECK DECK=BAI$CHECK_RECORD_LEVEL_ACCESS EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc amp$set_file_instance_abnormal
*copyc ame$conflicting_access_level
*copyc amt$access_level
?? POP ??

{
{ The purpose of this request is to check that the current access level
{ is of type amc$record.  Any other type is an error.
{

  PROCEDURE [INLINE] bai$check_record_level_access (file_identifier:
    amt$file_identifier;
        access_level: amt$access_level;
        operation: amt$fap_operation;
    VAR status: ost$status);

    CASE access_level OF
    = amc$record =
      status.normal := TRUE;
    = amc$segment =
      amp$set_file_instance_abnormal (file_identifier,
            ame$conflicting_access_level, operation, 'SEGMENT ACCESS', status);
    = amc$physical =
      amp$set_file_instance_abnormal (file_identifier,
            ame$conflicting_access_level, operation, 'PHYSICAL ACCESS',
            status);
    ELSE
    CASEND;

  PROCEND bai$check_record_level_access;
*DECK DECK=BAI$CHECK_TAPEMARK EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bap$tape_bm_tapemark_check
*copyc bap$tape_bm_advance_volume
?? POP ??

{
{ The purpose of this procedure is to determine whether the volume position is
{ currently at either an embedded tapemark, or at the end of the current
{ volume. Any other volume position will be regarded as an error.
{ This request will only return valid results if issued when positioned
{ at a tapemark.
{

  PROCEDURE [INLINE] bai$check_tapemark (file_identifier: amt$file_identifier;
    VAR volume_position: amt$volume_position;
    VAR status: ost$status);

    VAR
      next_block_is_a_tapemark: boolean;

{
{ Check for double tapemark, which indicates the end of volume.
{

    bap$tape_bm_tapemark_check (file_identifier, next_block_is_a_tapemark, status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF next_block_is_a_tapemark THEN

{
{ For unlabelled tape, this implies end of volume.
{

        volume_position := amc$eov;
    ELSE
      volume_position := amc$after_tapemark;
    IFEND;

  PROCEND bai$check_tapemark;
*DECK DECK=BAI$CHECK_TAPE_ERROR EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$tape_failure_isolation
*copyc bat$tape_descriptor
*copyc osp$append_status_parameter
?? POP ??

  PROCEDURE [INLINE] bai$check_tape_error (file_identifier:
    amt$file_identifier;
        file_instance: ^bat$task_file_entry;
        tape_failure_modes: amt$tape_failure_modes;
    VAR found_error: boolean;
    VAR status: ost$status);

    VAR
      delimiter: char,
      error_text: string (255),
      error_index: integer,
      tape_descriptor: ^bat$tape_descriptor,
      tape_error: amt$tape_failure_mode;

    found_error := FALSE;
    tape_descriptor := bai$tape_descriptor (file_instance);
    tape_descriptor^.failure_isolation.failure_modes := tape_failure_modes;

    IF status.normal THEN
      RETURN;
    IFEND;

    error_text := '';
    error_index := 1;
    delimiter := '[';

    FOR tape_error := LOWERVALUE (amt$tape_failure_mode) TO UPPERVALUE
          (amt$tape_failure_mode) DO
      IF tape_error IN tape_failure_modes THEN
        found_error := TRUE;
        CASE tape_error OF
        = amc$tfm_agc_gains_not_set =
          append_text (delimiter, ' agc_gains_not_set', error_text, error_index);
        = amc$tfm_bad_id_burst =
          append_text (delimiter, ' bad_id_burst', error_text, error_index);
        = amc$tfm_blank_tape_read =
          append_text (delimiter, ' blank_tape_read', error_text, error_index);
        = amc$tfm_data_parity_error =
          append_text (delimiter, ' data_parity_error', error_text, error_index);
        = amc$tfm_device_not_ready =
          append_text (delimiter, ' device_not_ready', error_text, error_index);
        = amc$tfm_erase_error =
          append_text (delimiter, ' erase_error', error_text, error_index);
        = amc$tfm_record_fragment =
          append_text (delimiter, ' record_fragment', error_text, error_index);
        = amc$tfm_hardware_failure =
          append_text (delimiter, ' hardware_failure', error_text, error_index);
        ELSE
          append_text (delimiter, ' unknown failure mode', error_text, error_index);
        CASEND;
        delimiter := ',';
      IFEND;
    FOREND;
    IF found_error THEN
      append_text (' ', ']', error_text, error_index);
      osp$append_status_parameter (' ', error_text, status);
    IFEND;

  PROCEND bai$check_tape_error;


  PROCEDURE [INLINE] append_text (delimiter: char;
        text: string ( * );
    VAR error_text: string ( * );
    VAR error_index: integer);

    error_text (error_index) := delimiter;
    error_index := error_index + 1;
    error_text (error_index, *) := text;
    error_index := error_index + STRLENGTH (text);

  PROCEND append_text;
*DECK DECK=BAI$CLEAR_FAIL_AT_CURRENT_POS EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_operation
*copyc bat$tape_descriptor
*copyc bat$task_file_table
*copyc ost$status
?? POP ??

{
{ The purpose of this request is to set the failure_isolation.
{ failed_at_current_position to FALSE.  The intent is for this routine to
{ set the field upon entry to the fap.
{
{ This field will only be set TRUE when an error is detected during an
{ operation on the current block.  Currently, this is only possible for
{ undefined records on user specified blocked tape files.
{
*copy bah$inline_proc_documentation

  PROCEDURE [INLINE] bai$clear_fail_at_current_pos (operation: amt$fap_operation;
    VAR status: ost$status);

    IF operation >= amc$last_access_start THEN
      tape_descriptor^.failure_isolation.failed_at_current_position := TRUE;
      tape_descriptor^.failure_isolation.failure_modes := $amt$tape_failure_modes [ ];
    IFEND;

  PROCEND bai$clear_fail_at_current_pos;
*DECK DECK=BAI$DYNAMIC_LABEL EXPAND=FALSE

{
{ The purpose of this request is to return a pointer to the
{ dynamic label for the current instance of open of the file.
{

 FUNCTION [INLINE] bai$dynamic_label (file_instance: ^bat$task_file_entry):
      ^bat$dynamic_label_attributes;

    bai$dynamic_label := ^file_instance^.instance_attributes.dynamic_label;

  FUNCEND bai$dynamic_label;
*DECK DECK=BAI$FAP_CONTROL EXPAND=FALSE
*copy bai$call_fap_control

  IF NOT bam_status.normal THEN
    IF osp$file_access_condition (bam_status) THEN
      PUSH context;
      context^ := osv$initial_exception_context;
      context^.allowed_access_conditions :=
            file_instance^.allowed_access_conditions;
      context^.file.selector := osc$ecp_file_identifier;
      context^.file.file_identifier := file_identifier;
      context^.wait_time := file_instance^.wait_time;
      IF file_instance^.device_class = rmc$mass_storage_device THEN
        context^.externalized_info.file_segment_isolated := TRUE;
        context^.externalized_info.file_segment := #SEGMENT (file_instance^.file_pva);
      IFEND;

      CASE call_block.operation OF
      = amc$flush_req =
        context^.wait := (call_block.flush.wait = osc$wait);
      ELSE
        context^.wait := file_instance^.wait;
      CASEND;

      REPEAT
        context^.condition_status := bam_status;
        osp$enforce_exception_policies (context^);
        bam_status := context^.condition_status;
        IF context^.wait THEN
*copy bai$call_fap_control
        IFEND;
      UNTIL bam_status.normal OR NOT (osp$file_access_condition (bam_status)) OR (NOT context^.wait);
    IFEND;
    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
  IFEND;
*DECK DECK=BAI$FETCH_TAPE_ATTRIBUTES EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc amp$fetch
*copyc amt$tape_error_options
?? POP ??
{
{ The purpose of this request is to use the amp$fetch interface
{ to fetch certain attributes used by the tape management faps.
{

  PROCEDURE [INLINE] bai$fetch_tape_attributes (file_identifier:
    amt$file_identifier;
    VAR forced_write: amt$forced_write;
    VAR max_block_length: amt$max_block_length;
    VAR tape_error_options: amt$tape_error_options;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??

    VAR
      fetch_items: array [1 .. 3] of amt$fetch_item;

    fetch_items [1].key := amc$forced_write;
    fetch_items [2].key := amc$max_block_length;
    { fetch_items[3].key := amc$tape_error_options; }

    amp$fetch (file_identifier, fetch_items, status);

    IF status.normal THEN
      forced_write := fetch_items [1].forced_write;
      max_block_length := fetch_items [2].max_block_length;
      { tape_error_options := fetch_items[3].tape_error_options; }
    IFEND;

  PROCEND bai$fetch_tape_attributes;
?? POP ??
*DECK DECK=BAI$FETCH_TAPE_ERROR_OPTIONS EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bat$task_file_table
*copyc ost$status
?? POP ??

{
{ The purpose of this request is to return the current tape_error_options
{ for the file indicated.
{
*copy bah$inline_proc_documentation

  PROCEDURE [INLINE] bai$fetch_tape_error_options (VAR tape_error_options: amt$tape_error_options;
    VAR status: ost$status);

    tape_error_options := tape_descriptor^.error_options;

  PROCEND bai$fetch_tape_error_options;
*DECK DECK=BAI$FETCH_TAPE_GET_ATTRIBUTES EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc amp$fetch
*copyc amt$tape_error_options
?? POP ??
{
{ The purpose of this request is to use the amp$fetch interface
{ to fetch certain attributes used by the tape management faps.
{

  PROCEDURE [INLINE] bai$fetch_tape_get_attributes (file_identifier:
    amt$file_identifier;
    VAR max_block_length: amt$max_block_length;
    VAR tape_error_options: amt$tape_error_options;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??

    VAR
      fetch_items: array [1 .. 2] of amt$fetch_item;

    fetch_items [1].key := amc$max_block_length;
    { fetch_items[2].key := amc$tape_error_options; }

    amp$fetch (file_identifier, fetch_items, status);

    IF status.normal THEN
      max_block_length := fetch_items [1].max_block_length;
      tape_error_options := $amt$tape_error_options [amc$accept_erroneous_block]; { kludge
                                                    {  until actual data can be returned. }
    IFEND;

  PROCEND bai$fetch_tape_get_attributes;
?? POP ??

*DECK DECK=BAI$FETCH_TAPE_PUT_ATTRIBUTES EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc amp$fetch
*copyc amt$tape_error_options
?? POP ??
{
{ The purpose of this request is to use the amp$fetch interface
{ to fetch certain attributes used by the tape management faps.
{

  PROCEDURE [INLINE] bai$fetch_tape_put_attributes (file_identifier:
    amt$file_identifier;
    VAR forced_write: amt$forced_write;
    VAR max_block_length: amt$max_block_length;
    VAR tape_error_options: amt$tape_error_options;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??

    VAR
      fetch_items: array [1 .. 3] of amt$fetch_item;

    fetch_items [1].key := amc$forced_write;
    fetch_items [2].key := amc$max_block_length;
    { fetch_items[3].key := amc$tape_error_options; }

    amp$fetch (file_identifier, fetch_items, status);

    IF status.normal THEN
      forced_write := fetch_items [1].forced_write;
      max_block_length := fetch_items [2].max_block_length;
    { tape_error_options := fetch_items [3].tape_error_options;
    IFEND;

  PROCEND bai$fetch_tape_put_attributes;
?? POP ??
*DECK DECK=BAI$FORCED_WRITE EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fetch_attributes
*copyc amt$call_block
*copyc ost$status
*copyc bap$fap_control
?? POP ??

  PROCEDURE [INLINE] bai$forced_write (file_identifier: amt$file_identifier;
    VAR forced_write: amt$forced_write;
    VAR status: ost$status);

    VAR
      call_block: amt$call_block,
      fetch_attribute: array [ 1 .. 1 ] of amt$fetch_item;

    call_block.operation := amc$fetch_req;
    fetch_attribute [1].key := amc$forced_write;
    call_block.fetch.file_attributes := ^fetch_attribute;
    bap$fap_control (file_identifier, call_block, global_layer_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    forced_write := fetch_attribute[1].forced_write;

  PROCEND bai$forced_write;
*DECK DECK=BAI$FTD EXPAND=FALSE

{
{ The purpose of this request is to return a pointer to the
{ private read information for the current instance of open
{ of the file.
{

 FUNCTION [INLINE] bai$pri (file_instance: ^bat$task_file_entry):
      ^bat$private_read_information;

    bai$pri := file_instance^.private_read_information;

  FUNCEND bai$pri;
*DECK DECK=BAI$GET_ANSI_RCW EXPAND=FALSE

PROCEDURE {[INLINE]} bai$get_ansi_rcw;

  VAR
    binary_length: clt$integer,
    os_status: ost$error;

  CONST
    ebcdic_zero = $CHAR(0F0(16));

/find_header/
  WHILE TRUE DO

    manually_advance_to_next_block := FALSE;

    IF block_info^.block_position = bac$middle_of_block THEN
      IF rhl <= block_info^.residual_block_length THEN
        start_new_block := FALSE;
      ELSE
        start_new_block := TRUE;
      IFEND;
    ELSE
      start_new_block := TRUE;
    IFEND;

    get_data (file_identifier, operation, #LOC(rh), rhl,
      allow_direct_io_transfer, start_new_block, {convert_if_ebcdic =} FALSE, status);

{ If the record header was recorded in EBCDIC and character conversion is requested,
{ convert the record header to ASCII.  This code assumes that any value greater
{ than or equal to EBCDIC zero indicates an EBCDIC representation for the control word.

    IF (state_info^.character_set = amc$ebcdic) AND state_info^.character_conversion
          AND (rh.length(1,1) >= ebcdic_zero) THEN
      osp$translate_bytes (#LOC(rh), rhl, #LOC(rh), rhl, ^osv$ebcdic_to_ascii, os_status);
    IFEND;

    start_new_block := FALSE;

    IF NOT status.normal THEN
      manually_advance_to_next_block := TRUE;
      exit_situation := TRUE;
      EXIT /find_header/;
    IFEND;

    IF gfi^.positioning_info.record_info.transfer_count < rhl THEN
      residual_data_length := 0;
      IF (tape_descriptor^.volume_position = amc$eov) OR
         (tape_descriptor^.volume_position = amc$after_tapemark) THEN
        no_header_read := TRUE;
        exit_situation := TRUE;
      ELSE
      { ! ERROR IN BLOCK
        manually_advance_to_next_block := TRUE;
        exit_situation := TRUE;
        amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
          call_block.operation, ' ', status);
      IFEND;
      EXIT /find_header/;
    IFEND;

    IF rh.length = bac$ansi_block_padding_chars THEN
      residual_data_length := 0;
      block_info^.current_block_byte_address :=
        block_info^.current_block_byte_address + block_info^.residual_block_length;
      block_info^.residual_block_length :=
        block_info^.residual_block_length - block_info^.residual_block_length;
      CYCLE /find_header/;

    ELSE
      clp$convert_string_to_integer (rh.length, binary_length, status);
      IF NOT status.normal THEN
        manually_advance_to_next_block := TRUE;
        exit_situation := TRUE;
        amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
          call_block.operation, ' ', status);
        EXIT /find_header/;
      IFEND;

      IF (binary_length.value <= UPPERVALUE (bat$rcw_length_value_range)) AND
         (binary_length.value >= LOWERVALUE (bat$rcw_length_value_range)) AND
         (binary_length.value - rhl <= block_info^.residual_block_length) THEN

        last_record_header_p := ^tape_descriptor^.get_tape_block_buffer^
          [block_info^.current_block_byte_address +1 -rhl ];
        residual_data_length := binary_length.value - rhl;

        IF binary_length.value = rhl THEN
          zero_length_record := TRUE;
          exit_situation := TRUE;
        IFEND;

        EXIT /find_header/;

      ELSE
        manually_advance_to_next_block := TRUE;
        exit_situation := TRUE;
        amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
          call_block.operation, ' ', status);
        EXIT /find_header/;

      IFEND;
    IFEND;

  WHILEND /find_header/;

  gfi^.positioning_info.record_info.transfer_count := 0;

  IF manually_advance_to_next_block THEN
    residual_data_length := 0;
    block_info^.current_block_byte_address :=
      block_info^.current_block_byte_address + block_info^.residual_block_length;
    block_info^.residual_block_length :=
      block_info^.residual_block_length - block_info^.residual_block_length;
    gfi^.positioning_info.record_info.file_position := amc$mid_record;
  IFEND;

PROCEND bai$get_ansi_rcw;

*DECK DECK=BAI$GET_ANSI_SCW EXPAND=FALSE

PROCEDURE {[INLINE]} bai$get_ansi_scw;

  VAR
    binary_length: clt$integer,
    os_status: ost$error;

  CONST
    ebcdic_zero = $CHAR(0F0(16));

/find_header/
  WHILE TRUE DO

    manually_advance_to_next_block := FALSE;

    IF block_info^.block_position = bac$middle_of_block THEN
      IF rhl <= block_info^.residual_block_length THEN
        start_new_block := FALSE;
      ELSE
        start_new_block := TRUE;
      IFEND;
    ELSE
      start_new_block := TRUE;
    IFEND;

    get_data (file_identifier, operation, #LOC(rh), rhl,
      allow_direct_io_transfer, start_new_block, {convert_if_ebcdic =} FALSE, status);

{ If the record header was recorded in EBCDIC and character conversion is requested,
{ convert the record header to ASCII.  This code assumes that any value greater
{ than or equal to EBCDIC zero indicates an EBCDIC representation for the control word.

    IF (state_info^.character_set = amc$ebcdic) AND state_info^.character_conversion
          AND (rh.header_type >= ebcdic_zero) THEN
      osp$translate_bytes (#LOC(rh), rhl, #LOC(rh), rhl, ^osv$ebcdic_to_ascii, os_status);
    IFEND;

    start_new_block := FALSE;

    IF NOT status.normal THEN
      manually_advance_to_next_block := TRUE;
      exit_situation := TRUE;
      EXIT /find_header/;
    IFEND;

    IF gfi^.positioning_info.record_info.transfer_count < rhl THEN
      residual_data_length := 0;
      IF (tape_descriptor^.volume_position = amc$eov) OR
         (tape_descriptor^.volume_position = amc$after_tapemark) THEN
        no_header_read := TRUE;
        exit_situation := TRUE;
      ELSE
      { ! ERROR IN BLOCK
        manually_advance_to_next_block := TRUE;
        exit_situation := TRUE;
        amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
          call_block.operation, ' ', status);
      IFEND;
      EXIT /find_header/;
    IFEND;

    IF (rh.header_type <= bac$end_segment) AND (rh.header_type >= bac$full_segment) THEN

      clp$convert_string_to_integer (rh.length, binary_length, status);
      IF NOT status.normal THEN
        manually_advance_to_next_block := TRUE;
        exit_situation := TRUE;
        amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
          call_block.operation, ' ', status);
        EXIT /find_header/;
      IFEND;

      IF (binary_length.value <= UPPERVALUE (bat$scw_length_value_range)) AND
         (binary_length.value >= LOWERVALUE (bat$scw_length_value_range)) AND
         (binary_length.value - rhl <= block_info^.residual_block_length) THEN

        last_record_header_p := ^tape_descriptor^.get_tape_block_buffer^
          [block_info^.current_block_byte_address +1 -rhl ];
        residual_data_length := binary_length.value - rhl;

        IF binary_length.value = rhl THEN
          IF rh.header_type = bac$full_segment THEN
            zero_length_record := TRUE;
            exit_situation := TRUE;
          IFEND;
        IFEND;

        EXIT /find_header/;

      ELSE
        manually_advance_to_next_block := TRUE;
        exit_situation := TRUE;
        amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
          call_block.operation, ' ', status);
        EXIT /find_header/;
      IFEND;

    ELSEIF rh.header_type = bac$ansi_block_padding_char THEN
      residual_data_length := 0;
      block_info^.current_block_byte_address :=
        block_info^.current_block_byte_address + block_info^.residual_block_length;
      block_info^.residual_block_length :=
        block_info^.residual_block_length - block_info^.residual_block_length;
      CYCLE /find_header/;

    ELSE
      manually_advance_to_next_block := TRUE;
      exit_situation := TRUE;
      amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
        call_block.operation, ' ', status);
      EXIT /find_header/;
    IFEND;

  WHILEND /find_header/;

  gfi^.positioning_info.record_info.transfer_count := 0;

  IF manually_advance_to_next_block THEN
    residual_data_length := 0;
    block_info^.current_block_byte_address :=
      block_info^.current_block_byte_address + block_info^.residual_block_length;
    block_info^.residual_block_length :=
      block_info^.residual_block_length - block_info^.residual_block_length;
    gfi^.positioning_info.record_info.file_position := amc$mid_record;
  IFEND;

PROCEND bai$get_ansi_scw;

*DECK DECK=BAI$GET_EOI_CHECK EXPAND=FALSE
{
{ BAI$GET_EOI_CHECK
{
{ This code does checking for gets at or past eoi_byte_address.
{ Caller must set record_info.current_byte_address.

  IF record_info.current_byte_address >=
        file_instance^.global_file_information^.eoi_byte_address THEN
    at_eoi := TRUE;
    IF record_info.current_byte_address >
          file_instance^.global_file_information^.eoi_byte_address THEN
      amp$set_file_instance_abnormal (file_identifier, ame$input_after_eoi,
            call_block.operation, '', status);
    ELSE
      IF record_info.file_position = amc$eoi THEN
        IF file_instance^.previous_get_at_eoi THEN
          amp$set_file_instance_abnormal (file_identifier, ame$input_after_eoi,
                call_block.operation, '', status);
        IFEND;
      IFEND; { fp = eoi }
    IFEND;
    record_info.file_position := amc$eoi;
    file_instance^.previous_get_at_eoi := TRUE;
  ELSE
    at_eoi := FALSE;
    file_instance^.previous_get_at_eoi := FALSE;
  IFEND;

{ end of BAI$GET_EOI_CHECK
{
*DECK DECK=BAI$GET_FAP_LAYER EXPAND=FALSE
      IF (file_instance^.fap_control_information.fap_array = NIL) AND
            (layer_number = 0) THEN
        layer := ^file_instance^.fap_control_information.first_fap;
      ELSEIF (file_instance^.fap_control_information.fap_array <> NIL) AND
            (layer_number <= UPPERBOUND (file_instance^.
            fap_control_information.fap_array^)) THEN
        layer := ^file_instance^.fap_control_information.
              fap_array^ [layer_number];
      ELSE
        osp$set_status_abnormal (amc$access_method_id,
              ame$improper_layer_number, interface_name, bam_status);
      IFEND;

*DECK DECK=BAI$GET_POSITIONING_INFO EXPAND=FALSE
{
{ BAI$GET_POSITIONING_INFO
{
{ Obtain current positioning information.

  IF file_instance^.private_read_information = NIL THEN
    record_info := file_instance^.global_file_information^.
      positioning_info.record_info;
    block_info := file_instance^.global_file_information^.
      positioning_info.block_info;
  ELSE
    record_info := file_instance^.private_read_information^.
      positioning_info.record_info;
    block_info := file_instance^.private_read_information^.
      positioning_info.block_info;
  IFEND;

{ end of BAI$GET_POSITIONING_INFO
{
*DECK DECK=BAI$GET_RECORD_HEADER EXPAND=FALSE

PROCEDURE [INLINE] bai$get_record_header;

  manually_advance_to_next_block := FALSE;

  IF block_info^.block_position = bac$middle_of_block THEN
    IF rhl <= block_info^.residual_block_length THEN
      start_new_block := FALSE;
    ELSE
      start_new_block := TRUE;
    IFEND;
  ELSE
    start_new_block := TRUE;
  IFEND;

  get_data (file_identifier, operation, #LOC(rh), rhl,
    allow_direct_io_transfer, start_new_block,
    {convert_if_ebcdic =} FALSE, status);

  start_new_block := FALSE;

  IF NOT status.normal THEN
    manually_advance_to_next_block := TRUE;
    exit_situation := TRUE;
  ELSEIF gfi^.positioning_info.record_info.transfer_count < rhl THEN
    residual_data_length := 0;
    IF (tape_descriptor^.volume_position = amc$eov) OR
       (tape_descriptor^.volume_position = amc$after_tapemark) THEN
      no_header_read := TRUE;
      exit_situation := TRUE;
    ELSE
      manually_advance_to_next_block := TRUE;
      exit_situation := TRUE;
      amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
        call_block.operation, ' ', status);
    IFEND
  ELSEIF (rh.unique_id = bac$record_header_unique_id)
    AND (rh.header_type <= UPPERVALUE (rh.header_type))
    AND (rh.header_type >= LOWERVALUE (rh.header_type))
    AND (rh.length <= UPPERVALUE (rh.length))
    AND (rh.length >= LOWERVALUE (rh.length))
    AND (rh.length <= block_info^.residual_block_length) THEN
      last_record_header_p := ^tape_descriptor^.get_tape_block_buffer^
        [block_info^.current_block_byte_address +1 -rhl ];
      residual_data_length := rh.length;
      IF rh.length = 0 THEN
        CASE rh.header_type OF
        = bac$full_record =
          zero_length_record := TRUE;
          exit_situation := TRUE;
        = bac$partition =
          exit_situation := TRUE;
        ELSE
        CASEND;
      IFEND;
  ELSE
    manually_advance_to_next_block := TRUE;
    exit_situation := TRUE;
    amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
      call_block.operation, ' ', status);
  IFEND;

  gfi^.positioning_info.record_info.transfer_count := 0;

  IF manually_advance_to_next_block THEN
    residual_data_length := 0;
    block_info^.current_block_byte_address :=
      block_info^.current_block_byte_address + block_info^.residual_block_length;
    block_info^.residual_block_length :=
      block_info^.residual_block_length - block_info^.residual_block_length;
    gfi^.positioning_info.record_info.file_position := amc$mid_record;
  IFEND;

PROCEND bai$get_record_header;
*DECK DECK=BAI$GET_RECORD_INFO EXPAND=FALSE
{
{ BAI$GET_RECORD_INFO
{
{ Obtain current record information.

  IF file_instance^.private_read_information = NIL THEN
    record_info := file_instance^.global_file_information^.positioning_info.
          record_info;
  ELSE
    record_info := file_instance^.private_read_information^.positioning_info.
          record_info;
  IFEND;

{ end of BAI$GET_RECORD_INFO
{
*DECK DECK=BAI$GFI EXPAND=FALSE

{
{ The purpose of this request is to return a pointer to the
{ global file information for the current instance of open
{ of the file.
{

 FUNCTION [INLINE] bai$gfi (file_instance: ^bat$task_file_entry):
      ^bat$global_file_information;

    bai$gfi := file_instance^.global_file_information;

  FUNCEND bai$gfi;
*DECK DECK=BAI$INIT_BOI_TAPE_POSITION EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bat$task_file_table
*copyc bai$gfi
*copyc bai$tape_descriptor
?? POP ??
*copyc bai$rewind_gfi
*copyc bai$rewind_tape_descriptor

{
{ The purpose of this procedure is to initialize fields that are used by BAM to
{ maintain file positions.  The fields are initialized to reflect an
{ open position of begining of information.
{

  PROCEDURE [INLINE] bai$init_boi_tape_position;

    bai$rewind_gfi;
    bai$rewind_tape_descriptor;

  PROCEND bai$init_boi_tape_position;
*DECK DECK=BAI$LABEL_TYPE EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bat$task_file_table
*copyc amt$file_label_type
?? POP ??

{
{ The purpose of this request is to return the label type of the file
{ associated with the file instance.
{
*copy bah$inline_proc_documentation

  FUNCTION [INLINE] bai$label_type: amt$file_label_type;

    bai$label_type := tape_descriptor^.file_label_type;

  FUNCEND bai$label_type;
*DECK DECK=BAI$LRT_COMMON_PROCEDURES EXPAND=FALSE
?? OLDTITLE ??
?? NEWTITLE := 'bai$lrt_common_procedures',  EJECT ??

{
{ The following procedures are common to the BAM$LRT Tape Faps.
{ The procedures assume the following global variables are defined
{ and initialized.
{
{   file_instance: ^bat$task_file_entry,
{   gfi: ^bat$global_file_information,
{   block_info: ^bat$block_info,
{   tape_descriptor: ^bat$tape_descriptor,
{   pad_blocks: boolean,
{   record_headers_exist: boolean,
{   operation: amt$fap_operation,
{   global_layer_number: amt$fap_layer_number,
{   state_info: ^file_instance^.labeled_tape_state_info (bat$labeled_tape_state_info)

?? NEWTITLE := '  close_req', EJECT ??

{
{ The purpose of this request is to get the tape file in consistant
{ state and close the tape file.
{ To get the tape file in a consistant state it must:
{  1) Complete writing of any partial blocks.
{  2) Tell tape block manager to align the physical and logical position.
{  3) Tell tape block manager to close the tape file.
{

  PROCEDURE close_req (file_identifier: amt$file_identifier;
    VAR status: ost$status);

    VAR
      error_action: bat$error_actions,
      file_position: amt$file_position,
      last_record_header_p: ^cell,
      request_status: ost$status,
      tape_failure_modes: amt$tape_failure_modes;

    status.normal := TRUE;

  /main_program/
    BEGIN

{
{ Check file position to see if any partial blocks need to be written out.
{

      IF bai$partial_block_exists () THEN
        bai$write_previous_block (file_identifier, status);
      IFEND;

      IF tape_descriptor^.file_label_type = amc$labeled THEN
        IF state_info^.put_op OR state_info^.eoi_labels_needed THEN
          rmp$log_debug_message ('Calling SL_PUT_END_OF_FILE_LABELS from CLOSE_REQ');
          sl_put_end_of_file_labels (file_identifier, status);
        IFEND;

      IFEND;

      error_action := bac$continue;

    /loop/
      REPEAT
        bap$tape_bm_align_position (file_identifier, tape_failure_modes, request_status);
        IF status.normal THEN
          bai$process_request_status (file_identifier, amc$close_req, request_status, tape_failure_modes,
                error_action, status);
          IF error_action = bac$exit_procedure THEN
            EXIT /loop/;
          IFEND;
        IFEND;
      UNTIL error_action = bac$continue;

{ Reset record_header_fba to a relative address within the current buffer
{ if record_headers_exist = TRUE.  This must be done to ensure the correct
{ location if the tape is opened ASIS following a get_partial and close.

      IF (((block_info^.block_position = bac$middle_of_block) OR
            (gfi^.positioning_info.record_info.file_position = amc$mid_record))
            AND (record_headers_exist)) THEN
        IF tape_descriptor^.get_tape_block_buffer <> NIL THEN
          last_record_header_p := #ADDRESS (#RING (tape_descriptor^.get_tape_block_buffer),
                #SEGMENT (tape_descriptor^.get_tape_block_buffer),
                gfi^.positioning_info.record_info.record_header_fba);
          IF (#OFFSET (last_record_header_p) >= #OFFSET (tape_descriptor^.get_tape_block_buffer)) THEN
            gfi^.positioning_info.record_info.record_header_fba := #OFFSET (last_record_header_p) -
                  #OFFSET (tape_descriptor^.get_tape_block_buffer);
          IFEND;
        IFEND;
      IFEND;

{
{ This request is only needed here because concurrent opens
{ of a tape file are illegal.  If that restriction is removed,
{ this call may be required on put and get requests.
{

      bap$tape_bm_close (file_identifier, tape_failure_modes, request_status);

      IF status.normal THEN
        bai$process_request_status (file_identifier, amc$close_req, request_status, tape_failure_modes,
              error_action, status);
        IF error_action = bac$exit_procedure THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

    END /main_program/;
  PROCEND close_req;
?? OLDTITLE ??
?? NEWTITLE := '  close_volume_req', EJECT ??

{
{ The purpose of this request is to switch to the next volume of a file.
{

  PROCEDURE close_volume_req
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      volume_position: amt$volume_position;

    status.normal := TRUE;
    volume_position := tape_descriptor^.volume_position;


{ Attempt to flush any buffered data to tape before advance volume.

    flush_req (file_identifier, status);
    IF status.normal THEN
      IF tape_descriptor^.file_label_type = amc$labeled THEN
        sl_close_label_volume (file_identifier, status);
      ELSE { label_type <> amc$labeled  }
        bai$advance_volume (file_identifier, volume_position, status);
        tape_descriptor^.volume_position := volume_position;
      IFEND;
    IFEND;

  PROCEND close_volume_req;
?? OLDTITLE ??
?? NEWTITLE := '  erase_tape_block_req', EJECT ??

{
{ The purpose of this request is to erase a specified length of magnetic tape.
{

  PROCEDURE erase_tape_block_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      error_action: bat$error_actions,
      request_status: ost$status,
      tape_failure_modes: amt$tape_failure_modes;

  /main_program/
    BEGIN

      status.normal := TRUE;

{
{ Check file position to see if any partial blocks need to be written out.
{

      IF bai$partial_block_exists () THEN
        bai$write_previous_block (file_identifier, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      REPEAT
        bap$tape_bm_erase_block (file_identifier, call_block.erase_tape_block.block_length,
              tape_failure_modes, request_status);
        bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
              error_action, status);
        IF error_action = bac$exit_procedure THEN
          EXIT /main_program/;
        IFEND;
      UNTIL error_action = bac$continue;

    END /main_program/;
    tape_descriptor^.labeled_volume_position := bac$lvp_within_ansi_file;
    tape_descriptor^.volume_position := amc$after_data_block;

  PROCEND erase_tape_block_req;
?? OLDTITLE ??
?? NEWTITLE := '  flush_req', EJECT ??

{
{ The purpose of this request is to flush any buffered data to tape.
{ This request onlyl makes sense if writing to tape.
{

  PROCEDURE flush_req (file_identifier: amt$file_identifier;
    VAR status: ost$status);

    VAR
      error_action: bat$error_actions,
      request_status: ost$status,
      tape_failure_modes: amt$tape_failure_modes;

  /main_program/
    BEGIN

      status.normal := TRUE;
      rmp$log_debug_message ('Entering FLUSH_REQ');

{ Pad record if compilation variable pad_records is true.

? IF pad_records THEN
      IF bai$partial_record_exists () THEN
        rmp$log_debug_message ('Padding record');
        pad_record;
      IFEND;
? IFEND

{
{ Check file position to see if any partial blocks need to be written out.
{

      IF bai$partial_block_exists () THEN
        rmp$log_debug_message ('Writing previous block');
        bai$write_previous_block (file_identifier, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      REPEAT
        rmp$log_debug_message ('Calling BM flush');
        bap$tape_bm_flush (file_identifier, tape_failure_modes, request_status);
        bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
              error_action, status);
        IF error_action = bac$exit_procedure THEN
          rmp$log_debug_message ('Exiting procedure');
          EXIT /main_program/;
        IFEND;
      UNTIL error_action = bac$continue;

    END /main_program/;

  PROCEND flush_req;
?? OLDTITLE ??
?? NEWTITLE := '  get_block', EJECT ??

{
{ The purpose of this request is to call bap$tape_bm_read_next_block,
{ process the block information and request_status, and to calculate
{ the block position.
{

  PROCEDURE get_block
    (    file_identifier: amt$file_identifier;
         operation: amt$fap_operation;
         volunteered_buffer: ^bat$tape_block;
         requested_buffer_length: amt$working_storage_length;
     VAR buffer_pointer: ^bat$tape_block;
     VAR error_action: bat$error_actions;
     VAR block_position: bat$block_position;
     VAR transfer_count: amt$transfer_count;
     VAR current_volume_position: amt$volume_position;
     VAR status: ost$status);

    VAR
      block_length: amt$max_block_length,
      block_type: bat$tape_block_type,
      pre_request_volume_position: amt$volume_position,
      reissue_read_request: boolean,
      request_status: ost$status,
      tape_error_options: amt$tape_error_options,
      tape_failure_modes: amt$tape_failure_modes,
      system_media_recovery: boolean;

    status.normal := TRUE;
    pre_request_volume_position := current_volume_position;
    transfer_count := 0;

    bai$fetch_tape_error_options (tape_error_options, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pre_request_volume_position <> amc$after_data_block THEN
      block_info^.block_number := 1;
    IFEND;

    system_media_recovery := tape_error_options.perform_failure_recovery;
    error_action := bac$continue;

    REPEAT
      bap$tape_bm_read_next_block (file_identifier, operation, volunteered_buffer, requested_buffer_length,
            system_media_recovery, buffer_pointer, block_type, block_length, tape_failure_modes,
            request_status);
      IF request_status.normal OR (request_status.condition = bae$block_truncated) THEN
        tape_descriptor^.labeled_volume_position := bac$lvp_within_ansi_file;
        status.normal := TRUE;
        IF block_type = bac$good_data_block THEN
          reissue_read_request := FALSE;
          current_volume_position := amc$after_data_block;
        ELSE
          bai$process_block_information (file_identifier, tape_descriptor^.file_label_type, operation,
                block_type, tape_error_options, tape_failure_modes, reissue_read_request,
                current_volume_position, status);
        IFEND;
        IF NOT status.normal AND (status.condition <> ame$accept_bad_block) THEN
          error_action := bac$exit_procedure;
          RETURN;
        IFEND;
      ELSE
        bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
              error_action, status);
        IF error_action = bac$exit_procedure THEN
          RETURN;
        IFEND;
      IFEND;
      transfer_count := block_length;
      IF (pre_request_volume_position = amc$after_data_block) AND
            (tape_descriptor^.volume_position = amc$after_data_block) THEN
        block_info^.block_number := block_info^.block_number + 1;
      IFEND;

      IF requested_buffer_length >= transfer_count THEN
        block_position := bac$beginning_of_block;
      ELSE
        block_position := bac$middle_of_block;
      IFEND;
      IF (current_volume_position = amc$after_tapemark) OR (current_volume_position = amc$eov) THEN
        transfer_count := 0;
        block_position := bac$beginning_of_block;
        reissue_read_request := FALSE;
      IFEND;
      IF NOT request_status.normal THEN
        IF request_status.condition = bae$block_truncated THEN
          block_position := bac$middle_of_block;
        IFEND;
      IFEND;

      IF NOT status.normal THEN
        RETURN;
      IFEND;

    UNTIL (error_action <> bac$retry_last_request) AND (reissue_read_request = FALSE);

  PROCEND get_block;
?? OLDTITLE ??
?? NEWTITLE := '  get_data', EJECT ??

{
{ The purpose of this request is to return a portion of a data block to the calling
{ routines.  It determines which part of the current block is to be returned, or
{ weather to read a new block in from tape.  This routine uses and updates information
{ stored in the block_info and tape_descriptor tables.
{

  PROCEDURE get_data (file_identifier: amt$file_identifier;
        operation: amt$fap_operation;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
        allow_direct_io_transfer: boolean;
        start_new_block: boolean;
        convert_if_ebcdic: boolean;
    VAR status: ost$status);

    VAR
      convert_data_to_ebcdic: boolean,
      current_block_byte_address: amt$file_byte_address,
      current_block_length: amt$working_storage_length,
      error_action: bat$error_actions,
      block_position: bat$block_position,
      from_ptr: ^cell,
      os_status: ost$error,
      remaining_block_length: amt$max_block_length,
      residual_skip_count: amt$skip_count,
      request_status: ost$status,
      tape_failure_modes: amt$tape_failure_modes,
      transfer_count: amt$transfer_count,
      volume_position: amt$volume_position,
      volunteered_buffer: ^bat$tape_block,
      wsa: ^cell,
      wsl: amt$working_storage_length;

  /main_program/
    BEGIN


{
{ Initialize local variables from the global file information.
{

      status.normal := TRUE;
      volume_position := tape_descriptor^.volume_position;
      transfer_count := gfi^.positioning_info.record_info.transfer_count;
      block_position := block_info^.block_position;
      current_block_byte_address := block_info^.current_block_byte_address;
      current_block_length := block_info^.current_block_length;
      wsl := working_storage_length;
      wsa := working_storage_area;

      convert_data_to_ebcdic:= (state_info^.character_set = amc$ebcdic) AND state_info^.character_conversion
          AND convert_if_ebcdic;

      IF tape_descriptor^.file_label_type = amc$labeled THEN
        IF state_info^.put_op OR state_info^.eoi_labels_needed THEN
          rmp$log_debug_message ('Calling SL_PUT_END_OF_FILE_LABELS from GET_DATA');
          sl_put_end_of_file_labels (file_identifier, status);
          rmp$log_debug_integer ('Labeled Volume Position is: ',
                $INTEGER (tape_descriptor^.labeled_volume_position));
          rmp$log_debug_integer ('Volume Position is: ',
                $INTEGER (tape_descriptor^.volume_position));
          rmp$log_debug_message ('Calling SL_PUT_END_OF_FILE_LABELS from CLOSE_REQ');
          IF status.normal THEN
            sl_enable_read_after_write (file_identifier, status);
          IFEND;
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
          transfer_count := 0;
          state_info^.put_op := FALSE;
          block_position := bac$beginning_of_block;
          volume_position := amc$after_tapemark;
          EXIT /main_program/;
        IFEND;

        IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
          transfer_count := 0;
          IF file_instance^.previous_get_at_eoi THEN
            amp$set_file_instance_abnormal (file_identifier, ame$input_after_eoi, operation, ' ', status);
          ELSE
            volume_position := amc$after_tapemark;
          IFEND;
          EXIT /main_program/;
        IFEND;

      ELSE  { label_type = amc$unlabeled or amc$non_standard_labeled

        IF (block_position = bac$beginning_of_block) AND (volume_position = amc$eov) THEN
          transfer_count := 0;
          IF file_instance^.previous_get_at_eoi THEN
            amp$set_file_instance_abnormal (file_identifier, ame$input_after_eoi, operation, ' ', status);
            EXIT /main_program/;
          IFEND;
        IFEND;

      IFEND;

      IF start_new_block OR (block_position <> bac$middle_of_block) THEN

        current_block_byte_address := 0;
        current_block_length := 0;
        IF allow_direct_io_transfer THEN
          volunteered_buffer := wsa;
        ELSE
          volunteered_buffer := NIL;
        IFEND;

        get_block (file_identifier, operation, volunteered_buffer, wsl, tape_descriptor^.
              get_tape_block_buffer, error_action, block_position, transfer_count, volume_position, status);

        IF NOT status.normal AND (status.condition = ame$input_after_output) THEN
          file_instance^.previous_get_at_eoi :=  TRUE;
          block_position := bac$beginning_of_block;
          volume_position := amc$eov;
          status.normal := TRUE;
          EXIT /main_program/;
        IFEND;

        IF (error_action = bac$exit_procedure) OR
              {} (volume_position = amc$eov) OR (volume_position = amc$after_tapemark) THEN
          EXIT /main_program/;
        IFEND;
        IF wsl > transfer_count THEN
          wsl := transfer_count;
        IFEND;
        IF NOT status.normal AND (status.condition = ame$unrecovered_read_error) THEN
          EXIT /main_program/;
        IFEND;

        IF volunteered_buffer = tape_descriptor^.get_tape_block_buffer THEN

{ Direct io transfer, no buffering. }
{ Clear the buffer pointer. }

          tape_descriptor^.get_tape_block_buffer := NIL;

{ Convert the data in the buffer if ebcdic.

          IF convert_data_to_ebcdic THEN
            osp$translate_bytes (volunteered_buffer, wsl, volunteered_buffer, wsl,
                  ^osv$ebcdic_to_ascii, os_status);
          IFEND;

        ELSE
          IF tape_descriptor^.get_tape_block_buffer = NIL THEN
            amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction, operation,
              'NIL get_tape_block_buffer in get_data.', status);
            EXIT /main_program/;
          IFEND;
          from_ptr := tape_descriptor^.get_tape_block_buffer;
          IF convert_data_to_ebcdic THEN
            osp$translate_bytes (from_ptr, wsl, wsa, wsl, ^osv$ebcdic_to_ascii, os_status);
          ELSE
            i#move (from_ptr, wsa, wsl);
          IFEND;
        IFEND;
        current_block_byte_address := wsl;
        current_block_length := transfer_count;
        transfer_count := wsl;

      ELSE { do not start_new_block and block_position = mid_block. }

        current_block_byte_address := block_info^.current_block_byte_address;

        IF tape_descriptor^.get_tape_block_buffer <> NIL THEN
          current_block_length := block_info^.current_block_length;
          remaining_block_length := current_block_length - current_block_byte_address;

          IF wsl >= remaining_block_length THEN
            wsl := remaining_block_length;
            block_position := bac$beginning_of_block;
          ELSE
            block_position := bac$middle_of_block;
          IFEND;

          from_ptr := ^tape_descriptor^.get_tape_block_buffer^ [current_block_byte_address + 1];
          IF convert_data_to_ebcdic THEN
            osp$translate_bytes (from_ptr, wsl, wsa, wsl, ^osv$ebcdic_to_ascii, os_status);
          ELSE
            i#move (from_ptr, wsa, wsl);
          IFEND;
          current_block_byte_address := current_block_byte_address + wsl;
          transfer_count := wsl;

        ELSE { No buffer available, need to  reread the block.   }

          REPEAT

            bap$tape_bm_skip_blocks (file_identifier, amc$backward, 1, residual_skip_count,
                  tape_failure_modes, request_status);

            bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
                  error_action, status);
            IF error_action = bac$exit_procedure THEN
              EXIT /main_program/;
            IFEND;
            tape_descriptor^.get_tape_block_buffer := NIL;

          UNTIL error_action = bac$continue;

{   Decrement block number to account for backspace

          IF block_info^.block_number > 1 THEN
            block_info^.block_number := block_info^.block_number - 1;
          ELSE
            tape_descriptor^.volume_position := amc$bov;
          IFEND;

          get_block (file_identifier, operation, NIL, gfi^.max_data_size, tape_descriptor^.
                get_tape_block_buffer, error_action, block_position, current_block_length, volume_position,
                status);

          IF NOT status.normal AND (status.condition = ame$input_after_output) THEN
            file_instance^.previous_get_at_eoi :=  TRUE;
            block_position := bac$beginning_of_block;
            volume_position := amc$eov;
            status.normal := TRUE;
            EXIT /main_program/;
          IFEND;

          IF (error_action = bac$exit_procedure) OR
                {} (volume_position = amc$eov) OR (volume_position = amc$after_tapemark) THEN
            EXIT /main_program/;
          IFEND;

          remaining_block_length := current_block_length - current_block_byte_address;

          IF wsl >= remaining_block_length THEN
            wsl := remaining_block_length;
            block_position := bac$beginning_of_block;
          ELSE
            block_position := bac$middle_of_block;
          IFEND;
          IF tape_descriptor^.get_tape_block_buffer = NIL THEN
            amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction, operation,
              'Get_block_buffer = NIL in get_data.', status);
            EXIT /main_program/;
          IFEND;
          from_ptr := ^tape_descriptor^.get_tape_block_buffer^ [current_block_byte_address + 1];
          IF convert_data_to_ebcdic THEN
            osp$translate_bytes (from_ptr, wsl, wsa, wsl, ^osv$ebcdic_to_ascii, os_status);
          ELSE
            i#move (from_ptr, wsa, wsl);
          IFEND;
          current_block_byte_address := current_block_byte_address + wsl;
          transfer_count := wsl;
        IFEND;
      IFEND;

    END /main_program/;

{
{ Set fields in the file transfer descriptor.
{

    block_info^.block_position := block_position;
    gfi^.positioning_info.record_info.transfer_count := transfer_count;
    block_info^.current_block_length := current_block_length;
    block_info^.current_block_byte_address := current_block_byte_address;
    block_info^.residual_block_length := current_block_length - current_block_byte_address;
    tape_descriptor^.volume_position := volume_position;

  PROCEND get_data;
?? OLDTITLE ??
?? NEWTITLE := '  open_req', EJECT ??

{
{ The purpose of this routine is to prepare the record management portion for
{ long record tape processing.
{

  PROCEDURE open_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
        dynamic_label: ^bat$dynamic_label_attributes;
    VAR status: ost$status);

?? NEWTITLE := '    bai$open_blk_xt_hndlr', EJECT ??
    PROCEDURE bai$open_blk_xt_hndlr (condition: pmt$condition;
          p_condition_info: ^pmt$condition_information;
          p_stack: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

{
{ The purpose of this condition handler is to handle all block
{ exit occurances that may occur while trying to open
{ a tape volume.  The assumptions is that appropriate actions
{ for the various conditions occur elsewhere.  If a block exit
{ is attempted at this level, the necessary action is to close
{ the file and get out.  Note that the tape block manager has
{ not set up any tables, thus does not need to be closed at that
{ level.
{

      VAR
        ignore_status: ost$status;

      condition_status.normal := TRUE;
      bap$close (file_identifier, ignore_status);

    PROCEND bai$open_blk_xt_hndlr;
?? OLDTITLE ??
?? NEWTITLE := '    initialize_tape_tables', EJECT ??
    PROCEDURE initialize_tape_tables
      (VAR status: ost$status);

{Design:
{For a labeled tape, the following attributes may be changed after labels are read:
{Block Type, Character Conversion, Character Set, Maximum Block Length, Maximum
{Record Length, Padding Character, and Record Type.
{
{For any file_label_type, the values of the 7 attributes above may be changed on each
{open via the default_creation and mandated attribute parameters of FSP$OPEN_FILE, via
{CHATLA, or via SETFA.  Block Type and Record Type are in the instance attributes.
{
{All but Block Type and Record Type are stored in LABELED_TAPE_STATE_INFO.  The values
{of the 5 attributes are initially stored here.  For a labeled tape, the 7 attributes
{defined in the HDR2 label are processed later in the OPEN process after labels are
{read.  Block Type and Record Type are updated in the instance attributes and the
{other 5 are stored in LABELED_TAPE_STATE_INFO.  This allows AMP$FETCH to return the
{correct values.

      CONST
        fw = 1;

      CONST
        ta_cc = 1,
        ta_cs = 2,
        ta_mbl = 3,
        ta_mrl = 4,
        ta_pc = 5;

      VAR
        call_block: amt$call_block,
        fetch_attribute: array [fw .. fw] of amt$fetch_item,
        file_access_options: fst$file_access_options,
        returned_attributes: fst$tla_returned_attributes,
        tape_attachments: ^array [ta_cc .. ta_pc] of fst$attachment_option;

      status.normal := TRUE;

      fetch_attribute [fw].key := amc$forced_write;

      call_block.operation := amc$fetch_req;
      call_block.fetch.file_attributes := ^fetch_attribute;
      bap$fap_control (file_identifier, call_block, global_layer_number, status);

      IF status.normal THEN
        tape_descriptor^.forced_write := fetch_attribute [fw].forced_write <> amc$unforced;

        state_info^ := bav$labeled_tape_state_info;

        PUSH tape_attachments;

        tape_attachments^ [ta_cc].selector := fsc$tape_attachment;
        tape_attachments^ [ta_cc].tape_attachment.selector := fsc$tape_character_conversion;
        tape_attachments^ [ta_cs].selector := fsc$tape_attachment;
        tape_attachments^ [ta_cs].tape_attachment.selector := fsc$tape_character_set;
        tape_attachments^ [ta_mbl].selector := fsc$tape_attachment;
        tape_attachments^ [ta_mbl].tape_attachment.selector := fsc$tape_max_block_length;
        tape_attachments^ [ta_mrl].selector := fsc$tape_attachment;
        tape_attachments^ [ta_mrl].tape_attachment.selector := fsc$tape_max_record_length;
        tape_attachments^ [ta_pc].selector := fsc$tape_attachment;
        tape_attachments^ [ta_pc].tape_attachment.selector := fsc$tape_padding_character;

        fsp$get_tape_label_attributes (file_instance^.local_file_name, fsc$tla_next_position,
              tape_attachments^, returned_attributes, status);

        IF status.normal THEN
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: NEXT_POSITION GETTLA status normal');
          IF fsc$tape_character_conversion IN returned_attributes THEN
            IF state_info^.character_conversion THEN
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Storing TRUE for Character Conversion');
            ELSE
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Storing FALSE for Character Conversion');
            IFEND;
            state_info^.character_conversion := tape_attachments^ [ta_cc].tape_attachment.
                  tape_character_conversion;
          IFEND;

          IF fsc$tape_character_set IN returned_attributes THEN
            state_info^.character_set := tape_attachments^ [ta_cs].tape_attachment.tape_character_set;
            CASE state_info^.character_set OF
            = amc$ascii =
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Storing ASCII for Character Set');
            = amc$ebcdic =
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Storing EBCDIC for Character Set');
            ELSE
              rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Storing OTHER Character Set=',
                    $INTEGER (state_info^.character_set));
            CASEND;
          IFEND;

          IF fsc$tape_max_block_length IN returned_attributes THEN
            state_info^.maximum_block_length:= tape_attachments^ [ta_mbl].tape_attachment.
                  tape_max_block_length;
            rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Stored MAXBL=',
                    state_info^.maximum_block_length);
          IFEND;

          IF fsc$tape_max_record_length IN returned_attributes THEN
            state_info^.maximum_record_length:= tape_attachments^ [ta_mrl].tape_attachment.
                  tape_max_record_length;
            rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Stored MAXRL=',
                    state_info^.maximum_record_length);
          IFEND;

          IF fsc$tape_padding_character IN returned_attributes THEN
            state_info^.padding_character:= tape_attachments^ [ta_pc].tape_attachment.
                  tape_padding_character;
          IFEND;

          gfi^.max_data_size := state_info^.maximum_block_length;
          gfi^.max_block_size := state_info^.maximum_block_length;
          gfi^.max_record_length := state_info^.maximum_record_length;
          gfi^.padding_character := state_info^.padding_character;

          IF file_instance^.instance_attributes.static_label.block_type = amc$system_specified THEN
            IF (tape_descriptor^.file_label_type = amc$labeled) OR
                  (($pft$usage_selections [pfc$shorten, pfc$append] * dynamic_label^.access_mode) <>
                  ($pft$usage_selections [])) THEN
              rmp$log_debug_integer ('LABELED_TAPE_DEBUG: REQUESTED_DENSITY=',
                    $INTEGER (tape_descriptor^.requested_density));
              IF tape_descriptor^.requested_density = rmc$38000 THEN
                rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting GFI max block size to 32640');
                gfi^.max_data_size := 32640;
                gfi^.max_block_size := 32640;
                state_info^.maximum_block_length := 32640;
              ELSE
                rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting GFI max block size to 4128');
                gfi^.max_data_size := 4128;
                gfi^.max_block_size := 4128;
                state_info^.maximum_block_length := 4128;
              IFEND;
            IFEND;
          IFEND;

          IF tape_descriptor^.file_label_type = amc$labeled THEN
            CASE dynamic_label^.open_position OF
            = amc$open_at_bop, amc$open_no_positioning =
              amp$set_file_instance_abnormal (file_identifier, ame$improper_open_position,
                    call_block.operation, '', status);
              RETURN;
            ELSE
            CASEND;
            #UNCHECKED_CONVERSION (dynamic_label^.access_mode, file_access_options);
            sl_store_authorized_access (file_access_options, status);
          IFEND;
        IFEND;
      IFEND;
    PROCEND initialize_tape_tables;
?? OLDTITLE ??
?? EJECT ??
    VAR
      block_position: bat$block_position,
      current_block_length: amt$working_storage_length,
      error_action: bat$error_actions,
      file_position: amt$file_position,
      os_status: ost$error,
      request_status: ost$status,
      residual_skip_count: amt$skip_count,
      temp_call_block: amt$call_block,
      tape_failure_modes: amt$tape_failure_modes;

  /main_program/
    BEGIN

      status.normal := TRUE;
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering OPEN_REQ');

      initialize_tape_tables (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
{
{ Initiate the tape block manager for this file.
{

      REPEAT
        osp$establish_block_exit_hndlr (^bai$open_blk_xt_hndlr);
        IF tape_descriptor^.tape_attachment_information.volume_initialization THEN
          sl_setup_volume_initialization (status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;

        IF (tape_descriptor^.volume_number = 1) AND (tape_descriptor^.volume_position = amc$bov) AND
           (tape_descriptor^.initial_volume.initial_read_labels_attempt) THEN
          CASE tape_descriptor^.file_label_type OF
          = amc$unlabeled, amc$non_standard_labeled =
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling SL_PREAUTHORIZE_ACCESS_METHOD - unlabeled');
            sl_preauthorize_access_method (file_identifier, tape_descriptor^.file_label_type, status);
          ELSE
          CASEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        bap$tape_bm_open (file_identifier, gfi^.max_data_size, request_status);
        osp$disestablish_cond_handler;
        tape_failure_modes := $amt$tape_failure_modes [ ];
        bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
              error_action, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      UNTIL error_action <> bac$retry_last_request;

      CASE tape_descriptor^.file_label_type OF

      = amc$unlabeled =
        IF (tape_descriptor^.volume_number = 1) AND (tape_descriptor^.volume_position = amc$bov) AND
           (tape_descriptor^.initial_volume.initial_read_labels_attempt) THEN
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling SL_AUTHORIZE_ACCESS_METHOD - unlabeled');
          sl_authorize_access_method (file_identifier, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        CASE dynamic_label^.open_position OF
        = amc$open_no_positioning =

          IF (block_info^.block_position = bac$middle_of_block) OR
                ((gfi^.positioning_info.record_info.file_position = amc$mid_record)
                AND (record_headers_exist)) THEN

{   Re-read the last block such that logical position is maintained

            REPEAT

              bap$tape_bm_skip_blocks (file_identifier, amc$backward, 1, residual_skip_count,
                    tape_failure_modes, request_status);

              bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
                    error_action, status);
              IF error_action = bac$exit_procedure THEN
                EXIT /main_program/;
              IFEND;
              tape_descriptor^.get_tape_block_buffer := NIL;

            UNTIL error_action = bac$continue;

{   Decrement block number to account for backspace

            IF block_info^.block_number > 1 THEN
              block_info^.block_number := block_info^.block_number - 1;
            ELSE
              tape_descriptor^.volume_position := amc$bov;
            IFEND;

            get_block (file_identifier, operation, NIL, gfi^.max_data_size, tape_descriptor^.
                  get_tape_block_buffer, error_action, block_position, current_block_length,
                  tape_descriptor^.volume_position, status);

            IF (error_action = bac$exit_procedure) OR NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

{   Reset record_header_fba to byte offset relative to segment.

            IF record_headers_exist AND (tape_descriptor^.get_tape_block_buffer <> NIL) THEN
              gfi^.positioning_info.record_info.record_header_fba :=
                      #OFFSET (tape_descriptor^.get_tape_block_buffer) +
                      gfi^.positioning_info.record_info.record_header_fba;
            IFEND;

          ELSE
            tape_descriptor^.get_tape_block_buffer := NIL;
            tape_descriptor^.put_tape_block_buffer := NIL;
            tape_descriptor^.last_data_operation := amc$open_req;
          IFEND;

        = amc$open_at_eoi =
          temp_call_block.operation := amc$skip_req;
          temp_call_block.skp.unit := amc$skip_tape_mark {amc$skip_block} ;
          temp_call_block.skp.count := 1;
          temp_call_block.skp.direction := amc$forward;
          temp_call_block.skp.file_position := ^file_position;
          skip_req (file_identifier, temp_call_block, status);
          IF NOT status.normal AND (status.condition = ame$skip_encountered_eoi) THEN
            status.normal := TRUE;
            file_instance^.residual_skip_count := 0;
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Unlabeled - Setting AT_EOI to TRUE');
            tape_descriptor^.at_eoi := TRUE;
          IFEND;
          tape_descriptor^.last_data_operation := amc$open_req;

        = amc$open_at_boi =

          rewind_tape (file_identifier, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
          tape_descriptor^.last_data_operation := amc$open_req;

        ELSE
          amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction, operation,
            'Unknown open_position in open_req (lrt fap)', status);
        CASEND;
      = amc$labeled =

        sl_open_label_file (file_identifier, call_block, layer_number, file_instance^.
              local_file_name, status);
        tape_descriptor^.rewind_file_command := FALSE;
        tape_descriptor^.get_tape_block_buffer := NIL;
        tape_descriptor^.put_tape_block_buffer := NIL;
        tape_descriptor^.last_data_operation := amc$open_req;

      = amc$non_standard_labeled =
        IF (tape_descriptor^.volume_number = 1) AND (tape_descriptor^.volume_position = amc$bov) AND
           (tape_descriptor^.initial_volume.initial_read_labels_attempt) THEN
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling SL_AUTHORIZE_ACCESS_METHOD - non standard');
          sl_authorize_access_method (file_identifier, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

{
{ Always open ASIS.
{
        tape_descriptor^.get_tape_block_buffer := NIL;
        tape_descriptor^.put_tape_block_buffer := NIL;
        tape_descriptor^.last_data_operation := amc$open_req;

      ELSE
        amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction, operation,
          'Unknown file_label_type in open_req (lrt fap)', status);
      CASEND;

      state_info^.translated_record_padding_char := state_info^.padding_character;
      IF (state_info^.character_set = amc$ebcdic) AND
         (state_info^.character_conversion = TRUE) THEN
        osp$translate_bytes (^state_info^.translated_block_padding_char, 1, ^state_info^.
              translated_block_padding_char, 1, ^osv$ascii_to_ebcdic, os_status);
        osp$translate_bytes (^state_info^.translated_record_padding_char, 1, ^state_info^.
              translated_record_padding_char, 1, ^osv$ascii_to_ebcdic, os_status);
      IFEND;

    END /main_program/;

    IF NOT status.normal THEN
      bap$tape_bm_close (file_identifier, tape_failure_modes, request_status);
      bap$close (file_identifier, request_status);
    IFEND;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting OPEN_REQ');

  PROCEND open_req;
?? OLDTITLE ??
?? NEWTITLE := '  put_data', EJECT ??

  PROCEDURE put_data (file_identifier: amt$file_identifier;
        operation: amt$fap_operation;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
        term_option: amt$term_option;
        terminate_previous_record: boolean;
        convert_if_ebcdic: boolean;
    VAR status: ost$status);

    VAR
      buffer_ptr: ^bat$tape_block,
      convert_data_to_ebcdic: boolean,
      current_block_byte_address: amt$file_byte_address,
      current_block_length: amt$working_storage_length,
      data_already_moved: boolean,
      error_action: bat$error_actions,
      block_position: bat$block_position,
      force_immediate_write: boolean,
      i : integer,
      os_status: ost$error,
      padding_character : amt$padding_character,
      request_status: ost$status,
      residual_block_length: 0 .. amc$maximum_block - 1,
      system_media_recovery: boolean,
      tape_error_options: amt$tape_error_options,
      tape_failure_modes: amt$tape_failure_modes,
      temp_wsa : ^array [1 .. amc$maximum_block - 1] of char,
      wsa: ^cell,
      wsl: amt$working_storage_length;

  /main_program/
    BEGIN


      status.normal := TRUE;
      block_position := block_info^.block_position;
      wsa := working_storage_area;
      wsl := working_storage_length;
      current_block_length := block_info^.current_block_length;
      current_block_byte_address := block_info^.current_block_byte_address;
      padding_character := state_info^.translated_block_padding_char;
      convert_data_to_ebcdic:= (state_info^.character_set = amc$ebcdic) AND state_info^.character_conversion
          AND convert_if_ebcdic;
      data_already_moved := FALSE;

{
{ Fetch the tape error options.
{

      bai$fetch_tape_error_options (tape_error_options, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      system_media_recovery := tape_error_options.perform_failure_recovery;

{
{ Set forced write attribute.
{

      force_immediate_write := tape_descriptor^.forced_write;

      IF tape_descriptor^.volume_position <> amc$after_data_block THEN
        block_info^.block_number := 1;
      IFEND;

      IF terminate_previous_record THEN
        IF bai$partial_block_exists () THEN

{
{ Write previous record.
{

          IF pad_blocks AND (current_block_length < gfi^.min_block_length) THEN
            temp_wsa := ^tape_descriptor^.put_tape_block_buffer^ [current_block_byte_address + 1];
            FOR i := 1 TO (gfi^.min_block_length - current_block_length) DO
              temp_wsa^ [i] := padding_character;
            FOREND;
            current_block_length := gfi^.min_block_length;
            current_block_byte_address := gfi^.min_block_length;
          IFEND;

          REPEAT
            bap$tape_bm_write_next_block (file_identifier, tape_descriptor^.put_tape_block_buffer,
                  current_block_length, system_media_recovery, force_immediate_write,
                  tape_failure_modes, request_status);

            bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
                  error_action, status);
            IF error_action = bac$exit_procedure THEN
              EXIT /main_program/;
            IFEND;
          UNTIL error_action <> bac$retry_last_request;
          tape_descriptor^.put_tape_block_buffer := NIL;
          IF tape_descriptor^.volume_position = amc$after_data_block THEN
            block_info^.block_number := block_info^.block_number + 1;
          IFEND;
          tape_descriptor^.labeled_volume_position := bac$lvp_within_ansi_file;
          tape_descriptor^.volume_position := amc$after_data_block;
        IFEND;
        block_position := bac$beginning_of_block;
        current_block_byte_address := 0;
        current_block_length := 0;

{
{ A zero length transfer will close out the current record, while
{ transfering no data.
{

        IF wsl = 0 THEN
          block_position := bac$beginning_of_block;
          EXIT /main_program/;
        IFEND;
      IFEND;
      residual_block_length := gfi^.max_data_size - current_block_byte_address;

{ Check if possible direct IO. If so and the data is to be converted, a buffer must be
{ reserved and the data converted from the user buffer to the block manager buffer.

      IF ((convert_data_to_ebcdic) AND (block_position <> bac$middle_of_block) AND
            (term_option = amc$terminate)) THEN

        IF wsl > residual_block_length THEN
          amp$set_file_instance_abnormal (file_identifier, ame$record_exceeds_mbl, operation, ' ', status);
          EXIT /main_program/;
        IFEND;

        REPEAT
          bap$tape_bm_reserve_blk_buffer (file_identifier, tape_descriptor^.put_tape_block_buffer,
                tape_failure_modes, request_status);
          bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
                error_action, status);
          IF error_action = bac$exit_procedure THEN
            EXIT /main_program/;
          IFEND;
        UNTIL error_action <> bac$retry_last_request;

        osp$translate_bytes (wsa, wsl, tape_descriptor^.put_tape_block_buffer, wsl,
              ^osv$ascii_to_ebcdic, os_status);
        block_position := bac$middle_of_block;
        current_block_length := wsl;
        current_block_byte_address := wsl;
        data_already_moved := TRUE;
      IFEND;

      CASE term_option OF
      = amc$start =

        IF block_position = bac$middle_of_block THEN
          IF NOT terminate_previous_record THEN
            amp$set_file_instance_abnormal (file_identifier, 0, operation, 'lrt fap: illegal combination of f'
              CAT 'ile_postion = mid_record, terminate_previous_record = FALSE, and term_option = start',
                status);
            RETURN;
          IFEND;
        IFEND;
        residual_block_length := gfi^.max_data_size;
        IF wsl > residual_block_length THEN
          amp$set_file_instance_abnormal (file_identifier, ame$record_exceeds_mbl, operation, ' ', status);
          EXIT /main_program/;
        IFEND;

        REPEAT
          bap$tape_bm_reserve_blk_buffer (file_identifier, tape_descriptor^.put_tape_block_buffer,
                tape_failure_modes, request_status);
          bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
                error_action, status);
          IF error_action = bac$exit_procedure THEN
            EXIT /main_program/;
          IFEND;
        UNTIL error_action <> bac$retry_last_request;

        IF convert_data_to_ebcdic THEN
          osp$translate_bytes (wsa, wsl, tape_descriptor^.put_tape_block_buffer, wsl,
                ^osv$ascii_to_ebcdic, os_status);
        ELSE
          i#move (wsa, tape_descriptor^.put_tape_block_buffer, wsl);
        IFEND;
        block_position := bac$middle_of_block;
        current_block_length := wsl;
        current_block_byte_address := wsl;
      = amc$continue =

        IF block_position <> bac$middle_of_block THEN
          amp$set_file_instance_abnormal (file_identifier, ame$improper_continue, operation, ' ', status);
          EXIT /main_program/;
        IFEND;
        IF tape_descriptor^.put_tape_block_buffer = NIL THEN
          amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction, operation,
            'Put block buffer = NIL in put_data', status);
          EXIT /main_program/;
        IFEND;

        IF wsl > residual_block_length THEN
          amp$set_file_instance_abnormal (file_identifier, ame$record_exceeds_mbl, operation, ' ', status);
          EXIT /main_program/;
        IFEND;

        buffer_ptr := ^tape_descriptor^.put_tape_block_buffer^ [current_block_byte_address + 1];
        IF convert_data_to_ebcdic THEN
          osp$translate_bytes (wsa, wsl, buffer_ptr, wsl,
                ^osv$ascii_to_ebcdic, os_status);
        ELSE
          i#move (wsa, buffer_ptr, wsl);
        IFEND;

        current_block_length := current_block_length + wsl;
        current_block_byte_address := current_block_byte_address + wsl;
      = amc$terminate =

        IF wsl > residual_block_length THEN
          amp$set_file_instance_abnormal (file_identifier, ame$record_exceeds_mbl, operation, ' ', status);
          EXIT /main_program/;
        IFEND;

        IF block_position = bac$middle_of_block THEN
          IF tape_descriptor^.put_tape_block_buffer <> NIL THEN
            IF NOT data_already_moved THEN
              buffer_ptr := ^tape_descriptor^.put_tape_block_buffer^ [current_block_byte_address + 1];
              IF convert_data_to_ebcdic THEN
                osp$translate_bytes (wsa, wsl, buffer_ptr, wsl,
                      ^osv$ascii_to_ebcdic, os_status);
              ELSE
                i#move (wsa, buffer_ptr, wsl);
              IFEND;
              current_block_length := current_block_length + wsl;
            IFEND;

            IF pad_blocks AND (current_block_length < gfi^.min_block_length) THEN
              temp_wsa := ^tape_descriptor^.put_tape_block_buffer^ [current_block_byte_address + wsl + 1];
              FOR i := 1 TO (gfi^.min_block_length - current_block_length) DO
                temp_wsa^ [i] := padding_character;
              FOREND;
              current_block_length := gfi^.min_block_length;
              current_block_byte_address := gfi^.min_block_length;
            IFEND;

            REPEAT
              bap$tape_bm_write_next_block (file_identifier, tape_descriptor^.put_tape_block_buffer,
                    current_block_length, system_media_recovery, force_immediate_write, tape_failure_modes,
                    request_status);
              bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
                    error_action, status);
              IF error_action = bac$exit_procedure THEN
                IF NOT status.normal and (status.condition = ame$end_of_tape_op_inhibited) THEN
                  current_block_length := block_info^.current_block_length;
                  current_block_byte_address := block_info^.current_block_byte_address;
                IFEND;
                EXIT /main_program/;
              IFEND;
            UNTIL error_action <> bac$retry_last_request;
            IF tape_descriptor^.volume_position = amc$after_data_block THEN
              block_info^.block_number := block_info^.block_number + 1;
            IFEND;
            tape_descriptor^.labeled_volume_position := bac$lvp_within_ansi_file;
            tape_descriptor^.volume_position := amc$after_data_block;
            tape_descriptor^.put_tape_block_buffer := NIL;
            block_position := bac$beginning_of_block;
            current_block_byte_address := 0;
            current_block_length := 0;
          ELSE
            amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction, operation,
              'Put block buffer = NIL and block_position = bac$middle_of_block in put_data.', status);
          IFEND;
        ELSE

          REPEAT
            bap$tape_bm_write_next_block (file_identifier, wsa, wsl, system_media_recovery,
                  force_immediate_write, tape_failure_modes, request_status);
            bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
                  error_action, status);
            IF error_action = bac$exit_procedure THEN
              EXIT /main_program/;
            IFEND;
          UNTIL error_action <> bac$retry_last_request;
          IF tape_descriptor^.volume_position = amc$after_data_block THEN
            block_info^.block_number := block_info^.block_number + 1;
          IFEND;
          tape_descriptor^.labeled_volume_position := bac$lvp_within_ansi_file;
          tape_descriptor^.volume_position := amc$after_data_block;
          tape_descriptor^.put_tape_block_buffer := NIL;
          block_position := bac$beginning_of_block;
          current_block_byte_address := 0;
          current_block_length := 0;
        IFEND;
      ELSE
        amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction, operation,
          'Improper term_option in put_data.', status);
      CASEND;

    END /main_program/;

    block_info^.block_position := block_position;
    block_info^.current_block_length := current_block_length;
    block_info^.current_block_byte_address := current_block_byte_address;
    block_info^.residual_block_length := gfi^.max_data_size - current_block_byte_address;

  PROCEND put_data;
?? OLDTITLE ??
?? NEWTITLE := '  rewind_req', EJECT ??

{
{ The purpose of this request is to rewind a tape file to the beginning
{ of information.  The tape rewind interface is called to invoke the
{ physical repositioning of the tape.
{

  PROCEDURE rewind_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      error_action: bat$error_actions,
      request_status: ost$status,
      file_position: amt$file_position,
      tape_failure_modes: amt$tape_failure_modes;

    status.normal := TRUE;

  /main_program/
    BEGIN

{
{ Check file position to see if any partial blocks need to be written out.
{

      IF bai$partial_block_exists () THEN
        bai$write_previous_block (file_identifier, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF tape_descriptor^.file_label_type = amc$labeled THEN
        sl_rewind_ansi_file (file_identifier, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      ELSE
        rewind_tape (file_identifier, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

    END /main_program/;

  PROCEND rewind_req;
?? OLDTITLE ??
?? NEWTITLE := '  rewind_tape', EJECT ??

  PROCEDURE rewind_tape (file_identifier: amt$file_identifier;
    VAR status: ost$status);

    VAR
      error_action: bat$error_actions,
      request_status: ost$status,
      tape_failure_modes: amt$tape_failure_modes;

    status.normal := TRUE;

    REPEAT
      bap$tape_bm_rewind (file_identifier, tape_failure_modes, request_status);
      bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
            error_action, status);
      IF error_action = bac$exit_procedure THEN
        RETURN;
      IFEND;
    UNTIL error_action <> bac$retry_last_request;

    bai$init_boi_tape_position;

  PROCEND rewind_tape;
?? OLDTITLE ??
?? NEWTITLE := '  switch_from_read_to_write', EJECT ??

  PROCEDURE switch_from_read_to_write (file_identifier: amt$file_identifier;
    VAR status: ost$status);

    VAR
      error_action: bat$error_actions,
      request_status: ost$status,
      tape_failure_modes: amt$tape_failure_modes;

    status.normal := TRUE;

    bap$tape_bm_read_to_write (file_identifier, tape_descriptor^.get_tape_block_buffer,
          tape_descriptor^.put_tape_block_buffer, tape_failure_modes, request_status);
    bai$process_request_status (file_identifier, operation, request_status,
          tape_failure_modes, error_action, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF tape_descriptor^.put_tape_block_buffer <> NIL THEN
      block_info^.residual_block_length := gfi^.max_data_size -
            block_info^.current_block_byte_address;
      block_info^.current_block_length := block_info^.
            current_block_byte_address;
      IF block_info^.block_number > 1 THEN
        block_info^.block_number := block_info^.block_number - 1;
      ELSE
        tape_descriptor^.volume_position := amc$bov;
      IFEND;
    ELSE {previous read buffer had unrecovered error data in it}
      block_info^.block_position := bac$beginning_of_block;
    IFEND;

    tape_descriptor^.get_tape_block_buffer := NIL;

  PROCEND switch_from_read_to_write;
?? OLDTITLE ??
?? NEWTITLE := '  validate_skip_parameters', EJECT ??

  PROCEDURE validate_skip_parameters (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        skip_partitions_valid: boolean;
        skip_partitions_back_valid: boolean;
        skip_records_valid: boolean;
        skip_records_back_valid: boolean;
    VAR status: ost$status);

    status.normal := TRUE;
    call_block.skp.file_position^ := gfi^.positioning_info.record_info.file_position;

    IF (call_block.skp.count < 0) OR (call_block.skp.count > UPPERVALUE (amt$skip_count)) THEN
      amp$set_file_instance_abnormal (file_identifier, ame$improper_skip_count,
            operation, '', status);
      RETURN;
    IFEND;

    file_instance^.residual_skip_count := call_block.skp.count;

    CASE call_block.skp.unit OF

    = amc$skip_partition =

      IF NOT skip_partitions_valid THEN
        amp$set_file_instance_abnormal (file_identifier, ame$unsupported_skip,
              operation, 'PARTITIONS', status);
        RETURN;
      IFEND;

      CASE call_block.skp.direction OF
      = amc$forward =
        ;
      = amc$backward =
        IF NOT skip_partitions_back_valid THEN
          amp$set_file_instance_abnormal (file_identifier, ame$unsupported_skip,
                operation, 'BACKWARD PARTITIONS', status);
          RETURN;
        IFEND;
      ELSE
        amp$set_file_instance_abnormal (file_identifier, ame$improper_skip_direction,
              operation, 'PARTITIONS', status);
        RETURN;
      CASEND;

    = amc$skip_record =

      IF NOT skip_records_valid THEN
        amp$set_file_instance_abnormal (file_identifier, ame$unsupported_skip,
              operation, 'RECORDS', status);
        RETURN;
      IFEND;

      CASE call_block.skp.direction OF
      = amc$forward =
        ;
      = amc$backward =
        IF NOT skip_records_back_valid THEN
          amp$set_file_instance_abnormal (file_identifier, ame$unsupported_skip,
                operation, 'BACKWARD RECORDS', status);
          RETURN;
        IFEND;
      ELSE
        amp$set_file_instance_abnormal (file_identifier, ame$improper_skip_direction,
              operation, 'RECORDS', status);
        RETURN;
      CASEND;

    = amc$skip_tape_mark =

      IF tape_descriptor^.file_label_type = amc$labeled THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_labelled_skip_unit,
              operation, '', status);
        RETURN;
      IFEND;

      CASE call_block.skp.direction OF
      = amc$forward, amc$backward =
        ;
      ELSE
        amp$set_file_instance_abnormal (file_identifier, ame$improper_skip_direction,
              operation, 'TAPEMARKS', status);
        RETURN;
      CASEND;

    ELSE

      amp$set_file_instance_abnormal (file_identifier, ame$improper_skip_unit,
            operation, '', status);
      RETURN;

    CASEND;

    IF tape_descriptor^.file_label_type = amc$labeled THEN
      IF call_block.skp.direction = amc$backward THEN
        IF state_info^.put_op OR state_info^.eoi_labels_needed THEN
          rmp$log_debug_message ('Calling SL_PUT_END_OF_FILE_LABELS from VALIDATE_SKIP_PARAMETERS');
          sl_put_end_of_file_labels (file_identifier, status);
          IF status.normal THEN
            sl_enable_read_after_write (file_identifier, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
          {   HDR1 HDR2* data * EOF1 EOF2* * *
          {                               ^
          sl_advance_tapemark (file_identifier, amc$backward, 2, status);
          {   HDR1 HDR2* data * EOF1 EOF2* * *
          {                  ^
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        state_info^.put_op := FALSE;
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting LVP to within ansi file - skipb');
        tape_descriptor^.labeled_volume_position := bac$lvp_within_ansi_file;
        file_instance^.previous_get_at_eoi := FALSE;

      ELSE  { direction = forward  }

        IF state_info^.put_op OR state_info^.eoi_labels_needed THEN
          rmp$log_debug_message ('Calling SL_PUT_END_OF_FILE_LABELS from VALIDATE_SKIP_PARAMETERS');
          sl_put_end_of_file_labels (file_identifier, status);
          IF status.normal THEN
            sl_enable_read_after_write (file_identifier, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          state_info^.put_op := FALSE;
        IFEND;

        IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
          call_block.skp.file_position^ := amc$eoi;
          gfi^.positioning_info.record_info.file_position := amc$eoi;
          gfi^.positioning_info.record_info.record_length := 0;
          gfi^.positioning_info.record_info.residual_record_length := 0;
          gfi^.positioning_info.record_info.transfer_count := 0;
          IF call_block.skp.count = 0 THEN
            RETURN;
          IFEND;
          IF call_block.skp.unit = amc$skip_record THEN
            amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi,
              operation, 'RECORDS', status);
          ELSE { call_block.skp.unit = amc$skip_partition
            amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi,
              operation, 'PARTITIONS', status);
          IFEND;
          RETURN;
        IFEND;
      IFEND;
    IFEND;

  PROCEND validate_skip_parameters;
?? OLDTITLE ??
?? NEWTITLE := '  write_tape_mark_req', EJECT ??

  PROCEDURE write_tape_mark_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      error_action: bat$error_actions,
      force_immediate_write: boolean,
      request_status: ost$status,
      system_media_recovery: boolean,
      tape_error_options: amt$tape_error_options,
      tape_failure_modes: amt$tape_failure_modes;

  /main_program/
    BEGIN

      status.normal := TRUE;
      bai$fetch_tape_error_options (tape_error_options, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      system_media_recovery := tape_error_options.perform_failure_recovery;

      force_immediate_write := tape_descriptor^.forced_write;

{
{ Check file position to see if any partial blocks need to be written out.
{

      IF bai$partial_block_exists () THEN
        bai$write_previous_block (file_identifier, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      REPEAT
        bap$tape_bm_write_tapemark (file_identifier, system_media_recovery, force_immediate_write,
              tape_failure_modes, request_status);

        bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
              error_action, status);
        IF error_action = bac$exit_procedure THEN
          EXIT /main_program/;
        IFEND;

        CASE tape_descriptor^.file_label_type OF
        = amc$unlabeled =
          IF NOT request_status.normal AND (request_status.condition = bae$vol_end_operation_completed) THEN

{
{ Curious situation for unlabeled tapes.
{
{   Have just completed writing the tapemark, however some requests will force
{   an advance volume request.  This will write two more tapemarks before
{   advancing, leaving three tapemarks at the end of the current volume.
{   When reading, the first two tapemarks will be interpreted as end of volume,
{   and the third tapemark will be lost.  Therefore, the write tapemark request
{   needs to be reissued.
{

            error_action := bac$retry_last_request;

          IFEND;

        = amc$labeled, amc$non_standard_labeled =

{
{ To be determined.
{

        ELSE
          amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction, operation,
            'Unknown label_type in write_tape_mark_req.', status);
        CASEND;

      UNTIL error_action <> bac$retry_last_request;

    END /main_program/;

    tape_descriptor^.volume_position := amc$after_tapemark;

  PROCEND write_tape_mark_req;
?? OLDTITLE ??
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$label_validation_errors
*copyc fsd$ansi_label_identifiers
*copyc fst$ansi_eof1_label
*copyc fst$ansi_eof2_label
*copyc fst$ansi_eov1_label
*copyc fst$ansi_eov2_label
*copyc fst$ansi_hdr1_label
*copyc fst$ansi_hdr2_label
*copyc fst$ansi_vol1_label
*copyc fst$tape_security_call_block
?? POP ??
*copyc amp$access_method
*copyc amp$set_local_name_abnormal
*copyc avp$removable_media_admin
*copyc bap$after_trailer_labels
*copyc bap$change_tape_bt_and_rt
*copyc bap$free_tape_label_sequences
*copyc bap$get_phn_via_file_id
*copyc bap$get_tape_security_state
*copyc bap$next_position_is_bos
*copyc bap$store_unsecured_tape_labels
*copyc bap$tape_bm_write_label_mark
*copyc bav$labeled_tape_state_info
*copyc clp$convert_integer_to_string
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_string_to_integer
*copyc clp$get_fs_path_elements
*copyc cmp$get_logical_unit_number_r3
*copyc dmp$setup_tape_init_in_progress
*copyc dmp$validate_tape_element
*copyc fsp$get_tape_label_attributes
*copyc fsp$locate_tape_label
*copyc fsp$path_element
*copyc fsp$file_header_labels
*copyc fsp$file_trailer_labels
*copyc fsp$header_labels
*copyc fsp$trailer_labels
*copyc fsp$ve_wrote_ansi_file
*copyc fsp$version_one_tape_label
*copyc fsp$volume_header_labels
*copyc fsp$volume_trailer_labels
*copyc i#move
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$generate_error_message
*copyc osp$generate_log_message
*copyc osp$set_status_condition
*copyc osp$translate_bytes
*copyc oss$task_private
*copyc osv$task_private_heap
*copyc pmp$get_date
*copyc rmp$classify_tape_volume
*copyc rmp$format_vol_classification
*copyc rmp$log_debug_integer
*copyc rmp$log_debug_message
*copyc rmp$log_debug_status
*copyc rmv$tape_debug_mode

  VAR
    bov_position: boolean;

  TYPE
    tape_attach_info_sources = set of fst$tape_attach_info_source;

  VAR
    tape_label_sources: [STATIC, READ, oss$job_paged_literal] tape_attach_info_sources :=
          [fsc$tape_label_attr_command, fsc$tape_open_tape_attachment, fsc$tape_hdr1_label,
          fsc$tape_hdr2_label];

?? NEWTITLE := '    sl_adjust_trailer_labels', EJECT ??

  PROCEDURE sl_adjust_trailer_labels
    (    file_identifier: amt$file_identifier;
         label_sequence: ^SEQ ( * );
         new_label_identifier: fst$ansi_label_identifier;
     VAR status: ost$status);

{Design: FSP$GET_TAPE_LABEL_ATTRIBUTES is used to build the trailer labels for the
{next position.  It always builds file trailer labels, i.e. * EOF1 EOF2 *.  The
{block_count in the EOF1 label is zero.  By ANSI standard, the EOF1 and EOV1 labels
{are identical as are the EOF2 and EOV2 labels.  This procedure stores the proper
{label identifier (EOF or EOV) for the label group we are writing and sets the block
{count to the physical block count for the current file or file section on the
{current volume.

    CONST
      write_mode = 'WRITTEN';

    VAR
      block_count: integer,
      buffered_blocks: bat$tape_block_buffer_count,
      eox1_label: ^fst$ansi_eof1_label,
      eox2_label: ^fst$ansi_eof2_label,
      label_identifier: fst$tape_label_identifier,
      label_locator: fst$tape_label_locator,
      trailer_labels: ^SEQ ( * );

    status.normal := TRUE;

    bap$tape_bm_unwritten_blk_count (file_identifier, buffered_blocks, status);
    IF status.normal THEN
      state_info^.buffered_blocks := buffered_blocks;
      IF state_info^.put_op THEN
        block_count := gfi^.positioning_info.block_info.block_number - state_info^.buffered_blocks;
      ELSE
        block_count := 0;
      IFEND;

      IF new_label_identifier = fsc$ansi_eof_label_identifier THEN
        sl_log_eof_block_count (block_count, write_mode);
      ELSE
        sl_log_eov_block_count (block_count, write_mode);
      IFEND;

      trailer_labels := label_sequence;
      RESET trailer_labels;
      label_identifier.location_method := fsc$tape_label_locate_by_kind;
      label_identifier.label_kind := fsc$ansi_eof1_label_kind;
      fsp$locate_tape_label (trailer_labels, label_identifier, label_locator);

      IF label_locator.label_found THEN
        RESET label_locator.label_block;
        NEXT eox1_label IN label_locator.label_block;
        eox1_label^.label_identifier := new_label_identifier;
        clp$convert_integer_to_rjstring (block_count, 10, FALSE, '0', eox1_label^.block_count, status);
        IF status.normal THEN
          label_identifier.location_method := fsc$tape_label_locate_by_kind;
          label_identifier.label_kind := fsc$ansi_eof2_label_kind;
          fsp$locate_tape_label (trailer_labels, label_identifier, label_locator);

          IF label_locator.label_found THEN
            RESET label_locator.label_block;
            NEXT eox2_label IN label_locator.label_block;
            eox2_label^.label_identifier := new_label_identifier;
          ELSE
            osp$set_status_condition (ame$label_not_in_sequence, status);
            osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, fsc$ansi_eof_label_identifier,
                  status);
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (ame$label_not_in_sequence, status);
        osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, fsc$ansi_eof_label_identifier, status);
      IFEND;
    IFEND;
  PROCEND sl_adjust_trailer_labels;

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

  PROCEDURE sl_advance_tapemark
    (    file_identifier: amt$file_identifier;
         direction: amt$skip_direction;
         count: amt$skip_count;
     VAR status: ost$status);

    VAR
      skip_call_block: amt$call_block;

    status.normal := TRUE;

    IF direction = amc$forward THEN
      rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Skipping forward tapemarks: ', count);
    ELSE
      rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Skipping backward tapemarks: ', count);
    IFEND;
    skip_call_block.operation := amc$skip_req;
    skip_call_block.skp.direction := direction;
    skip_call_block.skp.count := count;
    skip_call_block.skp.unit := amc$skip_tape_mark;
    amp$access_method (file_identifier, skip_call_block, global_layer_number, status);
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting AT_EOI to FALSE');
    tape_descriptor^.at_eoi := FALSE;
    bov_position := FALSE;

  PROCEND sl_advance_tapemark;
?? OLDTITLE ??
?? NEWTITLE := '    sl_advance_volume', EJECT ??

  PROCEDURE sl_advance_volume
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      label_group: fst$ansi_label_kinds,
      volume_position: amt$volume_position;

    status.normal := TRUE;

    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering SL_ADVANCE_VOLUME');
    bai$advance_volume (file_identifier, volume_position, status);
    rmp$log_debug_status (status);
    tape_descriptor^.volume_position := volume_position;
    IF volume_position = amc$mid_bov_label_group THEN
      bov_position := TRUE;
    ELSE
      bov_position := FALSE;
    IFEND;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_ADVANCE_VOLUME');

  PROCEND sl_advance_volume;
?? OLDTITLE ??
?? NEWTITLE := '    sl_authorize_access', EJECT ??
  PROCEDURE sl_authorize_access
    (    file_identifier: amt$file_identifier;
         label_group: fst$ansi_label_kinds;
         read_tape_labels_status: ost$status;
     VAR status: ost$status);

?? NEWTITLE := '    authorize_file_access', EJECT ??

    PROCEDURE authorize_file_access
      (VAR status: ost$status);

      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling AUTHORIZE_FILE_ACCESS');

      tape_security_call_block.operation := fsc$ts_authorize_file_access;
      tape_security_call_block.authorize_file_access.header_labels := last_accessed_header_labels;
      #UNCHECKED_CONVERSION (file_instance^.instance_attributes.dynamic_label.access_mode,
            file_access_options);
      tape_security_call_block.authorize_file_access.proposed_access := file_access_options;
      tape_security_call_block.authorize_file_access.proposed_access_defaulted :=
            (file_instance^.instance_attributes.dynamic_label.access_mode_source = amc$access_method_default);
      tape_security_call_block.authorize_file_access.authorized_access := ^authorized_access;

      sl_enforce_tape_security (file_identifier, tape_security_call_block, status);

      IF status.normal THEN
        sl_store_authorized_access (authorized_access, status);
      IFEND;
    PROCEND authorize_file_access;
?? OLDTITLE ??
?? NEWTITLE := '      classify_tape_volume', EJECT ??

    PROCEDURE classify_tape_volume
      (    file_identifier: amt$file_identifier;
           read_tape_labels_status: ost$status;
       VAR classification: rmt$tape_volume_classification;
       VAR status: ost$status);

{Design: It is not sufficient to judge a volume to be blank labeled solely on the
{ content of the volume header labels.  This procedure attempts to read beyond the
{ volume label group.  If a tapemark is encountered, as expected, the classification
{ is retained.  If more labels are encountered after the volume header labels, the
{ volume is considered damaged and access is restricted.  If data is encountered,
{ the volume is no longer considered blank.

      VAR
        backspace_count: 1 .. 2,
        call_block: amt$call_block,
        formatted_classification: ost$status_message,
        local_status: ost$status,
        read_tape_labels: amt$read_tape_labels;

      status.normal := TRUE;

      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering classify_tape_volume');
      rmp$classify_tape_volume (read_tape_labels_status, tape_descriptor^.last_accessed.
            unsecured_header_labels, classification, status);
      IF status.normal THEN
        IF rmv$tape_debug_mode THEN
          rmp$format_vol_classification ({max_message_line} 80, classification, formatted_classification,
                local_status);
          IF local_status.normal THEN
            log_volume_classification (formatted_classification);
          IFEND;
        IFEND;
        IF (classification.volume_label_type = rmc$labeled_volume_type) AND classification.labeled.blank THEN
          { VOL1 HDR1 HDR2 *
          {                 ^
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Initially classified labeled and blank');
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling read tape labels to see for sure');
          call_block.operation := amc$read_tape_labels;
          call_block.read_tape_labels := ^read_tape_labels;
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling FAP to read labels');
          amp$access_method (file_identifier, call_block, global_layer_number, local_status);
          rmp$log_debug_status (local_status);

          IF local_status.normal THEN {ERROR - missing a tapemark}
            { VOL1 HDR1 HDR2 * EOF1 EOF2 *  *
            {                             ^
            backspace_count := 2;
            classification.labeled.blank := FALSE;
            classification.labeled.volume_security_type := rmc$vst_access_restricted;
            classification.labeled.reason := rmc$excessive_tape_labels;
            rmp$log_debug_message ('Classified labeled, nonblank, damaged - missing tmk1');
          ELSE
            CASE local_status.condition OF
            = ame$invalid_tape_label =
              { VOL1 HDR1 HDR2 *  data
              {                        ^
              backspace_count := 1;
              classification.blank := FALSE;
              rmp$log_debug_message ('Classified labeled and nonblank');
            = ame$unexpected_tapemark =
              { VOL1 HDR1 HDR2 *  *
              {                    ^
              backspace_count := 2;

              rmp$log_debug_message ('Classified labeled and blank - retained original classification');
            = ame$excessive_tape_labels, ame$unexpected_tape_label, ame$tape_label_read_error =
            { VOL1 HDR1 HDR2 data blocks *
            {                             ^
              backspace_count := 1;
              classification.labeled.blank := FALSE;
              classification.labeled.volume_security_type := rmc$vst_access_restricted;
              classification.labeled.reason := rmc$excessive_tape_labels;
              rmp$log_debug_message ('Classified labeled, nonblank, damaged - missing tmk2');
            ELSE
            CASEND;
          IFEND;
          { VOL1 HDR1 HDR2 *
          {                 ^
          local_status.normal := TRUE;
          sl_advance_tapemark (file_identifier, amc$backward, backspace_count, local_status);
          { VOL1 HDR1 HDR2 *
          {               ^
          IF local_status.normal THEN
            sl_advance_tapemark (file_identifier, amc$forward, 1, local_status);
            { VOL1 HDR1 HDR2 *
            {                 ^
          IFEND;
        IFEND;
      IFEND;
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting classify_tape_volume');
    PROCEND classify_tape_volume;
?? OLDTITLE ??
?? NEWTITLE := '      log_volume_classification', EJECT ??

    PROCEDURE log_volume_classification
      (    formatted_message: ost$status_message);

      VAR
        line_count_p: ^ost$status_message_line_count,
        line_number: ost$status_message_line_count,
        line_size_p: ^ost$status_message_line_size,
        line_text_p: ^string ( * <= osc$status_message_width),
        lines: ost$status_message_line_count,
        local_status: ost$status,
        message_p: ^ost$status_message,
        tape_security_state : bat$tape_validation_state;

      message_p := ^formatted_message;
      RESET message_p;

      NEXT line_count_p IN message_p;
      IF line_count_p <> NIL THEN
        bap$get_tape_security_state (tape_security_state, local_status);
        IF local_status.normal AND (NOT avp$removable_media_admin ()) AND (tape_security_state =
              bac$tape_validation_on) THEN
          lines := 4;
        ELSE
          lines := line_count_p^;
        IFEND;
        FOR line_number := 1 TO lines DO
          NEXT line_size_p IN message_p;
          NEXT line_text_p: [line_size_p^] IN message_p;
          rmp$log_debug_message (line_text_p^);
        FOREND;
      IFEND;

    PROCEND log_volume_classification;
?? OLDTITLE, EJECT ??

    VAR
      authorized_access: fst$file_access_options,
      classification: rmt$tape_volume_classification,
      file_access_options: fst$file_access_options,
      file_set_access: fst$file_access_options,
      initial_vol_sequence: ^SEQ ( * ),
      initial_header_labels: ^SEQ ( * ),
      last_accessed_sequence: ^SEQ ( * ),
      last_accessed_header_labels: ^SEQ ( * ),
      sequence_header: ^fst$tape_label_sequence_header,
      tape_security_call_block: fst$tape_security_call_block;

    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering SL_AUTHORIZE_ACCESS');

    IF tape_descriptor^.initial_volume.header_labels <> NIL THEN
      initial_vol_sequence := tape_descriptor^.initial_volume.header_labels;
      RESET initial_vol_sequence;
      NEXT sequence_header IN initial_vol_sequence;
      PUSH initial_header_labels: [[REP sequence_header^.sequence_size OF cell]];
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Copying initial_header_labels');
      initial_header_labels^ := initial_vol_sequence^;
    ELSE
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Copying initial_header_labels=NIL');
      initial_header_labels := NIL;
    IFEND;

    IF tape_descriptor^.last_accessed.unsecured_header_labels <> NIL THEN
      last_accessed_sequence := tape_descriptor^.last_accessed.unsecured_header_labels;
      RESET last_accessed_sequence;
      NEXT sequence_header IN last_accessed_sequence;
      PUSH last_accessed_header_labels: [[REP sequence_header^.sequence_size OF cell]];
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Copying last_accessed_header_labels');
      last_accessed_header_labels^ := last_accessed_sequence^;
    ELSE
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Last_accessed_header_labels=NIL');
      last_accessed_header_labels := NIL;
    IFEND;

    IF fsp$volume_header_labels (label_group) OR (NOT read_tape_labels_status.normal) THEN
      classify_tape_volume (file_identifier, read_tape_labels_status, classification, status);
      IF status.normal THEN
        IF (tape_descriptor^.volume_number = 1) THEN
          {Ensure that invalid fields such as VOL1 II are not carried forth if labels are rewritten}
          bap$store_unsecured_tape_labels (last_accessed_header_labels, tape_descriptor^.initial_volume.
                header_labels);
          IF tape_descriptor^.initial_volume.initial_read_labels_attempt THEN
            tape_descriptor^.initial_volume.classification := classification;
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling AUTHORIZE_FILE_SET_MOUNT');
            tape_security_call_block.operation := fsc$ts_authorize_file_set_mount;
            tape_security_call_block.authorize_file_set_mount.access_method :=
                  tape_descriptor^.file_label_type;
            tape_security_call_block.authorize_file_set_mount.header_labels := initial_header_labels;
            #UNCHECKED_CONVERSION (file_instance^.instance_attributes.dynamic_label.access_mode,
                  file_access_options);
            tape_security_call_block.authorize_file_set_mount.proposed_access := file_access_options;
            tape_security_call_block.authorize_file_set_mount.proposed_access_defaulted :=
                  (file_instance^.instance_attributes.dynamic_label.access_mode_source =
                  amc$access_method_default);
            tape_security_call_block.authorize_file_set_mount.volume_classification :=
                  tape_descriptor^.initial_volume.classification;
            tape_security_call_block.authorize_file_set_mount.authorized_access := ^authorized_access;
            tape_security_call_block.authorize_file_set_mount.file_set_access := ^file_set_access;
            sl_enforce_tape_security (file_identifier, tape_security_call_block, status);
            IF status.normal THEN
              tape_descriptor^.initial_volume.access_modes := file_set_access;
              sl_store_authorized_access (authorized_access, status);
              tape_descriptor^.initial_volume.initial_read_labels_attempt := FALSE;
            IFEND;
          ELSEIF read_tape_labels_status.normal THEN
            authorize_file_access (status);
          ELSE
            status := read_tape_labels_status;
          IFEND;
        ELSEIF NOT (state_info^.put_op OR state_info^.eoi_labels_needed) THEN
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling AUTHORIZE_SECTION_READ');
          tape_security_call_block.operation := fsc$ts_authorize_section_read;
          tape_security_call_block.authorize_section_read.current_header_labels :=
                last_accessed_header_labels;
          tape_security_call_block.authorize_section_read.current_volume_classification := classification;
          tape_security_call_block.authorize_section_read.file_section_number :=
                tape_descriptor^.next_position.file_section_number;
          tape_security_call_block.authorize_section_read.file_sequence_number :=
                tape_descriptor^.next_position.file_sequence_number;
          tape_security_call_block.authorize_section_read.initial_volume_classification :=
                tape_descriptor^.initial_volume.classification;
          tape_security_call_block.authorize_section_read.initial_volume_header_labels :=
                initial_header_labels;
          sl_enforce_tape_security (file_identifier, tape_security_call_block, status);
        IFEND;
      IFEND;
    ELSE
      authorize_file_access (status);
    IFEND;
    IF (NOT status.normal) AND (NOT sl_irrelevant_condition (status)) THEN
      sl_tape_abnormal_termination (file_identifier);
    IFEND;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_AUTHORIZE_ACCESS');

  PROCEND sl_authorize_access;
?? OLDTITLE ??
?? NEWTITLE := '    sl_authorize_access_method', EJECT ??
  PROCEDURE sl_authorize_access_method
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      ignore_label_group: fst$ansi_label_kinds,
      ignore_status: ost$status;

    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering SL_AUTHORIZE_ACCESS_METHOD');
    status.normal := TRUE;
    sl_read_tape_labels (file_identifier, ignore_label_group, status);
    IF status.normal THEN
      rewind_tape (file_identifier, ignore_status);
    ELSE
      rmp$log_debug_status (status);
      sl_tape_abnormal_termination (file_identifier);
    IFEND;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_AUTHORIZE_ACCESS_METHOD');

  PROCEND sl_authorize_access_method;
?? OLDTITLE ??
?? NEWTITLE := '    sl_authorize_write_access', EJECT ??
  PROCEDURE sl_authorize_write_access
    (    file_identifier: amt$file_identifier;
         proposed_header_labels: ^SEQ ( * );
         writing_vol1_label: boolean;
     VAR status: ost$status);

    VAR
      authorized_access: fst$file_access_options,
      file_access_options: fst$file_access_options,
      file_set_access: fst$file_access_options,
      ignore_read_labels_status: ost$status,
      initial_vol_sequence: ^SEQ ( * ),
      initial_volume_header_labels: ^SEQ ( * ),
      last_accessed_sequence: ^SEQ ( * ),
      last_accessed_header_labels: ^SEQ ( * ),
      proposed_volume_classification: rmt$tape_volume_classification,
      sequence_header: ^fst$tape_label_sequence_header,
      tape_security_call_block: fst$tape_security_call_block;

    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering SL_AUTHORIZE_WRITE_ACCESS');

    IF tape_descriptor^.initial_volume.header_labels <> NIL THEN
      initial_vol_sequence := tape_descriptor^.initial_volume.header_labels;
      RESET initial_vol_sequence;
      NEXT sequence_header IN initial_vol_sequence;
      PUSH initial_volume_header_labels: [[REP sequence_header^.sequence_size OF cell]];
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Copying initial_volume_header_labels');
      initial_volume_header_labels^ := initial_vol_sequence^;
    ELSE
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: initial_volume_header_labels = NIL');
      initial_volume_header_labels := NIL;
    IFEND;
    IF tape_descriptor^.last_accessed.unsecured_header_labels <> NIL THEN
      last_accessed_sequence := tape_descriptor^.last_accessed.unsecured_header_labels;
      RESET last_accessed_sequence;
      NEXT sequence_header IN last_accessed_sequence;
      PUSH last_accessed_header_labels: [[REP sequence_header^.sequence_size OF cell]];
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Copying last_accessed_header_labels');
      last_accessed_header_labels^ := last_accessed_sequence^;
    ELSE
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: last_accessed_header_labels = NIL');
      last_accessed_header_labels := NIL;
    IFEND;

    IF writing_vol1_label THEN
      IF tape_descriptor^.volume_number = 1 THEN
        IF tape_descriptor^.tape_attachment_information.volume_initialization THEN
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling AUTHORIZE_VOLUME_REUSE');
          tape_security_call_block.operation := fsc$ts_authorize_volume_reuse;
          tape_security_call_block.authorize_volume_reuse.current_header_labels :=
                initial_volume_header_labels;
          tape_security_call_block.authorize_volume_reuse.proposed_file_label_type :=
                tape_descriptor^.file_label_type;
          tape_security_call_block.authorize_volume_reuse.proposed_blank_labels := proposed_header_labels;
          sl_enforce_tape_security (file_identifier, tape_security_call_block, status);
          IF status.normal THEN
            bap$store_unsecured_tape_labels (proposed_header_labels,
                  tape_descriptor^.initial_volume.header_labels);
          IFEND;
        ELSE
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling AUTHORIZE_FILE_SET_REUSE');
          ignore_read_labels_status.normal := TRUE;
          rmp$classify_tape_volume (ignore_read_labels_status, proposed_header_labels,
                proposed_volume_classification, status);
          IF status.normal THEN
            tape_security_call_block.operation := fsc$ts_authorize_file_set_reuse;
            tape_security_call_block.authorize_file_set_reuse.initial_volume_classification :=
                  tape_descriptor^.initial_volume.classification;
            tape_security_call_block.authorize_file_set_reuse.initial_volume_header_labels :=
                  initial_volume_header_labels;
            #UNCHECKED_CONVERSION (file_instance^.instance_attributes.dynamic_label.access_mode,
                  file_access_options);
            file_access_options := file_access_options * tape_descriptor^.initial_volume.access_modes;
            tape_security_call_block.authorize_file_set_reuse.proposed_access := file_access_options;
            tape_security_call_block.authorize_file_set_reuse.proposed_volume_classification :=
                  proposed_volume_classification;
            tape_security_call_block.authorize_file_set_reuse.proposed_access_defaulted :=
                  (file_instance^.instance_attributes.dynamic_label.access_mode_source =
                  amc$access_method_default);
            tape_security_call_block.authorize_file_set_reuse.proposed_header_labels :=
                  proposed_header_labels;
            tape_security_call_block.authorize_file_set_reuse.authorized_access := ^authorized_access;
            tape_security_call_block.authorize_file_set_reuse.file_set_access := ^file_set_access;
            sl_enforce_tape_security (file_identifier, tape_security_call_block, status);
            IF status.normal THEN
              tape_descriptor^.initial_volume.access_modes := file_set_access;
              tape_descriptor^.initial_volume.classification := proposed_volume_classification;
              sl_store_authorized_access (authorized_access, status);
              bap$store_unsecured_tape_labels (proposed_header_labels,
                    tape_descriptor^.initial_volume.header_labels);
            IFEND;
          IFEND;
        IFEND;
      ELSE
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling AUTHORIZE_SECTION_WRITE');
        tape_security_call_block.operation := fsc$ts_authorize_section_write;
        tape_security_call_block.authorize_section_write.current_header_labels := last_accessed_header_labels;
        tape_security_call_block.authorize_section_write.initial_volume_classification :=
              tape_descriptor^.initial_volume.classification;
        tape_security_call_block.authorize_section_write.initial_volume_header_labels :=
              initial_volume_header_labels;
        sl_enforce_tape_security (file_identifier, tape_security_call_block, status);
      IFEND;
    ELSEIF tape_descriptor^.labeled_volume_position = bac$lvp_before_header_labels THEN
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling AUTHORIZE_FILE_REUSE');
      tape_security_call_block.operation := fsc$ts_authorize_file_reuse;
      tape_security_call_block.authorize_file_reuse.initial_volume_classification :=
            tape_descriptor^.initial_volume.classification;
      tape_security_call_block.authorize_file_reuse.initial_volume_header_labels :=
            initial_volume_header_labels;
      tape_security_call_block.authorize_file_reuse.original_header_labels := last_accessed_header_labels;
      tape_security_call_block.authorize_file_reuse.proposed_header_labels := proposed_header_labels;
      sl_enforce_tape_security (file_identifier, tape_security_call_block, status);
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_AUTHORIZE_WRITE_ACCESS');
    IFEND;
    IF NOT status.normal THEN
      rmp$log_debug_status (status);
      sl_tape_abnormal_termination (file_identifier);
    IFEND;
  PROCEND sl_authorize_write_access;
?? OLDTITLE ??
?? NEWTITLE := '    sl_close_label_volume', EJECT ??
  PROCEDURE sl_close_label_volume
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      label_group: fst$ansi_label_kinds;

    status.normal := TRUE;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering SL_CLOSE_LABEL_VOLUME');
    IF state_info^.put_op OR state_info^.eoi_labels_needed THEN
      sl_put_end_of_vol_labels (file_identifier, status);
      IF status.normal THEN
        sl_advance_volume (file_identifier, status);
        IF status.normal THEN
          sl_read_tape_labels (file_identifier, label_group, status);
          IF status.normal THEN
            sl_advance_tapemark (file_identifier, amc$backward, 2, status);
            IF (NOT status.normal) AND (status.condition = ame$skip_encountered_bov) THEN
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Rewriting labels on volume overflow');
              sl_put_header_labels (file_identifier, {include_vol1_label=} TRUE, status);
              IF status.normal THEN
                IF state_info^.buffered_blocks = 0 THEN
                  gfi^.positioning_info.block_info.block_number := 1;
                  tape_descriptor^.volume_position := amc$after_tapemark;
                  bov_position := FALSE;
                  state_info^.put_op := FALSE;
                ELSE
                  gfi^.positioning_info.block_info.block_number := state_info^.buffered_blocks;
                  tape_descriptor^.volume_position := amc$after_data_block;
                  bov_position := FALSE;
                  state_info^.put_op := TRUE;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    ELSE
      sl_advance_volume (file_identifier, status);
      IF status.normal THEN
        sl_read_tape_labels (file_identifier, label_group, status)
      IFEND;
    IFEND;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_CLOSE_LABEL_VOLUME');
    rmp$log_debug_status (status);
  PROCEND sl_close_label_volume;
?? OLDTITLE ??
?? NEWTITLE := '    sl_decrement_file_sequence_no', EJECT ??

  PROCEDURE [INLINE] sl_decrement_file_sequence_no;

    IF tape_descriptor^.next_position.file_sequence_number > 1 THEN
      rmp$log_debug_integer ('LABELED_TAPE_DEBUG: FILE_SEQUENCE_NUMBER was: ',
            tape_descriptor^.next_position.file_sequence_number);
      tape_descriptor^.next_position.file_sequence_number :=
            tape_descriptor^.next_position.file_sequence_number - 1;
      rmp$log_debug_integer ('LABELED_TAPE_DEBUG: FILE_SEQUENCE_NUMBER decremented to: ',
            tape_descriptor^.next_position.file_sequence_number);
    IFEND;

  PROCEND sl_decrement_file_sequence_no;

?? OLDTITLE ??
?? NEWTITLE := '    sl_enable_read_after_write', EJECT ??
  PROCEDURE sl_enable_read_after_write
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

{Design: The buffer manager maintains I/O operation status of read, write, or
{indeterminated.  When the direction of the tape reverses after writing, it is
{necessary to close and reopen the tape at the BM level to change the operational
{status.  Reading after writing is only allowed when the ANSI file is first rewound.
{But the operational status should be changed to indetermainate immediately after
{writing trailer labels to allow a subsequent rewind/get sequence to work.

    VAR
      ignore_failure_modes: amt$tape_failure_modes;

    status.normal := TRUE;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering SL_ENABLE_READ_AFTER_WRITE');
    bap$tape_bm_close (file_identifier, ignore_failure_modes, status);
    IF status.normal THEN
      bap$tape_bm_open (file_identifier, gfi^.max_data_size, status);
    IFEND;

    IF NOT status.normal THEN
      CASE status.condition OF
      = bae$maxbl_exceeds_ws_limit =
        amp$set_file_instance_abnormal (file_identifier, ame$maxbl_exceeds_ws_limit, operation, '',
              status);
      = bae$tape_block_mgr_malfunction =
        amp$set_file_instance_abnormal (file_identifier, ame$tape_block_mgr_malfunction, operation,
              status.text.value (2, status.text.size - 1), status);
      = bae$tape_driver_not_capable =
        amp$set_file_instance_abnormal (file_identifier, ame$tape_driver_not_capable, operation,
              '', status);
      ELSE
      CASEND;
    IFEND;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_ENABLE_READ_AFTER_WRITE');

  PROCEND sl_enable_read_after_write;
?? OLDTITLE ??
?? NEWTITLE := '    sl_enforce_tape_security', EJECT ??
  PROCEDURE sl_enforce_tape_security
    (    file_identifier: amt$file_identifier;
     VAR tape_security_call_block {input, output}: fst$tape_security_call_block;
     VAR status: ost$status);

    VAR
      call_block: amt$call_block,
      enforce_tape_security: boolean,
      local_status: ost$status,
      tape_security_state : bat$tape_validation_state;

    status.normal := TRUE;

    call_block.operation := amc$enforce_tape_security;
    call_block.enforce_tape_security := #SEQ (tape_security_call_block);
    CASE tape_security_call_block.operation OF
    = fsc$ts_authorize_access_method, fsc$ts_authorize_file_access, fsc$ts_authorize_file_reuse,
          fsc$ts_authorize_section_write, fsc$ts_authorize_file_set_mount, fsc$ts_authorize_file_set_reuse,
          fsc$ts_authorize_section_read, fsc$ts_authorize_volume_reuse =
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling bap$get_tape_security_state');
      bap$get_tape_security_state (tape_security_state, local_status);
      enforce_tape_security := (tape_security_state = bac$tape_validation_on);
      IF enforce_tape_security THEN
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Tape security state is ON');
      ELSE
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Tape security state is OFF');
      IFEND;
      CASE tape_security_call_block.operation OF
      = fsc$ts_authorize_access_method =
        tape_security_call_block.authorize_access_method.enforce_tape_security := enforce_tape_security;
      = fsc$ts_authorize_file_access =
        tape_security_call_block.authorize_file_access.enforce_tape_security := enforce_tape_security;
      = fsc$ts_authorize_file_reuse =
        tape_security_call_block.authorize_file_reuse.enforce_tape_security := enforce_tape_security;
      = fsc$ts_authorize_section_write =
        tape_security_call_block.authorize_section_write.enforce_tape_security := enforce_tape_security;
      = fsc$ts_authorize_file_set_mount =
        tape_security_call_block.authorize_file_set_mount.enforce_tape_security := enforce_tape_security;
      = fsc$ts_authorize_file_set_reuse =
        tape_security_call_block.authorize_file_set_reuse.enforce_tape_security := enforce_tape_security;
      = fsc$ts_authorize_section_read =
        tape_security_call_block.authorize_section_read.enforce_tape_security := enforce_tape_security;
      = fsc$ts_authorize_volume_reuse =
        tape_security_call_block.authorize_volume_reuse.enforce_tape_security := enforce_tape_security;
      ELSE
      CASEND;
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling amp$access_method - authorize');
      amp$access_method (file_identifier, call_block, global_layer_number, status);
    = fsc$ts_secure_header_labels, fsc$ts_secure_trailer_labels, fsc$ts_validate_header_labels,
          fsc$ts_validate_trailer_labels =
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling amp$access_method - secure or validate');
      amp$access_method (file_identifier, call_block, global_layer_number, status);
    CASEND;

  PROCEND sl_enforce_tape_security;
?? OLDTITLE ??
?? NEWTITLE := '    sl_find_next_header_group', EJECT ??
  PROCEDURE sl_find_next_header_group
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

{Design: On entry, the tape could be positioned just about anywhere, including the
{end of the volume set.  We may have to skip over embedded tapemarks to get to the
{next header label group.
{
{The end of a file set is signaled by a single tapemark following an EOF label group.
{If the starting position is after an EOF label group, we can only read one tapemark
{beyond the current position for fear of reading beyond the end of recorded data on
{the volume.  If the volume does not adhere to ANSI convention, we will stop if 3
{consecutive tapemarks are encountered.  We always backspace over consecutive tapemarks
{that we read when we exit due to reaching end of set.

    VAR
      consecutive_tapemarks_read: 0 .. 3,
      ignore_status: ost$status,
      label_group: fst$ansi_label_kinds,
      after_labels: boolean;

    status.normal := TRUE;

    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering SL_FIND_NEXT_HEADER_GROUP');
    rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Value of LVP is: ', $integer(tape_descriptor^.
           labeled_volume_position));
    consecutive_tapemarks_read := 0;
    after_labels := sl_after_label_group (tape_descriptor^.labeled_volume_position);
    CASE tape_descriptor^.labeled_volume_position OF
    = bac$lvp_end_of_file_set, bac$lvp_end_of_volume_list =
      osp$set_status_condition (ame$file_not_in_volume_set, status);
      osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name, status);
    = bac$lvp_after_header_labels =
      IF NOT (tape_descriptor^.initial_volume.classification.labeled.blank) THEN
        sl_advance_tapemark (file_identifier, amc$forward, 1, status);
        IF status.normal THEN
          consecutive_tapemarks_read := 1;
        IFEND;
      IFEND;
    = bac$lvp_within_ansi_file =
      sl_advance_tapemark (file_identifier, amc$forward, 1, status);
      IF status.normal THEN
        consecutive_tapemarks_read := 1;
      IFEND;
    ELSE
    CASEND;
    IF status.normal THEN
      REPEAT
        {   * EOF1 EOF2 * HDR1 HDR2* data * EOF1 EOF2*
        {                ^
        sl_read_tape_labels (file_identifier, label_group, status);
        IF status.normal THEN
          IF fsp$header_labels (label_group) THEN
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_FIND_NEXT_HEADER_GROUP - success');
            RETURN;
          ELSEIF fsp$file_trailer_labels (label_group) THEN
            consecutive_tapemarks_read := 0;
            after_labels := TRUE;
          ELSEIF fsp$volume_trailer_labels (label_group) THEN
            sl_advance_volume (file_identifier, status);
            IF status.normal THEN
              consecutive_tapemarks_read := 0;
              after_labels := TRUE;
            IFEND;
          IFEND;
        ELSE
          CASE status.condition OF
          = ame$invalid_tape_label =
            {   * EOF1 EOF2 * HDR1 HDR2* data * EOF1 EOF2*
            {                             ^
            sl_advance_tapemark (file_identifier, amc$forward, 1, status);
            {   * EOF1 EOF2 * HDR1 HDR2* data * EOF1 EOF2*
            {                                  ^
            IF status.normal THEN
              consecutive_tapemarks_read := 1;
              after_labels := FALSE;
            IFEND;
          = ame$unexpected_tapemark =
            consecutive_tapemarks_read := consecutive_tapemarks_read + 1;
            IF (after_labels AND (consecutive_tapemarks_read = 1)) OR (consecutive_tapemarks_read = 3) THEN
              {   * EOF1 EOF2 * HDR1 HDR2* data * data * EOF1 EOF2* * *
              {                                                        ^
              sl_advance_tapemark (file_identifier, amc$backward, consecutive_tapemarks_read, ignore_status);
              {   HDR1 HDR2* data * data * EOF1 EOF2* * *
              {                                      ^
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting LVP to end of file set');
              tape_descriptor^.labeled_volume_position := bac$lvp_end_of_file_set;
              tape_descriptor^.volume_position := amc$after_tapemark;
              state_info^.put_op := FALSE;
              file_instance^.previous_get_at_eoi := FALSE;
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_FIND_NEXT_HEADER_GROUP - hit EOS');
              osp$set_status_condition (ame$file_not_in_volume_set, status);
              osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name, status);
              RETURN;
            ELSE
              {   * EOF1 EOF2 * HDR1 HDR2* data * data * EOF1 EOF2*
              {                                  ^
              status.normal := TRUE;
            IFEND;
          ELSE
          CASEND;
        IFEND;
      UNTIL NOT status.normal;
    IFEND;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_FIND_NEXT_HEADER_GROUP - abnormal');
    rmp$log_debug_status (status);
  PROCEND sl_find_next_header_group;
?? OLDTITLE ??
?? NEWTITLE := '    sl_find_next_trailer_group', EJECT ??
  PROCEDURE sl_find_next_trailer_group
    (    file_identifier: amt$file_identifier;
     VAR label_group: fst$ansi_label_kinds;
     VAR status: ost$status);

{Design: On entry, the tape could be positioned just about anywhere, including the
{end of the volume set.  We may have to skip over embedded tapemarks to find the
{next trailer label group.
{
{The end of a file set is signaled by a single tapemark following a label group.
{If the starting position is after a label group, we can only read one tapemark
{beyond the current position for fear of reading beyond the end of recorded data on
{the volume.  If the ANSI file contains embedded tapemarks, we will stop if 3
{consecutive tapemarks are encountered.  We always backspace over consecutive tapemarks
{that we read when we exit due to reaching end of set.

    VAR
      consecutive_tapemarks_read: 0 .. 3,
      ignore_status: ost$status,
      after_labels: boolean;

    {   * EOF1 EOF2* HDR1 HDR2* data * EOF1 EOF2* * *
    {               ?             ?              ?
    status.normal := TRUE;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering SL_FIND_NEXT_TRAILER_GROUP');
    rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Value of LVP is: ', $integer(tape_descriptor^.
           labeled_volume_position));
    consecutive_tapemarks_read := 0;
    after_labels := sl_after_label_group (tape_descriptor^.labeled_volume_position);
    CASE tape_descriptor^.labeled_volume_position OF
    = bac$lvp_end_of_file_set =
      osp$set_status_condition (ame$file_not_in_volume_set, status);
      osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name, status);
      RETURN;

    = bac$lvp_within_ansi_file =
      sl_advance_tapemark (file_identifier, amc$forward, 1, status);
      IF status.normal THEN
        consecutive_tapemarks_read := 1;
      IFEND;
    ELSE
    CASEND;

  /find_trailer/
    REPEAT
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling sl_read_tape_labels');
      sl_read_tape_labels (file_identifier, label_group, status);
      IF status.normal OR sl_irrelevant_condition (status) THEN
        status.normal := TRUE;
        IF fsp$trailer_labels (label_group) THEN
          RETURN;
        ELSEIF fsp$volume_header_labels (label_group) AND (tape_descriptor^.volume_number = 1) AND
            (tape_descriptor^.initial_volume.classification.volume_label_type = rmc$labeled_volume_type) AND
            (tape_descriptor^.initial_volume.classification.labeled.blank) THEN
          {An initialized volume may, according to ANSI, consist of a VOL1 label followed by as few as two
          {tapemarks.  Avoid skipping or reading beyond the recorded area of the tape.
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Blank volume - hit EOS');
          osp$set_status_condition (ame$file_not_in_volume_set, status);
          RETURN;
        ELSEIF fsp$header_labels (label_group) THEN
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Header labels were read');
          sl_advance_tapemark (file_identifier, amc$forward, 1, status);
          rmp$log_debug_status (status);
          {
          {   HDR1 HDR2* data * EOF1 EOF2*
          {                    ^
          consecutive_tapemarks_read := 1;
          after_labels := FALSE;
          CYCLE /find_trailer/;
        IFEND;
      ELSE
        CASE status.condition OF
        = ame$invalid_tape_label =
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Found data block?');
          { We must have encountered a data block after a tapemark
          {   HDR1 HDR2* data * data * EOF1 EOF2*
          {                     ^
          sl_advance_tapemark (file_identifier, amc$forward, 1, status);
          {
          {   HDR1 HDR2* data * data * EOF1 EOF2*
          {                           ^
          IF status.normal THEN
            tape_descriptor^.volume_position := amc$after_tapemark;
            consecutive_tapemarks_read := 1;
            after_labels := FALSE;
          IFEND;
        = ame$unexpected_tapemark =
          consecutive_tapemarks_read := consecutive_tapemarks_read + 1;
          IF (after_labels AND (consecutive_tapemarks_read = 2)) OR
                (consecutive_tapemarks_read = 3) THEN
            sl_advance_tapemark (file_identifier, amc$backward, consecutive_tapemarks_read, ignore_status);
            {   HDR1 HDR2* data * data * EOF1 EOF2* * *
            {                                      ^
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting LVP to end of file set');
            tape_descriptor^.labeled_volume_position := bac$lvp_end_of_file_set;
            tape_descriptor^.volume_position := amc$after_tapemark;
            state_info^.put_op := FALSE;
            file_instance^.previous_get_at_eoi := FALSE;
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_FIND_NEXT_TRAILER_GROUP - hit EOS');
            osp$set_status_condition (ame$file_not_in_volume_set, status);
            osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name, status);
            RETURN;
          ELSE {Could be embedded tapemark, try once more}
            {
            {   HDR1 HDR2* data * data * EOF1 EOF2* * *
            {                                        ^
            status.normal := TRUE;
          IFEND;
        ELSE
        CASEND;
      IFEND;
    UNTIL NOT status.normal;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_FIND_NEXT_TRAILER_GROUP - abnormal status');
    rmp$log_debug_status (status);

  PROCEND sl_find_next_trailer_group;
?? OLDTITLE ??
?? NEWTITLE := '    sl_increment_file_sequence_no', EJECT ??

  PROCEDURE [INLINE] sl_increment_file_sequence_no;

{Design: The ANSI standard limits the number of ANSI files on a volume set to 9999.
{Our implementation increments the NEXT_POSITION file sequence number after trailer
{labels are written or read.  If we have just accessed the last possible ANSI file,
{the NEXT_POSITION value is left at 9999.  Setting the labeled_volume_position to
{END_OF_VOLUME_SET prevents further writing of ANSI files.

    IF tape_descriptor^.next_position.file_sequence_number < 9999 THEN
      rmp$log_debug_integer ('LABELED_TAPE_DEBUG: FILE_SEQUENCE_NUMBER was: ',
            tape_descriptor^.next_position.file_sequence_number);
      tape_descriptor^.next_position.file_sequence_number :=
            tape_descriptor^.next_position.file_sequence_number + 1;
      rmp$log_debug_integer ('LABELED_TAPE_DEBUG: FILE_SEQUENCE_NUMBER incremented to: ',
            tape_descriptor^.next_position.file_sequence_number);
    ELSE
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting LVP to end of volume set');
      tape_descriptor^.labeled_volume_position := bac$lvp_end_of_volume_list;
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting AT_EOI to TRUE');
      tape_descriptor^.at_eoi := TRUE;
    IFEND;

  PROCEND sl_increment_file_sequence_no;

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

  PROCEDURE sl_log_eof_block_count
    (    block_count: 0 .. 999999;
         mode: string ( * ));

    VAR
      ignore_status: ost$status,
      local_status: ost$status;

    osp$set_status_condition (ame$log_eof_block_count, local_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, mode, local_status);
    osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name, local_status);
    osp$append_status_integer (osc$status_parameter_delimiter,
          tape_descriptor^.next_position.file_sequence_number, 10, false, local_status);
    osp$append_status_integer (osc$status_parameter_delimiter,
          tape_descriptor^.next_position.file_section_number, 10, false, local_status);
    osp$append_status_integer (osc$status_parameter_delimiter, block_count, 10, false, local_status);
    osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);

  PROCEND sl_log_eof_block_count;
?? OLDTITLE ??
?? NEWTITLE := '    sl_log_eov_block_count', EJECT ??

  PROCEDURE sl_log_eov_block_count
    (    block_count: 0 .. 999999;
         mode: string ( * ));

    VAR
      ignore_status: ost$status,
      local_status: ost$status;

    osp$set_status_condition (ame$log_eov_block_count, local_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, mode, local_status);
    osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name, local_status);
    osp$append_status_integer (osc$status_parameter_delimiter,
          tape_descriptor^.next_position.file_sequence_number, 10, false, local_status);
    osp$append_status_integer (osc$status_parameter_delimiter,
          tape_descriptor^.next_position.file_section_number, 10, false, local_status);
    osp$append_status_integer (osc$status_parameter_delimiter, block_count, 10, false, local_status);
    osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);

  PROCEND sl_log_eov_block_count;
?? OLDTITLE ??
?? NEWTITLE := '    sl_after_label_group', EJECT ??

  FUNCTION [INLINE] sl_after_label_group
    (    labeled_volume_position: bat$labeled_volume_position):boolean;

{ This function determines whether we are positioned after a label group.

    CASE labeled_volume_position OF
    = bac$lvp_after_header_labels, bac$lvp_after_trailer_labels, bac$lvp_end_of_file_set,
            bac$lvp_end_of_volume_list =
      sl_after_label_group := TRUE;
    = bac$lvp_beginning_of_file_set, bac$lvp_within_ansi_file =
      sl_after_label_group := FALSE;
    CASEND;

  FUNCEND sl_after_label_group;

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

  FUNCTION [INLINE] sl_irrelevant_condition
    (    status: ost$status): boolean;

{ This function identifies certain exception conditions as irrelevant.
{ These conditions are considered irrelevant when they are detected during the
{ positioning of a volume set prior to finding the target ANSI file.

    sl_irrelevant_condition := FALSE;
    IF NOT status.normal THEN
      CASE status.condition OF
      = ame$ansi_file_unexpired, ame$insufficient_file_access =
        sl_irrelevant_condition := TRUE;
      ELSE
      CASEND;
    IFEND;

  FUNCEND sl_irrelevant_condition;

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

  FUNCTION [INLINE] sl_next_position_is_last_file
    (    file_set_position: fst$tape_file_set_position;
         last_accessed_file_id: string (17);
         last_accessed_generation_no: 1 .. 9999): boolean;

{ This function determines whether the next position is the last ANSI file that
{ was accessed.  The next position file sequence number is only incremented after
{ trailer labels are read or written.  Therefore, if our current positon is after
{ trailer labels, the current ansi file sequence number is one less than the next
{ position value.

    VAR
      last_accessed_file_sequence: 1 .. 9999;

    sl_next_position_is_last_file := FALSE;
    CASE file_set_position.position OF
    = fsc$tape_file_sequence_pos =
      IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
        last_accessed_file_sequence := tape_descriptor^.next_position.file_sequence_number - 1;
        IF last_accessed_file_sequence = file_set_position.file_sequence_number THEN
          sl_next_position_is_last_file := TRUE;
        IFEND;
      ELSEIF (tape_descriptor^.next_position.file_sequence_number =
            file_set_position.file_sequence_number) THEN
        sl_next_position_is_last_file := TRUE;
      IFEND;
    = fsc$tape_file_identifier_pos =
      IF (last_accessed_file_id = file_set_position.file_identifier) AND
            (last_accessed_generation_no = file_set_position.generation_number)
            THEN
        sl_next_position_is_last_file := TRUE;
      IFEND;
    ELSE
    CASEND;

  FUNCEND sl_next_position_is_last_file;

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

  PROCEDURE sl_open_label_file
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
         local_file_name: amt$local_file_name;
     VAR status: ost$status);

?? NEWTITLE := '      adjust_file_attributes', EJECT ??

    PROCEDURE adjust_file_attributes
      (VAR status: ost$status);

      CONST
        bo = 1,
        bt = 2,
        cc = 3,
        cs = 4,
        ii = 5,
        mbl = 6,
        mrl = 7,
        pc = 8,
        rt = 9;

      VAR
        hdr2_label: ^fst$ansi_hdr2_label,
        instance_attrib: ^array [bo .. rt] of fst$attachment_option,
        label_identifier: fst$tape_label_identifier,
        label_locator: fst$tape_label_locator,
        returned_attributes: fst$tla_returned_attributes,
        tape_failure_modes: amt$tape_failure_modes;

      status.normal := TRUE;
      state_info^.ve_wrote_ansi_file := FALSE;
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering ADJUST_FILE_ATTRIBUTES');
      PUSH instance_attrib;
      instance_attrib^ [bo].selector := fsc$tape_attachment;
      instance_attrib^ [bo].tape_attachment.selector := fsc$tape_buffer_offset;
      instance_attrib^ [bt].selector := fsc$tape_attachment;
      instance_attrib^ [bt].tape_attachment.selector := fsc$tape_block_type;
      instance_attrib^ [cc].selector := fsc$tape_attachment;
      instance_attrib^ [cc].tape_attachment.selector := fsc$tape_character_conversion;
      instance_attrib^ [cs].selector := fsc$tape_attachment;
      instance_attrib^ [cs].tape_attachment.selector := fsc$tape_character_set;
      instance_attrib^ [ii].selector := fsc$tape_attachment;
      instance_attrib^ [ii].tape_attachment.selector := fsc$tape_implementation_id;
      instance_attrib^ [mbl].selector := fsc$tape_attachment;
      instance_attrib^ [mbl].tape_attachment.selector := fsc$tape_max_block_length;
      instance_attrib^ [mrl].selector := fsc$tape_attachment;
      instance_attrib^ [mrl].tape_attachment.selector := fsc$tape_max_record_length;
      instance_attrib^ [pc].selector := fsc$tape_attachment;
      instance_attrib^ [pc].tape_attachment.selector := fsc$tape_padding_character;
      instance_attrib^ [rt].selector := fsc$tape_attachment;
      instance_attrib^ [rt].tape_attachment.selector := fsc$tape_record_type;

      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling FSP$GETTLA - last_accessed - for VE fields');
      fsp$get_tape_label_attributes (file_instance^.local_file_name, fsc$tla_last_ansi_file_accessed,
            instance_attrib^, returned_attributes, status);

      IF status.normal THEN
        IF (fsc$tape_buffer_offset IN returned_attributes) AND
              (instance_attrib^ [bo].tape_attachment.tape_buffer_offset > 0) THEN
          osp$set_status_condition (ame$unimplemented_buffer_offset, status);
          osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name, status);
        IFEND;
      IFEND;
      IF status.normal THEN
        IF fsc$tape_character_conversion IN returned_attributes THEN
          IF state_info^.character_conversion THEN
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Storing TRUE for Character Conversion');
          ELSE
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Storing FALSE for Character Conversion');
          IFEND;
          state_info^.character_conversion := instance_attrib^ [cc].tape_attachment.tape_character_conversion;
        IFEND;
        IF fsc$tape_character_set IN returned_attributes THEN
          CASE state_info^.character_set OF
          = amc$ascii =
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Storing ASCII for Character Set');
          = amc$ebcdic =
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Storing EBCDIC for Character Set');
          ELSE
            rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Storing OTHER Character Set=',
                  $INTEGER (state_info^.character_set));
          CASEND;
          state_info^.character_set := instance_attrib^ [cs].tape_attachment.tape_character_set;
        IFEND;
        IF fsc$tape_max_block_length IN returned_attributes THEN
          state_info^.maximum_block_length := instance_attrib^ [mbl].tape_attachment.tape_max_block_length;
          rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Stored MAXBL=',
                  state_info^.maximum_block_length);
        IFEND;
        IF fsc$tape_max_record_length IN returned_attributes THEN
          state_info^.maximum_record_length := instance_attrib^ [mrl].tape_attachment.tape_max_record_length;
          rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Stored MAXRL=',
                  state_info^.maximum_record_length);
        IFEND;
        IF fsc$tape_padding_character IN returned_attributes THEN
          state_info^.padding_character := instance_attrib^ [pc].tape_attachment.tape_padding_character;
        IFEND;
        IF fsc$tape_implementation_id IN returned_attributes THEN
          state_info^.ve_wrote_ansi_file := fsp$ve_wrote_ansi_file
                (instance_attrib^ [ii].tape_attachment.tape_implementation_id);
        IFEND;

        gfi^.max_data_size := state_info^.maximum_block_length;
        gfi^.max_block_size := state_info^.maximum_block_length;
        gfi^.max_record_length := state_info^.maximum_record_length;
        gfi^.padding_character := state_info^.padding_character;

        { Reject unsupported block_type/record_type combinations
        IF instance_attrib^ [bt].tape_attachment.tape_block_type = amc$user_specified THEN
          IF instance_attrib^ [rt].tape_attachment.tape_record_type = amc$trailing_char_delimited THEN
            amp$set_local_name_abnormal (local_file_name, ame$unsupported_tape_bt_rt, call_block.operation,
                  'Block type USER_SPECIFIED (US), record type TRAILING_CHARACTER_DELIMITED (T)', status);
          IFEND;
        ELSEIF instance_attrib^ [bt].tape_attachment.tape_block_type = amc$system_specified THEN
          IF instance_attrib^ [rt].tape_attachment.tape_record_type = amc$trailing_char_delimited THEN
            amp$set_local_name_abnormal (local_file_name, ame$unsupported_tape_bt_rt, call_block.operation,
                  'Block type SYSTEM_SPECIFIED (SS), record type TRAILING_CHARACTER_DELIMITED (T)', status);
          ELSEIF instance_attrib^ [rt].tape_attachment.tape_record_type = amc$ansi_fixed THEN
            amp$set_local_name_abnormal (local_file_name, ame$unsupported_tape_bt_rt, call_block.operation,
                  'Block type SYSTEM_SPECIFIED (SS), record type FIXED (F)', status);
          ELSEIF instance_attrib^ [rt].tape_attachment.tape_record_type = amc$ansi_variable THEN
            amp$set_local_name_abnormal (local_file_name, ame$unsupported_tape_bt_rt, call_block.operation,
                  'Block type SYSTEM_SPECIFIED (SS), record type ANSI_VARIABLE (D)', status);
          ELSEIF instance_attrib^ [rt].tape_attachment.tape_record_type = amc$ansi_spanned THEN
            amp$set_local_name_abnormal (local_file_name, ame$unsupported_tape_bt_rt, call_block.operation,
                  'Block type SYSTEM_SPECIFIED (SS), record type ANSI_SPANNED (S)', status);
          IFEND;
        IFEND;

        label_identifier.location_method := fsc$tape_label_locate_by_kind;
        label_identifier.label_kind := fsc$ansi_hdr2_label_kind;
        fsp$locate_tape_label (tape_descriptor^.last_accessed.unsecured_header_labels, label_identifier,
              label_locator);
        IF status.normal AND label_locator.label_found THEN
          RESET label_locator.label_block;
          NEXT hdr2_label IN label_locator.label_block;
          IF hdr2_label <> NIL THEN
            IF ((hdr2_label^.record_format = 'V') OR (hdr2_label^.record_format = 'v')) AND
                  NOT fsp$ve_wrote_ansi_file (instance_attrib^ [ii].tape_attachment.tape_implementation_id)
                  THEN
              {Convert IBM V record formatted tape to NOS/VE U/US format
              bap$change_tape_bt_and_rt (file_identifier, layer_number, amc$user_specified, amc$undefined,
                    status);
            ELSEIF (hdr2_label^.record_format <> ' ') OR ((hdr2_label^.ve_record_type <> ' ') AND
                  (hdr2_label^.ve_block_type <> ' ')) THEN
              bap$change_tape_bt_and_rt (file_identifier, layer_number,
                    instance_attrib^ [bt].tape_attachment.tape_block_type,
                    instance_attrib^ [rt].tape_attachment.tape_record_type, status);
            IFEND;

            IF status.normal THEN

              IF instance_attrib^ [bt].tape_attachment.tape_block_type = amc$system_specified THEN
                IF ($pft$usage_selections [pfc$shorten, pfc$append] * file_instance^.instance_attributes.
                      dynamic_label.access_mode) <> $pft$usage_selections [] THEN
                  rmp$log_debug_integer ('LABELED_TAPE_DEBUG: REQUESTED_DENSITY=',
                        $INTEGER (tape_descriptor^.requested_density));
                  IF (tape_descriptor^.requested_density = rmc$38000) THEN
                    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting GFI max block size to 32640');
                    gfi^.max_data_size := 32640;
                    gfi^.max_block_size := 32640;
                  ELSE
                    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting GFI max block size to 4128');
                    gfi^.max_data_size := 4128;
                    gfi^.max_block_size := 4128;
                  IFEND;
                IFEND;
              ELSE
                rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Setting GFI max block size to ',
                      state_info^.maximum_block_length);
                gfi^.max_data_size := state_info^.maximum_block_length;
                gfi^.max_block_size := state_info^.maximum_block_length;
              IFEND;
{
{ Call the Block Manager to close and open the file in order to change the maximum block length.
{
              sl_enable_read_after_write (file_identifier, status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    PROCEND adjust_file_attributes;
?? OLDTITLE ??
?? NEWTITLE := '      implement_file_set_position', EJECT ??
    PROCEDURE implement_file_set_position
      (VAR rewrite_labels: boolean;
       VAR status: ost$status);

?? NEWTITLE := '        adjust_rewrite_labels', EJECT ??

      PROCEDURE adjust_rewrite_labels
        (VAR rewrite_labels: boolean);

{Design:
{A tape written by NOS/VE prior to L780 (R1.6.1) may have a blank label group at BOS
{but have files beyond the first one.  If writing at BOS on a such a volume, we force
{REWRITE_LABELS to TRUE to ensure that a blank label group is rewritten with a proper
{(nonblank) label group.  RMP$CLASSIFY_TAPE_VOLUME determines that the label group
{corresponds to a pre-L780 NOS/VE blank label group and classifies it as
{cdc_version_one, nonblank, with owner_identifier = ' '.  The code below ensures that
{all of the conditions that were checked by RMP$CLASSIFY_TAPE_VOLUME are still in effect.
{
{This allows files after the empty one to be read and allows random positioning beyond
{the first ANSI file.

        VAR
          hdr2_label: ^fst$ansi_hdr2_label,
          ignore_status: ost$status,
          label_identifier: fst$tape_label_identifier,
          label_locator: fst$tape_label_locator;

        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering ADJUST_REWRITE_LABELS');
        IF tape_descriptor^.initial_volume.classification.labeled.expired AND
              (NOT tape_descriptor^.initial_volume.classification.labeled.blank) AND
              (tape_descriptor^.initial_volume.classification.labeled.file_accessibility = ' ') AND
              (tape_descriptor^.initial_volume.classification.labeled.volume_accessibility = ' ') THEN
          IF (tape_descriptor^.initial_volume.classification.labeled.volume_security_type =
                rmc$vst_ve_password_protected) AND fsp$version_one_tape_label (tape_descriptor^.
                initial_volume.classification.labeled.implementation_identifier) AND (tape_descriptor^.
                initial_volume.classification.labeled.ve_owner_identifier = ' ') THEN
            label_identifier.location_method := fsc$tape_label_locate_by_kind;
            label_identifier.label_kind := fsc$ansi_hdr2_label_kind;
            fsp$locate_tape_label (tape_descriptor^.last_accessed.unsecured_header_labels, label_identifier,
                  label_locator);
            IF label_locator.label_found THEN
              RESET label_locator.label_block;
              NEXT hdr2_label IN label_locator.label_block;
              IF hdr2_label <> NIL THEN
                IF (hdr2_label^.record_format = ' ') AND (hdr2_label^.block_length = '00000') AND
                      (hdr2_label^.record_length = '00000') AND (hdr2_label^.ve_block_type = ' ') AND
                      (hdr2_label^.ve_record_type = ' ') AND (hdr2_label^.ve_block_length_ext = '000') AND
                      (hdr2_label^.ve_record_length_ext = '000') AND
                      (hdr2_label^.ve_padding_character = ' ') AND (hdr2_label^.ve_character_set = ' ') AND
                      (hdr2_label^.ve_character_conversion = ' ') THEN
                  rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting RL=TRUE for blank V1.0');
                  rewrite_labels := TRUE;
                  rewind_tape (file_identifier, ignore_status);
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting ADJUST_REWRITE_LABELS');

      PROCEND adjust_rewrite_labels;
?? OLDTITLE ??
?? NEWTITLE := '        position_to_end_of_set', EJECT ??
    PROCEDURE position_to_end_of_set
      (VAR status: ost$status);

      VAR
        ignore_label_group: fst$ansi_label_kinds,
        ignore_status: ost$status;

{Design: The volume could be positioned anywhere at the time this procedure is
{called.  We read file header labels until we encounter a tapemark which signals
{ end of set.

      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering POSITION_TO_END_OF_SET');
      rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Current file sequence # is: ',
            tape_descriptor^.next_position.file_sequence_number);
      rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Value of LVP is: ',
            $INTEGER (tape_descriptor^.labeled_volume_position));

      IF tape_descriptor^.labeled_volume_position <> bac$lvp_end_of_file_set THEN
        status.normal := TRUE;
        REPEAT
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling SL_POSITION_AFTER_NEXT_EOF');
          sl_position_after_next_eof (file_identifier, status);
          IF status.normal THEN
            {   * EOF1 EOF2 * HDR1 HDR2* data * EOF1 EOF2*
            {                ^
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling SL_READ_TAPE_LABELS');
            sl_read_tape_labels (file_identifier, ignore_label_group, status);
            {   * EOF1 EOF2 * HDR1 HDR2* data * EOF1 EOF2*
            {                           ^
            IF status.normal OR sl_irrelevant_condition (status) THEN
              sl_advance_tapemark (file_identifier, amc$forward, 1, status);
              {   *EOF1 EOF2 * HDR1 HDR2* data * EOF1 EOF2 *
              {                                 ^
            ELSEIF status.condition = ame$unexpected_tapemark THEN
              sl_advance_tapemark (file_identifier, amc$backward, 1, ignore_status);
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting LVP to end of file set');
              tape_descriptor^.labeled_volume_position := bac$lvp_end_of_file_set;
              tape_descriptor^.volume_position := amc$after_tapemark;
              osp$set_status_condition (ame$file_not_in_volume_set, status);
              osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name, status);
            IFEND;
          IFEND;
        UNTIL NOT status.normal;
      ELSE
        osp$set_status_condition (ame$file_not_in_volume_set, status);
        osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name, status);
      IFEND;

      IF status.condition = ame$file_not_in_volume_set THEN
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Successfully positioned to EOS');
      IFEND;
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting POSITION_TO_END_OF_SET');
      rmp$log_debug_status (status);

    PROCEND position_to_end_of_set;
?? OLDTITLE ??
?? NEWTITLE := '        position_to_file_identifier', EJECT ??

      PROCEDURE position_to_file_identifier
        (    file_identifier: amt$file_identifier;
             starting_point: 1 .. 9999;
             target_file_identifier: string (17);
             target_generation_number: 1 .. 9999;
         VAR status: ost$status);

{Design:  This procedure assumes that the volume must be searched in a forward
{direction from the current position.  It is not intended for random access, use
{sl_position_to_file_seq_no for this purpose.  If we encounter the end of the
{file set, the volume set is rewound and searching commences in the forward
{direction until we either find the target ANSI file or we are positioned back to
{the starting point.

        CONST
          la_fi = 1,
          la_gn = 2;

        VAR
          ignore_returned_attributes: fst$tla_returned_attributes,
          ignore_status: ost$status,
          last_accessed_attrib: ^array [1 .. 2] of fst$attachment_option,
          local_status: ost$status,
          rewound_volume_set: boolean,
          started_at_bos: boolean;

        status.normal := TRUE;
        rewound_volume_set := FALSE;
        started_at_bos := (tape_descriptor^.volume_number = 1) AND
              (tape_descriptor^.volume_position = amc$bov);
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering SL_POSITION_TO_FILE_IDENTIFIER');
        rmp$log_debug_integer (target_file_identifier, target_generation_number);
        rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Will stop after FILE_SEQUENCE_NUMBER: ', starting_point);
        rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Value of LVP is: ',
              $INTEGER (tape_descriptor^.labeled_volume_position));
        REPEAT
          {   * EOF1 EOF2 * HDR1 HDR2* data * EOF1 EOF2*
          {                ^
          sl_find_next_header_group (file_identifier, status);
          {   * EOF1 EOF2 * HDR1 HDR2* data * EOF1 EOF2*
          {                           ^
          IF status.normal OR sl_irrelevant_condition (status) THEN
            PUSH last_accessed_attrib;
            last_accessed_attrib^ [la_fi].selector := fsc$tape_attachment;
            last_accessed_attrib^ [la_fi].tape_attachment.selector := fsc$tape_file_identifier;
            last_accessed_attrib^ [la_gn].selector := fsc$tape_attachment;
            last_accessed_attrib^ [la_gn].tape_attachment.selector := fsc$tape_generation_number;

            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling FSP$GETTLA - last_accessed - Position FID');
            fsp$get_tape_label_attributes (file_instance^.local_file_name, fsc$tla_last_ansi_file_accessed,
                  last_accessed_attrib^, ignore_returned_attributes, local_status);
            IF local_status.normal THEN
              IF (last_accessed_attrib^ [la_fi].tape_attachment.tape_file_identifier =
                    target_file_identifier) AND (last_accessed_attrib^ [la_gn].tape_attachment.
                    tape_generation_number = target_generation_number) THEN
                rmp$log_debug_message ('LABELED_TAPE_DEBUG: Found target file_identifier');
                rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting POSITION_TO_FILE_IDENTIFIER');
                RETURN;
              ELSEIF (tape_descriptor^.next_position.file_sequence_number = starting_point) AND
                    (rewound_volume_set) THEN
                rmp$log_debug_message ('LABELED_TAPE_DEBUG: Went around the volume set');
                {   * EOF1 EOF2 * HDR1 HDR2* data * EOF1 EOF2*
                {                           ^
                sl_position_after_next_eof (file_identifier, ignore_status);
                {   * EOF1 EOF2 * HDR1 HDR2* data * EOF1 EOF2 * HDR1 etc.
                {                                              ^
                rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting POSITION_TO_FILE_IDENTIFIER');
                osp$set_status_condition (ame$file_not_in_volume_set, status);
                osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name,
                      status);
                RETURN;
              IFEND;
            IFEND;
          ELSEIF (status.condition = ame$file_not_in_volume_set) AND (NOT rewound_volume_set) AND
                (NOT started_at_bos) THEN
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Continuing FID search at BOS');
            rewind_tape (file_identifier, status);
            {   VOL1 HDR1 HDR2* data * EOF1 EOF2*
            {  ^
            rewound_volume_set := TRUE;
          IFEND;
          IF (NOT status.normal) AND sl_irrelevant_condition (status) THEN
            status.normal := TRUE;
          IFEND;
        UNTIL (NOT status.normal);
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Abnormal status terminated search');
        rmp$log_debug_status (status);
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting POSITION_TO_FILE_IDENTIFIER');
      PROCEND position_to_file_identifier;
?? OLDTITLE ??
?? EJECT ??

      CONST
        la_fi = 1,
        la_gn = 2;

      CONST
        np_fsp = 1,
        np_rl = 2;

      VAR
        file_set_position: fst$tape_file_set_position,
        ignore_returned_attributes: fst$tla_returned_attributes,
        ignore_status: ost$status,
        label_group: fst$ansi_label_kinds,
        last_accessed_attrib: ^array [la_fi .. la_gn] of fst$attachment_option,
        next_position_attrib: ^array [np_fsp .. np_rl] of fst$attachment_option;

      status.normal := TRUE;

      IF tape_descriptor^.initial_volume.header_labels = NIL THEN
        tape_descriptor^.next_position.file_section_number := 1;
        tape_descriptor^.next_position.file_sequence_number := 1;
      IFEND;
      PUSH next_position_attrib;
      next_position_attrib^ [np_fsp].selector := fsc$tape_attachment;
      next_position_attrib^ [np_fsp].tape_attachment.selector := fsc$tape_file_set_position;
      next_position_attrib^ [np_rl].selector := fsc$tape_attachment;
      next_position_attrib^ [np_rl].tape_attachment.selector := fsc$tape_rewrite_labels;

      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering IMPLEMENT_FILE_SET_POSITION');
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling FSP$GETTLA - next_position - Getting FSP');
      fsp$get_tape_label_attributes (file_instance^.local_file_name, fsc$tla_next_position,
            next_position_attrib^, ignore_returned_attributes, status);
      IF status.normal THEN
        PUSH last_accessed_attrib;
        last_accessed_attrib^ [la_fi].selector := fsc$tape_attachment;
        last_accessed_attrib^ [la_fi].tape_attachment.selector := fsc$tape_file_identifier;
        last_accessed_attrib^ [la_gn].selector := fsc$tape_attachment;
        last_accessed_attrib^ [la_gn].tape_attachment.selector := fsc$tape_generation_number;

        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling FSP$GETTLA - last_accessed - FSQP or FID');
        fsp$get_tape_label_attributes (file_instance^.local_file_name, fsc$tla_last_ansi_file_accessed,
              last_accessed_attrib^, ignore_returned_attributes, status);
        IF status.normal THEN
          file_set_position := next_position_attrib^ [np_fsp].tape_attachment.tape_file_set_position;
          rewrite_labels := next_position_attrib^ [np_rl].tape_attachment.tape_rewrite_labels;
          IF tape_descriptor^.tape_attachment_information.volume_initialization THEN
            rewind_tape (file_identifier, ignore_status);
            IF rewrite_labels THEN
              sl_put_header_labels (file_identifier, {include_vol1_label=} TRUE, status);
            ELSE
              sl_read_tape_labels (file_identifier, label_group, status);
            IFEND;
            RETURN;
          ELSEIF bap$next_position_is_bos (file_set_position, tape_descriptor,
                last_accessed_attrib^ [la_fi].tape_attachment.tape_file_identifier,
                last_accessed_attrib^ [la_gn].tape_attachment.tape_generation_number) THEN
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Implementing FSP=BOS or equivalent');
            rewind_tape (file_identifier, status);
            IF status.normal THEN
              sl_read_tape_labels (file_identifier, label_group, status);
            IFEND;
          ELSEIF file_set_position.position = fsc$tape_current_file THEN
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Implementing FSP=CURRENT_FILE');
            sl_rewind_ansi_file (file_identifier, status);
          ELSEIF file_set_position.position = fsc$tape_next_file THEN
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Implementing FSP=NEXT_FILE');
            IF tape_descriptor^.rewind_file_command THEN
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Implementing REWIND_FILE_COMMAND');
              sl_rewind_ansi_file (file_identifier, status);
            ELSE
              CASE tape_descriptor^.labeled_volume_position OF
              = bac$lvp_after_header_labels, bac$lvp_within_ansi_file =
                sl_position_after_next_eof (file_identifier, status);
              = bac$lvp_beginning_of_file_set, bac$lvp_after_trailer_labels =
                ;
              = bac$lvp_end_of_file_set, bac$lvp_end_of_volume_list =
                osp$set_status_condition (ame$file_not_in_volume_set, status);
                osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name,
                      status);
              ELSE
              CASEND;
              IF status.normal THEN
                sl_read_tape_labels (file_identifier, label_group, status);
                IF (NOT status.normal) AND (status.condition = ame$unexpected_tapemark) THEN
                  sl_advance_tapemark (file_identifier, amc$backward, 1, status);
                  rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting LVP to end of file set');
                  tape_descriptor^.labeled_volume_position := bac$lvp_end_of_file_set;
                  tape_descriptor^.volume_position := amc$after_tapemark;
                  osp$set_status_condition (ame$file_not_in_volume_set, status);
                  osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name,
                        status);
                IFEND;
              IFEND;
            IFEND;
          ELSEIF file_set_position.position = fsc$tape_end_of_set THEN
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Implementing FSP=EOS');
            position_to_end_of_set (status);
          ELSE {file sequence position or file identifier position}
            rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Value of LVP is: ',
                  $INTEGER (tape_descriptor^.labeled_volume_position));
            rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Current file sequence # is: ',
                  tape_descriptor^.next_position.file_sequence_number);
            CASE file_set_position.position OF
            = fsc$tape_file_sequence_pos =
              rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Proposed file sequence # is: ',
                    file_set_position.file_sequence_number);
            = fsc$tape_file_identifier_pos =
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Last accessed FI: ');
              rmp$log_debug_message (last_accessed_attrib^ [la_fi].tape_attachment.tape_file_identifier);
              rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Last accessed GN: ',
                    last_accessed_attrib^ [la_gn].tape_attachment.tape_generation_number);
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Proposed FI: ');
              rmp$log_debug_message (file_set_position.file_identifier);
              rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Proposed GN: ',
                    file_set_position.generation_number);
            ELSE
            CASEND;

            IF sl_next_position_is_last_file (file_set_position, last_accessed_attrib^ [la_fi].
                  tape_attachment.tape_file_identifier, last_accessed_attrib^ [la_gn].tape_attachment.
                  tape_generation_number) THEN
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Rewinding last ANSI file');
              sl_rewind_ansi_file (file_identifier, status);
            ELSEIF file_set_position.position = fsc$tape_file_sequence_pos THEN
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Implementing FSP=FSP or equivalent');
              sl_position_to_file_seq_number (file_identifier, file_set_position.file_sequence_number,
                    status);
            ELSEIF file_set_position.position = fsc$tape_file_identifier_pos THEN
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Implementing FSP=FIP or equivalent');
              IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
                position_to_file_identifier (file_identifier, tape_descriptor^.next_position.
                      file_sequence_number - 1, file_set_position.file_identifier,
                      file_set_position.generation_number, status);
              ELSE
                position_to_file_identifier (file_identifier, tape_descriptor^.next_position.
                      file_sequence_number, file_set_position.file_identifier,
                      file_set_position.generation_number, status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      IF (NOT status.normal) AND (status.condition = ame$file_not_in_volume_set) THEN
        CASE file_set_position.position OF
        = fsc$tape_beginning_of_set =
          IF state_info^.file_access = bac$write {implies shorten allowed} THEN
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting REWRITE_LABELS to TRUE');
            rewrite_labels := TRUE;
            status.normal := TRUE;
          IFEND;
        = fsc$tape_end_of_set, fsc$tape_next_file =
          CASE state_info^.file_access OF
          = bac$write, bac$append =
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting REWRITE_LABELS to TRUE');
            rewrite_labels := TRUE;
            status.normal := TRUE;
          ELSE
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Not bac$write nor bac$append');
          CASEND;
        = fsc$tape_file_sequence_pos =
          IF file_set_position.file_sequence_number = tape_descriptor^.next_position.file_sequence_number THEN
            CASE state_info^.file_access OF
            = bac$write, bac$append =
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting REWRITE_LABELS to TRUE');
              rewrite_labels := TRUE;
              status.normal := TRUE;
            ELSE
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Neither bac$write nor bac$append');
            CASEND;
          ELSE
            osp$set_status_condition (ame$spec_fsn_out_of_seq, status);
            osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name, status);
          IFEND;
        ELSE
        CASEND;
      IFEND;
      IF status.normal THEN
        IF (tape_descriptor^.volume_number = 1) AND (((tape_descriptor^.next_position.file_sequence_number =
              1) AND (tape_descriptor^.labeled_volume_position = bac$lvp_after_header_labels)) OR
              ((tape_descriptor^.next_position.file_sequence_number = 2) AND
              bap$after_trailer_labels (tape_descriptor^.labeled_volume_position))) THEN

          IF (tape_descriptor^.initial_volume.classification.volume_label_type = rmc$labeled_volume_type)
                AND (state_info^.file_access=bac$write) THEN
            {May set REWRITE_LABELS to TRUE and rewind the tape, if pre-L780 blank labeled}
            adjust_rewrite_labels (rewrite_labels);
          IFEND;

          IF tape_descriptor^.initial_volume.classification.labeled.blank THEN
            rewind_tape (file_identifier, ignore_status);
            CASE state_info^.file_access OF
            = bac$write =
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Forcing REWRITE_LABELS to TRUE');
              rewrite_labels := TRUE;
            = bac$append =
              IF (pfc$append IN file_instance^.instance_attributes.dynamic_label.access_mode) THEN
                rmp$log_debug_message ('LABELED_TAPE_DEBUG: Forcing REWRITE_LABELS to TRUE');
                rewrite_labels := TRUE;
              ELSE
                osp$set_status_condition (ame$blank_volume_read, status);
                osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name,
                      status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      tape_descriptor^.initial_volume.classification.labeled.volume_identifier, status);
              IFEND;
            = bac$read =
              osp$set_status_condition (ame$blank_volume_read, status);
              osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    tape_descriptor^.initial_volume.classification.labeled.volume_identifier, status);
            ELSE
            CASEND;
          IFEND;
        IFEND;
      IFEND;
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting IMPLEMENT_FILE_SET_POSITION');

    PROCEND implement_file_set_position;
?? OLDTITLE ??
?? NEWTITLE := '      implement_open_position', EJECT ??

    PROCEDURE implement_open_position
      (    rewrite_labels: boolean;
       VAR status: ost$status);

      status.normal := TRUE;
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering IMPLEMENT_OPEN_POSITION');
      rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Value of LVP is: ',
            $INTEGER (tape_descriptor^.labeled_volume_position));
      CASE state_info^.file_access OF
      = bac$write =
        IF rewrite_labels THEN
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: bac$write and REWRITE_LABELS=TRUE');
          {
          {  EOF1 EOF2 * HDR1 HDR2* data * EOF1 EOF2*
          {                        ^
          CASE tape_descriptor^.labeled_volume_position OF
          = bac$lvp_beginning_of_file_set =
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Writing File Header Labels at BOS');
            sl_put_header_labels (file_identifier, {include_vol1_label=} TRUE, status);
          = bac$lvp_after_trailer_labels, bac$lvp_end_of_file_set =
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Writing File Header Labels at EOS');
            sl_put_header_labels (file_identifier, {include_vol1_label=} FALSE, status);
          = bac$lvp_after_header_labels, bac$lvp_within_ansi_file =
            sl_advance_tapemark (file_identifier, amc$backward, 2, status);
            IF status.normal THEN
              {
              {  EOF1 EOF2 * HDR1 HDR2* data *EOF1 EOF2*
              {           ^
              sl_advance_tapemark (file_identifier, amc$forward, 1, status);
              IF status.normal THEN
                {
                {  EOF1 EOF2 * HDR1 HDR2* data *EOF1 EOF2*
                {             ^
                rmp$log_debug_message ('LABELED_TAPE_DEBUG: Rewriting File Header Labels');
                tape_descriptor^.labeled_volume_position := bac$lvp_before_header_labels;
                sl_put_header_labels (file_identifier, {include_vol1_label=} FALSE, status);
              IFEND;
            ELSEIF status.condition = ame$skip_encountered_bov THEN
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Rewriting Volume Header Labels');
              IF tape_descriptor^.volume_number = 1 THEN
                rmp$log_debug_message ('LABELED_TAPE_DEBUG: Reset NEXT_POSITION to 1 at BOS');
                tape_descriptor^.labeled_volume_position := bac$lvp_beginning_of_file_set;
                tape_descriptor^.next_position.file_section_number := 1;
                tape_descriptor^.next_position.file_sequence_number := 1;
              IFEND;
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Writing File Header Labels at BOV');
              sl_put_header_labels (file_identifier, {include_vol1_label=} TRUE, status);
            IFEND;
          = bac$lvp_end_of_volume_list =
            amp$set_file_instance_abnormal (file_identifier, ame$tape_end_of_volume_list, operation, '',
                  status);
          CASEND;
        IFEND;
        {
        {  EOF1  EOF2*HDR1 HDR2* data *EOF1 EOF2*
        {                       ^
      = bac$append = {Implies either $EOI, only append access, or both $EOI and append access}
        rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Open Position is: ',
              $INTEGER (file_instance^.instance_attributes.dynamic_label.open_position));
        CASE tape_descriptor^.labeled_volume_position OF
        = bac$lvp_beginning_of_file_set = {Volume must be blank}
          sl_put_header_labels (file_identifier, {include_volume_label} TRUE, status);
        = bac$lvp_end_of_volume_list =
          amp$set_file_instance_abnormal (file_identifier, ame$tape_end_of_volume_list, operation, '',
                status);
        = bac$lvp_end_of_file_set =
          IF pfc$append IN file_instance^.instance_attributes.dynamic_label.access_mode THEN
            sl_put_header_labels (file_identifier, {include_volume_label=} FALSE, status);
          IFEND;
        ELSE
          IF rewrite_labels AND (file_instance^.instance_attributes.dynamic_label.open_position <>
                amc$open_at_eoi) THEN
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: bac$append and rewrite_labels');
            sl_put_header_labels (file_identifier, {include_volume_label=} FALSE, status);
          ELSE
            IF NOT bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: bac$append and/or $EOI');
              sl_position_after_next_eof (file_identifier, status);
              {
              {  EOF1  EOF2*HDR1 HDR2* data *EOF1 EOF2*
              {                                        ^
            IFEND;
            IF status.normal THEN
              sl_reposition_for_put_at_eoi (file_identifier, status);
              {
              {  EOF1  EOF2*HDR1 HDR2* data *EOF1 EOF2*
              {                            ^
            IFEND;
          IFEND;
        CASEND;
      ELSE { state_info^.file_access = bac$read }
      CASEND;
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting IMPLEMENT_OPEN_POSITION');
    PROCEND implement_open_position;
?? OLDTITLE ??
?? EJECT ??

    VAR
      rewrite_labels: boolean;

    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering SL_OPEN_LABEL_FILE');
    implement_file_set_position (rewrite_labels, status);
    IF status.normal AND (NOT tape_descriptor^.tape_attachment_information.volume_initialization) THEN
      implement_open_position (rewrite_labels, status);
      IF status.normal THEN
        adjust_file_attributes (status);
      IFEND;
    IFEND;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_OPEN_LABEL_FILE');

  PROCEND sl_open_label_file;
?? OLDTITLE ??
?? NEWTITLE := '    sl_position_after_next_eof', EJECT ??

  PROCEDURE sl_position_after_next_eof
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

{Design: On entry, the tape could be positioned just about anywhere, including the
{end of the volume set.  We advance volumes, if necessary, to find the next EOF.
{

    VAR
      label_group: fst$ansi_label_kinds;

    {   * EOF1 EOF2* HDR1 HDR2* data * EOF1 EOF2* * *
    {               ?             ?              ?
    status.normal := TRUE;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering SL_POSITION_AFTER_NEXT_EOF');
    rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Value of LVP is: ', $integer(tape_descriptor^.
           labeled_volume_position));

    REPEAT
      sl_find_next_trailer_group (file_identifier, label_group, status);
      IF status.normal THEN
        IF fsp$file_trailer_labels (label_group) THEN
          state_info^.put_op := FALSE;
          file_instance^.previous_get_at_eoi := FALSE;
          {   * EOF1 EOF2* HDR1 HDR2* data * EOF1 EOF2* HDR1 HDR2
          {                                            ^
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_POSITION_AFTER_NEXT_EOF - success');
          RETURN;
        ELSEIF fsp$volume_trailer_labels (label_group) THEN
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Read volume trailer labels');
          sl_advance_volume (file_identifier, status);
          {   VOL1 HDR1 HDR2* data * EOF1 EOF2*
          {  ^
        IFEND;
      IFEND;
    UNTIL NOT status.normal;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_POSITION_AFTER_NEXT_EOF - abnormal status');
    rmp$log_debug_status (status);

  PROCEND sl_position_after_next_eof;
?? OLDTITLE ??
?? NEWTITLE := '    sl_position_to_file_seq_number', EJECT ??
  PROCEDURE sl_position_to_file_seq_number
    (    file_identifier: amt$file_identifier;
         target_file_seq_number: 1 .. 9999;
     VAR status: ost$status);

    status.normal := TRUE;

    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering SL_POSITION_TO_FILE_SEQ_NUMBER');
    rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Positioning to file sequence #', target_file_seq_number);
    rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Value of LVP is: ', $integer(tape_descriptor^.
           labeled_volume_position));
    IF target_file_seq_number < tape_descriptor^.next_position.file_sequence_number THEN
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Rewinding volume set');
      rewind_tape (file_identifier, status);
      {   VOL1 HDR1 HDR2* data * EOF1 EOF2*
      {  ^
    IFEND;

    IF status.normal THEN
      IF target_file_seq_number < tape_descriptor^.next_position.file_sequence_number THEN
        {The value in the first HDR1 label of the file set is greater than the request}
        osp$set_status_condition (ame$fsn_out_of_sequence, status);
        osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name, status);
      ELSE
        REPEAT
          sl_find_next_header_group (file_identifier, status);
          {   * EOF1 EOF2 * HDR1 HDR2 * data * EOF1 EOF2*
          {                          ^
        UNTIL (target_file_seq_number = tape_descriptor^.next_position.file_sequence_number) OR
              ((NOT status.normal) AND (NOT sl_irrelevant_condition (status)));
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_POSITION_TO_FILE_SEQ_NUMBER');
        rmp$log_debug_status (status);
      IFEND;
    IFEND;
  PROCEND sl_position_to_file_seq_number;
?? OLDTITLE ??
?? NEWTITLE := '    sl_preauthorize_access_method', EJECT ??

  PROCEDURE sl_preauthorize_access_method
    (    file_identifier: amt$file_identifier;
         access_method: amt$file_label_type;
     VAR status: ost$status);

    VAR
      tape_security_call_block: fst$tape_security_call_block;

    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering SL_PREAUTHORIZE_ACCESS_METHOD');
    tape_security_call_block.operation := fsc$ts_authorize_access_method;
    tape_security_call_block.authorize_access_method.access_method := access_method;
    sl_enforce_tape_security (file_identifier, tape_security_call_block, status);
    IF NOT status.normal THEN
      rmp$log_debug_status (status);
    IFEND;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_PREAUTHORIZE_ACCESS_METHOD');

  PROCEND sl_preauthorize_access_method;
?? OLDTITLE ??
?? NEWTITLE := '    sl_put_end_of_file_labels', EJECT ??

  PROCEDURE sl_put_end_of_file_labels
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      attachment_options: ^array [1 .. 1] of fst$attachment_option,
      block_count: 0 .. 999999,
      ignore_returned_attributes: fst$tla_returned_attributes,
      trailer_labels: ^SEQ (REP 1 of fst$tape_label_sequence_header, REP 4 of fst$tape_label_block_descriptor,
            {tapemark} REP 1 of fst$ansi_eof1_label, REP 1 of fst$ansi_eof2_label {tapemark} );

    status.normal := TRUE;
    rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Value of LVP is: ',
          $INTEGER (tape_descriptor^.labeled_volume_position));
    flush_req (file_identifier, status);
    IF status.normal THEN
      PUSH trailer_labels;
      PUSH attachment_options;
      attachment_options^ [1].selector := fsc$tape_attachment;
      attachment_options^ [1].tape_attachment.selector := fsc$tape_trailer_labels;
      attachment_options^ [1].tape_attachment.tape_trailer_labels := trailer_labels;

      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling FSP$GETTLA - next_position - Getting TRL');
      fsp$get_tape_label_attributes (file_instance^.local_file_name, fsc$tla_next_position,
            attachment_options^, ignore_returned_attributes, status);
      IF status.normal THEN
        sl_adjust_trailer_labels (file_identifier, trailer_labels, fsc$ansi_eof_label_identifier, status);
        IF status.normal THEN
          sl_put_trailer_labels (file_identifier, trailer_labels, status);
          IF status.normal THEN
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting LVP to end of file set');
            tape_descriptor^.labeled_volume_position := bac$lvp_end_of_file_set;
            file_instance^.previous_get_at_eoi := FALSE;
            tape_descriptor^.next_position.file_section_number := 1;
            sl_increment_file_sequence_no;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND sl_put_end_of_file_labels;
?? OLDTITLE ??
?? NEWTITLE := '    sl_put_end_of_vol_labels', EJECT ??

  PROCEDURE sl_put_end_of_vol_labels
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      attachment_options: ^array [1 .. 1] of fst$attachment_option,
      block_count: 0 .. 999999,
      ignore_returned_attributes: fst$tla_returned_attributes,
      trailer_labels: ^SEQ (REP 1 of fst$tape_label_sequence_header, REP 4 of fst$tape_label_block_descriptor,
            {tapemark} REP 1 of fst$ansi_eof1_label, REP 1 of fst$ansi_eof2_label {tapemark} );

    status.normal := TRUE;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering SL_PUT_END_OF_VOL_LABELS');
    rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Value of LVP is: ',
          $INTEGER (tape_descriptor^.labeled_volume_position));
    PUSH trailer_labels;
    PUSH attachment_options;
    attachment_options^ [1].selector := fsc$tape_attachment;
    attachment_options^ [1].tape_attachment.selector := fsc$tape_trailer_labels;
    attachment_options^ [1].tape_attachment.tape_trailer_labels := trailer_labels;

    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling FSP$GETTLA - next_position - Getting TRL');
    fsp$get_tape_label_attributes (file_instance^.local_file_name, fsc$tla_next_position, attachment_options^,
          ignore_returned_attributes, status);
    IF status.normal THEN
      sl_adjust_trailer_labels (file_identifier, trailer_labels, fsc$ansi_eov_label_identifier, status);
      IF status.normal THEN
        sl_put_trailer_labels (file_identifier, trailer_labels, status);
        IF status.normal THEN
          rmp$log_debug_integer ('LABELED_TAPE_DEBUG: FILE_SECTION_NUMBER was: ',
                tape_descriptor^.next_position.file_section_number);
          tape_descriptor^.next_position.file_section_number :=
                tape_descriptor^.next_position.file_section_number + 1;
          rmp$log_debug_integer ('LABELED_TAPE_DEBUG: FILE_SECTION_NUMBER incremented to: ',
                tape_descriptor^.next_position.file_section_number);
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting LVP to after trailer labels');
          tape_descriptor^.labeled_volume_position := bac$lvp_after_trailer_labels;
        IFEND;
      IFEND;
    IFEND;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_PUT_END_OF_VOL_LABELS');

  PROCEND sl_put_end_of_vol_labels;
?? OLDTITLE ??
?? NEWTITLE := '    sl_put_header_labels', EJECT ??
  PROCEDURE sl_put_header_labels
    (    file_identifier: amt$file_identifier;
         include_vol1_label: boolean;
     VAR status: ost$status);

    CONST
      hl = 1;

    VAR
      attachment_options: ^array [hl .. hl] of fst$attachment_option,
      call_block: amt$call_block,
      ignore_returned_attributes: fst$tla_returned_attributes,
      header_labels: ^SEQ (REP 1 of fst$tape_label_sequence_header, REP 4 of fst$tape_label_block_descriptor,
            REP 1 of fst$ansi_vol1_label, REP 1 of fst$ansi_hdr1_label, REP 1 of fst$ansi_hdr2_label)
            {tapemark} ,
      label_identifier: fst$tape_label_identifier,
      label_locator: fst$tape_label_locator,
      secured_sequence: ^SEQ ( * ),
      sequence_header: ^fst$tape_label_sequence_header,
      tape_security_call_block: fst$tape_security_call_block,
      unsecured_sequence: ^SEQ ( * );

    status.normal := TRUE;
    rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Value of LVP is: ',
          $INTEGER (tape_descriptor^.labeled_volume_position));

    IF tape_descriptor^.tape_attachment_information.volume_initialization THEN
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling SL_AUTHORIZE_WRITE_ACCESS');
      sl_authorize_write_access (file_identifier, tape_descriptor^.tape_attachment_information.
            tape_volume_initialization.blank_label_group, include_vol1_label, status);
    ELSE
      PUSH header_labels;

      PUSH attachment_options;
      attachment_options^ [hl].selector := fsc$tape_attachment;
      attachment_options^ [hl].tape_attachment.selector := fsc$tape_header_labels;
      attachment_options^ [hl].tape_attachment.tape_header_labels := header_labels;

      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling FSP$GETTLA - next_position - Getting HDRL');
      fsp$get_tape_label_attributes (file_instance^.local_file_name, fsc$tla_next_position,
            attachment_options^, ignore_returned_attributes, status);
      IF status.normal THEN
        RESET header_labels;
        IF NOT include_vol1_label THEN
          NEXT sequence_header IN header_labels;
          IF sequence_header <> NIL THEN
            sequence_header^.label_kinds := sequence_header^.label_kinds -
                  $fst$ansi_label_kinds [fsc$ansi_vol1_label_kind];
          IFEND;
          label_identifier.location_method := fsc$tape_label_locate_by_kind;
          label_identifier.label_kind := fsc$ansi_vol1_label_kind;
          fsp$locate_tape_label (header_labels, label_identifier, label_locator);

          IF label_locator.label_found THEN
            label_locator.label_block_descriptor^.label_block_type := fsc$null_tape_label_block;
          IFEND;
        IFEND;
        IF include_vol1_label OR (tape_descriptor^.labeled_volume_position = bac$lvp_before_header_labels)
              THEN
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling SL_AUTHORIZE_WRITE_ACCESS');
          sl_authorize_write_access (file_identifier, header_labels, include_vol1_label, status);
        IFEND;
        IF status.normal THEN
          call_block.operation := amc$write_tape_labels;
          call_block.write_tape_labels := header_labels;
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling FAP to write header labels');
          amp$access_method (file_identifier, call_block, global_layer_number, status);
        IFEND;
      IFEND;

      IF status.normal THEN
        bov_position := FALSE;
        state_info^.eoi_labels_needed := TRUE;
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting LVP to after header labels');
        tape_descriptor^.labeled_volume_position := bac$lvp_after_header_labels;
        tape_descriptor^.volume_position := amc$after_tapemark;

        unsecured_sequence := tape_descriptor^.last_accessed.unsecured_header_labels;
        IF unsecured_sequence <> NIL THEN
          RESET unsecured_sequence;
          NEXT sequence_header IN unsecured_sequence;
          IF sequence_header <> NIL THEN
            PUSH secured_sequence: [[REP sequence_header^.sequence_size OF cell]];
            RESET secured_sequence;
            RESET unsecured_sequence;
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Making working copy of secured labels');
            secured_sequence^ := unsecured_sequence^;
            tape_security_call_block.operation := fsc$ts_secure_header_labels;
            tape_security_call_block.secure_header_labels.header_labels := secured_sequence;
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling FAP to secure header labels');
            sl_enforce_tape_security (file_identifier, tape_security_call_block, status);
            IF status.normal THEN
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Storing secured header labels');
              tape_descriptor^.last_accessed.secured_header_labels^ := secured_sequence^;
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting AT_EOI to TRUE; blank volume append');
              tape_descriptor^.at_eoi := TRUE;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND sl_put_header_labels;
?? OLDTITLE ??
?? NEWTITLE := '    sl_put_trailer_labels', EJECT ??

  PROCEDURE sl_put_trailer_labels
    (    file_identifier: amt$file_identifier;
         label_sequence: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      call_block: amt$call_block,
      ignore_status: ost$status,
      secured_sequence: ^SEQ ( * ),
      sequence_header: ^fst$tape_label_sequence_header,
      tape_failure_modes: amt$tape_failure_modes,
      tape_security_call_block: fst$tape_security_call_block,
      trailer_labels: ^SEQ ( * ),
      unsecured_sequence: ^SEQ ( * );

    status.normal := TRUE;
    rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Value of LVP is: ', $integer(tape_descriptor^.
           labeled_volume_position));
    trailer_labels := label_sequence;
    RESET trailer_labels;
    call_block.operation := amc$write_tape_labels;
    call_block.write_tape_labels := trailer_labels;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling FAP to write trailer labels');
    amp$access_method (file_identifier, call_block, global_layer_number, status);

    IF status.normal THEN
      bap$tape_bm_write_label_mark (file_identifier, {system_media_recovery=} TRUE, tape_failure_modes,
            status);
      IF status.normal THEN
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Wrote 2ND tapemark');
        bap$tape_bm_write_label_mark (file_identifier, {system_media_recovery=} TRUE, tape_failure_modes,
              status);
        IF status.normal THEN
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Wrote 3RD tapemark');
          sl_advance_tapemark (file_identifier, amc$backward, 2, ignore_status);
        ELSE
          sl_advance_tapemark (file_identifier, amc$backward, 1, ignore_status);
          tape_descriptor^.failure_isolation.failure_modes := tape_failure_modes;
          tape_descriptor^.failure_isolation.failed_at_current_position := TRUE;
        IFEND;
      ELSE
        tape_descriptor^.failure_isolation.failure_modes := tape_failure_modes;
        tape_descriptor^.failure_isolation.failed_at_current_position := TRUE;
      IFEND;
      tape_descriptor^.volume_position := amc$after_tapemark;
    IFEND;
    state_info^.eoi_labels_needed := FALSE;

    unsecured_sequence := tape_descriptor^.last_accessed.unsecured_trailer_labels;
    RESET unsecured_sequence;
    NEXT sequence_header IN unsecured_sequence;
    IF sequence_header <> NIL THEN
      PUSH secured_sequence: [[REP sequence_header^.sequence_size OF cell]];
      RESET secured_sequence;
      RESET unsecured_sequence;
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Making working copy of secured labels');
      secured_sequence^ := unsecured_sequence^;
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling FAP to secure trailer labels');
      tape_security_call_block.operation := fsc$ts_secure_trailer_labels;
      tape_security_call_block.secure_trailer_labels.trailer_labels := secured_sequence;
      sl_enforce_tape_security (file_identifier, tape_security_call_block, status);
      IF status.normal THEN
        tape_descriptor^.last_accessed.secured_trailer_labels^ := secured_sequence^;
      IFEND;
    IFEND;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting AT_EOI to TRUE');
    tape_descriptor^.at_eoi := TRUE;

  PROCEND sl_put_trailer_labels;
?? OLDTITLE ??
?? NEWTITLE := '    sl_read_tape_labels', EJECT ??
  PROCEDURE sl_read_tape_labels
    (    file_identifier: amt$file_identifier;
     VAR label_group: fst$ansi_label_kinds;
     VAR status: ost$status);

    CONST
      bc = 1;

?? NEWTITLE := '      process_header_labels ', EJECT ??

    PROCEDURE process_header_labels;

?? NEWTITLE := '        initialize_next_position' ??

      PROCEDURE initialize_next_position
        (    header_labels: ^SEQ ( * ));

{Design: The purpose of this procedure is to support a user who mounts a subset of
{a volume set omitting the first volume of the set.  A warning message is logged and
{the FILE_SECTION_NUMBER and FILE_SEQUENCE_NUMBER are initialized from the first
{volume of the subset.  This requires a user who positions by FILE_SEQUENCE_NUMBER
{to use values originally written with the volume set, i.e. the first file of the
{subset may have a file sequence number > 1.

        VAR
          file_section_no: clt$integer,
          file_section_number: 1 .. 9999,
          file_sequence_no: clt$integer,
          file_sequence_number: 1 .. 9999,
          hdr1_label: ^fst$ansi_hdr1_label,
          ignore_status: ost$status,
          label_identifier: fst$tape_label_identifier,
          label_locator: fst$tape_label_locator,
          local_status: ost$status,
          vol1_label: ^fst$ansi_vol1_label;

        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering INITIALIZE_NEXT_POSITION');

        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Volume 1 - setting FSEC&FSEQ to 1');
        tape_descriptor^.next_position.file_section_number := 1;
        tape_descriptor^.next_position.file_sequence_number := 1;

        label_identifier.location_method := fsc$tape_label_locate_by_kind;
        label_identifier.label_kind := fsc$ansi_vol1_label_kind;
        fsp$locate_tape_label (header_labels, label_identifier, label_locator);
        IF label_locator.label_found THEN
          RESET label_locator.label_block;
          NEXT vol1_label IN label_locator.label_block;
          label_identifier.label_kind := fsc$ansi_hdr1_label_kind;
          fsp$locate_tape_label (header_labels, label_identifier, label_locator);
          IF (vol1_label <> NIL) AND label_locator.label_found THEN
            RESET label_locator.label_block;
            NEXT hdr1_label IN label_locator.label_block;
            IF (hdr1_label <> NIL) THEN
              file_sequence_number := 1;
              IF (hdr1_label^.file_sequence_number <> ' ') THEN
                clp$convert_string_to_integer (hdr1_label^.file_sequence_number, file_sequence_no,
                      local_status);
                IF local_status.normal AND (file_sequence_no.value > 1) AND
                      (file_sequence_no.value <= 9999) THEN
                  file_sequence_number := file_sequence_no.value;
                IFEND;
              IFEND;
              file_section_number := 1;
              IF (hdr1_label^.file_section_number <> ' ') THEN
                clp$convert_string_to_integer (hdr1_label^.file_section_number, file_section_no,
                      local_status);
                IF local_status.normal AND (file_section_no.value > 1) AND
                      (file_section_no.value <= 9999) THEN
                  file_section_number := file_section_no.value;
                IFEND
              IFEND;
              IF (file_sequence_number > 1) OR (file_section_number > 1) THEN
                IF ((pfc$read IN file_instance^.instance_attributes.dynamic_label.access_mode) AND
                      (file_section_number > 1)) THEN
                  osp$set_status_condition (ame$not_initial_volume_of_set, local_status);
                  osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name,
                        local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        vol1_label^.volume_identifier, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        hdr1_label^.file_identifier, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        hdr1_label^.file_section_number, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        hdr1_label^.file_sequence_number, local_status);
                  osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
                IFEND;
              IFEND;
              IF file_sequence_number > 1 THEN
                rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Setting FILE_SEQUENCE_NUMBER from HDR1 label: ',
                      file_sequence_number);
                tape_descriptor^.next_position.file_sequence_number := file_sequence_number;
              IFEND;
              IF file_section_number > 1 THEN
                rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Setting FILE_SECTION_NUMBER from HDR1 label: ',
                      file_section_number);
                tape_descriptor^.next_position.file_section_number := file_section_number;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting INITIALIZE_NEXT_POSITION');
      PROCEND initialize_next_position;
?? OLDTITLE, EJECT ??

      VAR
        call_block: amt$call_block,
        secured_sequence: ^SEQ ( * ),
        sequence_header: ^fst$tape_label_sequence_header,
        tape_security_call_block: fst$tape_security_call_block,
        unsecured_sequence: ^SEQ ( * );

      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering PROCESS_HEADER_LABELS');
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting LVP to after header labels');
      tape_descriptor^.labeled_volume_position := bac$lvp_after_header_labels;
      unsecured_sequence := tape_descriptor^.last_accessed.unsecured_header_labels;
      IF unsecured_sequence <> NIL THEN
        RESET unsecured_sequence;
        NEXT sequence_header IN unsecured_sequence;
        IF sequence_header <> NIL THEN
          PUSH secured_sequence: [[REP sequence_header^.sequence_size OF cell]];
          RESET secured_sequence;
          RESET unsecured_sequence;
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Making working copy of secured labels');
          secured_sequence^ := unsecured_sequence^;
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling FAP to validate header labels');
          tape_security_call_block.operation := fsc$ts_validate_header_labels;
          tape_security_call_block.validate_header_labels.header_labels := secured_sequence;
          sl_enforce_tape_security (file_identifier, tape_security_call_block, status);
          IF status.normal THEN
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Successfully validated header labels');
            rmp$log_debug_message (
                  'LABELED_TAPE_DEBUG: Calling bap$store_unsecured_tape_labels for header labels');
            bap$store_unsecured_tape_labels (secured_sequence,
                  tape_descriptor^.last_accessed.unsecured_header_labels);
            tape_security_call_block.operation := fsc$ts_secure_header_labels;
            tape_security_call_block.secure_header_labels.header_labels := secured_sequence;
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling FAP to secure header labels');
            sl_enforce_tape_security (file_identifier, tape_security_call_block, status);
            IF status.normal THEN
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Moving secured header labels to tape_descriptor');
              tape_descriptor^.last_accessed.secured_header_labels^ := secured_sequence^;
              IF fsp$volume_header_labels (label_group) AND (tape_descriptor^.volume_number = 1) THEN
                initialize_next_position (secured_sequence);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting PROCESS_HEADER_LABELS');
    PROCEND process_header_labels;
?? OLDTITLE ??
?? NEWTITLE := '      process_trailer_labels ', EJECT ??

    PROCEDURE process_trailer_labels;

      CONST
        read_mode = 'READ';

      VAR
        ansi_file_attrib: ^array [1 .. 1] of fst$attachment_option,
        call_block: amt$call_block,
        ignore_returned_attributes: fst$tla_returned_attributes,
        secured_sequence: ^SEQ ( * ),
        sequence_header: ^fst$tape_label_sequence_header,
        tape_security_call_block: fst$tape_security_call_block,
        unsecured_sequence: ^SEQ ( * );

      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering PROCESS_TRAILER_LABELS');
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting LVP to after trailer labels');
      tape_descriptor^.labeled_volume_position := bac$lvp_after_trailer_labels;
      unsecured_sequence := tape_descriptor^.last_accessed.unsecured_trailer_labels;
      RESET unsecured_sequence;
      NEXT sequence_header IN unsecured_sequence;
      IF sequence_header <> NIL THEN
        PUSH secured_sequence: [[REP sequence_header^.sequence_size OF cell]];
        RESET secured_sequence;
        RESET unsecured_sequence;
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Making working copy of secured labels');
        secured_sequence^ := unsecured_sequence^;
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling FAP to validate trailer labels');
        tape_security_call_block.operation := fsc$ts_validate_trailer_labels;
        tape_security_call_block.validate_trailer_labels.trailer_labels := secured_sequence;
        sl_enforce_tape_security (file_identifier, tape_security_call_block, status);
        IF status.normal THEN
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Successfully validated trailer labels');
          rmp$log_debug_message (
                'LABELED_TAPE_DEBUG: Calling bap$store_unsecured_tape_labels for trailer labels');
          bap$store_unsecured_tape_labels (secured_sequence,
                tape_descriptor^.last_accessed.unsecured_trailer_labels);
          tape_security_call_block.operation := fsc$ts_secure_trailer_labels;
          tape_security_call_block.secure_trailer_labels.trailer_labels := secured_sequence;
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling FAP to secure trailer labels');
          sl_enforce_tape_security (file_identifier, tape_security_call_block, status);
          IF status.normal THEN
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Moving secured trailer labels to tape_descriptor');
            tape_descriptor^.last_accessed.secured_trailer_labels^ := secured_sequence^;
            PUSH ansi_file_attrib;
            ansi_file_attrib^ [bc].selector := fsc$tape_attachment;
            ansi_file_attrib^ [bc].tape_attachment.selector := fsc$tape_block_count;

            fsp$get_tape_label_attributes (file_instance^.local_file_name, fsc$tla_last_ansi_file_accessed,
                  ansi_file_attrib^, ignore_returned_attributes, status);

            IF status.normal THEN
              state_info^.eof1_block_count := ansi_file_attrib^ [bc].tape_attachment.tape_block_count;
              IF fsp$file_trailer_labels (label_group) THEN
                IF state_info^.file_access <> bac$append THEN
                  tape_descriptor^.next_position.file_section_number := 1;
                IFEND;
                sl_log_eof_block_count (ansi_file_attrib^ [bc].tape_attachment.tape_block_count, read_mode);
                rmp$log_debug_message ('LABELED_TAPE_DEBUG: Incrementing FILE_SEQUENCE_NUMBER');
                sl_increment_file_sequence_no;
                rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting AT_EOI to TRUE');
                tape_descriptor^.at_eoi := TRUE;
              ELSEIF fsp$volume_trailer_labels (label_group) THEN
                rmp$log_debug_integer ('LABELED_TAPE_DEBUG: FILE_SECTION_NUMBER was: ',
                      tape_descriptor^.next_position.file_section_number);
                sl_log_eov_block_count (ansi_file_attrib^ [bc].tape_attachment.tape_block_count, read_mode);
                tape_descriptor^.next_position.file_section_number :=
                      tape_descriptor^.next_position.file_section_number + 1;
                rmp$log_debug_integer ('LABELED_TAPE_DEBUG: FILE_SECTION_NUMBER incremented to: ',
                      tape_descriptor^.next_position.file_section_number);
                rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting LVP to after trailer labels');
                tape_descriptor^.labeled_volume_position := bac$lvp_after_trailer_labels;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting PROCESS_TRAILER_LABELS');
    PROCEND process_trailer_labels;
?? OLDTITLE, EJECT ??

    VAR
      call_block: amt$call_block,
      initial_volume_position: amt$volume_position,
      read_labels_status: ost$status,
      read_tape_labels: amt$read_tape_labels;

    status.normal := TRUE;

    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering SL_READ_TAPE_LABELS');
    initial_volume_position := tape_descriptor^.volume_position;

    call_block.operation := amc$read_tape_labels;
    call_block.read_tape_labels := ^read_tape_labels;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling FAP to read labels');
    amp$access_method (file_identifier, call_block, global_layer_number, read_labels_status);

    IF read_labels_status.normal THEN
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Successfully read labels');
      label_group := read_tape_labels.label_kinds;
      IF fsp$header_labels (label_group) THEN
        process_header_labels;
        IF status.normal THEN
          IF (NOT tape_descriptor^.tape_attachment_information.volume_initialization) THEN
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling SL_AUTHORIZE_ACCESS - normal');
            sl_authorize_access (file_identifier, label_group, read_labels_status, status);
          IFEND;
        IFEND;
      ELSEIF fsp$trailer_labels (label_group) THEN
        process_trailer_labels;
      IFEND;
    ELSE
      status := read_labels_status;
      CASE read_labels_status.condition OF
      = ame$invalid_tape_label, ame$unexpected_tapemark =
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting LVP to within ANSI file');
        tape_descriptor^.labeled_volume_position := bac$lvp_within_ansi_file;
      ELSE
      CASEND;
      IF NOT tape_descriptor^.tape_attachment_information.volume_initialization THEN
        IF tape_descriptor^.initial_volume.initial_read_labels_attempt AND (initial_volume_position =
              amc$bov) THEN
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling SL_AUTHORIZE_ACCESS - abnormal');
          status.normal := TRUE;
          sl_authorize_access (file_identifier, $fst$ansi_label_kinds [], read_labels_status, status);
          tape_descriptor^.initial_volume.initial_read_labels_attempt := NOT status.normal;
        IFEND;
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Failed to read labels');
      IFEND;
    IFEND;
    rmp$log_debug_status (status);
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_READ_TAPE_LABELS');
  PROCEND sl_read_tape_labels;
?? OLDTITLE ??
?? NEWTITLE := '    sl_reposition_for_put_at_eoi', EJECT ??
  PROCEDURE sl_reposition_for_put_at_eoi
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

    status.normal := TRUE;

    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering SL_REPOSITION_FOR_PUT_AT_EOI');
    rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Value of LVP is: ', $integer(tape_descriptor^.
           labeled_volume_position));
    sl_advance_tapemark (file_identifier, amc$backward, 2, status);
    IF status.normal THEN
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting LVP to within ANSI file');
      tape_descriptor^.labeled_volume_position := bac$lvp_within_ansi_file;
      IF state_info^.eof1_block_count = 0 THEN
        gfi^.positioning_info.block_info.block_number := 1;
        bov_position := FALSE;
        tape_descriptor^.volume_position := amc$before_tapemark;
      ELSE
        gfi^.positioning_info.block_info.block_number := state_info^.eof1_block_count;
        bov_position := FALSE;
        tape_descriptor^.volume_position := amc$after_data_block;
      IFEND;
      gfi^.positioning_info.record_info.file_position := amc$eoi;
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting AT_EOI to TRUE');
      tape_descriptor^.at_eoi := TRUE;
      sl_decrement_file_sequence_no;
    IFEND;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_REPOSITION_FOR_PUT_AT_EOI');

  PROCEND sl_reposition_for_put_at_eoi;
?? OLDTITLE ??
?? NEWTITLE := '    sl_rewind_ansi_file', EJECT ??
  PROCEDURE sl_rewind_ansi_file
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

{Design: The intent of this procedure is to rewind the current ANSI file to BOI.
{If the ANSI file begins on the current volume, this is just a matter of positioning
{after the most recent file header labels.  However, embedded tapemarks make the
{process of finding the most recent file header labels more difficult.  If the ANSI
{file began on a previous volume, we rewind the volume set and position forward by
{file sequence number until we find the original ANSI file.

    VAR
      attachment_options: ^array [1 .. 1] of fst$attachment_option,
      decrement_file_sequence: boolean,
      encountered_bov: boolean,
      error_action: bat$error_actions,
      label_group: fst$ansi_label_kinds,
      request_status: ost$status,
      returned_attributes: fst$tla_returned_attributes,
      skip_count: amt$skip_count,
      tape_failure_modes: amt$tape_failure_modes,
      target_file_sequence_no: 1 .. 9999;

    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering SL_REWIND_ANSI_FILE');
    rmp$log_debug_integer ('LABELED_TAPE_DEBUG: Value of LVP is: ',
          $INTEGER (tape_descriptor^.labeled_volume_position));

    status.normal := TRUE;
    decrement_file_sequence := FALSE;

    IF state_info^.put_op OR state_info^.eoi_labels_needed THEN
      rmp$log_debug_message ('Calling SL_PUT_END_OF_FILE_LABELS from SL_REWIND_ANSI_FILE');
      sl_put_end_of_file_labels (file_identifier, status);
      IF status.normal THEN
        sl_enable_read_after_write (file_identifier, status);
      IFEND;
      state_info^.put_op := FALSE;
    ELSE
      bap$tape_bm_align_position (file_identifier, tape_failure_modes, request_status);
      bai$process_request_status (file_identifier, amc$rewind_req, request_status, tape_failure_modes,
            error_action, status);
    IFEND;

    IF status.normal THEN
      PUSH attachment_options;
      attachment_options^ [1].selector := fsc$tape_attachment;
      attachment_options^ [1].tape_attachment.selector := fsc$tape_file_section_number;
      fsp$get_tape_label_attributes (file_instance^.local_file_name, fsc$tla_last_ansi_file_accessed,
            attachment_options^, returned_attributes, status);
      IF status.normal THEN
        rmp$log_debug_integer ('LABELED_TAPE_DEBUG: File Section Number is: ',
              attachment_options^ [1].tape_attachment.tape_file_section_number);
        IF (tape_descriptor^.initial_volume.header_labels = NIL) OR
              (tape_descriptor^.next_position.file_sequence_number = 1) OR
              ((tape_descriptor^.next_position.file_sequence_number = 2) AND
              bap$after_trailer_labels (tape_descriptor^.labeled_volume_position)) OR
              ((fsc$tape_file_section_number IN returned_attributes) AND
              (attachment_options^ [1].tape_attachment.tape_file_section_number <> 1)) THEN
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Rewinding volume set');
          IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
            target_file_sequence_no := tape_descriptor^.next_position.file_sequence_number - 1;
          ELSE
            target_file_sequence_no := tape_descriptor^.next_position.file_sequence_number;
          IFEND;
          rewind_tape (file_identifier, status);
          IF status.normal THEN
            file_instance^.previous_get_at_eoi := FALSE;
            sl_position_to_file_seq_number (file_identifier, target_file_sequence_no, status);
          IFEND;
        ELSE
          rmp$log_debug_message ('LABELED_TAPE_DEBUG: Current file on current volume');
          IF tape_descriptor^.volume_position <> amc$bov THEN
            IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
              decrement_file_sequence := TRUE;
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: At END_OF_FILE_SET; Back 4 TMK');
              {   * EOF1 EOF2 * HDR1 HDR2* data * EOF1 EOF2* * *
              {                                             ^
              sl_advance_tapemark (file_identifier, amc$backward, 4, status);
            ELSE
              decrement_file_sequence := FALSE;
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: After header labels; Back 2 TMK');
              {   * EOF1 EOF2 * HDR1 HDR2* data * EOF1 EOF2*
              {                               ^
              sl_advance_tapemark (file_identifier, amc$backward, 2, status);
            IFEND;
            IF status.normal THEN
              file_instance^.previous_get_at_eoi := FALSE;
              {   * EOF1 EOF2 * HDR1 HDR2* data * EOF1 EOF2*
              {              ^
              sl_advance_tapemark (file_identifier, amc$forward, 1, status);
              {   * EOF1 EOF2 * HDR1 HDR2* data * EOF1 EOF2*
              {                ^
              bai$rewind_gfi;
            ELSEIF status.condition = ame$skip_encountered_bov THEN
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Encountered BOV');
              IF tape_descriptor^.volume_number = 1 THEN
                bai$init_boi_tape_position;
              ELSE
                bai$rewind_gfi;
              IFEND;
              status.normal := TRUE;
            ELSE
              rmp$log_debug_message ('LABELED_TAPE_DEBUG: Backward TMK skip failed');
              rmp$log_debug_status (status);
            IFEND;
          IFEND;
          IF status.normal THEN
            encountered_bov := FALSE;
            REPEAT
              sl_read_tape_labels (file_identifier, label_group, status);
              IF (status.normal AND fsp$file_header_labels (label_group)) THEN
                rmp$log_debug_message ('LABELED_TAPE_DEBUG: Setting LVP to after header labeels');
                IF decrement_file_sequence THEN
                  sl_decrement_file_sequence_no;
                IFEND;
                {   * EOF1  EOF2 * HDR1 HDR2* data * EOF1 EOF2*
                {                            ^
                rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_REWIND_ANSI_FILE - success');
                RETURN;
              ELSEIF status.condition = ame$unexpected_tapemark THEN
                {   * EOF1 EOF2 * HDR1 HDR2 * * data * EOF1 EOF2*
                {                              ^
                sl_advance_tapemark (file_identifier, amc$backward, 3, status);
              ELSEIF status.condition = ame$invalid_tape_label THEN
                {   * EOF1 EOF2 * HDR1 HDR2* data * data * EOF1 EOF2*
                {                                  ^
                sl_advance_tapemark (file_identifier, amc$backward, 2, status);
              IFEND;
              IF status.normal THEN
                sl_advance_tapemark (file_identifier, amc$forward, 1, status);
                {   * EOF1 EOF2 * HDR1 HDR2* data * EOF1 EOF2*
                {                ^
              ELSEIF (status.condition = ame$skip_encountered_bov) AND (NOT encountered_bov) THEN
                rmp$log_debug_message ('LABELED_TAPE_DEBUG: Encountered BOV');
                encountered_bov := TRUE;
                status.normal := TRUE;
              ELSEIF encountered_bov THEN
                osp$set_status_condition (ame$label_sequence_error, status);
              IFEND;
            UNTIL (NOT status.normal);
            rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting SL_REWIND_ANSI_FILE -failure');
            rmp$log_debug_status (status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND sl_rewind_ansi_file;
?? OLDTITLE ??
?? NEWTITLE := '    sl_setup_volume_initialization', EJECT ??
  PROCEDURE sl_setup_volume_initialization
    (VAR status: ost$status);

    VAR
      logical_unit: iot$logical_unit;

    status.normal := TRUE;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Entering sl_setup_volume_initialization');
    IF tape_descriptor^.tape_attachment_information.tape_volume_initialization.element <> osc$null_name THEN
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling cmp$get_logical_unit_number_r3');
      cmp$get_logical_unit_number_r3 (tape_descriptor^.tape_attachment_information.tape_volume_initialization.
            element, logical_unit, status);
      IF status.normal THEN
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling dmp$validate_tape_element');
        dmp$validate_tape_element (logical_unit, tape_descriptor^.requested_density, status);
      IFEND;
    ELSE
      logical_unit := 0;
    IFEND;
    IF status.normal THEN
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Calling dmp$setup_tape_init_in_progress');
      dmp$setup_tape_init_in_progress ({in_progress} TRUE, tape_descriptor^.tape_attachment_information.
            tape_volume_initialization.element, logical_unit)
    IFEND;
    rmp$log_debug_message ('LABELED_TAPE_DEBUG: Exiting sl_setup_volume_initialization');

  PROCEND sl_setup_volume_initialization;
?? OLDTITLE ??
?? NEWTITLE := '    sl_store_authorized_access', EJECT ??

  PROCEDURE sl_store_authorized_access
    (    authorized_access: fst$file_access_options;
     VAR status: ost$status);

    VAR
      dynamic_label: ^bat$dynamic_label_attributes;

    status.normal := TRUE;

    dynamic_label := ^file_instance^.instance_attributes.dynamic_label;
    #UNCHECKED_CONVERSION (authorized_access, dynamic_label^.access_mode);

    IF dynamic_label^.open_position = amc$open_at_eoi THEN
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Storing file access= BAC$APPEND($EOI)');
      state_info^.file_access := bac$append;
    ELSEIF pfc$shorten IN dynamic_label^.access_mode THEN
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Storing file access= BAC$WRITE');
      state_info^.file_access := bac$write;
    ELSEIF dynamic_label^.access_mode = $pft$usage_selections [pfc$append] THEN
      IF dynamic_label^.open_position = amc$open_at_boi THEN
        osp$set_status_condition (ame$improper_append_open, status);
        osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name, status);
      ELSE
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: Storing file access= BAC$APPEND');
        state_info^.file_access := bac$append;
      IFEND;
    ELSE
      rmp$log_debug_message ('LABELED_TAPE_DEBUG: Storing file access= BAC$READ');
      state_info^.file_access := bac$read;
    IFEND;

  PROCEND sl_store_authorized_access;
?? OLDTITLE ??
?? NEWTITLE := '    sl_tape_abnormal_termination', EJECT ??
  PROCEDURE sl_tape_abnormal_termination
    (    file_identifier: amt$file_identifier);

    VAR
      local_status: ost$status,
      tape_failure_modes: amt$tape_failure_modes;

    bap$tape_bm_close (file_identifier, tape_failure_modes, local_status);
    bai$init_boi_tape_position;
    state_info^.put_op := FALSE;
    state_info^.eoi_labels_needed := FALSE;
    tape_descriptor^.initial_volume.assigned := FALSE;
    tape_descriptor^.initial_volume.initial_read_labels_attempt := TRUE;
    IF NOT avp$removable_media_admin () THEN
      bap$free_tape_label_sequences ({free_initial_volume_sequence=} TRUE, tape_descriptor);
    IFEND;
    close_file_on_exit := TRUE;

  PROCEND sl_tape_abnormal_termination;
?? OLDTITLE ??
?? OLDTITLE ??
*DECK DECK=BAI$PARTIAL_BLOCK_EXISTS EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bat$task_file_table
?? POP ??

{
{ The purpose of this request is to determine if there remains any
{ data in the record management buffer to be physically output.
{
*copy bah$inline_proc_documentation

  FUNCTION [INLINE] bai$partial_block_exists: boolean;

    bai$partial_block_exists := (block_info^.block_position = bac$middle_of_block)
          AND (tape_descriptor^.put_tape_block_buffer <> NIL);

  FUNCEND bai$partial_block_exists;
*DECK DECK=BAI$PARTIAL_READ_BLOCK_EXISTS EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bat$task_file_table
?? POP ??

{
{ The purpose of this request is to determine if there a buffer exists
{ with read data in it.
{
*copy bah$inline_proc_documentation

  FUNCTION [INLINE] bai$partial_read_block_exists: boolean;

    bai$partial_read_block_exists := (block_info^.block_position = bac$middle_of_block)
          AND (tape_descriptor^.get_tape_block_buffer <> NIL);

  FUNCEND bai$partial_read_block_exists;
*DECK DECK=BAI$PARTIAL_RECORD_EXISTS EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bat$task_file_table
?? POP ??

{
{ The purpose of this request is to determine if there remains any
{ partial records in the data management buffer.
{
*copy bah$inline_proc_documentation

  FUNCTION [INLINE] bai$partial_record_exists: boolean;

    bai$partial_record_exists := (gfi^.positioning_info.record_info.file_position = amc$mid_record) AND
          (tape_descriptor^.put_tape_block_buffer <> NIL);

  FUNCEND bai$partial_record_exists;
*DECK DECK=BAI$POSITION_TO_NEXT_BLK_HDR EXPAND=TRUE
{
{ BAI$POSITION_TO_NEXT_BLK_HDR
{
{ Positions to the start of next block header if not currently
{ positioned at the start of a block header.
{ Will always return updated block_info, ^block_header, and file_byte_address.
{ The block_header will always be validated.

  IF file_byte_address MOD file_instance^.global_file_information^.
        max_block_size <> 0 THEN
    file_byte_address := block_info.current_block_byte_address +
          file_instance^.global_file_information^.max_block_size;
    block_info.previous_block_header_fba :=
          block_info.current_block_byte_address;
    block_info.current_block_byte_address := file_byte_address;
    block_info.block_number := block_info.block_number + 1;
  ELSE { on a block_header, check block number }
    IF (file_byte_address DIV file_instance^.global_file_information^.
          max_block_size) <> block_info.block_number THEN
*copy   bai$update_block_info_from_fba
    IFEND;
  IFEND;
  block_header := #ADDRESS (osc$min_ring, #SEGMENT (file_instance^.file_pva),
        file_byte_address);

{ NOTE: current_block_length must be set by the fap using
{ block_header^.block_length, after validating the header.
{
{ end of BAI$POSITION_TO_NEXT_BLK_HDR
{
*DECK DECK=BAI$PRI EXPAND=FALSE

{
{ The purpose of this request is to return a pointer to the
{ private read information for the current instance of open
{ of the file.
{

 FUNCTION [INLINE] bai$pri (file_instance: ^bat$task_file_entry):
      ^bat$private_read_information;

    bai$pri := file_instance^.private_read_information;

  FUNCEND bai$pri;
*DECK DECK=BAI$PROCESS_BLOCK_INFORMATION EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
?? RIGHT := 110 ??
*copyc amt$call_block
*copyc amt$file_identifier
*copyc amt$tape_error_options
*copyc amt$volume_position
*copyc bai$advance_volume
*copyc bap$validate_file_identifier
*copyc fsp$get_tape_label_attributes
*copyc ost$status
?? POP ??

{
{ The purpose of this routine is to process the read block information and
{ use the tape error options to determine how much, if any of the data
{ returned is any good for the application.
{
*copy bah$inline_proc_documentation

  PROCEDURE {INLINE} bai$process_block_information
    (    file_identifier: amt$file_identifier;
         label_type: amt$file_label_type;
         operation: amt$fap_operation;
         block_type: bat$tape_block_type;
         tape_error_options: amt$tape_error_options;
         tape_failure_modes: amt$tape_failure_modes;
     VAR reissue_read_request: boolean;
     VAR volume_position: amt$volume_position;
     VAR status: ost$status);

    CONST
      bc = 1;

    VAR
      ansi_file_attrib: ^array [bc .. bc] of fst$attachment_option,
      error_action: bat$error_actions,
      returned_attributes: fst$tla_returned_attributes,
      label_group: fst$ansi_label_kinds,
      request_status: ost$status,
      started_after_label_group: boolean;

?? NEWTITLE := '      validate_block_count', EJECT ??
    PROCEDURE validate_block_count
      (    label: string (4));

      VAR
        error_status: ost$status,
        ignore_status: ost$status,
        logset: pmt$ascii_logset;

      IF (ansi_file_attrib^ [bc].tape_attachment.tape_block_count <> 0) AND
            (ansi_file_attrib^ [bc].tape_attachment.tape_block_count <>
            gfi^.positioning_info.block_info.block_number) THEN
        osp$set_status_condition (ame$label_block_count_mismatch, error_status);
        osp$append_status_file (osc$status_parameter_delimiter, file_instance^.local_file_name, error_status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              gfi^.positioning_info.block_info.block_number, 10, FALSE, error_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, label, error_status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              ansi_file_attrib^ [bc].tape_attachment.tape_block_count, 10, FALSE, error_status);
      IFEND;
      osp$generate_error_message (error_status, ignore_status);
      logset := $pmt$ascii_logset [pmc$job_log];
      osp$generate_log_message (logset, error_status, ignore_status);

    PROCEND validate_block_count;
?? OLDTITLE, EJECT ??


    reissue_read_request := FALSE;
    volume_position := amc$after_data_block;

{
{ The following are descriptions of the various error actions.
{
{       = amc$accept_erroneous_block =
{
{ This option causes all I/O errors to be reported to the application.
{ Data is transferred as best as can be accomplished.
{
{       = amc$ignore_erroneous_block =
{
{ This option causes any blocks with unrecoverable errors to be ignored.
{ The action will be as if the block did not appear on the tape at all,
{ except for possibly trashing the users working storage area.
{
{       = amc$terminate_file_access =
{
{ When this option is selected, any unrecovered tape I/O error will be a fatal
{ error.
{

    CASE block_type OF

    = bac$good_data_block =
    = bac$error_data_block =
      CASE tape_error_options.error_action OF
      = amc$accept_erroneous_block =
        amp$set_file_instance_abnormal (file_identifier, ame$accept_bad_block, operation, ' ', status);
        bai$append_tape_error (file_identifier, tape_failure_modes, status);
        tape_descriptor^.failure_isolation.failure_modes := tape_failure_modes;
      = amc$ignore_erroneous_block =
        reissue_read_request := TRUE;
      ELSE
        amp$set_file_instance_abnormal (file_identifier, ame$unrecovered_read_error, operation, ' ', status);
        bai$append_tape_error (file_identifier, tape_failure_modes, status);
        tape_descriptor^.failure_isolation.failure_modes := tape_failure_modes;
      CASEND;
    = bac$error_without_data =
      CASE tape_error_options.error_action OF
      = amc$ignore_erroneous_block =
        IF (amc$tfm_device_not_ready IN tape_failure_modes) OR
              (amc$tfm_agc_gains_not_set IN tape_failure_modes) OR
              (amc$tfm_hardware_failure IN tape_failure_modes) THEN
          ;
        ELSE
          reissue_read_request := TRUE;
          RETURN;
        IFEND;
      ELSE
      CASEND;
      amp$set_file_instance_abnormal (file_identifier, ame$unrecovered_read_error, operation, ' ', status);
      bai$append_tape_error (file_identifier, tape_failure_modes, status);
      tape_descriptor^.failure_isolation.failure_modes := tape_failure_modes;
    = bac$density_mismatch =
      amp$set_file_instance_abnormal (file_identifier, ame$tape_density_mismatch, operation, ' ', status);
      tape_descriptor^.failure_isolation.failure_modes := tape_failure_modes;
    = bac$read_past_phys_eot =
      amp$set_file_instance_abnormal (file_identifier, ame$motion_past_phys_eot, operation, ' ', status);
      tape_descriptor^.failure_isolation.failure_modes := tape_failure_modes;
    = bac$tapemark =
      IF label_type = amc$unlabelled THEN
        bai$check_tapemark (file_identifier, volume_position, request_status);
        bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
              error_action, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF volume_position = amc$eov THEN
          bai$advance_volume (file_identifier, volume_position, status);
          tape_descriptor^.volume_position := volume_position;
          IF NOT status.normal OR (volume_position = amc$eov) THEN
            RETURN;
          IFEND;
          reissue_read_request := TRUE;
        IFEND;
      ELSEIF label_type = amc$labelled THEN
        started_after_label_group := sl_after_label_group (tape_descriptor^.labeled_volume_position);
        sl_read_tape_labels (file_identifier, label_group, status);
        IF NOT status.normal THEN
          IF started_after_label_group THEN
            tape_descriptor^.labeled_volume_position := bac$lvp_end_of_file_set;
            volume_position := amc$after_tapemark;
            RETURN;
          ELSE
            CASE status.condition OF
            = ame$invalid_tape_label = {Allow: * data}
              sl_advance_tapemark (file_identifier, amc$backward, 1, status);
              IF status.normal THEN
                sl_advance_tapemark (file_identifier, amc$forward, 1, status);
                volume_position := amc$after_tapemark;
                RETURN;
              IFEND;
            = ame$unexpected_tapemark =  {Each embedded tapemark returns EOI status}
              sl_advance_tapemark (file_identifier, amc$backward, 2, status);
              IF status.normal THEN
                sl_advance_tapemark (file_identifier, amc$forward, 1, status);
                volume_position := amc$after_tapemark;
                RETURN;
              IFEND;
            ELSE
            CASEND;
          IFEND;
        IFEND;
        IF status.normal THEN
          PUSH ansi_file_attrib;
          ansi_file_attrib^ [bc].selector := fsc$tape_attachment;
          ansi_file_attrib^ [bc].tape_attachment.selector := fsc$tape_block_count;
          fsp$get_tape_label_attributes (file_instance^.local_file_name, fsc$tla_last_ansi_file_accessed,
                ansi_file_attrib^, returned_attributes, status);
          IF status.normal THEN
            IF fsc$tape_block_count IN returned_attributes THEN
              IF fsc$ansi_eof1_label_kind IN label_group THEN
                validate_block_count ('EOF1');
              ELSEIF fsc$ansi_eov1_label_kind IN label_group THEN
                validate_block_count ('EOV1');
              IFEND;
            IFEND;
            IF fsc$ansi_eof1_label_kind IN label_group THEN
              volume_position := amc$after_tapemark;
              IF fsc$tape_block_count IN returned_attributes THEN
                state_info^.eof1_block_count := ansi_file_attrib^ [bc].tape_attachment.tape_block_count;
              ELSE
                state_info^.eof1_block_count := 0;
              IFEND;
              IF state_info^.eof1_block_count = 0 THEN
                gfi^.positioning_info.block_info.block_number := 1;
              ELSE
                gfi^.positioning_info.block_info.block_number := state_info^.eof1_block_count;
              IFEND;
            ELSEIF fsc$ansi_eov1_label_kind IN label_group THEN
              reissue_read_request := TRUE;
              volume_position := amc$bov;
              sl_close_label_volume (file_identifier, status);
              IF (NOT status.normal) AND (status.condition = ame$tape_end_of_volume_list) THEN
                IF fsc$tape_block_count IN returned_attributes THEN
                  state_info^.eof1_block_count := ansi_file_attrib^ [bc].tape_attachment.tape_block_count;
                ELSE
                  state_info^.eof1_block_count := 0;
                IFEND;
                IF state_info^.eof1_block_count = 0 THEN
                  gfi^.positioning_info.block_info.block_number := 1;
                ELSE
                  gfi^.positioning_info.block_info.block_number := state_info^.eof1_block_count;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      ELSE { label_type =  non  standard labelled. }
        volume_position := amc$after_tapemark;
      IFEND;
    ELSE
      amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction, operation,
            'Unknown block_type in bai$process_block_description.', status);
      bai$append_tape_error (file_identifier, tape_failure_modes, status);
      tape_descriptor^.failure_isolation.failure_modes := tape_failure_modes;
    CASEND;

  PROCEND bai$process_block_information;
*DECK DECK=BAI$PROCESS_REQUEST_STATUS EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
?? RIGHT := 110 ??
*copyc bat$task_file_table
*copyc bae$tape_bm_error_codes
*copyc dme$tape_errors
*copyc ost$status
*copyc bai$advance_volume
*copyc bai$gfi
*copyc amp$set_file_instance_abnormal
*copyc clp$convert_integer_to_string
*copyc osp$append_status_integer
*copyc ame$get_program_actions
*copyc ame$get_validation_errors
*copyc ame$improper_file_id
*copyc ame$open_validation_errors
*copyc ame$put_program_actions
*copyc ame$put_validation_errors
*copyc ame$ring_validation_errors
*copyc ame$skip_program_actions
*copyc ame$skip_validation_errors
*copyc ame$unimplemented_request
*copyc ame$wtmk_validation_errors
*copyc ame$tape_program_actions
?? POP ??

{
{ The purpose of this request is to take a request status and failure modes
{ returned by the tape_block_manager and do the following:
{
{   1) Store the tape_failure_modes in the tape_descriptor,
{   2) Change any internal errors into either appropriate external errors, or
{   3) Take an appropriate action to allow processing to continue.
{
*copy bah$inline_proc_documentation

  TYPE
    bat$error_actions = (bac$continue, bac$exit_procedure, bac$retry_last_request);

  PROCEDURE {INLINE} bai$process_request_status (file_identifier: amt$file_identifier;
        operation: amt$fap_operation;
        request_status: ost$status;
        tape_failure_modes: amt$tape_failure_modes;
    VAR error_action: bat$error_actions;
    VAR status: ost$status);

    status.normal := TRUE;
    error_action := bac$continue;
    tape_descriptor^.failure_isolation.failure_modes := tape_failure_modes;
    tape_descriptor^.failure_isolation.failed_at_current_position := TRUE;
    IF request_status.normal THEN
      RETURN;
    IFEND;

{ Process abnormal request_status.

    process_abnormal_request_status (file_identifier, operation, request_status,
          tape_failure_modes, error_action, status);

  PROCEND bai$process_request_status;

  PROCEDURE process_abnormal_request_status (file_identifier: amt$file_identifier;
        operation: amt$fap_operation;
        request_status: ost$status;
        tape_failure_modes: amt$tape_failure_modes;
    VAR error_action: bat$error_actions;
    VAR status: ost$status);

    VAR
      local_status: ost$status,
      maxbl_string: ost$string,
      volume_descriptor: rmt$volume_descriptor,
      volume_position: amt$volume_position;

    IF request_status.condition =

{******} bae$block_larger_than_maxbl {******} THEN

      CASE operation OF
*copy bac$write_requests
        amp$set_file_instance_abnormal (file_identifier, ame$record_exceeds_mbl, operation, '', status);
      ELSE
        clp$convert_integer_to_string (gfi^.max_data_size, 10, FALSE, maxbl_string, status);
        amp$set_file_instance_abnormal (file_identifier, ame$input_block_exceeds_maxbl, operation,
            maxbl_string.value, status);
      CASEND;
    ELSEIF request_status.condition =

{******} bae$block_truncated {******} THEN

      ;
    ELSEIF request_status.condition =

{******} bae$cannot_lock_tape_pages {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$cannot_lock_tape_pages, operation, '', status);
      error_action := bac$exit_procedure;
    ELSEIF request_status.condition =

{******} bae$improper_access_attempt {******} THEN

      CASE operation OF
*copy bac$write_requests
        amp$set_file_instance_abnormal (file_identifier, ame$improper_access_attempt, operation, 'WRITE',
            status);
      = amc$put_label_req =
        amp$set_file_instance_abnormal (file_identifier, ame$improper_access_attempt, operation, 'WRITE',
            status);
      ELSE
        amp$set_file_instance_abnormal (file_identifier, ame$improper_access_attempt, operation, 'READ',
            status);
      CASEND;
      error_action := bac$exit_procedure;
    ELSEIF request_status.condition =

{******} bae$improper_file_id {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$improper_file_id, operation, '', status);
      error_action := bac$exit_procedure;
    ELSEIF request_status.condition =

{******} bae$improper_input_attempt {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$improper_input_attempt, operation, '', status);
      error_action := bac$exit_procedure;
    ELSEIF request_status.condition =

{******} bae$input_after_output {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$input_after_output, operation, '', status);
      error_action := bac$exit_procedure;
    ELSEIF request_status.condition =

{******} bae$maxbl_exceeds_ws_limit {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$maxbl_exceeds_ws_limit, operation, '', status);
      error_action := bac$exit_procedure;
    ELSEIF request_status.condition =

{******} bae$multiple_open_of_tape {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$multiple_open_of_tape, operation, '', status);
      error_action := bac$exit_procedure;
    ELSEIF request_status.condition =

{******} bae$no_tape_write_ring {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$no_write_ring, operation, '', status);
      error_action := bac$exit_procedure;
    ELSEIF request_status.condition =

{******} bae$ring_validation_error {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$ring_validation_error, operation, '', status);
      error_action := bac$exit_procedure;
    ELSEIF request_status.condition =

{******} bae$skip_encountered_bov {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_bov, operation, '', status);
    ELSEIF request_status.condition =

{******} bae$tape_block_mgr_malfunction {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$tape_block_mgr_malfunction, operation,
            request_status.text.value (2, request_status.text.size - 1), status);
      error_action := bac$exit_procedure;
      bai$append_tape_error (file_identifier, tape_failure_modes, status);
    ELSEIF request_status.condition =

{******} bae$tape_driver_not_capable {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$tape_driver_not_capable, operation, '', status);
      error_action := bac$exit_procedure;
    ELSEIF request_status.condition =

{******} bae$too_many_reserved_buffers {******} THEN

      status := request_status;
      error_action := bac$exit_procedure;
    ELSEIF request_status.condition =

{******} bae$uncertain_tape_position {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$uncertain_tape_position, operation, '', status);
      error_action := bac$exit_procedure;
      bai$append_tape_error (file_identifier, tape_failure_modes, status);
    ELSEIF request_status.condition =

{******} bae$unimplemented_request {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$unimplemented_request, operation,
            ' for tape files', status);
      error_action := bac$exit_procedure;
    ELSEIF request_status.condition =

{******} bae$unreserved_buffer_used {******} THEN

      status := request_status;
      error_action := bac$exit_procedure;
    ELSEIF request_status.condition =

{******} bae$vol_end_operation_completed {******} THEN

      IF operation <> amc$close_volume_req THEN
        IF (bai$label_type () = amc$unlabelled) OR (bai$label_type () = amc$labelled) THEN
          ;
        ELSE { label_type = amc$non_standard_labelled       }
          amp$set_file_instance_abnormal (file_identifier, ame$end_of_tape_op_completed, operation, '',
                status);
        IFEND;
      ELSE
{ Ignore error if close_volume.
{ The volume advance will be initiated from the close_volume_req procedure.
        ;
      IFEND;

    ELSEIF request_status.condition =

{******} bae$vol_end_operation_inhibited {******} THEN

{ This error occurs only when writing.
{ For unlabelled and labelled tapes, dme$volume_list_exhausted will never
{ occur here since a scratch volume will always be requested.  Therefore,
{ there is no need for logic to call the process_volume_list_exhausted
{ procedure.
{ IF end of tape occurs during a user initiated close volume request, it
{ is a result of the flush that was issued prior to the volume advance.
{ The error will be ignored and the volume advance will be initiated from
{ the close_volume_req procedure.

      IF operation <> amc$close_volume_req THEN
        IF bai$label_type () = amc$unlabelled THEN
          bai$advance_volume (file_identifier, volume_position, status);
          tape_descriptor^.volume_position := volume_position;
          IF NOT status.normal THEN
            error_action := bac$exit_procedure;
          ELSE
            error_action := bac$retry_last_request;
          IFEND;
        ELSEIF bai$label_type () = amc$labelled THEN
          sl_close_label_volume (file_identifier, status);
          IF NOT status.normal THEN
            error_action := bac$exit_procedure;
          ELSE
            error_action := bac$retry_last_request;
          IFEND;
        ELSE { label_type = amc$non_standard_labelled       }
          amp$set_file_instance_abnormal (file_identifier, ame$end_of_tape_op_inhibited, operation, '',
                status);
          error_action := bac$exit_procedure;
        IFEND;
      ELSE
{ Ignore error if close_volume.  Buffered data will be retained and written on the next reel.
{ The volume advance will be initiated from the close_volume_req procedure.
        ;
      IFEND;
    ELSEIF request_status.condition =

{******} bae$write_error_previous_block {******} THEN

      tape_descriptor^.failure_isolation.failed_at_current_position := FALSE;
      amp$set_file_instance_abnormal (file_identifier, ame$unrecovered_write_error, operation, '', status);
      error_action := bac$exit_procedure;
      bai$append_tape_error (file_identifier, tape_failure_modes, status);
    ELSEIF request_status.condition =

{******} bae$read_error_this_block {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$unrecovered_read_error, operation, '', status);
      error_action := bac$exit_procedure;
      bai$append_tape_error (file_identifier, tape_failure_modes, status);
    ELSEIF request_status.condition =

{******} bae$density_mismatch {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$tape_density_mismatch, operation, '', status);
      error_action := bac$exit_procedure;
    ELSEIF request_status.condition =

{******} bae$cartridge_tape_erase_limit {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$cartridge_tape_erase_limit, operation, '', status);
      error_action := bac$exit_procedure;
    ELSEIF request_status.condition =

{******} bae$motion_past_phys_eot {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$motion_past_phys_eot, operation, '', status);
      error_action := bac$exit_procedure;
    ELSEIF request_status.condition =

{******} bae$write_error_this_block {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$unrecovered_write_error, operation, '', status);
      error_action := bac$exit_procedure;
      bai$append_tape_error (file_identifier, tape_failure_modes, status);
    ELSEIF request_status.condition =

{******} dme$volume_list_exhausted {******} THEN

      process_volume_list_exhausted (file_identifier, operation,
            error_action, status);
    ELSE
      status := request_status;
      error_action := bac$exit_procedure;
    IFEND;

  PROCEND process_abnormal_request_status;

{
{ The purpose of this request is to take appropriate actions when an operation
{ is performed that can not complete on the current volume set.
{
{ When reading an unlabelled tape, end_of_volume is defined when two
{ consecutive tapemarks are encountered.  When this occurs, the tape drive is
{ logically positioned between the two tapemarks. By convention, the tape drive
{ should be repositioned in front of the tapemarks.  The appropriate action is
{ then to skip one tapemark backwards.
{
*copy bah$inline_proc_documentation

  PROCEDURE process_volume_list_exhausted (file_identifier: amt$file_identifier;
        operation: amt$fap_operation;
    VAR error_action: bat$error_actions;
    VAR status: ost$status);

    VAR
      tape_failure_modes: amt$tape_failure_modes,
      request_status: ost$status;

    IF bai$label_type () = amc$labelled THEN
      tape_descriptor^.labeled_volume_position := bac$lvp_end_of_volume_list;
      file_instance^.previous_get_at_eoi := TRUE;
      gfi^.positioning_info.record_info.file_position := amc$eoi;
      amp$set_file_instance_abnormal (file_identifier, ame$tape_end_of_volume_list, operation, '', status);

    ELSE { label_type <> amc$labelled  }

      CASE operation OF
      = amc$open_req =
        bap$tape_bm_skip_tapemark (file_identifier, amc$backward, tape_failure_modes, request_status);
        bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
              error_action, status);
*copy bac$read_requests
        bap$tape_bm_skip_tapemark (file_identifier, amc$backward, tape_failure_modes, request_status);
        bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
              error_action, status);
      ELSE
        amp$set_file_instance_abnormal (file_identifier, ame$tape_end_of_volume_list, operation, '', status);
      CASEND;

    IFEND;

    rmp$log_debug_message ('LABELED_TAPE_DEBUG: End of Volume List - Setting AT_EOI to TRUE');
    tape_descriptor^.at_eoi := TRUE;

  PROCEND process_volume_list_exhausted;
*DECK DECK=BAI$PUT_ANSI_RCW EXPAND=FALSE

PROCEDURE {[INLINE]} bai$put_ansi_rcw;

  VAR
    character_length: string (bac$rcw_length_size),
    character_length_index: integer,
    i: integer,
    working_string: ost$string;


  clp$convert_integer_to_string ( put_size + rhl, 10, FALSE, working_string, status);
  IF NOT status.normal THEN
    amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
      operation, 'Integer to string error encountered in US/D put_ansi_rcw ', status);
    RETURN;
  IFEND;

  IF working_string.size > bac$rcw_length_size THEN
    amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
      operation, 'RCW length overflow encountered in US/D put_ansi_rcw ', status);
    RETURN;
  ELSE
    character_length := bac$rcw_length_value_of_zero;
    character_length_index := bac$rcw_length_size;
    FOR i := working_string.size DOWNTO 1 DO
      character_length(character_length_index) := working_string.value(i);
      character_length_index := character_length_index - 1;
    FOREND;
    rh.length := character_length;
  IFEND;

  put_data (file_identifier, operation, #LOC(rh), rhl, term_option,
        terminate_previous_block, {convert_if_ebcdic} TRUE, status);

  IF status.normal THEN
    last_record_header_p := ^tape_descriptor^.put_tape_block_buffer^
      [block_info^.current_block_byte_address +1 -rhl ];
  IFEND;


PROCEND bai$put_ansi_rcw;

*DECK DECK=BAI$PUT_ANSI_SCW_FOR_PUTN EXPAND=FALSE

PROCEDURE {[INLINE]} bai$put_ansi_scw_for_putn;

  VAR
    character_length: string (bac$scw_length_size),
    character_length_index: integer,
    i: integer,
    working_string: ost$string;

  IF start_of_data THEN
    IF end_of_data THEN
      rh.header_type := bac$full_segment;
    ELSE
      rh.header_type := bac$start_segment;
    IFEND;
  ELSE
    IF end_of_data THEN
      rh.header_type := bac$end_segment;
    ELSE
      rh.header_type := bac$continued_segment;
    IFEND;
  IFEND;

  clp$convert_integer_to_string ( put_size + rhl, 10, FALSE, working_string, status);
  IF NOT status.normal THEN
    amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
      operation, 'Integer to string error encountered in US/S put_ansi_rcw_for_putn ', status);
    RETURN;
  IFEND;

  IF working_string.size > bac$scw_length_size THEN
    amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
      operation, 'SCW length overflow encountered in US/S put_ansi_rcw_for_putn ', status);
    RETURN;
  ELSE
    character_length := bac$scw_length_value_of_zero;
    character_length_index := bac$scw_length_size;
    FOR i := working_string.size DOWNTO 1 DO
      character_length(character_length_index) := working_string.value(i);
      character_length_index := character_length_index - 1;
    FOREND;
    rh.length := character_length;
  IFEND;

  put_data (file_identifier, operation, #LOC(rh), rhl, term_option,
        terminate_previous_block, {convert_if_ebcdic} TRUE, status);

  IF status.normal THEN
    last_record_header_p := ^tape_descriptor^.put_tape_block_buffer^
      [block_info^.current_block_byte_address +1 -rhl ];
  IFEND;

  start_of_data := FALSE;

PROCEND bai$put_ansi_scw_for_putn;

*DECK DECK=BAI$PUT_ANSI_SCW_FOR_PUTP EXPAND=FALSE

PROCEDURE {[INLINE]} bai$put_ansi_scw_for_putp;

  VAR
    character_length: string (bac$scw_length_size),
    character_length_index: integer,
    i: integer,
    working_string: ost$string;

  CASE call_block.putp.term_option OF

    = amc$start =
      IF start_of_data THEN
        rh.header_type := bac$start_segment;
      ELSE
        rh.header_type := bac$continued_segment;
      IFEND;

    = amc$continue =
        rh.header_type := bac$continued_segment;

    = amc$terminate =
      IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
        IF end_of_data THEN
          rh.header_type := bac$end_segment;
        ELSE
          rh.header_type := bac$continued_segment;
        IFEND;
      ELSE { gfi^.positioning_info.record_info.file_position <> amc$mid_record
        IF start_of_data THEN
          IF end_of_data THEN
            rh.header_type := bac$full_segment;
          ELSE
            rh.header_type := bac$start_segment;
          IFEND;
        ELSE
          IF end_of_data THEN
            rh.header_type := bac$end_segment;
          ELSE
            rh.header_type := bac$continued_segment;
          IFEND;
        IFEND;
      IFEND;
    ELSE
      amp$set_file_instance_abnormal (file_identifier,
        ame$improper_term_option, call_block.operation, ' ', status);
      RETURN;
  CASEND;

  clp$convert_integer_to_string ( put_size + rhl, 10, FALSE, working_string, status);
  IF NOT status.normal THEN
    amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
      operation, 'Integer to string error encountered in US/S put_ansi_rcw_for_putp ', status);
    RETURN;
  IFEND;

  IF working_string.size > bac$scw_length_size THEN
    amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
      operation, 'SCW length overflow encountered in US/S put_ansi_rcw_for_putp ', status);
    RETURN;
  ELSE
    character_length := bac$scw_length_value_of_zero;
    character_length_index := bac$scw_length_size;
    FOR i := working_string.size DOWNTO 1 DO
      character_length(character_length_index) := working_string.value(i);
      character_length_index := character_length_index - 1;
    FOREND;
    rh.length := character_length;
  IFEND;

  put_data (file_identifier, operation, #LOC(rh), rhl, term_option,
        terminate_previous_block, {convert_if_ebcdic} TRUE, status);

  IF status.normal THEN
    last_record_header_p := ^tape_descriptor^.put_tape_block_buffer^
      [block_info^.current_block_byte_address +1 -rhl ];
  IFEND;

  start_of_data := FALSE;

PROCEND bai$put_ansi_scw_for_putp;
*DECK DECK=BAI$PUT_RECORD_HEADER_FOR_PUTN EXPAND=FALSE

PROCEDURE [INLINE] bai$put_record_header_for_putn;

  IF start_of_data THEN
    IF end_of_data THEN
      rh.header_type := bac$full_record;
    ELSE
      rh.header_type := bac$start_record;
    IFEND;
  ELSE
    IF end_of_data THEN
      rh.header_type := bac$end_record;
    ELSE
      rh.header_type := bac$continued_record;
    IFEND;
  IFEND;

  rh.length := put_size;
  rh.previous_header_fba := 0;
  rh.unique_id := bac$record_header_unique_id;

  put_data (file_identifier, operation, #LOC(rh), rhl, term_option,
        terminate_previous_block, {convert_if_ebcdic =} FALSE, status);

  IF status.normal THEN
    last_record_header_p := ^tape_descriptor^.put_tape_block_buffer^
      [block_info^.current_block_byte_address +1 -rhl ];
  IFEND;

  start_of_data := FALSE;

PROCEND bai$put_record_header_for_putn;

*DECK DECK=BAI$PUT_RECORD_HEADER_FOR_PUTP EXPAND=FALSE

PROCEDURE [INLINE] bai$put_record_header_for_putp;

  CASE call_block.putp.term_option OF

    = amc$start =
      IF start_of_data THEN
        rh.header_type := bac$start_record;
      ELSE
        rh.header_type := bac$continued_record;
      IFEND;

    = amc$continue =
        rh.header_type := bac$continued_record;

    = amc$terminate =
      IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
        IF end_of_data THEN
          rh.header_type := bac$end_record;
        ELSE
          rh.header_type := bac$continued_record;
        IFEND;
      ELSE
        IF start_of_data THEN
          IF end_of_data THEN
            rh.header_type := bac$full_record;
          ELSE
            rh.header_type := bac$start_record;
          IFEND;
        ELSE
          IF end_of_data THEN
            rh.header_type := bac$end_record;
          ELSE
            rh.header_type := bac$continued_record;
          IFEND;
        IFEND;
      IFEND;
    ELSE
      amp$set_file_instance_abnormal (file_identifier,
        ame$improper_term_option, call_block.operation, ' ', status);
      RETURN;
  CASEND;

  rh.length := put_size;
  rh.previous_header_fba := 0;
  rh.unique_id := bac$record_header_unique_id;

  put_data (file_identifier, operation, #LOC(rh), rhl, term_option,
        terminate_previous_block, {convert_if_ebcdic =} FALSE, status);

  IF status.normal THEN
    last_record_header_p := ^tape_descriptor^.put_tape_block_buffer^
      [block_info^.current_block_byte_address +1 -rhl ];
  IFEND;

  start_of_data := FALSE;

PROCEND bai$put_record_header_for_putp;
*DECK DECK=BAI$REWIND EXPAND=FALSE
{
{ BAI$REWIND

  /REWIND/
    BEGIN
      IF NOT ((pfc$read IN file_instance^.instance_attributes.dynamic_label.
            access_mode) OR (pfc$modify IN file_instance^.instance_attributes.
            dynamic_label.access_mode) OR (pfc$shorten IN file_instance^.
            instance_attributes.dynamic_label.access_mode) OR (pfc$append IN
            file_instance^.instance_attributes.dynamic_label.access_mode)) THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_access_attempt, call_block.operation,
          ' READ or WRITE', status);
        EXIT /REWIND/;
      IFEND;

      IF file_instance^.global_file_information = NIL THEN
{error}
        EXIT /REWIND/;
      IFEND;

      IF file_instance^.access_level = amc$segment THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation,
          ' SEGMENT ACCESS', status);
        EXIT /REWIND/;
      IFEND;

      IF file_instance^.private_read_information <> NIL THEN
        file_instance^.private_read_information^.positioning_info :=
              fmv$global_file_information.positioning_info;
      ELSE
        file_instance^.global_file_information^.positioning_info :=
              fmv$global_file_information.positioning_info;
      IFEND;
    END /REWIND/;

{ end of BAI$REWIND
{
*DECK DECK=BAI$REWIND_FTD EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bat$private_read_information
?? POP ??

{
{ The purpose of this request is to reset fields in the private
{ read information to reflect a rewind.
{
*copy bah$inline_proc_documentation

  PROCEDURE [INLINE] bai$rewind_pri;

    pri^.positioning_info.record_info.file_position := amc$boi;
    pri^.positioning_info.record_info.record_header_fba := 0;
    pri^.positioning_info.record_info.record_length := 0;
    pri^.positioning_info.record_info.residual_record_length := 0;
    pri^.positioning_info.record_info.residual_skip_count := 0;
    pri^.positioning_info.record_info.transfer_count := 0;
    pri^.positioning_info.block_info.block_number := 1;
    pri^.positioning_info.block_info.block_position := bac$beginning_of_block;
    pri^.positioning_info.block_info.current_block_byte_address := 0;
    pri^.positioning_info.block_info.current_block_length := 0;
    pri^.positioning_info.block_info.residual_block_length := 0;

  PROCEND bai$rewind_ftd;
*DECK DECK=BAI$REWIND_GFI EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bat$global_file_information
*copyc fmv$global_file_information
?? POP ??

{
{ The purpose of this request is to reset fields in the global
{ file information table to reflect a rewind.
{
*copyc bah$inline_proc_documentation

  PROCEDURE [INLINE] bai$rewind_gfi;

    gfi^.positioning_info := fmv$global_file_information.positioning_info;

  PROCEND bai$rewind_gfi;
*DECK DECK=BAI$REWIND_TAPE_DESCRIPTOR EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bat$tape_descriptor
?? POP ??

{
{ The purpose of this request is to reset fields in the tape descriptor
{ to reflect the results of a rewind operation.
{
*copy bah$inline_proc_documentation

  PROCEDURE [INLINE] bai$rewind_tape_descriptor;

    tape_descriptor^.at_eoi := FALSE;
    tape_descriptor^.get_tape_block_buffer := NIL;
    tape_descriptor^.labeled_volume_position := bac$lvp_beginning_of_file_set;
    tape_descriptor^.next_position.file_section_number := 1;
    tape_descriptor^.next_position.file_sequence_number := 1;
    tape_descriptor^.put_tape_block_buffer := NIL;
    tape_descriptor^.volume_number := 1;
    tape_descriptor^.volume_position := amc$bov;

  PROCEND bai$rewind_tape_descriptor;
*DECK DECK=BAI$SAVE_POSITIONING_INFO EXPAND=FALSE
{
{ BAI$SAVE_POSITIONING_INFO
{
{ Save current position information.  This update is done only after operation
{ has completed successfully.

  IF file_instance^.private_read_information = NIL THEN
    file_instance^.global_file_information^.positioning_info.block_info :=
          block_info;
    file_instance^.global_file_information^.positioning_info.record_info :=
          record_info;
  ELSE
    file_instance^.private_read_information^.positioning_info.block_info :=
          block_info;
    file_instance^.private_read_information^.positioning_info.record_info :=
          record_info;
  IFEND;

{ end of BAI$SAVE_POSITIONING_INFO
{
*DECK DECK=BAI$SAVE_RECORD_INFO EXPAND=FALSE
{
{ BAI$SAVE_RECORD_INFO
{
{ Save current record information.  This update is done only after operation
{ has completed successfully.

  IF file_instance^.private_read_information = NIL THEN
    file_instance^.global_file_information^.positioning_info.record_info :=
          record_info;
  ELSE
    file_instance^.private_read_information^.positioning_info.record_info :=
          record_info;
  IFEND;

{ end of BAI$SAVE_RECORD_INFO
{


*DECK DECK=BAI$SCAN_TO_DELIMITING_CHAR EXPAND=FALSE
{
{ BAI$SCAN_TO_DELIMITING_CHAR
{
{ This code scans until a delimiting character is found.
{
{ It is designed to handle the case of a missing delimiter at the end
{ of the file.  Normally, this code leaves the variable <trailing_char_length>
{ with a value of 1, but in the case of a missing delimiter at the end
{ of the file, trailing_char_length will be left with a value of 0.

      scan_byte_address := record_info.current_byte_address;
      scan_size := max_scan_size;
      trailing_char_length := trailing_char_length_constant; { assume that a delimiter will be found

    /scanning_for_delimiter/
      REPEAT
        IF scan_byte_address + max_scan_size > file_instance^.
              global_file_information^.eoi_byte_address THEN
          IF scan_byte_address >= file_instance^.global_file_information^.
                eoi_byte_address THEN

            trailing_char_length := 0;
            EXIT /scanning_for_delimiter/
          IFEND;
          scan_size := file_instance^.global_file_information^.
            eoi_byte_address - scan_byte_address;
        IFEND;

        scan_string := #address (#ring (file_instance^.file_pva), #segment
              (file_instance^.file_pva), scan_byte_address);

        #scan (delimiting_char_set, scan_string^ (1, scan_size),
              scanned_piece_size, found_delimiter);

        scan_byte_address := scan_byte_address + scanned_piece_size;

{  Since scanned_piece_size is scan_size + 1, scan_byte_address is
{  one beyond the delimiter if the record length is exactly max_scan_size
{  or some multiple of it.  The test is for the negative condition since
{  the conditional code will seldom be executed.

        IF NOT found_delimiter THEN
          scan_byte_address := scan_byte_address - 1;
        IFEND;
      UNTIL found_delimiter;

{ end of BAI$SCAN_TO_DELIMITING_CHAR
{
*DECK DECK=BAI$SEEK_VALIDATION EXPAND=FALSE
{
{ BAI$SEEK_VALIDATION
{
{ This code does general validation for seek_direct.

  IF caller_id.ring > file_instance^.instance_attributes.static_label.
        ring_attributes.r2 THEN
    amp$set_file_instance_abnormal (file_identifier, ame$ring_validation_error,
          call_block.operation, error_text, status);
  ELSEIF NOT ((file_instance^.instance_attributes.static_label.
        file_organization = amc$byte_addressable) OR
        (file_instance^.instance_attributes.static_label.file_organization =
        amc$sequential)) THEN
    amp$set_file_instance_abnormal (file_identifier,
          ame$file_organization_conflict, call_block.operation, error_text,
          status);
  ELSE
    IF file_byte_address > file_instance^.global_file_information^.
          eoi_byte_address THEN
      IF NOT (pfc$append IN file_instance^.instance_attributes.dynamic_label.
            access_mode) THEN
        IF call_block.operation = amc$get_direct_req THEN
          amp$set_file_instance_abnormal (file_identifier, ame$input_after_eoi,
                call_block.operation, error_text, status);
        ELSE
          amp$set_file_instance_abnormal (file_identifier,
                ame$position_beyond_eoi, call_block.operation, error_text,
                status);
        IFEND;
      ELSEIF file_instance^.instance_attributes.static_label.
            file_organization <> amc$byte_addressable THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$seek_beyond_eoi_fo_conflict, call_block.operation,
              error_text, status);
      IFEND;
    ELSEIF file_byte_address = file_instance^.global_file_information^.
          eoi_byte_address THEN
      IF (call_block.operation = amc$put_direct_req) AND
            NOT (pfc$append IN file_instance^.instance_attributes.
            dynamic_label.access_mode) THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_access_attempt, call_block.operation, ' APPEND ',
              status);
      IFEND;
    ELSEIF NOT ((pfc$read IN file_instance^.instance_attributes.dynamic_label.
          access_mode) OR (pfc$shorten IN file_instance^.instance_attributes.
          dynamic_label.access_mode) OR (pfc$modify IN
          file_instance^.instance_attributes.dynamic_label.access_mode)) THEN
      amp$set_file_instance_abnormal (file_identifier,
            ame$improper_access_attempt, call_block.operation,
            ' READ, MODIFY, OR SHORTEN ', status);
    IFEND;
  IFEND;

{ end of BAI$SEEK_VALIDATION
{
*DECK DECK=BAI$SKIP_TO_NEXT_ANSI_RCW EXPAND=FALSE

PROCEDURE {[INLINE]} bai$skip_to_next_ansi_rcw;

  VAR
    binary_length: clt$integer,
    os_status: ost$error;

  CONST
    ebcdic_zero = $CHAR(0F0(16));

/find_header/
  WHILE TRUE DO

    manually_advance_to_next_block := FALSE;

    IF rhl <= block_info^.residual_block_length THEN
      next_record_header_p := ^tape_descriptor^.get_tape_block_buffer^
        [block_info^.current_block_byte_address +1 ];

{ If the record header was recorded in EBCDIC and character conversion is requested,
{ convert the record header to ASCII.  This code assumes that any value greater
{ than or equal to EBCDIC zero indicates an EBCDIC representation for the control word.

    IF (state_info^.character_set = amc$ebcdic) AND state_info^.character_conversion
          AND (next_record_header_p^.length(1,1) >= ebcdic_zero) THEN
      osp$translate_bytes (#LOC(next_record_header_p^), rhl, #LOC(next_record_header_p^),
            rhl, ^osv$ebcdic_to_ascii, os_status);
    IFEND;

      IF next_record_header_p^.length = bac$ansi_block_padding_chars THEN
        residual_data_length := 0;
        block_info^.current_block_byte_address :=
          block_info^.current_block_byte_address + block_info^.residual_block_length;
        block_info^.residual_block_length :=
          block_info^.residual_block_length - block_info^.residual_block_length;
        CYCLE /find_header/;

      ELSE
        clp$convert_string_to_integer (next_record_header_p^.length, binary_length, status);
        IF NOT status.normal THEN
          manually_advance_to_next_block := TRUE;
          no_header_read := TRUE;
          amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
            call_block.operation, ' ', status);
          EXIT /find_header/;
        IFEND;

        IF (binary_length.value <= UPPERVALUE (bat$rcw_length_value_range)) AND
           (binary_length.value >= LOWERVALUE (bat$rcw_length_value_range)) AND
           (binary_length.value <= block_info^.residual_block_length) THEN

          last_record_header_p := next_record_header_p;
          residual_data_length := binary_length.value - rhl;
          block_info^.current_block_byte_address :=
            block_info^.current_block_byte_address + rhl;
          block_info^.residual_block_length :=
            block_info^.residual_block_length - rhl;
          EXIT /find_header/;

        ELSE
          manually_advance_to_next_block := TRUE;
          no_header_read := TRUE;
          amp$set_file_instance_abnormal (file_identifier,
            ame$improper_record_header, call_block.operation, ' ', status);
          EXIT /find_header/;

        IFEND;
      IFEND;

    ELSE
      get_data (file_identifier, operation, #LOC(rh), rhl,
        FALSE, {start_new_block=}TRUE, {convert_if_ebcdic =} FALSE, status);

{ If the record header was recorded in EBCDIC and character conversion is requested,
{ convert the record header to ASCII.  This code assumes that any value greater
{ than or equal to EBCDIC zero indicates an EBCDIC representation for the control word.

      IF (state_info^.character_set = amc$ebcdic) AND state_info^.character_conversion
            AND (rh.length(1,1) >= ebcdic_zero) THEN
        osp$translate_bytes (#LOC(rh), rhl, #LOC(rh), rhl, ^osv$ebcdic_to_ascii, os_status);
      IFEND;

      IF NOT status.normal THEN
        manually_advance_to_next_block := TRUE;
        no_header_read := TRUE;
        EXIT /find_header/;
      IFEND;

      IF gfi^.positioning_info.record_info.transfer_count < rhl THEN
        residual_data_length := 0;
        IF (tape_descriptor^.volume_position = amc$eov) OR
           (tape_descriptor^.volume_position = amc$after_tapemark) THEN
          no_header_read := TRUE;
        ELSE
          { ! ERROR IN BLOCK
          manually_advance_to_next_block := TRUE;
          no_header_read := TRUE;
          amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
            call_block.operation, ' ', status);
        IFEND;
        EXIT /find_header/;
      IFEND;

      IF rh.length = bac$ansi_block_padding_chars THEN
        residual_data_length := 0;
        block_info^.current_block_byte_address :=
          block_info^.current_block_byte_address + block_info^.residual_block_length;
        block_info^.residual_block_length :=
          block_info^.residual_block_length - block_info^.residual_block_length;
        CYCLE /find_header/;


      ELSE
        clp$convert_string_to_integer (rh.length, binary_length, status);
        IF NOT status.normal THEN
          manually_advance_to_next_block := TRUE;
          no_header_read := TRUE;
          amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
            call_block.operation, ' ', status);
          EXIT /find_header/;
        IFEND;

        IF (binary_length.value <= UPPERVALUE (bat$rcw_length_value_range)) AND
           (binary_length.value >= LOWERVALUE (bat$rcw_length_value_range)) AND
           (binary_length.value - rhl <= block_info^.residual_block_length) THEN

          last_record_header_p := ^tape_descriptor^.get_tape_block_buffer^
            [block_info^.current_block_byte_address +1 -rhl ];
          residual_data_length := binary_length.value - rhl;
          EXIT /find_header/;

        ELSE
          manually_advance_to_next_block := TRUE;
          no_header_read := TRUE;
          amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
            call_block.operation, ' ', status);
          EXIT /find_header/;

        IFEND;
      IFEND;
    IFEND;

  WHILEND /find_header/;

  gfi^.positioning_info.record_info.transfer_count := 0;

  IF manually_advance_to_next_block THEN
    residual_data_length := 0;
    block_info^.current_block_byte_address :=
      block_info^.current_block_byte_address + block_info^.residual_block_length;
    block_info^.residual_block_length :=
      block_info^.residual_block_length - block_info^.residual_block_length;
    gfi^.positioning_info.record_info.file_position := amc$mid_record;
  IFEND;

PROCEND bai$skip_to_next_ansi_rcw;
*DECK DECK=BAI$SKIP_TO_NEXT_ANSI_SCW EXPAND=FALSE

PROCEDURE {[INLINE]} bai$skip_to_next_ansi_scw;

  VAR
    binary_length: clt$integer,
    os_status: ost$error;

  CONST
    ebcdic_zero = $CHAR(0F0(16));

/find_header/
  WHILE TRUE DO

    manually_advance_to_next_block := FALSE;

    IF rhl <= block_info^.residual_block_length THEN
      next_record_header_p := ^tape_descriptor^.get_tape_block_buffer^
        [block_info^.current_block_byte_address +1 ];

{ If the record header was recorded in EBCDIC and character conversion is requested,
{ convert the record header to ASCII.  This code assumes that any value greater
{ than or equal to EBCDIC zero indicates an EBCDIC representation for the control word.

      IF (state_info^.character_set = amc$ebcdic) AND state_info^.character_conversion
            AND (next_record_header_p^.header_type >= ebcdic_zero) THEN
        osp$translate_bytes (#LOC(next_record_header_p^), rhl, #LOC(next_record_header_p^),
              rhl, ^osv$ebcdic_to_ascii, os_status);
      IFEND;

      IF (next_record_header_p^.header_type <= bac$end_segment) AND
        (next_record_header_p^.header_type >= bac$full_segment) THEN

        clp$convert_string_to_integer (next_record_header_p^.length, binary_length, status);
        IF NOT status.normal THEN
          manually_advance_to_next_block := TRUE;
          no_header_read := TRUE;
          amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
            call_block.operation, ' ', status);
          EXIT /find_header/;
        IFEND;

        IF (binary_length.value <= UPPERVALUE (bat$scw_length_value_range)) AND
           (binary_length.value >= LOWERVALUE (bat$scw_length_value_range)) AND
           (binary_length.value <= block_info^.residual_block_length) THEN

          last_record_header_p := next_record_header_p;
          residual_data_length := binary_length.value - rhl;
          block_info^.current_block_byte_address :=
            block_info^.current_block_byte_address + rhl;
          block_info^.residual_block_length :=
            block_info^.residual_block_length - rhl;
          EXIT /find_header/;

        ELSE
          manually_advance_to_next_block := TRUE;
          no_header_read := TRUE;
          amp$set_file_instance_abnormal (file_identifier,
            ame$improper_record_header, call_block.operation, ' ', status);
          EXIT /find_header/;
        IFEND;


      ELSEIF next_record_header_p^.header_type = bac$ansi_block_padding_char THEN
        residual_data_length := 0;
        block_info^.current_block_byte_address :=
          block_info^.current_block_byte_address + block_info^.residual_block_length;
        block_info^.residual_block_length :=
          block_info^.residual_block_length - block_info^.residual_block_length;
        CYCLE /find_header/;

      ELSE
        manually_advance_to_next_block := TRUE;
        no_header_read := TRUE;
        amp$set_file_instance_abnormal (file_identifier,
          ame$improper_record_header, call_block.operation, ' ', status);
        EXIT /find_header/;
      IFEND;

    ELSE
      get_data (file_identifier, operation, #LOC(rh), rhl,
        FALSE, {start_new_block=}TRUE, {convert_if_ebcdic =} FALSE, status);

{ If the record header was recorded in EBCDIC and character conversion is requested,
{ convert the record header to ASCII.  This code assumes that any value greater
{ than or equal to EBCDIC zero indicates an EBCDIC representation for the control word.

      IF (state_info^.character_set = amc$ebcdic) AND state_info^.character_conversion
            AND (rh.header_type >= ebcdic_zero) THEN
        osp$translate_bytes (#LOC(rh), rhl, #LOC(rh), rhl, ^osv$ebcdic_to_ascii, os_status);
      IFEND;

      IF NOT status.normal THEN
        manually_advance_to_next_block := TRUE;
        no_header_read := TRUE;
        EXIT /find_header/;
      IFEND;

      IF gfi^.positioning_info.record_info.transfer_count < rhl THEN
        residual_data_length := 0;
        IF (tape_descriptor^.volume_position = amc$eov) OR
           (tape_descriptor^.volume_position = amc$after_tapemark) THEN
          no_header_read := TRUE;
        ELSE
          { ! ERROR IN BLOCK
          manually_advance_to_next_block := TRUE;
          no_header_read := TRUE;
          amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
            call_block.operation, ' ', status);
        IFEND;
        EXIT /find_header/;
      IFEND;

      IF (rh.header_type <= bac$end_segment) AND (rh.header_type >= bac$full_segment) THEN

        clp$convert_string_to_integer (rh.length, binary_length, status);
        IF NOT status.normal THEN
          manually_advance_to_next_block := TRUE;
          no_header_read := TRUE;
          amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
            call_block.operation, ' ', status);
          EXIT /find_header/;
        IFEND;

        IF (binary_length.value <= UPPERVALUE (bat$scw_length_value_range)) AND
           (binary_length.value >= LOWERVALUE (bat$scw_length_value_range)) AND
           (binary_length.value - rhl <= block_info^.residual_block_length) THEN

          last_record_header_p := ^tape_descriptor^.get_tape_block_buffer^
            [block_info^.current_block_byte_address +1 -rhl ];
          residual_data_length := binary_length.value - rhl;
          EXIT /find_header/;

        ELSE
          manually_advance_to_next_block := TRUE;
          no_header_read := TRUE;
          amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
            call_block.operation, ' ', status);
          EXIT /find_header/;
        IFEND;

      ELSEIF rh.header_type = bac$ansi_block_padding_char THEN
        residual_data_length := 0;
        block_info^.current_block_byte_address :=
          block_info^.current_block_byte_address + block_info^.residual_block_length;
        block_info^.residual_block_length :=
          block_info^.residual_block_length - block_info^.residual_block_length;
        CYCLE /find_header/;

      ELSE
        manually_advance_to_next_block := TRUE;
        no_header_read := TRUE;
        amp$set_file_instance_abnormal (file_identifier,
          ame$improper_record_header, call_block.operation, ' ', status);
        EXIT /find_header/;
      IFEND;

    IFEND;

  WHILEND /find_header/;

  gfi^.positioning_info.record_info.transfer_count := 0;

  IF manually_advance_to_next_block THEN
    residual_data_length := 0;
    block_info^.current_block_byte_address :=
      block_info^.current_block_byte_address + block_info^.residual_block_length;
    block_info^.residual_block_length :=
      block_info^.residual_block_length - block_info^.residual_block_length;
    gfi^.positioning_info.record_info.file_position := amc$mid_record;
  IFEND;

PROCEND bai$skip_to_next_ansi_scw;
*DECK DECK=BAI$SKIP_TO_NEXT_RECORD_HEADER EXPAND=FALSE

PROCEDURE [INLINE] bai$skip_to_next_record_header;

  manually_advance_to_next_block := FALSE;

  IF rhl <= block_info^.residual_block_length THEN
    next_record_header_p := ^tape_descriptor^.get_tape_block_buffer^
      [block_info^.current_block_byte_address +1 ];
    IF (next_record_header_p^.unique_id=bac$record_header_unique_id)
      AND (next_record_header_p^.header_type <= UPPERVALUE (rh.header_type))
      AND (next_record_header_p^.header_type >= LOWERVALUE (rh.header_type))
      AND (next_record_header_p^.length <= UPPERVALUE (rh.length))
      AND (next_record_header_p^.length >= LOWERVALUE (rh.length))
      AND (next_record_header_p^.length <= block_info^.residual_block_length - rhl) THEN
      last_record_header_p := next_record_header_p;
      residual_data_length := last_record_header_p^.length;
      block_info^.current_block_byte_address :=
        block_info^.current_block_byte_address + rhl;
      block_info^.residual_block_length :=
        block_info^.residual_block_length - rhl;
    ELSE
      manually_advance_to_next_block := TRUE;
      no_header_read := TRUE;
      amp$set_file_instance_abnormal (file_identifier,
        ame$improper_record_header, call_block.operation, ' ', status);
    IFEND;

  ELSE
    get_data (file_identifier, operation, #LOC(rh), rhl,
      FALSE, {start_new_block=}TRUE, {convert_if_ebcdic =} FALSE, status);

    IF NOT status.normal THEN
      manually_advance_to_next_block := TRUE;
      no_header_read := TRUE;
    ELSEIF gfi^.positioning_info.record_info.transfer_count < rhl THEN
      residual_data_length := 0;
      IF (tape_descriptor^.volume_position = amc$eov) OR
         (tape_descriptor^.volume_position = amc$after_tapemark) THEN
        no_header_read := TRUE;
      ELSE
        manually_advance_to_next_block := TRUE;
        no_header_read := TRUE;
        amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
          call_block.operation, ' ', status);
      IFEND;
    ELSEIF (rh.unique_id = bac$record_header_unique_id)
      AND (rh.header_type <= UPPERVALUE (rh.header_type))
      AND (rh.header_type >= LOWERVALUE (rh.header_type))
      AND (rh.length <= UPPERVALUE (rh.length))
      AND (rh.length >= LOWERVALUE (rh.length))
      AND (rh.length <= block_info^.residual_block_length) THEN
      last_record_header_p := ^tape_descriptor^.get_tape_block_buffer^
        [block_info^.current_block_byte_address +1 -rhl ];
      residual_data_length := rh.length;
    ELSE
      manually_advance_to_next_block := TRUE;
      no_header_read := TRUE;
      amp$set_file_instance_abnormal (file_identifier, ame$improper_record_header,
        call_block.operation, ' ', status);
    IFEND;
  IFEND;

  gfi^.positioning_info.record_info.transfer_count := 0;

  IF manually_advance_to_next_block THEN
    residual_data_length := 0;
    block_info^.current_block_byte_address :=
      block_info^.current_block_byte_address + block_info^.residual_block_length;
    block_info^.residual_block_length :=
      block_info^.residual_block_length - block_info^.residual_block_length;
    gfi^.positioning_info.record_info.file_position := amc$mid_record;
  IFEND;

PROCEND bai$skip_to_next_record_header;
*DECK DECK=BAI$SL_POSITION_FILE EXPAND=FALSE

  PROCEDURE [INLINE] bai$sl_position_file
    (    file_identifier: amt$file_identifier;
         skip_count: integer;
     VAR status: ost$status);

    VAR
      label_group: fst$ansi_label_kinds;

    sl_advance_tapemark (file_identifier, amc$backward, skip_count, status);
    IF status.normal THEN
      sl_advance_tapemark (file_identifier, amc$forward, 1, status);
    ELSEIF status.condition = ame$skip_encountered_bov THEN
      rewind_tape (file_identifier, status);
      IF status.normal THEN
        sl_read_tape_labels (file_identifier, label_group, status);
      IFEND;
    IFEND;

  PROCEND bai$sl_position_file;
*DECK DECK=BAI$STATE_INFO EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bat$task_file_table
*copyc bat$labeled_tape_state_info
?? POP ??

{
{ The purpose of this request is to return a pointer to the
{ labeled tape state info for the current instance of open of the
{ file.
{

  FUNCTION [INLINE] bai$state_info
    (    file_instance: ^bat$task_file_entry): ^bat$labeled_tape_state_info;

    VAR
      state_info: ^bat$labeled_tape_state_info;

    bai$state_info := ^file_instance^.labeled_tape_state_info;

  FUNCEND bai$state_info;
*DECK DECK=BAI$STATIC_LABEL EXPAND=FALSE

{
{ The purpose of this request is to return a pointer to the
{ static label for the current instance of open of the file.
{

 FUNCTION [INLINE] bai$static_label (file_instance: ^bat$task_file_entry):
      ^bat$instance_static_attributes;

    bai$static_label := ^file_instance^.instance_attributes.static_label;

  FUNCEND bai$static_label;
*DECK DECK=BAI$SYSTEM_MEDIA_RECOVERY EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bat$task_file_table
?? POP ??

{
{ The purpose of this request is to return a boolean to indicate weather
{ system media recovery is to be used on tape_bm requests.
{

  FUNCTION [INLINE] bai$system_media_recovery (file_instance:
    ^bat$task_file_entry): boolean;

    bai$system_media_recovery := TRUE; { kludge until phase 2. }

  FUNCEND bai$system_media_recovery;
*DECK DECK=BAI$TAPE_DESCRIPTOR EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc bat$task_file_table
*copyc bat$tape_descriptor
?? POP ??

{
{ The purpose of this request is to return a pointer to the
{ tape descriptor for the current instance of open of the
{ file.
{

  FUNCTION [INLINE] bai$tape_descriptor (file_instance: ^bat$task_file_entry):
    ^bat$tape_descriptor;

    VAR
      tape_descriptor: ^bat$tape_descriptor,
      seq_ptr: ^SEQ ( * );

    seq_ptr := file_instance^.global_file_information^.device_dependent_info.
          tape_descriptor;
    RESET seq_ptr;
    NEXT tape_descriptor IN seq_ptr;
    bai$tape_descriptor := tape_descriptor;

  FUNCEND bai$tape_descriptor;
*DECK DECK=BAI$UPDATE_EOI EXPAND=FALSE
{
{ BAI$UPDATE_EOI
{
{ This code update eoi in all write access procedures.
{ Caller must set record_info.current_byte_address.

  CASE file_instance^.instance_attributes.static_label.file_organization OF
  = amc$byte_addressable =
    IF record_info.current_byte_address >
          file_instance^.global_file_information^.eoi_byte_address THEN
      file_instance^.global_file_information^.eoi_byte_address :=
            record_info.current_byte_address;
    IFEND;
  = amc$sequential =
    IF record_info.current_byte_address <
          file_instance^.global_file_information^.eoi_byte_address THEN
      mmp$set_segment_length (file_instance^.file_pva, bac$minimum_open_ring,
            record_info.current_byte_address, status);
    IFEND;
    file_instance^.global_file_information^.eoi_byte_address :=
          record_info.current_byte_address;
  ELSE
    amp$set_file_instance_abnormal (file_identifier,
          ame$unrecovered_read_error, call_block.operation,
          ' bai$update_eoi error', status);
  CASEND;
  file_instance^.previous_get_at_eoi := FALSE;

{ end of BAI$UPDATE_EOI
{
*DECK DECK=BAI$VALIDATE_BLOCK_HEADER EXPAND=FALSE
{
{ BAI$VALIDATE_BLOCK_HEADER

    IF (block_header^.unique_id <> bac$block_header_unique_id) OR
          (block_header^.block_length > UPPERVALUE
          (block_header^.block_length)) OR (block_header^.block_length <
          LOWERVALUE (block_header^.block_length)) THEN
      amp$set_file_instance_abnormal (file_identifier,
            ame$block_hdr_validation_error, call_block.operation, error_text,
            status);
    IFEND;

{ end of BAI$VALIDATE_BLOCK_HEADER
{
*DECK DECK=BAI$VALIDATE_FILE_IDENTIFIER EXPAND=FALSE
*IF NOT $true(osv$unix)
?? PUSH (CHKALL := OFF) ??
  IF (bav$task_file_table <> NIL)
  {} AND (file_identifier.ordinal >= 1)
  {} AND (file_identifier.ordinal <= bav$last_tft_entry)
  {} AND (file_identifier.sequence > 0)
  {} AND (file_identifier.sequence =
           bav$task_file_table^ [file_identifier.ordinal].sequence_number) THEN
    file_instance := ^bav$task_file_table^ [file_identifier.ordinal];
    file_id_is_valid := TRUE;
  ELSE
    file_id_is_valid := FALSE;
    file_instance := NIL;
  IFEND;
?? POP ??
*ELSE
  IF (file_identifier < 0) OR (file_identifier > amc$max_file_id_ordinal) THEN
    osp$set_status_abnormal ('AM', ame$improper_file_id, interface_name, status);
  IFEND;
*IFEND
*DECK DECK=BAI$VALIDATE_READ_ACCESS EXPAND=FALSE
{
{ BAI$VALIDATE_READ_ACCESS
{
{ This code does general validation for all reads.
{ Note that working_storage_length is in the same location in the call_block
{ of all get operations.

  IF (call_block.getn.working_storage_length <= 0) OR
        (call_block.getn.working_storage_length >
        UPPERVALUE (amt$working_storage_length)) THEN
    amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
          call_block.operation, error_text, status);
  ELSEIF caller_id.ring > file_instance^.instance_attributes.static_label.
        ring_attributes.r2 THEN
    amp$set_file_instance_abnormal (file_identifier, ame$ring_validation_error,
          call_block.operation, error_text, status);
  ELSEIF NOT (pfc$read IN file_instance^.instance_attributes.dynamic_label.
        access_mode) THEN
    amp$set_file_instance_abnormal (file_identifier,
          ame$improper_input_attempt, call_block.operation, ' PFC$READ',
          status);
  IFEND;

{ end of BAI$VALIDATE_READ_ACCESS
{


*DECK DECK=BAI$VALIDATE_RECORD_HEADER EXPAND=FALSE
{
{ BAI$VALIDATE_RECORD_HEADER
{
{ This code does validation of a record header.
{ Validation is attempted at record_info.current_byte_address.
{ record_info.current_byte_address must be set by caller.

  record_header := #ADDRESS (osc$min_ring, #SEGMENT (file_instance^.file_pva),
        record_info.current_byte_address);

  IF (record_header^.unique_id = bac$record_header_unique_id) { } AND
        (record_header^.length <= UPPERVALUE (record_header^.length)) { } AND
        (record_header^.length >= LOWERVALUE (record_header^.length)) { } AND
        (record_header^.previous_header_fba <=
        UPPERVALUE (record_header^.previous_header_fba)) { } AND
        (record_header^.previous_header_fba >=
        LOWERVALUE (record_header^.previous_header_fba)) { } AND
        (record_header^.header_type <= UPPERVALUE (record_header^.header_type))
        { } AND (record_header^.header_type >=
        LOWERVALUE (record_header^.header_type)) THEN
    record_info.bor_address := record_info.current_byte_address;
  ELSE
    amp$set_file_instance_abnormal (file_identifier,
          ame$improper_record_header, call_block.operation, error_text,
          status);
  IFEND;

{ end of BAI$VALIDATE_RECORD_HEADER
{

*DECK DECK=BAI$VALIDATE_TAPE_ACCESS EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc ame$access_validation_errors
*copyc amp$set_file_instance_abnormal
*copyc bat$task_file_table
*copyc ost$status
*copyc pfd$permanent_file_attributes
?? POP ??

  PROCEDURE [INLINE] bai$validate_tape_access
    (    file_identifier: amt$file_identifier;
         access_mode: pft$usage_selections;
         operation: amt$fap_operation;
         tape_descriptor: ^bat$tape_descriptor;
     VAR status: ost$status);

    CASE operation OF

*copy bac$read_requests

      IF operation = amc$skip_req THEN
        tape_descriptor^.at_eoi := FALSE;
      ELSE
        IF NOT (pfc$read IN access_mode) THEN
          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_access_attempt, operation, 'READ', status);
        IFEND;

      IFEND;

*copy bac$write_requests

      IF tape_descriptor^.at_eoi THEN
        IF NOT ((pfc$append IN access_mode) OR (pfc$shorten IN access_mode)) THEN
          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_access_attempt, operation, 'APPEND or SHORTEN', status);
        IFEND;
      ELSEIF NOT (pfc$shorten IN access_mode) THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_access_attempt, operation, 'SHORTEN', status);
      IFEND;

    ELSE
    CASEND;

  PROCEND bai$validate_tape_access;
*DECK DECK=BAI$VALIDATE_WRITE_ACCESS EXPAND=FALSE
{
{ BAI$VALIDATE_WRITE_ACCESS
{
{ This code does general validation for all writes.
{ Note that working_storage_length is in the same location in the call_block
{ of all put operations.

  IF (call_block.putn.working_storage_length < 0) OR
        (call_block.putn.working_storage_length >
        UPPERVALUE (amt$working_storage_length)) THEN
    amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
          call_block.operation, error_text, status);
  ELSEIF caller_id.ring > file_instance^.instance_attributes.static_label.
        ring_attributes.r1 THEN
    amp$set_file_instance_abnormal (file_identifier, ame$ring_validation_error,
          call_block.operation, error_text, status);
  ELSEIF (file_instance^.global_file_information^.positioning_info.record_info.
        current_byte_address < file_instance^.global_file_information^.
        eoi_byte_address) THEN
    IF (file_instance^.instance_attributes.static_label.file_organization =
          amc$sequential) AND NOT (pfc$shorten IN
          file_instance^.instance_attributes.dynamic_label.access_mode) THEN

{ Note: A put_direct on sequential access will shorten a file.

      amp$set_file_instance_abnormal (file_identifier,
            ame$improper_access_attempt, call_block.operation, ' SHORTEN',
            status);
    ELSEIF (file_instance^.instance_attributes.static_label.file_organization =
          amc$byte_addressable) AND NOT ((pfc$modify IN
          file_instance^.instance_attributes.dynamic_label.access_mode) OR
          (pfc$shorten IN file_instance^.instance_attributes.dynamic_label.
          access_mode)) THEN
      amp$set_file_instance_abnormal (file_identifier,
            ame$improper_access_attempt, call_block.operation,
            ' MODIFY OR SHORTEN', status);
    IFEND;
  ELSE
    IF NOT (pfc$append IN file_instance^.instance_attributes.dynamic_label.
          access_mode) THEN
      amp$set_file_instance_abnormal (file_identifier,
            ame$improper_access_attempt, call_block.operation, ' APPEND',
            status);
    IFEND;
  IFEND;

{  end of BAI$VALIDATE_WRITE_ACCESS
{
*DECK DECK=BAI$WRITE_BLOCK_HEADER EXPAND=FALSE
{
{ BAI$WRITE_BLOCK_HEADER

    block_header^.unique_id := bac$block_header_unique_id;
    block_header^.padding := bac$block_header_padding;

    record_info.current_byte_address := record_info.current_byte_address + #SIZE (bat$block_header);

{ Caller must set block_header^.block_length.
{
{ end of BAI$WRITE_BLOCK_HEADER
{

*DECK DECK=BAI$WRITE_PREVIOUS_BLOCK EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc bat$task_file_table
*copyc ost$status
*copyc amt$call_block
?? POP ??

{
{ The purpose of this request is to cause the previous partial
{ block to be completed, then written to tape.  This is necessary
{ when a partial block has been started, but not completed
{ before repositioning or closing the file.
{
*copy bah$inline_proc_documentation

  PROCEDURE [INLINE] bai$write_previous_block (file_identifier:
    amt$file_identifier;
    VAR status: ost$status);

  CONST
    terminate_previous_block = TRUE;

    IF (tape_descriptor^.tape_attachment_information.record_type = amc$ansi_spanned) OR
          (tape_descriptor^.tape_attachment_information.record_type = amc$ansi_variable) THEN
      put_data (file_identifier, amc$put_next_req, NIL, 0, amc$terminate,
            terminate_previous_block, {convert_if_ebcdic} TRUE, status);
    ELSE
      put_data (file_identifier, amc$put_next_req, NIL, 0, amc$terminate,
            terminate_previous_block, {convert_if_ebcdic} FALSE, status);
    IFEND;

    gfi^.positioning_info.record_info.file_position := amc$eor;
    IF NOT status.normal and (status.condition = ame$end_of_tape_op_completed) THEN
      status.normal := TRUE;  {ignore EOT in this case}
    IFEND;

  PROCEND bai$write_previous_block;
*DECK DECK=BAI$WRITE_RECORD_HEADER EXPAND=FALSE
{
{ BAI$WRITE_RECORD_HEADER
{
{ This code writes a variable record_header.
{ Record_length must be set by the calling procedure.

record_header := #ADDRESS (osc$min_ring, #SEGMENT (file_instance^.file_pva),
        record_info.current_byte_address);

  record_header^.header_type := bac$full_record;
  record_header^.previous_header_fba := record_info.bor_address;
  record_header^.unique_id := bac$record_header_unique_id;

  record_info.bor_address := record_info.current_byte_address;
  record_info.current_byte_address := record_info.current_byte_address +
        #SIZE (bat$record_header);

{ end of BAI$WRITE_RECORD_HEADER
{

*DECK DECK=BAK$BAP_PROCEDURE_KEYPOINTS EXPAND=FALSE
{ this deck defines constants for use  with
{ keypoints in bap procedures.
{ COMMON DECK bak$bap_procedure_keypoints }

  CONST
    bak$control = bak$base + 1,
    {E 'bap$control' }
    {X 'bap$control' }

    bak$connected_file_device = bak$base + 2,
    {E 'bap$connected_file_device' }
    {X 'bap$connected_file_device' }

    bak$open_file = bak$base + 4,
    {E 'bap$open_file' }
    {X 'bap$open_file' }

    bak$log_device = bak$base + 5,
    {E 'bap$log_device' }
    {X 'bap$log_device' }

    bak$us_blk_undef_rec_tape_fap = bak$base + 59,
    {E 'bap$us_blk_undefined_rec_tape_fap' 'fid.ord' H16 }
    {E 8.122 'us_undef_tape - get_next' 'fid + op' I12 }
    {E 8.134 'us_undef_tape - put_next' 'fid + op' I12 }
    {E 8.124 'us_undef_tape - get_partial' 'fid + op' I12 }
    {E 8.135 'us_undef_tape - put_partial' 'fid + op' I12 }
    {E 8.147 'us_undef_tape - seek_direct' 'fid + op' I12 }
    {E 8.119 'us_undef_tape - get_direct' 'fid + op' I12 }
    {E 8.131 'us_undef_tape - put_direct' 'fid + op' I12 }
    {E 8.150 'us_undef_tape - skip' 'fid + op' I12 }
    {E 8.128 'us_undef_tape - open' 'fid + op' I12 }
    {E 8.101 'us_undef_tape - fetch_access_information' 'fid + op' I12 }
    {E 8.117 'us_undef_tape - fetch' 'fid + op' I12 }
    {E 8.126 'us_undef_tape - get_segment_pointer' 'fid + op' I12 }
    {E 8.148 'us_undef_tape - set_segment_eoi' 'fid + op' I12 }
    {E 8.149 'us_undef_tape - set_segment_position' 'fid + op' I12 }
    {E 8.145 'us_undef_tape - rewind' 'fid + op' I12 }
    {E 8.152 'us_undef_tape - store' 'fid + op' I12 }
    {E 8.112 'us_undef_tape - close' 'fid + op' I12 }
    {E 8.160 'us_undef_tape - ifc$fetch_terminal' 'fid + op' I12 }
    {E 8.161 'us_undef_tape - ifc$store_terminal' 'fid + op' I12 }
    {X 'bap$us_blk_undefined_rec_tape_fap  ' 'status' I20 }

    bak$sys_blk_undef_rec_tape_fap = bak$base + 60,
    {E 'bap$sys_blk_undefined_rec_tape_fap' 'fid.ord' H16 }
    {E 8.122 'sys_undef_tape - get_next' 'fid + op' I12 }
    {E 8.134 'sys_undef_tape - put_next' 'fid + op' I12 }
    {E 8.124 'sys_undef_tape - get_partial' 'fid + op' I12 }
    {E 8.135 'sys_undef_tape - put_partial' 'fid + op' I12 }
    {E 8.147 'sys_undef_tape - seek_direct' 'fid + op' I12 }
    {E 8.119 'sys_undef_tape - get_direct' 'fid + op' I12 }
    {E 8.131 'sys_undef_tape - put_direct' 'fid + op' I12 }
    {E 8.150 'sys_undef_tape - skip' 'fid + op' I12 }
    {E 8.128 'sys_undef_tape - open' 'fid + op' I12 }
    {E 8.101 'sys_undef_tape - fetch_access_info' 'fid + op' I12 }
    {E 8.117 'sys_undef_tape - fetch' 'fid + op' I12 }
    {E 8.126 'sys_undef_tape - get_segment_pointer' 'fid + op' I12 }
    {E 8.148 'sys_undef_tape - set_segment_eoi' 'fid + op' I12 }
    {E 8.149 'sys_undef_tape - set_segment_position' 'fid + op' I12 }
    {E 8.145 'sys_undef_tape - rewind' 'fid + op' I12 }
    {E 8.152 'sys_undef_tape - store' 'fid + op' I12 }
    {E 8.112 'sys_undef_tape - close' 'fid + op' I12 }
    {E 8.160 'sys_undef_tape - ifc$fetch_terminal' 'fid + op' I12 }
    {E 8.161 'sys_undef_tape - ifc$store_terminal' 'fid + op' I12 }
    {X 'bap$sys_blk_undefined_rec_tape_fap  ' 'status' I20 }

    bak$sys_blk_var_rec_tape_fap = bak$base + 61,
    {E 'bap$sys_blk_var_rec_tape_fap' 'fid.ord' H16 }
    {E 8.122 'sys_var_tape - get_next' 'fid + op' I12 }
    {E 8.134 'sys_var_tape - put_next' 'fid + op' I12 }
    {E 8.124 'sys_var_tape - get_partial' 'fid + op' I12 }
    {E 8.135 'sys_var_tape - put_partial' 'fid + op' I12 }
    {E 8.147 'sys_var_tape - seek_direct' 'fid + op' I12 }
    {E 8.119 'sys_var_tape - get_direct' 'fid + op' I12 }
    {E 8.131 'sys_var_tape - put_direct' 'fid + op' I12 }
    {E 8.150 'sys_var_tape - skip' 'fid + op' I12 }
    {E 8.128 'sys_var_tape - open' 'fid + op' I12 }
    {E 8.101 'sys_var_tape - fetch_access_information' 'fid + op' I12 }
    {E 8.117 'sys_var_tape - fetch' 'fid + op' I12 }
    {E 8.126 'sys_var_tape - get_segment_pointer' 'fid + op' I12 }
    {E 8.148 'sys_var_tape - set_segment_eoi' 'fid + op' I12 }
    {E 8.149 'sys_var_tape - set_segment_position' 'fid + op' I12 }
    {E 8.145 'sys_var_tape - rewind' 'fid + op' I12 }
    {E 8.152 'sys_var_tape - store' 'fid + op' I12 }
    {E 8.112 'sys_var_tape - close' 'fid + op' I12 }
    {E 8.160 'sys_var_tape - ifc$fetch_terminal' 'fid + op' I12 }
    {E 8.161 'sys_var_tape - ifc$store_terminal' 'fid + op' I12 }
    {X 'bap$sys_blk_var_rec_tape_fap  ' 'status' I20 }

    bak$us_blk_var_rec_tape_fap = bak$base + 63,
    {E 'bap$us_blk_var_rec_tape_fap' 'fid.ord' H16 }
    {E 8.122 'us_var_tape - get_next' 'fid + op' I12 }
    {E 8.134 'us_var_tape - put_next' 'fid + op' I12 }
    {E 8.124 'us_var_tape - get_partial' 'fid + op' I12 }
    {E 8.135 'us_var_tape - put_partial' 'fid + op' I12 }
    {E 8.147 'us_var_tape - seek_direct' 'fid + op' I12 }
    {E 8.119 'us_var_tape - get_direct' 'fid + op' I12 }
    {E 8.131 'us_var_tape - put_direct' 'fid + op' I12 }
    {E 8.150 'us_var_tape - skip' 'fid + op' I12 }
    {E 8.128 'us_var_tape - open' 'fid + op' I12 }
    {E 8.101 'us_var_tape - fetch_access_information' 'fid + op' I12 }
    {E 8.117 'us_var_tape - fetch' 'fid + op' I12 }
    {E 8.126 'us_var_tape - get_segment_pointer' 'fid + op' I12 }
    {E 8.148 'us_var_tape - set_segment_eoi' 'fid + op' I12 }
    {E 8.149 'us_var_tape - set_segment_position' 'fid + op' I12 }
    {E 8.145 'us_var_tape - rewind' 'fid + op' I12 }
    {E 8.152 'us_var_tape - store' 'fid + op' I12 }
    {E 8.112 'us_var_tape - close' 'fid + op' I12 }
    {E 8.160 'us_var_tape - ifc$fetch_terminal' 'fid + op' I12 }
    {E 8.161 'us_var_tape - ifc$store_terminal' 'fid + op' I12 }
    {X 'bap$us_blk_var_rec_tape_fap  ' 'status' I20 }

    bak$sys_blk_fixed_rec_tape_fap = bak$base + 65,
    {E 'bap$sys_blk_fixed_rec_tape_fap' 'fid.ord' H16 }
    {E 8.122 'sys_fixed_tape - get_next' 'fid + op' I12 }
    {E 8.134 'sys_fixed_tape - put_next' 'fid + op' I12 }
    {E 8.124 'sys_fixed_tape - get_partial' 'fid + op' I12 }
    {E 8.135 'sys_fixed_tape - put_partial' 'fid + op' I12 }
    {E 8.147 'sys_fixed_tape - seek_direct' 'fid + op' I12 }
    {E 8.119 'sys_fixed_tape - get_direct' 'fid + op' I12 }
    {E 8.131 'sys_fixed_tape - put_direct' 'fid + op' I12 }
    {E 8.150 'sys_fixed_tape - skip' 'fid + op' I12 }
    {E 8.128 'sys_fixed_tape - open' 'fid + op' I12 }
    {E 8.101 'sys_fixed_tape - fetch_access_info' 'fid + op' I12 }
    {E 8.117 'sys_fixed_tape - fetch' 'fid + op' I12 }
    {E 8.126 'sys_fixed_tape - get_segment_pointer' 'fid + op' I12 }
    {E 8.148 'sys_fixed_tape - set_segment_eoi' 'fid + op' I12 }
    {E 8.149 'sys_fixed_tape - set_segment_position' 'fid + op' I12 }
    {E 8.145 'sys_fixed_tape - rewind' 'fid + op' I12 }
    {E 8.152 'sys_fixed_tape - store' 'fid + op' I12 }
    {E 8.112 'sys_fixed_tape - close' 'fid + op' I12 }
    {E 8.160 'sys_fixed_tape - ifc$fetch_terminal' 'fid + op' I12 }
    {E 8.161 'sys_fixed_tape - ifc$store_terminal' 'fid + op' I12 }
    {X 'bap$sys_blk_fixed_rec_tape_fap  ' 'status' I20 }

    bak$us_blk_fixed_rec_tape_fap = bak$base + 67,
    {E 'bap$us_blk_fixed_rec_tape_fap' 'fid.ord' H16 }
    {E 8.122 'us_fixed_tape - get_next' 'fid + op' I12 }
    {E 8.134 'us_fixed_tape - put_next' 'fid + op' I12 }
    {E 8.124 'us_fixed_tape - get_partial' 'fid + op' I12 }
    {E 8.135 'us_fixed_tape - put_partial' 'fid + op' I12 }
    {E 8.147 'us_fixed_tape - seek_direct' 'fid + op' I12 }
    {E 8.119 'us_fixed_tape - get_direct' 'fid + op' I12 }
    {E 8.131 'us_fixed_tape - put_direct' 'fid + op' I12 }
    {E 8.150 'us_fixed_tape - skip' 'fid + op' I12 }
    {E 8.128 'us_fixed_tape - open' 'fid + op' I12 }
    {E 8.101 'us_fixed_tape - fetch_access_information' 'fid + op' I12 }
    {E 8.117 'us_fixed_tape - fetch' 'fid + op' I12 }
    {E 8.126 'us_fixed_tape - get_segment_pointer' 'fid + op' I12 }
    {E 8.148 'us_fixed_tape - set_segment_eoi' 'fid + op' I12 }
    {E 8.149 'us_fixed_tape - set_segment_position' 'fid + op' I12 }
    {E 8.145 'us_fixed_tape - rewind' 'fid + op' I12 }
    {E 8.152 'us_fixed_tape - store' 'fid + op' I12 }
    {E 8.112 'us_fixed_tape - close' 'fid + op' I12 }
    {E 8.160 'us_fixed_tape - ifc$fetch_terminal' 'fid + op' I12 }
    {E 8.161 'us_fixed_tape - ifc$store_terminal' 'fid + op' I12 }
    {X 'bap$us_blk_fixed_rec_tape_fap  ' 'status' I20 }

    bak$labelled_tape_fap = bak$base + 69;
    {E 'bap$labelled_tape_fap' 'fid.ord' H16 }
    {E 8.122 'labelled_tape - get_next' 'fid + op' I12 }
    {E 8.134 'labelled_tape - put_next' 'fid + op' I12 }
    {E 8.124 'labelled_tape - get_partial' 'fid + op' I12 }
    {E 8.135 'labelled_tape - put_partial' 'fid + op' I12 }
    {E 8.147 'labelled_tape - seek_direct' 'fid + op' I12 }
    {E 8.119 'labelled_tape - get_direct' 'fid + op' I12 }
    {E 8.131 'labelled_tape - put_direct' 'fid + op' I12 }
    {E 8.150 'labelled_tape - skip' 'fid + op' I12 }
    {E 8.128 'labelled_tape - open' 'fid + op' I12 }
    {E 8.101 'labelled_tape - fetch_access_information' 'fid + op' I12 }
    {E 8.117 'labelled_tape - fetch' 'fid + op' I12 }
    {E 8.126 'labelled_tape - get_segment_pointer' 'fid + op' I12 }
    {E 8.148 'labelled_tape - set_segment_eoi' 'fid + op' I12 }
    {E 8.149 'labelled_tape - set_segment_position' 'fid + op' I12 }
    {E 8.145 'labelled_tape - rewind' 'fid + op' I12 }
    {E 8.152 'labelled_tape - store' 'fid + op' I12 }
    {E 8.112 'labelled_tape - close' 'fid + op' I12 }
    {E 8.160 'labelled_tape - ifc$fetch_terminal' 'fid + op' I12 }
    {E 8.161 'labelled_tape - ifc$store_terminal' 'fid + op' I12 }
    {X 'bap$labelled_tape_fap  ' 'status' I20 }

?? PUSH (LISTEXT := ON) ??
*copyc osk$keypoints
?? POP ??
*DECK DECK=BAM$2DD_STATIC_VARIABLE_HELPER EXPAND=TRUE
*copyc osd$default_pragmats
MODULE bam$2dd_static_variable_helper;
MODEND bam$2dd_static_variable_helper;
*DECK DECK=BAM$BYTE_MOVE EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE bam$byte_move;

{ MODULE DECK BAMBMV }
?? TITLE := ' PROCEDRUE BAP$BYTE_MOVE ' ??
?? PUSH (LISTEXT := ON) ??
*copyc I#MOVE
*copyc AME$IMPROPER_FILE_ID
*copyc BAV$TASK_FILE_TABLE
*copyc OSP$SET_STATUS_ABNORMAL
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc AMP$SET_LOCAL_NAME_ABNORMAL
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc MMP$ADVISE_OUT
*copyc MMP$PRESET_PAGE_STREAMING
*copyc syp$advised_move_bytes
*copyc OST$CALLER_IDENTIFIER
*copyc osp$verify_system_privilege
*copyc BAT$TASK_FILE_TABLE
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$ACCESS_VALIDATION_ERRORS
?? POP ??

  PROCEDURE [XDCL, #GATE] bap$byte_move (from_fid: amt$file_identifier;
        to_fid: amt$file_identifier;
        move: amt$file_byte_address;
        last_move: boolean;
    VAR byte_offset: amt$file_byte_address;
    VAR status: ost$status);


    CONST
      minimum_preset = 4096,
      move_transfer_size =  10000(16);   { 65536 bytes

    VAR
      advise_size: integer,
      advise_pointer: ^cell,
      from_pointer: ^cell,
      to_pointer: ^cell,
      file_id_is_valid: boolean,
      file_instance_from: ^bat$task_file_entry,
      file_instance_to: ^bat$task_file_entry,
      ignore_transfer_size: 0..15,
      ignore_free_behind: boolean,
      caller_id: ost$caller_identifier;

    PROCEDURE byte_move_rollback_proc (condition_status: ost$status);

      status := condition_status;
      file_instance_from^.rollback_procedure := NIL;
      file_instance_to^.rollback_procedure := NIL;
      EXIT bap$byte_move;
    PROCEND byte_move_rollback_proc;

  /main_program/
    BEGIN
      osp$verify_system_privilege;
      #caller_id (caller_id);

      status.normal := TRUE;

      bap$validate_file_identifier (from_fid, file_instance_from, file_id_is_valid);
      IF NOT file_id_is_valid THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
          'bap$byte_move', status);
        RETURN;
      IFEND;

      bap$validate_file_identifier (to_fid, file_instance_to, file_id_is_valid);
      IF NOT file_id_is_valid THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
          'bap$byte_move', status);
        RETURN;
      IFEND;

      IF caller_id.ring > file_instance_from^.instance_attributes.static_label.ring_attributes.r2 THEN
        amp$set_file_instance_abnormal (from_fid, ame$ring_validation_error,
              fsc$copy_file_req, ' ', status);
        EXIT /main_program/;
      IFEND;

      IF file_instance_from^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (from_fid, ame$improper_access_attempt,
              fsc$copy_file_req, ' RECORD ', status);
        EXIT /main_program/;
      IFEND;

      IF NOT (pfc$read IN file_instance_from^.instance_attributes.dynamic_label.access_mode) THEN
        amp$set_file_instance_abnormal (from_fid, ame$improper_access_attempt,
              fsc$copy_file_req, ' READ ', status);
        EXIT /main_program/;
      IFEND;

      IF caller_id.ring > file_instance_to^.instance_attributes.static_label.ring_attributes.r1 THEN
        amp$set_file_instance_abnormal (to_fid, ame$ring_validation_error,
              fsc$copy_file_req, ' ', status);
        EXIT /main_program/;
      IFEND;

      IF file_instance_to^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (to_fid, ame$improper_access_attempt,
              fsc$copy_file_req, ' RECORD ', status);
        EXIT /main_program/;
      IFEND;

      IF NOT (file_instance_to^.instance_attributes.dynamic_label.access_mode >=
            $pft$usage_selections [pfc$shorten, pfc$append]) THEN
        amp$set_file_instance_abnormal (to_fid, ame$improper_access_attempt,
              fsc$copy_file_req, ' SHORTEN, APPEND ', status);
        EXIT /main_program/;
      IFEND;

      file_instance_from^.rollback_procedure := ^byte_move_rollback_proc;
      file_instance_to^.rollback_procedure := ^byte_move_rollback_proc;

      from_pointer := #ADDRESS ( #RING (file_instance_from^.file_pva),
            #SEGMENT (file_instance_from^.file_pva), byte_offset);
      to_pointer := #address ( #RING (file_instance_to^.file_pva),
            #SEGMENT (file_instance_to^.file_pva), byte_offset);

      IF byte_offset = 0  THEN  {this is the first call, check the length

{ BAM$BYTE_MOVE will be called repeatedly in blocks of 512K if the move is a large move. For the first
{ call determine the appropriate action:
{   a) If the number of bytes is <=  minimum_preset (4096), just use I#MOVE without presetting stream mode
{   b) Otherwise, call mmp$preset_page_streaming for both the source and the destination files and then
{      use I#MOVE for the move.  Note that the reason for setting streaming mode on the destination file
{      is to ensure that free_behind is true.
{
        IF move > minimum_preset  THEN
          mmp$preset_page_streaming (TRUE, from_pointer, move_transfer_size, ignore_transfer_size,
                ignore_free_behind, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

{ Use 16K transfer size on the destination file so that free behind will release pages faster than it
{ would at a 64K transfer size.  Note that if the disk allocation unit > 16K, the free behind
{ process within the page fault processor will actually use AU size as the free behind size.

          mmp$preset_page_streaming (TRUE, to_pointer, 16384, ignore_transfer_size,
                ignore_free_behind, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;

      IFEND;  {byte_offset=0

      I#MOVE(from_pointer, to_pointer, move);
      byte_offset := byte_offset + move;

      IF file_instance_from^.private_read_information <> NIL THEN
        file_instance_from^.private_read_information^.positioning_info.
              record_info.current_byte_address := byte_offset;
      ELSE
        file_instance_from^.global_file_information^.positioning_info.record_info.
              current_byte_address := byte_offset;
      IFEND;

      file_instance_to^.instance_of_open_modified := TRUE;

      file_instance_to^.global_file_information^.positioning_info.record_info.
            current_byte_address := byte_offset;
      file_instance_to^.global_file_information^.eoi_byte_address :=
            byte_offset;
      file_instance_to^.global_file_information^.positioning_info.record_info.
            file_position := amc$eoi;

      IF last_move  THEN
        IF file_instance_from^.private_read_information <> NIL THEN
          file_instance_from^.private_read_information^.positioning_info.
                record_info.file_position := amc$eoi;
        ELSE
          file_instance_from^.global_file_information^.positioning_info.record_info.
                file_position := amc$eoi;
        IFEND;


        { Even though free_behind was set in the source file, the last 2 or 3 transfer units + a partial TU
        { are still in the working set.  In the destination file, the last transfer unit + a partial TU
        { are still in the working set.  Advise these pages out.  However, instead of calculating which pages
        { to advise_out, just advise out the entire file.  The advise code will call remove pages which
        { will go through the chain of all pages of the segment in memory... this is as efficient as we
        { can get and it will thus get all pages out of memory.  (unless the pages are in the shared queue).

        advise_size:= #OFFSET (from_pointer) + move;
        advise_pointer := #ADDRESS (#RING (from_pointer), #SEGMENT (from_pointer), 0);
        mmp$advise_out (advise_pointer, advise_size, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        advise_size:= #OFFSET (to_pointer) + move;
        advise_pointer := #ADDRESS (#RING (to_pointer), #SEGMENT (to_pointer), 0);
        mmp$advise_out (advise_pointer, advise_size, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;   {last_move

    END /main_program/;
    file_instance_from^.rollback_procedure := NIL;
    file_instance_to^.rollback_procedure := NIL;

  PROCEND bap$byte_move;

MODEND bam$byte_move;
*DECK DECK=BAM$CHANGE_TAPE_BT_AND_RT EXPAND=TRUE
*copyc osd$default_pragmats
MODULE bam$change_tape_bt_and_rt;

?? TITLE := 'NOS/VE : BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] BAP$CHANGE_TAPE_BT_AND_RT' ??
?? NEWTITLE := '  RING BRACKETS 23D' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amt$file_identifier
*copyc ame$fap_validation_errors
*copyc ame$improper_file_id
*copyc bat$instance_attributes
*copyc ost$status
?? POP ??
*copyc bav$magnetic_tape_device_faps
*copyc bav$task_file_table
*copyc osp$set_status_abnormal
*copyc bap$validate_file_identifier
?? EJECT ??

  PROCEDURE [XDCL] bap$change_tape_bt_and_rt
    (    file_identifier: amt$file_identifier;
         layer_number: amt$fap_layer_number;
         block_type: amt$block_type;
         record_type: amt$record_type;
     VAR status: ost$status);

    PROCEDURE change_block_and_record_type
      (    block_type: amt$block_type;
           record_type: amt$record_type;
           layer: {i/o} ^bat$fap_descriptor;
           static_label: {i/o} ^bat$instance_static_attributes);

      layer^.access_method := bav$magnetic_tape_device_faps [block_type]
            [record_type];

      static_label^.block_type := block_type;
      static_label^.block_type_source := amc$local_file_information;

      static_label^.record_type := record_type;
      static_label^.record_type_source := amc$local_file_information;
    PROCEND change_block_and_record_type;

    CONST
      interface_name = 'BAP$CHANGE_TAPE_BT_AND_RT';

    VAR
      file_is_valid: boolean,
      file_instance: ^bat$task_file_entry;

    status.normal := TRUE;

    bap$validate_file_identifier (file_identifier, file_instance,
          file_is_valid);

    IF file_is_valid THEN
      IF (file_instance^.fap_control_information.fap_array = NIL) AND
            (layer_number = 0) THEN
        change_block_and_record_type (block_type, record_type,
              ^file_instance^.fap_control_information.first_fap,
              ^file_instance^.instance_attributes.static_label);
      ELSEIF (file_instance^.fap_control_information.fap_array <> NIL) AND
            (layer_number <= UPPERBOUND (file_instance^.fap_control_information.
            fap_array^)) THEN
        change_block_and_record_type (block_type, record_type,
              ^file_instance^.fap_control_information.fap_array^ [layer_number],
              ^file_instance^.instance_attributes.static_label);
        IF layer_number = 0 THEN
          change_block_and_record_type (block_type, record_type,
                ^file_instance^.fap_control_information.first_fap,
                ^file_instance^.instance_attributes.static_label);
        IFEND;
      ELSE
        osp$set_status_abnormal (amc$access_method_id,
              ame$improper_layer_number, interface_name, status);
      IFEND;
    ELSE
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
    IFEND;
  PROCEND bap$change_tape_bt_and_rt;

MODEND bam$change_tape_bt_and_rt;
*DECK DECK=BAM$CLOSE EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE Basic_Access_method : Close File' ??

MODULE bam$close;

{
{ PURPOSE:
{   This module performs most of the operations necessary to close a file.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$improper_file_id
*copyc ame$put_program_actions
*copyc ame$ring_validation_errors
*copyc bac$minimum_open_ring
*copyc bat$global_file_information
*copyc bat$task_file_table
*copyc cle$ecc_miscellaneous
*copyc fse$close_validation_errors
*copyc fst$file_access_options
*copyc mme$condition_codes
*copyc mmt$attribute_keyword
*copyc osd$virtual_address
*copyc ost$caller_identifier
*copyc ost$name
*copyc rmt$device_class
*copyc rmd$tape_declarations
?? POP ??
*copyc amp$set_file_instance_abnormal
{*copyc bap$pad_to_minbl
*copyc bap$release_tft_entry
*copyc bap$validate_file_identifier
*copyc fmp$close_file
*copyc mmp$set_segment_length
*copyc mmp$write_modified_pages
*copyc osp$file_access_condition
*copyc osp$generate_log_message
*copyc osp$increment_locked_variable
*copyc osp$set_status_abnormal
*copyc osp$verify_system_privilege

*copyc osv$task_private_heap
?? OLDTITLE ??

?? NEWTITLE := '[XDCL, #GATE] bap$close', EJECT ??
  PROCEDURE [XDCL, #GATE] bap$close (file_identifier: amt$file_identifier;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      local_status: ost$status,
      special_status: ost$status,
      open_count: integer;

    status.normal := TRUE;
    #caller_id (caller_id);

    bap$validate_file_identifier (file_identifier, file_instance,
          file_id_is_valid);
    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
        'AMP$CLOSE', status);
      RETURN;
    IFEND;

    IF caller_id.ring > file_instance^.open_ring THEN
      amp$set_file_instance_abnormal (file_identifier,
            ame$ring_validation_error, amc$close_req, '', status);
      RETURN;
    IFEND;

    IF NOT (file_instance^.close_allowed) THEN
      amp$set_file_instance_abnormal (file_identifier, fse$close_of_target_not_allowed,
        amc$close_req, '', status);
      RETURN;
    IFEND;

    CASE file_instance^.device_class OF
    = rmc$mass_storage_device =
      IF (file_instance^.access_level = amc$record) AND file_instance^.
            instance_of_open_modified AND (file_instance^.file_pva <> NIL) THEN
        mmp$set_segment_length (file_instance^.file_pva, bac$minimum_open_ring,
              file_instance^.global_file_information^.eoi_byte_address, local_status);
        IF osp$file_access_condition (local_status) THEN
          status := local_status;
        IFEND;

       { Protect against an escaped allocation condition at detach}

        bap$write_modified_pages (file_instance, file_identifier, special_status);
        IF osp$file_access_condition (special_status) THEN
          status := special_status;
        IFEND;


      IFEND;
    ELSE
    CASEND;

    fmp$close_file (file_instance, local_status);
    IF osp$file_access_condition (local_status) THEN
      osp$increment_locked_variable (file_instance^.global_file_information^.open_count,
            0, open_count);
      status := local_status;
      RETURN;
    IFEND;

    bap$release_tft_entry (file_instance, file_identifier.ordinal);

  PROCEND bap$close;
?? OLDTITLE ??

?? NEWTITLE := '[XDCL] bap$write_modified_pages', EJECT ??
  PROCEDURE [XDCL] bap$write_modified_pages (file_instance:
    ^bat$task_file_entry;
        file_identifier: amt$file_identifier;
    VAR status: ost$status);

    VAR
      mm_status,
      ignore_status: ost$status;

    status.normal := TRUE;
    IF file_instance^.file_pva <> NIL THEN
      IF (file_instance^.instance_attributes. dynamic_label.access_mode *
            $pft$usage_selections [pfc$shorten, pfc$append, pfc$modify]) <>
            $pft$usage_selections [] THEN
        mmp$write_modified_pages (file_instance^.file_pva, osc$maximum_offset,
              osc$wait, mm_status);
        IF (NOT mm_status.normal) THEN
          IF NOT osp$file_access_condition (mm_status) THEN
            IF mm_status.condition = mme$io_write_error THEN
              amp$set_file_instance_abnormal (file_identifier,
                    ame$unrecovered_write_error, amc$close_req, ' ', status);
              osp$generate_log_message ($pmt$ascii_logset [pmc$job_log,
                    pmc$system_log], status, ignore_status);
            ELSE
              osp$generate_log_message ($pmt$ascii_logset [pmc$job_log,
                    pmc$system_log], mm_status, ignore_status);
            IFEND;
          ELSE
            status := mm_status;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND bap$write_modified_pages;
?? OLDTITLE ??

?? NEWTITLE := 'PROCEDURE [XDCL] bap$inhibit_implicit_detach', EJECT ??
  PROCEDURE [XDCL] bap$inhibit_implicit_detach
    (    file_identifier: amt$file_identifier);

    VAR
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry;

    bap$validate_file_identifier (file_identifier, file_instance, file_id_is_valid);
    IF file_id_is_valid THEN
      file_instance^.global_file_information^.implicit_detach_inhibited := TRUE;
    IFEND;

  PROCEND bap$inhibit_implicit_detach;
?? OLDTITLE ??

?? NEWTITLE := 'PROCEDURE [XDCL, #GATE] bap$set_close_allowed', EJECT ??
  PROCEDURE [XDCL, #GATE] bap$set_close_allowed
    (    file_identifier: amt$file_identifier);

    VAR
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry;

    osp$verify_system_privilege;
    bap$validate_file_identifier (file_identifier, file_instance,
          file_id_is_valid);
    IF file_id_is_valid THEN
      file_instance^.close_allowed := TRUE;
    IFEND;

  PROCEND bap$set_close_allowed;

?? NEWTITLE := 'PROCEDURE [XDCL, #GATE] bap$set_return_at_close', EJECT ??
  PROCEDURE [XDCL, #GATE] bap$set_return_at_close
    (    file_identifier: amt$file_identifier);

    VAR
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry;

    osp$verify_system_privilege;
    bap$validate_file_identifier (file_identifier, file_instance,
          file_id_is_valid);
    IF file_id_is_valid THEN
      file_instance^.instance_attributes.dynamic_label.return_option := amc$return_at_close;
      file_instance^.instance_attributes.dynamic_label.return_option_source := amc$open_request;
    IFEND;

  PROCEND bap$set_return_at_close;
?? OLDTITLE ??

MODEND bam$close;
*DECK DECK=BAM$CONNECTED_FILE_DEVICE EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Basic Access Method : Connected File Device' ??

MODULE bam$connected_file_device;

{
{ PURPOSE:
{   This module contains the processor for subjects of file connections.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$fap_validation_errors
*copyc ame$open_validation_errors
*copyc ame$unimplemented_request
*copyc amt$fap_declarations
*copyc amt$file_identifier
*copyc bak$bap_procedure_keypoints
*copyc clt$connected_file
*copyc fmc$entry_assigned
*copyc ife$error_codes
*copyc ost$caller_identifier
*copyc ost$status
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$rewind
*copyc amp$set_file_instance_abnormal
*copyc amp$skip
*copyc bap$close
*copyc bap$enable_close_of_target
*copyc bap$fetch
*copyc bap$force_update_of_targets
*copyc bap$null_device
*copyc bap$record_opened_file_target
*copyc bap$record_opened_subject_file
*copyc bap$record_subject_file_op
*copyc bap$store
*copyc bap$update_opened_subject_file
*copyc bap$validate_file_identifier
*copyc bav$last_tft_entry
*copyc bav$task_file_table
*copyc bav$tft_entry_assignment
*copyc clp$find_connected_files
*copyc clv$standard_files
*copyc fsp$close_file
*copyc fsp$convert_to_new_contents
*copyc fsp$open_file
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal

  CONST
    interface_name = 'BAP$CONNECTED_FILE_DEVICE';

  TYPE
    amt$input_requests = set of amc$get_direct_req .. amc$get_partial_req;

?? TITLE := 'bap$verify_file_connection_attr', EJECT ??
*copyc bap$verify_file_connection_attr
?? TITLE := 'bap$connected_file_device', EJECT ??
*copy bah$connected_file_device

  PROCEDURE [XDCL] bap$connected_file_device (subject_file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      connected_files: ^clt$connected_files,
      file_id_is_valid: boolean,
      file_is_open: boolean,
      file_position: amt$file_position,
      found_target_index: boolean,
      i: integer,
      index_of_last_target_file_id: clt$connected_file_target_index,
      last_target_file_instance: ^bat$task_file_entry,
      local_call_block: amt$call_block,
      local_status: ost$status,
      open_target: boolean,
      subject_file_attributes: array [1 .. 2] of amt$fetch_item,
      subject_file_instance: ^bat$task_file_entry,
      target_attachment_options: array [1 .. 2] OF fst$attachment_option,
      target_default_attributes: array [1 .. 1] OF fst$file_cycle_attribute,
      target_file: ^clt$connected_file_target,
      target_file_identifier: amt$file_identifier,
      target_file_index: clt$connected_file_target_index,
      target_file_instance: ^bat$task_file_entry,
      target_file_name: amt$local_file_name,
      target_mandated_attributes: array [1 .. 1] OF fst$file_cycle_attribute,
      update_targets: boolean;

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

{ PURPOSE:
{     This procedure checks whether or not a particular target file of a file
{     connection needs to be opened.
{
{ DESIGN:
{     A target file does NOT need to be opened if it is found in the task
{     file table.  When this is called:  (1) all obsolete target files
{     have been closed, and (2) if the i'th target is being checked then the
{     previous i-1 have already been opened.  Thus, this function needs to
{     locate the i'th TFT target (if it exists) and compare it to the i'th
{     target in the connected files table (as specified by target_file_path_
{     handle_name).  If they match, the file need not be opened.  If they don't
{     match or the match cannot be performed, the file needs to be opened.
{
{     The operation of this procedure is dependent on the procedure
{     bap$record_opened_file_target which orders a TFT subject's targets.
{
{     This procedure modifies 4 parameters.  Three of these exist so that
{     if we have located the i'th TFT target and then need to locate the
{     i+1'th, we needn't start with the first target but may start with the
{     i'th and look at the next.  The three parameters are:
{
{     1. last_target_file_instance - TFT instance corresponding to
{        last target file id located for the subject.  This is
{        undefined if found_target_index = FALSE.
{
{     2. index_of_last_target_file_id - This represents the position of
{        the 'last_target_file_id' in the TFT target list.
{
{     3. found_target_index - Set to TRUE when first valid target is found
{        for the subject in the TFT.


    PROCEDURE [INLINE] chk_if_need_to_open_target (
          subject_file_instance: ^bat$task_file_entry;
          target_file_index: clt$connected_file_target_index;
          target_file_path_handle_name: fst$path_handle_name;
      VAR {input, output} last_target_file_instance: ^bat$task_file_entry;
      VAR {input, output} index_of_last_target_file_id: clt$connected_file_target_index;
      VAR {input, output} found_target_index: boolean;
      VAR open_target: boolean);


      VAR
        i: clt$connected_file_target_index,
        file_id_is_valid: boolean,
        target_file_instance: ^bat$task_file_entry;

      open_target := TRUE;

    /set_open_target/
      BEGIN
        IF (target_file_index = 1) OR (NOT found_target_index) THEN
          IF subject_file_instance^.first_target.defined THEN
            bap$validate_file_identifier (subject_file_instance^.first_target.file_identifier,
                  target_file_instance, file_id_is_valid);
            IF file_id_is_valid THEN
              last_target_file_instance := target_file_instance;
              index_of_last_target_file_id := 1;
              found_target_index := TRUE;
            ELSE
              EXIT /set_open_target/;
            IFEND;
          ELSE
            EXIT /set_open_target/;
          IFEND;
        ELSE { (target_file_index > 1) AND (index_of_last_target_file_id > 0)
          target_file_instance := last_target_file_instance;
        IFEND;

{  At this point, target_file_instance is valid and corresponds to the
{  index_of_last_target_file_id'th TFT target.

        FOR i := (index_of_last_target_file_id + 1) TO target_file_index DO
          IF target_file_instance^.next_target.defined THEN
            bap$validate_file_identifier (target_file_instance^.next_target.file_identifier,
                   target_file_instance, file_id_is_valid);
            IF file_id_is_valid THEN
              last_target_file_instance := target_file_instance;
              index_of_last_target_file_id := i;
            ELSE
              EXIT /set_open_target/;
            IFEND;
          ELSE
            EXIT /set_open_target/;
          IFEND;
        FOREND;

{  At this point, target_file_instance is valid and corresponds to the
{  target_file_index'th target.

        open_target := target_file_instance^.local_file_name <>
              target_file_path_handle_name;

        RETURN;

      END /set_open_target/;

    PROCEND chk_if_need_to_open_target;
?? OLDTITLE, EJECT ??

    #keypoint (osk$entry, 0, bak$connected_file_device);

    #caller_id (caller_id);
    status.normal := TRUE;
    local_status.normal := TRUE;

  /fap/
    BEGIN
      bap$validate_file_identifier (subject_file_identifier, subject_file_instance, file_id_is_valid);
      IF NOT file_id_is_valid THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id, interface_name, status);
        #keypoint (osk$exit, 0, bak$connected_file_device);
        RETURN;
      IFEND;

      IF call_block.operation = amc$open_req THEN
        IF call_block.open.access_level <> amc$record THEN
          amp$set_file_instance_abnormal (subject_file_identifier, ame$not_virtual_memory_device,
                amc$open_req, 'CONNECTED FILE', local_status);
          EXIT /fap/;
        IFEND;
        bap$record_opened_subject_file (subject_file_identifier);
        update_targets := TRUE;
      ELSE
        clp$find_connected_files (connected_files);

{  Check for a PUSH.  If found, update the task_file_table entry pointers to the
{  connected_files table.  NOTE:  a POP calls bap$update_opened_subject_file for all
{  subjects.

        IF #offset(subject_file_instance^.connected_files) <> #offset(connected_files) THEN
          bap$update_opened_subject_file (subject_file_identifier);
        IFEND;

{  Check to see if it is necessary to synchronize the targets in the connected_files table
{  and the task_file table.
{
{  This is necessary if the connection_levels differ.  Consider the two cases:
{
{  1. subject_file_instance^.connection_level < subject_file_instance^.subject^.connection_level.
{     (the task file table's targets were last updated BEFORE the connected_file table's targets)
{     This can happen if another synchronous task has updated the subject's connections since
{     the last time this task accessed the subject or if this task has created/deleted another file
{     connection from the subject.
{
{  2. subject_file_instance^.connection_level > subject_file_instance^.subject^.connection_level.
{     (the task file table's targets were last updated AFTER the connected_file table's targets)
{     This occurs on a POP where the subject's connections were modified in the pushed
{     environment..

        update_targets := (subject_file_instance^.subject = NIL) OR
              (subject_file_instance^.connection_level <>
               subject_file_instance^.subject^.connection_level);

        IF update_targets THEN
          close_obsolete_target_files (subject_file_identifier, subject_file_instance, local_status);
        IFEND;
      IFEND;

      file_position := subject_file_instance^.global_file_information^.
            positioning_info.record_info.file_position;


{ Open targets because subject is being opened, or to }
{ bring the connections of the subject_file_instance level with the global }
{ description of connections for the subject file. }

      IF update_targets AND (subject_file_instance^.subject <> NIL) AND (subject_file_instance^.subject^.
            targets <> NIL) AND (call_block.operation <> amc$close_req) THEN

        local_call_block.operation := amc$fetch_req;
        local_call_block.fetch.file_attributes := ^subject_file_attributes;
        subject_file_attributes [1].key := amc$file_contents;
        subject_file_attributes [2].key := amc$file_structure;
        bap$fetch (subject_file_identifier, local_call_block, layer_number, local_status);
        IF NOT local_status.normal THEN
          EXIT /fap/;
        IFEND;

        target_file_index := 1;
        found_target_index := FALSE;

      /prepare_targets/
        FOR i := 1 TO UPPERBOUND (subject_file_instance^.subject^.targets^) DO
          target_file := ^subject_file_instance^.subject^.targets^ [i];
          IF target_file^.connection_active THEN

{  The target is always opened if (1) the subject is being opened, or (2) the connection has
{  not been recorded in the task_file_table.  The latter is detected by comparing the
{  connection levels of the target in the connected_files table and the subject in the task
{  file table.

            open_target := (call_block.operation = amc$open_req) OR (target_file^.connection_level >
                  subject_file_instance^.connection_level);

{  If neither of the above conditions is true, we may still need to open the target.  A scenario
{  where this may arise is closing the target in a pushed environment and then popping.

            IF ((NOT open_target) AND (target_file^.connection_level <
                  subject_file_instance^.connection_level)) THEN

              chk_if_need_to_open_target (subject_file_instance, target_file_index,
                    target_file^.path_handle_name,
                    last_target_file_instance, index_of_last_target_file_id,
                    found_target_index, open_target);
            IFEND;

            IF open_target THEN
              prepare_for_opening_target (subject_file_identifier, subject_file_instance,
                    subject_file_attributes [1].file_contents, subject_file_attributes [2].file_structure,
                    target_file, target_file_name, target_attachment_options, target_default_attributes,
                    target_mandated_attributes, local_status);
              IF local_status.normal THEN
                fsp$open_file (target_file_name, amc$record, ^target_attachment_options,
                      ^target_default_attributes, ^target_mandated_attributes, NIL, NIL,
                      target_file_identifier, local_status);
              IFEND;
              IF NOT local_status.normal THEN
                IF call_block.operation = amc$open_req THEN
                  EXIT /fap/;
                ELSEIF status.normal THEN
                  status := local_status;
                IFEND;
                local_status.normal := TRUE;
                CYCLE /prepare_targets/;
              IFEND;
              bap$record_opened_file_target (subject_file_identifier, target_file_index,
                    target_file_identifier, target_file^.connection_level);
            IFEND;

            target_file_index := target_file_index + 1;
          IFEND;
        FOREND /prepare_targets/;

      IFEND;


      IF NOT subject_file_instance^.first_target.defined THEN

{ If there are no targets, treat as a null_device file. }

        CASE call_block.operation OF
        = amc$open_req =
          ;
        = amc$close_req =
          bap$close (subject_file_identifier, local_status);
        ELSE
          bap$null_device (subject_file_identifier, call_block, layer_number, local_status);
          file_position := subject_file_instance^.global_file_information^.
                positioning_info.record_info.file_position;
        CASEND;
        EXIT /fap/;
      IFEND;

{ Process all target files. }

      IF call_block.operation = amc$open_req THEN
        EXIT /fap/;
      IFEND;

      target_file_identifier := subject_file_instance^.first_target.file_identifier;
      target_file_instance := NIL;

    /process_targets/
      WHILE TRUE DO
        bap$validate_file_identifier (target_file_identifier, target_file_instance, file_id_is_valid);
        IF NOT file_id_is_valid THEN
          osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id, interface_name, local_status);
          EXIT /fap/;
        IFEND;

      /process_target/
        BEGIN

          { The disposition of the operation is determined by the following
          { case statement. Most operations are actually performed at the
          { end of the case statement. Some require special handling and
          { those are dealt with in the corresponding case selector.

          CASE call_block.operation OF

          = amc$close_req =
            bap$enable_close_of_target (subject_file_identifier, target_file_identifier);
            fsp$close_file (target_file_identifier, local_status);
            EXIT /process_target/;

          = amc$close_volume_req =
            ;

          = amc$delete_req, amc$delete_direct_req, amc$delete_key_req =
            ;

          = amc$fetch_req =
            IF NOT target_file_instance^.next_target.defined THEN
              IF target_file_instance^.local_file_name =
                    clv$standard_files [clc$sf_null_file].path_handle_name THEN
                bap$fetch (subject_file_identifier, call_block, layer_number, local_status);
              ELSE
                target_file_instance^.fap_control_information.first_fap.access_method^
                 (target_file_identifier, call_block, 0, local_status);
              IFEND;
              EXIT /fap/;
            IFEND;
            EXIT /process_target/;

          = amc$fetch_access_information_rq =
            IF (subject_file_instance^.global_file_information^.last_access_operation IN ( -
                  $amt$input_requests [])) OR (NOT target_file_instance^.next_target.defined) THEN
              target_file_instance^.fap_control_information.first_fap.access_method^
                (target_file_identifier, call_block, 0, local_status);
              EXIT /fap/;
            IFEND;
            EXIT /process_target/;

          = amc$flush_req =
            ;

          = amc$get_direct_req, amc$get_key_req, amc$get_next_req, amc$get_next_key_req, amc$get_partial_req =
            target_file_instance^.fap_control_information.first_fap.access_method^
              (target_file_identifier, call_block, 0, local_status);
            IF target_file_instance^.private_read_information = NIL THEN
              file_position := target_file_instance^.global_file_information^.
                    positioning_info.record_info.file_position;
            ELSE
              file_position := target_file_instance^.private_read_information^.
                    positioning_info.record_info.file_position;
            IFEND;
            EXIT /fap/;

          = amc$get_label_req =
            target_file_instance^.fap_control_information.first_fap.access_method^
                 (target_file_identifier, call_block, 0, local_status);
            IF local_status.normal THEN
              EXIT /fap/;
            IFEND;
            EXIT /process_target/;

          = amc$open_req =
            {processed above} ;
            EXIT /fap/;

          = amc$put_direct_req, amc$put_key_req, amc$put_label_req, amc$put_next_req, amc$put_partial_req,
                amc$putrep_req, amc$replace_req, amc$replace_direct_req, amc$replace_key_req =
            ;

          = amc$rewind_req =
            amp$rewind (target_file_identifier, osc$wait, local_status);
            EXIT /process_target/;

          = amc$seek_direct_req =
            ;

          = amc$skip_req =
            amp$skip (target_file_identifier, call_block.skp.direction, call_block.skp.unit, call_block.skp.
                  count, call_block.skp.file_position^, local_status);
            EXIT /process_target/;

          = amc$store_req =
            ;

          = amc$write_end_partition_req, amc$write_tape_mark_req =
            ;

          = ifc$fetch_terminal_req =
            target_file_instance^.fap_control_information.first_fap.access_method^
                 (target_file_identifier, call_block, 0, local_status);
            IF local_status.normal THEN
              EXIT /fap/;
            ELSEIF (local_status.condition = ame$improper_fap_operation) OR (local_status.condition =
                  ame$unimplemented_request) OR (local_status.condition = ife$current_job_not_interactive)
                  THEN
              FOR i := 1 TO UPPERBOUND (call_block.fetch_terminal.terminal_attributes^) DO
                call_block.fetch_terminal.terminal_attributes^ [i].source := ifc$undefined_attribute;
              FOREND;
              IF target_file_instance^.next_target.defined THEN
                local_status.normal := TRUE;
              IFEND;
            IFEND;
            EXIT /process_target/;

          = ifc$store_terminal_req =
            target_file_instance^.fap_control_information.first_fap.access_method^
                 (target_file_identifier, call_block, 0, local_status);
            IF (NOT local_status.normal) AND ((local_status.condition = ame$improper_fap_operation) OR
                  (local_status.condition = ame$unimplemented_request) OR (local_status.condition =
                  ife$current_job_not_interactive)) THEN
              local_status.normal := TRUE;
            IFEND;
            EXIT /process_target/;

          ELSE
            amp$set_file_instance_abnormal (subject_file_identifier, ame$unimplemented_request, call_block.
                  operation, ' for connected files', local_status);
          CASEND;

{ Common processing for most requests. }

          IF local_status.normal THEN
            target_file_instance^.fap_control_information.first_fap.access_method^
              (target_file_identifier, call_block, 0, local_status);
          IFEND;
          IF NOT local_status.normal THEN
            IF status.normal THEN
              status := local_status;
            IFEND;
            local_status.normal := TRUE;
          IFEND;
        END /process_target/;

{ Advance to the next target file. }

        IF NOT target_file_instance^.next_target.defined THEN
          file_position := subject_file_instance^.global_file_information^.
                positioning_info.record_info.file_position;
          EXIT /process_targets/;
        IFEND;

        target_file_identifier := target_file_instance^.next_target.file_identifier;
      WHILEND /process_targets/;

{ Deal with requests that apply to the subject file as well as all targets. }

      CASE call_block.operation OF
      = amc$close_req =
        bap$close (subject_file_identifier, local_status);
      = amc$store_req =
        bap$store (subject_file_identifier, call_block, layer_number, local_status);
      ELSE
        ;
      CASEND;

    END /fap/;


    CASE call_block.operation OF
    = amc$close_req, amc$open_req =
      ;
    = amc$fetch_access_information_rq =
      IF (subject_file_instance^.subject <> NIL) AND (subject_file_instance^.connection_level <
            subject_file_instance^.subject^.connection_level) THEN
        bap$record_subject_file_op (subject_file_identifier, call_block.operation, file_position);
      IFEND;
    ELSE
      bap$record_subject_file_op (subject_file_identifier, call_block.operation, file_position);
    CASEND;

    IF (NOT local_status.normal) AND status.normal THEN
      status := local_status;
    IFEND;

    #keypoint (osk$exit, 0, bak$connected_file_device);

  PROCEND bap$connected_file_device;
?? TITLE := 'close_obsolete_target_files', EJECT ??

  PROCEDURE [INLINE] close_obsolete_target_files (subject_file_identifier: amt$file_identifier;
        subject_file_instance: ^bat$task_file_entry;
    VAR status: ost$status);

    VAR
      a_target_file_was_closed: boolean,
      close_status: ost$status,
      close_target: boolean,
      target_file: ^clt$connected_file_target,
      target_file_identifier: amt$file_identifier,
      target_file_instance: ^bat$task_file_entry,
      file_id_is_valid: boolean,
      next_target_defined: boolean,
      next_target_file_identifier: amt$file_identifier,
      i: clt$connected_file_target_index;

    status.normal := TRUE;
    a_target_file_was_closed := FALSE;

    IF NOT subject_file_instance^.first_target.defined THEN
      RETURN;
    IFEND;

    target_file_identifier := subject_file_instance^.first_target.file_identifier;

    WHILE TRUE DO
      bap$validate_file_identifier (target_file_identifier, target_file_instance, file_id_is_valid);
      IF NOT file_id_is_valid THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id, interface_name, status);
        RETURN;
      IFEND;

      next_target_defined := target_file_instance^.next_target.defined;
      IF next_target_defined THEN
        next_target_file_identifier := target_file_instance^.next_target.file_identifier;
      IFEND;

{  Set close_target initially TRUE because we want to close a target if it is not found in the subject's
{  target array in the connected_files table.

      close_target := TRUE;

{  Search the subject file's target array in the connected_files table for the target file.

      IF (subject_file_instance^.subject <> NIL) AND (subject_file_instance^.subject^.targets <> NIL) THEN

      /find_target_description/
        FOR i := 1 TO UPPERBOUND (subject_file_instance^.subject^.targets^) DO
          target_file := ^subject_file_instance^.subject^.targets^ [i];
          IF target_file^.path_handle_name = target_file_instance^.local_file_name THEN

{  Close the target if the connection is not active or the connections in the task_file table
{  and the connected_files table are not in sync.
{
{  Consider the following 2 forms of the latter condition:
{
{  1. target_file_instance^.target_connection_level > target_file^.connection_level
{     (task_file_table target updated AFTER connected_file table's target)
{     This could occur if a connection inherited by a pushed environment was
{     deleted (closing the file), recreated and referenced, followed by a POP.
{
{  2. target_file_instance^.target_connection_level < target_file^.connection_level
{     (task_file_table target updated BEFORE connected_file table's target)
{     Another task updated the file connection.

            close_target := (NOT target_file^.connection_active) OR
                 (target_file_instance^.target_connection_level <> target_file^.connection_level);

            EXIT /find_target_description/;
          IFEND;
        FOREND /find_target_description/;
      IFEND;

      IF close_target THEN
        bap$enable_close_of_target (subject_file_identifier, target_file_identifier);
        fsp$close_file (target_file_identifier, close_status);
        IF NOT close_status.normal THEN
          IF status.normal THEN
            status := close_status;
          IFEND;
        ELSE
          a_target_file_was_closed := TRUE;
        IFEND;
      IFEND;

      IF NOT next_target_defined THEN

{  If any targets were closed, the subject's targets should be
{  updated the next time the fap is called.

        IF a_target_file_was_closed THEN
          bap$force_update_of_targets (subject_file_identifier);
        IFEND;
        RETURN;
      IFEND;
      target_file_identifier := next_target_file_identifier;
    WHILEND;

  PROCEND close_obsolete_target_files;
?? TITLE := 'prepare_for_opening_target', EJECT ??

  PROCEDURE [INLINE] prepare_for_opening_target (subject_file_identifier: amt$file_identifier;
        subject_file_instance: ^bat$task_file_entry;
        subject_file_contents: amt$file_contents;
        subject_file_structure: amt$file_structure;
        target_file: ^clt$connected_file_target;
    VAR target_file_name: amt$local_file_name;
    VAR target_attachment_options: array [1 .. 2] OF fst$attachment_option;
    VAR target_default_attributes: array [1 .. 1] OF fst$file_cycle_attribute;
    VAR target_mandated_attributes: array [1 .. 1] OF fst$file_cycle_attribute;
    VAR status: ost$status);

    VAR
      access_modes: pft$usage_selections,
      ignore_contains_data: boolean,
      ignore_local_file: boolean,
      ignore_open_position: clt$open_position,
      file_contents_truncated: boolean,
      target_attributes: array [1 .. 5] of amt$get_item,
      target_file_exists: boolean;

    target_file_name := target_file^.path_handle_name;

    target_attributes [1].key := amc$access_mode;
    target_attributes [2].key := amc$open_position;
    target_attributes [3].key := amc$file_contents;
    target_attributes [4].key := amc$file_structure;
    target_attributes [5].key := amc$ring_attributes;
    amp$get_file_attributes (target_file_name, target_attributes, ignore_local_file, target_file_exists,
          ignore_contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    bap$verify_file_connection_attr (TRUE, subject_file_instance^.local_file_name, target_file_name,
          subject_file_contents, target_attributes [3].file_contents, subject_file_structure,
          target_attributes [4].file_structure, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    target_attachment_options [1].selector := fsc$access_and_share_modes;
    target_attachment_options [1].share_modes.selector := fsc$determine_from_access_modes;
    target_attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    IF target_attributes [1].source = amc$access_method_default THEN
      #UNCHECKED_CONVERSION (subject_file_instance^.instance_attributes.dynamic_label.access_mode,
            target_attachment_options [1].access_modes.value);
    ELSE
      access_modes := subject_file_instance^.instance_attributes.dynamic_label.access_mode *
            target_attributes [1].access_mode;
      IF access_modes = $pft$usage_selections[] THEN
        amp$set_file_instance_abnormal (subject_file_identifier, ame$incompatible_file_connect, amc$open_req,
              target_file_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'ACCESS_MODE', status);
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (access_modes, target_attachment_options [1].access_modes.value);
    IFEND;

    IF target_file^.open_position.specified THEN
      target_attachment_options [2].selector := fsc$open_position;
      target_attachment_options [2].open_position := target_file^.open_position.value;
    ELSEIF (subject_file_instance^.instance_attributes.dynamic_label.open_position_source <>
          amc$access_method_default) AND (target_attributes [2].source = amc$access_method_default) THEN
      target_attachment_options [2].selector := fsc$open_position;
      target_attachment_options [2].open_position := subject_file_instance^.instance_attributes.
            dynamic_label.open_position;
    ELSE
      target_attachment_options [2].selector := fsc$null_attachment_option;
    IFEND;

    IF target_file_exists OR (target_attributes [3].source <> amc$access_method_default) OR
          (target_attributes [4].source <> amc$access_method_default) THEN
      target_default_attributes [1].selector := fsc$null_attribute;
    ELSE
      target_default_attributes [1].selector := fsc$file_contents_and_processor;
      fsp$convert_to_new_contents (subject_file_contents, subject_file_structure,
            target_default_attributes [1].file_contents,
            file_contents_truncated);
      target_default_attributes [1].file_processor := osc$null_name;
    IFEND;

    IF target_file_exists THEN
      target_mandated_attributes [1].selector := fsc$null_attribute;
    ELSE
      target_mandated_attributes [1].selector := fsc$ring_attributes;
      IF target_attributes [5].source = amc$undefined_attribute THEN
        target_mandated_attributes [1].ring_attributes.r1 := target_file^.connection_ring;
        target_mandated_attributes [1].ring_attributes.r2 := target_file^.connection_ring;
        target_mandated_attributes [1].ring_attributes.r3 := target_file^.connection_ring;
      ELSE
        target_mandated_attributes [1].ring_attributes := target_attributes [5].ring_attributes;
        IF target_file^.connection_ring > target_attributes [5].ring_attributes.r1 THEN
          target_mandated_attributes [1].ring_attributes.r1 := target_file^.connection_ring;
        IFEND;
        IF target_file^.connection_ring > target_attributes [5].ring_attributes.r2 THEN
          target_mandated_attributes [1].ring_attributes.r2 := target_file^.connection_ring;
        IFEND;
        IF target_file^.connection_ring > target_attributes [5].ring_attributes.r3 THEN
          target_mandated_attributes [1].ring_attributes.r3 := target_file^.connection_ring;
        IFEND;
      IFEND;
    IFEND;

  PROCEND prepare_for_opening_target;
?? TITLE := 'bap$close_obsolete_target_files', EJECT ??

  PROCEDURE [XDCL] bap$close_obsolete_target_files
    (    connected_files: ^clt$connected_files);

    VAR
      subject_file_identifier: amt$file_identifier,
      subject_file_instance: ^bat$task_file_entry,
      entry_index: integer,
      ignore_status: ost$status;


    IF bav$task_file_table = NIL THEN
      RETURN;
    IFEND;

    FOR entry_index := 1 to bav$last_tft_entry DO
      IF bav$tft_entry_assignment^ (entry_index) = fmc$entry_assigned THEN
        subject_file_instance := ^bav$task_file_table^ [entry_index];

        IF (subject_file_instance^.device_class = rmc$connected_file_device) THEN

          subject_file_identifier.ordinal := entry_index;
          subject_file_identifier.sequence := subject_file_instance^.sequence_number;

          IF #offset(subject_file_instance^.connected_files) <> #offset(connected_files) THEN
            bap$update_opened_subject_file (subject_file_identifier);
          IFEND;

{  Call <close_obsolete_target_files> if the targets specified in the connected_files table
{  and the task_file_table are out of sync.  Note:  not all targets may be closed.

          IF ((subject_file_instance^.subject = NIL) OR (subject_file_instance^.connection_level <>
                subject_file_instance^.subject^.connection_level)) THEN
            close_obsolete_target_files (subject_file_identifier, subject_file_instance, ignore_status);
          IFEND;

        IFEND;
      IFEND;
    FOREND;

  PROCEND bap$close_obsolete_target_files;

MODEND bam$connected_file_device;
*DECK DECK=BAM$CONNECTED_FILE_DEV_SUPPORT EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Basic Access Method : Connected File Device Support' ??

MODULE bam$connected_file_dev_support;

{
{ PURPOSE:
{   This module contains procedures that support the file access procedure
{   (fap) for connected files (subject files).
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc cle$ecc_miscellaneous
*copyc clt$connected_file
?? POP ??
*copyc bap$validate_file_identifier
*copyc clp$find_connected_file
*copyc clp$find_connected_files
*copyc osp$set_status_abnormal
*copyc pmp$exit

?? TITLE := 'bap$enable_close_of_target', EJECT ??
*copy bah$enable_close_of_target

  PROCEDURE [XDCL, #GATE] bap$enable_close_of_target (subject_file_identifier: amt$file_identifier;
        target_file_identifier: amt$file_identifier);

    VAR
      subject_file_instance: ^bat$task_file_entry,
      file_id_is_valid: boolean,
      target_file_instance: ^bat$task_file_entry,
      next_file_instance: ^bat$task_file_entry,
      status: ost$status;

  /enable_close_of_target/
    BEGIN
      bap$validate_file_identifier (subject_file_identifier, subject_file_instance, file_id_is_valid);
      IF (NOT file_id_is_valid) OR (subject_file_instance^.device_class <> rmc$connected_file_device)
            OR (NOT subject_file_instance^.first_target.defined) THEN
        EXIT /enable_close_of_target/;
      IFEND;
      bap$validate_file_identifier (target_file_identifier, target_file_instance, file_id_is_valid);
      IF (NOT file_id_is_valid) OR (subject_file_instance = target_file_instance) THEN
        EXIT /enable_close_of_target/;
      IFEND;

      IF subject_file_instance^.first_target.file_identifier = target_file_identifier THEN
        subject_file_instance^.first_target := target_file_instance^.next_target;
      ELSE
        bap$validate_file_identifier (subject_file_instance^.first_target.file_identifier, next_file_instance,
              file_id_is_valid);
        IF NOT (file_id_is_valid AND next_file_instance^.next_target.defined) THEN
          EXIT /enable_close_of_target/;
        IFEND;
        WHILE next_file_instance^.next_target.file_identifier <> target_file_identifier DO
          bap$validate_file_identifier (next_file_instance^.next_target.file_identifier, next_file_instance,
                file_id_is_valid);
          IF NOT (file_id_is_valid AND next_file_instance^.next_target.defined) THEN
            EXIT /enable_close_of_target/;
          IFEND;
        WHILEND;
        next_file_instance^.next_target := target_file_instance^.next_target;
      IFEND;

      target_file_instance^.close_allowed := TRUE;

      RETURN;

    END /enable_close_of_target/;
    osp$set_status_abnormal (amc$access_method_id, cle$unexpected_call_to, 'bap$enable_close_of_target',
          status);
    pmp$exit (status);

  PROCEND bap$enable_close_of_target;
?? TITLE := 'bap$record_opened_file_target', EJECT ??
*copy bah$record_opened_file_target

  PROCEDURE [XDCL, #GATE] bap$record_opened_file_target (subject_file_identifier: amt$file_identifier;
        target_file_index: clt$connected_file_target_index;
        target_file_identifier: amt$file_identifier;
        connection_level: clt$file_connection_level);

    VAR
      i: clt$connected_file_target_index,
      subject_file_instance: ^bat$task_file_entry,
      file_id_is_valid: boolean,
      target_file_instance: ^bat$task_file_entry,
      next_file_instance: ^bat$task_file_entry,
      status: ost$status;

  /record_opened_file_target/
    BEGIN
      bap$validate_file_identifier (subject_file_identifier, subject_file_instance, file_id_is_valid);
      IF (NOT file_id_is_valid) OR (subject_file_instance^.device_class <> rmc$connected_file_device) THEN
        EXIT /record_opened_file_target/;
      IFEND;
      bap$validate_file_identifier (target_file_identifier, target_file_instance, file_id_is_valid);
      IF (NOT file_id_is_valid) OR (subject_file_instance = target_file_instance) OR (target_file_index < 1)
            THEN
        EXIT /record_opened_file_target/;
      IFEND;

      IF target_file_index = 1 THEN
        target_file_instance^.next_target := subject_file_instance^.first_target;
        subject_file_instance^.first_target.defined := TRUE;
        subject_file_instance^.first_target.file_identifier := target_file_identifier;
      ELSE
        bap$validate_file_identifier (subject_file_instance^.first_target.file_identifier, next_file_instance,
              file_id_is_valid);
        IF (NOT file_id_is_valid) OR (next_file_instance = target_file_instance) THEN
          EXIT /record_opened_file_target/;
        IFEND;
        FOR i := 2 TO target_file_index - 1 DO
          bap$validate_file_identifier (next_file_instance^.next_target.file_identifier, next_file_instance,
                file_id_is_valid);
          IF (NOT file_id_is_valid) OR (next_file_instance = target_file_instance) THEN
            EXIT /record_opened_file_target/;
          IFEND;
        FOREND;
        target_file_instance^.next_target := next_file_instance^.next_target;
        next_file_instance^.next_target.defined := TRUE;
        next_file_instance^.next_target.file_identifier := target_file_identifier;
      IFEND;

      target_file_instance^.close_allowed := FALSE;
      target_file_instance^.target_connection_level := connection_level;

      RETURN;

    END /record_opened_file_target/;
    osp$set_status_abnormal (amc$access_method_id, cle$unexpected_call_to, 'bap$record_opened_file_target',
          status);
    pmp$exit (status);

  PROCEND bap$record_opened_file_target;
?? TITLE := 'bap$record_opened_subject_file', EJECT ??
*copy bah$record_opened_subject_file

  PROCEDURE [XDCL, #GATE] bap$record_opened_subject_file (subject_file_identifier: amt$file_identifier);

    VAR
      subject_file_instance: ^bat$task_file_entry,
      file_id_is_valid: boolean,
      status: ost$status;

  /record_opened_subject_file/
    BEGIN
      bap$validate_file_identifier (subject_file_identifier, subject_file_instance, file_id_is_valid);
      IF (NOT file_id_is_valid) OR (subject_file_instance^.device_class <> rmc$connected_file_device) THEN
        EXIT /record_opened_subject_file/;
      IFEND;

      clp$find_connected_files (subject_file_instance^.connected_files);
      clp$find_connected_file (subject_file_instance^.local_file_name, subject_file_instance^.subject);
      IF subject_file_instance^.subject <> NIL THEN
        subject_file_instance^.connection_level := subject_file_instance^.subject^.connection_level;
      ELSE
        subject_file_instance^.connection_level := 0;
      IFEND;
      subject_file_instance^.first_target.defined := FALSE;

      RETURN;

    END /record_opened_subject_file/;
    osp$set_status_abnormal (amc$access_method_id, cle$unexpected_call_to, 'bap$record_opened_subject_file',
          status);
    pmp$exit (status);

  PROCEND bap$record_opened_subject_file;
?? TITLE := 'bap$record_subject_file_op', EJECT ??
*copy bah$record_subject_file_op

  PROCEDURE [XDCL, #GATE] bap$record_subject_file_op (subject_file_identifier: amt$file_identifier;
        operation: amt$last_operation;
        file_position: amt$file_position);

    VAR
      subject_file_instance: ^bat$task_file_entry,
      file_id_is_valid: boolean,
      status: ost$status;

  /record_subject_file_op/
    BEGIN
      bap$validate_file_identifier (subject_file_identifier, subject_file_instance, file_id_is_valid);
      IF (NOT file_id_is_valid) OR (subject_file_instance^.device_class <> rmc$connected_file_device) THEN
        EXIT /record_subject_file_op/;
      IFEND;

      IF operation <> amc$fetch_access_information_rq THEN
        subject_file_instance^.global_file_information^.last_access_operation := operation;
        subject_file_instance^.global_file_information^.positioning_info.
              record_info.file_position := file_position;
      IFEND;

      IF subject_file_instance^.subject <> NIL THEN
        subject_file_instance^.connection_level := subject_file_instance^.subject^.connection_level;
      ELSE
        subject_file_instance^.connection_level := 0;
      IFEND;

      RETURN;

    END /record_subject_file_op/;
    osp$set_status_abnormal (amc$access_method_id, cle$unexpected_call_to, 'bap$record_subject_file_op',
          status);
    pmp$exit (status);

  PROCEND bap$record_subject_file_op;
?? TITLE := 'bap$update_opened_subject_file', EJECT ??
*copy bah$update_opened_subject_file

  PROCEDURE [XDCL, #GATE] bap$update_opened_subject_file (subject_file_identifier: amt$file_identifier);

    VAR
      subject_file_instance: ^bat$task_file_entry,
      file_id_is_valid: boolean,
      status: ost$status;

  /record_opened_subject_file/
    BEGIN
      bap$validate_file_identifier (subject_file_identifier, subject_file_instance, file_id_is_valid);
      IF (NOT file_id_is_valid) OR (subject_file_instance^.device_class <> rmc$connected_file_device) THEN
        EXIT /record_opened_subject_file/;
      IFEND;

      clp$find_connected_files (subject_file_instance^.connected_files);
      clp$find_connected_file (subject_file_instance^.local_file_name, subject_file_instance^.subject);

      RETURN;

    END /record_opened_subject_file/;
    osp$set_status_abnormal (amc$access_method_id, cle$unexpected_call_to, 'bap$record_opened_subject_file',
          status);
    pmp$exit (status);

  PROCEND bap$update_opened_subject_file;

?? OLDTITLE ??
?? NEWTITLE := 'bap$force_update_of_targets', EJECT ??

{  PURPOSE
{       This module updates a subject file's TFT connection_level to its
{       largest possible value.  This will force an update of the subject's
{       targets the next time bap$connected_file_device is called.
{
{  PARAMETERS
{       SUBJECT_FILE_IDENTIFIER  -  Subject file identifier of the subject
{       of the target just closed.

  PROCEDURE [XDCL, #GATE] bap$force_update_of_targets (
        subject_file_identifier: amt$file_identifier);

    VAR
      subject_file_instance: ^bat$task_file_entry,
      file_id_is_valid: boolean,
      status: ost$status;

  /force_update_of_targets/
    BEGIN
      bap$validate_file_identifier (subject_file_identifier, subject_file_instance, file_id_is_valid);
      IF (NOT file_id_is_valid) OR (subject_file_instance^.device_class <> rmc$connected_file_device) THEN
        EXIT /force_update_of_targets/;
      IFEND;

      subject_file_instance^.connection_level := UPPERVALUE (clt$file_connection_level);

      RETURN;

    END /force_update_of_targets/;
    osp$set_status_abnormal (amc$access_method_id, cle$unexpected_call_to, 'bap$force_update_of_targets',
          status);
    pmp$exit (status);

  PROCEND bap$force_update_of_targets;

MODEND bam$connected_file_dev_support;
*DECK DECK=BAM$CONTROL EXPAND=TRUE
?? RIGHT := 80 ??
*copyc OSD$DEFAULT_PRAGMATS
MODULE bam$control;
?? TITLE := 'NOS/VE:  BASIC ACCESS METHOD, TASK SERVICES' ??
?? NEWTITLE := 'COMMON DECLARATIONS' ??
*copyc ame$conflicting_access_level
*copyc AME$DEVICE_CLASS_VALIDATION
*copyc AME$IMPROPER_FILE_ID
*copyc AME$UNIMPLEMENTED_REQUEST
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc AMT$FAP_DECLARATIONS
*copyc BAK$BAP_PROCEDURE_KEYPOINTS
*copyc BAP$CLOSE
*copyc BAP$FETCH
*copyc BAP$FETCH_ACCESS_INFORMATION
*copyc BAP$SET_SEGMENT_EOI
*copyc BAP$SET_SEGMENT_POSITION
*copyc BAP$GET_SEGMENT_POINTER
*copyc BAP$REWIND
*copyc BAP$STORE
*copyc bap$validate_file_identifier
*copyc bap$write_modified_pages
*copyc BAV$TASK_FILE_TABLE
*copyc IFE$ERROR_CODES
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$GET_JOB_MODE

?? TITLE := 'PROCEDURE [XDCL, #GATE] BAP$FAP_CONTROL', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$fap_control (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    CONST
      error_text = 'BAP$FAP_CONTROL ';

    VAR
      file_instance: ^bat$task_file_entry,
      validation_ok: boolean,
      job_mode: jmt$job_mode;

    #keypoint (osk$entry, 0, bak$control);

    bap$validate_file_identifier (file_identifier, file_instance,
          validation_ok);
    IF NOT validation_ok THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            error_text, status);
      RETURN;
    IFEND;

    /FAP_CONTROL/
    BEGIN
    CASE call_block.operation OF
    = amc$close_req =
      bap$close (file_identifier, status);
      EXIT /FAP_CONTROL/;
    = amc$fetch_access_information_rq =
      bap$fetch_access_information (file_identifier, call_block, layer_number,
            status);
      EXIT /FAP_CONTROL/;
    = amc$fetch_req =
      bap$fetch (file_identifier, call_block, layer_number, status);
      EXIT /FAP_CONTROL/;
    = amc$flush_req =
      bap$write_modified_pages (file_instance, file_identifier, status);
    = amc$get_segment_pointer_req =
      bap$get_segment_pointer (file_identifier, call_block, layer_number,
            status);
    = amc$rewind_req =
      bap$rewind (file_identifier, call_block, layer_number, status);
    = amc$set_segment_eoi_req =
      bap$set_segment_eoi (file_identifier, call_block, layer_number, status);
    = amc$set_segment_position_req =
      bap$set_segment_position (file_identifier, call_block, layer_number,
            status);
    = amc$store_req =
      bap$store (file_identifier, call_block, layer_number, status);
    = amc$open_req =
      ;
    = amc$get_next_req, amc$put_next_req, amc$get_partial_req,
      amc$put_partial_req, amc$write_end_partition_req,
      amc$skip_req, amc$write_tape_mark_req, amc$seek_direct_req,
      amc$get_direct_req, amc$put_direct_req, amc$replace_req, amc$close_volume_req =
      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
        EXIT /FAP_CONTROL/;
      IFEND;
    = ifc$fetch_terminal_req, ifc$store_terminal_req =
      pmp$get_job_mode (job_mode, status);
      IF status.normal THEN
        IF job_mode = jmc$batch THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$current_job_not_interactive, ' FETCH/STORE_TERMINAL_REQ',
                status);
        ELSE
          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_device_class, call_block.operation,
            ' NON TERMINAL ', status);
        IFEND;
      IFEND;
    ELSE
      amp$set_file_instance_abnormal (file_identifier,
            ame$unimplemented_request, call_block.operation,
            '', status);
      EXIT /FAP_CONTROL/;
    CASEND;

    IF bav$task_file_table^ [file_identifier.ordinal].private_read_information
          = NIL THEN
      bav$task_file_table^ [file_identifier.ordinal].global_file_information^.
            last_access_operation := call_block.operation;
      IF status.normal THEN
        bav$task_file_table^ [file_identifier.ordinal].global_file_information^.
              error_status := 0;
      ELSE
        bav$task_file_table^ [file_identifier.ordinal].global_file_information^.
              error_status := status.condition;
      IFEND;
    ELSE
      bav$task_file_table^ [file_identifier.ordinal].private_read_information^.
            last_access_operation := call_block.operation;
      IF status.normal THEN
        bav$task_file_table^ [file_identifier.ordinal].private_read_information^.
              error_status := 0;
      ELSE
        bav$task_file_table^ [file_identifier.ordinal].private_read_information^.
              error_status := status.condition;
      IFEND;
    IFEND;
    END /FAP_CONTROL/;
    #keypoint (osk$exit, 0, bak$control);

  PROCEND bap$fap_control;

MODEND bam$control;
*DECK DECK=BAM$CREATE_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Basic Access Methods : Create File' ??
MODULE bam$create_file;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc dmt$allocation_size
*copyc dmt$class
*copyc dmt$transfer_size
*copyc fmt$removable_media_req_info
*copyc fsc$local
*copyc fse$create_validation_errors
*copyc fst$attachment_options
*copyc fst$device_attributes
*copyc fst$file_attributes
*copyc fst$file_cycle_attributes
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc pfc$null_shared_queue
*copyc pfe$error_condition_codes
*copyc rme$request_tape
?? POP ??
*copyc bap$fetch_tape_validation
*copyc bap$process_pt_request
*copyc bap$set_evaluated_file_abnormal
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_string_to_file_ref
*copyc fmp$request_mass_storage
*copyc fmp$is_file_attached
*copyc fmv$default_file_attributes
*copyc fsp$path_element
*copyc fsp$set_evaluated_file_abnormal
*copyc fsp$validate_attributes
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$verify_system_privilege
*copyc pfi$convert_password
*copyc pfp$convert_fs_to_pft$path
*copyc pfp$convert_shared_queue_to_ord
*copyc pfp$r3_define_mass_storage
*copyc rmp$build_mass_storage_info
*copyc rmp$complete_tape_request
*copyc rmp$validate_ansi_string
*copyc rmp$validate_mass_storage_info
*copyc rmp$validate_tape_request

  CONST
    include_radix = TRUE,
    radix = 10;

  VAR
    file_attribute_names: [STATIC, READ, oss$job_paged_literal] array
          [fsc$attachment_logging .. fsc$file_password] of ost$name := [

          {fsc$attachment_logging ......... = 001} 'ATTACHMENT_LOGGING           ',
          {fsc$file_password .............. = 002} 'FILE_PASSWORD                '];

  VAR
    write_selections: [oss$job_paged_literal, READ] fst$file_access_options :=
          [fsc$shorten, fsc$append, fsc$modify];

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$create_file', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$create_file
    (    attachment_options: ^fst$attachment_options;
         cycle_attributes: ^fst$file_cycle_attributes;
         file_attributes: ^fst$file_attributes;
         device_attributes: ^fst$device_attributes;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR resolved_path: fst$path;
     VAR status: ost$status);

?? TITLE := '    STATUS_REPORTING_PROCEDURE', EJECT ??

    PROCEDURE status_reporting_procedure
      (    condition: ost$status_condition;
           text: string (*);
       VAR status: ost$status);

      fsp$set_evaluated_file_abnormal (evaluated_file_reference, condition, fsc$create_file_req,
            text, status);

    PROCEND status_reporting_procedure;

?? TITLE := 'PROCEDURE [INLINE] validate_cycle_attributes', EJECT ??

    PROCEDURE [INLINE] validate_cycle_attributes
      (    evaluated_file_reference: fst$evaluated_file_reference;
           cycle_attributes: ^fst$file_cycle_attributes;
       VAR fs_retention: fst$retention;
       VAR retrieve_option: pft$retrieve_option;
       VAR site_backup_option: pft$site_backup_option;
       VAR site_archive_option: pft$site_archive_option;
       VAR site_release_option: pft$site_release_option;
       VAR status: ost$status);

      CONST
        create_file_request = 'FSP$CREATE_FILE',
        cycle_attributes_parameter = 'FILE_CYCLE_ATTRIBUTES';

      VAR
        cycle_attribute_index: integer,
        cycle_attribute_name: ost$name;

      status.normal := TRUE;

      IF fmv$default_new_retention = NIL THEN
        fs_retention.selector := fsc$retention_day_increment;
        fs_retention.day_increment := 999;
      ELSE
        fs_retention := fmv$default_new_retention^;
      IFEND;

      retrieve_option := pfc$always_retrieve;
      site_backup_option := pfc$null_site_backup_option;
      site_archive_option := pfc$null_site_archive_option;
      site_release_option := pfc$null_site_release_option;

      IF cycle_attributes = NIL THEN
        RETURN;
      IFEND;

      FOR cycle_attribute_index := 1 TO UPPERBOUND (cycle_attributes^) DO
        CASE cycle_attributes^ [cycle_attribute_index].selector OF
        = fsc$retention =
        = fsc$retrieve_option =
        = fsc$site_backup_option =
        = fsc$site_archive_option =
        = fsc$site_release_option =
        = fsc$null_attribute =
          ;
        ELSE
          bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_file_attrib_key,
                create_file_request, cycle_attributes_parameter, status);
          osp$append_status_integer (osc$status_parameter_delimiter, cycle_attribute_index, radix,
                NOT include_radix, status);
        CASEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

      fsp$validate_attributes (cycle_attributes, 'CYCLE_ATTRIBUTES', ^status_reporting_procedure, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      FOR cycle_attribute_index := 1 TO UPPERBOUND (cycle_attributes^) DO
        CASE cycle_attributes^ [cycle_attribute_index].selector OF
        = fsc$retention =
          fs_retention := cycle_attributes^ [cycle_attribute_index].retention;
        = fsc$retrieve_option =
          retrieve_option := cycle_attributes^ [cycle_attribute_index].retrieve_option;
        = fsc$site_backup_option =
          site_backup_option := cycle_attributes^ [cycle_attribute_index].site_backup_option;
        = fsc$site_archive_option =
          site_archive_option := cycle_attributes^ [cycle_attribute_index].site_archive_option;
        = fsc$site_release_option =
          site_release_option := cycle_attributes^ [cycle_attribute_index].site_release_option;
        = fsc$null_attribute =
          ;
        CASEND;
      FOREND;

    PROCEND validate_cycle_attributes;

?? TITLE := 'PROCEDURE [INLINE] validate_device_attributes', EJECT ??

    PROCEDURE [INLINE] validate_device_attributes
      (    evaluated_file_reference: fst$evaluated_file_reference;
           device_attributes: ^fst$device_attributes;
       VAR allocation_size: rmt$allocation_size;
       VAR density: rmt$density;
       VAR device_class: fst$device_class;
       VAR estimated_file_size: amt$file_byte_address;
       VAR initial_volume: rmt$recorded_vsn;
       VAR mass_storage_class: rmt$mass_storage_class;
       VAR removable_media_group: ost$name;
       VAR shared_queue: pft$shared_queue;
       VAR transfer_size: fst$transfer_size;
       VAR volume_list: ^rmt$volume_list;
       VAR volume_overflow_allowed: boolean;
       VAR status: ost$status);

      CONST
        create_file_request = 'FSP$CREATE_FILE',
        device_attributes_parameter = 'DEVICE_ATTRIBUTES',
        request_mass_storage = 'RMP$REQUEST_MASS_STORAGE',
        request_tape = 'RMP$REQUEST_TAPE';

      VAR
        attribute_value_is_good: boolean,
        device_attribute_index: integer,
        device_attribute_name: ost$name,
        local_status: ost$status,
        valid_name: boolean,
        volume_list_index: integer;

      status.normal := TRUE;

      allocation_size := rmc$unspecified_allocation_size;
      density := rmc$6250;
      device_class := fsc$mass_storage_device;
      estimated_file_size := rmc$unspecified_file_size;
      initial_volume := rmc$unspecified_vsn;
      mass_storage_class := rmc$unspecified_file_class;
      shared_queue := pfc$null_shared_queue;
      transfer_size := rmc$unspecified_transfer_size;
      volume_list := NIL;
      volume_overflow_allowed := TRUE;

      IF device_attributes = NIL THEN
        RETURN;
      IFEND;

      FOR device_attribute_index := 1 TO UPPERBOUND (device_attributes^) DO
        device_attribute_name := osc$null_name;
        CASE device_attributes^ [device_attribute_index].selector OF
        = fsc$allocation_size =
          IF device_attributes^ [device_attribute_index].allocation_size >
                UPPERVALUE (dmt$allocation_size) THEN
            allocation_size := dmc$max_bytes_per_allocation;
          ELSEIF (device_attributes^ [device_attribute_index].allocation_size >=
                LOWERVALUE (rmt$allocation_size)) AND (device_attributes^ [device_attribute_index].
                allocation_size <= UPPERVALUE (rmt$allocation_size)) THEN
            allocation_size := device_attributes^ [device_attribute_index].allocation_size;
          ELSE
            device_attribute_name := 'ALLOCATION_SIZE';
          IFEND;
        = fsc$density =
          IF (device_attributes^ [device_attribute_index].density < LOWERVALUE (rmt$density))
                OR (device_attributes^ [device_attribute_index].density > UPPERVALUE (rmt$density)) THEN
            bap$set_evaluated_file_abnormal (evaluated_file_reference, rme$improper_density_value,
                  request_tape, '', status);
            device_attribute_name := 'DENSITY';
          ELSE
            density := device_attributes^ [device_attribute_index].density;
          IFEND;
        = fsc$device_class =
          IF (device_attributes^ [device_attribute_index].device_class < LOWERVALUE (fst$device_class)) OR
                (device_attributes^ [device_attribute_index].device_class > UPPERVALUE (fst$device_class))
                OR ((device_attributes^ [device_attribute_index].device_class <> fsc$mass_storage_device)
                AND (device_attributes^ [device_attribute_index].device_class <> fsc$magnetic_tape_device))
                THEN
            bap$set_evaluated_file_abnormal (evaluated_file_reference, fse$improper_device_class_value,
                  create_file_request, '', status);
            device_attribute_name := 'DEVICE_CLASS';
          ELSE
            device_class := device_attributes^ [device_attribute_index].device_class
          IFEND;
        = fsc$estimated_file_size =
          IF (device_attributes^ [device_attribute_index].estimated_file_size <>
                rmc$unspecified_file_size) AND status.normal THEN
            osp$set_status_abnormal (rmc$resource_management_id, rme$file_size_not_implemented,
                  request_mass_storage, status);
          IFEND;
        = fsc$initial_volume =
          initial_volume := device_attributes^ [device_attribute_index].initial_volume;
        = fsc$mass_storage_class =
          CASE device_attributes^ [device_attribute_index].mass_storage_class OF
          = 'A' .. 'Z' =
            mass_storage_class := device_attributes^ [device_attribute_index].mass_storage_class;
          = 'a' .. 'z' =
            mass_storage_class := $CHAR ($INTEGER (device_attributes^ [device_attribute_index].
                  mass_storage_class) - $INTEGER ('a') + $INTEGER ('A'));
          ELSE
            device_attribute_name := 'MASS_STORAGE_CLASS';
          CASEND;
        = fsc$null_device_attribute =
          ;
        = fsc$removable_media_group =
          IF device_attributes^ [device_attribute_index].removable_media_group = osc$null_name THEN
            removable_media_group := osc$null_name;
          ELSE
            clp$validate_name (device_attributes^ [device_attribute_index].removable_media_group,
                  removable_media_group, valid_name);
            IF NOT valid_name THEN
              device_attribute_name := 'REMOVABLE_MEDIA_GROUP';
            IFEND;
          IFEND;
        = fsc$requested_transfer_size =
          IF device_attributes^ [device_attribute_index].requested_transfer_size >
                UPPERVALUE (dmt$transfer_size) THEN
            transfer_size := dmc$max_transfer_size;
          ELSEIF (device_attributes^ [device_attribute_index].requested_transfer_size >=
                LOWERVALUE (fst$transfer_size)) AND (device_attributes^ [device_attribute_index].
                requested_transfer_size <= UPPERVALUE (fst$transfer_size)) THEN
            transfer_size := device_attributes^ [device_attribute_index].requested_transfer_size;
          ELSE
            device_attribute_name := 'REQUESTED_TRANSFER_SIZE';
          IFEND;
        = fsc$shared_queue =
          pfp$convert_shared_queue_to_ord (device_attributes^ [device_attribute_index].shared_queue,
                 shared_queue, local_status);
          IF NOT local_status.normal THEN
            device_attribute_name := 'SHARED_QUEUE';
          IFEND;
        = fsc$volume_list =
          volume_list :=
                device_attributes^ [device_attribute_index].volume_list;
          IF volume_list <> NIL THEN
          /validate_volume_list/
            BEGIN
              FOR volume_list_index := LOWERBOUND (volume_list^) TO
                    UPPERBOUND (volume_list^) DO
                IF volume_list^ [volume_list_index].recorded_vsn <> rmc$unspecified_vsn THEN
                  rmp$validate_ansi_string (volume_list^ [volume_list_index].recorded_vsn,
                        volume_list^ [volume_list_index].recorded_vsn, status);
                  IF NOT status.normal THEN
                    bap$set_evaluated_file_abnormal (evaluated_file_reference,
                          rme$improper_recorded_vsn_value, request_tape,
                          volume_list^ [volume_list_index].recorded_vsn, status);
                    device_attribute_name := 'VOLUME_LIST';
                    EXIT /validate_volume_list/;
                  IFEND;
                IFEND;
                IF volume_list^ [volume_list_index].external_vsn <> rmc$unspecified_vsn THEN
                  rmp$validate_ansi_string (volume_list^ [volume_list_index].external_vsn,
                        volume_list^ [volume_list_index].external_vsn, status);
                  IF NOT status.normal THEN
                    bap$set_evaluated_file_abnormal (evaluated_file_reference,
                          rme$improper_external_vsn_value, request_tape,
                          volume_list^ [volume_list_index].external_vsn, status);
                    device_attribute_name := 'VOLUME_LIST';
                    EXIT /validate_volume_list/;
                  IFEND;
                IFEND;
              FOREND;
            END /validate_volume_list/;
          IFEND;
        = fsc$volume_overflow_allowed =
          volume_overflow_allowed := device_attributes^ [device_attribute_index].volume_overflow_allowed;
        ELSE
          bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_file_attrib_key,
                create_file_request, device_attributes_parameter, status);
          osp$append_status_integer (osc$status_parameter_delimiter, device_attribute_index, radix,
                NOT include_radix, status);
        CASEND;
        IF status.normal AND (device_attribute_name <> osc$null_name) THEN
          bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_file_attrib_value,
                create_file_request, device_attributes_parameter, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, device_attribute_name, status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

    PROCEND validate_device_attributes;

?? TITLE := 'PROCEDURE [INLINE] validate_file_attributes', EJECT ??

    PROCEDURE [INLINE] validate_file_attributes
      (    evaluated_file_reference: fst$evaluated_file_reference;
           file_attributes: ^fst$file_attributes;
       VAR file_password: ost$name;
       VAR attachment_logging: boolean;
       VAR status: ost$status);

      CONST
        create_file_request = 'FSP$CREATE_FILE',
        file_attributes_parameter = 'FILE_ATTRIBUTES';

      VAR
        file_attribute_index: integer,
        file_attribute_name: ost$name;

      status.normal := TRUE;

      file_password := osc$null_name;
      attachment_logging := FALSE;

      IF file_attributes = NIL THEN
        RETURN;
      IFEND;

      FOR file_attribute_index := 1 TO UPPERBOUND (file_attributes^) DO
        file_attribute_name := osc$null_name;
        CASE file_attributes^ [file_attribute_index].selector OF
        = fsc$file_password =
          pfi$convert_password (file_attributes^ [file_attribute_index].file_password, file_password,
                status);
          IF NOT status.normal THEN
            file_attribute_name := file_attribute_names [fsc$file_password];
          IFEND;
        = fsc$attachment_logging =
          IF ((file_attributes^ [file_attribute_index].attachment_logging < LOWERVALUE(boolean)) OR
                (file_attributes^ [file_attribute_index].attachment_logging > UPPERVALUE(boolean))) THEN
            osp$set_status_condition (pfe$bad_log_option, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  $INTEGER (file_attributes^ [file_attribute_index].attachment_logging), radix,
                  NOT include_radix, status);
            file_attribute_name := file_attribute_names [fsc$attachment_logging];
          ELSE
            attachment_logging := file_attributes^ [file_attribute_index].attachment_logging;
          IFEND;
        = fsc$null_file_attribute =
          ;
        ELSE
          bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_file_attrib_key,
                create_file_request, file_attributes_parameter, status);
          osp$append_status_integer (osc$status_parameter_delimiter, file_attribute_index, radix,
                NOT include_radix, status);
        CASEND;
        IF status.normal AND (file_attribute_name <> osc$null_name) THEN
          bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_file_attrib_value,
                create_file_request, file_attributes_parameter, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, file_attribute_name, status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

    PROCEND validate_file_attributes;

    VAR
      allocation_size: rmt$allocation_size,
      attached: boolean,
      attachment_logging: boolean,
      attachment_options_index: integer,
      caller_id: ost$caller_identifier,
      cycle_string: ost$string,
      cycle_string_length: integer,
      density: rmt$density,
      device_class: fst$device_class,
      estimated_file_size: amt$file_byte_address,
      family_name: ost$name,
      file_password: pft$password,
      file_path: ost$string,
      file_path_length: integer,
      file_string: ost$string,
      file_string_length: integer,
      fs_retention: fst$retention,
      ignore_pt_results: bat$process_pt_results,
      ignore_path_length: fst$path_size,
      initial_volume: rmt$recorded_vsn,
      log: pft$log,
      mass_storage_class: rmt$mass_storage_class,
      mass_storage_request_info: fmt$mass_storage_request_info,
      number_of_volumes: integer,
      parsed_file_reference: fst$parsed_file_reference,
      path_length: fst$path_size,
      p_path: ^pft$path,
      p_volume_list: ^rmt$volume_list,
      path: fst$path,
      path_size: fst$path_size,
      pf_cycle: pft$cycle_selector,
      removable_media_group: ost$name,
      removable_media_req_info: fmt$removable_media_req_info,
      retrieve_option: pft$retrieve_option,
      share_selections: pft$share_selections,
      shared_queue: pft$shared_queue,
      site_archive_option: pft$site_archive_option,
      site_backup_option: pft$site_backup_option,
      site_release_option: pft$site_release_option,
      tape_validation: boolean,
      transfer_size: fst$transfer_size,
      validation_state: bat$tape_validation_state,
      volume_list: ^rmt$volume_list,
      volume_list_index: integer,
      volume_overflow_allowed: boolean,
      work_list: bat$process_pt_work_list,
      write_ring: rmt$write_ring;

    status.normal := TRUE;
    osp$verify_system_privilege;

    #CALLER_ID (caller_id);

    IF (fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local) AND
          evaluated_file_reference.path_handle_info.path_handle_present THEN
      fmp$is_file_attached (evaluated_file_reference.path_handle_info.path_handle, attached, status);
      IF NOT status.normal THEN
        RETURN;
      ELSEIF attached THEN
        evaluated_file_reference.cycle_reference.specification := fsc$next_cycle;
        evaluated_file_reference.path_handle_info.path_handle_present := FALSE;
      IFEND;
    IFEND;

    CASE evaluated_file_reference.cycle_reference.specification OF
    = fsc$low_cycle =
      pf_cycle.cycle_option := pfc$lowest_cycle;
    = fsc$cycle_omitted, fsc$next_cycle, fsc$high_cycle =
      pf_cycle.cycle_option := pfc$highest_cycle;
    = fsc$cycle_number =
      pf_cycle.cycle_option := pfc$specific_cycle;
      pf_cycle.cycle_number := evaluated_file_reference.cycle_reference.cycle_number;
    ELSE
    CASEND;

    validate_cycle_attributes (evaluated_file_reference, cycle_attributes, fs_retention, retrieve_option,
          site_backup_option, site_archive_option, site_release_option, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    validate_device_attributes (evaluated_file_reference, device_attributes, allocation_size, density,
          device_class, estimated_file_size, initial_volume, mass_storage_class, removable_media_group,
          shared_queue, transfer_size, volume_list, volume_overflow_allowed, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    validate_file_attributes (evaluated_file_reference, file_attributes, file_password, attachment_logging,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF attachment_logging THEN
      log := pfc$log;
    ELSE
      log := pfc$no_log;
    IFEND;

    IF device_class = fsc$mass_storage_device THEN
      rmp$build_mass_storage_info (allocation_size, estimated_file_size, initial_volume, mass_storage_class,
            shared_queue, transfer_size, volume_overflow_allowed, caller_id.ring,
            ^mass_storage_request_info, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local THEN
        family_name := fsp$path_element (^evaluated_file_reference, 1) ^;
        rmp$validate_mass_storage_info ({family_set_name} osc$null_name, {object_permanent} FALSE,
              pfc$file_object, ^mass_storage_request_info, status);
        IF status.normal THEN
          fmp$request_mass_storage (allocation_size, estimated_file_size, mass_storage_class,
                initial_volume, transfer_size, volume_overflow_allowed, evaluated_file_reference, status);
        IFEND;
      ELSE
        PUSH p_path: [1 .. evaluated_file_reference.number_of_path_elements];
        pfp$convert_fs_to_pft$path (evaluated_file_reference, p_path^);
        pfp$r3_define_mass_storage (p_path^, pf_cycle, file_password, caller_id.ring, fs_retention,
              log, retrieve_option, site_archive_option, site_backup_option, site_release_option,
              ^mass_storage_request_info, status);
      IFEND;

    ELSEIF device_class = fsc$magnetic_tape_device THEN

      IF volume_list <> NIL THEN
        number_of_volumes :=
              UPPERBOUND (volume_list^) - LOWERBOUND (volume_list^) + 1;
        PUSH p_volume_list: [1 .. number_of_volumes];
        FOR volume_list_index := 1 TO number_of_volumes DO
          p_volume_list^ [volume_list_index].recorded_vsn :=
                volume_list^ [volume_list_index].recorded_vsn;
          p_volume_list^ [volume_list_index].external_vsn :=
                volume_list^ [volume_list_index].external_vsn;
          IF p_volume_list^ [volume_list_index].recorded_vsn = rmc$unspecified_vsn THEN
            p_volume_list^ [volume_list_index].recorded_vsn :=
                  p_volume_list^ [volume_list_index].external_vsn;
          ELSEIF volume_list^ [volume_list_index].external_vsn = rmc$unspecified_vsn THEN
            p_volume_list^ [volume_list_index].external_vsn :=
                  p_volume_list^ [volume_list_index].recorded_vsn;
          IFEND;
        FOREND;
      ELSE
        PUSH p_volume_list: [1 .. 1];
        p_volume_list^ [1].recorded_vsn := rmc$unspecified_vsn;
        p_volume_list^ [1].external_vsn := rmc$unspecified_vsn;
      IFEND;

      write_ring := rmc$no_write_ring;
      IF attachment_options <> NIL THEN
        FOR attachment_options_index := 1 TO UPPERBOUND (attachment_options^) DO
          IF (attachment_options^ [attachment_options_index].selector = fsc$access_and_share_modes) AND
                (attachment_options^ [attachment_options_index].access_modes.selector =
                fsc$specific_access_modes) THEN
            IF (attachment_options^ [attachment_options_index].access_modes.value * write_selections) <>
                  $fst$file_access_options [] THEN
              write_ring := rmc$write_ring;
            IFEND;
          IFEND;
        FOREND;
      IFEND;

      clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} FALSE, path,
            path_size, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      bap$fetch_tape_validation (validation_state, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF validation_state <> bac$no_tape_validation THEN
        tape_validation := validation_state = bac$tape_validation_on;
        rmp$validate_tape_request (tape_validation, path (1, path_size), density, write_ring,
              p_volume_list^, removable_media_group, volume_overflow_allowed, caller_id.ring, file_password,
              attachment_logging, status);
      ELSE
        rmp$complete_tape_request (path (1, path_size), density, write_ring, p_volume_list^,
              removable_media_group, volume_overflow_allowed, caller_id.ring, file_password,
              attachment_logging, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      IF (evaluated_file_reference.cycle_reference.specification = fsc$cycle_omitted) OR
             (evaluated_file_reference.cycle_reference.specification = fsc$next_cycle) THEN
        evaluated_file_reference.cycle_reference.specification := fsc$high_cycle;
      IFEND;
      work_list := $bat$process_pt_work_list [bac$resolve_path, bac$resolve_to_catalog];
      bap$process_pt_request (work_list, osc$null_name, evaluated_file_reference, ignore_pt_results, status);
      IF status.normal THEN
        clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} TRUE, resolved_path,
              path_length, status);
        IF status.normal THEN
          clp$convert_string_to_file_ref (resolved_path (1, path_length), parsed_file_reference, status);
          IF status.normal THEN
            STRINGREP (file_string.value, file_string_length,
                  parsed_file_reference.path (1, parsed_file_reference.file_path_size));
            STRINGREP (cycle_string.value, cycle_string_length,
                  evaluated_file_reference.cycle_reference.cycle_number);
            STRINGREP (file_path.value, file_path_length, file_string.value (1, file_string_length), '.',
                  cycle_string.value (2, (cycle_string_length - 1)));
            resolved_path := (file_path.value (1, file_path_length));
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND bap$create_file;

MODEND bam$create_file;
*DECK DECK=BAM$DELETE_DATA EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Basic Access Methods : Delete Data' ??

MODULE bam$delete_data;

{  PURPOSE:
{    This module contains bap$delete_data which is called by
{    fsp$copy_file so that deletion of the output file can
{    be postponed until it is known that a copy will be performed.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$improper_file_id
*copyc amt$file_identifier
*copyc bac$minimum_open_ring
*copyc ost$status
?? POP ??
*copyc bap$validate_file_identifier
*copyc mmp$set_segment_length
*copyc osp$set_status_abnormal
?? TITLE := 'PROCEDURE bap$delete_data', EJECT ??
*copyc bah$delete_data
  PROCEDURE [XDCL, #GATE] bap$delete_data (file_identifier: amt$file_identifier;
    VAR status: ost$status);

    VAR
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry;

    status.normal := TRUE;

    bap$validate_file_identifier (file_identifier, file_instance, file_id_is_valid);
    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id, 'BAP$DELETE_DATA', status);
      RETURN;
    IFEND;

    file_instance^.global_file_information^.eoi_byte_address := 0;

    CASE file_instance^.device_class OF
    = rmc$mass_storage_device =
      mmp$set_segment_length (file_instance^.file_pva, bac$minimum_open_ring,
               0, status);
    ELSE
    CASEND

  PROCEND bap$delete_data;
?? OLDTITLE ??
MODEND bam$delete_data;
*DECK DECK=BAM$DISPLAY_TABLES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Basic Access Methods : Table Displays' ??

MODULE bam$display_tables;

{  PURPOSE:
{    This module contains procedures called by amp$display_bam_tables and
{    the amm$trace_routines.
{    These procedures display the BAM tables symbolically.
{
{  DESIGN:
{    The XDCLed procedures set up what is to be displayed and call internal
{    procedures to do the displaying.  Each internal procedure is passed
{    the record (or a pointer to it) that is to be displayed and the column
{    (indention) at which the display should start.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$improper_file_id
*copyc amt$file_reference
*copyc bat$task_file_table
*copyc bat$display_tables_indention
*copyc cyc$max_string_size
*copyc fmc$cycle_table_allocation_size
*copyc fmc$entry_assigned
*copyc fmc$number_of_init_cycle_descs
*copyc fmc$number_of_init_path_descs
*copyc fmc$path_table_allocation_size
*copyc fmc$pde_unique_identifier
*copyc fme$file_management_errors
*copyc fmt$cd_attachment_options
*copyc fmt$cycle_description
*copyc fmt$cycle_description_unit
*copyc fmt$path_description_entry
*copyc fmt$path_description_unit
*copyc fmt$path_element_type
*copyc fmt$path_handle
*copyc fmt$static_label_header
*copyc fsc$local
*copyc fsc$max_path_elements
*copyc fst$path
*copyc fst$path_handle_name
*copyc fst$path_table_expansion_limit
*copyc osd$integer_limits
*copyc osd$random_name
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc ost$status
?? POP ??
*copyc amp$put_next
*copyc bap$get_default_file_attribs
*copyc bap$validate_file_identifier
*copyc clp$construct_path_handle_name
*copyc clp$convert_integer_to_string
*copyc clp$trimmed_string_size
*copyc clp$validate_local_file_name
*copyc clp$validate_name
*copyc fmp$locate_pde_via_path_handle
*copyc fsp$expand_file_label
*copyc osp$set_status_abnormal
*copyc osp$randomize_name
*copyc pmp$convert_binary_unique_name

*copyc amv$access_level_names
*copyc amv$block_type_names
*copyc amv$device_class_names
*copyc amv$file_organization_names
*copyc amv$record_type_names
*copyc amv$usage_option_names
*copyc bav$auxilliary_request_table
*copyc bav$last_art_entry
*copyc bav$last_tft_entry
*copyc bav$task_file_table
*copyc bav$tft_entry_assignment
*copyc fmv$highest_pdu_offset
*copyc fmv$initial_cdu_pointer
*copyc fmv$initial_pdu_pointer
*copyc fmv$path_table_entry_point
*copyc fmv$path_table_statistics
*copyc fmv$pde_assignment_counter

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    title_length = 78;

  VAR
    bav$trace_file_open: [STATIC, oss$task_private] boolean := FALSE,
    bav$trace_file_id: [STATIC, oss$task_private] amt$file_identifier;

  VAR
    bav$file_positions: [XDCL, #GATE, READ, oss$job_paged_literal] array [amt$file_position] of string (3) :=
          ['BOI', 'BOP', 'MID', 'EOR', 'EOP', 'EOI', 'EOK'];

{The following two routines are used in AMM$TRACE_ROUTINES}
?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$fetch_trace_control', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$fetch_trace_control
    (VAR trace_file_open: boolean;
     VAR trace_file_id: amt$file_identifier);

    trace_file_open := bav$trace_file_open;
    trace_file_id := bav$trace_file_id;

  PROCEND bap$fetch_trace_control;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$store_trace_control', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$store_trace_control
    (    trace_file_open: boolean;
         trace_file_id: amt$file_identifier);

    bav$trace_file_open := trace_file_open;
    bav$trace_file_id := trace_file_id;

  PROCEND bap$store_trace_control;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$display_art', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$display_art
    (    output_fid: amt$file_identifier;
     VAR status: ost$status);

    VAR
      art_descriptor: bat$art_descriptor,
      ba: amt$file_byte_address,
      entry_found: boolean,
      entry_number: bat$tft_limit,
      indent: bat$display_tables_indention,
      output_length: integer,
      output_string: string (bat$display_tables_str_length);

    status.normal := TRUE;

    display_title (output_fid, 'AUXILIARY_REQUEST_TABLE', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    entry_found := FALSE;
    indent := 5;
    FOR entry_number := 1 TO bav$last_art_entry DO

      art_descriptor := bav$auxilliary_request_table^ [entry_number];
      IF art_descriptor.local_file_name <> osc$null_name THEN

        entry_found := TRUE;
        STRINGREP (output_string, output_length, '-', 'AUXILIARY_REQUEST_TABLE_ENTRY : ', entry_number);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        STRINGREP (output_string, output_length, ' ': indent, 'local_file_name : ',
              art_descriptor.local_file_name);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        STRINGREP (output_string, output_length, ' ': indent, 'file_attributes : ',
              art_descriptor.file_attributes);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      IFEND;

    FOREND;

    IF NOT entry_found THEN
      STRINGREP (output_string, output_length, ' ': indent, 'NO ENTRIES FOUND');
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND bap$display_art;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$display_files', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$display_files
    (    output_fid: amt$file_identifier;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      entry: 1 .. cyc$max_string_size,
      output_length: integer,
      output_path: string (fsc$max_path_size + 8),
      output_string: string (bat$display_tables_str_length),
      path: fst$path,
      path_handle: fmt$path_handle,
      path_handle_name: amt$local_file_name,
      path_length: fst$path_size,
      pde: ^fmt$path_description_entry,
      pdu: ^fmt$path_description_unit,
      temp_pde: ^fmt$path_description_entry;

    status.normal := TRUE;

    { get pointer first entry in the first path_description_unit }
    pdu := fmv$initial_pdu_pointer;

    display_title (output_fid, 'FILES IN PATH TABLE', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    WHILE pdu <> NIL DO

      { look at every assigned entry in a path_description_unit }
      FOR entry := 1 TO #SIZE (pdu^.entry_assignment^) DO
        IF pdu^.entry_assignment^ (entry) = fmc$entry_assigned THEN
          pde := ^pdu^.entries^ [entry];
          IF (pde^.entry_type = fmc$file_cycle_object) AND (pde^.cycle_description <> NIL) THEN
            get_path (pde, path, path_length, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            STRINGREP (output_path, output_length, ' path = ', path (1, path_length));
            amp$put_next (output_fid, ^output_path, output_length, ba, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            { create a path_handle_name for the cycle_object }
            path_handle := pde^.cycle_description^.path_handle;
            clp$construct_path_handle_name (path_handle, path_handle_name);
            STRINGREP (output_string, output_length, ' ': 5, 'attached = ',
                  pde^.cycle_description^.attached_file, '    path_handle_name = ',
                  path_handle_name (1, clp$trimmed_string_size (path_handle_name)));
            amp$put_next (output_fid, ^output_string, output_length, ba, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            temp_pde := pde^.first_cycle_alias_entry;
            WHILE temp_pde <> NIL DO
              { create a path_handle_name for the alias }
              path_handle.segment_offset := #OFFSET (temp_pde);
              path_handle.assignment_counter := temp_pde^.entry_assignment_counter;
              path_handle.open_position.specified := FALSE;
              clp$construct_path_handle_name (path_handle, path_handle_name);
              STRINGREP (output_string, output_length, ' ': 9, 'alias = ', temp_pde^.path_node_name.value,
                    ' phn = ', path_handle_name (1, clp$trimmed_string_size (path_handle_name)));
              amp$put_next (output_fid, ^output_string, output_length, ba, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              temp_pde := temp_pde^.next_cycle_alias_entry;
            WHILEND;
          IFEND;
        IFEND;
      FOREND;

      { move on to next unit if pointer is not NIL}
      pdu := pdu^.next_path_description_unit;
    WHILEND;

  PROCEND bap$display_files;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$display_path_table', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$display_path_table
    (    output_fid: amt$file_identifier;
         expansion_limit: fst$path_table_expansion_limit;
     VAR status: ost$status);

    CONST
      entry_assignment_display_size = 50;

    VAR
      ba: amt$file_byte_address,
      i: integer,
      indent: bat$display_tables_indention,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      pde: ^fmt$path_description_entry,
      pdu: ^fmt$path_description_unit,
      unit: integer;

    status.normal := TRUE;

    display_title (output_fid, 'PATH TABLE', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    indent := 5;
    unit := 1;
    pdu := fmv$initial_pdu_pointer;

    REPEAT
      IF unit = 1 THEN
        STRINGREP (output_string, output_length, ' ', 'PATH_DESCRIPTION_UNIT : ', pdu, '   UNIT # : ',
              unit: 4);
      ELSE
        STRINGREP (output_string, output_length, '1', 'PATH_DESCRIPTION_UNIT : ', pdu, '   UNIT # : ',
              unit: 4);
      IFEND;
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'next_path_description_unit : ',
            pdu^.next_path_description_unit);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'total_count : ', pdu^.total_count);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'current_count : ', pdu^.current_count);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, '                   ',
            '         11111111112222222222333333333344444444445');
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, '                   ',
            '12345678901234567890123456789012345678901234567890');
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      i := 0;
      WHILE i < ((#SIZE (pdu^.entry_assignment^) - 1) DIV entry_assignment_display_size) DO
        i := i + 1;
        STRINGREP (output_string, output_length, ' ': indent, 'entry_assignment : ', pdu^.
              entry_assignment^ (((i - 1) * entry_assignment_display_size + 1),
              entry_assignment_display_size));
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      WHILEND;

      STRINGREP (output_string, output_length, ' ': indent, 'entry_assignment : ', pdu^.
            entry_assignment^ ((i * entry_assignment_display_size + 1), * ));
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      FOR i := 1 TO #SIZE (pdu^.entry_assignment^) DO
        IF pdu^.entry_assignment^ (i) = fmc$entry_assigned THEN
          pde := ^pdu^.entries^ [i];
          STRINGREP (output_string, output_length, '-', ' ': indent - 1, 'PATH_DESCRIPTION_ENTRY : ', pde,
                '   ENTRY # : ', i, '   UNIT # : ', unit: 4);
          amp$put_next (output_fid, ^output_string, output_length, ba, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          display_pde (output_fid, pde, expansion_limit, indent + 4, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND
      FOREND;
      unit := unit + 1;
      pdu := pdu^.next_path_description_unit;
    UNTIL pdu = NIL;

  PROCEND bap$display_path_table;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$display_pde_via_ph', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$display_pde_via_ph
    (    output_fid: amt$file_identifier;
         path_handle: fmt$path_handle;
         expansion_limit: fst$path_table_expansion_limit;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      indent: bat$display_tables_indention,
      original_pde: ^fmt$path_description_entry,
      output_length: integer,
      output_path: string (fsc$max_path_size + 8),
      output_string: string (bat$display_tables_str_length),
      path: fst$path,
      path_length: fst$path_size,
      pde: ^fmt$path_description_entry;

    status.normal := TRUE;

    display_title (output_fid, 'PATH DESCRIPTION ENTRY', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fmp$locate_pde_via_path_handle (path_handle, pde, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    original_pde := pde;

    get_path (pde, path, path_length, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_path, output_length, ' path = ', path (1, path_length));
    amp$put_next (output_fid, ^output_path, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    indent := 5;
    STRINGREP (output_string, output_length, '-', 'PATH_DESCRIPTION_ENTRY : ', pde);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display_pde (output_fid, pde, expansion_limit, indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { display back up full path }
    WHILE pde^.parental_path_entry <> NIL DO
      pde := pde^.parental_path_entry;
      STRINGREP (output_string, output_length, '-', 'PARENT PATH_DESCRIPTION_ENTRY : ', pde);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      display_pde (output_fid, pde, expansion_limit, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    WHILEND;

    IF (original_pde^.entry_type = fmc$file_cycle_object) AND
          (original_pde^.first_cycle_alias_entry <> NIL) THEN

      pde := original_pde^.first_cycle_alias_entry;
      WHILE pde <> NIL DO
        STRINGREP (output_string, output_length, '-', 'ALIAS PATH_DESCRIPTION_ENTRY : ', pde);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        display_pde (output_fid, pde, expansion_limit, indent, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        pde := pde^.next_cycle_alias_entry;
      WHILEND;
    IFEND; {cycle_object}

  PROCEND bap$display_pde_via_ph;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$display_pt_stats', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$display_pt_stats
    (    output_fid: amt$file_identifier;
     VAR status: ost$status);

    CONST
      number_of_empty_node_statistics = 7;

    VAR
      ba: amt$file_byte_address,
      empty_node_depths: integer,
      first_x_empty_node_depths: array [1 .. number_of_empty_node_statistics] of integer,
      indent: bat$display_tables_indention,
      number_of_empty_nodes: integer,
      number_of_tree_nodes: integer,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      previous_randomized_name: ost$randomized_name,
      tree_depth: integer,
      tree_node_depths: integer,
      unused_externalized_entry_count: integer,
      unused_externalized_path_count: integer,
      unused_not_externalized_count: integer;

    PROCEDURE count_unused_paths
      (VAR unused_path_count: integer;
       VAR unused_externalized_entry_count: integer;
       VAR unused_externalized_path_count: integer;
       VAR unused_not_externalized_count: integer;
       VAR status: ost$status);

      VAR
        entry: 1 .. cyc$max_string_size,
        output_path: string (fsc$max_path_size + 8),
        path: fst$path,
        path_externalized: boolean,
        path_length: fst$path_size,
        pde: ^fmt$path_description_entry,
        pdu: ^fmt$path_description_unit;

      status.normal := TRUE;
      unused_path_count := 0;
      unused_externalized_entry_count := 0;
      unused_externalized_path_count := 0;
      unused_not_externalized_count := 0;

      pdu := fmv$initial_pdu_pointer;
      WHILE pdu <> NIL DO

        { look at every assigned entry in a path_description_unit }
        FOR entry := 1 TO #SIZE (pdu^.entry_assignment^) DO
          IF pdu^.entry_assignment^ (entry) = fmc$entry_assigned THEN
            pde := ^pdu^.entries^ [entry];
            IF ((pde^.entry_type = fmc$file_cycle_object) AND (pde^.cycle_description = NIL)) OR
                  ((pde^.entry_type = fmc$named_object) AND (pde^.active_path_participation_count = 0) AND
                  (pde^.highest_cycle = NIL)) THEN
              unused_path_count := unused_path_count + 1;
              IF pde^.path_handle_name_externalized THEN
                path_externalized := TRUE;
                unused_externalized_entry_count := unused_externalized_entry_count + 1;
              ELSE
                path_externalized := FALSE;
                unused_not_externalized_count := unused_not_externalized_count + 1;
              IFEND;
              pde := pde^.parental_path_entry;
              WHILE pde <> NIL DO
                IF pde^.active_path_participation_count = 1 THEN
                  IF pde^.path_handle_name_externalized THEN
                    unused_externalized_entry_count := unused_externalized_entry_count + 1;
                  ELSEIF path_externalized THEN
                    unused_externalized_path_count := unused_externalized_path_count + 1;
                  ELSE
                    unused_not_externalized_count := unused_not_externalized_count + 1;
                  IFEND;
                IFEND;
                pde := pde^.parental_path_entry;
              WHILEND;
            IFEND; {end of a path}
          IFEND; {assigned}
        FOREND;

        { move on to next unit if pointer is not NIL}
        pdu := pdu^.next_path_description_unit;
      WHILEND;
    PROCEND count_unused_paths;

    PROCEDURE find_file_entry
      (    parent_pde: ^fmt$path_description_entry;
       VAR file_entry_found: boolean;
       VAR path_externalized: boolean;
       VAR status: ost$status);

      PROCEDURE find_cycle_description
        (    pde: ^fmt$path_description_entry;
         VAR cycle_description_found: boolean;
         VAR path_externalized: {i/o} boolean;
         VAR status: ost$status);

        VAR
          cycle_pde: ^fmt$path_description_entry;

        status.normal := TRUE;

        cycle_description_found := FALSE;
        cycle_pde := pde^.highest_cycle;

        WHILE cycle_pde <> NIL DO
          IF (cycle_pde^.entry_assignment^ = fmc$entry_assigned) AND
                (cycle_pde^.entry_type = fmc$file_cycle_object) THEN
            IF (cycle_pde^.cycle_description <> NIL) THEN
              cycle_description_found := TRUE;
            ELSE
              IF cycle_pde^.path_handle_name_externalized THEN
                path_externalized := TRUE;
                unused_externalized_entry_count := unused_externalized_entry_count + 1;
              ELSE
                unused_not_externalized_count := unused_not_externalized_count + 1;
              IFEND;
            IFEND;
            cycle_pde := cycle_pde^.next_lower_cycle;
          ELSE
            STRINGREP (output_string, output_length, ' ': indent,
                  'PATH_DESCRIPTION_ENTRY is not an ASSIGNED - FILE_CYCLE_OBJECT : ', cycle_pde);
            amp$put_next (output_fid, ^output_string, output_length, ba, status);
            cycle_pde := NIL;
          IFEND;
        WHILEND;

      PROCEND find_cycle_description;

      VAR
        child_node_count: integer,
        cycle_description_found: boolean,
        cycle_pde: ^fmt$path_description_entry,
        entry: 1 .. cyc$max_string_size,
        local_file_entry_found: boolean,
        local_path_externalized: boolean,
        number_of_cycle_objects: integer,
        pde: ^fmt$path_description_entry,
        pdu: ^fmt$path_description_unit;

      status.normal := TRUE;

      file_entry_found := FALSE;
      path_externalized := FALSE;
      child_node_count := 0;
      pdu := fmv$initial_pdu_pointer;

      WHILE pdu <> NIL DO
        FOR entry := 1 TO #SIZE (pdu^.entry_assignment^) DO
          IF pdu^.entry_assignment^ (entry) = fmc$entry_assigned THEN
            pde := ^pdu^.entries^ [entry];
            IF (pde^.entry_type = fmc$named_object) AND (pde^.parental_path_entry = parent_pde) THEN
              child_node_count := child_node_count + 1;
              local_file_entry_found := FALSE;
              local_path_externalized := FALSE;
              IF pde^.active_path_participation_count > 0 THEN
{
{ The following code checks for a named object hung off the current object as well as a cycle object.
{ This is due to the fact that a permanent file catalog could have a cycle object hung off of it
{ because of the fact that paths are recorded before they are verified.
{
                number_of_cycle_objects := 0;
                cycle_pde := pde^.highest_cycle;
                WHILE cycle_pde <> NIL DO
                  number_of_cycle_objects := number_of_cycle_objects + 1;
                  cycle_pde := cycle_pde^.next_lower_cycle;
                WHILEND;
                IF pde^.active_path_participation_count > number_of_cycle_objects THEN
                  find_file_entry (pde, local_file_entry_found, local_path_externalized, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;
                IFEND;
                find_cycle_description (pde, cycle_description_found, local_path_externalized, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                local_file_entry_found := local_file_entry_found OR cycle_description_found;
              ELSEIF pde^.highest_cycle <> NIL THEN {ALIAS
                local_file_entry_found := TRUE;
              IFEND;
              IF NOT local_file_entry_found THEN
                IF pde^.path_handle_name_externalized THEN
                  unused_externalized_entry_count := unused_externalized_entry_count + 1;
                ELSEIF local_path_externalized THEN
                  unused_externalized_path_count := unused_externalized_path_count + 1;
                ELSE
                  unused_not_externalized_count := unused_not_externalized_count + 1;
                IFEND;
              IFEND;
              path_externalized := path_externalized OR local_path_externalized OR
                    pde^.path_handle_name_externalized;
              file_entry_found := file_entry_found OR local_file_entry_found;
              IF (parent_pde <> NIL) AND (child_node_count = parent_pde^.active_path_participation_count) THEN
                RETURN;
              IFEND;
            IFEND; {parental_path_entry = parent_pde.
          IFEND;
        FOREND;
        pdu := pdu^.next_path_description_unit;
      WHILEND;

    PROCEND find_file_entry;

    PROCEDURE traverse_path_table
      (    pde: ^fmt$path_description_entry;
           depth: integer;
       VAR status: ost$status);

      VAR
        i: integer,
        insert_index: integer;

      status.normal := TRUE;

      IF (pde <> NIL) THEN
        number_of_tree_nodes := number_of_tree_nodes + 1;
        tree_node_depths := tree_node_depths + depth;
        IF depth > tree_depth THEN
          tree_depth := depth;
        IFEND;
        IF pde^.entry_assignment^ = fmc$entry_assigned THEN
          IF pde^.entry_type = fmc$named_object THEN
            traverse_path_table (pde^.left_subtree, depth + 1, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF pde^.randomized_node_name < previous_randomized_name THEN
              STRINGREP (output_string, output_length, ' ': indent,
                    'PATH_DESCRIPTION_ENTRY in tree is out of order : ', pde);
              amp$put_next (output_fid, ^output_string, output_length, ba, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
            previous_randomized_name := pde^.randomized_node_name;
            traverse_path_table (pde^.right_subtree, depth + 1, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSE
            STRINGREP (output_string, output_length, ' ': indent,
                  'PATH_DESCRIPTION_ENTRY in tree is NOT a NAMED object : ', pde);
            amp$put_next (output_fid, ^output_string, output_length, ba, status);
          IFEND;
        ELSE
          STRINGREP (output_string, output_length, ' ': indent,
                'PATH_DESCRIPTION_ENTRY in tree is not active : ', pde);
          amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IFEND;
      ELSE {pde = NIL
        number_of_empty_nodes := number_of_empty_nodes + 1;
        empty_node_depths := empty_node_depths + depth;
        IF (depth < first_x_empty_node_depths [number_of_empty_node_statistics]) THEN
          insert_index := 1;
          WHILE depth >= first_x_empty_node_depths [insert_index] DO
            insert_index := insert_index + 1;
          WHILEND;
          FOR i := number_of_empty_node_statistics DOWNTO insert_index + 1  DO
            first_x_empty_node_depths [i] := first_x_empty_node_depths [i-1];
          FOREND;
          first_x_empty_node_depths [insert_index] := depth;
        IFEND;
      IFEND;

    PROCEND traverse_path_table;

    VAR
      cdu: ^fmt$cycle_description_unit,
      cdu_number: integer,
      current_count: integer,
      depth: 1 .. fsc$max_path_elements,
      file_entry_found: boolean,
      complete_tree_depth: integer,
      i: integer,
      number_of_named_objects: integer,
      number_of_nodes_in_full_tree: integer,
      path_externalized: boolean,
      pdu: ^fmt$path_description_unit,
      pdu_number: integer,
      unused_path_count: integer;

    status.normal := TRUE;

    display_title (output_fid, 'PATH TABLE STATISTICS', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    indent := 3;

    STRINGREP (output_string, output_length, '  General Statistics:');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_count := 0;
    FOR i := 1 to bav$last_art_entry DO
      IF bav$auxilliary_request_table^ [i].local_file_name <> osc$null_name THEN
        current_count := current_count + 1;
      IFEND;
    FOREND;

    IF bav$auxilliary_request_table = NIL THEN
      STRINGREP (output_string, output_length, ' ': indent,
            'Auxiliary Request Table (in use/bav$last_art_entry/size): NOT ALLOCATED');
    ELSE
      STRINGREP (output_string, output_length, ' ': indent,
            'Auxiliary Request Table (in use/bav$last_art_entry/size): ', current_count, '/',
            bav$last_art_entry, '/', UPPERBOUND(bav$auxilliary_request_table^));
    IFEND;
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_count := 0;
    FOR i := 1 to bav$last_tft_entry DO
      IF bav$tft_entry_assignment^ (i) = fmc$entry_assigned THEN
        current_count := current_count + 1;
      IFEND;
    FOREND;
    STRINGREP (output_string, output_length, ' ': indent,
          'Task File Table (in use/bav$last_tft_entry/size): ', current_count, '/',
          bav$last_tft_entry, '/', UPPERBOUND(bav$task_file_table^));
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    STRINGREP (output_string, output_length, '0 Path Table Object Statistics:');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'path table objects (current/maximum): ',
          (fmv$named_objects_created - fmv$named_objects_deleted + fmv$cycle_objects_created -
          fmv$cycle_objects_deleted), '/', fmv$max_active_objects);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent+2,
          'named objects (current/created/deleted): ',
          (fmv$named_objects_created - fmv$named_objects_deleted), '/', fmv$named_objects_created, '/',
          fmv$named_objects_deleted);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent+2,
          'cycle objects (current/created/deleted): ',
          (fmv$cycle_objects_created - fmv$cycle_objects_deleted), '/', fmv$cycle_objects_created, '/',
          fmv$cycle_objects_deleted);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    count_unused_paths (unused_path_count, unused_externalized_entry_count, unused_externalized_path_count,
          unused_not_externalized_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ This following method is more accurate but also much more time consuming if the # of entries exceeds 5000.

    IF (fmv$named_objects_created - fmv$named_objects_deleted + fmv$cycle_objects_created -
          fmv$cycle_objects_deleted) <= 5000 THEN
      unused_externalized_entry_count := 0;
      unused_externalized_path_count := 0;
      unused_not_externalized_count := 0;
      find_file_entry (NIL, file_entry_found, path_externalized, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'unused entries (total/externalized/in ext path/not ext): ',
          (unused_externalized_entry_count + unused_externalized_path_count + unused_not_externalized_count),
          '/', unused_externalized_entry_count, '/', unused_externalized_path_count, '/',
          unused_not_externalized_count);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'unused paths: ', unused_path_count);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    STRINGREP (output_string, output_length, '0 Tree Structure Statistics:');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    previous_randomized_name := 0;
    number_of_empty_nodes := 0;
    number_of_tree_nodes := 0;
    tree_depth := 0;
    empty_node_depths := 0;
    tree_node_depths := 0;
    FOR i := 1 to number_of_empty_node_statistics DO
      first_x_empty_node_depths [i] := osc$max_integer;
    FOREND;
    traverse_path_table (fmv$path_table_entry_point, 1 {depth} , status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'tree nodes: ', number_of_tree_nodes);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    number_of_nodes_in_full_tree := 1;
    i := 1;
    WHILE (i <= tree_depth) AND (i <= 62) DO
      number_of_nodes_in_full_tree := number_of_nodes_in_full_tree * 2;
      IF number_of_tree_nodes > (number_of_nodes_in_full_tree - 1) THEN
        complete_tree_depth := i + 1;
      IFEND;
      i := i + 1;
    WHILEND;
    number_of_nodes_in_full_tree := number_of_nodes_in_full_tree - 1;
    STRINGREP (output_string, output_length, ' ': indent,
          'depth (tree/complete tree/average empty node/average node): ', tree_depth, '/',
          complete_tree_depth, '/', (empty_node_depths DIV number_of_empty_nodes), '/',
          (tree_node_depths DIV number_of_tree_nodes));
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF tree_depth <= 62 THEN
      STRINGREP (output_string, output_length, ' ': indent, 'percentage of full tree of depth', tree_depth,
            ': ', ($REAL (number_of_tree_nodes * 100) / $REAL (number_of_nodes_in_full_tree)): 7: 3, '%');
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'first', number_of_empty_node_statistics,
          ' empty node depths: ');
    FOR i := 1 to number_of_empty_node_statistics DO
      STRINGREP (output_string, output_length, output_string (1, output_length),
            first_x_empty_node_depths [i], ', ');
    FOREND;
    output_length := output_length - 2; {remove last comma & space.
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    STRINGREP (output_string, output_length, '0 Path Depth Statistics:');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    depth := 1;
    current_count := 0;
    WHILE ((depth <= fmv$max_path_depth) AND (depth <= fmc$statistics_max_path_depth)) DO
      current_count := current_count + fmv$path_depth_entries [depth];
      depth := depth + 1;
    WHILEND;
    STRINGREP (output_string, output_length, ' ': indent, 'path references: ',
          current_count);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'maximum depth referenced: ', fmv$max_path_depth);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'path depth frequencies:');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    depth := 1;
    STRINGREP (output_string, output_length, ' ': indent);
    WHILE ((depth < fmv$max_path_depth) AND (depth < fmc$statistics_max_path_depth)) DO
      STRINGREP (output_string, output_length, output_string (1, output_length), '   ', depth: 2, ':',
            fmv$path_depth_entries [depth]: 10);
      IF (depth MOD 4) = 0 THEN
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        STRINGREP (output_string, output_length, ' ': indent);
      IFEND;
      depth := depth + 1;
    WHILEND;
    IF depth = fmv$max_path_depth THEN
      STRINGREP (output_string, output_length, output_string (1, output_length), '   ', depth: 2, ':',
            fmv$path_depth_entries [depth]: 10);
    ELSE
      STRINGREP (output_string, output_length, output_string (1, output_length), '  ', depth: 2, '+:',
            fmv$path_depth_entries [depth]: 10);
    IFEND;
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    STRINGREP (output_string, output_length, '0 CDU Statistics:');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'cycle table size (initial/allocated): ',
          fmc$number_of_init_cycle_descs, '/', fmc$cycle_table_allocation_size);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cdu := fmv$initial_cdu_pointer;
    cdu_number := 1;
    WHILE cdu <> NIL DO
      current_count := 0;
      FOR i := 1 TO #SIZE (cdu^.entry_assignment^) DO
        IF cdu^.entry_assignment^ (i) = fmc$entry_assigned THEN
          current_count := current_count + 1;
        IFEND;
      FOREND;
      STRINGREP (output_string, output_length, ' ': indent, 'entries in cdu', cdu_number,
            ' (current/created/deleted): ', current_count, '/', cdu^.total_count, '/',
            (cdu^.total_count - current_count));
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      cdu := cdu^.next_cycle_description_unit;
      cdu_number := cdu_number + 1;
    WHILEND;


    STRINGREP (output_string, output_length, '0 PDU Statistics:');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'fmv$pde_assignment_counter/fmv$highest_pdu_offset: ',
          fmv$pde_assignment_counter: #(16), '(16)/', fmv$highest_pdu_offset: #(16), '(16)');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'path table size (initial/allocated): ',
          fmc$number_of_init_path_descs, '/', fmc$path_table_allocation_size);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pdu := fmv$initial_pdu_pointer;
    pdu_number := 1;
    WHILE pdu <> NIL DO
      STRINGREP (output_string, output_length, ' ': indent, 'entries in pdu', pdu_number,
            ' (current/created/deleted): ', pdu^.current_count, '/', pdu^.total_count, '/',
            (pdu^.total_count - pdu^.current_count));
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      pdu := pdu^.next_path_description_unit;
      pdu_number := pdu_number + 1;
    WHILEND;

  PROCEND bap$display_pt_stats;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$display_task_file_table', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$display_task_file_table
    (    output_fid: amt$file_identifier;
         expand_task_file_table_entry: boolean;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      entry_number: bat$tft_limit,
      name_is_path_handle: boolean,
      name_is_valid: boolean,
      output_length: integer,
      output_path: string (fsc$max_path_size + 8),
      output_string: string (bat$display_tables_str_length),
      path: fst$path,
      path_handle: fmt$path_handle,
      path_handle_name: amt$local_file_name,
      path_length: fst$path_size,
      pde: ^fmt$path_description_entry;

    status.normal := TRUE;

    display_title (output_fid, 'TASK_FILE_TABLE', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR entry_number := 1 TO bav$last_tft_entry DO

      IF bav$tft_entry_assignment^ (entry_number) = fmc$entry_assigned THEN

        STRINGREP (output_string, output_length, '-', 'TASK_FILE_TABLE_ENTRY : ', entry_number);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$validate_local_file_name (bav$task_file_table^ [entry_number].local_file_name, path_handle_name,
              path_handle, name_is_path_handle, name_is_valid);
        IF NOT name_is_path_handle THEN
          STRINGREP (output_string, output_length, ' ', path_handle_name,
                ' is not a valid PATH_HANDLE_NAME.');
          amp$put_next (output_fid, ^output_string, output_length, ba, status);
          RETURN;
        IFEND;

        fmp$locate_pde_via_path_handle (path_handle, pde, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        get_path (pde, path, path_length, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        STRINGREP (output_path, output_length, ' path = ', path (1, path_length));
        amp$put_next (output_fid, ^output_path, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        display_tft_entry (output_fid, ^bav$task_file_table^ [entry_number], expand_task_file_table_entry, 5,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      IFEND;

    FOREND;

  PROCEND bap$display_task_file_table;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$display_tft_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$display_tft_entry
    (    output_fid: amt$file_identifier;
         file_identifier: amt$file_identifier;
     VAR status: ost$status);

    CONST
      indent = 6;

    VAR
      ba: amt$file_byte_address,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      tft_entry: ^bat$task_file_entry,
      valid_file_id: boolean;

    bap$validate_file_identifier (file_identifier, tft_entry, valid_file_id);
    IF NOT valid_file_id THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id, 'BAP$DISPLAY_TFT_ENTRY', status);
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'Task file table entry');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_tft_entry (output_fid, tft_entry, TRUE {expand_task_file_table_entry} , indent + 2, status);

  PROCEND bap$display_tft_entry;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$display_tfte_via_ph', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$display_tfte_via_ph
    (    output_fid: amt$file_identifier;
         path_handle: fmt$path_handle;
         expand_task_file_table_entry: boolean;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      entry_number: bat$tft_limit,
      found_entry: boolean,
      name_is_path_handle: boolean,
      name_is_valid: boolean,
      output_length: integer,
      output_path: string (fsc$max_path_size + 8),
      output_string: string (bat$display_tables_str_length),
      path: fst$path,
      path_handle_name: fst$path_handle_name,
      path_length: fst$path_size,
      pde: ^fmt$path_description_entry,
      valid_name: amt$local_file_name;

    status.normal := TRUE;
    found_entry := FALSE;

    display_title (output_fid, 'TASK FILE TABLE ENTRIES', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fmp$locate_pde_via_path_handle (path_handle, pde, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_path (pde, path, path_length, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_path, output_length, ' path = ', path (1, path_length));
    amp$put_next (output_fid, ^output_path, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$construct_path_handle_name (path_handle, path_handle_name);

    FOR entry_number := 1 TO bav$last_tft_entry DO

      IF (bav$tft_entry_assignment^ (entry_number) = fmc$entry_assigned) AND
            (bav$task_file_table^ [entry_number].local_file_name = path_handle_name) THEN

        STRINGREP (output_string, output_length, '-', 'TASK_FILE_TABLE_ENTRY : ', entry_number);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        display_tft_entry (output_fid, ^bav$task_file_table^ [entry_number], expand_task_file_table_entry, 5,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        found_entry := TRUE;
      IFEND;

    FOREND;

    IF NOT found_entry THEN
      STRINGREP (output_string, output_length, ' ', 'NO TASK_FILE_TABLE_ENTRY FOUND FOR PATH_HANDLE_NAME "',
            path_handle_name);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND bap$display_tfte_via_ph;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$display_unused_paths', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$display_unused_paths
    (    output_fid: amt$file_identifier;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      entry: 1 .. cyc$max_string_size,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      output_path: string (fsc$max_path_size + 8),
      path: fst$path,
      path_handle: fmt$path_handle,
      path_handle_name: amt$local_file_name,
      path_length: fst$path_size,
      pde: ^fmt$path_description_entry,
      pdu: ^fmt$path_description_unit;

    status.normal := TRUE;

    { get pointer first entry in the first path_description_unit }
    pdu := fmv$initial_pdu_pointer;

    display_title (output_fid, 'PATH TABLE UNUSED PATHS', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    WHILE pdu <> NIL DO

      { look at every assigned entry in a path_description_unit }
      FOR entry := 1 TO #SIZE (pdu^.entry_assignment^) DO
        IF pdu^.entry_assignment^ (entry) = fmc$entry_assigned THEN
          pde := ^pdu^.entries^ [entry];
          IF ((pde^.entry_type = fmc$file_cycle_object) AND (pde^.cycle_description = NIL)) OR
                ((pde^.entry_type = fmc$named_object) AND (pde^.active_path_participation_count = 0) AND
                (pde^.highest_cycle = NIL)) THEN
            get_path (pde, path, path_length, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            STRINGREP (output_path, output_length, ' path = ', path (1, path_length));
            amp$put_next (output_fid, ^output_path, output_length, ba, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            path_handle.segment_offset := #OFFSET (pde);
            path_handle.assignment_counter := pde^.entry_assignment_counter;
            path_handle.open_position.specified := FALSE;
            clp$construct_path_handle_name (path_handle, path_handle_name);
            STRINGREP (output_string, output_length, ' ': 5, 'externalized = ',
                  pde^.path_handle_name_externalized, '    path_handle_name = ',
                  path_handle_name (1, clp$trimmed_string_size (path_handle_name)));
            amp$put_next (output_fid, ^output_string, output_length, ba, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

          IFEND; {end of a path}
        IFEND; {assigned}
      FOREND;

      { move on to next unit if pointer is not NIL}
      pdu := pdu^.next_path_description_unit;
    WHILEND;

  PROCEND bap$display_unused_paths;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$validate_path_table_objects', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$validate_path_table_objects
    (    output_fid: amt$file_identifier;
     VAR status: ost$status);

    CONST
      indent = 5;

    VAR
      ba: amt$file_byte_address,
      i: integer,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      error_found: boolean,
      found: boolean,
      number_of_cycle_objects: integer,
      number_of_named_objects: integer,
      pde: ^fmt$path_description_entry,
      pdu: ^fmt$path_description_unit,
      temp_pde: ^fmt$path_description_entry;

    PROCEDURE display_tree_error
      (    error_text: string ( * );
           pde1_description: string ( * );
           pde1: ^fmt$path_description_entry;
           pde2_description: string ( * );
           pde2: ^fmt$path_description_entry;
       VAR status: ost$status);

      status.normal := TRUE;
      error_found := TRUE;

      STRINGREP (output_string, output_length, '-', error_text);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF STRLENGTH (pde1_description) > 0 THEN
        STRINGREP (output_string, output_length, ' ': indent, pde1_description, ' : ', pde1);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF pde1 <> NIL THEN
        display_pde (output_fid, pde1, fsc$disbt_pde, indent + 4, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF STRLENGTH (pde2_description) > 0 THEN
        STRINGREP (output_string, output_length, ' ': indent, pde2_description, ' : ', pde2);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF pde2 <> NIL THEN
        display_pde (output_fid, pde2, fsc$disbt_pde, indent + 4, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    PROCEND display_tree_error;

    PROCEDURE [INLINE] validate_active_path_part
      (    pde: ^fmt$path_description_entry;
       VAR status: ost$status);

      VAR
        error: string (80),
        error_length: integer,
        i: integer,
        participation_count: integer,
        pdu: ^fmt$path_description_unit;

      pdu := fmv$initial_pdu_pointer;
      participation_count := 0;

      REPEAT
        FOR i := 1 TO #SIZE (pdu^.entry_assignment^) DO
          IF pdu^.entry_assignment^ (i) = fmc$entry_assigned THEN
            IF pdu^.entries^ [i].parental_path_entry = pde THEN
              participation_count := participation_count + 1;
            IFEND;
          IFEND;
        FOREND;
        pdu := pdu^.next_path_description_unit;
      UNTIL pdu = NIL;

      IF participation_count <> pde^.active_path_participation_count THEN
        STRINGREP (error, error_length, 'Active_path_participation_count', ' should be ', participation_count,
              '.');
        display_tree_error (error (1, error_length), 'PATH_DESCRIPTION_ENTRY', pde, '', NIL, status);
      IFEND;

    PROCEND validate_active_path_part;

    PROCEDURE [INLINE] validate_cumulative_path_size
      (    pde: ^fmt$path_description_entry;
       VAR status: ost$status);

      VAR
        error: string (80),
        error_length: integer;

      IF pde^.parental_path_entry = NIL THEN
        IF pde^.cumulative_parental_path_size <> 0 THEN
          STRINGREP (error, error_length, 'Cumulative_parental_path_size', ' should be 0.');
          display_tree_error (error (1, error_length), 'PATH_DESCRIPTION_ENTRY', pde, '', NIL, status);
        IFEND;
      ELSE
        IF pde^.cumulative_parental_path_size <> (pde^.parental_path_entry^.cumulative_parental_path_size +
              pde^.parental_path_entry^.path_node_name.size + 1) THEN
          STRINGREP (error, error_length, 'Cumulative_parental_path_size', ' should be ',
                pde^.parental_path_entry^.cumulative_parental_path_size + 1,
                pde^.parental_path_entry^.path_node_name.size, '.');
          display_tree_error (error (1, error_length), 'PATH_DESCRIPTION_ENTRY', pde, '', NIL, status);
        IFEND;
      IFEND;

    PROCEND validate_cumulative_path_size;

    PROCEDURE [INLINE] validate_cycle_number
      (    pde: ^fmt$path_description_entry;
       VAR status: ost$status);

      IF (pde^.cycle_number < pfc$minimum_cycle_number) OR (pde^.cycle_number > pfc$maximum_cycle_number) THEN
        display_tree_error ('Cycle number of PDE is out of PF range.', 'PATH_DESCRIPTION_ENTRY', pde, '', NIL,
              status);
      IFEND;

    PROCEND validate_cycle_number;

    PROCEDURE [INLINE] validate_first_cycle_alias
      (    pde: ^fmt$path_description_entry;
       VAR status: ost$status);

      IF (pde^.first_cycle_alias_entry <> NIL) THEN
        IF (pde^.first_cycle_alias_entry^.entry_type <> fmc$named_object) THEN
          display_tree_error ('First_cycle_alias_entry of PDE is not a named object.',
                'PATH_DESCRIPTION_ENTRY', pde, 'FIRST_CYCLE_ALIAS_ENTRY', pde^.first_cycle_alias_entry,
                status);
        ELSEIF (pde^.first_cycle_alias_entry^.highest_cycle <> pde) THEN
          display_tree_error ('First_cycle_alias_entry of PDE does not point to PDE.',
                'PATH_DESCRIPTION_ENTRY', pde, 'FIRST_CYCLE_ALIAS_ENTRY', pde^.first_cycle_alias_entry,
                status);
        IFEND;
      IFEND;

    PROCEND validate_first_cycle_alias;

    PROCEDURE [INLINE] validate_highest_cycle
      (    pde: ^fmt$path_description_entry;
       VAR status: ost$status);

      IF (pde^.highest_cycle <> NIL) THEN
        IF (pde^.highest_cycle^.entry_type <> fmc$file_cycle_object) THEN
          display_tree_error ('Highest cycle of PDE is not a cycle object.', 'PATH_DESCRIPTION_ENTRY', pde,
                'HIGHEST_CYCLE', pde^.highest_cycle, status);
        ELSEIF (pde^.highest_cycle^.parental_path_entry <> pde) THEN
          temp_pde := pde^.highest_cycle^.first_cycle_alias_entry;
          WHILE (temp_pde <> NIL) AND (temp_pde <> pde) DO
            temp_pde := temp_pde^.next_cycle_alias_entry;
          WHILEND;
          IF temp_pde = NIL THEN
            display_tree_error ('Highest cycle of PDE does not point to PDE.', 'PATH_DESCRIPTION_ENTRY', pde,
                  'HIGHEST_CYCLE', pde^.highest_cycle, status);
          IFEND;
        IFEND;
      IFEND;

    PROCEND validate_highest_cycle;

    PROCEDURE [INLINE] validate_left_subtree
      (    pde: ^fmt$path_description_entry;
       VAR status: ost$status);

      IF (pde^.left_subtree <> NIL) THEN
        IF (pde^.left_subtree^.entry_type <> fmc$named_object) THEN
          display_tree_error ('Left subtree of PDE is not a named object.', 'PATH_DESCRIPTION_ENTRY', pde,
                'LEFT_SUBTREE', pde^.left_subtree, status);
        ELSEIF (pde^.left_subtree^.parental_tree_entry <> pde) THEN
          display_tree_error ('Left subtree of PDE does not point to PDE.', 'PATH_DESCRIPTION_ENTRY', pde,
                'LEFT_SUBTREE', pde^.left_subtree, status);
        IFEND;
      IFEND;

    PROCEND validate_left_subtree;

    PROCEDURE [INLINE] validate_next_cycle_alias_entry
      (    pde: ^fmt$path_description_entry;
       VAR status: ost$status);

      IF (pde^.next_cycle_alias_entry <> NIL) THEN
        IF (pde^.next_cycle_alias_entry^.entry_type <> fmc$named_object) THEN
          display_tree_error ('Next_cycle_alias_entry of PDE is not a named object.',
                'PATH_DESCRIPTION_ENTRY', pde, 'NEXT_CYCLE_ALIAS_ENTRY', pde^.next_cycle_alias_entry, status);
        ELSEIF (pde^.highest_cycle = NIL) THEN
          display_tree_error ('Alias pde does not point to a highest cycle.', 'ALIAS_PDE', pde, '', NIL,
                status);
        ELSEIF (pde^.highest_cycle^.next_lower_cycle <> NIL) OR
              (pde^.highest_cycle^.next_higher_cycle <> NIL) THEN
          display_tree_error ('Alias pde has more than one cycle objects.', 'ALIAS_PDE', pde, 'HIGHEST_CYCLE',
                pde^.highest_cycle, status);
        ELSEIF (pde^.next_cycle_alias_entry^.highest_cycle <> pde^.highest_cycle) THEN
          display_tree_error ('Next_cycle_alias_entry of PDE has a different highest_cycle.',
                'PATH_DESCRIPTION_ENTRY', pde, 'NEXT_CYCLE_ALIAS_ENTRY', pde^.next_cycle_alias_entry, status);
        IFEND;
      IFEND;

    PROCEND validate_next_cycle_alias_entry;

    PROCEDURE [INLINE] validate_next_higher_cycle
      (    pde: ^fmt$path_description_entry;
       VAR status: ost$status);

      IF (pde^.next_higher_cycle <> NIL) THEN
        IF (pde^.next_higher_cycle^.entry_type <> fmc$file_cycle_object) THEN
          display_tree_error ('Next higher cycle of PDE is not a cycle object.', 'PATH_DESCRIPTION_ENTRY',
                pde, 'NEXT_HIGHER_CYCLE', pde^.next_higher_cycle, status);
        ELSEIF (pde^.next_higher_cycle^.next_lower_cycle <> pde) THEN
          display_tree_error ('Next higher cycle of PDE does not point to PDE.', 'PATH_DESCRIPTION_ENTRY',
                pde, 'NEXT_HIGHER_CYCLE', pde^.next_higher_cycle, status);
        IFEND;
      IFEND;

    PROCEND validate_next_higher_cycle;

    PROCEDURE [INLINE] validate_next_lower_cycle
      (    pde: ^fmt$path_description_entry;
       VAR status: ost$status);

      IF (pde^.next_lower_cycle <> NIL) THEN
        IF (pde^.next_lower_cycle^.entry_type <> fmc$file_cycle_object) THEN
          display_tree_error ('Next lower cycle of PDE is not a cycle object.', 'PATH_DESCRIPTION_ENTRY', pde,
                'NEXT_LOWER_CYCLE', pde^.next_lower_cycle, status);
        ELSEIF (pde^.next_lower_cycle^.next_higher_cycle <> pde) THEN
          display_tree_error ('Next lower cycle of PDE does not point to PDE.', 'PATH_DESCRIPTION_ENTRY', pde,
                'NEXT_LOWER_CYCLE', pde^.next_lower_cycle, status);
        IFEND;
      IFEND;

    PROCEND validate_next_lower_cycle;

    PROCEDURE [INLINE] validate_number_of_objects
      (    number_of_named_objects: integer;
           number_of_cycle_objects: integer;
       VAR status: ost$status);

      IF (number_of_cycle_objects <> (fmv$cycle_objects_created - fmv$cycle_objects_deleted)) THEN
        error_found := TRUE;
        STRINGREP (output_string, output_length, ' ': indent,
              'Either fmv$cycle_objects_created or fmv$cycle_objects_deleted', ' is incorrect.');
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        STRINGREP (output_string, output_length, ' ': indent, 'fmv$cycle_objects_created : ',
              fmv$cycle_objects_created);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        STRINGREP (output_string, output_length, ' ': indent, 'fmv$cycle_objects_deleted : ',
              fmv$cycle_objects_deleted);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        STRINGREP (output_string, output_length, ' ': indent,
              'The number of cycle objects in the path table is ', number_of_cycle_objects, '.');
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF (number_of_named_objects <> (fmv$named_objects_created - fmv$named_objects_deleted)) THEN
        error_found := TRUE;
        STRINGREP (output_string, output_length, ' ': indent,
              'Either fmv$named_objects_created or fmv$named_objects_deleted', ' is incorrect.');
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        STRINGREP (output_string, output_length, ' ': indent, 'fmv$named_objects_created : ',
              fmv$named_objects_created);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        STRINGREP (output_string, output_length, ' ': indent, 'fmv$named_objects_deleted : ',
              fmv$named_objects_deleted);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        STRINGREP (output_string, output_length, ' ': indent,
              'The number of named objects in the path table is ', number_of_named_objects, '.');
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    PROCEND validate_number_of_objects;

    PROCEDURE [INLINE] validate_path_depth
      (    pde: ^fmt$path_description_entry;
       VAR status: ost$status);

      VAR
        error: string (80),
        error_length: integer,
        path_depth: integer,
        temp_pde: ^fmt$path_description_entry;

      path_depth := 0;
      temp_pde := pde;
      WHILE temp_pde^.parental_path_entry <> NIL DO
        temp_pde := temp_pde^.parental_path_entry;
        path_depth := path_depth + 1;
      WHILEND;

      IF pde^.entry_type = fmc$named_object THEN
        path_depth := path_depth + 1;
      IFEND;

      IF pde^.path_depth <> path_depth THEN
        STRINGREP (error, error_length, 'Path depth should be ', path_depth, '.');
        display_tree_error (error (1, error_length), 'PATH_DESCRIPTION_ENTRY', pde, '', NIL, status);
      IFEND;

    PROCEND validate_path_depth;

    PROCEDURE [INLINE] validate_parental_path_entry
      (    pde: ^fmt$path_description_entry;
       VAR status: ost$status);

      IF (pde^.parental_path_entry <> NIL) AND (pde^.parental_path_entry^.entry_type <> fmc$named_object) THEN
        display_tree_error ('Parental path entry of PDE is not a named object.', 'PATH_DESCRIPTION_ENTRY',
              pde, 'PARENTAL_PATH_ENTRY', pde^.parental_path_entry, status);
      IFEND;

    PROCEND validate_parental_path_entry;

    PROCEDURE [INLINE] validate_parental_tree_entry
      (    pde: ^fmt$path_description_entry;
       VAR status: ost$status);

      IF (pde^.parental_tree_entry <> NIL) THEN
        IF (pde^.parental_tree_entry^.entry_type <> fmc$named_object) THEN
          display_tree_error ('Parental tree entry of PDE is not a named object.', 'PATH_DESCRIPTION_ENTRY',
                pde, 'PARENTAL_TREE_ENTRY', pde^.parental_tree_entry, status);
        ELSEIF (pde^.parental_tree_entry^.left_subtree <> pde) AND
              (pde^.parental_tree_entry^.right_subtree <> pde) THEN
          display_tree_error ('Parental tree entry of PDE does not point to PDE.', 'PATH_DESCRIPTION_ENTRY',
                pde, 'PARENTAL_TREE_ENTRY', pde^.parental_tree_entry, status);
        IFEND;
      IFEND;

    PROCEND validate_parental_tree_entry;

    PROCEDURE [INLINE] validate_path_node_name
      (    pde: ^fmt$path_description_entry;
       VAR status: ost$status);

      VAR
        name_is_valid: boolean,
        randomized_name: ost$randomized_name,
        valid_name: ost$name;

      clp$validate_name (pde^.path_node_name.value, valid_name, name_is_valid);
      IF NOT name_is_valid THEN
        display_tree_error ('Path node name is not valid.', 'PATH_DESCRIPTION_ENTRY', pde, '', NIL, status);
      ELSEIF valid_name <> pde^.path_node_name.value THEN
        display_tree_error ('Path node name is not uppercase.', 'PATH_DESCRIPTION_ENTRY', pde, '', NIL,
              status);
      ELSEIF clp$trimmed_string_size (valid_name) <> pde^.path_node_name.size THEN
        display_tree_error ('Path node name size is incorrect.', 'PATH_DESCRIPTION_ENTRY', pde, '', NIL,
              status);
      ELSE
        osp$randomize_name (pde^.path_node_name.value, randomized_name);
        IF pde^.randomized_node_name <> randomized_name THEN
          display_tree_error ('Randomize node name size is incorrect.', 'PATH_DESCRIPTION_ENTRY', pde, '',
                NIL, status);
        IFEND;
      IFEND;

    PROCEND validate_path_node_name;

    PROCEDURE [INLINE] validate_right_subtree
      (    pde: ^fmt$path_description_entry;
       VAR status: ost$status);

      IF (pde^.right_subtree <> NIL) THEN
        IF (pde^.right_subtree^.entry_type <> fmc$named_object) THEN
          display_tree_error ('Right subtree of PDE is not a named object.', 'PATH_DESCRIPTION_ENTRY', pde,
                'RIGHT_SUBTREE', pde^.right_subtree, status);
        ELSEIF (pde^.right_subtree^.parental_tree_entry <> pde) THEN
          display_tree_error ('Right subtree of PDE does not point to PDE.', 'PATH_DESCRIPTION_ENTRY', pde,
                'RIGHT_SUBTREE', pde^.right_subtree, status);
        IFEND;
      IFEND;

    PROCEND validate_right_subtree;

    status.normal := TRUE;

    error_found := FALSE;
    number_of_cycle_objects := 0;
    number_of_named_objects := 0;
    pdu := fmv$initial_pdu_pointer;

    display_title (output_fid, 'VALIDATE PATH TABLE OBJECTS', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    REPEAT
      FOR i := 1 TO #SIZE (pdu^.entry_assignment^) DO
        IF pdu^.entry_assignment^ (i) = fmc$entry_assigned THEN
          pde := ^pdu^.entries^ [i];
          validate_cumulative_path_size (pde, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          validate_path_depth (pde, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF pde^.entry_assignment^ <> fmc$entry_assigned THEN
            display_tree_error ('Entry assignment pointer is incorrect', 'PATH_DESCRIPTION_ENTRY', pde, '',
                  NIL, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
          validate_parental_path_entry (pde, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF pde^.entry_type = fmc$named_object THEN
            number_of_named_objects := number_of_named_objects + 1;
            validate_active_path_part (pde, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            validate_parental_tree_entry (pde, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            validate_left_subtree (pde, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            validate_right_subtree (pde, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            validate_path_node_name (pde, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            validate_highest_cycle (pde, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            validate_next_cycle_alias_entry (pde, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSE {cycle objects
            number_of_cycle_objects := number_of_cycle_objects + 1;
            validate_cycle_number (pde, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            validate_next_lower_cycle (pde, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            validate_next_higher_cycle (pde, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            validate_first_cycle_alias (pde, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND; {NAMED OBJECT ?
        IFEND; {entry_assigned}
      FOREND;
      pdu := pdu^.next_path_description_unit;
    UNTIL pdu = NIL;

    validate_number_of_objects (number_of_named_objects, number_of_cycle_objects, status);

    IF NOT error_found THEN
      STRINGREP (output_string, output_length, ' ', 'No errors found in Path Table.');
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND bap$validate_path_table_objects;

?? TITLE := ' PROCEDURE append_cycle_damage_symptoms', EJECT ??

  PROCEDURE append_cycle_damage_symptoms
    (    cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR str: {i/o} string (300);
     VAR str_length: {i/o} integer);

    IF cycle_damage_symptoms = $fst$cycle_damage_symptoms [] THEN
      STRINGREP (str, str_length, str (1, str_length), 'NONE');
    ELSE
      STRINGREP (str, str_length, str (1, str_length), '(');
      IF fsc$media_image_inconsistent IN cycle_damage_symptoms THEN
        STRINGREP (str, str_length, str (1, str_length), 'fsc$media_image_inconsistant, ');
      IFEND;
      IF fsc$respf_modification_mismatch IN cycle_damage_symptoms THEN
        STRINGREP (str, str_length, str (1, str_length), 'fsc$respf_modification_mismatch, ');
      IFEND;
      IF fsc$cycle_restored IN cycle_damage_symptoms THEN
        STRINGREP (str, str_length, str (1, str_length), 'fsc$cycle_restored, ');
      IFEND;
      IF fsc$parent_catalog_restored IN cycle_damage_symptoms THEN
        STRINGREP (str, str_length, str (1, str_length), 'fsc$parent_catalog_restored, ');
      IFEND;
      str_length := str_length - 1;
      str (str_length) := ')';
    IFEND;

  PROCEND append_cycle_damage_symptoms;

?? TITLE := ' PROCEDURE append_file_access_options ', EJECT ??

  PROCEDURE append_file_access_options
    (    access_or_share_modes: fst$file_access_options;
     VAR str: {i/o} string (bat$display_tables_str_length);
     VAR str_length: {i/o} integer);

    VAR
      usage_selections: pft$usage_selections;

    #UNCHECKED_CONVERSION (access_or_share_modes, usage_selections);
    append_usage_selections (usage_selections, str, str_length);

  PROCEND append_file_access_options;

?? TITLE := ' PROCEDURE append_logging_options ', EJECT ??

  PROCEDURE append_logging_options
    (    logging_options: amt$logging_options;
     VAR str: {i/o} string (bat$display_tables_str_length);
     VAR str_length: {i/o} integer);

    IF logging_options = $amt$logging_options [] THEN
      STRINGREP (str, str_length, str (1, str_length), 'NONE');
    ELSE
      STRINGREP (str, str_length, str (1, str_length), '(');
      IF amc$enable_parcels IN logging_options THEN
        STRINGREP (str, str_length, str (1, str_length), 'AMC$ENABLE_PARCELS, ');
      IFEND;
      IF amc$enable_media_recovery IN logging_options THEN
        STRINGREP (str, str_length, str (1, str_length), 'AMC$ENABLE_MEDIA_RECOVERY, ');
      IFEND;
      IF amc$enable_request_recovery IN logging_options THEN
        STRINGREP (str, str_length, str (1, str_length), 'AMC$ENABLE_REQUEST_RECOVERY, ');
      IFEND;
      str_length := str_length - 1;
      str (str_length) := ')';
    IFEND;

  PROCEND append_logging_options;

?? TITLE := ' PROCEDURE append_message_control ', EJECT ??

  PROCEDURE append_message_control
    (    message_control: amt$message_control;
     VAR str: {i/o} string (bat$display_tables_str_length);
     VAR str_length: {i/o} integer);

    IF message_control = $amt$message_control [] THEN
      STRINGREP (str, str_length, str (1, str_length), 'NONE');
    ELSE
      STRINGREP (str, str_length, str (1, str_length), '(');
      IF amc$trivial_errors IN message_control THEN
        STRINGREP (str, str_length, str (1, str_length), 'AMC$TRIVIAL_ERRORS, ');
      IFEND;
      IF amc$messages IN message_control THEN
        STRINGREP (str, str_length, str (1, str_length), 'AMC$MESSAGES, ');
      IFEND;
      IF amc$statistics IN message_control THEN
        STRINGREP (str, str_length, str (1, str_length), 'AMC$STATISTICS, ');
      IFEND;
      str_length := str_length - 1;
      str (str_length) := ')';
    IFEND;

  PROCEND append_message_control;

?? TITLE := ' PROCEDURE append_usage_selections ', EJECT ??

  PROCEDURE append_usage_selections
    (    access_or_share_modes: pft$usage_selections;
     VAR str: {i/o} string (bat$display_tables_str_length);
     VAR str_length: {i/o} integer);

    VAR
      usage_option: pft$usage_options;

    IF access_or_share_modes = $pft$usage_selections [] THEN
      STRINGREP (str, str_length, str (1, str_length), 'NONE');
    ELSE
      STRINGREP (str, str_length, str (1, str_length), '(');
      FOR usage_option := LOWERVALUE (pft$usage_options) TO UPPERVALUE (pft$usage_options) DO
        IF usage_option IN access_or_share_modes THEN
          STRINGREP (str, str_length, str (1, str_length), amv$usage_option_names [usage_option].
                name (1, amv$usage_option_names [usage_option].size), ', ');
        IFEND;
      FOREND;
      str_length := str_length - 1;
      str (str_length) := ')';
    IFEND;

  PROCEND append_usage_selections;

?? TITLE := ' PROCEDURE display_apfid ', EJECT ??

  PROCEDURE display_apfid
    (    output_fid: amt$file_identifier;
         apfid: pft$attached_permanent_file_id,
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      output_length: integer,
      output_string: string (bat$display_tables_str_length);


    status.normal := TRUE;
    CASE apfid.family_location OF
    = pfc$local_mainframe =
      STRINGREP (output_string, output_length, ' ': indent, 'pfc$local_mainframe - index : ',
            apfid.attached_pf_table_index);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    = pfc$server_mainframe =
      STRINGREP (output_string, output_length, ' ': indent, 'pfc$server_mainframe - index : ',
            apfid.server_attached_pf_table_index);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      STRINGREP (output_string, output_length, ' ': indent, 'Served family index : ',
            apfid.served_family_table_index.pointers_index, ' ',
            apfid.served_family_table_index.family_list_index);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      STRINGREP (output_string, output_length, ' ': indent,
            'Server lifetime : ', apfid.server_lifetime);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    ELSE
      STRINGREP (output_string, output_length, ' ': indent, ' UNKNOWN residence ');
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    CASEND;
  PROCEND display_apfid;

?? TITLE := 'PROCEDURE display_cd_entry', EJECT ??

  PROCEDURE display_cd_entry
    (    output_fid: amt$file_identifier;
         cde: ^fmt$cycle_description;
         expansion_limit: fst$path_table_expansion_limit;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      local_indent: bat$display_tables_indention,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      path_handle_name: fst$path_handle_name;

    status.normal := TRUE;

    IF cde^.entry_assignment^ = fmc$entry_assigned THEN
      clp$construct_path_handle_name (cde^.path_handle, path_handle_name);
      STRINGREP (output_string, output_length, ' ': indent, 'path_handle_name : ',
            path_handle_name);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'global_file_information : ',
            cde^.global_file_information);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (expansion_limit > fsc$disbt_cd) AND (cde^.global_file_information <> NIL) THEN
        display_global_file_info (output_fid, cde^.global_file_information, indent + 4, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'static_setfa_entries : ',
            cde^.static_setfa_entries);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'cd_attachment_options : ',
            cde^.cd_attachment_options);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF cde^.cd_attachment_options <> NIL THEN
        IF cde^.cd_attachment_options^.free_behind_specified THEN
          STRINGREP (output_string, output_length, ' ': indent+4, 'free_behind : ',
                cde^.cd_attachment_options^.free_behind);
          amp$put_next (output_fid, ^output_string, output_length, ba, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        IF cde^.cd_attachment_options^.job_write_concurrency_specified THEN
          STRINGREP (output_string, output_length, ' ': indent+4, 'job_write_concurrency : ',
                cde^.cd_attachment_options^.job_write_concurrency);
          amp$put_next (output_fid, ^output_string, output_length, ba, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        IF cde^.cd_attachment_options^.private_read_specified THEN
          STRINGREP (output_string, output_length, ' ': indent+4, 'private_read : ',
                cde^.cd_attachment_options^.private_read);
          amp$put_next (output_fid, ^output_string, output_length, ba, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        IF cde^.cd_attachment_options^.sequential_access_specified THEN
          STRINGREP (output_string, output_length, ' ': indent+4, 'sequential_access : ',
                cde^.cd_attachment_options^.sequential_access);
          amp$put_next (output_fid, ^output_string, output_length, ba, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        IF cde^.cd_attachment_options^.transfer_size_specified THEN
          STRINGREP (output_string, output_length, ' ': indent+4, 'transfer_size : ',
                cde^.cd_attachment_options^.transfer_size);
          amp$put_next (output_fid, ^output_string, output_length, ba, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'dynamic_setfa_entries : ',
            cde^.dynamic_setfa_entries);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'attached_file : ', cde^.attached_file);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF cde^.attached_file THEN
        local_indent := indent + 4;
        STRINGREP (output_string, output_length, ' ': local_indent, 'system_file_label  ');
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF (expansion_limit > fsc$disbt_cd) THEN
          display_system_file_label (output_fid, ^cde^.system_file_label, local_indent + 4, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        STRINGREP (output_string, output_length, ' ': local_indent, 'device_class : ',
              amv$device_class_names [cde^.device_class].name);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        local_indent := local_indent + 4;
        CASE cde^.device_class OF
        = rmc$magnetic_tape_device, rmc$mass_storage_device =
          STRINGREP (output_string, output_length, ' ': local_indent, 'job_routing_label : ',
                cde^.job_routing_label);
          amp$put_next (output_fid, ^output_string, output_length, ba, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          STRINGREP (output_string, output_length, ' ': local_indent, 'job_routing_label_length : ',
                cde^.job_routing_label_length);
          amp$put_next (output_fid, ^output_string, output_length, ba, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          STRINGREP (output_string, output_length, ' ': local_indent, 'system_file_sfid : ',
                cde^.system_file_id.file_entry_index, ' ', cde^.system_file_id.residence,
                ' ', cde^.system_file_id.file_hash);
          amp$put_next (output_fid, ^output_string, output_length, ba, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          STRINGREP (output_string, output_length, ' ': local_indent, 'permanent_file : ',
                cde^.permanent_file);
          amp$put_next (output_fid, ^output_string, output_length, ba, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF cde^.permanent_file THEN
            local_indent := local_indent + 4;
            display_apfid (output_fid, cde^.apfid, local_indent, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            STRINGREP (output_string, output_length, ' ': local_indent, 'attached_access_modes : ');
            append_file_access_options (cde^.attached_access_modes, output_string, output_length);
            amp$put_next (output_fid, ^output_string, output_length, ba, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            STRINGREP (output_string, output_length, ' ': local_indent, 'attached_share_modes : ');
            append_file_access_options (cde^.attached_share_modes, output_string, output_length);
            amp$put_next (output_fid, ^output_string, output_length, ba, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            STRINGREP (output_string, output_length, ' ': local_indent, 'password_protected : ',
                  cde^.password_protected);
            amp$put_next (output_fid, ^output_string, output_length, ba, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            STRINGREP (output_string, output_length, ' ': local_indent, 'system_file_label_catalogued : ',
                  cde^.system_file_label_catalogued);
            amp$put_next (output_fid, ^output_string, output_length, ba, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        ELSE
        CASEND;
      IFEND;
    ELSE
      STRINGREP (output_string, output_length, ' ': indent, 'cycle_description_entry not assigned');
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND display_cd_entry;

?? TITLE := 'PROCEDURE display_descriptive_attr', EJECT ??

  PROCEDURE display_descriptive_attr
    (    output_fid: amt$file_identifier;
         descriptive: ^bat$descriptive_file_attributes;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      global_file_name: ost$name,
      output_length: integer,
      output_string: string (bat$display_tables_str_length);

    status.normal := TRUE;

    IF descriptive^.application_info_source <> amc$undefined_attribute THEN
      STRINGREP (output_string, output_length, ' ': indent, 'application_info : ',
            descriptive^.application_info);
    ELSE
      STRINGREP (output_string, output_length, ' ': indent, 'application_info :  Undefined');
    IFEND;
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, descriptive^.application_info_source, indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'global_access_mode : ');
    append_usage_selections (descriptive^.global_access_mode, output_string, output_length);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    put_source (output_fid, descriptive^.global_access_mode_source, indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$convert_binary_unique_name (descriptive^.global_file_name, global_file_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (output_string, output_length, ' ': indent, 'global_file_name : ', global_file_name);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, descriptive^.global_file_name_source, indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$convert_binary_unique_name (descriptive^.internal_cycle_name, global_file_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (output_string, output_length, ' ': indent, 'global_file_name : ', global_file_name);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, descriptive^.internal_cycle_name_source, indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'global_share_mode : ');
    append_usage_selections (descriptive^.global_share_mode, output_string, output_length);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, descriptive^.global_share_mode_source, indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'permanent_file : ', descriptive^.permanent_file);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, descriptive^.permanent_file_source, indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_descriptive_attr;

?? TITLE := 'PROCEDURE display_file_cycle_object', EJECT ??

  PROCEDURE display_file_cycle_object
    (    output_fid: amt$file_identifier;
         pde: ^fmt$path_description_entry;
         expansion_limit: fst$path_table_expansion_limit;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      output_length: integer,
      output_string: string (bat$display_tables_str_length);

    status.normal := TRUE;

    STRINGREP (output_string, output_length, ' ': indent, 'cycle_number : ', pde^.cycle_number);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'next_lower_cycle : ', pde^.next_lower_cycle);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'next_higher_cycle : ', pde^.next_higher_cycle);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'first_cycle_alias_entry : ',
          pde^.first_cycle_alias_entry);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'cycle_description : ', pde^.cycle_description);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (expansion_limit > fsc$disbt_pde) AND (pde^.cycle_description <> NIL) THEN
      display_cd_entry (output_fid, pde^.cycle_description, expansion_limit, indent + 4, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND display_file_cycle_object;

?? TITLE := 'PROCEDURE display_pri', EJECT ??

  PROCEDURE display_pri
    (    output_fid: amt$file_identifier;
         pri: ^bat$private_read_information;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      local_indent: bat$display_tables_indention;

    status.normal := TRUE;

    STRINGREP (output_string, output_length, ' ': indent, 'error_status : ', pri^.error_status);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'last_access_operation : ',
          pri^.last_access_operation);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'positioning_info ');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_indent := indent + 4;
    STRINGREP (output_string, output_length, ' ': local_indent, 'block_info ');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_indent := local_indent + 4;
    STRINGREP (output_string, output_length, ' ': local_indent, 'block_number : ',
          pri^.positioning_info.block_info.block_number);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'block_position : ',
          pri^.positioning_info.block_info.block_position);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'current_block_byte_address : ',
          pri^.positioning_info.block_info.current_block_byte_address);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'current_block_length : ',
          pri^.positioning_info.block_info.current_block_length);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'previous_block_header_fba : ',
          pri^.positioning_info.block_info.previous_block_header_fba);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'residual_block_length : ',
          pri^.positioning_info.block_info.residual_block_length);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_indent := indent + 4;
    STRINGREP (output_string, output_length, ' ': local_indent, 'record_info ');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_indent := local_indent + 4;
    STRINGREP (output_string, output_length, ' ': local_indent, 'bor_address : ',
          pri^.positioning_info.record_info.bor_address);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'current_byte_address : ',
          pri^.positioning_info.record_info.current_byte_address);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'file_position : ',
          bav$file_positions [pri^.positioning_info.record_info.file_position]);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'record_header_fba : ',
          pri^.positioning_info.record_info.record_header_fba);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'record_length : ',
          pri^.positioning_info.record_info.record_length);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'residual_record_length : ',
          pri^.positioning_info.record_info.residual_record_length);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'transfer_count : ',
          pri^.positioning_info.record_info.transfer_count);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_pri;

?? TITLE := 'PROCEDURE display_global_file_info', EJECT ??

  PROCEDURE display_global_file_info
    (    output_fid: amt$file_identifier;
         gfi: ^bat$global_file_information;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      cycle_damage_string: string (300),
      local_indent: bat$display_tables_indention,
      output_length: integer,
      output_string: string (bat$display_tables_str_length);

    status.normal := TRUE;

    STRINGREP (output_string, output_length, ' ': indent, 'open_count : ', gfi^.open_count);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'open_lock : ', gfi^.open_lock.lock_id);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'implicit_detach_inhibited : ',
          gfi^.implicit_detach_inhibited);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (cycle_damage_string, output_length, ' ': indent, 'cycle_damage_symptoms : ');
    append_cycle_damage_symptoms (gfi^.cycle_damage_symptoms, cycle_damage_string, output_length);
    amp$put_next (output_fid, ^cycle_damage_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'device_dependent_info');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent + 4, 'device_class : ',
          amv$device_class_names [gfi^.device_dependent_info.device_class].name);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'eoi_byte_address : ', gfi^.eoi_byte_address);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'eoi_set : ', gfi^.eoi_set);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'error_status : ', gfi^.error_status);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'file_limit : ', gfi^.file_limit);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'last_access_operation : ',
          gfi^.last_access_operation);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'max_block_size : ', gfi^.max_block_size);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'max_data_size : ', gfi^.max_data_size);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'max_record_length : ', gfi^.max_record_length);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'min_block_length : ', gfi^.min_block_length);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'opened_access_modes : read=',
          gfi^.opened_access_modes [fsc$read], ' shorten=', gfi^.opened_access_modes [fsc$shorten],
          ' append=', gfi^.opened_access_modes [fsc$append],
          ' modify=', gfi^.opened_access_modes [fsc$modify],
          ' execute=', gfi^.opened_access_modes [fsc$execute]);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'padding_character : ',
          $INTEGER (gfi^.padding_character): #(16), '(16)');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'positioning_info ');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_indent := indent + 4;
    STRINGREP (output_string, output_length, ' ': local_indent, 'block_info ');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_indent := local_indent + 4;
    STRINGREP (output_string, output_length, ' ': local_indent, 'block_number : ',
          gfi^.positioning_info.block_info.block_number);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'block_position : ',
          gfi^.positioning_info.block_info.block_position);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'current_block_byte_address : ',
          gfi^.positioning_info.block_info.current_block_byte_address);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'current_block_length : ',
          gfi^.positioning_info.block_info.current_block_length);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'previous_block_header_fba : ',
          gfi^.positioning_info.block_info.previous_block_header_fba);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'residual_block_length : ',
          gfi^.positioning_info.block_info.residual_block_length);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_indent := indent + 4;
    STRINGREP (output_string, output_length, ' ': local_indent, 'record_info ');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_indent := local_indent + 4;
    STRINGREP (output_string, output_length, ' ': local_indent, 'bor_address : ',
          gfi^.positioning_info.record_info.bor_address);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'current_byte_address : ',
          gfi^.positioning_info.record_info.current_byte_address);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'file_position : ',
          bav$file_positions [gfi^.positioning_info.record_info.file_position]);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'record_header_fba : ',
          gfi^.positioning_info.record_info.record_header_fba);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'record_length : ',
          gfi^.positioning_info.record_info.record_length);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'residual_record_length : ',
          gfi^.positioning_info.record_info.residual_record_length);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'transfer_count : ',
          gfi^.positioning_info.record_info.transfer_count);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'prevented_open_access_modes : read=',
          gfi^.prevented_open_access_modes [fsc$read], ' shorten=', gfi^.
          prevented_open_access_modes [fsc$shorten], ' append=', gfi^.
          prevented_open_access_modes [fsc$append], ' modify=', gfi^.prevented_open_access_modes [fsc$modify],
          ' execute=', gfi^.prevented_open_access_modes [fsc$execute]);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'record_delimiting_character : ',
          $INTEGER (gfi^.record_delimiting_character): #(16), '(16)');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_global_file_info;
?? TITLE := 'PROCEDURE display_instance_attributes', EJECT ??

  PROCEDURE display_instance_attributes
    (    output_fid: amt$file_identifier;
         instance_attributes: ^bat$instance_attributes;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      local_indent: bat$display_tables_indention,
      output_length: integer,
      output_string: string (bat$display_tables_str_length);

    status.normal := TRUE;

    STRINGREP (output_string, output_length, ' ': indent, 'instance_attributes.static_label');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_indent := indent + 4;
    STRINGREP (output_string, output_length, ' ': local_indent, 'block_type : ',
          amv$block_type_names [instance_attributes^.static_label.block_type].name);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, instance_attributes^.static_label.block_type_source, local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'file_organization : ',
          amv$file_organization_names [instance_attributes^.static_label.file_organization].name);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, instance_attributes^.static_label.file_organization_source, local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'record_type : ',
          amv$record_type_names [instance_attributes^.static_label.record_type].name);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, instance_attributes^.static_label.record_type_source, local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'ring_attributes.r1 : ',
          instance_attributes^.static_label.ring_attributes.r1);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (output_string, output_length, ' ': local_indent, 'ring_attributes.r2 : ',
          instance_attributes^.static_label.ring_attributes.r2);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (output_string, output_length, ' ': local_indent, 'ring_attributes.r3 : ',
          instance_attributes^.static_label.ring_attributes.r3);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, instance_attributes^.static_label.ring_attributes_source, local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'instance_attributes.dynamic_label');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'access_mode : ');
    append_usage_selections (instance_attributes^.dynamic_label.access_mode, output_string, output_length);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, instance_attributes^.dynamic_label.access_mode_source, local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'error_exit_name : ',
          instance_attributes^.dynamic_label.error_exit_name);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, instance_attributes^.dynamic_label.error_exit_name_source, local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF instance_attributes^.dynamic_label.error_exit_procedure = NIL THEN
      STRINGREP (output_string, output_length, ' ': local_indent, 'error_exit_procedure : NIL_POINTER');
    ELSE
      STRINGREP (output_string, output_length, ' ': local_indent, 'error_exit_procedure : ',
            instance_attributes^.dynamic_label.error_exit_procedure);
    IFEND;
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, instance_attributes^.dynamic_label.error_exit_procedure_source, local_indent,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'perform_failure_recovery : ',
          instance_attributes^.dynamic_label.error_options.perform_failure_recovery, '    error_action : ',
          instance_attributes^.dynamic_label.error_options.error_action);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, instance_attributes^.dynamic_label.error_options_source, local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'label_exit_name : ',
          instance_attributes^.dynamic_label.label_exit_name);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, instance_attributes^.dynamic_label.label_exit_name_source, local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF instance_attributes^.dynamic_label.label_exit_procedure = NIL THEN
      STRINGREP (output_string, output_length, ' ': local_indent, 'label_exit_procedure : NIL_POINTER');
    ELSE
      STRINGREP (output_string, output_length, ' ': local_indent, 'label_exit_procedure : ',
            instance_attributes^.dynamic_label.label_exit_procedure);
    IFEND;
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, instance_attributes^.dynamic_label.label_exit_procedure_source, local_indent,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE instance_attributes^.dynamic_label.open_position OF
    = amc$open_at_boi =
      STRINGREP (output_string, output_length, ' ': local_indent, 'open_position : amc$open_at_boi');
    = amc$open_no_positioning =
      STRINGREP (output_string, output_length, ' ': local_indent, 'open_position : amc$open_no_positioning');
    = amc$open_at_eoi =
      STRINGREP (output_string, output_length, ' ': local_indent, 'open_position : amc$open_at_eoi');
    ELSE
      STRINGREP (output_string, output_length, ' ': local_indent, 'open_position : INVALID OPEN_POSITION');
    CASEND;
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, instance_attributes^.dynamic_label.open_position_source, local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'open_share_modes : ');
    append_file_access_options (instance_attributes^.dynamic_label.open_share_modes, output_string,
          output_length);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, instance_attributes^.dynamic_label.open_share_modes_source, local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'return_option : ',
          instance_attributes^.dynamic_label.return_option);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, instance_attributes^.dynamic_label.return_option_source, local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'error_limit : ',
          instance_attributes^.dynamic_label.error_limit);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, instance_attributes^.dynamic_label.error_limit_source, local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'message_control : ');
    append_message_control (instance_attributes^.dynamic_label.message_control, output_string, output_length);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (output_fid, instance_attributes^.dynamic_label.message_control_source, local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_instance_attributes;

?? TITLE := 'PROCEDURE display_named_object', EJECT ??

  PROCEDURE display_named_object
    (    output_fid: amt$file_identifier;
         pde: ^fmt$path_description_entry;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      output_length: integer,
      output_string: string (bat$display_tables_str_length);

    status.normal := TRUE;

    STRINGREP (output_string, output_length, ' ': indent, 'active_path_participation_count : ',
          pde^.active_path_participation_count);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'parental_tree_entry : ', pde^.parental_tree_entry);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'left_subtree : ', pde^.left_subtree);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'right_subtree : ', pde^.right_subtree);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'path_node_name : ', pde^.path_node_name.value);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'randomized_node_name : ',
          pde^.randomized_node_name);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'highest_cycle : ', pde^.highest_cycle);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'next_cycle_alias_entry : ',
          pde^.next_cycle_alias_entry);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_named_object;

?? TITLE := 'PROCEDURE display_pde', EJECT ??

  PROCEDURE display_pde
    (    output_fid: amt$file_identifier;
         pde: ^fmt$path_description_entry;
         expansion_limit: fst$path_table_expansion_limit;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      output_length: integer,
      output_string: string (bat$display_tables_str_length);

    status.normal := TRUE;

    IF (pde^.unique_identifier = fmc$pde_unique_identifier) AND
          (pde^.entry_assignment^ = fmc$entry_assigned) THEN

      STRINGREP (output_string, output_length, ' ': indent, 'unique_identifier : ', pde^.unique_identifier:
            #(16), '(16)');
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'cumulative_parental_path_size : ',
            pde^.cumulative_parental_path_size);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'path_depth : ', pde^.path_depth);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'entry_assignment_counter : ',
            pde^.entry_assignment_counter: #(16), '(16)');
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'parental_path_entry : ',
            pde^.parental_path_entry);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'path_handle_name_externalized : ',
            pde^.path_handle_name_externalized);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE pde^.entry_type OF
      = fmc$named_object =
        STRINGREP (output_string, output_length, ' ': indent, 'entry_type : fmc$named_object');
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        display_named_object (output_fid, pde, indent + 4, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = fmc$file_cycle_object =
        STRINGREP (output_string, output_length, ' ': indent, 'entry_type : fmc$file_cycle_object');
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        display_file_cycle_object (output_fid, pde, expansion_limit, indent + 4, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSE
      CASEND

    ELSE
      IF pde^.unique_identifier <> fmc$pde_unique_identifier THEN
        STRINGREP (output_string, output_length, ' ': indent, 'Invalid pde passed to display_pde');
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        STRINGREP (output_string, output_length, ' ': indent, 'Entry not assigned');
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

  PROCEND display_pde;

?? TITLE := 'PROCEDURE display_static_label_attributes', EJECT ??

  PROCEDURE display_static_label_attributes
    (    output_fid: amt$file_identifier;
         expanded_static_label: bat$static_label_attributes;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      default_file_attributes: bat$static_label_attributes,
      default_new_retention: fst$retention,
      default_new_retention_specified: boolean,
      output_length: integer,
      output_library: string (amc$max_path_name_size + 100),
      output_string: string (bat$display_tables_str_length);

    status.normal := TRUE;

    bap$get_default_file_attribs (default_file_attributes, default_new_retention_specified,
          default_new_retention, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF expanded_static_label.block_type_source <> default_file_attributes.block_type_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'block_type : ',
            amv$block_type_names [expanded_static_label.block_type].name);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.block_type_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.character_conversion_source <>
          default_file_attributes.character_conversion_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'character_conversion : ',
            expanded_static_label.character_conversion);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.character_conversion_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.clear_space_source <> default_file_attributes.clear_space_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'clear_space : ',
            expanded_static_label.clear_space);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.clear_space_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.file_access_procedure_source <>
          default_file_attributes.file_access_procedure_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'file_access_procedure : ',
            expanded_static_label.file_access_procedure);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.file_access_procedure_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.file_contents_source <> default_file_attributes.file_contents_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'file_contents : ',
            expanded_static_label.file_contents);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.file_contents_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.file_limit_source <> default_file_attributes.file_limit_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'file_limit : ',
            expanded_static_label.file_limit);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.file_limit_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.file_organization_source <> default_file_attributes.file_organization_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'file_organization : ',
            amv$file_organization_names [expanded_static_label.file_organization].name);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.file_organization_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.file_processor_source <> default_file_attributes.file_processor_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'file_processor : ',
            expanded_static_label.file_processor);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.file_processor_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.file_structure_source <> default_file_attributes.file_structure_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'file_structure : ',
            expanded_static_label.file_structure);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.file_structure_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.forced_write <> default_file_attributes.forced_write THEN
      STRINGREP (output_string, output_length, ' ': indent, 'forced_write : ',
            expanded_static_label.forced_write);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.forced_write_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.internal_code_source <> default_file_attributes.internal_code_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'internal_code : ',
            expanded_static_label.internal_code);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.internal_code_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.label_type <> default_file_attributes.label_type THEN
      STRINGREP (output_string, output_length, ' ': indent, 'label_type : ',
            expanded_static_label.label_type);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.label_type_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.line_number <> default_file_attributes.line_number THEN
      STRINGREP (output_string, output_length, ' ': indent, 'line_number.length : ',
            expanded_static_label.line_number.length, '  line_number.location : ',
            expanded_static_label.line_number.location);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.line_number_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.max_block_length_source <> default_file_attributes.max_block_length_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'max_block_length : ',
            expanded_static_label.max_block_length);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.max_block_length_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.max_record_length_source <> default_file_attributes.max_record_length_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'max_record_length : ',
            expanded_static_label.max_record_length);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.max_record_length_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.min_block_length_source <> default_file_attributes.min_block_length_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'min_block_length : ',
            expanded_static_label.min_block_length);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.min_block_length_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.min_record_length_source <> default_file_attributes.min_record_length_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'min_record_length : ',
            expanded_static_label.min_record_length);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.min_record_length_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.padding_character_source <> default_file_attributes.padding_character_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'padding_character : ',
            $INTEGER (expanded_static_label.padding_character): #(16), '(16)');
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.padding_character_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.page_format_source <> default_file_attributes.page_format_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'page_format : ',
            expanded_static_label.page_format);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.page_format_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.page_length_source <> default_file_attributes.page_length_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'page_length : ',
            expanded_static_label.page_length);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.page_length_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.page_width_source <> default_file_attributes.page_width_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'page_width : ',
            expanded_static_label.page_width);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.page_width_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.preset_value <> default_file_attributes.preset_value THEN
      STRINGREP (output_string, output_length, ' ': indent, 'preset_value : ',
            expanded_static_label.preset_value);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.preset_value_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.record_delimiting_char_source <>
          default_file_attributes.record_delimiting_char_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'record_delimiting_character : ',
            $INTEGER (expanded_static_label.record_delimiting_character): #(16), '(16)');
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.record_delimiting_char_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.record_type_source <> default_file_attributes.record_type_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'record_type : ',
            amv$record_type_names [expanded_static_label.record_type].name);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.record_type_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;


    IF expanded_static_label.statement_identifier_source <>
          default_file_attributes.statement_identifier_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'statement_identifier :  length = ',
            expanded_static_label.statement_identifier.length, ' location = ',
            expanded_static_label.statement_identifier.location);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.statement_identifier_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.user_info_source <> default_file_attributes.user_info_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'user_info : ', expanded_static_label.user_info);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.user_info_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.vertical_print_density_source <>
          default_file_attributes.vertical_print_density_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'vertical_print_density : ',
            expanded_static_label.vertical_print_density);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.vertical_print_density_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.average_record_length_source <>
          default_file_attributes.average_record_length_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'average_record_length : ',
            expanded_static_label.average_record_length);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.average_record_length_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.collate_table_source <> default_file_attributes.collate_table_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'collate_table : set but not displayed');
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.collate_table_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.collate_table_name_source <>
          default_file_attributes.collate_table_name_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'collate_table_name : ',
            expanded_static_label.collate_table_name);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.collate_table_name_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.compression_proc_name_source <>
          default_file_attributes.compression_proc_name_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'compression_procedure_name.name : ',
            expanded_static_label.compression_procedure_name.name);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      STRINGREP (output_library, output_length, ' ': indent, 'compression_procedure_name.object_library : ',
            expanded_static_label.compression_procedure_name.object_library
            (1, clp$trimmed_string_size (expanded_static_label.compression_procedure_name.object_library)));
      amp$put_next (output_fid, ^output_library, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.compression_proc_name_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.data_padding_source <> default_file_attributes.data_padding_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'data_padding : ',
            expanded_static_label.data_padding);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.data_padding_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.dynamic_home_block_space_source <>
          default_file_attributes.dynamic_home_block_space_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'dynamic_home_block_space : ',
            expanded_static_label.dynamic_home_block_space);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.dynamic_home_block_space_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.embedded_key_source <> default_file_attributes.embedded_key_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'embedded_key : ',
            expanded_static_label.embedded_key);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.embedded_key_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.estimated_record_count_source <>
          default_file_attributes.estimated_record_count_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'estimated_record_count : ',
            expanded_static_label.estimated_record_count);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.estimated_record_count_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.hashing_procedure_name_source <>
          default_file_attributes.hashing_procedure_name_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'hashing_procedure_name.name : ',
            expanded_static_label.hashing_procedure_name.name);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      STRINGREP (output_library, output_length, ' ': indent, 'hashing_procedure_name.object_library : ',
            expanded_static_label.hashing_procedure_name.object_library
            (1, clp$trimmed_string_size (expanded_static_label.hashing_procedure_name.object_library)));
      amp$put_next (output_fid, ^output_library, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.hashing_procedure_name_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.index_levels_source <> default_file_attributes.index_levels_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'index_levels : ',
            expanded_static_label.index_levels);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.index_levels_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.index_padding_source <> default_file_attributes.index_padding_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'index_padding : ',
            expanded_static_label.index_padding);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.index_padding_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.initial_home_block_count_source <>
          default_file_attributes.initial_home_block_count_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'initial_home_block_count : ',
            expanded_static_label.initial_home_block_count);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.initial_home_block_count_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.key_length_source <> default_file_attributes.key_length_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'key_length : ',
            expanded_static_label.key_length);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.key_length_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.key_position_source <> default_file_attributes.key_position_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'key_position : ',
            expanded_static_label.key_position);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.key_position_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.key_type_source <> default_file_attributes.key_type_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'key_type : ', expanded_static_label.key_type);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.key_type_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.loading_factor_source <> default_file_attributes.loading_factor_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'loading_factor : ',
            expanded_static_label.loading_factor);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.loading_factor_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.lock_expiration_time_source <>
          default_file_attributes.lock_expiration_time_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'lock_expiration_time : ',
            expanded_static_label.lock_expiration_time);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.lock_expiration_time_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.logging_options_source <> default_file_attributes.logging_options_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'logging_options : ');
      append_logging_options (expanded_static_label.logging_options, output_string, output_length);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.logging_options_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.log_residence_source <> default_file_attributes.log_residence_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'log_residence : ',
            expanded_static_label.log_residence);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.log_residence_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.record_limit_source <> default_file_attributes.record_limit_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'record_limit : ',
            expanded_static_label.record_limit);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.record_limit_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF expanded_static_label.records_per_block_source <> default_file_attributes.records_per_block_source THEN
      STRINGREP (output_string, output_length, ' ': indent, 'records_per_block : ',
            expanded_static_label.records_per_block);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_source (output_fid, expanded_static_label.records_per_block_source, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND display_static_label_attributes;

?? TITLE := 'PROCEDURE display_system_file_label', EJECT ??

  PROCEDURE display_system_file_label
    (    output_fid: amt$file_identifier;
         sfl: ^fmt$system_file_label;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      expanded_static_label: bat$static_label_attributes,
      file_previously_opened: boolean,
      header: ^fmt$static_label_header,
      local_indent: bat$display_tables_indention,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      static_label: ^SEQ ( * );

    status.normal := TRUE;

    STRINGREP (output_string, output_length, ' ': indent, 'file_previously_opened : ',
          sfl^.file_previously_opened);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'static_label : ', sfl^.static_label);
    { pointer to seq }
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$expand_file_label (sfl^.static_label, expanded_static_label, file_previously_opened, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF sfl^.static_label <> NIL THEN
      static_label := sfl^.static_label;
      local_indent := indent + 4;

      RESET static_label;
      NEXT header IN static_label;
      STRINGREP (output_string, output_length, ' ': local_indent, 'unique_character : ',
            header^.unique_character);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': local_indent, 'revision_level : ',
            header^.revision_level);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': local_indent, 'highest_attribute_present : ',
            header^.highest_attribute_present);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': local_indent, 'highest_attribute_supported : ',
            header^.highest_attribute_supported);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': local_indent, 'job_routing_label_size : ',
            header^.job_routing_label_size);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': local_indent, 'default_revision_level : ',
            header^.default_revision_level);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': local_indent, 'user_attribute_length : ',
            header^.user_attribute_length);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': local_indent, 'file_previously_opened : ',
            header^.file_previously_opened);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF header^.file_previously_opened THEN
        STRINGREP (output_string, output_length, ' ': local_indent + 4, 'ring_attributes : ',
              header^.ring_attributes.r1, ' ', header^.ring_attributes.r2, ' ', header^.ring_attributes.r3);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF header^.highest_attribute_present > 0 THEN
        STRINGREP (output_string, output_length, ' ': local_indent,
              'static_label_attributes - nondefault values');
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        display_static_label_attributes (output_fid, expanded_static_label, local_indent + 4, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        STRINGREP (output_string, output_length, ' ': local_indent, 'NO static_label_attributes present');
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'descriptive_file_attributes ');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display_descriptive_attr (output_fid, ^sfl^.descriptive_label, indent + 4, status);

  PROCEND display_system_file_label;

?? TITLE := 'PROCEDURE display_title', EJECT ??

  PROCEDURE display_title
    (    output_fid: amt$file_identifier;
         title: string ( * <= title_length);
     VAR status: ost$status);

    CONST
      asterisks_constant = '****************************************' CAT
            '****************************************';

    VAR
      asterisks: string (80),
      ba: amt$file_byte_address,
      output_length: integer,
      output_string: string (bat$display_tables_str_length);

    status.normal := TRUE;

    asterisks := asterisks_constant;
    STRINGREP (output_string, output_length, '1', asterisks (1, title_length));
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (output_string, output_length, ' ', asterisks
          (1, ((title_length DIV 2) - (STRLENGTH (title) DIV 2) - 2 {spaces} )), '  ', title, '  ',
          asterisks (1, (((title_length + 1) DIV 2) - ((STRLENGTH (title) + 1) DIV 2) - 2 {spaces} )));
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (output_string, output_length, ' ', asterisks (1, title_length));
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output_string := '0 ';
    amp$put_next (output_fid, ^output_string, 2, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_title;

?? TITLE := 'PROCEDURE display_tft_entry', EJECT ??

  PROCEDURE display_tft_entry
    (    output_fid: amt$file_identifier;
         tft_entry: ^bat$task_file_entry;
         expand_task_file_table_entry: boolean;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      fap_layer: amt$fap_layer_number,
      output_length: integer,
      output_string: string (bat$display_tables_str_length);

    status.normal := TRUE;

    STRINGREP (output_string, output_length, ' ': indent, 'local_file_name : ', tft_entry^.local_file_name);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'sequence_number : ', tft_entry^.sequence_number);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);

    STRINGREP (output_string, output_length, ' ': indent, 'access_level : ',
          amv$access_level_names [tft_entry^.access_level].name);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT expand_task_file_table_entry THEN
      STRINGREP (output_string, output_length, ' ': indent, 'device_class : ',
            amv$device_class_names [tft_entry^.device_class].name);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'open_ring : ', tft_entry^.open_ring);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'close_allowed : ', tft_entry^.close_allowed);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'next_target.defined : ',
          tft_entry^.next_target.defined);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF tft_entry^.next_target.defined THEN

      STRINGREP (output_string, output_length, ' ': indent + 4, 'next_target.ordinal : ',
            tft_entry^.next_target.file_identifier.ordinal);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent + 4, 'next_target.sequence : ',
            tft_entry^.next_target.file_identifier.sequence);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'instance_of_open_modified : ',
          tft_entry^.instance_of_open_modified);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'instance_attributes');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_instance_attributes (output_fid, ^tft_entry^.instance_attributes, indent + 4, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'previous_get_at_eoi : ',
          tft_entry^.previous_get_at_eoi);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'residual_skip_count : ',
          tft_entry^.residual_skip_count);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'private_read_information : ',
          tft_entry^.private_read_information);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF tft_entry^.private_read_information <> NIL THEN
      display_pri (output_fid, tft_entry^.private_read_information, indent + 4, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'global_file_information : ',
          tft_entry^.global_file_information);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF tft_entry^.global_file_information <> NIL THEN
      display_global_file_info (output_fid, tft_entry^.global_file_information, indent + 4, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'system_file_label :  ',
          tft_entry^.system_file_label);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF tft_entry^.system_file_label <> NIL THEN
      display_system_file_label (output_fid, tft_entry^.system_file_label, indent + 4, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'fap_control_information ');
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF tft_entry^.fap_control_information.fap_array = NIL THEN
      output_fap_layer ({layer number} 0, tft_entry^.fap_control_information.
            first_fap, output_fid, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      FOR fap_layer := 0 TO UPPERBOUND (tft_entry^.fap_control_information.
            fap_array^) DO
        output_fap_layer (fap_layer, tft_entry^.fap_control_information.
              fap_array^[fap_layer], output_fid, indent, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;
    STRINGREP (output_string, output_length, ' ': indent,
          'module_dynamically_loaded : ', tft_entry^.module_dynamically_loaded);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    STRINGREP (output_string, output_length, ' ': indent, 'device_class : ',
          amv$device_class_names [tft_entry^.device_class].name);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    CASE tft_entry^.device_class OF
    = rmc$mass_storage_device =

      STRINGREP (output_string, output_length, ' ': indent + 4, 'file_pva : ', tft_entry^.file_pva);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF tft_entry^.rollback_procedure = NIL THEN
        STRINGREP (output_string, output_length, ' ': indent + 4, 'rollback_procedure : NIL_POINTER');
      ELSE
        STRINGREP (output_string, output_length, ' ': indent + 4, 'rollback_procedure : ',
              tft_entry^.rollback_procedure);
      IFEND;
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    = rmc$connected_file_device =
      STRINGREP (output_string, output_length, ' ': indent + 4, 'subject : ',
            tft_entry^.subject);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      STRINGREP (output_string, output_length, ' ': indent + 4,
            'connection_level : ', tft_entry^.connection_level);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF tft_entry^.first_target.defined THEN
        STRINGREP (output_string, output_length, ' ': indent + 4,
              'first_target.file_identifier.ordinal : ',
              tft_entry^.first_target.file_identifier.ordinal);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        STRINGREP (output_string, output_length, ' ': indent + 4,
              'first_target.file_identifier.sequence : ',
              tft_entry^.first_target.file_identifier.sequence);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        STRINGREP (output_string, output_length, ' ': indent + 4,
              'first_target not defined');
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    = rmc$log_device =
      STRINGREP (output_string, output_length, ' ': indent + 4,
            'log_ordinal : ', tft_entry^.log_ordinal);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent + 4,
            'log_address : ', tft_entry^.log_address);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent + 4,
            'log_cycle : ', tft_entry^.log_cycle);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent + 4,
            'log_entry : ', tft_entry^.log_entry);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    = rmc$network_device =
      STRINGREP (output_string, output_length, ' ': indent + 4, 'sender_active : ', tft_entry^.sender_active);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF tft_entry^.sender_active THEN
        STRINGREP (output_string, output_length, ' ': indent + 4, 'sender_activity_status : ',
              tft_entry^.sender_activity_status);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent + 4, 'receiver_active : ',
            tft_entry^.receiver_active);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF tft_entry^.receiver_active THEN
        STRINGREP (output_string, output_length, ' ': indent + 4, 'receiver_activity_status : ',
              tft_entry^.receiver_activity_status);
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent + 4, 'data_transfer_timeout : ',
            tft_entry^.data_transfer_timeout);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent + 4, 'eoi_message_enabled : ',
            tft_entry^.eoi_message_enabled);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF tft_entry^.eoi_message_enabled THEN
        STRINGREP (output_string, output_length, ' ': indent + 4, 'eoi_message : ',
              tft_entry^.eoi_message^.value (1, tft_entry^.eoi_message^.size));
        amp$put_next (output_fid, ^output_string, output_length, ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent + 4, 'eoi_peer_termination : ',
            tft_entry^.eoi_peer_termination);
      amp$put_next (output_fid, ^output_string, output_length, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
    CASEND;

  PROCEND display_tft_entry;

?? TITLE := 'PROCEDURE get_path', EJECT ??

  PROCEDURE get_path
    (    path_description_entry: ^fmt$path_description_entry;
     VAR path: fst$path;
     VAR path_length: fst$path_size;
     VAR status: ost$status);

    { PURPOSE: Given a path_description_entry, recreate a path to that node.
    {          A string containing the path is returned.

    VAR
      cycle_string: ost$string,
      pde: ^fmt$path_description_entry;

    status.normal := TRUE;
    pde := path_description_entry;
    path := osc$null_name;

    { Note: path depth is the same in last element and it's cycle objects }

    { Fill in cycle number if file cycle object. }
    IF pde^.entry_type = fmc$file_cycle_object THEN
      clp$convert_integer_to_string (pde^.cycle_number, 10, FALSE, cycle_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      path (pde^.cumulative_parental_path_size + 1, 1) := '.';
      path (pde^.cumulative_parental_path_size + 2, cycle_string.size) := cycle_string.value;
      path_length := pde^.cumulative_parental_path_size + cycle_string.size + 1;
      { Move up the tree. }
      pde := pde^.parental_path_entry;
    ELSE
      path_length := pde^.cumulative_parental_path_size + pde^.path_node_name.size + 1;
    IFEND;

    { Fill in each path element name from last to first. }
    REPEAT
      path (pde^.cumulative_parental_path_size + 1, 1) := '.';
      path (pde^.cumulative_parental_path_size + 2, pde^.path_node_name.size) := pde^.path_node_name.value;
      pde := pde^.parental_path_entry;
    UNTIL pde = NIL;
    path (1, 1) := ':';

  PROCEND get_path;

?? TITLE := 'PROCEDURE output_fap_layer', EJECT ??

  PROCEDURE output_fap_layer
    (    layer_number: amt$fap_layer_number;
         fap_layer: bat$fap_descriptor;
         output_fid: amt$file_identifier;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      output_string: string (bat$display_tables_str_length),
      output_length: integer;

    STRINGREP (output_string, output_length, ' ': indent + 4, 'fap_layer : ',
          layer_number);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent + 8,
          'access_method : ', fap_layer.access_method);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent + 8,
          'structure_pointer : ', fap_layer.structure_pointer);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent + 8, 'loaded_ring : ',
          fap_layer.loaded_ring);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent + 8, 'layer_closed : ',
          fap_layer.layer_closed);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND output_fap_layer;

?? TITLE := 'PROCEDURE put_source', EJECT ??

  PROCEDURE put_source
    (    output_fid: amt$file_identifier;
         source: amt$attribute_source;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      source_string: ost$name;


    status.normal := TRUE;

    CASE source OF
    = amc$undefined_attribute =
      source_string := 'amc$undefined_attribute';
    = amc$local_file_information =
      source_string := 'amc$local_file_information';
    = amc$change_file_attributes =
      source_string := 'amc$change_file_attributes';
    = amc$open_request =
      source_string := 'amc$open_request';
    = amc$file_reference =
      source_string := 'amc$file_reference';
    = amc$file_command =
      source_string := 'amc$file_command';
    = amc$file_request =
      source_string := 'amc$file_request';
    = amc$add_to_file_description =
      source_string := 'amc$add_to_file_description';
    = amc$access_method_default =
      source_string := 'amc$access_method_default';
    = amc$store_request =
      source_string := 'amc$store_request';
    ELSE
      source_string := 'INVALID SOURCE';
    CASEND;

    STRINGREP (output_string, output_length, ' ': indent + 4, 'source : ', source_string);
    amp$put_next (output_fid, ^output_string, output_length, ba, status);

  PROCEND put_source;

MODEND bam$display_tables;

*DECK DECK=BAM$DISPLAY_TAPE_TABLES EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
*copy osd$default_pragmats
MODULE bam$display_tape_tables;

{ This module provides the command DISPLAY_TAPE_TABLES.  This command simply establishes
{ pointers to the tables used by BAM$TAPE_BLOCK_MANAGER_RING3, then calls PMP$ABORT.
{ With the appropriate program description (one which specifies abort_file=$local.command)
{ this will cause control to be passed to the interactive debug facility.  Debug commands
{ can then be used to examine the tape_block_manager tables.

  PROCEDURE [XREF] bap$tape_bm_fetch_tables_ptr (VAR segment: integer;
    VAR offset: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc pmp$abort
*copyc osp$set_status_abnormal
*copyc clp$scan_parameter_list
?? POP ??
*copyc bat$tape_buffer_grp_descriptor
*copyc bat$tape_buffer_grp_descriptor
*copyc bat$tape_block
*copyc bat$tape_block_buffer_index
*copyc bat$tape_block_mgmt_descriptor
*copyc bat$tape_block_position
*copyc bat$tape_block_type
*copyc bat$tape_buffer_information
*copyc bat$tape_buffer_group_index
*copyc bat$tape_buffer_group_state
*copyc bat$tape_buffer_grp_descriptor
*copyc bat$tape_buffer_information
*copyc bat$tape_io_direction
*copyc bat$tape_read_block_description
*copyc iot$read_tape_description
*copyc iot$write_tape_description
*copyc iot$tape_block_count
*copyc iot$tape_io_status
?? EJECT ??
  VAR
    bgd: ^bat$tape_buffer_grp_descriptor := NIL,
    b: ^bat$tape_block := NIL,
    bbi: ^bat$tape_block_buffer_index := NIL,
    bmd: ^bat$tape_block_mgmt_descriptor := NIL,
    bp: ^bat$tape_block_position := NIL,
    bt: ^bat$tape_block_type := NIL,
    bgi: ^bat$tape_buffer_group_index := NIL,
    bgs: ^bat$tape_buffer_group_state := NIL,
    bi: ^bat$tape_buffer_information := NIL,
    iod: ^bat$tape_io_direction := NIL,
    rbd: ^bat$tape_read_block_description := NIL,
    is: ^iot$tape_io_status := NIL;
?? EJECT ??
  PROCEDURE [XDCL] bap$display_tape_tables (plist: clt$parameter_list; VAR status: ost$status);

    VAR
      segment: integer,
      offset: integer;

    bap$tape_bm_fetch_tables_ptr (segment,offset,status);
    IF NOT status.normal THEN
      pmp$abort(status);
    IFEND;

    bmd := #ADDRESS (0d(16), segment, offset);
    bgd := bmd^.buffer_group[1];
    bi := ^bgd^.block_buffer[1];
    b := bi^.block_buffer;

    osp$set_status_abnormal('BA',0,'Ready to display tape block manager tables.',status);
    pmp$abort(status);

  PROCEND bap$display_tape_tables;

MODEND bam$display_tape_tables;
*DECK DECK=BAM$EVALUATE_PATH EXPAND=TRUE
*copyc osd$default_pragmats

?? TITLE := 'NOS/VE : Basic Access Methods : Path evaluator' ??

MODULE bam$evaluate_path;

{ PURPOSE: Retrieve the evaluated_file_reference for a given path and the
{          path_handle_name if the path is registered.


?? PUSH (LISTEXT := ON) ??
*copyc fsc$local
?? POP ??
*copyc clp$construct_path_handle_name
*copyc fmp$evaluate_path
*copyc fsp$path_element

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$evaluate_path', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$evaluate_path (file: fst$file_reference;
        resolve_to_catalog: boolean;
        command_file_reference_allowed: boolean;
        record_path: boolean;
    VAR evaluated_file_reference: fst$evaluated_file_reference;
    VAR temporary_file: boolean;
    VAR file_registered: boolean;
    VAR path_handle_name: fst$path_handle_name;
    VAR status: ost$status);

    VAR
      ignore_cycle_description: ^fmt$cycle_description,
      path_handle: fmt$path_handle,
      process_pt_work_list: bat$process_pt_work_list;

    status.normal := TRUE;

    process_pt_work_list := $bat$process_pt_work_list [bac$resolve_path];

    IF resolve_to_catalog THEN
      process_pt_work_list := process_pt_work_list + $bat$process_pt_work_list
        [bac$resolve_to_catalog];
    IFEND;
    IF record_path THEN
      process_pt_work_list := process_pt_work_list + $bat$process_pt_work_list
        [bac$record_path];
    IFEND;
    fmp$evaluate_path (file, process_pt_work_list, evaluated_file_reference,
          ignore_cycle_description, status);
    IF status.normal THEN
      file_registered := evaluated_file_reference.path_handle_info.path_handle_present;
      temporary_file := (fsp$path_element (^evaluated_file_reference, 1)^ = fsc$local);
      IF file_registered THEN
        clp$construct_path_handle_name (evaluated_file_reference.path_handle_info.
          path_handle, path_handle_name);
      IFEND;
    IFEND;
  PROCEND bap$evaluate_path;
MODEND bam$evaluate_path;

*DECK DECK=BAM$EXIT_FAP_ON_CONDITION EXPAND=TRUE

?? RIGHT := 110 ??
MODULE bam$exit_fap_on_condition;

{ PURPOSE:
{   This module contains the procedure that returns control to BAM when a
{   volume down or disk full condition occurs during a record_access operation.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$task_private
?? POP ??
*copyc bav$last_tft_entry
*copyc bav$task_file_table
*copyc bav$tft_entry_assignment
*copyc osp$enforce_exception_policies
*copyc osp$establish_block_exit_hndlr
*copyc osp$get_access_condition_entry
*copyc osp$get_file_criteria
*copyc osp$set_status_condition
*copyc osp$verify_system_privilege
*copyc osp$wait_on_condition
*copyc osv$initial_exception_context
*copyc pmp$exit

?? TITLE := '[XDCL, #GATE] bap$exit_fap_on_condition', EJECT ??

{ PURPOSE:
{   To process the VOLUME_UNAVAILABLE and SPACE_UNAVAILABLE conditions that
{   arise during record or segment access.
{
{ DESIGN:
{   Search the task_file_table for an instance of open that has a pointer to a
{   rollback_procedure.  If a non-NIL pointer is found then invoke a call to
{   the rollback_procedure with the status that was passed in.  There should be
{   only one ^rollback_procedure in the TFT at any time except in the case of
{   a byte_move copy for which there are two pointers, one each for the input
{   and output files.  Since both files are involved in the copy process it's
{   okay to exit the copy if access to either of the files encounters volume
{   down.

{   If the preceding search fails, we repeat the scan of the TFT.  This time
{   we look for instances of open for segment access that reside on a missing
{   volume.  We then exit the task.

{   If neither preceding scan finds a file to blame the condition on, we
{   assume the problem is related to a scratch file.  This is not always true.
{   The BACPF and RESPF utilities open permanent files for segment access
{   using a low-level call to Segment Management.  This results in no
{   instance of open in the TFT and imprecision in our analysis of which
{   file is causing the condition.  We pass a NIL file name and call
{   OSP$ENFORCE_EXCEPTION_POLICIES in case the site wants to EXIT on
{   disk full or volume unavailable on a temporary device.

{   The possibility of recursion exists when we try to PUSH and we are processing
{   a temporary space unavailable condition.  In this situation, we detect recursion
{   by using the ISOLATING_SPACE_UNAVAILABLE boolean.  We stop trying to analyze the
{   specific file when we detect recursion and simply wait for space to become
{   available.

  PROCEDURE [XDCL, #GATE] bap$exit_fap_on_condition
    (    condition: ost$status_condition_code);

    CONST
      max_volumes_per_file = 500;

    VAR
      isolating_space_unavailable: [oss$task_private] boolean := FALSE;

?? TITLE := '  exit_fap_handler', EJECT ??

    PROCEDURE exit_fap_handler
      (    ignore_condition: pmt$condition;
           ignore_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

        isolating_space_unavailable := FALSE;

    PROCEND exit_fap_handler;
?? EJECT ??
    VAR
      access_condition_entry: fst$access_condition_entry,
      context: ost$ecp_exception_context,
      criteria: ost$ecp_criteria,
      debug_status: ost$status,
      file_id: ost$ecp_file_identification,
      found: boolean,
      index: bat$tft_limit,
      path: ^fst$path,
      seq_size: ost$positive_integers,
      status: ost$status,
      volume_condition_list: ^fst$volume_condition_list,
      work_area: ^SEQ ( * );


?? TITLE := 'process_space_unavailable', EJECT ??


    PROCEDURE process_space_unavailable;

      VAR
        number_found: 0 .. bac$maximum_tft_size;

      number_found := 0;

      FOR index := 1 TO bav$last_tft_entry DO
        IF (bav$tft_entry_assignment^ (index, 1) = fmc$entry_assigned) THEN
          IF (bav$task_file_table^ [index].device_class = rmc$mass_storage_device) THEN
            IF (bav$task_file_table^ [index].access_level = amc$segment) THEN
              IF (bav$task_file_table^ [index].instance_attributes.dynamic_label.access_mode *
                    $pft$usage_selections [pfc$append, pfc$modify, pfc$shorten]) <> $pft$usage_selections []
                    THEN
                file_id.selector := osc$ecp_file_identifier;
                file_id.file_identifier.ordinal := index;
                file_id.file_identifier.sequence := bav$task_file_table^ [index].sequence_number;

                seq_size := #SIZE (fst$goi_object_information) + fsc$max_path_size + #SIZE (fst$goi_object) +
                      #SIZE (fst$device_information) + (max_volumes_per_file *
                      (#SIZE (rmt$volume_descriptor) + #SIZE (fst$file_access_condition)));
                PUSH work_area: [[REP seq_size OF cell]];

                osp$get_file_criteria (file_id, {catalog_object} FALSE, {catalog_space_unavailable} FALSE,
                     {password} osc$null_name, work_area, criteria, volume_condition_list, status);

                IF status.normal THEN
                  IF (criteria.mass_storage_class = rmc$msc_system_temporary_files) OR
                         (criteria.mass_storage_class = rmc$msc_user_temporary_files) THEN
                    IF temp_space_unavailable () THEN
                      number_found := number_found + 1;
                    IFEND;
                  ELSEIF perm_space_unavailable () THEN
                    number_found := number_found + 1;
                  IFEND;
                IFEND;

              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND;
      IF number_found = 1 THEN
        context := osv$initial_exception_context;
        context.externalized_info.file_segment_isolated := TRUE;
        context.externalized_info.file_segment :=
              #SEGMENT (bav$task_file_table^ [file_id.file_identifier.ordinal].file_pva);
        context.file := file_id;
        context.force_wait := TRUE;
        context.logging_allowed := FALSE;

        osp$set_status_condition (condition, context.condition_status);

        osp$enforce_exception_policies (context);
        IF (context.elapsed_wait_time = 0) THEN
          osp$wait_on_condition (condition);
        IFEND;

        EXIT bap$exit_fap_on_condition;
      IFEND;
    PROCEND process_space_unavailable;
?? OLDTITLE, EJECT ??
?? TITLE := 'process_volume_unavailable', EJECT ??

    PROCEDURE process_volume_unavailable;

      FOR index := 1 TO bav$last_tft_entry DO
        IF (bav$tft_entry_assignment^ (index, 1) = fmc$entry_assigned) THEN
          IF (bav$task_file_table^ [index].device_class = rmc$mass_storage_device) THEN
            IF (bav$task_file_table^ [index].access_level = amc$segment) THEN
              file_id.selector := osc$ecp_file_identifier;
              file_id.file_identifier.ordinal := index;
              file_id.file_identifier.sequence := bav$task_file_table^ [index].sequence_number;

              seq_size := #SIZE (fst$goi_object_information) + fsc$max_path_size + #SIZE (fst$goi_object) +
                    #SIZE (fst$device_information) + (max_volumes_per_file *
                    (#SIZE (rmt$volume_descriptor) + #SIZE (fst$file_access_condition)));
              PUSH work_area: [[REP seq_size OF cell]];

              osp$get_file_criteria (file_id, {catalog_object} FALSE, {catalog_space_unavailable} FALSE,
                   {password} osc$null_name, work_area, criteria, volume_condition_list, status);

              IF status.normal AND volume_unavailable () THEN
                context := osv$initial_exception_context;
                context.externalized_info.file_segment_isolated := TRUE;
                context.externalized_info.file_segment := #SEGMENT (bav$task_file_table^ [index].file_pva);
                context.file := file_id;
                context.force_wait := TRUE;
                context.logging_allowed := FALSE;

                osp$set_status_condition (condition, context.condition_status);

                osp$enforce_exception_policies (context);
                IF (context.elapsed_wait_time = 0) THEN
                  osp$wait_on_condition (condition);
                IFEND;
                EXIT bap$exit_fap_on_condition;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND;
    PROCEND process_volume_unavailable;
?? OLDTITLE ??

?? TITLE := 'perm_space_unavailable', EJECT ??
    FUNCTION perm_space_unavailable: boolean;

      perm_space_unavailable := FALSE;
      IF volume_condition_list <> NIL THEN
        IF volume_condition_list^ [UPPERBOUND (volume_condition_list^)] = fsc$space_unavailable THEN
          perm_space_unavailable := TRUE;
        IFEND;
      IFEND;
    FUNCEND perm_space_unavailable;
 ?? OLDTITLE ??

?? TITLE := 'temp_space_unavailable', EJECT ??
    FUNCTION temp_space_unavailable: boolean;

      VAR
        i: ost$positive_integers;

      temp_space_unavailable := FALSE;
      IF volume_condition_list <> NIL THEN
        FOR i := 1 TO UPPERBOUND (volume_condition_list^) DO
          IF volume_condition_list^ [i] = fsc$space_unavailable THEN
            temp_space_unavailable := TRUE;
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    FUNCEND temp_space_unavailable;
 ?? OLDTITLE ??

?? TITLE := 'volume_unavailable', EJECT ??
    FUNCTION volume_unavailable: boolean;

      VAR
        i: ost$positive_integers;

      volume_unavailable := FALSE;
      IF volume_condition_list <> NIL THEN
        FOR i := 1 TO UPPERBOUND (volume_condition_list^) DO
          IF volume_condition_list^ [i] = fsc$volume_unavailable THEN
            volume_unavailable := TRUE;
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    FUNCEND volume_unavailable;
 ?? OLDTITLE, EJECT ??

    osp$verify_system_privilege;
    osp$establish_block_exit_hndlr (^exit_fap_handler);

    osp$set_status_condition (condition, context.condition_status);
    osp$get_access_condition_entry (context.condition_status, access_condition_entry, found);

    IF found AND (bav$task_file_table <> NIL) THEN

      {Search for an instance of record access and rollback to GET/PUT interface

      FOR index := 1 TO bav$last_tft_entry DO
        IF (bav$tft_entry_assignment^ (index, 1) = fmc$entry_assigned) THEN
          IF (bav$task_file_table^ [index].device_class = rmc$mass_storage_device) THEN
            IF (access_condition_entry.file_access_condition = fsc$space_unavailable) AND
                  ((bav$task_file_table^ [index].instance_attributes.dynamic_label.access_mode *
                  $pft$usage_selections [pfc$append, pfc$modify, pfc$shorten]) <>
                  $pft$usage_selections []) OR (access_condition_entry.file_access_condition =
                  fsc$volume_unavailable) THEN
              IF (bav$task_file_table^ [index].rollback_procedure <> NIL) THEN
                status := context.condition_status;
                bav$task_file_table^ [index].rollback_procedure^ (status);
                RETURN; {BAM does a block exit so this statement is for safety only}
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND;

      IF access_condition_entry.file_access_condition = fsc$volume_unavailable THEN
        process_volume_unavailable;
      ELSEIF access_condition_entry.file_access_condition = fsc$space_unavailable THEN
        IF isolating_space_unavailable THEN
          osp$wait_on_condition (condition);
          RETURN;
        ELSE
          isolating_space_unavailable := TRUE;
          #SPOIL (isolating_space_unavailable);
          process_space_unavailable;
        IFEND;
      IFEND;
      {Unable to isolate file involved.
      context := osv$initial_exception_context;
      context.file.selector := osc$ecp_file_reference;
      context.file.file_reference := NIL;
      context.force_wait := TRUE;
      context.logging_allowed := FALSE;

      osp$set_status_condition (condition, context.condition_status);

      osp$enforce_exception_policies (context);

      IF (context.elapsed_wait_time = 0) THEN
        osp$wait_on_condition (condition);
      IFEND;
    IFEND;
  PROCEND bap$exit_fap_on_condition;
MODEND bam$exit_fap_on_condition;

*DECK DECK=BAM$FILE_STRUCTURE_FUNCTIONS EXPAND=TRUE
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Basic Access method : File Structure Functions' ??

MODULE bam$file_structure_functions;

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc amd$file_attributes
*copyc ame$access_validation_errors
*copyc ame$attribute_validation_errors
*copyc ame$fap_validation_errors
*copyc ame$improper_access_info_key
*copyc ame$improper_file_id
*copyc ame$ring_validation_errors
*copyc amt$access_information
*copyc amt$fetch_attributes
*copyc amt$file_attributes
*copyc bat$tape_descriptor
*copyc bat$task_file_table
*copyc fsc$local
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc rmt$device_classes
?? POP ??
*copyc amp$set_file_instance_abnormal
*copyc avp$ring_min
*copyc bai$tape_descriptor
*copyc bap$validate_file_identifier
*copyc clp$check_name_for_path_handle
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_file_ref
*copyc clp$validate_name
*copyc cmp$get_element_name_via_lun
*copyc dmp$convert_sfid_to_lun
*copyc fmp$get_device_class_and_sfid
*copyc fmp$get_files_volume_info
*copyc fmp$get_resolved_file_reference
*copyc fmp$add_to_file_description
*copyc fmp$change_file_attributes
*copyc fmp$get_label_attributes
*copyc fmp$get_setfa_dynamic_attrs
*copyc fmp$process_pt_request
*copyc fmp$return_file
*copyc fmp$set_attachment_options
*copyc fsp$path_element
*copyc fsp$set_evaluated_file_abnormal
*copyc iop$get_tape_usage_data
*copyc mmp$get_segment_length
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$verify_system_privilege

*copyc amv$label_options
*copyc amv$message_control
*copyc amv$valid_ring
*copyc bav$task_file_table
*copyc fsv$evaluated_file_reference
*copyc rmv$null_device_set

  VAR
    null_set: [STATIC, READ, oss$job_paged_literal] pft$usage_selections := [];

?? TITLE := 'bap$fetch_access_information', EJECT ??
*copyc bah$fetch_access_information

  PROCEDURE [XDCL, #GATE] bap$fetch_access_information (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    VAR
      block_number: ost$non_negative_integers,
      device_class: rmt$device_class,
      element_name: ost$name,
      fetch_status: ost$status,
      fetch_eoi: ost$segment_length,
      caller_id: ost$caller_identifier,
      access_info_ptr: ^amt$access_information,
      file_instance: ^bat$task_file_entry,
      index_string: ost$string,
      logical_unit: iot$logical_unit,
      positioning_info: bat$positioning_info,
      sfid: dmt$system_file_id,
      tape_descriptor: ^bat$tape_descriptor,
      tapemark_number: ost$non_negative_integers,
      file_is_valid: boolean,
      volume_info: array [1..1] of fmt$volume_info,
      loop_index: integer;

    #caller_id (caller_id);
    status.normal := TRUE;
    fetch_status.normal := TRUE;

    bap$validate_file_identifier (file_identifier, file_instance,
          file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id, ' ',
            status);
      RETURN;
    IFEND;


    IF caller_id.ring <> 3 THEN
      IF caller_id.ring > file_instance^.instance_attributes.static_label.
            ring_attributes.r3 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, call_block.operation,
          'BAP$FETCH_ACCESS_INFO-ring validation', status);
        RETURN;
      IFEND;
    IFEND;

    IF file_instance^.private_read_information = NIL THEN
      positioning_info := file_instance^.global_file_information^.
            positioning_info;
    ELSE
      positioning_info := file_instance^.private_read_information^.
            positioning_info;
    IFEND;
    access_info_ptr := call_block.fai.access_information;
    FOR loop_index := LOWERBOUND (access_info_ptr^) TO UPPERBOUND
          (access_info_ptr^) DO
      CASE access_info_ptr^ [loop_index].key OF
      = amc$altered_not_closed =
        access_info_ptr^ [loop_index].item_returned := FALSE;
      = amc$block_number =
        access_info_ptr^ [loop_index].block_number := positioning_info.
              block_info.block_number;
        access_info_ptr^ [loop_index].item_returned := TRUE;
      = amc$current_byte_address =
        access_info_ptr^ [loop_index].current_byte_address := positioning_info.
              record_info.current_byte_address;
        access_info_ptr^ [loop_index].item_returned := TRUE;
      = amc$duplicate_value_inserted =
        access_info_ptr^ [loop_index].item_returned := FALSE;
      = amc$eoi_byte_address =
        IF (file_instance^.access_level = amc$segment) AND
              (file_instance^.device_class = rmc$mass_storage_device) THEN
          mmp$get_segment_length (file_instance^.file_pva, caller_id.ring,
                fetch_eoi, fetch_status);
          IF fetch_status.normal THEN
            access_info_ptr^ [loop_index].eoi_byte_address := fetch_eoi;
            access_info_ptr^ [loop_index].item_returned := TRUE;
          ELSE
            access_info_ptr^ [loop_index].item_returned := FALSE;
          IFEND;
        ELSE
          access_info_ptr^ [loop_index].eoi_byte_address := file_instance^.
                global_file_information^.eoi_byte_address;
          access_info_ptr^ [loop_index].item_returned := TRUE;
        IFEND;
      = amc$error_count =
        access_info_ptr^ [loop_index].item_returned := FALSE;
        { error_count was deleted in the conversion from ftd to
        { private_read_information but the default value is being returned
        { for those callers who previously expected a value.
        access_info_ptr^ [loop_index].error_count := 0;
      = amc$error_status =
        IF file_instance^.private_read_information = NIL THEN
          access_info_ptr^ [loop_index].error_status := file_instance^.
                global_file_information^.error_status;
        ELSE
          access_info_ptr^ [loop_index].error_status := file_instance^.
                private_read_information^.error_status;
        IFEND;
        access_info_ptr^ [loop_index].item_returned := TRUE;
      = amc$file_position =
        access_info_ptr^ [loop_index].file_position := positioning_info.
              record_info.file_position;
        access_info_ptr^ [loop_index].item_returned := TRUE;
      = amc$last_access_operation =
        IF file_instance^.private_read_information = NIL THEN
          access_info_ptr^ [loop_index].last_access_operation := file_instance^.
                global_file_information^.last_access_operation;
        ELSE
          access_info_ptr^ [loop_index].last_access_operation := file_instance^.
                private_read_information^.last_access_operation;
        IFEND;
        access_info_ptr^ [loop_index].item_returned := TRUE;
      = amc$last_op_status =
        access_info_ptr^ [loop_index].item_returned := FALSE;
        { last_op_status was deleted in the conversion from ftd to
        { private_read_information but the default value is being returned
        { for those callers who previously expected a value.
        access_info_ptr^ [loop_index].last_op_status := amc$complete;
      = amc$levels_of_indexing =
        access_info_ptr^ [loop_index].item_returned := FALSE;
        { levels_of_indexing was deleted in the conversion from ftd to
        { private_read_information but the default value is being returned
        { for those callers who previously expected a value.
        access_info_ptr^ [loop_index].levels_of_indexing := 0;
      = amc$lock_file_residence =
        access_info_ptr^ [loop_index].item_returned := FALSE;
      = amc$null_item =
        access_info_ptr^ [loop_index].item_returned := FALSE;
      = amc$number_of_nested_files =
        access_info_ptr^ [loop_index].item_returned := FALSE;
      = amc$number_of_volumes =
        volume_info[1].key := fmc$number_of_volumes;
        fmp$get_files_volume_info (file_instance^.local_file_name, volume_info, fetch_status);
        IF NOT fetch_status.normal THEN
          access_info_ptr^ [loop_index].item_returned := FALSE;
        ELSE
          IF volume_info[1].item_returned THEN
            access_info_ptr^ [loop_index].number_of_volumes := volume_info[1].number_of_volumes;
            access_info_ptr^ [loop_index].item_returned := TRUE;
          ELSE
            access_info_ptr^ [loop_index].item_returned := FALSE;
          IFEND;
        IFEND;
      = amc$physical_volume_position =
        fmp$get_device_class_and_sfid (file_instance^.local_file_name, device_class, sfid, fetch_status);
        IF NOT fetch_status.normal OR (device_class <> rmc$magnetic_tape_device) THEN
          access_info_ptr^ [loop_index].item_returned := FALSE;
        ELSE
          iop$get_tape_usage_data (sfid, block_number, tapemark_number, fetch_status);
          IF NOT fetch_status.normal THEN
            access_info_ptr^ [loop_index].item_returned := FALSE;
          ELSE
            access_info_ptr^ [loop_index].item_returned := TRUE;
            access_info_ptr^ [loop_index].physical_volume_position.block_number := block_number;
            access_info_ptr^ [loop_index].physical_volume_position.tapemark_number := tapemark_number;
          IFEND;
        IFEND;
      = amc$previous_record_address =
        access_info_ptr^ [loop_index].previous_record_address :=
              positioning_info.record_info.bor_address;
        access_info_ptr^ [loop_index].item_returned := TRUE;
      = amc$previous_record_length =
        IF positioning_info.record_info.file_position <>
              amc$mid_record THEN
          access_info_ptr^ [loop_index].previous_record_length :=
                positioning_info.record_info.record_length;
          access_info_ptr^ [loop_index].item_returned := TRUE;
        ELSE
          access_info_ptr^ [loop_index].item_returned := FALSE;
        IFEND;
      = amc$primary_key =
        access_info_ptr^ [loop_index].item_returned := FALSE;
      = amc$residual_skip_count =
        access_info_ptr^ [loop_index].residual_skip_count := file_instance^.
              residual_skip_count;
        access_info_ptr^ [loop_index].item_returned := TRUE;
      = amc$segment_count =
        access_info_ptr^ [loop_index].item_returned := FALSE;
      = amc$segment_information =
        access_info_ptr^ [loop_index].item_returned := FALSE;
      = amc$selected_key_name =
        access_info_ptr^ [loop_index].item_returned := FALSE;
      = amc$selected_nested_file =
        access_info_ptr^ [loop_index].item_returned := FALSE;
      = amc$size_in_blocks =
        access_info_ptr^ [loop_index].item_returned := FALSE;
      = amc$tape_element_name =
        access_info_ptr^ [loop_index].item_returned := FALSE;
        fmp$get_device_class_and_sfid (file_instance^.local_file_name, device_class, sfid, fetch_status);
        IF fetch_status.normal AND (device_class = rmc$magnetic_tape_device) THEN
          dmp$convert_sfid_to_lun (sfid, logical_unit, fetch_status);
          IF fetch_status.normal THEN
            cmp$get_element_name_via_lun (logical_unit, element_name, fetch_status);
            IF fetch_status.normal THEN
              access_info_ptr^ [loop_index].item_returned := TRUE;
              access_info_ptr^ [loop_index].tape_element_name := element_name;
            IFEND;
          IFEND;
        IFEND;
      = amc$tape_failure_isolation =
        access_info_ptr^ [loop_index].item_returned := FALSE;
        IF file_instance^.global_file_information^.device_dependent_info.device_class <>
          rmc$magnetic_tape_device THEN
          access_info_ptr^ [loop_index].item_returned := FALSE;
        ELSE
          RESET file_instance^.global_file_information^.device_dependent_info.tape_descriptor;
          NEXT tape_descriptor IN
            file_instance^.global_file_information^.device_dependent_info.tape_descriptor;
          access_info_ptr^ [loop_index].tape_failure_isolation := tape_descriptor^.failure_isolation;
          access_info_ptr^ [loop_index].item_returned := TRUE;
        IFEND;
      = amc$volume_description =
        volume_info[1].key := fmc$volume;
        volume_info[1].requested_volume_number := access_info_ptr^ [loop_index].volume_index;
        fmp$get_files_volume_info (file_instance^.local_file_name, volume_info, fetch_status);
        IF NOT fetch_status.normal THEN
          access_info_ptr^ [loop_index].item_returned := FALSE;
        ELSE
          IF volume_info[1].item_returned THEN
            access_info_ptr^ [loop_index].volume_description := volume_info[1].volume;
            access_info_ptr^ [loop_index].item_returned := TRUE;
          ELSE
            access_info_ptr^ [loop_index].item_returned := FALSE;
          IFEND;
        IFEND;
      = amc$volume_position =
        IF file_instance^.global_file_information^.device_dependent_info.device_class <>
          rmc$magnetic_tape_device THEN
          access_info_ptr^ [loop_index].item_returned := FALSE;
        ELSE
          RESET file_instance^.global_file_information^.device_dependent_info.tape_descriptor;
          NEXT tape_descriptor IN
            file_instance^.global_file_information^.device_dependent_info.tape_descriptor;
            access_info_ptr^ [loop_index].volume_position := tape_descriptor^.volume_position;
            access_info_ptr^ [loop_index].item_returned := TRUE;
        IFEND;
      = amc$volume_number =
        IF file_instance^.global_file_information^.device_dependent_info.device_class <>
          rmc$magnetic_tape_device THEN
          access_info_ptr^ [loop_index].item_returned := FALSE;
        ELSE
          RESET file_instance^.global_file_information^.device_dependent_info.tape_descriptor;
          NEXT tape_descriptor IN
            file_instance^.global_file_information^.device_dependent_info.tape_descriptor;
            access_info_ptr^ [loop_index].volume_number := tape_descriptor^.volume_number;
            access_info_ptr^ [loop_index].item_returned := TRUE;
        IFEND;
      ELSE
        clp$convert_integer_to_string (loop_index, 10, FALSE, index_string,
              fetch_status);
        IF status.normal THEN
          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_access_info_key, call_block.operation,
                index_string.value (1, index_string.size), status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter,
                index_string.value (1, index_string.size), status);
        IFEND;
      CASEND;
    FOREND;
  PROCEND bap$fetch_access_information;
?? TITLE := 'bap$fetch', EJECT ??
*copyc bah$fetch

  PROCEDURE [XDCL, #GATE] bap$fetch (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);



    VAR
      caller_id: ost$caller_identifier,
      cl_path_handle: clt$path_handle,
      file_attributes: ^amt$fetch_attributes,
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      i: integer,
      improper_key: ost$string,
      p_evaluated_file_reference: ^fst$evaluated_file_reference,
      resolved_file_reference: fst$resolved_file_reference,
      static_label: bat$static_label_attributes,
      tape_descriptor: ^bat$tape_descriptor;

    #caller_id (caller_id);
    status.normal := TRUE;
    bap$validate_file_identifier (file_identifier, file_instance,
          file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id, ' ',
            status);
      RETURN;
    IFEND;

    status.normal := TRUE;

    IF caller_id.ring <> 3 THEN
      IF caller_id.ring > file_instance^.instance_attributes.static_label.
            ring_attributes.r3 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, call_block.operation,
          'BAP$FETCH-ring validation', status);
        RETURN;
      IFEND;
    IFEND;

    file_attributes := call_block.fetch.file_attributes;
    fmp$get_label_attributes (file_instance^.system_file_label, static_label,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := LOWERBOUND (file_attributes^) TO UPPERBOUND (file_attributes^) DO
      CASE file_attributes^ [i].key OF
      = amc$access_level =
        file_attributes^ [i].access_level := file_instance^.access_level;
        file_attributes^ [i].source := amc$open_request;
      = amc$access_mode =
        file_attributes^ [i].access_mode := file_instance^.instance_attributes.
              dynamic_label.access_mode;
        file_attributes^ [i].source := file_instance^.instance_attributes.
              dynamic_label.access_mode_source;
      = amc$application_info =
        file_attributes^ [i].application_info := file_instance^.
              system_file_label^.descriptive_label.application_info;
        file_attributes^ [i].source := file_instance^.system_file_label^.
              descriptive_label.application_info_source;
      = amc$block_type =
        file_attributes^ [i].block_type := file_instance^.instance_attributes.
              static_label.block_type;
        file_attributes^ [i].source := file_instance^.instance_attributes.
              static_label.block_type_source;
      = amc$character_conversion =
        IF file_instance^.device_class = rmc$magnetic_tape_device THEN
          file_attributes^ [i].character_conversion := file_instance^.
               labeled_tape_state_info.character_conversion;
          IF file_instance^.labeled_tape_state_info.character_conversion = static_label.character_conversion
                THEN
            file_attributes^ [i].source := static_label.character_conversion_source;
          ELSE
            file_attributes^ [i].source := amc$local_file_information;
          IFEND;
        ELSE
          file_attributes^ [i].character_conversion := static_label.
                character_conversion;
          file_attributes^ [i].source := static_label.character_conversion_source;
        IFEND;
      = amc$clear_space =
        file_attributes^ [i].clear_space := static_label.clear_space;
        file_attributes^ [i].source := static_label.clear_space_source;
      = amc$device_class =
        file_attributes^ [i].device_class := file_instance^.device_class;
        file_attributes^ [i].source := amc$open_request;
      = amc$error_exit_name =
        file_attributes^ [i].error_exit_name := file_instance^.
              instance_attributes.dynamic_label.error_exit_name;
        file_attributes^ [i].source := file_instance^.instance_attributes.
              dynamic_label.error_exit_name_source;
      = amc$error_exit_procedure =
        file_attributes^ [i].error_exit_procedure := file_instance^.
              instance_attributes.dynamic_label.error_exit_procedure;
        file_attributes^ [i].source := file_instance^.instance_attributes.
              dynamic_label.error_exit_procedure_source;
      = amc$error_options =
        file_attributes^ [i].error_options := file_instance^.
              instance_attributes.dynamic_label.error_options;
        file_attributes^ [i].source := file_instance^.instance_attributes.
              dynamic_label.error_options_source;
      = amc$file_access_procedure =
        file_attributes^ [i].file_access_procedure := static_label.
              file_access_procedure;
        file_attributes^ [i].source := static_label.
              file_access_procedure_source;
      = amc$file_contents =
        file_attributes^ [i].file_contents := static_label.file_contents;
        file_attributes^ [i].source := static_label.file_contents_source;
      = amc$file_limit =
        file_attributes^ [i].file_limit := static_label.file_limit;
        file_attributes^ [i].source := static_label.file_limit_source;
      = amc$file_organization =
        file_attributes^ [i].file_organization := file_instance^.
              instance_attributes.static_label.file_organization;
        file_attributes^ [i].source := file_instance^.instance_attributes.
              static_label.file_organization_source;
      = amc$file_processor =
        file_attributes^ [i].file_processor := static_label.file_processor;
        file_attributes^ [i].source := static_label.file_processor_source;
      = amc$file_structure =
        file_attributes^ [i].file_structure := static_label.file_structure;
        file_attributes^ [i].source := static_label.file_structure_source;
      = amc$forced_write =
        file_attributes^ [i].forced_write := static_label.forced_write;
        file_attributes^ [i].source := static_label.forced_write_source;
      = amc$global_access_mode =
        file_attributes^ [i].global_access_mode := file_instance^.
              system_file_label^.descriptive_label.global_access_mode;
        file_attributes^ [i].source := file_instance^.system_file_label^.
              descriptive_label.global_access_mode_source;
      = amc$global_file_address =
        file_attributes^ [i].global_file_address := file_instance^.
              global_file_information^.positioning_info.record_info.
              current_byte_address;
        file_attributes^ [i].source := amc$local_file_information;
      = amc$global_file_name =
        file_attributes^ [i].global_file_name := file_instance^.
              system_file_label^.descriptive_label.global_file_name;
        file_attributes^ [i].source := file_instance^.system_file_label^.
              descriptive_label.global_file_name_source;
      = amc$global_file_position =
        file_attributes^ [i].global_file_position := file_instance^.
              global_file_information^.positioning_info.record_info.
              file_position;
        file_attributes^ [i].source := amc$local_file_information;
      = amc$global_share_mode =
        file_attributes^ [i].global_share_mode := file_instance^.
              system_file_label^.descriptive_label.global_share_mode;
        file_attributes^ [i].source := file_instance^.system_file_label^.
              descriptive_label.global_share_mode_source;
      = amc$initial_open =
        file_attributes^ [i].initial_open := file_instance^.initial_open;
        file_attributes^ [i].source := amc$open_request;
      = amc$input_device_classes=
        IF file_instance^.device_class IN rmv$null_device_set THEN
          file_attributes^ [i].input_device_classes :=
                $rmt$device_classes[file_instance^.device_class,
                rmc$null_device];
        ELSE
          file_attributes^ [i].input_device_classes :=
                $rmt$device_classes[file_instance^.device_class];
        IFEND;
      = amc$internal_code =
        IF file_instance^.device_class = rmc$magnetic_tape_device THEN
          file_attributes^ [i].internal_code := file_instance^.
               labeled_tape_state_info.character_set;
          IF file_instance^.labeled_tape_state_info.character_set = static_label.internal_code THEN
            file_attributes^ [i].source := static_label.internal_code_source;
          ELSE
            file_attributes^ [i].source := amc$local_file_information;
          IFEND;
        ELSE
          file_attributes^ [i].internal_code := static_label.internal_code;
          file_attributes^ [i].source := static_label.internal_code_source;
        IFEND;
      = amc$label_exit_name =
        file_attributes^ [i].label_exit_name := file_instance^.
              instance_attributes.dynamic_label.label_exit_name;
        file_attributes^ [i].source := file_instance^.instance_attributes.
              dynamic_label.label_exit_name_source;
      = amc$label_exit_procedure =
        file_attributes^ [i].label_exit_procedure := file_instance^.
              instance_attributes.dynamic_label.label_exit_procedure;
        file_attributes^ [i].source := file_instance^.instance_attributes.
              dynamic_label.label_exit_procedure_source;
      = amc$label_options =
        file_attributes^ [i].label_options := file_instance^.
              instance_attributes.dynamic_label.label_options;
        file_attributes^ [i].source := file_instance^.instance_attributes.
              dynamic_label.label_options_source;
      = amc$label_type =
        file_attributes^ [i].label_type := static_label.label_type;
        file_attributes^ [i].source := static_label.label_type_source;
      = amc$line_number =
        file_attributes^ [i].line_number := static_label.line_number;
        file_attributes^ [i].source := static_label.line_number_source;
      = amc$max_block_length =
        IF (file_instance^.device_class = rmc$magnetic_tape_device) THEN
          file_attributes^ [i].max_block_length := file_instance^.
               labeled_tape_state_info.maximum_block_length;
          IF file_instance^.labeled_tape_state_info.maximum_block_length = static_label.max_block_length
                THEN
            file_attributes^ [i].source := static_label.max_block_length_source;
          ELSE
            file_attributes^ [i].source := amc$local_file_information;
          IFEND;
        ELSE
          file_attributes^ [i].max_block_length := static_label.max_block_length;
          file_attributes^ [i].source := static_label.max_block_length_source;
        IFEND;
      = amc$max_record_length =
        IF (file_instance^.device_class = rmc$magnetic_tape_device) THEN
          file_attributes^ [i].max_record_length := file_instance^.
               labeled_tape_state_info.maximum_record_length;
          IF file_instance^.labeled_tape_state_info.maximum_record_length = static_label.max_record_length
                THEN
            file_attributes^ [i].source := static_label.max_record_length_source;
          ELSE
            file_attributes^ [i].source := amc$local_file_information;
          IFEND;
        ELSE
          file_attributes^ [i].max_record_length := static_label.max_record_length;
          file_attributes^ [i].source := static_label.max_record_length_source;
        IFEND;
      = amc$min_block_length =
        file_attributes^ [i].min_block_length := static_label.
              min_block_length;
        file_attributes^ [i].source := static_label.min_block_length_source;
      = amc$min_record_length =
        file_attributes^ [i].min_record_length := static_label.
              min_record_length;
        file_attributes^ [i].source := static_label.min_record_length_source;
      = amc$null_attribute =
        ;
      = amc$open_attached_file =
        file_attributes^ [i].open_attached_file := file_instance^.open_actions.
              open_attached_file;
        file_attributes^ [i].source := amc$open_request;
      = amc$open_created_file =
        file_attributes^ [i].open_created_file := file_instance^.open_actions.
              open_created_file;
        file_attributes^ [i].source := amc$open_request;
      = amc$open_deleted_data =
        file_attributes^ [i].open_deleted_data := file_instance^.open_actions.
              open_deleted_data;
        file_attributes^ [i].source := amc$open_request;
      = amc$open_share_modes =
        file_attributes^ [i].open_share_modes := file_instance^.
              instance_attributes.dynamic_label.open_share_modes;
        file_attributes^ [i].source := file_instance^.instance_attributes.
              dynamic_label.open_share_modes_source;
      = amc$open_position =
        file_attributes^ [i].open_position := file_instance^.
              instance_attributes.dynamic_label.open_position;
        file_attributes^ [i].source := file_instance^.instance_attributes.
              dynamic_label.open_position_source;
      = amc$output_device_classes=
        IF file_instance^.device_class IN rmv$null_device_set THEN
          file_attributes^ [i].output_device_classes :=
                $rmt$device_classes[file_instance^.device_class,
                rmc$null_device];
        ELSE
          file_attributes^ [i].output_device_classes :=
                $rmt$device_classes[file_instance^.device_class];
        IFEND;
      = amc$padding_character =
        IF (file_instance^.device_class = rmc$magnetic_tape_device) THEN
          file_attributes^ [i].padding_character := file_instance^.
                labeled_tape_state_info.padding_character;
          IF file_instance^.labeled_tape_state_info.padding_character = static_label.padding_character
                THEN
            file_attributes^ [i].source := static_label.padding_character_source;
          ELSE
            file_attributes^ [i].source := amc$local_file_information;
          IFEND;
        ELSE
          file_attributes^ [i].padding_character := static_label.padding_character;
          file_attributes^ [i].source := static_label.padding_character_source;
        IFEND;
      = amc$page_format =
        file_attributes^ [i].page_format := static_label.page_format;
        file_attributes^ [i].source := static_label.page_format_source;
      = amc$page_length =
        file_attributes^ [i].page_length := static_label.page_length;
        file_attributes^ [i].source := static_label.page_length_source;
      = amc$page_width =
        file_attributes^ [i].page_width := static_label.page_width;
        file_attributes^ [i].source := static_label.page_width_source;
      = amc$permanent_file =
        file_attributes^ [i].permanent_file := file_instance^.
              system_file_label^.descriptive_label.permanent_file;
        file_attributes^ [i].source := file_instance^.system_file_label^.
              descriptive_label.permanent_file_source;
      = amc$preset_value =
        file_attributes^ [i].preset_value := static_label.preset_value;
        file_attributes^ [i].source := static_label.preset_value_source;
      = amc$private_read =
        file_attributes^ [i].private_read := file_instance^.
              private_read_information <> NIL;
        file_attributes^ [i].source := amc$open_request;
      = amc$record_delimiting_character =
        file_attributes^ [i].record_delimiting_character := static_label.
              record_delimiting_character;
        file_attributes^ [i].source := static_label.
              record_delimiting_char_source;
      = amc$record_type =
        file_attributes^ [i].record_type := file_instance^.instance_attributes.
              static_label.record_type;
        file_attributes^ [i].source := file_instance^.instance_attributes.
              static_label.record_type_source;
      = amc$requested_tape_density =
        IF file_instance^.device_class = rmc$magnetic_tape_device THEN
          tape_descriptor := bai$tape_descriptor (file_instance);
          file_attributes^ [i].requested_tape_density := tape_descriptor^.requested_density;
          file_attributes^ [i].source := amc$local_file_information;
        ELSE
          file_attributes^ [i].source := amc$undefined_attribute;
        IFEND;
      = amc$resolved_file_reference =
        clp$check_name_for_path_handle (file_instance^.local_file_name, cl_path_handle);
        IF (file_instance^.instance_attributes.dynamic_label.open_position_source = amc$file_reference) OR
              (file_instance^.instance_attributes.dynamic_label.open_position_source = amc$open_request) THEN
           cl_path_handle.regular_handle.open_position.specified := TRUE;
           cl_path_handle.regular_handle.open_position.value := file_instance^.instance_attributes.
                 dynamic_label.open_position;
        ELSE
           cl_path_handle.regular_handle.open_position.specified := FALSE;
        IFEND;
        PUSH p_evaluated_file_reference;
        p_evaluated_file_reference^ := fsv$evaluated_file_reference;
        p_evaluated_file_reference^.path_handle_info.path_handle := cl_path_handle.regular_handle;
        p_evaluated_file_reference^.path_handle_info.path_handle_present := TRUE;
        fmp$get_resolved_file_reference (p_evaluated_file_reference^, resolved_file_reference, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF file_attributes^ [i].resolved_file_reference <> NIL THEN
          file_attributes^ [i].resolved_file_reference^ := resolved_file_reference;
          file_attributes^ [i].source := amc$open_request;
        IFEND;
      = amc$ring_attributes =
        file_attributes^ [i].ring_attributes := file_instance^.
              instance_attributes.static_label.ring_attributes;
        file_attributes^ [i].source := file_instance^.instance_attributes.
              static_label.ring_attributes_source;
      = amc$statement_identifier =
        file_attributes^ [i].statement_identifier := static_label.
              statement_identifier;
        file_attributes^ [i].source := static_label.
              statement_identifier_source;
      = amc$user_info =
        file_attributes^ [i].user_info := static_label.user_info;
        file_attributes^ [i].source := static_label.user_info_source;
      = amc$vertical_print_density =
        file_attributes^ [i].vertical_print_density := static_label.vertical_print_density;
        file_attributes^ [i].source := static_label.vertical_print_density_source;
      = amc$actual_block_length =
        file_attributes^ [i].source := amc$undefined_attribute;
      = amc$average_record_length =
        file_attributes^ [i].average_record_length := static_label.
              average_record_length;
        file_attributes^ [i].source := static_label.average_record_length_source;
      = amc$collate_table =
        file_attributes^ [i].collate_table^ :=
              static_label.collate_table;
        file_attributes^ [i].source :=
              static_label.collate_table_source;
      = amc$collate_table_name =
        file_attributes^ [i].collate_table_name := static_label.
              collate_table_name;
        file_attributes^ [i].source := static_label.collate_table_name_source;
      = amc$compression_procedure_name =
        IF file_attributes^ [i].compression_procedure_name <> NIL THEN
          file_attributes^ [i].compression_procedure_name^ := static_label.
                compression_procedure_name;
          file_attributes^ [i].source := static_label.
                compression_proc_name_source;
        IFEND;
      = amc$data_padding =
        file_attributes^ [i].data_padding := static_label.data_padding;
        file_attributes^ [i].source := static_label.data_padding_source;
      = amc$dynamic_home_block_space =
        file_attributes^ [i].dynamic_home_block_space := static_label.
              dynamic_home_block_space;
        file_attributes^ [i].source := static_label.
              dynamic_home_block_space_source;
      = amc$embedded_key =
        file_attributes^ [i].embedded_key := static_label.embedded_key;
        file_attributes^ [i].source := static_label.embedded_key_source;
      = amc$error_limit =
        file_attributes^ [i].error_limit := file_instance^.instance_attributes.
              dynamic_label.error_limit;
        file_attributes^ [i].source := file_instance^.instance_attributes.
              dynamic_label.error_limit_source;
      = amc$estimated_record_count =
        file_attributes^ [i].estimated_record_count := static_label.
              estimated_record_count;
        file_attributes^ [i].source := static_label.
              estimated_record_count_source;
      = amc$hashing_procedure_name =
        IF file_attributes^ [i].hashing_procedure_name <> NIL THEN
          file_attributes^ [i].hashing_procedure_name^ := static_label.
                hashing_procedure_name;
          file_attributes^ [i].source := static_label.
                hashing_procedure_name_source;
        IFEND;
      = amc$index_levels =
        file_attributes^ [i].index_levels := static_label.index_levels;
        file_attributes^ [i].source := static_label.index_levels_source;
      = amc$index_padding =
        file_attributes^ [i].index_padding := static_label.index_padding;
        file_attributes^ [i].source := static_label.index_padding_source;
      = amc$initial_home_block_count =
        file_attributes^ [i].initial_home_block_count := static_label.
              initial_home_block_count;
        file_attributes^ [i].source := static_label.
              initial_home_block_count_source;
      = amc$key_length =
        file_attributes^ [i].key_length := static_label.key_length;
        file_attributes^ [i].source := static_label.key_length_source;
      = amc$key_position =
        file_attributes^ [i].key_position := static_label.key_position;
        file_attributes^ [i].source := static_label.key_position_source;
      = amc$key_type =
        file_attributes^ [i].key_type := static_label.key_type;
        file_attributes^ [i].source := static_label.key_type_source;
      = amc$keyed_file_bkup_for_logging =
        file_attributes^ [i].source := amc$undefined_attribute;
      = amc$loading_factor =
        file_attributes^ [i].loading_factor := static_label.loading_factor;
        file_attributes^ [i].source := static_label.loading_factor_source;
      = amc$lock_expiration_time =
        file_attributes^ [i].lock_expiration_time := static_label.
              lock_expiration_time;
        file_attributes^ [i].source := static_label.
              lock_expiration_time_source;
      = amc$logging_options =
        file_attributes^ [i].logging_options := static_label.logging_options;
        file_attributes^ [i].source := static_label.logging_options_source;
      = amc$log_residence =
        IF file_attributes^ [i].log_residence <> NIL THEN
          file_attributes^ [i].log_residence^ := static_label.log_residence;
          file_attributes^ [i].source := static_label.log_residence_source;
        IFEND;
      = amc$message_control =
        file_attributes^ [i].message_control := file_instance^.
              instance_attributes.dynamic_label.message_control;
        file_attributes^ [i].source := file_instance^.instance_attributes.
              dynamic_label.message_control_source;
      = amc$record_limit =
        file_attributes^ [i].record_limit := static_label.record_limit;
        file_attributes^ [i].source := static_label.record_limit_source;
      = amc$records_per_block =
        file_attributes^ [i].records_per_block := static_label.
              records_per_block;
        file_attributes^ [i].source := static_label.records_per_block_source;
      ELSE
        clp$convert_integer_to_string (i, 10, FALSE, improper_key, status);
        IF status.normal THEN
          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_file_attrib_key, call_block.operation,
                'FILE_ATTRIBUTES', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                improper_key.value (1, improper_key.size), status);
        IFEND;
        RETURN;
      CASEND;

    FOREND;

  PROCEND bap$fetch;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$set_attachment_options', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$set_attachment_options
    (    file: fst$file_reference;
         attachment_options: fmt$cd_attachment_options;
         p_volume_list: {input} ^rmt$volume_list;
     VAR status: ost$status);

    osp$verify_system_privilege;

    IF attachment_options.transfer_size_specified AND (
          (attachment_options.transfer_size < LOWERVALUE (fst$transfer_size)) OR
          (attachment_options.transfer_size > UPPERVALUE (fst$transfer_size))) THEN
      osp$set_status_abnormal (amc$access_method_id, fme$system_error,
            'Improper specification of attachment_options on BAP$SET_ATTACHMENT_OPTIONS', status);
      RETURN;
    IFEND;

    fmp$set_attachment_options (file, attachment_options, p_volume_list, status);

  PROCEND bap$set_attachment_options;

?? TITLE := 'bap$store', EJECT ??
*copyc bah$store

  PROCEDURE [XDCL, #GATE] bap$store (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);



    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      i: integer,
      improper_key: ost$string,
      lfn: amt$local_file_name,
      lfn_status: ost$status,
      store_attr: ^amt$store_attributes,
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      text: ost$name;

    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;
    bap$validate_file_identifier (file_identifier, file_instance,
          file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id, ' ',
            status);
      RETURN;
    IFEND;


    IF caller_id.ring <> 3 THEN
      IF ((($pft$usage_selections [pfc$shorten, pfc$append, pfc$modify] *
            file_instance^.instance_attributes.dynamic_label.access_mode) <>
            $pft$usage_selections []) AND (caller_id.ring > file_instance^.
            instance_attributes.static_label.ring_attributes.r1)) OR ((pfc$read
            IN file_instance^.instance_attributes.dynamic_label.access_mode)
            AND (caller_id.ring > file_instance^.instance_attributes.
            static_label.ring_attributes.r2)) OR (caller_id.ring >
            file_instance^.instance_attributes.static_label.ring_attributes.r3) THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, call_block.operation,
              'BAP$STORE-ring validation', status);
        RETURN;
      IFEND;
    IFEND;
    store_attr := call_block.store.file_attributes;

    bam_status.normal := TRUE;
    text := osc$null_name;

  /verify_loop/
    FOR i := 1 TO UPPERBOUND (store_attr^) DO
      CASE store_attr^ [i].key OF
      = amc$error_exit_procedure =
        ;
      = amc$error_options =
        IF (store_attr^ [i].error_options.error_action < LOWERVALUE (amt$tape_error_action))
        { } OR (store_attr^ [i].error_options.error_action > UPPERVALUE (amt$tape_error_action))
 {      { } OR (store_attr^ [i].error_options.perform_failure_recovery < LOWERVALUE (boolean))
        { } OR (store_attr^ [i].error_options.perform_failure_recovery > UPPERVALUE (boolean))
              THEN
          text := 'ERROR_OPTIONS';
        IFEND;
      = amc$label_exit_procedure =
        ;
      = amc$label_options =
        IF NOT (store_attr^ [i].label_options <= amv$label_options) THEN
          text := 'LABEL_OPTIONS';
        IFEND;

      = amc$null_attribute =
        ;
        { aam }

      = amc$error_limit =
        IF (store_attr^ [i].error_limit < LOWERVALUE (amt$error_limit))
        { } OR (store_attr^ [i].error_limit > UPPERVALUE (amt$error_limit))
              THEN
          text := 'ERROR_LIMIT';
        IFEND;
      = amc$message_control =
        IF NOT (store_attr^ [i].message_control <= amv$message_control) THEN
          text := 'MESSAGE_CONTROL';
        IFEND;
      ELSE
        clp$convert_integer_to_string (i, 10, FALSE, improper_key, bam_status);
        IF bam_status.normal THEN
          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_file_attrib_key, call_block.operation,
                'FILE_ATTRIBUTES', bam_status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                improper_key.value (1, improper_key.size), bam_status);
        IFEND;
        EXIT /verify_loop/;
      CASEND;
      IF text <> osc$null_name THEN
        IF bam_status.normal THEN
          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_file_attrib_value, call_block.operation, text,
                bam_status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter, text,
                bam_status);
        IFEND;
        text := osc$null_name;
      IFEND;
    FOREND /verify_loop/;
    IF NOT bam_status.normal THEN
      status := bam_status;
    ELSE

      FOR i := 1 TO UPPERBOUND (store_attr^) DO
        CASE store_attr^ [i].key OF
        = amc$error_exit_procedure =
          file_instance^.instance_attributes.dynamic_label.error_exit_procedure
                := store_attr^ [i].error_exit_procedure;
          file_instance^.instance_attributes.dynamic_label.
                error_exit_procedure_source := amc$store_request;
        = amc$error_options =
          file_instance^.instance_attributes.dynamic_label.error_options :=
                store_attr^ [i].error_options;
          file_instance^.instance_attributes.dynamic_label.error_options_source
                := amc$store_request;
        = amc$label_exit_procedure =
          file_instance^.instance_attributes.dynamic_label.label_exit_procedure
                := store_attr^ [i].label_exit_procedure;
          file_instance^.instance_attributes.dynamic_label.
                label_exit_procedure_source := amc$store_request;
        = amc$label_options =
          file_instance^.instance_attributes.dynamic_label.label_options :=
                store_attr^ [i].label_options;
          file_instance^.instance_attributes.dynamic_label.label_options_source
                := amc$store_request;
        = amc$error_limit =
          file_instance^.instance_attributes.dynamic_label.error_limit :=
                store_attr^ [i].error_limit;
          file_instance^.instance_attributes.dynamic_label.error_limit_source
                := amc$store_request;
        = amc$message_control =
          file_instance^.instance_attributes.dynamic_label.message_control :=
                store_attr^ [i].message_control;
          file_instance^.instance_attributes.dynamic_label.
                message_control_source := amc$store_request;
        = amc$null_attribute =
          ;
        ELSE
          clp$convert_integer_to_string (i, 10, FALSE, improper_key, status);
          IF status.normal THEN
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_file_attrib_key, call_block.operation,
                  'FILE_ATTRIBUTES', status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  improper_key.value (1, improper_key.size), status);
          IFEND;
          RETURN;
        CASEND;

      FOREND;
    IFEND;

  PROCEND bap$store;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$get_setfa_dynamic_attrs', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$get_setfa_dynamic_attrs
    (    file: fst$file_reference;
     VAR attached_permanent_file: boolean;
     VAR attached_share_modes: fst$file_access_options;
     VAR setfa_specified: boolean;
     VAR dynamic_attributes: fst$setfa_attachment_options;
     VAR status: ost$status);

    fmp$get_setfa_dynamic_attrs (file, attached_permanent_file, attached_share_modes, setfa_specified,
          dynamic_attributes, status);

  PROCEND bap$get_setfa_dynamic_attrs;

?? TITLE := 'bap$add_to_file_description', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$add_to_file_description
    (    file_identifier: amt$file_identifier;
         file_attributes: ^amt$add_to_attributes;
     VAR status: ost$status);

    status.normal := TRUE;

    fmp$add_to_file_description (file_identifier, file_attributes^, status);

  PROCEND bap$add_to_file_description;

?? TITLE := 'bap$change_file_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$change_file_attributes
    (    file_attributes: ^amt$file_attributes;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR open_changed_file: boolean;
     VAR status: ost$status);

    VAR
      attribute_validation_status: ost$status,
      caller_id: ost$caller_identifier,
      i: integer,
      i_string: ost$string,
      ignore_allowed_access: fst$file_access_options,
      ignore_file: fst$parsed_file_reference,
      ignore_required_sharing: fst$file_access_options,
      ignore_status: ost$status,
      proposed_r1: ost$ring,
      proposed_r2: ost$ring,
      proposed_r3: ost$ring,
      text: ost$name,
      valid_name: boolean,
      validated_attr_name: ost$name;

    open_changed_file := FALSE;
    status.normal := TRUE;

    #caller_id (caller_id);
    attribute_validation_status.normal := TRUE;

    IF file_attributes = NIL THEN
      RETURN;
    IFEND;

{ validate file attributes }

    text := osc$null_name;
    FOR i := LOWERBOUND (file_attributes^) TO UPPERBOUND (file_attributes^) DO
      CASE file_attributes^ [i].key OF
      = amc$file_access_procedure =
        IF file_attributes^ [i].file_access_procedure <> osc$null_name THEN
          clp$validate_name (file_attributes^ [i].file_access_procedure,
                validated_attr_name, valid_name);
          IF NOT valid_name THEN
            text := 'FILE_ACCESS_PROCEDURE';
          IFEND;
        IFEND;
      = amc$file_contents =
        clp$validate_name (file_attributes^ [i].file_contents,
              validated_attr_name, valid_name);
        IF NOT valid_name THEN
          text := 'FILE_CONTENTS';
        IFEND;

      = amc$file_limit =
        IF (file_attributes^ [i].file_limit < LOWERVALUE (amt$file_limit))
        { } OR (file_attributes^ [i].file_limit > UPPERVALUE (amt$file_limit))
              THEN
          text := 'FILE_LIMIT';
        IFEND;
      = amc$file_processor =
        clp$validate_name (file_attributes^ [i].file_processor,
              validated_attr_name, valid_name);
        IF NOT valid_name THEN
          text := 'FILE_PROCESSOR';
        IFEND;

      = amc$file_structure =
        clp$validate_name (file_attributes^ [i].file_structure,
              validated_attr_name, valid_name);
        IF NOT valid_name THEN
          text := 'FILE_STRUCTURE';
        IFEND;

      = amc$forced_write =
        IF (file_attributes^ [i].forced_write < LOWERVALUE (amt$forced_write))
        { } OR (file_attributes^ [i].forced_write > UPPERVALUE
              (amt$forced_write)) THEN
          text := 'FORCED_WRITE';
        IFEND;
      = amc$line_number =
        IF (file_attributes^ [i].line_number.length < LOWERVALUE
              (amt$line_number_length))
        { } OR (file_attributes^ [i].line_number.length > UPPERVALUE
              (amt$line_number_length))
        { } OR (file_attributes^ [i].line_number.location < LOWERVALUE
              (amt$line_number_location))
        { } OR (file_attributes^ [i].line_number.location > UPPERVALUE
              (amt$line_number_location)) THEN
          text := 'LINE_NUMBER';
        IFEND;
      = amc$loading_factor =
        IF (file_attributes^ [i].loading_factor <
            LOWERVALUE (amt$loading_factor)) OR
            (file_attributes^ [i].loading_factor >
            UPPERVALUE (amt$loading_factor)) THEN
          text := 'LOADING_FACTOR';
        IFEND;
      = amc$lock_expiration_time =
        IF (file_attributes^ [i].lock_expiration_time < LOWERVALUE
              (amt$lock_expiration_time))
            OR (file_attributes^ [i].lock_expiration_time > UPPERVALUE
              (amt$lock_expiration_time)) THEN
          text := 'LOCK_EXPIRATION_TIME';
        IFEND;
      = amc$logging_options =
        IF NOT (file_attributes^ [i].logging_options <= $amt$logging_options
             [amc$enable_parcels, amc$enable_media_recovery,
             amc$enable_request_recovery]) THEN
          text := 'LOGGING_OPTIONS';
        IFEND;
      = amc$log_residence =
        IF file_attributes^ [i].log_residence <> NIL THEN
          IF file_attributes^ [i].log_residence^ <> osc$null_name THEN
            clp$convert_string_to_file_ref (file_attributes^ [i].log_residence^,
              ignore_file, status);
            IF NOT status.normal THEN
              status.normal := TRUE; {improper status handled by text}
              text := 'LOG_RESIDENCE';
            IFEND;
          IFEND;
        IFEND;
      = amc$record_limit =
        IF (file_attributes^ [i].record_limit < LOWERVALUE (amt$record_limit))
        { } OR (file_attributes^ [i].record_limit > UPPERVALUE
              (amt$record_limit)) THEN
          text := 'RECORD_LIMIT';
        IFEND;
      = amc$ring_attributes =
        proposed_r1 := file_attributes^ [i].ring_attributes.r1;
        proposed_r2 := file_attributes^ [i].ring_attributes.r2;
        proposed_r3 := file_attributes^ [i].ring_attributes.r3;
        IF NOT ((proposed_r1 IN amv$valid_ring)
              { } AND (proposed_r2 IN amv$valid_ring)
              { } AND (proposed_r3 IN amv$valid_ring)
              { } AND (proposed_r1 <= proposed_r2)
              { } AND (proposed_r2 <= proposed_r3)
              { } AND (proposed_r3 <= 13)) THEN
          text := 'RING_ATTRIBUTES';
        ELSEIF attribute_validation_status.normal THEN
          IF proposed_r1 < avp$ring_min () THEN
            fsp$set_evaluated_file_abnormal (evaluated_file_reference,
                  ame$ring_validation_error,
                  amc$change_file_attributes_cmd, '', status);
            RETURN;
          IFEND;
        IFEND;
      = amc$statement_identifier =
        IF ((file_attributes^ [i].statement_identifier.length < LOWERVALUE
              (amt$statement_id_length)) OR (file_attributes^ [i].
              statement_identifier.length > UPPERVALUE
              (amt$statement_id_length)) OR (file_attributes^ [i].
              statement_identifier.location < LOWERVALUE
              (amt$statement_id_location)) OR (file_attributes^ [i].
              statement_identifier.location > UPPERVALUE
              (amt$statement_id_location))) THEN
          text := 'STATEMENT_IDENTIFIER';
        IFEND;
      = amc$user_info =
        ;
      ELSE
        clp$convert_integer_to_string (i, 10, FALSE, i_string, status);
        IF status.normal THEN
          fsp$set_evaluated_file_abnormal (evaluated_file_reference,
                ame$improper_file_attrib_key,
                amc$change_file_attributes_cmd, 'FILE_ATTRIBUTES', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                i_string.value (1, i_string.size), status);
          RETURN;
        IFEND;
      CASEND;

      IF text <> osc$null_name THEN
        IF attribute_validation_status.normal THEN
          fsp$set_evaluated_file_abnormal (evaluated_file_reference,
                ame$improper_file_attrib_value,
                amc$change_file_attributes_cmd, 'FILE_ATTRIBUTES',
                attribute_validation_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, text,
                attribute_validation_status);
        ELSE
          osp$append_status_parameter (',', text,
                 attribute_validation_status);
        IFEND;
        text := osc$null_name;
      IFEND;
    FOREND;
    IF NOT attribute_validation_status.normal THEN
      status := attribute_validation_status;
      RETURN;
    IFEND;

    fmp$change_file_attributes (file_attributes^, evaluated_file_reference, caller_id.ring,
          open_changed_file, status);

  PROCEND bap$change_file_attributes;

MODEND bam$file_structure_functions;
*DECK DECK=BAM$FORMAT_SEGMENT_CONDITION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  BASIC ACCESS METHOD : Format Segment Condition' ??
MODULE bam$format_segment_condition;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$access_validation_errors
*copyc ame$put_validation_errors
*copyc ame$ring_validation_errors
*copyc ame$get_program_actions
*copyc mmd$segment_access_condition
*copyc osc$processor_defined_registers
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc ost$name
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*copyc clp$get_fs_path_string
*copyc ocp$find_debug_address
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc pmp$validate_previous_save_area
*copyc tmp$find_ring_crossing_frame

*copyc bav$last_tft_entry
*copyc bav$tft_entry_assignment
*copyc bav$task_file_table

?? NEWTITLE := 'PROCEDURE [INLINE] append_address_to_message', EJECT ??

  PROCEDURE [INLINE] append_address_to_message
    (    address: ost$pva;
     VAR message {input, output} : ost$status);

    osp$append_status_integer (' ', address.ring, 16, FALSE, message);
    osp$append_status_integer (' ', address.seg, 16, FALSE, message);
    osp$append_status_integer (' ', address.offset, 16, FALSE, message);
  PROCEND append_address_to_message;
?? OLDTITLE ??

?? NEWTITLE := 'PROCEDURE resolve_p_address', EJECT ??

  PROCEDURE resolve_p_address
    (    condition_save_area: ^ost$stack_frame_save_area;
         untranslatable_pointer: ost$pva;
     VAR actual_p: ost$pva;
     VAR resolved_p: ost$pva);

    VAR
      nil_pva: [STATIC, READ, oss$job_paged_literal] ost$pva :=
            [osc$max_ring, osc$maximum_segment, -(osc$maximum_offset + 1)],
      sfsa: ^ost$stack_frame_save_area,
      runanywhere_sfsa: ^ost$stack_frame_save_area,
      x_frame: ^ost$stack_frame_save_area,
      system_error: boolean,
      p_register_i: integer,
      p_reg: ^ost$p_register,
      status: ost$status;


    status.normal := TRUE;

    sfsa := condition_save_area;
    actual_p.ring := sfsa^.minimum_save_area.p_register.pva.ring;
    actual_p.seg := sfsa^.minimum_save_area.p_register.pva.seg;
    actual_p.offset := sfsa^.minimum_save_area.p_register.pva.offset;

    p_register_i := #READ_REGISTER (osc$pr_p_reg);
    p_reg := #LOC (p_register_i);

    IF ((untranslatable_pointer <> nil_pva) AND (sfsa^.minimum_save_area.p_register.pva.ring <=
          osc$sj_ring_3) AND (untranslatable_pointer.ring > osc$sj_ring_3)) OR
          (sfsa^.minimum_save_area.p_register.pva.seg = p_reg^.pva.seg) THEN

{p_reg^.pva.seg is the runanywhere segment

      system_error := FALSE;

      WHILE NOT system_error AND (sfsa^.minimum_save_area.a2_previous_save_area <> NIL) AND
            (sfsa^.minimum_save_area.p_register.pva.ring <= osc$sj_ring_3) AND status.normal DO
        tmp$find_ring_crossing_frame (sfsa, x_frame, status);
        IF (x_frame^.minimum_save_area.a2_previous_save_area <> NIL) THEN
          sfsa := x_frame^.minimum_save_area.a2_previous_save_area;
        ELSE
          sfsa := condition_save_area;
          system_error := TRUE;
        IFEND;
      WHILEND;

      runanywhere_sfsa := sfsa;
      WHILE NOT system_error AND (sfsa^.minimum_save_area.a2_previous_save_area <> NIL) AND
            (sfsa^.minimum_save_area.p_register.pva.seg = p_reg^.pva.seg) AND status.normal DO
        pmp$validate_previous_save_area (sfsa, status);
        IF status.normal THEN
          IF (sfsa^.minimum_save_area.a2_previous_save_area^.minimum_save_area.a2_previous_save_area <> NIL)
                THEN
            sfsa := sfsa^.minimum_save_area.a2_previous_save_area;
          ELSE
            sfsa := runanywhere_sfsa;
            system_error := TRUE;
          IFEND;
        IFEND;
      WHILEND;

      resolved_p.ring := sfsa^.minimum_save_area.p_register.pva.ring;
      resolved_p.seg := sfsa^.minimum_save_area.p_register.pva.seg;
      IF system_error THEN
        resolved_p.offset := sfsa^.minimum_save_area.p_register.pva.offset;
      ELSE
        resolved_p.offset := sfsa^.minimum_save_area.p_register.pva.offset - 4;
      IFEND;
    ELSE
      resolved_p.ring := sfsa^.minimum_save_area.p_register.pva.ring;
      resolved_p.seg := sfsa^.minimum_save_area.p_register.pva.seg;
      resolved_p.offset := sfsa^.minimum_save_area.p_register.pva.offset;
    IFEND;

  PROCEND resolve_p_address;
?? OLDTITLE ??

?? NEWTITLE := 'PROCEDURE [XDCL, #GATE] bap$format_segment_condition', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$format_segment_condition
    (    identifier: string (2);
         segment_access_condition: mmt$segment_access_condition;
         save_area: ^ost$stack_frame_save_area;
         error_pva: ost$pva;
     VAR condition_status: ost$status);

{   Purpose:
{ The purpose of this procedure is to emit a meaningful message
{ when a hardware/software violation occurs during segment access. The
{ message can be made more meaningful by finding the local name associated
{ with the segment which has encountered the violation.

    VAR
      actual_p: ost$pva,
      file_instance: ^bat$task_file_entry,
      found: boolean,
      module_name: pmt$program_name,
      offset_in_section: ost$segment_offset,
      path: fst$path,
      path_size: fst$path_size,
      resolved_p: ost$pva,
      section_name: pmt$program_name,
      status: ost$status;


    condition_status.normal := TRUE;
    bap$find_open_file_via_segment (#SEGMENT (segment_access_condition.segment), file_instance, path,
          path_size, found);
    IF found THEN
      CASE segment_access_condition.identifier OF
      = mmc$sac_read_beyond_eoi =
        osp$set_status_abnormal (identifier, ame$input_after_eoi, '', condition_status);
      = mmc$sac_read_write_beyond_msl =
        osp$set_status_abnormal (identifier, ame$position_beyond_file_limit, '', condition_status);
      = mmc$sac_pf_space_limit_exceeded, mmc$sac_tf_space_limit_exceeded =
        osp$set_status_abnormal (identifier, ame$file_space_limit_exceeded, '', condition_status);
      = mmc$sac_key_lock_violation, mmc$sac_ring_violation =
        osp$set_status_abnormal (identifier, ame$ring_validation_error, '', condition_status);
      = mmc$sac_segment_access_error =
        osp$set_status_abnormal (identifier, ame$improper_segment_access, '', condition_status);
      = mmc$sac_io_read_error =
        osp$set_status_abnormal (identifier, ame$unrecovered_read_error, '', condition_status);
      = mmc$sac_no_append_permission =
        osp$set_status_abnormal (identifier, ame$position_beyond_eoi, '', condition_status);
      = mmc$sac_file_server_terminated =
        osp$set_status_abnormal (identifier, ame$file_server_terminated, '', condition_status);
      ELSE
        RETURN;
      CASEND;
      osp$append_status_file (osc$status_parameter_delimiter, path (1, path_size), condition_status);
      CASE segment_access_condition.identifier OF
      = mmc$sac_pf_space_limit_exceeded =
        osp$append_status_parameter (osc$status_parameter_delimiter, 'Permanent', condition_status);
      = mmc$sac_tf_space_limit_exceeded =
        osp$append_status_parameter (osc$status_parameter_delimiter, 'Temporary', condition_status);
      ELSE
      CASEND;
      IF file_instance^.access_level = amc$record THEN
        resolve_p_address (save_area, error_pva, actual_p, resolved_p);
        ocp$find_debug_address (resolved_p.seg, resolved_p.offset, found, module_name, section_name,
              offset_in_section, status);
        IF status.normal AND found THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, section_name, condition_status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter, 'record access - P =',
                condition_status);
          append_address_to_message (actual_p, condition_status);
          IF resolved_p <> actual_p THEN
            osp$append_status_parameter (' ', 'CALLERS P =', condition_status);
            append_address_to_message (resolved_p, condition_status);
          IFEND;
        IFEND;
        IF file_instance^.rollback_procedure <> NIL THEN
          file_instance^.rollback_procedure^ (condition_status);
        IFEND;
      ELSEIF file_instance^.access_level = amc$segment THEN
        resolve_p_address (save_area, error_pva, actual_p, resolved_p);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'segment access - PVA =',
              condition_status);
        append_address_to_message (error_pva, condition_status);
        osp$append_status_parameter (' ', 'P =', condition_status);
        append_address_to_message (actual_p, condition_status);
        IF resolved_p <> actual_p THEN
          osp$append_status_parameter (' ', 'USERS P =', condition_status);
          append_address_to_message (resolved_p, condition_status);
        IFEND;
      IFEND; {file_instance^.access_level = amc$record}
    IFEND; {found}

  PROCEND bap$format_segment_condition;
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE [XDCL, #GATE] bap$find_open_file_via_segment', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$find_open_file_via_segment
    (    segment_number: ost$segment;
     VAR file_instance: ^bat$task_file_entry;
     VAR path: fst$path;
     VAR path_size: fst$path_size;
     VAR entry_found: boolean);

    VAR
      ignore_status: ost$status,
      ignore_path_handle: fmt$path_handle,
      index: bat$tft_limit;

    entry_found := FALSE;
    path := ' ';
    path_size := 1;

    IF (bav$task_file_table <> NIL) AND (#SEGMENT (bav$task_file_table) <> segment_number) THEN
      FOR index := 1 TO bav$last_tft_entry DO
        IF bav$tft_entry_assignment^ (index, 1) = fmc$entry_assigned THEN
          file_instance := ^bav$task_file_table^ [index];
          IF (file_instance^.device_class = rmc$mass_storage_device) AND (file_instance^.file_pva <> NIL) AND
                (#SEGMENT (file_instance^.file_pva) = segment_number) THEN
            entry_found := TRUE;
            clp$get_fs_path_string (file_instance^.local_file_name, path, path_size, ignore_path_handle,
                  ignore_status);
            RETURN;
          IFEND; {file_instance^.device_class = rmc$mass_storage_device}
        IFEND; {bav$tft_entry_assignment^ (index, 1) = fmc$entry_assigned}
      FOREND;
    IFEND;

  PROCEND bap$find_open_file_via_segment;
?? OLDTITLE ??

MODEND bam$format_segment_condition;


*DECK DECK=BAM$GET_$LOCAL_OBJECT_INFO EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Basic Access Methods : Get Object Information' ??
MODULE bam$get_$local_object_info;

{ PURPOSE:
{   This module contains the 23D interface for getting object_information for
{   a temporary file.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$caller_identifier
*copyc ost$name
*copyc pfe$internal_error_conditions
?? POP ??
*copyc fmp$get_$local_object_info
*copyc osp$set_status_condition

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$get_$local_object_info', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$get_$local_object_info
    (    evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
     VAR object_information_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      object_info_p: ^fst$goi_object_information,
      password_selector: pft$password_selector;

    status.normal := TRUE;
    #CALLER_ID (caller_id);

    password_selector.password_specified := pfc$default_password_option;

    NEXT object_info_p IN object_information_p;
    IF object_info_p = NIL THEN
      osp$set_status_condition (pfe$info_full, status);
      RETURN;
    ELSE
      object_info_p^.set_name := osc$null_name;
      object_info_p^.resolved_path := NIL;
      object_info_p^.object := NIL;
    IFEND;

    fmp$get_$local_object_info (evaluated_file_reference, information_request, password_selector,
          caller_id.ring, object_info_p, object_information_p, status);

  PROCEND bap$get_$local_object_info;
MODEND bam$get_$local_object_info;

*DECK DECK=BAM$GET_DEFAULT_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??
MODULE bam$get_default_attributes;
?? NEWTITLE := 'MODULE bam$get_default_attributes' ??
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc bat$static_label_attributes
*copyc fst$catalog_information
*copyc fst$cycle_attribute_sources
*copyc fst$cycle_attribute_values
*copyc fst$retention
*copyc ost$status
?? POP ??
*copyc fmv$default_file_attributes
*copyc fmv$system_file_attributes
*copyc fsp$convert_to_new_contents

?? TITLE := 'PROCEDURE bap$get_default_attributes' ??

*copyc bah$get_default_attributes

?? EJECT ??

  PROCEDURE [XDCL, #GATE] bap$get_default_attributes (catalog_information: ^fst$catalog_information;
        cycle_attribute_sources: ^fst$cycle_attribute_sources;
        cycle_attribute_values: ^fst$cycle_attribute_values;
    VAR status: ost$status);

    VAR
      default_attributes: bat$static_label_attributes,
      ignore_truncation: boolean;

    status.normal := TRUE;

    IF fmv$default_file_attributes = NIL THEN
       default_attributes := fmv$system_file_attributes.static_label;
    ELSE
       default_attributes := fmv$default_file_attributes^;
    IFEND;

    IF cycle_attribute_values <> NIL THEN
      cycle_attribute_values^.average_record_length := default_attributes.average_record_length;
      cycle_attribute_values^.block_type := default_attributes.block_type;
      cycle_attribute_values^.character_conversion := default_attributes.character_conversion;
      cycle_attribute_values^.collate_table_name.entry_point := default_attributes.collate_table_name;
      cycle_attribute_values^.collate_table_name.object_library := osc$null_name;
      cycle_attribute_values^.compression_procedure_name.entry_point := fmv$system_file_attributes.
            static_label.compression_procedure_name.name;
      cycle_attribute_values^.compression_procedure_name.object_library := fmv$system_file_attributes.
            static_label.compression_procedure_name.object_library;
      cycle_attribute_values^.data_padding := default_attributes.data_padding;
      cycle_attribute_values^.dynamic_home_block_space := default_attributes.dynamic_home_block_space;
      cycle_attribute_values^.embedded_key := default_attributes.embedded_key;
      cycle_attribute_values^.estimated_record_count := default_attributes.estimated_record_count;
      cycle_attribute_values^.file_access_procedure_name.entry_point :=
            default_attributes.file_access_procedure;
      cycle_attribute_values^.file_access_procedure_name.object_library := osc$null_name;
      fsp$convert_to_new_contents (default_attributes.file_contents,
            default_attributes.file_structure, cycle_attribute_values^.file_contents,
            ignore_truncation);
      cycle_attribute_values^.file_contents := default_attributes.file_contents;
      cycle_attribute_values^.file_processor := default_attributes.file_processor;
      cycle_attribute_values^.file_label_type := default_attributes.label_type;
      cycle_attribute_values^.file_organization := default_attributes.file_organization;
      cycle_attribute_values^.forced_write := default_attributes.forced_write;
      cycle_attribute_values^.hashing_procedure_name.entry_point := default_attributes.
            hashing_procedure_name.name;
      cycle_attribute_values^.hashing_procedure_name.object_library := fmv$system_file_attributes.
            static_label.hashing_procedure_name.object_library;
      cycle_attribute_values^.index_levels := default_attributes.index_levels;
      cycle_attribute_values^.index_padding := default_attributes.index_padding;
      cycle_attribute_values^.initial_home_block_count := default_attributes.initial_home_block_count;
      cycle_attribute_values^.internal_code := default_attributes.internal_code;
      cycle_attribute_values^.key_length := default_attributes.key_length;
      cycle_attribute_values^.key_position := default_attributes.key_position;
      cycle_attribute_values^.key_type := default_attributes.key_type;
      cycle_attribute_values^.line_number := default_attributes.line_number;
      cycle_attribute_values^.loading_factor := default_attributes.loading_factor;
      cycle_attribute_values^.lock_expiration_time := default_attributes.lock_expiration_time;
      cycle_attribute_values^.log_residence := default_attributes.log_residence;
      cycle_attribute_values^.logging_options := default_attributes.logging_options;
      cycle_attribute_values^.max_block_length := default_attributes.max_block_length;
      cycle_attribute_values^.max_record_length := default_attributes.max_record_length;
      cycle_attribute_values^.min_block_length := default_attributes.min_block_length;
      cycle_attribute_values^.min_record_length := default_attributes.min_record_length;
      cycle_attribute_values^.padding_character := default_attributes.padding_character;
      cycle_attribute_values^.page_format := default_attributes.page_format;
      cycle_attribute_values^.page_length := default_attributes.page_length;
      cycle_attribute_values^.page_width := default_attributes.page_width;
      cycle_attribute_values^.record_delimiting_character := default_attributes.record_delimiting_character;
      cycle_attribute_values^.record_limit := default_attributes.record_limit;
      cycle_attribute_values^.record_type := default_attributes.record_type;
      cycle_attribute_values^.records_per_block := default_attributes.records_per_block;
      cycle_attribute_values^.statement_identifier := default_attributes.statement_identifier;
      cycle_attribute_values^.user_information := default_attributes.user_info;
      cycle_attribute_values^.vertical_print_density := default_attributes.vertical_print_density;
    IFEND; {attribute values requested}

    IF cycle_attribute_sources <> NIL THEN
      cycle_attribute_sources^.average_record_length := default_attributes.average_record_length_source;
      cycle_attribute_sources^.block_type := default_attributes.block_type_source;
      cycle_attribute_sources^.character_conversion := default_attributes.character_conversion_source;
      cycle_attribute_sources^.collate_table_name := default_attributes.collate_table_name_source;
      cycle_attribute_sources^.compression_procedure_name := default_attributes.compression_proc_name_source;
      cycle_attribute_sources^.data_padding := default_attributes.data_padding_source;
      cycle_attribute_sources^.dynamic_home_block_space := default_attributes.dynamic_home_block_space_source;
      cycle_attribute_sources^.embedded_key := default_attributes.embedded_key_source;
      cycle_attribute_sources^.estimated_record_count := default_attributes.estimated_record_count_source;
      cycle_attribute_sources^.file_access_procedure_name := default_attributes.file_access_procedure_source;
      cycle_attribute_sources^.file_contents := default_attributes.file_contents_source;
      cycle_attribute_sources^.file_processor := default_attributes.file_processor_source;
      cycle_attribute_sources^.file_label_type := default_attributes.label_type_source;
      cycle_attribute_sources^.file_organization := default_attributes.file_organization_source;
      cycle_attribute_sources^.forced_write := default_attributes.forced_write_source;
      cycle_attribute_sources^.hashing_procedure_name := default_attributes.hashing_procedure_name_source;
      cycle_attribute_sources^.index_levels := default_attributes.index_levels_source;
      cycle_attribute_sources^.index_padding := default_attributes.index_padding_source;
      cycle_attribute_sources^.initial_home_block_count := default_attributes.initial_home_block_count_source;
      cycle_attribute_sources^.internal_code := default_attributes.internal_code_source;
      cycle_attribute_sources^.key_length := default_attributes.key_length_source;
      cycle_attribute_sources^.key_position := default_attributes.key_position_source;
      cycle_attribute_sources^.key_type := default_attributes.key_type_source;
      cycle_attribute_sources^.line_number := default_attributes.line_number_source;
      cycle_attribute_sources^.loading_factor := default_attributes.loading_factor_source;
      cycle_attribute_sources^.lock_expiration_time := default_attributes.lock_expiration_time_source;
      cycle_attribute_sources^.log_residence := default_attributes.log_residence_source;
      cycle_attribute_sources^.logging_options := default_attributes.logging_options_source;
      cycle_attribute_sources^.max_block_length := default_attributes.max_block_length_source;
      cycle_attribute_sources^.max_record_length := default_attributes.max_record_length_source;
      cycle_attribute_sources^.min_block_length := default_attributes.min_block_length_source;
      cycle_attribute_sources^.min_record_length := default_attributes.min_record_length_source;
      cycle_attribute_sources^.padding_character := default_attributes.padding_character_source;
      cycle_attribute_sources^.page_format := default_attributes.page_format_source;
      cycle_attribute_sources^.page_length := default_attributes.page_length_source;
      cycle_attribute_sources^.page_width := default_attributes.page_width_source;
      cycle_attribute_sources^.record_delimiting_character :=
            default_attributes.record_delimiting_char_source;
      cycle_attribute_sources^.record_limit := default_attributes.record_limit_source;
      cycle_attribute_sources^.record_type := default_attributes.record_type_source;
      cycle_attribute_sources^.records_per_block := default_attributes.records_per_block_source;
      cycle_attribute_sources^.statement_identifier := default_attributes.statement_identifier_source;
      cycle_attribute_sources^.user_information := default_attributes.user_info_source;
      cycle_attribute_sources^.vertical_print_density := default_attributes.vertical_print_density_source;
    IFEND; {attribute_sources_requested}

    IF catalog_information <> NIL THEN
      catalog_information^.cycle_registration.erase_at_deletion := default_attributes.clear_space;
      catalog_information^.cycle_registration.size_limit := default_attributes.file_limit;
      catalog_information^.cycle_registration.preset_value := default_attributes.preset_value;
      catalog_information^.cycle_registration.ring_attributes := default_attributes.ring_attributes;
    IFEND; {catalog_information_requested}

  PROCEND bap$get_default_attributes;

?? TITLE := 'PROCEDURE bap$get_default_file_attribs' ??

  PROCEDURE [XDCL, #GATE] bap$get_default_file_attribs (
    VAR default_attributes: bat$static_label_attributes;
    VAR default_new_retention_specified: boolean;
    VAR default_new_retention: fst$retention;
    VAR status: ost$status);

    status.normal := TRUE;

    IF fmv$default_file_attributes = NIL THEN
       default_attributes := fmv$system_file_attributes.static_label;
    ELSE
       default_attributes := fmv$default_file_attributes^;
    IFEND;

    IF fmv$default_new_retention = NIL THEN
      default_new_retention_specified := FALSE;
    ELSE
      default_new_retention_specified := TRUE;
      default_new_retention := fmv$default_new_retention^;
    IFEND;

  PROCEND bap$get_default_file_attribs;

MODEND bam$get_default_attributes;
*DECK DECK=BAM$GET_DEVICE_CLASS EXPAND=TRUE
*copyc osd$default_pragmats
?? TITLE := '  NOS/VE : Get Device Class' ??
MODULE bam$get_device_class;
{
{ PURPOSE:  This module contains the 23d interface for getting the device class
{           to which a file is assigned.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc fmp$get_device_class

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$get_device_class', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$get_device_class
    (    path_handle: fmt$path_handle;
     VAR device_assigned: boolean;
     VAR device_class: rmt$device_class;
     VAR status: ost$status);

    status.normal := TRUE;

    fmp$get_device_class (path_handle, device_assigned, device_class, status);

  PROCEND bap$get_device_class;
MODEND bam$get_device_class;

*DECK DECK=BAM$GET_OPEN_INFORMATION EXPAND=TRUE
?? RIGHT := 110 ??
MODULE bam$get_open_information;
?? NEWTITLE := 'MODULE bam$get_open_information' ??
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fmp$get_open_information
?? POP ??

?? NEWTITLE := 'PROCEDURE bap$get_open_information' ??
?? EJECT ??
*copyc bah$get_open_information
*copyc amt$file_identifier
*copyc osd$integer_limits
*copyc ost$status


?? EJECT ??

  PROCEDURE [XDCL, #GATE] bap$get_open_information (file_identifier: amt$file_identifier;
        attachment_information: ^SEQ ( * );
        catalog_information: ^SEQ ( * );
        cycle_attribute_sources: ^SEQ ( * );
        cycle_attribute_values: ^SEQ ( * );
        instance_information: ^SEQ ( * );
        resolved_file_reference: ^SEQ ( * );
        user_defined_attributes: ^SEQ ( * );
    VAR user_defined_attribute_size: ost$non_negative_integers;
    VAR status: ost$status);


    fmp$get_open_information (file_identifier, attachment_information, catalog_information,
          cycle_attribute_sources, cycle_attribute_values, instance_information, resolved_file_reference,
          user_defined_attributes, user_defined_attribute_size, status);

  PROCEND bap$get_open_information;
?? OLDTITLE ??

MODEND bam$get_open_information;
*DECK DECK=BAM$GET_PHN_VIA_FILE_ID EXPAND=TRUE
*copyc osd$default_pragmats
MODULE bam$get_phn_via_file_id;

?? PUSH (LISTEXT := ON) ??
*copyc ame$improper_file_id
*copyc amt$local_file_name
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal

  PROCEDURE [XDCL, #GATE] bap$get_phn_via_file_id (file_id: amt$file_identifier;
    VAR local_file_name: amt$local_file_name;
    VAR status: ost$status);


    VAR
      file_instance: ^bat$task_file_entry,
      file_id_is_valid: boolean;

    status.normal := TRUE;

    bap$validate_file_identifier (file_id, file_instance, file_id_is_valid);

    IF file_id_is_valid THEN
      local_file_name := file_instance^.local_file_name;
    ELSE
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
        'bap$get_phn_via_file_id ', status);
    IFEND;

  PROCEND bap$get_phn_via_file_id;

MODEND bam$get_phn_via_file_id;







*DECK DECK=BAM$GET_TAPE_LABEL_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Basic Access Method : Tape Label Attributes Retrieval' ??
MODULE bam$get_tape_label_attributes;

{ PURPOSE:
{   This module contains the 23D interface for getting the tape label
{   attributes.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fst$attachment_options
*copyc fst$evaluated_file_reference
*copyc fst$tape_attribute_source
*copyc fst$tla_returned_attributes
*copyc ost$caller_identifier
*copyc ost$status
?? POP ??
*copyc avp$removable_media_admin
*copyc fmp$get_tape_label_attributes
*copyc fmp$get_tape_label_cmd_attrib
*copyc osp$verify_system_privilege

?? TITLE := 'bap$get_tape_label_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$get_tape_label_attributes
    (    evaluated_file_reference: fst$evaluated_file_reference;
         source: fst$tape_attribute_source;
     VAR attributes {input, output} : fst$attachment_options;
     VAR returned_attributes: fst$tla_returned_attributes;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      rma_or_ring_privileged: boolean;

    status.normal := TRUE;

    osp$verify_system_privilege;
    #CALLER_ID (caller_id);

    rma_or_ring_privileged := avp$removable_media_admin () OR (caller_id.ring <= 3);

    CASE source OF
    = fsc$tla_last_ansi_file_accessed, fsc$tla_next_position =
      fmp$get_tape_label_attributes (evaluated_file_reference, source, rma_or_ring_privileged, attributes,
            returned_attributes, status);
    = fsc$tla_explicit_specification =
      fmp$get_tape_label_cmd_attrib (evaluated_file_reference, rma_or_ring_privileged, attributes,
            returned_attributes, status);
    ELSE
    ;
    CASEND;

  PROCEND bap$get_tape_label_attributes;
MODEND bam$get_tape_label_attributes;
*DECK DECK=BAM$LOADED_RING_CLEANUP EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE :  BASIC ACCESS METHOD : Loaded ring cleanup' ??
MODULE bam$loaded_ring_cleanup;
?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$put_program_actions
*copyc amt$fap_declarations
*copyc amt$file_byte_address
*copyc amt$file_identifier
*copyc oss$job_paged_literal
*copyc ost$status
*copyc pmd$system_log_interface
?? POP ??
*copyc amp$set_file_instance_abnormal
*copyc bap$mark_fap_layer_closed
*copyc bap$mark_fap_layer_open
*copyc bap$set_close_allowed
*copyc bap$set_task_cleanup_initiated
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$establish_condition_handler
*copyc osp$file_access_condition
*copyc osp$generate_log_message
*copyc osp$set_status_from_condition
*copyc pmp$continue_to_cause

*copyc bav$last_tft_entry
*copyc bav$task_cleanup_initiated
*copyc bav$task_file_table
*copyc bav$tft_entry_assignment
*copyc clv$processing_phase
*copyc osv$initial_exception_context

?? TITLE := 'Global Declarations Declared by this Module', EJECT ??

  VAR
    close_call_block: [READ, oss$job_paged_literal] amt$call_block := [amc$close_req];

{   Purpose:
{    The purpose of this module is to permit each fap associated
{    with an instance of a file to perform its close processing
{    during task termination.
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE [XDCL] bap$loaded_ring_cleanup', EJECT ??

  PROCEDURE [XDCL] bap$loaded_ring_cleanup;

    VAR
      fap_status: ost$status,
      ignore_status: ost$status,
      fid_ordinal: amt$file_id_ordinal,
      pass: 1 .. 2;

?? NEWTITLE := 'PROCEDURE handle_condition', EJECT ??

    PROCEDURE handle_condition
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      status.normal := TRUE;

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =

{ Purpose:
{   If a fap is called during loaded ring cleanup, it is desirable
{   to save the abnormal status, if any, generated by the fap.

        osp$set_status_from_condition (amc$access_method_id, condition, save_area, fap_status, ignore_status);

        EXIT bap$loaded_ring_cleanup;

      = pmc$block_exit_processing =

{ Purpose:
{      1.Ensure that all faps in this ring are called.
{         a.Protects against faps which abort during close processing.
{         b.Protects against faps which call pmp$exit or pmp$abort
{      2.Causes all conditions generated by faps during close processing
{         to be logged.

        status := fap_status;
        bap$loaded_ring_cleanup;

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

    PROCEND handle_condition;

?? OLDTITLE, EJECT ??

    fap_status.normal := TRUE;
    IF NOT bav$task_cleanup_initiated THEN
      bap$set_task_cleanup_initiated;
    IFEND;

    IF bav$task_file_table = NIL THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^handle_condition, TRUE);

    FOR pass := 1 TO 2 DO
      FOR fid_ordinal := 1 TO bav$last_tft_entry DO
        IF (bav$tft_entry_assignment^ (fid_ordinal, 1) = fmc$entry_assigned) AND
              (bav$task_file_table^ [fid_ordinal].close_allowed OR (pass = 2)) THEN
          close_fap_layers (fid_ordinal, pass);
        IFEND;
      FOREND;
    FOREND;

    osp$disestablish_cond_handler;

  PROCEND bap$loaded_ring_cleanup;
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE [XDCL] bap$monitor_loaded_ring_cleanup', EJECT ??

  PROCEDURE [XDCL] bap$monitor_loaded_ring_cleanup;

    VAR
      fap_status: ost$status,
      ignore_status: ost$status,
      fid_ordinal: amt$file_id_ordinal;

?? NEWTITLE := 'PROCEDURE handle_condition', EJECT ??

    PROCEDURE handle_condition
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      status.normal := TRUE;

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =

{ Purpose:
{   If a fap is called during loaded ring cleanup, it is desirable
{   to save the abnormal status, if any, generated by the fap.

        osp$set_status_from_condition (amc$access_method_id, condition, save_area, fap_status, ignore_status);

        EXIT bap$monitor_loaded_ring_cleanup;

      = pmc$block_exit_processing =

{ Purpose:
{      1.Ensure that all faps in this ring are called.
{         a.Protects against faps which abort during close processing.
{         b.Protects against faps which call pmp$exit or pmp$abort
{      2.Causes all conditions generated by faps during close processing
{         to be logged.

        status := fap_status;
        bap$monitor_loaded_ring_cleanup;

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

    PROCEND handle_condition;
?? OLDTITLE, EJECT ??

    fap_status.normal := TRUE;

    IF bav$task_file_table = NIL THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^handle_condition, TRUE);

{ close_allowed is set to FALSE for targets of connected files, all targets are closed in epilog processing.
    FOR fid_ordinal := 1 TO bav$last_tft_entry DO
      IF (bav$tft_entry_assignment^ (fid_ordinal, 1) = fmc$entry_assigned) AND
            (bav$task_file_table^ [fid_ordinal].close_allowed) AND
            ((bav$task_file_table^ [fid_ordinal].module_dynamically_loaded) OR
            (bav$task_file_table^ [fid_ordinal].device_class = rmc$magnetic_tape_device)) THEN
        close_fap_layers (fid_ordinal, {pass=} 2); {pass=2 implies wait on volume down}
      IFEND;
    FOREND;

    osp$disestablish_cond_handler;

  PROCEND bap$monitor_loaded_ring_cleanup;
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE close_fap_layers', EJECT ??

  PROCEDURE close_fap_layers
    (    fid_ordinal: amt$file_id_ordinal;
         pass: 1 .. 2);

    VAR
      bam_status: ost$status,
      execution_ring: ost$ring,
      file_identifier: amt$file_identifier,
      ignore_status: ost$status,
      layer: ^bat$fap_descriptor,
      layer_number: amt$fap_layer_number,
      tft_entry: ^bat$task_file_entry;

?? NEWTITLE := 'PROCEDURE [INLINE] close_layer', EJECT ??

    PROCEDURE [INLINE] close_layer;

    VAR
      context: ^ost$ecp_exception_context;

      PUSH context;
      context^ := osv$initial_exception_context;

      IF (NOT layer^.layer_closed) AND (layer^.loaded_ring = execution_ring) AND
            (layer^.access_method <> NIL) THEN
        terminate_file (file_identifier, tft_entry^, layer^, layer_number, bam_status);
        IF pass = 2 THEN
          IF osp$file_access_condition (bam_status) THEN
            context^.file.selector := osc$ecp_file_identifier;
            context^.file.file_identifier := file_identifier;

            REPEAT
              context^.condition_status := bam_status;
              osp$enforce_exception_policies (context^);
              bam_status := context^.condition_status;
              IF context^.wait THEN
                terminate_file (file_identifier, tft_entry^, layer^, layer_number,bam_status);
              IFEND;
           UNTIL bam_status.normal OR (NOT osp$file_access_condition (bam_status)) OR (NOT context^.wait);
          IFEND;
        IFEND;
        IF NOT osp$file_access_condition (bam_status) THEN
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], bam_status,
                ignore_status);
        IFEND;
        IF (NOT osp$file_access_condition (bam_status)) OR (pass=2) THEN
          bap$mark_fap_layer_closed (file_identifier, layer_number, bam_status);
          IF bam_status.normal THEN
            IF (pass = 2) AND (NOT tft_entry^.close_allowed) THEN
              bap$set_close_allowed (file_identifier);
            IFEND;
            layer^.access_method^ (file_identifier, close_call_block, layer_number, bam_status);
            IF pass = 2 THEN
              IF osp$file_access_condition (bam_status) THEN
                context^.file.selector := osc$ecp_file_identifier;
                context^.file.file_identifier := file_identifier;

                REPEAT
                  context^.condition_status := bam_status;
                  osp$enforce_exception_policies (context^);
                  bam_status := context^.condition_status;
                  IF context^.wait THEN
                    layer^.access_method^ (file_identifier, close_call_block, layer_number, bam_status);
                  IFEND;
                UNTIL bam_status.normal OR (NOT osp$file_access_condition (bam_status)) OR
                      (NOT context^.wait);
              IFEND;
            ELSEIF osp$file_access_condition (bam_status) THEN
              bap$mark_fap_layer_open (file_identifier, layer_number, bam_status);
            IFEND;
          IFEND;
          IF NOT bam_status.normal THEN
            IF bam_status.condition <> ame$unrecovered_write_error THEN
              osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], bam_status,
                    ignore_status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;

    PROCEND close_layer;
?? OLDTITLE, EJECT ??

    execution_ring := #RING (^layer_number);
    tft_entry := ^bav$task_file_table^ [fid_ordinal];
    file_identifier.ordinal := fid_ordinal;
    file_identifier.sequence := tft_entry^.sequence_number;
    IF tft_entry^.fap_control_information.fap_array = NIL THEN
      layer := ^tft_entry^.fap_control_information.first_fap;
      layer_number := 0;
      close_layer;
    ELSE
      FOR layer_number := 0 TO UPPERBOUND (tft_entry^.fap_control_information.fap_array^) DO
        layer := ^tft_entry^.fap_control_information.fap_array^ [layer_number];
        close_layer;
      FOREND;
    IFEND;

  PROCEND close_fap_layers;

?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE [INLINE] terminate_file', EJECT ??

  PROCEDURE [INLINE] terminate_file
    (    file_identifier: amt$file_identifier;
         file_instance: bat$task_file_entry;
         layer: bat$fap_descriptor;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);


    VAR
      call_block: amt$call_block,
      dummy_area: cell,
      ignore_byte_address: amt$file_byte_address;

    status.normal := TRUE;

    CASE file_instance.instance_attributes.static_label.file_organization OF
    = amc$sequential, amc$byte_addressable =
      IF (file_instance.private_read_information = NIL) AND
            (file_instance.global_file_information^.positioning_info.record_info.current_byte_address =
            file_instance.global_file_information^.eoi_byte_address) AND
            (file_instance.global_file_information^.positioning_info.record_info.file_position =
            amc$mid_record) AND (file_instance.global_file_information^.last_access_operation =
            amc$put_partial_req) THEN

{ terminate the file.

        call_block.operation := amc$put_partial_req;
        call_block.putp.working_storage_area := ^dummy_area;
        call_block.putp.working_storage_length := 0;
        call_block.putp.byte_address := ^ignore_byte_address;
        call_block.putp.term_option := amc$terminate;
        layer.access_method^ (file_identifier, call_block, layer_number, status);
      IFEND;
    ELSE
    CASEND;

  PROCEND terminate_file;
?? OLDTITLE ??

MODEND bam$loaded_ring_cleanup;
*DECK DECK=BAM$LOG_DEVICE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Basic Access Method : File Access Procedure for Logs' ??

MODULE bam$log_device;

{
{ PURPOSE:
{   This module contains the procedure (fap) that provides file access to
{   ascii and binary logs.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$access_validation_errors
*copyc ame$get_program_actions
*copyc ame$improper_file_id
*copyc ame$open_validation_errors
*copyc ame$put_validation_errors
*copyc ame$skip_program_actions
*copyc ame$skip_validation_errors
*copyc ame$open_validation_errors
*copyc ame$unimplemented_request
*copyc amt$fap_declarations
*copyc amt$file_identifier
*copyc bak$bap_procedure_keypoints
*copyc cyd$string
*copyc ose$heap_full_exceptions
*copyc ost$caller_identifier
*copyc ost$status
*copyc pme$logging_exceptions
?? POP ??
*copyc amp$set_file_instance_abnormal
*copyc amp$validate_caller_privilege
*copyc bap$close
*copyc bap$fetch
*copyc bap$fetch_access_information
*copyc bap$store
*copyc bav$task_file_table
*copyc clv$critical_log_path_handle
*copyc clv$log_name_path_handles
*copyc fmp$get_label_attributes
*copyc i#build_adaptable_seq_pointer
*copyc i#current_sequence_position
*copyc lgp$get_critical_log_read_info
*copyc lgp$get_critical_previous_size
*copyc lgp$get_entry_from_critical_log
*copyc lgp$get_entry_from_global_log
*copyc lgp$get_entry_from_local_log
*copyc lgp$get_global_log_read_info
*copyc lgp$get_global_previous_size
*copyc lgp$get_local_log_read_info
*copyc lgp$get_local_previous_size
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc osv$task_private_heap
*copyc pmp$log_ascii

?? TITLE := 'bap$log_device', EJECT ??
*copy bah$log_device

  PROCEDURE [XDCL, #GATE] bap$log_device (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    VAR
      local_file_name: amt$local_file_name,
      caller_id: ost$caller_identifier,
      critical_window_log: boolean,
      ignore_structure_pointer: ^cell,
      local_status: ost$status,
      ignore_status: ost$status,
      log_ordinal: pmt$logs,
      log_entry: ^bat$log_entry,
      log_cycle: lgt$log_cycle,
      log_address: ^SEQ ( * ),
      file_instance: ^bat$task_file_entry,
      file_position: amt$file_position,
      current_byte_address: amt$file_byte_address,
      text_ptr: ^string (cyc$max_string_size),
      text_size: cyt$string_size,
      static_label: bat$static_label_attributes,
      previous_length: lgt$log_entry_size,
      current_length: lgt$log_entry_size;

?? NEWTITLE := 'flush', EJECT ??
{
{ PURPOSE:
{   This procedure writes a record to an ascii log.
{   Before the write, the bor_address is established.
{   After the write, record_length, file_position (local and global),
{   current_byte_address (local and global), and eoi_byte_address
{   (local and global) are established.
{

    PROCEDURE [INLINE] flush;

      file_instance^.global_file_information^.positioning_info.record_info.
            bor_address := file_instance^.global_file_information^.
            positioning_info.record_info.current_byte_address;
      IF NOT critical_window_log THEN
        pmp$log_ascii (log_entry^.value (1, log_entry^.size), $pmt$ascii_logset [log_ordinal],
              pmc$msg_origin_program, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      file_instance^.global_file_information^.positioning_info.record_info.
            record_length := log_entry^.size;
      file_instance^.global_file_information^.positioning_info.record_info.
            file_position := amc$eor;
      file_position := amc$eor;
      IF critical_window_log THEN
        lgp$get_critical_log_read_info (0, log_cycle, log_address,
              current_byte_address, local_status);
      ELSEIF log_ordinal IN - $pmt$global_logset [] THEN
        lgp$get_global_log_read_info (log_ordinal, 0, log_cycle, log_address,
              current_byte_address, local_status);
      ELSE
        lgp$get_local_log_read_info (log_ordinal, 0, log_cycle, log_address,
              current_byte_address, local_status);
      IFEND;
      IF NOT local_status.normal THEN
        RETURN;
      IFEND;
      file_instance^.global_file_information^.positioning_info.record_info.
            current_byte_address := current_byte_address;
      file_instance^.global_file_information^.eoi_byte_address := current_byte_address;
      log_entry^.size := 0;

    PROCEND flush;
?? TITLE := 'get', EJECT ??
{
{ PURPOSE:
{   This procedure reads a record from a log.
{   Bor_address, current_byte_address (local and global), file_position
{   (local and global), record_length, and eoi_byte_address (local and
{   global - if eoi encountered) are established.
{

    PROCEDURE [INLINE] get (working_storage_area: ^cell;
          working_storage_length: amt$working_storage_length);

      VAR
        bor_address: amt$file_byte_address;

      text_ptr := working_storage_area;
      IF working_storage_length <= cyc$max_string_size THEN
        text_size := working_storage_length;
      ELSE
        text_size := cyc$max_string_size;
      IFEND;

      bor_address := i#current_sequence_position (file_instance^.log_address);

      IF critical_window_log THEN
        lgp$get_entry_from_critical_log (file_instance^.log_cycle, file_instance^.log_address,
              current_length, #SEQ(text_ptr^ (1, text_size))^, local_status);
        WHILE (NOT local_status.normal) AND (local_status.condition = lge$log_cycles_do_not_match) DO
          rewind;
          IF local_status.normal THEN
            lgp$get_entry_from_critical_log (file_instance^.log_cycle, file_instance^.log_address,
                  current_length, #SEQ (text_ptr^ (1, text_size))^, local_status);
          IFEND;
        WHILEND;
      ELSEIF log_ordinal IN - $pmt$global_logset [] THEN
        lgp$get_entry_from_global_log (log_ordinal, file_instance^.log_cycle, file_instance^.log_address,
              current_length, #SEQ(text_ptr^ (1, text_size))^, local_status);
        WHILE (NOT local_status.normal) AND (local_status.condition = lge$log_cycles_do_not_match) DO
          rewind;
          IF local_status.normal THEN
            lgp$get_entry_from_global_log (log_ordinal, file_instance^.log_cycle, file_instance^.log_address,
                  current_length, #SEQ (text_ptr^ (1, text_size))^, local_status);
          IFEND;
        WHILEND;
      ELSE
        lgp$get_entry_from_local_log (log_ordinal, file_instance^.log_cycle, file_instance^.log_address,
              current_length, #SEQ (text_ptr^ (1, text_size))^, local_status);
        WHILE (NOT local_status.normal) AND (local_status.condition = lge$log_cycles_do_not_match) DO
          rewind;
          IF local_status.normal THEN
            lgp$get_entry_from_local_log (log_ordinal, file_instance^.log_cycle, file_instance^.log_address,
                  current_length, #SEQ (text_ptr^ (1, text_size))^, local_status);
          IFEND;
        WHILEND;
      IFEND;

      IF local_status.normal THEN
        file_instance^.global_file_information^.positioning_info.record_info.bor_address := bor_address;
        current_byte_address := i#current_sequence_position (file_instance^.log_address);
        file_instance^.global_file_information^.positioning_info.record_info.
              current_byte_address := current_byte_address;
        file_position := amc$eor;
        file_instance^.global_file_information^.positioning_info.record_info.
              record_length := current_length;
        file_instance^.global_file_information^.positioning_info.record_info.
              file_position := file_position;
      ELSEIF local_status.condition = lge$end_of_log THEN
        local_status.normal := TRUE;
        file_position := amc$eoi;
        file_instance^.global_file_information^.eoi_byte_address := current_byte_address;
        file_instance^.global_file_information^.positioning_info.record_info.
              file_position := file_position;
      IFEND;

    PROCEND get;
?? TITLE := 'put', EJECT ??
{
{ PURPOSE:
{   This procedure adds characters to the log_entry being constructed.
{   It has no effect on any other file_instance data.
{   It is the responsibility of the processing for the various "put"
{   requests to update other relevant file_instance data.
{   (See the "flush" procedure, above.)
{
{ NOTE:
{   The effect of an amc$put_partial_req is local to the file_instance
{   until the record is terminated, hence global information is not
{   updated for that request.
{

    PROCEDURE [INLINE] put (working_storage_area: ^cell;
          working_storage_length: amt$working_storage_length);

      text_ptr := working_storage_area;
      IF working_storage_length <= cyc$max_string_size THEN
        text_size := working_storage_length;
      ELSE
        text_size := cyc$max_string_size;
      IFEND;
      IF text_size > (STRLENGTH (log_entry^.value) - log_entry^.size) THEN
        text_size := STRLENGTH (log_entry^.value) - log_entry^.size;
      IFEND;
      log_entry^.value (log_entry^.size + 1, text_size) := text_ptr^ (1, text_size);
      log_entry^.size := log_entry^.size + text_size;

    PROCEND put;
?? TITLE := 'rewind', EJECT ??
{
{ PURPOSE:
{   This procedure synchronizes the file_instance with the beginning
{   of the current log cycle; and establishes file_position (local and
{   global), current_byte_address (local and global), and bor_address.
{

    PROCEDURE [INLINE] rewind;

      IF critical_window_log THEN
        lgp$get_critical_log_read_info (0, file_instance^.log_cycle,
              file_instance^.log_address, current_byte_address, local_status);
      ELSEIF log_ordinal IN - $pmt$global_logset [] THEN
        lgp$get_global_log_read_info (log_ordinal, 0, file_instance^.log_cycle,
              file_instance^.log_address, current_byte_address, local_status);
      ELSE
        lgp$get_local_log_read_info (log_ordinal, 0, file_instance^.log_cycle,
              file_instance^.log_address, current_byte_address, local_status);
      IFEND;
      IF NOT local_status.normal THEN
        RETURN;
      IFEND;

      RESET file_instance^.log_address;
      current_byte_address := 0;
      file_position := amc$boi;
      file_instance^.global_file_information^.positioning_info.record_info.
            bor_address := 0;
      file_instance^.global_file_information^.positioning_info.record_info.
            current_byte_address := 0;
      file_instance^.global_file_information^.positioning_info.record_info.
            file_position := amc$boi;

    PROCEND rewind;
?? TITLE := 'seek', EJECT ??
{
{ PURPOSE:
{   This procedure establishes a new current_byte_address (local and
{   global), file_position (local and global), and bor_address.
{

    PROCEDURE [INLINE] seek;

      i#build_adaptable_seq_pointer (#ring (file_instance^.log_address), #segment (file_instance^.
            log_address), #offset (file_instance^.log_address), #SIZE (file_instance^.log_address^),
            current_byte_address, file_instance^.log_address);

      IF current_byte_address = 0 THEN
        file_position := amc$boi;
      ELSE
        file_position := amc$eor;
      IFEND;
      file_instance^.global_file_information^.positioning_info.record_info.
            file_position := file_position;
      file_instance^.global_file_information^.positioning_info.record_info.
            bor_address := current_byte_address;
      file_instance^.global_file_information^.positioning_info.record_info.
            current_byte_address := current_byte_address;

    PROCEND seek;
?? TITLE := 'skip', EJECT ??
{
{ PURPOSE:
{   This procedure performs forward/backward skips on a log.
{   The log is considerred to consist of a single partition.
{

    PROCEDURE {INLINE} skip;

      VAR
        ignore_text: cell,
        residual_skip_count: amt$skip_count;

      IF log_entry <> NIL THEN
        amp$set_file_instance_abnormal (file_identifier, ame$skip_requires_read_perm, call_block.operation,
              '', local_status);
        RETURN;
      IFEND;

      IF (call_block.skp.count < LOWERVALUE (amt$skip_count)) OR (call_block.skp.count > UPPERVALUE
            (amt$skip_count)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_skip_count, call_block.operation, '',
              local_status);
        RETURN;
      IFEND;

      CASE call_block.skp.unit OF
      = amc$skip_partition =
        residual_skip_count := UPPERVALUE (amt$skip_count);
      = amc$skip_record =
        residual_skip_count := call_block.skp.count;
      ELSE
        amp$set_file_instance_abnormal (file_identifier, ame$improper_skip_unit, call_block.operation, '',
              local_status);
        RETURN;
      CASEND;

      current_byte_address := i#current_sequence_position (file_instance^.log_address);
      file_position := file_instance^.global_file_information^.
            positioning_info.record_info.file_position;

      CASE call_block.skp.direction OF

      = amc$forward =
        WHILE (file_position < amc$eoi) AND (residual_skip_count > 0) DO
          get (^ignore_text, 1);
          IF NOT local_status.normal THEN
            RETURN;
          IFEND;
          residual_skip_count := residual_skip_count - 1;
        WHILEND;

        IF call_block.skp.unit = amc$skip_record THEN
          IF file_position = amc$eoi THEN
            residual_skip_count := residual_skip_count + 1;
            amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi, call_block.operation,
              'records', local_status);
          IFEND;
        ELSE {amc$skip_partition}
          IF call_block.skp.count > 0 THEN
            amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi, call_block.operation,
              'partitions', local_status);
          IFEND;
          residual_skip_count := call_block.skp.count;
        IFEND;

      = amc$backward =
        WHILE (file_position > amc$boi) AND (residual_skip_count > 0) DO
          residual_skip_count := residual_skip_count - 1;
          IF critical_window_log THEN
            lgp$get_critical_previous_size (file_instance^.log_cycle, file_instance^.log_address,
                  previous_length, local_status);
            WHILE (NOT local_status.normal) AND (local_status.condition = lge$log_cycles_do_not_match) DO
              rewind;
              IF local_status.normal THEN
                lgp$get_critical_previous_size (file_instance^.log_cycle, file_instance^.log_address,
                      previous_length, local_status);
              IFEND;
            WHILEND;
          ELSEIF log_ordinal IN - $pmt$global_logset [] THEN
            lgp$get_global_previous_size (log_ordinal, file_instance^.log_cycle, file_instance^.log_address,
                  previous_length, local_status);
            WHILE (NOT local_status.normal) AND (local_status.condition = lge$log_cycles_do_not_match) DO
              rewind;
              IF local_status.normal THEN
                lgp$get_global_previous_size (log_ordinal, file_instance^.log_cycle,
                      file_instance^.log_address, previous_length, local_status);
              IFEND;
            WHILEND;
          ELSE
            lgp$get_local_previous_size (log_ordinal, file_instance^.log_cycle, file_instance^.log_address,
                  previous_length, local_status);
            WHILE (NOT local_status.normal) AND (local_status.condition = lge$log_cycles_do_not_match) DO
              rewind;
              IF local_status.normal THEN
                lgp$get_local_previous_size (log_ordinal, file_instance^.log_cycle,
                      file_instance^.log_address, previous_length, local_status);
              IFEND;
            WHILEND;
          IFEND;
          IF NOT local_status.normal THEN
            RETURN;
          IFEND;
          current_byte_address := current_byte_address - (previous_length + #SIZE (lgt$log_entry_header));
          seek;
          IF NOT local_status.normal THEN
            RETURN;
          IFEND;
        WHILEND;

        IF call_block.skp.unit = amc$skip_record THEN
          IF residual_skip_count > 0 THEN
            amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_boi, call_block.operation,
              'records', local_status);
          IFEND;
        ELSE {amc$skip_partition}
          IF call_block.skp.count > 0 THEN
            amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_boi, call_block.operation,
              'partitions', local_status);
          IFEND;
          residual_skip_count := call_block.skp.count;
        IFEND;

      ELSE
        amp$set_file_instance_abnormal (file_identifier, ame$improper_skip_direction, call_block.operation,
              '', local_status);
        RETURN;
      CASEND;

      file_instance^.residual_skip_count := residual_skip_count;
      file_instance^.global_file_information^.positioning_info.record_info.
            file_position := file_position;
      file_instance^.global_file_information^.positioning_info.record_info.
            current_byte_address := current_byte_address;
      file_instance^.global_file_information^.positioning_info.record_info.
            bor_address := current_byte_address;
      IF file_position = amc$eoi THEN
        file_instance^.global_file_information^.eoi_byte_address := current_byte_address;
      IFEND;

    PROCEND skip;
?? OLDTITLE, EJECT ??

    #keypoint (osk$entry, 0, bak$log_device);

    #caller_id (caller_id);
    status.normal := TRUE;
    local_status.normal := TRUE;
    critical_window_log := FALSE;
    file_instance := NIL;

  /fap/
    BEGIN
      amp$validate_caller_privilege (file_identifier, call_block, layer_number, $pft$usage_selections
            [pfc$append], caller_id.ring, ignore_structure_pointer, local_status);
      IF NOT local_status.normal THEN
        IF local_status.condition <> ame$improper_file_id THEN
          file_instance := ^bav$task_file_table^ [file_identifier.ordinal];
        IFEND;
        EXIT /fap/;
      IFEND;

      file_instance := ^bav$task_file_table^ [file_identifier.ordinal];

      IF call_block.operation = amc$open_req THEN
        IF call_block.open.access_level <> amc$record THEN
          amp$set_file_instance_abnormal (file_identifier, ame$not_virtual_memory_device, amc$open_req,
                'LOG', local_status);
          EXIT /fap/;
        IFEND;

      /determine_log_ordinal/
        BEGIN
          #translate (osv$lower_to_upper, call_block.open.local_file_name, local_file_name);
          IF local_file_name = clv$critical_log_path_handle THEN
            log_ordinal := pmc$system_log;
            critical_window_log := TRUE;
            EXIT /determine_log_ordinal/;
          ELSE
            FOR log_ordinal := LOWERBOUND (clv$log_name_path_handles) TO
                  UPPERBOUND (clv$log_name_path_handles) DO
              IF local_file_name = clv$log_name_path_handles [log_ordinal] THEN
                EXIT /determine_log_ordinal/;
              IFEND;
            FOREND;
          IFEND;
          osp$set_status_abnormal (amc$access_method_id, pme$name_is_not_name_of_log, local_file_name,
                local_status);
          EXIT /fap/;
        END /determine_log_ordinal/;

        IF critical_window_log THEN
          lgp$get_critical_log_read_info (0, file_instance^.log_cycle,
                file_instance^.log_address, current_byte_address, local_status);
        ELSEIF log_ordinal IN - $pmt$global_logset [] THEN
          lgp$get_global_log_read_info (log_ordinal, 0, file_instance^.log_cycle,
                file_instance^.log_address, current_byte_address, local_status);
        ELSE
          lgp$get_local_log_read_info (log_ordinal, 0, file_instance^.log_cycle,
                file_instance^.log_address, current_byte_address, local_status);
        IFEND;
        IF NOT local_status.normal THEN
          EXIT /fap/;
        IFEND;
        RESET file_instance^.log_address;
        file_instance^.global_file_information^.eoi_byte_address := current_byte_address;

        IF (file_instance^.instance_attributes.dynamic_label.access_mode = $pft$usage_selections [pfc$append])
              { this next check will be taken out when amp$open is eliminated completely and }
              { fsp$open_file is used throughout command language.}
              OR (file_instance^.instance_attributes.dynamic_label.access_mode = $pft$usage_selections
              [pfc$append, pfc$shorten])
              THEN
          IF NOT critical_window_log AND NOT (log_ordinal IN - $pmt$ascii_logset []) THEN
            amp$set_file_instance_abnormal (file_identifier, ame$improper_access_attempt, call_block.
                  operation, ' READ ONLY', local_status);
            EXIT /fap/;
          IFEND;
          fmp$get_label_attributes (file_instance^.system_file_label,
                static_label, local_status);
          IF NOT local_status.normal THEN
            EXIT /fap/;
          IFEND;
          text_size := static_label.page_width;
          IF text_size < osc$max_string_size THEN
            text_size := osc$max_string_size;
          IFEND;
          ALLOCATE log_entry: [text_size] IN osv$task_private_heap^;
          log_entry^.size := 0;
          current_byte_address := file_instance^.global_file_information^.eoi_byte_address;
          file_position := amc$eoi;

        ELSEIF file_instance^.instance_attributes.dynamic_label.access_mode = $pft$usage_selections [pfc$read]
              THEN
          log_entry := NIL;
          current_byte_address := 0;
          file_position := amc$boi;

        ELSE
          IF critical_window_log OR (log_ordinal IN - $pmt$ascii_logset []) THEN
            amp$set_file_instance_abnormal (file_identifier, ame$improper_access_attempt, call_block.
                  operation, ' APPEND ONLY or READ ONLY', local_status);
          ELSE
            amp$set_file_instance_abnormal (file_identifier, ame$improper_access_attempt, call_block.
                  operation, ' READ ONLY', local_status);
          IFEND;
          EXIT /fap/;
        IFEND;

        file_instance^.log_entry := log_entry;
        file_instance^.log_ordinal := log_ordinal;

        file_instance^.global_file_information^.positioning_info.record_info.
              bor_address := current_byte_address;
        file_instance^.global_file_information^.positioning_info.record_info.
              current_byte_address := current_byte_address;
        file_instance^.global_file_information^.positioning_info.record_info.
              file_position := file_position;

      ELSE
        log_ordinal := file_instance^.log_ordinal;
        log_entry := file_instance^.log_entry;
      IFEND;


      CASE call_block.operation OF

      = amc$close_req =
        IF log_entry <> NIL THEN
          IF file_instance^.global_file_information^.positioning_info.record_info.
                file_position = amc$mid_record THEN
            flush;
          IFEND;
          FREE log_entry IN osv$task_private_heap^;
        IFEND;
        IF local_status.normal THEN
          bap$close (file_identifier, local_status);
        ELSE
          bap$close (file_identifier, ignore_status);
        IFEND;

      = amc$fetch_req =
        bap$fetch (file_identifier, call_block, layer_number, local_status);

      = amc$fetch_access_information_rq =
        bap$fetch_access_information (file_identifier, call_block, layer_number, local_status);

      = amc$flush_req, amc$write_end_partition_req =
        IF log_entry <> NIL THEN
          IF file_instance^.global_file_information^.positioning_info.record_info.
                file_position = amc$mid_record THEN
            flush;
          IFEND;
        IFEND;

      = amc$get_direct_req =
        current_byte_address := call_block.getd.byte_address;
        seek;
        IF NOT local_status.normal THEN
          EXIT /fap/;
        IFEND;

        get (call_block.getd.working_storage_area, call_block.getd.working_storage_length);
        IF NOT local_status.normal THEN
          EXIT /fap/;
        IFEND;

        call_block.getd.file_position^ := file_position;
        IF call_block.getd.file_position^ = amc$eoi THEN
          call_block.getd.transfer_count^ := 0;
        ELSEIF current_length <= text_size THEN
          call_block.getd.transfer_count^ := current_length;
        ELSE
          call_block.getd.transfer_count^ := text_size;
        IFEND;

      = amc$get_next_req =
        IF file_instance^.global_file_information^.positioning_info.record_info.
              file_position = amc$eoi THEN
          amp$set_file_instance_abnormal (file_identifier, ame$input_after_eoi, call_block.operation, '',
                local_status);
          EXIT /fap/;
        IFEND;

        get (call_block.getn.working_storage_area, call_block.getn.working_storage_length);
        IF NOT local_status.normal THEN
          EXIT /fap/;
        IFEND;

        call_block.getn.file_position^ := file_position;
        call_block.getn.byte_address^ := file_instance^.
              global_file_information^.positioning_info.record_info.bor_address;
        IF call_block.getn.file_position^ = amc$eoi THEN
          call_block.getn.transfer_count^ := 0;
        ELSEIF current_length <= text_size THEN
          call_block.getn.transfer_count^ := current_length;
        ELSE
          call_block.getn.transfer_count^ := text_size;
        IFEND;

      = amc$get_partial_req =
        IF file_instance^.global_file_information^.positioning_info.record_info.
              file_position = amc$eoi THEN
          amp$set_file_instance_abnormal (file_identifier, ame$input_after_eoi, call_block.operation, '',
                local_status);
          EXIT /fap/;
        IFEND;

        get (call_block.getp.working_storage_area, call_block.getp.working_storage_length);
        IF NOT local_status.normal THEN
          EXIT /fap/;
        IFEND;

        call_block.getp.file_position^ := file_position;
        call_block.getp.byte_address^ := file_instance^.
              global_file_information^.positioning_info.record_info.bor_address;
        IF call_block.getp.file_position^ = amc$eoi THEN
          call_block.getp.record_length^ := 0;
          call_block.getp.transfer_count^ := 0;
        ELSE
          call_block.getp.record_length^ := current_length;
          IF current_length <= text_size THEN
            call_block.getp.transfer_count^ := current_length;
          ELSE
            call_block.getp.transfer_count^ := text_size;
          IFEND;
        IFEND;

      = amc$open_req =
        {processed above} ;

      = amc$put_direct_req =
        IF file_instance^.global_file_information^.positioning_info.record_info.
              file_position = amc$mid_record THEN
          flush;
          IF NOT local_status.normal THEN
            EXIT /fap/;
          IFEND;
        IFEND;

        put (call_block.putd.working_storage_area, call_block.putd.working_storage_length);
        flush;

      = amc$put_next_req =
        IF file_instance^.global_file_information^.positioning_info.record_info.
              file_position = amc$mid_record THEN
          flush;
          IF NOT local_status.normal THEN
            EXIT /fap/;
          IFEND;
        IFEND;

        put (call_block.putn.working_storage_area, call_block.putn.working_storage_length);
        flush;
        IF NOT local_status.normal THEN
          EXIT /fap/;
        IFEND;

        call_block.putn.byte_address^ := file_instance^.
              global_file_information^.positioning_info.record_info.bor_address;

      = amc$put_partial_req =
        IF (file_instance^.global_file_information^.positioning_info.record_info.
              file_position <> amc$mid_record) AND (call_block.putp.
              term_option = amc$continue) THEN
          amp$set_file_instance_abnormal (file_identifier, ame$improper_continue, call_block.operation, '',
                local_status);
          EXIT /fap/;
        IFEND;

        IF (file_instance^.global_file_information^.positioning_info.record_info.
              file_position = amc$mid_record) AND (call_block.putp.
              term_option = amc$start) THEN
          flush;
          IF NOT local_status.normal THEN
            EXIT /fap/;
          IFEND;
        IFEND;

        put (call_block.putp.working_storage_area, call_block.putp.working_storage_length);

        IF call_block.putp.term_option = amc$terminate THEN
          flush;
          IF NOT local_status.normal THEN
            EXIT /fap/;
          IFEND;
        ELSE
          file_instance^.global_file_information^.positioning_info.record_info.
                file_position := amc$mid_record;
        IFEND;

        call_block.putn.byte_address^ := file_instance^.global_file_information^.
              positioning_info.record_info.bor_address;

      = amc$rewind_req =
        IF log_entry = NIL THEN
          rewind;
        IFEND;

      = amc$seek_direct_req =
        IF log_entry = NIL THEN
          current_byte_address := call_block.seekd.byte_address;
          seek;
        IFEND;

      = amc$skip_req =
        IF log_entry = NIL THEN
          skip;
          call_block.skp.file_position^ := file_position;
        IFEND;

      = amc$store_req =
        bap$store (file_identifier, call_block, layer_number, local_status);

      ELSE
        amp$set_file_instance_abnormal (file_identifier, ame$unimplemented_request, call_block.operation,
              ' for log device files', local_status);
      CASEND;
    END /fap/;

    IF (file_instance <> NIL) AND (call_block.operation <> amc$close_req) THEN
      IF call_block.operation <> amc$fetch_access_information_rq THEN
        file_instance^.global_file_information^.last_access_operation := call_block.operation;
      IFEND;
      IF local_status.normal THEN
        file_instance^.global_file_information^.error_status := 0;
      ELSE
        file_instance^.global_file_information^.error_status := local_status.condition;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #keypoint (osk$exit, 0, bak$log_device);

  PROCEND bap$log_device;

MODEND bam$log_device;
*DECK DECK=BAM$LRT_SS_UNDEF_TAPE_FAP EXPAND=TRUE
MODULE bam$lrt_ss_undef_tape_fap;
?? LEFT := 1, RIGHT := 110 ??
? VAR user_fap: boolean := FALSE?;
? VAR pad_records: boolean := FALSE?;
?? PUSH (LIST := OFF) ??

























?? POP ??
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
?? TITLE := 'Type definitions' ??
*copyc amt$tape_error_options
*copyc amt$file_identifier
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc bat$put_label_request
*copyc bat$record_header_type
*copyc ost$caller_identifier
*copyc bak$bap_procedure_keypoints
?? TITLE := 'Error code definitions', EJECT ??
*copyc ame$improper_file_id
*copyc ame$improper_wsl
*copyc ame$get_program_actions
*copyc ame$get_validation_errors
*copyc ame$put_program_actions
*copyc ame$put_validation_errors
*copyc ame$skip_program_actions
*copyc ame$skip_validation_errors
*copyc bae$tape_bm_error_codes
*copyc dme$tape_errors
?? OLDTITLE ??
?? EJECT ??
?? POP ??
{ The following POP pragmat is here to negate an extra push (listext :=on) in one of the bam decks. }
?? POP ??
?? TITLE := 'XREF variable and procedure definitions' ??
*copyc osv$task_private_heap
*copyc amp$set_file_instance_abnormal
*copyc bap$close
*copyc bap$tape_bm_align_position
*copyc bap$tape_bm_flush
*copyc bap$tape_bm_open
*copyc bap$tape_bm_read_label
*copyc bap$tape_bm_read_next_block
*copyc bap$tape_bm_read_to_write
*copyc bap$tape_bm_close
*copyc bap$tape_bm_write_next_block
*copyc bap$tape_bm_reserve_blk_buffer
*copyc bap$tape_bm_skip_blocks
*copyc bap$tape_bm_skip_tapemark
*copyc bap$tape_bm_rewind
*copyc bap$tape_bm_advance_volume
*copyc bap$tape_bm_erase_block
*copyc bap$tape_bm_tapemark_check
*copyc bap$tape_bm_write_tape_mark
*copyc bap$tape_bm_write_label
*copyc bap$tape_bm_write_label_mark
*copyc bap$fap_control
*copyc osp$set_status_abnormal
?? TITLE := 'INLINE function definitions' ??
?? NEWTITLE := ' ' ??
?? TITLE := 'bai$state_info', EJECT ??
*copyc bai$state_info
?? TITLE := 'bai$tape_descriptor', EJECT ??
*copyc bai$tape_descriptor
?? TITLE := 'bai$block_info', EJECT ??
*copyc bai$block_info
?? TITLE := 'bai$dynamic_label', EJECT ??
*copyc bai$dynamic_label
?? TITLE := 'bai$gfi', EJECT ??
*copyc bai$gfi
?? TITLE := 'bai$label_type', EJECT ??
*copyc bai$label_type
?? TITLE := 'bai$partial_block_exists', EJECT ??
*copyc bai$partial_block_exists
?? TITLE := 'bai$partial_read_block_exists', EJECT ??
*copyc bai$partial_read_block_exists
?? TITLE := 'bai$partial_record_exists', EJECT ??
*copyc bai$partial_record_exists
?? TITLE := 'bai$static_label', EJECT ??
*copyc bai$static_label
?? OLDTITLE ??
?? TITLE := 'INLINE procedure definitions' ??
?? NEWTITLE := ' ' ??
?? TITLE := 'osp$disestablish_cond_handler', EJECT ??
*copyc osp$disestablish_cond_handler
?? TITLE := 'osp$establish_block_exit_hndlr', EJECT ??
*copyc osp$establish_block_exit_hndlr
?? TITLE := 'bai$advance_volume', EJECT ??
*copyc bai$advance_volume
?? TITLE := 'bai$append_tape_error', EJECT ??
*copyc bai$append_tape_error
?? TITLE := 'bai$check_caller_id', EJECT ??
*copyc bai$check_caller_id
?? TITLE := 'bai$check_record_level_access', EJECT ??
*copyc bai$check_record_level_access
?? TITLE := 'bai$check_tapemark', EJECT ??
*copyc bai$check_tapemark
?? TITLE := 'bai$clear_fail_at_current_pos', EJECT ??
*copyc bai$clear_fail_at_current_pos
?? TITLE := 'bai$fetch_tape_error_options', EJECT ??
*copyc bai$fetch_tape_error_options
?? TITLE := 'bai$forced_write', EJECT ??
*copyc bai$forced_write
?? TITLE := 'bai$init_boi_tape_position', EJECT ??
*copyc bai$init_boi_tape_position
?? TITLE := 'bai$process_block_information', EJECT ??
*copyc bai$process_block_information
?? TITLE := 'bai$process_request_status', EJECT ??
*copyc bai$process_request_status
?? TITLE := 'bai$validate_tape_access', EJECT ??
*copyc bai$validate_tape_access
?? TITLE := 'bai$write_previous_block', EJECT ??
*copyc bai$write_previous_block
?? TITLE := 'bap$validate_fap_identifier', EJECT ??
*copyc bap$validate_fap_identifier
?? TITLE := 'bap$validate_file_identifier', EJECT ??
*copyc bap$validate_file_identifier
?? TITLE := 'i#move', EJECT ??
*copyc i#move
?? OLDTITLE ??
?? TITLE := 'global variables for this call of the fap', EJECT ??
*copyc bav$global_tape_fap_variables

  CONST
    pad_blocks = FALSE,
    record_headers_exist = FALSE;

?? TITLE := 'bap#lrt_ss_undef_tape_fap', EJECT ??
? IF user_fap THEN
  VAR
    ttv$layer_number: [XDCL] amt$fap_layer_number := 0;

  PROCEDURE [XDCL, #GATE] bap#lrt_ss_undef_tape_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    ttv$layer_number := layer_number;
    bap$lrt_ss_undef_tape_fap (file_identifier, call_block, layer_number, status);

  PROCEND bap#lrt_ss_undef_tape_fap;
? IFEND

?? TITLE := 'bap$lrt_ss_undef_tape_fap', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$lrt_ss_undef_tape_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      dynamic_label: ^bat$dynamic_label_attributes,
      i: integer,
      local_status: ost$status,
      static_label: ^bat$instance_static_attributes,
      validation_ok: boolean;

    #caller_id (caller_id);
    operation := call_block.operation;
    #keypoint (osk$entry, osk$m * ((file_identifier.ordinal * 256) + operation),
          bak$sys_blk_undef_rec_tape_fap);
    status.normal := TRUE;
    global_layer_number := layer_number;
    close_file_on_exit := FALSE;

  /main_program/
    BEGIN

? IF user_fap THEN
      bap$validate_fap_identifier (file_identifier, file_instance, validation_ok);
? ELSE
      bap$validate_file_identifier (file_identifier, file_instance, validation_ok);
? IFEND
      IF NOT validation_ok THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id, 'bap$lrt_ss_undef_tape_fap',
              status);
        EXIT /main_program/;
      IFEND;

      block_info := bai$block_info (file_instance);
      gfi := bai$gfi (file_instance);
      tape_descriptor := bai$tape_descriptor (file_instance);
      static_label := bai$static_label (file_instance);
      state_info := bai$state_info (file_instance);
      bai$check_caller_id (file_identifier, static_label^.ring_attributes, operation, caller_id,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      bai$check_record_level_access (file_identifier, file_instance^.access_level, operation,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      dynamic_label := bai$dynamic_label (file_instance);
      bai$validate_tape_access (file_identifier, dynamic_label^.access_mode, operation, tape_descriptor,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      bai$clear_fail_at_current_pos (operation, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;


      tape_descriptor^.error_options := dynamic_label^.error_options;

      CASE operation OF

      = amc$close_req =
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: SS/U FAP called on CLOSE');
        close_req (file_identifier, status);
        bap$close (file_identifier, local_status);
        IF status.normal THEN
          status := local_status;
        IFEND;
      = amc$close_volume_req =
        close_volume_req (file_identifier, status);
        file_instance^.previous_get_at_eoi := FALSE;
      = amc$erase_tape_block =
        erase_tape_block_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$fetch_req =
        bap$fap_control (file_identifier, call_block, layer_number, status);
      = amc$flush_req =
        flush_req (file_identifier, status);
      = amc$get_next_req =
        get_next_req (file_identifier, call_block, status);
        IF status.normal AND (call_block.getn.file_position^ <> amc$eoi) THEN
          tape_descriptor^.at_eoi := FALSE;
        IFEND;
      = amc$get_partial_req =
        get_partial_req (file_identifier, call_block, status);
        IF status.normal AND (call_block.getp.file_position^ <> amc$eoi) THEN
          tape_descriptor^.at_eoi := FALSE;
        IFEND;
      = amc$open_req =
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: SS/U FAP called on OPEN');
        tape_descriptor^.file_label_type := static_label^.file_label_type;
        open_req (file_identifier, call_block, layer_number, dynamic_label, status);
      = amc$put_next_req =
        IF (bai$label_type () = amc$labelled) THEN
          IF NOT state_info^.ve_wrote_ansi_file THEN
            amp$set_file_instance_abnormal (file_identifier, ame$rewrite_labels_conflict,
                  call_block.operation, ' ', status);
            RETURN;
          IFEND;
          IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
            sl_reposition_for_put_at_eoi (file_identifier, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
        put_next_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$put_partial_req =
        IF (bai$label_type () = amc$labelled) THEN
          IF NOT state_info^.ve_wrote_ansi_file THEN
            amp$set_file_instance_abnormal (file_identifier, ame$rewrite_labels_conflict,
                  call_block.operation, ' ', status);
            RETURN;
          IFEND;
          IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
            sl_reposition_for_put_at_eoi (file_identifier, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
        put_partial_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$rewind_req =
        rewind_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := FALSE;
      = amc$skip_req =
        validate_skip_parameters (file_identifier, call_block, FALSE, FALSE, FALSE, FALSE, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        skip_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
      = amc$write_tape_mark_req =
        IF bai$label_type () = amc$labelled THEN
          amp$set_file_instance_abnormal (file_identifier, ame$improper_labelled_tape_op,
                call_block.operation, 'WRITE OF TAPE MARK', status);
          EXIT /main_program/;
        IFEND;

{   Check if last operation was read type that left tape logically at mid_block

        IF bai$partial_read_block_exists () THEN
          switch_from_read_to_write (file_identifier, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;

        write_tape_mark_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      ELSE

        bap$fap_control (file_identifier, call_block, layer_number, status);

      CASEND;

    END /main_program/;

    IF (operation >= amc$last_access_start) AND (operation <= amc$max_operation)
          AND (operation <> amc$fetch_req) AND
          (operation <> amc$fetch_access_information_rq) THEN
      gfi^.last_access_operation := operation;
    IFEND;
    IF status.normal THEN
      gfi^.error_status := 0;
    ELSE
      gfi^.error_status := status.condition;
    IFEND;

{
{   IF the operator terminates a tape assignment that was initiated via bai$advance_volume,
{   the file will be closed at this point.  It cannot be closed in bai$advance_volume since
{   the global_file_information may be referenced after the call.
{

    IF close_file_on_exit THEN
      bap$close (file_identifier, local_status);
    IFEND;

    #keypoint (osk$exit, 0, bak$sys_blk_undef_rec_tape_fap);

  PROCEND bap$lrt_ss_undef_tape_fap;
?? TITLE := 'get_next_req', EJECT ??

{
{ The purpose of this request is to cause the transfer of data from tape to a
{ tape buffer, transfer data from the tape buffer to the users working
{ storage area, and to update all file descriptor fields.
{

  PROCEDURE get_next_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    CONST
      allow_direct_io_transfer = FALSE;

    VAR
      error_action : bat$error_actions,
      data_length : 0 .. amc$maximum_block - 1,
      get_size : 0 .. amc$maximum_block - 1,
      more_data : boolean,
      request_status : ost$status,
      start_new_block : boolean,
      tape_failure_modes : amt$tape_failure_modes,
      wsa : ^cell,
      wsl : amt$working_storage_length;

{
{ Check file position to see if any partial blocks need to be written out.
{

    IF bai$partial_block_exists () THEN
      bai$write_previous_block (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  /main_program/
    BEGIN

      data_length := 0;
      wsl := call_block.getn.working_storage_length;
      wsa := call_block.getn.working_storage_area;
      more_data := TRUE;

      IF (wsl <= 0) OR (wsl > UPPERVALUE (amt$working_storage_length)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value, operation,
              ' ', status);
        RETURN;
      IFEND;

      WHILE more_data DO
        IF block_info^.block_position = bac$middle_of_block THEN
          start_new_block := FALSE;
          IF wsl <= block_info^.residual_block_length THEN
            get_size := wsl;
            more_data := FALSE;
          ELSE
            get_size := block_info^.residual_block_length;
          IFEND;
        ELSE
          start_new_block := TRUE;
          IF wsl > gfi^.max_data_size THEN
            get_size := gfi^.max_data_size;
          ELSE
            get_size := wsl;
            more_data := FALSE;
          IFEND;
        IFEND;

        get_data (file_identifier, operation, wsa, get_size, allow_direct_io_transfer,
              start_new_block, {convert_if_ebcdic =} TRUE, status);
        data_length := data_length + gfi^.positioning_info.record_info.transfer_count;
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        IF gfi^.positioning_info.record_info.transfer_count < get_size THEN
          get_size := gfi^.positioning_info.record_info.transfer_count;
          IF (tape_descriptor^.volume_position = amc$after_tapemark) OR
                (tape_descriptor^.volume_position = amc$eov) THEN
            more_data := FALSE;
          ELSE
            more_data := TRUE;
          IFEND;
        IFEND;
        wsl := wsl - get_size;
        wsa := #address (#ring (wsa), #segment (wsa), (#offset (wsa) + get_size));
      WHILEND;

    END /main_program/;

    IF (tape_descriptor^.volume_position = amc$eov) OR
          (tape_descriptor^.volume_position = amc$after_tapemark) THEN
      IF data_length = 0 THEN
        gfi^.positioning_info.record_info.file_position := amc$eoi;
        file_instance^.previous_get_at_eoi := TRUE;
        tape_descriptor^.at_eoi := TRUE;
      ELSE {data was transfered}
        CASE bai$label_type () OF

        = amc$unlabelled =

          IF tape_descriptor^.volume_position = amc$after_tapemark THEN
            bap$tape_bm_skip_tapemark (file_identifier, amc$backward, tape_failure_modes, request_status);
            bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
                    error_action, status);
          IFEND;

          gfi^.positioning_info.record_info.file_position := amc$eor;
          tape_descriptor^.volume_position := amc$after_data_block;

        = amc$labelled =

          gfi^.positioning_info.record_info.file_position := amc$eor;

        = amc$non_standard_labelled =

          gfi^.positioning_info.record_info.file_position := amc$mid_record;

        ELSE
          amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
                operation, 'Unknown file_label_type in get_next_req (SS, U)', status);
        CASEND;
      IFEND;
    ELSE
      gfi^.positioning_info.record_info.file_position := amc$eor;
    IFEND;

    gfi^.positioning_info.record_info.transfer_count := data_length;
    gfi^.positioning_info.record_info.record_length := data_length;
    gfi^.positioning_info.record_info.residual_record_length := 0;
    call_block.getn.file_position^ := gfi^.positioning_info.record_info.file_position;
    call_block.getn.transfer_count^ := gfi^.positioning_info.record_info.transfer_count;

  PROCEND get_next_req;

?? TITLE := 'get_partial_req', EJECT ??

{
{ The purpose of this request is to cause a partial transfer of data from tape to a
{ tape buffer, transfer data from the tape buffer to the users working
{ storage area, and to update all file descriptor fields.
{

  PROCEDURE get_partial_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    CONST
      allow_direct_io_transfer = FALSE;

    VAR
      error_action : bat$error_actions,
      data_length : 0 .. amc$maximum_block - 1,
      get_size : 0 .. amc$maximum_block - 1,
      more_data : boolean,
      next_block_is_a_tapemark : boolean,
      request_status : ost$status,
      start_new_block : boolean,
      tape_failure_modes : amt$tape_failure_modes,
      wsa : ^cell,
      wsl : amt$working_storage_length;

{
{ Check file position to see if any partial blocks need to be written out.
{

    IF bai$partial_block_exists () THEN
      bai$write_previous_block (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  /main_program/
    BEGIN

      data_length := 0;
      wsl := call_block.getp.working_storage_length;
      wsa := call_block.getp.working_storage_area;
      more_data := TRUE;

      IF (wsl <= 0) OR (wsl > UPPERVALUE (amt$working_storage_length)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value, operation,
              ' ', status);
        RETURN;
      IFEND;

      IF (call_block.getp.skip_option < LOWERVALUE (amt$skip_option)) OR
            (call_block.getp.skip_option > UPPERVALUE (amt$skip_option)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_skip_option,
              operation, ' ', status);
        RETURN;
      IFEND;

      IF call_block.getp.skip_option = amc$skip_to_eor THEN
        gfi^.positioning_info.record_info.file_position := amc$eor;
      IFEND;

      IF gfi^.positioning_info.record_info.file_position = amc$eor THEN
        gfi^.positioning_info.record_info.record_length := 0;
      IFEND;

      WHILE more_data DO
        IF block_info^.block_position = bac$middle_of_block THEN
          start_new_block := FALSE;
          IF wsl <= block_info^.residual_block_length THEN
            get_size := wsl;
            more_data := FALSE;
          ELSE
            get_size := block_info^.residual_block_length;
          IFEND;
        ELSE
          start_new_block := TRUE;
          IF wsl > gfi^.max_data_size THEN
            get_size := gfi^.max_data_size;
          ELSE
            get_size := wsl;
            more_data := FALSE;
          IFEND;
        IFEND;

        get_data (file_identifier, operation, wsa, get_size, allow_direct_io_transfer,
              start_new_block, {convert_if_ebcdic =} TRUE, status);
        data_length := data_length + gfi^.positioning_info.record_info.transfer_count;
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        IF gfi^.positioning_info.record_info.transfer_count < get_size THEN
          get_size := gfi^.positioning_info.record_info.transfer_count;
          IF (tape_descriptor^.volume_position = amc$after_tapemark) OR
                (tape_descriptor^.volume_position = amc$eov) THEN
            more_data := FALSE;
          ELSE
            more_data := TRUE;
          IFEND;
        IFEND;
        wsl := wsl - get_size;
        wsa := #address (#ring (wsa), #segment (wsa), (#offset (wsa) + get_size));
      WHILEND;

    END /main_program/;

    IF (tape_descriptor^.volume_position = amc$eov) OR
          (tape_descriptor^.volume_position = amc$after_tapemark) THEN
      IF data_length = 0 THEN
        gfi^.positioning_info.record_info.file_position := amc$eoi;
        file_instance^.previous_get_at_eoi := TRUE;
        tape_descriptor^.at_eoi := TRUE;
      ELSE {data was transfered}
        CASE bai$label_type () OF

        = amc$unlabelled =

          IF tape_descriptor^.volume_position = amc$after_tapemark THEN
            bap$tape_bm_skip_tapemark (file_identifier, amc$backward, tape_failure_modes, request_status);
            bai$process_request_status (file_identifier, operation, request_status, tape_failure_modes,
                    error_action, status);
          IFEND;

          gfi^.positioning_info.record_info.file_position := amc$eor;
          tape_descriptor^.volume_position := amc$after_data_block;

        = amc$labelled =

          gfi^.positioning_info.record_info.file_position := amc$eor;

        = amc$non_standard_labelled =

          gfi^.positioning_info.record_info.file_position := amc$mid_record;

        ELSE
          amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
                operation, 'Unknown file_label_type in get_next_req (SS, U)', status);
        CASEND;
      IFEND;
    ELSE
      IF (block_info^.block_position = bac$middle_of_block) THEN
        gfi^.positioning_info.record_info.file_position := amc$mid_record;
      ELSE
        IF data_length < call_block.getp.working_storage_length THEN
          gfi^.positioning_info.record_info.file_position := amc$eor;
        ELSE
          bap$tape_bm_tapemark_check (file_identifier, next_block_is_a_tapemark, status);
          IF next_block_is_a_tapemark THEN
            gfi^.positioning_info.record_info.file_position := amc$eor;
          ELSE
            gfi^.positioning_info.record_info.file_position := amc$mid_record;
          IFEND
        IFEND;
      IFEND;
    IFEND;

    gfi^.positioning_info.record_info.transfer_count := data_length;
    gfi^.positioning_info.record_info.record_length := data_length +
          gfi^.positioning_info.record_info.record_length;
    gfi^.positioning_info.record_info.residual_record_length := 0;
    call_block.getp.file_position^ := gfi^.positioning_info.record_info.file_position;
    call_block.getp.transfer_count^ := gfi^.positioning_info.record_info.transfer_count;
    call_block.getp.record_length^ := gfi^.positioning_info.record_info.record_length;

  PROCEND get_partial_req;
?? TITLE := 'put_next_req', EJECT ??

{
{ The purpose of this request is to transfer data from the users
{ working storage area to a tape file, either directly, or through
{ a tape buffer, and to update all file descriptor fields.
{

  PROCEDURE put_next_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      data_length : 0 .. amc$maximum_block - 1,
      max_data_size : 0 .. amc$maximum_block - 1,
      more_data : boolean,
      put_size : 0 .. amc$maximum_block - 1,
      term_option : amt$term_option,
      terminate_previous_block : boolean,
      wsa : ^cell,
      wsl : amt$working_storage_length;

{   Check if last operation was read type that left tape logically at mid_block

      IF bai$partial_read_block_exists () THEN
        switch_from_read_to_write (file_identifier, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

  /main_program/
      BEGIN

        wsa := call_block.putn.working_storage_area;
        wsl := call_block.putn.working_storage_length;
        data_length := 0;
        max_data_size := gfi^.max_data_size;
        more_data := TRUE;

        IF wsl = 0 THEN
          EXIT /main_program/;
        IFEND;

        WHILE more_data DO
          IF bai$partial_block_exists () THEN
            terminate_previous_block := FALSE;
            IF wsl < block_info^.residual_block_length THEN
              term_option := amc$continue;
              put_size := wsl;
              more_data := FALSE;
            ELSE
              term_option := amc$terminate;
              put_size := block_info^.residual_block_length;
            IFEND;
          ELSE
            terminate_previous_block := TRUE;
            IF wsl >= max_data_size THEN
              term_option := amc$terminate;
              put_size := max_data_size
            ELSE
              IF wsl = 0 THEN
                EXIT /main_program/;
              IFEND;
              term_option := amc$start;
              put_size := wsl;
              more_data := FALSE;
            IFEND;
          IFEND;

          put_data (file_identifier, operation, wsa, put_size, term_option,
                terminate_previous_block, {convert_if_ebcdic =} TRUE, status);
          IF NOT status.normal THEN
            IF (status.condition = ame$end_of_tape_op_completed) THEN
              data_length := data_length + put_size;
            IFEND;
            EXIT /main_program/;
          IFEND;
          data_length := data_length + put_size;
          wsl := wsl - put_size;
          wsa := #address (#ring (wsa), #segment (wsa), (#offset (wsa) + put_size));
        WHILEND;

      END /main_program/;

      state_info^.put_op := TRUE;
      IF data_length = call_block.putn.working_storage_length THEN
        gfi^.positioning_info.record_info.file_position := amc$eor;
      ELSE {hit EOT on non-standard labeled tape}
        gfi^.positioning_info.record_info.file_position := amc$mid_record;
      IFEND;
      gfi^.positioning_info.record_info.transfer_count := data_length;
      gfi^.positioning_info.record_info.record_length := data_length;
      gfi^.positioning_info.record_info.residual_record_length := 0;

  PROCEND put_next_req;

?? TITLE := 'put_partial_req', EJECT ??

  PROCEDURE put_partial_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      data_length : 0 .. amc$maximum_block - 1,
      max_data_size : 0 .. amc$maximum_block - 1,
      more_data : boolean,
      put_size : 0 .. amc$maximum_block - 1,
      term_option : amt$term_option,
      terminate_previous_block : boolean,
      wsa : ^cell,
      wsl : amt$working_storage_length;

{   Check if last operation was read type that left tape logically at mid_block

      IF bai$partial_read_block_exists () THEN
        switch_from_read_to_write (file_identifier, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

  /main_program/
      BEGIN

        wsa := call_block.putp.working_storage_area;
        wsl := call_block.putp.working_storage_length;
        data_length := 0;
        max_data_size := gfi^.max_data_size;
        more_data := TRUE;

        IF (call_block.putp.term_option < LOWERVALUE (amt$term_option)) OR
              (call_block.putp.term_option > UPPERVALUE (amt$term_option)) THEN
          amp$set_file_instance_abnormal (file_identifier, ame$improper_term_option,
                operation, ' ', status);
          RETURN;
        IFEND;

        IF (call_block.putp.term_option = amc$continue) AND
              (gfi^.positioning_info.record_info.file_position <> amc$mid_record) THEN
          amp$set_file_instance_abnormal (file_identifier, ame$improper_continue,
                operation, ' ', status);
          RETURN;
        IFEND;

        IF wsl = 0 THEN
          EXIT /main_program/;
        IFEND;

        WHILE more_data DO
          IF bai$partial_block_exists () THEN
            terminate_previous_block := FALSE;
            IF wsl < block_info^.residual_block_length THEN
              term_option := amc$continue;
              put_size := wsl;
              more_data := FALSE;
            ELSE
              term_option := amc$terminate;
              put_size := block_info^.residual_block_length;
            IFEND;
          ELSE
            terminate_previous_block := TRUE;
            IF wsl >= max_data_size THEN
              term_option := amc$terminate;
              put_size := max_data_size
            ELSE
              IF wsl = 0 THEN
                EXIT /main_program/;
              IFEND;
              term_option := amc$start;
              put_size := wsl;
              more_data := FALSE;
            IFEND;
          IFEND;

          put_data (file_identifier, operation, wsa, put_size, term_option,
                terminate_previous_block, {convert_if_ebcdic =} TRUE, status);
          IF NOT status.normal THEN
            IF (status.condition = ame$end_of_tape_op_completed) THEN
              data_length := data_length + put_size;
            IFEND;
            EXIT /main_program/;
          IFEND;
          data_length := data_length + put_size;
          wsl := wsl - put_size;
          wsa := #address (#ring (wsa), #segment (wsa), (#offset (wsa) + put_size));
        WHILEND;

      END /main_program/;

      state_info^.put_op := TRUE;
      IF call_block.putp.term_option = amc$start THEN
        gfi^.positioning_info.record_info.file_position := amc$mid_record;
        gfi^.positioning_info.record_info.record_length := data_length;
      ELSEIF call_block.putp.term_option = amc$continue THEN
        gfi^.positioning_info.record_info.file_position := amc$mid_record;
        gfi^.positioning_info.record_info.record_length := data_length +
              gfi^.positioning_info.record_info.record_length;
      ELSE {amc$terminate}
        IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
          gfi^.positioning_info.record_info.record_length := data_length +
                gfi^.positioning_info.record_info.record_length;
        ELSE
          gfi^.positioning_info.record_info.record_length := data_length;
        IFEND;
        IF data_length = call_block.putp.working_storage_length THEN
          gfi^.positioning_info.record_info.file_position := amc$eor;
        ELSE {hit EOT on non-standard labeled tape}
          gfi^.positioning_info.record_info.file_position := amc$mid_record;
        IFEND;
      IFEND;

      gfi^.positioning_info.record_info.transfer_count := data_length;
      gfi^.positioning_info.record_info.residual_record_length := 0;

  PROCEND put_partial_req;
?? TITLE := 'skip_req', EJECT ??

  PROCEDURE skip_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      block_number: 0 .. amc$max_block_number,
      units_to_skip: amt$skip_count,
      direction: amt$skip_direction,
      error_action: bat$error_actions,
      file_position: amt$file_position,
      tape_failure_modes: amt$tape_failure_modes,
      records_remaining: amt$skip_count,
      request_status: ost$status,
      residual_skip_count: amt$skip_count,
      volume_position: amt$volume_position;


  /main_program/
    BEGIN

      file_position := gfi^.positioning_info.record_info.file_position;
      volume_position := tape_descriptor^.volume_position;
      block_number := block_info^.block_number;
      direction := call_block.skp.direction;
      units_to_skip := call_block.skp.count;

{
{ Check file position to see if any partial blocks need to be written out.
{

      IF bai$partial_block_exists () THEN
        bai$write_previous_block (file_identifier, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      CASE call_block.skp.unit OF

?? NEWTITLE := '    skip tape marks', EJECT ??

      = amc$skip_tape_mark =

        IF units_to_skip = 0 THEN {no-op.}
          file_instance^.residual_skip_count := 0;
          call_block.skp.file_position^ := file_position;
          RETURN;
        IFEND;

        residual_skip_count := units_to_skip;

        IF direction = amc$forward THEN

        /whileloop/
          WHILE residual_skip_count > 0 DO

            REPEAT
              bap$tape_bm_skip_tapemark (file_identifier, direction, tape_failure_modes, request_status);
              bai$process_request_status (file_identifier, operation, request_status,
                    tape_failure_modes, error_action, status);
              IF NOT status.normal AND (status.condition = ame$input_after_output) THEN
                file_position := amc$eoi;
                volume_position := amc$eov;
                amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi, operation,
                        'TAPEMARKS', status);
                EXIT /main_program/;
              IFEND;
              IF error_action = bac$exit_procedure THEN
                EXIT /main_program/;
              IFEND;
            UNTIL error_action <> bac$retry_last_request;

            IF bai$label_type () = amc$unlabelled THEN
              bai$check_tapemark (file_identifier, volume_position, request_status);
              bai$process_request_status (file_identifier, operation, request_status,
                    tape_failure_modes, error_action, status);
              IF NOT status.normal OR (error_action = bac$exit_procedure) THEN
                EXIT /main_program/;
              IFEND;
              CASE volume_position OF
              = amc$after_tapemark =
                residual_skip_count := residual_skip_count - 1;
              = amc$eov =
                bai$advance_volume (file_identifier, volume_position, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
                IF volume_position = amc$eov THEN
                  EXIT /whileloop/;
                IFEND;
              ELSE
                ;
              CASEND;
            ELSE { label_type <> amc$unlabelled     }

{
{ Since skipping by tapemarks is illegal on labelled tapes, this call must be for non_standard labels.
{
{ Consecutive tapemarks indicate a null file, not end of volume, and each tapemark needs to be skipped.
{

              residual_skip_count := residual_skip_count - 1;

            IFEND;

          WHILEND /whileloop/;

          IF residual_skip_count > 0 THEN
            amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi, operation,
              'TAPEMARKS', status);
          IFEND;
          IF status.normal THEN
            file_position := amc$boi;
            volume_position := amc$after_tapemark;
          ELSE
            file_position := amc$eoi;
            volume_position := amc$eov;
          IFEND;

        ELSE { direction = amc$backward }

          /backloop/
            WHILE residual_skip_count > 0 DO

              REPEAT
                bap$tape_bm_skip_tapemark (file_identifier, direction, tape_failure_modes, request_status);
                bai$process_request_status (file_identifier, operation, request_status,
                      tape_failure_modes, error_action, status);
                IF error_action = bac$exit_procedure THEN
                  EXIT /main_program/;
                IFEND;
                IF NOT status.normal AND (status.condition = ame$skip_encountered_bov) THEN
                  EXIT /backloop/;
                IFEND;
                IF status.normal THEN
                  residual_skip_count := residual_skip_count - 1;
                IFEND;
              UNTIL error_action <> bac$retry_last_request;

            WHILEND /backloop/;

            IF residual_skip_count > 0 THEN
              amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_bov, operation,
                'TAPEMARKS', status);
            IFEND;
            IF status.normal THEN
              file_position := amc$eoi;
              volume_position := amc$before_tapemark;
            ELSE
              file_position := amc$boi;
              volume_position := amc$bov;
            IFEND;
        IFEND;

        block_number := 1;

?? OLDTITLE ??
      ELSE
      CASEND;

    END /main_program/;

    call_block.skp.file_position^ := file_position;
    gfi^.positioning_info.record_info.file_position := file_position;
    file_instance^.residual_skip_count := residual_skip_count;
    tape_descriptor^.volume_position := volume_position;
    block_info^.block_number := block_number;
    IF call_block.skp.unit = amc$skip_tape_mark THEN
      block_info^.block_position := bac$beginning_of_block;
      block_info^.current_block_byte_address := 0;
      block_info^.current_block_length := 0;
      block_info^.residual_block_length := 0;
      gfi^.positioning_info.record_info.residual_record_length := 0;
      gfi^.positioning_info.record_info.record_length := 0;
      tape_descriptor^.put_tape_block_buffer := NIL;
      tape_descriptor^.get_tape_block_buffer := NIL;
    IFEND;

  PROCEND skip_req;
*copy bai$lrt_common_procedures
MODEND bam$lrt_ss_undef_tape_fap;
*DECK DECK=BAM$LRT_SS_VAR_TAPE_FAP EXPAND=TRUE

MODULE bam$lrt_ss_var_tape_fap;
?? LEFT := 1, RIGHT := 110 ??
? VAR user_fap: boolean := FALSE ?;
? VAR pad_records: boolean := FALSE?;
?? PUSH (LIST := OFF) ??

























?? POP ??
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
?? TITLE := 'Type definitions' ??
*copyc amt$tape_error_options
*copyc amt$file_identifier
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc bat$put_label_request
*copyc bat$record_header_type
*copyc ost$caller_identifier
*copyc bak$bap_procedure_keypoints
?? TITLE := 'Error code definitions', EJECT ??
*copyc ame$improper_file_id
*copyc ame$improper_wsl
*copyc ame$get_program_actions
*copyc ame$get_validation_errors
*copyc ame$put_program_actions
*copyc ame$put_validation_errors
*copyc ame$skip_program_actions
*copyc ame$skip_validation_errors
*copyc bae$tape_bm_error_codes
*copyc dme$tape_errors
?? OLDTITLE ??
?? EJECT ??
?? POP ??
{ The following POP pragmat is here to negate an extra push (listext :=on) in one of the bam decks. }
?? POP ??
?? TITLE := 'XREF variable and procedure definitions' ??
*copyc osv$task_private_heap
*copyc amp$set_file_instance_abnormal
*copyc bap$close
*copyc bap$tape_bm_align_position
*copyc bap$tape_bm_flush
*copyc bap$tape_bm_open
*copyc bap$tape_bm_read_label
*copyc bap$tape_bm_read_next_block
*copyc bap$tape_bm_read_to_write
*copyc bap$tape_bm_close
*copyc bap$tape_bm_write_next_block
*copyc bap$tape_bm_reserve_blk_buffer
*copyc bap$tape_bm_skip_blocks
*copyc bap$tape_bm_skip_tapemark
*copyc bap$tape_bm_rewind
*copyc bap$tape_bm_advance_volume
*copyc bap$tape_bm_erase_block
*copyc bap$tape_bm_tapemark_check
*copyc bap$tape_bm_write_tape_mark
*copyc bap$tape_bm_write_label
*copyc bap$tape_bm_write_label_mark
*copyc bap$fap_control
*copyc osp$set_status_abnormal
?? TITLE := 'INLINE function definitions' ??
?? NEWTITLE := ' ' ??
?? TITLE := 'bai$tape_descriptor', EJECT ??
*copyc bai$tape_descriptor
?? TITLE := 'bai$block_info', EJECT ??
*copyc bai$block_info
?? TITLE := 'bai$dynamic_label', EJECT ??
*copyc bai$dynamic_label
?? TITLE := 'bai$gfi', EJECT ??
*copyc bai$gfi
?? TITLE := 'bai$label_type', EJECT ??
*copyc bai$label_type
?? TITLE := 'bai$partial_block_exists', EJECT ??
*copyc bai$partial_block_exists
?? TITLE := 'bai$partial_read_block_exists', EJECT ??
*copyc bai$partial_read_block_exists
?? TITLE := 'bai$partial_record_exists', EJECT ??
*copyc bai$partial_record_exists
?? TITLE := 'bai$state_info', EJECT ??
*copyc bai$state_info
?? TITLE := 'bai$static_label', EJECT ??
*copyc bai$static_label
?? OLDTITLE ??
?? TITLE := 'INLINE procedure definitions' ??
?? NEWTITLE := ' ' ??
?? TITLE := 'osp$disestablish_cond_handler', EJECT ??
*copyc osp$disestablish_cond_handler
?? TITLE := 'osp$establish_block_exit_hndlr', EJECT ??
*copyc osp$establish_block_exit_hndlr
?? TITLE := 'bai$advance_volume', EJECT ??
*copyc bai$advance_volume
?? TITLE := 'bai$append_tape_error', EJECT ??
*copyc bai$append_tape_error
?? TITLE := 'bai$check_caller_id', EJECT ??
*copyc bai$check_caller_id
?? TITLE := 'bai$check_record_level_access', EJECT ??
*copyc bai$check_record_level_access
?? TITLE := 'bai$check_tapemark', EJECT ??
*copyc bai$check_tapemark
?? TITLE := 'bai$clear_fail_at_current_pos', EJECT ??
*copyc bai$clear_fail_at_current_pos
?? TITLE := 'bai$fetch_tape_error_options', EJECT ??
*copyc bai$fetch_tape_error_options
?? TITLE := 'bai$forced_write', EJECT ??
*copyc bai$forced_write
?? TITLE := 'bai$init_boi_tape_position', EJECT ??
*copyc bai$init_boi_tape_position
?? TITLE := 'bai$process_block_information', EJECT ??
*copyc bai$process_block_information
?? TITLE := 'bai$process_request_status', EJECT ??
*copyc bai$process_request_status
?? TITLE := 'bai$validate_tape_access', EJECT ??
*copyc bai$validate_tape_access
?? TITLE := 'bai$write_previous_block', EJECT ??
*copyc bai$write_previous_block
?? TITLE := 'bap$validate_fap_identifier', EJECT ??
*copyc bap$validate_fap_identifier
?? TITLE := 'bap$validate_file_identifier', EJECT ??
*copyc bap$validate_file_identifier
?? TITLE := 'i#move', EJECT ??
*copyc i#move
?? OLDTITLE ??
?? TITLE := 'global variables for this call of the fap', EJECT ??
*copyc bav$global_tape_fap_variables

  CONST
    pad_blocks = FALSE,
    record_headers_exist = TRUE;

?? TITLE := 'bap#lrt_ss_var_tape_fap', EJECT ??
? IF user_fap THEN
  VAR
    ttv$layer_number: [XDCL] amt$fap_layer_number := 0;

  PROCEDURE [XDCL, #GATE] bap#lrt_ss_var_tape_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    ttv$layer_number := layer_number;
    bap$lrt_ss_var_tape_fap (file_identifier, call_block, layer_number, status);

  PROCEND bap#lrt_ss_var_tape_fap;
? IFEND

?? TITLE := 'bap$lrt_ss_var_tape_fap', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$lrt_ss_var_tape_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      dynamic_label: ^bat$dynamic_label_attributes,
      i: integer,
      last_record_header_p: ^bat$record_header,
      local_status: ost$status,
      static_label: ^bat$instance_static_attributes,
      validation_ok: boolean;

    #caller_id (caller_id);
    operation := call_block.operation;
    #keypoint (osk$entry, osk$m * ((file_identifier.ordinal * 256) + operation),
          bak$sys_blk_var_rec_tape_fap);
    status.normal := TRUE;
    global_layer_number := layer_number;
    close_file_on_exit := FALSE;

  /main_program/
    BEGIN

? IF user_fap THEN
      bap$validate_fap_identifier (file_identifier, file_instance, validation_ok);
? ELSE
      bap$validate_file_identifier (file_identifier, file_instance, validation_ok);
? IFEND
      IF NOT validation_ok THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
              'bap$lrt_ss_var_tape_fap', status);
        EXIT /main_program/;
      IFEND;

      block_info := bai$block_info (file_instance);
      gfi := bai$gfi (file_instance);
      tape_descriptor := bai$tape_descriptor (file_instance);
      state_info := bai$state_info (file_instance);
      static_label := bai$static_label (file_instance);
      rhl := #SIZE(bat$record_header);
      bai$check_caller_id (file_identifier, static_label^.ring_attributes, operation, caller_id,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      bai$check_record_level_access (file_identifier, file_instance^.access_level, operation,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      dynamic_label := bai$dynamic_label (file_instance);
      bai$validate_tape_access (file_identifier, dynamic_label^.access_mode, operation, tape_descriptor,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      bai$clear_fail_at_current_pos (operation, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      tape_descriptor^.error_options := dynamic_label^.error_options;

      CASE operation OF

      = amc$close_req =
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: SS/V FAP called on CLOSE');
        IF bai$partial_block_exists () THEN
          process_previous_block (file_identifier, status);
        IFEND; { Ignore status.
        close_req (file_identifier, status);
        bap$close (file_identifier, local_status);
        IF status.normal THEN
          status := local_status;
        IFEND;
      = amc$close_volume_req =
        IF (bai$partial_block_exists()) AND (bai$label_type() = amc$unlabelled) THEN
          process_previous_block (file_identifier, status);
          IF status.normal THEN
            close_volume_req (file_identifier, status);
          IFEND;
        ELSE
          close_volume_req (file_identifier, status);
        IFEND;
        gfi^.positioning_info.record_info.residual_record_length := 0;
        file_instance^.previous_get_at_eoi := FALSE;
      = amc$erase_tape_block =
        IF bai$partial_block_exists () THEN
          process_previous_block (file_identifier, status);
          IF status.normal THEN
            erase_tape_block_req (file_identifier, call_block, status);
          ELSE
            tape_descriptor^.volume_position := amc$after_data_block;
          IFEND;
        ELSE
          erase_tape_block_req (file_identifier, call_block, status);
        IFEND;
        tape_descriptor^.last_data_operation := amc$erase_tape_block;
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$fetch_req =
        bap$fap_control (file_identifier, call_block, layer_number, status);
      = amc$flush_req =
        IF bai$partial_block_exists () THEN
          process_previous_block (file_identifier, status);
          IF status.normal THEN
            flush_req (file_identifier, status);
          IFEND;
        ELSE
          flush_req (file_identifier, status);
        IFEND;
        gfi^.positioning_info.record_info.residual_record_length := 0;
        tape_descriptor^.last_data_operation := amc$flush_req;
      = amc$get_next_req =
        get_next_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$get_next_req;
        IF status.normal AND (call_block.getn.file_position^ <> amc$eoi) THEN
          tape_descriptor^.at_eoi := FALSE;
        IFEND;
      = amc$get_partial_req =
        get_partial_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$get_partial_req;
        IF status.normal AND (call_block.getp.file_position^ <> amc$eoi) THEN
          tape_descriptor^.at_eoi := FALSE;
        IFEND;
      = amc$open_req =
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: SS/V FAP called on OPEN');
        tape_descriptor^.file_label_type := static_label^.file_label_type;
        open_req (file_identifier, call_block, layer_number, dynamic_label, status);
      = amc$put_next_req =
        IF (bai$label_type () = amc$labelled) THEN
          IF NOT state_info^.ve_wrote_ansi_file THEN
            amp$set_file_instance_abnormal (file_identifier, ame$rewrite_labels_conflict,
                  call_block.operation, ' ', status);
            RETURN;
          IFEND;
          IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
            sl_reposition_for_put_at_eoi (file_identifier, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
        put_next_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$put_next_req;
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$put_partial_req =
        IF (bai$label_type () = amc$labelled) THEN
          IF NOT state_info^.ve_wrote_ansi_file THEN
            amp$set_file_instance_abnormal (file_identifier, ame$rewrite_labels_conflict,
                  call_block.operation, ' ', status);
            RETURN;
          IFEND;
          IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
            sl_reposition_for_put_at_eoi (file_identifier, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
        put_partial_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$put_partial_req;
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$rewind_req =
        IF bai$partial_block_exists () THEN
          process_previous_block (file_identifier, status);
          IF status.normal THEN
            rewind_req (file_identifier, call_block, status);
          IFEND;
        ELSE
          rewind_req (file_identifier, call_block, status);
        IFEND;
        tape_descriptor^.last_data_operation := amc$rewind_req;
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := FALSE;
      = amc$skip_req =
        validate_skip_parameters (file_identifier, call_block, TRUE, FALSE, TRUE, FALSE, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        skip_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$skip_req;
        file_instance^.previous_get_at_eoi := FALSE;
      = amc$write_end_partition_req =
        IF (bai$label_type () = amc$labelled) THEN
          IF NOT state_info^.ve_wrote_ansi_file THEN
            amp$set_file_instance_abnormal (file_identifier, ame$rewrite_labels_conflict,
                  call_block.operation, ' ', status);
            RETURN;
          IFEND;
          IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
            sl_reposition_for_put_at_eoi (file_identifier, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
        write_end_partition_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$write_end_partition_req;
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$write_tape_mark_req =
        IF bai$label_type () = amc$labelled THEN
          amp$set_file_instance_abnormal (file_identifier, ame$improper_labelled_tape_op,
                call_block.operation, 'WRITE OF TAPE MARK', status);
          EXIT /main_program/;
        IFEND;
        IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
          last_record_header_p := NIL;
          CASE tape_descriptor^.last_data_operation OF
          = amc$get_next_req, amc$get_partial_req =
            last_record_header_p := #ADDRESS(
              #RING( tape_descriptor^.get_tape_block_buffer),
              #SEGMENT(tape_descriptor^.get_tape_block_buffer),
              gfi^.positioning_info.record_info.record_header_fba);
            CASE last_record_header_p^.header_type OF
            = bac$full_record, bac$end_record =
              last_record_header_p^.length := last_record_header_p^.length -
                gfi^.positioning_info.record_info.residual_record_length;
            = bac$start_record =
              last_record_header_p^.header_type := bac$full_record;
              last_record_header_p^.length := last_record_header_p^.length -
                gfi^.positioning_info.record_info.residual_record_length;
            = bac$continued_record =
              last_record_header_p^.header_type := bac$end_record;
              last_record_header_p^.length := last_record_header_p^.length -
                gfi^.positioning_info.record_info.residual_record_length;
            ELSE
              amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
                      operation, 'Incorrect record header in SS/V write_tape_mark', status);
              EXIT /main_program/;
            CASEND;
            block_info^.block_position := bac$middle_of_block;
            gfi^.positioning_info.record_info.file_position := amc$eor;
          ELSE
          CASEND;
        IFEND;

{   Check if last operation was read type that left tape logically at mid_block

        IF bai$partial_read_block_exists () THEN
          switch_from_read_to_write (file_identifier, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;

        IF bai$partial_block_exists () THEN
          process_previous_block (file_identifier, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;

        write_tape_mark_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$write_tape_mark_req;
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      ELSE

        bap$fap_control (file_identifier, call_block, layer_number, status);

      CASEND;

    END /main_program/;

    IF (operation >= amc$last_access_start) AND (operation <= amc$max_operation)
          AND (operation <> amc$fetch_req) AND
          (operation <> amc$fetch_access_information_rq) THEN
      gfi^.last_access_operation := operation;
    IFEND;
    IF status.normal THEN
      gfi^.error_status := 0;
    ELSE
      gfi^.error_status := status.condition;
    IFEND;

{
{   IF the operator terminates a tape assignment that was initiated via bai$advance_volume,
{   the file will be closed at this point.  It cannot be closed in bai$advance_volume since
{   the global_file_information may be referenced after the call.
{

    IF close_file_on_exit THEN
      bap$close (file_identifier, local_status);
    IFEND;

    #keypoint (osk$exit, 0, bak$sys_blk_var_rec_tape_fap);

  PROCEND bap$lrt_ss_var_tape_fap;
?? TITLE := 'get_next_req', EJECT ??

{
{ The purpose of this request is to cause the transfer of data from tape to a
{ tape buffer, transfer data from the tape buffer to the users working
{ storage area, and to update all file descriptor fields.
{

  PROCEDURE get_next_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    CONST
      allow_direct_io_transfer = FALSE;

    VAR
      data_length : 0 .. amc$maximum_block - 1,
      exit_situation : boolean,
      get_size : 0 .. amc$maximum_block - 1,
      last_record_header_p: ^bat$record_header,
      manually_advance_to_next_block: boolean,
      more_data : boolean,
      no_header_read : boolean,
      residual_data_length : 0 .. amc$maximum_block - 1,
      rh: bat$record_header,
      start_new_block : boolean,
      wsa : ^cell,
      wsl : amt$working_storage_length,
      zero_length_record : boolean;


*copy bai$get_record_header


      status.normal := TRUE;
      call_block.getn.transfer_count^ := 0;
      data_length := 0;
      exit_situation := FALSE;
      last_record_header_p := NIL;
      manually_advance_to_next_block := FALSE;
      more_data := TRUE;
      no_header_read := FALSE;
      residual_data_length := gfi^.positioning_info.record_info.residual_record_length;
      start_new_block := FALSE;
      wsa := call_block.getn.working_storage_area;
      wsl := call_block.getn.working_storage_length;
      zero_length_record := FALSE;

      IF (wsl <= 0) OR (wsl > UPPERVALUE (amt$working_storage_length)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
        operation, ' ', status);
        RETURN;
      IFEND;


{
{ Check file position to see if any partial blocks need to be written out.
{

      IF bai$partial_block_exists () THEN
        process_previous_block (file_identifier, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

  /main_program/
    BEGIN


{
{  Advance forward to the next record boundary if necessary.
{


      IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN

        REPEAT
          block_info^.current_block_byte_address :=
            block_info^.current_block_byte_address + residual_data_length;
          block_info^.residual_block_length :=
            block_info^.residual_block_length - residual_data_length;
          bai$get_record_header;
          IF (NOT status.normal) OR (no_header_read) THEN
            EXIT /main_program/;
          IFEND;
        UNTIL (rh.header_type = bac$start_record) OR
              (rh.header_type = bac$full_record) OR
              (rh.header_type = bac$partition);

        IF (zero_length_record) OR (rh.header_type = bac$partition) THEN
          EXIT /main_program/;
        IFEND;

      IFEND;


      WHILE more_data DO

        gfi^.positioning_info.record_info.transfer_count := 0;

        IF residual_data_length = 0 THEN
          bai$get_record_header;
          IF exit_situation THEN
            EXIT /main_program/;
          IFEND;
        IFEND;

        IF wsl > residual_data_length THEN
          CASE rh.header_type OF
            = bac$start_record, bac$continued_record =
                get_size := residual_data_length;
            = bac$full_record, bac$end_record =
                get_size := residual_data_length;
                more_data := FALSE;
            ELSE
              amp$set_file_instance_abnormal (file_identifier,
                ame$improper_record_header, call_block.operation,
                ' ', status);
              RETURN;
          CASEND;

        ELSE { wsl <= residual_data_length
          get_size := wsl;
          more_data := FALSE;
        IFEND;

        get_data (file_identifier, operation, wsa, get_size, allow_direct_io_transfer,
              start_new_block, {convert_if_ebcdic =} TRUE, status);
        data_length := data_length + gfi^.positioning_info.record_info.transfer_count;
        residual_data_length := residual_data_length - gfi^.positioning_info.record_info.transfer_count;
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        IF gfi^.positioning_info.record_info.transfer_count < get_size THEN
          get_size := gfi^.positioning_info.record_info.transfer_count;
        IFEND;


        wsl := wsl - get_size;
        wsa := #address (#ring (wsa), #segment (wsa), (#offset (wsa) + get_size));
      WHILEND;

    END /main_program/;

      IF (tape_descriptor^.volume_position = amc$eov) OR
         (tape_descriptor^.volume_position = amc$after_tapemark) THEN
        CASE bai$label_type() OF
        = amc$unlabelled =
          gfi^.positioning_info.record_info.file_position := amc$eoi;
          file_instance^.previous_get_at_eoi := TRUE;
          tape_descriptor^.at_eoi := TRUE;
        = amc$labelled =
          gfi^.positioning_info.record_info.file_position := amc$eoi;
          file_instance^.previous_get_at_eoi := TRUE;
        = amc$non_standard_labelled =
          gfi^.positioning_info.record_info.file_position := amc$mid_record;
        ELSE
          amp$set_file_instance_abnormal (file_identifier,
            ame$tape_rcd_mgr_malfunction, operation,
            'Unknown file_label_type in get_next_req (SS, V)', status);
        CASEND;
      ELSEIF NOT status.normal THEN
        ;
      ELSEIF zero_length_record THEN
        gfi^.positioning_info.record_info.file_position := amc$eor;
      ELSEIF manually_advance_to_next_block THEN
        ;
      ELSE
        CASE rh.header_type OF
          = bac$start_record, bac$continued_record =
            gfi^.positioning_info.record_info.file_position := amc$mid_record;

          = bac$full_record, bac$end_record =
            IF residual_data_length = 0 THEN
              gfi^.positioning_info.record_info.file_position := amc$eor;
            ELSE
              gfi^.positioning_info.record_info.file_position := amc$mid_record;
            IFEND;

          = bac$partition =
            gfi^.positioning_info.record_info.file_position := amc$eop;

          ELSE
            amp$set_file_instance_abnormal (file_identifier,
              ame$improper_record_header, call_block.operation,
              ' ', status);

        CASEND;
      IFEND;

      IF last_record_header_p <> NIL THEN
        gfi^.positioning_info.record_info.record_header_fba := #OFFSET( last_record_header_p);
      IFEND;

      gfi^.positioning_info.record_info.transfer_count := data_length;
      gfi^.positioning_info.record_info.record_length := data_length;
      gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
      call_block.getn.file_position^ := gfi^.positioning_info.record_info.file_position;
      call_block.getn.transfer_count^ := gfi^.positioning_info.record_info.transfer_count;

  PROCEND get_next_req;

?? TITLE := 'get_partial_req', EJECT ??

{
{ The purpose of this request is to cause a partial transfer of data from tape to a
{ tape buffer, transfer data from the tape buffer to the users working
{ storage area, and to update all file descriptor fields.
{

  PROCEDURE get_partial_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    CONST
      allow_direct_io_transfer = FALSE;

    VAR
      data_length : 0 .. amc$maximum_block - 1,
      exit_situation : boolean,
      get_size : 0 .. amc$maximum_block - 1,
      last_record_header_p: ^bat$record_header,
      manually_advance_to_next_block: boolean,
      more_data : boolean,
      no_header_read : boolean,
      residual_data_length : 0 .. amc$maximum_block - 1,
      rh: bat$record_header,
      start_new_block : boolean,
      wsa : ^cell,
      wsl : amt$working_storage_length,
      zero_length_record : boolean;


*copy bai$get_record_header


      status.normal := TRUE;
      call_block.getn.transfer_count^ := 0;
      data_length := 0;
      exit_situation := FALSE;
      last_record_header_p := NIL;
      manually_advance_to_next_block := FALSE;
      more_data := TRUE;
      no_header_read := FALSE;
      residual_data_length := gfi^.positioning_info.record_info.residual_record_length;
      start_new_block := FALSE;
      wsa := call_block.getp.working_storage_area;
      wsl := call_block.getp.working_storage_length;
      zero_length_record := FALSE;

      IF (wsl <= 0) OR (wsl > UPPERVALUE (amt$working_storage_length)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
        operation, ' ', status);
        RETURN;
      IFEND;

      IF (call_block.getp.skip_option < LOWERVALUE (amt$skip_option)) OR
        (call_block.getp.skip_option > UPPERVALUE (amt$skip_option)) THEN
        amp$set_file_instance_abnormal (file_identifier,
          ame$improper_skip_option, call_block.operation, ' ', status);
        RETURN;
      IFEND;

      IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
        CASE tape_descriptor^.last_data_operation OF
        = amc$get_next_req, amc$get_partial_req =
          last_record_header_p := #ADDRESS(
            #RING( tape_descriptor^.get_tape_block_buffer),
            #SEGMENT(tape_descriptor^.get_tape_block_buffer),
            gfi^.positioning_info.record_info.record_header_fba);
          rh := last_record_header_p^;

        ELSE
        CASEND;
      IFEND;

{
{ Check file position to see if any partial blocks need to be written out.
{

      IF bai$partial_block_exists () THEN
        process_previous_block (file_identifier, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        gfi^.positioning_info.record_info.record_length := 0;
      IFEND;

  /main_program/
    BEGIN


{
{  Advance forward to the next record boundary if necessary.
{


      IF call_block.getp.skip_option = amc$skip_to_eor THEN
        IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN

          REPEAT
            block_info^.current_block_byte_address :=
              block_info^.current_block_byte_address + residual_data_length;
            block_info^.residual_block_length :=
              block_info^.residual_block_length - residual_data_length;
            bai$get_record_header;
            IF NOT status.normal THEN
              EXIT /main_program/;
            ELSEIF no_header_read THEN
              gfi^.positioning_info.record_info.record_length := 0;
              EXIT /main_program/;
            IFEND;
          UNTIL (rh.header_type = bac$start_record) OR
                (rh.header_type = bac$full_record) OR
                (rh.header_type = bac$partition);

          gfi^.positioning_info.record_info.record_length := 0;

          IF (zero_length_record) OR (rh.header_type = bac$partition) THEN
            EXIT /main_program/;
          IFEND;

        IFEND;
      IFEND;

      IF gfi^.positioning_info.record_info.file_position <> amc$mid_record THEN
        gfi^.positioning_info.record_info.record_length := 0;
      IFEND;


      WHILE more_data DO

        gfi^.positioning_info.record_info.transfer_count := 0;
{ ! If prior operation = put_next or put_partial, residual_data_length = 0.    }
        IF residual_data_length = 0 THEN
          bai$get_record_header;
          IF exit_situation THEN
            EXIT /main_program/;
          IFEND;
        IFEND;

        IF wsl > residual_data_length THEN
          CASE rh.header_type OF
            = bac$start_record, bac$continued_record =
                get_size := residual_data_length;
            = bac$full_record, bac$end_record =
                get_size := residual_data_length;
                more_data := FALSE;
            ELSE
              amp$set_file_instance_abnormal (file_identifier,
                ame$improper_record_header, call_block.operation,
                ' ', status);
              RETURN;
          CASEND;

        ELSE { wsl <= residual_data_length
          get_size := wsl;
          more_data := FALSE;
        IFEND;

        get_data (file_identifier, operation, wsa, get_size, allow_direct_io_transfer,
              start_new_block, {convert_if_ebcdic =} TRUE, status);
        data_length := data_length + gfi^.positioning_info.record_info.transfer_count;
        residual_data_length := residual_data_length - gfi^.positioning_info.record_info.transfer_count;
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        IF gfi^.positioning_info.record_info.transfer_count < get_size THEN
          get_size := gfi^.positioning_info.record_info.transfer_count;
        IFEND;


        wsl := wsl - get_size;
        wsa := #address (#ring (wsa), #segment (wsa), (#offset (wsa) + get_size));
      WHILEND;

    END /main_program/;

    IF (tape_descriptor^.volume_position = amc$eov) OR
       (tape_descriptor^.volume_position = amc$after_tapemark) THEN
      CASE bai$label_type() OF
      = amc$unlabelled =
        gfi^.positioning_info.record_info.file_position := amc$eoi;
        file_instance^.previous_get_at_eoi := TRUE;
        tape_descriptor^.at_eoi := TRUE;
      = amc$labelled =
        gfi^.positioning_info.record_info.file_position := amc$eoi;
        file_instance^.previous_get_at_eoi := TRUE;
      = amc$non_standard_labelled =
        gfi^.positioning_info.record_info.file_position := amc$mid_record;
      ELSE
        amp$set_file_instance_abnormal (file_identifier,
          ame$tape_rcd_mgr_malfunction, operation,
          'Unknown file_label_type in get_next_req (SS, V)', status);
      CASEND;
    ELSEIF NOT status.normal THEN
      ;
    ELSEIF zero_length_record THEN
      gfi^.positioning_info.record_info.file_position := amc$eor;
    ELSEIF manually_advance_to_next_block THEN
      ;
    ELSE
      CASE rh.header_type OF
        = bac$start_record, bac$continued_record =
          gfi^.positioning_info.record_info.file_position := amc$mid_record;

        = bac$full_record, bac$end_record =
          IF residual_data_length = 0 THEN
            gfi^.positioning_info.record_info.file_position := amc$eor;
          ELSE
            gfi^.positioning_info.record_info.file_position := amc$mid_record;
          IFEND;

        = bac$partition =
          gfi^.positioning_info.record_info.file_position := amc$eop;

        ELSE
          amp$set_file_instance_abnormal (file_identifier,
            ame$improper_record_header, call_block.operation,
            ' ', status);

      CASEND;
    IFEND;

    IF last_record_header_p <> NIL THEN
      gfi^.positioning_info.record_info.record_header_fba := #OFFSET( last_record_header_p);
    IFEND;

    gfi^.positioning_info.record_info.transfer_count := data_length;
    gfi^.positioning_info.record_info.record_length := gfi^.positioning_info.
          record_info.record_length + data_length;
    gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
    call_block.getp.file_position^ := gfi^.positioning_info.record_info.file_position;
    call_block.getp.transfer_count^ := gfi^.positioning_info.record_info.transfer_count;
    call_block.getp.record_length^ := gfi^.positioning_info.record_info.record_length;

  PROCEND get_partial_req;

?? TITLE := 'process_previous_block', EJECT ??

  PROCEDURE process_previous_block (file_identifier: amt$file_identifier;
    VAR status: ost$status);

    VAR
      file_position: amt$file_position,
      last_record_header_p : ^bat$record_header;

      status.normal := TRUE;
      file_position := gfi^.positioning_info.record_info.file_position;
      last_record_header_p := NIL;

      IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
        last_record_header_p := #ADDRESS(
          #RING( tape_descriptor^.put_tape_block_buffer),
          #SEGMENT(tape_descriptor^.put_tape_block_buffer),
          gfi^.positioning_info.record_info.record_header_fba);
        CASE last_record_header_p^.header_type OF
        = bac$start_record =
          last_record_header_p^.header_type := bac$full_record;
          file_position := amc$eor;
        = bac$continued_record =
          last_record_header_p^.header_type := bac$end_record;
          file_position := amc$eor;
        ELSE
        CASEND;
      IFEND;

      bai$write_previous_block (file_identifier, status);
{ !   gfi^.positioning_info.record_info.file_position returned from bai$write_previous_block will always
{     = amc$eor due to oversight of ss/v environment.
{     All instances of calls in all of the tape faps should be changed to
{     set the appropriate file_position after returning from the call.
      IF status.normal THEN
        gfi^.positioning_info.record_info.file_position := file_position;
{       file_position = amc$eor or amc$eop.
      IFEND;


  PROCEND process_previous_block;


?? TITLE := 'put_next_req', EJECT ??

{
{ The purpose of this request is to transfer data from the users
{ working storage area to a tape file, either directly, or through
{ a tape buffer, and to update all file descriptor fields.
{


  PROCEDURE put_next_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      data_length : 0 .. amc$maximum_block - 1,
      end_of_data : boolean,
      last_record_header_p: ^bat$record_header,
      max_data_size : 0 .. amc$maximum_block - 1,
      more_data : boolean,
      put_size : 0 .. amc$maximum_block - 1,
      rh : bat$record_header,
      start_of_data : boolean,
      term_option : amt$term_option,
      terminate_previous_block : boolean,
      wsa : ^cell,
      wsl : amt$working_storage_length;


*copy bai$put_record_header_for_putn


  /main_program/
    BEGIN

      status.normal := TRUE;
      data_length := 0;
      end_of_data := FALSE;
      last_record_header_p := NIL;
      max_data_size := gfi^.max_data_size;
      more_data := TRUE;
      start_of_data := TRUE;
      wsa := call_block.putn.working_storage_area;
      wsl := call_block.putn.working_storage_length;

      IF (wsl < 0) OR (wsl > UPPERVALUE (amt$working_storage_length)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
        operation, ' ', status);
        RETURN;
      IFEND;

       IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
         CASE tape_descriptor^.last_data_operation OF
         = amc$get_next_req, amc$get_partial_req =
           last_record_header_p := #ADDRESS(
             #RING( tape_descriptor^.get_tape_block_buffer),
             #SEGMENT(tape_descriptor^.get_tape_block_buffer),
             gfi^.positioning_info.record_info.record_header_fba);
           CASE last_record_header_p^.header_type OF
           = bac$full_record, bac$end_record =
             last_record_header_p^.length := last_record_header_p^.length -
               gfi^.positioning_info.record_info.residual_record_length;
           = bac$start_record =
             last_record_header_p^.header_type := bac$full_record;
             last_record_header_p^.length := last_record_header_p^.length -
               gfi^.positioning_info.record_info.residual_record_length;
           = bac$continued_record =
             last_record_header_p^.header_type := bac$end_record;
             last_record_header_p^.length := last_record_header_p^.length -
               gfi^.positioning_info.record_info.residual_record_length;
           ELSE
             amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
                     operation, 'Incorrect record header in SS/V put_next_req', status);
             RETURN;
           CASEND;
           block_info^.block_position := bac$middle_of_block;

         = amc$put_partial_req =
           last_record_header_p := #ADDRESS(
             #RING( tape_descriptor^.put_tape_block_buffer),
             #SEGMENT(tape_descriptor^.put_tape_block_buffer),
             gfi^.positioning_info.record_info.record_header_fba);
           CASE last_record_header_p^.header_type OF
           = bac$start_record =
             last_record_header_p^.header_type := bac$full_record;
           = bac$continued_record =
             last_record_header_p^.header_type := bac$end_record;
           ELSE
           CASEND;
         ELSE
         CASEND;
       IFEND;

{   Check if last operation was read type that left tape logically at mid_block

       IF bai$partial_read_block_exists () THEN
         switch_from_read_to_write (file_identifier, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;
       IFEND;

        WHILE more_data DO
          IF (bai$partial_block_exists ()) AND
            (rhl <= block_info^.residual_block_length) THEN
            terminate_previous_block := FALSE;

            IF rhl + wsl <= block_info^.residual_block_length THEN
              put_size := wsl;
              end_of_data := TRUE;
{ ! Never attempt to flush the current block in case the next request needs    }
{   to examine the last record header.                                         }
              term_option := amc$continue;
              bai$put_record_header_for_putn;
              IF (wsl = 0) OR (NOT status.normal) THEN
                EXIT /main_program/;
              IFEND;
{ ! Never attempt to flush the current block in case the next request needs    }
{   to examine the last record header.                                         }
              term_option := amc$continue;
              more_data := FALSE;

            ELSE { rhl + wsl > block_info^.residual_block_length
              IF rhl = block_info^.residual_block_length THEN
{ ! Don't put header only in block when wsl <> 0.                             }
                term_option := amc$terminate;
                put_size := 0;
              ELSE
                put_size := block_info^.residual_block_length - rhl;
{               end_of_data := FALSE;
                term_option := amc$continue;
                bai$put_record_header_for_putn;
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
{ ! Never attempt to flush the current block in case the next request          }
{   hits EOT. (labelled tapes)                                                 }
                term_option := amc$continue;

              IFEND;
            IFEND;
          ELSE
            terminate_previous_block := TRUE;

            IF rhl + wsl <= max_data_size THEN
              put_size := wsl;
              end_of_data := TRUE;
              term_option := amc$start;
              bai$put_record_header_for_putn;
              IF (wsl = 0) OR (NOT status.normal) THEN
                EXIT /main_program/;
              IFEND;
              terminate_previous_block := FALSE;
              term_option := amc$continue;
              more_data := FALSE;

            ELSE { rhl + wsl > max_data_size
              put_size := max_data_size - rhl;
{             end_of_data := FALSE;
              term_option := amc$start;
              bai$put_record_header_for_putn;
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              terminate_previous_block := FALSE;
{ ! Never attempt to flush the current block in case the next request          }
{   hits EOT. (labelled tapes)                                                 }
              term_option := amc$continue;

            IFEND;
          IFEND;

          put_data (file_identifier, operation, wsa, put_size, term_option,
                terminate_previous_block, {convert_if_ebcdic =} TRUE, status);

          IF NOT status.normal THEN
            IF (status.condition = ame$end_of_tape_op_completed) THEN
              data_length := data_length + put_size;
            IFEND;
            EXIT /main_program/;
          IFEND;

          data_length := data_length + put_size;
          wsl := wsl - put_size;
          wsa := #address (#ring (wsa), #segment (wsa), (#offset (wsa) + put_size));
        WHILEND;

    END /main_program/;

    state_info^.put_op := TRUE;

{ The following check will set file_position to mid_record if an abnormal condition
{ occurred (such as unrecovered write error).  End of tape errors will never happen
{ for labelled or unlabelled operations.  If label type is non_standard, the file is
{ really at EOR if the error is ame$end_of_tape_op_completed and end_of_data = TRUE.

    IF NOT status.normal THEN
      IF (status.condition = ame$end_of_tape_op_completed) AND (end_of_data) THEN
        gfi^.positioning_info.record_info.file_position := amc$eor;
      ELSE
        gfi^.positioning_info.record_info.file_position := amc$mid_record;
      IFEND;
    ELSE
      gfi^.positioning_info.record_info.file_position := amc$eor;
    IFEND;

    IF last_record_header_p <> NIL THEN
      gfi^.positioning_info.record_info.record_header_fba := #OFFSET( last_record_header_p);
    IFEND;

    gfi^.positioning_info.record_info.transfer_count := data_length;
    gfi^.positioning_info.record_info.record_length := data_length;
    gfi^.positioning_info.record_info.residual_record_length := 0;

  PROCEND put_next_req;


?? TITLE := 'put_partial_req', EJECT ??


  PROCEDURE put_partial_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      data_length : 0 .. amc$maximum_block - 1,
      end_of_data : boolean,
      last_record_header_p: ^bat$record_header,
      max_data_size : 0 .. amc$maximum_block - 1,
      more_data : boolean,
      put_size : 0 .. amc$maximum_block - 1,
      rh: bat$record_header,
      start_of_data : boolean,
      term_option : amt$term_option,
      terminate_previous_block : boolean,
      wsa : ^cell,
      wsl : amt$working_storage_length;


*copy bai$put_record_header_for_putp


  /main_program/
      BEGIN

        status.normal := TRUE;
        data_length := 0;
        end_of_data := FALSE;
        last_record_header_p := NIL;
        max_data_size := gfi^.max_data_size;
        more_data := TRUE;
        start_of_data := TRUE;
        wsa := call_block.putp.working_storage_area;
        wsl := call_block.putp.working_storage_length;


        IF (wsl < 0) OR (wsl > UPPERVALUE (amt$working_storage_length)) THEN
          amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
          operation, ' ', status);
          RETURN;
        IFEND;

        IF (call_block.putp.term_option < LOWERVALUE (amt$term_option)) OR
           (call_block.putp.term_option > UPPERVALUE (amt$term_option)) THEN
          amp$set_file_instance_abnormal (file_identifier,
            ame$improper_term_option, call_block.operation, ' ',
            status);
          RETURN;
        IFEND;

        CASE call_block.putp.term_option OF

        = amc$start =
          CASE tape_descriptor^.last_data_operation OF
          = amc$get_next_req, amc$get_partial_req =
            last_record_header_p := #ADDRESS(
              #RING( tape_descriptor^.get_tape_block_buffer),
              #SEGMENT(tape_descriptor^.get_tape_block_buffer),
              gfi^.positioning_info.record_info.record_header_fba);
            CASE last_record_header_p^.header_type OF
            = bac$full_record, bac$end_record =
              last_record_header_p^.length := last_record_header_p^.length -
                gfi^.positioning_info.record_info.residual_record_length;
              block_info^.block_position := bac$middle_of_block;
            = bac$start_record =
              last_record_header_p^.header_type := bac$full_record;
              last_record_header_p^.length := last_record_header_p^.length -
                gfi^.positioning_info.record_info.residual_record_length;
              block_info^.block_position := bac$middle_of_block;
            = bac$continued_record =
              last_record_header_p^.header_type := bac$end_record;
              last_record_header_p^.length := last_record_header_p^.length -
                gfi^.positioning_info.record_info.residual_record_length;
              block_info^.block_position := bac$middle_of_block;
            ELSE
            CASEND;
          = amc$put_next_req, amc$put_partial_req =
            last_record_header_p := #ADDRESS(
              #RING( tape_descriptor^.put_tape_block_buffer),
              #SEGMENT(tape_descriptor^.put_tape_block_buffer),
              gfi^.positioning_info.record_info.record_header_fba);
            CASE last_record_header_p^.header_type OF
{           = bac$full_record, bac$end_record =
            = bac$start_record =
              last_record_header_p^.header_type := bac$full_record;
            = bac$continued_record =
              last_record_header_p^.header_type := bac$end_record;
            ELSE
            CASEND;
          ELSE
          CASEND;

        = amc$continue =
          IF gfi^.positioning_info.record_info.file_position <> amc$mid_record THEN
            amp$set_file_instance_abnormal (file_identifier, ame$improper_continue,
              operation, ' ', status);
            RETURN;
          IFEND;
          CASE tape_descriptor^.last_data_operation OF
          = amc$get_next_req, amc$get_partial_req =
            last_record_header_p := #ADDRESS(
              #RING( tape_descriptor^.get_tape_block_buffer),
              #SEGMENT(tape_descriptor^.get_tape_block_buffer),
              gfi^.positioning_info.record_info.record_header_fba);
            CASE last_record_header_p^.header_type OF
            = bac$full_record =
              last_record_header_p^.header_type := bac$start_record;
              last_record_header_p^.length := last_record_header_p^.length -
                gfi^.positioning_info.record_info.residual_record_length;
            = bac$start_record, bac$continued_record =
              last_record_header_p^.length := last_record_header_p^.length -
                gfi^.positioning_info.record_info.residual_record_length;
            = bac$end_record =
              last_record_header_p^.header_type := bac$continued_record;
              last_record_header_p^.length := last_record_header_p^.length -
                gfi^.positioning_info.record_info.residual_record_length;
            ELSE
              amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
                      operation, 'Incorrect record header in SS/V put_partial_req', status);
              RETURN;
            CASEND;
            block_info^.block_position := bac$middle_of_block;
{         = amc$put_next_req, amc$put_partial_req =
{           last_record_header_p := #ADDRESS(
{             #RING( tape_descriptor^.put_tape_block_buffer),
{             #SEGMENT(tape_descriptor^.put_tape_block_buffer),
{             gfi^.positioning_info.record_info.record_header_fba);
{           CASE last_record_header_p^.header_type OF
{           = bac$full_record =
{           = bac$start_record =
{           = bac$continued_record =
{           = bac$end_record =
{           ELSE
{           CASEND;
          ELSE
          CASEND;

        = amc$terminate =
          CASE tape_descriptor^.last_data_operation OF
          = amc$get_next_req, amc$get_partial_req =
            last_record_header_p := #ADDRESS(
              #RING( tape_descriptor^.get_tape_block_buffer),
              #SEGMENT(tape_descriptor^.get_tape_block_buffer),
              gfi^.positioning_info.record_info.record_header_fba);
            CASE last_record_header_p^.header_type OF
            = bac$full_record =
              IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
                last_record_header_p^.header_type := bac$start_record;
                last_record_header_p^.length := last_record_header_p^.length -
                  gfi^.positioning_info.record_info.residual_record_length;
                block_info^.block_position := bac$middle_of_block;
              IFEND;
            = bac$start_record, bac$continued_record =
              last_record_header_p^.length := last_record_header_p^.length -
                gfi^.positioning_info.record_info.residual_record_length;
              block_info^.block_position := bac$middle_of_block;
            = bac$end_record =
              IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
                last_record_header_p^.header_type := bac$continued_record;
                last_record_header_p^.length := last_record_header_p^.length -
                  gfi^.positioning_info.record_info.residual_record_length;
                block_info^.block_position := bac$middle_of_block;
              IFEND;
            ELSE
            CASEND;
{         = amc$put_next_req, amc$put_partial_req =
{           last_record_header_p := #ADDRESS(
{             #RING( tape_descriptor^.put_tape_block_buffer),
{             #SEGMENT(tape_descriptor^.put_tape_block_buffer),
{             gfi^.positioning_info.record_info.record_header_fba);
{           CASE last_record_header_p^.header_type OF
{           = bac$full_record =
{           = bac$start_record =
{           = bac$continued_record =
{           = bac$end_record =
{           ELSE
{           CASEND;
          ELSE
          CASEND;
        ELSE
        CASEND;

{   Check if last operation was read type that left tape logically at mid_block

        IF bai$partial_read_block_exists () THEN
          switch_from_read_to_write (file_identifier, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        WHILE more_data DO
          IF (bai$partial_block_exists ()) AND
            (rhl <= block_info^.residual_block_length) THEN
            terminate_previous_block := FALSE;

            IF rhl + wsl <= block_info^.residual_block_length THEN
              put_size := wsl;
              end_of_data := TRUE;
{ ! Never attempt to flush the current block in case the next request needs    }
{   to alter the last record header.                                           }
              term_option := amc$continue;
              bai$put_record_header_for_putp;
              IF (wsl = 0) OR (NOT status.normal) THEN
                EXIT /main_program/;
              IFEND;
{ ! Never attempt to flush the current block in case the next request needs    }
{   to alter the last record header.                                           }
              term_option := amc$continue;
              more_data := FALSE;

            ELSE { rhl + wsl > block_info^.residual_block_length
              IF rhl = block_info^.residual_block_length THEN
{ ! Don't put header only in block when wsl <> 0.                             }
                term_option := amc$terminate;
                put_size := 0;
              ELSE
                put_size := block_info^.residual_block_length - rhl;
{               end_of_data := FALSE;
                term_option := amc$continue;
                bai$put_record_header_for_putp;
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
{ ! Never attempt to flush the current block in case the next request          }
{   hits EOT. (labelled tapes)                                                 }
                term_option := amc$continue;

              IFEND;
            IFEND;
          ELSE
            terminate_previous_block := TRUE;

            IF rhl + wsl <= max_data_size THEN
              put_size := wsl;
              end_of_data := TRUE;
              term_option := amc$start;
              bai$put_record_header_for_putp;
              IF (wsl = 0) OR (NOT status.normal) THEN
                EXIT /main_program/;
              IFEND;
              terminate_previous_block := FALSE;
              term_option := amc$continue;
              more_data := FALSE;

            ELSE { rhl + wsl > max_data_size
              put_size := max_data_size - rhl;
{             end_of_data := FALSE;
              term_option := amc$start;
              bai$put_record_header_for_putp;
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              terminate_previous_block := FALSE;
{ ! Never attempt to flush the current block in case the next request          }
{   hits EOT. (labelled tapes)                                                 }
              term_option := amc$continue;

            IFEND;
          IFEND;

          put_data (file_identifier, operation, wsa, put_size, term_option,
                terminate_previous_block, {convert_if_ebcdic =} TRUE, status);

          IF NOT status.normal THEN
            IF (status.condition = ame$end_of_tape_op_completed) THEN
              data_length := data_length + put_size;
            IFEND;
            EXIT /main_program/;
          IFEND;

          data_length := data_length + put_size;
          wsl := wsl - put_size;
          wsa := #address (#ring (wsa), #segment (wsa), (#offset (wsa) + put_size));
        WHILEND;


      END /main_program/;

      state_info^.put_op := TRUE;

      IF call_block.putp.term_option = amc$start THEN
        gfi^.positioning_info.record_info.file_position := amc$mid_record;
        gfi^.positioning_info.record_info.record_length := data_length;
      ELSEIF call_block.putp.term_option = amc$continue THEN
        gfi^.positioning_info.record_info.file_position := amc$mid_record;
        gfi^.positioning_info.record_info.record_length := gfi^.positioning_info.
              record_info.record_length + data_length;
      ELSE {amc$terminate}
        IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
          gfi^.positioning_info.record_info.record_length := gfi^.positioning_info.
                record_info.record_length + data_length;
        ELSE
          gfi^.positioning_info.record_info.record_length := data_length;
        IFEND;
        gfi^.positioning_info.record_info.file_position := amc$eor;
      IFEND;

{ The following check will set file_position to mid_record if an abnormal condition
{ occurred (such as unrecovered write error).  End of tape errors will never happen
{ for labelled or unlabelled operations.  If label type is non_standard, the file
{ position is as computed above if the error is ame$end_of_tape_op_completed and
{ end_of_data = TRUE.

      IF NOT status.normal THEN
        IF NOT ((status.condition = ame$end_of_tape_op_completed) AND (end_of_data)) THEN
          gfi^.positioning_info.record_info.file_position := amc$mid_record;
        IFEND;
      IFEND;

      IF last_record_header_p <> NIL THEN
        gfi^.positioning_info.record_info.record_header_fba := #OFFSET( last_record_header_p);
      IFEND;

      gfi^.positioning_info.record_info.transfer_count := data_length;
      gfi^.positioning_info.record_info.residual_record_length := 0;

  PROCEND put_partial_req;

?? TITLE := 'skip_req', EJECT ??

  PROCEDURE skip_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      block_number: 0 .. amc$max_block_number,
      direction: amt$skip_direction,
      error_action: bat$error_actions,
      file_position: amt$file_position,
      last_record_header_p: ^bat$record_header,
      manually_advance_to_next_block: boolean,
      next_record_header_p: ^bat$record_header,
      no_header_read: boolean,
      records_remaining: amt$skip_count,
      request_status: ost$status,
      residual_data_length: 0 .. amc$maximum_block -1,
      residual_skip_count: amt$skip_count,
      rh: bat$record_header,
      skip_zero_completed: boolean,
      tape_failure_modes: amt$tape_failure_modes,
      units_to_skip: amt$skip_count,
      volume_position: amt$volume_position;


*copy bai$skip_to_next_record_header


  /main_program/
    BEGIN

      status.normal := TRUE;
      block_number := block_info^.block_number;
      direction := call_block.skp.direction;
      units_to_skip := call_block.skp.count;
      volume_position := tape_descriptor^.volume_position;

{
{ Check file position to see if any partial blocks need to be written out.
{

      IF bai$partial_block_exists () THEN
        process_previous_block (file_identifier, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;


      CASE call_block.skp.unit OF

?? NEWTITLE := '    skip partition', EJECT ??

      = amc$skip_partition =

        last_record_header_p := NIL;
        no_header_read := FALSE;
        residual_data_length := gfi^.positioning_info.record_info.residual_record_length;
        residual_skip_count := units_to_skip;

        CASE tape_descriptor^.last_data_operation OF
        = amc$get_next_req, amc$get_partial_req =
          last_record_header_p := #ADDRESS(
            #RING( tape_descriptor^.get_tape_block_buffer),
            #SEGMENT(tape_descriptor^.get_tape_block_buffer),
            gfi^.positioning_info.record_info.record_header_fba);

        ELSE
        CASEND;

        CASE direction OF
        = amc$forward =

/skip_partition_forward/
  BEGIN
          skip_zero_completed := FALSE;
          CASE gfi^.positioning_info.record_info.file_position OF
          = amc$bop, amc$eop, amc$boi, amc$eoi =
            ;
          ELSE
            REPEAT
              IF residual_data_length = 0 THEN
                bai$skip_to_next_record_header;
                IF (no_header_read) OR (NOT status.normal) THEN
                  EXIT /skip_partition_forward/;
                IFEND;
              IFEND;
              block_info^.current_block_byte_address :=
                block_info^.current_block_byte_address + residual_data_length;
              block_info^.residual_block_length :=
                block_info^.residual_block_length - residual_data_length;
              residual_data_length := 0;
            UNTIL (last_record_header_p^.header_type = bac$partition);
            gfi^.positioning_info.record_info.file_position := amc$bop;
          CASEND;
          skip_zero_completed := TRUE;

          IF units_to_skip = 0 THEN
            call_block.skp.file_position^ := gfi^.positioning_info.record_info.file_position;
            file_instance^.residual_skip_count := residual_skip_count;
            gfi^.positioning_info.record_info.record_length := 0;
            gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
            gfi^.positioning_info.record_info.transfer_count := 0;
            RETURN;
          IFEND;

          IF gfi^.positioning_info.record_info.file_position = amc$eoi THEN
            call_block.skp.file_position^ := gfi^.positioning_info.record_info.file_position;
            file_instance^.residual_skip_count := residual_skip_count;
            gfi^.positioning_info.record_info.record_length := 0;
            gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
            gfi^.positioning_info.record_info.transfer_count := 0;
            amp$set_file_instance_abnormal (file_identifier,
              ame$skip_encountered_eoi, operation, 'PARTITIONS', status);
            RETURN;
          IFEND;

          WHILE residual_skip_count > 0 DO
            REPEAT
              bai$skip_to_next_record_header;
              IF (no_header_read) OR (NOT status.normal) THEN
                EXIT /skip_partition_forward/;
              IFEND;
              block_info^.current_block_byte_address :=
                block_info^.current_block_byte_address + residual_data_length;
              block_info^.residual_block_length :=
                block_info^.residual_block_length - residual_data_length;
              residual_data_length := 0;
            UNTIL (last_record_header_p^.header_type = bac$partition);
            residual_skip_count := residual_skip_count - 1;
          WHILEND;
          gfi^.positioning_info.record_info.file_position := amc$bop;

          call_block.skp.file_position^ := gfi^.positioning_info.record_info.file_position;
          file_instance^.residual_skip_count := residual_skip_count;
          gfi^.positioning_info.record_info.record_length := 0;
          gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
          gfi^.positioning_info.record_info.transfer_count := 0;
          RETURN;

END /skip_partition_forward/;

{ If this point is reached, an error condition (such as unrecovered read error or
{ tapemark encountered) has occurred.

          IF (units_to_skip = 0) AND status.normal THEN
            IF (tape_descriptor^.volume_position = amc$eov) OR
               (tape_descriptor^.volume_position = amc$after_tapemark) THEN
              IF bai$label_type () = amc$unlabelled THEN
                gfi^.positioning_info.record_info.file_position := amc$eoi;
              ELSEIF bai$label_type () = amc$labelled THEN
                gfi^.positioning_info.record_info.file_position := amc$eoi;
                amp$set_file_instance_abnormal (file_identifier,
                  ame$skip_encountered_eoi, operation, 'PARTITIONS', status);
              ELSE  { label_type = amc$non_standard_labelled
                gfi^.positioning_info.record_info.file_position := amc$mid_record;
                amp$set_file_instance_abnormal (file_identifier,
                  ame$skip_encountered_eoi, operation, 'PARTITIONS', status);
              IFEND;
            IFEND;
          IFEND;

          IF (residual_skip_count > 0) AND status.normal THEN
            IF (tape_descriptor^.volume_position = amc$eov) OR
               (tape_descriptor^.volume_position = amc$after_tapemark) THEN
              IF bai$label_type () = amc$unlabelled THEN
{ If skip_zero_completed, decrement 1 from residual skip count since eoi =
{ logical eop.
                IF skip_zero_completed THEN
                  residual_skip_count := residual_skip_count - 1;
                IFEND;
                gfi^.positioning_info.record_info.file_position := amc$eoi;
                IF residual_skip_count > 0 THEN
                  amp$set_file_instance_abnormal (file_identifier,
                    ame$skip_encountered_eoi, operation, 'PARTITIONS', status);
                IFEND;

              ELSEIF bai$label_type () = amc$labelled THEN
{ If skip_zero_completed, decrement 1 from residual skip count since eoi =
{ logical eop.
                IF skip_zero_completed THEN
                  residual_skip_count := residual_skip_count - 1;
                IFEND;
                gfi^.positioning_info.record_info.file_position := amc$eoi;
                IF residual_skip_count > 0 THEN
                  amp$set_file_instance_abnormal (file_identifier,
                        ame$skip_encountered_eoi, operation, 'PARTITIONS', status);
                IFEND;
              ELSE  { amc$non_standard_labelled
                IF skip_zero_completed THEN
                  gfi^.positioning_info.record_info.file_position := amc$eop;
                ELSE
                  gfi^.positioning_info.record_info.file_position := amc$mid_record;
                IFEND;
              IFEND;
            IFEND;
          IFEND;

          call_block.skp.file_position^ := gfi^.positioning_info.record_info.file_position;
          file_instance^.residual_skip_count := residual_skip_count;
          gfi^.positioning_info.record_info.record_length := 0;
          gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
          gfi^.positioning_info.record_info.transfer_count := 0;
          RETURN;

        ELSE

        CASEND;

?? TITLE := '    skip record', EJECT ??

      = amc$skip_record =

        last_record_header_p := NIL;
        no_header_read := FALSE;
        residual_data_length := gfi^.positioning_info.record_info.residual_record_length;
        residual_skip_count := units_to_skip;

        CASE tape_descriptor^.last_data_operation OF
        = amc$get_next_req, amc$get_partial_req =
          last_record_header_p := #ADDRESS(
            #RING( tape_descriptor^.get_tape_block_buffer),
            #SEGMENT(tape_descriptor^.get_tape_block_buffer),
            gfi^.positioning_info.record_info.record_header_fba);

        ELSE
        CASEND;

        CASE direction OF
        = amc$forward =

/skip_record_forward/
  BEGIN
          skip_zero_completed := FALSE;

          IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
            REPEAT
              IF residual_data_length = 0 THEN
                bai$skip_to_next_record_header;
                IF (no_header_read) OR (NOT status.normal) THEN
                  EXIT /skip_record_forward/;
                IFEND;
              IFEND;
              block_info^.current_block_byte_address :=
                block_info^.current_block_byte_address + residual_data_length;
              block_info^.residual_block_length :=
                block_info^.residual_block_length - residual_data_length;
              residual_data_length := 0;
            UNTIL (last_record_header_p^.header_type = bac$full_record) OR
                  (last_record_header_p^.header_type = bac$end_record);
            gfi^.positioning_info.record_info.file_position := amc$eor;
          IFEND;

          skip_zero_completed := TRUE;

          IF units_to_skip = 0 THEN
            call_block.skp.file_position^ := gfi^.positioning_info.record_info.file_position;
            file_instance^.residual_skip_count := residual_skip_count;
            gfi^.positioning_info.record_info.record_length := 0;
            gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
            gfi^.positioning_info.record_info.transfer_count := 0;
            RETURN;
          IFEND;


          WHILE residual_skip_count > 0 DO
            REPEAT
              bai$skip_to_next_record_header;
              IF (no_header_read) OR (NOT status.normal) THEN
                EXIT /skip_record_forward/;
              IFEND;
              block_info^.current_block_byte_address :=
                block_info^.current_block_byte_address + residual_data_length;
              block_info^.residual_block_length :=
                block_info^.residual_block_length - residual_data_length;
              residual_data_length := 0;
            UNTIL (last_record_header_p^.header_type = bac$full_record) OR
                  (last_record_header_p^.header_type = bac$end_record) OR
                  (last_record_header_p^.header_type = bac$partition);

            IF last_record_header_p^.header_type = bac$partition THEN
              gfi^.positioning_info.record_info.file_position := amc$bop;
              amp$set_file_instance_abnormal (file_identifier,
                ame$skip_encountered_eop, operation, 'RECORDS', status);
              EXIT /skip_record_forward/;
            IFEND;

            residual_skip_count := residual_skip_count - 1;
          WHILEND;
          gfi^.positioning_info.record_info.file_position := amc$eor;

          call_block.skp.file_position^ := gfi^.positioning_info.record_info.file_position;
          file_instance^.residual_skip_count := residual_skip_count;
          gfi^.positioning_info.record_info.record_length := 0;
          gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
          gfi^.positioning_info.record_info.transfer_count := 0;
          RETURN;

END /skip_record_forward/;

{ If this point is reached, an error condition (such as unrecovered read error or
{ tapemark encountered) has occurred.

          IF NOT status.normal THEN
            ;
          ELSEIF (units_to_skip = 0) OR (residual_skip_count > 0) THEN
            IF (tape_descriptor^.volume_position = amc$eov) OR
               (tape_descriptor^.volume_position = amc$after_tapemark) THEN
              IF bai$label_type () = amc$unlabelled THEN
{ ! This should never happen. In case it does, set file_position to eoi and
{   set status abnormal.
                gfi^.positioning_info.record_info.file_position := amc$eoi;
              ELSEIF bai$label_type () = amc$labelled THEN
                gfi^.positioning_info.record_info.file_position := amc$eoi;
              ELSE { label_type = amc$non_standard_labelled
                IF skip_zero_completed THEN
                  gfi^.positioning_info.record_info.file_position := amc$eor;
                ELSE
                  gfi^.positioning_info.record_info.file_position := amc$mid_record;
                IFEND;
              IFEND;
              amp$set_file_instance_abnormal (file_identifier,
                ame$skip_encountered_eoi, operation, 'RECORDS', status);
            IFEND;
          IFEND;

          call_block.skp.file_position^ := gfi^.positioning_info.record_info.file_position;
          file_instance^.residual_skip_count := residual_skip_count;
          gfi^.positioning_info.record_info.record_length := 0;
          gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
          gfi^.positioning_info.record_info.transfer_count := 0;

          RETURN;

        ELSE

        CASEND;


?? TITLE := '    skip tape marks', EJECT ??

      = amc$skip_tape_mark =

        IF units_to_skip = 0 THEN {no-op.}
          file_instance^.residual_skip_count := 0;
          call_block.skp.file_position^ := gfi^.positioning_info.record_info.file_position;
          RETURN;
        IFEND;

        residual_skip_count := units_to_skip;
        file_position := gfi^.positioning_info.record_info.file_position;

/skip_tapemark_main/
BEGIN

        IF direction = amc$forward THEN

        /whileloop/
          WHILE residual_skip_count > 0 DO

            REPEAT
              bap$tape_bm_skip_tapemark (file_identifier, direction, tape_failure_modes, request_status);
              bai$process_request_status (file_identifier, operation, request_status,
                    tape_failure_modes, error_action, status);
              IF NOT status.normal AND (status.condition = ame$input_after_output) THEN
                file_position := amc$eoi;
                volume_position := amc$eov;
                amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi, operation,
                        'TAPEMARKS', status);
                EXIT /skip_tapemark_main/;
              IFEND;
              IF error_action = bac$exit_procedure THEN
                EXIT /skip_tapemark_main/;
              IFEND;
            UNTIL error_action <> bac$retry_last_request;

            IF bai$label_type () = amc$unlabelled THEN
              bai$check_tapemark (file_identifier, volume_position, request_status);
              bai$process_request_status (file_identifier, operation, request_status,
                    tape_failure_modes, error_action, status);
              IF NOT status.normal OR (error_action = bac$exit_procedure) THEN
                EXIT /skip_tapemark_main/;
              IFEND;
              CASE volume_position OF
              = amc$after_tapemark =
                residual_skip_count := residual_skip_count - 1;
              = amc$eov =
                bai$advance_volume (file_identifier, volume_position, status);
                IF NOT status.normal THEN
                  EXIT /skip_tapemark_main/;
                IFEND;
                IF volume_position = amc$eov THEN
                  EXIT /whileloop/;
                IFEND;
              ELSE
                ;
              CASEND;
            ELSE { label_type <> amc$unlabelled     }

{
{ Since skipping by tapemarks is illegal on labelled tapes, this call must be for non_standard labels.
{
{ Consecutive tapemarks indicate a null file, not end of volume, and each tapemark needs to be skipped.
{

              residual_skip_count := residual_skip_count - 1;

            IFEND;

          WHILEND /whileloop/;

          IF residual_skip_count > 0 THEN
            amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi, operation,
              'TAPEMARKS', status);
          IFEND;
          IF status.normal THEN
            file_position := amc$boi;
            volume_position := amc$after_tapemark;
          ELSE
            file_position := amc$eoi;
            volume_position := amc$eov;
          IFEND;

        ELSE { direction = amc$backward }

          /backloop/
            WHILE residual_skip_count > 0 DO

              REPEAT
                bap$tape_bm_skip_tapemark (file_identifier, direction, tape_failure_modes, request_status);
                bai$process_request_status (file_identifier, operation, request_status,
                      tape_failure_modes, error_action, status);
                IF error_action = bac$exit_procedure THEN
                  EXIT /skip_tapemark_main/;
                IFEND;
                IF NOT status.normal AND (status.condition = ame$skip_encountered_bov) THEN
                  EXIT /backloop/;
                IFEND;
                IF status.normal THEN
                  residual_skip_count := residual_skip_count - 1;
                IFEND;
              UNTIL error_action <> bac$retry_last_request;

            WHILEND /backloop/;

            IF residual_skip_count > 0 THEN
              amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_bov, operation,
                'TAPEMARKS', status);
            IFEND;
            IF status.normal THEN
              file_position := amc$eoi;
              volume_position := amc$before_tapemark;
            ELSE
              file_position := amc$boi;
              volume_position := amc$bov;
            IFEND;
        IFEND;

        block_number := 1;

END /skip_tapemark_main/;

        call_block.skp.file_position^ := file_position;
        gfi^.positioning_info.record_info.file_position := file_position;
        file_instance^.residual_skip_count := residual_skip_count;
        tape_descriptor^.volume_position := volume_position;
        block_info^.block_number := block_number;
        block_info^.block_position := bac$beginning_of_block;
        block_info^.current_block_byte_address := 0;
        block_info^.current_block_length := 0;
        block_info^.residual_block_length := 0;
        gfi^.positioning_info.record_info.residual_record_length := 0;
        gfi^.positioning_info.record_info.record_length := 0;
        tape_descriptor^.put_tape_block_buffer := NIL;
        tape_descriptor^.get_tape_block_buffer := NIL;



?? OLDTITLE ??
      ELSE
      CASEND;

    END /main_program/;


  PROCEND skip_req;

?? TITLE := 'write_end_partition_req', EJECT ??

  PROCEDURE write_end_partition_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      last_record_header_p: ^bat$record_header,
      rh : bat$record_header,
      term_option : amt$term_option,
      terminate_previous_block : boolean;

  /main_program/
    BEGIN

      status.normal := TRUE;
      last_record_header_p := NIL;


       IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
         CASE tape_descriptor^.last_data_operation OF
         = amc$get_next_req, amc$get_partial_req =
           last_record_header_p := #ADDRESS(
             #RING( tape_descriptor^.get_tape_block_buffer),
             #SEGMENT(tape_descriptor^.get_tape_block_buffer),
             gfi^.positioning_info.record_info.record_header_fba);
           CASE last_record_header_p^.header_type OF
           = bac$full_record, bac$end_record =
             last_record_header_p^.length := last_record_header_p^.length -
               gfi^.positioning_info.record_info.residual_record_length;
           = bac$start_record =
             last_record_header_p^.header_type := bac$full_record;
             last_record_header_p^.length := last_record_header_p^.length -
               gfi^.positioning_info.record_info.residual_record_length;
           = bac$continued_record =
             last_record_header_p^.header_type := bac$end_record;
             last_record_header_p^.length := last_record_header_p^.length -
               gfi^.positioning_info.record_info.residual_record_length;
           ELSE
             amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
                     operation, 'Incorrect record header in SS/V write_end_partition', status);
             RETURN;
           CASEND;
           block_info^.block_position := bac$middle_of_block;
           gfi^.positioning_info.record_info.file_position := amc$eor;

         = amc$put_partial_req =
           last_record_header_p := #ADDRESS(
             #RING( tape_descriptor^.put_tape_block_buffer),
             #SEGMENT(tape_descriptor^.put_tape_block_buffer),
             gfi^.positioning_info.record_info.record_header_fba);
           CASE last_record_header_p^.header_type OF
           = bac$start_record =
             last_record_header_p^.header_type := bac$full_record;
           = bac$continued_record =
             last_record_header_p^.header_type := bac$end_record;
           ELSE
           CASEND;
           gfi^.positioning_info.record_info.file_position := amc$eor;

         ELSE
         CASEND;
       IFEND;

{   Check if last operation was read type that left tape logically at mid_block

      IF bai$partial_read_block_exists () THEN
        switch_from_read_to_write (file_identifier, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      rh.header_type := bac$partition;
      rh.length := 0;
      rh.previous_header_fba := 0;
      rh.unique_id := bac$record_header_unique_id;

      IF (bai$partial_block_exists ()) AND
        (rhl <= block_info^.residual_block_length) THEN
        terminate_previous_block := FALSE;
        term_option := amc$continue;
      ELSE
        terminate_previous_block := TRUE;
        term_option := amc$start;
      IFEND;

      put_data (file_identifier, operation, #LOC(rh), rhl, term_option,
        terminate_previous_block, {convert_if_ebcdic =} FALSE, status);

      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      last_record_header_p := ^tape_descriptor^.put_tape_block_buffer^
        [block_info^.current_block_byte_address +1 -rhl ];
      gfi^.positioning_info.record_info.record_header_fba := #OFFSET( last_record_header_p);
      gfi^.positioning_info.record_info.file_position := amc$eop;
      gfi^.positioning_info.record_info.transfer_count := 0;
      gfi^.positioning_info.record_info.record_length := 0;
      gfi^.positioning_info.record_info.residual_record_length := 0;

    END /main_program/;

    state_info^.put_op := TRUE;

  PROCEND write_end_partition_req;

*copy bai$lrt_common_procedures
MODEND bam$lrt_ss_var_tape_fap;
*DECK DECK=BAM$LRT_US_ANSI_D_TAPE_FAP EXPAND=TRUE

MODULE bam$lrt_us_ansi_d_tape_fap;
?? LEFT := 1, RIGHT := 110 ??
? VAR user_fap: boolean := FALSE ?;
? VAR pad_records: boolean := FALSE?;
?? PUSH (LIST := OFF) ??

























?? POP ??
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
?? TITLE := 'Type definitions' ??
*copyc amt$tape_error_options
*copyc amt$file_identifier
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc bat$put_label_request
*copyc bat$d_record_rcw
*copyc ost$caller_identifier
*copyc bak$bap_procedure_keypoints
?? TITLE := 'Error code definitions', EJECT ??
*copyc ame$improper_file_id
*copyc ame$improper_wsl
*copyc ame$get_program_actions
*copyc ame$get_validation_errors
*copyc ame$put_program_actions
*copyc ame$put_validation_errors
*copyc ame$skip_program_actions
*copyc ame$skip_validation_errors
*copyc bae$tape_bm_error_codes
*copyc dme$tape_errors
?? OLDTITLE ??
?? EJECT ??
?? POP ??
{ The following POP pragmat is here to negate an extra push (listext :=on) in one of the bam decks. }
?? POP ??
?? TITLE := 'XREF variable and procedure definitions' ??
*copyc osv$task_private_heap
*copyc amp$set_file_instance_abnormal
*copyc bap$close
*copyc bap$tape_bm_align_position
*copyc bap$tape_bm_flush
*copyc bap$tape_bm_open
*copyc bap$tape_bm_read_label
*copyc bap$tape_bm_read_next_block
*copyc bap$tape_bm_read_to_write
*copyc bap$tape_bm_close
*copyc bap$tape_bm_write_next_block
*copyc bap$tape_bm_reserve_blk_buffer
*copyc bap$tape_bm_skip_blocks
*copyc bap$tape_bm_skip_tapemark
*copyc bap$tape_bm_rewind
*copyc bap$tape_bm_advance_volume
*copyc bap$tape_bm_erase_block
*copyc bap$tape_bm_tapemark_check
*copyc bap$tape_bm_write_tape_mark
*copyc bap$tape_bm_write_label
*copyc bap$tape_bm_write_label_mark
*copyc bap$fap_control
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_integer
?? TITLE := 'INLINE function definitions' ??
?? NEWTITLE := ' ' ??
?? TITLE := 'bai$state_info', EJECT ??
*copyc bai$state_info
?? TITLE := 'bai$tape_descriptor', EJECT ??
*copyc bai$tape_descriptor
?? TITLE := 'bai$block_info', EJECT ??
*copyc bai$block_info
?? TITLE := 'bai$dynamic_label', EJECT ??
*copyc bai$dynamic_label
?? TITLE := 'bai$gfi', EJECT ??
*copyc bai$gfi
?? TITLE := 'bai$label_type', EJECT ??
*copyc bai$label_type
?? TITLE := 'bai$partial_block_exists', EJECT ??
*copyc bai$partial_block_exists
?? TITLE := 'bai$partial_read_block_exists', EJECT ??
*copyc bai$partial_read_block_exists
?? TITLE := 'bai$partial_record_exists', EJECT ??
*copyc bai$partial_record_exists
?? TITLE := 'bai$static_label', EJECT ??
*copyc bai$static_label
?? OLDTITLE ??
?? TITLE := 'INLINE procedure definitions' ??
?? NEWTITLE := ' ' ??
?? TITLE := 'osp$disestablish_cond_handler', EJECT ??
*copyc osp$disestablish_cond_handler
?? TITLE := 'osp$establish_block_exit_hndlr', EJECT ??
*copyc osp$establish_block_exit_hndlr
?? TITLE := 'bai$advance_volume', EJECT ??
*copyc bai$advance_volume
?? TITLE := 'bai$append_tape_error', EJECT ??
*copyc bai$append_tape_error
?? TITLE := 'bai$check_caller_id', EJECT ??
*copyc bai$check_caller_id
?? TITLE := 'bai$check_record_level_access', EJECT ??
*copyc bai$check_record_level_access
?? TITLE := 'bai$check_tapemark', EJECT ??
*copyc bai$check_tapemark
?? TITLE := 'bai$clear_fail_at_current_pos', EJECT ??
*copyc bai$clear_fail_at_current_pos
?? TITLE := 'bai$fetch_tape_error_options', EJECT ??
*copyc bai$fetch_tape_error_options
?? TITLE := 'bai$forced_write', EJECT ??
*copyc bai$forced_write
?? TITLE := 'bai$init_boi_tape_position', EJECT ??
*copyc bai$init_boi_tape_position
?? TITLE := 'bai$process_block_information', EJECT ??
*copyc bai$process_block_information
?? TITLE := 'bai$process_request_status', EJECT ??
*copyc bai$process_request_status
?? TITLE := 'bai$validate_tape_access', EJECT ??
*copyc bai$validate_tape_access
?? TITLE := 'bai$write_previous_block', EJECT ??
*copyc bai$write_previous_block
?? TITLE := 'bap$validate_fap_identifier', EJECT ??
*copyc bap$validate_fap_identifier
?? TITLE := 'bap$validate_file_identifier', EJECT ??
*copyc bap$validate_file_identifier
?? TITLE := 'i#move', EJECT ??
*copyc i#move
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? TITLE := 'global variables for this call of the fap', EJECT ??
*copyc bav$global_tape_fap_variables

  CONST
    pad_blocks = TRUE,
    record_headers_exist = TRUE;

?? TITLE := 'bap#lrt_us_spanned_tape_fap', EJECT ??
? IF user_fap THEN
  VAR
    ttv$layer_number: [XDCL] amt$fap_layer_number := 0;

  PROCEDURE [XDCL, #GATE] bap#lrt_us_ansi_d_tape_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    ttv$layer_number := layer_number;
    bap$lrt_us_ansi_d_tape_fap (file_identifier, call_block, layer_number, status);

  PROCEND bap#lrt_us_ansi_d_tape_fap;
? IFEND

?? TITLE := 'bap$lrt_us_ansi_d_tape_fap', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$lrt_us_ansi_d_tape_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      dynamic_label: ^bat$dynamic_label_attributes,
      i: integer,
      last_record_header_p: ^bat$d_record_rcw,
      local_status: ost$status,
      static_label: ^bat$instance_static_attributes,
      validation_ok: boolean;

    #caller_id (caller_id);
    operation := call_block.operation;
    #keypoint (osk$entry, osk$m * ((file_identifier.ordinal * 256) + operation),
          bak$sys_blk_var_rec_tape_fap);
    status.normal := TRUE;
    global_layer_number := layer_number;
    close_file_on_exit := FALSE;

  /main_program/
    BEGIN

? IF user_fap THEN
      bap$validate_fap_identifier (file_identifier, file_instance, validation_ok);
? ELSE
      bap$validate_file_identifier (file_identifier, file_instance, validation_ok);
? IFEND
      IF NOT validation_ok THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
          'bap$lrt_us_ansi_d_tape_fap', status);
        EXIT /main_program/;
      IFEND;

      block_info := bai$block_info (file_instance);
      gfi := bai$gfi (file_instance);
      tape_descriptor := bai$tape_descriptor (file_instance);
      static_label := bai$static_label (file_instance);
      state_info := bai$state_info (file_instance);
      rhl := #SIZE(bat$d_record_rcw);
      bai$check_caller_id (file_identifier, static_label^.ring_attributes, operation, caller_id,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      bai$check_record_level_access (file_identifier, file_instance^.access_level, operation,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      dynamic_label := bai$dynamic_label (file_instance);
      bai$validate_tape_access (file_identifier, dynamic_label^.access_mode, operation, tape_descriptor,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      bai$clear_fail_at_current_pos (operation, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      tape_descriptor^.error_options := dynamic_label^.error_options;

      CASE operation OF

      = amc$close_req =
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: US/D FAP called on CLOSE');
        close_req (file_identifier, status);
        bap$close (file_identifier, local_status);
        IF status.normal THEN
          status := local_status;
        IFEND;
      = amc$close_volume_req =
        close_volume_req (file_identifier, status);
        gfi^.positioning_info.record_info.residual_record_length := 0;
        file_instance^.previous_get_at_eoi := FALSE;
      = amc$erase_tape_block =
        erase_tape_block_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$erase_tape_block;
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$fetch_req =
        bap$fap_control (file_identifier, call_block, layer_number, status);
      = amc$flush_req =
        flush_req (file_identifier, status);
        gfi^.positioning_info.record_info.residual_record_length := 0;
        tape_descriptor^.last_data_operation := amc$flush_req;
      = amc$get_next_req =
        get_next_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$get_next_req;
        IF status.normal AND (call_block.getn.file_position^ <> amc$eoi) THEN
          tape_descriptor^.at_eoi := FALSE;
        IFEND;
      = amc$get_partial_req =
        get_partial_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$get_partial_req;
        IF status.normal AND (call_block.getp.file_position^ <> amc$eoi) THEN
          tape_descriptor^.at_eoi := FALSE;
        IFEND;
      = amc$open_req =
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: US/D FAP called on OPEN');
        tape_descriptor^.file_label_type := static_label^.file_label_type;

        CASE bai$label_type() OF
        = amc$labelled =
          open_req (file_identifier, call_block, layer_number, dynamic_label, status);
        = amc$unlabelled, amc$non_standard_labelled =
? IF user_fap THEN
          open_req (file_identifier, call_block, layer_number, dynamic_label, status);
? ELSE
          amp$set_file_instance_abnormal(file_identifier, ame$bt_rt_supp_only_for_labeled,
            operation, 'Block type USER_SPECIFIED (US), record type ANSI_VARIABLE (D)', status);
? IFEND
        ELSE
          amp$set_file_instance_abnormal(file_identifier, ame$tape_rcd_mgr_malfunction,
            operation, 'Unknown file_label_type in open_req (US/D fap)', status);
        CASEND;
      = amc$put_next_req =
        IF (bai$label_type () = amc$labelled) THEN
          IF NOT state_info^.ve_wrote_ansi_file THEN
            amp$set_file_instance_abnormal (file_identifier, ame$rewrite_labels_conflict,
                  call_block.operation, ' ', status);
            RETURN;
          IFEND;
          IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
            sl_reposition_for_put_at_eoi (file_identifier, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
        put_next_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$put_next_req;
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$put_partial_req =
        IF (bai$label_type () = amc$labelled) THEN
          IF NOT state_info^.ve_wrote_ansi_file THEN
            amp$set_file_instance_abnormal (file_identifier, ame$rewrite_labels_conflict,
                  call_block.operation, ' ', status);
            RETURN;
          IFEND;
          IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
            sl_reposition_for_put_at_eoi (file_identifier, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
        put_partial_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$put_partial_req;
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$rewind_req =
        rewind_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$rewind_req;
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := FALSE;
      = amc$skip_req =
        validate_skip_parameters (file_identifier , call_block, FALSE, FALSE, TRUE, FALSE, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        skip_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$skip_req;
        file_instance^.previous_get_at_eoi := FALSE;
      = amc$write_tape_mark_req =
        IF bai$label_type () = amc$labelled THEN
          amp$set_file_instance_abnormal (file_identifier, ame$improper_labelled_tape_op,
                call_block.operation, 'WRITE OF TAPE MARK', status);
          EXIT /main_program/;
        IFEND;
        IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
          last_record_header_p := NIL;
          CASE tape_descriptor^.last_data_operation OF
          = amc$get_next_req, amc$get_partial_req =
            last_record_header_p := #ADDRESS(
              #RING( tape_descriptor^.get_tape_block_buffer),
              #SEGMENT(tape_descriptor^.get_tape_block_buffer),
              gfi^.positioning_info.record_info.record_header_fba);

            adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
              gfi^.positioning_info.record_info.residual_record_length, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            block_info^.block_position := bac$middle_of_block;
            gfi^.positioning_info.record_info.file_position := amc$eor;

          ELSE
          CASEND;
        IFEND;

{   Check if last operation was read type that left tape logically at mid_block

        IF bai$partial_read_block_exists () THEN
          switch_from_read_to_write (file_identifier, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;

        write_tape_mark_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$write_tape_mark_req;
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;

      ELSE
        bap$fap_control (file_identifier, call_block, layer_number, status);
      CASEND;

    END /main_program/;

    IF (operation >= amc$last_access_start) AND (operation <= amc$max_operation)
      AND (operation <> amc$fetch_req) AND (operation <> amc$fetch_access_information_rq) THEN
      gfi^.last_access_operation := operation;
    IFEND;

    IF status.normal THEN
      gfi^.error_status := 0;
    ELSE
      gfi^.error_status := status.condition;
    IFEND;

{
{   IF the operator terminates a tape assignment that was initiated via bai$advance_volume,
{   the file will be closed at this point.
{

    IF close_file_on_exit THEN
      bap$close (file_identifier, local_status);
    IFEND;

    #keypoint (osk$exit, 0, bak$sys_blk_var_rec_tape_fap);

  PROCEND bap$lrt_us_ansi_d_tape_fap;


?? TITLE := 'adjust_length_in_last_header', EJECT ??

  PROCEDURE adjust_length_in_last_header (
    file_identifier: amt$file_identifier;
    header_p: ^bat$d_record_rcw;
    operator: (add, subtract);
    value: integer;
    VAR status: ost$status);

    VAR
      binary_length: clt$integer,
      character_length: string (bac$rcw_length_size),
      character_length_index: integer,
      i: integer,
      working_string: ost$string;

    status.normal := TRUE;

    IF value = 0 THEN
      RETURN;
    IFEND;

    IF header_p = NIL THEN
      amp$set_file_instance_abnormal(file_identifier, ame$tape_rcd_mgr_malfunction, operation,
        'Incorrect header pointer in US/D procedure: adjust_length_in_last_header', status);
      RETURN;
    IFEND;

    clp$convert_string_to_integer (header_p^.length, binary_length, status);
    IF NOT status.normal THEN
      amp$set_file_instance_abnormal(file_identifier, ame$improper_record_header, operation,
        'Non numeric header encountered in US/D procedure: adjust_length_in_last_header', status);
      RETURN;
    IFEND;

    IF operator = add THEN
      binary_length.value := binary_length.value + value;
    ELSEIF operator = subtract THEN
      binary_length.value := binary_length.value - value;
    ELSE
      amp$set_file_instance_abnormal(file_identifier, ame$tape_rcd_mgr_malfunction, operation,
        'Incorrect operator encountered in US/D procedure: adjust_length_in_last_header', status);
      RETURN;
    IFEND;

    IF (binary_length.value > UPPERVALUE(bat$rcw_length_value_range)) OR
       (binary_length.value < LOWERVALUE(bat$rcw_length_value_range)) THEN
      amp$set_file_instance_abnormal(file_identifier, ame$tape_rcd_mgr_malfunction, operation,
        'RCW length value exceeds range in US/D procedure: adjust_length_in_last_header', status);
      RETURN;
    IFEND;

    clp$convert_integer_to_string (binary_length.value, 10, FALSE, working_string, status);
    IF NOT status.normal THEN
      amp$set_file_instance_abnormal(file_identifier, ame$tape_rcd_mgr_malfunction, operation,
        'Integer to string error encountered in US/D procedure: adjust_length_in_last_header', status);
      RETURN;
    IFEND;

    IF working_string.size > bac$rcw_length_size THEN
      amp$set_file_instance_abnormal(file_identifier, ame$tape_rcd_mgr_malfunction, operation,
        'RCW length overflow encountered in US/D procedure: adjust_length_in_last_header', status);
      RETURN;
    ELSE
      character_length := bac$rcw_length_value_of_zero;
      character_length_index := bac$rcw_length_size;
      FOR i := working_string.size DOWNTO 1 DO
        character_length(character_length_index) := working_string.value(i);
        character_length_index := character_length_index - 1;
      FOREND;
      header_p^.length := character_length;
    IFEND;


  PROCEND adjust_length_in_last_header;

?? TITLE := 'get_next_req', EJECT ??

{
{ The purpose of this request is to cause the transfer of data from tape to a
{ tape buffer, transfer data from the tape buffer to the users working
{ storage area, and to update all file descriptor fields.
{

  PROCEDURE get_next_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    CONST
      allow_direct_io_transfer = FALSE;

    VAR
      data_length : 0 .. amc$maximum_block - 1,
      exit_situation : boolean,
      get_size : 0 .. amc$maximum_block - 1,
      last_record_header_p: ^bat$d_record_rcw,
      manually_advance_to_next_block: boolean,
      no_header_read : boolean,
      residual_data_length : 0 .. amc$maximum_block - 1,
      rh: bat$d_record_rcw,
      start_new_block : boolean,
      wsa : ^cell,
      wsl : amt$working_storage_length,
      zero_length_record : boolean;


*copy bai$get_ansi_rcw


      status.normal := TRUE;
      call_block.getn.transfer_count^ := 0;
      data_length := 0;
      exit_situation := FALSE;
      last_record_header_p := NIL;
      manually_advance_to_next_block := FALSE;
      no_header_read := FALSE;
      residual_data_length := gfi^.positioning_info.record_info.residual_record_length;
      start_new_block := FALSE;
      wsa := call_block.getn.working_storage_area;
      wsl := call_block.getn.working_storage_length;
      zero_length_record := FALSE;

      IF (wsl <= 0) OR (wsl > UPPERVALUE (amt$working_storage_length)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
        operation, ' ', status);
        RETURN;
      IFEND;


{
{ Check file position to see if any partial blocks need to be written out.
{

      IF bai$partial_block_exists () THEN
        bai$write_previous_block (file_identifier, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

/main_program/
  BEGIN


{
{  Advance forward to the next record boundary if necessary.
{

      IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
        block_info^.current_block_byte_address :=
          block_info^.current_block_byte_address + residual_data_length;
        block_info^.residual_block_length :=
          block_info^.residual_block_length - residual_data_length;
        residual_data_length := 0;
        gfi^.positioning_info.record_info.file_position := amc$eor;
      IFEND;


      bai$get_ansi_rcw;
      IF exit_situation THEN { (NOT status.normal) OR (no_header_read) OR (zero_length_record)
        EXIT /main_program/;
      IFEND;

      IF wsl > residual_data_length THEN
        get_size := residual_data_length;
      ELSE { wsl <= residual_data_length
        get_size := wsl;
      IFEND;

      get_data (file_identifier, operation, wsa, get_size, allow_direct_io_transfer,
            start_new_block, {convert_if_ebcdic =} TRUE, status);

      data_length := gfi^.positioning_info.record_info.transfer_count;
      residual_data_length := residual_data_length - gfi^.positioning_info.record_info.transfer_count;
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF gfi^.positioning_info.record_info.transfer_count < get_size THEN
        get_size := gfi^.positioning_info.record_info.transfer_count;
      IFEND;

      wsl := wsl - get_size;
      wsa := #address (#ring (wsa), #segment (wsa), (#offset (wsa) + get_size));


    END /main_program/;

      IF (tape_descriptor^.volume_position = amc$eov) OR
         (tape_descriptor^.volume_position = amc$after_tapemark) THEN
        CASE bai$label_type() OF
        = amc$unlabelled =
          gfi^.positioning_info.record_info.file_position := amc$eoi;
          file_instance^.previous_get_at_eoi := TRUE;
          tape_descriptor^.at_eoi := TRUE;
        = amc$labelled =
          gfi^.positioning_info.record_info.file_position := amc$eoi;
          file_instance^.previous_get_at_eoi := TRUE;
        = amc$non_standard_labelled =
          gfi^.positioning_info.record_info.file_position := amc$mid_record;
        ELSE
          amp$set_file_instance_abnormal (file_identifier,
            ame$tape_rcd_mgr_malfunction, operation,
            'Unknown file_label_type in get_next_req (US/D)', status);
        CASEND;

      ELSEIF NOT status.normal THEN
        ;

      ELSEIF zero_length_record THEN
        gfi^.positioning_info.record_info.file_position := amc$eor;

      ELSEIF manually_advance_to_next_block THEN
        ;

      ELSE
        IF residual_data_length = 0 THEN
          gfi^.positioning_info.record_info.file_position := amc$eor;
        ELSE
          gfi^.positioning_info.record_info.file_position := amc$mid_record;
        IFEND;

      IFEND;

      IF last_record_header_p <> NIL THEN
        gfi^.positioning_info.record_info.record_header_fba := #OFFSET( last_record_header_p);
      IFEND;

      gfi^.positioning_info.record_info.transfer_count := data_length;
      gfi^.positioning_info.record_info.record_length := data_length;
      gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
      call_block.getn.file_position^ := gfi^.positioning_info.record_info.file_position;
      call_block.getn.transfer_count^ := gfi^.positioning_info.record_info.transfer_count;

  PROCEND get_next_req;

?? TITLE := 'get_partial_req', EJECT ??

{
{ The purpose of this request is to cause a partial transfer of data from tape to a
{ tape buffer, transfer data from the tape buffer to the users working
{ storage area, and to update all file descriptor fields.
{

  PROCEDURE get_partial_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    CONST
      allow_direct_io_transfer = FALSE;

    VAR
      data_length : 0 .. amc$maximum_block - 1,
      exit_situation : boolean,
      get_size : 0 .. amc$maximum_block - 1,
      last_record_header_p: ^bat$d_record_rcw,
      manually_advance_to_next_block: boolean,
      no_header_read : boolean,
      residual_data_length : 0 .. amc$maximum_block - 1,
      rh: bat$d_record_rcw,
      start_new_block : boolean,
      wsa : ^cell,
      wsl : amt$working_storage_length,
      zero_length_record : boolean;


*copy bai$get_ansi_rcw


      status.normal := TRUE;
      call_block.getn.transfer_count^ := 0;
      data_length := 0;
      exit_situation := FALSE;
      last_record_header_p := NIL;
      manually_advance_to_next_block := FALSE;
      no_header_read := FALSE;
      residual_data_length := gfi^.positioning_info.record_info.residual_record_length;
      start_new_block := FALSE;
      wsa := call_block.getp.working_storage_area;
      wsl := call_block.getp.working_storage_length;
      zero_length_record := FALSE;

      IF (wsl <= 0) OR (wsl > UPPERVALUE (amt$working_storage_length)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
        operation, ' ', status);
        RETURN;
      IFEND;

      IF (call_block.getp.skip_option < LOWERVALUE (amt$skip_option)) OR
        (call_block.getp.skip_option > UPPERVALUE (amt$skip_option)) THEN
        amp$set_file_instance_abnormal (file_identifier,
          ame$improper_skip_option, call_block.operation, ' ', status);
        RETURN;
      IFEND;

      IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
        CASE tape_descriptor^.last_data_operation OF
        = amc$get_next_req, amc$get_partial_req =
          last_record_header_p := #ADDRESS(
            #RING( tape_descriptor^.get_tape_block_buffer),
            #SEGMENT(tape_descriptor^.get_tape_block_buffer),
            gfi^.positioning_info.record_info.record_header_fba);
          rh := last_record_header_p^;

        ELSE
        CASEND;
      IFEND;

{
{ Check file position to see if any partial blocks need to be written out.
{

    IF bai$partial_block_exists () THEN
      bai$write_previous_block (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      gfi^.positioning_info.record_info.record_length := 0;
    IFEND;

  /main_program/
    BEGIN


{
{  Advance forward to the next record boundary if necessary.
{


    IF call_block.getp.skip_option = amc$skip_to_eor THEN
      IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN

        block_info^.current_block_byte_address :=
          block_info^.current_block_byte_address + residual_data_length;
        block_info^.residual_block_length :=
          block_info^.residual_block_length - residual_data_length;

        residual_data_length := 0;
        gfi^.positioning_info.record_info.file_position := amc$eor;
        gfi^.positioning_info.record_info.record_length := 0;

      IFEND;
    IFEND;

    IF gfi^.positioning_info.record_info.file_position <> amc$mid_record THEN
      gfi^.positioning_info.record_info.record_length := 0;
    IFEND;

    gfi^.positioning_info.record_info.transfer_count := 0;

{ ! If prior operation = put_next or put_partial, residual_data_length = 0.    }

    IF residual_data_length = 0 THEN
      bai$get_ansi_rcw;
      IF exit_situation THEN { (NOT status.normal) OR (no_header_read) OR (zero_length_record)
        EXIT /main_program/;
      IFEND;
    IFEND;

    IF wsl > residual_data_length THEN
      get_size := residual_data_length;
    ELSE { wsl <= residual_data_length
      get_size := wsl;
    IFEND;

    get_data (file_identifier, operation, wsa, get_size, allow_direct_io_transfer,
          start_new_block, {convert_if_ebcdic =} TRUE, status);

    data_length := gfi^.positioning_info.record_info.transfer_count;
    residual_data_length := residual_data_length - gfi^.positioning_info.record_info.transfer_count;
    IF NOT status.normal THEN
      EXIT /main_program/;
    IFEND;

    IF gfi^.positioning_info.record_info.transfer_count < get_size THEN
      get_size := gfi^.positioning_info.record_info.transfer_count;
    IFEND;

    wsl := wsl - get_size;
    wsa := #address (#ring (wsa), #segment (wsa), (#offset (wsa) + get_size));

  END /main_program/;

    IF (tape_descriptor^.volume_position = amc$eov) OR
       (tape_descriptor^.volume_position = amc$after_tapemark) THEN
      CASE bai$label_type() OF
      = amc$unlabelled =
        gfi^.positioning_info.record_info.file_position := amc$eoi;
        file_instance^.previous_get_at_eoi := TRUE;
        tape_descriptor^.at_eoi := TRUE;
      = amc$labelled =
        gfi^.positioning_info.record_info.file_position := amc$eoi;
        file_instance^.previous_get_at_eoi := TRUE;
      = amc$non_standard_labelled =
        gfi^.positioning_info.record_info.file_position := amc$mid_record;
      ELSE
        amp$set_file_instance_abnormal (file_identifier,
          ame$tape_rcd_mgr_malfunction, operation,
          'Unknown file_label_type in get_next_req (US/D)', status);
      CASEND;

    ELSEIF NOT status.normal THEN
      ;

    ELSEIF zero_length_record THEN
      gfi^.positioning_info.record_info.file_position := amc$eor;

    ELSEIF manually_advance_to_next_block THEN
      ;

    ELSE
      IF residual_data_length = 0 THEN
        gfi^.positioning_info.record_info.file_position := amc$eor;
      ELSE
        gfi^.positioning_info.record_info.file_position := amc$mid_record;
      IFEND;

    IFEND;

    IF last_record_header_p <> NIL THEN
      gfi^.positioning_info.record_info.record_header_fba := #OFFSET( last_record_header_p);
    IFEND;

    gfi^.positioning_info.record_info.transfer_count := data_length;
    gfi^.positioning_info.record_info.record_length :=
      gfi^.positioning_info.record_info.record_length + data_length;
    gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
    call_block.getp.file_position^ := gfi^.positioning_info.record_info.file_position;
    call_block.getp.transfer_count^ := gfi^.positioning_info.record_info.transfer_count;
    call_block.getp.record_length^ := gfi^.positioning_info.record_info.record_length;

  PROCEND get_partial_req;


?? TITLE := 'put_next_req', EJECT ??

{
{ The purpose of this request is to transfer data from the users
{ working storage area to a tape file, either directly, or through
{ a tape buffer, and to update all file descriptor fields.
{


  PROCEDURE put_next_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      data_length : 0 .. amc$maximum_block - 1,
      last_record_header_p: ^bat$d_record_rcw,
      max_data_size : 0 .. amc$maximum_block - 1,
      put_size : 0 .. amc$maximum_block - 1,
      rh : bat$d_record_rcw,
      term_option : amt$term_option,
      terminate_previous_block : boolean,
      wsa : ^cell,
      wsl : amt$working_storage_length;


*copy bai$put_ansi_rcw


  /main_program/
    BEGIN

      status.normal := TRUE;
      data_length := 0;
      last_record_header_p := NIL;
      max_data_size := gfi^.max_data_size;
      wsa := call_block.putn.working_storage_area;
      wsl := call_block.putn.working_storage_length;

      IF (wsl < 0) OR (wsl > UPPERVALUE (amt$working_storage_length)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
        operation, ' ', status);
        RETURN;
      IFEND;

      IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
        CASE tape_descriptor^.last_data_operation OF
        = amc$get_next_req, amc$get_partial_req =
          last_record_header_p := #ADDRESS(
            #RING( tape_descriptor^.get_tape_block_buffer),
            #SEGMENT(tape_descriptor^.get_tape_block_buffer),
            gfi^.positioning_info.record_info.record_header_fba);

          adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
            gfi^.positioning_info.record_info.residual_record_length, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          gfi^.positioning_info.record_info.residual_record_length := 0;

          block_info^.block_position := bac$middle_of_block;

        ELSE
        CASEND;
      IFEND;

{   Check if last operation was read type that left tape logically at mid_block

      IF bai$partial_read_block_exists () THEN
        switch_from_read_to_write (file_identifier, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;


      IF wsl + rhl > gfi^.max_data_size THEN
        amp$set_file_instance_abnormal (file_identifier, ame$record_exceeds_mbl,
        operation, ' ', status);
        gfi^.positioning_info.record_info.transfer_count := 0;
        RETURN;
      IFEND;

      IF (bai$partial_block_exists ()) AND
         (rhl + wsl <= block_info^.residual_block_length) THEN
        terminate_previous_block := FALSE;

        put_size := wsl;
        term_option := amc$continue;
        bai$put_ansi_rcw;
        IF (wsl = 0) OR (NOT status.normal) THEN
          EXIT /main_program/;
        IFEND;
        term_option := amc$continue;

      ELSE
        terminate_previous_block := TRUE;

        put_size := wsl;
        term_option := amc$start;
        bai$put_ansi_rcw;
        IF (wsl = 0) OR (NOT status.normal) THEN
          EXIT /main_program/;
        IFEND;
        terminate_previous_block := FALSE;
        term_option := amc$continue;

      IFEND;

      put_data (file_identifier, operation, wsa, put_size, term_option,
        terminate_previous_block, {convert_if_ebcdic =} TRUE, status);

      IF NOT status.normal THEN
        IF (status.condition = ame$end_of_tape_op_completed) THEN
          data_length := data_length + put_size;
        IFEND;
        EXIT /main_program/;
      IFEND;

      data_length := data_length + put_size;

      wsl := wsl - put_size;
      wsa := #address (#ring (wsa), #segment (wsa), (#offset (wsa) + put_size));


    END /main_program/;

      state_info^.put_op := TRUE;

{ The following check will set file_position to mid_record if an abnormal condition
{ occurred (such as unrecovered write error).  End of tape errors will never happen
{ for labelled or unlabelled operations.  If label type is non_standard, the file is
{ really at eor if the error is ame$end_of_tape_op_completed.

      IF NOT status.normal THEN
        IF (status.condition = ame$end_of_tape_op_completed) THEN
          gfi^.positioning_info.record_info.file_position := amc$eor;
        ELSE
          gfi^.positioning_info.record_info.file_position := amc$mid_record;
        IFEND;
      ELSE
        gfi^.positioning_info.record_info.file_position := amc$eor;
      IFEND;

      IF last_record_header_p <> NIL THEN
        gfi^.positioning_info.record_info.record_header_fba := #OFFSET( last_record_header_p);
      IFEND;

      gfi^.positioning_info.record_info.transfer_count := data_length;
      gfi^.positioning_info.record_info.record_length := data_length;
      gfi^.positioning_info.record_info.residual_record_length := 0;

  PROCEND put_next_req;


?? TITLE := 'put_partial_req', EJECT ??

  PROCEDURE put_partial_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      current_record_p: ^array [1..*] OF cell,
      data_length : 0 .. amc$maximum_block - 1,
      end_of_data : boolean,
      exit_after_header_update: boolean,
      last_record_header_p: ^bat$d_record_rcw,
      max_data_size : 0 .. amc$maximum_block - 1,
      more_data : boolean,
      put_data_status: ost$status,
      put_size : 0 .. amc$maximum_block - 1,
      relocate_current_record: boolean,
      rh: bat$d_record_rcw,
      start_of_data : boolean,
      term_option : amt$term_option,
      temp_current_block_byte_address: amt$file_byte_address,
      temp_current_block_length: 0 .. amc$maximum_block - 1,
      temp_residual_block_length: 0 .. amc$maximum_block - 1,
      terminate_previous_block : boolean,
      wsa : ^cell,
      wsl : amt$working_storage_length;


*copy bai$put_ansi_rcw


/main_program/
  BEGIN

    status.normal := TRUE;
    put_data_status.normal := TRUE;
    current_record_p := NIL;
    data_length := 0;
    end_of_data := FALSE;
    exit_after_header_update := FALSE;
    last_record_header_p := NIL;
    max_data_size := gfi^.max_data_size;
    more_data := TRUE;
    relocate_current_record := FALSE;
    start_of_data := TRUE;
    wsa := call_block.putp.working_storage_area;
    wsl := call_block.putp.working_storage_length;


    IF (wsl < 0) OR (wsl > UPPERVALUE (amt$working_storage_length)) THEN
      amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
      operation, ' ', status);
      RETURN;
    IFEND;

    IF (call_block.putp.term_option < LOWERVALUE (amt$term_option)) OR
       (call_block.putp.term_option > UPPERVALUE (amt$term_option)) THEN
      amp$set_file_instance_abnormal (file_identifier,
        ame$improper_term_option, call_block.operation, ' ', status);
      RETURN;
    IFEND;

    CASE call_block.putp.term_option OF

    = amc$start =

      CASE tape_descriptor^.last_data_operation OF
      = amc$get_next_req, amc$get_partial_req =
        last_record_header_p := #ADDRESS(
          #RING( tape_descriptor^.get_tape_block_buffer),
          #SEGMENT(tape_descriptor^.get_tape_block_buffer),
          gfi^.positioning_info.record_info.record_header_fba);

        adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
          gfi^.positioning_info.record_info.residual_record_length, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        gfi^.positioning_info.record_info.residual_record_length := 0;

        block_info^.block_position := bac$middle_of_block;

      ELSE
      CASEND;

    = amc$continue =

      IF gfi^.positioning_info.record_info.file_position <> amc$mid_record THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_continue,
          operation, ' ', status);
        RETURN;
      IFEND;

      CASE tape_descriptor^.last_data_operation OF
      = amc$get_next_req, amc$get_partial_req =
        last_record_header_p := #ADDRESS(
          #RING( tape_descriptor^.get_tape_block_buffer),
          #SEGMENT(tape_descriptor^.get_tape_block_buffer),
          gfi^.positioning_info.record_info.record_header_fba);

        adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
          gfi^.positioning_info.record_info.residual_record_length, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        gfi^.positioning_info.record_info.residual_record_length := 0;

        block_info^.block_position := bac$middle_of_block;

      ELSE
      CASEND;

    = amc$terminate =

      CASE tape_descriptor^.last_data_operation OF
      = amc$get_next_req, amc$get_partial_req =
        last_record_header_p := #ADDRESS(
          #RING( tape_descriptor^.get_tape_block_buffer),
          #SEGMENT(tape_descriptor^.get_tape_block_buffer),
          gfi^.positioning_info.record_info.record_header_fba);

        IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
          adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
            gfi^.positioning_info.record_info.residual_record_length, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          gfi^.positioning_info.record_info.residual_record_length := 0;

          block_info^.block_position := bac$middle_of_block;

        IFEND;
      ELSE
      CASEND;

    ELSE
    CASEND;

{   Check if last operation was read type that left tape logically at mid_block

    IF bai$partial_read_block_exists () THEN
      switch_from_read_to_write (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;


    last_record_header_p := #ADDRESS(
      #RING( tape_descriptor^.put_tape_block_buffer),
      #SEGMENT(tape_descriptor^.put_tape_block_buffer),
      gfi^.positioning_info.record_info.record_header_fba);


    CASE call_block.putp.term_option OF

    = amc$start =

      IF wsl + rhl > gfi^.max_data_size THEN
        amp$set_file_instance_abnormal (file_identifier, ame$record_exceeds_mbl,
          operation, ' ', status);
        gfi^.positioning_info.record_info.transfer_count := 0;
        RETURN;
      IFEND;

      IF (bai$partial_block_exists()) AND
        (wsl + rhl <= block_info^.residual_block_length) THEN

        terminate_previous_block := FALSE;
        put_size := wsl;
        term_option := amc$continue;
        bai$put_ansi_rcw;
        IF (wsl = 0) OR NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        term_option := amc$continue;

      ELSE
        terminate_previous_block := TRUE;
        put_size := wsl;
        term_option := amc$start;
        bai$put_ansi_rcw;
        IF (wsl = 0) OR NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        terminate_previous_block := FALSE;
        term_option := amc$continue;

      IFEND;

    = amc$continue =

      IF wsl + (gfi^.positioning_info.record_info.record_length + rhl) > gfi^.max_data_size THEN
        amp$set_file_instance_abnormal (file_identifier, ame$record_exceeds_mbl,
          operation, ' ', status);
        gfi^.positioning_info.record_info.transfer_count := 0;
        RETURN;
      IFEND;

      IF (bai$partial_block_exists()) AND
        (wsl <= block_info^.residual_block_length) THEN

        IF (wsl = 0) THEN
          EXIT /main_program/;
        IFEND;
        terminate_previous_block := FALSE;
        put_size := wsl;
        term_option := amc$continue;

      ELSE
        terminate_previous_block := TRUE;
        put_size := wsl;
        relocate_current_record := TRUE;

      IFEND;

    = amc$terminate =

      IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN

        IF wsl + (gfi^.positioning_info.record_info.record_length + rhl) > gfi^.max_data_size THEN
          amp$set_file_instance_abnormal (file_identifier, ame$record_exceeds_mbl,
            operation, ' ', status);
          gfi^.positioning_info.record_info.transfer_count := 0;
          RETURN;
        IFEND;

        IF (bai$partial_block_exists()) AND
          (wsl <= block_info^.residual_block_length) THEN

          IF (wsl = 0) THEN
            EXIT /main_program/;
          IFEND;
          terminate_previous_block := FALSE;
          put_size := wsl;
          term_option := amc$continue;

        ELSE
          terminate_previous_block := TRUE;
          put_size := wsl;
          relocate_current_record := TRUE;

        IFEND;

      ELSE { gfi^.positioning_info.record_info.file_position <> amc$mid_record

        IF wsl + rhl > gfi^.max_data_size THEN
          amp$set_file_instance_abnormal (file_identifier, ame$record_exceeds_mbl,
            operation, ' ', status);
          gfi^.positioning_info.record_info.transfer_count := 0;
          RETURN;
        IFEND;

        IF (bai$partial_block_exists()) AND
          (wsl + rhl <= block_info^.residual_block_length) THEN

          terminate_previous_block := FALSE;
          put_size := wsl;
          term_option := amc$continue;
          bai$put_ansi_rcw;
          IF (wsl = 0) OR NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
          term_option := amc$continue;

        ELSE
          terminate_previous_block := TRUE;
          put_size := wsl;
          term_option := amc$start;
          bai$put_ansi_rcw;
          IF (wsl = 0) OR NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
          terminate_previous_block := FALSE;
          term_option := amc$continue;

        IFEND;
      IFEND;

    ELSE
    CASEND;


    IF relocate_current_record THEN

      PUSH current_record_p : [1 .. (gfi^.positioning_info.record_info.record_length + rhl) ];
      IF current_record_p = NIL THEN
        amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
          operation, 'Unable to PUSH onto stack in US/D put_partial_request', status);
        RETURN;
      IFEND;

      temp_current_block_byte_address := block_info^.current_block_byte_address;
      temp_current_block_length := block_info^.current_block_length;
      temp_residual_block_length := block_info^.residual_block_length;

      i#move(last_record_header_p, current_record_p, (gfi^.positioning_info.record_info.record_length + rhl));

      block_info^.residual_block_length :=
        block_info^.residual_block_length
        + (gfi^.positioning_info.record_info.record_length + rhl);
      block_info^.current_block_byte_address :=
        block_info^.current_block_byte_address
        - (gfi^.positioning_info.record_info.record_length + rhl);
      block_info^.current_block_length :=
        block_info^.current_block_length
        - (gfi^.positioning_info.record_info.record_length + rhl);

      put_data (file_identifier, operation, current_record_p,
            (gfi^.positioning_info.record_info.record_length + rhl), amc$start,
            TRUE, {convert_if_ebcdic =} FALSE, status);

      IF status.normal THEN
        last_record_header_p := ^tape_descriptor^.put_tape_block_buffer^
          [(block_info^.current_block_byte_address + 1)
          - (gfi^.positioning_info.record_info.record_length + rhl)];
      ELSE
        block_info^.current_block_byte_address := temp_current_block_byte_address;
        block_info^.current_block_length := temp_current_block_length;
        block_info^.residual_block_length := temp_residual_block_length;
        EXIT /main_program/;
      IFEND;

      terminate_previous_block := FALSE;
      term_option := amc$continue;

    IFEND;


    put_data (file_identifier, operation, wsa, put_size, term_option,
      terminate_previous_block, {convert_if_ebcdic =} TRUE, put_data_status);

    IF NOT put_data_status.normal THEN
      IF (put_data_status.condition = ame$end_of_tape_op_completed) THEN
        exit_after_header_update := TRUE;
      ELSE
        EXIT /main_program/;
      IFEND;
    IFEND;


    CASE call_block.putp.term_option OF

    = amc$start =
      ;

    = amc$continue =
        adjust_length_in_last_header (file_identifier, last_record_header_p, add, put_size, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

    = amc$terminate =
      IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN

        adjust_length_in_last_header (file_identifier, last_record_header_p, add, put_size, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

      IFEND;

    ELSE
      amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
        operation, 'Incorrect term_option encountered in US/D put_partial_request', status);
      EXIT /main_program/;
    CASEND;


    data_length := data_length + put_size;

    IF exit_after_header_update THEN
      EXIT /main_program/;
    IFEND;

    wsl := wsl - put_size;
    wsa := #address (#ring (wsa), #segment (wsa), (#offset (wsa) + put_size));


END /main_program/;

    state_info^.put_op := TRUE;

    IF call_block.putp.term_option = amc$start THEN
      gfi^.positioning_info.record_info.file_position := amc$mid_record;
      gfi^.positioning_info.record_info.record_length := data_length;
    ELSEIF call_block.putp.term_option = amc$continue THEN
      gfi^.positioning_info.record_info.file_position := amc$mid_record;
      gfi^.positioning_info.record_info.record_length :=
        gfi^.positioning_info.record_info.record_length + data_length;
    ELSE {amc$terminate}
      IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
        gfi^.positioning_info.record_info.record_length :=
          gfi^.positioning_info.record_info.record_length + data_length;
      ELSE
        gfi^.positioning_info.record_info.record_length := data_length;
      IFEND;
      gfi^.positioning_info.record_info.file_position := amc$eor;
    IFEND;

{ The following check will set file_position to mid_record if an abnormal condition
{ occurred (such as unrecovered write error).  End of tape errors will never happen
{ for labelled or unlabelled operations.  If label type is non_standard, the file
{ position is as computed above if the error is ame$end_of_tape_op_completed.

    IF NOT status.normal THEN
      gfi^.positioning_info.record_info.file_position := amc$mid_record;
    ELSEIF NOT put_data_status.normal THEN
      status := put_data_status;
      IF NOT (status.condition = ame$end_of_tape_op_completed) THEN
        gfi^.positioning_info.record_info.file_position := amc$mid_record;
      IFEND;
    IFEND;

    IF last_record_header_p <> NIL THEN
      gfi^.positioning_info.record_info.record_header_fba := #OFFSET( last_record_header_p);
    IFEND;

    gfi^.positioning_info.record_info.transfer_count := data_length;
    gfi^.positioning_info.record_info.residual_record_length := 0;

  PROCEND put_partial_req;

?? TITLE := 'skip_req', EJECT ??

  PROCEDURE skip_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      block_number: 0 .. amc$max_block_number,
      direction: amt$skip_direction,
      error_action: bat$error_actions,
      file_position: amt$file_position,
      last_record_header_p: ^bat$d_record_rcw,
      manually_advance_to_next_block: boolean,
      next_record_header_p: ^bat$d_record_rcw,
      no_header_read: boolean,
      records_remaining: amt$skip_count,
      request_status: ost$status,
      residual_data_length: 0 .. amc$maximum_block -1,
      residual_skip_count: amt$skip_count,
      rh: bat$d_record_rcw,
      skip_zero_completed: boolean,
      tape_failure_modes: amt$tape_failure_modes,
      units_to_skip: amt$skip_count,
      volume_position: amt$volume_position;


*copy bai$skip_to_next_ansi_rcw


  /main_program/
    BEGIN

      status.normal := TRUE;
      block_number := block_info^.block_number;
      direction := call_block.skp.direction;
      units_to_skip := call_block.skp.count;
      volume_position := tape_descriptor^.volume_position;

      IF (units_to_skip < 0) OR (units_to_skip > UPPERVALUE (amt$skip_count)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_skip_count,
        operation, ' ', status);
        RETURN;
      IFEND;

{
{ Check file position to see if any partial blocks need to be written out.
{

      IF bai$partial_block_exists () THEN
        bai$write_previous_block (file_identifier, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;


      CASE call_block.skp.unit OF

?? NEWTITLE := '    skip record', EJECT ??

      = amc$skip_record =

        last_record_header_p := NIL;
        no_header_read := FALSE;
        residual_data_length := gfi^.positioning_info.record_info.residual_record_length;
        residual_skip_count := units_to_skip;

        CASE tape_descriptor^.last_data_operation OF
        = amc$get_next_req, amc$get_partial_req =
          last_record_header_p := #ADDRESS(
            #RING( tape_descriptor^.get_tape_block_buffer),
            #SEGMENT(tape_descriptor^.get_tape_block_buffer),
            gfi^.positioning_info.record_info.record_header_fba);

        ELSE
        CASEND;

        CASE direction OF
        = amc$forward =

/skip_record_forward/
  BEGIN
          skip_zero_completed := FALSE;
          IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
            block_info^.current_block_byte_address :=
              block_info^.current_block_byte_address + residual_data_length;
            block_info^.residual_block_length :=
              block_info^.residual_block_length - residual_data_length;

            residual_data_length := 0;
            gfi^.positioning_info.record_info.file_position := amc$eor;

          IFEND;
          skip_zero_completed := TRUE;

          IF units_to_skip = 0 THEN
            call_block.skp.file_position^ := gfi^.positioning_info.record_info.file_position;
            file_instance^.residual_skip_count := residual_skip_count;
            gfi^.positioning_info.record_info.record_length := 0;
            gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
            gfi^.positioning_info.record_info.transfer_count := 0;
            RETURN;
          IFEND;


          WHILE residual_skip_count > 0 DO
            bai$skip_to_next_ansi_rcw;
            IF (no_header_read) OR (NOT status.normal) THEN
              EXIT /skip_record_forward/;
            IFEND;

            block_info^.current_block_byte_address :=
              block_info^.current_block_byte_address + residual_data_length;
            block_info^.residual_block_length :=
              block_info^.residual_block_length - residual_data_length;

            residual_data_length := 0;
            residual_skip_count := residual_skip_count - 1;

          WHILEND;
          gfi^.positioning_info.record_info.file_position := amc$eor;

          call_block.skp.file_position^ := gfi^.positioning_info.record_info.file_position;
          file_instance^.residual_skip_count := residual_skip_count;
          gfi^.positioning_info.record_info.record_length := 0;
          gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
          gfi^.positioning_info.record_info.transfer_count := 0;
          RETURN;

END /skip_record_forward/;

{ If this point is reached, an error condition (such as unrecovered read error or
{ tapemark encountered) has occurred.

          IF NOT status.normal THEN
            ;
          ELSEIF (units_to_skip = 0) OR (residual_skip_count > 0) THEN
            IF (tape_descriptor^.volume_position = amc$eov) OR
               (tape_descriptor^.volume_position = amc$after_tapemark) THEN
              IF bai$label_type () = amc$unlabelled THEN
                gfi^.positioning_info.record_info.file_position := amc$eoi;
              ELSEIF bai$label_type () = amc$labelled THEN
                gfi^.positioning_info.record_info.file_position := amc$eoi;
              ELSE { amc$non_standard_labelled
                IF skip_zero_completed THEN
                  gfi^.positioning_info.record_info.file_position := amc$eor;
                ELSE
                  gfi^.positioning_info.record_info.file_position := amc$mid_record;
                IFEND;
              IFEND;
              amp$set_file_instance_abnormal (file_identifier,
                ame$skip_encountered_eoi, operation, 'RECORDS', status);
            IFEND;
          IFEND;

          call_block.skp.file_position^ := gfi^.positioning_info.record_info.file_position;
          file_instance^.residual_skip_count := residual_skip_count;
          gfi^.positioning_info.record_info.record_length := 0;
          gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
          gfi^.positioning_info.record_info.transfer_count := 0;
          RETURN;

        ELSE

        CASEND;


?? TITLE := '    skip tape marks', EJECT ??

      = amc$skip_tape_mark =

        IF units_to_skip = 0 THEN {no-op.}
          file_instance^.residual_skip_count := 0;
          call_block.skp.file_position^ := gfi^.positioning_info.record_info.file_position;
          RETURN;
        IFEND;

        residual_skip_count := units_to_skip;
        file_position := gfi^.positioning_info.record_info.file_position;

/skip_tapemark_main/
BEGIN

        IF direction = amc$forward THEN

        /whileloop/
          WHILE residual_skip_count > 0 DO

            REPEAT
              bap$tape_bm_skip_tapemark (file_identifier, direction, tape_failure_modes, request_status);
              bai$process_request_status (file_identifier, operation, request_status,
                    tape_failure_modes, error_action, status);
              IF NOT status.normal AND (status.condition = ame$input_after_output) THEN
                file_position := amc$eoi;
                volume_position := amc$eov;
                amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi, operation,
                        'TAPEMARKS', status);
                EXIT /skip_tapemark_main/;
              IFEND;
              IF error_action = bac$exit_procedure THEN
                EXIT /skip_tapemark_main/;
              IFEND;
            UNTIL error_action <> bac$retry_last_request;

            IF bai$label_type () = amc$unlabelled THEN
              bai$check_tapemark (file_identifier, volume_position, request_status);
              bai$process_request_status (file_identifier, operation, request_status,
                    tape_failure_modes, error_action, status);
              IF NOT status.normal OR (error_action = bac$exit_procedure) THEN
                EXIT /skip_tapemark_main/;
              IFEND;
              CASE volume_position OF
              = amc$after_tapemark =
                residual_skip_count := residual_skip_count - 1;
              = amc$eov =
                bai$advance_volume (file_identifier, volume_position, status);
                IF NOT status.normal THEN
                  EXIT /skip_tapemark_main/;
                IFEND;
                IF volume_position = amc$eov THEN
                  EXIT /whileloop/;
                IFEND;
              ELSE
                ;
              CASEND;
            ELSE { label_type <> amc$unlabelled     }

{
{ Since skipping by tapemarks is illegal on labelled tapes, this call must for non_standard labels.
{
{ Consecutive tapemarks indicate a null file, not end of volume, and each tapemark needs to be skipped.
{

              residual_skip_count := residual_skip_count - 1;

            IFEND;

          WHILEND /whileloop/;

          IF residual_skip_count > 0 THEN
            amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi, operation,
              'TAPEMARKS', status);
          IFEND;
          IF status.normal THEN
            file_position := amc$boi;
            volume_position := amc$after_tapemark;
          ELSE
            file_position := amc$eoi;
            volume_position := amc$eov;
          IFEND;

        ELSE { direction = amc$backward }

          /backloop/
            WHILE residual_skip_count > 0 DO

              REPEAT
                bap$tape_bm_skip_tapemark (file_identifier, direction, tape_failure_modes, request_status);
                bai$process_request_status (file_identifier, operation, request_status,
                      tape_failure_modes, error_action, status);
                IF error_action = bac$exit_procedure THEN
                  EXIT /skip_tapemark_main/;
                IFEND;
                IF NOT status.normal AND (status.condition = ame$skip_encountered_bov) THEN
                  EXIT /backloop/;
                IFEND;
                IF status.normal THEN
                  residual_skip_count := residual_skip_count - 1;
                IFEND;
              UNTIL error_action <> bac$retry_last_request;

            WHILEND /backloop/;

            IF residual_skip_count > 0 THEN
              amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_bov, operation,
                'TAPEMARKS', status);
            IFEND;
            IF status.normal THEN
              file_position := amc$eoi;
              volume_position := amc$before_tapemark;
            ELSE
              file_position := amc$boi;
              volume_position := amc$bov;
            IFEND;
        IFEND;

        block_number := 1;

END /skip_tapemark_main/;

        call_block.skp.file_position^ := file_position;
        gfi^.positioning_info.record_info.file_position := file_position;
        file_instance^.residual_skip_count := residual_skip_count;
        tape_descriptor^.volume_position := volume_position;
        block_info^.block_number := block_number;
        block_info^.block_position := bac$beginning_of_block;
        block_info^.current_block_byte_address := 0;
        block_info^.current_block_length := 0;
        block_info^.residual_block_length := 0;
        gfi^.positioning_info.record_info.residual_record_length := 0;
        gfi^.positioning_info.record_info.record_length := 0;
        tape_descriptor^.put_tape_block_buffer := NIL;
        tape_descriptor^.get_tape_block_buffer := NIL;



?? OLDTITLE ??
      ELSE
      CASEND;

    END /main_program/;


  PROCEND skip_req;


*copy bai$lrt_common_procedures
MODEND bam$lrt_us_ansi_d_tape_fap;
*DECK DECK=BAM$LRT_US_ANSI_S_TAPE_FAP EXPAND=TRUE

MODULE bam$lrt_us_ansi_s_tape_fap;
?? LEFT := 1, RIGHT := 110 ??
? VAR user_fap: boolean := FALSE ?;
? VAR pad_records: boolean := FALSE?;
?? PUSH (LIST := OFF) ??

























?? POP ??
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
?? TITLE := 'Type definitions' ??
*copyc amt$tape_error_options
*copyc amt$file_identifier
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc bat$put_label_request
*copyc bat$s_record_scw
*copyc ost$caller_identifier
*copyc bak$bap_procedure_keypoints
?? TITLE := 'Error code definitions', EJECT ??
*copyc ame$improper_file_id
*copyc ame$improper_wsl
*copyc ame$get_program_actions
*copyc ame$get_validation_errors
*copyc ame$put_program_actions
*copyc ame$put_validation_errors
*copyc ame$skip_program_actions
*copyc ame$skip_validation_errors
*copyc bae$tape_bm_error_codes
*copyc dme$tape_errors
?? OLDTITLE ??
?? EJECT ??
?? POP ??
{ The following POP pragmat is here to negate an extra push (listext :=on) in one of the bam decks. }
?? POP ??
?? TITLE := 'XREF variable and procedure definitions' ??
*copyc osv$task_private_heap
*copyc amp$set_file_instance_abnormal
*copyc bap$close
*copyc bap$tape_bm_align_position
*copyc bap$tape_bm_flush
*copyc bap$tape_bm_open
*copyc bap$tape_bm_read_label
*copyc bap$tape_bm_read_next_block
*copyc bap$tape_bm_read_to_write
*copyc bap$tape_bm_close
*copyc bap$tape_bm_write_next_block
*copyc bap$tape_bm_reserve_blk_buffer
*copyc bap$tape_bm_skip_blocks
*copyc bap$tape_bm_skip_tapemark
*copyc bap$tape_bm_rewind
*copyc bap$tape_bm_advance_volume
*copyc bap$tape_bm_erase_block
*copyc bap$tape_bm_tapemark_check
*copyc bap$tape_bm_write_tape_mark
*copyc bap$tape_bm_write_label
*copyc bap$tape_bm_write_label_mark
*copyc bap$fap_control
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_integer
?? TITLE := 'INLINE function definitions' ??
?? NEWTITLE := ' ' ??
?? TITLE := 'bai$state_info', EJECT ??
*copyc bai$state_info
?? TITLE := 'bai$tape_descriptor', EJECT ??
*copyc bai$tape_descriptor
?? TITLE := 'bai$block_info', EJECT ??
*copyc bai$block_info
?? TITLE := 'bai$dynamic_label', EJECT ??
*copyc bai$dynamic_label
?? TITLE := 'bai$gfi', EJECT ??
*copyc bai$gfi
?? TITLE := 'bai$label_type', EJECT ??
*copyc bai$label_type
?? TITLE := 'bai$partial_block_exists', EJECT ??
*copyc bai$partial_block_exists
?? TITLE := 'bai$partial_read_block_exists', EJECT ??
*copyc bai$partial_read_block_exists
?? TITLE := 'bai$partial_record_exists', EJECT ??
*copyc bai$partial_record_exists
?? TITLE := 'bai$static_label', EJECT ??
*copyc bai$static_label
?? OLDTITLE ??
?? TITLE := 'INLINE procedure definitions' ??
?? NEWTITLE := ' ' ??
?? TITLE := 'osp$disestablish_cond_handler', EJECT ??
*copyc osp$disestablish_cond_handler
?? TITLE := 'osp$establish_block_exit_hndlr', EJECT ??
*copyc osp$establish_block_exit_hndlr
?? TITLE := 'bai$advance_volume', EJECT ??
*copyc bai$advance_volume
?? TITLE := 'bai$append_tape_error', EJECT ??
*copyc bai$append_tape_error
?? TITLE := 'bai$check_caller_id', EJECT ??
*copyc bai$check_caller_id
?? TITLE := 'bai$check_record_level_access', EJECT ??
*copyc bai$check_record_level_access
?? TITLE := 'bai$check_tapemark', EJECT ??
*copyc bai$check_tapemark
?? TITLE := 'bai$clear_fail_at_current_pos', EJECT ??
*copyc bai$clear_fail_at_current_pos
?? TITLE := 'bai$fetch_tape_error_options', EJECT ??
*copyc bai$fetch_tape_error_options
?? TITLE := 'bai$forced_write', EJECT ??
*copyc bai$forced_write
?? TITLE := 'bai$init_boi_tape_position', EJECT ??
*copyc bai$init_boi_tape_position
?? TITLE := 'bai$process_block_information', EJECT ??
*copyc bai$process_block_information
?? TITLE := 'bai$process_request_status', EJECT ??
*copyc bai$process_request_status
?? TITLE := 'bai$validate_tape_access', EJECT ??
*copyc bai$validate_tape_access
?? TITLE := 'bai$write_previous_block', EJECT ??
*copyc bai$write_previous_block
?? TITLE := 'bap$validate_fap_identifier', EJECT ??
*copyc bap$validate_fap_identifier
?? TITLE := 'bap$validate_file_identifier', EJECT ??
*copyc bap$validate_file_identifier
?? TITLE := 'i#move', EJECT ??
*copyc i#move
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? TITLE := 'global variables for this call of the fap', EJECT ??
*copyc bav$global_tape_fap_variables

  CONST
    pad_blocks = TRUE,
    record_headers_exist = TRUE;

?? TITLE := 'bap#lrt_us_ansi_s_tape_fap', EJECT ??
? IF user_fap THEN
  VAR
    ttv$layer_number: [XDCL] amt$fap_layer_number := 0;

  PROCEDURE [XDCL, #GATE] bap#lrt_us_ansi_s_tape_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    ttv$layer_number := layer_number;
    bap$lrt_us_ansi_s_tape_fap (file_identifier, call_block, layer_number, status);

  PROCEND bap#lrt_us_ansi_s_tape_fap;
? IFEND

?? TITLE := 'bap$lrt_us_ansi_s_tape_fap', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$lrt_us_ansi_s_tape_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      dynamic_label: ^bat$dynamic_label_attributes,
      i: integer,
      last_record_header_p: ^bat$s_record_scw,
      local_status: ost$status,
      static_label: ^bat$instance_static_attributes,
      validation_ok: boolean;

    #caller_id (caller_id);
    operation := call_block.operation;
    #keypoint (osk$entry, osk$m * ((file_identifier.ordinal * 256) + operation),
          bak$sys_blk_var_rec_tape_fap);
    status.normal := TRUE;
    global_layer_number := layer_number;
    close_file_on_exit := FALSE;

  /main_program/
    BEGIN

? IF user_fap THEN
      bap$validate_fap_identifier (file_identifier, file_instance, validation_ok);
? ELSE
      bap$validate_file_identifier (file_identifier, file_instance, validation_ok);
? IFEND
      IF NOT validation_ok THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
          'bap$lrt_us_ansi_s_tape_fap', status);
        EXIT /main_program/;
      IFEND;

      block_info := bai$block_info (file_instance);
      gfi := bai$gfi (file_instance);
      tape_descriptor := bai$tape_descriptor (file_instance);
      static_label := bai$static_label (file_instance);
      state_info := bai$state_info (file_instance);
      rhl := #SIZE(bat$s_record_scw);
      bai$check_caller_id (file_identifier, static_label^.ring_attributes, operation, caller_id,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      bai$check_record_level_access (file_identifier, file_instance^.access_level, operation,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      dynamic_label := bai$dynamic_label (file_instance);
      bai$validate_tape_access (file_identifier, dynamic_label^.access_mode, operation, tape_descriptor,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      bai$clear_fail_at_current_pos (operation, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      tape_descriptor^.error_options := dynamic_label^.error_options;

      CASE operation OF

      = amc$close_req =
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: US/S FAP called on CLOSE');
        IF bai$partial_block_exists () THEN
          process_previous_block (file_identifier, status);
        IFEND; { Ignore status.
        close_req (file_identifier, status);
        bap$close (file_identifier, local_status);
        IF status.normal THEN
          status := local_status;
        IFEND;
      = amc$close_volume_req =
        IF (bai$partial_block_exists()) AND (bai$label_type() = amc$unlabelled) THEN
          process_previous_block (file_identifier, status);
        IFEND;
        IF status.normal THEN
          close_volume_req (file_identifier, status);
        IFEND;
        gfi^.positioning_info.record_info.residual_record_length := 0;
        file_instance^.previous_get_at_eoi := FALSE;
      = amc$erase_tape_block =
        IF bai$partial_block_exists () THEN
          process_previous_block (file_identifier, status);
          IF status.normal THEN
            erase_tape_block_req (file_identifier, call_block, status);
          ELSE
            tape_descriptor^.volume_position := amc$after_data_block;
          IFEND;
        ELSE
          erase_tape_block_req (file_identifier, call_block, status);
        IFEND;
        tape_descriptor^.last_data_operation := amc$erase_tape_block;
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$fetch_req =
        bap$fap_control (file_identifier, call_block, layer_number, status);
      = amc$flush_req =
        IF bai$partial_block_exists () THEN
          process_previous_block (file_identifier, status);
        IFEND;
        flush_req (file_identifier, status);
        gfi^.positioning_info.record_info.residual_record_length := 0;
        tape_descriptor^.last_data_operation := amc$flush_req;
      = amc$get_next_req =
        get_next_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$get_next_req;
        IF status.normal AND (call_block.getn.file_position^ <> amc$eoi) THEN
          tape_descriptor^.at_eoi := FALSE;
        IFEND;
      = amc$get_partial_req =
        get_partial_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$get_partial_req;
        IF status.normal AND (call_block.getp.file_position^ <> amc$eoi) THEN
          tape_descriptor^.at_eoi := FALSE;
        IFEND;
      = amc$open_req =
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: US/S FAP called on OPEN');
        tape_descriptor^.file_label_type := static_label^.file_label_type;

        CASE bai$label_type() OF
        = amc$labelled =
          open_req (file_identifier, call_block, layer_number, dynamic_label, status);
        = amc$unlabelled, amc$non_standard_labelled =
? IF user_fap THEN
          open_req (file_identifier, call_block, layer_number, dynamic_label, status);
? ELSE
          amp$set_file_instance_abnormal(file_identifier, ame$bt_rt_supp_only_for_labeled,
            operation, 'Block type USER_SPECIFIED (US), record type ANSI_SPANNED (S)', status);
? IFEND
        ELSE
          amp$set_file_instance_abnormal(file_identifier, ame$tape_rcd_mgr_malfunction,
            operation, 'Unknown file_label_type in open_req (US/S fap)', status);
        CASEND;
      = amc$put_next_req =
        IF (bai$label_type () = amc$labelled) THEN
          IF NOT state_info^.ve_wrote_ansi_file THEN
            amp$set_file_instance_abnormal (file_identifier, ame$rewrite_labels_conflict,
                  call_block.operation, ' ', status);
            RETURN;
          IFEND;
          IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
            sl_reposition_for_put_at_eoi (file_identifier, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
        put_next_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$put_next_req;
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$put_partial_req =
        IF (bai$label_type () = amc$labelled) THEN
          IF NOT state_info^.ve_wrote_ansi_file THEN
            amp$set_file_instance_abnormal (file_identifier, ame$rewrite_labels_conflict,
                  call_block.operation, ' ', status);
            RETURN;
          IFEND;
          IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
            sl_reposition_for_put_at_eoi (file_identifier, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
        put_partial_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$put_partial_req;
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$rewind_req =
        IF bai$partial_block_exists () THEN
          process_previous_block (file_identifier, status);
          IF status.normal THEN
            rewind_req (file_identifier, call_block, status);
          IFEND;
        ELSE
          rewind_req (file_identifier, call_block, status);
        IFEND;
        tape_descriptor^.last_data_operation := amc$rewind_req;
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := FALSE;
      = amc$skip_req =
        validate_skip_parameters (file_identifier, call_block, FALSE, FALSE, TRUE, FALSE, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        skip_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$skip_req;
        file_instance^.previous_get_at_eoi := FALSE;
      = amc$write_tape_mark_req =
        IF bai$label_type () = amc$labelled THEN
          amp$set_file_instance_abnormal (file_identifier, ame$improper_labelled_tape_op,
                call_block.operation, 'WRITE OF TAPE MARK', status);
          EXIT /main_program/;
        IFEND;
        IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
          last_record_header_p := NIL;
          CASE tape_descriptor^.last_data_operation OF
          = amc$get_next_req, amc$get_partial_req =
            last_record_header_p := #ADDRESS(
              #RING( tape_descriptor^.get_tape_block_buffer),
              #SEGMENT(tape_descriptor^.get_tape_block_buffer),
              gfi^.positioning_info.record_info.record_header_fba);
            CASE last_record_header_p^.header_type OF
            = bac$full_segment, bac$end_segment =
              adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
                gfi^.positioning_info.record_info.residual_record_length, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
            = bac$start_segment =
              last_record_header_p^.header_type := bac$full_segment;
              adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
                gfi^.positioning_info.record_info.residual_record_length, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
            = bac$continued_segment =
              last_record_header_p^.header_type := bac$end_segment;
              adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
                gfi^.positioning_info.record_info.residual_record_length, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
            ELSE
              amp$set_file_instance_abnormal(file_identifier, ame$tape_rcd_mgr_malfunction,
                operation, 'Incorrect record header in US/S write_tape_mark', status);
              EXIT /main_program/;
            CASEND;
            block_info^.block_position := bac$middle_of_block;
            gfi^.positioning_info.record_info.file_position := amc$eor;
          ELSE
          CASEND;
        IFEND;

{   Check if last operation was read type that left tape logically at mid_block

        IF bai$partial_read_block_exists () THEN
          switch_from_read_to_write (file_identifier, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;

        IF bai$partial_block_exists () THEN
          process_previous_block (file_identifier, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;

        write_tape_mark_req (file_identifier, call_block, status);
        tape_descriptor^.last_data_operation := amc$write_tape_mark_req;
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      ELSE

        bap$fap_control (file_identifier, call_block, layer_number, status);

      CASEND;

    END /main_program/;

    IF (operation >= amc$last_access_start) AND (operation <= amc$max_operation)
      AND (operation <> amc$fetch_req) AND (operation <> amc$fetch_access_information_rq) THEN
      gfi^.last_access_operation := operation;
    IFEND;

    IF status.normal THEN
      gfi^.error_status := 0;
    ELSE
      gfi^.error_status := status.condition;
    IFEND;

{
{   IF the operator terminates a tape assignment that was initiated via bai$advance_volume,
{   the file will be closed at this point.
{

    IF close_file_on_exit THEN
      bap$close (file_identifier, local_status);
    IFEND;

    #keypoint (osk$exit, 0, bak$sys_blk_var_rec_tape_fap);

  PROCEND bap$lrt_us_ansi_s_tape_fap;


?? TITLE := 'adjust_length_in_last_header', EJECT ??

  PROCEDURE adjust_length_in_last_header (
    file_identifier: amt$file_identifier;
    header_p: ^bat$s_record_scw;
    operator: (add, subtract);
    value: integer;
    VAR status: ost$status);

    VAR
      binary_length: clt$integer,
      character_length: string (bac$scw_length_size),
      character_length_index: integer,
      i: integer,
      working_string: ost$string;

    status.normal := TRUE;

    IF value = 0 THEN
      RETURN;
    IFEND;

    IF header_p = NIL THEN
      amp$set_file_instance_abnormal(file_identifier, ame$tape_rcd_mgr_malfunction, operation,
        'Incorrect header pointer in US/S procedure: adjust_length_in_last_header', status);
      RETURN;
    IFEND;

    clp$convert_string_to_integer (header_p^.length, binary_length, status);
    IF NOT status.normal THEN
      amp$set_file_instance_abnormal(file_identifier, ame$improper_record_header, operation,
        'Non numeric header encountered in US/S procedure: adjust_length_in_last_header', status);
      RETURN;
    IFEND;

    IF operator = add THEN
      binary_length.value := binary_length.value + value;
    ELSEIF operator = subtract THEN
      binary_length.value := binary_length.value - value;
    ELSE
      amp$set_file_instance_abnormal(file_identifier, ame$tape_rcd_mgr_malfunction, operation,
        'Incorrect operator encountered in US/S procedure: adjust_length_in_last_header', status);
      RETURN;
    IFEND;

    IF (binary_length.value > UPPERVALUE(bat$scw_length_value_range)) OR
       (binary_length.value < LOWERVALUE(bat$scw_length_value_range)) THEN
      amp$set_file_instance_abnormal(file_identifier, ame$tape_rcd_mgr_malfunction, operation,
        'SCW length value exceeds range in US/S procedure: adjust_length_in_last_header', status);
      RETURN;
    IFEND;

    clp$convert_integer_to_string (binary_length.value, 10, FALSE, working_string, status);
    IF NOT status.normal THEN
      amp$set_file_instance_abnormal(file_identifier, ame$tape_rcd_mgr_malfunction, operation,
        'Integer to string error encountered in US/S procedure: adjust_length_in_last_header', status);
      RETURN;
    IFEND;

    IF working_string.size > bac$scw_length_size THEN
      amp$set_file_instance_abnormal(file_identifier, ame$tape_rcd_mgr_malfunction, operation,
        'SCW length overflow encountered in US/S procedure: adjust_length_in_last_header', status);
      RETURN;
    ELSE
      character_length := bac$scw_length_value_of_zero;
      character_length_index := bac$scw_length_size;
      FOR i := working_string.size DOWNTO 1 DO
        character_length(character_length_index) := working_string.value(i);
        character_length_index := character_length_index - 1;
      FOREND;
      header_p^.length := character_length;
    IFEND;


  PROCEND adjust_length_in_last_header;

?? TITLE := 'get_next_req', EJECT ??

{
{ The purpose of this request is to cause the transfer of data from tape to a
{ tape buffer, transfer data from the tape buffer to the users working
{ storage area, and to update all file descriptor fields.
{

  PROCEDURE get_next_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    CONST
      allow_direct_io_transfer = FALSE;

    VAR
      data_length : 0 .. amc$maximum_block - 1,
      exit_situation : boolean,
      get_size : 0 .. amc$maximum_block - 1,
      last_record_header_p: ^bat$s_record_scw,
      manually_advance_to_next_block: boolean,
      more_data : boolean,
      no_header_read : boolean,
      residual_data_length : 0 .. amc$maximum_block - 1,
      rh: bat$s_record_scw,
      start_new_block : boolean,
      wsa : ^cell,
      wsl : amt$working_storage_length,
      zero_length_record : boolean;


*copy bai$get_ansi_scw


      status.normal := TRUE;
      call_block.getn.transfer_count^ := 0;
      data_length := 0;
      exit_situation := FALSE;
      last_record_header_p := NIL;
      manually_advance_to_next_block := FALSE;
      more_data := TRUE;
      no_header_read := FALSE;
      residual_data_length := gfi^.positioning_info.record_info.residual_record_length;
      start_new_block := FALSE;
      wsa := call_block.getn.working_storage_area;
      wsl := call_block.getn.working_storage_length;
      zero_length_record := FALSE;

      IF (wsl <= 0) OR (wsl > UPPERVALUE (amt$working_storage_length)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
        operation, ' ', status);
        RETURN;
      IFEND;


{
{ Check file position to see if any partial blocks need to be written out.
{

      IF bai$partial_block_exists () THEN
        process_previous_block (file_identifier, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

  /main_program/
    BEGIN


{
{  Advance forward to the next record boundary if necessary.
{

      IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN

        REPEAT
          block_info^.current_block_byte_address :=
            block_info^.current_block_byte_address + residual_data_length;
          block_info^.residual_block_length :=
            block_info^.residual_block_length - residual_data_length;
          bai$get_ansi_scw;
          IF (NOT status.normal) OR (no_header_read) THEN
            EXIT /main_program/;
          IFEND;
        UNTIL (rh.header_type = bac$start_segment) OR (rh.header_type = bac$full_segment);

        IF (zero_length_record) THEN
          EXIT /main_program/;
        IFEND;
      IFEND;


      WHILE more_data DO

        gfi^.positioning_info.record_info.transfer_count := 0;

        IF residual_data_length = 0 THEN
          bai$get_ansi_scw;
          IF exit_situation THEN
            EXIT /main_program/;
          IFEND;
        IFEND;

        IF wsl > residual_data_length THEN
          CASE rh.header_type OF
            = bac$start_segment, bac$continued_segment =
                get_size := residual_data_length;
            = bac$full_segment, bac$end_segment =
                get_size := residual_data_length;
                more_data := FALSE;
            ELSE
              amp$set_file_instance_abnormal (file_identifier,
                ame$improper_record_header, call_block.operation,
                ' ', status);
              RETURN;
          CASEND;

        ELSE { wsl <= residual_data_length
          get_size := wsl;
          more_data := FALSE;
        IFEND;

        get_data (file_identifier, operation, wsa, get_size, allow_direct_io_transfer,
              start_new_block, {convert_if_ebcdic =} TRUE, status);
        data_length := data_length + gfi^.positioning_info.record_info.transfer_count;
        residual_data_length := residual_data_length - gfi^.positioning_info.record_info.transfer_count;
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        IF gfi^.positioning_info.record_info.transfer_count < get_size THEN
          get_size := gfi^.positioning_info.record_info.transfer_count;
        IFEND;


        wsl := wsl - get_size;
        wsa := #address (#ring (wsa), #segment (wsa), (#offset (wsa) + get_size));
      WHILEND;

    END /main_program/;

      IF (tape_descriptor^.volume_position = amc$eov) OR
         (tape_descriptor^.volume_position = amc$after_tapemark) THEN
        CASE bai$label_type() OF
        = amc$unlabelled =
          gfi^.positioning_info.record_info.file_position := amc$eoi;
          file_instance^.previous_get_at_eoi := TRUE;
          tape_descriptor^.at_eoi := TRUE;
        = amc$labelled =
          gfi^.positioning_info.record_info.file_position := amc$eoi;
          file_instance^.previous_get_at_eoi := TRUE;
        = amc$non_standard_labelled =
          gfi^.positioning_info.record_info.file_position := amc$mid_record;
        ELSE
          amp$set_file_instance_abnormal (file_identifier,
            ame$tape_rcd_mgr_malfunction, operation,
            'Unknown file_label_type in get_next_req (US/S)', status);
        CASEND;
      ELSEIF NOT status.normal THEN
        ;
      ELSEIF zero_length_record THEN
        gfi^.positioning_info.record_info.file_position := amc$eor;
      ELSEIF manually_advance_to_next_block THEN
        ;
      ELSE
        CASE rh.header_type OF
          = bac$start_segment, bac$continued_segment =
            gfi^.positioning_info.record_info.file_position := amc$mid_record;

          = bac$full_segment, bac$end_segment =
            IF residual_data_length = 0 THEN
              gfi^.positioning_info.record_info.file_position := amc$eor;
            ELSE
              gfi^.positioning_info.record_info.file_position := amc$mid_record;
            IFEND;

          ELSE
            amp$set_file_instance_abnormal (file_identifier,
              ame$improper_record_header, call_block.operation,
              ' ', status);

        CASEND;
      IFEND;

      IF last_record_header_p <> NIL THEN
        gfi^.positioning_info.record_info.record_header_fba := #OFFSET( last_record_header_p);
      IFEND;

      gfi^.positioning_info.record_info.transfer_count := data_length;
      gfi^.positioning_info.record_info.record_length := data_length;
      gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
      call_block.getn.file_position^ := gfi^.positioning_info.record_info.file_position;
      call_block.getn.transfer_count^ := gfi^.positioning_info.record_info.transfer_count;

  PROCEND get_next_req;

?? TITLE := 'get_partial_req', EJECT ??

{
{ The purpose of this request is to cause a partial transfer of data from tape to a
{ tape buffer, transfer data from the tape buffer to the users working
{ storage area, and to update all file descriptor fields.
{

  PROCEDURE get_partial_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    CONST
      allow_direct_io_transfer = FALSE;

    VAR
      data_length : 0 .. amc$maximum_block - 1,
      exit_situation : boolean,
      get_size : 0 .. amc$maximum_block - 1,
      last_record_header_p: ^bat$s_record_scw,
      manually_advance_to_next_block: boolean,
      more_data : boolean,
      no_header_read : boolean,
      residual_data_length : 0 .. amc$maximum_block - 1,
      rh: bat$s_record_scw,
      start_new_block : boolean,
      wsa : ^cell,
      wsl : amt$working_storage_length,
      zero_length_record : boolean;


*copy bai$get_ansi_scw


      status.normal := TRUE;
      call_block.getn.transfer_count^ := 0;
      data_length := 0;
      exit_situation := FALSE;
      last_record_header_p := NIL;
      manually_advance_to_next_block := FALSE;
      more_data := TRUE;
      no_header_read := FALSE;
      residual_data_length := gfi^.positioning_info.record_info.residual_record_length;
      start_new_block := FALSE;
      wsa := call_block.getp.working_storage_area;
      wsl := call_block.getp.working_storage_length;
      zero_length_record := FALSE;

      IF (wsl <= 0) OR (wsl > UPPERVALUE (amt$working_storage_length)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
        operation, ' ', status);
        RETURN;
      IFEND;

      IF (call_block.getp.skip_option < LOWERVALUE (amt$skip_option)) OR
        (call_block.getp.skip_option > UPPERVALUE (amt$skip_option)) THEN
        amp$set_file_instance_abnormal (file_identifier,
          ame$improper_skip_option, call_block.operation, ' ', status);
        RETURN;
      IFEND;

      IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
        CASE tape_descriptor^.last_data_operation OF
        = amc$get_next_req, amc$get_partial_req =
          last_record_header_p := #ADDRESS(
            #RING( tape_descriptor^.get_tape_block_buffer),
            #SEGMENT(tape_descriptor^.get_tape_block_buffer),
            gfi^.positioning_info.record_info.record_header_fba);
          rh := last_record_header_p^;

        ELSE
        CASEND;
      IFEND;

{
{ Check file position to see if any partial blocks need to be written out.
{

      IF bai$partial_block_exists () THEN
        process_previous_block (file_identifier, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        gfi^.positioning_info.record_info.record_length := 0;
      IFEND;

  /main_program/
    BEGIN


{
{  Advance forward to the next record boundary if necessary.
{

      IF call_block.getp.skip_option = amc$skip_to_eor THEN
        IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN

          REPEAT
            block_info^.current_block_byte_address :=
              block_info^.current_block_byte_address + residual_data_length;
            block_info^.residual_block_length :=
              block_info^.residual_block_length - residual_data_length;
            bai$get_ansi_scw;
            IF NOT status.normal THEN
              EXIT /main_program/;
            ELSEIF no_header_read THEN
              gfi^.positioning_info.record_info.record_length := 0;
              EXIT /main_program/;
            IFEND;
          UNTIL (rh.header_type = bac$start_segment) OR (rh.header_type = bac$full_segment);

          gfi^.positioning_info.record_info.record_length := 0;

          IF (zero_length_record) THEN
            EXIT /main_program/;
          IFEND;

        IFEND;
      IFEND;

      IF gfi^.positioning_info.record_info.file_position <> amc$mid_record THEN
        gfi^.positioning_info.record_info.record_length := 0;
      IFEND;


      WHILE more_data DO

        gfi^.positioning_info.record_info.transfer_count := 0;
{ ! If prior operation = put_next or put_partial, residual_data_length = 0.    }
        IF residual_data_length = 0 THEN
          bai$get_ansi_scw;
          IF exit_situation THEN
            EXIT /main_program/;
          IFEND;
        IFEND;

        IF wsl > residual_data_length THEN
          CASE rh.header_type OF
            = bac$start_segment, bac$continued_segment =
                get_size := residual_data_length;
            = bac$full_segment, bac$end_segment =
                get_size := residual_data_length;
                more_data := FALSE;
            ELSE
              amp$set_file_instance_abnormal (file_identifier,
                ame$improper_record_header, call_block.operation,
                ' ', status);
              RETURN;
          CASEND;

        ELSE { wsl <= residual_data_length
          get_size := wsl;
          more_data := FALSE;
        IFEND;

        get_data (file_identifier, operation, wsa, get_size, allow_direct_io_transfer,
              start_new_block, {convert_if_ebcdic =} TRUE, status);
        data_length := data_length + gfi^.positioning_info.record_info.transfer_count;
        residual_data_length := residual_data_length - gfi^.positioning_info.record_info.transfer_count;
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        IF gfi^.positioning_info.record_info.transfer_count < get_size THEN
          get_size := gfi^.positioning_info.record_info.transfer_count;
        IFEND;


        wsl := wsl - get_size;
        wsa := #address (#ring (wsa), #segment (wsa), (#offset (wsa) + get_size));
      WHILEND;

    END /main_program/;

    IF (tape_descriptor^.volume_position = amc$eov) OR
       (tape_descriptor^.volume_position = amc$after_tapemark) THEN
      CASE bai$label_type() OF
      = amc$unlabelled =
        gfi^.positioning_info.record_info.file_position := amc$eoi;
        file_instance^.previous_get_at_eoi := TRUE;
        tape_descriptor^.at_eoi := TRUE;
      = amc$labelled =
        gfi^.positioning_info.record_info.file_position := amc$eoi;
        file_instance^.previous_get_at_eoi := TRUE;
      = amc$non_standard_labelled =
        gfi^.positioning_info.record_info.file_position := amc$mid_record;
      ELSE
        amp$set_file_instance_abnormal (file_identifier,
          ame$tape_rcd_mgr_malfunction, operation,
          'Unknown file_label_type in get_next_req (US/S)', status);
      CASEND;
    ELSEIF NOT status.normal THEN
      ;
    ELSEIF zero_length_record THEN
      gfi^.positioning_info.record_info.file_position := amc$eor;
    ELSEIF manually_advance_to_next_block THEN
      ;
    ELSE
      CASE rh.header_type OF
        = bac$start_segment, bac$continued_segment =
          gfi^.positioning_info.record_info.file_position := amc$mid_record;

        = bac$full_segment, bac$end_segment =
          IF residual_data_length = 0 THEN
            gfi^.positioning_info.record_info.file_position := amc$eor;
          ELSE
            gfi^.positioning_info.record_info.file_position := amc$mid_record;
          IFEND;

        ELSE
          amp$set_file_instance_abnormal (file_identifier,
            ame$improper_record_header, call_block.operation,
            ' ', status);

      CASEND;
    IFEND;

    IF last_record_header_p <> NIL THEN
      gfi^.positioning_info.record_info.record_header_fba := #OFFSET( last_record_header_p);
    IFEND;

    gfi^.positioning_info.record_info.transfer_count := data_length;
    gfi^.positioning_info.record_info.record_length :=
      gfi^.positioning_info.record_info.record_length + data_length;
    gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
    call_block.getp.file_position^ := gfi^.positioning_info.record_info.file_position;
    call_block.getp.transfer_count^ := gfi^.positioning_info.record_info.transfer_count;
    call_block.getp.record_length^ := gfi^.positioning_info.record_info.record_length;

  PROCEND get_partial_req;

?? TITLE := 'process_previous_block', EJECT ??

  PROCEDURE process_previous_block (file_identifier: amt$file_identifier;
    VAR status: ost$status);

    VAR
      file_position: amt$file_position,
      last_record_header_p : ^bat$s_record_scw;

      status.normal := TRUE;
      file_position := gfi^.positioning_info.record_info.file_position;
      last_record_header_p := NIL;

      IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
        last_record_header_p := #ADDRESS(
          #RING( tape_descriptor^.put_tape_block_buffer),
          #SEGMENT(tape_descriptor^.put_tape_block_buffer),
          gfi^.positioning_info.record_info.record_header_fba);
        CASE last_record_header_p^.header_type OF
        = bac$start_segment =
          last_record_header_p^.header_type := bac$full_segment;
          file_position := amc$eor;
        = bac$continued_segment =
          last_record_header_p^.header_type := bac$end_segment;
          file_position := amc$eor;
        ELSE
        CASEND;
      IFEND;

      bai$write_previous_block (file_identifier, status);
{ !   file_position returned from bai$write_previous_block will always
{     = amc$eor due to oversight of ss/v environment.
{     All instances of calls in all of the tape faps should be changed to
{     set the appropriate file_position after returning from the call.
      IF status.normal THEN
        gfi^.positioning_info.record_info.file_position := file_position;
{       file_position = amc$eor.
      IFEND;


  PROCEND process_previous_block;


?? TITLE := 'put_next_req', EJECT ??

{
{ The purpose of this request is to transfer data from the users
{ working storage area to a tape file, either directly, or through
{ a tape buffer, and to update all file descriptor fields.
{


  PROCEDURE put_next_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      data_length : 0 .. amc$maximum_block - 1,
      end_of_data : boolean,
      last_record_header_p: ^bat$s_record_scw,
      max_data_size : 0 .. amc$maximum_block - 1,
      more_data : boolean,
      put_size : 0 .. amc$maximum_block - 1,
      rh : bat$s_record_scw,
      start_of_data : boolean,
      term_option : amt$term_option,
      terminate_previous_block : boolean,
      wsa : ^cell,
      wsl : amt$working_storage_length;


*copy bai$put_ansi_scw_for_putn


  /main_program/
    BEGIN

      status.normal := TRUE;
      data_length := 0;
      end_of_data := FALSE;
      last_record_header_p := NIL;
      max_data_size := gfi^.max_data_size;
      more_data := TRUE;
      start_of_data := TRUE;
      wsa := call_block.putn.working_storage_area;
      wsl := call_block.putn.working_storage_length;

      IF (wsl < 0) OR (wsl > UPPERVALUE (amt$working_storage_length)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
        operation, ' ', status);
        RETURN;
      IFEND;

       IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
         CASE tape_descriptor^.last_data_operation OF
         = amc$get_next_req, amc$get_partial_req =
           last_record_header_p := #ADDRESS(
             #RING( tape_descriptor^.get_tape_block_buffer),
             #SEGMENT(tape_descriptor^.get_tape_block_buffer),
             gfi^.positioning_info.record_info.record_header_fba);
           CASE last_record_header_p^.header_type OF
           = bac$full_segment, bac$end_segment =
             adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
               gfi^.positioning_info.record_info.residual_record_length, status);
             IF NOT status.normal THEN
               RETURN;
             IFEND;
           = bac$start_segment =
             last_record_header_p^.header_type := bac$full_segment;
             adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
               gfi^.positioning_info.record_info.residual_record_length, status);
             IF NOT status.normal THEN
               RETURN;
             IFEND;
           = bac$continued_segment =
             last_record_header_p^.header_type := bac$end_segment;
             adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
               gfi^.positioning_info.record_info.residual_record_length, status);
             IF NOT status.normal THEN
               RETURN;
             IFEND;
           ELSE
             amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
                     operation, 'Incorrect record header in US/S put_next_req', status);
             RETURN;
           CASEND;
           block_info^.block_position := bac$middle_of_block;

         = amc$put_partial_req =
           last_record_header_p := #ADDRESS(
             #RING( tape_descriptor^.put_tape_block_buffer),
             #SEGMENT(tape_descriptor^.put_tape_block_buffer),
             gfi^.positioning_info.record_info.record_header_fba);
           CASE last_record_header_p^.header_type OF
           = bac$start_segment =
             last_record_header_p^.header_type := bac$full_segment;
           = bac$continued_segment =
             last_record_header_p^.header_type := bac$end_segment;
           ELSE
           CASEND;
         ELSE
         CASEND;
       IFEND;

{   Check if last operation was read type that left tape logically at mid_block

       IF bai$partial_read_block_exists () THEN
         switch_from_read_to_write (file_identifier, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;
       IFEND;

        WHILE more_data DO
          IF (bai$partial_block_exists ()) AND
            (rhl <= block_info^.residual_block_length) THEN
            terminate_previous_block := FALSE;

            IF rhl + wsl <= block_info^.residual_block_length THEN
              put_size := wsl;
              end_of_data := TRUE;
{ ! Never attempt to flush the current block in case the next request needs    }
{   to examine the last record header.                                         }
              term_option := amc$continue;
              bai$put_ansi_scw_for_putn;
              IF (wsl = 0) OR (NOT status.normal) THEN
                EXIT /main_program/;
              IFEND;
{ ! Never attempt to flush the current block in case the next request needs    }
{   to examine the last record header.                                         }
              term_option := amc$continue;
              more_data := FALSE;

            ELSE { rhl + wsl > block_info^.residual_block_length
              IF rhl = block_info^.residual_block_length THEN
{ ! Don't put header only in block when wsl <> 0.                             }
                term_option := amc$terminate;
                put_size := 0;
              ELSE
                put_size := block_info^.residual_block_length - rhl;
{               end_of_data := FALSE;
                term_option := amc$continue;
                bai$put_ansi_scw_for_putn;
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
{ ! Never attempt to flush the current block in case the next request          }
{   hits EOT. (labelled tapes)                                                 }
                term_option := amc$continue;

              IFEND;
            IFEND;
          ELSE
            terminate_previous_block := TRUE;

            IF rhl + wsl <= max_data_size THEN
              put_size := wsl;
              end_of_data := TRUE;
              term_option := amc$start;
              bai$put_ansi_scw_for_putn;
              IF (wsl = 0) OR (NOT status.normal) THEN
                EXIT /main_program/;
              IFEND;
              terminate_previous_block := FALSE;
              term_option := amc$continue;
              more_data := FALSE;

            ELSE { rhl + wsl > max_data_size
              put_size := max_data_size - rhl;
{             end_of_data := FALSE;
              term_option := amc$start;
              bai$put_ansi_scw_for_putn;
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              terminate_previous_block := FALSE;
{ ! Never attempt to flush the current block in case the next request          }
{   hits EOT. (labelled tapes)                                                 }
              term_option := amc$continue;

            IFEND;
          IFEND;

          put_data (file_identifier, operation, wsa, put_size, term_option,
                terminate_previous_block, {convert_if_ebcdic =} TRUE, status);

          IF NOT status.normal THEN
            IF (status.condition = ame$end_of_tape_op_completed) THEN
              data_length := data_length + put_size;
            IFEND;
            EXIT /main_program/;
          IFEND;

          data_length := data_length + put_size;
          wsl := wsl - put_size;
          wsa := #address (#ring (wsa), #segment (wsa), (#offset (wsa) + put_size));
        WHILEND;

    END /main_program/;

    state_info^.put_op := TRUE;

{ The following check will set file_position to mid_record if an abnormal condition
{ occurred (such as unrecovered write error).  End of tape errors will never happen
{ for labelled or unlabelled operations.  If label type is non_standard, the file is
{ really at EOR if the error is ame$end_of_tape_op_completed and end_of_data = TRUE.

    IF NOT status.normal THEN
      IF (status.condition = ame$end_of_tape_op_completed) AND (end_of_data) THEN
        gfi^.positioning_info.record_info.file_position := amc$eor;
      ELSE
        gfi^.positioning_info.record_info.file_position := amc$mid_record;
      IFEND;
    ELSE
      gfi^.positioning_info.record_info.file_position := amc$eor;
    IFEND;

    IF last_record_header_p <> NIL THEN
      gfi^.positioning_info.record_info.record_header_fba := #OFFSET( last_record_header_p);
    IFEND;

    gfi^.positioning_info.record_info.transfer_count := data_length;
    gfi^.positioning_info.record_info.record_length := data_length;
    gfi^.positioning_info.record_info.residual_record_length := 0;

  PROCEND put_next_req;


?? TITLE := 'put_partial_req', EJECT ??

  PROCEDURE put_partial_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      append_to_current_header: boolean,
      data_length : 0 .. amc$maximum_block - 1,
      end_of_data : boolean,
      exit_after_header_update: boolean,
      last_record_header_p: ^bat$s_record_scw,
      max_data_size : 0 .. amc$maximum_block - 1,
      more_data : boolean,
      put_data_status: ost$status,
      put_size : 0 .. amc$maximum_block - 1,
      put_header: boolean,
      rh: bat$s_record_scw,
      start_of_data : boolean,
      term_option : amt$term_option,
      terminate_previous_block : boolean,
      wsa : ^cell,
      wsl : amt$working_storage_length;


*copy bai$put_ansi_scw_for_putp


  /main_program/
      BEGIN

        status.normal := TRUE;
        put_data_status.normal := TRUE;
        data_length := 0;
        end_of_data := FALSE;
        exit_after_header_update := FALSE;
        last_record_header_p := NIL;
        max_data_size := gfi^.max_data_size;
        more_data := TRUE;
        start_of_data := TRUE;
        wsa := call_block.putp.working_storage_area;
        wsl := call_block.putp.working_storage_length;


        IF (wsl < 0) OR (wsl > UPPERVALUE (amt$working_storage_length)) THEN
          amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
          operation, ' ', status);
          RETURN;
        IFEND;

        IF (call_block.putp.term_option < LOWERVALUE (amt$term_option)) OR
           (call_block.putp.term_option > UPPERVALUE (amt$term_option)) THEN
          amp$set_file_instance_abnormal (file_identifier,
            ame$improper_term_option, call_block.operation, ' ',
            status);
          RETURN;
        IFEND;

        CASE call_block.putp.term_option OF

        = amc$start =
          CASE tape_descriptor^.last_data_operation OF
          = amc$get_next_req, amc$get_partial_req =
            last_record_header_p := #ADDRESS(
              #RING( tape_descriptor^.get_tape_block_buffer),
              #SEGMENT(tape_descriptor^.get_tape_block_buffer),
              gfi^.positioning_info.record_info.record_header_fba);
            CASE last_record_header_p^.header_type OF
            = bac$full_segment, bac$end_segment =
              adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
                gfi^.positioning_info.record_info.residual_record_length, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              block_info^.block_position := bac$middle_of_block;
            = bac$start_segment =
              last_record_header_p^.header_type := bac$full_segment;
              adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
                gfi^.positioning_info.record_info.residual_record_length, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              block_info^.block_position := bac$middle_of_block;
            = bac$continued_segment =
              last_record_header_p^.header_type := bac$end_segment;
              adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
                gfi^.positioning_info.record_info.residual_record_length, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              block_info^.block_position := bac$middle_of_block;
            ELSE
            CASEND;
          = amc$put_next_req, amc$put_partial_req =
            last_record_header_p := #ADDRESS(
              #RING( tape_descriptor^.put_tape_block_buffer),
              #SEGMENT(tape_descriptor^.put_tape_block_buffer),
              gfi^.positioning_info.record_info.record_header_fba);
            CASE last_record_header_p^.header_type OF
{           = bac$full_segment, bac$end_segment =
            = bac$start_segment =
              last_record_header_p^.header_type := bac$full_segment;
            = bac$continued_segment =
              last_record_header_p^.header_type := bac$end_segment;
            ELSE
            CASEND;
          ELSE
          CASEND;

        = amc$continue =
          IF gfi^.positioning_info.record_info.file_position <> amc$mid_record THEN
            amp$set_file_instance_abnormal (file_identifier, ame$improper_continue,
              operation, ' ', status);
            RETURN;
          IFEND;
          CASE tape_descriptor^.last_data_operation OF
          = amc$get_next_req, amc$get_partial_req =
            last_record_header_p := #ADDRESS(
              #RING( tape_descriptor^.get_tape_block_buffer),
              #SEGMENT(tape_descriptor^.get_tape_block_buffer),
              gfi^.positioning_info.record_info.record_header_fba);
            CASE last_record_header_p^.header_type OF
            = bac$full_segment =
              last_record_header_p^.header_type := bac$start_segment;
              adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
                gfi^.positioning_info.record_info.residual_record_length, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            = bac$start_segment, bac$continued_segment =
              adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
                gfi^.positioning_info.record_info.residual_record_length, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            = bac$end_segment =
              last_record_header_p^.header_type := bac$continued_segment;
              adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
                gfi^.positioning_info.record_info.residual_record_length, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            ELSE
              amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
                      operation, 'Incorrect record header in US/S put_partial_req', status);
              RETURN;
            CASEND;
            block_info^.block_position := bac$middle_of_block;
{         = amc$put_next_req, amc$put_partial_req =
{           last_record_header_p := #ADDRESS(
{             #RING( tape_descriptor^.put_tape_block_buffer),
{             #SEGMENT(tape_descriptor^.put_tape_block_buffer),
{             gfi^.positioning_info.record_info.record_header_fba);
{           CASE last_record_header_p^.header_type OF
{           = bac$full_segment =
{           = bac$start_segment =
{           = bac$continued_segment =
{           = bac$end_segment =
{           ELSE
{           CASEND;
          ELSE
          CASEND;

        = amc$terminate =
          CASE tape_descriptor^.last_data_operation OF
          = amc$get_next_req, amc$get_partial_req =
            last_record_header_p := #ADDRESS(
              #RING( tape_descriptor^.get_tape_block_buffer),
              #SEGMENT(tape_descriptor^.get_tape_block_buffer),
              gfi^.positioning_info.record_info.record_header_fba);
            CASE last_record_header_p^.header_type OF
            = bac$full_segment =
              IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
                last_record_header_p^.header_type := bac$start_segment;
                adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
                  gfi^.positioning_info.record_info.residual_record_length, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                block_info^.block_position := bac$middle_of_block;
              IFEND;
            = bac$start_segment, bac$continued_segment =
              adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
                gfi^.positioning_info.record_info.residual_record_length, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              block_info^.block_position := bac$middle_of_block;
            = bac$end_segment =
              IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
                last_record_header_p^.header_type := bac$continued_segment;
                adjust_length_in_last_header (file_identifier, last_record_header_p, subtract,
                  gfi^.positioning_info.record_info.residual_record_length, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                block_info^.block_position := bac$middle_of_block;
              IFEND;
            ELSE
            CASEND;
{         = amc$put_next_req, amc$put_partial_req =
{           last_record_header_p := #ADDRESS(
{             #RING( tape_descriptor^.put_tape_block_buffer),
{             #SEGMENT(tape_descriptor^.put_tape_block_buffer),
{             gfi^.positioning_info.record_info.record_header_fba);
{           CASE last_record_header_p^.header_type OF
{           = bac$full_segment =
{           = bac$start_segment =
{           = bac$continued_segment =
{           = bac$end_segment =
{           ELSE
{           CASEND;
          ELSE
          CASEND;
        ELSE
        CASEND;

{   Check if last operation was read type that left tape logically at mid_block

        IF bai$partial_read_block_exists () THEN
          switch_from_read_to_write (file_identifier, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;


        last_record_header_p := #ADDRESS(
          #RING( tape_descriptor^.put_tape_block_buffer),
          #SEGMENT(tape_descriptor^.put_tape_block_buffer),
          gfi^.positioning_info.record_info.record_header_fba);


        CASE call_block.putp.term_option OF

        = amc$start =

          put_header := TRUE;

        = amc$continue =

          IF (wsl = 0) THEN
            EXIT /main_program/;
          ELSE
            put_header := FALSE;
          IFEND;

        = amc$terminate =

          IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN

            IF (wsl = 0) THEN

              CASE last_record_header_p^.header_type OF
              = bac$start_segment =
                last_record_header_p^.header_type := bac$full_segment;

              = bac$continued_segment =
                last_record_header_p^.header_type := bac$end_segment;

{             = bac$full_segment, amc$end_segment =
{ !             These headers should never be encountered.

              ELSE
                amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
                  operation, 'Incorrect record scw in US/S put_partial_request', status);
                RETURN;
              CASEND;
              EXIT /main_program/;   { (wsl = 0)

            ELSE { (wsl > 0)
              put_header := FALSE;
            IFEND;

          ELSE { gfi^.positioning_info.record_info.file_position <> amc$mid_record
            put_header := TRUE;
          IFEND;

        ELSE
        CASEND;


        WHILE more_data DO
          IF (bai$partial_block_exists ()) AND (block_info^.residual_block_length > 0) THEN
            terminate_previous_block := FALSE;

            IF put_header THEN
              append_to_current_header := FALSE;

              IF rhl + wsl <= block_info^.residual_block_length THEN
                put_size := wsl;
                end_of_data := TRUE;
{ ! Never attempt to flush the current block in case the next request needs    }
{   to alter the last record header.                                           }
                term_option := amc$continue;
                bai$put_ansi_scw_for_putp;
                IF (wsl = 0) OR (NOT status.normal) THEN
                  EXIT /main_program/;
                IFEND;
{ ! Never attempt to flush the current block in case the next request needs    }
{   to alter the last record header.                                           }
                term_option := amc$continue;
                more_data := FALSE;

              ELSE { rhl + wsl > block_info^.residual_block_length

                IF rhl >= block_info^.residual_block_length THEN
{ ! Don't put header only in block when wsl <> 0.                             }
                  term_option := amc$terminate;
                  put_size := 0;

                ELSE
                  put_size := block_info^.residual_block_length - rhl;
{                 end_of_data := FALSE;
                  term_option := amc$continue;
                  bai$put_ansi_scw_for_putp;
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;
{ ! Never attempt to flush the current block in case the next request          }
{   hits EOT. (labelled tapes)                                                 }
                  term_option := amc$continue;

                IFEND;
              IFEND;

            ELSE { put_header = FALSE
              append_to_current_header := TRUE;

              IF wsl <= block_info^.residual_block_length THEN
                put_size := wsl;
                end_of_data := TRUE;
{ ! Never attempt to flush the current block in case the next request needs    }
{   to alter the last record header.                                           }
                term_option := amc$continue;
                more_data := FALSE;

              ELSE { wsl > block_info^.residual_block_length
                put_size := block_info^.residual_block_length;
{               end_of_data := FALSE;
{ ! Never attempt to flush the current block in case the next request          }
{   hits EOT. (labelled tapes)                                                 }
                term_option := amc$continue;

              IFEND;
            IFEND;

          ELSE
            terminate_previous_block := TRUE;
            append_to_current_header := FALSE;

            IF rhl + wsl <= max_data_size THEN
              put_size := wsl;
              end_of_data := TRUE;
              term_option := amc$start;
              bai$put_ansi_scw_for_putp;
              IF (wsl = 0) OR (NOT status.normal) THEN
                EXIT /main_program/;
              IFEND;
              terminate_previous_block := FALSE;
              term_option := amc$continue;
              more_data := FALSE;

            ELSE { rhl + wsl > max_data_size
              put_size := max_data_size - rhl;
{             end_of_data := FALSE;
              term_option := amc$start;
              bai$put_ansi_scw_for_putp;
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              terminate_previous_block := FALSE;
{ ! Never attempt to flush the current block in case the next request          }
{   hits EOT. (labelled tapes)                                                 }
              term_option := amc$continue;

            IFEND;
          IFEND;

          put_data (file_identifier, operation, wsa, put_size, term_option,
                terminate_previous_block, {convert_if_ebcdic =} TRUE, put_data_status);

          IF NOT put_data_status.normal THEN
            IF (put_data_status.condition = ame$end_of_tape_op_completed) THEN
              exit_after_header_update := TRUE;
            ELSE
              EXIT /main_program/;
            IFEND;
          IFEND;

          IF append_to_current_header THEN
            adjust_length_in_last_header (file_identifier, last_record_header_p, add, put_size, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
          IFEND;

          IF call_block.putp.term_option = amc$terminate THEN
            IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
              IF NOT more_data THEN

                CASE last_record_header_p^.header_type OF

                = bac$start_segment =
                  last_record_header_p^.header_type := bac$full_segment;

                = bac$continued_segment =
                  last_record_header_p^.header_type := bac$end_segment;

                = bac$full_segment, bac$end_segment =
                  ;

                ELSE
                  amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction,
                    operation, 'Incorrect record scw in US/S put_partial_request', status);
                  EXIT /main_program/;
                CASEND;

              IFEND;
            IFEND;
          IFEND;

          data_length := data_length + put_size;

          IF exit_after_header_update THEN
            EXIT /main_program/;
          IFEND;

          wsl := wsl - put_size;
          wsa := #address (#ring (wsa), #segment (wsa), (#offset (wsa) + put_size));
        WHILEND;


      END /main_program/;

      state_info^.put_op := TRUE;

      IF call_block.putp.term_option = amc$start THEN
        gfi^.positioning_info.record_info.file_position := amc$mid_record;
        gfi^.positioning_info.record_info.record_length := data_length;
      ELSEIF call_block.putp.term_option = amc$continue THEN
        gfi^.positioning_info.record_info.file_position := amc$mid_record;
        gfi^.positioning_info.record_info.record_length :=
          gfi^.positioning_info.record_info.record_length + data_length;
      ELSE {amc$terminate}
        IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
          gfi^.positioning_info.record_info.record_length :=
            gfi^.positioning_info.record_info.record_length + data_length;
        ELSE
          gfi^.positioning_info.record_info.record_length := data_length;
        IFEND;
        gfi^.positioning_info.record_info.file_position := amc$eor;
      IFEND;

{ The following check will set file_position to mid_record if an abnormal condition
{ occurred (such as unrecovered write error).  End of tape errors will never happen
{ for labelled or unlabelled operations.  If label type is non_standard, the file
{ position is as computed above if the error is ame$end_of_tape_op_completed and
{ end_of_data = TRUE.

      IF NOT status.normal THEN
        gfi^.positioning_info.record_info.file_position := amc$mid_record;
      ELSEIF NOT put_data_status.normal THEN
        status := put_data_status;
        IF NOT ((status.condition = ame$end_of_tape_op_completed) AND (end_of_data)) THEN
          gfi^.positioning_info.record_info.file_position := amc$mid_record;
        IFEND;
      IFEND;

      IF last_record_header_p <> NIL THEN
        gfi^.positioning_info.record_info.record_header_fba := #OFFSET( last_record_header_p);
      IFEND;

      gfi^.positioning_info.record_info.transfer_count := data_length;
      gfi^.positioning_info.record_info.residual_record_length := 0;

  PROCEND put_partial_req;

?? TITLE := 'skip_req', EJECT ??

  PROCEDURE skip_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      block_number: 0 .. amc$max_block_number,
      direction: amt$skip_direction,
      error_action: bat$error_actions,
      file_position: amt$file_position,
      last_record_header_p: ^bat$s_record_scw,
      manually_advance_to_next_block: boolean,
      next_record_header_p: ^bat$s_record_scw,
      no_header_read: boolean,
      records_remaining: amt$skip_count,
      request_status: ost$status,
      residual_data_length: 0 .. amc$maximum_block -1,
      residual_skip_count: amt$skip_count,
      rh: bat$s_record_scw,
      skip_zero_completed: boolean,
      tape_failure_modes: amt$tape_failure_modes,
      units_to_skip: amt$skip_count,
      volume_position: amt$volume_position;


*copy bai$skip_to_next_ansi_scw


  /main_program/
    BEGIN

      status.normal := TRUE;
      block_number := block_info^.block_number;
      direction := call_block.skp.direction;
      units_to_skip := call_block.skp.count;
      volume_position := tape_descriptor^.volume_position;

{
{ Check file position to see if any partial blocks need to be written out.
{

      IF bai$partial_block_exists () THEN
        process_previous_block (file_identifier, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;


      CASE call_block.skp.unit OF

?? NEWTITLE := '    skip record', EJECT ??

      = amc$skip_record =

        last_record_header_p := NIL;
        no_header_read := FALSE;
        residual_data_length := gfi^.positioning_info.record_info.residual_record_length;
        residual_skip_count := units_to_skip;

        CASE tape_descriptor^.last_data_operation OF
        = amc$get_next_req, amc$get_partial_req =
          last_record_header_p := #ADDRESS(
            #RING( tape_descriptor^.get_tape_block_buffer),
            #SEGMENT(tape_descriptor^.get_tape_block_buffer),
            gfi^.positioning_info.record_info.record_header_fba);

        ELSE
        CASEND;

        CASE direction OF
        = amc$forward =

/skip_record_forward/
  BEGIN
          skip_zero_completed := FALSE;
          IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
            REPEAT
              IF residual_data_length = 0 THEN
                bai$skip_to_next_ansi_scw;
                IF (no_header_read) OR (NOT status.normal) THEN
                  EXIT /skip_record_forward/;
                IFEND;
              IFEND;
              block_info^.current_block_byte_address :=
                block_info^.current_block_byte_address + residual_data_length;
              block_info^.residual_block_length :=
                block_info^.residual_block_length - residual_data_length;
              residual_data_length := 0;
            UNTIL (last_record_header_p^.header_type = bac$full_segment) OR
                  (last_record_header_p^.header_type = bac$end_segment);
            gfi^.positioning_info.record_info.file_position := amc$eor;
          IFEND;
          skip_zero_completed := TRUE;

          IF units_to_skip = 0 THEN
            call_block.skp.file_position^ := gfi^.positioning_info.record_info.file_position;
            file_instance^.residual_skip_count := residual_skip_count;
            gfi^.positioning_info.record_info.record_length := 0;
            gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
            gfi^.positioning_info.record_info.transfer_count := 0;
            RETURN;
          IFEND;


          WHILE residual_skip_count > 0 DO
            REPEAT
              bai$skip_to_next_ansi_scw;
              IF (no_header_read) OR (NOT status.normal) THEN
                EXIT /skip_record_forward/;
              IFEND;
              block_info^.current_block_byte_address :=
                block_info^.current_block_byte_address + residual_data_length;
              block_info^.residual_block_length :=
                block_info^.residual_block_length - residual_data_length;
              residual_data_length := 0;
            UNTIL (last_record_header_p^.header_type = bac$full_segment) OR
                  (last_record_header_p^.header_type = bac$end_segment);
            residual_skip_count := residual_skip_count - 1;
          WHILEND;
          gfi^.positioning_info.record_info.file_position := amc$eor;

          call_block.skp.file_position^ := gfi^.positioning_info.record_info.file_position;
          file_instance^.residual_skip_count := residual_skip_count;
          gfi^.positioning_info.record_info.record_length := 0;
          gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
          gfi^.positioning_info.record_info.transfer_count := 0;
          RETURN;

END /skip_record_forward/;

{ If this point is reached, an error condition (such as unrecovered read error or
{ tapemark encountered) has occurred.

          IF NOT status.normal THEN
            ;
          ELSEIF (units_to_skip = 0) OR (residual_skip_count > 0) THEN
            IF (tape_descriptor^.volume_position = amc$eov) OR
               (tape_descriptor^.volume_position = amc$after_tapemark) THEN
              IF bai$label_type () = amc$unlabelled THEN
{ ! This should never happen. In case it does, set file_position to eoi and
{   set status abnormal.
                gfi^.positioning_info.record_info.file_position := amc$eoi;
              ELSEIF bai$label_type () = amc$labelled THEN
                gfi^.positioning_info.record_info.file_position := amc$eoi;
              ELSE { amc$non_standard_labelled
                IF skip_zero_completed THEN
                  gfi^.positioning_info.record_info.file_position := amc$eor;
                ELSE
                  gfi^.positioning_info.record_info.file_position := amc$mid_record;
                IFEND;
              IFEND;
              amp$set_file_instance_abnormal (file_identifier,
                ame$skip_encountered_eoi, operation, 'RECORDS', status);
            IFEND;
          IFEND;

          call_block.skp.file_position^ := gfi^.positioning_info.record_info.file_position;
          file_instance^.residual_skip_count := residual_skip_count;
          gfi^.positioning_info.record_info.record_length := 0;
          gfi^.positioning_info.record_info.residual_record_length := residual_data_length;
          gfi^.positioning_info.record_info.transfer_count := 0;
          RETURN;

        ELSE

        CASEND;


?? TITLE := '    skip tape marks', EJECT ??

      = amc$skip_tape_mark =

        IF units_to_skip = 0 THEN {no-op.}
          file_instance^.residual_skip_count := 0;
          call_block.skp.file_position^ := gfi^.positioning_info.record_info.file_position;
          RETURN;
        IFEND;

        residual_skip_count := units_to_skip;
        file_position := gfi^.positioning_info.record_info.file_position;

/skip_tapemark_main/
BEGIN

        IF direction = amc$forward THEN

        /whileloop/
          WHILE residual_skip_count > 0 DO

            REPEAT
              bap$tape_bm_skip_tapemark (file_identifier, direction, tape_failure_modes, request_status);
              bai$process_request_status (file_identifier, operation, request_status,
                    tape_failure_modes, error_action, status);
              IF NOT status.normal AND (status.condition = ame$input_after_output) THEN
                file_position := amc$eoi;
                volume_position := amc$eov;
                amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi, operation,
                        'TAPEMARKS', status);
                EXIT /skip_tapemark_main/;
              IFEND;
              IF error_action = bac$exit_procedure THEN
                EXIT /skip_tapemark_main/;
              IFEND;
            UNTIL error_action <> bac$retry_last_request;

            IF bai$label_type () = amc$unlabelled THEN
              bai$check_tapemark (file_identifier, volume_position, request_status);
              bai$process_request_status (file_identifier, operation, request_status,
                    tape_failure_modes, error_action, status);
              IF NOT status.normal OR (error_action = bac$exit_procedure) THEN
                EXIT /skip_tapemark_main/;
              IFEND;
              CASE volume_position OF
              = amc$after_tapemark =
                residual_skip_count := residual_skip_count - 1;
              = amc$eov =
                bai$advance_volume (file_identifier, volume_position, status);
                IF NOT status.normal THEN
                  EXIT /skip_tapemark_main/;
                IFEND;
                IF volume_position = amc$eov THEN
                  EXIT /whileloop/;
                IFEND;
              ELSE
                ;
              CASEND;
            ELSE { label_type <> amc$unlabelled     }

{
{ Since skipping by tapemarks is illegal on labelled tapes, this call must be for non_standard labels.
{
{ Consecutive tapemarks indicate a null file, not end of volume, and each tapemark needs to be skipped.
{

              residual_skip_count := residual_skip_count - 1;

            IFEND;

          WHILEND /whileloop/;

          IF residual_skip_count > 0 THEN
            amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi, operation,
              'TAPEMARKS', status);
          IFEND;
          IF status.normal THEN
            file_position := amc$boi;
            volume_position := amc$after_tapemark;
          ELSE
            file_position := amc$eoi;
            volume_position := amc$eov;
          IFEND;

        ELSE { direction = amc$backward }

          /backloop/
            WHILE residual_skip_count > 0 DO

              REPEAT
                bap$tape_bm_skip_tapemark (file_identifier, direction, tape_failure_modes, request_status);
                bai$process_request_status (file_identifier, operation, request_status,
                      tape_failure_modes, error_action, status);
                IF error_action = bac$exit_procedure THEN
                  EXIT /skip_tapemark_main/;
                IFEND;
                IF NOT status.normal AND (status.condition = ame$skip_encountered_bov) THEN
                  EXIT /backloop/;
                IFEND;
                IF status.normal THEN
                  residual_skip_count := residual_skip_count - 1;
                IFEND;
              UNTIL error_action <> bac$retry_last_request;

            WHILEND /backloop/;

            IF residual_skip_count > 0 THEN
              amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_bov, operation,
                'TAPEMARKS', status);
            IFEND;
            IF status.normal THEN
              file_position := amc$eoi;
              volume_position := amc$before_tapemark;
            ELSE
              file_position := amc$boi;
              volume_position := amc$bov;
            IFEND;
        IFEND;

        block_number := 1;

END /skip_tapemark_main/;

        call_block.skp.file_position^ := file_position;
        gfi^.positioning_info.record_info.file_position := file_position;
        file_instance^.residual_skip_count := residual_skip_count;
        tape_descriptor^.volume_position := volume_position;
        block_info^.block_number := block_number;
        block_info^.block_position := bac$beginning_of_block;
        block_info^.current_block_byte_address := 0;
        block_info^.current_block_length := 0;
        block_info^.residual_block_length := 0;
        gfi^.positioning_info.record_info.residual_record_length := 0;
        gfi^.positioning_info.record_info.record_length := 0;
        tape_descriptor^.put_tape_block_buffer := NIL;
        tape_descriptor^.get_tape_block_buffer := NIL;



?? OLDTITLE ??
      ELSE
      CASEND;

    END /main_program/;


  PROCEND skip_req;


*copy bai$lrt_common_procedures

MODEND bam$lrt_us_ansi_s_tape_fap;
*DECK DECK=BAM$LRT_US_FIXED_TAPE_FAP EXPAND=TRUE
MODULE bam$lrt_us_fixed_tape_fap;
?? LEFT := 1, RIGHT := 110 ??
? VAR user_fap: boolean := FALSE?;
? VAR pad_records: boolean := TRUE?;
?? PUSH (LIST := OFF) ??

























?? POP ??
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
?? TITLE := 'Type definitions' ??
*copyc amt$tape_error_options
*copyc amt$file_identifier
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc bat$put_label_request
*copyc bat$record_header_type
*copyc ost$caller_identifier
*copyc bak$bap_procedure_keypoints
?? TITLE := 'Error code definitions', EJECT ??
*copyc ame$improper_file_id
*copyc ame$improper_wsl
*copyc ame$get_program_actions
*copyc ame$get_validation_errors
*copyc ame$put_program_actions
*copyc ame$put_validation_errors
*copyc ame$skip_program_actions
*copyc ame$skip_validation_errors
*copyc bae$tape_bm_error_codes
*copyc dme$tape_errors
?? OLDTITLE ??
?? EJECT ??
?? POP ??
{ The following POP pragmat is here to negate an extra push (listext :=on) in one of the bam decks. }
?? POP ??
?? TITLE := 'XREF variable and procedure definitions' ??
*copyc osv$task_private_heap
*copyc amp$set_file_instance_abnormal
*copyc bap$close
*copyc bap$tape_bm_align_position
*copyc bap$tape_bm_flush
*copyc bap$tape_bm_open
*copyc bap$tape_bm_read_label
*copyc bap$tape_bm_read_next_block
*copyc bap$tape_bm_read_to_write
*copyc bap$tape_bm_close
*copyc bap$tape_bm_write_next_block
*copyc bap$tape_bm_reserve_blk_buffer
*copyc bap$tape_bm_skip_blocks
*copyc bap$tape_bm_skip_tapemark
*copyc bap$tape_bm_rewind
*copyc bap$tape_bm_advance_volume
*copyc bap$tape_bm_erase_block
*copyc bap$tape_bm_tapemark_check
*copyc bap$tape_bm_write_tape_mark
*copyc bap$tape_bm_write_label
*copyc bap$tape_bm_write_label_mark
*copyc bap$fap_control
*copyc osp$set_status_abnormal
?? TITLE := 'INLINE function definitions' ??
?? NEWTITLE := ' ' ??
?? TITLE := 'bai$state_info', EJECT ??
*copyc bai$state_info
?? TITLE := 'bai$tape_descriptor', EJECT ??
*copyc bai$tape_descriptor
?? TITLE := 'bai$block_info', EJECT ??
*copyc bai$block_info
?? TITLE := 'bai$dynamic_label', EJECT ??
*copyc bai$dynamic_label
?? TITLE := 'bai$gfi', EJECT ??
*copyc bai$gfi
?? TITLE := 'bai$label_type', EJECT ??
*copyc bai$label_type
?? TITLE := 'bai$partial_block_exists', EJECT ??
*copyc bai$partial_block_exists
?? TITLE := 'bai$partial_read_block_exists', EJECT ??
*copyc bai$partial_read_block_exists
?? TITLE := 'bai$partial_record_exists', EJECT ??
*copyc bai$partial_record_exists
?? TITLE := 'bai$static_label', EJECT ??
*copyc bai$static_label
?? OLDTITLE ??
?? TITLE := 'INLINE procedure definitions' ??
?? NEWTITLE := ' ' ??
?? TITLE := 'osp$disestablish_cond_handler', EJECT ??
*copyc osp$disestablish_cond_handler
?? TITLE := 'osp$establish_block_exit_hndlr', EJECT ??
*copyc osp$establish_block_exit_hndlr
?? TITLE := 'bai$advance_volume', EJECT ??
*copyc bai$advance_volume
?? TITLE := 'bai$append_tape_error', EJECT ??
*copyc bai$append_tape_error
?? TITLE := 'bai$check_caller_id', EJECT ??
*copyc bai$check_caller_id
?? TITLE := 'bai$check_record_level_access', EJECT ??
*copyc bai$check_record_level_access
?? TITLE := 'bai$check_tapemark', EJECT ??
*copyc bai$check_tapemark
?? TITLE := 'bai$clear_fail_at_current_pos', EJECT ??
*copyc bai$clear_fail_at_current_pos
?? TITLE := 'bai$fetch_tape_error_options', EJECT ??
*copyc bai$fetch_tape_error_options
?? TITLE := 'bai$forced_write', EJECT ??
*copyc bai$forced_write
?? TITLE := 'bai$init_boi_tape_position', EJECT ??
*copyc bai$init_boi_tape_position
?? TITLE := 'bai$process_block_information', EJECT ??
*copyc bai$process_block_information
?? TITLE := 'bai$process_request_status', EJECT ??
*copyc bai$process_request_status
?? TITLE := 'bai$validate_tape_access', EJECT ??
*copyc bai$validate_tape_access
?? TITLE := 'bai$write_previous_block', EJECT ??
*copyc bai$write_previous_block
?? TITLE := 'bap$validate_fap_identifier', EJECT ??
*copyc bap$validate_fap_identifier
?? TITLE := 'bap$validate_file_identifier', EJECT ??
*copyc bap$validate_file_identifier
?? TITLE := 'i#move', EJECT ??
*copyc i#move
?? OLDTITLE ??
?? TITLE := 'global variables for this call of the fap', EJECT ??
*copyc bav$global_tape_fap_variables

  CONST
    pad_blocks = TRUE,
    record_headers_exist = FALSE;

?? TITLE := 'bap#lrt_us_fixed_tape_fap', EJECT ??

? IF user_fap THEN
  VAR
    ttv$layer_number: [XDCL] amt$fap_layer_number := 0;

  PROCEDURE [XDCL, #GATE] bap#lrt_us_fixed_tape_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    ttv$layer_number := layer_number;
    bap$lrt_us_fixed_tape_fap (file_identifier, call_block, layer_number, status);

  PROCEND bap#lrt_us_fixed_tape_fap;
? IFEND

?? TITLE := 'bap$lrt_us_fixed_tape_fap', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$lrt_us_fixed_tape_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      dynamic_label: ^bat$dynamic_label_attributes,
      i: integer,
      local_status: ost$status,
      static_label: ^bat$instance_static_attributes,
      validation_ok: boolean;

    #caller_id (caller_id);
    operation := call_block.operation;
    #keypoint (osk$entry, osk$m * ((file_identifier.ordinal * 256) + operation),
          bak$us_blk_fixed_rec_tape_fap);
    status.normal := TRUE;
    global_layer_number := layer_number;
    close_file_on_exit := FALSE;

  /main_program/
    BEGIN

? IF user_fap THEN
      bap$validate_fap_identifier (file_identifier, file_instance, validation_ok);
? ELSE
      bap$validate_file_identifier (file_identifier, file_instance, validation_ok);
? IFEND
      IF NOT validation_ok THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
              'bap$lrt_us_fixed_tape_fap', status);
        EXIT /main_program/;
      IFEND;

      block_info := bai$block_info (file_instance);
      gfi := bai$gfi (file_instance);
      tape_descriptor := bai$tape_descriptor (file_instance);
      static_label := bai$static_label (file_instance);
      state_info := bai$state_info (file_instance);
      bai$check_caller_id (file_identifier, static_label^.ring_attributes, operation, caller_id,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      bai$check_record_level_access (file_identifier, file_instance^.access_level, operation,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      dynamic_label := bai$dynamic_label (file_instance);
      bai$validate_tape_access (file_identifier, dynamic_label^.access_mode, operation, tape_descriptor,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      bai$clear_fail_at_current_pos (operation, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;


      tape_descriptor^.error_options := dynamic_label^.error_options;

      CASE operation OF

      = amc$close_req =
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: US/F FAP called on CLOSE');
        IF bai$partial_record_exists () THEN
          pad_record;
        IFEND;
        close_req (file_identifier, status);
        bap$close (file_identifier, local_status);
        IF status.normal THEN
          status := local_status;
        IFEND;
      = amc$close_volume_req =
        IF bai$partial_record_exists () THEN
          pad_record;
        IFEND;
        close_volume_req (file_identifier, status);
        file_instance^.previous_get_at_eoi := FALSE;
      = amc$erase_tape_block =
        IF bai$partial_record_exists () THEN
          pad_record;
        IFEND;
        erase_tape_block_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$fetch_req =
        bap$fap_control (file_identifier, call_block, layer_number, status);
      = amc$flush_req =
        flush_req (file_identifier, status);
      = amc$get_next_req =
        get_next_req (file_identifier, call_block, status);
        IF status.normal AND (call_block.getn.file_position^ <> amc$eoi) THEN
          tape_descriptor^.at_eoi := FALSE;
        IFEND;
      = amc$get_partial_req =
        get_partial_req (file_identifier, call_block, status);
        IF status.normal AND (call_block.getp.file_position^ <> amc$eoi) THEN
          tape_descriptor^.at_eoi := FALSE;
        IFEND;
      = amc$open_req =
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: US/F FAP called on OPEN');
        tape_descriptor^.file_label_type := static_label^.file_label_type;
        open_req (file_identifier, call_block, layer_number, dynamic_label, status);
      = amc$put_next_req =
        IF (bai$label_type () = amc$labelled) THEN
          IF NOT state_info^.ve_wrote_ansi_file THEN
            amp$set_file_instance_abnormal (file_identifier, ame$rewrite_labels_conflict,
                  call_block.operation, ' ', status);
            RETURN;
          IFEND;
          IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
            sl_reposition_for_put_at_eoi (file_identifier, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
        put_next_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$put_partial_req =
        IF (bai$label_type () = amc$labelled) THEN
          IF NOT state_info^.ve_wrote_ansi_file THEN
            amp$set_file_instance_abnormal (file_identifier, ame$rewrite_labels_conflict,
                  call_block.operation, ' ', status);
            RETURN;
          IFEND;
          IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
            sl_reposition_for_put_at_eoi (file_identifier, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
        put_partial_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$rewind_req =
        IF bai$partial_record_exists () THEN
          pad_record;
        IFEND;
        rewind_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := FALSE;
      = amc$skip_req =
        validate_skip_parameters (file_identifier, call_block, FALSE, FALSE, TRUE, FALSE, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        skip_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
      = amc$write_tape_mark_req =
        IF bai$label_type () = amc$labelled THEN
          amp$set_file_instance_abnormal (file_identifier, ame$improper_labelled_tape_op,
                call_block.operation, 'WRITE OF TAPE MARK', status);
          EXIT /main_program/;
        IFEND;

{   Check if last operation was read type that left tape logically at mid_block

        IF bai$partial_read_block_exists () THEN
          switch_from_read_to_write (file_identifier, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;

        IF bai$partial_record_exists () THEN
          pad_record;
        IFEND;
        write_tape_mark_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      ELSE

        bap$fap_control (file_identifier, call_block, layer_number, status);

      CASEND;

    END /main_program/;

    IF (operation >= amc$last_access_start) AND (operation <= amc$max_operation)
          AND (operation <> amc$fetch_req) AND
          (operation <> amc$fetch_access_information_rq) THEN
      gfi^.last_access_operation := operation;
    IFEND;
    IF status.normal THEN
      gfi^.error_status := 0;
    ELSE
      gfi^.error_status := status.condition;
    IFEND;

{
{   IF the operator terminates a tape assignment that was initiated via bai$advance_volume,
{   the file will be closed at this point.  It cannot be closed in bai$advance_volume since
{   the global_file_inforamtion may be referenced after the call.
{

    IF close_file_on_exit THEN
      bap$close (file_identifier, local_status);
    IFEND;

    #keypoint (osk$exit, 0, bak$us_blk_fixed_rec_tape_fap);

  PROCEND bap$lrt_us_fixed_tape_fap;
?? TITLE := 'get_next_req', EJECT ??

{
{ The purpose of this request is to cause the transfer of data from tape to a
{ tape buffer, transfer data from the tape buffer to the users working
{ storage area, and to update all file descriptor fields.
{

  PROCEDURE get_next_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      allow_direct_io_transfer : boolean,
      start_new_block : boolean,
      wsl : amt$working_storage_length;

{
{ Check file position to see if any partial blocks need to be written out.
{

    IF bai$partial_record_exists () THEN
      pad_record;
    IFEND;

    IF bai$partial_block_exists () THEN
      bai$write_previous_block (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    wsl := call_block.getn.working_storage_length;
    allow_direct_io_transfer := FALSE;

    IF (wsl <= 0) OR (wsl > UPPERVALUE (amt$working_storage_length)) THEN
      amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value, operation,
            ' ', status);
      RETURN;
    IFEND;

    IF (gfi^.positioning_info.record_info.file_position = amc$mid_record) AND (block_info^.
          residual_block_length >= gfi^.positioning_info.record_info.residual_record_length) THEN
      block_info^.current_block_byte_address := block_info^.current_block_byte_address +
            gfi^.positioning_info.record_info.residual_record_length;
      block_info^.residual_block_length := block_info^.residual_block_length -
            gfi^.positioning_info.record_info.residual_record_length;
    IFEND;

    gfi^.positioning_info.record_info.residual_record_length := gfi^.max_record_length;
    gfi^.positioning_info.record_info.record_length := 0;
    gfi^.positioning_info.record_info.transfer_count := 0;

    IF (block_info^.current_block_byte_address = 0) OR (block_info^.residual_block_length <
          gfi^.max_record_length) THEN
      start_new_block := TRUE;
    ELSE
      start_new_block := FALSE;
    IFEND;

    IF wsl > gfi^.max_record_length THEN
      wsl := gfi^.max_record_length;
    IFEND;

    IF (gfi^.max_record_length = gfi^.max_data_size) AND (wsl = gfi^.max_record_length) THEN
      allow_direct_io_transfer := TRUE;
    IFEND;

  /read_loop/
    WHILE TRUE DO
      get_data (file_identifier, operation, call_block.getn.working_storage_area, wsl,
            allow_direct_io_transfer, start_new_block, {convert_if_ebcdid =} TRUE, status);
      IF NOT start_new_block THEN
        EXIT /read_loop/;
      ELSE
        IF (block_info^.current_block_length >= gfi^.max_record_length) OR
              (block_info^.current_block_length = 0) OR NOT status.normal THEN
          EXIT /read_loop/;
        IFEND;
      IFEND;
    WHILEND /read_loop/;

    IF gfi^.positioning_info.record_info.transfer_count = gfi^.max_record_length THEN
      gfi^.positioning_info.record_info.file_position := amc$eor;
      gfi^.positioning_info.record_info.residual_record_length := 0;
      gfi^.positioning_info.record_info.record_length := gfi^.positioning_info.record_info.transfer_count;
    ELSEIF (tape_descriptor^.volume_position = amc$eov) OR
    {} (tape_descriptor^.volume_position = amc$after_tapemark) THEN
      gfi^.positioning_info.record_info.file_position := amc$eoi;
      file_instance^.previous_get_at_eoi := TRUE;
      tape_descriptor^.at_eoi := TRUE;
    ELSE
      gfi^.positioning_info.record_info.file_position := amc$mid_record;
      gfi^.positioning_info.record_info.residual_record_length := gfi^.max_record_length -
            gfi^.positioning_info.record_info.transfer_count;
      gfi^.positioning_info.record_info.record_length := gfi^.positioning_info.record_info.transfer_count;
    IFEND;

    call_block.getn.file_position^ := gfi^.positioning_info.record_info.file_position;
    call_block.getn.transfer_count^ := gfi^.positioning_info.record_info.transfer_count;

  PROCEND get_next_req;

?? TITLE := 'get_partial_req', EJECT ??

{
{ The purpose of this request is to cause a partial transfer of data from tape to a
{ tape buffer, transfer data from the tape buffer to the users working
{ storage area, and to update all file descriptor fields.
{

  PROCEDURE get_partial_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    CONST
      allow_direct_io_transfer = FALSE;

    VAR
      start_new_block : boolean,
      wsl : amt$working_storage_length;

{
{ Check file position to see if any partial blocks need to be written out.
{

    IF bai$partial_record_exists () THEN
      pad_record;
    IFEND;

    IF bai$partial_block_exists () THEN
      bai$write_previous_block (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    wsl := call_block.getp.working_storage_length;

    IF (wsl <= 0) OR (wsl > UPPERVALUE (amt$working_storage_length)) THEN
      amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value, operation,
            ' ', status);
      RETURN;
    IFEND;

    IF (call_block.getp.skip_option < LOWERVALUE (amt$skip_option)) OR
          (call_block.getp.skip_option > UPPERVALUE (amt$skip_option)) THEN
      amp$set_file_instance_abnormal (file_identifier, ame$improper_skip_option,
            operation, ' ', status);
      RETURN;
    IFEND;

    IF (gfi^.positioning_info.record_info.file_position = amc$mid_record) AND
          (call_block.getp.skip_option = amc$skip_to_eor) THEN
      IF block_info^.residual_block_length >= gfi^.positioning_info.record_info.residual_record_length THEN
        block_info^.current_block_byte_address := block_info^.current_block_byte_address +
              gfi^.positioning_info.record_info.residual_record_length;
        block_info^.residual_block_length := block_info^.residual_block_length -
              gfi^.positioning_info.record_info.residual_record_length;
      IFEND;
      gfi^.positioning_info.record_info.file_position := amc$eor;
    IFEND;

    start_new_block := FALSE;
    gfi^.positioning_info.record_info.transfer_count := 0;

    CASE gfi^.positioning_info.record_info.file_position OF

    = amc$mid_record =

      IF wsl > gfi^.positioning_info.record_info.residual_record_length THEN
        wsl := gfi^.positioning_info.record_info.residual_record_length;
      IFEND;

    = amc$boi, amc$eor, amc$eoi =

      IF block_info^.residual_block_length < gfi^.max_record_length THEN
        start_new_block := TRUE;
      IFEND;

      IF wsl > gfi^.max_record_length THEN
        wsl := gfi^.max_record_length;
      IFEND;
{ Initialize_new_record }
      gfi^.positioning_info.record_info.record_length := 0;
      gfi^.positioning_info.record_info.residual_record_length := gfi^.max_record_length;
    ELSE
      amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction, operation,
            'Unknown file_position in get_partial (US, F)', status);
      RETURN;
    CASEND;

  /read_loop/
    WHILE TRUE DO
      get_data (file_identifier, operation, call_block.getp.working_storage_area, wsl,
            allow_direct_io_transfer, start_new_block, {convert_if_ebcdid =} TRUE, status);
      IF NOT start_new_block THEN
        EXIT /read_loop/;
      ELSE
        IF (block_info^.current_block_length >= gfi^.max_record_length) OR
              (block_info^.current_block_length = 0) OR NOT status.normal THEN
          EXIT /read_loop/;
        IFEND;
      IFEND;
    WHILEND /read_loop/;

    gfi^.positioning_info.record_info.record_length := gfi^.positioning_info.record_info.record_length +
          gfi^.positioning_info.record_info.transfer_count;

    IF gfi^.positioning_info.record_info.record_length = gfi^.max_record_length THEN
      gfi^.positioning_info.record_info.file_position := amc$eor;
      gfi^.positioning_info.record_info.residual_record_length := 0;
    ELSEIF (tape_descriptor^.volume_position = amc$eov) OR
    {} (tape_descriptor^.volume_position = amc$after_tapemark) THEN
      gfi^.positioning_info.record_info.file_position := amc$eoi;
      file_instance^.previous_get_at_eoi := TRUE;
      tape_descriptor^.at_eoi := TRUE;
    ELSE
      gfi^.positioning_info.record_info.file_position := amc$mid_record;
      gfi^.positioning_info.record_info.residual_record_length := gfi^.max_record_length -
            gfi^.positioning_info.record_info.record_length;
    IFEND;
    call_block.getp.record_length^ := gfi^.positioning_info.record_info.record_length;
    call_block.getp.file_position^ := gfi^.positioning_info.record_info.file_position;
    call_block.getp.transfer_count^ := gfi^.positioning_info.record_info.transfer_count;

  PROCEND get_partial_req;
?? TITLE := 'pad_record', EJECT ??

  PROCEDURE pad_record;

    VAR
      i : integer,
      padding_area : ^cell,
      padding_length : 0 .. amc$maximum_block - 1,
      working_storage_area : ^char,
      wsa : ^cell;

    IF gfi^.positioning_info.record_info.residual_record_length > 0 THEN
      i := 1;
      wsa := ^tape_descriptor^.put_tape_block_buffer^ [block_info^.
            current_block_byte_address + 1];
      working_storage_area := wsa;
      working_storage_area^ := state_info^.translated_record_padding_char;
      block_info^.current_block_byte_address := block_info^.current_block_byte_address +
            gfi^.positioning_info.record_info.residual_record_length;
      gfi^.positioning_info.record_info.record_length := gfi^.positioning_info.record_info.record_length +
            gfi^.positioning_info.record_info.residual_record_length;
      gfi^.positioning_info.record_info.transfer_count := gfi^.positioning_info.record_info.transfer_count +
            gfi^.positioning_info.record_info.residual_record_length;
      block_info^.current_block_length := block_info^.current_block_length +
            gfi^.positioning_info.record_info.residual_record_length;
      gfi^.positioning_info.record_info.residual_record_length :=
            gfi^.positioning_info.record_info.residual_record_length - 1;

      WHILE gfi^.positioning_info.record_info.residual_record_length > 0 DO
        padding_area := #address (#ring (wsa), #segment (wsa), (#offset (wsa) + i));
        IF i <= gfi^.positioning_info.record_info.residual_record_length THEN
          padding_length := i;
        ELSE
          padding_length := gfi^.positioning_info.record_info.residual_record_length;
        IFEND;
        i#move (wsa, padding_area, padding_length);
        gfi^.positioning_info.record_info.residual_record_length :=
              gfi^.positioning_info.record_info.residual_record_length - padding_length;
        i := i + padding_length;
      WHILEND;

      gfi^.positioning_info.record_info.file_position := amc$eor;
      block_info^.residual_block_length := gfi^.max_data_size -
            block_info^.current_block_byte_address;

    IFEND;

  PROCEND pad_record;
?? TITLE := 'put_next_req', EJECT ??

{
{ The purpose of this request is to transfer data from the users
{ working storage area to a tape file, either directly, or through
{ a tape buffer, and to update all file descriptor fields.
{

  PROCEDURE put_next_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      term_option : amt$term_option,
      terminate_previous_block : boolean,
      wsa : ^cell,
      wsl : amt$working_storage_length;


{   Check if last operation was read type that left tape logically at mid_block

    IF bai$partial_read_block_exists () THEN
      switch_from_read_to_write (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF bai$partial_record_exists () THEN
      pad_record;
    IFEND;

    wsa := call_block.putn.working_storage_area;

    IF call_block.putn.working_storage_length <= gfi^.max_record_length THEN
      wsl := call_block.putn.working_storage_length;
    ELSE
      wsl := gfi^.max_record_length;
    IFEND;

    gfi^.positioning_info.record_info.record_length := 0;
    gfi^.positioning_info.record_info.transfer_count := 0;

    IF block_info^.current_block_byte_address = 0 THEN
      term_option := amc$start;
      terminate_previous_block := TRUE;
    ELSEIF block_info^.residual_block_length < gfi^.max_record_length THEN
      term_option := amc$start;
      terminate_previous_block := TRUE;
    ELSE  {record fits into current block}
      term_option := amc$continue;
      terminate_previous_block := FALSE;
    IFEND;

    IF (term_option = amc$start) AND (gfi^.max_record_length = gfi^.max_data_size) AND
          (wsl = gfi^.max_record_length) THEN
      term_option := amc$terminate;
    IFEND;

    state_info^.put_op := TRUE;

    put_data (file_identifier, operation, wsa, wsl, term_option, terminate_previous_block,
          {convert_if_ebcdid =} TRUE, status);
    IF NOT status.normal AND (status.condition <> ame$end_of_tape_op_completed) THEN
      RETURN;
    IFEND;

    IF (wsl = 0) AND terminate_previous_block THEN
      terminate_previous_block := FALSE;
      put_data (file_identifier, operation, wsa, wsl, term_option, terminate_previous_block,
            {convert_if_ebcdid =} TRUE, status);
      IF NOT status.normal AND (status.condition <> ame$end_of_tape_op_completed) THEN
        RETURN;
      IFEND;
    IFEND;

    gfi^.positioning_info.record_info.residual_record_length := gfi^.max_record_length - wsl;
    gfi^.positioning_info.record_info.transfer_count := wsl;
    gfi^.positioning_info.record_info.record_length := wsl;

    IF gfi^.positioning_info.record_info.residual_record_length > 0 THEN
      pad_record;
    IFEND;

    gfi^.positioning_info.record_info.residual_record_length := 0;
    gfi^.positioning_info.record_info.file_position := amc$eor;

  PROCEND put_next_req;

?? TITLE := 'put_partial_req', EJECT ??

  PROCEDURE put_partial_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      term_option : amt$term_option,
      terminate_previous_block : boolean,
      wsa : ^cell,
      wsl : amt$working_storage_length;

{   Check if last operation was read type that left tape logically at mid_block

    IF bai$partial_read_block_exists () THEN
      switch_from_read_to_write (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    wsl := call_block.putp.working_storage_length;
    wsa := call_block.putp.working_storage_area;
    state_info^.put_op := TRUE;

    CASE call_block.putp.term_option OF

    = amc$start =

      IF bai$partial_record_exists () THEN
        pad_record;
      IFEND;

      IF wsl > gfi^.max_record_length THEN
        wsl := gfi^.max_record_length;
      IFEND;

      gfi^.positioning_info.record_info.record_length := 0;
      gfi^.positioning_info.record_info.transfer_count := 0;

      IF block_info^.current_block_byte_address = 0 THEN
        term_option := amc$start;
        terminate_previous_block := TRUE;
      ELSEIF block_info^.residual_block_length < gfi^.max_record_length THEN
        term_option := amc$start;
        terminate_previous_block := TRUE;
      ELSE  {record fits into current block}
        term_option := amc$continue;
        terminate_previous_block := FALSE;
      IFEND;

      IF (term_option = amc$start) AND (gfi^.max_record_length = gfi^.max_data_size) AND
            (wsl = gfi^.max_record_length) THEN
        term_option := amc$terminate;
      IFEND;

      put_data (file_identifier, operation, wsa, wsl, term_option, terminate_previous_block,
            {convert_if_ebcdid =} TRUE, status);
      IF NOT status.normal AND (status.condition <> ame$end_of_tape_op_completed) THEN
        RETURN;
      IFEND;

      IF (wsl = 0) AND terminate_previous_block THEN
        terminate_previous_block := FALSE;
        put_data (file_identifier, operation, wsa, wsl, term_option, terminate_previous_block,
              {convert_if_ebcdid =} TRUE, status);
        IF NOT status.normal AND (status.condition <> ame$end_of_tape_op_completed) THEN
          RETURN;
        IFEND;
      IFEND;

      gfi^.positioning_info.record_info.record_length := wsl;
      gfi^.positioning_info.record_info.transfer_count := wsl;
      gfi^.positioning_info.record_info.residual_record_length := gfi^.max_record_length - wsl;
      gfi^.positioning_info.record_info.file_position := amc$mid_record;

    = amc$continue =

      IF gfi^.positioning_info.record_info.file_position <> amc$mid_record THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_continue,
              call_block.operation, ' ', status);
        RETURN;
      IFEND;

      IF wsl > gfi^.positioning_info.record_info.residual_record_length THEN
        wsl := gfi^.positioning_info.record_info.residual_record_length;
      IFEND;

      terminate_previous_block := FALSE;
      term_option := amc$continue;

      put_data (file_identifier, operation, wsa, wsl, term_option, terminate_previous_block,
            {convert_if_ebcdid =} TRUE, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      gfi^.positioning_info.record_info.residual_record_length :=
            gfi^.positioning_info.record_info.residual_record_length - wsl;
      gfi^.positioning_info.record_info.transfer_count := wsl;
      gfi^.positioning_info.record_info.record_length := gfi^.max_record_length -
            gfi^.positioning_info.record_info.residual_record_length;
      gfi^.positioning_info.record_info.file_position := amc$mid_record;

    = amc$terminate=

      IF bai$partial_record_exists () THEN
        IF wsl > gfi^.positioning_info.record_info.residual_record_length THEN
          wsl := gfi^.positioning_info.record_info.residual_record_length;
        IFEND;

        term_option := amc$continue;
        terminate_previous_block := FALSE;

        put_data (file_identifier, operation, wsa, wsl, term_option, terminate_previous_block,
              {convert_if_ebcdid =} TRUE, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        gfi^.positioning_info.record_info.residual_record_length :=
              gfi^.positioning_info.record_info.residual_record_length - wsl;
        gfi^.positioning_info.record_info.transfer_count := wsl;

        IF gfi^.positioning_info.record_info.residual_record_length > 0 THEN
          pad_record;
        IFEND;

      ELSE

        IF wsl > gfi^.max_record_length THEN
          wsl := gfi^.max_record_length;
        IFEND;

        gfi^.positioning_info.record_info.record_length := 0;
        gfi^.positioning_info.record_info.transfer_count := 0;

        IF block_info^.current_block_byte_address = 0 THEN
          term_option := amc$start;
          terminate_previous_block := TRUE;
        ELSEIF block_info^.residual_block_length < gfi^.max_record_length THEN
          term_option := amc$start;
          terminate_previous_block := TRUE;
        ELSE  {record fits into current block}
          term_option := amc$continue;
          terminate_previous_block := FALSE;
        IFEND;

        IF (term_option = amc$start) AND (gfi^.max_record_length = gfi^.max_data_size) AND
              (wsl = gfi^.max_record_length) THEN
          term_option := amc$terminate;
        IFEND;

        put_data (file_identifier, operation, wsa, wsl, term_option, terminate_previous_block,
              {convert_if_ebcdid =} TRUE, status);
        IF NOT status.normal AND (status.condition <> ame$end_of_tape_op_completed) THEN
          RETURN;
        IFEND;

        IF (wsl = 0) AND terminate_previous_block THEN
          terminate_previous_block := FALSE;
          put_data (file_identifier, operation, wsa, wsl, term_option, terminate_previous_block,
                {convert_if_ebcdid =} TRUE, status);
          IF NOT status.normal AND (status.condition <> ame$end_of_tape_op_completed) THEN
            RETURN;
          IFEND;
        IFEND;

        gfi^.positioning_info.record_info.residual_record_length := gfi^.max_record_length - wsl;
        gfi^.positioning_info.record_info.transfer_count := wsl;

        IF gfi^.positioning_info.record_info.residual_record_length > 0 THEN
          pad_record;
        IFEND;

      IFEND;

      gfi^.positioning_info.record_info.file_position := amc$eor;
      gfi^.positioning_info.record_info.record_length := gfi^.max_record_length;
      gfi^.positioning_info.record_info.residual_record_length := 0;
    ELSE
      amp$set_file_instance_abnormal (file_identifier, ame$improper_term_option,
            operation, ' ', status);
    CASEND;

  PROCEND put_partial_req;
?? TITLE := 'skip_req', EJECT ??

  PROCEDURE skip_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    CONST
      allow_direct_io_transfer = FALSE,
      start_new_block = TRUE;

    VAR
      block_number: 0 .. amc$max_block_number,
      dummy_wsa : char,
      units_to_skip: amt$skip_count,
      direction: amt$skip_direction,
      error_action: bat$error_actions,
      file_position: amt$file_position,
      tape_failure_modes: amt$tape_failure_modes,
      records_remaining: amt$skip_count,
      request_status: ost$status,
      residual_skip_count: amt$skip_count,
      volume_position: amt$volume_position,
      working_storage_area : ^char,
      wsa : ^cell;


  /main_program/
    BEGIN

      file_position := gfi^.positioning_info.record_info.file_position;
      volume_position := tape_descriptor^.volume_position;
      block_number := block_info^.block_number;
      direction := call_block.skp.direction;
      units_to_skip := call_block.skp.count;

{
{ Check file position to see if any partial blocks need to be written out.
{
      IF bai$partial_record_exists () THEN
        pad_record;
      IFEND;

      IF bai$partial_block_exists () THEN
        bai$write_previous_block (file_identifier, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      CASE call_block.skp.unit OF

?? NEWTITLE := '    skip record', EJECT ??

      = amc$skip_record =

        IF file_position = amc$mid_record THEN
          IF block_info^.residual_block_length >= gfi^.positioning_info.
                record_info.residual_record_length THEN
            block_info^.current_block_byte_address := block_info^.current_block_byte_address +
                  gfi^.positioning_info.record_info.residual_record_length;
            block_info^.residual_block_length := block_info^.residual_block_length -
                  gfi^.positioning_info.record_info.residual_record_length;
          IFEND;
          file_position := amc$eor;
        IFEND;
        gfi^.positioning_info.record_info.residual_record_length := gfi^.max_record_length;
        gfi^.positioning_info.record_info.record_length := 0;

        IF units_to_skip = 0 THEN
          residual_skip_count := 0;
          EXIT /main_program/;
        IFEND;

        working_storage_area := ^dummy_wsa;
        wsa := working_storage_area;

        IF block_info^.current_block_byte_address <> 0 THEN
          records_remaining := block_info^.residual_block_length DIV
                gfi^.max_record_length;
          IF records_remaining >= units_to_skip THEN  {skip can be done within current block}
            residual_skip_count := 0;
            file_position := amc$eor;
            block_info^.current_block_byte_address := block_info^.current_block_byte_address +
                    (units_to_skip * gfi^.max_record_length);
            block_info^.residual_block_length := block_info^.current_block_length -
                    block_info^.current_block_byte_address;
            EXIT /main_program/;

          ELSE
            units_to_skip := units_to_skip - records_remaining;

          IFEND;
        IFEND;

      /read_loop/
        WHILE TRUE DO
          residual_skip_count := units_to_skip;
          get_data (file_identifier, operation, wsa, {wsl=} 1, allow_direct_io_transfer,
                start_new_block, {convert_if_ebcdid =} TRUE, status);

          IF (tape_descriptor^.volume_position = amc$eov) OR
                (tape_descriptor^.volume_position = amc$after_tapemark) THEN
            EXIT /read_loop/;

          ELSE
            IF block_info^.current_block_length = 0 THEN
              EXIT /main_program/;   {fatal error occurred}
            IFEND;

            records_remaining := block_info^.current_block_length DIV
                  gfi^.max_record_length;
            IF records_remaining >= units_to_skip THEN  {skip can complete within this block}
              residual_skip_count := 0;
              gfi^.positioning_info.record_info.transfer_count := 0;
              block_info^.current_block_byte_address := units_to_skip * gfi^.max_record_length;
              block_info^.residual_block_length := block_info^.current_block_length -
                      block_info^.current_block_byte_address;
              IF block_info^.residual_block_length = 0 THEN
                block_info^.block_position := bac$beginning_of_block;
              ELSE
                block_info^.block_position := bac$middle_of_block;
              IFEND;
              EXIT /read_loop/;
            ELSE  {must continue reading}
              units_to_skip := units_to_skip - records_remaining;
            IFEND;
          IFEND;
        WHILEND /read_loop/;


        IF residual_skip_count > 0 THEN

{
{ Must have hit a tape_mark or a volume boundry. }
{

          file_position := amc$eoi;
          volume_position := tape_descriptor^.volume_position;
          amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi, operation,
            'RECORDS', status);

        ELSE
          file_position := amc$eor; { The normal case. }
          volume_position := amc$after_data_block;
        IFEND;

?? TITLE := '    skip tape marks', EJECT ??

      = amc$skip_tape_mark =

        IF units_to_skip = 0 THEN {no-op.}
          file_instance^.residual_skip_count := 0;
          call_block.skp.file_position^ := file_position;
          RETURN;
        IFEND;

        residual_skip_count := units_to_skip;

        IF direction = amc$forward THEN

        /whileloop/
          WHILE residual_skip_count > 0 DO

            REPEAT
              bap$tape_bm_skip_tapemark (file_identifier, direction, tape_failure_modes, request_status);
              bai$process_request_status (file_identifier, operation, request_status,
                    tape_failure_modes, error_action, status);
              IF NOT status.normal AND (status.condition = ame$input_after_output) THEN
                file_position := amc$eoi;
                volume_position := amc$eov;
                amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi, operation,
                        'TAPEMARKS', status);
                EXIT /main_program/;
              IFEND;
              IF error_action = bac$exit_procedure THEN
                EXIT /main_program/;
              IFEND;
            UNTIL error_action <> bac$retry_last_request;

            IF bai$label_type () = amc$unlabelled THEN
              bai$check_tapemark (file_identifier, volume_position, request_status);
              bai$process_request_status (file_identifier, operation, request_status,
                    tape_failure_modes, error_action, status);
              IF NOT status.normal OR (error_action = bac$exit_procedure) THEN
                EXIT /main_program/;
              IFEND;
              CASE volume_position OF
              = amc$after_tapemark =
                residual_skip_count := residual_skip_count - 1;
              = amc$eov =
                bai$advance_volume (file_identifier, volume_position, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
                IF volume_position = amc$eov THEN
                  EXIT /whileloop/;
                IFEND;
              ELSE
                ;
              CASEND;
            ELSE { label_type <> amc$unlabelled     }

{
{ Since skipping by tapemarks is illegal on labelled tapes, this call must be for non_standard labels.
{
{ Consecutive tapemarks indicate a null file, not end of volume, and each tapemark needs to be skipped.
{

              residual_skip_count := residual_skip_count - 1;

            IFEND;

          WHILEND /whileloop/;

          IF residual_skip_count > 0 THEN
            amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi, operation,
              'TAPEMARKS', status);
          IFEND;
          IF status.normal THEN
            file_position := amc$boi;
            volume_position := amc$after_tapemark;
          ELSE
            file_position := amc$eoi;
            volume_position := amc$eov;
          IFEND;

        ELSE { direction = amc$backward }

          /backloop/
            WHILE residual_skip_count > 0 DO

              REPEAT
                bap$tape_bm_skip_tapemark (file_identifier, direction, tape_failure_modes, request_status);
                bai$process_request_status (file_identifier, operation, request_status,
                      tape_failure_modes, error_action, status);
                IF error_action = bac$exit_procedure THEN
                  EXIT /main_program/;
                IFEND;
                IF NOT status.normal AND (status.condition = ame$skip_encountered_bov) THEN
                  EXIT /backloop/;
                IFEND;
                IF status.normal THEN
                  residual_skip_count := residual_skip_count - 1;
                IFEND;
              UNTIL error_action <> bac$retry_last_request;

            WHILEND /backloop/;

            IF residual_skip_count > 0 THEN
              amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_bov, operation,
                'TAPEMARKS', status);
            IFEND;
            IF status.normal THEN
              file_position := amc$eoi;
              volume_position := amc$before_tapemark;
            ELSE
              file_position := amc$boi;
              volume_position := amc$bov;
            IFEND;
        IFEND;

        block_number := 1;

?? OLDTITLE ??
      ELSE
      CASEND;

    END /main_program/;

    call_block.skp.file_position^ := file_position;
    gfi^.positioning_info.record_info.file_position := file_position;
    file_instance^.residual_skip_count := residual_skip_count;
    tape_descriptor^.volume_position := volume_position;
    block_info^.block_number := block_number;
    IF call_block.skp.unit = amc$skip_tape_mark THEN
      block_info^.block_position := bac$beginning_of_block;
      block_info^.current_block_byte_address := 0;
      block_info^.current_block_length := 0;
      block_info^.residual_block_length := 0;
      gfi^.positioning_info.record_info.residual_record_length := 0;
      gfi^.positioning_info.record_info.record_length := 0;
      tape_descriptor^.put_tape_block_buffer := NIL;
      tape_descriptor^.get_tape_block_buffer := NIL;
    IFEND;

  PROCEND skip_req;
*copy bai$lrt_common_procedures
MODEND bam$lrt_us_fixed_tape_fap;
*DECK DECK=BAM$LRT_US_UNDEF_TAPE_FAP EXPAND=TRUE
MODULE bam$lrt_us_undef_tape_fap;
?? LEFT := 1, RIGHT := 110 ??
? VAR user_fap: boolean := FALSE?;
? VAR pad_records: boolean := FALSE?;
?? PUSH (LIST := OFF) ??

























?? POP ??
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
?? TITLE := 'Type definitions' ??
*copyc amt$tape_error_options
*copyc amt$file_identifier
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc bat$put_label_request
*copyc bat$record_header_type
*copyc ost$caller_identifier
*copyc bak$bap_procedure_keypoints
?? TITLE := 'Error code definitions', EJECT ??
*copyc ame$improper_file_id
*copyc ame$improper_wsl
*copyc ame$get_program_actions
*copyc ame$get_validation_errors
*copyc ame$put_program_actions
*copyc ame$put_validation_errors
*copyc ame$skip_program_actions
*copyc ame$skip_validation_errors
*copyc bae$tape_bm_error_codes
*copyc dme$tape_errors
?? OLDTITLE ??
?? EJECT ??
?? POP ??
{ The following POP pragmat is here to negate an extra push (listext :=on) in one of the bam decks. }
?? POP ??
?? TITLE := 'XREF variable and procedure definitions' ??
*copyc osv$task_private_heap
*copyc amp$set_file_instance_abnormal
*copyc bap$close
*copyc bap$tape_bm_align_position
*copyc bap$tape_bm_flush
*copyc bap$tape_bm_open
*copyc bap$tape_bm_read_label
*copyc bap$tape_bm_read_next_block
*copyc bap$tape_bm_read_to_write
*copyc bap$tape_bm_close
*copyc bap$tape_bm_write_next_block
*copyc bap$tape_bm_reserve_blk_buffer
*copyc bap$tape_bm_skip_blocks
*copyc bap$tape_bm_skip_tapemark
*copyc bap$tape_bm_rewind
*copyc bap$tape_bm_advance_volume
*copyc bap$tape_bm_erase_block
*copyc bap$tape_bm_tapemark_check
*copyc bap$tape_bm_write_tape_mark
*copyc bap$tape_bm_write_label
*copyc bap$tape_bm_write_label_mark
*copyc bap$fap_control
*copyc osp$set_status_abnormal
?? TITLE := 'INLINE function definitions' ??
?? NEWTITLE := ' ' ??
?? TITLE := 'bai$state_info', EJECT ??
*copyc bai$state_info
?? TITLE := 'bai$tape_descriptor', EJECT ??
*copyc bai$tape_descriptor
?? TITLE := 'bai$block_info', EJECT ??
*copyc bai$block_info
?? TITLE := 'bai$dynamic_label', EJECT ??
*copyc bai$dynamic_label
?? TITLE := 'bai$gfi', EJECT ??
*copyc bai$gfi
?? TITLE := 'bai$label_type', EJECT ??
*copyc bai$label_type
?? TITLE := 'bai$partial_block_exists', EJECT ??
*copyc bai$partial_block_exists
?? TITLE := 'bai$partial_read_block_exists', EJECT ??
*copyc bai$partial_read_block_exists
?? TITLE := 'bai$static_label', EJECT ??
*copyc bai$static_label
?? OLDTITLE ??
?? TITLE := 'INLINE procedure definitions' ??
?? NEWTITLE := ' ' ??
?? TITLE := 'osp$disestablish_cond_handler', EJECT ??
*copyc osp$disestablish_cond_handler
?? TITLE := 'osp$establish_block_exit_hndlr', EJECT ??
*copyc osp$establish_block_exit_hndlr
?? TITLE := 'bai$advance_volume', EJECT ??
*copyc bai$advance_volume
?? TITLE := 'bai$append_tape_error', EJECT ??
*copyc bai$append_tape_error
?? TITLE := 'bai$check_caller_id', EJECT ??
*copyc bai$check_caller_id
?? TITLE := 'bai$check_record_level_access', EJECT ??
*copyc bai$check_record_level_access
?? TITLE := 'bai$check_tapemark', EJECT ??
*copyc bai$check_tapemark
?? TITLE := 'bai$clear_fail_at_current_pos', EJECT ??
*copyc bai$clear_fail_at_current_pos
?? TITLE := 'bai$fetch_tape_error_options', EJECT ??
*copyc bai$fetch_tape_error_options
?? TITLE := 'bai$forced_write', EJECT ??
*copyc bai$forced_write
?? TITLE := 'bai$init_boi_tape_position', EJECT ??
*copyc bai$init_boi_tape_position
?? TITLE := 'bai$process_block_information', EJECT ??
*copyc bai$process_block_information
?? TITLE := 'bai$process_request_status', EJECT ??
*copyc bai$process_request_status
?? TITLE := 'bai$validate_tape_access', EJECT ??
*copyc bai$validate_tape_access
?? TITLE := 'bai$write_previous_block', EJECT ??
*copyc bai$write_previous_block
?? TITLE := 'bap$validate_fap_identifier', EJECT ??
*copyc bap$validate_fap_identifier
?? TITLE := 'bap$validate_file_identifier', EJECT ??
*copyc bap$validate_file_identifier
?? TITLE := 'i#move', EJECT ??
*copyc i#move
?? OLDTITLE ??
?? TITLE := 'global variables for this call of the fap', EJECT ??
*copyc bav$global_tape_fap_variables

  CONST
    pad_blocks = FALSE,
    record_headers_exist = FALSE;

?? TITLE := 'bap#lrt_us_undef_tape_fap', EJECT ??
? IF user_fap THEN
  VAR
    ttv$layer_number: [XDCL] amt$fap_layer_number := 0;

  PROCEDURE [XDCL, #GATE] bap#lrt_us_undef_tape_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    ttv$layer_number := layer_number;
    bap$lrt_us_undef_tape_fap (file_identifier, call_block, layer_number, status);

  PROCEND bap#lrt_us_undef_tape_fap;
? IFEND

?? TITLE := 'bap$lrt_us_undef_tape_fap', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$lrt_us_undef_tape_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      dynamic_label: ^bat$dynamic_label_attributes,
      i: integer,
      local_status: ost$status,
      static_label: ^bat$instance_static_attributes,
      validation_ok: boolean;

    #caller_id (caller_id);
    operation := call_block.operation;
    #keypoint (osk$entry, osk$m * ((file_identifier.ordinal * 256) + operation),
          bak$us_blk_undef_rec_tape_fap);
    status.normal := TRUE;
    global_layer_number := layer_number;
    close_file_on_exit := FALSE;

  /main_program/
    BEGIN

? IF user_fap THEN
      bap$validate_fap_identifier (file_identifier, file_instance, validation_ok);
? ELSE
      bap$validate_file_identifier (file_identifier, file_instance, validation_ok);
? IFEND
      IF NOT validation_ok THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
              'bap$lrt_us_undef_tape_fap', status);
        EXIT /main_program/;
      IFEND;

      block_info := bai$block_info (file_instance);
      gfi := bai$gfi (file_instance);
      tape_descriptor := bai$tape_descriptor (file_instance);
      static_label := bai$static_label (file_instance);
      state_info := bai$state_info (file_instance);
      bai$check_caller_id (file_identifier, static_label^.ring_attributes, operation, caller_id,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      bai$check_record_level_access (file_identifier, file_instance^.access_level, operation,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      dynamic_label := bai$dynamic_label (file_instance);
      bai$validate_tape_access (file_identifier, dynamic_label^.access_mode, operation, tape_descriptor,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      bai$clear_fail_at_current_pos (operation, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;


      tape_descriptor^.error_options := dynamic_label^.error_options;

      CASE operation OF

      = amc$close_req =
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: US/U FAP calling CLOSE');
        close_req (file_identifier, status);
        bap$close (file_identifier, local_status);
        IF status.normal THEN
          status := local_status;
        IFEND;
      = amc$close_volume_req =
        close_volume_req (file_identifier, status);
        file_instance^.previous_get_at_eoi := FALSE;
      = amc$erase_tape_block =
        erase_tape_block_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$fetch_req =
        bap$fap_control (file_identifier, call_block, layer_number, status);
      = amc$flush_req =
        flush_req (file_identifier, status);
      = amc$get_next_req =
        get_next_req (file_identifier, call_block, status);
        IF status.normal AND (call_block.getn.file_position^ <> amc$eoi) THEN
          tape_descriptor^.at_eoi := FALSE;
        IFEND;
      = amc$get_partial_req =
        get_partial_req (file_identifier, call_block, status);
        IF status.normal AND (call_block.getp.file_position^ <> amc$eoi) THEN
          tape_descriptor^.at_eoi := FALSE;
        IFEND;
      = amc$open_req =
        rmp$log_debug_message ('LABELED_TAPE_DEBUG: US/U FAP calling OPEN');
        tape_descriptor^.file_label_type := static_label^.file_label_type;
        open_req (file_identifier, call_block, layer_number, dynamic_label, status);
      = amc$put_next_req =
        IF (bai$label_type () = amc$labelled) THEN
          IF NOT state_info^.ve_wrote_ansi_file THEN
            amp$set_file_instance_abnormal (file_identifier, ame$rewrite_labels_conflict,
                  call_block.operation, ' ', status);
            RETURN;
          IFEND;
          IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
            sl_reposition_for_put_at_eoi (file_identifier, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
        put_next_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$put_partial_req =
        IF (bai$label_type () = amc$labelled) THEN
          IF NOT state_info^.ve_wrote_ansi_file THEN
            amp$set_file_instance_abnormal (file_identifier, ame$rewrite_labels_conflict,
                  call_block.operation, ' ', status);
            RETURN;
          IFEND;
          IF bap$after_trailer_labels (tape_descriptor^.labeled_volume_position) THEN
            sl_reposition_for_put_at_eoi (file_identifier, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
        put_partial_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      = amc$rewind_req =
        rewind_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := FALSE;
      = amc$skip_req =
        validate_skip_parameters (file_identifier, call_block, FALSE, FALSE, TRUE, TRUE, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        skip_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
      = amc$write_tape_mark_req =
        IF bai$label_type () = amc$labelled THEN
          amp$set_file_instance_abnormal (file_identifier, ame$improper_labelled_tape_op,
                call_block.operation, 'WRITE OF TAPE MARK', status);
          EXIT /main_program/;
        IFEND;

{   Check if last operation was read type that left tape logically at mid_block

        IF bai$partial_read_block_exists () THEN
          switch_from_read_to_write (file_identifier, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;
        write_tape_mark_req (file_identifier, call_block, status);
        file_instance^.previous_get_at_eoi := FALSE;
        tape_descriptor^.at_eoi := status.normal OR tape_descriptor^.at_eoi;
      ELSE

        bap$fap_control (file_identifier, call_block, layer_number, status);

      CASEND;

    END /main_program/;

    IF (operation >= amc$last_access_start) AND (operation <= amc$max_operation)
          AND (operation <> amc$fetch_req) AND
          (operation <> amc$fetch_access_information_rq) THEN
      gfi^.last_access_operation := operation;
    IFEND;
    IF status.normal THEN
      gfi^.error_status := 0;
    ELSE
      gfi^.error_status := status.condition;
    IFEND;

{
{   IF the operator terminates a tape assignment that was initiated via bai$advance_volume,
{   the file will be closed at this point.  It cannot be closed in bai$advance_volume since
{   the global_file_information may be referenced after the call.
{

    IF close_file_on_exit THEN
      bap$close (file_identifier, local_status);
    IFEND;

    #keypoint (osk$exit, 0, bak$us_blk_undef_rec_tape_fap);

  PROCEND bap$lrt_us_undef_tape_fap;
?? TITLE := 'get_next_req', EJECT ??

{
{ The purpose of this request is to cause the transfer of data from tape to a
{ tape buffer, transfer data from the tape buffer to the users working
{ storage area, and to update all file descriptor fields.
{

  PROCEDURE get_next_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    CONST
      allow_direct_io_transfer = TRUE,
      start_new_block = TRUE;

    IF bai$partial_block_exists () THEN
      bai$write_previous_block (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF (call_block.getn.working_storage_length < 0) OR (call_block.getn.
          working_storage_length > UPPERVALUE (amt$working_storage_length)) THEN
      amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
            operation, ' ', status);
      RETURN;
    IFEND;

    get_data (file_identifier, operation, call_block.getn.working_storage_area, call_block.getn.
          working_storage_length, allow_direct_io_transfer, start_new_block,
          {convert_if_ebcdic =} TRUE, status);

    IF gfi^.positioning_info.block_info.block_position = bac$middle_of_block THEN
      gfi^.positioning_info.record_info.file_position := amc$mid_record;
    ELSEIF (tape_descriptor^.volume_position = amc$eov) OR
    {} (tape_descriptor^.volume_position = amc$after_tapemark) THEN
      gfi^.positioning_info.record_info.file_position := amc$eoi;
      file_instance^.previous_get_at_eoi := TRUE;
      tape_descriptor^.at_eoi := TRUE;
    ELSE
      gfi^.positioning_info.record_info.file_position := amc$eor;
    IFEND;

    call_block.getn.file_position^ := gfi^.positioning_info.record_info.file_position;
    call_block.getn.transfer_count^ := gfi^.positioning_info.record_info.transfer_count;
    gfi^.positioning_info.record_info.record_length := block_info^.current_block_byte_address;

  PROCEND get_next_req;

?? TITLE := 'get_partial_req', EJECT ??

{
{ The purpose of this request is to cause a partial transfer of data from tape to a
{ tape buffer, transfer data from the tape buffer to the users working
{ storage area, and to update all file descriptor fields.
{

  PROCEDURE get_partial_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    CONST
      allow_direct_io_transfer = FALSE;

    IF bai$partial_block_exists () THEN
      bai$write_previous_block (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF (call_block.getp.working_storage_length < 0) OR (call_block.getp.
          working_storage_length > UPPERVALUE (amt$working_storage_length)) THEN
      amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
            operation, ' ', status);
      RETURN;
    IFEND;

    IF (call_block.getp.skip_option < LOWERVALUE (amt$skip_option)) OR
          (call_block.getp.skip_option > UPPERVALUE (amt$skip_option)) THEN
      amp$set_file_instance_abnormal (file_identifier, ame$improper_skip_option,
            operation, ' ', status);
      RETURN;
    IFEND;

    get_data (file_identifier, operation, call_block.getp.working_storage_area, call_block.getp.
          working_storage_length, allow_direct_io_transfer,
          { start_new_block = } call_block.getp.skip_option = amc$skip_to_eor,
          {convert_if_ebcdic =} TRUE, status);

    IF gfi^.positioning_info.block_info.block_position = bac$middle_of_block THEN
      gfi^.positioning_info.record_info.file_position := amc$mid_record;
    ELSEIF (tape_descriptor^.volume_position = amc$eov) OR
    {} (tape_descriptor^.volume_position = amc$after_tapemark) THEN
      gfi^.positioning_info.record_info.file_position := amc$eoi;
      file_instance^.previous_get_at_eoi := TRUE;
      tape_descriptor^.at_eoi := TRUE;
    ELSE
      gfi^.positioning_info.record_info.file_position := amc$eor;
    IFEND;

    gfi^.positioning_info.record_info.record_length := block_info^.current_block_byte_address;
    call_block.getp.record_length^ := gfi^.positioning_info.record_info.record_length;
    call_block.getp.file_position^ := gfi^.positioning_info.record_info.file_position;
    call_block.getp.transfer_count^ := gfi^.positioning_info.record_info.transfer_count;

  PROCEND get_partial_req;
?? TITLE := 'put_next_req', EJECT ??

{
{ The purpose of this request is to transfer data from the users
{ working storage area to a tape file, either directly, or through
{ a tape buffer, and to update all file descriptor fields.
{

  PROCEDURE put_next_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    CONST
      terminate_previous_block = TRUE;

{   Check if last operation was read type that left tape logically at mid_block

    IF bai$partial_read_block_exists () THEN
      switch_from_read_to_write (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    put_data (file_identifier, operation, call_block.putn.working_storage_area, call_block.putn.
          working_storage_length, amc$terminate, terminate_previous_block,
          {convert_if_ebcdic =} TRUE, status);

    gfi^.positioning_info.record_info.record_length := call_block.putn.working_storage_length;
    gfi^.positioning_info.record_info.transfer_count := call_block.putn.working_storage_length;
    gfi^.positioning_info.record_info.file_position := amc$eor;
    state_info^.put_op := TRUE;

  PROCEND put_next_req;

?? TITLE := 'put_partial_req', EJECT ??

  PROCEDURE put_partial_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      terminate_previous_block: boolean;

    IF (call_block.putp.term_option < LOWERVALUE (amt$term_option)) OR
          (call_block.putp.term_option > UPPERVALUE (amt$term_option)) THEN
      amp$set_file_instance_abnormal (file_identifier, ame$improper_term_option,
            operation, ' ', status);
      RETURN;
    IFEND;

{   Check if last operation was read type that left tape logically at mid_block

    IF bai$partial_read_block_exists () THEN
      switch_from_read_to_write (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    terminate_previous_block := call_block.putp.term_option = amc$start;

    put_data (file_identifier, operation, call_block.putp.working_storage_area, call_block.putp.
          working_storage_length, call_block.putp.term_option, terminate_previous_block,
          {convert_if_ebcdic =} TRUE, status);

    gfi^.positioning_info.record_info.transfer_count := call_block.putp.working_storage_length;

    CASE call_block.putp.term_option OF

    = amc$start =
      gfi^.positioning_info.record_info.record_length := call_block.putp.working_storage_length;

    = amc$continue =
      gfi^.positioning_info.record_info.record_length := gfi^.positioning_info.
            record_info.record_length + call_block.putp.working_storage_length;

    = amc$terminate =
      IF gfi^.positioning_info.record_info.file_position = amc$mid_record THEN
        gfi^.positioning_info.record_info.record_length := gfi^.positioning_info.
              record_info.record_length + call_block.putp.working_storage_length;
      ELSE
        gfi^.positioning_info.record_info.record_length := call_block.putp.working_storage_length;
      IFEND;
    ELSE
    CASEND;

    IF gfi^.positioning_info.block_info.block_position = bac$middle_of_block THEN
      gfi^.positioning_info.record_info.file_position := amc$mid_record;
    ELSE
      gfi^.positioning_info.record_info.file_position := amc$eor;
    IFEND;

    state_info^.put_op := TRUE;

  PROCEND put_partial_req;
?? TITLE := 'skip_req', EJECT ??

  PROCEDURE skip_req (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

    VAR
      block_number: 0 .. amc$max_block_number,
      units_to_skip: amt$skip_count,
      direction: amt$skip_direction,
      error_action: bat$error_actions,
      file_position: amt$file_position,
      tape_failure_modes: amt$tape_failure_modes,
      next_block_is_a_tapemark: boolean,
      label_group: fst$ansi_label_kinds,
      pre_request_volume_position: amt$volume_position,
      request_status: ost$status,
      residual_skip_count: amt$skip_count,
      volume_boundary_encountered: boolean,
      volume_position: amt$volume_position;

  /main_program/
    BEGIN

      file_position := gfi^.positioning_info.record_info.file_position;
      volume_position := tape_descriptor^.volume_position;
      block_number := block_info^.block_number;
      direction := call_block.skp.direction;
      units_to_skip := call_block.skp.count;

{
{ Check block position to see if any partial blocks need to be written out.
{

      IF bai$partial_block_exists () THEN
        bai$write_previous_block (file_identifier, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      CASE call_block.skp.unit OF

?? NEWTITLE := '    skip record', EJECT ??

      = amc$skip_record =

{
{ For undefined record, user specified blocking, this request
{ is asking to skip tape blocks.
{

        IF (units_to_skip = 0) AND (file_position <> amc$mid_record) THEN
          residual_skip_count := 0;
          EXIT /main_program/;
        IFEND;

        volume_boundary_encountered := FALSE;
        pre_request_volume_position := volume_position;

        IF (file_position = amc$mid_record) AND (direction = amc$backward) THEN
          units_to_skip := units_to_skip + 1;
        IFEND;

      /repeat_loop/
        REPEAT

          bap$tape_bm_skip_blocks (file_identifier, direction, units_to_skip, residual_skip_count,
                tape_failure_modes, request_status);

          bai$process_request_status (file_identifier, operation, request_status,
                tape_failure_modes, error_action, status);
          IF NOT status.normal AND (status.condition = ame$input_after_output) THEN
            file_position := amc$eoi;
            volume_position := amc$eov;
            amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi, operation,
                    'RECORDS', status);
            EXIT /main_program/;
          IFEND;
          IF error_action = bac$exit_procedure THEN
            EXIT /main_program/;
          IFEND;

          IF (residual_skip_count > 0) AND (direction = amc$forward) THEN
            CASE bai$label_type () OF
            = amc$unlabelled =
              bap$tape_bm_tapemark_check (file_identifier, next_block_is_a_tapemark, request_status);
              bai$process_request_status (file_identifier, operation, request_status,
                    tape_failure_modes, error_action, status);
              IF NOT status.normal OR (error_action = bac$exit_procedure) THEN
                EXIT /main_program/;
              IFEND;
              IF next_block_is_a_tapemark THEN
                bai$advance_volume (file_identifier, volume_position, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
                IF volume_position = amc$eov THEN
                  volume_boundary_encountered := TRUE;
                  EXIT /repeat_loop/;
                IFEND;

{ Reset block_number and pre_request_volume_position to account for volume advance.  This
{ needs to be done so the calculation of block_number at the end of the request is correct.

                block_number := block_info^.block_number;
                pre_request_volume_position := volume_position;
                units_to_skip := residual_skip_count;
                error_action := bac$retry_last_request;
              IFEND;
            = amc$labelled =
              sl_read_tape_labels (file_identifier, label_group, status);
              IF status.normal THEN
                IF fsp$volume_trailer_labels (label_group) THEN
                  sl_close_label_volume (file_identifier, status);
                  IF status.normal THEN
                    volume_position := amc$bov;

{ Reset block_number and pre_request_volume_position to account for volume advance.  This
{ needs to be done so the calculation of block_number at the end of the request is correct.

                    block_number := block_info^.block_number;
                    pre_request_volume_position := volume_position;
                    units_to_skip := residual_skip_count;
                    error_action := bac$retry_last_request;
                  IFEND;
                ELSE
                  volume_position := amc$after_tapemark;
                  EXIT /repeat_loop/;
                IFEND;
              ELSE
                CASE status.condition OF
                = ame$invalid_tape_label = {Allow: * data}
                  sl_advance_tapemark (file_identifier, amc$backward, 1, status);
                  IF status.normal THEN
                    sl_advance_tapemark (file_identifier, amc$forward, 1, status);
                    volume_position := amc$after_tapemark;
                    EXIT /repeat_loop/;
                  IFEND;
                = ame$tape_end_of_volume_list =
                  volume_boundary_encountered := TRUE;
                  volume_position := amc$eov;
                  EXIT /repeat_loop/;
                = ame$unexpected_tapemark =
                  sl_advance_tapemark (file_identifier, amc$backward, 2, status);
                  IF status.normal THEN
                    sl_advance_tapemark (file_identifier, amc$forward, 1, status);
                    volume_position := amc$after_tapemark;
                    EXIT /repeat_loop/;
                  IFEND;
                ELSE
                CASEND;
              IFEND;
            = amc$non_standard_labelled =
              bap$tape_bm_tapemark_check (file_identifier, next_block_is_a_tapemark, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              IF next_block_is_a_tapemark THEN
                volume_boundary_encountered := TRUE;
              IFEND;
              EXIT /repeat_loop/;
            ELSE
            CASEND;
          IFEND;
        UNTIL error_action <> bac$retry_last_request;

        IF residual_skip_count > 0 THEN

{
{ Must have hit a tape_mark or a volume boundry. }
{

          IF direction = amc$forward THEN
            file_position := amc$eoi;
            IF volume_boundary_encountered THEN
              volume_position := amc$eov;
            ELSE
              volume_position := amc$after_tapemark;
            IFEND;
            amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi, operation,
              'RECORDS', status);
          ELSE { direction = amc$backward }
            file_position := amc$boi;
            IF bai$label_type () = amc$labelled THEN
              sl_advance_tapemark (file_identifier, amc$forward, 1, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              volume_position := amc$after_tapemark;
              IF tape_descriptor^.next_position.file_section_number = 1 THEN
                amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_boi, operation,
                  'RECORDS', status);
              ELSE
                amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_bot, operation,
                  '', status);
              IFEND;
            ELSE { amc$unlabelled or amc$non_standard_labelled }
              volume_boundary_encountered := NOT request_status.normal AND (request_status.condition =
                    bae$skip_encountered_bov);
              IF volume_boundary_encountered THEN
                volume_position := amc$bov;
              ELSE
                volume_position := amc$before_tapemark;
              IFEND;
              amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_boi, operation,
                'RECORDS', status);
            IFEND;
          IFEND;

        ELSE
          file_position := amc$eor; { The normal case. }
          volume_position := amc$after_data_block;
        IFEND;

        IF direction = amc$forward THEN
          IF pre_request_volume_position <> amc$after_data_block THEN
            block_number := block_number - 1;
          IFEND;
          IF block_number + (units_to_skip - residual_skip_count) <= 0 THEN
            block_number := 1;
          ELSE
            block_number := block_number + (units_to_skip - residual_skip_count);
          IFEND;
        ELSE { direction = amc$backward }
          IF block_number - (call_block.skp.count - residual_skip_count) <= 0 THEN
            block_number := 1;
          ELSE
            block_number := block_number - (call_block.skp.count - residual_skip_count);
          IFEND;
        IFEND;

?? TITLE := '    skip tape marks', EJECT ??

      = amc$skip_tape_mark =

        IF units_to_skip = 0 THEN {no-op.}
          file_instance^.residual_skip_count := 0;
          call_block.skp.file_position^ := file_position;
          RETURN;
        IFEND;

        residual_skip_count := units_to_skip;

        IF direction = amc$forward THEN

        /whileloop/
          WHILE residual_skip_count > 0 DO

            REPEAT
              bap$tape_bm_skip_tapemark (file_identifier, direction, tape_failure_modes, request_status);
              bai$process_request_status (file_identifier, operation, request_status,
                    tape_failure_modes, error_action, status);
              IF NOT status.normal AND (status.condition = ame$input_after_output) THEN
                file_position := amc$eoi;
                volume_position := amc$eov;
                amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi, operation,
                        'TAPEMARKS', status);
                EXIT /main_program/;
              IFEND;
              IF error_action = bac$exit_procedure THEN
                EXIT /main_program/;
              IFEND;
            UNTIL error_action <> bac$retry_last_request;

            IF bai$label_type () = amc$unlabelled THEN
              bai$check_tapemark (file_identifier, volume_position, request_status);
              bai$process_request_status (file_identifier, operation, request_status,
                    tape_failure_modes, error_action, status);
              IF NOT status.normal OR (error_action = bac$exit_procedure) THEN
                EXIT /main_program/;
              IFEND;
              CASE volume_position OF
              = amc$after_tapemark =
                residual_skip_count := residual_skip_count - 1;
              = amc$eov =
                bai$advance_volume (file_identifier, volume_position, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
                IF volume_position = amc$eov THEN
                  EXIT /whileloop/;
                IFEND;
              ELSE
                ;
              CASEND;
            ELSE { label_type <> amc$unlabelled     }

{
{ Since skipping by tapemarks is illegal on labelled tapes, this call must be for non_standard labels.
{
{ Consecutive tapemarks indicate a null file, not end of volume, and each tapemark needs to be skipped.
{

              residual_skip_count := residual_skip_count - 1;

            IFEND;

          WHILEND /whileloop/;

          IF residual_skip_count > 0 THEN
            amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_eoi, operation,
              'TAPEMARKS', status);
          IFEND;
          IF status.normal THEN
            file_position := amc$boi;
            volume_position := amc$after_tapemark;
          ELSE
            file_position := amc$eoi;
            volume_position := amc$eov;
          IFEND;

        ELSE { direction = amc$backward }

          /backloop/
            WHILE residual_skip_count > 0 DO

              REPEAT
                bap$tape_bm_skip_tapemark (file_identifier, direction, tape_failure_modes, request_status);
                bai$process_request_status (file_identifier, operation, request_status,
                      tape_failure_modes, error_action, status);
                IF error_action = bac$exit_procedure THEN
                  EXIT /main_program/;
                IFEND;
                IF NOT status.normal AND (status.condition = ame$skip_encountered_bov) THEN
                  EXIT /backloop/;
                IFEND;
                IF status.normal THEN
                  residual_skip_count := residual_skip_count - 1;
                IFEND;
              UNTIL error_action <> bac$retry_last_request;

            WHILEND /backloop/;

            IF residual_skip_count > 0 THEN
              amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_bov, operation,
                'TAPEMARKS', status);
            IFEND;
            IF status.normal THEN
              file_position := amc$eoi;
              volume_position := amc$before_tapemark;
            ELSE
              file_position := amc$boi;
              volume_position := amc$bov;
            IFEND;
        IFEND;

        block_number := 1;

      ELSE
      CASEND;
?? OLDTITLE ??

    END /main_program/;

    call_block.skp.file_position^ := file_position;
    gfi^.positioning_info.record_info.file_position := file_position;
    file_instance^.residual_skip_count := residual_skip_count;
    tape_descriptor^.volume_position := volume_position;
    block_info^.block_number := block_number;
    block_info^.block_position := bac$beginning_of_block;
    block_info^.current_block_byte_address := 0;
    block_info^.current_block_length := 0;
    block_info^.residual_block_length := 0;
    tape_descriptor^.put_tape_block_buffer := NIL;
    tape_descriptor^.get_tape_block_buffer := NIL;

  PROCEND skip_req;
*copy bai$lrt_common_procedures
MODEND bam$lrt_us_undef_tape_fap;
*DECK DECK=BAM$MARK_FAP_LAYER_STATUS EXPAND=TRUE
*copyc osd$default_pragmats
MODULE bam$mark_fap_layer_status;

?? TITLE := 'NOS/VE : BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] BAP$MARK_FAP_LAYER_CLOSED' ??
?? NEWTITLE := '  RING BRACKETS 23D' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amt$file_identifier
*copyc ame$fap_validation_errors
*copyc ame$improper_file_id
*copyc ost$status
?? POP ??
*copyc bap$validate_file_identifier
*copyc bav$task_file_table
*copyc osp$set_status_abnormal
?? EJECT ??

  PROCEDURE [XDCL, #GATE] bap$mark_fap_layer_closed
    (    file_identifier: amt$file_identifier;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    CONST
      interface_name = 'BAP$MARK_FAP_LAYER_CLOSED';

    VAR
      file_is_valid: boolean,
      file_instance: ^bat$task_file_entry;

    status.normal := TRUE;

    bap$validate_file_identifier (file_identifier, file_instance,
          file_is_valid);

    IF file_is_valid THEN
      IF layer_number = 0 THEN
        file_instance^.fap_control_information.first_fap.layer_closed := TRUE;
        IF  file_instance^.fap_control_information.fap_array <> NIL  THEN
          file_instance^.fap_control_information.fap_array^ [layer_number].
                layer_closed := TRUE;
        IFEND;
      ELSEIF (file_instance^.fap_control_information.fap_array <> NIL) AND
            (layer_number <= UPPERBOUND (file_instance^.fap_control_information.
            fap_array^)) THEN
        file_instance^.fap_control_information.fap_array^ [layer_number].
              layer_closed := TRUE;
      ELSE
        osp$set_status_abnormal (amc$access_method_id,
              ame$improper_layer_number, interface_name, status);
      IFEND;
    ELSE
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
    IFEND;

  PROCEND bap$mark_fap_layer_closed;
?? OLDTITLE ??
?? TITLE := '  [XDCL] BAP$MARK_FAP_LAYER_OPEN' ??
?? NEWTITLE := '  RING BRACKETS 23D' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] bap$mark_fap_layer_open
    (    file_identifier: amt$file_identifier;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    CONST
      interface_name = 'BAP$MARK_FAP_LAYER_OPEN';

    VAR
      file_is_valid: boolean,
      file_instance: ^bat$task_file_entry;

    status.normal := TRUE;

    bap$validate_file_identifier (file_identifier, file_instance,
          file_is_valid);

    IF file_is_valid THEN
      IF layer_number = 0 THEN
        file_instance^.fap_control_information.first_fap.layer_closed := FALSE;
        IF file_instance^.fap_control_information.fap_array <> NIL THEN
          file_instance^.fap_control_information.fap_array^ [layer_number].
                layer_closed := FALSE;
        IFEND;
      ELSEIF (file_instance^.fap_control_information.fap_array <> NIL) AND
            (layer_number <= UPPERBOUND (file_instance^.fap_control_information.
            fap_array^)) THEN
        file_instance^.fap_control_information.fap_array^ [layer_number].
              layer_closed := FALSE;
      ELSE
        osp$set_status_abnormal (amc$access_method_id,
              ame$improper_layer_number, interface_name, status);
      IFEND;
    ELSE
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
    IFEND;

  PROCEND bap$mark_fap_layer_open;
MODEND bam$mark_fap_layer_status;
*DECK DECK=BAM$MERGE_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Basic Access Method : Attribute Merging Procedures' ??

MODULE bam$merge_attributes;

{
{ PURPOSE:
{   This module contains the routines used to merge file attributes.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc amd$file_attributes
*copyc amd$open_declarations
*copyc ame$attribute_validation_errors
*copyc amt$file_attributes
*copyc bat$descriptive_file_attributes
*copyc bat$dynamic_label_attributes
*copyc bat$static_label_attributes
*copyc fsc$local
*copyc fst$open_position
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*copyc clp$convert_integer_to_string
*copyc fsp$dtm_structure_from_contents
*copyc fsp$path_element
*copyc fsp$set_evaluated_file_abnormal
*copyc osp$append_status_parameter

*copyc fmv$system_file_attributes
*copyc fsv$evaluated_file_reference
*copyc osv$lower_to_upper

  CONST
    parameter_name = 'FILE_ATTRIBUTES';

?? TITLE := '[XDCL] bap$merge_dynamic_attr_source', EJECT ??

  PROCEDURE [XDCL] bap$merge_dynamic_attr_source
    (    evaluated_file_reference: fst$evaluated_file_reference;
         attributes: ^amt$file_attributes;
         source: amc$file_command .. amc$file_request;
     VAR dynamic_label {input, output} : bat$dynamic_label_attributes;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      translated_name: amt$local_file_name,
      i_string: ost$string,
      i: integer;

    status.normal := TRUE;
    FOR i := 1 TO UPPERBOUND (attributes^) DO
      CASE attributes^ [i].key OF
      = amc$access_mode =
        IF (dynamic_label.access_mode_source = amc$undefined_attribute) OR
              (source <= dynamic_label.access_mode_source) THEN
          dynamic_label.access_mode := attributes^ [i].access_mode;
          dynamic_label.access_mode_source := source;
        IFEND;
      = amc$error_exit_name =
        IF (dynamic_label.error_exit_name_source = amc$undefined_attribute) OR
              (source <= dynamic_label.error_exit_name_source) THEN
          #TRANSLATE (osv$lower_to_upper, attributes^ [i].error_exit_name, translated_name);
          dynamic_label.error_exit_name := translated_name;
          IF dynamic_label.error_exit_name = osc$null_name THEN
            dynamic_label.error_exit_name_source := amc$undefined_attribute;
          ELSE
            dynamic_label.error_exit_name_source := source;
          IFEND;
        IFEND;
      = amc$error_options =
        IF (dynamic_label.error_options_source = amc$undefined_attribute) OR
              (source <= dynamic_label.error_options_source) THEN
          dynamic_label.error_options := attributes^ [i].error_options;
          dynamic_label.error_options_source := source;
        IFEND;
      = amc$label_exit_name =
        IF (dynamic_label.label_exit_name_source = amc$undefined_attribute) OR
              (source <= dynamic_label.label_exit_name_source) THEN
          #TRANSLATE (osv$lower_to_upper, attributes^ [i].label_exit_name, translated_name);
          dynamic_label.label_exit_name := translated_name;
          IF dynamic_label.label_exit_name = osc$null_name THEN
            dynamic_label.label_exit_name_source := amc$undefined_attribute;
          ELSE
            dynamic_label.label_exit_name_source := source;
          IFEND;
        IFEND;
      = amc$label_options =
        IF (dynamic_label.label_options_source = amc$undefined_attribute) OR
              (source <= dynamic_label.label_options_source) THEN
          dynamic_label.label_options := attributes^ [i].label_options;
          dynamic_label.label_options_source := source;
        IFEND;
      = amc$open_position =
        IF (dynamic_label.open_position_source = amc$undefined_attribute) OR
              (source <= dynamic_label.open_position_source) THEN
          dynamic_label.open_position := attributes^ [i].open_position;
          dynamic_label.open_position_source := source;
        IFEND;
      = amc$return_option =
        IF (dynamic_label.return_option_source = amc$undefined_attribute) OR
              (source <= dynamic_label.return_option_source) THEN
          dynamic_label.return_option := attributes^ [i].return_option;
          dynamic_label.return_option_source := source;
        IFEND;

        { aam }

      = amc$error_limit =
        IF (dynamic_label.error_limit_source = amc$undefined_attribute) OR
              (source <= dynamic_label.error_limit_source) THEN
          dynamic_label.error_limit := attributes^ [i].error_limit;
          dynamic_label.error_limit_source := source;
        IFEND;
      = amc$message_control =
        IF (dynamic_label.message_control_source = amc$undefined_attribute) OR
              (source <= dynamic_label.message_control_source) THEN
          dynamic_label.message_control := attributes^ [i].message_control;
          dynamic_label.message_control_source := source;
        IFEND;
      ELSE
        clp$convert_integer_to_string (i, 10, FALSE, i_string, ignore_status);
        IF status.normal THEN
          fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_file_attrib_key,
                amc$get_file_attributes_req, parameter_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, i_string.value (1, i_string.size),
                status);
        ELSE
          osp$append_status_parameter (',', i_string.value (1, i_string.size), status);
        IFEND;
      CASEND;
    FOREND;

  PROCEND bap$merge_dynamic_attr_source;
?? TITLE := '[XDCL, #GATE] bap$merge_static_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$merge_static_attributes
    (    evaluated_file_reference: fst$evaluated_file_reference;
         attributes: ^amt$file_attributes;
     VAR static_label {input, output} : bat$static_label_attributes;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      translated_name: ost$name,
      i_string: ost$string,
      i: integer;

    status.normal := TRUE;
    IF attributes = NIL THEN
      RETURN;
    IFEND;

    FOR i := 1 TO UPPERBOUND (attributes^) DO
      CASE attributes^ [i].key OF
      = amc$block_type =
        IF (static_label.block_type_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.block_type_source) THEN
          static_label.block_type := attributes^ [i].block_type;
          static_label.block_type_source := amc$file_request;
        IFEND;
      = amc$character_conversion =
        IF (static_label.character_conversion_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.character_conversion_source) THEN
          static_label.character_conversion := attributes^ [i].character_conversion;
          static_label.character_conversion_source := amc$file_request;
        IFEND;
      = amc$clear_space =
        IF (static_label.clear_space_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.clear_space_source) THEN
          static_label.clear_space := attributes^ [i].clear_space;
          static_label.clear_space_source := amc$file_request;
        IFEND;
      = amc$file_access_procedure =
        IF (static_label.file_access_procedure_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.file_access_procedure_source) THEN
          #TRANSLATE (osv$lower_to_upper, attributes^ [i].file_access_procedure, translated_name);
          static_label.file_access_procedure := translated_name;
          static_label.file_access_procedure_source := amc$file_request;
        IFEND;
      = amc$file_contents =
        IF ((amc$file_request <= static_label.file_contents_source) OR
              (static_label.file_contents_source = amc$undefined_attribute)) AND
              ((amc$file_request <= static_label.file_structure_source) OR
              (static_label.file_structure_source = amc$undefined_attribute)) THEN
          #TRANSLATE (osv$lower_to_upper, attributes^ [i].file_contents, translated_name);
          static_label.file_contents := translated_name;
          static_label.file_contents_source := amc$file_request;
        IFEND;
      = amc$file_limit =
        IF (static_label.file_limit_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.file_limit_source) THEN
          static_label.file_limit := attributes^ [i].file_limit;
          static_label.file_limit_source := amc$file_request;
        IFEND;
      = amc$file_organization =
        IF (static_label.file_organization_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.file_organization_source) THEN
          static_label.file_organization := attributes^ [i].file_organization;
          static_label.file_organization_source := amc$file_request;
        IFEND;
      = amc$file_processor =
        IF (static_label.file_processor_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.file_processor_source) THEN
          #TRANSLATE (osv$lower_to_upper, attributes^ [i].file_processor, translated_name);
          static_label.file_processor := translated_name;
          static_label.file_processor_source := amc$file_request;
        IFEND;
      = amc$file_structure =
        IF ((amc$file_request <= static_label.file_contents_source) OR
              (static_label.file_contents_source = amc$undefined_attribute)) AND
              ((amc$file_request <= static_label.file_structure_source) OR
              (static_label.file_structure_source = amc$undefined_attribute)) THEN
          #TRANSLATE (osv$lower_to_upper, attributes^ [i].file_structure, translated_name);
          static_label.file_structure := translated_name;
          static_label.file_structure_source := amc$file_request;
        IFEND;
      = amc$forced_write =
        IF (static_label.forced_write_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.forced_write_source) THEN
          static_label.forced_write := attributes^ [i].forced_write;
          static_label.forced_write_source := amc$file_request;
        IFEND;
      = amc$internal_code =
        IF (static_label.internal_code_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.internal_code_source) THEN
          static_label.internal_code := attributes^ [i].internal_code;
          static_label.internal_code_source := amc$file_request;
        IFEND;
      = amc$label_type =
        IF (static_label.label_type_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.label_type_source) THEN
          static_label.label_type := attributes^ [i].label_type;
          static_label.label_type_source := amc$file_request;
        IFEND;
      = amc$line_number =
        IF (static_label.line_number_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.line_number_source) THEN
          static_label.line_number := attributes^ [i].line_number;
          static_label.line_number_source := amc$file_request;
        IFEND;
      = amc$max_block_length =
        IF (static_label.max_block_length_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.max_block_length_source) THEN
          static_label.max_block_length := attributes^ [i].max_block_length;
          static_label.max_block_length_source := amc$file_request;
        IFEND;
      = amc$max_record_length =
        IF (static_label.max_record_length_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.max_record_length_source) THEN
          static_label.max_record_length := attributes^ [i].max_record_length;
          static_label.max_record_length_source := amc$file_request;
        IFEND;
      = amc$min_block_length =
        IF (static_label.min_block_length_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.min_block_length_source) THEN
          static_label.min_block_length := attributes^ [i].min_block_length;
          static_label.min_block_length_source := amc$file_request;
        IFEND;
      = amc$min_record_length =
        IF (static_label.min_record_length_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.min_record_length_source) THEN
          static_label.min_record_length := attributes^ [i].min_record_length;
          static_label.min_record_length_source := amc$file_request;
        IFEND;
      = amc$padding_character =
        IF (static_label.padding_character_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.padding_character_source) THEN
          static_label.padding_character := attributes^ [i].padding_character;
          static_label.padding_character_source := amc$file_request;
        IFEND;
      = amc$page_format =
        IF (static_label.page_format_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.page_format_source) THEN
          static_label.page_format := attributes^ [i].page_format;
          static_label.page_format_source := amc$file_request;
        IFEND;
      = amc$page_length =
        IF (static_label.page_length_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.page_length_source) THEN
          static_label.page_length := attributes^ [i].page_length;
          static_label.page_length_source := amc$file_request;
        IFEND;
      = amc$page_width =
        IF (static_label.page_width_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.page_width_source) THEN
          static_label.page_width := attributes^ [i].page_width;
          static_label.page_width_source := amc$file_request;
        IFEND;
      = amc$preset_value =
        IF (static_label.preset_value_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.preset_value_source) THEN
          static_label.preset_value := attributes^ [i].preset_value;
          static_label.preset_value_source := amc$file_request;
        IFEND;
      = amc$record_type =
        IF (static_label.record_type_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.record_type_source) THEN
          static_label.record_type := attributes^ [i].record_type;
          static_label.record_type_source := amc$file_request;
        IFEND;
      = amc$ring_attributes =
        IF (static_label.ring_attributes_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.ring_attributes_source) THEN
          static_label.ring_attributes := attributes^ [i].ring_attributes;
          static_label.ring_attributes_source := amc$file_request;
        IFEND;
      = amc$statement_identifier =
        IF (static_label.statement_identifier_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.statement_identifier_source) THEN
          static_label.statement_identifier := attributes^ [i].statement_identifier;
          static_label.statement_identifier_source := amc$file_request;
        IFEND;
      = amc$user_info =
        IF (static_label.user_info_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.user_info_source) THEN
          static_label.user_info := attributes^ [i].user_info;
          static_label.user_info_source := amc$file_request;
        IFEND;
      = amc$vertical_print_density =
        IF (static_label.vertical_print_density_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.vertical_print_density_source) THEN
          static_label.vertical_print_density := attributes^ [i].vertical_print_density;
          static_label.vertical_print_density_source := amc$file_request;
        IFEND;

        { aam }

      = amc$average_record_length =
        IF (static_label.average_record_length_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.average_record_length_source) THEN
          static_label.average_record_length := attributes^ [i].average_record_length;
          static_label.average_record_length_source := amc$file_request;
        IFEND;
      = amc$collate_table_name =
        IF (static_label.collate_table_name_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.collate_table_name_source) THEN
          #TRANSLATE (osv$lower_to_upper, attributes^ [i].collate_table_name, translated_name);
          static_label.collate_table_name := translated_name;
          IF static_label.collate_table_name = osc$null_name THEN
            static_label.collate_table_name_source := amc$undefined_attribute;
          ELSE
            static_label.collate_table_name_source := amc$file_request;
          IFEND;
        IFEND;
      = amc$compression_procedure_name =
        IF (static_label.compression_proc_name_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.compression_proc_name_source) THEN
          IF attributes^ [i].compression_procedure_name <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, attributes^ [i].compression_procedure_name^.name,
                  translated_name);
            static_label.compression_procedure_name.name := translated_name;
            static_label.compression_procedure_name.object_library :=
                  attributes^ [i].compression_procedure_name^.object_library;
            IF static_label.compression_procedure_name.name = osc$null_name THEN
              static_label.compression_proc_name_source := amc$undefined_attribute;
            ELSE
              static_label.compression_proc_name_source := amc$file_request;
            IFEND;
          IFEND;
        IFEND;
      = amc$data_padding =
        IF (static_label.data_padding_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.data_padding_source) THEN
          static_label.data_padding := attributes^ [i].data_padding;
          static_label.data_padding_source := amc$file_request;
        IFEND;
      = amc$dynamic_home_block_space =
        IF (static_label.dynamic_home_block_space_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.dynamic_home_block_space_source) THEN
          static_label.dynamic_home_block_space := attributes^ [i].dynamic_home_block_space;
          static_label.dynamic_home_block_space_source := amc$file_request;
        IFEND;
      = amc$embedded_key =
        IF (static_label.embedded_key_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.embedded_key_source) THEN
          static_label.embedded_key := attributes^ [i].embedded_key;
          static_label.embedded_key_source := amc$file_request;
        IFEND;
      = amc$estimated_record_count =
        IF (static_label.estimated_record_count_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.estimated_record_count_source) THEN
          static_label.estimated_record_count := attributes^ [i].estimated_record_count;
          static_label.estimated_record_count_source := amc$file_request;
        IFEND;
      = amc$hashing_procedure_name =
        IF (static_label.hashing_procedure_name_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.hashing_procedure_name_source) THEN
          IF attributes^ [i].hashing_procedure_name <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, attributes^ [i].hashing_procedure_name^.name, translated_name);
            static_label.hashing_procedure_name.name := translated_name;
            static_label.hashing_procedure_name.object_library :=
                  attributes^ [i].hashing_procedure_name^.object_library;
            IF static_label.hashing_procedure_name.name = osc$null_name THEN
              static_label.hashing_procedure_name_source := amc$undefined_attribute;
            ELSE
              static_label.hashing_procedure_name_source := amc$file_request;
            IFEND;
          IFEND;
        IFEND;
      = amc$index_levels =
        IF (static_label.index_levels_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.index_levels_source) THEN
          static_label.index_levels := attributes^ [i].index_levels;
          static_label.index_levels_source := amc$file_request;
        IFEND;
      = amc$index_padding =
        IF (static_label.index_padding_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.index_padding_source) THEN
          static_label.index_padding := attributes^ [i].index_padding;
          static_label.index_padding_source := amc$file_request;
        IFEND;
      = amc$initial_home_block_count =
        IF (static_label.initial_home_block_count_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.initial_home_block_count_source) THEN
          static_label.initial_home_block_count := attributes^ [i].initial_home_block_count;
          static_label.initial_home_block_count_source := amc$file_request;
        IFEND;
      = amc$key_length =
        IF (static_label.key_length_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.key_length_source) THEN
          static_label.key_length := attributes^ [i].key_length;
          static_label.key_length_source := amc$file_request;
        IFEND;
      = amc$key_position =
        IF (static_label.key_position_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.key_position_source) THEN
          static_label.key_position := attributes^ [i].key_position;
          static_label.key_position_source := amc$file_request;
        IFEND;
      = amc$key_type =
        IF (static_label.key_type_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.key_type_source) THEN
          static_label.key_type := attributes^ [i].key_type;
          static_label.key_type_source := amc$file_request;
        IFEND;
      = amc$loading_factor =
        IF (static_label.loading_factor_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.loading_factor_source) THEN
          static_label.loading_factor := attributes^ [i].loading_factor;
          static_label.loading_factor_source := amc$file_request;
        IFEND;
      = amc$lock_expiration_time =
        IF (static_label.lock_expiration_time_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.lock_expiration_time_source) THEN
          static_label.lock_expiration_time := attributes^ [i].lock_expiration_time;
          static_label.lock_expiration_time_source := amc$file_request;
        IFEND;
      = amc$logging_options =
        IF (static_label.logging_options_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.logging_options_source) THEN
          static_label.logging_options := attributes^ [i].logging_options;
          static_label.logging_options_source := amc$file_request;
        IFEND;
      = amc$log_residence =
        IF (static_label.log_residence_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.log_residence_source) THEN
          IF attributes^ [i].log_residence <> NIL THEN
            static_label.log_residence := attributes^ [i].log_residence^;
            IF static_label.log_residence = osc$null_name THEN
              static_label.log_residence_source := amc$undefined_attribute;
            ELSE
              static_label.log_residence_source := amc$file_request;
            IFEND;
          IFEND;
        IFEND;
      = amc$record_limit =
        IF (static_label.record_limit_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.record_limit_source) THEN
          static_label.record_limit := attributes^ [i].record_limit;
          static_label.record_limit_source := amc$file_request;
        IFEND;
      = amc$records_per_block =
        IF (static_label.records_per_block_source = amc$undefined_attribute) OR
              (amc$file_request <= static_label.records_per_block_source) THEN
          static_label.records_per_block := attributes^ [i].records_per_block;
          static_label.records_per_block_source := amc$file_request;
        IFEND;
      ELSE
      CASEND;
    FOREND;

    IF static_label.page_length_source = amc$access_method_default THEN
      IF static_label.vertical_print_density_source <> amc$access_method_default THEN
        static_label.page_length := static_label.vertical_print_density * 10;
      IFEND;
    IFEND;

    {The following code insures that file_contents and file_structure have}
    { sources with equivalent precedence.}
    IF (static_label.file_contents_source <> static_label.file_structure_source) THEN
      IF ((static_label.file_structure_source < static_label.file_contents_source) AND
            (static_label.file_structure_source <> amc$undefined_attribute)) OR
            (static_label.file_contents_source = amc$undefined_attribute) THEN
        static_label.file_contents := 'UNKNOWN';
        static_label.file_contents_source := static_label.file_structure_source;
      ELSE
        fsp$dtm_structure_from_contents (static_label.file_contents, static_label.file_structure);
        static_label.file_structure_source := static_label.file_contents_source;
      IFEND;
    IFEND;

  PROCEND bap$merge_static_attributes;

MODEND bam$merge_attributes;
*DECK DECK=BAM$MERGE_OPEN_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Basic Access Method : Attribute Merging Procedure' ??

MODULE bam$merge_open_attributes;

{
{ PURPOSE:
{   This module contains the routine used to merge file attributes.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc amd$file_attributes
*copyc ame$attribute_validation_errors
*copyc amt$access_level
*copyc bat$static_label_attributes
*copyc cld$path_description
*copyc clp$convert_integer_to_string
*copyc fsp$convert_to_old_contents
*copyc fst$file_cycle_attributes
*copyc fst$status_reporting_procedure
*copyc osp$append_status_parameter
*copyc oss$job_paged_literal
*copyc osv$lower_to_upper
?? POP ??
?? TITLE := '[XDCL] bap$merge_open_attributes', EJECT ??

  VAR
    space: [STATIC, READ, oss$job_paged_literal] packed array [0 .. 255] of
          boolean := [REP 32 of FALSE, TRUE, REP 223 of FALSE],
    underscore: [STATIC, READ, oss$job_paged_literal] packed array [0 .. 255] of
          boolean := [REP 95 of FALSE, TRUE, REP 160 of FALSE];

  PROCEDURE [XDCL] bap$merge_open_attributes
    (    attributes: ^fst$file_cycle_attributes;
         source: amc$open_request .. amc$file_request;
     VAR static_label {input, output} : bat$static_label_attributes;
         status_reporting_procedure_ptr: fst$status_reporting_procedure;
     VAR status: ost$status);

    VAR
      i: integer,
      i_string: ost$string,
      ignore_status: ost$status,
      status_text: string (28),
      translated_name: amt$local_file_name;

    status.normal := TRUE;
    IF source = amc$file_request THEN
      status_text := 'DEFAULT_CREATION_ATTRIBUTES';
    ELSE
      status_text := 'MANDATED_CREATION_ATTRIBUTES';
    IFEND;
    FOR i := UPPERBOUND (attributes^) DOWNTO 1 DO
      CASE attributes^ [i].selector OF
      = fsc$average_record_length =
        IF (static_label.average_record_length_source = amc$undefined_attribute) OR
              (source < static_label.average_record_length_source) THEN
          static_label.average_record_length := attributes^ [i].average_record_length;
          static_label.average_record_length_source := amc$open_request;
        IFEND;
      = fsc$block_type =
        IF (static_label.block_type_source = amc$undefined_attribute) OR
              (source < static_label.block_type_source) THEN
          static_label.block_type := attributes^ [i].block_type;
          static_label.block_type_source := amc$open_request;
        IFEND;
      = fsc$character_conversion =
        IF (static_label.character_conversion_source = amc$undefined_attribute) OR
              (source < static_label.character_conversion_source) THEN
          static_label.character_conversion := attributes^ [i].character_conversion;
          static_label.character_conversion_source := amc$open_request;
        IFEND;
      = fsc$collate_table_name =
        IF (static_label.collate_table_name_source = amc$undefined_attribute) OR
              (source < static_label.collate_table_name_source) THEN
          IF attributes^ [i].collate_table_name <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, attributes^ [i].collate_table_name^.entry_point, translated_name);
            static_label.collate_table_name := translated_name;
            static_label.collate_table_name_source := amc$open_request;
          IFEND;
        IFEND;
      = fsc$compression_procedure_name =
        IF (static_label.compression_proc_name_source = amc$undefined_attribute) OR
              (source < static_label.compression_proc_name_source) THEN
          IF attributes^ [i].compression_procedure_name <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, attributes^ [i].compression_procedure_name^.name,
                  translated_name);
            static_label.compression_procedure_name.name := translated_name;
            static_label.compression_procedure_name.object_library :=
                  attributes^ [i].compression_procedure_name^.object_library;
            IF static_label.compression_procedure_name.name = osc$null_name THEN
              static_label.compression_proc_name_source := amc$undefined_attribute;
            ELSE
              static_label.compression_proc_name_source := amc$open_request;
            IFEND;
          IFEND;
        IFEND;
      = fsc$data_padding =
        IF (static_label.data_padding_source = amc$undefined_attribute) OR
              (source < static_label.data_padding_source) THEN
          static_label.data_padding := attributes^ [i].data_padding;
          static_label.data_padding_source := amc$open_request;
        IFEND;
      = fsc$dynamic_home_block_space =
        IF (static_label.dynamic_home_block_space_source = amc$undefined_attribute) OR
              (source < static_label.dynamic_home_block_space_source) THEN
          static_label.dynamic_home_block_space := attributes^ [i].dynamic_home_block_space;
          static_label.dynamic_home_block_space_source := amc$open_request;
        IFEND;
      = fsc$embedded_key =
        IF (static_label.embedded_key_source = amc$undefined_attribute) OR
              (source < static_label.embedded_key_source) THEN
          static_label.embedded_key := attributes^ [i].embedded_key;
          static_label.embedded_key_source := amc$open_request;
        IFEND;
      = fsc$erase_at_deletion =
        IF (static_label.clear_space_source = amc$undefined_attribute) OR
              (source < static_label.clear_space_source) THEN
          static_label.clear_space := attributes^ [i].erase_at_deletion;
          static_label.clear_space_source := amc$open_request;
        IFEND;
      = fsc$estimated_record_count =
        IF (static_label.estimated_record_count_source = amc$undefined_attribute) OR
              (source < static_label.estimated_record_count_source) THEN
          static_label.estimated_record_count := attributes^ [i].estimated_record_count;
          static_label.estimated_record_count_source := amc$open_request;
        IFEND;
      = fsc$file_access_procedure_name =
        IF (static_label.file_access_procedure_source = amc$undefined_attribute) OR
              (source < static_label.file_access_procedure_source) THEN
          IF attributes^ [i].file_access_procedure_name <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, attributes^ [i].file_access_procedure_name^.entry_point,
                  translated_name);
            static_label.file_access_procedure := translated_name;
            static_label.file_access_procedure_source := amc$open_request;
          IFEND;
        IFEND;
      = fsc$file_contents_and_processor =
        IF ((source < static_label.file_contents_source) OR
              (static_label.file_contents_source = amc$undefined_attribute)) AND
              ((source < static_label.file_structure_source) OR
              (static_label.file_structure_source = amc$undefined_attribute)) THEN
          IF attributes^ [i].file_contents <> osc$null_name THEN
            #TRANSLATE (osv$lower_to_upper, attributes^ [i].file_contents, translated_name);
            fsp$convert_to_old_contents (translated_name, static_label.file_contents,
                  static_label.file_structure);
            static_label.file_contents_source := amc$open_request;
            static_label.file_structure_source := amc$open_request;
          IFEND;
        IFEND;
        IF (static_label.file_processor_source = amc$undefined_attribute) OR
              (source < static_label.file_processor_source) THEN
          IF attributes^ [i].file_processor <> osc$null_name THEN
            #TRANSLATE (osv$lower_to_upper, attributes^ [i].file_processor, translated_name);
            static_label.file_processor := translated_name;
            static_label.file_processor_source := amc$open_request;
          IFEND;
        IFEND;
      = fsc$file_label_type =
        IF (static_label.label_type_source = amc$undefined_attribute) OR
              (source < static_label.label_type_source) THEN
          static_label.label_type := attributes^ [i].file_label_type;
          static_label.label_type_source := amc$open_request;
        IFEND;
      = fsc$file_limit =
        IF (static_label.file_limit_source = amc$undefined_attribute) OR
              (source < static_label.file_limit_source) THEN
          static_label.file_limit := attributes^ [i].file_limit;
          static_label.file_limit_source := amc$open_request;
        IFEND;
      = fsc$file_organization =
        IF (static_label.file_organization_source = amc$undefined_attribute) OR
              (source < static_label.file_organization_source) THEN
          static_label.file_organization := attributes^ [i].file_organization;
          static_label.file_organization_source := amc$open_request;
        IFEND;
      = fsc$forced_write =
        IF (static_label.forced_write_source = amc$undefined_attribute) OR
              (source < static_label.forced_write_source) THEN
          static_label.forced_write := attributes^ [i].forced_write;
          static_label.forced_write_source := amc$open_request;
        IFEND;
      = fsc$hashing_procedure_name =
        IF (static_label.hashing_procedure_name_source = amc$undefined_attribute) OR
              (source < static_label.hashing_procedure_name_source) THEN
          IF attributes^ [i].hashing_procedure_name <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, attributes^ [i].hashing_procedure_name^.name, translated_name);
            static_label.hashing_procedure_name.name := translated_name;
            static_label.hashing_procedure_name.object_library :=
                  attributes^ [i].hashing_procedure_name^.object_library;
            IF static_label.hashing_procedure_name.name = osc$null_name THEN
              static_label.hashing_procedure_name_source := amc$undefined_attribute;
            ELSE
              static_label.hashing_procedure_name_source := amc$open_request;
            IFEND;
          IFEND;
        IFEND;
      = fsc$index_levels =
        IF (static_label.index_levels_source = amc$undefined_attribute) OR
              (source < static_label.index_levels_source) THEN
          static_label.index_levels := attributes^ [i].index_levels;
          static_label.index_levels_source := amc$open_request;
        IFEND;
      = fsc$index_padding =
        IF (static_label.index_padding_source = amc$undefined_attribute) OR
              (source < static_label.index_padding_source) THEN
          static_label.index_padding := attributes^ [i].index_padding;
          static_label.index_padding_source := amc$open_request;
        IFEND;
      = fsc$initial_home_block_count =
        IF (static_label.initial_home_block_count_source = amc$undefined_attribute) OR
              (source < static_label.initial_home_block_count_source) THEN
          static_label.initial_home_block_count := attributes^ [i].initial_home_block_count;
          static_label.initial_home_block_count_source := amc$open_request;
        IFEND;
      = fsc$internal_code =
        IF (static_label.internal_code_source = amc$undefined_attribute) OR
              (source < static_label.internal_code_source) THEN
          static_label.internal_code := attributes^ [i].internal_code;
          static_label.internal_code_source := amc$open_request;
        IFEND;
      = fsc$key_length =
        IF (static_label.key_length_source = amc$undefined_attribute) OR
              (source < static_label.key_length_source) THEN
          static_label.key_length := attributes^ [i].key_length;
          static_label.key_length_source := amc$open_request;
        IFEND;
      = fsc$key_position =
        IF (static_label.key_position_source = amc$undefined_attribute) OR
              (source < static_label.key_position_source) THEN
          static_label.key_position := attributes^ [i].key_position;
          static_label.key_position_source := amc$open_request;
        IFEND;
      = fsc$key_type =
        IF (static_label.key_type_source = amc$undefined_attribute) OR
              (source < static_label.key_type_source) THEN
          static_label.key_type := attributes^ [i].key_type;
          static_label.key_type_source := amc$open_request;
        IFEND;
      = fsc$line_number =
        IF (static_label.line_number_source = amc$undefined_attribute) OR
              (source < static_label.line_number_source) THEN
          static_label.line_number := attributes^ [i].line_number;
          static_label.line_number_source := amc$open_request;
        IFEND;
      = fsc$loading_factor =
        IF (static_label.loading_factor_source = amc$undefined_attribute) OR
              (source < static_label.loading_factor_source) THEN
          static_label.loading_factor := attributes^ [i].loading_factor;
          static_label.loading_factor_source := amc$open_request;
        IFEND;
      = fsc$lock_expiration_time =
        IF (static_label.lock_expiration_time_source = amc$undefined_attribute) OR
              (source < static_label.lock_expiration_time_source) THEN
          static_label.lock_expiration_time := attributes^ [i].lock_expiration_time;
          static_label.lock_expiration_time_source := amc$open_request;
        IFEND;
      = fsc$log_residence =
        IF (static_label.log_residence_source = amc$undefined_attribute) OR
              (source < static_label.log_residence_source) THEN
          IF attributes^ [i].log_residence <> NIL THEN
            static_label.log_residence := attributes^ [i].log_residence^;
            IF static_label.log_residence = osc$null_name THEN
              static_label.log_residence_source := amc$undefined_attribute;
            ELSE
              static_label.log_residence_source := amc$open_request;
            IFEND;
          IFEND;
        IFEND;
      = fsc$logging_options =
        IF (static_label.logging_options_source = amc$undefined_attribute) OR
              (source < static_label.logging_options_source) THEN
          static_label.logging_options := attributes^ [i].logging_options;
          static_label.logging_options_source := amc$open_request;
        IFEND;
      = fsc$max_block_length =
        IF (static_label.max_block_length_source = amc$undefined_attribute) OR
              (source < static_label.max_block_length_source) THEN
          static_label.max_block_length := attributes^ [i].max_block_length;
          static_label.max_block_length_source := amc$open_request;
        IFEND;
      = fsc$max_record_length =
        IF (static_label.max_record_length_source = amc$undefined_attribute) OR
              (source < static_label.max_record_length_source) THEN
          static_label.max_record_length := attributes^ [i].max_record_length;
          static_label.max_record_length_source := amc$open_request;
        IFEND;
      = fsc$min_block_length =
        IF (static_label.min_block_length_source = amc$undefined_attribute) OR
              (source < static_label.min_block_length_source) THEN
          static_label.min_block_length := attributes^ [i].min_block_length;
          static_label.min_block_length_source := amc$open_request;
        IFEND;
      = fsc$min_record_length =
        IF (static_label.min_record_length_source = amc$undefined_attribute) OR
              (source < static_label.min_record_length_source) THEN
          static_label.min_record_length := attributes^ [i].min_record_length;
          static_label.min_record_length_source := amc$open_request;
        IFEND;
      = fsc$null_attribute =
        ;
      = fsc$padding_character =
        IF (static_label.padding_character_source = amc$undefined_attribute) OR
              (source < static_label.padding_character_source) THEN
          static_label.padding_character := attributes^ [i].padding_character;
          static_label.padding_character_source := amc$open_request;
        IFEND;
      = fsc$page_format =
        IF (static_label.page_format_source = amc$undefined_attribute) OR
              (source < static_label.page_format_source) THEN
          static_label.page_format := attributes^ [i].page_format;
          static_label.page_format_source := amc$open_request;
        IFEND;
      = fsc$page_length =
        IF (static_label.page_length_source = amc$undefined_attribute) OR
              (source < static_label.page_length_source) THEN
          static_label.page_length := attributes^ [i].page_length;
          static_label.page_length_source := amc$open_request;
        IFEND;
      = fsc$page_width =
        IF (static_label.page_width_source = amc$undefined_attribute) OR
              (source < static_label.page_width_source) THEN
          static_label.page_width := attributes^ [i].page_width;
          static_label.page_width_source := amc$open_request;
        IFEND;
      = fsc$preset_value =
        IF (static_label.preset_value_source = amc$undefined_attribute) OR
              (source < static_label.preset_value_source) THEN
          static_label.preset_value := attributes^ [i].preset_value;
          static_label.preset_value_source := amc$open_request;
        IFEND;
      = fsc$record_delimiting_character =
        IF (static_label.record_delimiting_char_source = amc$undefined_attribute) OR
              (source < static_label.record_delimiting_char_source) THEN
          static_label.record_delimiting_character := attributes^ [i].record_delimiting_character;
          static_label.record_delimiting_char_source := amc$open_request;
        IFEND;
      = fsc$record_limit =
        IF (static_label.record_limit_source = amc$undefined_attribute) OR
              (source < static_label.record_limit_source) THEN
          static_label.record_limit := attributes^ [i].record_limit;
          static_label.record_limit_source := amc$open_request;
        IFEND;
      = fsc$record_type =
        IF (static_label.record_type_source = amc$undefined_attribute) OR
              (source < static_label.record_type_source) THEN
          static_label.record_type := attributes^ [i].record_type;
          static_label.record_type_source := amc$open_request;
        IFEND;
      = fsc$records_per_block =
        IF (static_label.records_per_block_source = amc$undefined_attribute) OR
              (source < static_label.records_per_block_source) THEN
          static_label.records_per_block := attributes^ [i].records_per_block;
          static_label.records_per_block_source := amc$open_request;
        IFEND;
      = fsc$retention =
        ;
      = fsc$retrieve_option =
        ;
      = fsc$ring_attributes =
        IF (static_label.ring_attributes_source = amc$undefined_attribute) OR
              (source < static_label.ring_attributes_source) THEN
          static_label.ring_attributes := attributes^ [i].ring_attributes;
          static_label.ring_attributes_source := amc$open_request;
        IFEND;
      = fsc$site_archive_option =
        ;
      = fsc$site_backup_option =
        ;
      = fsc$site_release_option =
        ;
      = fsc$statement_identifier =
        IF (static_label.statement_identifier_source = amc$undefined_attribute) OR
              (source < static_label.statement_identifier_source) THEN
          static_label.statement_identifier := attributes^ [i].statement_identifier;
          static_label.statement_identifier_source := amc$open_request;
        IFEND;
      = fsc$user_attribute =
        ;
      = fsc$user_information =
        IF (static_label.user_info_source = amc$undefined_attribute) OR
              (source < static_label.user_info_source) THEN
          static_label.user_info := attributes^ [i].user_information;
          static_label.user_info_source := amc$open_request;
        IFEND;
      = fsc$vertical_print_density =
        IF (static_label.vertical_print_density_source = amc$undefined_attribute) OR
              (source < static_label.vertical_print_density_source) THEN
          static_label.vertical_print_density := attributes^ [i].vertical_print_density;
          static_label.vertical_print_density_source := amc$open_request;
        IFEND;

      ELSE
        clp$convert_integer_to_string (i, 10, FALSE, i_string, ignore_status);
        IF status.normal THEN
          status_reporting_procedure_ptr^ (ame$improper_file_attrib_key, status_text, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, i_string.value (1, i_string.size),
                status);
        ELSE
          osp$append_status_parameter (',', i_string.value (1, i_string.size), status);
        IFEND;
      CASEND;
    FOREND;

  PROCEND bap$merge_open_attributes;
MODEND bam$merge_open_attributes;
*DECK DECK=BAM$MERGE_TAPE_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Basic Access Method : Tape Attribute Merging' ??

MODULE bam$merge_tape_attributes;

{
{ PURPOSE:
{   This module contains the routine used to merge tape attributes during an
{ open.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc bat$static_label_attributes
*copyc fst$file_cycle_attributes
*copyc fst$tape_attachment_information
*copyc osd$integer_limits
*copyc ost$status
?? POP ??
?? TITLE := '[XDCL] bap$merge_tape_attributes', EJECT ??

  PROCEDURE [XDCL] bap$merge_tape_attributes
    (    default_creation_attributes: ^fst$file_cycle_attributes;
         mandated_creation_attributes: ^fst$file_cycle_attributes;
     VAR merged_tape_attributes: {input, output} fst$tape_attachment_information;
     VAR static_label_attributes: {input, output} bat$static_label_attributes);

?? NEWTITLE := 'merge_mandated_creation_attrib', EJECT ??

    PROCEDURE merge_mandated_creation_attrib;

      VAR
        index: ost$positive_integers;

      FOR index := 1 TO UPPERBOUND (mandated_creation_attributes^) DO
        CASE mandated_creation_attributes^ [index].selector OF
        = fsc$block_type =
          merged_tape_attributes.block_type := mandated_creation_attributes^ [index].block_type;
          merged_tape_attributes.block_type_source := fsc$tape_open_request;
          static_label_attributes.block_type := mandated_creation_attributes^ [index].block_type;
          static_label_attributes.block_type_source := amc$open_request;
        = fsc$character_conversion =
          merged_tape_attributes.character_conversion := mandated_creation_attributes^ [index].
                character_conversion;
          merged_tape_attributes.character_conversion_source := fsc$tape_open_request;
          static_label_attributes.character_conversion := mandated_creation_attributes^ [index].
                character_conversion;
          static_label_attributes.character_conversion_source := amc$open_request;
        = fsc$internal_code =
          merged_tape_attributes.character_set := mandated_creation_attributes^ [index].internal_code;
          merged_tape_attributes.character_set_source := fsc$tape_open_request;
          static_label_attributes.internal_code := mandated_creation_attributes^ [index].internal_code;
          static_label_attributes.internal_code_source := amc$open_request;
        = fsc$max_block_length =
          merged_tape_attributes.max_block_length := mandated_creation_attributes^ [index].max_block_length;
          merged_tape_attributes.max_block_length_source := fsc$tape_open_request;
          static_label_attributes.max_block_length := mandated_creation_attributes^ [index].max_block_length;
          static_label_attributes.max_block_length_source := amc$open_request;
        = fsc$max_record_length =
          merged_tape_attributes.max_record_length := mandated_creation_attributes^ [index].max_record_length;
          merged_tape_attributes.max_record_length_source := fsc$tape_open_request;
          static_label_attributes.max_record_length := mandated_creation_attributes^ [index].
                max_record_length;
          static_label_attributes.max_record_length_source := amc$open_request;
        = fsc$padding_character =
          merged_tape_attributes.padding_character := mandated_creation_attributes^ [index].padding_character;
          merged_tape_attributes.padding_character_source := fsc$tape_open_request;
          static_label_attributes.padding_character := mandated_creation_attributes^ [index].
                padding_character;
          static_label_attributes.padding_character_source := amc$open_request;
        = fsc$record_type =
          merged_tape_attributes.record_type := mandated_creation_attributes^ [index].record_type;
          merged_tape_attributes.record_type_source := fsc$tape_open_request;
          static_label_attributes.record_type := mandated_creation_attributes^ [index].record_type;
          static_label_attributes.record_type_source := amc$open_request;
        ELSE
        CASEND;
      FOREND;
    PROCEND merge_mandated_creation_attrib;

?? TITLE := 'store_tape_attrib_in_static_lbl', EJECT ??

    PROCEDURE store_tape_attrib_in_static_lbl;

      IF (static_label_attributes.block_type_source <> amc$open_request) AND
            ((merged_tape_attributes.block_type_source = fsc$tape_label_attr_command) OR
            (merged_tape_attributes.block_type_source = fsc$tape_open_tape_attachment)) THEN
        static_label_attributes.block_type := merged_tape_attributes.block_type;
        static_label_attributes.block_type_source := amc$open_request;
      IFEND;
      IF (static_label_attributes.character_conversion_source <> amc$open_request) AND
            ((merged_tape_attributes.character_conversion_source = fsc$tape_label_attr_command) OR
            (merged_tape_attributes.character_conversion_source = fsc$tape_open_tape_attachment)) THEN
        static_label_attributes.character_conversion := merged_tape_attributes.character_conversion;
        static_label_attributes.character_conversion_source := amc$open_request;
      IFEND;
      IF (static_label_attributes.internal_code_source <> amc$open_request) AND
            ((merged_tape_attributes.character_set_source = fsc$tape_label_attr_command) OR
            (merged_tape_attributes.character_set_source = fsc$tape_open_tape_attachment)) THEN
        static_label_attributes.internal_code := merged_tape_attributes.character_set;
        static_label_attributes.internal_code_source := amc$open_request;
      IFEND;
      IF (static_label_attributes.max_block_length_source <> amc$open_request) AND
            ((merged_tape_attributes.max_block_length_source = fsc$tape_label_attr_command) OR
            (merged_tape_attributes.max_block_length_source = fsc$tape_open_tape_attachment)) THEN
        static_label_attributes.max_block_length := merged_tape_attributes.max_block_length;
        static_label_attributes.max_block_length_source := amc$open_request;
      IFEND;
      IF (static_label_attributes.max_record_length_source <> amc$open_request) AND
            ((merged_tape_attributes.max_record_length_source = fsc$tape_label_attr_command) OR
            (merged_tape_attributes.max_record_length_source = fsc$tape_open_tape_attachment)) THEN
        static_label_attributes.max_record_length := merged_tape_attributes.max_record_length;
        static_label_attributes.max_record_length_source := amc$open_request;
      IFEND;
      IF (static_label_attributes.padding_character_source <> amc$open_request) AND
            ((merged_tape_attributes.padding_character_source = fsc$tape_label_attr_command) OR
            (merged_tape_attributes.padding_character_source = fsc$tape_open_tape_attachment)) THEN
        static_label_attributes.padding_character := merged_tape_attributes.padding_character;
        static_label_attributes.padding_character_source := amc$open_request;
      IFEND;
      IF (static_label_attributes.record_type_source <> amc$open_request) AND
            ((merged_tape_attributes.record_type_source = fsc$tape_label_attr_command) OR
            (merged_tape_attributes.record_type_source = fsc$tape_open_tape_attachment)) THEN
        static_label_attributes.record_type := merged_tape_attributes.record_type;
        static_label_attributes.record_type_source := amc$open_request;
      IFEND;
    PROCEND store_tape_attrib_in_static_lbl;

?? TITLE := 'store_setfa_in_tape_attributes', EJECT ??

    PROCEDURE store_setfa_in_tape_attributes;

      IF (static_label_attributes.block_type_source = amc$file_command) AND
            (merged_tape_attributes.block_type_source = fsc$tape_label_attr_default) THEN
        merged_tape_attributes.block_type := static_label_attributes.block_type;
        merged_tape_attributes.block_type_source := fsc$tape_file_command;
      IFEND;
      IF (static_label_attributes.character_conversion_source = amc$file_command) AND
            (merged_tape_attributes.character_conversion_source = fsc$tape_label_attr_default) THEN
        merged_tape_attributes.character_conversion := static_label_attributes.character_conversion;
        merged_tape_attributes.character_conversion_source := fsc$tape_file_command;
      IFEND;
      IF (static_label_attributes.internal_code_source = amc$file_command) AND
            (merged_tape_attributes.character_set_source = fsc$tape_label_attr_default) THEN
        merged_tape_attributes.character_set := static_label_attributes.internal_code;
        merged_tape_attributes.character_set_source := fsc$tape_file_command;
      IFEND;
      IF (static_label_attributes.max_block_length_source = amc$file_command) AND
            (merged_tape_attributes.max_block_length_source = fsc$tape_label_attr_default) THEN
        merged_tape_attributes.max_block_length := static_label_attributes.max_block_length;
        merged_tape_attributes.max_block_length_source := fsc$tape_file_command;
      IFEND;
      IF (static_label_attributes.max_record_length_source = amc$file_command) AND
            (merged_tape_attributes.max_record_length_source = fsc$tape_label_attr_default) THEN
        merged_tape_attributes.max_record_length := static_label_attributes.max_record_length;
        merged_tape_attributes.max_record_length_source := fsc$tape_file_command;
      IFEND;
      IF (static_label_attributes.padding_character_source = amc$file_command) AND
            (merged_tape_attributes.padding_character_source = fsc$tape_label_attr_default) THEN
        merged_tape_attributes.padding_character := static_label_attributes.padding_character;
        merged_tape_attributes.padding_character_source := fsc$tape_file_command;
      IFEND;
      IF (static_label_attributes.record_type_source = amc$file_command) AND
            (merged_tape_attributes.record_type_source = fsc$tape_label_attr_default) THEN
        merged_tape_attributes.record_type := static_label_attributes.record_type;
        merged_tape_attributes.record_type_source := fsc$tape_file_command;
      IFEND;
    PROCEND store_setfa_in_tape_attributes;

?? TITLE := 'merge_default_creation_attrib', EJECT ??

    PROCEDURE merge_default_creation_attrib;

      VAR
        index: ost$positive_integers;

      FOR index := 1 TO UPPERBOUND (default_creation_attributes^) DO
        CASE default_creation_attributes^ [index].selector OF
        = fsc$block_type =
          IF (static_label_attributes.block_type_source = amc$undefined_attribute) OR
                (static_label_attributes.block_type_source > amc$file_command) THEN
            merged_tape_attributes.block_type := default_creation_attributes^ [index].block_type;
            merged_tape_attributes.block_type_source := fsc$tape_open_request;
            static_label_attributes.block_type := default_creation_attributes^ [index].block_type;
            static_label_attributes.block_type_source := amc$open_request;
          IFEND;
        = fsc$character_conversion =
          IF (static_label_attributes.character_conversion_source = amc$undefined_attribute) OR
                (static_label_attributes.character_conversion_source > amc$file_command) THEN
            merged_tape_attributes.character_conversion := default_creation_attributes^ [index].
                  character_conversion;
            merged_tape_attributes.character_conversion_source := fsc$tape_open_request;
            static_label_attributes.character_conversion := default_creation_attributes^ [index].
                  character_conversion;
            static_label_attributes.character_conversion_source := amc$open_request;
          IFEND;
        = fsc$internal_code =
          IF (static_label_attributes.internal_code_source = amc$undefined_attribute) OR
                (static_label_attributes.internal_code_source > amc$file_command) THEN
            merged_tape_attributes.character_set := default_creation_attributes^ [index].internal_code;
            merged_tape_attributes.character_set_source := fsc$tape_open_request;
            static_label_attributes.internal_code := default_creation_attributes^ [index].internal_code;
            static_label_attributes.internal_code_source := amc$open_request;
          IFEND;
        = fsc$max_block_length =
          IF (static_label_attributes.max_block_length_source = amc$undefined_attribute) OR
                (static_label_attributes.max_block_length_source > amc$file_command) THEN
            merged_tape_attributes.max_block_length := default_creation_attributes^ [index].max_block_length;
            merged_tape_attributes.max_block_length_source := fsc$tape_open_request;
            static_label_attributes.max_block_length := default_creation_attributes^ [index].max_block_length;
            static_label_attributes.max_block_length_source := amc$open_request;
          IFEND;
        = fsc$max_record_length =
          IF (static_label_attributes.max_record_length_source = amc$undefined_attribute) OR
                (static_label_attributes.max_record_length_source > amc$file_command) THEN
            merged_tape_attributes.max_record_length := default_creation_attributes^ [index].
                  max_record_length;
            merged_tape_attributes.max_record_length_source := fsc$tape_open_request;
            static_label_attributes.max_record_length := default_creation_attributes^ [index].
                  max_record_length;
            static_label_attributes.max_record_length_source := amc$open_request;
          IFEND;
        = fsc$padding_character =
          IF (static_label_attributes.padding_character_source = amc$undefined_attribute) OR
                (static_label_attributes.padding_character_source > amc$file_command) THEN
            merged_tape_attributes.padding_character := default_creation_attributes^ [index].
                  padding_character;
            merged_tape_attributes.padding_character_source := fsc$tape_open_request;
            static_label_attributes.padding_character := default_creation_attributes^ [index].
                  padding_character;
            static_label_attributes.padding_character_source := amc$open_request;
          IFEND;
        = fsc$record_type =
          IF (static_label_attributes.record_type_source = amc$undefined_attribute) OR
                (static_label_attributes.record_type_source > amc$file_command) THEN
            merged_tape_attributes.record_type := default_creation_attributes^ [index].record_type;
            merged_tape_attributes.record_type_source := fsc$tape_open_request;
            static_label_attributes.record_type := default_creation_attributes^ [index].record_type;
            static_label_attributes.record_type_source := amc$open_request;
          IFEND;
        ELSE
        CASEND;
      FOREND;
    PROCEND merge_default_creation_attrib;

?? TITLE := 'default_tape_attr_to_static_lbl', EJECT ??

    PROCEDURE default_tape_attr_to_static_lbl;

      IF merged_tape_attributes.block_type_source = fsc$tape_label_attr_default THEN
        merged_tape_attributes.block_type := static_label_attributes.block_type;
      IFEND;
      IF merged_tape_attributes.character_conversion_source = fsc$tape_label_attr_default THEN
        merged_tape_attributes.character_conversion := static_label_attributes.character_conversion;
      IFEND;
      IF merged_tape_attributes.character_set_source = fsc$tape_label_attr_default THEN
        merged_tape_attributes.character_set := static_label_attributes.internal_code;
      IFEND;
      IF merged_tape_attributes.max_block_length_source = fsc$tape_label_attr_default THEN
        merged_tape_attributes.max_block_length := static_label_attributes.max_block_length;
      IFEND;
      IF merged_tape_attributes.max_record_length_source = fsc$tape_label_attr_default THEN
        merged_tape_attributes.max_record_length := static_label_attributes.max_record_length;
      IFEND;
      IF merged_tape_attributes.padding_character_source = fsc$tape_label_attr_default THEN
        merged_tape_attributes.padding_character := static_label_attributes.padding_character;
      IFEND;
      IF merged_tape_attributes.record_type_source = fsc$tape_label_attr_default THEN
        merged_tape_attributes.record_type := static_label_attributes.record_type;
      IFEND;

    PROCEND default_tape_attr_to_static_lbl;
?? OLDTITLE, EJECT ??

      IF mandated_creation_attributes <> NIL THEN
        merge_mandated_creation_attrib;
      IFEND;

      store_tape_attrib_in_static_lbl;
      store_setfa_in_tape_attributes;

      IF default_creation_attributes <> NIL THEN
        merge_default_creation_attrib;
      IFEND;

      default_tape_attr_to_static_lbl;

    PROCEND bap$merge_tape_attributes;
  MODEND bam$merge_tape_attributes;
*DECK DECK=BAM$NULL_DEVICE EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE bam$null_device;

{ MODULE DECK BAMNUD }
?? TITLE := ' PROCEDURE BAP$NULL_DEVICE ' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$SEGMENT_VALIDATION_ERRORS
*copyc AME$UNIMPLEMENTED_REQUEST
*copyc AMT$FAP_DECLARATIONS
*copyc AMT$FILE_IDENTIFIER
*copyc OST$STATUS
*copyc AME$SKIP_PROGRAM_ACTIONS
*copyc CLP$CONVERT_INTEGER_TO_STRING
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc AME$IMPROPER_FILE_ID
*copyc AMP$ACCESS_METHOD
*copyc AME$FAP_VALIDATION_ERRORS
*copyc OSP$SET_STATUS_ABNORMAL
*copyc BAV$TASK_FILE_TABLE
*copyc AME$GET_PROGRAM_ACTIONS
*copyc BAP$CLOSE
*copyc BAP$STORE
*copyc BAP$FETCH
*copyc BAP$FETCH_ACCESS_INFORMATION
*copyc BAP$VALIDATE_FILE_IDENTIFIER
?? POP ??
?? EJECT ??
*copyc BAH$NULL_DEVICE

  PROCEDURE [XDCL, #GATE] bap$null_device (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    VAR
      count_str: ost$string,
      file_instance: ^bat$task_file_entry,
      file_id_is_valid: boolean;

    bap$validate_file_identifier (file_identifier, file_instance, file_id_is_valid);

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
        'BAP$NULL_DEVICE', status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    CASE call_block.operation OF

    = amc$get_next_req =

      call_block.getn.transfer_count^ := 0;
      call_block.getn.byte_address^ := 0;
      call_block.getn.file_position^ := amc$eoi;
      IF file_instance^.global_file_information^.positioning_info.record_info.
            file_position = amc$eoi THEN
        amp$set_file_instance_abnormal (file_identifier, ame$input_after_eoi,
              call_block.operation, '', status);
      ELSE
        file_instance^.global_file_information^.positioning_info.record_info.
              file_position := amc$eoi;
      IFEND;

    = amc$get_partial_req =

      call_block.getp.record_length^ := 0;
      call_block.getp.transfer_count^ := 0;
      call_block.getp.byte_address^ := 0;
      call_block.getp.file_position^ := amc$eoi;
      IF file_instance^.global_file_information^.positioning_info.record_info.
            file_position = amc$eoi THEN
        amp$set_file_instance_abnormal (file_identifier, ame$input_after_eoi,
              call_block.operation, '', status);
      ELSE
        file_instance^.global_file_information^.positioning_info.record_info.
              file_position := amc$eoi;
      IFEND;

    = amc$get_direct_req =

      call_block.getd.transfer_count^ := 0;
      call_block.getd.file_position^ := amc$eoi;
      IF file_instance^.global_file_information^.positioning_info.record_info.
            file_position = amc$eoi THEN
        amp$set_file_instance_abnormal (file_identifier, ame$input_after_eoi,
              call_block.operation, '', status);
      ELSE
        file_instance^.global_file_information^.positioning_info.record_info.
              file_position := amc$eoi;
      IFEND;

    = amc$get_segment_pointer_req =

      call_block.getsegp.segment_pointer^.kind := call_block.getsegp.
            pointer_kind;

      CASE call_block.getsegp.pointer_kind OF
      = amc$cell_pointer =
        call_block.getsegp.segment_pointer^.cell_pointer := NIL;
      = amc$heap_pointer =
        call_block.getsegp.segment_pointer^.heap_pointer := NIL;
      = amc$sequence_pointer =
        call_block.getsegp.segment_pointer^.sequence_pointer := NIL;
      ELSE
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_pointer_kind, amc$get_segment_pointer_req, ' ',
              status);
      CASEND;

    = amc$put_next_req =

      call_block.putn.byte_address^ := 0;
      file_instance^.global_file_information^.positioning_info.record_info.
            file_position := amc$eor;

    = amc$put_partial_req =

      call_block.putp.byte_address^ := 0;
      CASE call_block.putp.term_option OF
      = amc$start, amc$continue =
        file_instance^.global_file_information^.positioning_info.record_info.
              file_position := amc$mid_record;
      ELSE
        file_instance^.global_file_information^.positioning_info.record_info.
              file_position := amc$eor;
      CASEND;

    = amc$put_direct_req =

      file_instance^.global_file_information^.positioning_info.record_info.
            file_position := amc$eor;

    = amc$skip_req =
      clp$convert_integer_to_string (call_block.skp.count, 10, FALSE,
            count_str, status);
      CASE call_block.skp.direction OF
      = amc$forward =
        call_block.skp.file_position^ := amc$eoi;
        file_instance^.global_file_information^.positioning_info.record_info.
              file_position := amc$eoi;
        file_instance^.residual_skip_count := call_block.skp.count;
        amp$set_file_instance_abnormal (file_identifier,
              ame$skip_encountered_eoi, call_block.operation,
              count_str.value (1, count_str.size), status);
      ELSE
        call_block.skp.file_position^ := amc$boi;
        file_instance^.global_file_information^.positioning_info.record_info.
              file_position := amc$boi;
        file_instance^.residual_skip_count := call_block.skp.count;
        amp$set_file_instance_abnormal (file_identifier,
              ame$skip_encountered_boi, call_block.operation,
              count_str.value (1, count_str.size), status);
      CASEND;

    = amc$open_req, amc$flush_req, amc$write_tape_mark_req,
          amc$seek_direct_req, amc$pack_block_req, amc$pack_record_req,
            amc$unpack_block_req, amc$unpack_record_req, amc$rewind_req,
            amc$set_segment_eoi_req, amc$set_segment_position_req,
            amc$write_end_partition_req, amc$replace_req =
      ;

    = amc$close_req =
      bap$close (file_identifier, status);

    = amc$store_req =
      bap$store (file_identifier, call_block, layer_number, status);

    = amc$fetch_req =
      bap$fetch (file_identifier, call_block, layer_number, status);

    = amc$fetch_access_information_rq =
      bap$fetch_access_information (file_identifier, call_block, layer_number,
            status);

    ELSE

      amp$set_file_instance_abnormal (file_identifier,
            ame$unimplemented_request, call_block.operation, 'for null device files',
            status);

    CASEND;

    IF call_block.operation <> amc$close_req THEN
      IF call_block.operation <> amc$fetch_access_information_rq THEN

        file_instance^.global_file_information^.last_access_operation :=
              call_block.operation;

      IFEND;

      IF status.normal THEN
        file_instance^.global_file_information^.error_status := 0;
      ELSE
        file_instance^.global_file_information^.error_status := status.condition;
      IFEND;
    IFEND;

  PROCEND bap$null_device;

MODEND bam$null_device;
*DECK DECK=BAM$OPEN_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Basic Access Method : Open File' ??

MODULE bam$open_file;

{
{ PURPOSE:
{   This module contains the bulk of the processing needed to open a file.
{

*copyc fsh$open_file
?? PUSH (LISTEXT := ON) ??
?? NEWTITLE := 'Global Declarations', EJECT ??
*copyc ame$attribute_validation_errors
*copyc ame$device_class_validation
*copyc ame$label_validation_errors
*copyc ame$open_validation_errors
*copyc ame$ring_validation_errors
*copyc ame$lfn_program_actions
*copyc ame$tape_program_actions
*copyc bac$minimum_open_ring
*copyc cle$ecc_lexical
*copyc cle$ecc_file_reference
*copyc dme$tape_errors
*copyc fme$file_management_errors
*copyc fsc$file_system_id
*copyc fsc$local
*copyc fse$attach_validation_errors
*copyc fse$open_validation_errors
*copyc fse$path_exception_conditions
*copyc jml$user_id
*copyc lld$loader_execptions
*copyc mme$condition_codes
*copyc ofe$error_codes
*copyc ose$heap_full_exceptions
*copyc rmc$recorded_vsn_size
*copyc rme$creblv_errors
*copyc amt$fap_declarations
*copyc amt$get_attributes
*copyc amt$max_block_length
*copyc amt$max_record_length
*copyc bak$bap_procedure_keypoints
*copyc bat$auxilliary_request_table
*copyc bat$block_header
*copyc bat$system_file_attributes
*copyc bat$tape_descriptor
*copyc bat$task_file_table
*copyc clt$path_kind
*copyc fmv$tape_attachment_information
*copyc fst$attachment_options
*copyc fst$ansi_eof1_label
*copyc fst$ansi_eof2_label
*copyc fst$ansi_hdr1_label
*copyc fst$ansi_hdr2_label
*copyc fst$ansi_vol1_label
*copyc fst$device_classes
*copyc fst$file_cycle_attributes
*copyc fst$file_reference
*copyc fst$goi_object_information
*copyc fst$path_element_size
*copyc fst$status_reporting_procedure
*copyc fst$tape_attachment_information
*copyc iiv$interactive_terminated
*copyc osc$status_parameter_delimiter
*copyc osd$code_base_pointer
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc ost$caller_identifier
*copyc ost$name
*copyc ost$string
*copyc pfe$error_condition_codes
*copyc pmt$loaded_address
*copyc pmt$program_name
*copyc rmt$device_class
?? POP ??
*copyc amp$get_file_attributes
*copyc avp$removable_media_operator
*copyc avp$security_option_active
*copyc bap$connected_file_device
*copyc bap$determine_loaded_ring
*copyc bap$fap_control
*copyc bap$get_tape_label_attributes
*copyc bap$log_device
*copyc bap$merge_open_attributes
*copyc bap$merge_tape_attributes
*copyc bap$null_device
 PROCEDURE hide_xrefs_copied_by_inlines;
{bap$validate_file_identifier & bap$release_tft_entry
*copyc bav$last_tft_entry
*copyc bav$task_file_table
*copyc bav$tft_entry_assignment
 PROCEND hide_xrefs_copied_by_inlines;
*copyc bap$release_tft_entry
*copyc bap$system_tape_label_fap
*copyc bap$validate_file_identifier
*copyc clp$construct_path_handle_name
*copyc clp$convert_cyc_ref_to_cyc_sel
*copyc clp$convert_integer_to_string
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_string_to_integer
*copyc clp$get_fs_path_string
*copyc clp$trimmed_string_size
*copyc fmp$cleanup_open
*copyc fmp$create_cycle_description
*copyc fmp$decrement_open_count
*copyc fmp$end_new_open_processing
*copyc fmp$fetch_tape_attachment
*copyc fmp$fetch_tape_label_attributes
*copyc fmp$get_cd_info
*copyc fmp$get_device_class_and_sfid
*copyc fmp$locate_cd_via_path_handle
*copyc fmp$record_open_cycle_info
*copyc fmp$return_file
*copyc fmp$store_tape_attachment
*copyc fsp$convert_device_class_to_fs
*copyc fsp$convert_fs_structure_to_pf
*copyc fsp$convert_to_old_contents
*copyc fsp$locate_tape_label
*copyc fsp$path_element
*copyc fsp$set_evaluated_file_abnormal
*copyc fsp$strictly_null_device
*copyc fsp$validate_attachments
*copyc fsp$validate_attributes
*copyc fsp$ve_wrote_ansi_file
*copyc i#move
*copyc ifp$fap_control
*copyc ifp$st_fap_control
*copyc iip$xt_is_xterm_file
*copyc iip$xt_xterm_fap
*copyc jmp$job_file_fap
*copyc jmp$system_job
*copyc lop$find_entry_point_residence
*copyc lop$load_entry_point
*copyc mmp$close_segment
*copyc mmp$set_segment_length
*copyc nap$network_fap
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$clear_job_signature_lock
*copyc osp$decrement_locked_variable
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$fetch_locked_variable
*copyc osp$format_message
*copyc osp$increment_locked_variable
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$test_sig_lock
*copyc osp$verify_system_privilege
*copyc pfe$external_archive_conditions
*copyc pfp$purge
*copyc pfp$r3_attach_or_create_file
*copyc pfp$r3_get_object_information
*copyc pmp$change_legible_date_format
*copyc pmp$get_job_mode
*copyc pmp$load_module_from_library
*copyc rfp$network_fap
*copyc rmp$enforce_tape_security
*copyc rmp$validate_ansi_string
*copyc rmp$validate_specified_rmg
*copyc sfp$emit_audit_statistic
*copyc sfp$emit_statistic

*copyc amv$aam_file_organizations
*copyc amv$block_type_names
*copyc amv$device_class_names
*copyc amv$file_organization_names
*copyc amv$record_type_names
*copyc amv$usage_option_names
*copyc bav$magnetic_tape_device_faps
*copyc bav$mass_storage_device_faps
*copyc bav$rms_library_reference
*copyc clv$processing_phase
*copyc clv$standard_files
*copyc fmv$default_file_attributes
*copyc fmv$entry_assigned_free_select
*copyc fmv$global_file_information
*copyc fsv$attribute_names
*copyc osv$lower_to_upper
*copyc osv$task_private_heap
*copyc rmv$null_device_set
*copyc sfv$emit_job_open_statistics
*copyc sfv$emit_sys_open_statistics
?? EJECT ??

?? FMT (FORMAT := OFF) ??
  CONST
    bac$minimum_load_ring = osc$tsrv_ring;

{ single_choice_attachments
  CONST
    number_of_single_choice_attach = 16;

  TYPE
    single_choice_attachments_keys = (
      sca_allowed_device_classes,
      sca_allowed_exceptions,
      sca_create_file,
      sca_delete_data,
      sca_error_exit_procedure,
      sca_error_exit_procedure_name ,
      sca_error_limit {Advanced Access Method files only},
      sca_label_exit_procedure,
      sca_label_exit_procedure_name,
      sca_message_control {Advanced Access Method files only},
      sca_open_position,
      sca_password,
      sca_tape_error_options,
      sca_validation_ring,
      sca_wait_for_attachment,
      sca_exception_detection),

    single_choice_attachments_type = array [single_choice_attachments_keys] of
          fst$attachment_option;

  VAR
    single_choice_attachments_def: [STATIC, READ, oss$job_paged_literal]
      single_choice_attachments_type := [
      [fsc$allowed_device_classes, -$fst$device_classes []],
      [fsc$allowed_exceptions, [$fst$cycle_damage_symptoms[],
            -$fst$file_access_conditions[fsc$cycle_busy]]],
      { create_file } [fsc$null_attachment_option],
      [fsc$delete_data, FALSE],
      [fsc$error_exit_procedure, NIL],
      [fsc$error_exit_procedure_name, NIL],
      { error_limit } [fsc$null_attachment_option],
      [fsc$label_exit_procedure, NIL],
      [fsc$label_exit_procedure_name, NIL],
      { message_control } [fsc$null_attachment_option],
      { open_position } [fsc$null_attachment_option],
      {password} [fsc$null_attachment_option],
      { tape_error_options } [fsc$null_attachment_option],
      [fsc$validation_ring, * ],
      [fsc$wait_for_attachment, [osc$wait, fsc$longest_wait_time]],
      [fsc$exception_detection, $fst$cycle_damage_symptoms[]]];

{ Default record values
  VAR
    bav$default_tft: [READ, oss$job_paged_literal] bat$task_file_entry
      := [
       {local_file_name}           osc$null_name,
       {sequence_number}           4095,
       {access_level}              amc$record,
       {open_ring}                 * ,
       {close_allowed}             TRUE,
       {next_target}               [FALSE],
       {initial_open}              FALSE,
       {instance_of_open_modified} FALSE,
       {instance_attributes}       *,
       {open_actions}              [FALSE, FALSE, FALSE],
       {previous_get_at_eoi}       FALSE,
       {residual_skip_count}       0,
       {private_read_information}  NIL,
       {global_file_information}   NIL,
       {system_file_label}         NIL,
       {fap_control_information}   *,
       {module_dynamically_loaded} FALSE,
       {target_connection_level}   0,
       {device_class}              rmc$mass_storage_device,
       {= rmc$mass_storage_device =
       {  allowed_access_conditions} $fst$file_access_conditions [],
       {  file_pva}                  NIL,
       {  rollback_procedure}        NIL,
       {  wait}                      TRUE,
       {  wait_time}                 fsc$longest_wait_time
       ],
?? FMT (FORMAT := ON) ??
    bav$default_pri: [READ, oss$job_paged_literal]
      bat$private_read_information := [ 0, * , [[1, bac$beginning_of_block,
      0, 0, 0, 0], [0, 0, amc$boi, 0, 0, 0, 0]]],
    bav$default_fap_descriptor: [READ, oss$job_paged_literal]
      bat$fap_descriptor := [NIL, NIL, bac$minimum_load_ring, TRUE];

{ Task file table (TFT) & auxiliary request table (ART)
  VAR
    bav$auxilliary_request_table: [XDCL, oss$task_private]
      ^bat$auxilliary_request_table := NIL,
    bav$file_id_sequence_number: [XDCL, #GATE, oss$task_private]
      amt$file_id_sequence := LOWERVALUE (amt$file_id_sequence),
    bav$task_file_table: [XDCL, #GATE, oss$task_private] ^bat$task_file_table
      := NIL,
    bav$last_tft_entry: [XDCL, #GATE, oss$task_private] bat$last_tft_entry
      := 0,
    bav$tft_entry_assignment: [XDCL, #GATE, oss$task_private]
      ^bat$tft_entry_assignment := NIL;

{Tape information
  CONST
    tape_attach_choice_limit = fsc$tape_volume_initialization;

  VAR
    tape_attachment_names: [STATIC, READ, oss$job_paged_literal] array
          [fsc$tape_block_type .. tape_attach_choice_limit] of ost$name := [

          {fsc$tape_block_type ........... = 001} 'TAPE_BLOCK_TYPE               ',
          {fsc$tape_buffer_offset ........ = 002} 'TAPE_BUFFER_OFFSET            ',
          {fsc$tape_character_conversion . = 003} 'TAPE_CHARACTER_CONVERSION     ',
          {fsc$tape_character_set ........ = 004} 'TAPE_CHARACTER_SET            ',
          {fsc$tape_creation_date ........ = 005} 'TAPE_CREATION_DATE            ',
          {fsc$tape_expiration_date ...... = 006} 'TAPE_EXPIRATION_DATE          ',
          {fsc$tape_file_accessibility ... = 007} 'TAPE_FILE_ACCESSIBILITY       ',
          {fsc$tape_file_identifier ...... = 008} 'TAPE_FILE_IDENTIFIER          ',
          {fsc$tape_file_sequence_number . = 009} 'TAPE_FILE_SEQUENCE_NUMBER     ',
          {fsc$tape_file_set_identifier .. = 010} 'TAPE_FILE_SET_IDENTIFIER      ',
          {fsc$tape_file_set_position .... = 011} 'TAPE_FILE_SET_POSITION        ',
          {fsc$tape_generation_number .... = 012} 'TAPE_GENERATION_NUMBER        ',
          {fsc$tape_generation_version_num = 013} 'TAPE_GENERATION_VERSION_NUMBER',
          {fsc$tape_max_block_length ..... = 014} 'TAPE_MAX_BLOCK_LENGTH         ',
          {fsc$tape_max_record_length .... = 015} 'TAPE_MAX_RECORD_LENGTH        ',
          {fsc$tape_null_attachment_option = 016} 'TAPE_NULL_ATTACHMENT_OPTION   ',
          {fsc$tape_padding_character .... = 017} 'TAPE_PADDING_CHARACTER        ',
          {fsc$tape_record_type .......... = 018} 'TAPE_RECORD_TYPE              ',
          {fsc$tape_rewrite_labels ....... = 019} 'TAPE_REWRITE_LABELS           ',
          {fsc$tape_removable_media_group  = 020} 'TAPE_REMOVABLE_MEDIA_GROUP    ',
          {fsc$tape_volume_accessibility . = 021} 'TAPE_VOLUME_ACCESSIBILITY     ',
          {fsc$tape_owner_identification . = 022} 'TAPE_OWNER_IDENTIFICATION     ',
          {fsc$tape_label_standard_version = 023} 'TAPE_LABEL_STANDARD_VERSION   ',
          {fsc$tape_implementation_id .... = 024} 'TAPE_IMPLEMENTATION_ID        ',
          {fsc$tape_header_labels ........ = 025} 'TAPE_HEADER_LABELS            ',
          {fsc$tape_trailer_labels ....... = 026} 'TAPE_TRAILER_LABELS           ',
          {fsc$tape_file_section_number .. = 027} 'TAPE_FILE_SECTION_NUMBER      ',
          {fsc$tape_block_count .......... = 028} 'TAPE_BLOCK_COUNT              ',
          {fsc$tape_volume_initialization  = 029} 'TAPE_VOLUME_INITIALIZATION    '];

  VAR
    any_tape_opened_in_task: [STATIC, oss$task_private] boolean := FALSE;

{Get object information request
  VAR
    information_request: [READ, oss$job_paged_literal] fst$goi_information_request :=
          [[fsc$specific_depth, 1], [fsc$goi_cycle_device_info]];
?? OLDTITLE ??

?? NEWTITLE := 'PROCEDURE [XDCL, #GATE] bap$end_new_open_processing', EJECT ??
  PROCEDURE [XDCL, #GATE] bap$end_new_open_processing
    (    path_handle: fmt$path_handle;
     VAR status: ost$status);

    status.normal := TRUE;

    osp$verify_system_privilege;
    fmp$end_new_open_processing (path_handle, status);

  PROCEND bap$end_new_open_processing;
?? OLDTITLE ??

?? NEWTITLE := 'PROCEDURE [XDCL, #GATE] bap$free_static_label', EJECT ??
  PROCEDURE [XDCL, #GATE] bap$free_static_label
    (    path_handle: fmt$path_handle);

    VAR
      open_cleanup_work_list: fmt$open_cleanup_work_list;

    osp$verify_system_privilege;
    open_cleanup_work_list := $fmt$open_cleanup_work_list [fmc$free_static_label];
    fmp$cleanup_open (path_handle, open_cleanup_work_list);

  PROCEND bap$free_static_label;
?? OLDTITLE ??

?? NEWTITLE := 'PROCEDURE [XDCL, #GATE] bap$open_file', EJECT ??
*copyc bah$open_file
?? SKIP := 3 ??

  PROCEDURE [XDCL, #GATE] bap$open_file
    (   access_level: amt$access_level;
        file_attachment: ^fst$attachment_options;
        default_creation_attributes: ^fst$file_cycle_attributes;
        mandated_creation_attributes: ^fst$file_cycle_attributes;
        attribute_validation: ^fst$file_cycle_attributes;
        attribute_override: ^fst$file_cycle_attributes;
{ evaluated_file_reference should only be updated on a normal status.
    VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
    VAR contains_data: boolean;
    VAR file_identifier: amt$file_identifier;
    VAR archive_cycle_number: pft$cycle_number;
    VAR status: ost$status);

    CONST
      implicit_detach = TRUE;

    VAR
      access_and_share_modes_count: integer,
      access_mode_includes_write: boolean,
      caller_id: ost$caller_identifier,
      cd_attachment_options: fmt$cd_attachment_options,
      device_class: rmt$device_class,
      file_attachment_index: integer,
      file_instance_initialized: boolean,
      global_file_information: ^bat$global_file_information,
      i: 1 .. tape_attach_choice_limit,
      instance_access_mode: fst$file_access_options,
      instance_attributes: bat$instance_attributes,
      limit_str: ost$string,
      local_evaluated_file_reference: fst$evaluated_file_reference,
      merged_tape_attributes: fst$tape_attachment_information,
      open_cleanup_work_list: fmt$open_cleanup_work_list,
      open_count: integer,
      open_share_modes_specified: boolean,
      opened_access_modes: bat$access_counts,
      password: pft$password,
      preserved_attributes: bat$system_file_attributes,
      p_tape_descriptor: ^bat$tape_descriptor,
      retention: fst$retention,
      retrieve_option: pft$retrieve_option,
      segment_ptr: ^cell,
      sfid: gft$system_file_identifier,
      single_choice_attachments: single_choice_attachments_type,
      site_archive_option: pft$site_archive_option,
      site_backup_option: pft$site_backup_option,
      site_release_option: pft$site_release_option,
      system_file_label: ^fmt$system_file_label,
      tape_attachment_specified: boolean,
      tape_attachment: array [1 .. tape_attach_choice_limit] of fst$attachment_option,
      task_file_index: bat$tft_limit;

?? NEWTITLE := '    bam_open condition_handler proc', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cyd$run_time_error_condition
*copyc oss$job_paged_literal
*copyc pmt$condition
?? POP ??
*copyc pmp$continue_to_cause

{
{  PURPOSE:
{     This procedure invokes a clean_up of the established condition in event
{that
{     its establisher is aborted. Additionally, a call to free the current
{task_file_entry
{     is invoked.
{
{     Conditions considered to represent an abort are: system, segmt access,
{cybil runtime,
{     command retry, and interactive terminate breaks.
{
{

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

      VAR
        abort: boolean,
        ignore_status: ost$status;

      handler_status.normal := TRUE;

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        abort := TRUE;
      = pmc$user_defined_condition =
        abort := (condition.user_condition_name = cye$run_time_condition);
      = ifc$interactive_condition =
        abort := condition.interactive_condition = ifc$terminate_break;
      = jmc$job_resource_condition =
        abort := TRUE;
      ELSE
        abort := FALSE;
      CASEND;

      IF abort THEN
        osp$set_status_from_condition (amc$access_method_id, condition,
              save_area, status, ignore_status);
        IF file_instance_initialized THEN
          cleanup_open;
        IFEND;
        EXIT bap$open_file;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND bam_condition_handler;

    PROCEDURE cleanup_open;

      VAR
        cleanup_status: ost$status,
        cycle_selector: clt$cycle_selector,
        file_pva: mmt$segment_pointer,
        pf_path: ^pft$path;

      IF open_cleanup_work_list <> $fmt$open_cleanup_work_list [] THEN
        fmp$cleanup_open (local_evaluated_file_reference.
              path_handle_info.path_handle, open_cleanup_work_list);
{ We should retrieve the static label for a permanent file that isn't
{ being returned.  The following example currently fails:
{ cref $user.x; setfa $user.x fc=george; detf $user.x; attf $user.x
{ open $user.x - failing open
{ open $user.x - successful open but setfa may be lost
      IFEND;

      CASE bav$task_file_table^ [task_file_index].device_class OF
      = rmc$mass_storage_device =
        IF bav$task_file_table^ [task_file_index].file_pva <> NIL THEN
          file_pva.kind := mmc$cell_pointer;
          file_pva.cell_pointer := bav$task_file_table^ [task_file_index].file_pva;
          mmp$close_segment (file_pva, 1, cleanup_status);
          bav$task_file_table^ [task_file_index].file_pva := NIL;
        IFEND;
      ELSE
        ;
      CASEND;

      bap$release_tft_entry (^bav$task_file_table^ [task_file_index], task_file_index);

      IF fsp$path_element (^local_evaluated_file_reference, 1)^ <> fsc$local THEN
        IF bav$task_file_table^ [task_file_index].open_actions.open_created_file THEN
          PUSH pf_path: [1 .. local_evaluated_file_reference.
                 number_of_path_elements];
          fsp$convert_fs_structure_to_pf (local_evaluated_file_reference,
                pf_path);
          clp$convert_cyc_ref_to_cyc_sel (local_evaluated_file_reference.
                cycle_reference, cycle_selector);
          IF single_choice_attachments [sca_password].selector =
                fsc$password THEN
            password := single_choice_attachments [sca_password].password;
          ELSE
            password := osc$null_name;
          IFEND;
          pfp$purge (pf_path^, cycle_selector.value, password, cleanup_status);
          fmp$return_file (local_evaluated_file_reference, implicit_detach, {detachment_options} NIL,
                cleanup_status);
        ELSEIF bav$task_file_table^ [task_file_index].open_actions.
              open_attached_file THEN
          fmp$return_file (local_evaluated_file_reference, implicit_detach, {detachment_options} NIL,
                cleanup_status);
        IFEND;
      ELSEIF bav$task_file_table^ [task_file_index].open_actions.
            open_created_file THEN
        fmp$return_file (local_evaluated_file_reference, NOT implicit_detach, {detachment_options} NIL,
              cleanup_status);
      IFEND;
    PROCEND cleanup_open;

?? TITLE := '    STATUS_REPORTING_PROCEDURE', EJECT ??

    PROCEDURE status_reporting_procedure
      (    condition: ost$status_condition;
           text: string (*);
       VAR status: ost$status);

      fsp$set_evaluated_file_abnormal (local_evaluated_file_reference,
            condition, amc$open_req, text, status);

    PROCEND status_reporting_procedure;

?? OLDTITLE ??

    #keypoint (osk$entry, 0, bak$open_file);
    #caller_id (caller_id);
    status.normal := TRUE;

    osp$verify_system_privilege;

    file_instance_initialized := FALSE;
    open_cleanup_work_list := $fmt$open_cleanup_work_list [];

    local_evaluated_file_reference := evaluated_file_reference;

    access_and_share_modes_count := 0;
    open_share_modes_specified := FALSE;
    single_choice_attachments := single_choice_attachments_def;
    single_choice_attachments [sca_validation_ring].validation_ring :=
          caller_id.ring;
    FOR i := 1 TO tape_attach_choice_limit DO
      tape_attachment [i].selector := fsc$tape_attachment;
      tape_attachment [i].tape_attachment.selector := fsc$tape_null_attachment_option;
    FOREND;
    tape_attachment_specified := FALSE;

    osp$establish_condition_handler (^bam_condition_handler, FALSE);

  /main_program/
    BEGIN
      validate_open_parameters (caller_id.ring, access_level,
            file_attachment, default_creation_attributes,
            mandated_creation_attributes, attribute_validation,
            attribute_override, ^status_reporting_procedure, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      initialize_file_instance (access_level, caller_id.ring, task_file_index,
            ^status_reporting_procedure, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      file_instance_initialized := TRUE;

      IF file_attachment <> NIL THEN

        { Loop through the file_attachment array to find out if certain
        { attachment options were specified by the caller. This is done here
        { to avoid looping through the array each time it is necessary to find
        { out if a particular option was specified and if so what its value is.

        search_file_attachment (local_evaluated_file_reference,
               file_attachment, single_choice_attachments,
               tape_attachment, tape_attachment_specified, access_and_share_modes_count,
               open_share_modes_specified, ^status_reporting_procedure, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        IF single_choice_attachments [sca_validation_ring].validation_ring <
              caller_id.ring THEN
          status_reporting_procedure (ame$ring_validation_error, '', status);
          EXIT /main_program/;
        IFEND;
      IFEND;

      get_catalog_cycle_attributes (mandated_creation_attributes, default_creation_attributes, retention,
            retrieve_option, site_archive_option, site_backup_option, site_release_option);

      attach_or_create_file (task_file_index, access_level, file_attachment, access_and_share_modes_count,
            retention, retrieve_option, site_archive_option, site_backup_option, site_release_option,
            single_choice_attachments, open_cleanup_work_list, local_evaluated_file_reference,
            preserved_attributes, open_count, device_class, opened_access_modes, archive_cycle_number,
            cd_attachment_options, ^status_reporting_procedure, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF device_class = rmc$magnetic_tape_device THEN
        IF open_count > 1 THEN
          status_reporting_procedure (ame$multiple_open_of_tape, '', status);
          EXIT /main_program/;
        IFEND;

{ Get CHATLA specifications

        fmp$fetch_tape_label_attributes (evaluated_file_reference, merged_tape_attributes, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        IF tape_attachment_specified THEN

{ Merge CHATLA and tape attachment values into merged_tape_attributes

          fmp$store_tape_attachment (tape_attachment, fsc$tape_open_tape_attachment, ^merged_tape_attributes,
                status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;
      IFEND;

      IF file_attachment <> NIL THEN
        FOR file_attachment_index := LOWERBOUND (file_attachment^) TO UPPERBOUND (file_attachment^) DO
          CASE file_attachment^ [file_attachment_index].selector OF
          = fsc$free_behind =
            cd_attachment_options.free_behind_specified := TRUE;
            cd_attachment_options.free_behind := file_attachment^ [file_attachment_index].free_behind;
          = fsc$private_read =
            cd_attachment_options.private_read_specified := TRUE;
            cd_attachment_options.private_read := file_attachment^ [file_attachment_index].private_read;
          = fsc$sequential_access =
            cd_attachment_options.sequential_access_specified := TRUE;
            cd_attachment_options.sequential_access := file_attachment^ [file_attachment_index].
                  sequential_access;
          = fsc$transfer_size =
            cd_attachment_options.transfer_size_specified := TRUE;
            cd_attachment_options.transfer_size := file_attachment^ [file_attachment_index].transfer_size;
          ELSE
          CASEND;
        FOREND;
      IFEND;

      process_file_attributes (evaluated_file_reference, access_level, default_creation_attributes,
            mandated_creation_attributes, attribute_validation, attribute_override,
            single_choice_attachments [sca_validation_ring].validation_ring, caller_id.ring,
            NOT bav$task_file_table^ [task_file_index].initial_open, device_class,
            merged_tape_attributes, preserved_attributes, instance_attributes,
            access_mode_includes_write, ^status_reporting_procedure,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF (instance_attributes.dynamic_label.access_mode =
            $pft$usage_selections [pfc$read]) OR
            (instance_attributes.dynamic_label.access_mode =
            $pft$usage_selections [pfc$read, pfc$execute]) THEN
        IF ((NOT cd_attachment_options.private_read_specified) OR
             cd_attachment_options.private_read) AND
             (device_class = rmc$mass_storage_device) THEN
          ALLOCATE bav$task_file_table^ [task_file_index].private_read_information IN
                osv$task_private_heap^;
          bav$task_file_table^ [task_file_index].private_read_information^ :=
            bav$default_pri;
        IFEND;
      ELSEIF (cd_attachment_options.private_read_specified) AND
            cd_attachment_options.private_read THEN
        status_reporting_procedure (fse$improper_private_read,
              '', status);
        EXIT /main_program/;
      IFEND;

      IF NOT fsp$strictly_null_device (device_class, fsp$path_element (^evaluated_file_reference, 2)^) THEN
        enforce_concurrency_rules (file_attachment, cd_attachment_options, device_class,
              open_share_modes_specified, opened_access_modes,
              open_count, instance_attributes.dynamic_label.open_share_modes,
              ^status_reporting_procedure, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      load_all_faps (task_file_index, caller_id, device_class,
            preserved_attributes.static_label.file_access_procedure,
            instance_attributes.static_label.file_label_type,
            instance_attributes.static_label.file_organization,
            instance_attributes.static_label.block_type, instance_attributes.
            static_label.record_type, access_level,
            local_evaluated_file_reference.path_handle_info.path_handle,
            ^status_reporting_procedure, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF instance_attributes.dynamic_label.error_exit_name <> osc$null_name THEN
        load_error_exit (instance_attributes.dynamic_label.
              error_exit_name_source, instance_attributes.dynamic_label.
              error_exit_name, caller_id, instance_attributes.dynamic_label.
              error_exit_procedure, instance_attributes.dynamic_label.
              error_exit_procedure_source, ^status_reporting_procedure, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF bav$task_file_table^ [task_file_index].initial_open AND (preserved_attributes.static_label.
            collate_table_name <> osc$null_name) THEN
        load_collate_table (preserved_attributes.static_label.
              collate_table_name_source, preserved_attributes.static_label.
              collate_table_name, caller_id, preserved_attributes.
              static_label.collate_table_source, preserved_attributes.
              static_label.collate_table, ^status_reporting_procedure,
              status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      fmp$record_open_cycle_info (local_evaluated_file_reference.path_handle_info.path_handle,
            caller_id.ring, access_level, preserved_attributes.static_label, instance_attributes,
            cd_attachment_options, open_count, device_class, open_cleanup_work_list,
            global_file_information, segment_ptr, system_file_label, status);
      IF status.normal THEN
        IF device_class = rmc$mass_storage_device THEN
          bav$task_file_table^ [task_file_index].file_pva := segment_ptr;
          bav$task_file_table^ [task_file_index].allowed_access_conditions :=
                 single_choice_attachments [sca_allowed_exceptions].allowed_exceptions.access_conditions;
          bav$task_file_table^ [task_file_index].wait :=
                (single_choice_attachments [sca_wait_for_attachment].wait_for_attachment.wait = osc$wait);
          IF bav$task_file_table^ [task_file_index].wait THEN
            bav$task_file_table^ [task_file_index].wait_time :=
                   single_choice_attachments [sca_wait_for_attachment].wait_for_attachment.wait_time;
          IFEND;
          IF sfv$emit_job_open_statistics OR sfv$emit_sys_open_statistics THEN
            emit_open_statistics (local_evaluated_file_reference, task_file_index, global_file_information,
                  access_level, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
          IFEND;
        IFEND;
      ELSE
        IF status.condition = mme$segment_table_is_full THEN
          clp$convert_integer_to_string (bav$last_tft_entry, 10,
                FALSE, limit_str, status);
          IF status.normal THEN
            status_reporting_procedure (ame$concurrent_open_limit,
                  limit_str.value (1, limit_str.size), status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'Memory',
                  status);
          IFEND;
        IFEND;
        EXIT /main_program/;
      IFEND;

      IF device_class = rmc$magnetic_tape_device THEN
        RESET global_file_information^.device_dependent_info.tape_descriptor;
        NEXT p_tape_descriptor IN global_file_information^.device_dependent_info.tape_descriptor;
        p_tape_descriptor^.tape_attachment_information := merged_tape_attributes;
      IFEND;

      store_attributes_in_tft (instance_attributes, global_file_information,
            system_file_label, device_class, bav$task_file_table^ [task_file_index]);

      finalize_file_instance (task_file_index, system_file_label^.
            descriptive_label.internal_cycle_name, file_identifier);

      establish_open_position (instance_attributes.dynamic_label.open_position,
            caller_id, instance_attributes.dynamic_label.access_mode,
            single_choice_attachments [sca_delete_data].delete_data, task_file_index,
            preserved_attributes.descriptive_label.global_share_mode, open_count,
            bav$task_file_table^ [task_file_index].global_file_information,
            bav$task_file_table^ [task_file_index].private_read_information,
            device_class, segment_ptr);

      contains_data := bav$task_file_table^ [task_file_index].
            global_file_information^.eoi_byte_address > 0;

{ Clear OPEN's lock on the file, the following two lines assume that this process won't be interrupted.
{ If for some reason an interrupt can occur and the condition handler takes over, the lock could be
{ cleared twice. This would be fatal to the task.

      osp$clear_job_signature_lock (global_file_information^.open_lock);
      open_cleanup_work_list := open_cleanup_work_list - $fmt$open_cleanup_work_list [fmc$clear_open_lock];

      evaluated_file_reference := local_evaluated_file_reference;
    END /main_program/;

    IF NOT status.normal AND file_instance_initialized THEN
      cleanup_open;
    IFEND;

{   As long as bap$open_file does not establish a block exit handler, it is not
{   necessary to disestablish the condition handler.
{
{   osp$disestablish_cond_handler;

    #keypoint (osk$exit, 0, bak$open_file);

  PROCEND bap$open_file;

?? TITLE := 'emit_open_statistics', EJECT ??

  PROCEDURE [INLINE] emit_open_statistics
    (    evaluated_file_reference: fst$evaluated_file_reference;
         task_file_index: bat$tft_limit;
         global_file_information: ^bat$global_file_information;
         access_level: amt$access_level;
     VAR status: ost$status);

     VAR
       counters: array [1 .. 5] of sft$counter,
       data_size: 1 .. sfc$max_descriptive_data_size,
       descriptive_data: string (sfc$max_descriptive_data_size),
       entry: ost$positive_integers,
       ignore_device_class: rmt$device_class,
       object_info_seq: ^SEQ ( * ),
       object_info_seq_size: ost$positive_integers,
       object_information: ^fst$goi_object_information,
       resolved_path: fst$path,
       resolved_path_size: fst$path_size,
       sfid: gft$system_file_identifier,
       sfid_integer: integer;

     status.normal := TRUE;

     clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} FALSE, resolved_path,
           resolved_path_size, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

     descriptive_data := resolved_path (1, resolved_path_size);
     data_size := resolved_path_size;

     object_info_seq_size := #SIZE (fst$goi_object_information) + #SIZE (fst$goi_object) +
           #SIZE (fst$device_information) + fsc$max_path_size;
     PUSH object_info_seq: [[REP object_info_seq_size OF cell]];
     RESET object_info_seq;
     pfp$r3_get_object_information (evaluated_file_reference, information_request,
           {validation_criteria} NIL, object_info_seq, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;
     RESET object_info_seq;
     IF object_info_seq <> NIL THEN
       NEXT object_information IN object_info_seq;
       IF (object_information^.object <> NIL) AND (object_information^.object^.cycle_device_information
             <> NIL) AND object_information^.object^.cycle_device_information^.mass_storage_device_info.
             resides_online AND (object_information^.object^.cycle_device_information^.
             mass_storage_device_info.volume_list <> NIL) THEN
         descriptive_data (data_size + 1, 3) := ', (';
         data_size := data_size + 3;
         FOR entry := 1 TO UPPERBOUND (object_information^.object^.cycle_device_information^.
               mass_storage_device_info.volume_list^) DO
           descriptive_data (data_size + 1, rmc$recorded_vsn_size) := object_information^.object^.
                 cycle_device_information^.mass_storage_device_info.volume_list^ [entry].recorded_vsn;
           data_size := data_size + rmc$recorded_vsn_size + 1;
         FOREND;
         descriptive_data (data_size, 1) := ')';
       IFEND;
     IFEND;

     fmp$get_device_class_and_sfid (bav$task_file_table^ [task_file_index].local_file_name,
           ignore_device_class, sfid, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;
     sfid_integer := (sfid.file_entry_index * 1000(16)) + ($INTEGER(sfid.residence) * 100(16)) +
           sfid.file_hash;

     counters[1] := sfid_integer;
     counters[2] := $INTEGER (access_level);
     counters[3] := bav$task_file_table^ [task_file_index].open_ring;
     counters[4] := #SEGMENT (bav$task_file_table^ [task_file_index].file_pva);
     counters[5] := global_file_information^.eoi_byte_address;

     sfp$emit_statistic (jml$open_file_statistics, descriptive_data (1, data_size), ^counters, status);

  PROCEND emit_open_statistics;
?? TITLE := 'establish_open_position ', EJECT ??

  PROCEDURE [INLINE] establish_open_position (open_position: amt$open_position;
        caller_id: ost$caller_identifier;
        validated_access_mode: pft$usage_selections;
        delete_data: boolean;
        task_file_index: bat$tft_limit;
        global_share_mode: pft$share_selections;
        open_count: integer;
        global_file_information: ^bat$global_file_information;
        private_read_information: ^bat$private_read_information;
        device_class: rmt$device_class;
    VAR file_ptr: ^cell);

    VAR
      store_status: ost$status;

    CASE open_position OF
    = amc$open_at_eoi =
      IF private_read_information <> NIL THEN
        private_read_information^.positioning_info.record_info.file_position :=
              amc$eoi;
        private_read_information^.positioning_info.record_info.bor_address :=
              global_file_information^.eoi_byte_address;
        private_read_information^.positioning_info.record_info.
              current_byte_address := global_file_information^.eoi_byte_address;
      ELSE
        global_file_information^.positioning_info.record_info.file_position :=
              amc$eoi;
        global_file_information^.positioning_info.record_info.bor_address :=
              global_file_information^.eoi_byte_address;
        global_file_information^.positioning_info.record_info.record_header_fba
              := global_file_information^.eoi_byte_address;
        global_file_information^.positioning_info.record_info.
              current_byte_address := global_file_information^.eoi_byte_address;
        global_file_information^.positioning_info.record_info.record_length := 0;
        global_file_information^.positioning_info.record_info.
              residual_record_length := 0;
        global_file_information^.positioning_info.record_info.transfer_count
              := 0;
      IFEND;
    = amc$open_at_boi =
      IF private_read_information <> NIL THEN
        private_read_information^.positioning_info :=
          fmv$global_file_information.positioning_info;
      ELSE
        global_file_information^.positioning_info := fmv$global_file_information
              .positioning_info;
        IF open_count = 1 THEN
          IF delete_data AND (pfc$shorten IN validated_access_mode) AND
                (global_share_mode = $pft$usage_selections []) THEN
            global_file_information^.eoi_byte_address := 0;
            IF device_class = rmc$mass_storage_device THEN
              mmp$set_segment_length (file_ptr, bac$minimum_open_ring,
                      0, store_status);
            IFEND;
            bav$task_file_table^ [task_file_index].open_actions.open_deleted_data
                  := TRUE;
          IFEND;
        IFEND;
      IFEND;
    = amc$open_no_positioning, amc$open_at_bop =
      IF private_read_information <> NIL THEN

{ Pick up the address saved by the last close of either private or global.

        private_read_information^.positioning_info.record_info.
              current_byte_address := global_file_information^.
              asis_open_address;
        private_read_information^.positioning_info.record_info.
              bor_address := global_file_information^.
              asis_bor_address;
        private_read_information^.positioning_info.record_info.file_position :=
              global_file_information^.asis_file_position;
      ELSE
        IF open_count = 1 THEN

{ Pick up the address saved by the last close of either private or global.

          IF global_file_information^.positioning_info.record_info.
                current_byte_address <> global_file_information^.
                asis_open_address THEN
            global_file_information^.positioning_info.record_info.
                  current_byte_address := global_file_information^.
                  asis_open_address;
            global_file_information^.positioning_info.record_info.
                  bor_address := global_file_information^.
                  asis_bor_address;
            global_file_information^.positioning_info.record_info.file_position :=
                  global_file_information^.asis_file_position;
          IFEND;

        IFEND;
      IFEND;
    ELSE
    CASEND;

  PROCEND establish_open_position;

?? TITLE := 'validate_open_parameters ', EJECT ??

  PROCEDURE validate_open_parameters
    (   caller_ring: ost$valid_ring;
        access_level: amt$access_level;
        file_attachment: ^fst$attachment_options;
        default_creation_attributes: ^fst$file_cycle_attributes;
        mandated_creation_attributes: ^fst$file_cycle_attributes;
        attribute_validation: ^fst$file_cycle_attributes;
        attribute_override: ^fst$file_cycle_attributes;
        status_reporting_procedure_ptr: fst$status_reporting_procedure;
    VAR status: ost$status);

    status.normal := TRUE;

{ Validate_access_level_parameter
    CASE access_level OF
    = amc$record, amc$segment, amc$physical =
    ELSE
      status_reporting_procedure_ptr^ (ame$improper_access_level, '', status);
      RETURN;
    CASEND;

    IF file_attachment <> NIL THEN
      fsp$validate_attachments (file_attachment,
            status_reporting_procedure_ptr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    IF default_creation_attributes <> NIL THEN
      fsp$validate_attributes (default_creation_attributes,
           'DEFAULT_CREATION_ATTRIBUTES', status_reporting_procedure_ptr,
           status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    IF mandated_creation_attributes <> NIL THEN
      fsp$validate_attributes (mandated_creation_attributes,
           'MANDATED_CREATION_ATTRIBUTES', status_reporting_procedure_ptr,
           status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    IF attribute_validation <> NIL THEN
      fsp$validate_attributes (attribute_validation, 'ATTRIBUTE_VALIDATION',
            status_reporting_procedure_ptr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    IF attribute_override <> NIL THEN
      fsp$validate_attributes (attribute_override, 'ATTRIBUTE_OVERRIDE',
            status_reporting_procedure_ptr, status);
    IFEND;

  PROCEND validate_open_parameters;

?? TITLE := 'initialize_file_instance ', EJECT ??

  PROCEDURE initialize_file_instance
    (    access_level: amt$access_level;
         caller_ring: ost$valid_ring;
     VAR task_file_index: bat$tft_limit;
         status_reporting_procedure_ptr: fst$status_reporting_procedure;
     VAR status: ost$status);

    VAR
      free_entry_found: boolean,
      index: integer,
      limit_str: ost$string,
      new_tft_size: bat$tft_limit,
      old_entry_assignment_pointer: ^bat$tft_entry_assignment,
      old_tft_pointer: ^bat$task_file_table,
      old_tft_size: bat$tft_limit,
      text: ost$name;

    status.normal := TRUE;

{ Locate_tft_entry
    IF bav$task_file_table = NIL THEN
      ALLOCATE bav$tft_entry_assignment: [ bac$tft_allocation_size ] IN
         osv$task_private_heap^;
      ALLOCATE bav$task_file_table: [ 1 .. #SIZE(bav$tft_entry_assignment^) ] IN
         osv$task_private_heap^;
      bav$tft_entry_assignment^ := fmc$entry_free; { ' ' }
    IFEND;

    #scan (fmv$entry_free_selector, bav$tft_entry_assignment^, index,
          free_entry_found);
    IF NOT free_entry_found THEN
      old_tft_size := #SIZE(bav$tft_entry_assignment^);
      IF old_tft_size = bac$maximum_tft_size THEN
        clp$convert_integer_to_string (bac$maximum_tft_size, 10,
              FALSE, limit_str, {ignore}status);
        status_reporting_procedure_ptr^ (ame$concurrent_open_limit,
              limit_str.value (1, limit_str.size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'File',
              status);
        RETURN;
      ELSEIF (old_tft_size + bac$tft_allocation_size) < bac$maximum_tft_size THEN
        new_tft_size := old_tft_size + bac$tft_allocation_size;
      ELSE
        new_tft_size := bac$maximum_tft_size;
      IFEND;
      old_entry_assignment_pointer := bav$tft_entry_assignment;
      old_tft_pointer := bav$task_file_table;
      ALLOCATE bav$tft_entry_assignment: [ new_tft_size ] IN
         osv$task_private_heap^;
      ALLOCATE bav$task_file_table: [ 1 .. #SIZE(bav$tft_entry_assignment^) ] IN
         osv$task_private_heap^;
      bav$tft_entry_assignment^ := old_entry_assignment_pointer^;
      i#move (old_tft_pointer, bav$task_file_table,
            #SIZE(old_tft_pointer^));
      FREE old_tft_pointer IN osv$task_private_heap^;
      FREE old_entry_assignment_pointer IN osv$task_private_heap^;
      index := old_tft_size + 1;
    IFEND;
    task_file_index := index;
    bav$tft_entry_assignment^ (task_file_index, 1) := fmc$entry_assigned; {'A'}
    IF task_file_index > bav$last_tft_entry THEN
      bav$last_tft_entry := task_file_index;
    IFEND;

{ Initialize tft entry
    bav$task_file_table^ [task_file_index] := bav$default_tft;
    bav$task_file_table^ [task_file_index].access_level := access_level;
    IF caller_ring < bac$minimum_load_ring THEN
      bav$task_file_table^ [task_file_index].open_ring :=
            bac$minimum_load_ring;
    ELSE
      bav$task_file_table^ [task_file_index].open_ring := caller_ring;
    IFEND;

{ Initialize_fap_control
    bav$task_file_table^ [task_file_index].fap_control_information.first_fap:=
            bav$default_fap_descriptor;
    bav$task_file_table^ [task_file_index].fap_control_information.fap_array:=
          NIL;

  PROCEND initialize_file_instance;

?? TITLE := 'search_file_attachment', EJECT ??

  PROCEDURE search_file_attachment
{ Evaluated_file_reference is necessary only for call to
{ validate_tape_attachment/bap$get_tape_label_attributes
    (   evaluated_file_reference: fst$evaluated_file_reference;
        file_attachment: ^fst$attachment_options;
    VAR single_choice_attachments: single_choice_attachments_type;
    VAR tape_attachments: array [1 .. tape_attach_choice_limit] OF
             fst$attachment_option;
    VAR tape_attachment_specified: boolean;
    VAR access_and_share_modes_count: integer;
    VAR open_share_modes_specified: boolean;
        status_reporting_procedure_ptr: fst$status_reporting_procedure;
    VAR status: ost$status);

    VAR
      specified: array [1 .. tape_attach_choice_limit] of boolean,
      i: integer,
      job_mode: jmt$job_mode,
      local_status: ost$status;

    status.normal := TRUE;

    FOR i := 1 TO tape_attach_choice_limit DO
      specified [i] := FALSE;
    FOREND;

    pmp$get_job_mode (job_mode, local_status);
    IF local_status.normal AND (job_mode = jmc$batch) THEN
      single_choice_attachments [sca_allowed_exceptions].allowed_exceptions.access_conditions :=
           -$fst$file_access_conditions [];
    IFEND;

    FOR i := LOWERBOUND (file_attachment^) TO UPPERBOUND (file_attachment^) DO
      CASE file_attachment^ [i].selector OF
      = fsc$access_and_share_modes =
        access_and_share_modes_count := access_and_share_modes_count + 1;
      = fsc$allowed_device_classes =
        single_choice_attachments [sca_allowed_device_classes].allowed_device_classes :=
              file_attachment^ [i].allowed_device_classes;
      = fsc$allowed_exceptions =
        single_choice_attachments [sca_allowed_exceptions].allowed_exceptions :=
              file_attachment^ [i].allowed_exceptions;
      = fsc$create_file =
        single_choice_attachments [sca_create_file].selector := fsc$create_file;
        single_choice_attachments [sca_create_file].create_file :=
              file_attachment^ [i].create_file;
      = fsc$delete_data =
        single_choice_attachments [sca_delete_data].delete_data :=
              file_attachment^ [i].delete_data;
      = fsc$error_exit_procedure =
        single_choice_attachments [sca_error_exit_procedure].
              error_exit_procedure := file_attachment^ [i].error_exit_procedure;
      = fsc$error_exit_procedure_name =
        IF file_attachment^ [i].error_exit_procedure_name <> NIL THEN
          single_choice_attachments [sca_error_exit_procedure_name].
                error_exit_procedure_name :=
                file_attachment^ [i].error_exit_procedure_name;
        IFEND;
      = fsc$error_limit =
        single_choice_attachments [sca_error_limit].selector := fsc$error_limit;
        single_choice_attachments [sca_error_limit].error_limit :=
              file_attachment^ [i].error_limit;
      = fsc$exception_detection =
        single_choice_attachments [sca_exception_detection].exception_detection :=
              file_attachment^ [i].exception_detection;
      = fsc$label_exit_procedure =
        single_choice_attachments [sca_label_exit_procedure].
              label_exit_procedure := file_attachment^[i].label_exit_procedure;
      = fsc$label_exit_procedure_name =
        IF file_attachment^ [i].label_exit_procedure_name <> NIL THEN
          single_choice_attachments [sca_label_exit_procedure_name].
                label_exit_procedure_name :=
                file_attachment^ [i].label_exit_procedure_name;
        IFEND;
      = fsc$message_control =
        single_choice_attachments [sca_message_control].selector := fsc$message_control;
        single_choice_attachments [sca_message_control].message_control :=
              file_attachment^ [i].message_control;
      = fsc$open_position =
        single_choice_attachments [sca_open_position].selector := fsc$open_position;
        single_choice_attachments [sca_open_position].open_position :=
              file_attachment^ [i].open_position;
      = fsc$open_share_modes =
        open_share_modes_specified := TRUE;
      = fsc$password =
        single_choice_attachments [sca_password].selector := fsc$password;
        #translate (osv$lower_to_upper, file_attachment^ [i].password,
              single_choice_attachments [sca_password].password);
      = fsc$tape_attachment =
        tape_attachment_specified := TRUE;
        specified [file_attachment^ [i].tape_attachment.selector] := TRUE;
        store_tape_attachment (file_attachment^ [i].tape_attachment, tape_attachments,
              status_reporting_procedure_ptr, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      = fsc$tape_error_options =
        single_choice_attachments [sca_tape_error_options].selector := fsc$tape_error_options;
        single_choice_attachments [sca_tape_error_options].
              tape_error_options := file_attachment^ [i].tape_error_options;
      = fsc$validation_ring =
        single_choice_attachments [sca_validation_ring].validation_ring :=
              file_attachment^ [i].validation_ring;
      = fsc$wait_for_attachment =
        single_choice_attachments [sca_wait_for_attachment].wait_for_attachment :=
              file_attachment^ [i].wait_for_attachment;
      ELSE
      CASEND;
    FOREND;
    IF (single_choice_attachments [sca_error_exit_procedure].
          error_exit_procedure <> NIL) AND ((single_choice_attachments
          [sca_error_exit_procedure_name].error_exit_procedure_name <> NIL) AND
          (single_choice_attachments [sca_error_exit_procedure_name].
          error_exit_procedure_name^.entry_point <> osc$null_name)) THEN
      status_reporting_procedure_ptr^ (fse$redundant_attachment_choice,
            ' Error_exit_procedure', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
        'error_exit_procedure_name', status);
      RETURN;
    IFEND;
    IF (single_choice_attachments [sca_label_exit_procedure].
          label_exit_procedure <> NIL) AND ((single_choice_attachments
          [sca_label_exit_procedure_name].label_exit_procedure_name <> NIL) AND
          (single_choice_attachments [sca_label_exit_procedure_name].
          label_exit_procedure_name^.entry_point <> osc$null_name)) THEN
      status_reporting_procedure_ptr^ (fse$redundant_attachment_choice,
            ' Label_exit_procedure', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
        'label_exit_procedure', status);
      RETURN;
    IFEND;

    IF tape_attachment_specified THEN
      validate_tape_attachments (evaluated_file_reference,
            specified, tape_attachments, status);
      IF NOT status.normal THEN
        status.normal := (status.condition = ame$improper_device_class);
        RETURN;
      IFEND;
    IFEND;

  PROCEND search_file_attachment;
?? TITLE := 'store_tape_attachment', EJECT ??

  PROCEDURE store_tape_attachment (
        attachment: fst$tape_attachment;
    VAR tape_attachments: array [1 .. tape_attach_choice_limit] OF fst$attachment_option;
        status_reporting_procedure_ptr: fst$status_reporting_procedure;
    VAR status: ost$status);

    VAR
      dt: ost$date,
      status_parameter_string: string (50),
      string_length: integer;

    status.normal := TRUE;

    CASE attachment.selector OF

    = fsc$tape_block_type =
      IF (attachment.tape_block_type >= LOWERVALUE (amt$block_type)) AND
            (attachment.tape_block_type <= UPPERVALUE (amt$block_type)) THEN
        tape_attachments [fsc$tape_block_type].tape_attachment.selector := fsc$tape_block_type;
        tape_attachments [fsc$tape_block_type].tape_attachment.tape_block_type := attachment.tape_block_type;
        RETURN;
      IFEND;

    = fsc$tape_buffer_offset =
      IF (attachment.tape_buffer_offset >= 0) AND (attachment.tape_buffer_offset <= amc$maximum_block)
            THEN
        IF attachment.tape_buffer_offset > 0 THEN
          osp$set_status_abnormal ('AM', ame$unimplemented_buffer_offset, ' ', status);
          RETURN;
        IFEND;
        tape_attachments [fsc$tape_buffer_offset].tape_attachment.selector := fsc$tape_buffer_offset;
        tape_attachments [fsc$tape_buffer_offset].tape_attachment.tape_buffer_offset :=
              attachment.tape_buffer_offset;
        RETURN;
      IFEND;

    = fsc$tape_character_conversion =
      IF (attachment.tape_character_conversion >= LOWERVALUE (boolean)) AND
            (attachment.tape_character_conversion <= UPPERVALUE (boolean)) THEN
        tape_attachments [fsc$tape_character_conversion].tape_attachment.selector :=
              fsc$tape_character_conversion;
        tape_attachments [fsc$tape_character_conversion].tape_attachment.tape_character_conversion :=
              attachment.tape_character_conversion;
        RETURN;
      IFEND;

    = fsc$tape_character_set =
      IF (attachment.tape_character_set >= LOWERVALUE (amt$internal_code)) AND
            (attachment.tape_character_set <= UPPERVALUE (amt$internal_code)) THEN
        tape_attachments [fsc$tape_character_set].tape_attachment.selector := fsc$tape_character_set;
        tape_attachments [fsc$tape_character_set].tape_attachment.tape_character_set :=
              attachment.tape_character_set;
        RETURN;
      IFEND;

    = fsc$tape_creation_date =
      dt.date_format := osc$ordinal_date;
      dt.ordinal := attachment.tape_creation_date;
      pmp$change_legible_date_format (osc$ordinal_date, dt, status);
      IF status.normal THEN
        tape_attachments [fsc$tape_creation_date].tape_attachment.selector := fsc$tape_creation_date;
        tape_attachments [fsc$tape_creation_date].tape_attachment.tape_creation_date :=
              attachment.tape_creation_date;
        RETURN;
      IFEND;

    = fsc$tape_expiration_date =
      dt.date_format := osc$ordinal_date;
      dt.ordinal := attachment.tape_expiration_date;
      pmp$change_legible_date_format (osc$ordinal_date, dt, status);
      IF status.normal THEN
        tape_attachments [fsc$tape_expiration_date].tape_attachment.selector := fsc$tape_expiration_date;
        tape_attachments [fsc$tape_expiration_date].tape_attachment.tape_expiration_date :=
              attachment.tape_expiration_date;
        RETURN;
      IFEND;

    = fsc$tape_file_accessibility =
      rmp$validate_ansi_string (attachment.tape_file_accessibility,
            tape_attachments [fsc$tape_file_accessibility].tape_attachment.tape_file_accessibility, status);
      IF status.normal THEN
        tape_attachments [fsc$tape_file_accessibility].tape_attachment.selector :=
              fsc$tape_file_accessibility;
        RETURN;
      IFEND;

    = fsc$tape_file_identifier =
      rmp$validate_ansi_string (attachment.tape_file_identifier, tape_attachments [fsc$tape_file_identifier].
            tape_attachment.tape_file_identifier, status);
      IF status.normal THEN
        tape_attachments [fsc$tape_file_identifier].tape_attachment.selector := fsc$tape_file_identifier;
        RETURN;
      IFEND;

    = fsc$tape_file_sequence_number =
      IF (attachment.tape_file_sequence_number >= 1) AND
            (attachment.tape_file_sequence_number <= 9999) THEN
        tape_attachments [fsc$tape_file_sequence_number].tape_attachment.selector :=
              fsc$tape_file_sequence_number;
        tape_attachments [fsc$tape_file_sequence_number].tape_attachment.tape_file_sequence_number :=
              attachment.tape_file_sequence_number;
        RETURN;
      IFEND;

    = fsc$tape_file_set_identifier =
      rmp$validate_ansi_string (attachment.tape_file_set_identifier,
            tape_attachments [fsc$tape_file_set_identifier].tape_attachment.tape_file_set_identifier, status);
      IF status.normal THEN
        tape_attachments [fsc$tape_file_set_identifier].tape_attachment.selector :=
              fsc$tape_file_set_identifier;
        RETURN;
      IFEND;

    = fsc$tape_file_set_position =
      IF (attachment.tape_file_set_position.position >= LOWERVALUE (fst$tape_file_set_pos_choices)) AND
            (attachment.tape_file_set_position.position <= UPPERVALUE (fst$tape_file_set_pos_choices))
            THEN
        tape_attachments [fsc$tape_file_set_position].tape_attachment.selector := fsc$tape_file_set_position;
        tape_attachments [fsc$tape_file_set_position].tape_attachment.tape_file_set_position :=
              attachment.tape_file_set_position;
        IF attachment.tape_file_set_position.position = fsc$tape_file_identifier_pos THEN
          rmp$validate_ansi_string (attachment.tape_file_set_position.file_identifier,
                tape_attachments [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.
                file_identifier, status);
        IFEND;
        IF status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    = fsc$tape_generation_number =
      IF (attachment.tape_generation_number >= 1) AND (attachment.tape_generation_number <= 9999) THEN
        tape_attachments [fsc$tape_generation_number].tape_attachment.selector := fsc$tape_generation_number;
        tape_attachments [fsc$tape_generation_number].tape_attachment.tape_generation_number :=
              attachment.tape_generation_number;
        RETURN;
      IFEND;

    = fsc$tape_generation_version_num =
      IF (attachment.tape_generation_version_num >= 0) AND
            (attachment.tape_generation_version_num <= 99) THEN
        tape_attachments [fsc$tape_generation_version_num].tape_attachment.selector :=
              fsc$tape_generation_version_num;
        tape_attachments [fsc$tape_generation_version_num].tape_attachment.tape_generation_version_num :=
              attachment.tape_generation_version_num;
        RETURN;
      IFEND;

    = fsc$tape_implementation_id =
      rmp$validate_ansi_string (attachment.tape_implementation_id,
            tape_attachments [fsc$tape_implementation_id].tape_attachment.tape_implementation_id, status);
      IF status.normal THEN
        tape_attachments [fsc$tape_implementation_id].tape_attachment.selector := fsc$tape_implementation_id;
        RETURN;
      IFEND;

    = fsc$tape_label_standard_version =
      IF (attachment.tape_label_standard_version >= 0) AND (attachment.tape_label_standard_version
            <= 9) THEN
        tape_attachments [fsc$tape_label_standard_version].tape_attachment.selector :=
              fsc$tape_label_standard_version;
        tape_attachments [fsc$tape_label_standard_version].tape_attachment.tape_label_standard_version :=
              attachment.tape_label_standard_version;
        RETURN;
      IFEND;

    = fsc$tape_max_block_length =
      IF (attachment.tape_max_block_length >= LOWERVALUE (amt$max_block_length)) AND
            (attachment.tape_max_block_length <= UPPERVALUE (amt$max_block_length)) THEN
        tape_attachments [fsc$tape_max_block_length].tape_attachment.selector := fsc$tape_max_block_length;
        tape_attachments [fsc$tape_max_block_length].tape_attachment.tape_max_block_length :=
              attachment.tape_max_block_length;
        RETURN;
      IFEND;

    = fsc$tape_max_record_length =
      IF (attachment.tape_max_record_length >= LOWERVALUE (amt$max_record_length)) AND
            (attachment.tape_max_record_length <= UPPERVALUE (amt$max_record_length)) THEN
        tape_attachments [fsc$tape_max_record_length].tape_attachment.selector := fsc$tape_max_record_length;
        tape_attachments [fsc$tape_max_record_length].tape_attachment.tape_max_record_length :=
              attachment.tape_max_record_length;
        RETURN;
      IFEND;

    = fsc$tape_owner_identification =
      rmp$validate_ansi_string (attachment.tape_owner_identification,
            tape_attachments [fsc$tape_owner_identification].tape_attachment.tape_owner_identification,
            status);
      IF status.normal THEN
        tape_attachments [fsc$tape_owner_identification].tape_attachment.selector :=
              fsc$tape_owner_identification;
        RETURN;
      IFEND;

    = fsc$tape_padding_character =
      IF (attachment.tape_padding_character >= LOWERVALUE (amt$padding_character)) AND
            (attachment.tape_padding_character <= UPPERVALUE (amt$padding_character)) THEN
        tape_attachments [fsc$tape_padding_character].tape_attachment.selector := fsc$tape_padding_character;
        tape_attachments [fsc$tape_padding_character].tape_attachment.tape_padding_character :=
               attachment.tape_padding_character;
        RETURN;
      IFEND;

    = fsc$tape_record_type =
      IF (attachment.tape_record_type >= LOWERVALUE (amt$record_type)) AND
            (attachment.tape_record_type <= UPPERVALUE (amt$record_type)) THEN
        tape_attachments [fsc$tape_record_type].tape_attachment.selector := fsc$tape_record_type;
        tape_attachments [fsc$tape_record_type].tape_attachment.tape_record_type :=
               attachment.tape_record_type;
        RETURN;
      IFEND;

    = fsc$tape_removable_media_group =
      rmp$validate_ansi_string (attachment.tape_removable_media_group,
            tape_attachments [fsc$tape_removable_media_group].tape_attachment.tape_removable_media_group,
            status);
      IF status.normal THEN
        tape_attachments [fsc$tape_removable_media_group].tape_attachment.selector :=
              fsc$tape_removable_media_group;
        RETURN;
      IFEND;

    = fsc$tape_rewrite_labels =
      IF (attachment.tape_rewrite_labels >= LOWERVALUE (boolean)) AND
            (attachment.tape_rewrite_labels <= UPPERVALUE (boolean)) THEN
        tape_attachments [fsc$tape_rewrite_labels].tape_attachment.selector := fsc$tape_rewrite_labels;
        tape_attachments [fsc$tape_rewrite_labels].tape_attachment.tape_rewrite_labels :=
               attachment.tape_rewrite_labels;
        RETURN;
      IFEND;

    = fsc$tape_volume_accessibility =
      rmp$validate_ansi_string (attachment.tape_volume_accessibility,
            tape_attachments [fsc$tape_volume_accessibility].tape_attachment.tape_volume_accessibility,
            status);
      IF status.normal THEN
        tape_attachments [fsc$tape_volume_accessibility].tape_attachment.selector :=
              fsc$tape_volume_accessibility;
        RETURN;
      IFEND;

    = fsc$tape_volume_initialization =
      IF attachment.tape_volume_initialization <> NIL THEN
        tape_attachments [fsc$tape_volume_initialization].tape_attachment.selector :=
              fsc$tape_volume_initialization;
        tape_attachments [fsc$tape_volume_initialization].tape_attachment.tape_volume_initialization :=
              attachment.tape_volume_initialization;
        RETURN;
      IFEND;

    = fsc$tape_null_attachment_option, fsc$tape_block_count, fsc$tape_file_section_number,
      fsc$tape_header_labels, fsc$tape_trailer_labels =
      RETURN;

    ELSE
      ;
    CASEND;

    status_reporting_procedure_ptr^ (ame$improper_file_attrib_value, 'FILE_ATTACHMENT', status);
    STRINGREP (status_parameter_string, string_length, 'TAPE_ATTACHMENT - ',
          tape_attachment_names [attachment.selector]);
    osp$append_status_parameter (osc$status_parameter_delimiter, status_parameter_string (1, string_length),
          status);

  PROCEND store_tape_attachment;
?? TITLE := 'validate_tape_attachments', EJECT ??

  PROCEDURE validate_tape_attachments (
        evaluated_file_reference: fst$evaluated_file_reference;
        specified: array [1 .. tape_attach_choice_limit] of boolean;
    VAR tape_attachments: fst$attachment_options;
    VAR status: ost$status);

    VAR
      authorized_access: fst$file_access_options,
      blank_label_group: ^SEQ ( * ),
      command_attribute: array [1 .. 1] of fst$attachment_option,
      eof1_p: ^fst$ansi_eof1_label,
      eof2_p: ^fst$ansi_eof2_label,
      hdr1_p: ^fst$ansi_hdr1_label,
      hdr2_string: ^string (80),
      ignore_status: ost$status,
      label_identifier: fst$tape_label_identifier,
      label_locator: fst$tape_label_locator,
      label_standard_version_str: string (2),
      length: integer,
      returned_attribute: fst$tla_returned_attributes,
      rewrite_labels: boolean,
      sequence_header: ^fst$tape_label_sequence_header,
      source: fst$tape_attribute_source,
      str: ost$string,
      vol1_p: ^fst$ansi_vol1_label;

    status.normal := TRUE;

    IF NOT specified [fsc$tape_rewrite_labels] THEN
      command_attribute [1].selector := fsc$tape_attachment;
      command_attribute [1].tape_attachment.selector := fsc$tape_rewrite_labels;
      source := fsc$tla_next_position;
      bap$get_tape_label_attributes (evaluated_file_reference, source, command_attribute, returned_attribute,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      rewrite_labels := command_attribute [1].tape_attachment.tape_rewrite_labels;
    ELSE
      rewrite_labels := tape_attachments [fsc$tape_rewrite_labels].tape_attachment.tape_rewrite_labels;
    IFEND;

    {  Validate file_set_position options  }

    IF specified [fsc$tape_file_set_position] THEN
      CASE tape_attachments [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.position OF

      = fsc$tape_file_identifier_pos =

        IF rewrite_labels THEN

          IF specified [fsc$tape_file_sequence_number] THEN
            osp$set_status_abnormal (amc$access_method_id,
                 ame$file_seq_number_illegal, '', status);
            RETURN;
          IFEND;

        ELSE  {  rewrite_labels is FALSE  }

          IF specified [fsc$tape_file_identifier] THEN
            IF (tape_attachments [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.
                 file_identifier = tape_attachments [fsc$tape_file_identifier].
                 tape_attachment.tape_file_identifier) THEN
              tape_attachments [fsc$tape_file_identifier].tape_attachment.selector :=
                   fsc$tape_null_attachment_option;
            ELSE
              osp$set_status_abnormal (amc$access_method_id, ame$file_identifier_mismatch,
                   tape_attachments [fsc$tape_file_identifier].tape_attachment.
                   tape_file_identifier, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                   tape_attachments [fsc$tape_file_set_position].tape_attachment.
                   tape_file_set_position.file_identifier, status);
              RETURN;
            IFEND;
          IFEND;

          IF specified [fsc$tape_generation_number] THEN
            IF (tape_attachments [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.
                 generation_number = tape_attachments [fsc$tape_generation_number].
                 tape_attachment.tape_generation_number) THEN
              tape_attachments [fsc$tape_generation_number].tape_attachment.selector :=
                   fsc$tape_null_attachment_option;
            ELSE
              str.value := '';
              str.size := 0;
              clp$convert_integer_to_string (tape_attachments [fsc$tape_generation_number].
                   tape_attachment.tape_generation_number, 10, FALSE, str, ignore_status);
              osp$set_status_abnormal (amc$access_method_id,
                   ame$generation_number_mismatch, str.value (1, str.size), status);
              str.value := '';
              str.size := 0;
              clp$convert_integer_to_string (tape_attachments [fsc$tape_file_set_position].
                   tape_attachment.tape_file_set_position.generation_number, 10, FALSE, str, ignore_status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                   str.value (1, str.size), status);
              RETURN;
            IFEND;
          IFEND;

          IF specified [fsc$tape_file_sequence_number] THEN
            osp$set_status_abnormal (amc$access_method_id,
                 ame$file_seq_number_illegal, '', status);
            RETURN;
          IFEND;
        IFEND;

      = fsc$tape_file_sequence_pos =

        IF specified [fsc$tape_file_sequence_number] THEN
          IF (tape_attachments [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.
               file_sequence_number = tape_attachments [fsc$tape_file_sequence_number].
               tape_attachment.tape_file_sequence_number) THEN
            tape_attachments [fsc$tape_file_sequence_number].tape_attachment.selector :=
                 fsc$tape_null_attachment_option;
          ELSE
            str.value := '';
            str.size := 0;
            clp$convert_integer_to_string (tape_attachments [fsc$tape_file_sequence_number].
                 tape_attachment.tape_file_sequence_number, 10, FALSE, str, ignore_status);
            osp$set_status_abnormal (amc$access_method_id,
                 ame$file_seq_number_mismatch, str.value (1, str.size), status);
            str.value := '';
            str.size := 0;
            clp$convert_integer_to_string (tape_attachments [fsc$tape_file_set_position].
                 tape_attachment.tape_file_set_position.file_sequence_number, 10, FALSE,
                 str, ignore_status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                 str.value (1, str.size), status);
            RETURN;
          IFEND;
        IFEND;

      ELSE
        ;
      CASEND;

    IFEND;

    IF specified [fsc$tape_implementation_id] OR specified [fsc$tape_label_standard_version] THEN
      IF NOT (avp$removable_media_operator ()) THEN
        osp$set_status_abnormal ('OF', ofe$sou_not_active, 'removable_media_operator', status);
        RETURN;
      IFEND;
    IFEND;

    IF specified [fsc$tape_owner_identification] AND specified [fsc$tape_removable_media_group] THEN
      osp$set_status_abnormal ('AM', rme$ambiguous_specifications, '', status);
      RETURN;
     IFEND;

    IF specified [fsc$tape_volume_initialization] THEN
      IF NOT (avp$removable_media_operator ()) THEN
        osp$set_status_abnormal ('OF', ofe$sou_not_active, 'removable_media_operator', status);
        RETURN;
      IFEND;
      IF tape_attachments [fsc$tape_volume_initialization].tape_attachment.tape_volume_initialization^.
            blank_label_group <> NIL THEN
        blank_label_group := tape_attachments [fsc$tape_volume_initialization].tape_attachment.
              tape_volume_initialization^.blank_label_group;
        IF specified [fsc$tape_character_set] THEN
          RESET blank_label_group;
          NEXT sequence_header IN blank_label_group;
          sequence_header^.character_set := tape_attachments [fsc$tape_character_set].tape_attachment.
                tape_character_set;
        IFEND;

        label_identifier.location_method := fsc$tape_label_locate_by_kind;
        label_identifier.label_kind := fsc$ansi_vol1_label_kind;
        fsp$locate_tape_label (blank_label_group, label_identifier, label_locator);
        IF label_locator.label_found THEN
          NEXT vol1_p IN label_locator.label_block;
          IF specified [fsc$tape_volume_accessibility] THEN
            vol1_p^.accessibility := tape_attachments [fsc$tape_volume_accessibility].tape_attachment.
                  tape_volume_accessibility;
          IFEND;
          IF specified [fsc$tape_implementation_id] THEN
            vol1_p^.implementation_identifier := tape_attachments [fsc$tape_implementation_id].
                  tape_attachment.tape_implementation_id;
          IFEND;
          IF specified [fsc$tape_owner_identification] THEN
            vol1_p^.owner_identifier := tape_attachments [fsc$tape_owner_identification].tape_attachment.
                  tape_owner_identification;
          ELSEIF specified [fsc$tape_removable_media_group] THEN
            vol1_p^.owner_identifier (1, 1) := '&';
            vol1_p^.owner_identifier (2, 13) := tape_attachments [fsc$tape_removable_media_group].
                  tape_attachment.tape_removable_media_group;
          IFEND;
          IF specified [fsc$tape_label_standard_version] THEN
            STRINGREP (label_standard_version_str, length,
                  tape_attachments [fsc$tape_label_standard_version].tape_attachment.
                  tape_label_standard_version);
            vol1_p^.label_standard_version := label_standard_version_str (2,1);
          IFEND;
        ELSE
          label_identifier.location_method := fsc$tape_label_locate_by_index;
          FOR label_identifier.label_index:= 1 TO 3 DO
            fsp$locate_tape_label (blank_label_group, label_identifier, label_locator);
            IF (NOT label_locator.label_found) OR (label_locator.label_block_descriptor^.label_block_type <>
                  fsc$tapemark_tape_label_block) THEN { not unlabeled }
              osp$set_status_condition (ame$vol1_label_missing, status);
              RETURN;
            IFEND;
          FOREND;
        IFEND;

        label_identifier.label_kind := fsc$ansi_hdr1_label_kind;
        fsp$locate_tape_label (blank_label_group, label_identifier, label_locator);
        IF label_locator.label_found THEN
          NEXT hdr1_p IN label_locator.label_block;
        ELSE
          hdr1_p := NIL;
        IFEND;
        IF specified [fsc$tape_file_accessibility] OR specified [fsc$tape_implementation_id] OR
              specified [fsc$tape_removable_media_group] THEN
          IF hdr1_p = NIL THEN
            IF specified [fsc$tape_file_accessibility] THEN
              osp$set_status_abnormal ('RM', ame$hdr1_label_missing, 'FILE_ACCESSIBILITY', status);
            ELSEIF specified [fsc$tape_implementation_id] THEN
              osp$set_status_abnormal ('RM', ame$hdr1_label_missing, 'IMPLEMENTATION_IDENTIFIER', status);
            ELSE { removable_media_group specified }
              osp$set_status_abnormal ('RM', ame$hdr1_label_missing, 'REMOVABLE_MEDIA_GROUP', status);
            IFEND;
            RETURN;
          ELSE
            IF specified [fsc$tape_file_accessibility] THEN
              hdr1_p^.accessibility := tape_attachments [fsc$tape_file_accessibility].tape_attachment.
                    tape_file_accessibility;
            IFEND;
            IF specified [fsc$tape_implementation_id] THEN
              hdr1_p^.system_code := tape_attachments [fsc$tape_implementation_id].tape_attachment.
                    tape_implementation_id;
            IFEND;
            IF specified [fsc$tape_removable_media_group] AND (hdr1_p^.system_code <>
                  fsc$version_two_ve_identifier) THEN
              osp$set_status_abnormal ('RM', rme$rmg_parameter_conflict, 'IMPLEMENTATION_IDENTIFIER', status);
              RETURN;
            IFEND;
          IFEND;

          label_identifier.label_kind := fsc$ansi_eof1_label_kind;
          fsp$locate_tape_label (blank_label_group, label_identifier, label_locator);
          IF label_locator.label_found THEN
            NEXT eof1_p IN label_locator.label_block;
            IF specified [fsc$tape_file_accessibility] THEN
              eof1_p^.accessibility := tape_attachments [fsc$tape_file_accessibility].tape_attachment.
                    tape_file_accessibility;
            IFEND;
            IF specified [fsc$tape_implementation_id] THEN
              eof1_p^.system_code := tape_attachments [fsc$tape_implementation_id].tape_attachment.
                    tape_implementation_id;
            IFEND;
          IFEND;
        IFEND;

        IF (hdr1_p <> NIL) AND fsp$ve_wrote_ansi_file (hdr1_p^.system_code) THEN
          label_identifier.label_kind := fsc$ansi_hdr2_label_kind;
          fsp$locate_tape_label (blank_label_group, label_identifier, label_locator);
          IF NOT label_locator.label_found THEN
            osp$set_status_condition (ame$hdr2_label_missing, status);
          IFEND;
        IFEND;
      IFEND; { blank_label_group <> NIL }

    ELSEIF specified [fsc$tape_removable_media_group] THEN
      rmp$validate_specified_rmg (evaluated_file_reference, tape_attachments [fsc$tape_removable_media_group].
            tape_attachment.tape_removable_media_group, authorized_access, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND validate_tape_attachments;
?? TITLE := 'attach_or_create_file', EJECT ??

  PROCEDURE attach_or_create_file
    (   task_file_index: bat$tft_limit;
        access_level: amt$access_level;
        file_attachment: ^fst$attachment_options;
        access_and_share_modes_count: integer;
        retention: fst$retention;
        retrieve_option: pft$retrieve_option;
        site_archive_option: pft$site_archive_option;
        site_backup_option: pft$site_backup_option;
        site_release_option: pft$site_release_option;
    VAR single_choice_attachments: {i/o} single_choice_attachments_type;
    VAR open_cleanup_work_list: fmt$open_cleanup_work_list;
    VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
    VAR preserved_attributes: bat$system_file_attributes;
    VAR open_count: integer;
    VAR device_class: rmt$device_class;
    VAR opened_access_modes: bat$access_counts;
    VAR archive_cycle_number: pft$cycle_number;
    VAR cd_attachment_options: fmt$cd_attachment_options;
        status_reporting_procedure_ptr: fst$status_reporting_procedure;
    VAR status: ost$status);

    VAR
      action_taken: pft$attach_or_create_action,
      allowed_access: fst$file_access_options,
      attached_file: boolean,
      attachments: ^fst$attachment_options,
      converted_open_share_modes: pft$usage_selections,
      cycle_description_created: boolean,
      device_assigned: boolean,
      exception_selection_info: pft$exception_selection_info,
      file_previously_opened: boolean,
      fs_device_class: fst$device_class,
      global_file_information: bat$global_file_information,
      i: integer,
      ignore_cycle_description: ^fmt$cycle_description,
      j: integer,
      label_used: boolean,
      local_file: boolean,
      minimum_number_of_path_elements: 2 .. 3,
      open_position: amt$open_position,
      open_position_source: amt$attribute_source,
      open_share_modes: fst$file_access_options,
      path_ptr: ^fst$path,
      path_size: fst$path_size,
      required_sharing: fst$file_access_options,
      restricted_access_modes: pft$usage_selections,
      selected_access: fst$file_access_options,
      selected_sharing: fst$file_access_options,
      temporary_file: boolean,
      validation_modes: fst$file_access_options;

    status.normal := TRUE;

    temporary_file := (fsp$path_element (^evaluated_file_reference, 1)^ = fsc$local);
{ At this point a permanent file ALIAS is considered a temporary file.
    IF temporary_file THEN
      minimum_number_of_path_elements := 2;
    ELSE
      minimum_number_of_path_elements := 3;
    IFEND;

    IF evaluated_file_reference.number_of_path_elements <
          minimum_number_of_path_elements THEN
      PUSH path_ptr;
      clp$convert_file_ref_to_string (evaluated_file_reference,
            {include_open_position} FALSE, path_ptr^, path_size, status);
      osp$set_status_abnormal (amc$access_method_id, pfe$path_too_short, '',
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            path_ptr^ (1, path_size), status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            minimum_number_of_path_elements, 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'file',
            status);
      RETURN;
    IFEND;

    IF single_choice_attachments [sca_open_position].selector = fsc$open_position THEN
      open_position := single_choice_attachments [sca_open_position].open_position;
      open_position_source := amc$open_request;
    ELSEIF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
      open_position := evaluated_file_reference.path_handle_info.path_handle.open_position.value;
      open_position_source := amc$file_reference;
      evaluated_file_reference.path_handle_info.path_handle.open_position.specified := FALSE;
    ELSE
      open_position := amc$open_at_boi;
      open_position_source := amc$access_method_default;
    IFEND;

    IF temporary_file THEN {could be an alias
{
{  In addition to resolving and creating a cycle_description for a file,
{  fmp$create_cycle_description also returns the permanent file path of an alias.
{  A cycle_description will not be created, because by definition a permanent file
{  alias already has a cycle_description.
{
      fmp$create_cycle_description ({return_cycle_description=} FALSE, evaluated_file_reference,
            cycle_description_created, ignore_cycle_description, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF cycle_description_created THEN
        bav$task_file_table^ [task_file_index].open_actions.open_created_file :=
              TRUE;
      IFEND;
      temporary_file := (fsp$path_element (^evaluated_file_reference, 1)^ = fsc$local);
{ At this point a permanent file ALIAS is NOT considered a temporary file.
    IFEND;

    IF NOT temporary_file THEN
      PUSH attachments: [1 .. number_of_single_choice_attach +
                access_and_share_modes_count];
      i#move (^single_choice_attachments, attachments,
            #SIZE(single_choice_attachments));
      IF access_and_share_modes_count > 0 THEN
        preserved_attributes.dynamic_label.access_mode_source :=
              amc$open_request;
        j := number_of_single_choice_attach;
        FOR i := 1 TO UPPERBOUND (file_attachment^) DO
          IF file_attachment^ [i].selector = fsc$access_and_share_modes THEN
            j := j + 1;
            attachments^ [j] := file_attachment^ [i];
          IFEND;
        FOREND;
      IFEND;

      exception_selection_info.delete_data := single_choice_attachments [sca_delete_data].delete_data;
      exception_selection_info.open_position := open_position;
      exception_selection_info.open_position_source := open_position_source;
      exception_selection_info.access_level := access_level;

      pfp$r3_attach_or_create_file (single_choice_attachments [sca_validation_ring].validation_ring,
            exception_selection_info, attachments, {p_file_label} NIL, retention, retrieve_option,
            site_archive_option, site_backup_option, site_release_option, evaluated_file_reference,
            allowed_access, selected_access, required_sharing, selected_sharing, action_taken,
            label_used, device_class, status);
      IF NOT status.normal THEN
        IF status.condition = pfe$invalid_ring_access THEN
          status_reporting_procedure_ptr^ (ame$ring_validation_error,
                'attach or create', status);
        ELSEIF status.condition = fse$device_class_conflict THEN
          status_reporting_procedure_ptr^ (fse$device_class_conflict,
                amv$device_class_names [device_class].name, status);
        ELSEIF status.condition = pfe$unknown_permanent_file THEN
          status_reporting_procedure_ptr^ (ame$file_not_known,
                'pf attach or create', status);
        ELSEIF (status.condition = pfe$cycle_busy) AND (action_taken <>
              pfc$cycle_busy_elsewhere) THEN
          { cycle is attached within the current job }
          status_reporting_procedure_ptr^ (fse$redundant_attach_conflict,
                'cycle busy within job', status);
        ELSEIF (status.condition = pfe$cycle_data_resides_offline) THEN
          archive_cycle_number := evaluated_file_reference.cycle_reference.cycle_number;
        IFEND;
        RETURN;
      ELSE
        IF action_taken = pfc$cycle_created THEN
          bav$task_file_table^ [task_file_index].open_actions.open_created_file
                := TRUE;
        ELSEIF action_taken = pfc$cycle_newly_attached THEN
          bav$task_file_table^ [task_file_index].open_actions.open_attached_file
                := TRUE;
        IFEND;
      IFEND;
    IFEND;

    fmp$get_cd_info (evaluated_file_reference, {increment_open_count} TRUE, {lock_path_table} temporary_file,
          open_cleanup_work_list, preserved_attributes.static_label,
          preserved_attributes.dynamic_label,
          preserved_attributes.descriptive_label, global_file_information,
          local_file, attached_file, file_previously_opened, device_assigned,
          device_class, cd_attachment_options, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF temporary_file THEN
      fsp$convert_device_class_to_fs (device_class, fs_device_class);
      IF NOT (fs_device_class IN
            single_choice_attachments [sca_allowed_device_classes].allowed_device_classes) THEN
        status_reporting_procedure_ptr^ (fse$device_class_conflict,
              amv$device_class_names [device_class].name, status);
        RETURN;
      IFEND;
    IFEND;

    open_count := global_file_information.open_count;
    opened_access_modes := global_file_information.opened_access_modes;
    bav$task_file_table^ [task_file_index].initial_open := NOT file_previously_opened;

    IF open_position_source <> amc$access_method_default THEN
      preserved_attributes.dynamic_label.open_position := open_position;
      preserved_attributes.dynamic_label.open_position_source := open_position_source;
    IFEND;

    IF (preserved_attributes.dynamic_label.open_position_source =
          amc$access_method_default) AND temporary_file THEN
      IF (fsp$path_element (^evaluated_file_reference, 2)^ = 'OUTPUT') THEN
        preserved_attributes.dynamic_label.open_position := amc$open_at_eoi;
      IFEND;
    IFEND;

    merge_attachments (single_choice_attachments, preserved_attributes.
          dynamic_label, status_reporting_procedure_ptr, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF attached_file THEN
      IF open_count = 1 THEN
        IF temporary_file THEN
          assign_access_modes (file_attachment, preserved_attributes.
                descriptive_label.global_access_mode, preserved_attributes.
                dynamic_label.access_mode, preserved_attributes.dynamic_label.
                access_mode_source);
        ELSE
          #unchecked_conversion (selected_access, preserved_attributes.dynamic_label.access_mode);
          preserved_attributes.dynamic_label.access_mode_source :=
                amc$open_request;
        IFEND;

      ELSE
        determine_open_share_modes (global_file_information.
              prevented_open_access_modes, open_share_modes);
        IF temporary_file THEN
          IF fsp$strictly_null_device (device_class, fsp$path_element (^evaluated_file_reference, 2)^) THEN
            open_share_modes := -$fst$file_access_options [];
          IFEND;
          #unchecked_conversion (open_share_modes, converted_open_share_modes);
          restricted_access_modes := converted_open_share_modes * preserved_attributes.
                descriptive_label.global_access_mode;
          #unchecked_conversion (restricted_access_modes, validation_modes);
          validate_access_modes (file_attachment, validation_modes,
                preserved_attributes.dynamic_label.access_mode,
                preserved_attributes.dynamic_label.access_mode_source,
                status_reporting_procedure_ptr, status);
          IF NOT status.normal THEN
           RETURN;
          IFEND;
        ELSEIF selected_access <= open_share_modes THEN
          #unchecked_conversion (selected_access, preserved_attributes.
                dynamic_label.access_mode);
          preserved_attributes.dynamic_label.access_mode_source :=
                amc$open_request;
        ELSE
          access_or_share_conflict (fse$concurrent_access_conflict,
                (open_share_modes * allowed_access), selected_access,
                status_reporting_procedure_ptr, status);
          RETURN;
        IFEND;
      IFEND;
    ELSE
      { validate creation of a temporary file }
      { (a permanent file should always be attached by this time) }

      IF (device_class = rmc$mass_storage_device) AND
            (single_choice_attachments [sca_create_file].selector =
            fsc$create_file) AND (NOT single_choice_attachments
            [sca_create_file].create_file) THEN
        IF bav$task_file_table^ [task_file_index].open_actions.open_created_file THEN
          status_reporting_procedure_ptr^ (ame$file_not_known,
                'create_file cannot be false for temporary files', status);
        ELSE
          status_reporting_procedure_ptr^ (ame$new_file_requires_append,
                'create_file cannot be false for temporary files', status);
        IFEND;
        RETURN;
      ELSE
        validate_temp_creation (file_attachment, device_class,
              preserved_attributes.descriptive_label.global_access_mode,
              preserved_attributes.dynamic_label.access_mode,
              preserved_attributes.dynamic_label.access_mode_source,
              status_reporting_procedure_ptr, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    clp$construct_path_handle_name (evaluated_file_reference.path_handle_info.
         path_handle, bav$task_file_table^ [task_file_index].local_file_name);

  PROCEND attach_or_create_file;
?? TITLE := 'assign_access_modes', EJECT ??

  PROCEDURE [INLINE] assign_access_modes (file_attachment:
    ^fst$attachment_options;
        global_access_modes: pft$usage_selections;
    VAR instance_access_modes: pft$usage_selections;
    VAR instance_access_modes_source: amt$attribute_source);

    VAR
      access_modes_found: boolean,
      i: integer;

    i := 1;
    access_modes_found := FALSE;
    IF file_attachment <> NIL THEN
      WHILE (NOT access_modes_found) AND (i <= UPPERBOUND
            (file_attachment^)) DO
        IF file_attachment^ [i].selector = fsc$access_and_share_modes THEN
          IF file_attachment^ [i].access_modes.selector =
                fsc$specific_access_modes THEN
            #unchecked_conversion (file_attachment^ [i].access_modes.value,
                  instance_access_modes);
            instance_access_modes_source := amc$open_request;
            access_modes_found := TRUE;
          ELSEIF file_attachment^ [i].access_modes.selector =
                fsc$permitted_access_modes THEN
            instance_access_modes := global_access_modes;
            instance_access_modes_source := amc$access_method_default;
            access_modes_found := TRUE;
          IFEND;
        IFEND;
        i := i + 1;
      WHILEND;
    IFEND;
  PROCEND assign_access_modes;

?? TITLE := 'determine_open_share_modes', EJECT ??

  PROCEDURE [INLINE] determine_open_share_modes (prevented_open_access_modes:
    bat$access_counts;
    VAR open_share_modes: fst$file_access_options);

    VAR
      access_mode: fst$file_access_option;

    open_share_modes := $fst$file_access_options [];

    FOR access_mode := LOWERVALUE (fst$file_access_option) TO UPPERVALUE
          (fst$file_access_option) DO
      IF prevented_open_access_modes [access_mode] = 0 THEN
        open_share_modes := open_share_modes + $fst$file_access_options
          [access_mode];
      IFEND;
    FOREND;
  PROCEND determine_open_share_modes;

?? TITLE := 'merge_attachments', EJECT ??

  PROCEDURE [INLINE] merge_attachments
    (    single_choice_attachments: single_choice_attachments_type;
     VAR dynamic_label: bat$dynamic_label_attributes;
         status_reporting_procedure_ptr: fst$status_reporting_procedure;
     VAR status: ost$status);

    VAR
      i: integer,
      translated_name: pmt$program_name;

    status.normal := TRUE;

    IF single_choice_attachments [sca_error_exit_procedure_name].
            error_exit_procedure_name <> NIL THEN
      #translate (osv$lower_to_upper, single_choice_attachments [sca_error_exit_procedure_name].
          error_exit_procedure_name^.entry_point, translated_name);
    IFEND;
    IF (dynamic_label.error_exit_name_source = amc$file_command) AND
          ((single_choice_attachments [sca_error_exit_procedure].
          error_exit_procedure <> NIL) OR ((single_choice_attachments
          [sca_error_exit_procedure_name].error_exit_procedure_name <> NIL) AND
          (translated_name <> dynamic_label.error_exit_name))) THEN
      status_reporting_procedure_ptr^ (fse$redundant_attachment_choice,
            ' Error_exit_procedure', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            'error_exit_procedure_name', status);
      RETURN;
    ELSE
      IF single_choice_attachments [sca_error_exit_procedure].
            error_exit_procedure <> NIL THEN
        dynamic_label.error_exit_procedure := single_choice_attachments
             [sca_error_exit_procedure].error_exit_procedure;
        dynamic_label.error_exit_procedure_source := amc$open_request;
      IFEND;
      IF single_choice_attachments [sca_error_exit_procedure_name].
              error_exit_procedure_name <> NIL THEN
        dynamic_label.error_exit_name := translated_name;
        dynamic_label.error_exit_name_source := amc$open_request;
      IFEND;
    IFEND;

    IF single_choice_attachments [sca_label_exit_procedure_name].
            label_exit_procedure_name <> NIL THEN
      #translate (osv$lower_to_upper, single_choice_attachments [sca_label_exit_procedure_name].
          label_exit_procedure_name^.entry_point, translated_name);
    IFEND;
    IF (dynamic_label.label_exit_name_source = amc$file_command) AND
          ((single_choice_attachments [sca_label_exit_procedure].
          label_exit_procedure <> NIL) OR ((single_choice_attachments
          [sca_label_exit_procedure_name].label_exit_procedure_name <> NIL) AND
          (translated_name <> dynamic_label.label_exit_name))) THEN
      status_reporting_procedure_ptr^ (fse$redundant_attachment_choice,
             ' Label_exit_procedure', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            'label_exit_procedure_name', status);
      RETURN;
    ELSE
      IF single_choice_attachments [sca_label_exit_procedure].
            label_exit_procedure <> NIL THEN
        dynamic_label.label_exit_procedure := single_choice_attachments
              [sca_label_exit_procedure].label_exit_procedure;
        dynamic_label.label_exit_procedure_source := amc$open_request;
      IFEND;
      IF single_choice_attachments [sca_label_exit_procedure_name].
            label_exit_procedure_name <> NIL THEN
        dynamic_label.label_exit_name := translated_name;
        dynamic_label.label_exit_name_source := amc$open_request;
      IFEND;
    IFEND;

    IF single_choice_attachments [sca_error_limit].selector = fsc$error_limit THEN
      dynamic_label.error_limit := single_choice_attachments [sca_error_limit].
           error_limit;
      dynamic_label.error_limit_source := amc$open_request;
    IFEND;

    IF single_choice_attachments [sca_message_control].selector = fsc$message_control THEN
      dynamic_label.message_control := single_choice_attachments
           [sca_message_control].message_control;
      dynamic_label.message_control_source := amc$open_request;
    IFEND;

    IF single_choice_attachments [sca_tape_error_options].selector = fsc$tape_error_options THEN
      dynamic_label.error_options := single_choice_attachments
           [sca_tape_error_options].tape_error_options;
      dynamic_label.error_options_source := amc$open_request;
    IFEND;

  PROCEND merge_attachments;

?? TITLE := 'validate_access_modes', EJECT ??

  PROCEDURE [INLINE] validate_access_modes
    (    file_attachment: ^fst$attachment_options;
         validation_access_modes: fst$file_access_options;
     VAR instance_access_modes: pft$usage_selections;
     VAR instance_access_modes_source: amt$attribute_source;
         status_reporting_procedure_ptr: fst$status_reporting_procedure;
     VAR status: ost$status);

    VAR
      access_and_share_modes_index: integer,
      access_and_share_specified: boolean,
      i: integer,
      setfa_access_modes: fst$file_access_options,
      valid_access_modes_found: boolean;

    status.normal := TRUE;
    i := 0;
    access_and_share_specified := FALSE;
    valid_access_modes_found := FALSE;
    IF file_attachment <> NIL THEN
      REPEAT
        i := i + 1;
        IF file_attachment^ [i].selector = fsc$access_and_share_modes THEN
          access_and_share_specified := TRUE;
          access_and_share_modes_index := i;
          IF file_attachment^ [i].access_modes.selector =
                fsc$permitted_access_modes THEN
            #unchecked_conversion (validation_access_modes,
                  instance_access_modes);
            instance_access_modes_source := amc$access_method_default;
            valid_access_modes_found := TRUE;
          ELSEIF (file_attachment^ [i].access_modes.selector =
                fsc$specific_access_modes) AND (file_attachment^ [i].
                access_modes.value <= validation_access_modes) THEN
            #unchecked_conversion (file_attachment^ [i].access_modes.value,
                  instance_access_modes);
            instance_access_modes_source := amc$open_request;
            valid_access_modes_found := TRUE;
          IFEND;
        IFEND;
      UNTIL valid_access_modes_found OR (i = UPPERBOUND (file_attachment^));
    IFEND;

    IF access_and_share_specified THEN
      IF NOT valid_access_modes_found THEN
        access_or_share_conflict (fse$concurrent_access_conflict,
              validation_access_modes,
              file_attachment^ [access_and_share_modes_index].access_modes.value,
              status_reporting_procedure_ptr, status);
      ELSEIF (instance_access_modes_source = amc$access_method_default) AND
            (instance_access_modes = $pft$usage_selections []) THEN
        status_reporting_procedure_ptr^ (fse$concurrent_access_conflict,
              'NONE', status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              'PERMITTED', status);
      IFEND;
    ELSEIF validation_access_modes = $fst$file_access_options [] THEN
      IF instance_access_modes_source = amc$access_method_default THEN
        status_reporting_procedure_ptr^ (fse$concurrent_access_conflict,
              'NONE', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'DEFAULT',
              status);
      ELSEIF (instance_access_modes_source = amc$file_command) AND
            (instance_access_modes <> $pft$usage_selections []) THEN
        #unchecked_conversion (instance_access_modes, setfa_access_modes);
        access_or_share_conflict (fse$concurrent_access_conflict,
             validation_access_modes, setfa_access_modes,
             status_reporting_procedure_ptr, status);
      IFEND;
    ELSEIF instance_access_modes_source = amc$access_method_default THEN
      #unchecked_conversion (validation_access_modes, instance_access_modes);
    IFEND;

  PROCEND validate_access_modes;

?? TITLE := 'validate_temp_creation', EJECT ??

  PROCEDURE [INLINE] validate_temp_creation
    (   file_attachment: ^fst$attachment_options;
        device_class: rmt$device_class;
        global_access_modes: pft$usage_selections;
    VAR instance_access_modes: pft$usage_selections;
    VAR instance_access_modes_source: amt$attribute_source;
        status_reporting_procedure_ptr: fst$status_reporting_procedure;
    VAR status: ost$status);

    VAR
      access_and_share_specified: boolean,
      i: integer,
      valid_access_modes_found: boolean;

    status.normal := TRUE;
    i := 1;
    access_and_share_specified := FALSE;
    valid_access_modes_found := FALSE;
    IF file_attachment <> NIL THEN
      WHILE (NOT valid_access_modes_found) AND (i <= UPPERBOUND
            (file_attachment^)) DO
        IF file_attachment^ [i].selector = fsc$access_and_share_modes THEN
          access_and_share_specified := TRUE;
          IF (file_attachment^ [i].access_modes.selector =
                fsc$specific_access_modes) AND ((fsc$append IN
                file_attachment^ [i].access_modes.value) OR (device_class <>
                rmc$mass_storage_device)) THEN
            #unchecked_conversion (file_attachment^ [i].access_modes.value,
                  instance_access_modes);
            instance_access_modes_source := amc$open_request;
            valid_access_modes_found := TRUE;
          ELSEIF file_attachment^ [i].access_modes.selector =
                fsc$permitted_access_modes THEN
            instance_access_modes := global_access_modes;
            instance_access_modes_source := amc$open_request;
            valid_access_modes_found := TRUE;
          IFEND;
        IFEND;
        i := i + 1;
      WHILEND;
    IFEND;
    IF access_and_share_specified THEN
      IF NOT valid_access_modes_found THEN
        status_reporting_procedure_ptr^ (ame$new_file_requires_append,
              'temporary create', status);
      IFEND;
    ELSEIF instance_access_modes_source = amc$access_method_default THEN
      instance_access_modes := global_access_modes;
    IFEND;

  PROCEND validate_temp_creation;

?? TITLE := 'process_file_attributes', EJECT ??

  PROCEDURE process_file_attributes
    (   evaluated_file_reference: fst$evaluated_file_reference;
        access_level: amt$access_level;
        default_creation_attributes: ^fst$file_cycle_attributes;
        mandated_creation_attributes: ^fst$file_cycle_attributes;
        attribute_validation: ^fst$file_cycle_attributes;
        attribute_override: ^fst$file_cycle_attributes;
        validation_ring: ost$valid_ring;
        caller_ring: ost$valid_ring;
        file_previously_opened: boolean;
        device_class: rmt$device_class;
    VAR merged_tape_attributes {input, output} : fst$tape_attachment_information;
    VAR preserved_attributes {input, output} : bat$system_file_attributes;
    VAR instance_attributes: bat$instance_attributes;
    VAR access_mode_includes_write: boolean;
        status_reporting_procedure_ptr: fst$status_reporting_procedure;
    VAR status: ost$status);

    VAR
      attributes_validated: boolean,
      target_exists: boolean,
      target_static_attrs: ^bat$static_label_attributes;

    status.normal := TRUE;
    attributes_validated := FALSE;
    target_exists := FALSE;

    { The following chart shows the action taken with respect to validating
    { attributes:
    { SUBJECT  TARGET         ACTION
    { new      new            no validation
    { new      old            validate target
    { old      new            no validation
    { old      old            validate target
    { new      no connection  no validation
    { old      no connection  validate subject

    IF device_class = rmc$connected_file_device THEN
      PUSH target_static_attrs;
      get_connected_file_attributes (evaluated_file_reference,
            target_static_attrs^, target_exists, status);
      IF target_exists AND (attribute_validation <> NIL) AND (NOT (
         (evaluated_file_reference.path_handle_info.path_handle.segment_offset =
         clv$standard_files [clc$sf_null_file].path_handle.segment_offset) AND
         (evaluated_file_reference.path_handle_info.path_handle.assignment_counter =
         clv$standard_files [clc$sf_null_file].path_handle.assignment_counter)))
         THEN
        validate_attributes (attribute_validation,
              access_mode_includes_write, target_static_attrs^,
              status_reporting_procedure_ptr, status);
        attributes_validated := TRUE;
      IFEND;
    ELSEIF device_class = rmc$magnetic_tape_device THEN
      bap$merge_tape_attributes (default_creation_attributes, mandated_creation_attributes,
            merged_tape_attributes, preserved_attributes.static_label);
      IF merged_tape_attributes.file_set_position_source = fsc$tape_label_attr_command THEN
        IF merged_tape_attributes.file_set_position.position = fsc$tape_file_identifier_pos THEN
          IF (NOT (fsc$fsp_file_identifier IN merged_tape_attributes.supplied_file_set_pos_fields)) AND
                (merged_tape_attributes.file_identifier_source = fsc$tape_label_attr_default) THEN
            bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_identifier_required, '', '',
                  status);
            RETURN;
          IFEND;
        ELSEIF merged_tape_attributes.file_set_position.position = fsc$tape_file_sequence_pos THEN
          IF (NOT (fsc$fsp_file_sequence_number IN merged_tape_attributes.supplied_file_set_pos_fields)) AND
                (merged_tape_attributes.file_sequence_number_source = fsc$tape_label_attr_default) THEN
            bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_seq_number_required, '', '',
                  status);
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF file_previously_opened THEN
      validate_access_at_open (validation_ring, caller_ring,
            preserved_attributes.static_label.ring_attributes,
            preserved_attributes.descriptive_label.global_access_mode,
            preserved_attributes.dynamic_label.access_mode_source =
            amc$access_method_default, preserved_attributes.dynamic_label.
            access_mode, access_mode_includes_write,
            status_reporting_procedure_ptr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      assign_instance_attributes (preserved_attributes, instance_attributes);
    ELSE
      IF mandated_creation_attributes <> NIL THEN
        bap$merge_open_attributes (mandated_creation_attributes,
              amc$open_request, preserved_attributes.static_label,
              status_reporting_procedure_ptr, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      IF default_creation_attributes <> NIL THEN
        bap$merge_open_attributes (default_creation_attributes,
              amc$file_request, preserved_attributes.static_label,
              status_reporting_procedure_ptr, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      set_default_attributes (access_level, device_class, validation_ring,
            preserved_attributes.static_label);
      validate_merged_static_attr (validation_ring,
            preserved_attributes.static_label, device_class,
            status_reporting_procedure_ptr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      validate_access_at_open (validation_ring, caller_ring,
            preserved_attributes.static_label.ring_attributes,
            preserved_attributes.descriptive_label.global_access_mode,
            preserved_attributes.dynamic_label.access_mode_source =
            amc$access_method_default, preserved_attributes.dynamic_label.
            access_mode, access_mode_includes_write,
            status_reporting_procedure_ptr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      assign_instance_attributes (preserved_attributes, instance_attributes);
    IFEND;

    IF (NOT attributes_validated) AND (attribute_validation <> NIL) AND (NOT (
 {NOT $NULL
         (evaluated_file_reference.path_handle_info.path_handle.segment_offset =
         clv$standard_files [clc$sf_null_file].path_handle.segment_offset) AND
         (evaluated_file_reference.path_handle_info.path_handle.assignment_counter =
         clv$standard_files [clc$sf_null_file].path_handle.assignment_counter)))
         THEN
      validate_attributes (attribute_validation,
            access_mode_includes_write, preserved_attributes.static_label,
            status_reporting_procedure_ptr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF attribute_override <> NIL THEN
      override_attributes (access_level, caller_ring, device_class,
            attribute_override, access_mode_includes_write,
            preserved_attributes.dynamic_label.access_mode,
            preserved_attributes.dynamic_label.open_position,
            instance_attributes.static_label,
            status_reporting_procedure_ptr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{   validate_fo_access_level
    IF (instance_attributes.static_label.file_organization IN
          amv$aam_file_organizations) AND (access_level <> amc$record) THEN
      status_reporting_procedure_ptr^ (ame$fo_access_level_conflict,
            amv$file_organization_names [instance_attributes.static_label.file_organization].name, status);
      RETURN;
    IFEND;

{   default_open_position
    IF (device_class = rmc$mass_storage_device) AND
        ((instance_attributes.dynamic_label.open_position_source =
        amc$access_method_default) OR
        (instance_attributes.dynamic_label.open_position_source =
        amc$undefined_attribute)) AND
        (instance_attributes.dynamic_label.access_mode =
        $pft$usage_selections [pfc$append]) THEN
         instance_attributes.dynamic_label.open_position := amc$open_at_eoi;
         instance_attributes.dynamic_label.open_position_source := amc$open_request;
    IFEND;

    validate_device_class (device_class, instance_attributes.
          static_label.file_organization, access_level,
          status_reporting_procedure_ptr, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND process_file_attributes;

?? TITLE := 'PROCEDURE get_catalog_cycle_attributes', EJECT ??

  PROCEDURE get_catalog_cycle_attributes
    (    mandated_creation_attributes: ^fst$file_cycle_attributes;
         default_creation_attributes: ^fst$file_cycle_attributes;
     VAR retention: fst$retention;
     VAR retrieve_option: pft$retrieve_option;
     VAR site_archive_option: pft$site_archive_option;
     VAR site_backup_option: pft$site_backup_option;
     VAR site_release_option: pft$site_release_option);

    VAR
      attribute_index: integer,
      retention_mandated: boolean,
      retention_specified: boolean,
      retrieve_option_mandated: boolean,
      site_archive_option_mandated: boolean,
      site_backup_option_mandated: boolean,
      site_release_option_mandated: boolean;

    retention_mandated := FALSE;
    retention_specified := FALSE;
    retrieve_option_mandated := FALSE;
    site_archive_option_mandated := FALSE;
    site_backup_option_mandated := FALSE;
    site_release_option_mandated := FALSE;

    IF fmv$default_new_retention = NIL THEN
      retention.selector := fsc$retention_day_increment;
      retention.day_increment := 999;
    ELSE
      retention := fmv$default_new_retention^;
    IFEND;

    retrieve_option := pfc$always_retrieve;
    site_backup_option := pfc$null_site_backup_option;
    site_archive_option := pfc$null_site_archive_option;
    site_release_option := pfc$null_site_release_option;

    IF mandated_creation_attributes <> NIL THEN
      FOR attribute_index := 1 TO UPPERBOUND (mandated_creation_attributes^) DO
        CASE mandated_creation_attributes^ [attribute_index].selector OF
        = fsc$retention =
          retention := mandated_creation_attributes^ [attribute_index].retention;
          retention_mandated := TRUE;
        = fsc$retrieve_option =
          retrieve_option := mandated_creation_attributes^ [attribute_index].retrieve_option;
          retrieve_option_mandated := TRUE;
        = fsc$site_archive_option =
          site_archive_option := mandated_creation_attributes^ [attribute_index].site_archive_option;
          site_archive_option_mandated := TRUE;
        = fsc$site_backup_option =
          site_backup_option := mandated_creation_attributes^ [attribute_index].site_backup_option;
          site_backup_option_mandated := TRUE;
        = fsc$site_release_option =
          site_release_option := mandated_creation_attributes^ [attribute_index].site_release_option;
          site_release_option_mandated := TRUE;
        ELSE
        CASEND;
      FOREND;
    IFEND;

    IF default_creation_attributes <> NIL THEN
      FOR attribute_index := 1 TO UPPERBOUND (default_creation_attributes^) DO
        CASE default_creation_attributes^ [attribute_index].selector OF
        = fsc$retention =
          IF NOT retention_mandated THEN
            retention := default_creation_attributes^ [attribute_index].retention;
          IFEND;
        = fsc$retrieve_option =
          IF NOT retrieve_option_mandated THEN
            retrieve_option := default_creation_attributes^ [attribute_index].retrieve_option;
          IFEND;
        = fsc$site_archive_option =
          IF NOT site_archive_option_mandated THEN
            site_archive_option := default_creation_attributes^ [attribute_index].site_archive_option;
          IFEND;
        = fsc$site_backup_option =
          IF NOT site_backup_option_mandated THEN
            site_backup_option := default_creation_attributes^ [attribute_index].site_backup_option;
          IFEND;
        = fsc$site_release_option =
          IF NOT site_release_option_mandated THEN
            site_release_option := default_creation_attributes^ [attribute_index].site_release_option;
          IFEND;
        ELSE
        CASEND;
      FOREND;
    IFEND;

  PROCEND get_catalog_cycle_attributes;

?? TITLE := 'get_connected_file_attributes', EJECT ??

  PROCEDURE get_connected_file_attributes
    (    evaluated_file_reference: fst$evaluated_file_reference;
     VAR target_static_attrs: bat$static_label_attributes;
     VAR target_exists: boolean;
     VAR status: ost$status);

    VAR
      path: fst$path,
      path_size: fst$path_size,
      target_cpn: amt$compression_procedure_name,
      target_hpn: amt$hashing_procedure_name,
      target_lr: amt$log_residence,
      target_attr: array [1 .. 47] of amt$get_item,
      target_contains_data,
      target_local_file: boolean,
      i: integer;

    target_attr [1].key := amc$average_record_length;
    target_attr [2].key := amc$block_type;
    target_attr [3].key := amc$character_conversion;
    target_attr [4].key := amc$clear_space;
    target_attr [5].key := amc$collate_table_name;
    target_attr [6].key := amc$data_padding;
    target_attr [7].key := amc$embedded_key;
    target_attr [8].key := amc$estimated_record_count;
    target_attr [9].key := amc$file_access_procedure;
    target_attr [10].key := amc$file_contents;
    target_attr [11].key := amc$file_limit;
    target_attr [12].key := amc$file_organization;
    target_attr [13].key := amc$file_processor;
    target_attr [14].key := amc$file_structure;
    target_attr [15].key := amc$forced_write;
    target_attr [16].key := amc$index_levels;
    target_attr [17].key := amc$index_padding;
    target_attr [18].key := amc$internal_code;
    target_attr [19].key := amc$key_length;
    target_attr [20].key := amc$key_position;
    target_attr [21].key := amc$key_type;
    target_attr [22].key := amc$label_type;
    target_attr [23].key := amc$line_number;
    target_attr [24].key := amc$max_block_length;
    target_attr [25].key := amc$max_record_length;
    target_attr [26].key := amc$min_block_length;
    target_attr [27].key := amc$min_record_length;
    target_attr [28].key := amc$padding_character;
    target_attr [29].key := amc$page_format;
    target_attr [30].key := amc$page_length;
    target_attr [31].key := amc$page_width;
    target_attr [32].key := amc$preset_value;
    target_attr [33].key := amc$record_limit;
    target_attr [34].key := amc$records_per_block;
    target_attr [35].key := amc$record_type;
    target_attr [36].key := amc$ring_attributes;
    target_attr [37].key := amc$statement_identifier;
    target_attr [38].key := amc$user_info;
    target_attr [39].key := amc$vertical_print_density;
    target_attr [40].key := amc$compression_procedure_name;
    target_attr [41].key := amc$dynamic_home_block_space;
    target_attr [42].key := amc$hashing_procedure_name;
    target_attr [43].key := amc$initial_home_block_count;
    target_attr [44].key := amc$loading_factor;
    target_attr [45].key := amc$lock_expiration_time;
    target_attr [46].key := amc$logging_options;
    target_attr [47].key := amc$log_residence;

    target_attr [40].compression_procedure_name := ^target_cpn;
    target_attr [42].hashing_procedure_name := ^target_hpn;
    target_attr [47].log_residence := ^target_lr;

    clp$convert_file_ref_to_string (evaluated_file_reference,
          {include_open_position} FALSE, path, path_size, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_file_attributes (path (1, path_size), target_attr,
           target_local_file, target_exists, target_contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := LOWERBOUND (target_attr) TO UPPERBOUND (target_attr) DO
      CASE target_attr [i].key OF
      = amc$average_record_length =
        target_static_attrs.average_record_length := target_attr [i].
              average_record_length;
      = amc$block_type =
        target_static_attrs.block_type := target_attr [i].block_type;
      = amc$character_conversion =
        target_static_attrs.character_conversion := target_attr [i].
              character_conversion;
      = amc$clear_space =
        target_static_attrs.clear_space := target_attr [i].clear_space;
      = amc$collate_table_name =
        target_static_attrs.collate_table_name := target_attr [i].
              collate_table_name;
      = amc$data_padding =
        target_static_attrs.data_padding := target_attr [i].data_padding;
      = amc$embedded_key =
        target_static_attrs.embedded_key := target_attr [i].embedded_key;
      = amc$estimated_record_count =
        target_static_attrs.estimated_record_count := target_attr [i].
              estimated_record_count;
      = amc$file_access_procedure =
        target_static_attrs.file_access_procedure := target_attr [i].
              file_access_procedure;
      = amc$file_contents =
        target_static_attrs.file_contents := target_attr [i].file_contents;
      = amc$file_limit =
        target_static_attrs.file_limit := target_attr [i].file_limit;
      = amc$file_organization =
        target_static_attrs.file_organization := target_attr [i].
              file_organization;
      = amc$file_processor =
        target_static_attrs.file_processor := target_attr [i].file_processor;
      = amc$file_structure =
        target_static_attrs.file_structure := target_attr [i].file_structure;
      = amc$forced_write =
        target_static_attrs.forced_write := target_attr [i].forced_write;
      = amc$index_levels =
        target_static_attrs.index_levels := target_attr [i].index_levels;
      = amc$index_padding =
        target_static_attrs.index_padding := target_attr [i].index_padding;
      = amc$internal_code =
        target_static_attrs.internal_code := target_attr [i].internal_code;
      = amc$key_length =
        target_static_attrs.key_length := target_attr [i].key_length;
      = amc$key_position =
        target_static_attrs.key_position := target_attr [i].key_position;
      = amc$key_type =
        target_static_attrs.key_type := target_attr [i].key_type;
      = amc$label_type =
        target_static_attrs.label_type := target_attr [i].label_type;
      = amc$line_number =
        target_static_attrs.line_number := target_attr [i].line_number;
      = amc$max_block_length =
        target_static_attrs.max_block_length := target_attr [i].
              max_block_length;
      = amc$max_record_length =
        target_static_attrs.max_record_length := target_attr [i].
              max_record_length;
      = amc$min_block_length =
        target_static_attrs.min_block_length := target_attr [i].
              min_block_length;
      = amc$min_record_length =
        target_static_attrs.min_record_length := target_attr [i].
              min_record_length;
      = amc$padding_character =
        target_static_attrs.padding_character := target_attr [i].
              padding_character;
      = amc$page_format =
        target_static_attrs.page_format := target_attr [i].page_format;
      = amc$page_length =
        target_static_attrs.page_length := target_attr [i].page_length;
      = amc$page_width =
        target_static_attrs.page_width := target_attr [i].page_width;
      = amc$preset_value =
        target_static_attrs.preset_value := target_attr [i].preset_value;
      = amc$record_limit =
        target_static_attrs.record_limit := target_attr [i].record_limit;
      = amc$records_per_block =
        target_static_attrs.records_per_block := target_attr [i].
              records_per_block;
      = amc$record_type =
        target_static_attrs.record_type := target_attr [i].record_type;
      = amc$ring_attributes =
        target_static_attrs.ring_attributes := target_attr [i].ring_attributes;
      = amc$statement_identifier =
        target_static_attrs.statement_identifier := target_attr [i].
              statement_identifier;
      = amc$user_info =
        target_static_attrs.user_info := target_attr [i].user_info;
      = amc$vertical_print_density =
        target_static_attrs.vertical_print_density := target_attr [i].
              vertical_print_density;
      = amc$compression_procedure_name =
        IF target_attr [i].compression_procedure_name <> NIL THEN
          target_static_attrs.compression_procedure_name := target_attr [i].
                compression_procedure_name^;
        IFEND;
      = amc$dynamic_home_block_space =
        target_static_attrs.dynamic_home_block_space := target_attr [i].
              dynamic_home_block_space;
      = amc$hashing_procedure_name =
        IF target_attr [i].hashing_procedure_name <> NIL THEN
          target_static_attrs.hashing_procedure_name := target_attr [i].
                hashing_procedure_name^;
        IFEND;
      = amc$initial_home_block_count =
        target_static_attrs.initial_home_block_count := target_attr [i].
              initial_home_block_count;
      = amc$loading_factor =
        target_static_attrs.loading_factor := target_attr [i].loading_factor;
      = amc$lock_expiration_time =
        target_static_attrs.lock_expiration_time := target_attr [i].
              lock_expiration_time;
      = amc$logging_options =
        target_static_attrs.logging_options := target_attr [i].logging_options;
      = amc$log_residence =
        IF target_attr [i].log_residence <> NIL THEN
          target_static_attrs.log_residence := target_attr [i].log_residence^;
        IFEND;
      ELSE
      CASEND;
    FOREND;
  PROCEND get_connected_file_attributes;

?? TITLE := 'override_attributes', EJECT ??

    PROCEDURE override_attributes
      (   access_level: amt$access_level;
          caller_ring: ost$valid_ring;
          device_class: rmt$device_class;
          attribute_override: ^fst$file_cycle_attributes;
          access_mode_includes_write: boolean;
          access_mode: pft$usage_selections;
          open_position: amt$open_position;
      VAR instance_attributes {input, output} : bat$instance_static_attributes;
          status_reporting_procedure_ptr: fst$status_reporting_procedure;
      VAR status: ost$status);

      VAR
        overridden_attributes: bat$instance_static_attributes,
        override_from_ring_3: boolean,
        block_type_overridden: boolean,
        file_organization_overridden: boolean,
        label_type_overridden: boolean,
        record_type_overridden: boolean,
        ring_attributes_overridden: boolean,
        i: integer;

      status.normal := TRUE;

      FOR i := 1 TO UPPERBOUND (attribute_override^) DO
        CASE attribute_override^ [i].selector OF
        = fsc$block_type =
          ;
        = fsc$file_organization =
          ;
        = fsc$file_label_type =

          { A call to osp$verify_system_privilege should be added here when 'system privilege' is given to the
          { osf$builtin_library on which the PF utilities reside.  Override of label_type will only be allowed
          { for procedures which have system privilege.
          { This check requires passing the caller's segment number to this procedure.

          ;
        = fsc$null_attribute =
          ;
        = fsc$record_type =
          ;
        = fsc$ring_attributes =
          ;
        ELSE
          IF status.normal THEN
            status_reporting_procedure_ptr^ (ame$improper_override_attempt,
                  fsv$attribute_names^ [attribute_override^ [i].selector],
                  status);
          ELSE
            osp$append_status_parameter (',', fsv$attribute_names^
                  [attribute_override^ [i].selector], status);
          IFEND;
        CASEND;
      FOREND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      overridden_attributes := instance_attributes;
      override_from_ring_3 := (caller_ring = 3);
      block_type_overridden := FALSE;
      file_organization_overridden := FALSE;
      label_type_overridden := FALSE;
      record_type_overridden := FALSE;
      ring_attributes_overridden := FALSE;

      merge_overridden_attributes (amc$open_request, attribute_override,
            overridden_attributes, block_type_overridden,
            file_organization_overridden, label_type_overridden, record_type_overridden,
            ring_attributes_overridden);

      IF (block_type_overridden OR label_type_overridden OR file_organization_overridden OR
            record_type_overridden) THEN
        IF access_level = amc$record THEN

          IF access_mode_includes_write THEN
            IF NOT (override_from_ring_3 AND (open_position = amc$open_at_boi)
                  AND (access_mode = $pft$usage_selections [pfc$append,
                  pfc$shorten])) THEN
              status_reporting_procedure_ptr^ (ame$improper_override_access, '',
                    status);
              RETURN;
            IFEND;
            validate_override_for_write (block_type_overridden,
                  file_organization_overridden, label_type_overridden,
                  record_type_overridden, overridden_attributes,
                  status_reporting_procedure_ptr, status);
          ELSE {not access_mode_includes_write}
            validate_override_for_non_write (block_type_overridden,
                  file_organization_overridden, label_type_overridden,
                  record_type_overridden, overridden_attributes,
                  status_reporting_procedure_ptr, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;

      IF ring_attributes_overridden AND ((NOT override_from_ring_3) OR
            access_mode_includes_write) THEN
        status_reporting_procedure_ptr^ (ame$ring_validation_error, '', status);
        RETURN;
      IFEND;
      IF instance_attributes.ring_attributes.r1 > overridden_attributes.
            ring_attributes.r1 THEN
        status_reporting_procedure_ptr^ (ame$ring_validation_error, '', status);
        RETURN;
      IFEND;

      instance_attributes := overridden_attributes;

    PROCEND override_attributes;
?? TITLE := 'merge_overridden_attributes', EJECT ??

    PROCEDURE [INLINE] merge_overridden_attributes (source:
      amt$attribute_source;
          attributes: ^fst$file_cycle_attributes;
      VAR overridden_attributes {input, output} :
        bat$instance_static_attributes;
      VAR block_type_overridden {input, output} : boolean;
      VAR file_organization_overridden {input, output} : boolean;
      VAR label_type_overridden {input, output} : boolean;
      VAR record_type_overridden {input, output} : boolean;
      VAR ring_attributes_overridden {input, output} : boolean);

      VAR
        i: integer;

      FOR i := 1 TO UPPERBOUND (attributes^) DO
        CASE attributes^ [i].selector OF
        = fsc$block_type =
          IF attributes^ [i].block_type <> overridden_attributes.block_type
                THEN
            overridden_attributes.block_type := attributes^ [i].block_type;
            overridden_attributes.block_type_source := source;
            block_type_overridden := TRUE;
          IFEND;
        = fsc$file_organization =
          IF attributes^ [i].file_organization <> overridden_attributes.
                file_organization THEN
            overridden_attributes.file_organization := attributes^ [i].
                  file_organization;
            overridden_attributes.file_organization_source := source;
            file_organization_overridden := TRUE;
          IFEND;
        = fsc$file_label_type =
          IF attributes^ [i].file_label_type <> overridden_attributes.file_label_type THEN
            overridden_attributes.file_label_type := attributes^ [i].file_label_type;
            overridden_attributes.file_label_type_source := source;
            label_type_overridden := TRUE;
          IFEND;
        = fsc$record_type =
          IF attributes^ [i].record_type <> overridden_attributes.record_type
                THEN
            overridden_attributes.record_type := attributes^ [i].record_type;
            overridden_attributes.record_type_source := source;
            record_type_overridden := TRUE;
          IFEND;
        = fsc$ring_attributes =
          IF attributes^ [i].ring_attributes <> overridden_attributes.
                ring_attributes THEN
            overridden_attributes.ring_attributes := attributes^ [i].
                  ring_attributes;
            overridden_attributes.ring_attributes_source := source;
            ring_attributes_overridden := TRUE;
          IFEND;
        ELSE
          ;
        CASEND;
      FOREND;

    PROCEND merge_overridden_attributes;
?? TITLE := 'validate_override_for_write', EJECT ??

    PROCEDURE [INLINE] validate_override_for_write
      (   block_type_overridden: boolean;
          file_organization_overridden: boolean;
          label_type_overridden: boolean;
          record_type_overridden: boolean;
          override_attributes: bat$instance_static_attributes;
          status_reporting_procedure_ptr: fst$status_reporting_procedure;
      VAR status: ost$status);

      VAR
        condition: ost$status_condition;

      status.normal := TRUE;
      condition := 0;

      IF label_type_overridden THEN
        condition := ame$improper_write_override;
      ELSEIF file_organization_overridden AND (override_attributes.
            file_organization <> amc$sequential) THEN
        condition := ame$improper_write_override;
      ELSEIF block_type_overridden AND (override_attributes.block_type <>
            amc$system_specified) THEN
        condition := ame$improper_write_override;
      ELSEIF record_type_overridden AND (override_attributes.record_type <>
            amc$undefined) THEN
        condition := ame$improper_write_override;
      IFEND;

      IF condition <> 0 THEN
        status_reporting_procedure_ptr^ (condition, '', status);
      IFEND;

    PROCEND validate_override_for_write;
?? TITLE := 'validate_override_for_non_write', EJECT ??

    PROCEDURE [INLINE] validate_override_for_non_write
      (   block_type_overridden: boolean;
          file_organization_overridden: boolean;
          label_type_overridden: boolean;
          record_type_overridden: boolean;
          override_attributes: bat$instance_static_attributes;
          status_reporting_procedure_ptr: fst$status_reporting_procedure;
      VAR status: ost$status);

      TYPE
        record_types = set of amt$record_type;

      VAR
        variable_record_types: record_types,
        condition: ost$status_condition;

      status.normal := TRUE;
      condition := 0;
      variable_record_types := $record_types [amc$variable, amc$ansi_spanned,
            amc$ansi_variable, amc$trailing_char_delimited];

      IF NOT label_type_overridden THEN
        IF file_organization_overridden AND (override_attributes.
              file_organization IN amv$aam_file_organizations) THEN
          condition := ame$improper_fo_override;
        ELSEIF record_type_overridden AND (override_attributes.record_type IN
              variable_record_types) THEN
          condition := ame$improper_record_override;
        ELSEIF block_type_overridden THEN
          IF override_attributes.block_type = amc$user_specified THEN
            condition := ame$improper_ss_block_override;
          ELSEIF override_attributes.record_type IN variable_record_types THEN
            condition := ame$improper_us_block_override;
          IFEND;
        IFEND;
      IFEND;

      IF condition <> 0 THEN
        status_reporting_procedure_ptr^ (condition, '', status);
      IFEND;

    PROCEND validate_override_for_non_write;
?? TITLE := 'validate_access_at_open', EJECT ??

    PROCEDURE validate_access_at_open
      (   validation_ring: ost$valid_ring;
          caller_ring: ost$valid_ring;
          ring_attributes: amt$ring_attributes;
          global_access_mode: pft$usage_selections;
          access_mode_defaulted: boolean;
      VAR access_mode {input, output} : pft$usage_selections;
      VAR access_mode_includes_write: boolean;
          status_reporting_procedure_ptr: fst$status_reporting_procedure;
      VAR status: ost$status);

      status.normal := TRUE;
      access_mode_includes_write := ($pft$usage_selections [pfc$append,
            pfc$modify, pfc$shorten] * access_mode) <> $pft$usage_selections [];

      IF access_mode_defaulted THEN

        IF ((pfc$read IN access_mode) AND (validation_ring > ring_attributes.r2)) OR
              (validation_ring > ring_attributes.r3) THEN
          status_reporting_procedure_ptr^ (ame$ring_validation_error, '', status);
          RETURN;
        IFEND;


        IF access_mode_includes_write AND (validation_ring > ring_attributes.
              r1) THEN
          access_mode := access_mode - $pft$usage_selections [pfc$append,
                pfc$modify, pfc$shorten];
          access_mode_includes_write := FALSE;
        IFEND;

        IF access_mode = $pft$usage_selections [pfc$execute] THEN
          access_mode := $pft$usage_selections [];
        IFEND;

      ELSE {NOT access_mode_defaulted}

        IF caller_ring <> 3 THEN

          IF NOT (access_mode <= global_access_mode) THEN
            no_permission_for_access (access_mode - global_access_mode,
                  status_reporting_procedure_ptr, status);
            RETURN;
          IFEND;
          IF (access_mode_includes_write AND (validation_ring >
                ring_attributes.r1)) OR ((pfc$read IN access_mode) AND
                (validation_ring > ring_attributes.r2)) OR
                (validation_ring > ring_attributes.r3) THEN
            status_reporting_procedure_ptr^ (ame$ring_validation_error, '',
                  status);
            RETURN;
          IFEND;

        ELSE {caller_ring = 3}

          IF (access_mode_includes_write AND (validation_ring >
                ring_attributes.r1)) THEN
            status_reporting_procedure_ptr^ (ame$ring_validation_error, '',
                  status);
            RETURN;
          IFEND;
          IF NOT (access_mode <= global_access_mode) THEN
            IF global_access_mode <> $pft$usage_selections [pfc$execute] THEN
              no_permission_for_access (access_mode - global_access_mode,
                    status_reporting_procedure_ptr, status);
              RETURN;
            IFEND;
            IF access_mode_includes_write THEN
              no_permission_for_access (($pft$usage_selections
                   [pfc$append, pfc$modify, pfc$shorten] * access_mode),
                   status_reporting_procedure_ptr, status);
              RETURN;
            IFEND;
          IFEND;

          IF access_mode = $pft$usage_selections [pfc$execute] THEN
            access_mode := $pft$usage_selections [pfc$read, pfc$execute];
          IFEND;

        IFEND;
      IFEND;

      IF access_mode = $pft$usage_selections [] THEN
        status_reporting_procedure_ptr^ (ame$null_access_mode, '', status);
        RETURN;
      IFEND;

    PROCEND validate_access_at_open;
?? TITLE := 'no_permission_for_access', EJECT ??

    PROCEDURE no_permission_for_access
      (   invalid_access: pft$usage_selections;
          status_reporting_procedure_ptr: fst$status_reporting_procedure;
      VAR status: ost$status);

      VAR
        usage: pft$usage_options;

      status.normal := TRUE;
      FOR usage := LOWERVALUE (pft$usage_options) TO UPPERVALUE
            (pft$usage_options) DO
        IF usage IN invalid_access THEN
          IF status.normal THEN
            status_reporting_procedure_ptr^ (ame$no_permission_for_access,
                  amv$usage_option_names [usage].name
                  (1, amv$usage_option_names [usage].size), status);
          ELSE
            osp$append_status_parameter (',', amv$usage_option_names [usage].
                  name (1, amv$usage_option_names [usage].size), status);
          IFEND;
        IFEND;
      FOREND;

    PROCEND no_permission_for_access;
?? TITLE := 'store_attributes_in_tft', EJECT ??

    PROCEDURE [INLINE] store_attributes_in_tft (instance_attributes:
      bat$instance_attributes;
          global_file_information: ^bat$global_file_information;
          system_file_label: ^fmt$system_file_label;
          device_class: rmt$device_class;
      VAR tft_entry {input, output} : bat$task_file_entry);

      tft_entry.instance_attributes := instance_attributes;
      tft_entry.global_file_information := global_file_information;
      tft_entry.system_file_label := system_file_label;
      tft_entry.device_class := device_class;
      CASE device_class OF
      = rmc$connected_file_device =
        tft_entry.subject := NIL;
        tft_entry.connected_files := NIL;
        tft_entry.connection_level := 0;
        tft_entry.first_target.defined := FALSE;
      = rmc$log_device =
        tft_entry.log_ordinal := LOWERVALUE (pmt$logs);
        tft_entry.log_address := NIL;
        tft_entry.log_cycle := LOWERVALUE (lgt$log_cycle);
        tft_entry.log_entry := NIL;
      ELSE
        ;
      CASEND;

    PROCEND store_attributes_in_tft;
?? TITLE := 'set_default_attributes', EJECT ??

    PROCEDURE [INLINE] set_default_attributes (access_level: amt$access_level;
          device_class: rmt$device_class;
          validation_ring: ost$valid_ring;
      VAR static_label {input, output} : bat$static_label_attributes);

      IF static_label.record_type_source = amc$access_method_default THEN
        IF access_level = amc$segment THEN
          static_label.record_type := amc$undefined;
        IFEND;
      IFEND;

      IF static_label.min_record_length_source = amc$access_method_default THEN
        IF static_label.record_type = amc$ansi_fixed THEN
          static_label.min_record_length := static_label.max_record_length;
        ELSEIF (static_label.record_type = amc$undefined) AND (static_label.
              block_type = amc$user_specified) THEN
          static_label.min_record_length := static_label.min_block_length;
        IFEND;
      IFEND;

      IF (static_label.ring_attributes_source = amc$undefined_attribute) OR
            (static_label.ring_attributes_source = amc$access_method_default)
            THEN
        static_label.ring_attributes.r1 := validation_ring;
        static_label.ring_attributes.r2 := validation_ring;
        static_label.ring_attributes.r3 := validation_ring;
        static_label.ring_attributes_source := amc$access_method_default;
      IFEND;

      IF static_label.page_length_source = amc$access_method_default THEN
        IF static_label.vertical_print_density_source <>
              amc$access_method_default THEN
          static_label.page_length := static_label.vertical_print_density * 10;
        IFEND;
      IFEND;

    PROCEND set_default_attributes;
?? TITLE := 'validate_merged_static_attr', EJECT ??

    PROCEDURE [INLINE] validate_merged_static_attr
      (   validation_ring: ost$valid_ring;
          static_label: bat$static_label_attributes;
          device_class: rmt$device_class;
          status_reporting_procedure_ptr: fst$status_reporting_procedure;
      VAR status: ost$status);

      status.normal := TRUE;

      IF NOT ((1 <= static_label.ring_attributes.r1) AND (static_label.
            ring_attributes.r1 <= static_label.ring_attributes.r2) AND
            (static_label.ring_attributes.r2 <= static_label.ring_attributes.
            r3) AND (static_label.ring_attributes.r3 <= 13)) THEN
        status_reporting_procedure_ptr^ (ame$improper_file_attrib_value,
              'CREATION_ATTRIBUTES', status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              fsv$attribute_names^ [fsc$ring_attributes], status);
        RETURN;
      IFEND;

      IF validation_ring > static_label.ring_attributes.r1 THEN
        status_reporting_procedure_ptr^ (ame$ring_validation_error, '', status);
        RETURN;
      IFEND;

      IF static_label.block_type = amc$user_specified THEN
        IF static_label.max_block_length < static_label.min_block_length THEN
          status_reporting_procedure_ptr^ (ame$mbl_less_than_mibl, '', status);
          RETURN;
        IFEND;

        IF (static_label.record_type = amc$ansi_fixed) AND (static_label.
              max_record_length > static_label.max_block_length) THEN
          status_reporting_procedure_ptr^ (ame$mbl_less_than_mrl, '', status);
          RETURN;
        IFEND;
      IFEND;

    PROCEND validate_merged_static_attr;
?? TITLE := 'validate_device_class', EJECT ??

    PROCEDURE [INLINE] validate_device_class
      (    device_class: rmt$device_class;
           file_organization: amt$file_organization;
           access_level: amt$access_level;
           status_reporting_procedure_ptr: fst$status_reporting_procedure;
       VAR status: ost$status);

      TYPE
        file_organizations = set of amt$file_organization,
        access_levels = set of amt$access_level;

      VAR
        allowed_file_organizations: file_organizations,
        allowed_access_levels: access_levels;

      status.normal := TRUE;

      CASE device_class OF
      = rmc$mass_storage_device =
        allowed_file_organizations := $file_organizations [amc$sequential,
              amc$byte_addressable, amc$indexed_sequential, amc$direct_access,
              amc$system_key];
        allowed_access_levels := $access_levels [amc$record, amc$segment,
              amc$physical];
      = rmc$magnetic_tape_device =
        allowed_file_organizations := $file_organizations [amc$sequential];
        allowed_access_levels := $access_levels [amc$record];
        IF NOT any_tape_opened_in_task THEN
          tape_mount_kludge;
          any_tape_opened_in_task := TRUE;
        IFEND;
      = rmc$network_device =
        allowed_file_organizations := $file_organizations [amc$sequential,
        {
        {TEMPORARY CODE}amc$byte_addressable];
        {
        allowed_access_levels := $access_levels [amc$record];
      = rmc$rhfam_device =
        allowed_file_organizations := $file_organizations [amc$sequential];
        allowed_access_levels := $access_levels [amc$record];
      = rmc$terminal_device =
        allowed_file_organizations := $file_organizations [amc$sequential,
              amc$byte_addressable];
        allowed_access_levels := $access_levels [amc$record];
      ELSE {NULL DEVICES
        allowed_file_organizations := $file_organizations [amc$sequential,
              amc$byte_addressable];
        allowed_access_levels := $access_levels [amc$record, amc$segment];
      CASEND;

      IF NOT (file_organization IN allowed_file_organizations) THEN
        status_reporting_procedure_ptr^ (ame$fo_device_class_conflict,
              amv$file_organization_names [file_organization].name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              amv$device_class_names [device_class].name, status);
        RETURN;
      IFEND;

      IF NOT (access_level IN allowed_access_levels) THEN
        IF access_level = amc$segment THEN
          status_reporting_procedure_ptr^ (ame$not_virtual_memory_device,
                amv$device_class_names [device_class].name, status);
        ELSE
          status_reporting_procedure_ptr^ (ame$not_physical_access_device,
                amv$device_class_names [device_class].name, status);
        IFEND;
        RETURN;
      IFEND;

    PROCEND validate_device_class;
?? TITLE := 'tape_mount_kludge', EJECT ??
    PROCEDURE tape_mount_kludge;

 { This is done so that the opening of the library containing the message
 { templates used to action the operator in tapes are not opened in ring 2.
 { This was causing task termination to get a permission not granted for close
 { on these.  Preferable may be close ring 2 files from ring 2 during task
 { termination.

      VAR
        status: ost$status,
        request_status: ost$status,
        p_message: ^ost$status_message;

        osp$set_status_abnormal ('GS', dme$volume, '', status);

        PUSH p_message;
        osp$format_message (status, osc$full_message_level, 80, p_message^,
              request_status);
    PROCEND tape_mount_kludge;
?? TITLE := 'validate_attributes', EJECT ??

    PROCEDURE validate_attributes
      (   attribute_validation: ^fst$file_cycle_attributes;
          access_mode_includes_write: boolean;
      VAR preserved_static_label {input, output} : bat$static_label_attributes;
          status_reporting_procedure_ptr: fst$status_reporting_procedure;
      VAR status: ost$status);

{  This compares the attributes as input to bap$open_file for validation,
{  to the attributes preserved with the file.

      TYPE
        fst$attribute_choices = set of fst$cycle_attribute_choices;

      VAR
        file_contents: amt$file_contents,
        file_contents_valid: boolean,
        file_processor_valid: boolean,
        file_structure: amt$file_structure,
        i: integer,
        matches: fst$attribute_choices,
        mismatches: fst$attribute_choices,
        translated_name: amt$local_file_name;

      matches := $fst$attribute_choices [];
      mismatches := $fst$attribute_choices [];
      status.normal := TRUE;
      FOR i := 1 TO UPPERBOUND (attribute_validation^) DO
        IF NOT (attribute_validation^ [i].selector IN matches) THEN
          CASE attribute_validation^ [i].selector OF
          = fsc$average_record_length =
            IF attribute_validation^ [i].average_record_length =
                  preserved_static_label.average_record_length THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$block_type =
            IF attribute_validation^ [i].block_type = preserved_static_label.
                  block_type THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$character_conversion =
            IF attribute_validation^ [i].character_conversion =
                  preserved_static_label.character_conversion THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$collate_table_name =
            IF attribute_validation^ [i].collate_table_name <> NIL THEN
              #translate (osv$lower_to_upper, attribute_validation^ [i].
                    collate_table_name^.entry_point, translated_name);
              IF translated_name = preserved_static_label.collate_table_name THEN
                matches := matches + $fst$attribute_choices
                      [attribute_validation^ [i].selector];
              ELSE
                mismatches := mismatches + $fst$attribute_choices
                      [attribute_validation^ [i].selector];
              IFEND;
            IFEND;
          = fsc$compression_procedure_name =
            IF attribute_validation^ [i].compression_procedure_name <> NIL THEN
              #translate (osv$lower_to_upper, attribute_validation^ [i].
                    compression_procedure_name^.name, translated_name);
              IF (translated_name = preserved_static_label.
                    compression_procedure_name.name) AND
                    (attribute_validation^ [i].compression_procedure_name^.
                    object_library = preserved_static_label.
                    compression_procedure_name.object_library) THEN
                matches := matches + $fst$attribute_choices
                      [attribute_validation^ [i].selector];
              ELSE
                mismatches := mismatches + $fst$attribute_choices
                      [attribute_validation^ [i].selector];
              IFEND;
            IFEND;
          = fsc$data_padding =
            IF attribute_validation^ [i].data_padding = preserved_static_label.
                  data_padding THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$dynamic_home_block_space =
            IF attribute_validation^ [i].dynamic_home_block_space =
                  preserved_static_label.dynamic_home_block_space THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$embedded_key =
            IF attribute_validation^ [i].embedded_key = preserved_static_label.
                  embedded_key THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$erase_at_deletion =
            IF attribute_validation^ [i].erase_at_deletion =
                  preserved_static_label.clear_space THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$estimated_record_count =
            IF attribute_validation^ [i].estimated_record_count =
                  preserved_static_label.estimated_record_count THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$file_access_procedure_name =
            IF attribute_validation^ [i].file_access_procedure_name <> NIL THEN
              #translate (osv$lower_to_upper, attribute_validation^ [i].
                    file_access_procedure_name^.entry_point, translated_name);
              IF translated_name = preserved_static_label.file_access_procedure THEN
                matches := matches + $fst$attribute_choices
                      [attribute_validation^ [i].selector];
              ELSE
                mismatches := mismatches + $fst$attribute_choices
                      [attribute_validation^ [i].selector];
              IFEND;
            IFEND;
          = fsc$file_contents_and_processor =
            IF attribute_validation^ [i].file_contents <> osc$null_name THEN
              #translate (osv$lower_to_upper, attribute_validation^ [i].
                    file_contents, translated_name);
              fsp$convert_to_old_contents (translated_name, file_contents,
                    file_structure);
              { validate file_content }
              file_contents_valid := (file_contents = preserved_static_label.
                    file_contents);
              { validate file_structure }
              file_contents_valid := file_contents_valid AND ((file_structure =
                preserved_static_label.file_structure) OR (((file_structure =
                amc$unknown_structure) OR (file_structure = amc$data)) AND
                ((preserved_static_label.file_structure = amc$unknown_structure)
                OR (preserved_static_label.file_structure = amc$data))));
            ELSE
              file_contents_valid := TRUE;
            IFEND;
            IF attribute_validation^ [i].file_processor <> osc$null_name THEN
              #translate (osv$lower_to_upper, attribute_validation^ [i].
                    file_processor, translated_name);
              file_processor_valid := (translated_name
                    = preserved_static_label.file_processor)
            ELSE
              file_processor_valid := TRUE;
            IFEND;
            IF file_contents_valid AND file_processor_valid THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$file_label_type =
            IF attribute_validation^ [i].file_label_type =
                  preserved_static_label.label_type THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$file_limit =
            IF attribute_validation^ [i].file_limit = preserved_static_label.
                  file_limit THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$file_organization =
            IF attribute_validation^ [i].file_organization =
                  preserved_static_label.file_organization THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$forced_write =
            IF attribute_validation^ [i].forced_write = preserved_static_label.
                  forced_write THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$hashing_procedure_name =
            IF attribute_validation^ [i].hashing_procedure_name <> NIL THEN
              #translate (osv$lower_to_upper, attribute_validation^ [i].
                    hashing_procedure_name^.name, translated_name);
              IF (translated_name = preserved_static_label.
                    hashing_procedure_name.name) AND
                    (attribute_validation^ [i].hashing_procedure_name^.
                    object_library = preserved_static_label.
                    hashing_procedure_name.object_library) THEN
                matches := matches + $fst$attribute_choices
                      [attribute_validation^ [i].selector];
              ELSE
                mismatches := mismatches + $fst$attribute_choices
                      [attribute_validation^ [i].selector];
              IFEND;
            IFEND;
          = fsc$index_levels =
            IF attribute_validation^ [i].index_levels = preserved_static_label.
                  index_levels THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$index_padding =
            IF attribute_validation^ [i].index_padding =
                  preserved_static_label.index_padding THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$initial_home_block_count =
            IF attribute_validation^ [i].initial_home_block_count =
                  preserved_static_label.initial_home_block_count THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$internal_code =
            IF attribute_validation^ [i].internal_code =
                  preserved_static_label.internal_code THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$key_length =
            IF attribute_validation^ [i].key_length = preserved_static_label.
                  key_length THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$key_position =
            IF attribute_validation^ [i].key_position = preserved_static_label.
                  key_position THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$key_type =
            IF attribute_validation^ [i].key_type = preserved_static_label.
                  key_type THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$line_number =
            IF attribute_validation^ [i].line_number = preserved_static_label.
                  line_number THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$loading_factor =
            IF attribute_validation^ [i].loading_factor =
                  preserved_static_label.loading_factor THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$lock_expiration_time =
            IF attribute_validation^ [i].lock_expiration_time =
                  preserved_static_label.lock_expiration_time THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$log_residence =
            IF attribute_validation^ [i].log_residence <> NIL THEN
              IF attribute_validation^ [i].log_residence^ =
                    preserved_static_label.log_residence THEN
                matches := matches + $fst$attribute_choices
                      [attribute_validation^ [i].selector];
              ELSE
                mismatches := mismatches + $fst$attribute_choices
                      [attribute_validation^ [i].selector];
              IFEND;
            IFEND;
          = fsc$logging_options =
            IF attribute_validation^ [i].logging_options =
                  preserved_static_label.logging_options THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$max_block_length =
            IF attribute_validation^ [i].max_block_length =
                  preserved_static_label.max_block_length THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$max_record_length =
            IF attribute_validation^ [i].max_record_length =
                  preserved_static_label.max_record_length THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$min_block_length =
            IF attribute_validation^ [i].min_block_length =
                  preserved_static_label.min_block_length THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$min_record_length =
            IF attribute_validation^ [i].min_record_length =
                  preserved_static_label.min_record_length THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$padding_character =
            IF attribute_validation^ [i].padding_character =
                  preserved_static_label.padding_character THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$page_format =
            IF attribute_validation^ [i].page_format = preserved_static_label.
                  page_format THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$page_length =
            IF attribute_validation^ [i].page_length = preserved_static_label.
                  page_length THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$page_width =
            IF attribute_validation^ [i].page_width = preserved_static_label.
                  page_width THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$preset_value =
            IF attribute_validation^ [i].preset_value = preserved_static_label.
                  preset_value THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$record_delimiting_character =
            IF attribute_validation^ [i].record_delimiting_character =
               preserved_static_label.record_delimiting_character THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$record_limit =
            IF attribute_validation^ [i].record_limit = preserved_static_label.
                  record_limit THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$record_type =
            IF attribute_validation^ [i].record_type = preserved_static_label.
                  record_type THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$records_per_block =
            IF attribute_validation^ [i].records_per_block =
                  preserved_static_label.records_per_block THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$ring_attributes =
            IF attribute_validation^ [i].ring_attributes =
                  preserved_static_label.ring_attributes THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$statement_identifier =
            IF attribute_validation^ [i].statement_identifier =
                  preserved_static_label.statement_identifier THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$user_attribute =
            ;
          = fsc$user_information =
            IF attribute_validation^ [i].user_information =
                  preserved_static_label.user_info THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          = fsc$vertical_print_density =
            IF attribute_validation^ [i].vertical_print_density =
                  preserved_static_label.vertical_print_density THEN
              matches := matches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            ELSE
              mismatches := mismatches + $fst$attribute_choices
                    [attribute_validation^ [i].selector];
            IFEND;
          ELSE
          CASEND;
        IFEND;
      FOREND;

      mismatches := mismatches - matches;
      IF mismatches <> $fst$attribute_choices [] THEN
        FOR i := 1 TO fsc$highest_current_attribute DO
          IF i IN mismatches THEN
            IF status.normal THEN
              status_reporting_procedure_ptr^ (ame$attribute_validation_error,
                    fsv$attribute_names^ [i], status);
            ELSE
              osp$append_status_parameter (',', fsv$attribute_names^ [i],
                    status);
            IFEND;
          IFEND;
        FOREND;
      IFEND;

    PROCEND validate_attributes;
?? TITLE := 'enforce_concurrency_rules ', EJECT ??

    PROCEDURE enforce_concurrency_rules
      (   file_attachment: ^fst$attachment_options;
          cd_attachment_options: fmt$cd_attachment_options;
          device_class: rmt$device_class;
          open_share_modes_specified: boolean;
          opened_access_mode_counts: bat$access_counts;
          open_count: integer;
      VAR instance_open_share_modes: fst$file_access_options;
          status_reporting_procedure_ptr: fst$status_reporting_procedure;
      VAR status: ost$status);

      VAR
        i: integer,
        last_choice: integer,
        opened_access_modes: fst$file_access_options,
        valid_open_share_modes_found: boolean;

      status.normal := TRUE;

      IF device_class <> rmc$magnetic_tape_device THEN
        IF open_share_modes_specified THEN
          i := 1;
          valid_open_share_modes_found := FALSE;
          determine_opened_access_modes (opened_access_mode_counts,
                opened_access_modes);
          WHILE (NOT valid_open_share_modes_found) AND (i <= UPPERBOUND
                (file_attachment^)) DO
            IF file_attachment^ [i].selector = fsc$open_share_modes THEN
              IF opened_access_modes <= file_attachment^ [i].open_share_modes THEN
                instance_open_share_modes := file_attachment^ [i].
                  open_share_modes;
                valid_open_share_modes_found := TRUE;
              ELSE
                last_choice := i;
              IFEND;
            IFEND;
            i := i + 1;
          WHILEND;
          IF NOT valid_open_share_modes_found THEN
            access_or_share_conflict (fse$concurrent_share_conflict,
                  file_attachment^ [last_choice].open_share_modes,
                  opened_access_modes, status_reporting_procedure_ptr, status);
          IFEND;
        ELSEIF (cd_attachment_options.job_write_concurrency_specified AND
              (NOT cd_attachment_options.job_write_concurrency)) THEN
          IF open_count = 1 THEN
            instance_open_share_modes := $fst$file_access_options [];
          ELSE
            determine_opened_access_modes (opened_access_mode_counts,
                  opened_access_modes);
            access_or_share_conflict (fse$concurrent_share_conflict,
                  $fst$file_access_options [],
                  opened_access_modes, status_reporting_procedure_ptr, status);
          IFEND;
        IFEND;
      IFEND;

    PROCEND enforce_concurrency_rules;
?? TITLE := 'determine_opened_access_modes', EJECT ??

    PROCEDURE [INLINE] determine_opened_access_modes (opened_access_modes:
      bat$access_counts;
      VAR validation_access_modes: fst$file_access_options);

      VAR
        access_mode: fst$file_access_option;

      validation_access_modes := $fst$file_access_options [];

      FOR access_mode := LOWERVALUE (fst$file_access_option) TO UPPERVALUE
            (fst$file_access_option) DO
        IF opened_access_modes [access_mode] <> 0 THEN
          validation_access_modes := validation_access_modes +
                $fst$file_access_options [access_mode];
        IFEND;
      FOREND;
    PROCEND determine_opened_access_modes;

?? TITLE := 'access_or_share_conflict', EJECT ??

    PROCEDURE access_or_share_conflict
      (    condition: ost$status_condition;
           access_options_1: fst$file_access_options;
           access_options_2: fst$file_access_options;
           status_reporting_procedure_ptr: fst$status_reporting_procedure;
       VAR status: ost$status);

      VAR
        delimiter: char,
        option: fst$file_access_option,
        usage: pft$usage_options;


      status.normal := TRUE;
      IF access_options_1 = $fst$file_access_options [] THEN
        status_reporting_procedure_ptr^ (condition, 'NONE', status);
      ELSE
        FOR option := LOWERVALUE (fst$file_access_option) TO UPPERVALUE
              (fst$file_access_option) DO
          IF option IN access_options_1 THEN
            #unchecked_conversion (option, usage);
            IF status.normal THEN
              status_reporting_procedure_ptr^ (condition,
                    amv$usage_option_names [usage].name (1,
                    amv$usage_option_names [usage].size), status);
            ELSE
              osp$append_status_parameter (',', amv$usage_option_names [usage].
                    name (1, amv$usage_option_names [usage].size), status);
            IFEND;
          IFEND;
        FOREND;
      IFEND;

      delimiter := osc$status_parameter_delimiter;
      IF access_options_2 = $fst$file_access_options [] THEN
        osp$append_status_parameter (delimiter, 'NONE', status);
      ELSE
        FOR option := LOWERVALUE (fst$file_access_option) TO UPPERVALUE
              (fst$file_access_option) DO
          IF option IN access_options_2 THEN
            #unchecked_conversion (option, usage);
            osp$append_status_parameter (delimiter, amv$usage_option_names
                  [usage].name (1, amv$usage_option_names [usage].size), status);
            delimiter := ',';
          IFEND;
        FOREND;
      IFEND;

    PROCEND access_or_share_conflict;

?? TITLE := 'load_all_faps', EJECT ??

  PROCEDURE load_all_faps
    (    task_file_index: bat$tft_limit;
         caller_id: ost$caller_identifier;
         device_class: rmt$device_class;
         users_fap_name: ost$name,
         label_type: amt$label_type,
         file_organization: amt$file_organization;
         block_type: amt$block_type;
         record_type: amt$record_type;
         access_level: amt$access_level;
         cd_path_handle: fmt$path_handle;
         status_reporting_procedure_ptr: fst$status_reporting_procedure;
     VAR status: ost$status);

    CONST
      aam_fap_name = 'AMP$ADVANCED_ACCESS_METHODS    ',
      aam_library_name = 'AAF$44D_LIBRARY                ';

    VAR
      audit_information: sft$audit_information,
      aam_fap_pointer: amt$fap_pointer,
      aam_loaded_ring: ost$valid_ring,
      connected_file_fap_pointer: amt$fap_pointer,
      conversion_fap_name: ost$name,
      cycle_description: ^fmt$cycle_description,
      ignore_status: ost$status,
      file_path_p: ^fst$path,
      file_path_size: fst$path_size,
      job_file_fap_pointer: amt$fap_pointer,
      layer_number: amt$fap_layer_number,
      library_file_path_p: ^fst$path,
      loaded_address: pmt$loaded_address,
      local_status: ost$status,
      module_name_p: ^pmt$program_name,
      max_tape_layers: amt$fap_layer_number,
      path_handle: fmt$path_handle,
      rms_fap_pointer: amt$fap_pointer,
      rms_load_status: ost$status,
      rms_loaded_ring: ost$valid_ring,
      user_fap_loaded_ring: ost$valid_ring,
      user_fap_pointer: amt$fap_pointer;

    status.normal := TRUE;
    layer_number := 0;

    {******* load the user fap if a fap name has been provided *******}
    IF users_fap_name <> osc$null_name THEN
      load_fap (task_file_index, users_fap_name, caller_id,
            user_fap_loaded_ring, user_fap_pointer,
            status_reporting_procedure_ptr, status);


{ Emit an audit statistic recording the load of the FAP.

      IF avp$security_option_active (avc$vso_security_audit) THEN
        PUSH file_path_p;
        clp$get_fs_path_string (bav$task_file_table^ [task_file_index].local_file_name, file_path_p^,
              file_path_size, path_handle, local_status);
        IF NOT local_status.normal THEN
          file_path_p^ := ' ';
          local_status.normal := TRUE;
        IFEND;
        PUSH module_name_p;
        PUSH library_file_path_p;
        lop$find_entry_point_residence (users_fap_name, user_fap_loaded_ring, module_name_p^,
              library_file_path_p^, local_status);
        IF NOT local_status.normal THEN
          module_name_p^ := osc$null_name;
          library_file_path_p^ := ' ';
          local_status.normal := TRUE;
        IFEND;
        audit_information.audited_operation := sfc$ao_fs_load_fap;
        audit_information.load_fap.file_p := file_path_p;
        audit_information.load_fap.program_name_p := ^users_fap_name;
        audit_information.load_fap.module_name_p := module_name_p;
        audit_information.load_fap.library_name_p :=
              ^library_file_path_p^(1, clp$trimmed_string_size(library_file_path_p^));
        audit_information.load_fap.loaded_ring := user_fap_loaded_ring;
        sfp$emit_audit_statistic (audit_information, status);
      IFEND;

      IF status.normal THEN
        store_fap_in_tft (task_file_index, user_fap_loaded_ring,
              user_fap_pointer, {ignored} 1, layer_number);
      ELSE
        IF clv$processing_phase >= clc$class_epilog_phase THEN
          osp$generate_log_message ($pmt$ascii_logset
                [pmc$job_log, pmc$system_log], status, ignore_status);
          status.normal := TRUE;
        ELSE
          RETURN;
        IFEND;
      IFEND;
    IFEND;

  /select_system_faps/
    BEGIN
      CASE device_class OF
      = rmc$mass_storage_device =
        {Max_fap_layers = optional user fap + access method fap}
        IF file_organization IN amv$aam_file_organizations THEN
          load_fap_from_library (task_file_index, aam_fap_name,
                aam_library_name, caller_id.ring, aam_loaded_ring,
                aam_fap_pointer, status);
          IF status.normal THEN
            store_fap_in_tft (task_file_index, aam_loaded_ring,
                  aam_fap_pointer, {max_fap_layers} layer_number + 1,
                  layer_number);
          ELSE
            RETURN;
          IFEND;
        ELSEIF access_level = amc$segment THEN
          store_fap_in_tft (task_file_index, bac$minimum_load_ring,
                ^bap$fap_control, {max_fap_layers} layer_number + 1, layer_number);
        ELSEIF (bav$mass_storage_device_faps [block_type] [record_type] <>
              NIL) THEN
          store_fap_in_tft (task_file_index, bac$minimum_load_ring,
                bav$mass_storage_device_faps [block_type] [record_type],
                {max_fap_layers} layer_number + 1, layer_number);
        ELSE
          IF users_fap_name = osc$null_name THEN
            status_reporting_procedure_ptr^ (ame$unsupported_ms_bt_and_rt,
                  amv$block_type_names [block_type].name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  amv$record_type_names [record_type].name, status);
          IFEND;
        IFEND;
      = rmc$terminal_device =
        {Max_fap_layers = optional user fap + access method fap}
        bav$task_file_table^ [task_file_index].open_file_dsc_pointer := NIL;
        bav$task_file_table^ [task_file_index].st_open_file_dsc_pointer := NIL;
        CASE iiv$network_identifier OF
        = iic$cdcnet_network =
          store_fap_in_tft (task_file_index, caller_id.ring,
                ^ifp$st_fap_control, {max_fap_layers} layer_number + 1,
                layer_number);
        = iic$dsiaf_network =
          store_fap_in_tft (task_file_index, caller_id.ring, ^ifp$fap_control,
                {max_fap_layers} layer_number + 1, layer_number);
        ELSE
        CASEND;
      = rmc$magnetic_tape_device =
        {Max_fap_layers = optional user fap + access method fap +
        {    optional RMS site hook + rmp$enforce_tape_security + system tape label fap}
        max_tape_layers := layer_number + 3;
        IF (bav$magnetic_tape_device_faps [block_type] [record_type] <>
              NIL) THEN
          load_fap_from_library (task_file_index,
                bav$rms_library_reference.entry_point,
                bav$rms_library_reference.object_library,
                bac$minimum_load_ring, rms_loaded_ring, rms_fap_pointer,
                rms_load_status);
          IF rms_load_status.normal THEN
            max_tape_layers := max_tape_layers + 1;
          IFEND;
          store_fap_in_tft (task_file_index, caller_id.ring,
                bav$magnetic_tape_device_faps [block_type] [record_type],
                max_tape_layers, layer_number);
          IF rms_load_status.normal THEN
            store_fap_in_tft (task_file_index, rms_loaded_ring,
                  rms_fap_pointer, max_tape_layers, layer_number);
          IFEND;
          store_fap_in_tft (task_file_index, bac$minimum_load_ring,
                ^rmp$enforce_tape_security, max_tape_layers, layer_number);
          store_fap_in_tft (task_file_index, bac$minimum_load_ring,
                ^bap$system_tape_label_fap, max_tape_layers, layer_number);
        ELSEIF users_fap_name = osc$null_name THEN
          status_reporting_procedure_ptr^ (ame$unsupported_bt_and_rt,
                amv$block_type_names [block_type].name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                amv$record_type_names [record_type].name, status);
        IFEND;
      = rmc$network_device =
        {Max_fap_layers = optional user fap + access method fap}
        fmp$locate_cd_via_path_handle (cd_path_handle, FALSE{lock_path_table},
            cycle_description, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF iip$xt_is_xterm_file (^cycle_description^.system_file_label) THEN
          store_fap_in_tft (task_file_index, caller_id.ring, ^iip$xt_xterm_fap,
                {max_fap_layers} layer_number + 1, layer_number);
        ELSE { This is not an xterm file.
          store_fap_in_tft (task_file_index, caller_id.ring, ^nap$network_fap,
                {max_fap_layers} layer_number + 1, layer_number);
        IFEND;
      = rmc$rhfam_device =
        {Max_fap_layers = optional user fap + access method fap}
        store_fap_in_tft (task_file_index, caller_id.ring, ^rfp$network_fap,
              {max_fap_layers} layer_number + 1, layer_number);
      = rmc$connected_file_device =
        {Max_fap_layers = optional user fap + access method fap}
        store_fap_in_tft (task_file_index, caller_id.ring,
              ^bap$connected_file_device, {max_fap_layers} layer_number + 1,
              layer_number);
      = rmc$log_device =
        {Max_fap_layers = optional user fap + access method fap}
        store_fap_in_tft (task_file_index, bac$minimum_load_ring,
              ^bap$log_device, {max_fap_layers} layer_number + 1,
              layer_number);
      = rmc$null_device =
        {Max_fap_layers = optional user fap + access method fap}
        IF jmp$system_job () THEN
          job_file_fap_pointer := jmp$job_file_fap
                (bav$task_file_table^ [task_file_index].local_file_name);
          IF job_file_fap_pointer <> NIL THEN
            store_fap_in_tft (task_file_index, bac$minimum_load_ring,
                  job_file_fap_pointer, {max_fap_layers} layer_number + 1,
                  layer_number);
          ELSE
            store_fap_in_tft (task_file_index, bac$minimum_load_ring,
                  ^bap$null_device, {max_fap_layers} layer_number + 1,
                  layer_number);
          IFEND;
        ELSE
          store_fap_in_tft (task_file_index, bac$minimum_load_ring,
                ^bap$null_device, {max_fap_layers} layer_number + 1,
                layer_number);
        IFEND;
      ELSE
        store_fap_in_tft (task_file_index, bac$minimum_load_ring,
              ^bap$null_device, {max_fap_layers} layer_number + 1,
              layer_number);
      CASEND;
    END /select_system_faps/;

  PROCEND load_all_faps;

?? TITLE := 'load_fap ', EJECT ??

    PROCEDURE load_fap (task_file_index: bat$tft_limit;
          fap_name: ost$name;
          caller_id: ost$caller_identifier;
      VAR loaded_ring: ost$valid_ring;
      VAR fap_pointer: amt$fap_pointer;
          status_reporting_procedure_ptr: fst$status_reporting_procedure;
      VAR status: ost$status);

      VAR
        load_address: pmt$loaded_address,
        local_status: ost$status,
        requested_ring: ost$valid_ring,
        r3: ost$valid_ring,
        entry_kind: pmt$loaded_address_kind;

      entry_kind := pmc$procedure_address;

      IF caller_id.ring < bac$minimum_load_ring THEN
        requested_ring := bac$minimum_load_ring;
      ELSE
        requested_ring := caller_id.ring;
      IFEND;

      lop$load_entry_point (fap_name, requested_ring, caller_id.global_key,
            entry_kind, load_address, status);

      IF status.normal THEN
        bav$task_file_table^ [task_file_index].module_dynamically_loaded :=
                TRUE;
        #convert_pointer_to_procedure (load_address.pointer_to_procedure,
              fap_pointer);
        bap$determine_loaded_ring (load_address.pointer_to_procedure,
              loaded_ring, r3);
      ELSE
        status_reporting_procedure_ptr^ (ame$unable_to_load_fap, fap_name, status);
      IFEND;

    PROCEND load_fap;

?? TITLE := 'load_fap_from_library ', EJECT ??

    PROCEDURE load_fap_from_library
      (    task_file_index: bat$tft_limit;
           fap_name: pmt$program_name;
           library: fst$file_reference;
           target_ring: ost$valid_ring;
       VAR loaded_ring: ost$valid_ring;
       VAR fap_pointer: {output} amt$fap_pointer;
       VAR status: ost$status);

      VAR
        file_contains_data: boolean,
        file_exists: boolean,
        file_previously_opened: boolean,
        get_attributes: ARRAY [ 1 .. 1] of amt$get_item,
        ignore_call_bracket_ring: ost$valid_ring,
        loaded_address: pmt$loaded_address,
        referenced_ring: ost$valid_ring;

      IF target_ring < bac$minimum_load_ring THEN
        referenced_ring := bac$minimum_load_ring;
      ELSE
        referenced_ring := target_ring;
      IFEND;

      get_attributes [1].key := amc$null_attribute;
      amp$get_file_attributes (library, get_attributes, file_exists,
            file_previously_opened, file_contains_data, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF NOT file_contains_data THEN
        osp$set_status_condition (lle$unable_to_access_load_file, status);
        RETURN;
      IFEND;

      pmp$load_module_from_library (fap_name, referenced_ring,
            pmc$procedure_address, library, loaded_ring,
            ignore_call_bracket_ring, loaded_address, status);
      IF status.normal THEN
        bav$task_file_table^ [task_file_index].module_dynamically_loaded := TRUE;
        #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure,
              fap_pointer);
      IFEND;

    PROCEND load_fap_from_library;

?? TITLE := 'load_error_exit ', EJECT ??

    PROCEDURE load_error_exit
      (   error_exit_name_source: amt$attribute_source;
          error_exit_name: ost$name;
          caller_id: ost$caller_identifier;
      VAR error_exit: amt$error_exit_procedure;
      VAR error_exit_source: amt$attribute_source;
          status_reporting_procedure_ptr: fst$status_reporting_procedure;
      VAR status: ost$status);

      VAR
        entry_kind: pmt$loaded_address_kind,
        load_address: pmt$loaded_address,
        referenced_ring: ost$valid_ring;

      IF caller_id.ring < bac$minimum_load_ring THEN
        referenced_ring := bac$minimum_load_ring;
      ELSE
        referenced_ring := caller_id.ring;
      IFEND;
      entry_kind := pmc$procedure_address;
      lop$load_entry_point (error_exit_name, referenced_ring, caller_id.
            global_key, entry_kind, load_address, status);
      IF NOT status.normal THEN
        status_reporting_procedure_ptr^ (ame$unable_to_load_error_exit, error_exit_name, status);
        RETURN;
      IFEND;
      #convert_pointer_to_procedure (load_address.pointer_to_procedure,
            error_exit);
      error_exit_source := amc$open_request;

    PROCEND load_error_exit;
?? TITLE := 'load_collate_table ', EJECT ??

    PROCEDURE load_collate_table
      (   collate_table_name_source: amt$attribute_source;
          collate_table_name: ost$name;
          caller_id: ost$caller_identifier;
      VAR collate_table_source: amt$attribute_source;
      VAR collate_entry: amt$collate_table;
          status_reporting_procedure_ptr: fst$status_reporting_procedure;
      VAR status: ost$status);

      VAR
        load_address: pmt$loaded_address,
        p_collate_entry: ^amt$collate_table,
        entry_kind: pmt$loaded_address_kind,
        referenced_ring: ost$valid_ring;

      IF caller_id.ring < bac$minimum_load_ring THEN
        referenced_ring := bac$minimum_load_ring;
      ELSE
        referenced_ring := caller_id.ring;
      IFEND;
      entry_kind := pmc$data_address;
      lop$load_entry_point (collate_table_name, referenced_ring, caller_id.
            global_key, entry_kind, load_address, status);
      IF NOT status.normal THEN
        status_reporting_procedure_ptr^ (ame$unable_to_load_collate_tabl, collate_table_name, status);
        RETURN;
      IFEND;
      p_collate_entry := load_address.pointer_to_data;
      collate_entry := p_collate_entry^;
      collate_table_source := collate_table_name_source;
    PROCEND load_collate_table;
?? TITLE := 'finalize_file_instance', EJECT ??

    PROCEDURE [INLINE] finalize_file_instance
      (   task_file_index: bat$tft_limit;
          global_file_name: ost$binary_unique_name;
      VAR file_identifier: amt$file_identifier);

      VAR
        access_mode: fst$file_access_option,
        instance_access_modes: fst$file_access_options;

      IF bav$file_id_sequence_number = UPPERVALUE (amt$file_id_sequence) THEN
        bav$file_id_sequence_number := LOWERVALUE (amt$file_id_sequence);
      ELSE
        bav$file_id_sequence_number := bav$file_id_sequence_number + 1;
      IFEND;
      bav$task_file_table^ [task_file_index].sequence_number := bav$file_id_sequence_number;
      file_identifier.ordinal := task_file_index;
      file_identifier.sequence := bav$file_id_sequence_number;

      #unchecked_conversion (bav$task_file_table^ [task_file_index].
            instance_attributes.dynamic_label.access_mode, instance_access_modes);
      FOR access_mode := LOWERVALUE (fst$file_access_option) TO UPPERVALUE
            (fst$file_access_option) DO
        IF access_mode IN instance_access_modes THEN
          bav$task_file_table^ [task_file_index].global_file_information^.
                opened_access_modes [access_mode] := bav$task_file_table^
                [task_file_index].global_file_information^.opened_access_modes
                [access_mode] + 1;
        IFEND;
        IF NOT (access_mode IN bav$task_file_table^ [task_file_index].
              instance_attributes.dynamic_label.open_share_modes) THEN
          bav$task_file_table^ [task_file_index].global_file_information^.
                prevented_open_access_modes [access_mode] := bav$task_file_table^
                [task_file_index].global_file_information^.
                prevented_open_access_modes [access_mode] + 1;
        IFEND;
      FOREND;

    PROCEND finalize_file_instance;
?? TITLE := 'assign_instance_attributes', EJECT ??

    PROCEDURE [INLINE] assign_instance_attributes (preserved_attributes:
      bat$system_file_attributes;
      VAR instance_attributes: bat$instance_attributes);

      instance_attributes.dynamic_label := preserved_attributes.dynamic_label;

      instance_attributes.static_label.block_type := preserved_attributes.
            static_label.block_type;
      instance_attributes.static_label.block_type_source :=
            preserved_attributes.static_label.block_type_source;
      instance_attributes.static_label.file_label_type :=
            preserved_attributes.static_label.label_type;
      instance_attributes.static_label.file_label_type_source :=
            preserved_attributes.static_label.label_type_source;
      instance_attributes.static_label.file_organization :=
            preserved_attributes.static_label.file_organization;
      instance_attributes.static_label.file_organization_source :=
            preserved_attributes.static_label.file_organization_source;
      instance_attributes.static_label.record_type := preserved_attributes.
            static_label.record_type;
      instance_attributes.static_label.record_type_source :=
            preserved_attributes.static_label.record_type_source;
      instance_attributes.static_label.ring_attributes := preserved_attributes.
            static_label.ring_attributes;
      instance_attributes.static_label.ring_attributes_source :=
            preserved_attributes.static_label.ring_attributes_source;

    PROCEND assign_instance_attributes;

?? TITLE := 'store_fap_in_tft ', EJECT ??
    PROCEDURE [INLINE] store_fap_in_tft
      (    task_file_index: bat$tft_limit;
           loaded_ring: ost$valid_ring;
           fap_pointer: amt$fap_pointer;
           maximum_number_of_layers: 1 .. amc$max_fap_layers + 1;
       VAR layer_number: {i/o} amt$fap_layer_number);

      VAR
        layer_to_initialize: amt$fap_layer_number,
        layer: bat$fap_descriptor;

      layer := bav$default_fap_descriptor;
      layer.access_method := fap_pointer;

      IF loaded_ring > bac$minimum_load_ring THEN
        layer.loaded_ring := loaded_ring;
      IFEND;

      IF layer_number = 0 THEN
        bav$task_file_table^ [task_file_index].fap_control_information.
              first_fap := layer;
      ELSEIF bav$task_file_table^ [task_file_index].fap_control_information.
            fap_array = NIL THEN
        ALLOCATE bav$task_file_table^ [task_file_index].fap_control_information.
              fap_array: [0 .. maximum_number_of_layers - 1] IN
              osv$task_private_heap^;
        bav$task_file_table^ [task_file_index].fap_control_information.
              fap_array^ [0] := bav$task_file_table^ [task_file_index].
              fap_control_information.first_fap;
        bav$task_file_table^ [task_file_index].fap_control_information.
              fap_array^ [1] := layer;
        layer_to_initialize := 2;
        WHILE layer_to_initialize <= (maximum_number_of_layers - 1) DO
          bav$task_file_table^ [task_file_index].fap_control_information.
                fap_array^ [layer_to_initialize] := bav$default_fap_descriptor;
          layer_to_initialize := layer_to_initialize + 1;
        WHILEND;
      ELSEIF layer_number <= UPPERBOUND (bav$task_file_table^ [task_file_index].
            fap_control_information.fap_array^) THEN
        bav$task_file_table^ [task_file_index].fap_control_information.
              fap_array^ [layer_number] := layer;
      ELSE
        RETURN;
      IFEND;
      layer_number := layer_number + 1;
    PROCEND store_fap_in_tft;

  MODEND bam$open_file;
*DECK DECK=BAM$PAD_RECORD EXPAND=TRUE
{ MODULE DECK BAMPAD }

*copyc OSD$DEFAULT_PRAGMATS
?? TITLE := 'CYBIL RECORD PADDING MODULE' ??
?? NEWTITLE := '  ' ??

MODULE bam$pad_record;
?? PUSH (LISTEXT := ON) ??
*copyc AMT$MAX_RECORD_LENGTH
*copyc OSD$VIRTUAL_ADDRESS
*copyc AMT$MAX_BLOCK_LENGTH
?? POP ??

  PROCEDURE [XDCL] bap$pad_record (working_storage_area: ^cell;
        pad_length: amt$max_record_length;
        padding_character: char);

    VAR
      i: integer,
      wsa: ^array [1 .. amc$maximum_block] of char;

    wsa := #LOC (working_storage_area^);
    FOR i := 1 TO pad_length DO
      wsa^ [i] := padding_character;
    FOREND;

  PROCEND bap$pad_record;

MODEND bam$pad_record;
*DECK DECK=BAM$PATH_ACCESS_MANAGER EXPAND=TRUE
*copyc osd$default_pragmats

?? LEFT := 1, RIGHT := 110 ??
?? TITLE := 'NOS/VE : Basic Access Methods : Path Access Manager' ??


MODULE bam$path_access_manager;

*copyc amt$local_file_name
*copyc clp$construct_path_handle_name
*copyc fst$cycle_reference
*copyc fmt$path_handle
*copyc fst$evaluated_file_reference
*copyc fst$number_of_path_elements
*copyc fst$path
*copyc fst$path_element
*copyc fmp$get_path_elements
*copyc fmp$get_path_string
*copyc fmp$get_resolved_file_reference
*copyc fmp$is_file_registered
*copyc fmp$get_list_of_$local_files
*copyc fmp$process_pt_request
*copyc fmt$path_description_entry
*copyc fmt$path_handle
*copyc fmv$initial_pdu_pointer
*copyc fst$cycle_reference
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc pfd$catalog_info

?? TITLE := 'PROCEDURE [XDCL, #GATE] clp$get_list_of_$local_files', EJECT ??

*copy clh$get_list_of_$local_files

  PROCEDURE  [XDCL, #GATE] clp$get_list_of_$local_files (VAR info:
        pft$p_info;
    VAR status: ost$status);

    fmp$get_list_of_$local_files (info, status);

  PROCEND clp$get_list_of_$local_files;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$get_path_elements', EJECT ??

{*copy bah$get_path_elements}

  PROCEDURE [XDCL, #GATE] bap$get_path_elements
    (    path_handle: fmt$path_handle;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

    fmp$get_path_elements (path_handle, evaluated_file_reference,
          status);

  PROCEND bap$get_path_elements;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$get_path_string', EJECT ??

{*copy bah$get_path_string}

  PROCEDURE [XDCL, #GATE] bap$get_path_string (path_handle:
        fmt$path_handle;
    VAR path: fst$path;
    VAR path_size: fst$path_size;
    VAR status: ost$status);

    fmp$get_path_string (path_handle, { Lock_path_table} TRUE, path, path_size, status);

  PROCEND bap$get_path_string;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$get_resolved_file_reference', EJECT ??

{*copy bah$get_resolved_file_reference}

  PROCEDURE [XDCL, #GATE] bap$get_resolved_file_reference
    (VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR resolved_file_reference: fst$resolved_file_reference;
     VAR status: ost$status);

     fmp$get_resolved_file_reference (evaluated_file_reference, resolved_file_reference, status);

  PROCEND bap$get_resolved_file_reference;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$is_file_registered', EJECT ??

*copy bah$is_file_registered

  PROCEDURE [XDCL, #GATE] bap$is_file_registered (path_handle:
        fmt$path_handle;
    VAR registered: boolean;
    VAR status: ost$status);

    fmp$is_file_registered (path_handle, registered, status);

  PROCEND bap$is_file_registered;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$process_pt_request', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$process_pt_request (
        process_pt_work_list: bat$process_pt_work_list;
        local_file_name: amt$local_file_name;
    VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
        { path_structure and/or path_handle must be passed in }
    VAR process_pt_results: bat$process_pt_results;
    VAR status: ost$status);

    { PURPOSE: This procedure takes a path and records it in the
    {          path_table creating a node for each path_element that does
    {          not already exist.  If the path has an alias,
    {          then the local_file_name passed into the procedure in the
    {          local_file_name parameter will be used to record the
    {          local_file_name as $local.local_file_name, will remember
    {          the path_description_entry assigned and will then record
    {          the path_elements, associate the same cycle_object
    {          with that path, update the first_cycle_alias_entry pointer in
    {          the cycle_object to point to the aliased named_object.

    VAR
      ignore_cycle_description: ^fmt$cycle_description;

    fmp$process_pt_request (process_pt_work_list, local_file_name,
          evaluated_file_reference, ignore_cycle_description,
          process_pt_results, status);

  PROCEND bap$process_pt_request;

MODEND bam$path_access_manager;

*DECK DECK=BAM$R3_COMMAND_PROCESSOR EXPAND=TRUE
*copyc osd$default_pragmats
MODULE bam$r3_command_processor;
?? NEWTITLE := 'NOS/VE Basic Access Method : Process SET_FILE_ATTRIBUTES command', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_attributes
*copyc amt$local_file_name
*copyc fst$retention
*copyc ost$caller_identifier
*copyc ost$status
*copyc oss$job_paged_literal
?? POP ??
*copyc amp$validate_attributes
*copyc fmp$change_default_file_attribs
*copyc fmp$file_command
*copyc rmp$clear_implicit_reserve
*copyc rmp$set_explicit_reserve

*copyc amv$access_mode
*copyc amv$label_options
*copyc amv$valid_ring
*copyc amv$message_control

?? TITLE := '[XDCL] bap$change_default_file_attribs' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] bap$change_default_file_attribs
    (    attributes: ^amt$file_attributes;
         new_retention: ^fst$retention;
         reset_system_defaults: boolean;
     VAR status: ost$status);

     fmp$change_default_file_attribs (attributes, new_retention,
           reset_system_defaults, status);

  PROCEND bap$change_default_file_attribs;

?? NEWTITLE := 'bap$file_command' ??

  PROCEDURE [XDCL, #GATE] bap$file_command
    (    file: fst$file_reference;
         file_attributes: ^amt$file_attributes;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      validated_attributes: ^amt$file_attributes;

    status.normal := TRUE;
    #CALLER_ID (caller_id);

    IF file_attributes = NIL THEN
      validated_attributes := NIL;
    ELSE
      PUSH validated_attributes: [1 .. UPPERBOUND (file_attributes^)];
      validated_attributes^ := file_attributes^;
      amp$validate_attributes (file, amc$set_file_attributes_cmd,
            caller_id.ring, validated_attributes, status);
    IFEND;

    IF status.normal THEN
      fmp$file_command (file, validated_attributes, status);
    IFEND;

  PROCEND bap$file_command;

?? OLDTITLE ??
MODEND bam$r3_command_processor;
*DECK DECK=BAM$RETURN EXPAND=TRUE
?? RIGHT := 110 ??
MODULE bam$return;

?? PUSH (LISTEXT := OFF) ??
*copyc ame$lfn_program_actions
*copyc fst$detachment_options
*copyc fst$evaluated_file_reference
?? POP ??
*copyc fmp$process_pt_request
*copyc fmp$return_file
*copyc fsp$set_evaluated_file_abnormal
*copyc osp$verify_system_privilege

  PROCEDURE [XDCL, #GATE] bap$return
    (VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
         detachment_options: ^fst$detachment_options;
     VAR status: ost$status);

    VAR
      ignore_cycle_description: ^fmt$cycle_description,
      ignore_process_pt_results: bat$process_pt_results,
      process_pt_work_list: bat$process_pt_work_list;

    status.normal := TRUE;
    osp$verify_system_privilege;

{ If the path is a local file, bac$resolve_path will cause resolution to take place.
{ If the path is a permanent file, then either bac$resolve_pf_in_pt or bac$resolve_to_catalog
{ is necessary. If a generic file reference ($HIGH, $LOW, or $NEXT) is specified, resolution
{ should be done by permanent files (ie. bac$resolve_to_catalog); if a cycle reference is omitted
{ then resolution should be done based on the path table.  If a cycle number is specified,
{ no resolution is necessary; therefore any specification is acceptable.

    IF (evaluated_file_reference.cycle_reference.specification = fsc$cycle_number) OR
          (evaluated_file_reference.cycle_reference.specification = fsc$cycle_omitted) THEN
      process_pt_work_list := $bat$process_pt_work_list [bac$resolve_path, bac$leave_aliases_unresolved,
            bac$resolve_pf_in_pt];
    ELSE
      process_pt_work_list := $bat$process_pt_work_list [bac$resolve_path, bac$leave_aliases_unresolved,
            bac$resolve_to_catalog];
    IFEND;
    fmp$process_pt_request (process_pt_work_list, {local_file_name=} osc$null_name,
          evaluated_file_reference, ignore_cycle_description, ignore_process_pt_results, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT (evaluated_file_reference.path_handle_info.path_handle_present) THEN
      fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_not_known, amc$return_req, '',
            status);
      RETURN;
    IFEND;

    fmp$return_file (evaluated_file_reference, {implicit_detach} FALSE, detachment_options, status);

  PROCEND bap$return;

MODEND bam$return;
*DECK DECK=BAM$REWIND EXPAND=TRUE
*copy OSD$DEFAULT_PRAGMATS
?? TITLE := 'RING 3 REWIND PROCEDURES' ??
?? NEWTITLE := '[XDCL] bap$rewind' ??

{ MODULE DECK BAMRWD }

MODULE bam$rewind;
?? PUSH (LISTEXT := ON) ??
*copyc RMT$DEVICE_CLASS
*copyc OST$CALLER_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$CONFLICTING_ACCESS_LEVEL
*copyc AME$ACCESS_VALIDATION_ERRORS
*copyc AME$IMPROPER_FILE_ID
*copyc BAP$VALIDATE_FILE_IDENTIFIER
?? POP ??
*copyc BAV$TASK_FILE_TABLE
*copyc fmv$global_file_information
?? EJECT ??

  PROCEDURE [XDCL] bap$rewind (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    VAR
      file_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      caller_id: ost$caller_identifier;

    #caller_id (caller_id);
    status.normal := TRUE;
    bap$validate_file_identifier (file_identifier, file_instance,
          file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
        'Uninitialized task_file_table in bap$rewind', status);
    ELSE

      IF caller_id.ring > file_instance^.instance_attributes.static_label.
            ring_attributes.r2 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, call_block.operation,
          '', status);
        RETURN;
      IFEND;
      IF NOT ((pfc$read IN file_instance^.instance_attributes.dynamic_label.
            access_mode) OR (pfc$modify IN file_instance^.instance_attributes.
            dynamic_label.access_mode) OR (pfc$shorten IN file_instance^.
            instance_attributes.dynamic_label.access_mode) OR (pfc$append IN
            file_instance^.instance_attributes.dynamic_label.access_mode)) THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_access_attempt, call_block.operation,
          ' READ or WRITE', status);
        RETURN;
      IFEND;
      IF file_instance^.global_file_information = NIL THEN
{error}
        RETURN;
      IFEND;
      IF file_instance^.access_level = amc$segment THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation,
          'SEGMENT ACCESS', status);
        RETURN;
      IFEND;

      IF file_instance^.device_class = rmc$magnetic_tape_device THEN
        RETURN;
      IFEND;

      IF file_instance^.private_read_information <> NIL THEN
        file_instance^.private_read_information^.positioning_info :=
              fmv$global_file_information.positioning_info;
      ELSE
        file_instance^.global_file_information^.positioning_info :=
              fmv$global_file_information.positioning_info;
      IFEND;
    IFEND;

  PROCEND bap$rewind;
MODEND bam$rewind;
*DECK DECK=BAM$SEGMENT_POINTER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Basic Access Method : Segment Access Management' ??
MODULE bam$segment_pointer;
?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$CONFLICTING_ACCESS_LEVEL
*copyc AME$CONFLICTING_ACCESS_LEVEL
*copyc AME$DEVICE_CLASS_VALIDATION
*copyc AME$IMPROPER_FILE_ID
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$SEGMENT_VALIDATION_ERRORS
*copyc AMT$FAP_DECLARATIONS
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$SEGMENT_POINTER
*copyc BAC$MINIMUM_OPEN_RING
*copyc I#BUILD_ADAPTABLE_HEAP_POINTER
*copyc I#BUILD_ADAPTABLE_SEQ_POINTER
*copyc I#CURRENT_SEQUENCE_POSITION
*copyc OSD$CYBIL_STRUCTURE_DEFINITIONS
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc AMP$GET_SEGMENT_POINTER
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc BAP$SET_FILE_INSTANCE_ABNORMAL
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc MMP$CHANGE_SEGMENT_NUMBER
*copyc MMP$GET_PAGE_SIZE
*copyc MMP$GET_SEGMENT_LENGTH
*copyc MMP$SET_SEGMENT_LENGTH
*copyc OSP$SET_STATUS_ABNORMAL

*copyc AMV$DEVICE_CLASS_NAMES
*copyc BAV$TASK_FILE_TABLE
*copyc OSV$PAGE_SIZE

?? TITLE := 'PROCEDURE [XDCL] BAP$GET_SEGMENT_POINTER', EJECT ??
*copyc BAH$GET_SEGMENT_POINTER

  PROCEDURE [XDCL] bap$get_segment_pointer
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         fap_layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    CONST
      error_text = 'BAP$GET_SEGMENT_POINTER';

    VAR
      caller_id: ost$caller_identifier,
      current_byte_address: amt$file_byte_address,
      file_instance: ^bat$task_file_entry,
      heap_length: 0 .. osc$maximum_offset,
      heap_var: ^HEAP ( * ),
      pva: ^cell,
      pva_ptr: ^cell,
      segment_length: ost$segment_length,
      seq_length: ost$segment_length,
      seq_next: 0 .. osc$maximum_offset,
      seq_var: ^SEQ ( * ),
      validation_ok: boolean;

    status.normal := TRUE;
    #CALLER_ID (caller_id);

  /get_segment_pointer/
    BEGIN
      bap$validate_file_identifier (file_identifier, file_instance,
            validation_ok);
      IF NOT validation_ok THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
              error_text, status);
        EXIT /get_segment_pointer/;
      IFEND;

      IF caller_id.ring <> osc$tsrv_ring {task services ring - ring 3} THEN
        IF caller_id.ring > file_instance^.instance_attributes.static_label.
              ring_attributes.r2 THEN
          amp$set_file_instance_abnormal (file_identifier,
                ame$ring_validation_error, call_block.operation, error_text,
                status);
          EXIT /get_segment_pointer/;
        IFEND;
      IFEND;

      IF file_instance^.device_class <> rmc$mass_storage_device THEN
        IF (file_instance^.device_class = rmc$null_device) THEN
          EXIT /get_segment_pointer/;
        ELSE
          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_device_class, call_block.operation, 'NON-MASS_STORAGE',
                status);
          EXIT /get_segment_pointer/;
        IFEND;
      IFEND;

      pva := file_instance^.file_pva;

      mmp$get_segment_length (pva, #RING (pva), segment_length, status);
      IF NOT status.normal THEN
        EXIT /get_segment_pointer/;
      IFEND;

      IF segment_length = 0 THEN
        IF (($pft$usage_selections [pfc$shorten, pfc$append,
              pfc$modify]) * file_instance^.instance_attributes.dynamic_label.
              access_mode) = $pft$usage_selections [] THEN
          amp$set_file_instance_abnormal (file_identifier,
                ame$read_of_empty_segment, call_block.operation, error_text,
                status);
          EXIT /get_segment_pointer/;
        ELSEIF NOT (pfc$append IN file_instance^.instance_attributes.
              dynamic_label.access_mode) THEN
          amp$set_file_instance_abnormal (file_identifier,
                ame$write_of_empty_segment, call_block.operation, error_text,
                status);
          EXIT /get_segment_pointer/;
        IFEND;
      IFEND;

      IF file_instance^.private_read_information = NIL THEN
        current_byte_address := file_instance^.global_file_information^.
              positioning_info.record_info.current_byte_address;
      ELSE
        current_byte_address := file_instance^.private_read_information^.
              positioning_info.record_info.current_byte_address;
      IFEND;

      CASE call_block.getsegp.pointer_kind OF
      = amc$cell_pointer =
        call_block.getsegp.segment_pointer^.cell_pointer :=
              #ADDRESS (#RING (pva), #SEGMENT (pva), current_byte_address);
        call_block.getsegp.segment_pointer^.kind := amc$cell_pointer;
        RETURN;

      = amc$heap_pointer =
        IF pfc$append IN file_instance^.instance_attributes.dynamic_label.
              access_mode THEN
          IF file_instance^.global_file_information^.file_limit <=
                osc$maximum_offset THEN
            heap_length := file_instance^.global_file_information^.file_limit;
          ELSE
            heap_length := osc$maximum_offset;
          IFEND;
        ELSE
          heap_length := segment_length;
        IFEND;
        i#build_adaptable_heap_pointer (#RING (pva), #SEGMENT (pva),
              current_byte_address, heap_length, heap_var);
        call_block.getsegp.segment_pointer^.heap_pointer := heap_var;
        call_block.getsegp.segment_pointer^.kind := amc$heap_pointer;
        RETURN;

      = amc$sequence_pointer =
        IF current_byte_address <= segment_length THEN
          seq_next := current_byte_address;
        ELSE
          seq_next := segment_length;
        IFEND;
        IF pfc$append IN file_instance^.instance_attributes.dynamic_label.
              access_mode THEN
          IF file_instance^.global_file_information^.file_limit <=
                osc$maximum_offset THEN
            seq_length := file_instance^.global_file_information^.file_limit;
          ELSE
            seq_length := osc$maximum_offset;
          IFEND;
        ELSE
          seq_length := segment_length;
        IFEND;

        i#build_adaptable_seq_pointer (#RING (pva), #SEGMENT (pva),
              #OFFSET (pva), seq_length, seq_next, seq_var);
        call_block.getsegp.segment_pointer^.sequence_pointer := seq_var;
        call_block.getsegp.segment_pointer^.kind := amc$sequence_pointer;
        RETURN;

      ELSE
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_pointer_kind, amc$get_segment_pointer_req, error_text,
              status);
      CASEND;
    END /get_segment_pointer/;

    CASE call_block.getsegp.pointer_kind OF
    = amc$cell_pointer =
      call_block.getsegp.segment_pointer^.cell_pointer := NIL;
      call_block.getsegp.segment_pointer^.kind := amc$cell_pointer;
    = amc$heap_pointer =
      call_block.getsegp.segment_pointer^.heap_pointer := NIL;
      call_block.getsegp.segment_pointer^.kind := amc$heap_pointer;
    = amc$sequence_pointer =
      call_block.getsegp.segment_pointer^.sequence_pointer := NIL;
      call_block.getsegp.segment_pointer^.kind := amc$sequence_pointer;
    ELSE
      amp$set_file_instance_abnormal (file_identifier,
            ame$improper_pointer_kind, amc$get_segment_pointer_req, error_text,
            status);
    CASEND;

  PROCEND bap$get_segment_pointer;
?? TITLE := 'PROCEDURE [XDCL] BAP$SET_SEGMENT_POSITION', EJECT ??

*copyc BAH$SET_SEGMENT_POSITION

  PROCEDURE [XDCL] bap$set_segment_position
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         fap_layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    CONST
      error_text = 'BAP$SET_SEGMENT_POSITION';

    VAR
      byte_address: amt$file_byte_address,
      call_block_pva: ^cell,
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      pva: ^cell,
      segment_length: ost$segment_length,
      validation_ok: boolean;

    status.normal := TRUE;
    #CALLER_ID (caller_id);

    bap$validate_file_identifier (file_identifier, file_instance,
          validation_ok);
    IF NOT validation_ok THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            error_text, status);
      RETURN;
    IFEND;

    IF caller_id.ring <> osc$tsrv_ring THEN
      IF caller_id.ring > file_instance^.instance_attributes.static_label.
            ring_attributes.r2 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, call_block.operation, error_text,
              status);
        RETURN;
      IFEND;
    IFEND;

    IF file_instance^.device_class <> rmc$mass_storage_device THEN
      IF (file_instance^.device_class = rmc$null_device) THEN
        RETURN;
      ELSE
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_device_class, call_block.operation, 'NON-MASS_STORAGE',
              status);
        RETURN;
      IFEND;
    IFEND;

    pva := file_instance^.file_pva;

    CASE call_block.segpos.segment_pointer.kind OF
    = amc$cell_pointer =
      call_block_pva := call_block.segpos.segment_pointer.cell_pointer;
      byte_address := #OFFSET (call_block_pva);

    = amc$sequence_pointer =
      call_block_pva := call_block.segpos.segment_pointer.sequence_pointer;
      byte_address := i#current_sequence_position
            (call_block.segpos.segment_pointer.sequence_pointer);
    = amc$heap_pointer =
      amp$set_file_instance_abnormal (file_identifier,
            ame$set_on_adaptable_heap, amc$set_segment_position_req,
            error_text, status);
      RETURN;
    ELSE
      amp$set_file_instance_abnormal (file_identifier,
            ame$improper_pointer_kind, amc$set_segment_position_req,
            error_text, status);
      RETURN;
    CASEND;

    IF (call_block_pva = NIL) THEN
      amp$set_file_instance_abnormal (file_identifier,
            ame$improper_segment_pointer, call_block.operation, '', status);
      RETURN;
    IFEND;

    IF (#SEGMENT (call_block_pva) <> #SEGMENT (pva)) THEN
      amp$set_file_instance_abnormal (file_identifier,
            ame$improper_segment_number, call_block.operation, '', status);
      RETURN;
    IFEND;

    mmp$get_segment_length (pva, #RING (pva), segment_length, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF byte_address > segment_length THEN
      amp$set_file_instance_abnormal (file_identifier, ame$set_pos_beyond_eoi,
            call_block.operation, '', status);
      RETURN;
    IFEND;

    IF file_instance^.private_read_information <> NIL THEN
      file_instance^.private_read_information^.positioning_info.record_info.
            current_byte_address := byte_address;
    ELSE
      file_instance^.global_file_information^.positioning_info.record_info.
            current_byte_address := byte_address;
    IFEND;

  PROCEND bap$set_segment_position;
?? TITLE := 'PROCEDURE [XDCL] BAP$SET_SEGMENT_EOI', EJECT ??

*copyc BAH$SET_SEGMENT_EOI

  PROCEDURE [XDCL] bap$set_segment_eoi
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         fap_layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    CONST
      error_text = 'BAP$SET_SEGMENT_EOI';

    VAR
      call_block_pva: ^cell,
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      proposed_eoi: amt$file_byte_address,
      pva: ^cell,
      segment_eoi: ost$segment_length,
      validation_ok: boolean;

?? NEWTITLE := 'validate_proposed_eoi', EJECT ??

    PROCEDURE validate_proposed_eoi
      (VAR status: ost$status);

      IF proposed_eoi > (((file_instance^.global_file_information^.file_limit +
            (osv$page_size - 1)) DIV osv$page_size) * osv$page_size) THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$position_beyond_file_limit, call_block.operation, '', status);
      IFEND;

    PROCEND validate_proposed_eoi;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    #CALLER_ID (caller_id);

    bap$validate_file_identifier (file_identifier, file_instance,
          validation_ok);
    IF NOT validation_ok THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            error_text, status);
      RETURN;
    IFEND;

    IF caller_id.ring > file_instance^.instance_attributes.static_label.
          ring_attributes.r1 THEN
      amp$set_file_instance_abnormal (file_identifier,
            ame$ring_validation_error, call_block.operation, error_text,
            status);
      RETURN;
    IFEND;

    IF file_instance^.device_class <> rmc$mass_storage_device THEN
      IF (file_instance^.device_class = rmc$null_device) THEN
        RETURN;
      ELSE
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_device_class, call_block.operation, 'NON-MASS_STORAGE',
              status);
        RETURN;
      IFEND;
    IFEND;
    pva := file_instance^.file_pva;

    CASE call_block.segeoi.segment_pointer.kind OF
    = amc$cell_pointer =
      call_block_pva := call_block.segeoi.segment_pointer.cell_pointer;
      proposed_eoi := #OFFSET (call_block_pva);

    = amc$sequence_pointer =
      call_block_pva := call_block.segeoi.segment_pointer.sequence_pointer;
      proposed_eoi := i#current_sequence_position
            (call_block.segeoi.segment_pointer.sequence_pointer);

    = amc$heap_pointer =
      amp$set_file_instance_abnormal (file_identifier,
            ame$set_on_adaptable_heap, amc$set_segment_eoi_req, error_text,
            status);
      RETURN;

    ELSE
      amp$set_file_instance_abnormal (file_identifier,
            ame$improper_pointer_kind, amc$set_segment_eoi_req, error_text,
            status);
      RETURN;
    CASEND;

    IF (call_block_pva = NIL) THEN
      amp$set_file_instance_abnormal (file_identifier,
            ame$improper_segment_pointer, call_block.operation, '', status);
      RETURN;
    IFEND;

    IF (#SEGMENT (call_block_pva) <> #SEGMENT (pva)) THEN
      amp$set_file_instance_abnormal (file_identifier,
            ame$improper_segment_number, call_block.operation, '', status);
      RETURN;
    IFEND;

    mmp$get_segment_length (pva, #RING (pva), segment_eoi, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (segment_eoi MOD osv$page_size) > 0 THEN

{ Eoi is not on a page boundary so it must have been explicitly set.

      IF proposed_eoi < segment_eoi THEN
        IF NOT (pfc$shorten IN file_instance^.instance_attributes.dynamic_label.
              access_mode) THEN
          amp$set_file_instance_abnormal (file_identifier,
                ame$set_eoi_needs_shorten, call_block.operation, '', status);
          RETURN;
        IFEND;
      ELSEIF proposed_eoi > segment_eoi THEN
        IF NOT (pfc$append IN file_instance^.instance_attributes.dynamic_label.
              access_mode) THEN
          amp$set_file_instance_abnormal (file_identifier,
                ame$set_eoi_needs_append, call_block.operation, '', status);
          RETURN;
        ELSE
          validate_proposed_eoi (status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
    { ELSE
    {   proposed_eoi = segment_eoi is okay
      IFEND;
    ELSE

{ Eoi is on a page boundary so we don't know if that's the true value or
{ just the result of a page fault - we can only check for shorten access
{ if the requested address is not within the last referenced page.

      IF proposed_eoi < (segment_eoi - osv$page_size) THEN
        IF NOT (pfc$shorten IN file_instance^.instance_attributes.dynamic_label.
              access_mode) THEN
          amp$set_file_instance_abnormal (file_identifier,
                ame$set_eoi_needs_shorten, call_block.operation, '', status);
          RETURN;
        IFEND;
      ELSEIF proposed_eoi > segment_eoi THEN
        IF NOT (pfc$append IN file_instance^.instance_attributes.dynamic_label.
              access_mode) THEN
          amp$set_file_instance_abnormal (file_identifier,
                ame$set_eoi_needs_append, call_block.operation, '', status);
          RETURN;
        ELSE
          validate_proposed_eoi (status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    mmp$set_segment_length (file_instance^.file_pva, caller_id.ring,
          proposed_eoi, status);

    IF status.normal THEN
      file_instance^.global_file_information^.positioning_info.record_info.
            current_byte_address := proposed_eoi;
      file_instance^.global_file_information^.eoi_byte_address := proposed_eoi;
    IFEND;

  PROCEND bap$set_segment_eoi;
?? TITLE := '  PROCEDURE [XDCL, #GATE] fsp$change_segment_number', EJECT ??
*copyc fsh$change_segment_number

  PROCEDURE [XDCL, #GATE] fsp$change_segment_number
    (    file_identifier: amt$file_identifier;
         new_segment_number: ost$segment;
         validation_ring: ost$valid_ring;
         pointer_kind: amt$pointer_kind;
     VAR segment_pointer: amt$segment_pointer;
     VAR status: ost$status);

    CONST
      change_segment_number_request = 'FSP$CHANGE_SEGMENT_NUMBER';

    VAR
      caller_id: ost$caller_identifier,
      ignore_fid_validation: boolean,
      file_instance: ^bat$task_file_entry,
      old_segment_pointer: amt$segment_pointer,
      new_segment_pointer: amt$segment_pointer,
      validation_ring_number: ost$valid_ring;

    #CALLER_ID (caller_id);
    IF validation_ring > caller_id.ring THEN
      validation_ring_number := validation_ring;
    ELSE
      validation_ring_number := caller_id.ring;
    IFEND;

    CASE pointer_kind OF
    = amc$cell_pointer =
      segment_pointer.cell_pointer := NIL;
      segment_pointer.kind := amc$cell_pointer;
    = amc$heap_pointer =
      segment_pointer.heap_pointer := NIL;
      segment_pointer.kind := amc$heap_pointer;
    = amc$sequence_pointer =
      segment_pointer.sequence_pointer := NIL;
      segment_pointer.kind := amc$sequence_pointer;
    ELSE
    CASEND;

    amp$get_segment_pointer (file_identifier, amc$cell_pointer,
          old_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    bap$validate_file_identifier (file_identifier, file_instance,
          ignore_fid_validation);
{   File_id was validated by amp$get_segment_pointer.}

    IF file_instance^.device_class <> rmc$mass_storage_device THEN
      bap$set_file_instance_abnormal (file_identifier,
            ame$improper_device_class, change_segment_number_request,
            amv$device_class_names [file_instance^.device_class].name, status);
      RETURN;
    IFEND;

    IF validation_ring_number > file_instance^.instance_attributes.
          static_label.ring_attributes.r2 THEN
      bap$set_file_instance_abnormal (file_identifier,
            ame$ring_validation_error, change_segment_number_request, '',
            status);
      RETURN;
    IFEND;

    mmp$change_segment_number (old_segment_pointer, new_segment_number,
          bac$minimum_open_ring, new_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_instance^.file_pva := new_segment_pointer.cell_pointer;

    amp$get_segment_pointer (file_identifier, pointer_kind, segment_pointer,
          status);
  PROCEND fsp$change_segment_number;

MODEND bam$segment_pointer;
*DECK DECK=BAM$SL_REWIND_FILE_COMMAND EXPAND=TRUE
*copyc osd$default_pragmats

MODULE bam$sl_rewind_file_command;

?? PUSH (LISTEXT := ON) ??
*copyc fmp$sl_rewind_file_command
?? POP ??

  PROCEDURE [XDCL, #GATE] bap$sl_rewind_file_command (
        local_file_name: amt$local_file_name;
    VAR status: ost$status);


    fmp$sl_rewind_file_command ( local_file_name, status);

  PROCEND bap$sl_rewind_file_command;

MODEND bam$sl_rewind_file_command;




*DECK DECK=BAM$STORE_ART_TABLE_POINTER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Basic Access Methods : AMP$FILE' ??
MODULE bam$store_art_table_pointer;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc bat$auxilliary_request_table
*copyc bat$task_file_table
*copyc fme$file_management_errors
*copyc oss$task_private
*copyc ost$name
?? POP ??
*copyc osp$set_status_abnormal

*copyc bav$auxilliary_request_table
*copyc osv$task_private_heap


  VAR
    bav$last_art_entry: [XDCL, #GATE, oss$task_private] bat$last_art_entry := 0;

?? TITLE := '    [XDCL, #GATE] bap$delete_art_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$delete_art_entry
    (    local_file_name: amt$local_file_name;
     VAR status: ost$status);

    VAR
      art_index: bat$art_limit,
      found: boolean;

    status.normal := TRUE;

    fetch_art_index (local_file_name, art_index, found);

    IF found THEN
      IF bav$auxilliary_request_table^ [art_index].file_attributes <> NIL THEN
        FREE bav$auxilliary_request_table^ [art_index].file_attributes IN osv$task_private_heap^;
      IFEND;
      bav$auxilliary_request_table^ [art_index].local_file_name := osc$null_name;
    IFEND;

  PROCEND bap$delete_art_entry;

?? TITLE := '    [XDCL, #GATE] bap$fetch_art_table_pointer', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$fetch_art_table_pointer
    (    local_file_name: amt$local_file_name;
     VAR file_attributes: ^amt$file_attributes);

    VAR
      art_index: bat$art_limit,
      found: boolean;

    fetch_art_index (local_file_name, art_index, found);
    IF found THEN
      file_attributes := bav$auxilliary_request_table^ [art_index].file_attributes;
    ELSE
      file_attributes := NIL;
    IFEND;

  PROCEND bap$fetch_art_table_pointer;

?? TITLE := ' PROCEDURE [XDCL, #GATE] bap$store_art_table_pointer', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$store_art_table_pointer
    (    local_file_name: amt$local_file_name;
     VAR file_attributes: ^amt$file_attributes;
     VAR status: ost$status);

    VAR
      art_index: bat$art_limit;

    status.normal := TRUE;
    find_art_entry (local_file_name, art_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF bav$auxilliary_request_table^ [art_index].file_attributes <> NIL THEN
      FREE bav$auxilliary_request_table^ [art_index].file_attributes IN osv$task_private_heap^;
      bav$auxilliary_request_table^ [art_index].file_attributes := NIL;
    IFEND;
    IF file_attributes <> NIL THEN
      ALLOCATE bav$auxilliary_request_table^ [art_index].file_attributes:
            [LOWERBOUND (file_attributes^) .. UPPERBOUND (file_attributes^)] IN osv$task_private_heap^;
      bav$auxilliary_request_table^ [art_index].file_attributes^ := file_attributes^;
    IFEND;

  PROCEND bap$store_art_table_pointer;

?? TITLE := 'PROCEDURE [INLINE] fetch_art_index', EJECT ??

  PROCEDURE [INLINE] fetch_art_index
    (    lfn: amt$local_file_name;
     VAR art_index: bat$art_limit;
     VAR found: boolean);

    found := FALSE;
    IF bav$auxilliary_request_table <> NIL THEN

    /search_for_entry/
      FOR art_index := 1 TO bav$last_art_entry DO
        IF bav$auxilliary_request_table^ [art_index].local_file_name = lfn THEN
          found := TRUE;
          EXIT /search_for_entry/;
        IFEND;
      FOREND /search_for_entry/;
    IFEND;

  PROCEND fetch_art_index;

?? TITLE := 'PROCEDURE find_art_entry' ??
?? EJECT ??

  PROCEDURE find_art_entry
    (    lfn: amt$local_file_name;
     VAR art_index: bat$art_limit;
     VAR status: ost$status);

    VAR
      entry_found: boolean;


    status.normal := TRUE;
    IF bav$auxilliary_request_table = NIL THEN
      ALLOCATE bav$auxilliary_request_table IN osv$task_private_heap^;
    IFEND;

    fetch_art_index (lfn, art_index, entry_found);
    IF NOT entry_found THEN

    /art_null_search/
      BEGIN

        FOR art_index := 1 TO bav$last_art_entry DO
          IF bav$auxilliary_request_table^ [art_index].local_file_name = osc$null_name THEN
            entry_found := TRUE;
            EXIT /art_null_search/;
          IFEND;
        FOREND;
        IF (bav$last_art_entry < bac$art_size) THEN
          bav$last_art_entry := bav$last_art_entry + 1;
          art_index := bav$last_art_entry;
          entry_found := TRUE;
        IFEND;
      END /art_null_search/;
      IF entry_found THEN
        bav$auxilliary_request_table^ [art_index].local_file_name := lfn;
        bav$auxilliary_request_table^ [art_index].file_attributes := NIL;
      ELSE
        osp$set_status_abnormal (amc$access_method_id, fme$system_error, 'amp$file table overflow', status);
      IFEND;
    IFEND;

  PROCEND find_art_entry;

MODEND bam$store_art_table_pointer;
*DECK DECK=BAM$STORE_FETCH_TAPE_LABEL_ATTR EXPAND=TRUE
*copyc osd$default_pragmats

MODULE bam$store_fetch_tape_label_attr;

*copyc fst$attachment_options
*copyc fst$tape_attachment_information
*copyc ost$status

*copyc fmp$fetch_tape_attachment_info
*copyc fmp$fetch_tape_label_attributes
*copyc fmp$store_tape_attachment
*copyc fmp$store_tape_label_attributes


  PROCEDURE [XDCL, #GATE] bap$store_tape_label_attributes (
        evaluated_file_reference: fst$evaluated_file_reference;
        tape_attachments: fst$attachment_options;
        supplied_file_set_pos_fields: fst$supplied_file_set_positions;
        tape_attachment_info_source: fst$tape_attach_info_source;
    VAR status: ost$status);

    status.normal := TRUE;

    fmp$store_tape_label_attributes (evaluated_file_reference, tape_attachments,
           supplied_file_set_pos_fields, tape_attachment_info_source, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND bap$store_tape_label_attributes;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] bap$fetch_tape_label_attributes (
        evaluated_file_reference: fst$evaluated_file_reference;
    VAR tape_attachments: fst$tape_attachment_information;
    VAR status: ost$status);

    status.normal := TRUE;

    fmp$fetch_tape_label_attributes (evaluated_file_reference, tape_attachments, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND bap$fetch_tape_label_attributes;

?? EJECT ??

  PROCEDURE [XDCL, #GATE] bap$fetch_tape_attachment_info (
        evaluated_file_reference: fst$evaluated_file_reference;
    VAR tape_attachments: fst$tape_attachment_information;
    VAR status: ost$status);

    status.normal := TRUE;

    fmp$fetch_tape_attachment_info (evaluated_file_reference, tape_attachments, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND bap$fetch_tape_attachment_info;

?? EJECT ??

  PROCEDURE [XDCL, #GATE] bap$store_tape_attachment (
        tape_attachments: fst$attachment_options;
        tape_attachment_info_source: fst$tape_attach_info_source;
        tape_attachment_info: ^fst$tape_attachment_information;
    VAR status: ost$status);

    status.normal := TRUE;

    fmp$store_tape_attachment (tape_attachments, tape_attachment_info_source, tape_attachment_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND bap$store_tape_attachment;

MODEND bam$store_fetch_tape_label_attr;
*DECK DECK=BAM$SYSTEM_TAPE_LABEL_FAP EXPAND=TRUE
?? RIGHT := 110 ??
MODULE bam$system_tape_label_fap;

*copyc amp$set_file_instance_abnormal
*copyc bai$append_tape_error
*copyc bai$label_type
*copyc bai$tape_descriptor
*copyc bap$dismount_tape_volume
*copyc bap$fap_control
*copyc bap$get_tape_element_name
*copyc bap$store_unsecured_tape_labels
*copyc bap$tape_bm_read_label
*copyc bap$tape_bm_skip_label_mark
*copyc bap$tape_bm_rewind
*copyc bap$tape_bm_write_label
*copyc bap$tape_bm_write_label_mark
*copyc bav$task_file_table
*copyc bap$volume_robotically_mounted
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_integer
*copyc dmp$advance_tape_volume
*copyc dmp$assign_tape_volume
*copyc dmp$reset_tape_volume
*copyc dmp$unload_remount_tape_volume
*copyc dmp$update_tape_vsn_list
*copyc dmv$initialize_tape_volume
*copyc fmp$get_files_volume_info
*copyc fmp$get_system_file_id
*copyc fsp$classify_tape_label
*copyc fsp$header_labels
*copyc fsp$locate_tape_label
*copyc fsp$trailer_labels
*copyc ofp$format_operator_menu
*copyc osp$append_status_integer
*copyc osp$generate_error_message
*copyc osp$generate_log_message
*copyc osp$set_status_condition
*copyc osp$set_status_abnormal
*copyc osp$translate_bytes
*copyc oss$job_paged_literal
*copyc osv$task_shared_heap
*copyc pmp$log_ascii
*copyc rmp$log_debug_message
*copyc rmp$log_debug_status

?? PUSH (LISTEXT := ON) ??
*copyc ame$access_validation_errors
*copyc ame$get_program_actions
*copyc ame$get_validation_errors
*copyc ame$improper_file_id
*copyc ame$open_validation_errors
*copyc ame$put_program_actions
*copyc ame$put_validation_errors
*copyc ame$ring_validation_errors
*copyc ame$skip_program_actions
*copyc ame$skip_validation_errors
*copyc ame$tape_program_actions
*copyc ame$unimplemented_request
*copyc ame$wtmk_validation_errors
*copyc bae$tape_bm_error_codes
*copyc bat$task_file_table
*copyc dme$tape_errors
*copyc fsc$max_tape_label_length
*copyc fsc$min_tape_label_length
*copyc fst$ansi_vol1_label
*copyc fst$tape_label_block_descriptor
*copyc fst$tape_label_sequence_header
*copyc ost$status
*copyc rmc$incorrect_recorded_vsn
*copyc rmc$wrong_label_type
?? POP ??

  TYPE
    bat$error_actions = (bac$continue, bac$exit_procedure, bac$retry_last_request),
    tape_attach_info_sources = SET OF fst$tape_attach_info_source;

  VAR
    blank_tape_volume: [STATIC, READ, oss$job_paged_literal] rmt$volume_descriptor :=
          [rmc$unspecified_vsn, rmc$unspecified_vsn],
    tape_label_sources: [STATIC, READ, oss$job_paged_literal] tape_attach_info_sources :=
          [fsc$tape_label_attr_command, fsc$tape_open_tape_attachment, fsc$tape_hdr1_label,
          fsc$tape_hdr2_label],
    valid_file_header_labels: [STATIC, READ, oss$job_paged_literal] fst$ansi_label_kinds :=
          [fsc$ansi_hdr1_label_kind, fsc$ansi_hdr2_label_kind, fsc$ansi_hdrn_label_kind,
          fsc$ansi_uhla_label_kind],
    valid_file_trailer_labels: [STATIC, READ, oss$job_paged_literal] fst$ansi_label_kinds :=
          [fsc$ansi_eof1_label_kind, fsc$ansi_eof2_label_kind, fsc$ansi_eofn_label_kind,
          fsc$ansi_utla_label_kind],
    valid_volume_header_labels: [STATIC, READ, oss$job_paged_literal] fst$ansi_label_kinds :=
          [fsc$ansi_hdr1_label_kind, fsc$ansi_hdr2_label_kind, fsc$ansi_hdrn_label_kind,
          fsc$ansi_uhla_label_kind, fsc$ansi_uvln_label_kind, fsc$ansi_vol1_label_kind,
          fsc$ansi_voln_label_kind],
    valid_volume_trailer_labels: [STATIC, READ, oss$job_paged_literal] fst$ansi_label_kinds :=
          [fsc$ansi_eov1_label_kind, fsc$ansi_eov2_label_kind, fsc$ansi_eovn_label_kind,
          fsc$ansi_uvln_label_kind];

{ GLOBAL_TAPE_FAP_VARIABLES.

  VAR
    block_info: [XDCL] ^bat$block_info,
    file_instance: [XDCL] ^bat$task_file_entry,
    gfi: [XDCL] ^bat$global_file_information,
    close_file_on_exit: [XDCL] boolean,
    global_layer_number: [XDCL] amt$fap_layer_number,
    operation: [XDCL] amt$fap_operation,
    rhl: [XDCL] 0 .. amc$maximum_block - 1,
    state_info: [XDCL] ^bat$labeled_tape_state_info,
    tape_descriptor: [XDCL] ^bat$tape_descriptor,
    tai: [XDCL] ^fst$tape_attachment_information;

  PROCEDURE [XDCL] bap$system_tape_label_fap (
        file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    status.normal := TRUE;

  /main_program/
    BEGIN

      CASE call_block.operation OF

      = amc$dismount_current_volume =
        dismount_tape_volume (status);

      = amc$open_tape_volume =
        open_tape_volume (file_identifier, call_block, layer_number, status);

      = amc$read_tape_labels =

        read_tape_labels (file_identifier, call_block, layer_number, status);

      = amc$write_tape_labels =
        write_tape_labels (file_identifier, call_block, layer_number, status);

      = amc$skip_req =
        IF call_block.skp.unit <> amc$skip_tape_mark THEN
          amp$set_file_instance_abnormal (file_identifier, ame$tape_rcd_mgr_malfunction, operation,
                'The tape label fap received a skip request with unit not equal to tape mark.', status);
          RETURN;
        IFEND;
        skip_tape_mark (file_identifier, call_block, status);

      = amc$terminate_tape_volume =
        terminate_tape_volume (call_block, status);

      ELSE

        bap$fap_control (file_identifier, call_block, layer_number, status);

      CASEND;

    END /main_program/;

  PROCEND bap$system_tape_label_fap;

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

  PROCEDURE dismount_tape_volume
    (VAR status: ost$status);

    VAR
      log_status: ost$status,
      sfid: gft$system_file_identifier;

    fmp$get_system_file_id (file_instance^.local_file_name, sfid, status);

    IF status.normal THEN
      bap$dismount_tape_volume (sfid, status);
    IFEND;

    IF NOT status.normal THEN
      pmp$log_ascii (' The following error occurred while dismounting a tape volume: ',
            $pmt$ascii_logset [pmc$job_log, pmc$system_log], pmc$msg_origin_program, log_status);
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], status, log_status);
    IFEND;

  PROCEND dismount_tape_volume;

?? OLDTITLE ??
?? NEWTITLE := '    get_volume_descriptor', EJECT ??
  PROCEDURE get_volume_descriptor (
        file_identifier: amt$file_identifier;
        layer_number: amt$fap_layer_number;
    VAR volume_descriptor: rmt$volume_descriptor);

    VAR
      fai_call_block: amt$call_block,
      local_status: ost$status,
      p_access_information: ^amt$access_information,
      volume_number: amt$volume_number;

    volume_descriptor.external_vsn := rmc$unspecified_vsn;
    volume_descriptor.recorded_vsn := rmc$unspecified_vsn;
    PUSH p_access_information: [1..1];
    p_access_information^ [1].key := amc$volume_number;
    fai_call_block.operation := amc$fetch_access_information_rq;
    fai_call_block.fai.access_information := p_access_information;
    bap$fap_control (file_identifier, fai_call_block, layer_number, local_status);
    IF local_status.normal THEN
      volume_number := p_access_information^ [1].volume_number;
      p_access_information^ [1].key := amc$volume_description;
      p_access_information^ [1].volume_index := volume_number;
      fai_call_block.operation := amc$fetch_access_information_rq;
      fai_call_block.fai.access_information := p_access_information;
      bap$fap_control (file_identifier, fai_call_block, layer_number, local_status);
      IF local_status.normal THEN
        volume_descriptor.external_vsn := p_access_information^ [1].volume_description.external_vsn;
        volume_descriptor.recorded_vsn := p_access_information^ [1].volume_description.recorded_vsn;
      IFEND;
    IFEND;

  PROCEND get_volume_descriptor;

?? OLDTITLE ??
?? NEWTITLE := '    get_volume_number', EJECT ??
  PROCEDURE get_volume_number (
        file_identifier: amt$file_identifier;
        layer_number: amt$fap_layer_number;
    VAR volume_number: amt$volume_number);

    VAR
      fai_call_block: amt$call_block,
      local_status: ost$status,
      p_access_information: ^amt$access_information;

    PUSH p_access_information: [1..1];
    p_access_information^ [1].key := amc$volume_number;
    fai_call_block.operation := amc$fetch_access_information_rq;
    fai_call_block.fai.access_information := p_access_information;
    bap$fap_control (file_identifier, fai_call_block, layer_number, local_status);
    IF local_status.normal THEN
      volume_number := p_access_information^ [1].volume_number;
    ELSE
      volume_number := 1;
    IFEND;

  PROCEND get_volume_number;

?? OLDTITLE ??
?? NEWTITLE := '    get_volume_position', EJECT ??
  PROCEDURE get_volume_position (
        file_identifier: amt$file_identifier;
        layer_number: amt$fap_layer_number;
    VAR volume_position: amt$volume_position);

    VAR
      fai_call_block: amt$call_block,
      local_status: ost$status,
      log_status: ost$status,
      p_access_information: ^amt$access_information;

    PUSH p_access_information: [1..1];
    p_access_information^ [1].key := amc$volume_position;
    fai_call_block.operation := amc$fetch_access_information_rq;
    fai_call_block.fai.access_information := p_access_information;

    bap$fap_control (file_identifier, fai_call_block, layer_number, local_status);
    IF local_status.normal THEN
      volume_position := p_access_information^ [1].volume_position;
    ELSE
      pmp$log_ascii (' The following error occurred on fetch of tape volume position: ',
            $pmt$ascii_logset [pmc$job_log, pmc$system_log], pmc$msg_origin_program, log_status);
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], local_status, log_status);
    IFEND;

  PROCEND get_volume_position;

?? OLDTITLE ??
?? NEWTITLE := '    open_tape_volume', EJECT ??
  PROCEDURE open_tape_volume (
        file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    VAR
      assignment_operation: dmt$tape_assignment_operation,
      current_volume: amt$volume_number,
      number_of_volumes: amt$volume_number,
      sfid: gft$system_file_identifier,
      requested_volume_attributes: iot$requested_volume_attributes,
      volume_information: ARRAY [1 .. 1] OF fmt$volume_info;

    get_volume_number (file_identifier, layer_number, current_volume);

    volume_information [1].key := fmc$number_of_volumes;
    fmp$get_files_volume_info (file_instance^.local_file_name, volume_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF volume_information [1].item_returned THEN
      number_of_volumes := volume_information [1].number_of_volumes;
    ELSE
      number_of_volumes := 1;
    IFEND;

    fmp$get_system_file_id (file_instance^.local_file_name, sfid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF call_block.open_tape_volume^.initial_assignment THEN
      assignment_operation := dmc$assign_initial_tape_volume;
    ELSE
      IF call_block.open_tape_volume^.opening_volume_number = 1 THEN
        assignment_operation := dmc$reset_tape_volume_list;
      ELSE
        IF call_block.open_tape_volume^.opening_volume_number <= number_of_volumes THEN
          IF call_block.open_tape_volume^.opening_volume_number = (current_volume + 1) THEN
            assignment_operation := dmc$advance_to_next_tape_volume;
          ELSE
            amp$set_file_instance_abnormal (file_identifier,
                dme$unimp_tape_assignment, LOWERVALUE (amt$last_operation),
                'non sequential assignment not implemented', status);
            RETURN;
          IFEND;
        ELSE
          IF call_block.open_tape_volume^.opening_volume_number = (number_of_volumes + 1) THEN
            assignment_operation := dmc$extend_tape_volume_list;
          ELSE
            amp$set_file_instance_abnormal (file_identifier,
                dme$invalid_tape_assignment, LOWERVALUE (amt$last_operation),
                'non sequential extension of volume list not allowed', status);
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF call_block.open_tape_volume^.opening_volume <> blank_tape_volume THEN
      requested_volume_attributes.account := call_block.open_tape_volume^.account;
      requested_volume_attributes.family := call_block.open_tape_volume^.family;
      requested_volume_attributes.project := call_block.open_tape_volume^.project;
      requested_volume_attributes.removable_media_group := call_block.open_tape_volume^.
             removable_media_group;
      requested_volume_attributes.removable_media_location := call_block.open_tape_volume^.
             removable_media_location;
      requested_volume_attributes.slot := call_block.open_tape_volume^.slot;
      requested_volume_attributes.user := call_block.open_tape_volume^.user;
      dmp$update_tape_vsn_list (sfid, file_instance^.local_file_name,
             call_block.open_tape_volume^.opening_volume, requested_volume_attributes,
             call_block.open_tape_volume^.source_pool, call_block.open_tape_volume^.source_pool_location,
             assignment_operation, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    CASE assignment_operation OF
    = dmc$assign_initial_tape_volume =
      dmp$assign_tape_volume (sfid, file_instance^.local_file_name, tape_descriptor^.
          file_label_type, file_instance^.instance_attributes.dynamic_label.access_mode, status);
    = dmc$advance_to_next_tape_volume =
      dmp$advance_tape_volume (sfid, { extend_volume_list = } FALSE,
          tape_descriptor^.file_label_type,
          file_instance^.instance_attributes.dynamic_label.access_mode, status);
    = dmc$extend_tape_volume_list =
      dmp$advance_tape_volume (sfid, { extend_volume_list = } TRUE,
          tape_descriptor^.file_label_type,
          file_instance^.instance_attributes.dynamic_label.access_mode, status);
    = dmc$reset_tape_volume_list =
      dmp$reset_tape_volume (sfid, tape_descriptor^.file_label_type,
          file_instance^.instance_attributes.dynamic_label.access_mode, status);
    ELSE
    CASEND;

  PROCEND open_tape_volume;

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

  PROCEDURE operator_menu_for_incorrect_vsn
    (    actual_rvsn: rmt$recorded_vsn;
         element_name: cmt$element_name;
         requested_evsn: rmt$external_vsn;
         requested_rvsn: rmt$recorded_vsn;
     VAR status: ost$status);

    CONST
      default_terminate_reason = 'the requested tape volume is not available',
      number_of_choices = 2;

    VAR
      message_parameters: array [1 .. 4] of ^ost$message_parameter,
      parameter_names: ^ost$parameter_help_names,
      response: oft$number_of_choices,
      response_string: ost$string,
      string_size: ost$name_size,
      terminate_reason: string (osc$max_string_size);

    message_parameters [1] := ^requested_rvsn;
    message_parameters [2] := ^requested_evsn;
    message_parameters [3] := ^actual_rvsn;
    message_parameters [4] := ^element_name;

    PUSH parameter_names: [1 .. number_of_choices];
    parameter_names^ [1] := 'CONTINUE_REQUEST';
    parameter_names^ [2] := 'TERMINATE_REQUEST';

    ofp$format_operator_menu (rmc$incorrect_recorded_vsn, parameter_names, ^message_parameters,
          number_of_choices, ofc$removable_media_operator, response, response_string, status);
    IF status.normal THEN
      CASE response OF
      = 1 = {reassign the correct volume. }
        osp$set_status_condition (dme$operator_reassign, status);
      = 2 = {terminate the assignment. }
        IF response_string.size > 0 THEN
          terminate_reason := response_string.value (1, response_string.size);
        ELSE
          terminate_reason := default_terminate_reason;
        IFEND;
        osp$set_status_abnormal (rmc$resource_management_id, dme$operator_stop, terminate_reason, status);
      ELSE
      CASEND;
    IFEND;

  PROCEND operator_menu_for_incorrect_vsn;

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

  PROCEDURE operator_menu_for_unlabeled
    (    element_name: cmt$element_name;
         requested_evsn: rmt$external_vsn;
         requested_rvsn: rmt$recorded_vsn;
     VAR status: ost$status);

    CONST
      default_terminate_reason = 'the requested tape volume is not available',
      number_of_choices = 2;

    VAR
      message_parameters: array [1 .. 3] of ^ost$message_parameter,
      parameter_names: ^ost$parameter_help_names,
      response_string: ost$string,
      response: oft$number_of_choices,
      string_size: ost$name_size,
      terminate_reason: string (osc$max_string_size);

    message_parameters [1] := ^requested_rvsn;
    message_parameters [2] := ^requested_evsn;
    message_parameters [3] := ^element_name;

    PUSH parameter_names: [1 .. number_of_choices];
    parameter_names^ [1] := 'ASSIGN_LABELED_VOLUME';
    parameter_names^ [2] := 'TERMINATE_REQUEST';

    ofp$format_operator_menu (rmc$wrong_label_type, parameter_names, ^message_parameters,
          number_of_choices, ofc$removable_media_operator, response, response_string, status);
    IF status.normal THEN
      CASE response OF
      = 1 = { reassign the correct volume. }
        osp$set_status_condition (dme$operator_reassign, status);
      = 2 = { terminate the assignment. }
        IF response_string.size > 0 THEN
          terminate_reason := response_string.value (1, response_string.size);
        ELSE
          terminate_reason := default_terminate_reason;
        IFEND;
        osp$set_status_abnormal (rmc$resource_management_id, dme$operator_stop, terminate_reason, status);
      ELSE
      CASEND;
    IFEND;

  PROCEND operator_menu_for_unlabeled;

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

{
{ The purpose of this request is to take a request status and failure modes
{ returned by the tape_block_manager and do the following:
{
{   1) Store the tape_failure_modes in the tape_descriptor,
{   2) Change any internal errors into either appropriate external errors.
{

  PROCEDURE process_request_status (
        file_identifier: amt$file_identifier;
        operation: amt$fap_operation;
        request_status: ost$status;
        tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);


    status.normal := TRUE;
    tape_descriptor^.failure_isolation.failure_modes := tape_failure_modes;
    tape_descriptor^.failure_isolation.failed_at_current_position := TRUE;
    IF request_status.normal THEN
      RETURN;
    IFEND;

{ Process abnormal request_status.

    IF request_status.condition =

{******} bae$cannot_lock_tape_pages {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$cannot_lock_tape_pages, operation, '', status);

    ELSEIF request_status.condition =

{******} bae$improper_access_attempt {******} THEN

      CASE operation OF

      = amc$write_tape_labels =
        amp$set_file_instance_abnormal (file_identifier, ame$improper_access_attempt, operation, 'WRITE',
            status);
      ELSE
        amp$set_file_instance_abnormal (file_identifier, ame$improper_access_attempt, operation, 'READ',
            status);
      CASEND;


    ELSEIF request_status.condition =

{******} bae$improper_file_id {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$improper_file_id, operation, '', status);

    ELSEIF request_status.condition =

{******} bae$improper_input_attempt {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$improper_input_attempt, operation, '', status);

    ELSEIF request_status.condition =

{******} bae$no_tape_write_ring {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$no_write_ring, operation, '', status);

    ELSEIF request_status.condition =

{******} bae$ring_validation_error {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$ring_validation_error, operation, '', status);

    ELSEIF request_status.condition =

{******} bae$skip_encountered_bov {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$skip_encountered_bov, operation, '', status);

    ELSEIF request_status.condition =

{******} bae$tape_block_mgr_malfunction {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$tape_block_mgr_malfunction, operation,
            request_status.text.value (2, request_status.text.size - 1), status);
      bai$append_tape_error (file_identifier, tape_failure_modes, status);

    ELSEIF request_status.condition =

{******} bae$tape_driver_not_capable {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$tape_driver_not_capable, operation, '', status);

    ELSEIF request_status.condition =

{******} bae$uncertain_tape_position {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$uncertain_tape_position, operation, '', status);
      bai$append_tape_error (file_identifier, tape_failure_modes, status);

    ELSEIF request_status.condition =

{******} bae$write_error_previous_block {******} THEN

      tape_descriptor^.failure_isolation.failed_at_current_position := FALSE;
      amp$set_file_instance_abnormal (file_identifier, ame$unrecovered_write_error, operation, '', status);
      bai$append_tape_error (file_identifier, tape_failure_modes, status);

    ELSEIF request_status.condition =

{******} bae$read_error_this_block {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$unrecovered_read_error, operation, '', status);
      bai$append_tape_error (file_identifier, tape_failure_modes, status);

    ELSEIF request_status.condition =

{******} bae$density_mismatch {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$tape_density_mismatch, operation, '', status);

    ELSEIF request_status.condition =

{******} bae$motion_past_phys_eot {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$motion_past_phys_eot, operation, '', status);

    ELSEIF request_status.condition =

{******} bae$write_error_this_block {******} THEN

      amp$set_file_instance_abnormal (file_identifier, ame$unrecovered_write_error, operation, '', status);
      bai$append_tape_error (file_identifier, tape_failure_modes, status);

    ELSE
      status := request_status;

    IFEND;

  PROCEND process_request_status;

?? OLDTITLE ??
?? NEWTITLE := '    read_tape_labels', EJECT ??
  PROCEDURE read_tape_labels
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    TYPE
      bat$read_label_list_entry = record
        link: ^bat$read_label_list_entry,
        tape_label_block_descriptor: fst$tape_label_block_descriptor,
        label: SEQ ( * ),
      recend;

    VAR
      block_length: amt$transfer_count,
      character_set: amt$internal_code,
      element_name: cmt$element_name,
      file_instance: ^bat$task_file_entry,
      first_label_kind: fst$ansi_label_kind,
      ignore_status: ost$status,
      initial_volume_position: amt$volume_position,
      label_classification: fst$tape_label_classification,
      label_count: integer,
      label_kinds: fst$ansi_label_kinds,
      label_sequence_size: ost$positive_integers,
      local_status: ost$status,
      os_error: ost$error,
      p_ansi_vol1_label: ^fst$ansi_vol1_label,
      p_area: ^string ( * ),
      p_area_request: ^array [1 .. * ] of cell,
      p_current_list_entry: ^bat$read_label_list_entry,
      p_initial_list_entry: ^bat$read_label_list_entry,
      p_label: ^SEQ ( * ),
      p_label_sequence: ^SEQ ( * ),
      p_label_sequence_header: ^fst$tape_label_sequence_header,
      p_label_string: ^string ( * ),
      p_next_list_entry: ^bat$read_label_list_entry,
      p_read_label_sequence: ^SEQ ( * ),
      p_tape_descriptor: ^bat$tape_descriptor,
      p_tape_label_block_descriptor: ^fst$tape_label_block_descriptor,
      request_status: ost$status,
      sfid: gft$system_file_identifier,
      tape_failure_modes: amt$tape_failure_modes,
      transfer_length: amt$transfer_count,
      valid_label: boolean,
      volume_descriptor: rmt$volume_descriptor,
      volume_number: amt$volume_number,
      volume_position: amt$volume_position;

    status.normal := TRUE;
    label_count := 0;
    label_sequence_size := #SIZE (fst$tape_label_sequence_header);
    file_instance := ^bav$task_file_table^ [file_identifier.ordinal];
    p_tape_descriptor := bai$tape_descriptor (file_instance);
    label_kinds := $fst$ansi_label_kinds [];

    get_volume_position (file_identifier, layer_number, initial_volume_position);

{   The first list entry is initialized to a tapemark but it will only be put into the trailer label
{   sequence.

    PUSH p_initial_list_entry: [[REP 1 OF cell]];
    p_initial_list_entry^.link := NIL;
    p_initial_list_entry^.tape_label_block_descriptor.label_block_type := fsc$tapemark_tape_label_block;
    p_current_list_entry := p_initial_list_entry;

    PUSH p_read_label_sequence: [[REP fsc$max_tape_label_length OF cell]];
    NEXT p_area_request: [1 .. fsc$max_tape_label_length] IN p_read_label_sequence;

  /read_labels/
    REPEAT
      block_length := 0;
      transfer_length := 0;
      tape_failure_modes := $amt$tape_failure_modes [];
      valid_label := FALSE;

      bap$tape_bm_read_label (file_identifier, p_area_request, fsc$max_tape_label_length,
            {system_media_recovery} TRUE, block_length, volume_position, tape_failure_modes, request_status);
      process_request_status (file_identifier, operation, request_status, tape_failure_modes, status);

      IF block_length > 0 THEN
        IF block_length > fsc$max_tape_label_length THEN
          transfer_length := fsc$max_tape_label_length;
        ELSE
          transfer_length := block_length;
        IFEND;
        PUSH p_next_list_entry: [[REP transfer_length OF cell]];
        label_sequence_size := label_sequence_size + #SIZE (fst$tape_label_block_descriptor) +
              transfer_length;
        RESET p_read_label_sequence;
        NEXT p_area: [transfer_length] IN p_read_label_sequence;
      ELSE
        transfer_length := 0;
        PUSH p_next_list_entry: [[REP 1 OF cell]];
        label_sequence_size := label_sequence_size + #SIZE (fst$tape_label_block_descriptor);
      IFEND;

      p_current_list_entry^.link := p_next_list_entry;
      p_next_list_entry^.link := NIL;

      IF status.normal THEN
        tape_descriptor^.volume_position := volume_position;
        IF volume_position = amc$after_tapemark THEN
          IF label_count = 0 THEN
            get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
            IF dmv$initialize_tape_volume.in_progress OR (initial_volume_position <> amc$bov) OR
                  (tape_descriptor^.file_label_type <> amc$labeled) THEN
              amp$set_file_instance_abnormal (file_identifier, ame$unexpected_tapemark, operation,
                    volume_descriptor.external_vsn, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn,
                    status);
            ELSE
              fmp$get_system_file_id (file_instance^.local_file_name, sfid, status);
              IF NOT status.normal THEN
                EXIT /read_labels/;
              IFEND;
              IF bap$volume_robotically_mounted (sfid) THEN
                amp$set_file_instance_abnormal (file_identifier, ame$improper_file_label_type, operation,
                      volume_descriptor.external_vsn, status);
                dismount_tape_volume (ignore_status);
              ELSE
                bap$get_tape_element_name (sfid, element_name, status);
                IF NOT status.normal THEN
                  EXIT /read_labels/;
                IFEND;
                operator_menu_for_unlabeled (element_name, volume_descriptor.external_vsn,
                      volume_descriptor.recorded_vsn, status);
                IF status.condition = dme$operator_reassign THEN
                  remount_tape_volume (status);
                  IF status.normal THEN
                    CYCLE /read_labels/;
                  IFEND;
                ELSE
                  dismount_tape_volume (ignore_status);
                IFEND;
              IFEND;
            IFEND;
            EXIT /read_labels/;
          ELSE
            p_next_list_entry^.tape_label_block_descriptor.label_block_type := fsc$tapemark_tape_label_block;
            label_count := label_count + 1;
          IFEND;
        ELSE
          IF (volume_position = amc$after_data_block) AND (block_length >= fsc$min_tape_label_length) THEN
            fsp$classify_tape_label (p_area^, label_classification);
            valid_label := label_classification.valid_label;
            IF valid_label THEN
              IF label_classification.character_set = amc$ebcdic THEN
                osp$translate_bytes (#LOC (p_area^), transfer_length, #LOC (p_area^), transfer_length,
                      ^osv$ebcdic_to_ascii, os_error);
              IFEND;
              IF label_count = 0 THEN
                character_set := label_classification.character_set;
                first_label_kind := label_classification.label_kind;
                IF initial_volume_position = amc$bov THEN
                  IF label_classification.label_kind = fsc$ansi_vol1_label_kind THEN
                    RESET p_read_label_sequence;
                    NEXT p_ansi_vol1_label IN p_read_label_sequence;
                    get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
                    IF (tape_descriptor^.file_label_type = amc$labeled) AND
                          (NOT dmv$initialize_tape_volume.in_progress) AND
                          (p_ansi_vol1_label^.volume_identifier <> volume_descriptor.recorded_vsn) THEN
                      fmp$get_system_file_id (file_instance^.local_file_name, sfid, status);
                      IF NOT status.normal THEN
                        EXIT /read_labels/;
                      IFEND;
                      IF bap$volume_robotically_mounted (sfid) THEN
                        osp$set_status_abnormal (amc$access_method_id, ame$unknown_volume,
                              volume_descriptor.external_vsn, status);
                        osp$append_status_parameter (osc$status_parameter_delimiter,
                              volume_descriptor.recorded_vsn, status);
                        dismount_tape_volume (ignore_status);
                      ELSE
                        bap$get_tape_element_name (sfid, element_name, status);
                        IF NOT status.normal THEN
                          EXIT /read_labels/;
                        IFEND;
                        operator_menu_for_incorrect_vsn (p_ansi_vol1_label^.volume_identifier, element_name,
                              volume_descriptor.external_vsn, volume_descriptor.recorded_vsn, status);
                        IF status.condition = dme$operator_reassign THEN
                          remount_tape_volume (status);
                          IF status.normal THEN
                            CYCLE /read_labels/;
                          IFEND;
                        ELSE
                          dismount_tape_volume (ignore_status);
                        IFEND;
                      IFEND;
                      EXIT /read_labels/;
                    IFEND;
                  ELSE {at BOV and first label is not VOL1}
                    IF NOT dmv$initialize_tape_volume.in_progress THEN
                      get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
                      amp$set_file_instance_abnormal (file_identifier, ame$unexpected_tape_label,
                            operation, volume_descriptor.external_vsn, status);
                      osp$append_status_parameter (osc$status_parameter_delimiter,
                            volume_descriptor.recorded_vsn, status);
                      osp$append_status_parameter (osc$status_parameter_delimiter,
                            label_classification.label_identifier, status);
                      osp$append_status_parameter (osc$status_parameter_delimiter, 'VOL1', status);
                      EXIT /read_labels/;
                    IFEND;
                  IFEND;
                ELSE
                  IF NOT ((label_classification.label_kind = fsc$ansi_hdr1_label_kind) OR
                        (label_classification.label_kind = fsc$ansi_eof1_label_kind) OR
                        (label_classification.label_kind = fsc$ansi_eov1_label_kind)) THEN
                    get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
                    amp$set_file_instance_abnormal (file_identifier, ame$unexpected_tape_label, operation,
                          volume_descriptor.external_vsn, status);
                    osp$append_status_parameter (osc$status_parameter_delimiter,
                          volume_descriptor.recorded_vsn, status);
                    osp$append_status_parameter (osc$status_parameter_delimiter,
                          label_classification.label_identifier, status);
                    osp$append_status_parameter (osc$status_parameter_delimiter, 'HDR1 or EOF1 or EOV1',
                          status);
                    EXIT /read_labels/;
                  IFEND;
                IFEND;

              ELSE { label_count > 0 }
                IF (first_label_kind = fsc$ansi_vol1_label_kind) AND
                      (NOT (label_classification.label_kind IN valid_volume_header_labels)) THEN
                  get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
                  amp$set_file_instance_abnormal (file_identifier, ame$unexpected_tape_label, operation,
                        volume_descriptor.external_vsn, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn,
                        local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        label_classification.label_identifier, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, 'VOLN or UVNL or HDRN or UHLA',
                        local_status);
                  rmp$log_debug_message (' The following error occurred while reading tape labels: ');
                  rmp$log_debug_status (local_status);
                ELSEIF (first_label_kind = fsc$ansi_eov1_label_kind) AND
                      (NOT (label_classification.label_kind IN valid_volume_trailer_labels)) THEN
                  get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
                  amp$set_file_instance_abnormal (file_identifier, ame$unexpected_tape_label, operation,
                        volume_descriptor.external_vsn, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn,
                        local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        label_classification.label_identifier, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, 'VOLN or UVLN', local_status);
                  rmp$log_debug_message (' The following error occurred while reading tape labels: ');
                  rmp$log_debug_status (local_status);
                ELSEIF (first_label_kind = fsc$ansi_hdr1_label_kind) AND
                      (NOT (label_classification.label_kind IN valid_file_header_labels)) THEN
                  get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
                  amp$set_file_instance_abnormal (file_identifier, ame$unexpected_tape_label, operation,
                        volume_descriptor.external_vsn, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn,
                        local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        label_classification.label_identifier, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, 'HDRN or UHLA', local_status);
                  rmp$log_debug_message (' The following error occurred while reading tape labels: ');
                  rmp$log_debug_status (local_status);
                ELSEIF (first_label_kind = fsc$ansi_eof1_label_kind) AND
                      (NOT (label_classification.label_kind IN valid_file_trailer_labels)) THEN
                  get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
                  amp$set_file_instance_abnormal (file_identifier, ame$unexpected_tape_label, operation,
                        volume_descriptor.external_vsn, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn,
                        local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        label_classification.label_identifier, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, 'EOFN or UTLA', local_status);
                  rmp$log_debug_message (' The following error occurred while reading tape labels: ');
                  rmp$log_debug_status (local_status);
                IFEND;
              IFEND;

              label_kinds := label_kinds + $fst$ansi_label_kinds [label_classification.label_kind];
              p_next_list_entry^.tape_label_block_descriptor.label_block_type := fsc$normal_tape_label_block;
              p_next_list_entry^.tape_label_block_descriptor.normal_label_actual_length := block_length;
              p_next_list_entry^.tape_label_block_descriptor.normal_label_transfer_length := transfer_length;
              p_next_list_entry^.tape_label_block_descriptor.normal_label_character_set :=
                    label_classification.character_set;
              p_next_list_entry^.tape_label_block_descriptor.normal_label_kind :=
                    label_classification.label_kind;
              label_count := label_count + 1;
            IFEND;
          IFEND;

          IF NOT valid_label THEN
            IF label_count = 0 THEN
              IF initial_volume_position = amc$bov THEN
                IF dmv$initialize_tape_volume.in_progress OR (tape_descriptor^.file_label_type <> amc$labeled)
                      THEN
                  get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
                  amp$set_file_instance_abnormal (file_identifier, ame$invalid_tape_label, operation,
                        volume_descriptor.external_vsn, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn,
                        status);
                  EXIT /read_labels/;
                ELSE
                  get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
                  fmp$get_system_file_id (file_instance^.local_file_name, sfid, status);
                  IF NOT status.normal THEN
                    EXIT /read_labels/;
                  IFEND;
                  IF bap$volume_robotically_mounted (sfid) THEN
                    amp$set_file_instance_abnormal (file_identifier, ame$improper_file_label_type, operation,
                          volume_descriptor.external_vsn, status);
                    dismount_tape_volume (ignore_status);
                  ELSE
                    bap$get_tape_element_name (sfid, element_name, status);
                    IF NOT status.normal THEN
                      EXIT /read_labels/;
                    IFEND;
                    operator_menu_for_unlabeled (element_name, volume_descriptor.external_vsn,
                          volume_descriptor.recorded_vsn, status);
                    IF status.condition = dme$operator_reassign THEN
                      remount_tape_volume (status);
                      IF status.normal THEN
                        CYCLE /read_labels/;
                      IFEND;
                    ELSE
                      dismount_tape_volume (ignore_status);
                    IFEND;
                  IFEND;
                  EXIT /read_labels/;
                IFEND;
              ELSE
                get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
                amp$set_file_instance_abnormal (file_identifier, ame$invalid_tape_label, operation,
                      volume_descriptor.external_vsn, status);
                osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn,
                      status);
                EXIT /read_labels/;
              IFEND;
            ELSE
              p_next_list_entry^.tape_label_block_descriptor.label_block_type := fsc$non_tape_label_block;
              p_next_list_entry^.tape_label_block_descriptor.non_label_actual_length := block_length;
              p_next_list_entry^.tape_label_block_descriptor.non_label_transfer_length := transfer_length;
              label_count := label_count + 1;
            IFEND;
          IFEND;
        IFEND;
      ELSE
        IF (status.condition = ame$unrecovered_read_error) OR (dmv$initialize_tape_volume.in_progress AND
              (status.condition = ame$tape_density_mismatch)) THEN
          get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
          amp$set_file_instance_abnormal (file_identifier, ame$tape_label_read_error, operation,
                volume_descriptor.external_vsn, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn,
                status);
          osp$append_status_integer (osc$status_parameter_delimiter, label_count + 1, {radix} 10,
                {include_radix_specifier} FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, '', status);
          bai$append_tape_error (file_identifier, tape_failure_modes, status);
          IF (amc$tfm_blank_tape_read IN tape_failure_modes) THEN
            EXIT /read_labels/;
          IFEND;
        IFEND;
{
{ A new or degaussed tape gets a density error at loadpoint.  If the tape is requested as
{ unlabeled for write purposes (not initialization), set an error condition which allows
{ the request to continue without processing tape labels
{
        IF (status.condition = ame$tape_density_mismatch) AND
              (tape_descriptor^.file_label_type <> amc$labeled) AND
              (pfc$append IN file_instance^.instance_attributes.dynamic_label.access_mode) THEN
          get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
          amp$set_file_instance_abnormal (file_identifier, ame$invalid_tape_label, operation,
                volume_descriptor.external_vsn, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn,
                status);
          EXIT /read_labels/;
        IFEND;
        IF label_count = 0 THEN
          EXIT /read_labels/;
        ELSE
          rmp$log_debug_message (' The following error occurred while reading tape labels: ');
          rmp$log_debug_status (status);
          p_next_list_entry^.tape_label_block_descriptor.label_block_type := fsc$erroneous_tape_label_block;
          p_next_list_entry^.tape_label_block_descriptor.erroneous_label_actual_length := block_length;
          p_next_list_entry^.tape_label_block_descriptor.erroneous_label_transfer_length := transfer_length;
          p_next_list_entry^.tape_label_block_descriptor.erroneous_label_failure_modes := tape_failure_modes;
          label_count := label_count + 1;
        IFEND;
      IFEND;

      IF transfer_length > 0 THEN
        p_label := ^p_next_list_entry^.label;
        NEXT p_label_string: [transfer_length] IN p_label;
        p_label_string^ (1, transfer_length) := p_area^ (1, transfer_length);
      IFEND;
      p_current_list_entry := p_next_list_entry;

      IF label_count >= (fsc$max_tape_labels - 1) THEN
        PUSH p_next_list_entry: [[REP 1 OF cell]];
        label_sequence_size := label_sequence_size + #SIZE (fst$tape_label_block_descriptor);
        p_current_list_entry^.link := p_next_list_entry;
        p_next_list_entry^.link := NIL;
        p_next_list_entry^.tape_label_block_descriptor.label_block_type := fsc$tapemark_tape_label_block;
        label_count := label_count + 1;

        get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
        amp$set_file_instance_abnormal (file_identifier, ame$excessive_tape_labels, operation,
              volume_descriptor.external_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn, status);
        osp$append_status_integer (osc$status_parameter_delimiter, fsc$max_tape_labels, {radix} 10,
              {include_radix_specifier} FALSE, status);
        EXIT /read_labels/;
      IFEND;

    UNTIL volume_position = amc$after_tapemark;

    IF NOT status.normal THEN
      rmp$log_debug_message (' The following error occurred while reading tape labels: ');
      rmp$log_debug_status (status);
    IFEND;

    IF (label_count > 0) AND (status.normal OR (status.condition = ame$excessive_tape_labels)) THEN
      call_block.read_tape_labels^.label_kinds := label_kinds;

{     A trailer label sequence (but not a header label sequence) begins with a tapemark if the volume position
{     before reading labels is 'after tapemark'.

      IF (initial_volume_position = amc$after_tapemark) AND
            ((first_label_kind = fsc$ansi_eov1_label_kind) OR (first_label_kind = fsc$ansi_eof1_label_kind))
            THEN
        p_next_list_entry := p_initial_list_entry;
        label_count := label_count + 1;
        label_sequence_size := label_sequence_size + #SIZE (fst$tape_label_block_descriptor);
      ELSE
        p_next_list_entry := p_initial_list_entry^.link;
      IFEND;

      PUSH p_label_sequence: [[REP label_sequence_size OF cell]];
      NEXT p_label_sequence_header IN p_label_sequence;
      p_label_sequence_header^.character_set := character_set;
      p_label_sequence_header^.label_kinds := label_kinds;
      p_label_sequence_header^.sequence_size := label_sequence_size;
      p_label_sequence_header^.label_count := label_count;

      REPEAT
        NEXT p_tape_label_block_descriptor IN p_label_sequence;
        p_tape_label_block_descriptor^ := p_next_list_entry^.tape_label_block_descriptor;
        p_label := NIL;

        CASE p_next_list_entry^.tape_label_block_descriptor.label_block_type OF

        = fsc$erroneous_tape_label_block =
          IF p_next_list_entry^.tape_label_block_descriptor.erroneous_label_transfer_length > 0 THEN
            NEXT p_label: [[REP p_next_list_entry^.tape_label_block_descriptor.
                  erroneous_label_transfer_length OF cell]] IN p_label_sequence;
          IFEND;

        = fsc$non_tape_label_block =
          IF p_next_list_entry^.tape_label_block_descriptor.non_label_transfer_length > 0 THEN
            NEXT p_label: [[REP p_next_list_entry^.tape_label_block_descriptor.non_label_transfer_length OF
                  cell]] IN p_label_sequence;
          IFEND;

        = fsc$normal_tape_label_block =
          IF p_next_list_entry^.tape_label_block_descriptor.normal_label_transfer_length > 0 THEN
            NEXT p_label: [[REP p_next_list_entry^.tape_label_block_descriptor.normal_label_transfer_length OF
                  cell]] IN p_label_sequence;
          IFEND;

        = fsc$tapemark_tape_label_block =
          ;

        CASEND;

        IF p_label <> NIL THEN
          p_label^ := p_next_list_entry^.label;
        IFEND;
        p_current_list_entry := p_next_list_entry;
        p_next_list_entry := p_next_list_entry^.link;
      UNTIL p_next_list_entry = NIL;

      get_volume_number (file_identifier, layer_number, volume_number);
      IF (volume_number = 1) AND (initial_volume_position = amc$bov) THEN
        bap$store_unsecured_tape_labels (p_label_sequence, p_tape_descriptor^.initial_volume.header_labels);
      IFEND;

      IF fsp$header_labels (label_kinds) THEN
        bap$store_unsecured_tape_labels (p_label_sequence, p_tape_descriptor^.last_accessed.
              unsecured_header_labels);
        store_secured_tape_labels (p_label_sequence, p_tape_descriptor^.last_accessed.secured_header_labels);
      ELSEIF fsp$trailer_labels (label_kinds) THEN
        bap$store_unsecured_tape_labels (p_label_sequence, p_tape_descriptor^.last_accessed.
              unsecured_trailer_labels);
        store_secured_tape_labels (p_label_sequence, p_tape_descriptor^.last_accessed.secured_trailer_labels);
      IFEND;
    IFEND;

  PROCEND read_tape_labels;

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

  PROCEDURE remount_tape_volume
    (VAR status: ost$status);

    VAR
      log_status: ost$status,
      sfid: gft$system_file_identifier;

    fmp$get_system_file_id (file_instance^.local_file_name, sfid, status);

    IF status.normal THEN
      dmp$unload_remount_tape_volume (sfid, file_instance^.instance_attributes.dynamic_label.access_mode,
            {recovery_remount} FALSE, status);
    IFEND;

    IF NOT status.normal THEN
      pmp$log_ascii (' The following error occurred while remounting a tape volume: ',
            $pmt$ascii_logset [pmc$job_log, pmc$system_log], pmc$msg_origin_program, log_status);
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], status, log_status);
    IFEND;

  PROCEND remount_tape_volume;

?? OLDTITLE ??
?? NEWTITLE := '    skip_tape_mark', EJECT ??
  PROCEDURE skip_tape_mark (
        file_identifier: amt$file_identifier;
        call_block: amt$call_block;
    VAR status: ost$status);

{ This procedure is used to skip a user defined number of tape marks in the
{ user defined direction. Tape mark skipping will stop when the number of
{ tape marks are reached or when the tape reached the beginning of volume.

    VAR
      request_status: ost$status,
      skip_count: amt$skip_count,
      tape_failure_modes: amt$tape_failure_modes;

    status.normal := TRUE;
    skip_count := call_block.skp.count;

    WHILE skip_count > 0 DO
      bap$tape_bm_skip_label_mark (file_identifier, call_block.skp.direction,
            tape_failure_modes, request_status);
      process_request_status (file_identifier, operation, request_status, tape_failure_modes,
            status);
      IF NOT status.normal THEN
        IF (status.condition = ame$skip_encountered_bov) AND
              (call_block.skp.direction = amc$backward) THEN
          tape_descriptor^.volume_position := amc$bov;
        IFEND;
        RETURN;
      IFEND;
      skip_count := skip_count - 1;
    WHILEND;

    IF call_block.skp.direction = amc$forward THEN
      tape_descriptor^.volume_position := amc$after_tapemark;
    ELSE {call_block.skp.direction = amc$backward THEN
      tape_descriptor^.volume_position := amc$before_tapemark;
    IFEND;

  PROCEND skip_tape_mark;

?? OLDTITLE ??
?? NEWTITLE := '    store_secured_tape_labels', EJECT ??
  PROCEDURE store_secured_tape_labels
    (    p_label_sequence: ^SEQ ( * );
     VAR p_stored_label_sequence: ^SEQ ( * ));

    IF p_stored_label_sequence <> NIL THEN
      FREE p_stored_label_sequence IN osv$task_shared_heap^;
    IFEND;

    ALLOCATE p_stored_label_sequence: [[REP #SIZE (p_label_sequence^) OF CELL]] IN osv$task_shared_heap^;

    p_stored_label_sequence^ := p_label_sequence^;

    RESET p_stored_label_sequence;

  PROCEND store_secured_tape_labels;

?? OLDTITLE ??
?? NEWTITLE := '    terminate_tape_volume', EJECT ??
  PROCEDURE terminate_tape_volume (
        call_block: amt$call_block;
    VAR status: ost$status);

    status.normal := TRUE;

{ The purpose of this fap operation is to let the RMS fap, if installed, get control
{ when a file is being terminated because the last operation was a write to tape and
{ the current operation is either to close the file, to rewind the file or to
{ skip backwards. The process is to first call the RMS fap which will then call the
{ site modifiable validation fap which finally calls this fap. At present this fap
{ is a no-op for this operation and control is returned to the caller.

  PROCEND terminate_tape_volume;

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

  PROCEDURE write_tape_labels
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      file_instance: ^bat$task_file_entry,
      first_label_kind: fst$ansi_label_kind,
      ignore_status: ost$status,
      initial_volume_position: amt$volume_position,
      label_count: ost$non_negative_integers,
      labels_written: boolean,
      log_status: ost$status,
      normal_label_blocks_written: ost$non_negative_integers,
      os_error: ost$error,
      p_area: ^string ( * ),
      p_area_request: ^array [1 .. * ] of cell,
      p_label_sequence: ^SEQ ( * ),
      p_label_sequence_header: ^fst$tape_label_sequence_header,
      p_label_string: ^string ( * ),
      p_tape_descriptor: ^bat$tape_descriptor,
      p_tape_label_block_descriptor: ^fst$tape_label_block_descriptor,
      request_status: ost$status,
      tape_failure_modes: amt$tape_failure_modes,
      transfer_length: amt$transfer_count,
      volume_descriptor: rmt$volume_descriptor,
      volume_number: amt$volume_number;

?? NEWTITLE := '      write_block', EJECT ??

    PROCEDURE write_block;

      VAR
        block_pointer: ^cell,
        ebcdic_block: ^string ( * );

      IF (p_label_sequence_header^.character_set = amc$ascii) THEN
        rmp$log_debug_message (p_label_string^);
        block_pointer := p_label_string;
        bap$tape_bm_write_label (file_identifier, block_pointer, transfer_length,
              {system_media_recovery} TRUE, tape_failure_modes, request_status);
        process_request_status (file_identifier, operation, request_status, tape_failure_modes, status);
      ELSEIF p_label_sequence_header^.character_set = amc$ebcdic THEN
        PUSH ebcdic_block: [transfer_length];
        ebcdic_block^ (1, transfer_length) := p_label_string^ (1, transfer_length);
        osp$translate_bytes (#LOC (ebcdic_block^), transfer_length, #LOC (ebcdic_block^), transfer_length,
              ^osv$ascii_to_ebcdic, os_error);
        block_pointer := ebcdic_block;
        bap$tape_bm_write_label (file_identifier, block_pointer, transfer_length,
              {system_media_recovery} TRUE, tape_failure_modes, request_status);
        process_request_status (file_identifier, operation, request_status, tape_failure_modes, status);
      ELSE
        get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
        amp$set_file_instance_abnormal (file_identifier, ame$invalid_tape_label_sequence, operation,
              volume_descriptor.external_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              'invalid character_set in fst$tape_label_sequence_header', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'write', status);
      IFEND;

    PROCEND write_block;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

  /write_labels_block/
    BEGIN

      file_instance := ^bav$task_file_table^ [file_identifier.ordinal];
      p_tape_descriptor := bai$tape_descriptor (file_instance);
      normal_label_blocks_written := 0;

      get_volume_position (file_identifier, layer_number, initial_volume_position);

      p_label_sequence := call_block.write_tape_labels;
      IF p_label_sequence = NIL THEN
        get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
        amp$set_file_instance_abnormal (file_identifier, ame$invalid_tape_label_sequence,
              operation, volume_descriptor.external_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              volume_descriptor.recorded_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              'NIL label sequence pointer in amc$write_tape_labels call block', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'write', status);
        EXIT /write_labels_block/;
      IFEND;

      RESET p_label_sequence;
      NEXT p_label_sequence_header IN p_label_sequence;

      IF p_label_sequence_header = NIL THEN
        get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
        amp$set_file_instance_abnormal (file_identifier, ame$invalid_tape_label_sequence,
              operation, volume_descriptor.external_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              volume_descriptor.recorded_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              'sequence too short for fst$tape_label_sequence_header', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'write', status);
        EXIT /write_labels_block/;
      IFEND;

      IF p_label_sequence_header^.label_count <= 0 THEN
        get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
        amp$set_file_instance_abnormal (file_identifier, ame$invalid_tape_label_sequence,
              operation, volume_descriptor.external_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              volume_descriptor.recorded_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              'label_count in fst$tape_label_sequence_header <= 0', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'write', status);
        EXIT /write_labels_block/;
      IFEND;

      IF p_label_sequence_header^.label_count > fsc$max_tape_labels THEN
        get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
        amp$set_file_instance_abnormal (file_identifier, ame$invalid_tape_label_sequence,
              operation, volume_descriptor.external_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              volume_descriptor.recorded_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              'label_count in fst$tape_label_sequence_header > fsc$max_tape_labels', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'write', status);
        EXIT /write_labels_block/;
      IFEND;

    /write_labels/
      FOR label_count := 1 TO p_label_sequence_header^.label_count DO
        NEXT p_tape_label_block_descriptor IN p_label_sequence;
        IF p_tape_label_block_descriptor = NIL THEN
          get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
          amp$set_file_instance_abnormal (file_identifier, ame$invalid_tape_label_sequence,
                operation, volume_descriptor.external_vsn, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                volume_descriptor.recorded_vsn, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'sequence too short for fst$tape_label_block_descriptor', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'write', status);
          EXIT /write_labels_block/;
        IFEND;

        CASE p_tape_label_block_descriptor^.label_block_type OF

          = fsc$erroneous_tape_label_block =
            NEXT p_label_string: [p_tape_label_block_descriptor^.erroneous_label_transfer_length]
                  IN p_label_sequence;
            IF p_label_string = NIL THEN
              get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
              amp$set_file_instance_abnormal (file_identifier, ame$invalid_tape_label_sequence,
                    operation, volume_descriptor.external_vsn, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    volume_descriptor.recorded_vsn, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    'sequence too short for fsc$erroneous_tape_label_block', status);
              osp$append_status_parameter (osc$status_parameter_delimiter, 'write', status);
              EXIT /write_labels_block/;
            IFEND;

          = fsc$non_tape_label_block =
            transfer_length := p_tape_label_block_descriptor^.non_label_transfer_length;
            NEXT p_label_string: [transfer_length] IN p_label_sequence;
            IF p_label_string = NIL THEN
              get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
              amp$set_file_instance_abnormal (file_identifier, ame$invalid_tape_label_sequence,
                    operation, volume_descriptor.external_vsn, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    volume_descriptor.recorded_vsn, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    'sequence too short for fsc$non_tape_label_block', status);
              osp$append_status_parameter (osc$status_parameter_delimiter, 'write', status);
              EXIT /write_labels_block/;
            IFEND;
            write_block;

          = fsc$normal_tape_label_block =
            transfer_length := p_tape_label_block_descriptor^.normal_label_transfer_length;
            NEXT p_label_string: [transfer_length] IN p_label_sequence;
            IF p_label_string = NIL THEN
              get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
              amp$set_file_instance_abnormal (file_identifier, ame$invalid_tape_label_sequence,
                    operation, volume_descriptor.external_vsn, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    volume_descriptor.recorded_vsn, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    'sequence too short for fsc$normal_tape_label_block', status);
              osp$append_status_parameter (osc$status_parameter_delimiter, 'write', status);
              EXIT /write_labels_block/;
            IFEND;
            IF normal_label_blocks_written = 0 THEN
              IF p_label_string^ (1, 4) = 'VOL1' THEN
                first_label_kind := fsc$ansi_vol1_label_kind;
              ELSEIF p_label_string^ (1, 4) = 'HDR1' THEN
                first_label_kind := fsc$ansi_hdr1_label_kind;
              ELSEIF p_label_string^ (1, 4) = 'EOF1' THEN
                first_label_kind := fsc$ansi_eof1_label_kind;
              ELSEIF p_label_string^ (1, 4) = 'EOV1' THEN
                first_label_kind := fsc$ansi_eov1_label_kind;
              ELSE
                get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
                amp$set_file_instance_abnormal (file_identifier, ame$invalid_tape_label_sequence,
                      operation, volume_descriptor.external_vsn, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      volume_descriptor.recorded_vsn, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      'first normal label not VOL1, HDR1, EOF1 or EOV1', status);
                osp$append_status_parameter (osc$status_parameter_delimiter, 'write', status);
                EXIT /write_labels_block/;
              IFEND;
            IFEND;
            write_block;
            IF status.normal THEN
              tape_descriptor^.volume_position := amc$after_data_block;
              normal_label_blocks_written := normal_label_blocks_written + 1;
            IFEND;

          = fsc$null_tape_label_block =
            NEXT p_label_string: [p_tape_label_block_descriptor^.null_label_transfer_length]
                  IN p_label_sequence;
            IF p_label_string = NIL THEN
                get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
                  amp$set_file_instance_abnormal (file_identifier, ame$invalid_tape_label_sequence,
                        operation, volume_descriptor.external_vsn, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      volume_descriptor.recorded_vsn, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      'sequence too short for fsc$null_tape_label_block', status);
                osp$append_status_parameter (osc$status_parameter_delimiter, 'write', status);
              EXIT /write_labels_block/;
            IFEND;

          = fsc$tapemark_tape_label_block =
             rmp$log_debug_message ('*');
             bap$tape_bm_write_label_mark (file_identifier, {system_media_recovery} TRUE, tape_failure_modes,
                   request_status);
             process_request_status (file_identifier, operation, request_status, tape_failure_modes,
                   status);

            IF status.normal THEN
              tape_descriptor^.volume_position := amc$after_tapemark;
            IFEND;

          ELSE
            get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
              amp$set_file_instance_abnormal (file_identifier, ame$invalid_tape_label_sequence,
                    operation, volume_descriptor.external_vsn, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  volume_descriptor.recorded_vsn, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  'invalid label_block_type in fst$tape_label_block_descriptor', status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'write', status);
        CASEND;

        IF NOT status.normal THEN
          IF status.condition = ame$unrecovered_write_error THEN
            get_volume_descriptor (file_identifier, layer_number, volume_descriptor);
            amp$set_file_instance_abnormal (file_identifier, ame$tape_label_write_error,
                  operation, volume_descriptor.external_vsn, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  volume_descriptor.recorded_vsn, status);
            osp$append_status_integer (osc$status_parameter_delimiter, label_count + 1,
                     {radix} 10, {include_radix_specifier} FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, '', status);
            bai$append_tape_error (file_identifier, tape_failure_modes, status);
          IFEND;
          EXIT /write_labels/;
        IFEND;

      FOREND /write_labels/;

      IF status.normal AND (normal_label_blocks_written > 0) THEN
        get_volume_number (file_identifier, layer_number, volume_number);
        IF (first_label_kind = fsc$ansi_vol1_label_kind) AND (volume_number = 1) AND
              (initial_volume_position = amc$bov) THEN
          bap$store_unsecured_tape_labels (p_label_sequence,
                p_tape_descriptor^.initial_volume.header_labels);
        IFEND;

        IF (first_label_kind = fsc$ansi_vol1_label_kind) OR
              (first_label_kind = fsc$ansi_hdr1_label_kind) THEN
          bap$store_unsecured_tape_labels (p_label_sequence,
                p_tape_descriptor^.last_accessed.unsecured_header_labels);
          store_secured_tape_labels (p_label_sequence,
                p_tape_descriptor^.last_accessed.secured_header_labels);
        ELSEIF (first_label_kind = fsc$ansi_eov1_label_kind) OR
              (first_label_kind = fsc$ansi_eof1_label_kind) THEN
          bap$store_unsecured_tape_labels (p_label_sequence,
                p_tape_descriptor^.last_accessed.unsecured_trailer_labels);
          store_secured_tape_labels (p_label_sequence,
                p_tape_descriptor^.last_accessed.secured_trailer_labels);
        IFEND;
      IFEND;

    END /write_labels_block/;

    IF NOT status.normal THEN
      pmp$log_ascii (' The following error occurred while writing tape labels: ',
            $pmt$ascii_logset [pmc$job_log, pmc$system_log], pmc$msg_origin_program, log_status);
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], status, log_status);
      osp$generate_error_message (status, ignore_status);
    IFEND;

  PROCEND write_tape_labels;

MODEND bam$system_tape_label_fap;
*DECK DECK=BAM$SYSTEM_TAPE_LABEL_FAP_RING2 EXPAND=TRUE
?? RIGHT := 110 ??
MODULE bam$system_tape_label_fap_ring2;

?? OLDTITLE ??
?? NEWTITLE := 'Global Variables Referenced by This Module', EJECT ??
*copyc cmp$get_element_name_via_lun
*copyc dmv$initialize_tape_volume
*copyc dmv$tape_job_lun_table_p
*copyc fmv$default_detachment_options
*copyc iop$tape_request_status
*copyc iop$unload_tape
*copyc osv$job_pageable_heap
*copyc osv$task_private_heap
*copyc osv$task_shared_heap
*copyc rmp$clear_implicit_reserve
*copyc rmp$deactivate_volume
*copyc rmv$job_tape_table_p

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc bat$tape_descriptor
?? POP ??

?? OLDTITLE ??
?? NEWTITLE := ' PROCEDURE [XDCL, #GATE] bap$dismount_tape_volume', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$dismount_tape_volume
    (    sfid: gft$system_file_identifier;
     VAR status: ost$status);

    VAR
      detachment_options: fmt$detachment_options,
      io_status: iot$tape_io_status,
      ioid: iot$io_id;

    detachment_options := fmv$default_detachment_options;
    detachment_options.device_class := rmc$magnetic_tape_device;
    detachment_options.physical_unload := TRUE;

    iop$unload_tape (sfid, detachment_options, ioid, status);

    IF status.normal THEN
      iop$tape_request_status (sfid, ioid, {wait} TRUE, io_status, status);
    IFEND;

    rmp$deactivate_volume (sfid, {delete_request_from_vsn_queue} TRUE, status);

    IF (NOT dmv$initialize_tape_volume.in_progress) AND
          (NOT rmv$job_tape_table_p^.explicit_reservation) THEN
      rmp$clear_implicit_reserve (dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].density,
            status);
    IFEND;

  PROCEND bap$dismount_tape_volume;

?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE [XDCL, #GATE] bap$get_tape_element_name', EJECT ??

  PROCEDURE[XDCL, #GATE] bap$get_tape_element_name
    (    sfid: gft$system_file_identifier;
     VAR element_name: cmt$element_name;
     VAR status: ost$status);

    cmp$get_element_name_via_lun (dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].lun,
          element_name, status);

  PROCEND bap$get_tape_element_name;

?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE [XDCL, #GATE] bap$free_tape_label_sequences', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$free_tape_label_sequences
    (    free_initial_volume_sequence: boolean;
     VAR p_tape_descriptor: ^bat$tape_descriptor);

    IF free_initial_volume_sequence AND
          (p_tape_descriptor^.initial_volume.header_labels <> NIL) THEN
      FREE p_tape_descriptor^.initial_volume.header_labels IN osv$job_pageable_heap^;
    IFEND;

    IF (p_tape_descriptor^.last_accessed.unsecured_header_labels <> NIL) THEN
      FREE p_tape_descriptor^.last_accessed.unsecured_header_labels IN osv$job_pageable_heap^;
    IFEND;

    IF (p_tape_descriptor^.last_accessed.secured_header_labels <> NIL) THEN
      FREE p_tape_descriptor^.last_accessed.secured_header_labels IN osv$task_shared_heap^;
    IFEND;

    IF (p_tape_descriptor^.last_accessed.unsecured_trailer_labels <> NIL) THEN
      FREE p_tape_descriptor^.last_accessed.unsecured_trailer_labels IN osv$job_pageable_heap^;
    IFEND;

    IF (p_tape_descriptor^.last_accessed.secured_trailer_labels <> NIL) THEN
      FREE p_tape_descriptor^.last_accessed.secured_trailer_labels IN osv$task_shared_heap^;
    IFEND;

    IF p_tape_descriptor^.tape_attachment_information.volume_initialization THEN
      IF p_tape_descriptor^.tape_attachment_information.tape_volume_initialization.blank_label_group <>
           NIL THEN
        FREE p_tape_descriptor^.tape_attachment_information.tape_volume_initialization.blank_label_group
             IN osv$task_private_heap^;
      IFEND;
    IFEND;

  PROCEND bap$free_tape_label_sequences;

?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE [XDCL, #GATE] bap$store_unsecured_tape_labels', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$store_unsecured_tape_labels
    (    p_label_sequence: ^SEQ ( * );
     VAR p_stored_label_sequence: ^SEQ ( * ));

    VAR
      p_local_label_sequence: ^SEQ ( * );

    IF p_label_sequence <> NIL THEN
      IF p_stored_label_sequence <> NIL THEN
        FREE p_stored_label_sequence IN osv$job_pageable_heap^;
      IFEND;
      ALLOCATE p_local_label_sequence: [[REP #SIZE (p_label_sequence^) OF cell]] IN osv$job_pageable_heap^;
      p_local_label_sequence^ := p_label_sequence^;
      RESET p_local_label_sequence;
      p_stored_label_sequence := p_local_label_sequence;
    IFEND;

  PROCEND bap$store_unsecured_tape_labels;

?? OLDTITLE ??
?? NEWTITLE := 'FUNCTION [XDCL, #GATE] bap$volume_robotically_mounted', EJECT ??

  FUNCTION [XDCL, #GATE] bap$volume_robotically_mounted (sfid: gft$system_file_identifier):
        boolean;

    bap$volume_robotically_mounted := dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].
          robotic_mount_info.volume_robotically_mounted;

  FUNCEND bap$volume_robotically_mounted;

MODEND bam$system_tape_label_fap_ring2;
*DECK DECK=BAM$SYS_BLK_FIXED_REC_FAP EXPAND=TRUE
?? RIGHT := 80 ??
*copyc osd$default_pragmats
MODULE bam$sys_blk_fixed_rec_fap;
?? TITLE := 'NOS/VE:  BASIC ACCESS METHOD, TASK SERVICES' ??
?? NEWTITLE := 'COMMON DECLARATIONS' ??
*copyc amc$condition_code_limits
*copyc ame$access_validation_errors
*copyc ame$conflicting_access_level
*copyc ame$device_class_validation
*copyc ame$fap_validation_errors
*copyc ame$file_organization_errors
*copyc ame$get_program_actions
*copyc ame$get_validation_errors
*copyc ame$improper_file_id
*copyc ame$improper_random_access
*copyc ame$improper_wsl
*copyc ame$open_validation_errors
*copyc ame$put_program_actions
*copyc ame$put_validation_errors
*copyc ame$skip_validation_errors
*copyc ame$skip_program_actions
*copyc ame$ring_validation_errors
*copyc ame$unimplemented_request
*copyc amp$set_file_instance_abnormal
*copyc amt$fap_declarations
*copyc bac$minimum_open_ring
*copyc bap$close
*copyc bap$fetch
*copyc bap$fetch_access_information
*copyc bap$get_segment_pointer
*copyc bap$rewind
*copyc bap$set_segment_eoi
*copyc bap$set_segment_position
*copyc bap$store
*copyc bap$validate_file_identifier
*copyc bat$block_header
*copyc bat$global_file_information
*copyc bat$positioning_info
*copyc bat$task_file_table
*copyc bav$default_record_info
*copyc bav$task_file_table
*copyc fmv$global_file_information
*copyc i#move
*copyc ife$error_codes
*copyc mmp$set_segment_length
*copyc bap$write_modified_pages
*copyc osd$virtual_address
*copyc osp$set_status_abnormal
*copyc ost$caller_identifier
*copyc pmp$get_job_mode

?? TITLE := 'BAP$SYS_BLK_FIXED_REC_FAP', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$sys_blk_fixed_rec_fap
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    CONST
      error_text = 'BAP$SYS_BLK_FIXED_REC_FAP - ';

    VAR
      at_eoi: boolean,
      caller_id: ost$caller_identifier,
      data_ptr: ^cell,
      default_padding_string: string (80),
      file_byte_address: amt$file_byte_address,
      file_instance: ^bat$task_file_entry,
      i: integer,
      job_mode: jmt$job_mode,
      padding_area: ^cell,
      padding_character: char,
      padding_length: 0 .. amc$maximum_block - 1,
      record_info: bat$record_info,
      validation_ok: boolean,
      working_storage_area: ^char,
      wsa: ^cell;

?? TITLE := 'rollback_procedure', EJECT ??

    PROCEDURE rollback_procedure
      (    condition_status: ost$status);

      status := condition_status;
      file_instance^.rollback_procedure := NIL;
      EXIT bap$sys_blk_fixed_rec_fap;

    PROCEND rollback_procedure;

?? TITLE := 'GET_NEXT', EJECT ??

    PROCEDURE [INLINE] get_next;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE

*copy   bai$validate_read_access

        IF status.normal THEN

        /main_code_get_next/
          BEGIN

*copy       bai$get_record_info

            { move to start of a fixed record }
            IF record_info.file_position = amc$mid_record THEN
              IF (file_instance^.private_read_information = NIL) AND
                    (file_instance^.global_file_information^.
                    last_access_operation = amc$put_partial_req) THEN
                pad_record_proc;

                update_eoi;

              ELSE
                IF record_info.bor_address + file_instance^.
                      global_file_information^.max_record_length >=
                      file_instance^.global_file_information^.eoi_byte_address
                      THEN
                  record_info.current_byte_address := file_instance^.
                        global_file_information^.eoi_byte_address;
                ELSE
                  record_info.current_byte_address :=
                        record_info.bor_address + file_instance^.
                        global_file_information^.max_record_length;
                IFEND;
                record_info.file_position := amc$eor;
              IFEND;
            IFEND;

*copy       bai$get_eoi_check

            call_block.getn.file_position^ := record_info.file_position;

            IF NOT at_eoi THEN
              IF call_block.getn.working_storage_length >=
                    file_instance^.global_file_information^.
                    max_record_length THEN
                IF record_info.current_byte_address + file_instance^.
                      global_file_information^.max_record_length >
                      file_instance^.global_file_information^.eoi_byte_address
                      THEN
                  record_info.record_length := file_instance^.
                        global_file_information^.eoi_byte_address -
                        record_info.current_byte_address;
                ELSE
                  record_info.record_length := file_instance^.
                        global_file_information^.max_record_length;
                IFEND;
                record_info.file_position := amc$eor;
              ELSE
                IF record_info.current_byte_address + call_block.getn.
                      working_storage_length > file_instance^.
                      global_file_information^.eoi_byte_address THEN
                  record_info.record_length := file_instance^.
                        global_file_information^.eoi_byte_address -
                        record_info.current_byte_address;
                  record_info.file_position := amc$eor;
                ELSE
                  record_info.record_length := call_block.getn.
                        working_storage_length;
                  record_info.file_position := amc$mid_record;
                IFEND;
              IFEND;

              record_info.bor_address := record_info.current_byte_address;

              data_ptr := #ADDRESS (osc$min_ring,
                    #SEGMENT (file_instance^.file_pva),
                    record_info.current_byte_address);

              i#move (data_ptr, call_block.getn.working_storage_area,
                    record_info.record_length);

              record_info.current_byte_address :=
                    record_info.current_byte_address +
                    record_info.record_length;
            ELSE
              record_info.bor_address := record_info.current_byte_address;
              record_info.record_length := 0;
            IFEND; { NOT at eoi }
*copy       bai$save_record_info

            call_block.getn.file_position^ := record_info.file_position;
            call_block.getn.transfer_count^ := record_info.record_length;
            IF call_block.operation = amc$get_next_req THEN
              call_block.getn.byte_address^ := record_info.bor_address;
            IFEND;
          END /main_code_get_next/;
        IFEND;
      IFEND;
    PROCEND get_next;

?? TITLE := 'PUT_NEXT', EJECT ??

    PROCEDURE [INLINE] put_next;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_write_access
        IF status.normal THEN

        /main_code_put_next/
          BEGIN

            record_info := file_instance^.global_file_information^.
                  positioning_info.record_info;

            IF record_info.file_position = amc$mid_record THEN
              IF file_instance^.global_file_information^.last_access_operation =
                    amc$put_partial_req THEN
                pad_record_proc;
              ELSE
                record_info.current_byte_address :=
                      record_info.bor_address + file_instance^.
                      global_file_information^.max_record_length;
                record_info.file_position := amc$eor;
              IFEND;
            IFEND;

{ Check to make sure we do not go over the 2 GB file limit.

            IF file_instance^.global_file_information^.file_limit <
                  record_info.current_byte_address +
                  file_instance^.global_file_information^.max_record_length THEN
              amp$set_file_instance_abnormal (file_identifier,
                  ame$put_beyond_file_limit, call_block.operation, error_text,
                  status);
              EXIT /main_code_put_next/;
            IFEND;

            record_info.bor_address := record_info.current_byte_address;
            record_info.residual_record_length :=
                  file_instance^.global_file_information^.max_record_length;

            data_ptr := #ADDRESS (osc$min_ring,
                  #SEGMENT (file_instance^.file_pva),
                  record_info.current_byte_address);

            IF call_block.putn.working_storage_length >
                  record_info.residual_record_length THEN
              record_info.record_length := record_info.residual_record_length;
            ELSE
              record_info.record_length := call_block.putn.
                    working_storage_length;
            IFEND;

            i#move (call_block.putn.working_storage_area, data_ptr,
                  record_info.record_length);

            record_info.current_byte_address :=
                  record_info.current_byte_address + record_info.record_length;

            pad_record;

            file_instance^.instance_of_open_modified := TRUE;
            record_info.record_length := file_instance^.
                  global_file_information^.max_record_length;

*copy       bai$update_eoi
            file_instance^.global_file_information^.positioning_info.
                  record_info := record_info;
          END /main_code_put_next/;

          IF call_block.operation = amc$put_next_req THEN
            call_block.putn.byte_address^ := record_info.bor_address;
          IFEND;
        IFEND;
      IFEND;
    PROCEND put_next;

?? TITLE := 'GET_PARTIAL', EJECT ??

    PROCEDURE [INLINE] get_partial;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_read_access
        IF status.normal THEN
          IF (call_block.getp.skip_option < LOWERVALUE (amt$skip_option)) OR
                (call_block.getp.skip_option > UPPERVALUE (amt$skip_option))
                THEN
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_skip_option, call_block.operation, error_text,
                  status);
          ELSE

          /main_code_get_partial/
            BEGIN

*copy         bai$get_record_info

              IF (record_info.file_position = amc$mid_record) AND
                    (file_instance^.private_read_information = NIL) AND
                    (file_instance^.global_file_information^.
                    last_access_operation = amc$put_partial_req) THEN
                pad_record_proc;

                update_eoi;

                record_info.file_position := amc$eor;
              IFEND;

              { move to start of a fixed record }
              IF (record_info.file_position = amc$mid_record) AND
                    (call_block.getp.skip_option = amc$skip_to_eor) THEN
                IF record_info.bor_address + file_instance^.
                      global_file_information^.max_record_length >=
                      file_instance^.global_file_information^.eoi_byte_address
                      THEN
                  record_info.current_byte_address := file_instance^.
                        global_file_information^.eoi_byte_address;
                ELSE
                  record_info.current_byte_address :=
                        record_info.bor_address + file_instance^.
                        global_file_information^.max_record_length;
                IFEND;
                record_info.file_position := amc$eor;
              IFEND;

*copy         bai$get_eoi_check

              IF NOT at_eoi THEN
                IF record_info.file_position <> amc$mid_record THEN
                  record_info.bor_address := record_info.current_byte_address;
                IFEND;

                record_info.residual_record_length :=
                      record_info.bor_address + file_instance^.
                      global_file_information^.max_record_length -
                      record_info.current_byte_address;
                IF call_block.getp.working_storage_length >=
                      record_info.residual_record_length THEN
                  IF record_info.current_byte_address + record_info.
                        residual_record_length > file_instance^.
                        global_file_information^.eoi_byte_address THEN
                    record_info.record_length := file_instance^.
                          global_file_information^.eoi_byte_address -
                          record_info.current_byte_address;
                  ELSE
                    record_info.record_length := record_info.
                          residual_record_length;
                  IFEND;
                  record_info.file_position := amc$eor;
                ELSE
                  IF record_info.current_byte_address + call_block.getp.
                        working_storage_length > file_instance^.
                        global_file_information^.eoi_byte_address THEN
                    record_info.record_length := file_instance^.
                          global_file_information^.eoi_byte_address -
                          record_info.current_byte_address;
                    record_info.file_position := amc$eor;
                  ELSE
                    record_info.record_length := call_block.getp.
                          working_storage_length;
                    record_info.file_position := amc$mid_record;
                  IFEND;
                IFEND;

                data_ptr := #ADDRESS (osc$min_ring,
                      #SEGMENT (file_instance^.file_pva),
                      record_info.current_byte_address);

                i#move (data_ptr, call_block.getp.working_storage_area,
                      record_info.record_length);

                record_info.current_byte_address :=
                      record_info.current_byte_address +
                      record_info.record_length;

{ Set transfer count before calculating total record_length transferred.

                call_block.getp.transfer_count^ := record_info.record_length;
                record_info.record_length := record_info.current_byte_address -
                      record_info.bor_address;
              ELSE { at eoi }
                call_block.getp.transfer_count^ := 0;
                record_info.record_length := 0;
              IFEND; { NOT at eoi }

*copy         bai$save_record_info

              call_block.getp.file_position^ := record_info.file_position;
              call_block.getp.record_length^ := record_info.record_length;
              IF at_eoi THEN
                call_block.getp.byte_address^ := file_instance^.
                      global_file_information^.eoi_byte_address;
              ELSE
                call_block.getp.byte_address^ := record_info.bor_address;
              IFEND;
            END /main_code_get_partial/;
          IFEND;
        IFEND;
      IFEND;
    PROCEND get_partial;

?? TITLE := 'PUT_PARTIAL', EJECT ??

    PROCEDURE [INLINE] put_partial;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_write_access
        IF status.normal THEN
          IF (call_block.putp.term_option < LOWERVALUE (amt$term_option)) OR
                (call_block.putp.term_option > UPPERVALUE (amt$term_option))
                THEN
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_term_option, call_block.operation, error_text,
                  status);
          ELSE

          /main_code_put_partial/
            BEGIN

              record_info := file_instance^.global_file_information^.
                    positioning_info.record_info;

              IF ((call_block.putp.term_option = amc$continue) AND
                    (record_info.file_position <> amc$mid_record)) THEN
                amp$set_file_instance_abnormal (file_identifier,
                      ame$improper_continue, call_block.operation, error_text,
                      status);
                EXIT /main_code_put_partial/;
              IFEND;

              IF (record_info.file_position = amc$mid_record) AND
                    (call_block.putp.term_option = amc$start) THEN
                IF file_instance^.global_file_information^.
                      last_access_operation = amc$put_partial_req THEN
                  pad_record_proc;
                  update_eoi;
                ELSE
                  record_info.current_byte_address :=
                        record_info.bor_address + file_instance^.
                        global_file_information^.max_record_length;
                  record_info.file_position := amc$eor;
                IFEND;
              IFEND;

              IF record_info.file_position <> amc$mid_record THEN
                record_info.bor_address := record_info.current_byte_address;
              IFEND;

              record_info.residual_record_length :=
                    record_info.bor_address + file_instance^.
                    global_file_information^.max_record_length -
                    record_info.current_byte_address;

              IF call_block.putp.working_storage_length >
                    record_info.residual_record_length THEN
                record_info.record_length := record_info.residual_record_length;
              ELSE
                record_info.record_length := call_block.putp.
                      working_storage_length;
              IFEND;

{ Check to make sure we do not go over the 2 GB file limit.

              IF (call_block.putp.term_option = amc$start) AND
                 (file_instance^.global_file_information^.file_limit <
                    record_info.current_byte_address +
                    file_instance^.global_file_information^.max_record_length) THEN
                amp$set_file_instance_abnormal (file_identifier,
                    ame$put_beyond_file_limit, call_block.operation, error_text,
                    status);
                EXIT /main_code_put_partial/;
              IFEND;

              data_ptr := #ADDRESS (osc$min_ring,
                    #SEGMENT (file_instance^.file_pva),
                    record_info.current_byte_address);

              i#move (call_block.putp.working_storage_area, data_ptr,
                    record_info.record_length);

              record_info.current_byte_address :=
                    record_info.current_byte_address +
                    record_info.record_length;

              IF call_block.putp.term_option = amc$terminate THEN
                pad_record;
                record_info.record_length := file_instance^.
                      global_file_information^.max_record_length;
*copy           bai$update_eoi
              ELSE
                record_info.file_position := amc$mid_record;
              IFEND;

              file_instance^.instance_of_open_modified := TRUE;

              file_instance^.global_file_information^.positioning_info.
                    record_info := record_info;
            END /main_code_put_partial/;

            call_block.putp.byte_address^ := record_info.bor_address;
          IFEND;
        IFEND;
      IFEND;
    PROCEND put_partial;

?? TITLE := 'skip', EJECT ??

    PROCEDURE [INLINE] skip;

      VAR
        skip_number: integer;

      IF file_instance^.instance_attributes.static_label.file_organization <>
            amc$sequential THEN
        amp$set_file_instance_abnormal (file_identifier, ame$conflicting_fo,
              call_block.operation, error_text, status);
      ELSEIF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE

      /main_code_skip/
        BEGIN

*copy     bai$get_record_info

          CASE call_block.skp.direction OF
          = amc$forward =
            IF record_info.file_position = amc$mid_record THEN
              record_info.current_byte_address :=
                    record_info.bor_address + file_instance^.
                    global_file_information^.max_record_length;
              record_info.bor_address := record_info.current_byte_address;
              record_info.file_position := amc$eor;
            IFEND;

            skip_number := (file_instance^.global_file_information^.
                  eoi_byte_address - record_info.current_byte_address) DIV
                  file_instance^.global_file_information^.max_record_length;

            IF call_block.skp.count > skip_number THEN
              record_info.current_byte_address :=
                    file_instance^.global_file_information^.eoi_byte_address;
              record_info.bor_address := record_info.current_byte_address -
                    file_instance^.global_file_information^.max_record_length;
              record_info.file_position := amc$eoi;
              file_instance^.residual_skip_count :=
                    call_block.skp.count - skip_number;
              amp$set_file_instance_abnormal (file_identifier,
                    ame$skip_encountered_eoi, amc$skip_req, ' RECORDS', status);
            ELSE {can complete full skip}
              IF call_block.skp.count > 0 THEN
                record_info.current_byte_address :=
                      record_info.current_byte_address +
                      (call_block.skp.count * file_instance^.
                      global_file_information^.max_record_length);
                file_instance^.residual_skip_count := 0;
                record_info.file_position := amc$eor;
              IFEND;
            IFEND;
          = amc$backward =
            IF record_info.file_position = amc$mid_record THEN
              record_info.current_byte_address := record_info.bor_address;
              record_info.file_position := amc$eor;
            IFEND;
            skip_number := record_info.current_byte_address DIV
                  file_instance^.global_file_information^.max_record_length;
            IF call_block.skp.count > skip_number THEN
              record_info.current_byte_address := 0;
              record_info.bor_address := 0;
              record_info.current_byte_address := 0;
              record_info.file_position := amc$boi;
              file_instance^.residual_skip_count :=
                    call_block.skp.count - skip_number;
              amp$set_file_instance_abnormal (file_identifier,
                    ame$skip_encountered_boi, amc$skip_req, ' RECORDS', status);
            ELSE {completed skip back}
              IF call_block.skp.count > 0 THEN
                record_info.current_byte_address :=
                      record_info.current_byte_address -
                      (call_block.skp.count * file_instance^.
                      global_file_information^.max_record_length);
                record_info.bor_address := record_info.current_byte_address;
                record_info.file_position := amc$eor;
              IFEND;
              file_instance^.residual_skip_count := 0;
            IFEND;
          CASEND;
        END /main_code_skip/;

*copy bai$save_record_info

        call_block.skp.file_position^ := record_info.file_position;
      IFEND;
    PROCEND skip;

?? TITLE := 'PROCEDURE [INLINE] SEEK_DIRECT', EJECT ??

    PROCEDURE [INLINE] seek_direct;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE

*copy   bai$seek_validation

        IF NOT status.normal THEN
          RETURN;
        IFEND;

*copy   bai$get_record_info

        IF (record_info.file_position = amc$mid_record) AND
              (file_instance^.private_read_information = NIL) AND
              (file_instance^.global_file_information^.last_access_operation =
              amc$put_partial_req) THEN

{ If last operation was a put_partial then the record must be terminated
{ before repositioning since byte_addressable put in the middle of the
{ file may have been in progress.

          pad_record_proc;
          update_eoi;
        IFEND;

        IF file_byte_address MOD file_instance^.global_file_information^.
              max_record_length <> 0 THEN

{ Seek must position to a record boundary or it is an error.

          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_seek_address, call_block.operation, error_text,
                status);
        IFEND;

        IF record_info.current_byte_address = file_byte_address THEN

{ IF the seek is to the address the file is already at then it is a no-op.

          RETURN;
        IFEND;

        record_info.bor_address := file_byte_address;
        record_info.current_byte_address := file_byte_address;
        record_info.file_position := amc$eor;

*copy   bai$save_record_info

      IFEND;
    PROCEND seek_direct;
?? TITLE := 'PROCEDURE update_eoi', EJECT ??

    PROCEDURE update_eoi;

*copy bai$update_eoi

    PROCEND update_eoi;
?? TITLE := 'PROCEDURE [INLINE] PAD_RECORD', EJECT ??

    PROCEDURE [INLINE] pad_record;

      record_info.residual_record_length :=
            record_info.bor_address + file_instance^.global_file_information^.
            max_record_length - record_info.current_byte_address;
      IF record_info.residual_record_length > 0 THEN
        i := 1;
        wsa := #ADDRESS (osc$min_ring, #SEGMENT (file_instance^.file_pva),
              record_info.current_byte_address);
        record_info.current_byte_address := record_info.current_byte_address +
              record_info.residual_record_length;
        IF file_instance^.global_file_information^.padding_character = ' ' THEN
          default_padding_string := ' ';
          IF #SIZE (default_padding_string) >
                record_info.residual_record_length THEN
            i := record_info.residual_record_length;
          ELSE
            i := #SIZE (default_padding_string);
          IFEND;
          i#move (^default_padding_string, wsa, i);
          record_info.residual_record_length :=
                record_info.residual_record_length - i;
        ELSE
          working_storage_area := wsa;
          working_storage_area^ := file_instance^.global_file_information^.
                padding_character;
          record_info.residual_record_length :=
                record_info.residual_record_length - 1;
        IFEND;

        WHILE record_info.residual_record_length > 0 DO
          padding_area := #ADDRESS (osc$min_ring, #SEGMENT (wsa),
                (#OFFSET (wsa) + i));
          IF i <= record_info.residual_record_length THEN
            padding_length := i;
          ELSE
            padding_length := record_info.residual_record_length;
          IFEND;

          i#move (wsa, padding_area, padding_length);

          record_info.residual_record_length :=
                record_info.residual_record_length - padding_length;
          i := i + padding_length;
        WHILEND;
      IFEND;

      record_info.file_position := amc$eor;

    PROCEND pad_record;
?? TITLE := 'PROCEDURE pad_record_proc', EJECT ??

    PROCEDURE pad_record_proc;

      pad_record;

    PROCEND pad_record_proc;
?? TITLE := 'replace_record', EJECT ??

    PROCEDURE replace_record;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSEIF file_instance^.instance_attributes.static_label.
            file_organization <> amc$sequential THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$file_organization_conflict, call_block.operation, error_text,
              status);
      ELSEIF NOT ((file_instance^.global_file_information^.positioning_info.
            record_info.file_position <> amc$mid_record) AND
            (file_instance^.global_file_information^.positioning_info.
            record_info.current_byte_address > 0)) THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_file_position, call_block.operation, error_text,
              status);
      ELSEIF (call_block.putn.working_storage_length < 0) OR
            (call_block.putn.working_storage_length >
            UPPERVALUE (amt$working_storage_length)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
              call_block.operation, error_text, status);
      ELSEIF caller_id.ring > file_instance^.instance_attributes.static_label.
            ring_attributes.r1 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, call_block.operation, error_text,
              status);
      ELSEIF NOT (pfc$modify IN file_instance^.instance_attributes.
            dynamic_label.access_mode) THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_access_attempt, call_block.operation, ' MODIFY',
              status);
      ELSE
        record_info := file_instance^.global_file_information^.positioning_info.
              record_info;

        record_info.current_byte_address := record_info.current_byte_address -
              file_instance^.global_file_information^.max_record_length;
        IF call_block.replace.working_storage_length >
              file_instance^.global_file_information^.max_record_length THEN
          record_info.record_length := file_instance^.global_file_information^.
                max_record_length;
        ELSE
          record_info.record_length := call_block.replace.
                working_storage_length;
        IFEND;

        data_ptr := #ADDRESS (osc$min_ring, #SEGMENT (file_instance^.file_pva),
              record_info.current_byte_address);

        i#move (call_block.replace.working_storage_area, data_ptr,
              record_info.record_length);
        record_info.current_byte_address := record_info.current_byte_address +
              record_info.record_length;

        pad_record;

        file_instance^.instance_of_open_modified := TRUE;
      IFEND;
    PROCEND replace_record;
?? TITLE := 'terminate_record', EJECT ??

    PROCEDURE terminate_record;

      IF file_instance^.private_read_information = NIL THEN
        record_info := file_instance^.global_file_information^.positioning_info.
              record_info;
        IF (record_info.file_position = amc$mid_record) AND
              (file_instance^.global_file_information^.last_access_operation =
              amc$put_partial_req) THEN
          pad_record_proc;
          update_eoi;
        IFEND;
        file_instance^.global_file_information^.positioning_info.record_info :=
              record_info;
      IFEND;
    PROCEND terminate_record;
?? TITLE := 'MAIN CODE OF BAP$SYS_BLK_FIXED_REC_FAP', EJECT ??

    #CALLER_ID (caller_id);
    status.normal := TRUE;

  /process_fap_request/
    BEGIN
      bap$validate_file_identifier (file_identifier, file_instance,
            validation_ok);
      IF NOT validation_ok THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
              error_text, status);
        RETURN;
      ELSE

        file_instance^.rollback_procedure := ^rollback_procedure;
        CASE call_block.operation OF
        = amc$get_next_req =
          get_next;
        = amc$put_next_req =
          put_next;
        = amc$get_partial_req =
          get_partial;
        = amc$put_partial_req =
          put_partial;
        = amc$open_req =
          ;
        = amc$close_req =
          terminate_record;
          bap$close (file_identifier, status);
          EXIT /process_fap_request/;
        = amc$rewind_req =
          terminate_record;
*copy     bai$rewind
        = amc$seek_direct_req =
          file_byte_address := call_block.seekd.byte_address;
          seek_direct;
        = amc$get_direct_req =
          file_byte_address := call_block.getd.byte_address;
          seek_direct;
          IF NOT status.normal THEN
            IF status.condition = ame$position_beyond_eoi THEN
              status.condition := ame$input_after_eoi;
            IFEND;
          ELSE
            get_next;
          IFEND;
        = amc$put_direct_req =
          file_byte_address := call_block.putd.byte_address;
          seek_direct;
          IF status.normal THEN
            put_next;
          IFEND;
        = amc$skip_req =
          IF call_block.skp.unit <> amc$skip_record  THEN
             amp$set_file_instance_abnormal (file_identifier,
                ame$unsupported_skip, call_block.operation, ' ',
                status);
          ELSE
             skip;
          IFEND;
        = amc$fetch_access_information_rq =
          bap$fetch_access_information (file_identifier, call_block,
                layer_number, status);
          EXIT /process_fap_request/;
        = amc$fetch_req =
          bap$fetch (file_identifier, call_block, layer_number, status);
          EXIT /process_fap_request/;
        = amc$get_segment_pointer_req =
          bap$get_segment_pointer (file_identifier, call_block, layer_number,
                status);
        = amc$set_segment_eoi_req =
          bap$set_segment_eoi (file_identifier, call_block, layer_number,
                status);
        = amc$set_segment_position_req =
          bap$set_segment_position (file_identifier, call_block, layer_number,
                status);
        = amc$replace_req =
          replace_record;
        = amc$store_req =
          bap$store (file_identifier, call_block, layer_number, status);
        = amc$write_end_partition_req =
          amp$set_file_instance_abnormal (file_identifier,
                ame$unsupported_operation, call_block.operation, error_text,
                status);
        = amc$write_tape_mark_req, amc$close_volume_req =
          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_device_class, call_block.operation, 'MASS_STORAGE',
                status);
        = amc$flush_req =
          bap$write_modified_pages (file_instance, file_identifier, status);
        = ifc$fetch_terminal_req, ifc$store_terminal_req =
          pmp$get_job_mode (job_mode, status);
          IF status.normal THEN
            IF job_mode = jmc$batch THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$current_job_not_interactive, 'FETCH/STORE_TERMINAL_REQ',
                    status);
            ELSE
              amp$set_file_instance_abnormal (file_identifier,
                    ame$improper_device_class, call_block.operation,
                    'MASS STORAGE', status);
            IFEND;
          IFEND;
        ELSE { NO CASE }
          amp$set_file_instance_abnormal (file_identifier,
                ame$unimplemented_request, call_block.operation,
                ' for sequential or byte addressable files', status);
        CASEND;
      IFEND; { validate_file_identifier }

      IF file_instance^.private_read_information = NIL THEN
        IF status.normal THEN
          file_instance^.global_file_information^.error_status := 0;
        ELSE
          file_instance^.global_file_information^.error_status :=
                status.condition;
        IFEND;
        file_instance^.global_file_information^.last_access_operation :=
              call_block.operation;
      ELSE
        IF status.normal THEN
          file_instance^.private_read_information^.error_status := 0;
        ELSE
          file_instance^.private_read_information^.error_status :=
                status.condition;
        IFEND;
        file_instance^.private_read_information^.last_access_operation :=
              call_block.operation;
      IFEND;
    END /process_fap_request/;

    file_instance^.rollback_procedure := NIL;
  PROCEND bap$sys_blk_fixed_rec_fap;
MODEND bam$sys_blk_fixed_rec_fap;
*DECK DECK=BAM$SYS_BLK_UNDEFINED_REC_FAP EXPAND=TRUE
?? RIGHT := 80 ??
*copyc osd$default_pragmats
MODULE bam$sys_blk_undefined_rec_fap;
?? TITLE := 'NOS/VE:  BASIC ACCESS METHOD, TASK SERVICES' ??
?? NEWTITLE := 'COMMON DECLARATIONS' ??
*copyc amc$condition_code_limits
*copyc ame$access_validation_errors
*copyc ame$conflicting_access_level
*copyc ame$device_class_validation
*copyc ame$fap_validation_errors
*copyc ame$file_organization_errors
*copyc ame$get_program_actions
*copyc ame$get_validation_errors
*copyc ame$improper_file_id
*copyc ame$improper_random_access
*copyc ame$improper_wsl
*copyc ame$open_validation_errors
*copyc ame$put_program_actions
*copyc ame$put_validation_errors
*copyc ame$ring_validation_errors
*copyc ame$unimplemented_request
*copyc ame$skip_validation_errors
*copyc amp$set_file_instance_abnormal
*copyc amt$fap_declarations
*copyc bac$minimum_open_ring
*copyc bap$close
*copyc bap$fetch
*copyc bap$fetch_access_information
*copyc bap$get_segment_pointer
*copyc bap$set_segment_eoi
*copyc bap$set_segment_position
*copyc bap$store
*copyc bap$validate_file_identifier
*copyc bat$global_file_information
*copyc bat$positioning_info
*copyc bat$private_read_information
*copyc bat$record_header_type
*copyc bat$task_file_table
*copyc bav$task_file_table
*copyc i#move
*copyc ife$error_codes
*copyc fmv$global_file_information
*copyc mmp$set_segment_length
*copyc bap$write_modified_pages
*copyc osd$virtual_address
*copyc osp$set_status_abnormal
*copyc ost$caller_identifier
*copyc pmp$get_job_mode

?? TITLE := 'BAP$SYS_BLK_UNDEFINED_REC_FAP', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$sys_blk_undefined_rec_fap
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    CONST
      error_text = 'BAP$SYS_BLK_UNDEFINED_REC_FAP - ';

    VAR
      at_eoi: boolean,
      caller_id: ost$caller_identifier,
      data_ptr: ^cell,
      file_byte_address: amt$file_byte_address,
      file_instance: ^bat$task_file_entry,
      job_mode: jmt$job_mode,
      record_header: bat$record_header,
      record_info: bat$record_info,
      validation_ok: boolean;

?? TITLE := 'rollback_procedure', EJECT ??

    PROCEDURE rollback_procedure
      (    condition_status: ost$status);

      status := condition_status;
      file_instance^.rollback_procedure := NIL;
      EXIT bap$sys_blk_undefined_rec_fap;

    PROCEND rollback_procedure;

?? TITLE := 'GET_NEXT', EJECT ??

    PROCEDURE [INLINE] get_next;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_read_access
        IF status.normal THEN

        /main_code_get_next/
          BEGIN
*copy       bai$get_record_info

            IF (record_info.file_position = amc$mid_record) AND
                  (file_instance^.private_read_information = NIL) AND
                  (file_instance^.global_file_information^.
                  last_access_operation = amc$put_partial_req) THEN

{ Must have been left mid_record by a put_partial.  EOI needs updating.

              update_eoi;
            IFEND;

*copy       bai$get_eoi_check

            IF NOT at_eoi THEN
              IF call_block.getn.working_storage_length +
                    record_info.current_byte_address >=
                    file_instance^.global_file_information^.
                    eoi_byte_address THEN
                record_info.record_length := file_instance^.
                      global_file_information^.eoi_byte_address -
                      record_info.current_byte_address;
              ELSE
                record_info.record_length := call_block.getn.
                      working_storage_length;
              IFEND;

              record_info.bor_address := record_info.current_byte_address;

              data_ptr := #ADDRESS (#RING (file_instance^.file_pva),
                    #SEGMENT (file_instance^.file_pva),
                    record_info.current_byte_address);

              i#move (data_ptr, call_block.getn.working_storage_area,
                    record_info.record_length);

              record_info.current_byte_address :=
                    record_info.current_byte_address +
                    record_info.record_length;
              record_info.file_position := amc$eor;
            ELSE
              record_info.bor_address := record_info.current_byte_address;
              record_info.record_length := 0;
            IFEND; { NOT at eoi }

*copy       bai$save_record_info

            call_block.getn.file_position^ := record_info.file_position;
            call_block.getn.transfer_count^ := record_info.record_length;
            IF call_block.operation = amc$get_next_req THEN
              call_block.getn.byte_address^ := record_info.bor_address;
            IFEND;
          END /main_code_get_next/;
        IFEND;
      IFEND;
    PROCEND get_next;

?? TITLE := 'PUT_NEXT', EJECT ??

    PROCEDURE [INLINE] put_next;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_write_access
        IF status.normal THEN

        /main_code_put_next/
          BEGIN

            record_info := file_instance^.global_file_information^.
                  positioning_info.record_info;

{ Check to make sure we do not go over the 2 GB file limit.

            IF file_instance^.global_file_information^.file_limit <
                  record_info.current_byte_address +
                  call_block.putn.working_storage_length THEN
              amp$set_file_instance_abnormal (file_identifier,
                  ame$put_beyond_file_limit, call_block.operation, error_text,
                  status);
              EXIT /main_code_put_next/;
            IFEND;

            record_info.record_length := call_block.putn.working_storage_length;
            record_info.bor_address := record_info.current_byte_address;

            data_ptr := #ADDRESS (#RING (file_instance^.file_pva),
                  #SEGMENT (file_instance^.file_pva),
                  record_info.current_byte_address);

            i#move (call_block.putn.working_storage_area, data_ptr,
                  record_info.record_length);

            record_info.current_byte_address :=
                  record_info.current_byte_address + record_info.record_length;
            record_info.file_position := amc$eor;

*copy       bai$update_eoi

            file_instance^.instance_of_open_modified := TRUE;
            file_instance^.global_file_information^.positioning_info.
                  record_info := record_info;

          END /main_code_put_next/;

          IF call_block.operation = amc$put_next_req THEN
            call_block.putn.byte_address^ := record_info.bor_address;
          IFEND;
        IFEND;
      IFEND;
    PROCEND put_next;

?? TITLE := 'GET_PARTIAL', EJECT ??

    PROCEDURE [INLINE] get_partial;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE

*copy   bai$validate_read_access

        IF status.normal THEN

{ Note: since only the user knows where records are, skip_option is ignored.

        /main_code_get_partial/
          BEGIN
*copy         bai$get_record_info

            IF (record_info.file_position = amc$mid_record) AND
                  (file_instance^.private_read_information = NIL) AND
                  (file_instance^.global_file_information^.
                  last_access_operation = amc$put_partial_req) THEN

{ Must have been left mid_record by a put_partial.  EOI needs updating.

              record_info.file_position := amc$eor;
              update_eoi;
            IFEND;

*copy       bai$get_eoi_check

            IF NOT at_eoi THEN
              IF record_info.file_position <> amc$mid_record THEN
                record_info.bor_address := record_info.current_byte_address;
              IFEND;

              IF call_block.getp.working_storage_length +
                    record_info.current_byte_address >=
                    file_instance^.global_file_information^.
                    eoi_byte_address THEN
                record_info.record_length := file_instance^.
                      global_file_information^.eoi_byte_address -
                      record_info.current_byte_address;
                record_info.file_position := amc$eor;
              ELSE
                record_info.record_length := call_block.getp.
                      working_storage_length;
                record_info.file_position := amc$mid_record;
              IFEND;

              data_ptr := #ADDRESS (#RING (file_instance^.file_pva),
                    #SEGMENT (file_instance^.file_pva),
                    record_info.current_byte_address);

              i#move (data_ptr, call_block.getp.working_storage_area,
                    record_info.record_length);

              record_info.current_byte_address :=
                    record_info.current_byte_address +
                    record_info.record_length;

            ELSE { not at eoi }
              record_info.bor_address := record_info.current_byte_address;
              record_info.record_length := 0;
            IFEND;

*copy         bai$save_record_info

            call_block.getp.record_length^ := record_info.current_byte_address -
                  record_info.bor_address;
            call_block.getp.transfer_count^ := record_info.record_length;
            call_block.getp.file_position^ := record_info.file_position;
            call_block.getp.byte_address^ := record_info.bor_address;

          END /main_code_get_partial/;
        IFEND; { validate read access }
      IFEND;
    PROCEND get_partial;

?? TITLE := 'PUT_PARTIAL', EJECT ??

    PROCEDURE [INLINE] put_partial;

      { This procedure uses globally defined variables and therefore }
      { must be used as a nested procedure. }

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE

*copy   bai$validate_write_access

        IF status.normal THEN
          IF (call_block.putp.term_option < LOWERVALUE (amt$term_option)) OR
                (call_block.putp.term_option > UPPERVALUE (amt$term_option))
                THEN
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_term_option, call_block.operation, error_text,
                  status);
          ELSE

          /main_code_put_partial/
            BEGIN

              record_info := file_instance^.global_file_information^.
                    positioning_info.record_info;

              IF ((call_block.putp.term_option = amc$continue) AND
                    (record_info.file_position <> amc$mid_record)) THEN
                amp$set_file_instance_abnormal (file_identifier,
                      ame$improper_continue, call_block.operation, '', status);
                EXIT /main_code_put_partial/;
              IFEND;

{ Check to make sure we do not go over the 2 GB file limit.

              IF file_instance^.global_file_information^.file_limit <
                    record_info.current_byte_address +
                    call_block.putn.working_storage_length THEN
                amp$set_file_instance_abnormal (file_identifier,
                    ame$put_beyond_file_limit, call_block.operation, error_text,
                    status);
                EXIT /main_code_put_partial/;
              IFEND;

              data_ptr := #ADDRESS (#RING (file_instance^.file_pva),
                    #SEGMENT (file_instance^.file_pva),
                    record_info.current_byte_address);

              i#move (call_block.putp.working_storage_area, data_ptr,
                    call_block.putp.working_storage_length);

              CASE call_block.putp.term_option OF
              = amc$start =
                IF (record_info.file_position = amc$mid_record) AND
                      (file_instance^.private_read_information = NIL) AND
                      (file_instance^.global_file_information^.
                      last_access_operation = amc$put_partial_req) THEN

{ Must have been left mid_record by a put_partial.  EOI needs updating.

                  record_info.file_position := amc$eor;
                  update_eoi;
                IFEND;
                record_info.file_position := amc$mid_record;
                record_info.bor_address := record_info.current_byte_address;
                record_info.record_length := call_block.putp.
                      working_storage_length;
              = amc$continue =
                record_info.file_position := amc$mid_record;
                record_info.record_length := record_info.record_length +
                      call_block.putp.working_storage_length;
              = amc$terminate =
                IF record_info.file_position = amc$mid_record THEN
                  record_info.record_length := record_info.record_length +
                        call_block.putp.working_storage_length;
                ELSE { writing a full_record using terminate }
                  record_info.record_length := call_block.putp.
                        working_storage_length;
                  record_info.bor_address := record_info.current_byte_address;
                IFEND;
                record_info.file_position := amc$eor;
              ELSE
              CASEND;

              record_info.current_byte_address :=
                    record_info.current_byte_address +
                    call_block.putp.working_storage_length;

              IF call_block.putp.term_option = amc$terminate THEN
*copy           bai$update_eoi
              IFEND;

              file_instance^.instance_of_open_modified := TRUE;
              file_instance^.global_file_information^.positioning_info.
                    record_info := record_info;

            END /main_code_put_partial/;

            call_block.putp.byte_address^ := record_info.bor_address;
          IFEND;
        IFEND;
      IFEND;
    PROCEND put_partial;

?? TITLE := 'PROCEDURE [INLINE] SEEK_DIRECT', EJECT ??

    PROCEDURE [INLINE] seek_direct;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$seek_validation
        IF NOT status.normal THEN
          RETURN;
        IFEND;

*copy   bai$get_record_info

        IF (record_info.file_position = amc$mid_record) AND
              (file_instance^.private_read_information = NIL) AND
              (file_instance^.global_file_information^.last_access_operation =
              amc$put_partial_req) THEN

{ Must have been left mid_record by a put_partial.  EOI needs updating.

          update_eoi;
        IFEND;

        record_info.bor_address := file_byte_address;
        record_info.current_byte_address := file_byte_address;
        record_info.file_position := amc$eor;

*copy   bai$save_record_info

      IFEND;
    PROCEND seek_direct;
?? TITLE := 'PROCEDURE update_eoi', EJECT ??

    PROCEDURE update_eoi;

*copy bai$update_eoi

    PROCEND update_eoi;
?? TITLE := 'PROCEDURE terminate_record', EJECT ??
    PROCEDURE terminate_record;

      IF (file_instance^.private_read_information = NIL) AND
            (file_instance^.global_file_information^.positioning_info.
            record_info.file_position = amc$mid_record) AND
            (file_instance^.global_file_information^.last_access_operation =
            amc$put_partial_req) THEN

{ Must have been left mid_record by a put_partial.  EOI needs updating.

        record_info := file_instance^.global_file_information^.
              positioning_info.record_info;

        update_eoi;

        file_instance^.global_file_information^.positioning_info.
              record_info := record_info;
      IFEND;

    PROCEND terminate_record;
?? TITLE := 'MAIN CODE OF BAP$SYS_BLK_UNDEF_REC_FAP', EJECT ??

    #CALLER_ID (caller_id);
    status.normal := TRUE;

  /process_fap_request/
    BEGIN
      bap$validate_file_identifier (file_identifier, file_instance,
            validation_ok);
      IF NOT validation_ok THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_file_id,
              call_block.operation, error_text, status);
        RETURN;
      ELSE

        file_instance^.rollback_procedure := ^rollback_procedure;
        CASE call_block.operation OF
        = amc$get_next_req =
          get_next;
        = amc$put_next_req =
          put_next;
        = amc$get_partial_req =
          get_partial;
        = amc$put_partial_req =
          put_partial;
        = amc$open_req =
          ;
        = amc$close_req =
          terminate_record;
          bap$close (file_identifier, status);
          EXIT /process_fap_request/;
        = amc$rewind_req =
          terminate_record;
*copy     bai$rewind
        = amc$seek_direct_req =
          file_byte_address := call_block.seekd.byte_address;
          seek_direct;
        = amc$get_direct_req =
          file_byte_address := call_block.getd.byte_address;
          seek_direct;
          IF NOT status.normal THEN
            IF status.condition = ame$position_beyond_eoi THEN
              status.condition := ame$input_after_eoi;
            IFEND;
          ELSE
            get_next;
          IFEND;
        = amc$put_direct_req =
          file_byte_address := call_block.putd.byte_address;
          seek_direct;
          IF status.normal THEN
            put_next;
          IFEND;
        = amc$skip_req =
          amp$set_file_instance_abnormal (file_identifier,
                ame$unsupported_skip, call_block.operation, ' ',
                status);
        = amc$fetch_access_information_rq =
          bap$fetch_access_information (file_identifier, call_block,
                layer_number, status);
          EXIT /process_fap_request/;
        = amc$fetch_req =
          bap$fetch (file_identifier, call_block, layer_number, status);
          EXIT /process_fap_request/;
        = amc$get_segment_pointer_req =
          bap$get_segment_pointer (file_identifier, call_block, layer_number,
                status);
        = amc$set_segment_eoi_req =
          bap$set_segment_eoi (file_identifier, call_block, layer_number,
                status);
        = amc$set_segment_position_req =
          bap$set_segment_position (file_identifier, call_block, layer_number,
                status);
        = amc$store_req =
          bap$store (file_identifier, call_block, layer_number, status);
        = amc$replace_req, amc$write_end_partition_req =
          amp$set_file_instance_abnormal (file_identifier,
                ame$unsupported_operation, call_block.operation, error_text,
                status);
        = amc$write_tape_mark_req, amc$close_volume_req =
          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_device_class, call_block.operation, 'MASS_STORAGE',
                status);
        = amc$flush_req =
          bap$write_modified_pages (file_instance, file_identifier, status);
        = ifc$fetch_terminal_req, ifc$store_terminal_req =
          pmp$get_job_mode (job_mode, status);
          IF status.normal THEN
            IF job_mode = jmc$batch THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$current_job_not_interactive, 'FETCH/STORE_TERMINAL_REQ',
                    status);
            ELSE
              amp$set_file_instance_abnormal (file_identifier,
                    ame$improper_device_class, call_block.operation,
                    'MASS STORAGE', status);
            IFEND;
          IFEND;
        ELSE
          amp$set_file_instance_abnormal (file_identifier,
                ame$unimplemented_request, call_block.operation,
                ' for sequential or byte addressable files', status);
        CASEND;
      IFEND; { validate_file_identifier }
      IF file_instance^.private_read_information = NIL THEN
        IF status.normal THEN
          file_instance^.global_file_information^.error_status := 0;
        ELSE
          file_instance^.global_file_information^.error_status :=
                status.condition;
        IFEND;
        file_instance^.global_file_information^.last_access_operation :=
              call_block.operation;
      ELSE
        IF status.normal THEN
          file_instance^.private_read_information^.error_status := 0;
        ELSE
          file_instance^.private_read_information^.error_status :=
                status.condition;
        IFEND;
        file_instance^.private_read_information^.last_access_operation :=
              call_block.operation;
      IFEND;

    END /process_fap_request/;

    file_instance^.rollback_procedure := NIL;
  PROCEND bap$sys_blk_undefined_rec_fap;
MODEND bam$sys_blk_undefined_rec_fap;
*DECK DECK=BAM$SYS_BLK_VARIABLE_REC_FAP EXPAND=TRUE
?? RIGHT := 80 ??
*copyc osd$default_pragmats
MODULE bam$sys_blk_variable_rec_fap;
?? TITLE := 'NOS/VE:  BASIC ACCESS METHOD, TASK SERVICES' ??
?? NEWTITLE := 'COMMON DECLARATIONS' ??
*copyc amc$condition_code_limits
*copyc ame$access_validation_errors
*copyc ame$conflicting_access_level
*copyc ame$device_class_validation
*copyc ame$fap_validation_errors
*copyc ame$file_organization_errors
*copyc ame$get_program_actions
*copyc ame$get_validation_errors
*copyc ame$improper_file_id
*copyc ame$improper_wsl
*copyc ame$improper_random_access
*copyc ame$open_validation_errors
*copyc ame$put_program_actions
*copyc ame$put_validation_errors
*copyc ame$ring_validation_errors
*copyc ame$skip_validation_errors
*copyc ame$skip_program_actions
*copyc ame$unimplemented_request
*copyc amp$set_file_instance_abnormal
*copyc amt$fap_declarations
*copyc bac$minimum_open_ring
*copyc bap$close
*copyc bap$fetch
*copyc bap$fetch_access_information
*copyc bap$get_segment_pointer
*copyc bap$set_segment_eoi
*copyc bap$set_segment_position
*copyc bap$store
*copyc bap$validate_file_identifier
*copyc bat$global_file_information
*copyc bat$record_info
*copyc bat$private_read_information
*copyc bat$record_header_type
*copyc bat$positioning_info
*copyc bat$task_file_table
*copyc bav$task_file_table
*copyc fmv$global_file_information
*copyc i#move
*copyc ife$error_codes
*copyc mmp$set_segment_length
*copyc bap$write_modified_pages
*copyc osd$virtual_address
*copyc osp$set_status_abnormal
*copyc ost$caller_identifier
*copyc pmp$get_job_mode

?? TITLE := 'BAP$SYS_BLK_VARIABLE_REC_FAP', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$sys_blk_variable_rec_fap
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    CONST
      error_text = 'BAP$SYS_BLK_VARIABLE_REC_FAP - ';

    VAR
      at_eoi: boolean,
      caller_id: ost$caller_identifier,
      data_ptr: ^cell,
      file_byte_address: amt$file_byte_address,
      file_instance: ^bat$task_file_entry,
      job_mode: jmt$job_mode,
      previous_record_header: ^bat$record_header,
      record_header: ^bat$record_header,
      record_info: bat$record_info,
      validation_ok: boolean;

?? TITLE := 'rollback_procedure', EJECT ??

    PROCEDURE rollback_procedure
      (    condition_status: ost$status);

      status := condition_status;
      file_instance^.rollback_procedure := NIL;

{ Since all positioning info is kept local to the fap until the
{ positioning operation is complete, exiting the fap before the
{ tft of gfi are updated effectively achieves rollback.

      EXIT bap$sys_blk_variable_rec_fap;

    PROCEND rollback_procedure;
?? TITLE := 'PROCEDURE [INLINE] get_next', EJECT ??

    PROCEDURE [INLINE] get_next;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_read_access
        IF status.normal THEN

        /main_code_get_next/
          BEGIN
*copy       bai$get_record_info

{ Note that wsl is in the same position for get operation call_blocks.

            IF (record_info.file_position = amc$mid_record) AND
                  (file_instance^.private_read_information = NIL) AND
                  (file_instance^.global_file_information^.
                  last_access_operation = amc$put_partial_req) THEN

{ Must have been left mid_record by a put_partial.  EOI needs updating.

              record_info.file_position := amc$eor;
              update_eoi;
            IFEND;

            IF record_info.file_position = amc$mid_record THEN
              IF record_info.current_byte_address <
                    file_instance^.global_file_information^.
                    eoi_byte_address THEN
                record_header := #ADDRESS (osc$min_ring,
                      #SEGMENT (file_instance^.file_pva),
                      record_info.bor_address);
                IF (record_header^.unique_id = bac$record_header_unique_id) AND
                      (record_header^.length <= UPPERVALUE (record_header^.
                      length)) AND (record_header^.length >=
                      LOWERVALUE (record_header^.length)) THEN
                  record_info.current_byte_address :=
                        record_info.bor_address + record_header^.length +
                        #SIZE (bat$record_header)
                ELSE
                  amp$set_file_instance_abnormal (file_identifier,
                        ame$improper_record_header, call_block.operation,
                        error_text, status);
                  RETURN;
                IFEND;
              IFEND;
            IFEND;

*copy       bai$get_eoi_check
            IF NOT status.normal THEN
              EXIT /main_code_get_next/;
            IFEND;

            IF NOT at_eoi THEN

*copy         bai$validate_record_header
              IF NOT status.normal THEN
                EXIT /main_code_get_next/;
              IFEND;

              record_info.current_byte_address :=
                    record_info.current_byte_address +
                    #SIZE (bat$record_header);

              IF call_block.getn.working_storage_length >=
                    record_header^.length THEN
                record_info.record_length := record_header^.length;
                record_info.file_position := amc$eor;
              ELSE
                record_info.record_length := call_block.getn.
                      working_storage_length;
                record_info.file_position := amc$mid_record;
              IFEND;
              IF record_header^.header_type = bac$partition THEN
                record_info.file_position := amc$eop;
              IFEND;

              data_ptr := #ADDRESS (osc$min_ring,
                    #SEGMENT (file_instance^.file_pva),
                    record_info.current_byte_address);

              i#move (data_ptr, call_block.getn.working_storage_area,
                    record_info.record_length);

              record_info.current_byte_address :=
                    record_info.current_byte_address +
                    record_info.record_length;

            ELSE { at eoi }
              record_info.record_length := 0;
            IFEND; { NOT at eoi }
          END /main_code_get_next/;

*copy     bai$save_record_info

          call_block.getn.file_position^ := record_info.file_position;
          call_block.getn.transfer_count^ := record_info.record_length;
          IF call_block.operation = amc$get_next_req THEN
            IF at_eoi THEN
              call_block.getn.byte_address^ := file_instance^.
                    global_file_information^.eoi_byte_address;
            ELSE
              call_block.getn.byte_address^ := record_info.bor_address;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    PROCEND get_next;
?? TITLE := 'PROCEDURE [INLINE] put_next', EJECT ??

    PROCEDURE [INLINE] put_next;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_write_access
        IF status.normal THEN

        /main_code_put_next/
          BEGIN

            record_info := file_instance^.global_file_information^.
                  positioning_info.record_info;

            record_info.record_length := call_block.putn.working_storage_length;

{ Check to make sure we do not go over the 2 GB file limit.

            IF file_instance^.global_file_information^.file_limit <
                  record_info.current_byte_address + record_info.record_length +
                  #SIZE (bat$record_header) THEN
              amp$set_file_instance_abnormal (file_identifier,
                  ame$put_beyond_file_limit, call_block.operation, error_text,
                  status);
              EXIT /main_code_put_next/;
            IFEND;

            IF record_info.file_position = amc$mid_record THEN

{ Put correct length in header of record that is about to be truncated.

              record_header := #ADDRESS (osc$min_ring,
                    #SEGMENT (file_instance^.file_pva),
                    record_info.bor_address);

              record_header^.length := record_info.current_byte_address -
                    record_info.bor_address - #SIZE (bat$record_header);
            IFEND;

*copy       bai$write_record_header
            record_header^.length := record_info.record_length;

            data_ptr := #ADDRESS (osc$min_ring,
                  #SEGMENT (file_instance^.file_pva),
                  record_info.current_byte_address);

            i#move (call_block.putn.working_storage_area, data_ptr,
                  record_info.record_length);

            record_info.current_byte_address :=
                  record_info.current_byte_address + record_info.record_length;

            record_info.file_position := amc$eor;
            file_instance^.instance_of_open_modified := TRUE;

*copy       bai$update_eoi

            file_instance^.global_file_information^.positioning_info.
                  record_info := record_info;

            IF call_block.operation = amc$put_next_req THEN
              call_block.putn.byte_address^ := record_info.bor_address;
            IFEND;
          END /main_code_put_next/;

        IFEND;
      IFEND;
    PROCEND put_next;
?? TITLE := 'GET_PARTIAL', EJECT ??

    PROCEDURE [INLINE] get_partial;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_read_access
        IF status.normal THEN
          IF (call_block.getp.skip_option < LOWERVALUE (amt$skip_option)) OR
                (call_block.getp.skip_option > UPPERVALUE (amt$skip_option))
                THEN
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_skip_option, call_block.operation, error_text,
                  status);
          ELSE

          /main_code_get_partial/
            BEGIN
*copy         bai$get_record_info

              IF (record_info.file_position = amc$mid_record) AND
                    (file_instance^.private_read_information = NIL) AND
                    (file_instance^.global_file_information^.
                    last_access_operation = amc$put_partial_req) THEN

{ Must have been left mid_record by a put_partial.  EOI needs updating.

                record_info.file_position := amc$eor;
                update_eoi;
              IFEND;

              IF (record_info.file_position = amc$mid_record) AND
                    (call_block.getp.skip_option = amc$skip_to_eor) THEN
                record_header := #ADDRESS (osc$min_ring,
                      #SEGMENT (file_instance^.file_pva),
                      record_info.bor_address);
                IF (record_header^.unique_id = bac$record_header_unique_id) AND
                      (record_header^.length <= UPPERVALUE (record_header^.
                      length)) AND (record_header^.length >=
                      LOWERVALUE (record_header^.length)) THEN
                  record_info.current_byte_address :=
                        record_info.bor_address + record_header^.length +
                        #SIZE (bat$record_header);
                  record_info.file_position := amc$eor;
                ELSE
                  amp$set_file_instance_abnormal (file_identifier,
                        ame$improper_record_header, call_block.operation,
                        error_text, status);
                  RETURN;
                IFEND;
              IFEND;

*copy         bai$get_eoi_check

              IF NOT at_eoi THEN
                IF record_info.file_position <> amc$mid_record THEN
*copy             bai$validate_record_header
                  IF NOT status.normal THEN
                    EXIT /main_code_get_partial/;
                  IFEND;
                  record_info.current_byte_address :=
                        record_info.current_byte_address +
                        #SIZE (bat$record_header);
                ELSE

{ Header has already been validated in getting to mid_record.

                  record_header := #ADDRESS (osc$min_ring,
                        #SEGMENT (file_instance^.file_pva),
                        record_info.bor_address);
                IFEND;

                record_info.residual_record_length :=
                      record_info.bor_address + #SIZE (bat$record_header) +
                      record_header^.length - record_info.current_byte_address;
                IF call_block.getp.working_storage_length >=
                      record_info.residual_record_length THEN
                  record_info.record_length := record_info.
                        residual_record_length;
                  record_info.file_position := amc$eor;
                ELSE
                  record_info.record_length := call_block.getp.
                        working_storage_length;
                  record_info.file_position := amc$mid_record;
                IFEND;

                data_ptr := #ADDRESS (osc$min_ring,
                      #SEGMENT (file_instance^.file_pva),
                      record_info.current_byte_address);

                i#move (data_ptr, call_block.getp.working_storage_area,
                      record_info.record_length);

                record_info.current_byte_address :=
                      record_info.current_byte_address +
                      record_info.record_length;

{ Set transfer_count for this getp before resetting record_length to length
{ of record transferred cumulatively.

                call_block.getp.transfer_count^ := record_info.record_length;
                record_info.record_length := record_info.current_byte_address -
                      record_info.bor_address - #SIZE (bat$record_header);

                IF record_header^.header_type = bac$partition THEN
                  record_info.file_position := amc$eop;
                IFEND;
              ELSE { at eoi }
                call_block.getp.transfer_count^ := 0;
                record_info.record_length := 0;
              IFEND;
            END /main_code_get_partial/;
*copy       bai$save_record_info
            IF at_eoi THEN
              call_block.getp.byte_address^ := file_instance^.
                    global_file_information^.eoi_byte_address;
            ELSE
              call_block.getp.byte_address^ := record_info.bor_address;
            IFEND;
            call_block.getp.file_position^ := record_info.file_position;
            call_block.getp.record_length^ := record_info.record_length;
          IFEND;
        IFEND;
      IFEND;
    PROCEND get_partial;
?? TITLE := 'PUT_PARTIAL', EJECT ??

    PROCEDURE [INLINE] put_partial;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_write_access
        IF status.normal THEN
          IF (call_block.putp.term_option < LOWERVALUE (amt$term_option)) OR
                (call_block.putp.term_option > UPPERVALUE (amt$term_option))
                THEN
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_term_option, call_block.operation, error_text,
                  status);
          ELSE

          /main_code_put_partial/
            BEGIN

              record_info := file_instance^.global_file_information^.
                    positioning_info.record_info;

              record_info.record_length := call_block.putp.
                    working_storage_length;

              CASE call_block.putp.term_option OF
              = amc$start =

{ Check to make sure we do not go over the 2 GB file limit.

                IF file_instance^.global_file_information^.file_limit <
                      record_info.current_byte_address + record_info.record_length +
                      #SIZE (bat$record_header) THEN
                  amp$set_file_instance_abnormal (file_identifier,
                      ame$put_beyond_file_limit, call_block.operation, error_text,
                      status);
                  EXIT /main_code_put_partial/;
                IFEND;

                IF (record_info.file_position = amc$mid_record) AND
                      (file_instance^.global_file_information^.
                      last_access_operation = amc$put_partial_req) THEN

{ Must have been left mid_record by a put_partial.  EOI needs updating.

                  record_info.file_position := amc$eor;
                  update_eoi;
                IFEND;

                IF record_info.file_position = amc$mid_record THEN

{ Put correct length in header of record that is about to be truncated.

                  record_header := #ADDRESS (osc$min_ring,
                        #SEGMENT (file_instance^.file_pva),
                        record_info.bor_address);

                  record_header^.length := record_info.current_byte_address -
                        record_info.bor_address - #SIZE (bat$record_header);
                IFEND;


*copy           bai$write_record_header
                record_info.file_position := amc$mid_record;
              = amc$continue =
                IF record_info.file_position <> amc$mid_record THEN
                  amp$set_file_instance_abnormal (file_identifier,
                        ame$improper_continue, call_block.operation, error_text,
                        status);
                  EXIT /main_code_put_partial/;
                IFEND;

{ Check to make sure we do not go over the 2 GB file limit.

                IF file_instance^.global_file_information^.file_limit <
                      record_info.current_byte_address + record_info.record_length THEN
                  amp$set_file_instance_abnormal (file_identifier,
                      ame$put_beyond_file_limit, call_block.operation, error_text,
                      status);
                  EXIT /main_code_put_partial/;
                IFEND;

                record_header := #ADDRESS (osc$min_ring,
                      #SEGMENT (file_instance^.file_pva),
                      record_info.bor_address);
                record_info.file_position := amc$mid_record;
              = amc$terminate =
                IF record_info.file_position = amc$mid_record THEN

{ Check to make sure we do not go over the 2 GB file limit.

                  IF file_instance^.global_file_information^.file_limit <
                        record_info.current_byte_address + record_info.record_length THEN
                    amp$set_file_instance_abnormal (file_identifier,
                        ame$put_beyond_file_limit, call_block.operation, error_text,
                        status);
                    EXIT /main_code_put_partial/;
                  IFEND;

                  record_header := #ADDRESS (osc$min_ring,
                        #SEGMENT (file_instance^.file_pva),
                        record_info.bor_address);

                ELSE { writing a complete record using terminate }

{ Check to make sure we do not go over the 2 GB file limit.

                  IF file_instance^.global_file_information^.file_limit <
                        record_info.current_byte_address + record_info.record_length +
                        #SIZE (bat$record_header) THEN
                    amp$set_file_instance_abnormal (file_identifier,
                        ame$put_beyond_file_limit, call_block.operation, error_text,
                        status);
                    EXIT /main_code_put_partial/;
                  IFEND;

*copy             bai$write_record_header
                IFEND;
                record_info.file_position := amc$eor;
              ELSE
              CASEND;

              data_ptr := #ADDRESS (osc$min_ring,
                    #SEGMENT (file_instance^.file_pva),
                    record_info.current_byte_address);

              i#move (call_block.putp.working_storage_area, data_ptr,
                    record_info.record_length);

              record_info.current_byte_address :=
                    record_info.current_byte_address +
                    record_info.record_length;
              record_info.record_length := record_info.current_byte_address -
                    record_info.bor_address - #SIZE (bat$record_header);
              record_header^.length := record_info.record_length;

              IF call_block.putp.term_option = amc$terminate THEN
*copy           bai$update_eoi
              IFEND;

              file_instance^.global_file_information^.positioning_info.
                    record_info := record_info;

              file_instance^.instance_of_open_modified := TRUE;

              call_block.putp.byte_address^ := record_info.bor_address;
            END /main_code_put_partial/;

          IFEND;
        IFEND;
      IFEND;
    PROCEND put_partial;
?? TITLE := 'PROCEDURE [INLINE] WRITE_END_PARTITION', EJECT ??

    PROCEDURE [INLINE] write_end_partition;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSEIF caller_id.ring > file_instance^.instance_attributes.static_label.
            ring_attributes.r1 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, call_block.operation, error_text,
              status);
      ELSE

      /main_code_write_end_partition/
        BEGIN

          IF (file_instance^.global_file_information^.positioning_info.
                record_info.current_byte_address <
                file_instance^.global_file_information^.eoi_byte_address) THEN
            IF (file_instance^.instance_attributes.static_label.
                  file_organization = amc$sequential) AND
                  NOT (pfc$shorten IN file_instance^.instance_attributes.
                  dynamic_label.access_mode) THEN

{ Note: A put_direct on sequential access will shorten a file.

              amp$set_file_instance_abnormal (file_identifier,
                    ame$improper_access_attempt, call_block.operation,
                    ' SHORTEN', status);
              EXIT /main_code_write_end_partition/;
            ELSEIF (file_instance^.instance_attributes.static_label.
                  file_organization = amc$byte_addressable) AND
                  NOT ((pfc$modify IN file_instance^.instance_attributes.
                  dynamic_label.access_mode) OR (pfc$shorten IN
                  file_instance^.instance_attributes.dynamic_label.access_mode))
                  THEN
              amp$set_file_instance_abnormal (file_identifier,
                    ame$improper_access_attempt, call_block.operation,
                    ' MODIFY OR SHORTEN', status);
              EXIT /main_code_write_end_partition/;
            IFEND;
          ELSE { at eoi }
            IF NOT (pfc$append IN file_instance^.instance_attributes.
                  dynamic_label.access_mode) THEN
              amp$set_file_instance_abnormal (file_identifier,
                    ame$improper_access_attempt, call_block.operation,
                    ' APPEND', status);
              EXIT /main_code_write_end_partition/;
            IFEND;
          IFEND;

          record_info := file_instance^.global_file_information^.
                positioning_info.record_info;

*copy     bai$write_record_header
          record_header^.header_type := bac$partition;
          record_header^.length := 0;

          record_info.file_position := amc$eop;
          record_info.record_length := 0;

          update_eoi;

          file_instance^.global_file_information^.positioning_info.
                record_info := record_info;
          file_instance^.instance_of_open_modified := TRUE;

        END /main_code_write_end_partition/;
      IFEND;
    PROCEND write_end_partition;
?? TITLE := 'PROCEDURE [INLINE] SEEK_DIRECT', EJECT ??

    PROCEDURE [INLINE] seek_direct;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$seek_validation
        IF NOT status.normal THEN
          RETURN;
        IFEND;

*copy   bai$get_record_info

        IF record_info.current_byte_address = file_byte_address THEN
          IF record_info.file_position = amc$mid_record THEN

{ Seek must position to a record boundary or it is an error.

            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_seek_address, call_block.operation, error_text,
                  status);
          IFEND;

{ IF the seek is to the address the file is already at then it is a no-op.

          RETURN;
        IFEND;

        IF (file_byte_address <= file_instance^.global_file_information^.
              eoi_byte_address - #SIZE (bat$record_header)) AND
              ((file_instance^.instance_attributes.static_label.
              file_organization = amc$sequential) OR
              ((file_instance^.instance_attributes.static_label.
              file_organization = amc$byte_addressable) AND
              (call_block.operation = amc$get_direct_req))) THEN
          record_header := #ADDRESS (osc$min_ring,
                #SEGMENT (file_instance^.file_pva), file_byte_address);

{ Seek must position to a record boundary or it is an error.

          IF (record_header^.unique_id = bac$record_header_unique_id) { } AND
                (record_header^.length <= UPPERVALUE (record_header^.length))
                { } AND (record_header^.length >=
                LOWERVALUE (record_header^.length)) { } AND
                (record_header^.previous_header_fba <=
                UPPERVALUE (record_header^.previous_header_fba)) { } AND
                (record_header^.previous_header_fba >=
                LOWERVALUE (record_header^.previous_header_fba)) { } AND
                (record_header^.header_type <= UPPERVALUE (record_header^.
                header_type)) { } AND (record_header^.header_type >=
                LOWERVALUE (record_header^.header_type)) THEN

{ Found a good record_header.

          ELSE
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_seek_address, call_block.operation, error_text,
                  status);
            RETURN;
          IFEND;
        IFEND;

        IF (record_info.file_position = amc$mid_record) AND
              (file_instance^.private_read_information = NIL) AND
              (file_instance^.global_file_information^.last_access_operation =
              amc$put_partial_req) THEN

{ Must have been left mid_record by a put_partial.  EOI needs updating.

          record_info.file_position := amc$eor;
          update_eoi;
        IFEND;

        record_info.current_byte_address := file_byte_address;
        record_info.file_position := amc$eor;

        IF (file_byte_address > #SIZE (bat$record_header)) AND
              (call_block.operation <> amc$get_direct_req) THEN

          file_byte_address := file_byte_address - #SIZE (bat$record_header) +
                1;

        /search_loop_rhba/
          WHILE file_byte_address >= 1 DO
            file_byte_address := file_byte_address - 1;
            record_header := #ADDRESS (osc$min_ring,
                  #SEGMENT (file_instance^.file_pva), file_byte_address);
            IF (record_header^.unique_id = bac$record_header_unique_id) { } AND
                  (record_header^.length <= UPPERVALUE (record_header^.length))
                  { } AND (record_header^.length >=
                  LOWERVALUE (record_header^.length)) { } AND
                  (record_header^.previous_header_fba <=
                  UPPERVALUE (record_header^.previous_header_fba)) { } AND
                  (record_header^.previous_header_fba >=
                  LOWERVALUE (record_header^.previous_header_fba)) { } AND
                  (record_header^.header_type <= UPPERVALUE (record_header^.
                  header_type)) { } AND (record_header^.
                  header_type >= LOWERVALUE (record_header^.header_type)) THEN
              IF file_byte_address + #SIZE (bat$record_header) +
                    record_header^.length = record_info.
                    current_byte_address THEN

{ Validate backward link of record header

                previous_record_header := #ADDRESS (osc$min_ring, #SEGMENT (file_instance^.file_pva),
                      record_header^.previous_header_fba);
                IF (file_byte_address = 0) OR (record_header^.previous_header_fba + #SIZE (bat$record_header)
                      + previous_record_header^.length = file_byte_address) THEN
                  record_info.bor_address := file_byte_address;
                  EXIT /search_loop_rhba/;
                IFEND;
              IFEND;
            IFEND;
          WHILEND /search_loop_rhba/;
        IFEND;

*copy   bai$save_record_info

      IFEND;
    PROCEND seek_direct;
?? TITLE := 'PROCEDURE locate_previous_header', EJECT ??

    PROCEDURE locate_previous_header;

*copy bai$get_record_info

      IF record_info.bor_address < record_info.current_byte_address THEN
        record_header := #ADDRESS (osc$min_ring,
              #SEGMENT (file_instance^.file_pva), record_info.bor_address);
        IF (record_header^.unique_id = bac$record_header_unique_id) { } AND
              (record_header^.length <= UPPERVALUE (record_header^.length))
              { } AND (record_header^.length >=
              LOWERVALUE (record_header^.length)) { } AND
              (record_header^.previous_header_fba <=
              UPPERVALUE (record_header^.previous_header_fba)) { } AND
              (record_header^.previous_header_fba >=
              LOWERVALUE (record_header^.previous_header_fba)) { } AND
              (record_header^.header_type <= UPPERVALUE (record_header^.
              header_type)) { } AND (record_header^.header_type >=
              LOWERVALUE (record_header^.header_type)) THEN
          IF record_info.bor_address + #SIZE (bat$record_header) +
                record_header^.length >= record_info.current_byte_address THEN

{ bor_address is correct for previous_record_header

            RETURN;
          IFEND;
        IFEND;
      IFEND;

      IF record_info.current_byte_address >= #SIZE (bat$record_header) THEN

{ Look backward for offset of previous record header.

        file_byte_address := record_info.current_byte_address -
              #SIZE (bat$record_header) + 1;

      /search_loop/
        WHILE file_byte_address >= 1 DO
          file_byte_address := file_byte_address - 1;
          record_header := #ADDRESS (osc$min_ring,
                #SEGMENT (file_instance^.file_pva), file_byte_address);
          IF (record_header^.unique_id = bac$record_header_unique_id) { } AND
                (record_header^.length <= UPPERVALUE (record_header^.length))
                { } AND (record_header^.length >=
                LOWERVALUE (record_header^.length)) { } AND
                (record_header^.previous_header_fba <=
                UPPERVALUE (record_header^.previous_header_fba)) { } AND
                (record_header^.previous_header_fba >=
                LOWERVALUE (record_header^.previous_header_fba)) { } AND
                (record_header^.header_type <= UPPERVALUE (record_header^.
                header_type)) { } AND (record_header^.header_type >=
                LOWERVALUE (record_header^.header_type)) THEN
            IF file_byte_address + #SIZE (bat$record_header) +
                  record_header^.length = record_info.current_byte_address THEN

{ Validate backward link of record header

              previous_record_header := #ADDRESS (osc$min_ring, #SEGMENT (file_instance^.file_pva),
                    record_header^.previous_header_fba);
              IF (file_byte_address = 0) OR (record_header^.previous_header_fba + #SIZE (bat$record_header) +
                    previous_record_header^.length = file_byte_address) THEN
                record_info.bor_address := file_byte_address;
*copy           bai$save_record_info
                EXIT /search_loop/;
              IFEND;
            IFEND;
          IFEND;
        WHILEND /search_loop/;
      IFEND;

    PROCEND locate_previous_header;
?? TITLE := 'PROCEDURE open_positioning', EJECT ??

    PROCEDURE [INLINE] open_positioning;

      { initialize positioning information }
      CASE file_instance^.instance_attributes.dynamic_label.open_position OF
      = amc$open_at_boi =
        ;
      = amc$open_no_positioning, amc$open_at_eoi, amc$open_at_bop =

{ When opening ASIS, if the open follows a byte_move copy then the
{ previous header must be found.
{ Open will always set bor_address to eoi_byte_address if opening at
{ end_of_information and it is the only instance of open or it is opening for
{ private read.

        locate_previous_header;

      ELSE
      CASEND;

    PROCEND open_positioning;
?? TITLE := 'PROCEDURE replace_record', EJECT ??

    PROCEDURE replace_record;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSEIF file_instance^.instance_attributes.static_label.
            file_organization <> amc$sequential THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$file_organization_conflict, call_block.operation, error_text,
              status);
      ELSEIF NOT ((file_instance^.global_file_information^.positioning_info.
            record_info.file_position <> amc$mid_record) AND
            (file_instance^.global_file_information^.positioning_info.
            record_info.current_byte_address > 0)) THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_file_position, call_block.operation, error_text,
              status);
      ELSEIF (call_block.putn.working_storage_length < 0) OR
            (call_block.putn.working_storage_length >
            UPPERVALUE (amt$working_storage_length)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
              call_block.operation, error_text, status);
      ELSEIF caller_id.ring > file_instance^.instance_attributes.static_label.
            ring_attributes.r1 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, call_block.operation, error_text,
              status);
      ELSEIF NOT (pfc$modify IN file_instance^.instance_attributes.
            dynamic_label.access_mode) THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_access_attempt, call_block.operation, ' MODIFY',
              status);
      IFEND;
      IF status.normal THEN

      /main_code_replace/
        BEGIN
          record_info := file_instance^.global_file_information^.
                positioning_info.record_info;

          IF record_info.bor_address < file_instance^.global_file_information^.
                eoi_byte_address THEN

            record_header := #ADDRESS (osc$min_ring,
                  #SEGMENT (file_instance^.file_pva), record_info.bor_address);
            IF (record_header^.unique_id = bac$record_header_unique_id) { } AND
                  (record_header^.length <= UPPERVALUE (record_header^.length))
                  { } AND (record_header^.length >=
                  LOWERVALUE (record_header^.length)) { } AND
                  (record_header^.previous_header_fba <=
                  UPPERVALUE (record_header^.previous_header_fba)) { } AND
                  (record_header^.previous_header_fba >=
                  LOWERVALUE (record_header^.previous_header_fba)) { } AND
                  (record_header^.header_type <= UPPERVALUE (record_header^.
                  header_type)) { } AND (record_header^.
                  header_type >= LOWERVALUE (record_header^.header_type)) THEN
              ;
            ELSE
              amp$set_file_instance_abnormal (file_identifier,
                    ame$improper_record_header, call_block.operation,
                    error_text, status);
              EXIT /main_code_replace/;
            IFEND;
          ELSE
{ Locate correct bor_address for current_byte_address.
            EXIT /main_code_replace/; { remove when comment implemented }
          IFEND;

          IF record_header^.length = call_block.replace.
                working_storage_length THEN
            data_ptr := #ADDRESS (osc$min_ring,
                  #SEGMENT (file_instance^.file_pva),
                  record_info.bor_address + #SIZE (bat$record_header));

            i#move (call_block.replace.working_storage_area, data_ptr,
                  call_block.replace.working_storage_length);
            file_instance^.instance_of_open_modified := TRUE;
          ELSE
            amp$set_file_instance_abnormal (file_identifier,
                  ame$record_unequal_to_previous, call_block.operation,
                  error_text, status);
          IFEND;
        END /main_code_replace/;
      IFEND;
    PROCEND replace_record;
?? TITLE := 'PROCEDURE  validate_record_header', EJECT ??

    PROCEDURE validate_record_header;

*copy bai$validate_record_header

    PROCEND validate_record_header;
?? TITLE := 'PROCEDURE update_eoi', EJECT ??

    PROCEDURE update_eoi;

*copy bai$update_eoi

    PROCEND update_eoi;
?? TITLE := 'PROCEDURE [INLINE] skip', EJECT ??

    PROCEDURE [INLINE] skip;

      VAR
        skip_count: amt$skip_count;

      status.normal := TRUE;

      IF pfc$read IN file_instance^.instance_attributes.dynamic_label.
            access_mode THEN
        CASE file_instance^.instance_attributes.static_label.
              file_organization OF
        = amc$sequential =
          CASE file_instance^.access_level OF
          = amc$record =

*copy       bai$get_record_info

            IF (record_info.file_position = amc$mid_record) AND
                  (file_instance^.private_read_information = NIL) AND
                  (file_instance^.global_file_information^.
                  last_access_operation = amc$put_partial_req) THEN

{ Must have been left mid_record by a put_partial.  EOI needs updating.

              record_info.file_position := amc$eor;
              update_eoi;
            IFEND;

            CASE call_block.skp.direction OF
            = amc$forward =

              IF record_info.file_position = amc$mid_record THEN
                record_header := #ADDRESS (osc$min_ring,
                      #SEGMENT (file_instance^.file_pva),
                      record_info.bor_address);
                record_info.current_byte_address :=
                      record_info.bor_address + record_header^.length +
                      #SIZE (bat$record_header);
                record_info.file_position := amc$eor;
              IFEND;
              IF record_info.current_byte_address <>
                    file_instance^.global_file_information^.
                    eoi_byte_address THEN
                validate_record_header;
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              IFEND;

              CASE call_block.skp.unit OF
              = amc$skip_record =

              /skip_fwd_record/
                BEGIN
                  skip_count := call_block.skp.count;

                  IF skip_count > 0 THEN
                    WHILE (record_info.current_byte_address <
                          file_instance^.global_file_information^.
                          eoi_byte_address) AND (skip_count <> 0) DO
                      record_info.current_byte_address :=
                            record_info.current_byte_address +
                            #SIZE (bat$record_header) + record_header^.length;
                      IF record_info.current_byte_address >
                            file_instance^.global_file_information^.
                            eoi_byte_address THEN
                        amp$set_file_instance_abnormal
                              (file_identifier, ame$input_after_eoi, amc$skip_req,
                              '', status);
                        RETURN;
                      IFEND;
                      IF record_header^.header_type = bac$partition THEN
                        record_info.file_position := amc$bop;
                        amp$set_file_instance_abnormal
                              (file_identifier, ame$skip_encountered_eop,
                              amc$skip_req, ' RECORD', status);
                        EXIT /skip_fwd_record/;
                      IFEND;
                      IF record_info.current_byte_address <
                            file_instance^.global_file_information^.
                            eoi_byte_address THEN
*copy                   bai$validate_record_header
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;
                      IFEND;
                      skip_count := skip_count - 1;
                    WHILEND;

                    IF skip_count <> 0 THEN
                      amp$set_file_instance_abnormal
                            (file_identifier, ame$skip_encountered_eoi,
                            amc$skip_req, ' RECORD', status);
                      record_info.file_position := amc$eoi;
                    ELSE
                      record_info.file_position := amc$eor;
                    IFEND;
                  IFEND;
                END /skip_fwd_record/;

              = amc$skip_partition =

                skip_count := call_block.skp.count;

{ Do a 0 partition skip.  Find a partition boundary.

                WHILE (record_info.current_byte_address <>
                      file_instance^.global_file_information^.
                      eoi_byte_address) AND (record_info.current_byte_address <>
                      0) AND (record_info.file_position <> amc$bop) DO
                  IF record_header^.header_type = bac$partition THEN
                    record_info.file_position := amc$bop;
                  IFEND;
                  record_info.current_byte_address :=
                        record_info.current_byte_address +
                        #SIZE (bat$record_header) + record_header^.length;
                  IF record_info.current_byte_address >
                        file_instance^.global_file_information^.
                        eoi_byte_address THEN
                    amp$set_file_instance_abnormal
                          (file_identifier, ame$input_after_eoi, amc$skip_req,
                          '', status);
                    RETURN;
                  IFEND;
                  IF record_info.current_byte_address <
                        file_instance^.global_file_information^.
                        eoi_byte_address THEN
                    validate_record_header;
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;
                  IFEND;
                WHILEND;

{ Skip partitions until skip_count exhausted or EOI encountered.

                WHILE (skip_count <> 0) AND (record_info.current_byte_address <
                      file_instance^.global_file_information^.eoi_byte_address)
                      DO
                  record_info.current_byte_address :=
                        record_info.current_byte_address +
                        #SIZE (bat$record_header) + record_header^.length;
                  IF record_info.current_byte_address >
                        file_instance^.global_file_information^.
                        eoi_byte_address THEN
                    amp$set_file_instance_abnormal
                          (file_identifier, ame$input_after_eoi, amc$skip_req,
                          '', status);
                    RETURN;
                  IFEND;
                  IF record_info.current_byte_address <
                        file_instance^.global_file_information^.
                        eoi_byte_address THEN
                    validate_record_header;
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;
                  IFEND;
                  IF (record_info.current_byte_address <
                        file_instance^.global_file_information^.
                        eoi_byte_address) AND (record_header^.header_type =
                        bac$partition) THEN
                    skip_count := skip_count - 1;
                  IFEND;
                WHILEND;

                IF ((record_info.current_byte_address +
                      #SIZE (bat$record_header)) <=
                      file_instance^.global_file_information^.
                      eoi_byte_address) AND (record_header^.header_type =
                      bac$partition) THEN
                  record_info.current_byte_address :=
                        record_info.current_byte_address +
                        #SIZE (bat$record_header);
                IFEND;

                IF skip_count = 0 THEN
                  record_info.file_position := amc$bop;
                ELSE
                  amp$set_file_instance_abnormal (file_identifier,
                        ame$skip_encountered_eoi, amc$skip_req, ' PARTITION',
                        status);
                  record_info.file_position := amc$eoi;
                IFEND;

              ELSE
                amp$set_file_instance_abnormal (file_identifier,
                      ame$improper_skip_unit, amc$skip_req,
                      ' AMC$SKIP_TAPE_MARK', status);
                RETURN;
              CASEND;
            = amc$backward =

{ Position to beginning of current record.

              IF record_info.file_position = amc$mid_record THEN
                record_info.current_byte_address := record_info.bor_address;
                record_info.file_position := amc$eor;
              IFEND;

              CASE call_block.skp.unit OF

              = amc$skip_record =

              /bkwd_skip_record/
                BEGIN
                  skip_count := call_block.skp.count;

                  IF skip_count > 0 THEN
                    IF record_info.current_byte_address <>
                          file_instance^.global_file_information^.
                          eoi_byte_address THEN
                      validate_record_header;
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;
                    IFEND;

                    WHILE (record_info.current_byte_address <> 0) AND
                          (skip_count <> 0) DO
                      IF record_info.current_byte_address <
                            file_instance^.global_file_information^.
                            eoi_byte_address THEN
                        record_info.current_byte_address :=
                              record_header^.previous_header_fba;
                      ELSE
                        record_info.current_byte_address :=
                              record_info.bor_address;
                      IFEND;
*copy                 bai$validate_record_header
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;
                      record_info.bor_address := record_header^.previous_header_fba;
                      IF record_header^.header_type = bac$partition THEN
                        amp$set_file_instance_abnormal
                              (file_identifier, ame$skip_encountered_bop,
                              amc$skip_req, ' RECORD', status);
                        record_info.file_position := amc$eop;
                        EXIT /bkwd_skip_record/;
                      IFEND;
                      skip_count := skip_count - 1;
                    WHILEND;

                    IF skip_count <> 0 THEN
                      amp$set_file_instance_abnormal
                            (file_identifier, ame$skip_encountered_boi,
                            amc$skip_req, ' RECORD', status);
                      record_info.file_position := amc$boi;
                    ELSE
                      record_info.file_position := amc$eor;
                    IFEND;
                  IFEND;
                END /bkwd_skip_record/;

              = amc$skip_partition =

                skip_count := call_block.skp.count;

                IF (record_info.file_position = amc$bop) AND (record_info.current_byte_address <> 0) THEN
                  record_info.current_byte_address := record_info.current_byte_address -
                        #SIZE (bat$record_header);
                IFEND;
                IF record_info.current_byte_address <
                      file_instance^.global_file_information^.
                      eoi_byte_address THEN
                  validate_record_header;
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;
                IFEND;

{ Do a skip of 0 partitions

                WHILE (record_info.current_byte_address <> 0) AND
                      (record_info.file_position <> amc$bop) DO
                  IF record_info.current_byte_address <
                        file_instance^.global_file_information^.
                        eoi_byte_address THEN
                    record_info.current_byte_address :=
                          record_header^.previous_header_fba;
                  ELSE
                    record_info.current_byte_address := record_info.bor_address;
                  IFEND;
                  validate_record_header;
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;
                  IF record_header^.header_type = bac$partition THEN
                    record_info.file_position := amc$bop;
                  IFEND;
                WHILEND;

                WHILE (record_info.current_byte_address <> 0) AND
                      (skip_count <> 0) DO
                  IF record_info.current_byte_address <
                        file_instance^.global_file_information^.
                        eoi_byte_address THEN
                    record_info.current_byte_address :=
                          record_header^.previous_header_fba;
                  ELSE { No header to look at so get address from tables.
                    record_info.current_byte_address := record_info.bor_address;
                  IFEND;
                  validate_record_header;
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;
                  IF (record_header^.header_type = bac$partition) OR (record_info.current_byte_address = 0)
                        THEN
                    skip_count := skip_count - 1;
                    record_info.file_position := amc$bop;
                  IFEND;
                WHILEND;

                IF skip_count = 0 THEN
                  record_info.file_position := amc$bop;
                  IF record_info.current_byte_address <> 0 THEN

{ Position after the partition delimiter

                    record_info.current_byte_address := record_info.current_byte_address +
                          #SIZE (bat$record_header);
                  IFEND;
                ELSE
                  amp$set_file_instance_abnormal (file_identifier,
                        ame$skip_encountered_boi, amc$skip_req, ' PARTITION',
                        status);
                  record_info.file_position := amc$boi;
                IFEND;

              ELSE
                amp$set_file_instance_abnormal (file_identifier,
                      ame$improper_skip_unit, amc$skip_req,
                      ' AMC$SKIP_TAPE_MARK', status);
                RETURN;
              CASEND;
            ELSE
              amp$set_file_instance_abnormal (file_identifier,
                    ame$improper_skip_direction, amc$skip_req, '', status);
              RETURN;
            CASEND;
          ELSE
            amp$set_file_instance_abnormal (file_identifier,
                  ame$conflicting_access_level, amc$skip_req, '', status);
            RETURN;
          CASEND;
        ELSE
          amp$set_file_instance_abnormal (file_identifier,
                ame$file_organization_conflict, amc$skip_req, '', status);
          RETURN;
        CASEND;
      ELSE
        amp$set_file_instance_abnormal (file_identifier,
              ame$skip_requires_read_perm, call_block.operation, '', status);
        RETURN;
      IFEND;

*copy bai$save_record_info

      file_instance^.residual_skip_count := skip_count;
      call_block.skp.file_position^ := record_info.file_position;

    PROCEND skip;
?? TITLE := 'MAIN CODE OF BAM$SYS_BLK_VARIABLE_REC_FAP', EJECT ??

    #CALLER_ID (caller_id);
    status.normal := TRUE;

  /process_fap_request/
    BEGIN
      bap$validate_file_identifier (file_identifier, file_instance,
            validation_ok);
      IF NOT validation_ok THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
              error_text, status);
        RETURN;
      ELSE

        file_instance^.rollback_procedure := ^rollback_procedure;
        CASE call_block.operation OF
        = amc$get_next_req =
          get_next;
        = amc$put_next_req =
          put_next;
        = amc$get_partial_req =
          get_partial;
        = amc$put_partial_req =
          put_partial;
        = amc$open_req =
          open_positioning;
        = amc$close_req =
          IF (file_instance^.private_read_information = NIL) AND
                (file_instance^.global_file_information^.last_access_operation =
                amc$put_partial_req) AND (file_instance^.
                global_file_information^.positioning_info.record_info.
                file_position = amc$mid_record) THEN

{ Must have been left mid_record by a put_partial.  EOI needs updating.

            record_info := file_instance^.global_file_information^.
                  positioning_info.record_info;
            update_eoi;
            file_instance^.global_file_information^.positioning_info.
                  record_info := record_info;
          IFEND;
          bap$close (file_identifier, status);
          EXIT /process_fap_request/;
        = amc$rewind_req =
          IF (file_instance^.private_read_information = NIL) AND
                (file_instance^.global_file_information^.last_access_operation =
                amc$put_partial_req) AND (file_instance^.
                global_file_information^.positioning_info.record_info.
                file_position = amc$mid_record) THEN

{ Must have been left mid_record by a put_partial.  EOI needs updating.

            record_info := file_instance^.global_file_information^.
                  positioning_info.record_info;
            update_eoi;
            file_instance^.global_file_information^.positioning_info.
                  record_info := record_info;
          IFEND;
*copy     bai$rewind
        = amc$seek_direct_req =
          file_byte_address := call_block.seekd.byte_address;
          seek_direct;
        = amc$get_direct_req =
          file_byte_address := call_block.getd.byte_address;
          seek_direct;
          IF NOT status.normal THEN
            IF status.condition = ame$position_beyond_eoi THEN
              status.condition := ame$input_after_eoi;
            IFEND;
          ELSE
            get_next;
          IFEND;
        = amc$put_direct_req =
          file_byte_address := call_block.putd.byte_address;
          seek_direct;
          IF status.normal THEN
            put_next;
          IFEND;
        = amc$skip_req =
          skip;
        = amc$fetch_access_information_rq =
          bap$fetch_access_information (file_identifier, call_block,
                layer_number, status);
          EXIT /process_fap_request/;
        = amc$fetch_req =
          bap$fetch (file_identifier, call_block, layer_number, status);
          EXIT /process_fap_request/;
        = amc$get_segment_pointer_req =
          bap$get_segment_pointer (file_identifier, call_block, layer_number,
                status);
        = amc$set_segment_eoi_req =
          bap$set_segment_eoi (file_identifier, call_block, layer_number,
                status);
        = amc$set_segment_position_req =
          bap$set_segment_position (file_identifier, call_block, layer_number,
                status);
        = amc$replace_req =
          replace_record;
        = amc$store_req =
          bap$store (file_identifier, call_block, layer_number, status);
        = amc$write_end_partition_req =
          write_end_partition;
        = amc$write_tape_mark_req, amc$close_volume_req =
          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_device_class, call_block.operation, 'MASS_STORAGE',
                status);
        = amc$flush_req =
          bap$write_modified_pages (file_instance, file_identifier, status);
        = ifc$fetch_terminal_req, ifc$store_terminal_req =
          pmp$get_job_mode (job_mode, status);
          IF status.normal THEN
            IF job_mode = jmc$batch THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$current_job_not_interactive, 'FETCH/STORE_TERMINAL_REQ',
                    status);
            ELSE
              amp$set_file_instance_abnormal (file_identifier,
                    ame$improper_device_class, call_block.operation,
                    'MASS STORAGE', status);
            IFEND;
          IFEND;
        ELSE { NO CASE }
          amp$set_file_instance_abnormal (file_identifier,
                ame$unimplemented_request, call_block.operation,
                ' for sequential or byte addressable files', status);
        CASEND;
      IFEND; { validate_file_identifier }

      IF file_instance^.private_read_information = NIL THEN
        IF status.normal THEN
          file_instance^.global_file_information^.error_status := 0;
        ELSE
          file_instance^.global_file_information^.error_status :=
                status.condition;
        IFEND;
        file_instance^.global_file_information^.last_access_operation :=
              call_block.operation;
      ELSE
        IF status.normal THEN
          file_instance^.private_read_information^.error_status := 0;
        ELSE
          file_instance^.private_read_information^.error_status :=
                status.condition;
        IFEND;
        file_instance^.private_read_information^.last_access_operation :=
              call_block.operation;
      IFEND;
    END /process_fap_request/;

    file_instance^.rollback_procedure := NIL;
  PROCEND bap$sys_blk_variable_rec_fap;
MODEND bam$sys_blk_variable_rec_fap;
*DECK DECK=BAM$TABLES EXPAND=TRUE
?? RIGHT := 110 ??
MODULE bam$tables;
?? TITLE := 'NOS/VE :  Basic Access Method' ??
?? NEWTITLE := '  [XDCL] COMMON VARIABLE DECLARATIONS', EJECT ??
{}
{   This module contains static variables for basic access method routines.}
{}
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_pointer
*copyc amt$file_position
*copyc bap$lrt_ss_undef_tape_fap
*copyc bap$lrt_ss_var_tape_fap
*copyc bap$lrt_us_ansi_d_tape_fap
*copyc bap$lrt_us_ansi_s_tape_fap
*copyc bap$lrt_us_fixed_tape_fap
*copyc bap$lrt_us_undef_tape_fap
*copyc bap$sys_blk_fixed_rec_fap
*copyc bap$sys_blk_undefined_rec_fap
*copyc bap$sys_blk_variable_rec_fap
*copyc bap$trailing_char_delimited_fap
*copyc bap$us_blk_fixed_rec_fap
*copyc bap$us_blk_undefined_rec_fap
*copyc bap$us_blk_variable_rec_fap
*copyc bat$block_header
*copyc bat$block_info
*copyc bat$global_file_information
*copyc bat$labeled_tape_state_info
*copyc bat$record_info
*copyc bat$system_file_attributes
*copyc bat$tape_descriptor
*copyc fst$attachment_options_sources
*copyc fst$job_environment_information
*copyc fmt$static_label_header
*copyc fst$tape_attachment_information
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc rmc$unspecified_vsn
?? POP ??

  CONST
    default_ring_number = 11;

?? FMT (FORMAT := OFF) ??

?? NEWTITLE := '[XDCL] bav$default_attachment_sources', EJECT ??
    VAR
      bav$default_attachment_sources: [XDCL, READ, oss$job_paged_literal]
            fst$attachment_options_sources := [
        { access_modes_source } amc$access_method_default,
        { error_exit_name_source } amc$undefined_attribute,
        { error_limit_source } amc$undefined_attribute,
        { label_exit_name_source } amc$undefined_attribute,
        { message_control_source } amc$access_method_default,
        { open_position_source } amc$access_method_default];
?? OLDTITLE ??

?? NEWTITLE := '[XDCL] bav$default_block_info', EJECT ??
  VAR
    bav$default_block_info: [XDCL, #GATE, READ, oss$job_paged_literal]
          bat$block_info := [
      { block_number } 1,
      { block_position } *,
      { current_block_byte_address } 0,
      { current_block_length } 0,
      { previous_block_header_fba } 0,
      { residual_block_length } 0];
?? OLDTITLE ??

?? NEWTITLE := '[XDCL] bav$default_record_info', EJECT ??
  VAR
    bav$default_record_info: [XDCL, #GATE, READ, oss$job_paged_literal]
          bat$record_info := [
      { bor_address } 0,
      { current_byte_address } 0,
      { file_position } amc$boi,
      { record_header_fba } 0,
      { record_length } 0,
      { residual_record_length } 0,
      { transfer_count } 0];
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] bav$labeled_tape_state_info', EJECT ??
  VAR
    bav$labeled_tape_state_info: [XDCL, #GATE, READ, oss$job_paged_literal]
          bat$labeled_tape_state_info := [
        { buffered_blocks } 0,
        { character_conversion } FALSE,
        { character_set } amc$ascii,
        { eof1_block_count } 0,
        { eoi_labels_needed } FALSE,
        { file_access } bac$read,
        { maximum_block_length } 1,
        { maximum_record_length } 0,
        { padding_character } ' ',
        { put_op } FALSE,
        { translated_block_padding_char } '^',
        { translated_record_padding_char } ' ',
        { ve_wrote_ansi_file } TRUE];
?? OLDTITLE ??

?? NEWTITLE := '[XDCL] bav$magnetic_tape_device_faps', EJECT ??
  VAR
    bav$magnetic_tape_device_faps: [XDCL, #GATE, READ, oss$job_paged_literal]
         array [amt$block_type] of array [amt$record_type] of amt$fap_pointer:=
     [
      [ {SS/V}  ^bap$lrt_ss_var_tape_fap,
        {SS/U}  ^bap$lrt_ss_undef_tape_fap,
        {SS/F}  NIL,
        {SS/S}  NIL,
        {SS/D}  NIL,
        {SS/T}  NIL],
      [ {US/V}  ^bap$lrt_ss_var_tape_fap, {allows maxbl to exceed 4128}
        {US/U}  ^bap$lrt_us_undef_tape_fap,
        {US/F}  ^bap$lrt_us_fixed_tape_fap,
        {US/S}  ^bap$lrt_us_ansi_s_tape_fap,
        {US/D}  ^bap$lrt_us_ansi_d_tape_fap,
        {US/T}  NIL]
                    ];
?? OLDTITLE ??

?? NEWTITLE := '[XDCL] bav$mass_storage_device_faps', EJECT ??
  VAR
    bav$mass_storage_device_faps: [XDCL, #GATE, READ, oss$job_paged_literal]
         array [amt$block_type] of array [amt$record_type] of amt$fap_pointer:=
     [
      [ {SS/V}  ^bap$sys_blk_variable_rec_fap,
        {SS/U}  ^bap$sys_blk_undefined_rec_fap,
        {SS/F}  ^bap$sys_blk_fixed_rec_fap,
        {SS/S}  NIL,
        {SS/D}  NIL,
        {SS/T}  ^bap$trailing_char_delimited_fap],
      [ {US/V}  ^bap$us_blk_variable_rec_fap,
        {US/U}  ^bap$us_blk_undefined_rec_fap,
        {US/F}  ^bap$us_blk_fixed_rec_fap,
        {US/S}  NIL,
        {US/D}  NIL,
        {US/T}  NIL]
                    ];

?? OLDTITLE ??

?? NEWTITLE := '[XDCL] bav$rms_library_refrence', EJECT ??
  VAR
    bav$rms_library_reference: [XDCL, #GATE, READ, oss$job_paged_literal]
       record
         entry_point: pmt$program_name,
         object_library: string (33),
       recend :=[
        'RSP$RMS_FAP                    ',
        '$SYSTEM.RMS.RSF$BOUND_PRODUCT_333'];

?? OLDTITLE ??


?? NEWTITLE := '[XDCL] fmv$system_file_attributes', EJECT ??
    VAR
      fmv$static_label_header: [XDCL, #GATE, READ, oss$job_paged_literal]
            fmt$static_label_header := [
        {unique_character} fmc$unique_label_id,
        {revision_level} fmc$current_revision_level,
        {highest_attribute_present} 0,
        {highest_attribute_supported} fmc$highest_current_attribute,
        {job_routing_label_size} 0,
        {default_revision_level} 1,
        {user_attribute_length} 0,
        {filler} ' ',
        {attribute_present} [REP amc$max_attribute of FALSE],
        {file_previously_opened} TRUE,
        {ring_attributes} [default_ring_number, default_ring_number, default_ring_number],
        {ring_attributes_source} amc$access_method_default];

?? OLDTITLE ??

?? NEWTITLE := '[XDCL] fmv$system_file_attributes', EJECT ??
    VAR
      fmv$system_file_attributes: [oss$job_paged_literal, XDCL, #GATE, READ]
        bat$system_file_attributes := [[

        { static label }

        { block_type } amc$system_specified,
        { item_source } amc$access_method_default,
        { character_conversion } FALSE,
        { item_source } amc$access_method_default,
        { item.clear_space } FALSE,
        { item_source } amc$access_method_default,
        { item.file_access_procedure } osc$null_name,
        { item_source } amc$undefined_attribute,
        { item.file_contents } amc$unknown_contents,
        { item_source } amc$access_method_default,
        { item.file_limit } osc$max_segment_length,
        { item_source } amc$access_method_default,
        { item.file_organization } amc$sequential,
        { item_source } amc$access_method_default,
        { file_processor } amc$unknown_processor,
        { item_source } amc$access_method_default,
        { file_structure } amc$unknown_structure,
        { item_source } amc$access_method_default,
        { forced_write } amc$unforced,
        { item_source } amc$access_method_default,
        { item.internal_code } amc$ascii,
        { item_source } amc$access_method_default,
        { item.label_type } amc$unlabelled,
        { item_source } amc$access_method_default,
        { item.line_number } [1,1],
        { item_source } amc$undefined_attribute,
        { item.max_block_length } 4128,
        { item_source } amc$access_method_default,
        { item.max_record_length } 256,
        { item_source } amc$access_method_default,
        { item.min_block_length } 18,
        { item_source } amc$access_method_default,
        { item.min_record_length } 0,
        { item_source } amc$access_method_default,
        { item.padding_character } ' ',
        { item_source } amc$access_method_default,
        { item.page_format } amc$burstable_form,
        { item_source } amc$access_method_default,
        { item.page_length } 60,
        { item_source } amc$access_method_default,
        { item.page_width } 132,
        { item_source } amc$access_method_default,
        { item.preset_value } 0,
        { item_source } amc$access_method_default,
        { item.record_delimiting_character } $CHAR(10) { lf },
        { item_source } amc$access_method_default,
        { item.record_type } amc$variable { v } ,
        { item_source } amc$access_method_default,
        { item.ring_attributes } [default_ring_number, default_ring_number, default_ring_number],
        { item_source } amc$access_method_default,
        { statement_identifier } [1,1],
        { statement_identifier_source } amc$undefined_attribute,
        { item.user_info } osc$null_name,
        { item_source } amc$undefined_attribute,
        { vertical_print_density } 6,
        { vertical_print_density_source } amc$access_method_default,
        { item.average_record_length } 1 ,
        { item_source } amc$undefined_attribute,
        { collate_table } [rep 33 of 0,
                          34, 23,  5, 16,  2,  6,  7, 21, 13, 17, 15, 20, 18,
                          12, 19, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 53,
                          14, 24, 22,  9,  8,  1, 25, 26, 27, 28, 29, 30, 31,
                          32, 33, 35, 36, 37, 38, 39, 40, 41, 42, 43, 45, 46,
                          47, 48, 49, 50, 51, 52,  3, 10, 44, 11,  4, rep 160 of 0],
        { collate_table_source } amc$undefined_attribute,
        { collate_table_name } osc$null_name,
        { collate_table_name_source } amc$undefined_attribute,
        { compression_procedure_name } [osc$null_name, osc$null_name],
        { compression_procedure_name_source } amc$undefined_attribute,
        { item.data_padding } 0,
        { item_source } amc$access_method_default,
        { dynamic_home_block_space } FALSE,
        { dynamic_home_block_space_source } amc$access_method_default,
        { item.embedded_key } TRUE,
        { item_source } amc$access_method_default,
        { item.estimated_record_count } 0 ,
        { item_source } amc$undefined_attribute,
        { hashing_procedure_name } ['AMP$SYSTEM_HASHING_PROCEDURE   ', osc$null_name],
        { hashing_procedure_name_source } amc$undefined_attribute,
        { item.index_levels } 2 ,
        { item_source } amc$access_method_default,
        { item.index_padding } 0,
        { item_source } amc$access_method_default,
        { initial_home_block_count } 1,
        { initial_home_block_count_source } amc$access_method_default,
        { item.key_length } 1 ,
        { item_source } amc$undefined_attribute,
        { item.key_position } 0,
        { item_source } amc$access_method_default,
        { item.key_type } amc$uncollated_key,
        { item_source } amc$access_method_default,
        { loading_factor } 90,
        { loading_factor_source } amc$access_method_default,
        { lock_expiration_time } 60000,
        { lock_expiration_time_source } amc$access_method_default,
        { logging_options } $amt$logging_options [],
        { logging_options_source } amc$undefined_attribute,
        { log_residence } osc$null_name,
        { log_residence_source } amc$undefined_attribute,
        { item.record_limit } amc$file_byte_limit,
        { item_source } amc$undefined_attribute,
        { item.records_per_block } amc$max_records_per_block,
        { item_source } amc$undefined_attribute
        { recend; } ],

        { dynamic label } [

        { access_mode } $pft$usage_selections [pfc$read, pfc$shorten,
        pfc$modify, pfc$append, pfc$execute],
        { item_source } amc$access_method_default,
        { error_exit_name } osc$null_name,
        { error_exit_name_source } amc$undefined_attribute,
        { error_exit_procedure } NIL,
        { error_exit_procedure source } amc$undefined_attribute,
        { error_options } [TRUE, amc$terminate_file_access],
        { error_options_source } amc$access_method_default,
        { label_exit_name } osc$null_name,
        { label_exit_name_source } amc$undefined_attribute,
        { label exit procedure } NIL,
        { label_exit procedure source } amc$undefined_attribute,
        { item.label_options } * ,
        { item_source } amc$undefined_attribute,
        { item.open_position } amc$open_at_boi,
        { item_source } amc$access_method_default,
        { open_share_modes } $fst$file_access_options [fsc$read, fsc$shorten,
        fsc$append, fsc$modify, fsc$execute],
        { open_share_modes_source } amc$access_method_default,
        { return_option } amc$return_at_job_exit,
        { item_source } amc$access_method_default,
        { item.error_limit } * ,
        { item_source } amc$undefined_attribute,
        { item.message_control } $amt$message_control [],
        { item_source } amc$access_method_default
        { recend; } ],

        { descriptive label } [

        { application_info } osc$null_name,
        { application_info_source } amc$local_file_information,
        { global_access_mode } $pft$usage_selections [pfc$read, pfc$shorten,
        pfc$append, pfc$modify, pfc$execute],
        { item_source } amc$local_file_information,
        { global_file_name } [0, osc$cyber_180_model_unknown, 1980, 8, 12, 0, 0, 0, 0, 0],
        { item_source } amc$local_file_information,
        { global_share_mode } $pft$share_selections [],
        { item_source } amc$local_file_information,
        { internal_cycle_name } [0, osc$cyber_180_model_unknown, 1980, 8, 12, 0, 0, 0, 0, 0],
        { item_source } amc$local_file_information,
        { permanent_file } FALSE,
        { item_source } amc$local_file_information
        { recend; } ]];
?? OLDTITLE ??

?? NEWTITLE := '[XDCL] fmv$global_file_information', EJECT ??
    VAR
      fmv$global_file_information: [oss$job_paged_literal, XDCL, #GATE, READ]
        bat$global_file_information := [
        { open_count } 0,
        { open_lock } [0],
        { implicit_detach_inhibited } FALSE,
        { asis_bor_address } 0,
        { asis_file_position } amc$boi,
        { asis_open_address } 0,
        { cycle_damage_symptoms } [],
        { device_dependent_info } [rmc$mass_storage_device, NIL],
        { eoi_byte_address } 0,
        { eoi_set } FALSE,
        { error_status } 0,
        { file_limit } amc$file_byte_limit,
        { last_access_operation } *,
        { max_block_size } 4128 + #SIZE(bat$block_header),
        { max_data_size} 4128,
        { max_record_length } 256,
        { min_block_length } 18,
        { opened_access_modes } [rep 5 of 0],
        { padding_character } ' ',
        { positioning_info } [[1,bac$beginning_of_block,0,0,0,0],
                              [0,0,amc$boi,0,0,0,0]],
        { prevented_open_access_modes } [rep 5 of 0],
        { record_delimiting_character } $CHAR(10) { lf }];
?? OLDTITLE ??

?? NEWTITLE := '[XDCL] fmv$tape_descriptor', EJECT ??
    VAR
      fmv$tape_descriptor: [oss$job_paged_literal, XDCL, #GATE, READ]
        bat$tape_descriptor := [

        { at_eoi } FALSE,
        { block_management_descriptor } NIL,
        { error_options } [
          { perform_failure_recovery } TRUE,
          { error_action } amc$terminate_file_access],
        { failure_isolation } [
          { failed_at_current_position } TRUE,
          { failure_modes } $amt$tape_failure_modes []],
        { file_label_type } amc$labelled,
        { forced_write } FALSE,
        { get_tape_block_buffer } NIL,
        { initial_volume} [
          {access_modes } $fst$file_access_options [],
          {assigned } FALSE,
          {classification } *,
          {header_labels } NIL,
          {initial_read_labels_attempt } TRUE],
        { labeled_volume_position } bac$lvp_beginning_of_file_set,
        { last_accessed } [
          { secured_header_labels } NIL,
          { secured_trailer_labels } NIL,
          { unsecured_header_labels } NIL,
          { unsecured_trailer_labels } NIL ],
        { last_data_operation } amc$rewind_req,
        { next_position } [
          { file_section_number } 1,
          { file_sequence_number } 1 ],
        { put_tape_block_buffer } NIL,
        { requested_density } rmc$1600,
        { rewind_file_command } FALSE,
        { tape_attachment_information } [
          { block_type } amc$system_specified,
          { block_type_source } fsc$tape_label_attr_default,
          { buffer_offset } 0,
          { buffer_offset_source } fsc$tape_label_attr_default,
          { character_conversion } FALSE,
          { character_conversion_source } fsc$tape_label_attr_default,
          { character_set } amc$ascii,
          { character_set_source } fsc$tape_label_attr_default,
          { creation_date } '  ',
          { creation_date_source } fsc$tape_label_attr_default,
          { expiration_date } '1900000',
          { expiration_date_source } fsc$tape_label_attr_default,
          { file_accessibility } ' ',
          { file_accessibility_source } fsc$tape_label_attr_default,
          { file_identifier } '  ',
          { file_identifier_source } fsc$tape_label_attr_default,
          { file_section_number } 1,
          { file_section_number_source } fsc$tape_label_attr_default,
          { file_sequence_number } 1,
          { file_sequence_number_source } fsc$tape_label_attr_default,
          { file_set_identifier } '  ',
          { file_set_identifier_source } fsc$tape_label_attr_default,
          { file_set_position } [fsc$tape_next_file],
          { file_set_position_source } fsc$tape_label_attr_default,
          { generation_number } 1,
          { generation_number_source } fsc$tape_label_attr_default,
          { generation_version_number } 0,
          { generation_version_num_source } fsc$tape_label_attr_default,
          { label_standard_version } '4',
          { label_standard_version_source } fsc$tape_label_attr_default,
          { max_block_length } 4128,
          { max_block_length_source } fsc$tape_label_attr_default,
          { max_record_length } 256,
          { max_record_length_source } fsc$tape_label_attr_default,
          { owner_identifier } '  ',
          { owner_identifier_source } fsc$tape_label_attr_default,
          { padding_character } ' ',
          { padding_character_source } fsc$tape_label_attr_default,
          { record_type } amc$variable,
          { record_type_source } fsc$tape_label_attr_default,
          { removable_media_group } ' ',
          { removable_media_group_source } fsc$tape_label_attr_default,
          { rewrite_labels } FALSE ,
          { rewrite_labels_source } fsc$tape_label_attr_default,
          { supplied_file_set_pos_fields } [],
          { system_code } '  ' ,
          { system_code_source } fsc$tape_label_attr_default,
          { volume_accessibility } 'A',
          { volume_accessibility_source } fsc$tape_label_attr_default,
          { volume_initialization } FALSE],
        { tape_label_attr_command_info } [
          { block_type } amc$system_specified,
          { block_type_source } fsc$tape_label_attr_default,
          { buffer_offset } 0,
          { buffer_offset_source } fsc$tape_label_attr_default,
          { character_conversion } FALSE,
          { character_conversion_source } fsc$tape_label_attr_default,
          { character_set } amc$ascii,
          { character_set_source } fsc$tape_label_attr_default,
          { creation_date } '  ',
          { creation_date_source } fsc$tape_label_attr_default,
          { expiration_date } '1900000',
          { expiration_date_source } fsc$tape_label_attr_default,
          { file_accessibility } ' ',
          { file_accessibility_source } fsc$tape_label_attr_default,
          { file_identifier } '  ',
          { file_identifier_source } fsc$tape_label_attr_default,
          { file_section_number } 1,
          { file_section_number_source } fsc$tape_label_attr_default,
          { file_sequence_number } 1,
          { file_sequence_number_source } fsc$tape_label_attr_default,
          { file_set_identifier } '  ',
          { file_set_identifier_source } fsc$tape_label_attr_default,
          { file_set_position } [fsc$tape_next_file],
          { file_set_position_source } fsc$tape_label_attr_default,
          { generation_number } 1,
          { generation_number_source } fsc$tape_label_attr_default,
          { generation_version_number } 0,
          { generation_version_num_source } fsc$tape_label_attr_default,
          { label_standard_version } '4',
          { label_standard_version_source } fsc$tape_label_attr_default,
          { max_block_length } 4128,
          { max_block_length_source } fsc$tape_label_attr_default,
          { max_record_length } 256,
          { max_record_length_source } fsc$tape_label_attr_default,
          { owner_identifier } '  ',
          { owner_identifier_source } fsc$tape_label_attr_default,
          { padding_character } ' ',
          { padding_character_source } fsc$tape_label_attr_default,
          { record_type } amc$variable,
          { record_type_source } fsc$tape_label_attr_default,
          { removable_media_group } ' ',
          { removable_media_group_source } fsc$tape_label_attr_default,
          { rewrite_labels } FALSE ,
          { rewrite_labels_source } fsc$tape_label_attr_default,
          { supplied_file_set_pos_fields } [],
          { system_code } '  ' ,
          { system_code_source } fsc$tape_label_attr_default,
          { volume_accessibility } 'A',
          { volume_accessibility_source } fsc$tape_label_attr_default,
          { volume_initialization } FALSE],
        { volume_number } 1,
        { volume_position } amc$bov ];
?? OLDTITLE ??

?? NEWTITLE := '[XDCL] fmv$tape_attachment_information', EJECT ??
    VAR
      fmv$tape_attachment_information: [oss$job_paged_literal, XDCL, #GATE, READ]
        fst$tape_attachment_information := [

        { block_type } amc$system_specified,
        { block_type_source } fsc$tape_label_attr_default,
        { buffer_offset } 0,
        { buffer_offset_source } fsc$tape_label_attr_default,
        { character_conversion } FALSE,
        { character_conversion_source } fsc$tape_label_attr_default,
        { character_set } amc$ascii,
        { character_set_source } fsc$tape_label_attr_default,
        { creation_date } '  ',
        { creation_date_source } fsc$tape_label_attr_default,
        { expiration_date } '1900000',
        { expiration_date_source } fsc$tape_label_attr_default,
        { file_accessibility } ' ',
        { file_accessibility_source } fsc$tape_label_attr_default,
        { file_identifier } '  ',
        { file_identifier_source } fsc$tape_label_attr_default,
        { file_section_number } 1,
        { file_section_number_source } fsc$tape_label_attr_default,
        { file_sequence_number } 1,
        { file_sequence_number_source } fsc$tape_label_attr_default,
        { file_set_identifier } '  ',
        { file_set_identifier_source } fsc$tape_label_attr_default,
        { file_set_position } [fsc$tape_next_file],
        { file_set_position_source } fsc$tape_label_attr_default,
        { generation_number } 1,
        { generation_number_source } fsc$tape_label_attr_default,
        { generation_version_number } 0,
        { generation_version_num_source } fsc$tape_label_attr_default,
        { label_standard_version } '4',
        { label_standard_version_source } fsc$tape_label_attr_default,
        { max_block_length } 4128,
        { max_block_length_source } fsc$tape_label_attr_default,
        { max_record_length } 256,
        { max_record_length_source } fsc$tape_label_attr_default,
        { owner_identifier } '  ',
        { owner_identifier_source } fsc$tape_label_attr_default,
        { padding_character } ' ',
        { padding_character_source } fsc$tape_label_attr_default,
        { record_type } amc$variable,
        { record_type_source } fsc$tape_label_attr_default,
        { removable_media_group } ' ',
        { removable_media_group_source } fsc$tape_label_attr_default,
        { rewrite_labels } FALSE ,
        { rewrite_labels_source } fsc$tape_label_attr_default,
        { supplied_file_set_pos_fields } [],
        { system_code } '  ' ,
        { system_code_source } fsc$tape_label_attr_default,
        { volume_accessibility } 'A',
        { volume_accessibility_source } fsc$tape_label_attr_default,
        { volume_initialization } FALSE];
?? OLDTITLE ??

?? NEWTITLE := '[XDCL] fsv$default_job_environ_info', EJECT ??
    VAR
      fsv$default_job_environ_info: [oss$job_paged_literal, XDCL, #GATE, READ]
            fst$job_environment_information := [

        { attached_access_modes } -$fst$file_access_options [],
        { attached_share_modes } $fst$file_access_options [],
        { concurrent_open_count } 0,
        { connected_files } NIL,
        { cycle_attached } FALSE,
        { error_exit_procedure_name } osc$null_name,
        { error_limit } 0,
        { job_file_address } 0,
        { job_file_position } amc$boi,
        { job_write_concurrency } FALSE,
        { label_exit_procedure_name } osc$null_name,
        { mass_storage_free_behind } FALSE,
        { mass_storage_sequential_access } FALSE,
        { message_control } $amt$message_control [],
        { open_position } amc$open_at_boi,
        { prevented_open_access_modes } $fst$file_access_options [],
        { private_read } [FALSE],
        { setfa_access_modes } $fst$file_access_options [],
        { specified_attachment_options } $fst$specified_attach_options [],
        { transfer_size } 0,
        { volume_list } NIL,
        { volume_number } 1,
        { volume_overflow_allowed } FALSE,
        { attachment_options_sources } [amc$access_method_default, amc$undefined_attribute,
                                        amc$undefined_attribute, amc$undefined_attribute,
                                        amc$access_method_default, amc$access_method_default]];

?? FMT (FORMAT := ON) ??

MODEND bam$tables;

*DECK DECK=BAM$TAPE_BLOCK_MANAGER_RING1 EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
*copy osd$default_pragmats
MODULE bam$tape_block_manager_ring1;

  { This module exists only to contain certain variables which are tuning and/or debugging }
  { parameters for tape block management.  These variables are packaged in ring 1 so that }
  { their values will be shared by all jobs in the system. }

  { Set_system_attribute commands exist to modify the values of these variables.  See module }
  { sym$system_constant_manager for the names of the attributes.  These values can, or course, }
  { also be modified with the system core debugger if necessary. }

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

?? TITLE := 'System wide variables for tape block management', EJECT ??

  { The following variable controls the maximum MAX_BLOCK_LENGTH which will be allowed for tape files. }
  { Any attempt to open a tape with a MAXBL larger than this value will be rejected by tape block }
  { management. }

  VAR
    bav$max_allowed_tape_block_size: [STATIC, XDCL, #GATE] integer := 7FFFFFFFF(16);

  { The value of the following variable controls the decision to use direct tape I/O. }
  { If the max_block_length specified by the user is larger than this value direct I/O }
  { will be used. }

  VAR
    bav$max_indirect_tape_block: [STATIC, XDCL, #GATE] integer :=  65536;

  { The value of the following variable is the maximum number of bytes which will be }
  { used in a tape buffer group.  The users max_block_length is divided by this number to }
  { determine the number of tape blocks to be read or written in each physical I/O call. }

  VAR
    bav$max_bytes_per_tape_io: [STATIC, XDCL, #GATE] integer := 196608;

  { The following variable is here to help with debugging  of direct I/O.  This variable is }
  { normally FALSE.  If it is set TRUE then all tape I/O  will be done direct, regardless of }
  { the MAXBL specified by the user. }

  VAR
    bav$force_direct_tape_io: [STATIC, XDCL, #GATE] boolean := FALSE;

  { The following variable is here to help evaluate the performance if the memory management }
  { strategy used in tape block management.  If this variable is TRUE, block management will }
  { use mmp$assign_pages, mmp$check_if_pages_in_memory and mmp$conditional_free to manage the }
  { assignment of real memory to tape buffers.  If this variable is FALSE, block management }
  { will use mmp$advise_in to rapidly bring data into memory, and will take no special action }
  { to free space when it is no longer needed. }

  VAR
    bav$use_assign_pages_for_tape: [STATIC, XDCL, #GATE] boolean := TRUE;

  { The following variable controls the enforcement of tape security.
  {
  {   TRUE
  {     Enforcement of security in ANSI VOL1 and HDR1 labels is enabled.
  {     Labeled external and unlabeled tape access is controlled via capabilities.
  {     Expiration_date is enforced.
  {
  {   FALSE
  {     Enforcement of security in ANSI VOL1 and HDR1 labels is disabled.
  {     Labeled external and unlabeled tape access is not controlled.
  {     Expiration_date is enforced.
  {

  VAR
    bav$enforce_tape_security: [STATIC, XDCL] bat$tape_validation_state := bac$no_tape_validation;

  { The following variable controls the use of tape management site hooks.
  { The system maintains the following tape validation states:
  {
  {   No Validation (bac$no_tape_validation):
  {     Tape management site hooks are not called in this state.
  {     The system is in this state during deadstart and until the state is changed by a
  {     CHANGE_TAPE_VALIDATION command which can be inserted in the SITE_STARTUP_COMMANDS file.
  {
  {   Validation On (bac$tape_validation_on):
  {     Tape management site hooks are called in this state with a value of TRUE in the
  {     TAPE_VALIDATION_STATE parameter which is passed to each of the site tape validation interfaces.
  {     This is set by specifying a value of TRUE for the VALIDATE_TAPE_ACCESS parameter
  {     on the CHANGE_TAPE_VALIDATION command
  {
  {   Validation Off (bac$tape_validation_off):
  {     Tape management site hooks are called in this state with a value of FALSE in the
  {     TAPE_VALIDATION_STATE parameter which is passed to each of the site tape validation interfaces.
  {     This state is selected by specifying a value of FALSE for the VALIDATE_TAPE_ACCESS parameter
  {     on the CHANGE_TAPE_VALIDATION command.
  {

  VAR
    bav$tape_validation_state: [STATIC, XDCL] bat$tape_validation_state := bac$no_tape_validation;

*copyc bat$tape_validation_state

?? EJECT ??

{
{ This procedure returns the current tape validation state.
{

  PROCEDURE [XDCL, #GATE] bap$fetch_tape_validation_r1 (
    VAR tape_validation_state: bat$tape_validation_state;
    VAR status: ost$status);

    tape_validation_state := bav$tape_validation_state;

  PROCEND bap$fetch_tape_validation_r1;

?? EJECT ??

{
{ This procedure returns the current tape security state.
{

  PROCEDURE [XDCL, #GATE] bap$get_tape_security_state_r1 (
    VAR enforce_tape_security : bat$tape_validation_state);

    enforce_tape_security := bav$enforce_tape_security;

  PROCEND bap$get_tape_security_state_r1;

?? EJECT ??

{
{ This procedure changes tape security state.
{

  PROCEDURE [XDCL, #GATE] bap$put_tape_security_state_r1 (
        enforce_tape_security: bat$tape_validation_state);

    bav$enforce_tape_security := enforce_tape_security;

  PROCEND bap$put_tape_security_state_r1;
?? EJECT ??

{
{ This procedure changes the tape validation state.
{

  PROCEDURE [XDCL, #GATE] bap$store_tape_validation_r1 (
        tape_validation_state: bat$tape_validation_state;
    VAR status: ost$status);

    bav$tape_validation_state := tape_validation_state;

  PROCEND bap$store_tape_validation_r1;

MODEND bam$tape_block_manager_ring1;




*DECK DECK=BAM$TAPE_BLOCK_MANAGER_RING2 EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
*copy osd$default_pragmats
MODULE bam$tape_block_manager_ring2;
























  {  This module provides access  to the ring 2, system_file_id  oriented interfaces for the }
  {  ring 3 tape_block_manager.   Interfaces are provided to physical I/O and device management. }

?? PUSH (LISTEXT := ON) ??
*copyc iop$tape_request_status
*copyc iop$backspace_tape
*copyc iop$erase_tape
*copyc iop$forspace_tape
*copyc iop$fetch_tape_capabilities
*copyc iop$read_tape
*copyc iop$rewind_tape
*copyc iop$write_tape
*copyc iop$write_tapemark
*copyc dmp$advance_tape_volume
*copyc dmp$reset_tape_volume
*copyc oss$job_pageable
{*copyc bat$tape_block_mgmt_descriptor
?? POP ??
?? EJECT ??
?? TITLE := '  PROCEDURE [XDCL, #GATE] bap$await_tape_io_completion' ??

  PROCEDURE [XDCL, #GATE] bap$await_tape_io_completion (sfid: dmt$system_file_id;
        io_id: iot$io_id;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

    status.normal := TRUE;

    iop$tape_request_status (sfid, io_id, {wait=} TRUE, tape_status, status);

  PROCEND bap$await_tape_io_completion;

?? EJECT ??
?? TITLE := '  PROCEDURE [XDCL, #GATE] bap$backspace_tape' ??

  PROCEDURE [XDCL, #GATE] bap$backspace_tape (
        sfid: dmt$system_file_id;
        count: iot$tape_block_count;
        use_locate_block: boolean;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

    status.normal := TRUE;

    iop$backspace_tape (sfid, count, use_locate_block, tape_status, status);

  PROCEND bap$backspace_tape;

?? EJECT ??
?? TITLE := '  PROCEDURE [XDCL, #GATE] bap$forspace_tape' ??

  PROCEDURE [XDCL, #GATE] bap$forspace_tape (sfid: dmt$system_file_id;
        count: iot$tape_block_count;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

    VAR
      io_id: iot$io_id;

    status.normal := TRUE;

    iop$forspace_tape (sfid, count, io_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    bap$await_tape_io_completion (sfid, io_id, tape_status, status);

  PROCEND bap$forspace_tape;
?? EJECT ??
?? TITLE := '  PROCEDURE [XDCL, #GATE] bap$rewind_tape' ??

  PROCEDURE [XDCL, #GATE] bap$rewind_tape (sfid: dmt$system_file_id;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

    VAR
      io_id: iot$io_id;

    status.normal := TRUE;

    iop$rewind_tape (sfid, io_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    bap$await_tape_io_completion (sfid, io_id, tape_status, status);

  PROCEND bap$rewind_tape;

?? EJECT ??
?? TITLE := '  PROCEDURE [XDCL, #GATE] bap$write_tapemark' ??

  PROCEDURE [XDCL, #GATE] bap$write_tapemark (sfid: dmt$system_file_id;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

    VAR
      io_id: iot$io_id;

    status.normal := TRUE;

    iop$write_tapemark (sfid, io_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    bap$await_tape_io_completion (sfid, io_id, tape_status, status);

  PROCEND bap$write_tapemark;

?? EJECT ??
?? TITLE := '  PROCEDURE [XDCL, #GATE] bap$erase_tape' ??

  PROCEDURE [XDCL, #GATE] bap$erase_tape (sfid: dmt$system_file_id;
        block_length: amt$max_block_length;
        number_of_erases: integer;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

    status.normal := TRUE;

    iop$erase_tape (sfid, block_length, number_of_erases, io_status, status);

  PROCEND bap$erase_tape;

?? EJECT ??
?? TITLE := '  PROCEDURE [XDCL, #GATE] bap$fetch_tape_capabilities' ??

  PROCEDURE [XDCL, #GATE] bap$fetch_tape_capabilities (sfid: dmt$system_file_id;
    VAR maximum_block_length: amt$max_block_length;
    VAR max_blocks_per_physical_call: iot$tape_block_count;
    VAR status: ost$status);

    status.normal := TRUE;

    iop$fetch_tape_capabilities (sfid, maximum_block_length, max_blocks_per_physical_call, status);

  PROCEND bap$fetch_tape_capabilities;

?? EJECT ??
?? TITLE := '  PROCEDURE [XDCL, #GATE] bap$read_tape' ??

  PROCEDURE [XDCL, #GATE] bap$read_tape (sfid: dmt$system_file_id;
        max_block_size: iot$tape_block_length;
        block_description: ^iot$read_tape_description;
        block_count: iot$tape_block_count;
        perform_media_error_recovery: boolean;
    VAR io_id: iot$io_id;
    VAR status: ost$status);

    VAR
      inhibit_media_error_recovery: boolean;

    status.normal := TRUE;

    inhibit_media_error_recovery := NOT perform_media_error_recovery;
    iop$read_tape (sfid, inhibit_media_error_recovery, max_block_size, block_description, block_count, io_id,
          status);

  PROCEND bap$read_tape;

?? EJECT ??
?? TITLE := '  PROCEDURE [XDCL, #GATE] bap$write_tape' ??

  PROCEDURE [XDCL, #GATE] bap$write_tape (sfid: dmt$system_file_id;
        block_description: ^iot$write_tape_description;
        block_count: iot$tape_block_count;
        perform_media_error_recovery: boolean;
    VAR io_id: iot$io_id;
    VAR status: ost$status);

    VAR
      inhibit_media_error_recovery: boolean;

    status.normal := TRUE;

    inhibit_media_error_recovery := NOT perform_media_error_recovery;
    iop$write_tape (sfid, inhibit_media_error_recovery, block_description, block_count, io_id, status);

  PROCEND bap$write_tape;

MODEND bam$tape_block_manager_ring2;
*DECK DECK=BAM$TAPE_BLOCK_MANAGER_RING3 EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
*copy osd$default_pragmats
MODULE bam$tape_block_manager_ring3;
























  { This module provides buffered access to tape physical I/O for the ring 3 file access }
  { procedures which are the heart of basic access methods.  At  this  level, all I/O     }
  { is done in  units  of  tape blocks.  It is the responsibility of the ring 3 FAP to   }
  { map records into blocks. }

?? TITLE := 'Global constants and variables', EJECT ??

  { Global constants }

  CONST
    bac$max_ansi_label_length = 80, { Maximum length of an ANSI tape label }
    bac$reserved_pages = 20;        { Number of memory pages required in the working set limit beyond those }
                                    { required to contain the tape block buffer. }

  { Global types. }

  TYPE
    tape_block_access_mode = (open_access, read_access, write_access, non_data_transfer_access),

    tape_write_error = (no_write_error, write_error_last_block, write_error_previous_block),

    tape_write_completion = record
      end_of_tape_reflective_spot_hit: boolean,
      error_type: tape_write_error,
      failure_modes: amt$tape_failure_modes,
    recend;

  { Global variables. }

  { The following variable is global to avoid the need to make it a parameter on almost }
  { every procedure in the module.  Note, however, that the value must still be loaded }
  { at every external  entry point via a call to load_block_mgmt_descriptor_ptr to ensure }
  { that the correct pointer is used. }

  VAR
    bmd: [STATIC, oss$task_private] ^bat$tape_block_mgmt_descriptor := NIL;

  { The following variable, which is shared by all tasks in the job, is set to point to the block }
  {  management descriptor for each open of a tape file.  In this way another task in the same job }
  {  can locate the tables for the most recently opened tape and examine them. }

  VAR
    bav$tape_bmd_saved_for_debug: [STATIC, XDCL, oss$task_shared] ^bat$tape_block_mgmt_descriptor := NIL;

  { The following variables control various aspects of the operation of tape block management. }
  { These variables are defined and described in bam$tape_block_manager_ring1. }


*copyc bav$max_allowed_tape_block_size
*copy bav$max_indirect_tape_block
*copy bav$max_bytes_per_tape_io
*copy bav$force_direct_tape_io
*copy bav$use_assign_pages_for_tape

  { The following variable is a constant for initializing write_completion records }

  VAR
    normal_write_completion: [STATIC, READ, oss$job_paged_literal] tape_write_completion := [FALSE,
      no_write_error, $amt$tape_failure_modes []];

  VAR
    blank_tape_volume: [STATIC, READ, oss$job_paged_literal] rmt$volume_descriptor := [rmc$unspecified_vsn,
          rmc$unspecified_vsn];

?? PUSH (LISTEXT := ON) ??
?? TITLE := 'Procedure XREF decks', EJECT ??
*copyc amp$access_method
*copyc avp$configuration_administrator
*copyc avp$removable_media_operator
*copyc avp$system_displays
*copyc bap$await_tape_io_completion
*copyc bap$backspace_tape
*copyc bap$erase_tape
*copyc bap$get_tape_security_state_r1
*copyc bap$fetch_tape_capabilities
*copyc bap$fetch_tape_validation_r1
*copyc bap$forspace_tape
*copyc bap$get_tape_security_state_r1
*copyc bap$put_tape_security_state_r1
*copyc bap$read_tape
*copyc bap$rewind_tape
*copyc bap$store_tape_validation_r1
*copyc bap$write_tape
*copyc bap$write_tapemark
*copyc bap$validate_file_identifier
*copyc clp$convert_integer_to_string
*copyc clp$trimmed_string_size
*copyc cmp$get_element_name_via_lun
*copyc dmp$convert_sfid_to_lun
*copyc dmp$get_tape_volume_information
*copyc dmp$unload_remount_tape_volume
*copyc iop$backspace_tape_to_tapemark
*copyc iop$forspace_tape_to_tapemark
*copyc iop$get_position_of_tape_file
*copyc iop$locate_block
*copyc iop$tape_update_byte_counts
*copyc iop$update_block_count
*copyc ofp$format_operator_menu
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
*copyc osp$append_status_integer
*copyc mmp$advise_in
*copyc mmp$assign_pages
*copyc mme$condition_codes
*copyc mmp$check_if_pages_in_memory
*copyc mmp$create_segment
*copyc mmp$delete_segment
*copyc mmp$touch_all_pages
*copyc rmp$complete_tape_assignment
*copyc rmp$validate_tape_assignment
*copyc fmp$get_system_file_id
*copyc fmp$get_files_volume_info
*copyc jmp$get_job_attributes
*copyc i#move
?? TITLE := 'Type and Constant Declaration COPY decks', EJECT ??
*copyc amd$skip_declarations
*copyc amt$local_file_name
*copyc amt$max_block_length
*copyc amt$file_identifier
*copyc amt$working_storage_length
*copyc amt$tape_error_options
*copyc amt$tape_failure_modes
*copyc amd$operation_declarations
*copyc amd$skip_declarations
*copyc bae$tape_bm_error_codes
*copyc bai$tape_descriptor
*copyc bat$global_file_information
*copyc bat$tape_block
*copyc bat$tape_block_buffer_count
*copyc bat$tape_block_type
*copyc bat$tape_block_mgmt_descriptor
*copyc bat$tape_block_position
*copyc bat$tape_buffer_group_index
*copyc bat$tape_buffer_grp_descriptor
*copyc bat$tape_buffer_group_state
*copyc bat$tape_block_buffer_index
*copyc bat$tape_io_direction
*copyc bat$tape_fatal_recovery_modes
*copyc bat$tape_read_block_description
*copyc bac$max_tape_buffer_group_size
*copyc bat$tape_buffer_information
*copyc bat$tape_validation_state
*copyc cmv$logical_unit_table
*copyc cmt$element_name
*copyc dme$tape_errors
*copyc dmv$initialize_tape_volume
*copyc ioe$tape_io_conditions
*copyc iot$tape_block_id_area
*copyc iot$tape_position
*copyc mmt$rma_list
*copyc ofe$error_codes
*copyc osc$processor_defined_registers
*copyc osd$operating_system_exceptions
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc oss$task_shared
*copyc ost$caller_identifier
*copyc ost$page_size
*copyc ost$wait
*copyc osv$task_shared_heap
*copyc osp$verify_system_privilege
*copyc rmc$generic_error_recovery
*copyc rmc$loadpoint_error_recovery
*copyc rmc$write_error_recovery
?? POP ??
  VAR
    global_layer_number: [XREF] amt$fap_layer_number;


?? OLDTITLE ??
?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_advance_volume', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_advance_volume (
        file_id: amt$file_identifier;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    VAR
      call_block: amt$call_block,
      caller_id: ost$caller_identifier,
      current_volume: amt$volume_number,
      current_vsns: rmt$volume_descriptor,
      density: rmt$density,
      file_instance: ^bat$task_file_entry,
      label_type: amt$label_type,
      number_of_volumes: amt$volume_number,
      requested_volume_attributes: iot$requested_volume_attributes,
      tape_descriptor: ^bat$tape_descriptor,
      terminate_tape_volume: amt$terminate_tape_volume,
      volume_info: array [1 .. 1] of fmt$volume_info,
      volume_overflow_allowed: boolean,
      write_completion: tape_write_completion,
      write_ring: rmt$write_ring;

    #caller_id (caller_id);
    status.normal := TRUE;
    tape_failure_modes := $amt$tape_failure_modes [];
    write_completion := normal_write_completion;

    validate_call (file_id, caller_id.ring, non_data_transfer_access, 'BAP$TAPE_BM_ADVANCE_VOLUME',
          file_instance, bmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    tape_descriptor := bai$tape_descriptor (file_instance);

    IF bmd^.fatal_write_error THEN
      tape_failure_modes := bmd^.fatal_write_failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
        'Outstanding fatal write error in bap$tape_bm_advance_volume', status);
      RETURN;
    IFEND;

    finish_all_outstanding_io (write_completion, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    iop$tape_update_byte_counts (bmd^.sfid, bmd^.max_block_length, status);

    bmd^.write_hit_end_of_tape_reflector := bmd^.write_hit_end_of_tape_reflector OR write_completion.
          end_of_tape_reflective_spot_hit;

    IF write_completion.error_type <> no_write_error THEN
      bmd^.fatal_write_error := TRUE;
      bmd^.fatal_write_failure_modes := write_completion.failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
        'Finishing I/O in bap$tape_bm_advance_volume', status);
      tape_failure_modes := write_completion.failure_modes;
      RETURN;
    IFEND;

  /advance_the_volume/
    BEGIN

      volume_info[1].key := fmc$number_of_volumes;
      fmp$get_files_volume_info (file_instance^.local_file_name, volume_info, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE bmd^.io_direction OF
      = bac$iod_reading, bac$iod_indeterminate =
        IF tape_descriptor^.volume_number < volume_info[1].number_of_volumes THEN
          validate_tape_assignment (file_id, file_instance, bmd^.sfid,
              tape_descriptor^.file_label_type, {initial_assignment = } FALSE,
              tape_descriptor^.volume_number + 1 , status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_list_exhausted,
                ' ', status);
          RETURN;
        IFEND;
        { discard any data which has been read-ahead from the previous volume }
        reset_buffer_pointers;
      = bac$iod_writing =
        dmp$get_tape_volume_information (bmd^.sfid, number_of_volumes, current_volume, current_vsns,
              density, write_ring, requested_volume_attributes, volume_overflow_allowed, label_type,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        call_block.operation := amc$terminate_tape_volume;
        call_block.terminate_tape_volume := ^terminate_tape_volume;
        terminate_tape_volume.tape_density := density;
        terminate_tape_volume.terminating_volume_number := current_volume;
        terminate_tape_volume.terminating_volume := current_vsns;
        terminate_tape_volume.removable_media_location := requested_volume_attributes.
              removable_media_location;
        terminate_tape_volume.removable_media_group := requested_volume_attributes.
              removable_media_group;
        amp$access_method (file_id, call_block, global_layer_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF label_type <> amc$labelled THEN
          terminate_volume (write_completion, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          bmd^.write_hit_end_of_tape_reflector := bmd^.write_hit_end_of_tape_reflector OR
                write_completion.end_of_tape_reflective_spot_hit;
          IF write_completion.error_type <> no_write_error THEN
            bmd^.fatal_write_error := TRUE;
            bmd^.fatal_write_failure_modes := write_completion.failure_modes;
            tape_failure_modes := write_completion.failure_modes;
            osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
              'In bap$tape_bm_advance_volume', status);
            EXIT /advance_the_volume/;
          IFEND;
        IFEND;
        IF volume_overflow_allowed OR
            (tape_descriptor^.volume_number < volume_info[1].number_of_volumes) THEN
          validate_tape_assignment (file_id, file_instance, bmd^.sfid,
              tape_descriptor^.file_label_type, {initial_assignment = } FALSE,
              tape_descriptor^.volume_number + 1 , status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_list_exhausted,
                ' ', status);
          RETURN;
        IFEND;
        bmd^.write_hit_end_of_tape_reflector := FALSE;
      ELSE
        osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
          'illegal io_direction value in bap$tape_bm_advance_volume', status);
      CASEND;

    END /advance_the_volume/;

  PROCEND bap$tape_bm_advance_volume;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_align_position', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_align_position (file_id: amt$file_identifier;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      write_completion: tape_write_completion;

    #caller_id (caller_id);
    status.normal := TRUE;
    tape_failure_modes := $amt$tape_failure_modes [];

    validate_call (file_id, caller_id.ring, non_data_transfer_access, 'BAP$TAPE_BM_ALIGN_POSITION',
          file_instance, bmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF bmd^.fatal_write_error THEN
      tape_failure_modes := bmd^.fatal_write_failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
        'Outstanding fatal write error in bap$tape_bm_align_position', status);
      RETURN;
    IFEND;

  /perform_align_position/
    BEGIN

      align_physical_logical_position (write_completion, status);
      IF NOT status.normal THEN
        tape_failure_modes := write_completion.failure_modes;
        RETURN;
      IFEND;

      bmd^.write_hit_end_of_tape_reflector := bmd^.write_hit_end_of_tape_reflector OR
            write_completion.end_of_tape_reflective_spot_hit;

      IF write_completion.error_type <> no_write_error THEN
        bmd^.fatal_write_error := TRUE;
        bmd^.fatal_write_failure_modes := write_completion.failure_modes;
        osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
          'Fatal write error in bap$tape_bm_align_position', status);
        tape_failure_modes := write_completion.failure_modes;
        EXIT /perform_align_position/;
      IFEND;

      IF write_completion.end_of_tape_reflective_spot_hit THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$vol_end_operation_inhibited,
          'End of tape encountered in bap$tape_bm_align_position', status);
        EXIT /perform_align_position/;
      IFEND;

    END /perform_align_position/;

  PROCEND bap$tape_bm_align_position;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_close', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_close (file_id: amt$file_identifier;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    VAR
      access_status: ost$status,
      caller_id: ost$caller_identifier,
      call_block: amt$call_block,
      current_volume: amt$volume_number,
      current_vsns: rmt$volume_descriptor,
      delete_segment_status: ost$status,
      density: rmt$density,
      file_instance: ^bat$task_file_entry,
      i: bat$tape_buffer_group_index,
      finish_status: ost$status,
      finish_write_completion: tape_write_completion,
      label_type: amt$label_type,
      number_of_volumes: amt$volume_number,
      requested_volume_attributes: iot$requested_volume_attributes,
      terminate_tape_volume: amt$terminate_tape_volume,
      terminate_write_completion: tape_write_completion,
      tape_descriptor: ^bat$tape_descriptor,
      terminate_volume_status: ost$status,
      volume_overflow_allowed: boolean,
      write_ring: rmt$write_ring;

    #caller_id (caller_id);
    status.normal := TRUE;
    tape_failure_modes := $amt$tape_failure_modes [];

    access_status.normal := TRUE;
    delete_segment_status.normal := TRUE;
    terminate_volume_status.normal := TRUE;
    finish_status.normal := TRUE;
    finish_write_completion := normal_write_completion;
    terminate_write_completion := normal_write_completion;

    validate_call (file_id, caller_id.ring, non_data_transfer_access, 'BAP$TAPE_BM_CLOSE',
          file_instance, bmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    tape_descriptor := bai$tape_descriptor (file_instance);

    finish_all_outstanding_io (finish_write_completion, finish_status);

    IF bmd^.io_direction = bac$iod_writing THEN
      IF NOT bmd^.fatal_write_error THEN
        dmp$get_tape_volume_information (bmd^.sfid, number_of_volumes, current_volume, current_vsns,
              density, write_ring, requested_volume_attributes, volume_overflow_allowed, label_type,
              status);
        call_block.operation := amc$terminate_tape_volume;
        call_block.terminate_tape_volume := ^terminate_tape_volume;
        terminate_tape_volume.tape_density := density;
        terminate_tape_volume.terminating_volume_number := current_volume;
        terminate_tape_volume.terminating_volume := current_vsns;
        terminate_tape_volume.removable_media_location := requested_volume_attributes.
              removable_media_location;
        terminate_tape_volume.removable_media_group := requested_volume_attributes.
              removable_media_group;
        amp$access_method (file_id, call_block, global_layer_number, access_status);
        IF label_type <> amc$labelled THEN
          terminate_volume (terminate_write_completion, terminate_volume_status);
        IFEND;
      IFEND;
    IFEND;
    iop$tape_update_byte_counts (bmd^.sfid, bmd^.max_block_length, status);
    mmp$delete_segment (bmd^.buffer_segment, caller_id.ring, delete_segment_status);

    FREE bmd IN osv$task_shared_heap^;

    tape_descriptor^.block_management_descriptor := NIL;

    IF NOT access_status.normal THEN
      status := access_status;
    ELSEIF NOT terminate_volume_status.normal THEN
      IF (terminate_volume_status.condition = ioe$task_terminated_during_rec) THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
          'detected in bap$tape_bm_close', status);
      ELSE
        status := terminate_volume_status;
      IFEND;
    ELSEIF NOT delete_segment_status.normal THEN
      status := delete_segment_status;
    ELSEIF NOT finish_status.normal THEN
      IF (finish_status.condition = ioe$task_terminated_during_rec) THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
          'detected in bap$tape_bm_close', status);
      ELSE
        status := finish_status;
      IFEND;
    ELSEIF finish_write_completion.error_type <> no_write_error THEN
      tape_failure_modes := finish_write_completion.failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
        'detected in bap$tape_bm_close', status);
    ELSEIF terminate_write_completion.error_type <> no_write_error THEN
      tape_failure_modes := terminate_write_completion.failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
        'detected in bap$tape_bm_close', status);
    IFEND;

  PROCEND bap$tape_bm_close;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_erase_block', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_erase_block (file_id: amt$file_identifier;
        block_length: amt$max_block_length;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      write_completion: tape_write_completion;

    #caller_id (caller_id);
    status.normal := TRUE;
    tape_failure_modes := $amt$tape_failure_modes [];

    validate_call (file_id, caller_id.ring, write_access, 'BAP$TAPE_BM_ERASE_BLOCK', file_instance, bmd,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF bmd^.fatal_write_error THEN
      tape_failure_modes := bmd^.fatal_write_failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
        'Outstanding fatal write error in bap$tape_bm_erase_block', status);
      RETURN;
    IFEND;

    align_physical_logical_position (write_completion, status);
    IF NOT status.normal THEN
      tape_failure_modes := write_completion.failure_modes;
      RETURN;
    IFEND;

    bmd^.write_hit_end_of_tape_reflector := bmd^.write_hit_end_of_tape_reflector OR write_completion.
          end_of_tape_reflective_spot_hit;

    IF write_completion.error_type <> no_write_error THEN
      bmd^.fatal_write_error := TRUE;
      bmd^.fatal_write_failure_modes := write_completion.failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
        'Detected in bap$tape_bm_erase_block', status);
      tape_failure_modes := write_completion.failure_modes;
      RETURN;
    IFEND;

    IF write_completion.end_of_tape_reflective_spot_hit THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$vol_end_operation_inhibited,
        'bap$tape_bm_erase_block', status);
      RETURN;
    IFEND;

    bap$erase_tape (bmd^.sfid, block_length, {number_of_erases =} 0, bmd^.non_data_io_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    form_failure_modes (bmd^.non_data_io_status, tape_failure_modes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    bmd^.write_hit_end_of_tape_reflector := bmd^.write_hit_end_of_tape_reflector OR bmd^.non_data_io_status.
          end_of_tape;

    IF NOT bmd^.non_data_io_status.normal_completion THEN
      IF bmd^.non_data_io_status.completion_code = ioc$erase_limit_exceeded THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$cartridge_tape_erase_limit,
              'bap$tape_bm_erase_block', status);
      ELSEIF bmd^.non_data_io_status.completion_code = ioc$write_past_phys_eot THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$motion_past_phys_eot,
              'bap$tape_bm_erase_block', status);
        bmd^.io_direction := bac$iod_writing;
      ELSEIF bmd^.non_data_io_status.completion_code = ioc$no_write_ring THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$no_tape_write_ring,
              'bap$tape_bm_erase_block', status);
      ELSE
        osp$set_status_abnormal (bac$basic_access_id, bae$write_error_this_block, 'bap$tape_bm_erase_block',
              status);
        bmd^.io_direction := bac$iod_writing;
      IFEND;
    ELSE
      bmd^.io_direction := bac$iod_writing;
      IF bmd^.non_data_io_status.end_of_tape THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$vol_end_operation_completed,
          'bap$tape_bm_erase_block', status);
      IFEND;
    IFEND;

  PROCEND bap$tape_bm_erase_block;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_fetch_tables_ptr', EJECT ??
{  This procedure has been disabled.  It was initially created for debugging
{  and is not longer used.  The contents are retained if it is ever needed
{  in the future.
{
{ PROCEDURE [XDCL, #GATE] bap$tape_bm_fetch_tables_ptr (VAR segment: integer;
{   VAR offset: integer;
{   VAR status: ost$status);
{
{   status.normal := TRUE;
{
{   segment := #segment (bav$tape_bmd_saved_for_debug);
{   offset := #offset (bav$tape_bmd_saved_for_debug);
{
{ PROCEND bap$tape_bm_fetch_tables_ptr;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_flush', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_flush (file_id: amt$file_identifier;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      write_completion: tape_write_completion;

    #caller_id (caller_id);
    status.normal := TRUE;
    tape_failure_modes := $amt$tape_failure_modes [];

    validate_call (file_id, caller_id.ring, non_data_transfer_access, 'BAP$TAPE_BM_FLUSH',
          file_instance, bmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF bmd^.fatal_write_error THEN
      tape_failure_modes := bmd^.fatal_write_failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
        'Outstanding fatal write error in bap$tape_bm_flush', status);
      RETURN;
    IFEND;

    IF bmd^.write_hit_end_of_tape_reflector THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$vol_end_operation_inhibited,
        'Outstanding EOT in bap$tape_bm_flush', status);
    IFEND;

    IF bmd^.io_direction = bac$iod_writing THEN

    /perform_flush/
      BEGIN

        align_physical_logical_position (write_completion, status);
        IF NOT status.normal THEN
          tape_failure_modes := write_completion.failure_modes;
          RETURN;
        IFEND;

        IF write_completion.error_type <> no_write_error THEN
          bmd^.fatal_write_error := TRUE;
          bmd^.fatal_write_failure_modes := write_completion.failure_modes;
          osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
            'Fatal write error in bap$tape_bm_flush', status);
          tape_failure_modes := write_completion.failure_modes;
          EXIT /perform_flush/;
        IFEND;

        IF write_completion.end_of_tape_reflective_spot_hit THEN
          osp$set_status_abnormal (bac$basic_access_id, bae$vol_end_operation_inhibited,
            'End of tape encountered in bap$tape_bm_flush', status);
          EXIT /perform_flush/;
        IFEND;

      END /perform_flush/;

    IFEND;

  PROCEND bap$tape_bm_flush;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_read_label', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_read_label (file_id: amt$file_identifier;
        label_ptr: ^bat$tape_block;
        label_area_length: amt$max_block_length;
        system_media_recovery: boolean;
    VAR actual_block_length: amt$transfer_count;
    VAR volume_position: amt$volume_position;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    TYPE
      word_aligned_tape_block = record
        tape_block: ALIGNED [0 MOD 8] array [1 .. * ] of cell,
      recend;

    TYPE
      word_aligned_transfer_count = record
        tape_transfer_count: ALIGNED [0 MOD 8] iot$tape_transfer_count,
      recend;

    CONST
      read_buffer_length = 4128;

    VAR
      aligned_buffer: ^word_aligned_tape_block, { <-- must be aligned on a word boundary }
      aligned_transfer_count: ^word_aligned_transfer_count, { <-- must be aligned on a word boundary }
      attempt_close: boolean,
      attempt_recovery: boolean,
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      io_id: iot$io_id,
      read_description: iot$read_tape_description,
      transfer_count: amt$transfer_count;

    #caller_id (caller_id);
    status.normal := TRUE;
    actual_block_length := 0;
    tape_failure_modes := $amt$tape_failure_modes [];

    validate_call (file_id, caller_id.ring, non_data_transfer_access, 'BAP$TAPE_BM_READ_LABEL',
        file_instance, bmd,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF label_area_length < bac$max_ansi_label_length THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
        'Insuffient label area length passed to bap$tape_bm_read_label', status);
      RETURN;
    IFEND;

    IF bmd^.fatal_write_error THEN
      tape_failure_modes := bmd^.fatal_write_failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
        'Outstanding fatal write error in bap$tape_bm_read_label', status);
      RETURN;
    IFEND;

    { Read the label into a word aligned buffer. }

    PUSH aligned_buffer: [1 .. read_buffer_length];
    PUSH aligned_transfer_count;

    read_description [1].buffer_area := ^aligned_buffer^.tape_block;
    read_description [1].block_transfer_length := ^aligned_transfer_count^.tape_transfer_count;
    read_description [1].block_transfer_length^.length := 0;

/read_label_recovery/
    WHILE TRUE DO
      bap$read_tape (bmd^.sfid, read_buffer_length, ^read_description, {block_count=} 1,
            {system_media_recovery=} TRUE, io_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      bap$await_tape_io_completion (bmd^.sfid, io_id, bmd^.non_data_io_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT bmd^.non_data_io_status.normal_completion THEN
        IF bmd^.non_data_io_status.completion_code = ioc$tapemark_read THEN
          status.normal := TRUE;
          volume_position := amc$after_tapemark;
        ELSE
          form_failure_modes (bmd^.non_data_io_status, tape_failure_modes, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF bmd^.non_data_io_status.completion_code = ioc$not_capable_of_density THEN
            osp$set_status_abnormal (bac$basic_access_id, bae$density_mismatch,
                  'Density mismatch in bap$tape_bm_read_label', status);
          ELSEIF bmd^.non_data_io_status.completion_code = ioc$read_past_phys_eot THEN
            osp$set_status_abnormal (bac$basic_access_id, bae$motion_past_phys_eot,
                  'Read past physical EOT in bap$tape_bm_read_label', status);
          ELSEIF bmd^.non_data_io_status.completion_code = ioc$blank_tape THEN
            osp$set_status_abnormal (bac$basic_access_id, bae$read_error_this_block,
                  'Blank tape in bap$tape_bm_read_label', status);
          ELSEIF bmd^.non_data_io_status.completion_code = ioc$alert_condition_encountered THEN
            volume_position := amc$after_data_block;
            i#move (aligned_buffer, label_ptr, label_area_length);
          ELSE
            menu_tape_fatal_error_recovery (bac$tfrm_fatal_read, tape_failure_modes, attempt_recovery,
                  attempt_close, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF attempt_recovery THEN
              CYCLE /read_label_recovery/;
            IFEND;
            osp$set_status_abnormal (bac$basic_access_id, bae$read_error_this_block, 'bap$tape_bm_read_label',
                  status);
          IFEND;
          RETURN;
        IFEND;
      ELSE
        actual_block_length := read_description [1].block_transfer_length^.length;
        IF label_area_length < read_description [1].block_transfer_length^.length THEN
          transfer_count := label_area_length;
        ELSE
          transfer_count := read_description [1].block_transfer_length^.length;
        IFEND;
        volume_position := amc$after_data_block;
        i#move (aligned_buffer, label_ptr, transfer_count);
      IFEND;
      tape_failure_modes := $amt$tape_failure_modes [];
      RETURN;
    WHILEND /read_label_recovery/;

  PROCEND bap$tape_bm_read_label;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_open', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_open (file_id: amt$file_identifier;
        max_block_length: amt$max_block_length;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      tape_descriptor: ^bat$tape_descriptor,
      sfid: dmt$system_file_id,
      write_ring,
      direct_io: boolean,
      i,
      buffer_group_count: bat$tape_buffer_group_index,
      j,
      buffer_group_size: integer,
      segment_attributes: array [1 .. 1] of mmt$attribute_descriptor,
      buffer_segment: mmt$segment_pointer,
      max_supported_block_length: amt$max_block_length,
      max_blocks_per_physical_call: iot$tape_block_count,
      rma_list_entries_required: integer,
      page_size: ost$page_size,
      job_attributes: ^jmt$job_attribute_results,
      bytes_used,
      unused_bytes_in_last_page: integer,
      buffer_allocation_size: integer,
      allocated_block_buffer: ^array [1 .. * ] of cell,
      buffer_group_space: ^array [1 .. bac$max_buffer_group_size] of cell,
      buffer_group_p: ^cell,
      unused_space: ^array [1 .. * ] of cell,
      volume_info: array [1 .. 1] of fmt$volume_info,
      ignore_status: ost$status;

    #caller_id (caller_id);
    status.normal := TRUE;

    validate_call (file_id, caller_id.ring, open_access, 'BAP$TAPE_BM_OPEN', file_instance, bmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    tape_descriptor := bai$tape_descriptor (file_instance);

    IF bmd <> NIL THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$multiple_open_of_tape,
        'multiple calls to bam$tape_bm_open', status);
      RETURN;
    IFEND;

    fmp$get_system_file_id (file_instance^.local_file_name, sfid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF max_block_length > bav$max_allowed_tape_block_size THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$cannot_lock_tape_pages,
        'Max_block_length exceeds bav$max_allowed_tape_block_size.  Max value is', status);
      osp$append_status_integer (' ', bav$max_allowed_tape_block_size, 10, TRUE, status);
      RETURN;
    IFEND;

    page_size := 512 * (128 - #read_register (osc$pr_page_size_mask));

    { Keep MAXBL from being larger than the amount of memory we can sucessfully lock down. }
    rma_list_entries_required := ((max_block_length + page_size - 1) DIV page_size) + 1;
    IF rma_list_entries_required > (page_size DIV #SIZE (mmt$rma_list_entry)) THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$cannot_lock_tape_pages,
        'Max_block_length too large for page size in use.  Page size is', status);
      osp$append_status_integer (' ', page_size, 10, TRUE, status);
      RETURN;
    IFEND;

    { Prevent open when maxbl is within 20 pages of the job working set limit }
    PUSH job_attributes: [1..1];
    job_attributes^ [1].key := jmc$maximum_working_set;
    jmp$get_job_attributes (job_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (max_block_length DIV page_size) > (job_attributes^ [1].maximum_working_set - bac$reserved_pages)
          THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$maxbl_exceeds_ws_limit, '', status);
      RETURN;
    IFEND;

    IF NOT tape_descriptor^.initial_volume.assigned THEN
      validate_tape_assignment (file_id, file_instance, sfid,
          tape_descriptor^.file_label_type, {initial_assignment = } TRUE,
          {next_volume = } 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      tape_descriptor^.initial_volume.assigned := TRUE;
    IFEND;

    volume_info [1].key := fmc$write_ring;
    fmp$get_files_volume_info (file_instance^.local_file_name, volume_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    write_ring := volume_info [1].write_ring = rmc$write_ring;

    bap$fetch_tape_capabilities (sfid, max_supported_block_length, max_blocks_per_physical_call, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF max_block_length > max_supported_block_length THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_driver_not_capable, ' ', status);
      osp$append_status_integer (osc$status_parameter_delimiter, max_supported_block_length, 10, TRUE,
            status);
      RETURN;
    IFEND;

    IF (max_block_length > bav$max_indirect_tape_block) OR bav$force_direct_tape_io THEN
      direct_io := TRUE;
      buffer_group_count := 1;
      buffer_group_size := 1;
    ELSE
      direct_io := FALSE;
      buffer_group_size := bav$max_bytes_per_tape_io DIV max_block_length;
      buffer_group_count := ioc$max_multiple_tape_requests;
      IF buffer_group_size < 1 THEN
        buffer_group_size := 1;
      IFEND;
      IF buffer_group_size > max_blocks_per_physical_call THEN
        buffer_group_size := max_blocks_per_physical_call;
      IFEND;
    IFEND;

    ALLOCATE bmd IN osv$task_shared_heap^;
    bav$tape_bmd_saved_for_debug := bmd;

    segment_attributes [1].keyword := mmc$kw_segment_access_control;
    segment_attributes [1].access_control.cache_bypass := TRUE;
    segment_attributes [1].access_control.execute_privilege := osc$non_executable;
    segment_attributes [1].access_control.read_privilege := osc$read_uncontrolled;
    segment_attributes [1].access_control.write_privilege := osc$write_uncontrolled;
    mmp$create_segment (^segment_attributes, mmc$sequence_pointer, caller_id.ring, buffer_segment, status);
    IF NOT status.normal THEN
      FREE bmd IN osv$task_shared_heap^;
      RETURN;
    IFEND;

    bmd^.io_direction := bac$iod_indeterminate;
    bmd^.sfid := sfid;
    bmd^.tape_has_write_ring := write_ring;
    bmd^.fatal_write_error := FALSE;
    bmd^.fatal_write_failure_modes := $amt$tape_failure_modes [];
    bmd^.write_hit_end_of_tape_reflector := FALSE;
    bmd^.direct_io := direct_io;
    bmd^.inhibit_read_ahead := FALSE;
    bmd^.max_block_length := max_block_length;
    bmd^.max_blocks_per_physical_call := max_blocks_per_physical_call;
    bmd^.buffer_segment := buffer_segment;
    bmd^.buffer_groups_in_use := buffer_group_count;
    bmd^.buffer_group_size := buffer_group_size;

  /allocate_buffer_groups/
    FOR i := 1 TO buffer_group_count DO
      NEXT buffer_group_space IN buffer_segment.seq_pointer;
      buffer_group_p := buffer_group_space;
      bmd^.buffer_group [i] := buffer_group_p;
      bmd^.buffer_group [i]^.group_state := bac$group_empty;
    FOREND /allocate_buffer_groups/;

    bytes_used := buffer_group_count * bac$max_buffer_group_size;
    unused_bytes_in_last_page := page_size - ((bytes_used - 1) MOD page_size) - 1;
    IF unused_bytes_in_last_page > 0 THEN
      NEXT unused_space: [1 .. unused_bytes_in_last_page] IN buffer_segment.seq_pointer;
    IFEND;

    buffer_allocation_size := ((max_block_length + 7) DIV 8) * 8; { Round up to an even word }

  /initialize_buffer_groups/
    FOR i := 1 TO buffer_group_count DO

    /allocate_block_buffers/
      FOR j := 1 TO buffer_group_size DO
        NEXT allocated_block_buffer: [1 .. buffer_allocation_size] IN buffer_segment.seq_pointer;
        bmd^.buffer_group [i]^.block_buffer [j].block_buffer := allocated_block_buffer;
        bmd^.buffer_group [i]^.read_description [j].buffer_area := allocated_block_buffer;
        bmd^.buffer_group [i]^.read_description [j].block_transfer_length := ^bmd^.buffer_group [i]^.
              block_buffer [j].block_length;
        bmd^.buffer_group [i]^.write_description [j].buffer_area := allocated_block_buffer;
        bmd^.buffer_group [i]^.write_description [j].transfer_length := 0;
      FOREND /allocate_block_buffers/;

      bytes_used := buffer_group_size * buffer_allocation_size;
      unused_bytes_in_last_page := page_size - ((bytes_used - 1) MOD page_size) - 1;
      IF unused_bytes_in_last_page > 0 THEN
        NEXT unused_space: [1 .. unused_bytes_in_last_page] IN buffer_segment.seq_pointer;
      IFEND;

    FOREND /initialize_buffer_groups/;
    reset_buffer_pointers;

    { All set up -- mark file as open (as far as block mangement is concerned) }

    IF tape_descriptor^.block_management_descriptor = NIL THEN
      tape_descriptor^.block_management_descriptor := bmd;
    ELSE
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
            'Attempt to overstore the block management descriptor pointer', status);
    IFEND;

  PROCEND bap$tape_bm_open;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_read_next_block', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_read_next_block (file_id: amt$file_identifier;
        operation: amt$fap_operation;
        volunteered_buffer_area: ^bat$tape_block;
        volunteered_buffer_length: amt$working_storage_length;
        system_media_recovery: boolean;
    VAR block_ptr: ^bat$tape_block;
    VAR block_type: bat$tape_block_type;
    VAR block_length: amt$max_block_length;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      ignore_write_completion: tape_write_completion,
      buffer_information: ^bat$tape_buffer_information,
      direct_io_length_to_read: amt$working_storage_length,
      byte_to_write_into_buffer: [STATIC, oss$job_paged_literal, READ] 0 .. 0ff(16) := 0;

    #caller_id (caller_id);
    status.normal := TRUE;
    tape_failure_modes := $amt$tape_failure_modes [];

    IF (operation = amc$get_label_req) OR (operation = amc$skip_req) THEN
      validate_call (file_id, caller_id.ring, non_data_transfer_access, 'BAP$TAPE_BM_READ_NEXT_BLOCK',
            file_instance, bmd, status);
    ELSE
      validate_call (file_id, caller_id.ring, read_access, 'BAP$TAPE_BM_READ_NEXT_BLOCK', file_instance, bmd,
            status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF bmd^.io_direction = bac$iod_writing THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$input_after_output,
        'Call to bap$tape_bm_read while writing tape', status);
      RETURN;
    IFEND;

    bmd^.io_direction := bac$iod_reading;
    bmd^.system_media_recovery := system_media_recovery;

/perform_read/
    BEGIN

      IF bmd^.direct_io THEN

      /direct_io_read_recovery_loop/
        WHILE TRUE DO
          IF bmd^.buffer_group [1]^.group_state = bac$group_empty THEN
            { Ensure buffer is aligned so that the Peripheral Processor can address it }
            IF (volunteered_buffer_area <> NIL) AND ((#OFFSET (volunteered_buffer_area) MOD 8) = 0) AND
                  ((volunteered_buffer_length MOD 8) = 0) THEN
              block_ptr := volunteered_buffer_area;
              IF volunteered_buffer_length <= bmd^.max_block_length THEN
                direct_io_length_to_read := volunteered_buffer_length;
              ELSE
                direct_io_length_to_read := bmd^.max_block_length;
              IFEND;
              { write into the buffer to ensure that ring attributes allow writing }
              i#move (^byte_to_write_into_buffer, block_ptr, 1);
              i#move (^byte_to_write_into_buffer, ^block_ptr^ [direct_io_length_to_read], 1);
              initiate_read (1, block_ptr, direct_io_length_to_read, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            ELSE
              block_ptr := bmd^.buffer_group [1]^.block_buffer [1].block_buffer;
              initiate_read (1, block_ptr, bmd^.max_block_length, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          ELSE { data already buffered from tapemark check }
            block_ptr := bmd^.buffer_group [1]^.block_buffer [1].block_buffer;
          IFEND;
          await_data_io_completion (bmd^.logical_position, ignore_write_completion, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          bmd^.buffer_group [1]^.group_state := bac$group_empty;
          buffer_information := ^bmd^.buffer_group [1]^.block_buffer [1];
          IF (buffer_information^.block_type <> bac$good_data_block) AND {}
                (buffer_information^.block_type <> bac$tapemark) AND (system_media_recovery) AND
                (buffer_information^.attempt_recovery) THEN
            CYCLE /direct_io_read_recovery_loop/
          ELSE
            tape_failure_modes := $amt$tape_failure_modes [];
            EXIT /direct_io_read_recovery_loop/;
          IFEND;
        WHILEND /direct_io_read_recovery_loop/;

      ELSE { normal, buffered I/O }

      /buffered_io_read_recovery_loop/
        WHILE TRUE DO
          advance_read_position (buffer_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF (buffer_information^.block_type <> bac$good_data_block) AND {}
                (buffer_information^.block_type <> bac$tapemark) AND system_media_recovery THEN

            IF (NOT buffer_information^.system_media_recovery_used) AND
                  (amc$tfm_data_parity_error IN buffer_information^.failure_modes) THEN

{ Force a re-read of the block if User Recovery for this block.

              reposition_back_one_block (tape_failure_modes, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              CYCLE /buffered_io_read_recovery_loop/;

            ELSEIF (buffer_information^.system_media_recovery_used) AND
                   (buffer_information^.attempt_recovery) THEN

{ Attempt recovery if operator chose that option.

              CYCLE /buffered_io_read_recovery_loop/;

            IFEND;

            EXIT /buffered_io_read_recovery_loop/;

          IFEND;

          EXIT /buffered_io_read_recovery_loop/;

        WHILEND /buffered_io_read_recovery_loop/;

        block_ptr := buffer_information^.block_buffer;

      IFEND;

      block_type := buffer_information^.block_type;
      CASE block_type OF
      = bac$good_data_block =
        block_length := buffer_information^.block_length.length;
        tape_failure_modes := $amt$tape_failure_modes [];
      = bac$error_data_block =
        block_length := buffer_information^.block_length.length;
        tape_failure_modes := buffer_information^.failure_modes;
      = bac$error_without_data, bac$density_mismatch, bac$read_past_phys_eot =
        tape_failure_modes := buffer_information^.failure_modes;
        block_ptr := NIL;
      = bac$tapemark =
        tape_failure_modes := $amt$tape_failure_modes [];
        block_ptr := NIL;
      ELSE
        osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
              'Illegal block type in bap$tape_bm_read_next_block', status);
        RETURN;
      CASEND;

      IF buffer_information^.block_truncated THEN
        IF buffer_information^.block_length.length < bmd^.max_block_length THEN
          osp$set_status_abnormal (bac$basic_access_id, bae$block_truncated,
            'block truncated in bam$tape_bm_read_next_block', status);
        ELSE
          osp$set_status_abnormal (bac$basic_access_id, bae$block_larger_than_maxbl,
            'block exceeds MAXBL in bam$tape_bm_read_next_block', status);
        IFEND;
      IFEND;

    END /perform_read/;

  PROCEND bap$tape_bm_read_next_block;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_read_to_write', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_read_to_write (file_id: amt$file_identifier;
        read_block_buffer: ^bat$tape_block;
    VAR write_block_buffer: ^bat$tape_block;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      ignore_write_completion: tape_write_completion,
      position: bat$tape_block_position;

    #caller_id (caller_id);
    status.normal := TRUE;
    tape_failure_modes := $amt$tape_failure_modes [];
    write_block_buffer := NIL;

    validate_call (file_id, caller_id.ring, write_access, 'BAP$TAPE_BM_READ_TO_WRITE',
          file_instance, bmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF bmd^.buffer_reserved THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
            'Write_buffer_reserved in bap$tape_bm_read_to_write', status);
      RETURN;
    IFEND;

    IF bmd^.io_direction = bac$iod_reading THEN

{   Save block_position of last block taken by FAP.

      IF NOT bmd^.direct_io THEN
        IF (bmd^.logical_position.buffer_index = 1) THEN
          IF bmd^.logical_position.buffer_group = 1 THEN
            form_tape_block_position (position, bmd^.buffer_groups_in_use,
                  bmd^.buffer_group_size);
          ELSE
            form_tape_block_position (position, bmd^.logical_position.buffer_group - 1,
                  bmd^.buffer_group_size);
          IFEND;
        ELSE
          form_tape_block_position (position, bmd^.logical_position.buffer_group,
                bmd^.logical_position.buffer_index - 1);
        IFEND;
      ELSE
        form_tape_block_position (position, 1, 1);
      IFEND;

      IF bmd^.buffer_group [position.buffer_group]^.block_buffer [position.
            buffer_index].block_type <> bac$good_data_block THEN
        RETURN;
      IFEND;

      align_physical_logical_position (ignore_write_completion, status);
      IF NOT status.normal THEN
        tape_failure_modes := ignore_write_completion.failure_modes;
        RETURN;
      IFEND;
      reset_buffer_pointers;
    ELSE
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
            'bap$tape_bm_read_to_write called and io direction is not read', status);
      RETURN;
    IFEND;

    bap$backspace_tape (bmd^.sfid, 1, {use_locate_block} FALSE, bmd^.non_data_io_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT bmd^.non_data_io_status.normal_completion THEN
      form_failure_modes (bmd^.non_data_io_status, tape_failure_modes, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
            'bam$tape_block_manager_ring3 - bap$tape_bm_read_to_write', status);
      RETURN;
    IFEND;

    IF bmd^.direct_io THEN
      IF (read_block_buffer <> bmd^.buffer_group [1]^.block_buffer [1].block_buffer) THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
              'Invalid read_block_buffer for direct io in bap$tape_bm_read_to_write', status);
        RETURN;
      IFEND;
      write_block_buffer := read_block_buffer;

    ELSE {buffered I/O}

{   Verify last read buffer address

      IF (read_block_buffer <> bmd^.buffer_group [position.buffer_group]^.
            block_buffer [position.buffer_index].block_buffer) THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
              'Incorrect read_block_buffer in bap$tape_bm_read_to_write', status);
        RETURN;
      IFEND;

      write_block_buffer := bmd^.buffer_group [bmd^.logical_position.buffer_group]^.
            block_buffer [bmd^.logical_position.buffer_index].block_buffer;

      IF NOT (read_block_buffer = write_block_buffer) THEN
        i#move (read_block_buffer, write_block_buffer, bmd^.buffer_group [position.
              buffer_group]^.block_buffer [position.buffer_index].block_length.length);
      IFEND;

    IFEND;

    bmd^.io_direction := bac$iod_writing;

    bmd^.buffer_reserved := TRUE;

  PROCEND bap$tape_bm_read_to_write;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_reserve_blk_buffer', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_reserve_blk_buffer (file_id: amt$file_identifier;
    VAR block_buffer_ptr: ^bat$tape_block;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      ignore_write_completion: tape_write_completion,
      reserved_position: bat$tape_block_position,
      write_completion: tape_write_completion;

    #caller_id (caller_id);
    status.normal := TRUE;
    tape_failure_modes := $amt$tape_failure_modes [];

    validate_call (file_id, caller_id.ring, write_access, 'BAP$TAPE_BM_RESERVE_BLK_BUFFER',
          file_instance, bmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF bmd^.fatal_write_error THEN
      tape_failure_modes := bmd^.fatal_write_failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
        'Outstanding fatal write error in bap$tape_bm_reserve_blk_buffer', status);
      RETURN;
    IFEND;

    IF bmd^.buffer_reserved THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$too_many_reserved_buffers, ' ', status);
      RETURN;
    IFEND;

    IF bmd^.io_direction = bac$iod_reading THEN
      align_physical_logical_position (ignore_write_completion, status);
      IF NOT status.normal THEN
        tape_failure_modes := ignore_write_completion.failure_modes;
        RETURN;
      IFEND;
      reset_buffer_pointers;
    IFEND;
    bmd^.io_direction := bac$iod_writing;

    ensure_write_buffer_available (write_completion, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    bmd^.write_hit_end_of_tape_reflector := bmd^.write_hit_end_of_tape_reflector OR write_completion.
          end_of_tape_reflective_spot_hit;

    IF write_completion.error_type <> no_write_error THEN
      bmd^.fatal_write_error := TRUE;
      bmd^.fatal_write_failure_modes := write_completion.failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
        'Write error in bap$tape_bm_reserve_block_buffer', status);
      tape_failure_modes := write_completion.failure_modes;
      RETURN;
    IFEND;
    IF write_completion.end_of_tape_reflective_spot_hit THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$vol_end_operation_inhibited,
        'End of tape in bap$tape_bm_reserve_block_buffer', status);
      RETURN;
    IFEND;

    block_buffer_ptr := bmd^.buffer_group [bmd^.logical_position.buffer_group]^.block_buffer [bmd^.
          logical_position.buffer_index].block_buffer;

    bmd^.buffer_reserved := TRUE;

  PROCEND bap$tape_bm_reserve_blk_buffer;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_rewind', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_rewind (file_id: amt$file_identifier;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    VAR
      attempt_close: boolean,
      attempt_recovery: boolean,
      caller_id: ost$caller_identifier,
      call_block: amt$call_block,
      current_volume: amt$volume_number,
      current_vsns: rmt$volume_descriptor,
      density: rmt$density,
      file_instance: ^bat$task_file_entry,
      label_type: amt$label_type,
      number_of_volumes: amt$volume_number,
      requested_volume_attributes: iot$requested_volume_attributes,
      tape_descriptor: ^bat$tape_descriptor,
      terminate_tape_volume: amt$terminate_tape_volume,
      write_completion: tape_write_completion,
      write_ring: rmt$write_ring,
      volume_overflow_allowed: boolean,
      ignore_write_completion: tape_write_completion;

    #caller_id (caller_id);
    status.normal := TRUE;
    tape_failure_modes := $amt$tape_failure_modes [];

    validate_call (file_id, caller_id.ring, non_data_transfer_access, 'BAP$TAPE_BM_REWIND', file_instance,
          bmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    tape_descriptor := bai$tape_descriptor (file_instance);

  /rewind_tape/
    BEGIN

      IF bmd^.io_direction = bac$iod_writing THEN
        IF NOT bmd^.fatal_write_error THEN
          align_physical_logical_position (write_completion, status);
          IF NOT status.normal THEN
            tape_failure_modes := write_completion.failure_modes;
            RETURN;
          IFEND;
          bmd^.write_hit_end_of_tape_reflector := bmd^.write_hit_end_of_tape_reflector OR write_completion.
                end_of_tape_reflective_spot_hit;
          IF write_completion.error_type <> no_write_error THEN
            bmd^.fatal_write_error := TRUE;
            bmd^.fatal_write_failure_modes := write_completion.failure_modes;
            osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
              'Fatal write error in bap$tape_bm_rewind', status);
            tape_failure_modes := write_completion.failure_modes;
            EXIT /rewind_tape/;
          IFEND;
          IF write_completion.end_of_tape_reflective_spot_hit THEN
            osp$set_status_abnormal (bac$basic_access_id, bae$vol_end_operation_inhibited,
              'End of reel in BAP$TAPE_BM_REWIND', status);
            EXIT /rewind_tape/;
          IFEND;
          dmp$get_tape_volume_information (bmd^.sfid, number_of_volumes, current_volume, current_vsns,
                density, write_ring, requested_volume_attributes, volume_overflow_allowed, label_type,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          call_block.operation := amc$terminate_tape_volume;
          call_block.terminate_tape_volume := ^terminate_tape_volume;
          terminate_tape_volume.tape_density := density;
          terminate_tape_volume.terminating_volume_number := current_volume;
          terminate_tape_volume.terminating_volume := current_vsns;
          terminate_tape_volume.removable_media_location := requested_volume_attributes.
                removable_media_location;
          terminate_tape_volume.removable_media_group := requested_volume_attributes.
                removable_media_group;
          amp$access_method (file_id, call_block, global_layer_number, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF label_type <> amc$labelled THEN
            terminate_volume (write_completion, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF write_completion.error_type <> no_write_error THEN
              osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
                'In bap$tape_bm_rewind', status);
              bmd^.fatal_write_error := TRUE;
              bmd^.fatal_write_failure_modes := write_completion.failure_modes;
              tape_failure_modes := write_completion.failure_modes;
              EXIT /rewind_tape/;
            IFEND;
          IFEND;
        IFEND; { fatal write error }
        bmd^.fatal_write_error := FALSE;
        bmd^.write_hit_end_of_tape_reflector := FALSE;
      ELSE { reading or indeterminate I/O    direction }
        finish_all_outstanding_io (ignore_write_completion, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

{ Do not issue rewind if volume_number is not 1.  This is done since the
{ tape is going to be unloaded anyway when dmp$reset_tape_volume is called.

      IF tape_descriptor^.volume_number = 1 THEN

      /fatal_rewind_loop/
        WHILE TRUE DO
          bap$rewind_tape (bmd^.sfid, bmd^.non_data_io_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF NOT bmd^.non_data_io_status.normal_completion THEN
            form_failure_modes (bmd^.non_data_io_status, tape_failure_modes, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            menu_tape_fatal_error_recovery (bac$tfrm_fatal_rewind, tape_failure_modes,
                  attempt_recovery, attempt_close, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

{ Cycle to retry rewind if operator chose response of 1 (attempt_recovery).

            IF attempt_recovery THEN
              CYCLE /fatal_rewind_loop/;
            IFEND;

            osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
                  'Uncertain tape position in bap$tape_bm_rewind', status);
            EXIT /rewind_tape/;
          IFEND;
          tape_failure_modes := $amt$tape_failure_modes [];
          EXIT /fatal_rewind_loop/;
        WHILEND /fatal_rewind_loop/;

      IFEND;

      IF tape_descriptor^.volume_number > 1 THEN
        iop$tape_update_byte_counts (bmd^.sfid, bmd^.max_block_length, status);
        validate_tape_assignment (file_id, file_instance, bmd^.sfid,
            tape_descriptor^.file_label_type, {initial_assignment = } FALSE,
            {next_volume = } 1, status);
        IF NOT status.normal THEN
          IF (status.condition = dme$operator_stop) OR (status.condition = dme$termination_condition) THEN
            tape_descriptor^.volume_number := 1;
            tape_descriptor^.initial_volume.assigned := FALSE;
          IFEND;
          RETURN;
        IFEND;
      IFEND;

      reset_buffer_pointers;

      bmd^.io_direction := bac$iod_indeterminate;

    END /rewind_tape/;

  PROCEND bap$tape_bm_rewind;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_skip_blocks', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_skip_blocks (file_id: amt$file_identifier;
        direction: amt$skip_direction;
        count: amt$skip_count;
    VAR residual_skip_count: amt$skip_count;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    VAR
      attempt_close: boolean,
      attempt_recovery: boolean,
      block_found: boolean,
      buffer_information: ^bat$tape_buffer_information,
      blocks_in_this_skip: amt$skip_count,
      blocks_remaining_to_skip: amt$skip_count,
      caller_id: ost$caller_identifier,
      call_block: amt$call_block,
      current_volume: amt$volume_number,
      current_vsns: rmt$volume_descriptor,
      density: rmt$density,
      file_instance: ^bat$task_file_entry,
      label_type: amt$label_type,
      number_of_volumes: amt$volume_number,
      requested_volume_attributes: iot$requested_volume_attributes,
      terminate_tape_volume: amt$terminate_tape_volume,
      volume_overflow_allowed: boolean,
      write_completion: tape_write_completion,
      write_ring: rmt$write_ring;

    #caller_id (caller_id);
    status.normal := TRUE;
    tape_failure_modes := $amt$tape_failure_modes [];

    validate_call (file_id, caller_id.ring, non_data_transfer_access, 'BAP$TAPE_BM_SKIP_BLOCKS',
          file_instance, bmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    blocks_remaining_to_skip := count;

    CASE direction OF
    = amc$forward =

    /skip_forward/
      BEGIN
        IF count > 0 THEN
          IF bmd^.io_direction = bac$iod_writing THEN
            osp$set_status_abnormal (bac$basic_access_id, bae$input_after_output,
              'Skip forward after write in bap$tape_bm_skip_blocks', status);
            RETURN;
          IFEND;
          bmd^.io_direction := bac$iod_reading;
          find_buffered_read_data_block (block_found, buffer_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        /consume_buffered_data/
          WHILE block_found DO
            IF buffer_information^.block_type = bac$tapemark THEN
              EXIT /skip_forward/;
            IFEND;
            blocks_remaining_to_skip := blocks_remaining_to_skip - 1;
            IF blocks_remaining_to_skip = 0 THEN
              EXIT /skip_forward/;
            IFEND;
            find_buffered_read_data_block (block_found, buffer_information, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          WHILEND /consume_buffered_data/;
          reset_buffer_pointers;

        /skip_remaining_blocks/
          WHILE blocks_remaining_to_skip > 0 DO
            IF blocks_remaining_to_skip <= bmd^.max_blocks_per_physical_call THEN
              blocks_in_this_skip := blocks_remaining_to_skip;
            ELSE
              blocks_in_this_skip := bmd^.max_blocks_per_physical_call;
            IFEND;
            bap$forspace_tape (bmd^.sfid, blocks_in_this_skip, bmd^.non_data_io_status, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF bmd^.non_data_io_status.normal_completion THEN
              blocks_remaining_to_skip := blocks_remaining_to_skip - blocks_in_this_skip;
            ELSE
              blocks_remaining_to_skip := blocks_remaining_to_skip - (blocks_in_this_skip - bmd^.
                    non_data_io_status.residual_block_count);
              IF bmd^.non_data_io_status.completion_code = ioc$tapemark_read THEN
                EXIT /skip_remaining_blocks/;
              ELSE
                form_failure_modes (bmd^.non_data_io_status, tape_failure_modes, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                IF bmd^.non_data_io_status.completion_code = ioc$not_capable_of_density THEN
                  osp$set_status_abnormal (bac$basic_access_id, bae$density_mismatch,
                    'Density mismatch in bap$tape_bm_skip_blocks', status);
                ELSEIF bmd^.non_data_io_status.completion_code = ioc$read_past_phys_eot THEN
                  osp$set_status_abnormal (bac$basic_access_id, bae$motion_past_phys_eot,
                        'Read past physical EOT in bap$tape_bm_skip_blocks', status);
                ELSEIF bmd^.non_data_io_status.completion_code = ioc$blank_tape THEN
                  osp$set_status_abnormal (bac$basic_access_id, bae$read_error_this_block,
                        'Blank tape in bap$tape_bm_skip_blocks', status);
                ELSE
                  menu_tape_fatal_error_recovery (bac$tfrm_fatal_read, tape_failure_modes, attempt_recovery,
                        attempt_close, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;
                  IF attempt_recovery THEN
                    CYCLE /skip_remaining_blocks/;
                  IFEND;
                  osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
                    'Bad tape status in bap$tape_bm_skip_blocks', status);
                IFEND;
                EXIT /skip_remaining_blocks/;
              IFEND;
            IFEND;
          WHILEND /skip_remaining_blocks/;
        IFEND;
      END /skip_forward/;

    = amc$backward =

    /skip_backward/
      BEGIN
        IF NOT bmd^.fatal_write_error THEN
          align_physical_logical_position (write_completion, status);
          IF NOT status.normal THEN
            tape_failure_modes := write_completion.failure_modes;
            RETURN;
          IFEND;
          bmd^.write_hit_end_of_tape_reflector := bmd^.write_hit_end_of_tape_reflector OR write_completion.
                end_of_tape_reflective_spot_hit;
          IF write_completion.error_type <> no_write_error THEN
            bmd^.fatal_write_error := TRUE;
            bmd^.fatal_write_failure_modes := write_completion.failure_modes;
            osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
              'Fatal write error in bap$tape_bm_skip_blocks   (backward)', status);
            tape_failure_modes := write_completion.failure_modes;
            EXIT /skip_backward/;
          IFEND;
          IF write_completion.end_of_tape_reflective_spot_hit THEN
            osp$set_status_abnormal (bac$basic_access_id, bae$vol_end_operation_inhibited,
              'End of reel in bap$tape_bm_skip_blocks   (backward)', status);
            EXIT /skip_backward/;
          IFEND;
          IF bmd^.io_direction = bac$iod_writing THEN
            dmp$get_tape_volume_information (bmd^.sfid, number_of_volumes, current_volume, current_vsns,
                  density, write_ring, requested_volume_attributes, volume_overflow_allowed, label_type,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            call_block.operation := amc$terminate_tape_volume;
            call_block.terminate_tape_volume := ^terminate_tape_volume;
            terminate_tape_volume.tape_density := density;
            terminate_tape_volume.terminating_volume_number := current_volume;
            terminate_tape_volume.terminating_volume := current_vsns;
            terminate_tape_volume.removable_media_location := requested_volume_attributes.
                  removable_media_location;
            terminate_tape_volume.removable_media_group := requested_volume_attributes.
                  removable_media_group;
            amp$access_method (file_id, call_block, global_layer_number, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF label_type <> amc$labelled THEN
              terminate_volume (write_completion, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              IF write_completion.error_type <> no_write_error THEN
                osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
                  'Position uncertain in bap$tape_bm_skip_blocks   (backwards)', status);
                bmd^.fatal_write_error := TRUE;
                bmd^.fatal_write_failure_modes := write_completion.failure_modes;
                tape_failure_modes := write_completion.failure_modes;
                EXIT /skip_backward/;
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        bmd^.fatal_write_error := FALSE;
        bmd^.write_hit_end_of_tape_reflector := FALSE;
        bmd^.io_direction := bac$iod_indeterminate;
        reset_buffer_pointers;

      /backspace_the_tape/
        WHILE blocks_remaining_to_skip > 0 DO
          IF blocks_remaining_to_skip <= bmd^.max_blocks_per_physical_call THEN
            blocks_in_this_skip := blocks_remaining_to_skip;
          ELSE
            blocks_in_this_skip := bmd^.max_blocks_per_physical_call;
          IFEND;
          bap$backspace_tape (bmd^.sfid, blocks_in_this_skip, {use_locate_block} FALSE,
                bmd^.non_data_io_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF bmd^.non_data_io_status.normal_completion THEN
            blocks_remaining_to_skip := blocks_remaining_to_skip - blocks_in_this_skip;
          ELSE
            IF bmd^.non_data_io_status.completion_code = ioc$tapemark_read THEN
              blocks_remaining_to_skip := blocks_remaining_to_skip - (blocks_in_this_skip - bmd^.
                    non_data_io_status.residual_block_count);
              tape_failure_modes := $amt$tape_failure_modes [];
              EXIT /backspace_the_tape/;
            ELSEIF (bmd^.non_data_io_status.completion_code = ioc$load_point) OR
            {} (bmd^.non_data_io_status.completion_code = ioc$load_point_block_count_ne_0) THEN
              blocks_remaining_to_skip := blocks_remaining_to_skip - (blocks_in_this_skip - bmd^.
                    non_data_io_status.residual_block_count);
              osp$set_status_abnormal (bac$basic_access_id, bae$skip_encountered_bov,
                'Skip hit BOV in bap$tape_bm_skip_blocks', status);
              tape_failure_modes := $amt$tape_failure_modes [];
              EXIT /skip_backward/;
            ELSE
              form_failure_modes (bmd^.non_data_io_status, tape_failure_modes, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
                'Bad tape status in bap$tape_bm_skip_blocks', status);
              RETURN;
            IFEND;
          IFEND;
        WHILEND /backspace_the_tape/;
      END /skip_backward/;
    ELSE
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
        'illegal skip direction in bap$tape_bm_skip_blocks', status);
      RETURN;
    CASEND;

    residual_skip_count := blocks_remaining_to_skip;

  PROCEND bap$tape_bm_skip_blocks;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_skip_label_mark', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_skip_label_mark (file_id: amt$file_identifier;
        direction: amt$skip_direction;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    VAR
      attempt_close: boolean,
      attempt_recovery: boolean,
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry;

    #caller_id (caller_id);
    status.normal := TRUE;
    tape_failure_modes := $amt$tape_failure_modes [];

    validate_call (file_id, caller_id.ring, non_data_transfer_access, 'BAP$TAPE_BM_SKIP_LABEL_MARK',
          file_instance, bmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE direction OF
    = amc$forward =

    /fatal_forspace_to_tapemark/
      WHILE TRUE DO
        iop$forspace_tape_to_tapemark (bmd^.sfid, bmd^.non_data_io_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF NOT bmd^.non_data_io_status.normal_completion THEN
          form_failure_modes (bmd^.non_data_io_status, tape_failure_modes, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF bmd^.non_data_io_status.completion_code = ioc$not_capable_of_density THEN
            osp$set_status_abnormal (bac$basic_access_id, bae$density_mismatch,
                  'Density mismatch in bap$tape_bm_skip_label_mark', status);
          ELSEIF bmd^.non_data_io_status.completion_code = ioc$read_past_phys_eot THEN
            osp$set_status_abnormal (bac$basic_access_id, bae$motion_past_phys_eot,
                  'Read past physical EOT in bap$tape_bm_skip_label_mark', status);
          ELSEIF bmd^.non_data_io_status.completion_code = ioc$blank_tape THEN
            osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
                  'Blank tape in bap$tape_bm_skip_label_mark', status);
          ELSE
            menu_tape_fatal_error_recovery (bac$tfrm_fatal_read, tape_failure_modes,
                  attempt_recovery, attempt_close, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

{ Cycle to continue skipping to tapemark if operator chooses attempt_recovery option.

            IF attempt_recovery THEN
              CYCLE /fatal_forspace_to_tapemark/;
            IFEND;
            osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
                'Bad tape status in bap$tape_bm_skip_label_mark (forward)', status);
          IFEND;
            RETURN;
        IFEND;

        tape_failure_modes := $amt$tape_failure_modes [];
        EXIT /fatal_forspace_to_tapemark/;

      WHILEND /fatal_forspace_to_tapemark/;

    = amc$backward =

    /skip_backward/
      BEGIN
        iop$backspace_tape_to_tapemark (bmd^.sfid, bmd^.non_data_io_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF NOT bmd^.non_data_io_status.normal_completion THEN
          IF (bmd^.non_data_io_status.completion_code = ioc$load_point) OR
          {} (bmd^.non_data_io_status.completion_code = ioc$load_point_block_count_ne_0) THEN
            osp$set_status_abnormal (bac$basic_access_id, bae$skip_encountered_bov,
              'Skip hit BOV in bap$tape_bm_skip_label_mark', status);
            tape_failure_modes := $amt$tape_failure_modes [];
            EXIT /skip_backward/;
          ELSE
            form_failure_modes (bmd^.non_data_io_status, tape_failure_modes, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
              'Bad tape status in bap$tape_bm_skip_label_mark', status);
            RETURN;
          IFEND;
        IFEND;
      END /skip_backward/;

    ELSE
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
        'illegal skip direction in bap$tape_bm_skip_label_mark', status);
    CASEND;

  PROCEND bap$tape_bm_skip_label_mark;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_skip_tapemark', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_skip_tapemark (file_id: amt$file_identifier;
        direction: amt$skip_direction;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    VAR
      attempt_close: boolean,
      attempt_recovery: boolean,
      block_found: boolean,
      buffer_information: ^bat$tape_buffer_information,
      caller_id: ost$caller_identifier,
      call_block: amt$call_block,
      current_vsns: rmt$volume_descriptor,
      current_volume: amt$volume_number,
      density: rmt$density,
      file_instance: ^bat$task_file_entry,
      label_type: amt$label_type,
      number_of_volumes: amt$volume_number,
      requested_volume_attributes: iot$requested_volume_attributes,
      terminate_tape_volume: amt$terminate_tape_volume,
      volume_overflow_allowed: boolean,
      write_completion: tape_write_completion,
      write_ring: rmt$write_ring;

    #caller_id (caller_id);
    status.normal := TRUE;
    tape_failure_modes := $amt$tape_failure_modes [];

    validate_call (file_id, caller_id.ring, non_data_transfer_access, 'BAP$TAPE_BM_SKIP_TAPEMARK',
          file_instance, bmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE direction OF
    = amc$forward =

    /skip_forward/
      BEGIN
        IF bmd^.io_direction = bac$iod_writing THEN
          osp$set_status_abnormal (bac$basic_access_id, bae$input_after_output,
            'Skip forward after write in bap$tape_bm_skip_tapemark', status);
          RETURN;
        IFEND;
        bmd^.io_direction := bac$iod_reading;
        find_buffered_read_data_block (block_found, buffer_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      /consume_buffered_data/
        WHILE block_found DO
          IF buffer_information^.block_type = bac$tapemark THEN
            EXIT /skip_forward/;
          IFEND;
          find_buffered_read_data_block (block_found, buffer_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        WHILEND /consume_buffered_data/;
        reset_buffer_pointers;

      /fatal_forspace_to_tapemark/
        WHILE TRUE DO
          iop$forspace_tape_to_tapemark (bmd^.sfid, bmd^.non_data_io_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF NOT bmd^.non_data_io_status.normal_completion THEN
            form_failure_modes (bmd^.non_data_io_status, tape_failure_modes, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF bmd^.non_data_io_status.completion_code = ioc$not_capable_of_density THEN
              osp$set_status_abnormal (bac$basic_access_id, bae$density_mismatch,
                    'Density mismatch in bap$tape_bm_skip_tapemark', status);
            ELSEIF bmd^.non_data_io_status.completion_code = ioc$read_past_phys_eot THEN
              osp$set_status_abnormal (bac$basic_access_id, bae$motion_past_phys_eot,
                    'Read past physical EOT in bap$tape_bm_skip_tapemark', status);
            ELSEIF bmd^.non_data_io_status.completion_code = ioc$blank_tape THEN
              osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
                    'Blank tape in bap$tape_bm_skip_tapemark', status);
            ELSE
              menu_tape_fatal_error_recovery (bac$tfrm_fatal_read, tape_failure_modes,
                    attempt_recovery, attempt_close, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

{ Cycle to continue skipping to tapemark if operator chooses attempt_recovery option.

              IF attempt_recovery THEN
                CYCLE /fatal_forspace_to_tapemark/;
              IFEND;
              osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
                  'Bad tape status in bap$tape_bm_skip_tapemark (forward)', status);
            IFEND;
            RETURN;
          IFEND;

          tape_failure_modes := $amt$tape_failure_modes [];
          EXIT /fatal_forspace_to_tapemark/;

        WHILEND /fatal_forspace_to_tapemark/;
      END /skip_forward/;

    = amc$backward =

    /skip_backward/
      BEGIN
        IF NOT bmd^.fatal_write_error THEN
          align_physical_logical_position (write_completion, status);
          IF NOT status.normal THEN
            tape_failure_modes := write_completion.failure_modes;
            RETURN;
          IFEND;
          bmd^.write_hit_end_of_tape_reflector := bmd^.write_hit_end_of_tape_reflector OR write_completion.
                end_of_tape_reflective_spot_hit;
          IF write_completion.error_type <> no_write_error THEN
            bmd^.fatal_write_error := TRUE;
            bmd^.fatal_write_failure_modes := write_completion.failure_modes;
            osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
              'Fatal write error in bap$tape_bm_skip_tapemark (backward)', status);
            tape_failure_modes := write_completion.failure_modes;
            EXIT /skip_backward/;
          IFEND;
          IF write_completion.end_of_tape_reflective_spot_hit THEN
            osp$set_status_abnormal (bac$basic_access_id, bae$vol_end_operation_inhibited,
              'End of reel in bap$tape_bm_skip_tapemark (backward)', status);
            EXIT /skip_backward/;
          IFEND;
          IF bmd^.io_direction = bac$iod_writing THEN
            dmp$get_tape_volume_information (bmd^.sfid, number_of_volumes, current_volume, current_vsns,
                  density, write_ring, requested_volume_attributes, volume_overflow_allowed, label_type,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            call_block.operation := amc$terminate_tape_volume;
            call_block.terminate_tape_volume := ^terminate_tape_volume;
            terminate_tape_volume.tape_density := density;
            terminate_tape_volume.terminating_volume_number := current_volume;
            terminate_tape_volume.terminating_volume := current_vsns;
            terminate_tape_volume.removable_media_location := requested_volume_attributes.
                  removable_media_location;
            terminate_tape_volume.removable_media_group := requested_volume_attributes.
                  removable_media_group;
            amp$access_method (file_id, call_block, global_layer_number, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF label_type <> amc$labelled THEN
              terminate_volume (write_completion, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              IF write_completion.error_type <> no_write_error THEN
                osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
                  'Position uncertain in bap$tape_bm_skip_tapemark (backwards)', status);
                bmd^.fatal_write_error := TRUE;
                bmd^.fatal_write_failure_modes := write_completion.failure_modes;
                tape_failure_modes := write_completion.failure_modes;
                EXIT /skip_backward/;
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        bmd^.fatal_write_error := FALSE;
        bmd^.write_hit_end_of_tape_reflector := FALSE;
        bmd^.io_direction := bac$iod_indeterminate;
        reset_buffer_pointers;

        iop$backspace_tape_to_tapemark (bmd^.sfid, bmd^.non_data_io_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF NOT bmd^.non_data_io_status.normal_completion THEN
          IF (bmd^.non_data_io_status.completion_code = ioc$load_point) OR
          {} (bmd^.non_data_io_status.completion_code = ioc$load_point_block_count_ne_0) THEN
            osp$set_status_abnormal (bac$basic_access_id, bae$skip_encountered_bov,
              'Skip hit BOV in bap$tape_bm_skip_tapemark', status);
            tape_failure_modes := $amt$tape_failure_modes [];
            EXIT /skip_backward/;
          ELSE
            form_failure_modes (bmd^.non_data_io_status, tape_failure_modes, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
              'Bad tape status in bap$tape_bm_skip_tapemark', status);
            RETURN;
          IFEND;
        IFEND;
      END /skip_backward/;

    ELSE
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
        'illegal skip direction in bap$tape_bm_skip_tapemark', status);
    CASEND;

  PROCEND bap$tape_bm_skip_tapemark;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_tapemark_check', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_tapemark_check (file_id: amt$file_identifier;
    VAR tapemark_is_next: boolean;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      next_position: bat$tape_block_position,
      ignore_write_completion: tape_write_completion;

    #caller_id (caller_id);
    status.normal := TRUE;

    validate_call (file_id, caller_id.ring, non_data_transfer_access, 'BAP$TAPE_BM_TAPEMARK_CHECK',
          file_instance, bmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF bmd^.io_direction <> bac$iod_reading THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
        'Call to bap$tape_bm_tapemark_check while not reading.', status);
      RETURN;
    IFEND;

    IF bmd^.direct_io THEN
      CASE bmd^.buffer_group [1]^.group_state OF
      = bac$group_io_pending =
        osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
          'group_io_pending in bap$tape_bm_tapemark_check (direct_io)', status);
        RETURN;
      = bac$group_contains_data =
        ;
      = bac$group_empty =
        initiate_read (1, bmd^.buffer_group [1]^.block_buffer [1].block_buffer, bmd^.max_block_length,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        await_data_io_completion (bmd^.logical_position, ignore_write_completion, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
          'Unrecognized group state in bap$tape_bm_tapemark_check', status);
        RETURN;
      CASEND;
      tapemark_is_next := bmd^.buffer_group [1]^.block_buffer [1].block_type = bac$tapemark;

    ELSE { normal, buffered I/O }

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

      next_position := bmd^.logical_position;
      IF bmd^.buffer_group [next_position.buffer_group]^.group_state = bac$group_empty THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
          'Empty group in bap$tape_bm_tapemark_check', status);
        RETURN;
      IFEND;
      await_data_io_completion (next_position, ignore_write_completion, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      tapemark_is_next := bmd^.buffer_group [next_position.buffer_group]^.block_buffer [next_position.
            buffer_index].block_type = bac$tapemark;

    IFEND;

  PROCEND bap$tape_bm_tapemark_check;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_write_label', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_write_label (file_id: amt$file_identifier;
        label_ptr: ^bat$tape_block;
        label_length: amt$max_block_length;
        system_media_recovery: boolean;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    TYPE
      word_aligned_tape_block = record
        tape_block: ALIGNED [0 MOD 8] array [1 .. * ] of cell,
      recend;

    VAR
      attempt_close: boolean,
      attempt_recovery: boolean,
      aligned_buffer_p: ^word_aligned_tape_block,
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      ignore_write_completion: tape_write_completion,
      io_id: iot$io_id,
      write_completion: tape_write_completion,
      write_description: iot$write_tape_description;

    #caller_id (caller_id);
    status.normal := TRUE;
    tape_failure_modes := $amt$tape_failure_modes [];

    validate_call (file_id, caller_id.ring, write_access, 'BAP$TAPE_BM_WRITE_LABEL', file_instance, bmd,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF label_length <= 0 THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
        'Zero length label passed to bap$tape_bm_write_label', status);
      RETURN;
    IFEND;

    IF bmd^.fatal_write_error THEN
      tape_failure_modes := bmd^.fatal_write_failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
        'Outstanding fatal write error in bap$tape_bm_write_label', status);
      RETURN;
    IFEND;

    IF bmd^.io_direction = bac$iod_reading THEN
      align_physical_logical_position (ignore_write_completion, status);
      IF NOT status.normal THEN
        tape_failure_modes := ignore_write_completion.failure_modes;
        RETURN;
      IFEND;
      reset_buffer_pointers;
    IFEND;

    bmd^.io_direction := bac$iod_writing;

    finish_all_outstanding_io (write_completion, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    bmd^.write_hit_end_of_tape_reflector := bmd^.write_hit_end_of_tape_reflector OR write_completion.
          end_of_tape_reflective_spot_hit;

    IF write_completion.error_type <> no_write_error THEN
      bmd^.fatal_write_error := TRUE;
      bmd^.fatal_write_failure_modes := write_completion.failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
        'Finishing I/O in bap$tape_bm_write_label', status);
      tape_failure_modes := write_completion.failure_modes;
      RETURN;
    IFEND;

    IF (label_length > bac$max_ansi_label_length) AND (label_length > bmd^.max_block_length) THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$block_larger_than_maxbl,
        'Label longer than MAXBL in bap$tape_bm_write_label', status);
      RETURN;
    IFEND;

    { Copy the label into a word aligned buffer for writing }

    PUSH aligned_buffer_p: [1 .. label_length];
    i#move (label_ptr, ^aligned_buffer_p^.tape_block, label_length);

    write_description [1].buffer_area := ^aligned_buffer_p^.tape_block;
    write_description [1].transfer_length := label_length;

{ The following WHILE TRUE loop is used to cycle back to retry write if operator chooses fatal error recovery.

  /write_label_recovery/
    WHILE TRUE DO
      bap$write_tape (bmd^.sfid, ^write_description, {block_count=} 1, {system_media_recovery=} TRUE, io_id,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      bap$await_tape_io_completion (bmd^.sfid, io_id, bmd^.non_data_io_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (NOT bmd^.non_data_io_status.normal_completion) THEN
        form_failure_modes (bmd^.non_data_io_status, tape_failure_modes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF bmd^.non_data_io_status.completion_code = ioc$no_write_ring THEN
          osp$set_status_abnormal (bac$basic_access_id, bae$no_tape_write_ring,
                ' ', status);
        ELSEIF bmd^.non_data_io_status.completion_code = ioc$write_past_phys_eot THEN
          osp$set_status_abnormal (bac$basic_access_id, bae$motion_past_phys_eot,
                'Write past physical EOT in bap$tape_bm_write_label', status);
        ELSE
          menu_tape_fatal_error_recovery (bac$tfrm_fatal_write, tape_failure_modes, attempt_recovery,
                attempt_close, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Cycle to retry write label if operator chose response of 1 (attempt_recovery).

          IF attempt_recovery THEN
            CYCLE /write_label_recovery/;
          IFEND;
          osp$set_status_abnormal (bac$basic_access_id, bae$write_error_this_block, 'bap$tape_bm_write_label',
                status);
        IFEND;

        bmd^.fatal_write_error := TRUE;
        bmd^.fatal_write_failure_modes := tape_failure_modes;
        RETURN;
      IFEND;
      tape_failure_modes := $amt$tape_failure_modes [];
      RETURN;
    WHILEND /write_label_recovery/;

  PROCEND bap$tape_bm_write_label;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_write_label_mark', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_write_label_mark (file_id: amt$file_identifier;
        system_media_recovery: boolean;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    VAR
      attempt_close: boolean,
      attempt_recovery: boolean,
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      write_completion: tape_write_completion,
      ignore_write_completion: tape_write_completion;

    #caller_id (caller_id);
    status.normal := TRUE;
    tape_failure_modes := $amt$tape_failure_modes [];

    validate_call (file_id, caller_id.ring, write_access, 'BAP$TAPE_BM_WRITE_LABEL_MARK', file_instance, bmd,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF bmd^.fatal_write_error THEN
      tape_failure_modes := bmd^.fatal_write_failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
        'Outstanding fatal write error in bap$tape_bm_write_label_mark', status);
      RETURN;
    IFEND;

    IF bmd^.io_direction = bac$iod_reading THEN
      align_physical_logical_position (ignore_write_completion, status);
      IF NOT status.normal THEN
        tape_failure_modes := ignore_write_completion.failure_modes;
        RETURN;
      IFEND;
      reset_buffer_pointers;
    IFEND;

    bmd^.io_direction := bac$iod_writing;

    finish_all_outstanding_io (write_completion, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    bmd^.write_hit_end_of_tape_reflector := bmd^.write_hit_end_of_tape_reflector OR write_completion.
          end_of_tape_reflective_spot_hit;

    IF write_completion.error_type <> no_write_error THEN
      bmd^.fatal_write_error := TRUE;
      bmd^.fatal_write_failure_modes := write_completion.failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
        'Finishing I/O in bap$tape_bm_advance_volume', status);
      tape_failure_modes := write_completion.failure_modes;
      RETURN;
    IFEND;

  /write_label_mark_recovery/
    WHILE TRUE DO
      bap$write_tapemark (bmd^.sfid, bmd^.non_data_io_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF NOT bmd^.non_data_io_status.normal_completion THEN
        form_failure_modes (bmd^.non_data_io_status, tape_failure_modes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF bmd^.non_data_io_status.completion_code = ioc$no_write_ring THEN
          osp$set_status_abnormal (bac$basic_access_id, bae$no_tape_write_ring,
                ' ', status);
        ELSEIF bmd^.non_data_io_status.completion_code = ioc$write_past_phys_eot THEN
          osp$set_status_abnormal (bac$basic_access_id, bae$motion_past_phys_eot,
                'Write past physical EOT in bap$tape_bm_write_label_mark', status);
        ELSE
          menu_tape_fatal_error_recovery (bac$tfrm_fatal_write_tapemark , tape_failure_modes,
                attempt_recovery, attempt_close, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF attempt_recovery THEN
            CYCLE /write_label_mark_recovery/
          IFEND;
          osp$set_status_abnormal (bac$basic_access_id, bae$write_error_this_block,
                'bap$tape_bm_write_label_mark', status);
        IFEND;
        bmd^.fatal_write_error := TRUE;
        bmd^.fatal_write_failure_modes := tape_failure_modes;
        RETURN;
      IFEND;
      tape_failure_modes := $amt$tape_failure_modes [];
      RETURN;
    WHILEND /write_label_mark_recovery/;

  PROCEND bap$tape_bm_write_label_mark;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_write_next_block', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_write_next_block (file_id: amt$file_identifier;
        block_ptr: ^bat$tape_block;
        block_length: amt$max_block_length;
        system_media_recovery: boolean;
        forced_write: boolean;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      ignore_write_completion: tape_write_completion,
      initial_buffer_reserved_value: boolean,
      write_completion: tape_write_completion,
      block_to_write: ^bat$tape_block,
      byte_read_from_buffer: cell,
      end_of_volume_status: ost$status;

    #caller_id (caller_id);
    status.normal := TRUE;
    tape_failure_modes := $amt$tape_failure_modes [];

    validate_call (file_id, caller_id.ring, write_access, 'BAP$TAPE_BM_WRITE_NEXT_BLOCK', file_instance, bmd,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF bmd^.fatal_write_error THEN
      tape_failure_modes := bmd^.fatal_write_failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
        'Outstanding fatal write error in bap$tape_bm_write_next_block', status);
      RETURN;
    IFEND;

    IF block_length > bmd^.max_block_length THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$block_larger_than_maxbl,
        'block exceeds MAXBL in bam$tape_bm_write_next_block', status);
      RETURN;
    IFEND;

    IF block_length <= 0 THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
        'Zero length block passed to bap$tape_bm_write_next_block', status);
      RETURN;
    IFEND;

    IF #segment (bmd^.buffer_segment.seq_pointer) = #segment (block_ptr) THEN
      IF NOT bmd^.buffer_reserved THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$unreserved_buffer_used,
          'unreserved buffer in bap$tape_bm_write_next_block', status);
        RETURN;
      IFEND;
    IFEND;

    IF block_ptr = NIL THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
        'NIL buffer pointer in bap$tape_bm_write_next_block.', status);
      RETURN;
    IFEND;

    IF bmd^.write_hit_end_of_tape_reflector THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$vol_end_operation_inhibited,
        'Call to bap$tape_bm_write_next_block while end of volume is pending.', status);
      RETURN;
    IFEND;

    initial_buffer_reserved_value := bmd^.buffer_reserved;
    bmd^.buffer_reserved := FALSE;
    bmd^.system_media_recovery := system_media_recovery;

    IF bmd^.io_direction = bac$iod_reading THEN
      align_physical_logical_position (ignore_write_completion, status);
      IF NOT status.normal THEN
        tape_failure_modes := ignore_write_completion.failure_modes;
        RETURN;
      IFEND;
      reset_buffer_pointers;
    IFEND;
    bmd^.io_direction := bac$iod_writing;

    end_of_volume_status.normal := TRUE;
    IF bmd^.direct_io THEN

      IF (#offset (block_ptr) MOD 8) = 0 THEN
        { Buffer is aligned to a word boundary -- we can write direct from the buffer
        block_to_write := block_ptr;
        byte_read_from_buffer := block_to_write^ [1];
        #SPOIL (byte_read_from_buffer);
        byte_read_from_buffer := block_to_write^ [block_length];
      ELSE
        { Unaligned buffer -- copy into the allocated buffer
        block_to_write := bmd^.buffer_group [1]^.block_buffer [1].block_buffer;
        i#move (block_ptr, block_to_write, block_length);
      IFEND;
      bmd^.buffer_group [1]^.group_state := bac$group_contains_data;
      bmd^.buffer_group [1]^.last_buffer_with_data := 1;
      initiate_write ( {buffer_group =} 1, block_to_write, block_length, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      await_data_io_completion (bmd^.logical_position, write_completion, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF write_completion.error_type <> no_write_error THEN
        write_completion.error_type := write_error_last_block;
      IFEND;
      bmd^.buffer_group [1]^.group_state := bac$group_empty;
      IF write_completion.end_of_tape_reflective_spot_hit THEN
        bmd^.write_hit_end_of_tape_reflector := TRUE;
        osp$set_status_abnormal (bac$basic_access_id, bae$vol_end_operation_completed,
          'Volume end in bap$tape_bm_write_next_block (direct io)', end_of_volume_status);
      IFEND;

    ELSE { normal, buffered I/O }

    /buffered_write/
      BEGIN
        perform_buffered_write (block_ptr, block_length, write_completion, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        bmd^.write_hit_end_of_tape_reflector := bmd^.write_hit_end_of_tape_reflector OR write_completion.
              end_of_tape_reflective_spot_hit;
        IF write_completion.error_type <> no_write_error THEN
          EXIT /buffered_write/;
        IFEND;
        IF write_completion.end_of_tape_reflective_spot_hit THEN
          osp$set_status_abnormal (bac$basic_access_id, bae$vol_end_operation_inhibited, 'Buffered write',
                end_of_volume_status);
          bmd^.buffer_reserved := initial_buffer_reserved_value;
          EXIT /buffered_write/;
        IFEND;
        IF forced_write THEN
          align_physical_logical_position (write_completion, status);
          IF write_completion.error_type <> no_write_error THEN
            write_completion.error_type := write_error_last_block;
          IFEND;
          IF write_completion.end_of_tape_reflective_spot_hit THEN
            bmd^.write_hit_end_of_tape_reflector := TRUE;
            osp$set_status_abnormal (bac$basic_access_id, bae$vol_end_operation_completed,
              'Buffered write - While advancing write-behind', end_of_volume_status);
            EXIT /buffered_write/;
          IFEND;
        ELSE
          advance_write_behind (status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      END /buffered_write/;

    IFEND;

    tape_failure_modes := write_completion.failure_modes;

    { Set status appropriately.  Note that a write error overrides an end-of-volume indication. }
    { (The EOV will be returned on  the next block management call.) }

    CASE write_completion.error_type OF
    = write_error_previous_block =
      bmd^.fatal_write_error := TRUE;
      bmd^.fatal_write_failure_modes := tape_failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
        'In bap$tape_bm_write_next_block', status);
    = write_error_last_block =
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_this_block,
        'In bap$tape_bm_write_next_block', status);
    = no_write_error =
      status := end_of_volume_status;
    ELSE
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
        'Illegal value of write_error in bap$tape_bm_write_next_block', status);
      RETURN;
    CASEND;

  PROCEND bap$tape_bm_write_next_block;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$tape_bm_write_tapemark', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_write_tapemark (file_id: amt$file_identifier;
        system_media_recovery: boolean;
        force_write: boolean;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    VAR
      attempt_close: boolean,
      attempt_recovery: boolean,
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      write_completion: tape_write_completion;

    #caller_id (caller_id);
    status.normal := TRUE;
    tape_failure_modes := $amt$tape_failure_modes [];

    validate_call (file_id, caller_id.ring, write_access, 'BAP$TAPE_BM_WRITE_TAPEMARK', file_instance, bmd,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF bmd^.fatal_write_error THEN
      tape_failure_modes := bmd^.fatal_write_failure_modes;
      osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
        'Outstanding fatal write error in bap$tape_bm_write_tapemark', status);
      RETURN;
    IFEND;

    IF bmd^.write_hit_end_of_tape_reflector THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$vol_end_operation_inhibited,
        'Call to bap$tape_bm_write_tapemark after end of volume has been returned.', status);
      RETURN;
    IFEND;

  /write_tapemark/
    BEGIN
      align_physical_logical_position (write_completion, status);
      IF NOT status.normal THEN
        tape_failure_modes := write_completion.failure_modes;
        RETURN;
      IFEND;

      bmd^.write_hit_end_of_tape_reflector := bmd^.write_hit_end_of_tape_reflector OR write_completion.
            end_of_tape_reflective_spot_hit;
      IF write_completion.error_type <> no_write_error THEN
        bmd^.fatal_write_error := TRUE;
        bmd^.fatal_write_failure_modes := write_completion.failure_modes;
        osp$set_status_abnormal (bac$basic_access_id, bae$write_error_previous_block,
          'Fatal write error in bap$tape_bm_write_tapemark', status);
        tape_failure_modes := write_completion.failure_modes;
        EXIT /write_tapemark/;
      IFEND;
      IF write_completion.end_of_tape_reflective_spot_hit THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$vol_end_operation_inhibited,
          'End of reel in BAP$TAPE_BM_REWIND', status);
        RETURN;
        EXIT /write_tapemark/;
      IFEND;

      reset_buffer_pointers;
      bmd^.io_direction := bac$iod_writing;

  /write_tapemark_recovery/
      WHILE TRUE DO
        bap$write_tapemark (bmd^.sfid, bmd^.non_data_io_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        bmd^.write_hit_end_of_tape_reflector := bmd^.write_hit_end_of_tape_reflector OR
              bmd^.non_data_io_status.end_of_tape;
        IF NOT bmd^.non_data_io_status.normal_completion THEN
          form_failure_modes (bmd^.non_data_io_status, tape_failure_modes, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF bmd^.non_data_io_status.completion_code = ioc$no_write_ring THEN
            osp$set_status_abnormal (bac$basic_access_id, bae$no_tape_write_ring,
                  ' ', status);
          ELSEIF bmd^.non_data_io_status.completion_code = ioc$write_past_phys_eot THEN
            osp$set_status_abnormal (bac$basic_access_id, bae$motion_past_phys_eot,
                  'Write past physical EOT in bap$tape_bm_write_tapemark', status);
          ELSE
            menu_tape_fatal_error_recovery (bac$tfrm_fatal_write_tapemark, tape_failure_modes,
                  attempt_recovery, attempt_close, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF attempt_recovery THEN
              CYCLE /write_tapemark_recovery/
            IFEND;
            osp$set_status_abnormal (bac$basic_access_id, bae$write_error_this_block,
                  'Tape position uncertain in bap$tape_bm_write_tapemark', status);
          IFEND;
          bmd^.fatal_write_error := TRUE;
          bmd^.fatal_write_failure_modes := tape_failure_modes;
          RETURN;
        IFEND;
        tape_failure_modes := $amt$tape_failure_modes [];
        EXIT /write_tapemark_recovery/;
      WHILEND /write_tapemark_recovery/;

      IF bmd^.non_data_io_status.end_of_tape THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$vol_end_operation_completed,
          'bap$tape_bm_write_tapemark hit end_of_tape', status);
      IFEND;
    END /write_tapemark/;

  PROCEND bap$tape_bm_write_tapemark;

?? TITLE := 'PROCEDURE bap$tape_bm_unwritten_blk_count', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$tape_bm_unwritten_blk_count (file_id: amt$file_identifier;
    VAR blocks_currently_buffered: bat$tape_block_buffer_count;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      buffer_group: bat$tape_buffer_group_index,
      group_descriptor: ^bat$tape_buffer_grp_descriptor;

    #caller_id (caller_id);
    status.normal := TRUE;
    blocks_currently_buffered := 0;

    validate_call (file_id, caller_id.ring, non_data_transfer_access, 'BAP$TAPE_BM_UNWRITTEN_BLK_COUNT',
          file_instance, bmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE bmd^.io_direction OF
    = bac$iod_indeterminate, bac$iod_reading =
      ;
    = bac$iod_writing =

    /count_buffers_in_each_group/
      FOR buffer_group := 1 TO bmd^.buffer_groups_in_use DO
        group_descriptor := bmd^.buffer_group[buffer_group];
        IF group_descriptor^.group_state = bac$group_contains_data THEN
          blocks_currently_buffered := blocks_currently_buffered + bmd^.buffer_group_size;
          IF bmd^.physical_position.buffer_group = buffer_group THEN
            blocks_currently_buffered := blocks_currently_buffered -
                  (bmd^.physical_position.buffer_index - 1) - (bmd^.buffer_group_size -
                  group_descriptor^.last_buffer_with_data);
          IFEND;
          IF (bmd^.logical_position.buffer_group = buffer_group) AND NOT
                (bmd^.physical_position.buffer_group = buffer_group) THEN
            blocks_currently_buffered := blocks_currently_buffered -  (bmd^.buffer_group_size -
                  bmd^.logical_position.buffer_index + 1);
          IFEND;
        IFEND;
      FOREND /count_buffers_in_each_group/;

    ELSE

      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
            'Illegal I/O direction in bap$tape_bm_unwritten_blk_count', status);
      RETURN;

    CASEND;

    IF (blocks_currently_buffered < 0) OR (blocks_currently_buffered > (bmd^.buffer_groups_in_use *
          bmd^.buffer_group_size)) THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
            'Out of range unwritten block count.  Count =', status);
      osp$append_status_integer (' ', blocks_currently_buffered, 10, TRUE, status);
      RETURN;
    IFEND;

  PROCEND bap$tape_bm_unwritten_blk_count;

?? TITLE := 'PROCEDURE [INLINE] advance_read_ahead', EJECT ??

  PROCEDURE [INLINE] advance_read_ahead (VAR status: ost$status);

    VAR
      full_groups: integer,
      group: bat$tape_buffer_group_index;

    status.normal := TRUE;

    full_groups := 0;
  /count_full_groups/
    FOR group := 1 TO bmd^.buffer_groups_in_use DO;
      { Note that groups with I/O outstanding are considered "full", since they will become full when }
      { I/O completes }
      IF bmd^.buffer_group [group]^.group_state <> bac$group_empty THEN
        full_groups := full_groups + 1;
      IFEND;
    FOREND /count_full_groups/;

    IF full_groups = 0 THEN
      bmd^.inhibit_read_ahead := FALSE;
    IFEND;

    IF bmd^.inhibit_read_ahead OR (full_groups = bmd^.buffer_groups_in_use) THEN
      RETURN;     {do not attempt to initiate any more reads
    IFEND;

    group := bmd^.logical_position.buffer_group;
  /issue_read_requests/
    REPEAT
      IF bmd^.buffer_group [group]^.group_state = bac$group_empty THEN
        initiate_read (group, {block_pointer =} NIL, 1, status);
        IF NOT status.normal THEN
          IF (status.condition = ioe$tape_unit_disabled) OR
             (status.condition = ioe$tape_pp_q_locked)   THEN
            { TQM couldn't accept our request for some reason.  (Recovery in progress, or some previous)}
            { request encountering an error.)  Just exit and try again next time. }
            status.normal := TRUE;
            EXIT /issue_read_requests/;
          ELSE
            RETURN;
          IFEND;
        IFEND;
      IFEND;
      IF group < bmd^.buffer_groups_in_use THEN
        group := group + 1;
      ELSE
        group := 1;
      IFEND;
    UNTIL group = bmd^.logical_position.buffer_group;

  PROCEND advance_read_ahead;

?? TITLE := 'PROCEDURE [INLINE] advance_read_position', EJECT ??

  PROCEDURE [INLINE] advance_read_position (VAR block_description: ^bat$tape_buffer_information;
    VAR status: ost$status);

    VAR
      ignore_write_completion: tape_write_completion,
      block_found: boolean;

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

    find_buffered_read_data_block (block_found, block_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT block_found THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
        'No block found in advance_read_position', status);
      RETURN;
    IFEND;

  PROCEND advance_read_position;

?? TITLE := 'PROCEDURE [INLINE] advance_write_behind', EJECT ??

  PROCEDURE [INLINE] advance_write_behind (VAR status: ost$status);

    VAR
      group: bat$tape_buffer_group_index;

    status.normal := TRUE;

    group := bmd^.physical_position.buffer_group;

    { Note that this loop stops BEFORE checking the group at the current logical position.  This   }
    { allows the current group to be filled before it is written to tape.   }

  /issue_write_requests/
    REPEAT
      IF (bmd^.buffer_group [group]^.group_state = bac$group_contains_data) THEN
        IF (group <> bmd^.logical_position.buffer_group) OR ((bmd^.physical_position.buffer_group =
              bmd^.logical_position.buffer_group) AND (bmd^.logical_position.buffer_index = 1)) THEN
          initiate_write (group, {block_pointer =} NIL, 1, status);
          IF NOT status.normal THEN
              IF (status.condition = ioe$tape_unit_disabled) OR
                 (status.condition = ioe$tape_pp_q_locked)   THEN
                { TQM couldn't accept our request for some reason.  (Recovery in progress, or some previous)}
                { request encountering an error.)  Just exit and try again next time. }
                status.normal := TRUE;
                EXIT /issue_write_requests/;
              ELSE
                RETURN;
              IFEND;
          IFEND;
        IFEND;
      IFEND;
      IF group < bmd^.buffer_groups_in_use THEN
        group := group + 1;
      ELSE
        group := 1;
      IFEND;
    UNTIL group = bmd^.logical_position.buffer_group;

  PROCEND advance_write_behind;

?? TITLE := 'PROCEDURE align_physical_logical_position', EJECT ??

  PROCEDURE align_physical_logical_position (VAR write_completion: tape_write_completion;
    VAR status: ost$status);

    VAR
      buffer_group: bat$tape_buffer_group_index,
      blocks_to_backspace: 0 .. bac$max_tape_buffer_group_size,
      blocks_used_from_this_group: 0 .. bac$max_tape_buffer_group_size;

    status.normal := TRUE;
    write_completion := normal_write_completion;

    finish_all_outstanding_io (write_completion, status);
    IF (NOT status.normal) OR
    {} write_completion.end_of_tape_reflective_spot_hit OR
    {} (write_completion.error_type <> no_write_error) THEN
      RETURN;
    IFEND;

    IF bmd^.direct_io THEN

      CASE bmd^.io_direction OF
      = bac$iod_reading =
        CASE bmd^.buffer_group [1]^.group_state OF
        = bac$group_empty =
          ;
        = bac$group_contains_data =
          IF bmd^.buffer_group [1]^.block_buffer [1].block_type = bac$tapemark THEN
            iop$backspace_tape_to_tapemark (bmd^.sfid, bmd^.non_data_io_status, status);
          ELSE
            bap$backspace_tape (bmd^.sfid, 1, {use_locate_block} FALSE, bmd^.non_data_io_status, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF NOT bmd^.non_data_io_status.normal_completion THEN
            form_failure_modes (bmd^.non_data_io_status, write_completion.failure_modes, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
              'bam$tape_block_manager_ring3 - align_physical_logical_position', status);
            RETURN;
          IFEND;
          bmd^.buffer_group [1]^.group_state := bac$group_empty;
        = bac$group_io_pending =
          osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
            'IO pending in align_physical_logical_position', status);
          RETURN;
        ELSE
          osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
            'Unrecognized group state in align_physical_logical_position', status);
          RETURN;
        CASEND;
      = bac$iod_writing =
        CASE bmd^.buffer_group [1]^.group_state OF
        = bac$group_empty =
          ;
        = bac$group_contains_data =
          osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
            'Group contains data during direct I/O writing', status);
        = bac$group_io_pending =
          osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
            'IO pending in align_physical_logical_position', status);
          RETURN;
        ELSE
          osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
            'Unrecognized group state in align_physical_logical_position', status);
          RETURN;
        CASEND;
      ELSE
        ;
      CASEND;

    ELSE { normal, buffered i/o }

      CASE bmd^.io_direction OF
      = bac$iod_indeterminate =

        ; { Nothing to do }

      = bac$iod_reading =

        buffer_group := bmd^.physical_position.buffer_group;

      /back_over_read_ahead_data/
        WHILE bmd^.buffer_group [buffer_group]^.group_state <> bac$group_empty DO
          IF bmd^.buffer_group [buffer_group]^.group_state = bac$group_io_pending THEN
            osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
              'Outstanding I/O in align_phyiscal_logical_position', status);
            RETURN;
          IFEND;

          blocks_to_backspace := bmd^.buffer_group [buffer_group]^.last_buffer_with_data;

          IF buffer_group = bmd^.physical_position.buffer_group THEN
            IF bmd^.inhibit_read_ahead THEN  { either error or tapemark was the reason
              IF (bmd^.buffer_group [buffer_group]^.block_buffer [blocks_to_backspace].block_type =
                    bac$tapemark) THEN
                bap$backspace_tape (bmd^.sfid, {blocks_to_backspace} 1, {use_locate_block} FALSE,
                  bmd^.non_data_io_status, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                IF NOT bmd^.non_data_io_status.normal_completion THEN
                  IF (bmd^.non_data_io_status.completion_code = ioc$tapemark_read) THEN
                    blocks_to_backspace := blocks_to_backspace - 1;
                  ELSE
                    reset_buffer_pointers;
                    form_failure_modes (bmd^.non_data_io_status, write_completion.failure_modes, status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;
                    osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
                          'Tape position uncertain in align_physical_logical_position', status);
                    RETURN;
                  IFEND;
                ELSE { must encounter a tapemark
                  osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
                        'Tapemark missing during backspace in align_phyiscal_logical_position', status);
                  RETURN;
                IFEND;
              IFEND;
            IFEND;
          IFEND;

          IF buffer_group = bmd^.logical_position.buffer_group THEN
            blocks_used_from_this_group := bmd^.logical_position.buffer_index - 1;
            blocks_to_backspace := blocks_to_backspace - blocks_used_from_this_group;
          IFEND;

        /back_over_one_buffer_group/
          WHILE blocks_to_backspace > 0 DO
            bap$backspace_tape (bmd^.sfid, blocks_to_backspace, {use_locate_block} TRUE,
                  bmd^.non_data_io_status, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF NOT bmd^.non_data_io_status.normal_completion THEN
              IF bmd^.non_data_io_status.completion_code = ioc$tapemark_read THEN
                osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
                      'Tapemark encountered during backspace in align_phyiscal_logical_position', status);
                RETURN;
              ELSE
                reset_buffer_pointers;
                form_failure_modes (bmd^.non_data_io_status, write_completion.failure_modes, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
                  'Tape position uncertain in align_physical_logical_position', status);
                RETURN;
              IFEND;
            ELSE
              blocks_to_backspace := 0;
            IFEND;
          WHILEND /back_over_one_buffer_group/;
          bmd^.buffer_group [buffer_group]^.group_state := bac$group_empty;

          IF buffer_group = 1 THEN
            buffer_group := bmd^.buffer_groups_in_use;
          ELSE
            buffer_group := buffer_group - 1;
          IFEND;

        WHILEND /back_over_read_ahead_data/;

        reset_buffer_pointers;

      = bac$iod_writing =

      /buffered_io_writing_align/
        BEGIN

        /write_each_buffer_group/
          WHILE bmd^.buffer_group [bmd^.physical_position.buffer_group]^.group_state <> bac$group_empty DO

            CASE bmd^.buffer_group [bmd^.physical_position.buffer_group]^.group_state OF
            = bac$group_contains_data =
              initiate_write (bmd^.physical_position.buffer_group, {block_ptr =} NIL, 1, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              IF (bmd^.physical_position.buffer_group = bmd^.logical_position.buffer_group) THEN
                IF bmd^.logical_position.buffer_group < bmd^.buffer_groups_in_use THEN
                  form_tape_block_position (bmd^.logical_position, bmd^.logical_position.buffer_group + 1, 1);
                ELSE
                  form_tape_block_position (bmd^.logical_position, 1, 1);
                IFEND;
              IFEND;
              await_data_io_completion (bmd^.physical_position, write_completion, status);
            = bac$group_io_pending =
              await_data_io_completion (bmd^.physical_position, write_completion, status);
            ELSE
              osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
                'Illegal group state in align_phyiscal_logical_position (buffered write)', status);
              RETURN;
            CASEND;
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF write_completion.error_type <> no_write_error THEN
              EXIT /buffered_io_writing_align/;
            IFEND;

            IF write_completion.end_of_tape_reflective_spot_hit THEN
              EXIT /buffered_io_writing_align/;
            IFEND;

          WHILEND /write_each_buffer_group/;

          reset_buffer_pointers;

        END /buffered_io_writing_align/;

      ELSE
        osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
          'Invalid I/O direction in align_physical_logical_position (buffered)', status)
      CASEND;

    IFEND;

  PROCEND align_physical_logical_position;

?? TITLE := 'PROCEDURE await_data_io_completion', EJECT ??

  PROCEDURE await_data_io_completion (position: bat$tape_block_position;
    VAR write_completion: tape_write_completion;
    VAR status: ost$status);

    VAR
      group_description: ^bat$tape_buffer_grp_descriptor,
      tape_status: ^iot$tape_io_status;

    status.normal := TRUE;
    write_completion := normal_write_completion;

    group_description := bmd^.buffer_group [position.buffer_group];

    CASE group_description^.group_state OF
    = bac$group_empty =
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
        'Empty group encountered in await_data_io_completion', status);
      RETURN;
    = bac$group_contains_data =
      ;
    = bac$group_io_pending =
      tape_status := ^group_description^.io_status;
      bap$await_tape_io_completion (bmd^.sfid, group_description^.io_id, tape_status^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      process_data_io_completion (position.buffer_group, tape_status^, write_completion, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
        'Unrecognizable group state in await_data_io_completion', status);
    CASEND;

  PROCEND await_data_io_completion;

?? TITLE := 'PROCEDURE clear_other_pending_requests', EJECT ??

  { This procedure is called after an I/O error has occurred on a read or a write.  It goes through }
  { the buffer groups and fetches the completed status of all pending I/O requests from tape queue manager. }

  PROCEDURE clear_other_pending_requests (current_group: bat$tape_buffer_group_index;
    VAR status: ost$status);

    VAR
      group: bat$tape_buffer_group_index,
      group_description: ^bat$tape_buffer_grp_descriptor,
      tape_status: ^iot$tape_io_status;

    status.normal := TRUE;

  /check_each_buffer_group/
    FOR group := 1 TO bmd^.buffer_groups_in_use DO
      IF bmd^.buffer_group [group]^.group_state = bac$group_io_pending THEN
        IF group <> current_group THEN
          group_description := bmd^.buffer_group [group];

          tape_status := ^group_description^.io_status;
          bap$await_tape_io_completion (bmd^.sfid, bmd^.buffer_group [group]^.io_id, tape_status^, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF tape_status^.normal_completion THEN
            osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
                  'Normal I/O completion in clear_other_pending_requests', status);
            RETURN;
          ELSE
            IF tape_status^.completion_code <> ioc$request_not_processed THEN
              osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
                    'Unexpected I/O completion code in clear_other_pending_requests -- code =', status);
              osp$append_status_integer (' ', tape_status^.completion_code, 10, TRUE, status);
              RETURN;
            IFEND;
          IFEND;

          CASE bmd^.io_direction OF
          = bac$iod_reading =
            group_description^.group_state := bac$group_empty;
          = bac$iod_writing =
            group_description^.group_state := bac$group_contains_data;
          = bac$iod_indeterminate =
              osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
                    'Unexpected indeterminate I/O direction in clear_other_pending_requests', status);
              RETURN;
          ELSE
            osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
                  'Illegal I/O direction in procedure clear_other_pending_requests', status);
          CASEND;
        IFEND;
      IFEND;
    FOREND /check_each_buffer_group/;

  PROCEND clear_other_pending_requests;

?? TITLE := 'PROCEDURE [INLINE] ensure_write_buffer_available', EJECT ??

  PROCEDURE [INLINE] ensure_write_buffer_available (VAR write_completion: tape_write_completion;
    VAR status: ost$status);

    status.normal := TRUE;
    write_completion := normal_write_completion;

    IF bmd^.logical_position.buffer_index = 1 THEN

      { First block in a buffer group -- ensure that any data previously in this buffer group }
      { has been written to tape. }

    /ensure_the_new_group_is_empty/
      WHILE bmd^.buffer_group [bmd^.logical_position.buffer_group]^.group_state <> bac$group_empty DO
        advance_write_behind (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF bmd^.buffer_group [bmd^.physical_position.buffer_group]^.group_state = bac$group_contains_data THEN
          osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
            'Unable to advance write behind in ensure_write_buffer_available', status);
          RETURN;
        IFEND;
        await_data_io_completion (bmd^.physical_position, write_completion, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF write_completion.end_of_tape_reflective_spot_hit OR (write_completion.error_type <> no_write_error)
              THEN
          EXIT /ensure_the_new_group_is_empty/;
        IFEND;
      WHILEND /ensure_the_new_group_is_empty/;

    IFEND;

  PROCEND ensure_write_buffer_available;

?? TITLE := 'PROCEDURE find_buffered_read_data_block', EJECT ??

  PROCEDURE find_buffered_read_data_block (VAR block_found: boolean;
    VAR found_block_information: ^bat$tape_buffer_information;
    VAR status: ost$status);

    VAR
      ignore_write_completion: tape_write_completion;

    status.normal := TRUE;
    found_block_information := NIL;

    IF bmd^.direct_io THEN

      IF bmd^.buffer_group [1]^.group_state = bac$group_contains_data THEN
        block_found := TRUE;
        found_block_information := ^bmd^.buffer_group [1]^.block_buffer [1];
        bmd^.buffer_group [1]^.group_state := bac$group_empty;
      ELSE
        block_found := FALSE;
      IFEND;

    ELSE { normal, buffered I/O }

      IF bmd^.buffer_group [bmd^.logical_position.buffer_group]^.group_state = bac$group_empty THEN
        block_found := FALSE;
      ELSE
        IF bmd^.buffer_group [bmd^.logical_position.buffer_group]^.group_state <>
              bac$group_contains_data THEN
          await_data_io_completion (bmd^.logical_position, ignore_write_completion, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        block_found := TRUE;
        found_block_information := ^bmd^.buffer_group [bmd^.logical_position.buffer_group]^.block_buffer
              [bmd^.logical_position.buffer_index];
        IF bmd^.logical_position.buffer_index < bmd^.buffer_group [bmd^.logical_position.buffer_group]^.
              last_buffer_with_data THEN
          bmd^.logical_position.buffer_index := bmd^.logical_position.buffer_index + 1;
        ELSE
          bmd^.buffer_group [bmd^.logical_position.buffer_group]^.group_state := bac$group_empty;
          IF bmd^.logical_position.buffer_group < bmd^.buffer_groups_in_use THEN
            form_tape_block_position (bmd^.logical_position, bmd^.logical_position.buffer_group + 1, 1);
          ELSE
            form_tape_block_position (bmd^.logical_position, 1, 1);
          IFEND;
        IFEND;
      IFEND;

    IFEND;

  PROCEND find_buffered_read_data_block;

?? TITLE := 'PROCEDURE finish_all_outstanding_io', EJECT ??

  PROCEDURE finish_all_outstanding_io (VAR write_completion: tape_write_completion;
    VAR status: ost$status);

    VAR
      last_group: bat$tape_buffer_group_index,
      position: bat$tape_block_position;

    status.normal := TRUE;
    write_completion := normal_write_completion;

  /complete_io/
    BEGIN
      CASE bmd^.io_direction OF
      = bac$iod_indeterminate =
        EXIT /complete_io/;
      = bac$iod_reading =
        form_tape_block_position (position, bmd^.logical_position.buffer_group, 1);
      = bac$iod_writing =
        form_tape_block_position (position, bmd^.physical_position.buffer_group,
              bmd^.physical_position.buffer_index);
      ELSE
        osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
          'Invalid I/O direction in finish_all_outstanding_io', status);
        RETURN;
      CASEND;
      last_group := position.buffer_group;

    /check_each_buffer_group/
      REPEAT
        IF bmd^.buffer_group [position.buffer_group]^.group_state = bac$group_io_pending THEN
          await_data_io_completion (position, write_completion, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF write_completion.end_of_tape_reflective_spot_hit OR
          {} (write_completion.error_type <> no_write_error) THEN
            EXIT /complete_io/;
          IFEND;
        IFEND;

        IF position.buffer_group < bmd^.buffer_groups_in_use THEN
          form_tape_block_position (position, position.buffer_group + 1, 1);
        ELSE
          form_tape_block_position (position, 1, 1);
        IFEND;

      UNTIL position.buffer_group = last_group;

    END /complete_io/;

  PROCEND finish_all_outstanding_io;

?? TITLE := 'PROCEDURE form_failure_modes', EJECT ??

  PROCEDURE form_failure_modes (tape_status: iot$tape_io_status;
    VAR failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    status.normal := TRUE;

    IF tape_status.normal_completion THEN
      failure_modes := $amt$tape_failure_modes [];
    ELSE
      CASE tape_status.completion_code OF
      = ioc$indeterminate, ioc$input_channel_parity, ioc$output_channel_parity, ioc$controller_failure,
            ioc$unit_failure, ioc$function_timeout, ioc$unit_reserved, ioc$iou_output_parity,
              ioc$indeterminate_output_parity, ioc$load_point =
        failure_modes := $amt$tape_failure_modes [amc$tfm_hardware_failure];
        IF (tape_status.completion_code = ioc$function_timeout) OR
              (tape_status.completion_code = ioc$controller_failure) THEN
          RETURN; {skip unit_ready check since status may not have been returned}
        IFEND;
      = ioc$tape_medium_failure, ioc$not_capable_of_density =
        failure_modes := $amt$tape_failure_modes [amc$tfm_data_parity_error];
      = ioc$erase_limit_exceeded =
        failure_modes := $amt$tape_failure_modes [amc$tfm_erase_error];
      = ioc$unable_to_write_id_burst =
        failure_modes := $amt$tape_failure_modes [amc$tfm_bad_id_burst];
      = ioc$unable_to_set_agc =
        failure_modes := $amt$tape_failure_modes [amc$tfm_agc_gains_not_set];
      = ioc$blank_tape =
        failure_modes := $amt$tape_failure_modes [amc$tfm_blank_tape_read];
      = ioc$alert_condition_encountered =
        failure_modes := $amt$tape_failure_modes []; { alert booleans are processed   below }
      = ioc$no_write_ring, ioc$read_past_phys_eot, ioc$write_past_phys_eot =
        failure_modes := $amt$tape_failure_modes [];
      ELSE
        osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
          'Unanticipated tape I/O status -- completion_code =', status);
        osp$append_status_integer (' ', tape_status.completion_code, 10, TRUE, status);
        RETURN;
      CASEND;
    IFEND;

    IF NOT tape_status.unit_ready THEN
      failure_modes := failure_modes + $amt$tape_failure_modes [amc$tfm_device_not_ready];
    IFEND;

  PROCEND form_failure_modes;

?? TITLE := 'PROCEDURE [INLINE] form_tape_block_position', EJECT ??

  PROCEDURE [INLINE] form_tape_block_position (VAR tape_position: bat$tape_block_position;
        buffer_group: bat$tape_buffer_group_index;
        buffer_index: bat$tape_block_buffer_index);

    tape_position.buffer_group := buffer_group;
    tape_position.buffer_index := buffer_index;

  PROCEND form_tape_block_position;

?? TITLE := 'PROCEDURE initiate_read', EJECT ??

  PROCEDURE initiate_read (buffer_group: bat$tape_buffer_group_index;
        block_ptr: ^bat$tape_block;
        block_length: amt$max_block_length;
    VAR status: ost$status);

    VAR
      bgd: ^bat$tape_buffer_grp_descriptor,
      read_description: ^iot$read_tape_description,
      buffer_index: bat$tape_block_buffer_index,
      block_buffer_length,
      bytes_to_force_into_memory: integer,
      all_pages_in_memory: boolean,
      page_size: ost$page_size,
      io_id: iot$io_id;

    status.normal := TRUE;

    bgd := bmd^.buffer_group [buffer_group];

    IF bgd^.group_state <> bac$group_empty THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
        'Wrong group state in initiate_read', status);
      RETURN;
    IFEND;

    read_description := ^bgd^.read_description;

    IF block_ptr <> NIL THEN

      IF NOT bmd^.direct_io THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
          'Block pointer given for indirect read in initate_read', status);
        RETURN;
      IFEND;
      bgd^.block_buffer [1].system_media_recovery_used := bmd^.system_media_recovery;
      bgd^.block_buffer [1].attempt_recovery := FALSE;
      read_description^ [1].buffer_area := block_ptr;
      read_description^ [1].block_transfer_length := ^bgd^.block_buffer [1].block_length;
      bgd^.block_buffer [1].block_length.length := 0;
      bgd^.requested_read_length := block_length;
      bytes_to_force_into_memory := block_length;

    ELSE

    /set_up_for_the_read/
      FOR buffer_index := 1 TO bmd^.buffer_group_size DO
        bgd^.block_buffer [buffer_index].system_media_recovery_used := bmd^.system_media_recovery;
        bgd^.block_buffer [buffer_index].attempt_recovery := FALSE;
        read_description^ [buffer_index].buffer_area := bgd^.block_buffer [buffer_index].block_buffer;
        read_description^ [buffer_index].block_transfer_length := ^bgd^.block_buffer [buffer_index].
              block_length;
        bgd^.block_buffer [buffer_index].block_length.length := 0;
      FOREND /set_up_for_the_read/;
      bgd^.requested_read_length := bmd^.max_block_length;
      block_buffer_length := ((bmd^.max_block_length + 7) DIV 8) * 8;
      bytes_to_force_into_memory := block_buffer_length * bmd^.buffer_group_size;
      { round up to a full page }
      page_size := 512 * (128 - #read_register (osc$pr_page_size_mask));
      bytes_to_force_into_memory := ((bytes_to_force_into_memory + page_size - 1) DIV page_size) * page_size;

    IFEND;

    IF bav$use_assign_pages_for_tape THEN
      mmp$check_if_pages_in_memory (read_description^ [1].buffer_area, bytes_to_force_into_memory,
            all_pages_in_memory);
      IF NOT all_pages_in_memory THEN
          mmp$assign_pages (read_description^ [1].buffer_area, bytes_to_force_into_memory,
                FALSE, osc$wait, status);
          IF NOT status.normal THEN
            IF status.condition = mme$assign_length_too_long THEN
              { This condition is ignored.  It indicates that the length of our buffer,  }
              { plus the current working set, exceeds the jobs working set limit.  Since }
              { open processing disallows opening with a MAXBL larger than the working   }
              { set limit we can simply ignore this error and allow the page touching    }
              { algorithm in tape queue manager to bring the pages into the working set. }
            ELSE
              RETURN;
            IFEND;
          IFEND;
      IFEND;
    ELSE
      mmp$advise_in (read_description^ [1].buffer_area, bytes_to_force_into_memory, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    bap$read_tape (bmd^.sfid, bgd^.requested_read_length, read_description, bmd^.buffer_group_size, bmd^.
          system_media_recovery, io_id, status);
    IF status.normal THEN
      bgd^.group_state := bac$group_io_pending;
      bgd^.blks_requested_to_be_transfered := bmd^.buffer_group_size;
      bgd^.io_id := io_id;
    IFEND;

  PROCEND initiate_read;

?? TITLE := 'PROCEDURE initiate_write', EJECT ??

  PROCEDURE initiate_write (buffer_group: bat$tape_buffer_group_index;
        block_ptr: ^bat$tape_block;
        block_length: amt$max_block_length;
    VAR status: ost$status);

    VAR
      group_description: ^bat$tape_buffer_grp_descriptor,
      write_description: ^iot$write_tape_description,
      block_count: iot$tape_block_count,
      i: integer,
      j: integer,
      block_buffer_length: integer,
      bytes_to_force_into_memory: integer,
      all_pages_in_memory: boolean,
      io_id: iot$io_id;

    status.normal := TRUE;

    group_description := bmd^.buffer_group [buffer_group];

    IF group_description^.group_state <> bac$group_contains_data THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
        'Wrong group state in initiate_single_write', status);
      RETURN;
    IFEND;

    write_description := ^bmd^.buffer_group [buffer_group]^.write_description;

    IF block_ptr <> NIL THEN

      IF NOT bmd^.direct_io THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
          'Block pointer given for indirect write in initate_write', status);
        RETURN;
      IFEND;
      write_description^ [1].buffer_area := block_ptr;
      write_description^ [1].transfer_length := block_length;
      block_count := 1;
      bytes_to_force_into_memory := block_length;

    ELSE

      IF bmd^.direct_io THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
          'NIL block pointer given for direct write in initate_write', status);
        RETURN;
      IFEND;

{     When writing, the only group that can have a buffer_index <> 1 is the group at
{     physical_position.  If initiating write on any other group, start from first buffer.

      IF buffer_group = bmd^.physical_position.buffer_group THEN
        j := bmd^.physical_position.buffer_index;
      ELSE
        j := 1;
      IFEND;

      block_count := group_description^.last_buffer_with_data - j + 1;

    /set_up_for_the_write/
      FOR i := 1 TO block_count DO
        write_description^ [i].buffer_area := group_description^.block_buffer [j].block_buffer;
        write_description^ [i].transfer_length := group_description^.block_buffer [j].block_length.length;
        j := j + 1;
      FOREND /set_up_for_the_write/;
      block_buffer_length := ((bmd^.max_block_length + 7) DIV 8) * 8;
      bytes_to_force_into_memory := block_buffer_length * block_count;

    IFEND;

    IF bav$use_assign_pages_for_tape THEN
      mmp$check_if_pages_in_memory (write_description^ [1].buffer_area, bytes_to_force_into_memory,
            all_pages_in_memory);
      IF NOT all_pages_in_memory THEN
        mmp$advise_in (write_description^ [1].buffer_area, bytes_to_force_into_memory, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        mmp$touch_all_pages (write_description^ [1].buffer_area, bytes_to_force_into_memory);
      IFEND;
    ELSE
      mmp$advise_in (write_description^ [1].buffer_area, bytes_to_force_into_memory, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      mmp$touch_all_pages (write_description^ [1].buffer_area, bytes_to_force_into_memory);
    IFEND;
    bap$write_tape (bmd^.sfid, write_description, block_count, bmd^.system_media_recovery, io_id, status);
    IF status.normal THEN
      group_description^.group_state := bac$group_io_pending;
      group_description^.blks_requested_to_be_transfered := block_count;
      group_description^.io_id := io_id;
    IFEND;

  PROCEND initiate_write;

?? TITLE := 'PROCEDURE menu_tape_fatal_error_recovery', EJECT ??

  PROCEDURE menu_tape_fatal_error_recovery
    (    operation_mode: bat$tape_fatal_recovery_mode;
         tape_failure_modes: amt$tape_failure_modes;
     VAR attempt_recovery: boolean;
     VAR attempt_close: boolean;
     VAR status: ost$status);

{ This procedure performs the following algorithm's to allow recovery from a fatal tape error:
{
{  1. Determines (from the passed operation_mode), what menu to present to the operator.
{  2. Will not present a menu (allows fatal error to be returned to tape operator), if the error
{     occurred while a tape was being labelled. Call for write from the module DMM$INITIALIZE_TAPE_VOLUME.
{  3. Sets the VAR parameter booleans (attempt_recovery and attempt_close), and the boolean in each
{     separate read block buffer (attempt_recovery) according to the response chosen by the operator.
{     The operator responses have the options of 1 (attempt_recovery), 2 (NOT attempt_recovery), and
{     3 (attempt_close). The operator options were mapped to local file booleans so the recovery choice
{     is contained within the local file, thus recovery flags are localized and tape recovery will be able
{     to handle asyncronized tape I/O if it comes to be (do a GET without wait and return later for status)!
{  4. If operator response is 1, attempt recovery is set TRUE, the tape involved is unloaded and a mount
{     request is issued to have the tape remounted. The position of the tape at error time is preserved
{     in the tape job unit descriptor. The tape is then positioned to the block prior to where the fatal
{     error occurred. The current position is then verified against the historical position at error time.
{     The attempt_recovery boolean is set TRUE, and a RETURN or exit from the procedure is completed.
{  5. If the operator response is a 2 (No Recovery), both attempt_recovery and attempt_close are set FALSE,
{     and the procedure exited.
{  6. If the operator response is a 3, the VAR boolean attempt_close is set TRUE and the procedure exited.
{     The attempt_close flag will cause the tape subsystem to emulate END_OF_TAPE status and advance to a new
{     tape volume.
{  7. The reassignment of a tape for fatal error recovery must have the tape placed on the same type equipment
{     that caused the fatal error. This is due to the hardware differences in the polynomial generator of the
{     tape controllers causing different block_id's to be generated for the same data block on different
{     equipment. If the polynomial hardware generation for block_id's is the same between different
{     controllers, then those equipments are compatible and can be interchanged for fatal error recovery.


    CONST
      element_name_max = 10;

    VAR
      access_mode: pft$usage_selections,
      bid_index: iot$bid_index,
      count: integer,
      current_volume: amt$volume_number,
      current_vsns: rmt$volume_descriptor,
      density: rmt$density,
      element_name: cmt$element_name,
      historical_position: iot$tape_position,
      i: integer,
      ignore_status: ost$status,
      integer_string: ost$string,
      labelled: boolean,
      label_type: amt$label_type,
      loop: boolean,
      lun: iot$logical_unit,
      number_of_choices: oft$number_of_choices,
      number_of_volumes: amt$volume_number,
      op_mode: bat$tape_fatal_recovery_mode,
      parameter_names: ^ost$parameter_help_names,
      position: iot$tape_position,
      repeat_count: iot$tape_block_count,
      requested_volume_attributes: iot$requested_volume_attributes,
      response: oft$number_of_choices,
      response_string: ost$string,
      recovery_failure_mode: amt$tape_failure_modes,
      seed_name: pmt$program_name,
      string_size: ost$name_size,
      tape_error: amt$tape_failure_mode,
      menu_parameters: array [1 .. 5] of ^ost$message_parameter,
      terminate_reason: string (osc$max_string_size),
      unique: boolean,
      volume_overflow_allowed: boolean,
      write_ring: rmt$write_ring;

    status.normal := TRUE;

{ Set default operator response to not attempt recovery and allow fatal error to occurr.

    attempt_recovery := FALSE;
    attempt_close := FALSE;
    op_mode := operation_mode;
    recovery_failure_mode := tape_failure_modes;

{ No tape fatal error recovery processing done when an INTITIALIZE_TAPE_VOLUME operation caused
{ the fatal error. We do not want to present recovery option menu's when labeling a tape, but
{ simply let the fatal tape error be returned to the operator.

    IF dmv$initialize_tape_volume.in_progress THEN
      RETURN;
    IFEND;

{ Obtain the logical unit number of the tape device involved in the original fatal error call.

    dmp$convert_sfid_to_lun (bmd^.sfid, lun, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$get_tape_volume_information (bmd^.sfid, number_of_volumes, current_volume, current_vsns, density,
          write_ring, requested_volume_attributes, volume_overflow_allowed, label_type,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (label_type = amc$unlabelled) THEN
      labelled := FALSE;
    ELSE
      labelled := TRUE;
    IFEND;

{ Obtain the position of the tape at the original fatal error time.

    iop$get_position_of_tape_file (lun, position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Save as historical position of the tape at error the original fatal error time for
{ comparison when repositioning is complete.

    historical_position := position;

{ Assure uniqueness in historical_bid_window (there is at least 2 block_id's that are different)
{ This only need be done at the time of the original error.  If errors occur during respoitioning,
{ we do not care if the block_id window is unique at that point.

    IF historical_position.unit_type = ioc$reel_to_reel THEN
      unique := FALSE;
    /uniqueness/
      FOR bid_index := LOWERVALUE (iot$bid_index) TO UPPERVALUE (iot$bid_index) - 1 DO
        IF historical_position.historical_bid_window [bid_index] <>
              historical_position.historical_bid_window [bid_index + 1] THEN
          unique := TRUE;
          EXIT /uniqueness/;
        IFEND;
      FOREND /uniqueness/;
    ELSE
      unique := TRUE;  { cartridge tape block_id is always unique
    IFEND;

{ If 32 decimal block_id window has all entries the same, do not attempt recovery.
{ Return with error that was reported at fatal error time.

    IF NOT unique THEN
      RETURN;
    IFEND;

  /tape_fatal_error_recovery/
    WHILE TRUE DO

      response := 2;
      attempt_recovery := FALSE;

      cmp$get_element_name_via_lun (lun, element_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      string_size := clp$trimmed_string_size (element_name);

{ Check if original tape position was at loadpoint and error was on attempting to write 1st record off
{ loadpoint. This check is meaningless if we are here because of an error in reassignement, rewind, or
{ repositioning. The displays for repositioning errors, rewind_errors, reassignment_errors will present the
{ same menu whether we are at loadpoint or away from loadpoint. So if were here because of an error in
{ repositioning, the menu presented indicates the repositioning problem. The additional check for the
{ blocks_from_loadpoint to be zero on a loadpoint check is only to assure everything is as expected. There
{ should never be an occurence where loadpoint is indicated and blocks_from_loadpoint is non-zero (a system
{ error could be inserted for that condition, but we presently will be unable to recover as the historical
{ and current information will not match.

      IF (historical_position.tape_position = ioc$tape_at_loadpoint_position) AND
                  (historical_position.blocks_from_loadpoint = 0) THEN
        IF (labelled) AND ((op_mode = bac$tfrm_fatal_write) OR
              (op_mode = bac$tfrm_fatal_data_write)) THEN
          seed_name := rmc$loadpoint_error_recovery;
          menu_parameters [4] := ^current_vsns.recorded_vsn;
        ELSE

{ Present generic loadpoint menu.

          seed_name := rmc$generic_error_recovery;
          CASE op_mode OF

          = bac$tfrm_fatal_write, bac$tfrm_fatal_data_write =
            PUSH menu_parameters [4]: [5];
            menu_parameters [4]^ := 'write';
            PUSH menu_parameters [5]: [12];
            menu_parameters [5]^ := 'at loadpoint';

          = bac$tfrm_fatal_read =
            PUSH menu_parameters [4]: [4];
            menu_parameters [4]^ := 'read';
            PUSH menu_parameters [5]: [12];
            menu_parameters [5]^ := 'at loadpoint';

          = bac$tfrm_fatal_write_tapemark =
            PUSH menu_parameters [4]: [5];
            menu_parameters [4]^ := 'write';
            PUSH menu_parameters [5]: [33];
            menu_parameters [5]^ := 'at loadpoint (writing a tapemark)';

          = bac$tfrm_fatal_rewind =
            menu_parameters [4] := NIL;
            PUSH menu_parameters [5]: [13];
            menu_parameters [5]^ := 'during rewind';

          = bac$tfrm_repositioning_error =
            menu_parameters [4] := NIL;
            PUSH menu_parameters [5]: [20];
            menu_parameters [5]^ := 'during repositioning';

          = bac$tfrm_reassignment_error =
            menu_parameters [4] := NIL;
            PUSH menu_parameters [5]: [19];
            menu_parameters [5]^ := 'during reassignment';

          ELSE

{ We should never arrive here, as every tape operation calling this procedure is interrogated
{ in the above CASE statement. If we do arrive here, we return original fatal error to user, and
{ set abnormal status.

          osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
            'illegal operation_mode in menu_tape_fatal_error_recovery', status);

            RETURN;
          CASEND;
        IFEND;
      ELSE

{ Present correct menu for tape fatal error recovery out and away from loadpoint.

        CASE op_mode OF

        = bac$tfrm_fatal_data_write =
          seed_name := rmc$write_error_recovery;
          clp$convert_integer_to_string (position.blocks_from_loadpoint + 1, 10, FALSE, integer_string,
                ignore_status);
          menu_parameters [4] := ^integer_string.value(1, integer_string.size);

        = bac$tfrm_fatal_write =
          seed_name := rmc$generic_error_recovery;
          PUSH menu_parameters [4]: [5];
          menu_parameters [4]^ := 'write';
          clp$convert_integer_to_string (position.blocks_from_loadpoint + 1, 10, FALSE, integer_string,
                ignore_status);
          PUSH menu_parameters [5]: [integer_string.size + 9];
          menu_parameters [5]^ (1, 9) := 'at block ';
          menu_parameters [5]^ (10, integer_string.size) := integer_string.value(1, integer_string.size);

        = bac$tfrm_fatal_write_tapemark =
          seed_name := rmc$generic_error_recovery;
          PUSH menu_parameters [4]: [5];
          menu_parameters [4]^ := 'write';
          clp$convert_integer_to_string (position.blocks_from_loadpoint + 1, 10, FALSE, integer_string,
                ignore_status);
          PUSH menu_parameters [5]: [integer_string.size + 30];
          menu_parameters [5]^ (1, 9) := 'at block ';
          menu_parameters [5]^ (10, integer_string.size) := integer_string.value(1, integer_string.size);
          menu_parameters [5]^ (integer_string.size + 10, 21) := ' (writing a tapemark)';

        = bac$tfrm_fatal_read =
          seed_name := rmc$generic_error_recovery;
          PUSH menu_parameters [4]: [4];
          menu_parameters [4]^ := 'read';
          clp$convert_integer_to_string (position.blocks_from_loadpoint + 1, 10, FALSE, integer_string,
                ignore_status);
          PUSH menu_parameters [5]: [integer_string.size + 9];
          menu_parameters [5]^ (1, 9) := 'at block ';
          menu_parameters [5]^ (10, integer_string.size) := integer_string.value(1, integer_string.size);

        = bac$tfrm_fatal_rewind =
          seed_name := rmc$generic_error_recovery;
          menu_parameters [4] := NIL;
          PUSH menu_parameters [5]: [13];
          menu_parameters [5]^ := 'during rewind';

        = bac$tfrm_repositioning_error =
          seed_name := rmc$generic_error_recovery;
          menu_parameters [4] := NIL;
          PUSH menu_parameters [5]: [20];
          menu_parameters [5]^ := 'during repositioning';

        = bac$tfrm_reassignment_error =
          seed_name := rmc$generic_error_recovery;
          menu_parameters [4] := NIL;
          PUSH menu_parameters [5]: [19];
          menu_parameters [5]^ := 'during reassignment';

        ELSE

{ We should not arrive here, as every tape operation calling this procedure is interrogated
{ in the above CASE statement. If we do arrive here, we return original fatal error to user, and
{ set abnormal status.

          osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
            'illegal operation_mode in menu_tape_fatal_error_recovery', status);

          RETURN;
        CASEND;
      IFEND;

{ Set element name in menu.
{ Use the elipse (..) to indicate element name is longer than presented on menu.


      IF string_size <= element_name_max THEN
        menu_parameters [2] := ^element_name (1, string_size);
      ELSE
        PUSH menu_parameters [2]: [element_name_max + 1];
        menu_parameters [2]^ := element_name (1, string_size);
        menu_parameters [2]^ (element_name_max, 2) := '..';
      IFEND;

{ Set external volume serial number (evsn) in menu.

      menu_parameters [1] := ^current_vsns.external_vsn;

{ Place tape_failure_modes on the menu.

      PUSH menu_parameters [3]: [20];
      IF recovery_failure_mode = $amt$tape_failure_modes [] THEN
        menu_parameters [3]^ := 'unknown failure mode';
      ELSE
       /determine_failure_mode/
        FOR tape_error := LOWERVALUE (amt$tape_failure_mode) TO UPPERVALUE (amt$tape_failure_mode) DO
          IF tape_error IN recovery_failure_mode THEN
            CASE tape_error OF
            = amc$tfm_agc_gains_not_set =
              menu_parameters [3]^ := 'agc_gains_not_set';
            = amc$tfm_bad_id_burst =
              menu_parameters [3]^ := 'bad_id_burst';
            = amc$tfm_blank_tape_read =
              menu_parameters [3]^ := 'blank_tape_read';
            = amc$tfm_data_parity_error =
              menu_parameters [3]^ := 'data_parity_error';
            = amc$tfm_device_not_ready =
              menu_parameters [3]^ := 'device_not_ready';
            = amc$tfm_erase_error =
              menu_parameters [3]^ := 'erase_error';
            = amc$tfm_record_fragment =
              menu_parameters [3]^ := 'record_fragment';
            = amc$tfm_hardware_failure =
              menu_parameters [3]^ := 'hardware_failure';
            ELSE
              menu_parameters [3]^ := 'unknown failure mode';
            CASEND;
            EXIT /determine_failure_mode/;
          IFEND;
        FOREND /determine_failure_mode/;
      IFEND;

{ Present correct menu to operator. Number of options presented is either 2 or 3.

      IF (op_mode = bac$tfrm_fatal_data_write) THEN
        number_of_choices := 3;
        PUSH parameter_names: [1 .. number_of_choices];
        parameter_names^ [1] := 'CONTINUE_SAME_VOLUME';
        parameter_names^ [2] := 'NO_RECOVERY';
        parameter_names^ [3] := 'CONTINUE_NEXT_VOLUME';
        ofp$format_operator_menu (seed_name, parameter_names, ^menu_parameters, number_of_choices,
              ofc$removable_media_operator, response, response_string, status);
      ELSE
        number_of_choices := 2;
        PUSH parameter_names: [1 .. number_of_choices];
        parameter_names^ [1] := 'ATTEMPT_RECOVERY';
        parameter_names^ [2] := 'NO_RECOVERY';
        ofp$format_operator_menu (seed_name, parameter_names, ^menu_parameters, number_of_choices,
              ofc$removable_media_operator, response, response_string, status);
      IFEND;

{ All calls to this procedure (MENU_TAPE_FATAL_ERROR_RECOVERY), will investigate two boolean VAR
{ passed parameters upon return from the menu call to determine the operator option chosen (1, 2, 3).
{ If operator response is to attempt recovery, this procedure (prior to retruning to caller) will unload
{ the tape in error and cause a MOUNT message to be issued for the tape in error. If reposition is necessary,
{ the tape is forspaced the correct number of blocks and the ATTEMPT_RECOVERY VAR boolean is set TRUE.
{ Attempt_recovery maps to the Operator choosing Option 1. Option 2 is No Recovery. Option 3 (when presented)
{ will set the VAR boolean ATTEMPT_CLOSE to TRUE. The calling routine will emulate an END_OF_TAPE condition
{ and if the Close Volume succeeds, the writing of data is continued on the next tape Volume assigned.

      IF (response = 1) THEN

{ Unload the tape in error and cause a mount request to be posted for the tape.
{ Force write access_mode default to eliminate access_mode interrogation for unload.

        access_mode := $pft$usage_selections [pfc$shorten, pfc$append, pfc$modify];
        dmp$unload_remount_tape_volume (bmd^.sfid, access_mode, {recovery_remount} TRUE, status);
        IF NOT status.normal THEN
          IF (status.condition = dme$operator_stop) OR (status.condition = dme$termination_condition) THEN
            status.normal := TRUE;  { Return with attempt_recovery = FALSE, original error is returned to user
            RETURN;
          IFEND;

{ Reset the logical unit number as a different unit may have been assigned.
{ If status is abnormal, ignore status and return attempt_recovery = FALSE.  Status
{ may be abnormal if the new volume was not assigned yet.

          dmp$convert_sfid_to_lun (bmd^.sfid, lun, status);
          IF NOT status.normal THEN
            status.normal := TRUE;
            RETURN;
          IFEND;
          recovery_failure_mode := $amt$tape_failure_modes [];
          op_mode := bac$tfrm_reassignment_error;
          CYCLE /tape_fatal_error_recovery/;
        IFEND;

{ Reset the logical unit number as a different unit may have been assigned.

        dmp$convert_sfid_to_lun (bmd^.sfid, lun, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Rewind the tape and reposition (forespace) to the correct physical block.

        bap$rewind_tape (bmd^.sfid, bmd^.non_data_io_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF NOT bmd^.non_data_io_status.normal_completion THEN
          form_failure_modes (bmd^.non_data_io_status, recovery_failure_mode, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          op_mode := bac$tfrm_reassignment_error;
          CYCLE /tape_fatal_error_recovery/;
        IFEND;

{ The following RETURN is made when the fatal error, presently being processed, was not involved
{ in positioning away from loadpoint. See previous mention in this procedure for the redundant
{ check of blocks_from_loadpoint = zero.

        IF ((historical_position.tape_position = ioc$tape_at_loadpoint_position) AND
              (historical_position.blocks_from_loadpoint = 0)) OR
              (operation_mode = bac$tfrm_fatal_rewind) THEN
          attempt_recovery := TRUE;
          RETURN; {<----------
        IFEND;

        IF historical_position.blocks_from_loadpoint = 0 THEN
          osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
            'Block number is zero when attempting to position tape during error recovery', status);
          RETURN;
        IFEND;

        IF historical_position.unit_type = ioc$reel_to_reel THEN

{ The following sequence forspaces the tape to the correct physical block on tape that was
{ correctly processed prior to the block that had the fatal error.

          count := historical_position.blocks_from_loadpoint;
          loop := TRUE;
          repeat_count := ioc$max_tape_blocks_to_process;
          WHILE loop DO
            IF (count > ioc$max_tape_blocks_to_process) THEN
              count := count - ioc$max_tape_blocks_to_process;
            ELSE
              repeat_count := count;
              count := 0;
              loop := FALSE;
            IFEND;
            bap$forspace_tape (bmd^.sfid, repeat_count, bmd^.non_data_io_status, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF (NOT bmd^.non_data_io_status.normal_completion) THEN
              IF (bmd^.non_data_io_status.completion_code = ioc$tapemark_read) THEN
                count := count + bmd^.non_data_io_status.residual_block_count - 1;
                IF count > 0 THEN
                  loop := TRUE;
                IFEND;
              ELSE
                form_failure_modes (bmd^.non_data_io_status, recovery_failure_mode, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                op_mode := bac$tfrm_repositioning_error;
                CYCLE /tape_fatal_error_recovery/;
              IFEND;
            IFEND;
          WHILEND;

        ELSE {cartridge tape

          iop$locate_block (lun, historical_position.last_good_bid, {bid_recovery} FALSE,
                historical_position.tapemarks_from_loadpoint, ioc$lbg_plus_count_minus_1,
                bmd^.non_data_io_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF (NOT bmd^.non_data_io_status.normal_completion) THEN
            form_failure_modes (bmd^.non_data_io_status, recovery_failure_mode, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            op_mode := bac$tfrm_repositioning_error;
            CYCLE /tape_fatal_error_recovery/;
          IFEND;
        IFEND;

{ Obtain the present position of the tape. We should be at the same physical block position on the tape
{ that was correctly processed just prior to the tape fatal error occurring.

        iop$get_position_of_tape_file (lun, position, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Compare the present position of the tape against the historical position saved at fatal error time.

        IF (historical_position.tape_position = position.tape_position) AND
              (historical_position.blocks_from_loadpoint = position.blocks_from_loadpoint) AND
              (historical_position.tapemarks_from_loadpoint = position.tapemarks_from_loadpoint) THEN

          IF position.unit_type = ioc$reel_to_reel THEN
            IF (historical_position.historical_bid_index <> position.historical_bid_index) THEN
              RETURN;
            IFEND;
            FOR bid_index := LOWERBOUND (position.historical_bid_window)
                  TO UPPERBOUND (position.historical_bid_window) DO
              IF (historical_position.historical_bid_window [bid_index] <>
                    position.historical_bid_window [bid_index]) AND
                    NOT (historical_position.historical_bid_window [bid_index] = ioc$error_block_bid) THEN
                RETURN;
              IFEND;
            FOREND;
          ELSE {cartridge tape
            IF (historical_position.last_good_bid.logical_position <> position.last_good_bid.
                  logical_position) THEN
              RETURN;
            IFEND;
          IFEND;
          attempt_recovery := TRUE;
          RETURN; {<----------
        ELSE
          RETURN;
        IFEND;

{ If the Operator chose option of No Recovery, he chose the number 2 option.

    ELSEIF (response = 2) THEN

        IF (op_mode = bac$tfrm_reassignment_error) OR
              (op_mode = bac$tfrm_repositioning_error) THEN
          osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
                'Uncertain tape position on reassignment during fatal error recovery', status);
        ELSEIF (op_mode = bac$tfrm_fatal_read) AND (amc$tfm_data_parity_error IN
              recovery_failure_mode) THEN  { update block count from loadpoint
          iop$update_block_count (bmd^.sfid, status);
        IFEND;
        RETURN; {<----------

{ Option 3 of Close Volume only valid when writing a data record (not on write tapemark, read data, etc.).
{ Also, as previously mentioned, the menu with the Close Volume option is not presented if the tape drive
{ fatal error indicated the tape drive is NOT_READY.

      ELSEIF (op_mode = bac$tfrm_fatal_data_write) AND (response = 3) THEN

        attempt_close := TRUE;
        RETURN; {<----------
      IFEND

    WHILEND /tape_fatal_error_recovery/;

  PROCEND menu_tape_fatal_error_recovery;

?? TITLE := 'PROCEDURE [INLINE] perform_buffered_write', EJECT ??

  PROCEDURE [INLINE] perform_buffered_write (block_ptr: ^bat$tape_block;
        block_length: amt$max_block_length;
    VAR write_completion: tape_write_completion;
    VAR status: ost$status);

    VAR
      buffer_info: ^bat$tape_buffer_information,
      block_to_write: ^bat$tape_block;

    status.normal := TRUE;

    ensure_write_buffer_available (write_completion, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF write_completion.end_of_tape_reflective_spot_hit OR
          (write_completion.error_type <> no_write_error) THEN
      RETURN;
    IFEND;

    buffer_info := ^bmd^.buffer_group [bmd^.logical_position.buffer_group]^.block_buffer [bmd^.
          logical_position.buffer_index];
    block_to_write := buffer_info^.block_buffer;
    IF block_ptr <> block_to_write THEN
      i#move (block_ptr, block_to_write, block_length);
    IFEND;
    buffer_info^.block_length.length := block_length;

    IF bmd^.logical_position.buffer_index = 1 THEN
      bmd^.buffer_group [bmd^.logical_position.buffer_group]^.group_state := bac$group_contains_data;
    IFEND;
    bmd^.buffer_group [bmd^.logical_position.buffer_group]^.last_buffer_with_data := bmd^.logical_position.
          buffer_index;

    { Advance logical_position to point to the next block buffer to use }

    IF bmd^.logical_position.buffer_index < bmd^.buffer_group_size THEN
      bmd^.logical_position.buffer_index := bmd^.logical_position.buffer_index + 1;
    ELSE
      IF bmd^.logical_position.buffer_group < bmd^.buffer_groups_in_use THEN
        form_tape_block_position (bmd^.logical_position, bmd^.logical_position.buffer_group + 1, 1);
      ELSE
        form_tape_block_position (bmd^.logical_position, 1, 1);
      IFEND;
    IFEND;

  PROCEND perform_buffered_write;

?? TITLE := 'PROCEDURE process_data_io_completion', EJECT ??

  PROCEDURE process_data_io_completion (buffer_group: bat$tape_buffer_group_index;
        io_status: iot$tape_io_status;
    VAR write_completion: tape_write_completion;
    VAR status: ost$status);

    VAR
      end_of_tape_reflective_spot_hit: boolean,
      access_mode: pft$usage_selections,
      attempt_close: boolean,
      attempt_recovery: boolean,
      no_write_ring: boolean,
      write_error_encountered: boolean,
      write_failure_modes: amt$tape_failure_modes,
      blocks_transfered: iot$tape_block_count,
      current_write_buffer_index: bat$tape_block_buffer_index,
      group_description: ^bat$tape_buffer_grp_descriptor,
      write_description: ^iot$write_tape_description;

    status.normal := TRUE;
    write_completion := normal_write_completion;

    group_description := bmd^.buffer_group [buffer_group];

    process_tape_io_status (io_status, buffer_group, blocks_transfered, end_of_tape_reflective_spot_hit,
          write_error_encountered, write_failure_modes, no_write_ring, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF bmd^.io_direction = bac$iod_reading THEN

{ The following statements allow the menu call to be bypassed if the abnormal completion was due to
{ a TAPEMARK being read or the non-fatal ALERT CONDITION ENCOUNTERED error was returned (presently means
{ a block was read that was longer than the input buffer provided). The menu call is also bypassed if the
{ error was a TAPE PARITY ERROR and SYSTEM MEDIA RECOVERY was NOT TO BE USED for reading that block or
{ if some other fatal error occurred that performing fatal tape error recovery would not help.

      IF ((NOT io_status.normal_completion) AND NOT (io_status.completion_code = ioc$tapemark_read)) AND
            NOT (io_status.completion_code = ioc$alert_condition_encountered) AND
            NOT (io_status.completion_code = ioc$blank_tape) AND
            NOT (io_status.completion_code = ioc$not_capable_of_density) AND
            NOT (io_status.completion_code = ioc$read_past_phys_eot) THEN

        bmd^.buffer_group [buffer_group] ^.block_buffer [blocks_transfered].attempt_recovery := FALSE;
        IF ((bmd^.buffer_group [buffer_group] ^.block_buffer [blocks_transfered].
              system_media_recovery_used) OR ((io_status.completion_code <> ioc$tape_medium_failure) AND
              NOT (bmd^.buffer_group [buffer_group] ^.block_buffer [blocks_transfered].
              system_media_recovery_used))) THEN

          menu_tape_fatal_error_recovery (bac$tfrm_fatal_read, {failure_mode =}
                bmd^.buffer_group [buffer_group] ^.block_buffer [blocks_transfered].failure_modes,
                attempt_recovery, attempt_close, status);

          IF attempt_recovery THEN

{ Set attempt_recovery boolean in this bad block buffer to cause reread of the block in the direct_io case
{ or the buffered read case where this is the first block in the group.
{ If the error does not occur on the first block in the buffer, 1 is subtracted from blocks_transfered
{ to cause a new buffer to be initiated when the block to be retried is reached.

            bmd^.buffer_group [buffer_group] ^.block_buffer [blocks_transfered].attempt_recovery := TRUE;

            IF blocks_transfered > 1 THEN
              blocks_transfered := blocks_transfered - 1;
              form_tape_block_position (bmd^.physical_position, buffer_group, blocks_transfered);
              group_description^.group_state := bac$group_contains_data;
            ELSE
              group_description^.group_state := bac$group_empty;
            IFEND;
            group_description^.last_buffer_with_data := blocks_transfered;

          ELSE {continue with read processing, which will have a fatal error}
            form_tape_block_position (bmd^.physical_position, buffer_group, blocks_transfered);
            group_description^.group_state := bac$group_contains_data;
            group_description^.last_buffer_with_data := blocks_transfered;
          IFEND;
        ELSE {continue with read processing, which will have a fatal error}
          form_tape_block_position (bmd^.physical_position, buffer_group, blocks_transfered);
          group_description^.group_state := bac$group_contains_data;
          group_description^.last_buffer_with_data := blocks_transfered;
        IFEND;
      ELSE {continue with normal read processing}
        form_tape_block_position (bmd^.physical_position, buffer_group, blocks_transfered);
        group_description^.group_state := bac$group_contains_data;
        group_description^.last_buffer_with_data := blocks_transfered;
      IFEND;

    ELSE { writing }

      IF buffer_group <> bmd^.physical_position.buffer_group THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
              'Not at physical_position when processing data_io_completion of write', status);
        RETURN;
      IFEND;
      current_write_buffer_index := bmd^.physical_position.buffer_index + blocks_transfered;
      write_completion.end_of_tape_reflective_spot_hit := end_of_tape_reflective_spot_hit;
      IF (current_write_buffer_index = group_description^.last_buffer_with_data + 1) THEN
        IF bmd^.physical_position.buffer_group < bmd^.buffer_groups_in_use THEN
          form_tape_block_position (bmd^.physical_position, bmd^.physical_position.buffer_group + 1, 1);
        ELSE
          form_tape_block_position (bmd^.physical_position, 1, 1);
        IFEND;

        group_description^.group_state := bac$group_empty;

        IF write_error_encountered THEN
          IF bmd^.system_media_recovery THEN
            osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
                  'Write error encountered after all write data transferred ', status);
            RETURN;
          ELSE
            write_completion.failure_modes := write_failure_modes;
            write_completion.error_type := write_error_previous_block;
          IFEND;
        IFEND;

      ELSE { not all data was transfered - fatal write error or EOT occurred }

        group_description^.group_state := bac$group_contains_data;

{ Set physical_position.buffer_index to point to the next block to write if I/O is continued.
{ This is the only place physical_position.buffer_index is set <> 1 when writing.

        IF no_write_ring THEN
          bmd^.fatal_write_error := TRUE;
          osp$set_status_abnormal (bac$basic_access_id, bae$no_tape_write_ring, ' ', status);
          RETURN;
        IFEND;

        IF io_status.completion_code = ioc$write_past_phys_eot THEN
          bmd^.fatal_write_error := TRUE;
          osp$set_status_abnormal (bac$basic_access_id, bae$motion_past_phys_eot,
                'Write past physical EOT in process_data_io_completion', status);
          RETURN;
        IFEND;

        IF write_error_encountered THEN
          write_completion.failure_modes := write_failure_modes;
          write_completion.error_type := write_error_previous_block;
        ELSEIF end_of_tape_reflective_spot_hit THEN
          ;
        ELSE
          osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
                'Not all data written in process_data_io_completion -- blocks_transfered =', status);
          osp$append_status_integer (' ', blocks_transfered, 10, TRUE, status);
          RETURN;
        IFEND;

{ The following sequence provides the tape fatal error recovery option to the operator.
{ Tape fatal error recovery will not be attempted if the error occurrs on an INITIALIZE_TAPE_VOLUME command.
{ The direct_io initiate_write call assumes the write_descriptor is intact after processing by the tape_queue_
{ manager subsystem.  Direct_io only processes one block at a time and TQM will not modify the structure.
{ An important fact to note here is the recursive call to 'await_data_io_completion' for processing the tape
{ status of the recovery attempt.

        IF (write_error_encountered) AND (bmd^.system_media_recovery) THEN
          IF (amc$tfm_device_not_ready IN write_failure_modes) THEN
            menu_tape_fatal_error_recovery (bac$tfrm_fatal_write, write_failure_modes, attempt_recovery,
                  attempt_close, status);
          ELSE
            menu_tape_fatal_error_recovery (bac$tfrm_fatal_data_write, write_failure_modes, attempt_recovery,
                  attempt_close, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          form_tape_block_position (bmd^.physical_position, buffer_group, current_write_buffer_index);

          IF attempt_recovery THEN

{ Clear local EOT indicator as EOT processing will be handled by recovery if it occurrs without error.

            end_of_tape_reflective_spot_hit := FALSE;

            IF bmd^.direct_io THEN
              write_description := ^bmd^.buffer_group [buffer_group] ^.write_description;
              initiate_write ({buffer_group =} 1, write_description^ [1].buffer_area,
                    write_description^ [1].transfer_length, status);
            ELSE
              initiate_write (bmd^.physical_position.buffer_group, {block_ptr =} NIL, 1, status);
            IFEND;
            IF NOT status.normal THEN
              RETURN;
            IFEND;

{ Recursive call to await_data_io_completion

{   Remember if hit end of tape reflector before write_completion gets cleared out on recursive call

            bmd^.write_hit_end_of_tape_reflector := bmd^.write_hit_end_of_tape_reflector OR
                  write_completion.end_of_tape_reflective_spot_hit;
            await_data_io_completion (bmd^.physical_position, write_completion, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSEIF attempt_close THEN

{ We will be positioned correctly as we went through reposition to LGB when we decided to abandon
{ recovery. We will be after the LGB of data written/transferred. If the unit status was not ready
{ status, we should not be here because we would not be positioned correctly due to not being able
{ to function the unit to place us prior to the bad block (after LGB) in iop$tape_reposition_b.
{ If the write error occurred on the first physical block of a buffer group, then a backspace is
{ not possible - instead we must set status to attempt to write an end-of-volume trailer label.

            IF (bmd^.physical_position.buffer_index - 1) <> 0 THEN
              bap$backspace_tape (bmd^.sfid, bmd^.physical_position.buffer_index - 1,
                    {use_locate_block} FALSE, bmd^.non_data_io_status, status);
              IF NOT status.normal THEN
                attempt_close := FALSE;
                RETURN;
              IFEND;

              IF NOT (bmd^.non_data_io_status.normal_completion) AND
                    NOT (bmd^.non_data_io_status.completion_code = ioc$tapemark_read) THEN
                attempt_close := FALSE;
                RETURN;
              IFEND;
            IFEND;

{ Set buffer_index to point to first block in buffer group.

            form_tape_block_position (bmd^.physical_position, buffer_group, 1);
            write_completion.end_of_tape_reflective_spot_hit := TRUE;
            write_completion.error_type := no_write_error;
            write_completion.failure_modes := $amt$tape_failure_modes [];
          IFEND;
        ELSE
          form_tape_block_position (bmd^.physical_position, buffer_group, current_write_buffer_index);
        IFEND;

      IFEND; { all data transfered }

      IF end_of_tape_reflective_spot_hit AND NOT bmd^.direct_io AND status.normal AND NOT
            write_error_encountered THEN
        bap$erase_tape (bmd^.sfid, 1, {number_of_erases =} 8, bmd^.non_data_io_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF NOT bmd^.non_data_io_status.normal_completion THEN
          form_failure_modes (bmd^.non_data_io_status, write_completion.failure_modes, status);
          write_completion.error_type := write_error_previous_block;
        IFEND;
      IFEND;
    IFEND; { read or write }

  PROCEND process_data_io_completion;

?? TITLE := 'PROCEDURE process_tape_io_status', EJECT ??

  PROCEDURE process_tape_io_status (tape_status: iot$tape_io_status;
        buffer_group: bat$tape_buffer_group_index;
    VAR blocks_transfered: iot$tape_block_count;
    VAR write_hit_end_of_tape_reflector: boolean;
    VAR write_error_encountered: boolean;
    VAR write_failure_modes: amt$tape_failure_modes;
    VAR no_write_ring: boolean;
    VAR status: ost$status);

    VAR
      i: integer,
      ignore_status: ost$status,
      read_block_type: bat$tape_block_type,
      read_block_truncated: boolean,
      read_failure_modes: amt$tape_failure_modes;

    status.normal := TRUE;
    no_write_ring := FALSE;
    write_hit_end_of_tape_reflector := FALSE;
    write_error_encountered := FALSE;
    write_failure_modes := $amt$tape_failure_modes [];


    blocks_transfered := bmd^.buffer_group [buffer_group]^.blks_requested_to_be_transfered - tape_status.
          residual_block_count;
    IF (tape_status.residual_block_count < 0) OR (tape_status.residual_block_count > bmd^.buffer_group_size)
          THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
        'Out of range tape_status.residual_block_count in process_tape_io_status --', status);
      osp$append_status_integer (' ', tape_status.residual_block_count, 10, TRUE, status);
      RETURN;
    IFEND;

    IF bmd^.io_direction = bac$iod_reading THEN

    /set_initial_block_types/
      FOR i := 1 TO blocks_transfered DO
        bmd^.buffer_group [buffer_group]^.block_buffer [i].block_type := bac$good_data_block;
        bmd^.buffer_group [buffer_group]^.block_buffer [i].block_truncated := FALSE;
        bmd^.buffer_group [buffer_group]^.block_buffer [i].failure_modes := $amt$tape_failure_modes [];
      FOREND /set_initial_block_types/;

      IF NOT tape_status.normal_completion THEN
        { Since the residual block count reflects only those blocks transfered without error, the error }
        { actually occurred on the next block.  Accordingly, we increment the blocks_transfered count here. }
        blocks_transfered := blocks_transfered + 1;
        read_block_truncated := FALSE;

        IF tape_status.completion_code = ioc$tapemark_read THEN
          read_block_type := bac$tapemark;
          read_failure_modes := $amt$tape_failure_modes [];
        ELSE { not a tapemark, must be a genuine read error }
          IF tape_status.completion_code = ioc$alert_condition_encountered THEN
            read_block_type := bac$good_data_block;
            read_block_truncated := tape_status.long_input_block;
          ELSE
            IF bmd^.buffer_group [buffer_group]^.block_buffer [blocks_transfered].block_length.length > 0 THEN
              read_block_type := bac$error_data_block;
            ELSE
              IF tape_status.completion_code = ioc$not_capable_of_density THEN
                read_block_type := bac$density_mismatch;
              ELSEIF tape_status.completion_code = ioc$read_past_phys_eot THEN
                read_block_type := bac$read_past_phys_eot;
              ELSE
                read_block_type := bac$error_without_data;
              IFEND;
            IFEND;
          IFEND;

          IF read_block_truncated OR (bmd^.buffer_group [buffer_group]^.block_buffer [blocks_transfered].
                block_length.length > bmd^.buffer_group [buffer_group]^.requested_read_length) THEN
              { The TAPE PP returns the full  record length, not the length   written to CM, when a   }
              { long_input_block is encountered.  Therefore we must reduce this count to the actual }
              { amount transfered to our buffer. }
            bmd^.buffer_group [buffer_group]^.block_buffer [blocks_transfered].block_length.length := bmd^.
                    buffer_group [buffer_group]^.requested_read_length;
          IFEND;

          form_failure_modes (tape_status, read_failure_modes, status);
          IF NOT status.normal THEN
            clear_other_pending_requests (buffer_group, ignore_status);
            RETURN;
          IFEND;
        IFEND;
        bmd^.buffer_group [buffer_group]^.block_buffer [blocks_transfered].block_type := read_block_type;
        bmd^.buffer_group [buffer_group]^.block_buffer [blocks_transfered].block_truncated :=
              read_block_truncated;
        bmd^.buffer_group [buffer_group]^.block_buffer [blocks_transfered].failure_modes :=
              read_failure_modes;
        bmd^.inhibit_read_ahead := TRUE;

        clear_other_pending_requests (buffer_group, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      IFEND; { normal completion }

    ELSE { writing }

      IF NOT tape_status.normal_completion THEN

        write_error_encountered := TRUE;
        form_failure_modes (tape_status, write_failure_modes, status);
        IF NOT status.normal THEN
          clear_other_pending_requests (buffer_group, ignore_status);
          RETURN;
        IFEND;

        IF (tape_status.completion_code = ioc$no_write_ring) THEN
          no_write_ring := TRUE;
        IFEND;

      IFEND; { normal completion }

      write_hit_end_of_tape_reflector := tape_status.end_of_tape;

      IF (NOT tape_status.normal_completion) OR write_hit_end_of_tape_reflector THEN
        clear_other_pending_requests (buffer_group, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    IFEND;

  PROCEND process_tape_io_status;

?? TITLE := 'PROCEDURE reposition_back_one_block', EJECT ??

  PROCEDURE reposition_back_one_block (VAR failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

    VAR
      ignore_write_completion: tape_write_completion;

    status.normal := TRUE;
    failure_modes := $amt$tape_failure_modes[];

    align_physical_logical_position (ignore_write_completion, status);
    IF NOT status.normal THEN
      failure_modes := ignore_write_completion.failure_modes;
      RETURN;
    IFEND;
    reset_buffer_pointers;

    bap$backspace_tape (bmd^.sfid, {count =} 1, {use_locate_block} FALSE, bmd^.non_data_io_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT bmd^.non_data_io_status.normal_completion THEN
      IF bmd^.non_data_io_status.completion_code = ioc$tapemark_read THEN
        ; { A tapemark is ok }
      ELSE
        form_failure_modes (bmd^.non_data_io_status, failure_modes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        osp$set_status_abnormal (bac$basic_access_id, bae$uncertain_tape_position,
          'Tape position lost in bam$tape_block_manager - reposition_back_one_block', status);
      IFEND;
    IFEND;

  PROCEND reposition_back_one_block;

?? TITLE := 'PROCEDURE reset_buffer_pointers', EJECT ??

  PROCEDURE reset_buffer_pointers;

    VAR
      initial_position: [READ, STATIC, oss$job_paged_literal] bat$tape_block_position := [1, 1];

    VAR
      i: bat$tape_buffer_group_index;

    FOR i := 1 TO bmd^.buffer_groups_in_use DO
      bmd^.buffer_group [i]^.group_state := bac$group_empty;
    FOREND;
    bmd^.logical_position := initial_position;
    bmd^.physical_position := initial_position;
    bmd^.buffer_reserved := FALSE;

  PROCEND reset_buffer_pointers;

?? TITLE := 'PROCEDURE terminate_volume', EJECT ??

  PROCEDURE terminate_volume (VAR write_completion: tape_write_completion;
    VAR status: ost$status);

    { This procedure writes the two tapemarks which indicate the end of a volume }
    { The tape is left positioned BEFORE the two tapemarks .}

    VAR
      attempt_close: boolean,
      attempt_recovery: boolean,
      tapemark_count: 1 .. 2;

    status.normal := TRUE;
    write_completion := normal_write_completion;

  /terminate_the_volume/
    BEGIN

      FOR tapemark_count := 1 TO 2 DO
       /fatal_write_tapemark_loop/
        WHILE TRUE DO
          bap$write_tapemark (bmd^.sfid, bmd^.non_data_io_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF NOT bmd^.non_data_io_status.normal_completion THEN
            write_completion.error_type := write_error_last_block;
            form_failure_modes (bmd^.non_data_io_status, write_completion.failure_modes, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF bmd^.non_data_io_status.completion_code = ioc$no_write_ring THEN
              osp$set_status_abnormal (bac$basic_access_id, bae$no_tape_write_ring,
                    ' ', status);
              bmd^.fatal_write_error := TRUE;
              EXIT /terminate_the_volume/;
            ELSEIF bmd^.non_data_io_status.completion_code = ioc$write_past_phys_eot THEN
              osp$set_status_abnormal (bac$basic_access_id, bae$motion_past_phys_eot,
                    'Write past physical EOT in bap$tape_bm_write_tapemark', status);
              bmd^.fatal_write_error := TRUE;
              EXIT /terminate_the_volume/;
            ELSE
              menu_tape_fatal_error_recovery (bac$tfrm_fatal_write_tapemark, write_completion.failure_modes,
                    attempt_recovery, attempt_close, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

{ Cycle to retry write tapemark if operator chose response of 1 (attempt_recovery).

              IF attempt_recovery THEN
                CYCLE /fatal_write_tapemark_loop/
              IFEND;
              bmd^.fatal_write_error := TRUE;
              EXIT /terminate_the_volume/;
            IFEND;
          IFEND;
          write_completion := normal_write_completion;
          EXIT /fatal_write_tapemark_loop/;
        WHILEND /fatal_write_tapemark_loop/;
      FOREND;

      write_completion.end_of_tape_reflective_spot_hit := bmd^.non_data_io_status.end_of_tape;

    /reposition_before_the_tapemarks/
      FOR tapemark_count := 1 TO 2 DO
        bap$backspace_tape (bmd^.sfid, {count =} 1, {use_locate_block} FALSE, bmd^.non_data_io_status,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF bmd^.non_data_io_status.normal_completion THEN
          { Shouldn't complete normally -- should have hit a tapemark }
          write_completion.error_type := write_error_last_block;
          write_completion.failure_modes := $amt$tape_failure_modes [];
        ELSE { This is the normal case }
          IF bmd^.non_data_io_status.completion_code <> ioc$tapemark_read THEN
            write_completion.error_type := write_error_last_block;
            form_failure_modes (bmd^.non_data_io_status, write_completion.failure_modes, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            EXIT /terminate_the_volume/;
          IFEND;
        IFEND;
      FOREND /reposition_before_the_tapemarks/;

    END /terminate_the_volume/;

  PROCEND terminate_volume;

?? TITLE := 'PROCEDURE validate_call', EJECT ??

  PROCEDURE validate_call (file_id: amt$file_identifier;
        caller_ring: ost$valid_ring;
        access_mode: tape_block_access_mode;
        procedure_name: string ( * );
    VAR file_instance: ^bat$task_file_entry;
    VAR loaded_bmd: ^bat$tape_block_mgmt_descriptor;
    VAR status: ost$status);

    VAR
      tape_descriptor: ^bat$tape_descriptor,
      valid_file_id: boolean;

    bap$validate_file_identifier (file_id, file_instance, valid_file_id);
    IF NOT valid_file_id THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$improper_file_id, 'Improper file id passed to',
            status);
      osp$append_status_parameter (' ', procedure_name, status);
      RETURN;
    IFEND;
    tape_descriptor := bai$tape_descriptor (file_instance);

    CASE access_mode OF
    = open_access =
      { open access allows the block management descriptor pointer  to be NIL }
      validate_non_data_access (file_id, caller_ring, file_instance, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      loaded_bmd := tape_descriptor^.block_management_descriptor;
    = read_access =
      validate_read_access (file_id, caller_ring, file_instance, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      loaded_bmd := tape_descriptor^.block_management_descriptor;
      IF loaded_bmd = NIL THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$improper_file_id,
          'NIL block management descriptor in ', status);
        osp$append_status_parameter (' ', procedure_name, status);
        RETURN;
      IFEND;
    = write_access =
      validate_write_access (file_id, caller_ring, file_instance, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      loaded_bmd := tape_descriptor^.block_management_descriptor;
      IF loaded_bmd = NIL THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$improper_file_id,
          'NIL block management descriptor in ', status);
        osp$append_status_parameter (' ', procedure_name, status);
        RETURN;
      IFEND;
      IF NOT bmd^.tape_has_write_ring THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$no_tape_write_ring, procedure_name, status);
        RETURN;
      IFEND;
    = non_data_transfer_access =
      validate_non_data_access (file_id, caller_ring, file_instance, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      loaded_bmd := tape_descriptor^.block_management_descriptor;
      IF loaded_bmd = NIL THEN
        osp$set_status_abnormal (bac$basic_access_id, bae$improper_file_id,
          'NIL block management descriptor in ', status);
        osp$append_status_parameter (' ', procedure_name, status);
        RETURN;
      IFEND;
    ELSE
      osp$set_status_abnormal (bac$basic_access_id, bae$tape_block_mgr_malfunction,
        'Illegal access mode in validate_call', status);
      RETURN;
    CASEND;

  PROCEND validate_call;

?? TITLE := 'PROCEDURE [INLINE] validate_non_data_access', EJECT ??

  PROCEDURE [INLINE] validate_non_data_access (file_id: amt$file_identifier;
        ring: ost$valid_ring;
        file_instance: ^bat$task_file_entry;
    VAR status: ost$status);

    status.normal := TRUE;

    IF ring > file_instance^.instance_attributes.static_label.ring_attributes.r2 THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$ring_validation_error,
        'non data transfer ring validation error in bam$tape_block_manager_ring3', status);
    IFEND;

  PROCEND validate_non_data_access;

?? TITLE := 'PROCEDURE [INLINE] validate_read_access', EJECT ??

  PROCEDURE [INLINE] validate_read_access (file_id: amt$file_identifier;
        ring: ost$valid_ring;
        file_instance: ^bat$task_file_entry;
    VAR status: ost$status);

    status.normal := TRUE;

    IF ring > file_instance^.instance_attributes.static_label.ring_attributes.r2 THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$ring_validation_error,
        'read ring validation error in bam$tape_block_manager_ring3', status);

    ELSEIF NOT (pfc$read IN file_instance^.instance_attributes.dynamic_label.access_mode) THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$improper_input_attempt,
        'READ access is required to read a tape', status);
    IFEND;

  PROCEND validate_read_access;
?? TITLE := 'PROCEDURE validate_tape_assignment', EJECT ??

  PROCEDURE validate_tape_assignment (
        file_id: amt$file_identifier;
        file_instance: ^bat$task_file_entry;
        sfid: dmt$system_file_id;
        label_type: amt$label_type;
        initial_assignment: boolean;
        next_volume: amt$volume_number;
    VAR status: ost$status);

    VAR
      current_volume: amt$volume_number,
      current_vsns: rmt$volume_descriptor,
      density: rmt$density,
      ignore_label_type: amt$label_type,
      number_of_volumes: amt$volume_number,
      operator_terminated_assignment: boolean,
      requested_volume_attributes: iot$requested_volume_attributes,
      tape_validation: boolean,
      validation_state: bat$tape_validation_state,
      volume_descriptor: rmt$volume_descriptor,
      volume_info: array [1 .. 1] of fmt$volume_info,
      volume_overflow_allowed: boolean,
      write_ring: rmt$write_ring;

    volume_descriptor := blank_tape_volume;
    dmp$get_tape_volume_information (sfid, number_of_volumes, current_volume, current_vsns, density,
          write_ring, requested_volume_attributes, volume_overflow_allowed, ignore_label_type,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF next_volume <= number_of_volumes THEN
      volume_info [1].key := fmc$volume;
      volume_info [1].requested_volume_number := next_volume;
      fmp$get_files_volume_info (file_instance^.local_file_name, volume_info, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF volume_info [1].item_returned THEN
        volume_descriptor.recorded_vsn := volume_info [1].volume.recorded_vsn;
        volume_descriptor.external_vsn := volume_info [1].volume.external_vsn;
      IFEND;
    IFEND;

    bap$fetch_tape_validation (validation_state, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF validation_state <> bac$no_tape_validation THEN
      tape_validation := (validation_state = bac$tape_validation_on);
      rmp$validate_tape_assignment (tape_validation, file_id, file_instance^.local_file_name,
            density, write_ring, label_type, file_instance^.instance_attributes.
            dynamic_label.access_mode, initial_assignment, next_volume, volume_descriptor,
            requested_volume_attributes.removable_media_group, requested_volume_attributes.
            removable_media_location, status);
    ELSE
      rmp$complete_tape_assignment (file_id, file_instance^.local_file_name, density, write_ring,
            label_type, file_instance^.instance_attributes.dynamic_label.access_mode,
            initial_assignment, next_volume, volume_descriptor, requested_volume_attributes.
            removable_media_group, requested_volume_attributes.removable_media_location,
            operator_terminated_assignment, status);
    IFEND;

  PROCEND validate_tape_assignment;

?? TITLE := 'PROCEDURE [INLINE] validate_write_access', EJECT ??

  PROCEDURE [INLINE] validate_write_access (file_id: amt$file_identifier;
        ring: ost$valid_ring;
        file_instance: ^bat$task_file_entry;
    VAR status: ost$status);

    status.normal := TRUE;

    IF ring > file_instance^.instance_attributes.static_label.ring_attributes.r1 THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$ring_validation_error,
        'write ring validation error in bam$tape_block_manager_ring3', status);

    ELSEIF ($pft$usage_selections [pfc$append, pfc$shorten, pfc$modify] * file_instance^.instance_attributes.
          dynamic_label.access_mode) = $pft$usage_selections [] THEN
      osp$set_status_abnormal (bac$basic_access_id, bae$improper_access_attempt,
        'APPEND, SHORTEN or MODIFY is required to write on tape', status);

    IFEND;

  PROCEND validate_write_access;

?? EJECT ??

{
{ This procedure calls BAP$FETCH_TAPE_VALIDATION_R1 to obtain the current tape validation state.
{

  PROCEDURE [XDCL, #GATE] bap$fetch_tape_validation (
    VAR tape_validation_state: bat$tape_validation_state;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      validation_state: bat$tape_validation_state;


    #CALLER_ID (caller_id);
    status.normal := TRUE;
    IF caller_id.ring > osc$tsrv_ring THEN
      IF NOT (avp$configuration_administrator () OR avp$system_displays () OR
               avp$removable_media_operator ()) THEN
        osp$set_status_abnormal ('OF', ofe$sou_not_active,
             'configuration_administration, system_displays, removable_media_operation', status);
        RETURN;
      IFEND;
      osp$verify_system_privilege;
    IFEND;

    bap$fetch_tape_validation_r1 (validation_state, status);
    IF status.normal THEN
      tape_validation_state := validation_state;
    IFEND;
  PROCEND bap$fetch_tape_validation;

?? EJECT ??

{
{ This procedure calls BAP$STORE_TAPE_VALIDATION_R1 to change the tape validation state.
{

  PROCEDURE [XDCL, #GATE] bap$store_tape_validation (
        tape_validation_state: bat$tape_validation_state;
    VAR status: ost$status);

    VAR
      validation_state: bat$tape_validation_state;

    status.normal := TRUE;
    IF NOT avp$configuration_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      RETURN;
    IFEND;

{ Reference input parameter here. If NIL pointer is passed in access violation will be returned to user.

    validation_state := tape_validation_state;
    bap$store_tape_validation_r1 (tape_validation_state, status);

  PROCEND bap$store_tape_validation;

?? EJECT ??

  PROCEDURE [XDCL, #GATE] bap$get_tape_security_state (
    VAR enforce_tape_security: bat$tape_validation_state;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      tape_security_state: bat$tape_validation_state;


    #CALLER_ID (caller_id);
    status.normal := TRUE;
    IF caller_id.ring > osc$tsrv_ring THEN
      IF NOT (avp$configuration_administrator () OR avp$system_displays () OR
               avp$removable_media_operator ()) THEN
        osp$set_status_abnormal ('OF', ofe$sou_not_active,
             'configuration_administration, system_displays, removable_media_operation', status);
        RETURN;
      IFEND;
    IFEND;
    osp$verify_system_privilege;

    bap$get_tape_security_state_r1 (tape_security_state);
    enforce_tape_security := tape_security_state;
  PROCEND bap$get_tape_security_state;
?? EJECT ??


  PROCEDURE [XDCL, #GATE] bap$put_tape_security_state (
        enforce_tape_security: bat$tape_validation_state;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      tape_security_state: bat$tape_validation_state;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    IF caller_id.ring > osc$tsrv_ring THEN
      IF NOT avp$configuration_administrator () THEN
        osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
        RETURN;
      IFEND;
    IFEND;
    osp$verify_system_privilege;

    tape_security_state := enforce_tape_security;
    bap$put_tape_security_state_r1 (tape_security_state);

  PROCEND bap$put_tape_security_state;
MODEND bam$tape_block_manager_ring3;
*DECK DECK=BAM$TASK_CLEANUP EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  BASIC ACCESS METHOD : Task termination cleanup', EJECT ??
MODULE bam$task_cleanup;
?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc oss$job_paged_literal
*copyc oss$task_private
?? POP ??
*copyc bap$close
*copyc bap$validate_file_identifier
*copyc fmp$close_file
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$generate_log_message
*copyc pmp$establish_condition_handler
*copyc pmp$disestablish_cond_handler
*copyc pmd$system_log_interface

*copyc bav$last_tft_entry
*copyc bav$task_file_table
*copyc bav$tft_entry_assignment
*copyc osv$initial_exception_context

?? TITLE := 'Global Declarations Declared by this Module', EJECT ??

  VAR
    bav$task_cleanup_initiated: [XDCL, #GATE, oss$task_private] boolean := FALSE;

?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE [XDCL] bap$monitor_task_term_cleanup', EJECT ??

  PROCEDURE [XDCL] bap$monitor_task_term_cleanup;

{   Purpose:
{     The purpose of this procedure is to close any files which
{     remain open at task termination.  Note that all files should
{     have been previously closed by the bap$loaded_ring_cleanup
{     procedure.  Therefore this procedure should find files open
{     only in the event of some abnormal situation.

    VAR
      file_identifier: amt$file_identifier,
      index: bat$tft_limit;

    IF bav$task_file_table = NIL THEN
      RETURN;
    IFEND;

    FOR index := 1 TO bav$last_tft_entry DO
      IF (bav$tft_entry_assignment^ (index, 1) = fmc$entry_assigned) AND
            (bav$task_file_table^ [index].close_allowed) AND ((bav$task_file_table^ [index].
            module_dynamically_loaded) OR (bav$task_file_table^ [index].
            device_class = rmc$magnetic_tape_device))  THEN
        file_identifier.ordinal := index;
        file_identifier.sequence := bav$task_file_table^ [index].sequence_number;
        close_file_at_task_exit (file_identifier);
      IFEND;
    FOREND;

  PROCEND bap$monitor_task_term_cleanup;
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE [XDCL] bap$task_termination_cleanup', EJECT ??

  PROCEDURE [XDCL] bap$task_termination_cleanup;

{   Purpose:
{     The purpose of this procedure is to close any files which
{     remain open at task termination.  Note that all files should
{     have been previously closed by the bap$loaded_ring_cleanup
{     procedure.  Therefore this procedure should find files open
{     only in the event of some abnormal situation.

    VAR
      file_identifier: amt$file_identifier,
      index: bat$tft_limit;

    IF bav$task_file_table = NIL THEN
      RETURN;
    IFEND;

    FOR index := 1 TO bav$last_tft_entry DO
      IF bav$tft_entry_assignment^ (index, 1) = fmc$entry_assigned THEN
        bav$task_file_table^ [index].close_allowed := TRUE;
        file_identifier.ordinal := index;
        file_identifier.sequence := bav$task_file_table^ [index].sequence_number;
        close_file_at_task_exit (file_identifier);
      IFEND;
    FOREND;

  PROCEND bap$task_termination_cleanup;
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE [XDCL, #GATE] bap$set_task_cleanup_initiated', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$set_task_cleanup_initiated;

    bav$task_cleanup_initiated := TRUE;

  PROCEND bap$set_task_cleanup_initiated;
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE close_file_at_task_exit', EJECT ??

  PROCEDURE close_file_at_task_exit
    (    file_identifier: amt$file_identifier);

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      EXIT close_file_at_task_exit;

    PROCEND condition_handler;

    VAR
      conditions: [READ, STATIC, oss$job_paged_literal] pmt$condition := [pmc$condition_combination,
            [pmc$system_conditions, mmc$segment_access_condition]],
      context: ^ost$ecp_exception_context,
      establish_descriptor: pmt$established_handler,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      ignore_status: ost$status,
      status: ost$status;

    context := NIL;

    pmp$establish_condition_handler (conditions, ^condition_handler, ^establish_descriptor, status);

    REPEAT
      bap$close (file_identifier, status);
      IF osp$file_access_condition (status) THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_file_identifier;
          context^.file.file_identifier := file_identifier;
        IFEND;

        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
        IF NOT context^.wait THEN
          {If ignoring file access condition, ensure open count is decremented.}
          bap$validate_file_identifier (file_identifier, file_instance, file_id_is_valid);
          IF file_id_is_valid THEN
            fmp$close_file (file_instance, ignore_status);
          IFEND;
        IFEND;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
    IF NOT osp$file_access_condition (status) THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], status, ignore_status);
    IFEND;

  PROCEND close_file_at_task_exit;
?? OLDTITLE ??

MODEND bam$task_cleanup;
*DECK DECK=BAM$TRAILING_CHAR_DELIMITED_FAP EXPAND=TRUE
?? RIGHT := 80 ??
*copyc osd$default_pragmats
MODULE bam$trailing_char_delimited_fap;
?? TITLE := 'NOS/VE:  BASIC ACCESS METHOD, TASK SERVICES' ??
?? NEWTITLE := 'COMMON DECLARATIONS' ??
*copyc amc$condition_code_limits
*copyc ame$device_class_validation
*copyc ame$access_validation_errors
*copyc ame$file_organization_errors
*copyc ame$improper_file_id
*copyc ame$ring_validation_errors
*copyc ame$conflicting_access_level
*copyc ame$unimplemented_request
*copyc ame$get_program_actions
*copyc ame$put_program_actions
*copyc ame$fap_validation_errors
*copyc ame$improper_wsl
*copyc ame$put_validation_errors
*copyc ame$get_validation_errors
*copyc ame$open_validation_errors
*copyc ame$improper_random_access
*copyc ame$skip_program_actions
*copyc ame$skip_validation_errors
*copyc amp$set_file_instance_abnormal
*copyc amt$fap_declarations
*copyc bac$minimum_open_ring
*copyc bap$close
*copyc bap$fetch
*copyc bap$fetch_access_information
*copyc bat$block_manager_descriptor
*copyc bat$block_header
*copyc bat$block_position
*copyc bat$global_file_information
*copyc bap$get_segment_pointer
*copyc bap$set_segment_eoi
*copyc bap$set_segment_position
*copyc bap$store
*copyc bap$validate_file_identifier
*copyc bat$task_file_table
*copyc bav$task_file_table
*copyc fme$file_management_errors
*copyc fmv$global_file_information
*copyc i#move
*copyc ife$error_codes
*copyc mmp$set_segment_length
*copyc bap$write_modified_pages
*copyc osd$virtual_address
*copyc osp$set_status_abnormal
*copyc ost$caller_identifier
*copyc pmp$get_job_mode

?? TITLE := 'BAP$TRAILING_CHAR_DELIMITED_FAP', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$trailing_char_delimited_fap
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    CONST
      error_text = 'BAP$TRAILING_CHAR_DELIMITED_FAP - ',
      max_scan_size = 256, { current maximum scan length }
      trailing_char_length_constant = 1;

    TYPE
      set_of_char = set of char;

    VAR
      at_eoi: boolean,
      caller_id: ost$caller_identifier,
      data_ptr: ^cell,
      delimiting_char_set: set_of_char,
      delimiter_ptr: ^char,
      file_byte_address: amt$file_byte_address,
      file_instance: ^bat$task_file_entry,
      found_delimiter: boolean,
      job_mode: jmt$job_mode,
      record_info: bat$record_info,
      scan_byte_address: amt$file_byte_address,
      scan_max: 0 .. max_scan_size,
      scan_size: amt$working_storage_length,
      scan_string: ^string (max_scan_size),
      scanned_piece_size: amt$working_storage_length,
      skip_count: amt$skip_count,
      trailing_char_length: integer,
      validation_ok: boolean;

?? TITLE := 'rollback_procedure', EJECT ??

    PROCEDURE rollback_procedure
      (    condition_status: ost$status);

      status := condition_status;
      file_instance^.rollback_procedure := NIL;
      EXIT bap$trailing_char_delimited_fap;

    PROCEND rollback_procedure;

?? TITLE := 'GET_NEXT', EJECT ??

    PROCEDURE [INLINE] get_next;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_read_access
        IF status.normal THEN

        /main_code_get_next/
          BEGIN

*copy       bai$get_record_info

            IF (record_info.file_position = amc$mid_record) AND
                  (file_instance^.private_read_information = NIL) AND
                  (file_instance^.global_file_information^.
                  last_access_operation = amc$put_partial_req) THEN

{ Must have been left mid_record by a put_partial.  EOI needs updating.

              record_info.file_position := amc$eor;
              update_eoi;
            IFEND;

            IF record_info.file_position = amc$mid_record THEN

{ Move to start of next record.

              scan_to_delimiting_char;

{ Scanned_length includes the delimiter.

              record_info.current_byte_address := scan_byte_address;
            IFEND;

*copy       bai$get_eoi_check

            IF NOT at_eoi THEN

{ Locate eor.

*copy         bai$scan_to_delimiting_char

              data_ptr := #ADDRESS (osc$min_ring,
                    #SEGMENT (file_instance^.file_pva),
                    record_info.current_byte_address);
              record_info.bor_address := record_info.current_byte_address;

              IF call_block.getn.working_storage_length <
                    scan_byte_address - record_info.current_byte_address -
                    trailing_char_length THEN
                record_info.record_length := call_block.getn.
                      working_storage_length;
                record_info.file_position := amc$mid_record;
                record_info.current_byte_address :=
                      record_info.current_byte_address +
                      record_info.record_length;
              ELSE { getting a full record }
                record_info.record_length := scan_byte_address -
                      record_info.current_byte_address - trailing_char_length;
                record_info.file_position := amc$eor;
                record_info.current_byte_address := scan_byte_address;
              IFEND;

{ Move data to user's working_storage_area.

              i#move (data_ptr, call_block.getn.working_storage_area,
                    record_info.record_length);
            ELSE { at eoi }
              record_info.bor_address := record_info.current_byte_address;
              record_info.record_length := 0;
            IFEND; { NOT at eoi }
          END /main_code_get_next/;

*copy     bai$save_record_info

          call_block.getn.file_position^ := record_info.file_position;
          call_block.getn.transfer_count^ := record_info.record_length;
          call_block.getn.byte_address^ := record_info.bor_address;
        IFEND;
      IFEND;
    PROCEND get_next;

?? TITLE := 'PUT_NEXT', EJECT ??

    PROCEDURE [INLINE] put_next;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_write_access
        IF status.normal THEN

        /main_code_put_next/
          BEGIN

            record_info := file_instance^.global_file_information^.
                  positioning_info.record_info;

{ Not necessary to add delimiter if mid_record since all put_partials will
{ write a temporary delimiter.

            record_info.bor_address := record_info.current_byte_address;

{ Check to make sure we do not go over the 2 GB file limit.

            IF file_instance^.global_file_information^.file_limit <
                  record_info.current_byte_address +
                  call_block.putn.working_storage_length +
                  trailing_char_length_constant THEN
              amp$set_file_instance_abnormal (file_identifier,
                  ame$put_beyond_file_limit, call_block.operation, error_text,
                  status);
              EXIT /main_code_put_next/;
            IFEND;

{ Write data to file.

            data_ptr := #ADDRESS (osc$min_ring,
                  #SEGMENT (file_instance^.file_pva),
                  record_info.current_byte_address);
            i#move (call_block.putn.working_storage_area, data_ptr,
                  call_block.putn.working_storage_length);

{ Write trailing_character_delimiter

            delimiter_ptr := #ADDRESS (osc$min_ring, #SEGMENT (data_ptr),
                  #OFFSET (data_ptr) + call_block.putn.working_storage_length);
            delimiter_ptr^ := file_instance^.global_file_information^.
                  record_delimiting_character;

            record_info.current_byte_address :=
                  record_info.current_byte_address +
                  call_block.putn.working_storage_length +
                        trailing_char_length_constant;
            record_info.file_position := amc$eor;
            record_info.record_length := call_block.putn.working_storage_length;

*copy       bai$update_eoi

            file_instance^.instance_of_open_modified := TRUE;

          END /main_code_put_next/;

          file_instance^.global_file_information^.positioning_info.
                record_info := record_info;
          IF call_block.operation = amc$put_next_req THEN
            call_block.putn.byte_address^ := record_info.bor_address;
          IFEND;
        IFEND;
      IFEND;
    PROCEND put_next;

?? TITLE := 'GET_PARTIAL', EJECT ??

    PROCEDURE [INLINE] get_partial;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_read_access
        IF status.normal THEN
          IF (call_block.getp.skip_option < LOWERVALUE (amt$skip_option)) OR
                (call_block.getp.skip_option > UPPERVALUE (amt$skip_option))
                THEN
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_skip_option, call_block.operation, error_text,
                  status);
          ELSE

          /main_code_get_partial/
            BEGIN

*copy         bai$get_record_info

              IF (record_info.file_position = amc$mid_record) AND
                    (file_instance^.private_read_information = NIL) AND
                    (file_instance^.global_file_information^.
                    last_access_operation = amc$put_partial_req) THEN

{ Must have been left mid_record by a put_partial.  EOI needs updating.

                record_info.file_position := amc$eor;
                update_eoi;
              IFEND;

              IF (record_info.file_position = amc$mid_record) AND
                    (call_block.getp.skip_option = amc$skip_to_eor) THEN
                scan_to_delimiting_char;
                record_info.current_byte_address := scan_byte_address;
                record_info.file_position := amc$eor;
              IFEND;

*copy         bai$get_eoi_check

              IF NOT at_eoi THEN

{ Locate delimiter.

                data_ptr := #ADDRESS (osc$min_ring,
                      #SEGMENT (file_instance^.file_pva),
                      record_info.current_byte_address);
*copy           bai$scan_to_delimiting_char

                IF record_info.file_position <> amc$mid_record THEN
                  record_info.bor_address := record_info.current_byte_address;
                IFEND;

                IF call_block.getp.working_storage_length <
                      scan_byte_address - record_info.current_byte_address -
                      trailing_char_length THEN
                  record_info.record_length := call_block.getp.
                        working_storage_length;
                  record_info.file_position := amc$mid_record;
                  record_info.current_byte_address :=
                        record_info.current_byte_address +
                        record_info.record_length;
                ELSE { getting a full record }
                  record_info.record_length := scan_byte_address -
                        record_info.current_byte_address - trailing_char_length;
                  record_info.file_position := amc$eor;
                  record_info.current_byte_address := scan_byte_address;
                IFEND;

                i#move (data_ptr, call_block.getp.working_storage_area,
                      record_info.record_length);

{ Get transfer count before resetting record_length to sum of transfer counts.

                call_block.getp.transfer_count^ := record_info.record_length;

{ Remember that record_length is the sum of get_partial transfer_counts.

                IF record_info.file_position = amc$eor THEN
                  record_info.record_length := record_info.
                        current_byte_address - record_info.bor_address -
                        trailing_char_length;
                ELSE
                  record_info.record_length := record_info.
                        current_byte_address - record_info.bor_address;
                IFEND;
              ELSE { at eoi }
                record_info.record_length := 0;
                call_block.getp.transfer_count^ := record_info.record_length;
              IFEND;
            END /main_code_get_partial/;
*copy       bai$save_record_info

            call_block.getp.file_position^ := record_info.file_position;
            call_block.getp.record_length^ := record_info.record_length;
            call_block.getp.byte_address^ := record_info.bor_address;
          IFEND;
        IFEND;
      IFEND;
    PROCEND get_partial;

?? TITLE := 'PUT_PARTIAL', EJECT ??

    PROCEDURE [INLINE] put_partial;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_write_access
        IF status.normal THEN
          IF (call_block.putp.term_option < LOWERVALUE (amt$term_option)) OR
                (call_block.putp.term_option > UPPERVALUE (amt$term_option))
                THEN
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_term_option, call_block.operation, error_text,
                  status);
          ELSE

          /main_code_put_partial/
            BEGIN

              record_info := file_instance^.global_file_information^.
                    positioning_info.record_info;

{ Figure out if starting or continuing a record.

              CASE call_block.putp.term_option OF
              = amc$start =
                IF (record_info.file_position = amc$mid_record) AND
                      (file_instance^.global_file_information^.
                      last_access_operation = amc$put_partial_req) THEN

{ Terminate_last record before starting new record.

                  update_eoi;
                IFEND;
                record_info.bor_address := record_info.current_byte_address;
                record_info.file_position := amc$mid_record;
              = amc$continue =
                IF record_info.file_position <> amc$mid_record THEN
                  amp$set_file_instance_abnormal (file_identifier,
                        ame$improper_continue, call_block.operation, ' ',
                        status);
                  EXIT /main_code_put_partial/;
                IFEND;
                IF (record_info.file_position = amc$mid_record) AND
                      (file_instance^.global_file_information^.
                      last_access_operation = amc$put_partial_req) THEN

{ Must skip backwards over the temporary delimiter.

                  record_info.current_byte_address :=
                        record_info.current_byte_address -
                        trailing_char_length_constant;
                IFEND;
              = amc$terminate =
                IF record_info.file_position = amc$mid_record THEN
                  IF file_instance^.global_file_information^.
                        last_access_operation = amc$put_partial_req THEN

{ Must skip backwards over the temporary delimiter.

                    record_info.current_byte_address :=
                        record_info.current_byte_address -
                        trailing_char_length_constant;
                  IFEND;
                ELSE
                  record_info.bor_address := record_info.current_byte_address;
                IFEND;
                record_info.file_position := amc$eor;
              ELSE
              CASEND;

{ Check to make sure we do not go over the 2 GB file limit.

              IF file_instance^.global_file_information^.file_limit <
                    record_info.current_byte_address +
                    call_block.putn.working_storage_length +
                    trailing_char_length_constant THEN
                amp$set_file_instance_abnormal (file_identifier,
                    ame$put_beyond_file_limit, call_block.operation, error_text,
                    status);
                EXIT /main_code_put_partial/;
              IFEND;

              data_ptr := #ADDRESS (osc$min_ring,
                    #SEGMENT (file_instance^.file_pva),
                    record_info.current_byte_address);
              i#move (call_block.putn.working_storage_area, data_ptr,
                    call_block.putn.working_storage_length);

{ Write trailing_character_delimiter. Delimiter will be temporary if the
{ record is continued. This guarantees a delimiter at eoi.

              delimiter_ptr := #ADDRESS (osc$min_ring, #SEGMENT (data_ptr),
                    #OFFSET (data_ptr) + call_block.putn.
                    working_storage_length);
              delimiter_ptr^ := file_instance^.global_file_information^.
                    record_delimiting_character;

              record_info.current_byte_address :=
                    record_info.current_byte_address +
                    call_block.putp.working_storage_length +
                    trailing_char_length_constant;
              record_info.record_length := record_info.current_byte_address -
                    record_info.bor_address - trailing_char_length_constant;

              IF call_block.putp.term_option = amc$terminate THEN
*copy           bai$update_eoi
              IFEND;

              file_instance^.instance_of_open_modified := TRUE;

            END /main_code_put_partial/;

            file_instance^.global_file_information^.positioning_info.
                  record_info := record_info;
            call_block.putp.byte_address^ := record_info.bor_address;
          IFEND;
        IFEND;
      IFEND;
    PROCEND put_partial;

?? TITLE := 'PROCEDURE [INLINE] SKIP', EJECT ??

    PROCEDURE [INLINE] skip;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSEIF NOT (pfc$read IN file_instance^.instance_attributes.dynamic_label.
            access_mode) THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$skip_requires_read_perm, call_block.operation, error_text,
              status);
      ELSEIF call_block.skp.unit <> amc$skip_record THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_skip_unit,
              call_block.operation, error_text, status);
      ELSE

      /main_code_skip/
        BEGIN

        /skip_loop/
          BEGIN

*copy     bai$get_record_info

            IF (record_info.file_position = amc$mid_record) AND
                  (file_instance^.private_read_information = NIL) AND
                  (file_instance^.global_file_information^.
                  last_access_operation = amc$put_partial_req) THEN

{ Must have been left mid_record by a put_partial.  EOI needs updating.

              record_info.file_position := amc$eor;
              update_eoi;
            IFEND;

            skip_count := call_block.skp.count;

            CASE call_block.skp.direction OF
            = amc$forward =
              IF record_info.file_position = amc$mid_record THEN
                scan_to_delimiting_char;
                record_info.current_byte_address := scan_byte_address;
                record_info.file_position := amc$eor;
              ELSE
                scan_byte_address := record_info.current_byte_address;
              IFEND;
              IF skip_count > 0 THEN
                WHILE (skip_count > 0) AND (scan_byte_address <
                      file_instance^.global_file_information^.eoi_byte_address) DO
*copy             bai$scan_to_delimiting_char
                  skip_count := skip_count - 1;
                  record_info.current_byte_address := scan_byte_address;
                WHILEND;
                IF (scan_byte_address = file_instance^.global_file_information^.
                      eoi_byte_address) AND (skip_count <> 0) THEN
                  record_info.file_position := amc$eoi;
                  amp$set_file_instance_abnormal (file_identifier,
                        ame$skip_encountered_eoi, amc$skip_req, 'RECORDS',
                        status);
                ELSE
                  record_info.file_position := amc$eor;
                IFEND;
              IFEND;
            = amc$backward =

              scan_byte_address := record_info.current_byte_address;

              IF record_info.file_position = amc$mid_record THEN

{ Always position to beginning of current record.
{ Remember that mid_record position is after a temporary delimiter.

                backscan_to_delimiting_char;
                record_info.file_position := amc$eor;
              ELSEIF scan_byte_address > 0 THEN

{ Back up over the delimiting_char in preparation to finding start of the
{ next record.  Note that it is NOT necessary to check for a missing
{ delimiting character at the end of the file.  If the file is at EOI and the
{ final delimiter is missing, it is NOT NECESSARY to back up, but it doesn't
{ alter the result if it is done.

                scan_byte_address := scan_byte_address -
                      trailing_char_length_constant;
              IFEND;

              IF skip_count > 0 THEN
                WHILE (skip_count > 0) AND (scan_byte_address <> 0) DO
                  backscan_to_delimiting_char;
                  skip_count := skip_count - 1;
                WHILEND;

{ Will be positioned after the delimiting_char or at boi.

                IF scan_byte_address = 0 THEN
                  IF skip_count = 0 THEN
                    record_info.file_position := amc$eor;
                  ELSE
                    record_info.file_position := amc$boi;
                    amp$set_file_instance_abnormal (file_identifier,
                          ame$skip_encountered_boi, amc$skip_req, 'RECORDS',
                          status);
                  IFEND;
                ELSE
                  record_info.file_position := amc$eor;
                  scan_byte_address := scan_byte_address + 1;
                IFEND;
              IFEND;
            CASEND;
          END /skip_loop/;

          record_info.bor_address := scan_byte_address;
          record_info.current_byte_address := scan_byte_address;

*copy     bai$save_record_info

          file_instance^.residual_skip_count := skip_count;

        END /main_code_skip/;
        call_block.skp.file_position^ := record_info.file_position;
      IFEND;
    PROCEND skip;

?? TITLE := 'PROCEDURE [INLINE] SEEK_DIRECT', EJECT ??

    PROCEDURE [INLINE] seek_direct;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$seek_validation
        IF NOT status.normal THEN
          RETURN;
        IFEND;

*copy   bai$get_record_info

        IF (record_info.file_position = amc$mid_record) AND
              (file_instance^.private_read_information = NIL) AND
              (file_instance^.global_file_information^.last_access_operation =
              amc$put_partial_req) THEN

{ Must have been left mid_record by a put_partial.  EOI needs updating.

          record_info.file_position := amc$eor;
          update_eoi;
        IFEND;

        IF (record_info.current_byte_address = file_byte_address) THEN
          IF record_info.file_position = amc$mid_record THEN

{ Seek must position to a record boundary or it is an error.

            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_seek_address, call_block.operation, error_text,
                  status);
          IFEND;

{ IF the seek is to the address the file is already at then it is a no-op.

          RETURN;
        IFEND;

        IF (file_byte_address > 0) AND
              (file_byte_address < file_instance^.global_file_information^.
              eoi_byte_address) AND
              ((file_instance^.instance_attributes.static_label.
              file_organization = amc$sequential) OR
              ((file_instance^.instance_attributes.static_label.
              file_organization = amc$byte_addressable) AND
              (call_block.operation = amc$get_direct_req))) THEN
          delimiter_ptr := #ADDRESS (osc$min_ring,
                #SEGMENT (file_instance^.file_pva), file_byte_address - 1);
          IF delimiter_ptr^ <> file_instance^.global_file_information^.
                record_delimiting_character THEN

{ Seek must position to a record boundary or it is an error.

            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_seek_address, call_block.operation, error_text,
                  status);
            RETURN;
          IFEND;
        IFEND;

        record_info.current_byte_address := file_byte_address;
        record_info.file_position := amc$eor;

*copy   bai$save_record_info

      IFEND;
    PROCEND seek_direct;

?? TITLE := 'PROCEDURE backscan_to_delimiting_char', EJECT ??

    PROCEDURE backscan_to_delimiting_char;

{ This code scans backwards until it finds boi or a delimiter, and assumes that
{ the scan_byte_address starts and ends on a delimiter if one is found.

      found_delimiter := FALSE;
      scan_max := max_scan_size;

      WHILE (scan_byte_address >= 1) AND (NOT found_delimiter) DO
        IF scan_byte_address < max_scan_size THEN
          scan_max := scan_byte_address;
        IFEND;

        scan_string := #ADDRESS (osc$min_ring,
              #SEGMENT (file_instance^.file_pva), scan_byte_address - scan_max);

      /backscan_loop/
        FOR scanned_piece_size := scan_max DOWNTO 1 DO
          IF scan_string^ (scanned_piece_size) =
                file_instance^.global_file_information^.
                record_delimiting_character THEN
            found_delimiter := TRUE;
            EXIT /backscan_loop/;
          IFEND;
        FOREND /backscan_loop/;

{ Note: Scanned_piece_size is really the unscanned piece size in this usage.
{       Indexing a string starts from 1, but offsets in file start from 0,
{       so scanned_piece_size must be decremented to get true file offset.

        scan_byte_address := (scan_byte_address - scan_max) +
              (scanned_piece_size - 1);

      WHILEND;

    PROCEND backscan_to_delimiting_char;
?? TITLE := 'PROCEDURE scan_to_delimiting_char', EJECT ??

    PROCEDURE scan_to_delimiting_char;

*copy bai$scan_to_delimiting_char

    PROCEND scan_to_delimiting_char;
?? TITLE := 'PROCEDURE update_eoi', EJECT ??

    PROCEDURE update_eoi;

*copy bai$update_eoi

    PROCEND update_eoi;
?? TITLE := 'PROCEDURE terminate_record', EJECT ??
    PROCEDURE terminate_record;

      IF (file_instance^.private_read_information = NIL) AND
            (file_instance^.global_file_information^.positioning_info.
            record_info.file_position = amc$mid_record) AND
            (file_instance^.global_file_information^.
            last_access_operation = amc$put_partial_req) THEN

{ Must have been left mid_record by a put_partial.  EOI needs updating.

        record_info := file_instance^.global_file_information^.
              positioning_info.record_info;
        update_eoi;
        file_instance^.global_file_information^.positioning_info.
              record_info := record_info;
      IFEND;

    PROCEND terminate_record;
?? TITLE := 'MAIN CODE OF BAP$TRAILING_CHAR_DELIMITED_FAP', EJECT ??

    #CALLER_ID (caller_id);
    status.normal := TRUE;

  /process_fap_request/
    BEGIN
      bap$validate_file_identifier (file_identifier, file_instance,
            validation_ok);
      IF NOT validation_ok THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
              error_text, status);
        RETURN;
      ELSE

      /main_code_fap/
        BEGIN
          delimiting_char_set := $set_of_char
                [file_instance^.global_file_information^.
                record_delimiting_character];

          file_instance^.rollback_procedure := ^rollback_procedure;
          CASE call_block.operation OF
          = amc$get_next_req =
            get_next;
          = amc$put_next_req =
            put_next;
          = amc$get_partial_req =
            get_partial;
          = amc$put_partial_req =
            put_partial;
          = amc$open_req =
            ;
          = amc$close_req =
            terminate_record;
            bap$close (file_identifier, status);
            EXIT /process_fap_request/;
          = amc$rewind_req =
            terminate_record;
*copy       bai$rewind
          = amc$seek_direct_req =
            file_byte_address := call_block.seekd.byte_address;
            seek_direct;
          = amc$get_direct_req =
            file_byte_address := call_block.getd.byte_address;
            seek_direct;
            IF NOT status.normal THEN
              IF status.condition = ame$position_beyond_eoi THEN
                status.condition := ame$input_after_eoi;
              IFEND;
            ELSE
              get_next;
            IFEND;
          = amc$put_direct_req =
            file_byte_address := call_block.putd.byte_address;
            seek_direct;
            IF status.normal THEN
              put_next;
            IFEND;
          = amc$skip_req =
            skip;
          = amc$fetch_access_information_rq =
            bap$fetch_access_information (file_identifier, call_block,
                  layer_number, status);
            EXIT /process_fap_request/;
          = amc$fetch_req =
            bap$fetch (file_identifier, call_block, layer_number, status);
            EXIT /process_fap_request/;
          = amc$get_segment_pointer_req =
            bap$get_segment_pointer (file_identifier, call_block, layer_number,
                  status);
          = amc$set_segment_eoi_req =
            bap$set_segment_eoi (file_identifier, call_block, layer_number,
                  status);
          = amc$set_segment_position_req =
            bap$set_segment_position (file_identifier, call_block, layer_number,
                  status);
          = amc$replace_req, amc$write_end_partition_req =
            amp$set_file_instance_abnormal (file_identifier,
                  ame$unsupported_operation, call_block.operation, error_text,
                  status);
          = amc$store_req =
            bap$store (file_identifier, call_block, layer_number, status);
          = amc$write_tape_mark_req, amc$close_volume_req =
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_device_class, call_block.operation,
                  'MASS_STORAGE', status);
          = amc$flush_req =
            bap$write_modified_pages (file_instance, file_identifier, status);
          = ifc$fetch_terminal_req, ifc$store_terminal_req =
            pmp$get_job_mode (job_mode, status);
            IF status.normal THEN
              IF job_mode = jmc$batch THEN
                osp$set_status_abnormal (ifc$interactive_facility_id,
                      ife$current_job_not_interactive,
                      'FETCH/STORE_TERMINAL_REQ', status);
              ELSE
                amp$set_file_instance_abnormal (file_identifier,
                      ame$improper_device_class, call_block.operation,
                      'MASS STORAGE', status);
              IFEND;
            IFEND;
          ELSE { NO CASE }
            amp$set_file_instance_abnormal (file_identifier,
                  ame$unimplemented_request, call_block.operation,
                  ' for sequential or byte addressable files', status);
          CASEND;
        END /main_code_fap/;
      IFEND; { validate_file_identifier }

      IF file_instance^.private_read_information = NIL THEN
        IF status.normal THEN
          file_instance^.global_file_information^.error_status := 0;
        ELSE
          file_instance^.global_file_information^.error_status :=
                status.condition;
        IFEND;
        file_instance^.global_file_information^.last_access_operation :=
              call_block.operation;
      ELSE
        IF status.normal THEN
          file_instance^.private_read_information^.error_status := 0;
        ELSE
          file_instance^.private_read_information^.error_status :=
                status.condition;
        IFEND;
        file_instance^.private_read_information^.last_access_operation :=
              call_block.operation;
      IFEND;
    END /process_fap_request/;

    file_instance^.rollback_procedure := NIL;

  PROCEND bap$trailing_char_delimited_fap;
MODEND bam$trailing_char_delimited_fap;
*DECK DECK=BAM$US_BLK_FIXED_REC_FAP EXPAND=TRUE
?? RIGHT := 80 ??
*copyc osd$default_pragmats
MODULE bam$us_blk_fixed_rec_fap;
?? TITLE := 'NOS/VE:  BASIC ACCESS METHOD, TASK SERVICES' ??
?? NEWTITLE := 'COMMON DECLARATIONS' ??
*copyc amc$condition_code_limits
*copyc ame$access_validation_errors
*copyc ame$conflicting_access_level
*copyc ame$device_class_validation
*copyc ame$fap_validation_errors
*copyc ame$file_organization_errors
*copyc ame$get_program_actions
*copyc ame$get_validation_errors
*copyc ame$improper_file_id
*copyc ame$improper_random_access
*copyc ame$improper_wsl
*copyc ame$open_validation_errors
*copyc ame$put_program_actions
*copyc ame$put_validation_errors
*copyc ame$skip_program_actions
*copyc ame$skip_validation_errors
*copyc ame$ring_validation_errors
*copyc ame$unimplemented_request
*copyc amp$set_file_instance_abnormal
*copyc amt$fap_declarations
*copyc bac$minimum_open_ring
*copyc bap$close
*copyc bap$fetch
*copyc bap$fetch_access_information
*copyc bat$block_header
*copyc bat$block_info
*copyc bat$global_file_information
*copyc bat$positioning_info
*copyc bap$get_segment_pointer
*copyc bap$set_segment_eoi
*copyc bap$set_segment_position
*copyc bap$store
*copyc bap$validate_file_identifier
*copyc bat$task_file_table
*copyc bav$default_block_info
*copyc bav$task_file_table
*copyc bav$default_record_info
*copyc fmv$global_file_information
*copyc i#move
*copyc ife$error_codes
*copyc mmp$set_segment_length
*copyc bap$write_modified_pages
*copyc osd$virtual_address
*copyc osp$set_status_abnormal
*copyc ost$caller_identifier
*copyc pmp$get_job_mode

?? TITLE := 'BAP$US_BLK_FIXED_REC_FAP', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$us_blk_fixed_rec_fap
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    CONST
      error_text = 'BAP$US_BLK_FIXED_REC_FAP - ';

    VAR
      at_eoi: boolean,
      block_header: ^bat$block_header,
      block_info: bat$block_info,
      block_padding_string: string (40),
      caller_id: ost$caller_identifier,
      data_length: amt$file_byte_address,
      data_ptr: ^cell,
      default_padding_string: string (80),
      file_byte_address: amt$file_byte_address,
      file_instance: ^bat$task_file_entry,
      i: integer,
      job_mode: jmt$job_mode,
      padding_area: ^cell,
      padding_character: char,
      padding_length: 0 .. amc$maximum_block - 1,
      record_info: bat$record_info,
      validation_ok: boolean,
      working_storage_area: ^char,
      wsa: ^cell,
      wsl: amt$working_storage_length;

?? TITLE := 'rollback_procedure', EJECT ??

    PROCEDURE rollback_procedure
      (    condition_status: ost$status);

      status := condition_status;
      file_instance^.rollback_procedure := NIL;
      EXIT bap$us_blk_fixed_rec_fap;

    PROCEND rollback_procedure;
?? TITLE := 'GET_NEXT', EJECT ??

    PROCEDURE [INLINE] get_next;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_read_access
        IF status.normal THEN

        /main_code_get_next/
          BEGIN

*copy       bai$get_positioning_info

            block_header := #ADDRESS (osc$min_ring,
                  #SEGMENT (file_instance^.file_pva),
                  block_info.current_block_byte_address);
            IF block_info.current_block_byte_address <
                  file_instance^.global_file_information^.eoi_byte_address THEN
*copy         bai$validate_block_header
              IF NOT status.normal THEN
                EXIT /main_code_get_next/;
              IFEND;
            IFEND;

            IF (record_info.file_position = amc$mid_record) AND
                  (file_instance^.private_read_information = NIL) AND
                  (file_instance^.global_file_information^.
                  last_access_operation = amc$put_partial_req) THEN
              pad_record_proc;
              IF (record_info.current_byte_address >=
                    file_instance^.global_file_information^.eoi_byte_address) OR
                    (file_instance^.instance_attributes.static_label.
                    file_organization <> amc$byte_addressable) THEN
                block_header^.block_length := record_info.
                      current_byte_address - (block_info.
                      current_block_byte_address + #SIZE (bat$block_header));
              IFEND;

              update_eoi;
            IFEND; { mid_record, putp, global }

            IF record_info.file_position = amc$mid_record THEN
              record_info.current_byte_address :=
                    record_info.bor_address + file_instance^.
                    global_file_information^.max_record_length;
            IFEND;

*copy       bai$get_eoi_check

            IF NOT at_eoi THEN

{ Residual_block_length tracks length of data left to read in a block.
{ Residual_record_length tracks length of data left to read in a record.

              record_info.residual_record_length :=
                    file_instance^.global_file_information^.max_record_length;

              IF record_info.current_byte_address MOD
                    file_instance^.global_file_information^.max_block_size <>
                    0 THEN
                block_info.residual_block_length :=
                      block_info.current_block_byte_address +
                      block_header^.block_length + #SIZE (bat$block_header) -
                      record_info.current_byte_address;
              ELSE { on a block header }
                block_info.residual_block_length := block_header^.block_length;
                record_info.current_byte_address :=
                      record_info.current_byte_address +
                      #SIZE (bat$block_header);
              IFEND;

              IF block_info.residual_block_length <
                    file_instance^.global_file_information^.
                    max_record_length THEN

{ Note: must be another record or we would be at_eoi so move to next block.

                block_info.current_block_byte_address :=
                      block_info.current_block_byte_address +
                      file_instance^.global_file_information^.max_block_size;
                block_header := #ADDRESS (osc$min_ring,
                      #SEGMENT (file_instance^.file_pva),
                      block_info.current_block_byte_address);
*copy           bai$validate_block_header
                IF NOT status.normal THEN
                  EXIT /main_code_get_next/;
                IFEND;
                record_info.current_byte_address :=
                      block_info.current_block_byte_address +
                      #SIZE (bat$block_header);
                block_info.residual_block_length := block_header^.block_length;
              IFEND;

              IF call_block.getn.working_storage_length >=
                    file_instance^.global_file_information^.
                    max_record_length THEN
                record_info.record_length := file_instance^.
                      global_file_information^.max_record_length;
                record_info.file_position := amc$eor;
              ELSE
                record_info.record_length := call_block.getn.
                      working_storage_length;
                record_info.file_position := amc$mid_record;
              IFEND;

              record_info.bor_address := record_info.current_byte_address;

              data_ptr := #ADDRESS (osc$min_ring,
                    #SEGMENT (file_instance^.file_pva),
                    record_info.current_byte_address);

              i#move (data_ptr, call_block.getn.working_storage_area,
                    record_info.record_length);

              record_info.current_byte_address :=
                    record_info.current_byte_address +
                    record_info.record_length;

            ELSE { at eoi }
              record_info.bor_address := record_info.current_byte_address;
              record_info.record_length := 0;
            IFEND; { NOT at eoi }

          END /main_code_get_next/;

*copy     bai$save_positioning_info

          call_block.getn.transfer_count^ := record_info.record_length;
          call_block.getn.file_position^ := record_info.file_position;
          IF call_block.operation = amc$get_next_req THEN
            call_block.getn.byte_address^ := record_info.bor_address;
          IFEND;
        IFEND;
      IFEND;
    PROCEND get_next;
?? TITLE := 'PUT_NEXT', EJECT ??

    PROCEDURE [INLINE] put_next;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_write_access
        IF status.normal THEN

        /main_code_put_next/
          BEGIN

            block_info := file_instance^.global_file_information^.
                  positioning_info.block_info;
            record_info := file_instance^.global_file_information^.
                  positioning_info.record_info;

            block_header := #ADDRESS (osc$min_ring,
                  #SEGMENT (file_instance^.file_pva),
                  block_info.current_block_byte_address);
            IF block_info.current_block_byte_address <
                  file_instance^.global_file_information^.eoi_byte_address THEN
*copy         bai$validate_block_header
              IF NOT status.normal THEN
                EXIT /main_code_put_next/;
              IFEND;
            IFEND;

            IF record_info.file_position = amc$mid_record THEN
              IF file_instance^.global_file_information^.last_access_operation =
                    amc$put_partial_req THEN
                pad_record_proc;
                IF (record_info.current_byte_address >=
                      file_instance^.global_file_information^.
                      eoi_byte_address) OR (file_instance^.instance_attributes.
                      static_label.file_organization <> amc$byte_addressable)
                      THEN
                  block_header^.block_length := record_info.
                        current_byte_address - (block_info.
                        current_block_byte_address + #SIZE (bat$block_header));
                IFEND;
              ELSE
                record_info.current_byte_address :=
                      record_info.bor_address + file_instance^.
                      global_file_information^.max_record_length;
              IFEND;
            IFEND;

            IF record_info.current_byte_address >
                  block_info.current_block_byte_address THEN
              block_info.residual_block_length :=
                    file_instance^.global_file_information^.max_data_size +
                    block_info.current_block_byte_address +
                    #SIZE (bat$block_header) - record_info.current_byte_address;
            ELSE
              block_info.residual_block_length := 0;
            IFEND;

            IF block_info.residual_block_length <
                  file_instance^.global_file_information^.max_record_length THEN

              IF record_info.current_byte_address <>
                    block_info.current_block_byte_address THEN
                record_info.current_byte_address :=
                      block_info.current_block_byte_address +
                      file_instance^.global_file_information^.max_block_size;
                block_info.current_block_byte_address :=
                      record_info.current_byte_address;
                block_header := #ADDRESS (osc$min_ring,
                      #SEGMENT (file_instance^.file_pva),
                      block_info.current_block_byte_address);
              IFEND;

{ Check to make sure we do not go over the 2 GB file limit.

              IF file_instance^.global_file_information^.file_limit <
                    record_info.current_byte_address +
                    #SIZE (bat$block_header) THEN
                amp$set_file_instance_abnormal (file_identifier,
                    ame$put_beyond_file_limit, call_block.operation, error_text,
                    status);
                EXIT /main_code_put_next/;
              IFEND;

*copy         bai$write_block_header
            IFEND;

            record_info.bor_address := record_info.current_byte_address;

            IF call_block.putn.working_storage_length >
                  file_instance^.global_file_information^.max_record_length THEN

{ Truncate data without warning if to long for fixed record.

              record_info.record_length := file_instance^.
                    global_file_information^.max_record_length;
            ELSE
              record_info.record_length := call_block.putn.
                    working_storage_length;
            IFEND;

{ Check to make sure we do not go over the 2 GB file limit.

            IF file_instance^.global_file_information^.file_limit <
                  record_info.current_byte_address +
                  record_info.record_length THEN
              amp$set_file_instance_abnormal (file_identifier,
                  ame$put_beyond_file_limit, call_block.operation, error_text,
                  status);
              EXIT /main_code_put_next/;
            IFEND;

            data_ptr := #ADDRESS (osc$min_ring,
                  #SEGMENT (file_instance^.file_pva),
                  record_info.current_byte_address);

            i#move (call_block.putn.working_storage_area, data_ptr,
                  record_info.record_length);

            record_info.current_byte_address :=
                  record_info.current_byte_address + record_info.record_length;

            pad_record;

            file_instance^.instance_of_open_modified := TRUE;
            record_info.file_position := amc$eor;
            record_info.record_length := file_instance^.
                  global_file_information^.max_record_length;

*copy       bai$update_eoi
            IF (call_block.operation = amc$put_next_req) AND
                  ((record_info.current_byte_address =
                  file_instance^.global_file_information^.eoi_byte_address) OR
                  (file_instance^.instance_attributes.static_label.
                  file_organization <> amc$byte_addressable)) THEN
              block_header^.block_length := record_info.current_byte_address -
                    (block_info.current_block_byte_address +
                    #SIZE (bat$block_header));
            IFEND;

          END /main_code_put_next/;

          file_instance^.global_file_information^.positioning_info.block_info :=
                block_info;
          file_instance^.global_file_information^.positioning_info.
                record_info := record_info;

          IF call_block.operation = amc$put_next_req THEN
            call_block.putn.byte_address^ := record_info.bor_address;
          IFEND;
        IFEND; { status.normal }
      IFEND; { record_access }
    PROCEND put_next;
?? TITLE := 'GET_PARTIAL', EJECT ??

    PROCEDURE [INLINE] get_partial;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_read_access
        IF status.normal THEN
          IF (call_block.getp.skip_option < LOWERVALUE (amt$skip_option)) OR
                (call_block.getp.skip_option > UPPERVALUE (amt$skip_option))
                THEN
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_skip_option, call_block.operation, error_text,
                  status);
          ELSE

          /main_code_get_partial/
            BEGIN

*copy         bai$get_positioning_info

              block_header := #ADDRESS (osc$min_ring,
                    #SEGMENT (file_instance^.file_pva),
                    block_info.current_block_byte_address);
              IF block_info.current_block_byte_address <
                    file_instance^.global_file_information^.
                    eoi_byte_address THEN
*copy           bai$validate_block_header
                IF NOT status.normal THEN
                  EXIT /main_code_get_partial/;
                IFEND;
              IFEND;

{ Move to start of a fixed record if skip_to_eor, but terminate first if
{ necessary.

              IF (record_info.file_position = amc$mid_record) AND
                    (file_instance^.private_read_information = NIL) AND
                    (file_instance^.global_file_information^.
                    last_access_operation = amc$put_partial_req) THEN
                pad_record_proc;
                IF (record_info.current_byte_address >=
                      file_instance^.global_file_information^.
                      eoi_byte_address) OR (file_instance^.instance_attributes.
                      static_label.file_organization <> amc$byte_addressable)
                      THEN
                  block_header^.block_length := record_info.
                        current_byte_address - (block_info.
                        current_block_byte_address + #SIZE (bat$block_header));
                  update_eoi;
                IFEND;
              IFEND; { mid_record, putp, global }

              IF (record_info.file_position = amc$mid_record) AND
                    (call_block.getp.skip_option = amc$skip_to_eor) THEN
                record_info.current_byte_address :=
                      record_info.bor_address + file_instance^.
                      global_file_information^.max_record_length;
                record_info.file_position := amc$eor;
              IFEND;

*copy         bai$get_eoi_check

              IF NOT at_eoi THEN

                IF record_info.current_byte_address >
                      block_info.current_block_byte_address THEN
                  block_info.residual_block_length :=
                        block_info.current_block_byte_address +
                        block_header^.block_length + #SIZE (bat$block_header) -
                        record_info.current_byte_address;
                ELSE { must be on the block header }
                  block_info.residual_block_length :=
                        block_header^.block_length;
                  record_info.current_byte_address :=
                        record_info.current_byte_address +
                        #SIZE (bat$block_header);
                IFEND;

                IF record_info.file_position <> amc$mid_record THEN
                  IF block_info.residual_block_length <
                        file_instance^.global_file_information^.
                        max_record_length THEN

                    block_info.current_block_byte_address :=
                          block_info.current_block_byte_address +
                          file_instance^.global_file_information^.
                          max_block_size;
                    block_header := #ADDRESS (osc$min_ring,
                          #SEGMENT (file_instance^.file_pva),
                          block_info.current_block_byte_address);

*copy               bai$validate_block_header
                    IF NOT status.normal THEN
                      EXIT /main_code_get_partial/;
                    IFEND;

                    block_info.residual_block_length :=
                          block_header^.block_length;
                    record_info.current_byte_address :=
                          block_info.current_block_byte_address +
                          #SIZE (bat$block_header);
                  IFEND;
                  record_info.bor_address := record_info.current_byte_address;
                IFEND;

                record_info.residual_record_length :=
                      record_info.bor_address + file_instance^.
                      global_file_information^.max_record_length -
                      record_info.current_byte_address;
                IF call_block.getp.working_storage_length >=
                      record_info.residual_record_length THEN
                  record_info.record_length := record_info.
                        residual_record_length;
                  record_info.file_position := amc$eor;
                ELSE
                  record_info.record_length := call_block.getp.
                        working_storage_length;
                  record_info.file_position := amc$mid_record;
                IFEND;

                data_ptr := #ADDRESS (osc$min_ring,
                      #SEGMENT (file_instance^.file_pva),
                      record_info.current_byte_address);

                i#move (data_ptr, call_block.getp.working_storage_area,
                      record_info.record_length);

                record_info.current_byte_address :=
                      record_info.current_byte_address +
                      record_info.record_length;

                call_block.getp.transfer_count^ := record_info.record_length;
                record_info.record_length := record_info.current_byte_address -
                      record_info.bor_address;

              ELSE { at eoi }
                record_info.bor_address := record_info.current_byte_address;
                record_info.record_length := 0;
                call_block.getp.transfer_count^ := record_info.record_length;
              IFEND; { NOT at eoi }

            END /main_code_get_partial/;
*copy       bai$save_positioning_info

            call_block.getp.file_position^ := record_info.file_position;
            call_block.getp.record_length^ := record_info.record_length;
            IF call_block.operation = amc$get_partial_req THEN
              call_block.getp.byte_address^ := record_info.bor_address;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    PROCEND get_partial;
?? TITLE := 'PUT_PARTIAL', EJECT ??

    PROCEDURE [INLINE] put_partial;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_write_access
        IF status.normal THEN
          IF (call_block.putp.term_option < LOWERVALUE (amt$term_option)) OR
                (call_block.putp.term_option > UPPERVALUE (amt$term_option))
                THEN
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_term_option, call_block.operation, error_text,
                  status);
          ELSE

          /main_code_put_partial/
            BEGIN

              block_info := file_instance^.global_file_information^.
                    positioning_info.block_info;
              record_info := file_instance^.global_file_information^.
                    positioning_info.record_info;

              IF ((record_info.file_position <> amc$mid_record) AND
                    (call_block.putp.term_option = amc$continue)) THEN
                amp$set_file_instance_abnormal (file_identifier,
                      ame$improper_continue, call_block.operation, error_text,
                      status);
                EXIT /main_code_put_partial/;
              IFEND;

              block_header := #ADDRESS (osc$min_ring,
                    #SEGMENT (file_instance^.file_pva),
                    block_info.current_block_byte_address);
              IF block_info.current_block_byte_address <
                    file_instance^.global_file_information^.
                    eoi_byte_address THEN
*copy           bai$validate_block_header
                IF NOT status.normal THEN
                  EXIT /main_code_put_partial/;
                IFEND;
              IFEND;

              IF record_info.current_byte_address <>
                    block_info.current_block_byte_address THEN
                block_info.residual_block_length :=
                      block_info.current_block_byte_address +
                      #SIZE (bat$block_header) + file_instance^.
                      global_file_information^.max_data_size -
                      record_info.current_byte_address;
              ELSE
                block_info.residual_block_length := 0;
              IFEND;

              IF (record_info.file_position = amc$mid_record) AND
                    (call_block.putp.term_option = amc$start) AND
                    (file_instance^.global_file_information^.
                    last_access_operation = amc$put_partial_req) THEN
                pad_record_proc;
                update_eoi;
              IFEND;

              IF record_info.file_position <> amc$mid_record THEN
                IF block_info.residual_block_length <
                      file_instance^.global_file_information^.
                      max_record_length THEN
                  IF record_info.current_byte_address <>
                        block_info.current_block_byte_address THEN
                    IF (record_info.current_byte_address >=
                          file_instance^.global_file_information^.
                          eoi_byte_address) OR (file_instance^.
                          instance_attributes.static_label.file_organization <>
                          amc$byte_addressable) THEN
                      block_header^.block_length :=
                            record_info.current_byte_address -
                            (block_info.current_block_byte_address +
                            #SIZE (bat$block_header));
                    IFEND;

                    record_info.current_byte_address :=
                          block_info.current_block_byte_address +
                          file_instance^.global_file_information^.
                          max_block_size;
                    block_info.current_block_byte_address :=
                          record_info.current_byte_address;
                  IFEND;

{ Check to make sure we do not go over the 2 GB file limit.

                  IF file_instance^.global_file_information^.file_limit <
                        record_info.current_byte_address +
                        #SIZE (bat$block_header) +
                        file_instance^.global_file_information^.max_record_length THEN
                    amp$set_file_instance_abnormal (file_identifier,
                        ame$put_beyond_file_limit, call_block.operation, error_text,
                        status);
                    EXIT /main_code_put_partial/;
                  IFEND;

                  block_header := #ADDRESS (osc$min_ring,
                        #SEGMENT (file_instance^.file_pva),
                        block_info.current_block_byte_address);
*copy             bai$write_block_header
                IFEND; { rbl < maxrl }
                record_info.bor_address := record_info.current_byte_address;
              IFEND; { NOT mid_record }

              record_info.residual_record_length :=
                    record_info.bor_address + file_instance^.
                    global_file_information^.max_record_length -
                    record_info.current_byte_address;
              IF call_block.putp.working_storage_length >
                    record_info.residual_record_length THEN
                record_info.record_length := record_info.residual_record_length;
              ELSE
                record_info.record_length := call_block.putp.
                      working_storage_length;
              IFEND;

{ Before starting a record make sure a fixed length record can be written.

              IF file_instance^.global_file_information^.file_limit <
                    record_info.bor_address +
                    record_info.record_length THEN
                amp$set_file_instance_abnormal (file_identifier,
                    ame$put_beyond_file_limit, call_block.operation, error_text,
                    status);
                EXIT /main_code_put_partial/;
              IFEND;

              data_ptr := #ADDRESS (osc$min_ring,
                    #SEGMENT (file_instance^.file_pva),
                    record_info.current_byte_address);

              i#move (call_block.putp.working_storage_area, data_ptr,
                    record_info.record_length);

              record_info.current_byte_address :=
                    record_info.current_byte_address +
                    record_info.record_length;

              record_info.residual_record_length :=
                    record_info.residual_record_length -
                    record_info.record_length;

              file_instance^.instance_of_open_modified := TRUE;
              IF call_block.putp.term_option = amc$terminate THEN
                IF record_info.residual_record_length <> 0 THEN
                  pad_record;
                IFEND;
                record_info.file_position := amc$eor;
*copy           bai$update_eoi
              ELSE
                record_info.file_position := amc$mid_record;
              IFEND;

              record_info.record_length := record_info.current_byte_address -
                    record_info.bor_address;

              IF (record_info.current_byte_address >=
                    file_instance^.global_file_information^.eoi_byte_address) OR
                    (file_instance^.instance_attributes.static_label.
                    file_organization <> amc$byte_addressable) THEN
                block_header^.block_length := record_info.
                      current_byte_address - (block_info.
                      current_block_byte_address + #SIZE (bat$block_header));
              IFEND;

            END /main_code_put_partial/;

            file_instance^.global_file_information^.positioning_info.
                  block_info := block_info;
            file_instance^.global_file_information^.positioning_info.
                  record_info := record_info;

            call_block.putp.byte_address^ := record_info.bor_address;
          IFEND;
        IFEND;
      IFEND;
    PROCEND put_partial;
?? TITLE := 'PROCEDURE [INLINE] SKIP', EJECT ??

    PROCEDURE [INLINE] skip;

      VAR
        skip_count: integer;

*copy bai$get_positioning_info

      skip_count := call_block.skp.count;
      IF file_instance^.instance_attributes.static_label.file_organization <>
            amc$sequential THEN
        amp$set_file_instance_abnormal (file_identifier, ame$conflicting_fo,
              call_block.operation, error_text, status);
      ELSEIF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE

      /main_code_skip/
        BEGIN
          block_header := #ADDRESS (osc$min_ring,
                #SEGMENT (file_instance^.file_pva),
                block_info.current_block_byte_address);
          IF block_info.current_block_byte_address <
                file_instance^.global_file_information^.eoi_byte_address THEN
*copy       bai$validate_block_header
            IF NOT status.normal THEN
              EXIT /main_code_skip/;
            IFEND;
          IFEND;

          CASE call_block.skp.direction OF
          = amc$forward =

{ Start by doing a skip of 0.

            IF record_info.file_position = amc$mid_record THEN
              record_info.current_byte_address :=
                    record_info.bor_address + file_instance^.
                    global_file_information^.max_record_length;
              record_info.bor_address := record_info.current_byte_address;
              record_info.file_position := amc$eor;
            ELSEIF record_info.current_byte_address = 0 THEN
              record_info.current_byte_address := #SIZE (bat$block_header);
              record_info.bor_address := record_info.current_byte_address;
            IFEND;

            block_info.residual_block_length :=
                  block_info.current_block_byte_address +
                  block_header^.block_length + #SIZE (bat$block_header) -
                  record_info.current_byte_address;

            IF skip_count > 0 THEN
              WHILE (skip_count > 0) AND (record_info.current_byte_address <
                    file_instance^.global_file_information^.eoi_byte_address) DO

                IF block_info.residual_block_length <
                      file_instance^.global_file_information^.
                      max_record_length THEN

                  IF block_info.current_block_byte_address +
                        file_instance^.global_file_information^.max_block_size <=
                        file_instance^.global_file_information^.
                        eoi_byte_address THEN
                    block_info.current_block_byte_address :=
                          block_info.current_block_byte_address +
                          file_instance^.global_file_information^.max_block_size;
                    record_info.current_byte_address :=
                          block_info.current_block_byte_address;
                    IF record_info.current_byte_address <
                          file_instance^.global_file_information^.
                          eoi_byte_address THEN
                      block_header := #ADDRESS (osc$min_ring,
                            #SEGMENT (file_instance^.file_pva),
                            block_info.current_block_byte_address);
*copy                 bai$validate_block_header
                      IF NOT status.normal THEN
                        EXIT /main_code_skip/;
                      IFEND;
                      block_info.residual_block_length :=
                            block_header^.block_length;
                      record_info.current_byte_address :=
                            record_info.current_byte_address +
                            #SIZE (bat$block_header);
                    IFEND;
                  IFEND; { new cbba < eoi }
                IFEND; { rbl < maxrl }

                IF record_info.current_byte_address <
                      file_instance^.global_file_information^.
                      eoi_byte_address THEN
                  record_info.current_byte_address :=
                        record_info.current_byte_address +
                        file_instance^.global_file_information^.max_record_length;
                  block_info.residual_block_length :=
                        block_info.residual_block_length -
                        file_instance^.global_file_information^.max_record_length;
                  skip_count := skip_count - 1;
                IFEND;
              WHILEND;

              IF skip_count = 0 THEN
                record_info.file_position := amc$eor;
              ELSE
                amp$set_file_instance_abnormal (file_identifier,
                      ame$skip_encountered_eoi, amc$skip_req, ' RECORDS', status);
                record_info.file_position := amc$eoi;
              IFEND;
            IFEND;
            file_instance^.residual_skip_count := skip_count;

          = amc$backward =

{ Start with skip or 0 backward to the start of a fixed record.

            IF record_info.file_position = amc$mid_record THEN
              record_info.current_byte_address := record_info.bor_address;
              record_info.current_byte_address :=
                    record_info.current_byte_address;
              record_info.file_position := amc$eor;
            IFEND;

            IF skip_count > 0 THEN
              WHILE (skip_count > 0) AND (record_info.current_byte_address >
                    #SIZE (bat$block_header)) DO
                IF record_info.current_byte_address - #SIZE (bat$block_header) <=
                      block_info.current_block_byte_address THEN
                  block_info.current_block_byte_address :=
                        block_info.current_block_byte_address -
                        file_instance^.global_file_information^.max_block_size;
                  block_header := #ADDRESS (osc$min_ring,
                        #SEGMENT (file_instance^.file_pva),
                        block_info.current_block_byte_address);
*copy             bai$validate_block_header
                  IF NOT status.normal THEN
                    EXIT /main_code_skip/;
                  IFEND;

{ Position to end of data in new block.

                  record_info.current_byte_address :=
                        block_info.current_block_byte_address +
                        #SIZE (bat$block_header) + block_header^.block_length;
                IFEND;

                record_info.current_byte_address :=
                      record_info.current_byte_address -
                      file_instance^.global_file_information^.max_record_length;
                skip_count := skip_count - 1;
              WHILEND;

              IF skip_count = 0 THEN
                record_info.file_position := amc$eor;
              ELSE
                record_info.file_position := amc$boi;
                record_info.current_byte_address := 0;
                amp$set_file_instance_abnormal (file_identifier,
                      ame$skip_encountered_boi, amc$skip_req, ' RECORDS', status);
              IFEND;
            IFEND;
            file_instance^.residual_skip_count := skip_count;

          ELSE
          CASEND; { skip_direction }
        END /main_code_skip/;
        call_block.skp.file_position^ := record_info.file_position;
      IFEND; { record access }

*copy bai$save_positioning_info

    PROCEND skip;
?? TITLE := 'PROCEDURE [INLINE] SEEK_DIRECT', EJECT ??

    PROCEDURE [INLINE] seek_direct;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE

*copy   bai$seek_validation
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        terminate_record;

*copy   bai$get_positioning_info

        block_info.current_block_byte_address :=
              (file_byte_address DIV file_instance^.global_file_information^.
              max_block_size) * file_instance^.global_file_information^.
              max_block_size;
        IF ((file_byte_address - (block_info.current_block_byte_address +
              #SIZE (bat$block_header))) MOD file_instance^.
              global_file_information^.max_record_length <> 0) OR
              (((file_byte_address - (block_info.current_block_byte_address +
              #SIZE (bat$block_header))) DIV file_instance^.
              global_file_information^.max_record_length) + 1 >=
              (file_instance^.global_file_information^.max_data_size DIV
              file_instance^.global_file_information^.max_record_length)) THEN

{ File_byte_address is not at the beginning of a record.

          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_seek_address, call_block.operation, error_text,
                status);
          RETURN;
        IFEND;

        record_info.bor_address := file_byte_address;
        record_info.current_byte_address := file_byte_address;
        record_info.file_position := amc$eor;

*copy   bai$save_positioning_info

      IFEND;
    PROCEND seek_direct;
?? TITLE := 'PROCEDURE [INLINE] PAD_RECORD', EJECT ??

    PROCEDURE [INLINE] pad_record;

      record_info.residual_record_length :=
            record_info.bor_address + file_instance^.global_file_information^.
            max_record_length - record_info.current_byte_address;

      IF record_info.residual_record_length > 0 THEN
        i := 1;
        wsa := #ADDRESS (osc$min_ring, #SEGMENT (file_instance^.file_pva),
              record_info.current_byte_address);
        record_info.current_byte_address := record_info.current_byte_address +
              record_info.residual_record_length;
        IF file_instance^.global_file_information^.padding_character = ' ' THEN
          default_padding_string := ' ';
          IF #SIZE (default_padding_string) >
                record_info.residual_record_length THEN
            i := record_info.residual_record_length;
          ELSE
            i := #SIZE (default_padding_string);
          IFEND;
          i#move (^default_padding_string, wsa, i);
          record_info.residual_record_length :=
                record_info.residual_record_length - i;
        ELSE
          working_storage_area := wsa;
          working_storage_area^ := file_instance^.global_file_information^.
                padding_character;
          record_info.residual_record_length :=
                record_info.residual_record_length - 1;
        IFEND;

        WHILE record_info.residual_record_length > 0 DO
          padding_area := #ADDRESS (osc$min_ring, #SEGMENT (wsa),
                (#OFFSET (wsa) + i));
          IF i <= record_info.residual_record_length THEN
            padding_length := i;
          ELSE
            padding_length := record_info.residual_record_length;
          IFEND;

          i#move (wsa, padding_area, padding_length);

          record_info.residual_record_length :=
                record_info.residual_record_length - padding_length;
          i := i + padding_length;
        WHILEND;
      IFEND;

      record_info.file_position := amc$eor;

    PROCEND pad_record;
?? TITLE := 'PROCEDURE pad_record_proc', EJECT ??

    PROCEDURE pad_record_proc;

      pad_record;

    PROCEND pad_record_proc;
?? TITLE := 'PROCEDURE replace_record', EJECT ??

    PROCEDURE replace_record;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSEIF NOT ((file_instance^.global_file_information^.positioning_info.
            record_info.file_position <> amc$mid_record) AND
            (file_instance^.global_file_information^.positioning_info.
            record_info.current_byte_address > 0)) THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_file_position, call_block.operation, error_text,
              status);
      ELSEIF (call_block.putn.working_storage_length < 0) OR
            (call_block.putn.working_storage_length >
            UPPERVALUE (amt$working_storage_length)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
              call_block.operation, error_text, status);
      ELSEIF caller_id.ring > file_instance^.instance_attributes.static_label.
            ring_attributes.r1 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, call_block.operation, error_text,
              status);
      ELSEIF NOT (pfc$modify IN file_instance^.instance_attributes.
            dynamic_label.access_mode) THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_access_attempt, call_block.operation, ' MODIFY',
              status);
      ELSE
        record_info := file_instance^.global_file_information^.positioning_info.
              record_info;
        record_info.current_byte_address := record_info.bor_address;

        IF call_block.replace.working_storage_length >
              file_instance^.global_file_information^.max_record_length THEN
          record_info.record_length := file_instance^.global_file_information^.
                max_record_length;
        ELSE
          record_info.record_length := call_block.replace.
                working_storage_length;
        IFEND;

        data_ptr := #ADDRESS (osc$min_ring, #SEGMENT (file_instance^.file_pva),
              record_info.current_byte_address);

        i#move (call_block.putn.working_storage_area, data_ptr,
              record_info.record_length);

        record_info.current_byte_address := record_info.current_byte_address +
              record_info.record_length;
        file_instance^.instance_of_open_modified := TRUE;

        pad_record_proc;

        file_instance^.global_file_information^.positioning_info.record_info :=
              record_info;
      IFEND;
    PROCEND replace_record;
?? TITLE := 'PROCEDURE terminate_record', EJECT ??

    PROCEDURE terminate_record;

      IF (file_instance^.private_read_information = NIL) AND
            (file_instance^.global_file_information^.last_access_operation =
            amc$put_partial_req) AND (file_instance^.global_file_information^.
            positioning_info.record_info.file_position = amc$mid_record) THEN

        block_info := file_instance^.global_file_information^.positioning_info.
              block_info;
        record_info := file_instance^.global_file_information^.positioning_info.
              record_info;

        pad_record_proc;

        IF (record_info.current_byte_address >=
              file_instance^.global_file_information^.eoi_byte_address) OR
              (file_instance^.instance_attributes.static_label.
              file_organization <> amc$byte_addressable) THEN
          block_header := #ADDRESS (osc$min_ring,
                #SEGMENT (file_instance^.file_pva),
                block_info.current_block_byte_address);
          block_header^.block_length := record_info.current_byte_address -
                (block_info.current_block_byte_address +
                #SIZE (bat$block_header));
          update_eoi;
        IFEND;

        file_instance^.global_file_information^.positioning_info.block_info :=
              block_info;
        file_instance^.global_file_information^.positioning_info.record_info :=
              record_info;

      IFEND; { mid_record, putp, global }

    PROCEND terminate_record;
?? TITLE := 'PROCEDURE update_eoi', EJECT ??

    PROCEDURE update_eoi;

*copy bai$update_eoi

    PROCEND update_eoi;
?? TITLE := 'MAIN BODY OF BAM$US_BLK_FIXED_REC_FAP', EJECT ??

    #CALLER_ID (caller_id);
    status.normal := TRUE;

  /process_fap_request/
    BEGIN
      bap$validate_file_identifier (file_identifier, file_instance,
            validation_ok);
      IF NOT validation_ok THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
              error_text, status);
        RETURN;
      ELSE

        file_instance^.rollback_procedure := ^rollback_procedure;
        CASE call_block.operation OF
        = amc$get_next_req =
          get_next;
        = amc$put_next_req =
          put_next;
        = amc$get_partial_req =
          get_partial;
        = amc$put_partial_req =
          put_partial;
        = amc$open_req =
          CASE file_instance^.instance_attributes.dynamic_label.open_position OF
          = amc$open_at_boi =
*copy       bai$get_positioning_info
            block_info := bav$default_block_info;
*copy       bai$save_positioning_info
          = amc$open_at_eoi =
*copy       bai$get_positioning_info
            block_info.current_block_byte_address :=
                  (record_info.current_byte_address DIV
                  file_instance^.global_file_information^.max_block_size) *
                  file_instance^.global_file_information^.max_block_size;
*copy       bai$save_positioning_info
          ELSE
          CASEND;
        = amc$close_req =
          terminate_record;
          bap$close (file_identifier, status);
          EXIT /process_fap_request/;
        = amc$rewind_req =
          terminate_record;
*copy     bai$rewind
        = amc$seek_direct_req =
          file_byte_address := call_block.seekd.byte_address;
          seek_direct;
        = amc$get_direct_req =
          file_byte_address := call_block.getd.byte_address;
          seek_direct;
          IF NOT status.normal THEN
            IF status.condition = ame$position_beyond_eoi THEN
              status.condition := ame$input_after_eoi;
            IFEND;
          ELSE
            get_next;
          IFEND;
        = amc$put_direct_req =
          file_byte_address := call_block.putd.byte_address;
          seek_direct;
          IF status.normal THEN
            put_next;
          IFEND;
        = amc$skip_req =
          IF call_block.skp.unit <> amc$skip_record THEN
             amp$set_file_instance_abnormal (file_identifier,
                ame$unsupported_skip, call_block.operation, ' ',
                status);
          ELSE
             terminate_record;
             skip;
          IFEND;
        = amc$fetch_access_information_rq =
          bap$fetch_access_information (file_identifier, call_block,
                layer_number, status);
          EXIT /process_fap_request/;
        = amc$fetch_req =
          bap$fetch (file_identifier, call_block, layer_number, status);
          EXIT /process_fap_request/;
        = amc$get_segment_pointer_req =
          bap$get_segment_pointer (file_identifier, call_block, layer_number,
                status);
        = amc$set_segment_eoi_req =
          bap$set_segment_eoi (file_identifier, call_block, layer_number,
                status);
        = amc$set_segment_position_req =
          bap$set_segment_position (file_identifier, call_block, layer_number,
                status);
        = amc$replace_req =
          replace_record;
        = amc$store_req =
          bap$store (file_identifier, call_block, layer_number, status);
        = amc$write_end_partition_req =
          amp$set_file_instance_abnormal (file_identifier,
                ame$unsupported_operation, call_block.operation, error_text,
                status);
        = amc$write_tape_mark_req, amc$close_volume_req =
          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_device_class, call_block.operation, 'MASS_STORAGE',
                status);
        = amc$flush_req =
          bap$write_modified_pages (file_instance, file_identifier, status);
        = ifc$fetch_terminal_req, ifc$store_terminal_req =
          pmp$get_job_mode (job_mode, status);
          IF status.normal THEN
            IF job_mode = jmc$batch THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$current_job_not_interactive, 'FETCH/STORE_TERMINAL_REQ',
                    status);
            ELSE
              amp$set_file_instance_abnormal (file_identifier,
                    ame$improper_device_class, call_block.operation,
                    'MASS STORAGE', status);
            IFEND;
          IFEND;
        ELSE
          amp$set_file_instance_abnormal (file_identifier,
                ame$unimplemented_request, call_block.operation,
                ' for sequential or byte addressable files', status);
        CASEND;
      IFEND; { validate_file_identifier }

      IF file_instance^.private_read_information = NIL THEN
        IF status.normal THEN
          file_instance^.global_file_information^.error_status := 0;
        ELSE
          file_instance^.global_file_information^.error_status :=
                status.condition;
        IFEND;
        file_instance^.global_file_information^.last_access_operation :=
              call_block.operation;
      ELSE
        IF status.normal THEN
          file_instance^.private_read_information^.error_status := 0;
        ELSE
          file_instance^.private_read_information^.error_status :=
                status.condition;
        IFEND;
        file_instance^.private_read_information^.last_access_operation :=
              call_block.operation;
      IFEND;

    END /process_fap_request/;

    file_instance^.rollback_procedure := NIL;
  PROCEND bap$us_blk_fixed_rec_fap;
MODEND bam$us_blk_fixed_rec_fap;
*DECK DECK=BAM$US_BLK_UNDEFINED_REC_FAP EXPAND=TRUE
?? RIGHT := 80 ??
*copyc osd$default_pragmats
MODULE bam$us_blk_undefined_rec_fap;
?? TITLE := 'NOS/VE:  BASIC ACCESS METHOD, TASK SERVICES' ??
?? NEWTITLE := 'COMMON DECLARATIONS' ??
*copyc amc$condition_code_limits
*copyc ame$access_validation_errors
*copyc ame$conflicting_access_level
*copyc ame$device_class_validation
*copyc ame$fap_validation_errors
*copyc ame$file_organization_errors
*copyc ame$get_program_actions
*copyc ame$get_validation_errors
*copyc ame$improper_file_id
*copyc ame$improper_random_access
*copyc ame$improper_wsl
*copyc ame$open_validation_errors
*copyc ame$put_program_actions
*copyc ame$put_validation_errors
*copyc ame$ring_validation_errors
*copyc ame$skip_program_actions
*copyc ame$skip_validation_errors
*copyc ame$unimplemented_request
*copyc amp$set_file_instance_abnormal
*copyc amt$fap_declarations
*copyc bac$minimum_open_ring
*copyc bap$close
*copyc bap$fetch
*copyc bap$fetch_access_information
*copyc bap$get_segment_pointer
*copyc bap$set_segment_eoi
*copyc bap$set_segment_position
*copyc bap$store
*copyc bap$validate_file_identifier
*copyc bat$block_header
*copyc bat$block_position
*copyc bat$global_file_information
*copyc bat$positioning_info
*copyc bat$task_file_table
*copyc bav$default_block_info
*copyc bav$default_record_info
*copyc bav$task_file_table
*copyc fmv$global_file_information
*copyc i#move
*copyc ife$error_codes
*copyc mmp$set_segment_length
*copyc bap$write_modified_pages
*copyc osd$virtual_address
*copyc osp$set_status_abnormal
*copyc ost$caller_identifier
*copyc pmp$get_job_mode

?? TITLE := 'BAP$US_BLK_UNDEFINED_REC_FAP', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$us_blk_undefined_rec_fap
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    CONST
      error_text = 'BAP$US_BLK_UNDEFINED_REC_FAP';

    VAR
      at_eoi: boolean,
      block_header: ^bat$block_header,
      block_info: bat$block_info,
      block_padding_string: string (40),
      caller_id: ost$caller_identifier,
      data_ptr: ^cell,
      file_byte_address: amt$file_byte_address,
      file_instance: ^bat$task_file_entry,
      job_mode: jmt$job_mode,
      padding_length: 0 .. amc$maximum_block - 1,
      record_info: bat$record_info,
      validation_ok: boolean,
      wsa: ^cell,
      x: 0 .. amc$maximum_block - 1;

?? TITLE := 'rollback_procedure', EJECT ??

    PROCEDURE rollback_procedure
      (    condition_status: ost$status);

      status := condition_status;
      file_instance^.rollback_procedure := NIL;
      EXIT bap$us_blk_undefined_rec_fap;

    PROCEND rollback_procedure;

?? TITLE := 'GET_NEXT', EJECT ??

    PROCEDURE [INLINE] get_next;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_read_access
        IF status.normal THEN

        /main_code_get_next/
          BEGIN

*copy       bai$get_positioning_info

            block_header := #ADDRESS (osc$min_ring,
                  #SEGMENT (file_instance^.file_pva),
                  block_info.current_block_byte_address);
            IF block_info.current_block_byte_address <
                  file_instance^.global_file_information^.eoi_byte_address THEN
*copy         bai$validate_block_header
              IF NOT status.normal THEN
                EXIT /main_code_get_next/;
              IFEND;
            IFEND;

            IF (record_info.file_position = amc$mid_record) AND
                  (file_instance^.private_read_information = NIL) AND
                  (file_instance^.global_file_information^.
                  last_access_operation = amc$put_partial_req) THEN
              IF block_header^.block_length <
                    file_instance^.global_file_information^.
                    min_block_length THEN
                pad_to_minbl;
              IFEND;
              update_eoi;
            IFEND;

            IF record_info.file_position = amc$mid_record THEN
              record_info.current_byte_address :=
                    block_info.current_block_byte_address +
                    #SIZE (bat$block_header) + block_header^.block_length;
            IFEND;

*copy       bai$get_eoi_check

            IF NOT at_eoi THEN
              IF record_info.current_byte_address <>
                    block_info.current_block_byte_address THEN

{ Must be another block or would have been at eoi.

                block_info.current_block_byte_address :=
                      block_info.current_block_byte_address +
                      file_instance^.global_file_information^.max_block_size;
                record_info.current_byte_address :=
                      block_info.current_block_byte_address;
                block_header := #ADDRESS (osc$min_ring,
                      #SEGMENT (file_instance^.file_pva),
                      block_info.current_block_byte_address);

*copy           bai$validate_block_header

                IF NOT status.normal THEN
                  EXIT /main_code_get_next/;
                IFEND;
              IFEND;

              record_info.bor_address := record_info.current_byte_address;
              record_info.current_byte_address :=
                    record_info.current_byte_address + #SIZE (bat$block_header);
              IF call_block.getn.working_storage_length >=
                    block_header^.block_length THEN
                record_info.record_length := block_header^.block_length;
                record_info.file_position := amc$eor;
              ELSE
                record_info.record_length := call_block.getn.
                      working_storage_length;
                record_info.file_position := amc$mid_record;
              IFEND;

              data_ptr := #ADDRESS (osc$min_ring,
                    #SEGMENT (file_instance^.file_pva),
                    record_info.current_byte_address);

              i#move (data_ptr, call_block.getn.working_storage_area,
                    record_info.record_length);

              record_info.current_byte_address :=
                    record_info.current_byte_address +
                    record_info.record_length;

            ELSE { at eoi }
              record_info.bor_address := record_info.current_byte_address;
              record_info.record_length := 0;
            IFEND; { NOT at eoi }
          END /main_code_get_next/;
*copy     bai$save_positioning_info

          call_block.getn.file_position^ := record_info.file_position;
          call_block.getn.transfer_count^ := record_info.record_length;
          IF call_block.operation = amc$get_next_req THEN
            call_block.getn.byte_address^ := record_info.bor_address;
          IFEND;
        IFEND;
      IFEND;
    PROCEND get_next;

?? TITLE := 'PUT_NEXT', EJECT ??

    PROCEDURE [INLINE] put_next;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_write_access
        IF status.normal THEN

        /main_code_put_next/
          BEGIN

            block_info := file_instance^.global_file_information^.
                  positioning_info.block_info;
            record_info := file_instance^.global_file_information^.
                  positioning_info.record_info;

            IF (record_info.file_position = amc$mid_record) AND
                  (file_instance^.private_read_information = NIL) AND
                  (file_instance^.global_file_information^.
                  last_access_operation = amc$put_partial_req) THEN
              block_header := #ADDRESS (osc$min_ring,
                    #SEGMENT (file_instance^.file_pva),
                    block_info.current_block_byte_address);
              IF block_header^.block_length <
                    file_instance^.global_file_information^.
                    min_block_length THEN
                pad_to_minbl;
              IFEND;
              update_eoi;
            IFEND;

            IF call_block.putn.working_storage_length = 0 THEN

{ A put of 0 length is basically a NO-OP, this means blanks lines will be
{ lost!  By design we cannot have a 0 length block.

              record_info.file_position := amc$eor;
              record_info.record_length := 0;
              EXIT /main_code_put_next/;
            IFEND;

            IF call_block.putn.working_storage_length >
                  file_instance^.global_file_information^.max_data_size THEN
              amp$set_file_instance_abnormal (file_identifier,
                    ame$record_exceeds_mbl, call_block.operation, error_text,
                    status);
              EXIT /main_code_put_next/;
            ELSE
              record_info.record_length := call_block.putn.
                    working_storage_length;
            IFEND;

            block_header := #ADDRESS (osc$min_ring,
                  #SEGMENT (file_instance^.file_pva),
                  block_info.current_block_byte_address);
            IF block_info.current_block_byte_address <
                  file_instance^.global_file_information^.eoi_byte_address THEN
*copy         bai$validate_block_header
              IF NOT status.normal THEN
                EXIT /main_code_put_next/;
              IFEND;
            IFEND;

            IF record_info.current_byte_address <>
                  block_info.current_block_byte_address THEN
              block_info.current_block_byte_address :=
                    block_info.current_block_byte_address +
                    file_instance^.global_file_information^.max_block_size;
              record_info.current_byte_address :=
                    block_info.current_block_byte_address;
            IFEND;
            record_info.bor_address := record_info.current_byte_address;
            block_header := #ADDRESS (osc$min_ring,
                  #SEGMENT (file_instance^.file_pva),
                  block_info.current_block_byte_address);

{ Check to make sure we do not go over the 2 GB file limit.

            IF file_instance^.global_file_information^.file_limit <
                  record_info.current_byte_address +
                  record_info.record_length + #SIZE(bat$block_header) THEN
              amp$set_file_instance_abnormal (file_identifier,
                  ame$put_beyond_file_limit, call_block.operation, error_text,
                  status);
              EXIT /main_code_put_next/;
            IFEND;

*copy       bai$write_block_header

            data_ptr := #ADDRESS (osc$min_ring,
                  #SEGMENT (file_instance^.file_pva),
                  record_info.current_byte_address);

            i#move (call_block.putn.working_storage_area, data_ptr,
                  record_info.record_length);

            record_info.current_byte_address :=
                  record_info.current_byte_address + record_info.record_length;
            file_instance^.instance_of_open_modified := TRUE;

            block_header^.block_length := record_info.record_length;
            IF record_info.record_length < file_instance^.
                  global_file_information^.min_block_length THEN
              pad_to_minbl;
            IFEND;

            record_info.file_position := amc$eor;

*copy       bai$update_eoi

          END /main_code_put_next/;

          file_instance^.global_file_information^.positioning_info.block_info :=
                block_info;
          file_instance^.global_file_information^.positioning_info.
                record_info := record_info;

          IF call_block.operation = amc$put_next_req THEN
            call_block.putn.byte_address^ := record_info.bor_address;
          IFEND;
        IFEND;
      IFEND;
    PROCEND put_next;

?? TITLE := 'GET_PARTIAL', EJECT ??

    PROCEDURE [INLINE] get_partial;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE

*copy   bai$validate_read_access
        IF status.normal THEN
          IF (call_block.getp.skip_option < LOWERVALUE (amt$skip_option)) OR
                (call_block.getp.skip_option > UPPERVALUE (amt$skip_option))
                THEN
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_skip_option, call_block.operation, error_text,
                  status);
          ELSE

          /main_code_get_partial/
            BEGIN

*copy         bai$get_positioning_info

              IF (record_info.file_position = amc$mid_record) AND
                    (file_instance^.private_read_information = NIL) AND
                    (file_instance^.global_file_information^.
                    last_access_operation = amc$put_partial_req) THEN
                block_header := #ADDRESS (osc$min_ring,
                      #SEGMENT (file_instance^.file_pva),
                      block_info.current_block_byte_address);
                IF block_header^.block_length <
                      file_instance^.global_file_information^.
                      min_block_length THEN
                  pad_to_minbl;
                IFEND;
                update_eoi;
              IFEND;

              block_header := #ADDRESS (osc$min_ring,
                    #SEGMENT (file_instance^.file_pva),
                    block_info.current_block_byte_address);
              IF block_info.current_block_byte_address <
                    file_instance^.global_file_information^.
                    eoi_byte_address THEN
*copy           bai$validate_block_header
                IF NOT status.normal THEN
                  EXIT /main_code_get_partial/;
                IFEND;
              IFEND;

              IF ((record_info.file_position = amc$mid_record) AND
                    (call_block.getp.skip_option = amc$skip_to_eor)) OR
                    ((record_info.file_position = amc$eor) AND
                    (record_info.current_byte_address <>
                    block_info.current_block_byte_address)) THEN
                IF block_info.current_block_byte_address +
                      #SIZE (bat$block_header) + block_header^.block_length <
                      file_instance^.global_file_information^.
                      eoi_byte_address THEN

                  block_info.current_block_byte_address :=
                        block_info.current_block_byte_address +
                        file_instance^.global_file_information^.max_block_size;
                  record_info.current_byte_address :=
                        block_info.current_block_byte_address;
                  record_info.bor_address := record_info.current_byte_address;
                  block_header := #ADDRESS (osc$min_ring,
                        #SEGMENT (file_instance^.file_pva),
                        block_info.current_block_byte_address);

*copy             bai$validate_block_header
                  IF NOT status.normal THEN
                    EXIT /main_code_get_partial/;
                  IFEND;

                  record_info.current_byte_address :=
                        record_info.current_byte_address +
                        #SIZE (bat$block_header);
                ELSE

{ No more records but move to eor anyway so get_eoi_check will work.

                  record_info.current_byte_address :=
                        block_info.current_block_byte_address +
                        #SIZE (bat$block_header) + block_header^.block_length;
                IFEND;
              IFEND;

*copy         bai$get_eoi_check

              IF NOT at_eoi THEN
                IF record_info.current_byte_address =
                      block_info.current_block_byte_address THEN
                  record_info.current_byte_address :=
                        record_info.current_byte_address +
                        #SIZE (bat$block_header);
                IFEND;

                record_info.residual_record_length :=
                      record_info.bor_address + #SIZE (bat$block_header) +
                      block_header^.block_length - record_info.
                      current_byte_address;

                IF call_block.getp.working_storage_length >=
                      record_info.residual_record_length THEN
                  record_info.record_length := record_info.
                        residual_record_length;
                  record_info.file_position := amc$eor;
                ELSE
                  record_info.record_length := call_block.getp.
                        working_storage_length;
                  record_info.file_position := amc$mid_record;
                IFEND;

                data_ptr := #ADDRESS (osc$min_ring,
                      #SEGMENT (file_instance^.file_pva),
                      record_info.current_byte_address);

                i#move (data_ptr, call_block.getp.working_storage_area,
                      record_info.record_length);

                record_info.current_byte_address :=
                      record_info.current_byte_address +
                      record_info.record_length;
                call_block.getp.transfer_count^ := record_info.record_length;
                record_info.record_length := record_info.current_byte_address -
                      record_info.bor_address - #SIZE (bat$block_header);

              ELSE { at eoi }
                record_info.bor_address := record_info.current_byte_address;
                record_info.record_length := 0;
                call_block.getp.transfer_count^ := record_info.record_length;
              IFEND; { NOT at eoi }
            END /main_code_get_partial/;
*copy     bai$save_positioning_info

            call_block.getp.file_position^ := record_info.file_position;
            call_block.getp.record_length^ := record_info.record_length;
            call_block.getp.byte_address^ := record_info.bor_address;
          IFEND;
        IFEND;
      IFEND;
    PROCEND get_partial;

?? TITLE := 'PUT_PARTIAL', EJECT ??

    PROCEDURE [INLINE] put_partial;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE

*copy bai$validate_write_access
        IF status.normal THEN
          IF (call_block.putp.term_option < LOWERVALUE (amt$term_option)) OR
                (call_block.putp.term_option > UPPERVALUE (amt$term_option))
                THEN
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_term_option, call_block.operation, error_text,
                  status);
          ELSE

          /main_code_put_partial/
            BEGIN

              block_info := file_instance^.global_file_information^.
                    positioning_info.block_info;
              record_info := file_instance^.global_file_information^.
                    positioning_info.record_info;

              IF (call_block.putp.working_storage_length = 0) AND
                    (record_info.file_position <> amc$mid_record) THEN

{ A put of 0 length is basically a NO-OP, this means blanks lines will be
{ lost!  By design we cannot have a 0 length block.

                EXIT /main_code_put_partial/;
              IFEND;

              block_header := #ADDRESS (osc$min_ring,
                    #SEGMENT (file_instance^.file_pva),
                    block_info.current_block_byte_address);
              IF block_info.current_block_byte_address <
                    file_instance^.global_file_information^.
                    eoi_byte_address THEN
*copy         bai$validate_block_header
                IF NOT status.normal THEN
                  EXIT /main_code_put_partial/;
                IFEND;
              IFEND;

              IF ((call_block.putp.term_option = amc$start) OR
                    (record_info.file_position <> amc$mid_record)) THEN

                IF call_block.putp.term_option = amc$continue THEN
                  amp$set_file_instance_abnormal (file_identifier,
                        ame$improper_continue, call_block.operation, error_text,
                        status);
                  EXIT /main_code_put_partial/;
                IFEND;

                IF record_info.file_position = amc$mid_record THEN
                  IF block_header^.block_length <
                        file_instance^.global_file_information^.
                        min_block_length THEN
                    pad_to_minbl;
                  IFEND;
                  update_eoi;
                IFEND;

{ Position to next block header.

                IF record_info.current_byte_address <>
                      block_info.current_block_byte_address THEN
                  block_info.current_block_byte_address :=
                        block_info.current_block_byte_address +
                        file_instance^.global_file_information^.max_block_size;
                  record_info.current_byte_address :=
                        block_info.current_block_byte_address;
                IFEND;
                block_header := #ADDRESS (osc$min_ring,
                      #SEGMENT (file_instance^.file_pva),
                      block_info.current_block_byte_address);

                IF call_block.putp.working_storage_length >
                      file_instance^.global_file_information^.max_data_size THEN
                  amp$set_file_instance_abnormal (file_identifier,
                        ame$record_exceeds_mbl, call_block.operation,
                        error_text, status);
                  EXIT /main_code_put_partial/;
                IFEND;

{ Check to make sure we do not go over the 2 GB file limit.

                IF file_instance^.global_file_information^.file_limit <
                      record_info.current_byte_address +
                      #SIZE(bat$block_header) +
                      call_block.putp.working_storage_length THEN
                  amp$set_file_instance_abnormal (file_identifier,
                      ame$put_beyond_file_limit, call_block.operation, error_text,
                      status);
                  EXIT /main_code_put_partial/;
                IFEND;

*copy           bai$write_block_header

                record_info.bor_address := block_info.
                      current_block_byte_address;

              ELSE { Record is already started.

                IF call_block.putp.working_storage_length >
                      file_instance^.global_file_information^.max_data_size -
                      block_header^.block_length THEN
                  amp$set_file_instance_abnormal (file_identifier,
                        ame$record_exceeds_mbl, call_block.operation,
                        error_text, status);
                  EXIT /main_code_put_partial/;
                IFEND;

{ Check to make sure we do not go over the 2 GB file limit.

                IF file_instance^.global_file_information^.file_limit <
                      record_info.current_byte_address +
                      call_block.putp.working_storage_length THEN
                  amp$set_file_instance_abnormal (file_identifier,
                      ame$put_beyond_file_limit, call_block.operation, error_text,
                      status);
                  EXIT /main_code_put_partial/;
                IFEND;

              IFEND;

              data_ptr := #ADDRESS (osc$min_ring,
                    #SEGMENT (file_instance^.file_pva),
                    record_info.current_byte_address);

              i#move (call_block.putp.working_storage_area, data_ptr,
                    call_block.putp.working_storage_length);

              record_info.current_byte_address :=
                    record_info.current_byte_address +
                    call_block.putp.working_storage_length;

              file_instance^.instance_of_open_modified := TRUE;

              block_header^.block_length := record_info.current_byte_address -
                    (block_info.current_block_byte_address +
                    #SIZE (bat$block_header));

              IF call_block.putp.term_option = amc$terminate THEN
                record_info.file_position := amc$eor;
                IF block_header^.block_length <
                      file_instance^.global_file_information^.
                      min_block_length THEN
                  pad_to_minbl;
                IFEND;
*copy           bai$update_eoi
              ELSE
                record_info.file_position := amc$mid_record;
              IFEND;

              record_info.record_length := block_header^.block_length;

            END /main_code_put_partial/;

            file_instance^.global_file_information^.positioning_info.
                  block_info := block_info;
            file_instance^.global_file_information^.positioning_info.
                  record_info := record_info;

            call_block.putp.byte_address^ := record_info.bor_address;
          IFEND;
        IFEND;
      IFEND;
    PROCEND put_partial;

?? TITLE := 'PROCEDURE [INLINE] SKIP', EJECT ??

    PROCEDURE [INLINE] skip;

      VAR
        skip_number: integer;

      IF file_instance^.instance_attributes.static_label.file_organization <>
            amc$sequential THEN
        amp$set_file_instance_abnormal (file_identifier, ame$conflicting_fo,
              call_block.operation, error_text, status);
      ELSEIF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE

      /main_code_skip/
        BEGIN

*copy     bai$get_positioning_info

          CASE call_block.skp.direction OF
          = amc$forward =
            IF record_info.file_position = amc$mid_record THEN
              IF record_info.current_byte_address DIV
                    file_instance^.global_file_information^.max_block_size <>
                    0 THEN

{ Not on a block_boundary so do 0 skip forward to next block_boundary or eoi.

                IF block_info.current_block_byte_address +
                      file_instance^.global_file_information^.max_block_size >
                      file_instance^.global_file_information^.
                      eoi_byte_address THEN
                  record_info.current_byte_address :=
                        file_instance^.global_file_information^.
                        eoi_byte_address;
                ELSE
                  record_info.current_byte_address :=
                        block_info.current_block_byte_address +
                        file_instance^.global_file_information^.max_block_size;
                IFEND;
              IFEND;
              record_info.file_position := amc$eor;
            IFEND;

            IF call_block.skp.count > 0 THEN
              IF file_instance^.global_file_information^.eoi_byte_address MOD
                    file_instance^.global_file_information^.max_block_size =
                    0 THEN
                skip_number := (file_instance^.global_file_information^.
                      eoi_byte_address - record_info.current_byte_address) DIV
                      file_instance^.global_file_information^.max_block_size;
              ELSE

{ Must add 1 to count the last incomplete block.

                skip_number := ((file_instance^.global_file_information^.
                      eoi_byte_address - record_info.current_byte_address) DIV
                      file_instance^.global_file_information^.max_block_size) + 1;
              IFEND;
              IF record_info.current_byte_address =
                    file_instance^.global_file_information^.eoi_byte_address THEN
                skip_number := 0;
              IFEND;

              IF call_block.skp.count > skip_number THEN
  { Skip past eoi.
                record_info.current_byte_address :=
                      file_instance^.global_file_information^.eoi_byte_address;
                record_info.file_position := amc$eoi;
                file_instance^.residual_skip_count :=
                      call_block.skp.count - skip_number;
                amp$set_file_instance_abnormal (file_identifier,
                      ame$skip_encountered_eoi, amc$skip_req, 'RECORDS', status);
              ELSE {can complete full skip}
                IF record_info.current_byte_address +
                      (call_block.skp.count * file_instance^.
                      global_file_information^.max_block_size) >
                      file_instance^.global_file_information^.
                      eoi_byte_address THEN
                  record_info.current_byte_address :=
                        file_instance^.global_file_information^.eoi_byte_address;
                ELSE
                  record_info.current_byte_address :=
                        record_info.current_byte_address +
                        (call_block.skp.count * file_instance^.
                        global_file_information^.max_block_size);
                IFEND;
                record_info.file_position := amc$eor;
                file_instance^.residual_skip_count := 0;
              IFEND;
              record_info.bor_address := record_info.current_byte_address;
              block_info.current_block_byte_address :=
                    (record_info.current_byte_address DIV
                    file_instance^.global_file_information^.max_block_size) *
                    file_instance^.global_file_information^.max_block_size;
            ELSE
              file_instance^.residual_skip_count := call_block.skp.count;
            IFEND;
          = amc$backward =
            IF (record_info.file_position = amc$mid_record) AND
                  (file_instance^.global_file_information^.max_block_size <>
                  0) AND (record_info.current_byte_address <>
                  file_instance^.global_file_information^.eoi_byte_address) THEN

{ Not on a block_boundary so do 0 skip backward to block_boundary.

              record_info.current_byte_address :=
                    block_info.current_block_byte_address;
              record_info.file_position := amc$eor;
            IFEND;
            IF call_block.skp.count > 0 THEN
              IF (record_info.current_byte_address MOD
                    file_instance^.global_file_information^.max_block_size <> 0)
                    THEN

{ Must be at eoi and not a block boundary.

                skip_number := record_info.current_byte_address DIV
                      file_instance^.global_file_information^.max_block_size + 1;
              ELSE
                skip_number := record_info.current_byte_address DIV
                      file_instance^.global_file_information^.max_block_size;
              IFEND;
              IF call_block.skp.count > skip_number THEN
                record_info.current_byte_address := 0;
                record_info.bor_address := 0;
                record_info.file_position := amc$boi;
                block_info.current_block_byte_address := 0;
                file_instance^.residual_skip_count :=
                      call_block.skp.count - skip_number;

                amp$set_file_instance_abnormal (file_identifier,
                      ame$skip_encountered_boi, amc$skip_req, 'RECORDS', status);
              ELSE { can skip back requested records }
                IF (record_info.current_byte_address MOD
                      file_instance^.global_file_information^.max_block_size <>
                      0) AND (record_info.current_byte_address =
                      file_instance^.global_file_information^.eoi_byte_address)
                      THEN

{ must be at eoi and not on a block boundary.  Move to block_boundary as
{ first skip.

                  record_info.current_byte_address :=
                        block_info.current_block_byte_address;
                  record_info.current_byte_address :=
                        record_info.current_byte_address -
                        ((call_block.skp.count - 1) *
                        file_instance^.global_file_information^.max_block_size);
                ELSE
                  record_info.current_byte_address :=
                        record_info.current_byte_address -
                        (call_block.skp.count * file_instance^.
                        global_file_information^.max_block_size);
                IFEND;
                record_info.bor_address := record_info.current_byte_address;
                record_info.file_position := amc$eor;
                block_info.current_block_byte_address :=
                      record_info.current_byte_address;
                file_instance^.residual_skip_count := 0;
              IFEND;
              IF file_instance^.residual_skip_count <> 0 THEN
                amp$set_file_instance_abnormal (file_identifier,
                      ame$skip_encountered_boi, amc$skip_req, 'RECORDS', status);
              IFEND;
            ELSE
              file_instance^.residual_skip_count := call_block.skp.count;
            IFEND;
          ELSE
          CASEND;

*copy   bai$save_positioning_info

          call_block.skp.file_position^ := record_info.file_position;
        END /main_code_skip/;
      IFEND;

    PROCEND skip;
?? TITLE := 'PROCEDURE [INLINE] SEEK_DIRECT', EJECT ??

    PROCEDURE [INLINE] seek_direct;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
        IF file_byte_address MOD file_instance^.global_file_information^.
              max_block_size <> 0 THEN
          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_seek_address, call_block.operation, error_text,
                status);
          RETURN;
        IFEND;

*copy bai$seek_validation
        IF NOT status.normal THEN
          RETURN;
        IFEND;

*copy bai$get_positioning_info

        IF file_byte_address = record_info.current_byte_address THEN
          RETURN;

{ A seek to the same address is a nop.

        IFEND;

        record_info.bor_address := file_byte_address;
        record_info.current_byte_address := file_byte_address;
        record_info.file_position := amc$eor;
        block_info.current_block_byte_address :=
              (record_info.current_byte_address DIV
              file_instance^.global_file_information^.max_block_size) *
              file_instance^.global_file_information^.max_block_size;
      IFEND;

*copy bai$save_positioning_info

    PROCEND seek_direct;

?? TITLE := 'PROCEDURE terminate_record', EJECT ??

    PROCEDURE terminate_record;

      IF (file_instance^.private_read_information = NIL) AND
            (file_instance^.global_file_information^.positioning_info.
            record_info.file_position = amc$mid_record) AND
            (file_instance^.global_file_information^.last_access_operation =
            amc$put_partial_req) THEN

{ If last operation was a put_partial then the record must be
{ terminated before repositioning.

        block_info := file_instance^.global_file_information^.positioning_info.
              block_info;
        record_info := file_instance^.global_file_information^.positioning_info.
              record_info;

        block_header := #ADDRESS (osc$min_ring,
              #SEGMENT (file_instance^.file_pva),
              block_info.current_block_byte_address);

        IF block_header^.block_length <
              file_instance^.global_file_information^.min_block_length THEN
          pad_to_minbl;
        IFEND;
        update_eoi;
        file_instance^.global_file_information^.positioning_info.block_info :=
              block_info;
        file_instance^.global_file_information^.positioning_info.record_info :=
              record_info;
      IFEND;

    PROCEND terminate_record;
?? TITLE := 'PROCEDURE replace_record', EJECT ??

    PROCEDURE replace_record;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSEIF file_instance^.instance_attributes.static_label.
            file_organization <> amc$sequential THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$file_organization_conflict, call_block.operation, error_text,
              status);
      ELSEIF NOT ((file_instance^.global_file_information^.positioning_info.
            record_info.file_position <> amc$mid_record) AND
            (file_instance^.global_file_information^.positioning_info.
            record_info.current_byte_address > 0)) THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_file_position, call_block.operation, error_text,
              status);
      ELSEIF (call_block.replace.working_storage_length < 0) OR
            (call_block.replace.working_storage_length >
            UPPERVALUE (amt$working_storage_length)) THEN
        amp$set_file_instance_abnormal (file_identifier, ame$improper_wsl_value,
              call_block.operation, error_text, status);
      ELSEIF call_block.replace.working_storage_length >
            file_instance^.global_file_information^.max_data_size THEN
        amp$set_file_instance_abnormal (file_identifier, ame$record_exceeds_mbl,
              call_block.operation, error_text, status);
      ELSEIF caller_id.ring > file_instance^.instance_attributes.static_label.
            ring_attributes.r1 THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$ring_validation_error, call_block.operation, error_text,
              status);
      ELSEIF NOT (pfc$modify IN file_instance^.instance_attributes.
            dynamic_label.access_mode) THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$improper_access_attempt, call_block.operation, ' MODIFY',
              status);
      ELSE
        block_info := file_instance^.global_file_information^.positioning_info.
              block_info;
        record_info := file_instance^.global_file_information^.positioning_info.
              record_info;

        block_header := #ADDRESS (osc$min_ring,
              #SEGMENT (file_instance^.file_pva),
              block_info.current_block_byte_address);
        IF block_header^.block_length <> call_block.replace.
              working_storage_length THEN
          amp$set_file_instance_abnormal (file_identifier,
                ame$record_unequal_to_previous, call_block.operation,
                error_text, status);
          RETURN;
        IFEND;

        record_info.current_byte_address := block_info.
              current_block_byte_address + #SIZE (bat$block_header);
        record_info.bor_address := record_info.current_byte_address;

        data_ptr := #ADDRESS (osc$min_ring, #SEGMENT (file_instance^.file_pva),
              record_info.current_byte_address);

        i#move (call_block.replace.working_storage_area, data_ptr,
              call_block.replace.working_storage_length);

        record_info.current_byte_address := record_info.current_byte_address +
              call_block.replace.working_storage_length;
        record_info.file_position := amc$eor;
        record_info.record_length := call_block.replace.working_storage_length;
        file_instance^.instance_of_open_modified := TRUE;

        file_instance^.global_file_information^.positioning_info.block_info :=
              block_info;
        file_instance^.global_file_information^.positioning_info.record_info :=
              record_info;
      IFEND;
    PROCEND replace_record;
?? TITLE := 'PROCEDURE pad_to_minbl', EJECT ??

    PROCEDURE pad_to_minbl;

      block_padding_string := '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^';
      padding_length := file_instance^.global_file_information^.
            min_block_length - block_header^.block_length;

      REPEAT
        wsa := #ADDRESS (osc$min_ring,
            #SEGMENT (file_instance^.file_pva),
            record_info.current_byte_address);
        IF #SIZE (block_padding_string) >
              padding_length THEN
          x := padding_length;
        ELSE
          x := #SIZE (block_padding_string);
        IFEND;
        i#move (^block_padding_string, wsa, x);
        padding_length :=
              padding_length - x;
        record_info.current_byte_address := record_info.current_byte_address
              + x;
      UNTIL padding_length = 0;
      block_header^.block_length := file_instance^.global_file_information^.
            min_block_length;
      block_info.current_block_length := block_header^.block_length;

    PROCEND pad_to_minbl;
?? TITLE := 'PROCEDURE update_eoi', EJECT ??

    PROCEDURE update_eoi;

*copy bai$update_eoi

    PROCEND update_eoi;
?? TITLE := 'MAIN BODY OF BAM$US_BLK_UNDEFINED_REC_FAP', EJECT ??

    #CALLER_ID (caller_id);
    status.normal := TRUE;

  /process_fap_request/
    BEGIN
      bap$validate_file_identifier (file_identifier, file_instance,
            validation_ok);
      IF NOT validation_ok THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
              error_text, status);
        RETURN;
      ELSE

        file_instance^.rollback_procedure := ^rollback_procedure;
        CASE call_block.operation OF
        = amc$get_next_req =
          get_next;
        = amc$put_next_req =
          put_next;
        = amc$get_partial_req =
          get_partial;
        = amc$put_partial_req =
          put_partial;
        = amc$open_req =
*copy     bai$get_positioning_info
          block_info.current_block_byte_address :=
                (record_info.current_byte_address DIV
                file_instance^.global_file_information^.max_block_size) *
                file_instance^.global_file_information^.max_block_size;
*copy     bai$save_positioning_info
        = amc$close_req =
          terminate_record;
          bap$close (file_identifier, status);
          EXIT /process_fap_request/;
        = amc$rewind_req =
          terminate_record;
*copy     bai$rewind
        = amc$seek_direct_req =
          file_byte_address := call_block.seekd.byte_address;
          seek_direct;
        = amc$get_direct_req =
          file_byte_address := call_block.getd.byte_address;
          seek_direct;
          IF NOT status.normal THEN
            IF status.condition = ame$position_beyond_eoi THEN
              status.condition := ame$input_after_eoi;
            IFEND;
          ELSE
            get_next;
          IFEND;
        = amc$put_direct_req =
          file_byte_address := call_block.putd.byte_address;
          seek_direct;
          IF status.normal THEN
            put_next;
          IFEND;
        = amc$skip_req =
          IF call_block.skp.unit <> amc$skip_record THEN
             amp$set_file_instance_abnormal (file_identifier,
                ame$unsupported_skip, call_block.operation, ' ',
                status);
          ELSE
             terminate_record;
             skip;
          IFEND;
        = amc$fetch_access_information_rq =
          bap$fetch_access_information (file_identifier, call_block,
                layer_number, status);
          EXIT /process_fap_request/;
        = amc$fetch_req =
          bap$fetch (file_identifier, call_block, layer_number, status);
          EXIT /process_fap_request/;
        = amc$get_segment_pointer_req =
          bap$get_segment_pointer (file_identifier, call_block, layer_number,
                status);
        = amc$set_segment_eoi_req =
          bap$set_segment_eoi (file_identifier, call_block, layer_number,
                status);
        = amc$set_segment_position_req =
          bap$set_segment_position (file_identifier, call_block, layer_number,
                status);
        = amc$replace_req =
          replace_record;
        = amc$store_req =
          bap$store (file_identifier, call_block, layer_number, status);
        = amc$write_end_partition_req =
          amp$set_file_instance_abnormal (file_identifier,
                ame$unsupported_operation, call_block.operation, error_text,
                status);
        = amc$write_tape_mark_req, amc$close_volume_req =
          amp$set_file_instance_abnormal (file_identifier,
                ame$improper_device_class, call_block.operation, 'MASS_STORAGE',
                status);
        = amc$flush_req =
          bap$write_modified_pages (file_instance, file_identifier, status);
        = ifc$fetch_terminal_req, ifc$store_terminal_req =
          pmp$get_job_mode (job_mode, status);
          IF status.normal THEN
            IF job_mode = jmc$batch THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$current_job_not_interactive, 'FETCH/STORE_TERMINAL_REQ',
                    status);
            ELSE
              amp$set_file_instance_abnormal (file_identifier,
                    ame$improper_device_class, call_block.operation,
                    'MASS STORAGE', status);
            IFEND;
          IFEND;
        ELSE
          amp$set_file_instance_abnormal (file_identifier,
                ame$unimplemented_request, call_block.operation,
                ' for sequential or byte addressable files', status);
        CASEND;
      IFEND; { validate_file_identifier }

      IF file_instance^.private_read_information = NIL THEN
        IF status.normal THEN
          file_instance^.global_file_information^.error_status := 0;
        ELSE
          file_instance^.global_file_information^.error_status :=
                status.condition;
        IFEND;
        file_instance^.global_file_information^.last_access_operation :=
              call_block.operation;
      ELSE
        IF status.normal THEN
          file_instance^.private_read_information^.error_status := 0;
        ELSE
          file_instance^.private_read_information^.error_status :=
                status.condition;
        IFEND;
        file_instance^.private_read_information^.last_access_operation :=
              call_block.operation;
      IFEND;

    END /process_fap_request/;

    file_instance^.rollback_procedure := NIL;
  PROCEND bap$us_blk_undefined_rec_fap;
MODEND bam$us_blk_undefined_rec_fap;
*DECK DECK=BAM$US_BLK_VARIABLE_REC_FAP EXPAND=TRUE
?? RIGHT := 80 ??
*copyc osd$default_pragmats
MODULE bam$us_blk_variable_rec_fap;
?? TITLE := 'NOS/VE:  BASIC ACCESS METHOD, TASK SERVICES' ??
?? NEWTITLE := 'COMMON DECLARATIONS' ??
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ame$unimplemented_request
*copyc amp$set_file_instance_abnormal
*copyc amt$fap_declarations
*copyc bap$close
*copyc bap$validate_file_identifier
*copyc bat$task_file_table
*copyc bav$task_file_table
*copyc osp$set_status_abnormal

?? TITLE := 'BAP$US_BLK_VARIABLE_REC_FAP', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$us_blk_variable_rec_fap (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    VAR
      file_instance: ^bat$task_file_entry,
      validation_ok: boolean;

    bap$validate_file_identifier (file_identifier, file_instance,
          validation_ok);
    IF NOT validation_ok THEN
      osp$set_status_abnormal (amc$access_method_id,
        ame$improper_file_id, '', status);
    ELSE
      CASE call_block.operation OF
      = amc$close_req =
        bap$close (file_identifier, status);
      ELSE
        amp$set_file_instance_abnormal (file_identifier, ame$deleted_bt_rt,
              call_block.operation, '', status);
      CASEND;
    IFEND;

  PROCEND bap$us_blk_variable_rec_fap;
MODEND bam$us_blk_variable_rec_fap;
*DECK DECK=BAM$US_BLK_VAR_READ_ONLY_FAP EXPAND=TRUE
?? RIGHT := 80 ??
*copyc osd$default_pragmats
MODULE bam$us_blk_var_read_only_fap;
?? TITLE := 'NOS/VE:  BASIC ACCESS METHOD, TASK SERVICES' ??
?? NEWTITLE := 'COMMON DECLARATIONS' ??
*copyc amc$condition_code_limits
*copyc ame$device_class_validation
*copyc ame$access_validation_errors
*copyc ame$file_organization_errors
*copyc ame$improper_file_id
*copyc ame$ring_validation_errors
*copyc ame$conflicting_access_level
*copyc ame$unimplemented_request
*copyc ame$get_program_actions
*copyc ame$fap_validation_errors
*copyc ame$improper_wsl
*copyc ame$put_validation_errors
*copyc ame$get_validation_errors
*copyc ame$open_validation_errors
*copyc amp$set_file_instance_abnormal
*copyc amt$fap_declarations
*copyc bap$close
*copyc bap$fetch_access_information
*copyc bap$fetch
*copyc bap$get_segment_pointer
*copyc bap$rewind
*copyc bap$set_segment_position
*copyc bap$store
*copyc bap$validate_file_identifier
*copyc bat$block_header
*copyc bat$global_file_information
*copyc bat$positioning_info
*copyc bat$record_header_type
*copyc bat$task_file_table
*copyc bav$task_file_table
*copyc i#move
*copyc ife$error_codes
*copyc mmp$set_segment_length
*copyc pmp$get_job_mode
*copyc osd$virtual_address
*copyc osp$fetch_locked_variable
*copyc osp$set_status_abnormal
*copyc ost$caller_identifier

?? TITLE := 'BAP$US_BLK_VAR_READ_ONLY_FAP', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$us_blk_var_read_only_fap
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    CONST
      error_text = 'BAP$US_BLK_VAR_READ_ONLY_FAP';

    VAR
      at_eoi: boolean,
      block_header: ^bat$block_header,
      block_info: bat$block_info,
      caller_id: ost$caller_identifier,
      data_moved: 0 .. amc$maximum_block,
      data_ptr: ^cell,
      file_instance: ^bat$task_file_entry,
      job_mode: jmt$job_mode,
      more_data: boolean,
      record_header: ^bat$record_header,
      record_info: bat$record_info,
      record_spans_blocks: boolean,
      starting_new_block: boolean,
      starting_new_record: boolean,
      update_segment_length: boolean,
      validation_ok: boolean,
      wsa: ^cell,
      wsl: amt$working_storage_length,
      x: integer;

?? TITLE := 'rollback_procedure', EJECT ??

    PROCEDURE rollback_procedure
      (    condition_status: ost$status);

      status := condition_status;
      file_instance^.rollback_procedure := NIL;
      EXIT bap$us_blk_var_read_only_fap;

    PROCEND rollback_procedure;

?? TITLE := 'GET_NEXT', EJECT ??

    PROCEDURE get_next;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_read_access
        IF status.normal THEN

        /main_code_get_next/
          BEGIN
            IF record_info.file_position = amc$mid_record THEN
              move_to_next_start_header (status);
              IF NOT status.normal THEN
                EXIT /main_code_get_next/;
              IFEND;
            IFEND;

*copy       bai$get_eoi_check
            IF NOT at_eoi THEN
              data_moved := 0;
              more_data := TRUE;
              wsa := call_block.getn.working_storage_area;
              wsl := call_block.getn.working_storage_length;
              REPEAT
                position_to_next_block (status);
                IF NOT status.normal THEN
                  EXIT /main_code_get_next/;
                IFEND;

                record_info.current_byte_address :=
                      record_info.current_byte_address +
                      #SIZE (bat$record_header);

                IF wsl > record_header^.length THEN
                  wsl := record_header^.length;
                IFEND;

                data_ptr := #ADDRESS (#RING (file_instance^.file_pva),
                      #SEGMENT (file_instance^.file_pva),
                      record_info.current_byte_address);

                i#move (data_ptr, wsa, wsl);

                record_info.current_byte_address :=
                      record_info.current_byte_address + wsl;
                data_moved := data_moved + wsl;

                block_info.residual_block_length :=
                      block_info.residual_block_length - wsl -
                      #SIZE (bat$record_header);

                IF (data_moved < call_block.getn.working_storage_length) AND
                      (record_info.current_byte_address <
                      file_instance^.global_file_information^.
                      eoi_byte_address) AND (record_header^.header_type <>
                      bac$full_record) AND (record_header^.header_type <>
                      bac$end_record) THEN
                  { prepare to loop and get more data }
                  wsa := #ADDRESS (#RING (wsa), #SEGMENT (wsa),
                        (#OFFSET (wsa) + wsl));
                  wsl := call_block.getn.working_storage_length - data_moved;
                ELSE
                  more_data := FALSE;
                IFEND;
              UNTIL ((NOT more_data) OR (record_header^.header_type =
                    bac$full_record) OR (record_header^.header_type =
                    bac$end_record) OR (record_header^.header_type =
                    bac$partition));

              CASE record_header^.header_type OF
              = bac$full_record, bac$end_record =
                IF wsl < record_header^.length THEN
                  record_info.file_position := amc$mid_record;
                ELSE
                  record_info.file_position := amc$eor;
                IFEND;
              = bac$start_record, bac$continued_record =
                record_info.file_position := amc$mid_record;
              = bac$partition =
                record_info.file_position := amc$eop;
              ELSE
                amp$set_file_instance_abnormal (file_identifier,
                      ame$improper_record_header, call_block.operation,
                      error_text, status);
              CASEND;

              { update local file information }

              record_info.record_length := data_moved;
            IFEND; { NOT at eoi }

            call_block.getn.file_position^ := record_info.file_position;
            call_block.getn.transfer_count^ := data_moved;
            IF call_block.operation = amc$get_next_req THEN
              call_block.getn.byte_address^ := record_info.bor_address;
            IFEND;

          END /main_code_get_next/;
        IFEND;
      IFEND;
    PROCEND get_next;

    PROCEDURE get_partial;

      IF file_instance^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (file_identifier,
              ame$conflicting_access_level, call_block.operation, error_text,
              status);
      ELSE
*copy   bai$validate_read_access
        IF status.normal THEN
          IF (call_block.getp.skip_option < LOWERVALUE (amt$skip_option)) OR
                (call_block.getp.skip_option > UPPERVALUE (amt$skip_option))
                THEN
            amp$set_file_instance_abnormal (file_identifier,
                  ame$improper_skip_option, call_block.operation, error_text,
                  status);
          ELSE

          /main_code_get_partial/
            BEGIN

              block_info.residual_block_length :=
                    block_info.current_block_byte_address +
                    block_header^.block_length + #SIZE (bat$block_header) -
                    record_info.current_byte_address;

              IF ((call_block.getp.skip_option = amc$skip_to_eor) AND
                    (record_info.file_position = amc$mid_record)) OR
                    (record_info.current_byte_address = 0) THEN
                move_to_next_start_header (status);
                IF NOT status.normal THEN
                  EXIT /main_code_get_partial/;
                IFEND;
              IFEND;

*copy         bai$get_eoi_check
              IF NOT at_eoi THEN

                block_header := #ADDRESS (#RING (file_instance^.file_pva),
                      #SEGMENT (file_instance^.file_pva),
                      block_info.current_block_byte_address);
*copy           bai$validate_block_header
                IF NOT status.normal THEN
                  EXIT /main_code_get_partial/;
                IFEND;

                IF record_info.file_position = amc$mid_record THEN
                  record_header := #ADDRESS (osc$min_ring,
                        #SEGMENT (file_instance^.file_pva),
                        record_info.bor_address);
                IFEND;

                wsa := call_block.getp.working_storage_area;
                wsl := call_block.getp.working_storage_length;
                data_moved := 0;
                more_data := TRUE;

                REPEAT
                  position_to_next_block (status);
                  IF NOT status.normal THEN
                    EXIT /main_code_get_partial/;
                  IFEND;

                  IF (record_info.residual_record_length = 0) OR
                        (record_info.current_byte_address =
                        block_info.current_block_byte_address +
                        #SIZE (bat$block_header)) THEN
*copy               bai$validate_record_header
                    IF NOT status.normal THEN
                      EXIT /main_code_get_partial/;
                    IFEND;
                    record_info.bor_address := record_info.current_byte_address;
                    record_info.residual_record_length := record_header^.length;
                    record_info.current_byte_address :=
                          record_info.current_byte_address +
                          #SIZE (bat$record_header);
                    block_info.residual_block_length :=
                          block_info.residual_block_length -
                          #SIZE (bat$record_header);
                  IFEND;

                  IF wsl >= record_info.residual_record_length THEN
                    wsl := record_info.residual_record_length;
                  IFEND;

                  data_ptr := #ADDRESS (#RING (file_instance^.file_pva),
                        #SEGMENT (file_instance^.file_pva),
                        record_info.current_byte_address);

                  i#move (data_ptr, wsa, wsl);

                  block_info.residual_block_length :=
                        block_info.residual_block_length - wsl;

                  record_info.current_byte_address :=
                        record_info.current_byte_address + wsl;
                  data_moved := data_moved + wsl;
                  IF (data_moved < call_block.getp.working_storage_length) AND
                        (record_info.current_byte_address <
                        file_instance^.global_file_information^.
                        eoi_byte_address) AND (record_header^.header_type <>
                        bac$full_record) AND (record_header^.header_type <>
                        bac$end_record) THEN
                    { prepare to loop and get more data }
                    wsa := #ADDRESS (#RING (wsa), #SEGMENT (wsa),
                          (#OFFSET (wsa) + wsl));
                    wsl := call_block.getp.working_storage_length - data_moved;
                  ELSE
                    more_data := FALSE;
                  IFEND;
                UNTIL ((NOT more_data) OR (record_header^.header_type =
                      bac$full_record) OR (record_header^.header_type =
                      bac$end_record) OR (record_header^.header_type =
                      bac$partition));

                IF record_info.file_position <> amc$mid_record THEN
                  record_info.record_length := data_moved;
                ELSE
                  record_info.record_length := record_info.record_length +
                        data_moved;
                IFEND;

                CASE record_header^.header_type OF
                = bac$full_record, bac$end_record =
                  IF record_info.current_byte_address =
                        record_info.record_header_fba +
                        #SIZE (bat$record_header) + record_header^.length THEN
                    record_info.file_position := amc$eor;
                  ELSE
                    record_info.file_position := amc$mid_record;
                  IFEND;
                = bac$start_record, bac$continued_record =
                  record_info.file_position := amc$mid_record;
                = bac$partition =
                  record_info.file_position := amc$eop;
                ELSE
                  amp$set_file_instance_abnormal (file_identifier,
                        ame$improper_record_header, call_block.operation,
                        error_text, status);
                CASEND;
              IFEND; { if not at eoi }

              call_block.getp.byte_address^ := record_info.bor_address;
              call_block.getp.file_position^ := record_info.file_position;
              call_block.getp.transfer_count^ := data_moved;
              call_block.getp.record_length^ := record_info.record_length;
            END /main_code_get_partial/;
          IFEND;
        IFEND;
      IFEND;
    PROCEND get_partial;
?? TITLE := 'PROCEDURE move_to_next_start_header', EJECT ??

    PROCEDURE move_to_next_start_header
      (VAR status: ost$status);

      WHILE (record_info.current_byte_address <
            file_instance^.global_file_information^.eoi_byte_address) AND
            ((record_info.file_position <> amc$eor) OR
            (block_info.residual_block_length < #SIZE (bat$record_header))) DO

        IF block_info.residual_block_length < #SIZE (bat$record_header) THEN
          position_to_next_block (status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSEIF record_info.current_byte_address <
              file_instance^.global_file_information^.eoi_byte_address THEN
*copy     bai$validate_record_header
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          record_info.current_byte_address := record_info.bor_address +
                record_header^.length;
          block_info.residual_block_length := block_info.
                current_block_byte_address + block_header^.block_length +
                #SIZE (bat$block_header) - record_info.current_byte_address;
        IFEND;
        IF (record_header^.header_type = bac$full_record) OR
              (record_header^.header_type = bac$start_record) OR
              (record_header^.header_type = bac$partition) THEN
          record_info.file_position := amc$eor;
        IFEND;
      WHILEND;

    PROCEND move_to_next_start_header;
?? TITLE := 'PROCEDURE position_to_next_block', EJECT ??

    PROCEDURE position_to_next_block
      (VAR status: ost$status);

      IF (block_info.residual_block_length < #SIZE (bat$record_header)) AND
            (record_info.current_byte_address <
            file_instance^.global_file_information^.eoi_byte_address) THEN
        IF record_info.current_byte_address <> block_info.
              current_block_byte_address THEN
          block_info.current_block_byte_address :=
                block_info.current_block_byte_address +
                file_instance^.global_file_information^.max_block_size;
          record_info.current_byte_address := block_info.
                current_block_byte_address;
        IFEND;
        block_header := #ADDRESS (osc$min_ring,
              #SEGMENT (file_instance^.file_pva),
              block_info.current_block_byte_address);

        IF record_info.current_byte_address <
              file_instance^.global_file_information^.eoi_byte_address THEN
*copy     bai$validate_block_header
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        block_info.residual_block_length := block_header^.block_length;
        record_info.current_byte_address := record_info.
              current_byte_address + #SIZE (bat$block_header);

      IFEND;
      IF record_info.current_byte_address <
            file_instance^.global_file_information^.eoi_byte_address THEN
*copy   bai$validate_record_header
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    PROCEND position_to_next_block;

?? TITLE := 'MAIN CODE OF BAM$US_BLK_VAR_READ_ONLY_FAP', EJECT ??

    #CALLER_ID (caller_id);
    status.normal := TRUE;

  /process_fap_request/
    BEGIN
      bap$validate_file_identifier (file_identifier, file_instance,
            validation_ok);
      IF NOT validation_ok THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
              error_text, status);
        RETURN;
      ELSE

        file_instance^.rollback_procedure := ^rollback_procedure;

*copy   bai$get_positioning_info

        CASE call_block.operation OF
        = amc$get_next_req =
          get_next;
        = amc$get_partial_req =
          get_partial;
        = amc$open_req =
          record_info.current_byte_address := 0;
          record_info.file_position := amc$eor;
          block_info.current_block_byte_address := 0;
          block_info.current_block_length := 0;
          block_info.residual_block_length := 0;
        = amc$fetch_access_information_rq =
          bap$fetch_access_information (file_identifier, call_block,
                layer_number, status);
        = amc$fetch_req =
          bap$fetch (file_identifier, call_block, layer_number, status);
        = amc$get_segment_pointer_req =
          bap$get_segment_pointer (file_identifier, call_block, layer_number,
                status);
        = amc$set_segment_position_req =
          bap$set_segment_position (file_identifier, call_block, layer_number,
                status);
        = amc$rewind_req =
        = amc$store_req =
          bap$store (file_identifier, call_block, layer_number, status);
        = amc$close_req =
          bap$close (file_identifier, status);
        ELSE
          amp$set_file_instance_abnormal (file_identifier,
                ame$unimplemented_request, call_block.operation,
                ' for sequential or byte addressable files', status);
        CASEND;

*copy   bai$save_positioning_info

        file_instance^.rollback_procedure := NIL;

      IFEND; { validate_file_identifier }

    END /process_fap_request/;

  PROCEND bap$us_blk_var_read_only_fap;
MODEND bam$us_blk_var_read_only_fap;
*DECK DECK=BAM$VALIDATE_COMPATIBILITY EXPAND=TRUE
*copyc osd$default_pragmats
MODULE bam$validate_compatibility;

{
{ PURPOSE:
{    This module validates upward and downward compatibility of the
{ file label between different systems.
{
{        BAP$VALIDATE_COMPATIBILITY (P_FILE_LABEL, P_FILE_LABEL_HEADER,
{              LOCAL_FILE_NAME, STATUS)
{
{ P_FILE_LABEL: (input) This parameter specifies the file label to be
{        validated.
{
{ P_FILE_LABEL_HEADER: (input) This parameter specifies the header in
{        the file label.
{
{ LOCAL_FILE_NAME: (input) This parameter specifies the local name of the
{        file whose label is to be validated.
{
{ STATUS: (output) This parameter returns the request status.
{
?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc ame$lfn_program_actions
*copyc amt$file_reference
*copyc amt$local_file_name
*copyc amt$logging_options
*copyc amt$path_name
*copyc clp$construct_path_handle_name
*copyc clp$convert_string_to_file_ref
*copyc clp$validate_name
*copyc clt$file
*copyc fmc$current_revision_level
*copyc fmc$unique_label_id
*copyc fmt$file_attribute_keys
*copyc fmt$file_label
*copyc fmt$static_label_header
*copyc fmt$static_label_item
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc ost$name
*copyc pmt$program_name
?? POP ??

  VAR
    bav$attribute_ordinal: [STATIC, oss$task_private] fmt$file_attribute_keys;

?? TITLE := '[XDCL] bap$validate_compatibility', EJECT ??

  PROCEDURE [XDCL] bap$validate_compatibility (file_label_p: fmt$p_file_label;
        p_file_label_header: ^fmt$static_label_header;
        path_handle: fmt$path_handle;
        checksum_present: boolean;
    VAR status: ost$status);

    TYPE
      attribute_keys = SET OF fmt$file_attribute_keys;

    VAR
      attributes_are_compatible: boolean,
      entry_point_refs: [STATIC, READ, oss$job_paged_literal] attribute_keys := $attribute_keys
        [fmc$compression_procedure_name, fmc$hashing_procedure_name,
        fmc$file_access_procedure, fmc$collate_table_name],
      i: integer,
      job_label: ^SEQ ( * ),
      names: [STATIC, READ, oss$job_paged_literal] attribute_keys := $attribute_keys
        [fmc$file_contents, fmc$file_processor, fmc$file_structure],
      p_file_label: fmt$p_file_label,
      static_label_item: ^fmt$static_label_item,
      str: ^string ( * ),
      text: string (50),
      text_length: integer,
      user_attributes: ^SEQ ( * ),
      x: ^cell;

    PROCEDURE set_status_abnormal (level: fmt$revision_level;
          text: string ( * );
      VAR status: ost$status);

      VAR
        path_handle_name: fst$path_handle_name;

      clp$construct_path_handle_name (path_handle, path_handle_name);
      osp$set_status_abnormal (amc$access_method_id,
            ame$incompatible_attributes, path_handle_name, status);
      osp$append_status_integer (osc$status_parameter_delimiter, level, 10,
            false, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, text,
            status);
    PROCEND set_status_abnormal;


    p_file_label := file_label_p; {make a local copy of sequence pointer}

    IF p_file_label_header^.revision_level > fmc$current_revision_level THEN
    { validate downward compatibility }

      FOR i := fmc$average_record_length TO fmc$highest_current_attribute DO
        IF p_file_label_header^.attribute_present [i] THEN
          NEXT static_label_item: [i] IN p_file_label;
          IF static_label_item = NIL THEN
            STRINGREP (text, text_length, 'downward (attribute ordinal ', i:2, ')');
            set_status_abnormal (p_file_label_header^.
                  revision_level, text(1, text_length), status);
            RETURN;
          IFEND;

          IF i IN entry_point_refs THEN
            NEXT str: [static_label_item^.entry_point_name_length] IN p_file_label;
            IF str = NIL THEN
              STRINGREP (text, text_length, 'downward (attribute ordinal ', i:2, ')');
              set_status_abnormal (p_file_label_header^.
                    revision_level, text(1, text_length), status);
              RETURN;
            IFEND;
            IF static_label_item^.entry_point_path_length > 0 THEN
              NEXT str: [static_label_item^.entry_point_path_length] IN p_file_label;
              IF str = NIL THEN
                STRINGREP (text, text_length, 'downward (attribute ordinal ', i:2, ')');
                set_status_abnormal (p_file_label_header^.
                      revision_level, text(1, text_length), status);
                RETURN;
              IFEND;
            IFEND;
          IFEND;

          IF i IN names THEN
            NEXT str: [static_label_item^.name_length] IN p_file_label;
            IF str = NIL THEN
              STRINGREP (text, text_length, 'downward (attribute ordinal ', i:2, ')');
              set_status_abnormal (p_file_label_header^.
                    revision_level, text(1, text_length), status);
              RETURN;
            IFEND;
          IFEND;

          IF i = fmc$log_residence THEN
            NEXT str: [static_label_item^.path_length] IN p_file_label;
            IF str = NIL THEN
              STRINGREP (text, text_length, 'downward (attribute ordinal ', i:2, ')');
              set_status_abnormal (p_file_label_header^.
                    revision_level, text(1, text_length), status);
              RETURN;
            IFEND;
          IFEND;

          IF i = fmc$user_info THEN
            NEXT str: [32] IN p_file_label;
            IF str = NIL THEN
              STRINGREP (text, text_length, 'downward (attribute ordinal ', i:2, ')');
              set_status_abnormal (p_file_label_header^.
                    revision_level, text(1, text_length), status);
              RETURN;
            IFEND;
          IFEND;

        IFEND;
      FOREND;
      FOR i := fmc$highest_current_attribute + 1 TO
            p_file_label_header^.highest_attribute_supported DO
        IF p_file_label_header^.attribute_present [i] THEN
          STRINGREP (text, text_length, 'downward (attribute ordinal ', i:2, ')');
          set_status_abnormal (p_file_label_header^.
                revision_level, text(1, text_length), status);
          RETURN;
        IFEND;
      FOREND;

      IF p_file_label_header^.user_attribute_length > 0 THEN
        NEXT user_attributes: [[REP p_file_label_header^.user_attribute_length
              OF cell]] IN p_file_label;
        IF user_attributes = NIL THEN
          osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
            'user_attributes NIL on downward validation in bap$validate_compatibility',
            status);
          RETURN;
        IFEND;
      IFEND;
      IF p_file_label_header^.job_routing_label_size > 0 THEN
        NEXT job_label: [[REP p_file_label_header^.job_routing_label_size
              OF cell]] IN p_file_label;
        IF job_label = NIL THEN
          osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
            'job_label NIL on downward validation in bap$validate_compatibility',
            status);
          RETURN;
        IFEND;
      IFEND;
      NEXT x IN p_file_label;
      IF x <> NIL THEN
        set_status_abnormal (p_file_label_header^.revision_level,
              'downward (x)', status);
        RETURN;
      IFEND;
      bap$validate_attributes (p_file_label, checksum_present,
            attributes_are_compatible, status);
      IF NOT attributes_are_compatible THEN
        STRINGREP (text, text_length,
          'downward (attribute validation ordinal ',
          bav$attribute_ordinal:2, ')');
        set_status_abnormal (p_file_label_header^.revision_level,
              text(1, text_length), status);
      IFEND;

    ELSEIF p_file_label_header^.revision_level < fmc$current_revision_level THEN
    { validate upward compatibility }

      FOR i := fmc$average_record_length TO p_file_label_header^.
            highest_attribute_supported DO
        IF p_file_label_header^.attribute_present [i] THEN
          NEXT static_label_item: [i] IN p_file_label;
          IF static_label_item = NIL THEN
            STRINGREP (text, text_length, 'upward (attribute ordinal ', i:2, ')');
            set_status_abnormal (p_file_label_header^.
                  revision_level, text(1, text_length), status);
            RETURN;
          IFEND;

          IF i IN entry_point_refs THEN
            NEXT str: [static_label_item^.entry_point_name_length] IN p_file_label;
            IF str = NIL THEN
              STRINGREP (text, text_length, 'upward (attribute ordinal ', i:2, ')');
              set_status_abnormal (p_file_label_header^.
                    revision_level, text(1, text_length), status);
              RETURN;
            IFEND;
            IF static_label_item^.entry_point_path_length > 0 THEN
              NEXT str: [static_label_item^.entry_point_path_length] IN p_file_label;
              IF str = NIL THEN
                STRINGREP (text, text_length, 'upward (attribute ordinal ', i:2, ')');
                set_status_abnormal (p_file_label_header^.
                      revision_level, text(1, text_length), status);
                RETURN;
              IFEND;
            IFEND;
          IFEND;

          IF i IN names THEN
            NEXT str: [static_label_item^.name_length] IN p_file_label;
            IF str = NIL THEN
              STRINGREP (text, text_length, 'upward (attribute ordinal ', i:2, ')');
              set_status_abnormal (p_file_label_header^.
                    revision_level, text(1, text_length), status);
              RETURN;
            IFEND;
          IFEND;

          IF i = fmc$log_residence THEN
            NEXT str: [static_label_item^.path_length] IN p_file_label;
            IF str = NIL THEN
              STRINGREP (text, text_length, 'upward (attribute ordinal ', i:2, ')');
              set_status_abnormal (p_file_label_header^.
                    revision_level, text(1, text_length), status);
              RETURN;
            IFEND;
          IFEND;

          IF i = fmc$user_info THEN
            NEXT str: [32] IN p_file_label;
            IF str = NIL THEN
              STRINGREP (text, text_length, 'upward (attribute ordinal ', i:2, ')');
              set_status_abnormal (p_file_label_header^.
                    revision_level, text(1, text_length), status);
              RETURN;
            IFEND;
          IFEND;

        IFEND;
      FOREND;
      FOR i := p_file_label_header^.highest_attribute_supported + 1 TO
            fmc$highest_current_attribute DO
        IF p_file_label_header^.attribute_present [i] THEN
          STRINGREP (text, text_length, 'upward (attribute ordinal ', i:2, ')');
          set_status_abnormal (p_file_label_header^.
                revision_level, text(1, text_length), status);
          RETURN;
        IFEND;
      FOREND;

      IF p_file_label_header^.user_attribute_length > 0 THEN
        NEXT user_attributes: [[REP p_file_label_header^.user_attribute_length
              OF cell]] IN p_file_label;
        IF user_attributes = NIL THEN
          osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
            'user_attributes NIL on upward validation in bap$validate_compatibility',
            status);
          RETURN;
        IFEND;
      IFEND;
      IF p_file_label_header^.job_routing_label_size > 0 THEN
        NEXT job_label: [[REP p_file_label_header^.job_routing_label_size
              OF cell]] IN p_file_label;
        IF job_label = NIL THEN
          osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
            'job_label NIL on upward validation in bap$validate_compatibility',
            status);
          RETURN;
        IFEND;
      IFEND;
      NEXT x IN p_file_label;
      IF x <> NIL THEN
        set_status_abnormal (p_file_label_header^.revision_level,
              'upward (x)', status);
        RETURN;
      IFEND;
      bap$validate_attributes (p_file_label, checksum_present,
            attributes_are_compatible, status);
      IF NOT attributes_are_compatible THEN
        STRINGREP (text, text_length,
          'upward (attribute validation ordinal ',
          bav$attribute_ordinal:2, ')');
        set_status_abnormal (p_file_label_header^.revision_level,
              text(1, text_length), status);
      IFEND;

    IFEND;
  PROCEND bap$validate_compatibility;


?? TITLE := '[XDCL] bap$validate_attributes', EJECT ??

  PROCEDURE [XDCL] bap$validate_attributes (p_static_label: ^SEQ ( * );
        checksum_present: boolean;
    VAR attributes_are_compatible: boolean;
    VAR status: ost$status);


    VAR
      amv$logging_options: [STATIC, READ, oss$job_paged_literal]
        amt$logging_options := [amc$enable_parcels, amc$enable_media_recovery,
        amc$enable_request_recovery],
      checksum: ^integer,
      header: ^fmt$static_label_header,
      attribute_key: fmt$file_attribute_keys,
      static_label: ^SEQ ( * ),
      static_label_item: ^fmt$static_label_item,
      collate_table_name: pmt$program_name,
      compression_procedure_name: pmt$program_name,
      compression_procedure_path: amt$path_name,
      hashing_procedure_name: pmt$program_name,
      hashing_procedure_path: amt$path_name,
      fap_name: pmt$program_name,
      file_contents,
      file_processor,
      file_structure: pmt$program_name,
      validated_name: ost$name,
      ignore_file: fst$parsed_file_reference,
      ignore_path: amt$path_name,
      ignore_found: boolean,
      str: ^string ( * );

    PROCEDURE [INLINE] get_entry_point_reference (VAR name: pmt$program_name;
      VAR path: amt$file_reference);

      NEXT str: [static_label_item^.entry_point_name_length] IN static_label;
      IF str = NIL THEN
        osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
          'str NIL in bap$validate_attributes for entry_point_name', status);
        RETURN;
      IFEND;
      name := str^;
      IF static_label_item^.entry_point_path_length > 0 THEN
        NEXT str: [static_label_item^.entry_point_path_length] IN static_label;
        IF str = NIL THEN
          osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
            'str NIL in bap$validate_attributes for entry_point_path', status);
          RETURN;
        IFEND;
        path := str^;
      IFEND;
    PROCEND get_entry_point_reference;

    PROCEDURE [INLINE] get_name (VAR name: pmt$program_name);

      NEXT str: [static_label_item^.name_length] IN static_label;
      IF str = NIL THEN
        osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
          'get_name str NIL in bap$validate_attributes', status);
        RETURN;
      IFEND;
      name := str^;
    PROCEND get_name;

    status.normal := TRUE;
    attributes_are_compatible := TRUE;

    static_label := p_static_label; {assign seq pointer to local variable}

    IF static_label <> NIL THEN
      RESET static_label;
      IF checksum_present THEN
        NEXT checksum IN static_label;
        IF checksum = NIL THEN
          osp$set_status_abnormal (amc$access_method_id,
                ame$damaged_file_attributes,
                'BAD LABEL DETECTED in bap$validate_attributes', status);
          RETURN;
        IFEND;
      IFEND;
      NEXT header IN static_label;
      IF (header = NIL) OR (header^.unique_character <> fmc$unique_label_id) THEN
        osp$set_status_abnormal (amc$access_method_id,
              ame$damaged_file_attributes,
              'INVALID STATIC LABEL DETECTED in bap$validate_attributes',
              status);
        RETURN;
      IFEND;
      IF header^.file_previously_opened THEN
        IF NOT ((1 <= header^.ring_attributes.r1) AND
              (header^.ring_attributes.r1 <= header^. ring_attributes.r2)
              AND (header^.ring_attributes.r2 <= header^.ring_attributes.r3)
              AND (header^.ring_attributes.r3 <= 13)) THEN
          attributes_are_compatible := FALSE;
        IFEND;
      IFEND;
      IF header^.highest_attribute_present > 0 THEN
        attribute_key := fmc$average_record_length;
        WHILE (attribute_key <= header^.highest_attribute_present) AND
              (attributes_are_compatible) DO
          IF header^.attribute_present [attribute_key] THEN
            CASE attribute_key OF
            = fmc$block_type =
              NEXT static_label_item: [fmc$block_type] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'block_type NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.block_type < LOWERVALUE (amt$block_type))
                    OR (static_label_item^.block_type > UPPERVALUE
                    (amt$block_type)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$character_conversion =
              NEXT static_label_item: [fmc$character_conversion] IN
                    static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'character_conversion NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.character_conversion < LOWERVALUE
                    (boolean)) OR (static_label_item^.character_conversion >
                    UPPERVALUE (boolean)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$clear_space =
              NEXT static_label_item: [fmc$clear_space] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'clear_space NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.clear_space < LOWERVALUE
                    (ost$clear_file_space)) OR (static_label_item^.clear_space
                    > UPPERVALUE (ost$clear_file_space)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$file_access_procedure =
              NEXT static_label_item: [fmc$file_access_procedure] IN
                    static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'file_access_procedure NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              get_entry_point_reference (fap_name, ignore_path);
              clp$validate_name (fap_name, validated_name,
                    attributes_are_compatible);
            = fmc$file_contents =
              NEXT static_label_item: [fmc$file_contents] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'file_contents NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              get_name (file_contents);
              clp$validate_name (file_contents, validated_name,
                    attributes_are_compatible);
            = fmc$file_limit =
              NEXT static_label_item: [fmc$file_limit] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'file_limit NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$file_limit)) OR (static_label_item^.integer_value >
                    UPPERVALUE (amt$file_limit)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$file_organization =
              NEXT static_label_item: [fmc$file_organization] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'file_organization NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.file_organization < LOWERVALUE
                    (amt$file_organization)) OR (static_label_item^.
                    file_organization > UPPERVALUE (amt$file_organization))
                    THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$file_processor =
              NEXT static_label_item: [fmc$file_processor] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'file_processor NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              get_name (file_processor);
              clp$validate_name (file_processor, validated_name,
                    attributes_are_compatible);
            = fmc$file_structure =
              NEXT static_label_item: [fmc$file_structure] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'file_structure NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              get_name (file_structure);
              clp$validate_name (file_structure, validated_name,
                    attributes_are_compatible);
            = fmc$forced_write =
              NEXT static_label_item: [fmc$forced_write] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'forced_write NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.forced_write < LOWERVALUE
                    (amt$forced_write)) OR (static_label_item^.forced_write >
                    UPPERVALUE (amt$forced_write)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$internal_code =
              NEXT static_label_item: [fmc$internal_code] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'internal_code NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.internal_code < LOWERVALUE
                    (amt$internal_code)) OR (static_label_item^.internal_code >
                    UPPERVALUE (amt$internal_code)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$label_type =
              NEXT static_label_item: [fmc$label_type] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'label_type NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.label_type < LOWERVALUE (amt$label_type))
                    OR (static_label_item^.label_type > UPPERVALUE
                    (amt$label_type)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$line_number =
              NEXT static_label_item: [fmc$line_number] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'line_number NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.line_number.length < LOWERVALUE
                    (amt$line_number_length)) OR (static_label_item^.
                    line_number.length > UPPERVALUE (amt$line_number_length))
                    OR (static_label_item^.line_number.location < LOWERVALUE
                    (amt$line_number_location)) OR (static_label_item^.
                    line_number.location > UPPERVALUE
                    (amt$line_number_location)) THEN
                IF (static_label_item^.source = amc$undefined_attribute) THEN
                  { Old default value; must be changed later.
                  { A change here will cause a change to pf label without
                  { a corresponding checksum change.
                ELSE
                  attributes_are_compatible := FALSE;
                IFEND;
              IFEND;
            = fmc$max_block_length =
              NEXT static_label_item: [fmc$max_block_length] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'max_block_length NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$max_block_length)) OR (static_label_item^.
                    integer_value > UPPERVALUE (amt$max_block_length)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$max_record_length =
              NEXT static_label_item: [fmc$max_record_length] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'max_record_length NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$max_record_length)) OR (static_label_item^.
                    integer_value > UPPERVALUE (amt$max_record_length)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$min_block_length =
              NEXT static_label_item: [fmc$min_block_length] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'min_block_length NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$min_block_length)) OR (static_label_item^.
                    integer_value > UPPERVALUE (amt$min_block_length)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$min_record_length =
              NEXT static_label_item: [fmc$min_record_length] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'min_record_length NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$min_record_length)) OR (static_label_item^.
                    integer_value > UPPERVALUE (amt$min_record_length)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$padding_character =
              NEXT static_label_item: [fmc$padding_character] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'padding_character NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.padding_character < LOWERVALUE
                    (static_label_item^.padding_character)) OR
                    (static_label_item^.padding_character > UPPERVALUE
                    (static_label_item^.padding_character)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$page_format =
              NEXT static_label_item: [fmc$page_format] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'page_format NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.page_format < LOWERVALUE
                    (amt$page_format)) OR (static_label_item^.page_format >
                    UPPERVALUE (amt$page_format)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$page_length =
              NEXT static_label_item: [fmc$page_length] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'page_length NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$page_length)) OR (static_label_item^.integer_value >
                    UPPERVALUE (amt$page_length)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$page_width =
              NEXT static_label_item: [fmc$page_width] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'page_width NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$page_width)) OR (static_label_item^.integer_value >
                    UPPERVALUE (amt$page_width)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$preset_value =
              NEXT static_label_item: [fmc$preset_value] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'preset_value NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$preset_value)) OR (static_label_item^.integer_value >
                    UPPERVALUE (amt$preset_value)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$record_delimiting_character =
              NEXT static_label_item: [fmc$record_delimiting_character] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'record_delimiting_character NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
            = fmc$record_type =
              NEXT static_label_item: [fmc$record_type] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'record_type NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.record_type < LOWERVALUE
                    (amt$record_type)) OR (static_label_item^.record_type >
                    UPPERVALUE (amt$record_type)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$statement_identifier =
              NEXT static_label_item: [fmc$statement_identifier] IN
                    static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'statement_identifier NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF ((static_label_item^.statement_identifier.length < LOWERVALUE
                    (amt$statement_id_length)) OR (static_label_item^.
                    statement_identifier.length > UPPERVALUE
                    (amt$statement_id_length)) OR (static_label_item^.
                    statement_identifier.location < LOWERVALUE
                    (amt$statement_id_location)) OR (static_label_item^.
                    statement_identifier.location > UPPERVALUE
                    (amt$statement_id_location))) THEN
                IF (static_label_item^.source = amc$undefined_attribute) THEN
                  { Old default value; must be changed later.
                  { A change here will cause a change to pf label without
                  { a corresponding checksum change.
                ELSE
                  attributes_are_compatible := FALSE;
                IFEND;
              IFEND;
            = fmc$user_info =
              NEXT static_label_item: [fmc$user_info] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'user_info NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF static_label_item^.user_info_present THEN
                NEXT str: [32] IN static_label;
              IFEND;
            = fmc$vertical_print_density =
              NEXT static_label_item: [fmc$vertical_print_density] IN
                    static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'vertical_print_density NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$vertical_print_density)) OR (static_label_item^.
                    integer_value > UPPERVALUE (amt$vertical_print_density)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$average_record_length =
              NEXT static_label_item: [fmc$average_record_length] IN
                    static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'average_record_length NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$average_record_length)) OR (static_label_item^.
                    integer_value > UPPERVALUE (amt$average_record_length)) THEN
                IF static_label_item^.source <> amc$undefined_attribute THEN
                  attributes_are_compatible := FALSE;
                IFEND;
              IFEND;
            = fmc$collate_table =
              NEXT static_label_item: [fmc$collate_table] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'collate_table NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
            = fmc$collate_table_name =
              NEXT static_label_item: [fmc$collate_table_name] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'collate_table_name NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              get_entry_point_reference (collate_table_name, ignore_path);
              IF collate_table_name <> osc$null_name THEN
                clp$validate_name (collate_table_name, validated_name,
                      attributes_are_compatible);
              IFEND;
            = fmc$compression_procedure_name =
              NEXT static_label_item: [fmc$compression_procedure_name] IN
                    static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'compression_procedure_name NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              get_entry_point_reference (compression_procedure_name,
                    compression_procedure_path);
              IF compression_procedure_name <> osc$null_name THEN
                clp$validate_name (compression_procedure_name, validated_name,
                      attributes_are_compatible);
                IF compression_procedure_path <> osc$null_name THEN
                  clp$convert_string_to_file_ref (compression_procedure_path,
                        ignore_file, status);
                  IF NOT status.normal THEN
                    attributes_are_compatible := FALSE;
                  IFEND;
                IFEND;
              IFEND;
            = fmc$data_padding =
              NEXT static_label_item: [fmc$data_padding] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'data_padding NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.data_padding < LOWERVALUE
                    (amt$data_padding)) OR (static_label_item^.data_padding >
                    UPPERVALUE (amt$data_padding)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$dynamic_home_block_space =
              NEXT static_label_item: [fmc$dynamic_home_block_space] IN
                    static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'dynamic_home_block_space NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.dynamic_home_block_space < LOWERVALUE
                    (boolean)) OR (static_label_item^.dynamic_home_block_space
                    > UPPERVALUE (boolean)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$embedded_key =
              NEXT static_label_item: [fmc$embedded_key] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'embedded_key NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.embedded_key < LOWERVALUE (boolean)) OR
                    (static_label_item^.embedded_key > UPPERVALUE (boolean))
                    THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$estimated_record_count =
              NEXT static_label_item: [fmc$estimated_record_count] IN
                    static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'estimated_record_count NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$estimated_record_count)) OR (static_label_item^.
                    integer_value > UPPERVALUE (amt$estimated_record_count))
                    THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$hashing_procedure_name =
              NEXT static_label_item: [fmc$hashing_procedure_name] IN
                    static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'hashing_procedure_name NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              get_entry_point_reference (hashing_procedure_name,
                    hashing_procedure_path);
              IF hashing_procedure_name <> osc$null_name THEN
                clp$validate_name (hashing_procedure_name, validated_name,
                      attributes_are_compatible);
                IF hashing_procedure_path <> osc$null_name THEN
                  clp$convert_string_to_file_ref (hashing_procedure_path,
                        ignore_file, status);
                  IF NOT status.normal THEN
                    attributes_are_compatible := FALSE;
                  IFEND;
                IFEND;
              IFEND;
            = fmc$index_levels =
              NEXT static_label_item: [fmc$index_levels] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'index_levels NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$index_levels)) OR (static_label_item^.integer_value >
                    UPPERVALUE (amt$index_levels)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$index_padding =
              NEXT static_label_item: [fmc$index_padding] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'index_padding NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.index_padding < LOWERVALUE
                    (amt$index_padding)) OR (static_label_item^.index_padding >
                    UPPERVALUE (amt$index_padding)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$initial_home_block_count =
              NEXT static_label_item: [fmc$initial_home_block_count] IN
                    static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'initial_home_block_count NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$initial_home_block_count)) OR (static_label_item^.
                    integer_value > UPPERVALUE (amt$initial_home_block_count))
                    THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$key_length =
              NEXT static_label_item: [fmc$key_length] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'key_length NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$key_length)) OR (static_label_item^.integer_value >
                    UPPERVALUE (amt$key_length)) THEN
                IF static_label_item^.source <> amc$undefined_attribute THEN
                  attributes_are_compatible := FALSE;
                IFEND;
              IFEND;
            = fmc$key_position =
              NEXT static_label_item: [fmc$key_position] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'key_position NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$key_position)) OR (static_label_item^.integer_value >
                    UPPERVALUE (amt$key_position)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$key_type =
              NEXT static_label_item: [fmc$key_type] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'key_type NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.key_type < LOWERVALUE (amt$key_type)) OR
                    (static_label_item^.key_type > UPPERVALUE (amt$key_type))
                    THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$loading_factor =
              NEXT static_label_item: [fmc$loading_factor] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'loading_factor NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.loading_factor < LOWERVALUE
                    (amt$loading_factor)) OR (static_label_item^.loading_factor
                    > UPPERVALUE (amt$loading_factor)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$lock_expiration_time =
              NEXT static_label_item: [fmc$lock_expiration_time] IN
                    static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'lock_expiration_time NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$lock_expiration_time)) OR (static_label_item^.
                    integer_value > UPPERVALUE (amt$lock_expiration_time)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$logging_options =
              NEXT static_label_item: [fmc$logging_options] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'logging_options NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF NOT (static_label_item^.logging_options <=
                    amv$logging_options) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            = fmc$log_residence =
              NEXT static_label_item: [fmc$log_residence] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'log_residence NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              NEXT str: [static_label_item^.path_length] IN static_label;
              IF str = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'log_residence str NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF str^ <> osc$null_name THEN
                clp$convert_string_to_file_ref (str^, ignore_file, status);
                IF NOT status.normal THEN
                  attributes_are_compatible := FALSE;
                IFEND;
              IFEND;
            = fmc$record_limit =
              NEXT static_label_item: [fmc$record_limit] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'record_limit NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$record_limit)) OR (static_label_item^.integer_value >
                    UPPERVALUE (amt$record_limit)) THEN
                IF static_label_item^.source <> amc$undefined_attribute THEN
                  attributes_are_compatible := FALSE;
                IFEND;
              IFEND;
            = fmc$records_per_block =
              NEXT static_label_item: [fmc$records_per_block] IN static_label;
              IF static_label_item = NIL THEN
                osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'records_per_block NIL in bap$validate_attributes', status);
                RETURN;
              IFEND;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (amt$records_per_block)) OR (static_label_item^.
                    integer_value > UPPERVALUE (amt$records_per_block)) THEN
                IF static_label_item^.source <> amc$undefined_attribute THEN
                  attributes_are_compatible := FALSE;
                IFEND;
              IFEND;
            ELSE
              attributes_are_compatible := FALSE;
            CASEND;
          IFEND;
          attribute_key := attribute_key + 1;
        WHILEND;
      IFEND;
    IFEND;

  PROCEND bap$validate_attributes;

MODEND bam$validate_compatibility;

*DECK DECK=BAM$V_TO_T_RECORD_CONVERSION EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE bam$v_to_t_record_conversion;

?? TITLE := ' PROCEDRUE bap$v_to_t_record_conversion ' ??
?? PUSH (LISTEXT := ON) ??
*copyc BAK$BAP_PROCEDURE_KEYPOINTS
*copyc AME$IMPROPER_FILE_ID
*copyc BAV$TASK_FILE_TABLE
*copyc OSP$SET_STATUS_ABNORMAL
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc AMP$SET_LOCAL_NAME_ABNORMAL
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OST$CALLER_IDENTIFIER
*copyc BAT$TASK_FILE_TABLE
*copyc BAT$RECORD_HEADER_TYPE
*copyc AME$RING_VALIDATION_ERRORS
*copyc AME$ACCESS_VALIDATION_ERRORS
*copyc I#MOVE
?? POP ??

  PROCEDURE [XDCL, #GATE] bap$v_to_t_record_conversion
        (from_fid: amt$file_identifier;
        to_fid: amt$file_identifier;
        file_size_source: amt$file_byte_address;
    VAR current_byte_source: amt$file_byte_address;
    VAR current_byte_destination: amt$file_byte_address;
    VAR last_move: boolean;
    VAR status: ost$status);

    VAR
      from_pointer: ^cell,
      to_pointer: ^cell,
      file_id_is_valid: boolean,
      file_instance_from: ^bat$task_file_entry,
      file_instance_to: ^bat$task_file_entry,
      move_to: amt$file_byte_address,
      caller_id: ost$caller_identifier;

    PROCEDURE rollback_procedure (condition_status: ost$status);

      status := condition_status;
      file_instance_from^.rollback_procedure := NIL;
      file_instance_to^.rollback_procedure := NIL;
      EXIT bap$v_to_t_record_conversion;
    PROCEND rollback_procedure;

  /main_program/
    BEGIN
      #caller_id (caller_id);

      status.normal := TRUE;

      bap$validate_file_identifier (from_fid, file_instance_from, file_id_is_valid);
      IF NOT file_id_is_valid THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
          'bap$v_to_t_record_conversion', status);
        EXIT /main_program/;
      IFEND;

      IF caller_id.ring <> file_instance_from^.open_ring THEN
        amp$set_file_instance_abnormal (from_fid, ame$ring_validation_error,
              fsc$copy_file_req, ' ', status);
        EXIT /main_program/;
      IFEND;

      IF file_instance_from^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (from_fid, ame$improper_access_attempt,
              fsc$copy_file_req, ' RECORD ', status);
        EXIT /main_program/;
      IFEND;

      IF NOT (pfc$read IN file_instance_from^.instance_attributes.dynamic_label.access_mode) THEN
        amp$set_file_instance_abnormal (from_fid, ame$improper_access_attempt,
              fsc$copy_file_req, ' READ ', status);
        EXIT /main_program/;
      IFEND;

      bap$validate_file_identifier (to_fid, file_instance_to, file_id_is_valid);
      IF NOT file_id_is_valid THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
          'bap$v_to_t_record_conversion', status);
        EXIT /main_program/;
      IFEND;

      IF caller_id.ring <> file_instance_to^.open_ring THEN
        amp$set_file_instance_abnormal (to_fid, ame$ring_validation_error,
              fsc$copy_file_req, ' ', status);
        EXIT /main_program/;
      IFEND;

      IF file_instance_to^.access_level <> amc$record THEN
        amp$set_file_instance_abnormal (to_fid, ame$improper_access_attempt,
              fsc$copy_file_req, ' RECORD ', status);
        EXIT /main_program/;
      IFEND;

      IF NOT (file_instance_to^.instance_attributes.dynamic_label.access_mode >=
            $pft$usage_selections [pfc$shorten, pfc$append]) THEN
        amp$set_file_instance_abnormal (to_fid, ame$improper_access_attempt,
              fsc$copy_file_req, ' SHORTEN, APPEND ', status);
        EXIT /main_program/;
      IFEND;

      file_instance_from^.rollback_procedure := ^rollback_procedure;
      file_instance_to^.rollback_procedure := ^rollback_procedure;

      from_pointer := #ADDRESS ( #RING (file_instance_from^.file_pva),
            #SEGMENT (file_instance_from^.file_pva), current_byte_source);
      to_pointer := #address ( #RING (file_instance_to^.file_pva),
            #SEGMENT (file_instance_to^.file_pva), current_byte_destination);
      move_data (from_pointer, to_pointer, file_size_source,
            file_instance_to^.global_file_information^.record_delimiting_character,
            current_byte_source, current_byte_destination, last_move);

      IF file_instance_from^.private_read_information <> NIL THEN
        file_instance_from^.private_read_information^.positioning_info.
              record_info.current_byte_address := current_byte_source;
        IF last_move THEN
          file_instance_from^.private_read_information^.positioning_info.
                record_info.file_position := amc$eoi;
        IFEND;
      ELSE
        file_instance_from^.global_file_information^.positioning_info.
              record_info.current_byte_address := current_byte_source;
        IF last_move THEN
          file_instance_from^.global_file_information^.positioning_info.
                record_info.file_position := amc$eoi;
        IFEND;
      IFEND;

      file_instance_to^.instance_of_open_modified := TRUE;

      file_instance_to^.global_file_information^.positioning_info.record_info.
            current_byte_address := current_byte_destination;
      file_instance_to^.global_file_information^.eoi_byte_address :=
            current_byte_destination;
      file_instance_to^.global_file_information^.positioning_info.record_info.
            file_position := amc$eoi;
    END /main_program/;
    file_instance_from^.rollback_procedure := NIL;
    file_instance_to^.rollback_procedure := NIL;

  PROCEND bap$v_to_t_record_conversion;

?? TITLE := '  Internal_procedure move_data', EJECT ??

  PROCEDURE move_data (source: ^cell;
        destination: ^cell;
        file_length_source: amt$file_byte_address;
        record_delimiting_character: char;
    VAR current_byte_source: amt$file_byte_address;
    VAR current_byte_destination: amt$file_byte_address;
    VAR last_move: boolean);

    VAR
      from_ring: 0 .. 0f(16),
      to_ring: 0 .. 0f(16),
      from_segment: 0 .. 0fff(16),
      to_segment: 0 .. 0fff(16),
      from_header: 0 .. 0ffffffff(16),
      from_record: 0 .. 0ffffffff(16),
      to_record: 0 .. 0ffffffff(16),
      next_from: ^cell,
      next_to: ^cell,
      next_header: ^bat$record_header,
      records_moved: integer,
      transfer_length: integer,
      trailing_character_p: ^char;

    from_ring := #RING (source);
    from_segment := #SEGMENT (source);
    from_header := #OFFSET (source);
    from_record := from_header + #SIZE (bat$record_header);
    to_ring := #RING (destination);
    to_segment := #SEGMENT (destination);
    to_record := #OFFSET (destination);
    last_move := TRUE;
    records_moved := 0;

    /copy_the_records/
    WHILE from_header < file_length_source DO
       next_from := #ADDRESS (from_ring, from_segment, from_record);
       next_to := #ADDRESS (to_ring, to_segment, to_record);
       next_header := #ADDRESS (from_ring, from_segment, from_header);
       transfer_length := next_header^.length;
       IF transfer_length > 0 THEN
         I#MOVE (next_from, next_to, transfer_length);
       IFEND;
       trailing_character_p := #address (to_ring, to_segment, to_record + transfer_length);
       trailing_character_p^ := record_delimiting_character;
       from_record := from_record + transfer_length + #SIZE (bat$record_header);
       from_header := from_header + transfer_length + #SIZE (bat$record_header);
       to_record := to_record + transfer_length + 1;
       records_moved := records_moved +1;

{ 10000 records were chosen to allow for interruptability of the copy

       IF records_moved = 10000 THEN
         last_move := FALSE;
         EXIT /copy_the_records/;
       IFEND;
    WHILEND /copy_the_records/;

    current_byte_source := from_header;
    current_byte_destination := to_record;
    PROCEND move_data;

MODEND bam$v_to_t_record_conversion;
*DECK DECK=BAP$ADD_TO_FILE_DESCRIPTION EXPAND=FALSE

{ COMMON DECK BAXATFD }

  PROCEDURE [XREF] bap$add_to_file_description (file_identifier:
    amt$file_identifier;
    file_attributes: ^amt$add_to_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$ADD_TO_ATTRIBUTES
*copyc OST$STATUS
?? POP ??
*DECK DECK=BAP$AFTER_TRAILER_LABELS EXPAND=FALSE
  FUNCTION [INLINE] bap$after_trailer_labels
    (    labeled_volume_position: bat$labeled_volume_position): boolean;

{ This function determines whether we are positioned after a trailer label
{ group.

    CASE labeled_volume_position OF
    = bac$lvp_after_trailer_labels, bac$lvp_end_of_file_set,
          bac$lvp_end_of_volume_list =
      bap$after_trailer_labels := TRUE;
    ELSE
      bap$after_trailer_labels := FALSE;
    CASEND;

  FUNCEND bap$after_trailer_labels;

?? PUSH (LISTEXT := ON) ??
*copyc bat$labeled_volume_position
?? POP ??
*DECK DECK=BAP$ASSIGN_SB EXPAND=FALSE

?? NEWTITLE := 'PROCEDURE BAP$ASSIGN_SB [XREF]' ??
{ COMMON DECK BAXASSB }

  PROCEDURE [XREF] bap$assign_sb (file_instance: ^bat$task_file_entry;
        write_ring: ost$ring;
        read_ring: ost$ring;
    VAR sbd_ptr: ^sb_descriptor;
        byte_address: amt$file_byte_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc BAT$TASK_FILE_TABLE
*copyc AMT$FILE_BYTE_ADDRESS
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??
?? OLDTITLE ??
*DECK DECK=BAP$AWAIT_TAPE_IO_COMPLETION EXPAND=FALSE
  PROCEDURE [XREF] bap$await_tape_io_completion (sfid: dmt$system_file_id;
        io_id: iot$io_id;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc iot$io_id
*copyc iot$tape_io_status
*copyc ost$status
?? POP ??
*DECK DECK=BAP$BACKSPACE_TAPE EXPAND=FALSE
  PROCEDURE [XREF] bap$backspace_tape (
        sfid: dmt$system_file_id;
        count: iot$tape_block_count;
        use_locate_block: boolean;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc iot$tape_block_count
*copyc iot$tape_io_status
*copyc ost$status
?? POP ??
*DECK DECK=BAP$BLOCK_MANAGER EXPAND=FALSE

{ COMMON DECK BAXBLKM }

  PROCEDURE [XREF] bap$block_manager (file_instance: ^bat$task_file_entry;
        file_byte_address: amt$file_byte_address;
        record_request: bat$record_request_descriptor;
        wsl: amt$working_storage_length;
        call_block: amt$call_block;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc BAT$TASK_FILE_TABLE
*copyc BAT$BLOCK_MANAGER_DESCRIPTOR
*copyc BAT$RECORD_REQUEST_DESCRIPTOR
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$MAX_RECORD_LENGTH
*copyc AMT$FAP_DECLARATIONS
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc OST$STATUS
?? POP ??
*DECK DECK=BAP$BYTE_MOVE EXPAND=FALSE

  PROCEDURE [XREF] bap$byte_move (from_fid: amt$file_identifier;
        to_fid: amt$file_identifier;
        move: amt$file_byte_address;
        last_move: boolean;
    VAR byte_offset: amt$file_byte_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc OST$STATUS
*copyc AMT$FILE_IDENTIFIER
?? POP ??
*DECK DECK=BAP$CHANGE_DEFAULT_FILE_ATTRIBS EXPAND=FALSE

  PROCEDURE [XREF] bap$change_default_file_attribs
    (    attributes: ^amt$file_attributes;
         new_retention: ^fst$retention;
         reset_system_defaults: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_attributes
*copyc fst$retention
*copyc ost$status
?? POP ??
*DECK DECK=BAP$CHANGE_FILE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] bap$change_file_attributes
    (    file_attributes: ^amt$file_attributes;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR open_changed_file: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_attributes
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??




*DECK DECK=BAP$CHANGE_TAPE_BT_AND_RT EXPAND=FALSE

  PROCEDURE [XREF] bap$change_tape_bt_and_rt (file_identifier: amt$file_identifier;
    layer_number: amt$fap_layer_number;
    block_type: amt$block_type;
    record_type: amt$record_type;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$block_type
*copyc amt$file_identifier
*copyc amt$fap_declarations
*copyc amt$record_type
*copyc ost$status
?? POP ??
*DECK DECK=BAP$CLOSE EXPAND=FALSE
{ COMMON DECK BAXCLSE }


  PROCEDURE [XREF] bap$close (file_identifer: amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc OST$STATUS
?? POP ??
*DECK DECK=BAP$CLOSE_OBSOLETE_TARGET_FILES EXPAND=FALSE

  PROCEDURE [XREF] bap$close_obsolete_target_files
    (    connected_files: ^clt$connected_files);

?? PUSH (LISTEXT := ON) ??
*copyc clt$connected_file
?? POP ??
*DECK DECK=BAP$CONNECTED_FILE_DEVICE EXPAND=FALSE

  PROCEDURE [XREF] bap$connected_file_device (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=BAP$CREATE_FILE EXPAND=FALSE

  PROCEDURE [XREF] bap$create_file
    (    attachment_options: ^fst$attachment_options;
         cycle_attributes: ^fst$file_cycle_attributes;
         file_attributes: ^fst$file_attributes;
         device_attributes: ^fst$device_attributes;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR resolved_path: fst$path;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fse$attach_validation_errors
*copyc fst$attachment_options
*copyc fst$device_attributes
*copyc fst$evaluated_file_reference
*copyc fst$file_attributes
*copyc fst$file_cycle_attributes
*copyc ost$status
*copyc pfe$error_condition_codes
*copyc rme$request_mass_storage
?? POP ??

*DECK DECK=BAP$DELETE_ART_ENTRY EXPAND=FALSE

{ COMMON DECK BAXDART }

  PROCEDURE [XREF] bap$delete_art_entry (local_file_name: amt$local_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=BAP$DELETE_DATA EXPAND=FALSE

  PROCEDURE [XREF] bap$delete_data (file_identifier: amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
*copyc ame$improper_file_id
?? POP ??
*DECK DECK=BAP$DELETE_DIRECT EXPAND=FALSE

{ COMMON DECK BAXDELD }

  PROCEDURE [XREF] bap$delete_direct (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$DETERMINE_FILE_ACTIVE EXPAND=FALSE
?? NEWTITLE := 'BAP$DETERMINE_FILE_ACTIVE [XREF]' ??

  PROCEDURE [XREF] bap$determine_file_active (file_identifier:
    amt$file_identifier;
        active: boolean;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc AMT$FILE_IDENTIFIER
?? POP ??
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc AMT$FILE_IDENTIFIER
?? POP ??
?? OLDTITLE ??
*DECK DECK=BAP$DETERMINE_LOADED_RING EXPAND=FALSE


  PROCEDURE [INLINE] bap$determine_loaded_ring (pointer_to_procedure:
    ^procedure;
    VAR loaded_ring: ost$valid_ring;
    VAR r3: ost$valid_ring);

?? PUSH (LISTEXT := ON) ??

    VAR
      first_conversion: record
        case boolean of
        = TRUE =
          procedure_pointer: ^procedure,
        = FALSE =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend,

      second_conversion: record
        case boolean of
        = TRUE =
          code_base_pva: ^cell,
        = FALSE =
          pva_record: ^ost$pva,
        casend,
      recend;

    first_conversion.procedure_pointer := pointer_to_procedure;
    r3 := first_conversion.code_base_pointer^.r3;

    { This is to get the loaded ring of the fap, not the apd intercept procedure. }
    IF #ring(first_conversion.code_base_pointer^.code_pva) = 2 THEN
      first_conversion.code_base_pointer := first_conversion.code_base_pointer^.binding_pva;
    IFEND;

    second_conversion.code_base_pva := ^first_conversion.code_base_pointer^.
          code_pva;
    loaded_ring := second_conversion.pva_record^.ring;

  PROCEND bap$determine_loaded_ring;

*copyc OSD$VIRTUAL_ADDRESS
*copyc OSD$CODE_BASE_POINTER

?? POP ??
*DECK DECK=BAP$DISMOUNT_TAPE_VOLUME EXPAND=FALSE

  PROCEDURE [XREF] bap$dismount_tape_volume
    (    sfid: gft$system_file_identifier;
     VAR status: ost$status);

*copyc gft$system_file_identifier
*copyc ost$status
*DECK DECK=BAP$DISPLAY_ART EXPAND=FALSE

  PROCEDURE [XREF] bap$display_art
    (    output_fid: amt$file_identifier;
     VAR ost$status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??

*DECK DECK=BAP$DISPLAY_FILES EXPAND=FALSE

  PROCEDURE [XREF] bap$display_files
    (    output_fid: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??

*DECK DECK=BAP$DISPLAY_PATH_TABLE EXPAND=FALSE
  PROCEDURE [XREF] bap$display_path_table
    (    output_fid: amt$file_identifier;
         depth: fst$path_table_expansion_limit;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc fst$path_table_expansion_limit
*copyc ost$status
?? POP ??

*DECK DECK=BAP$DISPLAY_PDE_VIA_PH EXPAND=FALSE

  PROCEDURE [XREF] bap$display_pde_via_ph
    (    output_fid: amt$file_identifier;
         path_handle: fmt$path_handle;
         depth: fst$path_table_expansion_limit;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc fmt$path_handle
*copyc fst$path_table_expansion_limit
*copyc ost$status
?? POP ??

*DECK DECK=BAP$DISPLAY_PT_STATS EXPAND=FALSE
  PROCEDURE [XREF] bap$display_pt_stats
    (    output_fid: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??


*DECK DECK=BAP$DISPLAY_TASK_FILE_TABLE EXPAND=FALSE

  PROCEDURE [XREF] bap$display_task_file_table
    (    output_fid: amt$file_identifier;
         expand_task_file_table_entries: boolean;
     VAR ost$status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=BAP$DISPLAY_TFTE_VIA_PH EXPAND=FALSE

  PROCEDURE [XREF] bap$display_tfte_via_ph
    (    output_fid: amt$file_identifier;
         path_handle: fmt$path_handle;
         expand_task_file_table_entry: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc fmt$path_handle
*copyc ost$status
?? POP ??


*DECK DECK=BAP$DISPLAY_TFT_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] bap$display_tft_entry
    (    output_fid: amt$file_identifier;
         file_identifier: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=BAP$DISPLAY_UNUSED_PATHS EXPAND=FALSE

  PROCEDURE [XREF] bap$display_unused_paths
    (    output_fid: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=BAP$EMPTY_SB EXPAND=FALSE

?? NEWTITLE := ' PROCEDURE BAP$EMPTY_SB [XREF]' ??
{ COMMON DECK BAXEMSB }

  PROCEDURE [XREF] bap$empty_sb (file_instance: ^bat$task_file_entry;
        sbd_ptr: ^sb_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc BAT$TASK_FILE_TABLE
*copyc OST$STATUS
?? POP ??
?? OLDTITLE ??
*DECK DECK=BAP$ENABLE_CLOSE_OF_TARGET EXPAND=FALSE

  PROCEDURE [XREF] bap$enable_close_of_target (subjuect_file_identifier:
    amt$file_identifier;
        target_file_identifier: amt$file_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
?? POP ??
*DECK DECK=BAP$END_NEW_OPEN_PROCESSING EXPAND=FALSE

  PROCEDURE [XREF] bap$end_new_open_processing
    (    path_handle: fmt$path_handle;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_handle
*copyc ost$status
?? POP ??

*DECK DECK=BAP$ERASE_TAPE EXPAND=FALSE
 PROCEDURE [XREF] bap$erase_tape (sfid: dmt$system_file_id;
        block_length: amt$max_block_length;
        number_of_erases: integer;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc amt$max_block_length
*copyc iot$tape_io_status
*copyc ost$status
?? POP ??
*DECK DECK=BAP$EVALUATE_PATH EXPAND=FALSE

  PROCEDURE [XREF] bap$evaluate_path (file: fst$file_reference;
        resolve_to_catalog: boolean;
        command_file_reference_allowed: boolean;
        record_path: boolean;
    VAR evaluated_file_reference: fst$evaluated_file_reference;
    VAR temporary_file: boolean;
    VAR file_registered: boolean;
    VAR path_handle_name: fst$path_handle_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc fst$file_reference
*copyc fst$path_handle_name
*copyc ost$status
?? POP ??

*DECK DECK=BAP$EXIT_FAP_ON_CONDITION EXPAND=FALSE

  PROCEDURE [XREF] bap$exit_fap_on_condition
    (    condition: ost$status_condition_code);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status_condition_code
?? POP ??
*DECK DECK=BAP$FAP_CONTROL EXPAND=FALSE

{ COMMON DECK BAXCTL }

  PROCEDURE [XREF] bap$fap_control (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$FETCH EXPAND=FALSE

{ COMMON DECK BAXFTCH }

  PROCEDURE [XREF] bap$fetch (file_identifier: amt$file_identifier;
    call_block: amt$call_block;
    fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$FETCH_ACCESS_INFORMATION EXPAND=FALSE

{ COMMON DECK BAXFNFO }

  PROCEDURE [XREF] bap$fetch_access_information (file_identifier:
    amt$file_identifier;
    call_block: amt$call_block;
    fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$FETCH_ART_TABLE_POINTER EXPAND=FALSE

  PROCEDURE [XREF] bap$fetch_art_table_pointer
    (    local_file_name: amt$local_file_name;
     VAR file_attributes: ^amt$file_attributes);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_attributes
*copyc amt$local_file_name
?? POP ??
*DECK DECK=BAP$FETCH_ROUTE_LABEL EXPAND=FALSE

  PROCEDURE [XREF] bap$fetch_route_label (local_file_name: amt$local_file_name;
        route_label_ptr: ^bat$route_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc FMT$LOCAL_NAME_TABLE
*copyc OST$STATUS
?? POP ??
*DECK DECK=BAP$FETCH_SYSTEM_LABEL EXPAND=FALSE

{ COMMON DECK BAXFSL }

  PROCEDURE [XREF] bap$fetch_system_label (local_file_name:
    amt$local_file_name;
        label_pointer: ^SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc AMT$LOCAL_FILE_NAME
?? POP ??
*DECK DECK=BAP$FETCH_TAPE_ATTACHMENT_INFO EXPAND=FALSE

  PROCEDURE [XREF] bap$fetch_tape_attachment_info
    (    evaluated_file_reference: fst$evaluated_file_reference;
     VAR tape_attachments: fst$tape_attachment_information;
     VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc fst$evaluated_file_reference
*copyc fst$tape_attachment_information
?? POP ??


*DECK DECK=BAP$FETCH_TAPE_CAPABILITIES EXPAND=FALSE
 PROCEDURE [XREF] bap$fetch_tape_capabilities (sfid: dmt$system_file_id;
    VAR maximum_block_length: amt$max_block_length;
    VAR max_blocks_per_physical_call: iot$tape_block_count;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc amt$max_block_length
*copyc iot$tape_block_count
*copyc ost$status
?? POP ??
*DECK DECK=BAP$FETCH_TAPE_LABEL_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] bap$fetch_tape_label_attributes
    (    evaluated_file_reference: fst$evaluated_file_reference;
     VAR tape_attachments: fst$tape_attachment_information;
     VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc fst$evaluated_file_reference
*copyc fst$tape_attachment_information
?? POP ??
*DECK DECK=BAP$FETCH_TAPE_VALIDATION EXPAND=FALSE

  PROCEDURE [XREF] bap$fetch_tape_validation (
    VAR tape_validation_state: bat$tape_validation_state;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc bat$tape_validation_state
*copyc ost$status
?? POP ??

*DECK DECK=BAP$FETCH_TAPE_VALIDATION_R1 EXPAND=FALSE

  PROCEDURE [XREF] bap$fetch_tape_validation_r1 (
    VAR tape_validation_state: bat$tape_validation_state;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc bat$tape_validation_state
*copyc ost$status
?? POP ??


*DECK DECK=BAP$FILE_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] bap$file_command
    (    file: fst$file_reference;
         file_attributes: ^amt$file_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc amt$file_attributes
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=BAP$FILL_SB EXPAND=FALSE

?? NEWTITLE := 'PROCEDURE BAP$FILL_SB [XREF]' ??
{ COMMON DECK BAXFLSB }

  PROCEDURE [XREF] bap$fill_sb (file_instance: ^bat$task_file_entry;
        sbd_ptr: ^sb_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc BAT$TASK_FILE_TABLE
*copyc OST$STATUS
?? POP ??
?? OLDTITLE ??
*DECK DECK=BAP$FIND_OPEN_FILE_VIA_SEGMENT EXPAND=FALSE
  PROCEDURE [XREF] bap$find_open_file_via_segment
    (    segment_number: ost$segment;
     VAR file_instance: ^bat$task_file_entry;
     VAR path: fst$path;
     VAR path_size: fst$path_size;
     VAR entry_found: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc bat$task_file_table
*copyc osd$virtual_address
*copyc fst$path
*copyc fst$path_size
?? POP ??
*DECK DECK=BAP$FORCE_UPDATE_OF_TARGETS EXPAND=FALSE
 PROCEDURE [XREF] bap$force_update_of_targets (
       subject_file_identifier:  amt$file_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
?? POP ??
*DECK DECK=BAP$FORMAT_SEGMENT_CONDITION EXPAND=FALSE
 PROCEDURE [XREF] bap$format_segment_condition (identifier: string (2);
        segment_access_condition: mmt$segment_access_condition;
        save_area: ^ost$stack_frame_save_area;
        error_pva: ost$pva;
    VAR condition_status: ost$status);

*copyc mmd$segment_access_condition
*copyc osd$virtual_address
*copyc ost$stack_frame_save_area
*copyc ost$status
*DECK DECK=BAP$FORSPACE_TAPE EXPAND=FALSE
  PROCEDURE [XREF] bap$forspace_tape (sfid: dmt$system_file_id;
        count: iot$tape_block_count;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc iot$tape_block_count
*copyc iot$tape_io_status
*copyc ost$status
?? POP ??
*DECK DECK=BAP$FREE_STATIC_LABEL EXPAND=FALSE

  PROCEDURE [XREF] bap$free_static_label
    (    path_handle: fmt$path_handle);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_handle
?? POP ??
*DECK DECK=BAP$FREE_TAPE_LABEL_SEQUENCES EXPAND=FALSE

  PROCEDURE [XREF] bap$free_tape_label_sequences
    (    free_initial_volume_sequence: boolean;
     VAR p_tape_descriptor: ^bat$tape_descriptor);

*copyc bat$tape_descriptor
*DECK DECK=BAP$GET_$LOCAL_OBJECT_INFO EXPAND=FALSE

  PROCEDURE [XREF] bap$get_$local_object_info
    (    evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
     VAR object_information_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc fst$goi_information_request
*copyc ost$status
?? POP ??
*DECK DECK=BAP$GET_DEFAULT_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] bap$get_default_attributes (catalog_information:
    ^fst$catalog_information;
        cycle_attribute_sources: ^fst$cycle_attribute_sources;
        cycle_attribute_values: ^fst$cycle_attribute_values;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$cycle_attribute_sources
*copyc fst$cycle_attribute_values
*copyc fst$catalog_information
*copyc ost$status
?? POP ??
*DECK DECK=BAP$GET_DEFAULT_FILE_ATTRIBS EXPAND=FALSE

  PROCEDURE [XREF] bap$get_default_file_attribs
    (VAR default_attributes: bat$static_label_attributes;
     VAR default_new_retention_specified: boolean;
     VAR default_new_retention: fst$retention;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc bat$static_label_attributes
*copyc fst$retention
*copyc ost$status
?? POP ??
*DECK DECK=BAP$GET_DEVICE_CLASS EXPAND=FALSE

  PROCEDURE [XREF] bap$get_device_class
    (    path_handle: fmt$path_handle;
     VAR device_assigned: boolean;
     VAR device_class: rmt$device_class;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_handle
*copyc ost$status
*copyc rmt$device_class
?? POP ??
*DECK DECK=BAP$GET_DIRECT EXPAND=FALSE

{ COMMON DECK BAXGETD }

  PROCEDURE [XREF] bap$get_direct (file_identifier: amt$file_identifier;
    call_block: amt$call_block;
    fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$GET_LABEL EXPAND=FALSE

{ COMMON DECK BAXGETL }

  PROCEDURE [XREF] bap$get_label (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$GET_NEXT EXPAND=FALSE

{ COMMON DECK BAXGETN }

  PROCEDURE [XREF] bap$get_next (file_identifier: amt$file_identifier;
    call_block: amt$call_block;
    fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$GET_OPEN_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] bap$get_open_information (file_identifier:
    amt$file_identifier;
        attachment_information: ^SEQ ( * );
        catalog_information: ^SEQ ( * );
        cycle_attribute_sources: ^SEQ ( * );
        cycle_attribute_values: ^SEQ ( * );
        instance_information: ^SEQ ( * );
        resolved_file_reference: ^SEQ ( * );
        user_defined_attributes: ^SEQ ( * );
    VAR user_defined_attribute_size: ost$non_negative_integers;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc osd$integer_limits
*copyc ost$status
?? POP ??
*DECK DECK=BAP$GET_PARTIAL EXPAND=FALSE

{ COMMON DECK BAXGETP }

  PROCEDURE [XREF] bap$get_partial (file_identifier: amt$file_identifier;
    call_block: amt$call_block;
    fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$GET_PATH_ELEMENTS EXPAND=FALSE

  PROCEDURE [XREF] bap$get_path_elements
    (    path_handle: fmt$path_handle;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT:=ON) ??
*copyc fmt$path_handle
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=BAP$GET_PATH_STRING EXPAND=FALSE

  PROCEDURE [XREF] bap$get_path_string
    (   path_handle: fmt$path_handle;
     VAR path: fst$path;
     VAR path_size: fst$path_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_handle
*copyc fst$path
*copyc fst$path_size
*copyc ost$status
?? POP ??
*DECK DECK=BAP$GET_PHN_VIA_FILE_ID EXPAND=FALSE

  PROCEDURE [XREF] bap$get_phn_via_file_id (file_id: amt$file_identifier;
    VAR local_file_name: amt$local_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$improper_file_id
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc ost$status
?? POP ??
*DECK DECK=BAP$GET_RESOLVED_FILE_REFERENCE EXPAND=FALSE

  PROCEDURE [XREF] bap$get_resolved_file_reference
    (VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR resolved_file_reference: fst$resolved_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_handle
*copyc fst$resolved_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=BAP$GET_ROUTE_INFO EXPAND=FALSE
{COMMON DECK BAXGRTE}

  PROCEDURE [XREF] bap$get_route_info (local_file_name: amt$local_file_name;
        qlabel: bat$qlabel;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??

*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc BAT$QLABEL
?? POP ??
*DECK DECK=BAP$GET_SEGMENT_POINTER EXPAND=FALSE

{ COMMON DECK BAXGSGP }

  PROCEDURE [XREF] bap$get_segment_pointer (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$GET_SETFA_DYNAMIC_ATTRS EXPAND=FALSE

  PROCEDURE [XREF] bap$get_setfa_dynamic_attrs
    (    file: fst$file_reference;
     VAR attached_permanent_file: boolean;
     VAR attached_share_modes: fst$file_access_options;
     VAR setfa_specified: boolean;
     VAR dynamic_attributes: fst$setfa_attachment_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$setfa_attachment_options
*copyc fst$file_access_options
*copyc fst$file_reference
*copyc ost$status
?? POP ??





*DECK DECK=BAP$GET_SYSTEM_LABEL EXPAND=FALSE

  PROCEDURE [XREF] bap$get_system_label (local_file_name: amt$local_file_name;
        file_label: bat$system_file_attributes;
        status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc BAT$SYSTEM_FILE_ATTRIBUTES
?? POP ??
*DECK DECK=BAP$GET_TAPE_ELEMENT_NAME EXPAND=FALSE

  PROCEDURE[XREF] bap$get_tape_element_name
    (    sfid: gft$system_file_identifier;
     VAR element_name: cmt$element_name;
     VAR status: ost$status);

*copyc cmt$element_name
*copyc gft$system_file_identifier
*copyc ost$status
*DECK DECK=BAP$GET_TAPE_LABEL_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] bap$get_tape_label_attributes
    (    evaluated_file_reference: fst$evaluated_file_reference;
         source: fst$tape_attribute_source;
     VAR attributes {input, output} : fst$attachment_options;
     VAR returned_attributes: fst$tla_returned_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$attachment_options
*copyc fst$evaluated_file_reference
*copyc fst$tape_attribute_source
*copyc fst$tla_returned_attributes
*copyc ost$status
?? POP ??
*DECK DECK=BAP$GET_TAPE_SECURITY_STATE EXPAND=FALSE

  PROCEDURE [XREF] bap$get_tape_security_state
    (VAR enforce_tape_security: bat$tape_validation_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc bat$tape_validation_state
*copyc ost$status
?? POP ??
*DECK DECK=BAP$GET_TAPE_SECURITY_STATE_R1 EXPAND=FALSE

  PROCEDURE [XREF] bap$get_tape_security_state_r1
    (VAR enforce_tape_security: bat$tape_validation_state);

?? PUSH (LISTEXT := ON) ??
*copyc bat$tape_validation_state
?? POP ??

*DECK DECK=BAP$IMPLICIT_ATTACH EXPAND=FALSE

  PROCEDURE [INLINE] bap$implicit_attach (validation_ring: ost$valid_ring;
    VAR evaluated_file_reference: fst$evaluated_file_reference;
        null_share_modes: boolean;
    VAR allowed_access: fst$file_access_options;
    VAR required_sharing: fst$file_access_options;
    VAR action_taken: pft$attach_or_create_action;
    VAR status: ost$status);

    VAR
      attachment_choices: array [1 .. 2] of fst$attachment_option,
      device_class: rmt$device_class,
      ignore_label_used: boolean,
      ignore_selected_access: fst$file_access_options,
      ignore_selected_sharing: fst$file_access_options;

    attachment_choices [1].selector := fsc$access_and_share_modes;
    attachment_choices [1].access_modes.selector := fsc$specific_access_modes;
    attachment_choices [1].access_modes.value := $fst$file_access_options [];
    attachment_choices [1].share_modes.selector := fsc$specific_share_modes;
    IF null_share_modes THEN
      attachment_choices [1].share_modes.value := $fst$file_access_options [];
    ELSE
      attachment_choices [1].share_modes.value := -$fst$file_access_options [];
    IFEND;
    attachment_choices [2].selector := fsc$create_file;
    attachment_choices [2].create_file := FALSE;

    pfp$r3_attach_or_create_file (validation_ring, ^attachment_choices, NIL,
          evaluated_file_reference, allowed_access, ignore_selected_access,
          required_sharing, ignore_selected_sharing,
          action_taken, ignore_label_used, device_class, status);

  PROCEND bap$implicit_attach;

?? PUSH (LISTEXT := ON) ??
*copyc pfp$r3_attach_or_create_file
?? POP ??
*DECK DECK=BAP$INHIBIT_IMPLICIT_DETACH EXPAND=FALSE

  PROCEDURE [XREF] bap$inhibit_implicit_detach
    (    file_identifier: amt$file_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
?? POP ??
*DECK DECK=BAP$IS_FILE_REGISTERED EXPAND=FALSE
  PROCEDURE [XREF] bap$is_file_registered (path_handle:
        fmt$path_handle;
    VAR registered: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_handle
*copyc ost$status
?? POP ??
*DECK DECK=BAP$LABELLED_TAPE_FAP EXPAND=FALSE

  PROCEDURE [XREF] bap$labelled_tape_fap (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??

*DECK DECK=BAP$LOADED_RING_CLEANUP EXPAND=FALSE

  PROCEDURE [XREF] bap$loaded_ring_cleanup;
*DECK DECK=BAP$LOCATE_LNT_ENTRY EXPAND=FALSE

{ COMMON DECK BAXLLEB }

  PROCEDURE [XREF] bap$locate_lnt_entry (local_file_name: amt$local_file_name;
    VAR flag: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
?? POP ??
*DECK DECK=BAP$LOCATE_SB EXPAND=FALSE

?? NEWTITLE := 'PROCEDURE BAP$LOCATE_SB [XREF]' ??
{ COMMON DECK BAXLOSB }

  PROCEDURE [XREF] bap$locate_sb (file_instance: ^bat$task_file_entry;
        byte_address: amt$file_byte_address;
    VAR sbd_ptr: ^sb_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc BAT$TASK_FILE_TABLE
*copyc AMT$FILE_BYTE_ADDRESS
*copyc OST$STATUS
?? POP ??
?? OLDTITLE ??
*DECK DECK=BAP$LOCK_FILE EXPAND=FALSE

{ COMMON DECK BAXLOCK }

  PROCEDURE [XREF] bap$lock_file (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$LOG_DEVICE EXPAND=FALSE

  PROCEDURE [XREF] bap$log_device (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=BAP$LRT_SS_UNDEF_TAPE_FAP EXPAND=FALSE

  PROCEDURE [XREF] bap$lrt_ss_undef_tape_fap (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc ost$status
?? POP ??
*DECK DECK=BAP$LRT_SS_VAR_TAPE_FAP EXPAND=FALSE

  PROCEDURE [XREF] bap$lrt_ss_var_tape_fap (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc ost$status
?? POP ??
*DECK DECK=BAP$LRT_US_ANSI_D_TAPE_FAP EXPAND=FALSE

  PROCEDURE [XREF] bap$lrt_us_ansi_d_tape_fap (
    file_identifier: amt$file_identifier;
    call_block: amt$call_block;
    layer_number: amt$fap_layer_number;
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc ost$status
?? POP ??
*DECK DECK=BAP$LRT_US_ANSI_S_TAPE_FAP EXPAND=FALSE

  PROCEDURE [XREF] bap$lrt_us_ansi_s_tape_fap (
    file_identifier: amt$file_identifier;
    call_block: amt$call_block;
    layer_number: amt$fap_layer_number;
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc ost$status
?? POP ??
*DECK DECK=BAP$LRT_US_FIXED_TAPE_FAP EXPAND=FALSE

  PROCEDURE [XREF] bap$lrt_us_fixed_tape_fap (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc ost$status
?? POP ??
*DECK DECK=BAP$LRT_US_UNDEF_TAPE_FAP EXPAND=FALSE

  PROCEDURE [XREF] bap$lrt_us_undef_tape_fap (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc ost$status
?? POP ??
*DECK DECK=BAP$MARK_FAP_LAYER_CLOSED EXPAND=FALSE

  PROCEDURE [XREF] bap$mark_fap_layer_closed (file_identifier:
    amt$file_identifier;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FAP_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=BAP$MARK_FAP_LAYER_OPEN EXPAND=FALSE

  PROCEDURE [XREF] bap$mark_fap_layer_open (file_identifier:
    amt$file_identifier;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FAP_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=BAP$MERGE_DYNAMIC_ATTR_SOURCE EXPAND=FALSE

  PROCEDURE [XREF] bap$merge_dynamic_attr_source
    (   evaluated_file_reference: fst$evaluated_file_reference;
        attributes: ^amt$file_attributes;
        source: amc$file_command .. amc$file_request;
    VAR dynamic_label {input, output} : bat$dynamic_label_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
*copyc amt$file_attributes
*copyc bat$dynamic_label_attributes
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=BAP$MERGE_OPEN_ATTRIBUTES EXPAND=FALSE
  PROCEDURE [XREF] bap$merge_open_attributes
    (    attributes: ^fst$file_cycle_attributes;
         source: amc$open_request .. amc$file_request;
     VAR static_label {input, output} : bat$static_label_attributes;
         status_reporting_procedure_ptr: fst$status_reporting_procedure;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
*copyc bat$static_label_attributes
*copyc fst$file_cycle_attributes
*copyc fst$status_reporting_procedure
*copyc ost$status
?? POP ??
*DECK DECK=BAP$MERGE_STATIC_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] bap$merge_static_attributes
    (   evaluated_file_reference: fst$evaluated_file_reference;
        file_request_attributes: ^amt$file_attributes;
    VAR static_label {input, output} : bat$static_label_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_attributes
*copyc bat$static_label_attributes
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=BAP$MERGE_TAPE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] bap$merge_tape_attributes
    (    default_creation_attributes: ^fst$file_cycle_attributes;
         mandated_creation_attributes: ^fst$file_cycle_attributes;
     VAR merged_tape_attributes {input, output} :
        fst$tape_attachment_information;
     VAR static_label_attributes {input, output} :
        bat$static_label_attributes);

?? PUSH (LISTEXT := ON) ??
*copyc bat$static_label_attributes
*copyc fst$file_cycle_attributes
*copyc fst$tape_attachment_information
?? POP ??
*DECK DECK=BAP$MONITOR_LOADED_RING_CLEANUP EXPAND=FALSE

  PROCEDURE [XREF] bap$monitor_loaded_ring_cleanup;
*DECK DECK=BAP$MONITOR_TASK_TERM_CLEANUP EXPAND=FALSE

  PROCEDURE [XREF] bap$monitor_task_term_cleanup;

*DECK DECK=BAP$NEXT_POSITION_IS_BOS EXPAND=FALSE

  FUNCTION [INLINE] bap$next_position_is_bos
    (    file_set_position: fst$tape_file_set_position;
         tape_descriptor_p: ^bat$tape_descriptor;
         last_accessed_file_identifier: string (17);
         last_accessed_generation_number: 1 .. 9999): boolean;

{ This function determines whether the next position is the beginning of the
{ volume set, i.e loadpoint of the first volume in the volume set.

    VAR
      blank: boolean;

    bap$next_position_is_bos := FALSE;

    blank := (tape_descriptor_p^.initial_volume.header_labels <> NIL) AND (tape_descriptor_p^.
          initial_volume.classification.volume_label_type = rmc$labeled_volume_type) AND tape_descriptor_p^.
          initial_volume.classification.labeled.blank;

    IF blank THEN
      bap$next_position_is_bos := TRUE;
    ELSE

      CASE file_set_position.position OF

      = fsc$tape_beginning_of_set =
        bap$next_position_is_bos := TRUE;

      = fsc$tape_current_file =
        CASE tape_descriptor_p^.labeled_volume_position OF
        = bac$lvp_after_trailer_labels, bac$lvp_end_of_file_set, bac$lvp_end_of_volume_list =
          IF tape_descriptor_p^.next_position.file_sequence_number = 2 THEN
            bap$next_position_is_bos := TRUE;
          IFEND;
        ELSE
          IF tape_descriptor_p^.next_position.file_sequence_number = 1 THEN
            bap$next_position_is_bos := TRUE;
          IFEND;
        CASEND;

      = fsc$tape_file_identifier_pos =
        IF (file_set_position.file_identifier = last_accessed_file_identifier) AND
              (file_set_position.generation_number = last_accessed_generation_number) THEN

          CASE tape_descriptor_p^.labeled_volume_position OF
          = bac$lvp_after_trailer_labels, bac$lvp_end_of_file_set, bac$lvp_end_of_volume_list =
            IF tape_descriptor_p^.next_position.file_sequence_number = 2 THEN
              bap$next_position_is_bos := TRUE;
            IFEND;
          ELSE
            IF tape_descriptor_p^.next_position.file_sequence_number = 1 THEN
              bap$next_position_is_bos := TRUE;
            IFEND;
          CASEND;
        IFEND;

      = fsc$tape_file_sequence_pos =
        IF file_set_position.file_sequence_number = 1 THEN
          bap$next_position_is_bos := TRUE;
        IFEND;

      = fsc$tape_next_file =
        IF tape_descriptor_p^.labeled_volume_position = bac$lvp_beginning_of_file_set THEN
          bap$next_position_is_bos := TRUE;
        IFEND;

      ELSE {fsc$tape_end_of_set}
      CASEND;
    IFEND;
  FUNCEND bap$next_position_is_bos;

?? PUSH (LISTEXT := ON) ??
*copyc bat$tape_descriptor
*copyc fst$tape_file_set_position
?? POP ??
*DECK DECK=BAP$NULL_DEVICE EXPAND=FALSE

{ COMMON DECK BAXNUD }

  PROCEDURE [XREF] bap$null_device (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FAP_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=BAP$OPEN EXPAND=FALSE

{ COMMON DECK BAXOPEN }

  PROCEDURE [XREF] bap$open
    (    local_file_name: amt$local_file_name;
         access_level: amt$access_level;
         access_selections: amt$file_access_selections;
     VAR file_previously_opened: boolean;
     VAR contains_data: boolean;
     VAR file_identifier: amt$file_identifier;
     VAR work_result: bat$open_work_result;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc bat$open_work_result
*copyc fst$evaluated_file_reference
?? POP ??
*DECK DECK=BAP$OPEN_FILE EXPAND=FALSE
  PROCEDURE [XREF] bap$open_file
    (    access_level: amt$access_level;
         file_attachment: ^fst$attachment_options;
         default_creation_attributes: ^fst$file_cycle_attributes;
         mandated_creation_attributes: ^fst$file_cycle_attributes;
         attribute_validation: ^fst$file_cycle_attributes;
         attribute_override: ^fst$file_cycle_attributes;
{ evaluated_file_reference is only updated on a normal status.
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR contains_data: boolean;
     VAR file_identifier: amt$file_identifier;
     VAR archive_cycle_number: pft$cycle_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$lfn_program_actions
*copyc ame$open_validation_errors
*copyc ame$ring_validation_errors
*copyc amt$access_level
*copyc amt$file_identifier
*copyc fst$attachment_options
*copyc fst$evaluated_file_reference
*copyc fst$file_cycle_attributes
*copyc ost$status
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=BAP$PAD_RECORD EXPAND=FALSE

{ COMMON DECK BAXPADR }

  PROCEDURE [XREF] bap$pad_record (working_storage_area: ^cell;
    pad_length: amt$max_record_length;
    padding_character: char);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$MAX_RECORD_LENGTH
?? POP ??
*DECK DECK=BAP$PROCESS_PT_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] bap$process_pt_request (
        process_pt_work_list: bat$process_pt_work_list;
        local_file_name: amt$local_file_name;
    VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
    VAR process_pt_results: bat$process_pt_results;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc bat$process_pt_work_list
*copyc bat$process_pt_results
*copyc fme$file_management_errors
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=BAP$PUT_DIRECT EXPAND=FALSE

{ COMMON DECK BAXPUTD }

  PROCEDURE [XREF] bap$put_direct (file_identifier: amt$file_identifier;
    call_block: amt$call_block;
    fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$PUT_LABEL EXPAND=FALSE

{ COMMON DECK BAXPUTL }

  PROCEDURE [XREF] bap$put_label (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$PUT_NEXT EXPAND=FALSE

{ COMMON DECK BAXPUTN }

  PROCEDURE [XREF] bap$put_next (file_identifier: amt$file_identifier;
    call_block: amt$call_block;
    fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$PUT_PARTIAL EXPAND=FALSE

{ COMMON DECK BAXPUTP }

  PROCEDURE [XREF] bap$put_partial (file_identifier: amt$file_identifier;
    call_block: amt$call_block;
    fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$PUT_ROUTE_INFO EXPAND=FALSE
?? NEWTITLE := 'BAP$PUT_ROUTE_INFO [XREF]' ??


{ PROCEDURE [XREF] bap$put_route_info (file_identifier:
{        amt$file_identifier;
{        qlabel: jmt$qlabel;
{        status: ost$status);

*copyc AMDGLOB

?? OLDTITLE ??
*DECK DECK=BAP$PUT_SYSTEM_LABEL EXPAND=FALSE

  PROCEDURE [XREF] bap$put_system_label (local_file_name: amt$local_file_name;
        file_label: bat$system_file_attributes;
        status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc BAT$SYSTEM_FILE_ATTRIBUTES
?? POP ??
*DECK DECK=BAP$PUT_TAPE_SECURITY_STATE EXPAND=FALSE
  PROCEDURE [XREF] bap$put_tape_security_state
    (    enforce_tape_security: bat$tape_validation_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc bat$tape_validation_state
*copyc ost$status
?? POP ??

*DECK DECK=BAP$PUT_TAPE_SECURITY_STATE_R1 EXPAND=FALSE

  PROCEDURE [XREF] bap$put_tape_security_state_r1
    (    enforce_tape_security: bat$tape_validation_state);

?? PUSH (LISTEXT := ON) ??
*copyc bat$tape_validation_state
?? POP ??
*DECK DECK=BAP$READ_TAPE EXPAND=FALSE
  PROCEDURE [XREF] bap$read_tape (sfid: dmt$system_file_id;
        max_block_size: iot$tape_block_length;
        block_description: ^iot$read_tape_description;
        block_count: iot$tape_block_count;
        perform_media_error_recovery: boolean;
    VAR io_id: iot$io_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc iot$tape_block_count
*copyc iot$read_tape_description
*copyc iot$io_id
*copyc ost$status
?? POP ??
*DECK DECK=BAP$RECORD_OPENED_FILE_TARGET EXPAND=FALSE

  PROCEDURE [XREF] bap$record_opened_file_target (subject_file_identifier:
    amt$file_identifier;
        target_file_index: clt$connected_file_target_index;
        target_file_identifier: amt$file_identifier;
        connection_level: clt$file_connection_level);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc clt$connected_file
?? POP ??
*DECK DECK=BAP$RECORD_OPENED_SUBJECT_FILE EXPAND=FALSE

  PROCEDURE [XREF] bap$record_opened_subject_file (subject_file_identifier:
    amt$file_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
?? POP ??
*DECK DECK=BAP$RECORD_SUBJECT_FILE_OP EXPAND=FALSE

  PROCEDURE [XREF] bap$record_subject_file_op (subject_file_identifier:
    amt$file_identifier;
        operation: amt$last_operation;
        file_position: amt$file_position);

?? PUSH (LISTEXT := ON) ??
*copyc amd$operation_declarations
*copyc amt$file_identifier
*copyc amt$file_position
?? POP ??
*DECK DECK=BAP$RELEASE_RESOURCE_COMMAND EXPAND=FALSE
*DECK DECK=BAP$RELEASE_SB EXPAND=FALSE
?? NEWTITLE := 'PROCEDURE BAP$RELEASE_SB [XREF]' ??
{ COMMON DECK BAXRLSB }

  PROCEDURE [XREF] bap$release_sb (file_instance: ^bat$task_file_entry;
    VAR sbd_ptr: ^sb_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc BAT$TASK_FILE_TABLE
*copyc OST$STATUS
?? POP ??
?? OLDTITLE ??
*DECK DECK=BAP$RELEASE_TFT_ENTRY EXPAND=FALSE
  PROCEDURE [INLINE] bap$release_tft_entry
    (    file_instance: ^bat$task_file_entry;
         task_file_table_index: bat$tft_limit);

    VAR
      zero: 0 .. 0;

{The following code is to get around run-time and compile-time checks, because
{the sequence number type in the task file table entry begins with 1.
?? PUSH (CHKALL := OFF) ??
    zero := 0;
    file_instance^.sequence_number := zero;
?? POP ??

    file_instance^.local_file_name := osc$null_name;

    IF file_instance^.private_read_information <> NIL THEN
      FREE file_instance^.private_read_information IN osv$task_private_heap^;
    IFEND;

    bav$tft_entry_assignment^ (task_file_table_index, 1) := fmc$entry_free;

    WHILE (bav$last_tft_entry > 0) AND (bav$tft_entry_assignment^
          (bav$last_tft_entry, 1) = fmc$entry_free) DO
      bav$last_tft_entry := bav$last_tft_entry - 1;
    WHILEND;

  PROCEND bap$release_tft_entry;

*copyc bav$last_tft_entry
*copyc bav$tft_entry_assignment
*copyc osv$task_private_heap
*DECK DECK=BAP$RENAME_FILE EXPAND=FALSE
?? TITLE := 'PROCEDURE BAP$RENAME_FILE [XREF]' ??
{ COMMON DECK BAXRNM }

  PROCEDURE [XREF] bap$rename_file (old_fle_name: amt$local_file_name;
        new_file_name: amt$local_file_name;
    VAR status: ost$status);
*DECK DECK=BAP$REPLACE EXPAND=FALSE

{ COMMON DECK BAXREP }

  PROCEDURE [XREF] bap$replace (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$REPLACE_DIRECT EXPAND=FALSE

{ COMMON DECK BAXREPD }

  PROCEDURE [XREF] bap$replace_direct (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$RESERVE_RESOURCE_COMMAND EXPAND=FALSE
*DECK DECK=BAP$RETURN EXPAND=FALSE

  PROCEDURE [XREF] bap$return
    (VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
         detachment_options: ^fst$detachment_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$detachment_options
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=BAP$REWIND EXPAND=FALSE

{ COMMON DECK BAXREWD }

  PROCEDURE [XREF] bap$rewind (file_identifier: amt$file_identifier;
    call_block: amt$call_block;
    fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$REWIND_TAPE EXPAND=FALSE
  PROCEDURE [XREF] bap$rewind_tape (sfid: dmt$system_file_id;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc iot$tape_io_status
*copyc ost$status
?? POP ??
*DECK DECK=BAP$SEEK_DIRECT EXPAND=FALSE

{ COMMON DECK BAXSEEK }

  PROCEDURE [XREF] bap$seek_direct (file_identifier: amt$file_identifier;
    call_block: amt$call_block;
    fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$SET_ATTACHMENT_OPTIONS EXPAND=FALSE

  PROCEDURE [XREF] bap$set_attachment_options
    (    file: fst$file_reference;
         attachment_options: fmt$cd_attachment_options;
         p_volume_list: {input} ^rmt$volume_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$cd_attachment_options
*copyc fst$file_reference
*copyc ost$status
*copyc rmt$volume_list
?? POP ??
*DECK DECK=BAP$SET_CLOSE_ALLOWED EXPAND=FALSE

  PROCEDURE [XREF] bap$set_close_allowed
    (    file_identifier: amt$file_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
?? POP ??
*DECK DECK=BAP$SET_EVALUATED_FILE_ABNORMAL EXPAND=FALSE

  PROCEDURE [XREF] bap$set_evaluated_file_abnormal
    (    evaluated_file_reference: fst$evaluated_file_reference;
         exception_condition: ost$status_condition;
         request_name: string ( * <= osc$max_name_size);
         text: string ( * <= osc$max_string_size );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=BAP$SET_FILE_INSTANCE_ABNORMAL EXPAND=FALSE


  PROCEDURE [XREF] bap$set_file_instance_abnormal (file_identifier:
    amt$file_identifier;
    exception_condition: ost$status_condition;
    request_name: string ( * <= osc$max_name_size);
    text: string ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc amt$file_identifier
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=BAP$SET_FILE_REFERENCE_ABNORMAL EXPAND=FALSE

  PROCEDURE [XREF] bap$set_file_reference_abnormal
    (    file: fst$file_reference;
         exception_condition: ost$status_condition;
         request_name: string ( * <= osc$max_name_size);
         text: string ( * <= osc$max_string_size );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=BAP$SET_LOCAL_NAME_ABNORMAL EXPAND=FALSE


  PROCEDURE [XREF] bap$set_local_name_abnormal (local_file_name:
    amt$local_file_name;
    exception_condition: ost$status_condition;
    request_name: string ( * <= osc$max_name_size);
    text: string ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc amt$local_file_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=BAP$SET_RETURN_AT_CLOSE EXPAND=FALSE

  PROCEDURE [XREF] bap$set_return_at_close
    (    file_identifier: amt$file_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
?? POP ??
*DECK DECK=BAP$SET_SEGMENT_EOI EXPAND=FALSE

{ COMMON DECK BAXSETE }

  PROCEDURE [XREF] bap$set_segment_eoi (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$SET_SEGMENT_POSITION EXPAND=FALSE

{ COMMON DECK BAXSETP }

  PROCEDURE [XREF] bap$set_segment_position (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$SET_STD_FILES_DEFAULT_AM EXPAND=FALSE

  PROCEDURE [XREF] bap$set_std_files_default_am
    (    subject_file_identifier: amt$file_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
?? POP ??
*DECK DECK=BAP$SET_TASK_CLEANUP_INITIATED EXPAND=FALSE

  PROCEDURE [XREF] bap$set_task_cleanup_initiated;
*DECK DECK=BAP$SL_REWIND_FILE_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] bap$sl_rewind_file_command (
        local_file_name: amt$local_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=BAP$STORE EXPAND=FALSE

{ COMMON DECK BAXSTOR }

  PROCEDURE [XREF] bap$store (file_identifier: amt$file_identifier;
    call_block: amt$call_block;
    fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$STORE_ART_TABLE_POINTER EXPAND=FALSE

  PROCEDURE [XREF] bap$store_art_table_pointer
    (    local_file_name: amt$local_file_name;
     VAR file_attributes: ^amt$file_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_attributes
*copyc amt$local_file_name
*copyc ost$status
?? POP ??
*DECK DECK=BAP$STORE_ROUTE_LABEL EXPAND=FALSE

  PROCEDURE [XREF] bap$store_route_label (local_file_name: amt$local_file_name;
        route_label_ptr: ^bat$route_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc FMT$LOCAL_NAME_TABLE
*copyc OST$STATUS
?? POP ??
*DECK DECK=BAP$STORE_SYSTEM_LABEL EXPAND=FALSE

{ COMMON DECK BAXSSL }

  PROCEDURE [XREF] bap$store_system_label (local_file_name:
    amt$local_file_name;
        label_pointer: ^SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc AMT$LOCAL_FILE_NAME
?? POP ??
*DECK DECK=BAP$STORE_TAPE_ATTACHMENT EXPAND=FALSE

  PROCEDURE [XREF] bap$store_tape_attachment (
        tape_attachments: fst$attachment_options;
        tape_attachment_info_source: fst$tape_attach_info_source;
        tape_attachment_info: ^fst$tape_attachment_information;
    VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc fst$attachment_options
*copyc ost$status
?? POP ??
*DECK DECK=BAP$STORE_TAPE_LABEL_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] bap$store_tape_label_attributes
    (    evaluated_file_reference: fst$evaluated_file_reference;
         tape_attachments: fst$attachment_options;
         supplied_file_set_pos_fields: fst$supplied_file_set_positions;
         tape_attachment_info_source: fst$tape_attach_info_source;
     VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc fst$attachment_options
*copyc fst$evaluated_file_reference
*copyc fst$supplied_file_set_positions
?? POP ??


*DECK DECK=BAP$STORE_TAPE_VALIDATION EXPAND=FALSE

  PROCEDURE [XREF] bap$store_tape_validation (
        tape_validation_state: bat$tape_validation_state;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc bat$tape_validation_state
*copyc ost$status
?? POP ??


*DECK DECK=BAP$STORE_TAPE_VALIDATION_R1 EXPAND=FALSE

  PROCEDURE [XREF] bap$store_tape_validation_r1 (
        tape_validation_state: bat$tape_validation_state;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc bat$tape_validation_state
*copyc ost$status
?? POP ??
*DECK DECK=BAP$STORE_UNSECURED_TAPE_LABELS EXPAND=FALSE

  PROCEDURE [XREF] bap$store_unsecured_tape_labels
    (    p_label_sequence: ^SEQ ( * );
     VAR p_stored_label_sequence: ^SEQ ( * ));
*DECK DECK=BAP$SYSTEM_TAPE_LABEL_FAP EXPAND=FALSE
  PROCEDURE [XREF] bap$system_tape_label_fap
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=BAP$SYS_BLK_FIXED_REC_FAP EXPAND=FALSE

{ COMMON DECK BAP$SYS_BLK_FIXED_REC_FAP }

  PROCEDURE [XREF] bap$sys_blk_fixed_rec_fap (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$SYS_BLK_UNDEFINED_REC_FAP EXPAND=FALSE

{ COMMON DECK BAP$SYS_BLK_UNDEFINED_REC_FAP }

  PROCEDURE [XREF] bap$sys_blk_undefined_rec_fap (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$SYS_BLK_VARIABLE_REC_FAP EXPAND=FALSE

{ COMMON DECK BAXSBVF }

  PROCEDURE [XREF] bap$sys_blk_variable_rec_fap (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$TAPE_BM_ADVANCE_VOLUME EXPAND=FALSE

  PROCEDURE [XREF] bap$tape_bm_advance_volume
    (    file_identifier: amt$file_identifier;
     VAR failure_modes: amt$tape_failure_modes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$tape_failure_modes
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_ALIGN_POSITION EXPAND=FALSE
 PROCEDURE [XREF] bap$tape_bm_align_position (file_identifier:
  amt$file_identifier;
    VAR failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$tape_failure_modes
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_CLOSE EXPAND=FALSE
 PROCEDURE [XREF] bap$tape_bm_close (file_identifier: amt$file_identifier;
    VAR failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$tape_failure_modes
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_ERASE_BLOCK EXPAND=FALSE
 PROCEDURE [XREF] bap$tape_bm_erase_block (file_identifier: amt$file_identifier;
        block_length: amt$max_block_length;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$max_block_length
*copyc amt$tape_failure_modes
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_FLUSH EXPAND=FALSE
 PROCEDURE [XREF] bap$tape_bm_flush (file_identifier: amt$file_identifier;
    VAR failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$tape_failure_modes
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_OPEN EXPAND=FALSE
 PROCEDURE [XREF] bap$tape_bm_open (file_identifier: amt$file_identifier;
        max_block_length: amt$max_block_length;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc amt$max_block_length
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_READ_LABEL EXPAND=FALSE

  PROCEDURE [XREF] bap$tape_bm_read_label
    (    file_id: amt$file_identifier;
         label_ptr: ^bat$tape_block;
         label_area_length: amt$max_block_length;
         system_media_recovery: boolean;
     VAR actual_block_length: amt$transfer_count;
     VAR volume_position: amt$volume_position;
     VAR tape_failure_modes: amt$tape_failure_modes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$max_block_length
*copyc amt$tape_failure_modes
*copyc amt$transfer_count
*copyc amt$volume_position
*copyc bat$tape_block
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_READ_NEXT_BLOCK EXPAND=FALSE
 PROCEDURE [XREF] bap$tape_bm_read_next_block (file_identifier:
  amt$file_identifier;
        operation: amt$fap_operation;
        volunteered_buffer_area: ^bat$tape_block;
        volunteered_buffer_length: amt$working_storage_length;
        system_media_recovery: boolean;
    VAR block_ptr: ^bat$tape_block;
    VAR block_type: bat$tape_block_type;
    VAR block_length: amt$max_block_length;
    VAR failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_operation
*copyc bat$tape_block
*copyc amt$working_storage_length
*copyc bat$tape_block_type
*copyc amt$max_block_length
*copyc amt$tape_failure_modes
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_READ_TO_WRITE EXPAND=FALSE
  PROCEDURE [XREF] bap$tape_bm_read_to_write (file_identifier: amt$file_identifier;
        read_block_buffer: ^bat$tape_block;
    VAR write_block_buffer: ^bat$tape_block;
    VAR failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc bat$tape_block
*copyc amt$tape_failure_modes
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_RESERVE_BLK_BUFFER EXPAND=FALSE
 PROCEDURE [XREF] bap$tape_bm_reserve_blk_buffer (file_identifier:
  amt$file_identifier;
    VAR block_buffer_ptr: ^bat$tape_block;
    VAR failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc bat$tape_block
*copyc amt$tape_failure_modes
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_REWIND EXPAND=FALSE
 PROCEDURE [XREF] bap$tape_bm_rewind (file_identifier: amt$file_identifier;
    VAR failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$tape_failure_modes
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_SKIP_BLOCKS EXPAND=FALSE
 PROCEDURE [XREF] bap$tape_bm_skip_blocks (
        file_identifier: amt$file_identifier;
        direction: amt$skip_direction;
        count: amt$skip_count;
    VAR residual_skip_count: amt$skip_count;
    VAR failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amd$skip_declarations
*copyc amt$tape_failure_modes
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_SKIP_LABEL_MARK EXPAND=FALSE
  PROCEDURE [XREF] bap$tape_bm_skip_label_mark (file_id: amt$file_identifier;
        direction: amt$skip_direction;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$skip_direction
*copyc amt$tape_failure_modes
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_SKIP_TAPEMARK EXPAND=FALSE
 PROCEDURE [XREF] bap$tape_bm_skip_tapemark (
        file_identifier: amt$file_identifier;
        direction: amt$skip_direction;
    VAR failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amd$skip_declarations
*copyc amt$tape_failure_modes
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_TAPEMARK_CHECK EXPAND=FALSE
 PROCEDURE [XREF] bap$tape_bm_tapemark_check (file_identifier:
  amt$file_identifier;
    VAR tapemark_next:boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_UNWRITTEN_BLK_COUNT EXPAND=FALSE
  PROCEDURE [XREF] bap$tape_bm_unwritten_blk_count (file_id: amt$file_identifier;
    VAR blocks_currently_buffered: bat$tape_block_buffer_count;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc bat$tape_block_buffer_count
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_WRITE_LABEL EXPAND=FALSE
 PROCEDURE [XREF] bap$tape_bm_write_label (file_identifier: amt$file_identifier;
        label_ptr: ^bat$tape_block;
        label_length: amt$max_block_length;
        system_media_recovery: boolean;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc bat$tape_block
*copyc amt$max_block_length
*copyc amt$tape_failure_modes
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_WRITE_LABEL_MARK EXPAND=FALSE
 PROCEDURE [XREF] bap$tape_bm_write_label_mark (file_identifier:
  amt$file_identifier;
        system_media_recovery: boolean;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$tape_failure_modes
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_WRITE_NEXT_BLOCK EXPAND=FALSE
 PROCEDURE [XREF] bap$tape_bm_write_next_block (file_identifier:
  amt$file_identifier;
        block_ptr: ^bat$tape_block;
        block_length: amt$max_block_length;
        system_media_recovery: boolean;
        force_write: boolean;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc bat$tape_block
*copyc amt$max_block_length
*copyc amt$tape_failure_modes
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_BM_WRITE_TAPE_MARK EXPAND=FALSE
 PROCEDURE [XREF] bap$tape_bm_write_tapemark (file_identifier:
  amt$file_identifier;
        system_media_recovery: boolean;
        force_write: boolean;
    VAR tape_failure_modes: amt$tape_failure_modes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$tape_failure_modes
*copyc ost$status
?? POP ??
*DECK DECK=BAP$TAPE_FAP EXPAND=FALSE

  PROCEDURE [XREF] bap$tape_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=BAP$TASK_TERMINATION_CLEANUP EXPAND=FALSE

  PROCEDURE [XREF] bap$task_termination_cleanup;
*DECK DECK=BAP$TRAILING_CHAR_DELIMITED_FAP EXPAND=FALSE

{ COMMON DECK BAP$TRAILING_CHAR_DELIMITED_FAP }

  PROCEDURE [XREF] bap$trailing_char_delimited_fap (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$UPDATE_OPENED_SUBJECT_FILE EXPAND=FALSE


  PROCEDURE [XREF] bap$update_opened_subject_file (subject_file_identifier:
    amt$file_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
?? POP ??
*DECK DECK=BAP$US_BLK_FIXED_REC_FAP EXPAND=FALSE

{ COMMON DECK BAP$US_BLK_FIXED_REC_FAP }

  PROCEDURE [XREF] bap$us_blk_fixed_rec_fap (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$US_BLK_UNDEFINED_REC_FAP EXPAND=FALSE

{ COMMON DECK BAP$US_BLK_UNDEFINED_REC_FAP }

  PROCEDURE [XREF] bap$us_blk_undefined_rec_fap (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$US_BLK_VARIABLE_REC_FAP EXPAND=FALSE

{ COMMON DECK BAP$US_BLK_VARIABLE_REC_FAP }

  PROCEDURE [XREF] bap$us_blk_variable_rec_fap (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=BAP$US_BLK_VAR_READ_ONLY_FAP EXPAND=FALSE

  PROCEDURE [XREF] bap$us_blk_var_read_only_fap (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??

*DECK DECK=BAP$VALIDATE_COMPATIBILITY EXPAND=FALSE

  PROCEDURE [XREF] bap$validate_compatibility (p_file_label:
        fmt$p_file_label;
        p_file_label_header: ^fmt$static_label_header;
        path_handle: fmt$path_handle;
        checksum_present: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$file_label
*copyc fmt$static_label_header
*copyc fmt$path_handle
*copyc ost$status
?? POP ??
*DECK DECK=BAP$VALIDATE_FAP_IDENTIFIER EXPAND=FALSE
{
{ The purpose of this request is to first validate the file identifier
{ as does bap$validate_file_identifier, and second to allocate a dummy
{ file_instance so the calling procedure can have a working copy of the
{ BAM tables.  This allows a BAM FAP to be run as a user FAP for debugging.
{ ~rOne limitation is that all interfaces called by the FAP must be callable
{ at the ring the FAP is running.~r
{

  PROCEDURE [INLINE] bap$validate_fap_identifier (file_identifier:
    amt$file_identifier;
    VAR file_instance: ^bat$task_file_entry;
    VAR file_id_is_valid: boolean);

?? PUSH (LISTEXT := ON) ??

  VAR
    status: ost$status,
    dummy_pva: ^cell,
    dummy_file_instance: ^bat$task_file_entry;

*copy BAI$VALIDATE_FILE_IDENTIFIER

  amp$fetch_fap_pointer (file_identifier, global_layer_number, dummy_pva, status);

  IF NOT status.normal THEN

    ALLOCATE dummy_file_instance;
    dummy_file_instance^ := file_instance^;
    ALLOCATE dummy_file_instance^.global_file_information;
    dummy_file_instance^.global_file_information^ := file_instance^.global_file_information^;
    ALLOCATE dummy_file_instance^.global_file_information^.device_dependent_info.tape_descriptor :[[REP
          (#SIZE (bat$tape_descriptor)) OF cell]];
    i#move (#LOC(file_instance^.global_file_information^.device_dependent_info.tape_descriptor^),
          #LOC(dummy_file_instance^.global_file_information^.device_dependent_info.tape_descriptor^),
          #size (bat$tape_descriptor));

    dummy_pva := dummy_file_instance;
    amp$store_fap_pointer (file_identifier, global_layer_number, dummy_pva, status);

  IFEND;

  file_instance := dummy_pva;

  PROCEND bap$validate_fap_identifier;
*copyc AMT$FILE_IDENTIFIER
*copyc BAT$TASK_FILE_TABLE
*copyc BAV$TASK_FILE_TABLE
*copyc amp$fetch_fap_pointer
*copyc amp$store_fap_pointer
?? POP ??
*DECK DECK=BAP$VALIDATE_FILE_IDENTIFIER EXPAND=FALSE


  PROCEDURE [INLINE] bap$validate_file_identifier (file_identifier:
    amt$file_identifier;
    VAR file_instance: ^bat$task_file_entry;
    VAR file_id_is_valid: boolean);

?? PUSH (LISTEXT := ON) ??

*copy BAI$VALIDATE_FILE_IDENTIFIER

  PROCEND bap$validate_file_identifier;
*copyc AMT$FILE_IDENTIFIER
*copyc BAT$TASK_FILE_TABLE
*copyc BAV$LAST_TFT_ENTRY
*copyc BAV$TASK_FILE_TABLE
?? POP ??
*DECK DECK=BAP$VALIDATE_PATH_TABLE_OBJECTS EXPAND=FALSE

  PROCEDURE [XREF] bap$validate_path_table_objects
    (    output_fid: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??


*DECK DECK=BAP$VERIFY_FILE_CONNECTION_ATTR EXPAND=FALSE

  PROCEDURE [INLINE] bap$verify_file_connection_attr (verify_for_open: boolean;
        subject_file_name: amt$local_file_name;
        target_file_name: amt$local_file_name;
        subject_contents: amt$file_contents;
        target_contents: amt$file_contents;
        subject_structure: amt$file_structure;
        target_structure: amt$file_structure;
    VAR status: ost$status);

    status.normal := TRUE;

    IF (subject_contents <> target_contents) AND (subject_contents <>
          amc$unknown_contents) AND (target_contents <> amc$unknown_contents)
          THEN
      IF verify_for_open THEN
        amp$set_local_name_abnormal (subject_file_name,
              ame$incompatible_file_connect, amc$open_req, target_file_name,
              status);
      ELSE
        osp$set_status_abnormal ('CL', cle$incompatible_file_connect,
              subject_file_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              target_file_name, status);
      IFEND;
      osp$append_status_parameter (osc$status_parameter_delimiter,
        'FILE_CONTENTS', status);
    IFEND;

    IF (subject_structure <> target_structure) AND (subject_structure <>
          amc$unknown_structure) AND (target_structure <>
          amc$unknown_structure) THEN
      IF status.normal THEN
        IF verify_for_open THEN
          amp$set_local_name_abnormal (subject_file_name,
                ame$incompatible_file_connect, amc$open_req, target_file_name,
                status);
        ELSE
          osp$set_status_abnormal ('CL', cle$incompatible_file_connect,
                subject_file_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                target_file_name, status);
        IFEND;
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'FILE_STRUCTURE', status);
      ELSE
        osp$append_status_parameter (' ', 'FILE_STRUCTURE', status);
      IFEND;
    IFEND;

  PROCEND bap$verify_file_connection_attr;

?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc amd$file_contents
*copyc amd$file_structure
*copyc ame$open_validation_errors
*copyc amt$local_file_name
*copyc cle$ecc_connected_file
*copyc ost$status
?? POP ??
*copyc amp$set_local_name_abnormal
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*DECK DECK=BAP$VOLUME_ROBOTICALLY_MOUNTED EXPAND=FALSE

  FUNCTION [XREF] bap$volume_robotically_mounted
    (    sfid: gft$system_file_identifier): boolean;

*copyc gft$system_file_identifier
*DECK DECK=BAP$V_TO_T_RECORD_CONVERSION EXPAND=FALSE

  PROCEDURE [XREF] bap$v_to_t_record_conversion (from_fid: amt$file_identifier;
        to_fid: amt$file_identifier;
        file_size_source: amt$file_byte_address;
    VAR current_byte_source: amt$file_byte_address;
    VAR current_byte_destination: amt$file_byte_address;
    VAR last_move: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc amt$file_byte_address
*copyc ost$status
*copyc amt$file_identifier
?? POP ??
*DECK DECK=BAP$WRITE_END_PARTITION EXPAND=FALSE
?? NEWTITLE := 'PROCEDURE BAP$WRITE_END_PARTITION' ??
{ COMMON DECK BAXWEOP }

  PROCEDURE [XREF] bap$write_end_partition (file_identifier:
    amt$file_identifier;
        call_block: amt$call_block;
        fap_layer_number: amt$fap_layer_number;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FAP_DECLARATIONS

?? POP ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FAP_DECLARATIONS
*copyc OST$STATUS
?? POP ??
?? OLDTITLE ??
*DECK DECK=BAP$WRITE_MODIFIED_PAGES EXPAND=FALSE

  PROCEDURE [XREF] bap$write_modified_pages (file_instance:
    ^bat$task_file_entry;
        file_identifier: amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc BAT$TASK_FILE_TABLE
*copyc OST$STATUS
?? POP ??
*DECK DECK=BAP$WRITE_TAPE EXPAND=FALSE
  PROCEDURE [XREF] bap$write_tape (sfid: dmt$system_file_id;
        block_description: ^iot$write_tape_description;
        block_count: iot$tape_block_count;
        perform_media_error_recovery: boolean;
    VAR io_id: iot$io_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc iot$write_tape_description
*copyc iot$tape_block_count
*copyc iot$io_id
*copyc ost$status
?? POP ??
*DECK DECK=BAP$WRITE_TAPEMARK EXPAND=FALSE
  PROCEDURE [XREF] bap$write_tapemark (sfid: dmt$system_file_id;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc iot$tape_io_status
*copyc ost$status
?? POP ??
*DECK DECK=BAT$ACCESS_CONDITIONS EXPAND=FALSE
*DECK DECK=BAT$ACCESS_COUNT EXPAND=FALSE
 TYPE
    bat$access_count = 0 .. 0ffff(16);
*DECK DECK=BAT$ACCESS_COUNTS EXPAND=FALSE
 TYPE
    bat$access_counts = array [fst$file_access_option] of bat$access_count;

*copyc bat$access_count
*DECK DECK=BAT$AUXILLIARY_REQUEST_TABLE EXPAND=FALSE

  CONST
    bac$art_size = 100;

  TYPE
    bat$last_art_entry = 0 .. bac$art_size,

    bat$art_limit = 1 .. bac$art_size,

    bat$auxilliary_request_table = array [bat$art_limit] of
      bat$art_descriptor,

    bat$art_descriptor = record
      local_file_name: amt$local_file_name,
      file_attributes: ^amt$file_attributes,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_attributes
*copyc amt$local_file_name
?? POP ??
*DECK DECK=BAT$BLOCK_HEADER EXPAND=FALSE

{ COMMON DECK BADBLKH }

  CONST
    bac$block_header_unique_id = 1919(16),
    bac$block_header_padding = ' BLOCK HDR';

  TYPE
    bat$block_header = record
      fill: 0 .. 0ffffffff(16),
      block_length: amt$max_block_length,
      previous_block_header_fba: amt$file_byte_address,
      unique_id: 0 .. 0ffff(16),
      header_type: amt$block_header_type,
      block_number: amt$block_number,
      block_status: amt$block_status,
      padding: string (10),
    recend;

{
?? PUSH (LISTEXT := ON) ??
*copyc AMD$BLOCK_HEADERS
*copyc AMT$FILE_BYTE_ADDRESS
?? POP ??
*DECK DECK=BAT$BLOCK_INFO EXPAND=FALSE

{ This record contains information that is used during record_access on a
{ blocked file.

  TYPE
    bat$block_info = record
      block_number: amt$block_number,
      block_position: bat$block_position,
      current_block_byte_address: amt$file_byte_address,
      current_block_length: 0 .. amc$maximum_block - 1,
      previous_block_header_fba: amt$file_byte_address,
      residual_block_length: 0 .. amc$maximum_block - 1,
    recend;

*copyc amc$maximum_block
*copyc amt$block_number
*copyc amt$file_byte_address
*copyc bat$block_position
*DECK DECK=BAT$BLOCK_MANAGER_DESCRIPTOR EXPAND=FALSE

{ COMMON DECK BAT$BLOCK_MANAGER_DESCRIPTOR }

  TYPE
    bat$block_manager_descriptor = record
      block_number: amt$block_number,
      block_position: bat$block_position,
      current_block_byte_address: amt$file_byte_address,
      current_block_length: 0 .. amc$maximum_block - 1,
      previous_block_header_fba: amt$file_byte_address,
      residual_block_length: 0 .. amc$maximum_block - 1,
      get_block_buffer: ^bat$tape_block,
      put_block_buffer: ^bat$tape_block,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$BLOCK_NUMBER
*copyc AMT$MAX_BLOCK_LENGTH
*copyc BAT$BLOCK_POSITION
*copyc bat$tape_block
?? POP ??
*DECK DECK=BAT$BLOCK_POSITION EXPAND=FALSE
{ COMMON DECK BADBPOS }

  TYPE
    bat$block_position = (bac$beginning_of_block, bac$middle_of_block);
*DECK DECK=BAT$BUFFER_DESCRIPTOR EXPAND=FALSE

{ COMMON DECK BADBFM }

  CONST
    bac$default_block_elements = 16;

  TYPE
    bat$buffer_descriptor = array [ * ] of bat$space_descriptor,

    bat$space_descriptor = record
      element_address: ^cell,
      element_length: amt$max_record_length,
      element_offset: integer,
    recend;

  TYPE
    bat$get_put_call = (bac$get, bac$put);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$MAX_RECORD_LENGTH
?? POP ??
*DECK DECK=BAT$CURRENT_BLOCK_DESCRIPTOR EXPAND=FALSE

  TYPE
    bat$current_block_descriptor = record
      byte_address_offset: amt$file_byte_address,
      length: amt$max_block_length,
      transfer_count: amt$transfer_count,
      reserved_block_buffer: ^bat$tape_block,
    recend;

*copyc amt$file_byte_address
*copyc amt$max_block_length
*copyc amt$transfer_count
*copyc bat$tape_block
*DECK DECK=BAT$DEFAULT_HANDLER_PARAMS EXPAND=FALSE
*DECK DECK=BAT$DESCRIPTIVE_FILE_ATTRIBUTES EXPAND=FALSE

{ COMMON DECK BADDSA }

{   This common deck contains the type declarations for the attributes
{ used in the descriptive file label.  Each field has a source
{ variable associated with it, describing where the value origianated.

  TYPE
    bat$descriptive_file_attributes = record
      application_info: pft$application_info,
      application_info_source: amt$attribute_source,
      global_access_mode: pft$usage_selections,
      global_access_mode_source: amt$attribute_source,
      global_file_name: ost$binary_unique_name,
      global_file_name_source: amt$attribute_source,
      global_share_mode: pft$share_selections,
      global_share_mode_source: amt$attribute_source,
      internal_cycle_name: ost$binary_unique_name,
      internal_cycle_name_source: amt$attribute_source,
      permanent_file: boolean,
      permanent_file_source: amt$attribute_source,
    recend;


?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
*copyc AMD$FILE_ATTRIBUTES
*copyc AMT$FILE_BYTE_ADDRESS
*copyc OSD$UNIQUE_NAME
?? POP ??
*DECK DECK=BAT$DISPLAY_TABLES_INDENTION EXPAND=FALSE

  CONST
    bat$display_tables_str_length = 132;

  TYPE
    bat$display_tables_indention = 0 .. bat$display_tables_str_length;

*DECK DECK=BAT$DYNAMIC_LABEL_ATTRIBUTES EXPAND=FALSE

{   This common deck contains the type declarations for the attributes
{ used in the dynamic file label.  Each field has a source
{ variable associated with it, describing where the value originated.

  TYPE
    bat$dynamic_label_attributes = record
      access_mode: pft$usage_selections,
      access_mode_source: amt$attribute_source,
      error_exit_name: pmt$program_name,
      error_exit_name_source: amt$attribute_source,
      error_exit_procedure: amt$error_exit_procedure,
      error_exit_procedure_source: amt$attribute_source,
      error_options: amt$tape_error_options,
      error_options_source: amt$attribute_source,
      label_exit_name: pmt$program_name,
      label_exit_name_source: amt$attribute_source,
      label_exit_procedure: amt$label_exit_procedure,
      label_exit_procedure_source: amt$attribute_source,
      label_options: amt$label_options,
      label_options_source: amt$attribute_source,
      open_position: amt$open_position,
      open_position_source: amt$attribute_source,
      open_share_modes: fst$file_access_options,
      open_share_modes_source: amt$attribute_source,
      return_option: amt$return_option,
      return_option_source: amt$attribute_source,
      error_limit: amt$error_limit,
      error_limit_source: amt$attribute_source,
      message_control: amt$message_control,
      message_control_source: amt$attribute_source,
    recend;


?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
*copyc AMD$FILE_ATTRIBUTES
*copyc AMT$OPEN_POSITION
*copyc FST$FILE_ACCESS_OPTIONS
?? POP ??
*DECK DECK=BAT$D_RECORD_RCW EXPAND=FALSE

{ The following defines an ANSI Variable-Record Record-Control-Word:

  TYPE
    bat$d_record_rcw = record
      length: string (bac$rcw_length_size),
    recend;

  CONST
    bac$rcw_length_size = 4;

{ The following defines the bat$d_record_rcw.length range:

  TYPE
    bat$rcw_length_value_range = 4 .. 9999;

  CONST
    bac$rcw_min_length_value = '0004',
    bac$rcw_max_length_value = '9999',
    bac$rcw_length_value_of_zero = '0000',
    bac$ansi_block_padding_chars = '^^^^';


*DECK DECK=BAT$FAP_CONTROL_INFORMATION EXPAND=FALSE
  TYPE
    bat$fap_control_information = record
      first_fap: bat$fap_descriptor,
      fap_array: ^array [0 .. * ] of bat$fap_descriptor,
    recend;

*copyc bat$fap_descriptor

*DECK DECK=BAT$FAP_DESCRIPTOR EXPAND=FALSE
  TYPE
    bat$fap_descriptor = record
      access_method: amt$fap_pointer,
      structure_pointer: ^cell,
      loaded_ring: ost$valid_ring,
      layer_closed: boolean,
    recend;

*copyc amt$fap_pointer
*copyc osd$virtual_address
*DECK DECK=BAT$GLOBAL_FILE_INFORMATION EXPAND=FALSE

  TYPE
    bat$global_file_information = record
      open_count: ALIGNED [0 MOD 8] ost$compare_swap_lock,
      open_lock: ost$signature_lock,
      implicit_detach_inhibited: boolean,
      asis_bor_address: amt$file_byte_address,
      asis_file_position: amt$file_position,
      asis_open_address: amt$file_byte_address,
      cycle_damage_symptoms: fst$cycle_damage_symptoms,
      device_dependent_info: bat$device_dependent_info,
      eoi_byte_address: amt$file_byte_address,
      eoi_set: boolean,
      error_status: ost$status_condition,
      file_limit: amt$file_limit,
      last_access_operation: amt$last_access_operation,
      max_block_size: 0 .. amc$maximum_block - 1,
      max_data_size: 0 .. amc$maximum_block - 1,
      max_record_length: amt$max_record_length,
      min_block_length: amt$min_block_length,
      opened_access_modes: bat$access_counts,
      padding_character: amt$padding_character,
      positioning_info: bat$positioning_info,
      prevented_open_access_modes: bat$access_counts,
      record_delimiting_character: CHAR,
    recend,

    bat$device_dependent_info = record
      case device_class: rmt$device_class OF
        = rmc$connected_file_device =
          connected_file_descriptor: ^SEQ(*),
        = rmc$interstate_link_device =
          interstate_link_descriptor: ^SEQ(*),
        = rmc$local_queue_device =
          local_queue_descriptor: ^SEQ(*),
        = rmc$log_device =
          log_descriptor: ^SEQ(*),
        = rmc$magnetic_tape_device =
          tape_descriptor: ^SEQ(*), { ^bat$tape_descriptor }
        = rmc$mass_storage_device =
          mass_storage_descriptor: ^SEQ(*),
        = rmc$memory_resident_device =
          memory_resident_descriptor: ^SEQ(*),
        = rmc$network_device =
          network_global_file_information: ^nat$global_file_information,
          network_connection_id: nat$connection_id,
        = rmc$null_device =
          null_descriptor: ^SEQ(*),
        = rmc$pipeline_device =
          pipeline_descriptor: ^SEQ(*),
        = rmc$rhfam_device =
          rhfam_descriptor: ^SEQ(*),
        = rmc$terminal_device =
          terminal_descriptor: ^SEQ(*),
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amd$information
*copyc amd$operation_declarations
*copyc amt$file_byte_address
*copyc amt$file_limit
*copyc amt$file_position
*copyc amt$last_access_operation
*copyc amt$max_block_length
*copyc amt$min_block_length
*copyc bat$access_counts
*copyc bat$positioning_info
*copyc bat$tape_descriptor
*copyc rmt$device_class
*copyc fst$cycle_damage_symptoms
*copyc fst$file_access_options
*copyc ost$signature_lock
*copyc ost$status_condition
*copyc nat$global_file_information
*copyc nat$connection_id
?? POP ??
*DECK DECK=BAT$GLOBAL_TAPE_INFORMATION EXPAND=FALSE

  TYPE
    bat$global_tape_information = record
      vsn: rmt$external_vsn,
      volume_number: amt$volume_number,
      volume_position: amt$volume_position,
      block_number: amt$block_number,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc rmd$volume_declarations
*copyc amd$information
*copyc amt$volume_position
*copyc amt$block_number
?? POP ??

*DECK DECK=BAT$INITIAL_VOLUME_CONTROL_INFO EXPAND=FALSE
  TYPE
    bat$initial_volume_control_info = record
      access_modes: fst$file_access_options,
      assigned: boolean,
      classification: rmt$tape_volume_classification,
      header_labels: ^SEQ ( * ),
      initial_read_labels_attempt: boolean,
    recend;

*copyc fst$file_access_options
*copyc rmt$tape_volume_classification
*DECK DECK=BAT$INSTANCE_ATTRIBUTES EXPAND=FALSE

{COMMON DECK BADIA}

  TYPE
    bat$instance_attributes = record
      static_label: bat$instance_static_attributes,
      dynamic_label: bat$dynamic_label_attributes,
    recend,

    bat$instance_static_attributes = record
      block_type: amt$block_type,
      block_type_source: amt$attribute_source,
      file_label_type: amt$file_label_type,
      file_label_type_source: amt$attribute_source,
      file_organization: amt$file_organization,
      file_organization_source: amt$attribute_source,
      record_type: amt$record_type,
      record_type_source: amt$attribute_source,
      ring_attributes: amt$ring_attributes,
      ring_attributes_source: amt$attribute_source,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc AMD$FILE_ATTRIBUTES
*copyc AMT$RING_ATTRIBUTES
*copyc BAT$DYNAMIC_LABEL_ATTRIBUTES
?? POP ??
*DECK DECK=BAT$LABELED_TAPE_STATE_INFO EXPAND=FALSE
  TYPE
    bat$labeled_tape_state_info = record
      buffered_blocks: 0 .. 999999,
      character_conversion: boolean,
      character_set: amt$internal_code,
      eof1_block_count: 0 .. 999999,
      eoi_labels_needed: boolean,
      file_access: (bac$read, bac$append, bac$write),
      maximum_block_length: amt$max_block_length,
      maximum_record_length: amt$max_record_length,
      padding_character: amt$padding_character,
      put_op: boolean,
      translated_block_padding_char: amt$padding_character,
      translated_record_padding_char: amt$padding_character,
      ve_wrote_ansi_file: boolean,
    recend;

*copyc amt$internal_code
*copyc amt$max_block_length
*copyc amt$max_record_length
*copyc amt$padding_character
*DECK DECK=BAT$LABELED_VOLUME_POSITION EXPAND=FALSE
  TYPE

    bat$labeled_volume_position = (bac$lvp_after_header_labels,
          bac$lvp_after_trailer_labels, bac$lvp_before_header_labels,
          bac$lvp_beginning_of_file_set, bac$lvp_end_of_file_set,
          bac$lvp_end_of_volume_list, bac$lvp_within_ansi_file);

*DECK DECK=BAT$LABEL_DESCRIPTOR EXPAND=FALSE

{ COMMON DECK BADLABD }

  TYPE
    bat$label_descriptor = record
      label_attributes: bat$label_attributes
    recend,
    bat$label_attributes = integer;

?? PUSH (LISTEXT := ON) ??
?? POP ??
*DECK DECK=BAT$LAST_ACCESSED_LABELS EXPAND=FALSE

  TYPE
    bat$last_accessed_labels = record
      secured_header_labels: ^SEQ ( * ),
      secured_trailer_labels: ^SEQ ( * ),
      unsecured_header_labels: ^SEQ ( * ),
      unsecured_trailer_labels: ^SEQ ( * ),
    recend;
*DECK DECK=BAT$NEXT_POSITION_CONTROL_INFO EXPAND=FALSE

  TYPE
    bat$next_position_control_info = record
      file_section_number: 1 .. 9999,
      file_sequence_number: 1 .. 9999,
    recend;
*DECK DECK=BAT$OPEN_ACTIONS EXPAND=FALSE
TYPE
  bat$open_actions = PACKED record
    open_attached_file: boolean,
    open_created_file: boolean,
    open_deleted_data: boolean,
  recend;
*DECK DECK=BAT$OPEN_WORK_RESULT EXPAND=FALSE

  TYPE
    bat$open_work_result = (bac$file_not_created, bac$implicit_pf_create,
          bac$implicit_pf_attach, bac$temporary_file_create);

*DECK DECK=BAT$POSITIONING_INFO EXPAND=FALSE

{ This record contains information that is used for positioning within a file.

  TYPE
    bat$positioning_info = record
      block_info: bat$block_info,
      record_info: bat$record_info,
    recend;

*copyc bat$block_info
*copyc bat$record_info
*DECK DECK=BAT$PRIVATE_READ_INFORMATION EXPAND=FALSE

{ This record contains the information affected by private_read.

  TYPE
    bat$private_read_information = record
      error_status: ost$status_condition,
      last_access_operation: amt$last_access_operation,
      positioning_info: bat$positioning_info,
    recend;

*copyc amt$last_access_operation
*copyc bat$positioning_info
*copyc ost$status_condition
*DECK DECK=BAT$PROCESS_PT_RESULT EXPAND=FALSE

  TYPE
    bat$process_pt_result = (bac$cycle_description_created,
          bac$cycle_description_exists);
*DECK DECK=BAT$PROCESS_PT_RESULTS EXPAND=FALSE

  TYPE
    bat$process_pt_results = set of bat$process_pt_result;

?? PUSH (LISTEXT := ON) ??
*copyc bat$process_pt_result
?? POP ??
*DECK DECK=BAT$PROCESS_PT_WORK_ITEMS EXPAND=FALSE

  TYPE
    bat$process_pt_work_items = (bac$create_cycle_description,
          bac$externalize_path_handle, bac$inhibit_locking_pt,
          bac$leave_aliases_unresolved, bac$record_path, bac$resolve_path,
          bac$resolve_pf_in_pt, bac$resolve_to_catalog,
          bac$return_cycle_description);

*DECK DECK=BAT$PROCESS_PT_WORK_LIST EXPAND=FALSE

  TYPE
    bat$process_pt_work_list = set of bat$process_pt_work_items;

?? PUSH (LISTEXT := ON) ??
*copyc bat$process_pt_work_items
?? POP ??
*DECK DECK=BAT$PUT_LABEL_REQUEST EXPAND=FALSE

  TYPE
    bat$put_label_request = record
      case operation: bat$put_label_operation of
      = bac$write_label_record =
        label_record: STRING(80),
      = bac$write_label_tapemark =
        ,
      casend,
    recend,

    bat$put_label_operation =
      (bac$write_label_record, bac$write_label_tapemark);
*DECK DECK=BAT$QLABEL EXPAND=FALSE

{COMMON DECK BADRTE}

  TYPE
    bat$qlabel = array [1 .. 20] of bat$q_entry,

    bat$q_entry = record
      dummy: integer,
    recend;
*DECK DECK=BAT$QLABEL_SYSTEM_FILE_ID EXPAND=FALSE
{TEMP DECK TO DEFINE QLABEL AND SYSTEM_FILE_ID}

TYPE
   bat$qlabel = amt$file_attributes,
   bat$system_file_id = integer;
*DECK DECK=BAT$RECORD_HEADER_TYPE EXPAND=FALSE

{ COMMON DECK BADRCDH }

  CONST
    bac$record_header_unique_id = 1e(16);

  TYPE
    bat$record_header_type = (bac$full_record, bac$start_record,
      bac$continued_record, bac$end_record, bac$partition, bac$deleted_record,
      bac$end_of_data);


  TYPE
    bat$record_header = record
      header_type: bat$record_header_type,
      length: amt$max_record_length,
      previous_header_fba: amt$file_byte_address,
      unique_id: 0 .. 0ff(16),
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$MAX_RECORD_LENGTH
?? POP ??
*DECK DECK=BAT$RECORD_INFO EXPAND=FALSE

{ This record contains information that is used for positioning in a file
{ during record_access.  It also contains information that is returned to
{ the caller of the request.

  TYPE
    bat$record_info = record
      bor_address: amt$file_byte_address,
      current_byte_address: amt$file_byte_address,
      file_position: amt$file_position,
      record_header_fba: amt$file_byte_address,
      record_length: amt$max_record_length,
      residual_record_length: amt$max_record_length,
      transfer_count: amt$transfer_count,
    recend;

*copyc amt$file_byte_address
*copyc amt$file_position
*copyc amt$max_record_length
*copyc amt$transfer_count
*DECK DECK=BAT$RECORD_REQUEST_DESCRIPTOR EXPAND=FALSE

{ COMMON DECK BADRRD }

  TYPE
    bat$record_request_descriptor = record
      minimum_transfer: amt$max_record_length,
      residual_record_offset: amt$max_record_length,
      record_padding: amt$max_record_length,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc AMT$MAX_RECORD_LENGTH
?? POP ??
*DECK DECK=BAT$REQUEST_NAME_TABLE_ENTRY EXPAND=FALSE

{ COMMON DECK BADRNTE }

  TYPE
    bat$request_name_table_entry = record
      code: amt$last_operation,
      name: ost$name,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$last_operation
*copyc ost$name
?? POP ??
*DECK DECK=BAT$SINGLE_ATTACHMENT_CHOICES EXPAND=FALSE

  CONST
    bac$create_file = 1,
    bac$delete_data = 2,
    bac$error_exit_procedure = 3,
    bac$error_exit_procedure_name = 4,
    bac$error_limit {Advanced Access Method files only} = 5,
    bac$label_exit_procedure = 6,
    bac$label_exit_procedure_name = 7,
    bac$message_control {Advanced Access Method files only} = 8,
    bac$open_position = 9,
    bac$password = 10,
    bac$private_read = 11,
    bac$sequential_access = 12,
    bac$tape_attachment = 13,
    bac$validation_ring = 14,
    bac$wait_for_attachment = 15,

    bac$max_attach_choice = 15;

  TYPE
    bat$single_attachment_choices = 1 .. bac$max_attach_choice;

*DECK DECK=BAT$SL_TAPE_DOSSIER_REC EXPAND=FALSE
*DECK DECK=BAT$STATIC_LABEL_ATTRIBUTES EXPAND=FALSE

{ COMMON DECK BADSLA }

{   This common deck contains the type declarations for the attributes
{ used in the static file label.  Each field has a source
{ variable associated with it, describing where the value origianated.

  TYPE
    bat$static_label_attributes = record
      block_type: amt$block_type,
      block_type_source: amt$attribute_source,
      character_conversion: boolean,
      character_conversion_source: amt$attribute_source,
      clear_space: ost$clear_file_space,
      clear_space_source: amt$attribute_source,
      file_access_procedure: pmt$program_name,
      file_access_procedure_source: amt$attribute_source,
      file_contents: amt$file_contents,
      file_contents_source: amt$attribute_source,
      file_limit: amt$file_limit,
      file_limit_source: amt$attribute_source,
      file_organization: amt$file_organization,
      file_organization_source: amt$attribute_source,
      file_processor: amt$file_processor,
      file_processor_source: amt$attribute_source,
      file_structure: amt$file_structure,
      file_structure_source: amt$attribute_source,
      forced_write: amt$forced_write,
      forced_write_source: amt$attribute_source,
      internal_code: amt$internal_code,
      internal_code_source: amt$attribute_source,
      label_type: amt$label_type,
      label_type_source: amt$attribute_source,
      line_number: amt$line_number,
      line_number_source: amt$attribute_source,
      max_block_length: amt$max_block_length,
      max_block_length_source: amt$attribute_source,
      max_record_length: amt$max_record_length,
      max_record_length_source: amt$attribute_source,
      min_block_length: amt$min_block_length,
      min_block_length_source: amt$attribute_source,
      min_record_length: amt$min_record_length,
      min_record_length_source: amt$attribute_source,
      padding_character: amt$padding_character,
      padding_character_source: amt$attribute_source,
      page_format: amt$page_format,
      page_format_source: amt$attribute_source,
      page_length: amt$page_length,
      page_length_source: amt$attribute_source,
      page_width: amt$page_width,
      page_width_source: amt$attribute_source,
      preset_value: amt$preset_value,
      preset_value_source: amt$attribute_source,
      record_delimiting_character: char,
      record_delimiting_char_source: amt$attribute_source,
      record_type: amt$record_type,
      record_type_source: amt$attribute_source,
      ring_attributes: amt$ring_attributes,
      ring_attributes_source: amt$attribute_source,
      statement_identifier: amt$statement_identifier,
      statement_identifier_source: amt$attribute_source,
      user_info: amt$user_info,
      user_info_source: amt$attribute_source,
      vertical_print_density: amt$vertical_print_density,
      vertical_print_density_source: amt$attribute_source,
{}
{ The following attributes are only used to describe files which}
{ are accessed with the Advanced Access Mehtod (AAM).  The}
{ documentation of the AAM attributes are found in the AAM ERS.}
{}
      average_record_length: amt$average_record_length,
      average_record_length_source: amt$attribute_source,
      collate_table: amt$collate_table,
      collate_table_source: amt$attribute_source,
      collate_table_name: pmt$program_name,
      collate_table_name_source: amt$attribute_source,
      compression_procedure_name: amt$compression_procedure_name,
      compression_proc_name_source: amt$attribute_source,
      data_padding: amt$data_padding,
      data_padding_source: amt$attribute_source,
      dynamic_home_block_space: amt$dynamic_home_block_space,
      dynamic_home_block_space_source: amt$attribute_source,
      embedded_key: boolean,
      embedded_key_source: amt$attribute_source,
      estimated_record_count: amt$estimated_record_count,
      estimated_record_count_source: amt$attribute_source,
      hashing_procedure_name: amt$hashing_procedure_name,
      hashing_procedure_name_source: amt$attribute_source,
      index_levels: amt$index_levels,
      index_levels_source: amt$attribute_source,
      index_padding: amt$index_padding,
      index_padding_source: amt$attribute_source,
      initial_home_block_count: amt$initial_home_block_count,
      initial_home_block_count_source: amt$attribute_source,
      key_length: amt$key_length,
      key_length_source: amt$attribute_source,
      key_position: amt$key_position,
      key_position_source: amt$attribute_source,
      key_type: amt$key_type,
      key_type_source: amt$attribute_source,
      loading_factor: amt$loading_factor,
      loading_factor_source: amt$attribute_source,
      lock_expiration_time: amt$lock_expiration_time,
      lock_expiration_time_source: amt$attribute_source,
      logging_options: amt$logging_options,
      logging_options_source: amt$attribute_source,
      log_residence: amt$log_residence,
      log_residence_source: amt$attribute_source,
      record_limit: amt$record_limit,
      record_limit_source: amt$attribute_source,
      records_per_block: amt$records_per_block,
      records_per_block_source: amt$attribute_source,
    recend;


?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
*copyc OST$CLEAR_FILE_SPACE
*copyc AMD$FILE_ATTRIBUTES
*copyc AMT$COMPRESSION_PROCEDURE_NAME
*copyc AMT$DYNAMIC_HOME_BLOCK_SPACE
*copyc AMT$HASHING_PROCEDURE_NAME
*copyc AMT$INITIAL_HOME_BLOCK_COUNT
*copyc AMT$LOADING_FACTOR
*copyc AMT$LOCK_EXPIRATION_TIME
*copyc AMT$LOG_RESIDENCE
*copyc AMT$LOGGING_OPTIONS
*copyc AMT$MAX_BLOCK_LENGTH
*copyc AMT$MAX_RECORD_LENGTH
*copyc AMT$STATEMENT_IDENTIFIER
*copyc AMD$OPEN_DECLARATIONS
?? POP ??
*DECK DECK=BAT$SYSTEM_FILE_ATTRIBUTES EXPAND=FALSE

{ COMMON DECK BADSFA }

{   This common deck contains the type declarations for the attributes
{ used in the system file label.

  TYPE
    bat$system_file_attributes = record
      static_label: bat$static_label_attributes,
      dynamic_label: bat$dynamic_label_attributes,
      descriptive_label: bat$descriptive_file_attributes,
    recend;

*copyc BAT$STATIC_LABEL_ATTRIBUTES
*copyc BAT$DYNAMIC_LABEL_ATTRIBUTES
*copyc BAT$DESCRIPTIVE_FILE_ATTRIBUTES
*DECK DECK=BAT$S_RECORD_SCW EXPAND=FALSE

{ The following defines an ANSI Spanned-Record Segment-Control-Word:

  TYPE
    bat$s_record_scw = record
      header_type: CHAR,
      length: string (bac$scw_length_size),
    recend;

  CONST
    bac$scw_length_size = 4;

{ The following defines the bat$s_record_scw.header_type values:

  CONST
    bac$full_segment = '0',
    bac$start_segment = '1',
    bac$continued_segment = '2',
    bac$end_segment = '3';

{ The following defines the bat$s_record_scw.length range:

  TYPE
    bat$scw_length_value_range = 5 .. 9999;

  CONST
    bac$scw_min_length_value = '0005',
    bac$scw_max_length_value = '9999',
    bac$scw_length_value_of_zero = '0000',
    bac$ansi_block_padding_char = '^';


*DECK DECK=BAT$TAPE_BLOCK EXPAND=FALSE
  TYPE
    bat$tape_block = array [amt$max_block_length] of cell;

*copyc amt$max_block_length

*DECK DECK=BAT$TAPE_BLOCK_BUFFER_COUNT EXPAND=FALSE
TYPE
  bat$tape_block_buffer_count = 0..amc$maximum_block;

*copyc amc$maximum_block
*DECK DECK=BAT$TAPE_BLOCK_BUFFER_INDEX EXPAND=FALSE
  TYPE
    bat$tape_block_buffer_index = 1 .. bac$max_tape_buffer_group_size;

*copyc bac$max_tape_buffer_group_size
*DECK DECK=BAT$TAPE_BLOCK_MGMT_DESCRIPTOR EXPAND=FALSE
 TYPE
    bat$tape_block_mgmt_descriptor = record
      sfid: dmt$system_file_id,
      tape_has_write_ring: boolean,
      io_direction: bat$tape_io_direction,
      direct_io: boolean,
      max_block_length: amt$max_block_length,
      max_blocks_per_physical_call: iot$tape_block_count,
      buffer_segment: mmt$segment_pointer,
      non_data_io_status: iot$tape_io_status, { for debugging }
      system_media_recovery: boolean,
      fatal_write_error: boolean,
      fatal_write_failure_modes: amt$tape_failure_modes,
      inhibit_read_ahead: boolean,
      write_hit_end_of_tape_reflector: boolean,
      buffer_groups_in_use: bat$tape_buffer_group_index,
      buffer_group_size: bat$tape_block_buffer_index,
      buffer_reserved: boolean,
      physical_position: bat$tape_block_position,
      logical_position: bat$tape_block_position,
      buffer_group: array [bat$tape_buffer_group_index] of
        ^bat$tape_buffer_grp_descriptor,
    recend;

*copyc iot$tape_io_status
*copyc bat$tape_io_direction
*copyc dmt$system_file_id
*copyc bat$tape_buffer_grp_descriptor
*copyc amt$max_block_length
*copyc bat$tape_block_position
*copyc bat$tape_buffer_group_index
*copyc mmt$attribute_keyword
*DECK DECK=BAT$TAPE_BLOCK_POSITION EXPAND=FALSE
 TYPE
    bat$tape_block_position = record
      buffer_group: bat$tape_buffer_group_index,
      buffer_index: bat$tape_block_buffer_index,
    recend;

*copyc bat$tape_buffer_group_index
*copyc bat$tape_block_buffer_index
*DECK DECK=BAT$TAPE_BLOCK_TYPE EXPAND=FALSE
 TYPE
    bat$tape_block_type = (bac$good_data_block, bac$error_data_block,
      bac$error_without_data, bac$density_mismatch, bac$read_past_phys_eot, bac$tapemark);
*DECK DECK=BAT$TAPE_BUFFER_GROUP_INDEX EXPAND=FALSE
 TYPE
    bat$tape_buffer_group_index = 1 .. ioc$max_multiple_tape_requests;

*copyc iot$io_id
*DECK DECK=BAT$TAPE_BUFFER_GROUP_STATE EXPAND=FALSE
  TYPE
    bat$tape_buffer_group_state = (bac$group_empty, bac$group_contains_data,
      bac$group_io_pending);

*DECK DECK=BAT$TAPE_BUFFER_GRP_DESCRIPTOR EXPAND=FALSE

{ Note - The constant bac$max_buffer_group_size is used by bap$tape_bm_open
{ to ensure that every buffer group descriptor is guaranteed to not cross a
{ page boundary.  The size of bat$tape_buffer_grp_descriptor is currently
{ 1768 bytes long.  It must NEVER be increased to larger than 2048 bytes long.

  CONST
    bac$max_buffer_group_size = 2048;

 TYPE
    bat$tape_buffer_grp_descriptor = record
      group_state: bat$tape_buffer_group_state,
      requested_read_length: amt$max_block_length,
      read_description: iot$read_tape_description,
      write_description: iot$write_tape_description,
      blks_requested_to_be_transfered: iot$tape_block_count,
      io_id: iot$io_id,
      io_status: iot$tape_io_status, { here for debugging }
      last_buffer_with_data: bat$tape_block_buffer_index,
      block_buffer: array [bat$tape_block_buffer_index] of
        bat$tape_buffer_information,
    recend;

*copyc bat$tape_buffer_group_state
*copyc bat$tape_block_buffer_index
*copyc bat$tape_buffer_information
*copyc iot$io_id
*copyc iot$tape_io_status
*copyc iot$read_tape_description
*copyc iot$write_tape_description
*DECK DECK=BAT$TAPE_BUFFER_INFORMATION EXPAND=FALSE
TYPE
  bat$tape_buffer_information = RECORD
    block_length: ALIGNED [0 MOD 8] iot$tape_transfer_count,
    block_type: bat$tape_block_type,
    block_truncated: boolean,
    block_buffer: ^bat$tape_block,
    failure_modes: amt$tape_failure_modes,
    system_media_recovery_used: boolean,
    attempt_recovery: boolean,
  recend;

*copyc bat$tape_block_type
*copyc amt$max_block_length
*copyc bat$tape_block
*copyc amt$tape_failure_modes

*DECK DECK=BAT$TAPE_DESCRIPTOR EXPAND=FALSE

  TYPE
    bat$tape_descriptor = record
      at_eoi: boolean,
      block_management_descriptor: ^bat$tape_block_mgmt_descriptor,
      error_options: amt$tape_error_options,
      failure_isolation: amt$tape_failure_isolation,
      file_label_type: amt$file_label_type,
      forced_write: boolean,
      get_tape_block_buffer: ^bat$tape_block,
      initial_volume: bat$initial_volume_control_info,
      labeled_volume_position: bat$labeled_volume_position,
      last_accessed: bat$last_accessed_labels,
      last_data_operation: amt$last_access_operation,
      next_position: bat$next_position_control_info,
      put_tape_block_buffer: ^bat$tape_block,
      requested_density: rmt$density,
      rewind_file_command: boolean,
      tape_attachment_information: fst$tape_attachment_information,
      tape_label_attr_command_info: fst$tape_attachment_information,
      volume_number: amt$volume_number,
      volume_position: amt$volume_position,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_label_type
*copyc amt$internal_code
*copyc amt$last_access_operation
*copyc amt$tape_error_options
*copyc amt$tape_failure_isolation
*copyc amt$volume_number
*copyc amt$volume_position
*copyc bat$initial_volume_control_info
*copyc bat$labeled_volume_position
*copyc bat$last_accessed_labels
*copyc bat$next_position_control_info
*copyc bat$tape_block
*copyc bat$tape_block_mgmt_descriptor
*copyc fst$tape_attachment_information
*copyc fst$tape_label_sequence_header
*copyc fst$tape_label_block_descriptor
*copyc rmt$density
?? POP ??
*DECK DECK=BAT$TAPE_FATAL_RECOVERY_MODES EXPAND=FALSE
  TYPE
    bat$tape_fatal_recovery_modes = set of bat$tape_fatal_recovery_mode;

  TYPE
    bat$tape_fatal_recovery_mode = (bac$tfrm_fatal_data_write, bac$tfrm_fatal_write,
                                      bac$tfrm_fatal_read, bac$tfrm_fatal_rewind,
                                      bac$tfrm_fatal_write_tapemark,
                                      bac$tfrm_repositioning_error,
                                      bac$tfrm_reassignment_error);

*DECK DECK=BAT$TAPE_IO_DIRECTION EXPAND=FALSE
 TYPE
    bat$tape_io_direction = (bac$iod_reading, bac$iod_writing,
      bac$iod_indeterminate);
*DECK DECK=BAT$TAPE_READ_BLOCK_DESCRIPTION EXPAND=FALSE
 TYPE
    bat$tape_read_block_description = record
      case block_type: bat$tape_block_type of
      = bac$good_data_block =
        good_block_length: amt$max_block_length,
      = bac$error_data_block =
        error_block_length: amt$max_block_length,
        data_failure_modes: amt$tape_failure_modes,
      = bac$error_without_data =
        no_data_failure_modes: amt$tape_failure_modes,
      = bac$tapemark =
        ,
      casend,
    recend;

*copyc bat$tape_block_type
*copyc amt$max_block_length
*copyc amt$tape_failure_modes
*DECK DECK=BAT$TAPE_VALIDATION_STATE EXPAND=FALSE
 TYPE
    bat$tape_validation_state = (bac$no_tape_validation, bac$tape_validation_on, bac$tape_validation_off);

*DECK DECK=BAT$TASK_FILE_TABLE EXPAND=FALSE

{COMMON DECK BADTFT}

  CONST
    bac$tft_allocation_size = 75, {number of entries allocated at a time
    bac$maximum_tft_size = amc$max_file_id_ordinal;


    TYPE
      bat$tft_limit = 1 .. bac$maximum_tft_size,


      bat$last_tft_entry = 0 .. bac$maximum_tft_size,


      bat$tft_entry_assignment = string ( * <= bac$maximum_tft_size),


      bat$task_file_table = array [ 1 .. * ] of bat$task_file_entry,


{  The target_connection_level field is copied from the connection_level
{  of the target in the connected_files table at the time the
{  target file is opened.
{
{  The connection_level field is updated from the connection_level
{  of the subject in the connected_files table at the time the
{  subject is opened.  If one of its targets is closed and the
{  subject is not being closed, this value is set to
{  UPPERVALUE (clt$file_connection_level).  This forces an update
{  of all the TFT targets of this subject the next time the
{  connected_files FAP is called.

      bat$task_file_entry = record
        local_file_name: fst$path_handle_name,
        sequence_number: amt$file_id_sequence,
        access_level: amt$access_level,
        open_ring: ost$valid_ring,
        close_allowed: boolean,
        next_target: bat$target_file,
        initial_open: boolean,
        instance_of_open_modified: boolean,
        instance_attributes: bat$instance_attributes,
        open_actions: bat$open_actions,
        previous_get_at_eoi: boolean,
        residual_skip_count: amt$residual_skip_count,
        private_read_information: ^bat$private_read_information,
        global_file_information: ^bat$global_file_information,
        system_file_label: ^fmt$system_file_label,
        fap_control_information: bat$fap_control_information,
        module_dynamically_loaded: boolean,
        target_connection_level: clt$file_connection_level,
        case device_class: rmt$device_class of
        = rmc$connected_file_device =
          subject: ^clt$connected_file_subject,
          connected_files: ^clt$connected_files,
          connection_level: clt$file_connection_level,
          first_target: bat$target_file,
        = rmc$interstate_link_device =
          ,
        = rmc$local_queue_device =
          ,
        = rmc$log_device =
          log_ordinal: pmt$logs,
          log_address: ^SEQ ( * ),
          log_cycle: lgt$log_cycle,
          log_entry: ^bat$log_entry,
        = rmc$magnetic_tape_device =
          labeled_tape_state_info: bat$labeled_tape_state_info,
        = rmc$mass_storage_device =
          allowed_access_conditions: fst$file_access_conditions,
          file_pva: ^cell,
          rollback_procedure: fst$rollback_procedure,
          wait: boolean,
          wait_time: 0 .. fsc$longest_wait_time,
        = rmc$memory_resident_device =
          ,
        = rmc$network_device =
          sender_active: boolean,
          sender_activity_status: ^ost$activity_status,
          receiver_active: boolean,
          receiver_activity_status: ^ost$activity_status,
          data_transfer_timeout: nat$wait_time,
          eoi_message_enabled: boolean,
          eoi_message: ^nat$eoi_message,
          eoi_peer_termination: boolean,
        = rmc$null_device =
          ,
        = rmc$pipeline_device =
          ,
        = rmc$rhfam_device =
          , {Not a requestable option, placed here for completeness.
        = rmc$terminal_device =
          st_open_file_dsc_pointer: ^iit$st_open_file_description,
          open_file_dsc_pointer: ^iit$open_file_description,
        casend,
      recend,

      bat$target_file = record
        case defined: boolean of
        = TRUE =
          file_identifier: amt$file_identifier,
        = FALSE =
          ,
        casend,
      recend,

      bat$log_entry = record
        size: cyt$string_size,
        value: string ( * <= cyc$max_string_size),
      recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amt$file_identifier
*copyc amt$residual_skip_count
*copyc bat$fap_control_information
*copyc bat$instance_attributes
*copyc bat$global_file_information
*copyc bat$open_actions
*copyc bat$private_read_information
*copyc bat$labeled_tape_state_info
*copyc clt$connected_file
*copyc cyd$string
*copyc fmc$entry_assigned
*copyc fmt$system_file_label
*copyc fsc$longest_wait_time
*copyc fst$file_access_conditions
*copyc fst$path_handle_name
*copyc fst$rollback_procedure
*copyc iit$connection_description
*copyc lgt$log_read_activity
*copyc osd$virtual_address
*copyc pmd$system_log_interface
*copyc rmt$device_class
*copyc nat$eoi_message
*copyc nat$wait_time
*copyc ost$activity_status
*copyc ost$page_size
?? POP ??
*DECK DECK=BAT$TERMINAL_CMD_LIST EXPAND=FALSE

{ COMMON DECK BADTCL }

  TYPE
    bat$terminal_cmd_list = record
      next_cmd: ^bat$terminal_cmd_list,
      attribute_present: boolean,
      attribute: ift$connection_attributes,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ift$connection_attributes
?? POP ??
*DECK DECK=BAT$USER_LABEL_PROCESSING EXPAND=FALSE

{ COMMON DECK BADULP }

  TYPE
    bat$user_label_processing = record
      a: ^cell,
    recend;
*DECK DECK=BAT$V1_MAX_BLOCK_LENGTH EXPAND=FALSE


  CONST
    bac$maximum_block = 16777216 {2**24 bytes} ;

  TYPE
    bat$v1_max_block_length = 1 .. bac$maximum_block - 1;

*DECK DECK=BAT$WAIT_CONDITIONS EXPAND=FALSE

*DECK DECK=BAV$AUXILLIARY_REQUEST_TABLE EXPAND=FALSE

{COMMON DECK BAXART}

  VAR
    bav$auxilliary_request_table: [XREF] ^bat$auxilliary_request_table;

?? PUSH (LISTEXT := ON) ??
*copyc BAT$AUXILLIARY_REQUEST_TABLE
?? POP ??
*DECK DECK=BAV$DEFAULT_BLOCK_INFO EXPAND=FALSE

  VAR
    bav$default_block_info: [XREF, READ, oss$job_paged_literal]
      bat$block_info;

?? PUSH (LISTEXT := ON) ??
*copyc BAT$BLOCK_INFO
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=BAV$DEFAULT_RECORD_INFO EXPAND=FALSE

  VAR
    bav$default_record_info: [XREF, READ, oss$job_paged_literal]
      bat$record_info;

?? PUSH (LISTEXT := ON) ??
*copyc BAT$RECORD_INFO
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=BAV$FILE_POSITIONS EXPAND=FALSE

  VAR
    bav$file_positions: [XREF] array [amt$file_position] of string (3);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_position
?? POP ??
*DECK DECK=BAV$FORCE_DIRECT_TAPE_IO EXPAND=FALSE
  VAR
    bav$force_direct_tape_io: [XREF] boolean;
*DECK DECK=BAV$GLOBAL_TAPE_FAP_VARIABLES EXPAND=FALSE

{ DECK: BAV$GLOBAL_TAPE_FAP_VARIABLES

  VAR
    block_info: [XREF] ^bat$block_info,
    file_instance: [XREF] ^bat$task_file_entry,
    gfi: [XREF] ^bat$global_file_information,
    close_file_on_exit: [XREF] boolean,
    global_layer_number: [XREF] amt$fap_layer_number,
    operation: [XREF] amt$fap_operation,
    rhl: [XREF] 0 .. amc$maximum_block - 1,
    state_info: [XREF] ^bat$labeled_tape_state_info,
    tape_descriptor: [XREF] ^bat$tape_descriptor,
    tai: [XREF] ^fst$tape_attachment_information;
*DECK DECK=BAV$LABELED_TAPE_STATE_INFO EXPAND=FALSE
  VAR
    bav$labeled_tape_state_info: [XREF] bat$labeled_tape_state_info;

?? PUSH (LISTEXT := ON) ??
*copyc bat$labeled_tape_state_info
?? POP ??
*DECK DECK=BAV$LAST_ART_ENTRY EXPAND=FALSE

  VAR { XDCL,#GATE,OSS$TASK_PRIVATE in BAM$STORE_ART_TABLE_POINTER.}
    bav$last_art_entry: [XREF] bat$last_art_entry;

?? PUSH (LISTEXT := ON) ??
*copyc bat$auxilliary_request_table
?? POP ??
*DECK DECK=BAV$LAST_TFT_ENTRY EXPAND=FALSE

  VAR { XDCL,#GATE,OSS$TASK_PRIVATE in BAM$OPEN_FILE.}
    bav$last_tft_entry: [XREF] bat$last_tft_entry;

?? PUSH (LISTEXT := ON) ??
*copyc bat$task_file_table
?? POP ??

*DECK DECK=BAV$MAGNETIC_TAPE_DEVICE_FAPS EXPAND=FALSE

  VAR
    bav$magnetic_tape_device_faps: [XREF] array [amt$block_type] of
          array [amt$record_type] of amt$fap_pointer;

?? PUSH (LISTEXT := ON) ??
*copyc amt$block_type
*copyc amt$fap_pointer
*copyc amt$record_type
?? POP ??
*DECK DECK=BAV$MASS_STORAGE_DEVICE_FAPS EXPAND=FALSE

  VAR
    bav$mass_storage_device_faps: [XREF] array [amt$block_type] of
          array [amt$record_type] of amt$fap_pointer;

?? PUSH (LISTEXT := ON) ??
*copyc amt$block_type
*copyc amt$fap_pointer
*copyc amt$record_type
?? POP ??
*DECK DECK=BAV$MAX_ALLOWED_TAPE_BLOCK_SIZE EXPAND=FALSE
  VAR
    bav$max_allowed_tape_block_size: [XREF] integer;
*DECK DECK=BAV$MAX_BYTES_PER_TAPE_IO EXPAND=FALSE
  VAR
    bav$max_bytes_per_tape_io: [XREF] integer;
*DECK DECK=BAV$MAX_INDIRECT_TAPE_BLOCK EXPAND=FALSE
  VAR
    bav$max_indirect_tape_block: [XREF] integer;
*DECK DECK=BAV$REQUEST_NAME_TABLE_PTR EXPAND=FALSE

{ COMMON DECK BAXRNT }

  VAR
    bav$request_name_table_ptr: [XREF] ^array [1 .. * ] of
      bat$request_name_table_entry;

?? PUSH (LISTEXT := ON) ??
*copyc BAT$REQUEST_NAME_TABLE_ENTRY
?? POP ??
*DECK DECK=BAV$RMS_LIBRARY_REFERENCE EXPAND=FALSE

  VAR
    bav$rms_library_reference: [XREF] record
      entry_point: pmt$program_name,
      object_library: string (33),
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc pmt$program_name
?? POP ??
*DECK DECK=BAV$TASK_CLEANUP_INITIATED EXPAND=FALSE

  VAR
    bav$task_cleanup_initiated: [XREF] boolean;
*DECK DECK=BAV$TASK_FILE_TABLE EXPAND=FALSE

  VAR
    bav$task_file_table: [XREF] ^bat$task_file_table;

?? PUSH (LISTEXT := ON) ??
*copyc bat$task_file_table
?? POP ??
*DECK DECK=BAV$TFT_ENTRY_ASSIGNMENT EXPAND=FALSE

{ COMMON DECK BAXTEA }

  VAR
    bav$tft_entry_assignment: [XREF] ^bat$tft_entry_assignment;

?? PUSH (LISTEXT := ON) ??
*copyc BAT$TASK_FILE_TABLE
?? POP ??
*DECK DECK=BAV$USE_ASSIGN_PAGES_FOR_TAPE EXPAND=FALSE
  VAR
    bav$use_assign_pages_for_tape: [XREF] boolean;

*DECK DECK=BAX$CLOSE_VOLUME EXPAND=FALSE
{ COMMON DECK BAXCLSV }


  PROCEDURE [XREF] bap$close_volume (file_identifer: amt$file_identifier;
        call_block: amt$call_block;
        layer: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FAP_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=BRF$BUILD_REQUEST_DIRECTIVES EXPAND=FALSE
include_group FDF$LIBRARY
include_group OCF$BINDING_PROCEDURE
include_group OCF$OBJECT_CODE_UTILITIES
include_group OSF$BATCH_DEVICE_SUPPORT
include_group OSF$BOOT_JOB
include_group OSF$BOOT_MONITOR
include_group OSF$BUILTIN_LIBRARY
include_group OSF$C170_EI
include_group OSF$COMMAND_LIBRARY
include_group OSF$DEADSTART_LIBRARY
include_group OSF$DEVELOPMENT_DCFILE
include_group OSF$DEV_SYS_INIT_EPILOG
include_group OSF$DUMP_ANALYZER
include_group OSF$DUMP_ANALYZER_PROCS
include_group OSF$JOB_ACTIVATION_EPILOG
include_group OSF$JOB_ACTIVATION_PROLOG
include_group OSF$JOB_LEVELER_TASK
include_group OSF$JOB_TEMPLATE_223
include_group OSF$JOB_TEMPLATE_236
include_group OSF$JOB_TEMPLATE_23D
include_group OSF$JOB_TEMPLATE_2DD
include_group OSF$LCU_MF_SUBCMDS
include_group OSF$MANAGE_FILE_SERVER
include_group OSF$MESSAGE_TEMPLATES
include_group OSF$MF_CONFIG_EPILOG
include_group OSF$MONITOR
include_group OSF$NETWORK_ACTIVATION_EPILOG
include_group OSF$NETWORK_ACTIVATION_PROLOG
include_group OSF$NETWORK_MANAGEMENT
include_group OSF$NOSBINS
include_group OSF$NVELIB
include_group OSF$NVEPROL
include_group OSF$NVERELS
include_group OSF$OPERATOR_COMMAND_LIBRARY
include_group OSF$PRODUCT_EPILOG
include_group OSF$PROGRAMS
include_group OSF$PHYSICAL_CONFIG
include_group OSF$PROLOG_LIBRARY
include_group OSF$RELEASED_DCFILE
include_group OSF$RELEASED_SITECP
include_group OSF$RHFAM_NETWORK_UTILITIES
include_group OSF$SITE_COMMAND_LIBRARY
include_group OSF$SOU_LIBRARY
include_group OSF$SYSTEM_CORE_113
include_group OSF$SYSTEM_CORE_133
include_group OSF$SYSTEM_CORE_13D
include_group OSF$SYSTEM_CORE_1DD
include_group OSF$SYSTEM_DEADSTART_PROLOG
include_group OSF$SYSTEM_EPILOG
include_group OSF$SYSTEM_INITIATION_EPILOG
include_group OSF$SYSTEM_INITIATION_PROLOG
include_group OSF$SYSTEM_PROLOG
include_group OSF$SYSTEM_TERMINATION_PROLOG
include_group OSF$TASKS
include_group OSF$UNBOUND_PF_UTILITIES
include_group OSF$USER_FILE_TRANSFER
include_group RAF$BINDING_PROCEDURE
include_group RAF$BIND_NETWORK_MANAGEMENT
include_group RAF$FORTRAN_COMMAND_LIBRARY
include_group RAF$INTEGRATION_TOOLS
include_group RAF$LIBRARY
include_group RAF$MAINTENANCE_COMMAND_LIBRARY
include_group RAF$OPEN_SHOP_DI_CONFIGURATIONS
include_group RAF$OPEN_SHOP_TERMINAL_PROCS
include_group RAF$OPEN_SHOP_USER_PROCS
include_group TUF$TERMINAL_DEFINITIONS
exclude_group program_descriptions
exclude_group program_description
exclude_group program_descriptors
exclude_group generate_help_text_module
exclude_group generate_help_module
exclude_group message_templates
exclude_group generate_msg_template_module
exclude_group delete_decks
exclude_group deleted_decks
exclude_group convert_text_to_object
*DECK DECK=BUILD_00000 EXPAND=TRUE
*copyc BUILD_9517
*DECK DECK=BUILD_9517 EXPAND=TRUE
*copyc BUILD_A101
*IF bev$product_level = 'BUILD_9517'
*copyc cycle95_exceptions
*ELSE
*copyc BUILD_9517_contents
*IFEND
*DECK DECK=BUILD_9517_CONTENTS EXPAND=TRUE
IF $variable(BUILD_9517_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_9517_STATUS kind=status
IFEND
 exclude_feature nv0u756                         status=BUILD_9517_STATUS
*DECK DECK=BUILD_9517_NEW_DECKS EXPAND=TRUE
*copyc BUILD_A101_NEW_DECKS
*IF bev$product_level = 'BUILD_9517_NEW_DECKS'
*copyc cycle95_exceptions
*ELSE
*copyc BUILD_9517_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_9517_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_9581 EXPAND=TRUE
*IF bev$product_level = 'BUILD_9506 '
*copyc BUILD_9506
*IFEND
IF $variable(build_9581_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_9581_status kind=status
IFEND
 include_feature fulb_listing_to_pf              status=build_9581_status
 include_feature add_edid_stats_to_entbe         status=build_9581_status
 include_feature auto_reconfiguration_ofm_code   status=build_9581_status
 include_feature batch_output_filters_p2_jm      status=build_9581_status
 include_feature batch_output_filters_p2_jm_a    status=build_9581_status
 include_feature cartridge_tape_support_silo_6   status=build_9581_status
 include_feature cleanup_df_loopback_id_deck     status=build_9581_status
 include_feature df_add_server_loopback_id       status=build_9581_status
 include_feature generic_queues                  status=build_9581_status
 include_feature generic_queues_1                status=build_9581_status
 include_feature generic_queues_2                status=build_9581_status
 include_feature generic_queues_3                status=build_9581_status
 include_feature generic_queues_4                status=build_9581_status
 include_feature generic_queues_5                status=build_9581_status
 include_feature generic_queues_6                status=build_9581_status
 include_feature generic_queues_7                status=build_9581_status
 include_feature generic_queues_8                status=build_9581_status
 include_feature generic_queues_9                status=build_9581_status
 include_feature list_function_enhancements      status=build_9581_status
 include_feature memory_link_speedup             status=build_9581_status
 include_feature nv05445                         status=build_9581_status
 include_feature nv05445_a                       status=build_9581_status
 include_feature nv05445_b                       status=build_9581_status
 include_feature nv05766                         status=build_9581_status
 include_feature nv06947                         status=build_9581_status
 include_feature nv07146                         status=build_9581_status
 include_feature nv07162                         status=build_9581_status
 include_feature nv07162a                        status=build_9581_status
 include_feature nv07189                         status=build_9581_status
 include_feature nv07205                         status=build_9581_status
 include_feature nv07245_os3                     status=build_9581_status
 include_feature nv07311                         status=build_9581_status
 include_feature nv07473                         status=build_9581_status
 include_feature nv07548                         status=build_9581_status
 include_feature nv07555                         status=build_9581_status
 include_feature nv07590                         status=build_9581_status
 include_feature nv07597                         status=build_9581_status
 include_feature nv07599                         status=build_9581_status
 include_feature nv07647                         status=build_9581_status
 include_feature nv07649                         status=build_9581_status
 include_feature nv07703                         status=build_9581_status
 include_feature nv07712                         status=build_9581_status
 include_feature nv07724                         status=build_9581_status
 include_feature nv07889                         status=build_9581_status
 include_feature nv07900                         status=build_9581_status
 include_feature nv07916                         status=build_9581_status
 include_feature nv07924                         status=build_9581_status
 include_feature nv07943                         status=build_9581_status
 include_feature nv07963                         status=build_9581_status
 include_feature nv08036                         status=build_9581_status
 include_feature nv08043                         status=build_9581_status
 include_feature nv0p898                         status=build_9581_status
 include_feature nv0q194                         status=build_9581_status
 include_feature nv0s677                         status=build_9581_status
 include_feature nv0u057                         status=build_9581_status
 include_feature nv0u195                         status=build_9581_status
 include_feature nv0u299                         status=build_9581_status
 include_feature nv0u305                         status=build_9581_status
 include_feature nv0u312                         status=build_9581_status
 include_feature nv0u364                         status=build_9581_status
 include_feature nv0u405                         status=build_9581_status
 include_feature nv0u445                         status=build_9581_status
 include_feature nv0u481                         status=build_9581_status
 include_feature nv0u502                         status=build_9581_status
 include_feature nv0u525                         status=build_9581_status
 include_feature nv0u527                         status=build_9581_status
 include_feature nv0u529                         status=build_9581_status
 include_feature nv0u550                         status=build_9581_status
 include_feature nv0u578                         status=build_9581_status
 include_feature nv0u580                         status=build_9581_status
 include_feature nv0u607                         status=build_9581_status
 include_feature nv0u613                         status=build_9581_status
 include_feature nvtb140                         status=build_9581_status
 include_feature queue_file_compatibility_ph2    status=build_9581_status
 include_feature reduce_apd_task_private_usage   status=build_9581_status
 include_feature sc80322_os                      status=build_9581_status
 include_feature sc8a744_os                      status=build_9581_status
 include_feature tape_interface_improvements_a   status=build_9581_status
*DECK DECK=BUILD_9583 EXPAND=TRUE
*IF bev$product_level = 'BUILD_9506 '
*copyc BUILD_9506
*IFEND
*copyc BUILD_9581
IF $variable(build_9583_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_9583_status kind=status
IFEND
 include_feature express_link_2                  status=build_9583_status
 include_feature fix_nfs                         status=build_9583_status
 include_feature generic_queues_10               status=build_9583_status
 include_feature mauve_ms_class                  status=build_9583_status
 include_feature mve_multiple_mta_a              status=build_9583_status
 include_feature network_queueing_system_os      status=build_9583_status
 include_feature nv07954_r153                    status=build_9583_status
 include_feature nv0u596                         status=build_9583_status
 include_feature nv0u599                         status=build_9583_status
 include_feature nv0u613                         status=build_9583_status
 include_feature nv0u618                         status=build_9583_status
 include_feature nv0u624                         status=build_9583_status
 include_feature nv0u625                         status=build_9583_status
 include_feature nv0u628                         status=build_9583_status
 include_feature theta_e_support_13              status=build_9583_status
 include_feature rms_av_support                  status=build_9583_status
*DECK DECK=BUILD_9585 EXPAND=TRUE
*IF bev$product_level = 'BUILD_9513 '
*copyc BUILD_9513
*IFEND
IF $variable(build_9585_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_9585_status kind=status
IFEND
 include_feature fulb_listing_to_pf              status=build_9585_status
 include_feature network_queueing_system_os      status=build_9585_status
 include_feature add_edid_stats_to_entbe         status=build_9585_status
 include_feature auto_reconfiguration_ofm_code   status=build_9585_status
 include_feature batch_output_filters_p2         status=build_9585_status
 include_feature batch_output_filters_p2_jm      status=build_9585_status
 include_feature batch_output_filters_p2_jm_a    status=build_9585_status
 include_feature cartridge_tape_support_silo_6   status=build_9585_status
 include_feature cleanup_df_loopback_id_deck     status=build_9585_status
 include_feature df_add_server_loopback_id       status=build_9585_status
 include_feature fix_substring_locations_genhm   status=build_9585_status
 include_feature generic_queues                  status=build_9585_status
 include_feature generic_queues_1                status=build_9585_status
 include_feature generic_queues_2                status=build_9585_status
 include_feature generic_queues_3                status=build_9585_status
 include_feature generic_queues_4                status=build_9585_status
 include_feature generic_queues_5                status=build_9585_status
 include_feature generic_queues_6                status=build_9585_status
 include_feature generic_queues_7                status=build_9585_status
 include_feature generic_queues_8                status=build_9585_status
 include_feature generic_queues_9                status=build_9585_status
 include_feature generic_queues_10               status=build_9585_status
 include_feature list_function_enhancements      status=build_9585_status
 include_feature memory_link_speedup             status=build_9585_status
 include_feature mve_multiple_mta_a              status=build_9585_status
 include_feature nv05445                         status=build_9585_status
 include_feature nv05445_a                       status=build_9585_status
 include_feature nv05445_b                       status=build_9585_status
 include_feature nv05766                         status=build_9585_status
 include_feature nv05812                         status=build_9585_status
 include_feature nv06947                         status=build_9585_status
 include_feature nv07146                         status=build_9585_status
 include_feature nv07162                         status=build_9585_status
 include_feature nv07162a                        status=build_9585_status
 include_feature nv07189                         status=build_9585_status
 include_feature nv07205                         status=build_9585_status
 include_feature nv07245_os3                     status=build_9585_status
 include_feature nv07311                         status=build_9585_status
 include_feature nv07386                         status=build_9585_status
 include_feature nv07473                         status=build_9585_status
 include_feature nv07548                         status=build_9585_status
 include_feature nv07555                         status=build_9585_status
 include_feature nv07590                         status=build_9585_status
 include_feature nv07597                         status=build_9585_status
 include_feature nv07599                         status=build_9585_status
 include_feature nv07649                         status=build_9585_status
 include_feature nv07703                         status=build_9585_status
 include_feature nv07712                         status=build_9585_status
 include_feature nv07900                         status=build_9585_status
 include_feature nv07916                         status=build_9585_status
 include_feature nv07943                         status=build_9585_status
 include_feature nv07963                         status=build_9585_status
 include_feature nv08036                         status=build_9585_status
 include_feature nv08043                         status=build_9585_status
 include_feature nv0p898                         status=build_9585_status
 include_feature nv0q194                         status=build_9585_status
 include_feature nv0q659                         status=build_9585_status
 include_feature nv0s677                         status=build_9585_status
 include_feature nv0t631a                        status=build_9585_status
 include_feature nv0t644                         status=build_9585_status
 include_feature nv0u057                         status=build_9585_status
 include_feature nv0u195                         status=build_9585_status
 include_feature nv0u279                         status=build_9585_status
 include_feature nv0u299                         status=build_9585_status
 include_feature nv0u305                         status=build_9585_status
 include_feature nv0u312                         status=build_9585_status
 include_feature nv0u332                         status=build_9585_status
 include_feature nv0u364                         status=build_9585_status
 include_feature nv0u445                         status=build_9585_status
 include_feature nv0u502                         status=build_9585_status
 include_feature nv0u525                         status=build_9585_status
 include_feature nv0u529                         status=build_9585_status
 include_feature nv0u532                         status=build_9585_status
 include_feature nv0u541                         status=build_9585_status
 include_feature nv0u550                         status=build_9585_status
 include_feature nv0u572                         status=build_9585_status
 include_feature nv0u578                         status=build_9585_status
 include_feature nv0u580                         status=build_9585_status
 include_feature nv0u590                         status=build_9585_status
 include_feature nvtb140                         status=build_9585_status
 include_feature orasrv_application              status=build_9585_status
 include_feature queue_file_compatibility_ph2    status=build_9585_status
 include_feature reduce_apd_task_private_usage   status=build_9585_status
 include_feature rms_av_support                  status=build_9585_status
 include_feature tape_interface_improvements_a   status=build_9585_status
*DECK DECK=BUILD_9587 EXPAND=TRUE
*IF bev$product_level = 'BUILD_9513 '
*copyc BUILD_9513
*IFEND
*copyc BUILD_9585
IF $variable(build_9587_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_9587_status kind=status
IFEND
 include_feature cartridge_tape_support_silo_2   status=build_9587_status
 include_feature cartridge_tape_support_silo_3   status=build_9587_status
 include_feature cartridge_tape_support_silo_5   status=build_9587_status
 include_feature command_level_cond_handling     status=build_9587_status
 include_feature command_lvl_cond_handling_anad  status=build_9587_status
 include_feature delete_unused_dm_decks          status=build_9587_status
 include_feature dft0041                         status=build_9587_status
 include_feature dft0044                         status=build_9587_status
 include_feature df_pause_break_support          status=build_9587_status
 include_feature df_pause_break_support_test     status=build_9587_status
 include_feature generic_queues_11               status=build_9587_status
 include_feature nv04992                         status=build_9587_status
 include_feature nv05375                         status=build_9587_status
 include_feature nv07428                         status=build_9587_status
 include_feature nv07814                         status=build_9587_status
 include_feature nv07922                         status=build_9587_status
 include_feature nv07968                         status=build_9587_status
 include_feature nv08087                         status=build_9587_status
 include_feature nv08141                         status=build_9587_status
 include_feature nv08145                         status=build_9587_status
 include_feature nv08180                         status=build_9587_status
 include_feature nv0s003                         status=build_9587_status
 include_feature nv0u092                         status=build_9587_status
 include_feature nv0u511                         status=build_9587_status
 include_feature nv0u511_a                       status=build_9587_status
 include_feature nv0u537                         status=build_9587_status
 include_feature nv0u561                         status=build_9587_status
 include_feature nv0u646                         status=build_9587_status
 include_feature nv0u653                         status=build_9587_status
 include_feature nv0u655                         status=build_9587_status
 include_feature nv0u660                         status=build_9587_status
 include_feature nv0u666                         status=build_9587_status
 include_feature nv0u669                         status=build_9587_status
 include_feature reorganize_env_objects          status=build_9587_status
 include_feature reorganize_env_objects_2        status=build_9587_status
 include_feature restore_list_of_file            status=build_9587_status
 include_feature sc80322_os                      status=build_9587_status
 include_feature sc8a744_os                      status=build_9587_status
 include_feature system_operator_utility_18      status=build_9587_status
 include_feature theta_e_set_lock_2              status=build_9587_status
 include_feature update_streamtest_os            status=build_9587_status
 include_feature uri_atap_scfsve                 status=build_9587_status
 include_feature vfs_os                          status=build_9587_status
 include_feature uri_atap_scfsve_2               status=build_9587_status
 include_feature reorganize_env_objects_3        status=build_9587_status
 include_feature cmml_2000_vector_code_2         status=build_9587_status
 include_feature cmml_2000_vector_code           status=build_9587_status
 include_feature catalog_name_security           status=build_9587_status
*DECK DECK=BUILD_9588 EXPAND=TRUE
*IF bev$product_level = 'BUILD_9513 '
*copyc BUILD_9513
*IFEND
*copyc BUILD_9587
IF $variable(build_9588_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_9588_status kind=status
IFEND
 include_feature list_function_enhancements_2    status=build_9588_status
 include_feature nv0u679                         status=build_9588_status
 include_feature nv0u680                         status=build_9588_status
*DECK DECK=BUILD_9589 EXPAND=TRUE
*IF bev$product_level = 'BUILD_9513 '
*copyc BUILD_9513
*IFEND
*copyc BUILD_9588
IF $variable(build_9589_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_9589_status kind=status
IFEND
 include_feature nv06740                         status=build_9589_status
 include_feature clsh_stornet_config_chng_091290 status=build_9589_status
 include_feature nv08137                         status=build_9589_status
 include_feature nv08193                         status=build_9589_status
 include_feature nv08193_2                       status=build_9589_status
 include_feature nv08194                         status=build_9589_status
 include_feature nv08256                         status=build_9589_status
 include_feature nv0s873                         status=build_9589_status
 include_feature nv0u587                         status=build_9589_status
 include_feature nv0u695                         status=build_9589_status
 include_feature nv0u695a                        status=build_9589_status
 include_feature nv0u708                         status=build_9589_status
 include_feature nv0u721                         status=build_9589_status
 include_feature nv0u728                         status=build_9589_status
 include_feature nv0u731                         status=build_9589_status
 include_feature nv0u732                         status=build_9589_status
 include_feature nv0u737                         status=build_9589_status
 include_feature nv0u756                         status=build_9589_status
 include_feature anad_changes_for_l762           status=build_9589_status
 include_feature ar2a203                         status=build_9589_status
 include_feature command_level_cond_handling_2   status=build_9589_status
 include_feature dfta158                         status=build_9589_status
 include_feature display_fmd                     status=build_9589_status
 include_feature network_archiving_1             status=build_9589_status
 include_feature nv07272                         status=build_9589_status
 include_feature nv07298                         status=build_9589_status
 include_feature nv07752                         status=build_9589_status
 include_feature nv08022                         status=build_9589_status
 include_feature nv08143                         status=build_9589_status
 include_feature nv08155                         status=build_9589_status
 include_feature nv08217                         status=build_9589_status
 include_feature nv08219                         status=build_9589_status
 include_feature nv08220                         status=build_9589_status
 include_feature nv08232                         status=build_9589_status
 include_feature nv08235                         status=build_9589_status
 include_feature nv0u386                         status=build_9589_status
 include_feature nv0u446                         status=build_9589_status
 include_feature nv0u475                         status=build_9589_status
 include_feature nv0u642                         status=build_9589_status
 include_feature nv0u652                         status=build_9589_status
 include_feature nv0u670                         status=build_9589_status
 include_feature nv0u672                         status=build_9589_status
 include_feature nv0u687                         status=build_9589_status
 include_feature nv0u705                         status=build_9589_status
 include_feature nv0u717                         status=build_9589_status
 include_feature nv0u724                         status=build_9589_status
 include_feature nv0u730                         status=build_9589_status
 include_feature nv0u735                         status=build_9589_status
 include_feature nv0u736                         status=build_9589_status
 include_feature nv0u739                         status=build_9589_status
 include_feature nv0u743                         status=build_9589_status
 include_feature nv0u753                         status=build_9589_status
 include_feature rms0002                         status=build_9589_status
 include_feature rms0002_2                       status=build_9589_status
 include_feature theta_e_negative_sit            status=build_9589_status
*DECK DECK=BUILD_9599 EXPAND=TRUE
*IF bev$product_level = 'BUILD_9512 '
*copyc BUILD_9512
*IFEND
*DECK DECK=BUILD_A101 EXPAND=TRUE
*copyc BUILD_A102
*IF bev$product_level = 'BUILD_A101'
*copyc cycleA1_exceptions
*ELSE
*copyc BUILD_A101_contents
*IFEND
*DECK DECK=BUILD_A101_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A101_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A101_STATUS kind=status
IFEND
 exclude_feature add_edid_stats_to_entbe         status=BUILD_A101_STATUS
 exclude_feature anad_changes_for_l762           status=BUILD_A101_STATUS
 exclude_feature ar2a203                         status=BUILD_A101_STATUS
 exclude_feature auto_reconfiguration_ofm_code   status=BUILD_A101_STATUS
 exclude_feature batch_output_filters_p2         status=BUILD_A101_STATUS
 exclude_feature batch_output_filters_p2_jm      status=BUILD_A101_STATUS
 exclude_feature batch_output_filters_p2_jm_a    status=BUILD_A101_STATUS
 exclude_feature cartridge_tape_support_silo_2   status=BUILD_A101_STATUS
 exclude_feature cartridge_tape_support_silo_3   status=BUILD_A101_STATUS
 exclude_feature cartridge_tape_support_silo_5   status=BUILD_A101_STATUS
 exclude_feature cartridge_tape_support_silo_6   status=BUILD_A101_STATUS
 exclude_feature catalog_name_security           status=BUILD_A101_STATUS
 exclude_feature cleanup_df_loopback_id_deck     status=BUILD_A101_STATUS
 exclude_feature cmml_2000_vector_code           status=BUILD_A101_STATUS
 exclude_feature cmml_2000_vector_code_2         status=BUILD_A101_STATUS
 exclude_feature command_level_cond_handling     status=BUILD_A101_STATUS
 exclude_feature command_level_cond_handling_2   status=BUILD_A101_STATUS
 exclude_feature command_lvl_cond_handling_anad  status=BUILD_A101_STATUS
 exclude_feature delete_unused_dm_decks          status=BUILD_A101_STATUS
 exclude_feature df_add_server_loopback_id       status=BUILD_A101_STATUS
 exclude_feature df_pause_break_support          status=BUILD_A101_STATUS
 exclude_feature df_pause_break_support_test     status=BUILD_A101_STATUS
 exclude_feature dft0041                         status=BUILD_A101_STATUS
 exclude_feature dft0044                         status=BUILD_A101_STATUS
 exclude_feature dfta158                         status=BUILD_A101_STATUS
 exclude_feature display_fmd                     status=BUILD_A101_STATUS
 exclude_feature fix_substring_locations_genhm   status=BUILD_A101_STATUS
 exclude_feature fix_pi_for_9589                 status=BUILD_A101_STATUS
 exclude_feature generic_queues                  status=BUILD_A101_STATUS
 exclude_feature generic_queues_1                status=BUILD_A101_STATUS
 exclude_feature generic_queues_2                status=BUILD_A101_STATUS
 exclude_feature generic_queues_3                status=BUILD_A101_STATUS
 exclude_feature generic_queues_4                status=BUILD_A101_STATUS
 exclude_feature generic_queues_5                status=BUILD_A101_STATUS
 exclude_feature generic_queues_6                status=BUILD_A101_STATUS
 exclude_feature generic_queues_7                status=BUILD_A101_STATUS
 exclude_feature generic_queues_8                status=BUILD_A101_STATUS
 exclude_feature generic_queues_9                status=BUILD_A101_STATUS
 exclude_feature generic_queues_10               status=BUILD_A101_STATUS
 exclude_feature generic_queues_11               status=BUILD_A101_STATUS
 exclude_feature list_function_enhancements      status=BUILD_A101_STATUS
 exclude_feature list_function_enhancements_2    status=BUILD_A101_STATUS
 exclude_feature memory_link_speedup             status=BUILD_A101_STATUS
 exclude_feature mve_multiple_mta_a              status=BUILD_A101_STATUS
 exclude_feature network_archiving_1             status=BUILD_A101_STATUS
 exclude_feature network_queueing_system_os      status=BUILD_A101_STATUS
 exclude_feature nv04992                         status=BUILD_A101_STATUS
 exclude_feature nv05445                         status=BUILD_A101_STATUS
 exclude_feature nv05445_a                       status=BUILD_A101_STATUS
 exclude_feature nv05445_b                       status=BUILD_A101_STATUS
 exclude_feature nv05766                         status=BUILD_A101_STATUS
 exclude_feature nv05812                         status=BUILD_A101_STATUS
 exclude_feature nv06947                         status=BUILD_A101_STATUS
 exclude_feature nv07146                         status=BUILD_A101_STATUS
 exclude_feature nv07162                         status=BUILD_A101_STATUS
 exclude_feature nv07162a                        status=BUILD_A101_STATUS
 exclude_feature nv07189                         status=BUILD_A101_STATUS
 exclude_feature nv07245_os3                     status=BUILD_A101_STATUS
 exclude_feature nv07272                         status=BUILD_A101_STATUS
 exclude_feature nv07298                         status=BUILD_A101_STATUS
 exclude_feature nv07311                         status=BUILD_A101_STATUS
 exclude_feature nv07386                         status=BUILD_A101_STATUS
 exclude_feature nv07428                         status=BUILD_A101_STATUS
 exclude_feature nv07473                         status=BUILD_A101_STATUS
 exclude_feature nv07548                         status=BUILD_A101_STATUS
 exclude_feature nv07555                         status=BUILD_A101_STATUS
 exclude_feature nv07590                         status=BUILD_A101_STATUS
 exclude_feature nv07597                         status=BUILD_A101_STATUS
 exclude_feature nv07599                         status=BUILD_A101_STATUS
 exclude_feature nv07649                         status=BUILD_A101_STATUS
 exclude_feature nv07703                         status=BUILD_A101_STATUS
 exclude_feature nv07712                         status=BUILD_A101_STATUS
 exclude_feature nv07752                         status=BUILD_A101_STATUS
 exclude_feature nv07900                         status=BUILD_A101_STATUS
 exclude_feature nv07916                         status=BUILD_A101_STATUS
 exclude_feature nv07943                         status=BUILD_A101_STATUS
 exclude_feature nv07963                         status=BUILD_A101_STATUS
 exclude_feature nv07968                         status=BUILD_A101_STATUS
 exclude_feature nv08022                         status=BUILD_A101_STATUS
 exclude_feature nv08036                         status=BUILD_A101_STATUS
 exclude_feature nv08043                         status=BUILD_A101_STATUS
 exclude_feature nv08143                         status=BUILD_A101_STATUS
 exclude_feature nv08155                         status=BUILD_A101_STATUS
 exclude_feature nv08217                         status=BUILD_A101_STATUS
 exclude_feature nv08219                         status=BUILD_A101_STATUS
 exclude_feature nv08220                         status=BUILD_A101_STATUS
 exclude_feature nv08232                         status=BUILD_A101_STATUS
 exclude_feature nv08235                         status=BUILD_A101_STATUS
 exclude_feature nv08256                         status=BUILD_A101_STATUS
 exclude_feature nv0p898                         status=BUILD_A101_STATUS
 exclude_feature nv0q194                         status=BUILD_A101_STATUS
 exclude_feature nv0q659                         status=BUILD_A101_STATUS
 exclude_feature nv0s003                         status=BUILD_A101_STATUS
 exclude_feature nv0s677                         status=BUILD_A101_STATUS
 exclude_feature nv0t631a                        status=BUILD_A101_STATUS
 exclude_feature nv0t644                         status=BUILD_A101_STATUS
 exclude_feature nv0u057                         status=BUILD_A101_STATUS
 exclude_feature nv0u092                         status=BUILD_A101_STATUS
 exclude_feature nv0u195                         status=BUILD_A101_STATUS
 exclude_feature nv0u279                         status=BUILD_A101_STATUS
 exclude_feature nv0u299                         status=BUILD_A101_STATUS
 exclude_feature nv0u305                         status=BUILD_A101_STATUS
 exclude_feature nv0u312                         status=BUILD_A101_STATUS
 exclude_feature nv0u332                         status=BUILD_A101_STATUS
 exclude_feature nv0u364                         status=BUILD_A101_STATUS
 exclude_feature nv0u386                         status=BUILD_A101_STATUS
 exclude_feature nv0u445                         status=BUILD_A101_STATUS
 exclude_feature nv0u446                         status=BUILD_A101_STATUS
 exclude_feature nv0u475                         status=BUILD_A101_STATUS
 exclude_feature nv0u502                         status=BUILD_A101_STATUS
 exclude_feature nv0u511                         status=BUILD_A101_STATUS
 exclude_feature nv0u511_a                       status=BUILD_A101_STATUS
 exclude_feature nv0u525                         status=BUILD_A101_STATUS
 exclude_feature nv0u529                         status=BUILD_A101_STATUS
 exclude_feature nv0u532                         status=BUILD_A101_STATUS
 exclude_feature nv0u537                         status=BUILD_A101_STATUS
 exclude_feature nv0u541                         status=BUILD_A101_STATUS
 exclude_feature nv0u550                         status=BUILD_A101_STATUS
 exclude_feature nv0u572                         status=BUILD_A101_STATUS
 exclude_feature nv0u578                         status=BUILD_A101_STATUS
 exclude_feature nv0u580                         status=BUILD_A101_STATUS
 exclude_feature nv0u642                         status=BUILD_A101_STATUS
 exclude_feature nv0u652                         status=BUILD_A101_STATUS
 exclude_feature nv0u669                         status=BUILD_A101_STATUS
 exclude_feature nv0u670                         status=BUILD_A101_STATUS
 exclude_feature nv0u672                         status=BUILD_A101_STATUS
 exclude_feature nv0u687                         status=BUILD_A101_STATUS
 exclude_feature nv0u705                         status=BUILD_A101_STATUS
 exclude_feature nv0u717                         status=BUILD_A101_STATUS
 exclude_feature nv0u724                         status=BUILD_A101_STATUS
 exclude_feature nv0u730                         status=BUILD_A101_STATUS
 exclude_feature nv0u735                         status=BUILD_A101_STATUS
 exclude_feature nv0u736                         status=BUILD_A101_STATUS
 exclude_feature nv0u739                         status=BUILD_A101_STATUS
 exclude_feature nv0u743                         status=BUILD_A101_STATUS
 exclude_feature nv0u753                         status=BUILD_A101_STATUS
 exclude_feature nvtb140                         status=BUILD_A101_STATUS
 exclude_feature orasrv_application              status=BUILD_A101_STATUS
 exclude_feature queue_file_compatibility_ph2    status=BUILD_A101_STATUS
 exclude_feature reduce_apd_task_private_usage   status=BUILD_A101_STATUS
 exclude_feature reorganize_env_objects          status=BUILD_A101_STATUS
 exclude_feature reorganize_env_objects_2        status=BUILD_A101_STATUS
 exclude_feature reorganize_env_objects_3        status=BUILD_A101_STATUS
 exclude_feature restore_list_of_file            status=BUILD_A101_STATUS
 exclude_feature rms0002                         status=BUILD_A101_STATUS
 exclude_feature rms0002_2                       status=BUILD_A101_STATUS
 exclude_feature rms_av_support                  status=BUILD_A101_STATUS
 exclude_feature sc80322_os                      status=BUILD_A101_STATUS
 exclude_feature sc8a744_os                      status=BUILD_A101_STATUS
 exclude_feature system_operator_utility_18      status=BUILD_A101_STATUS
 exclude_feature tape_interface_improvements_a   status=BUILD_A101_STATUS
 exclude_feature theta_e_negative_sit            status=BUILD_A101_STATUS
 exclude_feature theta_e_set_lock_2              status=BUILD_A101_STATUS
 exclude_feature uri_atap_scfsve                 status=BUILD_A101_STATUS
 exclude_feature uri_atap_scfsve_2               status=BUILD_A101_STATUS
 exclude_feature vfs_os                          status=BUILD_A101_STATUS
 exclude_feature close_pi_for_9581               status=BUILD_A101_STATUS
 exclude_feature mv2a821                         status=BUILD_A101_STATUS
*DECK DECK=BUILD_A101_NEW_DECKS EXPAND=TRUE
*copyc BUILD_A102_NEW_DECKS
*IF bev$product_level = 'BUILD_A101_NEW_DECKS'
*copyc cycleA1_exceptions
*ELSE
*copyc BUILD_A101_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_A101_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A101_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A101_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck AVE$TEMPLATE_FILE_DAMAGED         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck AVH$CALCULATE_APPLICATION_SRUS    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck AVH$VALIDATE_NQS_USER             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck AVH$VERIFY_TEMPLATE_HEAP          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck AVP$CALCULATE_APPLICATION_SRUS    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck AVP$VALIDATE_NQS_USER             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck AVP$VERIFY_TEMPLATE_HEAP          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLC$EXITING_CONDITION             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLC$MAX_ESTABLISHED_HANDLERS      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLH$PROCESS_WHEN_COND_IN_TASK     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLH$SCL_SIGNAL_HANDLER            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLM$NUMERIC_OPERATIONS            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLM$SCL_SIGNAL_HANDLER            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$DETERMINE_SELECT_RESULT_TYP   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$DETERMINE_WHEN_CONDITION      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$ENVIRONMENT_OBJECT_IN_BLOCK   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$ENVIRONMENT_OBJECT_NAME       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_INIT_COMMAND_LIST          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_INIT_FILE_CONNECTIONS      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_INIT_SCL_OPTIONS           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_INIT_UNSEEN_MAIL_ACTION    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_INIT_WORKING_CATALOG       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_POP_COMMAND_LIST           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_POP_FILE_CONNECTIONS       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_POP_UNSEEN_MAIL_ACTION     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_POP_WORKING_CATALOG        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_PUSH_COMMAND_LIST          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_PUSH_FILE_CONNECTIONS      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_PUSH_WORKING_CATALOG       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_SIZE_COMMAND_LIST          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_SIZE_FILE_CONNECTIONS      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_SIZE_SCL_OPTIONS           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_SIZE_UNSEEN_MAIL_ACTION    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_SIZE_WORKING_CATALOG       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_UPDT_COMMAND_LIST          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EO_UPDT_UNSEEN_MAIL_ACTION    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$EXECUTION_FAULT_HANDLER_EST   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$FIND_ENVIRONMENT_OBJECT       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$FIND_ENV_OBJECT_FIRST_TIME    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$FIND_SCL_OPTIONS              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$FREE_ALL_HANDLERS             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$FREE_ALL_HANDLERS_IN_BLOCK    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$INIT_ALL_ENVIRONMENT          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$INTEGER_COMPARE               status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$MAKE_CHAR_VALUE               status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$MAKE_TRIMMED_STRING_VALUE     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$NUMBER_COMPARE                status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$PERFORM_NUMERIC_OPERATION     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$POP_ALL_ENVIRONMENT           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$PREPROCESS_COMMAND_LINE       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$PROCESS_COMMAND_FAULT         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$PROCESS_CONTINUED_CONDITION   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$PROCESS_EXECUTION_FAULT       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$PROCESS_EXIT_CONDITION        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$PROCESS_WHEN_COND_IN_BLOCK    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$PROCESS_WHEN_COND_IN_TASK     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$PUSH_ALL_ENVIRONMENT          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$SCL_SIGNAL_HANDLER            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$SEND_EXITING_SIGNAL           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$SORT_RECORD_FIELDS            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$STRING_COMPARE                status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLP$UPDATE_ALL_ENVIRONMENT        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$CONDITION_PROCESSED_STATE     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$ENVIRONMENT_OBJECT_CONTENTS   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$ENVIRONMENT_OBJECT_INFO       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$ENVIRONMENT_OBJECT_LOCATION   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$ENVIRONMENT_OBJECT_ORDINAL    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$ENVIRONMENT_OBJECT_SIZE       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$ENV_OBJECT_POP_REASON         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$ENV_OBJECT_PUSH_REASON        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$ESTABLISHED_HANDLER           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$ESTABLISHED_HANDLERS          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$ESTABLISHED_HANDLER_COUNT     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$ESTABLISHED_HANDLER_INDEX     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$ESTABLISHED_HANDLER_INFO      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$ESTABLISHED_HANDLER_STMNTS    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$SCL_SIGNAL                    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$SCL_SIGNAL_CONTENTS           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$SCL_SIGNAL_KIND               status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$WHEN_CONDITION                status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$WHEN_CONDITION_DEFINITION     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLT$WHEN_CONDITION_DESCRIPTOR     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CLV$ENVIRONMENT_OBJECT_LOCATION   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CML$5744_LIBRARY_FAILURE_ERROR    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck CMT$ELEMENT_STATES                status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck DFC$CLIENT_PAUSE_BREAK            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck DFC$LOOPBACK_SERVER_CONSTANTS     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck DMT$INITIALIZE_TAPE_VOLUME        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck DMV$JOB_TAPE_TABLE_LOCK           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck DMV$TAPE_JOB_LUN_TABLE_P          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck DUM$DISPLAY_ALTERNATE_IOU_CONF    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck DUM$DISPLAY_ALTERNATE_IOU_EC      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck DUM$DISPLAY_B_AND_C_REGISTERS     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck DUM$DISPLAY_ENVIRONMENT_CONTROL   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck DUM$DISPLAY_FAULT_STATUS_MASK     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck DUM$DISPLAY_PC_CONSOLE_INFO       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck DUM$DISPLAY_PHYSICAL_FMD          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck DUM$DISPLAY_STORED_FMD            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck DUP$DISPLAY_REGISTER_DATA         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck FDC$DECIMAL_CURRENCY_SYMBOL       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck FDC$DOLLAR_CURRENCY_SYMBOL        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck FDC$POUND_CURRENCY_SYMBOL         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck FDC$THOUSANDS_CURRENCY_SYMBOL     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck FDE$FORTRAN_STATUS                status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck FDE$FORTRAN_VARIABLE_STATUS       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck FDH$CHANGE_CURRENCY_SYMBOLS       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck FDP$CHANGE_CURRENCY_SYMBOLS       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck FDT$COBOL_CURRENCY_SYMBOLS        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck FDV$COBOL_CURRENCY_SYMBOLS        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IFH$GET_NETWORK_IDENTIFIER        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IFM$GET_NETWORK_IDENTIFIER        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IFM$INTERACTIVE_COMMANDS          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IFP$GET_NETWORK_IDENTIFIER        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IFT$NETWORK_IDENTIFIER            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOC$MAX_SERVER_INDEX              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOC$MAX_TASKS_PER_SERVER          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$ASSIGN_TAPE_UNIT              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$CLIENT_CANCEL_REQUEST         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$CLIENT_DELETE_REQUEST         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$CLIENT_GET_RESPONSE           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$CLIENT_PUT_REQUEST            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$DEFINE_ROBOTIC_SERVER         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$GET_DENSITY_STATES            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$GET_SELECTED_ELEMENT          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$GET_SERVER_ENTRY              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$QUEUE_VOLUME_ASSIGNMENT       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$READY_WAITING_TAPE_TASKS      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$RECORD_ROBOTIC_ASSIGNMENT     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$RELEASE_TAPE_UNIT             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$REMOVE_ROBOTIC_SERVER         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$SELECT_BEST_ELEMENT           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$SERVER_GET_REQUEST            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$SERVER_PUT_RESPONSE           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOP$VALIDATE_CANDIDATE_ELEMENT    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOT$CONDITIONAL_SERVER_MESSAGE    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOT$DENSITY_STATES                status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOT$FORMATTED_SERVER_RESPONSE     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOT$MANAGED_DENSITIES             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOT$REQUESTED_SERVER_MESSAGES     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOT$ROBOTIC_COMMUNICATION         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOT$ROBOTIC_SERVER_ATTRIBUTES     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOT$ROBOTIC_SERVER_ENTRY          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOT$ROBOTIC_SERVER_INDEX          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOT$ROBOTIC_SERVER_MESSAGES       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck IOT$SERVER_MESSAGE_TYPE           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMC$GENERIC_QUEUE_FULL_MESSAGE    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMC$MAXIMUM_QFILE_APPLICATIONS    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMC$MAXIMUM_QFILE_COUNT           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$APPLICATION_NAME_INCORRECT    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$APPLICATION_NAME_IN_USE       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$GENERIC_QUEUE_IS_EMPTY        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$INVALID_DESTINATION           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$INVALID_RHD                   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$LATEST_RUN_TIME_EXPIRED       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$MAXIMUM_GENERIC_QFILES        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$NO_QFILES_WERE_FOUND          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$QFILE_ALREADY_TERMINATED      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$QFILE_APPL_NOT_PERMITTED      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$QFILE_CANNOT_INITIATE         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$QFILE_IS_INITIATED            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$QFILE_IS_TERMINATED           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$QFILE_STATE_IS_NULL           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$QFILE_WAS_NOT_RECOVERED       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$QFILE_WAS_RECOVERED           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$READ_QFILE_SYSTEM_LABEL       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$SYSTEM_LABEL_INTERNAL_ERROR   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$UNLIMITED_TIMEOUT_MESSAGE     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JME$WRITE_QFILE_SYSTEM_LABEL      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$ACQUIRE_MODIFIED_QFILE        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$ACQUIRE_NEW_QFILE             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$CHANGE_QFILE_ATTRIBUTES       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$CLOSE_QFILE                   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$GET_QFILE_ATTRIBUTES          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$GET_QFILE_ATTRIBUTES_SIZE     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$GET_QFILE_STATUS              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$GET_QFILE_STATUS_SIZE         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$MODIFIED_QFILE_EXISTS         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$NEW_QFILE_EXISTS              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$OPEN_QFILE                    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$PURGE_EXPIRED_QUEUE_FILE      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$PURGE_PROCESSED_QUEUE_FILE    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$REBUILD_GENERIC_QUEUE         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$REGISTER_QFILE_APPLICATION    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$RELEASE_GENERIC_QUEUE_FILES   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$SET_QFILE_COMPLETED           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$SET_QFILE_INITIATED           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$SUBMIT_QFILE                  status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$TERMINATED_QFILE_EXISTS       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$TERMINATE_ACQUIRED_QFILE      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$TERMINATE_QFILE               status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMH$UPDATE_QFILE_STATUS           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMM$GENERIC_QUEUE_FILE_MANAGER    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMM$MANAGE_QUEUE_FILE_UTILITY     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMM$MANAGE_QUEUE_FILE_UTIL_PD     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$ACQUIRE_MODIFIED_QFILE        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$ACQUIRE_NEW_QFILE             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$CHANGE_QFILE_ATTRIBUTES       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$CLOSE_QFILE                   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$DECREMENT_LW_THRESHOLD        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$GET_JM_WORK_AREA              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$GET_QFILE_ATTRIBUTES          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$GET_QFILE_ATTRIBUTES_SIZE     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$GET_QFILE_STATUS              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$GET_QFILE_STATUS_SIZE         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$IDLE_ADVANCE_LW_JOBS          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$MODIFIED_QFILE_EXISTS         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$NEW_QFILE_EXISTS              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$OPEN_QFILE                    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$PURGE_EXPIRED_QUEUE_FILE      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$PURGE_PROCESSED_QUEUE_FILE    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$REBUILD_GENERIC_QUEUE         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$REGISTER_QFILE_APPLICATION    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$RELEASE_GENERIC_QUEUE_FILES   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$SET_QFILE_COMPLETED           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$SET_QFILE_INITIATED           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$SUBMIT_QFILE                  status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$TERMINATED_QFILE_EXISTS       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$TERMINATE_ACQUIRED_QFILE      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$TERMINATE_QFILE               status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMP$UPDATE_QFILE_STATUS           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$KNOWN_QFILE_LIST              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$KNOWN_QFILE_LIST_ENTRY        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$KQL_APPLICATION_STATE         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$KQL_ENTRY_KIND                status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$KQL_ENTRY_KIND_SET            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$KQL_INDEX                     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$LONG_WAIT_SWAP_THRESHOLD      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$LONG_WAIT_THINK_TIME          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_APPLICATION_ATTRS       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_APPLICATION_TABLE       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_ATTRIBUTE_CHANGES       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_ATTRIBUTE_COUNT         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_ATTRIBUTE_KEYS          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_ATTRIBUTE_OPTIONS       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_ATTRIBUTE_RESULTS       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_COUNT_RANGE             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_REGISTRATION_OPTIONS    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_STATE                   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_STATE_SET               status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_STATUS_COUNT            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_STATUS_OPTIONS          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_STATUS_RESULTS          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_STATUS_UPDATES          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_SUBMISSION_OPTIONS      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_SYSTEM_LABEL            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$QFILE_TERMINATION_OPTIONS     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$RERUN_DISPOSITION             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMT$SYSTEM_SUPPLIED_NAME_LIST     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMV$JOB_MANAGEMENT_WORK_AREA_P    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMV$KNOWN_QFILE_LIST              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMV$KQL_P                         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMV$LAST_USED_APPLICATION_INDEX   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMV$PURGE_EXPIRED_QFILE_TIME      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMV$PURGE_PROCESSED_QFILE_TIME    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMV$QFILE_RECOVERY_OPTION         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck JMV$READY_DEFERRED_QFILE_TIME     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck LGM$COMMON_PROCESSORS_R1          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck LGM$COMMON_PROCESSORS_R2          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck LGP$GET_GLOBAL_PREVIOUS_SIZE      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck LGP$GET_LOCAL_PREVIOUS_SIZE       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck LGP$GET_PREVIOUS_LOG_ENTRY_SIZE   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck MLP$UPDATE_JOB_STATE_TO_SIGN_ON   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck NFB$SCFS_PROTOCOL_SPECIFICATION   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck NFM$$BLOCK_TEXT                   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck NFM$$DEVICE_ATTRIBUTES            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck NFM$$WRAPPED_BLOCK_TEXT           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck NFM$BOF_PROGRAM_DESCRIPTIONS      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck NFM$CONTROL_ACCESS                status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck NFM$CREATE_T_RECORD_FILE          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck NFM$EMULATE_FORMAT_EFFECTORS      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck NFM$GENERATE_BANNER_PAGE          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck NFM$GENERATE_POSTSCRIPT_BANNER    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck NFM$MAIN_BATCH_OUTPUT_FILTER      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck NFM$PREPROCESS_POSTSCRIPT_FILE    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck NFT$DEVICE_ATTRIBUTES             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OFH$FORMAT_OPERATOR_MENU          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OFH$GET_MENU_HELP_TEXT            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OFH$GET_MENU_HELP_TEXT_R1         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OFH$GET_OPERATOR_MENU             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OFH$SEND_FORMATTED_OPERATOR_MSG   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OFH$STORE_MENU_HELP_TEXT          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OFP$FORMAT_OPERATOR_MENU          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OFP$FORMAT_OPERATOR_MESSAGE       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OFP$GET_MENU_HELP_TEXT            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OFP$GET_MENU_HELP_TEXT_R1         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OFP$SEND_FORMATTED_OPERATOR_MSG   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OFP$STORE_MENU_HELP_TEXT          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OFT$FORMATTED_OPERATOR_MESSAGE    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSC$MAX_SYSTEM_MESSAGE_MODULES    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSH$GET_FULL_HELP_MESSAGE         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSH$GET_HELP_MESSAGE              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSH$GET_PARAMETER_HELP_MESSAGE    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSH$GET_PARAMETER_PROMPT          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSM$DATE_TIME_MANAGEMENT          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSM$DATE_TIME_MANAGEMENT_113      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSM$MESSAGE_MODULE_POINTERS       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSP$CHANGE_BASE_SYSTEM_TIME       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSP$CHANGE_DATE_TIME              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSP$CHANGE_HARDWARE_DATE_TIME     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSP$CLEAR_DEFAULTS_CHANGED_FLAG   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSP$EO_INIT_INTERACTION_INFO      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSP$EO_INIT_MESSAGE_LEVEL         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSP$EO_INIT_NATURAL_LANGUAGE      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSP$EO_POP_NATURAL_LANGUAGE       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSP$EO_SIZE_INTERACTION_INFO      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSP$EO_SIZE_MESSAGE_LEVEL         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSP$EO_SIZE_NATURAL_LANGUAGE      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSP$GET_FULL_HELP_MESSAGE         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSP$GET_HELP_MESSAGE              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSP$GET_PARAMETER_HELP_MESSAGE    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSP$GET_PARAMETER_PROMPT          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSP$INITIALIZE_DATE_TIME          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSP$UPDATE_WAIT_FRC               status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OST$OS_DEFAULTS                   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OST$PARAMETER_HELP_NAMES          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSV$OS_DEFAULTS                   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck OSV$SYSTEM_MESSAGE_MODULES        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck PMP$EO_INIT_PROGRAM_ATTRIBUTES    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck PMP$EO_POP_PROGRAM_ATTRIBUTES     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck PMP$EO_PUSH_PROGRAM_ATTRIBUTES    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck PMP$EO_SIZE_PROGRAM_ATTRIBUTES    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck PUM$RESTORE_OBJECT                status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck PUP$RESTORE_SELECTED_OBJECTS      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck PUP$SET_OBJECT_ABNORMAL           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck PUT$SELECTED_OBJECT               status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$ACQUIRE_MODIFIED_QFILE        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$ACQUIRE_NEW_QFILE             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$CHANGE_QFILE_ATTRIBUTES       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$GET_QFILE_STATUS              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$PURGE_EXPIRED_QUEUE_FILE      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$PURGE_PROCESSED_QUEUE_FILE    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$READY_DEFERRED_QUEUE_FILE     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$READ_QFILE_SYSTEM_LABEL       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$REBUILD_GENERIC_QUEUE         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$REGISTER_QFILE_APPLICATION    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$RELEASE_GENERIC_QUEUE_FILES   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$SET_QFILE_COMPLETED           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$SET_QFILE_INITIATED           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$SUBMIT_QFILE                  status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$TERMINATE_ACQUIRED_QFILE      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$TERMINATE_QFILE               status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$VALIDATE_QFILE_ACCESS         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFH$WRITE_QFILE_SYSTEM_LABEL      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFM$GENERIC_QUEUE_FILE_MANAGER    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$ACQUIRE_MODIFIED_QFILE        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$ACQUIRE_NEW_QFILE             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$CHANGE_QFILE_ATTRIBUTES       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$GET_QFILE_STATUS              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$PURGE_EXPIRED_QUEUE_FILE      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$PURGE_PROCESSED_QUEUE_FILE    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$READY_DEFERRED_QUEUE_FILE     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$READ_QFILE_SYSTEM_LABEL       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$REBUILD_GENERIC_QUEUE         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$REGISTER_QFILE_APPLICATION    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$RELEASE_GENERIC_QUEUE_FILES   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$SET_QFILE_COMPLETED           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$SET_QFILE_INITIATED           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$SUBMIT_QFILE                  status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$TERMINATE_ACQUIRED_QFILE      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$TERMINATE_QFILE               status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$VALIDATE_QFILE_ACCESS         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFP$WRITE_QFILE_SYSTEM_LABEL      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFV$CURRENT_KQL_LIMIT             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck QFV$KQL_LOCK                      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RAM$DELETE_PTF_FOR_RHFAM          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RAP$DEFINE_ORASRV                 status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RAP$DEFINE_ORASRVS                status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RAP$DELETE_ORASRV                 status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RAP$DELETE_ORASRVS                status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RAP$INSTALL_MATH_LIBRARY          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RAP$MANAGE_QUEUE_FILE             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$ACTION_MESSAGES               status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$DEDICATED_MAINTENANCE         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$EXTEND_LABELED_VOL_LIST       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$EXTEND_UNLABELED_VOL_LIST     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$GENERIC_ERROR_RECOVERY        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$HELP_MODULE_SEED              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$HIGHEST_UNIT_TYPE             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$INCORRECT_RECORDED_VSN        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$JOB_STATUS_MESSAGES           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$LOADPOINT_ERROR_RECOVERY      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$MANUAL_TAPE_MAINTENANCE       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$MAXIMUM_DENSITY               status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$RBT_MAX_ATTRIBUTE             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$RBT_MAX_REQUEST_ID            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$RBT_MAX_REQUEST_TYPE          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$RBT_STATUS_MESSAGE_WIDTH      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$RESERVE_TAPE                  status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$ROBOTIC_ELEMENT_MONOPOLY      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$ROBOTIC_TAPE_MAINTENANCE      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$ROBOTIC_WRITE_DISABLED        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$WRITE_ERROR_RECOVERY          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMC$WRONG_LABEL_TYPE              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RME$ROBOTIC_INTERFACE_ERRORS      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMI$BLOCK_EXIT_HANDLER            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMM$MANAGE_CLIENT_VOLUMES_223     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMM$MANAGE_RESERVATIONS_223       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMM$RESOURCE_HELP_MESSAGES        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMM$ROBOTIC_INTERFACES_23D        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMM$ROBOTIC_INTERFACES_2DD        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMM$TABLES                        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMM$TAPE_SERVICES_223             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMM$TAPE_SERVICES_23D             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$ACTIVATE_VOLUME               status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$ASSIGN_TAPE_UNIT              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$CHANGE_TAPE_DEBUG_MODE_23D    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$CLEAR_EXPLICIT_RESERVE        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$CLEAR_IMPLICIT_RESERVE        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$CONVERT_DENSITY               status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$DEACTIVATE_VOLUME             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$DEFINE_ROBOTIC_SERVER         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$EMIT_OPERATOR_MESSAGE         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$EXTEND_VOLUME_LIST            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$GET_MEDIA_REQUEST_23D         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$GET_SELECTED_ELEMENT          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$LOG_DEBUG_INTEGER             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$LOG_DEBUG_MESSAGE             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$LOG_DEBUG_STATUS              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$PUT_JOB_STATUS_DISPLAY        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$RECOVER_JOB_TAPE_TABLE        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$RELEASE_RESOURCE_COMMAND      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$RELEASE_TAPE_UNIT             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$REMOVE_ROBOTIC_SERVER         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$RESERVE_RESOURCE_COMMAND      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$SERVER_GET_REQUEST            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$SERVER_GET_REQUEST_23D        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$SERVER_PUT_RESPONSE           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$SET_EXPLICIT_RESERVE          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMP$SET_IMPLICIT_RESERVE          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$JOB_TAPE_TABLE                status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$RBT_ATTRIBUTE_KEY             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$RBT_CONDITIONAL_MESSAGE       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$RBT_DISMOUNT_REQUEST          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$RBT_DISMOUNT_RESPONSE         status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$RBT_FORCE_DISMOUNT_REQUEST    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$RBT_FORCE_DISMOUNT_RESPONSE   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$RBT_MOUNT_REQUEST             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$RBT_MOUNT_RESPONSE            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$RBT_QUERY_REQUEST             status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$RBT_QUERY_RESPONSE            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$RBT_REQUEST                   status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$RBT_REQUEST_ID                status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$RBT_REQUEST_TYPE              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$RBT_SERVER_ATTRIBUTE          status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$RBT_SUPPORTED_REQUESTS        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$RBT_UNFORMATTED_RESPONSE      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$ROBOTIC_MOUNT_INFORMATION     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$ROBOTIC_REQUEST_ID            status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$SUPPORTED_TAPE_DENSITIES      status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$TAPE_RESERVATION              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMT$TAPE_UNIT_TYPES               status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMV$DENSITIES                     status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMV$JOB_TAPE_TABLE_DEFAULT        status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMV$JOB_TAPE_TABLE_LOCK           status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMV$JOB_TAPE_TABLE_P              status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMV$TAPE_DEBUG_MODE               status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck RMV$WRITE_RING                    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck SYM$PROCESS_DEADSTART_COMMANDS    status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck TCM$ENGINEERING_LOG_SUPPORT       status=BUILD_A101_NEW_DECKS_STATUS
 exclude_deck TCP$ACTIVATE_HPA_LOGGING          status=BUILD_A101_NEW_DECKS_STATUS
*DECK DECK=BUILD_A102 EXPAND=TRUE
*copyc BUILD_A111
*IF bev$product_level = 'BUILD_A102'
*copyc cycleA1_exceptions
*ELSE
*copyc BUILD_A102_contents
*IFEND
*DECK DECK=BUILD_A102_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A102_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A102_STATUS kind=status
IFEND
 exclude_feature command_level_cond_handling_3   status=BUILD_A102_STATUS
 exclude_feature correct_violet_fmd_numbers      status=BUILD_A102_STATUS
 exclude_feature ds_support_for_cyber_2000u      status=BUILD_A102_STATUS
 exclude_feature ds_support_for_cyber_2000u_a    status=BUILD_A102_STATUS
 exclude_feature nfsa153_os                      status=BUILD_A102_STATUS
 exclude_feature nv0u665                         status=BUILD_A102_STATUS
 exclude_feature nv0u678                         status=BUILD_A102_STATUS
 exclude_feature nv0u751                         status=BUILD_A102_STATUS
 exclude_feature soviet_962_ds_153               status=BUILD_A102_STATUS
 exclude_feature soviet_962_pm_153               status=BUILD_A102_STATUS
 exclude_feature lib99_cy2000u                   status=BUILD_A102_STATUS
 exclude_feature ds_support_for_cyber_2000u_b    status=BUILD_A102_STATUS
*DECK DECK=BUILD_A102_NEW_DECKS EXPAND=TRUE
*copyc BUILD_A111_NEW_DECKS
*IF bev$product_level = 'BUILD_A102_NEW_DECKS'
*copyc cycleA1_exceptions
*ELSE
*copyc BUILD_A102_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_A102_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A102_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A102_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck OSP$GET_CPU_MODEL_DEFINITION      status=BUILD_A102_NEW_DECKS_STATUS
 exclude_deck OSP$GET_GLOBAL_CPU_MODEL_DEF      status=BUILD_A102_NEW_DECKS_STATUS
 exclude_deck OSP$SET_GLOBAL_CPU_MODEL_DEF      status=BUILD_A102_NEW_DECKS_STATUS
*DECK DECK=BUILD_A111 EXPAND=TRUE
*copyc BUILD_A112
*IF bev$product_level = 'BUILD_A111'
*copyc cycleA1_exceptions
*ELSE
*copyc BUILD_A111_contents
*IFEND
*DECK DECK=BUILD_A111_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A111_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A111_STATUS kind=status
IFEND
 exclude_feature batch_output_filters_p2_i_os    status=BUILD_A111_STATUS
 exclude_feature cartridge_tape_support_silo_7   status=BUILD_A111_STATUS
 exclude_feature doit_side_door_port_optional    status=BUILD_A111_STATUS
 exclude_feature ds_update_level_to_l762         status=BUILD_A111_STATUS
 exclude_feature lib99_cy2000_update             status=BUILD_A111_STATUS
 exclude_feature network_queueing_system_os_1    status=BUILD_A111_STATUS
 exclude_feature nv07504                         status=BUILD_A111_STATUS
 exclude_feature nv08182                         status=BUILD_A111_STATUS
 exclude_feature nv08182_a                       status=BUILD_A111_STATUS
 exclude_feature nv08227                         status=BUILD_A111_STATUS
 exclude_feature nv08251                         status=BUILD_A111_STATUS
 exclude_feature nv08296                         status=BUILD_A111_STATUS
 exclude_feature nv0t879                         status=BUILD_A111_STATUS
 exclude_feature nv0u239                         status=BUILD_A111_STATUS
 exclude_feature nv0u664                         status=BUILD_A111_STATUS
 exclude_feature nv0u690                         status=BUILD_A111_STATUS
 exclude_feature nv0u716                         status=BUILD_A111_STATUS
 exclude_feature nv0u754                         status=BUILD_A111_STATUS
 exclude_feature nv0u759                         status=BUILD_A111_STATUS
 exclude_feature nv0u761                         status=BUILD_A111_STATUS
 exclude_feature nv0u767                         status=BUILD_A111_STATUS
 exclude_feature nv0u771                         status=BUILD_A111_STATUS
 exclude_feature nv0u777                         status=BUILD_A111_STATUS
 exclude_feature uri_filter                      status=BUILD_A111_STATUS
 exclude_feature batch_output_filters_p2_i_os2   status=BUILD_A111_STATUS
*DECK DECK=BUILD_A111_NEW_DECKS EXPAND=TRUE
*copyc BUILD_A112_NEW_DECKS
*IF bev$product_level = 'BUILD_A111_NEW_DECKS'
*copyc cycleA1_exceptions
*ELSE
*copyc BUILD_A111_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_A111_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A111_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A111_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck NFM$PREPROCESS_URI                status=BUILD_A111_NEW_DECKS_STATUS
 exclude_deck RAM$DEFINE_NQS                    status=BUILD_A111_NEW_DECKS_STATUS
 exclude_deck RAM$DELETE_NQS                    status=BUILD_A111_NEW_DECKS_STATUS
 exclude_deck RAP$INSTALL_BATCH_FILTERS         status=BUILD_A111_NEW_DECKS_STATUS
*DECK DECK=BUILD_A112 EXPAND=TRUE
*copyc BUILD_A121
*IF bev$product_level = 'BUILD_A112'
*copyc cycleA1_exceptions
*ELSE
*copyc BUILD_A112_contents
*IFEND
*DECK DECK=BUILD_A112_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A112_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A112_STATUS kind=status
IFEND
 exclude_feature command_level_cond_handling_4   status=BUILD_A112_STATUS
 exclude_feature network_queueing_system_os_2    status=BUILD_A112_STATUS
 exclude_feature nv08197                         status=BUILD_A112_STATUS
 exclude_feature nv0u573                         status=BUILD_A112_STATUS
 exclude_feature nv0u773                         status=BUILD_A112_STATUS
 exclude_feature nv0u775                         status=BUILD_A112_STATUS
 exclude_feature nv0u787                         status=BUILD_A112_STATUS
 exclude_feature nv0u788                         status=BUILD_A112_STATUS
 exclude_feature nv0u792                         status=BUILD_A112_STATUS
 exclude_feature standard_time_1990              status=BUILD_A112_STATUS
 exclude_feature tcv0151                         status=BUILD_A112_STATUS
*DECK DECK=BUILD_A112_NEW_DECKS EXPAND=TRUE
*copyc BUILD_A121_NEW_DECKS
*IF bev$product_level = 'BUILD_A112_NEW_DECKS'
*copyc cycleA1_exceptions
*ELSE
*copyc BUILD_A112_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_A112_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A112_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A112_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck NLH$CL_ZERO_TERMINATED_CONNECTS   status=BUILD_A112_NEW_DECKS_STATUS
 exclude_deck NLP$CL_ZERO_TERMINATED_CONNECTS   status=BUILD_A112_NEW_DECKS_STATUS
 exclude_deck RAP$DEFINE_NQS_HOST               status=BUILD_A112_NEW_DECKS_STATUS
 exclude_deck RAP$END_INSTALL_NQS               status=BUILD_A112_NEW_DECKS_STATUS
 exclude_deck RAP$INSTALL_NQS                   status=BUILD_A112_NEW_DECKS_STATUS
 exclude_deck RAP$NQS_DEFINE_VALIDATION_FLDS    status=BUILD_A112_NEW_DECKS_STATUS
 exclude_deck RAP$NQS_UPDATE_NETWORK_FILES      status=BUILD_A112_NEW_DECKS_STATUS
*DECK DECK=BUILD_A121 EXPAND=TRUE
*copyc BUILD_A122
*IF bev$product_level = 'BUILD_A121'
*copyc cycleA1_exceptions
*ELSE
*copyc BUILD_A121_contents
*IFEND
*DECK DECK=BUILD_A121_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A121_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A121_STATUS kind=status
IFEND
 exclude_feature anad_s0_msr_fix                 status=BUILD_A121_STATUS
 exclude_feature cdna_directory_enh_os           status=BUILD_A121_STATUS
 exclude_feature dfta206                         status=BUILD_A121_STATUS
 exclude_feature nrs_into_create_sched_class     status=BUILD_A121_STATUS
 exclude_feature nv07454                         status=BUILD_A121_STATUS
 exclude_feature nv07867                         status=BUILD_A121_STATUS
 exclude_feature nv08164                         status=BUILD_A121_STATUS
 exclude_feature nv08210                         status=BUILD_A121_STATUS
 exclude_feature nv0n936                         status=BUILD_A121_STATUS
 exclude_feature nv0u545                         status=BUILD_A121_STATUS
 exclude_feature nv0u751_a                       status=BUILD_A121_STATUS
 exclude_feature nv0u793                         status=BUILD_A121_STATUS
 exclude_feature nv0u794                         status=BUILD_A121_STATUS
 exclude_feature nv0u795                         status=BUILD_A121_STATUS
 exclude_feature nv0u815                         status=BUILD_A121_STATUS
 exclude_feature nv0u814                         status=BUILD_A121_STATUS
 exclude_feature nv0u545_fix                     status=BUILD_A121_STATUS
*DECK DECK=BUILD_A121_NEW_DECKS EXPAND=TRUE
*copyc BUILD_A122_NEW_DECKS
*IF bev$product_level = 'BUILD_A121_NEW_DECKS'
*copyc cycleA1_exceptions
*ELSE
*copyc BUILD_A121_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_A121_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A121_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A121_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck DFC$QUEUE_REQUEST_CONSTANTS       status=BUILD_A121_NEW_DECKS_STATUS
 exclude_deck DFP$CURRENT_RQ_BUFFER_OUT_INDEX   status=BUILD_A121_NEW_DECKS_STATUS
 exclude_deck DFP$GET_CURRENT_RQ_BUFFER_ENTRY   status=BUILD_A121_NEW_DECKS_STATUS
 exclude_deck DFP$SET_QUEUE_TIMED_OUT           status=BUILD_A121_NEW_DECKS_STATUS
 exclude_deck DFV$TASK_QUEUE_TIMEOUT_INTERVAL   status=BUILD_A121_NEW_DECKS_STATUS
 exclude_deck DPP$GET_NUMBER_LINES_IN_WINDOW    status=BUILD_A121_NEW_DECKS_STATUS
 exclude_deck DPT$CRITICAL_WINDOW_DATE_TIME     status=BUILD_A121_NEW_DECKS_STATUS
 exclude_deck JMH$UTIL_GET_QFILE_ATTRIBUTES     status=BUILD_A121_NEW_DECKS_STATUS
 exclude_deck JMH$UTIL_TERMINATE_QFILE          status=BUILD_A121_NEW_DECKS_STATUS
 exclude_deck JMM$MANAGE_QFILE_INTERFACES       status=BUILD_A121_NEW_DECKS_STATUS
 exclude_deck JMM$MANAGE_QFILE_UTILITY          status=BUILD_A121_NEW_DECKS_STATUS
 exclude_deck JMP$UTIL_GET_QFILE_ATTRIBUTES     status=BUILD_A121_NEW_DECKS_STATUS
 exclude_deck JMP$UTIL_TERMINATE_QFILE          status=BUILD_A121_NEW_DECKS_STATUS
 exclude_deck NLV$DIRECTORY_PDU_SEQ_NUMBER      status=BUILD_A121_NEW_DECKS_STATUS
 exclude_deck NLV$DIRECTORY_VERSION             status=BUILD_A121_NEW_DECKS_STATUS
 exclude_deck PFP$DISPLAY_MEMORY_TO_LOG         status=BUILD_A121_NEW_DECKS_STATUS
*DECK DECK=BUILD_A122 EXPAND=TRUE
*copyc BUILD_A201
*IF bev$product_level = 'BUILD_A122'
*copyc cycleA1_exceptions
*ELSE
*copyc BUILD_A122_contents
*IFEND
*DECK DECK=BUILD_A122_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_A122_NEW_DECKS EXPAND=TRUE
*copyc BUILD_A201_NEW_DECKS
*IF bev$product_level = 'BUILD_A122_NEW_DECKS'
*copyc cycleA1_exceptions
*ELSE
*copyc BUILD_A122_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_A122_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_A191 EXPAND=TRUE
*IF bev$product_level = 'BUILD_A111 '
*copyc BUILD_A111
*IFEND
IF $variable(build_a191_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_a191_status kind=status
IFEND
 include_feature cdna_directory_enh_os           status=build_a191_status
 include_feature fulb_listing_to_pf              status=build_a191_status
 include_feature manage_job_utility_via_fs       status=build_a191_status
 include_feature manage_job_utility_via_fs_1     status=build_a191_status
 include_feature nv06740                         status=build_a191_status
 include_feature command_level_cond_handling_4   status=build_a191_status
 include_feature network_queueing_system_os_2    status=build_a191_status
 include_feature nv08197                         status=build_a191_status
 include_feature nv0u573                         status=build_a191_status
 include_feature nv0u773                         status=build_a191_status
 include_feature nv0u787                         status=build_a191_status
 include_feature nv0u788                         status=build_a191_status
 include_feature standard_time_1990              status=build_a191_status
 include_feature manage_job_utility_via_fs_4     status=build_a191_status
*DECK DECK=BUILD_A201 EXPAND=TRUE
*copyc BUILD_A202
*IF bev$product_level = 'BUILD_A201'
*copyc cycleA2_exceptions
*ELSE
*copyc BUILD_A201_contents
*IFEND
*DECK DECK=BUILD_A201_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A201_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A201_STATUS kind=status
IFEND
 exclude_feature ar20357                         status=BUILD_A201_STATUS
 exclude_feature archive_ve_ihb_updates          status=BUILD_A201_STATUS
 exclude_feature batch_output_filters_p2_i_os3   status=BUILD_A201_STATUS
 exclude_feature hydras_on_violet                status=BUILD_A201_STATUS
 exclude_feature lib99_l765_update               status=BUILD_A201_STATUS
 exclude_feature mv2a838                         status=BUILD_A201_STATUS
 exclude_feature nv07171                         status=BUILD_A201_STATUS
 exclude_feature nv07748                         status=BUILD_A201_STATUS
 exclude_feature nv08179                         status=BUILD_A201_STATUS
 exclude_feature nv08302                         status=BUILD_A201_STATUS
 exclude_feature nv08346                         status=BUILD_A201_STATUS
 exclude_feature nv08362                         status=BUILD_A201_STATUS
 exclude_feature nv08363                         status=BUILD_A201_STATUS
 exclude_feature nv08401                         status=BUILD_A201_STATUS
 exclude_feature nv0u718                         status=BUILD_A201_STATUS
 exclude_feature nv0u770                         status=BUILD_A201_STATUS
 exclude_feature nv0u781                         status=BUILD_A201_STATUS
 exclude_feature nv0u798                         status=BUILD_A201_STATUS
 exclude_feature nv0u810                         status=BUILD_A201_STATUS
 exclude_feature nv0u812                         status=BUILD_A201_STATUS
 exclude_feature nv0u816                         status=BUILD_A201_STATUS
 exclude_feature nv0u830                         status=BUILD_A201_STATUS
 exclude_feature nv0u832                         status=BUILD_A201_STATUS
 exclude_feature nv0u838                         status=BUILD_A201_STATUS
 exclude_feature nv0u842                         status=BUILD_A201_STATUS
 exclude_feature nv0u849                         status=BUILD_A201_STATUS
 exclude_feature nv0u850                         status=BUILD_A201_STATUS
 exclude_feature open_file_statistics            status=BUILD_A201_STATUS
 exclude_feature silo_os_decks                   status=BUILD_A201_STATUS
 exclude_feature test_harness_update_29          status=BUILD_A201_STATUS
*DECK DECK=BUILD_A201_NEW_DECKS EXPAND=TRUE
*copyc BUILD_A202_NEW_DECKS
*IF bev$product_level = 'BUILD_A201_NEW_DECKS'
*copyc cycleA2_exceptions
*ELSE
*copyc BUILD_A201_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_A201_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A201_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A201_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck NLV$BM_BUFFERS_FREED              status=BUILD_A201_NEW_DECKS_STATUS
 exclude_deck RAI$PROLOG_SN302_HYDRAS           status=BUILD_A201_NEW_DECKS_STATUS
 exclude_deck RAI$PROLOG_SN302_HYDRAS_PF        status=BUILD_A201_NEW_DECKS_STATUS
 exclude_deck RAM$ACTIVATE_5744_APPLICATION     status=BUILD_A201_NEW_DECKS_STATUS
 exclude_deck RAM$DEACTIVATE_5744_APPLICATION   status=BUILD_A201_NEW_DECKS_STATUS
 exclude_deck RAM$DEFINE_5744_APPLICATION       status=BUILD_A201_NEW_DECKS_STATUS
 exclude_deck RAM$DELETE_5744_APPLICATION       status=BUILD_A201_NEW_DECKS_STATUS
 exclude_deck RAP$UPDATE_SYSFILES_FOR_ARCHIVE   status=BUILD_A201_NEW_DECKS_STATUS
 exclude_deck SFV$EMIT_JOB_OPEN_STATISTICS      status=BUILD_A201_NEW_DECKS_STATUS
 exclude_deck SFV$EMIT_SYS_OPEN_STATISTICS      status=BUILD_A201_NEW_DECKS_STATUS
 exclude_deck TCE$5744_ERROR_MESSAGES           status=BUILD_A201_NEW_DECKS_STATUS
 exclude_deck TCM$5744_HELP_MODULE              status=BUILD_A201_NEW_DECKS_STATUS
 exclude_deck TCM$5744_MSG_TEMPLATE_MODULE      status=BUILD_A201_NEW_DECKS_STATUS
*DECK DECK=BUILD_A202 EXPAND=TRUE
*copyc BUILD_A203
*IF bev$product_level = 'BUILD_A202'
*copyc cycleA2_exceptions
*ELSE
*copyc BUILD_A202_contents
*IFEND
*DECK DECK=BUILD_A202_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A202_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A202_STATUS kind=status
IFEND
 exclude_feature batch_output_filters_p2_i_os4   status=BUILD_A202_STATUS
 exclude_feature command_level_cond_handling_5   status=BUILD_A202_STATUS
 exclude_feature ds_change_level_from_762_to_765 status=BUILD_A202_STATUS
 exclude_feature ei_dual_nos_cpu_support         status=BUILD_A202_STATUS
 exclude_feature handle_monitor_dues             status=BUILD_A202_STATUS
 exclude_feature nv0u834                         status=BUILD_A202_STATUS
 exclude_feature nv0u836                         status=BUILD_A202_STATUS
 exclude_feature nv0u849a                        status=BUILD_A202_STATUS
 exclude_feature nv0u852                         status=BUILD_A202_STATUS
 exclude_feature nv0u853                         status=BUILD_A202_STATUS
 exclude_feature nv0u854                         status=BUILD_A202_STATUS
 exclude_feature nv0u857                         status=BUILD_A202_STATUS
 exclude_feature nv0u863                         status=BUILD_A202_STATUS
 exclude_feature nv0u869                         status=BUILD_A202_STATUS
 exclude_feature nv0u875                         status=BUILD_A202_STATUS
 exclude_feature nv0u876                         status=BUILD_A202_STATUS
 exclude_feature nv0u877                         status=BUILD_A202_STATUS
 exclude_feature nv0u882                         status=BUILD_A202_STATUS
 exclude_feature the_time_has_come               status=BUILD_A202_STATUS
 exclude_feature nv07045                         status=BUILD_A202_STATUS
 exclude_feature vistacom_mac_30                 status=BUILD_A202_STATUS
 exclude_feature nv07045_prog_int_additions      status=BUILD_A202_STATUS
 exclude_feature add_vistacom_mac_30_to_prog_int status=BUILD_A202_STATUS
*DECK DECK=BUILD_A202_NEW_DECKS EXPAND=TRUE
*copyc BUILD_A203_NEW_DECKS
*IF bev$product_level = 'BUILD_A202_NEW_DECKS'
*copyc cycleA2_exceptions
*ELSE
*copyc BUILD_A202_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_A202_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A202_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A202_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck BAT$ACCESS_CONDITIONS             status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck BAT$DEFAULT_HANDLER_PARAMS        status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck BAT$WAIT_CONDITIONS               status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck CSM$VISTACOM_MAC_30               status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck FSC$FILE_ACCESS_CONDITIONS_MAX    status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck FSC$INTERNAL_CONDITIONS_MAX       status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck FSC$WAIT_CATALOG_MISSING          status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck FSC$WAIT_CATALOG_UNAVAILABLE      status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck FSC$WAIT_CYCLE_BUSY               status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck FSC$WAIT_FILE_MISSING             status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck FSC$WAIT_FILE_UNAVAILABLE         status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck FSC$WAIT_FOR_RETRIEVAL            status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck FSC$WAIT_FOR_SPACE                status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck FSC$WAIT_SERVER_INACTIVE          status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck FSP$CONVERT_STATUS_CONDITION      status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck FSP$FILE_ACCESS_CONDITION         status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck FSP$GET_ACCESS_CONDITION_ENTRY    status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck FSP$GET_SIGNIFICANT_PATH_STRING   status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck FST$ACCESS_CONDITION_ENTRY        status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck FSV$CONDITION_MAPPING_TABLE       status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck FSV$FILE_ACCESS_CONDITIONS        status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck I#MTR_DISABLE_TRAPS               status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck I#MTR_ENABLE_TRAPS                status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck I#MTR_RESTORE_TRAPS               status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck I#SYNC                            status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck MTT$MONITOR_CONDITIONS            status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck OSC$CYCLE_BUSY_COND               status=BUILD_A202_NEW_DECKS_STATUS
 exclude_deck OSC$DATA_RETRIEVAL_REQ_COND       status=BUILD_A202_NEW_DECKS_STATUS
*DECK DECK=BUILD_A203 EXPAND=TRUE
*copyc BUILD_A204
*IF bev$product_level = 'BUILD_A203'
*copyc cycleA2_exceptions
*ELSE
*copyc BUILD_A203_contents
*IFEND
*DECK DECK=BUILD_A203_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A203_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A203_STATUS kind=status
IFEND
 exclude_feature anad_2ap_fix                    status=BUILD_A203_STATUS
 exclude_feature electronic_qcu_31               status=BUILD_A203_STATUS
 exclude_feature fix_batch_filters_ip            status=BUILD_A203_STATUS
 exclude_feature network_queueing_system_os_3    status=BUILD_A203_STATUS
 exclude_feature nv08250                         status=BUILD_A203_STATUS
 exclude_feature nv08408                         status=BUILD_A203_STATUS
 exclude_feature nv08440                         status=BUILD_A203_STATUS
 exclude_feature nv08530                         status=BUILD_A203_STATUS
 exclude_feature nv0u769                         status=BUILD_A203_STATUS
 exclude_feature nv0u887                         status=BUILD_A203_STATUS
 exclude_feature nv0u889                         status=BUILD_A203_STATUS
 exclude_feature nv0u893                         status=BUILD_A203_STATUS
 exclude_feature nv0u894                         status=BUILD_A203_STATUS
 exclude_feature nv0u898                         status=BUILD_A203_STATUS
 exclude_feature special_for_liar_1              status=BUILD_A203_STATUS
 exclude_feature batch_filters_os                status=BUILD_A203_STATUS
 exclude_feature copyright_1991                  status=BUILD_A203_STATUS
*DECK DECK=BUILD_A203_NEW_DECKS EXPAND=TRUE
*copyc BUILD_A204_NEW_DECKS
*IF bev$product_level = 'BUILD_A203_NEW_DECKS'
*copyc cycleA2_exceptions
*ELSE
*copyc BUILD_A203_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_A203_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A203_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A203_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck QCM$MAKCCU_PHASE_100              status=BUILD_A203_NEW_DECKS_STATUS
 exclude_deck QCM$MANAGE_PSR_STATISTICS         status=BUILD_A203_NEW_DECKS_STATUS
 exclude_deck QCP$FETCH_PSR_STATISTICS          status=BUILD_A203_NEW_DECKS_STATUS
 exclude_deck QCP$INITIALIZE_PSR_STATISTICS     status=BUILD_A203_NEW_DECKS_STATUS
 exclude_deck QCP$UPDATE_PSR_STATISTICS         status=BUILD_A203_NEW_DECKS_STATUS
 exclude_deck QCT$PSR_STATISTICS                status=BUILD_A203_NEW_DECKS_STATUS
 exclude_deck QCV$PSRS_P                        status=BUILD_A203_NEW_DECKS_STATUS
*DECK DECK=BUILD_A204 EXPAND=TRUE
*copyc BUILD_A205
*IF bev$product_level = 'BUILD_A204'
*copyc cycleA2_exceptions
*ELSE
*copyc BUILD_A204_contents
*IFEND
*DECK DECK=BUILD_A204_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A204_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A204_STATUS kind=status
IFEND
 exclude_feature l765_mdd_dft_final_date_lvl_mod status=BUILD_A204_STATUS
 exclude_feature nv06337                         status=BUILD_A204_STATUS
 exclude_feature nv08499                         status=BUILD_A204_STATUS
 exclude_feature nv0u875a                        status=BUILD_A204_STATUS
 exclude_feature nv0u903                         status=BUILD_A204_STATUS
 exclude_feature nv0u904                         status=BUILD_A204_STATUS
 exclude_feature nv0u908                         status=BUILD_A204_STATUS
*DECK DECK=BUILD_A204_NEW_DECKS EXPAND=TRUE
*copyc BUILD_A205_NEW_DECKS
*IF bev$product_level = 'BUILD_A204_NEW_DECKS'
*copyc cycleA2_exceptions
*ELSE
*copyc BUILD_A204_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_A204_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A204_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A204_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck FSH$RESOLVE_FILE_REFERENCE        status=BUILD_A204_NEW_DECKS_STATUS
 exclude_deck FSM$RESOLVE_FILE_REFERENCE        status=BUILD_A204_NEW_DECKS_STATUS
 exclude_deck FSP$RESOLVE_FILE_REFERENCE        status=BUILD_A204_NEW_DECKS_STATUS
*DECK DECK=BUILD_A205 EXPAND=TRUE
*copyc BUILD_A206
*IF bev$product_level = 'BUILD_A205'
*copyc cycleA2_exceptions
*ELSE
*copyc BUILD_A205_contents
*IFEND
*DECK DECK=BUILD_A205_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A205_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A205_STATUS kind=status
IFEND
 exclude_feature nv0u723                         status=BUILD_A205_STATUS
 exclude_feature nv0u870                         status=BUILD_A205_STATUS
 exclude_feature nv0u875b                        status=BUILD_A205_STATUS
 exclude_feature nv0u911                         status=BUILD_A205_STATUS
 exclude_feature nv0u921                         status=BUILD_A205_STATUS
 exclude_feature nv0u923                         status=BUILD_A205_STATUS
*DECK DECK=BUILD_A205_NEW_DECKS EXPAND=TRUE
*copyc BUILD_A206_NEW_DECKS
*IF bev$product_level = 'BUILD_A205_NEW_DECKS'
*copyc cycleA2_exceptions
*ELSE
*copyc BUILD_A205_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_A205_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A205_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A205_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck DFH$BEGIN_CH_REMOTE_PROC_CALL     status=BUILD_A205_NEW_DECKS_STATUS
 exclude_deck DFH$END_CH_REMOTE_PROC_CALL       status=BUILD_A205_NEW_DECKS_STATUS
 exclude_deck DFP$BEGIN_CH_REMOTE_PROC_CALL     status=BUILD_A205_NEW_DECKS_STATUS
 exclude_deck DFP$END_CH_REMOTE_PROC_CALL       status=BUILD_A205_NEW_DECKS_STATUS
 exclude_deck DFV$CH_QUEUE_ENTRY_LOCATION       status=BUILD_A205_NEW_DECKS_STATUS
*DECK DECK=BUILD_A206 EXPAND=TRUE
*copyc BUILD_B101
*IF bev$product_level = 'BUILD_A206'
*copyc cycleA2_exceptions
*ELSE
*copyc BUILD_A206_contents
*IFEND
*DECK DECK=BUILD_A206_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A206_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A206_STATUS kind=status
IFEND
 exclude_feature namve_small_memory              status=BUILD_A206_STATUS
 exclude_feature nv0u909                         status=BUILD_A206_STATUS
 exclude_feature nv0u929                         status=BUILD_A206_STATUS
 exclude_feature nv0u930                         status=BUILD_A206_STATUS
 exclude_feature nv0u930a                        status=BUILD_A206_STATUS
 exclude_feature nv0u932                         status=BUILD_A206_STATUS
 exclude_feature nv0u933                         status=BUILD_A206_STATUS
 exclude_feature nvou937                         status=BUILD_A206_STATUS
 exclude_feature nv0u946                         status=BUILD_A206_STATUS
*DECK DECK=BUILD_A206_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B101_NEW_DECKS
*IF bev$product_level = 'BUILD_A206_NEW_DECKS'
*copyc cycleA2_exceptions
*ELSE
*copyc BUILD_A206_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_A206_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_A206_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_A206_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck NLC$SMALL_MACHINE_THRESHOLD       status=BUILD_A206_NEW_DECKS_STATUS
*DECK DECK=BUILD_A291 EXPAND=TRUE
*IF bev$product_level = 'BUILD_A201 '
*copyc BUILD_A201
*IFEND
IF $variable(build_a291_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_a291_status kind=status
IFEND
 include_feature fulb_listing_to_pf              status=build_a291_status
 include_feature manage_job_utility_via_fs       status=build_a291_status
 include_feature manage_job_utility_via_fs_1     status=build_a291_status
 include_feature manage_job_utility_via_fs_4     status=build_a291_status
 include_feature manage_job_utility_via_fs_5     status=build_a291_status
 include_feature nv06740                         status=build_a291_status
 include_feature batch_output_filters_p2_i_os4   status=build_a291_status
 include_feature nv0u834                         status=build_a291_status
 include_feature nv0u849a                        status=build_a291_status
 include_feature nv0u854                         status=build_a291_status
 include_feature manage_job_utility_via_fs_2     status=build_a291_status
*DECK DECK=BUILD_A298 EXPAND=TRUE
*IF bev$product_level = 'BUILD_A206 '
*copyc BUILD_A206
*IFEND
*DECK DECK=BUILD_A299 EXPAND=TRUE
*IF bev$product_level = 'BUILD_A203 '
*copyc BUILD_A203
*IFEND
*DECK DECK=BUILD_B101 EXPAND=TRUE
*copyc BUILD_B201
*IF bev$product_level = 'BUILD_B101'
*copyc cycleB1_exceptions
*ELSE
*copyc BUILD_B101_contents
*IFEND
*DECK DECK=BUILD_B101_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B101_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B101_STATUS kind=status
IFEND
 exclude_feature china_992_support_ds            status=BUILD_B101_STATUS
 exclude_feature china_992_support_pm            status=BUILD_B101_STATUS
 exclude_feature resequence_cleanup_jm_152       status=BUILD_B101_STATUS
 exclude_feature resequence_cleanup_os           status=BUILD_B101_STATUS
 exclude_feature china_992_support_ds_2          status=BUILD_B101_STATUS
 exclude_feature china_992_support_ds_3          status=BUILD_B101_STATUS
*DECK DECK=BUILD_B101_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B201_NEW_DECKS
*IF bev$product_level = 'BUILD_B101_NEW_DECKS'
*copyc cycleB1_exceptions
*ELSE
*copyc BUILD_B101_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B101_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B101_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B101_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck DPT$LOCK_MAIN_WINDOW              status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DPT$SECURE_INPUT_LINE             status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DPV$LOCK_MAIN_WINDOW              status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DPV$SECURE_INPUT_LINE             status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSE$INTERVAL_PASSWORD_ERRORS      status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSM$DEADSTART_SERVICES_23D        status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSM$MANAGE_INTERVAL_PASSWORD      status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSP$CHANGE_OPERATION_PASSWORD     status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSP$CHECK_INTERVAL                status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSP$CHECK_INTERVAL_23D            status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSP$CHECK_PASSWORD_FOR_INISD      status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSP$CHECK_SAVED_PASSWORDS         status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSP$FORCE_LOCK_OF_MAIN_WINDOW     status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSP$FORCE_LOCK_OF_WINDOW_23D      status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSP$LOCK_UNLOCK_MAIN_WINDOW       status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSP$LOCK_UNLOCK_WINDOW_FROM_MTR   status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSP$PROCESS_SETOI_COMMAND         status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSP$PROCESS_SETOP_COMMAND         status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSP$SET_OPERATION_INTERVAL        status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSP$SET_OPERATION_PASSWORD        status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSP$SIGNAL_HANDLER                status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DST$SIGNAL_CONTENTS               status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DST$SUB_MAINFRAME_TYPE            status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck DSV$SUB_MAINFRAME_TYPE            status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck PME$NEW_PASSWORD_DOES_NOT_MATCH   status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck PMM$CHANGE_OPERATION_PASSWRD_PD   status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck PMM$DISABLE_MAIN_OPERATOR_WI_PD   status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck PMM$ENABLE_MAIN_OPERATOR_WIN_PD   status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck PMM$SET_OPERATION_INTERVAL_PD     status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck PMM$SET_OPERATION_PASSWORD_PD     status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck PMM$SYSTEM_ADMIN_MISC_COMMANDS    status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck PMM$SYSTEM_ADMIN_MISC_COM_R3      status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck PMP$CHANGE_OPERATION_PASSWORD     status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck PMP$LOCK_UNLOCK_MAIN_WINDOW       status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck PMP$SET_OPERATION_INTERVAL        status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck PMP$SET_OPERATION_PASSWORD        status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck RAP$INITIATE_SOU                  status=BUILD_B101_NEW_DECKS_STATUS
 exclude_deck SYV$READING_DCFILE                status=BUILD_B101_NEW_DECKS_STATUS
*DECK DECK=BUILD_B171 EXPAND=TRUE
*IF bev$product_level = 'BUILD_A206 '
*copyc BUILD_A206
*IFEND
IF $variable(build_b171_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_b171_status kind=status
IFEND
 include_feature fulb_listing_to_pf              status=build_b171_status
 include_feature manage_job_utility_via_fs       status=build_b171_status
 include_feature manage_job_utility_via_fs_1     status=build_b171_status
 include_feature manage_job_utility_via_fs_2     status=build_b171_status
 include_feature manage_job_utility_via_fs_4     status=build_b171_status
 include_feature manage_job_utility_via_fs_5     status=build_b171_status
 include_feature est_860_orig                    status=build_b171_status
 include_feature est_860_001                     status=build_b171_status
 include_feature est_860_002                     status=build_b171_status
 include_feature ftma026                         status=build_b171_status
 include_feature nv05790                         status=build_b171_status
 include_feature nv05927                         status=build_b171_status
 include_feature nv06740                         status=build_b171_status
 include_feature nv07761                         status=build_b171_status
 include_feature nv07858                         status=build_b171_status
 include_feature nv07995                         status=build_b171_status
 include_feature nv08121                         status=build_b171_status
 include_feature nv08299                         status=build_b171_status
 include_feature nv08351                         status=build_b171_status
 include_feature nv08357                         status=build_b171_status
 include_feature nv08398                         status=build_b171_status
 include_feature nv08402                         status=build_b171_status
 include_feature nv08462                         status=build_b171_status
 include_feature nv08470                         status=build_b171_status
 include_feature nv0q638                         status=build_b171_status
 include_feature nv0t746                         status=build_b171_status
 include_feature nv0t881                         status=build_b171_status
 include_feature nv0t926                         status=build_b171_status
 include_feature nv0t942                         status=build_b171_status
 include_feature nv0u023                         status=build_b171_status
 include_feature nv0u171                         status=build_b171_status
 include_feature nv0u540                         status=build_b171_status
 include_feature nv0u927                         status=build_b171_status
 include_feature nv0u940                         status=build_b171_status
*DECK DECK=BUILD_B172 EXPAND=TRUE
*IF bev$product_level = 'BUILD_A206 '
*copyc BUILD_A206
*IFEND
*copyc BUILD_B171
IF $variable(build_b172_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_b172_status kind=status
IFEND
 include_feature basic_tape_security_phase_1     status=build_b172_status
 include_feature est_860_003                     status=build_b172_status
 include_feature nv08654                         status=build_b172_status
 include_feature nv0u948                         status=build_b172_status
 include_feature nv0u960                         status=build_b172_status
 include_feature nv0u961                         status=build_b172_status
 include_feature nv0u963                         status=build_b172_status
 include_feature nv0u977                         status=build_b172_status
 include_feature selom_team_fix_1                status=build_b172_status
 include_feature basic_tape_security_phase_1f2   status=build_b172_status
*DECK DECK=BUILD_B201 EXPAND=TRUE
*copyc BUILD_B205
*IF bev$product_level = 'BUILD_B201'
*copyc cycleB2_exceptions
*ELSE
*copyc BUILD_B201_contents
*IFEND
*DECK DECK=BUILD_B201_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B201_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B201_STATUS kind=status
IFEND
 exclude_feature basic_tape_security_phase_1     status=BUILD_B201_STATUS
 exclude_feature basic_tape_security_phase_1f2   status=BUILD_B201_STATUS
 exclude_feature est_860_001                     status=BUILD_B201_STATUS
 exclude_feature est_860_002                     status=BUILD_B201_STATUS
 exclude_feature est_860_003                     status=BUILD_B201_STATUS
 exclude_feature est_860_orig                    status=BUILD_B201_STATUS
 exclude_feature dfta190                         status=BUILD_B201_STATUS
 exclude_feature dismr_proc                      status=BUILD_B201_STATUS
 exclude_feature ftma026                         status=BUILD_B201_STATUS
 exclude_feature incr_output_applications_tmp    status=BUILD_B201_STATUS
 exclude_feature lockd_stats_os                  status=BUILD_B201_STATUS
 exclude_feature manage_job_utility_via_fs       status=BUILD_B201_STATUS
 exclude_feature manage_job_utility_via_fs_1     status=BUILD_B201_STATUS
 exclude_feature manage_job_utility_via_fs_2     status=BUILD_B201_STATUS
 exclude_feature manage_job_utility_via_fs_4     status=BUILD_B201_STATUS
 exclude_feature manage_job_utility_via_fs_5     status=BUILD_B201_STATUS
 exclude_feature manage_job_utility_via_fs_6     status=BUILD_B201_STATUS
 exclude_feature mv2a671                         status=BUILD_B201_STATUS
 exclude_feature nv05790                         status=BUILD_B201_STATUS
 exclude_feature nv05927                         status=BUILD_B201_STATUS
 exclude_feature nv06740                         status=BUILD_B201_STATUS
 exclude_feature nv07761                         status=BUILD_B201_STATUS
 exclude_feature nv07858                         status=BUILD_B201_STATUS
 exclude_feature nv07995                         status=BUILD_B201_STATUS
 exclude_feature nv08121                         status=BUILD_B201_STATUS
 exclude_feature nv08299                         status=BUILD_B201_STATUS
 exclude_feature nv08351                         status=BUILD_B201_STATUS
 exclude_feature nv08357                         status=BUILD_B201_STATUS
 exclude_feature nv08398                         status=BUILD_B201_STATUS
 exclude_feature nv08402                         status=BUILD_B201_STATUS
 exclude_feature nv08462                         status=BUILD_B201_STATUS
 exclude_feature nv08470                         status=BUILD_B201_STATUS
 exclude_feature nv08654                         status=BUILD_B201_STATUS
 exclude_feature nv08684                         status=BUILD_B201_STATUS
 exclude_feature nv0q638                         status=BUILD_B201_STATUS
 exclude_feature nv0t746                         status=BUILD_B201_STATUS
 exclude_feature nv0t881                         status=BUILD_B201_STATUS
 exclude_feature nv0t926                         status=BUILD_B201_STATUS
 exclude_feature nv0t942                         status=BUILD_B201_STATUS
 exclude_feature nv0u023                         status=BUILD_B201_STATUS
 exclude_feature nv0u171                         status=BUILD_B201_STATUS
 exclude_feature nv0u540                         status=BUILD_B201_STATUS
 exclude_feature nv0u927                         status=BUILD_B201_STATUS
 exclude_feature nv0u940                         status=BUILD_B201_STATUS
 exclude_feature nv0u954_os                      status=BUILD_B201_STATUS
 exclude_feature nv0u960                         status=BUILD_B201_STATUS
 exclude_feature nv0u961                         status=BUILD_B201_STATUS
 exclude_feature nv0u963                         status=BUILD_B201_STATUS
 exclude_feature nv0u974                         status=BUILD_B201_STATUS
 exclude_feature nv0u977                         status=BUILD_B201_STATUS
 exclude_feature resequence_cleanup_ba           status=BUILD_B201_STATUS
 exclude_feature resequence_cleanup_io           status=BUILD_B201_STATUS
 exclude_feature resequence_cleanup_mm           status=BUILD_B201_STATUS
 exclude_feature resequence_cleanup_na           status=BUILD_B201_STATUS
 exclude_feature resequence_cleanup_pf_1         status=BUILD_B201_STATUS
 exclude_feature resequence_cleanup_ra           status=BUILD_B201_STATUS
 exclude_feature screen_formatting_speedup_2     status=BUILD_B201_STATUS
 exclude_feature selom_team_fix_1                status=BUILD_B201_STATUS
 exclude_feature turn_off_mm_debug               status=BUILD_B201_STATUS
*DECK DECK=BUILD_B201_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B205_NEW_DECKS
*IF bev$product_level = 'BUILD_B201_NEW_DECKS'
*copyc cycleB2_exceptions
*ELSE
*copyc BUILD_B201_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B201_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B201_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B201_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck BAP$GET_TAPE_SECURITY_STATE       status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck BAP$GET_TAPE_SECURITY_STATE_R1    status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck BAP$PUT_TAPE_SECURITY_STATE       status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck BAP$PUT_TAPE_SECURITY_STATE_R1    status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck CLP$ADD_TO_DEFER_LIST             status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck CLP$DELETE_FROM_DEFER_LIST        status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck CLP$GET_LOG_SECURE_PARAMETERS     status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck CLV$LOG_SECURE_PARAMETERS         status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck CSM$HP_2392                       status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck CSM$HP_2645                       status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck DUM$DISPLAY_MONITOR_REQUESTS      status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck FDP$CONVERT_TO_COBOL_NAME         status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck FDP$CONVERT_TO_FORTRAN_NAME       status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck FDP$GET_MESSAGE                   status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck FDT$MESSAGE_TEXT                  status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck FDV$TO_COBOL                      status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck FDV$TO_CYBIL                      status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck FDV$TO_EXTENDED_FORTRAN           status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck FDV$TO_FORTRAN                    status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck FDV$TO_SCL                        status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck FMC$MAXIMUM_FILE_LABEL_SIZE       status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck FSP$STRICTLY_NULL_DEVICE          status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JME$INTERNAL_WORK_AREA_OVERFLOW   status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JME$UNKNOWN_REQUESTOR             status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMH$GENERAL_PURPOSE_CLUSTER_RPC   status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMH$GET_RESULT_SIZE               status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMH$MAINFRAME_CHANGE_INPUT_ATTR   status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMH$MAINFRAME_CHANGE_OUTPUT_ATT   status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMH$MAINFRAME_GET_INPUT_ATTRIBU   status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMH$MAINFRAME_GET_JOB_STATUS      status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMH$MAINFRAME_GET_OUTPUT_ATTRIB   status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMH$MAINFRAME_GET_OUTPUT_STATUS   status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMH$MAINFRAME_SET_SENSE_SWITCH    status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMH$MAINFRAME_TERMINATE_OUTPUT    status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMH$SERVER_GENERAL_PURPOSE_RPC    status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMM$GENERAL_PURPOSE_CLUSTER_RPC   status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMP$COPY_SEQ_TO_RESULT_ARRAY      status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMP$GENERAL_PURPOSE_CLUSTER_RPC   status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMP$GET_DATA_PACKET_SIZE          status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMP$GET_RESULT_SIZE               status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMP$MAINFRAME_CHANGE_INPUT_ATTR   status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMP$MAINFRAME_CHANGE_OUTPUT_ATT   status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMP$MAINFRAME_GET_INPUT_ATTRIBU   status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMP$MAINFRAME_GET_JOB_STATUS      status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMP$MAINFRAME_GET_OUTPUT_ATTRIB   status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMP$MAINFRAME_GET_OUTPUT_STATUS   status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMP$MAINFRAME_SET_SENSE_SWITCH    status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMP$MAINFRAME_TERMINATE_OUTPUT    status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMP$SERVER_GENERAL_PURPOSE_RPC    status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMP$VALIDATE_ATTRIBUTE_OPTIONS    status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMP$VALIDATE_STATUS_OPTIONS       status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMT$FULL_JOB_CATEGORY_LIST        status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMT$GENERAL_PURPOSE_RPC_ORDINAL   status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMT$RESULTS                       status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMT$RESULTS_KEYS                  status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck JMT$RPC_MAINFRAMES_PROCESSED      status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck RAI$PROLOG_EST_860_A              status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck RAI$PROLOG_EST_860_B              status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck RAM$ACTIVATE_XTF                  status=BUILD_B201_NEW_DECKS_STATUS
 exclude_deck RAM$DEACTIVATE_XTF                status=BUILD_B201_NEW_DECKS_STATUS
*DECK DECK=BUILD_B205 EXPAND=TRUE
*copyc BUILD_B211
*IF bev$product_level = 'BUILD_B205'
*copyc cycleB2_exceptions
*ELSE
*copyc BUILD_B205_contents
*IFEND
*DECK DECK=BUILD_B205_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B205_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B205_STATUS kind=status
IFEND
 exclude_feature basisplus_profile_update        status=BUILD_B205_STATUS
 exclude_feature cm_flawing                      status=BUILD_B205_STATUS
 exclude_feature dft0046                         status=BUILD_B205_STATUS
 exclude_feature dft0046_fix                     status=BUILD_B205_STATUS
 exclude_feature electronic_qcu_43               status=BUILD_B205_STATUS
 exclude_feature nv03555                         status=BUILD_B205_STATUS
 exclude_feature nv05421                         status=BUILD_B205_STATUS
 exclude_feature nv06409                         status=BUILD_B205_STATUS
 exclude_feature nv07152                         status=BUILD_B205_STATUS
 exclude_feature nv07884                         status=BUILD_B205_STATUS
 exclude_feature nv08249                         status=BUILD_B205_STATUS
 exclude_feature nv08280                         status=BUILD_B205_STATUS
 exclude_feature nv08318                         status=BUILD_B205_STATUS
 exclude_feature nv08319                         status=BUILD_B205_STATUS
 exclude_feature nv08383                         status=BUILD_B205_STATUS
 exclude_feature nv08456_161                     status=BUILD_B205_STATUS
 exclude_feature nv08512                         status=BUILD_B205_STATUS
 exclude_feature nv08545                         status=BUILD_B205_STATUS
 exclude_feature nv08553                         status=BUILD_B205_STATUS
 exclude_feature nv08580                         status=BUILD_B205_STATUS
 exclude_feature nv08609                         status=BUILD_B205_STATUS
 exclude_feature nv08618                         status=BUILD_B205_STATUS
 exclude_feature nv08620                         status=BUILD_B205_STATUS
 exclude_feature nv08622                         status=BUILD_B205_STATUS
 exclude_feature nv08649                         status=BUILD_B205_STATUS
 exclude_feature nv08688                         status=BUILD_B205_STATUS
 exclude_feature nv08692                         status=BUILD_B205_STATUS
 exclude_feature nv08694                         status=BUILD_B205_STATUS
 exclude_feature nv08698                         status=BUILD_B205_STATUS
 exclude_feature nv08700                         status=BUILD_B205_STATUS
 exclude_feature nv08706                         status=BUILD_B205_STATUS
 exclude_feature nv08710                         status=BUILD_B205_STATUS
 exclude_feature nv08745                         status=BUILD_B205_STATUS
 exclude_feature nv08760                         status=BUILD_B205_STATUS
 exclude_feature nv08771                         status=BUILD_B205_STATUS
 exclude_feature nv08817                         status=BUILD_B205_STATUS
 exclude_feature nv0s406                         status=BUILD_B205_STATUS
 exclude_feature nv0u027                         status=BUILD_B205_STATUS
 exclude_feature nv0u948                         status=BUILD_B205_STATUS
 exclude_feature nv0u955                         status=BUILD_B205_STATUS
 exclude_feature nv0u978                         status=BUILD_B205_STATUS
 exclude_feature nv0u984                         status=BUILD_B205_STATUS
 exclude_feature nv0u989                         status=BUILD_B205_STATUS
 exclude_feature nv0u990                         status=BUILD_B205_STATUS
 exclude_feature nv0v007                         status=BUILD_B205_STATUS
 exclude_feature pewter_expresslink              status=BUILD_B205_STATUS
 exclude_feature remove_cle$unexpected_qual_kind status=BUILD_B205_STATUS
 exclude_feature screen_formatting_speedup_3     status=BUILD_B205_STATUS
 exclude_feature spinnaker_ii                    status=BUILD_B205_STATUS
 exclude_feature delete_references_to_chablt     status=BUILD_B205_STATUS
*DECK DECK=BUILD_B205_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B211_NEW_DECKS
*IF bev$product_level = 'BUILD_B205_NEW_DECKS'
*copyc cycleB2_exceptions
*ELSE
*copyc BUILD_B205_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B205_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B205_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B205_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck DSP$GET_FLAW_MAP                  status=BUILD_B205_NEW_DECKS_STATUS
 exclude_deck MMP$MARK_PAGE_FLAWED              status=BUILD_B205_NEW_DECKS_STATUS
 exclude_deck NFT$OPTIMIZE_LIST                 status=BUILD_B205_NEW_DECKS_STATUS
*DECK DECK=BUILD_B211 EXPAND=TRUE
*copyc BUILD_B212
*IF bev$product_level = 'BUILD_B211'
*copyc cycleB2_exceptions
*ELSE
*copyc BUILD_B211_contents
*IFEND
*DECK DECK=BUILD_B211_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B211_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B211_STATUS kind=status
IFEND
 exclude_feature auto_reconfiguration            status=BUILD_B211_STATUS
 exclude_feature auto_reconfiguration_ajl        status=BUILD_B211_STATUS
 exclude_feature basic_tape_security_phase_1f3   status=BUILD_B211_STATUS
 exclude_feature cm_flaw_fix                     status=BUILD_B211_STATUS
 exclude_feature delete_prerm_utility            status=BUILD_B211_STATUS
 exclude_feature esmd_fix_for_s1                 status=BUILD_B211_STATUS
 exclude_feature fix_chafa_of_attached_pfs       status=BUILD_B211_STATUS
 exclude_feature ftp_accounting_os               status=BUILD_B211_STATUS
 exclude_feature network_queueing_system_os_4    status=BUILD_B211_STATUS
 exclude_feature nv07729                         status=BUILD_B211_STATUS
 exclude_feature nv08425                         status=BUILD_B211_STATUS
 exclude_feature nv08537                         status=BUILD_B211_STATUS
 exclude_feature nv08610                         status=BUILD_B211_STATUS
 exclude_feature nv08615                         status=BUILD_B211_STATUS
 exclude_feature nv08703                         status=BUILD_B211_STATUS
 exclude_feature nv08716                         status=BUILD_B211_STATUS
 exclude_feature nv08729_os                      status=BUILD_B211_STATUS
 exclude_feature nv08839                         status=BUILD_B211_STATUS
 exclude_feature nv0u900                         status=BUILD_B211_STATUS
 exclude_feature nv0u987                         status=BUILD_B211_STATUS
 exclude_feature nv0v015                         status=BUILD_B211_STATUS
 exclude_feature nv0v017                         status=BUILD_B211_STATUS
*DECK DECK=BUILD_B211_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B212_NEW_DECKS
*IF bev$product_level = 'BUILD_B211_NEW_DECKS'
*copyc cycleB2_exceptions
*ELSE
*copyc BUILD_B211_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B211_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B211_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B211_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck BAM$MERGE_TAPE_ATTRIBUTES         status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck BAP$MERGE_TAPE_ATTRIBUTES         status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMC$ACTION_MESSAGES               status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMH$SIGNAL_HANDLER                status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CML$CONNECTION_DISABLED           status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CML$ELEMENT_DISABLED              status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMM$ACTION_MESSAGES               status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMM$CONNECTION_MANAGER            status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMM$MANAGE_CM_TABLES_R1           status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMM$MONITOR_JOB_MODE_INTERFACES   status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMM$SIGNAL_HANDLER                status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$CHANGE_CONNECTION_STATUS      status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$CHANGE_CONNECTION_STATUS_R1   status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$CHANNELS_EQUIVALENT           status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$CLEAR_LCU_TASKID              status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$CLEAR_LCU_TASKID_R1           status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$DETERMINE_ACTIVE_PATH         status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$ENABLE_ALL_CONNECTIONS        status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$FIND_REDUNDANT_PATH           status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$GET_CONNECTION_LIST           status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$GET_CONNECTION_STATUS         status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$GET_ELEMENT_ENTRY             status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$GET_ELEMENT_ENTRY_R1          status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$GET_ELEMENT_ENTRY_VIA_ADR     status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$GET_ELEMENT_ENTRY_VIA_NAME    status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$GET_ELEMENT_VIA_LUN           status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$GET_ELEMENT_VIA_NAME          status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$LOCATE_DISABLED_CONNECTION    status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$LOCATE_ELEMENT_VIA_ADR        status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$LOCATE_ELEMENT_VIA_NAME       status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$SELECT_PRIMARY_CONTROLLER     status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$SET_LCU_TASKID                status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$SET_LCU_TASKID_R1             status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$SIGNAL_HANDLER                status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$SUPPORT_REDUNDANT_ACCESS      status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$SWITCH_TO_REDUNDANT_PATH      status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMP$VERIFY_ACTIVE_PATH_EXISTS     status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMT$DEADSTART_LCU_TASKID          status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMT$DOWNLINE_CONNECTION           status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMT$SIGNAL_CONTENTS               status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMV$ACQUIRE_PP_FOR_REDUNDANT_CH   status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMV$CONTROLLER_ADDRESS            status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMV$DATA_CHANNEL_ADDRESS          status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMV$DEADSTART_LCU_TASKID          status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMV$ENABLE_AUTO_RECONFIGURATION   status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMV$HYDRA_MASS_STORAGE_ADDRESS    status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck CMV$MASS_STORAGE_ADDRESS          status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck JMT$FTP_STATISTIC_DATA            status=BUILD_B211_NEW_DECKS_STATUS
 exclude_deck PUP$CONSTRUCT_VOLUME_LIST         status=BUILD_B211_NEW_DECKS_STATUS
*DECK DECK=BUILD_B212 EXPAND=TRUE
*copyc BUILD_B221
*IF bev$product_level = 'BUILD_B212'
*copyc cycleB2_exceptions
*ELSE
*copyc BUILD_B212_contents
*IFEND
*DECK DECK=BUILD_B212_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B212_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B212_STATUS kind=status
IFEND
 exclude_feature nv0v022                         status=BUILD_B212_STATUS
 exclude_feature screen_formatting_email_1       status=BUILD_B212_STATUS
 exclude_feature screen_formatting_email_2       status=BUILD_B212_STATUS
 exclude_feature close_sub_ip                    status=BUILD_B212_STATUS
 exclude_feature dcfile_update                   status=BUILD_B212_STATUS
*DECK DECK=BUILD_B212_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B221_NEW_DECKS
*IF bev$product_level = 'BUILD_B212_NEW_DECKS'
*copyc cycleB2_exceptions
*ELSE
*copyc BUILD_B212_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B212_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B212_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B212_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck FDC$REASSIGN_EVENT_CAPABILITY     status=BUILD_B212_NEW_DECKS_STATUS
 exclude_deck FDT$EVENT_LABEL_V1                status=BUILD_B212_NEW_DECKS_STATUS
*DECK DECK=BUILD_B221 EXPAND=TRUE
*copyc BUILD_B222
*IF bev$product_level = 'BUILD_B221'
*copyc cycleB2_exceptions
*ELSE
*copyc BUILD_B221_contents
*IFEND
*DECK DECK=BUILD_B221_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B221_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B221_STATUS kind=status
IFEND
 exclude_feature cyber_96x_512_mb_memory_mm      status=BUILD_B221_STATUS
 exclude_feature daylight_time_1991              status=BUILD_B221_STATUS
 exclude_feature handle_monitor_dues             status=BUILD_B221_STATUS
 exclude_feature handle_monitor_dues_2           status=BUILD_B221_STATUS
 exclude_feature nv08483                         status=BUILD_B221_STATUS
 exclude_feature nv08525                         status=BUILD_B221_STATUS
 exclude_feature nv08573                         status=BUILD_B221_STATUS
 exclude_feature nv08628                         status=BUILD_B221_STATUS
 exclude_feature nv08759                         status=BUILD_B221_STATUS
 exclude_feature nv08773                         status=BUILD_B221_STATUS
 exclude_feature nv08794                         status=BUILD_B221_STATUS
 exclude_feature nv08804                         status=BUILD_B221_STATUS
 exclude_feature nv08835                         status=BUILD_B221_STATUS
 exclude_feature nv08863                         status=BUILD_B221_STATUS
 exclude_feature nv0u796                         status=BUILD_B221_STATUS
 exclude_feature nv0u978a                        status=BUILD_B221_STATUS
 exclude_feature nv0u996                         status=BUILD_B221_STATUS
 exclude_feature nv0u996_ds                      status=BUILD_B221_STATUS
 exclude_feature nv0v014                         status=BUILD_B221_STATUS
 exclude_feature nv0v025                         status=BUILD_B221_STATUS
 exclude_feature nv0v027                         status=BUILD_B221_STATUS
 exclude_feature nv0v032                         status=BUILD_B221_STATUS
 exclude_feature tcv0152_os                      status=BUILD_B221_STATUS
 exclude_feature update_senom_message_in_writo   status=BUILD_B221_STATUS
*DECK DECK=BUILD_B221_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B222_NEW_DECKS
*IF bev$product_level = 'BUILD_B221_NEW_DECKS'
*copyc cycleB2_exceptions
*ELSE
*copyc BUILD_B221_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B221_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B221_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B221_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck DFP$CLIENT_MAINFRAMES_DISPLAY     status=BUILD_B221_NEW_DECKS_STATUS
 exclude_deck I#MTR_DISABLE_TRAPS               status=BUILD_B221_NEW_DECKS_STATUS
 exclude_deck I#MTR_ENABLE_TRAPS                status=BUILD_B221_NEW_DECKS_STATUS
 exclude_deck I#MTR_RESTORE_TRAPS               status=BUILD_B221_NEW_DECKS_STATUS
 exclude_deck I#SYNC                            status=BUILD_B221_NEW_DECKS_STATUS
 exclude_deck MTT$MONITOR_CONDITIONS            status=BUILD_B221_NEW_DECKS_STATUS
*DECK DECK=BUILD_B222 EXPAND=TRUE
*copyc BUILD_B226
*IF bev$product_level = 'BUILD_B222'
*copyc cycleB2_exceptions
*ELSE
*copyc BUILD_B222_contents
*IFEND
*DECK DECK=BUILD_B222_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B222_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B222_STATUS kind=status
IFEND
 exclude_feature handle_monitor_dues_3           status=BUILD_B222_STATUS
 exclude_feature nv08742                         status=BUILD_B222_STATUS
 exclude_feature raise_cycle_busy_cond_in_open   status=BUILD_B222_STATUS
*DECK DECK=BUILD_B222_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B226_NEW_DECKS
*IF bev$product_level = 'BUILD_B222_NEW_DECKS'
*copyc cycleB2_exceptions
*ELSE
*copyc BUILD_B222_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B222_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B226 EXPAND=TRUE
*copyc BUILD_B301
*IF bev$product_level = 'BUILD_B226'
*copyc cycleB2_exceptions
*ELSE
*copyc BUILD_B226_contents
*IFEND
*DECK DECK=BUILD_B226_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B226_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B226_STATUS kind=status
IFEND
 exclude_feature bcu_helper                      status=BUILD_B226_STATUS
 exclude_feature ei_support_for_512_mb           status=BUILD_B226_STATUS
 exclude_feature i4_43_os_support_ds             status=BUILD_B226_STATUS
 exclude_feature i4cr_os_support                 status=BUILD_B226_STATUS
 exclude_feature namve_small_memory_2            status=BUILD_B226_STATUS
 exclude_feature ntf_configuration_enhance_os    status=BUILD_B226_STATUS
 exclude_feature nv08571                         status=BUILD_B226_STATUS
 exclude_feature nv08602                         status=BUILD_B226_STATUS
 exclude_feature nv08832                         status=BUILD_B226_STATUS
 exclude_feature nv08871                         status=BUILD_B226_STATUS
 exclude_feature nv08878                         status=BUILD_B226_STATUS
 exclude_feature nv0u967                         status=BUILD_B226_STATUS
 exclude_feature nv0v019                         status=BUILD_B226_STATUS
 exclude_feature nv0v021                         status=BUILD_B226_STATUS
 exclude_feature nv0v033                         status=BUILD_B226_STATUS
 exclude_feature nv0v035                         status=BUILD_B226_STATUS
 exclude_feature nv0v041                         status=BUILD_B226_STATUS
 exclude_feature spinnaker_iia                   status=BUILD_B226_STATUS
*DECK DECK=BUILD_B226_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B301_NEW_DECKS
*IF bev$product_level = 'BUILD_B226_NEW_DECKS'
*copyc cycleB2_exceptions
*ELSE
*copyc BUILD_B226_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B226_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B226_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B226_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CMP$GET_DRIVER_BY_CONTROLLER      status=BUILD_B226_NEW_DECKS_STATUS
 exclude_deck IOM$TAPF                          status=BUILD_B226_NEW_DECKS_STATUS
 exclude_deck QCM$BCU_HELPER_JT223              status=BUILD_B226_NEW_DECKS_STATUS
 exclude_deck QCM$BCU_HELPER_JT236              status=BUILD_B226_NEW_DECKS_STATUS
 exclude_deck QCM$BCU_HELPER_JT23D              status=BUILD_B226_NEW_DECKS_STATUS
 exclude_deck QCM$BCU_HELPER_JT2DD              status=BUILD_B226_NEW_DECKS_STATUS
 exclude_deck QCM$BCU_HELPER_MONITOR            status=BUILD_B226_NEW_DECKS_STATUS
 exclude_deck QCM$BCU_HELPER_SC113              status=BUILD_B226_NEW_DECKS_STATUS
 exclude_deck QCM$BCU_HELPER_SC133              status=BUILD_B226_NEW_DECKS_STATUS
 exclude_deck QCM$BCU_HELPER_SC13D              status=BUILD_B226_NEW_DECKS_STATUS
 exclude_deck QCM$BCU_HELPER_SC1DD              status=BUILD_B226_NEW_DECKS_STATUS
*DECK DECK=BUILD_B271 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B201 '
*copyc BUILD_B201
*IFEND
IF $variable(build_b271_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_b271_status kind=status
IFEND
 include_feature nv0u948                         status=build_b271_status
 include_feature cm_flawing                      status=build_b271_status
 include_feature dft0046                         status=build_b271_status
 include_feature dft0046_fix                     status=build_b271_status
 include_feature electronic_qcu_43               status=build_b271_status
 include_feature nv06409                         status=build_b271_status
 include_feature nv07152                         status=build_b271_status
 include_feature nv07884                         status=build_b271_status
 include_feature nv08249                         status=build_b271_status
 include_feature nv08280                         status=build_b271_status
 include_feature nv08318                         status=build_b271_status
 include_feature nv08319                         status=build_b271_status
 include_feature nv08383                         status=build_b271_status
 include_feature nv08456_161                     status=build_b271_status
 include_feature nv08512                         status=build_b271_status
 include_feature nv08545                         status=build_b271_status
 include_feature nv08553                         status=build_b271_status
 include_feature nv08580                         status=build_b271_status
 include_feature nv08609                         status=build_b271_status
 include_feature nv08618                         status=build_b271_status
 include_feature nv08620                         status=build_b271_status
 include_feature nv08649                         status=build_b271_status
 include_feature nv08692                         status=build_b271_status
 include_feature nv08694                         status=build_b271_status
 include_feature nv08698                         status=build_b271_status
 include_feature nv08700                         status=build_b271_status
 include_feature nv08706                         status=build_b271_status
 include_feature nv08710                         status=build_b271_status
 include_feature nv08745                         status=build_b271_status
 include_feature nv08760                         status=build_b271_status
 include_feature nv0s406                         status=build_b271_status
 include_feature nv0u978                         status=build_b271_status
 include_feature nv0u984                         status=build_b271_status
 include_feature nv0u989                         status=build_b271_status
 include_feature nv0u990                         status=build_b271_status
 include_feature remove_cle$unexpected_qual_kind status=build_b271_status
 include_feature spinnaker_ii                    status=build_b271_status
*DECK DECK=BUILD_B272 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B201 '
*copyc BUILD_B201
*IFEND
*copyc BUILD_B271
IF $variable(build_b272_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_b272_status kind=status
IFEND
 include_feature basisplus_profile_update        status=build_b272_status
 include_feature nv03555                         status=build_b272_status
 include_feature nv05421                         status=build_b272_status
 include_feature nv08622                         status=build_b272_status
 include_feature nv08688                         status=build_b272_status
 include_feature nv08771                         status=build_b272_status
 include_feature nv08817                         status=build_b272_status
 include_feature nv0u027                         status=build_b272_status
 include_feature nv0u955                         status=build_b272_status
 include_feature nv0v007                         status=build_b272_status
 include_feature pewter_expresslink              status=build_b272_status
 include_feature screen_formatting_speedup_3     status=build_b272_status
 include_feature ftp_accounting_os               status=build_b272_status
 include_feature auto_reconfiguration            status=build_b272_status
 include_feature auto_reconfiguration_ajl        status=build_b272_status
 include_feature nv07729                         status=build_b272_status
 include_feature nv08425                         status=build_b272_status
 include_feature nv08537                         status=build_b272_status
 include_feature nv08610                         status=build_b272_status
 include_feature nv08703                         status=build_b272_status
 include_feature nv0u900                         status=build_b272_status
*DECK DECK=BUILD_B273 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B212 '
*copyc BUILD_B212
*IFEND
IF $variable(build_b273_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_b273_status kind=status
IFEND
 include_feature daylight_time_1991              status=build_b273_status
 include_feature handle_monitor_dues             status=build_b273_status
 include_feature handle_monitor_dues_2           status=build_b273_status
 include_feature nv08525                         status=build_b273_status
 include_feature nv08573                         status=build_b273_status
 include_feature nv08628                         status=build_b273_status
 include_feature nv08759                         status=build_b273_status
 include_feature nv08773                         status=build_b273_status
 include_feature nv08794                         status=build_b273_status
 include_feature nv08804                         status=build_b273_status
 include_feature nv08835                         status=build_b273_status
 include_feature nv0u796                         status=build_b273_status
 include_feature nv0u996                         status=build_b273_status
 include_feature nv0u996_ds                      status=build_b273_status
 include_feature nv0v014                         status=build_b273_status
 include_feature nv0v025                         status=build_b273_status
 include_feature tcv0152_os                      status=build_b273_status
 include_feature update_senom_message_in_writo   status=build_b273_status
*DECK DECK=BUILD_B274 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B221 '
*copyc BUILD_B221
*IFEND
IF $variable(build_b274_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_b274_status kind=status
IFEND
 include_feature handle_monitor_dues_3           status=build_b274_status
 include_feature mv2a671_sou                     status=build_b274_status
 include_feature mv2a779_os                      status=build_b274_status
 include_feature mv2a779_os_2                    status=build_b274_status
 include_feature namve_small_memory_2            status=build_b274_status
 include_feature ntf_configuration_enhance_os    status=build_b274_status
 include_feature nv08832                         status=build_b274_status
 include_feature nv08872                         status=build_b274_status
 include_feature nv0u967                         status=build_b274_status
 include_feature nv0v019                         status=build_b274_status
 include_feature nv0v021                         status=build_b274_status
 include_feature nv0v033                         status=build_b274_status
 include_feature raise_cycle_busy_cond_in_open   status=build_b274_status
 include_feature ip_broadcast_os                 status=build_b274_status
*DECK DECK=BUILD_B281 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B201 '
*copyc BUILD_B201
*IFEND
*DECK DECK=BUILD_B291 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B212 '
*copyc BUILD_B212
*IFEND
*DECK DECK=BUILD_B301 EXPAND=TRUE
*copyc BUILD_B303
*IF bev$product_level = 'BUILD_B301'
*copyc cycleB3_exceptions
*ELSE
*copyc BUILD_B301_contents
*IFEND
*DECK DECK=BUILD_B301_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B301_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B301_STATUS kind=status
IFEND
 exclude_feature concurrent_tape_arc_ret_jcl_g   status=BUILD_B301_STATUS
 exclude_feature cpu_reinstatement               status=BUILD_B301_STATUS
 exclude_feature cpu_reinstatement_ds            status=BUILD_B301_STATUS
 exclude_feature ds_update_level_to_780          status=BUILD_B301_STATUS
 exclude_feature ftma029a                        status=BUILD_B301_STATUS
 exclude_feature i4cr_os_support_dft             status=BUILD_B301_STATUS
 exclude_feature ip_broadcast_os                 status=BUILD_B301_STATUS
 exclude_feature mv2a671_sou                     status=BUILD_B301_STATUS
 exclude_feature mv2a779_os                      status=BUILD_B301_STATUS
 exclude_feature mv2a779_os_2                    status=BUILD_B301_STATUS
 exclude_feature nfsa182_os                      status=BUILD_B301_STATUS
 exclude_feature nosve_disk_formatting           status=BUILD_B301_STATUS
 exclude_feature nv08008                         status=BUILD_B301_STATUS
 exclude_feature nv08826                         status=BUILD_B301_STATUS
 exclude_feature nv08872                         status=BUILD_B301_STATUS
 exclude_feature nv08909                         status=BUILD_B301_STATUS
 exclude_feature nv08921                         status=BUILD_B301_STATUS
 exclude_feature nv08926                         status=BUILD_B301_STATUS
 exclude_feature nv0v036                         status=BUILD_B301_STATUS
 exclude_feature nv0v045                         status=BUILD_B301_STATUS
 exclude_feature nv0v048                         status=BUILD_B301_STATUS
 exclude_feature qtfve_support_generic_queues    status=BUILD_B301_STATUS
 exclude_feature release_data_on_missing_volume  status=BUILD_B301_STATUS
 exclude_feature i4cr_os_support_2               status=BUILD_B301_STATUS
*DECK DECK=BUILD_B301_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B303_NEW_DECKS
*IF bev$product_level = 'BUILD_B301_NEW_DECKS'
*copyc cycleB3_exceptions
*ELSE
*copyc BUILD_B301_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B301_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B301_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B301_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CMP$ENABLE_PRODUCTION_R3          status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck DST$CHANGE_PROCESSOR_STATE        status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck DST$PROCESSOR_DOWN_REASON         status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck FDH$CONVERT_YYMMDD_TO_DATE_TIME   status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck FDP$CONVERT_YYMMDD_TO_DATE_TIME   status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck FDP$DATE_VARIABLE                 status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck FDT$INPUT_FORMAT_KEY_SET          status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck IOM$CLBTP                         status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck MTV$MONITOR_STACK_CPU_0_P         status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck NFC$QTF_NAME_CONSTANTS            status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck NFH$QTF_PRIF_OPTIONS              status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck NFH$QTF_SUBJ_OPTIONS              status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck NFT$GENERIC_DESCRIPTOR            status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck OSP$ALERT_KEYP_CPU_STATE_CHNG     status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck OSP$HANDLE_KEYP_ENVIRON_CHANGE    status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck OST$CPU_DOWN_STATE_REASON         status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck PFP$PURGE_OBJECT                  status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck PFP$PUT_CATALOG_SEGMENT           status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck PFP$R2_PURGE_OBJECT               status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck PFP$R2_PUT_CATALOG_SEGMENT        status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck PFT$RELEASE_DATA_INFO             status=BUILD_B301_NEW_DECKS_STATUS
 exclude_deck IOM$E9Q5698                       status=BUILD_B301_NEW_DECKS_STATUS
*DECK DECK=BUILD_B303 EXPAND=TRUE
*copyc BUILD_B304
*IF bev$product_level = 'BUILD_B303'
*copyc cycleB3_exceptions
*ELSE
*copyc BUILD_B303_contents
*IFEND
*DECK DECK=BUILD_B303_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B303_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B303_STATUS kind=status
IFEND
 exclude_feature auto_recon_fix_1                status=BUILD_B303_STATUS
 exclude_feature auto_recon_fix_2                status=BUILD_B303_STATUS
 exclude_feature basic_tape_security_phase_2     status=BUILD_B303_STATUS
 exclude_feature basic_tape_security_phase_2_f1  status=BUILD_B303_STATUS
 exclude_feature basic_tape_security_phase_2sc   status=BUILD_B303_STATUS
 exclude_feature i4_43_os_support_ds_fix_1       status=BUILD_B303_STATUS
 exclude_feature nv08631                         status=BUILD_B303_STATUS
 exclude_feature nv08653                         status=BUILD_B303_STATUS
 exclude_feature nv08653_2                       status=BUILD_B303_STATUS
 exclude_feature nv08660                         status=BUILD_B303_STATUS
 exclude_feature nv08857                         status=BUILD_B303_STATUS
 exclude_feature nv08904                         status=BUILD_B303_STATUS
 exclude_feature nv08931                         status=BUILD_B303_STATUS
 exclude_feature nv0u449                         status=BUILD_B303_STATUS
 exclude_feature nv0v018                         status=BUILD_B303_STATUS
 exclude_feature nv0v050                         status=BUILD_B303_STATUS
 exclude_feature nv0v059                         status=BUILD_B303_STATUS
*DECK DECK=BUILD_B303_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B304_NEW_DECKS
*IF bev$product_level = 'BUILD_B303_NEW_DECKS'
*copyc cycleB3_exceptions
*ELSE
*copyc BUILD_B303_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B303_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B303_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B303_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck AME$LABEL_VALIDATION_ERRORS       status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck AVH$GET_REMOVABLE_MEDIA_ACCESS    status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck AVP$GET_REMOVABLE_MEDIA_ACCESS    status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck CMP$ACTIVATE_SIGNAL_HANDLER       status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck CMP$FREE_DEADSTART_SIGNALS        status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck CMP$PROCESS_DEADSTART_SIGNALS     status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck CMP$QUEUE_DEADSTART_SIGNAL        status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck CMT$DEADSTART_SIGNAL              status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck CMV$DEADSTART_SIGNALS             status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck CMV$SIGNAL_HANDLER_ACTIVE         status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck DMP$CREATE_MAT                    status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck DMP$CREATE_MFL                    status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck DMP$DELETE_MAT                    status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck DMP$DELETE_MFL                    status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSC$MAX_TAPE_LABELS               status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSC$MAX_TAPE_LABEL_BLOCK_TYPE     status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSC$MAX_TAPE_LABEL_LENGTH         status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSC$MAX_TAPE_LABEL_LOC_METHOD     status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSC$MAX_TAPE_SECURITY_OPERATION   status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSC$MIN_TAPE_LABEL_LENGTH         status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSC$VERSION_ONE_VE_IDENTIFIER     status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSC$VERSION_TWO_VE_IDENTIFIER     status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSD$ANSI_LABEL_IDENTIFIERS        status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSH$ANALYZE_FILE_EXPIRATION       status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSH$FILE_HEADER_LABELS            status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSH$FILE_TRAILER_LABELS           status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSH$HEADER_LABELS                 status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSH$LOCATE_TAPE_LABEL             status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSH$TRAILER_LABELS                status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSH$VERSION_ONE_TAPE_LABEL        status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSH$VERSION_TWO_TAPE_LABEL        status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSH$VE_WROTE_ANSI_FILE            status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSH$VOLUME_HEADER_LABELS          status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSH$VOLUME_TRAILER_LABELS         status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSP$ANALYZE_FILE_EXPIRATION       status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSP$FILE_HEADER_LABELS            status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSP$FILE_TRAILER_LABELS           status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSP$HEADER_LABELS                 status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSP$LOCATE_TAPE_LABEL             status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSP$TRAILER_LABELS                status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSP$VERSION_ONE_TAPE_LABEL        status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSP$VERSION_TWO_TAPE_LABEL        status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSP$VE_WROTE_ANSI_FILE            status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSP$VOLUME_HEADER_LABELS          status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FSP$VOLUME_TRAILER_LABELS         status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$ANSI_LABEL_IDENTIFIER         status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$ANSI_LABEL_KIND               status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$ANSI_LABEL_KINDS              status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$ANSI_LABEL_NUMBER             status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TAPE_BLOCK_LENGTH             status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TAPE_LABEL_BLOCK_DESCRIPTOR   status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TAPE_LABEL_BLOCK_TYPE         status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TAPE_LABEL_COUNT              status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TAPE_LABEL_IDENTIFIER         status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TAPE_LABEL_LENGTH             status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TAPE_LABEL_LOCATION_METHOD    status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TAPE_LABEL_LOCATOR            status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TAPE_LABEL_SEQUENCE_HEADER    status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TAPE_SECURITY_CALL_BLOCK      status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TAPE_SECURITY_OPERATION       status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TAPE_VOLUME_INITIALIZATION    status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TS_AUTHORIZE_ACCESS_METHOD    status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TS_AUTHORIZE_FILE_ACCESS      status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TS_AUTHORIZE_FILE_REUSE       status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TS_AUTHORIZE_FILE_SECTION     status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TS_AUTHORIZE_FILE_SET_MOUNT   status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TS_AUTHORIZE_FILE_SET_REUSE   status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TS_AUTHORIZE_OBJECT_REUSE     status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TS_AUTHORIZE_VOLUME_ACCESS    status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TS_AUTHORIZE_VOLUME_MOUNT     status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TS_AUTHORIZE_VOLUME_REUSE     status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TS_SECURE_HEADER_LABELS       status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TS_SECURE_TRAILER_LABELS      status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TS_VALIDATE_HEADER_LABELS     status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$TS_VALIDATE_TRAILER_LABELS    status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$VOLUME_CONFIRMATION_OPTION    status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck FST$VOLUME_CONFIRMATION_OPTIONS   status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck IOT$REQUESTED_VOLUME_ATTRIBUTES   status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck RMC$LABELED_EXTERNAL_TAPES        status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck RMC$UNLABELED_TAPES               status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck RME$CREBLV_ERRORS                 status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck RMH$CLASSIFY_TAPE_VOLUME          status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck RMH$ENFORCE_TAPE_SECURITY         status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck RMP$CLASSIFY_TAPE_VOLUME          status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck RMP$ENFORCE_TAPE_SECURITY         status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck RMT$LABELED_TAPE_CLASSIFICATION   status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck RMT$MANRM_STATUS                  status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck RMT$RESTRICTED_ACCESS_REASON      status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck RMT$TAPE_VOLUME_CLASSIFICATION    status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck RMT$VOLUME_LABEL_TYPE             status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck RMT$VOLUME_SECURITY_TYPE          status=BUILD_B303_NEW_DECKS_STATUS
 exclude_deck SYP$WRITE_OUTPUT_HEADER           status=BUILD_B303_NEW_DECKS_STATUS
*DECK DECK=BUILD_B304 EXPAND=TRUE
*copyc BUILD_B311
*IF bev$product_level = 'BUILD_B304'
*copyc cycleB3_exceptions
*ELSE
*copyc BUILD_B304_contents
*IFEND
*DECK DECK=BUILD_B304_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B304_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B311_NEW_DECKS
*IF bev$product_level = 'BUILD_B304_NEW_DECKS'
*copyc cycleB3_exceptions
*ELSE
*copyc BUILD_B304_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B304_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B311 EXPAND=TRUE
*copyc BUILD_B312
*IF bev$product_level = 'BUILD_B311'
*copyc cycleB3_exceptions
*ELSE
*copyc BUILD_B311_contents
*IFEND
*DECK DECK=BUILD_B311_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B311_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B311_STATUS kind=status
IFEND
 exclude_feature cm_release_of_pp_fix            status=BUILD_B311_STATUS
 exclude_feature cpu_reinstatement_ds_fix_1      status=BUILD_B311_STATUS
 exclude_feature fix_dft_rq_protocol_cpu_reinst  status=BUILD_B311_STATUS
 exclude_feature fix_idle_stats_line             status=BUILD_B311_STATUS
 exclude_feature i4cr_os_support_dft_1           status=BUILD_B311_STATUS
 exclude_feature namve_small_memory_3            status=BUILD_B311_STATUS
 exclude_feature new_fsc_decks                   status=BUILD_B311_STATUS
 exclude_feature nv08225                         status=BUILD_B311_STATUS
 exclude_feature nv08265                         status=BUILD_B311_STATUS
 exclude_feature nv08541                         status=BUILD_B311_STATUS
 exclude_feature nv08604                         status=BUILD_B311_STATUS
 exclude_feature nv08683                         status=BUILD_B311_STATUS
 exclude_feature nv08742_1                       status=BUILD_B311_STATUS
 exclude_feature nv08795                         status=BUILD_B311_STATUS
 exclude_feature nv08813                         status=BUILD_B311_STATUS
 exclude_feature nv08905                         status=BUILD_B311_STATUS
 exclude_feature nv0p957                         status=BUILD_B311_STATUS
 exclude_feature nv0u068                         status=BUILD_B311_STATUS
 exclude_feature nv0u513                         status=BUILD_B311_STATUS
 exclude_feature nv0u870_2                       status=BUILD_B311_STATUS
 exclude_feature nv0u870_3                       status=BUILD_B311_STATUS
 exclude_feature nv0v009                         status=BUILD_B311_STATUS
 exclude_feature nv0v023                         status=BUILD_B311_STATUS
 exclude_feature nv0v055                         status=BUILD_B311_STATUS
 exclude_feature nv0v056                         status=BUILD_B311_STATUS
 exclude_feature nv0v064                         status=BUILD_B311_STATUS
 exclude_feature nv0v071                         status=BUILD_B311_STATUS
 exclude_feature tcv0158_os                      status=BUILD_B311_STATUS
 exclude_feature basic_tape_security_phase_2_f2  status=BUILD_B311_STATUS
*DECK DECK=BUILD_B311_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B312_NEW_DECKS
*IF bev$product_level = 'BUILD_B311_NEW_DECKS'
*copyc cycleB3_exceptions
*ELSE
*copyc BUILD_B311_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B311_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B311_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B311_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CMP$GET_ELEMENT_ENTRY_VIA_LUN     status=BUILD_B311_NEW_DECKS_STATUS
 exclude_deck CMP$LOCATE_ELEMENT_VIA_LUN        status=BUILD_B311_NEW_DECKS_STATUS
 exclude_deck CSP$DISABLE_PAGE                  status=BUILD_B311_NEW_DECKS_STATUS
 exclude_deck CSP$ENABLE_PAGE                   status=BUILD_B311_NEW_DECKS_STATUS
 exclude_deck DSV$AUTOMATIC_SYSTEM_RESTART      status=BUILD_B311_NEW_DECKS_STATUS
 exclude_deck MTV$DUAL_STATE_CPU_NUMBER         status=BUILD_B311_NEW_DECKS_STATUS
 exclude_deck PFH$CHANGE_RES_TO_RELEASABLE      status=BUILD_B311_NEW_DECKS_STATUS
 exclude_deck PFP$CHANGE_RES_TO_RELEASABLE      status=BUILD_B311_NEW_DECKS_STATUS
 exclude_deck PFP$R2_CHANGE_RES_TO_RELEASABLE   status=BUILD_B311_NEW_DECKS_STATUS
 exclude_deck PFP$R2_DF_CLIENT_CHANGE_RES_REL   status=BUILD_B311_NEW_DECKS_STATUS
 exclude_deck PFP$R3_CHANGE_RES_TO_RELEASABLE   status=BUILD_B311_NEW_DECKS_STATUS
 exclude_deck PFT$DF_CHANGE_RESIDENCE_IN        status=BUILD_B311_NEW_DECKS_STATUS
 exclude_deck TMP$CHANGE_TASKS_170_CP_SELECTS   status=BUILD_B311_NEW_DECKS_STATUS
*DECK DECK=BUILD_B312 EXPAND=TRUE
*copyc BUILD_B321
*IF bev$product_level = 'BUILD_B312'
*copyc cycleB3_exceptions
*ELSE
*copyc BUILD_B312_contents
*IFEND
*DECK DECK=BUILD_B312_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B312_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B312_STATUS kind=status
IFEND
 exclude_feature cyber_96x_512_mb_memory_mm_2    status=BUILD_B312_STATUS
 exclude_feature nosve_disk_formatting_fix_1     status=BUILD_B312_STATUS
 exclude_feature nv08849_161                     status=BUILD_B312_STATUS
 exclude_feature nv08970                         status=BUILD_B312_STATUS
 exclude_feature nv0u043                         status=BUILD_B312_STATUS
 exclude_feature nv0v062                         status=BUILD_B312_STATUS
 exclude_feature tcva322                         status=BUILD_B312_STATUS
*DECK DECK=BUILD_B312_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B321_NEW_DECKS
*IF bev$product_level = 'BUILD_B312_NEW_DECKS'
*copyc cycleB3_exceptions
*ELSE
*copyc BUILD_B312_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B312_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B321 EXPAND=TRUE
*copyc BUILD_B322
*IF bev$product_level = 'BUILD_B321'
*copyc cycleB3_exceptions
*ELSE
*copyc BUILD_B321_contents
*IFEND
*DECK DECK=BUILD_B321_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B321_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B321_STATUS kind=status
IFEND
 exclude_feature basic_tape_security_phase_3     status=BUILD_B321_STATUS
 exclude_feature basic_tape_security_phase_3sc   status=BUILD_B321_STATUS
 exclude_feature determine_number_of_tapes       status=BUILD_B321_STATUS
 exclude_feature ftma030os                       status=BUILD_B321_STATUS
 exclude_feature restore_output_applications     status=BUILD_B321_STATUS
 exclude_feature basic_tape_security_phase_3f1   status=BUILD_B321_STATUS
 exclude_feature basic_tape_security_phase_3f2   status=BUILD_B321_STATUS
*DECK DECK=BUILD_B321_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B322_NEW_DECKS
*IF bev$product_level = 'BUILD_B321_NEW_DECKS'
*copyc cycleB3_exceptions
*ELSE
*copyc BUILD_B321_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B321_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B321_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B321_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck BAI$STATE_INFO                    status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck BAM$SYSTEM_TAPE_LABEL_FAP_RING2   status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck BAP$AFTER_TRAILER_LABELS          status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck BAP$DISMOUNT_TAPE_VOLUME          status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck BAP$FREE_TAPE_LABEL_SEQUENCES     status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck BAP$GET_TAPE_ELEMENT_NAME         status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck BAP$NEXT_POSITION_IS_BOS          status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck BAP$STORE_UNSECURED_TAPE_LABELS   status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck BAP$VOLUME_ROBOTICALLY_MOUNTED    status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck BAT$INITIAL_VOLUME_CONTROL_INFO   status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck BAT$LABELED_TAPE_STATE_INFO       status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck BAT$LABELED_VOLUME_POSITION       status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck BAT$LAST_ACCESSED_LABELS          status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck BAT$NEXT_POSITION_CONTROL_INFO    status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck BAV$LABELED_TAPE_STATE_INFO       status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck FMM$GET_TAPE_LABEL_ATTRIBUTES     status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck FMP$ADJUST_FILE_SET_POS_VALUES    status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck FMP$GET_TAPE_LABEL_ATTRIBUTES     status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck FSH$CLASSIFY_TAPE_LABEL           status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck FSM$TAPE_LABEL_INTERFACES_2DD     status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck FSP$CLASSIFY_TAPE_LABEL           status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck FSP$VALIDATE_STRING               status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck FST$SUPPLIED_FILE_SET_POSITIONS   status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck FST$TAPE_LABEL_CLASSIFICATION     status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck FST$TS_AUTHORIZE_SECTION_READ     status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck FST$TS_AUTHORIZE_SECTION_WRITE    status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck RAM$COMPARE_LABELED_VOLUMES       status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck RAM$COMPARE_UNLABELED_VOLUMES     status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck RAM$DETERMINE_NUMBER_OF_TAPES     status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck RAM$DISPLAY_FILE_SET_ATTRIBUTES   status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck RAM$DUPLICATE_LABELED_VOLUME      status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck RAM$DUPLICATE_UNLABELED_VOLUME    status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck RAP$CREATE_BLANK_LABELED_VOLUME   status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck RAP$CREATE_BLANK_UNLABELED_VOL    status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck RAP$GET_FILE_PATH                 status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck RMM$CREATE_BLANK_VOLUMES          status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck RMM$ENFORCE_TAPE_SECURITY         status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck RMP$INITIALIZE_TAPE_VOLUME        status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck RMP$VALIDATE_SPECIFIED_RMG        status=BUILD_B321_NEW_DECKS_STATUS
 exclude_deck RMV$REQUESTED_VOLUME_ATTRIBUTES   status=BUILD_B321_NEW_DECKS_STATUS
*DECK DECK=BUILD_B322 EXPAND=TRUE
*copyc BUILD_B360
*IF bev$product_level = 'BUILD_B322'
*copyc cycleB3_exceptions
*ELSE
*copyc BUILD_B322_contents
*IFEND
*DECK DECK=BUILD_B322_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B322_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B322_STATUS kind=status
IFEND
 exclude_feature basic_tape_security_phase_3f3   status=BUILD_B322_STATUS
 exclude_feature ip_broadcast_os_2               status=BUILD_B322_STATUS
 exclude_feature network_queueing_system_os_5    status=BUILD_B322_STATUS
 exclude_feature network_queueing_system_os_6    status=BUILD_B322_STATUS
 exclude_feature nosve_disk_formatting_fix_2     status=BUILD_B322_STATUS
 exclude_feature nv0v065                         status=BUILD_B322_STATUS
 exclude_feature nv0v066                         status=BUILD_B322_STATUS
 exclude_feature nv0v073                         status=BUILD_B322_STATUS
 exclude_feature nv0v079                         status=BUILD_B322_STATUS
 exclude_feature nv0v084                         status=BUILD_B322_STATUS
 exclude_feature pup$construct_volume_list_fix   status=BUILD_B322_STATUS
 exclude_feature basic_tape_security_phase_3f4   status=BUILD_B322_STATUS
*DECK DECK=BUILD_B322_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B360_NEW_DECKS
*IF bev$product_level = 'BUILD_B322_NEW_DECKS'
*copyc cycleB3_exceptions
*ELSE
*copyc BUILD_B322_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B322_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B322_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B322_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CMP$PROCESS_FORCE_FORMAT          status=BUILD_B322_NEW_DECKS_STATUS
 exclude_deck DMP$PROCESS_FORCE_FORMAT          status=BUILD_B322_NEW_DECKS_STATUS
*DECK DECK=BUILD_B360 EXPAND=TRUE
*copyc BUILD_B401
*IF bev$product_level = 'BUILD_B360'
*copyc cycleB3_exceptions
*ELSE
*copyc BUILD_B360_contents
*IFEND
*DECK DECK=BUILD_B360_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B360_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B360_STATUS kind=status
IFEND
 exclude_feature auto_recon_fix_3                status=BUILD_B360_STATUS
 exclude_feature basic_tape_security_phase_3f5   status=BUILD_B360_STATUS
 exclude_feature change_wrio_tp_parameter        status=BUILD_B360_STATUS
 exclude_feature cpu_reinstatement_fix_1         status=BUILD_B360_STATUS
 exclude_feature i4_43_os_support_ds_fix_2       status=BUILD_B360_STATUS
 exclude_feature nv07835                         status=BUILD_B360_STATUS
 exclude_feature nv08937                         status=BUILD_B360_STATUS
 exclude_feature nv08993                         status=BUILD_B360_STATUS
 exclude_feature nv09001                         status=BUILD_B360_STATUS
 exclude_feature nv09027                         status=BUILD_B360_STATUS
 exclude_feature nv09044                         status=BUILD_B360_STATUS
 exclude_feature nv0u659                         status=BUILD_B360_STATUS
 exclude_feature nv0v051                         status=BUILD_B360_STATUS
 exclude_feature nv0v058                         status=BUILD_B360_STATUS
 exclude_feature nv0v067                         status=BUILD_B360_STATUS
 exclude_feature tc0a001                         status=BUILD_B360_STATUS
*DECK DECK=BUILD_B360_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B401_NEW_DECKS
*IF bev$product_level = 'BUILD_B360_NEW_DECKS'
*copyc cycleB3_exceptions
*ELSE
*copyc BUILD_B360_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B360_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B360_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B360_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck MTT$MONITOR_XP_SLOT_POINTERS      status=BUILD_B360_NEW_DECKS_STATUS
 exclude_deck MTV$FIRST_CPU_MONITOR_STACK_P     status=BUILD_B360_NEW_DECKS_STATUS
 exclude_deck MTV$MONITOR_XP_SLOT_POINTERS      status=BUILD_B360_NEW_DECKS_STATUS
 exclude_deck RAM$DISPLAY_VOL_CLASSIFICATION    status=BUILD_B360_NEW_DECKS_STATUS
 exclude_deck RMC$VOL_CLASSIFICATION_MODULE     status=BUILD_B360_NEW_DECKS_STATUS
 exclude_deck RMC$VOL_CLASSIFICATION_PROMPT     status=BUILD_B360_NEW_DECKS_STATUS
 exclude_deck RMH$FORMAT_VOL_CLASSIFICATION     status=BUILD_B360_NEW_DECKS_STATUS
 exclude_deck RMP$FORMAT_VOL_CLASSIFICATION     status=BUILD_B360_NEW_DECKS_STATUS
*DECK DECK=BUILD_B401 EXPAND=TRUE
*copyc BUILD_B402
*IF bev$product_level = 'BUILD_B401'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B401_contents
*IFEND
*DECK DECK=BUILD_B401_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B401_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B401_STATUS kind=status
IFEND
 exclude_feature basic_tape_security_phase_3f6   status=BUILD_B401_STATUS
 exclude_feature fix_fu_berlin                   status=BUILD_B401_STATUS
 exclude_feature move_di_30044f                  status=BUILD_B401_STATUS
*DECK DECK=BUILD_B401_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B402_NEW_DECKS
*IF bev$product_level = 'BUILD_B401_NEW_DECKS'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B401_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B401_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B401_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B401_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck FMP$GET_GLOBAL_FILE_INFORMATION   status=BUILD_B401_NEW_DECKS_STATUS
 exclude_deck RAI$PROLOG_SN302_SABRE_2X8        status=BUILD_B401_NEW_DECKS_STATUS
 exclude_deck RAP$DISPLAY_VOL_CLASSIFICATION    status=BUILD_B401_NEW_DECKS_STATUS
 exclude_deck RMM$DISVC_R3_HELPER               status=BUILD_B401_NEW_DECKS_STATUS
 exclude_deck RMP$DISVC_R3_HELPER               status=BUILD_B401_NEW_DECKS_STATUS
*DECK DECK=BUILD_B402 EXPAND=TRUE
*copyc BUILD_B403
*IF bev$product_level = 'BUILD_B402'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B402_contents
*IFEND
*DECK DECK=BUILD_B402_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B402_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B402_STATUS kind=status
IFEND
 exclude_feature ar2a232                         status=BUILD_B402_STATUS
 exclude_feature basic_tape_security_phase_3f7   status=BUILD_B402_STATUS
 exclude_feature nv08326                         status=BUILD_B402_STATUS
 exclude_feature nv08758                         status=BUILD_B402_STATUS
 exclude_feature nv08815                         status=BUILD_B402_STATUS
 exclude_feature nv09003                         status=BUILD_B402_STATUS
 exclude_feature nv09009                         status=BUILD_B402_STATUS
 exclude_feature nv0v099                         status=BUILD_B402_STATUS
 exclude_feature nv0v104                         status=BUILD_B402_STATUS
 exclude_feature rmsa023_os                      status=BUILD_B402_STATUS
*DECK DECK=BUILD_B402_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B403_NEW_DECKS
*IF bev$product_level = 'BUILD_B402_NEW_DECKS'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B402_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B402_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B402_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B402_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck FMT$DETACHMENT_OPTIONS            status=BUILD_B402_NEW_DECKS_STATUS
 exclude_deck FMV$DEFAULT_DETACHMENT_OPTIONS    status=BUILD_B402_NEW_DECKS_STATUS
 exclude_deck FSC$MAX_DETACH_CHOICE             status=BUILD_B402_NEW_DECKS_STATUS
 exclude_deck FSH$DETACH_FILE                   status=BUILD_B402_NEW_DECKS_STATUS
 exclude_deck FSM$DETACH_FILE                   status=BUILD_B402_NEW_DECKS_STATUS
 exclude_deck FSP$DETACH_FILE                   status=BUILD_B402_NEW_DECKS_STATUS
 exclude_deck FST$DETACHMENT_OPTION             status=BUILD_B402_NEW_DECKS_STATUS
 exclude_deck FST$DETACHMENT_OPTIONS            status=BUILD_B402_NEW_DECKS_STATUS
 exclude_deck FST$FILE_DETACHMENT_CHOICES       status=BUILD_B402_NEW_DECKS_STATUS
*DECK DECK=BUILD_B403 EXPAND=TRUE
*copyc BUILD_B404
*IF bev$product_level = 'BUILD_B403'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B403_contents
*IFEND
*DECK DECK=BUILD_B403_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B403_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B403_STATUS kind=status
IFEND
 exclude_feature basic_tape_security_phase_3f8   status=BUILD_B403_STATUS
 exclude_feature dfta209                         status=BUILD_B403_STATUS
 exclude_feature dfta210                         status=BUILD_B403_STATUS
 exclude_feature electronic_qcu_61               status=BUILD_B403_STATUS
 exclude_feature electronic_qcu_62               status=BUILD_B403_STATUS
 exclude_feature handshaking_fix                 status=BUILD_B403_STATUS
 exclude_feature nv08874                         status=BUILD_B403_STATUS
 exclude_feature nv08967                         status=BUILD_B403_STATUS
 exclude_feature nv09072                         status=BUILD_B403_STATUS
 exclude_feature nv09087                         status=BUILD_B403_STATUS
 exclude_feature nv0v111                         status=BUILD_B403_STATUS
 exclude_feature nv0v112                         status=BUILD_B403_STATUS
 exclude_feature nv0v114                         status=BUILD_B403_STATUS
 exclude_feature nv0v118                         status=BUILD_B403_STATUS
 exclude_feature nv0v120                         status=BUILD_B403_STATUS
 exclude_feature nv0v124                         status=BUILD_B403_STATUS
*DECK DECK=BUILD_B403_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B404_NEW_DECKS
*IF bev$product_level = 'BUILD_B403_NEW_DECKS'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B403_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B403_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B404 EXPAND=TRUE
*copyc BUILD_B410
*IF bev$product_level = 'BUILD_B404'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B404_contents
*IFEND
*DECK DECK=BUILD_B404_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B404_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B404_STATUS kind=status
IFEND
 exclude_feature nv0v108                         status=BUILD_B404_STATUS
 exclude_feature nv0v135                         status=BUILD_B404_STATUS
 exclude_feature nv0v137                         status=BUILD_B404_STATUS
*DECK DECK=BUILD_B404_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B410_NEW_DECKS
*IF bev$product_level = 'BUILD_B404_NEW_DECKS'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B404_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B404_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B410 EXPAND=TRUE
*copyc BUILD_B411
*IF bev$product_level = 'BUILD_B410'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B410_contents
*IFEND
*DECK DECK=BUILD_B410_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B410_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B410_STATUS kind=status
IFEND
 exclude_feature basic_tape_security_phase_3f9   status=BUILD_B410_STATUS
 exclude_feature basic_tape_security_phase_3f10  status=BUILD_B410_STATUS
*DECK DECK=BUILD_B410_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B411_NEW_DECKS
*IF bev$product_level = 'BUILD_B410_NEW_DECKS'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B410_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B410_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B411 EXPAND=TRUE
*copyc BUILD_B412
*IF bev$product_level = 'BUILD_B411'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B411_contents
*IFEND
*DECK DECK=BUILD_B411_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B411_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B412_NEW_DECKS
*IF bev$product_level = 'BUILD_B411_NEW_DECKS'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B411_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B411_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B412 EXPAND=TRUE
*copyc BUILD_B414
*IF bev$product_level = 'BUILD_B412'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B412_contents
*IFEND
*DECK DECK=BUILD_B412_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B412_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B412_STATUS kind=status
IFEND
 exclude_feature add_empower_os_2                status=BUILD_B412_STATUS
 exclude_feature nv0v135_fix_1                   status=BUILD_B412_STATUS
 exclude_feature nv0v140                         status=BUILD_B412_STATUS
 exclude_feature nv0v141                         status=BUILD_B412_STATUS
*DECK DECK=BUILD_B412_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B414_NEW_DECKS
*IF bev$product_level = 'BUILD_B412_NEW_DECKS'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B412_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B412_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B414 EXPAND=TRUE
*copyc BUILD_B416
*IF bev$product_level = 'BUILD_B414'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B414_contents
*IFEND
*DECK DECK=BUILD_B414_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B414_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B416_NEW_DECKS
*IF bev$product_level = 'BUILD_B414_NEW_DECKS'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B414_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B414_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B416 EXPAND=TRUE
*copyc BUILD_B418
*IF bev$product_level = 'BUILD_B416'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B416_contents
*IFEND
*DECK DECK=BUILD_B416_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B416_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B416_STATUS kind=status
IFEND
 exclude_feature basic_tape_security_phase_3f12  status=BUILD_B416_STATUS
 exclude_feature ei_support_for_512_mb_fix_1     status=BUILD_B416_STATUS
 exclude_feature hotkey_prolog                   status=BUILD_B416_STATUS
 exclude_feature nv09162                         status=BUILD_B416_STATUS
 exclude_feature nv0v149                         status=BUILD_B416_STATUS
 exclude_feature validate_development_users_fix  status=BUILD_B416_STATUS
 exclude_feature basic_tape_security_phase_3f13  status=BUILD_B416_STATUS
*DECK DECK=BUILD_B416_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B418_NEW_DECKS
*IF bev$product_level = 'BUILD_B416_NEW_DECKS'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B416_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B416_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B416_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B416_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck RAI$PROLOG_SN302_SABRE_HOTKEY     status=BUILD_B416_NEW_DECKS_STATUS
*DECK DECK=BUILD_B418 EXPAND=TRUE
*copyc BUILD_B501
*IF bev$product_level = 'BUILD_B418'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B418_contents
*IFEND
*DECK DECK=BUILD_B418_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B418_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B418_STATUS kind=status
IFEND
 exclude_feature basic_tape_security_phase_3f14  status=BUILD_B418_STATUS
*DECK DECK=BUILD_B418_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B501_NEW_DECKS
*IF bev$product_level = 'BUILD_B418_NEW_DECKS'
*copyc cycleB4_exceptions
*ELSE
*copyc BUILD_B418_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B418_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B501 EXPAND=TRUE
*copyc BUILD_B502
*IF bev$product_level = 'BUILD_B501'
*copyc cycleB5_exceptions
*ELSE
*copyc BUILD_B501_contents
*IFEND
*DECK DECK=BUILD_B501_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B501_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B501_STATUS kind=status
IFEND
 exclude_feature nv08097                         status=BUILD_B501_STATUS
 exclude_feature nv08935                         status=BUILD_B501_STATUS
 exclude_feature nv09083                         status=BUILD_B501_STATUS
 exclude_feature nv09121                         status=BUILD_B501_STATUS
 exclude_feature nv09139                         status=BUILD_B501_STATUS
 exclude_feature nv09150                         status=BUILD_B501_STATUS
 exclude_feature nv09185                         status=BUILD_B501_STATUS
 exclude_feature nv09189                         status=BUILD_B501_STATUS
 exclude_feature nv0v125                         status=BUILD_B501_STATUS
 exclude_feature nv0v147                         status=BUILD_B501_STATUS
 exclude_feature nv0v155                         status=BUILD_B501_STATUS
 exclude_feature nv0v164                         status=BUILD_B501_STATUS
*DECK DECK=BUILD_B501_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B502_NEW_DECKS
*IF bev$product_level = 'BUILD_B501_NEW_DECKS'
*copyc cycleB5_exceptions
*ELSE
*copyc BUILD_B501_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B501_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B501_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B501_NEW_DECKS_STATUS kind=status
IFEND
*DECK DECK=BUILD_B502 EXPAND=TRUE
*copyc BUILD_B503
*IF bev$product_level = 'BUILD_B502'
*copyc cycleB5_exceptions
*ELSE
*copyc BUILD_B502_contents
*IFEND
*DECK DECK=BUILD_B502_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B502_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B502_STATUS kind=status
IFEND
 exclude_feature nfsa175_os                      status=BUILD_B502_STATUS
 exclude_feature nv07594                         status=BUILD_B502_STATUS
 exclude_feature nv07811                         status=BUILD_B502_STATUS
 exclude_feature nv08755                         status=BUILD_B502_STATUS
 exclude_feature nv09019                         status=BUILD_B502_STATUS
 exclude_feature nv09041                         status=BUILD_B502_STATUS
 exclude_feature nv09056                         status=BUILD_B502_STATUS
 exclude_feature nv09061                         status=BUILD_B502_STATUS
 exclude_feature nv09067                         status=BUILD_B502_STATUS
 exclude_feature nv0v101                         status=BUILD_B502_STATUS
 exclude_feature seg_20_trap_code                status=BUILD_B502_STATUS
*DECK DECK=BUILD_B502_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B503_NEW_DECKS
*IF bev$product_level = 'BUILD_B502_NEW_DECKS'
*copyc cycleB5_exceptions
*ELSE
*copyc BUILD_B502_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B502_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B502_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B502_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck DFP$CHECK_IF_VALID                status=BUILD_B502_NEW_DECKS_STATUS
 exclude_deck DFP$NEW_CRACK_MAINFRAME_ID        status=BUILD_B502_NEW_DECKS_STATUS
 exclude_deck MMH$LOCK_CATALOG_SEGMENT          status=BUILD_B502_NEW_DECKS_STATUS
 exclude_deck MMP$LOCK_CATALOG_SEGMENT          status=BUILD_B502_NEW_DECKS_STATUS
 exclude_deck PFP$UNLOCK_CATALOG_PAGES          status=BUILD_B502_NEW_DECKS_STATUS
 exclude_deck PFV$UNLOCK_CATALOG_THRESHOLD      status=BUILD_B502_NEW_DECKS_STATUS
*DECK DECK=BUILD_B503 EXPAND=TRUE
*copyc BUILD_B505
*IF bev$product_level = 'BUILD_B503'
*copyc cycleB5_exceptions
*ELSE
*copyc BUILD_B503_contents
*IFEND
*DECK DECK=BUILD_B503_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B503_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B503_STATUS kind=status
IFEND
 exclude_feature aio_limit                       status=BUILD_B503_STATUS
 exclude_feature backout_nv09150_code            status=BUILD_B503_STATUS
 exclude_feature basic_tape_security_phase_3f15  status=BUILD_B503_STATUS
 exclude_feature bcu_helper_l780aa               status=BUILD_B503_STATUS
 exclude_feature delete_max_tasks                status=BUILD_B503_STATUS
 exclude_feature delete_wef_tests_from_crete     status=BUILD_B503_STATUS
 exclude_feature electronic_qcu_71               status=BUILD_B503_STATUS
 exclude_feature mv20482_os                      status=BUILD_B503_STATUS
 exclude_feature nv09014                         status=BUILD_B503_STATUS
 exclude_feature nv09180                         status=BUILD_B503_STATUS
 exclude_feature nv09199                         status=BUILD_B503_STATUS
 exclude_feature nv09207                         status=BUILD_B503_STATUS
 exclude_feature nv09209                         status=BUILD_B503_STATUS
 exclude_feature nv0u337                         status=BUILD_B503_STATUS
 exclude_feature nv0v165                         status=BUILD_B503_STATUS
 exclude_feature nv0v173                         status=BUILD_B503_STATUS
 exclude_feature nv0v174                         status=BUILD_B503_STATUS
 exclude_feature nv0v178                         status=BUILD_B503_STATUS
 exclude_feature nv0v179                         status=BUILD_B503_STATUS
 exclude_feature reset_qcu_environment           status=BUILD_B503_STATUS
 exclude_feature tcv0221_inetd                   status=BUILD_B503_STATUS
 exclude_feature tcv0221_inetd_a                 status=BUILD_B503_STATUS
 exclude_feature tcva332                         status=BUILD_B503_STATUS
 exclude_feature basic_tape_security_phase_3f16  status=BUILD_B503_STATUS
 exclude_feature nv09207_a                       status=BUILD_B503_STATUS
*DECK DECK=BUILD_B503_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B505_NEW_DECKS
*IF bev$product_level = 'BUILD_B503_NEW_DECKS'
*copyc cycleB5_exceptions
*ELSE
*copyc BUILD_B503_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B503_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B503_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B503_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck JMT$AIO_LIMIT                     status=BUILD_B503_NEW_DECKS_STATUS
 exclude_deck NLV$DIRECTORY_LOCK                status=BUILD_B503_NEW_DECKS_STATUS
 exclude_deck QCM$ESTABLISH_BACKUP_CATALOG      status=BUILD_B503_NEW_DECKS_STATUS
 exclude_deck RAM$SEARCH_LINK_MAP               status=BUILD_B503_NEW_DECKS_STATUS
 exclude_deck RAM$SEARCH_LINK_MAP_PD            status=BUILD_B503_NEW_DECKS_STATUS
 exclude_deck RMP$VALIDATE_ANSI_STRING          status=BUILD_B503_NEW_DECKS_STATUS
*DECK DECK=BUILD_B505 EXPAND=TRUE
*copyc BUILD_B506
*IF bev$product_level = 'BUILD_B505'
*copyc cycleB5_exceptions
*ELSE
*copyc BUILD_B505_contents
*IFEND
*DECK DECK=BUILD_B505_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B505_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B505_STATUS kind=status
IFEND
 exclude_feature bcu_helper_l780_1               status=BUILD_B505_STATUS
 exclude_feature exd0025                         status=BUILD_B505_STATUS
 exclude_feature nv08707                         status=BUILD_B505_STATUS
 exclude_feature nv09148                         status=BUILD_B505_STATUS
 exclude_feature nv0v182                         status=BUILD_B505_STATUS
 exclude_feature nv0v185                         status=BUILD_B505_STATUS
 exclude_feature standard_time_1991              status=BUILD_B505_STATUS
 exclude_feature utility_port_$true              status=BUILD_B505_STATUS
*DECK DECK=BUILD_B505_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B506_NEW_DECKS
*IF bev$product_level = 'BUILD_B505_NEW_DECKS'
*copyc cycleB5_exceptions
*ELSE
*copyc BUILD_B505_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B505_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B506 EXPAND=TRUE
*copyc BUILD_B507
*IF bev$product_level = 'BUILD_B506'
*copyc cycleB5_exceptions
*ELSE
*copyc BUILD_B506_contents
*IFEND
*DECK DECK=BUILD_B506_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B506_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B506_STATUS kind=status
IFEND
 exclude_feature nv09207_b                       status=BUILD_B506_STATUS
 exclude_feature nv09285                         status=BUILD_B506_STATUS
*DECK DECK=BUILD_B506_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B507_NEW_DECKS
*IF bev$product_level = 'BUILD_B506_NEW_DECKS'
*copyc cycleB5_exceptions
*ELSE
*copyc BUILD_B506_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B506_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B507 EXPAND=TRUE
*copyc BUILD_B601
*IF bev$product_level = 'BUILD_B507'
*copyc cycleB5_exceptions
*ELSE
*copyc BUILD_B507_contents
*IFEND
*DECK DECK=BUILD_B507_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B507_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B507_STATUS kind=status
IFEND
 exclude_feature nv09318                         status=BUILD_B507_STATUS
 exclude_feature nv09319                         status=BUILD_B507_STATUS
 exclude_feature update_violet_config            status=BUILD_B507_STATUS
*DECK DECK=BUILD_B507_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B601_NEW_DECKS
*IF bev$product_level = 'BUILD_B507_NEW_DECKS'
*copyc cycleB5_exceptions
*ELSE
*copyc BUILD_B507_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B507_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B601 EXPAND=TRUE
*copyc BUILD_B602
*IF bev$product_level = 'BUILD_B601'
*copyc BUILD_B507_contents
*copyc BUILD_B506_contents
*copyc BUILD_B505_contents
*copyc BUILD_B503_contents
*copyc BUILD_B502_contents
*copyc BUILD_B501_contents
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B601_contents
*IFEND
*DECK DECK=BUILD_B601_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B601_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B601_STATUS kind=status
IFEND
 exclude_feature dynamic_pp_reload               status=BUILD_B601_STATUS
 exclude_feature nv04076                         status=BUILD_B601_STATUS
 exclude_feature nv08708                         status=BUILD_B601_STATUS
 exclude_feature nv08969                         status=BUILD_B601_STATUS
 exclude_feature pp_reload                       status=BUILD_B601_STATUS
*DECK DECK=BUILD_B601_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B602_NEW_DECKS
*IF bev$product_level = 'BUILD_B601_NEW_DECKS'
*copyc BUILD_B507_NEW_DECKS_contents
*copyc BUILD_B506_NEW_DECKS_contents
*copyc BUILD_B505_NEW_DECKS_contents
*copyc BUILD_B503_NEW_DECKS_contents
*copyc BUILD_B502_NEW_DECKS_contents
*copyc BUILD_B501_NEW_DECKS_contents
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B601_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B601_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B601_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B601_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CML$PP_HUNG                       status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMM$PHYSICAL_CONFIG_MGR_R1        status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMP$ACQUIRE_ALL_PERIPHERALS_R1    status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMP$CLEAR_ELEMENT_LOCK            status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMP$CRACK_PHYSICAL_ADDRESS        status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMP$GET_LOGICAL_PP_INDEX          status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMP$MARK_PP_ELEMENT_RESERVED      status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMP$RELEASE_CHANNEL_RESOURCE      status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMP$RELEASE_EQUIPMENT_RESOURCE    status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMP$RELEASE_PP_BY_CHANNEL         status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMP$RELEASE_PP_BY_INDEX           status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMP$RELEASE_PP_RESOURCE           status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMP$REQUEST_RESOURCES             status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMP$RETRIEVE_LOGICAL_PP_INDEX     status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMP$SET_ELEMENT_LOCK              status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMP$UNMARK_PP_ELEMENT_RESERVED    status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMP$UNMARK_PP_WHEN_CLEANUP        status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMT$ACCESS_ELEMENTS               status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMV$ELEMENT_RESERVATION_LOCK      status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMV$LOGICAL_PP_TABLE_LOCK         status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMV$LOGICAL_PP_TABLE_P            status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMV$NEW_LOGICAL_PP_TABLE_P        status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMV$SAVE_PCT_P                    status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CMV$SAVE_STATE_TABLE_P            status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CTP$DFT_HANDLE_IOU_BIT57          status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck CTP$DFT_RESTART_SCI               status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck DSM$MTR_AUTOMATIC_PP_RELOAD       status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck DSP$GET_IOU_STATUS_REGISTER       status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck DSP$MOVE_PP_DRIVER                status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck DSP$MTR_DFT_PUF_REQUEST           status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck DSP$MTR_DFT_RELOAD_SCI            status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck DSP$MTR_HANDLE_BIT_57             status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck DSP$MTR_HANDLE_PP_HANG            status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck DSP$MTR_PROCESS_HUNG_PP           status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck DSP$MTR_RESERVE_PUF_MEMORY_AREA   status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck DSP$MTR_RETURN_PUF_MEMORY_AREA    status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck DST$AUTOMATIC_PP_RELOAD           status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck DST$LOG_HUNG_PP_DATA              status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck DST$MTR_DFT_REQUESTS              status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck DSV$AUTOMATIC_PP_RELOAD           status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck DSV$MTR_DFT_REQUESTS              status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck DUM$DISPLAY_ASSIGNED_PPS          status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck IOM$MTR_MANAGE_PP_PROCESS         status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck IOP$IDLE_RESUME                   status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck IOP$RELOAD_HUNG_DISK_PP           status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck IOT$IDLE_RESUME_ACTION            status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck JMT$AIO_LIMIT                     status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck JSV$AGE_BEFORE_SWAP_PERCENTAGE    status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck JSV$AGE_JWS_BEFORE_SWAP           status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck NAH$RELOAD_NETWORK_PP             status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck NAP$RELOAD_NETWORK_PP             status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck NLV$DIRECTORY_LOCK                status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck OSV$MISC_TEST_COMMANDS_CALL_PDT   status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck OSV$MISC_TEST_COMMANDS_INT1_PDT   status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck OSV$MISC_TEST_COMMANDS_INT2_PDT   status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck OSV$MISC_TEST_COMMANDS_INT4_PDT   status=BUILD_B601_NEW_DECKS_STATUS
 exclude_deck OSV$MISC_TEST_COMMANDS_INT6_PDT   status=BUILD_B601_NEW_DECKS_STATUS
*DECK DECK=BUILD_B602 EXPAND=TRUE
*copyc BUILD_B611
*IF bev$product_level = 'BUILD_B602'
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B602_contents
*IFEND
*DECK DECK=BUILD_B602_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B602_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B602_STATUS kind=status
IFEND
 exclude_feature add_pp_reload_turn_off_option   status=BUILD_B602_STATUS
 exclude_feature dynamic_pp_reload_sci_fix_1     status=BUILD_B602_STATUS
 exclude_feature fix_i4p_driver                  status=BUILD_B602_STATUS
 exclude_feature ftm0009                         status=BUILD_B602_STATUS
 exclude_feature i4cr_os_support_sci             status=BUILD_B602_STATUS
 exclude_feature interactive_load_leveling       status=BUILD_B602_STATUS
 exclude_feature interactive_load_leveling_1     status=BUILD_B602_STATUS
 exclude_feature interactive_load_leveling_2     status=BUILD_B602_STATUS
 exclude_feature interactive_load_leveling_3     status=BUILD_B602_STATUS
 exclude_feature interactive_load_leveling_4     status=BUILD_B602_STATUS
 exclude_feature make_xref_match_get_qfile_attr  status=BUILD_B602_STATUS
 exclude_feature manage_job_utility_via_fs_7     status=BUILD_B602_STATUS
 exclude_feature nv04561                         status=BUILD_B602_STATUS
 exclude_feature nv06105                         status=BUILD_B602_STATUS
 exclude_feature nv08954                         status=BUILD_B602_STATUS
 exclude_feature nv09034                         status=BUILD_B602_STATUS
 exclude_feature nv09048                         status=BUILD_B602_STATUS
 exclude_feature nv09048_fix                     status=BUILD_B602_STATUS
 exclude_feature nv09138                         status=BUILD_B602_STATUS
 exclude_feature nv09210                         status=BUILD_B602_STATUS
 exclude_feature nv09235                         status=BUILD_B602_STATUS
 exclude_feature nv09239                         status=BUILD_B602_STATUS
 exclude_feature nv09243                         status=BUILD_B602_STATUS
 exclude_feature nv09246                         status=BUILD_B602_STATUS
 exclude_feature nv09256                         status=BUILD_B602_STATUS
 exclude_feature nv09267                         status=BUILD_B602_STATUS
 exclude_feature nv09284                         status=BUILD_B602_STATUS
 exclude_feature nv09296                         status=BUILD_B602_STATUS
 exclude_feature nv09328                         status=BUILD_B602_STATUS
 exclude_feature nv0t172                         status=BUILD_B602_STATUS
 exclude_feature nv0u352                         status=BUILD_B602_STATUS
 exclude_feature nv0v076                         status=BUILD_B602_STATUS
 exclude_feature nv0v163                         status=BUILD_B602_STATUS
 exclude_feature nv0v170                         status=BUILD_B602_STATUS
 exclude_feature nv0v172                         status=BUILD_B602_STATUS
 exclude_feature nv0v193                         status=BUILD_B602_STATUS
 exclude_feature nv0v195                         status=BUILD_B602_STATUS
 exclude_feature simultaneous_copies_os          status=BUILD_B602_STATUS
 exclude_feature nv07791                         status=BUILD_B602_STATUS
 exclude_feature nv09275                         status=BUILD_B602_STATUS
 exclude_feature nv09275_a                       status=BUILD_B602_STATUS
 exclude_feature nv09327                         status=BUILD_B602_STATUS
 exclude_feature nv09346                         status=BUILD_B602_STATUS
 exclude_feature nv0v138                         status=BUILD_B602_STATUS
 exclude_feature nv0v198                         status=BUILD_B602_STATUS
 exclude_feature nv0v205                         status=BUILD_B602_STATUS
*DECK DECK=BUILD_B602_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B611_NEW_DECKS
*IF bev$product_level = 'BUILD_B602_NEW_DECKS'
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B602_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B602_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B602_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B602_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CMP$GET_MS_CLASS_ON_VOLUME        status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck CMP$GET_MS_CLASS_ON_VOLUME_R1     status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck CMT$MS_CLASS                      status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck CMT$MS_CLASS_INFO                 status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck CMT$MS_CLASS_MEMBERS              status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck DMP$CLOSE_DFL_R3                  status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck DMP$CLOSE_LOGIN_TABLE_R3          status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck DMP$CLOSE_LOG_R3                  status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck DMP$COPY_LABEL                    status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck DMP$COPY_LOG                      status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck DMP$COPY_LOGIN_TABLE              status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck DMP$OPEN_DFL_R3                   status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck DMP$OPEN_LOGIN_TABLE_R3           status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck DMP$OPEN_LOG_R3                   status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck IIP$VTP_DEL_PAIRED_CON_FIRST      status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JME$JOB_ON_ANOTHER_MAINFRAME      status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMH$CLUSTER_GET_LEVELING_DATA     status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMH$GET_ACTIVE_SCHEDULING_ATTR    status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMH$GET_LEVELING_DATA             status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMH$MAINFRAME_GET_LEVELING_DATA   status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMH$SELECT_INTERACTIVE_JOB_DEST   status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMM$MAINFRAME_GET_LEVELING_DATA   status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMM$SELECT_INTERACTIVE_JOB_DEST   status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMM$SWITCH_REMOTE_CONNECTION      status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMP$CLUSTER_GET_LEVELING_DATA     status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMP$GET_ACTIVE_SCHEDULING_ATTR    status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMP$GET_LEVELING_DATA             status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMP$MAINFRAME_GET_LEVELING_DATA   status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMP$SELECT_INTERACTIVE_JOB_DEST   status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMT$INTERACTIVE_JOB_INFO          status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMT$JOB_INITIATION_LEVEL          status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMT$LEVELED_JOB_CONNECT_DATA      status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMT$LEVELED_JOB_LIST              status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMT$MAINFRAME_LEVELING_DATA       status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMT$SCHEDULING_ATTRIBUTE_KEYS     status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMT$SCHEDULING_ATTR_RESULTS       status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMT$SCHEDULING_RESULTS_KEYS       status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck JMT$SELECTION_PRIORITY            status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck MTA$BOOT_CONTROL_TABLE            status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck NAP$ACQUIRE_SPECIFIC_CONNECTION   status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck NAP$ATTACH_SPECIFIC_SERVER_APPL   status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck NAP$DETACH_SPECIFIC_SERVER_APPL   status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck NAP$SET_SERVER_JOB_INIT_PENDING   status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck NLP$ACQUIRE_SPECIFIC_CONNECTION   status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck OSH$CHECK_CLIENT_LEVELED_ACCESS   status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck OSP$CHECK_CLIENT_LEVELED_ACCESS   status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck OSP$CHECK_FOR_DESIRED_MF_CLASS    status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck OSP$CONVERT_TO_REAL_MODEL_NUM     status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck OST$MAINFRAME_CLASSES             status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck PMP$GET_PSEUDO_MAINFRAME_ID       status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck PMT$CPU_DATA                      status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck PMV$CPU_DATA                      status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck QFH$FIND_JOB_CONNECTION_SWITCH    status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck QFH$QUEUE_JOB_FOR_CON_SWITCH      status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck QFP$FIND_JOB_CONNECTION_SWITCH    status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck QFP$QUEUE_JOB_FOR_CON_SWITCH      status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck RAM$ACTIVATE_FTAM_RESPONDER       status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck RAM$COMPILE_GET_LEVELING_DATA     status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck RAM$COMPILE_SELECT_JOB_DEST       status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck RAM$DEACTIVATE_FTAM_RESPONDER     status=BUILD_B602_NEW_DECKS_STATUS
 exclude_deck RAM$DEFINE_FTAM_INITIATOR_ADDR    status=BUILD_B602_NEW_DECKS_STATUS
*DECK DECK=BUILD_B611 EXPAND=TRUE
*copyc BUILD_B612
*IF bev$product_level = 'BUILD_B611'
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B611_contents
*IFEND
*DECK DECK=BUILD_B611_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B611_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B611_STATUS kind=status
IFEND
 exclude_feature interactive_load_leveling_5     status=BUILD_B611_STATUS
 exclude_feature interactive_load_leveling_6     status=BUILD_B611_STATUS
 exclude_feature l780ab_dft_lvl_mod              status=BUILD_B611_STATUS
 exclude_feature l780ab_mdd_date_mod             status=BUILD_B611_STATUS
 exclude_feature pf_condition_handlers           status=BUILD_B611_STATUS
 exclude_feature nv08448                         status=BUILD_B611_STATUS
 exclude_feature nv08641                         status=BUILD_B611_STATUS
 exclude_feature nv08784                         status=BUILD_B611_STATUS
 exclude_feature nv09175                         status=BUILD_B611_STATUS
 exclude_feature nv09213                         status=BUILD_B611_STATUS
 exclude_feature nv09268                         status=BUILD_B611_STATUS
 exclude_feature nv09281                         status=BUILD_B611_STATUS
 exclude_feature nv09287                         status=BUILD_B611_STATUS
 exclude_feature nv09291                         status=BUILD_B611_STATUS
 exclude_feature nv09338                         status=BUILD_B611_STATUS
 exclude_feature nv09341                         status=BUILD_B611_STATUS
 exclude_feature nv09371                         status=BUILD_B611_STATUS
 exclude_feature nv09385                         status=BUILD_B611_STATUS
 exclude_feature nv0v143                         status=BUILD_B611_STATUS
 exclude_feature nv0v180                         status=BUILD_B611_STATUS
 exclude_feature nv0v204                         status=BUILD_B611_STATUS
 exclude_feature nv0v208                         status=BUILD_B611_STATUS
 exclude_feature nv0v211                         status=BUILD_B611_STATUS
*DECK DECK=BUILD_B611_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B612_NEW_DECKS
*IF bev$product_level = 'BUILD_B611_NEW_DECKS'
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B611_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B611_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B611_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B611_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck DFP$LOCATE_EVERY_SERVED_FAMILY    status=BUILD_B611_NEW_DECKS_STATUS
 exclude_deck LOP$AUGMENT_DYNAMIC_LOADED_EPS    status=BUILD_B611_NEW_DECKS_STATUS
 exclude_deck LOT$LOADED_ENTRY_POINT_LIST       status=BUILD_B611_NEW_DECKS_STATUS
 exclude_deck LOV$DYNAMIC_LOADED_ENTRY_POINTS   status=BUILD_B611_NEW_DECKS_STATUS
 exclude_deck PFM$TASK_TERMINATION              status=BUILD_B611_NEW_DECKS_STATUS
 exclude_deck PFP$LOG_PATH                      status=BUILD_B611_NEW_DECKS_STATUS
 exclude_deck PFP$R2_CONDITION_HANDLER          status=BUILD_B611_NEW_DECKS_STATUS
 exclude_deck PFP$TASK_TERMINATION_CLEANUP      status=BUILD_B611_NEW_DECKS_STATUS
 exclude_deck PFP$TEST_CONDITION_HANDLER        status=BUILD_B611_NEW_DECKS_STATUS
 exclude_deck PFV$LOCKED_APFID                  status=BUILD_B611_NEW_DECKS_STATUS
 exclude_deck PFV$P_LOCKED_CATALOG              status=BUILD_B611_NEW_DECKS_STATUS
*DECK DECK=BUILD_B612 EXPAND=TRUE
*copyc BUILD_B613
*IF bev$product_level = 'BUILD_B612'
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B612_contents
*IFEND
*DECK DECK=BUILD_B612_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B612_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B612_STATUS kind=status
IFEND
*DECK DECK=BUILD_B612_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B613_NEW_DECKS
*IF bev$product_level = 'BUILD_B612_NEW_DECKS'
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B612_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B612_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B612_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B612_NEW_DECKS_STATUS kind=status
IFEND
*DECK DECK=BUILD_B613 EXPAND=TRUE
*copyc BUILD_B621
*IF bev$product_level = 'BUILD_B613'
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B613_contents
*IFEND
*DECK DECK=BUILD_B613_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B613_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B613_STATUS kind=status
IFEND
 exclude_feature nv09281_fix                     status=BUILD_B613_STATUS
*DECK DECK=BUILD_B613_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B621_NEW_DECKS
*IF bev$product_level = 'BUILD_B613_NEW_DECKS'
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B613_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B613_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B621 EXPAND=TRUE
*copyc BUILD_B622
*IF bev$product_level = 'BUILD_B621'
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B621_contents
*IFEND
*DECK DECK=BUILD_B621_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B621_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B621_STATUS kind=status
IFEND
 exclude_feature anad_fix_for_large_octal_memory status=BUILD_B621_STATUS
 exclude_feature anaol_count_bind_section_refs   status=BUILD_B621_STATUS
 exclude_feature auto_cmd_list                   status=BUILD_B621_STATUS
 exclude_feature bcu_helper_l780ab               status=BUILD_B621_STATUS
 exclude_feature copyright_1992                  status=BUILD_B621_STATUS
 exclude_feature electronic_qcu_76               status=BUILD_B621_STATUS
 exclude_feature nv06552                         status=BUILD_B621_STATUS
 exclude_feature nv06571                         status=BUILD_B621_STATUS
 exclude_feature nv08792                         status=BUILD_B621_STATUS
 exclude_feature nv08792_1                       status=BUILD_B621_STATUS
 exclude_feature nv09031                         status=BUILD_B621_STATUS
 exclude_feature nv09234                         status=BUILD_B621_STATUS
 exclude_feature nv09301                         status=BUILD_B621_STATUS
 exclude_feature nv09362                         status=BUILD_B621_STATUS
 exclude_feature nv09373                         status=BUILD_B621_STATUS
 exclude_feature nv09383                         status=BUILD_B621_STATUS
 exclude_feature nv09384                         status=BUILD_B621_STATUS
 exclude_feature nv09403                         status=BUILD_B621_STATUS
 exclude_feature nv09438                         status=BUILD_B621_STATUS
 exclude_feature nv0u549                         status=BUILD_B621_STATUS
 exclude_feature nv0v037                         status=BUILD_B621_STATUS
 exclude_feature nv0v217                         status=BUILD_B621_STATUS
 exclude_feature nv0v218                         status=BUILD_B621_STATUS
 exclude_feature nv0v222                         status=BUILD_B621_STATUS
 exclude_feature nv0v227                         status=BUILD_B621_STATUS
 exclude_feature nv0v229                         status=BUILD_B621_STATUS
 exclude_feature os_support_for_the_97x          status=BUILD_B621_STATUS
 exclude_feature pf_condition_handlers           status=BUILD_B621_STATUS
 exclude_feature pf_condition_handlers_fix_1     status=BUILD_B621_STATUS
 exclude_feature pf_condition_handlers_fix_2     status=BUILD_B621_STATUS
 exclude_feature rms0041_os                      status=BUILD_B621_STATUS
 exclude_feature rms0059_os                      status=BUILD_B621_STATUS
 exclude_feature test_harness_update_30          status=BUILD_B621_STATUS
 exclude_feature xterm_ncdx_1                    status=BUILD_B621_STATUS
 exclude_feature xterm_ncdx_2                    status=BUILD_B621_STATUS
 exclude_feature xterm_ncdx_3                    status=BUILD_B621_STATUS
 exclude_feature xterm_os_changes_1              status=BUILD_B621_STATUS
 exclude_feature xterm_os_changes_2              status=BUILD_B621_STATUS
 exclude_feature xterm_os_changes_3              status=BUILD_B621_STATUS
 exclude_feature xterm_os_changes_4              status=BUILD_B621_STATUS
 exclude_feature xterm_os_changes_5              status=BUILD_B621_STATUS
*DECK DECK=BUILD_B621_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B622_NEW_DECKS
*IF bev$product_level = 'BUILD_B621_NEW_DECKS'
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B621_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B621_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B621_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B621_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CAM$TERMINATE_MASSTOR             status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck CAM$TERMINATE_MASSTOR_23D         status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck CAP$CHANGE_TERMINATION_PRIORITY   status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck CAP$PREPARE_FOR_IDLE_SYSTEM       status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck CLM$TAPE_SCAN_COMMANDS            status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck CMP$SSIOT_TERMINATION             status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck CMP$SSIOT_TERMINATION_CLEANUP     status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck CMP$UNLOCK_THE_RMA_LIST           status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck CMP$UNLOCK_WIRED_RMA_LIST         status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck CSM$NCDX_24_80                    status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck CSM$NCDX_43_80                    status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck CSM$SUN_4_43_80                   status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck DUP$IS_CPU1_INSTALLED             status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIC$XT_COMPILING_FOR_TRACE        status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIC$XT_XTERM_CATALOG_NAME         status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIM$XT_XTERM_FAP                  status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIM$XT_XTERM_INTERFACES           status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_CHECK_DOWNLINE             status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_CHECK_UPLINE               status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_CLOSE_FILE                 status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_CREATE_MESSAGE_FILE        status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_CREATE_XTERM_FILES         status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_EXECUTE_XTERM_COMMAND      status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_FETCH_ATTRIBUTES           status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_GET_TERMINAL_ATTRIBUTES    status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_INITIALIZE_XTERM           status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_LOCK_DOWNLINE_MESSAGES     status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_LOCK_UPLINE_MESSAGES       status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_OPEN_DOWNLINE_MESSAGES     status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_OPEN_FILE                  status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_OPEN_MESSAGE_FILE          status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_OPEN_UPLINE_MESSAGES       status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_READY_TASK                 status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_RECEIVE_DATA               status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_REDIRECT_XTERM_OUTPUT      status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_ROUTE                      status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_SEND_DATA                  status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_SEND_INTERRUPT             status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_SEND_SIGNAL                status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_STOP_XTERM                 status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_STORE_ATTRIBUTES           status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_SYNCHRONIZE                status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_SYNCHRONIZE_CONFIRM        status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_UNLOCK_DOWNLINE_MESSAGES   status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_UNLOCK_UPLINE_MESSAGES     status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_WRITE_TRACE                status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_WRITE_TRACE_STATUS         status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIP$XT_XTERM_FAP                  status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$VT_INPUT_HEADER               status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$XT_MESSAGE_CONTROL_BLOCK      status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$XT_MESSAGE_CONTROL_STATUS     status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$XT_MESSAGE_COUNT              status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$XT_MESSAGE_FILE_REFERENCE     status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$XT_MESSAGE_HEADER             status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$XT_MESSAGE_SIZE               status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$XT_MESSAGE_STATE              status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$XT_MESSAGE_TYPE               status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$XT_RECORD_POSITION            status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$XT_TERMINATE_OPTION           status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$XT_TRACE_OPTIONS              status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$XT_TRACE_SET                  status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$XT_XTERM_CONTROL_BLOCK        status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$XT_XTERM_MESSAGE_CONTROL      status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$XT_XTERM_STATE                status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$XT_XTERM_TASK                 status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIT$XT_XTERM_TASK_OUTPUT          status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIV$XT_MESSAGE_CONTROL            status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIV$XT_XTERM_CONTROL_BLOCK        status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIV$XT_XTERM_DOWNLINE             status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIV$XT_XTERM_TASK_OUTPUT          status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IIV$XT_XTERM_UPLINE               status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IOP$ACCESS_TUSL_ENTRY             status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IOP$CHANGE_TAPE_SCAN_FREQ_113     status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IOP$CHANGE_TAPE_SCAN_FREQ_23D     status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IOP$FETCH_TAPE_SCAN_FREQUENCY     status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IOP$UNLOCK_THE_RMA_LIST           status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IOT$TUSL_ENTRY_ACCESS             status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IOT$TUSL_ENTRY_OPERATION          status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck IOV$TAPE_SCAN_FREQUENCY           status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck JME$CANNOT_DETACH_XTERM_JOB       status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck JMP$IS_DUAL_STATE_JOB             status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck JMP$IS_XTERM_JOB                  status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck JMP$IS_XTERM_TASK                 status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck JMV$XTERM_JOB                     status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck OCP$GET_BINDING_SECTION_REFS      status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck OCT$ADDRESS_TYPE                  status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck OSC$XTERM_APPLICATION_NAME        status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck PFM$TASK_TERMINATION              status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck PFP$LOG_PATH                      status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck PFP$R2_CONDITION_HANDLER          status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck PFP$TASK_TERMINATION_CLEANUP      status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck PFP$TEST_CONDITION_HANDLER        status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck PFV$LOCKED_APFID                  status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck PFV$P_LOCKED_CATALOG              status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck PUT$SELECTED_CYCLE                status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck PUT$SELECTED_CYCLE_INFO           status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck RAP$CHANGE_TAPE_SCAN_FREQUENCY    status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck RAP$DISPLAY_TAPE_SCAN_FREQUENCY   status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck RSC$EXTEND_LABELED_MESSAGE        status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck RSC$EXTEND_UNLABELED_MESSAGE      status=BUILD_B621_NEW_DECKS_STATUS
 exclude_deck RSM$RESOURCE_HELP_MESSAGES        status=BUILD_B621_NEW_DECKS_STATUS
*DECK DECK=BUILD_B622 EXPAND=TRUE
*copyc BUILD_B623
*IF bev$product_level = 'BUILD_B622'
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B622_contents
*IFEND
*DECK DECK=BUILD_B622_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B622_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B622_STATUS kind=status
IFEND
 exclude_feature cve0227_ve                      status=BUILD_B622_STATUS
 exclude_feature dfta211                         status=BUILD_B622_STATUS
 exclude_feature nv09048_fix1                    status=BUILD_B622_STATUS
 exclude_feature nv09360                         status=BUILD_B622_STATUS
 exclude_feature nv09454                         status=BUILD_B622_STATUS
 exclude_feature xterm_os_changes_7              status=BUILD_B622_STATUS
 exclude_feature dfta212                         status=BUILD_B622_STATUS
*DECK DECK=BUILD_B622_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B623_NEW_DECKS
*IF bev$product_level = 'BUILD_B622_NEW_DECKS'
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B622_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B622_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B622_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B622_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CTP$DFT_NO_RESET_PIT              status=BUILD_B622_NEW_DECKS_STATUS
 exclude_deck CTP$DFT_RESET_PIT                 status=BUILD_B622_NEW_DECKS_STATUS
*DECK DECK=BUILD_B623 EXPAND=TRUE
*copyc BUILD_B624
*IF bev$product_level = 'BUILD_B623'
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B623_contents
*IFEND
*DECK DECK=BUILD_B623_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B623_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B623_STATUS kind=status
IFEND
 exclude_feature nv0v212                         status=BUILD_B623_STATUS
 exclude_feature nv0v234                         status=BUILD_B623_STATUS
 exclude_feature nv0v242                         status=BUILD_B623_STATUS
 exclude_feature pf_condition_handlers_fix_3     status=BUILD_B623_STATUS
*DECK DECK=BUILD_B623_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B624_NEW_DECKS
*IF bev$product_level = 'BUILD_B623_NEW_DECKS'
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B623_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B623_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B624 EXPAND=TRUE
*copyc BUILD_B701
*IF bev$product_level = 'BUILD_B624'
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B624_contents
*IFEND
*DECK DECK=BUILD_B624_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B624_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B624_STATUS kind=status
IFEND
*DECK DECK=BUILD_B624_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B701_NEW_DECKS
*IF bev$product_level = 'BUILD_B624_NEW_DECKS'
*copyc cycleB6_exceptions
*ELSE
*copyc BUILD_B624_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B624_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B671 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B418 '
*copyc BUILD_B418
*IFEND
IF $variable(build_b671_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_b671_status kind=status
IFEND
 include_feature dynamic_pp_reload               status=build_b671_status
 include_feature nfsa175_os                      status=build_b671_status
 include_feature nv04076                         status=build_b671_status
 include_feature nv07811                         status=build_b671_status
 include_feature nv08708                         status=build_b671_status
 include_feature nv08755                         status=build_b671_status
 include_feature nv08969                         status=build_b671_status
 include_feature nv09019                         status=build_b671_status
 include_feature nv09061                         status=build_b671_status
 include_feature nv09121                         status=build_b671_status
 include_feature nv0u337                         status=build_b671_status
 include_feature nv0v101                         status=build_b671_status
 include_feature nv0v125                         status=build_b671_status
 include_feature nv0v147                         status=build_b671_status
 include_feature pp_reload                       status=build_b671_status
*DECK DECK=BUILD_B672 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B601 '
*copyc BUILD_B601
*IFEND
IF $variable(build_b672_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_b672_status kind=status
IFEND
 include_feature nv09056                         status=build_b672_status
 include_feature nv0v163                         status=build_b672_status
 include_feature utility_port_$true              status=build_b672_status
*DECK DECK=BUILD_B673 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B601 '
*copyc BUILD_B601
*IFEND
*copyc BUILD_B672
IF $variable(build_b673_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_b673_status kind=status
IFEND
 include_feature nv07594                         status=build_b673_status
 include_feature nv09041                         status=build_b673_status
 include_feature nv09067                         status=build_b673_status
 include_feature seg_20_trap_code                status=build_b673_status
 include_feature interactive_load_leveling       status=build_b673_status
 include_feature nv09209                         status=build_b673_status
 include_feature nv0v165                         status=build_b673_status
 include_feature nv0v172                         status=build_b673_status
 include_feature nv0v173                         status=build_b673_status
 include_feature simultaneous_copies_os          status=build_b673_status
*DECK DECK=BUILD_B674 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B601 '
*copyc BUILD_B601
*IFEND
*copyc BUILD_B673
IF $variable(build_b674_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_b674_status kind=status
IFEND
 include_feature backout_nv09150_code            status=build_b674_status
 include_feature basic_tape_security_phase_3f15  status=build_b674_status
 include_feature basic_tape_security_phase_3f16  status=build_b674_status
 include_feature bcu_helper_l780aa               status=build_b674_status
 include_feature bcu_helper_l780_1               status=build_b674_status
 include_feature delete_max_tasks                status=build_b674_status
 include_feature delete_wef_tests_from_crete     status=build_b674_status
 include_feature electronic_qcu_71               status=build_b674_status
 include_feature exd0025                         status=build_b674_status
 include_feature mv20482_os                      status=build_b674_status
 include_feature nv08707                         status=build_b674_status
 include_feature nv09014                         status=build_b674_status
 include_feature nv09148                         status=build_b674_status
 include_feature nv09180                         status=build_b674_status
 include_feature nv09207                         status=build_b674_status
 include_feature nv09207_a                       status=build_b674_status
 include_feature nv0v174                         status=build_b674_status
 include_feature nv0v178                         status=build_b674_status
 include_feature nv0v179                         status=build_b674_status
 include_feature nv0v182                         status=build_b674_status
 include_feature nv0v185                         status=build_b674_status
 include_feature reset_qcu_environment           status=build_b674_status
 include_feature standard_time_1991              status=build_b674_status
 include_feature tcv0221_inetd                   status=build_b674_status
 include_feature tcv0221_inetd_a                 status=build_b674_status
 include_feature interactive_load_leveling_1     status=build_b674_status
 include_feature interactive_load_leveling_2     status=build_b674_status
 include_feature nv09210                         status=build_b674_status
 include_feature nv09048                         status=build_b674_status
 include_feature nv09150_applied_again           status=build_b674_status
 include_feature nv09220                         status=build_b674_status
 include_feature nv09239                         status=build_b674_status
 include_feature nv09246                         status=build_b674_status
 include_feature nv09267                         status=build_b674_status
 include_feature nv0t172                         status=build_b674_status
 include_feature nv0v076                         status=build_b674_status
 include_feature nv0v170                         status=build_b674_status
*DECK DECK=BUILD_B675 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B601 '
*copyc BUILD_B601
*IFEND
*copyc BUILD_B674
IF $variable(build_b675_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_b675_status kind=status
IFEND
 include_feature nv09207_b                       status=build_b675_status
 include_feature nv09285                         status=build_b675_status
 include_feature tcva332                         status=build_b675_status
 include_feature add_pp_reload_turn_off_option   status=build_b675_status
 include_feature interactive_load_leveling_3     status=build_b675_status
 include_feature manage_job_utility_via_fs_7     status=build_b675_status
 include_feature dynamic_pp_reload_sci_fix_1     status=build_b675_status
 include_feature fix_i4p_driver                  status=build_b675_status
 include_feature ftm0009                         status=build_b675_status
 include_feature i4cr_os_support_sci             status=build_b675_status
 include_feature make_xref_match_get_qfile_attr  status=build_b675_status
 include_feature nv04561                         status=build_b675_status
 include_feature nv06105                         status=build_b675_status
 include_feature nv08954                         status=build_b675_status
 include_feature nv09034                         status=build_b675_status
 include_feature nv09048_fix                     status=build_b675_status
 include_feature nv09138                         status=build_b675_status
 include_feature nv09210                         status=build_b675_status
 include_feature nv09235                         status=build_b675_status
 include_feature nv09243                         status=build_b675_status
 include_feature nv09256                         status=build_b675_status
 include_feature nv09284                         status=build_b675_status
 include_feature nv0u352                         status=build_b675_status
 include_feature nv0v193                         status=build_b675_status
 include_feature nv0v195                         status=build_b675_status
 include_feature update_violet_config            status=build_b675_status
*DECK DECK=BUILD_B681 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B602 '
*copyc BUILD_B602
*IFEND
IF $variable(build_b681_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_b681_status kind=status
IFEND
 include_feature nv09150_applied_again           status=build_b681_status
 include_feature nv09220                         status=build_b681_status
 include_feature nv09268                         status=build_b681_status
 include_feature nv09281                         status=build_b681_status
 include_feature nv09338                         status=build_b681_status
 include_feature nv0v143                         status=build_b681_status
 include_feature nv0v204                         status=build_b681_status
 include_feature nv0v208                         status=build_b681_status
*DECK DECK=BUILD_B682 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B611 '
*copyc BUILD_B611
*IFEND
IF $variable(build_b682_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_b682_status kind=status
IFEND
 include_feature nv09150_applied_again           status=build_b682_status
 include_feature nv09220                         status=build_b682_status
 include_feature xterm_os_changes_1              status=build_b682_status
 include_feature xterm_os_changes_2              status=build_b682_status
 include_feature xterm_os_changes_3              status=build_b682_status
 include_feature xterm_os_changes_4              status=build_b682_status
 exclude_feature pf_condition_handlers           status=build_b682_status
*DECK DECK=BUILD_B685 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B623 '
*copyc BUILD_B623
*IFEND
IF $variable(build_b685_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_b685_status kind=status
IFEND
 include_feature nv08749                         status=build_b685_status
 include_feature nv08481                         status=build_b685_status
 include_feature nv09097                         status=build_b685_status
 include_feature nv09098                         status=build_b685_status
 include_feature nv09274                         status=build_b685_status
 include_feature nv09419                         status=build_b685_status
 include_feature nv09450                         status=build_b685_status
 include_feature nv09456                         status=build_b685_status
 include_feature nv09466                         status=build_b685_status
 include_feature broadcast_os                    status=build_b685_status
 include_feature xterm_os_changes_6              status=build_b685_status
 include_feature xterm_os_changes_8              status=build_b685_status
 include_feature ve_connection_switch_os         status=build_b685_status
 include_feature ve_connection_switch_os_1       status=build_b685_status
*DECK DECK=BUILD_B691 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B622 '
*copyc BUILD_B622
*IFEND
*DECK DECK=BUILD_B695 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B624 '
*copyc BUILD_B624
*IFEND
IF $variable(build_b695_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_b695_status kind=status
IFEND
 include_feature nv0v251                         status=build_b695_status
*DECK DECK=BUILD_B701 EXPAND=TRUE
*copyc BUILD_B710
*IF bev$product_level = 'BUILD_B701'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B701_contents
*IFEND
*DECK DECK=BUILD_B701_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B701_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B701_STATUS kind=status
IFEND
 exclude_feature nv08749                         status=BUILD_B701_STATUS
 exclude_feature nv08481                         status=BUILD_B701_STATUS
 exclude_feature nv09097                         status=BUILD_B701_STATUS
 exclude_feature nv09098                         status=BUILD_B701_STATUS
 exclude_feature nv09274                         status=BUILD_B701_STATUS
 exclude_feature nv09419                         status=BUILD_B701_STATUS
 exclude_feature nv09450                         status=BUILD_B701_STATUS
 exclude_feature nv09456                         status=BUILD_B701_STATUS
 exclude_feature nv09466                         status=BUILD_B701_STATUS
 exclude_feature broadcast_os                    status=BUILD_B701_STATUS
 exclude_feature ve_connection_switch_os         status=BUILD_B701_STATUS
 exclude_feature ve_connection_switch_os_1       status=BUILD_B701_STATUS
 exclude_feature xterm_os_changes_6              status=BUILD_B701_STATUS
 exclude_feature xterm_os_changes_8              status=BUILD_B701_STATUS
 exclude_feature xterm_os_changes_9              status=BUILD_B701_STATUS
 exclude_feature nv09387                         status=BUILD_B701_STATUS
 exclude_feature nv0v231                         status=BUILD_B701_STATUS
 exclude_feature nv0v244                         status=BUILD_B701_STATUS
 exclude_feature nv09304                         status=BUILD_B701_STATUS
 exclude_feature xterm_extract_resources_1_os    status=BUILD_B701_STATUS
 exclude_feature nv09484                         status=BUILD_B701_STATUS
 exclude_feature nv09471                         status=BUILD_B701_STATUS
 exclude_feature nv0v249                         status=BUILD_B701_STATUS
 exclude_feature nv09499                         status=BUILD_B701_STATUS
 exclude_feature nv0v250                         status=BUILD_B701_STATUS
 exclude_feature analyze_device_file             status=BUILD_B701_STATUS
 exclude_feature ac1k775_os                      status=BUILD_B701_STATUS
 exclude_feature nv09460                         status=BUILD_B701_STATUS
 exclude_feature nv0v254                         status=BUILD_B701_STATUS
 exclude_feature nv08547                         status=BUILD_B701_STATUS
 exclude_feature nv0v251                         status=BUILD_B701_STATUS
*DECK DECK=BUILD_B701_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B710_NEW_DECKS
*IF bev$product_level = 'BUILD_B701_NEW_DECKS'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B701_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B701_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B701_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B701_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck DMM$ANALYZE_DEVICE_FILE           status=BUILD_B701_NEW_DECKS_STATUS
 exclude_deck IFH$VTP_CREATE_CDCNET_CONNECT     status=BUILD_B701_NEW_DECKS_STATUS
 exclude_deck IFP$VTP_CREATE_CDCNET_CONNECT     status=BUILD_B701_NEW_DECKS_STATUS
 exclude_deck IIH$VTP_CREATE_CDCNET_CONNECT     status=BUILD_B701_NEW_DECKS_STATUS
 exclude_deck IIM$XT_CREATE_NETWORK_FILE        status=BUILD_B701_NEW_DECKS_STATUS
 exclude_deck IIP$VTP_CREATE_CDCNET_CONNECT     status=BUILD_B701_NEW_DECKS_STATUS
 exclude_deck IIP$XT_CREATE_NETWORK_FILE        status=BUILD_B701_NEW_DECKS_STATUS
 exclude_deck IIP$XT_IS_XTERM_FILE              status=BUILD_B701_NEW_DECKS_STATUS
 exclude_deck IIT$CDCNET_CONN_REJECT_REASONS    status=BUILD_B701_NEW_DECKS_STATUS
 exclude_deck RAM$ACTIVATE_YPXFRD               status=BUILD_B701_NEW_DECKS_STATUS
 exclude_deck RAM$ANALYZE_DEVICE_FILE           status=BUILD_B701_NEW_DECKS_STATUS
 exclude_deck RAM$DEACTIVATE_YPXFRD             status=BUILD_B701_NEW_DECKS_STATUS
 exclude_deck RAM$DISPLAY_DEVICE_FILE           status=BUILD_B701_NEW_DECKS_STATUS
*DECK DECK=BUILD_B710 EXPAND=TRUE
*copyc BUILD_B715
*IF bev$product_level = 'BUILD_B710'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B710_contents
*IFEND
*DECK DECK=BUILD_B710_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B710_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B710_STATUS kind=status
IFEND
 exclude_feature xterm_os_changes_10             status=BUILD_B710_STATUS
 exclude_feature nv09493                         status=BUILD_B710_STATUS
 exclude_feature nv09489                         status=BUILD_B710_STATUS
 exclude_feature bcu_helper_l780ac               status=BUILD_B710_STATUS
 exclude_feature nv09436                         status=BUILD_B710_STATUS
 exclude_feature nv09485                         status=BUILD_B710_STATUS
 exclude_feature nv09264                         status=BUILD_B710_STATUS
 exclude_feature nv0v255                         status=BUILD_B710_STATUS
 exclude_feature nv0v260                         status=BUILD_B710_STATUS
 exclude_feature nv08443                         status=BUILD_B710_STATUS
 exclude_feature nv07140                         status=BUILD_B710_STATUS
 exclude_feature nv09513                         status=BUILD_B710_STATUS
 exclude_feature nv08039_jm                      status=BUILD_B710_STATUS
 exclude_feature anaol_count_bind_section_refs_1 status=BUILD_B710_STATUS
 exclude_feature nv09507                         status=BUILD_B710_STATUS
 exclude_feature nv09512                         status=BUILD_B710_STATUS
 exclude_feature disk_ft_feature_2               status=BUILD_B710_STATUS
 exclude_feature generic_queues_ii               status=BUILD_B710_STATUS
 exclude_feature generic_queues_iia              status=BUILD_B710_STATUS
 exclude_feature move_classes_command            status=BUILD_B710_STATUS
*DECK DECK=BUILD_B710_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B715_NEW_DECKS
*IF bev$product_level = 'BUILD_B710_NEW_DECKS'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B710_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B710_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B710_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B710_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck BAI$VALIDATE_TAPE_ACCESS          status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck BAP$FIND_OPEN_FILE_VIA_SEGMENT    status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck DMP$GET_STORED_FMD_SUBFILE_LIST   status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck DMP$PUT_STORED_FMD_HEADER_INFO    status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck DMP$STORE_VALID_CLASS_IN_FMD      status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck JMH$COPY_QFILE                    status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck JMP$COPY_QFILE                    status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck JMP$OPEN_FILES_FOR_COPQF          status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck MTV$MAX_ASYNC_LOCK_TIME           status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck OSM$DISK_FAULT_TOLERANCE_23D      status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck OSP$LOG_IO_READ_ERROR             status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck PFM$MOVE_OBJECT                   status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck PFM$R2_MOVE_OBJECT                status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck PFP$DM_CREATE_FILE_ENTRY          status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck PFP$GET_FAMILIES_IN_SET           status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck PFP$GET_FILE_INFO                 status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck PFP$GET_VOLUMES_IN_SET            status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck PFP$GET_VOLUMES_SET_NAME          status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck PFP$R2_GET_MOVE_OBJ_DEVICE_INFO   status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck PFP$R2_PHYSICALLY_MOVE_CATALOG    status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck PFP$R2_PHYSICALLY_MOVE_CYCLE      status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck PFP$R3_GET_MOVE_OBJ_DEVICE_INFO   status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck PFP$R3_PHYSICALLY_MOVE_CATALOG    status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck PFP$R3_PHYSICALLY_MOVE_CYCLE      status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck PFT$MOVE_OBJECT_INFO              status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck PFT$SUBFILE                       status=BUILD_B710_NEW_DECKS_STATUS
 exclude_deck PFT$SUBFILE_LIST                  status=BUILD_B710_NEW_DECKS_STATUS
*DECK DECK=BUILD_B715 EXPAND=TRUE
*copyc BUILD_B717
*IF bev$product_level = 'BUILD_B715'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B715_contents
*IFEND
*DECK DECK=BUILD_B715_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B715_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B715_STATUS kind=status
IFEND
 exclude_feature generic_queues_iib              status=BUILD_B715_STATUS
 exclude_feature nv09522                         status=BUILD_B715_STATUS
 exclude_feature nv09567                         status=BUILD_B715_STATUS
 exclude_feature debug_av                        status=BUILD_B715_STATUS
 exclude_feature nv0v272                         status=BUILD_B715_STATUS
 exclude_feature nv09471a                        status=BUILD_B715_STATUS
 exclude_feature nv09470                         status=BUILD_B715_STATUS
 exclude_feature nv09537                         status=BUILD_B715_STATUS
 exclude_feature nv0v265                         status=BUILD_B715_STATUS
 exclude_feature nv09557                         status=BUILD_B715_STATUS
 exclude_feature nv09412                         status=BUILD_B715_STATUS
*DECK DECK=BUILD_B715_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B717_NEW_DECKS
*IF bev$product_level = 'BUILD_B715_NEW_DECKS'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B715_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B715_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B715_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B715_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck AVV$DEBUG_ACCOUNTING_VALIDATION   status=BUILD_B715_NEW_DECKS_STATUS
*DECK DECK=BUILD_B717 EXPAND=TRUE
*copyc BUILD_B720
*IF bev$product_level = 'BUILD_B717'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B717_contents
*IFEND
*DECK DECK=BUILD_B717_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B717_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B717_STATUS kind=status
IFEND
 exclude_feature nv09489                         status=BUILD_B717_STATUS
*DECK DECK=BUILD_B717_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B720_NEW_DECKS
*IF bev$product_level = 'BUILD_B717_NEW_DECKS'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B717_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B717_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B720 EXPAND=TRUE
*copyc BUILD_B722
*IF bev$product_level = 'BUILD_B720'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B720_contents
*IFEND
*DECK DECK=BUILD_B720_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B720_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B720_STATUS kind=status
IFEND
 exclude_feature nv08740                         status=BUILD_B720_STATUS
 exclude_feature nv08961                         status=BUILD_B720_STATUS
 exclude_feature nv09406                         status=BUILD_B720_STATUS
 exclude_feature nv09471b                        status=BUILD_B720_STATUS
 exclude_feature nv09493_1                       status=BUILD_B720_STATUS
 exclude_feature nv09570                         status=BUILD_B720_STATUS
 exclude_feature nv09538                         status=BUILD_B720_STATUS
 exclude_feature nv09546                         status=BUILD_B720_STATUS
 exclude_feature nv09546_1                       status=BUILD_B720_STATUS
 exclude_feature nv09546_2                       status=BUILD_B720_STATUS
 exclude_feature disk_ft_feature_2_fix1          status=BUILD_B720_STATUS
 exclude_feature move_classes_fix_1              status=BUILD_B720_STATUS
 exclude_feature move_classes_fix_4              status=BUILD_B720_STATUS
*DECK DECK=BUILD_B720_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B722_NEW_DECKS
*IF bev$product_level = 'BUILD_B720_NEW_DECKS'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B720_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B720_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B720_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B720_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck MTV$PROCESSOR_MODE                status=BUILD_B720_NEW_DECKS_STATUS
 exclude_deck PFC$MAX_LOCKED_CATALOGS           status=BUILD_B720_NEW_DECKS_STATUS
 exclude_deck PFP$R1_CLEAR_MOVE_CLASSES_LOCK    status=BUILD_B720_NEW_DECKS_STATUS
 exclude_deck PFP$R1_SET_MOVE_CLASSES_LOCK      status=BUILD_B720_NEW_DECKS_STATUS
 exclude_deck PFP$R3_CLEAR_MOVE_CLASSES_LOCK    status=BUILD_B720_NEW_DECKS_STATUS
 exclude_deck PFP$R3_SET_MOVE_CLASSES_LOCK      status=BUILD_B720_NEW_DECKS_STATUS
 exclude_deck PFT$LOCKED_CATALOG_LIST           status=BUILD_B720_NEW_DECKS_STATUS
 exclude_deck PFV$LOCKED_CATALOG_LIST           status=BUILD_B720_NEW_DECKS_STATUS
 exclude_deck QCM$CORRECT_V_FILES               status=BUILD_B720_NEW_DECKS_STATUS
 exclude_deck QCM$FILE_REPAIR_UTILITY           status=BUILD_B720_NEW_DECKS_STATUS
 exclude_deck QCM$FILE_REPAIR_UTILITY_PD        status=BUILD_B720_NEW_DECKS_STATUS
 exclude_deck QCM$QUIT_FILRU                    status=BUILD_B720_NEW_DECKS_STATUS
 exclude_deck QCV$FILRU_UTILITY_NAME            status=BUILD_B720_NEW_DECKS_STATUS
 exclude_deck RAP$MOVE_CLASSES                  status=BUILD_B720_NEW_DECKS_STATUS
*DECK DECK=BUILD_B722 EXPAND=TRUE
*copyc BUILD_B723
*IF bev$product_level = 'BUILD_B722'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B722_contents
*IFEND
*DECK DECK=BUILD_B722_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B722_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B722_STATUS kind=status
IFEND
 exclude_feature nv09471c                        status=BUILD_B722_STATUS
 exclude_feature delete_settz_from_dcfile        status=BUILD_B722_STATUS
 exclude_feature nv0v300                         status=BUILD_B722_STATUS
 exclude_feature nv0v267                         status=BUILD_B722_STATUS
*DECK DECK=BUILD_B722_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B723_NEW_DECKS
*IF bev$product_level = 'BUILD_B722_NEW_DECKS'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B722_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B722_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B722_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B722_NEW_DECKS_STATUS kind=status
IFEND
*DECK DECK=BUILD_B723 EXPAND=TRUE
*copyc BUILD_B724
*IF bev$product_level = 'BUILD_B723'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B723_contents
*IFEND
*DECK DECK=BUILD_B723_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B723_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B723_STATUS kind=status
IFEND
 exclude_feature nv09612                         status=BUILD_B723_STATUS
 exclude_feature nv0v300_fix                     status=BUILD_B723_STATUS
 exclude_feature nv0v302                         status=BUILD_B723_STATUS
*DECK DECK=BUILD_B723_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B724_NEW_DECKS
*IF bev$product_level = 'BUILD_B723_NEW_DECKS'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B723_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B723_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B723_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B723_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck NLV$DIRECTORY_ID_SEQ_NUMBER       status=BUILD_B723_NEW_DECKS_STATUS
*DECK DECK=BUILD_B724 EXPAND=TRUE
*copyc BUILD_B725
*IF bev$product_level = 'BUILD_B724'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B724_contents
*IFEND
*DECK DECK=BUILD_B724_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B724_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B725_NEW_DECKS
*IF bev$product_level = 'BUILD_B724_NEW_DECKS'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B724_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B724_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B725 EXPAND=TRUE
*copyc BUILD_B801
*IF bev$product_level = 'BUILD_B725'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B725_contents
*IFEND
*DECK DECK=BUILD_B725_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B725_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B725_STATUS kind=status
IFEND
 exclude_feature nv0v300_fix1                    status=BUILD_B725_STATUS
*DECK DECK=BUILD_B725_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B801_NEW_DECKS
*IF bev$product_level = 'BUILD_B725_NEW_DECKS'
*copyc cycleB7_exceptions
*ELSE
*copyc BUILD_B725_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B725_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B771 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B724 '
*copyc BUILD_B724
*IFEND
IF $variable(build_b771_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_b771_status kind=status
IFEND
 include_feature nv07737                         status=build_b771_status
 include_feature nv07737_1                       status=build_b771_status
 include_feature nv07737_2                       status=build_b771_status
 include_feature nv08695                         status=build_b771_status
*DECK DECK=BUILD_B791 EXPAND=TRUE
*IF bev$product_level = 'BUILD_B725 '
*copyc BUILD_B725
*IFEND
*DECK DECK=BUILD_B801 EXPAND=TRUE
*copyc BUILD_B805
*IF bev$product_level = 'BUILD_B801'
*copyc cycleB8_exceptions
IF $variable(BUILD_B801_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B801_STATUS kind=status
IFEND
 include_feature nv09208                         status=BUILD_B801_STATUS
 include_feature nv09280                         status=BUILD_B801_STATUS
 include_feature nv09538                         status=BUILD_B801_STATUS
 include_feature nv09538_2                       status=BUILD_B801_STATUS
 include_feature nv09546_3                       status=BUILD_B801_STATUS
 include_feature nv09602                         status=BUILD_B801_STATUS
 include_feature nv09552                         status=BUILD_B801_STATUS
 include_feature nv09623                         status=BUILD_B801_STATUS
 include_feature nv09623a                        status=BUILD_B801_STATUS
 include_feature nv09635                         status=BUILD_B801_STATUS
 include_feature nv09656                         status=BUILD_B801_STATUS
 include_feature tcv0269_os                      status=BUILD_B801_STATUS
 include_feature nv09573                         status=BUILD_B801_STATUS
 include_feature nv09619                         status=BUILD_B801_STATUS
 include_feature nv09669                         status=BUILD_B801_STATUS
 include_feature nv09469                         status=BUILD_B801_STATUS
 include_feature nv09632                         status=BUILD_B801_STATUS
 include_feature nv09652                         status=BUILD_B801_STATUS
 include_feature nv09297                         status=BUILD_B801_STATUS
*ELSE
*copyc BUILD_B801_contents
*IFEND
*DECK DECK=BUILD_B801_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B801_NEW_DECKS EXPAND=TRUE
*copyc BUILD_B805_NEW_DECKS
*IF bev$product_level = 'BUILD_B801_NEW_DECKS'
*copyc cycleB8_exceptions
*ELSE
*copyc BUILD_B801_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B801_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_B801_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B801_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck MMV$TEMP_FILE_SPACE_GUARD         status=BUILD_B801_NEW_DECKS_STATUS
 exclude_deck MTV$EXECUTING_AJL_AT_FAILURE      status=BUILD_B801_NEW_DECKS_STATUS
 exclude_deck MTV$PROCESSOR_MODE                status=BUILD_B801_NEW_DECKS_STATUS
 exclude_deck PMV$JOB_MAXIMUM_LIMIT_EXCEEDED    status=BUILD_B801_NEW_DECKS_STATUS
 exclude_deck SYP$RECOVER_EXECUTING_AJL_ORD     status=BUILD_B801_NEW_DECKS_STATUS
*DECK DECK=BUILD_B805 EXPAND=TRUE
*copyc BUILD_C101
*IF bev$product_level = 'BUILD_B805'
IF $variable(BUILD_B801_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B801_STATUS kind=status
IFEND
 include_feature nv09208                         status=BUILD_B801_STATUS
 include_feature nv09280                         status=BUILD_B801_STATUS
 include_feature nv09538                         status=BUILD_B801_STATUS
 include_feature nv09538_2                       status=BUILD_B801_STATUS
 include_feature nv09546_3                       status=BUILD_B801_STATUS
 include_feature nv09602                         status=BUILD_B801_STATUS
 include_feature nv09552                         status=BUILD_B801_STATUS
 include_feature nv09623                         status=BUILD_B801_STATUS
 include_feature nv09623a                        status=BUILD_B801_STATUS
 include_feature nv09635                         status=BUILD_B801_STATUS
 include_feature nv09656                         status=BUILD_B801_STATUS
 include_feature tcv0269_os                      status=BUILD_B801_STATUS
 include_feature nv09573                         status=BUILD_B801_STATUS
 include_feature nv09619                         status=BUILD_B801_STATUS
 include_feature nv09669                         status=BUILD_B801_STATUS
 include_feature nv09469                         status=BUILD_B801_STATUS
 include_feature nv09632                         status=BUILD_B801_STATUS
 include_feature nv09652                         status=BUILD_B801_STATUS
 include_feature nv09297                         status=BUILD_B801_STATUS
IF $variable(BUILD_B805_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B805_STATUS kind=status
IFEND
 include_feature nv09215                         status=BUILD_B805_STATUS
 include_feature nv09697                         status=BUILD_B805_STATUS
 include_feature nv09700                         status=BUILD_B805_STATUS
 include_feature nv09685                         status=BUILD_B805_STATUS
*copyc cycleB8_exceptions
*ELSE
*copyc BUILD_B805_contents
*IFEND
*DECK DECK=BUILD_B805_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_B805_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C101_NEW_DECKS
*IF bev$product_level = 'BUILD_B805_NEW_DECKS'
*copyc cycleB8_exceptions
*ELSE
*copyc BUILD_B805_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_B805_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C101 EXPAND=TRUE
*copyc BUILD_C111
*IF bev$product_level = 'BUILD_C101'
*copyc BUILD_B805_contents
*copyc BUILD_B801_contents
*copyc BUILD_B725_contents
*copyc BUILD_B724_contents
*copyc cycleC1_exceptions
*ELSE
*copyc BUILD_C101_contents
*IFEND
*DECK DECK=BUILD_C101_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C101_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C101_STATUS kind=status
IFEND
 exclude_feature nv09511                         status=BUILD_C101_STATUS
 exclude_feature nv09538                         status=BUILD_C101_STATUS
 exclude_feature nv09538_2                       status=BUILD_C101_STATUS
 exclude_feature nv09591                         status=BUILD_C101_STATUS
 exclude_feature nv09402                         status=BUILD_C101_STATUS
 exclude_feature nv0v201                         status=BUILD_C101_STATUS
 exclude_feature nv09208                         status=BUILD_C101_STATUS
 exclude_feature nv0v233                         status=BUILD_C101_STATUS
 exclude_feature nv0v233_fix_1                   status=BUILD_C101_STATUS
 exclude_feature nv09539                         status=BUILD_C101_STATUS
 exclude_feature nv09545                         status=BUILD_C101_STATUS
 exclude_feature nv09543                         status=BUILD_C101_STATUS
 exclude_feature nv0v310                         status=BUILD_C101_STATUS
 exclude_feature dft0054                         status=BUILD_C101_STATUS
 exclude_feature nv09280                         status=BUILD_C101_STATUS
 exclude_feature nv09561                         status=BUILD_C101_STATUS
 exclude_feature nv09549                         status=BUILD_C101_STATUS
 exclude_feature nv0v313                         status=BUILD_C101_STATUS
 exclude_feature nv09597                         status=BUILD_C101_STATUS
 exclude_feature nv09608                         status=BUILD_C101_STATUS
 exclude_feature nv09104                         status=BUILD_C101_STATUS
 exclude_feature nv0u549                         status=BUILD_C101_STATUS
 exclude_feature nv09048                         status=BUILD_C101_STATUS
 exclude_feature nv09048_fix                     status=BUILD_C101_STATUS
 exclude_feature nv09048_fix1                    status=BUILD_C101_STATUS
 exclude_feature nv09220                         status=BUILD_C101_STATUS
 exclude_feature nv09150_applied_again           status=BUILD_C101_STATUS
 exclude_feature nv09226                         status=BUILD_C101_STATUS
*DECK DECK=BUILD_C101_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C111_NEW_DECKS
*IF bev$product_level = 'BUILD_C101_NEW_DECKS'
*copyc BUILD_B805_NEW_DECKS_contents
*copyc BUILD_B801_NEW_DECKS_contents
*copyc BUILD_B725_NEW_DECKS_contents
*copyc BUILD_B724_NEW_DECKS_contents
*copyc cycleC1_exceptions
*ELSE
*copyc BUILD_C101_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C101_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C101_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C101_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck MMV$TEMP_FILE_SPACE_GUARD         status=BUILD_C101_NEW_DECKS_STATUS
 exclude_deck MTV$EXECUTING_AJL_AT_FAILURE      status=BUILD_C101_NEW_DECKS_STATUS
 exclude_deck MTV$PROCESSOR_MODE                status=BUILD_C101_NEW_DECKS_STATUS
 exclude_deck OCP$RETURN_FILES                  status=BUILD_C101_NEW_DECKS_STATUS
 exclude_deck OCT$RETURN_FILE_LIST              status=BUILD_C101_NEW_DECKS_STATUS
 exclude_deck OCV$RETURN_FILE_LIST              status=BUILD_C101_NEW_DECKS_STATUS
 exclude_deck SYP$RECOVER_EXECUTING_AJL_ORD     status=BUILD_C101_NEW_DECKS_STATUS
*DECK DECK=BUILD_C111 EXPAND=TRUE
*copyc BUILD_C121
*IF bev$product_level = 'BUILD_C111'
*copyc BUILD_B805_contents
*copyc BUILD_B801_contents
*copyc cycleC1_exceptions
*ELSE
*copyc BUILD_C111_contents
*IFEND
*DECK DECK=BUILD_C111_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C111_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C111_STATUS kind=status
IFEND
 exclude_feature nfs0124_os                      status=BUILD_C111_STATUS
 exclude_feature nfs0044                         status=BUILD_C111_STATUS
 exclude_feature nv0u632                         status=BUILD_C111_STATUS
 exclude_feature nv06469                         status=BUILD_C111_STATUS
 exclude_feature nv0v320                         status=BUILD_C111_STATUS
 exclude_feature gateway_removal_os              status=BUILD_C111_STATUS
 exclude_feature nv09602                         status=BUILD_C111_STATUS
 exclude_feature nv05788                         status=BUILD_C111_STATUS
 exclude_feature nv0v318                         status=BUILD_C111_STATUS
 exclude_feature directory_version_3             status=BUILD_C111_STATUS
 exclude_feature test_harness_update_31          status=BUILD_C111_STATUS
 exclude_feature nv05551                         status=BUILD_C111_STATUS
 exclude_feature nv09550                         status=BUILD_C111_STATUS
 exclude_feature dft0055                         status=BUILD_C111_STATUS
 exclude_feature resequence_cleanup_cm           status=BUILD_C111_STATUS
 exclude_feature nv09546_3                       status=BUILD_C111_STATUS
 exclude_feature nv08892                         status=BUILD_C111_STATUS
 exclude_feature nv06669                         status=BUILD_C111_STATUS
 exclude_feature nv07737                         status=BUILD_C111_STATUS
 exclude_feature nv07737_1                       status=BUILD_C111_STATUS
 exclude_feature nv07737_2                       status=BUILD_C111_STATUS
 exclude_feature nv07737_4                       status=BUILD_C111_STATUS
 exclude_feature nv08695                         status=BUILD_C111_STATUS
 exclude_feature nv06437                         status=BUILD_C111_STATUS
*DECK DECK=BUILD_C111_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C121_NEW_DECKS
*IF bev$product_level = 'BUILD_C111_NEW_DECKS'
*copyc BUILD_B805_NEW_DECKS_contents
*copyc BUILD_B801_NEW_DECKS_contents
*copyc cycleC1_exceptions
*ELSE
*copyc BUILD_C111_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C111_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C111_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C111_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck DSP$SET_ALLOW_LOGGING_FLAG        status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck DSV$ALLOW_LOGGING                 status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck MMC$NULL_SHARED_QUEUE             status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck MMP$FETCH_SITE_ACTIVE_Q_CNT_R1    status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck MMP$FETCH_SITE_ACTIVE_Q_CNT_R3    status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck MMP$STORE_SITE_ACTIVE_Q_CNT_R1    status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck MMT$SHARED_QUEUE                  status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck PFC$MAX_SHARED_QUEUE              status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck PFC$NULL_SHARED_QUEUE             status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck PFC$SHARED_QUEUES                 status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck PFC$SYSTEM_SHARED_QUEUE_NAME      status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck PFP$CONVERT_ORD_TO_SHARED_QUEUE   status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck PFP$CONVERT_SHARED_QUEUE_TO_ORD   status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck PFP$LOG_STATUS                    status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck PFP$SHARED_QUEUE                  status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck PFT$SHARED_QUEUE                  status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck PFT$SHARED_QUEUE_INFO             status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck PUC$DELETE_ALL_FILES_MESSAGE      status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck PUM$RESOURCE_HELP_MESSAGES        status=BUILD_C111_NEW_DECKS_STATUS
 exclude_deck RAM$WRITE_TAPE_MARK_COMMAND       status=BUILD_C111_NEW_DECKS_STATUS
*DECK DECK=BUILD_C121 EXPAND=TRUE
*copyc BUILD_C131
*IF bev$product_level = 'BUILD_C121'
*copyc BUILD_B805_contents
*copyc BUILD_B801_contents
*copyc cycleC1_exceptions
*ELSE
*copyc BUILD_C121_contents
*IFEND
*DECK DECK=BUILD_C121_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C121_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C131_NEW_DECKS
*IF bev$product_level = 'BUILD_C121_NEW_DECKS'
*copyc BUILD_B805_NEW_DECKS_contents
*copyc BUILD_B801_NEW_DECKS_contents
*copyc cycleC1_exceptions
*ELSE
*copyc BUILD_C121_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C121_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C131 EXPAND=TRUE
*copyc BUILD_C141
*IF bev$product_level = 'BUILD_C131'
*copyc BUILD_B805_contents
*copyc BUILD_B801_contents
*copyc cycleC1_exceptions
*ELSE
*copyc BUILD_C131_contents
*IFEND
*DECK DECK=BUILD_C131_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C131_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C131_STATUS kind=status
IFEND
 exclude_feature nv06497                         status=BUILD_C131_STATUS
 exclude_feature nv07737_5                       status=BUILD_C131_STATUS
 exclude_feature nv09340                         status=BUILD_C131_STATUS
 exclude_feature nv09552                         status=BUILD_C131_STATUS
 exclude_feature nv09623                         status=BUILD_C131_STATUS
 exclude_feature nv09623a                        status=BUILD_C131_STATUS
 exclude_feature nv09635                         status=BUILD_C131_STATUS
 exclude_feature nv0v322                         status=BUILD_C131_STATUS
 exclude_feature nv0v325                         status=BUILD_C131_STATUS
 exclude_feature dfta213                         status=BUILD_C131_STATUS
 exclude_feature sc80486_os                      status=BUILD_C131_STATUS
 exclude_feature nfs0045_os                      status=BUILD_C131_STATUS
 exclude_feature tcva347_os                      status=BUILD_C131_STATUS
 exclude_feature disk_ft_phase3a                 status=BUILD_C131_STATUS
 exclude_feature chalpw_in_queued_jobs           status=BUILD_C131_STATUS
 exclude_feature read_tailored_file              status=BUILD_C131_STATUS
*DECK DECK=BUILD_C131_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C141_NEW_DECKS
*IF bev$product_level = 'BUILD_C131_NEW_DECKS'
*copyc BUILD_B805_NEW_DECKS_contents
*copyc BUILD_B801_NEW_DECKS_contents
*copyc cycleC1_exceptions
*ELSE
*copyc BUILD_C131_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C131_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C131_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C131_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck FSC$WAIT_DATA_RESTORATION         status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck OSC$DATA_RESTORATION_COND         status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck OSD$EXCEPTION_POLICIES            status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck OSE$DISK_FT_EXCEPTIONS            status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck OSM$DISK_FAULT_TOLERANCE_113      status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck OSM$DISK_FAULT_TOLERANCE_13D      status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck OSM$MANAGE_EXCEPTION_POLICIES     status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck OSP$COPY_EXCEPTION_POLICIES       status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck OSP$COPY_INSTALLED_POLICIES       status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck OSP$FIND_APPLICABLE_POLICY        status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck OSP$GET_LOGIN_USER_CRITERIA       status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck OSP$R1_COPY_INSTALLED_POLICIES    status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck OSP$R1_INSTALL_EXCEPTION_POLICY   status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck OSP$R3_COPY_INSTALLED_POLICIES    status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck OSP$R3_INSTALL_EXCEPTION_POLICY   status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck OSP$STORE_SEQUENCE_HEADERS        status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck OSV$ECP_SEQUENCE_HEADERS          status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck PFP$ADD_TO_PROJECT_INFO           status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck PFP$CREATE_SCRATCH_SEGMENTS       status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck PFP$RECORD_CATALOG_ERROR          status=BUILD_C131_NEW_DECKS_STATUS
 exclude_deck PFP$WRITE_LIMIT_ENTRY             status=BUILD_C131_NEW_DECKS_STATUS
*DECK DECK=BUILD_C141 EXPAND=TRUE
*copyc BUILD_C151
*IF bev$product_level = 'BUILD_C141'
*copyc BUILD_B805_contents
*copyc BUILD_B801_contents
*copyc cycleC1_exceptions
*ELSE
*copyc BUILD_C141_contents
*IFEND
*DECK DECK=BUILD_C141_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C141_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C141_STATUS kind=status
IFEND
 exclude_feature nv09575                         status=BUILD_C141_STATUS
 exclude_feature scratch_volume_support_for_rms  status=BUILD_C141_STATUS
 exclude_feature initv_support_for_rms           status=BUILD_C141_STATUS
 exclude_feature tcv0269_os                      status=BUILD_C141_STATUS
 exclude_feature nv0v327                         status=BUILD_C141_STATUS
 exclude_feature nv09656                         status=BUILD_C141_STATUS
*DECK DECK=BUILD_C141_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C151_NEW_DECKS
*IF bev$product_level = 'BUILD_C141_NEW_DECKS'
*copyc BUILD_B805_NEW_DECKS_contents
*copyc BUILD_B801_NEW_DECKS_contents
*copyc cycleC1_exceptions
*ELSE
*copyc BUILD_C141_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C141_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C141_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C141_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck DMH$FETCH_TAPE_UNIT_COUNT         status=BUILD_C141_NEW_DECKS_STATUS
 exclude_deck DMH$FETCH_TAPE_UNIT_STATUS_INFO   status=BUILD_C141_NEW_DECKS_STATUS
 exclude_deck DMP$FETCH_TAPE_UNIT_COUNT         status=BUILD_C141_NEW_DECKS_STATUS
 exclude_deck DMP$FETCH_TAPE_UNIT_STATUS_INFO   status=BUILD_C141_NEW_DECKS_STATUS
 exclude_deck DMT$TAPE_UNIT_STATUS_INFO         status=BUILD_C141_NEW_DECKS_STATUS
*DECK DECK=BUILD_C151 EXPAND=TRUE
*copyc BUILD_C201
*IF bev$product_level = 'BUILD_C151'
*copyc BUILD_B805_contents
*copyc BUILD_B801_contents
*copyc cycleC1_exceptions
*ELSE
*copyc BUILD_C151_contents
*IFEND
*DECK DECK=BUILD_C151_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C151_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C151_STATUS kind=status
IFEND
 exclude_feature move_classes_fix_5              status=BUILD_C151_STATUS
 exclude_feature nv09619                         status=BUILD_C151_STATUS
 exclude_feature nv09669                         status=BUILD_C151_STATUS
 exclude_feature disk_ft_phase3b                 status=BUILD_C151_STATUS
 exclude_feature nv03313                         status=BUILD_C151_STATUS
 exclude_feature nv03313a                        status=BUILD_C151_STATUS
 exclude_feature nv09573                         status=BUILD_C151_STATUS
 exclude_feature test_harness_update_32          status=BUILD_C151_STATUS
 exclude_feature nv06787                         status=BUILD_C151_STATUS
*DECK DECK=BUILD_C151_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C201_NEW_DECKS
*IF bev$product_level = 'BUILD_C151_NEW_DECKS'
*copyc BUILD_B805_NEW_DECKS_contents
*copyc BUILD_B801_NEW_DECKS_contents
*copyc cycleC1_exceptions
*ELSE
*copyc BUILD_C151_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C151_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C151_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C151_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CLC$COPYRIGHT                     status=BUILD_C151_NEW_DECKS_STATUS
 exclude_deck CLE$COPYRIGHT                     status=BUILD_C151_NEW_DECKS_STATUS
 exclude_deck FST$MASS_STORAGE_EXCEPTIONS       status=BUILD_C151_NEW_DECKS_STATUS
 exclude_deck OSM$DEBUG_TABLES                  status=BUILD_C151_NEW_DECKS_STATUS
 exclude_deck OSP$GET_INSTALLED_POLICIES        status=BUILD_C151_NEW_DECKS_STATUS
 exclude_deck OSP$GET_UNION_OF_POLICIES         status=BUILD_C151_NEW_DECKS_STATUS
 exclude_deck OSP$R1_GET_INSTALLED_POLICIES     status=BUILD_C151_NEW_DECKS_STATUS
 exclude_deck OSP$R3_GET_INSTALLED_POLICIES     status=BUILD_C151_NEW_DECKS_STATUS
 exclude_deck PFC$MOVE_CLASSES                  status=BUILD_C151_NEW_DECKS_STATUS
 exclude_deck PFM$ACTION_MESSAGES               status=BUILD_C151_NEW_DECKS_STATUS
 exclude_deck PFM$EXTRACT_FILE_LIST             status=BUILD_C151_NEW_DECKS_STATUS
 exclude_deck PFM$EXTRACT_FILE_LIST_PD          status=BUILD_C151_NEW_DECKS_STATUS
 exclude_deck PMV$JOB_MAXIMUM_LIMIT_EXCEEDED    status=BUILD_C151_NEW_DECKS_STATUS
*DECK DECK=BUILD_C201 EXPAND=TRUE
*copyc BUILD_C301
*IF bev$product_level = 'BUILD_C201'
*copyc BUILD_B805_contents
*copyc BUILD_B801_contents
*copyc cycleC2_exceptions
*ELSE
*copyc BUILD_C201_contents
*IFEND
*DECK DECK=BUILD_C201_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C201_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C201_STATUS kind=status
IFEND
 exclude_feature nv07737_dissfid                 status=BUILD_C201_STATUS
 exclude_feature nv07586                         status=BUILD_C201_STATUS
 exclude_feature nv09038                         status=BUILD_C201_STATUS
 exclude_feature nv09469                         status=BUILD_C201_STATUS
 exclude_feature nv09632                         status=BUILD_C201_STATUS
 exclude_feature nv09663                         status=BUILD_C201_STATUS
 exclude_feature nv09679                         status=BUILD_C201_STATUS
 exclude_feature nv0v336                         status=BUILD_C201_STATUS
 exclude_feature kinder_gentler_dft              status=BUILD_C201_STATUS
*DECK DECK=BUILD_C201_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C301_NEW_DECKS
*IF bev$product_level = 'BUILD_C201_NEW_DECKS'
*copyc BUILD_B805_NEW_DECKS_contents
*copyc BUILD_B801_NEW_DECKS_contents
*copyc cycleC2_exceptions
*ELSE
*copyc BUILD_C201_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C201_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C201_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C201_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck QFP$GET_APPLICATION_NAME          status=BUILD_C201_NEW_DECKS_STATUS
*DECK DECK=BUILD_C301 EXPAND=TRUE
*copyc BUILD_C302
*IF bev$product_level = 'BUILD_C301'
*copyc BUILD_B805_contents
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C301_contents
*IFEND
*DECK DECK=BUILD_C301_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C301_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C301_STATUS kind=status
IFEND
 exclude_feature nv09297                         status=BUILD_C301_STATUS
 exclude_feature nv09215                         status=BUILD_C301_STATUS
 exclude_feature nv09652                         status=BUILD_C301_STATUS
*DECK DECK=BUILD_C301_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C302_NEW_DECKS
*IF bev$product_level = 'BUILD_C301_NEW_DECKS'
*copyc BUILD_B805_NEW_DECKS_contents
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C301_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C301_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C302 EXPAND=TRUE
*copyc BUILD_C303
*IF bev$product_level = 'BUILD_C302'
*copyc BUILD_B805_contents
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C302_contents
*IFEND
*DECK DECK=BUILD_C302_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C302_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C303_NEW_DECKS
*IF bev$product_level = 'BUILD_C302_NEW_DECKS'
*copyc BUILD_B805_NEW_DECKS_contents
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C302_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C302_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C303 EXPAND=TRUE
*copyc BUILD_C304
*IF bev$product_level = 'BUILD_C303'
*copyc BUILD_B805_contents
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C303_contents
*IFEND
*DECK DECK=BUILD_C303_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C303_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C303_STATUS kind=status
IFEND
 exclude_feature gjf                             status=BUILD_C303_STATUS
 exclude_feature nv09700                         status=BUILD_C303_STATUS
 exclude_feature nv09697                         status=BUILD_C303_STATUS
 exclude_feature nv09685                         status=BUILD_C303_STATUS
 exclude_feature nv09633                         status=BUILD_C303_STATUS
 exclude_feature nv0v343a                        status=BUILD_C303_STATUS
 exclude_feature nv0v342                         status=BUILD_C303_STATUS
*DECK DECK=BUILD_C303_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C304_NEW_DECKS
*IF bev$product_level = 'BUILD_C303_NEW_DECKS'
*copyc BUILD_B805_NEW_DECKS_contents
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C303_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C303_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C304 EXPAND=TRUE
*copyc BUILD_C305
*IF bev$product_level = 'BUILD_C304'
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C304_contents
*IFEND
*DECK DECK=BUILD_C304_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C304_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C304_STATUS kind=status
IFEND
 exclude_feature copyright_drivers               status=BUILD_C304_STATUS
 exclude_feature copyright_mapv_driver           status=BUILD_C304_STATUS
 exclude_feature copyright_misc_drivers          status=BUILD_C304_STATUS
 exclude_feature copyright_namve                 status=BUILD_C304_STATUS
 exclude_feature copyright_os_banner             status=BUILD_C304_STATUS
 exclude_feature copyright_os_common             status=BUILD_C304_STATUS
 exclude_feature copyright_os_eum                status=BUILD_C304_STATUS
 exclude_feature copyright_os_ra                 status=BUILD_C304_STATUS
 exclude_feature copyright_os_rf                 status=BUILD_C304_STATUS
 exclude_feature copyright_os_tdu                status=BUILD_C304_STATUS
 exclude_feature dft_930_pkt_mod                 status=BUILD_C304_STATUS
 exclude_feature scw_copyright                   status=BUILD_C304_STATUS
 exclude_feature nv09559                         status=BUILD_C304_STATUS
 exclude_feature copyright_dft                   status=BUILD_C304_STATUS
*DECK DECK=BUILD_C304_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C305_NEW_DECKS
*IF bev$product_level = 'BUILD_C304_NEW_DECKS'
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C304_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C304_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C305 EXPAND=TRUE
*copyc BUILD_C306
*IF bev$product_level = 'BUILD_C305'
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C305_contents
*IFEND
*DECK DECK=BUILD_C305_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C305_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C305_STATUS kind=status
IFEND
 exclude_feature nv09340_v1                      status=BUILD_C305_STATUS
 exclude_feature nv09215_fix                     status=BUILD_C305_STATUS
 exclude_feature scw_copyright_1                 status=BUILD_C305_STATUS
*DECK DECK=BUILD_C305_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C306_NEW_DECKS
*IF bev$product_level = 'BUILD_C305_NEW_DECKS'
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C305_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C305_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C305_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C305_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck AVP$CHANGE_USER_PF_SPACE_LIMIT    status=BUILD_C305_NEW_DECKS_STATUS
*DECK DECK=BUILD_C306 EXPAND=TRUE
*copyc BUILD_C307
*IF bev$product_level = 'BUILD_C306'
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C306_contents
*IFEND
*DECK DECK=BUILD_C306_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C306_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C306_STATUS kind=status
IFEND
 exclude_feature disk_ft_phase3b_fix_1           status=BUILD_C306_STATUS
 exclude_feature disk_ft_phase3b_fix_2           status=BUILD_C306_STATUS
 exclude_feature nv05551_fix                     status=BUILD_C306_STATUS
 exclude_feature change_maxjc_and_maxsc_defaults status=BUILD_C306_STATUS
 exclude_feature ivsa808_os                      status=BUILD_C306_STATUS
 exclude_feature ivsa808_os_2                    status=BUILD_C306_STATUS
*DECK DECK=BUILD_C306_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C307_NEW_DECKS
*IF bev$product_level = 'BUILD_C306_NEW_DECKS'
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C306_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C306_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C306_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C306_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck FST$VOLUME_CONDITION_LIST         status=BUILD_C306_NEW_DECKS_STATUS
 exclude_deck RAP$ALTER_ACCESS_MODES            status=BUILD_C306_NEW_DECKS_STATUS
*DECK DECK=BUILD_C307 EXPAND=TRUE
*copyc BUILD_C308
*IF bev$product_level = 'BUILD_C307'
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C307_contents
*IFEND
*DECK DECK=BUILD_C307_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C307_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C307_STATUS kind=status
IFEND
 exclude_feature nv09754                         status=BUILD_C307_STATUS
 exclude_feature nv09340_v2                      status=BUILD_C307_STATUS
 exclude_feature nv09757                         status=BUILD_C307_STATUS
*DECK DECK=BUILD_C307_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C308_NEW_DECKS
*IF bev$product_level = 'BUILD_C307_NEW_DECKS'
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C307_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C307_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C308 EXPAND=TRUE
*copyc BUILD_C309
*IF bev$product_level = 'BUILD_C308'
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C308_contents
*IFEND
*DECK DECK=BUILD_C308_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C308_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C308_STATUS kind=status
IFEND
 exclude_feature ivsa808_os_3                    status=BUILD_C308_STATUS
*DECK DECK=BUILD_C308_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C309_NEW_DECKS
*IF bev$product_level = 'BUILD_C308_NEW_DECKS'
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C308_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C308_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C309 EXPAND=TRUE
*copyc BUILD_C310
*IF bev$product_level = 'BUILD_C309'
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C309_contents
*IFEND
*DECK DECK=BUILD_C309_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C309_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C309_STATUS kind=status
IFEND
 exclude_feature nv0v381                         status=BUILD_C309_STATUS
 exclude_feature nv0v384                         status=BUILD_C309_STATUS
 exclude_feature dfta214                         status=BUILD_C309_STATUS
 exclude_feature change_c2f$library_value        status=BUILD_C309_STATUS
 exclude_feature int_load_lev_remove_ro_data     status=BUILD_C309_STATUS
 exclude_feature disk_ft_phase3c_os              status=BUILD_C309_STATUS
*DECK DECK=BUILD_C309_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C310_NEW_DECKS
*IF bev$product_level = 'BUILD_C309_NEW_DECKS'
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C309_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C309_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C309_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C309_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck OSM$DEFAULT_EXCEPTION_POLICIES    status=BUILD_C309_NEW_DECKS_STATUS
*DECK DECK=BUILD_C310 EXPAND=TRUE
*copyc BUILD_C401
*IF bev$product_level = 'BUILD_C310'
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C310_contents
*IFEND
*DECK DECK=BUILD_C310_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C310_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C310_STATUS kind=status
IFEND
 exclude_feature nv09785                         status=BUILD_C310_STATUS
 exclude_feature nv0v385                         status=BUILD_C310_STATUS
 exclude_feature job_paged                       status=BUILD_C310_STATUS
 exclude_feature nv09699                         status=BUILD_C310_STATUS
*DECK DECK=BUILD_C310_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C401_NEW_DECKS
*IF bev$product_level = 'BUILD_C310_NEW_DECKS'
*copyc cycleC3_exceptions
*ELSE
*copyc BUILD_C310_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C310_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C371 EXPAND=TRUE
*IF bev$product_level = 'BUILD_C306 '
*copyc BUILD_C306
*IFEND
IF $variable(build_c371_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_c371_status kind=status
IFEND
 include_feature add_support_for_eliteii         status=build_c371_status
 include_feature nv09754                         status=build_c371_status
 include_feature nv09340_v2                      status=build_c371_status
 include_feature nv09757                         status=build_c371_status
 include_feature ivsa808_os_3                    status=build_c371_status
*DECK DECK=BUILD_C372 EXPAND=TRUE
*IF bev$product_level = 'BUILD_C308 '
*copyc BUILD_C308
*IFEND
IF $variable(build_c372_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_c372_status kind=status
IFEND
 include_feature add_support_for_eliteii         status=build_c372_status
 include_feature nv0v381                         status=build_c372_status
 include_feature nv0v384                         status=build_c372_status
 include_feature dfta214                         status=build_c372_status
 include_feature change_c2f$library_value        status=build_c372_status
 include_feature int_load_lev_remove_ro_data     status=build_c372_status
*DECK DECK=BUILD_C373 EXPAND=TRUE
*IF bev$product_level = 'BUILD_C308 '
*copyc BUILD_C308
*IFEND
*copyc BUILD_C372
IF $variable(build_c373_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_c373_status kind=status
IFEND
 include_feature nv09699                         status=build_c373_status
 include_feature nv09785                         status=build_c373_status
 include_feature nv0v385                         status=build_c373_status
 include_feature job_paged                       status=build_c373_status
*DECK DECK=BUILD_C401 EXPAND=TRUE
*copyc BUILD_C411
*IF bev$product_level = 'BUILD_C401'
*copyc BUILD_C310_contents
*copyc BUILD_C309_contents
*copyc BUILD_C308_contents
*copyc BUILD_C307_contents
*copyc BUILD_C306_contents
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C401_contents
*IFEND
*DECK DECK=BUILD_C401_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C401_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C401_STATUS kind=status
IFEND
 exclude_feature nv07345                         status=BUILD_C401_STATUS
 exclude_feature nv07907                         status=BUILD_C401_STATUS
 exclude_feature nv08954_part_2                  status=BUILD_C401_STATUS
 exclude_feature nv09244_part_1                  status=BUILD_C401_STATUS
 exclude_feature nv09433                         status=BUILD_C401_STATUS
 exclude_feature nv09477                         status=BUILD_C401_STATUS
 exclude_feature nv09565                         status=BUILD_C401_STATUS
 exclude_feature nv09637                         status=BUILD_C401_STATUS
 exclude_feature nv09661                         status=BUILD_C401_STATUS
 exclude_feature nv09668                         status=BUILD_C401_STATUS
 exclude_feature nv09686                         status=BUILD_C401_STATUS
 exclude_feature nv09690                         status=BUILD_C401_STATUS
 exclude_feature nv09713                         status=BUILD_C401_STATUS
 exclude_feature nv09717                         status=BUILD_C401_STATUS
 exclude_feature nv0r618                         status=BUILD_C401_STATUS
 exclude_feature nv0v190                         status=BUILD_C401_STATUS
 exclude_feature nv0v341                         status=BUILD_C401_STATUS
 exclude_feature nv0v354                         status=BUILD_C401_STATUS
 exclude_feature open_fault_tolerance            status=BUILD_C401_STATUS
*DECK DECK=BUILD_C401_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C411_NEW_DECKS
*IF bev$product_level = 'BUILD_C401_NEW_DECKS'
*copyc BUILD_C310_NEW_DECKS_contents
*copyc BUILD_C309_NEW_DECKS_contents
*copyc BUILD_C308_NEW_DECKS_contents
*copyc BUILD_C307_NEW_DECKS_contents
*copyc BUILD_C306_NEW_DECKS_contents
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C401_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C401_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C401_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C401_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck DMP$REPLACE_CLIENT_SFT            status=BUILD_C401_NEW_DECKS_STATUS
 exclude_deck NFP$PTF_FORMAT_MESSAGE_TO_OUT     status=BUILD_C401_NEW_DECKS_STATUS
 exclude_deck OSP$GET_VOLUME_CONDITION          status=BUILD_C401_NEW_DECKS_STATUS
 exclude_deck PFT$EXCEPTION_SELECTION_INFO      status=BUILD_C401_NEW_DECKS_STATUS
 exclude_deck RAM$ACTIVATE_DRJE                 status=BUILD_C401_NEW_DECKS_STATUS
 exclude_deck RAM$DEACTIVATE_DRJE               status=BUILD_C401_NEW_DECKS_STATUS
 exclude_deck RAM$DELETE_PACKING_LIST           status=BUILD_C401_NEW_DECKS_STATUS
*DECK DECK=BUILD_C411 EXPAND=TRUE
*copyc BUILD_C421
*IF bev$product_level = 'BUILD_C411'
*copyc BUILD_C310_contents
*copyc BUILD_C309_contents
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C411_contents
*IFEND
*DECK DECK=BUILD_C411_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C411_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C411_STATUS kind=status
IFEND
 exclude_feature add_support_for_eliteii         status=BUILD_C411_STATUS
 exclude_feature ftma045                         status=BUILD_C411_STATUS
 exclude_feature nv07494                         status=BUILD_C411_STATUS
 exclude_feature nv08685                         status=BUILD_C411_STATUS
 exclude_feature nv09467                         status=BUILD_C411_STATUS
 exclude_feature nv09609                         status=BUILD_C411_STATUS
 exclude_feature nv09709                         status=BUILD_C411_STATUS
 exclude_feature nv09725                         status=BUILD_C411_STATUS
 exclude_feature nv09729                         status=BUILD_C411_STATUS
 exclude_feature nv09730                         status=BUILD_C411_STATUS
 exclude_feature nv09761                         status=BUILD_C411_STATUS
 exclude_feature nv0v355                         status=BUILD_C411_STATUS
 exclude_feature nv0v363                         status=BUILD_C411_STATUS
 exclude_feature nv0v364                         status=BUILD_C411_STATUS
 exclude_feature nv0v371                         status=BUILD_C411_STATUS
 exclude_feature nv0v372                         status=BUILD_C411_STATUS
 exclude_feature tcv0283                         status=BUILD_C411_STATUS
 exclude_feature utility_port_os                 status=BUILD_C411_STATUS
 exclude_feature utility_port_fix_1              status=BUILD_C411_STATUS
*DECK DECK=BUILD_C411_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C421_NEW_DECKS
*IF bev$product_level = 'BUILD_C411_NEW_DECKS'
*copyc BUILD_C310_NEW_DECKS_contents
*copyc BUILD_C309_NEW_DECKS_contents
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C411_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C411_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C411_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C411_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck IIC$XT_JOB_CATALOG_NAME           status=BUILD_C411_NEW_DECKS_STATUS
 exclude_deck IIC$XT_MAX_MESSAGE_LENGTH         status=BUILD_C411_NEW_DECKS_STATUS
 exclude_deck IIC$XT_MESSAGE_OFFSET             status=BUILD_C411_NEW_DECKS_STATUS
 exclude_deck IIC$XT_STATUS_CATALOG_NAME        status=BUILD_C411_NEW_DECKS_STATUS
 exclude_deck IIP$XT_WAIT_FOR_XTERM             status=BUILD_C411_NEW_DECKS_STATUS
 exclude_deck IIT$XT_XTERM_STATUS               status=BUILD_C411_NEW_DECKS_STATUS
 exclude_deck JMP$RECOVER_INPUT_QUEUE           status=BUILD_C411_NEW_DECKS_STATUS
*DECK DECK=BUILD_C421 EXPAND=TRUE
*copyc BUILD_C422
*IF bev$product_level = 'BUILD_C421'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C421_contents
*IFEND
*DECK DECK=BUILD_C421_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C421_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C421_STATUS kind=status
IFEND
 exclude_feature nv07863                         status=BUILD_C421_STATUS
 exclude_feature nv07926                         status=BUILD_C421_STATUS
 exclude_feature nv0v394                         status=BUILD_C421_STATUS
 exclude_feature nv0q413                         status=BUILD_C421_STATUS
 exclude_feature nv09703                         status=BUILD_C421_STATUS
 exclude_feature nv09776                         status=BUILD_C421_STATUS
 exclude_feature nv08822                         status=BUILD_C421_STATUS
 exclude_feature nv08796                         status=BUILD_C421_STATUS
 exclude_feature nv08581                         status=BUILD_C421_STATUS
 exclude_feature nv09411                         status=BUILD_C421_STATUS
 exclude_feature nv09792                         status=BUILD_C421_STATUS
 exclude_feature ef40002                         status=BUILD_C421_STATUS
 exclude_feature nv09768                         status=BUILD_C421_STATUS
 exclude_feature nv08936                         status=BUILD_C421_STATUS
 exclude_feature nv09248                         status=BUILD_C421_STATUS
 exclude_feature nv09772                         status=BUILD_C421_STATUS
 exclude_feature nv09769                         status=BUILD_C421_STATUS
 exclude_feature nv08925                         status=BUILD_C421_STATUS
 exclude_feature nv08215                         status=BUILD_C421_STATUS
 exclude_feature nv09746                         status=BUILD_C421_STATUS
 exclude_feature remove_dfm$printer              status=BUILD_C421_STATUS
 exclude_feature nv0s151                         status=BUILD_C421_STATUS
*DECK DECK=BUILD_C421_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C422_NEW_DECKS
*IF bev$product_level = 'BUILD_C421_NEW_DECKS'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C421_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C421_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C421_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C421_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck JME$VSN_OR_VSNP_OR_BF_REQUIRED    status=BUILD_C421_NEW_DECKS_STATUS
 exclude_deck JME$VSN_VSNP_VSNS_BF_REQUIRED     status=BUILD_C421_NEW_DECKS_STATUS
*DECK DECK=BUILD_C422 EXPAND=TRUE
*copyc BUILD_C423
*IF bev$product_level = 'BUILD_C422'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C422_contents
*IFEND
*DECK DECK=BUILD_C422_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C422_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C423_NEW_DECKS
*IF bev$product_level = 'BUILD_C422_NEW_DECKS'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C422_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C422_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C423 EXPAND=TRUE
*copyc BUILD_C430
*IF bev$product_level = 'BUILD_C423'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C423_contents
*IFEND
*DECK DECK=BUILD_C423_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C423_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C423_STATUS kind=status
IFEND
 exclude_feature nv01433                         status=BUILD_C423_STATUS
 exclude_feature nv09146os                       status=BUILD_C423_STATUS
 exclude_feature nv09150_fix                     status=BUILD_C423_STATUS
 exclude_feature nv09150_fix1                    status=BUILD_C423_STATUS
 exclude_feature nv09333                         status=BUILD_C423_STATUS
 exclude_feature nv09400                         status=BUILD_C423_STATUS
 exclude_feature nv09492                         status=BUILD_C423_STATUS
 exclude_feature nv09515                         status=BUILD_C423_STATUS
 exclude_feature nv09771                         status=BUILD_C423_STATUS
 exclude_feature nv09780                         status=BUILD_C423_STATUS
 exclude_feature nv09781                         status=BUILD_C423_STATUS
 exclude_feature nv09805                         status=BUILD_C423_STATUS
 exclude_feature nv09814                         status=BUILD_C423_STATUS
 exclude_feature nv09818                         status=BUILD_C423_STATUS
 exclude_feature nv0v400                         status=BUILD_C423_STATUS
 exclude_feature nv0v404                         status=BUILD_C423_STATUS
 exclude_feature nv0v406                         status=BUILD_C423_STATUS
 exclude_feature ef40004                         status=BUILD_C423_STATUS
 exclude_feature ef4a001                         status=BUILD_C423_STATUS
 exclude_feature remove_old_attributes           status=BUILD_C423_STATUS
*DECK DECK=BUILD_C423_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C430_NEW_DECKS
*IF bev$product_level = 'BUILD_C423_NEW_DECKS'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C423_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C423_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C430 EXPAND=TRUE
*copyc BUILD_C431
*IF bev$product_level = 'BUILD_C430'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C430_contents
*IFEND
*DECK DECK=BUILD_C430_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C430_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C430_STATUS kind=status
IFEND
 exclude_feature bcu_helper_l803aa               status=BUILD_C430_STATUS
 exclude_feature cso_ph_client_os                status=BUILD_C430_STATUS
 exclude_feature disk_ft_phase3c                 status=BUILD_C430_STATUS
 exclude_feature nv06226                         status=BUILD_C430_STATUS
 exclude_feature nv06395                         status=BUILD_C430_STATUS
 exclude_feature nv07103                         status=BUILD_C430_STATUS
 exclude_feature nv07128                         status=BUILD_C430_STATUS
 exclude_feature nv07325                         status=BUILD_C430_STATUS
 exclude_feature nv08077                         status=BUILD_C430_STATUS
 exclude_feature nv08642                         status=BUILD_C430_STATUS
 exclude_feature nv09068                         status=BUILD_C430_STATUS
 exclude_feature nv09184                         status=BUILD_C430_STATUS
 exclude_feature nv09646                         status=BUILD_C430_STATUS
 exclude_feature nv09646_fix                     status=BUILD_C430_STATUS
 exclude_feature nv09681                         status=BUILD_C430_STATUS
 exclude_feature nv09695                         status=BUILD_C430_STATUS
 exclude_feature nv09695_fix                     status=BUILD_C430_STATUS
 exclude_feature nv09828                         status=BUILD_C430_STATUS
 exclude_feature nv0e569                         status=BUILD_C430_STATUS
 exclude_feature nv0v396                         status=BUILD_C430_STATUS
 exclude_feature update_copyright_1993           status=BUILD_C430_STATUS
*DECK DECK=BUILD_C430_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C431_NEW_DECKS
*IF bev$product_level = 'BUILD_C430_NEW_DECKS'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C430_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C430_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C430_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C430_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck FSC$WAIT_MSG_MODULE_NAME          status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck FSC$WAIT_UNDEFINED_CONDITION      status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck FSC$WAIT_VOLUME_MISSING           status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck FSC$WAIT_VOLUME_UNAVAILABLE       status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck FSM$FILE_ACCESS_CONDITIONS        status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck FSM$HELP_MESSAGES                 status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck FSP$DEFAULT_FILE_CLASS            status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck FSP$FIND_ACCESS_CONDITION_ENTRY   status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck IPM$SENCPR_PROGRAM_DESCRIPTION    status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck NV0E569                           status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck OSM$DISK_FAULT_TOLERANCE_2DD      status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck OSP$CHACC_APPLICABLE_POLICY       status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck OSP$ENFORCE_EXCEPTION_POLICIES    status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck OSP$FORMAT_WAIT_MESSAGE           status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck OSP$GET_FILE_CRITERIA             status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck OSP$GET_POLICY                    status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck OSP$GET_POLICY_LIST               status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck OSP$GET_RELEVANT_PATH_STRING      status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck OSP$INSTALL_EXCEPTION_POLICIES    status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck OSP$LOG_EXECUTED_POLICY           status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck OSP$REMOVE_POLICY                 status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck PFC$CHACC_HELP_MODULE_NAME        status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck PFM$HELP_MESSAGES                 status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck PFP$R2_DF_CLIENT_GET_VOL_CL       status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck PFP$R2_GET_VOL_CONDITION_LIST     status=BUILD_C430_NEW_DECKS_STATUS
 exclude_deck RAP$MANAGE_EXCEPTION_POLICIES     status=BUILD_C430_NEW_DECKS_STATUS
*DECK DECK=BUILD_C431 EXPAND=TRUE
*copyc BUILD_C440
*IF bev$product_level = 'BUILD_C431'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C431_contents
*IFEND
*DECK DECK=BUILD_C431_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C431_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C431_STATUS kind=status
IFEND
 exclude_feature nv09695_fix_2                   status=BUILD_C431_STATUS
*DECK DECK=BUILD_C431_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C440_NEW_DECKS
*IF bev$product_level = 'BUILD_C431_NEW_DECKS'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C431_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C431_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C440 EXPAND=TRUE
*copyc BUILD_C441
*IF bev$product_level = 'BUILD_C440'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C440_contents
*IFEND
*DECK DECK=BUILD_C440_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C440_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C440_STATUS kind=status
IFEND
 exclude_feature nv09809                         status=BUILD_C440_STATUS
 exclude_feature nv0v415                         status=BUILD_C440_STATUS
 exclude_feature nv0v403                         status=BUILD_C440_STATUS
 exclude_feature nv0v403_fix                     status=BUILD_C440_STATUS
 exclude_feature nv08642_fix                     status=BUILD_C440_STATUS
 exclude_feature ntf0118_os                      status=BUILD_C440_STATUS
 exclude_feature nv0v416                         status=BUILD_C440_STATUS
 exclude_feature nv09688                         status=BUILD_C440_STATUS
 exclude_feature nv09858                         status=BUILD_C440_STATUS
 exclude_feature nv09859                         status=BUILD_C440_STATUS
 exclude_feature violet_config_chjanges          status=BUILD_C440_STATUS
 exclude_feature disk_ft_phase3d                 status=BUILD_C440_STATUS
 exclude_feature nv09688_1                       status=BUILD_C440_STATUS
 exclude_feature nv09688_2                       status=BUILD_C440_STATUS
*DECK DECK=BUILD_C440_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C441_NEW_DECKS
*IF bev$product_level = 'BUILD_C440_NEW_DECKS'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C440_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C440_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C440_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C440_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck LGP$INSTALL_ENGINEERING_LOG       status=BUILD_C440_NEW_DECKS_STATUS
 exclude_deck PFC$MOVC_INSUF_SPACE              status=BUILD_C440_NEW_DECKS_STATUS
 exclude_deck PFC$MOVC_NO_SPACE                 status=BUILD_C440_NEW_DECKS_STATUS
*DECK DECK=BUILD_C441 EXPAND=TRUE
*copyc BUILD_C442
*IF bev$product_level = 'BUILD_C441'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C441_contents
*IFEND
*DECK DECK=BUILD_C441_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C441_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C441_STATUS kind=status
IFEND
 exclude_feature nv09782                         status=BUILD_C441_STATUS
 exclude_feature nv09860                         status=BUILD_C441_STATUS
 exclude_feature nv09863                         status=BUILD_C441_STATUS
 exclude_feature tcva354_os                      status=BUILD_C441_STATUS
 exclude_feature das_head_shift                  status=BUILD_C441_STATUS
 exclude_feature disk_ft_phase3e                 status=BUILD_C441_STATUS
 exclude_feature disk_ft_phase3f                 status=BUILD_C441_STATUS
 exclude_feature disk_ft_phase3g                 status=BUILD_C441_STATUS
 exclude_feature nv0v390                         status=BUILD_C441_STATUS
*DECK DECK=BUILD_C441_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C442_NEW_DECKS
*IF bev$product_level = 'BUILD_C441_NEW_DECKS'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C441_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C441_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C441_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C441_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck IOM$DAS_HEAD_SHIFT_TEST           status=BUILD_C441_NEW_DECKS_STATUS
 exclude_deck PFI$STORE_FILE_MEDIA_DESCRIPTOR   status=BUILD_C441_NEW_DECKS_STATUS
*DECK DECK=BUILD_C442 EXPAND=TRUE
*copyc BUILD_C443
*IF bev$product_level = 'BUILD_C442'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C442_contents
*IFEND
*DECK DECK=BUILD_C442_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C442_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C443_NEW_DECKS
*IF bev$product_level = 'BUILD_C442_NEW_DECKS'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C442_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C442_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C443 EXPAND=TRUE
*copyc BUILD_C444
*IF bev$product_level = 'BUILD_C443'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C443_contents
*IFEND
*DECK DECK=BUILD_C443_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C443_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C443_STATUS kind=status
IFEND
 exclude_feature nv07104                         status=BUILD_C443_STATUS
 exclude_feature nv07128_fix                     status=BUILD_C443_STATUS
 exclude_feature nv09068_fix                     status=BUILD_C443_STATUS
 exclude_feature nv09860_1                       status=BUILD_C443_STATUS
 exclude_feature tcva354a_os                     status=BUILD_C443_STATUS
 exclude_feature das_head_shift_fix_1            status=BUILD_C443_STATUS
 exclude_feature delete_hydras                   status=BUILD_C443_STATUS
*DECK DECK=BUILD_C443_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C444_NEW_DECKS
*IF bev$product_level = 'BUILD_C443_NEW_DECKS'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C443_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C443_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C443_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C443_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CLP$F_PROCESS_TASK_OR_JOB         status=BUILD_C443_NEW_DECKS_STATUS
 exclude_deck CLP$F_SET_SUBSTITUTION_MARK       status=BUILD_C443_NEW_DECKS_STATUS
*DECK DECK=BUILD_C444 EXPAND=TRUE
*copyc BUILD_C445
*IF bev$product_level = 'BUILD_C444'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C444_contents
*IFEND
*DECK DECK=BUILD_C444_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C444_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C444_STATUS kind=status
IFEND
 exclude_feature disk_ft_phase3h                 status=BUILD_C444_STATUS
 exclude_feature disk_ft_phase_3i                status=BUILD_C444_STATUS
 exclude_feature disk_ft_phase3j                 status=BUILD_C444_STATUS
 exclude_feature elite_fix_1                     status=BUILD_C444_STATUS
 exclude_feature tcva354b_os                     status=BUILD_C444_STATUS
*DECK DECK=BUILD_C444_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C445_NEW_DECKS
*IF bev$product_level = 'BUILD_C444_NEW_DECKS'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C444_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C444_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C444_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C444_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck DMP$GET_UNIQUE_FMD_VOLUME_LIST    status=BUILD_C444_NEW_DECKS_STATUS
 exclude_deck PFT$UNIQUE_VOLUME_DESC            status=BUILD_C444_NEW_DECKS_STATUS
 exclude_deck PFT$UNIQUE_VOLUME_LIST            status=BUILD_C444_NEW_DECKS_STATUS
*DECK DECK=BUILD_C445 EXPAND=TRUE
*copyc BUILD_C446
*IF bev$product_level = 'BUILD_C445'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C445_contents
*IFEND
*DECK DECK=BUILD_C445_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C445_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C445_STATUS kind=status
IFEND
 exclude_feature head_shift_fix_1                status=BUILD_C445_STATUS
 exclude_feature disk_ft_phase_3i_fix_1          status=BUILD_C445_STATUS
*DECK DECK=BUILD_C445_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C446_NEW_DECKS
*IF bev$product_level = 'BUILD_C445_NEW_DECKS'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C445_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C445_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C446 EXPAND=TRUE
*copyc BUILD_C501
*IF bev$product_level = 'BUILD_C446'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C446_contents
*IFEND
*DECK DECK=BUILD_C446_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C446_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C446_STATUS kind=status
IFEND
 exclude_feature disk_ft_phase3m                 status=BUILD_C446_STATUS
 exclude_feature disk_ft_phase3n                 status=BUILD_C446_STATUS
 exclude_feature disk_ft_phase_3i_fix_2          status=BUILD_C446_STATUS


*DECK DECK=BUILD_C446_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C501_NEW_DECKS
*IF bev$product_level = 'BUILD_C446_NEW_DECKS'
*copyc cycleC4_exceptions
*ELSE
*copyc BUILD_C446_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C446_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C501 EXPAND=TRUE
*copyc BUILD_C505
*IF bev$product_level = 'BUILD_C501'
*copyc BUILD_C446_contents
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C501_contents
*IFEND
*DECK DECK=BUILD_C501_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C501_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C501_STATUS kind=status
IFEND
 exclude_feature nv09640                         status=BUILD_C501_STATUS
 exclude_feature nv09865                         status=BUILD_C501_STATUS
 exclude_feature nv09897                         status=BUILD_C501_STATUS
 exclude_feature nv09886                         status=BUILD_C501_STATUS
 exclude_feature nv09244                         status=BUILD_C501_STATUS
 exclude_feature nv09854                         status=BUILD_C501_STATUS
 exclude_feature nv0v420                         status=BUILD_C501_STATUS
 exclude_feature nv0v413                         status=BUILD_C501_STATUS
 exclude_feature nv08854                         status=BUILD_C501_STATUS
 exclude_feature sc8a354_os                      status=BUILD_C501_STATUS
 exclude_feature sc8a542_os                      status=BUILD_C501_STATUS
*DECK DECK=BUILD_C501_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C505_NEW_DECKS
*IF bev$product_level = 'BUILD_C501_NEW_DECKS'
*copyc BUILD_C446_NEW_DECKS_contents
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C501_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C501_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C501_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C501_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck AVH$REORGANIZE_VALIDATION_FILE    status=BUILD_C501_NEW_DECKS_STATUS
 exclude_deck AVM$COMPRESS_VALIDATION_FILE      status=BUILD_C501_NEW_DECKS_STATUS
 exclude_deck AVP$COMPRESS_VALIDATION_FILE      status=BUILD_C501_NEW_DECKS_STATUS
 exclude_deck AVP$REORGANIZE_VALIDATION_FILE    status=BUILD_C501_NEW_DECKS_STATUS
*DECK DECK=BUILD_C505 EXPAND=TRUE
*copyc BUILD_C506
*IF bev$product_level = 'BUILD_C505'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C505_contents
*IFEND
*DECK DECK=BUILD_C505_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C505_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C505_STATUS kind=status
IFEND
 exclude_feature nv09921                         status=BUILD_C505_STATUS
 exclude_feature nv0v136                         status=BUILD_C505_STATUS
 exclude_feature nv0v116                         status=BUILD_C505_STATUS
 exclude_feature nv0v452                         status=BUILD_C505_STATUS
 exclude_feature nv09879                         status=BUILD_C505_STATUS
 exclude_feature ntfa084                         status=BUILD_C505_STATUS
 exclude_feature sc8a412_os                      status=BUILD_C505_STATUS
 exclude_feature nv09869                         status=BUILD_C505_STATUS
*DECK DECK=BUILD_C505_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C506_NEW_DECKS
*IF bev$product_level = 'BUILD_C505_NEW_DECKS'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C505_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C505_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C505_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C505_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CLP$CLEANUP_DYNAMIC_LOAD          status=BUILD_C505_NEW_DECKS_STATUS
*DECK DECK=BUILD_C506 EXPAND=TRUE
*copyc BUILD_C511
*IF bev$product_level = 'BUILD_C506'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C506_contents
*IFEND
*DECK DECK=BUILD_C506_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C506_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C506_STATUS kind=status
IFEND
*DECK DECK=BUILD_C506_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C511_NEW_DECKS
*IF bev$product_level = 'BUILD_C506_NEW_DECKS'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C506_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C506_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C506_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C506_NEW_DECKS_STATUS kind=status
IFEND
*DECK DECK=BUILD_C511 EXPAND=TRUE
*copyc BUILD_C521
*IF bev$product_level = 'BUILD_C511'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C511_contents
*IFEND
*DECK DECK=BUILD_C511_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C511_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C511_STATUS kind=status
IFEND
 exclude_feature swap_q_trace                    status=BUILD_C511_STATUS
 exclude_feature nv09928                         status=BUILD_C511_STATUS
 exclude_feature nv0t008                         status=BUILD_C511_STATUS
 exclude_feature nv0v454                         status=BUILD_C511_STATUS
 exclude_feature nv0v463                         status=BUILD_C511_STATUS
 exclude_feature nv0v461                         status=BUILD_C511_STATUS
 exclude_feature disk_ft_getoi_cond_handlers     status=BUILD_C511_STATUS
 exclude_feature ssd_battery_status              status=BUILD_C511_STATUS
 exclude_feature mve_deliver_filter_os           status=BUILD_C511_STATUS
*DECK DECK=BUILD_C511_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C521_NEW_DECKS
*IF bev$product_level = 'BUILD_C511_NEW_DECKS'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C511_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C511_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C511_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C511_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck RAM$ACTIVATE_MAIL_DELIVERY_AGEN   status=BUILD_C511_NEW_DECKS_STATUS
 exclude_deck RAM$DEACTIVATE_MAIL_DELIVERY_AG   status=BUILD_C511_NEW_DECKS_STATUS
*DECK DECK=BUILD_C521 EXPAND=TRUE
*copyc BUILD_C522
*IF bev$product_level = 'BUILD_C521'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C521_contents
*IFEND
*DECK DECK=BUILD_C521_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C521_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C521_STATUS kind=status
IFEND
 exclude_feature nv09924                         status=BUILD_C521_STATUS
 exclude_feature nv09939                         status=BUILD_C521_STATUS
 exclude_feature nv09947                         status=BUILD_C521_STATUS
 exclude_feature nv0v466                         status=BUILD_C521_STATUS
 exclude_feature nv0v468                         status=BUILD_C521_STATUS
 exclude_feature nv0v469                         status=BUILD_C521_STATUS
 exclude_feature nv0v472                         status=BUILD_C521_STATUS
 exclude_feature tcv0306                         status=BUILD_C521_STATUS
*DECK DECK=BUILD_C521_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C522_NEW_DECKS
*IF bev$product_level = 'BUILD_C521_NEW_DECKS'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C521_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C521_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C521_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C521_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CSM$TEKX_40_80                    status=BUILD_C521_NEW_DECKS_STATUS
*DECK DECK=BUILD_C522 EXPAND=TRUE
*copyc BUILD_C531
*IF bev$product_level = 'BUILD_C522'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C522_contents
*IFEND
*DECK DECK=BUILD_C522_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C522_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C531_NEW_DECKS
*IF bev$product_level = 'BUILD_C522_NEW_DECKS'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C522_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C522_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C531 EXPAND=TRUE
*copyc BUILD_C532
*IF bev$product_level = 'BUILD_C531'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C531_contents
*IFEND
*DECK DECK=BUILD_C531_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C531_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C531_STATUS kind=status
IFEND
 exclude_feature bcu_helper_l803ab               status=BUILD_C531_STATUS
 exclude_feature nv09314                         status=BUILD_C531_STATUS
 exclude_feature nv09732                         status=BUILD_C531_STATUS
 exclude_feature nv09889                         status=BUILD_C531_STATUS
 exclude_feature nv09903                         status=BUILD_C531_STATUS
 exclude_feature nv09910                         status=BUILD_C531_STATUS
 exclude_feature nv09949                         status=BUILD_C531_STATUS
 exclude_feature nv09958                         status=BUILD_C531_STATUS
 exclude_feature nv09964                         status=BUILD_C531_STATUS
 exclude_feature nv0v473                         status=BUILD_C531_STATUS
 exclude_feature nv0v473_1                       status=BUILD_C531_STATUS
 exclude_feature nv0v474                         status=BUILD_C531_STATUS
 exclude_feature nv0v475                         status=BUILD_C531_STATUS
 exclude_feature nv0v478                         status=BUILD_C531_STATUS
 exclude_feature nv0v479                         status=BUILD_C531_STATUS
*DECK DECK=BUILD_C531_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C532_NEW_DECKS
*IF bev$product_level = 'BUILD_C531_NEW_DECKS'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C531_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C531_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C531_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C531_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CMV$ENABLE_HEAD_SHIFT_MESSAGE     status=BUILD_C531_NEW_DECKS_STATUS
 exclude_deck FDC$HIDDEN_EDITING_CAPABILITY     status=BUILD_C531_NEW_DECKS_STATUS
 exclude_deck NLH$SK_CLEAR_JOB_SOCKET_LOCK      status=BUILD_C531_NEW_DECKS_STATUS
 exclude_deck NLP$SK_CLEAR_JOB_SOCKET_LOCK      status=BUILD_C531_NEW_DECKS_STATUS
*DECK DECK=BUILD_C532 EXPAND=TRUE
*copyc BUILD_C533
*IF bev$product_level = 'BUILD_C532'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C532_contents
*IFEND
*DECK DECK=BUILD_C532_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C532_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C532_STATUS kind=status
IFEND
 exclude_feature nv09969                         status=BUILD_C532_STATUS
 exclude_feature nv09971                         status=BUILD_C532_STATUS
*DECK DECK=BUILD_C532_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C533_NEW_DECKS
*IF bev$product_level = 'BUILD_C532_NEW_DECKS'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C532_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C532_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C533 EXPAND=TRUE
*copyc BUILD_C534
*IF bev$product_level = 'BUILD_C533'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C533_contents
*IFEND
*DECK DECK=BUILD_C533_CONTENTS EXPAND=TRUE
IF $variable(BUILD_C533_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C533_STATUS kind=status
IFEND
 exclude_feature nv09977                         status=BUILD_C533_STATUS
*DECK DECK=BUILD_C533_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C534_NEW_DECKS
*IF bev$product_level = 'BUILD_C533_NEW_DECKS'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C533_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C533_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C534 EXPAND=TRUE
*copyc BUILD_C601
*IF bev$product_level = 'BUILD_C534'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C534_contents
*IFEND
*DECK DECK=BUILD_C534_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C534_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C601_NEW_DECKS
*IF bev$product_level = 'BUILD_C534_NEW_DECKS'
*copyc cycleC5_exceptions
*ELSE
*copyc BUILD_C534_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C534_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C601 EXPAND=TRUE
*copyc BUILD_C605
*IF bev$product_level = 'BUILD_C601'
*copyc cycleC6_exceptions
IF $variable(BUILD_C601_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C601_STATUS kind=status
IFEND
 include_feature nv09953                         status=BUILD_C601_STATUS
 include_feature nv10015                         status=BUILD_C601_STATUS
 include_feature nv09945                         status=BUILD_C601_STATUS
 include_feature nv10024                         status=BUILD_C601_STATUS
 include_feature nv09765                         status=BUILD_C601_STATUS
*ELSE
*copyc BUILD_C601_contents
*IFEND
*DECK DECK=BUILD_C601_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C601_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C605_NEW_DECKS
*IF bev$product_level = 'BUILD_C601_NEW_DECKS'
*copyc cycleC6_exceptions
*ELSE
*copyc BUILD_C601_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C601_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C605 EXPAND=TRUE
*copyc BUILD_C610
*IF bev$product_level = 'BUILD_C605'
*copyc cycleC6_exceptions
IF $variable(BUILD_C601_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C601_STATUS kind=status
IFEND
 include_feature nv09953                         status=BUILD_C601_STATUS
 include_feature nv10015                         status=BUILD_C601_STATUS
 include_feature nv09945                         status=BUILD_C601_STATUS
 include_feature nv10024                         status=BUILD_C601_STATUS
 include_feature nv09765                         status=BUILD_C601_STATUS
IF $variable(BUILD_C605_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C605_STATUS kind=status
IFEND
 include_feature bcu_helper_l803ac               status=BUILD_C605_STATUS
 include_feature nfs0139_os                      status=BUILD_C605_STATUS
 include_feature nv09674                         status=BUILD_C605_STATUS
 include_feature nv09931                         status=BUILD_C605_STATUS
 include_feature nv0v441                         status=BUILD_C605_STATUS
 include_feature nv0v499                         status=BUILD_C605_STATUS
 include_feature nv10035                         status=BUILD_C605_STATUS
 include_feature nv10040                         status=BUILD_C605_STATUS
 include_feature nv10048                         status=BUILD_C605_STATUS
*ELSE
*copyc BUILD_C605_contents
*IFEND
*DECK DECK=BUILD_C605_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C605_NEW_DECKS EXPAND=TRUE
*copyc BUILD_C610_NEW_DECKS
*IF bev$product_level = 'BUILD_C605_NEW_DECKS'
*copyc cycleC6_exceptions
IF $variable(BUILD_C605_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C605_NEW_DECKS_STATUS kind=status
IFEND
 include_deck PFP$CATALOG_ACCESS_RETRY_WAIT     status=BUILD_C605_NEW_DECKS_STATUS
 include_deck PFV$DEBUG_CATALOG_ACCESS          status=BUILD_C605_NEW_DECKS_STATUS
*ELSE
*copyc BUILD_C605_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C605_NEW_DECKS_CONTENTS EXPAND=TRUE







*DECK DECK=BUILD_C610 EXPAND=TRUE
*copyc BUILD_D101
*IF bev$product_level = 'BUILD_C610'
*copyc cycleC6_exceptions
IF $variable(BUILD_C601_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C601_STATUS kind=status
IFEND
 include_feature nv09953                         status=BUILD_C601_STATUS
 include_feature nv10015                         status=BUILD_C601_STATUS
 include_feature nv09945                         status=BUILD_C601_STATUS
 include_feature nv10024                         status=BUILD_C601_STATUS
 include_feature nv09765                         status=BUILD_C601_STATUS
IF $variable(BUILD_C605_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C605_STATUS kind=status
IFEND
 include_feature bcu_helper_l803ac               status=BUILD_C605_STATUS
 include_feature nfs0139_os                      status=BUILD_C605_STATUS
 include_feature nv09674                         status=BUILD_C605_STATUS
 include_feature nv09931                         status=BUILD_C605_STATUS
 include_feature nv0v441                         status=BUILD_C605_STATUS
 include_feature nv0v499                         status=BUILD_C605_STATUS
 include_feature nv10035                         status=BUILD_C605_STATUS
 include_feature nv10040                         status=BUILD_C605_STATUS
 include_feature nv10048                         status=BUILD_C605_STATUS
IF $variable(BUILD_C610_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C610_STATUS kind=status
IFEND
 include_feature nv10051                         status=BUILD_C610_STATUS
 include_feature nv10052                         status=BUILD_C610_STATUS
 include_feature nv10042                         status=BUILD_C610_STATUS
 include_feature nv10080                         status=BUILD_C610_STATUS
 include_feature nv0v509                         status=BUILD_C610_STATUS
 include_feature nv10042_fix                     status=BUILD_C610_STATUS
*ELSE
*copyc BUILD_C610_contents
*IFEND
*DECK DECK=BUILD_C610_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_C610_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D101_NEW_DECKS
*IF bev$product_level = 'BUILD_C610_NEW_DECKS'
*copyc cycleC6_exceptions
IF $variable(BUILD_C605_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C605_NEW_DECKS_STATUS kind=status
IFEND
 include_deck PFP$CATALOG_ACCESS_RETRY_WAIT     status=BUILD_C605_NEW_DECKS_STATUS
 include_deck PFV$DEBUG_CATALOG_ACCESS          status=BUILD_C605_NEW_DECKS_STATUS
IF $variable(BUILD_C610_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C610_NEW_DECKS_STATUS kind=status
IFEND
 include_deck PUV$INCLUDE_EXCEPTIONS            status=BUILD_C610_NEW_DECKS_STATUS
*ELSE
*copyc BUILD_C610_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_C610_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D101 EXPAND=TRUE
*copyc BUILD_D105
*IF bev$product_level = 'BUILD_D101'
*copyc BUILD_C610_contents
*copyc BUILD_C605_contents
*copyc BUILD_C601_contents
*copyc BUILD_C534_contents
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D101_contents
*IFEND
*DECK DECK=BUILD_D101_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D101_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D101_STATUS kind=status
IFEND
 exclude_feature deactivate_network              status=BUILD_D101_STATUS
 exclude_feature fix_job_templates               status=BUILD_D101_STATUS
 exclude_feature nv09452                         status=BUILD_D101_STATUS
 exclude_feature nv09915                         status=BUILD_D101_STATUS
 exclude_feature nv09936                         status=BUILD_D101_STATUS
 exclude_feature nv0q515                         status=BUILD_D101_STATUS
 exclude_feature nv0t006                         status=BUILD_D101_STATUS
 exclude_feature nv0t007                         status=BUILD_D101_STATUS
 exclude_feature nv0t009                         status=BUILD_D101_STATUS
 exclude_feature nv0t979                         status=BUILD_D101_STATUS
*DECK DECK=BUILD_D101_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D105_NEW_DECKS
*IF bev$product_level = 'BUILD_D101_NEW_DECKS'
*copyc BUILD_C610_NEW_DECKS_contents
*copyc BUILD_C605_NEW_DECKS_contents
*copyc BUILD_C601_NEW_DECKS_contents
*copyc BUILD_C534_NEW_DECKS_contents
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D101_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D101_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D101_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D101_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck NAP$IDLE_NETWORK_APPLICATIONS     status=BUILD_D101_NEW_DECKS_STATUS
 exclude_deck NAP$RECORD_COMPLETED_OUTPUT       status=BUILD_D101_NEW_DECKS_STATUS
 exclude_deck NAV$COMPLETED_OUTPUT_TASKID       status=BUILD_D101_NEW_DECKS_STATUS
 exclude_deck RAM$NETWORK_DEACTIVATION_EPILOG   status=BUILD_D101_NEW_DECKS_STATUS
 exclude_deck RAM$NETWORK_DEACTIVATION_PROLOG   status=BUILD_D101_NEW_DECKS_STATUS
 exclude_deck RAP$DEACTIVATE_NAMVE              status=BUILD_D101_NEW_DECKS_STATUS
 exclude_deck RAP$DEACTIVATE_NETWORK            status=BUILD_D101_NEW_DECKS_STATUS
*DECK DECK=BUILD_D105 EXPAND=TRUE
*copyc BUILD_D111
*IF bev$product_level = 'BUILD_D105'
*copyc BUILD_C610_contents
*copyc BUILD_C605_contents
*copyc BUILD_C601_contents
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D105_contents
*IFEND
*DECK DECK=BUILD_D105_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D105_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D105_STATUS kind=status
IFEND
 exclude_feature nv09765                         status=BUILD_D105_STATUS
 exclude_feature nv09935                         status=BUILD_D105_STATUS
 exclude_feature nv09953                         status=BUILD_D105_STATUS
 exclude_feature nv09957                         status=BUILD_D105_STATUS
 exclude_feature nv0j552                         status=BUILD_D105_STATUS
 exclude_feature nv0n071                         status=BUILD_D105_STATUS
 exclude_feature nv0n072                         status=BUILD_D105_STATUS
 exclude_feature nv0p658                         status=BUILD_D105_STATUS
 exclude_feature nv0s128                         status=BUILD_D105_STATUS
 exclude_feature nv0s162                         status=BUILD_D105_STATUS
 exclude_feature nv0s580                         status=BUILD_D105_STATUS
 exclude_feature nv0t264                         status=BUILD_D105_STATUS
 exclude_feature nv0t292                         status=BUILD_D105_STATUS
 exclude_feature nv0u750                         status=BUILD_D105_STATUS
 exclude_feature nv0u897                         status=BUILD_D105_STATUS
 exclude_feature nv0v483                         status=BUILD_D105_STATUS
 exclude_feature nv0v489                         status=BUILD_D105_STATUS
 exclude_feature nv0v490                         status=BUILD_D105_STATUS
 exclude_feature nv10014                         status=BUILD_D105_STATUS
 exclude_feature nv10015                         status=BUILD_D105_STATUS
*DECK DECK=BUILD_D105_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D111_NEW_DECKS
*IF bev$product_level = 'BUILD_D105_NEW_DECKS'
*copyc BUILD_C610_NEW_DECKS_contents
*copyc BUILD_C605_NEW_DECKS_contents
*copyc BUILD_C601_NEW_DECKS_contents
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D105_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D105_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D111 EXPAND=TRUE
*copyc BUILD_D121
*IF bev$product_level = 'BUILD_D111'
*copyc BUILD_C610_contents
*copyc BUILD_C605_contents
*copyc BUILD_C601_contents
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D111_contents
*IFEND
*DECK DECK=BUILD_D111_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D111_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D111_STATUS kind=status
IFEND
 exclude_feature nv09945                         status=BUILD_D111_STATUS
 exclude_feature nv0v499                         status=BUILD_D111_STATUS
 exclude_feature nv0v501                         status=BUILD_D111_STATUS
 exclude_feature nv10024                         status=BUILD_D111_STATUS
 exclude_feature nv0v501_1                       status=BUILD_D111_STATUS
*DECK DECK=BUILD_D111_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D121_NEW_DECKS
*IF bev$product_level = 'BUILD_D111_NEW_DECKS'
*copyc BUILD_C610_NEW_DECKS_contents
*copyc BUILD_C605_NEW_DECKS_contents
*copyc BUILD_C601_NEW_DECKS_contents
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D111_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D111_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D121 EXPAND=TRUE
*copyc BUILD_D122
*IF bev$product_level = 'BUILD_D121'
*copyc BUILD_C610_contents
*copyc BUILD_C605_contents
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D121_contents
*IFEND
*DECK DECK=BUILD_D121_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D121_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D121_STATUS kind=status
IFEND
 exclude_feature nv09931                         status=BUILD_D121_STATUS
 exclude_feature nv0v441                         status=BUILD_D121_STATUS
 exclude_feature nv10048                         status=BUILD_D121_STATUS
 exclude_feature nv09674                         status=BUILD_D121_STATUS
 exclude_feature nv09824                         status=BUILD_D121_STATUS
 exclude_feature nv10026_1                       status=BUILD_D121_STATUS
 exclude_feature nv0v116                         status=BUILD_D121_STATUS
 exclude_feature nv0v116_undo                    status=BUILD_D121_STATUS
 exclude_feature nv0u005                         status=BUILD_D121_STATUS
 exclude_feature nv10012                         status=BUILD_D121_STATUS
 exclude_feature nv0v493                         status=BUILD_D121_STATUS
 exclude_feature nv1a002                         status=BUILD_D121_STATUS
 exclude_feature nv10022                         status=BUILD_D121_STATUS
 exclude_feature nv0v481                         status=BUILD_D121_STATUS
 exclude_feature generalize_copyright_os         status=BUILD_D121_STATUS
*DECK DECK=BUILD_D121_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D122_NEW_DECKS
*IF bev$product_level = 'BUILD_D121_NEW_DECKS'
*copyc BUILD_C610_NEW_DECKS_contents
*copyc BUILD_C605_NEW_DECKS_contents
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D121_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D121_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D121_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D121_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CLP$CLEANUP_DYNAMIC_LOAD          status=BUILD_D121_NEW_DECKS_STATUS
 exclude_deck CLP$RESET_INPUT_STATE             status=BUILD_D121_NEW_DECKS_STATUS
 exclude_deck PFP$CATALOG_ACCESS_RETRY_WAIT     status=BUILD_D121_NEW_DECKS_STATUS
 exclude_deck PFV$DEBUG_CATALOG_ACCESS          status=BUILD_D121_NEW_DECKS_STATUS
*DECK DECK=BUILD_D122 EXPAND=TRUE
*copyc BUILD_D125
*IF bev$product_level = 'BUILD_D122'
*copyc BUILD_C610_contents
*copyc BUILD_C605_contents
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D122_contents
*IFEND
*DECK DECK=BUILD_D122_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D122_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D125_NEW_DECKS
*IF bev$product_level = 'BUILD_D122_NEW_DECKS'
*copyc BUILD_C610_NEW_DECKS_contents
*copyc BUILD_C605_NEW_DECKS_contents
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D122_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D122_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D125 EXPAND=TRUE
*copyc BUILD_D126
*IF bev$product_level = 'BUILD_D125'
*copyc BUILD_C610_contents
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D125_contents
*IFEND
*DECK DECK=BUILD_D125_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D125_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D125_STATUS kind=status
IFEND
 exclude_feature bcu_helper_l803ac               status=BUILD_D125_STATUS
 exclude_feature nv06810                         status=BUILD_D125_STATUS
 exclude_feature nv09339                         status=BUILD_D125_STATUS
 exclude_feature nv0v504                         status=BUILD_D125_STATUS
 exclude_feature nv10046                         status=BUILD_D125_STATUS
 exclude_feature nv09959                         status=BUILD_D125_STATUS
 exclude_feature nv09959_1                       status=BUILD_D125_STATUS
 exclude_feature nv0v438                         status=BUILD_D125_STATUS
 exclude_feature nv10044                         status=BUILD_D125_STATUS
 exclude_feature nv0v506                         status=BUILD_D125_STATUS
 exclude_feature xwna014                         status=BUILD_D125_STATUS
 exclude_feature nv10035                         status=BUILD_D125_STATUS
 exclude_feature xtfa001                         status=BUILD_D125_STATUS
 exclude_feature xtfa001b                        status=BUILD_D125_STATUS
 exclude_feature xtfa001a                        status=BUILD_D125_STATUS
 exclude_feature archive_cmd_and_ptable_fab_a    status=BUILD_D125_STATUS
 exclude_feature nv10009                         status=BUILD_D125_STATUS
 exclude_feature nfs0139_os                      status=BUILD_D125_STATUS
 exclude_feature nv10040                         status=BUILD_D125_STATUS
 exclude_feature disk_ft_phase3o                 status=BUILD_D125_STATUS
 exclude_feature disk_ft_phase3o_f1              status=BUILD_D125_STATUS
*DECK DECK=BUILD_D125_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D126_NEW_DECKS
*IF bev$product_level = 'BUILD_D125_NEW_DECKS'
*copyc BUILD_C610_NEW_DECKS_contents
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D125_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D125_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D125_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D125_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CLP$GET_SYSTEM_MESSAGE_MOD_PTR    status=BUILD_D125_NEW_DECKS_STATUS
 exclude_deck OSI$FIND_APPLICABLE_POLICY        status=BUILD_D125_NEW_DECKS_STATUS
 exclude_deck OSM$FILE_ACCESS_CONDITIONS        status=BUILD_D125_NEW_DECKS_STATUS
 exclude_deck OSP$FILE_ACCESS_CONDITION         status=BUILD_D125_NEW_DECKS_STATUS
 exclude_deck OSP$FIND_ACCESS_CONDITION_ENTRY   status=BUILD_D125_NEW_DECKS_STATUS
 exclude_deck OSP$GET_ACCESS_CONDITION_ENTRY    status=BUILD_D125_NEW_DECKS_STATUS
 exclude_deck OSP$GET_CONDITION_STATUS          status=BUILD_D125_NEW_DECKS_STATUS
 exclude_deck OSP$LOG_SYSTEM_STATUS_MESSAGE     status=BUILD_D125_NEW_DECKS_STATUS
 exclude_deck OSP$R1_GET_APPLICABLE_POLICY      status=BUILD_D125_NEW_DECKS_STATUS
 exclude_deck OSP$R1_LOCK_POLICIES              status=BUILD_D125_NEW_DECKS_STATUS
 exclude_deck OSP$R1_UNLOCK_POLICIES            status=BUILD_D125_NEW_DECKS_STATUS
 exclude_deck OSP$R3_GET_APPLICABLE_POLICY      status=BUILD_D125_NEW_DECKS_STATUS
 exclude_deck OST$CONDITION_INFORMATION         status=BUILD_D125_NEW_DECKS_STATUS
 exclude_deck OST$ECP_EXCEPTION_CONTEXT         status=BUILD_D125_NEW_DECKS_STATUS
 exclude_deck OST$ECP_FILE_IDENTIFICATION       status=BUILD_D125_NEW_DECKS_STATUS
 exclude_deck OST$ECP_FILE_IDENTIFIER           status=BUILD_D125_NEW_DECKS_STATUS
 exclude_deck OSV$INITIAL_EXCEPTION_CONTEXT     status=BUILD_D125_NEW_DECKS_STATUS
 exclude_deck OSV$INSTALLED_POLICIES            status=BUILD_D125_NEW_DECKS_STATUS
*DECK DECK=BUILD_D126 EXPAND=TRUE
*copyc BUILD_D131
*IF bev$product_level = 'BUILD_D126'
*copyc BUILD_C610_contents
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D126_contents
*IFEND
*DECK DECK=BUILD_D126_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D126_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D126_STATUS kind=status
IFEND
 exclude_feature disk_ft_phase3o_fix             status=BUILD_D126_STATUS
 exclude_feature nv0v521                         status=BUILD_D126_STATUS
 exclude_feature nv0v509                         status=BUILD_D126_STATUS
*DECK DECK=BUILD_D126_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D131_NEW_DECKS
*IF bev$product_level = 'BUILD_D126_NEW_DECKS'
*copyc BUILD_C610_NEW_DECKS_contents
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D126_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D126_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D131 EXPAND=TRUE
*copyc BUILD_D135
*IF bev$product_level = 'BUILD_D131'
*copyc BUILD_C610_contents
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D131_contents
*IFEND
*DECK DECK=BUILD_D131_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D131_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D131_STATUS kind=status
IFEND
 exclude_feature nv10042_fix                     status=BUILD_D131_STATUS
 exclude_feature nv09035                         status=BUILD_D131_STATUS
 exclude_feature nv0s203                         status=BUILD_D131_STATUS
 exclude_feature nv09641                         status=BUILD_D131_STATUS
 exclude_feature nv10051                         status=BUILD_D131_STATUS
 exclude_feature nv10080                         status=BUILD_D131_STATUS
 exclude_feature nv10052                         status=BUILD_D131_STATUS
 exclude_feature nv10042                         status=BUILD_D131_STATUS
 exclude_feature nv0v512                         status=BUILD_D131_STATUS
 exclude_feature disk_ft_phase3o_f2              status=BUILD_D131_STATUS
 exclude_feature nvtb099                         status=BUILD_D131_STATUS
 exclude_feature nv09993                         status=BUILD_D131_STATUS
 exclude_feature nv0v517                         status=BUILD_D131_STATUS
 exclude_feature archive_cmd_and_ptable_jcl_g    status=BUILD_D131_STATUS
*DECK DECK=BUILD_D131_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D135_NEW_DECKS
*IF bev$product_level = 'BUILD_D131_NEW_DECKS'
*copyc BUILD_C610_NEW_DECKS_contents
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D131_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D131_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D131_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D131_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck PUV$INCLUDE_EXCEPTIONS            status=BUILD_D131_NEW_DECKS_STATUS
 exclude_deck RAM$$FILE_LIST                    status=BUILD_D131_NEW_DECKS_STATUS
 exclude_deck RAM$DISFP$US_ENGLISH              status=BUILD_D131_NEW_DECKS_STATUS
 exclude_deck RAM$DISPLAY_FILE_PERMITS          status=BUILD_D131_NEW_DECKS_STATUS
*DECK DECK=BUILD_D135 EXPAND=TRUE
*copyc BUILD_D137
*IF bev$product_level = 'BUILD_D135'
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D135_contents
*IFEND
*DECK DECK=BUILD_D135_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D135_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D135_STATUS kind=status
IFEND
 exclude_feature disk_ft_phase3o_fix1            status=BUILD_D135_STATUS
 exclude_feature disk_ft_phase3o_fix2            status=BUILD_D135_STATUS
 exclude_feature improve_operator_msg_for_repdtc status=BUILD_D135_STATUS
 exclude_feature nv10011                         status=BUILD_D135_STATUS
 exclude_feature improve_operator_msg_for_fs     status=BUILD_D135_STATUS
 exclude_feature disk_ft_phase3o_fix3            status=BUILD_D135_STATUS
 exclude_feature nv0n072_fix                     status=BUILD_D135_STATUS
*DECK DECK=BUILD_D135_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D137_NEW_DECKS
*IF bev$product_level = 'BUILD_D135_NEW_DECKS'
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D135_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D135_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D137 EXPAND=TRUE
*copyc BUILD_D141
*IF bev$product_level = 'BUILD_D137'
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D137_contents
*IFEND
*DECK DECK=BUILD_D137_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D137_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D141_NEW_DECKS
*IF bev$product_level = 'BUILD_D137_NEW_DECKS'
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D137_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D137_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D141 EXPAND=TRUE
*copyc BUILD_D142
*IF bev$product_level = 'BUILD_D141'
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D141_contents
*IFEND
*DECK DECK=BUILD_D141_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D141_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D141_STATUS kind=status
IFEND
 exclude_feature disk_ft_phase3o_fix4            status=BUILD_D141_STATUS
 exclude_feature disk_ft_phase3o_fix5            status=BUILD_D141_STATUS
 exclude_feature nv0v509_1                       status=BUILD_D141_STATUS
 exclude_feature nv10107                         status=BUILD_D141_STATUS
 exclude_feature nv10060                         status=BUILD_D141_STATUS
 exclude_feature nv10053                         status=BUILD_D141_STATUS
 exclude_feature update_for_dissa_all            status=BUILD_D141_STATUS
 exclude_feature update_actjt                    status=BUILD_D141_STATUS
 exclude_feature xwn0011_os                      status=BUILD_D141_STATUS
*DECK DECK=BUILD_D141_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D142_NEW_DECKS
*IF bev$product_level = 'BUILD_D141_NEW_DECKS'
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D141_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D141_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D142 EXPAND=TRUE
*copyc BUILD_D143
*IF bev$product_level = 'BUILD_D142'
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D142_contents
*IFEND
*DECK DECK=BUILD_D142_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D142_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D142_STATUS kind=status
IFEND
 exclude_feature nv0v531                         status=BUILD_D142_STATUS
 exclude_feature nv0v532                         status=BUILD_D142_STATUS
 exclude_feature disk_ft_phase3o_fix6            status=BUILD_D142_STATUS
 exclude_feature disk_ft_phase3o_fix7            status=BUILD_D142_STATUS
*DECK DECK=BUILD_D142_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D143_NEW_DECKS
*IF bev$product_level = 'BUILD_D142_NEW_DECKS'
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D142_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D142_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D143 EXPAND=TRUE
*copyc BUILD_D145
*IF bev$product_level = 'BUILD_D143'
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D143_contents
*IFEND
*DECK DECK=BUILD_D143_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D143_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D143_STATUS kind=status
IFEND
 exclude_feature dlh_feature_fix_1               status=BUILD_D143_STATUS
 exclude_feature nv09864                         status=BUILD_D143_STATUS
*DECK DECK=BUILD_D143_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D145_NEW_DECKS
*IF bev$product_level = 'BUILD_D143_NEW_DECKS'
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D143_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D143_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D145 EXPAND=TRUE
*copyc BUILD_D146
*IF bev$product_level = 'BUILD_D145'
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D145_contents
*IFEND
*DECK DECK=BUILD_D145_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D145_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D146_NEW_DECKS
*IF bev$product_level = 'BUILD_D145_NEW_DECKS'
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D145_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D145_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D146 EXPAND=TRUE
*copyc BUILD_D147
*IF bev$product_level = 'BUILD_D146'
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D146_contents
*IFEND
*DECK DECK=BUILD_D146_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D146_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D146_STATUS kind=status
IFEND
*DECK DECK=BUILD_D146_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D147_NEW_DECKS
*IF bev$product_level = 'BUILD_D146_NEW_DECKS'
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D146_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D146_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D147 EXPAND=TRUE
*copyc BUILD_D201
*IF bev$product_level = 'BUILD_D147'
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D147_contents
*IFEND
*DECK DECK=BUILD_D147_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D147_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D147_STATUS kind=status
IFEND
 exclude_feature disk_ft_phase3o_fix8            status=BUILD_D147_STATUS
*DECK DECK=BUILD_D147_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D201_NEW_DECKS
*IF bev$product_level = 'BUILD_D147_NEW_DECKS'
*copyc cycleD1_exceptions
*ELSE
*copyc BUILD_D147_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D147_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D201 EXPAND=TRUE
*copyc BUILD_D205
*IF bev$product_level = 'BUILD_D201'
*copyc cycleD2_exceptions
*ELSE
*copyc BUILD_D201_contents
*IFEND
*DECK DECK=BUILD_D201_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D201_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D201_STATUS kind=status
IFEND
 exclude_feature delete_rat$product_types        status=BUILD_D201_STATUS
 exclude_feature nv09375                         status=BUILD_D201_STATUS
 exclude_feature nv09869_fix                     status=BUILD_D201_STATUS
 exclude_feature nv09975                         status=BUILD_D201_STATUS
 exclude_feature nv09982                         status=BUILD_D201_STATUS
 exclude_feature nv0t368                         status=BUILD_D201_STATUS
 exclude_feature nv0v511                         status=BUILD_D201_STATUS
 exclude_feature nv0v537                         status=BUILD_D201_STATUS
 exclude_feature nv0v539                         status=BUILD_D201_STATUS
 exclude_feature nv0v552                         status=BUILD_D201_STATUS
 exclude_feature nv10018                         status=BUILD_D201_STATUS
 exclude_feature nv10021                         status=BUILD_D201_STATUS
 exclude_feature nv10037                         status=BUILD_D201_STATUS
 exclude_feature nv10063                         status=BUILD_D201_STATUS
 exclude_feature nv10088                         status=BUILD_D201_STATUS
 exclude_feature nv10091                         status=BUILD_D201_STATUS
 exclude_feature nv10098                         status=BUILD_D201_STATUS
 exclude_feature nv10114                         status=BUILD_D201_STATUS
 exclude_feature nv10117                         status=BUILD_D201_STATUS
 exclude_feature nv10125                         status=BUILD_D201_STATUS
 exclude_feature nv10131                         status=BUILD_D201_STATUS
 exclude_feature nv10132                         status=BUILD_D201_STATUS
 exclude_feature nv1a006                         status=BUILD_D201_STATUS
 exclude_feature xwn0012                         status=BUILD_D201_STATUS
 exclude_feature ef40011                         status=BUILD_D201_STATUS
 exclude_feature ftm0029                         status=BUILD_D201_STATUS
 exclude_feature nv0v511a                        status=BUILD_D201_STATUS
*DECK DECK=BUILD_D201_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D205_NEW_DECKS
*IF bev$product_level = 'BUILD_D201_NEW_DECKS'
*copyc cycleD2_exceptions
*ELSE
*copyc BUILD_D201_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D201_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D201_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D201_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CSM$NCDX_PL_24                    status=BUILD_D201_NEW_DECKS_STATUS
 exclude_deck NLH$CONNECTION_QUEUED             status=BUILD_D201_NEW_DECKS_STATUS
 exclude_deck NLP$CONNECTION_QUEUED             status=BUILD_D201_NEW_DECKS_STATUS
*DECK DECK=BUILD_D205 EXPAND=TRUE
*copyc BUILD_D211
*IF bev$product_level = 'BUILD_D205'
*copyc cycleD2_exceptions
*ELSE
*copyc BUILD_D205_contents
*IFEND
*DECK DECK=BUILD_D205_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D205_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D205_STATUS kind=status
IFEND
 exclude_feature nv0v534                         status=BUILD_D205_STATUS
 exclude_feature nv0v547                         status=BUILD_D205_STATUS
 exclude_feature nv10151                         status=BUILD_D205_STATUS
 exclude_feature nv09838                         status=BUILD_D205_STATUS
 exclude_feature nv0v555                         status=BUILD_D205_STATUS
 exclude_feature nv10065                         status=BUILD_D205_STATUS
 exclude_feature nv10116_trap                    status=BUILD_D205_STATUS
*DECK DECK=BUILD_D205_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D211_NEW_DECKS
*IF bev$product_level = 'BUILD_D205_NEW_DECKS'
*copyc cycleD2_exceptions
*ELSE
*copyc BUILD_D205_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D205_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D205_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D205_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck IFM$GET_TELNET_CONNECTION_LIMIT   status=BUILD_D205_NEW_DECKS_STATUS
 exclude_deck IFP$GET_TELNET_CONNECTION_LIMIT   status=BUILD_D205_NEW_DECKS_STATUS
 exclude_deck IFV$TELNET_CONNECTION_LIMIT       status=BUILD_D205_NEW_DECKS_STATUS
*DECK DECK=BUILD_D211 EXPAND=TRUE
*copyc BUILD_D221
*IF bev$product_level = 'BUILD_D211'
*copyc cycleD2_exceptions
*ELSE
*copyc BUILD_D211_contents
*IFEND
*DECK DECK=BUILD_D211_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D211_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D211_STATUS kind=status
IFEND
 exclude_feature nv10164                         status=BUILD_D211_STATUS
 exclude_feature nv10171                         status=BUILD_D211_STATUS
 exclude_feature disk_ft_phase3o_fix10           status=BUILD_D211_STATUS
 exclude_feature nv0v564                         status=BUILD_D211_STATUS
 exclude_feature nv09374                         status=BUILD_D211_STATUS
 exclude_feature bcu_helper_l826aa               status=BUILD_D211_STATUS
 exclude_feature disk_ft_phase3o_fix11           status=BUILD_D211_STATUS
 exclude_feature nv10155                         status=BUILD_D211_STATUS
 exclude_feature nv0s659                         status=BUILD_D211_STATUS
*DECK DECK=BUILD_D211_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D221_NEW_DECKS
*IF bev$product_level = 'BUILD_D211_NEW_DECKS'
*copyc cycleD2_exceptions
*ELSE
*copyc BUILD_D211_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D211_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D211_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D211_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CLP$CHANGE_COLT_RUC_VALUE         status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck CLV$CRITICAL_LOG_PATH_HANDLE      status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck DPT$CRITICAL_MESSAGES             status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck DPV$CRITICAL_MESSAGES             status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck DPV$CRITICAL_MSGS_NEED_LOGGING    status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGH$ADD_ENTRY_TO_CRITICAL_LOG     status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGH$GET_CRITICAL_LOG_READ_INFO    status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGH$GET_ENTRY_FROM_CRITICAL_LOG   status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGH$INITIALIZE_CRITICAL_LOG_LCD   status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGH$RELEASE_CRITICAL_LOG_SPACE    status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGH$TERMINATE_CRITICAL_LOG        status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGP$ADD_CRITICAL_LOG_ENTRY        status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGP$ADD_ENTRY_TO_CRITICAL_LOG     status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGP$DISPLAY_CRITICAL_LOG_ATTR     status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGP$GET_CRITICAL_LOG_ENTRY        status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGP$GET_CRITICAL_LOG_READ_INFO    status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGP$GET_CRITICAL_PREVIOUS_SIZE    status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGP$GET_CRITICAL_READ_INFO        status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGP$GET_ENTRY_FROM_CRITICAL_LOG   status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGP$GET_PREVIOUS_CRIT_LOG_SIZE    status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGP$INITIALIZE_CRITICAL_LOG_LCD   status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGP$RELEASE_CRITICAL_LOG_SPACE    status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGP$TERMINATE_CRITICAL_LOG        status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGT$CRITICAL_LOG_CONTROL_DESC     status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGV$CRITICAL_LOG_ATTRIBUTES       status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGV$CRITICAL_LOG_CTL              status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck LGV$CRITICAL_LOG_NAME             status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck OFH$CRITICAL_WINDOW_MANAGER       status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck OFM$CRITICAL_WINDOW_MANAGER       status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck OFM$LOG_CRITICAL_MTR_MESSAGES     status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck OFP$CRITICAL_WINDOW_LOG_DISPLAY   status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck OFP$LOG_CRITICAL_MTR_MESSAGES     status=BUILD_D211_NEW_DECKS_STATUS
 exclude_deck RAP$DISPLAY_CRITICAL_WINDOW_LOG   status=BUILD_D211_NEW_DECKS_STATUS
*DECK DECK=BUILD_D221 EXPAND=TRUE
*copyc BUILD_D226
*IF bev$product_level = 'BUILD_D221'
*copyc cycleD2_exceptions
*ELSE
*copyc BUILD_D221_contents
*IFEND
*DECK DECK=BUILD_D221_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D221_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D221_STATUS kind=status
IFEND
 exclude_feature nv0t007                         status=BUILD_D221_STATUS
 exclude_feature nv0t007_fix                     status=BUILD_D221_STATUS
 exclude_feature nv10058                         status=BUILD_D221_STATUS
 exclude_feature nv10169                         status=BUILD_D221_STATUS
 exclude_feature nv10172                         status=BUILD_D221_STATUS
 exclude_feature update_shared_lab_decks         status=BUILD_D221_STATUS
 exclude_feature lab_prolog_fix                  status=BUILD_D221_STATUS
*DECK DECK=BUILD_D221_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D226_NEW_DECKS
*IF bev$product_level = 'BUILD_D221_NEW_DECKS'
*copyc cycleD2_exceptions
*ELSE
*copyc BUILD_D221_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D221_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D221_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D221_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck RAI$PROLOG_SN302_DAS              status=BUILD_D221_NEW_DECKS_STATUS
*DECK DECK=BUILD_D226 EXPAND=TRUE
*copyc BUILD_D227
*IF bev$product_level = 'BUILD_D226'
*copyc cycleD2_exceptions
*ELSE
*copyc BUILD_D226_contents
*IFEND
*DECK DECK=BUILD_D226_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D226_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D226_STATUS kind=status
IFEND
 exclude_feature cti0242                         status=BUILD_D226_STATUS
 exclude_feature nv10118                         status=BUILD_D226_STATUS
 exclude_feature nv10118_1                       status=BUILD_D226_STATUS
 exclude_feature nv10070                         status=BUILD_D226_STATUS
 exclude_feature nv09374_fix                     status=BUILD_D226_STATUS
 exclude_feature nv0v541                         status=BUILD_D226_STATUS
 exclude_feature disk_ft_phase3o_fix13           status=BUILD_D226_STATUS
 exclude_feature nv10174                         status=BUILD_D226_STATUS
 exclude_feature nv10173                         status=BUILD_D226_STATUS
 exclude_feature xtfa008                         status=BUILD_D226_STATUS
*DECK DECK=BUILD_D226_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D227_NEW_DECKS
*IF bev$product_level = 'BUILD_D226_NEW_DECKS'
*copyc cycleD2_exceptions
*ELSE
*copyc BUILD_D226_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D226_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D226_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D226_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CMP$CHECK_FOREIGN_IO              status=BUILD_D226_NEW_DECKS_STATUS
 exclude_deck CMP$CLEAR_IOCT_SERIAL_LOCK        status=BUILD_D226_NEW_DECKS_STATUS
 exclude_deck CMP$SET_IOCT_SERIAL_LOCK          status=BUILD_D226_NEW_DECKS_STATUS
 exclude_deck CMP$UPDATE_ERROR_COUNT            status=BUILD_D226_NEW_DECKS_STATUS
 exclude_deck JSP$CLEAR_RELINK_LOCK             status=BUILD_D226_NEW_DECKS_STATUS
 exclude_deck JSP$SET_RELINK_LOCK               status=BUILD_D226_NEW_DECKS_STATUS
 exclude_deck JST$IJL_LOCK                      status=BUILD_D226_NEW_DECKS_STATUS
 exclude_deck OSC$ECP_MAX_CATALOG_MOVES         status=BUILD_D226_NEW_DECKS_STATUS
 exclude_deck OSP$PREVALIDATE_FREE              status=BUILD_D226_NEW_DECKS_STATUS
 exclude_deck OST$PREVALIDATE_FREE_RESULT       status=BUILD_D226_NEW_DECKS_STATUS
 exclude_deck PFP$REPORT_INVALID_FREE           status=BUILD_D226_NEW_DECKS_STATUS
 exclude_deck PFV$VERIFY_CATALOG_HEAPS          status=BUILD_D226_NEW_DECKS_STATUS
*DECK DECK=BUILD_D227 EXPAND=TRUE
*copyc BUILD_D228
*IF bev$product_level = 'BUILD_D227'
*copyc cycleD2_exceptions
*ELSE
*copyc BUILD_D227_contents
*IFEND
*DECK DECK=BUILD_D227_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D227_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D227_STATUS kind=status
IFEND
 exclude_feature nv0v541_1                       status=BUILD_D227_STATUS
 exclude_feature xtfa010                         status=BUILD_D227_STATUS
 exclude_feature nv10118_2                       status=BUILD_D227_STATUS
 exclude_feature disk_ft_retrieval_sc            status=BUILD_D227_STATUS
 exclude_feature nv10070_1                       status=BUILD_D227_STATUS
*DECK DECK=BUILD_D227_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D228_NEW_DECKS
*IF bev$product_level = 'BUILD_D227_NEW_DECKS'
*copyc cycleD2_exceptions
*ELSE
*copyc BUILD_D227_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D227_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D227_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D227_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck RAM$RETRIEVE_QUALIFIED_FILES      status=BUILD_D227_NEW_DECKS_STATUS
*DECK DECK=BUILD_D228 EXPAND=TRUE
*copyc BUILD_D231
*IF bev$product_level = 'BUILD_D228'
*copyc cycleD2_exceptions
*ELSE
*copyc BUILD_D228_contents
*IFEND
*DECK DECK=BUILD_D228_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D228_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D231_NEW_DECKS
*IF bev$product_level = 'BUILD_D228_NEW_DECKS'
*copyc cycleD2_exceptions
*ELSE
*copyc BUILD_D228_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D228_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D231 EXPAND=TRUE
*copyc BUILD_D301
*IF bev$product_level = 'BUILD_D231'
*copyc cycleD2_exceptions
*ELSE
*copyc BUILD_D231_contents
*IFEND
*DECK DECK=BUILD_D231_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D231_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D231_STATUS kind=status
IFEND
 exclude_feature nv09194                         status=BUILD_D231_STATUS
 exclude_feature disk_ft_retrieval_sc_1          status=BUILD_D231_STATUS
 exclude_feature nv10192                         status=BUILD_D231_STATUS
 exclude_feature xtfa011                         status=BUILD_D231_STATUS
 exclude_feature nv10070_2                       status=BUILD_D231_STATUS
*DECK DECK=BUILD_D231_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D301_NEW_DECKS
*IF bev$product_level = 'BUILD_D231_NEW_DECKS'
*copyc cycleD2_exceptions
*ELSE
*copyc BUILD_D231_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D231_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D231_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D231_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CMP$CHECK_IO_STATUS               status=BUILD_D231_NEW_DECKS_STATUS
 exclude_deck CMP$DOWN_FOREIGN_IO               status=BUILD_D231_NEW_DECKS_STATUS
 exclude_deck CMP$ENABLE_FOREIGN_IO             status=BUILD_D231_NEW_DECKS_STATUS
 exclude_deck CMP$TEST_AND_CLEAR_IOCT_LOCK      status=BUILD_D231_NEW_DECKS_STATUS
 exclude_deck IOP$CLEAR_RESPONSE_PTR            status=BUILD_D231_NEW_DECKS_STATUS
 exclude_deck PUP$RETRIEVE_QUALIFIED_FILES      status=BUILD_D231_NEW_DECKS_STATUS
*DECK DECK=BUILD_D271 EXPAND=TRUE
*IF bev$product_level = 'BUILD_D221 '
*copyc BUILD_D221
*IFEND
IF $variable(build_d271_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_d271_status kind=status
IFEND
 include_feature cti0242                         status=build_d271_status
 include_feature nv10118                         status=build_d271_status
 include_feature nv10118_1                       status=build_d271_status
 include_feature nv10070                         status=build_d271_status
 include_feature nv09374_fix                     status=build_d271_status
 include_feature disk_ft_phase3o_fix13           status=build_d271_status
 include_feature nv10174                         status=build_d271_status
 include_feature nv10173                         status=build_d271_status
 include_feature xtfa008                         status=build_d271_status
*DECK DECK=BUILD_D273 EXPAND=TRUE
*IF bev$product_level = 'BUILD_D221 '
*copyc BUILD_D221
*IFEND
IF $variable(build_d273_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_d273_status kind=status
IFEND
 include_feature cti0242                         status=build_d273_status
 include_feature nv10118                         status=build_d273_status
 include_feature nv10118_1                       status=build_d273_status
 include_feature nv0v541                         status=build_d273_status
 include_feature nv0v541_1                       status=build_d273_status
 include_feature nv09374_fix                     status=build_d273_status
 include_feature disk_ft_phase3o_fix13           status=build_d273_status
 include_feature nv10174                         status=build_d273_status
 include_feature nv10173                         status=build_d273_status
 include_feature xtfa008                         status=build_d273_status
*DECK DECK=BUILD_D301 EXPAND=TRUE
*copyc BUILD_D311
*IF bev$product_level = 'BUILD_D301'
*copyc cycleD3_exceptions
*ELSE
*copyc BUILD_D301_contents
*IFEND
*DECK DECK=BUILD_D301_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D301_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D301_STATUS kind=status
IFEND
 exclude_feature nv0v589                         status=BUILD_D301_STATUS
 exclude_feature nv0v526                         status=BUILD_D301_STATUS
 exclude_feature nv0v576                         status=BUILD_D301_STATUS
 exclude_feature nv10183                         status=BUILD_D301_STATUS
 exclude_feature display_log_status_in_cwl       status=BUILD_D301_STATUS
 exclude_feature nv10025                         status=BUILD_D301_STATUS
 exclude_feature nv10202                         status=BUILD_D301_STATUS
 exclude_feature change_pacs_loapl               status=BUILD_D301_STATUS
*DECK DECK=BUILD_D301_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D311_NEW_DECKS
*IF bev$product_level = 'BUILD_D301_NEW_DECKS'
*copyc cycleD3_exceptions
*ELSE
*copyc BUILD_D301_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D301_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D301_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D301_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck MMH$VERIFY_NO_SPACE_AVAILABLE     status=BUILD_D301_NEW_DECKS_STATUS
 exclude_deck MMP$VERIFY_NO_SPACE_AVAILABLE     status=BUILD_D301_NEW_DECKS_STATUS
*DECK DECK=BUILD_D311 EXPAND=TRUE
*copyc BUILD_D321
*IF bev$product_level = 'BUILD_D311'
*copyc cycleD3_exceptions
*ELSE
*copyc BUILD_D311_contents
*IFEND
*DECK DECK=BUILD_D311_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D311_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D311_STATUS kind=status
IFEND
 exclude_feature correct_ved_aj_header           status=BUILD_D311_STATUS
 exclude_feature display_upf                     status=BUILD_D311_STATUS
 exclude_feature nv10221                         status=BUILD_D311_STATUS
 exclude_feature nv10235                         status=BUILD_D311_STATUS
 exclude_feature nv10228                         status=BUILD_D311_STATUS
 exclude_feature nv0s030                         status=BUILD_D311_STATUS
 exclude_feature xwna020_os                      status=BUILD_D311_STATUS
 exclude_feature nv0r630                         status=BUILD_D311_STATUS
*DECK DECK=BUILD_D311_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D321_NEW_DECKS
*IF bev$product_level = 'BUILD_D311_NEW_DECKS'
*copyc cycleD3_exceptions
*ELSE
*copyc BUILD_D311_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D311_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D321 EXPAND=TRUE
*copyc BUILD_D326
*IF bev$product_level = 'BUILD_D321'
*copyc cycleD3_exceptions
*ELSE
*copyc BUILD_D321_contents
*IFEND
*DECK DECK=BUILD_D321_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D321_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D321_STATUS kind=status
IFEND
 exclude_feature nv10116_trap_2                  status=BUILD_D321_STATUS
 exclude_feature nv10238                         status=BUILD_D321_STATUS
 exclude_feature nv10234                         status=BUILD_D321_STATUS
 exclude_feature nv10209                         status=BUILD_D321_STATUS
 exclude_feature nv0v596                         status=BUILD_D321_STATUS
 exclude_feature nv0s186                         status=BUILD_D321_STATUS
 exclude_feature ibm_35_disk_drive_support_code  status=BUILD_D321_STATUS
*DECK DECK=BUILD_D321_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D326_NEW_DECKS
*IF bev$product_level = 'BUILD_D321_NEW_DECKS'
*copyc cycleD3_exceptions
*ELSE
*copyc BUILD_D321_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D321_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D321_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D321_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CMP$PROCESS_DAS_RESTORE           status=BUILD_D321_NEW_DECKS_STATUS
 exclude_deck DMP$PROCESS_DAS_RESTORE           status=BUILD_D321_NEW_DECKS_STATUS
*DECK DECK=BUILD_D326 EXPAND=TRUE
*copyc BUILD_D331
*IF bev$product_level = 'BUILD_D326'
*copyc cycleD3_exceptions
*ELSE
*copyc BUILD_D326_contents
*IFEND
*DECK DECK=BUILD_D326_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D326_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D326_STATUS kind=status
IFEND
 exclude_feature nv10049                         status=BUILD_D326_STATUS
 exclude_feature nv10199                         status=BUILD_D326_STATUS
 exclude_feature tcpip_job_recovery              status=BUILD_D326_STATUS
 exclude_feature nv10234_1                       status=BUILD_D326_STATUS
 exclude_feature nv09992                         status=BUILD_D326_STATUS
 exclude_feature fuf_makbr_os                    status=BUILD_D326_STATUS
 exclude_feature clear_log_lock                  status=BUILD_D326_STATUS
 exclude_feature nv0s030                         status=BUILD_D326_STATUS
 exclude_feature nv0s030_fix                     status=BUILD_D326_STATUS
 exclude_feature nv09680                         status=BUILD_D326_STATUS
 exclude_feature nv10143                         status=BUILD_D326_STATUS
 exclude_feature ibm_35_fix_1                    status=BUILD_D326_STATUS
*DECK DECK=BUILD_D326_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D331_NEW_DECKS
*IF bev$product_level = 'BUILD_D326_NEW_DECKS'
*copyc cycleD3_exceptions
*ELSE
*copyc BUILD_D326_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D326_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D326_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D326_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck PFP$NO_SPACE_MOVC_DEST_VOLUMES    status=BUILD_D326_NEW_DECKS_STATUS
 exclude_deck PUV$CREATE_OBJECTS                status=BUILD_D326_NEW_DECKS_STATUS
 exclude_deck PUV$REPLACE_CYCLE_DATA            status=BUILD_D326_NEW_DECKS_STATUS
 exclude_deck RAF$FUF_INTERFACE_SC              status=BUILD_D326_NEW_DECKS_STATUS
*DECK DECK=BUILD_D331 EXPAND=TRUE
*copyc BUILD_D332
*IF bev$product_level = 'BUILD_D331'
*copyc cycleD3_exceptions
*ELSE
*copyc BUILD_D331_contents
*IFEND
*DECK DECK=BUILD_D331_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D331_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D331_STATUS kind=status
IFEND
 exclude_feature nv10178                         status=BUILD_D331_STATUS
 exclude_feature nv10232                         status=BUILD_D331_STATUS
 exclude_feature validate_store_seg_attributes   status=BUILD_D331_STATUS
 exclude_feature user_callable_fsp$create_file   status=BUILD_D331_STATUS
 exclude_feature fuf_makbr_os_1                  status=BUILD_D331_STATUS
 exclude_feature nv10261                         status=BUILD_D331_STATUS
 exclude_feature nv0v604                         status=BUILD_D331_STATUS
 exclude_feature nv0v601                         status=BUILD_D331_STATUS
 exclude_feature nv10239                         status=BUILD_D331_STATUS
 exclude_feature nv10253                         status=BUILD_D331_STATUS
 exclude_feature remove_jr_trap                  status=BUILD_D331_STATUS
 exclude_feature ibm35_fc_fix                    status=BUILD_D331_STATUS
 exclude_feature xtfa016                         status=BUILD_D331_STATUS
 exclude_feature scl_new_types_i_s_lib           status=BUILD_D331_STATUS
*DECK DECK=BUILD_D331_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D332_NEW_DECKS
*IF bev$product_level = 'BUILD_D331_NEW_DECKS'
*copyc cycleD3_exceptions
*ELSE
*copyc BUILD_D331_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D331_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D331_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D331_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck JME$UNABLE_TO_ALLOC_ALL_SPACE     status=BUILD_D331_NEW_DECKS_STATUS
*DECK DECK=BUILD_D332 EXPAND=TRUE
*copyc BUILD_D333
*IF bev$product_level = 'BUILD_D332'
*copyc cycleD3_exceptions
*ELSE
*copyc BUILD_D332_contents
*IFEND
*DECK DECK=BUILD_D332_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D332_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D333_NEW_DECKS
*IF bev$product_level = 'BUILD_D332_NEW_DECKS'
*copyc cycleD3_exceptions
*ELSE
*copyc BUILD_D332_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D332_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D333 EXPAND=TRUE
*copyc BUILD_D334
*IF bev$product_level = 'BUILD_D333'
*copyc cycleD3_exceptions
*ELSE
*copyc BUILD_D333_contents
*IFEND
*DECK DECK=BUILD_D333_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D333_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D333_STATUS kind=status
IFEND
 exclude_feature nv09992_2                       status=BUILD_D333_STATUS
 exclude_feature ibm_35_fix_2                    status=BUILD_D333_STATUS
*DECK DECK=BUILD_D333_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D334_NEW_DECKS
*IF bev$product_level = 'BUILD_D333_NEW_DECKS'
*copyc cycleD3_exceptions
*ELSE
*copyc BUILD_D333_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D333_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D334 EXPAND=TRUE
*copyc BUILD_D502
*IF bev$product_level = 'BUILD_D334'
*copyc cycleD3_exceptions
*ELSE
*copyc BUILD_D334_contents
*IFEND
*DECK DECK=BUILD_D334_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D334_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D502_NEW_DECKS
*IF bev$product_level = 'BUILD_D334_NEW_DECKS'
*copyc cycleD3_exceptions
*ELSE
*copyc BUILD_D334_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D334_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D501 EXPAND=TRUE
*IF bev$product_level = 'BUILD_D501'
*copyc BUILD_D502_contents
*copyc BUILD_D334_contents
*copyc BUILD_D333_contents
*copyc BUILD_D332_contents
*copyc BUILD_D331_contents
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D501_contents
*IFEND
*DECK DECK=BUILD_D501_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D501_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D501_STATUS kind=status
IFEND
 exclude_feature host_echo_os_1                  status=BUILD_D501_STATUS
 exclude_feature host_echo_os_2                  status=BUILD_D501_STATUS
*DECK DECK=BUILD_D501_NEW_DECKS EXPAND=TRUE
*IF bev$product_level = 'BUILD_D501_NEW_DECKS'
*copyc BUILD_D502_NEW_DECKS_contents
*copyc BUILD_D334_NEW_DECKS_contents
*copyc BUILD_D333_NEW_DECKS_contents
*copyc BUILD_D332_NEW_DECKS_contents
*copyc BUILD_D331_NEW_DECKS_contents
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D501_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D501_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D502 EXPAND=TRUE
*copyc BUILD_D505
*IF bev$product_level = 'BUILD_D502'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D502_contents
*IFEND
*DECK DECK=BUILD_D502_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D502_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D505_NEW_DECKS
*IF bev$product_level = 'BUILD_D502_NEW_DECKS'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D502_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D502_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D505 EXPAND=TRUE
*copyc BUILD_D511
*IF bev$product_level = 'BUILD_D505'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D505_contents
*IFEND
*DECK DECK=BUILD_D505_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D505_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D505_STATUS kind=status
IFEND
 exclude_feature host_echo_os                    status=BUILD_D505_STATUS
 exclude_feature fix_dev_accounts                status=BUILD_D505_STATUS
 exclude_feature nv09531                         status=BUILD_D505_STATUS
 exclude_feature nv0n506                         status=BUILD_D505_STATUS
 exclude_feature nv0s253                         status=BUILD_D505_STATUS
 exclude_feature nv0n062                         status=BUILD_D505_STATUS
 exclude_feature nv0n062_unix_fix                status=BUILD_D505_STATUS
 exclude_feature nv0v326                         status=BUILD_D505_STATUS
 exclude_feature nv0v594                         status=BUILD_D505_STATUS
 exclude_feature nv0v597                         status=BUILD_D505_STATUS
 exclude_feature nv0v602                         status=BUILD_D505_STATUS
 exclude_feature nv0v610                         status=BUILD_D505_STATUS
 exclude_feature nv10176                         status=BUILD_D505_STATUS
 exclude_feature nv10210                         status=BUILD_D505_STATUS
 exclude_feature nv10244                         status=BUILD_D505_STATUS
 exclude_feature nv10245_1                       status=BUILD_D505_STATUS
 exclude_feature nv10257                         status=BUILD_D505_STATUS
 exclude_feature nv10268                         status=BUILD_D505_STATUS
 exclude_feature nv10269                         status=BUILD_D505_STATUS
 exclude_feature nv10272                         status=BUILD_D505_STATUS
 exclude_feature nv10276                         status=BUILD_D505_STATUS
 exclude_feature nv10277                         status=BUILD_D505_STATUS
 exclude_feature nv10279                         status=BUILD_D505_STATUS
 exclude_feature nv10281                         status=BUILD_D505_STATUS
 exclude_feature nv10282                         status=BUILD_D505_STATUS
 exclude_feature nv10286                         status=BUILD_D505_STATUS
 exclude_feature nv1a011                         status=BUILD_D505_STATUS
 exclude_feature nv10267                         status=BUILD_D505_STATUS
*DECK DECK=BUILD_D505_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D511_NEW_DECKS
*IF bev$product_level = 'BUILD_D505_NEW_DECKS'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D505_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D505_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D505_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D505_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CLP$CHANGE_HDR_CREATION_VALUE     status=BUILD_D505_NEW_DECKS_STATUS
 exclude_deck CMM$NO_PP_DRIVER                  status=BUILD_D505_NEW_DECKS_STATUS
 exclude_deck CMP$DUMMY_UP_PP                   status=BUILD_D505_NEW_DECKS_STATUS
 exclude_deck CSM$DEC_VT100_HOST_ECHO           status=BUILD_D505_NEW_DECKS_STATUS
 exclude_deck CSM$MAC_HOST_ECHO_21              status=BUILD_D505_NEW_DECKS_STATUS
 exclude_deck CSM$MAC_HOST_ECHO_22              status=BUILD_D505_NEW_DECKS_STATUS
 exclude_deck CSM$PC_HOST_ECHO_13               status=BUILD_D505_NEW_DECKS_STATUS
 exclude_deck CSM$PC_HOST_ECHO_20               status=BUILD_D505_NEW_DECKS_STATUS
 exclude_deck CSM$TV_HALF_FULL_DUPLEX           status=BUILD_D505_NEW_DECKS_STATUS
 exclude_deck CSM$VISTA_MAC_HOST_ECHO_30        status=BUILD_D505_NEW_DECKS_STATUS
 exclude_deck CSM$WYSE_60_HOST_ECHO             status=BUILD_D505_NEW_DECKS_STATUS
 exclude_deck DMV$MAINFRAME_RECOVERED           status=BUILD_D505_NEW_DECKS_STATUS
 exclude_deck IOP$GET_IN_OUT_PTRS               status=BUILD_D505_NEW_DECKS_STATUS
 exclude_deck SYP$SET_MAINFRAME_RECOVERED       status=BUILD_D505_NEW_DECKS_STATUS
*DECK DECK=BUILD_D511 EXPAND=TRUE
*copyc BUILD_D512
*IF bev$product_level = 'BUILD_D511'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D511_contents
*IFEND
*DECK DECK=BUILD_D511_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D511_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D511_STATUS kind=status
IFEND
 exclude_feature nv10291                         status=BUILD_D511_STATUS
 exclude_feature nv10283                         status=BUILD_D511_STATUS
 exclude_feature xwna022                         status=BUILD_D511_STATUS
 exclude_feature nv0v623                         status=BUILD_D511_STATUS
 exclude_feature nv10287                         status=BUILD_D511_STATUS
 exclude_feature nv10244_1                       status=BUILD_D511_STATUS
*DECK DECK=BUILD_D511_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D512_NEW_DECKS
*IF bev$product_level = 'BUILD_D511_NEW_DECKS'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D511_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D511_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D512 EXPAND=TRUE
*copyc BUILD_D521
*IF bev$product_level = 'BUILD_D512'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D512_contents
*IFEND
*DECK DECK=BUILD_D512_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D512_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D512_STATUS kind=status
IFEND
*DECK DECK=BUILD_D512_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D521_NEW_DECKS
*IF bev$product_level = 'BUILD_D512_NEW_DECKS'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D512_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D512_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D521 EXPAND=TRUE
*copyc BUILD_D525
*IF bev$product_level = 'BUILD_D521'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D521_contents
*IFEND
*DECK DECK=BUILD_D521_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D521_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D521_STATUS kind=status
IFEND
 exclude_feature ibm_35_fix_3                    status=BUILD_D521_STATUS
 exclude_feature nv0v326                         status=BUILD_D521_STATUS
 exclude_feature nv0v326_1                       status=BUILD_D521_STATUS
 exclude_feature nv0v565                         status=BUILD_D521_STATUS
 exclude_feature nv0v620                         status=BUILD_D521_STATUS
 exclude_feature nv0v621                         status=BUILD_D521_STATUS
 exclude_feature nv10250                         status=BUILD_D521_STATUS
 exclude_feature nv10284                         status=BUILD_D521_STATUS
 exclude_feature nv10293                         status=BUILD_D521_STATUS
 exclude_feature nv08775                         status=BUILD_D521_STATUS
 exclude_feature nv10309                         status=BUILD_D521_STATUS
*DECK DECK=BUILD_D521_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D525_NEW_DECKS
*IF bev$product_level = 'BUILD_D521_NEW_DECKS'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D521_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D521_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D521_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D521_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CLP$CHANGE_COMMAND_TYPE_VALUE     status=BUILD_D521_NEW_DECKS_STATUS
 exclude_deck CLV$COMMAND_IS_ASSIGNMENT         status=BUILD_D521_NEW_DECKS_STATUS
*DECK DECK=BUILD_D525 EXPAND=TRUE
*copyc BUILD_D531
*IF bev$product_level = 'BUILD_D525'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D525_contents
*IFEND
*DECK DECK=BUILD_D525_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D525_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D531_NEW_DECKS
*IF bev$product_level = 'BUILD_D525_NEW_DECKS'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D525_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D525_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D531 EXPAND=TRUE
*copyc BUILD_D536
*IF bev$product_level = 'BUILD_D531'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D531_contents
*IFEND
*DECK DECK=BUILD_D531_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D531_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D531_STATUS kind=status
IFEND
 exclude_feature nv09992_1                       status=BUILD_D531_STATUS
 exclude_feature nv0v607                         status=BUILD_D531_STATUS
 exclude_feature nv0v619                         status=BUILD_D531_STATUS
 exclude_feature nv10143_1                       status=BUILD_D531_STATUS
 exclude_feature nv10266                         status=BUILD_D531_STATUS
 exclude_feature nv10298                         status=BUILD_D531_STATUS
 exclude_feature nv10300                         status=BUILD_D531_STATUS
 exclude_feature nv10304                         status=BUILD_D531_STATUS
 exclude_feature nv10309a                        status=BUILD_D531_STATUS
 exclude_feature nv10314                         status=BUILD_D531_STATUS
 exclude_feature update_pmh$wait                 status=BUILD_D531_STATUS
 exclude_feature user_callable_fsp$create_file_1 status=BUILD_D531_STATUS
*DECK DECK=BUILD_D531_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D536_NEW_DECKS
*IF bev$product_level = 'BUILD_D531_NEW_DECKS'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D531_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D531_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D531_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D531_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck PFH$DELETE_CYCLE_DATA             status=BUILD_D531_NEW_DECKS_STATUS
 exclude_deck PFP$DELETE_CYCLE_DATA             status=BUILD_D531_NEW_DECKS_STATUS
 exclude_deck PFT$PURGE_CYCLE_OPTIONS           status=BUILD_D531_NEW_DECKS_STATUS
 exclude_deck PFV$NULL_DATE_TIME                status=BUILD_D531_NEW_DECKS_STATUS
 exclude_deck PUV$PURGE_CYCLE_OPTIONS           status=BUILD_D531_NEW_DECKS_STATUS
*DECK DECK=BUILD_D536 EXPAND=TRUE
*copyc BUILD_D541
*IF bev$product_level = 'BUILD_D536'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D536_contents
*IFEND
*DECK DECK=BUILD_D536_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D536_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D536_STATUS kind=status
IFEND
 exclude_feature fix_false_losing_log_msgs       status=BUILD_D536_STATUS
 exclude_feature nv0v533                         status=BUILD_D536_STATUS
 exclude_feature unmodify_command_descriptor     status=BUILD_D536_STATUS
*DECK DECK=BUILD_D536_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D541_NEW_DECKS
*IF bev$product_level = 'BUILD_D536_NEW_DECKS'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D536_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D536_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D541 EXPAND=TRUE
*copyc BUILD_D542
*IF bev$product_level = 'BUILD_D541'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D541_contents
*IFEND
*DECK DECK=BUILD_D541_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D541_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D541_STATUS kind=status
IFEND
 exclude_feature nv10325                         status=BUILD_D541_STATUS
 exclude_feature nv10115                         status=BUILD_D541_STATUS
 exclude_feature disk_ft_retrieval_sc_2          status=BUILD_D541_STATUS
*DECK DECK=BUILD_D541_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D542_NEW_DECKS
*IF bev$product_level = 'BUILD_D541_NEW_DECKS'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D541_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D541_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D542 EXPAND=TRUE
*copyc BUILD_D543
*IF bev$product_level = 'BUILD_D542'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D542_contents
*IFEND
*DECK DECK=BUILD_D542_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D542_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D543_NEW_DECKS
*IF bev$product_level = 'BUILD_D542_NEW_DECKS'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D542_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D542_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D543 EXPAND=TRUE
*copyc BUILD_D544
*IF bev$product_level = 'BUILD_D543'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D543_contents
*IFEND
*DECK DECK=BUILD_D543_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D543_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D543_STATUS kind=status
IFEND
 exclude_feature nfs0140_os                      status=BUILD_D543_STATUS
 exclude_feature nv10266_1                       status=BUILD_D543_STATUS
 exclude_feature nv0v643                         status=BUILD_D543_STATUS
*DECK DECK=BUILD_D543_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D544_NEW_DECKS
*IF bev$product_level = 'BUILD_D543_NEW_DECKS'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D543_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D543_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D543_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D543_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CLP$CHANGE_COMMAND_TYPE_VALUE     status=BUILD_D543_NEW_DECKS_STATUS
 exclude_deck CLV$COMMAND_IS_ASSIGNMENT         status=BUILD_D543_NEW_DECKS_STATUS
*DECK DECK=BUILD_D544 EXPAND=TRUE
*copyc BUILD_D601
*IF bev$product_level = 'BUILD_D544'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D544_contents
*IFEND
*DECK DECK=BUILD_D544_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D544_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D601_NEW_DECKS
*IF bev$product_level = 'BUILD_D544_NEW_DECKS'
*copyc cycleD5_exceptions
*ELSE
*copyc BUILD_D544_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D544_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D601 EXPAND=TRUE
*copyc BUILD_D605
*IF bev$product_level = 'BUILD_D601'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D601_contents
*IFEND
*DECK DECK=BUILD_D601_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D601_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D601_STATUS kind=status
IFEND
 exclude_feature cm_status_logging               status=BUILD_D601_STATUS
 exclude_feature disk_ft_retrieval_sc_3          status=BUILD_D601_STATUS
 exclude_feature nv09908                         status=BUILD_D601_STATUS
 exclude_feature nv0v634                         status=BUILD_D601_STATUS
 exclude_feature nv0v637                         status=BUILD_D601_STATUS
 exclude_feature nv0v638                         status=BUILD_D601_STATUS
 exclude_feature nv10033                         status=BUILD_D601_STATUS
 exclude_feature nv10313                         status=BUILD_D601_STATUS
 exclude_feature nv10315                         status=BUILD_D601_STATUS
 exclude_feature nv10316                         status=BUILD_D601_STATUS
 exclude_feature nv10320                         status=BUILD_D601_STATUS
 exclude_feature nv10323                         status=BUILD_D601_STATUS
 exclude_feature nv10329                         status=BUILD_D601_STATUS
 exclude_feature nv10335                         status=BUILD_D601_STATUS
 exclude_feature nv10338                         status=BUILD_D601_STATUS
 exclude_feature set_cycle_damage_command_fix    status=BUILD_D601_STATUS
 exclude_feature silo_shared_lab                 status=BUILD_D601_STATUS
*DECK DECK=BUILD_D601_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D605_NEW_DECKS
*IF bev$product_level = 'BUILD_D601_NEW_DECKS'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D601_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D601_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D605 EXPAND=TRUE
*copyc BUILD_D611
*IF bev$product_level = 'BUILD_D605'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D605_contents
*IFEND
*DECK DECK=BUILD_D605_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D605_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D605_STATUS kind=status
IFEND
 exclude_feature nv09974                         status=BUILD_D605_STATUS
 exclude_feature nv10367                         status=BUILD_D605_STATUS
 exclude_feature nv10350                         status=BUILD_D605_STATUS
 exclude_feature nv10345                         status=BUILD_D605_STATUS
 exclude_feature disfat_fix                      status=BUILD_D605_STATUS
 exclude_feature nv0q259                         status=BUILD_D605_STATUS
 exclude_feature nv09826                         status=BUILD_D605_STATUS
 exclude_feature nv10354                         status=BUILD_D605_STATUS
*DECK DECK=BUILD_D605_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D611_NEW_DECKS
*IF bev$product_level = 'BUILD_D605_NEW_DECKS'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D605_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D605_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D611 EXPAND=TRUE
*copyc BUILD_D621
*IF bev$product_level = 'BUILD_D611'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D611_contents
*IFEND
*DECK DECK=BUILD_D611_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D611_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D611_STATUS kind=status
IFEND
 exclude_feature nv0v656                         status=BUILD_D611_STATUS
 exclude_feature nv0v656_1                       status=BUILD_D611_STATUS
 exclude_feature nv10336_doc                     status=BUILD_D611_STATUS
 exclude_feature nv10336_doc1                    status=BUILD_D611_STATUS
 exclude_feature nv10365                         status=BUILD_D611_STATUS
 exclude_feature nv10373                         status=BUILD_D611_STATUS
 exclude_feature nv0v655                         status=BUILD_D611_STATUS
 exclude_feature nv0v657                         status=BUILD_D611_STATUS
 exclude_feature nv0v654                         status=BUILD_D611_STATUS
 exclude_feature nv10374                         status=BUILD_D611_STATUS
 exclude_feature nv10343                         status=BUILD_D611_STATUS
 exclude_feature nv10227                         status=BUILD_D611_STATUS
*DECK DECK=BUILD_D611_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D621_NEW_DECKS
*IF bev$product_level = 'BUILD_D611_NEW_DECKS'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D611_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D611_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D621 EXPAND=TRUE
*copyc BUILD_D622
*IF bev$product_level = 'BUILD_D621'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D621_contents
*IFEND
*DECK DECK=BUILD_D621_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D621_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D621_STATUS kind=status
IFEND
 exclude_feature nv0v658                         status=BUILD_D621_STATUS
 exclude_feature nv0v664                         status=BUILD_D621_STATUS
 exclude_feature nv0v665                         status=BUILD_D621_STATUS
 exclude_feature nv0t889_os                      status=BUILD_D621_STATUS
 exclude_feature nv10086                         status=BUILD_D621_STATUS
 exclude_feature nv10355                         status=BUILD_D621_STATUS
 exclude_feature nv10376                         status=BUILD_D621_STATUS
*DECK DECK=BUILD_D621_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D622_NEW_DECKS
*IF bev$product_level = 'BUILD_D621_NEW_DECKS'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D621_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D621_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D621_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D621_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CMP$GET_PARITY_STATUS_INFO        status=BUILD_D621_NEW_DECKS_STATUS
*DECK DECK=BUILD_D622 EXPAND=TRUE
*copyc BUILD_D631
*IF bev$product_level = 'BUILD_D622'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D622_contents
*IFEND
*DECK DECK=BUILD_D622_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D622_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D622_STATUS kind=status
IFEND
 exclude_feature seguras                         status=BUILD_D622_STATUS
*DECK DECK=BUILD_D622_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D631_NEW_DECKS
*IF bev$product_level = 'BUILD_D622_NEW_DECKS'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D622_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D622_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D631 EXPAND=TRUE
*copyc BUILD_D632
*IF bev$product_level = 'BUILD_D631'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D631_contents
*IFEND
*DECK DECK=BUILD_D631_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D631_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D631_STATUS kind=status
IFEND
 exclude_feature nv0v649                         status=BUILD_D631_STATUS
 exclude_feature nv0v657_a                       status=BUILD_D631_STATUS
 exclude_feature nv09687                         status=BUILD_D631_STATUS
 exclude_feature nv10086_fix_1                   status=BUILD_D631_STATUS
 exclude_feature nv10242                         status=BUILD_D631_STATUS
 exclude_feature nv10380                         status=BUILD_D631_STATUS
 exclude_feature nv10382                         status=BUILD_D631_STATUS
 exclude_feature nv0v669                         status=BUILD_D631_STATUS
 exclude_feature nv0v670                         status=BUILD_D631_STATUS
 exclude_feature nv10382_1                       status=BUILD_D631_STATUS
 exclude_feature seguros                         status=BUILD_D631_STATUS
*DECK DECK=BUILD_D631_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D632_NEW_DECKS
*IF bev$product_level = 'BUILD_D631_NEW_DECKS'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D631_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D631_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D631_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D631_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck PUP$CHECK_IF_SUBITEM_EXCLUDED     status=BUILD_D631_NEW_DECKS_STATUS
*DECK DECK=BUILD_D632 EXPAND=TRUE
*copyc BUILD_D633
*IF bev$product_level = 'BUILD_D632'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D632_contents
*IFEND
*DECK DECK=BUILD_D632_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D632_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D632_STATUS kind=status
IFEND
 exclude_feature nv09687_fix_1                   status=BUILD_D632_STATUS
 exclude_feature nv0v455                         status=BUILD_D632_STATUS
 exclude_feature nv10379                         status=BUILD_D632_STATUS
 exclude_feature nv10392                         status=BUILD_D632_STATUS
 exclude_feature nv10393                         status=BUILD_D632_STATUS
*DECK DECK=BUILD_D632_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D633_NEW_DECKS
*IF bev$product_level = 'BUILD_D632_NEW_DECKS'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D632_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D632_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D633 EXPAND=TRUE
*copyc BUILD_D641
*IF bev$product_level = 'BUILD_D633'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D633_contents
*IFEND
*DECK DECK=BUILD_D633_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D633_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D641_NEW_DECKS
*IF bev$product_level = 'BUILD_D633_NEW_DECKS'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D633_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D633_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D641 EXPAND=TRUE
*copyc BUILD_D642
*IF bev$product_level = 'BUILD_D641'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D641_contents
*IFEND
*DECK DECK=BUILD_D641_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D641_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D641_STATUS kind=status
IFEND
 exclude_feature nv0v662                         status=BUILD_D641_STATUS
 exclude_feature xtf0034_os                      status=BUILD_D641_STATUS
*DECK DECK=BUILD_D641_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D642_NEW_DECKS
*IF bev$product_level = 'BUILD_D641_NEW_DECKS'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D641_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D641_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D642 EXPAND=TRUE
*copyc BUILD_D643
*IF bev$product_level = 'BUILD_D642'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D642_contents
*IFEND
*DECK DECK=BUILD_D642_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D642_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D643_NEW_DECKS
*IF bev$product_level = 'BUILD_D642_NEW_DECKS'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D642_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D642_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D643 EXPAND=TRUE
*copyc BUILD_D701
*IF bev$product_level = 'BUILD_D643'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D643_contents
*IFEND
*DECK DECK=BUILD_D643_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D643_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D643_STATUS kind=status
IFEND
*DECK DECK=BUILD_D643_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D701_NEW_DECKS
*IF bev$product_level = 'BUILD_D643_NEW_DECKS'
*copyc cycleD6_exceptions
*ELSE
*copyc BUILD_D643_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D643_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D701 EXPAND=TRUE
*copyc BUILD_D705
*IF bev$product_level = 'BUILD_D701'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D701_contents
*IFEND
*DECK DECK=BUILD_D701_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D701_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D701_STATUS kind=status
IFEND
 exclude_feature nv0t543                         status=BUILD_D701_STATUS
 exclude_feature nv0u515                         status=BUILD_D701_STATUS
 exclude_feature nv0u365                         status=BUILD_D701_STATUS
 exclude_feature nv0v674                         status=BUILD_D701_STATUS
 exclude_feature nv1a015                         status=BUILD_D701_STATUS
 exclude_feature nv10366                         status=BUILD_D701_STATUS
 exclude_feature nv10399                         status=BUILD_D701_STATUS
 exclude_feature nv10411                         status=BUILD_D701_STATUS
 exclude_feature nv10412                         status=BUILD_D701_STATUS
*DECK DECK=BUILD_D701_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D705_NEW_DECKS
*IF bev$product_level = 'BUILD_D701_NEW_DECKS'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D701_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D701_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D705 EXPAND=TRUE
*copyc BUILD_D711
*IF bev$product_level = 'BUILD_D705'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D705_contents
*IFEND
*DECK DECK=BUILD_D705_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D705_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D705_STATUS kind=status
IFEND
 exclude_feature nv0v679                         status=BUILD_D705_STATUS
 exclude_feature nv10112                         status=BUILD_D705_STATUS
 exclude_feature nv10186                         status=BUILD_D705_STATUS
 exclude_feature nv10407                         status=BUILD_D705_STATUS
 exclude_feature nv10407_2                       status=BUILD_D705_STATUS
 exclude_feature nv10413                         status=BUILD_D705_STATUS
*DECK DECK=BUILD_D705_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D711_NEW_DECKS
*IF bev$product_level = 'BUILD_D705_NEW_DECKS'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D705_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D705_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D711 EXPAND=TRUE
*copyc BUILD_D721
*IF bev$product_level = 'BUILD_D711'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D711_contents
*IFEND
*DECK DECK=BUILD_D711_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D711_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D711_STATUS kind=status
IFEND
 exclude_feature nv10420                         status=BUILD_D711_STATUS
 exclude_feature nv10405                         status=BUILD_D711_STATUS
 exclude_feature nv0v678                         status=BUILD_D711_STATUS
 exclude_feature nv09980                         status=BUILD_D711_STATUS
*DECK DECK=BUILD_D711_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D721_NEW_DECKS
*IF bev$product_level = 'BUILD_D711_NEW_DECKS'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D711_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D711_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D721 EXPAND=TRUE
*copyc BUILD_D731
*IF bev$product_level = 'BUILD_D721'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D721_contents
*IFEND
*DECK DECK=BUILD_D721_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D721_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D721_STATUS kind=status
IFEND
 exclude_feature nv10406                         status=BUILD_D721_STATUS
 exclude_feature nv10422                         status=BUILD_D721_STATUS
 exclude_feature nv10418                         status=BUILD_D721_STATUS
 exclude_feature nv09869_final_fix               status=BUILD_D721_STATUS
*DECK DECK=BUILD_D721_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D731_NEW_DECKS
*IF bev$product_level = 'BUILD_D721_NEW_DECKS'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D721_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D721_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D721_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D721_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck JMH$CLOSE_FILES_FOR_COPQF         status=BUILD_D721_NEW_DECKS_STATUS
 exclude_deck JMP$CLOSE_FILES_FOR_COPQF         status=BUILD_D721_NEW_DECKS_STATUS
 exclude_deck OFP$DISPLAY_SITE_VED_NAMES        status=BUILD_D721_NEW_DECKS_STATUS
 exclude_deck RAP$DISPLAY_SITE_VED_NAMES        status=BUILD_D721_NEW_DECKS_STATUS
*DECK DECK=BUILD_D731 EXPAND=TRUE
*copyc BUILD_D732
*IF bev$product_level = 'BUILD_D731'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D731_contents
*IFEND
*DECK DECK=BUILD_D731_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D731_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D731_STATUS kind=status
IFEND
 exclude_feature nv04319                         status=BUILD_D731_STATUS
 exclude_feature nv09741                         status=BUILD_D731_STATUS
 exclude_feature nv10408                         status=BUILD_D731_STATUS
 exclude_feature $program_attributes             status=BUILD_D731_STATUS
*DECK DECK=BUILD_D731_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D732_NEW_DECKS
*IF bev$product_level = 'BUILD_D731_NEW_DECKS'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D731_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D731_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D731_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D731_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck PMM$PROGRAM_ATTRIBUTES            status=BUILD_D731_NEW_DECKS_STATUS
 exclude_deck PMM$PROGRAM_ATTRIBUTES_FD         status=BUILD_D731_NEW_DECKS_STATUS
 exclude_deck PUT$FILE_DISPLAY_INFO             status=BUILD_D731_NEW_DECKS_STATUS
 exclude_deck PUV$DISPLAY_EXCLUDED_ITEMS        status=BUILD_D731_NEW_DECKS_STATUS
*DECK DECK=BUILD_D732 EXPAND=TRUE
*copyc BUILD_D733
*IF bev$product_level = 'BUILD_D732'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D732_contents
*IFEND
*DECK DECK=BUILD_D732_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D732_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D732_STATUS kind=status
IFEND
 exclude_feature cilb402                         status=BUILD_D732_STATUS
 exclude_feature nv10385                         status=BUILD_D732_STATUS
 exclude_feature nv10423                         status=BUILD_D732_STATUS
 exclude_feature nv10426                         status=BUILD_D732_STATUS
 exclude_feature rf_repackage_151                status=BUILD_D732_STATUS
*DECK DECK=BUILD_D732_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D733_NEW_DECKS
*IF bev$product_level = 'BUILD_D732_NEW_DECKS'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D732_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D732_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D732_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D732_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck RFH$CHANGE_ATTRIBUTES             status=BUILD_D732_NEW_DECKS_STATUS
 exclude_deck RFH$FETCH                         status=BUILD_D732_NEW_DECKS_STATUS
 exclude_deck RFH$GET_ATTRIBUTES                status=BUILD_D732_NEW_DECKS_STATUS
 exclude_deck RFH$STORE                         status=BUILD_D732_NEW_DECKS_STATUS
*DECK DECK=BUILD_D733 EXPAND=TRUE
*copyc BUILD_D741
*IF bev$product_level = 'BUILD_D733'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D733_contents
*IFEND
*DECK DECK=BUILD_D733_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D733_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D741_NEW_DECKS
*IF bev$product_level = 'BUILD_D733_NEW_DECKS'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D733_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D733_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D741 EXPAND=TRUE
*copyc BUILD_D742
*IF bev$product_level = 'BUILD_D741'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D741_contents
*IFEND
*DECK DECK=BUILD_D741_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D741_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D741_STATUS kind=status
IFEND
 exclude_feature $program_attributes_fix         status=BUILD_D741_STATUS
 exclude_feature display_station_ers_changes     status=BUILD_D741_STATUS
 exclude_feature fix_scl_problem_in_ra_decks     status=BUILD_D741_STATUS
 exclude_feature marben_24e_port_repairs_2_os    status=BUILD_D741_STATUS
 exclude_feature nv0s580_a                       status=BUILD_D741_STATUS
 exclude_feature nv0v686                         status=BUILD_D741_STATUS
 exclude_feature nv10429                         status=BUILD_D741_STATUS
 exclude_feature nv10432                         status=BUILD_D741_STATUS
 exclude_feature nv10433                         status=BUILD_D741_STATUS
 exclude_feature nv10417                         status=BUILD_D741_STATUS
*DECK DECK=BUILD_D741_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D742_NEW_DECKS
*IF bev$product_level = 'BUILD_D741_NEW_DECKS'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D741_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D741_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D742 EXPAND=TRUE
*copyc BUILD_D743
*IF bev$product_level = 'BUILD_D742'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D742_contents
*IFEND
*DECK DECK=BUILD_D742_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D742_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D743_NEW_DECKS
*IF bev$product_level = 'BUILD_D742_NEW_DECKS'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D742_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D742_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D743 EXPAND=TRUE
*copyc BUILD_D744
*IF bev$product_level = 'BUILD_D743'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D743_contents
*IFEND
*DECK DECK=BUILD_D743_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D743_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D743_STATUS kind=status
IFEND
 exclude_feature nv10417_1                       status=BUILD_D743_STATUS
*DECK DECK=BUILD_D743_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D744_NEW_DECKS
*IF bev$product_level = 'BUILD_D743_NEW_DECKS'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D743_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D743_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D744 EXPAND=TRUE
*copyc BUILD_D745
*IF bev$product_level = 'BUILD_D744'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D744_contents
*IFEND
*DECK DECK=BUILD_D744_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D744_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D745_NEW_DECKS
*IF bev$product_level = 'BUILD_D744_NEW_DECKS'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D744_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D744_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D745 EXPAND=TRUE
*copyc BUILD_D746
*IF bev$product_level = 'BUILD_D745'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D745_contents
*IFEND
*DECK DECK=BUILD_D745_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D745_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D746_NEW_DECKS
*IF bev$product_level = 'BUILD_D745_NEW_DECKS'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D745_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D745_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D746 EXPAND=TRUE
*copyc BUILD_D901
*IF bev$product_level = 'BUILD_D746'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D746_contents
*IFEND
*DECK DECK=BUILD_D746_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D746_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D901_NEW_DECKS
*IF bev$product_level = 'BUILD_D746_NEW_DECKS'
*copyc cycleD7_exceptions
*ELSE
*copyc BUILD_D746_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D746_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D901 EXPAND=TRUE
*copyc BUILD_D902
*IF bev$product_level = 'BUILD_D901'
*copyc BUILD_D746_contents
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D901_contents
*IFEND
*DECK DECK=BUILD_D901_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D901_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D901_STATUS kind=status
IFEND
 exclude_feature default_system_file_attributes  status=BUILD_D901_STATUS
 exclude_feature lislf                           status=BUILD_D901_STATUS
 exclude_feature nv0v700                         status=BUILD_D901_STATUS
 exclude_feature nv10353                         status=BUILD_D901_STATUS
*DECK DECK=BUILD_D901_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D902_NEW_DECKS
*IF bev$product_level = 'BUILD_D901_NEW_DECKS'
*copyc BUILD_D746_NEW_DECKS_contents
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D901_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D901_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D901_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D901_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck RAM$LIST_LEGIBLE_FILES            status=BUILD_D901_NEW_DECKS_STATUS
*DECK DECK=BUILD_D902 EXPAND=TRUE
*copyc BUILD_D905
*IF bev$product_level = 'BUILD_D902'
*copyc BUILD_D746_contents
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D902_contents
*IFEND
*DECK DECK=BUILD_D902_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D902_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D905_NEW_DECKS
*IF bev$product_level = 'BUILD_D902_NEW_DECKS'
*copyc BUILD_D746_NEW_DECKS_contents
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D902_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D902_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D905 EXPAND=TRUE
*copyc BUILD_D911
*IF bev$product_level = 'BUILD_D905'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D905_contents
*IFEND
*DECK DECK=BUILD_D905_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D905_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D905_STATUS kind=status
IFEND
 exclude_feature fix_default_sfa_code            status=BUILD_D905_STATUS
 exclude_feature nv0v695                         status=BUILD_D905_STATUS
 exclude_feature nv10450                         status=BUILD_D905_STATUS
 exclude_feature offline_command_libraries       status=BUILD_D905_STATUS
*DECK DECK=BUILD_D905_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D911_NEW_DECKS
*IF bev$product_level = 'BUILD_D905_NEW_DECKS'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D905_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D905_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D911 EXPAND=TRUE
*copyc BUILD_D916
*IF bev$product_level = 'BUILD_D911'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D911_contents
*IFEND
*DECK DECK=BUILD_D911_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D911_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D911_STATUS kind=status
IFEND
 exclude_feature nv0v682                         status=BUILD_D911_STATUS
 exclude_feature nv10440                         status=BUILD_D911_STATUS
 exclude_feature nv10455                         status=BUILD_D911_STATUS
 exclude_feature nv10435                         status=BUILD_D911_STATUS
*DECK DECK=BUILD_D911_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D916_NEW_DECKS
*IF bev$product_level = 'BUILD_D911_NEW_DECKS'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D911_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D911_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D911_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D911_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CMP$CHECK_LCU_LOCK_SET            status=BUILD_D911_NEW_DECKS_STATUS
 exclude_deck CMP$LCU_LOCK_SET_BY_JOB           status=BUILD_D911_NEW_DECKS_STATUS
 exclude_deck MMV$AVAIL_MODIFIED_QUEUE_MAX      status=BUILD_D911_NEW_DECKS_STATUS
*DECK DECK=BUILD_D916 EXPAND=TRUE
*copyc BUILD_D921
*IF bev$product_level = 'BUILD_D916'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D916_contents
*IFEND
*DECK DECK=BUILD_D916_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D916_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D916_STATUS kind=status
IFEND
 exclude_feature default_sfa_code_fix2           status=BUILD_D916_STATUS
 exclude_feature report_disk_fragmentation       status=BUILD_D916_STATUS
*DECK DECK=BUILD_D916_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D921_NEW_DECKS
*IF bev$product_level = 'BUILD_D916_NEW_DECKS'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D916_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D916_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D921 EXPAND=TRUE
*copyc BUILD_D923
*IF bev$product_level = 'BUILD_D921'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D921_contents
*IFEND
*DECK DECK=BUILD_D921_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D921_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D921_STATUS kind=status
IFEND
 exclude_feature $pa_fix                         status=BUILD_D921_STATUS
 exclude_feature fsp$create_file_null_attributes status=BUILD_D921_STATUS
 exclude_feature mv20736                         status=BUILD_D921_STATUS
 exclude_feature nv09870                         status=BUILD_D921_STATUS
 exclude_feature nv10456                         status=BUILD_D921_STATUS
 exclude_feature report_disk_fragmentation_1     status=BUILD_D921_STATUS
*DECK DECK=BUILD_D921_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D923_NEW_DECKS
*IF bev$product_level = 'BUILD_D921_NEW_DECKS'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D921_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D921_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D921_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D921_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck MTV$RESET_ALL_CACHE_NOW           status=BUILD_D921_NEW_DECKS_STATUS
*DECK DECK=BUILD_D923 EXPAND=TRUE
*copyc BUILD_D925
*IF bev$product_level = 'BUILD_D923'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D923_contents
*IFEND
*DECK DECK=BUILD_D923_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D923_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D925_NEW_DECKS
*IF bev$product_level = 'BUILD_D923_NEW_DECKS'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D923_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D923_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D925 EXPAND=TRUE
*copyc BUILD_D931
*IF bev$product_level = 'BUILD_D925'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D925_contents
*IFEND
*DECK DECK=BUILD_D925_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D925_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D931_NEW_DECKS
*IF bev$product_level = 'BUILD_D925_NEW_DECKS'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D925_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D925_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D931 EXPAND=TRUE
*copyc BUILD_D935
*IF bev$product_level = 'BUILD_D931'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D931_contents
*IFEND
*DECK DECK=BUILD_D931_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D931_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D931_STATUS kind=status
IFEND
 exclude_feature ac12180_os                      status=BUILD_D931_STATUS
 exclude_feature fides_performance_2             status=BUILD_D931_STATUS
 exclude_feature nv10466                         status=BUILD_D931_STATUS
 exclude_feature nv10468                         status=BUILD_D931_STATUS
*DECK DECK=BUILD_D931_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D935_NEW_DECKS
*IF bev$product_level = 'BUILD_D931_NEW_DECKS'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D931_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D931_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D931_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D931_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck IOV$ENFORCE_READ_PRIORITY         status=BUILD_D931_NEW_DECKS_STATUS
 exclude_deck MMV$TIME_TO_CALL_QUICK_SWEEP      status=BUILD_D931_NEW_DECKS_STATUS
*DECK DECK=BUILD_D935 EXPAND=TRUE
*copyc BUILD_D936
*IF bev$product_level = 'BUILD_D935'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D935_contents
*IFEND
*DECK DECK=BUILD_D935_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D935_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D936_NEW_DECKS
*IF bev$product_level = 'BUILD_D935_NEW_DECKS'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D935_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D935_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D936 EXPAND=TRUE
*copyc BUILD_D937
*IF bev$product_level = 'BUILD_D936'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D936_contents
*IFEND
*DECK DECK=BUILD_D936_CONTENTS EXPAND=TRUE
IF $variable(BUILD_D936_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D936_STATUS kind=status
IFEND
 exclude_feature fides_performance_3             status=BUILD_D936_STATUS
*DECK DECK=BUILD_D936_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D937_NEW_DECKS
*IF bev$product_level = 'BUILD_D936_NEW_DECKS'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D936_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D936_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D937 EXPAND=TRUE
*copyc BUILD_D939
*IF bev$product_level = 'BUILD_D937'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D937_contents
*IFEND
*DECK DECK=BUILD_D937_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D937_NEW_DECKS EXPAND=TRUE
*copyc BUILD_D939_NEW_DECKS
*IF bev$product_level = 'BUILD_D937_NEW_DECKS'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D937_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D937_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D939 EXPAND=TRUE
*copyc BUILD_E101
*IF bev$product_level = 'BUILD_D939'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D939_contents
*IFEND
*DECK DECK=BUILD_D939_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_D939_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E101_NEW_DECKS
*IF bev$product_level = 'BUILD_D939_NEW_DECKS'
*copyc cycleD9_exceptions
*ELSE
*copyc BUILD_D939_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_D939_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E101 EXPAND=TRUE
*copyc BUILD_E105
*IF bev$product_level = 'BUILD_E101'
*copyc cycleE1_exceptions
*ELSE
*copyc BUILD_E101_contents
*IFEND
*DECK DECK=BUILD_E101_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E101_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E101_STATUS kind=status
IFEND
 exclude_feature nv0v713                         status=BUILD_E101_STATUS
 exclude_feature sc80499_os                      status=BUILD_E101_STATUS
*DECK DECK=BUILD_E101_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E105_NEW_DECKS
*IF bev$product_level = 'BUILD_E101_NEW_DECKS'
*copyc cycleE1_exceptions
*ELSE
*copyc BUILD_E101_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E101_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E105 EXPAND=TRUE
*copyc BUILD_E111
*IF bev$product_level = 'BUILD_E105'
*copyc cycleE1_exceptions
*ELSE
*copyc BUILD_E105_contents
*IFEND
*DECK DECK=BUILD_E105_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E105_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E105_STATUS kind=status
IFEND
 exclude_feature nv10471                         status=BUILD_E105_STATUS
*DECK DECK=BUILD_E105_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E111_NEW_DECKS
*IF bev$product_level = 'BUILD_E105_NEW_DECKS'
*copyc cycleE1_exceptions
*ELSE
*copyc BUILD_E105_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E105_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E111 EXPAND=TRUE
*copyc BUILD_E121
*IF bev$product_level = 'BUILD_E111'
*copyc cycleE1_exceptions
*ELSE
*copyc BUILD_E111_contents
*IFEND
*DECK DECK=BUILD_E111_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E111_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E111_STATUS kind=status
IFEND
 exclude_feature ar20593_os                      status=BUILD_E111_STATUS
 exclude_feature nv10479                         status=BUILD_E111_STATUS
 exclude_feature nv10480                         status=BUILD_E111_STATUS
 exclude_feature nv10482                         status=BUILD_E111_STATUS
 exclude_feature year_2000_os                    status=BUILD_E111_STATUS
 exclude_feature nv10479_fix                     status=BUILD_E111_STATUS
*DECK DECK=BUILD_E111_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E121_NEW_DECKS
*IF bev$product_level = 'BUILD_E111_NEW_DECKS'
*copyc cycleE1_exceptions
*ELSE
*copyc BUILD_E111_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E111_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E111_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E111_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck RAP$ACTIVATE_ARCHIVE_VE           status=BUILD_E111_NEW_DECKS_STATUS
 exclude_deck RAP$DEACTIVATE_ARCHIVE_VE         status=BUILD_E111_NEW_DECKS_STATUS
*DECK DECK=BUILD_E121 EXPAND=TRUE
*copyc BUILD_E125
*IF bev$product_level = 'BUILD_E121'
*copyc cycleE1_exceptions
*ELSE
*copyc BUILD_E121_contents
*IFEND
*DECK DECK=BUILD_E121_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E121_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E121_STATUS kind=status
IFEND
 exclude_feature nv10454                         status=BUILD_E121_STATUS
 exclude_feature nv10478                         status=BUILD_E121_STATUS
 exclude_feature year_2000_os_1                  status=BUILD_E121_STATUS
*DECK DECK=BUILD_E121_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E125_NEW_DECKS
*IF bev$product_level = 'BUILD_E121_NEW_DECKS'
*copyc cycleE1_exceptions
*ELSE
*copyc BUILD_E121_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E121_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E125 EXPAND=TRUE
*copyc BUILD_E131
*IF bev$product_level = 'BUILD_E125'
*copyc cycleE1_exceptions
*ELSE
*copyc BUILD_E125_contents
*IFEND
*DECK DECK=BUILD_E125_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E125_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E131_NEW_DECKS
*IF bev$product_level = 'BUILD_E125_NEW_DECKS'
*copyc cycleE1_exceptions
*ELSE
*copyc BUILD_E125_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E125_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E131 EXPAND=TRUE
*copyc BUILD_E133
*IF bev$product_level = 'BUILD_E131'
*copyc cycleE1_exceptions
*ELSE
*copyc BUILD_E131_contents
*IFEND
*DECK DECK=BUILD_E131_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E131_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E131_STATUS kind=status
IFEND
 exclude_feature nv10483                         status=BUILD_E131_STATUS
 exclude_feature nv10486                         status=BUILD_E131_STATUS
*DECK DECK=BUILD_E131_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E133_NEW_DECKS
*IF bev$product_level = 'BUILD_E131_NEW_DECKS'
*copyc cycleE1_exceptions
*ELSE
*copyc BUILD_E131_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E131_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E133 EXPAND=TRUE
*copyc BUILD_E141
*IF bev$product_level = 'BUILD_E133'
*copyc cycleE1_exceptions
*ELSE
*copyc BUILD_E133_contents
*IFEND
*DECK DECK=BUILD_E133_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E133_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E141_NEW_DECKS
*IF bev$product_level = 'BUILD_E133_NEW_DECKS'
*copyc cycleE1_exceptions
*ELSE
*copyc BUILD_E133_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E133_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E141 EXPAND=TRUE
*copyc BUILD_E201
*IF bev$product_level = 'BUILD_E141'
*copyc cycleE1_exceptions
*ELSE
*copyc BUILD_E141_contents
*IFEND
*DECK DECK=BUILD_E141_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E141_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E141_STATUS kind=status
IFEND
 exclude_feature year_2000_os_2                  status=BUILD_E141_STATUS
*DECK DECK=BUILD_E141_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E201_NEW_DECKS
*IF bev$product_level = 'BUILD_E141_NEW_DECKS'
*copyc cycleE1_exceptions
*ELSE
*copyc BUILD_E141_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E141_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E172 EXPAND=TRUE
*IF bev$product_level = 'BUILD_E133 '
*copyc BUILD_E133
*IFEND
IF $variable(build_e172_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_e172_status kind=status
IFEND
 include_feature year_2000_os_2                  status=build_e172_status
*DECK DECK=BUILD_E173 EXPAND=TRUE
*IF bev$product_level = 'BUILD_E141 '
*copyc BUILD_E141
*IFEND
IF $variable(build_e173_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_e173_status kind=status
IFEND
 include_feature year_2000_os_2                  status=build_e173_status
*DECK DECK=BUILD_E182 EXPAND=TRUE
*IF bev$product_level = 'BUILD_E133 '
*copyc BUILD_E133
*IFEND
IF $variable(build_e182_status, declared) = 'UNKNOWN' THEN
  create_variable name=build_e182_status kind=status
IFEND
 include_feature year_2000_os_2                  status=build_e182_status
*DECK DECK=BUILD_E201 EXPAND=TRUE
*copyc BUILD_E205
*IF bev$product_level = 'BUILD_E201'
*copyc cycleE2_exceptions
*ELSE
*copyc BUILD_E201_contents
*IFEND
*DECK DECK=BUILD_E201_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E201_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E201_STATUS kind=status
IFEND
 exclude_feature fsp$validate_file_identifier    status=BUILD_E201_STATUS
 exclude_feature nv10490                         status=BUILD_E201_STATUS
 exclude_feature nv10513                         status=BUILD_E201_STATUS
*DECK DECK=BUILD_E201_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E205_NEW_DECKS
*IF bev$product_level = 'BUILD_E201_NEW_DECKS'
*copyc cycleE2_exceptions
*ELSE
*copyc BUILD_E201_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E201_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E201_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E201_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck FSH$VALIDATE_FILE_IDENTIFIER      status=BUILD_E201_NEW_DECKS_STATUS
 exclude_deck FSM$VALIDATE_FILE_IDENTIFIER      status=BUILD_E201_NEW_DECKS_STATUS
 exclude_deck FSP$VALIDATE_FILE_IDENTIFIER      status=BUILD_E201_NEW_DECKS_STATUS
*DECK DECK=BUILD_E205 EXPAND=TRUE
*copyc BUILD_E221
*IF bev$product_level = 'BUILD_E205'
*copyc cycleE2_exceptions
*ELSE
*copyc BUILD_E205_contents
*IFEND
*DECK DECK=BUILD_E205_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E205_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E205_STATUS kind=status
IFEND
 exclude_feature fix_pewter_open_usage_config    status=BUILD_E205_STATUS
 exclude_feature cartridge_tape_830              status=BUILD_E205_STATUS
*DECK DECK=BUILD_E205_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E221_NEW_DECKS
*IF bev$product_level = 'BUILD_E205_NEW_DECKS'
*copyc cycleE2_exceptions
*ELSE
*copyc BUILD_E205_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E205_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E221 EXPAND=TRUE
*copyc BUILD_E223
*IF bev$product_level = 'BUILD_E221'
*copyc cycleE2_exceptions
*ELSE
*copyc BUILD_E221_contents
*IFEND
*DECK DECK=BUILD_E221_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E221_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E221_STATUS kind=status
IFEND
 exclude_feature backup_archive_attr_os          status=BUILD_E221_STATUS
 exclude_feature gray_open_usage                 status=BUILD_E221_STATUS
 exclude_feature nv10490_fix                     status=BUILD_E221_STATUS
 exclude_feature backup_archive_attr_os_fix_1    status=BUILD_E221_STATUS
 exclude_feature backup_archive_attr_os_fix_2    status=BUILD_E221_STATUS
 exclude_feature backup_archive_attr_os_fix_3    status=BUILD_E221_STATUS
*DECK DECK=BUILD_E221_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E223_NEW_DECKS
*IF bev$product_level = 'BUILD_E221_NEW_DECKS'
*copyc cycleE2_exceptions
*ELSE
*copyc BUILD_E221_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E221_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E221_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E221_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck CLH$VERIFY_TIME_INCREMENT         status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck CLP$VERIFY_TIME_INCREMENT         status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck FSC$MAX_FILE_CHANGE               status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck FSH$CHANGE_FILE                   status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck FSP$CHANGE_FILE                   status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck FST$FILE_CHANGE                   status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck FST$FILE_CHANGES                  status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck FST$FILE_CHANGE_CHOICES           status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck FST$RETENTION                     status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck FST$RETENTION_ATTRIBUTE_TYPE      status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PFC$NULL_SITE_ARCHIVE_OPTION      status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PFC$NULL_SITE_BACKUP_OPTION       status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PFC$NULL_SITE_RELEASE_OPTION      status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PFH$VALIDATE_SITE_OPTIONS         status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PFP$CONVERT_FS_RETENTION_TO_INT   status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PFP$R2_CHANGE_FILE                status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PFP$R2_DF_CLIENT_CHANGE_FILE      status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PFP$R3_CHANGE_FILE                status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PFP$VALIDATE_SITE_OPTIONS         status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PFP$VERIFY_ADMIN_RETRIEVAL        status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PFT$DF_CHANGE_FILE_IN             status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PFT$DF_CHANGE_FILE_OUT            status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PFT$RETRIEVE_OPTION               status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PFT$SITE_ARCHIVE_OPTION           status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PFT$SITE_BACKUP_OPTION            status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PFT$SITE_RELEASE_OPTION           status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PUP$CHECK_SITE_BACKUP_OPTIONS     status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PUT$EXCLUDE_SITE_BACKUP_OPTIONS   status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck PUV$EXCLUDE_SITE_BACKUP_OPTIONS   status=BUILD_E221_NEW_DECKS_STATUS
 exclude_deck RAI$PROLOG_GRAY_OPEN_USAGE        status=BUILD_E221_NEW_DECKS_STATUS
*DECK DECK=BUILD_E223 EXPAND=TRUE
*copyc BUILD_E231
*IF bev$product_level = 'BUILD_E223'
*copyc cycleE2_exceptions
*ELSE
*copyc BUILD_E223_contents
*IFEND
*DECK DECK=BUILD_E223_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E223_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E231_NEW_DECKS
*IF bev$product_level = 'BUILD_E223_NEW_DECKS'
*copyc cycleE2_exceptions
*ELSE
*copyc BUILD_E223_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E223_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E231 EXPAND=TRUE
*copyc BUILD_E232
*IF bev$product_level = 'BUILD_E231'
*copyc cycleE2_exceptions
*ELSE
*copyc BUILD_E231_contents
*IFEND
*DECK DECK=BUILD_E231_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E231_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E231_STATUS kind=status
IFEND
 exclude_feature backup_archive_attr_os_fix_4    status=BUILD_E231_STATUS
 exclude_feature backup_archive_attr_os_fix_5    status=BUILD_E231_STATUS
*DECK DECK=BUILD_E231_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E232_NEW_DECKS
*IF bev$product_level = 'BUILD_E231_NEW_DECKS'
*copyc cycleE2_exceptions
*ELSE
*copyc BUILD_E231_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E231_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E232 EXPAND=TRUE
*copyc BUILD_E411
*IF bev$product_level = 'BUILD_E232'
*copyc cycleE2_exceptions
*ELSE
*copyc BUILD_E232_contents
*IFEND
*DECK DECK=BUILD_E232_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E232_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E232_STATUS kind=status
IFEND
 exclude_feature backup_archive_attr_os_fix_6    status=BUILD_E232_STATUS
 exclude_feature backup_archive_attr_os_fix_7    status=BUILD_E232_STATUS
*DECK DECK=BUILD_E232_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E411_NEW_DECKS
*IF bev$product_level = 'BUILD_E232_NEW_DECKS'
*copyc cycleE2_exceptions
*ELSE
*copyc BUILD_E232_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E232_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E411 EXPAND=TRUE
*copyc BUILD_E421
*IF bev$product_level = 'BUILD_E411'
*copyc cycleE4_exceptions
*ELSE
*copyc BUILD_E411_contents
*IFEND
*DECK DECK=BUILD_E411_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E411_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E411_STATUS kind=status
IFEND
 exclude_feature add_report_files                status=BUILD_E411_STATUS
*DECK DECK=BUILD_E411_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E421_NEW_DECKS
*IF bev$product_level = 'BUILD_E411_NEW_DECKS'
*copyc cycleE4_exceptions
*ELSE
*copyc BUILD_E411_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E411_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E411_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E411_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck FIP#ARRAY_UPPER_BOUND_IN_SEQ      status=BUILD_E411_NEW_DECKS_STATUS
 exclude_deck FIP#CREATE_SCRATCH_SEQUENCE       status=BUILD_E411_NEW_DECKS_STATUS
 exclude_deck FIP#MOVE                          status=BUILD_E411_NEW_DECKS_STATUS
 exclude_deck FIT#SEQUENCE_CONVERTER            status=BUILD_E411_NEW_DECKS_STATUS
 exclude_deck FMT#FILE_ATTRIBUTE_KEYS_SET       status=BUILD_E411_NEW_DECKS_STATUS
 exclude_deck FSM#EXPAND_FILE_LABEL             status=BUILD_E411_NEW_DECKS_STATUS
 exclude_deck FSP#EXPAND_FILE_LABEL             status=BUILD_E411_NEW_DECKS_STATUS
 exclude_deck REPORT_FILES                      status=BUILD_E411_NEW_DECKS_STATUS
 exclude_deck USD#REPORT_FILES                  status=BUILD_E411_NEW_DECKS_STATUS
 exclude_deck USM#REPORT_FILES                  status=BUILD_E411_NEW_DECKS_STATUS
*DECK DECK=BUILD_E421 EXPAND=TRUE
*copyc BUILD_E425
*IF bev$product_level = 'BUILD_E421'
*copyc cycleE4_exceptions
*ELSE
*copyc BUILD_E421_contents
*IFEND
*DECK DECK=BUILD_E421_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E421_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E421_STATUS kind=status
IFEND
 exclude_feature fides_loop                      status=BUILD_E421_STATUS
 exclude_feature fides_performance_4             status=BUILD_E421_STATUS
 exclude_feature nv10518                         status=BUILD_E421_STATUS
 exclude_feature nv10535                         status=BUILD_E421_STATUS
 exclude_feature nv10536_4                       status=BUILD_E421_STATUS
*DECK DECK=BUILD_E421_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E425_NEW_DECKS
*IF bev$product_level = 'BUILD_E421_NEW_DECKS'
*copyc cycleE4_exceptions
*ELSE
*copyc BUILD_E421_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E421_NEW_DECKS_CONTENTS EXPAND=TRUE
IF $variable(BUILD_E421_NEW_DECKS_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_E421_NEW_DECKS_STATUS kind=status
IFEND
 exclude_deck IOT$TAPE_TRACK                    status=BUILD_E421_NEW_DECKS_STATUS
 exclude_deck IOT$VSN                           status=BUILD_E421_NEW_DECKS_STATUS
 exclude_deck OFM$IO_SUMMARY_DISPLAY            status=BUILD_E421_NEW_DECKS_STATUS
 exclude_deck OFM$SPECIAL_STATISTICS_DISPLAY    status=BUILD_E421_NEW_DECKS_STATUS
 exclude_deck OFP$IO_SUMMARY_DISPLAY            status=BUILD_E421_NEW_DECKS_STATUS
 exclude_deck OFP$SPECIAL_STATISTICS_DISPLAY    status=BUILD_E421_NEW_DECKS_STATUS
 exclude_deck OSM$FETCH_SPECIAL_STATISTICS      status=BUILD_E421_NEW_DECKS_STATUS
*DECK DECK=BUILD_E425 EXPAND=TRUE
*copyc BUILD_E431
*IF bev$product_level = 'BUILD_E425'
*copyc cycleE4_exceptions
*ELSE
*copyc BUILD_E425_contents
*IFEND
*DECK DECK=BUILD_E425_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E425_NEW_DECKS EXPAND=TRUE
*copyc BUILD_E431_NEW_DECKS
*IF bev$product_level = 'BUILD_E425_NEW_DECKS'
*copyc cycleE4_exceptions
*ELSE
*copyc BUILD_E425_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E425_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E431 EXPAND=TRUE
*IF bev$product_level = 'BUILD_E431'
*copyc cycleE4_exceptions
*ELSE
*copyc BUILD_E431_contents
*IFEND
*DECK DECK=BUILD_E431_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E431_NEW_DECKS EXPAND=TRUE
*IF bev$product_level = 'BUILD_E431_NEW_DECKS'
*copyc cycleE4_exceptions
*ELSE
*copyc BUILD_E431_NEW_DECKS_contents
*IFEND
*DECK DECK=BUILD_E431_NEW_DECKS_CONTENTS EXPAND=TRUE
*DECK DECK=BUILD_E475 EXPAND=TRUE
*IF bev$product_level = 'BUILD_E421 '
*copyc BUILD_E421
*IFEND
*DECK DECK=CAM$TERMINATE_MASSTOR EXPAND=TRUE

?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? TITLE := 'NOS/VE MASSTOR assist' ??
?? NEWTITLE := '  Module Header', EJECT ??
MODULE cam$terminate_masstor;
{
{  PURPOSE: This module contains the code to support MASSTOR shutdown.
{
{
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmt$name
*copyc ost$system_flag
*copyc oss$mainframe_paged_literal
*copyc oss$task_private
*copyc cap$change_termination_priority
*copyc clp$include_line
*copyc jmp$job_exists
*copyc osp$verify_system_privilege
*copyc pmp$cause_task_condition
*copyc pmp$get_executing_task_gtid_r6
*copyc pmp$get_time
*copyc pmp$log
*copyc pmp$long_term_wait
*copyc pmp$wait
*copyc jmt$job_state_set
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc syt$180_idle_code

?? POP ??




  PROCEDURE [XDCL] cap$prepare_for_idle_system (
        idle_code: syt$180_idle_code;
    VAR status: ost$status);

    VAR
      masstor_job_name: string (6),
      job_state: jmt$job_state_set,
      job_exists: boolean,
      local_status: ost$status;




     osp$verify_system_privilege;
     status.normal := TRUE;
     masstor_job_name := 'CAS$EX';
     job_state := $jmt$job_state_set [jmc$initiated_job, jmc$terminating_job];

     jmp$job_exists (masstor_job_name, job_state, job_exists, local_status);


      IF NOT job_exists THEN
         RETURN;
      IFEND;

     CASE idle_code OF
   = syc$ic_idle_command, syc$ic_system_terminated =

     { call the shutdown if masstor is up }
      clp$include_line ('$system.osf$operator_command_library.deactivate_cartridge_storage',
         TRUE, osc$null_name, status);

      cap$change_termination_priority (masstor_job_name, status);

      jmp$job_exists (masstor_job_name, job_state, job_exists, local_status);

      WHILE job_exists DO
        pmp$wait (5000, 5000);
        jmp$job_exists (masstor_job_name, job_state, job_exists, local_status);
      WHILEND;




   = syc$ic_hardware_idle, syc$ic_long_power =

     { do nothing yet for these cases }

     ELSE

     CASEND;



  PROCEND cap$prepare_for_idle_system;



MODEND cam$terminate_masstor;
*DECK DECK=CAM$TERMINATE_MASSTOR_23D EXPAND=TRUE


?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? TITLE := 'NOS/VE MASSTOR assist' ??
?? NEWTITLE := '  Module Header', EJECT ??
MODULE cam$terminate_masstor_23d;
{
{  PURPOSE: This module contains the code to support MASSTOR shutdown.
{
{
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmt$name
*copyc ost$system_flag
*copyc oss$mainframe_paged_literal
*copyc oss$task_private
*copyc clp$include_line
*copyc jmp$job_exists
*copyc jmp$get_job_ijl_ordinal
*copyc jmp$queue_operator_request
*copyc osp$verify_system_privilege
*copyc pmp$cause_task_condition
*copyc pmp$get_executing_task_gtid_r6
*copyc pmp$get_time
*copyc pmp$log
*copyc pmp$long_term_wait
*copyc jmt$job_state_set
*copyc jmt$dispatching_priority
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc syt$180_idle_code

?? POP ??

  PROCEDURE [XDCL, #GATE] cap$change_termination_priority
    (    job_name: string (6);
     VAR status: ost$status);

    VAR
      ijl_ordinal: jmt$ijl_ordinal,
      privileged_job: boolean,
      priority: jmt$dispatching_priority,
      system_supplied_name: jmt$system_supplied_name;

    status.normal := TRUE;
    privileged_job := TRUE;
    priority := jmc$priority_p10;

    jmp$get_job_ijl_ordinal (job_name, privileged_job, ijl_ordinal, system_supplied_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

      jmp$queue_operator_request (jmc$or_change_dispatching_prio, ijl_ordinal, system_supplied_name,
            priority, {disable_recovery} FALSE, status);

  PROCEND cap$change_termination_priority;

MODEND cam$terminate_masstor_23d;
*DECK DECK=CAP$CHANGE_TERMINATION_PRIORITY EXPAND=FALSE

PROCEDURE [XREF] cap$change_termination_priority ( job_name: string(6);
VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc ost$status
?? POP ??
*DECK DECK=CAP$PREPARE_FOR_IDLE_SYSTEM EXPAND=FALSE
PROCEDURE [XREF] cap$prepare_for_idle_system ( idle_code:syt$180_idle_code;
VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc syt$180_idle_code
*copyc ost$status
?? POP ??
*DECK DECK=CFC$ERROR_CODES_FORMATTER_RANGE EXPAND=FALSE

  CONST
    cfc$min_ecc = (($INTEGER ('C') * 100(16)) + $INTEGER ('F')) * 1000000(16),
    cfc$max_ecc = cfc$min_ecc + 9999;
*DECK DECK=CFE$CYBIL_FORMAT_ERROR_CODES EXPAND=FALSE

{ common deck CFE$CYBIL_FORMAT_ERROR_CODES

*copyc cfc$error_codes_formatter_range

  CONST
    cfc$formatter_errors = cfc$min_ecc + 0;

  CONST
    cfe$input_output_same = cfc$formatter_errors + 0,
    {F Input and Output files are the same.

    cfe$unbalanced_block_structure = cfc$formatter_errors + 1,
    {W No matching +P for +P on line +P.

    cfe$unmatched_parens = cfc$formatter_errors + 2,
    {W Unmatched parenthesis on line +P: +N15 +P

    cfe$unmatched_brackets = cfc$formatter_errors + 3,
    {W Unmatched brackets on line +P: +N15 +P

    cfe$expecting_found_error = cfc$formatter_errors + 5,
    {W Expecting +P found +P on line +P: +N15 +P

    cfe$integer_range_error = cfc$formatter_errors + 6,
    {W Expecting +P <= integer value <= +P , found +P on line +P: +N15 +P

    cfe$line_too_long = cfc$formatter_errors + 7,
    {I Line +P is too long for current margin values. +N15 +P

    cfe$illegal_format_option = cfc$formatter_errors + 8,
    {F Undefined format option selected +P.

    cfe$tab_character_error = cfc$formatter_errors + 9,
    {W Length of tab character +P must be <= +P on line +P: +N15 +P

    cfe$unbalanced_range_mess = cfc$formatter_errors + 11,
    {W Unbalanced block structure -- possible +N15 +P missing for +P on line +P or
    {+N15 +P missing for +P on line +P.

    cfe$syntax_error = cfc$formatter_errors + 12,
    {W Syntax error -- identifier too long or unrecognized character on line +P:
    {+N15 +P

    cfe$token_too_long = cfc$formatter_errors + 13;
    {I Token +P +N15 on line +P is too long for current margin values. +N15 +P

  CONST
    cfc$formatter_global_base = cfc$min_ecc + 100,

    cfe$no_central_memory = cfc$formatter_global_base + 0;
    {F Insufficient central memory available.

  CONST
    cfc$formatter_state_base = cfc$min_ecc + 200,

    cfe$token_length_error = cfc$formatter_state_base + 0;
    {I Token beginning with +P on line +P is > +P characters. +N Token truncated
    {to +P characters.
*DECK DECK=CFM$MESSAGE_TEMPLATE_MODULE EXPAND=TRUE
MODULE cfm$message_template_module;
*copyc cfe$cybil_format_error_codes
MODEND cfm$message_template_module;
*DECK DECK=CHCQP EXPAND=TRUE
          IDENT  CHCQP,110B,CHCQP
          TITLE  CHCQP - CHANGE CP/QUEUE PRIORITY.
          ABS
          SST
          ENTRY  CHCQP
          ENTRY  RFL=
          SYSCOM B1
          ORG    120B
OPL XTEXT COMCMAC
OPL XTEXT COMCCPM
OPL XTEXT COMCSYS
 CHCQP    BSS    0
          SB1    1
          GETJO  ORIGIN
          SA1    ORIGIN
          SX2    SYOT
          BX3    X1-X2
          NZ     X3,DONE     IF NOT SYOT
          SETQP  7760B
          SETPR  31B
 DONE     ENDRUN
 ORIGIN   BSS    1
 RFL=     END
*DECK DECK=CLC$BEFORE_COMMAND_READ EXPAND=FALSE

  CONST
    clc$before_command_read = 'CLC$BEFORE_COMMAND_READ        ';

*DECK DECK=CLC$CHANGE_SECURE_LOGGING_NAME EXPAND=FALSE

  CONST
    clc$change_secure_logging_name = '* CHANGE_SECURE_LOGGING *';

*DECK DECK=CLC$COMMAND_CLEANUP_COMPLETED EXPAND=FALSE

  CONST
    clc$command_cleanup_completed = 'CLC$COMMAND_CLEANUP_COMPLETED  ';

*DECK DECK=CLC$COMPILING_FOR_TEST_HARNESS EXPAND=FALSE

  ?VAR
*IF ($variable(clv$test_harness, declared) = 'LOCAL') AND clv$test_harness
    clc$compiling_for_test_harness: boolean := TRUE ?;
*ELSE
    clc$compiling_for_test_harness: boolean := FALSE ?;
*IFEND

*DECK DECK=CLC$CONDITION_CODE_LIMITS EXPAND=FALSE

  CONST
    cll$min_scc = clc$min_ecc,
    cll$max_scc = clc$max_ecc;

*copyc clc$ecc_range

*DECK DECK=CLC$COPYRIGHT EXPAND=FALSE

  CONST
*PUT '    clc$copyright = '' Copyright Control Data Systems Inc. '//$STRING($NOW.YEAR)//''';'
*DECK DECK=CLC$DECLARATION_VERSION EXPAND=FALSE

  CONST
*IF NOT $true(osv$unix)
    clc$declaration_version = 1;
*ELSE
    clc$declaration_version = 2;
*IFEND

*DECK DECK=CLC$ECC_RANGE EXPAND=FALSE

  CONST
*IF NOT $true(osv$unix)
    clc$min_ecc = (($INTEGER('C')*100(16))+$INTEGER('L'))*1000000(16),
*ELSE
    clc$min_ecc = (($INTEGER('C')*100(16))+$INTEGER('L'))*10000(16),
*IFEND
    clc$max_ecc = clc$min_ecc + 9999;

*DECK DECK=CLC$EXITING_CONDITION EXPAND=FALSE

  CONST
    clc$exiting_condition = 'CLC$EXITING_CONDITION          ';

*DECK DECK=CLC$LEXICAL_UNITS_SIZE_PAD EXPAND=FALSE

{ The follwoing constant is used when allocating (usually PUSHing) space for
{ a work area in which to build a clt$lexical_units array.  It is added to
{ to the length of the text whoose units are to be identified in order to
{ ensure there will be room for the beginning and end of line units.

  CONST
    clc$lexical_units_size_pad = 2;

*DECK DECK=CLC$MAX_ARRAY_BOUND EXPAND=FALSE

  CONST
    clc$max_array_bound = 7fffffff(16);

*DECK DECK=CLC$MAX_COBOL_NAME_SIZE EXPAND=FALSE

  CONST
    clc$max_cobol_name_size = 30;

*DECK DECK=CLC$MAX_COMMAND_LINE_SIZE EXPAND=FALSE

  CONST
    clc$max_command_line_size = cyc$max_string_size;

*copyc cyc$max_string_size
*DECK DECK=CLC$MAX_COMMAND_TABLE_SIZE EXPAND=FALSE

  CONST
*IF NOT $true(osv$unix)
    clc$max_command_table_size = 7fffffff(16);
*ELSE
    clc$max_command_table_size = 7ffffffe(16);
*IFEND

*DECK DECK=CLC$MAX_DATE_TIME_FORM_STRING EXPAND=FALSE

  CONST
    clc$max_date_time_form_string = 255;

*DECK DECK=CLC$MAX_ESTABLISHED_HANDLERS EXPAND=FALSE

  CONST
    clc$max_established_handlers = 7fffffff(16);

*DECK DECK=CLC$MAX_EXPRESSION_TEXT_SIZE EXPAND=FALSE

  CONST
    clc$max_expression_text_size = clc$max_string_size;

*copyc clc$max_string_size
*DECK DECK=CLC$MAX_FIELDS EXPAND=FALSE

  CONST
    clc$max_fields = 7fffffff(16);

*DECK DECK=CLC$MAX_INTEGER EXPAND=FALSE

  CONST
    clc$max_integer = cyc$uppervalue_integer;

*copyc cyc$uppervalue_integer
*DECK DECK=CLC$MAX_KEYWORDS EXPAND=FALSE

  CONST
*IF NOT $true(osv$unix)
    clc$max_keywords = 7fffffff(16);
*ELSE
    clc$max_keywords = 7ffffffe(16);
*IFEND

*DECK DECK=CLC$MAX_LEXICAL_UNITS EXPAND=FALSE

  CONST
    clc$max_lexical_units = clc$max_string_size + 2;

*copyc clc$max_string_size
*DECK DECK=CLC$MAX_LIST_SIZE EXPAND=FALSE

  CONST
    clc$max_list_size = 7fffffff(16);

*DECK DECK=CLC$MAX_PARAMETERS EXPAND=FALSE

  CONST
*IF NOT $true(osv$unix)
    clc$max_parameters = 7fffffff(16);
*ELSE
    clc$max_parameters = 7ffffffe(16);
*IFEND

*DECK DECK=CLC$MAX_PARAMETER_LIST_SIZE EXPAND=FALSE

  CONST
    clc$max_parameter_list_size = clc$max_string_size;

*copyc clc$max_string_size
*DECK DECK=CLC$MAX_PARAMETER_NAMES EXPAND=FALSE

  CONST
*IF NOT $true(osv$unix)
    clc$max_parameter_names = 7fffffff(16);
*ELSE
    clc$max_parameter_names = 7ffffffe(16);
*IFEND

*DECK DECK=CLC$MAX_PROC_NAMES EXPAND=FALSE

  CONST
    clc$max_proc_names = 255;

*DECK DECK=CLC$MAX_PROMPT_SIZE EXPAND=FALSE

  CONST
    clc$max_prompt_size = clc$max_prompt_string_size - 3;

*copyc clc$max_prompt_string_size
*DECK DECK=CLC$MAX_PROMPT_STRING_SIZE EXPAND=FALSE

  CONST
    clc$max_prompt_string_size = ifc$max_prompt_string_size - 1;

*copyc ift$terminal_connection_types
*DECK DECK=CLC$MAX_REAL_EXPONENT_DIGITS EXPAND=FALSE

  CONST
    clc$max_real_exponent_digits = 4;

*DECK DECK=CLC$MAX_REAL_NUMBER_DIGITS EXPAND=FALSE

  CONST
    clc$max_real_number_digits = 28;

*DECK DECK=CLC$MAX_REAL_NUMBER_SIZE EXPAND=FALSE

  CONST
    clc$max_real_number_size = clc$max_real_number_digits +
          clc$max_real_exponent_digits + 4;

*copyc clc$max_real_exponent_digits
*copyc clc$max_real_number_digits
*DECK DECK=CLC$MAX_SCU_MODIFICATION_NAME EXPAND=FALSE

  CONST
    clc$max_scu_modification_name = 9;

*DECK DECK=CLC$MAX_SCU_SEQUENCE_NUMBER EXPAND=FALSE

  CONST
    clc$max_scu_sequence_number = 0ffffff(16);

*DECK DECK=CLC$MAX_STRING_SIZE EXPAND=FALSE

  CONST
    clc$max_string_size = cyc$max_string_size;

*copyc cyc$max_string_size
*DECK DECK=CLC$MAX_TYPE_SPECIFICATION_SIZE EXPAND=FALSE

  CONST
    clc$max_type_specification_size = 7fffffff(16);

*DECK DECK=CLC$MAX_UNION_MEMBERS EXPAND=FALSE

  CONST
    clc$max_union_members = 7fffffff(16);

*DECK DECK=CLC$MAX_VARIABLE_HASH_GROUPS EXPAND=FALSE

  CONST
    clc$max_variable_hash_groups = 13;

*DECK DECK=CLC$MIN_ARRAY_BOUND EXPAND=FALSE

  CONST
    clc$min_array_bound = -80000000(16);

*DECK DECK=CLC$MIN_INTEGER EXPAND=FALSE

  CONST
    clc$min_integer = cyc$lowervalue_integer;

*copyc cyc$lowervalue_integer
*DECK DECK=CLC$PAGE_WIDTHS EXPAND=FALSE

  CONST
    clc$narrow_page_width = 80,
    clc$wide_page_width = 132;

*DECK DECK=CLC$PROC_PDT_PARAMETER_LIMITS EXPAND=FALSE

  CONST
    clc$max_proc_pdt_param_names = clc$max_proc_pdt_parameters * 2,
    clc$max_proc_pdt_parameters = 100,
    clc$proc_pdt_info_area_size = 2000(16);

*DECK DECK=CLC$RESET_DEREFERENCE_NAME EXPAND=FALSE

  CONST
    clc$reset_dereference_name = 'CLC$RESET_DEREFERENCE_NAME     ';

*DECK DECK=CLC$STANDARD_FILE_NAMES EXPAND=FALSE

  CONST
    clc$current_command_input = '$COMMAND                       ',
    clc$echoed_commands = '$ECHO                          ',
    clc$error_output = '$ERRORS                        ',
    clc$job_command_input = 'COMMAND                        ',
    clc$job_command_response = '$RESPONSE                      ',
    clc$job_input = 'INPUT                          ',
    clc$job_log = '$JOB_LOG                       ',
    clc$job_output = 'OUTPUT                         ',
    clc$listing_output = '$LIST                          ',
    clc$null_file = '$NULL                          ',
    clc$proc_caller_command_input = '$COMMAND_OF_CALLER             ',
    clc$standard_input = '$INPUT                         ',
    clc$standard_output = '$OUTPUT                        ';

*DECK DECK=CLC$SYSTEM_LOGGING_ACTIVE_NAME EXPAND=FALSE

  CONST
    clc$system_logging_active_name = '* SYSTEM_LOGGING_ACTIVE *';

*DECK DECK=CLC$SYSTEM_MESSAGES_MODULE EXPAND=FALSE

{
{ The following constant defines the "seed" name for the help module
{ containing SCL's default parameter prompts and echo trace messages.
{

  CONST
    clc$system_messages_module = 'CLM$SYS_MESSAGES               ';

*DECK DECK=CLD$APPLICATION_VALUE_SCANNER EXPAND=FALSE

  TYPE
    clt$application_value_scanner = procedure
           (    value_name: clt$application_value_name;
                keyword_values: ^array [1 .. * ] of ost$name;
                text: string ( * );
            VAR value: clt$value;
            VAR status: ost$status);

  TYPE
    clt$av_scanner_kind = (clc$unspecified_av_scanner, clc$linked_av_scanner,
          clc$unlinked_av_scanner);

*copyc cld$value
*copyc clt$application_value
*copyc ost$name
*copyc ost$status
*DECK DECK=CLD$PARAMETER_LIMITS EXPAND=FALSE

  CONST
    clc$max_value_sets = 7fffffff(16),
    clc$max_values_per_set = 7fffffff(16),
    clc$max_keyword_values = 7fffffff(16);

*copyc clc$max_parameters
*copyc clc$max_parameter_names
*copyc clt$low_or_high
*DECK DECK=CLD$PARAMETER_LIST EXPAND=FALSE
*copyc clt$parameter_list
*copyc clt$parameter_list_contents
*DECK DECK=CLD$PATH_DESCRIPTION EXPAND=FALSE

  CONST
    clc$max_path_elements = clc$max_path_name_size DIV 2;

  TYPE
    clt$path_container = SEQ (REP clc$max_path_elements of pft$name);

  TYPE
    clt$open_position = record
      case specified: boolean of
      = TRUE =
        value: amt$open_position,
      = FALSE =
        ,
      casend,
    recend;

*copyc amt$open_position
*copyc clt$cycle_selector
*copyc clt$path_name
*copyc ost$string
*copyc pfd$permanent_file_definitions
*DECK DECK=CLD$PROC_DECLARATION EXPAND=FALSE
*copyc clc$max_proc_names
*copyc clt$name
*copyc clt$proc_input_procedure
*copyc clt$proc_input_type
*copyc clt$proc_names
*copyc clt$symbolic_parameters

*DECK DECK=CLD$VALUE EXPAND=FALSE

  TYPE
    clt$value = record
      descriptor: string (osc$max_name_size),
      case kind: clc$unknown_value .. clc$status_value of
      = clc$unknown_value =
        ,
      = clc$application_value =
        application: clt$application_value,
      = clc$variable_reference =
        var_ref: clt$variable_reference,
      = clc$string_value =
        str: ost$string,
      = clc$file_value =
        file: clt$file,
      = clc$name_value =
        name: clt$name,
      = clc$real_value =
        rnum: clt$real,
      = clc$integer_value =
        int: clt$integer,
      = clc$boolean_value =
        bool: clt$boolean,
      = clc$status_value =
        status: ost$status,
      casend,
    recend;

*copyc cld$variable_reference
*copyc clt$application_value
*copyc clt$boolean
*copyc clt$file
*copyc clt$integer
*copyc clt$name
*copyc clt$real
*copyc clt$value_kinds
*copyc ost$name
*copyc ost$status
*copyc ost$string
*DECK DECK=CLD$VARIABLE_REFERENCE EXPAND=FALSE

  TYPE
    clt$variable_reference = record
      reference: ost$string,
      lower_bound: clt$variable_dimension,
      upper_bound: clt$variable_dimension,
      value: clt$variable_value,
    recend;

  TYPE
    clt$variable_value = record
      descriptor: string (osc$max_name_size),
      case kind: clt$variable_kinds of
      = clc$string_value =
{ The max_string_size and string_value fields which follow should be
{ interpreted as though they were replaced by:
{       string_value: ^array [1 .. * ] of record
{         current_string_size: ost$string_size,
{         value: string ( * ),
{       recend,
{ where STRLENGTH(string_value^[i].value) = max_string_size
{   and string_value^[i].current_string_size <= max_string_size
        max_string_size: ost$string_size,
        string_value: ^array [1 .. * ] of cell,
      = clc$real_value =
        real_value: ^array [1 .. * ] of clt$real,
      = clc$integer_value =
        integer_value: ^array [1 .. * ] of clt$integer,
      = clc$boolean_value =
        boolean_value: ^array [1 .. * ] of clt$boolean,
      = clc$status_value =
{ Status variables are mapped to clt$status records rather than ost$status
{ records so that the individual fields of an SCL status variable can be
{ directly referenced as if they were SCL variables of the appropriate kind.
{ The size subfields of the identifier and text fields of a clt$status record
{ represent the corresponding current_string_size.
        status_value: ^array [1 .. * ] of clt$status,
      casend,
    recend;

  TYPE
    clt$status = record
      normal: clt$boolean,
      identifier: clt$status_identifier,
      condition: clt$integer,
      text: ost$string,
    recend,
    clt$status_identifier = record
      size: ost$string_size,
      value: string (2),
    recend;

  TYPE
    clt$variable_dimension = clc$min_variable_dimension ..
          clc$max_variable_dimension;

  CONST
    clc$min_variable_dimension = -7fffffff(16),
    clc$max_variable_dimension = 7fffffff(16);

  TYPE
    clt$variable_scope = record
      case kind: clt$variable_scope_kind of
      = clc$local_variable .. clc$xref_variable =
        ,
      = clc$utility_variable =
        utility_name: ost$name,
      casend,
    recend,
    clt$variable_scope_kind = (clc$local_variable, clc$job_variable,
          clc$xdcl_variable, clc$xref_variable, clc$utility_variable);

*copyc clt$boolean
*copyc clt$integer
*copyc clt$real
*copyc clt$variable_kinds
*copyc ost$name
*copyc ost$status
*copyc ost$string
*DECK DECK=CLE$ALL_MUST_BE_USED_ALONE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$all_must_be_used_alone      = clc$min_ecc + 5;
    {E ALL must be used alone for parameter +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$AWAITING_TASK_TERMINATION EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$awaiting_task_termination   = clc$min_ecc + 10;
    {I Waiting for asynchronous task(s) to terminate.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$BAD_APPLICATION_TASK_LINK EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$bad_application_task_link   = clc$min_ecc + 11;
    {I Child task for application +P could not be found in the application ..
    {task link.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$BAD_CLT$VALUE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$bad_clt$value               = clc$min_ecc + 16;
    {E A clt$value is improperly constructed.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$BAD_CLT$VARIABLE_VALUE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$bad_clt$variable_value      = clc$min_ecc + 18;
    {E A clt$variable_value is improperly constructed.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$BAD_DATA_REP_OPTION EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$bad_data_rep_option         = clc$min_ecc + 6;
    {E Improper value supplied for REPRESENTATION_OPTION parameter of ..
    {CLP$CONVERT_DATA_TO_STRING request.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$BAD_DATA_VALUE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$bad_data_value              = clc$min_ecc + 7;
    {E A clt$data_value is improperly constructed.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$BAD_DECLARATION_VERSION EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$bad_declaration_version     = clc$min_ecc + 1;
    {E Version +P for an SCL table or specification declaration is not ..
    {supported.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$BAD_INTERNAL_VALUE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$bad_internal_value          = clc$min_ecc + 15;
    {E A clt$internal_data_value is improperly constructed.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$BAD_KEYWORD_TYPE_SPEC EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$bad_keyword_type_spec       = clc$min_ecc + 2;
    {E Bad clt$type_specification for KEYWORD type.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$BAD_PARAMETER_LIST EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$bad_parameter_list          = clc$min_ecc + 17;
    {E A clt$parameter_list is improperly constructed.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$BAD_PDT EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$bad_pdt                     = clc$min_ecc + 605;
    {E Improperly constructed parameter description table.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$BAD_PVT EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$bad_pvt                     = clc$min_ecc + 607;
    {E A clt$parameter_value_table is not the same size as its ..
    {associated clt$parameter_description_table.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$BAD_STRING_PATTERN EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$bad_string_pattern          = clc$min_ecc + 97;
    {E A clt$string_pattern is improperly constructed.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$BAD_TYPE_DESCRIPTION EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$bad_type_description        = clc$min_ecc + 4;
    {E A clt$type_description is improperly constructed.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$BAD_TYPE_SPECIFICATION EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$bad_type_specification      = clc$min_ecc + 25;
    {E A clt$type_specification is improperly constructed.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$BAD_UNSEEN_MAIL_ACTION EXPAND=FALSE
?? NEWTITLE := 'CLE$BAD_UNSEEN_MAIL_ACTION', EJECT ??
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$bad_unseen_mail_action = clc$min_ecc + 33;
    {E Unrecognizable unseen mail action.}

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=CLE$BAD_WILD_CARD_PATTERN EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$bad_wild_card_pattern       = clc$min_ecc + 98;
    {E Missing or unexpected characters in "wild card" pattern.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$BLOCK_ACCESS_COUNT_ERROR EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$block_access_count_error    = clc$min_ecc + 12;
    {F ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **+N10..
    {The access count for an SCL clt$block (kind=+P) could not be ..
    {decremented because it was already zero.  +E10(PVA of block = +P.)}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$CANNOT_ACCESS_UNIT_ARRAY EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$cannot_access_unit_array    = clc$min_ecc + 13;
    {E Cannot access application counter array for application +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$COMMAND_CANCELLED EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$command_cancelled           = clc$min_ecc + 7015;
    {I Command +P cancelled.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$COMMAND_LINE_CANCELLED EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$command_line_cancelled      = clc$min_ecc + 7014;
    {I Command line cancelled.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$COMMAND_TERMINATED EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$command_terminated          = clc$min_ecc + 7002;
    {I Command terminated.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$COMPARED_FILES_UNEQUAL_SIZE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$compared_files_unequal_size = clc$min_ecc + 5030;
    {E File +F shorter than file +F.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$COMPARE_ERRORS_DETECTED EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$compare_errors_detected     = clc$min_ecc + 5025;
    {E +P compare errors.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$CONFLICTING_OPTIONS_SPEC EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$conflicting_options_spec    = clc$min_ecc + 19;
    {E Conflicting options were specified for function +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$COPYRIGHT EXPAND=FALSE
*DECK DECK=CLE$DETACHED_JOBS EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$detached_jobs               = clc$min_ecc + 7001;
    {I +N..
    {You have the following detached jobs:+N..
    {+P}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$ECC_COMMAND_PROCESSING EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??
{
{ CLE$ECC_command_processing has the following unused code offsets:
{
{ 700..704 706 721..724 726..729 731..734 736..739 741..743 745..747
{ 758 762..774 776..779 781..784 787 791..799
{

  CONST
    clc$min_ecc_command_processing  = clc$min_ecc + 700,

    cle$assignment_cant_be_labelled = clc$min_ecc + 705,
    {E Assignment statements cannot be labelled or preceded by '/'.}

    cle$bad_or_missing_login_in_job = clc$min_ecc + 707,
    {E Login command is either missing or incorrect in +F.}

    cle$command_aborted             = clc$min_ecc + 708,
    {F Command aborted: +P}

    cle$command_file_not_accessible = clc$min_ecc + 709,
    {E Command file is not accessible.}

    cle$command_file_not_callable   = clc$min_ecc + 710,
    {E Command/procedure file +F is not callable.}

    cle$command_file_not_executable = clc$min_ecc + 711,
    {E Command/procedure file +F is not executable.}

    cle$duplicate_fence_entry       = clc$min_ecc + 712,
    {E Attempt to add a FENCE to the command list, but there is already one ..
    {in the list.}

    cle$duplicate_work_cat_entry    = clc$min_ecc + 713,
    {E Attempt to add the working catalog to the command list, but it is ..
    {already in the list.}

    cle$commands_cant_be_labelled   = clc$min_ecc + 714,
    {E Commands cannot be labelled.}

    cle$command_search_aborted      = clc$min_ecc + 715,
    {F Command search aborted due to system condition or segment access..
    { condition on file +F.}

    cle$duplicate_command_list_ent  = clc$min_ecc + 717,
    {E Attempt to add +F to the command list, but it is already in the list.}

    cle$duplicate_$system_entry     = clc$min_ecc + 718,
    {E Attempt to add $SYSTEM to the command list, but it is already in the ..
    {list.}

    cle$escape_not_allowed          = clc$min_ecc + 719,
    {E '/' not allowed before command in exclusive mode.}

    cle$escaped_command_not_allowed = clc$min_ecc + 720,
    {E "Escaped" command not allowed: +P.}

    cle$expecting_command           = clc$min_ecc + 725,
    {E Expecting command, found +P.}

    cle$expecting_command_reference = clc$min_ecc + 729,
    {E Expecting command reference, found +P.}

    cle$expecting_entry_point_ref   = clc$min_ecc + 732,
    {E Expecting entry point reference, found +P.}

    cle$file_dot_cmnd_not_allowed   = clc$min_ecc + 735,
    {E File.command (+P) not allowed in "exclusive" command mode.}

    cle$file_not_in_input_stack     = clc$min_ecc + 740,
    {E File +P not found in input stack.}

    cle$improper_command_file_attr  = clc$min_ecc + 744,
    {E Attributes of command file +F are improper: +P8.}

    cle$multiple_include_command    = clc$min_ecc + 749,
    {E The input to INCLUDE_COMMAND consisted of more than one ..
    {command: +P}

    cle$not_a_command_file          = clc$min_ecc + 750,
    {E File +F is not a command file.}

    cle$incorrect_exec_command_file = clc$min_ecc + 751,
    {E File +F can not be used as an EXECUTE_COMMAND command file.}

    cle$multiple_execute_command    = clc$min_ecc + 752,
    {E The input to EXECUTE_COMMAND consisted of more than one ..
    {command: +P}

    cle$invalid_exec_command        = clc$min_ecc + 753,
    {E A +P statement can not be used as an EXECUTE_COMMAND command.}

    cle$invalid_exec_task_name      = clc$min_ecc + 754,
    {E +P may not be used as a EXECUTE_COMMAND task name.}

    cle$not_in_command_list         = clc$min_ecc + 755,
    {W +F not in job command list.}

    cle$entry_not_in_command_list   = clc$min_ecc + 756,
    {W +P not in job command list.}

    cle$cannot_change_search_mode   = clc$min_ecc + 757,
    {E The command search mode cannot be changed within a command utility ..
    {if the command search mode is restricted.}

    cle$exclusve_mode_excludes_cmnd = clc$min_ecc + 759,
    {E The command list and command search mode cannot be changed if the ..
    {command search mode is exclusive.}

    cle$not_allowed_in_exclusive    = clc$min_ecc + 760,
    {E The +P command is not allowed while the command search mode is ..
    {exclusive.}

    cle$restricted_mode_cmnd_change  = clc$min_ecc + 761,
    {E The command list cannot be changed while the command search mode is ..
    {restricted.}

    cle$unable_to_call_command      = clc$min_ecc + 775,
    {E Unable to call command: +P.}

    cle$unbalanced_block_structure  = clc$min_ecc + 780,
    {E Unbalanced block structure: found +P, expecting +P.}

    cle$unexpected_after_command    = clc$min_ecc + 785,
    {E Unexpected +P after command.}

    cle$unexpected_comma_after      = clc$min_ecc + 786,
    {E Unexpected ',' after +P.}

    cle$unexpected_escape           = clc$min_ecc + 788,
    {E Unexpected '/' before +P.}

    cle$unexpected_prompt_statement = clc$min_ecc + 789,
    {E Unexpected '?' before +P.}

    cle$unknown_command             = clc$min_ecc + 790,
    {E +P is not a command.}

    clc$max_ecc_command_processing  = clc$min_ecc + 799;

?? FMT (FORMAT := ON) ??
*copyc cle$ecc_line_length
*DECK DECK=CLE$ECC_COMPARE_COMMAND EXPAND=FALSE

{ This deck (cle$ecc_compare_command) should no longer be used.
{ Do *copyc's of the decks containing the exception condition codes
{ you need.

*copyc cle$compare_errors_detected
*copyc cle$compared_files_unequal_size
*DECK DECK=CLE$ECC_CONNECTED_FILE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??
{
{ CLE$ECC_connected_file has the follwoing unused code offsets:
{
{ 1300..1309 1311..1314 1316..1319 1321..1324 1326..1329 1331..1334 1336..1369
{ 1371..1379 1381..1399
{

  CONST
    clc$min_ecc_connected_file      = clc$min_ecc + 1300,

    cle$circular_file_connection    = clc$min_ecc + 1310,
    {E Attempt to make circular file connection from +F to +F.}

    cle$connection_cannot_be_broken = clc$min_ecc + 1315,
    {E Connection between +F and +F may not be broken.}

    cle$duplicate_file_connection   = clc$min_ecc + 1320,
    {W Connection between +F and +F already exists.}

    cle$incompatible_file_connect   = clc$min_ecc + 1325,
    {E Cannot connect +F and +F because of incompatible attributes: +P.}

    cle$improper_subject_file_name  = clc$min_ecc + 1330,
    {E Improper name for subject of file connection: +P.}

    cle$improper_target_file_name   = clc$min_ecc + 1335,
    {E Improper name for target of file connection: +P.}

    cle$subject_cannot_be_connected = clc$min_ecc + 1370,
    {E +F may not be made the subject of a file connection because it ..}
    {already exists.}

    cle$unknown_file_connection     = clc$min_ecc + 1380,
    {W +F is not connected to +F.}

    clc$max_ecc_connected_file      = clc$min_ecc + 1399;

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$ECC_CONTROL_STATEMENT EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??
{
{ CLE$ECC_control_statement has the following unused code offsets:
{
{ 1100..1101 1103 1116..1119 1121 1124..1125 1137 1139 1141..1149
{ 1153..1154 1156..1159 1171..1172 1177..1179 1181..1183 1186..1189
{ 1191..1192 1196..1199
{

  CONST
    clc$min_ecc_control_statements  = clc$min_ecc + 1100,

    cle$abort_option_not_allowed    = clc$min_ecc + 1102,
    {E ABORT option for WITH clause only allowed in an EXIT statement that ..
    {designates a task.}

    cle$cannot_cause_condition      = clc$min_ecc + 1104,
    {E CAUSE statement cannot be used to cause condition +P.}

    cle$cannot_pop_command_list     = clc$min_ecc + 1105,
    {E Cannot pop command list because a utility was added.}

    cle$case_sel_cant_be_labelled   = clc$min_ecc + 1106,
    {E CASE selection statement cannot be labelled.}

    cle$duplicate_abort_option      = clc$min_ecc + 1109,
    {E ABORT option found more than once in EXIT statement.}

    cle$duplicate_when_clause       = clc$min_ecc + 1107,
    {E WHEN clause found more than once in EXIT or EXIT_PROC statement.}

    cle$duplicate_with_clause       = clc$min_ecc + 1108,
    {E WITH clause found more than once in EXIT or EXIT_PROC statement.}

    cle$expecting_for_assign        = clc$min_ecc + 1110,
    {E Expecting '=', found +P after FOR statement control variable.}

    cle$expecting_for_by_or_do      = clc$min_ecc + 1111,
    {E Expecting BY or DO, found +P in FOR statement.}

    cle$expecting_for_to            = clc$min_ecc + 1112,
    {E Expecting TO, found +P in FOR statement.}

    cle$expecting_for_in            = clc$min_ecc + 1113,
    {E Expecting IN, found +P in FOR statement.}

    cle$expecting_for_var_or_each   = clc$min_ecc + 1114,
    {E Expecting variable reference or EACH, found +P in FOR statement.}

    cle$expecting_for_variable      = clc$min_ecc + 1115,
    {E Expecting variable reference, found +P in FOR statement.}

    cle$expecting_label             = clc$min_ecc + 1120,
    {E Expecting label, found +P in +P statement.}

    cle$expecting_label_or_when     = clc$min_ecc + 1122,
    {E Expecting label or WHEN, found +P in CYCLE statement.}

    cle$expecting_label_when_with   = clc$min_ecc + 1123,
    {E Expecting label, WHEN or WITH, found +P in EXIT statement.}

    cle$expecting_retry_or_when     = clc$min_ecc + 1126,
    {E Expecting NEXT, NEXT_HANDLER, NEXT_USER_HANDLER, RETRY or WHEN, ..
    {found +P in CONTINUE statement.}

    cle$expecting_continue_when     = clc$min_ecc + 1127,
    {E Expecting WHEN, found +P in CONTINUE statement.}

    cle$expecting_cycle_when        = clc$min_ecc + 1128,
    {E Expecting WHEN, found +P in CYCLE statement.}

    cle$expecting_exit_when         = clc$min_ecc + 1129,
    {E Expecting WHEN, found +P in EXIT or EXIT_PROC statement.}

    cle$expecting_with              = clc$min_ecc + 1130,
    {E Expecting WITH, found +P in EXIT or EXIT_PROC statement.}

    cle$expecting_with_after_abort  = clc$min_ecc + 1136,
    {E Expecting WITH, found +P,  after ABORT in EXIT statement.}

    cle$expecting_with_for_cause    = clc$min_ecc + 1151,
    {E Expecting WITH, found +P in CAUSE statement.}

    cle$expecting_with_or_when      = clc$min_ecc + 1131,
    {E Expecting WITH or WHEN, found +P in EXIT or EXIT_PROC statement.}

    cle$improper_env_object_name    = clc$min_ecc + 1132,
    {E Improper name for environment object or variable: +P.}

    cle$no_object_to_pop            = clc$min_ecc + 1133,
    {E +P cannot be popped.}

    cle$not_an_environment_object   = clc$min_ecc + 1134,
    {E +P is not an environment object or variable.}

    cle$object_already_pushed       = clc$min_ecc + 1135,
    {E +P has already been pushed at this level.}

    cle$statement_cant_be_cycled    = clc$min_ecc + 1138,
    {E +P statement cannot be cycled.}

    cle$statement_cant_be_labelled  = clc$min_ecc + 1140,
    {E +P statement cannot be labelled.}

    cle$unexpected_after_bool_expr  = clc$min_ecc + 1150,
    {E Unexpected +P after boolean expression.}

    cle$unexpected_after_cond_name  = clc$min_ecc + 1152,
    {E Unexpected +P after condition name in +P statement.}

    cle$unexpected_after_end_label  = clc$min_ecc + 1155,
    {E Unexpected +P after label in +P statement.}

    cle$unexpected_after_for_by     = clc$min_ecc + 1160,
    {E Unexpected +P after BY in FOR statement.}

    cle$unexpected_after_for_final  = clc$min_ecc + 1161,
    {E Unexpected +P after final value in FOR statement.}

    cle$unexpected_after_for_in     = clc$min_ecc + 1167,
    {E Unexpected +P after IN in FOR statement.}

    cle$unexpected_after_for_init   = clc$min_ecc + 1162,
    {E Unexpected +P after initial value in FOR statement.}

    cle$unexpected_after_for_step   = clc$min_ecc + 1163,
    {E Unexpected +P after step value in FOR statement.}

    cle$unexpected_after_for_to     = clc$min_ecc + 1164,
    {E Unexpected +P after TO in FOR statement.}

    cle$unexpected_after_for_list   = clc$min_ecc + 1165,
    {E Unexpected +P after list value in FOR statement.}

    cle$unexpected_after_obj_name   = clc$min_ecc + 1166,
    {E Unexpected +P after environment object name.}

    cle$unexpected_after_procend    = clc$min_ecc + 1169,
    {E Unexpected +P after +P statement.}

    cle$unexpected_after_retry      = clc$min_ecc + 1168,
    {E Unexpected +P after +P in CONTINUE statement.}

    cle$unexpected_after_then_or_do = clc$min_ecc + 1170,
    {E Unexpected +P2 after +P1.}

    cle$unexpected_after_when       = clc$min_ecc + 1173,
    {E Unexpected +P after WHEN in +P statement.}

    cle$unexpected_after_with       = clc$min_ecc + 1174,
    {E Unexpected +P after WITH in EXIT or EXIT_PROC statement.}

    cle$unexpected_after_with_value = clc$min_ecc + 1175,
    {E Unexpected +P after WITH value in EXIT or EXIT_PROC statement.}

    cle$unexpected_after_when_value = clc$min_ecc + 1176,
    {E Unexpected +P after WHEN value in EXIT or EXIT_PROC statement.}

    cle$unexpected_control_statemnt = clc$min_ecc + 1180,
    {E Unexpected +P statement.}

    cle$unexpected_function         = clc$min_ecc + 1184,
    {E Unexpected FUNCTION declaration.}

    cle$unexpected_proc             = clc$min_ecc + 1185,
    {E Unexpected PROCEDURE declaration.}

    cle$unexpected_statement_params = clc$min_ecc + 1190,
    {E Unexpected parameters for +P statement.}

    cle$with_clause_not_allowed     = clc$min_ecc + 1193,
    {E WITH clause only allowed in an EXIT statement that designates a ..
    {PROCEDURE, FUNCTION or TASK.}

    cle$with_clause_required        = clc$min_ecc + 1194,
    {E WITH clause required in an EXIT statement that designates a FUNCTION ..
    {or TASK.}

    cle$wrong_statement_label       = clc$min_ecc + 1195,
    {E Wrong statement label for +P statement.}

    clc$max_ecc_control_statements  = clc$min_ecc + 1199;

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$ECC_CT_GENERATOR EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??
{
{ CLE$ECC_ct_generator has the following unused code offsets:
{
{ 9000..9004 9006..9009 9011..9014 9016..9499
{

  CONST
    clc$min_ecc_ct_generator        = clc$min_ecc + 9000,

    cle$unexpected_entry            = clc$min_ecc + 9005,
    {E Expecting +P entry, found +P entry.}

    cle$improper_module_name        = clc$min_ecc + 9010,
    {E Improper module name - +P.}

    cle$duplicate_cmnd_or_fcn_name  = clc$min_ecc + 9015,
    {W Name "+P" duplicated in command or function table.}

    clc$max_ecc_ct_generator        = clc$min_ecc + 9499;

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$ECC_DATE_TIME_FORMAT EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??
{
{ CLE$ECC_date_time_format has the following unused code offsets:
{
{ 1400..1404 1406 1409 1411..1414 1416..1419 1421..1424 1426..1429 1431..1434
{ 1436..1439 1441..1444 1446..1499
{

  CONST
    clc$min_ecc_date_time_format    = clc$min_ecc + 1400,

    cle$language_delimiter_missing  = clc$min_ecc + 1405,
    {E Ending ) is missing from language string.}

    cle$language_module_not_found   = clc$min_ecc + 1407,
    {E Cannot find message module for specified language +P.}

    cle$bad_template_for_month_day  = clc$min_ecc + 1408,
    {E Template for +P is invalid for +P.}

    cle$date_time_format_null       = clc$min_ecc + 1410,
    {E Date_time format may not be null or blank.}

    cle$unexpected_dt_format_char   = clc$min_ecc + 1415,
    {E +P is not allowed in this date_time format context.}

    cle$unknown_date_time_format    = clc$min_ecc + 1420,
    {E Specified date_time string is not a known date_time format.}

    cle$name_not_month_or_day       = clc$min_ecc + 1425,
    {E +P is not a known month or day name.}

    cle$date_time_string_too_long   = clc$min_ecc + 1435,
    {E Too many components in date_time string +P.}

    cle$bad_month_number            = clc$min_ecc + 1440,
    {E Incorrect month number specified.}

    cle$invalid_time_increment      = clc$min_ecc + 1445,
    {E Time increment field out of range.}

    clc$max_ecc_date_time_format    = clc$min_ecc + 1499;

?? FMT (FORMAT := ON) ??
*copyc cle$ecc_parsing
*DECK DECK=CLE$ECC_EXPRESSION EXPAND=FALSE
*copyc clc$ecc_range

{ This deck (cle$ecc_expression) should no longer be used.
{ Do *copyc's of the decks containing the exception condition codes
{ you need.  Note that the codes defined directly within this deck
{ are no longer produced by the SCL interpreter; they continue to be
{ defined for "compatibility" with previous systems.

?? FMT (FORMAT := OFF) ??

  CONST
    clc$min_ecc_expression          = clc$min_ecc + 300,

    cle$concatenation_overflow      = clc$min_ecc + 305,
    {E Concatenation produced too long a string.}

    cle$expecting_relation_operand  = clc$min_ecc + 315,
    {E Expecting number or string operand, found +P for +P operator.}

    cle$expecting_rparen            = clc$min_ecc + 320,
    {E Expecting ')', found +P.}

    cle$unbalanced_parenthesis     = clc$min_ecc + 321,
    {E Unbalanced parenthesis.}

    cle$integer_divide_by_zero      = clc$min_ecc + 325,
    {E Division by zero is undefined.}

    cle$integer_overflow            = clc$min_ecc + 330,
    {E Integer overflow with +P operator.}

    cle$operand_kind_mismatch       = clc$min_ecc + 335,
    {E Operand mismatch for +P operator.}

    cle$undeclared_operand          = clc$min_ecc + 340,
    {E Undeclared operand +P for +P operator.}

    cle$wrong_kind_of_operand       = clc$min_ecc + 345,
    {E Expecting +P operand, found +P for +P operator.}

    clc$max_ecc_expression          = clc$min_ecc + 399;

?? FMT (FORMAT := ON) ??
*copyc cle$ecc_parsing
*DECK DECK=CLE$ECC_EXPRESSION_RESULT EXPAND=FALSE
*copyc clc$ecc_range

{ This deck (cle$ecc_expression_result) should no longer be used.
{ Do *copyc's of the decks containing the exception condition codes
{ you need.  Note that the codes defined directly within this deck
{ are no longer produced by the SCL interpreter; they continue to be
{ defined for "compatibility" with previous systems.

?? FMT (FORMAT := OFF) ??

  CONST
    clc$min_ecc_expression_result   = clc$min_ecc + 200,

    cle$array_not_allowed           = clc$min_ecc + 205,
    {E Array variable not allowed+P.}

    cle$expecting_expression        = clc$min_ecc + 210,
    {E Expecting value, found +P+P.}

    cle$expecting_keyword_value     = clc$min_ecc + 215,
    {E Expecting keyword value, found +P+P.}

    cle$name_not_a_keyword_value    = clc$min_ecc + 235,
    {E +P not an allowed value+P.}

    cle$unexpected_array_reference  = clc$min_ecc + 260,
    {E Unexpected array reference +P+P.}

    cle$wrong_kind_of_variable      = clc$min_ecc + 270,
    {E Expecting +P variable, found +P+P.}

    clc$max_ecc_expression_result   = clc$min_ecc + 299;

?? FMT (FORMAT := ON) ??
*copyc cle$ecc_parsing
*copyc cle$string_too_long
*copyc cle$string_too_short
*copyc cle$unable_to_call_av_scanner
*DECK DECK=CLE$ECC_FILE_REFERENCE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??
{
{ CLE$ECC_file_reference has the following unused code offsets:
{
*IF NOT $true(osv$unix)
{ 515..519 521..524 526..529 531..534 536..537 539 541
{ 545 547 549..551 553 557 559..560 566 569 571..574 576..577 579..580
*ELSE
{ 515..519 521..524 526..529 531..534 536..537 541
{ 545 547 549..551 553 557 559 569 571..574 576..577 579..580
*IFEND
{ 582..584 587..599
{

  CONST
    clc$min_ecc_file_reference      = clc$min_ecc + 500,

    cle$catalog_not_empty           = clc$min_ecc + 503,
    {E Catalog "+P" is not empty.}

    cle$concatenate_cant_be_first   = clc$min_ecc + 504,
    {E A file reference cannot begin with "//".}

    cle$conflicting_parse_options   = clc$min_ecc + 502,
    {E Conflicting file reference parsing options were specified.}

    cle$cycle_must_follow_file_name = clc$min_ecc + 505,
    {E Cycle designator must follow file name in file reference.}

    cle$cycle_number_not_known      = clc$min_ecc + 508,
    {E The cycle number for file reference +F is not known.}

    cle$recursive_$defer            = clc$min_ecc + 513,
    {E Recursive use of $DEFER is not allowed.}

    cle$defer_must_follow_colon     = clc$min_ecc + 514,
    {E $DEFER must be preceeded by a colon.}

    cle$duplicate_pf_cycle          = clc$min_ecc + 520,
    {E More than one cycle designator given in file reference.}

    cle$expecting_end_of_file_ref   = clc$min_ecc + 525,
    {E Expecting end of file reference, found +P.}

    cle$expecting_file_reference    = clc$min_ecc + 530,
    {E Expecting file reference, found +P.}

    cle$expecting_file_var_or_fcn   = clc$min_ecc + 500,
    {E Expecting file variable or function, found +P.}

    cle$expecting_path_element      = clc$min_ecc + 535,
    {E Expecting file reference element, found +P.}

    cle$file_not_assigned_to_device = clc$min_ecc + 542,
    {E +P1 is only allowed on a file assigned to a device class of +P2.}

    cle$file_position_not_allowed   = clc$min_ecc + 538,
    {E File position specifier not allowed on catalog reference.}
*IF $true(osv$unix)

    cle$file_position_not_supported = clc$min_ecc + 539,
    {E File position specifier not supported for UNIX file.}
*IFEND

    cle$file_reference_too_long     = clc$min_ecc + 540,
    {E File reference too long.}

    cle$improper_cmd_file_qualifier= clc$min_ecc + 543,
    {E Command file qualifier +P has improper form.}

    cle$improper_device_class       = clc$min_ecc + 544,
    {E +P1 is not allowed on a file assigned to a +P2 device class.}

    cle$improper_fs_path_structure  = clc$min_ecc + 501,
    {E The path structure is improper: +P.}

    cle$improper_labelled_tape_op   = clc$min_ecc + 546,
    {E +P1 is not allowed on a labelled tape file.}

    cle$improper_open_position      = clc$min_ecc + 548,
    {E +P1 is not allowed as an open position on the +P2 command.}

    cle$improper_vsn_value          = clc$min_ecc + 554,
    {E A value of +P1 is improper for the +P2 parameter.}

    cle$inappropriate_cmnd_file_ref = clc$min_ecc + 568,
    {E Use of command file reference (i.e. $COMMAND or $COMMAND_OF_CALLER)..
    { is inappropriate for the requested operation.}

    cle$inconsistent_vsn_lists      = clc$min_ecc + 552,
    {E The EXTERNAL_VSN and RECORDED_VSN lists are inconsistent.}

    cle$invalid_cmnd_file_qualifier = clc$min_ecc + 555,
    {E An invalid command file qualifier was specified: +P.}

    cle$missing_colon_in_var_or_fcn = clc$min_ecc + 507,
    {E File variable or function value must begin with a ':'.}

    cle$name_already_catalog        = clc$min_ecc + 556,
    {E Name "+P" is already being used as the name of a catalog.}

    cle$name_not_file               = clc$min_ecc + 558,
    {E Name "+P" is expected to be the name of a file but it is not.}

    cle$no_concat_in_job_indep_path = clc$min_ecc + 510,
    {E The concatenation operator is not valid in a job independent path.}

    cle$no_concat_in_var_or_fcn     = clc$min_ecc + 509,
    {E Concatenation operator is not valid in a file variable or function..
    { value.}

    cle$no_job_context_elements     = clc$min_ecc + 511,
    {E The +P path element is not allowed in a job independent path.}

    cle$no_pos_on_cmnd_entry_pt_ref = clc$min_ecc + 565,
    {E Position designator not allowed on command or entry_point reference.}

    cle$not_permitted_on_loc_cat    = clc$min_ecc + 561,
    {E The requested operation cannot be performed on the $LOCAL catalog.}

    cle$not_permitted_on_loc_file   = clc$min_ecc + 562,
    {E The requested operation cannot be performed on a file in the..
    { $LOCAL catalog.}
*IF $true(osv$unix)

    cle$null_path_element           = clc$min_ecc + 560,
    {E An element of a file path must have at least one non-space character.}
*IFEND

    cle$only_cycle_one_allowed      = clc$min_ecc + 564,
    {E Only cycle 1 is allowed for file +F.}

    cle$only_permitted_on_loc_file  = clc$min_ecc + 563,
    {E The requested operation can be performed only on a temporary..
    { file in the $LOCAL catalog.}
*IF $true(osv$unix)

    cle$path_element_too_long       = clc$min_ecc + 566,
    {E An element of a file path may not be longer than 31 characters: +P}
*IFEND

    cle$position_must_be_last       = clc$min_ecc + 567,
    {E Position designator must follow file name in file reference.}

    cle$special_element_not_first   = clc$min_ecc + 570,
    {E +P must be first element of file reference.}

    cle$system_error                = clc$min_ecc + 575,
    {E System error - see job log.}

    cle$unable_to_find_cmnd_source  = clc$min_ecc + 506,
    {E Unable to find command source.}

    cle$undefined_user_ident        = clc$min_ecc + 512,
    {E The user identification information is not available.}

    cle$unexpected_sys_cmnd_source = clc$min_ecc + 578,
    {E Expecting file reference, found $SYSTEM command source.}

    cle$unexpected_util_cmnd_source = clc$min_ecc + 581,
    {E Expecting file reference, found +P utility command source.}

    cle$unexpected_colon_in_path    = clc$min_ecc + 585,
    {E A ":" may only be used at the beginning of a path.}

*IF $true(osv$unix)
    cle$up_produced_empty_file_ref  = clc$min_ecc + 586,
    {E .. produced an empty file reference.}
*ELSE
    cle$up_produced_empty_file_ref  = clc$min_ecc + 586,
    {E $UP produced an empty file reference.}
*IFEND

    cle$var_or_fcn_follows_concat   = clc$min_ecc + 591,
    {E "//" in a file reference must be followed by a name or integer..
    { variable or function: +P was specified.}

    cle$var_or_fcn_follows_$defer   = clc$min_ecc + 592,
    {E :$DEFER must be followed by a file variable or function:..
    { +P was specified.}

    clc$max_ecc_file_reference      = clc$min_ecc + 599;

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$ECC_FUNCTION_PROCESSING EXPAND=FALSE
*copyc clc$ecc_range

{ This deck (cle$ecc_function_processing) should no longer be used.
{ Do *copyc's of the decks containing the exception condition codes
{ you need.  Note that the codes defined directly within this deck
{ are no longer produced by the SCL interpreter; they continue to be
{ defined for "compatibility" with previous systems.

?? FMT (FORMAT := OFF) ??

  CONST
    clc$min_ecc_function_processing = clc$min_ecc + 1000,

    cle$bad_adt                     = clc$min_ecc + 1005,
    {E Improper argument descriptor table for function +P2 : +P1.}

    cle$expecting_argument_term     = clc$min_ecc + 1020,
    {E Expecting end of argument +P2 of function +P3, found +P1.}

    cle$expecting_rparen_of_alist   = clc$min_ecc + 1030,
    {E Expecting ')' of argument list for function +P, found +P.}

    cle$required_argument_omitted   = clc$min_ecc + 1060,
    {E Argument +P2 is required but was omitted from function +P1.}

    cle$too_many_arguments          = clc$min_ecc + 1070,
    {E Too many arguments given for function +P.}

    clc$max_ecc_function_processing = clc$min_ecc + 1099;

?? FMT (FORMAT := ON) ??
*copyc cle$ecc_parsing
*copyc cle$unable_to_call_function
*DECK DECK=CLE$ECC_LEXICAL EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??
{
{ CLE$ECC_lexical has the following unused code offsets:
{
{ 100..104 106..109 111..114 116..119 121..124 126..129 131..134 136..139
{ 141..144 146..149 151 153 156..159 161..164 166..169 171..174 176..179
{ 181..184 186..189 191..199
{

  CONST
    clc$min_ecc_lexical             = clc$min_ecc + 100,

    cle$alpha_char_in_exponent      = clc$min_ecc + 105,
    {E Alphabetic character in exponent part of real number: +P.}

    cle$alpha_char_in_fraction      = clc$min_ecc + 110,
    {E Alphabetic character in fraction part of real number: +P.}

    cle$alpha_char_in_number        = clc$min_ecc + 115,
    {E Alphabetic character in number: +P.}

    cle$digit_too_large             = clc$min_ecc + 120,
    {E Digit too large for radix of integer: +P.}

*IF $true(osv$unix)
    cle$epix_command_requested      = clc$min_ecc + 121,
    {E The requested EP/IX command failed to execute.}

*IFEND
    cle$expecting_digit             = clc$min_ecc + 125,
    {F Expecting digit in number: +P.}

    cle$exponent_too_large          = clc$min_ecc + 130,
    {E Real number exponent too large: +P.}

    cle$improper_integer            = clc$min_ecc + 135,
    {E "+P" is not a properly formed integer.}

    cle$improper_name               = clc$min_ecc + 140,
    {E Improper name: +P.}

    cle$improper_radix_spec         = clc$min_ecc + 145,
    {E Improper integer radix specifier: +P.}

    cle$improper_radix_value        = clc$min_ecc + 150,
    {E Improper radix value: +P.}

    cle$improper_real               = clc$min_ecc + 152,
    {E "+P" is not a properly formed real number.}

*IF $true(osv$unix)
    cle$integer_literal_too_large   = clc$min_ecc + 154,
    {E The integer +P is too large.  Integers must be between -(2**31) ..
    {and (2**31)-1.}
*ELSE
    cle$integer_literal_too_large   = clc$min_ecc + 154,
    {E The integer +P is too large.  Integers must be between -(2**63) ..
    {and (2**63)-1.}
*IFEND

    cle$integer_too_large           = clc$min_ecc + 155,
    {E Integer value too large: +P.}

    cle$missing_exponent            = clc$min_ecc + 160,
    {E Missing exponent for real number: +P.}

    cle$missing_radix               = clc$min_ecc + 165,
    {E Missing radix specifier for integer: +P.}

    cle$missing_spaces_after        = clc$min_ecc + 170,
    {E Missing spaces after +P.}

    cle$missing_spaces_before       = clc$min_ecc + 175,
    {E Missing spaces before +P.}

    cle$missing_string_delimiter    = clc$min_ecc + 180,
    {E Missing string delimiter: +P.}

    cle$name_too_long               = clc$min_ecc + 185,
    {E Name +P is too long. It has more than 31 characters.}

    cle$real_literal_too_large      = clc$min_ecc + 190,
    {E The real number +P is too large.  The magnitude of real numbers ..
    {must be between (approximately) 4.8e-1234 and 5.2e+1232.)

    clc$max_ecc_lexical             = clc$min_ecc + 199;

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$ECC_LINE_LENGTH EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST

    cle$continued_line_too_long     = clc$min_ecc + 716,
    {E Continued command line too long.}

    cle$expecting_continuation_line = clc$min_ecc + 730,
    {E Expecting continuation of command line, found end of input.}

    cle$line_too_long               = clc$min_ecc + 748;
    {E Line from command file +F is too long.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$ECC_MESSAGES_AND_PROMPTS EXPAND=FALSE

{ This deck (cle$ecc_messages_and_prompts) should no longer be used.
{ Do *copyc's of the decks containing the exception condition codes
{ you need.

*copyc cle$command_cancelled
*copyc cle$command_line_cancelled
*copyc cle$command_terminated
*copyc cle$detached_jobs
*copyc cle$interactive_eoi_ignored
*copyc cle$interactive_eop_ignored
*copyc cle$password_expiration_warning
*copyc cle$welcome_banner
*DECK DECK=CLE$ECC_MISCELLANEOUS EXPAND=FALSE

{ This deck (cle$ecc_miscellaneous) should no longer be used.
{ Do *copyc's of the decks containing the exception condition codes
{ you need.  Each one is in its own deck.

{ When creating a new "miscellaneous" condition do not add it to this deck.
{ Put a *copyc to it directly in deck cle$exception_condition_codes (where
{ you will find a list of the available code offsets).

*copyc cle$all_must_be_used_alone
*copyc cle$awaiting_task_termination
*copyc cle$bad_application_task_link
*copyc cle$bad_data_rep_option
*copyc cle$bad_data_value
*copyc cle$block_access_count_error
*copyc cle$cannot_access_unit_array
*copyc cle$empty_file
*copyc cle$encountered_eoi
*copyc cle$file_never_opened
*copyc cle$file_reference_conflict
*copyc cle$improper_substitution_mark
*copyc cle$improper_use_of_subst_mark
*copyc cle$incompatible_params_given
*copyc cle$multiple_applic_unit_arrays
*copyc cle$negative_application_units
*copyc cle$none_must_be_used_alone
*copyc cle$not_list_legible
*copyc cle$not_yet_implemented
*copyc cle$redundancy_in_selections
*copyc cle$system_prolog_not_allowed
*copyc cle$table_overflow
*copyc cle$task_already_complete
*copyc cle$task_not_found
*copyc cle$terminated_application_task
*copyc cle$unable_to_free_block
*copyc cle$unable_to_set_cai
*copyc cle$unable_to_set_minws
*copyc cle$unable_to_set_pai
*copyc cle$unexpected_call_to
*copyc cle$user_already_logged_in
*copyc cle$value_counts_unequal
*copyc cle$work_area_overflow
*DECK DECK=CLE$ECC_MT_GENERATOR EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??
{
{ CLE$ECC_mt_generator has the following unused code offsets:
{
{ 8000..8001 8004 8006..8009 8011..8014 8016..8019 8021..8024 8028..8029
{ 8031..8034 8036 8038..8039 8041..8044 8046..8049 8051..8054 8056..8059
{ 8061..8064 8066..8069 8071 8076 8079 8081..8084 8086..8089 8091 8093..8094
{ 8096 8098 8101..8104 8106..8499
{

  CONST
    clc$min_ecc_mt_generator        = clc$min_ecc + 8000,

    cle$bad_help_module             = clc$min_ecc + 8003,
    {E Bad help module.}

    cle$cond_code_too_large         = clc$min_ecc + 8005,
    {E Condition code is too large for +P.}

    cle$constant_already_defined    = clc$min_ecc + 8010,
    {E +P defined more than once.  First definition is used.}

    cle$constant_not_defined        = clc$min_ecc + 8015,
    {E +P is not a defined constant when defining +P.}

    cle$constant_stack_overflow     = clc$min_ecc + 8020,
    {E Constant save area overflow when saving +P.}

    cle$duplicate_condition_codes   = clc$min_ecc + 8025,
    {E Duplicated condition code +P found in module +P.}

    cle$duplicate_keys              = clc$min_ecc + 8026,
    {E Key +P has already been assigned to a menu item.}

    cle$duplicate_menu_class        = clc$min_ecc + 8027,
    {E Duplicate menu class : +P.}

    cle$duplicate_names             = clc$min_ecc + 8030,
    {E +P entered more than once for +P in module +P.}

    cle$duplicate_help_messages     = clc$min_ecc + 8035,
    {E Attempt to enter +P  but one is already defined for module +P.}

    cle$duplicate_shifted_keys      = clc$min_ecc + 8037,
    {E Shifted key +P has already been assigned to a menu item.}

    cle$errors_in_module            = clc$min_ecc + 8040,
    {W Errors encountered in creation of message module +P.}

    cle$expecting_equal_sign        = clc$min_ecc + 8045,
    {E Expecting "=", found +P when defining +P.}

    cle$expecting_integer_value     = clc$min_ecc + 8050,
    {E Expecting integer value, found +P when defining +P.}

    cle$expecting_module_name       = clc$min_ecc + 8055,
    {E Expecting MODULE name value, found +P.}

    cle$expecting_name_value        = clc$min_ecc + 8060,
    {E Expecting name for constant or code definition, found +P.}

    cle$internal_generator_error    = clc$min_ecc + 8065,
    {W Internal generator error after defining +P.}

    cle$invalid_integer_constant    = clc$min_ecc + 8070,
    {W +P is not defined as an integer constant.}

    cle$invalid_int_or_string_const = clc$min_ecc + 8072,
    {W +P is not defined as an integer or string constant.}

    cle$max_menu_classes_exceeded   = clc$min_ecc + 8073,
    {E Maximum number of menu classes exceeded - the maximum is 16.}

    cle$max_menu_items_exceeded     = clc$min_ecc + 8074,
    {E Maximum number of menu items per class exceeded - the
    {  maximum is 20.}

    cle$menu_class_not_defined      = clc$min_ecc + 8075,
    {E Menu class was not previously defined: +P.}

    cle$module_too_large            = clc$min_ecc + 8077,
    {F Message module +P is too large.}

    cle$no_menu_class_defined       = clc$min_ecc + 8078,
    {E No menu class has been defined.}

    cle$no_message_text             = clc$min_ecc + 8080,
    {E No message text found for +P.}

    cle$no_module_created           = clc$min_ecc + 8085,
    {E No messages defined for module +P.}

    cle$no_nested_message_modules   = clc$min_ecc + 8002,
    {E Attempt to create a message module, but the current ..
    {module +P has not been completed.}

    cle$no_severity_level           = clc$min_ecc + 8090,
    {E No severity level found for +P.  "E" is assumed.}

    cle$null_not_allowed            = clc$min_ecc + 8092,
    {E Null name is not valid for +P.}

    cle$template_too_long           = clc$min_ecc + 8095,
    {W Template defined for +P in module +P exceeds maximum allowable ..
    {length of +P characters.+N
    {Template was truncated.}

    cle$too_few_classes             = clc$min_ecc + 8097,
    {E Too few classes defined for application menu +P.}

    cle$too_few_items               = clc$min_ecc + 8099,
    {E Too few items defined for application menu +P.}

    cle$too_many_entries_for_module = clc$min_ecc + 8100,
    {E Number of entries exceeds maximum of +P for message module +P.}

    cle$unrecognizable_ecc_base     = clc$min_ecc + 8105,
    {E +P is not defined as a recognizable exception condition code base.}

    clc$max_ecc_mt_generator        = clc$min_ecc + 8499;

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$ECC_NAMED_TASK EXPAND=FALSE

{ This deck (cle$ecc_named_task) should no longer be used.
{ Do *copyc's of the decks containing the exception condition codes
{ you need.

*copyc cle$task_name_in_use
*copyc cle$task_taskend_ring_below_min
*DECK DECK=CLE$ECC_PARAMETER_LIST EXPAND=FALSE
*copyc clc$ecc_range

{ This deck (cle$ecc_parameter_list) should no longer be used.
{ Do *copyc's of the decks containing the exception condition codes
{ you need.  Note that the codes defined directly within this deck
{ are no longer produced by the SCL interpreter; they continue to be
{ defined for "compatibility" with previous systems.

?? FMT (FORMAT := OFF) ??

  CONST
    clc$min_ecc_parameters          = clc$min_ecc + 600,

    cle$expecting_rparen_of_vlist   = clc$min_ecc + 625,
    {E Expecting ')' of value list for parameter +P.}

    cle$expecting_rparen_of_vset    = clc$min_ecc + 630,
    {E Expecting ')' of value set for parameter +P.}

    cle$expecting_value_elem_term   = clc$min_ecc + 635,
    {E Expecting end of value for parameter +P, found +P.}

    cle$expecting_value_set_term    = clc$min_ecc + 640,
    {E Expecting end of value set for parameter +P, found +P.}

    cle$garbled_parameter_list      = clc$min_ecc + 645,
    {E The parameter_list passed to clp$scan_parameter_list is garbled.}

    cle$semicolon_not_separator     = clc$min_ecc + 653,
    {E Semicolon cannot be used as separator when replying to ..
    {prompting.}

    cle$too_few_values              = clc$min_ecc + 655,
    {E Too few values given for parameter +P.}

    cle$too_few_values_in_set       = clc$min_ecc + 660,
    {E Too few values in value set given for parameter +P.}

    cle$too_few_value_sets          = clc$min_ecc + 665,
    {E Too few value sets given for parameter +P.}

    cle$too_many_values             = clc$min_ecc + 675,
    {E Too many values given for parameter +P.}

    cle$too_many_values_in_set      = clc$min_ecc + 680,
    {E Too many values in value set given for parameter +P.}

    cle$too_many_value_sets         = clc$min_ecc + 685,
    {E Too many value sets given for parameter +P.}

    cle$value_range_not_allowed     = clc$min_ecc + 695,
    {E Value range not allowed for parameter +P.}

    clc$max_ecc_parameters          = clc$min_ecc + 699;

?? FMT (FORMAT := ON) ??
*copyc cle$bad_pdt
*copyc cle$bad_pvt
*copyc cle$ecc_parsing
*copyc cle$parameters_displayed
*copyc cle$unable_to_call_check_proc
*copyc cle$unable_to_call_parm_dlg_mgr
*DECK DECK=CLE$ECC_PARSING EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??
{
{ CLE$ECC_parsing has the following unused code offsets:
{
{ 2247..2999
{

  CONST

    clc$min_ecc_parsing             = clc$min_ecc + 2000,

{ Application type conformance errors }

    cle$application_name_mismatch   = clc$min_ecc + 2185,
    {E Application type names do not match.}

    cle$balance_brackets_dont_match = clc$min_ecc + 2186,
    {E "BALANCE_BRACKETS" attributes do not match.}

{ Application type specification errors }

    cle$expecting_applic_type_attr  = clc$min_ecc + 2000,
    {E Expecting attribute for APPLICATION type, found +P.}

{ Array type conformance errors }

    cle$array_bounds_dont_match     = clc$min_ecc + 2092,
    {E Array bounds do not match.}

    cle$unknown_array_element_type  = clc$min_ecc + 2191,
    {E Undefined array element type.}

{ Array expression errors }

    cle$too_few_or_many_array_elems = clc$min_ecc + 2001,
    {E +P elements given for array, but the array bounds are +P .. +P.}

    cle$unexpected_empty_array      = clc$min_ecc + 2226,
    {E No elements given for array, but at least one element must be given.}

{ Array type specification errors }

    cle$array_bound_out_of_range    = clc$min_ecc + 2002,
    {E The ARRAY bound +P is out of range.  It must be between +P and +P.}

    cle$array_bounds_required       = clc$min_ecc + 2003,
    {E In the declaration for an ARRAY type, the bounds must be specified ..
    {unless the declaration is for the type of a command (procedure) or ..
    {function parameter.}

    cle$array_elem_type_required    = clc$min_ecc + 2004,
    {E In the declaration for an ARRAY type, the element type must be ..
    {specified unless the declaration is for the type of a command ..
    {(procedure) or function parameter.}

    cle$expecting_of_for_array      = clc$min_ecc + 2005,
    {E Expecting OF in ARRAY type specification, found +P.}

    cle$max_array_bound_omitted     = clc$min_ecc + 2006,
    {E The maximum bound for an array was omitted but must be given when ..
    {the minimum bound is given.}

    cle$min_array_bound_gt_max      = clc$min_ecc + 2007,
    {E The minimum bound for an array may not be greater than the ..
    {corresponding maximum bound.}

{ Boolean expression errors }

    cle$and_operand_not_boolean     = clc$min_ecc + 2008,
    {E The operands of the "AND" operator must be booleans, a +P was found.}

    cle$not_operand_not_boolean     = clc$min_ecc + 2009,
    {E The operand of the "NOT" operator must be a boolean, a +P was found.}

    cle$or_operand_not_boolean      = clc$min_ecc + 2010,
    {E The operands of the "OR" operator must be booleans, a +P was found.}

    cle$xor_operand_not_boolean     = clc$min_ecc + 2011,
    {E The operands of the "XOR" operator must be booleans, a +P was found.}

{ COBOL_name expression errors }

    cle$expecting_cobol_name_expr   = clc$min_ecc + 2012,
    {E Expecting COBOL_name expression, found +P.}

    cle$not_a_cobol_name            = clc$min_ecc + 2013,
    {E +P is not a COBOL_name.  A COBOL name may contain up to 30 letters, ..
    {digits or hyphens. It may not start or end with a hyphen and must ..
    {contain at least one letter.}

{ Comparison (relational expression) errors }

    cle$non_comparable_type         = clc$min_ecc + 2014,
    {E Values of type +P may not be compared.}

    cle$non_comparable_values       = clc$min_ecc + 2015,
    {E Values of types +P and +P may not be compared.}

    cle$only_compare_for_equality   = clc$min_ecc + 2087,
    {E Values of type +P may only be compared for equality or inequality.}

{ Date_Time  type conformance errors }

    cle$date_time_tenses_dont_match = clc$min_ecc + 2189,
    {E Date_Time tenses do not match.}

    cle$date_time_types_dont_match  = clc$min_ecc + 2190,
    {E Date_Time type identifiers do not match.}

{ Date_Time, Date and Time expression errors }

    cle$expecting_date_time_expr    = clc$min_ecc + 2016,
    {E Expecting DATE_TIME expression, found +P.}

    cle$impossible_date_or_time     = clc$min_ecc + 1430,
    {E One or more of the components of a DATE_TIME value is out of ..
    {range, or the components are mutually incompatible: +P.}

    cle$unrecognizable_date_time    = clc$min_ecc + 2018,
    {E Unrecognizable DATE_TIME expression: +P.}

    cle$wrong_date_time_tense       = clc$min_ecc + 2019,
    {E The tense for +P1 "+P4" (+P2) is wrong, it must be: +P3.}

{ Date_Time, Date and Time type specification errors }

    cle$expecting_date_time_tense   = clc$min_ecc + 2020,
    {E Expecting tense (PAST, PRESENT or FUTURE) in DATE/TIME type ..
    {specification, found +P.}

{ Field referencing errors }

    cle$expecting_field_name        = clc$min_ecc + 405,
    {E Expecting field name following "." qualifier of +P, found +P.}

    cle$unaccessible_field          = clc$min_ecc + 2022,
    {E Field +P cannot be accessed because of the values of other ..
    {fields within +P.}

    cle$undefined_field             = clc$min_ecc + 2023,
    {E Field +P within +P has not been assigned a value.}

    cle$unknown_field               = clc$min_ecc + 2024,
    {E +P is not a field within +P.}

{ Function call errors }

    cle$expecting_rparen_of_plist   = clc$min_ecc + 623,
    {E Expecting ")" of parameter list for function +P, found +P.}

    cle$function_is_read_only       = clc$min_ecc + 2017,
    {E Function +P can only be read; it may not be used as a variable or ..
    {parameter.}

    cle$no_function_result          = clc$min_ecc + 2026,
    {E No result was returned by function +P.}

    cle$qual_$value_is_read_only    = clc$min_ecc + 2063,
    {E When the $VALUE function is used to refer to a VAR parameter ..
    {only the parameter name may be given.}

    cle$unknown_function            = clc$min_ecc + 1090,
    {E +P is not a function.}

{ Integer type conformance errors }

    cle$integer_ranges_dont_match   = clc$min_ecc + 2096,
    {E Integer subranges do not match.}

    cle$integer_radices_dont_match  = clc$min_ecc + 2099,
    {E Integer default radices do not match.}

{ Integer type specification errors }

    cle$radix_out_of_range          = clc$min_ecc + 2028,
    {E The radix +P is out of range.  It must be between +P and +P.}

{ Keyword type conformance errors }

    cle$keywords_dont_match         = clc$min_ecc + 2107,
    {E Keywords do not match.}

{ Keyword expression errors }

    cle$unknown_keyword             = clc$min_ecc + 2029,
    {E +P is not a keyword.}

{ Keyword type specification errors }

    cle$duplicate_keyword           = clc$min_ecc + 2030,
    {E Duplicate keyword +P in +P declaration.}

    cle$expecting_key_in_spec       = clc$min_ecc + 2031,
    {E Expecting keyword in KEY type specification, found +P.}

    cle$no_advanced_usage_keywords  = clc$min_ecc + 2032,
    {E No keywords following ADVANCED_KEY in KEY type specification.}

    cle$no_hidden_keywords          = clc$min_ecc + 2033,
    {E No keywords following HIDDEN_KEY in KEY type specification.}

    cle$no_keywords                 = clc$min_ecc + 2034,
    {E No keywords in KEY type specification.}

    cle$no_normal_usage_keywords    = clc$min_ecc + 2035,
    {E No keywords before ADVANCED_KEY or HIDDEN_KEY in KEY type ..
    {specification.}

{ Line_identifier expression errors }

    cle$expecting_sequence_number   = clc$min_ecc + 2088,
    {E Expecting sequence number of line_identifier, found +P.

    cle$modification_name_too_long  = clc$min_ecc + 2036,
    {E The modification name +P is too long. It has more than 9 ..
    {characters.}

    cle$sequence_number_not_integer = clc$min_ecc + 2037,
    {E The line_identifier's sequence number must be an integer, not a ..
    {real number, but +P was given.}

    cle$sequence_num_out_of_range   = clc$min_ecc + 2038,
    {E The line_identifier's sequence number must be between 1 and ..
    {16777215, but +P was given.}

{ List type conformance errors }

    cle$defer_expans_doesnt_match   = clc$min_ecc + 2244,
    {E "DEFER_EXPANSION" qualifiers for the lists do not match.}

    cle$list_rest_doesnt_match      = clc$min_ecc + 2111,
    {E "REST" qualifiers for the lists do not match.}

    cle$list_sizes_dont_match       = clc$min_ecc + 2144,
    {E List size qualifiers do not match.}

    cle$undefined_value_in_list     = clc$min_ecc + 2240,
    {E An uninitialized value may not be the element of a list.}

    cle$unknown_array_to_list_value = clc$min_ecc + 2241,
    {E An uninitialized array element may not be the element of a list.}

    cle$unknown_list_element_type   = clc$min_ecc + 2192,
    {E An undefined type may not be the element of a list.}

{ List expression errors }

    cle$expecting_list_elem_sep     = clc$min_ecc + 2039,
    {E Expecting  space, ','  or ')' after list element, found +P.}

    cle$expecting_rparen_of_list    = clc$min_ecc + 2040,
    {E Expecting ")" of list, found +P.}

    cle$too_few_or_many_list_elems  = clc$min_ecc + 2041,
    {E +P elements given for list, but the number of elements must be ..
    {between +P and +P.}

{ List type specification errors }

    cle$expecting_of_for_list       = clc$min_ecc + 2042,
    {E Expecting OF in LIST type specification, found +P.}

    cle$improper_use_of_list_rest   = clc$min_ecc + 2043,
    {E The REST qualifier for a LIST type may only be specified for the ..
    {last field of a RECORD, or the last parameter of a function ..
    {(provided the parameter does not have the VAR attribute).}

    cle$list_bound_out_of_range     = clc$min_ecc + 2044,
    {E The list bound +P is out of range.  It must be between +P and +P.}

    cle$list_elem_type_required     = clc$min_ecc + 2045,
    {E In the declaration for a LIST type, the element type must be ..
    {specified unless the declaration is for the type of a command ..
    {(procedure) or function parameter.}

    cle$max_list_bound_omitted      = clc$min_ecc + 2046,
    {E The maximum bound for a list was omitted but must be given when ..
    {the minimum bound is given.}

    cle$min_list_bound_gt_max       = clc$min_ecc + 2047,
    {E The minimum bound for a list may not be greater than the ..
    {corresponding maximum bound.}

{ Miscellaneous type conformance errors }

    cle$undefined_type              = clc$min_ecc + 2193,
    {E Type is not defined.}

    cle$undefined_value             = clc$min_ecc + 2194,
    {E Value is not defined.}

    cle$value_not_union_type        = clc$min_ecc + 2195,
    {E Wrong kind of value or value out of range for a union (ANY) type.}

    cle$variable_not_union_type     = clc$min_ecc + 2228,
    {E Wrong kind of variable for a union (ANY) type for parameter +P.}

{ Miscellaneous declaration errors }

    cle$expecting_type_expression   = clc$min_ecc + 2048,
    {E Expecting type expression, found +P.}

{ Miscellaneous expression errors }

    cle$expecting_end_of_expression = clc$min_ecc + 310,
    {E Expecting end of expression, found +P.}

    cle$expecting_operand           = clc$min_ecc + 2050,
    {E Expecting operand of expression, found +P.}

    cle$expecting_rparen_of_subexpr = clc$min_ecc + 2051,
    {E Expecting ")" of subexpression, found +P.}

    cle$expression_not_union_type   = clc$min_ecc + 2052,
    {E Wrong kind of value, value out of range, or improper expression ..
    {for a union (ANY) type: +P.}

    cle$nonevaluable_deferred_value = clc$min_ecc + 2053,
    {E Unable to evaluate deferred value for +P.}

    cle$recursive_deferred_variable = clc$min_ecc + 2245,
    {E Recursive use of deferred variable or parameter +P is not allowed.}

    cle$unexpected_oper_for_unspec  = clc$min_ecc + 2054,
    {E A reference to unspecified (omitted) parameter +P may not be ..
    {the operand of the "+P" operator.}

    cle$unexpected_qual_for_unspec  = clc$min_ecc + 2055,
    {E A reference to unspecified (omitted) parameter +P may not be ..
    {followed by a subscript, substring, field reference or path ..
    {element; a "+P" was found.}

    cle$unspecified_value_for_list  = clc$min_ecc + 2233,
    {E A reference to unspecified (omitted) parameter +P may not be the ..
    {element value of a list or array.}

    cle$unspecified_value_for_range = clc$min_ecc + 2234,
    {E A reference to unspecified (omitted) parameter +P may not be the ..
    {low or high value of a range.}

    cle$unspecified_value_for_req   = clc$min_ecc + 2056,
    {E The +P request resulted in an unspecified value (omitted parameter +P).}

    cle$unspecified_value_for_state = clc$min_ecc + 2057,
    {E A reference to unspecified (omitted) parameter +P may not be given ..
    {as the expression for the +P statement.}

    cle$unrecognizable_data_value   = clc$min_ecc + 2058,
    {F Attempt to use unrecognizable value with the "+P" operator.}

    cle$wrong_kind_of_element_type  = clc$min_ecc + 2059,
    {E Wrong kind of list or array element type, expecting +P, found +P.}

    cle$wrong_kind_of_element_value = clc$min_ecc + 2060,
    {E Wrong kind of list or array element value, expecting +P, found +P ..
    {for element number +P.}

    cle$wrong_kind_of_value         = clc$min_ecc + 265,
    {E Wrong kind of value, expecting +P, found +P.}

{ Name type conformance errors }

    cle$name_sizes_dont_match       = clc$min_ecc + 2150,
    {E Name sizes do not match.}

{ Name expression errors }

    cle$name_value_too_long         = clc$min_ecc + 240,
    {E Name +P3 should not have more than +P1 characters in it but ..
    {it has +P2.}

    cle$name_value_too_short        = clc$min_ecc + 245,
    {E Name +P3 should have at least +P1 characters in it but it has ..
    {only +P2.}

{ Name type specification errors }

    cle$min_name_size_gt_max        = clc$min_ecc + 2064,
    {E The minimum size for a name may not be greater than the ..
    {corresponding maximum size.}

    cle$name_size_out_of_range      = clc$min_ecc + 2065,
    {E The name size +P is out of range.  It must be between +P and +P.}

{ Numeric expression errors }

    cle$arithmetic_operand_not_num  = clc$min_ecc + 2066,
    {E The operands of the "+P" operator must be numbers (integer or real), ..
    {a +P was found.}

    cle$arithmetic_overflow         = clc$min_ecc + 2067,
    {E Arithmetic overflow occurred attempting +P.}

    cle$arithmetic_significance     = clc$min_ecc + 2068,
    {E A loss of significant digits resulted from attempting +P.}

    cle$divide_fault                = clc$min_ecc + 2069,
    {E A divide fault (division by zero) occurred attempting +P.}

    cle$exponent_overflow           = clc$min_ecc + 2070,
    {E Exponent overflow occurred attempting +P.}

    cle$exponent_underflow          = clc$min_ecc + 2071,
    {E Exponent underflow occurred attempting +P.}

    cle$exponentiate_fault          = clc$min_ecc + 2072,
    {E Improper operands were used for exponentiation: +P. ..
    {The left operand may not be negative, and if the left operand is ..
    {zero the right operand may not be zero or negative.}

    cle$fp_indefinite               = clc$min_ecc + 2073,
    {E An indefinite value resulted from attempting +P.}

    cle$fp_significance_loss        = clc$min_ecc + 2074,
    {E A loss of significant digits resulted from attempting +P.}

    cle$integer_out_of_range        = clc$min_ecc + 225,
    {E The integer +P is out of range.  It must be between +P and +P.}

    cle$real_greater_than_integer   = clc$min_ecc + 2076,
    {E The real number +P cannot be converted to an integer because it is ..
    {not within the range of values -(2**63) and (2**63)-1.}

    cle$real_number_out_of_range    = clc$min_ecc + 2077,
    {E The real number +P is out of range.  It must be between +P and +P.}

{ Numeric type specification errors }

    cle$max_of_subrange_omitted     = clc$min_ecc + 2078,
    {E The maximum value for a subrange type may not be omitted .}

    cle$min_of_subrange_not_le_max  = clc$min_ecc + 2079,
    {E The minimum value for a subrange type must be less than or equal to ..
    {the corresponding maximum value.}

{ Parameter evaluation errors }

    cle$default_name_not_string     = clc$min_ecc + 2080,
    {E The default variable +P for parameter +P is not a string variable.}

    cle$defaulted_parameter_unspec  = clc$min_ecc + 2198,
    {E Parameter +P, for which a default value is declared, was specified ..
    {with an omitted procedure parameter.}

    cle$doubly_defined_parameter    = clc$min_ecc + 610,
    {E Parameter +P already given.}

    cle$expecting_default_term      = clc$min_ecc + 615,
    {E Expecting end of default value expression for parameter +P, found +P.}

    cle$expecting_parameter_term    = clc$min_ecc + 620,
    {E Expecting end of parameter +P, found +P.}

    cle$expecting_var_for_param     = clc$min_ecc + 2179,
    {E Expecting variable for parameter +P, found +P.}

    cle$by_name_not_by_name         = clc$min_ecc + 2246,
    {E A parameter with the BY_NAME attribute was given positionally.}

    cle$indeterminate_param_var     = clc$min_ecc + 2081,
    {E +P cannot be validated to conform to +P.}

    cle$omited_param_cant_have_qual = clc$min_ecc + 2236,
    {E A reference to unspecified (omitted) parameter +P may not be ..
    {followed by a subscript, substring, or field reference.

    cle$only_string_literal_for_par = clc$min_ecc + 2084,
    {E Only a literal quoted string is allowed for parameter +P. ..
    {No variables, function or operators may be used.}

    cle$p_application_name_mismatch = clc$min_ecc + 2199,
    {E Application type names do not match for parameter +P.}

    cle$p_array_bounds_dont_match   = clc$min_ecc + 2200,
    {E Array bounds do not match for parameter +P.}

    cle$p_balance_brackets_mismatch = clc$min_ecc + 2201,
    {E "BALANCE_BRACKETS" attributes do not match for parameter +P.}

    cle$p_date_time_tenses_mismatch = clc$min_ecc + 2202,
    {E Date_Time tenses do not match for parameter +P.}

    cle$p_date_time_types_mismatch  = clc$min_ecc + 2203,
    {E Date_Time type identifiers do not match for parameter +P.}

    cle$p_field_names_dont_match    = clc$min_ecc + 2204,
    {E Field names for records do not match for parameter +P.}

    cle$p_field_requiremnt_mismatch = clc$min_ecc + 2205,
    {E Field requirements for records do not match for parameter +P.}

    cle$p_field_types_dont_match    = clc$min_ecc + 2206,
    {E Wrong kind of record field type, expecting +P, found +P ..
    {for field +P for parameter +P.}

    cle$p_integer_radices_mismatch  = clc$min_ecc + 2207,
    {E Integer default radices do not match for parameter +P.}

    cle$p_integer_ranges_dont_match = clc$min_ecc + 2208,
    {E Integer subranges do not match for parameter +P.}

    cle$p_keywords_dont_match       = clc$min_ecc + 2209,
    {E Keywords do not match for parameter +P.}

    cle$p_list_rest_doesnt_match    = clc$min_ecc + 2210,
    {E "REST" qualifiers for the lists do not match for parameter +P.}

    cle$p_list_sizes_dont_match     = clc$min_ecc + 2211,
    {E List size qualifiers do not match for parameter +P.}

    cle$p_name_sizes_dont_match     = clc$min_ecc + 2212,
    {E Name sizes do not match for parameter +P.}

    cle$p_number_of_fields_mismatch = clc$min_ecc + 2213,
    {E Number of fields for records do not match for parameter +P.}

    cle$p_range_types_dont_match    = clc$min_ecc + 2214,
    {E Wrong kind of range type, expecting +P, found +P for parameter +P.}

    cle$p_real_subranges_dont_match = clc$min_ecc + 2215,
    {E Real subranges do not match for parameter +P.}

    cle$p_string_literals_mismatch  = clc$min_ecc + 2216,
    {E "LITERAL" qualifier for strings do not match for parameter +P.}

    cle$p_string_sizes_dont_match   = clc$min_ecc + 2217,
    {E String sizes do not match for parameter +P.}

    cle$p_undefined_type            = clc$min_ecc + 2218,
    {E Type is not defined for parameter +P.}

    cle$p_undefined_value           = clc$min_ecc + 2219,
    {E Value is not defined for parameter +P.}

    cle$p_unexpect_oper_for_unspec  = clc$min_ecc + 2235,
    {E A reference to unspecified (omitted) parameter +P may not be ..
    {the operand of the "+P" operator for parameter +P.}

    cle$p_unknown_array_elem_type   = clc$min_ecc + 2220,
    {E Undefined array element type for parameter +P.}

    cle$p_unknown_list_element_type = clc$min_ecc + 2221,
    {E Undefined list element type for parameter +P.}

    cle$p_unknown_range_elem_type   = clc$min_ecc + 2222,
    {E Undefined range element type for parameter +P.}

    cle$p_value_not_union_type      = clc$min_ecc + 2229,
    {E Wrong kind of value or value out of range for a union (ANY) type ..
    {for parameter +P.}

    cle$p_wrong_kind_of_elem_type   = clc$min_ecc + 2232,
    {E Wrong kind of list or array element type, expecting +P, found +P ..
    {for parameter +P.}

    cle$param_expr_not_union_type   = clc$min_ecc + 2085,
    {E Wrong kind of value, value out of range, or improper expression ..
    {for parameter +P: +P.}

    cle$param_not_spec_by_name      = clc$min_ecc + 648,
    {E Parameter +P must be specified by name but was given positionally ..
    {as: +P.}

    cle$parameter_never_given_value = clc$min_ecc + 2231,
    {E A reference was made to parameter +P, but no value has ever been ..
    {assigned to it.}

    cle$required_parameter_omitted  = clc$min_ecc + 650,
    {E Parameter +P is required but was omitted.}

    cle$required_parameter_unspec   = clc$min_ecc + 2224,
    {E Required parameter +P was specified with omitted procedure ..
    {parameter +P.}

    cle$secure_parameter_incorrect  = clc$min_ecc + 2230,
    {E Value for secure parameter +P is incorrect.}

    cle$too_many_parameters         = clc$min_ecc + 670,
    {E Too many parameters given.}

    cle$unexpected_in_param_list    = clc$min_ecc + 688,
    {E Unexpected +P in parameter list.}

    cle$unknown_parameter_keyword   = clc$min_ecc + 2090,
    {E +P is not a keyword for parameter +P.}

    cle$unknown_parameter_name      = clc$min_ecc + 690,
    {E +P is not a parameter name.}

    cle$value_given_positionally    = clc$min_ecc + 694,
    {E A parameter was given positionally but there is no parameter ..
    {defined for that position; value = +P.}

    cle$wrong_kind_of_param_value   = clc$min_ecc + 2093,
    {E Wrong kind of value, expecting +P, found +P for parameter +P.}

    cle$wrong_kind_of_param_var     = clc$min_ecc + 2180,
    {E Wrong kind of variable, expecting +P2, found +P3 for parameter +P1.}

{ Parameter specification errors }

    cle$advanced_parameter_conflict = clc$min_ecc + 2094,
    {E Specification conflict for parameter +P: a parameter with the ..
    {ADVANCED attribute may not also be a required parameter or have a ..
    {default option of $CONFIRM.}

    cle$by_name_in_function         = clc$min_ecc + 2095,
    {E The BY_NAME attribute, specified for parameter +P, may not be used in ..
    {a function declaration.}

    cle$defer_with_var              = clc$min_ecc + 2097,
    {E Attribute conflict for parameter +P: a parameter with the VAR ..
    {attribute may not also have the DEFER attribute.}

    cle$duplicate_parameter_attr    = clc$min_ecc + 2098,
    {E Duplicate attribute +P for parameter +P.}

    cle$duplicate_parameter_name    = clc$min_ecc + 810,
    {E Duplicate parameter name +P in +P declaration.}

    cle$expecting_parameter_attr    = clc$min_ecc + 2100,
    {E Expecting attribute for parameter +P, found +P.}

    cle$expecting_parameter_name    = clc$min_ecc + 2101,
    {E Expecting parameter name in +P declaration, found +P.

    cle$expecting_end_of_param_spec = clc$min_ecc + 2227,
    {E Expecting semicolon or end of line after specification for parameter ..
    {+P, found +P.}

    cle$expecting_parameter_spec    = clc$min_ecc + 2102,
    {E Expecting parameter specification in +P declaration, found +P.}

    cle$function_parameter_one_name = clc$min_ecc + 2103,
    {E Function parameter +P declared with more than one name.}

    cle$hidden_parameter_conflict   = clc$min_ecc + 2104,
    {E Specification conflict for parameter +P: a parameter with the HIDDEN ..
    {attribute may not also be a required parameter or have a default option ..
    {of $CONFIRM.}

    cle$no_type_for_function_param  = clc$min_ecc + 2105,
    {E Type specification for function parameter +P missing, found +P.}

    cle$secure_param_in_function    = clc$min_ecc + 2178,
    {E The SECURE attribute, specified for parameter +P, may not be used ..
    {in a function declaration.}

    cle$secure_with_var             = clc$min_ecc + 2177,
    {E Attribute conflict for parameter +P: a parameter with the VAR ..
    {attribute may not also have the SECURE attribute.}

    cle$unsupported_parameter_spec  = clc$min_ecc + 692,
    {E "VAR (or ARRAY) OF type" is not supported in combination with ..
    {LIST, RANGE, or KEY specifications (parameter +P).}

    cle$var_param_in_function       = clc$min_ecc + 2176,
    {E The VAR attribute, specified for parameter +P, may not be used in ..
    {a function declaration.}

{ Procedure / Function declaration errors }

    cle$duplicate_proc_attribute    = clc$min_ecc + 2106,
    {E Duplicate +P attribute in +P declaration.}

    cle$duplicate_proc_name         = clc$min_ecc + 815,
    {E Duplicate name +P in +P declaration.}

    cle$expecting_proc_attribute    = clc$min_ecc + 2108,
    {E Expecting +P attribute, found +P.}

    cle$expecting_proc_func_or_type = clc$min_ecc + 2109,
    {E Expecting PROCEDURE, FUNCTION, or TYPE, found +P.}

    cle$expecting_proc_header_term  = clc$min_ecc + 2110,
    {E Expecting ";" or end of line after +P declaration, found +P.

    cle$expecting_proc_name         = clc$min_ecc + 855,
    {E Expecting +P name in declaration, found +P.}

    cle$function_name_needs_$       = clc$min_ecc + 2112,
    {E Function name +P does not begin with a "$" character.}

    cle$proc_scope_attr_conflict    = clc$min_ecc + 2113,
    {E Attribute conflict in +P declaration: LOCAL may not be used with XDCL ..
    {or GATE.}

{ Program_name expression errors }

    cle$null_program_name           = clc$min_ecc + 2114,
    {E A string specified for a program_name may not be null or blank.}

    cle$program_name_too_long       = clc$min_ecc + 2115,
    {E Program name string '+P' is too long. It has more than 31 characters.}

{ Range type conformance errors }

    cle$range_types_dont_match      = clc$min_ecc + 2163,
    {E Wrong kind of range type, expecting +P, found +P.}

    cle$undefined_value_in_range    = clc$min_ecc + 2242,
    {E An uninitialized value may not be the low or high value of a range.}

    cle$unknown_range_element_type  = clc$min_ecc + 2196,
    {E An undefined type may not be the low or high value of a range.}

{ Range referencing errors }

    cle$undefined_range_selector    = clc$min_ecc + 2089,
    {E Range selector +P for +P has not been assigned a value.}

    cle$unknown_range_selector      = clc$min_ecc + 2091,
    {E +P is not a range selector for +P.  It must be 'LOW' or 'HIGH'.}

{ Range type specification errors }

    cle$range_elem_type_required    = clc$min_ecc + 2116,
    {E In the declaration for a RANGE type, the element type must be ..
    {specified unless the declaration is for the type of a command ..
    {(procedure) or function parameter.}

    cle$expecting_of_for_range      = clc$min_ecc + 2117,
    {E Expecting OF in RANGE type specification, found +P.}

{ Real type conformance errors }

    cle$real_subranges_dont_match   = clc$min_ecc + 2164,
    {E Real subranges do not match.}

{ Record type conformance errors }

    cle$field_names_dont_match      = clc$min_ecc + 2173,
    {E Field names for records do not match.}

    cle$field_requirements_mismatch = clc$min_ecc + 2175,
    {E Field requirements for records do not match.}

    cle$field_types_dont_match      = clc$min_ecc + 2181,
    {E Wrong kind of record field type, expecting +P, found +P ..
    {for field +P.}

    cle$number_of_fields_dont_match = clc$min_ecc + 2182,
    {E Number of fields for records do not match.}

{ Record expression errors }

    cle$expecting_rparen_of_flist   = clc$min_ecc + 2118,
    {E Expecting ")" for field list of +P, found +P.}

    cle$field_expr_not_union_type   = clc$min_ecc + 2119,
    {E Wrong kind of value, value out of range, or improper expression ..
    {for field +P: +P.}

    cle$only_string_literal_for_fld = clc$min_ecc + 2120,
    {E Only a literal quoted string is allowed for field +P of +P. ..
    {No variables functions or operators may be used.}

    cle$required_field_omitted      = clc$min_ecc + 2121,
    {E Field +P for +P is required but was omitted.}

    cle$required_field_unspecified  = clc$min_ecc + 2225,
    {E Required field +P1 for +P3 was specified with omitted procedure ..
    {parameter +P2.}

    cle$too_many_fields             = clc$min_ecc + 2122,
    {E Too many fields for +P.}

    cle$unexpected_in_field_list    = clc$min_ecc + 2123,
    {E Unexpected +P in field list for +P.}

    cle$unknown_field_keyword       = clc$min_ecc + 2124,
    {E +P is not a keyword for field +P of +P.}

    cle$wrong_kind_of_field_value   = clc$min_ecc + 2125,
    {E Wrong kind of value, expecting +P, found +P for field +P of +P.}

{ Record type specification errors }

    cle$duplicate_field_name        = clc$min_ecc + 2223,
    {E Duplicate field name +P in RECORD type specification.}

    cle$expecting_after_field_name  = clc$min_ecc + 2126,
    {E Expecting ":" after field name +P in RECORD type specification, ..
    {found +P.}

    cle$expecting_after_field_spec  = clc$min_ecc + 2127,
    {E Expecting "," or ";" or end of line after specification for field +P ..
    {in RECORD type specification, found +P.}

    cle$expecting_field_attribute   = clc$min_ecc + 2128,
    {E Expecting attribute for field +P in RECORD type specification, ..
    {found +P.}

    cle$expecting_field_requirement = clc$min_ecc + 2129,
    {E Expecting $REQUIRED or $OPTIONAL for field +P in RECORD type ..
    {specification, found +P.}

    cle$expecting_record_field_name = clc$min_ecc + 2130,
    {E Expecting field name in RECORD type specification, found +P.}

    cle$no_record_fields            = clc$min_ecc + 2131,
    {E No fields in RECORD type specification.}

{ Statistic_code expression errors }

    cle$statistic_code_out_of_range = clc$min_ecc + 2132,
    {E An integer for a statistic code must be between 0 and ..
    {0ffffffffff(16), but +P was given.}

    cle$unrecognizable_statist_name = clc$min_ecc + 2133,
    {E A statistic code may be specified by a name of the form "xxnnn" ..
    {or "xx_nnn", where xx is the code's 2 character product identifier ..
    {and nnn is an unsigned decimal number between 0 and 16777215. ..
    {The following was specified: +P.}

    cle$unrecognizable_statist_str  = clc$min_ecc + 2134,
    {E A statistic code may be specified by a string of the form "XX nnn", ..
    {where XX is the code's 2 character product identifier and is an ..
    {unsigned decimal number between 0 and 16777215. ..
    {The following was specified: +P.}

{ Status_code expression errors }

    cle$status_code_out_of_range    = clc$min_ecc + 2135,
    {E An integer for a status code must be between 0 and ..
    {0ffffffffff(16), but +P was given.}

    cle$unknown_status_code_name    = clc$min_ecc + 2243,
    {E +P is not a status code name.}

    cle$unrecognizable_status_name  = clc$min_ecc + 2136,
    {E A status code may be specified by a name of the form "xxnnn" ..
    {or "xx_nnn", where xx is the code's 2 character product identifier ..
    {and nnn is an unsigned decimal number between 0 and 16777215. ..
    {The following was specified: +P.}

    cle$unrecognizable_status_str   = clc$min_ecc + 2137,
    {E A status code may be specified by a string of the form "XX nnn", ..
    {where XX is the code's 2 character product identifier and nnn is an ..
    {unsigned decimal number between 0 and 16777215. ..
    {The following was specified: +P.}

{ String type conformance errors }

    cle$string_literals_dont_match  = clc$min_ecc + 2183,
    {E "LITERAL" qualifier for strings do not match.}

    cle$string_sizes_dont_match     = clc$min_ecc + 2184,
    {E String sizes do not match.}

{ String expression errors }

    cle$concat_left_op_not_str      = clc$min_ecc + 2138,
    {E The left operand of the "//" operator must be a string, a +P was found.}

    cle$concat_right_op_not_str     = clc$min_ecc + 2139,
    {E The right operand of the "//" operator must be a string or ..
    {representable as a single string, a +P was found.}

    cle$concatenated_str_too_long   = clc$min_ecc + 2140,
    {E The concatenation of strings via the "//" operator resulted in a ..
    {string that exceeded the maximum string size of 65535 characters.}

    cle$only_string_literal_allowed = clc$min_ecc + 2141,
    {E Only a literal quoted string is allowed.  No variables, function or ..
    {operators may be used.}

    cle$string_value_too_long       = clc$min_ecc + 2142,
    {E String '+P3' should not have more than +P1 characters in it but ..
    {contains +P2.}

    cle$string_value_too_short      = clc$min_ecc + 2143,
    {E String '+P3' should have at least +P1 characters in it but contains ..
    {only +P2.}

{ String type specification errors }

    cle$min_string_size_gt_max      = clc$min_ecc + 2145,
    {E The minimum size for a string may not be greater than the ..
    {corresponding maximum size.}

    cle$string_size_out_of_range    = clc$min_ecc + 2146,
    {E The string size +P is out of range.  It must be between +P and +P.}

{ Subscript referencing errors }

    cle$expecting_rparen_of_subscr  = clc$min_ecc + 2147,
    {E Expecting ")" of subscript qualifier used with +P, found +P.}

    cle$list_subscript_too_large    = clc$min_ecc + 2148,
    {E The subscript +P2 used with +P1 is greater than the current ..
    {number of elements in the list (+P3).}

    cle$list_subscript_too_small    = clc$min_ecc + 2149,
    {E The subscript +P2 used with +P1 is too small to be used with a ..
    {list.  A list subscript must be greater than or equal to 1.}

    cle$max_list_subscript_error    = clc$min_ecc + 2086,
    {E The subscript +P2 used with +P1 is greater than the maximum ..
    {number of allowed elements in the list (+P3).}

    cle$subscript_out_of_max_range  = clc$min_ecc + 2083,
    {E The subscript +P2 used with +P1 is out of range.  It must be ..
    {between the maximum range +P3 and +P4.}

    cle$subscript_out_of_range      = clc$min_ecc + 455,
    {E The subscript +P2 used with +P1 is out of range.  It must be ..
    {between +P3 and +P4.}

    cle$undefined_subscr_element    = clc$min_ecc + 2151,
    {E Element +P2 within +P1 has not been assigned a value.}

{ Substring referencing errors }

    cle$expecting_rparen_of_substr  = clc$min_ecc + 2152,
    {E Expecting ")" of substring qualifier used with +P, found +P.}

    cle$max_substr_index_error      = clc$min_ecc + 2082,
    {E The substring index +P2 used with +P1 is out of range.  It must be ..
    {between 1 and the maximum allowed index of +P3.}

    cle$substr_index_out_of_range   = clc$min_ecc + 2153,
    {E The substring index +P2 used with +P1 is out of range.  It must be ..
    {between 1 and +P3.}

    cle$substr_size_out_of_range    = clc$min_ecc + 2154,
    {E The substring size +P2 used with +P1 is out of range.  It must be ..
    {between 0 and +P3.}

{ Time_Increment expression errors }

    cle$expecting_date_time_operand = clc$min_ecc + 2155,
    {E Expecting DATE_TIME after "-" in TIME_INCREMENT expression, found +P.}

    cle$expecting_date_time_subtrct = clc$min_ecc + 2156,
    {E Expecting "-" after DATE_TIME in TIME_INCREMENT expression, found +P.}

    cle$expecting_time_incr_expr    = clc$min_ecc + 2157,
    {E Expecting TIME_INCREMENT expression, found +P.}

    cle$expecting_time_incr_operand = clc$min_ecc + 2158,
    {E Expecting TIME_INCREMENT variable or function after +P, found +P.}

    cle$expecting_time_zone_operand = clc$min_ecc + 2159,
    {E Expecting TIME_ZONE after "-" in TIME_INCREMENT expression, found +P.}

    cle$expecting_time_zone_subtrct = clc$min_ecc + 2160,
    {E Expecting "-" after TIME_ZONE in TIME_INCREMENT expression, found +P.}

    cle$unrecognizable_time_incr    = clc$min_ecc + 2161,
    {E Unrecognizable TIME_INCREMENT expression: +P.}

{ Time_Zone expression errors }

    cle$expecting_time_zone_expr    = clc$min_ecc + 2162,
    {E Expecting TIME_ZONE expression, found +P.}

    cle$impossible_time_zone        = clc$min_ecc + 275,
    {E One or more of the components of a TIME_ZONE value is out of range, ..
    {or the components are mutually incompatible: +P.}

    cle$unrecognizable_time_zone    = clc$min_ecc + 280,
    {E Unrecognizable TIME_ZONE expression: +P.}

{ Type specification errors }

    cle$expecting_after_type_def    = clc$min_ecc + 2165,
    {E Expecting comma, semicolon or end of line after TYPE definition, ..
    {found +P.}

    cle$expecting_after_type_name   = clc$min_ecc + 2166,
    {E Expecting : or = after TYPE name, found +P.}

    cle$expecting_type_name         = clc$min_ecc + 2167,
    {E Expecting TYPE name, found +P.}

    cle$expecting_typend            = clc$min_ecc + 2168,
    {E Expecting TYPEND, found +P.}

{ Union (Any) type specification errors }

    cle$expecting_after_member_spec = clc$min_ecc + 2169,
    {E Expecting "," or ";" or end of line after member type specification ..
    {in ANY specification, found +P.}

    cle$expecting_of_for_any        = clc$min_ecc + 2170,
    {E Expecting OF in ANY type specification, found +P.}

    cle$inconsistent_radix_in_union = clc$min_ecc + 2171,
    {E Numeric member types of a union type specified different radices. ..
    {If multiple integer types are specified they must have identical ..
    {radices.  If integer and real types are specified, the radix for ..
    {the integer types must be 10.}

    cle$no_union_members            = clc$min_ecc + 2172,
    {E No member types in ANY type specification.}

{ Variable reference and specification errors }

    cle$bad_function_result         = clc$min_ecc + 401,
    {E A bad function result was found for variable +P.}

    cle$bad_value_qualifier         = clc$min_ecc + 402,
    {E Bad value qualifier encountered for variable +P.}

    cle$bad_variable_access_mode    = clc$min_ecc + 400,
    {E Improper access mode specification for variable +P.}

    cle$bad_variable_eval_method    = clc$min_ecc + 414,
    {E Improper evaluation method specification for variable +P.}

    cle$bad_variable_kind           = clc$min_ecc + 403,
    {E Improper kind specification for variable +P.}

    cle$bad_variable_scope          = clc$min_ecc + 407,
    {E Improper scope specification for variable +P.}

    cle$bad_variable_string_size    = clc$min_ecc + 412,
    {E Improper string size specification for variable +P.}

    cle$cannot_assign_to_a_read_var = clc$min_ecc + 404,
    {E Cannot assign a value to a read only variable: +P.}

    cle$cannot_initialize_component = clc$min_ecc + 406,
    {E Can only initialize by component an array or record in variable +P.}

    cle$cannot_push_variable        = clc$min_ecc + 423,
    {E Cannot push variable +P because it is not an environment variable.}

    cle$cannot_read_component       = clc$min_ecc + 408,
    {E Cannot get the component value of variable +P ..
    {because the variable is uninitialized.}

    cle$cannot_read_omitted_param   = clc$min_ecc + 419,
    {E Cannot read an omitted parameter, +P.}

    cle$cannot_write_omitted_param   = clc$min_ecc + 421,
    {E Cannot write to an omitted parameter, +P.}

    cle$duplicate_variable_attr     = clc$min_ecc + 2049,
    {E Duplicate attribute +P for variable +P.}

    cle$expecting_after_var_def     = clc$min_ecc + 2021,
    {E Expecting semicolon or end of line after VAR definition, found +P.}

    cle$expecting_after_var_name    = clc$min_ecc + 2025,
    {E Expecting colon after VAR name, found +P.}

    cle$expecting_variable_attr     = clc$min_ecc + 2061,
    {E Expecting attribute for variable +P, found +P.}

    cle$expecting_variable_name     = clc$min_ecc + 415,
    {E Expecting variable name, found +P.}

    cle$improper_array_bounds       = clc$min_ecc + 426,
    {E Lowerbound must be <= upperbound for variable +P.}

    cle$improper_use_of_$           = clc$min_ecc + 427,
    {E $ improper first character in declaration of +P.}

    cle$improper_use_of_defer_value = clc$min_ecc + 2187,
    {E A deferred value cannot be assigned to a component of ..
    {variable +P.}

    cle$improper_use_of_defer_var   = clc$min_ecc + 2188,
    {E Cannot assign a value to a component of variable +P ..
    {because it has the deferred attribute.}

    cle$improper_var_specification  = clc$min_ecc + 428,
    {E Improper attributes for variable +P.}

    cle$improper_variable_name      = clc$min_ecc + 429,
    {E Improper variable name: +P.}

    cle$improper_variable_requests  = clc$min_ecc + 2237,
    {E Improper access requests for variable +P.}

    cle$improper_variable_value     = clc$min_ecc + 431,
    {E Improper value for variable: +P.}

    cle$incompatible_assignment     = clc$min_ecc + 442,
    {E Wrong kind of value for variable: +P.}

    cle$initial_name_not_string     = clc$min_ecc + 2075,
    {E The "initial variable" +P for variable +P is not a string variable.}

    cle$internal_read_qualifier_err  = clc$min_ecc + 2238,
    {E An internal error was encountered while trying ..
    {to read variable: +P.  An invalid qualifier was ..
    {detected.}

    cle$improper_parameter_value  = clc$min_ecc + 2239,
    {E Value +P is improper for the parameter type.}

    cle$internal_read_variable_err  = clc$min_ecc + 422,
    {E An internal error was encountered while trying ..
    {to read variable: +P.  The type description does not ..
    {match the current value.}

    cle$must_specify_new_data_value = clc$min_ecc + 418,
    {E Must specify new value in order to change the value ..
    {of variable +P.}

    cle$no_space_for_variable       = clc$min_ecc + 444,
    {E Not enough space to hold variable +P.}

    cle$not_a_variable_attribute    = clc$min_ecc + 2062,
    {E "+P" is not a variable attribute.}

    cle$not_a_variable_kind         = clc$min_ecc + 445,
    {E The initial value kind for variable +P is not ..
    {assignable to a variable.

    cle$no_type_spec_specified      = clc$min_ecc + 416,
    {E No type specification given for variable +P.}

    cle$read_var_requires_value     = clc$min_ecc + 2027,
    {E Variable, +P, defined with the read attribute must be ..
    {given an initial value.}

    cle$special_name_use            = clc$min_ecc + 453,
    {E +P identifies a boolean constant and therefore may not be ..
    {used as a variable name.}

    cle$undefined_variable_field    = clc$min_ecc + 465,
    {E Field +P is not meaningful in current value of variable +P.}

    cle$undefined_var_qualifier     = clc$min_ecc + 409,
    {E Component after field +P is not meaningful in current value ..
    {of variable +P.}

    cle$undefined_var_subscript     = clc$min_ecc + 411,
    {E Subscript +P2 is not meaningful in current value of variable +P1.}

    cle$undefined_var_substring     = clc$min_ecc + 413,
    {E Substring is not meaningful in current value of variable +P.}

    cle$variable_never_given_value  = clc$min_ecc + 2174,
    {E A reference was made to variable +P, but no value has ever been ..
    {assigned to it.}

    cle$xref_var_cannot_have_value  = clc$min_ecc + 417,
    {E Cannot create variable +P with an XREF scope and ..
    { an initial value.

    clc$max_ecc_parsing             = clc$min_ecc + 2999;

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$ECC_PROC_DECLARATION EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??
{
{ CLE$ECC_proc_declaration has the following unused code offsets:
{
{ 800..804 806..809 811..814 816..819 821..824 826..829 831..834 836..839
{ 841..844 846..849 851..854 856..859 861..864 866..869 871..874 876..879
{ 881..884 886..889 891..899 901..904 906..909 911..914 916..919 921..924
{ 926..929 931..934 936..939 941..944 946..949 951..954 956..959 961..964
{ 966..969 971..999
{

  CONST
    clc$min_ecc_proc_declaration    = clc$min_ecc + 800,

    cle$duplicate_keyword_value     = clc$min_ecc + 805,
    {E Duplicated keyword value: +P.}

    cle$expecting_avs_name          = clc$min_ecc + 820,
    {E Expecting name for application value scanner, found +P.}

    cle$expecting_command_separator = clc$min_ecc + 825,
    {E Expecting ';' or END OF LINE, found +P.}

    cle$expecting_key_spec          = clc$min_ecc + 830,
    {E Expecting KEY, found +P.}

    cle$expecting_param_def         = clc$min_ecc + 835,
    {E Expecting parameter definition, found +P.}

    cle$expecting_param_def_sep     = clc$min_ecc + 840,
    {E Expecting ';' or END OF LINE, found +P.}

    cle$expecting_param_name        = clc$min_ecc + 845,
    {E Expecting parameter name, found +P.}

    cle$expecting_value_kind        = clc$min_ecc + 860,
    {E Expecting value kind name, found +P.}

    cle$expecting_var_kind          = clc$min_ecc + 865,
    {E Expecting variable kind name, found +P.}

    cle$integer_uppervalue_omitted  = clc$min_ecc + 870,
    {E Uppervalue for +P omitted.}

    cle$low_greater_than_high       = clc$min_ecc + 875,
    {E Low greater than high for +P.}

    cle$too_many_parameter_defs     = clc$min_ecc + 880,
    {E Too many parameter definitions.}

    cle$too_many_parameter_names    = clc$min_ecc + 885,
    {E Too many parameter names.}

    cle$too_many_names_for_pdt      = clc$min_ecc + 890,
    {E Only one name allowed for PDT.}

    cle$unexpected_after_integer    = clc$min_ecc + 900,
    {E Unexpected +P after INTEGER.}

    cle$unexpected_after_key        = clc$min_ecc + 905,
    {E Unexpected +P after KEY.}

    cle$unexpected_after_list       = clc$min_ecc + 910,
    {E Unexpected +P after LIST.}

    cle$unexpected_after_name       = clc$min_ecc + 915,
    {E Unexpected +P after NAME.}

    cle$unexpected_after_of         = clc$min_ecc + 920,
    {E Unexpected +P after OF.}

    cle$unexpected_after_param_name = clc$min_ecc + 925,
    {E Unexpected +P after parameter name.}

    cle$unexpected_after_proc       = clc$min_ecc + 930,
    {E Unexpected +P2 after +P1.}

    cle$unexpected_after_proc_name  = clc$min_ecc + 935,
    {E Unexpected +P after proc name.}

    cle$unexpected_after_range      = clc$min_ecc + 940,
    {E Unexpected +P after RANGE.}

    cle$unexpected_after_string     = clc$min_ecc + 945,
    {E Unexpected +P after STRING.}

    cle$unexpected_after_value_kind = clc$min_ecc + 950,
    {E Unexpected +P after value kind.}

    cle$unexpected_after_var        = clc$min_ecc + 955,
    {E Unexpected +P after VAR.}

    cle$unexpected_after_vc_spec    = clc$min_ecc + 960,
    {E Unexpected +P after value count.}

    cle$unexpected_after_vsc_spec   = clc$min_ecc + 965,
    {E Unexpected +P after value set count.}

    cle$unexpected_of_after_comma   = clc$min_ecc + 970,
    {E Unexpected OF after ','.}

    clc$max_ecc_proc_declaration    = clc$min_ecc + 999;

?? FMT (FORMAT := ON) ??
*copyc cle$ecc_parsing
*copyc cle$expecting_proc
*DECK DECK=CLE$ECC_SCL_FORMATTER EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??
{
{ CLE$ECC_scl_formatter has the following unused code offsets:
{
{ 9500..9509 9511..9519 9521..9539 9541..9559 9561..9579 9581..9599 9601..9619
{ 9621..9639 9641..9659 9661..9679 9681..9999
{

  CONST
    clc$min_ecc_scl_formatter       = clc$min_ecc + 9500,

    cle$cannot_be_translated        = clc$min_ecc + 9510,
    {E +P can not be translated.}

    cle$duplicate_utility_name      = clc$min_ecc + 9520,
    {E Utility name +P already specified.}

    cle$errors_and_warnings         = clc$min_ecc + 9540,
    {E +P Error messages.  +P Warning messages.}

    cle$errors_encountered          = clc$min_ecc + 9560,
    {E +P Error messages.}

    cle$internal_formatter_error    = clc$min_ecc + 9580,
    {W Internal formatter error - +P.}

    cle$max_error_count_reached     = clc$min_ecc + 9600,
    {E Maximum number of errors (+P) encountered.}

    cle$page_width_too_small        = clc$min_ecc + 9620,
    {E PAGE_WIDTH value must be at least +P greater than ..
    {INITIAL_IDENT_COLUMN value.}

    cle$too_many_names              = clc$min_ecc + 9640,
    {E Utility +P count exceeded.}

    cle$utility_same_as_end         = clc$min_ecc + 9660,
    {E Utility name +P same as terminator name.}

    cle$warnings_encountered        = clc$min_ecc + 9680,
    {W +P Warning messages.}

    clc$max_ecc_scl_formatter       = clc$min_ecc + 9999;

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$ECC_UTILITIES EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

{ CLE$ECC_UTILITIES has the following unused code offsets:
{
{ 1500..1501 1503 1505 1507 1509 1511 1513 1517 1519 1521 1523 1525 1527
{ 1529 1531..1599


  CONST
    clc$min_ecc_utilities           = clc$min_ecc + 1500,

    cle$cannot_move_utility_entry   = clc$min_ecc + 1502,
    {E Utility command list entries cannot be moved in the command list.}

    cle$command_source_not_lib      = clc$min_ecc + 1504,
    {E Command source is not a library.}

    cle$command_source_unknown      = clc$min_ecc + 1506,
    {E Command source is unknown.}

    cle$improper_utility_attribute  = clc$min_ecc + 1508,
    {E Utility attributes had key(s) that do not apply to this request ..
    {in array element(s): +P. }

    cle$improper_utility_attr_value = clc$min_ecc + 1510,
    {E Utility attributes had improper value(s) in array element(s): +P. }

    cle$improper_utility_name       = clc$min_ecc + 1512,
    {E +P may not be used as a utility name.}

    cle$include_processor_active    = clc$min_ecc + 1514,
    {W Interactive include processor for utility +P is currently ..
    {active. The processor is ignored.}

    cle$no_utility_active           = clc$min_ecc + 1515,
    {E No utility is currently active.}

    cle$term_command_not_defined    = clc$min_ecc + 1516,
    {E Termination command +P not defined in command table.}

    cle$unable_to_call_inc_procesor = clc$min_ecc + 1518,
    {E Unable to call interactive include processor: +P.}

    cle$unable_to_call_preprocessor = clc$min_ecc + 1520,
    {E Unable to call line preprocessor: +P.}

    cle$unknown_utility_attribute   = clc$min_ecc + 1522,
    {E Utility attributes had unknown key(s) in array element(s): +P.}

    cle$util_cmds_fctns_unavailable = clc$min_ecc + 1524,
    {E Utility command/function +P is not available.}

    cle$utility_left_in_cmnd_list   = clc$min_ecc + 1526,
    {W Utility commands/functions left in the command list.}

    cle$unknown_utility             = clc$min_ecc + 1528,
    {E +P does not designate a utility that is currently active.}

    cle$inaccessible_utility        = clc$min_ecc + 1530,
    {E The utility +P cannot be accessed by +P.}

    clc$max_ecc_utilities           = clc$min_ecc + 1599;

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$ECC_VARIABLE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

{ This deck (cle$ecc_variable) should no longer be used.
{ Do *copyc's of the decks containing the exception condition codes
{ you need.  Note that the codes defined directly within this deck
{ are no longer produced by the SCL interpreter; they continue to be
{ defined for "compatibility" with previous systems.

  CONST
    clc$min_ecc_variable            = clc$min_ecc + 400,

    cle$expecting_subscript_term    = clc$min_ecc + 410,
    {E Expecting ')' of subscript, found +P.}

    cle$expecting_var_kind_name     = clc$min_ecc + 420,
    {E Expecting variable kind name, found +P.}

    cle$expecting_var_string_size   = clc$min_ecc + 425,
    {E Expecting maximum string size, found +P.}

    cle$improper_variable_reference = clc$min_ecc + 430,
    {E Improper variable reference: +P.}

    cle$only_qualify_string_var     = clc$min_ecc + 450,
    {E Only variable kind STRING can be qualified.}

    cle$undefined_var_attribute     = clc$min_ecc + 467,
    {E The +P attribute is not meaningful for variable +P.}

    cle$unexpected_after_variable   = clc$min_ecc + 470,
    {E Unexpected +P after variable reference.}

    cle$unexpected_field_name       = clc$min_ecc + 475,
    {E Field names (+P) are not defined for variable +P.}

    cle$unknown_variable_field      = clc$min_ecc + 480,
    {E +P is not a field of variable +P.}

    clc$max_ecc_variable            = clc$min_ecc + 499;

?? FMT (FORMAT := ON) ??
*copyc cle$ecc_parsing
*copyc cle$unknown_variable
*copyc cle$var_already_created
*DECK DECK=CLE$EMPTY_FILE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$empty_file                  = clc$min_ecc + 15;
    {E File +F is empty.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$ENCOUNTERED_EOI EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$encountered_eoi             = clc$min_ecc + 20;
    {W +P encountered EOI.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$EOI_IN_DECLARATION EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$eoi_in_declaration          = clc$min_ecc + 26;
    {E End of input encountered while processing +P declaration.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$EPILOG_FILE_MISSING EXPAND=FALSE

*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$epilog_file_missing         = clc$min_ecc + 23;
    {I Epilog file, +F does not exist or you are not permitted for any access.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$EXCEPTION_CONDITION_CODES EXPAND=FALSE
?? NEWTITLE := 'CLE$EXCEPTION_CONDITION_CODES --- ''CL'' 0 .. 9999', EJECT ??
*copyc clc$ecc_range
?? NEWTITLE := 'CL ECC miscellaneous', EJECT ??
{
{ The following offsets are available for "miscellaneous" codes:
{
{ 34 36 38..39 41 44 46..49 51..54 56..59 61 63..64 66 71..84
{ 86..89 91..94
{ 200..204 206..209 211..214 216..224 226..234 236..239 241..244 246..249
{ 251..254 256..257 259 261..264 266..269 271..274 276..279 281..299
{ 300..304 306..309 311..314 316..319 321..324 326..329 331..334 336..339
{ 341..344 346..399
{ 424 432..441 443 446..449 451..452 454 456..459 461..464
{ 466 468..469 471..474 476..479 481..489 491..499
{ 600..604 606 608..609 611..614 616..619 621..622 624 626..629 631..634
{ 636..639 641..644 649 651..652 654 656..659 661..664 666..669 671..674
{ 676..679 681..684 689 691 693 696..699
{ 1000..1004 1006..1019 1021..1029 1031..1059 1061..1069 1071..1079 1081..1089
{ 1091..1099
{ 1200..1259 1261..1279 1281..1299
{ 1606..1999
{ 3000..3999
{ 4000..4999
{ 5000..5024 5026..5029 5031..5999
{ 6000..6999
{ 7006..7013 7016..7999
{ 8500..8999
{
*copyc cle$all_must_be_used_alone
*copyc cle$awaiting_task_termination
*copyc cle$bad_application_task_link
*copyc cle$bad_clt$value
*copyc cle$bad_clt$variable_value
*copyc cle$bad_data_rep_option
*copyc cle$bad_data_value
*copyc cle$bad_declaration_version
*copyc cle$bad_keyword_type_spec
*copyc cle$bad_parameter_list
*copyc cle$bad_pdt
*copyc cle$bad_pvt
*copyc cle$bad_string_pattern
*copyc cle$bad_type_description
*copyc cle$bad_type_specification
*copyc cle$bad_unseen_mail_action
*copyc cle$bad_wild_card_pattern
*copyc cle$block_access_count_error
*copyc cle$cannot_access_unit_array
*copyc cle$command_cancelled
*copyc cle$command_line_cancelled
*copyc cle$command_terminated
*copyc cle$compare_errors_detected
*copyc cle$compared_files_unequal_size
*copyc cle$conflicting_options_spec
*copyc cle$detached_jobs
*copyc cle$empty_file
*copyc cle$encountered_eoi
*copyc cle$eoi_in_declaration
*copyc cle$epilog_file_missing
*copyc cle$expecting_proc
*copyc cle$file_never_opened
*copyc cle$file_reference_conflict
*copyc cle$function_cancelled
*copyc cle$improper_substitution_mark
*copyc cle$improper_use_of_subst_mark
*copyc cle$incompatible_params_given
*copyc cle$interactive_eoi_ignored
*copyc cle$interactive_eop_ignored
*copyc cle$login_prolog_file_missing
*copyc cle$multiple_applic_unit_arrays
*copyc cle$negative_application_units
*copyc cle$none_must_be_used_alone
*copyc cle$no_cyc_expr_with_wild_card
*copyc cle$no_match_for_wild_card_file
*copyc cle$no_match_for_wild_card_name
*copyc cle$not_list_legible
*copyc cle$not_supported
*copyc cle$not_yet_implemented
*copyc cle$parameters_displayed
*copyc cle$param_dialog_not_privileged
*copyc cle$password_expiration_warning
*copyc cle$pdt_processor_mismatch
*copyc cle$redundancy_in_selections
*copyc cle$string_too_long
*copyc cle$string_too_short
*copyc cle$system_prolog_not_allowed
*copyc cle$table_overflow
*copyc cle$task_already_complete
*copyc cle$task_name_in_use
*copyc cle$task_not_found
*copyc cle$task_taskend_ring_below_min
*copyc cle$terminated_application_task
*copyc cle$unable_to_call_av_scanner
*copyc cle$unable_to_call_check_proc
*copyc cle$unable_to_call_function
*copyc cle$unable_to_call_input_proc
*copyc cle$unable_to_call_parm_dlg_mgr
*copyc cle$unable_to_call_util_dlg_mgr
*copyc cle$unable_to_enter_screen_mode
*copyc cle$unable_to_free_block
*copyc cle$unable_to_set_cai
*copyc cle$unable_to_set_minws
*copyc cle$unable_to_set_pai
*copyc cle$unexpected_call_to
*copyc cle$unexpected_value_type
*copyc cle$unknown_variable
*copyc cle$unseen_mail_condition
*copyc cle$up_cant_follow_wild_card
*copyc cle$user_already_logged_in
*copyc cle$value_counts_unequal
*copyc cle$var_already_created
*copyc cle$var_sub_params_not_allowed
*copyc cle$welcome_banner
*copyc cle$wild_card_cant_be_first
*copyc cle$wild_card_not_allowed
*copyc cle$work_area_overflow
?? TITLE := 'CLE$ECC_line_length', EJECT ??
*copyc cle$ecc_line_length
?? TITLE := 'CLE$ECC_parsing', EJECT ??
{
{ CLE$ECC_parsing is assigned codes 2000 .. 2999
{
*copyc cle$ecc_parsing
?? TITLE := 'CLE$ECC_lexical', EJECT ??
{
{ CLE$ECC_lexical is assigned codes 100 .. 199
{
*copyc cle$ecc_lexical
?? TITLE := 'CLE$ECC_parameter_list', EJECT ??
{
{ CLE$ECC_parameter_list is an "obsolete" deck.
{
*copyc cle$ecc_parameter_list
?? TITLE := 'CLE$ECC_expression_result', EJECT ??
{
{ CLE$ECC_expression_result is an "obsolete" deck.
{
*copyc cle$ecc_expression_result
?? TITLE := 'CLE$ECC_expression', EJECT ??
{
{ CLE$ECC_expression is an "obsolete" deck.
{
*copyc cle$ecc_expression
?? TITLE := 'CLE$ECC_variable', EJECT ??
{
{ CLE$ECC_variable is an "obsolete" deck.
{
*copyc cle$ecc_variable
?? TITLE := 'CLE$ECC_file_reference', EJECT ??
{
{ CLE$ECC_file_reference is assigned codes 500 .. 599
{
*copyc cle$ecc_file_reference
?? TITLE := 'CLE$ECC_command_processing', EJECT ??
{
{ CLE$ECC_command_processing is assigned codes 700 .. 799
{
*copyc cle$ecc_command_processing
?? TITLE := 'CLE$ECC_proc_declaration', EJECT ??
{
{ CLE$ECC_proc_declaration is assigned codes 800 .. 999
{
*copyc cle$ecc_proc_declaration
?? TITLE := 'CLE$ECC_function_processing', EJECT ??
{
{ CLE$ECC_function_processing is an "obsolete" deck.
{
*copyc cle$ecc_function_processing
?? TITLE := 'CLE$ECC_control_statement', EJECT ??
{
{ CLE$ECC_control_statement is assigned codes 1100 .. 1199
{
*copyc cle$ecc_control_statement
?? TITLE := 'CLE$ECC_connected_file', EJECT ??
{
{ CLE$ECC_connected_file is assigned codes 1300 .. 1399
{
*copyc cle$ecc_connected_file
?? TITLE := 'CLE$ECC_date_time_format', EJECT ??
{
{ CLE$ECC_date_time_format is assigned codes 1400 .. 1499
{
*copyc cle$ecc_date_time_format
?? TITLE := 'CLE$ECC_utilities', EJECT ??
{
{ CLE$ECC_utilities is assigned codes 1500 .. 1599
{
*copyc cle$ecc_utilities
?? TITLE := 'CLE$ECC_mt_generator', EJECT ??
{
{ CLE$ECC_mt_generator is assigned codes 8000 .. 8499
{
*copyc cle$ecc_mt_generator
?? TITLE := 'CLE$ECC_ct_generator', EJECT ??
{
{ CLE$ECC_ct_generator is assigned codes 9000 .. 9499
{
*copyc cle$ecc_ct_generator
?? TITLE := 'CLE$ECC_scl_formatter', EJECT ??
{
{ CLE$ECC_scl_formatter is assigned codes 9500 .. 9999
{
*copyc cle$ecc_scl_formatter
?? OLDTITLE, OLDTITLE, EJECT ??
*DECK DECK=CLE$EXPECTING_PROC EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$expecting_proc              = clc$min_ecc + 850;
    {E Expecting +P, found +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$FILE_NEVER_OPENED EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$file_never_opened           = clc$min_ecc + 27;
    {E +P2 was issued for file +F1 which has never been opened.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$FILE_REFERENCE_CONFLICT EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$file_reference_conflict     = clc$min_ecc + 30;
    {E +P refer to the same file.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$FUNCTION_CANCELLED EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$function_cancelled          = clc$min_ecc + 7005;
    {E Function +P cancelled.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$IMPROPER_SUBSTITUTION_MARK EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$improper_substitution_mark  = clc$min_ecc + 35;
    {E "+P" may not be used for a substitution mark.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$IMPROPER_USE_OF_SUBST_MARK EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$improper_use_of_subst_mark  = clc$min_ecc + 37;
    {E A substitution mark may only be use in a command ..
    {for an asynchronous task.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$INCOMPATIBLE_PARAMS_GIVEN EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$incompatible_params_given   = clc$min_ecc + 40;
    {E Parameters given are incompatible with value of parameter +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$INTERACTIVE_EOI_IGNORED EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$interactive_eoi_ignored     = clc$min_ecc + 7003;
    {I End of information from terminal file ignored.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$INTERACTIVE_EOP_IGNORED EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$interactive_eop_ignored     = clc$min_ecc + 7004;
    {I End of partition from terminal file ignored.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$LOGIN_PROLOG_FILE_MISSING EXPAND=FALSE

*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$login_prolog_file_missing   = clc$min_ecc + 22;
    {I Prolog file, +F does not exist or you are not permitted for any access.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$MULTIPLE_APPLIC_UNIT_ARRAYS EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$multiple_applic_unit_arrays = clc$min_ecc + 42;
    {E Application +P attempted to define more than one application counter ..
    {array.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$NEGATIVE_APPLICATION_UNITS EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$negative_application_units  = clc$min_ecc + 43;
    {E Application +P terminated with a negative value in counter +P of the ..
    {application counter array.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$NONE_MUST_BE_USED_ALONE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$none_must_be_used_alone     = clc$min_ecc + 50;
    {E NONE must be used alone for parameter +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$NOT_LIST_LEGIBLE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$not_list_legible            = clc$min_ecc + 45;
    {E File +F is not list or legible.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$NOT_SUPPORTED EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$not_supported               = clc$min_ecc + 29;
*IF $true(osv$unix)
    {I +P not supported.}
*ELSE
    {E +P not supported.}
*IFEND

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$NOT_YET_IMPLEMENTED EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$not_yet_implemented         = clc$min_ecc + 55;
    {E +P not yet implemented.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$NO_CYC_EXPR_WITH_WILD_CARD EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$no_cyc_expr_with_wild_card  = clc$min_ecc + 1602;
    {E A cycle reference expression is not allowed after a ..
    {wild card.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$NO_MATCH_FOR_WILD_CARD_FILE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$no_match_for_wild_card_file = clc$min_ecc + 1600;
    {E No matches found for wild card file reference +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$NO_MATCH_FOR_WILD_CARD_NAME EXPAND=TRUE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$no_match_for_wild_card_name = clc$min_ecc + 1605;
    {E No matches found for wild card name +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$PARAMETERS_DISPLAYED EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$parameters_displayed        = clc$min_ecc + 646;
    {I The parameters for a command or function were successfully ..
    {displayed. This message should never appear to a user; if it does, ..
    {the processor for the command or function whose parameters were ..
    {displayed is not interfacing properly with the SCL interpreter.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$PARAM_DIALOG_NOT_PRIVILEGED EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$param_dialog_not_privileged = clc$min_ecc + 647;
    {E You do not have sufficient privilege to call commands from ..
    {this parameter dialog.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$PASSWORD_EXPIRATION_WARNING EXPAND=FALSE

*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$password_expiration_warning = clc$min_ecc + 7018;
    {I Your login password will expire +P+X2+P.}

?? FMT (FORMAT := ON) ??

*DECK DECK=CLE$PDT_PROCESSOR_MISMATCH EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$pdt_processor_mismatch      = clc$min_ecc + 21;
    {E A clt$parameter_description_table generated for command can't be ..
    {used by the processor for a function; and one generated for a ..
    {function can't be used by the processor for a command.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$REDUNDANCY_IN_SELECTIONS EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$redundancy_in_selections    = clc$min_ecc + 60;
    {E Redundant values given for parameter +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$STRING_TOO_LONG EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$string_too_long             = clc$min_ecc + 250;
    {E String too long.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$STRING_TOO_SHORT EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$string_too_short            = clc$min_ecc + 255;
    {E String too short.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$SYSTEM_PROLOG_NOT_ALLOWED EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$system_prolog_not_allowed   = clc$min_ecc + 96;
    {E The system_prolog command can only be executed from within the ..
    {system prolog.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$TABLE_OVERFLOW EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$table_overflow              = clc$min_ecc + 70;
    {F Table overflow: +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$TASK_ALREADY_COMPLETE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$task_already_complete       = clc$min_ecc + 8;
    {W The following tasks have already completed: +P }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$TASK_NAME_IN_USE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$task_name_in_use            = clc$min_ecc + 1260;
    {E +P designates a task which has not yet completed.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$TASK_NOT_FOUND EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$task_not_found              = clc$min_ecc + 9;
    {E The following tasks are either not known to the requesting task ..
    {or not initiated by the requesting task: +P }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$TASK_TASKEND_RING_BELOW_MIN EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$task_taskend_ring_below_min = clc$min_ecc + 1280;
    {E You may not use TASK/TASKEND to run below your validated ..}
    {minimum ring.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$TERMINATED_APPLICATION_TASK EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$terminated_application_task = clc$min_ecc + 62;
    {I Asynchronous application tasks were terminated by SCL when ..
    {application +P ended.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$UNABLE_TO_CALL_AV_SCANNER EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$unable_to_call_av_scanner   = clc$min_ecc + 258;
    {E Unable to call processor for "application value" +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$UNABLE_TO_CALL_CHECK_PROC EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$unable_to_call_check_proc   = clc$min_ecc + 686;
    {E Unable to call procedure to do command/function specific ..
    {parameter checking for clp$evaluate_parameters.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$UNABLE_TO_CALL_FUNCTION EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$unable_to_call_function     = clc$min_ecc + 1080;
    {E Unable to call function: +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$UNABLE_TO_CALL_INPUT_PROC EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$unable_to_call_input_proc   = clc$min_ecc + 28;
    {E Unable to call procedure to read input for +P declaration.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$UNABLE_TO_CALL_PARM_DLG_MGR EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$unable_to_call_parm_dlg_mgr = clc$min_ecc + 687;
    {E Unable to call SCL parameter dialog manager.}

?? FMT (FORMAT := OFF) ??
*DECK DECK=CLE$UNABLE_TO_CALL_UTIL_DLG_MGR EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$unable_to_call_util_dlg_mgr = clc$min_ecc + 24;
    {E Unable to call SCL utility dialog manager.}

?? FMT (FORMAT := OFF) ??
*DECK DECK=CLE$UNABLE_TO_ENTER_SCREEN_MODE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$unable_to_enter_screen_mode = clc$min_ecc + 31;
    {E Unable to enter screen mode.  Please check terminal_model.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$UNABLE_TO_FREE_BLOCK EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$unable_to_free_block        = clc$min_ecc + 85;
    {F ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **+N10..
    {An SCL clt$block (kind=+P) could not be freed because of +P ..
    {outstanding references to it.  +E10(PVA of unfreed block = +P.)}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$UNABLE_TO_SET_CAI EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$unable_to_set_cai           = clc$min_ecc + 68;
    {E Caller ring # too high to set cyclic aging interval.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$UNABLE_TO_SET_MINWS EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$unable_to_set_minws         = clc$min_ecc + 65;
    {E Caller ring # too high to set minimum working set.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$UNABLE_TO_SET_PAI EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$unable_to_set_pai           = clc$min_ecc + 67;
    {E Caller ring # too high to set page aging interval.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$UNEXPECTED_CALL_TO EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$unexpected_call_to          = clc$min_ecc + 90;
    {F Unexpected call to +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$UNEXPECTED_VALUE_TYPE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$unexpected_value_type       = clc$min_ecc + 14;
    {E A +P value cannot be represented as a clt$value.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$UNKNOWN_VARIABLE EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$unknown_variable            = clc$min_ecc + 460;
    {E +P is not a variable.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$UNSEEN_MAIL_CONDITION EXPAND=FALSE
?? NEWTITLE := 'CLE$UNSEEN_MAIL_CONDITION', EJECT ??
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$unseen_mail_condition = clc$min_ecc + 32;
    {I You have mail.}

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=CLE$UP_CANT_FOLLOW_WILD_CARD EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$up_cant_follow_wild_card    = clc$min_ecc + 1603;
    {E $UP cannot follow a wild card character in a file ..
    {reference.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$USER_ALREADY_LOGGED_IN EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$user_already_logged_in      = clc$min_ecc + 69;
    {E User is already logged in.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$VALUE_COUNTS_UNEQUAL EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$value_counts_unequal        = clc$min_ecc + 95;
    {E Same number of values must be supplied for parameters +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$VAR_ALREADY_CREATED EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$var_already_created         = clc$min_ecc + 490;
    {E +P is already declared as a variable.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$VAR_SUB_PARAMS_NOT_ALLOWED EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$var_sub_params_not_allowed  = clc$min_ecc + 3;
    {E The parameter description table passed to clp$evaluate_sub_parameters ..
    {may not contain VAR (pass by reference) parameters.}

?? FMT (FORMAT := ON) ??

*DECK DECK=CLE$WELCOME_BANNER EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$welcome_banner              = clc$min_ecc + 7000;
    {I Welcome to the NOS/VE Software System.+N..
*PUT '    {Copyright Control Data Systems Inc. '//$STRING($NOW.YEAR)//'.+N..'
    {+P SN+P.+X2+P+N..
    {+P.+X2+P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$WILD_CARD_CANT_BE_FIRST EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$wild_card_cant_be_first     = clc$min_ecc + 1601;
    {E The first element of a file reference may not be ..
    {$ALL or contain a wild character.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$WILD_CARD_NOT_ALLOWED EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$wild_card_not_allowed  = clc$min_ecc + 1604;
    {E Use of a wild card is not allowed for the requested ..
    {operation.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLE$WORK_AREA_OVERFLOW EXPAND=FALSE
*copyc clc$ecc_range
?? FMT (FORMAT := OFF) ??

  CONST
    cle$work_area_overflow          = clc$min_ecc + 99;
    {E Work area overflow in +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CLH$ADD_AUXILIARY_UTILITY_LIB EXPAND=FALSE
{
{   This request adds a library to a utility's list of auxiliary libraries.
{ This list of libraries is searched as part of the command list entry for a
{ utility, however its contents are invisible to users of the utility (i.e.
{ none of the information displays divulge its existence, and calls to commands
{ in it are not logged).
{
{       CLP$ADD_AXUILIARY_UTILITY_LIB (UTILITY, LIBRARY, STATUS)
{
{ UTILITY: (input)  This parameter specifies the name of the utility to which
{       the library is to be added.
{
{ LIBRARY: (input)  This parameter specifies the object library to be added.
{       If this library has already been added via this request to the UTILITY,
{       no operation is performed.
{
{ CHECKOUT_LIBRARY: (input)  This parameter specifies an object library to be
{       added for purposes of checking out a new version of the LIBRARY.  If
{       this parameter is a blank or empty string, or has already been added
{       via this request to the UTILITY, or the command search mode is not
{       global, no operation is performed.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$ADD_FILE_TO_COMMAND_LIST EXPAND=FALSE
{
{   The purpose of this request is to add an entry other than a utility to the
{ command list.
{
{       CLP$ADD_FILE_TO_COMMAND_LIST (ENTRY, APPEND, STATUS)
{
{ ENTRY: (input)  This parameter specifies the name of the file to be added
{       to the command list.
{
{ APPEND: (input)  This parameter specifies whether the entry is placed
{       before or after the current entries in the command list.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:  cle$duplicate_command_list_ent
{                    cle$duplicate_fence_entry
{                    cle$duplicate_$system_entry
{                    cle$duplicate_work_cat_entry
{                    cle$exclusve_mode_excludes_cmnd
{                    cle$restricted_mode_cmnd_change
{
*DECK DECK=CLH$ANALYZE_COMMAND EXPAND=FALSE
{
{   The purpose of this request is to analyze a command and identify its major
{ component parts.
{
{       CLP$ANALYZE_COMMAND (COMMAND_TEXT, PROMPTING_REQUESTED, ESCAPED, LABEL,
{         COMMAND_REFERENCE_INDEX, COMMAND_REFERENCE_SIZE, FILE, FORM, NAME,
{         UTILITY_NAME, PARAMETER_LIST_INDEX, SEPARATOR, EMPTY_COMMAND, STATUS)
{
{ COMMAND_TEXT: (input)  This parameter specifies the command or statement to
{       be analyzed.  This request assumes that the command or statement has
{       been isolated from other commands and statements on the same line (e.g.
{       via CLP$ISOLATE_COMMAND) such that this parmaeter specifies the text of
{       a single command or statement.
{
{ PROMPTING_REQUESTED: (output)  This parameter specifies whether the command
{       was prefixed by the "prompt for parameters" character (?).  (Undefined
{       if EMPTY_COMMAND is TRUE.)
{
{ ESCAPED: (output)  This parameter specifies whether the command was prefixed
{       by the "escape" character (/) used to control command search.
{       (Undefined if EMPTY_COMMAND is TRUE.)
{
{ LABEL: (output)  This parameter specifies the label on the command.  If no
{       label was present, osc$null_name is returned.  (Undefined if
{       EMPTY_COMMAND is TRUE.)
{
{ COMMAND_REFERENCE_INDEX: (output)  This parameter specifies the start of the
{       "command reference" part of the analyzed command.  If the analyzed
{       statement is an assignment statement, it specifies the start of the
{       variable reference or "left part" of the assignment statement.
{       (Undefined if EMPTY_COMMAND is TRUE.)
{
{ COMMAND_REFERENCE_SIZE: (output)  This parameter specifies the size of the
{       "command reference" part of the analyzed command.  If the analyzed
{       statement is an assignment statement, it specifies the size of the
{       variable reference or "left part" of the assignment statement.
{       (Undefined if EMPTY_COMMAND is TRUE.)
{
{ FILE: (output)  This parameter specifies the file used in a file.command
{       style reference.  (Undefined if EMPTY_COMMAND is TRUE or if file_given
{       is FALSE.)
{
{ FORM: (output)  This parameter represents the form in which the command was
{       specified (undefined if EMPTY_COMMAND is TRUE):
{
{             command ----> clc$name_only_command_ref
{
{             file.command ----> clc$module_or_file_command_ref
{
{             catalog.command.cycle ----> clc$file_cycle_command_ref
{
{             $SYSTEM.command ----> clc$system_command_ref
{
{             UTILITY.command ----> clc$utility_command_ref
{
{ NAME: (output)  This parameter specifies the name of the command.  For an
{       assignment statement, it is set to the string 'assignment'.  For a
{       <case selection> statement, it is set to the string 'CASE selection'.
{       For any other command or statement the name is returned in upper case.
{       (Undefined if EMPTY_COMMAND is TRUE.)
{
{ UTILITY_NAME: (output)  This parameter specifies the name of_ the utility on
{       a UTILITY.command reference.  (Undefined if EMPTY_COMMAND is TRUE,
{       osc$null_name if FORM is not clc$utility_command_ref.)
{
{ SEPARATOR: (output)  This parameter specifies the separator between the
{       command reference and the parameters for the command.  If CLC$LEX_EQUAL
{       is returned, the command is a <case selection> statement if
{       COMMAND_REFERENCE_SIZE is zero and an assignment statement otherwise.
{       Other possible values are:  CLC$LEX_SPACE, CLC$LEX_COMMA,
{       CLC$LEX_SEMICOLON, CLC$LEX_END_OF_LINE.  (Undefined if EMPTY_COMMAND is
{       TRUE.)
{
{ EMPTY_COMMAND: (output)  This parameter specifies whether the command is
{       empty (consists solely of spaces and/or comments).
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$APPEND_STATUS_PARSE_STATE EXPAND=FALSE
{
{   This request appends the string representation of a clt$parse_state  as  a
{ status parameter to the text field of a status record.  This request assumes
{ that   the   status   record   has   been   initialized   by   a   call   to
{ osp$set_status_abnormal.
{
{       CLP$APPEND_STATUS_PARSE_STATE (DELIMITER, PARSE, STATUS)
{
{ DELIMITER:  (input) This parameter specifies the character that will precede
{       the parse state supplied by this request in  the  text  field  of  the
{       status  record  being  formed.  Depending on its value, this character
{       may cause one of two effects when  the  status  is  formatted  into  a
{       message.   If this character is the same as the first character in the
{       text field, then the parse state will be treated as a separate  status
{       parameter.   If,  however,  this character is different from the first
{       character in the text field, then this character and the  parse  state
{       will  be  treated  as  part  of  the  preceding status parameter (this
{       feature permits  the  creation  of  a  single  status  parameter  from
{       separate pieces of data).
{
{ PARSE: (input) This parameter specifies the parse state to be appended.
{
{ STATUS:  (input, output) This parameter specifies the status record to which
{       the parse state is to be appended.
{
*DECK DECK=CLH$APPEND_STATUS_STRING EXPAND=FALSE
{
{   This request appends a string as a status parameter to the text field of a
{ status record.  This request assumes that the status record has been
{ initialized by a call to osp$set_status_abnormal.
{
{   This request differs from osp$append_status_parameter in that it accepts a
{ string of any length.  If the string is too long to fit into the status
{ record's text field, it is truncated on the right.
{
{       CLP$APPEND_STATUS_STRING (DELIMITER, TEXT, STATUS)
{
{ DELIMITER: (input)  This parameter specifies the character that will precede
{       the text supplied by this request in the text field of the status being
{       formed.  Depending on its value, this character may cause one of two
{       effects when the status is formatted into a message.  If this character
{       is the same as the first character in the text field, then the new text
{       will be treated as a separate status parameter.  If, however, this
{       character is different from the first character in the text field, then
{       this character and the new text will be treated as part of the
{       preceding status parameter (this feature permits the creation of a
{       single status parameter from separate pieces of data).
{
{ TEXT: (input)  This parameter specifies the string text.  Trailing spaces in
{       this text are not included in the status record.
{
{ STATUS: (input, output) This parameter specifies the status record to  which
{       the text is to be appended.
{
*DECK DECK=CLH$APPEND_STATUS_TYPE EXPAND=FALSE
{
{   This request appends the string representation of a clt$type_specification
{ as  a  status  parameter to the text field of a status record.  This request
{ assumes  that  the  status  record  has  been  initialized  by  a  call   to
{ osp$set_status_abnormal.
{
{       CLP$APPEND_STATUS_TYPE (DELIMITER, TYPE_SPECIFICATION, STATUS)
{
{ DELIMITER:  (input) This parameter specifies the character that will precede
{       the type specification supplied by this request in the text  field  of
{       the  status  record  being  formed.   Depending  on  its  value,  this
{       character may cause one of two effects when the  status  is  formatted
{       into  a message.  If this character is the same as the first character
{       in the text field, then the type specification will be  treated  as  a
{       separate  status  parameter.  If, however, this character is different
{       from the first character in the text field, then  this  character  and
{       the type specification will be treated as part of the preceding status
{       parameter (this feature  permits  the  creation  of  a  single  status
{       parameter from separate pieces of data).
{
{ TYPE_SPECIFICATION:  (input) This parameter specifies the type specification
{       to be appended.
{
{ STATUS: (input, output) This parameter specifies the status record to  which
{       the type specification is to be appended.
{
*DECK DECK=CLH$APPEND_STATUS_VALUE_TYPE EXPAND=FALSE
{
{   This  request  appends  the  string  representation  of  the  type  of   a
{ clt$data_value  as  a status parameter to the text field of a status record.
{ This request assumes that the status record has been initialized by  a  call
{ to osp$set_status_abnormal.
{
{       CLP$APPEND_STATUS_VALUE_TYPE (DELIMITER, VALUE, STATUS)
{
{ DELIMITER:  (input) This parameter specifies the character that will precede
{       the value type supplied by this request  in  the  text  field  of  the
{       status  record  being  formed.  Depending on its value, this character
{       may cause one of two effects when  the  status  is  formatted  into  a
{       message.   If this character is the same as the first character in the
{       text field, then the value type will be treated as a  separate  status
{       parameter.   If,  however,  this character is different from the first
{       character in the text field, then this character and  the  value  type
{       will  be  treated  as  part  of  the  preceding status parameter (this
{       feature permits  the  creation  of  a  single  status  parameter  from
{       separate pieces of data).
{
{ VALUE:  (input)  This  parameter  specifies  the  value  whose type is to be
{       appended.
{
{ STATUS: (input, output) This parameter specifies the status record to  which
{       the type specification is to be appended.
{
*DECK DECK=CLH$APPLICATION_VALUE_SCANNER EXPAND=FALSE
{
{   An application value scanner is passed the following parameters.
{
{       application_value_scanner (VALUE_NAME, KEYWORD_VALUES, TEXT, VALUE,
{         STATUS)
{
{ VALUE_NAME: (input) This parameter specifies the  name  of  the  application
{       value  as  defined in the value kind specifier that caused the scanner
{       to be called.
{
{ KEYWORD_VALUES: (input) This parameter  specifies  the  array  (if  any)  of
{       keyword  values  allowed for this application value (as defined in the
{       value kind specifier that caused the scanner to be called).
{
{ TEXT: (input) This parameter specifies the application value to  be  scanned
{       (evaluated).
{
{ VALUE:  (output)  This  parameter  specifies  the  result  of  the  scanning
{       (evaluation) of the text.  Results that cannot conform to one  of  the
{       standard  SCL forms can be returned in a clt$application_value via the
{       application field of this parameter.  The  descriptor  field  of  this
{       parameter should name the kind of value returned (e.g.  'STRING' for a
{       clc$string_value).
{
{ STATUS: (output) This parameter  specifies  the  completion  status  of  the
{       application value scanner.
{
*DECK DECK=CLH$BEGIN_UTILITY EXPAND=FALSE
{
{   This request defines the environment for a command utility.
{
{       CLP$BEGIN_UTILITY (NAME, ATTRIBUTES, STATUS)
{
{ NAME: (input)  This parameter specifies the name of the utility.
{
{ ATTRIBUTES: (input)  This parameter specifies the initial attributes for the
{       utility.  The following attributes may be specified:
{       clc$null_utility_attribute, clc$utility_command_search_mode,
{       clc$utility_command_table, clc$utility_function_table,
{       clc$utility_function_proc_table, clc$utility_interactive_include,
{       clc$utility_line_preprocessor, clc$utility_online_manual,
{       clc$utility_prompt, clc$utility_subcmnd_log_enabled,
{       clc$utility_termination_command.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:  cle$term_command_not_defined
{                    cle$unknown_utility_attribute
{                    cle$improper_utility_attribute
{                    cle$improper_utility_attr_value
{                    cle$improper_utility_name
{
*DECK DECK=CLH$BUILD_FORMATTED_STRINGS EXPAND=FALSE
{
{   The purpose of this request is to build a data_representation from a
{ format and one or more clt$data_values.
{
{   This representation is returned in a sequence.  The first data item in the
{ sequence is a clt$data_representation_count, i.e.  the number of strings
{ used in the representation.  The remaining data is a series of
{ clt$string_size, clt$string_value pairs with the length of each
{ clt$string_value determined by the corresponding clt$string_size.
{
{       CLP$FORMAT_VALUES (FORMAT_REPRESENTATION, VALUE, MAX_STRING,
{         WORK_AREA, DATA_REPRESENTATION, STATUS)
{
{ FORMAT: (input) This parameter specifies the formatting for the text lines
{       in the data_representation.  This is build by clp$build_format_
{       representation.
{
{ VALUE: (input)  This parameter specifies the data values referenced by the
{       format.
{
{ MAX_STRING: (input)  This parameter specifies the maximum length of strings
{       in the representation of the value.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the value's representation.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The value's respresentation occupies the
{       used part of this sequence.
{
{ DATA_REPRESENTATION: (output)  This parameter specifies the data value's
{       representation as described above.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$work_area_overflow
{                   cle$bad_data_rep_option
{                   cle$bad_data_value
*DECK DECK=CLH$BUILD_FORMAT_REPRESENTATION EXPAND=FALSE
{
{   The purpose of this request is to "compile" a format string to an easily
{ processed internal representation to be used by clp$build_formatted_strings.
{
{   This representation is returned in a sequence.
{
{       CLP$BUILD_FORMAT_REPRESENTATION (FORMAT_STRING, WORK_AREA,
{         FORMAT_REPRESENTATION, STATUS)
{
{ FORMAT_STRING: (input) This parameter specifies the format of the text lines.
{       This string consists of display characters and formatting directives.
{       The display characters are copied to the text lines directly.  The
{       format directives all start with a "+" character and have the following
{       effects.  (nn'th data_value here refers to the nn'th data_value of
{       the data_value list element currently in effect.)
{
{       If format string is NIL then the format '+S' is used.
{
{       +Enn Define a soft end of line.  This position will be used to break
{             the line if the line extends past the string width.  nn defines
{             the indentation for the new line.
{
{       +Fc: Define a fill character 'c'.  This must be immediately followed
{             by another directive with no interveening '+' character.  The
{             fill character is used with the +W, +H, and +X directives.
{
{       +Hnn: Horizontally tab to column.  If nn is specified, it tabs to
{             column nn starting a new line if the current column is too large.
{             If nn is ommitted, it tabs to the next tab of 9, 17, 25, etc.
{             The fill character is used to pad the line to the column.
{
{       +K: Keep the text between pairs of +K directives together on one line.
{
{       +Lxnn: Puts the specified data value label to the string.
{             If nn is specified and not 0, the nn'th data value label is used.
{             If nn is not specified, the next data value label is used.  If nn
{             is 0, the label of the previously referenced value is used.  The
{             'x' specifies how to show record labels.  'U' specifies that they
{             be in upper case characters.  'L' specifies that they be in lower
{             case characters.  'I' specifies that only the initial letters
{             of words be capitalized.  If the 'x' is not specified, 'L' is
{             used.
{
{       +Nnn: Specifies a hard end of line.  This causes the current line to
{             be ended and a new line started with nn leading spaces.
{
{       +Pxnn: Convert the specified data value using element representation.
{             If nn is specified and not 0, the nn'th data value is used.
{             If nn is not specified, the next data value is used.  If nn
{             is 0, the previously referenced value is used.  The 'x'
{             specifies how to convert names.  'U' specifies that names be in
{             upper case characters.  'L' specifies that names be in lower
{             case characters.  'I' specifies that only the initial letters
{             of words be capitalized.  If the 'x' is not specified, 'L' is
{             used.
{
{       +R: Causes a portion of the format to be repeated.  The portion
{             repeated is between '+R' pairs at the same nesting level (see
{             '+('.  The repeated format is processed until all values at
{             this nesting level are used.  If all values have been used when
{             the '+R' is encountered, the repeated portion is not processed
{             at all.
{
{       +Sxnn: Convert the specified data value using source representation.
{             If nn is specified and not 0, the nn'th data value is used.
{             If nn is not specified, the next data value is used.  If nn
{             is 0, the previously referenced value is used.  The 'x'
{             specifies how to convert names.  'U' specifies that names be in
{             upper case characters.  'L' specifies that names be in lower
{             case characters.  'I' specifies that only the initial letters
{             of words be capitalized.  If the 'x' is not specified, 'L' is
{             used.
{
{       +Wjnn: Define a fixed field width for the display of the value that
{             follows as 'nn'.  If the value is larger than this width, it will
{             be truncated (on the left for right justification; on the right
{             for left justification and center justification).  If the value
{             is smaller than this width, it will be justified as specified
{             and padded by the fill character as defined by the 'F' directive.
{             'j' optionally specifies the justification.  'R' selects right
{             justification, 'L' selects left justification (the default) and
{             'C' selects center justification.  If nn is not specified a
{             value of 31 is used.  NOTE:  This must be immediately followed
{             by another directive with no interveening '+' character.
{
{       +Xnn: Expand count as fill character.  The fill character is put to
{             the string nn times.
{
{       +(nn: Move to the next nesting level.  This causes the '+P' and '+S'
{             directives to refer to subvalues of the next (or nnth) value.
{
{       +): Return to the previous nesting level.
{
{       ++: Places a '+' into the string.
{
{       +-: Places the null string '' into the string.  This allows one to
{             follow a directive by a number without the interpretation of
{             the number as part of the directive.  eg. +p+-5 means put the
{             next parameter to the string then put '5' to the string.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the value's representation.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The value's respresentation occupies the
{       used part of this sequence.
{
{ FORMAT_REPRESENTATION: (output)  This parameter specifies the format's
{       internal representation as described above.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$work_area_overflow
{
*DECK DECK=CLH$BUILD_PATH_SUBTITLE EXPAND=FALSE
{
{   The purpose of this request is to build information to be used when
{ displaying a path name as part of a subtitle.
{
{       CLP$BUILD_PATH_SUBTITLE (PATH_NAME, LENGTH, WIDTH, COUNT,
{         DISPLAY_ARRAY)
{
{ PATH_NAME: (input, output)  This parameter specifies the name of the path.
{       This request translates upper case letters in the path name to their
{       lower case equivalents.
{
{ LENGTH: (input)  This parameter specifies the number of characters from
{       PATH_NAME to be displayed.
{
{ WIDTH: (input)  This parameter specifies the maximum number of characters of
{       the path to be displayed per line.
{
{ COUNT: (output)  This parameter specifies the number of lines needed to
{       display the path name.
{
{ DISPLAY_ARRAY: (output)  This parameter specifies the parts of the path name
{       to be displayed in the subtitle lines.  Each entry in this array
{       identifies the starting POSITION and LENGTH of the substring of
{       PATH_NAME to appear in the corresponding line of the subtitle.
{
*DECK DECK=CLH$BUILD_PATTERN_FOR_WILD_CARD EXPAND=FALSE
{
{   The CLP$BUILD_PATTERN_FOR_WILD_CARD request builds a clt$string_pattern
{ representation from a "wild card" pattern specification.  The following
{ have special meaning with a "wild card" pattern.
{
{       ?     This character (wild card single) matches any single character.
{
{       *     This character (wild card multiple) matches any string of
{             characters, including a zero-length (null) string.
{
{       '     This character is used to enclose other special characters that
{             are to be matched literally.  Two ' characters in succession
{             means a single '.
{
{             Note, the quote character may not be used in a wild card pattern
{             for a file or name.
{
{   In addition to the above, the following have special meaning when the
{ PATTERN_TYPE is CLC$WC_EXTENDED_PATTERN.
{
{       [ ]   This notation (wild card class) can be used in an extended
{             pattern and matches any of the characters enclosed by the square
{             brackets.  If either of the characters [ or ] are to be members
{             of the class, they must be enclosed in ' characters.  If a '
{             character is to be a member of the the class, two consecutive '
{             characters must be used.
{
{             The characters ? and * characters have no special significance
{             within a character class pattern element.  The - character has no
{             special significance if it is the first or last wild card class
{             component.
{
{             A shorthand notation for representing a range of characters that
{             are to be members of the class is provided.  This notation
{             consists of placing a - between the characters at the low and
{             high ends of the range.  All of the ASCII characters between and
{             including the characters on either side of the - are included in
{             the class, regardless of the collating order of those characters
{             (i.e.  [0-9] and [9-0] are equivalent and include all the decimal
{             digits).
{
{       [^ ]  This notation (wild card inverse class) is very similar to that
{             above except that the characters between the square brackets
{             following the first ^ character specify characters that are not
{             to be members of the class.  The ^ character has no special
{             significance except when it immediately follows the [ of the
{             class.
{
{       { }   {This notation (wild card alternation) can be used in an extended
{             pattern and matches any one of a number of alternative
{             sub-patterns.  The alternatives are separated from one another by
{             the | character.  An empty alternative matches the null string.
{             The | character has no special significance outside of a wild
{             card alternation.
{
{
{       CLP$BUILD_PATTERN_FOR_WILD_CARD (WILD_CARD_PATTERN_TYPE, BUILD_OPTIONS,
{         SOURCE, WORK_AREA, PATTERN, STATUS)
{
{ WILD_CARD_PATTERN_TYPE: (input)  This parameter determines which of the
{       special characters described above are to be treated as such within the
{       pattern string.
{
{       CLC$WC_BASIC_PATTERN:  This option causes only the "?", "*" and "'"
{             characters to have the meanings described above.
{
{       CLC$WC_EXTENDED_PATTERN:  This option causes all of elements described
{             above to be recognized.
{
{ BUILD_OPTIONS: (input)  This parameter specifies options that affect how the
{       "wild card" pattern is represented as a string pattern.
{
{       CLC$SP_FILE_REFERENCE_PATTERN:  This options should be used only if the
{             pattern is to be used to match strings containing NOS/VE file
{             references.  It causes the "*" character to not match "."s and
{             imposes the necessary interpretation of the special file
{             reference path element $ALL.
{
{       CLC$SP_MATCH_AT_LEFT:  This option causes an element to be added to the
{             string pattern that forces the pattern to match at the left end
{             of a subject string.  This same effect can be acheived by
{             specifying CLC$SP_ANCHORED for the ANCHOR_OPTION parameter of
{             CLP$MATCH_STRING_PATTERN, which is slightly more efficient.
{
{       CLC$SP_MATCH_AT_RIGHT:  This option causes an element to be added to
{             the string pattern that forces the pattern to match at the right
{             end of a subject string.
{
{       CLC$SP_IGNORE_MATCHED_SUBSTRING:  This option can cause a slightly more
{             efficient representation for certain patterns to be built.  It
{             should be specified when the INDEX and SIZE components of the
{             MATCH_INFO parameter of CLP$MATCH_STRING_PATTERN are NOT to be
{             used.
{
{ SOURCE: (input)  This parameter specifies the "wild card" pattern.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the string pattern.  The current position of
{       this sequence pointer is updated to reflect the amount of storage used
{       by the request.  The resulting string pattern is completely contained
{       within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the resulting string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{
{       CONDITIONS: cle$bad_wild_card_pattern
{                   cle$work_area_overflow
{
*DECK DECK=CLH$BUILD_STANDARD_TITLE EXPAND=FALSE
{
{   The purpose of this request is to build a standard NOS/VE page title for
{ either the wide (132 column) format or narrow (80 column) format.  The
{ information included in the title is:  command name, OS version, date and
{ time.  The page number is not included.
{
{       CLP$BUILD_STANDARD_TITLE (WIDE, COMMAND_NAME, WIDE_TITLE,
{         NARROW_TITLE1, NARROW_TITLE2, DISPLAY_CONTROL, STATUS)
{
{ WIDE: (input)  This parameter specifies whether the wide format of title is
{       to be procduced (TRUE) or the narrow format (FALSE).
{
{ COMMAND_NAME: (input)  This parameter specifies the name of the command for
{       which the title is being built.
{
{ WIDE_TITLE: (output)  This parameter specifies the wide format of the title.
{       This parameter is only meaningful if WIDE is TRUE.
{
{ NARROW_TITLE1: (output)  This parameter specifies the first line of the
{       narrow format of the title.  This parameter is only meaningful if WIDE
{       is FALSE.
{
{ NARROW_TITLE2: (output)  This parameter specifies the second line of the
{       narrow format of the title.  This parameter is only meaningful if WIDE
{       is FALSE.
{
{ DISPLAY_CONTROL: (input)  This parameter specifies the display_control
{       variable initialized when the display was opened.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$CHANGE_PDT EXPAND=FALSE
{
{   This request changes information in a clt$parameter_description_table.
{
{       CLP$CHANGE_PDT (PARAMETER_DESCRIPTION_TABLE, CHANGES, STATUS)
{
{ PARAMETER_DESCRIPTION_TABLE: (input)  This parameter specifies the
{       clt$parameter_description_table to be changed.  Note that the table
{       must be writable and that GENERATE_PDT produces the declarations for a
{       PDT in a read-only section, so the output from GENERATE_PDT must be
{       edited to allow this request to operate.
{
{ CHANGES: (input)  This parameer specifies the changes to be made.  The NUMBER
{       field of each element determines which parameter to change and the KIND
{       field determines what aspect of the parameter description is to be
{       changed as follows.
{
{       CLC$PDTC_AVAILABILITY:  specifies a new AVAILABILITY level for the
{             parameter.
{
{       CLC$PDTC_SECURITY:  specifies a new SECURITY level for the parameter.
{
{       CLC$PDTC_TYPE:  specifies changes to the type of the parameter.  The
{             TYPE_CHANGES are passed to CLP$CHANGE_TYPE_SPECIFICATION.
{
{       CLC$PDTC_DEFAULT_VALUE:  specifies a new DEFAULT_VALUE for the
{             parameter.  The default value in the original PDT must be large
{             enough to accommodate the new one.
{
{       CLC$PDTC_NULL:  can be used as a place holder in the changes array.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$CHANGE_TYPE_SPECIFICATION EXPAND=FALSE
{
{   This request changes constraint information within a
{ clt$type_specification.
{
{       CLP$CHANGE_TYPE_SPECIFICATION (TYPE_SPECIFICATION, CHANGES, STATUS)
{
{ TYPE_SPECIFICATION: (input)  This parameter specifies the type specification
{       to be changed.
{
{ CHANGES: (input)  This parameter specifies the changes to be made.  The KIND
{       field of each change element determines what aspect of the type is to
{       be changed as foillows.
{
{       CLC$TC_INTEGER_SUBRANGE:  specifies a new MIN_INTEGER_VALUE and
{             MAX_INTEGER_VALUE for an integer type.
{
{       CLC$TC_KEYWORD_AVAILABILITY:  specifies a new AVAILABILITY level for
{             the specified KEYWORD.
{
{       CLC$TC_LIST_SIZE:  specifies a new MIN_LIST_SIZE and MAX_LIST_SIZE for
{             a list type.
{
{       CLC$TC_REAL_SUBRANGE:  specifies a new MIN_REAL_VALUE and
{             MAX_REAL_VALUE for a real type.
{
{       CLC$TC_STRING_SIZE:  specifies a new MIN_STRING_SIZE and
{             MAX_STRING_SIZE for a string type.
{
{       CLC$TC_NULL:  can be used as a place holder in the changes array.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$CHANGE_UNSEEN_MAIL_ACTION EXPAND=FALSE
{
{   This request sets the action to be performed by the default unseen_mail
{ condition handler to the option selected by the user for the current
{ environment. Actions which may be specified are postpone condition handling
{ and display a message. If the request changes the action from postpone to
{ display and the unseen_mail condition has been postponed, the unseen_mail
{ condition is caused in the current task.
{
{       CLP$CHANGE_UNSEEN_MAIL_ACTION (ACTION, STATUS)
{
{ ACTION: (input) This parameter specifies the action to be performed by the
{        default unseen_mail condition handler.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             cle$bad_unseen_mail_action
{
*DECK DECK=CLH$CHANGE_UTILITY_ATTRIBUTES EXPAND=FALSE
{
{   This request is used to change the attributes of a utility that was
{ defined via the clp$begin_utility request.  The attributes of a utility
{ defined via the UTILITY/UTILEND command cannot be changed via this request.
{
{       CLP$CHANGE_UTILITY_ATTRIBUTES (NAME, ATTRIBUTES, STATUS)
{
{ NAME: (input)  This parameter specifies the name of the utiility whose
{       attributes are to be changed.
{
{ ATTRIBUTES: (input)  This parameter specifies the attributes of the utility
{       that are to be changed.  The following attributes may be specified:
{       clc$null_utility_attribute, clc$utility_command_table,
{       clc$utility_function_table, clc$utility_function_proc_table,
{       clc$utility_interactive_include, clc$utility_line_preprocessor,
{       clc$utility_online_manual, clc$utility_prompt,
{       clc$utility_subcmnd_log_enabled.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:  cle$unknown_utility
{                    cle$unknown_utility_attribute
{                    cle$improper_utility_attribute
{
*DECK DECK=CLH$CHANGE_VARIABLE EXPAND=FALSE
{
{   This request changes the value of an SCL variable.  Any variable reference
{ permitted  as  the object of an SCL assignment statement may be specified as
{ the variable to be changed.
{
{       CLP$CHANGE_VARIABLE (REFERENCE, VALUE, STATUS)
{
{ REFERENCE: (input) This parameter specifies the variable to be changed.
{
{ VALUE: (input) This parameter specifies the new value for the variable.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=CLH$CLEAR_LOCK_VARIABLE EXPAND=FALSE
{
{   This request is used to clear a variable of type lock.  It can be used to
{ clear an expired lock.  A lock which has not expired may only be cleared by
{ the task which set it.
{
{       CLP$CLEAR_LOCK_VARIABLE (REFERENCE, STATUS)
{
{ REFERENCE: (input)  This parameter specifies the lock variable to be
{       cleared.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: cle$lock_already_clear
{                   cle$lock_not_set_by_this_task
{
*DECK DECK=CLH$CLOSE_DISPLAY EXPAND=FALSE
{
{   The purpose of this request is to close the file opened for a display.  If
{ any data has not yet been written to the display, e.g.  via
{ clp$put_partial_display requests, that data is written prior to closing the
{ file.
{
{       CLP$CLOSE_DISPLAY (DISPLAY_CONTROL, STATUS)
{
{ DISPLAY_CONTROL: (input, output)  This parameter specifies the
{       display_control variable initialized when the display was opened.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$COLLECT_COMMANDS EXPAND=FALSE
{
{   The purpose of this request is to collect subsequent commands from the
{ current command file and write them, one per line, to a specified file.
{ Collection is terminated when a specified "terminator" is found as a
{ "command" (the terminator is not written to the collection file).  Collection
{ is also terminated if end-of-information is encounterred.
{
{   This request is intended for use by command utilities; therefore if the
{ requesting task does not have an active call to clp$include_file/line, the
{ request will terminate with an error status.
{
{       CLP$COLLECT_COMMANDS (FILE, TERMINATOR, STATUS)
{
{ FILE: (input)  This parameter specifies the file which is to receive the
{       collected commands.
{
{ TERMINATOR: (input)  This parameter specifies the collection "terminator"
{       name.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$unexpected_call_to
{
*DECK DECK=CLH$COMMAND EXPAND=FALSE
{
{   A command processor may receive control from the SCL interpreter either by
{ direct procedure call or by being executed as a task.  Which method is used
{ is determined by how the command is made known to SCL; i.e.  is the command
{ a subcommand of a utility, or a "stand-alone" program.
{
{   Regardless of how it is invoked, a command processor is passed the
{ parameters described below.
{
{       command_processor (PARAMETER_LIST, STATUS)
{
{ PARAMETER_LIST: (input)  This parameter specifies the actual parameter list
{       for the command.  Command parameters are passed in a sequence for
{       compatibility with the passing of parameters to a program via the
{       pmp$execute request.  Normally the command processor passes this
{       parameter on to clp$evaluate_parameters to be interpreted.  If, for
{       some reason, the command processor needs to examine the unevaluated
{       parameters, it can pass this parameter to clp$get_parameter_list_text.
{
{ STATUS: (output)  This parameter specifies the completion status of the
{       command.  The command processor does not need to bother with the
{       command level status parameter optionally passed to it via the
{       clt$parameter_list.  The SCL interpreter will use the status passed
{       back to it in this parameter to handle the command level status
{       parameter.
{
*DECK DECK=CLH$COMMAND_PROCESSOR EXPAND=FALSE
{
{   A command processor is passed the following parameters.
{
{       command_processor (PARAMETER_LIST, STATUS)
{
{ PARAMETER_LIST:  (input)  This parameter specifies the actual parameter list
{       for the command.  Command parameters are  passed  in  a  sequence  for
{       compatibility  with  the  passing  of  parameters to a program via the
{       pmp$execute request.  The contents of this sequence  is  described  by
{       clt$parameter_list_contents.  The command processor, however, need not
{       be  aware  of  this  structure  since  it  simply  passes  it  on   to
{       clp$scan_parameter_list to be interpreted.
{
{ STATUS:  (output)  This  parameter  specifies  the  completion status of the
{       command.  The command processor does  not  need  to  bother  with  the
{       command  level  status  parameter  optionally  passed  to  it  via the
{       clt$parameter_list.  The SCL interpreter will use  the  status  passed
{       back  to  it  in  this  parameter  to  handle the command level status
{       parameter.
{
*DECK DECK=CLH$COMPLETE_FILE_REF_EVAL EXPAND=FALSE
{
{   This request is used to complete the evaluation of a file reference.  The
{ reference has the form of a file expression as defined for the NOS/VE command
{ interface.
{
*IF NOT $true(osv$unix)
{       CLP$COMPLETE_FILE_REF_EVAL (MULTIPLE_REFERENCE_ALLOWED,
*ELSE
{       CLP$COMPLETE_FILE_REF_EVAL (UNIX_PATH, MULTIPLE_REFERENCE_ALLOWED,
*IFEND
{             DEFER_EXPANSION, ENCODE_FILE_VALUES, INITIAL_PATH, PARSE,
{             WORK_AREA, RESULT, RESULT_SUB_LIST_TAIL, STATUS)
*IF $true(osv$unix)
{
{ UNIX_PATH: (input)  This option specifies whether the file reference's
{       syntax is that of a UNIX path (TRUE) or a NOS/VE path (FALSE).
*IFEND
{
{ MULTIPLE_REFERENCE_ALLOWED: (input)  This option specifies that the "wild
{       card" notation is to be allowed in the file reference.
{
{ DEFER_EXPANSION: (input)  This parameter specifies, if TRUE, that if the
{       "wild card" notation was used that no expansion into the corresponding
{       list of files is to be done.
{
{ ENCODE_FILE_VALUES: (input)  This parameter specifies that all file values
{       returned by this request should be encoded in the form of "path handle
{       names".
{
{ INITIAL_PATH: (input, output)  This parameter specifies a pre-evaluated
{       portion of the file reference.  If it is not NIL, then it represents an
{       evaluated file variable or function to be concatenated to the beginning
{       of the file reference contained within the PARSE.text.
{
{ PARSE: (input, output)  This parameter specifies the file expression whose
{       evaluation is to be completed.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to evaluate the file reference.  The current position of
{       this sequence pointer is updated to reflect the amount of storage used
{       by this request.
{
{ RESULT: (output)  This parameter specifies the result of the evaluation.  If
{       no "wild card" notation was used or if DEFER_EXPANSION is TRUE, this
{       parameter points to a CLC$FILE value; otherwise it points to a CLC$LIST
{       of CLC$FILE values.
{
{ RESULT_SUB_LIST_TAIL: (output)  If RESULT points to a CLC$LIST value, this
{       parameter points to the last node in that list (the "tail").  Otherwise
{       this parameter is NIL.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$COMPLETE_FILE_REF_PARSE EXPAND=FALSE
{
{    This request is used to complete the evaluation of a file reference.  The
{ reference has the form of a file expression as defined for the NOS/VE command
{ interface.
{
{       CLP$COMPLETE_FILE_REF_PARSE (INITIAL_PATH, PARSE, WORK_AREA,
{         FILE_REFERENCE_PARSING_OPTIONS, USER_IDENTIFICATION,
{         EVALUATED_FILE_REFERENCE, COMMAND_NAME, FORM, PARAMETER_NAME, STATUS)
{
{ INITIAL_PATH: (input, output)  This parameter specifies a pre-evaluated
{       portion of the file reference.  If it is not NIL, then it represents an
{       evaluated file variable or function to be concatenated to the beginning
{       of the file reference contained within the PARSE.text.
{
{ PARSE: (input, output)  This parameter specifies the file expression whose
{       evaluation is to be completed.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to parse the file reference.  The current position of this
{       sequence pointer is updated to reflect the amount of storage used by
{       this request.
{
{ FILE_REFERENCE_PARSING_OPTIONS: (input)  This parameter specifies the
{       parsing options which will govern the manner in which the expression
{       is evaluated.  The options are:
{
{       clc$use_$local_as_working_cat:  This option specifies that
{             $LOCAL should be used as the working catalog in the event that
{             the file reference is a relative path.  If this option is
{             omitted, the path is considered to be relative to the current
{             working catalog.
{
{       clc$evaluating_command_ref:  This option specifies that the
{             file reference is part of a command reference. Specifying
{             this option in conjunction with the clc$evaluating_entry_
{             point_ref option will result in an error.
{
{       clc$evaluating_entry_point_ref:  This option specifies that the
{             file reference is part of an entry point reference. Specifying
{             this option in conjunction with the clc$evaluating_command_ref
{             option will result in an error.
{
{       clc$multiple_reference_allowed:  This option specifies that the
{             "wild card" notation is to be allowed in the file reference.
{
{       clc$command_file_ref_allowed:  This option specifies that a
{             command file reference (i.e.  $COMMAND or $COMMAND_OF_CALLER) is
{             to be allowed.
{
{       clc$file_ref_evaluation_stage:  This option specifies the
{             extent to which the expression is evaluated.  If
{             this option is specified, the values of any variables or
{             functions in the expression are determined and an
{             absolute path is constructed. If omitted, additional
{             interpretation of generic path elements and cycle
{             references occurs, which is the case when the file
{             expression is being used to access a file or catalog.
{
{ USER_IDENTIFICATION: (input)  This parameter specifies the identification
{       of the current user.
{
{ EVALUATED_FILE_REFERENCE: (output)  This parameter specifies the information
{       resulting from the evaluation of the file reference.
{
{ COMMAND_NAME: (output)  This parameter is set only if the
{       clc$evaluating_command_ref option is specified in the
{       FILE_REFERENCE_PARSING_OPTIONS parameter.  It specifies the command
{       name part of the command reference.
{
{ FORM: (output)  This parameter is set only if the clc$evaluating_command_ref
{       option is specified in the FILE_REFERENCE_PARSING_OPTIONS parameter.
{       It represents the form in which the command reference was specified:
{
{       clc$module_or_file_command_ref <file> <.> <command_name> OR <catalog>
{       <.> <command_name> clc$file_cycle_command_ref <catalog> <.>
{       <command_name> <.> <cycle_reference>
{
{ PARAMETER_NAME: (output)  If this parameter's value is a null name then it
{       indicates that the file reference represents an omitted parameter.  In
{       this case, all other output parameters of this request are meaningless.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$CONSTRUCT_PATH_HANDLE_NAME EXPAND=FALSE
{
{   The purpose of this procedure is to construct a local file name  that  can
{ be  subsequently  used  to  rebuild  the  path  handle  from  which  it  was
{ constructed.  All components of the path handle enter into the  construction
{ of the path handle name.  The assignment_counter field of the path handle is
{ assumed to be a positive integer.
{
{       CLP$CONSTRUCT_PATH_HANDLE_NAME (PATH_HANDLE, PATH_HANDLE_NAME)
{
{ PATH_HANDLE: (input) This parameter specifies the path handle from which the
{       name is to be constructed.
{
{ PATH_HANDLE_NAME: (output) This parameter specifies the local file name that
{       can subsequently be used as a path handle name.
{
*DECK DECK=CLH$CONVERT_CHAR_TO_GRAPHIC EXPAND=FALSE
{
{   The purpose of this request is to produce a displayable representation of a
{ non-displayable ASCII character.
{
{       CLP$CONVERT_CHAR_TO_GRAPHIC (CH, CHAR_STRING, STATUS);
{
{ CH: (input)  This parameter specifies the character for which a
{       representation is to be produced.
{
{ CHAR_STRING: (output)  This parameter specifies the representation of the
{       character.  If a displayable character is specified for CH, that
{       character is its own representation.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$CONVERT_CYC_REF_TO_CYC_SEL EXPAND=FALSE
{
{   The purpose of this request is to convert an FST$CYCLE_REFERENCE to a
{ CLT$CYCLE_SELECTOR.
{
{       CLP$CONVERT_CYC_REF_TO_CYC_SEL (FS_CYCLE_REFERENCE, CYCLE_SELECTOR)
{
{ FS_CYCLE_REFERENCE: (input)  This parameter specifies the cycle reference to
{       be converted.
{
{ CYCLE_SELECTOR: (output)  This parameter specifies the resulting cycle
{       selector.
{
*DECK DECK=CLH$CONVERT_DATA_TO_STRING EXPAND=FALSE
{
{   The purpose of this request is to convert a clt$data_value to its string
{ representation.  The representation may take on a number of forms determined
{ by the REPRESENTATION_OPTION parameter.
{
{   This representation is returned in a sequence.  The first data item in the
{ sequence is a clt$data_representation_count, i.e.  the number of strings
{ used in the representation.  The remaining data is a series of
{ clt$string_size, clt$string_value pairs with the length of each
{ clt$string_value determined by the corresponding clt$string_size.
{
{       CLP$CONVERT_DATA_TO_STRING (VALUE, REPRESENTATION_OPTION, MAX_STRING,
{         WORK_AREA, DATA_REPRESENTATION, STATUS)
{
{ VALUE: (input)  This parameter specifies the data value to be converted.
{
{ REPRESENTATION_OPTION: (input)  This parameter specifies the form of the
{       data value's representation as determined by the following options:
{
{       CLC$COMPRESSED_LABELED_ELEM_REP:  each element of the data value is
{             converted to display.  Items that are components of data
{             structures are prefixed with identifying "labels", e.g.  field
{             names for record elements, subscripts for array elements, etc.
{             When possible, multiple items are placed in one string seperated
{             by commas.
{
{       CLC$DATA_ELEM_REPRESENTATION:  each element of the data value is
{             converted to a separate string in the representation.  Status
{             values are formatted as messages and may therefore occupy more
{             than one string.  The built-in record types command_reference,
{             date_time, entry_point_reference, scu_line_identifier,
{             time_increment and time_zone are considered to be elements for
{             purposes of this option.
{
{       CLC$DATA_STRUCT_REPRESENTATION:  each element of the data value is
{             converted to a separate string in the representation.  The
{             generic data type of the value (and components of the value, if
{             applicable) are included in the representation as "comments"
{             prefixing the corresponding value or value component.  Items that
{             are components of data structures are prefixed with identifying
{             "labels", e.g.  field names for record elements, subscripts for
{             array elements, etc.
{
{       CLC$DATA_SOURCE_REPRESENTATION:  the data value is represented in the
{             form of an SCL "expression" that if evaluated with an appropriate
{             type specification would yield exactly the same data value.  All
{             strings in the representation, except the last, will end with an
{             ellipsis ("..").
{
{       CLC$DISPLAY_ELEM_REPRESENTATION:  each element of the data value is
{             converted to a separate string in the representation.  The
{             elements are converted using display conventions so all names,
{             keywords, and files are in lower case characters.  Status values
{             are formatted as messages and may therefore occupy more than one
{             string.  The built-in record types command_reference, date_time,
{             entry_point_reference, scu_line_identifier, time_increment and
{             time_zone are considered to be elements for purposes of this
{             option.
{
{       CLC$DISPLAY_SOURCE_REPRESENTATION:  the data value is represented in
{             the form of an SCL "expression" that if evaluated with an
{             appropriate type specification would yield exactly the same data
{             value.  The elements are converted using display conventions so
{             all names, keywords, and files are in lower case characters.  All
{             strings in the representation, except the last, will end with an
{             ellipsis ("..").
{
{       CLC$LABELED_ELEM_REPRESENTATION:  each element of the data value is
{             converted to a separate string in the representation.  Items that
{             are components of data structures are prefixed with identifying
{             "labels", e.g.  field names for record elements, subscripts for
{             array elements, etc.  Each of these "labels" is a separate string
{             in the representation if the value of the corresponding component
{             also has components.
{
{ MAX_STRING: (input)  This parameter specifies the maximum length of strings
{       in the representation of the value.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the value's representation.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The value's respresentation occupies the
{       used part of this sequence.
{
{ DATA_REPRESENTATION: (output)  This parameter specifies the data value's
{       representation as described above.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$work_area_overflow
{                   cle$bad_data_rep_option
{                   cle$bad_data_value
{
*DECK DECK=CLH$CONVERT_DATE_TIME_TO_STRING EXPAND=FALSE
{
{   This request produces the string representation  of  a  date  and/or  time
{ and/or day of the week.
{
{       CLP$CONVERT_DATE_TIME_TO_STRING (DATE_TIME, FORMAT, STR, STATUS)
{
{ DATE_TIME: (input) This parameter specifies the date/time to be represented.
{
{ FORMAT: (input) This parameter specifies the "date time form string"  to  be
{       used to guide the construction of the representation.
{
{ STR: (output) This parameter specifies the result string.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=CLH$CONVERT_FILE_REF_TO_STRING EXPAND=FALSE
{
{   This request produces the  string  representation  of  an  evaluated  file
{ reference.
{
*IF NOT $true(osv$unix)
{       CLP$CONVERT_FILE_REF_TO_STRING (EVALUATED_FILE_REFERENCE, STR, SIZE,
{         STATUS)
*ELSE
{       CLP$CONVERT_FILE_REF_TO_STRING (EVALUATED_FILE_REFERENCE,
{         INCLUDE_OPEN_POSITION, STR, SIZE, STATUS)
*IFEND
{
{ EVALUATED_FILE_REFERENCE:   (input)   This   parameter  specifies  the  file
{       reference to be converted.
{
*IF $true(osv$unix)
{
{ INCLUDE_OPEN_POSITION: (input)  This parameter specifies whether an open
{       position designator in the EVALUATED_FILE_REFERENCE should be
{       represented in the string.
{
*IFEND
{ STR: (output) This parameter specifies the resulting string.
{
{ SIZE: (output) This parameter specifies the  number  of  characters  in  the
{       resulting string excluding trailing space characters.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=CLH$CONVERT_INTEGER_TO_RJSTRING EXPAND=FALSE
{
{   The purpose  of  this  request  is  to  convert  an  integer to its string
{ representation in a specified radix.  The result is right justified  in  the
{ returned  string.   If the integer is negative, a minus sign (-) is included
{ in the result either just to the left of the converted integer if  the  fill
{ character is a space, or as the leftmost character of the result string.  If
{ the specified radix is greater than ten and the leftmost digit of the result
{ is  greater  than  nine, then a leading zero digit is added to the result if
{ the result string is long enough to hold it.
{
{       CLP$CONVERT_INTEGER_TO_RJSTRING (INT, RADIX, INCLUDE_RADIX_SPECIFIER,
{         FILL_CHARACTER, STR, STATUS)
{
{ INT: (input) This parameter specifies the integer to be converted.
{
{ RADIX:  (input)  This  parameter  specifies the radix in which the integer's
{       value is to be represented.
{
{ INCLUDE_RADIX_SPECIFIER:  (input)  This  parameter  specifies  whether   the
{       representation  of the radix is to be included in the resulting string
{       -- e.g.  (16) for a number with a radix of 16.
{
{ FILL_CHARACTER: (input) This parameter specifies the character used to  fill
{       unused positions in the returned string.
{
{ STR: (output)  This  parameter  specifies  the  string representation of the
{       integer.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$string_too_short
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$CONVERT_INTEGER_TO_STRING EXPAND=FALSE
{
{   The purpose  of  this  request  is  to  convert  an  integer to its string
{ representation in a specified radix.  The result is left  justified  in  the
{ returned  string.   If  the  integer is negative, the first character of the
{ result is a minus sign (-).  If the specified radix is greater than ten  and
{ the  leftmost  digit of the result is greater than nine, then a leading zero
{ digit is added to the result.
{
{       CLP$CONVERT_INTEGER_TO_STRING (INT, RADIX, INCLUDE_RADIX_SPECIFIER,
{         STR, STATUS)
{
{ INT: (input) This parameter specifies the integer to be converted.
{
{ RADIX:  (input)  This  parameter  specifies the radix in which the integer's
{       value is to be represented.
{
{ INCLUDE_RADIX_SPECIFIER:  (input)  This  parameter  specifies  whether   the
{       representation  of the radix is to be included in the resulting string
{       -- e.g.  (16) for a number with a radix of 16.
{
{ STR: (output) This parameter specifies  the  string  representation  of  the
{       integer.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$CONVERT_PDT EXPAND=FALSE
{
{   This request converts an "old" PDT (clt$paramter_descriptor_table) to a
{ "new" PDT (clt$parameter_description_table).
{
{       CLP$CONVERT_PDT (OLD_PDT, WORK_AREA, NEW_PDT, STATUS)
{
{ OLD_PDT: (input)  This parameter specifies the PDT to be converted.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the new PDT.  The current position of this
{       sequence pointer is updated to reflect the amount of storage used by
{       the request.
{
{ NEW_PDT: (output)  This parameter specifies the converted PDT.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$CONVERT_REAL_TO_STRING EXPAND=FALSE
{
{   This request converts a real number to  its  string  representation.   The
{ result  is  left  justified  in  the returned string.  If the real number is
{ negative, the first character of the result is a minus  sign  (-).   If  the
{ absolute value of the real number is less than or equal to 10**-6 or greater
{ than 10**9, then an exponent is included in the result.
{
{       CLP$CONVERT_REAL_TO_STRING (REAL_NUMBER, NUMBER_OF_DIGITS, STR,
{         STATUS)
{
{ REAL_NUMBER:  (input)  This  parameter  specifies  the  real  number  to  be
{       converted.
{
{ NUMBER_OF_DIGITS:  (input)  This  parameter  specifies the maximum number of
{       digits to include in the result.  There may be fewer digits than  this
{       since zero  digits to the right of the decimal point are not included.
{
{ STR: (output) This parameter specifies the string representation of the real
{       number.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=CLH$CONVERT_STRING_TO_DATE_TIME EXPAND=FALSE
{
{   This request interprets the string representation of a date and/or time to
{ produce a formal representation of the date/time.
{
{       CLP$CONVERT_STRING_TO_DATE_TIME (STR, FORMAT, DATE_TIME, STATUS)
{
{ STR: (input)  This parameter specifies the string to be interpreted.
{
{ FORMAT: (input)  This  parameter specifies the "date time form string" to be
{       used to guide the interpretation.  If the format is null or all blanks
{       an  attempt  is  made  to  match  the  input string against one of the
{       standard "date time form strings".
{
{ DATE_TIME: (output)  This parameter specifies the interpreted date/time.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=CLH$CONVERT_STRING_TO_FILE EXPAND=FALSE
{
{   The purpose of this request is to convert a string to a file.  As a result
{ of this request, a "local file name" is assigned to designate the file
{ reference.
{
{       CLP$CONVERT_STRING_TO_FILE (STR, FILE, STATUS)
{
{ STR: (input)  This parameter specifies the string to be converted.
{
{ FILE: (output)  This parameter specifies the file.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$CONVERT_STRING_TO_FILE_PATH EXPAND=FALSE
{
{   This request is used to convert a string to a resolved file reference.  The
{ resolved path is returned in two forms:  the complete path, and optionally
{ the "path handle name" form.
{
{       CLP$CONVERT_STRING_TO_FILE_PATH (STR, USE_$LOCAL_AS_WORKING_CATALOG,
{         RETURN_PATH_HANDLE_NAME, PATH_HANDLE_NAME, RESOLVED_PATH, STATUS)
{
{ STR: (input)  This parameter specifies the string, representing a file
{       expression, to be converted.
{
{ USE_$LOCAL_AS_WORKING_CATALOG: (input)  This parameter specifies whether
{       $LOCAL should be used as the working catalog in the event that the file
{       reference is a relative path.  If this parameter is FALSE, the path is
{       considered to be relative to the current working catalog.
{
{ RETURN_PATH_HANDLE_NAME: (input)  This parameter specifies whether the
{       path_handle_name for the file reference should be returned.  This
{       option exists soley for compatibility reasons, and should normally be
{       set to FALSE.
{
{ PATH_HANDLE_NAME: (output)  This parameter specifies the resulting path in
{       the form of a path handle name.  Its value will be a null name if
{       RETURN_PATH_HANDLE_NAME is set to FALSE.  This parameter exists soley
{       for compatibility reasons.  Use of this parameter is not recommended.
{
{ RESOLVED_PATH: (output)  This parameter specifies the resulting path in the
{       complete path format.  This record contains information that allows
{       easy access to the entire path or components of it.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$CONVERT_STRING_TO_FILE_REF EXPAND=FALSE
{
{   The purpose of this request is to convert a string to a file reference.
{ The string is assumed to contain a file expression.  The returned parsed file
{ reference provides for accessing the entire path of the file reference or its
{ components.
{
{       CLP$CONVERT_STRING_TO_FILE_REF (STR, PARSED_FILE_REFERENCE, STATUS)
{
{ STR: (input)  This parameter specifies the string to be converted.
{
{ PARSED_FILE_REFERENCE: (output)  This parameter specifies the file reference.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$CONVERT_STRING_TO_INTEGER EXPAND=FALSE
{
{   The purpose  of this request is to convert the string representation of an
{ integer to an integer.  The string representation may contain a leading sign
{ (+ or -) and/or a trailing radix enclosed in parentheses.
{
{       CLP$CONVERT_STRING_TO_INTEGER (STR, INT, STATUS)
{
{ STR: (input) This parameter specifies the string to be converted.
{
{ INT: (output)  This  parameter  specifies  the converted integer value along
{       with the radix in which the integer was represented.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: clc$min_ecc_lexical ..  clc$max_ecc_lexical
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$CONVERT_STRING_TO_NAME EXPAND=FALSE
{
{   The purpose  of  this  request  is  to  convert  a  string to a name.  The
{ conversion invloves  padding  the  name  with  spaces  (on  the  right)  and
{ transforming lower case letters into their upper case counterparts.
{
{       CLP$CONVERT_STRING_TO_NAME (STR, NAME, STATUS)
{
{ STR: (input) This parameter specifies the string to be converted.
{
{ NAME: (output) This parameter specifies the converted name and its length.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: clc$min_ecc_lexical ..  clc$max_ecc_lexical
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$CONVERT_STRING_TO_REAL EXPAND=FALSE
{
{   This request converts the string representation of a real number to a real
{ number.  The string representation may contain leading sign (+ or -).
{
{       CLP$CONVERT_STRING_TO_REAL (STR, REAL_NUMBER, STATUS)
{
{ STR: (input) This parameter specifies the string to be converted.
{
{ REAL_NUMBER: (output) This parameter specifies the resulting real number.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=CLH$CONVERT_VALUE_TO_STRING EXPAND=FALSE
{
{   The purpose  of  this  request  is  to  convert a value (clt$value) into a
{ string.  If the value is a variable reference or a name  that  designates  a
{ variable  then:  if  the  reference is to an array then a description of the
{ array is returned; otherwise the value of the variable is  returned  in  the
{ string.   If  the value is not convertable to a string then a description of
{ it is returned.
{
{       CLP$CONVERT_VALUE_TO_STRING (VALUE, STR, STATUS)
{
{ VALUE: (input) This parameter specifies the value to be converted.
{
{ STR: (output) This parameter specifies  the  string  representation  of  the
{       value.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nome
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$COUNT_LIST_ELEMENTS EXPAND=FALSE
{
{   This function returns a count of the number of elements in an SCL list
{ value.  If the list is empty, zero is returned.  If the value passed to
{ this function is not a properly formed list the results are undefined.
{
{       CLP$COUNT_LIST_ELEMENTS (LIST_VALUE):  COUNT
{
{ LIST_VALUE: (input)  This parameter specifies the list value whose elements
{       are to be counted.
{
*DECK DECK=CLH$CREATE_ENVIRONMENT_VARIABLE EXPAND=FALSE
{
{   This request creates an SCL "environment" variable.
{
{       CLP$CREATE_ENVIRONMENT_VARIABLE (NAME, SCOPE, ACCESS_MODE,
{         EVALUATION_METHOD, TYPE_SPECIFICATION, INITIAL_VALUE, STATUS)
{
{ NAME: (input)  This parameter specifies the name of the variable to be
{       created.
{
{ SCOPE: (input)  This parameter specifies the scope (residence) of the
{       environment variable.  The options are:
{
{       clc$environment_scope:  the variable is to be created in the current
{             block
{
{       clc$utility_scope:  the variable is to be created in the most recently
{             activated utility block
{
{       clc$task_scope:  the variable is to be created in the most recently
{             activated task block
{
{       clc$job_scope:  the variable is to be created in the job block
{
{       clc$push_scope:  this is, strictly speaking, not a true scope.  It is
{             provided as a convenience for defining environment variables in
{             a context where a definition may or may not have already been
{             made.
{
{             If the variable has already been defined as an environment
{             variable, it is PUSHed (see the clp$push_environment request for
{             information on pushing an environemnt variable).  The type must
{             be identical to the original definition.  If an initial value is
{             specified, it becomes the value of the PUSHed instance of the
{             variable.
{
{             If the variable has not already been defined, it is defined with
{             a scope of clc$environment_scope.
{
{ ACCESS_MODE: (input)  This parameter specifies how the variable, once
{       created, may be accessed.
{
{ EVALUATION_METHOD: (input)  This parameter specifies whether values assigned
{       to the variable are to be evaluated at the time of the assignment
{       (clc$immediate_evaluation) or at the time the variable is referenced
{       (clc$deferred_evaluation).  Immediate evaluation is the normal choice.
{
{ TYPE_SPECIFICATION: (input)  This parameter specifies the type of the
{       variable to be created.
{
{ INITIAL_VALUE: (input)  This parameter specifies the initial value to to be
{       given to the created variable.  If clc$read_write is specified for
{       ACCESS_MODE, no initial value need be supplied (indicated by giving a
{       NIL pointer).  If clc$read_only is specified, an initial value for the
{       variable must be supplied.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$CREATE_FILE_CONNECTION EXPAND=FALSE
{
{   The purpose  of  this  request  is  to  establish  a "connection" from the
{ subject file to the target file.  The effect of this connection is that  any
{ data  access  requests  against the subject file are passed on to the target
{ file.
{   A subject file may be connected to more than one target file.
{   Output requests for the subject file are passed on to all targets.
{   Input requests are passed on only to the most recently connected target.
{   The amp$fetch_access_information, amp$fetch  and  amp$store  requests  are
{ passed on only to the least recently connected target.
{   The ifp$fetch_terminal and ifp$store_terminal requests are passed on  only
{ to the most recently connected target for which they are appropriate.
{   If the  subject  file  is not currently connected to any target files, the
{ connection is made only for subsequent opens of the subject file (i.e.   for
{ any  current opens of the subject file the connection is ignored).  However,
{ if the subject file is currently connected to one or more target files,  the
{ new connection is immediate.
{
{   The connection  will  be  rejected  if  the  attributes of the subject and
{ target files are incompatible.  The attributes in question are file_contents
{ and  file_structure.   The  corresponding  attributes  of the two files must
{ either be identical or the value for one of the files must be "unknown".
{   If the  target  file  doesn't  currently  exist the default values for its
{ file_contents  and  file_strucutre  attributes  will  be  the  corresponding
{ attribute values of the subject file.
{
{   The following   files   may   not   be   the   subject  of  a  connection:
{ clc$current_command_input,       clc$job_command_input,       clc$job_input,
{ clc$proc_caller_command_input, clc$job_output and clc$null_file.
{
{       CLP$CREATE_FILE_CONNECTION (SUBJECT_FILE, TARGET_FILE, STATUS)
{
{ SUBJECT_FILE:  (input)  This  parameter  specifies  the  file from which the
{       connection is to be made.
{
{ TARGET_FILE:  (input)  This  parameter  specifies  the  file  to  which  the
{       connection is to be made.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$improper_subject_file_name,
{             cle$improper_target_file_name, cle$duplicate_file_connection,
{             cle$circular_file_connection, cle$incompatible_file_connect,
{             cle$subject_cannot_be_connected
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$CREATE_PROCEDURE_VARIABLE EXPAND=FALSE
{
{   This request creates an SCL "procedure" variable.
{
{       CLP$CREATE_PROCEDURE_VARIABLE (NAME, SCOPE, ACCESS_MODE,
{         EVALUATION_METHOD, TYPE_SPECIFICATION, INITIAL_VALUE, STATUS)
{
{ NAME: (input) This parameter specifies  the  name  of  the  variable  to  be
{       created.
{
{ SCOPE:  (input)  This  parameter  specifies the scope (accessibility) of the
{       procedure variable.  The options are:
{
{       clc$local_scope: the variable is to  be  accessible  only  within  the
{             current block
{
{       clc$xdcl_scope:  the  variable  is  to  be  accessible  by  any  block
{             performing a corresponding XREF declaration.
{
{       clc$xref_scope: the variable to be created is actually a reference  to
{             a variable created with a corresponding XDCL declaration.
{
{ ACCESS_MODE:  (input)  This  parameter  specifies  how  the  variable,  once
{       created, may be accessed.
{
{ EVALUATION_METHOD: (input)  This parameter specifies whether values assigned
{       to the variable are to be evaluated at the time of the assignment
{       (clc$immediate_evaluation) or at the time the variable is referenced
{       (clc$deferred_evaluation).  Immediate evaluation is the normal choice.
{
{ TYPE_SPECIFICATION:  (input)  This  parameter  specifies  the  type  of  the
{       variable to be created.
{
{ INITIAL_VALUE:  (input)  This specifies the initial value to be given to the
{       created variable.  If clc$read_write is specified for ACCESS_MODE,  no
{       initial  value  need  be supplied (indicated by giving a NIL pointer).
{       If clc$read_only is specified, an initial value for the variable  must
{       be  supplied.   If  clc$xref_scope  is specified for SCOPE, no initial
{       value may be supplied.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$CREATE_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to create a command language variable.  The
{ variable is initialized according to its kind: "null" for string,  zero  for
{ integer and real, false for boolean, and "normal" for status.
{
{       CLP$CREATE_VARIABLE (NAME, KIND, MAX_STRING_SIZE, LOWER_BOUND,
{         UPPER_BOUND, SCOPE, VARIABLE, STATUS)
{
{ NAME: (input) This parameter  specifies  the  name  of  the  variable  being
{       created.
{
{ KIND: (input) This parameter specifies the kind of variable being created.
{
{ MAX_STRING_SIZE: (input) This parameter specifies the maximum size for (each
{       element of) a string variable.  If the variable kind  is  not  string,
{       this parameter is ignored.
{
{ LOWER_BOUND: (input) This parameter specifies the smallest index (subscript)
{       for an array variable.  If the value of this parameter is equal to the
{       value of the upper_bound parameter, the variable is not considerred to
{       be an array.
{
{ UPPER_BOUND: (input) This parameter specifies the largest index  (subscript)
{       for  an  array  variable.   The  number of elements in the variable is
{       upper_bound-lower_bound+1.
{
{ SCOPE: (input) This parameter specifies the  scope  of  the  variable.   The
{       options are:
{
{       clc$local_variable  -  The lifetime of a local variable is that of the
{             block in which it is created unless it is explicitly deleted.  A
{             local  variable can only be referenced within the block in which
{             it is created.
{
{       clc$utility_variable  -  Creating  a  variable  with  this  option  is
{             equivalent   to   creating   a   variable   with   a   scope  of
{             clc$xdcl_variable from within the utility  block.   This  option
{             permits  a  command  called  from within the utility to create a
{             variable whose scope is the entire utility rather than just that
{             of the command actually doing the creating.
{
{       clc$job_variable  - Creating a variable with this option is equivalent
{             to creating a variable with a scope  of  clc$xdcl_variable  from
{             within the job block.  This option permits a command called from
{             within the job to create a variable whose scope  is  the  entire
{             job  rather  than  just  that  of the command actually doing the
{             creating.
{
{       clc$xdcl_variable - An xdcl (externally  declared)  variable  has  the
{             same lifetime as a local variable but is accessible by any block
{             contained  within  the  creating   block   provided   that   the
{             referencing block specifies a scope of xref.
{
{       clc$xref_variable - An xref (externally referenced)  variable  is  one
{             that  actually exists in another block and in that block has the
{             xdcl  attribute.   When  this   option   is   used   the   kind,
{             max_string_size  and  dimension  parameters are compared against
{             those attributes of the actual variable and must match.
{
{ VARIABLE: (output) This parameter specifies the descriptor for the  variable
{       once it has been created.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$improper_variable_name, cle$improper_var_specification,
{             cle$no_space_for_var, cle$unknown_utility,
{             cle$var_already_created.
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$DATA_REPRESENTATION_TEXT EXPAND=FALSE
{
{   This function is intended for use following a call to
{ CLP$CONVERT_DATA_TO_STRING.  Given a pointer to the "data representation"
{ produced by that request it returns a pointer to the first "line" of that
{ representation.  It is intended as a convenience; for use only in those cases
{ where the representation consists of exactly one "line".
{
{       CLP$DATA_REPRESENTATION_TEXT (REPRESENTATION):  TEXT
{
{ REPRESENTATION: (input)  This parameter specifies the data representation
{       produced by CLP$CONVERT_DATA_TO_STRING.
{
{ TEXT: (result)  The function's result specifies a pointer to the first "line"
{       within the representation.
{
*DECK DECK=CLH$DEFINE_APPLIC_UNIT_ARRAY EXPAND=FALSE
{
{   This interface is used by a unit measured application to define the storage
{ area where it will place its "units".  Unit measurement is the measurement of
{ resources calculated by the application itself(e.g.  number of schematics
{ produced by a CAD program).
{
{       CLP$DEFINE_APPLIC_UNIT_ARRAY (APPLICATION_UNIT_ARRAY,
{         APPLICATION_UNIT_ARRAY_SIZE, APPLICATION_ADDRESS, STATUS);
{
{ APPLICATION_UNIT_ARRAY:  (input) Specifies a pointer to an array of integers
{        within the application that will contain the "units" for the
{        application.  The storage area for the array of integers MUST be
{        staticly allocated!  If it is not the array may not be accessable by
{        SCL when the application terminates.
{
{ APPLICATION_UNIT_ARRAY_SIZE:  (input) Specifies the number of integer
{        elements in the array specifed by the APPLICATION_UNIT_ARRAY
{        parameter.
{
{ APPLICATION_ADDRESS:  (input) Specifies PVA that points to executable code in
{        the application module.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS:  cle$cannot_access_unit_array
{                      cle$multiple_applic_unit_arrays
{                      pme$pva_not_in_any_module
*DECK DECK=CLH$DEFINE_MESSAGE_MODULE EXPAND=FALSE
{
{   The purpose of this request is to construct a message module for  addition
{ to or replacement on an object library.
{
{   A  utility  environemnt  is established to accept the commands that define
{ individual messages.
{
{   If a NIL  pointer  is  returned  via  the  message_module  parameter,  the
{ creation of the message module is to be abandoned.  If a status condition of
{ cle$errors_in_module is returned, the message module has been built but  may
{ be  incomplete  because  of  problems with message definitions; in this case
{ messages are written using ocp$generate_message for each  problem.   If  any
{ other  status  condition  is  returned,  the module could not be built, even
{ incompletely.
{
{       CLP$DEFINE_MESSAGE_MODULE (MODULE_NAME, NATURAL_LANGUAGE,
{         ONLINE_MANUAL_NAME, WORK_AREA, MESSAGE_MODULE, STATUS)
{
{ MODULE_NAME: (input) This parameter specifies the name of the  module  being
{       defined.
{
{ NATURAL_LANGUAGE:  (input)  This parameter specifies the natural language in
{       which all of the messages to be included in this module are written.
{
{ ONLINE_MANUAL_NAME: (input) This parameter specifies the name of the  online
{       manual that contains information about the messages in this module.
{
{ WORK_AREA:  (input)  This  parameter specifies the storage area in which the
{       module data will be placed.
{
{ MESSAGE_MODULE: (output) This parameter specifies the data representing  the
{       message module.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$errors_in_module
{
*DECK DECK=CLH$DEFINE_SCL_PROCEDURE EXPAND=FALSE
{
{   The purpose of this request is to prepare an SCL Procedure for addition to
{ or replacement on an object library.
{
{   The procedure file is read from its current position until either a PROCEND
{ statement is found or end of information is reached.  This provides for
{ having more than one SCL Procedure on the same input file.
{
{       CLP$DEFINE_SCL_PROCEDURE (FILE_ID, WORK_AREA, PROCEDURE_NAME, ALIASES,
{         COMMAND_OR_FUNCTION, AVAILABILITY, COMMAND_KIND, COMMAND_LOG_OPTION,
{         SCL_PROCEDURE, FILE_POSITION, STATUS)
{
{ FILE_ID: (input)  This parameter specifies the identifier of the file
{       containing the SCL Procedure.
{
{ WORK_AREA: (input)  This parameter specifies the storage area in which the
{       procedure data and aliases will be placed.
{
{ PROCEDURE_NAME: (output)  This parameter specifies the name of the SCL
{       Procedure to be used both as the module name and as an entry point name
{       for the procedure on the library.
{
{ ALIASES: (output)  This parameter specifies the aliases for the procedure
{       name.  NIL is used to indicate no aliases.
{
{ COMMAND_OR_FUNCTION: (output)  This parameter specifies whether the procedure
{       being defined is a command procedure or a function procedure.
{
{ AVAILABILITY: (output)  This parameter specifies whether the procedure is to
{       be advertised or hidden (for instance, by the
{       display_command_list_entry command).
{
{ COMMAND_KIND: (output)  This parameter specifies the scope of the procedure.
{
{ COMMAND_LOG_OPTION: (output)  This parameter specifies whether calls to the
{       command procedure are to be logged automatically or manually.
{
{ SCL_PROCEDURE: (output)  This parameter specifies the data representing the
{       procedure.
{
{ FILE_POSITION: (output)  This parameter specifies the input file's (the file
{       containing the command procedures) current position.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:  cle$expecting_proc
{
*DECK DECK=CLH$DELETE_ALL_FILE_CONNECTIONS EXPAND=FALSE
{
{    The purpose of this request is to break all file connections including the
{ connections initially created by the system.  The deletion of the connection
{ is immediate.  Once all connections from a subject file have been deleted,
{ normal processing of the file is resumed.
{
{    The system initially connects clc$job_command_response to clc$job_log and
{ (for an interactive job) to clc$job_output.  This original connection of
{ clc$job_command_response may not be deleted.
{
{    CLP$DELETE_ALL_FILE_CONNECTIONS
{
*DECK DECK=CLH$DELETE_ALL_TARGETS EXPAND=FALSE
{
{   The purpose of this request is to break all "connections" from the subject
{ file   to   each   target    file    that    was    established    by    the
{ clp$create_file_connection  request.   The  deletion  of  the  connection is
{ immediate.  Once all connections from a  subject  file  have  been  deleted,
{ normal processing of the file is resumed.
{
{   The system initially  connects clc$job_command_response to clc$job_log and
{ (for an interactive job)  to  clc$job_output.   This   original   connection
{ of clc$job_command_response may not be deleted.
{
{       CLP$DELETE_ALL_TARGETS (SUBJECT_FILE, STATUS)
{
{ SUBJECT_FILE:  (input)  This  parameter  specifies  the  file from which the
{       connection is to be deleted.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$improper_subject_file_name,
{             cle$improper_target_file_name, cle$unknown_file_connection,
{             cle$connection_cannot_be_broken
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$DELETE_FILE_CONNECTION EXPAND=FALSE
{
{   The purpose  of  this  request is to break a "connection" from the subject
{ file   to   the    target    file    that    was    established    by    the
{ clp$create_file_connection  request.   The  deletion  of  the  connection is
{ immediate.  Once all connections from a  subject  file  have  been  deleted,
{ normal processing of the file is resumed.
{
{   The system  initially  connects clc$job_command_response to clc$job_output
{ (for an interactive job) or  to  (clc$null_file)  for  a  batch  job.   This
{ original connection of clc$job_command_response may not be deleted.
{
{       CLP$DELETE_FILE_CONNECTION (SUBJECT_FILE, TARGET_FILE, STATUS)
{
{ SUBJECT_FILE:  (input)  This  parameter  specifies  the  file from which the
{       connection is to be deleted.
{
{ TARGET_FILE:  (input)  This  parameter  specifies  the  file  to  which  the
{       connection  is  to be deleted.  If this file has been connected to the
{       subject file more than  once,  only  the  most  recent  connection  is
{       deleted.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$improper_subject_file_name,
{             cle$improper_target_file_name, cle$unknown_file_connection,
{             cle$connection_cannot_be_broken
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$DELETE_FILE_FROM_CMND_LIST EXPAND=FALSE
{
{   The purpose of this request is to delete an entry other than a utility from
{ the command list.
{
{       CLP$DELETE_FILE_FROM_CMND_LIST (ENTRY, STATUS)
{
{ ENTRY: (input)  This parameter specifies the name of the file to be
{       deleted from the command list.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:  cle$entry_not_in_comamnd_list
{                    cle$exclusve_mode_excludes_cmnd
{                    cle$not_in_command_list
{                    cle$restricted_mode_cmnd_change
{
*DECK DECK=CLH$DELETE_VARIABLE EXPAND=FALSE
{
{   The purpose  of this request is to delete a command language variable from
{ the current block.
{
{       CLP$DELETE_VARIABLE (NAME, STATUS)
{
{ NAME: (input) This parameter specifies  the  name  of  the  variable  to  be
{       deleted.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$improper_variable_name, cle$unknown_variable.
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$DERIVE_TYPE_SPEC_FROM_VALUE EXPAND=FALSE
{
{   This request derives a clt$type_specification to correspond to a
{ clt$data_value.
{
{       CLP$DERIVE_TYPE_SPEC_FROM_VALUE (VALUE, WORK_AREA, TYPE_SPECIFICATION,
{         STATUS)
{
{ VALUE: (input)  This parameter specifies the value for which a type
{       specification is desired.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the type specification.  The current position
{       of this sequence pointer is updated to reflect the amount of storage
{       used by the request.
{
{ TYPE_SPECIFICATION: (output)  This parameter specifies the derived type
{       specification.
{
{ STATUS: (output)  This paramter specifies the request status.
{
*DECK DECK=CLH$DISCARD_ACCUMULATED_DISPLAY EXPAND=FALSE
{
{   The purpose of this request is to discard any data accumulated for a line,
{ e.g.  via clp$put_partial_display requests.  This request is meaningless if
{ the most recent "write" operation to the display was via clp$put_display or
{ clp$put_partial_display with the amc$terminate option.
{
{       CLP$DISCARD_ACCUMULATED_DISPLAY (DISPLAY_CONTROL, STATUS)
{
{ DISPLAY_CONTROL: (input, output)  This parameter specifies the
{       display_control variable initialized when the display was opened.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$EDIT_COMMAND_PARAMETER_LIST EXPAND=FALSE
{
{   This request is used to edit the parameter list for a command.  The caller
{ supplies the text of a call to a command including both the command reference
{ and parameter list (the parameter list may be empty).  An environment is
{ established such when the command processor requests that its parameters be
{ evaluated, a parameter dialog in the currently selected interaction style is
{ initiated.  This dialog differs from the standard parameter dialog in that
{ required parameters are treated as optional, default values are not evaluated
{ and if the command processor supplied a "check parameter procedure" it is
{ ignored.
{
{   The edited parameter list is constructed from the parameters supplied by
{ the user during the parameter dialog.  The representation of the edited
{ parameter list is returned in a sequence.  The first data item in the
{ sequence is a clt$data_representation_count, i.e. the number of strings used
{ in the representation.  The remaining data is a series of clt$string_size,
{ clt$string_value pairs with the length of each clt$string_value determined by
{ the corresponding clt$string_size.
{
{   Only commands the use clp$evaluate_paramters (or clp$scan_parameter_list).
{ can have their parameter lists successfully edited via this request.
{
{       CLP$EDIT_COMMAND_PARAMETER_LIST (COMMAND_AND_PARAMETERS, MAX_STRING,
{         WORK_AREA, EDITED_PARAMETERS, STATUS)
{
{ COMMAND_AND_PARAMETERS: (input)  This parameter specifies the text of a call
{       to the command for which a parameter list is to be edited.
{
{ MAX_STRING: (input)  This parameter specifies the maximum length of strings
{       in the representation of the edited parameter list.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the edited parameter list.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The edited parameter list's
{       representation occupies the used part of this sequence.
{
{ EDITED_PARAMETERS: (output)  This parameter specifies the edited parameter
{       list's representation as described above.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: cle$work_area_overflow
{
*DECK DECK=CLH$END_INCLUDE EXPAND=FALSE
{
{   The purpose of this request is to terminate the interpretation of commands
{ for a command utility that was initiated by an INCLUDE_FILE command
{ (clp$include_file request) or an INCLUDE_LINE command (clp$include_line
{ request).  The effect of this request is delayed until the requester returns
{ control to the command language interpreter at which time it will return to
{ the issuer of the include command or request rather than continuing to read
{ commands.
{
{       CLP$END_INCLUDE (UTILITY, STATUS)
{
{ UTILITY: (input)  This parameter specifies the utility for which command
{       interpretation is to be terminated.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$unknown_utility
{
{
{   Note:  If this procedure is called with a utility name of osc$null_name
{ from a command utility that was initiated by a clp$include_file request,
{ or osc$null_name is specified as the utility name when the procedure is
{ called directly, the calling job will abort.
{

*DECK DECK=CLH$END_SCAN_COMMAND_FILE EXPAND=FALSE
{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     ****** This program interface is obsolete.  Modules presently    ******
{     ****** using it should be changed to use CLP$END_INCLUDE.        ******
{     ***********************************************************************
{     ***********************************************************************
{
{   The purpose of this request is to terminate the interpretation of commands
{ that was initiated by a clp$scan_command_file request.  The effect  of  this
{ request  is  delayed  until  the  requester  returns  control to the command
{ language interpreter at which time it will  return  to  the  issuer  of  the
{ interpret commands request rather than continuing to read commands.
{
{       CLP$END_SCAN_COMMAND_FILE (UTILITY_NAME, STATUS)
{
{ UTILITY_NAME:  (input)  This  parameter  specifies the utility (process) for
{       which command interpretation is to be terminated.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$unknown_utility
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$END_UTILITY EXPAND=FALSE
{
{   This request removes the environment for a command utility.
{
{       CLP$END_UTILITY (NAME, STATUS)
{
{ NAME: (input)  This parameter specifies the name of the utiility to be
{       terminated.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:  cle$improper_utility_name
{                    cle$unexpected_call_to
{
*DECK DECK=CLH$ERASE_CHILD_TASK EXPAND=FALSE
{
{   This request  is  called  in a parent task when one of its child tasks has
{ terminated.  It frees any Block stack frames created by  or  for  the  child
{ task  that  have not already been freed.  It then erases the parent's record
{ of the child task.
{   Also, if the child task is the "current job synchronous task" (the task to
{ be sent interactive "break" signals), then the parent is made to  take  over
{ that role.
{
{       CLP$ERASE_CHILD_TASK (CHILD_TASK_ID, STATUS)
{
{ CHILD_TASK_ID:  (input)  This  parameter  specifies the task_id of the child
{       task which has terminated.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$EVALUATE_EXPRESSION EXPAND=FALSE
{
{   This request evaluates an SCL expression.
{
{       CLP$EVALUATE_EXPRESSION (EXPRESSION, TYPE_SPECIFICATION, WORK_AREA,
{         RESULT, STATUS)
{
{ EXPRESSION: (input)  This parameter specifies the expression to be
{       evaluated.
{
{ TYPE_SPECIFICATION: (input)  This parameter specifies the data type the
{       expression is expected to result in.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the expression's result value.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The expression's result value is
{       completely contained within the used part of this sequence.
{
{ RESULT: (output)  This parameter specifies the expression's result value.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=CLH$EVALUATE_EXPRESSION_TO_STR EXPAND=FALSE
{
{   This request evaluates an SCL expression using a type specification of ANY
{ and returns the result in its string representation.  Also returned is the
{ name of the generic type of the result.
{
{       CLP$EVALUATE_EXPRESSION_TO_STR (EXPRESSION, RESULT_STRING, TYPE_NAME,
{         STATUS)
{
{ EXPRESSION: (input)  This parameter specifies the expression to be
{       evaluated.
{
{ RESULT_STRING: (output)  This parameter specifies the string representation
{       of the expression's result value.  The string must be long enough to
{       hold the result's representation.
{
{ TYPE_NAME: (output)  This parameter specifies the name of the generic type
{       of the result.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:  cle$string_too_short
{
*DECK DECK=CLH$EVALUATE_FILE_REFERENCE EXPAND=FALSE
{
{   This request is used to evaluate a file reference.  The reference has the
{ form of a file expression as defined for the NOS/VE command interface.
{
{       CLP$EVALUATE_FILE_REFERENCE (FILE, FILE_REFERENCE_PARSING_OPTIONS,
{         RESOLVE_CYCLE_NUMBER, EVALUATED_FILE_REFERENCE, STATUS)
{
{ FILE: (input)  This parameter specifies the file expression to be evaluated.
{
{ FILE_REFERENCE_PARSING_OPTIONS: (input)  This parameter specifies the
{       parsing options which will govern the manner in which the expression
{       is evaluated.  The options are:
{
{       clc$use_$local_as_working_cat:  This option specifies that
{             $LOCAL should be used as the working catalog in the event that
{             the file reference is a relative path.  If this option is
{             omitted, the path is considered to be relative to the current
{             working catalog.
{
{       clc$evaluating_command_ref:  This option specifies that the
{             file reference is part of a command reference. Specifying
{             this option in conjunction with the clc$evaluating_entry_
{             point_ref option will result in an error.
{
{             Not applicable for this request.
{
{       clc$evaluating_entry_point_ref:  This option specifies that the
{             file reference is part of an entry point reference. Specifying
{             this option in conjunction with the clc$evaluating_command_ref
{             option will result in an error.
{
{             Not applicable for this request.
{
{       clc$multiple_reference_allowed:  This option specifies that the
{             "wild card" notation is to be allowed in the file reference.
{
{       clc$command_file_ref_allowed:  This option specifies that a
{             command file reference (i.e.  $COMMAND or $COMMAND_OF_CALLER) is
{             to be allowed.
{
{       clc$file_ref_evaluation_stage:  This option specifies the
{             extent to which the expression is evaluated.  If
{             this option is specified, the values of any variables or
{             functions in the expression are determined and an
{             absolute path is constructed. If omitted, additional
{             interpretation of generic path elements and cycle
{             references occurs, which is the case when the file
{             expression is being used to access a file or catalog.
{
{             Not applicable for this request.
{
{ RESOLVE_CYCLE_NUMBER: (input)  This parameter specifies whether a generic
{       cycle reference ($high, $low, $next) is to be resolved (TRUE) or not
{       (FALSE).
{
{ EVALUATED_FILE_REFERENCE: (output)  This parameter specifies the information
{       resulting from the evaluation of the file reference.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$EVALUATE_PARAMETERS EXPAND=FALSE
{
{   This request is called by a command or function processor to parse and
{ evaluate its parameter list.  If an abnormal status is returned, the command
{ or function processor should return to its caller with that same abnormal
{ status.  The request will verify that the actual parameters conform to the
{ specification in the Parameter Description Table (PDT).
{
{   In addition a clt$check_parameters_procedure may be given to this request.
{ If supplied, the procedure will be called to perform command or function
{ specific validation for each parameter that has the CHECK attribute and for
{ the command or function as a whole.  The procedure may be called more than
{ once to perform the same validation in the context of a parameter dialog.
{
{   A command or function that has no parameters should call this request to
{ verify that no parameters were passed to it.  In such a case an "empty" PDT
{ must be passed for the PARAMETER_DESCRIPTION_TABLE and NIL must be passed for
{ the CHECK_PARAMETERS_PROCEDURE and PARAMETER_VALUE_TABLE parameters.
{
{       CLP$EVALUATE_PARAMETERS (PARAMETER_LIST, PARAMETER_DESCRIPTION_TABLE,
{         CHECK_PARAMETERS_PROCEDURE, PARAMETER_VALUE_TABLE, STATUS)
{
{ PARAMETER_LIST: (input)  This parameter specifies the actual parameters
{       to be evaluated for the command or function as passed to the requesting
{       processor.
{
{ PARAMETER_DESCRIPTION_TABLE: (input)  This parameter specifies the names,
{       types and defaults for the command's or function's parameters.  The
{       variable referenced for this parameter should be produced using the
{       GENERATE_PDT tool.  The #SEQ function is used to pass the variable as
{       the actual value for this parametrer.  NIL may not be specified to
{       indicate that there are no parameters; an "empty" PDT must be used.
{
{ CHECK_PARAMETERS_PROCEDURE: (input)  This parameter specifies the procedure
{       to be called to perform additional parameter validation.  NIL may be
{       specified to indicate the absence of such a procedure.
{
{             CHECK_PARAMETERS_PROCEDURE (PARAMETER_VALUE_TABLE,
{               WHICH_PARAMETER, STATUS)
{
{       PARAMETER_VALUE_TABLE: (input)  This parameter specifies the evaluated
{             parameters for the command or function.  If a parameter was
{             omitted and has no default, then the corresponding value or
{             variable field is NIL.
{
{       WHICH_PARAMETER: (input)  This parameter specifies which command or
{             function parameter to check.  This parameter may specify that a
{             particular command or function parameter should be checked or
{             that general checks should be made (e.g.  of parameter
{             interdependencies).  Each time clp$evaluate_parameters has
{             successfully evaluated a parameter's expression (including a
{             default), it calls this routine specifying that parameter is to
{             be checked.  Once all parameters have been evaluated, this
{             routine is called to perform general checks.
{
{       STATUS: (output)  This parameter specifies the result of the checking.
{
{ PARAMETER_VALUE_TABLE: (output)  This parameter specifies the evaluated
{       parameters for the command or function.  NIL may be specified to
{       indicate that there are no parameters.  If a parameter was omitted and
{       has no default, then the corresponding value or variable field is NIL.
{
{ STATUS: (output)  This parameter specifies the request status.  If this
{       status is not normal, the command or function processor should return
{       immediately to its caller with this status.
{
*DECK DECK=CLH$EVALUATE_SUB_PARAMETERS EXPAND=FALSE
{
{   This request provides for utilizing SCL's facilities to parse and evaluate
{ a parameter list other than one passed to a command or function processor.
{ It is similar to clp$evaluate_parameters except that the parameter list is
{ supplied in its text form, and no clt$check_parameters_procedure may be
{ supplied.  Also the parameter description table (PDT) may not allow any VAR
{ parameters.
{
{       CLP$EVALUATE_SUB_PARAMETERS (PARAMETER_LIST_TEXT,
{         PARAMETER_DESCRIPTION_TABLE, WORK_AREA, PARAMETER_VALUE_TABLE,
{         STATUS)
{
{ PARAMETER_LIST_TEXT: (input)  This parameter specifies the parameter list
{       text to be evaluated.
{
{ PARAMETER_DESCRIPTION_TABLE: (input)  This parameter specifies the names,
{       types and defaults for the command's or function's parameters.  The
{       variable referenced for this parameter should be produced using the
{       GENERATE_PDT tool.  The #SEQ function is used to pass the variable as
{       the actual value for this parametrer.  NIL may not be specified to
{       indicate that there are no parameters; an "empty" PDT must be used.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the evaluated parameters.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The evaluated parameters are completely
{       contained within the used part of this sequence.
{
{ PARAMETER_VALUE_TABLE: (output)  This parameter specifies the evaluated
{       parameters.  NIL may be specified to indicate that there are no
{       parameters.  If a parameter was omitted and has no default, then the
{       corresponding value field is NIL.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$EVALUATE_TOKEN EXPAND=FALSE
{
{   The purpose of this request is to scan the next lexical token in a line.
{ On entry, INDEX indicates where to begin scanning TEXT.  On exit, INDEX
{ indicates where scanning stopped (i.e.  the next character, if any, to be
{ scanned).
{
{   The TEXT_INDEX field of TOKEN is set to the position of the first
{ character of the returned token.  The TEXT_SIZE field of TOKEN is set to the
{ number of characters occupied by the token in the text (i.e.  exit value of
{ INDEX - TOKEN.TEXT_INDEX).  The DESCRIPTOR field of TOKEN is set to a string
{ that describes the token, e.g.  for use in error messages.
{
{   Name tokens are 1 to 31 characters in length and are returned in TOKEN.STR
{ with all lower case letters translated to their upper case counterparts.
{ The following BNF definitions illustrate the syntax of a name:
{
{    <clc$name_token> ::= <alphabetic char> [<alphanumeric char>]...
{    <alphanumeric char> ::= <alphabetic char> | <digit>
{    <alphabetic char> ::= <letter>
{                        | <special alphabetic char>
{                        | <international letter>
{    <letter> ::= <upper case letter> | <lower case letter>
{    <upper case letter> ::= A | B | C | D | E | F | G | H | I | J | K | L | M
{                          | N | O | P | Q | R | S | T | U | V | W | X | Y | Z
{    <lower case letter> ::= a | b | c | d | e | f | g | h | i | j | k | l | m
{                          | n | o | p | q | r | s | t | u | v | w | x | y | z
{    <international letter> ::= <upper case international letter>
{                             | <lower case international letter>
{    <upper case international letter> ::= @ | '[' |  \  | ^ | ']'
{    <lower case international letter> ::= ` |  {  | '|' | ~ |  }
{    <special alphabetic char> ::= # | $ | _
{    <digit> ::= 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
{
{   A CYBIL name token differs from an SCL name token in that it must start
{ with a letter and may not contain any of the international alphabetic
{ characters except @.  The distinction between a CYBIL name and an SCL name
{ is made only if the scan option CLC$CLASSIFY_NAME_TOKEN is selected.  The
{ following BNF definitions illustrate the syntax of a CYBIL name:
{
{    <clc$cybil_name_token> ::= <letter> [<cybil name char>]...
{    <cybil name char> ::= <letter>
{                        | <special alphabetic char>
{                        | @
{                        | <digit>
{
{   A special CYBIL name token differs from a regular CYBIL name token in that
{ it starts with either a $ or a # and is 2 to 32 characters in length.  The
{ intent of this kind of token is to accomodate set value constructor
{ notation.  A special CYBIL name is recognized as such only if the scan
{ options CLC$CLASSIFY_NAME_TOKEN and CLC$SPECIAL_CYBIL_NAME_IS_TOKEN are
{ selected.  The following BNF definitions illustrate the syntax of a special
{ CYBIL name:
{
{    <clc$special_cybil_name_token> ::= $ <clc$cybil_name_token>
{                                     | # <clc$cybil_name_token>
{
{   A simple name token contains only letters or digits and must start with a
{ letter.  Thus a simple name may be considered to be any of the other kinds
{ of names (except a special CYBIL name).  The distinction between a simple
{ name and an SCL name is made only if the scan option CLC$CLASSIFY_NAME_TOKEN
{ is selected.  The following BNF definitions illustrate the syntax of a
{ simple name.
{
{    <clc$simple_name_token> ::= <letter> [<letter | digit>]...
{    <letter | digit> ::= <letter> | <digit>
{
{   COBOL name tokens are 1 to 30 characters in length and may contain
{ hyphens.  A COBOL name is recognized only if the scan options
{ CLC$CLASSIFY_NAME_TOKEN and CLC$COBOL_NAME_IS_TOKEN are selected.  The
{ following BNF definitions illustrate the syntax of a COBOL name:
{
{    <clc$cobol_name_token> ::=
{          <letter> [[<COBOL name char>]... <letter | digit>]
{        | <digit> [<COBOL name char>]... <letter>
{                 [[<COBOL name char>]... <letter | digit>]
{    <COBOL name char> ::= <letter> | <digit> | <hyphen>
{    <letter | digit> ::= <letter> | <digit>
{    <hyphen> ::= -
{
{   Integer tokens may have radix specifications and must be delimited at both
{ ends.  The default radix is decimal (10).  The following BNF definitions
{ illustrate the syntax of integers:
{
{    <clc$signed_integer_token> ::= <sign> <clc$unsigned_integer_token>
{    <sign> ::= + | -
{    <clc$unsigned_integer_token> ::=  <digit> [<hex digit>]... [(<radix>)]
{    <hex digit> ::= <digit> | A | B | C | D | E | F
{                            | a | b | c | d | e | f
{    <radix> ::= <unsigned decimal>
{    <unsigned decimal> ::= <digit>...
{
{   Real tokens, must have fractional portions and may have an exponent.  The
{ following BNF definitions illustrate the syntax of real numbers:
{
{    <clc$signed_real_token> ::= <sign> <clc$unsigned_real_token>
{    <clc$unsigned_real_token> ::= <mantissa> [<exponent>]
{    <mantissa> ::= <integer part> . <fraction part>
{    <integer part> ::= <unsigned decimal>
{    <fraction part> ::= <unsigned decimal>
{    <exponent> ::= <E|e> [<sign>] <unsigned decimal>
{    <E|e> ::= E | e
{
{   Strings must be enclosed in apostrophes (single quote marks).  In the STR
{ field of TOKEN, the enclosing apostrophes are removed and doubled
{ apostrophes within the original TEXT are replaced by a single apostrophe.
{ The token can hold a string up to 256 characters long.  If the STR_COMPLETE
{ field of TOKEN is FALSE, the string is too large to fit in TOKEN and must be
{ accessed via the TEXT_INDEX and TEXT_SIZE fields.  The following BNF
{ definitions illustrate the syntax of strings:
{
{    <clc$string_token> ::= ' [<string char>]... '
{    <string char> ::= <any ascii character except '> | ''
{
{   Comments are treated as spaces unless the scan option CLC$COMMENT_IS_TOKEN
{ is selected.  The following BNF definitions illustrate the syntax of
{ comments:
{
{    <clc$comment_token> ::= " [<comment char>]... ["]
{    <comment char> ::= <any ascii character except ">
{
{   The following BNF definitions illustrate the representation of the
{ delimiter and operator tokens:
{
{    <clc$semicolon_token> ::= ;
{    <clc$colon_token> ::= :
{    <clc$cybil_assign_token> ::= :=
{    <clc$left_parenthesis_token> ::= (
{    <clc$right_parenthesis_token> ::= )
{    <clc$comma_token> ::= ,
{    <clc$ellipsis_token> ::= .. [.]...
{    <clc$dot_token> ::= .
{    <clc$query_token> ::= ?
{    <clc$greater_than_token> ::= >
{    <clc$greater_equal_token> ::= >=
{    <clc$less_than_token> ::= <
{    <clc$less_equal_token> ::= <=
{    <clc$equal_token> ::= =
{    <clc$not_equal_token> ::= <>
{    <clc$assign_token> ::= =
{    <clc$concatenate_token> ::= //
{    <clc$exponentiate_token> ::= **
{    <clc$multiply_token> ::= *
{    <clc$divide_token> ::= /
{    <clc$add_token> ::= +
{    <clc$subtract_token> ::= -
{
{   The following are considered tokens only if the scan options
{ CLC$CLASSIFY_NAME_TOKEN and CLC$INTERNATIONAL_CHAR_IS_TOKEN are selected.
{
{    <clc$commercial_at_token> ::= @
{    <clc$left_bracket_token> ::= '['
{    <clc$reverse_slant_token> ::= \
{    <clc$right_bracket_token> ::= ']'
{    <clc$circumflex_token> ::= ^
{    <clc$grave_accent_token> ::= `
{    <clc$left_brace_token> ::= {
{    <clc$vertical_bar_token> ::= '|'
{    <clc$right_brace_token> ::= }
{    <clc$tilde_token> ::= ~
{
{   The following are considered tokens only if the scan options
{ CLC$CLASSIFY_NAME_TOKEN and CLC$SPECIAL_CHAR_IS_TOKEN are selected.
{
{    <clc$number_sign_token> ::= #
{    <clc$dollar_sign_token> ::= $
{    <clc$underscore_token> ::= _
{
{   Contiguous spaces are treated collectively as a clc$space_token.  The
{ horizontal tab (HT) character is treated identically to the space character.
{ Also, comments are normally treated as spaces.
{
{   Any character that does not begin a token previously described, is
{ returned as a clc$unknown_token.
{
{
{       CLP$EVALUATE_TOKEN (TEXT, SCAN_OPTIONS, INDEX, SPACES_PRECEDED_TOKEN,
{         TOKEN, STATUS)
{
{ TEXT: (input)  This parameter specifies the text to be scanned.
{
{ SCAN_OPTIONS: (input)  This parameter specifies options for the token
{       scanning process.  These options are:
{
{       clc$ignore_spaces_before_token:  if selected and a clc$space_token
{             would be returned, the space token is bypassed and the next
{             token is returned.  For a clc$signed_integer_token or a
{             clc$signed_real_tokens, this applies to spaces appearing between
{             the sign and the number as well.
{
{       clc$comment_is_token:  if selected this option defeats the normal
{             process of comments being considered as equivalent to spaces.
{
{       clc$classify_name_token:  if selected this option causes names to be
{             classified according to the BNF definitions above.
{
{       clc$cobol_name_is_token:  if selected this option allows a
{             clc$cobol_name_token to be returned.  This option is ignored
{             unless clc$classify_name_token is also selected.
{
{       clc$special_cybil_name_is_token:  if selected this option allows a
{             clc$special_cybil_name_token to be returned.  This option is
{             ignored unless clc$classify_name_token is also selected.
{
{       clc$international_char_is_token:  if selected allows the international
{             characters, normally considered to be part of a name, to be
{             returned as tokens (see above).  This option is ignored unless
{             clc$classify_name_token is also selected.
{
{       clc$special_char_is_token:  if selected allows the special characters,
{             normally considered to be part of a name, to be returned as
{             tokens (see above).  This option is ignored unless
{             clc$classify_name_token is also selected.
{
{ INDEX: (input, output)  This parameter specifies the next character within
{       TEXT to be scanned.
{
{ SPACES_PRECEDED_TOKEN: (output)  This parameter specifies whether spaces
{       were found before the returned token and is only meaningful if the
{       clc$ignore_spaces_before_token option is selected.
{
{ TOKEN: (output)  This parameter specifes the returned token.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=CLH$EXECUTE_COMMAND EXPAND=FALSE
{
{   The purpose of this request is to execute a command asynchronously in a
{ new task.  Any command other than a utility subcommand may be executed via
{ this request.
{
{   If the command being executed is not already packaged as a program, i.e.
{ it is an SCL procedure or built_in system command, an internal SCL program
{ is executed which in turn calls the command.  Otherwise, the command's own
{ program description is used.
{
{       CLP$EXECUTE_COMMAND (COMMAND, COMMAND_FILE, ENABLE_ECHOING, TASK_NAME,
{         TASK_ID, STATUS)
{
{ COMMAND: (input)  This parameter specifies the command to be executed.  The
{       text of this string must conform to the syntax of a single command.
{
{ COMMAND_FILE: (input)  This parameter specifies a file which becomes the
{       current command file (i.e.  $COMMAND) within the new task.  This
{       parameter is only meaningful if the command being executed is a
{       command utility, or for some other reason references the current
{       command file.  A null or blank string can be used to specify the
{       absence of a command file.
{
{ ENABLE_ECHOING: (input)  This  parameter determines whether the command may
{       be echoed (TRUE) or not (FALSE).
{
{ TASK_NAME: (input)  This parameter specifies the name to be used to refer to
{       the task subsequent to this request (e.g.  in a clp$get_task_status
{       request).
{
{ TASK_ID: (output)  This parameter specifies the identifier assigned to the
{       task and can be used in subsequent program management requests to
{       refer to the task.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$EXECUTE_JOB_EPILOG EXPAND=FALSE
{ PURPOSE:
{    The purpose of this request is to execute a job epilog.
{ DESIGN:
{    The procedure is called only by pmp$execute_epilog during Job Monitor task
{    termination.  The epilog to be executed is specified by the contents of
{    the global variable CLV$PROCESSING_PHASE.
*DECK DECK=CLH$EXPRESSION_SCANNER EXPAND=FALSE
{
{   The purpose  of this request is to scan and evaluate an expression that is
{ part of some larger syntactic construct.
{
{       CLP$EXPRESSION_SCANNER (TEXT, INDEX, VALUE_KIND_SPECIFIER, VALUE,
{         TOKEN, TOKEN_STATUS, STATUS)
{
{ TEXT: (input) This parameter specifies the text to be scanned.
{
{ INDEX: (input, output) This parameter specifies the  next  character  within
{       TEXT to be scanned.
{
{ VALUE_KIND_SPECIFIER: (input) This parameter specifies the value kind of the
{       result of the expression.
{
{ VALUE: (output) This parameter specifies the result of the expression.
{
{ TOKEN: (input, output) On input, this parameter specifies the first token of
{       the  expression.   On  output,  it  specifies  the  token  immediately
{       following the expression.
{
{ TOKEN_STATUS: (input) This parameter specifies whether the  first  token  of
{       the   expression   was   successfully   scanned.    This   permits  an
{       APPLICATION_KIND value to be composed of non-SCL tokens.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$EXTRACT_MESSAGE_MODULE EXPAND=FALSE
{
{   The purpose of this request is to write a message module to a legible file
{ in the form of the commands that could be used to recreate the module.
{
{       CLP$EXTRACT_MESSAGE_MODULE (FILE_ID, MODULE_NAME, MESSAGE_MODULE,
{         STATUS)
{
{ FILE_ID: (input) This parameter specifies the identifier of the legible file
{       to which the source form of the message module is to be written.
{
{ MODULE_NAME: (input) This parameter specifies the name of the  module  being
{       extracted.
{
{ MESSAGE_MODULE:  (input)  This parameter specifies the data representing the
{       message module.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$EXTRACT_SCL_PROCEDURE EXPAND=FALSE
{
{   The purpose of this request is to write an SCL procedure  from  an  object
{ library to a legible file in its original source form.
{
{       CLP$EXTRACT_SCL_PROCEDURE (FILE_ID, SCL_PROCEDURE, STATUS)
{
{ FILE_ID: (input) This parameter specifies the identifier of the legible file
{       to which the source form of the SCL procedure is to be written.
{
{ SCL_PROCEDURE: (input) This parameter specifies the  data  representing  the
{       SCL procedure.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$FETCH_UTILITY_DIALOG_INFO EXPAND=FALSE
{
{   This request returns the established information for a utility dialog.
{ Since this information is passed to a utility dialog manager, the only use
{ for this request is to support an activate_screen command established by a
{ utility dialog manager.
{
{       CLP$FETCH_UTILITY_DIALOG_INFO (UTILITY, DIALOG_INFO, STATUS)
{
{ UTILITY: (input)  This parameter specifies the name of the utility for which
{       the utility dialog manager is called.  Osc$null_name can be used to
{       refer to the current utility.
{
{ DIALOG_INFO: (output)  This parameter specifies the information established
{       for the utility dialog.  It includes a pointer to a table of commands,
{       a pointer to a table of functions, and a pointer to a SEQuence
{       designating a scratch segment.  If a pointer is NIL, the corresponding
{       item has not been established for the dialog manager.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: cle$unexpected_call_to
{
*DECK DECK=CLH$FILE_REF_IS_PRE_EVALUATED EXPAND=FALSE
{
{   This function returns a boolean specifying whether a file reference has
{ been "pre-evaluated".  A check must be made previous to this request to
{ ensure that the file reference begins with a colon.  This routine checks that
{ the first path element does not begin with a '$' and that the file reference
{ is not being evaluated as a command reference or entry point reference.  If
{ TRUE is returned, a call to CLP$PARSE_FILE_REFERENCE can be made as opposed
{ to a call to CLP$COMPLETE_FILE_REF_PARSE, which is more expensive.
{
{       CLP$FILE_REF_IS_PRE_EVALUATED (FILE_REFERENCE_PARSING_OPTIONS, PARSE):
{         BOOLEAN
{
{ FILE_REFERENCE_PARSING_OPTIONS: (input)  This parameter indicates how the
{       file reference is to be evaluated.  If clc$evaluating_command_ref or
{       clc$evaluating_entry_point_ref is specified, FALSE is returned.  The
{       options are:
{
{       clc$use_$local_as_working_cat:  This option specifies that $LOCAL
{             should be used as the working catalog in the event that the file
{             reference is a relative path.  If this option is omitted, the
{             path is considered to be relative to the current working catalog.
{
{       clc$evaluating_command_ref:  This option specifies that the file
{             reference is part of a command reference.  Specifying this option
{             in conjunction with the clc$evaluating_entry_ point_ref option
{             will result in an error.
{
{       clc$evaluating_entry_point_ref:  This option specifies that the file
{             reference is part of an entry point reference.  Specifying this
{             option in conjunction with the clc$evaluating_command_ref option
{             will result in an error.
{
{       clc$multiple_reference_allowed:  This option specifies that the "wild
{             card" notation is to be allowed in the file reference.
{
{       clc$command_file_ref_allowed:  This option specifies that a command
{             file reference (i.e.  $COMMAND or $COMMAND_OF_CALLER) is to be
{             allowed.
{
{       clc$file_ref_evaluation_stage:  This option specifies the extent to
{             which the expression is evaluated.  If this option is specified,
{             the values of any variables or functions in the expression are
{             determined and an absolute path is constructed.  If omitted,
{             additional interpretation of generic path elements and cycle
{             references occurs, which is the case when the file expression is
{             being used to access a file or catalog.
{
{ PARSE: (input)  This parameter specifies the file expression.
{
*DECK DECK=CLH$FIND_CURRENT_JOB_SYNCH_TASK EXPAND=FALSE
{
{   The purpose  of  this request is to determine which task within the job is
{ the most recently initiated, active task that is running synchronously  with
{ the "job monitor" task.
{   This request is intended to be used primarily by the interactive  facility
{ to determine which task should be given an interactive "break" signal.
{
{       CLP$FIND_CURRENT_JOB_SYNCH_TASK (TASK_ID, STATUS)
{
{ TASK_ID: (output) This parameter specifies the (local) identifier of the job
{       synchronous task.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$FIND_FORM EXPAND=FALSE
{
{   This request returns a pointer to a form in an object code library.
{
{       CLP$FIND_FORM (FORM_NAME, P_FORM_MODULE, STATUS)
{
{ FORM_NAME: (input) This parameter specifies the name of the form.
{
{ P_FORM_MODULE: (output) This parameter specifies the pointer to the form
{       module returned by this request.  The pointer is returned as a
{       SEQuence pointer that has been RESET.  If NIL is returned, the
{       form name could not be found.
{
{ STATUS: (output) This parameter specifies the request status.
{

*DECK DECK=CLH$FIND_HELP_MODULE EXPAND=FALSE

{
{   This interface is a clone of OSP$FIND_HELP_MODULE. The only difference
{ between the two routines is that this routine accepts the natural language
{ as an input parameter, and uses it to locate the requested module.
{
{   The purpose of this request is to search for a help module.  Help  modules
{ reside  on object libraries and contain prompts and help information for SCL
{ commands and functions, and descriptions of menus for applications.  A  help
{ module may also contain status message descriptions.
{
{   A help module is located by searching each object library in  the  command
{ list for the name of the help module.  The name of the help module is formed
{ by using the seed name passed to this request and suffixing it with a dollar
{ sign  ($)  character  followed by the name of the preferred natural language
{ selected for the job.
{
{       CLP$FIND_HELP_MODULE (SEED_NAME, HELP_MODULE, ONLINE_MANUAL_NAME,
{         NATURAL_LANGUAGE, STATUS)
{
{ SEED_NAME: (input) This parameter specifies the name that is to be  suffixed
{       with  a $ and the name of the natural language to form the name of the
{       module to be searched for.
{
{ NATURAL_LANGUAGE: (input) This parameter specifies the name of the  natural
{       language to be used to locate the desired help module.
{
{ HELP_MODULE: (output) This parameter  specifies  the  pointer  to  the  help
{       module.   This  pointer  is  used  as  input  to  requests that locate
{       specific messages within  the  help  module.   If  this  parameter  is
{       returned as NIL, the specified help module could not be found.
{
{ ONLINE_MANUAL_NAME: (output) This parameter specifies the name of the online
{       manual associated with the help module.  If the specified help  module
{       could not be found or if there is no online manual associated with the
{       help module, osc$null_name is returned.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=CLH$FIND_SCL_PROC_IN_LIBRARY EXPAND=FALSE
{
{   This request returns a pointer to the body of an SCL procedure module in
{ object library.
{
{       CLP$FIND_SCL_PROC_IN_LIBRARY (OBJECT_LIBRARY, OBJECT_LIBRARY_NAME,
{         PROCEDURE_NAME, SCL_PROCEDURE, STATUS)
{
{ OBJECT_LIBRARY: (input) This parameter specifies the object library as a
{       SEQuence.
{
{ OBJECT_LIBRARY_NAME: (input) This parameter specifies the name of the
{       object library.
{
{ PROCEDURE_NAME: (input) This parameter specifies the name of the procedure
{       to be found.  It may specify any of the names by which the procedure
{       is known.
{
{ SCL_PROCEDURE: (output) This parameter specifies the pointer to the body
{       of the SCL procedure module returned by this request.  The pointer
{       is returned as a SEQuence pointer that has been RESET.  If NIL is
{       returned, the procedure could not be found in the library.
{
{ STATUS: (output) this parameter specifies the request status.
{
*DECK DECK=CLH$FORMAT_VALUE EXPAND=FALSE
{
{   The purpose of this request is to build a data_representation from a
{ format string and one or more clt$data_values.
{
{   This representation is returned in a sequence.  The first data item in the
{ sequence is a clt$data_representation_count, i.e.  the number of strings
{ used in the representation.  The remaining data is a series of
{ clt$string_size, clt$string_value pairs with the length of each
{ clt$string_value determined by the corresponding clt$string_size.
{
{       CLP$FORMAT_VALUES (FORMAT_STRING, VALUE, MAX_STRING,
{         WORK_AREA, DATA_REPRESENTATION, STATUS)
{
{ FORMAT_STRING: (input) This parameter specifies the format of the text lines.
{       This string consists of display characters and formatting directives.
{       The display characters are copied to the text lines directly.  The
{       format directives all start with a "+" character and have the following
{       effects.  (nn'th data_value here refers to the nn'th data_value of
{       the data_value list element currently in effect.)
{
{       If format string is NIL then the format '+S' is used.
{
{       +Enn Define a soft end of line.  This position will be used to break
{             the line if the line extends past the string width.  nn defines
{             the indentation for the new line.
{
{       +Fc: Define a fill character 'c'.  This must be immediately followed
{             by another directive with no interveening '+' character.  The
{             fill character is used with the +W, +H, and +X directives.
{
{       +Hnn: Horizontally tab to column.  If nn is specified, it tabs to
{             column nn starting a new line if the current column is too large.
{             If nn is ommitted, it tabs to the next tab of 9, 17, 25, etc.
{             The fill character is used to pad the line to the column.
{
{       +K: Keep the text between pairs of +K directives together on one line.
{
{       +Lxnn: Puts the specified data value label to the string.
{             If nn is specified and not 0, the nn'th data value label is used.
{             If nn is not specified, the next data value label is used.  If nn
{             is 0, the label of the previously referenced value is used.  The
{             'x' specifies how to show record labels.  'U' specifies that they
{             be in upper case characters.  'L' specifies that they be in lower
{             case characters.  'I' specifies that only the initial letters
{             of words be capitalized.  If the 'x' is not specified, 'L' is
{             used.
{
{       +Nnn: Specifies a hard end of line.  This causes the current line to
{             be ended and a new line started with nn leading spaces.
{
{       +Pxnn: Convert the specified data value using element representation.
{             If nn is specified and not 0, the nn'th data value is used.
{             If nn is not specified, the next data value is used.  If nn
{             is 0, the previously referenced value is used.  The 'x'
{             specifies how to convert names.  'U' specifies that names be in
{             upper case characters.  'L' specifies that names be in lower
{             case characters.  'I' specifies that only the initial letters
{             of words be capitalized.  If the 'x' is not specified, 'L' is
{             used.
{
{       +R: Causes a portion of the format to be repeated.  The portion
{             repeated is between '+R' pairs at the same nesting level (see
{             '+('.  The repeated format is processed until all values at
{             this nesting level are used.  If all values have been used when
{             the '+R' is encountered, the repeated portion is not processed
{             at all.
{
{       +Sxnn: Convert the specified data value using source representation.
{             If nn is specified and not 0, the nn'th data value is used.
{             If nn is not specified, the next data value is used.  If nn
{             is 0, the previously referenced value is used.  The 'x'
{             specifies how to convert names.  'U' specifies that names be in
{             upper case characters.  'L' specifies that names be in lower
{             case characters.  'I' specifies that only the initial letters
{             of words be capitalized.  If the 'x' is not specified, 'L' is
{             used.
{
{       +Wjnn: Define a fixed field width for the display of the value that
{             follows as 'nn'.  If the value is larger than this width, it will
{             be truncated (on the left for right justification; on the right
{             for left justification and center justification).  If the value
{             is smaller than this width, it will be justified as specified
{             and padded by the fill character as defined by the 'F' directive.
{             'j' optionally specifies the justification.  'R' selects right
{             justification, 'L' selects left justification (the default) and
{             'C' selects center justification.  If nn is not specified a
{             value of 31 is used.  NOTE:  This must be immediately followed
{             by another directive with no interveening '+' character.
{
{       +Xnn: Expand count as fill character.  The fill character is put to
{             the string nn times.
{
{       +(nn: Move to the next nesting level.  This causes the '+P' and '+S'
{             directives to refer to subvalues of the next (or nnth) value.
{
{       +): Return to the previous nesting level.
{
{       ++: Places a '+' into the string.
{
{       +-: Places the null string '' into the string.  This allows one to
{             follow a directive by a number without the interpretation of
{             the number as part of the directive.  eg. +p+-5 means put the
{             next parameter to the string then put '5' to the string.
{
{ MAX_STRING: (input)  This parameter specifies the maximum length of strings
{       in the representation of the value.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the value's representation.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The value's respresentation occupies the
{       used part of this sequence.
{
{ DATA_REPRESENTATION: (output)  This parameter specifies the data value's
{       representation as described above.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$work_area_overflow
{                   cle$bad_data_rep_option
{                   cle$bad_data_value
{
*DECK DECK=CLH$FUNCTION_PROCESSOR EXPAND=FALSE
{
{   Unlike command processors, function processors are always invoked by direct
{ CYBIL procedure call.  The parameters passed to a function are the same as
{ those passed to a command processor with the addition of "work area" (which
{ is to used to construct the function's result value) and a parameter set by
{ the function processor to point to its result value.
{
{       function_processor (PARAMETER_LIST, WORK_AREA, RESULT, STATUS)
{
{ PARAMETER_LIST: (input)  This parameter specifies the actual parameter list
{       for the function.  Function parameters are passed in a sequence for
{       compatibility with the passing of parameters to a command processor.
{       Normally the function processor passes this parameter on to
{       clp$evaluate_parameters to be interpreted.  If, for some reason, the
{       function processor needs to examine the the unevaluated parameters, it
{       can pass this parameter to clp$get_parameter_list_text.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       must be used to construct the function's result value.  The current
{       position of this sequence pointer must be updated to reflect the amount
{       of storage used by the function.  The function's result value must be
{       completely contained within the used part of this sequence.
{
{ RESULT: (output)  This parameter specifies the function's result value.
{
{ STATUS: (output)  This parameter specifies the completion status of the
{       function.
{
*DECK DECK=CLH$GENERATE_PDT EXPAND=FALSE
{
{   The purpose of this request is to produce a Parameter Description Table
{ (PDT) from input in the form of an SCL procedure declaration.  In addition
{ to the FIRST_LINE to be processed, input to this request may be provided
{ dynamically by supplying an input procedure that obtains subsequent input as
{ required by this interface.
{
{   This interface assumes that the first word of the input declaration has
{ been processed by the caller; i.e.  whether the declaration begins with
{ PROCEDURE or FUNCTION has been determined and used to establish the value of
{ the COMMAND_OR_FUNCTION parameter.
{
{       CLP$GENERATE_PDT (COMMAND_OR_FUNCTION, FIRST_LINE, FIRST_LINE_INDEX,
{         GET_LINE, WORK_AREA, LAST_LINE, LAST_LINE_INDEX,
{         COMMAND_OR_FUNCTION_NAME, ALIASES, AVAILABILITY,
{         COMMAND_OR_FUNCTION_SCOPE, COMMAND_LOG_OPTION,
{         PARAMETER_DESCRIPTION_TABLE, STATUS)
{
{ COMMAND_OR_FUNCTION: (input)  This parameter specifies whether the PDT being
{       generated is for a command or a function.
{
{ FIRST_LINE: (input)  This parameter specifies the first (possibly only) line
{       to be processed by this request.
{
{ FIRST_LINE_INDEX: (input)  This parameter specifies the position within the
{       first line at which processing is to begin.
{
{ GET_LINE: (input)  This parameter specifies the procedure that this request
{       calls to get its input dynamically.  The procedure is responsible for
{       concatenating continuation lines to form a "command line".  NIL may be
{       specified to indicate the absence of an input procedure.
{
{             input_procedure (LINE, STATUS)
{
{       LINE: (output)  This parameter specifies the line.  A NIL pointer is
{             used to indicate end of input.
{
{       STATUS: (output)  This parameter specifies the input procedure's
{             completion status.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the PDT and aliases.  The current position
{       of this sequence pointer is updated to reflect the amount of storage
{       used by the request.  The PDT and aliases are completely contained
{       within the used part of this sequence.
{
{ LAST_LINE: (output)  This parameter specifies the last line processed by
{       this interface.  If an input procedure is supplied and is used by the
{       request, this is set to the last line that procedure returned;
{       otherwise this is set to FIRST_LINE.
{
{ LAST_LINE_INDEX: (output)  This parameter specifies the position within
{       LAST_LINE that immediately follows the last character that was
{       processed.
{
{ COMMAND_OR_FUNCTION_NAME: (output)  This parameter specifies the name of the
{       command or function for which the PDT is being generated.
{
{ ALIASES: (output)  This parameter specifies the aliases for the command or
{       function name.  NIL indicates there are no aliases.
{
{ AVAILABILITY: (output)  This parameter specifies whether the command or
{       function is to be advertised or hidden (for instance, by the
{       display_command_list_entry command).
{
{ COMMAND_OR_FUNCTION_SCOPE: (output)  This parameter specifies the scope of
{       the command or function.
{
{ COMMAND_LOG_OPTION: (output)  This parameter specifies whether calls to the
{       command are to be logged automatically or manually.
{
{ PARAMETER_DESCRIPTION_TABLE: (output)  This parameter specifies the
{       generated PDT.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$work_area_overflow
{
*DECK DECK=CLH$GENERATE_TYPE_SPECIFICATION EXPAND=FALSE
{
{   The purpose of this request is to produce a clt$type_specification from
{ input in the form of an SCL type expression.  In addition to the FIRST_LINE
{ to be processed, input to this request may be provided dynamically by
{ supplying an input procedure that obtains subsequent input as required by
{ this interface.
{
{       CLP$GENERATE_TYPE_SPECIFICATION (TYPE_NAME, FIRST_LINE,
{         FIRST_LINE_INDEX, GET_LINE, WORK_AREA, LAST_LINE, LAST_LINE_INDEX,
{         TYPE_SPECIFICATION, STATUS)
{
{ TYPE_NAME: (input)  This parameter specifies the name of the type for which
{       the specifiction is being generated.
{
{ FIRST_LINE: (input)  This parameter specifies the first (possibly only) line
{       to be processed by this request.
{
{ FIRST_LINE_INDEX: (input)  This parameter specifies the position within the
{       first line at which processing is to begin.
{
{ GET_LINE: (input)  This parameter specifies the procedure that this request
{       calls to get its input dynamically.  The procedure is responsible for
{       concatenating continuation lines to form a "command line".  NIL may be
{       specified to indicate the absence of an input procedure.
{
{             input_procedure (LINE, STATUS)
{
{       LINE: (output)  This parameter specifies the line.  A NIL pointer is
{             used to indicate end of input.
{
{       STATUS: (output)  This parameter specifies the input procedure's
{             completion status.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the type specification.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The type specification is completely
{       contained within the used part of this sequence.
{
{ LAST_LINE: (output)  This parameter specifies the last line processed by
{       this interface.  If an input procedure is supplied and is used by the
{       request, this is set to the last line that procedure returned;
{       otherwise this is set to FIRST_LINE.
{
{ LAST_LINE_INDEX: (output)  This parameter specifies the position within
{       LAST_LINE that immediately follows the last character that was
{       processed.
{
{ TYPE_SPECIFICATION: (output)  This parameter specifies the generated type
{       specification.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
*DECK DECK=CLH$GET_COMMAND_IMAGE EXPAND=FALSE
{
{   This request returns a pointer to the image (text) of the call to a
{ command.
{
{       CLP$GET_COMMAND_IMAGE (COMMAND_IMAGE, STATUS)
{
{ COMMAND_IMAGE: (output)  This parameter specifies the pointer to the image of
{       the call to the command being processed.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$GET_COMMAND_NAME EXPAND=FALSE
{
{   The purpose of this request is to get the name by which the current command
{ processor was called.
{
{       CLP$GET_COMMAND_NAME (NAME, STATUS)
{
{ NAME: (output)  This parameter receives the name by which the requesting
{       command was called.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$GET_COMMAND_ORIGIN EXPAND=FALSE
{
{   The purpose  of this request is to determine whether the command currently
{ being processed was entered directly from an interactive device.
{
{       CLP$GET_COMMAND_ORIGIN (INTERACTIVE, STATUS)
{
{ INTERACTIVE: (output) This parameter specifies whether the  current  command
{       came from an interactive device (true) or not (false).
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$GET_DATA_LINE EXPAND=FALSE
{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     ****** This program interface is obsolete.  Modules presently    ******
{     ****** using it should be changed to use CLP$GET_LINE_FROM_      ******
{     ****** COMMAND_FILE.                                             ******
{     ***********************************************************************
{     ***********************************************************************
{
{   The purpose of this request is to read the next "physical" line  from  the
{ current command file.  Line continuation is not processed by this request.
{
{   This  request  is  intended for use by command utilities; therefore if the
{ requesting task does not have an active call to  clp$scan_command_file/line,
{ the request will terminate with an error status.
{
{       CLP$GET_DATA_LINE (PROMPT_STRING, LINE, GOT_LINE, STATUS)
{
{ PROMPT_STRING: (input) This parameter specifies the string to be issued as a
{       prompt for the line if the current command file is associated with  an
{       interactive terminal.
{
{ LINE: (output) This parameter specifies the line.
{
{ GOT_LINE: (output) This parameter specifies whether the line was read (TRUE)
{       or end-of-information on the current  command  file  was  encounterred
{       (FALSE).
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$unexpected_call_to
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$GET_DATE_STRING EXPAND=FALSE
{
{   This request produces the string representation of the current date in a
{ site defined format.
{
{       CLP$GET_DATE_STRING (STR, STATUS)
{
{ STR: (output)  This parameter specifies the result string.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: none
{
*DECK DECK=CLH$GET_DATE_TIME_STRING EXPAND=FALSE
{
{   This request produces the string representation of the current date and/or
{ time and/or day of the week.
{
{       CLP$GET_DATE_TIME_STRING (FORMAT, STR, STATUS)
{
{ FORMAT: (input)  This parameter specifies the "date time form string" to be
{       used to guide the construction of the representation.  If this string
{       is null or all spaces a site defined default is used.
{
{ STR: (output)  This parameter specifies the result string.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=CLH$GET_DAY_NAME EXPAND=FALSE
{
{   The purpose of this request is to get the name of the specified day of the
{ week.  These names are kept on "month and day name" message modules (on an
{ object library in the command list).
{
{       CLP$GET_DAY_NAME (DAY_OF_WEEK, FULL_FORM, NATURAL_LANGUAGE, DAY_NAME,
{         STATUS
{
{ DAY_OF_WEEK: (input)  This parameter specifies the day of the week whose
{       name is desired.
{
{ FULL_FORM: (input)  This parameter specifies whether the "full" form of the
{       name is to be returned (TRUE) or the name's abbreviation (FALSE).
{
{ NATURAL_LANGUAGE: (input)  This parameter specifies the natural language in
{       which the name is to be returned.  Osc$null_name can be used to
{       specify the job's currently selected natural language.  If no
{       definition for the day can be found in the requested natural language,
{       US_English is used.
{
{ DAY_NAME: (output)  This parameter specifies the returned day name.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: ose$bad_day_of_week
{                   ose$bad_natural_language
{
*DECK DECK=CLH$GET_EXPECTED_TYPE EXPAND=FALSE
{
{   The purpose of this request is to determine the type of result that a
{ function is expected to return.  This request is intended for functions like
{ $READ which base the form of their results on the expected type.
{
{       CLP$GET_EXPECTED_TYPE (WORK_AREA, EXPECTED_TYPE, STATUS)
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       is used to construct the expected type's specification.  The position
{       of this sequence pointer is be updated to reflect the amount of storage
{       used by the request.  Normally, the work_area parameter passed to the
{       function processor is used for this parameter.
{
{ EXPECTED_TYPE: (output)  This parameter specifies the specification of the
{       expected type of the function's result.  If NIL is returned, no
{       particular tpye of result is expected, i.e.  any type of result is may
{       be acceptable.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$GET_INCLUDE_ENDED EXPAND=FALSE
{
{   This request determines whether the current input block (included file or
{ line) has been ended via a utility's termination command.
{
{   This request is intended for use by a CLT$UTILITY_DIALOG_MANAGER procedure
{ so that it can determine when to stop its processing
{
{       CLP$GET_INCLUDE_ENDED (UTILITY, INCLUDE_ENDED, STATUS)
{
{ UTILITY: (input)  This parameter specifies the name of the utility that is
{       expected to "own" the current input block.
{
{ INCLUDE_ENDED: (output)  This parameter specifies whether the input has been
{       ended (TRUE) or not (FALSE).
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: cle$unexpected_call_to
{
*DECK DECK=CLH$GET_LINE_FROM_COMMAND_FILE EXPAND=FALSE
{
{   The purpose of this request is to read the next "physical" line  from  the
{ current command file.  Line continuation is not processed by this request.
{
{       CLP$GET_LINE_FROM_COMMAND_FILE (PROMPT_STRING, LINE, STATUS)
{
{ PROMPT_STRING: (input) This parameter specifies the string to be issued as a
{       prompt for the line if the current command file is associated with  an
{       interactive terminal.
{
{ LINE:  (output)  This  parameter  specifies  the  line.  If a NIL pointer is
{       returned,  end-of-information  or  end-of-partition  on  the   current
{       command file was encounterred.  If the current source of command input
{       resulted from an include_line command or request,  a  NIL  pointer  is
{       returned.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=CLH$GET_LIST_OF_$LOCAL_FILES EXPAND=FALSE
{
{   The purpose of this request is to get a list of files in the $LOCAL
{ catalog.
{
{       CLP$GET_LIST_OF_$LOCAL_FILES (INFO, STATUS)
{
{ INFO: (input, output)  This parameter specifies the container to hold the
{       information returned by the request.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$GET_MESSAGE_MODULE_INFO EXPAND=FALSE
{
{   The purpose of this request is to retrieve  general  information  about  a
{ message module.
{
{       CLP$GET_MESSAGE_MODULE_INFO (MESSAGE_TEMPLATE_MODULE,
{         NATURAL_LANGUAGE, ONLINE_MANUAL_NAME, HELP_MODULE, MESSAGE_MODULE,
{         LOWEST_MESSAGE_CODE, HIGHEST_MESSAGE_CODE, STATUS)
{
{ MESSAGE_MODULE:  (input)  This parameter specifies the data representing the
{       message module.
{
{ NATURAL_LANGUAGE: (output) This parameter specifies the natural language  in
{       which all of the messages in the module are written.
{
{ ONLINE_MANUAL_NAME: (output) This parameter specifies the name of the online
{       manual that contains information about the messages in the module.
{
{ HELP_MODULE: (output) This parameter specifies whether the  module  contains
{       help messages.
{
{ MESSAGE_MODULE:   (output)  This  parameter  specifies  whether  the  module
{       contains status messages.
{
{ LOWEST_MESSAGE_CODE: (output) This parameter  specifies  the  value  of  the
{       lowest status condition code represented in the module.
{
{ HIGHEST_MESSAGE_CODE:  (output)  This  parameter  specifies the value of the
{       highest status condition code represented in the module.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$GET_MONTH_NAME EXPAND=FALSE
{
{   The purpose of this request is to get the name of the specified month
{ These names are kept on "month and day name" message modules (on an object
{ library in the command list).
{
{       CLP$GET_MONTH_NAME (MONTH_NUMBER, FULL_FORM, NATURAL_LANGUAGE,
{         MONTH_NAME, STATUS
{
{ MONTH_NUMBER: (input)  This parameter specifies the number (1..12) of the
{       month whose name is desired.
{
{ FULL_FORM: (input)  This parameter specifies whether the "full" form of the
{       name is to be returned (TRUE) or the name's abbreviation (FALSE).
{
{ NATURAL_LANGUAGE: (input)  This parameter specifies the natural language in
{       which the name is to be returned.  Osc$null_name can be used to
{       specify the job's currently selected natural language.  If no
{       definition for the month can be found in the requested natural
{       language, US_English is used.
{
{ MONTH_NAME: (output)  This parameter specifies the returned month name.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$bad_month_number
{                   ose$bad_natural_language
{
*DECK DECK=CLH$GET_NEXT_SCL_PROC_LINE EXPAND=FALSE
{
{   This request returns the next line from an SCL procedure module.
{
{       CLP$GET_NEXT_SCL_PROC_LINE (SCL_PROCEDURE, LINE, STATUS)
{
{ SCL_PROCEDURE: (input, output) This parameter specifies a SEQuence pointer
{       to an SCL procedure module.  The access the first line of a procedure
{       this pointer must be in a RESET state.  This request updates the
{       sequence pointer so that the next time the request is issued, the next
{       line of the procedure will be referenced.
{
{ LINE: (output) This parameter specifies a pointer to the line returned by
{       this request.  If NIL is returned there are no more lines in the
{       procedure.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$GET_OPEN_POS_OF_PATH_HANDLE EXPAND=FALSE
{
{   The purpose of this procedure is to determine the open position encoded in
{ a path handle name.
{
{       CLP$GET_OPEN_POS_OF_PATH_HANDLE (PATH_HANDLE_NAME, OPEN_POSITION)
{
{ PATH_HANDLE_NAME: (input) This parameter specifies the path handle name.
{
{ OPEN_POSITION: (output) This parameter specifies the open position.
{
*DECK DECK=CLH$GET_PARAMETER EXPAND=FALSE
{
{   The purpose  of  this  request  is to return the entire value list for the
{ specified parameter, in  its  uninterpreted  form,  as  a  string.   If  the
{ requested parameter was not given, a null string is returned.
{
{       CLP$GET_PARAMETER (PARAMETER_NAME, VALUE_LIST, STATUS)
{
{ PARAMETER_NAME:  (input)  This  parameter specifies any one of the parameter
{       names for the parameter in question.
{
{ VALUE_LIST: (output) This parameter specifies the parameter's value list.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$unexpected_call_to, cle$unknown_parameter_name
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$GET_PARAMETER_LIST EXPAND=FALSE
{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     ****** This program interface is obsolete.  Modules presently    ******
{     ****** using it should be changed to use CLP$GET_PARAMETER_      ******
{     ****** LIST_TEXT.                                                ******
{     ***********************************************************************
{     ***********************************************************************
{
{   The purpose of this request is to return the entire parameter list, in its
{ uninterpreted form, as a string.  If no parameters were given, a null string
{ is returned.
{
{       CLP$GET_PARAMETER_LIST (PARAMETER_LIST, STATUS)
{
{ PARAMETER_LIST: (output) This parameter specifies the parameter list.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$unexpected_call_to
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$GET_PARAMETER_LIST_TEXT EXPAND=FALSE
{
{   The purpose of this request is to get a pointer to the text of the
{ parameter list passed to a command or function processor.  The text is
{ passed in a SEQuence and this request returns a pointer to the text within
{ the sequence.
{
{   Normally this request is not needed since clp$evaluate_parameters does
{ this operation automatically.  This request is provided for those processors
{ that, for whatever reason, need to directly examine the unevaluated form of
{ the parameter list passed to them.
{
{       CLP$GET_PARAMETER_LIST_TEXT (PARAMETER_LIST, PARAMETER_LIST_TEXT,
{         STATUS)
{
{ PARAMETER_LIST: (input)  This parameter specifies the parameter list
{       containing the text.
{
{ PARAMETER_LIST_TEXT: (output)  This parameter specifies the parameter list
{       text.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$GET_PARAMETER_NUMBER EXPAND=FALSE
{
{   The purpose of this request is to determine the number (position) of a
{ command or function parameter.
{
{       CLP$GET_PARAMETER_NUMBER (PARAMETER_DESCRIPTION_TABLE, PARAMETER_NAME,
{         PARAMETER_NUMBER, STATUS)
{
{ PARAMETER_DESCRIPTION_TABLE: (input)  This parameter specifies the command's
{       or function's parameter description table (PDT).
{
{ PARAETER_NAME: (input)  This parameter specifies the name of the command or
{       function parameter whose number is desired.
{
{ PARAMETER_NUMBER: (output)  This parameter specifies the number of the
{       command or function parameter in question.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$GET_PATH_DESCRIPTION EXPAND=FALSE
{
{   The purpose  of  this  request  is  to  get  the  description of a command
{ language file reference.
{
{       CLP$GET_PATH_DESCRIPTION (FILE, FILE_REFERENCE, PATH_CONTAINER, PATH,
{         CYCLE_SELECTOR, OPEN_POSITION, STATUS)
{
{ FILE: (input)  This  parameter specifies the file whoose path description is
{       to be obtained.
{
{ FILE_REFERENCE: (output) This parameter specifies the  absolute  path  name,
{       size of the path name and validation ring for the file reference.  The
{       validation ring is the execution ring  in  which  the  file  reference
{       first  appeared  and  can be used by privileged processes to determine
{       appropriate access to the file.
{
{ PATH_CONTAINER: (output) This parameter specifies the storage area  for  the
{       path.   The array of path elements is placed in this area and the PATH
{       paraeter is set to point to the array.
{
{ PATH: (output) This parameter specifies the path through  the  hierarchy  of
{       catalogs  and  files  that  represents the item designated by the file
{       reference.  The first entry in this array is set to the family name of
{       the  owner  of  the file/catalog being referenced (if specified in the
{       reference as $FAMILY, the current family name  is  substituted).   The
{       second entry in this array is set to the user name of the owner of the
{       file/catalog being referenced (if specified in the reference as $USER,
{       the  current  user name is substituted).  The last entry in this array
{       specifies the file/catalog being referenced.  Entries between the user
{       and last entries, if any, designate subcatalogs.
{       NOTE that if the first entry in this array is $LOCAL,  then  the  path
{       designates  either  the  job's  $LOCAL  catalog  or a file within that
{       catalog.
{
{ CYCLE_SELECTOR: (output) This parameter specifies  the  cycle  of  the  file
{       being referenced.
{
{ OPEN_POSITION:  (output)  This  parameter  specifies the open position to be
{       used for the file being referenced.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$GET_PATH_NAME EXPAND=FALSE
{
{   The purpose of this request is to get a file reference from a local file
{ name.
{
{       CLP$GET_PATH_NAME (LOCAL_FILE_NAME, FORMAT, FILE_REFERENCE)
{
{ LOCAL_FILE_NAME : (input)  This parameter specifies the file name for which
{       the file reference is to be obtained.
{
{ FORMAT : (input)  This parameter specifies the message level for the file
{       reference:
{
{       OSC$BRIEF_MESSAGE_LEVEL - The path is presented relative to the working
{                                 catalog.
{       OSC$FULL_MESSAGE_LEVEL  - The path is presented as an absolute path.
{
{ FILE_REFERENCE: (output)  This parameter specifies the path represented by
{       the local file name.
{
*DECK DECK=CLH$GET_PROCESSING_PHASE EXPAND=FALSE
{
{   The purpose of this request is to return the command processing phase of
{ the requesting job.
{
{       CLP$GET_PROCESSING_PHASE (PROCESSING_PHASE, STATUS)
{
{ PROCESSING_PHASE: (output)  This parameter specifies the command processing
{       phase of the job.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$GET_REASON_FOR_CALL EXPAND=FALSE
{
{   The purpose of this request is to determine why a command or function
{ processor was called.  Normally, of course, the command or function is to be
{ processed; but a command or function processor may also be called as a
{ result of a call to the display_command/function_information command or its
{ equivalent.  In the latter case it is the responsibility of the command or
{ function processor to display the appropriate information.
{
{   Most command and function processors need not concern themselves with this
{ aspect of interfacing with SCL since they call clp$evaluate_parameters and
{ that request takes care of it for them.  This request is provided for those
{ command and function processors that, for whatever reason, don't use
{ clp$evaluate_parameters.
{
{       CLP$GET_REASON_FOR_CALL (INFORMATION_REQUEST, DISPLAY_FILE,
{         PROMPTING_ACTIVATED, STATUS)
{
{ INFORMATION_REQUEST: (output)  This parameter specifies whether the current
{       command or function processor was called to just provide information
{       (TRUE) or actually process the command or function (FALSE).
{
{ DISPLAY_FILE: (output)  This parameter specifies the file to which
{       information about the command or function is to be displayed.  This
{       parameter is meaningless (and set to all blanks) when FALSE is
{       returned for INFORMATION_REQUEST.
{
{ PROMPTING_ACTIVATED: (output)  This parameter specifies whether the command
{       or function processor should prompt for missing or erroneous
{       parameters (TRUE) or not (FALSE).  This parameter is meaningless (and
{       set to FALSE) when TRUE is returned for INFORMATION_REQUEST.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$GET_SEMICOLON_AFTER_COMMAND EXPAND=FALSE
{
{   The purpose of this request is to answer the question:  was the requesting
{ command terminated by a semicolon or an end-of-line?
{
{       CLP$GET_SEMICOLON_AFTER_COMMAND (SEMICOLON_AFTER_COMMAND, STATUS)
{
{ SEMICOLON_AFTER_COMMAND: (output)  This parameter specifies whether the
{       requesting command was followed by a semicolon (TRUE) or end-of-line
{       (FALSE).
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$GET_SET_COUNT EXPAND=FALSE
{
{   The purpose  of  this  request  is  to  determine the number of value sets
{ supplied for a particular parameter in the actual parameter  list.   If  the
{ parameter in  question was not given, a value set count of zero is returned.
{
{       CLP$GET_SET_COUNT (PARAMETER_NAME, VALUE_SET_COUNT, STATUS)
{
{ PARAMETER_NAME:  (input)  This  parameter specifies any one of the parameter
{       names for the parameter in question.
{
{ VALUE_SET_COUNT: (output) This parameter specifies the number of value  sets
{       given for the parameter.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$unexpected_call_to, cle$unknown_parameter_name
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$GET_SOURCE EXPAND=FALSE
{
{   The purpose of this request is to return the source (residence) of the
{ requesting command or function.
{
{       CLP$GET_SOURCE (SOURCE, STATUS)
{
{ SOURCE: (output)  This parameter specifies the source of the command or
{       function.  The KIND field specifies one of:
{
{       CLC$SYSTEM_SOURCE:  the command or function is part of the system.
{
{       CLC$UTILITY_SOURCE:  the command or function is part of the utility
{             designated by the UTILITY_NAME field.
{
{       CLC$CATALOG_SOURCE:  the command resides on a file in the catalog
{             designated by the PATH_NAME field.
{
{       CLC$LIBRARY_SOURCE:  the command or function resides in the object
{             library designated by the PATH_NAME field.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$GET_SYNCHRONOUS_WITH_PARENT EXPAND=FALSE
{
{   This request answers the question "is this task executing synchronously
{ with respect to its parent task".
{
{       CLP$GET_SYNCHRONOUS_WITH_PARENT (SYNCHRONOUS_WITH_PARENT, STATUS)
{
{ SYNCHRONOUS_WITH_PARENT: (output)  This parameter specifies whether the
{       requesting task is executing synchronously (TRUE) or asynchronously
{       (FALSE) with respect to the task that initiated it.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$GET_TASK_STATUS EXPAND=FALSE
{
{     The purpose of this request is to get the status of an asynchronous task.
{
{       CLP$GET_TASK_STATUS (TASK_NAME, TASK_STATUS, STATUS)
{
{ TASK_NAME: (input)  This parameter specifies the name of the task whose
{       status is requested.
{
{ TASK_STATUS: (output)  This parameter specifies whether the task has
{       completed and if so, what its completion status was.  If a TASK_NAME
{       is specified which is unknown, this parameter will indicate that the
{       task completed normally.
{
{ STATUS: (output)  This parameter specifies the request staus.
{
*DECK DECK=CLH$GET_TIME_STRING EXPAND=FALSE
{
{   This request produces the string representation of the current time in a
{ site defined format.
{
{       CLP$GET_TIME_STRING (STR, STATUS)
{
{ STR: (output)  This parameter specifies the result string.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: none
{
*DECK DECK=CLH$GET_TIME_ZONE_IDENTIFIER EXPAND=FALSE
{
{   The purpose of this request is to get the identifier of the specified time
{ zone.  These identifiers are kept on "time zone message modules" (on an
{ object library in the command list).
{
{       CLP$GET_TIME_ZONE_IDENTIFIER (TIME_ZONE, FULL_FORM, NATURAL_LANGUAGE,
{         TIME_ZONE_IDENTIFIER, STATUS)
{
{ TIME_ZONE: (input)  This parameter specifies the time zone whose identifier
{       is desired.
{
{ FULL_FORM: (input)  This parameter specifies whether the "full" form of the
{       identifier is to be returned (TRUE) or the identifier's abbreviation
{       (FALSE).
{
{ NATURAL_LANGUAGE: (input)  This parameter specifies the natural language in
{       which the identifier is to be returned.  Osc$null_name can be used to
{       specify the job's currently selected natural language.  If no
{       definition for the time zone can be found in the requested natural
{       language, US_English is used.  If a definition still cannot be found,
{       a null string (size = 0) is returned.
{
{ TIME_ZONE_IDENTIFIER: (output)  This parameter specifies the returned time
{       zone identifier.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: pme$invalid_time_zone
{                   ose$bad_natural_language
{
*DECK DECK=CLH$GET_TYPE_INFORMATION EXPAND=FALSE
{
{   This request retrieves information from a clt$type_specification.  It can
{ be used, for example, to determine the minimum and maximum size for a string,
{ the bounds for an array, etc.
{
{       CLP$GET_TYPE_INFORMATION (TYPE_SPECIFICATION, WORK_AREA,
{         TYPE_INFORMATION, STATUS)
{
{ TYPE_SPECIFICATION: (input)  This parameter specifies the type specification
{       from which information is to be obtained.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage which
{       is used to hold additional information about the type that is pointed
{       to from the TYPE_INFORMATION parameter.  The current position of this
{       sequence pointer is updated to reflect the amount of storage used by
{       the request.
{
{ TYPE_INFORMATION: (output)  This parameter specifies the information about
{       the type.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$GET_ULTIMATE_CONNECTION EXPAND=FALSE
{
{   This procedure  is called by bap$get_file_attributes to determine the name
{ of the file whoose attributes should be returned.  For a connected file, the
{ name  of  the  least  recently connected file is returned (this algorithm is
{ applied recursively).  For  a  non-connected  file,  the  original  name  is
{ returned.
{
{       CLP$GET_ULTIMATE_CONNECTION (CANDIDATE_NAME, ULTIMATE_NAME, STATUS)
{
{ CANDIDATE_NAME:  (input) This parameter specifies the name of the file being
{       interrogated.
{
{ ULTIMATE_NAME: (output) This parameter specifies the name of the  file  that
{       should be used.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$GET_UNSEEN_MAIL_ACTION EXPAND=FALSE
{
{   This request returns the currently selected action to be performed by the
{ default unseen_mail condition handler in the current environment.
{
{       CLP$GET_UNSEEN_MAIL_ACTION (ACTION, STATUS)
{
{ ACTION: (output) This parameter specifies the currently selected action to be
{        performed by the default unseen_mail condition handler.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             none
{
*DECK DECK=CLH$GET_UTILITY_ATTRIBUTES EXPAND=FALSE
{
{   This request gets the values of selected command utility attributes.
{
{       CLP$GET_UTILITY_ATTRIBUTES (NAME, ATTRIBUTES, STATUS)
{
{ NAME: (input)  This parameter specifies the name of the utiility whose
{       attributes are to be obtained.  If osc$null_name is specified, the
{       currently active utility is referenced.
{
{ ATTRIBUTES: (input, output)  This parameter specifies the attributes to get
{       via setting the key field of the array elements to designate the
{       desired attribute.  The attribute values are returned in the
{       corresponding array elements.  The following attributes may be
{       specified:  clc$null_utility_attribute,
{       clc$utility_command_search_mode, clc$utility_command_table,
{       clc$utility_function_table, clc$utility_function_proc_table,
{       clc$utility_interactive_include, clc$utility_libraries,
{       clc$utility_line_preprocessor, clc$utility_name,
{       clc$utility_online_manual, clc$utility_prompt,
{       clc$utility_subcmnd_log_enabled, clc$utility_termination_command.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:  cle$unknown_utility
{                    cle$unknown_utility_attribute
{                    cle$improper_utility_attribute
{                    cle$improper_utility_name
{
*DECK DECK=CLH$GET_VALUE EXPAND=FALSE
{
{   The purpose  of this request is to get a parameter value that was given in
{ the actual parameter list.  If the requested value was not given, a value of
{ kind  "unknown"  is  returned.   If the request is for the "high" value of a
{ range and a high value was not supplied but a "low" value was, then the  low
{ value is returned.
{
{       CLP$GET_VALUE (PARAMETER_NAME, VALUE_SET_NUMBER, VALUE_NUMBER,
{         LOW_OR_HIGH, VALUE, STATUS)
{
{ PARAMETER_NAME: (input) This parameter specifies any one  of  the  parameter
{       names for the parameter in question.
{
{ VALUE_SET_NUMBER:  (input) This parameter specifies from which value set the
{       value is to be obtained.
{
{ VALUE_NUMBER: (input) This parameter specifies which value within the  value
{       set is to be obtained.
{
{ LOW_OR_HIGH:  (input) This parameter specifies which "side" of a value range
{       is to be obtained.
{
{ VALUE: (output) This parameter specifies the parameter value.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$unexpected_call_to, cle$unknown_parameter_name
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$GET_VALUE_COUNT EXPAND=FALSE
{
{   The purpose  of this request is to determine the number of values given in
{ a particular value set for a particular parameter in  the  actual  parameter
{ list.   If  the  requested value set was not given, a value count of zero is
{ returned.
{
{       CLP$GET_VALUE_COUNT (PARAMETER_NAME, VALUE_SET_NUMBER, VALUE_COUNT,
{         STATUS)
{
{ PARAMETER_NAME:  (input)  This  parameter specifies any one of the parameter
{       names for the parameter in question.
{
{ VALUE_SET_NUMBER:  (input)  This  parameter  specifies  the  value  set   in
{       question.
{
{ VALUE_COUNT: (output) This parameter specifies the number of values given in
{       the specified value set for the specified parameter.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$unexpected_call_to, cle$unknown_parameter_name
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$GET_VARIABLE EXPAND=FALSE
{
{   This request retrieves the value, and related information, for an SCL
{ variable or variable component.  Any variable reference may be used to
{ specify the variable to be interrogated.
{
{       CLP$GET_VARIABLE (REFERENCE, WORK_AREA, CLASS, ACCESS_MODE,
{         EVALUATION_METHOD, TYPE_SPECIFICATION, VALUE, STATUS)
{
{ REFERENCE: (input)  This parameter specifies the variable to be interrogated.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage into
{       which is copied the returned variable's type specification and value.
{       The current position of this sequence pointer is updated to reflect
{       the amount of storage used by the request.
{
{ CLASS: (output)  This parameter specifies the class of the variable.
{
{ ACCESS_MODE: (output)  This parameter specifies the access mode of the
{       variable.
{
{ EVALUATION_METHOD: (output)  This parameter specifies the evaluation method
{       for the variable.
{
{ TYPE_SPECIFICATION: (output)  This parameter specifies (a copy of) the type
{       specification for the variable or variable component.
{
{ VALUE: (output)  This parameter specifies (a copy of) the value of the
{       variable or variable component.  If the variable has never been
{       assigned a value and the reference is to the entire variable (as
{       opposed to a component of the variable), NIL is returned.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$GET_VARIABLE_VALUE EXPAND=FALSE
{
{   This request retrieves the value for an SCL variable or variable component.
{ Any variable reference may be used to specify the variable.
{
{   The VALUE parameter returned by this requests points to a copy of the
{ variable's value.  The space occupied by that copy is released when the
{ requesting command processor terminates.  Therefore if a variable's value is
{ to be retreived repeatedly during the execution of a command processor it may
{ be better to use the CLP$GET_VARIABLE request which provides a WORK_AREA
{ parameter, thereby allowing the space to be reused on each call.
{
{       CLP$GET_VARIABLE_VALUE (REFERENCE, VALUE, STATUS)
{
{ REFERENCE: (input)  This parameter specifies the variable to be interrogated.
{
{ VALUE: (output)  This parameter specifies (a copy of) the value of the
{       variable or variable component.  If the variable has never been
{       assigned a value and the reference is to the entire variable (as
{       opposed to a component of the variable), NIL is returned.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$GET_WORKING_CATALOG EXPAND=FALSE
{
{   The purpose  of  this  request  is  to  get the description of the current
{ working catalog.
{
{       CLP$GET_WORKING_CATALOG (CATALOG_REFERENCE, PATH_CONTAINER, PATH,
{         STATUS)
{
{ CATALOG_REFERENCE:  (output) This parameter specifies the absolute path name
{       and size of the path name.
{
{ PATH_CONTAINER: (output) This parameter specifies the storage area  for  the
{       path.   The array of path elements is placed in this area and the PATH
{       paraeter is set to point to the array.
{
{ PATH: (output) This parameter specifies the path through  the  hierarchy  of
{       catalogs that represents the current working catalog.  The first entry
{       in this array is set to the family name of the owner  of  the  working
{       catalog  (if specified in the reference as $FAMILY, the current family
{       name is substituted).  The second entry in this array is  set  to  the
{       user  name  of  the  owner of the working catalog (if specified in the
{       reference as $USER, the current user name is substituted).   The  last
{       entry  in  this  array specifies the working catalog.  Entries between
{       the user and last entries, if any, designate subcatalogs.
{       NOTE  that  if  the first entry in this array is $LOCAL, then the path
{       designates the job's $LOCAL catalog.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$HORIZONTAL_TAB_DISPLAY EXPAND=FALSE
{
{   The purpose of this request is to write sufficient space characters to the
{ display such that the next character of data written to the display will
{ appear in the specified column.  If data has already been written at or
{ beyond the specified column, this request is ignored.
{
{       CLP$HORIZONTAL_TAB_DISPLAY (DISPLAY_CONTROL, COLUMN_NUMBER, STATUS)
{
{ DISPLAY_CONTROL: (input, output)  This parameter specifies the
{       display_control variable initialized when the display was opened.
{
{ COLUMN_NUMBER: (input)  This parameter specifies the column to which to tab.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$INCLUDE_COMMAND EXPAND=FALSE
{
{   The purpose of this request is to interpret a string as one or more
{ commands.
{
{   This request differs from the clp$include_line request in that the latter
{ builds a whole new "input control block" in which to process the commands and
{ control statements, whereas clp$include_command processes them in the context
{ of the current "input control block".
{
{       CLP$INCLUDE_COMMAND (COMMAND, ENABLE_ECHOING, STATUS)
{
{ COMMAND: (input)  This parameter specifies the command(s) to be interpreted.
{
{ ENABLE_ECHOING: (input)  This parameter determines whether the command may be
{       echoed (TRUE) or not (FALSE).
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$INCLUDE_FILE EXPAND=FALSE
{
{   The purpose of the CLP$INCLUDE_FILE request is to interpret text contained
{ in a specified file.  This request allows SCL statements contained in a
{ specified file to be processed in the same context as the issuer of the
{ request; i.e.  parameter substitution, variables and condition selections are
{ the same.
{
{   This request can be used on its own or in conjunction with the
{ clp$begin_utility request to initiate processing of the commands for a
{ utility.  When used with a utility, the file to be interpreted should
{ typically be specified as clc$current_command_input which is equivalent to
{ the SCL function $COMMAND.  Its use will result in the utility's commands
{ being read from the file that invoked the utility.
{
{   The text in the file may not contain incomplete statements, e.g.  if a
{ WHILE statement is in the file, the corresponding WHILEND must also be in the
{ file.
{
{   The attributes of the included file must conform to the following
{ constraints.
{
{   1.  The file_contents attribute must be either LEGIBLE_SCL_INCLUDE,
{       LEGIBLE_DATA or UNKNOWN.
{
{   2.  The record_type attribute may not be undefined (U).
{
{   3.  The access_mode attribute must contain at least the read and/or execute
{       modes.
{
{   4.  The request must be issued from a ring that is less than or equal to
{       the R2 component of the ring_attributes of the file.  If the
{       access_mode attribute does not include read (i.e.  the file is
{       "execute-only", the request is also constrained to be issued from a
{       ring greater than or equal to the R1 component of the ring attributes
{       of the file.
{
{   5.  A user defined file access procedure (fap) may be associated with the
{       file provided that read is in the access_mode attribute.
{
{   If the file to be included is associated with an interactive (terminal)
{ device, and the include is associated with a utility that has established an
{ "interactive include processor", that processor is called prior to
{ interpreting any commands from the file.  (This call may result in the
{ utility "going into screen mode" and therein doing its own "reading" of
{ commands.)
{
{   When control is returned from the "interactive include processor", further
{ processing is determined as follows:
{
{   1.  If the returned status is abnormal, this request terminates with that
{       status.
{
{   2.  If the utility's termination command has been executed, this request
{       terminates with normal status.
{
{   3.  Otherwise, processing of commands from the interactive file takes place
{       as if there had been no "interactive include processor".
{
{
{       CLP$INCLUDE_FILE (FILE, PROMPT, UTILITY, STATUS)
{
{ FILE: (input)  This parameter specifies the file to be included.
{
{ PROMPT: (input)  This parameter specifies a prompt string to be used if the
{       file is assigned to an interactive terminal.  If the request is used in
{       conjunction with a command utility, this parameter is ignored and the
{       utility's prompt attribute is used.
{
{ UTILITY: (input)  This parameter specifies the name of the utility with which
{       the clp$include_file is to be associated.  Osc$null_name may be
{       specified to avoid association with any utility.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: any
{
*DECK DECK=CLH$INCLUDE_LINE EXPAND=FALSE
{
{   The purpose of this request is to interpret a string as a statement list.
{ The text in the line may not contain incomplete statements, e.g.  if a WHILE
{ statement is in the line, the corresponding WHILEND must also be in the line.
{
{   This request can be used on its own or in conjunction with the
{ clp$begin_utility request to initiate processing of the commands for a
{ utility.
{
{   This request differs from the clp$include_command request in that
{ clp$include_line builds a whole new "input control block" in which to process
{ commands and control statements, whereas clp$include_command processes them
{ in the context of the current "input control block".
{
{       CLP$INCLUDE_LINE (STATEMENT_LIST, UTILITY, ENABLE_ECHOING, STATUS)
{
{ STATEMENT_LIST: (input)  This parameter specifies the string to be
{       interpreted.
{
{ ENABLE_ECHOING: (input)  This parameter determines whether the interpreted
{       commands and statements may be echoed (TRUE) or not (FALSE).
{
{ UTILITY: (input)  This parameter specifies the name of the utility with which
{       the clp$include_line is to be associated.  Osc$null_name may be
{       specified to avoid association with any utility.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$INTERNAL_EVALUATE_EXPR EXPAND=FALSE
{
{   This request evaluates an SCL expression.  It is the internal version of
{ clp$evaluate_expression used within the SCL interpreter.
{
{       CLP$INTERNAL_EVALUATE_EXPR (PARSE, TYPE_DESCRIPTION, WORK_AREA,
{         RESULT_TYPE_DESCRIPTION, RESULT, STATUS)
{
{ PARSE: (input, output)  This parameter specifies the expression to be
{       evaluated.  Upon entry it designates the first lexical unit of the
{       expression.  Upon exit it designates the lexical unit that follows the
{       expression.  Note the following:
{
{       1.  If the TYPE_DESCRIPTION specifies a union (ANY) or RANGE type, the
{           INDEX_LIMIT field of the PARSE parameter should "point" to the
{           position just past the end of the expression.  This restriction is
{           necessary in order to distinguish between the myriad possible types
{           of expressions.  For all other types of expressions, this routine
{           determines where it "thinks" the end of the expression is.
{
{       2.  If the TYPE_DESCRIPTION specifies an APPLICATION type with the
{           BALANCE_BRACKETS attribute, the INDEX_LIMIT field of the PARSE
{           parameter is ignored.  This allows the special parsing needed for
{           this case to be centrailized in this one place.  However, callers
{           of this routine that may specify such a type must check for the
{           INDEX_LIMIT being exceeded and take appropriate action.
{
{ TYPE_DESCRIPTION: (input)  This parameter specifies the data type the
{       expression is expected to result in.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the expression's result value.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The expression's result value is
{       completely contained within the used part of this sequence.
{
{ RESULT_TYPE_DESCRIPTION: (output)  This parameter specifies the type
{       description for for the result of the expresison.  It will be non-NIL
{       only if the expression consists entirely of a reference to a variable
{       or procedure parameter.
{
{ RESULT: (output)  This parameter specifies the expression's result value.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$ISOLATE_BALANCED_TEXT EXPAND=FALSE
{
{   The purpose  of  this  request  is to isolate the next group of characters
{ within TEXT that are balanced with respect to parentheses,
{ apostrophes  (single quotes) and double quotes.  The first
{ character of  the  isolated  text  is  designated  by  START_INDEX;  and  in
{ END_INDEX  is  returned  the  index  of the character following the balanced
{ text.  The text is isolated when one of HT (horizontal tab),  space,  comma,
{ semicolon,  two  (or  more)  dots,  right parenthesis,
{ or optionally, equal sign, less than  sign  or  greater
{ than  sign  is  found  not  nested  within pairs of the characters mentioned
{ above.  Also, finding the end of TEXT completes the isolation process.
{
{       CLP$ISOLATE_BALANCED_TEXT (MODE, TEXT, START_INDEX, END_INDEX)
{
{ MODE: (input) This parameter specifies  constraints  in  addition  to  those
{       described above on the text to be isolated.
{
{       CLC$IBT_NORMAL: This option specifies that only the criteria described
{             above are applied to the text.
{
{       CLC$IBT_STOP_ON_BALANCED: This option  specifies  that  the  isolation
{             process   should   stop   when  text  balanced  with  repect  to
{             parentheses is found.
{
{       CLC$IBT_STOP_ON_RELATIONAL: This option specifies that  the  isolation
{             process  should stop when an unnested equal sign, less than sign
{             or greater than sign is found.
{
{ TEXT: (input) This parameter specifies the text to be scanned.
{
{ START_INDEX: (input) This parameter specifies  the  first  character  within
{       TEXT to be scanned.
{
{ END_INDEX:  (output)  This  parameter  specifies  the index of the character
{       following the balanced text.
{
*DECK DECK=CLH$ISOLATE_COMMAND EXPAND=FALSE
{
{   The purpose of this request is to isolate an SCL command within TEXT.  The
{ command is assumed to begin in TEXT at START_INDEX.  This request returns in
{ END_INDEX the index of the character that follows the command.  Thus
{ END_INDEX is normally returned as strlength(text)+1, but when more than one
{ command appears on a line END_INDEX designates the command separator (e.g.  a
{ semicolon).
{
{       CLP$ISOLATE_COMMAND (TEXT, START_INDEX, END_INDEX)
{
{ TEXT: (input)  This parameter specifies the text to be scanned.
{
{ START_INDEX: (input)  This parameter specifies the first character within
{       TEXT to be scanned.
{
{ END_INDEX: (output)  This parameter specifies the index of the character
{       following the command.
{
*DECK DECK=CLH$KEYPOINT EXPAND=FALSE
{
{   The purpose of this procedure is to issue a keypoint instruction with
{ the specified keypoint class and keypoint code.
{
{        CLP$KEYPOINT (KEYPOINT_CLASS, KEYPOINT_CODE)
{
{ KEYPOINT_CLASS: (input) This parameter specifies the keypoint class.
{
{ KEYPOINT_CODE: (input) This parameter specifies the keypoint code.
{
*DECK DECK=CLH$LOG_AND_OR_ECHO_COMMAND EXPAND=FALSE
{
{   This request is intended for use by commands processors that do not use
{ clp$evaluate_parameters and have "secure" parameters.  The presence of
{ "secure" parameters should cause to command to have the "manually log"
{ attribute.  This attribute means that it is the responsibility of the
{ command's processor to cause the image of the command call to be logged
{ and/or echoed.  A command processor that uses clp$evaluate_parameters need
{ not concern itself with this responsibility since that interface will perform
{ the operation of this request on behalf of the command processor.
{
{       CLP$LOG_AND_OR_ECHO_COMMAND (EDITED_PARAMETER_LIST_TEXT, STATUS)
{
{ EDITED_PARAMETER_LIST_TEXT: (input)  This parameter specifies the text of the
{       parameter list passed to the command processor with the "secure"
{       parameters edited out.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$LOG_COMMENT EXPAND=FALSE
{
{   The purpose of this request is to place a message into the specified logs.
{
{       CLP$LOG_COMMENT (MESSAGE, LOG_NAME_SELECTIONS, STATUS)
{
{ MESSAGE: (input)  This parameter specifies the message to be placed in the
{       logs.
{
{ LOG_NAME_SELECTIONS: (input)  This parameter specifies the names of the logs.
{       Possible logs names are:  SYSTEM, STATISTIC, ENGINEERING, ACCOUNT, JOB,
{       JOB_ACCOUNT, JOB_STATISTIC, JOB_MESSAGE, HISTORY.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$MATCH_STRING_PATTERN EXPAND=FALSE
{
{   The CLP$MATCH_STRING_PATTERN request determines whether a string pattern
{ matches a subject string.
{
{   The clt$string_pattern that controls the matching process must be "built"
{ prior to calling this request.  For example, clp$build_pattern_for_wild_card
{ can be used.
{
{       CLP$MATCH_STRING_PATTERN (SUBJECT, PATTERN, ANCHOR_OPTION, SCAN_OPTION,
{         MATCH_INFO, STATUS)
{
{ SUBJECT: (input)  This parameter specifes the subject string to be scanned
{       for the PATTERN.
{
{ PATTERN: (input)  This parameter specifies the string pattern to be scanned
{       for in the SUBJECT.
{
{ ANCHOR_OPTION: (input)  This parameter specifies whether the pattern must be
{       found at the left end of the subject (CLC$SP_ANCHORED) or can be found
{       anywhere within the subject (CLC$SP_UNANCHORED).
{
{ SCAN_OPTION: (input)  This parameter specifies whether heuristics that can
{       speed up the scanning process should be used (CLC$SP_QUICK_SCAN) or
{       should be ignored (CLC$SP_FULL_SCAN).  It may be necessary to use the
{       "full" scan option for patterns containing certain advanced elements
{       (e.g.  "immediate assignment" and "unevaluated patterns").  Generally,
{       the "quick" scan option should be selected.
{
{ MATCH_INFO: (output)  This parameter specifies the results of the matching
{       process.  The RESULT field specifies the CLC$SP_SUCCESS or
{       CLC$SP_FAILURE of the attempt to match the pattern.  If the match was
{       successful, the INDEX field specifies where within the subject the
{       pattern was found, and the SIZE field specifies the number of
{       characters of the subject that the pattern matched.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{
{       CONDITIONS: cle$bad_string_pattern
{
*DECK DECK=CLH$NEW_DISPLAY_LINE EXPAND=FALSE
{
{   The purpose of this request is to start a new line on a display.  If this
{ operation would cause the page length of the display to be exceeeded, this
{ request calls clp$new_display_page.
{
{       CLP$NEW_DISPLAY_LINE (DISPLAY_CONTROL, SKIP_COUNT, STATUS)
{
{ DISPLAY_CONTROL: (input, output)  This parameter specifies the
{       display_control variable initialized when the display was opened.
{
{ SKIP_COUNT: (input)  This parameter specifies the number of lines to be left
{       blank before the new line.  CLC$NEXT_DISPLAY_LINE (0) is used to skip
{       no lines.  CLC$SAME_DISPLAY_LINE (-1) is used to "overprint" the
{       previously written line (treated like CLC$NEXT_DISPLAY_LINE if the
{       display's file_contents attribute is not LIST).
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$NEW_DISPLAY_PAGE EXPAND=FALSE
{
{   The purpose of this request is to start a new page on a display.  If a
{ new_page_procedure was specified when the display was opened, this request
{ calls it, otherwise clp$reset_for_next_display_page is called.  This
{ operation can be invoked automatically by clp$new_display_line,
{ clp$put_display and clp$put_partial_display.
{
{       CLP$NEW_DISPLAY_LINE (DISPLAY_CONTROL, SKIP_COUNT, STATUS)
{
{ DISPLAY_CONTROL: (input, output)  This parameter specifies the
{       display_control variable initialized when the display was opened.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$NEW_PAGE_PROCEDURE EXPAND=FALSE
{
{   CLP$NEW_PAGE_PROCEDURE is the standard new_page_procedure for displays.  A
{ pointer to it can be specified when a display is opened.
{
{   It should be nested within the main display procedure for the command using
{ it and requires the following decks to be *copy'd into the module in which it
{ is used:  clp$build_standard_title, clp$convert_integer_to_string,
{ clp$new_display_line, clp$put_display, clp$reset_for_next_display_page,
{ clp$right_justify_string, and clv$display_variables.
{
{   It also requires that a procedure called PUT_SUBTITLE be defined as:
{
{             PUT_SUBTITLE (DISPLAY_CONTROL, STATUS)
{
{       DISPLAY_CONTROL: (input, output)  This parameter specifies the
{             display_control variable initialized when the display was opened.
{
{       STATUS: (output)  This parameter specifies the request status.
{
{ PUT_SUBTITLE may produce any number of subtitle lines (it may for example
{ use clp$build_path_subtitle) or it may do nothing.
{
{   After the display has been opened the following variables (declared in
{ deck clv$display_variables) must be initialized:
{
{       CLV$COMMAND_NAME: to the name of the command producing the display.
{
{       CLV$TITLES_BUILT: to FALSE.
{
*DECK DECK=CLH$NOTIFY_BEFORE_COMMAND_READ EXPAND=FALSE
{
{   This request is obsolete.  The line_preprocessor utility attribute should
{ be used instead.
{
*DECK DECK=CLH$OPEN_DISPLAY EXPAND=FALSE
{
{   This request is obsolete.  CLP$OPEN_DISPLAY_REFERENCE shoule be used.
{
*DECK DECK=CLH$OPEN_DISPLAY_FILE EXPAND=FALSE
{
{   This request is obsolete.  CLP$OPEN_DISPLAY_REFERENCE shoule be used.
{
*DECK DECK=CLH$OPEN_DISPLAY_REFERENCE EXPAND=FALSE
{
{   The purpose of this request is to open a file for display output.  The file
{ is opened for append access (and shorten access if possible).  The file's
{ file_contents attribute must "list" or "legible" or "unknwon".  If it is
{ "list" each displayed line will have a "format effector" automatically
{ prefixed to it.
{
{   This request initializes a DISPLAY_CONTROL variable that holds state
{ information concerning the display.  The fields of this variable should never
{ be modified directly, always call the appropriate display request.  Certain
{ fields may, however, be usefully interrogated.  These are PAGE_WIDTH,
{ PAGE_LENGTH, PAGE_FORMAT and DEVICE_CLASS.  The display requests themselves
{ ignore PAGE_WIDTH and DEVICE_CLASS but PAGE_WIDTH should be used by most
{ display producers in order to tailor their output to the dimensions of the
{ output device or file.  The PAGE_LENGTH and PAGE_FORMAT fields are used to
{ automatically control the pagination of the display.  Unless you need to
{ place "page footers" in the output (see deck clh$vertical_tab_display) you
{ can ignore the PAGE_LENGTH field.  Unless you are imbedding "header" or
{ title-like information in the body of the display, you can ignore the
{ PAGE_FORMAT field.
{
{       CLP$OPEN_DISPLAY_REFERENCE (FILE, NEW_PAGE_PROCEDURE,
{         DEFAULT_FILE_CONTENTS, DEFAULT_RING_ATTRIBUTES, DISPLAY_CONTROL,
{         STATUS)
{
{ FILE: (input)  This parameter specifies the file to used for display output.
{
{ NEW_PAGE_PROCEDURE: (input)  This parameter specifies the procedure to be
{       called each time a new page of the display is about to be started.
{       This procedure may place "footer" information at the bottom of the
{       current page (if PAGE_NUMBER is greater than zero).  The procedure is
{       responsible for calling clp$reset_for_next_display_page.  It may then
{       put title information at the top of the new page (e.g.  using
{       clp$build_standard_title).  Alternativlely, the standard
{       clp$new_page_procedure may be specified.  See its header deck for more
{       information.  If NIL is specified only clp$reset_for_new_display_page
{       is called to start a new page.
{
{             NEW_PAGE_PROCEDURE (DISPLAY_CONTROL, NEW_PAGE_NUMBER, STATUS)
{
{       DISPLAY_CONTROL: (input, output)  This parameter specifies the
{             display_control variable initialized when the display was opened.
{
{       NEW_PAGE_NUMBER: (input)  This parameter specifies the number for the
{             page that the NEW_PAGE_PROCEDURE is to start.
{
{       STATUS: (output)  This parameter specifies the request status.
{
{ DEFAULT_FILE_CONTENTS: (input)  This parameter specifies the file_contents
{       attribute value to be used if this open request creates the file.
{       Usually this is specified as FSC$LIST.
{
{ DEFAULT_RING_ATTRIBUTES: (input)  This parameter specifies the ring
{       attributes to be used if this open request creates the file.  Normally,
{       the three ring attributes are set to the current ring of execution.
{       This parameter provides the means for a privileged process to created a
{       display file for a less privileged process.
{
{ DISPLAY_CONTROL: (output)  This parameter specifies the variable which
{       maintains state information for the display.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$PARAMETER_DESCRIPTOR_TABLE EXPAND=FALSE
{
{   A Parameter  Descriptor  Table  (PDT)  is used to specify to the parameter
{ list scanner the name(s) of, number and kind of values  allowed,  and  other
{ descriptive  information  about  the  parameters  for  a  command.   The PDT
{ consists  of  an  array  of  parameter  names  and  an  array  of  parameter
{ descriptors.   A  command  with  no parameters should set both the NAMES and
{ PARAMETERS fields to NIL.
{
{   The fields of a parameter descriptor table are defined as:
{
{ NAMES: specifies the parameter name descriptors.  The order  of  descriptors
{       in  the  array is irrelevant except that if an error is detected while
{       scanning a parameter that is given positionally, the error is reported
{       using  the  name  for  that parameter which appears first in the names
{       array.  There must be at least  one  entry  in  this  array  for  each
{       parameter.
{
{       NAME: specifies  the  name  by  which  the parameter can be given in a
{             non-positional manner.  The name must conform to the SCL  syntax
{             for names, and be left justified and space filled.
{
{       NUMBER:  specifies  the  number  or  positional  significance  of  the
{             parameter designated by the corresponding NAME.  This  value  is
{             an  index into the PARAMETER descriptor array for the designated
{             parameter.
{
{ PARAMETERS: specifies the parameter descriptors.  The elements  of  of  this
{       array are ordered by the positional significance of the parameters.
{
{       REQUIRED_OR_OPTIONAL:  specifies  whether  the parameter must be given
{             and what, if anything, its default is.
{
{             SELECTOR:  specifies  whether  the  parameter  must   be   given
{                   (clc$required),   can   be  omitted  and  has  no  default
{                   (clc$optional), or  can  be  omitted  and  has  a  default
{                   (clc$optional_with_default).
{
{             DEFAULT:      (only      defined      when      selector      is
{                   clc$optional_with_default) specifies the text representing
{                   the default value (list) for the parameter.
{
{       MIN_VALUE_SETS:  specifies  the minimum number of value sets that must
{             be given for the parameter.
{
{       MAX_VALUE_SETS: specifies the maximum number of value sets that can be
{             given for the parameter.
{
{       MIN_VALUES_PER_SET:  specifies  the minimum number of values that must
{             be given in each value set.
{
{       MAX_VALUES_PER_SET: specifies the maximum number of values that can be
{             given in each value set.
{
{       VALUE_RANGE_ALLOWED:  specifies  whether parameter values may be given
{             as a range (e.g.  low..high).
{
{       VALUE_KIND_SPECIFIER: specifies the kind of  value  allowed  for  this
{             parameter along with any appropriate qualifying information.
{
*DECK DECK=CLH$PARAMETER_DIALOG_MANAGER EXPAND=FALSE
{
{   A parameter dialog manager is a procedure called by the SCL interpreter
{ during parameter evaluation to obtain parameter values, corrections, etc.
{ for screen or desktop style interactions.
{
{       parameter_dialog_manager (SUPPORT, COMMAND_OR_FUNCTION_NAME,
{         ONLINE_MANUAL_NAME, PARAMETER_DESCRIPTION_TABLE, CANCEL, STATUS)
{
{ SUPPORT: (input)  This parameter specifies the procedures to be called for
{       various parameter dialog support activities.  Each field of the record
{       points to the procedure that implements a particular support request.
{       For those requests that return a pointer to some object (e.g.
{       "message" or "representation"), the pointer becomes invalid upon making
{       another support request.
{
{
{       The following requests ask for the corresponding messages from the
{       command's or function's "help module" to be returned.
{
{             support.GET_BRIEF_HELP (MAX_MESSAGE_LINE, MESSAGE, STATUS)
{
{       MAX_MESSAGE_LINE: (input)  This parameter specifies the maximum size a
{             line of the message can be.
{
{       MESSAGE: (output)  This parameter specifies the returned message.  The
{             message has the same structure as that returned by the
{             osp$format_help_message request.  NIL is returned is there is no
{             such message.
{
{       STATUS: (output)  This parameter specifies the request status.
{
{
{             support.GET_FULL_HELP (MAX_MESSAGE_LINE, MESSAGE, STATUS)
{
{       MAX_MESSAGE_LINE, MESSAGE, STATUS: See above.
{
{
{             support.GET_PARAMETER_PROMPT (PARAMETER_NUMBER, MAX_MESSAGE_LINE,
{                   MESSAGE, STATUS)
{
{       PARAMETER_NUMBER: (input)   This parameter specifies the number of the
{             command's or function's parameter being interrogated.
{
{       MAX_MESSAGE_LINE: See above.
{
{       MESSAGE: See above, except that NIL is not returned.  If there is no
{             prompt defined for the parameter, one is constructed from the
{             "nominal" name of the parameter.
{
{       STATUS: See above.
{
{
{             support.GET_PARAMETER_ASSIST_PROMPT (PARAMETER_NUMBER,
{                   MAX_MESSAGE_LINE, MESSAGE, STATUS)
{
{       PARAMETER_NUMBER, MAX_MESSAGE_LINE, MESSAGE, STATUS: See above.
{
{
{             support.GET_PARAMETER_HELP (PARAMETER_NUMBER, MAX_MESSAGE_LINE,
{                   MESSAGE, STATUS)
{
{       PARAMETER_NUMBER, MAX_MESSAGE_LINE, MESSAGE, STATUS: See above.
{
{
{       The following request asks for the "source" representation of the
{       specifications for all of the command's or function's parameters.
{
{             support.GET_ALL_PARAMETER_SPECS (INCLUDE_ADVANCED_ITEMS,
{                   MAX_REPRESENTATION_LINE, REPRESENTATION, STATUS)
{
{       INCLUDE_ADVANCED_ITEMS: (input)  This parameter specifies whether the
{             representation should include "advanced" parameters and keywords.
{
{       MAX_REPRESENTATION_LINE: (input)  This parameter specifies the
{             maximum size a line of the representation can be.
{
{       REPRESENTATION: (output)  This parameter specifies the returned
{             representation.  The representation has the same structure as
{             that returned by the clp$convert_data_to_string request.
{
{       STATUS: See above.
{
{
{       The following request asks for the "source" representation of the
{       specification for a particular command or function parameter.
{
{             support.GET_PARAMETER_SPEC (PARAMETER_NUMBER,
{                   INCLUDE_ADVANCED_KEYWORDS, MAX_REPRESENTATION_LINE,
{                   REPRESENTATION, STATUS)
{
{       INCLUDE_ADVANCED_KEYWORDS: (input)  This parameter specifies whether
{             the representation should include "advanced" keywords.
{
{       PARAMETER_NUMBER, MAX_REPRESENTATION_LINE, REPRESENTATION, STATUS:
{             See above.
{
{
{       The following request asks for the evaluated form of the value for a
{       particular command or function parameter.  This request can also be
{       used to determine whether a parameter was specified (and evaluated)
{       prior to calling the parameter dialog manager.
{
{             support.GET_PARAMETER_VALUE (PARAMETER_NUMBER, VALUE, STATUS)
{
{       PARAMETER_NUMBER:  See above.
{
{       VALUE: (output)  This parameter specifies the parameter value.
{
{       STATUS:  See above.
{
{
{       The following request asks for the "source" representation of the
{       value for a particular command or function parameter.  This request
{       should only be used for a parameter that has been evaluated (e.g.  via
{       a "support.EVALUATE_PARAMETER" request).
{
{             support.GET_PARAMETER_VALUE_SOURCE (PARAMETER_NUMBER,
{                   MAX_REPRESENTATION_LINE, REPRESENTATION, STATUS)
{
{       PARAMETER_NUMBER, MAX_REPRESENTATION_LINE, REPRESENTATION, STATUS:
{             See above.
{
{
{       The following request asks for the text of the default expression for a
{       command or function parameter to  returned.
{
{             support.GET_PARAMETER_DEFAULT (PARAMETER_NUMBER, TEXT, STATUS)
{
{       PARAMETER_NUMBER: See above.
{
{       TEXT: (output)   This parameter specifies the text of the default
{             expression.  If the parameter has no default, NIL is returned.
{             If the parameter has a "default variable" associated with it
{             and that variable is defined, its value is returned.  Otherwsie
{             the parameter's default expression is returned.
{
{       STATUS: See above.
{
{
{       The following request asks for an expression for a command or
{       function parameter to be evaluated.  If support.CHANGE_EXPRESSION_SAVE
{       is available (non-NIL) this request saves parameters according to the
{       most recent call made to it.  In that request's absence or if it is
{       not called, expression results are saved for parameters.  Also, if
{       that request is available and the attempt to evaluate the expression
{       fails, the source of the expression is saved for the parameter.
{
{             support.EVALUATE_PARAMETER (PARAMETER_NUMBER, TEXT, STATUS)
{
{       PARAMETER_NUMBER: See above.
{
{       TEXT: (input)   This parameter specifies the text of the expression
{             to be evaluated.
{
{       STATUS: See above.
{
{
{       The following request asks that the default specification for a
{       command or function parameter be restored, i.e. that any explicitly
{       specified value be erased.
{
{             support.RESTORE_PARAMETER_DEFAULT (PARAMETER_NUMBER, STATUS)
{
{       PARAMETER_NUMBER, STATUS: See above.
{
{
{       The following request asks that all command or function parameters
{       be verified.  This includes evaluation of default specifications for
{       optional parameters and checking that all required parameters have been
{       given.  All user supplied values for parameters must have been
{       evaluated via "support.EVALUATE_PARAMETER" requests.
{
{             support.VERIFY_ALL_PARAMETERS (ERROR_LOCATOR, STATUS)
{
{       ERROR_LOCATOR: (output)  This paramter specifies which, if any,
{             command or function parameter was in error, and is only
{             meaningful when STATUS is abnormal.  It may indicate the
{             particular parameter that was incorrect, or that the error
{             is not specific to any parameter.
{
{       STATUS: See above.
{
{
{       The following request asks that if there is an online manual defined
{       for the command, that it be invoked for an explanation of the command
{       or function.
{
{             support.EXPLAIN (EXPLANATION_AVAILABLE, STATUS)
{
{       EXPLANATION_AVAILABLE: (output)  This parameter specifies whether
{             sufficient information was available to call up an online
{             manual for the command or function.
{
{       STATUS: See above.
{
{
{       The following request asks that all of the names of the command or
{       function be returned.
{
{             support.GET_ALL_NAMES (NAMES, STATUS)
{
{       NAMES: (output)  This parameter specifies all of the names of the
{             command or function.
{
{       STATUS: See above.
{
{
{       The following request asks that the source of the command or
{       function be returned.  The source is the full path of a library
{       or catalog, a command utility's name, or $SYSTEM.
{
{             support.GET_SOURCE (SOURCE_STRING, SOURCE_STRING_SIZE, STATUS)
{
{       SOURCE_STRING: (output)  This parameter specifies a string representing
{             the source of the command or function.
{
{       SOURCE_STRING_SIZE: (output)  This parameter specifies the "trimmed"
{             size of SOURCE_STRING.
{
{       STATUS: See above.
{
{
{       Support.HELP_MODULE is a pointer to the help module for the command or
{       function.  NIL indicates there is no help module.
{
{
{       The following request is only available (its pointer is not NIL) if the
{       command or function has been called for the purpose of "editing" its
{       parameter list (e.g.  via clp$edit_command_parameter_list).  It enables
{       the parameter dialog manager to control what is saved for a parameter's
{       value: the expression as supplied by the user, or the result of
{       evaluating that expression.  When this request is available
{       support.EVALUATE_PARAMETER will save the source of the expression for
{       the parameter even if it could not be successfully evaluated.  This
{       enables the user to construct a parameter list that doesn't evaluate
{       correctly now, but will (presumably) when it is actually used.
{
{             support.CHANGE_EXPRESSION_SAVE (SAVE_EXPRESSION_SOURCE, STATUS)
{
{       SAVE_EXPRESSION_SOURCE: (input) This parameter specifies whether the
{             source of expressions should be saved for parameters (TRUE) or
{             the results of expressions should be saved (FALSE).
{
{       STATUS: See above.
{
{
{       The following request asks for a nested parameter dialog to occur.
{       This is intended for use with record types but could be used for other
{       purposes also.  The effect of this request is to recursively call the
{       parameter evaluation procedure which will, in turn, recursively call
{       dialog manager.  Once this nested dialog is completed, the source
{       representation of the resulting parameter list is returned.
{
{             support.NESTED_DIALOG (TEXT, DIALOG_PDT, DIALOG_TITLE,
{                   MAX_REPRESENTATION_LINE, REPRESENTATION, STATUS)
{
{       TEXT: (input)   This parameter specifies the text of the expression
{             representing the current value of the record.
{
{       DIALOG_PDT: (input)  This parameter specifies the Parameter Description
{             Table for the nested dialog.
{
{       DIALOG_TITLE: (input)  This parameter specifies the string to be used
{             to label the dialog for the record fields.
{
{       MAX_REPRESENTATION_LINE, REPRESENTATION, STATUS:
{             See above.
{
{
{       Support.NESTED_DIALOG_TITLE is a pointer to the "title" to be used for
{       a nested dialog, e.g. one resulting from a call to support.ZOOM_RECORD.
{       NIL indicates this is not a nested dialog.
{
{
{ COMMAND_OR_FUNCTION_NAME: (input)  This parameter specifies the name of the
{       command or function on behalf of which the parameter dialog is to be
{       carried on.
{
{ ONLINE_MANUAL_NAME: (input)  This parameter specifies the name of the online
{       manual that is assumed to contain a description of the command or
{       function.
{
{ PARAMETER_DESCRIPTION_TABLE: (input)  This parameter specifies the "Parameter
{       Description Table" (PDT) of the command or function for which a dialog
{       is to take place.  This is the "unbundled" (internal) form of the PDT.
{
{ CANCEL: (output)  This paramter specifies whether cancellation of execution
{       of the command was requested by the user (TRUE) or not (FALSE).
{
{ STATUS: (input, output)  On input this parameter specifies the status of
{       parameter evaluation up to the point of calling the parameter dialog
{       manager.  On output this parameter specifies the completion status of
{       the parameter dialog.
{
*DECK DECK=CLH$PARAMETER_LIST EXPAND=FALSE
{
{   The following  are  declarations  for  a  Parameter Value Table.  A PVT is
{ built by clp$scan_parameter_list in a task  local  segment  called  the  pvt
{ area.  Once constructed, it is placed in the block stack.
{
{   The first  part  of  the  pvt  area  is  the  actual parameter list in its
{ uninterpreted form.
{
{   The next part of the pvt area is an array of parameter  name  descriptors.
{ The  array  entries  are  derived  from the PDT, but are sorted in ascending
{ order  by  parameter  name.   Each  CLT$PVT_NAME  contains   the   following
{ information:
{
{ NAME: specifies a parameter name.
{
{ NUMBER:  specifies  the  number  or positional significance of the parameter
{       designated by the corresponding NAME.  This value is an index into the
{       CLT$PVT_PARAMETERS array for the designated parameter.
{
{   The next  part of the pvt area is an array of parameter descriptors.  Each
{ CLT$PVT_PARAMETER contains the following information:
{
{ HOW_GIVEN: specifies whether this entry represents a parameter that appeared
{       in  the  actual  parameter  list  or was given a default value, or was
{       omitted and has no default.
{
{ VALUE_SET_COUNT:  specifies  the  number  of  value  sets  given   for   the
{       parameter.
{
{ FIRST_VALUE_INDEX:  specifies the index into the CLT$PVT_VALUES array of the
{       first entry for this parameter.
{
{ LAST_VALUE_INDEX: specifies the index into the CLT$PVT_VALUES array  of  the
{       last entry for this parameter.
{
{ VALUE_LIST_INDEX:  specifies  the  index of the first character of the value
{       list for this parameter in the actual parameter list.
{
{ VALUE_LIST_SIZE: specifies the number of characters in the  value  list  for
{       this parameter in the actual parameter list.
{
{   The last   part  of  a  PVT  is  an  array  of  value  descriptors.   Each
{ CLT$PVT_VALUE contains the following information:
{
{ VALUE_SET_NUMBER: specifies the number of the value set  within  which  this
{       value appeared.
{
{ VALUE_NUMBER: specifies the number for this value within the value set.
{
{ LOW_OR_HIGH:  for  a value specified as a range (e.g.  low..high) this field
{       specifies which "side" of the range the value represents.  For a value
{       not specified as a range, this field is set to CLC$LOW.
{ VALUE: specifies the value itself.
{
{   The PVT is accessed through a CLT$PARAMETER_VALUE_TABLE which contains the
{ following information:
{
{ BUILT: indicates whether the PVT has been built for the block.
{
{ AREA: is a pointer to the area in which the data for the pvt in stored.  The
{       following pointers actually point into this area.
{
{ PARAMETER_LIST: is a pointer to the actual parameter list.
{
{ NAMES: is a pointer to the CLT$PVT_NAMES array.
{
{ PARAMETERS: is a pointer to the CLT$PVT_PARAMETERS array.
{
{ VALUES: is a pointer to the CLT$PVT_VALUES array.
{
*DECK DECK=CLH$PARSE_COMMAND EXPAND=FALSE
{
{   The purpose of this request is to parse a command into its major component
{ parts.
{
{       CLP$PARSE_COMMAND (PARSE, PROMPTING_REQUESTED, ESCAPED, LABEL,
{         COMMAND_REFERENCE_PARSE, FILE, FORM, NAME,
{         UTILITY_COMMAND_LIST_ENTRY, SEPARATOR, EMPTY_COMMAND, STATUS)
{
{ PARSE: (input, output)  On input this parameter specifies the command or
{       statement to be parsed; i.e.  the UNIT_INDEX and UNIT fields designate
{       the first lexical unit of the statement and the INDEX_LIMIT field
{       designates the position just past the end of the statement.  On output
{       this parameter specifies the parameter list for the command or
{       statement; i.e.  the UNIT_INDEX and UNIT fields have been updated to
{       designate the first lexical unit of the statement's parameters.
{
{ PROMPTING_REQUESTED: (output)  This parameter specifies whether the command
{       was prefixed by the "prompt for parameters" character (?).  (Undefined
{       if EMPTY_COMMAND is TRUE.)
{
{ ESCAPED: (output)  This parameter specifies whether the command was prefixed
{       by the "escape" character (/) used to control command search.
{       (Undefined if EMPTY_COMMAND is TRUE.)
{
{ LABEL: (output)  This parameter specifies the label on the command.  If no
{       label was present, osc$null_name is returned.  (Undefined if
{       EMPTY_COMMAND is TRUE.)
{
{ COMMAND_REFERENCE_PARSE: (output)  This parameter represents the "command
{       reference" part of the parsed command.  If the parsed statement is an
{       assignment statement, it represents the variable reference or "left
{       part" of the assignment statement.  (Undefined if EMPTY_COMMAND is
{       TRUE.)
{
{ FILE: (output)  This parameter specifies the file used in a file.command
{       style reference.  (Undefined if EMPTY_COMMAND is TRUE or if file_given
{       is FALSE.)
{
{ FORM: (output)  This parameter represents the form in which the command was
{       specified (undefined if EMPTY_COMMAND is TRUE):
{
{             command ----> clc$name_only_command_ref
{
{             file.command ----> clc$module_or_file_command_ref
{
{             catalog.command.cycle ----> clc$file_cycle_command_ref
{
{             $SYSTEM.command ----> clc$system_command_ref
{
{             UTILITY.command ----> clc$utility_command_ref
{
{ NAME: (output)  This parameter specifies the name of the command.  For an
{       assignment statement, the parameter is set to 'assignment' in lower
{       case.  For a <case selection> statement, the parameter is set to 'case
{       selection' in lower case.  For any other command the name is returned
{       in upper case.  (Undefined if EMPTY_COMMAND is TRUE.)
{
{ UTILITY_COMMAND_LIST_ENTRY: (output)  This parameter specifies the command_
{       list_entry representing the utility on a UTILITY.command reference.
{       (Undefined if EMPTY_COMMAND is TRUE, NIL if FORM is not
{       clc$utility_command_ref.)
{
{ SEPARATOR: (output)  This parameter specifies the separator between the
{       command reference and the parameters for the command.  If CLC$LEX_EQUAL
{       is returned, the command is a <case selection> statement if
{       COMMAND_REFERENCE_PARSE.UNIT.KIND is CLC$LEX_EQUAL and an assignment
{       statement otherwise.  Other possible values are:  CLC$LEX_SPACE,
{       CLC$LEX_COMMA, CLC$LEX_SEMICOLON, CLC$LEX_END_OF_LINE.  (Undefined if
{       EMPTY_COMMAND is TRUE.)
{
{ EMPTY_COMMAND: (output)  This parameter specifies whether the command is
{       empty (consists solely of spaces and/or comments).
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$PARSE_FILE_REFERENCE EXPAND=FALSE
*IF NOT $true(osv$unix)
{
{   This request is used to parse a "pre-evaluated" file reference.
{
{       CLP$PARSE_FILE_REFERENCE (PARSE, PATH_PARSED, EVALUATED_FILE_REFERENCE,
{         STATUS)
{
{ PARSE: (input, output)  This parameter specifies the file expression to be
{       evaluated.
{
{ PATH_PARSED: (output)  This parameter designates whether the file reference
{       had the correct syntax and was consequently successfully parsed.
{
{ EVALUATED_FILE_REFERENCE: (output)  This parameter specifies the information
{       resulting from the evaluation of the file reference.
{
{ STATUS: (output) This parameter specifies the request status.
{
*IFEND
*DECK DECK=CLH$PARSE_JOB_INDEPENDENT_PATH EXPAND=FALSE
{
{   This request is used to parse a job independent path.  Variables and
{ functions within the path are not dereferenced.  "Job context" path elements
{ ($command, $source, $defer, $local, $working_catalog, standard file, and job
{ file path elements) are not allowed.  The concatenation character is also not
{ allowed.
{
{       CLP$PARSE_JOB_INDEPENDENT_PATH (PATH, USER_IDENTIFICATION,
{         INCLUDE_OPEN_POSITION, PARSED_PATH, STATUS)
{
{ PATH: (input)  This parameter specifies the path to be parsed.
{
{ USER_IDENTIFICATION: (input)  This parameter specifies the family and user
{       information to be used for a relative path.
{
{ INCLUDE_OPEN_POSITION: (input)  This parameter specifies whether to include
{       the open position in the resulting parsed path.
{
{ PARSED_PATH: (output)  This parameter specifies the parsed path.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$POP_ENVIRONMENT EXPAND=FALSE

{
{   This request pops the current instance of an SCL "environment object" thus
{ restoring the previously pushed instance of that object.
{
{       CLP$POP_ENVIRONMENT (OBJECT, STATUS)
{
{ OBJECT:  (input) This parameter specifies the name of the environment object
{       to be popped.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=CLH$POP_INPUT EXPAND=FALSE
{
{   This request closes a file that has been used for command processing and
{ deletes its input block.
{
{       CLP$POP_INPUT (READ_ONLY, INPUT_BLOCK_HANDLE, FILE_ID,
{         OPENED_EXECUTABLE_FILE, TERMINATION_STATUS, STATUS)
{
{ READ_ONLY: (input)  This parameter specifies whether the input block was
{       created only for reading data (TRUE) or for command processing (FALSE).
{
{ INPUT_BLOCK_HANDLE: (input)  This parameter specifies the input block to be
{       deleted, if necessary.
{
{ FILE_ID: (input)  This parameter specifies the file_identifier if the file
{       was opened.
{
{ OPENED_EXECUTABLE_FILE: (input)  This parameter specifies whether the file
{       was opened for EXECUTEable access.
{
{ TERMINATION_STATUS: (input)  This parameter specifies the termination status
{       of processing the input in the block (ignored if READ_ONLY is TRUE).
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$POP_INTERACTIVE_INPUT EXPAND=FALSE
{
{   The purpose of this request is to remove the "input control block" from
{ SCL's command processing environment that was created by a corresponding
{ clp$push_interactive_input request.
{
{       CLP$POP_INTERACTIVE_INPUT (STATUS)
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$unexpected_call_to
{
*DECK DECK=CLH$POP_PARAMETERS EXPAND=FALSE
{
{   The purpose of this request is to undo the effect of the preceding call to
{ clp$push_parameters.
{
{       CLP$POP_PARAMETERS (STATUS)
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$unexpected_call_to
{
*DECK DECK=CLH$POP_UTILITY EXPAND=FALSE
{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     ****** This program interface is obsolete.  Modules presently    ******
{     ****** using it should be changed to use CLP$END_UTILITY.        ******
{     ***********************************************************************
{     ***********************************************************************
{
{   The purpose   of  this  request  is  to  disestablish  the  most  recently
{ established (via clp$push_utility) command environment.
{
{       CLP$POP_UTILITY (STATUS)
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$unexpected_call_to
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$PROCESS_WHEN_CONDITION EXPAND=FALSE
{
{   The purpose  of  this  request  is  to process the specified command level
{ "when" condition if one has been established.
{
{       CLP$PROCESS_WHEN_CONDITION (CONDITION, CONDITION_STATUS,
{         CONDITION_PROCESSED, STATUS)
{
{ CONDITION:  (input)  This  parameter  specifies  the  when  condition  to be
{       processed.
{
{ CONDITION_STATUS: (input) This parameter specifies the reason the  condition
{       has  been  raised.  The command language variable osv$status is set to
{       this value within the when/whenend block.
{
{ CONDITION_PROCESSED: (output) This parameter specifies whether the condition
{       was processed.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$PROCESS_WHEN_COND_IN_TASK EXPAND=FALSE
{
{   The purpose of this request is to process the specified command level
{ "when" condition if a WHEN/WHENEND handler has been established for the
{ condition.
{
{   It is intended to be called from the system supplied "default" handler for
{ the condition, i.e.  when no other handler has been established in the task
{ for the condition (or the condition has been "continued" back to the default
{ handler).
{
{       CLP$PROCESS_WHEN_COND_IN_TASK (CONDITION_DEFINITION, DEFAULT_HANDLER,
{         CONDITION_PROCESSED, STATUS)
{
{ CONDITION_DEFINITION: (input)  This parameter specifies the condition to be
{       processed.  It contains the NAME of the condition, its associated
{       STATUS and, for CLC$WC_LIMIT_FAULT conditions, the LIMIT_NAME.
{
{ DEFAULT_HANDLER: (input)  This parameter specifies the program interface
{       level procedure to be called if there are no command level handlers or
{       if the condition is continued to by the last such handler.
{
{ CONDITION_PROCESSED: (output)  This parameter specifies whether the condition
{       was processed (TRUE) or not (FALSE).
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$PUSH_ENVIRONMENT EXPAND=FALSE

{
{   This request pushes the current instance of an  SCL  "environment  object"
{ and  creates  a  new  instance of that object.  The initial value of the new
{ instance of the object is the current value of the pushed instance.
{
{       CLP$PUSH_ENVIRONMENT (OBJECT, STATUS)
{
{ OBJECT: (input) This parameter specifies the name of the environment  object
{       to  be pushed.  It is either the name of a standard environment object
{       or an SCL environment variable.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=CLH$PUSH_INPUT EXPAND=FALSE
{
{   This request opens a file for command processing and creates an input block
{ to be used by the SCL interpreter when accessing the file.
{
{   This request deals with the special "files" CLC$CURRENT_COMMAND_INPUT and
{ CLC$PROC_CALLER_COMMAND_INPUT by only opening the actual command file if
{ necessary and creating an input block "inherited" from the appropriate
{ current input block.
{
{       CLP$PUSH_INPUT (FILE, UTILITY_NAME, PROMPT_STRING, ENABLE_ECHOING,
{         READ_ONLY, INPUT_BLOCK_HANDLE, FILE_ID, OPENED_EXECUTABLE_FILE,
{         FILE_OPEN, STATUS)
{
{ FILE: (input)  This parameter specifies the name of the file to be used.
{
{ UTILITY_NAME: (input)  This parameter specifies the utility name to be
{       associated with the input block.  OSC$NULL_NAME should be used if the
{       processing of the file is not associated with a utility.
{
{ PROMPT_STRING: (input)  This parameter specifies the "seed" prompt string to
{       be used when prompting for command input from a terminal.
{
{ ENABLE_ECHOING: (input)  This parameter specifies whether commands processed
{       within the input block created by this request may be echoed.  Note
{       that specifying TRUE for this parameter does NOT guarantee that echoing
{       will occur, only that it is allowed as far as the caller of this
{       request is concerned.
{
{ READ_ONLY: (input)  This parameter specifies whether the input block is being
{       created only for reading data (TRUE) or for command processing (FALSE).
{
{ INPUT_BLOCK_HANDLE: (output)  This parameter specifies the input block
{       created by this request.
{
{ FILE_ID: (output)  This parameter specifies the file_identifier if the file
{       was opened.  It is meaningless if the FILE_OPEN parameter is returned
{       as FALSE.
{
{ OPENED_EXECUTABLE_FILE: (output)  This parameter specifies whether the file
{       was opened for EXECUTEable access.  It is needed when calling the
{       corresponding CLP$POP_INPUT request.  It is meaningless if the
{       FILE_OPEN parameter is returned as FALSE.
{
{ FILE_OPEN: (output)  This parameter specifies whether the file was opened by
{       this request (TRUE) or not (FALSE).
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$PUSH_INTERACTIVE_INPUT EXPAND=FALSE
{
{   The purpose of this request is to create an "input control block" in SCL's
{ command processing environment that represents input from an interactive
{ terminal.  This request is provided for applications that normally read
{ their own input (rather than have SCL read it for them) but that provide
{ some way for their users to enter "system commands".
{
{   This request should be made by an application at the point where it is
{ about to begin accepting input from an interactive terminal either in screen
{ or line mode.  When the application is finished accepting such input it
{ should make a corresponding clp$pop_interactive_input request.  In order to
{ process "system commands" received by it interactively, an application
{ should use the clp$include_command request.
{
{       CLP$PUSH_INTERACTIVE_INPUT (STATUS)
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$unexpected_call_to
{
*DECK DECK=CLH$PUSH_PARAMETERS EXPAND=FALSE
{
{   The purpose of this request is to establish an environment in which
{ clp$evaluate_parameters can be called to process a parameter list that was
{ not passed to a command or function processor.  This environment is created
{ automatically for a command or function processor but must be created
{ explicitly if clp$evaluate_parameters is called for other purposes.  Once
{ the "sub-parameters" have been evaluated and processed, a call should be
{ made to clp$pop_parameters to release the resources used for the parameter
{ evaluation.
{
{       CLP$PUSH_PARAMETERS (STATUS)
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{
*DECK DECK=CLH$PUSH_UTILITY EXPAND=FALSE
{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     ****** This program interface is obsolete.  Modules presently    ******
{     ****** using it should be changed to use CLP$BEGIN_UTILITY.      ******
{     ***********************************************************************
{     ***********************************************************************
{
{   The purpose  of  this  request  is to establish a new command environment.
{ This environment includes storage for command language variables, and a list
{ of subcommands  and "built-in" functions along with a search mode indicator.
{   This environment is disestablished when the  requesting  command  or  task
{ terminates or when a corresponding clp$pop_utility request is made.
{
{       CLP$PUSH_UTILITY (UTILITY_NAME, SEARCH_MODE, COMMANDS, FUNCTIONS,
{         STATUS)
{
{ UTILITY_NAME: (input) This parameter specifies the name of the  utility  (or
{       command  environment).   This  name  can be used to control scope when
{       declaring a command language variable.  Also, it  serves  to  identify
{       the  command  list  entry  in  the  output of the DISPLAY_COMMAND_LIST
{       command.
{
{ SEARCH_MODE: (input) This parameter specifies how the command list is to  be
{       searched:
{
{       clc$global_command_search:  specifies  that all entries in the command
{             list  will  be  searched  for  commands  unless  "escape   mode"
{             (preceding the command name with a reverse slant "\") is used to
{             bypass the first entry.
{
{       clc$restricted_command_search: specifies that  only  the  first  entry
{             will  be  searched  for commands unless "escape mode" is used to
{             cause searching of all but the first entry.
{
{       clc$exclusive_command_search: specifies that only the first entry will
{             be  searched  for  commands,  and  that  "escape  mode"  is  not
{             allowed.  This also disables the DELETE_COMMAND_LIST_ENTRY,
{             CREATE_COMMAND_LIST_ENTRY, CHANGE_COMMAND_SEARCH_MODE, and
{             SET_COMMAND_LIST commands.
{
{ COMMANDS: (input) This parameter specifies the utility's subcommands.
{
{ FUNCTIONS:  (input)  This  parameter  specifies  the  utility's   "built-in"
{       functions.  NIL can be used if the utility has no functions.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$improper_utility_name
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$PUT_DATA_REPRESENTATION EXPAND=FALSE
{
{   The purpose of this request is to write the string representation of a
{ clt$data_value to a display.
{
{       CLP$PUT_DATA_REPRESENTATION (DISPLAY_CONTROL, DATA_REPRESENTATION,
{         STATUS)
{
{ DISPLAY_CONTROL: (input, output)  This parameter specifies the
{       display_control variable initialized when the display was opened.
{
{ DATA_REPRESENTATION: (input, output) This parameter specifies the pointer to
{       the sequence containing the string representation of a clt$data_value.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$PUT_DISPLAY EXPAND=FALSE
{
{   The purpose of this request is to write a new line to a display.  If a line
{ has been partially written to the display, this request flushes that line
{ prior to writing the specified line.  If this operation would cause the page
{ length of the display to be exceeeded, this request calls
{ clp$new_display_page.
{
{       CLP$PUT_DISPLAY (DISPLAY_CONTROL, STR, TRIM_OPTION, STATUS)
{
{ DISPLAY_CONTROL: (input, output)  This parameter specifies the
{       display_control variable initialized when the display was opened.
{
{ STR: (input)  This parameter specifies the line to be written to the display.
{
{ TRIM_OPTION: (input)  This parameter specifies whether trailing spaces in STR
{       are to be trimmed prior to writing the line (CLC$TRIM) or not
{       (CLC$NO_TRIM).
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$PUT_JOB_OUTPUT EXPAND=FALSE
{
{   The purpose of this request is to write a line of text to $local.output.
{
{       CLP$PUT_JOB_OUTPUT (TEXT, STATUS)
{
{ TEXT: (input)  This parameter specifies the text to be written to $local.output.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$PUT_OPEN_POS_IN_PATH_HANDLE EXPAND=FALSE
{
{   The purpose of this procedure is to modify a path handle name to include a
{ representation  of  the  open  position  associated  with the file reference
{ corresponding to the path handle.
{
{       CLP$PUT_OPEN_POS_IN_PATH_HANDLE (OPEN_POSITION, PATH_HANDLE_NAME)
{
{ OPEN_POSITION: (input) This parameter specifies the open position.
{
{ PATH_HANDLE_NAME: (input, output) This parameter specifies the  path  handle
{       name to be modified.
{
*DECK DECK=CLH$PUT_PARTIAL_DISPLAY EXPAND=FALSE
{
{   The purpose of this request is to write part of a line to a display.  Using
{ this request a display line can be generated piece by piece.  If this
{ operation would cause the page length of the display to be exceeeded, this
{ request calls clp$new_display_page.
{
{       CLP$PUT_PARTIAL_DISPLAY (DISPLAY_CONTROL, STR, TRIM_OPTION,
{         TERM_OPTION, STATUS)
{
{ DISPLAY_CONTROL: (input, output)  This parameter specifies the
{       display_control variable initialized when the display was opened.
{
{ STR: (input)  This parameter specifies the text to be written to the display.
{
{ TRIM_OPTION: (input)  This parameter specifies whether trailing spaces in STR
{       are to be trimmed prior to writing the text (CLC$TRIM) or not
{       (CLC$NO_TRIM).
{
{ TERM_OPTION: (input)  This parameter specifies whether the text is to be
{       written as the first part of a line (AMC$START), the "middle" of a line
{       (AMC$CONTINUE) or the end of a line (AMC$TERMINATE).  If AMC$START is
{       specified and a line has been partially written to the display, this
{       request flushes that line prior to writing the specified text.  If
{       AMC$CONTINUE is specified but no line has been started, the request is
{       processed as if AMC$START had been specified.  If AMC$TERMINATE is
{       specified but no line has been started, the request is processed as if
{       clp$put_display had been called instead.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$PUT_PATH_REFERENCE_SUBTITLE EXPAND=FALSE
{
{   The purpose of this request is to produce a display subtitle consisting of
{ a path name prefixed by an identifying header string.
{
{   It should be nested within the main display procedure for the command using
{ it and requires the following decks to be *copy'd into the module in which it
{ is used:  clp$build_path_subtitle, clp$horizontal_tab_display,
{ clp$put_partial_display, clp$trimmed_string_size, and clv$display_variables.
{ It is intended to be called by the put_subtitle procedure used by
{ clp$new_page_procedure.
{
{   After the display has been opened that variable CLV$SUBTITLES_BUILT
{ (declared in deck clv$display_variables) must be initialized to FALSE.
{
{       CLP$PUT_PATH_REFERENCE_SUBTITLE (PATH, HEADER, STATUS)
{
{ PATH: (input)  This parameter specifies the path name to be displayed in the
{       subtitle.
{
{ HEADER: (input)  This parameter specifies the header text to precede the
{       first subtitle line containing the path name.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$PUT_PATH_SUBTITLE EXPAND=FALSE
{
{   This request is obsolete.  CLP$PUT_PATH_REFERENCE_SUBTITLE should be used
{ instead.
{
*DECK DECK=CLH$READ_VARIABLE EXPAND=FALSE
{
{   The purpose  of this request is to read the value of a variable or part of
{ a variable.  Only variables in the current block may be read.
{
{       CLP$READ_VARIABLE (REFERENCE, VARIABLE, STATUS)
{
{ REFERENCE: (input) This parameter specifies the variable or element or field
{       of  a variable to be read.  The parameter is given in the syntax of an
{       SCL variable reference except that if  a  subscript  is  part  of  the
{       reference  it  must  be  given  as  an  integer constant and not as an
{       expression.
{
{ VARIABLE: (output) This parameter specifies the variable or element or field
{       of the variable.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$improper_variable_reference, cle$unknown_variable.
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$RECORD_CHILD_TASK EXPAND=FALSE
{
{   This procedure  is  called  in  a  parent  task when a child task is being
{ created.  It allocates and initializes a frame in the Block  Stack  for  the
{ child  and records the child's presence in the appropriate Block Stack frame
{ of the parent.
{   Also, if  the  child  task is being executed synchronously with its parent
{ and the parent is executing synchronously with the original task in the job,
{ then  the  child is recorded as the "current job synchronous task" (the task
{ to be sent interactive "break" signals).
{
{       CLP$RECORD_CHILD_TASK (CALLER_RING, CHILD_TASK_ID,
{         SYNCHRONOUS_WITH_PARENT, COMMAND_FILE, STATUS)
{
{ CALLER_RING:  (input) This parameter specifies the ring of the caller of the
{       execute request for the specified child task.
{
{ CHILD_TASK_ID: (input) This parameter specifies the  task_id  of  the  child
{       task being created.
{
{ SYNCHRONOUS_WITH_PARENT:  (input) This parameter specifies whether the child
{       task  is  being  executed  synchronously  by  its  parent  (true)   or
{       asynchronously (false).
{
{ COMMAND_FILE:  (input) This parameter specifies a file which becomes the
{       current comand file (i.e.  $COMMAND) within the new task.  This
{       parameter is only meaningful if the task is being executed
{       asynchronously.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$RESET_FOR_NEXT_DISPLAY_PAGE EXPAND=FALSE
{
{   The purpose of this request is to start a new page of a display.  This
{ request is intended to be called by a "new_page_procedure" in order to
{ actually advance to the next page.
{
{       CLP$RESET_FOR_NEXT_DISPLAY_PAGE (DISPLAY_CONTROL, STATUS)
{
{ DISPLAY_CONTROL: (input, output)  This parameter specifies the
{       display_control variable initialized when the display was opened.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$RIGHT_JUSTIFY_STRING EXPAND=FALSE
{
{   The purpose of this request is to right justify a string of characters.
{
{       CLP$RIGHT_JUSTIFY_STRING (SUBSTRING)
{
{ SUBSTRING: (input,output)  This parameter specifies the string to be right
{       justified.
{
*DECK DECK=CLH$SCAN_ARGUMENT_LIST EXPAND=FALSE
{
{   The purpose  of  this request is to scan the argument list of a "built-in"
{ function.
{
{       CLP$SCAN_ARGUMENT_LIST (FUNCTION_NAME, ARGUMENT_LIST, ADT, AVT,
{         STATUS)
{
{ FUNCTION_NAME:  (input)  This  parameter  specifies the name of the function
{       whose argument list is to be scanned.
{
{ ARGUMENT_LIST: (input) This parameter specifies the argument  list  for  the
{       function.
{
{ ADT: (input)  This parameter specifies the Argument Descriptor Table for the
{       function.
{
{ AVT: (output) This parameter specifies the  Argument  Value  Table  for  the
{       function.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$SCAN_COMMAND_FILE EXPAND=FALSE
{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     ****** This program interface is obsolete.  Modules presently    ******
{     ****** using it should be changed to use CLP$INCLUDE_FILE.       ******
{     ***********************************************************************
{     ***********************************************************************
{
{   The purpose  of  this request is to cause the command language interpreter
{ to read and process commands from the specified file.  The commands  on  the
{ specified  file  are  treated  as  if  they  were  the  statement list of an
{ unlabelled block statement.  The interpretation  of  commands  initiated  by
{ this request can be terminated by a clp$end_scan_command_file request.
{
{       CLP$SCAN_COMMAND_FILE (FILE, UTILITY_NAME, PROMPT_STRING, STATUS)
{
{ FILE: (input)  This  parameter specifies the file from which commands are to
{       be read and processed.  If commands are to  be  interpreted  from  the
{       file  that  SCL is currently processing, then this parameter should be
{       specified by clc$current_command_input.
{
{ UTILITY_NAME: (input) This parameter specifies the name of  the  utility  on
{       whose  behalf  the file is to be scanned.  It is by means of this name
{       that clp$end_scan_command_file is told  which  command  file  scanning
{       operation is to be terminated.
{
{ PROMPT_STRING:  (input)  This parameter specifies the string to be used as a
{       prompt if the file  to  be  scanned  is  assigned  to  an  interactive
{       terminal.    See   the   interactive   processing   documentation  for
{       information about prompt strings.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: clc$min_ecc ..  clc$max_ecc
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$SCAN_COMMAND_LINE EXPAND=FALSE
{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     ****** This program interface is obsolete.  Modules presently    ******
{     ****** using it should be changed to use CLP$INCLUDE_LINE.       ******
{     ***********************************************************************
{     ***********************************************************************
{
{   The purpose  of  this  request  is to interpret a "line" of commands.  The
{ commands are treated as if they were the statement  list  of  an  unlabelled
{ block statement.
{
{       CLP$SCAN_COMMAND_LINE (TEXT, STATUS)
{
{ TEXT: (input) This parameter specifies the "line" to be scanned.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: clc$min_ecc ..  clc$max_ecc
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$SCAN_EXPRESSION EXPAND=FALSE
{
{   The purpose of this request is to scan and evaluate an expression.
{
{       CLP$SCAN_EXPRESSION (EXPRESSION, VALUE_KIND_SPECIFIER, VALUE, STATUS)
{
{ EXPRESSION: (input) This parameter specifies the expression to be scanned.
{
{ VALUE_KIND_SPECIFIER: (input) This parameter specifies the value kind of the
{       result of the expression.
{
{ VALUE: (output) This parameter specifies the result of the expression.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$SCAN_PARAMETER_LIST EXPAND=FALSE
{
{   The purpose  of  this  request is to scan the parameter list for a command
{ under control of a Parameter Descriptor Table.  This  request  may  only  be
{ invoked once an environment for the parameter list has been established.  An
{ environment is established automatically for a command processor,  but  must
{ be  explicitly  created (via clp$push_parameters) for a program other than a
{ command processor, or for a command  processor  which  wants  to  have  some
{ string interpreted as a parameter list.
{
{       CLP$SCAN_PARAMETER_LIST (PARAMETER_LIST, PDT, STATUS)
{
{ PARAMETER_LIST:  (input)  This  parameter specifies the parameter list to be
{       scanned.   Normally,  this  is  the  paramter  passed  to  a   command
{       processor.
{
{ PDT: (input) This parameter specifies the Parameter Descriptor Table for the
{       parameter list.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$SCAN_PROC_DECLARATION EXPAND=FALSE
{
{   The purpose  of  this  request  is to produce a parameter descriptor table
{ (PDT) from input that follows the form of  an  SCL  PROC  declaration.   The
{ caller  is  responsible  for dynamically providing the input to this request
{ via a procedure specified by the get_line parameter.
{
{       CLP$SCAN_PROC_DECLARATION (INPUT_TYPE, GET_LINE, PROC_NAME_AREA,
{         PARAMETER_NAME_AREA, PARAMETER_AREA, SYMBOLIC_PARAMETER_AREA,
{         EXTRA_INFO_AREA, PROC_NAMES, PDT, SYMBOLIC_PARAMETERS, STATUS)
{
{ INPUT_TYPE: (input) This parameter specifies what the first  "word"  of  the
{       input should be:
{
{       clc$proc_input  - The PROC option is used for scanning the declaration
{             of an SCL PROCedure, or for the dynamic building of  a  pdt  for
{             use by a command processor or program.
{
{       clc$pdt_input  -  The PDT option is used for static building of a pdt,
{             e.g.  when a source language definition of  the  pdt  is  to  be
{             produced.   When this option is selected only one <proc name> is
{             permitted in the declaration and the expressions for the minimum
{             and  maximum number of value sets and values, and the qualifiers
{             for the various value kinds are not evaluated but  are  returned
{             only in symbolic form.
{
{ GET_LINE:  (input)  This parameter specifies the procedure that this request
{       calls to get its input.  The procedure is responsible  for  processing
{       continuation  and  discarding  lines  that  are  empty or contain only
{       spaces or comments.  End  of  input  is  signalled  by  the  procedure
{       returning an empty line (i.e.  one whose size is zero).
{
{             get_line (LINE, INDEX, TOKEN, STATUS)
{
{       LINE: (output)   This   parameter   specifies  the  next  line  to  be
{             processed.
{
{       INDEX: (output) This parameter specifies the index  of  the  character
{             following the first token in the line.
{
{       TOKEN: (output)  This parameter specifies the first token in the line.
{
{       STATUS:  (output)  This parameter specifies the procedure's completion
{             status.
{
{ PROC_NAME_AREA: (input) This parameter specifies the  area  into  which  the
{       array of <proc name>s will be placed.
{
{ PARAMETER_NAME_AREA:  (input)  This  parameter specifies the area into which
{       the array of parameter names will be placed.
{
{ PARAMETER_AREA: (input) This parameter specifies the  area  into  which  the
{       array of parameter descriptors will be placed.
{
{ SYMBOLIC_PARAMETER_AREA: (input) This  parameter  specifies  the  area  into
{       which the array of symbolic parameter information will be placed.
{
{ EXTRA_INFO_AREA:  (input)  This  parameter  specifies  the  area  into which
{       information such as  keyword  value  tables  and  default  value  list
{       strings will be placed.
{
{ PROC_NAMES:  (output)  This  parameter specifies the pointer to the array of
{       <proc name>s.
{
{ PDT: (output) This parameter specifies the Parameter Descriptor Table.
{
{ SYMBOLIC_PARAMETERS: (output) This parameter specifies the pointer to  array
{       of symbolic parameter information.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: clc$min_ecc_proc_declaration ..
{             clc$max_ecc_proc_declaration, clc$min_ecc_expression_result ..
{             clc$max_ecc_expression_result, clc$min_ecc_expression ..
{             clc$max_ecc_expression, clc$min_ecc_function_processing ..
{             clc$max_ecc_function_processing, clc$min_ecc_variable ..
{             clc$max_ecc_variable, clc$min_ecc_file_reference ..
{             clc$max_ecc_file_reference, clc$min_ecc_lexical ..
{             clc$max_ecc_lexical
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$SCAN_TOKEN EXPAND=FALSE
{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     ****** This program interface is obsolete.  Modules presently    ******
{     ****** using it should be changed to use CLP$EVALUATE_TOKEN.     ******
{     ***********************************************************************
{     ***********************************************************************
{
{   The purpose  of this request is to scan the next lexical unit (token) in a
{ text string.  On input, the index indicates where to  begin  scanning  text.
{ On  output,  the  index  indicates  where  scanning  stopped (i.e.  the next
{ character, if any, to be scanned).
{
{   The text_index field of the token is set to the input value of index.  The
{ text_size  field of the token is set to the number of characters occupied by
{ the token in the text (i.e.  output value of index - token.text_index).  The
{ descriptor  field  of the token is set to a string that describes the token,
{ e.g.  for use in error messages.
{
{   Name tokens are left justified and  checked  for  size  not  exceeding  31
{ characters.   Lower case letters are converted to upper case.  Names must be
{ delimited at both ends.  The following definitions illustrate the syntax  of
{ a name:
{
{    clc$name_token ::= <alphabetic char> [<alphanumeric char>]...
{    <alphanumeric char> ::= <alphabetic char> | <digit>
{    <alphabetic char> ::= <letter> | _ | $ | # | @
{
{   Integer tokens may have radix specifications and must be delimited at both
{ ends.  The  default  radix  is  decimal  (10).   The  following  definitions
{ illustrate the syntax of integers:
{
{   clc$integer_token ::=  <digit> [<hex digit>]... [<(> <radix> <)>]
{
{   Real tokens,  must have fractional portions and may have an exponent and a
{ sign.  Example: 123.456e+3 The following definitions illustrate  the  syntax
{ of real numbers:
{
{    clc$real_token ::=  <mantissa> [<exponent>]
{    <mantissa> ::= <integer part> <.> <fraction part>
{    <integer part> ::= <unsigned decimal>
{    <fraction part> ::= <unsigned decimal>
{    <exponent> ::= <E|e> [<+|->] <unsigned decimal>
{    <unsigned decimal> ::= <digit>...
{
{   Strings must be enclosed in apostrophes  (single  quote  marks).   In  the
{ token,  the enclosing apostrophes are removed and doubled apostrophes within
{ the original string are replaced by  a  single  apostrophe.   The  following
{ definitions illustrate the syntax of strings:
{
{    clc$string_token ::= ' [<string char>]... '
{    <string char> ::= <any ascii character except '> | ''
{
{   Spaces preceding  and/or  following  commas,  equal  signs,   semi-colons,
{ reverse  slants  and  ellipsis  tokens  are  treated  as  part of the actual
{ delimiter.  The  following  definitions  illustrates  the  syntax  of  these
{ delimiters:
{
{    clc$comma_token ::= [<sp>] , [<sp>]
{    clc$assign_token ::= [<sp>] = [<sp>]
{    clc$semicolon_token ::= [<sp>] ; [<sp>]
{    clc$rslant_token ::= [<sp>] \ [<sp>]
{    clc$ellipsis_token ::= [<sp>] .. [.]... [<sp>]
{
{   Spaces following  but  not  preceding left parenthesis, left bracket, left
{ brace and query tokens are treated as part of  the  actual  delimiter.   The
{ following definitions illustrate the syntax of these delimiters:
{
{    clc$lparen_token ::= ( [<sp>]
{    clc$lbracket_token ::= [ [<sp>]
{    clc$lbrace_token ::= { [<sp>]
{    clc$query_token ::= ? [<sp>]
{
{   Spaces preceding but not following right parenthesis, right  bracket,  and
{ right  brace  tokens  are  treated  as  part  of  the actual delimiter.  The
{ following definitions illustrate the syntax of these delimiters:
{
{    clc$rparen_token ::=  [<sp>] )
{    clc$rbracket_token ::= [<sp>] ]
{    clc$rbrace_token ::= [<sp>] }
{
{   Spaces either preceding or following the dot  and  colon  tokens  are  not
{ treated  as  part  of  the  actual  delimiter.   The  following  definitions
{ illustrate the syntax of these delimiters:
{
{    clc$dot_token ::= .
{    clc$colon_token ::= :
{
{   Spaces preceding  and/or  following  the  exponentiate,  multiply, divide,
{ concatenate, greater than, greater than or equal to, less than, less than or
{ equal  to,  equal  to,  and  not  equal to tokens are treated as part of the
{ actual operator.  The following definitions illustrate the syntax  of  these
{ operators:
{
{    clc$exp_token ::= [<sp>] ** [<sp>]
{    clc$mult_token ::= [<sp>] * [<sp>]
{    clc$div_token ::= [<sp>] / [<sp>]
{    clc$cat_token ::= [<sp>] // [<sp>]
{    clc$gt_token ::= [<sp>] > [<sp>]
{    clc$ge_token ::= [<sp>] >= [<sp>]
{    clc$lt_token ::= [<sp>] < [<sp>]
{    clc$le_token ::= [<sp>] <= [<sp>]
{    clc$eq_token ::= [<sp>] = [<sp>]
{    clc$ne_token ::= [<sp>] <> [<sp>]
{
{   Spaces following but not preceding add and subtract tokens are treated  as
{ part  of  the  actual  operator.   The  following definitions illustrate the
{ syntax of these operators:
{
{    clc$add_token ::= + [<sp>]
{    clc$sub_token ::= - [<sp>]
{
{   Contiguous spaces  occurring  other  than  as described above, are treated
{ collectively as a clc$space_token.  The horizontal  tab  (HT)  character  is
{ treated  identically  to the space character.  Also, comments are treated as
{ spaces.
{
{   Any character that  does  not  begin  a  token  previously  described,  is
{ returned as a clc$unknown_token.
{
{
{       CLP$SCAN_TOKEN (TEXT, INDEX, TOKEN, STATUS)
{
{ TEXT: (input) This parameter specifies the text to be scanned.
{
{ INDEX: (input, output) This parameter specifies the  next  character  within
{       TEXT to be scanned.
{
{ TOKEN: (output) This parameter specifes the token.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: clc$min_ecc_lexical ..  clc$max_ecc_lexical
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$SCL_SIGNAL_HANDLER EXPAND=FALSE
{
{   The purpose of this request is to process signals sent from one task to
{ another in the same job by the NOS/VE SCL interpreter.
{
{       CLP$SIGNAL_HANDLER (ORIGINATOR, SIGNAL)
{
{ ORIGINATOR: (input)  This parameter specifies the sender of the signal.
{
{ SIGNAL: (input)  This parameter specifies the received signal.  The only
{       signal identifier expected by this handler is CLC$SCL_SIGNAL.  The
{       signal is described by CLT$SCL_SIGNAL_CONTENTS which defines the
{       following kinds of signals (currently only one):
{
{       CLC$SIGNAL_EXITING:  This signal is used in the processing of the SCL
{             EXIT statement when the target block of the EXIT belongs to an
{             ancester of the task issuing the EXIT statement.
{
{             CHILD_TASK_ID:  This field identifies the recipient task's child
{                   task, which must be terminated.
{
{             EXIT_CONTROL_BLOCK:  This field identifies the block whose
{                   corresponding condition handler is responsible for
{                   completing the EXIT.
{
*DECK DECK=CLH$SETUP_AND_PARSE_FILE_REF EXPAND=FALSE
{
{    This request obtains a work area, identifies lexical units, initializes
{ the parse state and calls clp$complete_file_ref_parse to evaluate the
{ file reference.
{
{       CLP$SETUP_AND_PARSE_FILE_REF (FILE, FILE_REFERENCE_PARSING_OPTIONS,
{         USER_IDENTIFICATION, EVALUATED_FILE_REFERENCE, STATUS)
{
{ FILE: (input)  This parameter specifies the file expression whose
{       evaluation is to be completed.
{
{ FILE_REFERENCE_PARSING_OPTIONS: (input)  This parameter specifies the
{       parsing options which will govern the manner in which the expression
{       is evaluated.  The options are:
{
{       clc$use_$local_as_working_cat:  This option specifies that
{             $LOCAL should be used as the working catalog in the event that
{             the file reference is a relative path.  If this option is
{             omitted, the path is considered to be relative to the current
{             working catalog.
{
{       clc$evaluating_command_ref:  This option specifies that the
{             file reference is part of a command reference. Specifying
{             this option in conjunction with the clc$evaluating_entry_
{             point_ref option will result in an error.
{
{       clc$evaluating_entry_point_ref:  This option specifies that the
{             file reference is part of an entry point reference. Specifying
{             this option in conjunction with the clc$evaluating_command_ref
{             option will result in an error.
{
{       clc$multiple_reference_allowed:  This option specifies that the
{             "wild card" notation is to be allowed in the file reference.
{
{       clc$command_file_ref_allowed:  This option specifies that a
{             command file reference (i.e.  $COMMAND or $COMMAND_OF_CALLER) is
{             to be allowed.
{
{       clc$file_ref_evaluation_stage:  This option specifies the
{             extent to which the expression is evaluated.  If
{             this option is specified, the values of any variables or
{             functions in the expression are determined and an
{             absolute path is constructed. If omitted, additional
{             interpretation of generic path elements and cycle
{             references occurs, which is the case when the file
{             expression is being used to access a file or catalog.
{
{ USER_IDENTIFICATION: (input)  This parameter specifies the family and
{       user identification to be used for a relative path.
{
{ EVALUATED_FILE_REFERENCE: (output)  This parameter specifies the information
{       resulting from the evaluation of the file reference.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CLH$SET_LOCK_VARIABLE EXPAND=FALSE
{
{   This request is used to set a variable of type lock.
{
{       CLP$SET_LOCK_VARIABLE (REFERENCE, WAIT, STATUS)
{
{ REFERENCE: (input)  This parameter specifies the lock variable to be set.
{
{ WAIT: (input)  This parameter specifies whether the request should wait
{       until the lock can be set or return immediately if the lock is already
{       set.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: cle$lock_already_set
{                   cle$lock_set_by_current_task
{                   cle$lock_expired
{
*DECK DECK=CLH$SET_PRIMARY_TASK EXPAND=FALSE
{
{   The purpose of this request is to establish the requesting task as the
{ primary task of the job.  The primary task is the task to which such events
{ as interactive conditions are sent.
{
{   If the primary task initiates a child task synchronously, that child task
{ becomes the primary task.  If the primary task terminates, its parent becomes
{ the primary task.
{
{       CLP$SET_PRIMARY_TASK (STATUS)
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$SET_WORKING_CATALOG EXPAND=FALSE
{
{   The purpose of this request is to set the working catalog.
{
{       CLP$SET_WORKING_CATALOG (CATALOG, STATUS)
{
{ CATALOG:  (input)  This  parameter specifies the string to be interpreted as
{       the new working catalog.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: clc$min_ecc_file_reference ..  clc$max_ecc_file_reference,
{             clc$min_ecc_lexical ..  clc$max_ecc_lexical
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$SKIP_SPACES_AND_COMMENTS EXPAND=FALSE
{
{   This procedure  scans  "text"  starting  at "start_index" until it finds a
{ character which is not a "space" that is not  contained  in  a  comment  and
{ returns the index of that character in "end_index".  If no such character is
{ found, "end_index" is set to strlength(text)+1.  Also a boolean is  returned
{ indicating whether any spaces or comments were found.
{
{       CLP$SKIP_SPACES_AND_COMMENTS (TEXT, START_INDEX, END_INDEX,
{         FOUND_SPACES_OR_COMMENT)
{
{ TEXT: (input) This parameter specifies the text in which leading spaces  and
{       comments are to be skipped.
{
{ START_INDEX:  (input)  This  parameter  specifies  where  in "text" to start
{       skipping.
{
{ END_INDEX: (output) This parameter specifies where the skipping stopped.
{
{ FOUND_SPACE_OR_COMMENT: (output) This parameter specifies  whether  anything
{       was skipped.
{
*DECK DECK=CLH$SP_CONVERT_TO_STRING EXPAND=FALSE
{
{   This request produces the string representation of a string pattern.  This
{ represenation is in the form of a string pattern expression, i.e. the standard
{ SCL functions and operators used to build string patterns are used to the
{ representation.
{
{       CLP$SP_CONVERT_TO_STRING (SOURCE_PATTERN, WORK_AREA, RESULT_STRING,
{         STATUS)
{
{ SOURCE_PATTERN: (input)  This parameter specifies the pattern to be represented.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the pattern's representation.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string is contained
{       completely within the used part of this sequence.
{
{ RESULT_STRING: (output)  This parameter specifies the result string.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{
*DECK DECK=CLH$SP_PATTERN_CONCAT_PATTERN EXPAND=FALSE
{
{   This request concatentates two string patterns together to form a pattern
{ that matches a subject string containing the "left" pattern followed
{ immediately by the "right" pattern.
{
{       CLP$SP_PATTERN_CONCAT_PATTERN (LEFT_PATTERN, RIGHT_PATTERN, WORK_AREA,
{         RESULT_PATTERN, STATUS)
{
{ LEFT_PATTERN: (input)  This parameter specifies the left operand pattern of
{       the concatentation.
{
{ RIGHT_PATTERN: (input)  This parameter specifies the right operand pattern of
{       the concatentation.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ RESULT_PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{
*DECK DECK=CLH$SP_PATTERN_CONCAT_STRING EXPAND=FALSE
{
{   This request concatentates a string pattern and a string together to form a
{ pattern that matches a subject string containing the "left" pattern followed
{ immediately by the "right" string.
{
{       CLP$SP_PATTERN_CONCAT_STRING (LEFT_PATTERN, RIGHT_STRING, WORK_AREA,
{         RESULT_PATTERN, STATUS)
{
{ LEFT_PATTERN: (input)  This parameter specifies the left operand pattern of
{       the concatentation.
{
{ RIGHT_PATTERN: (input)  This parameter specifies the right operand string of
{       the concatentation.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ RESULT_PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{
*DECK DECK=CLH$SP_PATTERN_OR_PATTERN EXPAND=FALSE
{
{   This request joins two string patterns together to form a pattern that
{ matches a subject string containing either the "first" pattern or the
{ "second" pattern.
{
{       CLP$SP_PATTERN_OR_PATTERN (FIRST_PATTERN, SECOND_PATTERN,
{         WORK_AREA, RESULT_PATTERN, STATUS)
{
{ FIRST_PATTERN: (input)  This parameter specifies the first pattern of the
{       alternation.
{
{ SECOND_PATTERN: (input)  This parameter specifies the second pattern of the
{       alternation.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ RESULT_PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{
*DECK DECK=CLH$SP_STRING_CONCAT_PATTERN EXPAND=FALSE
{
{   This request concatentates a string and a string pattern together to form a
{ pattern that matches a subject string containing the "left" string followed
{ immediately by the "right" pattern.
{
{       CLP$SP_STRING_CONCAT_PATTERN (LEFT_STRING, RIGHT_PATTERN, WORK_AREA,
{         RESULT_PATTERN, STATUS)
{
{ LEFT_STRING: (input)  This parameter specifies the left operand string of
{       the concatentation.
{
{ RIGHT_PATTERN: (input)  This parameter specifies the right operand pattern of
{       the concatentation.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ RESULT_PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{
*DECK DECK=CLH$SP_STRING_LITERAL EXPAND=FALSE
{
{   This request builds a string pattern that matches a literal string.
{
{       CLP$SP_STRING_LITERAL (STRING_LITERAL, WORK_AREA, PATTERN, STATUS)
{
{ STRING_LITERAL: (input)  This parameter specifies the string literal.
{
{ CASE_SENSITIVE: (input)  This parameter specifies whether the case (lower or
{       upper) matters (TRUE) or not (FALSE) when matching STRING_LITERAL.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{
*DECK DECK=CLH$STORE_UTILITY_DIALOG_INFO EXPAND=FALSE
{
{   This request establishes information for a utility dialog.
{
{       CLP$STORE_UTILITY_DIALOG_INFO (UTILITY, COMMANDS, FUNCTIONS,
{         CREATE_SCRATCH_SEGMENT, DIALOG_INFO, STATUS)
{
{ UTILITY: (input)  This parameter specifies the name of the utility for which
{       the utility dialog manager is called.
{
{ COMMANDS: (input)  This parameter specifies the table of auxilliary commands
{       provided by the utility dialog manager.
{
{ FUNCTIONS: (input)  This parameter specifies the table of auxilliary
{       functions provided by the utility dialog manager.
{
{ CREATE_SCRATCH_SEGMENT: (input)  This parameter specifies whether a scratch
{       segment is to be created for use by the utility dialog manager.  Such a
{       scratch segment is deleted automatically when the utility terminates.
{
{ DIALOG_INFO: (output)  This parameter specifies the information established
{       for the utility dialog.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: cle$unexpected_call_to
{
*DECK DECK=CLH$SUBSTITUTE_DELIMITED_TEXT EXPAND=FALSE
{
{   This request scans for delimited SCL string expressions within a  line  of
{ text.   Each  expression  is evaluated and the result replaces the delimited
{ text including the delimiters.
{
{   If a second delimiter is not found in a line, the end-of-line  is  treated
{ as  the  second  delimiter.   Two consecutive delimiters are replaced with a
{ single delimiter.
{
{   If an expression cannot be  evaluated  the  original  text  including  the
{ delimiters  is  not  replaced.   If the new line of text exceeds the maximum
{ line size, the original line  is  returned.   In  both  cases,  the  request
{ terminates with an appropriate status.
{
{       CLP$SUBSTITUTE_DELIMITED_TEXT (OLD_TEXT, DELIMITER, NEW_TEXT,
{         NEW_TEXT_SIZE, STATUS)
{
{ OLD_TEXT: (input) This parameter specifies the text to be processed.
{
{ DELIMITER:  (input)  This  parameter  specifies the delimiter for the string
{       expressions.
{
{ NEW_TEXT: (output) This parameter specifies the result of  the  substitution
{       process.
{
{ NEW_TEXT_SIZE: (output) This parameter specifies the length of the result of
{       the substitution process.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=CLH$TEST_HARNESS EXPAND=FALSE
{
{ PURPOSE:
{   This module contains the command language and file system test harnesses.
{   The command language and file system may be run as separate test harnesses
{   or together as one test harness.
{
{ Listed below are commands for building and running the test harness.  These
{ commands are currently available in .rrp.test_harness.command_library.
{   1. CHECK_STUBBED_PROCEDURES
{      This command will generate a list of latest modification dates and times
{      of the xref decks in .intve.os.source_library for each stubbed procedure
{      in the test harness.  It can also compare this new list against a
{      previous one and list the stubbed procedure names whose xref deck
{      modification date or time has changed.
{      Parameters:
{        old_file                :file containing stubbed procedure names with
{                                 their xref deck modification date and time.
{                                 The new list of stubbed procedure names with
{                                 their latest xref deck modification date and
{                                 time is compared with this file.  If the file
{                                 is omitted no comparison is made.
{        new_file                :file that will contain the stubbed procedure
{                                 names with their latest xref deck modification
{                                 date and time.
{        modification_file       :file that will contain the stubbed procedure
{                                 names that have a new xref deck modification
{                                 date or time as a result from the above
{                                 comparison.
{        found_new_modifications :indicates if a new xref deck modification date
{                                 or time has been found for a stubbed procedure
{                                 as a result from the above comparison.
{   2. BUILD_NEW_TEST_HARNESS
{      This command will submit a batch job to build the appropriate test
{      harness.
{      Paramters:
{        kind                       :type of test harness to be built.
{        build_level                :build level the test harness is to be
{                                    compiled at.
{        catalog                    :catalog that will contain the test harness
{                                    library, binaries, and listing library.
{        debug                      :indicates if the test harness is to be
{                                    compiled with debug information.
{        test_tool_build_level      :build level of the test tool library used
{                                    to satisfy external references.
{        check_stubbed_procedures   :indicates whether to execute the
{                                    CHECK_STUBBED_PROCEDURES command and to
{                                    keep building the test harness if new xref
{                                    deck modifications are found for the test
{                                    harness stubbed procedures.
{        old_stubbed_procedure_file :defined in CHECK_STUBBED_PROCEDURES
{                                    command. If check_stubbed_procedures
{                                    parameter is set to 'ignore' this parameter
{                                    is ignored.
{        new_stubbed_procedure_file :defined in CHECK_STUBBED_PROCEDURES
{                                    command. If check_stubbed_procedures
{                                    parameter is set to 'ignore' this parameter
{                                    is ignored.
{        modification_file          :defined in CHECK_STUBBED_PROCEDURES
{                                    command. If check stubbed_procedures
{                                    parameter is set to 'ignore' this parameter
{                                    is ignored.
{   3. BIND_TEST_HARNESS
{      This command will create a bound version of the test harness.
{      Parameters:
{        bound_library           :object library that will contain the test
{                                 harness bound module.
{        library                 :list of object libraries that will comprise
{                                 the test harness bound module.
{        kind                    :type of test harness.
{        retain                  :entry point names to be retained in the test
{                                 harness bound module.
{        enable_test_environment :indicates if libraries for
{                                 create_test_environment should be added to
{                                 test harness bound module.
{        feature_test_binary     :object library containing the feature test
{                                 binaries for create_test_environment.
{                                 If enable_test_environment parameter is
{                                 set to 'false' this parameter is ignored.
{   4. CREATE_TEST_HARNESS_PGM_DESC
{      This command will create a program description that will execute the
{      appropriate test harness.
{      Pararmeters:
{        pgm_desc_library         :object library that will contain the test
{                                  harness program description.
{        pgm_desc_name            :list of names defined for the test harness
{                                  program description.
{        library                  :list of object libraries that will be added to
{                                  the program library list when the test harness
{                                  harness is executed.
{        bound                    :indicates if the test harness is bound.
{        kind                     :type of test harness.
{        termination_error_level  :indicates the termination error level for
{                                  running the test harness.
{        enable_test_environment  :indicates if create_test_environment will
{                                  be enabled for the test harness.
{        feature_test_binary      :object_library containing the feature
{                                  test binaries for create_test_environment.
{                                  If enable_test_environment parameter is
{                                  set to 'false' this parameter is ignored.
{   5. ESTABLISH_SCL_ENVIRONMENT
{      This command will create the necessary environment needed before the SCL
{      test harness is run.
{      Parameters:
{        message_template_library :list of object libraries containing message
{                                  modules to be added to
{                                  $local.osf$command_library.
{   6. ESTABLISH_FS_ENVIRONMENT
{      This command will create the necessary environment needed before the FS
{      test harness is run.
{   7. EXECUTE_TEST_HARNESS
{      This command will create the necessary test harness environment by
{      executing command(s) ESTABLISH_SCL_ENVIRONMENT and/or
{      ESTABLISH_FS_ENVIRONMENT.  It will the execute the appropriate test
{      harness by using a supplied program description or by creating an EXET
{      command.
{      Parameters:
{        library                  :list of libraries to be added to program
{                                  library list via the EXET command.  This
{                                  parameter is ignored if a program description
{                                  is supplied.
{        pgm_desc_library         :object library containing a program
{                                  description to execute the test harness.
{        pgm_desc_name            :name of the program description to execute
{                                  the test harness.
{        kind                     :type of test harness.  This parameter is
{                                  ignored if a program description is supplied.
{        bound                    :indicates if the test harness is bound.  This
{                                  parameter is ignored if a program description
{                                  is supplied.
{        termination_error_level  :indicates the termination error level for
{                                  running the test harness.
{        message_template_library :defined in ESTABLISH_SCL_ENVIRONMENT command.
{                                  This parameter is ignored if a program
{                                  description is supplied or the parameter kind
{                                  is 'fs'.
{        enable_test_environment  :indicates if create_test_environment should
{                                  be enabled for the test harness.  This
{                                  parameter is ignored if a program description
{                                  is supplied.
{        feature_test_binary      :object_library containing the feature
{                                  test binaries for create_test_environment.
{                                  It will be added to the program library list
{                                  via the EXET command.  This parameter is
{                                  ignored is a program description is supplied
{                                  or enable_test_environment parameter is set
{                                  to 'false'.
{
{ Listed below is information regarding the different test harnesses.  To the
{ left of the information is a table indicating the test harness(es) to which
{ the information pertains. Any parameters referred to below are in relation
{ to an EXET command or a program description used to execute the test harness.
{
{ |SCL| FS|FS_SCL| BUILDING THE TEST HARNESS
{ |   |   |      | 1. Test harness procedure name to be specified on the
{ |   |   |      |    starting_procedure parameter
{ | * |   |  *   |    a. clp$test_harness.
{ |   | * |      |    b. fsp$test_harness.
{ |   |   |      | 2. Using an ubound version of the test harness
{ | * |   |  *   |    a. All libraries that are to be used including the test
{ |   |   |      |       harness should be specified in the library parameter.
{ |   |   |      |       This will eliminate any problems with multiple
{ |   |   |      |       executions of the same entry point.  It allows the
{ |   |   |      |       capability to reload the entry point.  The libraries
{ |   |   |      |       could also be put into the job library list.
{ |   |   |      | 3. Using a bound version of the test harness
{ | * |   |  *   |    a. All libraries that are to be used must be bound
{ |   |   |      |       together with the test harness library.
{ | * |   |  *   |    b. All entry point names that will be executed more than
{ |   |   |      |       once must be retained on the bound module.
{ | * |   |  *   |    c. If TASK/TASKEND statements will be executed, the entry
{ |   |   |      |       point name clp$task_taskend must be retained on the
{ |   |   |      |       bound module.
{ | * |   |  *   |    d. Omit all other non-retained entry points.
{ | * |   |  *   |    e. The bound library should be specified in the library
{ |   |   |      |       parameter.
{ | * |   |  *   |    f. Always execute the bound version with the debug_mode
{ |   |   |      |       parameter set to ON!  This will eliminate problems with
{ |   |   |      |       multiple executions of the same entry point because
{ |   |   |      |       entry points cannot be reloaded.  Some entry points such
{ |   |   |      |       as the editor will be affected by this since it is not
{ |   |   |      |       reloaded after the first time it is executed.
{ |   | * |  *   | 4. All AM, BAM, FM, PF, FS and test utility code are required
{ |   |   |      |    unmodified.
{ |   | * |  *   | 5. To make amp$return work, take out ring checking of
{ |   |   |      |    fmp$return_file, fmm$job_file_mgr.
{ |   | * |  *   | 6. Add the test tools library to the program library list.
{ |   |   |      |   (normally resides on .testve.test_tools.build_xxxxx.
{ |   |   |      |    ttf$test_tool_library)
{ |   | * |  *   | 7. The loadmap should be checked for dangerous references to
{ |   |   |      |    TASK_SERVICES.
{ |   | * |  *   | 8. Suggested enhancements:
{ |   | * |  *   |    a. Enforcement of protocol on mmp$lock, mmp$unlock
{ |   |   |      | 9. Examples
{ |   |   |      |    a. Executing an unbound version of the test harness
{ | * | * |      |       1. EXET library=(unbound_test_harness_library, ..
{ |   |   |      |               my_first_library, my_second_library) ..
{ |   |   |      |               starting_procedure=clp$test_harness
{ |   |   |  *   |       2. CREOL
{ |   |   |      |           addm library=(unbound_test_harness_library)
{ |   |   |      |           sater library=.testve.test_tools.build_xxxxx..
{ |   |   |      |                 .ttf$test_tool_library
{ |   |   |      |           genl library=unbound_test_harness_library
{ |   |   |      |         QUIT
{ |   |   |      |         EXET library=unbound_test_harness_library ..
{ |   |   |      |              sp=fsp$test_harness ..
{ |   |   |      |              termination_error_level=fatal
{ |   |   |      |    b. Executing a bound version of the test harness
{ | * |   |  *   |       1.CREOL
{ |   |   |      |           addm library=(unbound_test_harness_library, ..
{ |   |   |      |                my_first_library, my_second_library)
{ |   |   |      |           genl library=all_libraries
{ |   |   |      |           crem name=bound component=all_libraries ..
{ |   |   |      |           starting_procedure=clp$test_harness ..
{ |   |   |      |           retain=(clp$task_taskend, my_first_command, ..
{ |   |   |      |                  my_second_command)
{ |   |   |      |           chama name=bound omit_non_retained_entry_points=yes
{ |   |   |      |           genl library=bound_test_harness_library
{ |   |   |      |         QUIT
{ |   |   |      |         EXET library=bound_test_harness_library ..
{ |   |   |      |              starting_procedure=clp$test_harness ..
{ |   |   |      |              debug_mode=on
{ |   |   |      |
{ |   |   |      | RUNNING THE TEST HARNESS
{ | * | * |  *   | 1. The test harness must be in bound version to use the
{ |   |   |      |    debugger.
{ | * | * |  *   | 2. The unbound version of the test harness may be used
{ |   |   |      |    with measure_program_execution.
{ |   |   |      |    measure_program_execution
{ |   |   |      |      set_program_description target_text=test_harness_..
{ |   |   |      |        library sp=test_harness_starting_procedure
{ |   |   |      |      execute_instrumented_task
{ |   |   |      |        " Enter commands as you would normally
{ |   |   |      |        " Enter command to leave test harness
{ |   |   |      |      display_program_profile puc=local n=200 ..
{ |   |   |      |        output=output_file
{ |   |   |      |    quit
{ | * | * |  *   | 3. Some stubbed procedures used for multiple tasks will
{ |   |   |      |    display a message to the job log indicating thay are
{ |   |   |      |    being executed. A couple examples are pmp$execute and
{ |   |   |      |    pmp$abort.
{ |   |   |      | 4. The following represent known restrictions in this
{ |   |   |      |    environment:
{ | * | * |  *   |    a. no tape files,
{ |   |   |  *   |    b. no implicit attaches,
{ | * |   |  *   |    c. all files are treated as unconnected,
{ | * |   |  *   |    d. all open positions specified on commands are ignored.
{ | * |   |  *   | 5. A library containing a message template module should be
{ |   |   |      |    added to the command list. ESTABLISH_SCL_ENVIRONMENT
{ |   |   |      |    command does this.
{ | * |   |  *   | 6. Only the starting procedure parameter of an EXET command
{ |   |   |      |    or program description is processed. The starting
{ |   |   |      |    procedure must be in a library specified in the library
{ |   |   |      |    parameter at the point of excuting the test harness.
{ | * |   |  *   | 7. If executing a command as object_library.entry point or
{ |   |   |      |    object_library.program_description, the entry point to be
{ |   |   |      |    executed must be in a library specified in the library
{ |   |   |      |    parameter at the point of executing the test harness.
{ | * |   |  *   | 8. Execution of an object file as a command will not work
{ |   |   |      |    because the starting procedure is not determined.
{ |   | * |   *  | 9. The file system environment must be cleaned up before
{ |   |   |      |    executing the test harness.  ESTABLISH_FS_ENVIRONMENT
{ |   |   |      |    command does this.
{ | * | * |   *  | 10.If executing the test harness with enable_test_environment
{ |   |   |      |    set to 'true' then termination_error_level must be set
{ |   |   |      |    to 'fatal'.
{ |   |   |      |    The command library .rrp.test_harness.command_library
{ |   |   |      |    must be put into the command list.  The command for
{ |   |   |      |    create_test_environment is th_create_test_environment.
{ |   |   |      |    And the command for run_test is th_run_test.
{ |   |   |      |    The libraries .testve.test_tools.bound_product and
{ |   |   |      |    $system.osf$site_command_library are accessed.  If
{ |   |   |      |    feature_test_binary is set to 'current_build' a file
{ |   |   |      |    called $local.osf$f_test_binaries is created and accessed.
{ |   | * |      | 11.EXET commands, TASK/TASKEND statements, and any other type
{ |   |   |      |    of execution of binaries will execute in the real system.
{ |   | * |   *  | 12.For each test harness file or catalog created there is an
{ |   |   |      |    associated REAL file system file created. The first real
{ |   |   |      |    file is called $local.JJJ1, the second JJJ2, and so on.
{ |   |   |      |    This is a segment access file, and may be inspected with
{ |   |   |      |    the display_file command.  (Be sure to give byte_address
{ |   |   |      |    on the display_file).
{ |   | * |   *  | 13.To use permanent files do:
{ |   |   |      |      recover_files
{ |   |   |      |      define_master_catalog $user
{ |   |   |      |    To run through pf recovery do
{ |   |   |      |      recover_files
{ |   | * |      | 14.Always specify a LFN on all attach_file, and create_file
{ |   |   |      |    requests.  On detach_file be sure to specify $Local.file
{ |   |   |      |    name.  In general do not use working catalog, nor let the
{ |   |   |      |    lfn default.
{ |   | * |   *  | 15.To attempt job recovery do:
{ |   |   |      |      Create the permanent file base as above
{ |   |   |      |      recover_files recover_files=true
{ |   |   |      |      recover_job_files (for each job)
{ |   | * |   *  | 16.Bringing files into the environment - A terrible mess
{ |   |   |      |    colt file
{ |   |   |      |      put at least 100 bytes into the file
{ |   |   |      |    pause break
{ |   |   |      |    use disf to see which fake file to use
{ |   |   |      |    copf your real file $Local.jjjx
{ |   |   |      |    resc
{ |   |   |      |    chafa file to the needed file attributes
{ |   |   |      |    fc=object and fs=library for command libraries
{ |   |   |      |
{ |   |   |      | ADDITIONAL TEST HARNESS COMMANDS AND FUNCTIONS
{ |   |   |      | 1. The test harness commands and functions can be displayed
{ |   |   |      |    with the DISCLE command.  A list is shown below:
{ |   | * |   *  |    command (attach_file, attf)
{ |   | * |   *  |    command (change_catalog_entry, chace)
{ |   | * |   *  |    command (change_family_name, chafn)
{ |   | * |   *  |    command (change_file_attributes, change_file_attribute,
{ |   |   |      |             chafa)
{ |   | * |   *  |    command (compare_file, comf)
{ |   | * |   *  |    command (copy_file, copf)
{ |   | * |   *  |    command (create_catalog, crec)
{ |   | * |   *  |    command (create_catalog_permit, crecp)
{ |   | * |   *  |    command (create_file, cref)
{ |   | * |   *  |    command (create_file_permit, crefp)
{ |   | * |   *  |    command (delete_catalog, delc)
{ |   | * |   *  |    command (delete_catalog_permit, delcp)
{ |   | * |   *  |    command (delete_file, delf)
{ |   | * |   *  |    command (delete_file_permit, delfp)
{ |   | * |   *  |    command (detach_file, detach_files, detf)
{ |   | * |   *  |    command (display_catalog, disc)
{ |   | * |   *  |    command (display_catalog_entry, disce)
{ |   | * |   *  |    command (display_file_attributes, display_file_attribute,
{ |   |   |      |             disfa)
{ |   | * |   *  |    command (rewind_file, rewind_files, rewf)
{ |   | * |   *  |    command (set_file_attributes, set_file_attribute, setfa)
{ |   | * |   *  |    command (set_job_recovery_test, setjrt)
{ |   | * |   *  |    command (known_point, kp)
{ |   | * |      |    command (bap$task_termination_cleanup, task_termination)
{ |   | * |      |    command (job_exit)
{ |   | * |   *  |    command (define_master_catalog, defmc)
{ |   | * |   *  |    command (purge_master_catalog, purmc)
{ |   | * |   *  |    command (backup_permanent_files, backup_permanent_file,
{ |   |   |      |             bacpf)
{ |   | * |   *  |    command (restore_permanent_files, restore_permanent_file,
{ |   |   |      |             respf)
{ |   | * |   *  |    command recover_job_files
{ |   | * |   *  |    command recover_files
{ |   | * |   *  |    command (system_test_utility, systu)
{ |   | * |   *  |    command (set_administator_status, setas)
{ |   | * |      |    command (set_job_number, setjn)
{ |   | * |      |    command (set_task_number, settn)
{ |   | * |   *  |    command (set_user_id, setui)
{ |   | * |      |    command (quit, qui)
{ |   | * |   *  |    command (validate_catalog, valc)
{ |   | * |   *  |    function $file
{ |   | * |   *  |    function ($real_file_name, $rfn)
{ |   | * |  *   | 2. Test harness command known_point.
{ |   |   |      |    This command may be used to force a break to look at task
{ |   |   |      |    file tables or any of the job tables. When entering the
{ |   |   |      |    debugger do:
{ |   |   |      |      setb kp m=clm$test_harness p=known_point bo=xx(16)
{ |   |   |      |    When you desire to inspect a table do a set_job_number to
{ |   |   |      |    the current job, this will flush the tables to the
{ |   |   |      |    'multiple_job_table'.  You may then do kp and display the
{ |   |   |      |    table from the multiple job table.
{ |   | * |  *   | 3. Test harness command set_user_id.
{ |   |   |      |    Multiple users may be defined, to run under a different
{ |   |   |      |    user.  '$USER' however will always get your original user
{ |   |   |      |    name.  When you change user identification you should
{ |   |   |      |    probably also change jobs using set_job_number.  If you
{ |   |   |      |    don't do this you will inherit any authority for any
{ |   |   |      |    catalog in the queued catalog table.  This will make you
{ |   |   |      |    appear as owner for the original user as well as the
{ |   |   |      |    new user.
{ |   | * |      | 4. Test harness commands set_job_number and set_task_number.
{ |   |   |      |    Up to  5 jobs and tasks are supported, however they do
{ |   |   |      |    share the same heap.  Be careful - once a job is
{ |   |   |      |    terminated (via job_exit) or a task (via
{ |   |   |      |    bap$task_termination_cleanup) that job_number or
{ |   |   |      |    task_number should NOT be reused.
{
*DECK DECK=CLH$TEST_PARAMETER EXPAND=FALSE
{
{   The purpose  of this request is to test whether a particular parameter was
{ specified in the actual parameter list.
{
{       CLP$TEST_PARAMETER (PARAMETER_NAME, PARAMETER_SPECIFIED, STATUS)
{
{ PARAMETER_NAME: (input) This parameter specifies any one  of  the  parameter
{       names for the parameter in question.
{
{ PARAMETER_SPECIFIED:  (output)  This  parameter  specifies the result of the
{       test:
{       TRUE - the parameter was given,
{       FALSE - the parameter was not given.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$unexpected_call_to, cle$unknown_parameter_name
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$TEST_RANGE EXPAND=FALSE
{
{   The purpose of this request is to determine whether a particular value for
{ a particular parameter was given as a range.  If the requested value was not
{ given, then false is returned.
{
{       CLP$TEST_RANGE (PARAMETER_NAME, VALUE_SET_NUMBER, VALUE_NUMBER,
{         RANGE_SPECIFIED, STATUS)
{
{ PARAMETER_NAME: (input) This parameter specifies any one  of  the  parameter
{       names for the parameter in question.
{
{ VALUE_SET_NUMBER:   (input)  This  parameter  specifies  the  value  set  in
{       question.
{
{ VALUE_NUMBER: (input) This parameter specifies the value in question.
{
{ RANGE_SPECIFIED: (output) This parameter specifies the result of the test.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$unexpected_call_to, cle$unknown_parameter_name
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLH$TRIMMED_STRING_SIZE EXPAND=FALSE
{
{   The purpose  of  this  function  is  to  return  the size of a string once
{ trailing space characters have been removed from  it.   The  horizontal  tab
{ (HT)  in addition to the space are considered to be space characters by this
{ function.
{
{       CLP$TRIMMED_STRING_SIZE (STR): TRIMMED_STRING_SIZE
{
{ STR: (input) This parameter specifies the string for which the trimmed  size
{       is to be returned.
{
*DECK DECK=CLH$TURN_KEYPOINT_OFF EXPAND=FALSE

{
{   The purpose of this procedure is to process the 'KEYOFF' command.  Either
{ 'system' or 'job' keypoint recording and collecting are turned off.
{
{        CLP$TURN_KEYPOINT_OFF (COMMAND, CSTRING, STATUS);
{
{ COMMAND: (input) This parameter is the command name.
{
{ CSTRING: (input, output) This parameter is the command string passed to the
{        'HCS' command cracker.
{
{ STATUS: (output) This parameter is where the request status is returned to
{        the caller.
{
*DECK DECK=CLH$UTILITY_DIALOG_MANAGER EXPAND=FALSE
{
{   A utility dialog manager is a procedure called by the SCL interpreter on
{ behalf of a command utility that does not supply its own "interactive include
{ processor" for screen or desktop style interactions.
{
{   The first time a utility dialog manager is called within a utility it is
{ expected to establish tables of commands and functions to allow for user
{ customization of the screen/desktop environment for the utility.  These
{ commands and functions are in addition to those provided by the utility
{ itself.  It may obtain any additional information it needs about the utility
{ via the clp$get_utility_attributes request.  It should behave as if it were
{ an "interactive include processor" (see CLH$UTILITY_INTERACTIVE_INCLUDE for
{ more information).
{
{   It is possible for a utility dialog manager to called more than once within
{ a single utility session.  To support this situation and the ability of the
{ utility dialog manager to support activate_screen/deactivate_screen commands,
{ as well as providing a structured mechanism for cleaning up, the support
{ requests for a utility dialog manager provide for creation and deletion of a
{ scratrch segment for use by the utility dialog manager.
{
{       utility_dialog_manager (UTILITY, DIALOG_INFO, STATUS)
{
{ UTILITY: (input)  This parameter specifies the name of the utility for which
{       the utility dialog manager is called.
{
{ DIALOG_INFO: (input)  This parameter specifies the information established
{       for the utility dialog.  It includes a pointer to a table of commands,
{       a pointer to a table of functions, and a pointer to a SEQuence
{       designating a scratch segment.  If a pointer is NIL, the corresponding
{       item has not been established for the dialog manager, hence all of the
{       pointers are NIL on the first call to the utility dialog manager within
{       a utility session.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$UTILITY_INTERACTIVE_INCLUDE EXPAND=FALSE
{
{   A command utility may choose to be given control each time an include file
{ command or request that references an interactive (terminal) file is issued
{ on behalf of the utility.  This gives the utility the opportunity to switch
{ to "screen mode" processing automatically at the appropriate point in time.
{
{   When control is returned from the "interactive include processor", further
{ processing is determined as follows:
{
{   1.  If the returned status is abnormal, the include file command or request
{       terminates with that status.
{
{   2.  If the utility's termination command has been executed, the include
{       file command or request terminates with normal status.
{
{   3.  Otherwise, processing of commands from the interactive file takes place
{       as if there had been no "interactive include processor".
{
{
{       interactive_line_processor (INTERACTION_STYLE, STATUS)
{
{ INTERACTION_STYLE: (input)  This parameter specfies the user selected
{       interaction style at the point at which the include file command or
{       request was issued.
{
{ STATUS: (output)  This parameter specifies the interactive include
{       processor's termination status.
{
*DECK DECK=CLH$UTILITY_LINE_PREPROCESSOR EXPAND=FALSE
{
{   A command utility may choose to be given control each time a command line
{ is read.  This "hook" is provided for those utilities whose input is not
{ completely compatible with SCL.  Such incompatibility may result from a need
{ to meet an industry standard or retain compatibility with a predecessor
{ product.  Also, a utility may simply wish to be notified that a command line
{ has been read; for example, a line boundary may be a convenient point to
{ which to back up for a utility that supports an "undo" feature.
{
{   This capability allows a utility to use SCL facilities for reading
{ commands when that would otherwise not be possible.  Also, users of such a
{ utility may still be able to make use of SCL's programming language
{ facilities in conjunction with the utility.
{
{       utility_line_preprocessor (COMMAND_LINE, INTERACTIVE_SOURCE,
{         INTERPRETING_COMMANDS, EDITED_COMMAND_LINE, STATUS)
{
{ COMMAND_LINE: (input)  This parameter specifies the command line read by the
{       SCL interpreter.
{
{ INTERACTIVE_SOURCE: (input)  This parameter specfies whether the command
{       line originated from an interactive terminal (TRUE) or not (FALSE).
{
{ INTERPRETING_COMMANDS: (input)  This parameter specifies whether the SCL
{       interpreter would interpret (TRUE) the next command or skip it
{       (FALSE).  Skip mode is entered as a result of various control
{       statements, for example IF, ELSE, etc.  If the utility processes the
{       commands in the command line itself, it should only do so when this
{       parameter is TRUE.
{
{ EDITED_COMMAND_LINE: (output)  This parameter specifies the string that
{       represents the preprocessed command line.  (Upon entry to the line
{       preprocessor, the edited_command_line variable is NIL.) The
{       preprocessor may construct a new line in any manner it chooses and set
{       this parameter to point to it.  If this parameter is NIL upon return
{       to the SCL interpreter, the original command line is processed.  If
{       this parameter points to a null (empty) string, the SCL interpreter
{       will do no further processing with this line.
{
{ STATUS:   (output)   This   parameter   specifies  the  line  preprocessor's
{       termination status.
{
*DECK DECK=CLH$VALIDATE_LOCAL_FILE_NAME EXPAND=FALSE
{
{   The purpose of this procedure is to validate that a  string  represents  a
{ syntactically  valid  local  file name.  Further, it checks whether the name
{ has the form of a path handle name and if so  it  returns  the  path  handle
{ represented by the name.
{
{       CLP$VALIDATE_LOCAL_FILE_NAME (POTENTIAL_NAME, LOCAL_FILE_NAME,
{         PATH_HANDLE, NAME_IS_PATH_HANDLE, NAME_IS_VALID)
{
{ POTENTIAL_NAME: (input) This parameter specifies the name to be validated.
{
{ LOCAL_FILE_NAME:  (output) This parameter specifies the validated local file
{       name.  Any lower case letters in the POTENTIAL_NAME are  converted  to
{       their uppercase counterparts.
{
{ PATH_HANDLE:   (output)   This   parameter   is   meaningful   only  if  the
{       NAME_IS_PATH_HANDLE parameter is TRUE.  In that case this parameter is
{       set to the path handle derived from the name.
{
{ NAME_IS_PATH_HANDLE:  (output)  This  parameter  specifies  whether the name
{       designated a path handle.
{
{ NAME_IS_VALID: (output) This parameter specifies whether the  POTENTIAL_NAME
{       was a syntactically correct local file name.  If this parameter is set
{       to FALSE none of the other output parameters  of  this  procedure  are
{       meaningful.
{
*DECK DECK=CLH$VALIDATE_NAME EXPAND=FALSE
{
{   The purpose of this request is to validate a name as an SCL name.
{
{       CLP$VALIDATE_NAME (POTENTIAL_NAME, VALIDATED_NAME, NAME_IS_VALID)
{
{ POTENTIAL_NAME: (input)  This parameter specifies the name to be validated.
{
{ VALIDATED_NAME: (output)  This parameter specifies the validated SCL name.
{       Lowercase letters are converted to uppercase.
{
{ NAME_IS_VALID: (output)  This parameter specifies whether the potential name
{       is a valid SCL name.
{
*DECK DECK=CLH$VALUE_KIND_SPECIFIER EXPAND=FALSE
{
{   A Value  Kind Specifier (VKS) is used to specify to the expression scanner
{ the desired kind of result for the expression.  Thus, a VKS is an  important
{ component  of  each parameter descriptor in a command's parameter descriptor
{ table (PDT).
{
{   A VKS can specify that a value be specified as either  a  particular  kind
{ (with qualifying information for certain kinds) and/or a "keyword value".
{
{   The fields of a value kind specifier are defined as:
{
{   KEYWORD_VALUES: specifies  an  array of "keyword values" allowed as result
{ values.  IF this field is NIL there are no keyword values for the result.
{
{   KIND: specifies the kind of result  allowed.   Certain  value  kinds  have
{ special interpretations or additional qualifying information as follows:
{
{       clc$keyword_value:  specifies that only keyword values are allowed for
{             the result.
{
{       clc$any_value: specifies that any kind of value  is  allowed  for  the
{             result.
{
{       clc$variable_reference:  specifies that the result must be a reference
{             to a previously declared variable.
{
{             ARRAY_ALLOWED: specifies whether an array reference is  allowed.
{
{             VARIABLE_KIND: specifies  the  kind  of  variable  desired.   If
{                   clc$any_value  is  given  for  this  field,  any  kind  of
{                   variable is allowed.
{
{       clc$application_value:  specifies  that  the  "expression"  is  to  be
{             scanned  by  a procedure supplied by the application rather than
{             the standard expression scanner supplied by SCL.
{
{             VALUE_NAME: specifies a name for the application value that  can
{                   be placed in the descriptor field of a clt$value, returned
{                   as  the  value  of  the  $value_kind  function,  used   in
{                   messages, etc.
{
{             SCANNER:  specifies  the  procedure  that  scans the application
{                   value.
{
{                   KIND: specifies  how  the  application  value  scanner  is
{                         located as follows:
{
{                         clc$unspecified_av_scanner:    specifies   that   no
{                               scanner has been supplied  and  that  the  SCL
{                               interpreter should store the application value
{                               in the sequence as an ost$string.  This option
{                               permits the definition of an application value
{                               parameter on, for example, an SCL PROC without
{                               the  need  for  the PROC writer to be aware of
{                               what  procedure   is   responsible   for   the
{                               evaluation of this particular kind of value.
{
{                         clc$linked_av_scanner:  specifies  that a pointer to
{                               the scanning procedure has been supplied.
{
{                               PROC: specifies the pointer to the application
{                                     value scanner.
{
{                         clc$unlinked_av_scanner: specifies that the scanning
{                               procedure must be  loaded  before  it  can  be
{                               called.
{
{                               NAME: specifies  the  name  of the application
{                                     value scanner procedure.
{
{       clc$file_value: specifies that the result must be a <file|catalog>.
{
{       clc$name_value: specifies that the result must be a name.
{
{             MIN_NAME_SIZE: specifies the minimum number of characters  there
{                   must be in the result name.
{
{             MAX_NAME_SIZE:  specifies the maximum number of characters there
{                   may be in the result name.
{
{       clc$string_value: specifies that the result must be a string.
{
{             MIN_STRING_SIZE: specifies  the  minimum  number  of  characters
{                   there must be in the result string.
{
{             MAX_STRING_SIZE:  specifies  the  maximum  number  of characters
{                   there may be in the result string.
{
{       clc$integer_value: specifies that the result must be an integer.
{
{             MIN_INTEGER_VALUE: specifies the minimum value of the result.
{
{             MAX_INTEGER_VALUE: specifies the maximum value of the result.
{
{       clc$real_value: specifies that the result must be a real number.
{
{       clc$boolean_value: specifies that the result must be a boolean.
{
{       clc$status_value: specifies that the result must be an ost$status.
{
*DECK DECK=CLH$VERIFY_TIME_INCREMENT EXPAND=FALSE
{
{    The purpose of this request is to verify that all the components of a
{ PMT$TIME_INCREMENT record are within range since values that are too large
{ result in excessive computations.
{
{       CLP$VERIFY_TIME_INCREMENT (TIME_INCREMENT, STATUS)
{
{ TIME_INCREMENT: (input)  This parameter specifies the time increment value
{       that is to be verified.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$invalid_time_increment
{
*DECK DECK=CLH$VERTICAL_TAB_DISPLAY EXPAND=FALSE
{
{   The purpose of this request is to write sufficient empty lines to the
{ display such that the next line of data written to the display will appear on
{ the specified line of the page.  If data has already been written at or
{ beyond the specified line, clp$new_display_page is called prior to performing
{ this operation.
{
{   The most common use for this request is to place "footers" at the bottom of
{ display pages.  This requires that the PAGE_LENGTH field of the
{ DISPLAY_CONTROL variable be temporarily decremented by the number of lines
{ for the footer.  In a new_page_procedure, the original value of the
{ PAGE_LENGTH field is restored, clp$vertical_tab_display is called to "get to"
{ the first line for the footer, the footer is written, and the PAGE_LENGTH
{ field of the DISPLAY_CONTROL is again decremented.  The new_page_procedure
{ then calls clp$reset_for_next_display_page, and writes "header" (title) lines
{ on the top of the next page.
{
{       CLP$VERTICAL_TAB_DISPLAY (DISPLAY_CONTROL, LINE_NUMBER, STATUS)
{
{ DISPLAY_CONTROL: (input, output)  This parameter specifies the
{       display_control variable initialized when the display was opened.
{
{ LINE_NUMBER: (input)  This parameter specifies the number of the line to
{       which to tab.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CLH$WILD_CARD_FILE_EXPANSION EXPAND=FALSE
{
{   The CLP$WILD_CARD_FILE_EXPANSION request expands a file reference
{ containing "wild card" characters and/or the special path element $ALL into
{ an SCL "list of file" value.  Pointers to both the first (head) and last
{ (tail) elements of the result list are returned to facilitate joining the
{ result list with other lists.
{
{       CLP$WILD_CARD_FILE_EXPANSION (EVALUATED_FILE_REFERENCE,
{         EXPANSION_OPTION, WORK_AREA, RESULT_LIST_HEAD, RESULT_LIST_TAIL,
{         STATUS)
{
{ EVALUATED_FILE_REFERENCE: (input)  This parameter specifies the file
{       reference to be expanded.
{
{ EXPANSION_OPTION: (input)  This parameter specifies whether only files, only
{       catalogs, or both files and catalogs, are to be included in the
{       resulting list of file.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the result list.  The current position of
{       this sequence pointer is updated to reflect the amount of storage used
{       by the request.  The result list is completely contained within the
{       used part of this sequence.
{
{ RESULT_LIST_HEAD: (output)  This parameter specifies the first node of the
{       resulting list of file.
{
{ RESULT_LIST_TAIL: (output)  This parameter specifies the last node of the
{       resulting list of file.
{
{ STATUS: (output) This parameter specifies the request completion status.
{
{       CONDITIONS: cle$no_match_for_wild_card_file
{                   cle$wild_card_cant_be_first
{                   cle$work_area_overflow
{
*DECK DECK=CLH$WRITE_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to write the value of a variable or part of
{ a variable.  Only variables in the current block may be written.
{
{       CLP$WRITE_VARIABLE (REFERENCE, VALUE, STATUS)
{
{ REFERENCE: (input) This parameter specifies the variable or element or field
{       of  a variable to be written.  The parameter is given in the syntax of
{       an SCL variable reference except that if a subscript is  part  of  the
{       reference  it  must  be  given  as  an  integer constant and not as an
{       expression.
{
{ VALUE: (input) This parameter specifies the value  to  be  assigned  to  the
{       variable.  (The descriptor field of this parameter is ignored.)
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: cle$improper_variable_reference,
{             cle$improper_variable_value, cle$unknown_variable.
{       IDENTIFIER: 'CL'
{
*DECK DECK=CLI$COMPARE_DISPLAY_FILE_INPUT EXPAND=FALSE
?? TITLE := 'COMPARE_ and DISPLAY_FILE Input Procedures', EJECT ??
{
{ PURPOSE: The purpose of this "module" is to provide common input
{          procedures for the processors of the commands COMPARE_FILE
{          and DISPLAY_FILE. These procedures attempt to minimize input
{          data transfers for the commands.
{
{ NOTES:
{          1. This "module" is to be COPYed into each command processor.
{          2. For a mass storage file, the file is opened for segment
{             access and input requests result in the return of a
{             pointer to the requested data.
{          3. For a non-mass storage file, a buffer (which must be
{             PUSHed by the calling command processor) is used. Except
{             for having to establish the buffer after OPEN time, the
{             calling processor is unaware of the type of input file.
{          4. Reading of data from a particular byte address (other than
{             the current) is a result of the user specifying a byte
{             address in the call to DISPLAY_FILE. In such a case, the
{             byte address ia always relative to BOI of the file.
{          5. Information concerning the input file is maintained in a
{             variable of type clt$get_control_record.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc amp$fetch_access_information
*copyc amp$get_next
*copyc amp$get_segment_pointer
*copyc amp$rewind
*copyc amp$set_segment_position
*copyc fsp$close_file
*copyc fsp$open_file
*copyc i#current_sequence_position
*copyc osp$append_status_file
*copyc rmp$get_device_class
?? EJECT ??

  CONST
    clc$input_buffer_size = 8192;

  TYPE
    clt$get_control_record = record
      access_level: amt$access_level,
      file_id: amt$file_identifier,
      sequence_pointer: ^SEQ ( * ),
      sequence_size: amt$file_byte_address,
      bytes_remaining: amt$file_byte_address,
      file_position: amt$file_position,
      buffer_first_byte_address: integer,
      buffer_last_byte_address: integer,
      get_next_returned_eoi: boolean,
    recend;

?? TITLE := 'clp$open_for_get', EJECT ??

  PROCEDURE clp$open_for_get
    (    file: fst$file_reference;
         command_name: string ( * <= osc$max_name_size);
         byte_address_specified: boolean;
     VAR file_position: amt$file_position;
     VAR get_control: clt$get_control_record;
     VAR buffer_required: boolean;
     VAR status: ost$status);

    VAR
      file_attachment: array [1 .. 3] of fst$attachment_option,
      device_assigned: boolean,
      device_class: rmt$device_class,
      fetch_access_selections: array [1 .. 1] of amt$access_info,
      attribute_override: array [1 .. 3] of fst$file_cycle_attribute,
      file_organization_selector: [STATIC, READ,
            oss$job_paged_literal] array [boolean] of
            amt$file_organization := [amc$sequential, amc$byte_addressable],
      ignore_status: ost$status,
      segment_pointer: amt$segment_pointer;


    status.normal := TRUE;

    file_attachment [1].selector := fsc$access_and_share_modes;
    file_attachment [1].access_modes.selector := fsc$specific_access_modes;
    file_attachment [1].access_modes.value :=
          $fst$file_access_options [fsc$read];
    file_attachment [1].share_modes.selector := fsc$specific_share_modes;
    file_attachment [1].share_modes.value := $fst$file_access_options
          [fsc$read, fsc$execute];
    file_attachment [2].selector := fsc$open_share_modes;
    file_attachment [2].open_share_modes := $fst$file_access_options
          [fsc$read, fsc$execute];
    file_attachment [3].selector := fsc$create_file;
    file_attachment [3].create_file := FALSE;

    attribute_override [1].selector := fsc$block_type;
    attribute_override [1].block_type := amc$system_specified;
    attribute_override [2].selector := fsc$record_type;
    attribute_override [2].record_type := amc$undefined;
    attribute_override [3].selector := fsc$file_organization;

    rmp$get_device_class (file, device_assigned, device_class,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF device_class = rmc$mass_storage_device THEN
      get_control.access_level := amc$segment;
      attribute_override [3].file_organization :=
            file_organization_selector [byte_address_specified];
    ELSE
      get_control.access_level := amc$record;
      attribute_override [3].file_organization := amc$sequential;
    IFEND;

    fsp$open_file (file, get_control.access_level, ^file_attachment,
          NIL, NIL, NIL, ^attribute_override, get_control.file_id, status);
    IF NOT status.normal THEN
      IF status.condition = ame$new_file_requires_append THEN
        osp$set_status_abnormal ('CL', cle$file_never_opened, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, file, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              command_name, status);
      IFEND;
      RETURN;
    IFEND;

    fetch_access_selections [1].key := amc$file_position;
    amp$fetch_access_information (get_control.file_id, fetch_access_selections,
          status);
    IF NOT status.normal THEN
      fsp$close_file (get_control.file_id, ignore_status);
      RETURN;
    IFEND;
    IF fetch_access_selections [1].item_returned THEN
      file_position := fetch_access_selections [1].file_position;
    ELSE
      file_position := amc$boi;
    IFEND;

    IF get_control.access_level = amc$record THEN
      buffer_required := TRUE;
      get_control.sequence_size := clc$input_buffer_size;
      get_control.bytes_remaining := 0;
      IF byte_address_specified AND (file_position <> amc$boi) THEN
        amp$rewind (get_control.file_id, osc$wait, status);
        IF NOT status.normal THEN
          fsp$close_file (get_control.file_id, ignore_status);
          RETURN;
        IFEND;
        file_position := amc$boi;
      IFEND;
      get_control.buffer_first_byte_address := -1;
      get_control.buffer_last_byte_address := -1;

    ELSE {access_level = amc$segment
      amp$get_segment_pointer (get_control.file_id, amc$sequence_pointer,
            segment_pointer, status);
      IF status.normal THEN
        get_control.sequence_pointer := segment_pointer.sequence_pointer;
        IF byte_address_specified THEN
          RESET get_control.sequence_pointer;
        IFEND;
        get_control.bytes_remaining := #SIZE (get_control.sequence_pointer^) -
              i#current_sequence_position (get_control.sequence_pointer);
      ELSEIF status.condition = ame$read_of_empty_segment THEN
        status.normal := TRUE;
        get_control.sequence_pointer := NIL;
        get_control.bytes_remaining := 0;
      ELSE
        fsp$close_file (get_control.file_id, ignore_status);
        RETURN;
      IFEND;
      buffer_required := FALSE;
    IFEND;

    get_control.file_position := file_position;
    get_control.get_next_returned_eoi := FALSE;

  PROCEND clp$open_for_get;
?? TITLE := 'clp$get_next_bytes', EJECT ??

  PROCEDURE clp$get_next_bytes
    (    bytes_requested: amt$file_byte_address;
     VAR transfer_count: amt$transfer_count;
     VAR file_position: amt$file_position;
     VAR get_control: clt$get_control_record;
     VAR byte_pointer_returned: ^cell;
     VAR status: ost$status);

    VAR
      byte_pointer: ^array [1 .. * ] of cell,
      byte_address_ignored: amt$file_byte_address,
      index: amt$file_byte_address,
      temp_byte_pointer: ^array [1 .. * ] of cell;

{  Check first to see if data remain.  There are 2 cases:
{
{  1. segment_access - in this case get_control.bytes_remaining describes
{     the number of bytes left in the segment.
{
{  2. record_access - in this case get_control.bytes_remaining describes
{     the number of bytes left in the buffer from the last amp$get_next.

    status.normal := TRUE;
    IF (get_control.bytes_remaining <= 0) AND
          ((get_control.access_level = amc$segment) OR
          get_control.get_next_returned_eoi) THEN
      transfer_count := 0;
      file_position := amc$eoi;
      RETURN;
    ELSE
      file_position := amc$eor;
    IFEND;

    IF get_control.access_level = amc$record THEN
      IF (get_control.bytes_remaining < bytes_requested) AND
            (NOT get_control.get_next_returned_eoi) THEN

        IF get_control.bytes_remaining > 0 THEN
          NEXT temp_byte_pointer: [1 .. get_control.bytes_remaining] IN
                get_control.sequence_pointer;
          RESET get_control.sequence_pointer;
          NEXT byte_pointer: [1 .. get_control.bytes_remaining] IN
                get_control.sequence_pointer;
          FOR index := 1 TO get_control.bytes_remaining DO
            byte_pointer^ [index] := temp_byte_pointer^ [index];
          FOREND;
        ELSE
          RESET get_control.sequence_pointer;
        IFEND;
        NEXT temp_byte_pointer: [1 .. 1] IN get_control.sequence_pointer;

        amp$get_next (get_control.file_id, temp_byte_pointer,
              get_control.sequence_size - get_control.bytes_remaining,
              transfer_count, byte_address_ignored, get_control.file_position,
              status);
        IF NOT status.normal THEN
          IF status.condition = ame$input_after_eoi THEN
            transfer_count := 0;
            file_position := amc$eoi;
            get_control.file_position := amc$eoi;
            get_control.get_next_returned_eoi := TRUE;
            status.normal := TRUE;
          IFEND;
          RETURN;
        IFEND;
        get_control.get_next_returned_eoi := get_control.file_position = amc$eoi;

        get_control.bytes_remaining := get_control.bytes_remaining +
              transfer_count;
        RESET get_control.sequence_pointer;
        get_control.buffer_first_byte_address :=
              get_control.buffer_last_byte_address + 1;
        get_control.buffer_last_byte_address :=
              get_control.buffer_first_byte_address + transfer_count - 1;
      IFEND;

    ELSE {access_level = amc$segment
      IF get_control.bytes_remaining <= bytes_requested THEN
        get_control.file_position := amc$eoi;
      IFEND;
    IFEND;

    IF get_control.bytes_remaining > bytes_requested THEN
      transfer_count := bytes_requested;
    ELSE
      transfer_count := get_control.bytes_remaining;
    IFEND;

    IF transfer_count <= 0 THEN
      file_position := amc$eoi;
      RETURN;
    IFEND;

    NEXT byte_pointer: [1 .. transfer_count] IN get_control.sequence_pointer;
    byte_pointer_returned := byte_pointer;

    get_control.bytes_remaining := get_control.bytes_remaining -
          transfer_count;

  PROCEND clp$get_next_bytes;
?? TITLE := 'clp$close_for_get', EJECT ??

  PROCEDURE clp$close_for_get
    (VAR get_control: clt$get_control_record;
     VAR status: ost$status);

    VAR
      segment_pointer: amt$segment_pointer;


    status.normal := TRUE;

    IF (get_control.access_level = amc$segment) AND
          (get_control.sequence_pointer <> NIL) THEN
      segment_pointer.kind := amc$sequence_pointer;
      segment_pointer.sequence_pointer := get_control.sequence_pointer;
      amp$set_segment_position (get_control.file_id, segment_pointer, status);
    IFEND;

    fsp$close_file (get_control.file_id, status);

  PROCEND clp$close_for_get;
?? TITLE := 'clp$seek_byte', EJECT ??

  PROCEDURE clp$seek_byte
    (    byte_address: amt$file_byte_address;
     VAR get_control: clt$get_control_record;
     VAR status: ost$status);

    VAR
      file_position: amt$file_position,
      ignore_byte_pointer: ^cell,
      number_to_skip: amt$file_byte_address,
      positioner: ^array [1 .. * ] of cell,
      transfer_count: amt$transfer_count;


    status.normal := TRUE;

    IF get_control.access_level = amc$segment THEN
      IF byte_address > #SIZE (get_control.sequence_pointer^) THEN
        osp$set_status_abnormal ('CL', cle$integer_too_large, 'BYTE_ADDRESS',
              status);
        RETURN;
      IFEND;
      RESET get_control.sequence_pointer;
      IF byte_address > 0 THEN
        NEXT positioner: [1 .. byte_address] IN get_control.sequence_pointer;
      IFEND;
      get_control.bytes_remaining := #SIZE (get_control.sequence_pointer^) -
            byte_address;
      RETURN;
    IFEND;

    IF (get_control.buffer_last_byte_address < 0) AND
          (get_control.bytes_remaining = 0) THEN
      clp$get_next_bytes (1, transfer_count, file_position, get_control,
            ignore_byte_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF byte_address < get_control.buffer_first_byte_address THEN
      amp$rewind (get_control.file_id, osc$wait, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      get_control.file_position := amc$boi;
      number_to_skip := byte_address;
      get_control.buffer_first_byte_address := -1;
      get_control.buffer_last_byte_address := -1;
      get_control.bytes_remaining := 0;

    ELSEIF byte_address > get_control.buffer_last_byte_address THEN
      number_to_skip := byte_address - get_control.buffer_last_byte_address -
            1;
      get_control.bytes_remaining := 0;

    ELSE {byte address within current buffer}
      number_to_skip := byte_address - get_control.buffer_first_byte_address;
      RESET get_control.sequence_pointer;
      IF number_to_skip > 0 THEN
        NEXT positioner: [1 .. number_to_skip] IN get_control.sequence_pointer;
      IFEND;
      get_control.bytes_remaining := get_control.buffer_last_byte_address -
            byte_address + 1;
      RETURN;
    IFEND;

    WHILE number_to_skip >= clc$input_buffer_size DO
      clp$get_next_bytes (clc$input_buffer_size, transfer_count, file_position,
            get_control, ignore_byte_pointer, status);
      IF NOT status.normal OR (file_position = amc$eoi) THEN
        RETURN;
      IFEND;
      number_to_skip := number_to_skip - transfer_count;
    WHILEND;

    IF number_to_skip > 0 THEN
      clp$get_next_bytes (number_to_skip, transfer_count, file_position,
            get_control, ignore_byte_pointer, status);
    IFEND;

  PROCEND clp$seek_byte;
?? OLDTITLE ??
*DECK DECK=CLI$FIND_VAR_BLOCK EXPAND=FALSE

    WHILE current_block <> NIL DO
      IF (inherited_input_block <> NIL) AND (#OFFSET (inherited_input_block) = #OFFSET (current_block)) AND
            NOT associated_utility THEN
        allowed_classes := inherited_input_allowed_classes;
        inherited_input_block := NIL;
      IFEND;

      CASE current_block^.kind OF

      = clc$command_proc_block, clc$function_proc_block, clc$utility_block, clc$when_block =
        RETURN;

      = clc$input_block =
        IF current_block^.input.internal THEN
          ;
        ELSEIF current_block^.inherited_input.found AND (inherited_input_block = NIL) THEN
          inherited_input_block := current_block^.inherited_input.block;
          inherited_input_allowed_classes := allowed_classes;
        ELSEIF (current_block^.associated_utility <> NIL) AND (inherited_input_block = NIL) AND
              current_block^.associated_utility^.command_environment.command_level THEN
          inherited_input_block := current_block^.associated_utility;
          associated_utility := TRUE;
        IFEND;

      = clc$task_block =
        IF (NOT current_block^.synchronous_with_parent) OR
              (current_block^.task_kind = clc$task_statement_task) THEN
          RETURN;
        IFEND;

      ELSE
        ;
      CASEND;

      IF current_block^.static_link <> NIL THEN
        current_block := current_block^.static_link;
      ELSE
        current_block := current_block^.previous_block;
      IFEND;
    WHILEND;
*DECK DECK=CLI$INPUT_PROCEDURES EXPAND=FALSE
?? TITLE := 'cli$input_procedures' ??
?? NEWTITLE := 'cli$Input_procedures "global" declarations', EJECT ??
{
{ PURPOSE:
{   The purpose of this "module" is to provide a procedure of the type
{   clt$internal_input_procedure.  It is expected that this "module" will be
{   *COPYed into the module of the caller.
{
{ NOTES:
{   . clp$ip_initialize must be called before clp$input_procedure is called.
{
{   . Names of global variables and procedures in this "module" follow the
{     standard naming conventions with IP_ appended to the $ (with the
{     exception of clp$input_procedure).
{

?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc amt$file_identifier
*IFEND
*copyc clc$lexical_units_size_pad
*copyc clc$max_command_line_size
*copyc cle$ecc_line_length
*copyc clt$command_line
*copyc clt$command_line_size
*IF NOT $true(osv$unix)
*copyc fst$file_reference
*IFEND
?? POP ??
*IF NOT $true(osv$unix)
*copyc amp$fetch
*copyc amp$get_next
*copyc amp$get_partial
*copyc clp$determine_line_layout
*ELSE
*copyc amp_get_next
*IFEND
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*IF NOT $true(osv$unix)
*copyc clp$layout_data_line
*copyc osp$append_status_file
*IFEND
*copyc osp$set_status_abnormal

  VAR
    clv$ip: [STATIC] record
      capture_command_line: ^procedure (    line: ^clt$command_line;
                                            lexical_units: ^clt$lexical_units),
      capture_data_line: ^procedure (    line: ^clt$command_line),
*IF NOT $true(osv$unix)
      file_id: amt$file_identifier,
*IFEND
      file_name: ^fst$file_reference,
*IF NOT $true(osv$unix)
      file_position: ^amt$file_position,
*IFEND
      lexical_work_area: ^clt$work_area,
*IF NOT $true(osv$unix)
      line_identifier: clt$line_identifier,
      line_layout: clt$line_layout,
*IFEND
      line: ^string (clc$max_command_line_size),
    recend;

?? TITLE := 'clp$ip_initialize', EJECT ??

  PROCEDURE clp$ip_initialize
    (    input_file_name: fst$file_reference;
*IF NOT $true(osv$unix)
         input_file_id: amt$file_identifier;
         input_file_position: ^amt$file_position;
*IFEND
         capture_command_line: ^procedure
           (    line: ^clt$command_line;
                lexical_units: ^clt$lexical_units);
         capture_data_line: ^procedure (    line: ^clt$command_line);
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
    VAR
      dummy_file_name: amt$local_file_name,
      file_attributes: array [1 .. 4] of amt$fetch_item;
*IFEND


    status.normal := TRUE;
    clv$ip.capture_command_line := capture_command_line;
    clv$ip.capture_data_line := capture_data_line;
*IF NOT $true(osv$unix)
    clv$ip.file_id := input_file_id;
*IFEND
    NEXT clv$ip.file_name: [STRLENGTH (input_file_name)] IN work_area;
    clv$ip.file_name^ := input_file_name;
*IF NOT $true(osv$unix)
    clv$ip.file_position := input_file_position;
*IFEND
    NEXT clv$ip.lexical_work_area: [[REP clc$max_command_line_size +
          clc$lexical_units_size_pad OF clt$lexical_unit]] IN work_area;
    NEXT clv$ip.line IN work_area;

*IF NOT $true(osv$unix)
    file_attributes [1].key := amc$record_type;
    file_attributes [2].key := amc$max_record_length;
    file_attributes [2].max_record_length := 256;
    file_attributes [3].key := amc$line_number;
    file_attributes [4].key := amc$statement_identifier;
    amp$fetch (clv$ip.file_id, file_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dummy_file_name := clv$ip.file_name^;
    clp$determine_line_layout (dummy_file_name,
          file_attributes [1].record_type, file_attributes [2].
          max_record_length, file_attributes [3].source <>
          amc$undefined_attribute, file_attributes [3].line_number,
          file_attributes [4].source <> amc$undefined_attribute,
          file_attributes [4].statement_identifier, clv$ip.line_layout,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clv$ip.line_identifier.record_number := 0;
*IFEND

  PROCEND clp$ip_initialize;
?? TITLE := 'clp$input_procedure', EJECT ??

  PROCEDURE clp$input_procedure
    (VAR parse: clt$parse_state;
     VAR end_of_input: boolean;
     VAR status: ost$status);

    VAR
      lexical_units: ^clt$lexical_units,
      line: ^clt$command_line,
      line_size: clt$command_line_size;


    clp$ip_get_command_line (clv$ip.line^, line_size, end_of_input, status);
    IF (NOT status.normal) OR end_of_input THEN
      RETURN;
    IFEND;

    line := ^clv$ip.line^ (1, line_size);
    RESET clv$ip.lexical_work_area;
    clp$identify_lexical_units (line, clv$ip.lexical_work_area, lexical_units,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$initialize_parse_state (line, lexical_units, parse);

    IF clv$ip.capture_command_line <> NIL THEN
      clv$ip.capture_command_line^ (line, lexical_units);
    IFEND;

  PROCEND clp$input_procedure;
?? TITLE := 'clp$ip_get_command_line', EJECT ??

  PROCEDURE clp$ip_get_command_line
    (VAR line: clt$command_line;
     VAR line_size: clt$command_line_size;
     VAR end_of_input: boolean;
     VAR status: ost$status);

    VAR
      line_continued: boolean,
      continuation_line_size: clt$command_line_size,
      continuation_line: ^clt$command_line;


    clp$ip_get_data_line (line, line_size, end_of_input, status);
    IF (NOT status.normal) OR end_of_input THEN
      RETURN;
    IFEND;

    IF (line_size >= 2) AND (line (line_size - 1, 2) = '..') THEN
      line_size := line_size - 2;
      WHILE (line_size > 0) AND (line (line_size) = '.') DO
        line_size := line_size - 1;
      WHILEND;
      PUSH continuation_line: [clc$max_command_line_size];
      REPEAT
        clp$ip_get_data_line (continuation_line^, continuation_line_size,
              end_of_input, status);
        IF NOT status.normal THEN
          RETURN;
        ELSEIF end_of_input THEN
          osp$set_status_abnormal ('CL', cle$expecting_continuation_line, '',
                status);
          RETURN;
        IFEND;
        line_continued := (continuation_line_size >= 2) AND
              (continuation_line^ (continuation_line_size - 1, 2) = '..');
        IF line_continued THEN
          continuation_line_size := continuation_line_size - 2;
          WHILE (continuation_line_size > 0) AND
                (continuation_line^ (continuation_line_size) = '.') DO
            continuation_line_size := continuation_line_size - 1;
          WHILEND;
        IFEND;
        IF (line_size + continuation_line_size) >
              clc$max_command_line_size THEN
          osp$set_status_abnormal ('CL', cle$continued_line_too_long, '',
                status);
          RETURN;
        IFEND;
        line (line_size + 1, continuation_line_size) :=
              continuation_line^ (1, continuation_line_size);
        line_size := line_size + continuation_line_size;
      UNTIL NOT line_continued;
    IFEND;

  PROCEND clp$ip_get_command_line;
?? TITLE := 'clp$ip_get_data_line', EJECT ??

  PROCEDURE clp$ip_get_data_line
    (VAR line: clt$command_line;
     VAR line_size: clt$command_line_size;
     VAR end_of_input: boolean;
     VAR status: ost$status);

    VAR
      dummy_file_name: amt$local_file_name,
      line_area: ^SEQ ( * ),
      next_line_area: ^cell,
*IF NOT $true(osv$unix)
      nominal_line: ^array [1 .. clc$nominal_command_line_size] of cell,
      first_part_of_line: ^array [1 .. clc$nominal_command_line_size] of cell,
      ignore_byte_address: amt$file_byte_address,
      transfer_count: amt$transfer_count,
      record_length: amt$max_record_length,
*ELSE
      get_line: string (256),
      get_length: integer,
      stat: integer,
*IFEND
      line_value: ^clt$command_line;


    status.normal := TRUE;
    end_of_input := TRUE;
    line_size := 0;

*IF NOT $true(osv$unix)
    PUSH line_area: [[REP clc$nominal_command_line_size OF char]];
    clv$ip.line_identifier.byte_address := 0;
    amp$get_next (clv$ip.file_id, line_area, clc$nominal_command_line_size,
          transfer_count, clv$ip.line_identifier.byte_address,
          clv$ip.file_position^, status);
    IF status.normal AND (clv$ip.file_position^ < amc$eor) AND
          (clv$ip.line_layout.physical_line_size >
          clc$nominal_command_line_size) THEN
      RESET line_area;
      NEXT nominal_line IN line_area;
      PUSH line_area: [[REP clv$ip.line_layout.physical_line_size OF char]];
      RESET line_area;
      NEXT first_part_of_line IN line_area;
      first_part_of_line := nominal_line;
      NEXT next_line_area IN line_area;
      record_length := clc$nominal_command_line_size;
      amp$get_partial (clv$ip.file_id, next_line_area,
            clv$ip.line_layout.physical_line_size -
            clc$nominal_command_line_size, record_length, transfer_count,
            ignore_byte_address, clv$ip.file_position^, amc$no_skip, status);
      transfer_count := record_length;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    ELSEIF clv$ip.file_position^ < amc$eor THEN
      osp$set_status_abnormal ('CL', cle$line_too_long, '', status);
      osp$append_status_file (osc$status_parameter_delimiter,
            clv$ip.file_name^, status);
      RETURN;
    ELSEIF clv$ip.file_position^ > amc$eor THEN
      RETURN;
    ELSE
      dummy_file_name := clv$ip.file_name^;
      clp$layout_data_line (dummy_file_name, transfer_count,
            clv$ip.line_layout, line_area, line_value, clv$ip.line_identifier,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    end_of_input := FALSE;
    IF STRLENGTH (line_value^) > UPPERVALUE (line_size) THEN
      line_size := UPPERVALUE (line_size);
    ELSE
      line_size := STRLENGTH (line_value^);
    IFEND;
    line (1, line_size) := line_value^ (1, line_size);
*ELSE

    end_of_input := FALSE;
    amp_get_next (get_line, get_length, stat);
    status.normal := stat <> 1;
    status.condition := stat;
    line_size := get_length - 1;
    line (1, line_size) := get_line (1, line_size);
*IFEND

    IF clv$ip.capture_data_line <> NIL THEN
      clv$ip.capture_data_line^ (^line (1, line_size));
    IFEND;

  PROCEND clp$ip_get_data_line;
?? OLDTITLE ??
*DECK DECK=CLI$OUTPUT_PROCEDURES EXPAND=FALSE
?? TITLE := 'cli$output_procedures' ??
?? NEWTITLE := 'cli$output_procedures "global" declarations', EJECT ??
{
{ PURPOSE:
{   The purpose of this "module" is to provide simple output procedures for
{   those programs which write to a legible, but not a list, file.
{
{ NOTES:
{   . clp$op_initialize must be called before any other procedure in this
{     "module" is called. It will initialize certain global variables used by
{     the other modules and which may be accessed by the caller.
{
{   . Names of global variables and procedures in this module follow the
{     standard naming conventions with OP_ being appended to the first $ of
{     each name.
{

?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc amd$page_format_declarations
*IFEND
*copyc clt$command_line
*copyc clt$command_line_index
*copyc clt$command_line_size
?? POP ??
*IF NOT $true(osv$unix)
*copyc amp$put_next
*ELSE
*copyc amp_put_next
*IFEND
*copyc clp$convert_integer_to_string
*copyc clp$convert_real_to_string

  VAR
    clv$op: [STATIC] record
*IF NOT $true(osv$unix)
      file_id: amt$file_identifier,
*IFEND
      get_out: ^procedure (    stat: ost$status),
      line: string (amc$max_page_width),
      line_size: 0 .. amc$max_page_width,
      page_width: amt$page_width,
    recend;

?? TITLE := 'clp$op_initialize', EJECT ??

  PROCEDURE clp$op_initialize
*IF NOT $true(osv$unix)
    (    file_id: amt$file_identifier;
         page_width: amt$page_width;
*ELSE
    (    page_width: amt$page_width;
*IFEND
         get_out: ^procedure (    stat: ost$status));


*IF NOT $true(osv$unix)
    clv$op.file_id := file_id;
*IFEND
    clv$op.page_width := page_width;
    clv$op.line := '';
    clv$op.line_size := 0;
    clv$op.get_out := get_out;

  PROCEND clp$op_initialize;
?? TITLE := 'clp$op_add_integer_to_line', EJECT ??

  PROCEDURE [INLINE] clp$op_add_integer_to_line
    (    int: integer);

    VAR
      ignore_status: ost$status,
      int_string: ost$string;


    clp$convert_integer_to_string (int, 10, FALSE, int_string, ignore_status);
    clp$op_add_to_line (int_string.value (1, int_string.size));

  PROCEND clp$op_add_integer_to_line;
?? TITLE := 'clp$op_add_real_to_line', EJECT ??

*IF NOT $true(osv$unix)
  PROCEDURE [INLINE] clp$op_add_real_to_line
    (    real_number: longreal);

    VAR
      ignore_status: ost$status,
      real_string: ost$string;


    clp$convert_real_to_string (real_number, clc$max_real_number_digits,
          real_string, ignore_status);
    clp$op_add_to_line (real_string.value (1, real_string.size));

  PROCEND clp$op_add_real_to_line;
*IFEND
?? TITLE := 'clp$op_add_to_line', EJECT ??

  PROCEDURE clp$op_add_to_line
    (    str: string ( * ));

    VAR
      size: 0 .. osc$max_string_size + 1;


    size := STRLENGTH (str);
    IF (clv$op.line_size + size) <= clv$op.page_width THEN
      clv$op.line (clv$op.line_size + 1, size) := str;
      clv$op.line_size := clv$op.line_size + size;
      RETURN;
    IFEND;

    clp$op_flush_line;
    clp$op_tab_line (3);
    clv$op.line (clv$op.line_size + 1, size) := str;
    clv$op.line_size := clv$op.line_size + size;

  PROCEND clp$op_add_to_line;
?? TITLE := 'clp$op_tab_line', EJECT ??

  PROCEDURE clp$op_tab_line
    (    column: integer);


    IF (clv$op.line_size < column - 1) AND
          (clv$op.line_size <= clv$op.page_width) THEN
      clv$op.line (clv$op.line_size + 1, * ) := ' ';
      clv$op.line_size := column - 1;
    IFEND;

  PROCEND clp$op_tab_line;
?? TITLE := 'clp$op_flush_line', EJECT ??

  PROCEDURE [INLINE] clp$op_flush_line;


    IF clv$op.line_size > 0 THEN
      clp$op_put_line (clv$op.line (1, clv$op.line_size));
    IFEND;

  PROCEND clp$op_flush_line;
?? TITLE := 'clp$op_put_line', EJECT ??

  PROCEDURE clp$op_put_line
    (    line: string ( * ));

    VAR
*IF NOT $true(osv$unix)
      ignore_byte_address: amt$file_byte_address,
      local_status: ost$status;
*ELSE
      data_line: string (256),
      length: integer,
      local_status: ost$status,
      stat: integer;
*IFEND


*IF NOT $true(osv$unix)
    amp$put_next (clv$op.file_id, ^line, STRLENGTH (line), ignore_byte_address,
          local_status);
*ELSE
    length := STRLENGTH (line);
    data_line := line;
    amp_put_next (data_line, length);
    local_status.normal := TRUE;
*IFEND

    IF NOT local_status.normal THEN
      clv$op.get_out^ (local_status);
    IFEND;
    clv$op.line_size := 0;
    clv$op.line := '';

  PROCEND clp$op_put_line;
?? TITLE := 'clp$op_start_line', EJECT ??

  PROCEDURE [INLINE] clp$op_start_line
    (    str: string ( * ));


    clv$op.line := str;
    clv$op.line_size := STRLENGTH (str);

  PROCEND clp$op_start_line;
?? TITLE := 'clp$op_echo', EJECT ??
{
{ PURPOSE:
{   The purpose of this procedure is to echo the given line to the
{   output file.
{

  PROCEDURE clp$op_echo
    (    line: ^clt$command_line);

    CONST
      continuation_mark_char = '.',
      line_prefix = '{ ',
      line_prefix_size = 2,
      min_continuation_mark = '..',
      min_continuation_mark_size = 2;

    VAR
      continuation_line: boolean,
      index: clt$command_line_index,
      line_size: clt$command_line_size,
      size: clt$command_line_size;


    line_size := STRLENGTH (line^);
    continuation_line := (line_size >= min_continuation_mark_size) AND
          (line^ (line_size - min_continuation_mark_size + 1,
          min_continuation_mark_size) = min_continuation_mark);
    IF continuation_line THEN
      line_size := line_size - min_continuation_mark_size;
      WHILE (line_size > 0) AND (line^ (line_size) = continuation_mark_char) DO
        line_size := line_size - 1;
      WHILEND;
    IFEND;

    index := 1;
    WHILE TRUE DO
      clp$op_start_line (line_prefix);
      size := line_size - index + 1;
      IF (line_prefix_size + size + ($INTEGER (continuation_line) *
            min_continuation_mark_size)) <= clv$op.page_width THEN
        clp$op_add_to_line (line^ (index, size));
        IF continuation_line THEN
          clp$op_add_to_line (min_continuation_mark);
        IFEND;
        clp$op_flush_line;
        RETURN;
      IFEND;
      size := clv$op.page_width - line_prefix_size -
            min_continuation_mark_size;
      WHILE (size > 0) AND (line^ (index + size - 1) =
            continuation_mark_char) DO
        size := size - 1;
      WHILEND;
      IF size = 0 THEN
        size := clv$op.page_width - line_prefix_size -
              min_continuation_mark_size;
      IFEND;
      clp$op_add_to_line (line^ (index, size));
      clp$op_add_to_line (min_continuation_mark);
      clp$op_flush_line;
      index := index + size;
    WHILEND;

  PROCEND clp$op_echo;
?? OLDTITLE ??
*DECK DECK=CLK$BEGIN_UTILITY EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

 CONST
    clk$begin_utility               = clk$base + 47;
      {E 'clp$begin_utility' }
      {X 'clp$begin_utility' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$CHANGE_UTILITY_ATTRIBUTES EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

 CONST
    clk$change_utility_attributes   = clk$base_2 + 2;
      {E 'clp$change_utility_attributes' }
      {X 'clp$change_utility_attributes' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$CHANGE_VARIABLE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

 CONST
    clk$change_variable             = clk$base_2 + 6;
      {E 'clp$change_variable' }
      {X 'clp$change_variable' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$COLLECT_COMMANDS EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$collect_commands            = clk$base + 0;
      {E  'clp$collect_commands' }
      {X  'clp$collect_commands' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$CONVERT_INTEGER_TO_RJSTRING EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$convert_integer_to_rjstring = clk$base + 1;
      {E  'clp$convert_integer_to_rjstring' }
      {X  'clp$convert_integer_to_rjstring' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$CONVERT_INTEGER_TO_STRING EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$convert_integer_to_string   = clk$base + 2;
      {E  'clp$convert_integer_to_string' }
      {X  'clp$convert_integer_to_string' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$CONVERT_REAL_TO_STRING EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$convert_real_to_string      = clk$base + 3;
      {E  'clp$convert_real_to_string' }
      {X  'clp$convert_real_to_string' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$CONVERT_STRING_TO_FILE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$convert_string_to_file      = clk$base + 4;
      {E  'clp$convert_string_to_file' }
      {X  'clp$convert_string_to_file' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$CONVERT_STRING_TO_INTEGER EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$convert_string_to_integer   = clk$base + 5;
      {E  'clp$convert_string_to_integer' }
      {X  'clp$convert_string_to_integer' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$CONVERT_STRING_TO_NAME EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$convert_string_to_name      = clk$base + 6;
      {E  'clp$convert_string_to_name' }
      {X  'clp$convert_string_to_name' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$CONVERT_STRING_TO_REAL EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$convert_string_to_real      = clk$base + 7;
      {E  'clp$convert_string_to_real' }
      {X  'clp$convert_string_to_real' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$CONVERT_VALUE_TO_STRING EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$convert_value_to_string     = clk$base + 8;
      {E  'clp$convert_value_to_string' }
      {X  'clp$convert_value_to_string' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$CREATE_ENVIRONMENT_VARIABLE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

 CONST
    clk$create_environment_variable = clk$base_2 + 4;
      {E 'clp$create_environment_variable' }
      {X 'clp$create_environment_variable' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$CREATE_FILE_CONNECTION EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$create_file_connection      = clk$base + 9;
      {E  'clp$create_file_connection' }
      {X  'clp$create_file_connection' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$CREATE_PROCEDURE_VARIABLE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

 CONST
    clk$create_procedure_variable   = clk$base_2 + 5;
      {E 'clp$create_procedure_variable' }
      {X 'clp$create_procedure_variable' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$DECLARE_VARIABLE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$declare_variable            = clk$base + 10;
      {E  'clp$declare_variable' }
      {X  'clp$declare_variable' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$DELETE_FILE_CONNECTION EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$delete_file_connection      = clk$base + 11;
      {E  'clp$delete_file_connection' }
      {X  'clp$delete_file_connection' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$END_INCLUDE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

 CONST
    clk$end_include                 = clk$base_2 + 0;
      {E 'clp$end_include' }
      {X 'clp$end_include' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$END_SCAN_COMMAND_FILE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$end_scan_command_file       = clk$base + 12;
      {E  'clp$end_scan_command_file' }
      {X  'clp$end_scan_command_file' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$END_UTILITY EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

 CONST
    clk$end_utility                 = clk$base + 48;
      {E 'clp$end_utility' }
      {X 'clp$end_utility' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$ERASE_CHILD_TASK EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$erase_child_task            = clk$base + 13;
      {E  'clp$erase_child_task' }
      {X  'clp$erase_child_task' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$EVALUATE_TOKEN EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$evaluate_token              = clk$base + 14;
      {E  'clp$evaluate_token' }
      {X  'clp$evaluate_token' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$EXECUTE_COMMAND EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

 CONST
    clk$execute_command             = clk$base_2 + 8;
      {E 'clp$execute_command' }
      {X 'clp$execute_command' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$GET_COMMAND_ORIGIN EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$get_command_origin          = clk$base + 15;
      {E  'clp$get_command_origin' }
      {X  'clp$get_command_origin' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$GET_LINE_FROM_COMMAND_FILE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$get_line_from_command_file  = clk$base + 16;
      {E  'clp$get_line_from_command_file' }
      {X  'clp$get_line_from_command_file' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$GET_PARAMETER EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$get_parameter               = clk$base + 17;
      {E  'clp$get_parameter' }
      {X  'clp$get_parameter' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$GET_PARAMETER_LIST EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$get_parameter_list          = clk$base + 18;
      {E  'clp$get_parameter_list' }
      {X  'clp$get_parameter_list' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$GET_PATH_DESCRIPTION EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$get_path_description        = clk$base + 19;
      {E  'clp$get_path_description' }
      {X  'clp$get_path_description' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$GET_SET_COUNT EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$get_set_count               = clk$base + 20;
      {E  'clp$get_set_count' }
      {X  'clp$get_set_count' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$GET_UTILITY_ATTRIBUTES EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

 CONST
    clk$get_utility_attributes      = clk$base_2 + 3;
      {E 'clp$get_utility_attributes' }
      {X 'clp$get_utility_attributes' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$GET_VALUE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$get_value                   = clk$base + 21;
      {E  'clp$get_value' }
      {X  'clp$get_value' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$GET_VALUE_COUNT EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$get_value_count             = clk$base + 22;
      {E  'clp$get_value_count' }
      {X  'clp$get_value_count' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$GET_VARIABLE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

 CONST
    clk$get_variable                = clk$base_2 + 7;
      {E 'clp$get_variable' }
      {X 'clp$get_variable' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$GET_WORKING_CATALOG EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$get_working_catalog         = clk$base + 23;
      {E  'clp$get_working_catalog' }
      {X  'clp$get_working_catalog' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$INCLUDE_FILE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

 CONST
    clk$include_file                = clk$base + 49;
      {E 'clp$include_file' }
      {X 'clp$include_file' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$INCLUDE_LINE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

 CONST
    clk$include_line                = clk$base_2 + 1;
      {E 'clp$include_line' }
      {X 'clp$include_line' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$OPEN_COMMAND_FILE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$open_command_file           = clk$base + 24;
      {E  'clp$open_command_file' }
      {X  'clp$open_command_file' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$POP_BLOCK_STACK EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$pop_block_stack             = clk$base + 25;
      {E  'clp$pop_block_stack' }
      {X  'clp$pop_block_stack' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$POP_INPUT_STACK EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$pop_input_stack             = clk$base + 26;
      {E  'clp$pop_input_stack' }
      {X  'clp$pop_input_stack' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$POP_PARAMETERS EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$pop_parameters              = clk$base + 27;
      {E  'clp$pop_parameters' }
      {X  'clp$pop_parameters' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$POP_UTILITY EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$pop_utility                 = clk$base + 28;
      {E  'clp$pop_utility' }
      {X  'clp$pop_utility' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$PROCEDURE_KEYPOINTS EXPAND=FALSE

*copyc amk$base_keypoint_values

{
{ This deck *copyc's all of the decks that define individual keypoints for
{ the Command Language (CL) area of NOS/VE.
{
{ Currently there are two groups of 50 keypoints each assigned to the CL area.
{ The starting numbers for these two groups are identified by the constants
{ CLK$BASE and CLK$BASE_2 defined in deck AMK$BASE_KEYPOINT_VALUES.  Thus
{ the keypoint numbers assigned to the CL area are:
{
{                      CLK$BASE   .. CLK$BASE   + 49
{                      CLK$BASE_2 .. CLK$BASE_2 + 49
{
{ When a new keypoint is defined for the CL area, a new deck should be created
{ to hold its definition.  The number to use for the definition can be
{ determined by looking at the lines below in this deck that identify which
{ numbers are unused in the ranges assigned to the CL area.  This deck should
{ then be updated to reflect that the chosen number is now in use as well as
{ to *copyc the new deck.
{
{ If a keypoint is no longer needed, its defining deck should be deleted,
{ the *copyc to that deck should be removed from this deck, and the lines
{ below should be updated to indicate that the number may be reused.
{
{
{ **********   The following CL keypoint numbers are unused:   **********
{
{       CLK$BASE_2 +  9..49
{
{ ***********************************************************************
{

*copyc clk$begin_utility
*copyc clk$change_utility_attributes
*copyc clk$change_variable
*copyc clk$collect_commands
*copyc clk$convert_integer_to_rjstring
*copyc clk$convert_integer_to_string
*copyc clk$convert_real_to_string
*copyc clk$convert_string_to_file
*copyc clk$convert_string_to_integer
*copyc clk$convert_string_to_name
*copyc clk$convert_string_to_real
*copyc clk$convert_value_to_string
*copyc clk$create_environment_variable
*copyc clk$create_file_connection
*copyc clk$create_procedure_variable
*copyc clk$declare_variable
*copyc clk$delete_file_connection
*copyc clk$end_include
*copyc clk$end_scan_command_file
*copyc clk$end_utility
*copyc clk$erase_child_task
*copyc clk$evaluate_token
*copyc clk$execute_command
*copyc clk$get_command_origin
*copyc clk$get_line_from_command_file
*copyc clk$get_parameter
*copyc clk$get_parameter_list
*copyc clk$get_path_description
*copyc clk$get_set_count
*copyc clk$get_utility_attributes
*copyc clk$get_value
*copyc clk$get_value_count
*copyc clk$get_variable
*copyc clk$get_working_catalog
*copyc clk$include_file
*copyc clk$include_line
*copyc clk$open_command_file
*copyc clk$pop_block_stack
*copyc clk$pop_input_stack
*copyc clk$pop_parameters
*copyc clk$pop_utility
*copyc clk$process_command
*copyc clk$push_block_stack
*copyc clk$push_input_stack
*copyc clk$push_parameters
*copyc clk$push_utility
*copyc clk$read_variable
*copyc clk$record_child_task
*copyc clk$remove_variable
*copyc clk$scan_argument_list
*copyc clk$scan_command_file
*copyc clk$scan_command_line
*copyc clk$scan_expression
*copyc clk$scan_parameter_list
*copyc clk$scan_proc_declaration
*copyc clk$set_working_catalog
*copyc clk$test_parameter
*copyc clk$test_range
*copyc clk$write_variable
*DECK DECK=CLK$PROCESS_COMMAND EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$process_command             = clk$base + 29;
      {E  'clp$process_command' 'command ' A48 }
      {X  'clp$process_command' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$PUSH_BLOCK_STACK EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$push_block_stack            = clk$base + 30;
      {E  'clp$push_block_stack' 'blk kind' }
      {X  'clp$push_block_stack' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$PUSH_INPUT_STACK EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$push_input_stack            = clk$base + 31;
      {E  'clp$push_input_stack' }
      {X  'clp$push_input_stack' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$PUSH_PARAMETERS EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$push_parameters             = clk$base + 32;
      {E  'clp$push_parameters' }
      {X  'clp$push_parameters' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$PUSH_UTILITY EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$push_utility                = clk$base + 33;
      {E  'clp$push_utility' }
      {X  'clp$push_utility' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$READ_VARIABLE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$read_variable               = clk$base + 34;
      {E  'clp$read_variable' }
      {X  'clp$read_variable' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$RECORD_CHILD_TASK EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$record_child_task           = clk$base + 35;
      {E  'clp$record_child_task' }
      {X  'clp$record_child_task' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$REMOVE_VARIABLE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$remove_variable             = clk$base + 36;
      {E  'clp$remove_variable' }
      {X  'clp$remove_variable' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$SCAN_ARGUMENT_LIST EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$scan_argument_list          = clk$base + 37;
      {E  'clp$scan_argument_list' }
      {X  'clp$scan_argument_list' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$SCAN_COMMAND_FILE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$scan_command_file           = clk$base + 38;
      {E  'clp$scan_command_file' }
      {X  'clp$scan_command_file' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$SCAN_COMMAND_LINE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$scan_command_line           = clk$base + 39;
      {E  'clp$scan_command_line' }
      {X  'clp$scan_command_line' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$SCAN_EXPRESSION EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$scan_expression             = clk$base + 40;
      {E  'clp$scan_expression' }
      {X  'clp$scan_expression' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$SCAN_PARAMETER_LIST EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$scan_parameter_list         = clk$base + 41;
      {E  'clp$scan_parameter_list' }
      {X  'clp$scan_parameter_list' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$SCAN_PROC_DECLARATION EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$scan_proc_declaration       = clk$base + 42;
      {E  'clp$scan_proc_declaration' }
      {X  'clp$scan_proc_declaration' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$SET_WORKING_CATALOG EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$set_working_catalog         = clk$base + 43;
      {E  'clp$set_working_catalog' }
      {X  'clp$set_working_catalog' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$TEST_PARAMETER EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$test_parameter              = clk$base + 44;
      {E  'clp$test_parameter' }
      {X  'clp$test_parameter' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$TEST_RANGE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$test_range                  = clk$base + 45;
      {E  'clp$test_range' }
      {X  'clp$test_range' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLK$WRITE_VARIABLE EXPAND=FALSE
*copyc amk$base_keypoint_values
?? FMT (FORMAT := OFF) ??

  CONST
    clk$write_variable              = clk$base + 46;
      {E  'clp$write_variable' }
      {X  'clp$write_variable' }

?? FMT (FORMAT := ON) ??
*DECK DECK=CLL$COMMENT_COMMAND EXPAND=FALSE

*copyc CLC$CONDITION_CODE_LIMITS

  CONST
    cll$comment_command = cll$min_scc + 0,
    cll$processed_command = cll$min_scc + 1,
    cll$command_resources = cll$min_scc + 2,
    cll$processed_control_statement = cll$min_scc + 3,

    cll$last_scc = cll$max_scc;

*DECK DECK=CLM$ACCEPT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Get Line' ??
MODULE clm$accept;

{
{ PURPOSE:
{   This module contains the processor for the get_line command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$lfn_program_actions
*copyc clc$standard_file_names
*copyc cld$parameter_list
*copyc cle$bad_type_specification
*copyc clt$command_line
*copyc clt$command_line_size
*copyc clt$when_conditions
*copyc cyd$run_time_error_condition
*copyc ife$error_codes
*copyc ost$caller_identifier
*copyc ost$status
?? POP ??
*copyc amv$nil_file_identifier
*copyc clp$change_variable
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$find_current_block
*copyc clp$get_line_from_command_file
*copyc clp$get_type_information
*copyc clp$get_variable
*copyc clp$get_work_area
*copyc clp$make_array_value
*copyc clp$make_clt$integer_value
*copyc clp$make_list_value
*copyc clp$make_sized_string_value
*copyc clp$pop_input
*copyc clp$push_input
*copyc clp$put_job_output
*copyc clv$nil_block_handle
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal
*copyc pmp$continue_to_cause

?? TITLE := 'clp$get_line', EJECT ??

  PROCEDURE [XDCL] clp$_get_line
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$getl) get_line, get_lines, accept_line, accept_lines, accl, getl (
{   variable, v: (VAR) any of
{       string
{       list 0..clc$max_list_size of string
{       array of string
{     anyend = $required
{   input, i: file = $required
{   prompt, p: string = $optional
{   line_count, lc: (VAR) integer = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 9] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] 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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$list_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$string_type_qualifier,
            recend,
          recend,
          type_size_3: clt$type_specification_size,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$array_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$string_type_qualifier,
            recend,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 12, 9, 14, 15, 33, 835], clc$command, 9, 5, 2, 0, 0, 2, 5, 'OSM$GETL'],
            [['I                              ', clc$abbreviation_entry, 2],
            ['INPUT                          ', clc$nominal_entry, 2],
            ['LC                             ', clc$abbreviation_entry, 4],
            ['LINE_COUNT                     ', clc$nominal_entry, 4],
            ['P                              ', clc$abbreviation_entry, 3],
            ['PROMPT                         ', clc$nominal_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 5],
            ['V                              ', clc$abbreviation_entry, 1],
            ['VARIABLE                       ', clc$nominal_entry, 1]], [
{ PARAMETER 1
      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 88, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 3
      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 4
      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 5
      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$union_type], [[clc$array_type, clc$list_type, clc$string_type], FALSE, 3], 8,
            [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]], 24,
            [[1, 0, clc$list_type], [8, 0, clc$max_list_size, FALSE],
            [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]], 32,
            [[1, 0, clc$array_type], [8, FALSE], [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]]],
{ PARAMETER 2
      [[1, 0, clc$file_type]],
{ PARAMETER 3
      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 4
      [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
{ PARAMETER 5
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$variable = 1,
      p$input = 2,
      p$prompt = 3,
      p$line_count = 4,
      p$status = 5;

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


    CONST
      default_prompt_header = ' ENTER ',
      default_prompt_header_size = 7;

    VAR
      access_mode: clt$data_access_mode,
      class: clt$variable_class,
      default_prompt_size: ost$string_size,
      element_index: clt$array_bound,
      element_index_string: ost$string,
      evaluation_method: clt$expression_eval_method,
      input_block: ^clt$block,
      input_block_handle: clt$block_handle,
      input_executable: boolean,
      input_file_id: amt$file_identifier,
      input_file_name: amt$local_file_name,
      line_count: clt$data_value,
      line_value: ^clt$data_value,
      list_value: ^clt$data_value,
      local_status: ost$status,
      max_string_size: clt$string_size,
      min_string_size: clt$string_size,
      prompt_string: ost$string,
      retry_read: boolean,
      terminate_read: boolean,
      type_information: clt$type_information,
      type_specification: ^clt$type_specification,
      upper_bound: clt$array_bound,
      using_default_prompt: boolean,
      work_area: ^^clt$work_area;

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

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


      clean_up;

    PROCEND abort_handler;
?? TITLE := 'clean_up', EJECT ??

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;


      clp$pop_input (TRUE, input_block_handle, input_file_id, input_executable, NIL, ignore_status);

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

?? TITLE := 'read_line', EJECT ??
{
{ The READ_LINE procedure contains a pause_break condition handler so that
{ after a pause break occurs, the prompt for input can be re-issued.
{ Normally this would happen automatically as part of an interactive read
{ operation; but since the prompt issued can be longer than that handled
{ by interactive input, it must be "manually" issued.
{

    PROCEDURE read_line;

      VAR
        data_line_size: clt$string_size,
        data_line: ^clt$command_line,
        null_prompt: ^clt$prompt_string,
        result_string_size: clt$string_size;

?? NEWTITLE := 'interactive_pause_handler', EJECT ??

      PROCEDURE interactive_pause_handler
        (    condition: pmt$condition;
             ignore_condition_information: ^pmt$condition_information;
             ignore_save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);


        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IF handler_status.normal AND (condition.selector = ifc$interactive_condition) AND
              (condition.interactive_condition = ifc$pause_break) THEN
          retry_read := TRUE;
          EXIT read_line;
        IFEND;

      PROCEND interactive_pause_handler;
?? OLDTITLE, EJECT ??

      IF (input_block^.input.kind = clc$file_input) AND input_block^.input.interactive_device THEN
        osp$establish_condition_handler (^interactive_pause_handler, FALSE);
        clp$put_job_output (prompt_string.value (1, prompt_string.size), status);
        IF NOT status.normal THEN
          clean_up;
          EXIT clp$_get_line;
        IFEND;
      IFEND;

      PUSH null_prompt: [0];
      clp$get_line_from_command_file (null_prompt^, data_line, status);
      IF NOT status.normal THEN
        clean_up;
        EXIT clp$_get_line;
      IFEND;
      IF data_line <> NIL THEN
        IF STRLENGTH (data_line^) > max_string_size THEN
          data_line_size := max_string_size;
        ELSE
          data_line_size := STRLENGTH (data_line^);
        IFEND;
        IF data_line_size < min_string_size THEN
          result_string_size := min_string_size;
        ELSE
          result_string_size := data_line_size;
        IFEND;
        CASE line_value^.kind OF
        = clc$array =
          IF line_value^.array_value^ [element_index] = NIL THEN
            clp$make_sized_string_value (result_string_size, work_area^, line_value^.
                  array_value^ [element_index]);
          ELSE
            NEXT line_value^.array_value^ [element_index]^.string_value: [result_string_size] IN work_area^;
          IFEND;
          line_value^.array_value^ [element_index]^.string_value^ := data_line^ (1, data_line_size);
        = clc$list =
          IF line_value^.element_value <> NIL THEN {not first time through loop}
            clp$make_list_value (work_area^, list_value^.link);
            list_value := list_value^.link;
          IFEND;
          clp$make_sized_string_value (result_string_size, work_area^, list_value^.element_value);
          list_value^.element_value^.string_value^ := data_line^ (1, data_line_size);
        ELSE { clc$string_type }
          NEXT line_value^.string_value: [result_string_size] IN work_area^;
          line_value^.string_value^ := data_line^ (1, data_line_size);
          line_count.integer_value.value := line_count.integer_value.value + 1;
          terminate_read := TRUE;
        CASEND;
      ELSE
        terminate_read := TRUE;
      IFEND;

    PROCEND read_line;
?? OLDTITLE, EJECT ??

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

    clp$get_work_area (#RING (^work_area), work_area, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_variable (pvt [p$variable].variable^, work_area^, class, access_mode, evaluation_method,
          type_specification, line_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_type_information (type_specification, work_area^, type_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    input_block := NIL;
    input_block_handle := clv$nil_block_handle;
    input_file_id := amv$nil_file_identifier;
    #SPOIL (input_block_handle, input_file_id);

    osp$establish_block_exit_hndlr (^abort_handler);

  /get_line/
    BEGIN
      clp$push_input (pvt [p$input].value^.file_value^, osc$null_name, '', FALSE, TRUE, input_block_handle,
            input_file_id, input_executable, status);
      IF NOT status.normal THEN
        EXIT /get_line/;
      IFEND;
      clp$find_current_block (input_block);

      using_default_prompt := FALSE;

      IF (input_block^.input.kind = clc$file_input) AND input_block^.input.interactive_device THEN

        IF pvt [p$prompt].specified THEN
          IF STRLENGTH (pvt [p$prompt].value^.string_value^) >= osc$max_string_size THEN
            prompt_string.size := osc$max_string_size;
          ELSE
            prompt_string.size := 1 + STRLENGTH (pvt [p$prompt].value^.string_value^);
          IFEND;
          prompt_string.value (1) := ' ';
          prompt_string.value (2, prompt_string.size - 1) := pvt [p$prompt].
                value^.string_value^ (1, prompt_string.size - 1);
        ELSE
          using_default_prompt := TRUE;
          prompt_string.value := default_prompt_header;
          IF STRLENGTH (pvt [p$variable].variable^) <= (osc$max_string_size - 1 - default_prompt_header_size)
                THEN
            default_prompt_size := default_prompt_header_size + STRLENGTH (pvt [p$variable].variable^) + 1;
          ELSE
            default_prompt_size := osc$max_string_size;
          IFEND;
          prompt_string.size := default_prompt_size;
          prompt_string.value (default_prompt_header_size + 1, * ) := pvt [p$variable].variable^;
          prompt_string.value (prompt_string.size) := ' ';
        IFEND;

      ELSE
        prompt_string.size := 0;
      IFEND;

      IF line_value <> NIL THEN
        CASE line_value^.kind OF
        = clc$array =
          IF type_information.kind = clc$array_type THEN
            max_string_size := type_information.array_element_type_information^.max_string_size;
            min_string_size := type_information.array_element_type_information^.min_string_size;
          ELSE
            max_string_size := clc$max_string_size;
            min_string_size := 0;
          IFEND;
          element_index := LOWERBOUND (line_value^.array_value^);
          upper_bound := UPPERBOUND (line_value^.array_value^);
        = clc$list =
          line_value^.element_value := NIL;
          line_value^.link := NIL;
          list_value := line_value;
          IF type_information.kind = clc$list_type THEN
            max_string_size := type_information.list_element_type_information^.max_string_size;
            min_string_size := type_information.list_element_type_information^.min_string_size;
            upper_bound := type_information.max_list_size;
          ELSE
            max_string_size := clc$max_string_size;
            min_string_size := 0;
            upper_bound := clc$max_list_size;
          IFEND;
          element_index := 1;
        = clc$string =
          IF type_information.kind = clc$string_type THEN
            max_string_size := type_information.max_string_size;
            min_string_size := type_information.min_string_size;
          ELSE
            max_string_size := clc$max_string_size;
            min_string_size := 0;
          IFEND;
        ELSE
          line_value^.kind := clc$string;
          NEXT line_value^.string_value: [0] IN work_area^;
          max_string_size := clc$max_string_size;
          min_string_size := 0;
        CASEND;
      ELSE
        CASE type_information.kind OF
        = clc$array_type =
          clp$make_array_value (type_information.bounds.lower, type_information.bounds.upper, work_area^,
                line_value);
          FOR element_index := type_information.bounds.lower TO type_information.bounds.upper DO
            clp$make_sized_string_value (0, work_area^, line_value^.array_value^ [element_index]);
          FOREND;
          max_string_size := type_information.array_element_type_information^.max_string_size;
          min_string_size := type_information.array_element_type_information^.min_string_size;
          element_index := type_information.bounds.lower;
          upper_bound := type_information.bounds.upper;
        = clc$list_type =
          clp$make_list_value (work_area^, line_value);
          list_value := line_value;
          max_string_size := type_information.list_element_type_information^.max_string_size;
          min_string_size := type_information.list_element_type_information^.min_string_size;
          element_index := 1;
          upper_bound := type_information.max_list_size;
        = clc$string_type =
          clp$make_sized_string_value (0, work_area^, line_value);
          max_string_size := type_information.max_string_size;
          min_string_size := type_information.min_string_size;
        ELSE
          clp$make_sized_string_value (0, work_area^, line_value);
          max_string_size := clc$max_string_size;
          min_string_size := 0;
        CASEND;
      IFEND;

      line_count.kind := clc$integer;
      line_count.integer_value.value := 0;
      line_count.integer_value.radix := 10;
      line_count.integer_value.radix_specified := FALSE;

    /input_loop/
      WHILE TRUE DO
        terminate_read := FALSE;
        retry_read := FALSE;

        IF using_default_prompt AND ((line_value^.kind = clc$array) OR (line_value^.kind = clc$list)) THEN
          clp$convert_integer_to_string (element_index, 10, FALSE, element_index_string, local_status);
          IF (default_prompt_size + element_index_string.size + 2) <= osc$max_string_size THEN
            prompt_string.size := default_prompt_size + element_index_string.size + 2;
            prompt_string.value (default_prompt_size) := '(';
            prompt_string.value (default_prompt_size + 1, element_index_string.size) :=
                  element_index_string.value (1, element_index_string.size);
            prompt_string.value (prompt_string.size - 1, 2) := ') ';
          ELSE
            prompt_string.size := default_prompt_size;
            prompt_string.value (default_prompt_size) := ' ';
          IFEND;
        IFEND;

        read_line;
        IF terminate_read THEN
          EXIT /input_loop/;
        IFEND;
        IF NOT retry_read THEN
          line_count.integer_value.value := line_count.integer_value.value + 1;
          element_index := element_index + 1;
          IF element_index > upper_bound THEN
            EXIT /input_loop/;
          IFEND;
        IFEND;
      WHILEND /input_loop/;
    END /get_line/;

    clp$pop_input (TRUE, input_block_handle, input_file_id, input_executable, NIL, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

    osp$disestablish_cond_handler;

    IF status.normal THEN
      clp$change_variable (pvt [p$variable].variable^, line_value, status);
      IF status.normal AND pvt [p$line_count].specified THEN
        clp$change_variable (pvt [p$line_count].variable^, ^line_count, status);
      IFEND;
    IFEND;

  PROCEND clp$_get_line;

MODEND clm$accept;
*DECK DECK=CLM$ACCESS_COMMAND_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Access Command File' ??
MODULE clm$access_command_file;

{
{ PURPOSE:
{   This module contains a procedure to test command file attributes and
{ open the command file.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc ame$lfn_program_actions
*copyc ame$open_validation_errors
*IFEND
*copyc clc$standard_file_names
*copyc cle$ecc_command_processing
*copyc cle$ecc_miscellaneous
*copyc clt$command_file_kind
*copyc clt$file_contents
*IF $true(osv$unix)
*copyc cyt$mips_signal_handler
*ELSE
*copyc ost$caller_identifier
*IFEND
?? POP ??
*IF NOT $true(osv$unix)
*copyc amp$get_file_attributes
*copyc amp$set_local_name_abnormal
*IFEND
*copyc amv$nil_file_identifier
*IF NOT $true(osv$unix)
*copyc bap$get_phn_via_file_id
*IFEND
*copyc clp$close_command_file
*copyc clp$determine_line_layout
*copyc clp$open_command_file
*copyc clp$open_executable_cmnd_file
*copyc clp$trimmed_string_size
*IF NOT $true(osv$unix)
*copyc clv$standard_files
*copyc fsp$convert_to_new_contents
*copyc fsp$set_file_reference_abnormal
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*IFEND
*copyc fsp$get_open_information
*copyc osp$set_status_abnormal
*IF NOT $true(osv$unix)
*copyc pmp$get_job_mode
*copyc rmp$get_device_class
*ELSE
*copyc ame$condition_codes
*IFEND

?? TITLE := 'clp$access_command_file', EJECT ??
*IF NOT $true(osv$unix)
{
{   The purpose of this request is to open the command file if necessary and execute
{ file attribute tests other than those performed during open validation or if an open
{ request was never issued.  The command file will be closed if a test fails and the
{ file was opened.
{
{   The access modes for opening a command file are as follows:
{ 1. the command file may be opened as a readable file,
{ 2. the command file may be opened as an executable file in ring 3 or lower,
{ 3. an attempt is made to open the command file as a readable file if the
{    caller ring is higher than 3.  If that attempt fails, another attempt
{    is made to open the file in ring 3 as an executable file.
{ All command files are opened except for the command file kind of
{ clc$command_catalog that is found to be an object file or an object library.
{
{   A description of available tests is listed below:
{ COMMAND_FILE_TEST -
{   include_file:               file contents = legible_scl_include, legible_data, legible, data or unknown
{                            OR
{                               file contents = legible_scl_job, legible_data, legible, data or unknown
{
{   object_library:             file contents = object_library
{
{   proc_or_object_file_or_lib: file contents = legible_scl_procedure, legible_data, legible, data or unknown
{                            OR
{                               file contents = object_library or object_data
{
{ FILE_ORGANIZATION_TEST (boolean) -
{   TRUE:                       file_organization = sequential,
{                               (record type <> undefined OR block type = user specified).
{
{ CALLABLE_FILE_TEST -
{   (This test is not performed if the command file is opened as a readable_file.)
{   call_bracket:               caller_ring <= r3,
{
{   execute_bracket:            caller_ring >= r1,
{                               caller ring <= r2.
{
{ EXECUTE_ACCESS_TEST (boolean) -
{   TRUE:                       access mode includes execute.
{
{ FAP_NOT_ALLOWED_TEST (boolean) -
{   TRUE:                       file access procedure = none.
{
{   NOTE: A test has not been created for an allowable fap associated with a command file.
{         The attribute requirements for this instance are automatically validated during the
{         opening of the command file with one exception.  The exception is the caller ring is
{         ring 3 and the command file access mode does not include read.  The actual requirements
{         for an allowable fap associated with a command file are the caller ring <= r2 and the
{         access mode includes read.
{
{
{   Listed below for each kind of command file is the access mode option and the test settings
{   before the open is performed.
{ CLC$INCLUDE_FILE -
{   access mode option:     readable or executable, executable
{   command_file_test:      include_file, none
{   file_organization_test: TRUE
{   callable_file_test:     execute_bracket, none
{   execute_access_test:    FALSE
{   fap_not_allowed_test:   FALSE
{
{   IF the command file name is 'COMMAND' the access mode option will be executable.  The
{   command_file_test and the callable_file_test are set to none.  Otherwise the access
{   mode option will be readable or executable, the command_file_test is set to include_file,
{   and the callable_file_test is set to execute_bracket.
{   Access level is assumed record.
{
{ CLC$INCF_SEGMENT_CALLER_FILE -                                CLC$INCF_RECORD_CALLER_FILE -
{   access mode option:     readable or executable, executable    readable or executable, executable
{   command_file_test:      none                                   none
{   file_organization_test: FALSE                                 TRUE
{   callable_file_test:     execute_bracket, none                 execute_bracket, none
{   execute_access_test:    FALSE                                 FALSE
{   fap_not_allowed_test:   FALSE                                 FALSE
{
{   Access level is assumed segment.                              Access level is assumed record.
{
{   These two kinds of command files reference a file by $COMMAND or $COMMAND_OF_CALLER.
{   IF the command file name is 'COMMAND' the access mode option will be executable.  And the
{   callable_file_test is set to none.  Otherwise the access mode option will be readable or
{   executable.  AND the callable_file_test is set to execute_bracket.
{
{ CLC$GET_FILE -
{   access mode option:     readable
{   command_file_test:      none
{   file_organization_test: TRUE
{   callable_file_test:     none
{   execute_access_test:    FALSE
{   fap_not_allowed_test:   FALSE
{
{   Access level is assumed record.
{
{ CLC$GET_SEGMENT_CALLER_FILE -                                 CLC$GET_RECORD_CALLER_FILE -
{   access mode option:     readable                              readable
{   command_file_test:      none                                  none
{   file_organization_test: FALSE                                 TRUE
{   callable_file_test:     none                                  none
{   execute_access_test:    FALSE                                 FALSE
{   fap_not_allowed_test:   FALSE                                 FALSE
{
{   Access level is assumed segment.                              Access level is assumed record.
{
{   These two kinds of command files reference a file by $COMMAND or $COMMAND_OF_CALLER.
{
{ CLC$CATALOG_COMMAND -
{   access mode option:     executable, none
{   command_file_test:      proc_or_object_file_or_lib
{   file_organization_test: TRUE,FALSE
{   callable_file_test:     call_bracket, execute_bracket
{   execute_access_test:    TRUE,FALSE
{   fap_not_allowed_test:   TRUE
{
{   If the command_file_test has determined that the command file is an SCL proc the
{   access mode option will be executable, the access level is assumed record, the
{   file_organization_test is set to TRUE, the execute_access_test is set to FALSE, and the
{   callable_file_test is set to execute_bracket because, currently, there is no "ring switch"
{   for procs.  Otherwise the file is not opened, the access level is assumed segment, the
{   file_organization_test is set to FALSE, the execute_access_test is set to TRUE, and the
{   callable_file_test is set to call_bracket.
{
{ CLC$COMMAND_LIBRARY -
{   access mode option:     executable
{   command_file_test:      object_library
{   file_organization_test: FALSE
{   callable_file_test:     none
{   execute_access_test:    FALSE
{   fap_not_allowed_test:   TRUE
{
{   Access level is assumed segment.
{
{ CLC$SUBMIT_JOB -
{   access mode option:     executable
{   command_file_test:      include_file
{   file_organization_test: TRUE
{   callable_file_test:     call_bracket
{   execute_access_test:    FALSE
{   fap_not_allowed_test:   TRUE
{
{   Access level is assumed record.
{
{
{
{   Listed below are the output parameters that are set for each kind of command file:
{ CLC$INCLUDE_FILE, CLC$GET_FILE -
{   file_id, segment, opened_executable_file, can_be_echoed, line_layout, ring_attributes, file_has_fap,
{         open_path_handle_name.
{
{ CLC$INCF_SEGMENT_CALLER_FILE, CLC$INCF_RECORD_CALLER_FILE,
{ CLC$GET_SEGMENT_CALLER_FILE, CLC$GET_RECORD_CALLER_FILE -
{   file_id, segment, opened_executable_file, ring_attributes, file_has_fap, open_path_handle_name.
{
{ CLC$CATALOG_COMMAND -
{   file_contents, ring_attributes, file_has_fap,
{   IF the command file is an SCL PROC (file_contents.is_object = FALSE)
{     file_id, segment, opened_executable_file, can_be_echoed, line_layout, open_path_handle_name.
{
{ CLC$COMMAND_LIBRARY -
{   file_id, segment, opened_executable_file, can_be_echoed, ring_attributes, file_has_fap,
{         open_path_handle_name.
{
{ CLC$SUBMIT_JOB -
{   file_id, segment, opened_executable_file, can_be_echoed, line_layout, ring_attributes, file_has_fap,
{         open_path_handle_name.
{
{
{       CLP$ACCESS_COMMAND_FILE (COMMAND_FILE, SUBMITTER_RING, FILE_REFERENCE, FILE_ID,
{         SEGMENT, OPENED_EXECUTABLE_FILE, CAN_BE_ECHOED, LINE_LAYOUT, FILE_CONTENTS_IS_OBJECT,
{         RING_ATTRIBUTES, FILE_HAS_FAP, OPEN_PATH_HANDLE_NAME, DEVICE_CLASS, STATUS);
{
{ COMMAND_FILE: (input) This parameter specifies the command file kind.
{
{ SUBMITTER_RING: (input) This parameter specifies the submitted ring for validation.
{
{ FILE_REFERENCE: (input) This parameter specifies the file reference of the command file.  The file
{       reference must not be a relative path because this routine calls procedures (ie. fsp$open_file,
{       amp$get_file_attributes) which assume $LOCAL as the working catalog rather than using the actual
{       catalog.
{       If the file is the standard command file, then its path_handle_name must be passed instead.
{
{ FILE_ID: (output) This parameter specifies the file id after opening the command file.
{
{ SEGMENT: (output) This parameter specifies the segment address after opening the command file.
{
{ OPENED_EXECUTABLE_FILE: (output) This parameter specifies if the commmand file was opened as
{         an executable file (opened in ring 3) or the file was opened at the caller ring level.
{
{ CAN_BE_ECHOED: (output) This parameter specifies if the command file can be echoed.
{
{ LINE_LAYOUT: (output) This parameter specifes the line layout of the command file.
{
{ FILE_CONTENTS: (output) This parameter specifies if the file contents attribute is object
{         and if the path exists.
{
{ RING_ATTRIBUTES: (output) This parameter specifies the ring attributes of the command file.
{
{ FILE_HAS_FAP: (output) This parameter specifies whether the file has a FAP associated with it.
{
{ DEVICE_CLASS: (output) This parameter specifies the device class of the command file.
{
{ OPEN_PATH_HANDLE_NAME: (output) This parameter specifies the path handle name of the opened file.
{
{ STATUS: (output) This parameter specifes the request status.
{
*IFEND

  PROCEDURE [XDCL] clp$access_command_file
    (    command_file: clt$command_file_kind;
*IF NOT $true(osv$unix)
         submitter_ring: ost$ring;
*IFEND
         file_reference: fst$file_reference;
     VAR file_id: amt$file_identifier;
     VAR segment: ^SEQ ( * );
     VAR opened_executable_file: boolean;
     VAR can_be_echoed: boolean;
     VAR line_layout: clt$line_layout;
*IF NOT $true(osv$unix)
     VAR file_contents: clt$file_contents;
     VAR ring_attributes: amt$ring_attributes;
     VAR file_has_fap: boolean;
*IFEND
     VAR device_class: rmt$device_class;
*IF NOT $true(osv$unix)
     VAR open_path_handle_name: fst$path_handle_name;
*ELSE
     VAR open_path_handle_name: fst$path;
*IFEND
     VAR status: ost$status);

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

    PROCEDURE abort_handler
*IF $true(osv$unix)
      (    signal_no: integer;
           code: integer;
           p_sigcontext: ^cyt$mips_sigcontext);
*ELSE
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);
*IFEND

*IF NOT $true(osv$unix)
      clp$close_command_file (file_id, opened_executable_file, handler_status);
      handler_status.normal := TRUE;
*IFEND

    PROCEND abort_handler;
*IF NOT $true(osv$unix)
?? TITLE := 'establish_incf_caller_tests', EJECT ??

    PROCEDURE [INLINE] establish_incf_caller_tests;


      IF (job_mode = jmc$batch) AND (file_reference = clv$standard_files [clc$sf_command_file].
            path_handle_name) THEN
        open_executable_cmnd_file := TRUE;
        exec_cmnd_file_access_options := all_options;
        callable_file_test := no_callable_file_test;
      ELSE
        open_command_file := TRUE;
        cmnd_file_access_options := one_option_read;
        open_executable_cmnd_file := TRUE;
        exec_cmnd_file_access_options := one_option_execute;
        callable_file_test := execute_bracket;
      IFEND;

      command_file_test := no_command_file_test;
      execute_access_test := FALSE;
      fap_not_allowed_test := FALSE;
      fetch_attributes := TRUE;
      caller_file := TRUE;

    PROCEND establish_incf_caller_tests;
?? TITLE := 'establish_get_file_tests', EJECT ??

    PROCEDURE [INLINE] establish_get_file_tests;


      IF (command_file <> clc$get_file) AND (caller_id.ring > osc$tsrv_ring) AND (job_mode = jmc$batch) AND
            (file_reference = clv$standard_files [clc$sf_command_file].path_handle_name) THEN
        open_executable_cmnd_file := TRUE;
        exec_cmnd_file_access_options := one_option_read;
      ELSE
        open_command_file := TRUE;
        cmnd_file_access_options := one_option_read;
      IFEND;

      command_file_test := no_command_file_test;
      callable_file_test := no_callable_file_test;
      execute_access_test := FALSE;
      fap_not_allowed_test := FALSE;
      fetch_attributes := TRUE;

    PROCEND establish_get_file_tests;
*IFEND
?? TITLE := 'determine_open_choices', EJECT ??

    PROCEDURE [INLINE] determine_open_choices;


*IF NOT $true(osv$unix)
      IF caller_id.ring > osc$tsrv_ring THEN
        open_executable_cmnd_file := TRUE;
        exec_cmnd_file_access_options := two_options_read_exec_or_exec;
      ELSE
*IFEND
        open_command_file := TRUE;
        cmnd_file_access_options := two_options_read_exec_or_exec;
*IF NOT $true(osv$unix)
      IFEND;
*IFEND

    PROCEND determine_open_choices;
?? TITLE := 'establish_file_access_modes', EJECT ??

    PROCEDURE [INLINE] establish_file_access_modes
      (    file_access_options: access_options);


      CASE file_access_options OF
      = one_option_read =
        file_access_modes [1] := $fst$file_access_options [fsc$read];
        file_access_modes [2] := $fst$file_access_options [];
        file_access_modes [3] := $fst$file_access_options [];

      = one_option_execute =
        file_access_modes [1] := $fst$file_access_options [fsc$execute];
        file_access_modes [2] := $fst$file_access_options [];
        file_access_modes [3] := $fst$file_access_options [];

      = two_options_read_exec_or_exec =
        file_access_modes [1] := $fst$file_access_options [fsc$read, fsc$execute];
        file_access_modes [2] := $fst$file_access_options [fsc$execute];
        file_access_modes [3] := $fst$file_access_options [];

      ELSE
        file_access_modes [1] := $fst$file_access_options [fsc$read, fsc$execute];
        file_access_modes [2] := $fst$file_access_options [fsc$execute];
        file_access_modes [3] := $fst$file_access_options [fsc$read];

      CASEND;

    PROCEND establish_file_access_modes;
?? OLDTITLE, EJECT ??

    CONST

{ The constants defined below represent the number of attribute validation
{ selections needed for a particular test as listed:
{ command_file_test/include_file = 5,
{ command_file_test/object_library = 1,
{ file_organization_test = 1,
{ fap_not_allowed_test = 1.

      include_file_selections = 5,
      object_library_selections = 1,
      file_organization_selections = 1,
      fap_selections = 1,

{ The following constants represent the number of attribute validation
{ selections needed for open validation for each kind of command file.
{ The number of validation selections for a file is determined by the
{ required testing for that file.

      select_incf_file_org_fap = include_file_selections + file_organization_selections + fap_selections,
      select_incf_file_org = include_file_selections + file_organization_selections,
      select_object_lib_fap = object_library_selections + fap_selections,
      select_file_org_fap = file_organization_selections + fap_selections,
      select_file_org = file_organization_selections,
      no_selections = 0;

    TYPE
      access_options = (one_option_read, one_option_execute, two_options_read_exec_or_exec, all_options);

    VAR
      access_level: amc$record .. amc$segment,
      allowed_device_classes: fst$device_classes,
*IF NOT $true(osv$unix)
      attachment_information: fst$attachment_information,
*IFEND
      attribute_count: 1 .. 2,
      attribute_index: no_selections .. select_incf_file_org_fap,
      attribute_validation: ^fst$file_cycle_attributes,
      callable_file_test: (no_callable_file_test, execute_bracket, call_bracket),
      caller_file: boolean,
*IF NOT $true(osv$unix)
      caller_id: ost$caller_identifier,
      catalog_information: fst$catalog_information,
*IFEND
      cmnd_file_access_options: access_options,
      command_file_test: (no_command_file_test, include_file, object_library, proc_or_object_file_or_lib),
*IF NOT $true(osv$unix)
      cycle_attribute_sources: fst$cycle_attribute_sources,
      cycle_attribute_values: fst$cycle_attribute_values,
*IFEND
      device_assigned: boolean,
      exec_cmnd_file_access_options: access_options,
      execute_access_test: boolean,
      existing_file: boolean,
      fap_not_allowed_test: boolean,
*IF NOT $true(osv$unix)
      fap_null_name: pmt$entry_point_reference,
*IFEND
      fetch_attributes: boolean,
      file_access_modes: clt$command_file_access_modes,
      file_organization_test: boolean,
*IF NOT $true(osv$unix)
      fs_file_contents: amt$file_contents,
      get_attributes: array [1 .. 11] of amt$get_item,
*ELSE
      handler_established: boolean,
*IFEND
*IF NOT $true(osv$unix)
      ignore_contains_data: boolean,
      ignore_file_contents_truncated: boolean,
*IFEND
      ignore_local_file: boolean,
      ignore_status: ost$status,
*IF NOT $true(osv$unix)
      instance_information: fst$open_instance_information,
      job_mode: jmt$job_mode,
*IFEND
      open_command_file: boolean,
      open_executable_cmnd_file: boolean,
*IF NOT $true(osv$unix)
      open_validation_selections: no_selections .. select_incf_file_org_fap,
      user_defined_attribute_size: fst$user_defined_attribute_size;
*ELSE
      open_validation_selections: no_selections .. select_incf_file_org_fap;
*IFEND


    status.normal := TRUE;
    open_command_file := FALSE;
    open_executable_cmnd_file := FALSE;
    file_id := amv$nil_file_identifier;
*IF NOT $true(osv$unix)
    #SPOIL (file_id);
    file_contents.path_exists := TRUE;
    file_contents.is_object := FALSE;
*ELSE
    can_be_echoed := FALSE;
*IFEND
    open_path_handle_name := osc$null_name;
    allowed_device_classes := -$fst$device_classes [];

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);

    pmp$get_job_mode (job_mode, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
*IFEND

    CASE command_file OF
    = clc$include_file =
*IF NOT $true(osv$unix)
      IF (job_mode = jmc$batch) AND (file_reference = clv$standard_files [clc$sf_command_file].
            path_handle_name) THEN
        open_executable_cmnd_file := TRUE;
        exec_cmnd_file_access_options := all_options;
        command_file_test := no_command_file_test;
        callable_file_test := no_callable_file_test;
        open_validation_selections := select_file_org;
      ELSE
*IFEND
        open_command_file := TRUE;
        cmnd_file_access_options := one_option_read;
        open_executable_cmnd_file := TRUE;
        exec_cmnd_file_access_options := one_option_execute;
        command_file_test := include_file;
        callable_file_test := execute_bracket;
*IF NOT $true(osv$unix)
        open_validation_selections := select_incf_file_org;
      IFEND;
*IFEND

      file_organization_test := TRUE;
      execute_access_test := FALSE;
      fap_not_allowed_test := FALSE;
      access_level := amc$record;
      fetch_attributes := TRUE;
      caller_file := FALSE;

*IF NOT $true(osv$unix)
    = clc$incf_segment_caller_file =
      establish_incf_caller_tests;
      file_organization_test := FALSE;
      access_level := amc$segment;
      open_validation_selections := no_selections;

    = clc$incf_record_caller_file =
      establish_incf_caller_tests;
      file_organization_test := TRUE;
      access_level := amc$record;
      open_validation_selections := select_file_org;

    = clc$get_file =
      establish_get_file_tests;
      file_organization_test := TRUE;
      access_level := amc$record;
      open_validation_selections := select_file_org;
      caller_file := FALSE;

    = clc$get_segment_caller_file =
      establish_get_file_tests;
      file_organization_test := FALSE;
      access_level := amc$segment;
      open_validation_selections := no_selections;
      caller_file := TRUE;

    = clc$get_record_caller_file =
      establish_get_file_tests;
      file_organization_test := TRUE;
      access_level := amc$record;
      open_validation_selections := select_file_org;
      caller_file := TRUE;

    = clc$catalog_command =
      get_attributes [1].key := amc$ring_attributes;
      get_attributes [2].key := amc$record_type;
      get_attributes [3].key := amc$block_type;
      get_attributes [4].key := amc$access_mode;
      get_attributes [5].key := amc$global_access_mode;
      get_attributes [6].key := amc$max_record_length;
      get_attributes [7].key := amc$line_number;
      get_attributes [8].key := amc$statement_identifier;
      get_attributes [9].key := amc$file_access_procedure;
      get_attributes [10].key := amc$file_contents;
      get_attributes [11].key := amc$file_structure;

      amp$get_file_attributes (file_reference, get_attributes, ignore_local_file, existing_file,
            ignore_contains_data, status);

      IF NOT status.normal THEN
        file_contents.path_exists := FALSE;
        RETURN;
      IFEND;

      IF NOT existing_file THEN
        file_contents.path_exists := FALSE;
        osp$set_status_abnormal ('CL', cle$not_a_command_file, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, file_reference, status);
        RETURN;
      IFEND;

{ The decision to open the file, the file_organization_test, and the execute_access_test
{ are determined in the command_file_test.

      command_file_test := proc_or_object_file_or_lib;
      callable_file_test := call_bracket;
      fap_not_allowed_test := TRUE;
      open_validation_selections := select_file_org_fap;
      fetch_attributes := FALSE;
      caller_file := FALSE;
      file_contents.is_object := get_attributes [10].file_contents = amc$object;

    = clc$command_library =
      determine_open_choices;
      command_file_test := object_library;
      file_organization_test := FALSE;
      callable_file_test := no_callable_file_test;
      execute_access_test := FALSE;
      fap_not_allowed_test := TRUE;
      access_level := amc$segment;
      open_validation_selections := select_object_lib_fap;
      fetch_attributes := TRUE;
      caller_file := FALSE;

    = clc$submit_job =

{ It is known that the caller ring is ring 3.

      open_command_file := TRUE;
      allowed_device_classes := $fst$device_classes [fsc$mass_storage_device];
      cmnd_file_access_options := all_options;
      command_file_test := include_file;
      file_organization_test := TRUE;
      callable_file_test := call_bracket;
      execute_access_test := FALSE;
      fap_not_allowed_test := TRUE;
      access_level := amc$record;
      open_validation_selections := select_incf_file_org_fap;
      fetch_attributes := TRUE;
      caller_file := FALSE;
*IFEND

    ELSE
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$access_command_file', status);
      RETURN;
    CASEND;

*IF NOT $true(osv$unix)
    IF open_validation_selections = no_selections THEN
      attribute_validation := NIL;
    ELSE
      PUSH attribute_validation: [1 .. open_validation_selections];
      attribute_index := 0;
    IFEND;

    CASE command_file_test OF
    = include_file =
      FOR attribute_index := 1 TO 5 DO
        attribute_validation^ [attribute_index].selector := fsc$file_contents_and_processor;
        attribute_validation^ [attribute_index].file_processor := osc$null_name;
      FOREND;
      IF command_file = clc$submit_job THEN
        attribute_validation^ [1].file_contents := fsc$legible_scl_job;
      ELSE
        attribute_validation^ [1].file_contents := fsc$legible_scl_include;
      IFEND;
      attribute_validation^ [2].file_contents := fsc$legible_data;
      attribute_validation^ [3].file_contents := amc$legible;
      attribute_validation^ [4].file_contents := fsc$data;
      attribute_validation^ [5].file_contents := fsc$unknown_contents;
      attribute_index := 5;

    = object_library =
      attribute_validation^ [1].selector := fsc$file_contents_and_processor;
      attribute_validation^ [1].file_contents := fsc$object_library;
      attribute_validation^ [1].file_processor := osc$null_name;
      attribute_index := 1;

    = proc_or_object_file_or_lib =
      fsp$convert_to_new_contents (get_attributes [10].file_contents, get_attributes [11].file_structure,
            fs_file_contents, ignore_file_contents_truncated);
      IF (fs_file_contents = fsc$object_library) OR (fs_file_contents = fsc$object_data) THEN
        file_organization_test := FALSE;
        execute_access_test := TRUE;
        access_level := amc$segment;
      ELSEIF (fs_file_contents = fsc$legible_scl_procedure) OR (fs_file_contents = fsc$legible_data) OR
            (fs_file_contents = amc$legible) OR (fs_file_contents = fsc$data) OR (fs_file_contents =
            fsc$unknown_contents) THEN
        determine_open_choices;
        file_organization_test := TRUE;
        callable_file_test := execute_bracket; { Currently no "ring switch" for procs.
        execute_access_test := FALSE;
        access_level := amc$record;
      ELSE
        osp$set_status_abnormal ('CL', cle$not_a_command_file, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, file_reference, status);
        RETURN;
      IFEND;

    ELSE
      ;
    CASEND;

    IF file_organization_test THEN
      attribute_index := attribute_index + 1;
      attribute_validation^ [attribute_index].selector := fsc$file_organization;
      attribute_validation^ [attribute_index].file_organization := amc$sequential;
    IFEND;

    IF fap_not_allowed_test THEN
      fap_null_name.entry_point := osc$null_name;
      fap_null_name.object_library := ' ';
      attribute_index := attribute_index + 1;
      attribute_validation^ [attribute_index].selector := fsc$file_access_procedure_name;
      attribute_validation^ [attribute_index].file_access_procedure_name := ^fap_null_name;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);
*IFEND
*IF $true(osv$unix)
    handler_established := #establish_condition_handler (-1, ^abort_handler);
*IFEND

    IF open_command_file THEN
      establish_file_access_modes (cmnd_file_access_options);
*IF NOT $true(osv$unix)
      clp$open_command_file (file_reference, job_mode, access_level, file_access_modes, attribute_validation,
            allowed_device_classes, file_id, segment, status);
*ELSE
      clp$open_command_file (file_reference, access_level, file_access_modes, attribute_validation,
            file_id, segment, status);
*IFEND
      opened_executable_file := FALSE;
*IF NOT $true(osv$unix)
      #SPOIL (opened_executable_file);
*IFEND
    IFEND;

*IF NOT $true(osv$unix)
    IF open_executable_cmnd_file THEN
      IF (NOT open_command_file) OR ((NOT status.normal) AND
            (status.condition = cle$command_file_not_executable)) THEN
        establish_file_access_modes (exec_cmnd_file_access_options);
        clp$open_executable_cmnd_file (file_reference, job_mode, access_level, file_access_modes,
              attribute_validation, file_id, segment, status);
        opened_executable_file := TRUE;
        #SPOIL (opened_executable_file);
      ELSE
        callable_file_test := no_callable_file_test;
      IFEND;
    IFEND;
*IFEND

    IF NOT status.normal THEN
*IF NOT $true(osv$unix)
      IF status.condition = ame$attribute_validation_error THEN
        status.condition := cle$improper_command_file_attr;
      ELSEIF status.condition = cle$command_file_not_executable THEN
*ELSE
      IF status.condition = cle$command_file_not_executable THEN
*IFEND

        CASE command_file OF
        = clc$get_file, clc$get_segment_caller_file, clc$get_record_caller_file =
*IF NOT $true(osv$unix)
          fsp$set_file_reference_abnormal (file_reference, ame$no_permission_for_access,
                amc$open_req, 'READ', status);
*IFEND
        ELSE
          ;
        CASEND;

      IFEND;
*IF $true(osv$unix)
      IF handler_established THEN
        handler_established := NOT #disestablish_condition_handler (-1);
      IFEND;
*ELSE
      osp$disestablish_cond_handler;
*IFEND
      RETURN;
    IFEND;

  /file_tests/
    BEGIN
      IF open_command_file OR open_executable_cmnd_file THEN
*IF NOT $true(osv$unix)
        bap$get_phn_via_file_id (file_id, open_path_handle_name, status);
        IF NOT status.normal THEN
          EXIT /file_tests/;
        IFEND;
*ELSE
        open_path_handle_name := file_reference;
*IFEND
      IFEND;

*IF NOT $true(osv$unix)
      IF fetch_attributes THEN
        fsp$get_open_information (file_id, ^attachment_information,
              ^catalog_information, ^cycle_attribute_sources,
              ^cycle_attribute_values, ^instance_information,
              NIL, NIL, user_defined_attribute_size, status);
        IF NOT status.normal THEN
          EXIT /file_tests/;
        IFEND;
        device_class := catalog_information.cycle_registration.residence.device_class;
      ELSE
        rmp$get_device_class (file_reference, device_assigned, device_class, status);
        IF NOT status.normal THEN
          EXIT /file_tests/;
        IFEND;
*ELSE
        fsp$get_open_information (file_id, device_class);
*IFEND
*IF NOT $true(osv$unix)
        catalog_information.cycle_registration.ring_attributes := get_attributes [1].ring_attributes;
        cycle_attribute_values.record_type := get_attributes [2].record_type;
        cycle_attribute_values.block_type := get_attributes [3].block_type;
        #unchecked_conversion (get_attributes [4].access_mode,
              instance_information.attachment_information.access_modes);
        #unchecked_conversion (get_attributes [5].global_access_mode,
              attachment_information.administration_information.attached_access_modes);
        cycle_attribute_values.max_record_length := get_attributes [6].max_record_length;
        cycle_attribute_sources.line_number := get_attributes [7].source;
        cycle_attribute_values.line_number := get_attributes [7].line_number;
        cycle_attribute_sources.statement_identifier := get_attributes [8].source;
        cycle_attribute_values.statement_identifier := get_attributes [8].statement_identifier;
        cycle_attribute_values.file_access_procedure_name.entry_point :=
              get_attributes [9].file_access_procedure;
      IFEND;

      ring_attributes := catalog_information.cycle_registration.ring_attributes;
      file_has_fap := cycle_attribute_values.file_access_procedure_name.entry_point <> osc$null_name;
      IF submitter_ring > caller_id.ring THEN
        caller_id.ring := submitter_ring;
      IFEND;

      IF file_organization_test AND (cycle_attribute_values.record_type = amc$undefined) AND
            (cycle_attribute_values.block_type = amc$system_specified) THEN
        fsp$set_file_reference_abnormal (file_reference, cle$improper_command_file_attr,
              amc$open_req, 'record_type = undefined', status);
        EXIT /file_tests/;
      IFEND;

      CASE callable_file_test OF
      = call_bracket =
        IF caller_id.ring > catalog_information.cycle_registration.ring_attributes.r3 THEN
          osp$set_status_abnormal ('CL', cle$command_file_not_callable, '', status);
          osp$append_status_file (osc$status_parameter_delimiter, file_reference, status);
          EXIT /file_tests/;
        IFEND;

      = execute_bracket =
        IF (caller_id.ring < catalog_information.cycle_registration.ring_attributes.r1) OR
              (caller_id.ring > catalog_information.cycle_registration.ring_attributes.r2) THEN
          osp$set_status_abnormal ('CL', cle$command_file_not_callable, '', status);
          osp$append_status_file (osc$status_parameter_delimiter, file_reference, status);
          EXIT /file_tests/;
        IFEND;

      ELSE
        ;
      CASEND;

      IF execute_access_test AND (NOT (fsc$execute IN instance_information.
        attachment_information.access_modes)) THEN
        osp$set_status_abnormal ('CL', cle$command_file_not_executable, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, file_reference, status);
        EXIT /file_tests/;
      IFEND;
*IFEND

    END /file_tests/;

    IF file_id <> amv$nil_file_identifier THEN
      IF status.normal AND (NOT caller_file) THEN
*IF NOT $true(osv$unix)
        can_be_echoed := (file_reference = clv$standard_files [clc$sf_command_file].path_handle_name) OR
              ((fsc$read IN attachment_information.administration_information.attached_access_modes) AND
              (caller_id.ring <= catalog_information.cycle_registration.ring_attributes.r3));

*IFEND
        IF access_level = amc$record THEN
*IF NOT $true(osv$unix)
          clp$determine_line_layout (file_reference, cycle_attribute_values.record_type,
                cycle_attribute_values.max_record_length, cycle_attribute_sources.line_number
                <> amc$undefined_attribute, cycle_attribute_values.line_number,
                cycle_attribute_sources.statement_identifier <> amc$undefined_attribute,
                cycle_attribute_values.statement_identifier, line_layout, status);
*ELSE
          clp$determine_line_layout (file_reference, line_layout, status);
*IFEND
        IFEND;
      IFEND;

      IF NOT status.normal THEN
        clp$close_command_file (file_id, opened_executable_file, ignore_status);
      IFEND;
    IFEND;

*IF $true(osv$unix)
    IF handler_established THEN
      handler_established := NOT #disestablish_condition_handler (-1);
    IFEND;
*ELSE
    osp$disestablish_cond_handler;
*IFEND

  PROCEND clp$access_command_file;

MODEND clm$access_command_file;
*DECK DECK=CLM$ACCESS_PARAMETERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Parameter Access Requests' ??
MODULE clm$access_parameters;

{
{ PURPOSE:
{   This module contains the procedures that retrieve information about the parameters for a command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_limits
*copyc cld$value
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_parameter_list
*copyc cle$not_supported
*copyc cle$unexpected_value_type
*copyc clk$procedure_keypoints
*copyc clt$expression_eval_method
*copyc clv$type_kind_names
*copyc clv$value_descriptors
*copyc clv$value_type_kinds
*copyc oss$job_paged_literal
*copyc ost$name_reference
*copyc ost$status
*copyc osv$lower_to_upper
?? POP ??
*copyc clp$append_status_value_type
*copyc clp$convert_int_value_to_ext
*copyc clp$convert_value_to_clt$value
*copyc clp$data_representation_text
*copyc clp$find_current_block
*copyc clp$get_single_data_value
*copyc clp$get_single_internal_value
*copyc clp$get_variable
*copyc clp$get_work_area
*copyc clp$internal_convert_to_string
*copyc clp$make_clt$value
*copyc clp$make_string_value
*copyc clp$make_unspecified_value
*copyc clp$read_qualified_data_value
*copyc clp$read_variable
*copyc clp$search_parameter_names
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal

?? TITLE := 'clp$test_parameter', EJECT ??
*copyc clh$test_parameter

  PROCEDURE [XDCL, #GATE] clp$test_parameter
    (    parameter_name: string ( * );
     VAR parameter_specified: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      found: boolean,
      name: clt$parameter_name,
      name_index: clt$parameter_name_index,
      parameter_number: clt$parameter_number;


    #KEYPOINT (osk$entry, 0, clk$test_parameter);

  /test_parameter/
    BEGIN

      status.normal := TRUE;
      find_parameters_block ('clp$test_parameter', block, status);
      IF NOT status.normal THEN
        EXIT /test_parameter/;
      IFEND;
      IF (block^.parameters.names = NIL) OR (block^.parameters.parameter_value_table = NIL) THEN
        osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$test_parameter', status);
        EXIT /test_parameter/;
      IFEND;
      #TRANSLATE (osv$lower_to_upper, parameter_name, name);
      clp$search_parameter_names (name, block^.parameters.names, name_index, found);
      IF NOT found THEN
        osp$set_status_abnormal ('CL', cle$unknown_parameter_name, name, status);
        EXIT /test_parameter/;
      IFEND;
      parameter_number := block^.parameters.names^ [name_index].position;
      parameter_specified := block^.parameters.parameter_value_table^ [parameter_number].specified;

    END /test_parameter/;

    #KEYPOINT (osk$exit, 0, clk$test_parameter);

  PROCEND clp$test_parameter;
?? TITLE := 'clp$get_set_count', EJECT ??
*copyc clh$get_set_count

  PROCEDURE [XDCL, #GATE] clp$get_set_count
    (    parameter_name: string ( * );
     VAR value_set_count: 0 .. clc$max_value_sets;
     VAR status: ost$status);

    VAR
      value: ^clt$parameter_value;


    #KEYPOINT (osk$entry, 0, clk$get_set_count);

  /get_set_count/
    BEGIN

      status.normal := TRUE;
      get_parameter_value ('clp$get_set_count', parameter_name, value, status);
      value_set_count := 0;
      IF NOT status.normal THEN
        EXIT /get_set_count/;
      ELSEIF value^.passing_method = clc$pass_by_reference THEN
        IF value^.variable <> NIL THEN
          value_set_count := 1;
        IFEND;
        EXIT /get_set_count/;
      ELSEIF value^.value = NIL THEN
        EXIT /get_set_count/;
      ELSEIF value^.value^.kind <> clc$list THEN
        value_set_count := 1;
        EXIT /get_set_count/;
      IFEND;
      get_value_element_count (value^.value, value_set_count);

    END /get_set_count/;
    #KEYPOINT (osk$exit, 0, clk$get_set_count);

  PROCEND clp$get_set_count;
?? TITLE := 'clp$get_value_count', EJECT ??
*copyc clh$get_value_count

  PROCEDURE [XDCL, #GATE] clp$get_value_count
    (    parameter_name: string ( * );
         value_set_number: 1 .. clc$max_value_sets;
     VAR value_count: 0 .. clc$max_values_per_set;
     VAR status: ost$status);

    VAR
      data_value: ^clt$data_value,
      value: ^clt$parameter_value;


    #KEYPOINT (osk$entry, 0, clk$get_value_count);

  /get_val_count/
    BEGIN

      status.normal := TRUE;
      get_parameter_value ('clp$get_value_count', parameter_name, value, status);
      value_count := 0;
      IF NOT status.normal THEN
        EXIT /get_val_count/;
      ELSEIF value^.passing_method = clc$pass_by_reference THEN
        IF (value^.variable <> NIL) AND (value_set_number = 1) THEN
          value_count := 1;
        IFEND;
        EXIT /get_val_count/;
      ELSEIF value^.value = NIL THEN
        EXIT /get_val_count/;
      ELSEIF value^.value^.kind <> clc$list THEN
        IF value_set_number = 1 THEN
          value_count := 1;
        IFEND;
        EXIT /get_val_count/;
      IFEND;
      data_value := value^.value;
      get_value_element (value_set_number, data_value);
      IF data_value = NIL THEN
        EXIT /get_val_count/;
      ELSEIF data_value^.kind <> clc$list THEN
        value_count := 1;
        EXIT /get_val_count/;
      IFEND;
      get_value_element_count (data_value, value_count);

    END /get_val_count/;
    #KEYPOINT (osk$exit, 0, clk$get_value_count);

  PROCEND clp$get_value_count;
?? TITLE := 'clp$test_range', EJECT ??
*copyc clh$test_range

  PROCEDURE [XDCL, #GATE] clp$test_range
    (    parameter_name: string ( * );
         value_set_number: 1 .. clc$max_value_sets;
         value_number: 1 .. clc$max_values_per_set;
     VAR range_specified: boolean;
     VAR status: ost$status);

    VAR
      data_value: ^clt$data_value,
      value: ^clt$parameter_value;


    #KEYPOINT (osk$entry, 0, clk$test_range);

  /test_rng/
    BEGIN

      status.normal := TRUE;
      get_parameter_value ('clp$test_range', parameter_name, value, status);
      range_specified := FALSE;
      IF (NOT status.normal) OR (value = NIL) THEN
        EXIT /test_rng/;
      ELSEIF value^.passing_method = clc$pass_by_reference THEN
        EXIT /test_rng/;
      ELSEIF value^.value = NIL THEN
        EXIT /test_rng/;
      ELSEIF value^.value^.kind <> clc$list THEN
        IF (value_set_number <> 1) OR (value_number <> 1) THEN
          EXIT /test_rng/;
        IFEND;
        data_value := value^.value;
      ELSE
        data_value := value^.value;
        get_value_element (value_set_number, data_value);
        IF data_value = NIL THEN
          EXIT /test_rng/;
        ELSEIF data_value^.kind = clc$list THEN
          get_value_element (value_number, data_value);
        ELSEIF value_number <> 1 THEN
          EXIT /test_rng/;
        IFEND;
      IFEND;

      range_specified := (data_value^.kind = clc$range) AND (data_value^.low_value <> data_value^.high_value);

    END /test_rng/;
    #KEYPOINT (osk$exit, 0, clk$test_range);

  PROCEND clp$test_range;
?? TITLE := 'clp$get_value', EJECT ??
*copyc clh$get_value

  PROCEDURE [XDCL, #GATE] clp$get_value
    (    parameter_name: string ( * );
         value_set_number: 1 .. clc$max_value_sets;
         value_number: 1 .. clc$max_values_per_set;
         low_or_high: clt$low_or_high;
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      parameter_value: ^clt$parameter_value,
      variable_reference: clt$variable_reference;

    #KEYPOINT (osk$entry, 0, clk$get_value);

  /get_val/
    BEGIN

      status.normal := TRUE;
      get_parameter_value ('clp$get_value', parameter_name, parameter_value, status);
      IF NOT status.normal THEN
        EXIT /get_val/;
      ELSEIF parameter_value^.passing_method = clc$pass_by_reference THEN
        IF parameter_value^.variable = NIL THEN
          clp$make_clt$value (clc$unknown_value, value);
        ELSE
          clp$read_variable (parameter_value^.variable^, variable_reference, status);
          IF status.normal THEN
            clp$make_clt$value (clc$variable_reference, value);
            value.var_ref := variable_reference;
          IFEND;
        IFEND;
      ELSE
        clp$convert_value_to_clt$value (parameter_value^.value, value_set_number, value_number, low_or_high,
              value, status);
      IFEND;

    END /get_val/;
    #KEYPOINT (osk$exit, 0, clk$get_value);

  PROCEND clp$get_value;
?? TITLE := 'clp$get_parameter', EJECT ??
*copyc clh$get_parameter

  PROCEDURE [XDCL, #GATE] clp$get_parameter
    (    parameter_name: string ( * );
     VAR value_list: ost$string;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      original_work_area: ^clt$work_area,
      representation: ^clt$data_representation,
      representation_text: ^clt$string_value,
      request: clt$convert_to_string_request,
      value: ^clt$parameter_value,
      work_area: ^^clt$work_area;


    #KEYPOINT (osk$entry, 0, clk$get_parameter);

  /get_parameter/
    BEGIN

      status.normal := TRUE;
      find_parameters_block ('clp$get_parameter', block, status);
      IF NOT status.normal THEN
        EXIT /get_parameter/;
      IFEND;
      IF (block^.parameters.names = NIL) OR (block^.parameters.parameter_value_table = NIL) THEN
        osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$get_parameter', status);
        EXIT /get_parameter/;
      IFEND;
      get_parameter_value ('clp$get_parameter', parameter_name, value, status);
      IF NOT status.normal THEN
        EXIT /get_parameter/;
      ELSEIF value^.passing_method = clc$pass_by_reference THEN
        IF value^.variable = NIL THEN
          value_list.size := 0;
          value_list.value := '';
        ELSE
          IF STRLENGTH (value^.variable^) <= osc$max_string_size THEN
            value_list.size := STRLENGTH (value^.variable^);
          ELSE
            value_list.size := osc$max_string_size;
          IFEND;
          value_list.value := value^.variable^;
        IFEND;
        EXIT /get_parameter/;
      ELSEIF value^.value = NIL THEN
        value_list.size := 0;
        value_list.value := '';
        EXIT /get_parameter/;
      IFEND;

      clp$get_work_area (#RING (^work_area), work_area, status);
      IF NOT status.normal THEN
        EXIT /get_parameter/;
      IFEND;
      original_work_area := work_area^;

      request.initial_indentation := 0;
      request.continuation_indentation := 0;
      request.max_string := clc$max_string_size;
      request.include_advanced_items := TRUE;
      request.include_hidden_items := TRUE;
      request.kind := clc$convert_data_value;
      request.representation_option := clc$data_source_representation;
      request.value := value^.value;

      clp$internal_convert_to_string (request, work_area^, representation, status);
      IF NOT status.normal THEN
        work_area^ := original_work_area;
        EXIT /get_parameter/;
      IFEND;
      representation_text := clp$data_representation_text (representation);

      IF STRLENGTH (representation_text^) <= osc$max_string_size THEN
        value_list.size := STRLENGTH (representation_text^);
      ELSE
        value_list.size := osc$max_string_size;
      IFEND;
      value_list.value := representation_text^;
      work_area^ := original_work_area;

    END /get_parameter/;
    #KEYPOINT (osk$exit, 0, clk$get_parameter);

  PROCEND clp$get_parameter;
?? TITLE := 'clp$get_parameter_list', EJECT ??
*copyc clh$get_parameter_list

  PROCEDURE [XDCL, #GATE] clp$get_parameter_list
    (VAR parameter_list: ost$string;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      original_work_area: ^clt$work_area,
      representation: ^clt$data_representation,
      representation_text: ^clt$string_value,
      request: clt$convert_to_string_request,
      work_area: ^^clt$work_area;


    #KEYPOINT (osk$entry, 0, clk$get_parameter_list);

  /get_parameter_list/
    BEGIN

      status.normal := TRUE;
      find_parameters_block ('clp$get_parameter_list', block, status);
      IF NOT status.normal THEN
        EXIT /get_parameter_list/;
      IFEND;
      IF (block^.parameters.names = NIL) OR (block^.parameters.parameter_value_table = NIL) THEN
        parameter_list.size := 0;
        parameter_list.value := '';
        RETURN;
      IFEND;
      clp$get_work_area (#RING (^work_area), work_area, status);
      IF NOT status.normal THEN
        EXIT /get_parameter_list/;
      IFEND;
      original_work_area := work_area^;
      request.initial_indentation := 0;
      request.continuation_indentation := 0;
      request.max_string := clc$max_string_size;
      request.include_advanced_items := TRUE;
      request.include_hidden_items := TRUE;
      request.kind := clc$convert_parameters;
      request.initial_text := NIL;
      request.include_secure_parameters := TRUE;
      request.evaluated_pdt := block^.parameters.unbundled_pdt;
      request.evaluated_pvt := block^.parameters.parameter_value_table;
      request.parameter_substitutions := NIL;
      clp$internal_convert_to_string (request, work_area^, representation, status);
      IF NOT status.normal THEN
        work_area^ := original_work_area;
        EXIT /get_parameter_list/;
      IFEND;

      representation_text := clp$data_representation_text (representation);
      IF STRLENGTH (representation_text^) <= osc$max_string_size THEN
        parameter_list.size := STRLENGTH (representation_text^);
      ELSE
        parameter_list.size := osc$max_string_size;
      IFEND;
      parameter_list.value := representation_text^;
      work_area^ := original_work_area;

    END /get_parameter_list/;
    #KEYPOINT (osk$exit, 0, clk$get_parameter_list);

  PROCEND clp$get_parameter_list;
?? TITLE := 'clp$test_proc_parameter', EJECT ??

  PROCEDURE [XDCL] clp$test_proc_parameter
    (    parameter_name: string ( * );
     VAR parameter_specified: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      found: boolean,
      name_index: clt$parameter_name_index,
      parameter_number: clt$parameter_number;


    find_proc_parameters_block ('$SPECIFIED', block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (block^.parameters.names = NIL) OR (block^.parameters.accesses = NIL) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, '$SPECIFIED', status);
      RETURN;
    IFEND;
    clp$search_parameter_names (parameter_name, block^.parameters.names, name_index, found);
    IF NOT found THEN
      osp$set_status_abnormal ('CL', cle$unknown_parameter_name, parameter_name, status);
    ELSE
      parameter_number := block^.parameters.names^ [name_index].position;
      parameter_specified := block^.parameters.accesses^ [parameter_number].specified;
    IFEND;

  PROCEND clp$test_proc_parameter;
?? TITLE := 'clp$get_proc_set_count', EJECT ??

  PROCEDURE [XDCL] clp$get_proc_set_count
    (    parameter_name: string ( * );
     VAR work_area {input, output} : ^clt$work_area;
     VAR value_set_count: 0 .. clc$max_value_sets;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      data_value: ^clt$data_value,
      found: boolean,
      i_value: ^clt$i_data_value,
      internal_value: ^clt$internal_data_value,
      name_index: clt$parameter_name_index,
      parameter_number: clt$parameter_number;


    find_proc_parameters_block ('$SET_COUNT', block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (block^.parameters.names = NIL) OR (block^.parameters.accesses = NIL) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, '$SET_COUNT', status);
      RETURN;
    IFEND;
    clp$search_parameter_names (parameter_name, block^.parameters.names, name_index, found);
    IF NOT found THEN
      osp$set_status_abnormal ('CL', cle$unknown_parameter_name, parameter_name, status);
      RETURN;
    IFEND;
    parameter_number := block^.parameters.names^ [name_index].position;
    IF block^.parameters.accesses^ [parameter_number].info.access_mode = clc$read_only THEN
      get_proc_parameter_value (parameter_name, parameter_number, block, work_area, data_value,
            internal_value, i_value, status);
      IF status.normal THEN
        IF data_value <> NIL THEN
          get_value_element_count (data_value, value_set_count);
        ELSEIF i_value <> NIL THEN
          get_int_value_element_count (internal_value, i_value, value_set_count);
        ELSE
          value_set_count := 0;
        IFEND;
      IFEND;
    ELSE
      IF block^.parameters.accesses^ [parameter_number].info.descriptor = NIL THEN
        value_set_count := 0;
      ELSE
        value_set_count := 1;
      IFEND;
    IFEND;

  PROCEND clp$get_proc_set_count;
?? TITLE := 'clp$get_proc_value_count', EJECT ??

  PROCEDURE [XDCL] clp$get_proc_value_count
    (    parameter_name: string ( * );
         value_set_number: 1 .. clc$max_value_sets;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value_count: 0 .. clc$max_values_per_set;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      current_node: ^clt$data_value,
      data_value: ^clt$data_value,
      found: boolean,
      i_value: ^clt$i_data_value,
      internal_value: ^clt$internal_data_value,
      kind: clt$data_kind,
      name_index: clt$parameter_name_index,
      parameter_number: clt$parameter_number,
      value_set_index: 0 .. clc$max_value_sets;


    status.normal := TRUE;
    find_proc_parameters_block ('$VALUE_COUNT', block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (block^.parameters.names = NIL) OR (block^.parameters.accesses = NIL) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, '$VALUE_COUNT', status);
      RETURN;
    IFEND;
    clp$search_parameter_names (parameter_name, block^.parameters.names, name_index, found);
    IF NOT found THEN
      osp$set_status_abnormal ('CL', cle$unknown_parameter_name, parameter_name, status);
      RETURN;
    IFEND;
    parameter_number := block^.parameters.names^ [name_index].position;
    IF block^.parameters.accesses^ [parameter_number].info.access_mode = clc$read_only THEN
      get_proc_parameter_value (parameter_name, parameter_number, block, work_area, data_value,
            internal_value, i_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF data_value <> NIL THEN
        kind := data_value^.kind;
      ELSEIF i_value <> NIL THEN
        kind := i_value^.kind;
      ELSE
        kind := clc$unspecified;
      IFEND;
      IF kind = clc$unspecified THEN
        value_count := 0;
        RETURN;
      ELSEIF kind <> clc$list THEN
        IF value_set_number = 1 THEN
          value_count := 1;
        ELSE
          value_count := 0;
        IFEND;
        RETURN;
      IFEND;
      IF data_value <> NIL THEN
        get_value_element (value_set_number, data_value);
      ELSEIF i_value <> NIL THEN
        get_internal_value_element (value_set_number, internal_value, i_value);
      IFEND;
      IF data_value <> NIL THEN
        kind := data_value^.kind;
      ELSEIF i_value <> NIL THEN
        kind := i_value^.kind;
      ELSE
        kind := clc$unspecified;
      IFEND;
      IF kind = clc$unspecified THEN
        value_count := 0;
      ELSE
        IF data_value <> NIL THEN
          get_value_element_count (data_value, value_count);
        ELSEIF i_value <> NIL THEN
          get_int_value_element_count (internal_value, i_value, value_count);
        ELSE
          value_count := 0;
        IFEND;
      IFEND;
    ELSE
      IF (block^.parameters.accesses^ [parameter_number].info.descriptor = NIL) OR
            (value_set_number <> 1) THEN
        value_count := 0;
      ELSE
        value_count := 1;
      IFEND;
    IFEND;

  PROCEND clp$get_proc_value_count;
?? TITLE := 'clp$test_proc_range', EJECT ??

  PROCEDURE [XDCL] clp$test_proc_range
    (    parameter_name: string ( * );
         value_set_number: 1 .. clc$max_value_sets;
         value_number: 1 .. clc$max_values_per_set;
     VAR work_area {input, output} : ^clt$work_area;
     VAR range_specified: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      data_value: ^clt$data_value,
      found: boolean,
      i_value: ^clt$i_data_value,
      internal_value: ^clt$internal_data_value,
      kind: clt$data_kind,
      name_index: clt$parameter_name_index,
      parameter_number: clt$parameter_number;


    range_specified := FALSE;
    find_proc_parameters_block ('$RANGE', block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (block^.parameters.names = NIL) OR (block^.parameters.accesses = NIL) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, '$RANGE', status);
      RETURN;
    IFEND;
    clp$search_parameter_names (parameter_name, block^.parameters.names, name_index, found);
    IF NOT found THEN
      osp$set_status_abnormal ('CL', cle$unknown_parameter_name, parameter_name, status);
      RETURN;
    IFEND;
    parameter_number := block^.parameters.names^ [name_index].position;
    IF block^.parameters.accesses^ [parameter_number].info.access_mode = clc$read_write THEN
      RETURN;
    IFEND;
    get_proc_parameter_value (parameter_name, parameter_number, block, work_area, data_value, internal_value,
          i_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF data_value <> NIL THEN
      kind := data_value^.kind;
    ELSEIF i_value <> NIL THEN
      kind := i_value^.kind;
    ELSE
      kind := clc$unspecified;
    IFEND;
    IF kind = clc$unspecified THEN
      RETURN;
    IFEND;
    IF data_value <> NIL THEN
      get_value_element (value_set_number, data_value);
    ELSEIF i_value <> NIL THEN
      get_internal_value_element (value_set_number, internal_value, i_value);
    IFEND;
    IF data_value <> NIL THEN
      kind := data_value^.kind;
    ELSEIF i_value <> NIL THEN
      kind := i_value^.kind;
    ELSE
      kind := clc$unspecified;
    IFEND;
    IF kind = clc$unspecified THEN
      RETURN;
    IFEND;
    IF data_value <> NIL THEN
      get_value_element (value_number, data_value);
    ELSEIF i_value <> NIL THEN
      get_internal_value_element (value_number, internal_value, i_value);
    IFEND;
    IF data_value <> NIL THEN
      kind := data_value^.kind;
    ELSEIF i_value <> NIL THEN
      kind := i_value^.kind;
    ELSE
      kind := clc$unspecified;
    IFEND;
    IF kind <> clc$range THEN
      RETURN;
    IFEND;
    IF data_value <> NIL THEN
      range_specified := data_value^.high_value <> data_value^.low_value;
    ELSEIF i_value <> NIL THEN
      range_specified := i_value^.high_value <> i_value^.low_value;
    IFEND;

  PROCEND clp$test_proc_range;
?? TITLE := 'clp$get_proc_value', EJECT ??

  PROCEDURE [XDCL] clp$get_proc_value
    (    parameter_name: string ( * );
         value_set_number: 1 .. clc$max_value_sets;
         value_number: 1 .. clc$max_values_per_set;
         low_or_high: clt$low_or_high;
     VAR work_area {input, output} : ^clt$work_area;
     VAR access_mode: clt$data_access_mode;
     VAR value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      internal_component: REL (clt$internal_data_value) ^clt$i_data_value,
      found: boolean,
      i_value: ^clt$i_data_value,
      internal_value: ^clt$internal_data_value,
      name_index: clt$parameter_name_index,
      parameter_number: clt$parameter_number;


    status.normal := TRUE;
    value := NIL;
    find_proc_parameters_block ('$VALUE', block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (block^.parameters.names = NIL) OR (block^.parameters.accesses = NIL) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, '$VALUE', status);
      RETURN;
    IFEND;
    clp$search_parameter_names (parameter_name, block^.parameters.names, name_index, found);
    IF NOT found THEN
      osp$set_status_abnormal ('CL', cle$unknown_parameter_name, parameter_name, status);
      RETURN;
    IFEND;
    parameter_number := block^.parameters.names^ [name_index].position;
    access_mode := block^.parameters.accesses^ [parameter_number].info.access_mode;
    IF access_mode = clc$read_write THEN
      RETURN;
    IFEND;
    get_proc_parameter_value (parameter_name, parameter_number, block, work_area, value, internal_value,
          i_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value <> NIL THEN
      clp$get_single_data_value (value_set_number, value_number, low_or_high, value, status);
    ELSEIF i_value <> NIL THEN
      internal_component := #REL (i_value, internal_value^);
      clp$get_single_internal_value (internal_value, value_set_number, value_number, low_or_high,
            internal_component, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$convert_int_value_to_ext (internal_value, internal_component, work_area, value, status);
    ELSE
      clp$make_unspecified_value (work_area, value);
      IF value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

  PROCEND clp$get_proc_value;
?? TITLE := 'clp$get_proc_value_kind', EJECT ??

  PROCEDURE [XDCL] clp$get_proc_value_kind
    (    parameter_name: string ( * );
         value_set_number: 1 .. clc$max_value_sets;
         value_number: 1 .. clc$max_values_per_set;
         low_or_high: clt$low_or_high;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      internal_component: REL (clt$internal_data_value) ^clt$i_data_value,
      found: boolean,
      header: ^clt$type_specification_header,
      i_value: ^clt$i_data_value,
      internal_value: ^clt$internal_data_value,
      kind: clt$data_kind,
      name_index: clt$parameter_name_index,
      parameter_number: clt$parameter_number,
      specification: ^clt$type_specification,
      value: ^clt$data_value;


    status.normal := TRUE;
    find_proc_parameters_block ('$VALUE_KIND', block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (block^.parameters.names = NIL) OR (block^.parameters.accesses = NIL) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, '$VALUE_KIND', status);
      RETURN;
    IFEND;
    clp$search_parameter_names (parameter_name, block^.parameters.names, name_index, found);
    IF NOT found THEN
      osp$set_status_abnormal ('CL', cle$unknown_parameter_name, parameter_name, status);
      RETURN;
    IFEND;
    parameter_number := block^.parameters.names^ [name_index].position;
    IF block^.parameters.accesses^ [parameter_number].info.access_mode = clc$read_only THEN
      get_proc_parameter_value (parameter_name, parameter_number, block, work_area, value, internal_value,
            i_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value <> NIL THEN
        kind := value^.kind;
      ELSEIF i_value <> NIL THEN
        kind := i_value^.kind;
      ELSE
        kind := clc$unspecified;
      IFEND;
      IF kind = clc$unspecified THEN
        clp$make_string_value ('UNKNOWN', work_area, result);
        RETURN;
      IFEND;
      IF value <> NIL THEN
        clp$get_single_data_value (value_set_number, value_number, low_or_high, value, status);
      ELSE
        internal_component := #REL (i_value, internal_value^);
        clp$get_single_internal_value (internal_value, value_set_number, value_number, low_or_high,
              internal_component, status);
        i_value := #PTR (internal_component, internal_value^);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value <> NIL THEN
        kind := value^.kind;
      ELSEIF i_value <> NIL THEN
        kind := i_value^.kind;
      ELSE
        kind := clc$unspecified;
      IFEND;
      IF kind = clc$unspecified THEN
        clp$make_string_value ('UNKNOWN', work_area, result);
      ELSEIF kind = clc$keyword THEN
        clp$make_string_value ('NAME', work_area, result);
      ELSE
        clp$make_string_value (clv$type_kind_names [clv$value_type_kinds [kind]], work_area, result);
      IFEND;
    ELSE
      IF (value_set_number <> 1) OR (value_number <> 1) THEN
        clp$make_string_value ('UNKNOWN', work_area, result);
      ELSE
        clp$make_string_value (clv$value_descriptors [clc$variable_reference], work_area, result);
      IFEND;
    IFEND;
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$get_proc_value_kind;
?? TITLE := 'clp$get_proc_parameter', EJECT ??

  PROCEDURE [XDCL] clp$get_proc_parameter
    (    parameter_name: string ( * );
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      found: boolean,
      name_index: clt$parameter_name_index,
      parameter_number: clt$parameter_number,
      representation: ^clt$data_representation,
      request: clt$convert_to_string_request;


    status.normal := TRUE;
    find_proc_parameters_block ('$PARAMETER', block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (block^.parameters.names = NIL) OR (block^.parameters.accesses = NIL) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, '$PARAMETER', status);
      RETURN;
    IFEND;
    clp$search_parameter_names (parameter_name, block^.parameters.names, name_index, found);
    IF NOT found THEN
      osp$set_status_abnormal ('CL', cle$unknown_parameter_name, parameter_name, status);
      RETURN;
    IFEND;
    parameter_number := block^.parameters.names^ [name_index].position;
    IF block^.parameters.accesses^ [parameter_number].info.access_mode = clc$read_only THEN
      IF block^.parameters.accesses^ [parameter_number].info.descriptor^.header.value = NIL THEN
        clp$make_string_value ('', work_area, value);
        RETURN;
      IFEND;
      request.initial_indentation := 0;
      request.continuation_indentation := 0;
      request.max_string := clc$max_string_size;
      request.include_advanced_items := TRUE;
      request.include_hidden_items := TRUE;
      request.kind := clc$convert_data_value;
      request.representation_option := clc$data_source_representation;
      clp$convert_int_value_to_ext (block^.parameters.accesses^ [parameter_number].info.descriptor^.header.
            value, block^.parameters.accesses^ [parameter_number].info.descriptor^.header.value^.header.value,
            work_area, request.value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$internal_convert_to_string (request, work_area, representation, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$make_string_value (clp$data_representation_text (representation) ^, work_area, value);
    ELSE
      IF block^.parameters.accesses^ [parameter_number].passed_variable_reference <> NIL THEN
        clp$make_string_value (block^.parameters.accesses^ [parameter_number].passed_variable_reference^,
              work_area, value);
      ELSE
        clp$make_string_value ('', work_area, value);
      IFEND;
    IFEND;
    IF value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$get_proc_parameter;
?? TITLE := 'clp$get_proc_parameter_list', EJECT ??

  PROCEDURE [XDCL] clp$get_proc_parameter_list
    (VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      command_or_function: clt$command_or_function,
      representation: ^clt$data_representation,
      request: clt$convert_to_string_request;


    status.normal := TRUE;
    find_proc_parameters_block ('$PARAMETER_LIST', block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (block^.parameters.names = NIL) OR (block^.parameters.accesses = NIL) THEN
      clp$make_string_value ('', work_area, value);
      RETURN;
    IFEND;
    request.initial_indentation := 0;
    request.continuation_indentation := 0;
    request.max_string := osc$max_string_size;
    request.include_advanced_items := TRUE;
    request.include_hidden_items := TRUE;
    request.kind := clc$convert_parameters;
    request.initial_text := NIL;
    request.include_secure_parameters := TRUE;
    request.parameter_substitutions := NIL;
    IF block^.kind = clc$command_proc_block THEN
      command_or_function := clc$command;
    ELSE
      command_or_function := clc$function;
    IFEND;
    prepare_proc_param_conversion (command_or_function, block^.parameters.names, block^.parameters.accesses,
          work_area, request.evaluated_pdt, request.evaluated_pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$internal_convert_to_string (request, work_area, representation, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_string_value (clp$data_representation_text (representation) ^, work_area, value);
    IF value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$get_proc_parameter_list;
?? TITLE := 'find_parameters_block', EJECT ??

  PROCEDURE [INLINE] find_parameters_block
    (    request_name: ost$name_reference;
     VAR block: ^clt$block;
     VAR status: ost$status);


    status.normal := TRUE;
    clp$find_current_block (block);

  /find_block/
    WHILE block <> NIL DO
      CASE block^.kind OF
      = clc$command_proc_block =
        block := NIL;
        EXIT /find_block/;
      = clc$command_block, clc$sub_parameters_block =
        EXIT /find_block/;
      = clc$task_block =
        IF block^.task_kind <> clc$other_task THEN
          block := NIL;
        IFEND;
        EXIT /find_block/;
      ELSE
        block := block^.previous_block;
      CASEND;
    WHILEND /find_block/;

    IF (block = NIL) OR (NOT block^.parameters.evaluated) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, request_name, status);
      block := NIL;
      RETURN;
    IFEND;

  PROCEND find_parameters_block;
?? TITLE := 'find_proc_parameters_block', EJECT ??

  PROCEDURE [INLINE] find_proc_parameters_block
    (    request_name: ost$name_reference;
     VAR block: ^clt$block;
     VAR status: ost$status);


    status.normal := TRUE;
    clp$find_current_block (block);

  /find_block/
    WHILE block <> NIL DO
      CASE block^.kind OF
      = clc$command_proc_block, clc$function_proc_block =
        IF block^.parameters.evaluated THEN
          RETURN;
        IFEND;
      = clc$input_block =
        IF block^.inherited_input.found THEN
          block := block^.inherited_input.block;
          CYCLE /find_block/;
        IFEND;
      ELSE
        ;
      CASEND;

      IF block^.static_link <> NIL THEN
        block := block^.static_link;
      ELSE
        block := block^.previous_block;
      IFEND;
    WHILEND /find_block/;

    IF block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, request_name, status);
      RETURN;
    IFEND;

  PROCEND find_proc_parameters_block;
?? TITLE := 'get_parameter_value', EJECT ??

  PROCEDURE [INLINE] get_parameter_value
    (    request_name: ost$name_reference;
         parameter_name: string ( * );
     VAR value: ^clt$parameter_value;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      found: boolean,
      name: clt$parameter_name,
      name_index: clt$parameter_name_index;


    value := NIL;
    find_parameters_block (request_name, block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (block^.parameters.names = NIL) OR (block^.parameters.parameter_value_table = NIL) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, request_name, status);
      RETURN;
    IFEND;

    #TRANSLATE (osv$lower_to_upper, parameter_name, name);
    clp$search_parameter_names (name, block^.parameters.names, name_index, found);
    IF NOT found THEN
      osp$set_status_abnormal ('CL', cle$unknown_parameter_name, name, status);
      RETURN;
    IFEND;
    value := ^block^.parameters.parameter_value_table^ [block^.parameters.names^ [name_index].position];

  PROCEND get_parameter_value;
?? TITLE := 'get_proc_parameter_value', EJECT ??

  PROCEDURE [INLINE] get_proc_parameter_value
    (    parameter_name: string ( * );
         parameter_number: clt$parameter_number;
         block: ^clt$block;
     VAR work_area {input, output} : ^clt$work_area;
     VAR data_value: ^clt$data_value;
     VAR internal_value: ^clt$internal_data_value;
     VAR i_value: ^clt$i_data_value;
     VAR status: ost$status);

    VAR
      access_variable_requests: clt$access_variable_requests,
      ignore_parse_value_qualifiers: ^clt$value_qualifiers,
      ignore_parse_value_qual_index: integer,
      ignore_type_description: ^clt$type_description;


    data_value := NIL;
    internal_value := NIL;
    i_value := NIL;

    IF (block^.parameters.accesses^ [parameter_number].info.descriptor <> NIL) AND
          (block^.parameters.accesses^ [parameter_number].info.descriptor^.header.value <> NIL) THEN
      IF block^.parameters.accesses^ [parameter_number].info.qualifiers = NIL THEN
        internal_value := block^.parameters.accesses^ [parameter_number].info.descriptor^.header.value;
        i_value := #PTR (block^.parameters.accesses^ [parameter_number].info.descriptor^.header.value^.header.
              value, internal_value^);
      ELSE
        access_variable_requests := $clt$access_variable_requests[ ];
        ignore_type_description := NIL;
        ignore_parse_value_qualifiers := NIL;
        clp$read_qualified_data_value (parameter_name, access_variable_requests,
              block^.parameters.accesses^ [parameter_number].info.qualifiers, block^.parameters.
              accesses^ [parameter_number].info.descriptor^.header.value, data_value, work_area,
              ignore_type_description, ignore_parse_value_qualifiers, ignore_parse_value_qual_index, status);
      IFEND;
    IFEND;

  PROCEND get_proc_parameter_value;
?? TITLE := 'get_value_element', EJECT ??

  PROCEDURE [INLINE] get_value_element
    (    element_number: integer;
     VAR value {input, output} : ^clt$data_value);

    VAR
      count: integer;


    IF value^.kind <> clc$list THEN
      IF element_number > 1 THEN
        value := NIL;
      IFEND;
      RETURN;
    IFEND;

    count := 0;

    REPEAT
      IF value^.element_value <> NIL THEN
        count := count + 1;
        IF count = element_number THEN
          value := value^.element_value;
          RETURN;
        IFEND;
      IFEND;
      value := value^.link;
    UNTIL value = NIL;

  PROCEND get_value_element;
?? TITLE := 'get_internal_value_element', EJECT ??

  PROCEDURE [INLINE] get_internal_value_element
    (    element_number: integer;
         internal_value: ^clt$internal_data_value;
     VAR i_value {input, output} : ^clt$i_data_value);

    VAR
      count: integer;


    IF i_value^.kind <> clc$list THEN
      IF element_number > 1 THEN
        i_value := NIL;
      IFEND;
      RETURN;
    IFEND;

    count := 0;

    REPEAT
      IF i_value^.element_value <> NIL THEN
        count := count + 1;
        IF count = element_number THEN
          i_value := #PTR (i_value^.element_value, internal_value^);
          RETURN;
        IFEND;
      IFEND;
      i_value := #PTR (i_value^.link, internal_value^);
    UNTIL i_value = NIL;

  PROCEND get_internal_value_element;
?? TITLE := 'get_value_element_count', EJECT ??

  PROCEDURE [INLINE] get_value_element_count
    (    value: ^clt$data_value;
     VAR count: clt$list_size);

    VAR
      current_node: ^clt$data_value;


    IF value^.kind <> clc$list THEN
      count := 1;
      RETURN;
    IFEND;

    current_node := value;
    count := 0;

    WHILE current_node <> NIL DO
      IF current_node^.element_value <> NIL THEN
        count := count + 1;
      IFEND;
      current_node := current_node^.link;
    WHILEND;

  PROCEND get_value_element_count;
?? TITLE := 'get_int_value_element_count', EJECT ??

  PROCEDURE [INLINE] get_int_value_element_count
    (    internal_value: ^clt$internal_data_value;
         i_value: ^clt$i_data_value;
     VAR count: clt$list_size);

    VAR
      current_node: ^clt$i_data_value;


    IF i_value^.kind <> clc$list THEN
      count := 1;
      RETURN;
    IFEND;

    current_node := i_value;
    count := 0;

    WHILE current_node <> NIL DO
      IF current_node^.element_value <> NIL THEN
        count := count + 1;
      IFEND;
      current_node := #PTR (current_node^.link, internal_value^);
    WHILEND;

  PROCEND get_int_value_element_count;
?? TITLE := 'prepare_proc_param_conversion', EJECT ??

  PROCEDURE prepare_proc_param_conversion
    (    command_or_function: clt$command_or_function;
         names: ^clt$pdt_parameter_names;
         accesses: ^clt$parameter_accesses;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pdt: ^clt$unbundled_pdt;
     VAR pvt: ^clt$parameter_value_table;
     VAR status: ost$status);

    VAR
      i: clt$parameter_name_index,
      p: clt$parameter_number,
      preset_header: [STATIC, READ, oss$job_paged_literal] clt$pdt_header :=
            [clc$declaration_version, [87, 10, 15, 0, 0, 0, 0], clc$command, 0, 0, 0, 0, 0, 0, 0, ''],
      preset_parameter: [STATIC, READ, oss$job_paged_literal] clt$pdt_parameter :=
            [1, clc$normal_usage_entry, clc$non_secure_parameter,
            [clc$specify_positionally, clc$specify_by_name], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 0, clc$optional_parameter, 0, 0];

{
{   The pdt generated by this procedure contains only the information needed
{   by clp$internal_convert_to_string for the clc$convert_parameters request.
{

    NEXT pdt IN work_area;
    NEXT pdt^.header IN work_area;
    pdt^.header^ := preset_header;
    pdt^.header^.command_or_function := command_or_function;
    pdt^.header^.number_of_parameters := UPPERBOUND (accesses^);
    pdt^.header^.number_of_parameter_names := UPPERBOUND (names^);
    pdt^.header^.status_parameter_number := 0;
    pdt^.names := names;
    NEXT pdt^.parameters: [1 .. pdt^.header^.number_of_parameters] IN work_area;
    pdt^.type_descriptions := NIL;
    pdt^.default_names := NIL;
    pdt^.default_values := NIL;
    pdt^.header^.number_of_var_parameters := 0;

    NEXT pvt: [1 .. pdt^.header^.number_of_parameters] IN work_area;

    FOR p := 1 TO pdt^.header^.number_of_parameters DO
      pdt^.parameters^ [p] := preset_parameter;
      pdt^.parameters^ [p].name_index := accesses^ [p].name_index;
      pdt^.parameters^ [p].security := accesses^ [p].security;
      pvt^ [p].specified := accesses^ [p].specified;
      IF accesses^ [p].info.access_mode = clc$read_write THEN
        pvt^ [p].passing_method := clc$pass_by_reference;
        pvt^ [p].variable := accesses^ [p].passed_variable_reference;
      ELSE
        pvt^ [p].passing_method := clc$pass_by_value;
        IF (accesses^ [p].info.descriptor = NIL) OR (accesses^ [p].info.descriptor^.header.value = NIL) THEN
          pvt^ [p].value := NIL;
        ELSE
          clp$convert_int_value_to_ext (accesses^ [p].info.descriptor^.header.value,
                accesses^ [p].info.descriptor^.header.value^.header.value, work_area, pvt^ [p].value, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND prepare_proc_param_conversion;

MODEND clm$access_parameters;
*DECK DECK=CLM$ASSIGN_DEVICE_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Assign Device Command' ??
MODULE clm$assign_device_command;

{  PURPOSE:
{    This module contains the processor for the ASSIGN_DEVICE command.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_file_reference
*copyc jmt$system_supplied_name
*copyc rmc$condition_code_limits
?? POP ??

*copyc clp$evaluate_parameters
*copyc iop$assign_device_command
*copyc jmp$validate_name
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
*copyc osv$lower_to_upper
*copyc rmp$validate_ansi_string

?? OLDTITLE ??
?? NEWTITLE := 'clp$assign_device_command', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$assign_device_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (clm$assd) assign_device, assd (
{     element_name, en, element, e: name = $required
{     external_vsn, evsn, ev: any of
{         string 1..6
{         name 1..6
{     anyend = $required
{     job_name, jn : name = $optional
{     status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 11, 19, 13, 16, 7, 931],
    clc$command, 10, 4, 2, 0, 0, 0, 4, 'CLM$ASSD'], [
    ['E                              ',clc$abbreviation_entry, 1],
    ['ELEMENT                        ',clc$alias_entry, 1],
    ['ELEMENT_NAME                   ',clc$nominal_entry, 1],
    ['EN                             ',clc$alias_entry, 1],
    ['EV                             ',clc$abbreviation_entry, 2],
    ['EVSN                           ',clc$alias_entry, 2],
    ['EXTERNAL_VSN                   ',clc$nominal_entry, 2],
    ['JN                             ',clc$abbreviation_entry, 3],
    ['JOB_NAME                       ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [1, 6, FALSE]],
    5, [[1, 0, clc$name_type], [1, 6]]
    ],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

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

    CONST
      p$element_name = 1,
      p$external_vsn = 2,
      p$job_name = 3,
      p$status = 4;

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

    VAR
      candidate_job_name: jmt$name,
      element_name: ost$name,
      external_vsn: rmt$external_vsn,
      job_name: jmt$system_supplied_name,
      verified_job_name: jmt$name,
      vsn_string: ost$string;

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

    element_name := pvt [p$element_name].value^.name_value;

    IF pvt [p$external_vsn].value^.kind = clc$string THEN
      external_vsn := pvt [p$external_vsn].value^.string_value^;
    ELSEIF pvt [p$external_vsn].value^.kind = clc$name THEN
      external_vsn := pvt [p$external_vsn].value^.name_value;
    IFEND;
    rmp$validate_ansi_string (external_vsn, external_vsn, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (rmc$resource_management_id, cle$improper_vsn_value, external_vsn, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'EXTERNAL_VSN', status);
      RETURN;
    IFEND;

    IF pvt [p$job_name].specified THEN
      candidate_job_name.kind := jmc$system_supplied_name;
      candidate_job_name.system_supplied_name := pvt [p$job_name].value^.name_value;
      jmp$validate_name (candidate_job_name, verified_job_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      job_name := verified_job_name.system_supplied_name;
    ELSE
      job_name := jmc$blank_system_supplied_name;
    IFEND;

    iop$assign_device_command (job_name, element_name, external_vsn, status);

  PROCEND clp$assign_device_command;

MODEND clm$assign_device_command;
*DECK DECK=CLM$BLOCK_STACK_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Block Stack Manager' ??
MODULE clm$block_stack_manager;

{
{ PURPOSE:
{   This module contains the procedures that manage the Block stack which is used to keep track of the
{   current state of the SCL interpreter.
{   Included in this module are the procedures called by task management when a child task of the current
{   task is being created or has terminated.
{

?? NEWTITLE := 'Global Declarations' ??
?? NEWTITLE := 'Block Stack', EJECT ??
*copyc clt$block
?? OLDTITLE, EJECT ??
?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc avc$accounting_statistics
*copyc clc$compiling_for_test_harness
*copyc clc$declaration_version
*copyc clc$exiting_condition
*copyc clc$standard_file_names
*copyc cle$bad_application_task_link
*IFEND
*copyc cle$block_access_count_error
*copyc cle$cannot_access_unit_array
*IF NOT $true(osv$unix)
*copyc cle$ecc_control_statement
*copyc cle$multiple_applic_unit_arrays
*copyc cle$negative_application_units
*copyc cle$parameters_displayed
*copyc cle$terminated_application_task
*IFEND
*copyc cle$unable_to_free_block
*copyc cle$unexpected_call_to
*IF NOT $true(osv$unix)
*copyc clk$erase_child_task
*copyc clk$pop_block_stack
*copyc clk$push_block_stack
*copyc clk$record_child_task
*copyc clt$application_unit_info
*IFEND
*copyc clt$block_handle
*IF NOT $true(osv$unix)
*copyc clt$command_name
*copyc clt$command_or_function
*copyc clt$established_handler_index
*IFEND
*copyc clt$initial_application
*copyc clt$parameter_eval_context
*copyc clt$parameter_help_context
*IF NOT $true(osv$unix)
*copyc clt$processing_phase
*copyc clt$string_size
*IFEND
*copyc clt$task_list
*IF NOT $true(osv$unix)
*copyc clt$user_identification
*copyc clt$utility_attributes
*copyc clt$when_condition_definition
*copyc cyd$run_time_error_condition
*copyc fst$file_reference
*copyc jmt$ijl_ordinal
*copyc osc$timesharing_terminal_file
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc ose$heap_full_exceptions
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc oss$task_shared
*IFEND
*copyc ost$caller_identifier
*copyc ost$name
*copyc ost$status
*IF NOT $true(osv$unix)
*copyc ost$user_identification
*copyc pme$system_exceptions
*IFEND
?? SKIP := 3 ??

{
{ PURPOSE:
{   The following procedure exists solely to provide a "shelter" for the
{   declarations contained in certain decks that are *COPYC'd into this
{   deck.  For example, this module defines an XDCL'd variable that is
{   referenced by an INLINE procedure.  In order to make the deck containing
{   the INLINE procedure "self-contained" it *COPYCs the deck containing the
{   XREF declaration of the variable.  Since the INLINE procedure is needed
{   in this module, both the XDCL and XREF declaration will appear in this
{   module.  The following "dummy" procedure is used to hide the XREF
{   declaration of the variable from the rest of the module.
{

  PROCEDURE [INLINE] dummy;

*copyc clp$find_task_block_first_time
*copyc clv$current_task_block

  PROCEND dummy;
?? SKIP := 3 ??
?? POP ??
*IF NOT $true(osv$unix)
*copyc avp$calculate_application_srus
*copyc avp$emit_interactive_interval
*copyc avp$ring_nominal
*copyc avp$security_option_active
*copyc avv$active_sou_capabilities
*copyc avv$cond_capability_names
*copyc clp$convert_ext_value_to_int
*IFEND
*copyc clp$delete_expandable_string
*copyc clp$delete_util_from_cmnd_list
*IF NOT $true(osv$unix)
*copyc clp$delete_parameters
*copyc clp$delete_variables
*IFEND
*copyc clp$environment_object_in_block
*IF NOT $true(osv$unix)
*copyc clp$find_block_via_handle
*copyc clp$find_current_block
*IFEND
*copyc clp$find_task_block
*copyc clp$find_utility_block
*IF NOT $true(osv$unix)
*copyc clp$free_all_handlers_in_block
*copyc clp$get_command_search_mode
*IFEND
*copyc clp$get_non_standard_cmnd_line
*copyc clp$get_non_standard_line
*IF NOT $true(osv$unix)
*copyc clp$get_segment_cmnd_line
*copyc clp$get_segment_cmnd_line_v0
*copyc clp$get_segment_line
*copyc clp$get_segment_line_v0
*IFEND
*copyc clp$get_standard_cmnd_line
*copyc clp$get_standard_line
*IF NOT $true(osv$unix)
*copyc clp$get_system_file_id
*IFEND
*copyc clp$get_work_area
*IF NOT $true(osv$unix)
*copyc clp$initialize_parse_state
*IFEND
*copyc clp$init_all_environment
*IF NOT $true(osv$unix)
*copyc clp$internal_convert_to_string
*copyc clp$pop_all_environment
*IFEND
*copyc clp$pop_input_stack
*IF NOT $true(osv$unix)
*copyc clp$push_all_environment
*copyc clp$reset_input_position
*copyc clp$save_collect_statement_area
*copyc clp$send_exiting_signal
*IFEND
*copyc clp$set_prompt_string
*IF NOT $true(osv$unix)
*copyc clp$store_expandable_string
*copyc clp$trimmed_string_size
*copyc clp$update_all_environment
*copyc clv$standard_files
*copyc clv$var_access_assignment_count
*copyc i#current_sequence_position
*copyc iip$direct_fetch_trm_conn_atts
*copyc iip$direct_store_trm_conn_atts
*copyc jmp$job_file_fap
*copyc jmp$end_application_scheduling
*copyc jmp$read_application_record
*copyc jmp$set_application_scheduling
*copyc jmp$system_job
*copyc jmv$jcb
*copyc mmp$delete_segment
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*IFEND
*copyc osp$clear_job_signature_lock
*copyc osp$decrement_locked_variable
*IF NOT $true(osv$unix)
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*IFEND
*copyc osp$fetch_locked_variable
*copyc osp$find_interaction_info
*IF NOT $true(osv$unix)
*copyc osp$generate_log_message
*IFEND
*copyc osp$increment_locked_variable
*IF NOT $true(osv$unix)
*copyc osp$initialize_sig_lock
*IFEND
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*IF $true(osv$unix)
*copyc osp$set_status_from_errno
*IFEND
*IF NOT $true(osv$unix)
*copyc osp$system_error
*copyc osp$verify_system_privilege
*IFEND
*copyc osv$task_shared_heap
*IF NOT $true(osv$unix)
*copyc pmp$abort
*copyc pmp$cause_task_condition
*copyc pmp$continue_to_cause
*copyc pmp$find_executing_task_xcb
*copyc pmp$find_prog_options_and_libs
*copyc pmp$get_application_information
*copyc pmp$get_task_cp_time
*copyc pmp$get_task_id
*copyc pmp$get_task_jobmode_statistics
*copyc pmp$get_unique_name
*copyc pmp$get_user_identification
*copyc pmp$init_default_prog_options
*copyc pmp$log_ascii
*copyc pmp$terminate
*copyc sfp$emit_audit_statistic
*copyc sfp$emit_statistic
*ELSE
*copyc clt$user_identification
*copyc clt$env_object_pop_reason
*copyc clp$get_command_search_mode
*copyc pmp_get_task_id
*IFEND
?? TITLE := 'clv$nil_block_handle', EJECT ??

{
{ This variable contains the equivalent of a NIL pointer in the form of a block handle.
{

  VAR
*IF NOT $true(osv$unix)
    clv$nil_block_handle: [XDCL, #GATE, READ, oss$job_paged_literal] clt$block_handle := [0, 0];
*ELSE
    clv$nil_block_handle: [XDCL, #GATE, READ] clt$block_handle := [0, 0];
*IFEND

?? TITLE := 'clv$initial_blocks', EJECT ??

{
{ This variable contains initialized instances of each generic kind of block.
{

?? FMT (FORMAT := OFF) ??

  VAR
*IF NOT $true(osv$unix)
    clv$initial_blocks: [STATIC, READ, oss$job_paged_literal] array [clt$block_kind] of clt$block := [
*ELSE
    clv$initial_blocks: [STATIC, READ] array [clt$block_kind] of clt$block := [
*IFEND

*IF NOT $true(osv$unix)
{ CLC$BLOCK_BLOCK }

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 0,
          { previous_block ........................................... } NIL,
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } [],
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } TRUE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } FALSE,
          { parameters. unbundled_pdt ................................ } NIL,
          { parameters. command_status_variable ...................... } NIL,
          { parameters. parameter_value_table ........................ } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
          { input_can_be_echoed ...................................... } FALSE,
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'BLOCK',
          { kind_end_name ............................................ } 'BLOCKEND',
          { kind ..................................................... } clc$block_block],

{ CLC$CASE_BLOCK }

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 0,
          { previous_block ........................................... } NIL,
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } [],
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } TRUE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } FALSE,
          { parameters. unbundled_pdt ................................ } NIL,
          { parameters. command_status_variable ...................... } NIL,
          { parameters. parameter_value_table ........................ } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
          { input_can_be_echoed ...................................... } FALSE,
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'CASE',
          { kind_end_name ............................................ } 'CASEND',
          { kind ..................................................... } clc$case_block,
          { case_selection_value ..................................... } NIL,
          { case_selection_encounterred .............................. } FALSE,
          { case_selected ............................................ } FALSE,
          { case_else_allowed ........................................ } FALSE],

{ CLC$CHECK_BLOCK }

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 0,
          { previous_block ........................................... } NIL,
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } [],
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } TRUE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } FALSE,
          { parameters. unbundled_pdt ................................ } NIL,
          { parameters. command_status_variable ...................... } NIL,
          { parameters. parameter_value_table ........................ } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
          { input_can_be_echoed ...................................... } FALSE,
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'CHECK',
          { kind_end_name ............................................ } 'CHECKEND',
          { kind ..................................................... } clc$check_block,
          { check_status ............................................. } [TRUE]],

*IFEND
{ CLC$COMMAND_BLOCK }

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 0,
          { previous_block ........................................... } NIL,
*IF NOT $true(osv$unix)
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } [],
*IFEND
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
*IF NOT $true(osv$unix)
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
*IFEND
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } FALSE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } FALSE,
          { parameters. unbundled_pdt ................................ } NIL,
          { parameters. command_status_variable ...................... } NIL,
          { parameters. parameter_value_table ........................ } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
*IF NOT $true(osv$unix)
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
*IFEND
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
*IF NOT $true(osv$unix)
          { input_can_be_echoed ...................................... } FALSE,
*IFEND
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'command',
          { kind_end_name ............................................ } 'command_end',
          { kind ..................................................... } clc$command_block,
          { command_kind ............................................. } clc$regular_command,
*IF NOT $true(osv$unix)
          { command_logging_completed ................................ } FALSE,
          { command_echoing_completed ................................ } FALSE,
*IFEND
          { help_output_file ......................................... } NIL,
*IF NOT $true(osv$unix)
          { help_output_options ...................................... } [],
          { edited_parameters_max_size ............................... } 0,
          { edited_parameters ........................................ } NIL],
*ELSE
          { help_output_options ...................................... } []],
*IFEND

*IF NOT $true(osv$unix)
{ CLC$COMMAND_PROC_BLOCK }

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 0,
          { previous_block ........................................... } NIL,
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } [],
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } FALSE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } TRUE,
          { parameters. command_status_specified ..................... } FALSE,
          { parameters. accesses ..................................... } NIL,
          { parameters. values ....................................... } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
          { input_can_be_echoed ...................................... } FALSE,
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'PROCEDURE',
          { kind_end_name ............................................ } 'PROCEND',
          { kind ..................................................... } clc$command_proc_block,
          { inherited_input. found ................................... } [FALSE],
          { input. internal .......................................... } [FALSE,
          { input. prompting_input ................................... } FALSE,
          { input. line. area ........................................ } [NIL,
          { input. line. text ........................................ } NIL,
          { input. line. lexical_units ............................... } NIL],
          { input. pushed_line ....................................... } NIL,
          { input. kind .............................................. } clc$file_input,
          { input. local_file_name ................................... } osc$null_name,
          { input. file_id. ordinal .................................. } [0,
          { input. file_id. sequence ................................. } 1],
          { input. line_layout. physical_line_size ................... } [clc$max_physical_line_size,
          { input. line_layout. element .............................. } [REP 3 of
          { input. line_layout. element. kind......................... } [clc$null_line_element,
          { input. line_layout. element. size......................... } 0]]],
          { input. get_command_line .................................. } NIL,
          { input. get_line .......................................... } NIL,
          { input. data_line. area ................................... } [NIL,
          { input. data_line. text ................................... } NIL,
          { input. data_line. lexical_units .......................... } NIL],
          { input. line_address_is_for_previous ...................... } FALSE,
          { input. line_address ...................................... } 0,
          { input. record_number ..................................... } 0,
          { input. data .............................................. } NIL,
          { input. file_rereadable ................................... } FALSE,
          { input. interactive_device ................................ } FALSE,
          { input. device_class ...................................... } rmc$mass_storage_device,
          { input. base_prompt_string. size .......................... } [0,
          { input. base_prompt_string. value ......................... } ''],
          { input. current_prompt_string. size ....................... } [0,
          { input. current_prompt_string. value ...................... } ''],
          { input. state ............................................. } clc$continue_input],
          { previous_command. area ................................... } [NIL,
          { previous_command. text ................................... } NIL,
          { previous_command. lexical_units .......................... } NIL],
          { previous_command_name .................................... } osc$null_name,
          { previous_command_status .................................. } [TRUE],
          { proc_name ................................................ } osc$null_name,
          { command_proc_status ...................................... } NIL,
          { command_proc_logging_completed ........................... } FALSE,
          { command_proc_echoing_completed ........................... } FALSE,
          { function_proc_result ..................................... } NIL,
          { expected_function_proc_type .............................. } NIL,
          { when_condition ........................................... } NIL,
          { associated_utility ....................................... } NIL,
          { line_preprocessor_specified .............................. } FALSE],

{ CLC$FOR_BLOCK }

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 0,
          { previous_block ........................................... } NIL,
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } [],
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } TRUE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } FALSE,
          { parameters. unbundled_pdt ................................ } NIL,
          { parameters. command_status_variable ...................... } NIL,
          { parameters. parameter_value_table ........................ } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
          { input_can_be_echoed ...................................... } FALSE,
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'FOR',
          { kind_end_name ............................................ } 'FOREND',
          { kind ..................................................... } clc$for_block,
          { for_variable ............................................. } NIL,
          { for_control. style ....................................... } [clc$for_control_list,
          { for_control. list ........................................ } NIL]],

*IFEND
{ CLC$FUNCTION_BLOCK }

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 0,
          { previous_block ........................................... } NIL,
*IF NOT $true(osv$unix)
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } [],
*IFEND
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
*IF NOT $true(osv$unix)
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
*IFEND
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } FALSE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } FALSE,
          { parameters. unbundled_pdt ................................ } NIL,
          { parameters. command_status_variable ...................... } NIL,
          { parameters. parameter_value_table ........................ } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
*IF NOT $true(osv$unix)
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
*IFEND
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
*IF NOT $true(osv$unix)
          { input_can_be_echoed ...................................... } FALSE,
*IFEND
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'function',
          { kind_end_name ............................................ } 'function_end',
          { kind ..................................................... } clc$function_block,
          { expected_function_type ................................... } NIL],

*IF NOT $true(osv$unix)
{ CLC$FUNCTION_PROC_BLOCK }

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 0,
          { previous_block ........................................... } NIL,
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } [],
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } FALSE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } TRUE,
          { parameters. command_status_specified ..................... } FALSE,
          { parameters. accesses ..................................... } NIL,
          { parameters. values ....................................... } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
          { input_can_be_echoed ...................................... } FALSE,
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'FUNCTION',
          { kind_end_name ............................................ } 'FUNCEND',
          { kind ..................................................... } clc$function_proc_block,
          { inherited_input. found ................................... } [FALSE],
          { input. internal .......................................... } [FALSE,
          { input. prompting_input ................................... } FALSE,
          { input. line. area ........................................ } [NIL,
          { input. line. text ........................................ } NIL,
          { input. line. lexical_units ............................... } NIL],
          { input. pushed_line ....................................... } NIL,
          { input. kind .............................................. } clc$file_input,
          { input. local_file_name ................................... } osc$null_name,
          { input. file_id. ordinal .................................. } [0,
          { input. file_id. sequence ................................. } 1],
          { input. line_layout. physical_line_size ................... } [clc$max_physical_line_size,
          { input. line_layout. element .............................. } [REP 3 of
          { input. line_layout. element. kind......................... } [clc$null_line_element,
          { input. line_layout. element. size......................... } 0]]],
          { input. get_command_line .................................. } NIL,
          { input. get_line .......................................... } NIL,
          { input. data_line. area ................................... } [NIL,
          { input. data_line. text ................................... } NIL,
          { input. data_line. lexical_units .......................... } NIL],
          { input. line_address_is_for_previous ...................... } FALSE,
          { input. line_address ...................................... } 0,
          { input. record_number ..................................... } 0,
          { input. data .............................................. } NIL,
          { input. file_rereadable ................................... } FALSE,
          { input. interactive_device ................................ } FALSE,
          { input. device_class ...................................... } rmc$mass_storage_device,
          { input. base_prompt_string. size .......................... } [0,
          { input. base_prompt_string. value ......................... } ''],
          { input. current_prompt_string. size ....................... } [0,
          { input. current_prompt_string. value ...................... } ''],
          { input. state ............................................. } clc$continue_input],
          { previous_command. area ................................... } [NIL,
          { previous_command. text ................................... } NIL,
          { previous_command. lexical_units .......................... } NIL],
          { previous_command_name .................................... } osc$null_name,
          { previous_command_status .................................. } [TRUE],
          { proc_name ................................................ } osc$null_name,
          { command_proc_status ...................................... } NIL,
          { command_proc_logging_completed ........................... } FALSE,
          { command_proc_echoing_completed ........................... } FALSE,
          { function_proc_result ..................................... } NIL,
          { expected_function_proc_type .............................. } NIL,
          { when_condition ........................................... } NIL,
          { associated_utility ....................................... } NIL,
          { line_preprocessor_specified .............................. } FALSE],

{ CLC$IF_BLOCK }

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 0,
          { previous_block ........................................... } NIL,
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } [],
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } TRUE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } FALSE,
          { parameters. unbundled_pdt ................................ } NIL,
          { parameters. command_status_variable ...................... } NIL,
          { parameters. parameter_value_table ........................ } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
          { input_can_be_echoed ...................................... } FALSE,
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'IF',
          { kind_end_name ............................................ } 'IFEND',
          { kind ..................................................... } clc$if_block,
          { if_condition_met ......................................... } FALSE,
          { if_else_allowed .......................................... } TRUE],

*IFEND
{ CLC$INPUT_BLOCK }

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 0,
          { previous_block ........................................... } NIL,
*IF NOT $true(osv$unix)
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } [],
*IFEND
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
*IF NOT $true(osv$unix)
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
*IFEND
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } TRUE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } FALSE,
          { parameters. unbundled_pdt ................................ } NIL,
          { parameters. command_status_variable ...................... } NIL,
          { parameters. parameter_value_table ........................ } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
*IF NOT $true(osv$unix)
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
*IFEND
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
*IF NOT $true(osv$unix)
          { input_can_be_echoed ...................................... } FALSE,
*IFEND
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'input',
          { kind_end_name ............................................ } 'end_of_input',
          { kind ..................................................... } clc$input_block,
          { inherited_input. found ................................... } [FALSE],
          { input. internal .......................................... } [FALSE,
          { input. prompting_input ................................... } FALSE,
          { input. line. area ........................................ } [NIL,
          { input. line. text ........................................ } NIL,
          { input. line. lexical_units ............................... } NIL],
          { input. pushed_line ....................................... } NIL,
          { input. kind .............................................. } clc$file_input,
          { input. local_file_name ................................... } osc$null_name,
*IF NOT $true(osv$unix)
          { input. file_id. ordinal .................................. } [0,
          { input. file_id. sequence ................................. } 1],
*ELSE
          { input. file_id ......... ................................. } 0,
*IFEND
          { input. line_layout. physical_line_size ................... } [clc$max_physical_line_size,
          { input. line_layout. element .............................. } [REP 3 of
          { input. line_layout. element. kind......................... } [clc$null_line_element,
          { input. line_layout. element. size......................... } 0]]],
          { input. get_command_line .................................. } NIL,
          { input. get_line .......................................... } NIL,
          { input. data_line. area ................................... } [NIL,
          { input. data_line. text ................................... } NIL,
          { input. data_line. lexical_units .......................... } NIL],
          { input. line_address_is_for_previous ...................... } FALSE,
          { input. line_address ...................................... } 0,
          { input. record_number ..................................... } 0,
          { input. data .............................................. } NIL,
          { input. file_rereadable ................................... } FALSE,
          { input. interactive_device ................................ } FALSE,
          { input. device_class ...................................... } rmc$mass_storage_device,
          { input. base_prompt_string. size .......................... } [0,
          { input. base_prompt_string. value ......................... } ''],
          { input. current_prompt_string. size ....................... } [0,
          { input. current_prompt_string. value ...................... } ''],
          { input. state ............................................. } clc$continue_input],
          { previous_command. area ................................... } [NIL,
          { previous_command. text ................................... } NIL,
          { previous_command. lexical_units .......................... } NIL],
          { previous_command_name .................................... } osc$null_name,
          { previous_command_status .................................. } [TRUE],
*IF NOT $true(osv$unix)
          { proc_name ................................................ } osc$null_name,
          { command_proc_status ...................................... } NIL,
          { command_proc_logging_completed ........................... } FALSE,
          { command_proc_echoing_completed ........................... } FALSE,
          { function_proc_result ..................................... } NIL,
          { expected_function_proc_type .............................. } NIL,
          { when_condition ........................................... } NIL,
*IFEND
          { associated_utility ....................................... } NIL,
          { line_preprocessor_specified .............................. } FALSE],

*IF NOT $true(osv$unix)
{ CLC$LOOP_BLOCK }

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 0,
          { previous_block ........................................... } NIL,
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } [],
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } TRUE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } FALSE,
          { parameters. unbundled_pdt ................................ } NIL,
          { parameters. command_status_variable ...................... } NIL,
          { parameters. parameter_value_table ........................ } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
          { input_can_be_echoed ...................................... } FALSE,
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'LOOP',
          { kind_end_name ............................................ } 'LOOPEND',
          { kind ..................................................... } clc$loop_block],

{ CLC$REPEAT_BLOCK }

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 0,
          { previous_block ........................................... } NIL,
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } [],
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } TRUE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } FALSE,
          { parameters. unbundled_pdt ................................ } NIL,
          { parameters. command_status_variable ...................... } NIL,
          { parameters. parameter_value_table ........................ } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
          { input_can_be_echoed ...................................... } FALSE,
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'REPEAT',
          { kind_end_name ............................................ } 'UNTIL',
          { kind ..................................................... } clc$repeat_block,
          { expression_area .......................................... } NIL,
          { expression_parse. text ................................... } [NIL,
          { expression_parse. index .................................. } 1,
          { expression_parse. units_array ............................ } NIL,
          { expression_parse. units_array_index ...................... } 1,
          { expression_parse. index_limit ............................ } 1,
          { expression_parse. unit. size ............................. } [0,
          { expression_parse. unit. kind ............................. } clc$lex_end_of_line],
          { expression_parse. unit_index ............................. } 1,
          { expression_parse. unit_is_space .......................... } FALSE,
          { expression_parse. previous_unit_is_space ................. } FALSE,
          { expression_parse. previous_non_space_unit. size .......... } [0,
          { expression_parse. previous_non_space_unit. kind .......... } clc$lex_end_of_line],
          { expression_parse. previous_non_space_unit_index .......... } 1]],

{ CLC$SUB_PARAMETERS_BLOCK }

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 0,
          { previous_block ........................................... } NIL,
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } [],
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } FALSE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } FALSE,
          { parameters. unbundled_pdt ................................ } NIL,
          { parameters. command_status_variable ...................... } NIL,
          { parameters. parameter_value_table ........................ } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
          { input_can_be_echoed ...................................... } FALSE,
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'sub_parameters',
          { kind_end_name ............................................ } 'sub_parameters_end',
          { kind ..................................................... } clc$sub_parameters_block,
          { sub_parameters_work_area_ptr ............................. } NIL,
          { sub_parameters_work_area ................................. } NIL,
          { lookup_functions_and_variables ........................... } TRUE],

*IFEND

{ CLC$TASK_BLOCK }

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 0,
          { previous_block ........................................... } NIL,
*IF NOT $true(osv$unix)
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } [],
*IFEND
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
*IF NOT $true(osv$unix)
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
*IFEND
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } FALSE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } FALSE,
          { parameters. unbundled_pdt ................................ } NIL,
          { parameters. command_status_variable ...................... } NIL,
          { parameters. parameter_value_table ........................ } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
*IF NOT $true(osv$unix)
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
*IFEND
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
*IF NOT $true(osv$unix)
          { input_can_be_echoed ...................................... } FALSE,
*IFEND
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'task',
          { kind_end_name ............................................ } 'end_of_task',
          { kind ..................................................... } clc$task_block,
          { task_id .................................................. } 0,
          { task_kind ................................................ } clc$other_task,
          { task_link ................................................ } NIL,
*IF NOT $true(osv$unix)
          { application_task_link .................................... } NIL,
*IFEND
          { parent ................................................... } NIL,
          { current_block ............................................ } NIL,
*IF NOT $true(osv$unix)
          { display_log_indices ...................................... } [REP 3 of
          { display_log_indices. last_log_entry ...................... } [0,
          { display_log_indices. last_display_log_entry .............. } 0,
          { display_log_indices. last_log_cycle ...................... } 0]],
*IFEND
          { synchronous_with_job ..................................... } FALSE,
          { synchronous_with_parent .................................. } FALSE,
          { command_file ............................................. } osc$null_name,
*IF NOT $true(osv$unix)
          { named_task_list .......................................... } NIL,
          { default_session_file ..................................... } NIL],
*ELSE
          { named_task_list .......................................... } NIL],
*IFEND

{ CLC$UTILITY_BLOCK }

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 0,
          { previous_block ........................................... } NIL,
*IF NOT $true(osv$unix)
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } [],
*IFEND
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
*IF NOT $true(osv$unix)
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
*IFEND
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } TRUE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } FALSE,
          { parameters. unbundled_pdt ................................ } NIL,
          { parameters. command_status_variable ...................... } NIL,
          { parameters. parameter_value_table ........................ } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
*IF NOT $true(osv$unix)
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
*IFEND
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
*IF NOT $true(osv$unix)
          { input_can_be_echoed ...................................... } FALSE,
*IFEND
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'utility',
          { kind_end_name ............................................ } 'end_of_utility',
          { kind ..................................................... } clc$utility_block,
          { notify_before_command_read ............................... } NIL,
          { command_environment. commands ............................ } [NIL,
          { command_environment. contemporary_functions .............. } NIL,
          { command_environment. original_functions .................. } NIL,
          { command_environment. libraries ........................... } NIL,
          { command_environment. subcommand_logging_enabled .......... } TRUE,
          { command_environment. command_level ....................... } FALSE,
          { command_environment. task_id ............................. } 0,
          { command_environment. previous_search_mode ................ } clc$global_command_search,
          { command_environment. termination_command_ordinal ......... } 1,
          { command_environment. termination_command_index ........... } 1,
          { command_environment. auxiliary_libraries ................. } NIL,
          { command_environment. dialog_info. commands ............... } [NIL,
          { command_environment. dialog_info. functions .............. } NIL,
          { command_environment. dialog_info. scratch_segment ........ } NIL]],
          { command_search_mode ...................................... } clc$global_command_search,
          { interactive_include_processor. call_method ............... } [clc$unspecified_call],
          { libraries ................................................ } NIL,
          { line_preprocessor. call_method ........................... } [clc$unspecified_call],
          { online_manual_name ....................................... } osc$null_name,
          { prompt. size ............................................. } [0,
          { prompt. value ............................................ } ''],
          { termination_command_found ................................ } FALSE,
*IF NOT $true(osv$unix)
          { include_processor_active ................................. } FALSE,
          { active_sou_capabilities.saved ... ........................ } [FALSE]],
*ELSE
          { include_processor_active ................................. } FALSE]];
*IFEND

*IF NOT $true(osv$unix)
{ CLC$WHEN_BLOCK }

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 0,
          { previous_block ........................................... } NIL,
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } [],
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } TRUE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } FALSE,
          { parameters. unbundled_pdt ................................ } NIL,
          { parameters. command_status_variable ...................... } NIL,
          { parameters. parameter_value_table ........................ } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
          { input_can_be_echoed ...................................... } FALSE,
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'WHEN',
          { kind_end_name ............................................ } 'WHENEND',
          { kind ..................................................... } clc$when_block,
          { inherited_input. found ................................... } [FALSE],
          { input. internal .......................................... } [FALSE,
          { input. prompting_input ................................... } FALSE,
          { input. line. area ........................................ } [NIL,
          { input. line. text ........................................ } NIL,
          { input. line. lexical_units ............................... } NIL],
          { input. pushed_line ....................................... } NIL,
          { input. kind .............................................. } clc$file_input,
          { input. local_file_name ................................... } osc$null_name,
          { input. file_id. ordinal .................................. } [0,
          { input. file_id. sequence ................................. } 1],
          { input. line_layout. physical_line_size ................... } [clc$max_physical_line_size,
          { input. line_layout. element .............................. } [REP 3 of
          { input. line_layout. element. kind......................... } [clc$null_line_element,
          { input. line_layout. element. size......................... } 0]]],
          { input. get_command_line .................................. } NIL,
          { input. get_line .......................................... } NIL,
          { input. data_line. area ................................... } [NIL,
          { input. data_line. text ................................... } NIL,
          { input. data_line. lexical_units .......................... } NIL],
          { input. line_address_is_for_previous ...................... } FALSE,
          { input. line_address ...................................... } 0,
          { input. record_number ..................................... } 0,
          { input. data .............................................. } NIL,
          { input. file_rereadable ................................... } FALSE,
          { input. interactive_device ................................ } FALSE,
          { input. device_class ...................................... } rmc$mass_storage_device,
          { input. base_prompt_string. size .......................... } [0,
          { input. base_prompt_string. value ......................... } ''],
          { input. current_prompt_string. size ....................... } [0,
          { input. current_prompt_string. value ...................... } ''],
          { input. state ............................................. } clc$continue_input],
          { previous_command. area ................................... } [NIL,
          { previous_command. text ................................... } NIL,
          { previous_command. lexical_units .......................... } NIL],
          { previous_command_name .................................... } osc$null_name,
          { previous_command_status .................................. } [TRUE],
          { proc_name ................................................ } osc$null_name,
          { command_proc_status ...................................... } NIL,
          { command_proc_logging_completed ........................... } FALSE,
          { command_proc_echoing_completed ........................... } FALSE,
          { function_proc_result ..................................... } NIL,
          { expected_function_proc_type .............................. } NIL,
          { when_condition ........................................... } NIL,
          { associated_utility ....................................... } NIL,
          { line_preprocessor_specified .............................. } FALSE],

{ CLC$WHILE_BLOCK }

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 0,
          { previous_block ........................................... } NIL,
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } [],
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } TRUE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } FALSE,
          { parameters. unbundled_pdt ................................ } NIL,
          { parameters. command_status_variable ...................... } NIL,
          { parameters. parameter_value_table ........................ } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
          { input_can_be_echoed ...................................... } FALSE,
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'WHILE',
          { kind_end_name ............................................ } 'WHILEND',
          { kind ..................................................... } clc$while_block,
          { expression_area .......................................... } NIL,
          { expression_parse. text ................................... } [NIL,
          { expression_parse. index .................................. } 1,
          { expression_parse. units_array ............................ } NIL,
          { expression_parse. units_array_index ...................... } 1,
          { expression_parse. index_limit ............................ } 1,
          { expression_parse. unit. size ............................. } [0,
          { expression_parse. unit. kind ............................. } clc$lex_end_of_line],
          { expression_parse. unit_index ............................. } 1,
          { expression_parse. unit_is_space .......................... } FALSE,
          { expression_parse. previous_unit_is_space ................. } FALSE,
          { expression_parse. previous_non_space_unit. size .......... } [0,
          { expression_parse. previous_non_space_unit. kind .......... } clc$lex_end_of_line],
          { expression_parse. previous_non_space_unit_index .......... } 1]]];

*IFEND

?? FMT (FORMAT := ON) ??
?? TITLE := 'clv$job_monitor_task_block', EJECT ??

{
{ This variable contains the initialized task block for the "job monitor" task.
{

?? FMT (FORMAT := OFF) ??

  VAR
*IF NOT $true(osv$unix)
    clv$job_monitor_task_block: [STATIC, oss$task_shared] clt$block :=
*ELSE
    clv$job_monitor_task_block: [STATIC] clt$block :=
*IFEND

          { access_count ............................................. } [0,
          { assignment_counter ....................................... } 1,
          { previous_block ........................................... } NIL,
*IF NOT $true(osv$unix)
          { static_link .............................................. } NIL,
*IF NOT $true(osv$unix)
          { started_application ...................................... } FALSE,
          { application_info ......................................... } NIL,
          { caller_ring .............................................. } osc$user_ring_2,
          { active_capabilities ...................................... } - $avt$conditional_capabilities [],
*IFEND
*IFEND
          { interpreter_mode ......................................... } clc$interpret_mode,
*IF NOT $true(osv$unix)
          { variables. hash_groups ................................... } [[REP clc$max_variable_hash_groups of
          { variables. hash_groups. procedure_variables_in_group ..... } [0,
          { variables. hash_groups. environment_variables_in_group ... } 0,
          { variables. hash_groups. root ............................. } NIL]],
          { variables. thread ........................................ } NIL],
*IFEND
          { parameters. area ......................................... } [NIL,
          { parameters. evaluated .................................... } TRUE,
          { parameters. names ........................................ } NIL,
          { parameters. procedure_parameters ......................... } FALSE,
          { parameters. unbundled_pdt ................................ } NIL,
          { parameters. command_status_variable ...................... } NIL,
          { parameters. parameter_value_table ........................ } NIL],
          { source. index ............................................ } [1,
          { source. size ............................................. } 0,
          { source. reference_index .................................. } 1,
          { source. reference_size ................................... } 0,
          { source. ordinal .......................................... } 1,
          { source. function_interface ............................... } clc$fi_contemporary,
          { source. kind ............................................. } clc$system_commands,
          { source. system_command_table ............................. } NIL],
          { use_command_search_mode .................................. } TRUE,
          { prompting_requested ...................................... } FALSE,
*IF NOT $true(osv$unix)
          { established_handler_info. any_condition_handler .......... } [NIL,
          { established_handler_info. any_fault_handler .............. } NIL,
          { established_handler_info. specific_handler_count ......... } 0,
          { established_handler_info. specific_handlers .............. } NIL],
*IFEND
          { environment_object_info .................................. } NIL,
          { line_identifier. byte_address ............................ } [0,
          { line_identifier. record_number ........................... } 0,
          { line_identifier. line_number_size ........................ } 0,
          { line_identifier. line_number ............................. } '',
          { line_identifier. statement_identifier_size ............... } 0,
          { line_identifier. statement_identifier .................... } ''],
          { line_parse. text ......................................... } [NIL,
          { line_parse. index ........................................ } 1,
          { line_parse. units_array .................................. } NIL,
          { line_parse. units_array_index ............................ } 1,
          { line_parse. index_limit .................................. } 1,
          { line_parse. unit. size ................................... } [0,
          { line_parse. unit. kind ................................... } clc$lex_end_of_line],
          { line_parse. unit_index ................................... } 1,
          { line_parse. unit_is_space ................................ } FALSE,
          { line_parse. previous_unit_is_space ....................... } FALSE,
          { line_parse. previous_non_space_unit. size ................ } [0,
          { line_parse. previous_non_space_unit. kind ................ } clc$lex_end_of_line],
          { line_parse. previous_non_space_unit_index ................ } 1],
*IF NOT $true(osv$unix)
          { input_can_be_echoed ...................................... } FALSE,
*IFEND
          { being_exited ............................................. } FALSE,
          { exit_position. defined ................................... } [FALSE],
          { inheriting_block ......................................... } NIL,
          { label .................................................... } osc$null_name,
          { kind_name ................................................ } 'job',
          { kind_end_name ............................................ } 'end_of_job',
          { kind ..................................................... } clc$task_block,
          { task_id .................................................. } 0,
          { task_kind ................................................ } clc$job_monitor_task,
          { task_link ................................................ } NIL,
*IF NOT $true(osv$unix)
          { application_task_link .................................... } NIL,
*IFEND
          { parent ................................................... } NIL,
          { current_block ............................................ } ^clv$job_monitor_task_block,
*IF NOT $true(osv$unix)
          { display_log_indices ...................................... } [REP 3 of
          { display_log_indices. last_log_entry ...................... } [0,
          { display_log_indices. last_display_log_entry .............. } 0,
          { display_log_indices. last_log_cycle ...................... } 0]],
*IFEND
          { synchronous_with_job ..................................... } TRUE,
          { synchronous_with_parent .................................. } FALSE,
          { command_file ............................................. } osc$null_name,
*IF NOT $true(osv$unix)
          { named_task_list .......................................... } NIL,
          { default_session_file ..................................... } ^osv$timesharing_terminal_file];
*ELSE
          { named_task_list .......................................... } NIL];
*IFEND

*IF NOT $true(osv$unix)
  VAR
    osv$timesharing_terminal_file: [STATIC, READ, oss$job_paged_literal] amt$local_file_name :=
          osc$timesharing_terminal_file;

?? FMT (FORMAT := ON) ??
?? TITLE := 'clv$processing_phase', EJECT ??

{
{ This variable contains the current phase of a job execution, from the
{ clc$job_begin_phase through the clc$job_end_phase.  The user's phase is
{ clc$command_phase.  The other phase's designate the prolog's and epilog's.
{

  VAR
    clv$processing_phase: [XDCL, #GATE, oss$task_shared] clt$processing_phase := clc$job_begin_phase;

*IFEND
?? TITLE := 'clv$initial_application', EJECT ??

{
{ This variable contains the definition of the initial application to be
{ executed within the job.
{

  VAR
*IF NOT $true(osv$unix)
    clv$initial_application: [XDCL, #GATE, oss$task_shared] clt$initial_application := [FALSE];
*ELSE
    clv$initial_application: [XDCL, #GATE] clt$initial_application := [FALSE];
*IFEND

?? TITLE := 'clv$task_list', EJECT ??

{
{ This variable contains information that enables tasks to locate the
{ clt$block's that belong to them.  The HEAD field points to the first entry in
{ the linked list of clc$task_block's.  The LOCK field is used to lock the task
{ list when it is being searched or updated.  The CURRENT_JOB_SYNCHRONOUS_TASK
{ field points to the clt$block for the "innermost" task in the job that is
{ running synchronously with the job's "job monitor" task.  This is needed to
{ determine which task in a job should receive interactive conditions.
{

  VAR
*IF NOT $true(osv$unix)
    clv$task_list: [XDCL, oss$task_shared] clt$task_list := [NIL, [0], NIL];
*ELSE
    clv$task_list: [XDCL] clt$task_list := [NIL, [0], NIL];
*IFEND

?? TITLE := 'clv$user_identification', EJECT ??

{
{ This variable contains information about the user, i.e. the user name, user
{ name size, family name, and family name size.
{

  VAR
*IF NOT $true(osv$unix)
    clv$user_identification: [XDCL, #GATE, oss$task_shared] clt$user_identification := [[0, ''], [0, '']];
*ELSE
    clv$user_identification: [XDCL, #GATE] clt$user_identification := [[0, ''], [0, '']];

?? TITLE := 'clv$in_screen_mode', EJECT ??

{
{ This variable indicates whether we are currently in screen mode.
{

  VAR
    clv$in_screen_mode: [XDCL, #GATE] boolean := FALSE;

*IFEND
*IF NOT $true(osv$unix)

?? TITLE := 'clv$ijl_ordinal', EJECT ??

{
{ This variable contains the IJL ordinal for the job. It is used to emit the
{ ijl ordinal as part of the user keypoints.

  VAR
    clv$ijl_ordinal: [XDCL, #GATE, oss$task_shared] jmt$ijl_ordinal := [0, 0];

?? TITLE := 'clv$unique_name', EJECT ??

{
{ This variable contains a unique name generated via pmp$get_unique_name.
{

  VAR
    clv$unique_name: [XDCL, #GATE, oss$task_shared] ost$name := osc$null_name;

*IFEND
?? TITLE := 'clv$current_task_block', EJECT ??

{
{ This variable contains the pointer to the clc$task_block for the current
{ task.  It is initialized by clp$find_task_block_first_time (see below).
{

  VAR
*IF NOT $true(osv$unix)
    clv$current_task_block: [XDCL, #GATE, oss$task_private] ^clt$block := NIL;
*ELSE
    clv$current_task_block: [XDCL, #GATE] ^clt$block := NIL;
*IFEND

?? TITLE := 'clv$block_assignment_counter', EJECT ??

{
{ This variable is incremented (via osp$increment_locked_variable) every time
{ a new block is created.  The incremented value is then assigned to the
{ assignment_counter field of the new block.  When a block is freed its
{ assignment_counter field is zeroed.  This field therefore can serve as a
{ check that the expected block has been located, e.g. via a clt$block_handle.
{

  VAR
*IF NOT $true(osv$unix)
    clv$block_assignment_counter: [STATIC, oss$task_shared] integer := 1;
*ELSE
    clv$block_assignment_counter: [STATIC] integer := 1;
*IFEND

?? TITLE := 'clv$task_name', EJECT ??

{
{ This variable contains the name of the current task.
{

  VAR
*IF NOT $true(osv$unix)
    clv$task_name: [XDCL, #GATE, oss$task_private] ost$name := osc$null_name;
*ELSE
    clv$task_name: [XDCL, #GATE] ost$name := osc$null_name;
*IFEND

*IF NOT $true(osv$unix)
?? TITLE := 'clv$default_session_file', EJECT ??

*IF NOT $true(osv$unix)


{
{ This variable contains a pointer to the default interaction "session file"
{ to be used by this task.
{ It is initialized by clp$find_def_ses_file_1st_time (see below).
{

  VAR
    clv$default_session_file: [XDCL, oss$task_private] ^fst$file_reference := NIL;

*IFEND
?? TITLE := 'clv$applications_active', EJECT ??

*IF NOT $true(osv$unix)

{
{ This variable contains an integer value that contains the number of
{ applications active in the job.
{

  VAR
    clv$applications_active: [XDCL, #GATE, oss$task_shared] ost$non_negative_integers := 0;

*IFEND
?? TITLE := 'last_scheduled_application', EJECT ??

*IF NOT $true(osv$unix)

{
{ This variable contains a pointer to the most recent block which has special
{ application scheduling.
{

  VAR
    last_scheduled_application: [STATIC, oss$task_shared] record
      lock: ost$signature_lock,
      block: ^clt$block,
    recend := [[0], NIL];

*IFEND
*IFEND
?? TITLE := 'clp$find_task_block_first_time', EJECT ??

{
{ PURPOSE:
{   This procedure is called the first time in a task that the task's clc$task_block is needed.
{   It is only called by clp$find_task_block.
{   If the task list is empty, then this procedure assumes it is being called within the job monitor task
{   for a job and creates a task block for itself and initializes the task list to contain that block.
{

  PROCEDURE [XDCL, #GATE] clp$find_task_block_first_time
    (VAR task_block: ^clt$block;
     VAR status: ost$status);

    VAR
*IF NOT $true(osv$unix)
      current_task_id: pmt$task_id,
      ignore_task_link: ^^clt$block,
      prog_options_and_libraries: ^pmt$prog_options_and_libraries;
*ELSE
      c_status: integer,
      current_task_id: integer,
      ignore_task_link: ^^clt$block;
*IFEND


*IF NOT $true(osv$unix)
    pmp$get_task_id (current_task_id, status);
*ELSE
    c_status := 0;
    pmp_get_task_id (current_task_id, c_status);
    IF c_status = 0 THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_from_errno ('GET_TASK_ID', c_status, '', status);
    IFEND;
*IFEND
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$set_job_signature_lock (clv$task_list.lock);

    IF clv$task_list.head <> NIL THEN
      search_task_list (current_task_id, clv$current_task_block, ignore_task_link);
    ELSE
*IF NOT $true(osv$unix)
      ?IF clc$compiling_for_test_harness THEN
*IFEND
        ALLOCATE clv$current_task_block IN osv$task_shared_heap^;
        clv$current_task_block^ := clv$job_monitor_task_block;
        clv$current_task_block^.current_block := clv$current_task_block;
*IF NOT $true(osv$unix)
      ?ELSE
        clv$current_task_block := ^clv$job_monitor_task_block;
      ?IFEND;
      clv$current_task_block^.caller_ring := avp$ring_nominal ();
*IFEND
      clv$current_task_block^.task_id := current_task_id;
      clp$init_all_environment (clv$current_task_block^.environment_object_info);
*IF NOT $true(osv$unix)
      pmp$find_prog_options_and_libs (prog_options_and_libraries);
      pmp$init_default_prog_options (prog_options_and_libraries^.default_options, status);
      IF NOT status.normal THEN
        osp$clear_job_signature_lock (clv$task_list.lock);
        RETURN;
      IFEND;
*IFEND
      clv$task_list.head := clv$current_task_block;
    IFEND;

    osp$clear_job_signature_lock (clv$task_list.lock);

    IF clv$current_task_block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$find_task_block_first_time', status);
      RETURN;
    IFEND;

    task_block := clv$current_task_block;

  PROCEND clp$find_task_block_first_time;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$find_def_ses_file_1st_time', EJECT ??

{
{ PURPOSE:
{   This procedure is called the first time in a task that the task's default
{   interactive "sesion file" is needed.
{   It is only called by clp$find_default_session_file.
{

*IF NOT $true(osv$unix)

  PROCEDURE [XDCL] clp$find_def_ses_file_1st_time
    (VAR default_session_file: ^fst$file_reference);

    VAR
      block: ^clt$block,
      status: ost$status;


    clp$find_task_block (block, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to get pointer to SCL Task Block', ^status);
    IFEND;

    WHILE block^.synchronous_with_parent OR (block^.default_session_file = NIL) DO
      block := block^.parent;
    WHILEND;

    clv$default_session_file := block^.default_session_file;
    default_session_file := clv$default_session_file;

  PROCEND clp$find_def_ses_file_1st_time;

*IFEND
?? TITLE := 'clp$get_user_identification', EJECT ??

{
{ PURPOSE:
{   This procedure is called when the job is begun in order to retrieve the user identification
{   information, the user ijl ordinal and a unique name for later references.
{

  PROCEDURE [XDCL, #GATE] clp$get_user_identification
    (VAR status: ost$status);

    VAR
      user_id: ost$user_identification;


    status.normal := TRUE;
*IF NOT $true(osv$unix)
    ?IF NOT clc$compiling_for_test_harness THEN
      clv$ijl_ordinal := jmv$jcb.ijl_ordinal;
    ?IFEND
*IFEND

    pmp$get_user_identification (user_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clv$user_identification.user.value := user_id.user;
    clv$user_identification.user.size := osc$max_name_size;
    WHILE (clv$user_identification.user.size > 1) AND (clv$user_identification.user.
          value (clv$user_identification.user.size) = ' ') DO
      clv$user_identification.user.size := clv$user_identification.user.size - 1;
    WHILEND;
    clv$user_identification.family.value := user_id.family;
    clv$user_identification.family.size := osc$max_name_size;
    WHILE (clv$user_identification.family.size > 1) AND (clv$user_identification.family.
          value (clv$user_identification.family.size) = ' ') DO
      clv$user_identification.family.size := clv$user_identification.family.size - 1;
    WHILEND;

    pmp$get_unique_name (clv$unique_name, status);

  PROCEND clp$get_user_identification;
*ELSE
?? TITLE := 'clp$get_screen_mode', EJECT ??

{
{ PURPOSE:
{   This procedure is called to determine whether we are in screen mode.
{

  PROCEDURE [XDCL, #GATE] clp$get_screen_mode
    (VAR in_screen_mode: boolean);


    in_screen_mode := clv$in_screen_mode;

  PROCEND clp$get_screen_mode;
?? TITLE := 'clp$change_screen_mode', EJECT ??

{
{ PURPOSE:
{   This procedure is called to change the screen mode.
{

  PROCEDURE [XDCL, #GATE] clp$change_screen_mode
    (in_screen_mode: boolean);


    clv$in_screen_mode := in_screen_mode;

  PROCEND clp$change_screen_mode;
*IFEND
?? TITLE := 'search_task_list', EJECT ??

  PROCEDURE [INLINE] search_task_list
    (    task_id: pmt$task_id;
     VAR task_block: ^clt$block;
     VAR task_link: ^^clt$block);


    task_link := ^clv$task_list.head;
    task_block := clv$task_list.head;
    WHILE (task_block <> NIL) AND (task_block^.task_id <> task_id) DO
      task_link := ^task_block^.task_link;
      task_block := task_link^;
    WHILEND;

  PROCEND search_task_list;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$record_child_task', EJECT ??
*copyc clh$record_child_task

  PROCEDURE [XDCL] clp$record_child_task
    (    caller_ring: ost$valid_ring;
         child_task_id: pmt$task_id;
         synchronous_with_parent: boolean;
         command_file: amt$local_file_name;
     VAR status: ost$status);

    VAR
      ignore_access_count: integer,
      ignore_cmnd_list_found_in_task: boolean,
      parent_task_block: ^clt$block,
      child_task_block: ^clt$block;


    #KEYPOINT (osk$entry, 0, clk$record_child_task);

    status.normal := TRUE;

  /record_child_task/
    BEGIN
      clp$find_task_block (parent_task_block, status);
      IF NOT status.normal THEN
        EXIT /record_child_task/;
      IFEND;

      create_block (clc$task_block, parent_task_block, child_task_block);

*IF NOT $true(osv$unix)
      child_task_block^.caller_ring := caller_ring;
*IFEND
      child_task_block^.task_id := child_task_id;
      child_task_block^.parent := parent_task_block;
      child_task_block^.current_block := child_task_block;
      child_task_block^.display_log_indices := parent_task_block^.display_log_indices;
      child_task_block^.synchronous_with_job := parent_task_block^.synchronous_with_job AND
            synchronous_with_parent;
      child_task_block^.synchronous_with_parent := synchronous_with_parent;

      IF NOT synchronous_with_parent THEN
*IF NOT $true(osv$unix)
        IF child_task_block^.previous_block^.application_info = NIL THEN
          child_task_block^.previous_block := parent_task_block;
        ELSE

        /find_previous_block_for_appl/
          WHILE TRUE DO
            CASE child_task_block^.previous_block^.kind OF
            = clc$task_block =
              EXIT /find_previous_block_for_appl/;
            = clc$command_block, clc$command_proc_block =
              IF child_task_block^.previous_block^.started_application THEN
                EXIT /find_previous_block_for_appl/;
              IFEND;
            ELSE
              ;
            CASEND;
            child_task_block^.previous_block := child_task_block^.previous_block^.previous_block;
          WHILEND /find_previous_block_for_appl/;
          child_task_block^.application_info := child_task_block^.previous_block^.application_info;
        IFEND;
*ELSE
        child_task_block^.previous_block := parent_task_block;
*IFEND

        child_task_block^.command_file := command_file;

        clp$push_all_environment (child_task_block, status);
        IF NOT status.normal THEN
          FREE child_task_block IN osv$task_shared_heap^;
          EXIT /record_child_task/;
        IFEND;
      IFEND;

      osp$set_job_signature_lock (clv$task_list.lock);
      child_task_block^.task_link := clv$task_list.head;
      clv$task_list.head := child_task_block;
      IF child_task_block^.synchronous_with_job THEN
        clv$task_list.current_job_synchronous_task := child_task_block;
      IFEND;
      osp$clear_job_signature_lock (clv$task_list.lock);

*IF NOT $true(osv$unix)
      IF child_task_block^.previous_block^.started_application THEN
        osp$set_job_signature_lock (child_task_block^.application_info^.lock);
        child_task_block^.application_task_link := child_task_block^.previous_block^.application_info^.
              task_link_head;
        child_task_block^.previous_block^.application_info^.task_link_head := child_task_block;
        osp$clear_job_signature_lock (child_task_block^.application_info^.lock);
      IFEND;
*IFEND

      osp$increment_locked_variable (child_task_block^.previous_block^.access_count, 0, ignore_access_count);
    END /record_child_task/;

    #KEYPOINT (osk$exit, 0, clk$record_child_task);

  PROCEND clp$record_child_task;
?? TITLE := 'clp$erase_child_task', EJECT ??
*copyc clh$erase_child_task

  PROCEDURE [XDCL] clp$erase_child_task
    (    child_task_id: pmt$task_id;
     VAR status: ost$status);

    VAR
      child_task_block: ^clt$block,
      child_task_link: ^^clt$block,
      current_child_block: ^clt$block,
      current_task_link: ^clt$block,
      ignore_status: ^ost$status,
      local_status: ost$status,
      parent_task_block: ^clt$block,
      previous_child_block: ^clt$block,
      synchronous_with_job: boolean,
      synchronous_with_parent: boolean;


    #KEYPOINT (osk$entry, 0, clk$erase_child_task);

    status.normal := TRUE;

  /erase_child_task/
    BEGIN
      osp$set_job_signature_lock (clv$task_list.lock);
      search_task_list (child_task_id, child_task_block, child_task_link);
      child_task_link^ := child_task_block^.task_link;
      synchronous_with_parent := child_task_block^.synchronous_with_parent;
      synchronous_with_job := child_task_block^.synchronous_with_job;
      IF synchronous_with_job AND (child_task_block = clv$task_list.current_job_synchronous_task) THEN
        clv$task_list.current_job_synchronous_task := clv$task_list.current_job_synchronous_task^.parent;
      IFEND;
      osp$clear_job_signature_lock (clv$task_list.lock);

*IF NOT $true(osv$unix)
      IF child_task_block^.previous_block^.started_application THEN
        osp$set_job_signature_lock (child_task_block^.application_info^.lock);
        IF child_task_block^.application_info^.task_link_head <> NIL THEN
          current_task_link := child_task_block^.application_info^.task_link_head;
          IF child_task_block = current_task_link THEN
            child_task_block^.application_info^.task_link_head := child_task_block^.application_task_link;
          ELSE
            WHILE (current_task_link^.application_task_link <> NIL) AND
                  (current_task_link^.application_task_link <> child_task_block) DO
              current_task_link := current_task_link^.application_task_link;
            WHILEND;
            IF current_task_link^.application_task_link <> NIL THEN
              current_task_link^.application_task_link := current_task_link^.application_task_link^.
                    application_task_link;
            ELSE
              osp$set_status_abnormal ('CL', cle$bad_application_task_link,
                    child_task_block^.application_info^.identifier.name, local_status);
              PUSH ignore_status;
              osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], local_status,
                    ignore_status^);
            IFEND;
          IFEND;
        IFEND;
        osp$clear_job_signature_lock (child_task_block^.application_info^.lock);
      IFEND;
*IFEND

      parent_task_block := child_task_block^.parent;

      current_child_block := child_task_block^.current_block;
      WHILE current_child_block <> child_task_block DO
        previous_child_block := current_child_block^.previous_block;
        free_block (clc$eo_pop_for_task, current_child_block);
        current_child_block := previous_child_block;
      WHILEND;

      IF synchronous_with_parent THEN
        parent_task_block^.display_log_indices := child_task_block^.display_log_indices;
      ELSE
        parent_task_block^.display_log_indices [clc$display_system_log] :=
              child_task_block^.display_log_indices [clc$display_system_log];
      IFEND;

      free_block (clc$eo_pop_for_task, child_task_block);

      clp$update_all_environment (synchronous_with_parent, synchronous_with_job, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    END /erase_child_task/;

    #KEYPOINT (osk$exit, 0, clk$erase_child_task);

  PROCEND clp$erase_child_task;
?? TITLE := 'clp$find_current_job_synch_task', EJECT ??
*copyc clh$find_current_job_synch_task

  PROCEDURE [XDCL] clp$find_current_job_synch_task
    (VAR task_id: pmt$task_id;
     VAR status: ost$status);


    status.normal := TRUE;
    osp$set_job_signature_lock (clv$task_list.lock);
    IF clv$task_list.current_job_synchronous_task = NIL THEN
      pmp$get_task_id (task_id, status);
    ELSE
      task_id := clv$task_list.current_job_synchronous_task^.task_id;
    IFEND;
    osp$clear_job_signature_lock (clv$task_list.lock);

  PROCEND clp$find_current_job_synch_task;
?? TITLE := 'clp$get_processing_phase', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$get_processing_phase
    (VAR processing_phase: clt$processing_phase;
     VAR status: ost$status);


    status.normal := TRUE;
    processing_phase := clv$processing_phase;

  PROCEND clp$get_processing_phase;
?? TITLE := 'clp$set_processing_phase', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_processing_phase
    (    processing_phase: clt$processing_phase;
     VAR status: ost$status);


    status.normal := TRUE;
    clv$processing_phase := processing_phase;

  PROCEND clp$set_processing_phase;
*IFEND
?? TITLE := 'clp$define_initial_application', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$define_initial_application
    (    application: ^clt$command_line;
         logout_upon_termination: boolean;
     VAR status: ost$status);


    status.normal := TRUE;

*IF NOT $true(osv$unix)
    IF clv$processing_phase > clc$user_prolog_phase THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'DEFINE_INITIAL_APPLICATION', status);
      RETURN;
    IFEND;
*IFEND

    IF clv$initial_application.defined THEN
      FREE clv$initial_application.application IN osv$task_shared_heap^;
      clv$initial_application.defined := FALSE;
    IFEND;

    IF application <> NIL THEN
      clv$initial_application.defined := TRUE;
      ALLOCATE clv$initial_application.application: [STRLENGTH (application^)] IN osv$task_shared_heap^;
      clv$initial_application.application^ := application^;
      clv$initial_application.logout_upon_termination := logout_upon_termination;
    IFEND;

  PROCEND clp$define_initial_application;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$set_primary_task', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_primary_task
    (VAR status: ost$status);

    VAR
      task_block: ^clt$block,
      local_status: ost$status;


    status.normal := TRUE;
    clp$find_task_block (task_block, local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('Unable to get pointer to SCL Task Block', ^local_status);
    IFEND;
    osp$set_job_signature_lock (clv$task_list.lock);
    task_block^.synchronous_with_job := TRUE;
    clv$task_list.current_job_synchronous_task := task_block;
    osp$clear_job_signature_lock (clv$task_list.lock);

  PROCEND clp$set_primary_task;
?? TITLE := 'clp$get_synchronous_with_parent', EJECT ??
*copyc clh$get_synchronous_with_parent

  PROCEDURE [XDCL, #GATE] clp$get_synchronous_with_parent
    (VAR synchronous_with_parent: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block;


    clp$find_task_block (block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    synchronous_with_parent := block^.synchronous_with_parent;

  PROCEND clp$get_synchronous_with_parent;
?? TITLE := 'clp$push_block_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_block_block
    (    label: ost$name;
     VAR block_block: ^clt$block);

    VAR
      block: ^clt$block;


    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$block_block), clk$push_block_stack);

    push_block (clc$block_block, block);

    block^.label := label;

    block_block := block;

    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$block_block), clk$push_block_stack);

  PROCEND clp$push_block_block;
?? TITLE := 'clp$push_case_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_case_block
    (    selection_value: ^clt$internal_data_value;
     VAR case_block: ^clt$block);

    VAR
      block: ^clt$block;


    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$case_block), clk$push_block_stack);

    push_block (clc$case_block, block);

    IF selection_value = NIL THEN
      block^.interpreter_mode := clc$interpret_mode;
    ELSE
      ALLOCATE block^.case_selection_value: [[REP #SIZE (selection_value^.allocated_space) OF cell]] IN
            osv$task_shared_heap^;
      block^.case_selection_value^ := selection_value^;
    IFEND;

    case_block := block;

    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$case_block), clk$push_block_stack);

  PROCEND clp$push_case_block;
?? TITLE := 'clp$push_check_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_check_block
    (    parameter_name: clt$parameter_name;
     VAR check_block: ^clt$block);

    VAR
      block: ^clt$block;


    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$check_block), clk$push_block_stack);

    push_block (clc$check_block, block);

    block^.label := parameter_name;

    check_block := block;

    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$check_block), clk$push_block_stack);

  PROCEND clp$push_check_block;
*IFEND
?? TITLE := 'clp$push_command_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_command_block
    (    caller_ring: ost$valid_ring;
         command_name: clt$command_name;
         command_source: clt$command_or_function_source;
         command_logging_completed: boolean;
         command_echoing_completed: boolean;
         prompting_requested: boolean;
         command_kind: clt$command_kind;
         parameter_list_parse: clt$parse_state;
     VAR command_block: ^clt$block);

    VAR
      block: ^clt$block,
      caller_id: ost$caller_identifier;


*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$command_block), clk$push_block_stack);
*IFEND

    push_block (clc$command_block, block);

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
    IF caller_ring > caller_id.ring THEN
      block^.caller_ring := caller_ring;
    ELSE
      block^.caller_ring := caller_id.ring;
    IFEND;
*IFEND
    block^.line_parse := parameter_list_parse;
    save_parameter_list (block);
    block^.source := command_source;
    block^.prompting_requested := prompting_requested;
    block^.label := command_name;
    block^.command_kind := command_kind;
*IF NOT $true(osv$unix)
    block^.command_logging_completed := command_logging_completed;
    block^.command_echoing_completed := command_echoing_completed;
*IFEND

    command_block := block;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$command_block), clk$push_block_stack);
*IFEND

  PROCEND clp$push_command_block;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$push_command_proc_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_command_proc_block
    (    caller_ring: ost$valid_ring;
         command_name: clt$command_name;
         command_source: clt$command_or_function_source;
         command_proc_logging_completed: boolean;
         command_proc_echoing_completed: boolean;
         prompting_requested: boolean;
         proc_can_be_echoed: boolean;
         file_name: fst$path_handle_name;
         file_id: amt$file_identifier;
         line_layout: clt$line_layout;
         proc_data: ^clt$input_data;
         proc_data_version: clt$declaration_version;
         device_class: rmt$device_class;
     VAR command_proc_block: ^clt$block);

    VAR
      block: ^clt$block,
      caller_id: ost$caller_identifier;


    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$command_proc_block), clk$push_block_stack);

    push_block (clc$command_proc_block, block);

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
    IF caller_ring > caller_id.ring THEN
      block^.caller_ring := caller_ring;
    ELSE
      block^.caller_ring := caller_id.ring;
    IFEND;
*IFEND
    block^.interpreter_mode := clc$interpret_mode;
    block^.source := command_source;
    block^.prompting_requested := prompting_requested;
    block^.label := command_name;

    block^.input_can_be_echoed := proc_can_be_echoed;
    block^.input.local_file_name := file_name;
    block^.input.file_id := file_id;
    block^.input.data := proc_data;
    IF proc_data <> NIL THEN
      block^.input.line_address := i#current_sequence_position (proc_data);
      IF proc_data_version = 0 THEN
        block^.input.get_command_line := ^clp$get_segment_cmnd_line_v0;
        block^.input.get_line := ^clp$get_segment_line_v0;
      ELSE
        block^.input.get_command_line := ^clp$get_segment_cmnd_line;
        block^.input.get_line := ^clp$get_segment_line;
      IFEND;
      block^.input.file_rereadable := TRUE;
    ELSE
      block^.input.line_layout := line_layout;
      block^.input.get_command_line := ^clp$get_standard_cmnd_line;
      block^.input.get_line := ^clp$get_standard_line;
      block^.input.file_rereadable := device_class = rmc$mass_storage_device;
      block^.input.device_class := device_class;
    IFEND;
    block^.command_proc_logging_completed := command_proc_logging_completed;
    block^.command_proc_echoing_completed := command_proc_echoing_completed;

    command_proc_block := block;

    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$command_proc_block), clk$push_block_stack);

  PROCEND clp$push_command_proc_block;
?? TITLE := 'clp$push_edit_parameters_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_edit_parameters_block
    (    max_string: clt$string_size;
     VAR edit_parameters_block: ^clt$block);

    VAR
      block: ^clt$block;


    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$command_block), clk$push_block_stack);

    push_block (clc$command_block, block);

    block^.interpreter_mode := clc$help_mode;
    block^.label := 'CLP$EDIT_COMMAND_PARAMETER_LIST';
    block^.edited_parameters_max_size := max_string;

    edit_parameters_block := block;

    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$command_block), clk$push_block_stack);

  PROCEND clp$push_edit_parameters_block;
?? TITLE := 'clp$push_for_incremental_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_for_incremental_block
    (    label: ost$name;
         variable: ^clt$variable_ref_expression;
         initial: clt$integer;
         limit: integer;
         increment: integer;
     VAR for_block: ^clt$block);

    VAR
      block: ^clt$block;


    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$for_block), clk$push_block_stack);

    push_block (clc$for_block, block);

    capture_input_position (block, block^.line_identifier, block^.line_parse);
    block^.label := label;
    ALLOCATE block^.for_variable: [STRLENGTH (variable^)] IN osv$task_shared_heap^;
    block^.for_variable^ := variable^;
    block^.for_control.style := clc$for_control_incremental;
    block^.for_control.value := initial;
    block^.for_control.limit := limit;
    block^.for_control.increment := increment;

    for_block := block;

    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$for_block), clk$push_block_stack);

  PROCEND clp$push_for_incremental_block;
?? TITLE := 'clp$push_for_list_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_for_list_block
    (    label: ost$name;
         variable: ^clt$variable_ref_expression;
         list: ^clt$internal_data_value;
     VAR for_block: ^clt$block);

    VAR
      block: ^clt$block;


    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$for_block), clk$push_block_stack);

    push_block (clc$for_block, block);

    block^.label := label;
    IF list = NIL THEN
      block^.interpreter_mode := clc$skip_mode;
      block^.being_exited := TRUE;
      block^.for_control.list := NIL;
    ELSE
      capture_input_position (block, block^.line_identifier, block^.line_parse);
      ALLOCATE block^.for_variable: [STRLENGTH (variable^)] IN osv$task_shared_heap^;
      block^.for_variable^ := variable^;
      block^.for_control.style := clc$for_control_list;
      ALLOCATE block^.for_control.list: [[REP #SIZE (list^.allocated_space) OF cell]] IN
            osv$task_shared_heap^;
      block^.for_control.list^ := list^;
    IFEND;

    for_block := block;

    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$for_block), clk$push_block_stack);

  PROCEND clp$push_for_list_block;
*IFEND
?? TITLE := 'clp$push_function_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_function_block
    (    caller_ring: ost$valid_ring;
         function_name: ost$name;
         function_source: clt$command_or_function_source;
         parameter_list_parse: clt$parse_state;
         expected_result_type: ^clt$type_description;
     VAR function_block: ^clt$block);

    VAR
      block: ^clt$block,
      caller_id: ost$caller_identifier;


*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$function_block), clk$push_block_stack);
*IFEND

    push_block (clc$function_block, block);

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
    IF caller_ring > caller_id.ring THEN
      block^.caller_ring := caller_ring;
    ELSE
      block^.caller_ring := caller_id.ring;
    IFEND;
*IFEND
    block^.line_parse := parameter_list_parse;
    save_parameter_list (block);
    block^.source := function_source;
    block^.prompting_requested := block^.previous_block^.prompting_requested AND
          (NOT block^.previous_block^.parameters.evaluated);
    block^.label := function_name;

    block^.expected_function_type := expected_result_type;

    function_block := block;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$function_block), clk$push_block_stack);
*IFEND

  PROCEND clp$push_function_block;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$push_function_proc_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_function_proc_block
    (    caller_ring: ost$valid_ring;
         function_name: ost$name;
         function_source: clt$command_or_function_source;
         proc_can_be_echoed: boolean;
         file_name: fst$path_handle_name;
         file_id: amt$file_identifier;
         proc_data: ^clt$input_data;
         expected_result_type: ^clt$type_specification;
     VAR function_proc_block: ^clt$block);

    VAR
      block: ^clt$block,
      caller_id: ost$caller_identifier;


    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$function_proc_block), clk$push_block_stack);

    push_block (clc$function_proc_block, block);

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
    IF caller_ring > caller_id.ring THEN
      block^.caller_ring := caller_ring;
    ELSE
      block^.caller_ring := caller_id.ring;
    IFEND;
*IFEND
    block^.interpreter_mode := clc$interpret_mode;
    block^.source := function_source;
    block^.prompting_requested := block^.previous_block^.prompting_requested AND
          (NOT block^.previous_block^.parameters.evaluated);

    block^.input_can_be_echoed := proc_can_be_echoed;
    block^.input.local_file_name := file_name;
    block^.input.file_id := file_id;
    block^.input.data := proc_data;
    block^.input.line_address := i#current_sequence_position (proc_data);
    block^.input.get_command_line := ^clp$get_segment_cmnd_line;
    block^.input.get_line := ^clp$get_segment_line;
    block^.input.file_rereadable := TRUE;

    IF expected_result_type <> NIL THEN
      ALLOCATE block^.expected_function_proc_type: [[REP #SIZE (expected_result_type^) OF cell]] IN
            osv$task_shared_heap^;
      block^.expected_function_proc_type^ := expected_result_type^;
    IFEND;

    function_proc_block := block;

    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$function_proc_block), clk$push_block_stack);

  PROCEND clp$push_function_proc_block;
?? TITLE := 'clp$push_if_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_if_block
    (    condition_met: boolean;
     VAR if_block: ^clt$block);

    VAR
      block: ^clt$block;


    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$if_block), clk$push_block_stack);

    push_block (clc$if_block, block);

    IF NOT condition_met THEN
      block^.interpreter_mode := clc$skip_mode;
    IFEND;
    block^.if_condition_met := condition_met;

    if_block := block;

    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$if_block), clk$push_block_stack);

  PROCEND clp$push_if_block;
*IFEND
?? TITLE := 'clp$push_input_$command_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_input_$command_block
    (    inherited_input_block_offset: ost$segment_offset;
         utility_name: clt$utility_name;
         prompt_string: clt$prompt_string;
         file_id: amt$file_identifier;
         data: ^clt$input_data;
         input_can_be_echoed: boolean;
         inherited_input_in_current_task: boolean;
     VAR input_block: ^clt$block);

    VAR
      block: ^clt$block,
      caller_id: ost$caller_identifier,
      ignore_access_count: integer,
      inherited_input_block: ^clt$block,
      status: ^ost$status,
      utility_block: ^clt$block;


*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$input_block), clk$push_block_stack);
*IFEND

    IF utility_name <> osc$null_name THEN
      find_associated_utility (utility_name, utility_block);
    IFEND;

    push_block (clc$input_block, block);

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
    block^.caller_ring := caller_id.ring;
*IFEND
    block^.interpreter_mode := clc$interpret_mode;
*IF NOT $true(osv$unix)
    block^.input_can_be_echoed := input_can_be_echoed;
*IFEND
    IF utility_name <> osc$null_name THEN
      block^.label := utility_name;
      associate_input_with_utility (block, utility_block);
    ELSEIF (block^.previous_block^.kind = clc$task_block) AND
          (block^.previous_block^.task_kind = clc$job_monitor_task) THEN
*IF NOT $true(osv$unix)
      block^.established_handler_info := block^.previous_block^.established_handler_info;
      block^.previous_block^.established_handler_info :=
            clv$initial_blocks [clc$task_block].established_handler_info;
*IFEND
    IFEND;

  /find_caller_input/
    BEGIN
      inherited_input_block := block^.previous_block;
      WHILE inherited_input_block <> NIL DO
        IF inherited_input_block_offset = #OFFSET (inherited_input_block) THEN
          EXIT /find_caller_input/;
        IFEND;
        inherited_input_block := inherited_input_block^.previous_block;
      WHILEND;
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$push_input_block', status^);
*IF NOT $true(osv$unix)
      pmp$abort (status^);
*ELSE
      return;
*IFEND
    END /find_caller_input/;

    block^.inherited_input.found := TRUE;
    block^.inherited_input.block := inherited_input_block;
    osp$increment_locked_variable (block^.inherited_input.block^.access_count, 1, ignore_access_count);

    block^.use_command_search_mode := block^.inherited_input.block^.use_command_search_mode;
    block^.line_identifier := block^.inherited_input.block^.line_identifier;
    block^.line_parse := block^.inherited_input.block^.line_parse;
    block^.inherited_input.in_current_task := inherited_input_in_current_task;
    block^.inherited_input.block^.inheriting_block := block;
    block^.input := block^.inherited_input.block^.input;
    block^.input.internal := FALSE;

    IF block^.input.kind <> clc$line_input THEN
      IF (NOT inherited_input_in_current_task) AND (block^.input.kind = clc$file_input) THEN
        block^.input.file_id := file_id;
        block^.input.data := data;
      IFEND;

      IF block^.input.interactive_device THEN
        clp$set_prompt_string (block, prompt_string);
        IF block^.input.device_class = rmc$terminal_device THEN
*IF NOT $true(osv$unix)
          set_prompt_file_identifier (block^.input.file_id);
*IFEND
        IFEND;
        IF (NOT inherited_input_in_current_task) AND (block^.input.kind = clc$file_input) THEN
          block^.input.current_prompt_string.size := 0;
          block^.input.current_prompt_string.value := '';
        IFEND;
      IFEND;
    IFEND;

    input_block := block;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$input_block), clk$push_block_stack);
*IFEND

  PROCEND clp$push_input_$command_block;
?? TITLE := 'clp$push_input_file_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_input_file_block
*IF NOT $true(osv$unix)
    (    file_name: fst$path_handle_name;
*ELSE
    (    file_name: fst$path;
*IFEND
         file_id: amt$file_identifier;
         utility_name: clt$utility_name;
         prompt_string: clt$prompt_string;
         input_can_be_echoed: boolean;
         line_layout: clt$line_layout;
         device_class: rmt$device_class;
         file_has_fap: boolean;
         process_utility_end_include: boolean;
     VAR input_block: ^clt$block);

    VAR
      block: ^clt$block,
      caller_id: ost$caller_identifier,
      ignore_access_count: integer,
      inherited_input_block: ^clt$block,
      utility_block: ^clt$block;


*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$input_block), clk$push_block_stack);
*IFEND

    IF utility_name <> osc$null_name THEN
      find_associated_utility (utility_name, utility_block);
    IFEND;

    push_block (clc$input_block, block);

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
    block^.caller_ring := caller_id.ring;
*IFEND
    block^.interpreter_mode := clc$interpret_mode;
    block^.use_command_search_mode := TRUE;
*IF NOT $true(osv$unix)
    block^.input_can_be_echoed := input_can_be_echoed;
*IFEND
    IF utility_name <> osc$null_name THEN
      IF process_utility_end_include THEN
        block^.label := utility_name;
      IFEND;
      associate_input_with_utility (block, utility_block);
    ELSEIF (block^.previous_block^.kind = clc$task_block) AND
          (block^.previous_block^.task_kind = clc$job_monitor_task) THEN
*IF NOT $true(osv$unix)
      block^.established_handler_info := block^.previous_block^.established_handler_info;
      block^.previous_block^.established_handler_info :=
            clv$initial_blocks [clc$task_block].established_handler_info;
*IFEND
    IFEND;

    block^.input.local_file_name := file_name;
    block^.input.file_id := file_id;

*IF NOT $true(osv$unix)
    IF block^.input.local_file_name = clv$standard_files [clc$sf_null_file].path_handle_name THEN
      block^.input.device_class := rmc$null_device;
      block^.input.get_command_line := ^clp$get_non_standard_cmnd_line;
      block^.input.get_line := ^clp$get_non_standard_line;
      block^.input.state := clc$end_of_input;
    ELSE
*IFEND
      block^.input.line_layout := line_layout;
*IF NOT $true(osv$unix)
      IF jmp$job_file_fap (file_name) <> NIL THEN
        block^.input.interactive_device := TRUE;
        block^.input.device_class := rmc$null_device;
      ELSE
*IFEND
        block^.input.device_class := device_class;
        block^.input.interactive_device := block^.input.device_class = rmc$terminal_device;
        block^.input.file_rereadable := block^.input.device_class = rmc$mass_storage_device;
*IF NOT $true(osv$unix)
      IFEND;
*IFEND

*IF NOT $true(osv$unix)

      IF (block^.input.device_class = rmc$mass_storage_device) AND
            (block^.input.line_layout.element [2].kind = clc$null_line_element) AND (NOT file_has_fap) THEN
*ELSE
      IF (block^.input.device_class = rmc$mass_storage_device) THEN
*IFEND
        block^.input.get_command_line := ^clp$get_standard_cmnd_line;
        block^.input.get_line := ^clp$get_standard_line;
      ELSE
        block^.input.get_command_line := ^clp$get_non_standard_cmnd_line;
        block^.input.get_line := ^clp$get_non_standard_line;
      IFEND;
*IF NOT $true(osv$unix)
    IFEND;
*IFEND

    IF block^.input.interactive_device THEN
      clp$set_prompt_string (block, prompt_string);
*IF NOT $true(osv$unix)
      IF block^.input.device_class = rmc$terminal_device THEN
        set_prompt_file_identifier (block^.input.file_id);
      IFEND;
*IFEND
    IFEND;

    input_block := block;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$input_block), clk$push_block_stack);
*IFEND

  PROCEND clp$push_input_file_block;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$push_input_internal_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_input_internal_block
    (    utility_name: clt$utility_name;
         input_can_be_echoed: boolean;
         input_data: ^clt$input_data;
     VAR internal_input_block: ^clt$block);

    VAR
      block: ^clt$block,
      caller_id: ost$caller_identifier,
      utility_block: ^clt$block;


    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$input_block), clk$push_block_stack);

    IF utility_name <> osc$null_name THEN
      find_associated_utility (utility_name, utility_block);
    IFEND;

    push_block (clc$input_block, block);

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
    block^.caller_ring := caller_id.ring;
*IFEND
    block^.interpreter_mode := clc$interpret_mode;
    block^.input_can_be_echoed := input_can_be_echoed;
    IF utility_name <> osc$null_name THEN
      block^.label := utility_name;
      associate_input_with_utility (block, utility_block);
    ELSEIF (block^.previous_block^.kind = clc$task_block) AND
          (block^.previous_block^.task_kind = clc$job_monitor_task) THEN
      block^.established_handler_info := block^.previous_block^.established_handler_info;
      block^.previous_block^.established_handler_info :=
            clv$initial_blocks [clc$task_block].established_handler_info;
    IFEND;

    block^.input.internal := TRUE;
    block^.input.kind := clc$sequence_input;
    clp$save_collect_statement_area (input_data, block^.input.data);
    block^.input.line_address := i#current_sequence_position (input_data);
    block^.input.get_command_line := ^clp$get_segment_cmnd_line;
    block^.input.get_line := ^clp$get_segment_line;
    block^.input.file_rereadable := TRUE;

    internal_input_block := block;

    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$input_block), clk$push_block_stack);

  PROCEND clp$push_input_internal_block;
?? TITLE := 'clp$push_input_line_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_input_line_block
    (    utility_name: clt$utility_name;
         input_can_be_echoed: boolean;
         statement_list: ^clt$command_line;
         lexical_units: ^clt$lexical_units;
     VAR input_line_block: ^clt$block);

    VAR
      block: ^clt$block,
      caller_id: ost$caller_identifier,
      utility_block: ^clt$block;


    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$input_block), clk$push_block_stack);

    IF utility_name <> osc$null_name THEN
      find_associated_utility (utility_name, utility_block);
    IFEND;

    push_block (clc$input_block, block);

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
    block^.caller_ring := caller_id.ring;
*IFEND
    block^.interpreter_mode := clc$interpret_mode;
    block^.use_command_search_mode := TRUE;
    block^.input_can_be_echoed := input_can_be_echoed;
    IF utility_name <> osc$null_name THEN
      block^.label := utility_name;
      associate_input_with_utility (block, utility_block);
    ELSEIF (block^.previous_block^.kind = clc$task_block) AND
          (block^.previous_block^.task_kind = clc$job_monitor_task) THEN
      block^.established_handler_info := block^.previous_block^.established_handler_info;
      block^.previous_block^.established_handler_info :=
            clv$initial_blocks [clc$task_block].established_handler_info;
    IFEND;

    clp$store_expandable_string (statement_list, lexical_units, block^.input.line);
    clp$initialize_parse_state (block^.input.line.text, block^.input.line.lexical_units, block^.line_parse);
    block^.input.kind := clc$line_input;

    input_line_block := block;

    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$input_block), clk$push_block_stack);

  PROCEND clp$push_input_line_block;
?? TITLE := 'clp$push_loop_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_loop_block
    (    label: ost$name;
     VAR loop_block: ^clt$block);

    VAR
      block: ^clt$block;


    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$loop_block), clk$push_block_stack);

    push_block (clc$loop_block, block);

    capture_input_position (block, block^.line_identifier, block^.line_parse);
    block^.label := label;

    loop_block := block;

    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$loop_block), clk$push_block_stack);

  PROCEND clp$push_loop_block;
?? TITLE := 'clp$push_repeat_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_repeat_block
    (    label: ost$name;
     VAR repeat_block: ^clt$block);

    VAR
      block: ^clt$block;


    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$repeat_block), clk$push_block_stack);

    push_block (clc$repeat_block, block);

    capture_input_position (block, block^.line_identifier, block^.line_parse);
    block^.label := label;

    repeat_block := block;

    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$repeat_block), clk$push_block_stack);

  PROCEND clp$push_repeat_block;
?? TITLE := 'clp$push_sub_parameters_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_sub_parameters_block
    (    lookup_functions_and_variables: boolean);

    VAR
      block: ^clt$block;


    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$sub_parameters_block), clk$push_block_stack);

    push_block (clc$sub_parameters_block, block);

    block^.lookup_functions_and_variables := lookup_functions_and_variables;

    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$sub_parameters_block), clk$push_block_stack);

  PROCEND clp$push_sub_parameters_block;
*IFEND
?? TITLE := 'clp$push_utility_block', EJECT ??

  PROCEDURE [XDCL] clp$push_utility_block
    (    utility_name: clt$utility_name;
     VAR utility_block: ^clt$block);

    VAR
      block: ^clt$block;


*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$utility_block), clk$push_block_stack);
*IFEND

    push_block (clc$utility_block, block);

    block^.label := utility_name;

    utility_block := block;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$utility_block), clk$push_block_stack);
*IFEND

  PROCEND clp$push_utility_block;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$push_when_input_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_when_input_block
    (    condition_definition: clt$when_condition_definition;
         exit_on_continue_condition: boolean;
         default_handler: ^procedure (VAR status: ost$status);
         command: ^clt$command_line;
         command_name: clt$command_name;
         handler_statements: ^clt$established_handler_stmnts;
         static_link_handle: clt$block_handle;
     VAR when_block: ^clt$block);

    VAR
      block: ^clt$block,
      caller_id: ost$caller_identifier,
      command_string: ^clt$command_line,
      ignore_block_in_current_task: boolean,
      ignore_block_is_synchronous: boolean;


    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$when_block), clk$push_block_stack);

*IF NOT $true(osv$unix)
    ?IF NOT clc$compiling_for_test_harness THEN
      osp$verify_system_privilege;
    ?IFEND;
*IFEND

    push_block (clc$when_block, block);

    clp$find_block_via_handle (static_link_handle, block^.static_link, ignore_block_in_current_task,
          ignore_block_is_synchronous);

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
    block^.caller_ring := caller_id.ring;
*IFEND
    block^.interpreter_mode := clc$interpret_mode;
    block^.use_command_search_mode := block^.static_link^.use_command_search_mode;
    block^.input_can_be_echoed := handler_statements^.can_be_echoed;
    block^.input.kind := clc$sequence_input;
    block^.input.get_command_line := ^clp$get_segment_cmnd_line;
    block^.input.get_line := ^clp$get_segment_line;
    block^.input.data := ^handler_statements^.statement_area;
    RESET block^.input.data;
    block^.input.file_rereadable := TRUE;

    IF command = NIL THEN
      PUSH command_string: [0];
    ELSE
      command_string := command;
    IFEND;
    ALLOCATE block^.when_condition: [STRLENGTH (command_string^)] IN osv$task_shared_heap^;
    block^.when_condition^.name := condition_definition.name;
    IF condition_definition.status.normal THEN
      block^.when_condition^.status.normal := TRUE;
    ELSE
      block^.when_condition^.status := condition_definition.status;
    IFEND;
    block^.when_condition^.limit_name := condition_definition.limit_name;
    block^.when_condition^.exit_on_continue_condition := exit_on_continue_condition;
    block^.when_condition^.default_handler := default_handler;
    block^.when_condition^.condition_processed_state := clc$continue_next;
    block^.when_condition^.command_name := command_name;
    block^.when_condition^.command := command_string^;

    clp$store_expandable_string (command_string, NIL, block^.previous_command);
    block^.previous_command_name := command_name;
    block^.previous_command_status := condition_definition.status;

    IF (condition_definition.name = clc$wc_execution_fault) OR
          (condition_definition.name = clc$wc_command_fault) THEN

{ Since an EXECUTION_FAULT condition is intended for "debugging" purposes,
{ remove the "static link" for a "when block" invoked for that condition.
{ This allows the condition handler to "see" everything at the point where
{ the error occurred (e.g. variables).
{ This is also necessary for a COMMAND_FAULT because its handler may have
{ been established in an "inherited input" block.

      block^.static_link := NIL;
    IFEND;

    when_block := block;

    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$when_block), clk$push_block_stack);

  PROCEND clp$push_when_input_block;
?? TITLE := 'clp$push_while_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_while_block
    (    label: ost$name;
         condition: boolean;
         expression_parse: clt$parse_state;
     VAR while_block: ^clt$block);

    VAR
      block: ^clt$block;


    #KEYPOINT (osk$entry, osk$m * $INTEGER (clc$while_block), clk$push_block_stack);

    push_block (clc$while_block, block);

    block^.label := label;
    IF NOT condition THEN
      block^.interpreter_mode := clc$skip_mode;
      block^.being_exited := TRUE;
    ELSE
      capture_input_position (block, block^.line_identifier, block^.line_parse);
      ALLOCATE block^.expression_area: [[REP STRLENGTH (expression_parse.text^) OF
            char, REP UPPERBOUND (expression_parse.units_array^) OF clt$lexical_unit]] IN
            osv$task_shared_heap^;
      RESET block^.expression_area;
      block^.expression_parse := expression_parse;
      NEXT block^.expression_parse.text: [STRLENGTH (expression_parse.text^)] IN block^.expression_area;
      block^.expression_parse.text^ := expression_parse.text^;
      NEXT block^.expression_parse.units_array: [1 .. UPPERBOUND (expression_parse.units_array^)] IN
            block^.expression_area;
      block^.expression_parse.units_array^ := expression_parse.units_array^;
    IFEND;

    while_block := block;

    #KEYPOINT (osk$exit, osk$m * $INTEGER (clc$while_block), clk$push_block_stack);

  PROCEND clp$push_while_block;
*IFEND
?? TITLE := 'push_block', EJECT ??

  PROCEDURE [INLINE] push_block
    (    block_kind: clt$block_kind;
     VAR block: ^clt$block);

    VAR
      ignore_access_count: integer,
      status: ost$status,
      task_block: ^clt$block;


    clp$find_task_block (task_block, status);
    IF NOT status.normal THEN
*IF NOT $true(osv$unix)
      osp$system_error ('Unable to get pointer to SCL Task Block', ^status);
*ELSE
      RETURN;
*IFEND
    IFEND;

    create_block (block_kind, task_block, block);
    task_block^.current_block := block;

    osp$increment_locked_variable (block^.previous_block^.access_count, 0, ignore_access_count);

  PROCEND push_block;
?? TITLE := 'create_block', EJECT ??

  PROCEDURE [INLINE] create_block
    (    block_kind: clt$block_kind;
         task_block: ^clt$block;
     VAR new_block: ^clt$block);


    ALLOCATE new_block IN osv$task_shared_heap^;
    new_block^ := clv$initial_blocks [block_kind];

{! Subsequent to the above initialization, any further references to the
{! access_count field MUST be made via the OSP$xxx_LOCKED_VARIABLE interfaces.

    new_block^.previous_block := task_block^.current_block;
*IF NOT $true(osv$unix)
    new_block^.application_info := new_block^.previous_block^.application_info;
    new_block^.caller_ring := new_block^.previous_block^.caller_ring;
    new_block^.active_capabilities := new_block^.previous_block^.active_capabilities;
*IFEND
    new_block^.interpreter_mode := new_block^.previous_block^.interpreter_mode;
    new_block^.source := new_block^.previous_block^.source;
    new_block^.use_command_search_mode := new_block^.previous_block^.use_command_search_mode;
*IF NOT $true(osv$unix)
    new_block^.input_can_be_echoed := new_block^.previous_block^.input_can_be_echoed;
*IFEND

    osp$increment_locked_variable (clv$block_assignment_counter, 0, new_block^.assignment_counter);

  PROCEND create_block;
?? TITLE := 'find_associated_utility', EJECT ??

  PROCEDURE [INLINE] find_associated_utility
    (    utility_name: clt$utility_name;
     VAR utility_block: ^clt$block);

    VAR
      block_in_current_task: boolean,
      status: ^ost$status;


    clp$find_utility_block (utility_name, utility_block, block_in_current_task);

    IF (utility_block = NIL) OR (NOT (utility_block^.command_environment.command_level OR
          block_in_current_task)) THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'find_associated_utility', status^);
*IF NOT $true(osv$unix)
      pmp$abort (status^);
*ELSE
      RETURN;
*IFEND
    IFEND;

  PROCEND find_associated_utility;
?? TITLE := 'associate_input_with_utility', EJECT ??

  PROCEDURE [INLINE] associate_input_with_utility
    (    input_block: ^clt$block;
         utility_block: ^clt$block);

    VAR
      ignore_access_count: integer;


    utility_block^.termination_command_found := FALSE;

    input_block^.associated_utility := utility_block;
    input_block^.line_preprocessor_specified := utility_block^.line_preprocessor.call_method <>
          clc$unspecified_call;

    osp$increment_locked_variable (utility_block^.access_count, 1, ignore_access_count);

  PROCEND associate_input_with_utility;
*IF NOT $true(osv$unix)
?? TITLE := 'capture_input_position', EJECT ??

  PROCEDURE [INLINE] capture_input_position
    (    block: ^clt$block;
     VAR line_identifier: clt$line_identifier;
     VAR line_parse: clt$parse_state);

    VAR
      input_block: ^clt$block;


    input_block := block;
    WHILE (input_block <> NIL) AND (NOT (input_block^.kind IN $clt$block_kinds
          [clc$command_proc_block, clc$input_block, clc$function_proc_block, clc$when_block])) DO
      input_block := input_block^.previous_block;
    WHILEND;
    IF input_block <> NIL THEN
      line_identifier := input_block^.line_identifier;
      line_parse := input_block^.line_parse;
    IFEND;

  PROCEND capture_input_position;
*IFEND
?? TITLE := 'save_parameter_list', EJECT ??

  PROCEDURE [INLINE] save_parameter_list
    (    block: ^clt$block);

    VAR
      amount_to_save: integer,
      saved_text: ^clt$string_value,
      saved_units_array: ^clt$lexical_units;


*IF $true(osv$unix)

    amount_to_save := #SIZE (block^.line_parse.text^) + #SIZE (block^.line_parse.units_array^);
    amount_to_save := amount_to_save + (amount_to_save DIV 4) * 4;
    ALLOCATE block^.parameters.area: [[REP amount_to_save OF cell]] IN osv$task_shared_heap^;
    RESET block^.parameters.area;
    NEXT saved_text: [STRLENGTH (block^.line_parse.text^)] IN block^.parameters.area;
    saved_text^ := block^.line_parse.text^;
    block^.line_parse.text := saved_text;
    NEXT saved_units_array: [1 .. UPPERBOUND (block^.line_parse.units_array^)] IN block^.parameters.area;
    saved_units_array^ := block^.line_parse.units_array^;
    block^.line_parse.units_array := saved_units_array;

*ELSE

    IF #SEGMENT (block^.line_parse.text) <> #SEGMENT (block) THEN
      amount_to_save := #SIZE (block^.line_parse.text^);
    ELSE
      amount_to_save := 0;
    IFEND;
    IF #SEGMENT (block^.line_parse.units_array) <> #SEGMENT (block) THEN
      amount_to_save := amount_to_save + #SIZE (block^.line_parse.units_array^);
    IFEND;

    IF amount_to_save = 0 THEN
      RETURN;
    IFEND;

    ALLOCATE block^.parameters.area: [[REP amount_to_save OF cell]] IN osv$task_shared_heap^;
    RESET block^.parameters.area;
    IF #SEGMENT (block^.line_parse.text) <> #SEGMENT (block) THEN
      NEXT saved_text: [STRLENGTH (block^.line_parse.text^)] IN block^.parameters.area;
      saved_text^ := block^.line_parse.text^;
      block^.line_parse.text := saved_text;
    IFEND;
    IF #SEGMENT (block^.line_parse.units_array) <> #SEGMENT (block) THEN
      NEXT saved_units_array: [1 .. UPPERBOUND (block^.line_parse.units_array^)] IN block^.parameters.area;
      saved_units_array^ := block^.line_parse.units_array^;
      block^.line_parse.units_array := saved_units_array;
    IFEND;

*IFEND

  PROCEND save_parameter_list;
*IF NOT $true(osv$unix)
?? TITLE := 'set_prompt_file_identifier', EJECT ??

  PROCEDURE set_prompt_file_identifier
    (    input_file_id: amt$file_identifier);

    CONST
      default_prompt_file = '$LOCAL.OUTPUT.1';

    VAR
      connection_attributes: array [1 .. 1] of ift$connection_attribute,
      get_connection_attributes: array [1 .. 1] of ift$get_connection_attribute,
      ignore_status: ost$status;


    get_connection_attributes [1].key := ifc$prompt_file;
    get_connection_attributes [1].prompt_file := default_prompt_file;
    iip$direct_fetch_trm_conn_atts (input_file_id, get_connection_attributes, ignore_status);
    IF get_connection_attributes [1].prompt_file = default_prompt_file THEN
      connection_attributes [1].key := ifc$prompt_file_identifier;
      clp$get_system_file_id (clc$job_output, connection_attributes [1].prompt_file_identifier,
            ignore_status);
      iip$direct_store_trm_conn_atts (input_file_id, connection_attributes, ignore_status);
    IFEND;

  PROCEND set_prompt_file_identifier;
*IFEND
?? TITLE := 'clp$pop_block_stack', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$pop_block_stack
    (VAR current_block: ^clt$block);

    VAR
*IF NOT $true(osv$unix)
      audit_information: sft$audit_information,
      conditional_capability: avt$conditional_capability,
      deactivated_capabilities: avt$conditional_capabilities,
*IFEND
      task_block: ^clt$block,
      old_block: ^clt$block,
      segment_pointer: mmt$segment_pointer,
      status: ost$status;


*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, 0, clk$pop_block_stack);
*IFEND

    clp$find_task_block (task_block, status);
    IF NOT status.normal THEN
*IF NOT $true(osv$unix)
      osp$system_error ('Unable to get pointer to SCL Task Block', ^status);
    ELSEIF task_block^.current_block = task_block THEN
      osp$system_error ('Unexpected call to clp$pop_block_stack', ^status);
    IFEND;
*ELSE
      RETURN;
    IFEND;
*IFEND
    old_block := task_block^.current_block^.previous_block;

*IF NOT $true(osv$unix)
    IF (task_block^.current_block^.kind = clc$utility_block) AND
          (task_block^.current_block^.command_environment.dialog_info.scratch_segment <> NIL) THEN
      segment_pointer.kind := mmc$sequence_pointer;
      segment_pointer.seq_pointer := task_block^.current_block^.command_environment.dialog_info.
            scratch_segment;
      mmp$delete_segment (segment_pointer, osc$tsrv_ring, status);
      status.normal := TRUE; { delete status intentionally ignored }
    IFEND;
*IFEND

*IF NOT $true(osv$unix)
    IF task_block^.current_block^.started_application AND
          (task_block^.current_block^.kind = clc$command_proc_block) THEN
      end_application_procedure (task_block^.current_block^.application_info);
    IFEND;

{ Emit audit statistic when conditional capabilities are being deactivated.

    IF avp$security_option_active (avc$vso_security_audit) THEN
      deactivated_capabilities := task_block^.current_block^.active_capabilities -
            old_block^.active_capabilities;
      IF deactivated_capabilities <> $avt$conditional_capabilities [] THEN
        audit_information.audited_operation := sfc$ao_val_deact_capability;
        status.normal := TRUE; { status to be reported on the audit statistic }
        FOR conditional_capability := LOWERVALUE (conditional_capability)
              TO UPPERVALUE (conditional_capability) DO
          IF conditional_capability IN deactivated_capabilities THEN
            audit_information.activate_capability.field_name_p :=
                  ^avv$cond_capability_names [conditional_capability];
            sfp$emit_audit_statistic (audit_information, status);
          IFEND;
        FOREND;
      IFEND;
    IFEND;
*IFEND

*IF NOT $true(osv$unix)
    IF (task_block^.current_block^.kind = clc$sub_parameters_block) AND
          (task_block^.current_block^.sub_parameters_work_area_ptr <> NIL) THEN
      task_block^.current_block^.sub_parameters_work_area_ptr^ :=
            task_block^.current_block^.sub_parameters_work_area;
    IFEND;
*IFEND

    free_block (clc$eo_pop_for_block, task_block^.current_block);

    task_block^.current_block := old_block;
    current_block := old_block;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, 0, clk$pop_block_stack);
*IFEND

  PROCEND clp$pop_block_stack;
?? TITLE := 'free_block', EJECT ??

  PROCEDURE free_block
    (    pop_reason: clc$eo_pop_for_block .. clc$eo_pop_for_task;
     VAR block {input, output} : ^clt$block);

?? NEWTITLE := 'delete_util_from_cmnd_list', EJECT ??

    PROCEDURE delete_util_from_cmnd_list;

      VAR
        delete_status: ost$status,
        ignore_status: ost$status;


      clp$delete_util_from_cmnd_list (block, delete_status);
*IF NOT $true(osv$unix)
      IF NOT delete_status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], delete_status,
              ignore_status);
      IFEND;
*IFEND

    PROCEND delete_util_from_cmnd_list;
?? TITLE := 'record_block_access_count_error', EJECT ??

    PROCEDURE record_block_access_count_error
      (    problem_block: ^clt$block);

      VAR
        local_status: ost$status,
        problem_status: ost$status;


      osp$set_status_abnormal ('CL', cle$block_access_count_error, problem_block^.kind_name, problem_status);
*IF NOT $true(osv$unix)
*IF $true(osv$unix)
      osp$append_status_integer (osc$status_parameter_delimiter, #OFFSET (problem_block), 16, FALSE,
            problem_status);
*ELSE
      osp$append_status_integer (osc$status_parameter_delimiter, #RING (problem_block), 16, FALSE,
            problem_status);
      osp$append_status_integer (' ', #SEGMENT (problem_block), 16, FALSE, problem_status);
      osp$append_status_integer (' ', #OFFSET (problem_block), 16, FALSE, problem_status);
*IFEND
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], problem_status,
            local_status);
      IF NOT local_status.normal THEN
        pmp$log_ascii ('** ** ** **   FATAL  -- -- -- -- CLE$BLOCK_ACCESS_COUNT_ERROR ...',
              $pmt$ascii_logset [pmc$job_log, pmc$system_log], pmc$msg_origin_system, local_status);
        pmp$log_ascii (problem_status.text.value (1, problem_status.text.size), $pmt$ascii_logset
              [pmc$job_log, pmc$system_log], pmc$msg_origin_system, local_status);
      IFEND;
*IFEND

    PROCEND record_block_access_count_error;
?? TITLE := 'record_unable_to_free_block', EJECT ??

    PROCEDURE record_unable_to_free_block
      (    problem_block: ^clt$block;
           access_count: integer);

      VAR
        local_status: ost$status,
        problem_status: ost$status;


      osp$set_status_abnormal ('CL', cle$unable_to_free_block, problem_block^.kind_name, problem_status);
*IF NOT $true(osv$unix)
      osp$append_status_integer (osc$status_parameter_delimiter, access_count, 10, FALSE, problem_status);
*IF $true(osv$unix)
      osp$append_status_integer (osc$status_parameter_delimiter, #OFFSET (problem_block), 16, FALSE,
            problem_status);
*ELSE
      osp$append_status_integer (osc$status_parameter_delimiter, #RING (problem_block), 16, FALSE,
            problem_status);
      osp$append_status_integer (' ', #SEGMENT (problem_block), 16, FALSE, problem_status);
      osp$append_status_integer (' ', #OFFSET (problem_block), 16, FALSE, problem_status);
*IFEND
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], problem_status,
            local_status);
      IF NOT local_status.normal THEN
        pmp$log_ascii ('** ** ** **   FATAL  -- -- -- -- CLE$UNABLE_TO_FREE_BLOCK ...',
              $pmt$ascii_logset [pmc$job_log, pmc$system_log], pmc$msg_origin_system, local_status);
        pmp$log_ascii (problem_status.text.value (1, problem_status.text.size), $pmt$ascii_logset
              [pmc$job_log, pmc$system_log], pmc$msg_origin_system, local_status);
      IFEND;
*IFEND

    PROCEND record_unable_to_free_block;
?? OLDTITLE, EJECT ??

    VAR
      access_count: integer,
      access_count_error: boolean,
      current_task: ^clt$named_task,
      data_positioner: ^array [1 .. * ] of cell,
      ignore_status: ost$status,
      next_task: ^clt$named_task,
      previous_pushed_line: ^clt$pushed_line,
      previous_unseen_mail_block: ^clt$block;


*IF NOT $true(osv$unix)
    IF block^.started_application THEN
      end_application (block^.application_info);
      FREE block^.application_info IN osv$task_shared_heap^;
    IFEND;

    IF block^.variables.thread <> NIL THEN
      clp$delete_variables (block^.variables);
    IFEND;

*IFEND
    IF block^.parameters.area <> NIL THEN
*IF $true(osv$unix)
      FREE block^.parameters.area IN osv$task_shared_heap^;
*ELSE
      clp$delete_parameters (block^.parameters);
*IFEND
    IFEND;
*IF NOT $true(osv$unix)

    IF (block^.kind = clc$input_block) AND (block^.previous_block^.kind = clc$task_block) AND
          (block^.previous_block^.task_kind = clc$job_monitor_task) THEN
      block^.previous_block^.established_handler_info := block^.established_handler_info;
    ELSE
      clp$free_all_handlers_in_block (block);
    IFEND;

    IF block^.environment_object_info <> NIL THEN
      clp$pop_all_environment (pop_reason, block);
    IFEND;
*IFEND

    CASE block^.kind OF

*IF NOT $true(osv$unix)
    = clc$case_block =
      IF block^.case_selection_value <> NIL THEN
        FREE block^.case_selection_value IN osv$task_shared_heap^;
      IFEND;

    = clc$command_block =
      IF block^.help_output_file <> NIL THEN
        FREE block^.help_output_file IN osv$task_shared_heap^;
      IFEND;
      IF block^.edited_parameters <> NIL THEN
        FREE block^.edited_parameters IN osv$task_shared_heap^;
      IFEND;

    = clc$command_proc_block, clc$function_proc_block, clc$input_block, clc$when_block =
      IF block^.command_proc_status <> NIL THEN
        FREE block^.command_proc_status IN osv$task_shared_heap^;
      IFEND;
      IF block^.function_proc_result <> NIL THEN
        FREE block^.function_proc_result IN osv$task_shared_heap^;
      IFEND;
      IF block^.expected_function_proc_type <> NIL THEN
        FREE block^.expected_function_proc_type IN osv$task_shared_heap^;
      IFEND;
*ELSE
    = clc$input_block =
*IFEND
      IF block^.input.internal THEN
        FREE block^.input.data IN osv$task_shared_heap^;
      IFEND;
*IF NOT $true(osv$unix)
      IF block^.when_condition <> NIL THEN
        FREE block^.when_condition IN osv$task_shared_heap^;
      IFEND;
*IFEND

      IF NOT block^.inherited_input.found THEN
        clp$delete_expandable_string (block^.input.line);
        IF block^.input.kind <> clc$line_input THEN
          clp$delete_expandable_string (block^.input.data_line);
        IFEND;
        WHILE block^.input.pushed_line <> NIL DO
          clp$delete_expandable_string (block^.input.pushed_line^.line);
          previous_pushed_line := block^.input.pushed_line^.previous;
          FREE block^.input.pushed_line IN osv$task_shared_heap^;
          block^.input.pushed_line := previous_pushed_line;
        WHILEND;

      ELSE
        block^.inherited_input.block^.inheriting_block := NIL;
        IF block^.input.kind <> clc$line_input THEN
          CASE block^.input.state OF
          = clc$reset_input, clc$update_input =
            block^.inherited_input.block^.input.state := block^.input.state;
          = clc$end_of_input =
            IF NOT block^.input.interactive_device THEN
              block^.inherited_input.block^.input.state := block^.input.state;
            IFEND;
          ELSE {clc$continue_input}
            IF block^.input.file_rereadable AND (NOT block^.inherited_input.in_current_task) AND
                  (block^.input.line_address <> block^.inherited_input.block^.input.line_address) THEN
              block^.inherited_input.block^.input.state := clc$update_input;
            IFEND;
          CASEND;
          block^.inherited_input.block^.input.data_line := block^.input.data_line;
          IF (block^.inherited_input.block^.input.state <> clc$reset_input) OR
                block^.inherited_input.in_current_task THEN
            block^.inherited_input.block^.input.line_address_is_for_previous :=
                  block^.input.line_address_is_for_previous;
            block^.inherited_input.block^.input.line_address := block^.input.line_address;
          IFEND;
          IF (block^.inherited_input.block^.input.data <> NIL) THEN
            RESET block^.inherited_input.block^.input.data;
            IF block^.input.line_address > 0 THEN
              NEXT data_positioner: [1 .. block^.input.line_address] IN
                    block^.inherited_input.block^.input.data;
            IFEND;
          IFEND;
          IF block^.inherited_input.in_current_task THEN
            block^.inherited_input.block^.input.current_prompt_string := block^.input.current_prompt_string;
          IFEND;
        IFEND;
        block^.inherited_input.block^.input.line := block^.input.line;
        block^.inherited_input.block^.line_parse := block^.line_parse;
        block^.inherited_input.block^.line_identifier := block^.line_identifier;
        block^.inherited_input.block^.input.pushed_line := block^.input.pushed_line;

        osp$decrement_locked_variable (block^.inherited_input.block^.access_count, 2, access_count,
              access_count_error);
        IF access_count_error THEN
          record_block_access_count_error (block^.inherited_input.block);
        IFEND;
        block^.inherited_input.block := NIL;
        block^.inherited_input.found := FALSE;
      IFEND;

      IF block^.associated_utility <> NIL THEN
        osp$decrement_locked_variable (block^.associated_utility^.access_count, 2, access_count,
              access_count_error);
        IF access_count_error THEN
          record_block_access_count_error (block^.associated_utility);
        IFEND;
        block^.associated_utility := NIL;
      IFEND;

*IF NOT $true(osv$unix)
    = clc$for_block =
      IF block^.for_variable <> NIL THEN
        FREE block^.for_variable IN osv$task_shared_heap^;
      IFEND;
      IF (block^.for_control.style = clc$for_control_list) AND (block^.for_control.list <> NIL) THEN
        FREE block^.for_control.list IN osv$task_shared_heap^;
      IFEND;

    = clc$repeat_block, clc$while_block =
      IF block^.expression_area <> NIL THEN
        FREE block^.expression_area IN osv$task_shared_heap^;
      IFEND;
*IFEND

    = clc$utility_block =
      delete_util_from_cmnd_list;
      IF block^.command_environment.commands <> NIL THEN
        FREE block^.command_environment.commands IN osv$task_shared_heap^;
      IFEND;
      IF block^.command_environment.contemporary_functions <> NIL THEN
        FREE block^.command_environment.contemporary_functions IN osv$task_shared_heap^;
      IFEND;
      IF block^.command_environment.original_functions <> NIL THEN
        FREE block^.command_environment.original_functions IN osv$task_shared_heap^;
      IFEND;
      IF block^.command_environment.libraries <> NIL THEN
        FREE block^.command_environment.libraries IN osv$task_shared_heap^;
      IFEND;
      IF block^.command_environment.auxiliary_libraries <> NIL THEN
        FREE block^.command_environment.auxiliary_libraries IN osv$task_shared_heap^;
      IFEND;
      IF block^.command_environment.dialog_info.commands <> NIL THEN
        FREE block^.command_environment.dialog_info.commands IN osv$task_shared_heap^;
      IFEND;
      IF block^.command_environment.dialog_info.functions <> NIL THEN
        FREE block^.command_environment.dialog_info.functions IN osv$task_shared_heap^;
      IFEND;
      IF block^.libraries <> NIL THEN
        FREE block^.libraries IN osv$task_shared_heap^;
      IFEND;
*IF NOT $true(osv$unix)
      CASE block^.active_sou_capabilities.saved OF
      = TRUE =
        avv$active_sou_capabilities := block^.active_sou_capabilities.value;
      = FALSE =
      CASEND;
*IFEND

    = clc$task_block =
      IF NOT block^.synchronous_with_parent THEN
*IF NOT $true(osv$unix)
        IF block^.default_session_file <> NIL THEN
          FREE block^.default_session_file IN osv$task_shared_heap^;
        IFEND;
*IFEND

        current_task := block^.named_task_list;
        WHILE current_task <> NIL DO
          next_task := current_task^.link;
          FREE current_task IN osv$task_shared_heap^;
          current_task := next_task;
        WHILEND;
      IFEND;

    ELSE
      ;
    CASEND;

    IF block^.previous_block <> NIL THEN
      osp$decrement_locked_variable (block^.previous_block^.access_count, 1, access_count,
            access_count_error);
      IF access_count_error THEN
        record_block_access_count_error (block^.previous_block);
      ELSEIF (access_count = 0) AND (block^.previous_block^.previous_block = NIL) AND
            ((block^.previous_block^.kind <> clc$task_block) OR
            (block^.previous_block^.task_kind <> clc$job_monitor_task)) THEN
        FREE block^.previous_block IN osv$task_shared_heap^;
      IFEND;
    IFEND;

    block^.assignment_counter := 0;

    osp$fetch_locked_variable (block^.access_count, access_count);

    IF access_count = 0 THEN
      FREE block IN osv$task_shared_heap^;
    ELSE
      block^.previous_block := NIL;
      record_unable_to_free_block (block, access_count);
    IFEND;

  PROCEND free_block;
?? TITLE := 'clp$pop_terminated_blocks', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$pop_terminated_blocks
    (    first_block_to_keep: ^clt$block;
     VAR status {input,output} : ost$status);

    VAR
      local_status: ost$status,
      current_block: ^clt$block,
      block: ^clt$block;


    clp$find_current_block (current_block);

*IF NOT $true(osv$unix)
    IF #SEGMENT (current_block) <> #SEGMENT (first_block_to_keep) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$pop_terminated_blocks', local_status);
      pmp$abort (local_status);
    IFEND;
*IFEND

    block := current_block;
    WHILE #OFFSET (block) <> #OFFSET (first_block_to_keep) DO
      IF block^.kind = clc$task_block THEN
        RETURN;
      IFEND;
      block := block^.previous_block;
    WHILEND;

    block := current_block;
    WHILE #OFFSET (block) <> #OFFSET (first_block_to_keep) DO
      CASE block^.kind OF
*IF NOT $true(osv$unix)
      = clc$command_proc_block, clc$function_proc_block, clc$input_block, clc$when_block =
*ELSE
      = clc$input_block =
*IFEND
        clp$pop_input_stack (block, local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;
      ELSE
        clp$pop_block_stack (block);
      CASEND;
    WHILEND;

  PROCEND clp$pop_terminated_blocks;
*IF NOT $true(osv$unix)
?? TITLE := 'application accounting support routines' ??
?? NEWTITLE := 'get_procedure_stats', EJECT ??

  PROCEDURE get_procedure_stats
    (VAR cp_time: pmt$task_cp_time;
     VAR paging_stats: ost$paging_statistics);

    VAR
      jobmode_statistics: pmt$task_jobmode_statistics,
      local_status: ost$status,
      xcb: ^ost$execution_control_block;


    ?IF NOT clc$compiling_for_test_harness THEN
      pmp$find_executing_task_xcb (xcb);
      IF xcb = NIL THEN
        osp$system_error ('task XCB lost', NIL);
      ELSE
        paging_stats := xcb^.paging_statistics;
      IFEND;
      pmp$get_task_cp_time (cp_time, local_status);
      IF NOT local_status.normal THEN
        cp_time.task_time := 0;
        cp_time.monitor_time := 0;
      IFEND;
    ?ELSE
      pmp$get_task_jobmode_statistics (jobmode_statistics, local_status);
      IF NOT local_status.normal THEN
        paging_stats.page_fault_count := 0;
        paging_stats.page_in_count := 0;
        paging_stats.pages_reclaimed_from_queue := 0;
        paging_stats.new_pages_assigned := 0;
      ELSE
        paging_stats := jobmode_statistics.paging_statistics;
      IFEND;
      pmp$get_task_cp_time (cp_time, local_status);
      IF NOT local_status.normal THEN
        cp_time.task_time := 0;
        cp_time.monitor_time := 0;
      ELSE
        cp_time.monitor_time := 0;
      IFEND;
    ?IFEND;

  PROCEND get_procedure_stats;
?? TITLE := 'end_application_procedure', EJECT ??

  PROCEDURE end_application_procedure
    (    application_info: ^clt$application_info);

    VAR
      cp_time: pmt$task_cp_time,
      ignored_status: ost$status,
      local_status: ost$status,
      paging_stats: ost$paging_statistics,
      task_id: pmt$task_id;


    IF application_info <> NIL THEN
      osp$set_job_signature_lock (application_info^.lock);
      IF application_info^.task_link_head <> NIL THEN
        osp$set_status_abnormal ('CL', cle$terminated_application_task, application_info^.identifier.name,
              local_status);
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignored_status);
        WHILE application_info^.task_link_head <> NIL DO
          task_id := application_info^.task_link_head^.task_id;
          osp$clear_job_signature_lock (application_info^.lock);
          pmp$terminate (application_info^.task_link_head^.task_id, ignored_status);
          osp$set_job_signature_lock (application_info^.lock);
        WHILEND;
      IFEND;
      osp$clear_job_signature_lock (application_info^.lock);

      get_procedure_stats (cp_time, paging_stats);
      application_info^.procedure_cp_time.task_time := cp_time.task_time -
            application_info^.procedure_cp_time.task_time;
      application_info^.procedure_cp_time.monitor_time := cp_time.monitor_time -
            application_info^.procedure_cp_time.monitor_time;
      application_info^.procedure_paging_stats.page_fault_count :=
            paging_stats.page_fault_count - application_info^.procedure_paging_stats.page_fault_count;
      application_info^.procedure_paging_stats.page_in_count :=
            paging_stats.page_in_count - application_info^.procedure_paging_stats.page_in_count;
      application_info^.procedure_paging_stats.pages_reclaimed_from_queue :=
            paging_stats.pages_reclaimed_from_queue - application_info^.procedure_paging_stats.
            pages_reclaimed_from_queue;
      application_info^.procedure_paging_stats.new_pages_assigned :=
            paging_stats.new_pages_assigned - application_info^.procedure_paging_stats.new_pages_assigned;
    IFEND;

  PROCEND end_application_procedure;
?? TITLE := 'end_application', EJECT ??

  PROCEDURE end_application
    (    application_info: ^clt$application_info);

    VAR
      accumulated_srus: sft$counter,
      application_attributes: jmt$application_attributes,
      counters: sft$counters,
      description: string (osc$max_string_size),
      ignored_service_accumulator: jmt$service_accumulator,
      last_application_info: ^clt$application_info,
      local_status: ost$status,
      size: integer;


    IF application_info = NIL THEN
      RETURN;
    IFEND;

    clv$applications_active := clv$applications_active - 1;

    IF application_info^.application_scheduling THEN
      osp$set_job_signature_lock (last_scheduled_application.lock);
      last_scheduled_application.block := application_info^.previous_scheduled_block;

    /find_previous_application/
      WHILE last_scheduled_application.block <> NIL DO
        last_application_info := last_scheduled_application.block^.application_info;
        jmp$read_application_record (last_application_info^.identifier.name,
              last_application_info^.application_index, application_attributes, local_status);
        IF local_status.normal AND application_attributes.enable_application_scheduling THEN
          jmp$set_application_scheduling (application_attributes, last_application_info^.service_accumulator,
                ignored_service_accumulator, {ignored} local_status);
          EXIT /find_previous_application/;
        IFEND;
        last_scheduled_application.block := last_application_info^.previous_scheduled_block;
        last_application_info^.application_scheduling := FALSE;
        last_application_info^.previous_scheduled_block := NIL;
      WHILEND /find_previous_application/;
      IF last_scheduled_application.block = NIL THEN
        jmp$end_application_scheduling ({ignored} local_status);
      IFEND;
      osp$clear_job_signature_lock (last_scheduled_application.lock);
    IFEND;

{ If the module kind is load module then this is only a place holder for a unit application, and
{ no resource end statistic should be emitted.

    IF application_info^.module_kind <> llc$load_module THEN

      osp$set_job_signature_lock (application_info^.lock);

      IF application_info^.previous_info <> NIL THEN
        osp$set_job_signature_lock (application_info^.previous_info^.lock);
        application_info^.previous_info^.accumulated_cp_time.task_time :=
              application_info^.previous_info^.accumulated_cp_time.task_time +
              application_info^.accumulated_cp_time.task_time;
        application_info^.previous_info^.accumulated_cp_time.monitor_time :=
              application_info^.previous_info^.accumulated_cp_time.monitor_time +
              application_info^.accumulated_cp_time.monitor_time;
        application_info^.previous_info^.accumulated_paging_stats.page_fault_count :=
              application_info^.previous_info^.accumulated_paging_stats.page_fault_count +
              application_info^.accumulated_paging_stats.page_fault_count;
        application_info^.previous_info^.accumulated_paging_stats.page_in_count :=
              application_info^.previous_info^.accumulated_paging_stats.page_in_count +
              application_info^.accumulated_paging_stats.page_in_count;
        application_info^.previous_info^.accumulated_paging_stats.pages_reclaimed_from_queue :=
              application_info^.previous_info^.accumulated_paging_stats.pages_reclaimed_from_queue +
              application_info^.accumulated_paging_stats.pages_reclaimed_from_queue;
        application_info^.previous_info^.accumulated_paging_stats.new_pages_assigned :=
              application_info^.previous_info^.accumulated_paging_stats.new_pages_assigned +
              application_info^.accumulated_paging_stats.new_pages_assigned;
        osp$clear_job_signature_lock (application_info^.previous_info^.lock);
      IFEND;

{ Augment the current application information (for statistic emission) if necessary

      IF (application_info^.module_kind = llc$applic_command_procedure) OR
            (application_info^.module_kind = llc$applic_command_description) THEN
        application_info^.accumulated_cp_time.task_time :=
              application_info^.accumulated_cp_time.task_time +
              application_info^.procedure_cp_time.task_time;
        application_info^.accumulated_cp_time.monitor_time :=
              application_info^.accumulated_cp_time.monitor_time +
              application_info^.procedure_cp_time.monitor_time;
        application_info^.accumulated_paging_stats.page_fault_count :=
              application_info^.accumulated_paging_stats.page_fault_count +
              application_info^.procedure_paging_stats.page_fault_count;
        application_info^.accumulated_paging_stats.page_in_count :=
              application_info^.accumulated_paging_stats.page_in_count +
              application_info^.procedure_paging_stats.page_in_count;
        application_info^.accumulated_paging_stats.pages_reclaimed_from_queue :=
              application_info^.accumulated_paging_stats.pages_reclaimed_from_queue +
              application_info^.procedure_paging_stats.pages_reclaimed_from_queue;
        application_info^.accumulated_paging_stats.new_pages_assigned :=
              application_info^.accumulated_paging_stats.new_pages_assigned +
              application_info^.procedure_paging_stats.new_pages_assigned;
      IFEND;

      local_status.normal := TRUE;
      avp$calculate_application_srus (application_info^.accumulated_cp_time,
            application_info^.accumulated_paging_stats, accumulated_srus, local_status);
      IF local_status.normal THEN
        PUSH counters: [1 .. 7];
        counters^ [1] := accumulated_srus;
        counters^ [2] := application_info^.accumulated_cp_time.task_time;
        counters^ [3] := application_info^.accumulated_cp_time.monitor_time;
        counters^ [4] := application_info^.accumulated_paging_stats.page_fault_count;
        counters^ [5] := application_info^.accumulated_paging_stats.page_in_count;
        counters^ [6] := application_info^.accumulated_paging_stats.pages_reclaimed_from_queue;
        counters^ [7] := application_info^.accumulated_paging_stats.new_pages_assigned;

        STRINGREP (description, size, application_info^.identifier.
              name (1, clp$trimmed_string_size (application_info^.identifier.name)), ', ',
              application_info^.nested_identifier.name (1, clp$trimmed_string_size
              (application_info^.nested_identifier.name)));

        avp$emit_interactive_interval;
        sfp$emit_statistic (avc$end_application, description (1, size), counters, {ignored} local_status);
      IFEND;

      osp$clear_job_signature_lock (application_info^.lock)
    IFEND;

  PROCEND end_application;
?? TITLE := 'clp$update_applic_resources', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$update_applic_resources
    (    cp_time: pmt$task_cp_time;
         paging_stats: ost$paging_statistics);

    VAR
      block: ^clt$block;


    clp$find_current_block (block);

    IF block^.application_info <> NIL THEN
      osp$set_job_signature_lock (block^.application_info^.lock);

      block^.application_info^.accumulated_cp_time.task_time :=
            block^.application_info^.accumulated_cp_time.task_time + cp_time.task_time;
      block^.application_info^.accumulated_cp_time.monitor_time :=
            block^.application_info^.accumulated_cp_time.monitor_time + cp_time.monitor_time;
      block^.application_info^.accumulated_paging_stats.page_fault_count :=
            block^.application_info^.accumulated_paging_stats.page_fault_count +
            paging_stats.page_fault_count;
      block^.application_info^.accumulated_paging_stats.page_in_count :=
            block^.application_info^.accumulated_paging_stats.page_in_count + paging_stats.page_in_count;
      block^.application_info^.accumulated_paging_stats.pages_reclaimed_from_queue :=
            block^.application_info^.accumulated_paging_stats.pages_reclaimed_from_queue +
            paging_stats.pages_reclaimed_from_queue;
      block^.application_info^.accumulated_paging_stats.new_pages_assigned :=
            block^.application_info^.accumulated_paging_stats.new_pages_assigned +
            paging_stats.new_pages_assigned;

      osp$clear_job_signature_lock (block^.application_info^.lock);
    IFEND;

  PROCEND clp$update_applic_resources;
?? TITLE := 'clp$record_application_units', EJECT ??

{
{ PURPOSE:
{  This procedure is called at task termination time.  It retrieves all
{ of the application units from the storage areas defined by any calls to
{ CLP$DEFINE_APPLIC_UNIT_ARRAY, and places them on and emits an
{ AVC$APPLICATION_UNITS statistic for each array defined.
{

  PROCEDURE [XDCL] clp$record_application_units;

    VAR
      block: ^clt$block,
      current_unit_info: ^clt$application_unit_info,
      ignore_status: ost$status;

?? NEWTITLE := 'emit_application_unit_statistic', EJECT ??

    PROCEDURE emit_application_unit_statistic
      (    current_unit_info: ^clt$application_unit_info);

      VAR
        ignore_status: ost$status,
        message_status: ost$status,
        error_counter: array [1 .. 1] of sft$counter,
        error_descriptive_data: string (sfc$max_descriptive_data_size),
        index: integer,
        size: integer,
        counters: sft$counters,
        description: string (osc$max_string_size);

?? NEWTITLE := 'invalid_array_cond_handler', EJECT ??

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

        VAR
          ignore_status: ost$status;

?? NEWTITLE := 'set_invalid_array_status', EJECT ??

        PROCEDURE set_invalid_array_status;

          VAR
            ignore_status: ost$status;


{ ';' is used as the status parameter delimiter so that the error statistic descriptive data is displayable.

          osp$set_status_condition (cle$cannot_access_unit_array, message_status);
          osp$append_status_parameter (';', current_unit_info^.identifier.name, message_status);
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], message_status,
                ignore_status);
          error_counter [1] := message_status.condition;
          error_descriptive_data := message_status.text.value;
          sfp$emit_statistic (avc$applic_accounting_error, error_descriptive_data
                (1, message_status.text.size), ^error_counter, ignore_status);
          EXIT emit_application_unit_statistic;

        PROCEND set_invalid_array_status;
?? OLDTITLE, EJECT ??

        handler_status.normal := TRUE;

        CASE condition.selector OF
        = pmc$system_conditions =
          set_invalid_array_status;
        = mmc$segment_access_condition =
          set_invalid_array_status;
        = pmc$user_defined_condition =
          IF condition.user_condition_name = cye$run_time_condition THEN
            set_invalid_array_status;
          ELSE
            pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          IFEND;
        ELSE;
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        CASEND;

      PROCEND invalid_array_cond_handler;
?? OLDTITLE, EJECT ??

      PUSH counters: [1 .. current_unit_info^.unit_array_size];

{ Verify that the array defined by the application is accessable.

      osp$establish_condition_handler (^invalid_array_cond_handler, FALSE);

    /retrieve_unit_array_values/
      FOR index := 1 TO current_unit_info^.unit_array_size DO
        counters^ [index] := current_unit_info^.unit_array^ [index];
        IF counters^ [index] < 0 THEN
          osp$set_status_condition (cle$negative_application_units, message_status);
          osp$append_status_parameter (';', current_unit_info^.identifier.name, message_status);
          osp$append_status_integer (';', index, 10, FALSE, message_status);
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], message_status,
                ignore_status);
          error_counter [1] := message_status.condition;
          error_descriptive_data := message_status.text.value;
          sfp$emit_statistic (avc$applic_accounting_error, error_descriptive_data
                (1, message_status.text.size), ^error_counter, ignore_status);
          RETURN;
        IFEND;
      FOREND /retrieve_unit_array_values/;
      osp$disestablish_cond_handler;

{ Build and emit the application units statistic.

      STRINGREP (description, size, current_unit_info^.identifier.
            name (1, clp$trimmed_string_size (current_unit_info^.identifier.name)), ', ',
            current_unit_info^.nested_identifier.name (1, clp$trimmed_string_size
            (current_unit_info^.nested_identifier.name)));
      sfp$emit_statistic (avc$application_units, description (1, size), counters, ignore_status);

    PROCEND emit_application_unit_statistic;
?? OLDTITLE, EJECT ??

    clp$find_current_block (block);

    IF block^.application_info <> NIL THEN
      current_unit_info := block^.application_info^.unit_info;

    /process_application_unit_list/
      WHILE current_unit_info <> NIL DO
        emit_application_unit_statistic (current_unit_info);
        current_unit_info := current_unit_info^.unit_info;
      WHILEND /process_application_unit_list/;
    IFEND;

  PROCEND clp$record_application_units;
?? TITLE := 'clp$define_applic_unit_array', EJECT ??
*copyc clh$define_applic_unit_array

  PROCEDURE [XDCL, #GATE] clp$define_applic_unit_array
    (    application_unit_array: ^clt$application_unit_array;
         application_unit_array_size: clt$application_unit_array_size;
         application_address: ost$pva;
     VAR status: ost$status);

{
{ NOTES:
{
{   The storage area for the array of integers MUST be staticly allocated!  If
{ it is not the array may not be accessable by SCL when the application
{ terminates.
{
{   The application address does NOT have to be an entry point or some other
{ externally declared address.
{
{   Only one call to CLP$DEFINE_APPLIC_UNIT_ARRAY is allowed from any given load
{ module.
{
{ DESIGN:
{
{   Call the loader to determine if an application identifier has been assigned
{ to the module pointed to by application address.  If no application
{ identifier has been assigned then this module is not considered an
{ application and the control is returned with normal status.
{
{   If the pointer to the application unit array is NIL then return abnormal status.
{
{   If the ring of the application unit array pointer is less than the ring of
{ the application address then the application is attempting to reference a
{ storage area in a more secure module so an abnormal status is returned.
{
{   If a resource measured application is currently active there will aready be
{ an application information block in the block stack, if not a dummy
{ application information block is allocated.  The application information
{ block points to a list of unit application information blocks.  If a unit
{ application information block does not already exist for the calling load
{ module a new unit application information block with the appropriate
{ information is inserted as the first entry in the list.  If one already
{ exists for the calling load module an error status is returned.
{

    VAR
      block: ^clt$block,
      new_unit_info: ^clt$application_unit_info,
      current_unit_info: ^clt$application_unit_info,
      index: integer,
      size: integer,
      string_wsa: string (osc$max_string_size),
      application_module_name: ost$name,
      application_identifier: llt$application_identifier,
      null_application_identifier: llt$application_identifier,
      library_privilege: ost$name;


    status.normal := TRUE;

    pmp$get_application_information (application_address, application_module_name, application_identifier,
          library_privilege, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ If the module does not have an application identifier it is not an application.

    IF application_identifier.name = osc$null_name THEN
      RETURN;
    IFEND;

{ Verify that the array defined by the application is accessable.

    IF application_unit_array = NIL THEN
      osp$set_status_abnormal ('CL', cle$cannot_access_unit_array, application_identifier.name, status);
      RETURN;
    IFEND;

    IF #RING (application_unit_array) < application_address.ring THEN
      osp$set_status_abnormal ('CL', cle$cannot_access_unit_array, application_identifier.name, status);
      RETURN;
    IFEND;

{ Allocate and insert the application unit block information into the stack.

    clp$find_current_block (block);

{ Create a dummy resource application block as a placeholder if one doesn't already exist.

    IF block^.application_info = NIL THEN
      null_application_identifier.name := osc$null_name;
      clp$initialize_application_info (null_application_identifier, osc$null_name, llc$load_module, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Only one call to CLP$DEFINE_APPLIC_UNIT_ARRAY  is allowed per load module.

    current_unit_info := block^.application_info^.unit_info;

  /look_for_duplicate_module_name/
    WHILE current_unit_info <> NIL DO
      IF current_unit_info^.module_name = application_module_name THEN
        osp$set_status_abnormal ('CL', cle$multiple_applic_unit_arrays, application_identifier.name, status);
        RETURN;
      IFEND;
      current_unit_info := current_unit_info^.unit_info;
    WHILEND /look_for_duplicate_module_name/;

{ Enter a new unit application block.

    ALLOCATE new_unit_info IN osv$task_shared_heap^;

    new_unit_info^.module_name := application_module_name;
    new_unit_info^.identifier := application_identifier;
    IF block^.application_info^.identifier.name = osc$null_name THEN
      new_unit_info^.nested_identifier := application_identifier;
    ELSEIF block^.application_info^.identifier = application_identifier THEN
      new_unit_info^.nested_identifier := block^.application_info^.nested_identifier;
    ELSE
      STRINGREP (string_wsa, size, block^.application_info^.nested_identifier.
            name (1, clp$trimmed_string_size (block^.application_info^.nested_identifier.name)), '#',
            application_identifier.name);
      new_unit_info^.nested_identifier.name := string_wsa (1, osc$max_name_size);
    IFEND;
    new_unit_info^.library_privilege := library_privilege;
    new_unit_info^.unit_array := application_unit_array;
    new_unit_info^.unit_array_size := application_unit_array_size;

{ Insert it as the first entry in the list.

    new_unit_info^.unit_info := block^.application_info^.unit_info;
    block^.application_info^.unit_info := new_unit_info;

  PROCEND clp$define_applic_unit_array;
?? TITLE := 'clp$initialize_application_info', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$initialize_application_info
    (    application_identifier: llt$application_identifier;
         library_privilege: ost$name;
         module_kind: llt$library_module_kind;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      new_info: ^clt$application_info,
      application_attributes: jmt$application_attributes,
      task_block: ^clt$block,
      last_scheduled_task_block: ^clt$block,
      old_service_accumulator: jmt$service_accumulator,
      local_status: ost$status,
      size: integer,
      string_wsa: string (osc$max_string_size);


    status.normal := TRUE;

    clp$find_current_block (block);

    ALLOCATE new_info IN osv$task_shared_heap^;

    new_info^.identifier := application_identifier;
    new_info^.nested_identifier := application_identifier;
    IF block^.application_info <> NIL THEN
      STRINGREP (string_wsa, size, block^.application_info^.nested_identifier.
            name (1, clp$trimmed_string_size (block^.application_info^.nested_identifier.name)), '#',
            application_identifier.name);
      new_info^.nested_identifier.name := string_wsa (1, osc$max_name_size);
    IFEND;
    new_info^.library_privilege := library_privilege;
    new_info^.task_link_head := NIL;
    new_info^.previous_info := block^.application_info;
    new_info^.accumulated_cp_time.task_time := 0;
    new_info^.accumulated_cp_time.monitor_time := 0;
    new_info^.accumulated_paging_stats.page_fault_count := 0;
    new_info^.accumulated_paging_stats.page_in_count := 0;
    new_info^.accumulated_paging_stats.pages_reclaimed_from_queue := 0;
    new_info^.accumulated_paging_stats.new_pages_assigned := 0;
    new_info^.unit_info := NIL;
    new_info^.application_scheduling := FALSE;
    new_info^.application_index := 0;
    new_info^.previous_scheduled_block := NIL;
    new_info^.module_kind := module_kind;
    IF (module_kind = llc$applic_command_procedure) OR (module_kind = llc$applic_command_description) THEN
      get_procedure_stats (new_info^.procedure_cp_time, new_info^.procedure_paging_stats);
    IFEND;

{ Check for application scheduling only if it is not a call for a load module
{ application.  Only applications defined by program descriptors and SCL
{ procedures are supported for application scheduling.

    IF module_kind <> llc$load_module THEN

{ Application scheduling is set if
{  - The site has selected special scheduling for the application in the active
{    scheduling profile AND
{  - Application scheduling is not currently set for the job OR this task is
{    synchronous with the previous task that set application scheduling.

      jmp$read_application_record (new_info^.identifier.name, new_info^.application_index,
            application_attributes, local_status);
      IF local_status.normal AND application_attributes.enable_application_scheduling AND
            NOT jmp$system_job () THEN
        task_block := NIL;

        osp$set_job_signature_lock (last_scheduled_application.lock);

        last_scheduled_task_block := last_scheduled_application.block;
        IF last_scheduled_task_block <> NIL THEN
          WHILE last_scheduled_task_block^.kind <> clc$task_block DO
            last_scheduled_task_block := last_scheduled_task_block^.previous_block;
          WHILEND;
          clp$find_task_block (task_block, local_status);
          IF NOT local_status.normal THEN
            task_block := NIL;
          IFEND;
          WHILE (task_block <> NIL) AND (last_scheduled_task_block <> task_block) AND
                task_block^.synchronous_with_parent DO
            task_block := task_block^.parent;
          WHILEND;
        IFEND;
        IF task_block = last_scheduled_task_block THEN
          new_info^.application_scheduling := TRUE;
          new_info^.previous_scheduled_block := last_scheduled_application.block;
          last_scheduled_application.block := block;
        IFEND;

        osp$clear_job_signature_lock (last_scheduled_application.lock);

        IF new_info^.application_scheduling THEN
          jmp$set_application_scheduling (application_attributes, 0, old_service_accumulator, local_status);
          IF new_info^.previous_scheduled_block <> NIL THEN
            new_info^.previous_scheduled_block^.application_info^.service_accumulator :=
                  old_service_accumulator;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    osp$initialize_sig_lock (new_info^.lock);

{!
{!  task_link_head, and accumulated fields in application_info should only be accessed after
{!  locking the application_info record.
{!

    block^.started_application := TRUE;
    block^.application_info := new_info;

    clv$applications_active := clv$applications_active + 1;

{ If the module kind is load module then this is only a place holder for a unit application, and
{ no resource application begin statistic should be emitted.

    IF module_kind <> llc$load_module THEN
      STRINGREP (string_wsa, size, new_info^.identifier.name
            (1, clp$trimmed_string_size (new_info^.identifier.name)),
            ', ', new_info^.nested_identifier.name (1, clp$trimmed_string_size
            (new_info^.nested_identifier.name)));

      avp$emit_interactive_interval;
      sfp$emit_statistic (avc$begin_application, string_wsa (1, size), NIL, status);
    IFEND;

  PROCEND clp$initialize_application_info;
?? OLDTITLE, TITLE := '"Helper" routines for clp$evaluate_parameters, etc.' ??
*IFEND
?? NEWTITLE := 'clp$setup_parameter_evaluation', EJECT ??

{
{ PURPOSE:
{   This procedure is called in all command or function parameter evaluation
{   contexts except clp$evaluate_sub_parameters.  It gathers information from
{   the block stack and returns it in the evaluation_context and help_context
{   records.
{
{ NOTES:
{   1. Help_context is used only for parameter information displays.
{   2. Parameter_list_parse is not returned for a procedure.
{   3. Work_area_ptr is not returned for a procedure.
{   4. The current position of the work_area is saved for a sub_parameters
{      block so that when the block is popped the work_area can be reset.
{   5. The parameters.names and parameters.accesses fields of a block for a
{      procedure are initialized.  This allows for the passing of VAR
{      parameters to occur "on the fly" during parameter evaluation.
{

  PROCEDURE [XDCL, #GATE] clp$setup_parameter_evaluation
    (    proc_pdt: ^clt$unbundled_pdt;
         proc_name: clt$command_name;
         reset_interpreter_mode: boolean;
     VAR parameter_list_parse: clt$parse_state;
     VAR work_area_ptr: ^^clt$work_area;
     VAR evaluation_context: clt$parameter_eval_context;
     VAR help_context: clt$parameter_help_context;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      caller_id: ost$caller_identifier,
      command_or_function_block: ^clt$block,
      interaction_information: ^clt$interaction_information,
      parameters_block: ^clt$block,
      task_interaction_information: ^clt$interaction_information;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'initialize_proc_parameters', EJECT ??

    PROCEDURE [INLINE] initialize_proc_parameters;

      VAR
        area_size: integer,
        i: clt$parameter_number;


      area_size := #SIZE (proc_pdt^.names^) + (proc_pdt^.header^.number_of_parameters *
            #SIZE (clt$parameter_access));
      FOR i := 1 TO proc_pdt^.header^.number_of_parameters DO
        area_size := area_size + #SIZE (clt$variable_descriptor:
              [[REP proc_pdt^.parameters^ [i].type_specification_size OF cell]]);
      FOREND;

      ALLOCATE parameters_block^.parameters.area: [[REP area_size OF cell]] IN osv$task_shared_heap^;
      RESET parameters_block^.parameters.area;

      NEXT parameters_block^.parameters.names: [1 .. proc_pdt^.header^.number_of_parameter_names] IN
            parameters_block^.parameters.area;
      parameters_block^.parameters.names^ := proc_pdt^.names^;
      NEXT parameters_block^.parameters.accesses: [1 .. proc_pdt^.header^.number_of_parameters] IN
            parameters_block^.parameters.area;

      FOR i := 1 TO proc_pdt^.header^.number_of_parameters DO
        parameters_block^.parameters.accesses^ [i].name_index := proc_pdt^.parameters^ [i].name_index;
        parameters_block^.parameters.accesses^ [i].security := proc_pdt^.parameters^ [i].security;
        parameters_block^.parameters.accesses^ [i].specified := FALSE;
        parameters_block^.parameters.accesses^ [i].qualifiers_area := NIL;
        parameters_block^.parameters.accesses^ [i].passed_variable_reference := NIL;
        parameters_block^.parameters.accesses^ [i].info.class := clc$param_variable;
        parameters_block^.parameters.accesses^ [i].info.parameter_passed := FALSE;
        osp$increment_locked_variable (clv$var_access_assignment_count, 0,
              parameters_block^.parameters.accesses^ [i].info.assignment_counter);
        parameters_block^.parameters.accesses^ [i].info.qualifiers := NIL;

        IF proc_pdt^.parameters^ [i].passing_method = clc$pass_by_reference THEN
          parameters_block^.parameters.accesses^ [i].info.access_mode := clc$read_write;
        ELSE {clc$pass_by_value}
          parameters_block^.parameters.accesses^ [i].info.access_mode := clc$read_only;
        IFEND;

        NEXT parameters_block^.parameters.accesses^ [i].info.descriptor:
              [[REP proc_pdt^.parameters^ [i].type_specification_size OF cell]] IN
              parameters_block^.parameters.area;
        parameters_block^.parameters.accesses^ [i].info.descriptor^.header.access_count := 1;
        parameters_block^.parameters.accesses^ [i].info.descriptor^.header.evaluation_method :=
              proc_pdt^.parameters^ [i].evaluation_method;
        parameters_block^.parameters.accesses^ [i].info.descriptor^.header.value := NIL;
        parameters_block^.parameters.accesses^ [i].info.descriptor^.header.library := NIL;
        parameters_block^.parameters.accesses^ [i].info.descriptor^.type_specification :=
              proc_pdt^.type_descriptions^ [i].specification^;

        parameters_block^.parameters.accesses^ [i].info.original_parameter_descriptor :=
              parameters_block^.parameters.accesses^ [i].info.descriptor;

      FOREND;

    PROCEND initialize_proc_parameters;
*IFEND
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$find_current_block (block);
    parameters_block := NIL;
*IF NOT $true(osv$unix)
    evaluation_context.command_logging_completed := TRUE;
    evaluation_context.command_echoing_completed := TRUE;
*IFEND
    CASE block^.kind OF
    = clc$command_block =
      IF proc_pdt = NIL THEN
        command_or_function_block := block;
        parameters_block := block;
        evaluation_context.command_or_function := clc$command;
        evaluation_context.procedure_parameters := FALSE;
*IF NOT $true(osv$unix)
        evaluation_context.command_logging_completed := parameters_block^.command_logging_completed;
        evaluation_context.command_echoing_completed := parameters_block^.command_echoing_completed;
*IFEND
      IFEND;
*IF NOT $true(osv$unix)
    = clc$command_proc_block =
      IF proc_pdt <> NIL THEN
        command_or_function_block := block;
        parameters_block := block;
        evaluation_context.command_or_function := clc$command;
        evaluation_context.procedure_parameters := TRUE;
        evaluation_context.command_logging_completed := parameters_block^.command_proc_logging_completed;
        evaluation_context.command_echoing_completed := parameters_block^.command_proc_echoing_completed;
      IFEND;
*IFEND
    = clc$function_block =
      IF proc_pdt = NIL THEN
        command_or_function_block := block;
        parameters_block := block;
        evaluation_context.command_or_function := clc$function;
        evaluation_context.procedure_parameters := FALSE;
*IF NOT $true(osv$unix)
        evaluation_context.command_logging_completed := TRUE;
        evaluation_context.command_echoing_completed := TRUE;
*IFEND
      IFEND;
*IF NOT $true(osv$unix)
    = clc$function_proc_block =
      IF proc_pdt <> NIL THEN
        command_or_function_block := block;
        parameters_block := block;
        evaluation_context.command_or_function := clc$function;
        evaluation_context.procedure_parameters := TRUE;
        evaluation_context.command_logging_completed := TRUE;
        evaluation_context.command_echoing_completed := TRUE;
      IFEND;
*IFEND
    = clc$task_block =
      IF (block^.task_kind = clc$other_task) AND (proc_pdt = NIL) THEN
        evaluation_context.command_or_function := clc$command;
        evaluation_context.procedure_parameters := FALSE;
        command_or_function_block := block;
        parameters_block := block;
        IF block^.synchronous_with_parent AND (block^.previous_block^.kind = clc$command_block) AND
              (block^.previous_block^.command_kind = clc$program_command) THEN
          command_or_function_block := block^.previous_block;
*IF NOT $true(osv$unix)
          evaluation_context.command_logging_completed := command_or_function_block^.
                command_logging_completed;
          evaluation_context.command_echoing_completed := command_or_function_block^.
                command_echoing_completed;
*IFEND
          parameters_block^.line_parse := command_or_function_block^.line_parse;
          IF command_or_function_block^.parameters.evaluated THEN
            parameters_block := NIL;
          IFEND;
        ELSE
          evaluation_context.command_logging_completed := TRUE;
          evaluation_context.command_echoing_completed := TRUE;
        IFEND;
      IFEND;
*IF NOT $true(osv$unix)
    = clc$sub_parameters_block =
      IF proc_pdt = NIL THEN
        command_or_function_block := block;
        parameters_block := block;
        evaluation_context.command_or_function := clc$command;
        evaluation_context.procedure_parameters := FALSE;
        evaluation_context.command_logging_completed := TRUE;
        evaluation_context.command_echoing_completed := TRUE;
      IFEND;
*IFEND
    ELSE
      ;
    CASEND;
    IF (parameters_block = NIL) OR parameters_block^.parameters.evaluated THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$setup_parameter_evaluation', status);
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND

    IF proc_pdt <> NIL THEN
*IF NOT $true(osv$unix)
      IF proc_pdt^.header^.number_of_parameters > 0 THEN
        initialize_proc_parameters;
      IFEND;
      command_or_function_block^.proc_name := proc_name;
*IFEND

      IF command_or_function_block^.previous_block^.interpreter_mode = clc$help_mode THEN
        command_or_function_block^.interpreter_mode := clc$help_mode;
      IFEND;

    ELSE
      parameter_list_parse := parameters_block^.line_parse;

      clp$get_work_area (caller_id.ring, work_area_ptr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    evaluation_context.interpreter_mode := command_or_function_block^.interpreter_mode;

    IF (evaluation_context.interpreter_mode = clc$help_mode) AND
          (command_or_function_block^.previous_block^.kind = clc$command_block) AND
          reset_interpreter_mode THEN
      block^.interpreter_mode := clc$interpret_mode;
      block^.being_exited := TRUE;
    IFEND;

    evaluation_context.interactive_origin := FALSE;

    osp$find_interaction_info (interaction_information);
    evaluation_context.interaction_style := interaction_information^.style;

*IF NOT $true(osv$unix)
    IF parameters_block^.kind = clc$sub_parameters_block THEN
      block^.sub_parameters_work_area_ptr := work_area_ptr;
      block^.sub_parameters_work_area := work_area_ptr^;
    ELSEIF caller_id.ring > osc$tsrv_ring THEN
*ELSE
    IF caller_id.ring > osc$tsrv_ring THEN
*IFEND
      block := command_or_function_block^.previous_block;

    /search_for_interactive_origin/
      WHILE block <> NIL DO
        CASE block^.kind OF
*IF NOT $true(osv$unix)
        = clc$command_proc_block, clc$function_proc_block, clc$input_block, clc$when_block =
*ELSE
        = clc$input_block =
*IFEND
          evaluation_context.interactive_origin := (block^.input.kind = clc$file_input) AND
                (block^.input.device_class = rmc$terminal_device);
          EXIT /search_for_interactive_origin/;
        = clc$task_block =
          IF NOT block^.synchronous_with_parent THEN
            task_interaction_information := clp$environment_object_in_block (clc$eo_interaction_information,
                  block);
            evaluation_context.interactive_origin := (task_interaction_information <> NIL) AND
                  (task_interaction_information^.style = osc$desktop_interaction);
            EXIT /search_for_interactive_origin/;
          IFEND;
          block := block^.previous_block;
*IF NOT $true(osv$unix)
        = clc$sub_parameters_block =
          EXIT /search_for_interactive_origin/;
*IFEND
        ELSE
          block := block^.previous_block;
        CASEND;
      WHILEND /search_for_interactive_origin/;
    IFEND;

    evaluation_context.command_or_function_name := command_or_function_block^.label;
    evaluation_context.command_or_function_source := ^command_or_function_block^.source;

    IF (evaluation_context.interpreter_mode = clc$help_mode) AND
          (command_or_function_block^.previous_block^.kind = clc$command_block) THEN
      evaluation_context.prompting_requested := TRUE;
      help_context.help_output_file := command_or_function_block^.previous_block^.help_output_file;
*IF NOT $true(osv$unix)
      help_context.help_output_ring := command_or_function_block^.previous_block^.caller_ring;
*IFEND
      help_context.help_output_options := command_or_function_block^.previous_block^.help_output_options;
    ELSE
      evaluation_context.prompting_requested := command_or_function_block^.prompting_requested;
      help_context.help_output_file := NIL;
*IF NOT $true(osv$unix)
      help_context.help_output_ring := command_or_function_block^.caller_ring;
*IFEND
      help_context.help_output_options := $clt$parameter_help_options [];
    IFEND;

  PROCEND clp$setup_parameter_evaluation;
?? TITLE := 'clp$save_evaluated_parameters', EJECT ??

{
{ PURPOSE:
{   This procedure completes the parameter evaluation process for commands and
{   functions.  It sets the parameters.evaluated field of the block and saves
{   other information in the block dependent upon the context.
{
{ NOTES:
{   1. For a procedure the values for non-VAR parameters are saved along with a
{      boolean indicating whether the standard status parameter for a command
{      procedure was specified on the call.
{   2. For parameters evaluated by the clp$scan_parameter_list request, the
{      parameter value table is saved.
{   3. For a command a pointer to its "unbundled" parameter descriptor table is
{      saved.  Also, if the command's standard status parameter was specified
{      on the call, a pointer to the specified variable is saved.
{   4. For a command, command procedure or task the logging/echoing completed flags
{      are set to true.
{   5. If the command was called via clp$edit_command_parameter_list, the
{      evaluated_parameters are converted to a string representation and saved.
{

  PROCEDURE [XDCL, #GATE] clp$save_evaluated_parameters
    (    pdt: ^clt$unbundled_pdt;
         pvt: ^clt$parameter_value_table;
         evaluated_by_scan_param_list: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status {input, output} : ost$status);

    VAR
      block: ^clt$block,
      command_block: ^clt$block,
      parameters_block: ^clt$block,
      search_mode: clt$command_search_modes;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'save_edited_parameter_list', EJECT ??

    PROCEDURE save_edited_parameter_list;

      VAR
        edited_parameters: ^clt$data_representation,
        request: clt$convert_to_string_request;


      request.initial_indentation := 0;
      request.continuation_indentation := 0;
      request.max_string := command_block^.edited_parameters_max_size;
      request.include_advanced_items := TRUE;
      request.include_hidden_items := TRUE;
      request.kind := clc$convert_parameters;
      request.initial_text := NIL;
      request.include_secure_parameters := TRUE;
      request.evaluated_pdt := pdt;
      request.evaluated_pvt := pvt;
      request.parameter_substitutions := NIL;
      clp$internal_convert_to_string (request, work_area, edited_parameters, status);
      IF NOT status.normal THEN
        EXIT clp$save_evaluated_parameters;
      IFEND;

      ALLOCATE command_block^.edited_parameters: [[REP #SIZE (edited_parameters^) OF cell]] IN
            osv$task_shared_heap^;
      command_block^.edited_parameters^ := edited_parameters^;

      osp$set_status_condition (cle$parameters_displayed, status);

    PROCEND save_edited_parameter_list;
?? TITLE := 'save_proc_parameters', EJECT ??

    PROCEDURE save_proc_parameters;

      VAR
        area_size: integer,
        first_saved_parameter: 0 .. clc$max_parameters,
        i: clt$parameter_number,
        local_status: ost$status,
        values: ^array [1 .. * ] of ^clt$internal_data_value;


      PUSH values: [1 .. pdt^.header^.number_of_parameters];

      first_saved_parameter := 0;
      area_size := 0;

      FOR i := 1 TO pdt^.header^.number_of_parameters DO
        values^ [i] := NIL;
        IF pvt^ [i].passing_method = clc$pass_by_reference THEN
          IF pvt^ [i].variable <> NIL THEN
            area_size := area_size + #SIZE (pvt^ [i].variable^);
          IFEND;
        ELSEIF pvt^ [i].value <> NIL THEN
          clp$convert_ext_value_to_int (NIL, pvt^ [i].value, NIL, work_area, values^ [i], local_status);
          IF NOT local_status.normal THEN
            IF status.normal THEN
              status := local_status;
            IFEND;
            EXIT clp$save_evaluated_parameters;
          IFEND;
          area_size := area_size + #SIZE (values^ [i]^);
          IF first_saved_parameter = 0 THEN
            first_saved_parameter := i;
          IFEND;
        IFEND;
      FOREND;

      IF area_size > 0 THEN
        ALLOCATE parameters_block^.parameters.values: [[REP area_size OF cell]] IN osv$task_shared_heap^;
        RESET parameters_block^.parameters.values;
      IFEND;

      FOR i := 1 TO pdt^.header^.number_of_parameters DO
        parameters_block^.parameters.accesses^ [i].specified := pvt^ [i].specified;
        IF pvt^ [i].passing_method = clc$pass_by_reference THEN
          IF pvt^ [i].variable <> NIL THEN
            NEXT parameters_block^.parameters.accesses^ [i].passed_variable_reference:
                  [STRLENGTH (pvt^ [i].variable^)] IN parameters_block^.parameters.values;
            parameters_block^.parameters.accesses^ [i].passed_variable_reference^ := pvt^ [i].variable^;
            parameters_block^.parameters.accesses^ [i].info.parameter_passed := TRUE;
          IFEND;
        ELSEIF values^ [i] <> NIL THEN
          NEXT parameters_block^.parameters.accesses^ [i].info.descriptor^.header.value:
                [[REP #SIZE (values^ [i]^.allocated_space) OF cell]] IN parameters_block^.parameters.values;
          parameters_block^.parameters.accesses^ [i].info.descriptor^.header.value^ := values^ [i]^;
          parameters_block^.parameters.accesses^ [i].info.parameter_passed := TRUE;
        IFEND;
      FOREND;

    PROCEND save_proc_parameters;
?? OLDTITLE, EJECT ??
*IFEND

    clp$find_current_block (block);
    command_block := NIL;
    parameters_block := NIL;
    CASE block^.kind OF
*IF NOT $true(osv$unix)
    = clc$command_block, clc$function_block, clc$sub_parameters_block =
*ELSE
    = clc$command_block, clc$function_block =
*IFEND
      parameters_block := block;
*IF NOT $true(osv$unix)
    = clc$command_proc_block, clc$function_proc_block =
      parameters_block := block;
      IF parameters_block^.being_exited THEN
        parameters_block^.interpreter_mode := clc$skip_mode;
      IFEND;
*IFEND
    = clc$task_block =
      IF block^.task_kind = clc$other_task THEN
        parameters_block := block;
        IF block^.synchronous_with_parent AND (block^.previous_block^.kind = clc$command_block) AND
              (block^.previous_block^.command_kind = clc$program_command) THEN
          IF block^.previous_block^.parameters.evaluated THEN
            parameters_block := NIL;
          ELSE
            command_block := block^.previous_block;
          IFEND;
        IFEND;
      IFEND;
    ELSE
      ;
    CASEND;
    IF parameters_block <> NIL THEN
      IF parameters_block^.parameters.evaluated OR (pdt = NIL) THEN
        parameters_block := NIL;
      ELSEIF pdt^.header^.number_of_parameters = 0 THEN
        IF pvt <> NIL THEN
          parameters_block := NIL;
        IFEND;
      ELSEIF (pvt = NIL) OR (UPPERBOUND (pvt^) <> pdt^.header^.number_of_parameters) THEN
        parameters_block := NIL;
      IFEND;
    IFEND;
    IF parameters_block = NIL THEN
      IF status.normal THEN
        osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$save_evaluated_parameters', status);
      IFEND;
      RETURN;
    IFEND;

    clp$get_command_search_mode (search_mode);
    parameters_block^.parameters.evaluated := TRUE;
    CASE parameters_block^.kind OF

    = clc$command_block =
      parameters_block^.parameters.unbundled_pdt := pdt;
      IF evaluated_by_scan_param_list THEN
        parameters_block^.parameters.names := pdt^.names;
        parameters_block^.parameters.parameter_value_table := pvt;
      IFEND;
      IF (pdt^.header^.status_parameter_number > 0) AND pvt^ [pdt^.header^.status_parameter_number].
            specified THEN
        parameters_block^.parameters.command_status_variable :=
              pvt^ [pdt^.header^.status_parameter_number].variable;
      IFEND;
*IF NOT $true(osv$unix)
      parameters_block^.command_logging_completed := TRUE;
      parameters_block^.command_echoing_completed := TRUE;
*IFEND
      IF (search_mode <> clc$global_command_search) AND (parameters_block^.command_kind <>
            clc$command_is_include_file) AND (parameters_block^.command_kind <> clc$command_is_include_line)
            THEN
        parameters_block^.use_command_search_mode := FALSE;
      IFEND;
*IF NOT $true(osv$unix)

    = clc$command_proc_block =
      IF pdt^.header^.number_of_parameters > 0 THEN
        save_proc_parameters;
      IFEND;
      IF (pdt^.header^.status_parameter_number > 0) AND pvt^ [pdt^.header^.status_parameter_number].
            specified THEN
        parameters_block^.parameters.command_status_specified := TRUE;
      IFEND;
      parameters_block^.command_proc_logging_completed := TRUE;
      parameters_block^.command_proc_echoing_completed := TRUE;
      IF search_mode <> clc$global_command_search THEN
        parameters_block^.use_command_search_mode := FALSE;
      IFEND;
*IFEND

    = clc$function_block =
      parameters_block^.parameters.unbundled_pdt := pdt;
      IF search_mode <> clc$global_command_search THEN
        parameters_block^.use_command_search_mode := FALSE;
      IFEND;
*IF NOT $true(osv$unix)

    = clc$function_proc_block =
      IF pdt^.header^.number_of_parameters > 0 THEN
        save_proc_parameters;
      IFEND;
      IF search_mode <> clc$global_command_search THEN
        parameters_block^.use_command_search_mode := FALSE;
      IFEND;

    = clc$sub_parameters_block =
      parameters_block^.parameters.unbundled_pdt := pdt;
      IF evaluated_by_scan_param_list THEN
        parameters_block^.parameters.names := pdt^.names;
        parameters_block^.parameters.parameter_value_table := pvt;
      IFEND;
*IFEND

    ELSE { clc$task_block }
      parameters_block^.parameters.unbundled_pdt := pdt;
      IF evaluated_by_scan_param_list THEN
        parameters_block^.parameters.names := pdt^.names;
        parameters_block^.parameters.parameter_value_table := pvt;
      IFEND;
      IF (pdt^.header^.status_parameter_number > 0) AND (pvt^ [pdt^.header^.status_parameter_number].
            variable <> NIL) THEN
        IF command_block <> NIL THEN
          IF command_block^.parameters.area <> NIL THEN
            FREE command_block^.parameters.area IN osv$task_shared_heap^;
          IFEND;
          ALLOCATE command_block^.parameters.area: [[REP STRLENGTH (pvt^
                [pdt^.header^.status_parameter_number].variable^) OF char]] IN osv$task_shared_heap^;
          RESET command_block^.parameters.area;
          NEXT command_block^.parameters.command_status_variable:
                [STRLENGTH (pvt^ [pdt^.header^.status_parameter_number].variable^)] IN
                command_block^.parameters.area;
          command_block^.parameters.command_status_variable^ :=
                pvt^ [pdt^.header^.status_parameter_number].variable^;
        IFEND;
      IFEND;
*IF NOT $true(osv$unix)
      IF command_block <> NIL THEN
        command_block^.command_logging_completed := TRUE;
        command_block^.command_echoing_completed := TRUE;
      IFEND;
*IFEND
    CASEND;

    IF command_block <> NIL THEN
      command_block := command_block^.previous_block;
    ELSE
      command_block := parameters_block^.previous_block;
    IFEND;
*IF NOT $true(osv$unix)
    IF status.normal AND (command_block <> NIL) AND (command_block^.kind = clc$command_block) AND
          (command_block^.edited_parameters_max_size > 0) THEN
      save_edited_parameter_list;
    IFEND;
*IFEND

  PROCEND clp$save_evaluated_parameters;
?? OLDTITLE, TITLE := '"Helper" routines for command and control statement processing' ??
?? NEWTITLE := 'clp$set_command_kind', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_command_kind
    (    command_kind: clt$command_kind);

    VAR
      block: ^clt$block,
      status: ^ost$status;


    clp$find_current_block (block);

    IF block^.kind <> clc$command_block THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$set_command_kind', status^);
*IF NOT $true(osv$unix)
      pmp$abort (status^);
*ELSE
      RETURN;
*IFEND
    IFEND;

    block^.command_kind := command_kind;

  PROCEND clp$set_command_kind;
?? TITLE := 'clp$set_help_mode', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_help_mode
    (    help_output_file: ^fst$file_reference;
         help_output_options: clt$parameter_help_options);

    VAR
      block: ^clt$block,
      status: ^ost$status;


    clp$find_current_block (block);
    IF block^.kind <> clc$command_block THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$set_help_mode', status^);
*IF NOT $true(osv$unix)
      pmp$abort (status^);
*ELSE
      RETURN;
*IFEND
    IFEND;

    block^.interpreter_mode := clc$help_mode;
    block^.use_command_search_mode := block^.previous_block^.use_command_search_mode;

    ALLOCATE block^.help_output_file: [STRLENGTH (help_output_file^)] IN osv$task_shared_heap^;
    block^.help_output_file^ := help_output_file^;

    block^.help_output_options := help_output_options;

  PROCEND clp$set_help_mode;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$set_if_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_if_block
    (    interpreter_mode: clt$interpreter_modes;
         if_condition_met: boolean;
         if_else_allowed: boolean);

    VAR
      block: ^clt$block,
      status: ^ost$status;


    clp$find_current_block (block);
    IF block^.kind <> clc$if_block THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$set_if_block', status^);
      pmp$abort (status^);
    IFEND;
    block^.interpreter_mode := interpreter_mode;
    block^.if_condition_met := if_condition_met;
    block^.if_else_allowed := if_else_allowed;

  PROCEND clp$set_if_block;
?? TITLE := 'clp$set_repeat_until', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_repeat_until
    (    expression_parse: clt$parse_state);

    VAR
      block: ^clt$block,
      status: ^ost$status;


    clp$find_current_block (block);
    IF (block^.kind <> clc$repeat_block) OR (block^.expression_area <> NIL) THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$set_repeat_until', status^);
      pmp$abort (status^);
    IFEND;

    ALLOCATE block^.expression_area: [[REP STRLENGTH (expression_parse.text^) OF
          char, REP UPPERBOUND (expression_parse.units_array^) OF clt$lexical_unit]] IN osv$task_shared_heap^;
    RESET block^.expression_area;
    block^.expression_parse := expression_parse;
    NEXT block^.expression_parse.text: [STRLENGTH (expression_parse.text^)] IN block^.expression_area;
    block^.expression_parse.text^ := expression_parse.text^;
    NEXT block^.expression_parse.units_array: [1 .. UPPERBOUND (expression_parse.units_array^)] IN
          block^.expression_area;
    block^.expression_parse.units_array^ := expression_parse.units_array^;

    block^.exit_position.defined := TRUE;
    capture_input_position (block, block^.exit_position.line_identifier, block^.exit_position.line_parse);

    block^.interpreter_mode := clc$interpret_mode;

  PROCEND clp$set_repeat_until;
?? TITLE := 'clp$advance_for_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$advance_for_block
    (    set_exit_position: boolean);

    VAR
      block: ^clt$block,
      list_node: ^clt$i_data_value,
      status: ^ost$status;


    clp$find_current_block (block);
    IF block^.kind <> clc$for_block THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$advance_for_block', status^);
      pmp$abort (status^);
    IFEND;

    IF block^.for_control.style = clc$for_control_incremental THEN
      block^.for_control.value.value := block^.for_control.value.value + block^.for_control.increment;
    ELSE {clc$for_control_list}
      list_node := #PTR (block^.for_control.list^.header.value, block^.for_control.list^);
      IF list_node <> NIL THEN
        block^.for_control.list^.header.value := list_node^.link;
      IFEND;
    IFEND;

    IF set_exit_position AND (NOT block^.exit_position.defined) THEN
      block^.exit_position.defined := TRUE;
      capture_input_position (block, block^.exit_position.line_identifier, block^.exit_position.line_parse);
    IFEND;

  PROCEND clp$advance_for_block;
?? TITLE := 'clp$set_task_statement_task', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_task_statement_task
    (    task_name: ost$name);

    VAR
      block: ^clt$block,
      status: ^ost$status;


    clp$find_current_block (block);
    IF (block^.kind <> clc$task_block) OR (block^.task_kind <> clc$other_task) THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$set_task_statement_task', status^);
      pmp$abort (status^);
    IFEND;
    block^.task_kind := clc$task_statement_task;
    clv$task_name := task_name;

  PROCEND clp$set_task_statement_task;
?? TITLE := 'clp$skip_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$skip_block;

    VAR
      block: ^clt$block;


    clp$find_current_block (block);
    block^.interpreter_mode := clc$skip_mode;
    block^.being_exited := TRUE;

  PROCEND clp$skip_block;
?? TITLE := 'clp$find_exit_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$find_exit_block
    (    target_label: ost$name;
     VAR target_block: ^clt$block;
     VAR terminating_utility: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      input_block: ^clt$block,
      target_is_statement: boolean,
      target_kind: (labelled_structure, any_structure, any_utility, any_command_procedure,
            any_function_procedure, any_check_statement, any_task),
      targets_input_block: ^clt$block;


    status.normal := TRUE;

    IF target_label = '' THEN
      target_kind := any_structure;
    ELSEIF target_label = 'UTILITY' THEN
      target_kind := any_utility;
    ELSEIF (target_label = 'PROCEDURE') OR (target_label = 'PROC') THEN
      target_kind := any_command_procedure;
    ELSEIF target_label = 'FUNCTION' THEN
      target_kind := any_function_procedure;
    ELSEIF target_label = 'CHECK' THEN
      target_kind := any_check_statement;
    ELSEIF target_label = 'TASK' THEN
      target_kind := any_task;
    ELSE
      target_kind := labelled_structure;
    IFEND;

    input_block := NIL;
    target_is_statement := FALSE;

    clp$find_current_block (block);
    target_block := block;
    terminating_utility := FALSE;

  /find_block_to_be_exited/
    WHILE target_block <> NIL DO
      CASE target_block^.kind OF

      = clc$block_block, clc$for_block, clc$loop_block, clc$repeat_block, clc$while_block =
        CASE target_kind OF
        = labelled_structure =
          IF target_label = target_block^.label THEN
            target_is_statement := TRUE;
            EXIT /find_block_to_be_exited/;
          IFEND;
        = any_structure =
          target_is_statement := TRUE;
          EXIT /find_block_to_be_exited/;
        ELSE
          ;
        CASEND;

      = clc$check_block =
        CASE target_kind OF
        = labelled_structure =
          IF target_label = target_block^.label THEN
            target_is_statement := TRUE;
            EXIT /find_block_to_be_exited/;
          IFEND;
        = any_structure, any_check_statement =
          target_is_statement := TRUE;
          EXIT /find_block_to_be_exited/;
        ELSE
          ;
        CASEND;

      = clc$command_block =
        IF (target_block^.source.kind = clc$sub_commands) AND
              target_block^.source.utility_termination_command THEN
          terminating_utility := TRUE;
        IFEND;

      = clc$command_proc_block =
        IF input_block = NIL THEN
          input_block := target_block;
        IFEND;

        CASE target_kind OF
        = labelled_structure =
          IF target_label = target_block^.proc_name THEN
            EXIT /find_block_to_be_exited/;
          IFEND;
        = any_structure, any_command_procedure =
          EXIT /find_block_to_be_exited/;
        ELSE
          ;
        CASEND;

        IF (target_block^.source.kind = clc$sub_commands) AND
              target_block^.source.utility_termination_command THEN
          terminating_utility := TRUE;
        IFEND;

      = clc$function_proc_block =
        IF input_block = NIL THEN
          input_block := target_block;
        IFEND;

        CASE target_kind OF
        = labelled_structure =
          IF target_label = target_block^.proc_name THEN
            EXIT /find_block_to_be_exited/;
          IFEND;
        = any_structure, any_function_procedure =
          EXIT /find_block_to_be_exited/;
        ELSE
          ;
        CASEND;

      = clc$input_block =
        IF (target_block^.previous_block^.kind = clc$task_block) AND
              (target_block^.previous_block^.task_kind = clc$job_monitor_task) AND
              (target_block^.input.kind = clc$file_input) AND (clv$processing_phase = clc$command_phase) THEN
          target_block := NIL;
          EXIT /find_block_to_be_exited/;
        IFEND;

        IF input_block = NIL THEN
          input_block := target_block;
        IFEND;

        CASE target_kind OF
        = labelled_structure =
          IF target_label = target_block^.label THEN
            EXIT /find_block_to_be_exited/;
          IFEND;
        = any_structure =
          EXIT /find_block_to_be_exited/;
        = any_utility =
          IF target_block^.label <> osc$null_name THEN
            EXIT /find_block_to_be_exited/;
          IFEND;
        = any_command_procedure, any_function_procedure =
          IF target_block^.inherited_input.found THEN
            target_block := target_block^.inherited_input.block;
            CYCLE /find_block_to_be_exited/;
          IFEND;
        ELSE
          ;
        CASEND;

      = clc$task_block =
        CASE target_kind OF
        = any_task =
          EXIT /find_block_to_be_exited/;
        ELSE
          IF NOT target_block^.synchronous_with_parent THEN
            target_block := NIL;
            EXIT /find_block_to_be_exited/;
          IFEND;
        CASEND;

      = clc$when_block =
        IF input_block = NIL THEN
          input_block := target_block;
        IFEND;

        IF target_kind = any_structure THEN
          EXIT /find_block_to_be_exited/;
        IFEND;

        IF target_block^.static_link <> NIL THEN
          target_block := target_block^.static_link;
          CYCLE /find_block_to_be_exited/;
        IFEND;

      ELSE
        ;
      CASEND;

      target_block := target_block^.previous_block;
    WHILEND /find_block_to_be_exited/;

    IF target_block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'EXIT', status);
      IF target_label <> '' THEN
        osp$append_status_parameter (' ', target_label, status);
      IFEND;
      RETURN;
    IFEND;

    IF target_is_statement AND (input_block <> NIL) THEN

    /check_statement_accessibility/
      BEGIN
        IF NOT input_block^.inherited_input.found THEN
          target_block := NIL;
          EXIT /check_statement_accessibility/;
        IFEND;

        targets_input_block := target_block^.previous_block;

      /find_target_blocks_input_block/
        BEGIN
          WHILE targets_input_block <> NIL DO
            CASE targets_input_block^.kind OF
            = clc$command_proc_block, clc$function_proc_block, clc$input_block, clc$when_block =
              EXIT /find_target_blocks_input_block/;
            = clc$task_block =
              IF NOT targets_input_block^.synchronous_with_parent THEN
                target_block := NIL;
                EXIT /check_statement_accessibility/;
              IFEND;
            ELSE
              ;
            CASEND;
            targets_input_block := targets_input_block^.previous_block;
          WHILEND;
          target_block := NIL;
          EXIT /check_statement_accessibility/;
        END /find_target_blocks_input_block/;

        WHILE input_block^.inherited_input.found DO
          input_block := input_block^.inherited_input.block;
          IF #OFFSET (input_block) = #OFFSET (targets_input_block) THEN
            EXIT /check_statement_accessibility/;
          IFEND;
        WHILEND;

        target_block := NIL;
      END /check_statement_accessibility/;

    ELSEIF (target_block^.kind = clc$input_block) AND (target_block^.associated_utility <> NIL) AND
          terminating_utility THEN
      terminating_utility := FALSE;

    /recheck_terminating_utility/
      WHILE block <> target_block DO
        CASE block^.kind OF
        = clc$command_block, clc$command_proc_block =
          IF (block^.source.kind = clc$sub_commands) AND block^.source.utility_termination_command AND
                (#OFFSET (block^.source.utility_info) = #OFFSET (^target_block^.associated_utility^.
                command_environment)) THEN
            terminating_utility := TRUE;
            EXIT /recheck_terminating_utility/;
          IFEND;
        ELSE
          ;
        CASEND;
        block := block^.previous_block;
      WHILEND /recheck_terminating_utility/;
    IFEND;

    IF target_block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'EXIT', status);
      IF target_label <> '' THEN
        osp$append_status_parameter (' ', target_label, status);
      IFEND;
    IFEND;

  PROCEND clp$find_exit_block;
?? TITLE := 'clp$exit_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$exit_block
    (    target_block_offset: ost$segment_offset;
         exit_status: ^ost$status;
         function_result: ^clt$internal_data_value;
         terminating_utility: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      child_task_block: ^clt$block,
      exit_control_block: ^clt$block,
      target_block: ^clt$block;


    status.normal := TRUE;
    clp$find_current_block (block);
    target_block := block;

    WHILE (target_block <> NIL) AND (#OFFSET (target_block) <> target_block_offset) DO
      target_block := target_block^.previous_block;
    WHILEND;

    IF target_block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$exit_block', status);
      RETURN;
    IFEND;

    child_task_block := NIL;
    exit_control_block := NIL;

  /mark_exit/
    WHILE block <> target_block DO
      CASE block^.kind OF

      = clc$block_block, clc$case_block, clc$for_block, clc$if_block, clc$loop_block,
            clc$repeat_block, clc$while_block =
        IF target_block^.exit_position.defined AND (exit_control_block = NIL) AND (child_task_block = NIL)
              THEN
          clp$pop_block_stack (block);
          CYCLE /mark_exit/;
        IFEND;

      = clc$check_block, clc$command_block, clc$command_proc_block, clc$function_block,
            clc$function_proc_block, clc$input_block, clc$when_block =
        exit_control_block := block;

      = clc$task_block =
        child_task_block := block;
        exit_control_block := NIL;

      ELSE
        ;
      CASEND;

      block^.interpreter_mode := clc$skip_mode;
      block^.being_exited := TRUE;
      block := block^.previous_block;
    WHILEND /mark_exit/;

    IF target_block^.exit_position.defined AND (exit_control_block = NIL) AND (child_task_block = NIL) THEN
      clp$reset_input_position (target_block^.exit_position.line_identifier,
            target_block^.exit_position.line_parse);
      clp$pop_block_stack (block);
      RETURN;
    IFEND;

    target_block^.interpreter_mode := clc$skip_mode;
    target_block^.being_exited := TRUE;

    CASE target_block^.kind OF

    = clc$check_block =
      target_block^.check_status := exit_status^;
      exit_control_block := target_block;

    = clc$command_block, clc$function_block, clc$when_block =
      exit_control_block := target_block;

    = clc$command_proc_block =
      IF (exit_status <> NIL) AND (NOT exit_status^.normal) AND (target_block^.command_proc_status = NIL) THEN
        ALLOCATE target_block^.command_proc_status IN osv$task_shared_heap^;
      IFEND;
      IF target_block^.command_proc_status <> NIL THEN
        target_block^.command_proc_status^ := exit_status^;
      IFEND;
      exit_control_block := target_block;

    = clc$function_proc_block =
      IF function_result <> NIL THEN
        IF (target_block^.function_proc_result <> NIL) AND (#SIZE (function_result^) <>
              #SIZE (target_block^.function_proc_result^)) THEN
          FREE target_block^.function_proc_result IN osv$task_shared_heap^;
        IFEND;
        IF target_block^.function_proc_result = NIL THEN
          ALLOCATE target_block^.function_proc_result: [[REP #SIZE (function_result^.allocated_space) OF
                cell]] IN osv$task_shared_heap^;
        IFEND;
        target_block^.function_proc_result^ := function_result^;
      IFEND;
      exit_control_block := target_block;

    = clc$input_block =
      IF terminating_utility AND (target_block^.associated_utility <> NIL) THEN
        target_block^.associated_utility^.termination_command_found := TRUE;
      IFEND;
      exit_control_block := target_block;

    ELSE
      ;
    CASEND;

    IF child_task_block <> NIL THEN
      clp$send_exiting_signal (child_task_block^.parent^.task_id, child_task_block^.task_id,
            exit_control_block, status);
    ELSEIF exit_control_block <> NIL THEN
      pmp$cause_task_condition (clc$exiting_condition, exit_control_block, {notify_scl=} FALSE,
            {notify_debug=} FALSE, {propagate_to_parent=} FALSE, {call_default_handler=} FALSE, status);
    IFEND;

  PROCEND clp$exit_block;
?? TITLE := 'clp$find_cycle_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$find_cycle_block
    (    target_label: ost$name;
     VAR current_block: ^clt$block;
     VAR target_block: ^clt$block;
     VAR status: ost$status);


    status.normal := TRUE;
    clp$find_current_block (current_block);
    target_block := current_block;

  /find_block_to_be_cycled/
    WHILE target_block <> NIL DO
      CASE target_block^.kind OF
      = clc$block_block =
        IF (target_label <> '') AND (target_label = target_block^.label) THEN
          osp$set_status_abnormal ('CL', cle$statement_cant_be_cycled, 'BLOCK', status);
          RETURN;
        IFEND;
      = clc$case_block, clc$if_block =
        ;
      = clc$for_block, clc$loop_block, clc$repeat_block, clc$while_block =
        IF (target_label = '') OR (target_label = target_block^.label) THEN
          RETURN;
        IFEND;
      ELSE
        target_block := NIL;
        EXIT /find_block_to_be_cycled/;
      CASEND;
      target_block := target_block^.previous_block;
    WHILEND /find_block_to_be_cycled/;
    IF target_block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'CYCLE', status);
      IF target_label <> '' THEN
        osp$append_status_parameter (' ', target_label, status);
      IFEND;
      RETURN;
    IFEND;

  PROCEND clp$find_cycle_block;
?? TITLE := 'clp$cycle_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$cycle_block
    (    target_label: ost$name;
         no_more_iterations: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      reset_line_identifier: clt$line_identifier,
      reset_line_parse: clt$parse_state,
      target_block: ^clt$block;


    clp$find_cycle_block (target_label, block, target_block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF target_block^.exit_position.defined THEN
      WHILE block <> target_block DO
        clp$pop_block_stack (block);
      WHILEND;
      clp$reset_input_position (target_block^.exit_position.line_identifier,
            target_block^.exit_position.line_parse);
      clp$pop_block_stack (block);
    ELSE
      WHILE block <> target_block DO
        block^.interpreter_mode := clc$skip_mode;
        block^.being_exited := TRUE;
        block := block^.previous_block;
      WHILEND;
      target_block^.interpreter_mode := clc$skip_mode;
      target_block^.being_exited := no_more_iterations;
    IFEND;

  PROCEND clp$cycle_block;
?? TITLE := 'clp$set_exit_position', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_exit_position;

    VAR
      block: ^clt$block;


    clp$find_current_block (block);
    block^.exit_position.defined := TRUE;
    capture_input_position (block, block^.exit_position.line_identifier, block^.exit_position.line_parse);

  PROCEND clp$set_exit_position;
?? TITLE := 'clp$fetch_display_log_indices', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$fetch_display_log_indices
    (VAR indices: clt$display_log_indices);

    VAR
      status: ost$status,
      block: ^clt$block;


    clp$find_task_block (block, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to get pointer to SCL Task Block', ^status);
    IFEND;
    indices := block^.display_log_indices;

  PROCEND clp$fetch_display_log_indices;
?? TITLE := 'clp$store_display_log_indices', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$store_display_log_indices
    (    indices: clt$display_log_indices);

    VAR
      status: ost$status,
      block: ^clt$block;


    clp$find_task_block (block, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to get pointer to SCL Task Block', ^status);
    IFEND;
    block^.display_log_indices := indices;

  PROCEND clp$store_display_log_indices;
?? TITLE := 'clp$notify_before_command_read', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$notify_before_command_read
    (    notification_procedure: ^procedure
           (VAR status: ost$status));

    VAR
      status: ost$status,
      block: ^clt$block;


    clp$find_current_block (block);
    IF block^.kind <> clc$utility_block THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$notify_before_command_read', status);
      pmp$abort (status);
    IFEND;
    block^.notify_before_command_read := notification_procedure;

  PROCEND clp$notify_before_command_read;
?? TITLE := 'clp$get_command_name', EJECT ??
*copy clh$get_command_name

  PROCEDURE [XDCL, #GATE] clp$get_command_name
    (VAR name: clt$command_name;
     VAR status: ost$status);

    VAR
      block: ^clt$block;


    status.normal := TRUE;
    clp$find_current_block (block);

    CASE block^.kind OF
    = clc$command_block, clc$command_proc_block =
      name := block^.label;
      RETURN;
    = clc$task_block =
      IF (block^.task_kind = clc$other_task) AND block^.synchronous_with_parent AND
            (block^.previous_block^.kind = clc$command_block) THEN
        name := block^.previous_block^.label;
        RETURN;
      IFEND;
    ELSE
      ;
    CASEND;

    osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$get_command_name', status);

  PROCEND clp$get_command_name;
?? TITLE := 'clp$get_command_image', EJECT ??
*copy clh$get_command_image

  PROCEDURE [XDCL, #GATE] clp$get_command_image
    (VAR command_image: ^clt$command_line;
     VAR status: ost$status);

    VAR
      block: ^clt$block;


    status.normal := TRUE;
    command_image := NIL;

    clp$find_current_block (block);

  /find_command/
    WHILE block <> NIL DO
      CASE block^.kind OF
      = clc$command_block, clc$command_proc_block =
        IF block^.source.size <= (STRLENGTH (block^.line_parse.text^) - block^.source.index + 1) THEN
          command_image := ^block^.line_parse.text^ (block^.source.index, block^.source.size);
          RETURN;
        IFEND;
        EXIT /find_command/;
      ELSE
        block := block^.previous_block;
      CASEND;
    WHILEND /find_command/;

    osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$get_command_image', status);

  PROCEND clp$get_command_image;
*IFEND

MODEND clm$block_stack_manager;
*DECK DECK=CLM$CHANGE_NATURAL_LANGUAGE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Change Natural Language' ??
MODULE clm$change_natural_language;

{
{  PURPOSE:
{    This module contains the ring 11 processor for the CHANGE_NATURAL_LANGUAGE command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
*copyc clp$evaluate_parameters
*copyc osp$set_natural_language
?? TITLE := 'clp$_change_natural_language', EJECT ??

  PROCEDURE [XDCL] clp$_change_natural_language
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$chanl) change_natural_language, chanl (
{   natural_language, nl: any of
{       key
{         danish, dutch, english, finnish, flemish, french, german, italian, norwegian, portuguese, spanish
{         swedish, us_english
{       keyend
{       name
{     anyend = $required
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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 .. 13] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 1, 25, 14, 8, 9, 639],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$CHANL'], [
    ['NATURAL_LANGUAGE               ',clc$nominal_entry, 1],
    ['NL                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 513,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    488, [[1, 0, clc$keyword_type], [13], [
      ['DANISH                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['DUTCH                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['ENGLISH                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['FINNISH                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['FLEMISH                        ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['FRENCH                         ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['GERMAN                         ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['ITALIAN                        ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['NORWEGIAN                      ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['PORTUGUESE                     ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['SPANISH                        ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['SWEDISH                        ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['US_ENGLISH                     ', clc$nominal_entry, clc$normal_usage_entry, 13]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

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

    CONST
      p$natural_language = 1,
      p$status = 2;

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


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

    IF pvt [p$natural_language].value^.kind = clc$keyword THEN
      osp$set_natural_language (pvt [p$natural_language].value^.keyword_value, status);
    ELSE
      osp$set_natural_language (pvt [p$natural_language].value^.name_value, status);
    IFEND;

  PROCEND clp$_change_natural_language;

MODEND clm$change_natural_language;
*DECK DECK=CLM$CHANGE_REDO_TERMINAL_TYPE EXPAND=TRUE
PROC change_redo_terminal_type, chartt (full_duplex,fd: boolean = no
     insert_mode,im: boolean = no)
IF $JOB(mode) = 'INTERACTIVE' THEN
  $system.osf$command_library.clp$enable_redo fd=$value(fd) im=$value(im)
  disv 'Terminal type reset.'
IFEND
PROCEND

*DECK DECK=CLM$CHANGE_UNSEEN_MAIL_ACTION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter: UNSEEN_MAIL_ACTION Commands & Functions' ??
MODULE clm$change_unseen_mail_action;

{
{ PURPOSE:
{   This module contains the processors for the CHNAGE_UNSEEN_MAIL_ACTION
{   command and the $UNSEEN_MAIL_ACTION function.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc clt$unseen_mail_action
*copyc ost$status
?? POP ??
*copyc clp$change_unseen_mail_action
*copyc clp$evaluate_parameters
*copyc clp$find_unseen_mail_action
*copyc clp$make_value
?? OLDTITLE ??
?? NEWTITLE := 'clp$_change_unseen_mail_action', EJECT ??

  PROCEDURE [XDCL] clp$_change_unseen_mail_action
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (clm$chauma) change_unseen_mail_action, chauma (
{   action, a : key
{       (display, d)
{       (post, p)
{     keyend = display
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 12, 19, 13, 56, 6, 382],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'CLM$CHAUMA'], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['ACTION                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [4], [
    ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['DISPLAY                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['POST                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'display'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

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

    CONST
      p$action = 1,
      p$status = 2;

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

    VAR
      action: clt$unseen_mail_action;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF pvt [p$action].value^.keyword_value = 'POST' THEN
      action := clc$post_unseen_mail;
    ELSE
      action := clc$display_unseen_mail;
    IFEND;
    clp$change_unseen_mail_action (action, status);
  PROCEND clp$_change_unseen_mail_action;
?? OLDTITLE ??
?? NEWTITLE := 'clp$$unseen_mail_action', EJECT ??

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

{ FUNCTION (clm$$unsma) $unseen_mail_action

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [90, 7, 18, 13, 23, 55, 898],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'CLM$$UNSMA']];

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

    VAR
      action: ^clt$unseen_mail_action;


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

    clp$find_unseen_mail_action (action);

    clp$make_value (clc$keyword, work_area, result);

    IF action^ = clc$post_unseen_mail THEN
      result^.keyword_value := 'POST';
    ELSE
      result^.keyword_value := 'DISPLAY';
    IFEND;

  PROCEND clp$$unseen_mail_action;
?? OLDTITLE ??

MODEND clm$change_unseen_mail_action;
*DECK DECK=CLM$CLT$VALUE_CONVERSION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Clt$value Conversion Procedures' ??
MODULE clm$clt$value_conversion;

{
{ PURPOSE:
{   This module contains the procedures that convert between 'new' values
{   (clt$data_value, clt$internal_data_value) and 'old' values
{   (clt$value, clt$variable_value).

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_limits
*copyc cld$value
*copyc cle$bad_clt$value
*copyc cle$bad_clt$variable_value
*copyc cle$bad_data_value
*copyc cle$bad_internal_value
*copyc cle$not_supported
*copyc cle$string_too_long
*copyc cle$unexpected_value_type
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$internal_data_value
*copyc clt$internal_data_value_header
*copyc clt$type_conformance
*copyc clt$type_description
*copyc clt$work_area
*copyc clv$type_kind_names
*copyc clv$value_descriptors
*copyc clv$value_type_kinds
*IF NOT $true(osv$unix)
*copyc cyd$run_time_error_condition
*IFEND
*copyc ost$status
?? POP ??
*copyc clp$append_status_value_type
*copyc clp$convert_to_clt$status
*copyc clp$convert_to_ost$status
*copyc clp$get_path_name
*copyc clp$get_work_area
*IF NOT $true(osv$unix)
*copyc clp$longreal_compare_le
*IFEND
*copyc clp$make_application_clt$value
*copyc clp$make_application_value
*copyc clp$make_array_value
*copyc clp$make_boolean_clt$value
*copyc clp$make_clt$boolean_value
*copyc clp$make_clt$integer_value
*copyc clp$make_clt$real_value
*copyc clp$make_clt$value
*copyc clp$make_file_clt$value
*IF NOT $true(osv$unix)
*copyc clp$make_file_value
*IFEND
*copyc clp$make_integer_clt$value
*copyc clp$make_name_clt$value
*copyc clp$make_name_value
*IF $true(osv$unix)
*copyc clp$make_nos_ve_file_value
*IFEND
*copyc clp$make_real_clt$value
*copyc clp$make_status_clt$value
*copyc clp$make_status_value
*copyc clp$make_string_value
*copyc clp$make_unspecified_value
*copyc clp$trimmed_string_size
*copyc i#current_sequence_position
*copyc osp$append_status_parameter
*IF NOT $true(osv$unix)
*copyc osp$establish_condition_handler
*IFEND
*copyc osp$set_status_abnormal
*IF NOT $true(osv$unix)
*copyc pmp$continue_to_cause
*IFEND
?? TITLE := 'clp$convert_clt$value_to_value', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$convert_clt$value_to_value
    (    value: clt$value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR data_value: ^clt$data_value;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
?? NEWTITLE := 'abort_handler', EJECT ??

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


      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          bad_value;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          bad_value;
        IFEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
*IFEND
?? TITLE := 'bad_value', EJECT ??

    PROCEDURE bad_value;


      osp$set_status_abnormal ('CL', cle$bad_clt$value, '', status);
      EXIT clp$convert_clt$value_to_value;

    PROCEND bad_value;
?? TITLE := 'convert_application_value', EJECT ??

    PROCEDURE [INLINE] convert_application_value;

      VAR
        application_value: ^clt$application_value,
        text: ^clt$application_value_text;


      application_value := ^value.application;
      RESET application_value;
      NEXT text: [#SIZE (clt$application_value)] IN application_value;
      clp$make_application_value (text^, work_area, data_value);

    PROCEND convert_application_value;
?? TITLE := 'convert_boolean_value', EJECT ??

    PROCEDURE [INLINE] convert_boolean_value;


      clp$make_clt$boolean_value (value.bool, work_area, data_value);

    PROCEND convert_boolean_value;
?? TITLE := 'convert_file_value', EJECT ??

    PROCEDURE [INLINE] convert_file_value;

      VAR
        path: ^fst$path;


*IF NOT $true(osv$unix)
      PUSH path;
      clp$get_path_name (value.file.local_file_name, osc$full_message_level, path^);

      clp$make_file_value (path^ (1, clp$trimmed_string_size (path^)), work_area, data_value);
*ELSE
      clp$make_nos_ve_file_value (value.file.local_file_name, work_area, data_value);
*IFEND

    PROCEND convert_file_value;
?? TITLE := 'convert_integer_value', EJECT ??

    PROCEDURE [INLINE] convert_integer_value;


      clp$make_clt$integer_value (value.int, work_area, data_value);

    PROCEND convert_integer_value;
?? TITLE := 'convert_name_value', EJECT ??

    PROCEDURE [INLINE] convert_name_value;


      clp$make_name_value (value.name.value, work_area, data_value);

    PROCEND convert_name_value;
*IF NOT $true(osv$unix)
?? TITLE := 'convert_real_value', EJECT ??

    PROCEDURE [INLINE] convert_real_value;


      clp$make_clt$real_value (value.rnum, work_area, data_value);

    PROCEND convert_real_value;
*IFEND
?? TITLE := 'convert_status_value', EJECT ??

    PROCEDURE [INLINE] convert_status_value;


      clp$make_status_value (value.status, work_area, data_value);

    PROCEND convert_status_value;
?? TITLE := 'convert_string_value', EJECT ??

    PROCEDURE [INLINE] convert_string_value;


      clp$make_string_value (value.str.value (1, value.str.size), work_area, data_value);

    PROCEND convert_string_value;
?? TITLE := 'convert_unknown_value', EJECT ??

    PROCEDURE [INLINE] convert_unknown_value;


      clp$make_unspecified_value (work_area, data_value);

    PROCEND convert_unknown_value;
*IF NOT $true(osv$unix)
?? TITLE := 'convert_variable_reference', EJECT ??

    PROCEDURE [INLINE] convert_variable_reference;

      VAR
        lower_bound: clt$variable_dimension,
        upper_bound: clt$variable_dimension;

      CASE value.var_ref.value.kind OF
      = clc$boolean_value =
        lower_bound := LOWERBOUND (value.var_ref.value.boolean_value^);
        upper_bound := UPPERBOUND (value.var_ref.value.boolean_value^);
      = clc$integer_value =
        lower_bound := LOWERBOUND (value.var_ref.value.integer_value^);
        upper_bound := UPPERBOUND (value.var_ref.value.integer_value^);
      = clc$real_value =
        lower_bound := LOWERBOUND (value.var_ref.value.real_value^);
        upper_bound := UPPERBOUND (value.var_ref.value.real_value^);
      = clc$status_value =
        lower_bound := LOWERBOUND (value.var_ref.value.status_value^);
        upper_bound := UPPERBOUND (value.var_ref.value.status_value^);
      = clc$string_value =
        lower_bound := LOWERBOUND (value.var_ref.value.string_value^);
        upper_bound := (UPPERBOUND (value.var_ref.value.string_value^)) DIV
              (#SIZE (ost$string_size) + value.var_ref.value.max_string_size);
      ELSE
        bad_value;
      CASEND;

      clp$convert_var_value_to_value (value.var_ref.value, TRUE, lower_bound, upper_bound, work_area,
            data_value, status);

    PROCEND convert_variable_reference;
*IFEND
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    data_value := NIL;
*IF NOT $true(osv$unix)
    osp$establish_condition_handler (^abort_handler, FALSE);
*IFEND

    CASE value.kind OF
    = clc$application_value =
      convert_application_value;
    = clc$boolean_value =
      convert_boolean_value;
    = clc$file_value =
      convert_file_value;
    = clc$integer_value =
      convert_integer_value;
    = clc$name_value =
      convert_name_value;
*IF NOT $true(osv$unix)
    = clc$real_value =
      convert_real_value;
*IFEND
    = clc$status_value =
      convert_status_value;
    = clc$string_value =
      convert_string_value;
    = clc$unknown_value =
      convert_unknown_value;
*IF NOT $true(osv$unix)
    = clc$variable_reference =
      convert_variable_reference;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
*IFEND
    ELSE
      bad_value;
    CASEND;

    IF data_value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$convert_clt$value_to_value;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$convert_int_to_var_value', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$convert_int_to_var_value
    (    internal_value: ^clt$internal_data_value;
         max_string_size: clt$string_size;
     VAR variable_value: clt$variable_value;
     VAR status: ost$status);

    VAR
      array_value: ^array [ * ] of REL (clt$internal_data_value) ^clt$i_data_value,
      element_index: clt$array_bound,
      first_element_kind: clt$data_kind,
      i_value: ^clt$i_data_value,
      local_max_string_size: ost$string_size,
      lower_bound: clt$array_bound,
      string_value_record: ^record
        size: ost$string_size,
        value: string ( * ),
      recend,
      string_value_seq: ^SEQ ( * ),
      upper_bound: clt$array_bound,
      variable_value_allocated: boolean,
      work_area: ^^clt$work_area;

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

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


      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          bad_internal_value;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          bad_internal_value;
        IFEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? TITLE := 'bad_internal_value', EJECT ??

    PROCEDURE bad_internal_value;


      osp$set_status_abnormal ('CL', cle$bad_internal_value, '', status);
      EXIT clp$convert_int_to_var_value;

    PROCEND bad_internal_value;
?? TITLE := 'bad_internal_value_type', EJECT ??

    PROCEDURE bad_internal_value_type;


      IF i_value^.kind = clc$deferred THEN
        osp$set_status_abnormal ('CL', cle$not_supported, '', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'DEFERRED value', status);
      ELSE
        osp$set_status_abnormal ('CL', cle$unexpected_value_type, '', status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              clv$type_kind_names [clv$value_type_kinds [i_value^.kind]], status);
      IFEND;
      EXIT clp$convert_int_to_var_value;

    PROCEND bad_internal_value_type;
?? TITLE := 'work_area_overflow', EJECT ??

    PROCEDURE work_area_overflow;


      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      EXIT clp$convert_int_to_var_value;

    PROCEND work_area_overflow;
?? TITLE := 'allocate_variable_value', EJECT ??

    PROCEDURE [INLINE] allocate_variable_value;


      first_element_kind := i_value^.kind;
      CASE i_value^.kind OF
      = clc$boolean =
        variable_value.kind := clc$boolean_value;
        NEXT variable_value.boolean_value: [1 .. (upper_bound - lower_bound + 1)] IN work_area^;
        IF variable_value.boolean_value = NIL THEN
          work_area_overflow;
        IFEND;
      = clc$integer =
        variable_value.kind := clc$integer_value;
        NEXT variable_value.integer_value: [1 .. (upper_bound - lower_bound + 1)] IN work_area^;
        IF variable_value.integer_value = NIL THEN
          work_area_overflow;
        IFEND;
      = clc$real =
        variable_value.kind := clc$real_value;
        NEXT variable_value.real_value: [1 .. (upper_bound - lower_bound + 1)] IN work_area^;
        IF variable_value.real_value = NIL THEN
          work_area_overflow;
        IFEND;
      = clc$status =
        variable_value.kind := clc$status_value;
        NEXT variable_value.status_value: [1 .. (upper_bound - lower_bound + 1)] IN work_area^;
        IF variable_value.status_value = NIL THEN
          work_area_overflow;
        IFEND;
      = clc$string =
        variable_value.kind := clc$string_value;
        variable_value.max_string_size := local_max_string_size;
        NEXT variable_value.string_value: [1 .. ((upper_bound - lower_bound + 1) *
              (local_max_string_size + #SIZE (ost$string_size)))] IN work_area^;
        IF variable_value.string_value = NIL THEN
          work_area_overflow;
        IFEND;
        string_value_seq := #SEQ (variable_value.string_value^);
        RESET string_value_seq;
      = clc$array, clc$cobol_name, clc$command_reference, clc$data_name, clc$date_time, clc$deferred,
            clc$entry_point_reference, clc$keyword, clc$lock, clc$network_title, clc$program_name, clc$record,
            clc$scu_line_identifier, clc$statistic_code, clc$status_code, clc$string_pattern,
            clc$time_increment, clc$time_zone, clc$type_specification =
        bad_internal_value_type;
      ELSE
        bad_internal_value;
      CASEND;
      variable_value.descriptor := clv$value_descriptors [variable_value.kind];

    PROCEND allocate_variable_value;
?? TITLE := 'create_variable_value', EJECT ??

    PROCEDURE [INLINE] create_variable_value;


      CASE i_value^.kind OF
      = clc$boolean =
        convert_boolean_value;
      = clc$integer =
        convert_integer_value;
      = clc$real =
        convert_real_value;
      = clc$status =
        convert_status_value;
      = clc$string =
        convert_string_value;
      = clc$array, clc$cobol_name, clc$command_reference, clc$data_name, clc$date_time, clc$deferred,
            clc$entry_point_reference, clc$keyword, clc$lock, clc$network_title, clc$program_name, clc$record,
            clc$scu_line_identifier, clc$statistic_code, clc$status_code, clc$string_pattern,
            clc$time_increment, clc$time_zone, clc$type_specification =
        bad_internal_value_type;
      ELSE
        bad_internal_value;
      CASEND;

    PROCEND create_variable_value;
?? TITLE := 'convert_boolean_value', EJECT ??

    PROCEDURE [INLINE] convert_boolean_value;


      variable_value.boolean_value^ [element_index] := i_value^.boolean_value;

    PROCEND convert_boolean_value;
?? TITLE := 'convert_integer_value', EJECT ??

    PROCEDURE [INLINE] convert_integer_value;


      variable_value.integer_value^ [element_index] := i_value^.integer_value;

    PROCEND convert_integer_value;
?? TITLE := 'convert_real_value', EJECT ??

    PROCEDURE [INLINE] convert_real_value;


      variable_value.real_value^ [element_index] := i_value^.real_value;

    PROCEND convert_real_value;
?? TITLE := 'convert_status_value', EJECT ??

    PROCEDURE [INLINE] convert_status_value;

      VAR
        status_value: ^ost$status;


      status_value := #PTR (i_value^.status_value, internal_value^);

      clp$convert_to_clt$status (status_value^, variable_value.status_value^ [element_index]);

    PROCEND convert_status_value;
?? TITLE := 'convert_string_value', EJECT ??

    PROCEDURE [INLINE] convert_string_value;

      VAR
        string_length: ost$string_size,
        string_value: ^clt$string_value;


      string_value := #PTR (i_value^.string_value, internal_value^);

      IF STRLENGTH (string_value^) > local_max_string_size THEN
        string_length := local_max_string_size;
      ELSE
        string_length := STRLENGTH (string_value^);
      IFEND;
      NEXT string_value_record: [local_max_string_size] IN string_value_seq;
      string_value_record^.size := string_length;
      string_value_record^.value := string_value^ (1, string_length);

    PROCEND convert_string_value;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    variable_value_allocated := FALSE;
    IF max_string_size <= osc$max_string_size THEN
      local_max_string_size := max_string_size;
    ELSE
      local_max_string_size := osc$max_string_size;
    IFEND;

*IF NOT $true(osv$unix)
    clp$get_work_area (#RING (^work_area), work_area, status);
*ELSE
    clp$get_work_area (osc$user_ring, work_area, status);
*IFEND
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^abort_handler, FALSE);

    i_value := #PTR (internal_value^.header.value, internal_value^);

    IF i_value^.kind <> clc$array THEN
      lower_bound := 1;
      upper_bound := 1;
      element_index := 1;
      allocate_variable_value;
      create_variable_value;
      RETURN;
    IFEND;

    array_value := #PTR (i_value^.array_value, internal_value^);

    lower_bound := LOWERBOUND (array_value^);
    upper_bound := UPPERBOUND (array_value^);

    FOR element_index := 1 TO (upper_bound - lower_bound + 1) DO

      i_value := #PTR (array_value^ [element_index + lower_bound - 1], internal_value^);
      IF NOT variable_value_allocated THEN
        allocate_variable_value;
        variable_value_allocated := TRUE;
      ELSEIF i_value^.kind <> first_element_kind THEN
        bad_internal_value;
      IFEND;

      create_variable_value;

    FOREND;

  PROCEND clp$convert_int_to_var_value;
*IFEND
?? TITLE := 'clp$convert_value_to_clt$value', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$convert_value_to_clt$value
    (    data_value: ^clt$data_value;
         value_set_number: 1 .. clc$max_value_sets;
         value_number: 1 .. clc$max_values_per_set;
         low_or_high: clt$low_or_high;
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      element_value: ^clt$data_value;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'abort_handler', EJECT ??

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


      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          bad_data_value;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          bad_data_value;
        IFEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
*IFEND
?? TITLE := 'bad_data_value', EJECT ??

    PROCEDURE bad_data_value;


      osp$set_status_abnormal ('CL', cle$bad_data_value, '', status);
      EXIT clp$convert_value_to_clt$value;

    PROCEND bad_data_value;
?? TITLE := 'bad_data_value_type', EJECT ??

    PROCEDURE bad_data_value_type;


      IF element_value^.kind = clc$deferred THEN
        osp$set_status_abnormal ('CL', cle$not_supported, '', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'DEFERRED value', status);
      ELSE
        osp$set_status_abnormal ('CL', cle$unexpected_value_type, '', status);
        clp$append_status_value_type (osc$status_parameter_delimiter, element_value, status);
      IFEND;
      EXIT clp$convert_value_to_clt$value;

    PROCEND bad_data_value_type;
?? TITLE := 'convert_application_value', EJECT ??

    PROCEDURE [INLINE] convert_application_value;


      clp$make_application_clt$value (element_value^.application_value^, value);

    PROCEND convert_application_value;
?? TITLE := 'convert_boolean_value', EJECT ??

    PROCEDURE [INLINE] convert_boolean_value;


      clp$make_boolean_clt$value (element_value^.boolean_value, value);

    PROCEND convert_boolean_value;
?? TITLE := 'convert_file_value', EJECT ??

    PROCEDURE [INLINE] convert_file_value;

{     This assumes that the fst$file_reference really contains an amt$local_file_name.

      IF clp$trimmed_string_size (element_value^.file_value^) <= osc$max_name_size THEN
        clp$make_file_clt$value (element_value^.file_value^, value);
      ELSE
        bad_data_value;
      IFEND;

    PROCEND convert_file_value;
?? TITLE := 'convert_integer_value', EJECT ??

    PROCEDURE [INLINE] convert_integer_value;


      clp$make_integer_clt$value (element_value^.integer_value, value);

    PROCEND convert_integer_value;
?? TITLE := 'convert_keyword_value', EJECT ??

    PROCEDURE [INLINE] convert_keyword_value;


      clp$make_name_clt$value (element_value^.keyword_value,
            clp$trimmed_string_size (element_value^.data_name_value), value);

    PROCEND convert_keyword_value;
?? TITLE := 'convert_list_value', EJECT ??

    PROCEDURE [INLINE] convert_list_value;

      VAR
        current_node: ^clt$data_value,
        value_index: 0 .. clc$max_values_per_set,
        value_set_index: 0 .. clc$max_value_sets;


      current_node := element_value;
      element_value := NIL;
      value_set_index := 0;
      WHILE value_set_index < value_set_number DO
        IF current_node = NIL THEN
          clp$make_clt$value (clc$unknown_value, value);
          RETURN;
        IFEND;
        IF current_node^.kind <> clc$list THEN
          bad_data_value;
        IFEND;
        element_value := current_node^.element_value;
        IF element_value <> NIL THEN
          value_set_index := value_set_index + 1;
        IFEND;
        current_node := current_node^.link;
      WHILEND;

      IF element_value = NIL THEN
        clp$make_clt$value (clc$unknown_value, value);
        RETURN;
      ELSEIF element_value^.kind = clc$list THEN
        current_node := element_value;
        element_value := NIL;
        value_index := 0;
        WHILE value_index < value_number DO
          IF current_node = NIL THEN
            clp$make_clt$value (clc$unknown_value, value);
            RETURN;
          IFEND;
          IF current_node^.kind <> clc$list THEN
            bad_data_value;
          IFEND;
          element_value := current_node^.element_value;
          IF element_value <> NIL THEN
            value_index := value_index + 1;
          IFEND;
          current_node := current_node^.link;
        WHILEND;
      ELSEIF value_number <> 1 THEN
        clp$make_clt$value (clc$unknown_value, value);
        RETURN;
      IFEND;

      IF element_value = NIL THEN
        clp$make_clt$value (clc$unknown_value, value);
        RETURN;
      ELSEIF element_value^.kind = clc$range THEN
        IF low_or_high = clc$high THEN
          element_value := element_value^.high_value;
        ELSE
          element_value := element_value^.low_value;
        IFEND;
        IF element_value = NIL THEN
          clp$make_clt$value (clc$unknown_value, value);
          RETURN;
        IFEND;
      IFEND;

      convert_single_value;

    PROCEND convert_list_value;
?? TITLE := 'convert_name_value', EJECT ??

    PROCEDURE [INLINE] convert_name_value;


      clp$make_name_clt$value (element_value^.name_value, clp$trimmed_string_size
            (element_value^.data_name_value), value);

    PROCEND convert_name_value;
?? TITLE := 'convert_range_value', EJECT ??

    PROCEDURE [INLINE] convert_range_value;


      IF low_or_high = clc$high THEN
        element_value := element_value^.high_value;
      ELSE
        element_value := element_value^.low_value;
      IFEND;
      convert_single_value;

    PROCEND convert_range_value;
?? TITLE := 'convert_real_value', EJECT ??

    PROCEDURE [INLINE] convert_real_value;


      clp$make_real_clt$value (element_value^.real_value, value);

    PROCEND convert_real_value;
?? TITLE := 'convert_single_value', EJECT ??

    PROCEDURE [INLINE] convert_single_value;


      CASE element_value^.kind OF
      = clc$application =
        convert_application_value;
      = clc$boolean =
        convert_boolean_value;
*IF NOT $true(osv$unix)
      = clc$file =
*ELSE
      = clc$nos_ve_file =
*IFEND
        convert_file_value;
      = clc$integer =
        convert_integer_value;
      = clc$keyword =
        convert_keyword_value;
      = clc$name =
        convert_name_value;
      = clc$real =
        convert_real_value;
      = clc$status =
        convert_status_value;
      = clc$string =
        convert_string_value;
      = clc$unspecified =
        convert_unspecified_value;
      = clc$array, clc$cobol_name, clc$command_reference, clc$data_name, clc$date_time, clc$deferred,
            clc$entry_point_reference, clc$lock, clc$network_title, clc$program_name, clc$record,
            clc$scu_line_identifier, clc$statistic_code, clc$status_code, clc$string_pattern,
*IF NOT $true(osv$unix)
            clc$time_increment, clc$time_zone, clc$type_specification =
*ELSE
            clc$time_increment, clc$time_zone, clc$type_specification, clc$unix_file =
*IFEND
        bad_data_value_type;
      ELSE
        bad_data_value;
      CASEND;

    PROCEND convert_single_value;
?? TITLE := 'convert_status_value', EJECT ??

    PROCEDURE [INLINE] convert_status_value;


      clp$make_status_clt$value (element_value^.status_value^, value);

    PROCEND convert_status_value;
?? TITLE := 'convert_string_value', EJECT ??

    PROCEDURE [INLINE] convert_string_value;

      VAR
        string_length: ost$string_size;


      IF STRLENGTH (element_value^.string_value^) > osc$max_string_size THEN
        string_length := osc$max_string_size;
      ELSE
        string_length := STRLENGTH (element_value^.string_value^);
      IFEND;
      clp$make_clt$value (clc$string_value, value);
      value.str.size := string_length;
      value.str.value := element_value^.string_value^ (1, string_length);

    PROCEND convert_string_value;
?? TITLE := 'convert_unspecified_value', EJECT ??

    PROCEDURE [INLINE] convert_unspecified_value;


      clp$make_clt$value (clc$unknown_value, value);

    PROCEND convert_unspecified_value;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    element_value := data_value;

    IF (element_value = NIL) OR ((element_value^.kind <> clc$list) AND
          ((value_set_number <> 1) OR (value_number <> 1))) THEN
      convert_unspecified_value;
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    osp$establish_condition_handler (^abort_handler, FALSE);
*IFEND

    CASE element_value^.kind OF
    = clc$application =
      convert_application_value;
    = clc$boolean =
      convert_boolean_value;
*IF NOT $true(osv$unix)
    = clc$file =
*ELSE
    = clc$nos_ve_file =
*IFEND
      convert_file_value;
    = clc$integer =
      convert_integer_value;
    = clc$keyword =
      convert_keyword_value;
    = clc$list =
      convert_list_value;
    = clc$name =
      convert_name_value;
    = clc$range =
      convert_range_value;
    = clc$real =
      convert_real_value;
    = clc$status =
      convert_status_value;
    = clc$string =
      convert_string_value;
    = clc$unspecified =
      convert_unspecified_value;
    = clc$array, clc$cobol_name, clc$command_reference, clc$data_name, clc$date_time, clc$deferred,
          clc$entry_point_reference, clc$lock, clc$network_title, clc$program_name, clc$record,
          clc$scu_line_identifier, clc$statistic_code, clc$status_code, clc$string_pattern,
*IF NOT $true(osv$unix)
          clc$time_increment, clc$time_zone, clc$type_specification =
*ELSE
          clc$time_increment, clc$time_zone, clc$type_specification, clc$unix_file =
*IFEND
      bad_data_value_type;
    ELSE
      bad_data_value;
    CASEND;

  PROCEND clp$convert_value_to_clt$value;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$convert_value_to_var_value', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$convert_value_to_var_value
    (    data_value: ^clt$data_value;
         max_string_size: clt$string_size;
     VAR variable_value: clt$variable_value;
     VAR status: ost$status);

    VAR
      element: ^clt$data_value,
      element_index: clt$array_bound,
      first_element_kind: clt$data_kind,
      local_max_string_size: ost$string_size,
      lower_bound: clt$array_bound,
      string_value_record: ^record
        size: ost$string_size,
        value: string ( * ),
      recend,
      string_value_seq: ^SEQ ( * ),
      upper_bound: clt$array_bound,
      variable_value_allocated: boolean,
      work_area: ^^clt$work_area;

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

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


      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          bad_data_value;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          bad_data_value;
        IFEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? TITLE := 'bad_data_value', EJECT ??

    PROCEDURE bad_data_value;


      osp$set_status_abnormal ('CL', cle$bad_data_value, '', status);
      EXIT clp$convert_value_to_var_value;

    PROCEND bad_data_value;
?? TITLE := 'bad_data_value_type', EJECT ??

    PROCEDURE bad_data_value_type;


      IF element^.kind = clc$deferred THEN
        osp$set_status_abnormal ('CL', cle$not_supported, '', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'DEFERRED value', status);
      ELSE
        osp$set_status_abnormal ('CL', cle$unexpected_value_type, '', status);
        clp$append_status_value_type (osc$status_parameter_delimiter, element, status);
      IFEND;
      EXIT clp$convert_value_to_var_value;

    PROCEND bad_data_value_type;
?? TITLE := 'work_area_overflow', EJECT ??

    PROCEDURE work_area_overflow;


      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      EXIT clp$convert_value_to_var_value;

    PROCEND work_area_overflow;
?? TITLE := 'allocate_variable_value', EJECT ??

    PROCEDURE [INLINE] allocate_variable_value;


      first_element_kind := element^.kind;
      CASE element^.kind OF
      = clc$boolean =
        variable_value.kind := clc$boolean_value;
        NEXT variable_value.boolean_value: [1 .. (upper_bound - lower_bound + 1)] IN work_area^;
        IF variable_value.boolean_value = NIL THEN
          work_area_overflow;
        IFEND;
      = clc$integer =
        variable_value.kind := clc$integer_value;
        NEXT variable_value.integer_value: [1 .. (upper_bound - lower_bound + 1)] IN work_area^;
        IF variable_value.integer_value = NIL THEN
          work_area_overflow;
        IFEND;
      = clc$real =
        variable_value.kind := clc$real_value;
        NEXT variable_value.real_value: [1 .. (upper_bound - lower_bound + 1)] IN work_area^;
        IF variable_value.real_value = NIL THEN
          work_area_overflow;
        IFEND;
      = clc$status =
        variable_value.kind := clc$status_value;
        NEXT variable_value.status_value: [1 .. (upper_bound - lower_bound + 1)] IN work_area^;
        IF variable_value.status_value = NIL THEN
          work_area_overflow;
        IFEND;
      = clc$string =
        variable_value.kind := clc$string_value;
        variable_value.max_string_size := local_max_string_size;
        NEXT variable_value.string_value: [1 .. ((upper_bound - lower_bound + 1) *
              (local_max_string_size + #SIZE (ost$string_size)))] IN work_area^;
        IF variable_value.string_value = NIL THEN
          work_area_overflow;
        IFEND;
        string_value_seq := #SEQ (variable_value.string_value^);
        RESET string_value_seq;
      = clc$array, clc$cobol_name, clc$command_reference, clc$data_name, clc$date_time, clc$deferred,
            clc$entry_point_reference, clc$keyword, clc$lock, clc$network_title, clc$program_name, clc$record,
            clc$scu_line_identifier, clc$statistic_code, clc$status_code, clc$string_pattern,
            clc$time_increment, clc$time_zone, clc$type_specification =
        bad_data_value_type;
      ELSE
        bad_data_value;
      CASEND;
      variable_value.descriptor := clv$value_descriptors [variable_value.kind];

    PROCEND allocate_variable_value;
?? TITLE := 'create_variable_value', EJECT ??

    PROCEDURE [INLINE] create_variable_value;


      CASE element^.kind OF
      = clc$boolean =
        convert_boolean_value;
      = clc$integer =
        convert_integer_value;
      = clc$real =
        convert_real_value;
      = clc$status =
        convert_status_value;
      = clc$string =
        convert_string_value;
      = clc$array, clc$cobol_name, clc$command_reference, clc$data_name, clc$date_time, clc$deferred,
            clc$entry_point_reference, clc$keyword, clc$lock, clc$network_title, clc$program_name, clc$record,
            clc$scu_line_identifier, clc$statistic_code, clc$status_code, clc$string_pattern,
            clc$time_increment, clc$time_zone, clc$type_specification =
        bad_data_value_type;
      ELSE
        bad_data_value;
      CASEND;

    PROCEND create_variable_value;
?? TITLE := 'convert_boolean_value', EJECT ??

    PROCEDURE [INLINE] convert_boolean_value;


      variable_value.boolean_value^ [element_index] := element^.boolean_value;

    PROCEND convert_boolean_value;
?? TITLE := 'convert_integer_value', EJECT ??

    PROCEDURE [INLINE] convert_integer_value;


      variable_value.integer_value^ [element_index] := element^.integer_value;

    PROCEND convert_integer_value;
?? TITLE := 'convert_real_value', EJECT ??

    PROCEDURE [INLINE] convert_real_value;


      variable_value.real_value^ [element_index] := element^.real_value;

    PROCEND convert_real_value;
?? TITLE := 'convert_status_value', EJECT ??

    PROCEDURE [INLINE] convert_status_value;


      clp$convert_to_clt$status (element^.status_value^, variable_value.status_value^ [element_index]);

    PROCEND convert_status_value;
?? TITLE := 'convert_string_value', EJECT ??

    PROCEDURE [INLINE] convert_string_value;

      VAR
        string_length: ost$string_size;


      IF STRLENGTH (element^.string_value^) > local_max_string_size THEN
        string_length := local_max_string_size;
      ELSE
        string_length := STRLENGTH (element^.string_value^);
      IFEND;
      NEXT string_value_record: [local_max_string_size] IN string_value_seq;
      string_value_record^.size := string_length;
      string_value_record^.value := element^.string_value^ (1, string_length);

    PROCEND convert_string_value;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    variable_value_allocated := FALSE;
    IF max_string_size <= osc$max_string_size THEN
      local_max_string_size := max_string_size;
    ELSE
      local_max_string_size := osc$max_string_size;
    IFEND;

*IF NOT $true(osv$unix)
    clp$get_work_area (#RING (^work_area), work_area, status);
*ELSE
    clp$get_work_area (osc$user_ring, work_area, status);
*IFEND
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^abort_handler, FALSE);

    IF data_value^.kind <> clc$array THEN
      lower_bound := 1;
      upper_bound := 1;
      element_index := 1;
      element := data_value;
      allocate_variable_value;
      create_variable_value;
      RETURN;
    IFEND;

    lower_bound := LOWERBOUND (data_value^.array_value^);
    upper_bound := UPPERBOUND (data_value^.array_value^);

    FOR element_index := 1 TO (upper_bound - lower_bound + 1) DO

      element := data_value^.array_value^ [element_index + lower_bound - 1];
      IF NOT variable_value_allocated THEN
        allocate_variable_value;
        variable_value_allocated := TRUE;
      ELSEIF element^.kind <> first_element_kind THEN
        bad_data_value;
      IFEND;

      create_variable_value;

    FOREND;

  PROCEND clp$convert_value_to_var_value;
?? TITLE := 'clp$convert_var_value_to_value', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$convert_var_value_to_value
    (    variable_value: clt$variable_value;
         array_variable: boolean;
         lower_bound: clt$variable_dimension;
         upper_bound: clt$variable_dimension;
     VAR work_area {input, output} : ^clt$work_area;
     VAR data_value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      osv$status_value: ost$status,
      p_string: ^ost$string,
      string_size: ost$string_size;

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

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


      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          bad_value;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          bad_value;
        IFEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? TITLE := 'bad_value', EJECT ??

    PROCEDURE bad_value;


      osp$set_status_abnormal ('CL', cle$bad_clt$variable_value, '', status);
      EXIT clp$convert_var_value_to_value;

    PROCEND bad_value;
?? TITLE := 'work_area_overflow', EJECT ??

    PROCEDURE work_area_overflow;


      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      EXIT clp$convert_var_value_to_value;

    PROCEND work_area_overflow;
?? TITLE := 'convert_boolean_variable', EJECT ??

    PROCEDURE [INLINE] convert_boolean_variable;

      VAR
        i: clt$array_bound;


      IF (LOWERBOUND (variable_value.boolean_value^) <> 1) OR
            (UPPERBOUND (variable_value.boolean_value^) <> (upper_bound - lower_bound + 1)) THEN
        bad_value;
      IFEND;
      FOR i := lower_bound TO upper_bound DO
        clp$make_clt$boolean_value (variable_value.boolean_value^ [i - lower_bound + 1], work_area,
              data_value^.array_value^ [i]);
      FOREND;

    PROCEND convert_boolean_variable;
?? TITLE := 'convert_integer_variable', EJECT ??

    PROCEDURE [INLINE] convert_integer_variable;

      VAR
        i: clt$array_bound;


      IF (LOWERBOUND (variable_value.integer_value^) <> 1) OR
            (UPPERBOUND (variable_value.integer_value^) <> (upper_bound - lower_bound + 1)) THEN
        bad_value;
      IFEND;
      FOR i := lower_bound TO upper_bound DO
        clp$make_clt$integer_value (variable_value.integer_value^ [i - lower_bound + 1], work_area,
              data_value^.array_value^ [i]);
      FOREND;

    PROCEND convert_integer_variable;
?? TITLE := 'convert_real_variable', EJECT ??

    PROCEDURE [INLINE] convert_real_variable;

      VAR
        i: clt$array_bound;


      IF (LOWERBOUND (variable_value.real_value^) <> 1) OR
            (UPPERBOUND (variable_value.real_value^) <> (upper_bound - lower_bound + 1)) THEN
        bad_value;
      IFEND;
      FOR i := lower_bound TO upper_bound DO
        clp$make_clt$real_value (variable_value.real_value^ [i - lower_bound + 1], work_area,
              data_value^.array_value^ [i]);
      FOREND;

    PROCEND convert_real_variable;
?? TITLE := 'convert_status_variable', EJECT ??

    PROCEDURE [INLINE] convert_status_variable;

      VAR
        i: clt$array_bound,
        osv$status_value: ost$status;


      IF (LOWERBOUND (variable_value.status_value^) <> 1) OR
            (UPPERBOUND (variable_value.status_value^) <> (upper_bound - lower_bound + 1)) THEN
        bad_value;
      IFEND;
      FOR i := lower_bound TO upper_bound DO
        clp$convert_to_ost$status (variable_value.status_value^ [i - lower_bound + 1], osv$status_value);
        clp$make_status_value (osv$status_value, work_area, data_value^.array_value^ [i]);
      FOREND;

    PROCEND convert_status_variable;
?? TITLE := 'convert_string_variable', EJECT ??

    PROCEDURE [INLINE] convert_string_variable;

      VAR
        i: clt$array_bound,
        p_string: ^ost$string,
        string_element_size: integer,
        string_size: ost$string_size;


      string_element_size := #SIZE (ost$string_size) + variable_value.max_string_size;
      IF (LOWERBOUND (variable_value.string_value^) <> 1) OR
            (UPPERBOUND (variable_value.string_value^) <> ((upper_bound - lower_bound + 1) *
            string_element_size)) THEN
        bad_value;
      IFEND;
      FOR i := lower_bound TO upper_bound DO
        p_string := #LOC (variable_value.string_value^ [((i - lower_bound) * string_element_size) + 1]);
        IF p_string^.size <= variable_value.max_string_size THEN
          string_size := p_string^.size;
        ELSE
          string_size := 0;
        IFEND;
        clp$make_string_value (p_string^.value (1, string_size), work_area, data_value^.array_value^ [i]);
      FOREND;

    PROCEND convert_string_variable;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    IF array_variable THEN
      clp$make_array_value (lower_bound, upper_bound, work_area, data_value);
      IF data_value = NIL THEN
        work_area_overflow;
        RETURN;
      IFEND;

      CASE variable_value.kind OF
      = clc$boolean_value =
        convert_boolean_variable;
      = clc$integer_value =
        convert_integer_variable;
      = clc$real_value =
        convert_real_variable;
      = clc$status_value =
        convert_status_variable;
      = clc$string_value =
        convert_string_variable;
      ELSE
        bad_value;
      CASEND;
    ELSE
      CASE variable_value.kind OF
      = clc$boolean_value =
        IF (LOWERBOUND (variable_value.boolean_value^) = 1) AND
              (UPPERBOUND (variable_value.boolean_value^) = 1) THEN
          clp$make_clt$boolean_value (variable_value.boolean_value^ [1], work_area, data_value);
        ELSE
          bad_value;
        IFEND;
      = clc$integer_value =
        IF (LOWERBOUND (variable_value.integer_value^) = 1) AND
              (UPPERBOUND (variable_value.integer_value^) = 1) THEN
          clp$make_clt$integer_value (variable_value.integer_value^ [1], work_area, data_value);
        ELSE
          bad_value;
        IFEND;
      = clc$real_value =
        IF (LOWERBOUND (variable_value.real_value^) = 1) AND (UPPERBOUND (variable_value.real_value^) =
              1) THEN
          clp$make_clt$real_value (variable_value.real_value^ [1], work_area, data_value);
        ELSE
          bad_value;
        IFEND;
      = clc$status_value =
        IF (LOWERBOUND (variable_value.status_value^) = 1) AND (UPPERBOUND (variable_value.status_value^) =
              1) THEN
          clp$convert_to_ost$status (variable_value.status_value^ [1], osv$status_value);
          clp$make_status_value (osv$status_value, work_area, data_value);
        ELSE
          bad_value;
        IFEND;
      = clc$string_value =
        IF (LOWERBOUND (variable_value.string_value^) = 1) AND
              (UPPERBOUND (variable_value.string_value^) = (#SIZE (ost$string_size) +
              variable_value.max_string_size)) THEN
          p_string := #LOC (variable_value.string_value^ [1]);
          IF p_string^.size <= variable_value.max_string_size THEN
            string_size := p_string^.size;
          ELSE
            string_size := 0;
          IFEND;
          clp$make_string_value (p_string^.value (1, string_size), work_area, data_value);
        ELSE
          bad_value;
        IFEND;
      ELSE
        bad_value;
      CASEND;
    IFEND;

  PROCEND clp$convert_var_value_to_value;
?? TITLE := 'clp$get_single_data_value', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$get_single_data_value
    (    value_set_number: 1 .. clc$max_value_sets;
         value_number: 1 .. clc$max_values_per_set;
         low_or_high: clt$low_or_high;
     VAR data_value {input, output} : ^clt$data_value;
     VAR status: ost$status);

    VAR
      element_value: ^clt$data_value;

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

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


      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          bad_data_value;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          bad_data_value;
        IFEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? TITLE := 'bad_data_value', EJECT ??

    PROCEDURE bad_data_value;


      osp$set_status_abnormal ('CL', cle$bad_data_value, '', status);
      EXIT clp$get_single_data_value;

    PROCEND bad_data_value;
?? TITLE := 'bad_data_value_type', EJECT ??

    PROCEDURE bad_data_value_type;


      IF element_value^.kind = clc$deferred THEN
        osp$set_status_abnormal ('CL', cle$not_supported, '', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'DEFERRED value', status);
      ELSE
        osp$set_status_abnormal ('CL', cle$unexpected_value_type, '', status);
        clp$append_status_value_type (osc$status_parameter_delimiter, element_value, status);
      IFEND;
      EXIT clp$get_single_data_value;

    PROCEND bad_data_value_type;
?? TITLE := 'interpret_list_value', EJECT ??

    PROCEDURE [INLINE] interpret_list_value;

      VAR
        current_node: ^clt$data_value,
        value_index: 0 .. clc$max_values_per_set,
        value_set_index: 0 .. clc$max_value_sets;


      current_node := element_value;
      element_value := NIL;
      value_set_index := 0;
      WHILE value_set_index < value_set_number DO
        IF current_node = NIL THEN
          RETURN;
        IFEND;
        IF current_node^.kind <> clc$list THEN
          bad_data_value;
        IFEND;
        element_value := current_node^.element_value;
        IF element_value <> NIL THEN
          value_set_index := value_set_index + 1;
        IFEND;
        current_node := current_node^.link;
      WHILEND;

      IF element_value = NIL THEN
        RETURN;
      ELSEIF element_value^.kind = clc$list THEN
        current_node := element_value;
        element_value := NIL;
        value_index := 0;
        WHILE value_index < value_number DO
          IF current_node = NIL THEN
            RETURN;
          IFEND;
          IF current_node^.kind <> clc$list THEN
            bad_data_value;
          IFEND;
          element_value := current_node^.element_value;
          IF element_value <> NIL THEN
            value_index := value_index + 1;
          IFEND;
          current_node := current_node^.link;
        WHILEND;
      ELSEIF value_number <> 1 THEN
        RETURN;
      IFEND;

      IF element_value = NIL THEN
        RETURN;
      ELSEIF element_value^.kind = clc$range THEN
        IF low_or_high = clc$high THEN
          element_value := element_value^.high_value;
        ELSE
          element_value := element_value^.low_value;
        IFEND;
        IF element_value = NIL THEN
          RETURN;
        IFEND;
      IFEND;
      data_value := element_value;

    PROCEND interpret_list_value;
?? TITLE := 'interpret_range_value', EJECT ??

    PROCEDURE [INLINE] interpret_range_value;


      IF low_or_high = clc$high THEN
        data_value := element_value^.high_value;
      ELSE
        data_value := element_value^.low_value;
      IFEND;

    PROCEND interpret_range_value;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    osp$establish_condition_handler (^abort_handler, FALSE);

    element_value := data_value;
    IF element_value = NIL THEN
      RETURN;
    IFEND;
    data_value := NIL;

    IF ((value_set_number <> 1) OR (value_number <> 1)) AND (element_value^.kind <> clc$list) THEN
      RETURN;
    IFEND;

    CASE element_value^.kind OF
*IF NOT $true(osv$unix)
    = clc$application, clc$boolean, clc$file, clc$integer, clc$keyword, clc$name, clc$real, clc$status,
*ELSE
    = clc$application, clc$boolean, clc$nos_ve_file, clc$integer, clc$keyword, clc$name, clc$real, clc$status,
*IFEND
          clc$string =
      IF (value_set_number = 1) AND (value_number = 1) THEN
        data_value := element_value;
      IFEND;
    = clc$list =
      interpret_list_value;
    = clc$range =
      IF (value_set_number = 1) AND (value_number = 1) THEN
        interpret_range_value;
      IFEND;
    = clc$unspecified =
      ;
    = clc$array, clc$cobol_name, clc$command_reference, clc$data_name, clc$date_time, clc$deferred,
          clc$entry_point_reference, clc$lock, clc$network_title, clc$program_name, clc$record,
          clc$scu_line_identifier, clc$statistic_code, clc$status_code, clc$string_pattern,
*IF NOT $true(osv$unix)
          clc$time_increment, clc$time_zone, clc$type_specification =
*ELSE
          clc$time_increment, clc$time_zone, clc$type_specification, clc$unix_file =
*IFEND
      bad_data_value_type;
    ELSE
      bad_data_value;
    CASEND;

  PROCEND clp$get_single_data_value;
?? TITLE := 'clp$get_single_internal_value', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$get_single_internal_value
    (    internal_value: ^clt$internal_data_value;
         value_set_number: 1 .. clc$max_value_sets;
         value_number: 1 .. clc$max_values_per_set;
         low_or_high: clt$low_or_high;
     VAR internal_component {input, output} : REL (clt$internal_data_value) ^clt$i_data_value;
     VAR status: ost$status);

    VAR
      i_value: ^clt$i_data_value;

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

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


      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          bad_internal_value;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          bad_internal_value;
        IFEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? TITLE := 'bad_internal_value', EJECT ??

    PROCEDURE bad_internal_value;


      osp$set_status_abnormal ('CL', cle$bad_internal_value, '', status);
      EXIT clp$get_single_internal_value;

    PROCEND bad_internal_value;
?? TITLE := 'bad_internal_value_type', EJECT ??

    PROCEDURE bad_internal_value_type;


      IF i_value^.kind = clc$deferred THEN
        osp$set_status_abnormal ('CL', cle$not_supported, '', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'DEFERRED value', status);
      ELSE
        osp$set_status_abnormal ('CL', cle$unexpected_value_type, '', status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              clv$type_kind_names [clv$value_type_kinds [i_value^.kind]], status);
      IFEND;
      EXIT clp$get_single_internal_value;

    PROCEND bad_internal_value_type;
?? TITLE := 'interpret_list_value', EJECT ??

    PROCEDURE [INLINE] interpret_list_value;

      VAR
        current_node: ^clt$i_data_value,
        value_index: 0 .. clc$max_values_per_set,
        value_set_index: 0 .. clc$max_value_sets;


      current_node := i_value;
      i_value := NIL;
      value_set_index := 0;
      WHILE value_set_index < value_set_number DO
        IF current_node = NIL THEN
          RETURN;
        IFEND;
        IF current_node^.kind <> clc$list THEN
          bad_internal_value;
        IFEND;
        i_value := #PTR (current_node^.element_value, internal_value^);
        IF i_value <> NIL THEN
          value_set_index := value_set_index + 1;
        IFEND;
        current_node := #PTR (current_node^.link, internal_value^);
      WHILEND;

      IF i_value = NIL THEN
        RETURN;
      ELSEIF i_value^.kind = clc$list THEN
        current_node := i_value;
        i_value := NIL;
        value_index := 0;
        WHILE value_index < value_number DO
          IF current_node = NIL THEN
            RETURN;
          IFEND;
          IF current_node^.kind <> clc$list THEN
            bad_internal_value;
          IFEND;
          i_value := #PTR (current_node^.element_value, internal_value^);
          IF i_value <> NIL THEN
            value_index := value_index + 1;
          IFEND;
          current_node := #PTR (current_node^.link, internal_value^);
        WHILEND;
      ELSEIF value_number <> 1 THEN
        RETURN;
      IFEND;

      IF i_value = NIL THEN
        RETURN;
      ELSEIF i_value^.kind = clc$range THEN
        IF low_or_high = clc$high THEN
          i_value := #PTR (i_value^.high_value, internal_value^);
        ELSE
          i_value := #PTR (i_value^.low_value, internal_value^);
        IFEND;
        IF i_value = NIL THEN
          RETURN;
        IFEND;
      IFEND;
      internal_component := #REL (i_value, internal_value^);

    PROCEND interpret_list_value;
?? TITLE := 'interpret_range_value', EJECT ??

    PROCEDURE [INLINE] interpret_range_value;


      IF low_or_high = clc$high THEN
        internal_component := i_value^.high_value;
      ELSE
        internal_component := i_value^.low_value;
      IFEND;

    PROCEND interpret_range_value;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    osp$establish_condition_handler (^abort_handler, FALSE);

    i_value := #PTR (internal_component, internal_value^);

    IF ((value_set_number <> 1) OR (value_number <> 1)) AND (i_value^.kind <> clc$list) THEN
      RETURN;
    IFEND;

    CASE i_value^.kind OF
*IF NOT $true(osv$unix)
    = clc$application, clc$boolean, clc$file, clc$integer, clc$keyword, clc$name, clc$real, clc$status,
*ELSE
    = clc$application, clc$boolean, clc$nos_ve_file, clc$integer, clc$keyword, clc$name, clc$real, clc$status,
*IFEND
          clc$string =
      IF (value_set_number = 1) AND (value_number = 1) THEN
        internal_component := #REL (i_value, internal_value^);
      IFEND;
    = clc$list =
      interpret_list_value;
    = clc$range =
      IF (value_set_number = 1) AND (value_number = 1) THEN
        interpret_range_value;
      IFEND;
    = clc$unspecified =
      ;
    = clc$array, clc$cobol_name, clc$command_reference, clc$data_name, clc$date_time, clc$deferred,
          clc$entry_point_reference, clc$lock, clc$network_title, clc$program_name, clc$record,
          clc$scu_line_identifier, clc$statistic_code, clc$status_code, clc$string_pattern,
*IF NOT $true(osv$unix)
          clc$time_increment, clc$time_zone, clc$type_specification =
*ELSE
          clc$time_increment, clc$time_zone, clc$type_specification, clc$unix_file =
*IFEND
      bad_internal_value_type;
    ELSE
      bad_internal_value;
    CASEND;

  PROCEND clp$get_single_internal_value;
*IFEND

MODEND clm$clt$value_conversion;
*DECK DECK=CLM$COLLECT_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Collect Commands' ??
MODULE clm$collect_commands;

{
{ PURPOSE:
{   This module contains the procedures that collect commands from the current command file onto a
{   specified file.  Both external and internal versions of this facility are available.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_command_processing
*copyc cle$unexpected_call_to
*copyc clk$collect_commands
*copyc clt$command_line_index
*copyc clt$input_data_line_header
*copyc clt$lexical_unit_kinds
*copyc clt$substitution_mark
*copyc fst$file_reference
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc amp$put_next
*copyc amv$nil_file_identifier
*copyc clp$find_input_block
*copyc clp$get_collect_text_cmnd_info
*copyc clp$get_command_line
*copyc clp$get_line_from_command_file
*copyc clp$get_work_area
*copyc clp$identify_lexical_units
*copyc clp$internal_evaluate_sub_param
*copyc clp$parse_command
*copyc clp$scan_any_lexical_unit
*copyc clp$scan_unnested_cmnd_lex_unit
*copyc clp$set_input_line_finished
*copyc clp$set_input_line_parse
*copyc clp$substitute_delimited_text
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper

?? TITLE := 'clp$collect_commands', EJECT ??
*copyc clh$collect_commands

  PROCEDURE [XDCL, #GATE] clp$collect_commands
    (    file: fst$file_reference;
         terminator: ost$name;
     VAR status: ost$status);

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

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


      fsp$close_file (file_id, handler_status);
      handler_status.normal := TRUE;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      block: ^clt$block,
      collect_text_info: clt$collect_text_command_info,
      collect_text_prompt: ^clt$prompt_string,
      collect_text_pvt: ^clt$parameter_value_table,
      command_parse: clt$parse_state,
      empty_command: boolean,
      end_index: clt$command_line_index,
      end_of_input: boolean,
      file_attachment: array [1 .. 3] of fst$attachment_option,
      file_id: amt$file_identifier,
      first_line: boolean,
      form: clt$command_reference_form,
      ignore_byte_address: amt$file_byte_address,
      ignore_command_ref_parse: clt$parse_state,
      ignore_escaped: boolean,
      ignore_file: clt$file,
      ignore_label: ost$name,
      ignore_prompting_requested: boolean,
      ignore_util_command_list_entry: ^clt$command_list_entry,
      line: ^clt$command_line,
      line_size: clt$command_line_size,
      local_status: ost$status,
      name: clt$name,
      parse: clt$parse_state,
      saved_work_area: ^clt$work_area,
      separator: clt$lexical_unit_kind,
      start_index: clt$command_line_index,
      translated_terminator: ost$name,
      until_string: ^clt$command_line,
      write_line: boolean,
      work_area: ^^clt$work_area;


    #KEYPOINT (osk$entry, 0, clk$collect_commands);

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

  /collect_commands/
    BEGIN
      clp$find_input_block (TRUE, block);
      IF block = NIL THEN
        osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$collect_commands', status);
        EXIT /collect_commands/;
      IFEND;

      file_id := amv$nil_file_identifier;
      #SPOIL (file_id);
      osp$establish_block_exit_hndlr (^abort_handler);

      file_attachment [1].selector := fsc$access_and_share_modes;
      file_attachment [1].access_modes.selector := fsc$specific_access_modes;
      file_attachment [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
      file_attachment [1].share_modes.selector := fsc$specific_share_modes;
      file_attachment [1].share_modes.value := $fst$file_access_options [];
      file_attachment [2].selector := fsc$access_and_share_modes;
      file_attachment [2].access_modes.selector := fsc$specific_access_modes;
      file_attachment [2].access_modes.value := $fst$file_access_options [fsc$append];
      file_attachment [2].share_modes.selector := fsc$specific_share_modes;
      file_attachment [2].share_modes.value := $fst$file_access_options [];
      file_attachment [3].selector := fsc$open_share_modes;
      file_attachment [3].open_share_modes := -$fst$file_access_options [];

      fsp$open_file (file, amc$record, ^file_attachment, NIL, NIL, NIL, NIL, file_id, local_status);
      IF NOT local_status.normal THEN
        status := local_status;
        EXIT /collect_commands/;
      IFEND;

      clp$get_work_area (#RING (^work_area), work_area, local_status);
      IF NOT local_status.normal THEN
        status := local_status;
        EXIT /collect_commands/;
      IFEND;

      #TRANSLATE (osv$lower_to_upper, terminator, translated_terminator);

      collect_text_pvt := NIL;
      until_string := NIL;

      first_line := TRUE;
      end_of_input := FALSE;
      parse := block^.line_parse;
      line := parse.text;
      start_index := parse.unit_index;
      end_index := start_index;

    /loop/
      WHILE TRUE DO
        IF parse.unit.kind = clc$lex_end_of_line THEN

          line_size := end_index - start_index;
          IF write_line AND ((line_size > 0) OR (NOT first_line)) THEN
            amp$put_next (file_id, ^line^ (start_index), line_size, ignore_byte_address, local_status);
            IF NOT local_status.normal THEN
              write_line := FALSE;
              IF status.normal THEN
                status := local_status;
              IFEND;
            IFEND;
          IFEND;

          IF until_string <> NIL THEN
            REPEAT
              saved_work_area := work_area^;
              clp$get_line_from_command_file (collect_text_prompt^, line, local_status);
              work_area^ := saved_work_area;
              IF NOT local_status.normal THEN
                IF status.normal THEN
                  status := local_status;
                IFEND;
                EXIT /loop/;
              ELSEIF line = NIL THEN
                end_of_input := TRUE;
                IF status.normal THEN
                  osp$set_status_abnormal ('CL', cle$unbalanced_block_structure, 'end_of_input', status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, until_string^, status);
                IFEND;
                EXIT /loop/;
              IFEND;
              amp$put_next (file_id, line, STRLENGTH (line^), ignore_byte_address, local_status);
              IF NOT local_status.normal THEN
                write_line := FALSE;
                IF status.normal THEN
                  status := local_status;
                IFEND;
              IFEND;
            UNTIL line^ = until_string^;
            until_string := NIL;
          IFEND;

          saved_work_area := work_area^;
          clp$get_command_line (parse, end_of_input, local_status);
          work_area^ := saved_work_area;
          IF NOT local_status.normal THEN
            IF status.normal THEN
              status := local_status;
            IFEND;
            EXIT /loop/;
          ELSEIF end_of_input THEN
            EXIT /loop/;
          ELSEIF parse.unit.kind = clc$lex_beginning_of_line THEN
            clp$scan_any_lexical_unit (parse);
          IFEND;
          first_line := FALSE;
          line := parse.text;
          start_index := 1;
          end_index := 1;
        IFEND;

        command_parse := parse;
        clp$scan_unnested_cmnd_lex_unit (parse);
        command_parse.index_limit := parse.unit_index;
        IF parse.unit.kind = clc$lex_semicolon THEN
          clp$scan_any_lexical_unit (parse);
        IFEND;

        saved_work_area := work_area^;
        clp$parse_command (command_parse, ignore_prompting_requested, ignore_escaped, ignore_label,
              ignore_command_ref_parse, ignore_file, form, name, ignore_util_command_list_entry, separator,
              empty_command, local_status);
        work_area^ := saved_work_area;

        IF local_status.normal AND (NOT empty_command) AND (form = clc$name_only_command_ref) AND
              (separator <> clc$lex_equal) THEN

          IF (name.value = translated_terminator) AND (separator IN $clt$lexical_unit_kinds
                [clc$lex_semicolon, clc$lex_end_of_line]) THEN
            line_size := end_index - start_index;
            IF write_line AND (line_size > 0) THEN
              amp$put_next (file_id, ^line^ (start_index), line_size, ignore_byte_address, local_status);
              IF NOT local_status.normal THEN
                IF status.normal THEN
                  status := local_status;
                IFEND;
              IFEND;
            IFEND;
            EXIT /loop/;

          ELSEIF (name.value = 'COLLECT_TEXT') OR (name.value = 'COLT') THEN
            IF collect_text_pvt = NIL THEN
              clp$get_collect_text_cmnd_info (collect_text_info);
              PUSH collect_text_pvt: [1 .. collect_text_info.number_of_parameters];
              PUSH collect_text_prompt: [block^.input.base_prompt_string.size];
              IF STRLENGTH (collect_text_prompt^) > 0 THEN
                collect_text_prompt^ := block^.input.base_prompt_string.value (2, * );
                collect_text_prompt^ (STRLENGTH (collect_text_prompt^)) := '?';
              IFEND;
            IFEND;
            saved_work_area := work_area^;
            clp$internal_evaluate_sub_param (command_parse, collect_text_info.pdt, work_area^,
                  collect_text_pvt, local_status);
            IF NOT collect_text_pvt^ [collect_text_info.input_parameter_number].specified THEN
{
{ An input parameter was not specified.
{
              IF collect_text_pvt^ [collect_text_info.until_parameter_number].specified THEN
                IF collect_text_pvt^ [collect_text_info.until_parameter_number].value <> NIL THEN
{
{ An until string was specified and could be evaluated.
{
                  PUSH until_string: [STRLENGTH (collect_text_pvt^ [collect_text_info.until_parameter_number].
                        value^.string_value^)];
                  until_string^ := collect_text_pvt^ [collect_text_info.until_parameter_number].value^.
                        string_value^;
                ELSE
{
{ An until string was specified but could NOT be evaluated.
{
                  status := local_status;
                  EXIT /loop/;
                IFEND;
              ELSE
{
{ An until string was not specified.  The default is assumed.
{
                until_string := collect_text_info.default_until_string;
              IFEND;
            IFEND;
            work_area^ := saved_work_area;
          IFEND;

        IFEND;
        end_index := parse.unit_index;
      WHILEND /loop/;

      IF NOT end_of_input THEN
        IF until_string <> NIL THEN
          clp$set_input_line_finished;
        ELSE
          clp$set_input_line_parse (parse);
        IFEND;
      IFEND;

      fsp$close_file (file_id, local_status);
      IF (NOT local_status.normal) AND status.normal THEN
        status := local_status;
      IFEND;
    END /collect_commands/;

    osp$disestablish_cond_handler;

    #KEYPOINT (osk$exit, 0, clk$collect_commands);

  PROCEND clp$collect_commands;
?? TITLE := 'clp$collect_statement', EJECT ??
{
{ PURPOSE:
{   This procedure is used to collect commands within "structured statements" such WHEN/WHENEND.
{   Collection is terminated when an END_NAME is encounterred which balances the BEGIN_NAME that
{   is presumed to have called this procedure.
{

  PROCEDURE [XDCL] clp$collect_statement
    (    save_statement: boolean;
         begin_name: ost$name;
         end_name: ost$name;
         first_line_to_write: clt$command_line;
         substitution_mark: clt$substitution_mark;
     VAR work_area {input, output} : ^clt$work_area;
     VAR statement_area: ^clt$collect_statement_area;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      collect_statement_area: ^clt$collect_statement_area,
      collect_text_info: clt$collect_text_command_info,
      collect_text_prompt: ^clt$prompt_string,
      collect_text_pvt: ^clt$parameter_value_table,
      collect_the_statement: boolean,
      command_index: clt$command_line_index,
      command_parse: clt$parse_state,
      empty_command: boolean,
      end_index: clt$command_line_index,
      end_of_input: boolean,
      first_line: boolean,
      form: clt$command_reference_form,
      ignore_command_ref_parse: clt$parse_state,
      ignore_escaped: boolean,
      ignore_file: clt$file,
      ignore_label: ost$name,
      ignore_prompting_requested: boolean,
      ignore_util_command_list_entry: ^clt$command_list_entry,
      lexical_units: ^clt$lexical_units,
      line: ^clt$command_line,
      line_size: clt$command_line_size,
      local_status: ost$status,
      name: clt$name,
      new_line: ^clt$command_line,
      parse: clt$parse_state,
      save_lexical_units: boolean,
      saved_work_area: ^clt$work_area,
      separator: clt$lexical_unit_kind,
      start_index: clt$command_line_index,
      statement_area_size: integer,
      statement_level: integer,
      until_string: ^clt$command_line;

?? NEWTITLE := 'collect_line', EJECT ??

    PROCEDURE [INLINE] collect_line;

      VAR
        collected_lexical_units: ^clt$lexical_units,
        collected_line: ^clt$command_line,
        header: ^clt$input_data_line_header;


      NEXT header IN work_area;
      header^.line_size := line_size;
      NEXT collected_line: [line_size] IN work_area;
      collected_line^ (1, line_size) := line^ (start_index, line_size);
      statement_area_size := statement_area_size + #SIZE (header^) + #SIZE (collected_line^);

      IF NOT save_lexical_units THEN
        header^.number_of_lexical_units := 0;
      ELSE
        IF lexical_units <> NIL THEN
          NEXT collected_lexical_units: [1 .. UPPERBOUND (lexical_units^)] IN work_area;
          collected_lexical_units^ := lexical_units^;
        ELSE
          clp$identify_lexical_units (collected_line, work_area, collected_lexical_units, local_status);
          IF NOT local_status.normal THEN
            collect_the_statement := FALSE;
            IF status.normal THEN
              status := local_status;
            IFEND;
            RETURN;
          IFEND;
        IFEND;
        header^.number_of_lexical_units := UPPERBOUND (collected_lexical_units^);
        statement_area_size := statement_area_size + #SIZE (collected_lexical_units^);
      IFEND;

      header^.size_of_component_lines_data := 0;

    PROCEND collect_line;
?? TITLE := 'perform_substitution', EJECT ??

    PROCEDURE [INLINE] perform_substitution;

      VAR
        new_line_size: clt$command_line_size;


      clp$substitute_delimited_text (line^ (1, line_size), substitution_mark.value, new_line^, new_line_size,
            local_status);
      IF NOT local_status.normal THEN
        collect_the_statement := FALSE;
        IF status.normal THEN
          status := local_status;
        IFEND;
        RETURN;
      IFEND;

      IF (new_line_size <> line_size) OR (new_line^ (1, line_size) <> line^ (1, line_size)) THEN
        line := ^new_line^ (1, new_line_size);
        line_size := new_line_size;
        lexical_units := NIL;
      IFEND;

    PROCEND perform_substitution;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$find_input_block (TRUE, block);
    IF block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$collect_statement', status);
      statement_area := NIL;
      RETURN;
    IFEND;

    collect_the_statement := save_statement;
    save_lexical_units := save_statement AND (begin_name <> 'JOB');

    IF collect_the_statement THEN
      collect_statement_area := work_area;
      statement_area_size := 0;
      IF STRLENGTH (first_line_to_write) > 0 THEN
        line := ^first_line_to_write;
        line_size := STRLENGTH (line^);
        lexical_units := NIL;
        collect_line;
      IFEND;
      IF substitution_mark.specified THEN
        PUSH new_line: [clc$max_command_line_size];
      IFEND;
    IFEND;

    collect_text_pvt := NIL;
    until_string := NIL;

    first_line := TRUE;
    end_of_input := FALSE;
    parse := block^.line_parse;
    line := parse.text;
    start_index := parse.unit_index;
    end_index := start_index;
    statement_level := 1;

  /loop/
    WHILE TRUE DO
      IF parse.unit.kind = clc$lex_end_of_line THEN

        line_size := end_index - start_index;
        IF collect_the_statement AND ((line_size > 0) OR (NOT first_line)) THEN
          IF (line = parse.text) AND (start_index = 1) AND (line_size = STRLENGTH (line^)) THEN
            lexical_units := parse.units_array;
          ELSE
            lexical_units := NIL;
          IFEND;
          IF substitution_mark.specified THEN
            perform_substitution;
          IFEND;
          collect_line;
        IFEND;

        IF until_string <> NIL THEN
          save_lexical_units := FALSE;
          start_index := 1;
          REPEAT
            saved_work_area := work_area;
            clp$get_line_from_command_file (collect_text_prompt^, line, local_status);
            work_area := saved_work_area;
            IF NOT local_status.normal THEN
              IF status.normal THEN
                status := local_status;
              IFEND;
              EXIT /loop/;
            ELSEIF line = NIL THEN
              end_of_input := TRUE;
              osp$set_status_abnormal ('CL', cle$unbalanced_block_structure, 'end_of_input', status);
              osp$append_status_parameter (osc$status_parameter_delimiter, until_string^, status);
              EXIT /loop/;
            IFEND;
            start_index := 1;
            line_size := STRLENGTH (line^);
            IF substitution_mark.specified THEN
              perform_substitution;
            IFEND;
            collect_line;
          UNTIL line^ = until_string^;
          until_string := NIL;
          save_lexical_units := save_statement AND (begin_name <> 'JOB');
        IFEND;

        saved_work_area := work_area;
        clp$get_command_line (parse, end_of_input, local_status);
        work_area := saved_work_area;
        IF NOT local_status.normal THEN
          IF status.normal THEN
            status := local_status;
          IFEND;
          EXIT /loop/;
        ELSEIF end_of_input THEN
          osp$set_status_abnormal ('CL', cle$unbalanced_block_structure, 'end_of_input', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, end_name, status);
          EXIT /loop/;
        ELSEIF parse.unit.kind = clc$lex_beginning_of_line THEN
          clp$scan_any_lexical_unit (parse);
        IFEND;
        first_line := FALSE;
        line := parse.text;
        start_index := 1;
        end_index := 1;
      IFEND;

      command_parse := parse;
      command_index := parse.unit_index;
      clp$scan_unnested_cmnd_lex_unit (parse);
      command_parse.index_limit := parse.unit_index;
      IF parse.unit.kind = clc$lex_semicolon THEN
        clp$scan_any_lexical_unit (parse);
      IFEND;
      end_index := parse.unit_index;

      saved_work_area := work_area;
      clp$parse_command (command_parse, ignore_prompting_requested, ignore_escaped, ignore_label,
            ignore_command_ref_parse, ignore_file, form, name, ignore_util_command_list_entry, separator,
            empty_command, local_status);
      work_area := saved_work_area;

      IF local_status.normal AND (NOT empty_command) AND (form = clc$name_only_command_ref) AND
            (separator <> clc$lex_equal) THEN

        IF name.value = begin_name THEN
          statement_level := statement_level + 1;

        ELSEIF name.value = end_name THEN
          statement_level := statement_level - 1;
          IF statement_level <= 0 THEN

            IF collect_the_statement AND (begin_name = 'JOB') THEN
              PUSH new_line: [command_index + 6 - 1];
              new_line^ (1, command_index - 1) := line^ (1, command_index - 1);
              new_line^ (command_index, 6) := 'LOGOUT';
              line := new_line;
              end_index := command_index + 6;
            IFEND;

            IF collect_the_statement THEN
              line_size := end_index - start_index;
              IF (line = parse.text) AND (start_index = 1) AND (line_size = STRLENGTH (line^)) THEN
                lexical_units := parse.units_array;
              ELSE
                lexical_units := NIL;
              IFEND;
              IF substitution_mark.specified THEN
                perform_substitution;
              IFEND;
              collect_line;
            IFEND;

            EXIT /loop/;
          IFEND;

        ELSEIF (name.value = 'COLLECT_TEXT') OR (name.value = 'COLT') THEN
          saved_work_area := work_area;
          IF collect_text_pvt = NIL THEN
            clp$get_collect_text_cmnd_info (collect_text_info);
            PUSH collect_text_pvt: [1 .. collect_text_info.number_of_parameters];
            PUSH collect_text_prompt: [block^.input.base_prompt_string.size];
            IF STRLENGTH (collect_text_prompt^) > 0 THEN
              collect_text_prompt^ := block^.input.base_prompt_string.value (2, * );
              collect_text_prompt^ (STRLENGTH (collect_text_prompt^)) := '?';
            IFEND;
          IFEND;
          clp$internal_evaluate_sub_param (command_parse, collect_text_info.pdt, work_area, collect_text_pvt,
                local_status);
          IF NOT collect_text_pvt^ [collect_text_info.input_parameter_number].specified THEN
{
{ An input parameter was not specified.
{
            IF collect_text_pvt^ [collect_text_info.until_parameter_number].specified THEN
              IF collect_text_pvt^ [collect_text_info.until_parameter_number].value <> NIL THEN
{
{ An until string was specified and could be evaluated.
{
                PUSH until_string: [STRLENGTH (collect_text_pvt^ [collect_text_info.until_parameter_number].
                      value^.string_value^)];
                until_string^ := collect_text_pvt^ [collect_text_info.until_parameter_number].value^.
                      string_value^;
              ELSE
 {
{ An until string was specified but could NOT be evaluated.
{
               status := local_status;
                collect_the_statement := FALSE;
                EXIT /loop/;
              IFEND;
            ELSE
{
{ An until string was not specified.  The default is assumed.
{
              until_string := collect_text_info.default_until_string;
            IFEND;
          IFEND;
          work_area := saved_work_area;
        IFEND;

      IFEND;
    WHILEND /loop/;

    IF NOT end_of_input THEN
      IF until_string <> NIL THEN
        clp$set_input_line_finished;
      ELSE
        clp$set_input_line_parse (parse);
      IFEND;
    IFEND;

    IF collect_the_statement THEN
      work_area := collect_statement_area;
      NEXT statement_area: [[REP statement_area_size OF cell]] IN work_area;
      RESET statement_area;
    ELSE
      statement_area := NIL;
    IFEND;

  PROCEND clp$collect_statement;

MODEND clm$collect_commands;
*DECK DECK=CLM$COLLECT_TEXT_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Collect Text Command' ??
MODULE clm$collect_text_command;

{
{ PURPOSE:
{   This module contains the processor for the collect_text command.
{
{ NOTE:
{   The COLLECT_TEXT command processor is given control even in "skip" mode.
{   It always tries to read past the text even if it can't (or shouldn't)
{   write the text to the output file, including those cases where there's an
{   error with a parameter other than "until".
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc clt$collect_text_command_info
*copyc clt$parameter_list
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc amv$nil_file_identifier
*copyc clp$close_display
*copyc clp$change_colt_ruc_value
*copyc clp$evaluate_parameters
*copyc clp$find_caller_input_block
*copyc clp$get_command_origin
*copyc clp$get_interpreter_mode
*copyc clp$get_line_from_command_file
*copyc clp$open_display_reference
*copyc clp$pop_input
*copyc clp$push_input
*copyc clp$put_display
*copyc clp$substitute_delimited_text
*copyc clv$nil_block_handle
*copyc clv$nil_display_control
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_output_message
*copyc osp$get_status_condition_string
*copyc osp$set_status_abnormal
?? TITLE := 'Parameter Description Table (PDT) for the collect_text command', EJECT ??
{
{ * * * *   The PDT for COLLECT_TEXT is declared at the module level so that
{           it can be accessed by CLP$GET_COLLECT_TEXT_CMND_INFO as well as
{           CLP$_COLLECT_TEXT.
{
{ * * * *   NOTE: If this PDT must be regenerated, don't forget to move the
{                 declaration of the PVT variable into CLP$_COLLECT_TEXT.
{                 Failure to do so will result in an access violation when
{                 the command is called.
{
{ * * * *   NOTE: If the default value for the UNTIL parameter of COLLECT_TEXT
{                 is changed (an unimaginable idea), the following variable
{                 must be changed as well as the PDT.
{
  VAR
    clv$retain_unprintable_char: [XREF] boolean;
  VAR
    default_until_string: [STATIC, READ, oss$job_paged_literal] string (2) := '**';

{  PROCEDURE (osm$colt) collect_text, colt (
{    output, o: file = $required
{    until, u: string literal = '**'
{    prompt, p: string 0..31 = 'ct? '
{    substitution_mark, sm: any of
{        key
{          none
{        keyend
{        string 1
{      anyend = none
{    input, i: file = $optional
{    retain_unprintable_characters, ruc: boolean = csd$colt_ruc, FALSE
{    status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (4),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (6),
      recend,
      type4: 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$string_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
      type6: record
        header: clt$type_specification_header,
        default_name: string (12),
        default_value: string (5),
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [93, 11, 16, 5, 52, 1, 963],
    clc$command, 13, 7, 1, 0, 0, 0, 7, 'OSM$COLT'], [
    ['I                              ',clc$abbreviation_entry, 5],
    ['INPUT                          ',clc$nominal_entry, 5],
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['P                              ',clc$abbreviation_entry, 3],
    ['PROMPT                         ',clc$nominal_entry, 3],
    ['RETAIN_UNPRINTABLE_CHARACTERS  ',clc$nominal_entry, 6],
    ['RUC                            ',clc$abbreviation_entry, 6],
    ['SM                             ',clc$abbreviation_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 7],
    ['SUBSTITUTION_MARK              ',clc$nominal_entry, 4],
    ['U                              ',clc$abbreviation_entry, 2],
    ['UNTIL                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 4],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 6],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 72, clc$optional_default_parameter, 0, 4],
{ PARAMETER 5
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 12, 5],
{ PARAMETER 7
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [0, clc$max_string_size, TRUE],
    '''**'''],
{ PARAMETER 3
    [[1, 0, clc$string_type], [0, 31, FALSE],
    '''ct? '''],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$string_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [1, 1, FALSE]]
    ,
    'none'],
{ PARAMETER 5
    [[1, 0, clc$file_type]],
{ PARAMETER 6
    [[1, 0, clc$boolean_type],
    'CSD$COLT_RUC',
    'FALSE'],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

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

    CONST
      p$output = 1,
      p$until = 2,
      p$prompt = 3,
      p$substitution_mark = 4,
      p$input = 5,
      p$retain_unprintable_characters = 6,
      p$status = 7;

?? TITLE := 'clp$get_collect_text_cmnd_info', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$get_collect_text_cmnd_info
    (VAR collect_text_command_info: clt$collect_text_command_info);


    collect_text_command_info.pdt := #SEQ (pdt);
    collect_text_command_info.number_of_parameters := p$status;
    collect_text_command_info.until_parameter_number := p$until;
    collect_text_command_info.input_parameter_number := p$input;
    collect_text_command_info.default_until_string := ^default_until_string;

  PROCEND clp$get_collect_text_cmnd_info;
?? TITLE := 'clp$_collect_text', EJECT ??

  PROCEDURE [XDCL] clp$_collect_text
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

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

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

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


      clp$change_colt_ruc_value (FALSE, FALSE);
      clp$close_display (display_control, handler_status);
      IF input_block_handle <> clv$nil_block_handle THEN
        clp$pop_input (TRUE, input_block_handle, input_file_id, input_executable, NIL, handler_status);
      IFEND;
      handler_status.normal := TRUE;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      caller_in_current_task: boolean,
      caller_input_block: ^clt$block,
      default_input_file: [STATIC, READ, oss$job_paged_literal] string (8) := '$command',
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      ignore_status: ost$status,
      input_block_handle: clt$block_handle,
      input_executable: boolean,
      input_file: ^fst$file_reference,
      input_file_id: amt$file_identifier,
      interactive: boolean,
      interpreter_mode: clt$interpreter_modes,
      line: ^clt$command_line,
      local_status: ost$status,
      new_line: ^clt$command_line,
      new_line_size: clt$command_line_size,
      prompt_string: ^clt$string_value,
      strng: ost$string,
      until_string: ^clt$string_value;


{ NOTE that clp$get_interpreter_mode must be called before clp$evaluate_parameters
{ because the latter's call to clp$setup_parameter_evaluation may affect the
{ interpreter_mode stored in the clc$command_block.

    clp$get_interpreter_mode (interpreter_mode);

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);

    IF interpreter_mode = clc$help_mode THEN
      RETURN;
    IFEND;

    new_line := NIL;

{  Check for bad status.

    IF NOT status.normal THEN

{  The default values are not returned for parameters if a bad status
{  was returned by clp$evaluate_parameters.

      until_string := ^default_until_string;
      PUSH prompt_string: [0];

{  Check if the input parameter was specified.

      IF pvt [p$input].specified THEN

{  Just return with normal status if you are in SKIP mode.
{  Otherwise you are in INTERPRET mode and should return with
{  bad status.  No further processing is necessary.

        IF interpreter_mode = clc$skip_mode THEN
          status.normal := TRUE;
        IFEND;
        RETURN;

{  Return with bad status if the until string was specified and
{  could not be evaluated in either SKIP mode or INTERPRET mode.
{  We return a bad status even in SKIP mode because we can't know
{  when the text to be collect terminates.

      ELSEIF pvt [p$until].specified THEN
        IF pvt [p$until].value = NIL THEN
          RETURN;
        IFEND;

{  Save the specified until string value.

        until_string := pvt [p$until].value^.string_value;
      IFEND;


{  If you are in SKIP mode set status to normal and continue processing
{  to position the current input file past the until string.

      IF interpreter_mode = clc$skip_mode THEN

        status.normal := TRUE;

{  Change the interpreter mode from INTERPRET to SKIP mode and continue
{  processing to position the current input file past the until string.

      ELSE
        interpreter_mode := clc$skip_mode;
      IFEND;

{  Status is normal.
    ELSEIF (interpreter_mode = clc$skip_mode) AND pvt [p$input].specified THEN

{ Commands are being skipped and the input parameter was specified.  Do not
{ attempt to find the UNTIL string.

      RETURN;

    ELSE
      until_string := pvt [p$until].value^.string_value;
      prompt_string := pvt [p$prompt].value^.string_value;
      clp$change_colt_ruc_value (pvt [p$retain_unprintable_characters].value^.boolean_value.value,
            TRUE);
      IF pvt [p$substitution_mark].value^.kind = clc$string THEN
        PUSH new_line: [clc$max_command_line_size];
      IFEND;
    IFEND;

    caller_in_current_task := TRUE;
    input_block_handle := clv$nil_block_handle;
    input_file_id := amv$nil_file_identifier;
    display_control := clv$nil_display_control;
    #SPOIL (input_block_handle, input_file_id, display_control);

    osp$establish_block_exit_hndlr (^abort_handler);

  /collect_text/
    BEGIN
      IF interpreter_mode = clc$interpret_mode THEN
        default_ring_attributes.r1 := #RING (^default_ring_attributes);
        default_ring_attributes.r2 := #RING (^default_ring_attributes);
        default_ring_attributes.r3 := #RING (^default_ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, NIL, fsc$legible_data,
              default_ring_attributes, display_control, status);
      IFEND;

      IF NOT status.normal THEN
        clp$get_command_origin (interactive, local_status);
        IF interactive THEN
          EXIT /collect_text/;
        IFEND;
      IFEND;

      IF pvt [p$input].specified THEN
        input_file := pvt [p$input].value^.file_value;
      ELSE
        input_file := ^default_input_file;
        clp$find_caller_input_block (clc$current_command_input, caller_input_block, caller_in_current_task);
      IFEND;
      IF pvt [p$input].specified OR (NOT caller_in_current_task) THEN
        clp$push_input (input_file^, osc$null_name, '', FALSE, TRUE, input_block_handle, input_file_id,
              input_executable, local_status);
        IF NOT local_status.normal THEN
          IF status.normal AND (NOT local_status.normal) THEN
            status := local_status;
          IFEND;
          EXIT /collect_text/;
        IFEND;
      IFEND;

    /copy_loop/
      WHILE TRUE DO
        clp$get_line_from_command_file (prompt_string^, line, local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;
        IF NOT local_status.normal THEN
          EXIT /copy_loop/;
        ELSEIF line = NIL THEN
          IF status.normal THEN
            osp$set_status_abnormal ('CL', cle$encountered_eoi, 'COLLECT_TEXT', status);
          IFEND;
          EXIT /copy_loop/;
        ELSEIF (STRLENGTH (line^) = STRLENGTH (until_string^)) AND (line^ = until_string^) THEN
          EXIT /copy_loop/;
        ELSEIF (display_control.file_id <> amv$nil_file_identifier) AND
              (interpreter_mode = clc$interpret_mode) THEN
          IF new_line <> NIL THEN
            clp$substitute_delimited_text (line^, pvt [p$substitution_mark].value^.string_value^ (1),
                  new_line^, new_line_size, local_status);
            IF local_status.normal THEN
              clp$put_display (display_control, new_line^ (1, new_line_size), clc$no_trim, local_status);
            IFEND;
          ELSE
            clp$put_display (display_control, line^, clc$no_trim, local_status);
          IFEND;
          IF (NOT local_status.normal) THEN
            osp$get_status_condition_string(local_status.condition, strng, ignore_status);
            IF (strng.value(1,strng.size) = 'AA 2924') THEN
              osp$generate_output_message(local_status,ignore_status);
              local_status.normal := TRUE;
            ELSE
              interpreter_mode := clc$skip_mode;
            IFEND;
            IF status.normal THEN
              status := local_status;
            IFEND;
          IFEND;
        IFEND;
      WHILEND /copy_loop/;
    END /collect_text/;

    clp$change_colt_ruc_value (FALSE, FALSE);
    IF input_block_handle <> clv$nil_block_handle THEN
      clp$pop_input (TRUE, input_block_handle, input_file_id, input_executable, NIL, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF display_control.file_id <> amv$nil_file_identifier THEN
      clp$close_display (display_control, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND clp$_collect_text;

MODEND clm$collect_text_command;
*DECK DECK=CLM$COMMAND_LIST_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Command List Manager' ??
MODULE clm$command_list_manager;

{
{ PURPOSE:
{   This module contains the requests used to manage the command list at both the job and task levels.
{

?? NEWTITLE := 'Global Declarations' ??
?? NEWTITLE := 'Command List', EJECT ??
*copyc clt$command_list_info
?? OLDTITLE, EJECT ??
*IF NOT $true(osv$unix)
?? PUSH (LISTEXT := ON) ??
*copyc ame$lfn_program_actions
*IFEND
*copyc cle$ecc_command_processing
*IF NOT $true(osv$unix)
*copyc cle$ecc_control_statement
*copyc cle$ecc_file_reference
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_utilities
*copyc clt$command_library_search_info
*IFEND
*copyc clt$command_list_entry_file
*IF NOT $true(osv$unix)
*copyc clt$command_processor
*copyc clt$command_table
*IFEND
*copyc clt$environment_object_contents
*copyc clt$environment_object_size
*IF NOT $true(osv$unix)
*copyc clt$env_object_pop_reason
*copyc clt$env_object_push_reason
*copyc clt$function_table
*copyc clt$scl_procedure
*copyc clt$when_conditions
*copyc clv$local_catalog_handle_name
*copyc fse$path_exception_conditions
*copyc lle$load_map_diagnostics
*copyc lle$loader_status_conditions
*copyc llt$object_library_header
*copyc llt$program_description
*copyc osc$volume_unavailable_cond
*copyc ose$heap_full_exceptions
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc ost$caller_identifier
*IFEND
*copyc ost$message_template_module
*IF NOT $true(osv$unix)
*copyc ost$name
*IFEND
*copyc ost$status
*IF NOT $true(osv$unix)
*copyc pfe$error_condition_codes
*copyc pmt$program_name
?? POP ??
*copyc clp$access_command_file
*copyc clp$check_name_for_path_handle
*copyc clp$close_executable_cmnd_file
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_str_to_path_handle
*copyc clp$environment_object_in_block
*copyc clp$extract_msg_module_contents
*IFEND
*copyc clp$find_command_list
*copyc clp$find_current_block
*IF NOT $true(osv$unix)
*copyc clp$find_task_block
*copyc clp$find_utility_block
*copyc clp$pop_environment
*copyc clp$push_environment
*copyc clp$reverse_list
*copyc clp$search_dictionary_for_code
*copyc clp$search_dictionary_for_name
*IFEND
*copyc clp$search_module_for_code
*copyc clp$search_module_for_name
*IF NOT $true(osv$unix)
*copyc clp$trimmed_string_size
*copyc clv$processing_phase
*copyc fmp$process_pt_request
*copyc fsp$convert_fs_structure_to_pf
*copyc fsv$evaluated_file_reference
*copyc lop$find_command_in_program
*copyc lop$find_function_in_program
*copyc mmp$reverify_access
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$establish_condition_handler
*copyc osp$find_natural_language
*copyc osp$get_condition_status
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$system_error
*copyc osp$verify_system_privilege
*copyc osv$lower_to_upper
*copyc osv$task_private_heap
*IFEND
*copyc osv$task_shared_heap
*IF NOT $true(osv$unix)
*copyc pmp$abort
*copyc pmp$continue_to_cause
*copyc pmp$convert_entry_point_to_cmnd
*copyc pmp$get_library_dictionaries
*copyc pmp$load_from_library
*copyc pmp$log
?? TITLE := 'clp$check_valid_catalog', EJECT ??
*copyc clp$check_valid_catalog
?? TITLE := 'Message Cache Definitions', EJECT ??
*copyc clt$message_cache
*ELSE
*copyc clt$message_cache
*copyc clt$block
*IFEND
?? TITLE := 'Global Variables', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$task_command_library_list: [XDCL, oss$task_private] ^clt$command_library_list_entry := NIL;
*ELSE
    clv$task_command_library_list: [XDCL] ^clt$command_library_list_entry := NIL;
*IFEND

  VAR
*IF NOT $true(osv$unix)
    clv$message_cache: [XDCL, oss$task_private] clt$message_cache := [0, * ];
*ELSE
    clv$message_cache: [XDCL] clt$message_cache := [0, * ];
*IFEND

  VAR
*IF NOT $true(osv$unix)
    osv$built_in_message_templates: [XDCL, READ, oss$job_paged_literal] ^ost$message_template_module := NIL;
*ELSE
    osv$built_in_message_templates: [XREF] ^ost$message_template_module;
*IFEND

?? TITLE := 'clp$eo_size_command_list', EJECT ??

  FUNCTION [XDCL] clp$eo_size_command_list: clt$environment_object_size;


    clp$eo_size_command_list := #SIZE (clt$command_list);

  FUNCEND clp$eo_size_command_list;
?? TITLE := 'clp$eo_init_command_list', EJECT ??

  PROCEDURE [XDCL] clp$eo_init_command_list
    (    object: ^clt$environment_object_contents);

    VAR
      command_list: ^clt$command_list;


    command_list := object;

    command_list^.search_mode := clc$global_command_search;
    command_list^.entries.first_entry := NIL;
    command_list^.entries.entry_after_fence := NIL;
    command_list^.entries.last_entry := NIL;
    command_list^.system_command_library_lfn := osc$null_name;
    command_list^.system_library_contains.commands := FALSE;
    command_list^.system_library_contains.functions := FALSE;
    command_list^.system_library_contains.help_modules := FALSE;
    command_list^.system_library_contains.message_modules := FALSE;
    command_list^.system_library_contains.panels := FALSE;
    command_list^.number_of_utilities_added := 0;
    command_list^.deletion_made := FALSE;

  PROCEND clp$eo_init_command_list;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$eo_push_command_list', EJECT ??

  PROCEDURE [XDCL] clp$eo_push_command_list
    (    push_reason: clt$env_object_push_reason;
         new_object: ^clt$environment_object_contents;
         new_object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      copy_entry: boolean,
      old_command_list: ^clt$command_list,
      old_entry: ^clt$command_list_entry,
      new_command_list: ^clt$command_list,
      new_entry: ^clt$command_list_entry,
      task_block: ^clt$block;


    status.normal := TRUE;

    new_command_list := new_object;
    old_command_list := pushed_object;

    new_command_list^.search_mode := old_command_list^.search_mode;
    new_command_list^.entries.first_entry := NIL;
    new_command_list^.entries.last_entry := NIL;
    new_command_list^.system_command_library_lfn := old_command_list^.system_command_library_lfn;
    new_command_list^.system_library_contains := old_command_list^.system_library_contains;
    new_command_list^.number_of_utilities_added := 0;
    new_command_list^.deletion_made := FALSE;

    IF old_command_list^.entries.first_entry = NIL THEN
      RETURN;
    IFEND;

    IF push_reason = clc$eo_push_requested THEN
      task_block := NIL;
    ELSE
      clp$find_task_block (task_block, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    old_entry := old_command_list^.entries.first_entry;
    REPEAT
      IF (old_entry^.kind <> clc$sub_commands) OR (task_block = NIL) THEN
        copy_entry := TRUE;
      ELSE
        block := task_block;
        WHILE (block <> NIL) AND (block^.kind <> clc$utility_block) AND
              (#OFFSET (^block^.command_environment) <> #OFFSET (old_entry^.utility_info)) DO
          block := block^.previous_block;
        WHILEND;
        copy_entry := block <> NIL;
      IFEND;

      IF copy_entry THEN
        ALLOCATE new_entry IN osv$task_shared_heap^;
        new_entry^ := old_entry^;
        new_entry^.next_entry := NIL;
        IF new_command_list^.entries.first_entry = NIL THEN
          new_command_list^.entries.first_entry := new_entry;
        ELSE
          new_command_list^.entries.last_entry^.next_entry := new_entry;
        IFEND;
        new_command_list^.entries.last_entry := new_entry;
      IFEND;

      old_entry := old_entry^.next_entry;
    UNTIL old_entry = NIL;

    establish_fence (new_command_list^.search_mode, new_command_list^.entries.first_entry,
          new_command_list^.entries.entry_after_fence);

  PROCEND clp$eo_push_command_list;
?? TITLE := 'clp$eo_pop_command_list', EJECT ??

  PROCEDURE [XDCL] clp$eo_pop_command_list
    (    pop_reason: clt$env_object_pop_reason;
         object: ^clt$environment_object_contents;
         object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

    VAR
      command_list: ^clt$command_list,
      current_entry: ^clt$command_list_entry,
      next_entry: ^clt$command_list_entry;


    status.normal := TRUE;

    command_list := object;

    IF (pop_reason = clc$eo_pop_requested) AND (command_list^.number_of_utilities_added > 0) THEN
      osp$set_status_condition (cle$cannot_pop_command_list, status);
      RETURN;
    ELSEIF command_list^.entries.first_entry = NIL THEN
      RETURN;
    IFEND;

    current_entry := command_list^.entries.first_entry;
    REPEAT
      next_entry := current_entry^.next_entry;
      FREE current_entry IN osv$task_shared_heap^;
      current_entry := next_entry;
    UNTIL current_entry = NIL;

    IF (pushed_object <> NIL) AND ((pop_reason = clc$eo_pop_requested) OR (pop_reason = clc$eo_pop_for_block))
          THEN
      command_list := pushed_object;
      update_command_list (FALSE, command_list, pushed_object_in_current_task, status);
    IFEND;

  PROCEND clp$eo_pop_command_list;
?? TITLE := 'clp$eo_updt_command_list', EJECT ??

  PROCEDURE [XDCL] clp$eo_updt_command_list
    (    synchronous_with_parent: boolean;
         synchronous_with_job: boolean;
         current_object: ^clt$environment_object_contents;
         current_object_in_current_task: boolean;
     VAR status: ost$status);

    VAR
      command_list: ^clt$command_list;


    status.normal := TRUE;

    IF synchronous_with_parent THEN
      command_list := current_object;
      update_command_list (TRUE, command_list, current_object_in_current_task, status);
    IFEND;

  PROCEND clp$eo_updt_command_list;
*IFEND
?? TITLE := 'establish_fence', EJECT ??

  PROCEDURE establish_fence
    (    search_mode: clt$command_search_modes;
         first_entry: ^clt$command_list_entry;
     VAR entry_after_fence: ^clt$command_list_entry);

    VAR
      utility_entry: ^clt$command_list_entry;


    entry_after_fence := first_entry;
    utility_entry := NIL;

    WHILE entry_after_fence <> NIL DO
      CASE entry_after_fence^.kind OF

      = clc$command_list_fence =
        entry_after_fence := entry_after_fence^.next_entry;
        RETURN;

      = clc$sub_commands =
        IF search_mode <> entry_after_fence^.utility_info^.previous_search_mode THEN
          entry_after_fence := entry_after_fence^.next_entry;
          RETURN;
        ELSEIF utility_entry = NIL THEN
          utility_entry := entry_after_fence;
        IFEND;

      ELSE
        ;
      CASEND;

      entry_after_fence := entry_after_fence^.next_entry;
    WHILEND;

    IF utility_entry <> NIL THEN
      entry_after_fence := utility_entry^.next_entry;
    ELSEIF first_entry <> NIL THEN
      entry_after_fence := first_entry^.next_entry;
    IFEND;

  PROCEND establish_fence;
*IF NOT $true(osv$unix)
?? TITLE := 'externalize_path_handle_name', EJECT ??

  PROCEDURE externalize_path_handle_name
    (    path_handle_name: fst$path_handle_name);

    VAR
      cl_path_handle: clt$path_handle,
      evaluated_file_reference: fst$evaluated_file_reference,
      ignore_cycle_description: ^fmt$cycle_description,
      ignore_process_pt_results: bat$process_pt_results,
      ignore_status: ost$status;


    clp$check_name_for_path_handle (path_handle_name, cl_path_handle);
    evaluated_file_reference := fsv$evaluated_file_reference;
    evaluated_file_reference.path_handle_info.path_handle_present := TRUE;
    evaluated_file_reference.path_handle_info.path_handle := cl_path_handle.regular_handle;
    fmp$process_pt_request ($bat$process_pt_work_list [bac$externalize_path_handle],
          {local_file_name=} osc$null_name, evaluated_file_reference, ignore_cycle_description,
          ignore_process_pt_results, ignore_status);

  PROCEND externalize_path_handle_name;
?? TITLE := 'clp$set_job_command_search_mode', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_job_command_search_mode
    (    search_mode: clt$command_search_modes;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      caller_id: ost$caller_identifier,
      command_list: ^clt$command_list,
      ignore_cmnd_list_found_in_task: boolean,
      utility_block: ^clt$block,
      utility_block_in_current_task: boolean;


    status.normal := TRUE;

    IF (search_mode < LOWERVALUE (clt$command_search_modes)) OR
          (search_mode > UPPERVALUE (clt$command_search_modes)) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$set_job_command_search_mode', status);
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND
    clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);
    clp$find_current_block (block);

    IF (caller_id.ring > osc$tsrv_ring) AND (block^.previous_block <> NIL) AND
          block^.previous_block^.use_command_search_mode THEN
      CASE command_list^.search_mode OF
      = clc$exclusive_command_search =
        osp$set_status_abnormal ('CL', cle$exclusve_mode_excludes_cmnd, '', status);
        RETURN;
      = clc$restricted_command_search =
        clp$find_utility_block (osc$null_name, utility_block, utility_block_in_current_task);
        IF (utility_block <> NIL) AND (utility_block_in_current_task OR
              utility_block^.command_environment.command_level) THEN
          osp$set_status_abnormal ('CL', cle$cannot_change_search_mode, '', status);
          RETURN;
        IFEND;
      ELSE {clc$global_command_search}
        ;
      CASEND;
    IFEND;

{ Change the search mode.

    command_list^.search_mode := search_mode;

{ Mark blocks so that the change takes effect for the requester.

    WHILE block <> NIL DO
      block^.use_command_search_mode := TRUE;
      CASE block^.kind OF
      = clc$command_proc_block, clc$function_proc_block, clc$utility_block =
        RETURN;
      = clc$task_block =
        IF NOT block^.synchronous_with_parent THEN
          RETURN;
        IFEND;
      ELSE
        ;
      CASEND;
      block := block^.previous_block;
    WHILEND;

  PROCEND clp$set_job_command_search_mode;
*IFEND
?? TITLE := 'clp$add_utility_to_command_list', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$add_utility_to_command_list
    (    utility_block: ^clt$block;
     VAR status: ost$status);

    VAR
      command_list: ^clt$command_list,
      ignore_cmnd_list_found_in_task: boolean,
      new_entry: ^clt$command_list_entry;


    status.normal := TRUE;

    ALLOCATE new_entry IN osv$task_shared_heap^;

    clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);

    new_entry^.next_entry := command_list^.entries.first_entry;
    new_entry^.kind := clc$sub_commands;
    new_entry^.utility_name := utility_block^.label;
    new_entry^.utility_info := ^utility_block^.command_environment;
    new_entry^.utility_info^.previous_search_mode := command_list^.search_mode;

    command_list^.number_of_utilities_added := command_list^.number_of_utilities_added + 1;

{
{  The statement below ensures that the utility does not expand the search
{  mode, e.g. if it was restricted, it cannot be made global.
{  The code takes advantage of the fact that order of the elements of
{  the ordinal type clt$command_search_modes is: global, restricted,
{  exclusive.
{

    IF command_list^.search_mode <= utility_block^.command_search_mode THEN
      command_list^.search_mode := utility_block^.command_search_mode;
    IFEND;

    command_list^.entries.first_entry := new_entry;
    IF command_list^.entries.last_entry = NIL THEN
      command_list^.entries.last_entry := new_entry;
    IFEND;

    establish_fence (command_list^.search_mode, command_list^.entries.first_entry,
          command_list^.entries.entry_after_fence);

  PROCEND clp$add_utility_to_command_list;
?? TITLE := 'clp$delete_util_from_cmnd_list', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$delete_util_from_cmnd_list
    (    utility_block: ^clt$block;
     VAR status: ost$status);

    VAR
      auxiliary_libraries: ^clt$utility_auxiliary_libraries,
      command_list: ^clt$command_list,
      ignore_cmnd_list_found_in_task: boolean,
      index: integer,
      libraries: ^array [1 .. * ] of fst$path_handle_name,
      local_status: ost$status,
      previous_entry: ^clt$command_list_entry,
      old_entry: ^clt$command_list_entry;


    status.normal := TRUE;

    clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);
    previous_entry := NIL;
    old_entry := command_list^.entries.first_entry;

  /find_entry/
    WHILE old_entry <> NIL DO
      IF (old_entry^.kind = clc$sub_commands) AND (#OFFSET (^utility_block^.command_environment) =
            #OFFSET (old_entry^.utility_info)) THEN
        EXIT /find_entry/;
      IFEND;
      previous_entry := old_entry;
      old_entry := old_entry^.next_entry;
    WHILEND /find_entry/;

    IF old_entry <> NIL THEN
      IF old_entry = command_list^.entries.last_entry THEN
        command_list^.entries.last_entry := previous_entry;
      IFEND;

      IF old_entry = command_list^.entries.first_entry THEN
        command_list^.entries.first_entry := old_entry^.next_entry;
      ELSE
        previous_entry^.next_entry := old_entry^.next_entry;
      IFEND;

      FREE old_entry IN osv$task_shared_heap^;

      libraries := utility_block^.command_environment.libraries;
      utility_block^.command_environment.libraries := NIL;
      auxiliary_libraries := utility_block^.command_environment.auxiliary_libraries;
      utility_block^.command_environment.auxiliary_libraries := NIL;

      IF libraries <> NIL THEN
        FOR index := 1 TO UPPERBOUND (libraries^) DO
*IF NOT $true(osv$unix)
          clp$close_command_library (libraries^ [index], local_status);
          IF (NOT local_status.normal) AND status.normal THEN
            status := local_status;
          IFEND;
*IFEND
        FOREND;
        FREE libraries IN osv$task_shared_heap^;
      IFEND;

      IF auxiliary_libraries <> NIL THEN
        FOR index := 1 TO UPPERBOUND (auxiliary_libraries^) DO
*IF NOT $true(osv$unix)
          clp$close_command_library (auxiliary_libraries^ [index].name, local_status);
          IF (NOT local_status.normal) AND status.normal THEN
            status := local_status;
          IFEND;
*IFEND
        FOREND;
        FREE auxiliary_libraries IN osv$task_shared_heap^;
      IFEND;

      command_list^.search_mode := utility_block^.command_environment.previous_search_mode;
      IF command_list^.number_of_utilities_added > 0 THEN
        command_list^.number_of_utilities_added := command_list^.number_of_utilities_added - 1;
      IFEND;

      establish_fence (command_list^.search_mode, command_list^.entries.first_entry,
            command_list^.entries.entry_after_fence);

    IFEND;

  PROCEND clp$delete_util_from_cmnd_list;
?? TITLE := 'clp$add_file_to_command_list', EJECT ??
*copy clh$add_file_to_command_list

  PROCEDURE [XDCL, #GATE] clp$add_file_to_command_list
    (    entry: clt$command_list_entry_file;
         append: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
*IF NOT $true(osv$unix)
      caller_id: ost$caller_identifier,
      evaluated_file_reference: fst$evaluated_file_reference,
*IFEND
      ignore_cmnd_list_found_in_task: boolean,
      library_list_entry: ^clt$command_library_list_entry,
      local_file_name: fst$path_handle_name,
      command_list: ^clt$command_list,
      new_entry: ^clt$command_list_entry,
      new_entry_kind: clt$command_list_entry_kind,
*IF NOT $true(osv$unix)
      path_handle: clt$path_handle,
      path_handle_name: amt$local_file_name,
      pf_path: ^pft$path;
*ELSE
      path_handle_name: amt$local_file_name;
*IFEND


*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
    caller_id.ring := osc$user_ring;
*IFEND
    status.normal := TRUE;
    clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);
    clp$find_current_block (block);

*IF NOT $true(osv$unix)
    IF (caller_id.ring > osc$tsrv_ring) AND (block^.previous_block <> NIL) AND
          block^.previous_block^.use_command_search_mode THEN
      CASE command_list^.search_mode OF
      = clc$exclusive_command_search =
        osp$set_status_abnormal ('CL', cle$exclusve_mode_excludes_cmnd, '', status);
        RETURN;
      = clc$restricted_command_search =
        osp$set_status_abnormal ('CL', cle$restricted_mode_cmnd_change, '', status);
        RETURN;
      ELSE {clc$global_command_search}
        ;
      CASEND;
    IFEND;
*IFEND

    CASE entry.kind OF
    = clc$command_list_entry_$system =
      new_entry_kind := clc$system_commands;
*IF NOT $true(osv$unix)
    = clc$command_list_entry_fence =
      new_entry_kind := clc$command_list_fence;
    ELSE {clc$command_list_entry_path}
      IF entry.path^ = ':$WORKING_CATALOG' THEN
        new_entry_kind := clc$working_catalog_commands
      ELSEIF (entry.path^ = ':$LOCAL') OR (entry.path^ = clv$local_catalog_handle_name) THEN
        new_entry_kind := clc$catalog_commands;
        local_file_name := clv$local_catalog_handle_name;
      ELSE
        clp$convert_str_to_path_handle (entry.path^, FALSE, FALSE, FALSE, path_handle_name,
              evaluated_file_reference, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$open_command_library (caller_id.ring, path_handle_name, library_list_entry, local_file_name,
              status);
        IF status.normal THEN
          new_entry_kind := clc$library_commands;
        ELSEIF (status.condition <> pfe$path_too_short) AND (status.condition <> pfe$name_not_permanent_file)
                THEN
          RETURN;
        ELSE
          local_file_name := path_handle_name;
          PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
          fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);
          clp$check_valid_catalog (pf_path^, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF evaluated_file_reference.cycle_reference.specification <> fsc$cycle_omitted THEN
            osp$set_status_abnormal ('CL', fse$catalogs_do_not_have_cycles, '', status);
            osp$append_status_file (osc$status_parameter_delimiter, entry.path^, status);
            RETURN;
          IFEND;
          IF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
            osp$set_status_abnormal ('CL', cle$file_position_not_allowed, '', status);
            RETURN;
          IFEND;
          new_entry_kind := clc$catalog_commands;
        IFEND;
      IFEND;
*IFEND
    CASEND;

    new_entry := command_list^.entries.first_entry;
    WHILE new_entry <> NIL DO
      IF new_entry^.kind = new_entry_kind THEN
        CASE new_entry_kind OF
*IF NOT $true(osv$unix)
        = clc$catalog_commands, clc$library_commands =
          IF new_entry^.local_file_name = local_file_name THEN
            osp$set_status_abnormal ('CL', cle$duplicate_command_list_ent, local_file_name, status);
            RETURN;
          IFEND;
        = clc$working_catalog_commands =
          osp$set_status_abnormal ('CL', cle$duplicate_work_cat_entry, '', status);
          RETURN;
        = clc$command_list_fence =
          osp$set_status_abnormal ('CL', cle$duplicate_fence_entry, '', status);
          RETURN;
        ELSE {clc$system_commands}
*ELSE
        = clc$system_commands =
*IFEND
          osp$set_status_abnormal ('CL', cle$duplicate_$system_entry, '', status);
          RETURN;
        CASEND;
      IFEND;
      new_entry := new_entry^.next_entry;
    WHILEND;

    ALLOCATE new_entry IN osv$task_shared_heap^;

    IF append THEN

{ Add new entry to end of list.

      new_entry^.next_entry := NIL;
      IF command_list^.entries.last_entry <> NIL THEN
        command_list^.entries.last_entry^.next_entry := new_entry;
      ELSE
        command_list^.entries.first_entry := new_entry;
      IFEND;
      command_list^.entries.last_entry := new_entry;

    ELSE

{ Add new entry to front of list.

      new_entry^.next_entry := command_list^.entries.first_entry;
      command_list^.entries.first_entry := new_entry;
      IF command_list^.entries.last_entry = NIL THEN
        command_list^.entries.last_entry := new_entry;
      IFEND;

    IFEND;

    new_entry^.kind := new_entry_kind;
    CASE new_entry_kind OF

*IF NOT $true(osv$unix)
    = clc$catalog_commands =
      new_entry^.local_file_name := local_file_name;
      new_entry^.unaccessible_entry := FALSE;

    = clc$library_commands =

{ Externalize the path_handle_name for the case where the command_library is
{ added in a child task, and left in the library list.  If the path_handle_name
{ is not externalized, it will disappear when the task ends and the library is closed.

      externalize_path_handle_name (local_file_name);
      new_entry^.local_file_name := local_file_name;

      initialize_library_contains (library_list_entry, new_entry^.library_contains);

      new_entry^.unaccessible_entry := FALSE;
      clv$message_cache.count := 0;

*IFEND
    = clc$system_commands =
      clv$message_cache.count := 0;

    ELSE
      ;
    CASEND;

    establish_fence (command_list^.search_mode, command_list^.entries.first_entry,
          command_list^.entries.entry_after_fence);

  PROCEND clp$add_file_to_command_list;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$delete_file_from_cmnd_list', EJECT ??
*copy clh$delete_file_from_cmnd_list

  PROCEDURE [XDCL, #GATE] clp$delete_file_from_cmnd_list
    (    entry: clt$command_list_entry_file;
     VAR status: ost$status);

    CONST
      fence = 'FENCE',
      system = '$SYSTEM',
      system_user = ':' CAT system CAT '.' CAT system,
      working_catalog = ':$WORKING_CATALOG';

    VAR
      block: ^clt$block,
      caller_id: ost$caller_identifier,
      command_list: ^clt$command_list,
      done: boolean,
      first_time: boolean,
      original_file_name: fst$path_handle_name,
      local_file_name: fst$path_handle_name,
      path: fst$path,
      path_size: fst$path_size,
      evaluated_file_reference: fst$evaluated_file_reference,
      cmnd_list_found_in_current_task: boolean,
      previous_entry: ^clt$command_list_entry,
      old_entry: ^clt$command_list_entry,
      local_status: ost$status;


    first_time := FALSE;
    status.normal := TRUE;
*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND
    clp$find_command_list (command_list, cmnd_list_found_in_current_task);
    clp$find_current_block (block);

    IF (caller_id.ring > osc$tsrv_ring) AND (block^.previous_block <> NIL) AND
          block^.previous_block^.use_command_search_mode THEN
      CASE command_list^.search_mode OF
      = clc$exclusive_command_search =
        osp$set_status_abnormal ('CL', cle$exclusve_mode_excludes_cmnd, '', status);
        RETURN;
      = clc$restricted_command_search =
        osp$set_status_abnormal ('CL', cle$restricted_mode_cmnd_change, '', status);
        RETURN;
      ELSE {clc$global_command_search}
        ;
      CASEND;
    IFEND;

    IF entry.kind = clc$command_list_entry_$system THEN
      local_file_name := system;
    ELSEIF entry.kind = clc$command_list_entry_fence THEN
      local_file_name := fence;
    ELSEIF entry.path^ = working_catalog THEN
      local_file_name := working_catalog;
    ELSE
      clp$convert_str_to_path_handle (entry.path^, FALSE, TRUE, FALSE, local_file_name,
            evaluated_file_reference, status);
      first_time := TRUE;

      IF NOT status.normal THEN

{ If a problem comes up with obsolete path handle names in the command list, then STATUS
{ should be checked for CLE$SYSTEM_ERROR, and if true, set LOCAL_FILE_NAME = ENTRY.NAME^,
{ PATH = ' ', PATH_SIZE = 1, and STATUS.NORMAL = TRUE

        RETURN;
      ELSE
        clp$convert_file_ref_to_string (evaluated_file_reference, FALSE, path, path_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;
    original_file_name := local_file_name;

    REPEAT
      done := TRUE;
      previous_entry := NIL;
      old_entry := command_list^.entries.first_entry;

    /find_entry/
      WHILE old_entry <> NIL DO
        CASE old_entry^.kind OF
        = clc$library_commands, clc$catalog_commands =
          IF old_entry^.local_file_name = local_file_name THEN
            EXIT /find_entry/;
          IFEND;
        = clc$working_catalog_commands =
          IF local_file_name = working_catalog THEN
            EXIT /find_entry/;
          IFEND;
        = clc$system_commands =
          IF (local_file_name = system) OR (path (1, path_size) = system_user) THEN
            EXIT /find_entry/;
          IFEND;
        = clc$command_list_fence =
          IF local_file_name = fence THEN
            EXIT /find_entry/;
          IFEND;
        ELSE
          ;
        CASEND;
        previous_entry := old_entry;
        old_entry := old_entry^.next_entry;
      WHILEND /find_entry/;
      IF (old_entry = NIL) AND (first_time) THEN
        clp$convert_str_to_path_handle (entry.path^, FALSE, FALSE, FALSE, local_file_name,
              evaluated_file_reference, status);
        first_time := FALSE;
        done := FALSE;
      IFEND;
    UNTIL done;

    IF old_entry = NIL THEN
      local_file_name := original_file_name;
      IF (local_file_name = system) OR (path (1, path_size) = system_user) THEN
        osp$set_status_abnormal ('CL', cle$entry_not_in_command_list, system, status);
      ELSEIF (local_file_name = fence) OR (local_file_name = working_catalog) THEN
        osp$set_status_abnormal ('CL', cle$entry_not_in_command_list, local_file_name, status);
      ELSE
        osp$set_status_abnormal ('CL', cle$not_in_command_list, local_file_name, status);
      IFEND;
      RETURN;
    IFEND;

    IF old_entry = command_list^.entries.last_entry THEN
      command_list^.entries.last_entry := previous_entry;
    IFEND;

    IF old_entry = command_list^.entries.first_entry THEN
      command_list^.entries.first_entry := old_entry^.next_entry;
    ELSE
      previous_entry^.next_entry := old_entry^.next_entry;
    IFEND;

    CASE old_entry^.kind OF
    = clc$library_commands =
      clp$close_command_library (old_entry^.local_file_name, status);
      clv$message_cache.count := 0;
    = clc$system_commands =
      clv$message_cache.count := 0;
    ELSE
      ;
    CASEND;

    FREE old_entry IN osv$task_shared_heap^;

    IF NOT cmnd_list_found_in_current_task THEN
      command_list^.deletion_made := TRUE;
    IFEND;

    establish_fence (command_list^.search_mode, command_list^.entries.first_entry,
          command_list^.entries.entry_after_fence);

  PROCEND clp$delete_file_from_cmnd_list;
?? TITLE := 'clp$delete_all_from_cmnd_list', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$delete_all_from_cmnd_list
    (VAR status: ost$status);

    VAR
      block: ^clt$block,
      caller_id: ost$caller_identifier,
      command_list: ^clt$command_list,
      cmnd_list_found_in_current_task: boolean,
      free_old_entry: boolean,
      next_entry: ^clt$command_list_entry,
      old_entry: ^clt$command_list_entry,
      local_status: ost$status;


    status.normal := TRUE;
*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND
    clp$find_command_list (command_list, cmnd_list_found_in_current_task);
    clp$find_current_block (block);

    IF (caller_id.ring > osc$tsrv_ring) AND (block^.previous_block <> NIL) AND
          block^.previous_block^.use_command_search_mode THEN
      CASE command_list^.search_mode OF
      = clc$exclusive_command_search =
        osp$set_status_abnormal ('CL', cle$exclusve_mode_excludes_cmnd, '', status);
        RETURN;
      = clc$restricted_command_search =
        osp$set_status_abnormal ('CL', cle$restricted_mode_cmnd_change, '', status);
        RETURN;
      ELSE
        ;
      CASEND;
    IFEND;

    old_entry := command_list^.entries.first_entry;
    command_list^.entries.first_entry := NIL;
    command_list^.entries.last_entry := NIL;

    WHILE old_entry <> NIL DO
      next_entry := old_entry^.next_entry;
      free_old_entry := TRUE;
      CASE old_entry^.kind OF
      = clc$library_commands =
        clp$close_command_library (old_entry^.local_file_name, local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;
        clv$message_cache.count := 0;
      = clc$system_commands =
        clv$message_cache.count := 0;
      = clc$sub_commands =
        old_entry^.next_entry := NIL;
        IF command_list^.entries.first_entry = NIL THEN
          command_list^.entries.first_entry := old_entry;
        ELSE
          command_list^.entries.last_entry^.next_entry := old_entry;
        IFEND;
        command_list^.entries.last_entry := old_entry;
        free_old_entry := FALSE;
      ELSE
        ;
      CASEND;
      IF free_old_entry THEN
        FREE old_entry IN osv$task_shared_heap^;
      IFEND;
      old_entry := next_entry;
    WHILEND;

    IF NOT cmnd_list_found_in_current_task THEN
      command_list^.deletion_made := TRUE;
    IFEND;

    IF command_list^.entries.first_entry <> NIL THEN
      osp$set_status_abnormal ('CL', cle$utility_left_in_cmnd_list, '', status);
    IFEND;

    establish_fence (command_list^.search_mode, command_list^.entries.first_entry,
          command_list^.entries.entry_after_fence);

  PROCEND clp$delete_all_from_cmnd_list;
?? TITLE := 'clp$establish_sys_command_lib', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$establish_sys_command_lib
    (    file: ^fst$file_reference;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      command_list: ^clt$command_list,
      cmnd_list_found_in_current_task: boolean,
      evaluated_file_reference: fst$evaluated_file_reference,
      library_list_entry: ^clt$command_library_list_entry,
      path_handle_name: amt$local_file_name,
      previous_system_command_library: amt$local_file_name,
      validated_file_name: fst$path_handle_name,
      local_status: ost$status;


*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND
    status.normal := TRUE;

    clp$find_command_list (command_list, cmnd_list_found_in_current_task);

    previous_system_command_library := command_list^.system_command_library_lfn;

    IF (file <> NIL) AND (file^ = previous_system_command_library) THEN
      RETURN;
    IFEND;

    command_list^.system_command_library_lfn := osc$null_name;
    clv$message_cache.count := 0;

    IF previous_system_command_library <> osc$null_name THEN
      clp$close_command_library (previous_system_command_library, status);

      IF NOT cmnd_list_found_in_current_task THEN
        command_list^.deletion_made := TRUE;
      IFEND;

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

    IF file = NIL THEN
      RETURN;
    IFEND;

    clp$convert_str_to_path_handle (file^, FALSE, FALSE, FALSE, path_handle_name, evaluated_file_reference,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$open_command_library (caller_id.ring, path_handle_name, library_list_entry, validated_file_name,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Externalize the path_handle_name for the case where the command_library is
{ added in a child task, and left in the library list.  If the path_handle_name
{ is not externalized, it will disappear when the task ends and the library is closed.

    externalize_path_handle_name (validated_file_name);
    command_list^.system_command_library_lfn := validated_file_name;

    initialize_library_contains (library_list_entry, command_list^.system_library_contains);

  PROCEND clp$establish_sys_command_lib;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$get_system_message_mod_ptr', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$get_system_message_mod_ptr
    (VAR message_template: ^ost$message_template_module);

    osp$verify_system_privilege;
    message_template := osv$built_in_message_templates;

  PROCEND clp$get_system_message_mod_ptr;
*IFEND
?? TITLE := 'clp$push_dynamic_command_list', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_dynamic_command_list
    (VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      command_block: ^clt$block,
      command_list: ^clt$command_list,
      command_list_entry: ^clt$command_list_entry,
      ignore_cmnd_list_found_in_task: boolean,
      ignore_file_name: fst$path_handle_name,
      ignore_status: ^ost$status,
      library_list_entry: ^clt$command_library_list_entry,
      previous_entry: ^clt$command_list_entry;


    status.normal := TRUE;

    clp$find_current_block (command_block);

  /search/
    WHILE command_block <> NIL DO
      CASE command_block^.kind OF
      = clc$command_block =
        CASE command_block^.command_kind OF
        = clc$command_is_include_file, clc$command_is_include_line =
          ;
        ELSE
          EXIT /search/;
        CASEND;
      = clc$command_proc_block, clc$function_proc_block =
        EXIT /search/;
      = clc$task_block =
        IF NOT command_block^.synchronous_with_parent THEN
          command_block := NIL;
          EXIT /search/;
        IFEND;
      ELSE
        ;
      CASEND;
      command_block := command_block^.previous_block;
    WHILEND /search/;

    IF command_block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'PUSH_COMMANDS', status);
      RETURN;
    ELSEIF command_block^.source.kind = clc$sub_commands THEN
      osp$set_status_abnormal ('CL', cle$cannot_move_utility_entry, '', status);
      RETURN;
    IFEND;

    clp$push_environment (clc$command_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);

    previous_entry := NIL;
    command_list_entry := command_list^.entries.first_entry;

  /find_entry/
    WHILE command_list_entry <> NIL DO
      IF command_list_entry^.kind = command_block^.source.kind THEN
        CASE command_list_entry^.kind OF
        = clc$catalog_commands, clc$library_commands =
          IF command_list_entry^.local_file_name = command_block^.source.local_file_name THEN
            EXIT /find_entry/;
          IFEND;
        = clc$system_commands, clc$working_catalog_commands =
          EXIT /find_entry/;
        ELSE
          ;
        CASEND;
      IFEND;
      previous_entry := command_list_entry;
      command_list_entry := command_list_entry^.next_entry;
    WHILEND /find_entry/;

  /create_new_entry/
    BEGIN
      IF command_list_entry <> NIL THEN
        IF command_list_entry = command_list^.entries.first_entry THEN
          EXIT /create_new_entry/;
        ELSE
          previous_entry^.next_entry := command_list_entry^.next_entry;
          IF command_list_entry = command_list^.entries.last_entry THEN
            command_list^.entries.last_entry := previous_entry;
          IFEND;
        IFEND;
      ELSE
        IF command_block^.source.kind = clc$library_commands THEN
*IF NOT $true(osv$unix)
          #CALLER_ID (caller_id);
*ELSE
          caller_id.ring := osc$user_ring;
*IFEND
          clp$open_command_library (caller_id.ring, command_block^.source.local_file_name, library_list_entry,
                ignore_file_name, status);
          IF NOT status.normal THEN
            PUSH ignore_status;
            clp$pop_environment (clc$command_list, ignore_status^);
            RETURN;
          IFEND;
        IFEND;

        ALLOCATE command_list_entry IN osv$task_shared_heap^;

        command_list_entry^.kind := command_block^.source.kind;
        command_list_entry^.next_entry := NIL;
        CASE command_block^.source.kind OF
        = clc$catalog_commands =
          command_list_entry^.local_file_name := command_block^.source.local_file_name;
        = clc$library_commands =
          command_list_entry^.local_file_name := command_block^.source.local_file_name;
          initialize_library_contains (library_list_entry, command_list_entry^.library_contains);
          command_list_entry^.unaccessible_entry := FALSE;
        ELSE
          ;
        CASEND;
        IF command_list^.entries.last_entry = NIL THEN
          command_list^.entries.last_entry := command_list_entry;
        IFEND;
      IFEND;

      command_list_entry^.next_entry := command_list^.entries.first_entry;
      command_list^.entries.first_entry := command_list_entry;

      CASE command_list_entry^.kind OF
      = clc$library_commands, clc$system_commands =
        clv$message_cache.count := 0;
      ELSE
        ;
      CASEND;
    END /create_new_entry/;

    establish_fence (command_list^.search_mode, command_list^.entries.first_entry,
          command_list^.entries.entry_after_fence);

  PROCEND clp$push_dynamic_command_list;
?? TITLE := 'clp$open_command_library', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$open_command_library
    (    caller_ring: ost$valid_ring;
         local_file_name: amt$local_file_name;
     VAR library_list_entry: ^clt$command_library_list_entry;
     VAR validated_file_name: fst$path_handle_name;
     VAR status: ost$status);

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

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


      CASE condition.selector OF
      = mmc$segment_access_condition =
        IF condition.segment_access_condition.identifier = mmc$sac_io_read_error THEN
          osp$set_status_from_condition ('CL', condition, save_area, status, handler_status);
          EXIT clp$open_command_library;
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          EXIT clp$open_command_library;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      i: llt$entry_point_index,
      ignore_status: ost$status,
      ring_attributes: amt$ring_attributes,
      ignore_opened_executable_file: boolean,
      ignore_file_contents: clt$file_contents,
      ignore_file_has_fap: boolean,
      can_be_echoed: boolean,
      ignore_device_class: rmt$device_class,
      ignore_line_layout: clt$line_layout,
      current_entry: ^clt$command_library_list_entry,
      dictionaries: llt$library_dictionary_pointers,
      new_library_contents: ^SEQ ( * ),
      version: string (4),
      file_id: amt$file_identifier,
      caller_id: ost$caller_identifier;


    status.normal := TRUE;
    validated_file_name := local_file_name;

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND
    IF caller_ring > caller_id.ring THEN
      caller_id.ring := caller_ring;
    IFEND;

    current_entry := clv$task_command_library_list;
    WHILE (current_entry <> NIL) AND (current_entry^.local_file_name <> local_file_name) DO
      current_entry := current_entry^.next_entry;
    WHILEND;

    osp$establish_condition_handler (^abort_handler, FALSE);

    IF current_entry = NIL THEN
      clp$access_command_file (clc$command_library, caller_id.ring, local_file_name, file_id,
            new_library_contents, ignore_opened_executable_file, can_be_echoed, ignore_line_layout,
            ignore_file_contents, ring_attributes, ignore_file_has_fap, ignore_device_class,
            validated_file_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF validated_file_name <> local_file_name THEN
        current_entry := clv$task_command_library_list;
        WHILE (current_entry <> NIL) AND (current_entry^.local_file_name <> validated_file_name) DO
          current_entry := current_entry^.next_entry;
        WHILEND;
        IF current_entry <> NIL THEN
          clp$close_executable_cmnd_file (file_id, status);
          IF status.normal THEN
            library_list_entry := current_entry;
          IFEND;
          RETURN;
        IFEND;
      IFEND;

      pmp$get_library_dictionaries (new_library_contents, dictionaries, status);
      IF NOT status.normal THEN
        clp$close_executable_cmnd_file (file_id, ignore_status);
        RETURN;
      IFEND;

      IF dictionaries.library_version = 'V1.0' THEN
        ALLOCATE dictionaries.command_dictionary: [1 .. UPPERBOUND (dictionaries.entry_point_dictionary^)] IN
              osv$task_private_heap^;
        FOR i := 1 TO UPPERBOUND (dictionaries.entry_point_dictionary^) DO
          pmp$convert_entry_point_to_cmnd (dictionaries.entry_point_dictionary^ [i], i,
                dictionaries.command_dictionary^ [i]);
        FOREND;
      ELSEIF dictionaries.library_version > llc$object_library_version THEN
        clp$close_executable_cmnd_file (file_id, ignore_status);
        osp$set_status_abnormal ('CL', lle$wrong_library_version, llc$object_library_version, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, validated_file_name, status);
        RETURN;
      IFEND;

      ALLOCATE current_entry IN osv$task_private_heap^;

      current_entry^.next_entry := clv$task_command_library_list;
      current_entry^.local_file_name := validated_file_name;
      current_entry^.used_for_dynamic_load := FALSE;
      current_entry^.file_id := file_id;
      current_entry^.ring_attributes := ring_attributes;
      current_entry^.contents := new_library_contents;
      current_entry^.can_be_echoed := can_be_echoed;
      current_entry^.dictionaries := dictionaries;
      clv$task_command_library_list := current_entry;
    ELSEIF NOT mmp$reverify_access (#LOC (current_entry^.contents)) THEN
        osp$set_status_abnormal ('CL', cle$command_search_aborted, local_file_name, status);
    IFEND;

    library_list_entry := current_entry;

  PROCEND clp$open_command_library;
?? TITLE := 'check_if_library_still_in_use', EJECT ??

  PROCEDURE [INLINE] check_if_library_still_in_use
    (    local_file_name: amt$local_file_name;
     VAR library_still_in_use: boolean);

    VAR
      block: ^clt$block,
      command_list: ^clt$command_list,
      current_command_list_entry: ^clt$command_list_entry,
      first_task: record
        case found: boolean of
        = TRUE =
          block: ^clt$block,
        casend,
      recend,
      index: integer,
      scan_command_lists: boolean;


    clp$find_current_block (block);
    first_task.found := FALSE;
    scan_command_lists := TRUE;

  /check_command_lists/
    WHILE scan_command_lists DO
      IF (block^.kind = clc$task_block) AND (NOT first_task.found) THEN
        first_task.found := TRUE;
        first_task.block := block;
      IFEND;

      IF (block^.environment_object_info <> NIL) AND
            block^.environment_object_info^.defined [clc$eo_command_list] THEN
        command_list := clp$environment_object_in_block (clc$eo_command_list, block);
        IF local_file_name = command_list^.system_command_library_lfn THEN
          library_still_in_use := TRUE;
          RETURN;
        IFEND;

        current_command_list_entry := command_list^.entries.first_entry;

      /search_for_file_name/
        WHILE current_command_list_entry <> NIL DO
          CASE current_command_list_entry^.kind OF
          = clc$library_commands =
            IF current_command_list_entry^.local_file_name = local_file_name THEN
              EXIT /search_for_file_name/;
            IFEND;
          = clc$sub_commands =
            IF current_command_list_entry^.utility_info^.libraries <> NIL THEN
              FOR index := 1 TO UPPERBOUND (current_command_list_entry^.utility_info^.libraries^) DO
                IF current_command_list_entry^.utility_info^.libraries^ [index] = local_file_name THEN
                  EXIT /search_for_file_name/;
                IFEND;
              FOREND;
            IFEND;
            IF current_command_list_entry^.utility_info^.auxiliary_libraries <> NIL THEN
              FOR index := 1 TO UPPERBOUND (current_command_list_entry^.utility_info^.auxiliary_libraries^) DO
                IF current_command_list_entry^.utility_info^.auxiliary_libraries^ [index].name =
                      local_file_name THEN
                  EXIT /search_for_file_name/;
                IFEND;
              FOREND;
            IFEND;
          ELSE
            ;
          CASEND;
          current_command_list_entry := current_command_list_entry^.next_entry;
        WHILEND /search_for_file_name/;

        IF current_command_list_entry <> NIL THEN
          library_still_in_use := TRUE;
          RETURN;
        IFEND;

        IF first_task.found AND ((first_task.block <> block) OR
              NOT first_task.block^.synchronous_with_parent) THEN
          scan_command_lists := FALSE;
        IFEND;
      IFEND;

      IF NOT first_task.found THEN
        IF ((block^.kind IN $clt$block_kinds [clc$input_block, clc$command_proc_block,
              clc$function_proc_block, clc$when_block]) AND (block^.input.kind = clc$file_input) AND
              (block^.input.local_file_name = local_file_name)) THEN
          library_still_in_use := TRUE;
          RETURN;
        IFEND;
      IFEND;

      block := block^.previous_block;

    WHILEND /check_command_lists/;

    library_still_in_use := FALSE;

  PROCEND check_if_library_still_in_use;
?? TITLE := 'clp$close_command_library', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$close_command_library
    (    local_file_name: amt$local_file_name;
     VAR status: ost$status);

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

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


      CASE condition.selector OF
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          EXIT clp$close_command_library;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      library_still_in_use: boolean,
      previous_library_list_entry: ^^clt$command_library_list_entry,
      current_library_list_entry: ^clt$command_library_list_entry;


    status.normal := TRUE;
    osp$establish_condition_handler (^abort_handler, FALSE);

    check_if_library_still_in_use (local_file_name, library_still_in_use);
    IF library_still_in_use THEN
      RETURN;
    IFEND;

    previous_library_list_entry := ^clv$task_command_library_list;
    current_library_list_entry := clv$task_command_library_list;
    WHILE (current_library_list_entry <> NIL) AND (current_library_list_entry^.local_file_name <>
          local_file_name) DO
      previous_library_list_entry := ^current_library_list_entry^.next_entry;
      current_library_list_entry := current_library_list_entry^.next_entry;
    WHILEND;
    IF (current_library_list_entry = NIL) OR current_library_list_entry^.used_for_dynamic_load THEN
      RETURN;
    IFEND;

    clp$close_executable_cmnd_file (current_library_list_entry^.file_id, status);

    previous_library_list_entry^ := current_library_list_entry^.next_entry;
    IF current_library_list_entry^.dictionaries.library_version = 'V1.0' THEN
      FREE current_library_list_entry^.dictionaries.command_dictionary IN osv$task_private_heap^;
    IFEND;
    FREE current_library_list_entry IN osv$task_private_heap^;

  PROCEND clp$close_command_library;
?? TITLE := 'update_command_list', EJECT ??

  PROCEDURE update_command_list
    (    erasing_a_task: boolean;
         command_list: ^clt$command_list;
         command_list_in_current_task: boolean;
     VAR status: ost$status);

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

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


      CASE condition.selector OF
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          EXIT update_command_list;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    IF command_list_in_current_task THEN
      clv$message_cache.count := 0;
    IFEND;

    IF erasing_a_task AND NOT command_list^.deletion_made THEN
      RETURN;
    IFEND;

    command_list^.deletion_made := NOT command_list_in_current_task;

    osp$establish_condition_handler (^abort_handler, FALSE);

    update_command_library_list (status);

  PROCEND update_command_list;
?? TITLE := 'clp$update_command_library_list', EJECT ??

  PROCEDURE [INLINE] update_command_library_list
    (VAR status: ost$status);

    VAR
      library_still_in_use: boolean,
      previous_library_list_entry: ^^clt$command_library_list_entry,
      current_library_list_entry: ^clt$command_library_list_entry,
      local_status: ost$status;


    status.normal := TRUE;

    previous_library_list_entry := ^clv$task_command_library_list;
    current_library_list_entry := clv$task_command_library_list;

  /scan_library_list/
    WHILE current_library_list_entry <> NIL DO

    /check_library_still_in_use/
      BEGIN
        IF current_library_list_entry^.used_for_dynamic_load THEN
          EXIT /check_library_still_in_use/;
        IFEND;

        check_if_library_still_in_use (current_library_list_entry^.local_file_name, library_still_in_use);
        IF library_still_in_use THEN
          EXIT /check_library_still_in_use/;
        IFEND;

        clp$close_executable_cmnd_file (current_library_list_entry^.file_id, local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;

        previous_library_list_entry^ := current_library_list_entry^.next_entry;
        FREE current_library_list_entry IN osv$task_private_heap^;
        current_library_list_entry := previous_library_list_entry^;
        CYCLE /scan_library_list/;

      END /check_library_still_in_use/;

      previous_library_list_entry := ^current_library_list_entry^.next_entry;
      current_library_list_entry := current_library_list_entry^.next_entry;
    WHILEND /scan_library_list/;

  PROCEND update_command_library_list;
?? TITLE := 'clp$search_command_library', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$search_command_library
    (    command_or_function_name: ost$name;
         command_or_function: clt$command_or_function;
         searching_command_list: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR local_file_name {input, output} : amt$local_file_name;
     VAR file_id: amt$file_identifier;
     VAR ring_attributes: amt$ring_attributes;
     VAR can_be_echoed: boolean;
     VAR search_info: clt$command_library_search_info;
     VAR command_or_function_found: boolean;
     VAR status: ost$status);

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

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


      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF (condition.selector = mmc$segment_access_condition) AND
              (condition.segment_access_condition.identifier = mmc$sac_io_read_error) THEN
          osp$set_status_from_condition ('CL', condition, save_area, status, handler_status);
        ELSE
          osp$set_status_abnormal ('CL', cle$command_search_aborted, local_file_name, status);
          IF searching_command_list THEN
            clp$set_unaccessible_entry (local_file_name, TRUE, status);
          IFEND;
        IFEND;
        EXIT clp$search_command_library;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          EXIT clp$search_command_library;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      application_member_header: ^llt$application_member_header,
      caller_id: ost$caller_identifier,
      command_dictionary_item: ^llt$command_dictionary_item,
      command_list: ^clt$command_list,
      function_dictionary_item: ^llt$function_dictionary_item,
      ignore_cmnd_list_found_in_task: boolean,
      library_list_entry: ^clt$command_library_list_entry,
      library_module: ^SEQ ( * ),
      member_header: ^llt$library_member_header,
      validated_file_name: fst$path_handle_name;


    status.normal := TRUE;
    command_or_function_found := FALSE;
    library_list_entry := NIL;
    #SPOIL (library_list_entry);
*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND

{
{ Do not search if we are running below ring 3.  In this case,
{ assume we did not find the command in the library.
{

    IF caller_id.ring < osc$tsrv_ring THEN
      RETURN;
    IFEND;

    IF local_file_name = osc$null_name THEN
      clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);
      local_file_name := command_list^.system_command_library_lfn;
      #SPOIL (local_file_name);
      IF local_file_name = osc$null_name THEN
        RETURN;
      IFEND;
    IFEND;

    osp$establish_condition_handler (^abort_handler, FALSE);

    clp$open_command_library (caller_id.ring, local_file_name, library_list_entry, validated_file_name,
          status);
    IF validated_file_name <> osc$null_name THEN
      local_file_name := validated_file_name;
      #SPOIL (local_file_name);
    IFEND;
    IF searching_command_list THEN
      clp$set_unaccessible_entry (local_file_name, TRUE, status);
    IFEND;
    IF (NOT status.normal) OR (library_list_entry = NIL) THEN
      RETURN;
    IFEND;

    IF caller_id.ring > library_list_entry^.ring_attributes.r3 THEN
      RETURN;
    IFEND;

    IF command_or_function = clc$command THEN
      IF library_list_entry^.dictionaries.command_dictionary = NIL THEN
        RETURN;
      IFEND;
      search_command_library (library_list_entry^.dictionaries.command_dictionary, command_or_function_name,
            command_dictionary_item);
      command_or_function_found := command_dictionary_item <> NIL;
      IF command_or_function_found THEN
        IF ((caller_id.ring < library_list_entry^.ring_attributes.r1) OR
              (caller_id.ring > library_list_entry^.ring_attributes.r2)) AND
              (command_dictionary_item^.kind <> llc$gate) THEN
          osp$set_status_abnormal ('CL', cle$command_file_not_callable, local_file_name, status);
          RETURN;
        ELSEIF command_dictionary_item^.kind = llc$local_to_library THEN
          command_or_function_found := local_cmnd_or_func_callable (local_file_name);
        IFEND;
      IFEND;
      IF NOT command_or_function_found THEN
        RETURN;
      IFEND;

      search_info.command_or_function_module := NIL;
      search_info.command_or_function_kind := command_dictionary_item^.kind;
      search_info.ordinal := command_dictionary_item^.ordinal;
      search_info.module_kind := command_dictionary_item^.module_kind;
      search_info.log_option := command_dictionary_item^.log_option;
      search_info.library_privilege := 'OBJECT';
      CASE search_info.module_kind OF

      = llc$command_procedure, llc$applic_command_procedure =
        IF command_dictionary_item^.module_kind = llc$applic_command_procedure THEN
          application_member_header := #PTR (command_dictionary_item^.applic_command_header,
                library_list_entry^.contents^);
          search_info.command_or_function_module := #PTR (application_member_header^.library_member_header.
                member, library_list_entry^.contents^);
          search_info.application_identifier := application_member_header^.application_identifier;
        ELSE
          member_header := #PTR (command_dictionary_item^.command_header, library_list_entry^.contents^);
          search_info.command_or_function_module := #PTR (member_header^.member,
                library_list_entry^.contents^);
          search_info.application_identifier.name := osc$null_name;
        IFEND;

      = llc$program_description, llc$applic_program_description =
        IF command_dictionary_item^.module_kind = llc$applic_program_description THEN
          application_member_header := #PTR (command_dictionary_item^.applic_program_header,
                library_list_entry^.contents^);
          library_module := #PTR (application_member_header^.library_member_header.member,
                library_list_entry^.contents^);
          search_info.application_identifier := application_member_header^.application_identifier;
        ELSE
          member_header := #PTR (command_dictionary_item^.program_header, library_list_entry^.contents^);
          library_module := #PTR (member_header^.member, library_list_entry^.contents^);
          search_info.application_identifier.name := osc$null_name;
        IFEND;
        IF caller_id.ring <= library_list_entry^.ring_attributes.r2 THEN
          search_info.command_or_function_module := library_module;
        ELSE
          NEXT search_info.command_or_function_module: [[REP #SIZE (library_module^) OF cell]] IN work_area;
          IF search_info.command_or_function_module = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            RETURN;
          IFEND;
          search_info.command_or_function_module^ := library_module^;
        IFEND;

      = llc$command_description, llc$applic_command_description =
        IF command_dictionary_item^.module_kind = llc$applic_command_description THEN
          application_member_header := #PTR (command_dictionary_item^.applic_command_description_hdr,
                library_list_entry^.contents^);
          library_module := #PTR (application_member_header^.library_member_header.member,
                library_list_entry^.contents^);
          search_info.application_identifier := application_member_header^.application_identifier;
        ELSE
          member_header := #PTR (command_dictionary_item^.command_description_header,
                library_list_entry^.contents^);
          library_module := #PTR (member_header^.member, library_list_entry^.contents^);
          search_info.application_identifier.name := osc$null_name;
        IFEND;
        IF caller_id.ring <= library_list_entry^.ring_attributes.r2 THEN
          search_info.command_or_function_module := library_module;
        ELSE
          NEXT search_info.command_or_function_module: [[REP #SIZE (library_module^) OF cell]] IN work_area;
          IF search_info.command_or_function_module = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            RETURN;
          IFEND;
          search_info.command_or_function_module^ := library_module^;
        IFEND;

      = llc$load_module =
        ;

      ELSE
        command_or_function_found := FALSE;
        RETURN;
      CASEND;

    ELSE {clc$function}
      IF library_list_entry^.dictionaries.function_dictionary = NIL THEN
        RETURN;
      IFEND;
      search_function_library (library_list_entry^.dictionaries.function_dictionary, command_or_function_name,
            function_dictionary_item);
      command_or_function_found := function_dictionary_item <> NIL;
      IF command_or_function_found THEN
        IF ((caller_id.ring < library_list_entry^.ring_attributes.r1) OR
              (caller_id.ring > library_list_entry^.ring_attributes.r2)) AND
              (function_dictionary_item^.kind <> llc$gate) THEN
          osp$set_status_abnormal ('CL', cle$command_file_not_callable, local_file_name, status);
          RETURN;
        ELSEIF function_dictionary_item^.kind = llc$local_to_library THEN
          command_or_function_found := local_cmnd_or_func_callable (local_file_name);
        IFEND;
      IFEND;
      IF NOT command_or_function_found THEN
        RETURN;
      IFEND;

      search_info.command_or_function_module := NIL;
      search_info.command_or_function_kind := function_dictionary_item^.kind;
      search_info.ordinal := function_dictionary_item^.ordinal;
      search_info.module_kind := function_dictionary_item^.module_kind;
      CASE search_info.module_kind OF

      = llc$function_procedure =
        member_header := #PTR (function_dictionary_item^.function_header, library_list_entry^.contents^);
        search_info.command_or_function_module := #PTR (member_header^.member, library_list_entry^.contents^);

      = llc$function_description =
        member_header := #PTR (function_dictionary_item^.function_description_header,
              library_list_entry^.contents^);
        library_module := #PTR (member_header^.member, library_list_entry^.contents^);
        IF caller_id.ring <= library_list_entry^.ring_attributes.r2 THEN
          search_info.command_or_function_module := library_module;
        ELSE
          NEXT search_info.command_or_function_module: [[REP #SIZE (library_module^) OF cell]] IN work_area;
          IF search_info.command_or_function_module = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            RETURN;
          IFEND;
          search_info.command_or_function_module^ := library_module^;
        IFEND;

      ELSE
        command_or_function_found := FALSE;
        RETURN;
      CASEND;
    IFEND;

    IF search_info.command_or_function_module <> NIL THEN
      RESET search_info.command_or_function_module;
    IFEND;
    file_id := library_list_entry^.file_id;
    ring_attributes := library_list_entry^.ring_attributes;
    can_be_echoed := library_list_entry^.can_be_echoed;

  PROCEND clp$search_command_library;
?? TITLE := 'search_command_library', EJECT ??

  PROCEDURE [INLINE] search_command_library
    (    command_dictionary: ^llt$command_dictionary;
         command_name: ost$name;
     VAR command_dictionary_item: ^llt$command_dictionary_item);

    VAR
*IF $true(osv$unix)
      lower: 1 .. llc$max_commands_in_library,
*ELSE
      lower: 1 .. llc$max_commands_in_library + 1,
*IFEND
      upper: 0 .. llc$max_commands_in_library,
      temp: integer,
      index: llt$command_index;


    command_dictionary_item := NIL;
    lower := 1;
    upper := UPPERBOUND (command_dictionary^);


  /binary_search/
    WHILE (lower <= upper) DO
      temp := lower + upper;
      index := temp DIV 2;
      IF command_name = command_dictionary^ [index].name THEN
        command_dictionary_item := ^command_dictionary^ [index];
        EXIT /binary_search/;
      ELSEIF command_name > command_dictionary^ [index].name THEN
        lower := index + 1;
      ELSE
        upper := index - 1;
      IFEND;
    WHILEND /binary_search/;

  PROCEND search_command_library;
?? TITLE := 'local_cmnd_or_func_callable', EJECT ??

  FUNCTION [UNSAFE] local_cmnd_or_func_callable
    (    library: amt$local_file_name): boolean;

    VAR
      block: ^clt$block;


    clp$find_current_block (block);

  /search/
    WHILE block <> NIL DO
      CASE block^.kind OF
      = clc$command_block =
        CASE block^.command_kind OF
        = clc$command_is_include_file, clc$command_is_include_line =
          ;
        ELSE
          EXIT /search/;
        CASEND;
      = clc$command_proc_block, clc$function_block, clc$function_proc_block =
        EXIT /search/;
      ELSE
        ;
      CASEND;
      block := block^.previous_block;
    WHILEND /search/;

    local_cmnd_or_func_callable := (block <> NIL) AND (block^.source.kind = clc$library_commands) AND
          (library = block^.source.local_file_name);

  FUNCEND local_cmnd_or_func_callable;
?? TITLE := 'clp$find_cmnd_or_func_in_prog', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$find_cmnd_or_func_in_prog
    (    command_or_function_name: ost$name;
         command_or_function: clt$command_or_function;
     VAR work_area {input, output} : ^clt$work_area;
     VAR local_file_name: amt$local_file_name;
     VAR ring_attributes: amt$ring_attributes;
     VAR search_info: clt$command_library_search_info;
     VAR status: ost$status);

    VAR
      application_member_header: ^llt$application_member_header,
      caller_id: ost$caller_identifier,
      command_dictionary_item: llt$command_dictionary_item,
      function_dictionary_item: llt$function_dictionary_item,
      library: ^SEQ ( * ),
      library_module: ^SEQ ( * ),
      library_privilege: ost$name,
      member_header: ^llt$library_member_header;


    status.normal := TRUE;
*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND

    IF command_or_function = clc$command THEN
      lop$find_command_in_program (command_or_function_name, command_dictionary_item, library,
            local_file_name, ring_attributes, library_privilege, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal ('CL', cle$unable_to_call_command, command_or_function_name, status);
        RETURN;
      ELSEIF caller_id.ring > ring_attributes.r3 THEN
        RETURN;
      IFEND;

      search_info.command_or_function_module := NIL;
      search_info.command_or_function_kind := command_dictionary_item.kind;
      search_info.ordinal := command_dictionary_item.ordinal;
      search_info.module_kind := command_dictionary_item.module_kind;
      search_info.log_option := command_dictionary_item.log_option;
      search_info.library_privilege := library_privilege;
      CASE search_info.module_kind OF

      = llc$command_procedure, llc$applic_command_procedure =

{! The following check of rings (that the caller is within the execute bracket of the file) is temporary.
{! Someday (maybe) code will be added to switch rings when the caller is outside the execute bracket.

        IF (caller_id.ring < ring_attributes.r1) OR (caller_id.ring > ring_attributes.r2) THEN
          osp$set_status_abnormal ('CL', cle$command_file_not_callable, local_file_name, status);
          RETURN;
        IFEND;
        IF search_info.module_kind = llc$applic_command_procedure THEN
          application_member_header := #PTR (command_dictionary_item.applic_command_header, library^);
          search_info.command_or_function_module := #PTR (application_member_header^.library_member_header.
                member, library^);
          search_info.application_identifier := application_member_header^.application_identifier;
        ELSE
          member_header := #PTR (command_dictionary_item.command_header, library^);
          search_info.command_or_function_module := #PTR (member_header^.member, library^);
          search_info.application_identifier.name := osc$null_name;
        IFEND;

      = llc$program_description, llc$applic_program_description =
        IF ((caller_id.ring < ring_attributes.r1) OR (caller_id.ring > ring_attributes.r2)) AND
              (search_info.command_or_function_kind <> llc$gate) THEN
          osp$set_status_abnormal ('CL', cle$command_file_not_callable, local_file_name, status);
          RETURN;
        IFEND;
        IF command_dictionary_item.module_kind = llc$applic_program_description THEN
          application_member_header := #PTR (command_dictionary_item.applic_program_header, library^);
          library_module := #PTR (application_member_header^.library_member_header.member, library^);
          search_info.application_identifier := application_member_header^.application_identifier;
        ELSE
          member_header := #PTR (command_dictionary_item.program_header, library^);
          library_module := #PTR (member_header^.member, library^);
          search_info.application_identifier.name := osc$null_name;
        IFEND;
        IF caller_id.ring <= ring_attributes.r2 THEN
          search_info.command_or_function_module := library_module;
        ELSE
          NEXT search_info.command_or_function_module: [[REP #SIZE (library_module^) OF cell]] IN work_area;
          IF search_info.command_or_function_module = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            RETURN;
          IFEND;
          search_info.command_or_function_module^ := library_module^;
        IFEND;

      = llc$command_description, llc$applic_command_description =
        IF (caller_id.ring < ring_attributes.r1) OR ((caller_id.ring > ring_attributes.r2) AND
              (search_info.command_or_function_kind <> llc$gate)) THEN
          osp$set_status_abnormal ('CL', cle$command_file_not_callable, local_file_name, status);
          RETURN;
        IFEND;
        IF command_dictionary_item.module_kind = llc$applic_command_description THEN
          application_member_header := #PTR (command_dictionary_item.applic_command_description_hdr,
                library^);
          library_module := #PTR (application_member_header^.library_member_header.member, library^);
          search_info.application_identifier := application_member_header^.application_identifier;
        ELSE
          member_header := #PTR (command_dictionary_item.command_description_header, library^);
          library_module := #PTR (member_header^.member, library^);
          search_info.application_identifier.name := osc$null_name;
        IFEND;
        IF caller_id.ring <= ring_attributes.r2 THEN
          search_info.command_or_function_module := library_module;
        ELSE
          NEXT search_info.command_or_function_module: [[REP #SIZE (library_module^) OF cell]] IN work_area;
          IF search_info.command_or_function_module = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            RETURN;
          IFEND;
          search_info.command_or_function_module^ := library_module^;
        IFEND;

      = llc$load_module =
        IF ((caller_id.ring < ring_attributes.r1) OR (caller_id.ring > ring_attributes.r2)) AND
              (search_info.command_or_function_kind <> llc$gate) THEN
          osp$set_status_abnormal ('CL', cle$command_file_not_callable, local_file_name, status);
          RETURN;
        IFEND;

      ELSE
        osp$set_status_abnormal ('CL', cle$unable_to_call_command, command_or_function_name, status);
        RETURN;
      CASEND;

    ELSE {clc$function}
      lop$find_function_in_program (command_or_function_name, function_dictionary_item, library,
            local_file_name, ring_attributes, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal ('CL', cle$unable_to_call_command, command_or_function_name, status);
        RETURN;
      ELSEIF caller_id.ring > ring_attributes.r3 THEN
        RETURN;
      IFEND;

      search_info.command_or_function_module := NIL;
      search_info.command_or_function_kind := function_dictionary_item.kind;
      search_info.ordinal := function_dictionary_item.ordinal;
      search_info.module_kind := function_dictionary_item.module_kind;
      CASE search_info.module_kind OF

      = llc$function_procedure =

{! The following check of rings (that the caller is within the execute bracket of the file) is temporary.
{! Someday (maybe) code will be added to switch rings when the caller is outside the execute bracket.

        IF (caller_id.ring < ring_attributes.r1) OR (caller_id.ring > ring_attributes.r2) THEN
          osp$set_status_abnormal ('CL', cle$command_file_not_callable, local_file_name, status);
          RETURN;
        IFEND;
        member_header := #PTR (function_dictionary_item.function_header, library^);
        search_info.command_or_function_module := #PTR (member_header^.member, library^);

      = llc$function_description =
        IF (caller_id.ring < ring_attributes.r1) OR ((caller_id.ring > ring_attributes.r2) AND
              (search_info.command_or_function_kind <> llc$gate)) THEN
          osp$set_status_abnormal ('CL', cle$command_file_not_callable, local_file_name, status);
          RETURN;
        IFEND;
        member_header := #PTR (function_dictionary_item.function_description_header, library^);
        library_module := #PTR (member_header^.member, library^);
        IF caller_id.ring <= ring_attributes.r2 THEN
          search_info.command_or_function_module := library_module;
        ELSE
          NEXT search_info.command_or_function_module: [[REP #SIZE (library_module^) OF cell]] IN work_area;
          IF search_info.command_or_function_module = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            RETURN;
          IFEND;
          search_info.command_or_function_module^ := library_module^;
        IFEND;

      ELSE
        osp$set_status_abnormal ('CL', cle$unable_to_call_command, command_or_function_name, status);
        RETURN;
      CASEND;
    IFEND;

    IF search_info.command_or_function_module <> NIL THEN
      RESET search_info.command_or_function_module;
    IFEND;

  PROCEND clp$find_cmnd_or_func_in_prog;
?? TITLE := 'search_function_library', EJECT ??

  PROCEDURE [INLINE] search_function_library
    (    function_dictionary: ^llt$function_dictionary;
         function_name: ost$name;
     VAR function_dictionary_item: ^llt$function_dictionary_item);

    VAR
*IF $true(osv$unix)
      lower: 1 .. llc$max_functions_in_library,
*ELSE
      lower: 1 .. llc$max_functions_in_library + 1,
*IFEND
      upper: 0 .. llc$max_functions_in_library,
      temp: integer,
      index: llt$function_index;


    function_dictionary_item := NIL;
    lower := 1;
    upper := UPPERBOUND (function_dictionary^);

  /binary_search/
    WHILE (lower <= upper) DO
      temp := lower + upper;
      index := temp DIV 2;
      IF function_name = function_dictionary^ [index].name THEN
        function_dictionary_item := ^function_dictionary^ [index];
        EXIT /binary_search/;
      ELSEIF function_name > function_dictionary^ [index].name THEN
        lower := index + 1;
      ELSE
        upper := index - 1;
      IFEND;
    WHILEND /binary_search/;

  PROCEND search_function_library;
*IFEND
?? TITLE := 'clp$clear_message_cache', EJECT ??

  PROCEDURE [XDCL] clp$clear_message_cache;


    clv$message_cache.count := 0;

  PROCEND clp$clear_message_cache;
?? TITLE := 'clp$search_msg_library_via_name', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$search_msg_library_via_name
    (    caller_ring: ost$valid_ring;
         name: ost$status_condition_name;
         search_by_language: boolean;
         search_cache: boolean;
     VAR local_file_name {input, output} : amt$local_file_name;
     VAR code: ost$status_condition_code;
     VAR severity: ost$message_module_severity;
     VAR template: ^ost$message_template;
     VAR entry_found: boolean;
     VAR saved_default: boolean;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
?? NEWTITLE := 'abort_handler', EJECT ??

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


      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF (condition.selector = mmc$segment_access_condition) AND
              (condition.segment_access_condition.identifier = mmc$sac_io_read_error) THEN
          osp$set_status_from_condition ('CL', condition, save_area, status, handler_status);
        ELSE
          pmp$log ('Unable to lookup status name due to system condition or segment access condition',
                handler_status);
        IFEND;
        entry_found := FALSE;
        EXIT clp$search_msg_library_via_name;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          entry_found := FALSE;
          EXIT clp$search_msg_library_via_name;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? TITLE := 'search_cache_for_name', EJECT ??

    PROCEDURE [INLINE] search_cache_for_name;

      VAR
        i: 1 .. clc$message_cache_size;


      entry_found := FALSE;
      cache_index := 0;

      FOR i := 1 TO clv$message_cache.count DO
        IF name = clv$message_cache.buffer [i].name THEN
          cache_index := i;
          IF (NOT search_by_language) OR (clv$message_cache.buffer [i].template <> NIL) THEN
            entry_found := mmp$reverify_access (#LOC (clv$message_cache.buffer [i].template));
            IF entry_found THEN
              code := clv$message_cache.buffer [i].code;
              severity := clv$message_cache.buffer [i].severity;
              template := clv$message_cache.buffer [i].template;
            ELSE
              clv$message_cache.count := 0;
            IFEND;
          IFEND;
          RETURN;
        IFEND;
      FOREND;

    PROCEND search_cache_for_name;
?? TITLE := 'update_cache', EJECT ??

    PROCEDURE [INLINE] update_cache;

      VAR
        i: 1 .. clc$message_cache_size;


      IF NOT search_cache THEN
        cache_index := 0;

      /search_cache_buffer/
        FOR i := 1 TO clv$message_cache.count DO
          IF name = clv$message_cache.buffer [i].name THEN
            cache_index := i;
            EXIT /search_cache_buffer/;
          IFEND;
        FOREND /search_cache_buffer/;
      IFEND;

      IF cache_index = 0 THEN
        IF clv$message_cache.count < clc$message_cache_size THEN
          clv$message_cache.count := clv$message_cache.count + 1;
        IFEND;
        FOR cache_index := clv$message_cache.count DOWNTO 2 DO
          clv$message_cache.buffer [cache_index] := clv$message_cache.buffer [cache_index - 1];
        FOREND;
        cache_index := 1;
        clv$message_cache.buffer [cache_index].name := name;
      IFEND;
      clv$message_cache.buffer [cache_index].code := code;
      clv$message_cache.buffer [cache_index].severity := severity;
      IF language = natural_language^ THEN
        clv$message_cache.buffer [cache_index].template := template;
      ELSE
*IF NOT $true(osv$unix)
        clv$message_cache.buffer [cache_index].template := NIL;
*ELSE
        clv$message_cache.buffer [cache_index].template := osc$null_name;
*IFEND
      IFEND;

    PROCEND update_cache;
?? OLDTITLE, EJECT ??
*IFEND

    VAR
      natural_language: ^ost$natural_language,
*IF NOT $true(osv$unix)
      caller_id: ost$caller_identifier,
*IFEND
      cache_index: 0 .. clc$message_cache_size,
      message_module: ^ost$message_template_module,
*IF NOT $true(osv$unix)
      message_module_dictionary: ^llt$message_module_dictionary,
      member_header: ^llt$library_member_header,
      ignore_status: ost$status,
      index: llt$message_module_index,
      command_list: ^clt$command_list,
      language: ost$natural_language,
      ignore_validated_file_name: fst$path_handle_name,
      library_list_entry: ^clt$command_library_list_entry;
*ELSE
      language: ost$natural_language,
      ignore_status: ost$status;
*IFEND


    status.normal := TRUE;
    entry_found := FALSE;
*IF NOT $true(osv$unix)
    library_list_entry := NIL;
    #SPOIL (library_list_entry);

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND

{
{ Do not search a library if we are running below ring 3.  In this case,
{ assume we did not find the entry in the library.
{

    IF (caller_id.ring < osc$tsrv_ring) AND (local_file_name <> osc$null_name) THEN
      RETURN;
    IFEND;

    IF caller_ring > caller_id.ring THEN
      caller_id.ring := caller_ring;
    IFEND;

    osp$establish_condition_handler (^abort_handler, FALSE);

    IF search_cache THEN
      search_cache_for_name;
      IF entry_found THEN
        RETURN;
      IFEND;
    IFEND;

    osp$find_natural_language (natural_language);

  /search_library/
    BEGIN
      IF local_file_name = osc$null_name THEN
*ELSE
        language := osc$us_english;
*IFEND
        message_module := osv$built_in_message_templates;
        IF message_module <> NIL THEN
          clp$search_module_for_name (message_module, name, language, code, severity, template, entry_found,
                ignore_status);
          IF entry_found AND search_by_language AND (language <> natural_language^) AND
                (language = osc$default_natural_language) THEN
            saved_default := TRUE;
            entry_found := FALSE;
          IFEND;
        IFEND;
*IF NOT $true(osv$unix)
        EXIT /search_library/;
      IFEND;

      clp$open_command_library (caller_id.ring, local_file_name, library_list_entry,
            ignore_validated_file_name, status);
      IF (NOT status.normal) OR (library_list_entry = NIL) OR
            ((library_list_entry <> NIL) AND (NOT mmp$reverify_access (#LOC (library_list_entry^.contents))))
            THEN
        EXIT /search_library/;
      IFEND;

      message_module_dictionary := library_list_entry^.dictionaries.message_module_dictionary;
      IF (message_module_dictionary = NIL) OR (caller_id.ring > library_list_entry^.ring_attributes.r2) THEN
        EXIT /search_library/;
      IFEND;

      clp$search_dictionary_for_name (library_list_entry^.contents, message_module_dictionary,
            natural_language^, search_by_language, name, code, severity, template, entry_found,
            saved_default);
    END /search_library/;

    IF entry_found THEN
      update_cache;
    IFEND;
*IFEND

  PROCEND clp$search_msg_library_via_name;
?? TITLE := 'clp$search_msg_library_via_code', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$search_msg_library_via_code
    (    caller_ring: ost$valid_ring;
         code: ost$status_condition_code;
         search_by_language: boolean;
         search_cache: boolean;
     VAR local_file_name {input, output} : amt$local_file_name;
     VAR name {input, output} : ost$status_condition_name;
     VAR severity {input, output} : ost$message_module_severity;
     VAR template {input, output} : ^ost$message_template;
     VAR entry_found: boolean;
     VAR saved_default: boolean;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
?? NEWTITLE := 'abort_handler', EJECT ??

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


      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF (condition.selector = mmc$segment_access_condition) AND
              (condition.segment_access_condition.identifier = mmc$sac_io_read_error) THEN
          osp$set_status_from_condition ('CL', condition, save_area, status, handler_status);
        ELSE
          pmp$log ('Unable to lookup status code due to system condition or segment access condition',
                handler_status);
        IFEND;
        entry_found := FALSE;
        EXIT clp$search_msg_library_via_code;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          entry_found := FALSE;
          EXIT clp$search_msg_library_via_code;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? TITLE := 'search_cache_for_code', EJECT ??

    PROCEDURE [INLINE] search_cache_for_code;

      VAR
        i: 1 .. clc$message_cache_size;


      entry_found := FALSE;
      cache_index := 0;

      FOR i := 1 TO clv$message_cache.count DO
        IF code = clv$message_cache.buffer [i].code THEN
          cache_index := i;
          IF (NOT search_by_language) OR (clv$message_cache.buffer [i].template <> NIL) THEN
            entry_found := mmp$reverify_access (#LOC (clv$message_cache.buffer [i].template));
            IF entry_found THEN
              name := clv$message_cache.buffer [i].name;
              severity := clv$message_cache.buffer [i].severity;
              template := clv$message_cache.buffer [i].template;
            ELSE
              clv$message_cache.count := 0;
            IFEND;
          IFEND;
          RETURN;
        IFEND;
      FOREND;

    PROCEND search_cache_for_code;
?? TITLE := 'update_cache', EJECT ??

    PROCEDURE [INLINE] update_cache;

      VAR
        i: 1 .. clc$message_cache_size;


      IF NOT search_cache THEN
        cache_index := 0;

      /search_cache_buffer/
        FOR i := 1 TO clv$message_cache.count DO
          IF name = clv$message_cache.buffer [i].name THEN
            cache_index := i;
            EXIT /search_cache_buffer/;
          IFEND;
        FOREND /search_cache_buffer/;
      IFEND;

      IF cache_index = 0 THEN
        IF clv$message_cache.count < clc$message_cache_size THEN
          clv$message_cache.count := clv$message_cache.count + 1;
        IFEND;
        FOR cache_index := clv$message_cache.count DOWNTO 2 DO
          clv$message_cache.buffer [cache_index] := clv$message_cache.buffer [cache_index - 1];
        FOREND;
        cache_index := 1;
        clv$message_cache.buffer [cache_index].code := code;
      IFEND;
      clv$message_cache.buffer [cache_index].name := name;
      clv$message_cache.buffer [cache_index].severity := severity;
      IF language = natural_language^ THEN
        clv$message_cache.buffer [cache_index].template := template;
      ELSE
*IF NOT $true(osv$unix)
        clv$message_cache.buffer [cache_index].template := NIL;
*ELSE
        clv$message_cache.buffer [cache_index].template := osc$null_name;
*IFEND
      IFEND;

    PROCEND update_cache;
?? OLDTITLE, EJECT ??
*IFEND

    VAR
      natural_language: ^ost$natural_language,
*IF NOT $true(osv$unix)
      caller_id: ost$caller_identifier,
*IFEND
      cache_index: 0 .. clc$message_cache_size,
      message_module: ^ost$message_template_module,
*IF NOT $true(osv$unix)
      message_module_dictionary: ^llt$message_module_dictionary,
      member_header: ^llt$library_member_header,
      ignore_status: ost$status,
      index: llt$message_module_index,
      command_list: ^clt$command_list,
      language: ost$natural_language,
      ignore_validated_file_name: fst$path_handle_name,
      library_list_entry: ^clt$command_library_list_entry;
*ELSE
      language: ost$natural_language,
      ignore_status: ost$status;
*IFEND


    status.normal := TRUE;
    entry_found := FALSE;
*IF NOT $true(osv$unix)
    library_list_entry := NIL;
    #SPOIL (library_list_entry);

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND

{
{ Do not search a library if we are running below ring 3.  In this case,
{ assume we did not find the entry in the library.
{

    IF (caller_id.ring < osc$tsrv_ring) AND (local_file_name <> osc$null_name) THEN
      RETURN;
    IFEND;

    IF caller_ring > caller_id.ring THEN
      caller_id.ring := caller_ring;
    IFEND;

    osp$establish_condition_handler (^abort_handler, FALSE);

    IF search_cache THEN
      search_cache_for_code;
      IF entry_found THEN
        RETURN;
      IFEND;
    IFEND;

    osp$find_natural_language (natural_language);

  /search_library/
    BEGIN
      IF local_file_name = osc$null_name THEN
*ELSE
        language := osc$us_english;
*IFEND
        message_module := osv$built_in_message_templates;
        IF message_module <> NIL THEN
          clp$search_module_for_code (message_module, code, language, name, severity, template, entry_found,
                ignore_status);
*IF NOT $true(osv$unix)
          IF entry_found AND search_by_language AND (language <> natural_language^) AND
                (language = osc$default_natural_language) THEN
            saved_default := TRUE;
            entry_found := FALSE;
          IFEND;
*IFEND
        IFEND;
*IF NOT $true(osv$unix)
        EXIT /search_library/;
      IFEND;

      clp$open_command_library (caller_id.ring, local_file_name, library_list_entry,
            ignore_validated_file_name, status);
      IF (NOT status.normal) OR (library_list_entry = NIL) OR
            ((library_list_entry <> NIL) AND (NOT mmp$reverify_access (#LOC (library_list_entry^.contents))))
            THEN
        EXIT /search_library/;
      IFEND;

      message_module_dictionary := library_list_entry^.dictionaries.message_module_dictionary;
      IF (message_module_dictionary = NIL) OR (caller_id.ring > library_list_entry^.ring_attributes.r2) THEN
        EXIT /search_library/;
      IFEND;

      clp$search_dictionary_for_code (library_list_entry^.contents, message_module_dictionary,
            natural_language^, search_by_language, code, name, severity, template, entry_found,
            saved_default);
    END /search_library/;

    IF entry_found THEN
      update_cache;
    IFEND;
*IFEND

  PROCEND clp$search_msg_library_via_code;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$search_for_help_module', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$search_for_help_module
    (    caller_ring: ost$valid_ring;
         name: pmt$program_name;
     VAR local_file_name {input, output} : amt$local_file_name;
     VAR entry_found: boolean;
     VAR help_module: ^ost$message_template_module;
     VAR language: ost$natural_language;
     VAR online_manual: ost$online_manual_name;
     VAR status: ost$status);

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

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


      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        osp$set_status_from_condition ('CL', condition, save_area, status, handler_status);
        EXIT clp$search_for_help_module;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          EXIT clp$search_for_help_module;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      caller_id: ost$caller_identifier,
*IF $true(osv$unix)
      lower: 1 .. llc$max_help_modules_in_library,
*ELSE
      lower: 1 .. llc$max_help_modules_in_library + 1,
*IFEND
      upper: 0 .. llc$max_help_modules_in_library,
      help_module_dictionary: ^llt$help_module_dictionary,
      member_header: ^llt$library_member_header,
      header: ^ost$mtm_header,
      index: llt$help_module_index,
      ignore_condition_codes: ^ost$mtm_condition_codes,
      ignore_condition_names: ^ost$mtm_condition_names,
      ignore_validated_file_name: fst$path_handle_name,
      command_list: ^clt$command_list,
      temp: integer,
      library_list_entry: ^clt$command_library_list_entry;


    status.normal := TRUE;
    entry_found := FALSE;
    library_list_entry := NIL;
    #SPOIL (library_list_entry);

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND

{
{ Do not search if we are running below ring 3.  In this case,
{ assume we did not find the entry in the library.
{

    IF caller_id.ring < osc$tsrv_ring THEN
      RETURN;
    IFEND;

    IF caller_ring > caller_id.ring THEN
      caller_id.ring := caller_ring;
    IFEND;

    osp$establish_condition_handler (^abort_handler, FALSE);

  /search_library/
    BEGIN

      clp$open_command_library (caller_id.ring, local_file_name, library_list_entry,
            ignore_validated_file_name, status);
      IF (NOT status.normal) OR (library_list_entry = NIL) THEN
        EXIT /search_library/;
      IFEND;

      help_module_dictionary := library_list_entry^.dictionaries.help_module_dictionary;
      IF (help_module_dictionary = NIL) OR (caller_id.ring > library_list_entry^.ring_attributes.r2) THEN
        EXIT /search_library/;
      IFEND;

      lower := 1;
      upper := UPPERBOUND (help_module_dictionary^);
      ignore_condition_codes := NIL;
      ignore_condition_names := NIL;

    /search_dictionary/
      WHILE (lower <= upper) DO
        temp := lower + upper;
        index := temp DIV 2;
        IF help_module_dictionary^ [index].name = name THEN
          entry_found := TRUE;
          member_header := #PTR (help_module_dictionary^ [index].help_header, library_list_entry^.contents^);
          help_module := #PTR (member_header^.member, library_list_entry^.contents^);
          RESET help_module;
          clp$extract_msg_module_contents (help_module, header, ignore_condition_codes,
                ignore_condition_names);
          language := header^.language;
          online_manual := header^.online_manual_name;
          EXIT /search_dictionary/;
        ELSEIF help_module_dictionary^ [index].name > name THEN
          upper := index - 1;
        ELSE
          lower := index + 1;
        IFEND;
      WHILEND /search_dictionary/;
    END /search_library/;

  PROCEND clp$search_for_help_module;
?? TITLE := 'clp$set_unaccessible_entry', EJECT ??

  PROCEDURE [INLINE] clp$set_unaccessible_entry
    (    local_file_name: amt$local_file_name;
         reset_status: boolean;
     VAR status: {input, output} ost$status);

    VAR
      command_list: ^clt$command_list,
      ignore_cmnd_list_found_in_task: boolean,
      new_entry: ^clt$command_list_entry;


    clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);
    new_entry := command_list^.entries.first_entry;
    WHILE new_entry <> NIL DO
      IF (new_entry^.kind = clc$library_commands) AND (new_entry^.local_file_name = local_file_name) THEN
        IF NOT status.normal THEN
          IF NOT new_entry^.unaccessible_entry THEN
            new_entry^.unaccessible_entry := TRUE;
          ELSEIF reset_status THEN
            status.normal := TRUE;
          IFEND;
        ELSEIF new_entry^.unaccessible_entry THEN
          new_entry^.unaccessible_entry := FALSE;
        IFEND;
        RETURN;
      IFEND;
      new_entry := new_entry^.next_entry;
    WHILEND;

  PROCEND clp$set_unaccessible_entry;
?? TITLE := 'clp$find_command_entries', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$find_command_entries
    (    local_file_name: amt$local_file_name;
     VAR work_area {input, output} : ^clt$work_area;
     VAR ring_attributes: amt$ring_attributes;
     VAR command_entries: ^llt$command_dictionary;
     VAR function_entries: ^llt$function_dictionary;
     VAR status: ost$status);

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

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


      CASE condition.selector OF
      = mmc$segment_access_condition =
        IF condition.segment_access_condition.identifier = mmc$sac_io_read_error THEN
          osp$set_status_from_condition ('CL', condition, save_area, status, handler_status);
          EXIT clp$find_command_entries;
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          EXIT clp$find_command_entries;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      caller_id: ost$caller_identifier,
      ignore_validated_file_name: fst$path_handle_name,
      library_list_entry: ^clt$command_library_list_entry;


    status.normal := TRUE;
*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND

    clp$open_command_library (caller_id.ring, local_file_name, library_list_entry, ignore_validated_file_name,
          status);
    clp$set_unaccessible_entry (local_file_name, FALSE, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^abort_handler, FALSE);

    ring_attributes := library_list_entry^.ring_attributes;

    IF library_list_entry^.dictionaries.command_dictionary = NIL THEN
      command_entries := NIL;
    ELSEIF library_list_entry^.ring_attributes.r2 >= caller_id.ring THEN
      command_entries := library_list_entry^.dictionaries.command_dictionary;
    ELSE
      NEXT command_entries: [1 .. UPPERBOUND (library_list_entry^.dictionaries.command_dictionary^)] IN
            work_area;
      IF command_entries = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
      command_entries^ := library_list_entry^.dictionaries.command_dictionary^;
    IFEND;

    IF library_list_entry^.dictionaries.function_dictionary = NIL THEN
      function_entries := NIL;
    ELSEIF library_list_entry^.ring_attributes.r2 >= caller_id.ring THEN
      function_entries := library_list_entry^.dictionaries.function_dictionary;
    ELSE
      NEXT function_entries: [1 .. UPPERBOUND (library_list_entry^.dictionaries.function_dictionary^)] IN
            work_area;
      IF function_entries = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
      function_entries^ := library_list_entry^.dictionaries.function_dictionary^;
    IFEND;

  PROCEND clp$find_command_entries;
?? TITLE := 'clp$load_system_entry_point', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$load_system_entry_point
    (    name: pmt$program_name;
         kind: pmt$loaded_address_kind;
     VAR loaded_address: pmt$loaded_address;
     VAR status: ost$status);

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

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


      CASE condition.selector OF
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          EXIT clp$load_system_entry_point;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      caller_id: ost$caller_identifier,
      command_list: ^clt$command_list,
      ignore_cmnd_list_found_in_task: boolean,
      ring_for_load: ost$valid_ring,
      ignore_validated_file_name: fst$path_handle_name,
      library_list_entry: ^clt$command_library_list_entry;


    status.normal := TRUE;
    loaded_address.kind := kind;
    IF kind = pmc$procedure_address THEN
      loaded_address.pointer_to_procedure := NIL;
    ELSE
      loaded_address.pointer_to_data := NIL;
    IFEND;

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND
    osp$establish_condition_handler (^abort_handler, FALSE);

    clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);
    IF command_list^.system_command_library_lfn = osc$null_name THEN
      RETURN;
    IFEND;

    clp$open_command_library (caller_id.ring, command_list^.system_command_library_lfn, library_list_entry,
          ignore_validated_file_name, status);
    IF (NOT status.normal) OR (caller_id.ring > library_list_entry^.ring_attributes.r3) OR
          (caller_id.ring < library_list_entry^.ring_attributes.r1) THEN
      RETURN;
    IFEND;

    IF caller_id.ring > library_list_entry^.ring_attributes.r2 THEN
      ring_for_load := library_list_entry^.ring_attributes.r2;
    ELSE
      ring_for_load := caller_id.ring;
    IFEND;

    library_list_entry^.used_for_dynamic_load := TRUE;

    pmp$load_from_library (name, ring_for_load, 0, kind, library_list_entry^.contents,
          command_list^.system_command_library_lfn, loaded_address, status);

  PROCEND clp$load_system_entry_point;
?? TITLE := 'clp$load_from_library', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$load_from_library
    (    name: pmt$program_name;
         kind: pmt$loaded_address_kind;
         local_file_name: amt$local_file_name;
     VAR loaded_address: pmt$loaded_address;
     VAR status: ost$status);

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

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


      CASE condition.selector OF
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          EXIT clp$load_from_library;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      caller_id: ost$caller_identifier,
      library_list_entry: ^clt$command_library_list_entry,
      ring_for_load: ost$valid_ring,
      validated_file_name: fst$path_handle_name;


    status.normal := TRUE;
    loaded_address.kind := kind;
    IF kind = pmc$procedure_address THEN
      loaded_address.pointer_to_procedure := NIL;
    ELSE
      loaded_address.pointer_to_data := NIL;
    IFEND;

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND
    osp$establish_condition_handler (^abort_handler, FALSE);

    clp$open_command_library (caller_id.ring, local_file_name, library_list_entry, validated_file_name,
          status);
    IF (NOT status.normal) OR (caller_id.ring > library_list_entry^.ring_attributes.r3) OR
          (caller_id.ring < library_list_entry^.ring_attributes.r1) THEN
      RETURN;
    IFEND;

    IF caller_id.ring > library_list_entry^.ring_attributes.r2 THEN
      ring_for_load := library_list_entry^.ring_attributes.r2;
    ELSE
      ring_for_load := caller_id.ring;
    IFEND;

    library_list_entry^.used_for_dynamic_load := TRUE;

    pmp$load_from_library (name, ring_for_load, 0, kind, library_list_entry^.contents, validated_file_name,
          loaded_address, status);

  PROCEND clp$load_from_library;
?? TITLE := 'clp$find_form', EJECT ??
*copyc clh$find_form

  PROCEDURE [XDCL, #GATE] clp$find_form
    (    form_name: ost$name;
     VAR p_form_module: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      auxiliary_library_index: integer,
      block_in_current_task: boolean,
      caller_id: ost$caller_identifier,
      ignore_cmnd_list_found_in_task: boolean,
      local_library_name: amt$local_file_name,
      p_command_list: ^clt$command_list,
      p_command_list_entry: ^clt$command_list_entry,
      system_library_searched: boolean,
      utility_block: ^clt$block;

    status.normal := TRUE;
    p_form_module := NIL;

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND

{
{ Do not search if we are running below ring 3.  In this case,
{ assume we did not find the form module in the library.
{

    IF caller_id.ring < osc$tsrv_ring THEN
      RETURN;
    IFEND;

    clp$find_command_list (p_command_list, ignore_cmnd_list_found_in_task);
    p_command_list_entry := p_command_list^.entries.first_entry;

    system_library_searched := FALSE;

    WHILE p_command_list_entry <> NIL DO
      CASE p_command_list_entry^.kind OF

      = clc$library_commands =
        IF p_command_list_entry^.library_contains.panels THEN
          local_library_name := p_command_list_entry^.local_file_name;
          find_form_name (caller_id.ring, form_name, local_library_name, p_form_module, status);
        IFEND;

      = clc$system_commands =
        IF (p_command_list^.system_command_library_lfn <> osc$null_name) AND
              p_command_list^.system_library_contains.panels THEN
          local_library_name := p_command_list^.system_command_library_lfn;
          find_form_name (caller_id.ring, form_name, local_library_name, p_form_module, status);
        IFEND;

        system_library_searched := TRUE;

      = clc$sub_commands =
        clp$find_utility_block (p_command_list_entry^.utility_name, utility_block,
              block_in_current_task);

        IF (utility_block <> NIL) AND block_in_current_task THEN
          IF utility_block^.command_environment.auxiliary_libraries <> NIL THEN
            FOR auxiliary_library_index := 1 TO UPPERBOUND (utility_block^.command_environment.
                  auxiliary_libraries^) DO
              IF utility_block^.command_environment.auxiliary_libraries^ [auxiliary_library_index].
                    contains.panels THEN
                local_library_name := utility_block^.command_environment.auxiliary_libraries^
                      [auxiliary_library_index].name;
                find_form_name (caller_id.ring, form_name, local_library_name, p_form_module, status);
                IF ((NOT status.normal) OR (p_form_module <> NIL)) THEN
                  RETURN;
                IFEND;
              IFEND;
            FOREND;
          IFEND;
        IFEND;

      ELSE
        ;
      CASEND;

      IF ((NOT status.normal) OR (p_form_module <> NIL)) THEN
        RETURN;
      IFEND;

      p_command_list_entry := p_command_list_entry^.next_entry;
    WHILEND;

    IF (NOT system_library_searched) AND (p_command_list^.system_command_library_lfn <> osc$null_name) AND
          p_command_list^.system_library_contains.panels THEN
      local_library_name := osc$null_name;
      find_form_name (caller_id.ring, form_name, local_library_name, p_form_module, status);
      IF ((NOT status.normal) OR (p_form_module <> NIL)) THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND clp$find_form;
?? TITLE := 'find_form_name', EJECT ??

  PROCEDURE find_form_name
    (    caller_ring: ost$valid_ring;
         form_name: ost$name;
     VAR local_file_name {input, output} : amt$local_file_name;
     VAR p_form_module: ^SEQ ( * );
     VAR status: ost$status);

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

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


      CASE condition.selector OF
      = mmc$segment_access_condition =
        IF condition.segment_access_condition.identifier = mmc$sac_io_read_error THEN
          osp$set_status_from_condition ('CL', condition, save_area, status, handler_status);
          EXIT find_form_name;
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          EXIT find_form_name;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? TITLE := 'search_form_directory', EJECT ??

    PROCEDURE [INLINE] search_form_directory;

      VAR
        index: llt$command_index,
        lower: llt$command_index,
        temp: integer,
        upper: -1 .. llc$max_commands_in_library;


      lower := 1;
      upper := UPPERBOUND (p_panel_dictionary^);

    /binary_search/
      WHILE (lower <= upper) DO
        temp := lower + upper;
        index := temp DIV 2;
        p_panel_dictionary_item := ^p_panel_dictionary^ [index];

        IF (form_name = p_panel_dictionary_item^.name) THEN
          p_library_member_header := #PTR (p_panel_dictionary_item^.panel_header, p_panel_sequence^);
          p_form_module := #PTR (p_library_member_header^.member, p_panel_sequence^);
          RESET p_form_module;
          RETURN;

        ELSEIF form_name > p_panel_dictionary_item^.name THEN
          lower := index + 1;

        ELSE
          upper := index - 1;
        IFEND;
      WHILEND /binary_search/;

    PROCEND search_form_directory;
?? OLDTITLE, EJECT ??

    VAR
      ignore_validated_file_name: fst$path_handle_name,
      index: llt$message_module_index,
      p_library_list_entry: ^clt$command_library_list_entry,
      p_library_member_header: ^llt$library_member_header,
      p_panel_dictionary: ^llt$panel_dictionary,
      p_panel_dictionary_item: ^llt$panel_dictionary_item,
      p_panel_sequence: ^SEQ ( * );


    status.normal := TRUE;
    p_library_list_entry := NIL;
    #SPOIL (p_library_list_entry);
    p_form_module := NIL;

    clp$open_command_library (caller_ring, local_file_name, p_library_list_entry, ignore_validated_file_name,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^abort_handler, FALSE);

    p_panel_dictionary := p_library_list_entry^.dictionaries.panel_dictionary;
    IF p_panel_dictionary = NIL THEN
      RETURN;
    IFEND;

    IF caller_ring > p_library_list_entry^.ring_attributes.r2 THEN
      RETURN;
    IFEND;

    p_panel_sequence := p_library_list_entry^.contents;
    search_form_directory;

  PROCEND find_form_name;
?? TITLE := 'clp$find_scl_proc_in_library', EJECT ??
*copyc clh$find_scl_proc_in_library

  PROCEDURE [XDCL, #GATE] clp$find_scl_proc_in_library
    (    object_library: ^SEQ ( * );
         object_library_name: amt$local_file_name;
         procedure_name: ost$name;
     VAR scl_procedure: ^clt$scl_procedure;
     VAR status: ost$status);

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

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


      CASE condition.selector OF
      = mmc$segment_access_condition =
        IF condition.segment_access_condition.identifier = mmc$sac_io_read_error THEN
          osp$set_status_from_condition ('CL', condition, save_area, status, handler_status);
          EXIT clp$find_scl_proc_in_library;
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          EXIT clp$find_scl_proc_in_library;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      command_dictionary_item: ^llt$command_dictionary_item,
      command_header: ^llt$library_member_header,
      function_dictionary_item: ^llt$function_dictionary_item,
      function_header: ^llt$library_member_header,
      i: llt$entry_point_index,
      ignore_status: ost$status,
      dictionaries: llt$library_dictionary_pointers,
      translated_procedure_name: ost$name;


    status.normal := TRUE;
    scl_procedure := NIL;

    osp$establish_condition_handler (^abort_handler, FALSE);
    pmp$get_library_dictionaries (object_library, dictionaries, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF dictionaries.library_version = 'V1.0' THEN
      PUSH dictionaries.command_dictionary: [1 .. UPPERBOUND (dictionaries.entry_point_dictionary^)];
      FOR i := 1 TO UPPERBOUND (dictionaries.entry_point_dictionary^) DO
        pmp$convert_entry_point_to_cmnd (dictionaries.entry_point_dictionary^ [i], i,
              dictionaries.command_dictionary^ [i]);
      FOREND;
    ELSEIF dictionaries.library_version > llc$object_library_version THEN
      osp$set_status_abnormal ('CL', lle$wrong_library_version, llc$object_library_version, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, object_library_name, status);
      RETURN;
    IFEND;

    #TRANSLATE (osv$lower_to_upper, procedure_name, translated_procedure_name);

    IF dictionaries.command_dictionary <> NIL THEN
      search_command_library (dictionaries.command_dictionary, translated_procedure_name,
            command_dictionary_item);
      IF command_dictionary_item <> NIL THEN
        command_header := #PTR (command_dictionary_item^.command_header, object_library^);
        scl_procedure := #PTR (command_header^.member, object_library^);
        RESET scl_procedure;
        RETURN;
      IFEND;
    IFEND;

    IF dictionaries.function_dictionary <> NIL THEN
      search_function_library (dictionaries.function_dictionary, translated_procedure_name,
            function_dictionary_item);
      IF function_dictionary_item <> NIL THEN
        function_header := #PTR (function_dictionary_item^.function_header, object_library^);
        scl_procedure := #PTR (function_header^.member, object_library^);
        RESET scl_procedure;
      IFEND;
    IFEND;

  PROCEND clp$find_scl_proc_in_library;
?? TITLE := 'initialize_library_contains', EJECT ??

  PROCEDURE [INLINE] initialize_library_contains
    (    library_list_entry: ^clt$command_library_list_entry;
     VAR library_contains: clt$command_library_contains);


    library_contains.commands := library_list_entry^.dictionaries.command_dictionary <> NIL;
    library_contains.functions := library_list_entry^.dictionaries.function_dictionary <> NIL;
    library_contains.help_modules := library_list_entry^.dictionaries.help_module_dictionary <> NIL;
    library_contains.message_modules := library_list_entry^.dictionaries.message_module_dictionary <> NIL;
    library_contains.panels := library_list_entry^.dictionaries.panel_dictionary <> NIL;

  PROCEND initialize_library_contains;
*IFEND

MODEND clm$command_list_manager;
*DECK DECK=CLM$COMMAND_STATS_RING_3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL INTERPRETER : Command Statistic Ring 3' ??
MODULE clm$command_stats_ring_3;

{ PURPOSE :
{   This module contains the ring 3 procedure necessary to get
{   the xcb information needed by the command resources statistic.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$command_resource_statistics
*copyc sfd$type_declarations
?? POP ??
*copyc clv$command_statistics_enabled
*copyc clv$secure_logging_activated
*copyc clv$log_secure_parameters
*copyc osp$system_error
*copyc pmp$find_executing_task_xcb
*copyc pmp$get_task_cp_time
*copyc syv$perf_keypoints_enabled

?? TITLE := 'clp$get_command_statistics', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$get_command_statistics
    (VAR cmd_statistics: clt$command_resource_statistics;
     VAR secure_logging: boolean;
     VAR stats_enabled: boolean;
     VAR command_performance_keypoints: boolean);

    VAR
      cp_time: pmt$task_cp_time,
      local_status: ost$status,
      xcb: ^ost$execution_control_block;

    local_status.normal := TRUE;

    secure_logging := clv$secure_logging_activated;
    stats_enabled := clv$command_statistics_enabled;
    command_performance_keypoints := syv$perf_keypoints_enabled.command_keypoints;

    IF NOT stats_enabled THEN
      RETURN;
    IFEND;

    pmp$find_executing_task_xcb (xcb);

    IF xcb = NIL THEN
      osp$system_error ('task XCB lost', NIL);
    IFEND;

    cmd_statistics.paging_statistics := xcb^.paging_statistics;

    pmp$get_task_cp_time (cp_time, local_status);

    IF local_status.normal THEN
      cmd_statistics.cptime := cp_time;
    ELSE
      cmd_statistics.cptime.task_time := 0;
      cmd_statistics.cptime.monitor_time := 0;
    IFEND;

  PROCEND clp$get_command_statistics;

?? TITLE := 'clp$get_log_secure_parameters', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$get_log_secure_parameters
    (VAR log_secure_parameters: boolean);


    log_secure_parameters := clv$log_secure_parameters;

  PROCEND clp$get_log_secure_parameters;

MODEND clm$command_stats_ring_3;
*DECK DECK=CLM$COMMAND_UTILITY_HELPER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Command Utility Helper Routines' ??
MODULE clm$command_utility_helper;

{
{ PURPOSE:
{   This module contains the procedures that help the command utility manager to create and change
{   utility block information.
{
{ DESIGN:
{   Attributes defined for a utility are validated and then used to create a utility's environment or
{   change a utility's environment.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_command_processing
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_utilities
*copyc clt$utility_attributes
*copyc ost$caller_identifier
*copyc ost$name_reference
?? POP ??
*copyc clp$add_utility_to_command_list
*copyc clp$close_command_library
*IF NOT $true(osv$unix)
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_file
*IFEND
*copyc clp$find_current_block
*copyc clp$find_task_block
*copyc clp$find_utility_block
*copyc clp$get_command_search_mode
*copyc clp$open_command_library
*copyc clp$pop_block_stack
*copyc clp$push_utility_block
*copyc clp$search_command_table
*IF $true(osv$unix)
*copyc clt$command_name
*copyc clt$command_table
*copyc clt$command_table_index
*IFEND
*copyc clp$set_prompt_string
*copyc clp$validate_name
*IF NOT $true(osv$unix)
*copyc mmp$create_segment
*IFEND
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc osv$task_shared_heap

?? TITLE := 'clp$create_utility_environment', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$create_utility_environment
    (    name: clt$utility_name;
         defined_at_command_level: boolean;
         called_from_push_utility: boolean;
         attributes: clt$utility_attributes;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      caller_id: ost$caller_identifier,
      ignore_status: ost$status,
      index: integer,
      index_string: ost$string,
      library_names: ^array [1 .. * ] of fst$path_handle_name,
      name_is_valid: boolean,
      number_of_attributes: integer,
      prompt_size: ost$name_size,
      task_block: ^clt$block,
      termination_command_ordinal: clt$named_entry_ordinal,
      termination_command_index: clt$command_table_index,
      validated_utility_name: ost$name;


    status.normal := TRUE;
    block := NIL;

    clp$validate_name (name, validated_utility_name, name_is_valid);
    IF (NOT name_is_valid) OR (validated_utility_name = 'JOB') OR (validated_utility_name = 'LOCAL') OR
          (validated_utility_name = 'XDCL') OR (validated_utility_name = 'XREF') OR (validated_utility_name =
          'ALL') OR (validated_utility_name = 'NONE') THEN
      osp$set_status_abnormal ('CL', cle$improper_utility_name, name, status);
      RETURN;
    IFEND;
    number_of_attributes := UPPERBOUND (attributes);

    FOR index := 1 TO number_of_attributes DO
      IF (attributes [index].key = clc$utility_name) OR ((attributes [index].key = clc$utility_libraries) AND
            (NOT defined_at_command_level)) THEN
*IF NOT $true(osv$unix)
        clp$convert_integer_to_string (index, 10, FALSE, index_string, ignore_status);
        IF status.normal THEN
          osp$set_status_abnormal ('CL', cle$improper_utility_attribute, index_string.
                value (1, index_string.size), status);
        ELSE
          osp$append_status_parameter (',', index_string.value (1, index_string.size), status);
        IFEND;
*ELSE
        osp$set_status_abnormal ('CL', cle$improper_utility_attribute, '', status);
*IFEND
      IFEND;
    FOREND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND
    validate_utility_attributes (caller_id.ring, defined_at_command_level, called_from_push_utility,
          attributes, NIL, 'QUIT', termination_command_ordinal, termination_command_index, library_names,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$find_task_block (task_block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /create_utility/
    BEGIN
      clp$push_utility_block (validated_utility_name, block);
      block^.command_environment.task_id := task_block^.task_id;
      block^.command_environment.libraries := library_names;
      block^.command_environment.command_level := defined_at_command_level;
      block^.command_environment.termination_command_ordinal := termination_command_ordinal;
      block^.command_environment.termination_command_index := termination_command_index;

      prompt_size := STRLENGTH (validated_utility_name);
      IF prompt_size > clc$max_prompt_size THEN
        block^.prompt.size := clc$max_prompt_size;
      ELSE
        block^.prompt.size := prompt_size;
      IFEND;
      block^.prompt.value := validated_utility_name (1, block^.prompt.size);

      FOR index := 1 TO number_of_attributes DO
        CASE attributes [index].key OF

        = clc$null_utility_attribute =
          ;

        = clc$utility_command_search_mode =
          block^.command_search_mode := attributes [index].command_search_mode;

        = clc$utility_command_table =
          IF block^.command_environment.commands <> NIL THEN
            FREE block^.command_environment.commands IN osv$task_shared_heap^;
          IFEND;
          IF attributes [index].command_table = NIL THEN
            block^.command_environment.commands := NIL;
          ELSE
            ALLOCATE block^.command_environment.commands: [1 .. UPPERBOUND (attributes [index].
                  command_table^)] IN osv$task_shared_heap^;
            block^.command_environment.commands^ := attributes [index].command_table^;
          IFEND;

        = clc$utility_function_table =
          IF block^.command_environment.original_functions <> NIL THEN
            FREE block^.command_environment.original_functions IN osv$task_shared_heap^;
          IFEND;
          IF attributes [index].function_table = NIL THEN
            block^.command_environment.original_functions := NIL;
          ELSE
            ALLOCATE block^.command_environment.original_functions:
                  [1 .. UPPERBOUND (attributes [index].function_table^)] IN osv$task_shared_heap^;
            block^.command_environment.original_functions^ := attributes [index].function_table^;
          IFEND;

        = clc$utility_function_proc_table =
          IF block^.command_environment.contemporary_functions <> NIL THEN
            FREE block^.command_environment.contemporary_functions IN osv$task_shared_heap^;
          IFEND;
          IF attributes [index].function_processor_table = NIL THEN
            block^.command_environment.contemporary_functions := NIL;
          ELSE
            ALLOCATE block^.command_environment.contemporary_functions:
                  [1 .. UPPERBOUND (attributes [index].function_processor_table^)] IN osv$task_shared_heap^;
            block^.command_environment.contemporary_functions^ := attributes [index].
                  function_processor_table^;
          IFEND;

        = clc$utility_interactive_include =
          block^.interactive_include_processor := attributes [index].interactive_include_processor;

        = clc$utility_libraries =
          IF block^.libraries <> NIL THEN
            FREE block^.libraries IN osv$task_shared_heap^;
          IFEND;
          IF attributes [index].libraries <> NIL THEN
            ALLOCATE block^.libraries: [1 .. UPPERBOUND (attributes [index].libraries^)] IN
                  osv$task_shared_heap^;
            block^.libraries^ := attributes [index].libraries^;
          IFEND;

        = clc$utility_line_preprocessor =
          block^.line_preprocessor := attributes [index].line_preprocessor;

        = clc$utility_online_manual =
          #TRANSLATE (osv$lower_to_upper, attributes [index].online_manual_name, block^.online_manual_name);

        = clc$utility_prompt =
          block^.prompt := attributes [index].prompt;

        = clc$utility_subcmnd_log_enabled =
          block^.command_environment.subcommand_logging_enabled :=
                attributes [index].subcommand_logging_enabled;

        = clc$utility_termination_command =
          ;

        ELSE

{ Should never get here.

*IF NOT $true(osv$unix)
          clp$convert_integer_to_string (index, 10, FALSE, index_string, status);
          osp$set_status_abnormal ('CL', cle$improper_utility_attribute, index_string.
                value (1, index_string.size), status);
*ELSE
          osp$set_status_abnormal ('CL', cle$improper_utility_attribute, '', status);
*IFEND
          EXIT /create_utility/;
        CASEND;
      FOREND;

      clp$add_utility_to_command_list (block, status);

    END /create_utility/;

    IF NOT status.normal THEN
      IF block^.command_environment.commands <> NIL THEN
        FREE block^.command_environment.commands IN osv$task_shared_heap^;
      IFEND;
      IF block^.command_environment.original_functions <> NIL THEN
        FREE block^.command_environment.original_functions IN osv$task_shared_heap^;
      IFEND;
      IF block^.command_environment.contemporary_functions <> NIL THEN
        FREE block^.command_environment.contemporary_functions IN osv$task_shared_heap^;
      IFEND;
      IF block^.command_environment.libraries <> NIL THEN
        release_libraries (UPPERBOUND (block^.command_environment.libraries^),
              block^.command_environment.libraries);
      IFEND;
      IF block^.libraries <> NIL THEN
        FREE block^.libraries IN osv$task_shared_heap^;
      IFEND;
      clp$pop_block_stack (block);
    IFEND;

  PROCEND clp$create_utility_environment;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$change_utility_environment', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$change_utility_environment
    (    name: clt$utility_name;
         defined_at_command_level: boolean;
         attributes: clt$utility_attributes;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      block_in_current_task: boolean,
      caller_id: ost$caller_identifier,
      change_input_blocks: boolean,
      current_block: ^clt$block,
      default_termination_command: clt$command_name,
      ignore_library_names: ^array [1 .. * ] of fst$path_handle_name,
      ignore_status: ost$status,
      index: integer,
      index_string: ost$string,
      name_is_valid: boolean,
      number_of_attributes: integer,
      repeat_block: ^clt$block,
      termination_command_ordinal: clt$named_entry_ordinal,
      termination_command_index: clt$command_table_index,
      validated_utility_name: clt$utility_name;


    status.normal := TRUE;
    block := NIL;

    clp$validate_name (name, validated_utility_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal ('CL', cle$improper_utility_name, name, status);
      RETURN;
    IFEND;

    clp$find_utility_block (validated_utility_name, block, block_in_current_task);
    IF block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unknown_utility, name, status);
      RETURN;
    ELSEIF defined_at_command_level THEN
      IF NOT block^.command_environment.command_level THEN
        osp$set_status_abnormal ('CL', cle$inaccessible_utility, name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'CHANGE_UTILITY_ATTRIBUTES', status);
        RETURN;
      IFEND;
    ELSE
      IF (block^.command_environment.command_level OR (NOT block_in_current_task)) THEN
        osp$set_status_abnormal ('CL', cle$inaccessible_utility, name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'CHANGE_UTILITY_ATTRIBUTES', status);
        RETURN;
      IFEND;
    IFEND;
    number_of_attributes := UPPERBOUND (attributes);

    FOR index := 1 TO number_of_attributes DO
      CASE attributes [index].key OF
      = clc$utility_command_search_mode, clc$utility_libraries, clc$utility_name,
            clc$utility_termination_command =
        clp$convert_integer_to_string (index, 10, FALSE, index_string, ignore_status);
        IF status.normal THEN
          osp$set_status_abnormal ('CL', cle$improper_utility_attribute, index_string.
                value (1, index_string.size), status);
        ELSE
          osp$append_status_parameter (',', index_string.value (1, index_string.size), status);
        IFEND;
      ELSE
        ;
      CASEND;
    FOREND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF block^.command_environment.commands = NIL THEN
      default_termination_command := 'QUIT';
    ELSE
      default_termination_command := block^.command_environment.
            commands^ [block^.command_environment.termination_command_index].name;
    IFEND;
*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND
    validate_utility_attributes (caller_id.ring, defined_at_command_level, FALSE, attributes,
          block^.command_environment.commands, default_termination_command, termination_command_ordinal,
          termination_command_index, ignore_library_names, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    block^.command_environment.termination_command_ordinal := termination_command_ordinal;
    block^.command_environment.termination_command_index := termination_command_index;

    clp$find_current_block (current_block);

    FOR index := 1 TO number_of_attributes DO
      CASE attributes [index].key OF

      = clc$null_utility_attribute =
        ;

      = clc$utility_command_table =
        IF block^.command_environment.commands <> NIL THEN
          FREE block^.command_environment.commands IN osv$task_shared_heap^;
        IFEND;
        IF attributes [index].command_table = NIL THEN
          block^.command_environment.commands := NIL;
        ELSE
          ALLOCATE block^.command_environment.commands: [1 .. UPPERBOUND (attributes [index].
                command_table^)] IN osv$task_shared_heap^;
          block^.command_environment.commands^ := attributes [index].command_table^;
        IFEND;

      = clc$utility_function_table =
        IF block^.command_environment.original_functions <> NIL THEN
          FREE block^.command_environment.original_functions IN osv$task_shared_heap^;
        IFEND;
        IF attributes [index].function_table = NIL THEN
          block^.command_environment.original_functions := NIL;
        ELSE
          ALLOCATE block^.command_environment.original_functions:
                [1 .. UPPERBOUND (attributes [index].function_table^)] IN osv$task_shared_heap^;
          block^.command_environment.original_functions^ := attributes [index].function_table^;
        IFEND;

      = clc$utility_function_proc_table =
        IF block^.command_environment.contemporary_functions <> NIL THEN
          FREE block^.command_environment.contemporary_functions IN osv$task_shared_heap^;
        IFEND;
        IF attributes [index].function_processor_table = NIL THEN
          block^.command_environment.contemporary_functions := NIL;
        ELSE
          ALLOCATE block^.command_environment.contemporary_functions:
                [1 .. UPPERBOUND (attributes [index].function_processor_table^)] IN osv$task_shared_heap^;
          block^.command_environment.contemporary_functions^ := attributes [index].function_processor_table^;
        IFEND;

      = clc$utility_interactive_include =
        block^.interactive_include_processor := attributes [index].interactive_include_processor;

      = clc$utility_line_preprocessor =
        change_input_blocks := FALSE;
        IF block^.line_preprocessor.call_method = clc$unspecified_call THEN
          IF attributes [index].line_preprocessor.call_method <> clc$unspecified_call THEN
            change_input_blocks := TRUE;
          IFEND;
        ELSEIF attributes [index].line_preprocessor.call_method = clc$unspecified_call THEN
          change_input_blocks := TRUE;
        IFEND;

        block^.line_preprocessor := attributes [index].line_preprocessor;

        IF change_input_blocks THEN
          repeat_block := current_block;
          REPEAT
            IF (repeat_block^.kind = clc$input_block) AND (repeat_block^.associated_utility = block) THEN
              repeat_block^.line_preprocessor_specified := attributes [index].line_preprocessor.call_method <>
                    clc$unspecified_call;
            IFEND;
            IF NOT (repeat_block = block) THEN
              repeat_block := repeat_block^.previous_block;
            IFEND;
          UNTIL repeat_block = block;
        IFEND;

      = clc$utility_online_manual =
        #TRANSLATE (osv$lower_to_upper, attributes [index].online_manual_name, block^.online_manual_name);

      = clc$utility_prompt =
        IF block^.prompt <> attributes [index].prompt THEN
          block^.prompt := attributes [index].prompt;
          repeat_block := current_block;
          REPEAT
            IF (repeat_block^.kind = clc$input_block) AND (repeat_block^.associated_utility = block) AND
                  (repeat_block^.input.interactive_device) THEN
              CASE repeat_block^.input.kind OF
              = clc$file_input, clc$sequence_input =
                clp$set_prompt_string (repeat_block, attributes [index].prompt.value (1,
                      attributes [index].prompt.size));
              ELSE
                ;
              CASEND;
            IFEND;
            IF NOT (repeat_block = block) THEN
              repeat_block := repeat_block^.previous_block;
            IFEND;
          UNTIL repeat_block = block;
        IFEND;

      = clc$utility_subcmnd_log_enabled =
        block^.command_environment.subcommand_logging_enabled := attributes [index].
              subcommand_logging_enabled;

      ELSE

{ Should never get here.

        clp$convert_integer_to_string (index, 10, FALSE, index_string, status);
        osp$set_status_abnormal ('CL', cle$improper_utility_attribute, index_string.
              value (1, index_string.size), status);
        RETURN;
      CASEND;
    FOREND;

  PROCEND clp$change_utility_environment;
?? TITLE := 'clp$store_utility_dialog_info', EJECT ??
*copyc clh$store_utility_dialog_info

  PROCEDURE [XDCL, #GATE] clp$store_utility_dialog_info
    (    utility: clt$utility_name;
         commands: ^clt$command_table;
         functions: ^clt$function_processor_table;
         create_scratch_segment: boolean;
     VAR dialog_info: ^clt$utility_dialog_info;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      block_in_current_task: boolean,
      caller_id: ost$caller_identifier,
      name_is_valid: boolean,
      segment_attributes: array [1 .. 1] of mmt$attribute_descriptor,
      segment_pointer: mmt$segment_pointer,
      validated_utility_name: clt$utility_name;


    status.normal := TRUE;
    dialog_info := NIL;

*IF NOT $true(osv$unix)
    clp$validate_name (utility, validated_utility_name, name_is_valid);
*ELSE
    clp$validate_name (name, validated_utility_name, name_is_valid);
*IFEND
    IF NOT name_is_valid THEN
      osp$set_status_abnormal ('CL', cle$improper_utility_name, utility, status);
      RETURN;
    IFEND;

    clp$find_utility_block (validated_utility_name, block, block_in_current_task);
    IF block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unknown_utility, utility, status);
      RETURN;
    ELSEIF NOT (block^.command_environment.command_level OR block_in_current_task) THEN
      osp$set_status_abnormal ('CL', cle$inaccessible_utility, utility, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'CLP$STORE_UTILITY_DIALOG_INFO', status);
      RETURN;
    IFEND;

    IF block^.command_environment.dialog_info.commands <> NIL THEN
      FREE block^.command_environment.dialog_info.commands IN osv$task_shared_heap^;
    IFEND;
    IF commands = NIL THEN
      block^.command_environment.dialog_info.commands := NIL;
    ELSE
      ALLOCATE block^.command_environment.dialog_info.commands: [1 .. UPPERBOUND (commands^)] IN
            osv$task_shared_heap^;
      block^.command_environment.dialog_info.commands^ := commands^;
    IFEND;

    IF block^.command_environment.dialog_info.functions <> NIL THEN
      FREE block^.command_environment.dialog_info.functions IN osv$task_shared_heap^;
    IFEND;
    IF functions = NIL THEN
      block^.command_environment.dialog_info.functions := NIL;
    ELSE
      ALLOCATE block^.command_environment.dialog_info.functions: [1 .. UPPERBOUND (functions^)] IN
            osv$task_shared_heap^;
      block^.command_environment.dialog_info.functions^ := functions^;
    IFEND;

    IF create_scratch_segment AND (block^.command_environment.dialog_info.scratch_segment = NIL) THEN
*IF NOT $true(osv$unix)
      #CALLER_ID (caller_id);
*ELSE
      caller_id.ring := osc$user_ring;
*IFEND
      segment_attributes [1].keyword := mmc$kw_ring_numbers;
      segment_attributes [1].r1 := caller_id.ring;
      segment_attributes [1].r2 := osc$user_ring_2;
      mmp$create_segment (^segment_attributes, mmc$sequence_pointer, caller_id.ring, segment_pointer, status);
      IF NOT status.normal THEN
        IF block^.command_environment.dialog_info.commands <> NIL THEN
          FREE block^.command_environment.dialog_info.commands IN osv$task_shared_heap^;
        IFEND;
        IF block^.command_environment.dialog_info.functions <> NIL THEN
          FREE block^.command_environment.dialog_info.functions IN osv$task_shared_heap^;
        IFEND;
        RETURN;
      IFEND;
      block^.command_environment.dialog_info.scratch_segment := segment_pointer.seq_pointer;
    IFEND;

    dialog_info := ^block^.command_environment.dialog_info;

  PROCEND clp$store_utility_dialog_info;
?? TITLE := 'clp$add_auxiliary_utility_lib', EJECT ??
*copyc clh$add_auxiliary_utility_lib

  PROCEDURE [XDCL, #GATE] clp$add_auxiliary_utility_lib
    (    utility: clt$utility_name;
         library: fst$file_reference;
         checkout_library: fst$file_reference;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      block_in_current_task: boolean,
      caller_id: ost$caller_identifier,
      name_is_valid: boolean,
      search_mode: clt$command_search_modes,
      validated_utility_name: clt$utility_name;

?? TITLE := 'add_auxiliary_library', EJECT ??

    PROCEDURE add_auxiliary_library
      (    library: fst$file_reference;
       VAR status: ost$status);

      VAR
        file: clt$file,
        i: integer,
        library_list_entry: ^clt$command_library_list_entry,
        new_auxiliary_libraries: ^clt$utility_auxiliary_libraries,
        path_handle_name: fst$path_handle_name;


      clp$convert_string_to_file (library, file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$open_command_library (caller_id.ring, file.local_file_name, library_list_entry, path_handle_name,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF block^.command_environment.auxiliary_libraries = NIL THEN
        ALLOCATE new_auxiliary_libraries: [1 .. 1] IN osv$task_shared_heap^;
      ELSE
        FOR i := 1 TO UPPERBOUND (block^.command_environment.auxiliary_libraries^) DO
          IF block^.command_environment.auxiliary_libraries^ [i].name = path_handle_name THEN
            RETURN;
          IFEND;
        FOREND;
        ALLOCATE new_auxiliary_libraries: [1 .. UPPERBOUND (block^.command_environment.auxiliary_libraries^) +
              1] IN osv$task_shared_heap^;
        FOR i := 1 TO UPPERBOUND (block^.command_environment.auxiliary_libraries^) DO
          new_auxiliary_libraries^ [i + 1] := block^.command_environment.auxiliary_libraries^ [i];
        FOREND;
        FREE block^.command_environment.auxiliary_libraries IN osv$task_shared_heap^;
      IFEND;

      new_auxiliary_libraries^ [1].name := path_handle_name;
      new_auxiliary_libraries^ [1].contains.commands :=
            library_list_entry^.dictionaries.command_dictionary <> NIL;
      new_auxiliary_libraries^ [1].contains.functions :=
            library_list_entry^.dictionaries.function_dictionary <> NIL;
      new_auxiliary_libraries^ [1].contains.help_modules :=
            library_list_entry^.dictionaries.help_module_dictionary <> NIL;
      new_auxiliary_libraries^ [1].contains.message_modules :=
            library_list_entry^.dictionaries.message_module_dictionary <> NIL;
      new_auxiliary_libraries^ [1].contains.panels :=
            library_list_entry^.dictionaries.panel_dictionary <> NIL;

      block^.command_environment.auxiliary_libraries := new_auxiliary_libraries;

    PROCEND add_auxiliary_library;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

*IF NOT $true(osv$unix)
    clp$validate_name (utility, validated_utility_name, name_is_valid);
*ELSE
    clp$validate_name (name, validated_utility_name, name_is_valid);
*IFEND
    IF NOT name_is_valid THEN
      osp$set_status_abnormal ('CL', cle$improper_utility_name, utility, status);
      RETURN;
    IFEND;

    clp$find_utility_block (validated_utility_name, block, block_in_current_task);
    IF block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unknown_utility, utility, status);
      RETURN;
    ELSEIF NOT (block^.command_environment.command_level OR block_in_current_task) THEN
      osp$set_status_abnormal ('CL', cle$inaccessible_utility, utility, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'CLP$ADD_AUXILIARY_COMMAND_LIB', status);
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND

    add_auxiliary_library (library, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_command_search_mode (search_mode);

    IF (checkout_library = '') OR (checkout_library = library) OR
          (search_mode <> clc$global_command_search) THEN
      RETURN;
    IFEND;

    add_auxiliary_library (checkout_library, status);
    status.normal := TRUE {ignore status from attempt to add checkout library} ;

  PROCEND clp$add_auxiliary_utility_lib;
*IFEND
?? TITLE := 'validate_utility_attributes', EJECT ??

  PROCEDURE validate_utility_attributes
    (    caller_ring: ost$valid_ring;
         defined_at_command_level: boolean;
         called_from_push_utility: boolean;
         attributes: clt$utility_attributes;
         default_command_table: ^clt$command_table;
         default_termination_command: ost$name_reference;
     VAR termination_command_ordinal: clt$named_entry_ordinal;
     VAR termination_command_index: clt$command_table_index;
     VAR library_names: ^array [1 .. * ] of fst$path_handle_name;
     VAR status: ost$status);

    VAR
      file: clt$file,
      functions_given: boolean,
      index: integer,
      index_string: ost$string,
      i: integer,
      ignore_library_list_entry: ^clt$command_library_list_entry,
      ignore_status: ost$status,
      number_of_libraries: integer,
      validated_name: ost$name,
      command_table: ^clt$command_table,
      termination_command: clt$command_name,
      termination_command_defined: boolean,
      attribute_key_is_good: boolean,
      attribute_value_is_good: boolean;


    status.normal := TRUE;
    library_names := NIL;
    functions_given := FALSE;
    command_table := default_command_table;
    termination_command := default_termination_command;

{ The same attribute key can be specified more than once.  The last one specified
{ is used.

  /validate_attributes/
    FOR index := 1 TO UPPERBOUND (attributes) DO
      attribute_key_is_good := TRUE;
      attribute_value_is_good := TRUE;

      CASE attributes [index].key OF

      = clc$null_utility_attribute =
        ;

      = clc$utility_command_search_mode =
        IF (attributes [index].command_search_mode < LOWERVALUE (clt$command_search_modes)) OR
              (attributes [index].command_search_mode > UPPERVALUE (clt$command_search_modes)) THEN
          attribute_value_is_good := FALSE;
        IFEND;

      = clc$utility_command_table =
        command_table := attributes [index].command_table;

      = clc$utility_function_table =
        IF (attributes [index].function_table <> NIL) AND defined_at_command_level THEN
          osp$set_status_abnormal ('CL', cle$not_yet_implemented, 'Command level functions', status);
          EXIT /validate_attributes/;
        IFEND;

      = clc$utility_function_proc_table =
        ;

      = clc$utility_interactive_include =
        IF (attributes [index].interactive_include_processor.call_method < LOWERVALUE (clt$call_method)) OR
              (attributes [index].interactive_include_processor.call_method > UPPERVALUE (clt$call_method))
              THEN
          attribute_value_is_good := FALSE;
        ELSE
          CASE attributes [index].interactive_include_processor.call_method OF
          = clc$proc_call, clc$program_call =

{ This error will be removed when an interactive include processor proc or
{ program call method is implemented.

            osp$set_status_abnormal ('CL', cle$not_yet_implemented,
                  'interactive include processor call method clc$proc_call/clc$program_call', status);
            EXIT /validate_attributes/;
          ELSE
            ;
          CASEND;
        IFEND;

      = clc$utility_libraries =
        IF library_names <> NIL THEN
          release_libraries (UPPERBOUND (library_names^), library_names);
        IFEND;

        IF attributes [index].libraries <> NIL THEN
          number_of_libraries := 0;
          FOR i := 1 TO UPPERBOUND (attributes [index].libraries^) DO
            IF attributes [index].libraries^ [i] <> '' THEN
              number_of_libraries := number_of_libraries + 1;
            IFEND;
          FOREND;

          IF number_of_libraries > 0 THEN
            ALLOCATE library_names: [1 .. number_of_libraries] IN osv$task_shared_heap^;
            number_of_libraries := 0;

          /validate_libraries/
            FOR i := 1 TO UPPERBOUND (attributes [index].libraries^) DO
              IF attributes [index].libraries^ [i] <> '' THEN
                number_of_libraries := number_of_libraries + 1;
*IF NOT $true(osv$unix)
                clp$convert_string_to_file (attributes [index].libraries^ [i], file, status);
                IF NOT status.normal THEN
                  attribute_value_is_good := FALSE;
                  number_of_libraries := number_of_libraries - 1;
                  EXIT /validate_libraries/;
                IFEND;
                clp$open_command_library (caller_ring, file.local_file_name, ignore_library_list_entry,
                      library_names^ [number_of_libraries], status);
                IF NOT status.normal THEN
                  attribute_value_is_good := FALSE;
                  number_of_libraries := number_of_libraries - 1;
                  EXIT /validate_libraries/;
                IFEND;
*ELSE
                library_names^ [number_of_libraries] := attributes [index].libraries^ [i];
*IFEND
              IFEND;
            FOREND /validate_libraries/;
          IFEND;
        IFEND;

      = clc$utility_line_preprocessor =
        IF (attributes [index].line_preprocessor.call_method < LOWERVALUE (clt$call_method)) OR
              (attributes [index].line_preprocessor.call_method > UPPERVALUE (clt$call_method)) THEN
          attribute_value_is_good := FALSE;
        ELSE
          CASE attributes [index].line_preprocessor.call_method OF
          = clc$proc_call, clc$program_call =

{ This error will be removed when a line preprocessor proc or program call method is implemented.

            osp$set_status_abnormal ('CL', cle$not_yet_implemented,
                  'line preprocessor call method clc$proc_call/clc$program_call', status);
            EXIT /validate_attributes/;
          ELSE
            ;
          CASEND;
        IFEND;

      = clc$utility_name =
        clp$validate_name (attributes [index].name, validated_name, attribute_value_is_good);

      = clc$utility_online_manual =
        IF attributes [index].online_manual_name <> osc$null_name THEN
          clp$validate_name (attributes [index].online_manual_name, validated_name, attribute_value_is_good);
        IFEND;

      = clc$utility_prompt =
        IF (attributes [index].prompt.size < LOWERVALUE (clt$prompt_size)) OR
              (attributes [index].prompt.size > UPPERVALUE (clt$prompt_size)) THEN
          attribute_value_is_good := FALSE;
        IFEND;

      = clc$utility_subcmnd_log_enabled =
        IF (attributes [index].subcommand_logging_enabled < LOWERVALUE (boolean)) OR
              (attributes [index].subcommand_logging_enabled > UPPERVALUE (boolean)) THEN
          attribute_value_is_good := FALSE;
        IFEND;

      = clc$utility_termination_command =
        IF attributes [index].termination_command <> osc$null_name THEN
          clp$validate_name (attributes [index].termination_command, termination_command,
                attribute_value_is_good);
        IFEND;

      ELSE
        attribute_key_is_good := FALSE;
      CASEND;

      IF NOT attribute_key_is_good THEN
*IF NOT $true(osv$unix)
        clp$convert_integer_to_string (index, 10, FALSE, index_string, ignore_status);
        IF status.normal OR (status.condition <> cle$unknown_utility_attribute) THEN
          osp$set_status_abnormal ('CL', cle$unknown_utility_attribute, index_string.
                value (index_string.size), status);
        ELSE
          osp$append_status_parameter (',', index_string.value (1, index_string.size), status);
        IFEND;
*ELSE
        osp$set_status_abnormal ('CL', cle$unknown_utility_attribute, '', status);
*IFEND
      ELSEIF NOT attribute_value_is_good THEN
*IF NOT $true(osv$unix)
        clp$convert_integer_to_string (index, 10, FALSE, index_string, ignore_status);
        IF status.normal THEN
          osp$set_status_abnormal ('CL', cle$improper_utility_attr_value, index_string.
                value (index_string.size), status);
        ELSEIF status.condition = cle$improper_utility_attr_value THEN
          osp$append_status_parameter (',', index_string.value (1, index_string.size), status);
        IFEND;
*ELSE
        osp$set_status_abnormal ('CL', cle$improper_utility_attr_value, '', status);
*IFEND
      IFEND;
    FOREND /validate_attributes/;

    IF status.normal THEN
      termination_command_ordinal := UPPERVALUE (termination_command_ordinal);
      termination_command_index := UPPERVALUE (termination_command_index);
      IF command_table <> NIL THEN
        clp$search_command_table (termination_command, command_table, termination_command_index,
              termination_command_defined);
        IF termination_command_defined THEN
          termination_command_ordinal := command_table^ [termination_command_index].ordinal;
        ELSEIF NOT called_from_push_utility THEN
          osp$set_status_abnormal ('CL', cle$term_command_not_defined, termination_command, status);
        IFEND;
      IFEND;
    IFEND;

    IF (NOT status.normal) AND (library_names <> NIL) THEN
      release_libraries (number_of_libraries, library_names);
    IFEND;

  PROCEND validate_utility_attributes;
?? TITLE := 'release_libraries', EJECT ??

  PROCEDURE release_libraries
    (    count: integer;
     VAR libraries {input, output} : ^array [1 .. * ] of fst$path_handle_name);

    VAR
      i: integer,
      ignore_status: ost$status,
      local_libraries: ^array [1 .. * ] of fst$path_handle_name;


    local_libraries := libraries;
    libraries := NIL;

    FOR i := 1 TO count DO
      clp$close_command_library (local_libraries^ [i], ignore_status);
    FOREND;

    FREE local_libraries IN osv$task_shared_heap^;

  PROCEND release_libraries;
?? TITLE := 'clp$set_include_processor_state', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_include_processor_state
    (    name: clt$utility_name;
         active: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      ignore_block_in_current_task: boolean,
      name_is_valid: boolean,
      validated_utility_name: clt$utility_name;

    status.normal := TRUE;
    block := NIL;

    clp$validate_name (name, validated_utility_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal ('CL', cle$improper_utility_name, name, status);
      RETURN;
    IFEND;

    clp$find_utility_block (validated_utility_name, block, ignore_block_in_current_task);
    IF block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unknown_utility, name, status);
      RETURN;
    IFEND;

    block^.include_processor_active := active;

  PROCEND clp$set_include_processor_state;

MODEND clm$command_utility_helper;
*DECK DECK=CLM$COMMAND_UTILITY_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Command Utility Manager' ??
MODULE clm$command_utility_manager;

{
{ PURPOSE:
{   This module contains the procedures that manage the entries for command utilities on the block stack.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_utilities
*copyc cle$unexpected_call_to
*IF NOT $true(osv$unix)
*copyc clk$begin_utility
*copyc clk$change_utility_attributes
*copyc clk$end_utility
*copyc clk$get_command_origin
*copyc clk$get_utility_attributes
*copyc clk$pop_utility
*copyc clk$push_utility
*IFEND
*copyc clt$command_search_modes
*copyc clt$command_table
*copyc clt$function_table
*copyc clt$utility_attributes
*copyc clt$utility_dialog_info
*copyc clt$utility_name
*copyc ost$name
*copyc ost$status
?? POP ??
*IF NOT $true(osv$unix)
*copyc clp$change_utility_environment
*copyc clp$convert_integer_to_string
*IFEND
*copyc clp$create_utility_environment
*copyc clp$find_current_block
*copyc clp$find_external_input_block
*copyc clp$find_utility_block
*copyc clp$pop_block_stack
*copyc clp$validate_name
*copyc osp$append_status_parameter
*IF NOT $true(osv$unix)
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*IFEND
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*IF NOT $true(osv$unix)
*copyc osv$initial_exception_context
*IFEND

?? TITLE := 'clp$begin_utility', EJECT ??
*copyc clh$begin_utility

  PROCEDURE [XDCL, #GATE] clp$begin_utility
    (    name: clt$utility_name;
         attributes: clt$utility_attributes;
     VAR status: ost$status);


*IF NOT $true(osv$unix)
    VAR
      context: ^ost$ecp_exception_context;

    #KEYPOINT (osk$entry, 0, clk$begin_utility);
*IFEND

    status.normal := TRUE;
    context := NIL;

*IF NOT $true(osv$unix)
    REPEAT
      clp$create_utility_environment (name, FALSE, FALSE, attributes, status);
      IF osp$file_access_condition (status) THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, clk$begin_utility);
*ELSE
    clp$create_utility_environment (name, FALSE, FALSE, attributes, status);
*IFEND


  PROCEND clp$begin_utility;
?? TITLE := 'clp$end_utility', EJECT ??
*copyc clh$end_utility

  PROCEDURE [XDCL, #GATE] clp$end_utility
    (    name: clt$utility_name;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      name_is_valid: boolean,
      validated_utility_name: clt$utility_name;


*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, 0, clk$end_utility);
*IFEND

    status.normal := TRUE;

    IF name = osc$null_name THEN
      osp$set_status_abnormal ('CL', cle$improper_utility_name, name, status);
      RETURN;
    IFEND;
    clp$validate_name (name, validated_utility_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal ('CL', cle$improper_utility_name, name, status);
      RETURN;
    IFEND;

    clp$find_current_block (block);
    IF NOT ((block^.kind = clc$utility_block) AND (block^.label = validated_utility_name)) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$end_utility', status);
    ELSE
      clp$pop_block_stack (block);
    IFEND;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, 0, clk$end_utility);
*IFEND

  PROCEND clp$end_utility;
?? TITLE := 'clp$push_utility', EJECT ??
*copyc clh$push_utility

  PROCEDURE [XDCL, #GATE] clp$push_utility
    (    utility_name: ost$name;
         search_mode: clt$command_search_modes;
         commands: ^clt$command_table;
         functions: ^clt$function_table;
     VAR status: ost$status);

    VAR
      attributes: array [1 .. 3] of clt$utility_attribute;


*IF NOT $true(osv$unix)
    VAR
      context: ^ost$ecp_exception_context;

    #KEYPOINT (osk$entry, 0, clk$push_utility);

    context := NIL;
*IFEND

    status.normal := TRUE;

    attributes [1].key := clc$utility_command_search_mode;
    attributes [1].command_search_mode := search_mode;
    attributes [2].key := clc$utility_command_table;
    attributes [2].command_table := commands;
    attributes [3].key := clc$utility_function_table;
    attributes [3].function_table := functions;

*IF NOT $true(osv$unix)
    REPEAT
      clp$create_utility_environment (utility_name, FALSE, TRUE, attributes, status);
      IF osp$file_access_condition (status) THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, clk$push_utility);
*ELSE
    clp$create_utility_environment (utility_name, FALSE, TRUE, attributes, status);
*IFEND

  PROCEND clp$push_utility;
?? TITLE := 'clp$pop_utility', EJECT ??
*copyc clh$pop_utility

  PROCEDURE [XDCL, #GATE] clp$pop_utility
    (VAR status: ost$status);

    VAR
      block: ^clt$block;


*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, 0, clk$pop_utility);
*IFEND

    status.normal := TRUE;
    clp$find_current_block (block);
    IF block^.kind <> clc$utility_block THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$pop_utility', status);
    ELSE
      clp$pop_block_stack (block);
    IFEND;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, 0, clk$pop_utility);
*IFEND

  PROCEND clp$pop_utility;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$change_utility_attributes', EJECT ??
*copyc clh$change_utility_attributes

  PROCEDURE [XDCL, #GATE] clp$change_utility_attributes
    (    name: clt$utility_name;
         attributes: clt$utility_attributes;
     VAR status: ost$status);


    #KEYPOINT (osk$entry, 0, clk$change_utility_attributes);

    status.normal := TRUE;

    clp$change_utility_environment (name, FALSE, attributes, status);

    #KEYPOINT (osk$exit, 0, clk$change_utility_attributes);

  PROCEND clp$change_utility_attributes;
?? TITLE := 'clp$get_utility_attributes', EJECT ??
*copyc clh$get_utility_attributes

  PROCEDURE [XDCL, #GATE] clp$get_utility_attributes
    (    name: clt$utility_name;
     VAR attributes {input, output} : clt$utility_attributes;
     VAR status: ost$status);

    VAR
      ignore_block_in_current_task: boolean,
      ignore_status: ost$status,
      index: integer,
      index_string: ost$string,
      name_is_valid: boolean,
      utility_block: ^clt$block,
      validated_utility_name: clt$utility_name;


    #KEYPOINT (osk$entry, 0, clk$get_utility_attributes);

    status.normal := TRUE;

  /get_utility_attributes/
    BEGIN
      IF name = osc$null_name THEN
        validated_utility_name := osc$null_name;
      ELSE
        clp$validate_name (name, validated_utility_name, name_is_valid);
        IF NOT name_is_valid THEN
          osp$set_status_abnormal ('CL', cle$improper_utility_name, '', status);
          EXIT /get_utility_attributes/;
        IFEND;
      IFEND;

      clp$find_utility_block (validated_utility_name, utility_block, ignore_block_in_current_task);
      IF utility_block = NIL THEN
        osp$set_status_abnormal ('CL', cle$unknown_utility, name, status);
        EXIT /get_utility_attributes/;
      IFEND;

      FOR index := 1 TO UPPERBOUND (attributes) DO
        CASE attributes [index].key OF

        = clc$null_utility_attribute =
          ;

        = clc$utility_command_search_mode =
          attributes [index].command_search_mode := utility_block^.command_search_mode;

        = clc$utility_command_table =
          attributes [index].command_table := utility_block^.command_environment.commands;

        = clc$utility_function_table =
          attributes [index].function_table := utility_block^.command_environment.original_functions;

        = clc$utility_function_proc_table =
          attributes [index].function_processor_table := utility_block^.command_environment.
                contemporary_functions;

        = clc$utility_interactive_include =
          attributes [index].interactive_include_processor := utility_block^.interactive_include_processor;

        = clc$utility_libraries =
          attributes [index].libraries := utility_block^.libraries;

        = clc$utility_line_preprocessor =
          attributes [index].line_preprocessor := utility_block^.line_preprocessor;

        = clc$utility_name =
          attributes [index].name := utility_block^.label;

        = clc$utility_online_manual =
          attributes [index].online_manual_name := utility_block^.online_manual_name;

        = clc$utility_prompt =
          attributes [index].prompt := utility_block^.prompt;

        = clc$utility_subcmnd_log_enabled =
          attributes [index].subcommand_logging_enabled := utility_block^.command_environment.
                subcommand_logging_enabled;

        = clc$utility_termination_command =
          IF (utility_block^.command_environment.commands = NIL) OR
                (utility_block^.command_environment.termination_command_index >
                UPPERBOUND (utility_block^.command_environment.commands^)) THEN
            attributes [index].termination_command := 'QUIT';
          ELSE
            attributes [index].termination_command := utility_block^.command_environment.
                  commands^ [utility_block^.command_environment.termination_command_index].name;
          IFEND;

        ELSE
          clp$convert_integer_to_string (index, 10, FALSE, index_string, ignore_status);
          IF status.normal THEN
            osp$set_status_abnormal ('CL', cle$unknown_utility_attribute, index_string.
                  value (1, index_string.size), status);
          ELSE
            osp$append_status_parameter (',', index_string.value (1, index_string.size), status);
          IFEND;
        CASEND;
      FOREND;

    END /get_utility_attributes/;

    #KEYPOINT (osk$exit, 0, clk$get_utility_attributes);

  PROCEND clp$get_utility_attributes;
?? TITLE := 'clp$fetch_utility_dialog_info', EJECT ??
*copyc clh$fetch_utility_dialog_info

  PROCEDURE [XDCL, #GATE] clp$fetch_utility_dialog_info
    (    utility: clt$utility_name;
     VAR dialog_info: ^clt$utility_dialog_info;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      block_in_current_task: boolean,
      name_is_valid: boolean,
      validated_utility_name: clt$utility_name;


    status.normal := TRUE;
    dialog_info := NIL;

    IF utility = osc$null_name THEN
      validated_utility_name := osc$null_name;
    ELSE
      clp$validate_name (utility, validated_utility_name, name_is_valid);
      IF NOT name_is_valid THEN
        osp$set_status_abnormal ('CL', cle$improper_utility_name, utility, status);
        RETURN;
        IFEND;
    IFEND;

    clp$find_utility_block (validated_utility_name, block, block_in_current_task);
    IF block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unknown_utility, utility, status);
      RETURN;
    ELSEIF NOT block_in_current_task THEN
      osp$set_status_abnormal ('CL', cle$inaccessible_utility, utility, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'CLP$FETCH_UTILITY_DIALOG_INFO', status);
      RETURN;
    IFEND;

    dialog_info := ^block^.command_environment.dialog_info;

  PROCEND clp$fetch_utility_dialog_info;
*IFEND
?? TITLE := 'clp$get_command_origin', EJECT ??
*copyc clh$get_command_origin

  PROCEDURE [XDCL, #GATE] clp$get_command_origin
    (VAR interactive: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block;


*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, 0, clk$get_command_origin);
*IFEND

    status.normal := TRUE;

    clp$find_external_input_block (block);
    interactive := (block <> NIL) AND (block^.input.kind = clc$file_input) AND
          block^.input.interactive_device;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, 0, clk$get_command_origin);
*IFEND

  PROCEND clp$get_command_origin;

MODEND clm$command_utility_manager;
*DECK DECK=CLM$COMMENT_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Display_Message Command' ??
MODULE clm$comment_command;

{
{ PURPOSE:
{   This module contains the processor for the display_message command
{   (once upon a time called the comment command).
{

?? NEWTITLE := 'Global Declarations', EJECT ??
*copyc clp$evaluate_parameters
*copyc clp$log_comment

?? TITLE := 'clp$_display_message', EJECT ??

  PROCEDURE [XDCL] clp$_display_message
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$dism) display_message, dism (
{   message, m: list of string = $required
{   to, t: list of key
{       account, all, engineering, job, job_message, job_statistic, statistic,..
{  system, history
{     keyend = job
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type2: 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 .. 9] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [93, 12, 1, 23, 1, 32, 422],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'OSM$DISM'], [
    ['M                              ',clc$abbreviation_entry, 1],
    ['MESSAGE                        ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TO                             ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 24, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 356, clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [8, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [340, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [9], [
      ['ACCOUNT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['ENGINEERING                    ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['HISTORY                        ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
      ['JOB                            ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['JOB_MESSAGE                    ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
      ['JOB_STATISTIC                  ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
      ['STATISTIC                      ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
      ['SYSTEM                         ', clc$nominal_entry,
  clc$normal_usage_entry, 8]]
      ]
    ,
    'job'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

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

    CONST
      p$message = 1,
      p$to = 2,
      p$status = 3;

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

    CONST
      a_log = 0,
      e_log = 1,
      j_log = 2,
      j_message = 3,
      js_log = 4,
      st_log = 5,
      sy_log = 6,
      h_log = 7;

    TYPE
      logs = a_log .. h_log;

    VAR
      current_to: ^clt$data_value,
      log: logs,
      log_name_selections: array [logs] of ost$name,
      message: ^clt$data_value;

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

    FOR log := LOWERVALUE (logs) TO UPPERVALUE (logs) DO
      log_name_selections [log] := osc$null_name;
    FOREND;

    current_to := pvt [p$to].value;
    WHILE current_to <> NIL DO
      IF current_to^.element_value^.keyword_value = 'ACCOUNT' THEN
        log_name_selections [a_log] := 'ACCOUNT';
      ELSEIF current_to^.element_value^.keyword_value = 'ALL' THEN
        log_name_selections [a_log] := 'ACCOUNT';
        log_name_selections [e_log] := 'ENGINEERING';
        log_name_selections [j_log] := 'JOB';
        log_name_selections [j_message] := 'JOB_MESSAGE';
        log_name_selections [js_log] := 'JOB_STATISTIC';
        log_name_selections [st_log] := 'STATISTIC';
        log_name_selections [sy_log] := 'SYSTEM';
        log_name_selections [h_log] := 'HISTORY';
      ELSEIF current_to^.element_value^.keyword_value = 'ENGINEERING' THEN
        log_name_selections [e_log] := 'ENGINEERING';
      ELSEIF current_to^.element_value^.keyword_value = 'JOB' THEN
        log_name_selections [j_log] := 'JOB';
      ELSEIF current_to^.element_value^.keyword_value = 'JOB_MESSAGE' THEN
        log_name_selections [j_message] := 'JOB_MESSAGE';
      ELSEIF current_to^.element_value^.keyword_value = 'JOB_STATISTIC' THEN
        log_name_selections [js_log] := 'JOB_STATISTIC';
      ELSEIF current_to^.element_value^.keyword_value = 'STATISTIC' THEN
        log_name_selections [st_log] := 'STATISTIC';
      ELSEIF current_to^.element_value^.keyword_value = 'SYSTEM' THEN
        log_name_selections [sy_log] := 'SYSTEM';
      ELSEIF current_to^.element_value^.keyword_value = 'HISTORY' THEN
        log_name_selections [h_log] := 'HISTORY';
      IFEND;
      current_to := current_to^.link;
    WHILEND;

    message := pvt [p$message].value;
    WHILE message <> NIL DO
      clp$log_comment (message^.element_value^.string_value^ (1,
            STRLENGTH (message^.element_value^.string_value^)), log_name_selections, status);
      message := message^.link;
    WHILEND;

  PROCEND clp$_display_message;

MODEND clm$comment_command;
*DECK DECK=CLM$COMPARE_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter: Compare Command Processor' ??
MODULE clm$compare_command;

{
{  PURPOSE:
{    This module contains the processor for the compare command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amd$page_format_declarations
*copyc ame$improper_random_access
*copyc cle$ecc_compare_command
*copyc cle$ecc_lexical
*copyc cle$ecc_miscellaneous
*copyc clt$file_reference
*copyc clt$path_display_chunks
*copyc clt$path_name
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc amv$nil_file_identifier
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$get_path_name
*copyc clp$get_set_count
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$trimmed_string_size
*copyc clv$nil_display_control
*copyc fsp$close_file
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal

*copyc cli$compare_display_file_input

?? TITLE := 'clp$_compare_file', EJECT ??

  PROCEDURE [XDCL] clp$_compare_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$comf) compare_file, compare_files, comf (
{   file, f: file = $required
{   with, w: file = $required
{   error_limit, el: integer 0..amc$file_byte_limit = 0
{   output, o: file = $output
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 1, 25, 14, 10, 56, 414],
    clc$command, 9, 5, 2, 0, 0, 0, 5, 'OSM$COMF'], [
    ['EL                             ',clc$abbreviation_entry, 3],
    ['ERROR_LIMIT                    ',clc$nominal_entry, 3],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OUTPUT                         ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['W                              ',clc$abbreviation_entry, 2],
    ['WITH                           ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, amc$file_byte_limit, 10],
    '0'],
{ PARAMETER 4
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

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

    CONST
      p$file = 1,
      p$with = 2,
      p$error_limit = 3,
      p$output = 4,
      p$status = 5;

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

*copy clv$display_variables
?? NEWTITLE := 'abort_handler', EJECT ??

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


      IF file_control.file_id <> amv$nil_file_identifier THEN
        clp$close_for_get (file_control, handler_status);
      IFEND;
      IF with_control.file_id <> amv$nil_file_identifier THEN
        clp$close_for_get (with_control, handler_status);
      IFEND;
      clp$close_display (display_control, handler_status);

      handler_status.normal := TRUE;

    PROCEND abort_handler;
*copy clp$new_page_procedure
?? TITLE := 'put_subtitle ', EJECT ??

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);


      clp$put_path_reference_subtitle (pvt [p$file].value^.file_value^, 'FILE ', status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clv$subtitles_built := FALSE;
      clp$put_path_reference_subtitle (pvt [p$with].value^.file_value^, 'WITH ', status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clv$subtitles_built := FALSE;
      IF error_count > 0 THEN
        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        put_column_headers (display_control, status);
      IFEND;

    PROCEND put_subtitle;
?? TITLE := 'put_column_headers', EJECT ??

    PROCEDURE put_column_headers
      (VAR display_control: clt$display_control;
       VAR status: ost$status);


      clp$put_partial_display (display_control, ' BYTE ADDRESS', clc$no_trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$horizontal_tab_display (display_control, 15, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_partial_display (display_control, '   FILE  WORD   ', clc$no_trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$horizontal_tab_display (display_control, 32, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '   WITH  WORD   ', clc$no_trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$horizontal_tab_display (display_control, 49, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_partial_display (display_control, 'LOGICAL DIFFERENCE', clc$no_trim, amc$terminate, status);

    PROCEND put_column_headers;
*copy clp$put_path_reference_subtitle
?? OLDTITLE, EJECT ??

    CONST
      address_size = 13,
      address_start = 1,
      bytes_per_word = 8,
      difference_start = 49,
      file_start = 15,
      hex_digits_per_byte = 2,
      max_output_line_size = 64,
      with_start = 32;

    TYPE
      word_set = set of 0 .. 63;

    TYPE
      comparer = record
        case 1 .. 3 of
        = 1 =
          word: word_set,
        = 2 =
          digits: packed array [0 .. 15] of 0 .. 15,
        = 3 =
          bytes: packed array [1 .. bytes_per_word] of cell,
        casend,
      recend;

    VAR
      hex_digits: [STATIC, READ, oss$job_paged_literal] array [0 .. 15] of char := ['0', '1', '2', '3', '4',
            '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f'];

    VAR
      buffer_required: boolean,
      current_byte_address: amt$file_byte_address,
      default_ring_attributes: amt$ring_attributes,
      difference: comparer,
      display_control: clt$display_control,
      error_count: 0 .. amc$file_byte_limit,
      error_limit: 0 .. amc$file_byte_limit,
      file_control: clt$get_control_record,
      file_position: amt$file_position,
      file_transfer_count: amt$transfer_count,
      file_transfer_word: ^comparer,
      i: 0 .. clc$max_value_sets,
      ignore_byte_address: amt$file_byte_address,
      ignore_status: ost$status,
      output_count: 0 .. clc$max_value_sets,
      output_line: string (max_output_line_size),
      with_control: clt$get_control_record,
      with_position: amt$file_position,
      with_transfer_count: amt$transfer_count,
      with_transfer_word: ^comparer,
      word_from_file: comparer,
      word_from_with: comparer;


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

    error_limit := pvt [p$error_limit].value^.integer_value.value;
    error_count := 0;

    file_control.file_id := amv$nil_file_identifier;
    #SPOIL (file_control);
    with_control.file_id := amv$nil_file_identifier;
    #SPOIL (with_control);
    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    osp$establish_block_exit_hndlr (^abort_handler);

  /compare_files/
    BEGIN
      clp$open_for_get (pvt [p$file].value^.file_value^, 'COMPARE_FILE', FALSE, file_position, file_control,
            buffer_required, status);
      IF NOT status.normal THEN
        EXIT /compare_files/;
      IFEND;
      IF buffer_required THEN
        PUSH file_control.sequence_pointer: [[REP clc$input_buffer_size OF cell]];
        #SPOIL (file_control);
      IFEND;

      clp$open_for_get (pvt [p$with].value^.file_value^, 'COMPARE_FILE', FALSE, with_position, with_control,
            buffer_required, status);
      IF NOT status.normal THEN
        clp$close_for_get (file_control, ignore_status);
        EXIT /compare_files/;
      IFEND;
      IF buffer_required THEN
        PUSH with_control.sequence_pointer: [[REP clc$input_buffer_size OF cell]];
        #SPOIL (with_control);
      IFEND;

      default_ring_attributes.r1 := #RING (^default_ring_attributes);
      default_ring_attributes.r2 := #RING (^default_ring_attributes);
      default_ring_attributes.r3 := #RING (^default_ring_attributes);

      clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
            default_ring_attributes, display_control, status);
      IF NOT status.normal THEN
        clp$close_for_get (file_control, ignore_status);
        clp$close_for_get (with_control, ignore_status);
        EXIT /compare_files/;
      IFEND;
      clv$titles_built := FALSE;
      clv$subtitles_built := FALSE;
      clv$command_name := 'compare_file';
      current_byte_address := 0;
      file_transfer_count := 0;
      with_transfer_count := 0;

    /compare_loop/
      WHILE TRUE DO
        clp$get_next_bytes (bytes_per_word, file_transfer_count, file_position, file_control,
              file_transfer_word, status);
        IF NOT status.normal THEN
          EXIT /compare_loop/;
        IFEND;
        clp$get_next_bytes (bytes_per_word, with_transfer_count, with_position, with_control,
              with_transfer_word, status);
        IF NOT status.normal THEN
          EXIT /compare_loop/;
        IFEND;
        IF file_transfer_count < with_transfer_count THEN
          output_count := file_transfer_count;
        ELSE
          output_count := with_transfer_count;
        IFEND;

{ Exit loop here if either of the files has no more data for comparison.

        IF output_count = 0 THEN
          EXIT /compare_loop/;
        IFEND;

        IF output_count < bytes_per_word THEN
          word_from_file.word := $word_set [];
          word_from_with.word := $word_set [];
          FOR i := 1 TO output_count DO
            word_from_file.bytes [i] := file_transfer_word^.bytes [i];
            word_from_with.bytes [i] := with_transfer_word^.bytes [i];
          FOREND;
        ELSE
          word_from_file.word := file_transfer_word^.word;
          word_from_with.word := with_transfer_word^.word;
        IFEND;

        difference.word := word_from_file.word XOR word_from_with.word;
        IF difference.word <> $word_set [] THEN

          IF (error_count = 0) AND (display_control.page_format = amc$continuous_form) THEN
            put_column_headers (display_control, status);
            IF NOT status.normal THEN
              EXIT /compare_loop/;
            IFEND;
          IFEND;

          error_count := error_count + 1;

          output_line := '';
          clp$convert_integer_to_rjstring (current_byte_address, 10, FALSE, ' ',
                output_line (address_start, address_size), status);
          IF NOT status.normal THEN
            EXIT /compare_loop/;
          IFEND;

          FOR i := 0 TO (output_count * hex_digits_per_byte) - 1 DO
            output_line (file_start + i) := hex_digits [word_from_file.digits [i]];
            output_line (with_start + i) := hex_digits [word_from_with.digits [i]];
            output_line (difference_start + i) := hex_digits [difference.digits [i]];
          FOREND;
          clp$put_display (display_control, output_line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /compare_loop/;
          IFEND;

          IF error_count > error_limit THEN
            EXIT /compare_loop/;
          IFEND;
        IFEND;
        IF file_transfer_count <> with_transfer_count THEN
          EXIT /compare_loop/;
        IFEND;
        current_byte_address := current_byte_address + bytes_per_word;
      WHILEND;

      IF error_count > 0 THEN
        clp$put_display (display_control, '', clc$trim, ignore_status);
        IF error_count > error_limit THEN
          output_line := ' -- Specified compare error limit exceeded.';
          clp$put_display (display_control, output_line, clc$trim, ignore_status);
        IFEND;
        output_line := '    xxxxxxxx compare errors.';
        clp$convert_integer_to_rjstring (error_count, 10, FALSE, ' ', output_line (5, 8), ignore_status);
        clp$put_display (display_control, output_line, clc$trim, ignore_status);
        osp$set_status_abnormal ('CL', cle$compare_errors_detected, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, error_count, 10, FALSE, status);
      ELSEIF (file_position = with_position) AND (file_transfer_count = with_transfer_count) THEN
        output_line := '     No compare errors.';
        clp$put_display (display_control, output_line, clc$trim, ignore_status);
      IFEND;

      IF (file_position > with_position) OR (file_transfer_count < with_transfer_count) THEN
        output_line := ' -- FILE file shorter than WITH file.';
        clp$put_display (display_control, output_line, clc$trim, ignore_status);
        IF error_count = 0 THEN
          osp$set_status_abnormal ('CL', cle$compared_files_unequal_size, '', status);
          osp$append_status_file (osc$status_parameter_delimiter, pvt [p$file].value^.file_value^, status);
          osp$append_status_file (osc$status_parameter_delimiter, pvt [p$with].value^.file_value^, status);
        IFEND;
      ELSEIF (with_position > file_position) OR (with_transfer_count < file_transfer_count) THEN
        output_line := ' -- WITH file shorter than FILE file.';
        clp$put_display (display_control, output_line, clc$trim, ignore_status);
        IF error_count = 0 THEN
          osp$set_status_abnormal ('CL', cle$compared_files_unequal_size, '', status);
          osp$append_status_file (osc$status_parameter_delimiter, pvt [p$with].value^.file_value^, status);
          osp$append_status_file (osc$status_parameter_delimiter, pvt [p$file].value^.file_value^, status);
        IFEND;
      IFEND;

      IF status.normal THEN
        clp$close_for_get (file_control, status);
      ELSE
        clp$close_for_get (file_control, ignore_status);
      IFEND;
      IF status.normal THEN
        clp$close_for_get (with_control, status);
      ELSE
        clp$close_for_get (with_control, ignore_status);
      IFEND;
      IF status.normal THEN
        clp$close_display (display_control, status);
      ELSE
        clp$close_display (display_control, ignore_status);
      IFEND;
    END /compare_files/;

    osp$disestablish_cond_handler

  PROCEND clp$_compare_file;

MODEND clm$compare_command;
*DECK DECK=CLM$CONNECTED_FILES_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Connected Files Manager' ??
MODULE clm$connected_files_manager;

{
{ PURPOSE:
{   This module contains the procedures that manage the structures which describe the "connections" between
{   files in a job.  These connections are created and deleted via the requests clp$create_file_connection
{   and clp$delete_file_connection, and the corresponding commands.  The structures are used by the file
{   access procedure (FAP) associated with a file that has been the subject of a file connection.
{

?? NEWTITLE := 'Global Declarations' ??
?? NEWTITLE := 'Connected File Structures', EJECT ??
*copyc clc$compiling_for_test_harness
*copyc clt$connected_file
?? OLDTITLE, EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc cle$ecc_connected_file
*copyc cle$ecc_file_reference
*copyc clk$create_file_connection
*copyc clt$environment_object_contents
*copyc clt$environment_object_size
*copyc clt$env_object_pop_reason
*copyc clt$env_object_push_reason
*copyc fst$file_reference
*copyc ost$caller_identifier
*copyc ost$status
?? POP ??
*copyc amp$get_file_attributes
*copyc bap$close_obsolete_target_files
*copyc bap$get_device_class
*copyc bap$get_path_elements
*copyc bap$verify_file_connection_attr
*copyc clp$construct_path_handle_name
*copyc clp$find_current_block
*copyc clp$find_connected_files
*copyc clp$validate_local_file_name
*copyc clv$standard_files
*copyc clv$standard_files
*copyc fmp$evaluate_path
*copyc fmp$get_device_class
*copyc fmp$get_path_elements
*copyc fmp$request_null_device
*copyc fsp$convert_fs_structure_to_pf
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osv$task_shared_heap
*copyc pfp$get_object_information
*copyc pfp$retrieve_archived_file
*copyc pmp$get_job_mode
?? TITLE := 'clp$eo_size_file_connections', EJECT ??

  FUNCTION [XDCL] clp$eo_size_file_connections: clt$environment_object_size;


    clp$eo_size_file_connections := #SIZE (clt$connected_files);

  FUNCEND clp$eo_size_file_connections;
?? TITLE := 'clp$eo_init_file_connections', EJECT ??

  PROCEDURE [XDCL] clp$eo_init_file_connections
    (    object: ^clt$environment_object_contents);

    VAR
      connected_files: ^clt$connected_files;


    connected_files := object;

    connected_files^.subject_tree := NIL;
    connected_files^.echo_count := 0;
    connected_files^.connection_level := 0;

  PROCEND clp$eo_init_file_connections;
?? TITLE := 'clp$eo_push_file_connections', EJECT ??

  PROCEDURE [XDCL] clp$eo_push_file_connections
    (    push_reason: clt$env_object_push_reason;
         new_object: ^clt$environment_object_contents;
         new_object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

    VAR
      new_connected_files: ^clt$connected_files,
      old_connected_files: ^clt$connected_files;

?? NEWTITLE := 'copy_subject_node', EJECT ??

    PROCEDURE copy_subject_node
      (    old_subject_node: clt$connected_file_subject;
       VAR new_subject_node: ^clt$connected_file_subject);

      VAR
        i: clt$connected_file_target_index,
        j: 0 .. clc$max_connected_file_targets;


      ALLOCATE new_subject_node IN osv$task_shared_heap^;
      new_subject_node^.path_handle_name := old_subject_node.path_handle_name;
      new_subject_node^.left_link := NIL;
      new_subject_node^.right_link := NIL;
      new_subject_node^.connection_level := old_subject_node.connection_level;

      IF old_subject_node.targets = NIL THEN
        new_subject_node^.targets := NIL;
      ELSE
        ALLOCATE new_subject_node^.targets: [1 .. UPPERBOUND (old_subject_node.targets^)] IN
              osv$task_shared_heap^;

        j := UPPERBOUND (new_subject_node^.targets^);
        FOR i := UPPERBOUND (old_subject_node.targets^) DOWNTO 1 DO
          IF old_subject_node.targets^ [i].connection_active THEN
            new_subject_node^.targets^ [j] := old_subject_node.targets^ [i];
            j := j - 1;
          IFEND;
        FOREND;

        FOR i := j DOWNTO 1 DO
          new_subject_node^.targets^ [i].connection_active := FALSE;
          new_subject_node^.targets^ [i].path_handle_name := osc$null_name;
          new_subject_node^.targets^ [i].connection_level := 0;
        FOREND;
      IFEND;

      IF old_subject_node.left_link = NIL THEN
        new_subject_node^.left_link := NIL;
      ELSE
        copy_subject_node (old_subject_node.left_link^, new_subject_node^.left_link);
      IFEND;

      IF old_subject_node.right_link = NIL THEN
        new_subject_node^.right_link := NIL;
      ELSE
        copy_subject_node (old_subject_node.right_link^, new_subject_node^.right_link);
      IFEND;

    PROCEND copy_subject_node;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    new_connected_files := new_object;
    old_connected_files := pushed_object;

    IF old_connected_files^.subject_tree = NIL THEN
      new_connected_files^.subject_tree := NIL;
    ELSE
      copy_subject_node (old_connected_files^.subject_tree^, new_connected_files^.subject_tree);
    IFEND;

    new_connected_files^.echo_count := old_connected_files^.echo_count;
    new_connected_files^.connection_level := old_connected_files^.connection_level;

  PROCEND clp$eo_push_file_connections;
?? TITLE := 'clp$eo_pop_file_connections', EJECT ??

  PROCEDURE [XDCL] clp$eo_pop_file_connections
    (    pop_reason: clt$env_object_pop_reason;
         object: ^clt$environment_object_contents;
         object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

    VAR
      connected_files: ^clt$connected_files,
      current_connection_level: clt$file_connection_level,
      subject_tree: ^clt$connected_file_subject;


    status.normal := TRUE;

    connected_files := object;

    IF (pop_reason = clc$eo_pop_requested) OR (pop_reason = clc$eo_pop_for_block) THEN

{ Close any obsolete target files in the environment being popped.

      bap$close_obsolete_target_files (connected_files);
    IFEND;

{ Pop the current connected_files environment.

    current_connection_level := connected_files^.connection_level;

    IF connected_files^.subject_tree <> NIL THEN
      subject_tree := connected_files^.subject_tree;
      release_subject_node (subject_tree);
    IFEND;

{ Done if cleaning up or popping for an asynchronous task.

    IF pushed_object = NIL THEN
      RETURN;
    IFEND;

{ Update "global" connection_level.

    connected_files := pushed_object;
    connected_files^.connection_level := current_connection_level;

    IF (pop_reason = clc$eo_pop_requested) OR (pop_reason = clc$eo_pop_for_block) THEN

{ Close targets that were created in the popped environment and are now obsolete.

      bap$close_obsolete_target_files (connected_files);
    IFEND;

  PROCEND clp$eo_pop_file_connections;
?? TITLE := 'clp$find_connected_file', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$find_connected_file
    (    local_file_name: amt$local_file_name;
     VAR connected_file_subject: ^clt$connected_file_subject);

    VAR
      connected_files: ^clt$connected_files,
      previous_node: ^^clt$connected_file_subject;

    clp$find_connected_files (connected_files);

    search_subject_tree (local_file_name, ^connected_files^.subject_tree, previous_node,
          connected_file_subject);

  PROCEND clp$find_connected_file;
?? TITLE := 'clp$return_connected_file', EJECT ??

  PROCEDURE [XDCL] clp$return_connected_file
    (    local_file_name: amt$local_file_name);

    VAR
      connected_files: ^clt$connected_files,
      previous_node: ^^clt$connected_file_subject,
      subject_node: ^clt$connected_file_subject;

    clp$find_connected_files (connected_files);

    search_subject_tree (local_file_name, ^connected_files^.subject_tree, previous_node, subject_node);

    IF subject_node <> NIL THEN
      delete_subject_node (previous_node, subject_node);
    IFEND;

  PROCEND clp$return_connected_file;
?? TITLE := 'release_subject_node', EJECT ??

  PROCEDURE release_subject_node
    (VAR subject_node {input} : ^clt$connected_file_subject);

    IF subject_node^.left_link <> NIL THEN
      release_subject_node (subject_node^.left_link);
    IFEND;

    IF subject_node^.right_link <> NIL THEN
      release_subject_node (subject_node^.right_link);
    IFEND;

    IF subject_node^.targets <> NIL THEN
      FREE subject_node^.targets IN osv$task_shared_heap^;
    IFEND;

    FREE subject_node IN osv$task_shared_heap^;

  PROCEND release_subject_node;
?? TITLE := 'search_subject_tree', EJECT ??

  PROCEDURE [INLINE] search_subject_tree
    (    path_handle_name: fst$path_handle_name;
         subject_tree: ^^clt$connected_file_subject;
     VAR previous_node: ^^clt$connected_file_subject;
     VAR subject_node: ^clt$connected_file_subject);

    previous_node := subject_tree;
    WHILE previous_node^ <> NIL DO
      subject_node := previous_node^;
      IF path_handle_name = subject_node^.path_handle_name THEN
        RETURN;
      ELSEIF path_handle_name < subject_node^.path_handle_name THEN
        previous_node := ^subject_node^.left_link;
      ELSE {path_handle_name > subject_node^.path_handle_name
        previous_node := ^subject_node^.right_link;
      IFEND;
    WHILEND;
    subject_node := NIL;

  PROCEND search_subject_tree;
?? TITLE := 'delete_subject_node', EJECT ??

  PROCEDURE [INLINE] delete_subject_node
    (    previous_node: ^^clt$connected_file_subject;
         subject_node: ^clt$connected_file_subject);

    VAR
      current_node: ^clt$connected_file_subject,
      left_subtree: ^clt$connected_file_subject,
      previous_right_node: ^clt$connected_file_subject,
      right_node: ^clt$connected_file_subject;

    IF subject_node^.left_link = NIL THEN
      previous_node^ := subject_node^.right_link;
    ELSEIF subject_node^.right_link = NIL THEN
      previous_node^ := subject_node^.left_link;
    ELSE
      left_subtree := subject_node^.left_link;
      IF left_subtree^.right_link = NIL THEN
        left_subtree^.right_link := subject_node^.right_link;
        previous_node^ := left_subtree;
      ELSE
        right_node := left_subtree;
        REPEAT
          previous_right_node := right_node;
          right_node := right_node^.right_link;
        UNTIL right_node^.right_link = NIL;
        previous_right_node^.right_link := right_node^.left_link;
        right_node^.left_link := left_subtree;
        right_node^.right_link := subject_node^.right_link;
        previous_node^ := right_node;
      IFEND;
    IFEND;

    IF subject_node^.targets <> NIL THEN
      FREE subject_node^.targets IN osv$task_shared_heap^;
    IFEND;
    current_node := subject_node;
    FREE current_node IN osv$task_shared_heap^;

  PROCEND delete_subject_node;
?? TITLE := 'clp$get_ultimate_connection', EJECT ??
*copyc clh$get_ultimate_connection

  PROCEDURE [XDCL, #GATE] clp$get_ultimate_connection
    (    candidate_name: fst$path_handle_name;
     VAR ultimate_name: fst$path_handle_name;
     VAR status: ost$status);

    VAR
      connected_files: ^clt$connected_files,
      current_name: fst$path_handle_name,
      evaluated_file_reference: fst$evaluated_file_reference,
      ignore_cycle_description: ^fmt$cycle_description,
      ignore_previous_node: ^^clt$connected_file_subject,
      i: clt$connected_file_target_index,
      subject_file: ^clt$connected_file_subject;

    status.normal := TRUE;

    clp$find_connected_files (connected_files);
    fmp$evaluate_path (candidate_name, $bat$process_pt_work_list [bac$resolve_path],
          evaluated_file_reference, ignore_cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    ELSEIF (NOT evaluated_file_reference.path_handle_info.path_handle_present) THEN
      ultimate_name := candidate_name;
      RETURN;
    IFEND;
    clp$construct_path_handle_name (evaluated_file_reference.path_handle_info.path_handle, current_name);

  /get_ultimate_connection/
    WHILE TRUE DO
      ultimate_name := current_name;
      search_subject_tree (current_name, ^connected_files^.subject_tree, ignore_previous_node, subject_file);
      IF (subject_file = NIL) OR (subject_file^.targets = NIL) THEN
        EXIT /get_ultimate_connection/;
      IFEND;
      FOR i := UPPERBOUND (subject_file^.targets^) DOWNTO 1 DO
        IF subject_file^.targets^ [i].connection_active THEN
          current_name := subject_file^.targets^ [i].path_handle_name;
          CYCLE /get_ultimate_connection/;
        IFEND;
      FOREND;
      EXIT /get_ultimate_connection/;
    WHILEND /get_ultimate_connection/;

    IF ultimate_name = clv$standard_files [clc$sf_null_file].path_handle_name THEN
      ultimate_name := candidate_name;
    IFEND;

  PROCEND clp$get_ultimate_connection;
?? TITLE := 'clp$internal_cre_file_connect', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$internal_cre_file_connect
    (    subject_file: fst$path_handle_name;
         target_file: fst$path_handle_name;
         target_open_position: fst$open_position;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      catalog_depth: fst$catalog_depth,
      device_assigned: boolean,
      device_class: rmt$device_class,
      evaluated_file_reference: fst$evaluated_file_reference,
      file_path: ^pft$path,
      local_status: ost$status,
      subject_file_handle: fst$path_handle_name,
      subject_path_handle: fmt$path_handle,
      target_file_handle: fst$path_handle_name,
      path_handle: fmt$path_handle,
      name_is_path_handle: boolean,
      name_is_valid: boolean,
      subject_attributes: array [1 .. 2] of amt$get_item,
      target_attributes: array [1 .. 3] of amt$get_item,
      ignore_local_file: boolean,
      ignore_existing_file: boolean,
      ignore_contains_data: boolean,
      information_request: fst$goi_information_request,
      new_subject_file: boolean,
      object_info: ^fst$goi_object_information,
      object_info_sequence: ^SEQ (*),
      object_info_sequence_size: ost$positive_integers,
      i: clt$connected_file_target_index,
      circular_connection: boolean,
      connected_files: ^clt$connected_files,
      connected_file: ^clt$connected_file_subject,
      previous_connected_file: ^^clt$connected_file_subject,
      new_target: ^clt$connected_file_target;

?? NEWTITLE := 'check_for_circular_connection', EJECT ??

    PROCEDURE check_for_circular_connection
      (    candidate_name: fst$path_handle_name;
       VAR circular_connection: boolean);

      VAR
        i: clt$connected_file_target_index,
        ignore_previous_node: ^^clt$connected_file_subject,
        subject_file: ^clt$connected_file_subject;

      circular_connection := FALSE;
      search_subject_tree (candidate_name, ^connected_files^.subject_tree, ignore_previous_node,
            subject_file);
      IF (subject_file = NIL) OR (subject_file^.targets = NIL) THEN
        RETURN;
      IFEND;
      FOR i := 1 TO UPPERBOUND (subject_file^.targets^) DO
        IF subject_file^.targets^ [i].connection_active THEN
          IF subject_file_handle = subject_file^.targets^ [i].path_handle_name THEN
            circular_connection := TRUE;
            RETURN;
          IFEND;
          check_for_circular_connection (subject_file^.targets^ [i].path_handle_name, circular_connection);
          IF circular_connection THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND;

    PROCEND check_for_circular_connection;
?? TITLE := 'check_for_redundant_connection', EJECT ??

    PROCEDURE [INLINE] check_for_redundant_connection
      (VAR targets {input} : clt$connected_file_targets);

      VAR
        i: clt$connected_file_target_index;

      FOR i := 1 TO UPPERBOUND (targets) DO
        IF targets [i].connection_active AND (targets [i].path_handle_name = target_file_handle) THEN

          osp$set_status_abnormal ('CL', cle$duplicate_file_connection, subject_file_handle, local_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, target_file_handle, local_status);
          RETURN;

        IFEND;
      FOREND;

    PROCEND check_for_redundant_connection;
?? TITLE := 'create_new_targets_array', EJECT ??

    PROCEDURE [INLINE] create_new_targets_array
      (VAR old_targets {input, output} : ^clt$connected_file_targets);

      VAR
        old_target_count: 0 .. clc$max_connected_file_targets,
        new_targets: ^clt$connected_file_targets,
        i: clt$connected_file_target_index;

      IF old_targets = NIL THEN
        old_target_count := 0;
      ELSE
        old_target_count := UPPERBOUND (old_targets^);
      IFEND;

      ALLOCATE new_targets: [1 .. clc$min_connected_file_targets + old_target_count] IN osv$task_shared_heap^;
      FOR i := UPPERBOUND (new_targets^) DOWNTO clc$min_connected_file_targets + 1 DO
        new_targets^ [i] := old_targets^ [i - clc$min_connected_file_targets];
      FOREND;
      FOR i := 1 TO clc$min_connected_file_targets DO
        new_targets^ [i].connection_active := FALSE;
        new_targets^ [i].path_handle_name := osc$null_name;
        new_targets^ [i].connection_level := 0;
      FOREND;

      IF old_targets <> NIL THEN
        FREE old_targets IN osv$task_shared_heap^;
      IFEND;

      old_targets := new_targets;

    PROCEND create_new_targets_array;
?? OLDTITLE, EJECT ??

    #KEYPOINT (osk$entry, 0, clk$create_file_connection);

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    local_status.normal := TRUE;

  /create_connection/
    BEGIN

      clp$validate_local_file_name (subject_file, subject_file_handle, subject_path_handle,
            name_is_path_handle, name_is_valid);
      IF NOT name_is_path_handle THEN
        osp$set_status_abnormal ('CL', cle$improper_subject_file_name, subject_file, local_status);
        EXIT /create_connection/;
      IFEND;
      IF target_file = osc$null_name THEN
        target_file_handle := osc$null_name;
      ELSE
        clp$validate_local_file_name (target_file, target_file_handle, path_handle, name_is_path_handle,
              name_is_valid);
        IF NOT name_is_path_handle THEN
          osp$set_status_abnormal ('CL', cle$improper_target_file_name, target_file, local_status);
          EXIT /create_connection/;
        IFEND;
      IFEND;

      clp$find_connected_files (connected_files);

      IF subject_file_handle = target_file_handle THEN
        circular_connection := TRUE;
      ELSE
        check_for_circular_connection (target_file_handle, circular_connection);
      IFEND;
      IF circular_connection THEN
        osp$set_status_abnormal ('CL', cle$circular_file_connection, subject_file, local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, target_file, local_status);
        EXIT /create_connection/;
      IFEND;

      IF target_file_handle <> osc$null_name THEN
        subject_attributes [1].key := amc$file_contents;
        subject_attributes [2].key := amc$file_structure;
        amp$get_file_attributes (subject_file_handle, subject_attributes, ignore_local_file,
              ignore_existing_file, ignore_contains_data, local_status);
        IF NOT local_status.normal THEN
          EXIT /create_connection/;
        IFEND;
        target_attributes [1].key := amc$file_contents;
        target_attributes [2].key := amc$file_structure;
        target_attributes [3].key := amc$permanent_file;
        amp$get_file_attributes (target_file_handle, target_attributes, ignore_local_file,
              ignore_existing_file, ignore_contains_data, local_status);
        IF NOT local_status.normal THEN
          EXIT /create_connection/;
        IFEND;
        IF target_attributes[3].permanent_file THEN
          fmp$get_path_elements (path_handle, evaluated_file_reference, local_status);
          PUSH file_path: [1 .. evaluated_file_reference.number_of_path_elements];
          fsp$convert_fs_structure_to_pf (evaluated_file_reference, file_path);
          IF local_status.normal THEN
            catalog_depth.depth_specification := fsc$specific_depth;
            catalog_depth.depth := 1;
            information_request.catalog_depth := catalog_depth;
            information_request.object_information_requests := $fst$goi_object_info_requests
                  [fsc$goi_cycle_device_info];
            object_info_sequence_size := #SIZE (fst$goi_object_information) + fsc$max_path_size +
                  #SIZE (fst$goi_object) + #SIZE (fst$device_information);
            PUSH object_info_sequence: [[REP object_info_sequence_size OF cell]];
            pfp$get_object_information (target_file_handle, information_request,
                  NIL, object_info_sequence, local_status);
            IF local_status.normal THEN
              RESET object_info_sequence;
              NEXT object_info IN object_info_sequence;
              IF (object_info^.object^.cycle_device_information^.
                    mass_storage_device_info.object_condition = fsc$data_retrieval_required) THEN
                 pfp$retrieve_archived_file (file_path^, object_info^.object^.cycle_number,
                       osc$null_name, osc$wait, local_status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
        IF NOT local_status.normal THEN
          EXIT /create_connection/;
        IFEND;
        bap$verify_file_connection_attr (FALSE, subject_file_handle, target_file_handle,
              subject_attributes [1].file_contents, target_attributes [1].
              file_contents, subject_attributes [2].file_structure, target_attributes [2].file_structure,
              local_status);
        IF NOT local_status.normal THEN
          EXIT /create_connection/;
        IFEND;
      IFEND;

      search_subject_tree (subject_file_handle, ^connected_files^.subject_tree, previous_connected_file,
            connected_file);

      new_subject_file := connected_file = NIL;
      IF new_subject_file THEN

{ Assign subject file to null device.

        ?IF clc$compiling_for_test_harness THEN
          bap$get_path_elements (subject_path_handle, evaluated_file_reference, local_status);
        ?ELSE
          fmp$get_path_elements (subject_path_handle, evaluated_file_reference, local_status);
        ?IFEND
        IF NOT local_status.normal THEN
          EXIT /create_connection/;
        IFEND;

        ?IF clc$compiling_for_test_harness THEN
          bap$get_device_class (subject_path_handle, device_assigned, device_class, local_status);
        ?ELSE
          fmp$get_device_class (subject_path_handle, device_assigned, device_class, local_status);
        ?IFEND
        IF NOT local_status.normal THEN
          device_class := rmc$null_device;
          device_assigned := FALSE;
          local_status.normal := TRUE;
        IFEND;

        IF device_class <> rmc$connected_file_device THEN
          IF device_assigned THEN
            osp$set_status_abnormal ('CL', cle$subject_cannot_be_connected, subject_file_handle,
                  local_status);
            EXIT /create_connection/;
          IFEND;

          fmp$request_null_device (rmc$connected_file_device, evaluated_file_reference, local_status);
          IF NOT local_status.normal THEN
            EXIT /create_connection/;
          IFEND;
        IFEND;

{ Create descriptor for subject file.

        ALLOCATE connected_file IN osv$task_shared_heap^;
        connected_file^.path_handle_name := subject_file_handle;
        connected_file^.left_link := NIL;
        connected_file^.right_link := NIL;
        connected_file^.connection_level := 0;
        connected_file^.targets := NIL;

      ELSEIF (connected_file^.targets <> NIL) AND (target_file_handle <> osc$null_name) THEN

        check_for_redundant_connection (connected_file^.targets^);
        IF NOT local_status.normal THEN
          EXIT /create_connection/;
        IFEND;
      IFEND;

      IF target_file_handle <> osc$null_name THEN

{ Create descriptor for target file.

        new_target := NIL;
        IF connected_file^.targets <> NIL THEN

        /find_entry_for_target/
          FOR i := 1 TO UPPERBOUND (connected_file^.targets^) DO
            IF connected_file^.targets^ [i].connection_active THEN
              IF i > 1 THEN
                new_target := ^connected_file^.targets^ [i - 1];
              IFEND;
              EXIT /find_entry_for_target/;
            ELSEIF i = UPPERBOUND (connected_file^.targets^) THEN
              new_target := ^connected_file^.targets^ [i];
              EXIT /find_entry_for_target/;
            IFEND;
          FOREND /find_entry_for_target/;
        IFEND;

        IF new_target = NIL THEN
          create_new_targets_array (connected_file^.targets);
          new_target := ^connected_file^.targets^ [clc$min_connected_file_targets];
        IFEND;

{ Activate connection.

        new_target^.connection_active := TRUE;
        new_target^.path_handle_name := target_file_handle;
        new_target^.open_position := target_open_position;
        new_target^.connection_ring := caller_id.ring;

{  Increment global connection_level.

        connected_files^.connection_level := connected_files^.connection_level + 1;

{  Update subject's and target's connection levels to match new global value.

        connected_file^.connection_level := connected_files^.connection_level;
        new_target^.connection_level := connected_file^.connection_level;
      IFEND;

      IF new_subject_file THEN

{ Link up new subject file.

        previous_connected_file^ := connected_file;
      IFEND;
    END /create_connection/;

    IF local_status.normal AND (subject_file_handle = clv$standard_files [clc$sf_echo_file].
          path_handle_name) AND (target_file_handle <> osc$null_name) AND
          (target_file_handle <> clv$standard_files [clc$sf_null_file].path_handle_name) THEN
      connected_files^.echo_count := connected_files^.echo_count + 1;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, clk$create_file_connection);

  PROCEND clp$internal_cre_file_connect;
?? TITLE := 'clp$internal_del_file_connect', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$internal_del_file_connect
    (    subject_file: fst$path_handle_name;
         target_file: fst$path_handle_name;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      job_mode: jmt$job_mode,
      local_status: ost$status,
      subject_file_handle: fst$path_handle_name,
      target_file_handle: fst$path_handle_name,
      path_handle: fmt$path_handle,
      name_is_path_handle: boolean,
      name_is_valid: boolean,
      connected_files: ^clt$connected_files,
      previous_connected_file: ^^clt$connected_file_subject,
      connected_file: ^clt$connected_file_subject,
      connected_file_target: ^clt$connected_file_target,
      target_index: clt$connected_file_target_index;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    local_status.normal := TRUE;

  /delete_connection/
    BEGIN

      clp$validate_local_file_name (subject_file, subject_file_handle, path_handle, name_is_path_handle,
            name_is_valid);
      IF NOT name_is_path_handle THEN
        osp$set_status_abnormal ('CL', cle$improper_subject_file_name, subject_file, local_status);
        EXIT /delete_connection/;
      IFEND;
      clp$validate_local_file_name (target_file, target_file_handle, path_handle, name_is_path_handle,
            name_is_valid);
      IF NOT name_is_path_handle THEN
        osp$set_status_abnormal ('CL', cle$improper_target_file_name, target_file_handle, local_status);
        EXIT /delete_connection/;
      IFEND;
      IF subject_file_handle = target_file_handle THEN
        osp$set_status_abnormal ('CL', cle$unknown_file_connection, subject_file_handle, local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, target_file_handle, local_status);
        EXIT /delete_connection/;
      IFEND;

      clp$find_connected_files (connected_files);

      search_subject_tree (subject_file_handle, ^connected_files^.subject_tree, previous_connected_file,
            connected_file);

    /find_target/
      BEGIN
        connected_file_target := NIL;
        IF (connected_file <> NIL) AND (connected_file^.targets <> NIL) THEN
          FOR target_index := 1 TO UPPERBOUND (connected_file^.targets^) DO
            connected_file_target := ^connected_file^.targets^ [target_index];
            IF connected_file_target^.connection_active AND (connected_file_target^.path_handle_name =
                  target_file_handle) THEN
              EXIT /find_target/;
            IFEND;
          FOREND;
          connected_file_target := NIL;
        IFEND;
      END /find_target/;

      IF (connected_file = NIL) OR (connected_file_target = NIL) THEN
        osp$set_status_abnormal ('CL', cle$unknown_file_connection, subject_file_handle, local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, target_file_handle, local_status);
        EXIT /delete_connection/;
      IFEND;

      IF caller_id.ring > connected_file_target^.connection_ring THEN
        osp$set_status_abnormal ('CL', cle$connection_cannot_be_broken, subject_file_handle, local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, target_file_handle, local_status);
        EXIT /delete_connection/;
      IFEND;

      IF subject_file_handle = clv$standard_files [clc$sf_response_file].path_handle_name THEN

      /check_original_response_connect/
        BEGIN

        /ok/
          BEGIN
            IF target_file_handle = clv$standard_files [clc$sf_job_log_file].path_handle_name THEN
              EXIT /ok/;
            ELSEIF target_file_handle = clv$standard_files [clc$sf_job_output_file].path_handle_name THEN
              pmp$get_job_mode (job_mode, local_status);
              IF (NOT local_status.normal) OR (job_mode <> jmc$batch) THEN
                EXIT /ok/;
              IFEND;
            IFEND;
            EXIT /check_original_response_connect/;
          END /ok/;

          osp$set_status_abnormal ('CL', cle$connection_cannot_be_broken, subject_file_handle, local_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, target_file_handle, local_status);
          EXIT /delete_connection/;
        END /check_original_response_connect/;
      IFEND;

{ Deactivate the connection.

      FOR target_index := target_index DOWNTO 2 DO
        connected_file^.targets^ [target_index] := connected_file^.targets^ [target_index - 1];
      FOREND;
      connected_file^.targets^ [1].connection_active := FALSE;
      connected_file^.targets^ [1].path_handle_name := osc$null_name;

{ Increment global connection_level and use it to update connection_level of subject and
{ target.

      connected_files^.connection_level := connected_files^.connection_level + 1;
      connected_file^.connection_level := connected_files^.connection_level;
      connected_file^.targets^ [1].connection_level := connected_file^.connection_level;

    END /delete_connection/;

    IF local_status.normal AND (subject_file_handle = clv$standard_files [clc$sf_echo_file].
          path_handle_name) AND (target_file_handle <> clv$standard_files [clc$sf_null_file].path_handle_name)
          THEN
      connected_files^.echo_count := connected_files^.echo_count - 1;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND clp$internal_del_file_connect;
?? TITLE := 'clp$internal_del_all_targets', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$internal_del_all_targets
    (    subject_file: fst$path_handle_name;
     VAR status: ost$status);

    VAR
      connected_file: ^clt$connected_file_subject,
      connected_file_targets: ^clt$connected_file_targets,
      local_status: ost$status,
      target_index: clt$connected_file_target_index;


    status.normal := TRUE;
    clp$find_connected_file (subject_file, connected_file);
    IF (connected_file = NIL) OR (connected_file^.targets = NIL) THEN
      RETURN;
    IFEND;
    PUSH connected_file_targets: [1 .. UPPERBOUND (connected_file^.targets^)];
    IF connected_file_targets = NIL THEN
      RETURN;
    IFEND;
    connected_file_targets^ := connected_file^.targets^;

    FOR target_index := 1 TO UPPERBOUND (connected_file_targets^) DO
      IF connected_file_targets^ [target_index].connection_active THEN
        clp$internal_del_file_connect (subject_file, connected_file_targets^ [target_index].path_handle_name,
              local_status);
        IF (NOT local_status.normal) AND (status.normal) AND
              (status.condition <> cle$connection_cannot_be_broken) THEN
          status := local_status;
        IFEND;
      IFEND;
    FOREND;

  PROCEND clp$internal_del_all_targets;
?? TITLE := 'clp$update_connected_files', EJECT ??

  PROCEDURE [XDCL] clp$update_connected_files
    (    new_ring: ost$valid_ring );

    VAR
      connected_files: ^clt$connected_files;

?? NEWTITLE := 'update_subject_node', EJECT ??

    PROCEDURE update_subject_node
      (subject_node: ^clt$connected_file_subject);

      VAR
        i: clt$connected_file_target_index;


      IF subject_node^.left_link <> NIL THEN
        update_subject_node (subject_node^.left_link);
      IFEND;

      IF subject_node^.right_link <> NIL THEN
        update_subject_node (subject_node^.right_link);
      IFEND;

      IF subject_node^.targets <> NIL THEN
        FOR i := UPPERBOUND (subject_node^.targets^) DOWNTO 1 DO
          IF subject_node^.targets^ [i].connection_active THEN
            subject_node^.targets^ [i].connection_ring := new_ring;
          IFEND;
        FOREND;
      IFEND;

    PROCEND update_subject_node;
?? OLDTITLE, EJECT ??

    clp$find_connected_files (connected_files);

    IF connected_files^.subject_tree <> NIL THEN
      update_subject_node (connected_files^.subject_tree);
    IFEND;

  PROCEND clp$update_connected_files;

MODEND clm$connected_files_manager;
*DECK DECK=CLM$CONNECTED_FILES_SCREENS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Connected Files Manager Screens' ??
MODULE clm$connected_files_screens;

{
{ PURPOSE:
{   This module contains procedures that act as the interface between the
{   user and the procedures that maintain the information about connections
{   between files.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_connected_file
*copyc clk$procedure_keypoints
*copyc fst$file_reference
*copyc ost$status
*copyc pfe$error_condition_codes
?? POP ??
*copyc bap$close_obsolete_target_files
*copyc clp$convert_str_to_path_handle
*copyc clp$find_connected_files
*copyc clp$internal_cre_file_connect
*copyc clp$internal_del_all_targets
*copyc clp$internal_del_file_connect
*copyc clp$put_open_pos_in_path_handle
*copyc clp$validate_local_file_name
*copyc osp$set_status_abnormal

?? TITLE := 'clp$create_file_connection', EJECT ??
*copyc clh$create_file_connection

  PROCEDURE [XDCL, #GATE] clp$create_file_connection
    (    subject_file: fst$file_reference;
         target_file: fst$file_reference;
     VAR status: ost$status);

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      ignore_name_is_path_handle: boolean,
      name_is_valid: boolean,
      subject_handle_name: fst$path_handle_name,
      target_handle_name: fst$path_handle_name;

    #KEYPOINT (osk$entry, 0, clk$create_file_connection);

  /create_file_connection/
    BEGIN
      status.normal := TRUE;

      clp$convert_str_to_path_handle (subject_file, FALSE, TRUE, FALSE, subject_handle_name,
            evaluated_file_reference, status);
      IF NOT status.normal THEN
        EXIT /create_file_connection/;
      IFEND;
      IF evaluated_file_reference.path_resolution = fsc$command_file_path THEN
        osp$set_status_abnormal ('CL', cle$improper_subject_file_name, '$COMMAND', status);
        EXIT /create_file_connection/;
      ELSEIF evaluated_file_reference.path_resolution = fsc$catalog_path THEN
        osp$set_status_abnormal ('CL', pfe$name_not_permanent_file, subject_handle_name, status);
        EXIT /create_file_connection/;
      IFEND;

      IF target_file = '' THEN
        target_handle_name := osc$null_name;
      ELSE
        clp$convert_str_to_path_handle (target_file, FALSE, TRUE, FALSE, target_handle_name,
              evaluated_file_reference, status);
        IF NOT status.normal THEN
          EXIT /create_file_connection/;
        IFEND;
        IF evaluated_file_reference.path_resolution = fsc$command_file_path THEN
          osp$set_status_abnormal ('CL', cle$improper_target_file_name, '$COMMAND', status);
          EXIT /create_file_connection/;
        ELSEIF evaluated_file_reference.path_resolution = fsc$catalog_path THEN
          osp$set_status_abnormal ('CL', pfe$name_not_permanent_file, target_handle_name, status);
          EXIT /create_file_connection/;
        IFEND;
      IFEND;

      clp$internal_cre_file_connect (subject_handle_name, target_handle_name,
            evaluated_file_reference.path_handle_info.path_handle.open_position, status);
    END /create_file_connection/;

    #KEYPOINT (osk$exit, 0, clk$create_file_connection);

  PROCEND clp$create_file_connection;
?? TITLE := 'clp$delete_all_file_connections', EJECT ??
*copyc clh$delete_all_file_connections

  PROCEDURE [XDCL] clp$delete_all_file_connections;

    VAR
      connected_files: ^clt$connected_files,
      ignore_status: ost$status;

?? TITLE := 'delete_all_file_connections', EJECT ??

    PROCEDURE delete_all_file_connections
      (    connected_file: ^clt$connected_file_subject);


      IF connected_file^.left_link <> NIL THEN
        delete_all_file_connections (connected_file^.left_link);
      IFEND;

      clp$internal_del_all_targets (connected_file^.path_handle_name, ignore_status);

      IF connected_file^.right_link <> NIL THEN
        delete_all_file_connections (connected_file^.right_link);
      IFEND;

    PROCEND delete_all_file_connections;
?? OLDTITLE, EJECT ??

    clp$find_connected_files (connected_files);
    delete_all_file_connections (connected_files^.subject_tree);
    bap$close_obsolete_target_files (connected_files);

  PROCEND clp$delete_all_file_connections;
?? TITLE := 'clp$delete_file_connection', EJECT ??
*copyc clh$delete_file_connection

  PROCEDURE [XDCL, #GATE] clp$delete_file_connection
    (    subject_file: fst$file_reference;
         target_file: fst$file_reference;
     VAR status: ost$status);

    VAR
      connected_files: ^clt$connected_files,
      evaluated_file_reference: fst$evaluated_file_reference,
      ignore_name_is_path_handle: boolean,
      name_is_valid: boolean,
      subject_handle_name: fst$path_handle_name,
      target_handle_name: fst$path_handle_name;


    #KEYPOINT (osk$entry, 0, clk$delete_file_connection);

  /delete_file_connection/
    BEGIN
      status.normal := TRUE;

      clp$convert_str_to_path_handle (subject_file, FALSE, TRUE, FALSE, subject_handle_name,
            evaluated_file_reference, status);
      IF NOT status.normal THEN
        EXIT /delete_file_connection/;
      IFEND;
      IF evaluated_file_reference.path_resolution = fsc$command_file_path THEN
        osp$set_status_abnormal ('CL', cle$improper_subject_file_name, '$COMMAND', status);
        EXIT /delete_file_connection/;
      ELSEIF evaluated_file_reference.path_resolution = fsc$catalog_path THEN
        osp$set_status_abnormal ('CL', pfe$name_not_permanent_file, subject_handle_name, status);
        EXIT /delete_file_connection/;
      IFEND;

      clp$convert_str_to_path_handle (target_file, FALSE, TRUE, FALSE, target_handle_name,
            evaluated_file_reference, status);
      IF NOT status.normal THEN
        EXIT /delete_file_connection/;
      IFEND;
      IF evaluated_file_reference.path_resolution = fsc$command_file_path THEN
        osp$set_status_abnormal ('CL', cle$improper_target_file_name, '$COMMAND', status);
        EXIT /delete_file_connection/;
      ELSEIF evaluated_file_reference.path_resolution = fsc$catalog_path THEN
        osp$set_status_abnormal ('CL', pfe$name_not_permanent_file, target_handle_name, status);
        EXIT /delete_file_connection/;
      IFEND;

      clp$internal_del_file_connect (subject_handle_name, target_handle_name, status);

      clp$find_connected_files (connected_files);
      bap$close_obsolete_target_files (connected_files);
    END /delete_file_connection/;

    #KEYPOINT (osk$exit, 0, clk$delete_file_connection);

  PROCEND clp$delete_file_connection;
?? TITLE := 'clp$delete_all_targets', EJECT ??
*copyc clh$delete_all_targets

  PROCEDURE [XDCL, #GATE] clp$delete_all_targets
    (    subject_file: fst$file_reference;
     VAR status: ost$status);

    VAR
      connected_files: ^clt$connected_files,
      evaluated_file_reference: fst$evaluated_file_reference,
      subject_handle_name: fst$path_handle_name;


    status.normal := TRUE;

  /delete_all_targets/
    BEGIN
      clp$convert_str_to_path_handle (subject_file, FALSE, TRUE, FALSE, subject_handle_name,
            evaluated_file_reference, status);
      IF NOT status.normal THEN
        EXIT /delete_all_targets/;
      IFEND;
      IF evaluated_file_reference.path_resolution = fsc$command_file_path THEN
        osp$set_status_abnormal ('CL', cle$improper_subject_file_name, '$COMMAND', status);
        EXIT /delete_all_targets/;
      ELSEIF evaluated_file_reference.path_resolution = fsc$catalog_path THEN
        osp$set_status_abnormal ('CL', pfe$name_not_permanent_file, subject_handle_name, status);
        EXIT /delete_all_targets/;
      IFEND;

      clp$internal_del_all_targets (subject_handle_name, status);

      clp$find_connected_files (connected_files);
      bap$close_obsolete_target_files (connected_files);
    END /delete_all_targets/;

  PROCEND clp$delete_all_targets;

MODEND clm$connected_files_screens;
*DECK DECK=CLM$CONNECTED_FILE_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Connected File Commands' ??
MODULE clm$connected_file_commands;

{
{ PURPOSE:
{   This module contains the processors for the commands that control the logical connections between files
{   within a job.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc cld$parameter_list
*copyc cle$ecc_miscellaneous
*copyc clt$path_display_chunks
*copyc fst$file_reference
*copyc fst$path
*copyc fst$path_size
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc amv$nil_file_identifier
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$convert_str_to_path_handle
*copyc clp$create_file_connection
*copyc clp$delete_file_connection
*copyc clp$evaluate_parameters
*copyc clp$find_connected_file
*copyc clp$find_connected_files
*copyc clp$find_input_block
*copyc clp$get_path_name
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$new_display_line
*copyc clp$open_display
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$scan_parameter_list
*copyc clp$trimmed_string_size
*copyc clv$nil_display_control
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal

?? TITLE := 'clp$_create_file_connection', EJECT ??

  PROCEDURE [XDCL] clp$_create_file_connection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (osm$crefc) create_file_connection, crefc (
{   standard_file, sf: file = $required
{   file, f: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 6, 23, 9, 51, 48, 216], clc$command, 5, 3, 2, 0, 0, 0, 3, 'OSM$CREFC'],
            [['F                              ', clc$abbreviation_entry, 2],
            ['FILE                           ', clc$nominal_entry, 2],
            ['SF                             ', clc$abbreviation_entry, 1],
            ['STANDARD_FILE                  ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 3]], [
{ PARAMETER 1
      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 3
      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$file_type]],
{ PARAMETER 2
      [[1, 0, clc$file_type]],
{ PARAMETER 3
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$standard_file = 1,
      p$file = 2,
      p$status = 3;

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

    VAR
      value: clt$value,
      subject_file: amt$local_file_name,
      target_file: amt$local_file_name;

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

    clp$create_file_connection (pvt [p$standard_file].value^.file_value^, pvt [p$file].value^.file_value^,
          status);

  PROCEND clp$_create_file_connection;
?? TITLE := 'clp$_delete_file_connection', EJECT ??

  PROCEDURE [XDCL] clp$_delete_file_connection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (osm$delfc) delete_file_connection, delfc (
{    standard_file, sf : FILE = $REQUIRED
{    file, f : FILE = $REQUIRED
{    STATUS)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 6, 23, 9, 3, 44, 861], clc$command, 5, 3, 2, 0, 0, 0, 3, 'OSM$DELFC'],
            [['F                              ', clc$abbreviation_entry, 2],
            ['FILE                           ', clc$nominal_entry, 2],
            ['SF                             ', clc$abbreviation_entry, 1],
            ['STANDARD_FILE                  ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 3]], [
{ PARAMETER 1
      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 3
      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$file_type]],
{ PARAMETER 2
      [[1, 0, clc$file_type]],
{ PARAMETER 3
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$standard_file = 1,
      p$file = 2,
      p$status = 3;

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

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

    clp$delete_file_connection (pvt [p$standard_file].value^.file_value^, pvt [p$file].value^.file_value^,
          status);

  PROCEND clp$_delete_file_connection;
?? TITLE := 'clp$_display_file_connections', EJECT ??

  PROCEDURE [XDCL] clp$_display_file_connections
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$disfc) display_file_connections, display_file_connection, disfc (
{   standard_files, standard_file, sf: any of
{       key
{         all
{       keyend
{       list of file
{     anyend = all
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 6] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] 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,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
          default_value: string (3),
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 6, 23, 9, 53, 7, 691], clc$command, 6, 3, 0, 0, 0, 0, 3, 'OSM$DISFC'],
            [['O                              ', clc$abbreviation_entry, 2],
            ['OUTPUT                         ', clc$nominal_entry, 2],
            ['SF                             ', clc$abbreviation_entry, 1],
            ['STANDARD_FILE                  ', clc$alias_entry, 1],
            ['STANDARD_FILES                 ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 3]], [
{ PARAMETER 1
      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 83, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ 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]]], 19, [[1, 0, clc$list_type],
            [3, 1, clc$max_list_size, FALSE], [[1, 0, clc$file_type]]], 'all'],
{ PARAMETER 2
      [[1, 0, clc$file_type], '$output'],
{ PARAMETER 3
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$standard_files = 1,
      p$output = 2,
      p$status = 3;

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


    VAR
      open_positions: [STATIC, READ, oss$job_paged_literal] array [amt$open_position] of record
        size: 1 .. 6,
        value: string (6),
      recend := [[6, '.$ASIS'], [5, '.$BOI'], [5, '.$BOP'], [5, '.$EOI']];

*copy clv$display_variables
?? NEWTITLE := 'abort_handler', EJECT ??

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

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;
*copy clp$new_page_procedure
?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

{The display_connection command has no subtitles,
{ this is merely a dummy routine used to keep
{ the module consistent with those that do produce subtitles.

    PROCEND put_subtitle;
?? TITLE := 'put_partial_display', EJECT ??

    PROCEDURE [INLINE] put_partial_display
      (    str: string ( * );
           trim_option: clt$trim_display_text_option;
           term_option: amt$term_option);

      clp$put_partial_display (display_control, str, trim_option, term_option, status);
      IF NOT status.normal THEN
        EXIT clp$_display_file_connections
      IFEND;

    PROCEND put_partial_display;
?? TITLE := 'put_file', EJECT ??

    PROCEDURE [INLINE] put_file
      (    path_handle_name: fst$path_handle_name;
           term_option: amt$term_option);

      VAR
        p: amt$open_position,
        file_reference: fst$path;

      clp$get_path_name (path_handle_name, osc$full_message_level, file_reference);
      put_partial_display (file_reference (1, clp$trimmed_string_size (file_reference)), clc$no_trim,
            term_option);

    PROCEND put_file;
?? TITLE := 'display_connected_file', EJECT ??

    PROCEDURE display_connected_file
      (    file_reference: fst$file_reference;
           connected_file: ^clt$connected_file_subject;
       VAR status: ost$status);

      VAR
        target_count: 0 .. clc$max_connected_file_targets,
        i: clt$connected_file_target_index;

      IF file_reference <> '' THEN
        put_partial_display (file_reference, clc$no_trim, amc$start);
      ELSE
        put_file (connected_file^.path_handle_name, amc$start);
      IFEND;

      target_count := 0;
      IF connected_file^.targets <> NIL THEN
        FOR i := 1 TO UPPERBOUND (connected_file^.targets^) DO
          IF connected_file^.targets^ [i].connection_active THEN
            IF target_count = 0 THEN
              put_partial_display (' is connected to: ', clc$no_trim, amc$continue);
            ELSE
              put_partial_display (', ', clc$no_trim, amc$continue);
            IFEND;
            put_file (connected_file^.targets^ [i].path_handle_name, amc$continue);
            IF connected_file^.targets^ [i].open_position.specified THEN
              put_partial_display (open_positions [connected_file^.targets^ [i].open_position.value].
                    value (1, open_positions [connected_file^.targets^ [i].open_position.value].size),
                    clc$no_trim, amc$continue);
            IFEND;
            target_count := target_count + 1;
          IFEND;
        FOREND;
      IFEND;
      IF target_count = 0 THEN
        put_partial_display (' is not connected to any files.', clc$no_trim, amc$terminate);
      ELSE
        put_partial_display ('.', clc$no_trim, amc$terminate);
      IFEND;

    PROCEND display_connected_file;
?? TITLE := 'display_connected_file_tree', EJECT ??

    PROCEDURE display_connected_file_tree
      (    connected_file: ^clt$connected_file_subject;
       VAR status: ost$status);

      TYPE
        clt$subject_file_display_info = record
          name: fst$path,
          size: fst$path_size,
          subject: ^clt$connected_file_subject,
        recend;

      VAR
        file_reference: fst$path,
        subject_count: integer,
        subject_info: ^array [1 .. * ] of clt$subject_file_display_info;

?? NEWTITLE := 'count_subject_files', EJECT ??

      PROCEDURE count_subject_files
        (    connected_file: ^clt$connected_file_subject);

        IF connected_file^.left_link <> NIL THEN
          count_subject_files (connected_file^.left_link);
        IFEND;

        subject_count := subject_count + 1;

        IF connected_file^.right_link <> NIL THEN
          count_subject_files (connected_file^.right_link);
        IFEND;

      PROCEND count_subject_files;
?? TITLE := 'get_subject_files', EJECT ??

      PROCEDURE get_subject_files
        (    connected_file: ^clt$connected_file_subject);

        IF connected_file^.left_link <> NIL THEN
          get_subject_files (connected_file^.left_link);
        IFEND;

        clp$get_path_name (connected_file^.path_handle_name, osc$full_message_level, file_reference);
        subject_count := subject_count + 1;
        subject_info^ [subject_count].name := file_reference (1, clp$trimmed_string_size (file_reference));
        subject_info^ [subject_count].size := clp$trimmed_string_size (file_reference);
        subject_info^ [subject_count].subject := connected_file;

        IF connected_file^.right_link <> NIL THEN
          get_subject_files (connected_file^.right_link);
        IFEND;

      PROCEND get_subject_files;
?? TITLE := 'sort_subject_files', EJECT ??

      PROCEDURE sort_subject_files;

        VAR
          gap: integer,
          start: integer,
          current: integer,
          swap: clt$subject_file_display_info;

        { Sort subject file names using shell sort technique. }

        gap := UPPERBOUND (subject_info^);
        WHILE gap > 1 DO
          gap := 2 * (gap DIV 4) + 1;
          FOR start := 1 TO UPPERBOUND (subject_info^) - gap DO
            current := start;
            WHILE (current > 0) AND (subject_info^ [current].name > subject_info^ [current + gap].name) DO
              swap := subject_info^ [current];
              subject_info^ [current] := subject_info^ [current + gap];
              subject_info^ [current + gap] := swap;
              current := current - gap;
            WHILEND;
          FOREND;
        WHILEND;

      PROCEND sort_subject_files;
?? OLDTITLE, EJECT ??

      subject_count := 0;
      count_subject_files (connected_file);
      PUSH subject_info: [1 .. subject_count];
      subject_count := 0;
      get_subject_files (connected_file);
      sort_subject_files;

      FOR subject_count := 1 TO UPPERBOUND (subject_info^) DO
        display_connected_file (subject_info^ [subject_count].name (1, subject_info^ [subject_count].size),
              subject_info^ [subject_count].subject, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

    PROCEND display_connected_file_tree;
?? OLDTITLE, EJECT ??

    VAR
      connected_files: ^clt$connected_files,
      connected_file: ^clt$connected_file_subject,
      current_file: ^clt$data_value,
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      subject_file_name: fst$path_handle_name,
      ignore_evaluated_file_reference: fst$evaluated_file_reference,
      ignore_status: ost$status,
      i: 1 .. clc$max_value_sets,
      set_count: 0 .. clc$max_value_sets,
      value: clt$value;

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

    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    osp$establish_block_exit_hndlr (^abort_handler);

  /display/
    BEGIN
      default_ring_attributes.r1 := #RING (^default_ring_attributes);
      default_ring_attributes.r2 := #RING (^default_ring_attributes);
      default_ring_attributes.r3 := #RING (^default_ring_attributes);

      clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
            default_ring_attributes, display_control, status);
      IF NOT status.normal THEN
        EXIT /display/;
      IFEND;
      clv$titles_built := FALSE;
      clv$command_name := 'display_file_connection';
      current_file := pvt [p$standard_files].value;

      IF current_file^.kind = clc$keyword {keyword = ALL} THEN
{ Display ALL connected files. }
        clp$find_connected_files (connected_files);
        IF connected_files^.subject_tree = NIL THEN
          put_partial_display ('There are no connected files.', clc$no_trim, amc$terminate);
        ELSE
          display_connected_file_tree (connected_files^.subject_tree, status);
        IFEND;

      ELSE {list of files}

      /display_current_file/
        WHILE current_file <> NIL DO

{ Display selected connected files. }

          clp$convert_str_to_path_handle (current_file^.element_value^.file_value^, FALSE, TRUE, FALSE,
                subject_file_name, ignore_evaluated_file_reference, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$find_connected_file (subject_file_name, connected_file);
          IF connected_file = NIL THEN
            put_file (subject_file_name, amc$start);
            put_partial_display (' is not a connected file.', clc$no_trim, amc$terminate);
          ELSE
            display_connected_file ('', connected_file, status);
          IFEND;
          current_file := current_file^.link;
        WHILEND /display_current_file/;
      IFEND;
    END /display/;

    IF status.normal THEN
      clp$close_display (display_control, status);
    ELSE
      clp$close_display (display_control, ignore_status);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND clp$_display_file_connections;

MODEND clm$connected_file_commands;
*DECK DECK=CLM$CONTROL_STATEMENTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Control Statement Processors' ??
MODULE clm$control_statements;

{
{ PURPOSE:
{   This module contains the processors for the SCL control statements.  Also, it contains the procedure
{   and table used to search for a control statement or control command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$max_integer
*copyc clc$min_integer
*copyc clc$standard_file_names
*copyc cle$ecc_command_processing
*copyc cle$ecc_control_statement
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_parsing
*copyc clt$command_line
*copyc clt$command_line_index
*copyc clt$command_line_size
*copyc clt$command_processor
*copyc clt$control_statement
*copyc clt$control_statement_desc
*copyc clt$control_statement_info
*copyc clt$environment_object
*copyc clt$name
*copyc clt$parameter_list
*copyc clt$utility_name
*copyc clt$when_condition
*copyc cyd$run_time_error_condition
*copyc loc$task_services_library_name
*copyc osc$unseen_mail_condition
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc ost$caller_identifier
*copyc ost$name_reference
*copyc ost$status
?? POP ??
*copyc amv$nil_file_identifier
*copyc clp$append_status_parse_state
*copyc clp$advance_for_block
*copyc clp$change_prompt_string
*copyc clp$collect_statement
*copyc clp$continue
*copyc clp$convert_ext_value_to_int
*copyc clp$convert_int_value_to_ext
*copyc clp$convert_type_desc_to_spec
*copyc clp$convert_type_spec_to_desc
*copyc clp$create_var_from_type_spec
*copyc clp$cycle_block
*copyc clp$derive_type_desc_from_value
*copyc clp$disestablish_cond_handler
*copyc clp$echo_command
*copyc clp$echo_trace_information
*copyc clp$establish_condition_handler
*copyc clp$evaluate_boolean_expression
*copyc clp$evaluate_data_name_expr
*copyc clp$evaluate_integer_expression
*copyc clp$evaluate_list_expression
*copyc clp$evaluate_name
*copyc clp$evaluate_name_for_write
*copyc clp$evaluate_parameters
*copyc clp$evaluate_status_expression
*copyc clp$evaluate_unqual_union_expr
*copyc clp$execute_named_task
*copyc clp$exit_block
*copyc clp$find_connected_files
*copyc clp$find_current_block
*copyc clp$find_cycle_block
*copyc clp$find_exit_block
*copyc clp$find_input_block
*copyc clp$get_command_line
*copyc clp$get_command_search_mode
*copyc clp$get_interpreter_mode
*copyc clp$get_path_description
*copyc clp$get_work_area
*copyc clp$include_file
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*copyc clp$internal_evaluate_expr
*copyc clp$internal_gen_type_spec
*copyc clp$log_command_line
*copyc clp$make_deferred_value
*copyc clp$pop_block_stack
*copyc clp$pop_environment
*copyc clp$pop_input
*copyc clp$pop_input_stack
*copyc clp$process_command_file
*copyc clp$process_continued_condition
*copyc clp$process_exit_condition
*copyc clp$produce_variable_ref_expr
*copyc clp$push_block_block
*copyc clp$push_case_block
*copyc clp$push_if_block
*copyc clp$push_for_incremental_block
*copyc clp$push_for_list_block
*copyc clp$push_input_internal_block
*copyc clp$push_loop_block
*copyc clp$push_repeat_block
*copyc clp$push_while_block
*copyc clp$push_dynamic_command_list
*copyc clp$push_environment
*copyc clp$push_input
*copyc clp$reset_input_position
*copyc clp$scan_argument_list
*copyc clp$scan_any_lexical_unit
*copyc clp$scan_non_space_lexical_unit
*copyc clp$scan_unnested_cmnd_lex_unit
*copyc clp$set_exit_position
*copyc clp$set_if_block
*copyc clp$set_input_line_parse
*copyc clp$set_repeat_until
*copyc clp$set_task_statement_task
*copyc clp$skip_block
*copyc clp$trimmed_string_size
*copyc clp$update_variable
*copyc clp$validate_name
*copyc clv$nil_block_handle
*copyc clv$standard_files
*copyc clv$value_descriptors
*copyc jmp$_job
*copyc jmp$jobend_statement
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$establish_block_exit_hndlr
*copyc osp$file_access_condition
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osv$lower_to_upper
*copyc pmp$abort
*copyc pmp$continue_to_cause
*copyc pmp$exit
*copyc pmp$get_unique_name
*copyc pmp$get_user_identification

*copyc osv$initial_exception_context

  CONST
    ignore_command_file = osc$null_name;

?? TITLE := 'Control Statements and Commands', EJECT ??

{
{ NOTE:
{   All "commands" in the following table must also appear in the table
{   clv$intrinsic_commands with "availability=hidden".  This is to allow
{   all relevant information about these commands to be accessible via
{   the display_command_information command which is geared up to interrogate
{   a clt$command_table.  This also makes determining the source of the
{   command possible via function $source, etc.
{
{ NOTE:
{   The processor for the FUNCTION statement does not appear in this table
{   in order to allow "FUNCTION" to be used as the name for a subcommand of
{   generate_command_table and UTILITY/UTILITYEND.
{   The entry for FUNCTION appears in the table clv$intrinsic_commands with
{   "availability=hidden".
{

  CONST
    number_of_control_names = 49,
    min_control_name_size = 2 {IF} ,
    max_control_name_size = 13 {PUSH_COMMANDS} ;

  VAR
    control_statements: [STATIC, READ, oss$job_paged_literal] array [1 .. number_of_control_names] of record
      name: string (max_control_name_size),
      descriptor: clt$control_statement_desc,
    recend := [
          {} ['BLOCK                          ', [TRUE, clc$control_statement, TRUE, ^clp$block_statement]],
          {} ['BLOCKEND                       ', [TRUE, clc$control_statement, FALSE,
          ^clp$blockend_statement]],
          {} ['CANCEL                         ', [FALSE, clc$control_statement, FALSE,
          ^clp$cancel_statement]],
          {} ['CASE                           ', [TRUE, clc$control_statement, TRUE, ^clp$case_statement]],
          {} ['CASEND                         ', [TRUE, clc$control_statement, FALSE, ^clp$casend_statement]],
          {} ['CAUSE                          ', [FALSE, clc$control_statement, FALSE, ^clp$cause_statement]],
          {} ['CHECK                          ', [TRUE, clc$control_statement, TRUE, ^clp$check_statement]],
          {} ['CHECKEND                       ', [TRUE, clc$control_statement, FALSE,
          ^clp$checkend_statement]],
          {} ['COLLECT_TEXT                   ', [TRUE, clc$control_command, ^clp$_collect_text]],
          {} ['COLT                           ', [TRUE, clc$control_command, ^clp$_collect_text]],
          {} ['CONTINUE                       ', [FALSE, clc$control_statement, FALSE,
          ^clp$continue_statement]],
          {} ['CYCLE                          ', [FALSE, clc$control_statement, FALSE, ^clp$cycle_statement]],
          {} ['ELSE                           ', [TRUE, clc$control_statement, FALSE, ^clp$else_statement]],
          {} ['ELSEIF                         ', [TRUE, clc$control_statement, FALSE, ^clp$elseif_statement]],
          {} ['EXIT                           ', [FALSE, clc$control_statement, FALSE, ^clp$exit_statement]],
          {} ['EXIT_PROC                      ', [FALSE, clc$control_statement, FALSE,
          ^clp$exit_proc_statement]],
          {} ['FOR                            ', [TRUE, clc$control_statement, TRUE, ^clp$for_statement]],
          {} ['FOREND                         ', [TRUE, clc$control_statement, FALSE, ^clp$forend_statement]],
          {} ['FUNCEND                        ', [TRUE, clc$control_statement, FALSE,
          ^clp$funcend_statement]],

{-- 'FUNCTION                       ', [TRUE, clc$control_statement, FALSE,
{-- ^clp$_function_statement]],

    {} ['IF                             ', [TRUE, clc$control_statement, FALSE, ^clp$if_statement]],
          {} ['IFEND                          ', [TRUE, clc$control_statement, FALSE, ^clp$ifend_statement]],
          {} ['JOB                            ', [TRUE, clc$control_command, ^jmp$_job]],
          {} ['JOBEND                         ', [TRUE, clc$control_statement, FALSE, ^jmp$jobend_statement]],
          {} ['LOCK                           ', [FALSE, clc$control_statement, FALSE, ^clp$lock_statement]],
          {} ['LOOP                           ', [TRUE, clc$control_statement, TRUE, ^clp$loop_statement]],
          {} ['LOOPEND                        ', [TRUE, clc$control_statement, FALSE,
          ^clp$loopend_statement]],
          {} ['PIPE                           ', [TRUE, clc$control_statement, FALSE, ^clp$pipe_statement]],
          {} ['PIPEND                         ', [TRUE, clc$control_statement, FALSE, ^clp$pipend_statement]],
          {} ['POP                            ', [FALSE, clc$control_statement, FALSE, ^clp$pop_statement]],
          {} ['PROC                           ', [TRUE, clc$control_statement, FALSE,
          ^clp$procedure_statement]],
          {} ['PROCEDURE                      ', [TRUE, clc$control_statement, FALSE,
          ^clp$procedure_statement]],
          {} ['PROCEND                        ', [TRUE, clc$control_statement, FALSE,
          ^clp$procend_statement]],
          {} ['PUSH                           ', [FALSE, clc$control_statement, FALSE, ^clp$push_statement]],
          {} ['PUSH_COMMANDS                  ', [FALSE, clc$control_statement, FALSE, ^clp$push_commands]],
          {} ['REPEAT                         ', [TRUE, clc$control_statement, TRUE, ^clp$repeat_statement]],
          {} ['TASK                           ', [TRUE, clc$control_command, ^clp$_task]],
          {} ['TASKEND                        ', [TRUE, clc$control_statement, FALSE,
          ^clp$taskend_statement]],
          {} ['TYPE                           ', [TRUE, clc$control_statement, FALSE, ^clp$type_statement]],
          {} ['TYPEND                         ', [TRUE, clc$control_statement, FALSE, ^clp$typend_statement]],
          {} ['UNLOCK                         ', [FALSE, clc$control_statement, FALSE,
          ^clp$unlock_statement]],
          {} ['UNTIL                          ', [TRUE, clc$control_statement, FALSE, ^clp$until_statement]],
          {} ['UTILITY                        ', [TRUE, clc$control_command, ^clp$_utility]],
          {} ['UTILITYEND                     ', [TRUE, clc$control_statement, FALSE,
          ^clp$utilityend_statement]],
          {} ['VAR                            ', [TRUE, clc$control_statement, FALSE, ^clp$var_statement]],
          {} ['VAREND                         ', [TRUE, clc$control_statement, FALSE, ^clp$varend_statement]],
          {} ['WHEN                           ', [TRUE, clc$control_statement, FALSE, ^clp$when_statement]],
          {} ['WHENEND                        ', [TRUE, clc$control_statement, FALSE,
          ^clp$whenend_statement]],
          {} ['WHILE                          ', [TRUE, clc$control_statement, TRUE, ^clp$while_statement]],
          {} ['WHILEND                        ', [TRUE, clc$control_statement, FALSE,
          ^clp$whilend_statement]]];

?? EJECT ??

  VAR
    clv$non_substitution_mark: [STATIC, XDCL, READ, oss$job_paged_literal] packed array [char] of boolean := [
          {---} REP 9 of FALSE,
          {HT } TRUE,
          {---} REP 22 of FALSE,
          {- -} TRUE,
          {---} FALSE,
          { " } TRUE,
          { # } TRUE,
          { $ } TRUE,
          {---} REP 2 of FALSE,
          { ' } TRUE,
          { ( } TRUE,
          { ) } TRUE,
          {---} REP 2 of FALSE,
          { , } TRUE,
          {---} REP 3 of FALSE,
          {0..9} REP 10 of TRUE,
          {---} FALSE,
          { ; } TRUE,
          {---} REP 4 of FALSE,
          { @ } TRUE,
          {A..Z} REP 26 of TRUE,
          { [ } TRUE,
          { \ } TRUE,
          { ] } TRUE,
          { ^ } TRUE,
          { _ } TRUE,
          { ` } TRUE,
          {a..z} REP 26 of TRUE,
          { { } TRUE,
          { | } TRUE,
          { } TRUE,
          { ~ } TRUE,
          {---} REP 129 of FALSE];

?? PUSH (LISTEXT := ON) ??

  PROCEDURE [XREF] clp$_collect_text
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$_utility
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$utilityend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

?? POP ??
?? TITLE := 'clp$check_name_for_control', EJECT ??

  PROCEDURE [XDCL] clp$check_name_for_control
    (    name: clt$name;
     VAR control_statement_descriptor: ^clt$control_statement_desc);

    VAR
      current_index: 1 .. number_of_control_names,
      low_index: 1 .. number_of_control_names + 1,
      temp: integer,
      high_index: 0 .. number_of_control_names;


    IF (min_control_name_size <= name.size) AND (name.size <= max_control_name_size) THEN
      low_index := 1;
      high_index := UPPERBOUND (control_statements);
      REPEAT
        temp := low_index + high_index;
        current_index := temp DIV 2;
        IF name.value (1, max_control_name_size) = control_statements [current_index].name THEN
          control_statement_descriptor := ^control_statements [current_index].descriptor;
          RETURN;
        ELSEIF name.value (1, max_control_name_size) > control_statements [current_index].name THEN
          low_index := current_index + 1;
        ELSE
          high_index := current_index - 1;
        IFEND;
      UNTIL low_index > high_index;
    IFEND;

    control_statement_descriptor := NIL;

  PROCEND clp$check_name_for_control;
?? TITLE := 'evaluate_boolean_expression', EJECT ??

  PROCEDURE evaluate_boolean_expression
    (    statement_name: ost$name_reference;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
         optional_termination_name: ost$name_reference;
     VAR result: boolean;
     VAR status: ost$status);

    VAR
      clause_name: array [1 .. 1] of ost$name,
      ignore_found_clause_name: ost$name,
      next_parse: clt$parse_state,
      result_boolean: clt$boolean;


    status.normal := TRUE;

    IF optional_termination_name <> '' THEN
      clause_name [1] := optional_termination_name;
      find_clause_name (clause_name, TRUE, parse, next_parse, ignore_found_clause_name);
    IFEND;

    clp$evaluate_boolean_expression (work_area, parse, result_boolean, status);
    IF NOT status.normal THEN
      IF status.condition = cle$unspecified_value_for_req THEN
        osp$set_status_abnormal ('CL', cle$unspecified_value_for_state, statement_name, status);
      IFEND;
      RETURN;
    IFEND;
    result := result_boolean.value;

    IF parse.unit_is_space THEN
      clp$scan_non_space_lexical_unit (parse);
    IFEND;
    IF parse.unit_index < parse.index_limit THEN
      osp$set_status_condition (cle$unexpected_after_bool_expr, status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
    IFEND;

    IF optional_termination_name <> '' THEN
      parse := next_parse;
    IFEND;

  PROCEND evaluate_boolean_expression;
?? TITLE := 'check_statement_terminator', EJECT ??

  PROCEDURE check_statement_terminator
    (    statement_name: ost$name_reference;
         block_kind: clt$block_kind;
     VAR parse {input, output} : clt$parse_state;
     VAR statement_block: ^clt$block;
     VAR status: ost$status);

    VAR
      terminator_name: ost$name;


    status.normal := TRUE;
    clp$find_current_block (statement_block);

    IF statement_block^.kind <> block_kind THEN
      CASE statement_block^.kind OF
      = clc$block_block, clc$case_block, clc$check_block, clc$command_proc_block, clc$for_block,
            clc$function_proc_block, clc$if_block, clc$loop_block, clc$repeat_block, clc$when_block,
            clc$while_block =
        osp$set_status_abnormal ('CL', cle$unbalanced_block_structure, statement_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, statement_block^.kind_end_name, status);
      ELSE
        osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, statement_name, status);
      CASEND;
      RETURN;
    IFEND;

    CASE parse.unit.kind OF
    = clc$lex_end_of_line =
      ;
    = clc$lex_semicolon =
      CASE statement_block^.kind OF
      = clc$command_proc_block, clc$function_proc_block =
        clp$scan_non_space_lexical_unit (parse);
        IF parse.unit.kind <> clc$lex_end_of_line THEN
          osp$set_status_condition (cle$unexpected_after_procend, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, statement_name, status);
          RETURN;
        IFEND;
      ELSE
        ;
      CASEND;
    ELSE
      IF parse.unit.kind <> clc$lex_name THEN
        osp$set_status_condition (cle$expecting_label, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, statement_name, status);
        RETURN;
      IFEND;

      #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), terminator_name);
      CASE statement_block^.kind OF
      = clc$command_proc_block, clc$function_proc_block =
        IF terminator_name <> statement_block^.proc_name THEN
          osp$set_status_abnormal ('CL', cle$wrong_statement_label, statement_name, status);
          RETURN;
        IFEND;
      ELSE
        IF terminator_name <> statement_block^.label THEN
          osp$set_status_abnormal ('CL', cle$wrong_statement_label, statement_name, status);
          RETURN;
        IFEND;
      CASEND;

      clp$scan_non_space_lexical_unit (parse);
      CASE parse.unit.kind OF
      = clc$lex_end_of_line =
        ;
      = clc$lex_semicolon =
        CASE statement_block^.kind OF
        = clc$command_proc_block, clc$function_proc_block =
          clp$scan_non_space_lexical_unit (parse);
          IF parse.unit.kind <> clc$lex_end_of_line THEN
            osp$set_status_condition (cle$unexpected_after_end_label, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, statement_name, status);
            RETURN;
          IFEND;
        ELSE
          ;
        CASEND;
      ELSE
        osp$set_status_condition (cle$unexpected_after_end_label, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, statement_name, status);
        RETURN;
      CASEND;
    CASEND;

    IF NOT (statement_block^.being_exited OR statement_block^.exit_position.defined) THEN
      clp$set_exit_position;
    IFEND;

  PROCEND check_statement_terminator;
?? TITLE := 'find_clause_name', EJECT ??

  PROCEDURE find_clause_name
    (    clause_names: array [1 .. * ] of ost$name;
         clause_name_is_terminator: boolean;
     VAR parse {input, output} : clt$parse_state;
     VAR next_parse: clt$parse_state;
     VAR found_clause_name: ost$name);

    VAR
      check_parse: clt$parse_state,
      i: integer,
      name: ost$name,
      nesting_level: clt$string_size;


    found_clause_name := osc$null_name;
    next_parse := parse;
    nesting_level := 0;

    REPEAT
      CASE next_parse.unit.kind OF

      = clc$lex_left_parenthesis =
        nesting_level := nesting_level + 1;

      = clc$lex_right_parenthesis =
        IF nesting_level = 0 THEN
          RETURN;
        IFEND;
        nesting_level := nesting_level - 1;

      = clc$lex_name =
        IF nesting_level = 0 THEN
          #TRANSLATE (osv$lower_to_upper, next_parse.text^ (next_parse.unit_index, next_parse.unit.size),
                name);

        /check_clause_names/
          FOR i := 1 TO UPPERBOUND (clause_names) DO
            IF name = clause_names [i] THEN
              IF clause_name_is_terminator THEN
                check_parse := next_parse;
                clp$scan_non_space_lexical_unit (check_parse);
                IF check_parse.unit_index < check_parse.index_limit THEN
                  CYCLE /check_clause_names/;
                IFEND;
              IFEND;
              parse.index_limit := next_parse.unit_index;
              found_clause_name := name;
              RETURN;
            IFEND;
          FOREND /check_clause_names/;
        IFEND;

      ELSE
        ;
      CASEND;

      clp$scan_non_space_lexical_unit (next_parse);
    UNTIL next_parse.unit_index >= next_parse.index_limit;

  PROCEND find_clause_name;
?? TITLE := 'process_when_clause', EJECT ??

  PROCEDURE [INLINE] process_when_clause
    (    statement_name: ost$name_reference;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR when_condition: boolean;
     VAR status: ost$status);


    status.normal := TRUE;
    IF NOT parse.previous_unit_is_space THEN
      osp$set_status_condition (cle$unexpected_after_when, status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, statement_name, status);
      RETURN;
    IFEND;

    evaluate_boolean_expression (statement_name, parse, work_area, '', when_condition, status);

  PROCEND process_when_clause;
?? TITLE := 'prepare_interactive_statement', EJECT ??

  PROCEDURE prepare_interactive_statement
    (    begin_name: ost$name_reference;
         end_name: ost$name_reference;
         prompt_string: clt$prompt_string;
     VAR work_area {input, output} : ^clt$work_area;
     VAR internal_input_block: ^clt$block;
     VAR status: ost$status);

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

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


      clp$pop_input (TRUE, input_block_handle, file_id, input_executable, NIL, handler_status);
      handler_status.normal := TRUE;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      current_input_block: ^clt$block,
      file_id: amt$file_identifier,
      ignore_line_layout: clt$line_layout,
      input_block_handle: clt$block_handle,
      input_executable: boolean,
      local_status: ost$status,
      statement_area: ^clt$collect_statement_area,
      statement_begin_name: ost$name,
      statement_end_name: ost$name,
      substitution_mark: clt$substitution_mark;


    status.normal := TRUE;
    internal_input_block := NIL;

    clp$find_input_block (FALSE, current_input_block);
    IF current_input_block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'prepare_interactive_statement', status);
      RETURN;
    IFEND;
    IF (current_input_block^.input.kind <> clc$file_input) OR current_input_block^.input.file_rereadable THEN
      RETURN;
    IFEND;

    input_block_handle := clv$nil_block_handle;
    file_id := amv$nil_file_identifier;
    #SPOIL (input_block_handle, file_id);

    osp$establish_block_exit_hndlr (^abort_handler);

  /collect/
    BEGIN
      clp$push_input (clc$current_command_input, osc$null_name, prompt_string, FALSE, TRUE,
            input_block_handle, file_id, input_executable, status);
      IF NOT status.normal THEN
        EXIT /collect/;
      IFEND;

      statement_begin_name := begin_name;
      statement_end_name := end_name;
      substitution_mark.specified := FALSE;
      clp$collect_statement (TRUE, statement_begin_name, statement_end_name, '', substitution_mark, work_area,
            statement_area, status);

      clp$pop_input (TRUE, input_block_handle, file_id, input_executable, NIL, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    END /collect/;

    osp$disestablish_cond_handler;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$push_input_internal_block (osc$null_name, current_input_block^.input_can_be_echoed, statement_area,
          internal_input_block);

  PROCEND prepare_interactive_statement;
?? TITLE := 'process_interactive_statement', EJECT ??

  PROCEDURE process_interactive_statement
    (    internal_input_block: ^clt$block;
     VAR status: ost$status);

    VAR
      end_internal_input_block: ^clt$block,
      ignore_status: ost$status;


    clp$process_command_file (internal_input_block, NIL, status);
    IF status.normal AND (NOT internal_input_block^.being_exited) THEN
      clp$find_current_block (end_internal_input_block);
      IF end_internal_input_block <> internal_input_block THEN
        osp$set_status_abnormal ('CL', cle$unbalanced_block_structure, internal_input_block^.kind_end_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, end_internal_input_block^.kind_end_name,
              status);
      IFEND;
    IFEND;
    IF status.normal THEN
      clp$pop_input_stack (end_internal_input_block, status);
    ELSE
      clp$pop_input_stack (end_internal_input_block, ignore_status);
    IFEND;

  PROCEND process_interactive_statement;
?? TITLE := 'clp$process_delayed_block', EJECT ??

  PROCEDURE [XDCL] clp$process_delayed_block
    (    utility_name: clt$utility_name;
         statement_area: ^clt$collect_statement_area;
         can_be_echoed: boolean;
     VAR status: ost$status);

    VAR
      internal_input_block: ^clt$block;


    clp$push_input_internal_block (utility_name, can_be_echoed, statement_area, internal_input_block);

    process_interactive_statement (internal_input_block, status);

  PROCEND clp$process_delayed_block;
?? TITLE := 'clp$prepare_delayed_block', EJECT ??

  PROCEDURE [XDCL] clp$prepare_delayed_block
    (    interpreter_mode: clt$interpreter_modes;
         begin_name: ost$name_reference;
         end_name: ost$name_reference;
         prompt_string: clt$prompt_string;
         first_line_to_write: clt$command_line;
         substitution_mark: clt$substitution_mark;
     VAR statement_area: ^clt$collect_statement_area;
     VAR can_be_echoed: boolean;
     VAR status: ost$status);

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

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


      clp$pop_input (TRUE, input_block_handle, file_id, input_executable, NIL, handler_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      current_input_block: ^clt$block,
      file_id: amt$file_identifier,
      input_block_handle: clt$block_handle,
      input_executable: boolean,
      local_status: ost$status,
      statement_begin_name: ost$name,
      statement_end_name: ost$name,
      work_area: ^^clt$work_area;


    status.normal := TRUE;
    statement_area := NIL;

    clp$find_input_block (FALSE, current_input_block);
    IF current_input_block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$prepare_delayed_block', status);
      RETURN;
    IFEND;
    can_be_echoed := current_input_block^.input_can_be_echoed;

    input_block_handle := clv$nil_block_handle;
    file_id := amv$nil_file_identifier;
    #SPOIL (input_block_handle, file_id);

    osp$establish_block_exit_hndlr (^abort_handler);

  /collect/
    BEGIN
      clp$push_input (clc$current_command_input, osc$null_name, prompt_string, FALSE, TRUE,
            input_block_handle, file_id, input_executable, status);
      IF NOT status.normal THEN
        EXIT /collect/;
      IFEND;

      clp$get_work_area (#RING (^work_area), work_area, status);
      IF NOT status.normal THEN
        EXIT /collect/;
      IFEND;

      statement_begin_name := begin_name;
      statement_end_name := end_name;
      clp$collect_statement ((interpreter_mode = clc$interpret_mode), statement_begin_name,
            statement_end_name, first_line_to_write, substitution_mark, work_area^, statement_area, status);

      clp$pop_input (TRUE, input_block_handle, file_id, input_executable, NIL, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    END /collect/;

    osp$disestablish_cond_handler;

  PROCEND clp$prepare_delayed_block;
?? TITLE := 'process_exit_and_cycle_label', EJECT ??

  PROCEDURE process_exit_and_cycle_label
    (    statement_name: ost$name_reference;
     VAR parse {input, output} : clt$parse_state;
     VAR target_label: ost$name;
     VAR following_clause_name: ost$name;
     VAR status: ost$status);


    status.normal := TRUE;
    target_label := '';
    following_clause_name := '';

    CASE parse.unit.kind OF
    = clc$lex_end_of_line, clc$lex_semicolon =
      RETURN;
    = clc$lex_long_name =
      osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
            status);
      RETURN;
    = clc$lex_name =
      ;
    ELSE
      IF statement_name = 'EXIT' THEN
        osp$set_status_condition (cle$expecting_label_when_with, status);
      ELSE
        osp$set_status_condition (cle$expecting_label_or_when, status);
      IFEND;
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      RETURN;
    CASEND;

    #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), following_clause_name);
    IF (following_clause_name = 'WHEN') OR ((statement_name = 'EXIT') AND
          ((following_clause_name = 'WITH') OR (following_clause_name = 'ABORT'))) THEN
      RETURN;
    IFEND;

    target_label := following_clause_name;

    clp$scan_non_space_lexical_unit (parse);

    CASE parse.unit.kind OF
    = clc$lex_end_of_line, clc$lex_semicolon =
      RETURN;
    = clc$lex_long_name =
      osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
            status);
      RETURN;
    = clc$lex_name =
      ;
    ELSE
      IF statement_name = 'EXIT' THEN
        osp$set_status_condition (cle$expecting_with_or_when, status);
      ELSE
        osp$set_status_condition (cle$expecting_cycle_when, status);
      IFEND;
      RETURN;
    CASEND;

    #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), following_clause_name);
    IF (following_clause_name = 'WHEN') OR ((statement_name = 'EXIT') AND
          ((following_clause_name = 'WITH') OR (following_clause_name = 'ABORT'))) THEN
      RETURN;
    IFEND;

    IF statement_name = 'EXIT' THEN
      osp$set_status_condition (cle$expecting_with_or_when, status);
    ELSE
      osp$set_status_condition (cle$expecting_cycle_when, status);
    IFEND;

  PROCEND process_exit_and_cycle_label;
?? TITLE := 'clp$cycle_statement', EJECT ??

  PROCEDURE clp$cycle_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      clause_name: ost$name,
      current_block: ^clt$block,
      cycle_condition: boolean,
      expression_parse: clt$parse_state,
      for_list_node: ^clt$i_data_value,
      for_value: integer,
      target_block: ^clt$block,
      target_label: ost$name;


    process_exit_and_cycle_label ('CYCLE', parse, target_label, clause_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$find_cycle_block (target_label, current_block, target_block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF clause_name = 'WHEN' THEN
      clp$scan_non_space_lexical_unit (parse);
      process_when_clause ('CYCLE', parse, work_area, cycle_condition, status);
      IF NOT (status.normal AND cycle_condition) THEN
        RETURN;
      IFEND;
    IFEND;

    CASE target_block^.kind OF

    = clc$for_block =
      IF target_block^.for_control.style = clc$for_control_incremental THEN
        for_value := target_block^.for_control.value.value + target_block^.for_control.increment;
        cycle_condition := ((target_block^.for_control.increment > 0) AND
              (for_value <= target_block^.for_control.limit)) OR
              ((target_block^.for_control.increment < 0) AND (for_value >= target_block^.for_control.limit));
      ELSE {clc$for_control_list}
        for_list_node := #PTR (target_block^.for_control.list^.header.value, target_block^.for_control.list^);
        cycle_condition := for_list_node <> NIL;
      IFEND;

    = clc$loop_block =
      cycle_condition := TRUE;

    = clc$repeat_block =
      cycle_condition := target_block^.exit_position.defined;
      IF cycle_condition THEN
        expression_parse := target_block^.expression_parse;
        evaluate_boolean_expression ('UNTIL', expression_parse, work_area, '', cycle_condition, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        cycle_condition := NOT cycle_condition;
      IFEND;

    = clc$while_block =
      expression_parse := target_block^.expression_parse;
      evaluate_boolean_expression ('WHILE', expression_parse, work_area, 'DO', cycle_condition, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    ELSE

{ Should never get here.

      cycle_condition := FALSE;
    CASEND;

    IF cycle_condition THEN
      WHILE current_block <> target_block DO
        clp$pop_block_stack (current_block);
      WHILEND;

      IF target_block^.kind = clc$for_block THEN
        IF target_block^.for_control.style = clc$for_control_incremental THEN
          advance_for_increment (target_block, work_area, status);
        ELSE {clc$for_control_list}
          advance_for_list (target_block, target_block^.for_control.list, for_list_node^.element_value,
                work_area, status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$advance_for_block (FALSE);
      IFEND;

      clp$reset_input_position (target_block^.line_identifier, target_block^.line_parse);
    ELSE
      clp$cycle_block (target_label, (target_block^.kind <> clc$repeat_block) OR
            target_block^.exit_position.defined, status);
    IFEND;

  PROCEND clp$cycle_statement;
?? TITLE := 'clp$exit_statement', EJECT ??

  PROCEDURE clp$exit_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      initial_clause_name: ost$name,
      target_label: ost$name;


    process_exit_and_cycle_label ('EXIT', parse, target_label, initial_clause_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    exit_statement (target_label, initial_clause_name, parse, work_area, status);

  PROCEND clp$exit_statement;
?? TITLE := 'exit_statement', EJECT ??

{
{   The EXIT statement is used for the following purposes in SCL:
{
{   - get out of a structured statement (e.g.  LOOP/LOOPEND)
{   - get out of an SCL command procedure
{   - get out of and return a result from an SCL function procedure
{   - get out of a CHECK/CHECKEND statement (not yet implemented)
{   - get out of a task (program)
{   - get out of a command utility
{
{   There are two variants to EXITing a command utility.  The first appears
{ similar to EXITing a structured statement.  For example, the following
{ sequence shows a conditional exit from the "source code utility":
{
{       SOURCE_CODE_UTILITY
{         .
{         .
{         EXIT UTILITY WHEN some_condition
{         .
{         .
{       QUIT
{
{   In this example, if some_condition is true, the statements following the
{ EXIT statement up to and including the QUIT command are skipped, and normal
{ processing resumes with the statement following QUIT.
{
{   The EXIT statement also provides the means for implementing a "utility
{ termination command" for a utility implemented at the "command level." For
{ instance, the following is an example of an SCL procedure that implements the
{ command used to "quit" a hypothetical_utility.
{
{       PROCEDURE quit, qui (
{         status)
{
{         EXIT hypothetical_utility
{
{       PROCEND quit
{
{   In this procedure the EXIT statement causes termination of the "innermost"
{ input block associated with hypothetical_utility.  The following comments
{ describe how all of this is accomplished.
{
{   The following fields of a CLT$BLOCK are used by the EXIT process:
{
{ INTERPRETER_MODE:  This field is set to CLC$SKIP_MODE for any block that is
{       in the process of "being exited".
{
{ SOURCE.UTILITY_TERMINATION_COMMAND:  When a command is encountered (within
{       module CLM$PROCESS_COMMANDS) that is a utility subcommand and has the
{       same command table "ordinal" as the utility's termination command, this
{       field is set to TRUE in the corresponding CLC$COMMAND_BLOCK or
{       CLC$COMMAND_PROC_BLOCK.  Otherwise this field is FALSE.
{
{ BEING_EXITED:  This field is set to TRUE for any block that is in the process
{       of "being exited".
{
{ EXIT_POSITION:  This field contains information describing whether the
{       location of the end of a structured statement is known, and if so where
{       it is.  This information is used to avoid the need to explicitly skip
{       over statements when we already know where to transfer control after an
{       EXIT (or CYCLE when there are no more iterations of the statement to be
{       performed).
{
{ INPUT.STATE,
{ INPUT.RESET_LINE_IDENTIFIER,
{ INPUT.RESET_LINE_INDEX:  These fields are used to "mark" an input block so
{       that the next time a "get" is done using that block, its position can
{       be "reset" to the proper place.  This is done via the
{       CLP$RESET_INPUT_POSITION request which sets the INPUT.STATE field to
{       CLC$RESET_INPUT and stores the specified values into the other two
{       fields.
{
{ INPUT.ASSOCIATED_UTILITY:  This field points to the CLC$UTILITY_BLOCK
{       associated with a CLC$INPUT_BLOCK, if any.
{
{ COMMAND_ENVIRONMENT.COMMANDS,
{ COMMAND_ENVIRONMENT.TERMINATION_COMMAND_ORDINAL:  These fields of a
{       CLC$UTILITY_BLOCK are used to determine whether a command is a
{       utility termination command.
{
{ TERMINATION_COMMAND_FOUND:  This field of a CLC$UTILITY_BLOCK is used to
{       determine whether an input block associated with the utility that is
{       "being exited" can actually be exited yet.  It is set to TRUE by the
{       CLP$EXIT_STATEMENT request for the second type of exit from a utility,
{       described above.  It is also set to TRUE via the
{       CLP$IGNORE_REST_OF_FILE request which is called by CLP$END_INCLUDE (or
{       the "obsolete" CLP$END_SCAN_COMMAND_FILE request).
{
{   The process of EXITing starts in the control statement processor for the
{ EXIT statement (CLP$EXIT_STATEMENT) or EXIT_PROC (CLP$EXIT_PROC_STATEMENT).
{ CLP$EXIT_STATEMENT calls PROCESS_EXIT_AND_CYCLE_LABEL in order to determine
{ the target of the EXIT.  CLP$EXIT_PROC_STATEMENT "hard wires" the target as
{ "PROCEDURE." Both routines then call EXIT_STATEMENT.
{
{   The first thing EXIT_STATEMENT does is to call CLP$FIND_EXIT_BLOCK in order
{ to find the CLT$BLOCK that corresponds to the target block of the EXIT.  A
{ boolean that indicates whether a utility is the target is also returned.
{ Note that if a utility is the target of the EXIT, the block considered to be
{ the target is the innermost input block associated with that utility.
{
{   The next step is to evaluate the remaining parameters of the EXIT (or
{ EXIT_PROC) statement.
{
{   If the WHEN clause was present and the value of its expression was false,
{ the EXIT is inhibited.
{
{   If the target block is a function procedure, the WITH clause is required
{ and specifies an expression for the result of the function.  If the target
{ block is the current TASK, the WITH clause is required and specifies the
{ task's termination status.  If the target block is a command procedure or
{ CHECK/CHECKEND statement, the WITH clause is optional and specifies an
{ expression for the corresponding termination status.  For any other kind of
{ block, the WITH clause is not allowed.
{
{   If the target block is the current TASK, the ABORT option determines how to
{ proceed.  If ABORT was omitted, the task is terminated by calling PMP$EXIT.
{ If ABORT was specified, the task is terminated by calling PMP$ABORT, thereby
{ allowing an "abort file" associated with the task, if any, to be processed.
{
{   For any target block other than the current TASK, CLP$EXIT_BLOCK is called
{ to instigate the exiting process.  It marks the blocks between the current
{ and target, inclusive, as being exited and in skip mode.  If a utility is the
{ EXIT target, the utility block's TERMINATION_COMMAND_FOUND field is set to
{ true.
{
{   While CLP$EXIT_BLOCK is marking the appropriate blocks, it determines the
{ existence and location of two other blocks.  These are refered to as the
{ CHILD_TASK_BLOCK and the EXIT_CONTROL_BLOCK.  The term target task is used in
{ the following discussion to refer to the task that "owns" the target block of
{ the EXIT.
{
{   If the target task is not the task issuing the EXIT, the CHILD_TASK_BLOCK
{ is the CLC$TASK_BLOCK corresponding to the direct child task of the target
{ task.  Otherwise the CHILD_TASK_BLOCK is NIL.
{
{   The EXIT_CONTROL_BLOCK designates a block that either is the target block
{ or is the closest "control block" to the target block that is marked for
{ exit.  If no such block exists in the target task, the EXIT_CONTROL_BLOCK is
{ NIL.  A "control block" is either a CLC$COMMAND_BLOCK,
{ CLC$COMMAND_PROC_BLOCK, CLC$FUNCTION_BLOCK, CLC$FUNCTION_PROC_BLOCK,
{ CLC$INPUT_BLOCK, or CLC$WHEN_BLOCK.  These blocks are "control" blocks in the
{ sense that there is an instance of execution of a procedure within the SCL
{ interpreter corresponding to each of these kinds of blocks.  These procedures
{ have condition handlers wihtin them that can perform a (CYBIL) non-local exit
{ out of the procedure for the "control block."
{
{   If the CHILD_TASK_BLOCK is not NIL (i.e.  the target task is an ancester of
{ the task issuing the EXIT) CLP$EXIT_BLOCK sends a "signal" to the target task
{ by calling CLP$SEND_EXITING_SIGNAL.  The "exiting signal" includes the
{ PMT$TASK_ID of the target task's direct child task (which may be the task
{ issuing the EXIT) and the EXIT_CONTROL_BLOCK (which may be NIL).  The handler
{ for this signal, CLP$SCL_SIGNAL_HANDLER, terminates the child task and, if
{ the EXIT_CONTROL_BLOCK is not NIL, causes the "task condition"
{ CLC$EXITING_CONDITION.
{
{   If the CHILD_TASK_BLOCK is NIL but the EXIT_CONTROL_BLOCK is not NIL,
{ CLP$EXIT_BLOCK, itself, causes the "task condition" CLC$EXITING_CONDITION.
{
{   If both CHILD_TASK_BLOCK and EXIT_CONTROL_BLOCK are NIL, CLP$EXIT_BLOCK
{ does nothing more.
{
{   The processing done directly by the processor of the EXIT statement is
{ complete at this point.  The block stack now indicates what, if any, further
{ processing is needed in order to accomplish the EXIT.
{
{   CLP$PROCESS_COMMAND_FILE makes a "is it time to exit the current input
{ block" check after it has called PROCESS_COMMAND_LINE.  PROCESS_COMMAND_LINE
{ makes the same check after it has processed each statement on a line.
{
{   It is time to exit the current input block if the block's BEING_EXITED
{ field is true and
{
{   - the input is from an interactive device, or
{   - it is not associated with a command utility, or
{   - the command utility's termination command isn't defined, or
{   - the command utility's termination command has been found.
{
{   To take care of finding a utility's termination command when the
{ interpreter mode is CLC$SKIP_MODE, CLP$PROCESS_COMMAND makes a check to see
{ if the command it is "skipping" is the termination command of the utility
{ associated with the current input block.  If so, CLP$IGNORE_REST_OF_FILE is
{ called to indicate that the termination command has been found.
{
{   The PROCESS_SUB_COMMAND routine called during command search sets the
{ "command search state" according to whether the command being processed is
{ the termination command of a utility.  This information is ultimately set in
{ the CLC$COMMAND_BLOCK or CLC$COMMAND_PROC_BLOCK "pushed" for the command by
{ the appropriate "invoke" routine.
{
{   (When a utility is created (CLP$CREATE_UTILITY_ENVIRONMENT), a definition
{ for the termination command is part of it.  This definition consists of the
{ command's index and ordinal within the command table associated with the
{ utility.  The ordinal is what is checked during command search to determine
{ whether the current command is a utility's termination command.  The index
{ is used to retrieve the name of the termination command from the table for a
{ CLP$GET_UTILITY_ATTRIBUTES call.)
{

  PROCEDURE exit_statement
    (    target_label: ost$name,
         initial_clause_name: ost$name;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      abort_option_allowed: boolean,
      abort_option_specified: boolean,
      clause_name: ost$name,
      clause_names: [STATIC, READ, oss$job_paged_literal] array [1 .. 3] of ost$name := ['ABORT', 'WHEN',
            'WITH'],
      error_condition: ost$status_condition_code,
      exit_condition: boolean,
      exit_status: ^ost$status,
      function_result: ^clt$internal_data_value,
      ignore_result_type_description: ^clt$type_description,
      next_parse: clt$parse_state,
      target_block: ^clt$block,
      terminating_utility: boolean,
      unexpected_condition: ost$status_condition_code,
      when_clause_specified: boolean,
      when_expression_parse: clt$parse_state,
      with_clause_allowed: boolean,
      with_clause_specified: boolean,
      with_expression_parse: clt$parse_state,
      with_expression_result: ^clt$data_value;


    clp$find_exit_block (target_label, target_block, terminating_utility, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    abort_option_allowed := target_block^.kind = clc$task_block;
    abort_option_specified := FALSE;
    clause_name := initial_clause_name;
    exit_status := NIL;
    function_result := NIL;
    when_clause_specified := FALSE;
    with_clause_allowed := target_block^.kind IN $clt$block_kinds
          [clc$check_block, clc$command_proc_block, clc$function_proc_block, clc$task_block];
    with_clause_specified := FALSE;

  /process_exit_parameters/
    WHILE NOT (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_end_of_line, clc$lex_semicolon]) DO

      IF clause_name = 'ABORT' THEN
        IF NOT abort_option_allowed THEN
          osp$set_status_condition (cle$abort_option_not_allowed, status);
          RETURN;
        ELSEIF abort_option_specified THEN
          osp$set_status_condition (cle$duplicate_abort_option, status);
          RETURN;
        IFEND;
        abort_option_specified := TRUE;

        clp$scan_non_space_lexical_unit (parse);
        IF (parse.unit.kind <> clc$lex_name) OR (NOT parse.previous_unit_is_space) THEN
          osp$set_status_condition (cle$expecting_with_after_abort, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          RETURN;
        IFEND;

        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);
        IF clause_name <> 'WITH' THEN
          osp$set_status_condition (cle$expecting_with_after_abort, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          RETURN;
        IFEND;
      IFEND;

      IF clause_name = 'WITH' THEN
        IF NOT with_clause_allowed THEN
          osp$set_status_condition (cle$with_clause_not_allowed, status);
          RETURN;
        ELSEIF with_clause_specified THEN
          osp$set_status_condition (cle$duplicate_with_clause, status);
          RETURN;
        IFEND;
        with_clause_specified := TRUE;

        clp$scan_non_space_lexical_unit (parse);
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_condition (cle$unexpected_after_with, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          RETURN;
        IFEND;

        find_clause_name (clause_names, FALSE, parse, next_parse, clause_name);
        with_expression_parse := parse;
        parse := next_parse;

        unexpected_condition := cle$unexpected_after_with_value;
        error_condition := 0;

      ELSEIF clause_name = 'WHEN' THEN
        IF when_clause_specified THEN
          osp$set_status_condition (cle$duplicate_when_clause, status);
          RETURN;
        IFEND;
        when_clause_specified := TRUE;

        clp$scan_non_space_lexical_unit (parse);
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_condition (cle$unexpected_after_when, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          RETURN;
        IFEND;

        find_clause_name (clause_names, FALSE, parse, next_parse, clause_name);
        when_expression_parse := parse;
        parse := next_parse;

        unexpected_condition := cle$unexpected_after_when_value;
        error_condition := 0;

      ELSEIF with_clause_allowed THEN
        IF with_clause_specified THEN
          IF when_clause_specified THEN
            error_condition := unexpected_condition;
          ELSE
            error_condition := cle$expecting_exit_when;
          IFEND;
        ELSEIF when_clause_specified THEN
          error_condition := cle$expecting_with;
        ELSE
          error_condition := cle$expecting_with_or_when;
        IFEND;

      ELSEIF when_clause_specified THEN
        error_condition := cle$unexpected_after_when_value;

      ELSE
        error_condition := cle$expecting_exit_when;
      IFEND;

      IF error_condition <> 0 THEN
        osp$set_status_condition (error_condition, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        RETURN;
      IFEND;

    WHILEND /process_exit_parameters/;

    IF (NOT with_clause_specified) AND (target_block^.kind IN $clt$block_kinds [clc$function_proc_block,
          clc$task_block]) THEN
      osp$set_status_condition (cle$with_clause_required, status);
      RETURN;
    IFEND;

    IF when_clause_specified THEN
      process_when_clause ('EXIT', when_expression_parse, work_area, exit_condition, status);
      IF NOT (status.normal AND exit_condition) THEN
        RETURN;
      IFEND;
    IFEND;

    IF with_clause_specified THEN
      IF target_block^.kind = clc$function_proc_block THEN
        clp$evaluate_unqual_union_expr (work_area, with_expression_parse, ignore_result_type_description,
              with_expression_result, status);
        IF NOT status.normal THEN
          IF status.condition = cle$unspecified_value_for_req THEN
            osp$set_status_abnormal ('CL', cle$unspecified_value_for_state, 'EXIT', status);
          IFEND;
          RETURN;
        IFEND;
        clp$convert_ext_value_to_int (NIL, with_expression_result, NIL, work_area, function_result, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSE
        PUSH exit_status;
        clp$evaluate_status_expression (work_area, with_expression_parse, exit_status^, status);
        IF NOT status.normal THEN
          IF status.condition = cle$unspecified_value_for_req THEN
            osp$set_status_abnormal ('CL', cle$unspecified_value_for_state, 'EXIT', status);
          IFEND;
          RETURN;
        IFEND;
      IFEND;

      IF with_expression_parse.unit_index < with_expression_parse.index_limit THEN
        osp$set_status_condition (cle$unexpected_after_with_value, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, with_expression_parse, status);
        RETURN;
      IFEND;
    IFEND;

    IF target_block^.kind <> clc$task_block THEN
      clp$exit_block (#OFFSET (target_block), exit_status, function_result, terminating_utility, status);
    ELSEIF abort_option_specified THEN
      pmp$abort (exit_status^);
    ELSE
      pmp$exit (exit_status^);
    IFEND;

  PROCEND exit_statement;
?? TITLE := 'clp$exit_proc_statement', EJECT ??

  PROCEDURE clp$exit_proc_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      initial_clause_name: ost$name,
      target_label: ost$name;


    status.normal := TRUE;

    CASE parse.unit.kind OF
    = clc$lex_end_of_line, clc$lex_semicolon =
      initial_clause_name := '';
    = clc$lex_name =
      #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), initial_clause_name);
      IF (initial_clause_name <> 'WHEN') AND (initial_clause_name <> 'WITH') THEN
        osp$set_status_abnormal ('CL', cle$expecting_with_or_when, initial_clause_name, status);
        RETURN;
      IFEND;
    = clc$lex_long_name =
      osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
            status);
      RETURN;
    ELSE
      osp$set_status_condition (cle$expecting_with_or_when, status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      RETURN;
    CASEND;

    target_label := 'PROC';
    exit_statement (target_label, initial_clause_name, parse, work_area, status);

  PROCEND clp$exit_proc_statement;
?? TITLE := 'clp$procedure_statement', EJECT ??

{
{ PURPOSE:
{   This procedure receives control if a PROCEDURE (PROC) statement is encounterred in the normal course of
{   processing commands.   Since PROCEDURE declarations can not be nested an error status is returned.  This
{   is done in order to produce a less misleading status than "Unknown command: PROCEDURE (PROC)".
{

  PROCEDURE clp$procedure_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);


    osp$set_status_condition (cle$unexpected_proc, status);

  PROCEND clp$procedure_statement;
?? TITLE := 'clp$procend_statement', EJECT ??

  PROCEDURE clp$procend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      proc_block: ^clt$block;


    parse.index_limit := STRLENGTH (parse.text^) + 1;
    check_statement_terminator ('PROCEND', clc$command_proc_block, parse, proc_block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$skip_block;

  PROCEND clp$procend_statement;
?? TITLE := 'clp$_function_statement', EJECT ??

{
{ PURPOSE:
{   This commadn receives control if a FUNCTION statement is encounterred in the normal course of processing
{   commands.   Since FUNCTION declarations can not be nested an error status is returned.  This is done in
{   order to produce a less misleading status than "Unknown command: FUNCTION".
{

  PROCEDURE [XDCL] clp$_function_statement
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


    osp$set_status_condition (cle$unexpected_function, status);

  PROCEND clp$_function_statement;
?? TITLE := 'clp$funcend_statement', EJECT ??

  PROCEDURE clp$funcend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      proc_block: ^clt$block;


    parse.index_limit := STRLENGTH (parse.text^) + 1;
    check_statement_terminator ('FUNCEND', clc$function_proc_block, parse, proc_block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$skip_block;

  PROCEND clp$funcend_statement;
?? TITLE := 'clp$check_statement', EJECT ??

  PROCEDURE clp$check_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);


    osp$set_status_abnormal ('CL', cle$not_supported, 'CHECK statement', status);

  PROCEND clp$check_statement;
?? TITLE := 'clp$checkend_statement', EJECT ??

  PROCEDURE clp$checkend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      check_block: ^clt$block;


    check_statement_terminator ('CHECKEND', clc$check_block, parse, check_block, status);
    IF (NOT status.normal) AND ((status.condition = cle$unexpected_control_statemnt) OR
          (status.condition = cle$unbalanced_block_structure)) THEN
      RETURN;
    IFEND;
    clp$pop_block_stack (check_block);

  PROCEND clp$checkend_statement;
?? TITLE := 'clp$block_statement', EJECT ??

  PROCEDURE clp$block_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      internal_input_block: ^clt$block,
      block_block: ^clt$block;


    status.normal := TRUE;
    IF NOT (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_end_of_line, clc$lex_semicolon]) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_statement_params, 'BLOCK', status);
      RETURN;
    IFEND;

    prepare_interactive_statement ('BLOCK', 'BLOCKEND', 'block', work_area, internal_input_block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$push_block_block (info.label, block_block);

    IF internal_input_block <> NIL THEN
      process_interactive_statement (internal_input_block, status);
    IFEND;

  PROCEND clp$block_statement;
?? TITLE := 'clp$blockend_statement', EJECT ??

  PROCEDURE clp$blockend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      block_block: ^clt$block;


    check_statement_terminator ('BLOCKEND', clc$block_block, parse, block_block, status);
    IF (NOT status.normal) AND ((status.condition = cle$unexpected_control_statemnt) OR
          (status.condition = cle$unbalanced_block_structure)) THEN
      RETURN;
    IFEND;
    clp$pop_block_stack (block_block);

  PROCEND clp$blockend_statement;
?? TITLE := 'clp$if_statement', EJECT ??

  PROCEDURE clp$if_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      if_block: ^clt$block,
      if_condition: boolean,
      internal_input_block: ^clt$block;


    status.normal := TRUE;
    IF info.interpreter_mode <> clc$interpret_mode THEN
      if_condition := FALSE;
    ELSE
      evaluate_boolean_expression ('IF', parse, work_area, 'THEN', if_condition, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    prepare_interactive_statement ('IF', 'IFEND', 'if', work_area, internal_input_block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$push_if_block (if_condition, if_block);

    IF internal_input_block <> NIL THEN
      process_interactive_statement (internal_input_block, status);
    IFEND;

  PROCEND clp$if_statement;
?? TITLE := 'interpret_if', EJECT ??

  FUNCTION [INLINE] interpret_if
    (    bool: boolean): clt$interpreter_modes;

    IF bool THEN
      interpret_if := clc$interpret_mode;
    ELSE
      interpret_if := clc$skip_mode;
    IFEND;

  FUNCEND interpret_if;
?? TITLE := 'clp$elseif_statement', EJECT ??

  PROCEDURE clp$elseif_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      if_block: ^clt$block,
      elseif_condition: boolean;


    status.normal := TRUE;
    clp$find_current_block (if_block);

    CASE if_block^.kind OF
    = clc$if_block =
      IF NOT if_block^.if_else_allowed THEN
        osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'ELSEIF', status);
        RETURN;
      IFEND;
    = clc$block_block, clc$case_block, clc$check_block, clc$command_proc_block, clc$for_block,
          clc$function_proc_block, clc$loop_block, clc$repeat_block, clc$when_block, clc$while_block =
      osp$set_status_abnormal ('CL', cle$unbalanced_block_structure, 'ELSEIF', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, if_block^.kind_end_name, status);
      RETURN;
    ELSE
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'ELSEIF', status);
      RETURN;
    CASEND;

    IF if_block^.if_condition_met THEN
      IF if_block^.interpreter_mode = clc$interpret_mode THEN
        clp$set_if_block (clc$skip_mode, TRUE, TRUE);
      IFEND;
    ELSEIF if_block^.previous_block^.interpreter_mode = clc$interpret_mode THEN
      evaluate_boolean_expression ('ELSEIF', parse, work_area, 'THEN', elseif_condition, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$set_if_block (interpret_if (elseif_condition), elseif_condition, TRUE);
    IFEND;

  PROCEND clp$elseif_statement;
?? TITLE := 'clp$else_statement', EJECT ??

  PROCEDURE clp$else_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      block: ^clt$block;


    status.normal := TRUE;
    clp$find_current_block (block);

    CASE block^.kind OF
    = clc$case_block =
      IF NOT block^.case_else_allowed THEN
        osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'ELSE', status);
        RETURN;
      ELSEIF NOT (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_end_of_line, clc$lex_semicolon]) THEN
        osp$set_status_abnormal ('CL', cle$unexpected_statement_params, 'ELSE', status);
        RETURN;
      IFEND;

      osp$set_status_abnormal ('CL', cle$not_supported, 'CASE ELSE statement', status);

    = clc$if_block =
      IF NOT block^.if_else_allowed THEN
        osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'ELSE', status);
        RETURN;
      ELSEIF NOT (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_end_of_line, clc$lex_semicolon]) THEN
        osp$set_status_abnormal ('CL', cle$unexpected_statement_params, 'ELSE', status);
        RETURN;
      IFEND;

      clp$set_if_block (interpret_if ((NOT block^.if_condition_met) AND
            (block^.previous_block^.interpreter_mode = clc$interpret_mode)), TRUE, FALSE);

    = clc$block_block, clc$check_block, clc$command_proc_block, clc$for_block, clc$function_proc_block,
          clc$loop_block, clc$repeat_block, clc$when_block, clc$while_block =
      osp$set_status_abnormal ('CL', cle$unbalanced_block_structure, 'ELSE', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, block^.kind_end_name, status);
      RETURN;
    ELSE
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'ELSE', status);
      RETURN;
    CASEND;

  PROCEND clp$else_statement;
?? TITLE := 'clp$ifend_statement', EJECT ??

  PROCEDURE clp$ifend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      if_block: ^clt$block;


    check_statement_terminator ('IFEND', clc$if_block, parse, if_block, status);
    IF (NOT status.normal) AND ((status.condition = cle$unexpected_control_statemnt) OR
          (status.condition = cle$unbalanced_block_structure)) THEN
      RETURN;
    IFEND;
    clp$pop_block_stack (if_block);

  PROCEND clp$ifend_statement;
?? TITLE := 'clp$case_statement', EJECT ??

  PROCEDURE clp$case_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      case_block: ^clt$block,
      internal_input_block: ^clt$block,
      selection_value: ^clt$internal_data_value;


    status.normal := TRUE;
    IF info.interpreter_mode <> clc$interpret_mode THEN
      selection_value := NIL;
    ELSE
      osp$set_status_abnormal ('CL', cle$not_supported, 'CASE statement', status);
      RETURN;
    IFEND;

    prepare_interactive_statement ('CASE', 'CASEND', 'case', work_area, internal_input_block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$push_case_block (selection_value, case_block);

    IF internal_input_block <> NIL THEN
      process_interactive_statement (internal_input_block, status);
    IFEND;

  PROCEND clp$case_statement;
?? TITLE := 'clp$case_selection_statement', EJECT ??

  PROCEDURE [XDCL] clp$case_selection_statement
    (    interpreter_mode: clt$interpreter_modes;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      case_block: ^clt$block;


    status.normal := TRUE;
    clp$find_current_block (case_block);

    CASE case_block^.kind OF
    = clc$case_block =
      IF NOT case_block^.case_else_allowed THEN
        osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'case selection', status);
        RETURN;
      IFEND;
    = clc$block_block, clc$check_block, clc$command_proc_block, clc$for_block, clc$function_proc_block,
          clc$if_block, clc$loop_block, clc$repeat_block, clc$when_block, clc$while_block =
      osp$set_status_abnormal ('CL', cle$unbalanced_block_structure, 'case selection', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, case_block^.kind_end_name, status);
      RETURN;
    ELSE
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'case selection', status);
      RETURN;
    CASEND;

    IF case_block^.case_selection_made THEN
      IF case_block^.interpreter_mode = clc$interpret_mode THEN
        osp$set_status_abnormal ('CL', cle$not_supported, 'CASE selection statement', status);
      IFEND;
    ELSEIF case_block^.previous_block^.interpreter_mode = clc$interpret_mode THEN
      osp$set_status_abnormal ('CL', cle$not_supported, 'CASE selection statement', status);
    IFEND;

  PROCEND clp$case_selection_statement;
?? TITLE := 'clp$casend_statement', EJECT ??

  PROCEDURE clp$casend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      case_block: ^clt$block;


    check_statement_terminator ('CASEND', clc$case_block, parse, case_block, status);
    IF (NOT status.normal) AND ((status.condition = cle$unexpected_control_statemnt) OR
          (status.condition = cle$unbalanced_block_structure)) THEN
      RETURN;
    IFEND;
    clp$pop_block_stack (case_block);

  PROCEND clp$casend_statement;
?? TITLE := 'clp$loop_statement', EJECT ??

  PROCEDURE clp$loop_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      internal_input_block: ^clt$block,
      loop_block: ^clt$block;


    status.normal := TRUE;
    IF NOT (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_end_of_line, clc$lex_semicolon]) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_statement_params, 'LOOP', status);
      RETURN;
    IFEND;

    prepare_interactive_statement ('LOOP', 'LOOPEND', 'loop', work_area, internal_input_block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$push_loop_block (info.label, loop_block);

    IF internal_input_block <> NIL THEN
      process_interactive_statement (internal_input_block, status);
    IFEND;

  PROCEND clp$loop_statement;
?? TITLE := 'clp$loopend_statement', EJECT ??

  PROCEDURE clp$loopend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      loop_block: ^clt$block;


    check_statement_terminator ('LOOPEND', clc$loop_block, parse, loop_block, status);
    IF (NOT status.normal) AND ((status.condition = cle$unexpected_control_statemnt) OR
          (status.condition = cle$unbalanced_block_structure)) THEN
      RETURN;
    IFEND;
    IF status.normal AND (NOT loop_block^.being_exited) AND
          (loop_block^.previous_block^.interpreter_mode = clc$interpret_mode) THEN
      clp$reset_input_position (loop_block^.line_identifier, loop_block^.line_parse);
      RETURN;
    IFEND;
    clp$pop_block_stack (loop_block);

  PROCEND clp$loopend_statement;
?? TITLE := 'clp$while_statement', EJECT ??

  PROCEDURE clp$while_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      expression_parse: clt$parse_state,
      expression_text: ^clt$string_value,
      expression_units_array: ^clt$lexical_units,
      internal_input_block: ^clt$block,
      while_block: ^clt$block,
      while_condition: boolean;


    status.normal := TRUE;
    expression_parse := parse;
    IF info.interpreter_mode <> clc$interpret_mode THEN
      while_condition := FALSE;
    ELSE
      evaluate_boolean_expression ('WHILE', parse, work_area, 'DO', while_condition, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      expression_parse.index_limit := parse.unit_index;
      PUSH expression_text: [STRLENGTH (expression_parse.text^)];
      expression_text^ := expression_parse.text^;
      expression_parse.text := expression_text;
      PUSH expression_units_array: [1 .. UPPERBOUND (expression_parse.units_array^)];
      expression_units_array^ := expression_parse.units_array^;
      expression_parse.units_array := expression_units_array;
    IFEND;

    prepare_interactive_statement ('WHILE', 'WHILEND', 'while', work_area, internal_input_block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$push_while_block (info.label, while_condition, expression_parse, while_block);

    IF internal_input_block <> NIL THEN
      process_interactive_statement (internal_input_block, status);
    IFEND;

  PROCEND clp$while_statement;
?? TITLE := 'clp$whilend_statement', EJECT ??

  PROCEDURE clp$whilend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      expression_parse: clt$parse_state,
      while_block: ^clt$block,
      while_condition: boolean;


    check_statement_terminator ('WHILEND', clc$while_block, parse, while_block, status);
    IF (NOT status.normal) AND ((status.condition = cle$unexpected_control_statemnt) OR
          (status.condition = cle$unbalanced_block_structure)) THEN
      RETURN;
    IFEND;
    IF status.normal AND (NOT while_block^.being_exited) AND
          (while_block^.previous_block^.interpreter_mode = clc$interpret_mode) THEN
      expression_parse := while_block^.expression_parse;
      evaluate_boolean_expression ('WHILE', expression_parse, work_area, 'DO', while_condition, status);
      IF status.normal AND while_condition THEN
        clp$reset_input_position (while_block^.line_identifier, while_block^.line_parse);
        RETURN;
      IFEND;
    IFEND;
    clp$pop_block_stack (while_block);

  PROCEND clp$whilend_statement;
?? TITLE := 'clp$repeat_statement', EJECT ??

  PROCEDURE clp$repeat_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      internal_input_block: ^clt$block,
      repeat_block: ^clt$block;


    status.normal := TRUE;
    IF NOT (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_end_of_line, clc$lex_semicolon]) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_statement_params, 'REPEAT', status);
      RETURN;
    IFEND;

    prepare_interactive_statement ('REPEAT', 'UNTIL', 'repeat', work_area, internal_input_block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$push_repeat_block (info.label, repeat_block);

    IF internal_input_block <> NIL THEN
      process_interactive_statement (internal_input_block, status);
    IFEND;

  PROCEND clp$repeat_statement;
?? TITLE := 'clp$until_statement', EJECT ??

  PROCEDURE clp$until_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      expression_parse: clt$parse_state,
      repeat_block: ^clt$block,
      until_condition: boolean;


    status.normal := TRUE;
    clp$find_current_block (repeat_block);
    IF repeat_block^.kind <> clc$repeat_block THEN
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'UNTIL', status);
      RETURN;
    IFEND;

    IF (NOT repeat_block^.being_exited) AND (repeat_block^.previous_block^.interpreter_mode =
          clc$interpret_mode) THEN
      expression_parse := parse;
      evaluate_boolean_expression ('UNTIL', parse, work_area, '', until_condition, status);
      IF status.normal AND (NOT until_condition) THEN
        IF repeat_block^.expression_area = NIL THEN
          expression_parse.index_limit := parse.unit_index;
          clp$set_repeat_until (expression_parse);
        IFEND;
        clp$reset_input_position (repeat_block^.line_identifier, repeat_block^.line_parse);
        RETURN;
      IFEND;
    IFEND;
    clp$pop_block_stack (repeat_block);

  PROCEND clp$until_statement;
?? TITLE := 'clp$for_statement', EJECT ??

  PROCEDURE clp$for_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      for_condition: boolean,
      for_increment: integer,
      for_initial: clt$integer,
      for_limit: integer,
      for_list: ^clt$internal_data_value,
      for_variable_already_declared: boolean,
      for_variable_expression: ^clt$variable_ref_expression,
      for_variable_name: clt$variable_name;

?? NEWTITLE := 'setup_for_incremental_control', EJECT ??

    PROCEDURE setup_for_incremental_control;

{ TYPE
{   for_integer_type_spec = integer
{ TYPEND

?? PUSH (LISTEXT := ON) ??

      VAR
        for_integer_type_spec: [STATIC, READ, cls$declaration_section] record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend := [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]];

?? POP ??

      VAR
        clause_name: ost$name,
        for_value: clt$data_value,
        for_value_description: clt$variable_value_description,
        result: clt$integer;


      IF parse.unit.kind <> clc$lex_equal THEN
        osp$set_status_condition (cle$expecting_for_assign, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT clp$for_statement;
      IFEND;
      clp$scan_non_space_lexical_unit (parse);

      clp$evaluate_integer_expression (clc$min_integer, clc$max_integer, work_area, parse, for_initial,
            status);
      IF NOT status.normal THEN
        IF status.condition = cle$unspecified_value_for_req THEN
          osp$set_status_abnormal ('CL', cle$unspecified_value_for_state, 'FOR', status);
        IFEND;
        EXIT clp$for_statement;
      IFEND;

      IF parse.unit_is_space THEN
        clp$scan_non_space_lexical_unit (parse);
      IFEND;
      IF NOT parse.previous_unit_is_space THEN
        osp$set_status_condition (cle$unexpected_after_for_init, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT clp$for_statement;
      IFEND;
      IF parse.unit.kind <> clc$lex_name THEN
        osp$set_status_condition (cle$expecting_for_to, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT clp$for_statement;
      IFEND;
      #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);
      IF clause_name <> 'TO' THEN
        osp$set_status_abnormal ('CL', cle$expecting_for_to, clause_name, status);
        EXIT clp$for_statement;
      IFEND;
      clp$scan_non_space_lexical_unit (parse);
      IF NOT parse.previous_unit_is_space THEN
        osp$set_status_condition (cle$unexpected_after_for_to, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT clp$for_statement;
      IFEND;

      clp$evaluate_integer_expression (clc$min_integer, clc$max_integer, work_area, parse, result, status);
      IF NOT status.normal THEN
        IF status.condition = cle$unspecified_value_for_req THEN
          osp$set_status_abnormal ('CL', cle$unspecified_value_for_state, 'FOR', status);
        IFEND;
        EXIT clp$for_statement;
      IFEND;
      for_limit := result.value;

      IF parse.unit_is_space THEN
        clp$scan_non_space_lexical_unit (parse);
      IFEND;
      for_increment := 1;

    /optional_part/
      BEGIN
        CASE parse.unit.kind OF
        = clc$lex_end_of_line, clc$lex_semicolon =
          EXIT /optional_part/;
        = clc$lex_name =
          IF NOT parse.previous_unit_is_space THEN
            osp$set_status_condition (cle$unexpected_after_for_final, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT clp$for_statement;
          IFEND;
        = clc$lex_long_name =
          osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                status);
          EXIT clp$for_statement;
        ELSE
          osp$set_status_condition (cle$expecting_for_by_or_do, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT clp$for_statement;
        CASEND;
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);

        IF clause_name <> 'DO' THEN
          IF clause_name <> 'BY' THEN
            osp$set_status_abnormal ('CL', cle$expecting_for_by_or_do, clause_name, status);
            EXIT clp$for_statement;
          IFEND;
          clp$scan_non_space_lexical_unit (parse);
          IF NOT parse.previous_unit_is_space THEN
            osp$set_status_condition (cle$unexpected_after_for_by, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT clp$for_statement;
          IFEND;

          clp$evaluate_integer_expression (clc$min_integer, clc$max_integer, work_area, parse, result,
                status);
          IF NOT status.normal THEN
            IF status.condition = cle$unspecified_value_for_req THEN
              osp$set_status_abnormal ('CL', cle$unspecified_value_for_state, 'FOR', status);
            IFEND;
            EXIT clp$for_statement;
          IFEND;
          for_increment := result.value;

          IF parse.unit_is_space THEN
            clp$scan_non_space_lexical_unit (parse);
          IFEND;
          CASE parse.unit.kind OF
          = clc$lex_end_of_line, clc$lex_semicolon =
            EXIT /optional_part/;
          = clc$lex_name =
            IF NOT parse.previous_unit_is_space THEN
              osp$set_status_condition (cle$unexpected_after_for_step, status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$for_statement;
            IFEND;
          = clc$lex_long_name =
            osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                  status);
            EXIT clp$for_statement;
          ELSE
            osp$set_status_condition (cle$expecting_for_by_or_do, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT clp$for_statement;
          CASEND;
          #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);
          IF clause_name <> 'DO' THEN
            osp$set_status_abnormal ('CL', cle$unexpected_after_for_step, clause_name, status);
            EXIT clp$for_statement;
          IFEND;
        IFEND;

        clp$scan_non_space_lexical_unit (parse);
        IF NOT (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_end_of_line, clc$lex_semicolon]) THEN
          osp$set_status_abnormal ('CL', cle$unexpected_after_then_or_do, 'DO', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT clp$for_statement;
        IFEND;
      END /optional_part/;

      for_value.kind := clc$integer;
      for_value.integer_value := for_initial;
      IF for_variable_already_declared THEN
        clp$produce_variable_ref_expr (for_variable_information.class, for_variable_name,
              for_variable_information.value_qualifiers, work_area, for_variable_expression, status);
        IF NOT status.normal THEN
          EXIT clp$for_statement;
        IFEND;
        for_value_description.kind := clc$variable_data_value;
        for_value_description.data_value := ^for_value;
        clp$update_variable (for_variable_expression, for_value_description, work_area, status);
      ELSE
        for_variable_expression := ^for_variable_name (1, clp$trimmed_string_size (for_variable_name));
        clp$create_var_from_type_spec (for_variable_name, clc$local_scope, clc$read_write,
              clc$immediate_evaluation, #SEQ (for_integer_type_spec), ^for_value, FALSE, work_area, status);
      IFEND;
      IF NOT status.normal THEN
        EXIT clp$for_statement;
      IFEND;
      for_control_is_incremental := ((for_increment >= 0) AND (for_initial.value <= for_limit)) OR
            ((for_increment < 0) AND (for_initial.value >= for_limit));

    PROCEND setup_for_incremental_control;
?? TITLE := 'setup_for_list_control', EJECT ??

    PROCEDURE setup_for_list_control;

      VAR
        clause_name: ost$name,
        for_list_element_type_desc: ^clt$type_description,
        for_list_element_type_spec: ^clt$type_specification,
        for_list_node: ^clt$i_data_value,
        for_value: ^clt$data_value,
        for_value_description: clt$variable_value_description,
        result_type_description: ^clt$type_description;


      IF parse.unit.kind <> clc$lex_name THEN
        osp$set_status_condition (cle$expecting_for_in, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT clp$for_statement;
      IFEND;
      #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);
      IF clause_name <> 'IN' THEN
        osp$set_status_abnormal ('CL', cle$expecting_for_in, clause_name, status);
        EXIT clp$for_statement;
      IFEND;
      clp$scan_non_space_lexical_unit (parse);
      IF NOT parse.previous_unit_is_space THEN
        osp$set_status_condition (cle$unexpected_after_for_in, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT clp$for_statement;
      IFEND;

      clp$evaluate_list_expression (0, clc$max_list_size, FALSE, NIL, work_area, parse,
            result_type_description, for_value, status);
      IF NOT status.normal THEN
        IF status.condition = cle$unspecified_value_for_req THEN
          osp$set_status_abnormal ('CL', cle$unspecified_value_for_state, 'FOR', status);
        IFEND;
        EXIT clp$for_statement;
      IFEND;

      IF parse.unit_is_space THEN
        clp$scan_non_space_lexical_unit (parse);
      IFEND;

    /optional_part/
      BEGIN
        CASE parse.unit.kind OF
        = clc$lex_end_of_line, clc$lex_semicolon =
          EXIT /optional_part/;
        = clc$lex_name =
          IF NOT parse.previous_unit_is_space THEN
            osp$set_status_condition (cle$unexpected_after_for_list, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT clp$for_statement;
          IFEND;
        = clc$lex_long_name =
          osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                status);
          EXIT clp$for_statement;
        ELSE
          osp$set_status_condition (cle$unexpected_after_for_list, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT clp$for_statement;
        CASEND;
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);
        IF clause_name <> 'DO' THEN
          osp$set_status_abnormal ('CL', cle$unexpected_after_for_list, clause_name, status);
          EXIT clp$for_statement;
        IFEND;

        clp$scan_non_space_lexical_unit (parse);
        IF NOT (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_end_of_line, clc$lex_semicolon]) THEN
          osp$set_status_abnormal ('CL', cle$unexpected_after_then_or_do, 'DO', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT clp$for_statement;
        IFEND;
      END /optional_part/;

      IF for_variable_already_declared THEN
        IF for_value^.element_value <> NIL THEN
          clp$produce_variable_ref_expr (for_variable_information.class, for_variable_name,
                for_variable_information.value_qualifiers, work_area, for_variable_expression, status);
          IF NOT status.normal THEN
            EXIT clp$for_statement;
          IFEND;
          for_value_description.kind := clc$variable_data_value;
          for_value_description.data_value := for_value^.element_value;
          clp$update_variable (for_variable_expression, for_value_description, work_area, status);
        IFEND;
        for_list_element_type_desc := NIL;
      ELSE
        for_variable_expression := ^for_variable_name (1, clp$trimmed_string_size (for_variable_name));
        IF (result_type_description = NIL) OR (result_type_description^.kind <> clc$list_type) THEN
          NEXT result_type_description IN work_area;
          IF result_type_description = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT clp$for_statement;
          IFEND;
          clp$derive_type_desc_from_value (for_value, work_area, result_type_description^, status);
          IF NOT status.normal THEN
            EXIT clp$for_statement;
          IFEND;
        IFEND;
        for_list_element_type_desc := result_type_description^.list_element_type_description;
        clp$convert_type_desc_to_spec (for_list_element_type_desc, work_area, for_list_element_type_spec,
              status);
        IF NOT status.normal THEN
          EXIT clp$for_statement;
        IFEND;
        clp$create_var_from_type_spec (for_variable_name, clc$local_scope, clc$read_write,
              clc$immediate_evaluation, for_list_element_type_spec, for_value^.element_value, FALSE,
              work_area, status);
      IFEND;
      IF NOT status.normal THEN
        EXIT clp$for_statement;
      IFEND;

      IF for_value^.element_value = NIL THEN
        for_list := NIL;
      ELSE
        clp$convert_ext_value_to_int (for_list_element_type_desc, for_value, NIL, work_area, for_list,
              status);
        IF NOT status.normal THEN
          EXIT clp$for_statement;
        IFEND;
        for_list_node := #PTR (for_list^.header.value, for_list^);
        for_list^.header.value := for_list_node^.link;
      IFEND;

    PROCEND setup_for_list_control;
?? OLDTITLE, EJECT ??

    VAR
      access_variable_requests: clt$access_variable_requests,
      for_block: ^clt$block,
      for_control_is_incremental: boolean,
      for_variable: clt$variable_name,
      for_variable_information: clt$variable_information,
      ignore_access_handle: clt$variable_access_handle,
      ignore_type_description: ^clt$type_description,
      internal_input_block: ^clt$block;


    status.normal := TRUE;
    for_control_is_incremental := FALSE;
    for_list := NIL;

    IF info.interpreter_mode = clc$interpret_mode THEN
      CASE parse.unit.kind OF
      = clc$lex_name =
        ;
      = clc$lex_long_name =
        osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
              status);
        RETURN;
      ELSE
        osp$set_status_condition (cle$expecting_for_var_or_each, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        RETURN;
      CASEND;
      #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), for_variable);
      for_control_is_incremental := for_variable <> 'EACH';
      IF NOT for_control_is_incremental THEN
        clp$scan_non_space_lexical_unit (parse);
        CASE parse.unit.kind OF
        = clc$lex_name =
          ;
        = clc$lex_long_name =
          osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                status);
          RETURN;
        ELSE
          osp$set_status_condition (cle$expecting_for_variable, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          RETURN;
        CASEND;
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), for_variable);
      IFEND;
      clp$scan_any_lexical_unit (parse);
      access_variable_requests := $clt$access_variable_requests [clc$return_value_qualifiers];
      clp$evaluate_name_for_write (for_variable, access_variable_requests, FALSE, parse, work_area,
            for_variable_name, for_variable_information, ignore_access_handle, ignore_type_description,
            for_variable_already_declared, status);
      IF NOT status.normal THEN

{ Ignore the error if it is the result of attempting to write to a read only parameter variable,
{ not through $VALUE or $PARAMETER_VALUE, and it is an unqualified reference.  Then go ahead
{ and implicitly create the variable as it would if the parameter variable did not exist.

        IF (status.condition <> cle$cannot_assign_to_a_read_var) OR (for_variable (1) = '$') OR
              (for_variable_information.class <> clc$param_variable) OR
              (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_left_parenthesis, clc$lex_dot]) THEN
          RETURN;
        IFEND;
        for_variable_already_declared := FALSE;
        status.normal := TRUE;
      IFEND;

      IF parse.unit_is_space THEN
        clp$scan_non_space_lexical_unit (parse);
      IFEND;
      IF for_control_is_incremental THEN
        setup_for_incremental_control;
      ELSE
        setup_for_list_control;
      IFEND;
    IFEND;

    prepare_interactive_statement ('FOR', 'FOREND', 'for', work_area, internal_input_block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF for_control_is_incremental THEN
      clp$push_for_incremental_block (info.label, for_variable_expression, for_initial, for_limit,
            for_increment, for_block);
    ELSE
      clp$push_for_list_block (info.label, for_variable_expression, for_list, for_block);
    IFEND;

    IF internal_input_block <> NIL THEN
      process_interactive_statement (internal_input_block, status);
    IFEND;

  PROCEND clp$for_statement;
?? TITLE := 'advance_for_increment', EJECT ??

  PROCEDURE [INLINE] advance_for_increment
    (    for_block: ^clt$block;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      new_value: clt$data_value,
      new_value_description: clt$variable_value_description;


    status.normal := TRUE;

    new_value.kind := clc$integer;
    new_value.integer_value.value := for_block^.for_control.value.value + for_block^.for_control.increment;
    new_value.integer_value.radix := for_block^.for_control.value.radix;
    new_value.integer_value.radix_specified := for_block^.for_control.value.radix_specified;

    new_value_description.kind := clc$variable_data_value;
    new_value_description.data_value := ^new_value;
    clp$update_variable (for_block^.for_variable, new_value_description, work_area, status);

  PROCEND advance_for_increment;
?? TITLE := 'advance_for_list', EJECT ??

  PROCEDURE [INLINE] advance_for_list
    (    for_block: ^clt$block;
         for_list: ^clt$internal_data_value;
         for_list_element: REL (clt$internal_data_value) ^clt$i_data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      for_list_element_value: ^clt$data_value,
      for_list_element_value_desc: clt$variable_value_description;


    clp$convert_int_value_to_ext (for_list, for_list_element, work_area, for_list_element_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    for_list_element_value_desc.kind := clc$variable_data_value;
    for_list_element_value_desc.data_value := for_list_element_value;
    clp$update_variable (for_block^.for_variable, for_list_element_value_desc, work_area, status);

  PROCEND advance_for_list;
?? TITLE := 'clp$forend_statement', EJECT ??

  PROCEDURE clp$forend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      for_block: ^clt$block,
      for_list_node: ^clt$i_data_value,
      for_value: integer,
      forend_condition: boolean;


    check_statement_terminator ('FOREND', clc$for_block, parse, for_block, status);
    IF (NOT status.normal) AND ((status.condition = cle$unexpected_control_statemnt) OR
          (status.condition = cle$unbalanced_block_structure)) THEN
      RETURN;
    IFEND;

    IF status.normal AND (NOT for_block^.being_exited) AND
          (for_block^.previous_block^.interpreter_mode = clc$interpret_mode) THEN
      IF for_block^.for_control.style = clc$for_control_incremental THEN
        for_value := for_block^.for_control.value.value + for_block^.for_control.increment;
        forend_condition := ((for_block^.for_control.increment > 0) AND
              (for_value <= for_block^.for_control.limit)) OR ((for_block^.for_control.increment < 0) AND
              (for_value >= for_block^.for_control.limit));
        IF forend_condition THEN
          advance_for_increment (for_block, work_area, status);
        IFEND;
      ELSE {clc$for_control_list}
        for_list_node := #PTR (for_block^.for_control.list^.header.value, for_block^.for_control.list^);
        forend_condition := for_list_node <> NIL;
        IF forend_condition THEN
          advance_for_list (for_block, for_block^.for_control.list, for_list_node^.element_value, work_area,
                status);
        IFEND;
      IFEND;

      IF status.normal AND forend_condition THEN
        clp$advance_for_block (TRUE);
        clp$reset_input_position (for_block^.line_identifier, for_block^.line_parse);
        RETURN;
      IFEND;
    IFEND;

    clp$pop_block_stack (for_block);

  PROCEND clp$forend_statement;
?? TITLE := 'clp$when_statement', EJECT ??

  PROCEDURE clp$when_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      any_condition: boolean,
      any_fault: boolean,
      do_clause_name: [STATIC, READ, oss$job_paged_literal] array [1 .. 1] of ost$name := ['DO'],
      ignore_found_clause_name: ost$name,
      next_parse: clt$parse_state,
      specific_conditions: ^clt$when_conditions,
      substitution_mark: clt$substitution_mark,
      when_can_be_echoed: boolean,
      when_statement_area: ^clt$collect_statement_area;


    status.normal := TRUE;
    IF info.interpreter_mode = clc$interpret_mode THEN
      find_clause_name (do_clause_name, TRUE, parse, next_parse, ignore_found_clause_name);
      get_when_conditions ('WHEN', parse, work_area, specific_conditions, any_fault, any_condition, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    substitution_mark.specified := FALSE;
    clp$prepare_delayed_block (info.interpreter_mode, 'WHEN', 'WHENEND', 'when', '', substitution_mark,
          when_statement_area, when_can_be_echoed, status);
    IF (NOT status.normal) OR (info.interpreter_mode <> clc$interpret_mode) THEN
      RETURN;
    IFEND;

    clp$establish_condition_handler (any_condition, any_fault, specific_conditions, when_statement_area,
          when_can_be_echoed, status);

  PROCEND clp$when_statement;
?? TITLE := 'get_when_conditions', EJECT ??

  PROCEDURE get_when_conditions
    (    statement_name: ost$name_reference;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR specific_conditions: ^clt$when_conditions;
     VAR any_fault: boolean;
     VAR any_condition: boolean;
     VAR status: ost$status);

    TYPE
      t$condition_name = record
        link: ^t$condition_name,
        name: clt$when_condition,
      recend;

    VAR
      condition_name_count: clt$list_size,
      condition_name_list: ^t$condition_name,
      condition_name_node: ^^t$condition_name,
      i: clt$list_size,
      original_work_area: ^clt$work_area;


    status.normal := TRUE;
    any_condition := FALSE;
    any_fault := FALSE;
    specific_conditions := NIL;

    original_work_area := work_area;
    condition_name_count := 0;
    condition_name_list := NIL;
    condition_name_node := ^condition_name_list;

  /evaluate_condition_names/
    WHILE TRUE DO
      IF condition_name_node^ = NIL THEN
        PUSH condition_name_node^;
        condition_name_node^^.link := NIL;
      IFEND;

      clp$evaluate_data_name_expr (work_area, parse, condition_name_node^^.name, status);
      IF NOT status.normal THEN
        IF status.condition = cle$unspecified_value_for_req THEN
          osp$set_status_abnormal ('CL', cle$unspecified_value_for_state, statement_name, status);
        IFEND;
        RETURN;
      IFEND;

    /process_condition_name/
      BEGIN
        IF condition_name_node^^.name = clc$wc_any_condition THEN
          any_condition := TRUE;
          EXIT /process_condition_name/;
        ELSEIF condition_name_node^^.name = clc$wc_any_fault THEN
          any_fault := TRUE;
          EXIT /process_condition_name/;
        ELSEIF condition_name_node^^.name = 'PROGRAM_FAULT' THEN
          condition_name_node^^.name := clc$wc_command_fault;
        ELSEIF condition_name_node^^.name = 'RESOURCE_FAULT' THEN
          condition_name_node^^.name := clc$wc_limit_fault;
        ELSEIF condition_name_node^^.name = 'INTERRUPT' THEN
          condition_name_node^^.name := clc$wc_pause;
        ELSEIF condition_name_node^^.name = osc$unseen_mail_condition THEN
          condition_name_node^^.name := clc$wc_unseen_mail;
        IFEND;
        condition_name_node := ^condition_name_node^^.link;
        condition_name_count := condition_name_count + 1;
      END /process_condition_name/;

      IF parse.unit_is_space THEN
        clp$scan_non_space_lexical_unit (parse);
      IFEND;
      IF parse.unit_index >= parse.index_limit THEN
        EXIT /evaluate_condition_names/;
      IFEND;
      CASE parse.unit.kind OF
      = clc$lex_end_of_line, clc$lex_semicolon =
        EXIT /evaluate_condition_names/;
      = clc$lex_comma =
        clp$scan_non_space_lexical_unit (parse);
      = clc$lex_long_name =
        osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
              status);
        RETURN;
      = clc$lex_name =
        ;
      ELSE
        osp$set_status_condition (cle$unexpected_after_cond_name, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        RETURN;
      CASEND;
    WHILEND /evaluate_condition_names/;

    work_area := original_work_area;

    IF condition_name_count = 0 THEN
      RETURN;
    IFEND;

    NEXT specific_conditions: [1 .. condition_name_count] IN work_area;
    condition_name_node := ^condition_name_list;
    FOR i := 1 TO condition_name_count DO
      specific_conditions^ [i] := condition_name_node^^.name;
      condition_name_node := ^condition_name_node^^.link;
    FOREND;

  PROCEND get_when_conditions;
?? TITLE := 'clp$whenend_statement', EJECT ??

  PROCEDURE clp$whenend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      when_block: ^clt$block;


    check_statement_terminator ('WHENEND', clc$when_block, parse, when_block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$skip_block;

  PROCEND clp$whenend_statement;
?? TITLE := 'clp$continue_statement', EJECT ??

  PROCEDURE clp$continue_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      clause_name: ost$name,
      continue_when_condition_option: clt$condition_processed_state,
      expecting_when: ost$status_condition,
      process_continue: boolean,
      when_block: ^clt$block;


    status.normal := TRUE;
    clp$find_current_block (when_block);

  /find_when_block/
    WHILE when_block <> NIL DO
      CASE when_block^.kind OF
      = clc$block_block, clc$command_block, clc$for_block, clc$if_block, clc$input_block, clc$loop_block,
            clc$repeat_block, clc$while_block =
        when_block := when_block^.previous_block;
      = clc$when_block =
        EXIT /find_when_block/;
      ELSE
        when_block := NIL;
        EXIT /find_when_block/;
      CASEND;
    WHILEND /find_when_block/;

    IF when_block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'CONTINUE', status);
      RETURN;
    IFEND;

  /process_continue_parameters/
    BEGIN
      continue_when_condition_option := clc$continue_next;

      CASE parse.unit.kind OF
      = clc$lex_end_of_line, clc$lex_semicolon =
        EXIT /process_continue_parameters/;
      = clc$lex_name =
        ;
      ELSE
        osp$set_status_condition (cle$expecting_retry_or_when, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        RETURN;
      CASEND;

      #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);
      expecting_when := cle$expecting_retry_or_when;

    /process_continue_option/
      BEGIN
        IF clause_name = 'WHEN' THEN
          EXIT /process_continue_option/;
        ELSEIF clause_name = 'RETRY' THEN
          continue_when_condition_option := clc$continue_retry;
        ELSEIF clause_name = 'NEXT_USER_HANDLER' THEN
          continue_when_condition_option := clc$continue_next_user_handler;
        ELSEIF clause_name = 'NEXT_HANDLER' THEN
          continue_when_condition_option := clc$continue_next_handler;
        ELSEIF clause_name <> 'NEXT' THEN
          osp$set_status_condition (cle$expecting_retry_or_when, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          RETURN;
        IFEND;

        clp$scan_non_space_lexical_unit (parse);
        IF parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_end_of_line, clc$lex_semicolon] THEN
          EXIT /process_continue_parameters/;
        IFEND;
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_condition (cle$unexpected_after_retry, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, clause_name, status);
          RETURN;
        IFEND;
        IF parse.unit.kind <> clc$lex_name THEN
          osp$set_status_condition (cle$expecting_continue_when, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          RETURN;
        IFEND;
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);
        expecting_when := cle$expecting_continue_when;
      END /process_continue_option/;

      IF clause_name <> 'WHEN' THEN
        osp$set_status_condition (expecting_when, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        RETURN;
      IFEND;
      clp$scan_non_space_lexical_unit (parse);
      process_when_clause ('CONTINUE', parse, work_area, process_continue, status);
      IF NOT (status.normal AND process_continue) THEN
        RETURN;
      IFEND;
    END /process_continue_parameters/;

    CASE continue_when_condition_option OF

    = clc$continue_retry =
      IF (when_block^.when_condition^.name <> clc$wc_command_fault) AND
            (when_block^.when_condition^.name <> clc$wc_execution_fault) THEN
        continue_when_condition_option := clc$continue_next;
      IFEND;

    = clc$continue_next_handler, clc$continue_next_user_handler =
      IF NOT when_block^.when_condition^.exit_on_continue_condition THEN
        IF when_block^.when_condition^.default_handler <> NIL THEN
          clp$process_continued_condition (when_block, continue_when_condition_option, status);
        ELSEIF continue_when_condition_option = clc$continue_next_handler THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, status);
        ELSE
          pmp$continue_to_cause (pmc$inhibit_standard_procedure, status);
        IFEND;
        RETURN;
      IFEND;

    ELSE
      ;
    CASEND;

    clp$continue (continue_when_condition_option, status);

  PROCEND clp$continue_statement;
?? TITLE := 'clp$cancel_statement', EJECT ??

  PROCEDURE clp$cancel_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      any_condition: boolean,
      any_fault: boolean,
      specific_conditions: ^clt$when_conditions;


    get_when_conditions ('CANCEL', parse, work_area, specific_conditions, any_fault, any_condition, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$disestablish_cond_handler (any_condition, any_fault, specific_conditions);

  PROCEND clp$cancel_statement;
?? TITLE := 'clp$cause_statement', EJECT ??

  PROCEDURE clp$cause_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      cause_status: ost$status,
      clause_name: ost$name;


    status.normal := TRUE;
    cause_condition := clc$wc_command_fault;
    cause_status.normal := TRUE;

  /determine_condition_to_cause/
    BEGIN
      IF parse.unit.kind = clc$lex_name THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);
        IF clause_name = 'CONDITION' THEN
          clp$scan_non_space_lexical_unit (parse);
          clp$evaluate_data_name_expr (work_area, parse, cause_condition, status);
          IF NOT status.normal THEN
            IF status.condition = cle$unspecified_value_for_req THEN
              osp$set_status_abnormal ('CL', cle$unspecified_value_for_state, 'CAUSE', status);
            IFEND;
            cause_condition := osc$null_name;
            RETURN;
          ELSEIF (cause_condition = clc$wc_exit) OR (cause_condition = clc$wc_any_fault) OR
                (cause_condition = clc$wc_any_condition) THEN
            osp$set_status_abnormal ('CL', cle$cannot_cause_condition, cause_condition, status);
            cause_condition := osc$null_name;
            RETURN;
          IFEND;

          IF parse.unit_is_space THEN
            clp$scan_non_space_lexical_unit (parse);
          IFEND;
          CASE parse.unit.kind OF
          = clc$lex_end_of_line, clc$lex_semicolon =
            EXIT /determine_condition_to_cause/;
          = clc$lex_name =
            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);
            IF clause_name <> 'WITH' THEN
              osp$set_status_condition (cle$expecting_with_for_cause, status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              cause_condition := osc$null_name;
              RETURN;
            IFEND;
            clp$scan_non_space_lexical_unit (parse);
          ELSE
            osp$set_status_condition (cle$expecting_with_for_cause, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            cause_condition := osc$null_name;
            RETURN;
          CASEND;
        IFEND;
      IFEND;

      clp$evaluate_status_expression (work_area, parse, cause_status, status);
      IF NOT status.normal THEN
        IF status.condition = cle$unspecified_value_for_req THEN
          osp$set_status_abnormal ('CL', cle$unspecified_value_for_state, 'CAUSE', status);
        IFEND;
        cause_condition := osc$null_name;
        RETURN;
      IFEND;

      IF parse.unit_is_space THEN
        clp$scan_non_space_lexical_unit (parse);
      IFEND;
      IF NOT (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_end_of_line, clc$lex_semicolon]) THEN
        osp$set_status_abnormal ('CL', cle$unexpected_statement_params, 'CAUSE status', status);
        cause_condition := osc$null_name;
        RETURN;
      IFEND;
    END /determine_condition_to_cause/;

    status := cause_status;

  PROCEND clp$cause_statement;
?? TITLE := 'TASK/TASKEND processing TYPEs and VARiables', EJECT ??

  TYPE
    clt$task_parameters = record
      task_name: ost$name,
      can_be_echoed: boolean,
      statement_area_size: integer,
    recend,
    clt$task_statement_area = clt$collect_statement_area;

*copyc clv$task_name
?? TITLE := 'clp$_task', EJECT ??

  PROCEDURE [XDCL] clp$_task
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$task) task (
{   task_name, tn: name = $optional
{   ring, r: integer osc$min_ring..osc$max_ring = $ring
{   debug_mode, dm: boolean = no
{   substitution_mark, sm: any of
{       key
{         none
{       keyend
{       string 1
{     anyend = none
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 9] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (5),
        recend,
        type3: record
          header: clt$type_specification_header,
          default_value: string (2),
        recend,
        type4: 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$string_type_qualifier,
          recend,
          default_value: string (4),
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 21, 19, 50, 14, 987], clc$command, 9, 5, 0, 0, 0, 0, 5, 'OSM$TASK'],
            [['DEBUG_MODE                     ', clc$nominal_entry, 3],
            ['DM                             ', clc$abbreviation_entry, 3],
            ['R                              ', clc$abbreviation_entry, 2],
            ['RING                           ', clc$nominal_entry, 2],
            ['SM                             ', clc$abbreviation_entry, 4],
            ['STATUS                         ', clc$nominal_entry, 5],
            ['SUBSTITUTION_MARK              ', clc$nominal_entry, 4],
            ['TASK_NAME                      ', clc$nominal_entry, 1],
            ['TN                             ', clc$abbreviation_entry, 1]], [

{ PARAMETER 1

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 5],

{ PARAMETER 3

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 2],

{ PARAMETER 4

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 72, clc$optional_default_parameter, 0, 4],

{ PARAMETER 5

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$integer_type], [osc$min_ring, osc$max_ring, 10], '$ring'],

{ PARAMETER 3

      [[1, 0, clc$boolean_type], 'no'],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$string_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 8, [[1, 0, clc$string_type], [1, 1, FALSE]], 'none'],

{ PARAMETER 5

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$task_name = 1,
      p$ring = 2,
      p$debug_mode = 3,
      p$substitution_mark = 4,
      p$status = 5;

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

    VAR
      program_description_area: SEQ (pmt$program_attributes, amt$local_file_name),
      program_description: ^pmt$program_description,
      program_attributes: ^pmt$program_attributes,
      program_library_list: ^pmt$object_library_list,
      program_parameters: ^pmt$program_parameters,
      task_parameters: ^clt$task_parameters,
      search_mode: clt$command_search_modes,
      statement_area: ^clt$collect_statement_area,
      can_be_echoed: boolean,
      area_size: integer,
      block: ^clt$block,
      use_command_search_mode: boolean,
      task_statement_area: ^clt$task_statement_area,
      ignore_task_id: pmt$task_id,
      interpreter_mode: clt$interpreter_modes,
      substitution_mark: clt$substitution_mark;


    status.normal := TRUE;
    substitution_mark.specified := FALSE;

    clp$find_current_block (block);
    use_command_search_mode := block^.use_command_search_mode;
    interpreter_mode := block^.interpreter_mode;
    #SPOIL (use_command_search_mode, interpreter_mode);

    IF interpreter_mode = clc$skip_mode THEN
      PUSH task_parameters;
      clp$prepare_delayed_block (clc$skip_mode, 'TASK', 'TASKEND', 'task', '', substitution_mark,
            statement_area, can_be_echoed, status);
      RETURN;
    IFEND;

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

    IF pvt [p$substitution_mark].value^.kind = clc$string THEN
      IF clv$non_substitution_mark [pvt [p$substitution_mark].value^.string_value^ (1)] THEN
        osp$set_status_abnormal ('CL', cle$improper_substitution_mark,
              pvt [p$substitution_mark].value^.string_value^ (1), status);
        RETURN;
      IFEND;
      substitution_mark.specified := TRUE;
      substitution_mark.value := pvt [p$substitution_mark].value^.string_value^ (1);
    IFEND;

    IF (NOT pvt [p$task_name].specified) AND substitution_mark.specified THEN
      osp$set_status_condition (cle$improper_use_of_subst_mark, status);
      RETURN;
    IFEND;

    program_description := ^program_description_area;
    RESET program_description;
    NEXT program_attributes IN program_description;
    program_attributes^.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$library_list_specified, pmc$load_map_file_specified,
          pmc$load_map_options_specified, pmc$term_error_level_specified, pmc$max_stack_size_specified,
          pmc$abort_file_specified, pmc$debug_mode_specified];
    program_attributes^.starting_procedure := 'CLP$TASK_TASKEND';
    program_attributes^.number_of_libraries := 1;
    NEXT program_library_list: [1 .. 1] IN program_description;
    program_library_list^ [1] := loc$task_services_library_name;
    program_attributes^.load_map_file := clv$standard_files [clc$sf_null_file].path_handle_name;
    program_attributes^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    program_attributes^.termination_error_level := LOWERVALUE (pmt$termination_error_level);
    program_attributes^.maximum_stack_size := UPPERVALUE (ost$segment_length);
    program_attributes^.abort_file := clv$standard_files [clc$sf_null_file].path_handle_name;
    program_attributes^.debug_mode := pvt [p$debug_mode].value^.boolean_value.value;

    clp$get_command_search_mode (search_mode);

    IF pvt [p$task_name].specified THEN

{ Asynchronous mode.

      IF (search_mode = clc$exclusive_command_search) AND use_command_search_mode THEN
        osp$set_status_abnormal ('CL', cle$not_allowed_in_exclusive, 'TASK/TASKEND', status);
        RETURN;
      IFEND;

      clp$prepare_delayed_block (interpreter_mode, 'TASK', 'TASKEND', 'task', '', substitution_mark,
            statement_area, can_be_echoed, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF statement_area = NIL THEN
        osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$task_taskend', status);
        RETURN;
      IFEND;

      area_size := #SIZE (statement_area^);
      PUSH program_parameters: [[clt$task_parameters, REP area_size OF cell]];
      RESET program_parameters;

      NEXT task_parameters IN program_parameters;
      task_parameters^.task_name := pvt [p$task_name].value^.name_value;
      task_parameters^.can_be_echoed := can_be_echoed;
      task_parameters^.statement_area_size := area_size;
      NEXT task_statement_area: [[REP area_size OF cell]] IN program_parameters;
      task_statement_area^ := statement_area^;

      clp$execute_named_task (pvt [p$task_name].value^.name_value, pvt [p$ring].value^.integer_value.value,
            program_description^, program_parameters^, ignore_command_file, ignore_task_id, status);
    ELSE

{ Synchronous mode.

      IF (search_mode = clc$exclusive_command_search) AND use_command_search_mode AND
            (pvt [p$ring].value^.integer_value.value < #RING (block)) THEN
        osp$set_status_abnormal ('CL', cle$not_allowed_in_exclusive, 'TASK/TASKEND', status);
        RETURN;
      IFEND;

      PUSH program_parameters: [[clt$task_parameters]];
      RESET program_parameters;
      NEXT task_parameters IN program_parameters;
      task_parameters^.task_name := osc$null_name;
      clp$execute_named_task (osc$null_name, pvt [p$ring].value^.integer_value.value, program_description^,
            program_parameters^, ignore_command_file, ignore_task_id, status);
    IFEND;

  PROCEND clp$_task;
?? TITLE := 'clp$task_taskend', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$task_taskend
    (    program_parameters: pmt$program_parameters;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      connected_files: ^clt$connected_files,
      end_block: ^clt$block,
      ignore_status: ost$status,
      parameters: ^pmt$program_parameters,
      substitution_mark: clt$substitution_mark,
      task_name: ost$name,
      task_parameters: ^clt$task_parameters,
      task_statement_area: ^clt$task_statement_area,
      valid_local_file_name: boolean,
      valid_task_name: boolean;

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

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

      clp$process_exit_condition (block, status);

      IF task_parameters^.can_be_echoed THEN
        clp$find_connected_files (connected_files);
        IF connected_files^.echo_count > 0 THEN
          clp$echo_trace_information ('CLC$ECHO_TASK_END', ^task_name, NIL, ^status, ignore_status);
        IFEND;
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    parameters := ^program_parameters;
    RESET parameters;
    NEXT task_parameters IN parameters;
    IF task_parameters <> NIL THEN
      IF clv$task_name <> osc$null_name THEN
        valid_task_name := FALSE;
      ELSEIF task_parameters^.task_name = osc$null_name THEN
        task_name := osc$null_name;
        valid_task_name := TRUE;
      ELSE
        clp$validate_name (task_parameters^.task_name, task_name, valid_task_name);
      IFEND;
    IFEND;
    clp$find_current_block (block);
    IF (task_parameters = NIL) OR (NOT valid_task_name) OR (block^.kind <> clc$task_block) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$task_taskend', status);
      pmp$abort (status);
    IFEND;

    clp$set_task_statement_task (task_name);

    IF task_name = osc$null_name THEN
      clp$include_file (clc$current_command_input, 'task', osc$null_name, status);
    ELSE
      NEXT task_statement_area: [[REP task_parameters^.statement_area_size OF cell]] IN parameters;
      IF task_statement_area = NIL THEN
        osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$task_taskend', status);
        pmp$abort (status);
      IFEND;

      IF task_parameters^.can_be_echoed THEN
        clp$find_connected_files (connected_files);
        IF connected_files^.echo_count > 0 THEN
          clp$echo_trace_information ('CLC$ECHO_TASK_BEGIN', ^task_name, NIL, NIL, ignore_status);
        IFEND;
      IFEND;

      osp$establish_block_exit_hndlr (^abort_handler);

      clp$push_input_internal_block (osc$null_name, task_parameters^.can_be_echoed, task_statement_area,
            block);

      clp$process_command_file (block, NIL, status);
      IF status.normal AND (NOT block^.being_exited) THEN
        clp$find_current_block (end_block);
        IF end_block <> block THEN
          osp$set_status_abnormal ('CL', cle$unbalanced_block_structure, block^.kind_end_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, end_block^.kind_end_name, status);
        IFEND;
      IFEND;

      clp$process_exit_condition (block, status);

      IF task_parameters^.can_be_echoed THEN
        clp$find_connected_files (connected_files);
        IF connected_files^.echo_count > 0 THEN
          clp$echo_trace_information ('CLC$ECHO_TASK_END', ^task_name, NIL, ^status, ignore_status);
        IFEND;
      IFEND;

      osp$disestablish_cond_handler;

      IF status.normal THEN
        clp$pop_input_stack (end_block, status);
      ELSE
        clp$pop_input_stack (end_block, ignore_status);
      IFEND;
    IFEND;

  PROCEND clp$task_taskend;
?? TITLE := 'clp$$task_name', EJECT ??

  PROCEDURE [XDCL] clp$$task_name
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);


    clp$scan_argument_list (function_name, argument_list, NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    value.descriptor := clv$value_descriptors [clc$string_value];
    value.kind := clc$string_value;
    value.str.size := osc$max_name_size;
    WHILE (value.str.size > 0) AND (clv$task_name (value.str.size) = ' ') DO
      value.str.size := value.str.size - 1;
    WHILEND;
    value.str.value := clv$task_name;

  PROCEND clp$$task_name;
?? TITLE := 'clp$taskend_statement', EJECT ??

  PROCEDURE clp$taskend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      current_block: ^clt$block;


    status.normal := TRUE;
    clp$find_current_block (current_block);
    IF (current_block^.previous_block^.kind <> clc$task_block) OR
          (current_block^.previous_block^.task_kind <> clc$task_statement_task) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'TASKEND', status);
    ELSE
      clp$skip_block;
    IFEND;

  PROCEND clp$taskend_statement;
?? TITLE := 'clp$push_commands', EJECT ??

  PROCEDURE clp$push_commands
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context;

    status.normal := TRUE;

    context := NIL;

    IF NOT (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_end_of_line, clc$lex_semicolon]) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_statement_params, 'PUSH_COMMANDS', status);
      RETURN;
    IFEND;

    REPEAT
      clp$push_dynamic_command_list (status);
      IF osp$file_access_condition (status) THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
  PROCEND clp$push_commands;
?? TITLE := 'clp$push_statement', EJECT ??

  PROCEDURE clp$push_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      name: ost$name;


    status.normal := TRUE;

  /process_object_names/
    WHILE TRUE DO
      clp$evaluate_data_name_expr (work_area, parse, name, status);
      IF NOT status.normal THEN
        IF status.condition = cle$unspecified_value_for_req THEN
          osp$set_status_abnormal ('CL', cle$unspecified_value_for_state, 'PUSH', status);
        IFEND;
        RETURN
      IFEND;

      clp$push_environment (name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF parse.unit_is_space THEN
        clp$scan_non_space_lexical_unit (parse);
      IFEND;
      CASE parse.unit.kind OF
      = clc$lex_end_of_line, clc$lex_semicolon =
        EXIT /process_object_names/;
      = clc$lex_comma =
        clp$scan_non_space_lexical_unit (parse);
      ELSE
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_condition (cle$unexpected_after_obj_name, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        IFEND;
      CASEND;
    WHILEND /process_object_names/;

  PROCEND clp$push_statement;
?? TITLE := 'clp$pop_statement', EJECT ??

  PROCEDURE clp$pop_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      name: ost$name;


    status.normal := TRUE;

  /process_object_names/
    WHILE TRUE DO
      clp$evaluate_data_name_expr (work_area, parse, name, status);
      IF NOT status.normal THEN
        IF status.condition = cle$unspecified_value_for_req THEN
          osp$set_status_abnormal ('CL', cle$unspecified_value_for_state, 'POP', status);
        IFEND;
        RETURN
      IFEND;

      clp$pop_environment (name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF parse.unit_is_space THEN
        clp$scan_non_space_lexical_unit (parse);
      IFEND;
      CASE parse.unit.kind OF
      = clc$lex_end_of_line, clc$lex_semicolon =
        EXIT /process_object_names/;
      = clc$lex_comma =
        clp$scan_non_space_lexical_unit (parse);
      ELSE
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_condition (cle$unexpected_after_obj_name, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        IFEND;
      CASEND;
    WHILEND /process_object_names/;

  PROCEND clp$pop_statement;
?? TITLE := 'clp$type_statement', EJECT ??

  PROCEDURE clp$type_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

{ TYPE
{   type = type
{ TYPEND

?? PUSH (LISTEXT := ON) ??

    VAR
      type_specification: [STATIC, READ, cls$declaration_section] record
        header: clt$type_specification_header,
      recend := [[1, 0, clc$type_specification_type]];

?? POP ??

    VAR
      echoing_completed: boolean,
      get_command_line: clt$internal_input_procedure,
      ignore_new_prompt_string: string (ifc$max_prompt_string_size),
      input_block: ^clt$block,
      logging_completed: boolean,
      original_prompt_string: string (ifc$max_prompt_string_size),
      start_index: clt$string_index,
      type_name: clt$type_name,
      type_specification_value: clt$data_value;

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

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


      log_and_or_echo;

      clp$change_prompt_string (original_prompt_string, ignore_new_prompt_string);

    PROCEND abort_handler;
?? TITLE := 'get_and_log_echo_command_line', EJECT ??

    PROCEDURE get_and_log_echo_command_line
      (VAR parse: clt$parse_state;
       VAR end_of_input: boolean;
       VAR status: ost$status);


      log_and_or_echo;

      clp$get_command_line (parse, end_of_input, status);
      IF (NOT status.normal) OR end_of_input THEN
        RETURN;
      IFEND;

      start_index := 1;
      logging_completed := FALSE;
      echoing_completed := FALSE;

    PROCEND get_and_log_echo_command_line;
?? TITLE := 'get_next_line', EJECT ??

    PROCEDURE [INLINE] get_next_line;

      VAR
        end_of_input: boolean;


      REPEAT
        get_command_line^ (parse, end_of_input, status);
        IF NOT status.normal THEN
          EXIT clp$type_statement;
        ELSEIF end_of_input THEN
          osp$set_status_abnormal ('CL', cle$eoi_in_declaration, 'type', status);
          EXIT clp$type_statement;
        IFEND;
        clp$scan_non_space_lexical_unit (parse);
      UNTIL parse.unit.kind <> clc$lex_end_of_line;

    PROCEND get_next_line;
?? TITLE := 'log_and_or_echo', EJECT ??

    PROCEDURE log_and_or_echo;

      VAR
        ignore_status: ost$status;


      IF parse.unit_index <= start_index THEN
        RETURN;
      IFEND;

      IF info.logging_required AND (NOT logging_completed) THEN
        clp$log_command_line (parse.text^ (start_index, parse.unit_index - start_index), ignore_status);
        logging_completed := TRUE;
      IFEND;

      IF info.echoing_required AND (NOT echoing_completed) THEN
        clp$echo_command (info.interpreter_mode, parse.text^ (start_index, parse.unit_index - start_index),
              ignore_status);
        echoing_completed := TRUE;
      IFEND;

    PROCEND log_and_or_echo;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    logging_completed := TRUE;
    echoing_completed := TRUE;
    IF info.logging_required OR info.echoing_required THEN
      get_command_line := ^get_and_log_echo_command_line;
    ELSE
      get_command_line := ^clp$get_command_line;
    IFEND;

    clp$find_input_block (FALSE, input_block);
    IF (input_block^.input.kind = clc$file_input) AND input_block^.input.interactive_device THEN
      clp$change_prompt_string ('type', original_prompt_string);
      osp$establish_block_exit_hndlr (^abort_handler);
    IFEND;

    start_index := input_block^.line_parse.unit_index;
    parse.index_limit := input_block^.line_parse.index_limit;

    CASE parse.unit.kind OF
    = clc$lex_end_of_line =
      get_next_line;
    = clc$lex_semicolon =
      clp$scan_non_space_lexical_unit (parse);
      IF parse.unit.kind = clc$lex_end_of_line THEN
        get_next_line;
      ELSE
        logging_completed := FALSE;
        echoing_completed := FALSE;
      IFEND;
    ELSE
      ;
    CASEND;

    type_specification_value.kind := clc$type_specification;

  /type_typend/
    WHILE TRUE DO
      CASE parse.unit.kind OF
      = clc$lex_name =
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), type_name);
        IF type_name = 'TYPEND' THEN
          clp$scan_non_space_lexical_unit (parse);
          IF NOT (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_end_of_line, clc$lex_semicolon]) THEN
            osp$set_status_abnormal ('CL', cle$unexpected_statement_params, 'TYPEND', status);
          IFEND;
          EXIT /type_typend/;
        IFEND;
      = clc$lex_long_name =
        IF info.interpreter_mode = clc$interpret_mode THEN
          osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                status);
          EXIT /type_typend/;
        IFEND;
      ELSE
        IF info.interpreter_mode = clc$interpret_mode THEN
          osp$set_status_condition (cle$expecting_type_name, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT /type_typend/;
        IFEND;
      CASEND;

      IF info.interpreter_mode = clc$interpret_mode THEN
        clp$scan_non_space_lexical_unit (parse);
        IF parse.unit.kind = clc$lex_end_of_line THEN
          get_next_line;
        IFEND;
        IF NOT (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_colon, clc$lex_equal]) THEN
          osp$set_status_condition (cle$expecting_after_type_name, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT /type_typend/;
        IFEND;
        clp$scan_non_space_lexical_unit (parse);
        IF parse.unit.kind = clc$lex_end_of_line THEN
          get_next_line;
        IFEND;

        clp$internal_gen_type_spec (type_name, FALSE, get_command_line, NIL, work_area, parse,
              type_specification_value.type_specification_value, status);
        IF NOT status.normal THEN
          EXIT /type_typend/;
        IFEND;

        IF info.interpreter_mode = clc$interpret_mode THEN
          clp$create_var_from_type_spec (type_name, clc$environment_scope, clc$read_only,
                clc$immediate_evaluation, #SEQ (type_specification), ^type_specification_value, FALSE,
                work_area, status);
          IF NOT status.normal THEN
            EXIT /type_typend/;
          IFEND;
        IFEND;

        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

      ELSE { info.interprteter = clc$skip_mode }
        clp$scan_unnested_cmnd_lex_unit (parse);
      IFEND;

      CASE parse.unit.kind OF
      = clc$lex_semicolon =
        clp$scan_non_space_lexical_unit (parse);
        IF parse.unit.kind = clc$lex_end_of_line THEN
          get_next_line;
        ELSE
          logging_completed := FALSE;
          echoing_completed := FALSE;
        IFEND;
      = clc$lex_end_of_line =
        get_next_line;
      ELSE
        osp$set_status_condition (cle$expecting_after_type_def, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT /type_typend/;
      CASEND;
    WHILEND /type_typend/;

    IF NOT (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_end_of_line, clc$lex_semicolon]) THEN
      clp$scan_unnested_cmnd_lex_unit (parse);
    IFEND;

    log_and_or_echo;

    IF parse.unit.kind <> clc$lex_end_of_line THEN
      clp$scan_any_lexical_unit (parse);
    IFEND;

    IF (input_block^.input.kind = clc$file_input) AND input_block^.input.interactive_device THEN
      clp$change_prompt_string (original_prompt_string, ignore_new_prompt_string);
      osp$disestablish_cond_handler;
    IFEND;

    clp$set_input_line_parse (parse);

  PROCEND clp$type_statement;
?? TITLE := 'clp$typend_statement', EJECT ??

  PROCEDURE clp$typend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);


    osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'TYPEND', status);

  PROCEND clp$typend_statement;
?? TITLE := 'clp$var_statement', EJECT ??

  PROCEDURE clp$var_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      access_mode: clt$data_access_mode,
      echoing_completed: boolean,
      end_of_line_found: boolean,
      evaluation_method: clt$expression_eval_method,
      get_command_line: clt$internal_input_procedure,
      ignore_new_prompt_string: string (ifc$max_prompt_string_size),
      initial_value: ^clt$data_value,
      input_block: ^clt$block,
      logging_completed: boolean,
      original_prompt_string: string (ifc$max_prompt_string_size),
      scope: clt$variable_declaration_scope,
      start_index: clt$string_index,
      type_specification: ^clt$type_specification,
      variable_name: clt$variable_name;

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

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


      log_and_or_echo;

      clp$change_prompt_string (original_prompt_string, ignore_new_prompt_string);

    PROCEND abort_handler;
?? TITLE := 'get_and_log_echo_command_line', EJECT ??

    PROCEDURE get_and_log_echo_command_line
      (VAR parse: clt$parse_state;
       VAR end_of_input: boolean;
       VAR status: ost$status);


      log_and_or_echo;

      clp$get_command_line (parse, end_of_input, status);
      IF (NOT status.normal) OR end_of_input THEN
        RETURN;
      IFEND;

      start_index := 1;
      logging_completed := FALSE;
      echoing_completed := FALSE;

    PROCEND get_and_log_echo_command_line;
?? TITLE := 'get_next_line', EJECT ??

    PROCEDURE [INLINE] get_next_line;

      VAR
        end_of_input: boolean;


      REPEAT
        get_command_line^ (parse, end_of_input, status);
        IF NOT status.normal THEN
          EXIT clp$var_statement;
        ELSEIF end_of_input THEN
          osp$set_status_abnormal ('CL', cle$eoi_in_declaration, 'var', status);
          EXIT clp$var_statement;
        IFEND;
        clp$scan_non_space_lexical_unit (parse);
      UNTIL parse.unit.kind <> clc$lex_end_of_line;

    PROCEND get_next_line;
?? TITLE := 'log_and_or_echo', EJECT ??

    PROCEDURE log_and_or_echo;

      VAR
        ignore_status: ost$status;


      IF parse.unit_index <= start_index THEN
        RETURN;
      IFEND;

      IF info.logging_required AND (NOT logging_completed) THEN
        clp$log_command_line (parse.text^ (start_index, parse.unit_index - start_index), ignore_status);
        logging_completed := TRUE;
      IFEND;

      IF info.echoing_required AND (NOT echoing_completed) THEN
        clp$echo_command (info.interpreter_mode, parse.text^ (start_index, parse.unit_index - start_index),
              ignore_status);
        echoing_completed := TRUE;
      IFEND;

    PROCEND log_and_or_echo;
?? TITLE := 'process_initial_value', EJECT ??

    PROCEDURE process_initial_value;

      VAR
        access_variable_requests: clt$access_variable_requests,
        expression_parse: clt$parse_state,
        ignore_result_type_description: ^clt$type_description,
        initial_name: clt$variable_name,
        initial_name_found: boolean,
        initial_name_parse: clt$parse_state,
        initial_name_text: ^clt$string_value,
        initial_value_text: ^clt$expression_text,
        lexical_units: ^clt$lexical_units,
        type_description: clt$type_description;


      initial_name := '';
      expression_parse := parse;

      IF parse.unit.kind = clc$lex_name THEN
        clp$scan_non_space_lexical_unit (parse);
        IF parse.unit.kind = clc$lex_comma THEN
          #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.previous_non_space_unit_index,
                parse.previous_non_space_unit.size), initial_name);
          clp$scan_non_space_lexical_unit (parse);
          IF parse.unit.kind = clc$lex_end_of_line THEN
            get_next_line;
          IFEND;
          expression_parse := parse;
        ELSE
          parse := expression_parse;
        IFEND;
      IFEND;

      clp$scan_unnested_cmnd_lex_unit (parse);

      IF info.interpreter_mode <> clc$interpret_mode THEN
        RETURN;
      IFEND;

      expression_parse.index_limit := parse.unit_index;

      initial_value_text := ^expression_parse.text^ (expression_parse.unit_index,
            expression_parse.index_limit - expression_parse.unit_index);

      IF initial_name <> '' THEN
        PUSH initial_name_text: [0];
        clp$identify_lexical_units (initial_name_text, work_area, lexical_units, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$initialize_parse_state (initial_name_text, lexical_units, initial_name_parse);
        clp$scan_non_space_lexical_unit (initial_name_parse);
        access_variable_requests := $clt$access_variable_requests [];
        clp$evaluate_name (initial_name, access_variable_requests, initial_name_parse, work_area,
              initial_value, initial_name_found, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF initial_name_found AND (initial_value <> NIL) THEN
          IF initial_value^.kind <> clc$string THEN
            osp$set_status_abnormal ('CL', cle$initial_name_not_string, initial_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, variable_name, status);
            RETURN;
          IFEND;
          initial_value_text := initial_value^.string_value;
          initial_value := NIL;
          IF evaluation_method = clc$immediate_evaluation THEN
            clp$identify_lexical_units (initial_value_text, work_area, lexical_units, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            clp$initialize_parse_state (initial_value_text, lexical_units, expression_parse);
            clp$scan_non_space_lexical_unit (expression_parse);
          IFEND;
        IFEND;
      IFEND;

      IF evaluation_method = clc$deferred_evaluation THEN
        clp$make_deferred_value (initial_value_text^, type_specification, work_area, initial_value);
        IF initial_value = NIL THEN
          osp$set_status_condition (cle$work_area_overflow, status);
        IFEND;
        RETURN;
      IFEND;

      clp$convert_type_spec_to_desc (type_specification, work_area, type_description, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$internal_evaluate_expr (expression_parse, ^type_description, work_area,
            ignore_result_type_description, initial_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF expression_parse.unit_index < expression_parse.index_limit THEN
        osp$set_status_condition (cle$expecting_end_of_expression, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, expression_parse, status);
        RETURN;
      IFEND;

      IF initial_value^.kind = clc$unspecified THEN
        initial_value := NIL;
      IFEND;

    PROCEND process_initial_value;
?? TITLE := 'process_variable_attributes', EJECT ??

    PROCEDURE process_variable_attributes;

      VAR
        scope_given: boolean;

?? NEWTITLE := 'process_variable_attribute', EJECT ??

      PROCEDURE [INLINE] process_variable_attribute;

        VAR
          name: ost$name;


        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);

        IF name = 'DEFER' THEN
          IF evaluation_method <> clc$deferred_evaluation THEN
            evaluation_method := clc$deferred_evaluation;
            RETURN;
          IFEND;

        ELSEIF name = 'ENVIRONMENT' THEN
          IF NOT scope_given THEN
            scope := clc$environment_scope;
            scope_given := TRUE;
            RETURN;
          IFEND;

        ELSEIF name = 'JOB' THEN
          IF NOT scope_given THEN
            scope := clc$job_scope;
            scope_given := TRUE;
            RETURN;
          IFEND;

        ELSEIF name = 'LOCAL' THEN
          IF NOT scope_given THEN
            scope := clc$local_scope;
            scope_given := TRUE;
            RETURN;
          IFEND;

        ELSEIF name = 'PUSH' THEN
          IF NOT scope_given THEN
            scope := clc$push_scope;
            scope_given := TRUE;
            RETURN;
          IFEND;

        ELSEIF name = 'READ' THEN
          IF access_mode <> clc$read_only THEN
            access_mode := clc$read_only;
            RETURN;
          IFEND;

        ELSEIF name = 'TASK' THEN
          IF NOT scope_given THEN
            scope := clc$task_scope;
            scope_given := TRUE;
            RETURN;
          IFEND;

        ELSEIF name = 'UTILITY' THEN
          IF NOT scope_given THEN
            scope := clc$utility_scope;
            scope_given := TRUE;
            RETURN;
          IFEND;

        ELSEIF name = 'XDCL' THEN
          IF NOT scope_given THEN
            scope := clc$xdcl_scope;
            scope_given := TRUE;
            RETURN;
          IFEND;

        ELSEIF name = 'XREF' THEN
          IF NOT scope_given THEN
            scope := clc$xref_scope;
            scope_given := TRUE;
            RETURN;
          IFEND;

        ELSE
          osp$set_status_abnormal ('CL', cle$not_a_variable_attribute, name, status);
          EXIT process_variable_attributes;
        IFEND;

        osp$set_status_abnormal ('CL', cle$duplicate_variable_attr, name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, variable_name, status);
        EXIT process_variable_attributes;

      PROCEND process_variable_attribute;
?? OLDTITLE, EJECT ??

      scope_given := FALSE;

      clp$scan_non_space_lexical_unit (parse);

      WHILE TRUE DO
        CASE parse.unit.kind OF

        = clc$lex_right_parenthesis =
          IF parse.previous_non_space_unit.kind <> clc$lex_name THEN
            osp$set_status_abnormal ('CL', cle$expecting_variable_attr, variable_name, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            RETURN;
          IFEND;
          clp$scan_non_space_lexical_unit (parse);
          IF parse.unit.kind = clc$lex_end_of_line THEN
            get_next_line;
          IFEND;
          RETURN;

        = clc$lex_name =
          process_variable_attribute;
          clp$scan_non_space_lexical_unit (parse);
          IF parse.unit.kind = clc$lex_comma THEN
            clp$scan_non_space_lexical_unit (parse);
          IFEND;

        = clc$lex_long_name =
          osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                status);
          RETURN;

        ELSE
          osp$set_status_abnormal ('CL', cle$expecting_variable_attr, variable_name, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          RETURN;

        CASEND;
      WHILEND;

    PROCEND process_variable_attributes;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    logging_completed := TRUE;
    echoing_completed := TRUE;
    IF info.logging_required OR info.echoing_required THEN
      get_command_line := ^get_and_log_echo_command_line;
    ELSE
      get_command_line := ^clp$get_command_line;
    IFEND;

    clp$find_input_block (FALSE, input_block);
    IF (input_block^.input.kind = clc$file_input) AND input_block^.input.interactive_device THEN
      clp$change_prompt_string ('var', original_prompt_string);
      osp$establish_block_exit_hndlr (^abort_handler);
    IFEND;

    start_index := input_block^.line_parse.unit_index;
    parse.index_limit := input_block^.line_parse.index_limit;

    CASE parse.unit.kind OF
    = clc$lex_end_of_line =
      get_next_line;
    = clc$lex_semicolon =
      clp$scan_non_space_lexical_unit (parse);
      IF parse.unit.kind = clc$lex_end_of_line THEN
        get_next_line;
      ELSE
        logging_completed := FALSE;
        echoing_completed := FALSE;
      IFEND;
    ELSE
      ;
    CASEND;

  /var_varend/
    WHILE TRUE DO
      CASE parse.unit.kind OF
      = clc$lex_name =
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), variable_name);
        IF variable_name = 'VAREND' THEN
          clp$scan_non_space_lexical_unit (parse);
          IF NOT (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_end_of_line, clc$lex_semicolon]) THEN
            osp$set_status_abnormal ('CL', cle$unexpected_statement_params, 'VAREND', status);
          IFEND;
          EXIT /var_varend/;
        IFEND;
      = clc$lex_long_name =
        IF info.interpreter_mode = clc$interpret_mode THEN
          osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                status);
          EXIT /var_varend/;
        IFEND;
      ELSE
        IF info.interpreter_mode = clc$interpret_mode THEN
          osp$set_status_condition (cle$expecting_variable_name, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT /var_varend/;
        IFEND;
      CASEND;

      IF info.interpreter_mode = clc$interpret_mode THEN
        clp$evaluate_data_name_expr (work_area, parse, variable_name, status);
        IF NOT status.normal THEN
          IF status.condition = cle$unspecified_value_for_req THEN
            osp$set_status_abnormal ('CL', cle$unspecified_value_for_state, 'VAR', status);
          IFEND;
          EXIT /var_varend/;
        IFEND;

        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;
        IF parse.unit.kind = clc$lex_end_of_line THEN
          get_next_line;
        IFEND;
        IF parse.unit.kind <> clc$lex_colon THEN
          osp$set_status_condition (cle$expecting_after_var_name, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT /var_varend/;
        IFEND;
        clp$scan_non_space_lexical_unit (parse);
        IF parse.unit.kind = clc$lex_end_of_line THEN
          get_next_line;
        IFEND;

        access_mode := clc$read_write;
        evaluation_method := clc$immediate_evaluation;
        scope := clc$local_scope;
        IF parse.unit.kind = clc$lex_left_parenthesis THEN
          process_variable_attributes;
          IF NOT status.normal THEN
            EXIT /var_varend/;
          IFEND;
        IFEND;

        clp$internal_gen_type_spec (osc$null_name, FALSE, get_command_line, NIL, work_area, parse,
              type_specification, status);
        IF NOT status.normal THEN
          EXIT /var_varend/;
        IFEND;

        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;
        end_of_line_found := parse.unit.kind = clc$lex_end_of_line;
        IF end_of_line_found THEN
          get_next_line;
        IFEND;
        initial_value := NIL;
        IF parse.unit.kind = clc$lex_equal THEN
          clp$scan_non_space_lexical_unit (parse);
          IF parse.unit.kind = clc$lex_end_of_line THEN
            get_next_line;
          IFEND;
          process_initial_value;
          IF NOT status.normal THEN
            EXIT /var_varend/;
          ELSEIF (scope = clc$xref_scope) AND (initial_value <> NIL) THEN
            osp$set_status_abnormal ('CL', cle$xref_var_cannot_have_value, variable_name, status);
            EXIT /var_varend/;
          IFEND;
        IFEND;

        IF info.interpreter_mode = clc$interpret_mode THEN
          clp$create_var_from_type_spec (variable_name, scope, access_mode, evaluation_method,
                type_specification, initial_value, FALSE, work_area, status);
          IF NOT status.normal THEN
            EXIT /var_varend/;
          IFEND;
        IFEND;

        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

      ELSE { info.interpreter_mode = clc$skip_mode }
        clp$scan_unnested_cmnd_lex_unit (parse);
      IFEND;

      CASE parse.unit.kind OF
      = clc$lex_semicolon =
        clp$scan_non_space_lexical_unit (parse);
        IF parse.unit.kind = clc$lex_end_of_line THEN
          get_next_line;
        ELSE
          logging_completed := FALSE;
          echoing_completed := FALSE;
        IFEND;
      = clc$lex_end_of_line =
        get_next_line;
      ELSE
        IF NOT end_of_line_found THEN
          osp$set_status_condition (cle$expecting_after_var_def, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT /var_varend/;
        IFEND;
      CASEND;
    WHILEND /var_varend/;

    IF NOT (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_end_of_line, clc$lex_semicolon]) THEN
      clp$scan_unnested_cmnd_lex_unit (parse);
    IFEND;

    log_and_or_echo;

    IF parse.unit.kind <> clc$lex_end_of_line THEN
      clp$scan_any_lexical_unit (parse);
    IFEND;

    IF (input_block^.input.kind = clc$file_input) AND input_block^.input.interactive_device THEN
      clp$change_prompt_string (original_prompt_string, ignore_new_prompt_string);
      osp$disestablish_cond_handler;
    IFEND;

    clp$set_input_line_parse (parse);

  PROCEND clp$var_statement;
?? TITLE := 'clp$varend_statement', EJECT ??

  PROCEDURE clp$varend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);


    osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'VAREND', status);

  PROCEND clp$varend_statement;
?? TITLE := 'clp$lock_statement', EJECT ??

  PROCEDURE clp$lock_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);


    osp$set_status_abnormal ('CL', cle$not_yet_implemented, 'LOCK statement', status);

  PROCEND clp$lock_statement;
?? TITLE := 'clp$unlock_statement', EJECT ??

  PROCEDURE clp$unlock_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);


    osp$set_status_abnormal ('CL', cle$not_yet_implemented, 'UNLOCK statement', status);

  PROCEND clp$unlock_statement;
?? TITLE := 'clp$pipe_statement', EJECT ??

  PROCEDURE clp$pipe_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);


    osp$set_status_abnormal ('CL', cle$not_yet_implemented, 'PIPE statement', status);

  PROCEND clp$pipe_statement;
?? TITLE := 'clp$pipend_statement', EJECT ??

  PROCEDURE clp$pipend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);


    osp$set_status_abnormal ('CL', cle$not_yet_implemented, 'PIPEND statement', status);

  PROCEND clp$pipend_statement;

MODEND clm$control_statements;
*DECK DECK=CLM$CONVERT_CHAR_TO_GRAPHIC EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter: Convert Character To Graphic' ??
MODULE clm$convert_char_to_graphic;

{
{ PURPOSE:
{    This module contains the utility convert character to graphic which is
{    used by display command processors.
{
?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc oss$job_paged_literal
*IFEND
*copyc ost$status
*copyc ost$string
?? POP ??
?? TITLE := 'clp$convert_char_to_graphic', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$convert_char_to_graphic
    (    ch: char;
     VAR char_string: ost$string;
     VAR status: ost$status);

    VAR
*IF NOT $true(osv$unix)
      control_characters: [STATIC, READ, oss$job_paged_literal] array [$CHAR (0) .. $CHAR (20(16))] of
*ELSE
      control_characters: [STATIC, READ] array [$CHAR (0) .. $CHAR (20(16))] of
*IFEND
            string (3) := ['NUL', 'SOH', 'STX', 'ETX', 'EOT', 'ENQ', 'ACK', 'BEL', 'BS', 'HT', 'LF', 'VT',
            'FF', 'CR', 'SO', 'SI', 'DLE', 'DC1', 'DC2', 'DC3', 'DC4', 'NAK', 'SYN', 'ETB', 'CAN', 'EM',
            'SUB', 'ESC', 'FS', 'GS', 'RS', 'US', 'SP'];

    VAR
*IF NOT $true(osv$unix)
      hex_digits: [STATIC, READ, oss$job_paged_literal] array [0 .. 15] of char := ['0', '1', '2', '3', '4',
*ELSE
      hex_digits: [STATIC, READ] array [0 .. 15] of char := ['0', '1', '2', '3', '4',
*IFEND
            '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'];

    CASE ch OF
    = $CHAR (0) .. $CHAR (20(16)) =
      char_string.value (1, 3) := control_characters [ch];
      char_string.size := 3 - $INTEGER (char_string.value (3) = ' ');
    = $CHAR (21(16)) .. $CHAR (7e(16)) =
      char_string.value (1) := ch;
      char_string.size := 1;
    = $CHAR (7f(16)) =
      char_string.value := 'DEL';
      char_string.size := 3;
    = $CHAR (80(16)) .. $CHAR (0ff(16)) =
      char_string.value := '0xx(16)';
      char_string.value (2) := hex_digits [$INTEGER (ch) DIV 16];
      char_string.value (3) := hex_digits [$INTEGER (ch) MOD 16];
      char_string.size := 7;
    ELSE
      char_string.value := 'UNKNOWN';
      char_string.size := 7;
    CASEND;

  PROCEND clp$convert_char_to_graphic;

MODEND clm$convert_char_to_graphic;
*DECK DECK=CLM$CONVERT_CONSOLE_TO_ASCII EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Convert Operator Console String to Ascii' ??
MODULE clm$convert_console_to_ascii;

{
{ PURPOSE:
{   This module contains the procedure that processes the special character sequences used to represent
{   certain ASCII characters that are not available on the operator console.
{   Such a sequence consists of two characters the first of which is a slant (/).
{

?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_paged_literal
*copyc ost$status
*copyc ost$string
?? POP ??
?? NEWTITLE := 'clp$convert_console_to_ascii', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$convert_console_to_ascii
    (    console_string: string ( * );
     VAR ascii_string: string ( * );
     VAR status: ost$status);

    VAR
      conversion_table: [STATIC, READ, oss$mainframe_paged_literal] array [char] of char := [REP 40 of ' ',
            '[', ']', '''', '>', ':', '<', ' ', '/', '_', '^', '"', '#', '$', '\', ';', '?', '{', '}', ' ',
            ' ', ' ', '.', ' ', ' ', ' ', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm',
            'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', REP 165 of ' '];

    VAR
      i: ost$string_index,
      j: ost$string_index;

    status.normal := TRUE;
    ascii_string := '';
    i := 1;
    j := 1;

  /loop/
    WHILE i <= STRLENGTH (console_string) DO
      IF console_string (i) = '/' THEN
        i := i + 1;
        IF i > STRLENGTH (console_string) THEN
          EXIT /loop/;
        IFEND;
        ascii_string (j) := conversion_table [console_string (i)];
      ELSE
        ascii_string (j) := console_string (i);
      IFEND;
      i := i + 1;
      j := j + 1;
    WHILEND /loop/;

  PROCEND clp$convert_console_to_ascii;

MODEND clm$convert_console_to_ascii;
*DECK DECK=CLM$CONVERT_INTEGER_TO_STRING EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Convert Integer to String' ??
MODULE clm$convert_integer_to_string ALIAS 'clmi2s';

{
{ PURPOSE:
{   This module contains procedures that convert an integer to its string representation.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_expression_result
*IF NOT $true(osv$unix)
*copyc clk$procedure_keypoints
*copyc oss$mainframe_paged_literal
*IFEND
*copyc ost$status
*copyc ost$string
?? POP ??
*copyc osp$set_status_abnormal

  CONST
    max_digits = 64;

  VAR
*IF NOT $true(osv$unix)
    digit_char: [STATIC, READ, oss$mainframe_paged_literal] array [-15 .. 15] of char := ['F', 'E', 'D', 'C',
*ELSE
    digit_char: [STATIC, READ] array [-15 .. 15] of char := ['F', 'E', 'D', 'C',
*IFEND
          'B', 'A', '9', '8', '7', '6', '5', '4', '3', '2', '1', '0', '1', '2', '3', '4', '5', '6', '7', '8',
          '9', 'A', 'B', 'C', 'D', 'E', 'F'];

?? TITLE := 'clp$convert_integer_to_string', EJECT ??
*copyc clh$convert_integer_to_string

  PROCEDURE [XDCL, #GATE] clp$convert_integer_to_string ALIAS 'clpci2s'
    (    int: integer;
         radix: 2 .. 16;
         include_radix_specifier: boolean;
     VAR str: ost$string;
     VAR status: ost$status);

    VAR
      actual_radix: 2 .. 16,
      digits: array [1 .. max_digits] of -15 .. 15,
      digit_count: 0 .. max_digits,
      current_int: integer;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, 0, clk$convert_integer_to_string);
*IFEND

    status.normal := TRUE;
    current_int := int;
    digit_count := 0;

    IF (2 <= radix) AND (radix <= 16) THEN
      actual_radix := radix;
    ELSE
      actual_radix := 10;
    IFEND;

    REPEAT
      digit_count := digit_count + 1;
      digits [digit_count] := current_int MOD actual_radix;
      current_int := current_int DIV actual_radix;
    UNTIL current_int = 0;

    str.size := 0;
    str.value := '  ';
    IF int < 0 THEN
      str.size := 1;
      str.value (1) := '-';
    IFEND;

    IF (digits [digit_count] >= 10) OR (digits [digit_count] <= -10) THEN
      str.size := str.size + 1;
      str.value (str.size) := '0';
    IFEND;

    REPEAT
      str.size := str.size + 1;
      str.value (str.size) := digit_char [digits [digit_count]];
      digit_count := digit_count - 1;
    UNTIL digit_count <= 0;

    IF include_radix_specifier THEN
      str.size := str.size + 1;
      str.value (str.size) := '(';
      IF actual_radix >= 10 THEN
        str.size := str.size + 1;
        str.value (str.size) := '1';
      IFEND;
      str.size := str.size + 1;
      str.value (str.size) := digit_char [actual_radix MOD 10];
      str.size := str.size + 1;
      str.value (str.size) := ')';
    IFEND;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, 0, clk$convert_integer_to_string);
*IFEND

  PROCEND clp$convert_integer_to_string;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$convert_integer_to_rjstring', EJECT ??
*copyc clh$convert_integer_to_rjstring

  PROCEDURE [XDCL, #GATE] clp$convert_integer_to_rjstring ALIAS 'clpcirs'
    (    int: integer;
         radix: 2 .. 16;
         include_radix_specifier: boolean;
         fill_character: char;
     VAR str: string ( * );
     VAR status: ost$status);

    VAR
      actual_radix: 2 .. 16,
      digits: array [1 .. max_digits] of -15 .. 15,
      digit_count: 0 .. max_digits,
      i: 1 .. osc$max_string_size,
      current_int: integer,
      string_index: ost$string_size;

    #KEYPOINT (osk$entry, 0, clk$convert_integer_to_rjstring);

  /convert/
    BEGIN

      status.normal := TRUE;
      string_index := STRLENGTH (str);
      current_int := int;
      digit_count := 0;

      IF (2 <= radix) AND (radix <= 16) THEN
        actual_radix := radix;
      ELSE
        actual_radix := 10;
      IFEND;

      REPEAT
        digit_count := digit_count + 1;
        digits [digit_count] := current_int MOD actual_radix;
        current_int := current_int DIV actual_radix;
      UNTIL current_int = 0;

      IF (digit_count + $INTEGER (int < 0) + ($INTEGER (include_radix_specifier) *
            (3 + $INTEGER (actual_radix >= 10)))) > string_index THEN
        osp$set_status_abnormal ('CL', cle$string_too_short, ' for integer conversion', status);
        EXIT /convert/;
      IFEND;

      IF include_radix_specifier THEN
        str (string_index) := ')';
        string_index := string_index - 1;
        str (string_index) := digit_char [actual_radix MOD 10];
        string_index := string_index - 1;
        IF actual_radix >= 10 THEN
          str (string_index) := '1';
          string_index := string_index - 1;
        IFEND;
        str (string_index) := '(';
        string_index := string_index - 1;
      IFEND;

      FOR i := 1 TO digit_count DO
        str (string_index) := digit_char [digits [i]];
        string_index := string_index - 1;
      FOREND;

      IF ((digits [digit_count] >= 10) OR (digits [digit_count] <= -10)) AND
            (string_index > $INTEGER (int < 0)) THEN
        str (string_index) := '0';
        string_index := string_index - 1;
      IFEND;

      FOR i := 1 TO string_index DO
        str (i) := fill_character;
      FOREND;

      IF int < 0 THEN
        IF fill_character = ' ' THEN
          str (string_index) := '-';
        ELSE
          str (1) := '-';
        IFEND;
      IFEND;

    END /convert/;
    #KEYPOINT (osk$exit, 0, clk$convert_integer_to_rjstring);

  PROCEND clp$convert_integer_to_rjstring;
*IFEND

MODEND clm$convert_integer_to_string;
*DECK DECK=CLM$CONVERT_REAL_TO_STRING EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Convert Real to String' ??
MODULE clm$convert_real_to_string;

{
{ PURPOSE:
{   This module contains the procedure that converts a real number to its
{   string representation.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$max_real_number_size
*copyc clk$convert_real_to_string
*copyc clt$real
*copyc clt$real_number_digit_count
*copyc ost$status
*copyc ost$string
?? POP ??
*copyc clp$longreal_classify
*copyc mlp$output_floating_number

?? TITLE := 'clp$convert_real_to_string', EJECT ??
*copyc clh$convert_real_to_string

  PROCEDURE [XDCL, #GATE] clp$convert_real_to_string
    (    real_number: longreal;
         number_of_digits: clt$real_number_digit_count;
     VAR str: ost$string;
     VAR status: ost$status);

    VAR
*IF NOT $true(osv$unix)
      conversion_status: mlt$error,
      format: mlt$output_format,
      i: 1 .. clc$max_real_number_size + 1,
      temp_str: string (clc$max_real_number_size),
      size: mlt$string_length;
*ELSE
      line: string (256),
      length: integer;
*IFEND


*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, 0, clk$convert_real_to_string);
*IFEND

    status.normal := TRUE;

    str.size := 0;
    str.value := '';

*IF NOT $true(osv$unix)
    format.justification := mlc$left_justify;
    format.sign := mlc$minus_if_negative;
    format.format := mlc$list_directed;
    format.width := clc$max_real_number_size;
    format.digits := number_of_digits;
    format.exponent_character := 'E';
*IFEND

    CASE clp$longreal_classify (real_number) OF

    = clc$real_indefinite =
      str.value := '$INDEFINITE';
      str.size := 11;

    = clc$real_negative_infinite =
      str.value := '-$INFINITY';
      str.size := 10;

    = clc$real_zero =
      str.value := '0.0';
      str.size := 3;

    = clc$real_positive_infinite =
      str.value := '$INFINITY';
      str.size := 9;

    ELSE { clc$real_negative_standard, clc$real_positive_standard }
*IF NOT $true(osv$unix)
      mlp$output_floating_number (^real_number, mlc$double_precision, ^temp_str, format, size,
            conversion_status);
      i := 1;
      WHILE i <= size DO
        IF temp_str (i) <> '.' THEN
          str.size := str.size + 1;
          str.value (str.size) := temp_str (i);
        ELSEIF (i = 1) OR (temp_str (i - 1) < '0') OR (temp_str (i - 1) > '9') THEN
          str.value (str.size + 1, 2) := '0.';
          str.size := str.size + 2;
        ELSEIF (i = size) OR (temp_str (i + 1) < '0') OR (temp_str (i + 1) > '9') THEN
          str.value (str.size + 1, 2) := '.0';
          str.size := str.size + 2;
        ELSE
          str.size := str.size + 1;
          str.value (str.size) := '.';
        IFEND;
        i := i + 1;
      WHILEND;
*ELSE
      STRINGREP (line, length, real_number);
      str.value := line;
      str.size := length;
*IFEND
    CASEND;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, 0, clk$convert_real_to_string);
*IFEND

  PROCEND clp$convert_real_to_string;

MODEND clm$convert_real_to_string;
*DECK DECK=CLM$CONVERT_STATUS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Status Conversion Procedures' ??
MODULE clm$convert_status;

{
{ PURPOSE:
{   This module contains procedures to perform conversion between ost$status and clt$status, the latter
{   being the "mapping" of the former in command language variables.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$variable_reference
*copyc ost$status
?? POP ??
*copyc osp$status_condition_code
*copyc osp$unpack_status_identifier
?? TITLE := 'clp$convert_to_clt$status', EJECT ??
{
{ PURPOSE:
{   This procedure converts an ost$status to a clt$status.
{

  PROCEDURE [XDCL] clp$convert_to_clt$status
    (    osv$status: ost$status;
     VAR clv$status: clt$status);

    clv$status.normal.value := osv$status.normal;
    clv$status.normal.kind := clc$true_false_boolean;
    IF NOT clv$status.normal.value THEN
      clv$status.identifier.size := STRLENGTH (clv$status.identifier.value);
      osp$unpack_status_identifier (osv$status.condition, clv$status.identifier.value);
      clv$status.condition.value := osv$status.condition;
      clv$status.condition.radix := 10;
      clv$status.condition.radix_specified := FALSE;
      clv$status.text := osv$status.text;
    IFEND;

  PROCEND clp$convert_to_clt$status;
?? TITLE := 'clp$convert_to_ost$status', EJECT ??
{
{ PURPOSE:
{   This procedure converts a clt$status to an ost$status.
{

  PROCEDURE [XDCL] clp$convert_to_ost$status
    (    clv$status: clt$status;
     VAR osv$status: ost$status);

    VAR
      identifier: ost$status_identifier;

    osv$status.normal := clv$status.normal.value;
    IF NOT osv$status.normal THEN
      IF (1 <= clv$status.identifier.size) AND (clv$status.identifier.size <=
            STRLENGTH (ost$status_identifier)) THEN
        identifier := clv$status.identifier.value (1, clv$status.identifier.size);
      ELSE
        identifier := '??';
      IFEND;
      osv$status.condition := osp$status_condition_code (identifier,
            clv$status.condition.value MOD (UPPERVALUE (osv$status.condition) + 1));
      osv$status.text := clv$status.text;
    IFEND;

  PROCEND clp$convert_to_ost$status;

MODEND clm$convert_status;
*DECK DECK=CLM$CONVERT_TO_STRING EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter: Convert to string routines' ??
MODULE clm$convert_to_string;

{
{ PURPOSE:
{   This module contains the procedures that convert a data value, type
{   description, command/function declaration, or command/function parameters
{   to a string representation.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$max_integer
*copyc clc$max_proc_names
*copyc clc$min_integer
*copyc cle$bad_data_rep_option
*copyc cle$bad_data_value
*copyc cle$bad_string_pattern
*copyc cle$ecc_parsing
*copyc cle$string_too_short
*copyc cle$work_area_overflow
*copyc clk$convert_value_to_string
*copyc clt$convert_to_string_request
*copyc clt$data_kinds
*copyc clt$data_representation
*copyc clt$data_representation_option
*copyc clt$data_value
*copyc clt$string_index
*copyc clt$string_size
*copyc clt$string_value
*copyc clt$symbolic_subrange_qualifier
*copyc clt$type_name
*copyc clt$work_area
*IF NOT $true(osv$unix)
*copyc cyd$run_time_error_condition
*ELSE
*copyc cyt$mips_signal_handler
*IFEND
*IF NOT $true(osv$unix)
*copyc fst$path
*copyc oss$job_paged_literal
*IFEND
*copyc ost$status
?? POP ??
*copyc clp$convert_char_to_graphic
*copyc clp$convert_date_time_to_string
*copyc clp$convert_integer_to_string
*IF NOT $true(osv$unix)
*copyc clp$convert_real_to_string
*IFEND
*copyc clp$convert_type_spec_to_desc
*copyc clp$evaluate_expression
*IF NOT $true(osv$unix)
*copyc clp$get_path_name
*copyc clp$longreal_classify
*IFEND
*copyc clp$recognize_cobol_name
*IF NOT $true(osv$unix)
*copyc clp$search_parameter_names
*IFEND
*copyc clp$sp_convert_to_string
*copyc clp$trimmed_string_size
*copyc clp$type_desc_is_for_old_union
*copyc clp$validate_name
*copyc clv$non_graphic
*copyc i#current_sequence_position
*IF NOT $true(osv$unix)
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*IFEND
*copyc osp$append_status_parameter
*IF NOT $true(osv$unix)
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*IFEND
*copyc osp$format_message
*copyc osp$get_status_condition_name
*copyc osp$get_status_condition_string
*copyc osp$set_status_abnormal
*copyc osp$unpack_status_identifier
*copyc osv$upper_to_lower
*IF NOT $true(osv$unix)
*copyc pmp$continue_to_cause
*ELSE
*IFEND
?? EJECT ??

  VAR
    clv$retain_unprintable_char: [XREF] boolean;

  VAR
*IF NOT $true(osv$unix)
    clv$value_type_kinds: [XDCL, READ, oss$job_paged_literal] array [clt$data_kind] of
*ELSE
    clv$value_type_kinds: [XDCL, READ] array [clt$data_kind] of
*IFEND
          clt$type_kind := [clc$application_type, clc$array_type, clc$boolean_type, clc$cobol_name_type,
          clc$command_reference_type, clc$data_name_type, clc$date_time_type, * {clc$defered} ,
          clc$entry_point_reference_type, clc$file_type, clc$integer_type, clc$keyword_type, clc$list_type,
          clc$lock_type, clc$name_type, clc$network_title_type, clc$program_name_type, clc$range_type,
          clc$real_type, clc$record_type, clc$scu_line_identifier_type, clc$statistic_code_type,
          clc$status_type, clc$status_code_type, clc$string_type, clc$string_pattern_type,
*IF NOT $true(osv$unix)
          clc$time_increment_type, clc$time_zone_type, clc$type_specification_type, * {clc$unspecified} ];
*ELSE
          clc$time_increment_type, clc$time_zone_type, clc$type_specification_type, * {clc$unspecified},
          clc$unix_file_type];
*IFEND

  VAR
*IF NOT $true(osv$unix)
    clv$type_kind_names: [XDCL, READ, oss$job_paged_literal] array [clt$type_kind] of
*ELSE
    clv$type_kind_names: [XDCL, READ] array [clt$type_kind] of
*IFEND
          clt$type_name := ['APPLICATION', 'ARRAY', 'BOOLEAN', 'COBOL_NAME', 'COMMAND_REFERENCE', 'DATA_NAME',
          'DATE_TIME', 'ENTRY_POINT_REFERENCE', 'FILE', 'INTEGER', 'KEYWORD', 'LIST', 'LOCK', 'NAME',
          'NETWORK_TITLE', 'PROGRAM_NAME', 'RANGE', 'REAL', 'RECORD', 'LINE_IDENTIFIER', 'STATISTIC_CODE',
*IF NOT $true(osv$unix)
          'STATUS', 'STATUS_CODE', 'STRING', 'STRING_PATTERN', 'TIME_INCREMENT', 'TIME_ZONE',
          'TYPE_SPECIFICATION', 'ANY'];
*ELSE
          'STATUS', 'STATUS_CODE', 'STRING', 'STRING_PATTERN', 'TIME_INCREMENT', 'TIME_ZONE',
          'TYPE_SPECIFICATION', 'ANY', 'FILE', '', ''];
*IFEND

?? EJECT ??

  CONST
    continuation = '..',
    continuation_size = 2,
    nesting_indentation = 2,
    structure_indentation = 2;

  CONST
    comma_size = 2 {', '} ,
    left_parenthesis_size = 1 {'('} ,
    max_separator_size = comma_size,
    space_size = 1 {' '} ;

  TYPE
    break_info = record
      index: clt$string_size,
      indent: clt$string_size,
      mark_continuation: boolean,
    recend;

  TYPE
    separator_string = string ( * <= max_separator_size);

  VAR
*IF NOT $true(osv$unix)
    labeled_structures: [STATIC, oss$job_paged_literal, READ] clt$data_kinds :=
*ELSE
    labeled_structures: [STATIC, READ] clt$data_kinds :=
*IFEND
          [clc$array, clc$entry_point_reference, clc$list, clc$range, clc$record];

?? TITLE := 'clp$convert_data_to_string', EJECT ??
*copyc clh$convert_data_to_string

  PROCEDURE [XDCL, #GATE] clp$convert_data_to_string
    (    value: ^clt$data_value;
         representation_option: clt$data_representation_option;
         max_string: clt$string_size;
     VAR work_area {input, output} : ^clt$work_area;
     VAR data_representation: ^clt$data_representation;
     VAR status: ost$status);

    VAR
      request: clt$convert_to_string_request;


    #KEYPOINT (osk$entry, 1, clk$convert_value_to_string);

    request.initial_indentation := 0;
    request.continuation_indentation := 0;
    request.max_string := max_string;
    request.include_advanced_items := TRUE;
    request.include_hidden_items := TRUE;
    request.kind := clc$convert_data_value;
    request.representation_option := representation_option;
    request.value := value;
    clp$internal_convert_to_string (request, work_area, data_representation, status);

    IF status.condition = cle$work_area_overflow THEN
      status.text.size := 0;
      osp$append_status_parameter (osc$status_parameter_delimiter, 'clp$convert_data_to_string', status);
    IFEND;

    #KEYPOINT (osk$exit, 1, clk$convert_value_to_string);

  PROCEND clp$convert_data_to_string;
?? TITLE := 'clp$internal_convert_to_string', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$internal_convert_to_string
    (    request: clt$convert_to_string_request;
     VAR work_area {input, output} : ^clt$work_area;
     VAR data_representation: ^clt$data_representation;
     VAR status: ost$status);

    VAR
      break: break_info,
      break_pending: boolean,
      colon_indent: clt$string_size,
      comma: string (comma_size),
      continuation_indentation: clt$string_size,
      convert_to_lower_case: boolean,
      first_pass: boolean,
*IF $true(osv$unix)
      handler_established: boolean,
*IFEND
      include_advanced_items: boolean,
      include_hidden_items: boolean,
      indent_amount: clt$string_size,
      initial_indentation: clt$string_size,
      label_indent_limit: clt$string_size,
      left_parenthesis: string (left_parenthesis_size),
      level_of_nesting: clt$string_size,
      local_status: ost$status,
*IF NOT $true(osv$unix)
      local_work_area: amt$segment_pointer,
*ELSE
      local_work_area: ^clt$work_area,
*IFEND
      max_string: clt$string_size,
      multi_line_format: boolean,
      representation_option: clt$data_representation_option,
      secondary_break: break_info,
      secondary_break_pending: boolean,
      space: string (space_size),
      space_remaining: integer,
      string_count: ^clt$data_representation_count,
      string_may_be_trimmed: boolean,
      string_ptr: ^clt$string_value,
      string_size: ^clt$string_size,
      string_started: boolean,
      symbolic_qualifiers_work_area: ^clt$work_area;

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

    PROCEDURE abort_handler
*IF $true(osv$unix)
      (    signal_no: integer;
           code: integer;
           p_sigcontext: ^cyt$mips_sigcontext);
*ELSE
      (    condition: pmt$condition;
           ignore_condition_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          bad_data_value;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          bad_data_value;
        IFEND;

      = pmc$block_exit_processing =
*IFEND

*IF $true(osv$unix)
        IF local_work_area <> NIL THEN
          FREE local_work_area;
        IFEND;
*ELSE
        IF local_work_area.sequence_pointer <> NIL THEN
          mmp$delete_scratch_segment (local_work_area, handler_status);

{ ignore the delete segment status

          handler_status.normal := TRUE;
          local_work_area.sequence_pointer := NIL;
        IFEND;
*IFEND
        RETURN;

*IF NOT $true(osv$unix)
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
*IFEND

    PROCEND abort_handler;
?? TITLE := 'bad_data_value', EJECT ??

    PROCEDURE bad_data_value;


      osp$set_status_abnormal ('CL', cle$bad_data_value, '', status);
      EXIT clp$internal_convert_to_string;

    PROCEND bad_data_value;
?? TITLE := 'break_string', EJECT ??

    PROCEDURE break_string;

      VAR
        extra_chars: ^clt$string_value,
        i: clt$string_index,
        mark_continuation: boolean,
        put_enabled: boolean,
        save_indent_amount: clt$string_size;


      save_indent_amount := indent_amount;
      mark_continuation := representation_option = clc$data_source_representation;

      IF break.index = 0 THEN
        break := secondary_break;
      IFEND;

      IF break.index = 0 THEN
        PUSH extra_chars: [continuation_size];
        extra_chars^ (1, continuation_size) := string_ptr^ (string_size^ -continuation_size + 1,
              continuation_size);
        string_size^ := string_size^ -continuation_size;
        mark_continuation := TRUE;

      ELSEIF break.index < string_size^ THEN
        secondary_break.index := break.index;
        WHILE (secondary_break.index > 0) AND (string_ptr^ (secondary_break.index) = '.') DO
          secondary_break.index := secondary_break.index - 1;
        WHILEND;
        IF secondary_break.index > 0 THEN
          break.index := secondary_break.index;
        IFEND;

        PUSH extra_chars: [string_size^ -break.index];
        extra_chars^ := string_ptr^ (break.index + 1, STRLENGTH (extra_chars^));
        string_size^ := break.index;

        mark_continuation := break.mark_continuation;
        indent_amount := break.indent;

      ELSE
        PUSH extra_chars: [0];
      IFEND;

      IF mark_continuation THEN
        string_ptr^ (string_size^ +1, continuation_size) := continuation;
        string_size^ := string_size^ +continuation_size;
      IFEND;

      finish_string;
      start_string;

      put_enabled := FALSE;
      FOR i := 1 TO STRLENGTH (extra_chars^) DO
        IF extra_chars^ (i) <> ' ' THEN
          put_enabled := TRUE;
        IFEND;
        IF put_enabled THEN
          put_string (extra_chars^ (i));
        IFEND;
      FOREND;

      indent_amount := save_indent_amount;

    PROCEND break_string;
?? TITLE := 'convert_value_to_string', EJECT ??

    PROCEDURE convert_value_to_string
      (    value: ^clt$data_value);

      VAR
        indent_at_start_of_structure: clt$string_size;

?? NEWTITLE := 'convert_application_to_string', EJECT ??

      PROCEDURE convert_application_to_string;


        IF representation_option = clc$data_struct_representation THEN
          put_type_identification (clc$application);
        IFEND;

        put_trimmed_string (value^.application_value^);

      PROCEND convert_application_to_string;
?? TITLE := 'convert_array_to_string', EJECT ??

      PROCEDURE convert_array_to_string;

?? NEWTITLE := 'put_array_compressed_labels', EJECT ??

        PROCEDURE put_array_compressed_labels;

          VAR
            complex_elements: boolean,
            index: clt$array_bound,
            previous_indent_amount: clt$string_size,
            str: ost$string;


          level_of_nesting := level_of_nesting + 1;
          previous_indent_amount := indent_amount;
          complex_elements := FALSE;

        /check_complexity/
          FOR index := LOWERBOUND (value^.array_value^) TO UPPERBOUND (value^.array_value^) DO
            IF (value^.array_value^ [index] <> NIL) AND (value^.array_value^ [index]^.kind IN
                  labeled_structures) THEN
              complex_elements := TRUE;
              EXIT /check_complexity/;
            IFEND;
          FOREND /check_complexity/;

          IF complex_elements THEN
            start_string;
            FOR index := LOWERBOUND (value^.array_value^) TO UPPERBOUND (value^.array_value^) DO
              put_integer (index);
              put_string (': ');
              increment_indent (nesting_indentation);
              convert_value_to_string (value^.array_value^ [index]);
              finish_string;
              indent_amount := previous_indent_amount;
            FOREND;

          ELSE
            IF NOT string_started THEN
              start_string;
            IFEND;
            increment_indent (nesting_indentation);
            put_array_source;
            finish_string;
            indent_amount := previous_indent_amount;
          IFEND;

          level_of_nesting := level_of_nesting - 1;

        PROCEND put_array_compressed_labels;
?? OLDTITLE ??
?? NEWTITLE := 'put_array_elements', EJECT ??

        PROCEDURE put_array_elements;

          VAR
            index: clt$array_bound;


          FOR index := LOWERBOUND (value^.array_value^) TO UPPERBOUND (value^.array_value^) DO
            convert_value_to_string (value^.array_value^ [index]);
            finish_string;
          FOREND;

        PROCEND put_array_elements;
?? TITLE := 'put_array_labeled_elements', EJECT ??

        PROCEDURE put_array_labeled_elements;

          VAR
            index: clt$field_number,
            previous_indent_amount: clt$string_size,
            str: ost$string;


          IF level_of_nesting > 0 THEN
            increment_indent (nesting_indentation);
          IFEND;

          level_of_nesting := level_of_nesting + 1;
          previous_indent_amount := indent_amount;
          IF first_pass THEN
            FOR index := LOWERBOUND (value^.array_value^) TO UPPERBOUND (value^.array_value^) DO
              clp$convert_integer_to_string (index, 10, FALSE, str, status);
              IF NOT status.normal THEN
                EXIT clp$internal_convert_to_string;
              IFEND;
              increment_colon_indent (str.size + 1);
              IF (value^.array_value^ [index] <> NIL) AND (value^.array_value^ [index]^.kind IN
                    labeled_structures) THEN
                convert_value_to_string (value^.array_value^ [index]);
                indent_amount := previous_indent_amount;
              IFEND;
            FOREND;
          ELSE
            start_string;
            FOR index := LOWERBOUND (value^.array_value^) TO UPPERBOUND (value^.array_value^) DO
              put_integer (index);
              IF (value^.array_value^ [index] = NIL) OR NOT (value^.array_value^ [index]^.kind IN
                    labeled_structures) THEN
                put_blanks_and_colon;
                set_indent_amount;
              IFEND;
              convert_value_to_string (value^.array_value^ [index]);
              finish_string;
              indent_amount := previous_indent_amount;
            FOREND;
          IFEND;

          level_of_nesting := level_of_nesting - 1;

        PROCEND put_array_labeled_elements;
?? TITLE := 'put_array_source', EJECT ??

        PROCEDURE put_array_source;

          VAR
            index: clt$array_bound;


          put_string ('(');
          FOR index := LOWERBOUND (value^.array_value^) TO UPPERBOUND (value^.array_value^) DO
            convert_value_to_string (value^.array_value^ [index]);
            IF index <> UPPERBOUND (value^.array_value^) THEN
              put_string (', ');
              set_break_position;
            IFEND;
          FOREND;
          put_string (')');

        PROCEND put_array_source;
?? TITLE := 'put_array_structure', EJECT ??

        PROCEDURE put_array_structure;

          VAR
            index: clt$array_bound,
            previous_indent_amount: clt$string_size;


          start_structure;

          previous_indent_amount := indent_amount;
          FOR index := LOWERBOUND (value^.array_value^) TO UPPERBOUND (value^.array_value^) DO
            put_integer (index);
            put_string (': ');
            set_indent_amount;
            convert_value_to_string (value^.array_value^ [index]);
            finish_string;
            indent_amount := previous_indent_amount;
          FOREND;

          finish_structure;

        PROCEND put_array_structure;
?? OLDTITLE, EJECT ??

        CASE representation_option OF
        = clc$data_elem_representation =
          put_array_elements;
        = clc$data_source_representation =
          put_array_source;
        = clc$data_struct_representation =
          put_array_structure;
        = clc$labeled_elem_representation =
          put_array_labeled_elements;
        = clc$compressed_labeled_elem_rep =
          put_array_compressed_labels;
        CASEND;

      PROCEND convert_array_to_string;
?? TITLE := 'convert_boolean_to_string', EJECT ??

      PROCEDURE convert_boolean_to_string;


        IF representation_option = clc$data_struct_representation THEN
          put_type_identification (clc$boolean);
        IFEND;

        put_boolean (value^.boolean_value.value, value^.boolean_value.kind);

      PROCEND convert_boolean_to_string;
?? TITLE := 'convert_cobol_name_to_string', EJECT ??

      PROCEDURE convert_cobol_name_to_string;


        IF representation_option = clc$data_struct_representation THEN
          put_type_identification (clc$cobol_name);
        IFEND;

        put_string_translated (value^.cobol_name_value);

      PROCEND convert_cobol_name_to_string;
?? TITLE := 'convert_command_ref_to_string', EJECT ??

      PROCEDURE convert_command_ref_to_string;

?? NEWTITLE := 'put_command_ref_structure', EJECT ??

        PROCEDURE put_command_ref_structure;

          VAR
            previous_indent_amount: clt$string_size;


          start_structure;

          put_string ('NAME: ');
          put_type_identification (clc$name);
          put_trimmed_string (value^.command_reference_value^.name);
          finish_string;

          put_string ('FORM: ');
          put_type_identification (clc$keyword);
          CASE value^.command_reference_value^.form OF

          = clc$name_only_command_ref =
            put_string ('NAME_ONLY');

          = clc$skip_1st_entry_command_ref =
            put_string ('SKIP_FIRST_ENTRY');

          = clc$system_command_ref =
            put_string ('SYSTEM');

          = clc$utility_command_ref =
            put_string ('UTILITY');
            finish_string;
            put_string ('UTILITY: ');
            put_type_identification (clc$name);
            put_trimmed_string (value^.command_reference_value^.utility);

          = clc$module_or_file_command_ref =
            put_string ('MODULE_OR_FILE');
            finish_string;
            put_string ('LIBRARY_OR_CATALOG: ');
            put_type_identification (clc$file);
            previous_indent_amount := indent_amount;
            set_indent_amount;
            put_file_reference (value^.command_reference_value^.library_or_catalog);
            indent_amount := previous_indent_amount;

          = clc$file_cycle_command_ref =
            put_string ('FILE_CYCLE');
            finish_string;
            put_string ('LIBRARY_OR_CATALOG: ');
            put_type_identification (clc$file);
            previous_indent_amount := indent_amount;
            set_indent_amount;
            put_file_reference (value^.command_reference_value^.catalog);
            indent_amount := previous_indent_amount;
            finish_string;
            put_string ('CYCLE_NUMBER: ');
            put_type_identification (clc$integer);
            put_integer (value^.command_reference_value^.cycle_number);

          CASEND;
          finish_string;

          finish_structure;

        PROCEND put_command_ref_structure;
?? TITLE := 'put_command_ref_labeled_elems', EJECT ??

        PROCEDURE put_command_ref_labeled_elems;


          VAR
            lower_case_name: ost$name,
            utility: clt$utility_name;

          #TRANSLATE (osv$upper_to_lower, value^.command_reference_value^.name, lower_case_name);

          CASE value^.command_reference_value^.form OF

          = clc$name_only_command_ref =
            put_trimmed_string (lower_case_name);

          = clc$skip_1st_entry_command_ref =
            put_string ('/');
            put_trimmed_string (lower_case_name);

          = clc$system_command_ref =
            put_string ('$system.');
            put_trimmed_string (lower_case_name);

          = clc$utility_command_ref =
            #TRANSLATE (osv$upper_to_lower, value^.command_reference_value^.utility, utility);
            put_trimmed_string (utility);
            put_string ('.');
            put_trimmed_string (lower_case_name);

          = clc$module_or_file_command_ref =
            put_file_reference (value^.command_reference_value^.library_or_catalog);
            put_string ('.');
            put_trimmed_string (lower_case_name);

          = clc$file_cycle_command_ref =
            put_file_reference (value^.command_reference_value^.catalog);
            put_string ('.');
            put_trimmed_string (lower_case_name);
            put_string ('.');
            put_integer (value^.command_reference_value^.cycle_number);

          CASEND;

        PROCEND put_command_ref_labeled_elems;
?? TITLE := 'put_command_ref_value', EJECT ??

        PROCEDURE put_command_ref_value;


          CASE value^.command_reference_value^.form OF

          = clc$name_only_command_ref =
            put_trimmed_string (value^.command_reference_value^.name);

          = clc$skip_1st_entry_command_ref =
            put_string ('/');
            put_trimmed_string (value^.command_reference_value^.name);

          = clc$system_command_ref =
            put_string ('$SYSTEM.');
            put_trimmed_string (value^.command_reference_value^.name);

          = clc$utility_command_ref =
            put_trimmed_string (value^.command_reference_value^.utility);
            put_string ('.');
            put_trimmed_string (value^.command_reference_value^.name);

          = clc$module_or_file_command_ref =
            put_file_reference (value^.command_reference_value^.library_or_catalog);
            put_string ('.');
            put_trimmed_string (value^.command_reference_value^.name);

          = clc$file_cycle_command_ref =
            put_file_reference (value^.command_reference_value^.catalog);
            put_string ('.');
            put_trimmed_string (value^.command_reference_value^.name);
            put_string ('.');
            put_integer (value^.command_reference_value^.cycle_number);

          CASEND;

        PROCEND put_command_ref_value;
?? OLDTITLE, EJECT ??

        CASE representation_option OF
        = clc$compressed_labeled_elem_rep, clc$data_elem_representation, clc$data_source_representation =
          put_command_ref_value;
        = clc$labeled_elem_representation =
          put_command_ref_labeled_elems;
        = clc$data_struct_representation =
          put_command_ref_structure;
        CASEND;

      PROCEND convert_command_ref_to_string;
?? TITLE := 'convert_data_name_to_string', EJECT ??

      PROCEDURE convert_data_name_to_string;

        IF representation_option = clc$data_struct_representation THEN
          put_type_identification (clc$data_name);
        IFEND;

        put_string_translated (value^.data_name_value);

      PROCEND convert_data_name_to_string;
?? TITLE := 'convert_date_time_to_string', EJECT ??

      PROCEDURE convert_date_time_to_string;

?? NEWTITLE := 'put_date_time_element', EJECT ??

        PROCEDURE put_date_time_element;

          VAR
            str: ost$string;


          clp$convert_date_time_to_string (value^.date_time_value, '', str, status);
          IF NOT status.normal THEN
            EXIT clp$internal_convert_to_string;
          IFEND;

          put_string (str.value (1, str.size));

        PROCEND put_date_time_element;
?? TITLE := 'put_date_time_source', EJECT ??

        PROCEDURE put_date_time_source;

          CONST
            default_format_string_size = 11,
            default_date_format_size = 8,
            default_time_format_index = 10,
            default_time_format_size = 2;

          VAR
*IF NOT $true(osv$unix)
            default_format_string: [STATIC, READ, oss$job_paged_literal] string
*ELSE
            default_format_string: [STATIC, READ] string
*IFEND
                  (default_format_string_size) := 'Y4-M2-D2.MS',
            format_string: ^clt$date_time_form_string,
            str: ost$string;


          IF value^.date_time_value.date_specified THEN
            IF value^.date_time_value.time_specified THEN
              format_string := ^default_format_string;
            ELSE
              format_string := ^default_format_string (1, default_date_format_size);
            IFEND;
          ELSE
            format_string := ^default_format_string (default_time_format_index, default_time_format_size);
          IFEND;

          clp$convert_date_time_to_string (value^.date_time_value, format_string^, str, status);
          IF NOT status.normal THEN
            EXIT clp$internal_convert_to_string;
          IFEND;

          put_string (str.value (1, str.size));

        PROCEND put_date_time_source;
?? TITLE := 'put_date_time_structure', EJECT ??

        PROCEDURE put_date_time_structure;


          start_structure;

          IF value^.date_time_value.date_specified THEN
            put_string ('YEAR: ');
            put_type_identification (clc$integer);
            put_integer (value^.date_time_value.value.year + 1900);
            finish_string;
            put_string ('MONTH: ');
            put_type_identification (clc$integer);
            put_integer (value^.date_time_value.value.month);
            finish_string;
            put_string ('DAY: ');
            put_type_identification (clc$integer);
            put_integer (value^.date_time_value.value.day);
            finish_string;
          IFEND;

          IF value^.date_time_value.time_specified THEN
            put_string ('HOUR: ');
            put_type_identification (clc$integer);
            put_integer (value^.date_time_value.value.hour);
            finish_string;
            put_string ('MINUTE: ');
            put_type_identification (clc$integer);
            put_integer (value^.date_time_value.value.minute);
            finish_string;
            put_string ('SECOND: ');
            put_type_identification (clc$integer);
            put_integer (value^.date_time_value.value.second);
            finish_string;
            put_string ('MILLISECOND: ');
            put_type_identification (clc$integer);
            put_integer (value^.date_time_value.value.millisecond);
            finish_string;
          IFEND;

          finish_structure;

        PROCEND put_date_time_structure;
?? OLDTITLE, EJECT ??

        IF (NOT value^.date_time_value.date_specified) AND (NOT value^.date_time_value.time_specified) THEN
          bad_data_value;
        IFEND;

        CASE representation_option OF
        = clc$compressed_labeled_elem_rep, clc$data_elem_representation, clc$labeled_elem_representation =
          put_date_time_element;
        = clc$data_source_representation =
          put_date_time_source;
        = clc$data_struct_representation =
          put_date_time_structure;
        CASEND;

      PROCEND convert_date_time_to_string;
?? TITLE := 'convert_deferred_val_to_string', EJECT ??

      PROCEDURE convert_deferred_val_to_string;

        VAR
          previous_representation_option: clt$data_representation_option,
          result: ^clt$data_value,
          saved_local_work_area: ^clt$work_area;


        IF representation_option = clc$data_elem_representation THEN
          set_up_local_work_area;
*IF NOT $true(osv$unix)
          saved_local_work_area := local_work_area.sequence_pointer;
*ELSE
          saved_local_work_area := local_work_area;
*IFEND

          clp$evaluate_expression (value^.deferred_value^, value^.deferred_type,
*IF NOT $true(osv$unix)
                local_work_area.sequence_pointer, result, status);
*ELSE
                local_work_area, result, status);
*IFEND
          IF NOT status.normal THEN
            EXIT clp$internal_convert_to_string;
          IFEND;

          convert_value_to_string (result);

*IF NOT $true(osv$unix)
          local_work_area.sequence_pointer := saved_local_work_area;
*ELSE
          local_work_area := saved_local_work_area;
*IFEND

        ELSE
          IF representation_option = clc$data_struct_representation THEN
            put_string_translated ('"DEFER" ');
          IFEND;

          previous_representation_option := representation_option;
          representation_option := clc$data_source_representation;

          put_string (value^.deferred_value^);

          representation_option := previous_representation_option;
        IFEND;

      PROCEND convert_deferred_val_to_string;
*IF NOT $true(osv$unix)
?? TITLE := 'convert_entry_point_ref_to_str', EJECT ??

      PROCEDURE convert_entry_point_ref_to_str;

?? NEWTITLE := 'put_entry_point', EJECT ??

        PROCEDURE put_entry_point;


          IF value^.entry_point_reference_value^.entry_point = osc$null_name THEN
            put_string ('none');
          ELSE
            put_program_name (value^.entry_point_reference_value^.entry_point, FALSE,
                  clc$data_source_representation);
          IFEND;

        PROCEND put_entry_point;
?? TITLE := 'put_entry_point_labeled_elems', EJECT ??

        PROCEDURE put_entry_point_labeled_elems;

          VAR
            previous_indent_amount: clt$string_size;


          IF level_of_nesting > 0 THEN
            increment_indent (nesting_indentation);
          IFEND;

          IF first_pass THEN
            increment_colon_indent (STRLENGTH ('ENTRY_POINT '));
            IF value^.entry_point_reference_value^.object_library <> '' THEN
              increment_colon_indent (STRLENGTH ('OBJECT_LIBRARY '));
            IFEND;
          ELSE
            start_string;
            put_field_name_as_label ('ENTRY_POINT                    ');
            put_blanks_and_colon;
            put_entry_point;
            finish_string;
            IF value^.entry_point_reference_value^.object_library <> '' THEN
              put_field_name_as_label ('OBJECT_LIBRARY                 ');
              put_blanks_and_colon;
              previous_indent_amount := indent_amount;
              set_indent_amount;
              put_file_reference (value^.entry_point_reference_value^.object_library);
              indent_amount := previous_indent_amount;
              finish_string;
            IFEND;
          IFEND;

        PROCEND put_entry_point_labeled_elems;
?? TITLE := 'put_entry_point_structure', EJECT ??

        PROCEDURE put_entry_point_structure;

          VAR
            previous_indent_amount: clt$string_size;


          start_structure;

          put_string ('ENTRY_POINT: ');
          put_type_identification (clc$program_name);
          put_entry_point;
          finish_string;
          IF value^.entry_point_reference_value^.object_library <> '' THEN
            put_string ('OBJECT_LIBRARY: ');
            put_type_identification (clc$file);
            previous_indent_amount := indent_amount;
            set_indent_amount;
            put_file_reference (value^.entry_point_reference_value^.object_library);
            indent_amount := previous_indent_amount;
            finish_string;
          IFEND;

          finish_structure;

        PROCEND put_entry_point_structure;
?? TITLE := 'put_entry_point_value', EJECT ??

        PROCEDURE put_entry_point_value;


          IF value^.entry_point_reference_value^.object_library <> '' THEN
            put_trimmed_string (value^.entry_point_reference_value^.object_library);
            put_string ('.');
          IFEND;
          put_entry_point;

        PROCEND put_entry_point_value;
?? OLDTITLE, EJECT ??

        CASE representation_option OF
        = clc$compressed_labeled_elem_rep, clc$data_elem_representation, clc$data_source_representation =
          put_entry_point_value;
        = clc$data_struct_representation =
          put_entry_point_structure;
        = clc$labeled_elem_representation =
          put_entry_point_labeled_elems;
        CASEND;

      PROCEND convert_entry_point_ref_to_str;
*IFEND
?? TITLE := 'convert_file_to_string', EJECT ??

      PROCEDURE convert_file_to_string;


        IF representation_option = clc$data_struct_representation THEN
          put_type_identification (clc$file);
        IFEND;

        put_file_reference (value^.file_value^);

      PROCEND convert_file_to_string;
?? TITLE := 'convert_integer_to_string', EJECT ??

      PROCEDURE convert_integer_to_string;

        VAR
          str: ost$string;


        IF representation_option = clc$data_struct_representation THEN
          put_type_identification (clc$integer);
        IFEND;

        clp$convert_integer_to_string (value^.integer_value.value, value^.integer_value.radix,
              value^.integer_value.radix_specified, str, status);
        IF NOT status.normal THEN
          EXIT clp$internal_convert_to_string;
        IFEND;
        put_string (str.value (1, str.size));

      PROCEND convert_integer_to_string;
?? TITLE := 'convert_keyword_to_string', EJECT ??

      PROCEDURE convert_keyword_to_string;


        IF representation_option = clc$data_struct_representation THEN
          put_type_identification (clc$keyword);
        IFEND;

        put_string_translated (value^.keyword_value);

      PROCEND convert_keyword_to_string;
?? TITLE := 'convert_list_to_string', EJECT ??

      PROCEDURE convert_list_to_string;

?? NEWTITLE := 'put_list_compressed_labels', EJECT ??

        PROCEDURE put_list_compressed_labels;

          VAR
            node: ^clt$data_value,
            node_number: clt$list_size,
            previous_indent_amount: clt$string_size,
            str: ost$string;


          IF (value^.link = NIL) AND (value^.element_value = NIL) THEN
            IF NOT string_started THEN
              start_string;
            IFEND;
            put_blanks_and_colon;
            put_string ('"empty list"');
            finish_string;
            RETURN;
          IFEND;


          level_of_nesting := level_of_nesting + 1;
          node := value;
          node_number := 0;
          previous_indent_amount := indent_amount;
          WHILE (node <> NIL) AND NOT (node^.element_value^.kind IN labeled_structures) DO
            node := node^.link;
          WHILEND;
          IF node = NIL THEN
            IF NOT string_started THEN
              start_string;
            IFEND;
            increment_indent (nesting_indentation);
            put_list_source;
            finish_string;
            indent_amount := previous_indent_amount;
          ELSE
            start_string;
            node := value;
            WHILE node <> NIL DO
              node_number := node_number + 1;
              put_integer (node_number);
              put_string (': ');
              increment_indent (nesting_indentation);
              convert_value_to_string (node^.element_value);
              finish_string;
              node := node^.link;
              indent_amount := previous_indent_amount;
            WHILEND;
          IFEND;

          level_of_nesting := level_of_nesting - 1;

        PROCEND put_list_compressed_labels;
?? OLDTITLE ??
?? NEWTITLE := 'put_list_elements', EJECT ??

        PROCEDURE put_list_elements;

          VAR
            node: ^clt$data_value;


          IF (value^.link = NIL) AND (value^.element_value = NIL) THEN
            put_string_translated ('"EMPTY LIST"');
            finish_string;
            RETURN;
          IFEND;

          node := value;
          WHILE node <> NIL DO
            convert_value_to_string (node^.element_value);
            finish_string;
            node := node^.link;
          WHILEND;

        PROCEND put_list_elements;
?? TITLE := 'put_list_labeled_elements', EJECT ??

        PROCEDURE put_list_labeled_elements;

          VAR
            node: ^clt$data_value,
            node_number: clt$list_size,
            previous_indent_amount: clt$string_size,
            str: ost$string;


          IF (value^.link = NIL) AND (value^.element_value = NIL) THEN
            IF NOT first_pass THEN
              IF NOT string_started THEN
                start_string;
              IFEND;
              put_blanks_and_colon;
              put_string ('"empty list"');
              finish_string;
            IFEND;
            RETURN;
          IFEND;

          IF level_of_nesting > 0 THEN
            increment_indent (nesting_indentation);
          IFEND;

          level_of_nesting := level_of_nesting + 1;
          node := value;
          node_number := 0;
          previous_indent_amount := indent_amount;
          IF first_pass THEN
            WHILE node <> NIL DO
              node_number := node_number + 1;
              IF node^.element_value^.kind IN labeled_structures THEN
                clp$convert_integer_to_string (node_number, 10, FALSE, str, status);
                IF NOT status.normal THEN
                  EXIT clp$internal_convert_to_string;
                IFEND;
                increment_colon_indent (str.size + 1);
                convert_value_to_string (node^.element_value);
                indent_amount := previous_indent_amount;
              IFEND;
              node := node^.link;
            WHILEND;
          ELSE
            WHILE (node <> NIL) AND NOT (node^.element_value^.kind IN labeled_structures) DO
              node := node^.link;
            WHILEND;
            IF node = NIL THEN
              IF NOT string_started THEN
                start_string;
              IFEND;
              put_blanks_and_colon;
              set_indent_amount;
              put_list_source;
              finish_string;
            ELSE
              start_string;
              node := value;
              WHILE node <> NIL DO
                node_number := node_number + 1;
                put_integer (node_number);
                IF NOT (node^.element_value^.kind IN labeled_structures) THEN
                  put_blanks_and_colon;
                IFEND;
                convert_value_to_string (node^.element_value);
                finish_string;
                indent_amount := previous_indent_amount;
                node := node^.link;
              WHILEND;
            IFEND;
          IFEND;

          level_of_nesting := level_of_nesting - 1;

        PROCEND put_list_labeled_elements;
?? TITLE := 'put_list_source', EJECT ??

        PROCEDURE put_list_source;

          VAR
            node: ^clt$data_value,
            parentheses_needed: boolean;


          node := value;

        /determine_parentheses_needed/
          WHILE TRUE DO
            IF node = NIL THEN
              parentheses_needed := TRUE;
              EXIT /determine_parentheses_needed/;
            ELSEIF node^.generated_via_list_rest THEN
              parentheses_needed := FALSE;
              EXIT /determine_parentheses_needed/;
            ELSEIF (node^.link <> NIL) OR (node^.element_value = NIL) THEN
              parentheses_needed := TRUE;
              EXIT /determine_parentheses_needed/;
            ELSE
              CASE node^.element_value^.kind OF
              = clc$list =
                node := node^.element_value;
              = clc$array, clc$deferred, clc$record =
                parentheses_needed := TRUE;
                EXIT /determine_parentheses_needed/;
              ELSE
                parentheses_needed := FALSE;
                EXIT /determine_parentheses_needed/;
              CASEND;
            IFEND;
          WHILEND /determine_parentheses_needed/;

          IF parentheses_needed THEN
            put_string ('(');
          IFEND;

          IF (value^.link <> NIL) OR (value^.element_value <> NIL) THEN
            node := value;
            WHILE node <> NIL DO
              convert_value_to_string (node^.element_value);
              IF node^.link <> NIL THEN
                put_string (', ');
                set_break_position;
              IFEND;
              node := node^.link;
            WHILEND;
          ELSEIF NOT parentheses_needed THEN
            put_string_translated ('"EMPTY LIST"');
          IFEND;

          IF parentheses_needed THEN
            put_string (')');
          IFEND;

        PROCEND put_list_source;
?? TITLE := 'put_list_structure', EJECT ??

        PROCEDURE put_list_structure;

          VAR
            node: ^clt$data_value,
            node_number: clt$list_size,
            previous_indent_amount: clt$string_size;


          IF (value^.link = NIL) AND (value^.element_value = NIL) THEN
            put_string ('"EMPTY LIST"');
            finish_string;
            RETURN;
          IFEND;

          start_structure;

          node := value;
          node_number := 0;
          previous_indent_amount := indent_amount;
          WHILE node <> NIL DO
            node_number := node_number + 1;
            put_integer (node_number);
            put_string (': ');
            set_indent_amount;
            convert_value_to_string (node^.element_value);
            finish_string;
            indent_amount := previous_indent_amount;
            node := node^.link;
          WHILEND;

          finish_structure;

        PROCEND put_list_structure;
?? OLDTITLE, EJECT ??

        CASE representation_option OF
        = clc$data_elem_representation =
          put_list_elements;
        = clc$data_source_representation =
          put_list_source;
        = clc$data_struct_representation =
          put_list_structure;
        = clc$labeled_elem_representation =
          put_list_labeled_elements;
        = clc$compressed_labeled_elem_rep =
          put_list_compressed_labels;
        CASEND;

      PROCEND convert_list_to_string;
?? TITLE := 'convert_lock_to_string', EJECT ??

      PROCEDURE convert_lock_to_string;


        IF representation_option = clc$data_struct_representation THEN
          put_type_identification (clc$lock);
        IFEND;

        CASE value^.lock_value^.state OF
        = clc$lock_clear =
          put_string_translated ('"LOCK CLEAR"');
        = clc$lock_set =
          put_string_translated ('"LOCK SET"');
        = clc$lock_expired =
          put_string_translated ('"LOCK EXPIRED"');
        ELSE
          bad_data_value;
        CASEND;

      PROCEND convert_lock_to_string;
?? TITLE := 'convert_name_to_string', EJECT ??

      PROCEDURE convert_name_to_string;

        IF representation_option = clc$data_struct_representation THEN
          put_type_identification (clc$name);
        IFEND;

        put_string_translated (value^.name_value);

      PROCEND convert_name_to_string;
?? TITLE := 'convert_network_title_to_string', EJECT ??

      PROCEDURE convert_network_title_to_string;

        VAR
          previous_indent_amount: clt$string_size;


        CASE representation_option OF
        = clc$compressed_labeled_elem_rep, clc$data_elem_representation, clc$labeled_elem_representation =
          put_trimmed_string (value^.network_title_value^);
        = clc$data_source_representation =
          put_source_string (value^.network_title_value^);
        = clc$data_struct_representation =
          put_type_identification (clc$network_title);
          previous_indent_amount := indent_amount;
          set_indent_amount;
          put_source_string (value^.network_title_value^);
          indent_amount := previous_indent_amount;
        CASEND;

      PROCEND convert_network_title_to_string;
?? TITLE := 'convert_program_name_to_string', EJECT ??

      PROCEDURE convert_program_name_to_string;


        IF representation_option = clc$data_struct_representation THEN
          put_type_identification (clc$program_name);
        IFEND;

        put_program_name (value^.program_name_value, TRUE, representation_option);

      PROCEND convert_program_name_to_string;
?? TITLE := 'convert_range_to_string', EJECT ??

      PROCEDURE convert_range_to_string;

?? NEWTITLE := 'put_range_elements', EJECT ??

        PROCEDURE put_range_elements;


          convert_value_to_string (value^.low_value);
          finish_string;
          convert_value_to_string (value^.high_value);
          finish_string;

        PROCEND put_range_elements;
?? TITLE := 'put_range_labeled_elements', EJECT ??

        PROCEDURE put_range_labeled_elements;

          VAR
            previous_indent_amount: clt$string_size;


          IF level_of_nesting > 0 THEN
            increment_indent (nesting_indentation);
          IFEND;

          level_of_nesting := level_of_nesting + 1;
          previous_indent_amount := indent_amount;
          IF first_pass THEN
            IF value^.high_value <> value^.low_value THEN
              increment_colon_indent (STRLENGTH ('HIGH '));
              IF value^.low_value^.kind IN labeled_structures THEN
                convert_value_to_string (value^.low_value);
                indent_amount := previous_indent_amount;
              IFEND;
            ELSE
              increment_colon_indent (STRLENGTH ('LOW, HIGH '));
            IFEND;
            IF value^.high_value^.kind IN labeled_structures THEN
              convert_value_to_string (value^.high_value);
              indent_amount := previous_indent_amount;
            IFEND;
          ELSE
            start_string;
            IF value^.high_value <> value^.low_value THEN
              put_field_name_as_label ('LOW                            ');
              IF NOT (value^.low_value^.kind IN labeled_structures) THEN
                put_blanks_and_colon;
                set_indent_amount;
              IFEND;
              convert_value_to_string (value^.low_value);
              finish_string;
              indent_amount := previous_indent_amount;
              put_field_name_as_label ('HIGH                           ');
            ELSE
              put_field_name_as_label ('LOW, HIGH                      ');
            IFEND;
            IF NOT (value^.high_value^.kind IN labeled_structures) THEN
              put_blanks_and_colon;
              set_indent_amount;
            IFEND;
            convert_value_to_string (value^.high_value);
            finish_string;
            indent_amount := previous_indent_amount;
          IFEND;

          level_of_nesting := level_of_nesting - 1;

        PROCEND put_range_labeled_elements;
?? TITLE := 'put_range_source', EJECT ??

        PROCEDURE put_range_source;


          convert_value_to_string (value^.low_value);
          IF value^.high_value <> value^.low_value THEN
            put_string ('..');
            convert_value_to_string (value^.high_value);
          IFEND;

        PROCEND put_range_source;
?? TITLE := 'put_range_structure', EJECT ??

        PROCEDURE put_range_structure;

          VAR
            previous_indent_amount: clt$string_size;


          start_structure;

          previous_indent_amount := indent_amount;
          IF value^.high_value <> value^.low_value THEN
            put_string ('LOW: ');
          ELSE
            put_string ('LOW, HIGH: ');
          IFEND;
          convert_value_to_string (value^.low_value);
          finish_string;
          indent_amount := previous_indent_amount;
          IF value^.high_value <> value^.low_value THEN
            put_string ('HIGH: ');
            convert_value_to_string (value^.high_value);
            finish_string;
            indent_amount := previous_indent_amount;
          IFEND;

          finish_structure;

        PROCEND put_range_structure;
?? OLDTITLE, EJECT ??

        CASE representation_option OF
        = clc$data_elem_representation =
          put_range_elements;
        = clc$compressed_labeled_elem_rep, clc$data_source_representation =
          put_range_source;
        = clc$data_struct_representation =
          put_range_structure;
        = clc$labeled_elem_representation =
          put_range_labeled_elements;
        CASEND;

      PROCEND convert_range_to_string;
*IF NOT $true(osv$unix)
?? TITLE := 'convert_real_to_string', EJECT ??

      PROCEDURE convert_real_to_string;

        VAR
          str: ost$string;


        IF representation_option = clc$data_struct_representation THEN
          put_type_identification (clc$real);
        IFEND;

        clp$convert_real_to_string (value^.real_value.value, value^.real_value.number_of_digits, str, status);
        IF NOT status.normal THEN
          EXIT clp$internal_convert_to_string;
        IFEND;
        put_string (str.value (1, str.size));

      PROCEND convert_real_to_string;
*IFEND
?? TITLE := 'convert_record_to_string', EJECT ??

      PROCEDURE convert_record_to_string;

?? NEWTITLE := 'put_record_compressed_labels', EJECT ??

        PROCEDURE put_record_compressed_labels;

          VAR
            index: clt$field_number,
            initial_indent_amount: clt$string_size,
            record_indent_amount: clt$string_size;


          level_of_nesting := level_of_nesting + 1;
          IF NOT string_started THEN
            start_string;
          IFEND;
          initial_indent_amount := indent_amount;
          record_indent_amount := indent_amount;
          indent_amount := record_indent_amount;
          FOR index := 1 TO UPPERBOUND (value^.field_values^) DO
            IF (index > 1) AND string_started THEN
              IF (value^.field_values^ [index].value <> NIL) AND
                    (value^.field_values^ [index].value^.kind IN labeled_structures) THEN
                start_string;
              ELSE
                put_string (', ');
                set_break_position;
              IFEND;
            IFEND;
            put_field_name_as_label (value^.field_values^ [index].name);
            put_string (': ');
            increment_indent (nesting_indentation);
            convert_value_to_string (value^.field_values^ [index].value);
            indent_amount := record_indent_amount;
          FOREND;
          indent_amount := initial_indent_amount;
          finish_string;

          level_of_nesting := level_of_nesting - 1;

        PROCEND put_record_compressed_labels;
?? OLDTITLE ??
?? NEWTITLE := 'put_record_fields', EJECT ??

        PROCEDURE put_record_fields;

          VAR
            index: clt$field_number;


          FOR index := 1 TO UPPERBOUND (value^.field_values^) DO
            convert_value_to_string (value^.field_values^ [index].value);
            finish_string;
          FOREND;

        PROCEND put_record_fields;
?? TITLE := 'put_record_labeled_elements', EJECT ??

        PROCEDURE put_record_labeled_elements;

          VAR
            index: clt$field_number,
            previous_indent_amount: clt$string_size;


          IF level_of_nesting > 0 THEN
            increment_indent (nesting_indentation);
          IFEND;

          level_of_nesting := level_of_nesting + 1;
          previous_indent_amount := indent_amount;
          IF first_pass THEN
            FOR index := 1 TO UPPERBOUND (value^.field_values^) DO
              increment_colon_indent (clp$trimmed_string_size (value^.field_values^ [index].name) + 1);
              IF (value^.field_values^ [index].value <> NIL) AND
                    (value^.field_values^ [index].value^.kind IN labeled_structures) THEN
                convert_value_to_string (value^.field_values^ [index].value);
                indent_amount := previous_indent_amount;
              IFEND;
            FOREND;
          ELSE
            start_string;
            FOR index := 1 TO UPPERBOUND (value^.field_values^) DO
              put_field_name_as_label (value^.field_values^ [index].name);
              IF (value^.field_values^ [index].value = NIL) OR NOT (value^.field_values^ [index].
                    value^.kind IN labeled_structures) THEN
                put_blanks_and_colon;
                set_indent_amount;
              IFEND;
              convert_value_to_string (value^.field_values^ [index].value);
              finish_string;
              indent_amount := previous_indent_amount;
            FOREND;
          IFEND;

          level_of_nesting := level_of_nesting - 1;

        PROCEND put_record_labeled_elements;

?? TITLE := 'put_record_source', EJECT ??

        PROCEDURE put_record_source;

          VAR
            index: clt$field_number,
            last_index: clt$field_number;


          last_index := UPPERBOUND (value^.field_values^);
          WHILE (last_index > 1) AND (value^.field_values^ [last_index].value = NIL) DO
            last_index := last_index - 1;
          WHILEND;

          put_string ('(');
          FOR index := 1 TO last_index DO
            convert_value_to_string (value^.field_values^ [index].value);
            IF index <> last_index THEN
              put_string (', ');
              set_break_position;
            IFEND;
          FOREND;
          put_string (')');

        PROCEND put_record_source;
?? TITLE := 'put_record_structure', EJECT ??

        PROCEDURE put_record_structure;

          VAR
            index: clt$field_number,
            previous_indent_amount: clt$string_size;


          start_structure;

          previous_indent_amount := indent_amount;
          FOR index := 1 TO UPPERBOUND (value^.field_values^) DO
            put_trimmed_string (value^.field_values^ [index].name);
            put_string (': ');
            set_indent_amount;
            convert_value_to_string (value^.field_values^ [index].value);
            finish_string;
            indent_amount := previous_indent_amount;
          FOREND;

          finish_structure;

        PROCEND put_record_structure;
?? OLDTITLE, EJECT ??

        CASE representation_option OF
        = clc$data_elem_representation =
          put_record_fields;
        = clc$data_source_representation =
          put_record_source;
        = clc$data_struct_representation =
          put_record_structure;
        = clc$labeled_elem_representation =
          put_record_labeled_elements;
        = clc$compressed_labeled_elem_rep =
          put_record_compressed_labels;
        CASEND;

      PROCEND convert_record_to_string;
?? TITLE := 'convert_scu_line_id_to_string', EJECT ??

      PROCEDURE convert_scu_line_id_to_string;

?? NEWTITLE := 'put_scu_line_id_labeled_elems', EJECT ??

        PROCEDURE put_scu_line_id_labeled_elems;


          VAR
            line_id_mod_name: clt$scu_modification_name;

          #TRANSLATE (osv$upper_to_lower, value^.scu_line_identifier_value.modification_name,
                line_id_mod_name);
          put_trimmed_string (line_id_mod_name);
          put_string ('.');
          put_integer (value^.scu_line_identifier_value.sequence_number);

        PROCEND put_scu_line_id_labeled_elems;
?? TITLE := 'put_scu_line_id_structure', EJECT ??

        PROCEDURE put_scu_line_id_structure;


          start_structure;

          put_string ('MODIFICATION_NAME: ');
          put_type_identification (clc$name);
          put_trimmed_string (value^.scu_line_identifier_value.modification_name);
          finish_string;
          put_string ('SEQUENCE_NUMBER: ');
          put_type_identification (clc$integer);
          put_integer (value^.scu_line_identifier_value.sequence_number);
          finish_string;

          finish_structure;

        PROCEND put_scu_line_id_structure;
?? TITLE := 'put_scu_line_id_value', EJECT ??

        PROCEDURE put_scu_line_id_value;


          put_trimmed_string (value^.scu_line_identifier_value.modification_name);
          put_string ('.');
          put_integer (value^.scu_line_identifier_value.sequence_number);

        PROCEND put_scu_line_id_value;
?? OLDTITLE, EJECT ??

        CASE representation_option OF
        = clc$compressed_labeled_elem_rep, clc$data_elem_representation, clc$data_source_representation =
          put_scu_line_id_value;
        = clc$labeled_elem_representation =
          put_scu_line_id_labeled_elems;
        = clc$data_struct_representation =
          put_scu_line_id_structure;
        CASEND;

      PROCEND convert_scu_line_id_to_string;
?? TITLE := 'convert_statistic_code_to_str', EJECT ??

      PROCEDURE convert_statistic_code_to_str;


        IF representation_option = clc$data_struct_representation THEN
          put_type_identification (clc$statistic_code);
        IFEND;

        put_status_code (FALSE, value^.statistic_code_value);

      PROCEND convert_statistic_code_to_str;
?? TITLE := 'convert_status_to_string', EJECT ??

      PROCEDURE convert_status_to_string;

?? NEWTITLE := 'put_status_message', EJECT ??

        PROCEDURE put_status_message;

          VAR
            i: ost$status_message_line_count,
            message: ost$status_message,
            message_area: ^ost$status_message,
            message_line_count: ^ost$status_message_line_count,
            message_line_size: ^ost$status_message_line_size,
            message_line: ^string ( * );


          osp$format_message (value^.status_value^, osc$current_message_level, osc$max_string_size, message,
                status);
          IF NOT status.normal THEN
            EXIT clp$internal_convert_to_string;
          IFEND;
          message_area := ^message;
          RESET message_area;
          NEXT message_line_count IN message_area;
          IF message_line_count^ = 0 THEN
            put_string_translated ('NORMAL STATUS');
          ELSE
            FOR i := 1 TO message_line_count^ DO
              NEXT message_line_size IN message_area;
              NEXT message_line: [message_line_size^] IN message_area;
              put_string (message_line^ (2, * ));
              finish_string;
            FOREND;
          IFEND;

        PROCEND put_status_message;
?? TITLE := 'put_status_source', EJECT ??

        PROCEDURE put_status_source;

          VAR
            identifier: ost$status_identifier,
            parameter_delimiter: char,
            parameter_index: ost$string_index,
            str: ost$string,
            text_index: ost$string_index;


          IF value^.status_value^.normal THEN
            put_string_translated ('$STATUS(TRUE)');
            RETURN;
          IFEND;

          put_string_translated ('$STATUS(FALSE');
          put_string (', ');
          set_break_position;

          osp$unpack_status_identifier (value^.status_value^.condition, identifier);
          put_source_string (identifier);
          put_string (', ');
          set_break_position;

          put_status_code (TRUE, value^.status_value^.condition);

          IF value^.status_value^.text.size > 0 THEN
            put_string (', ');
            set_break_position;

            parameter_delimiter := value^.status_value^.text.value (1);
            IF parameter_delimiter <> osc$status_parameter_delimiter THEN
              put_source_string (value^.status_value^.text.value (1, value^.status_value^.text.size));
            ELSE
              parameter_index := 2;
              FOR text_index := 2 TO value^.status_value^.text.size DO
                IF value^.status_value^.text.value (text_index) = parameter_delimiter THEN
                  put_source_string (value^.status_value^.text.value
                        (parameter_index, text_index - parameter_index));
                  parameter_index := text_index + 1;
                  put_string (', ');
                  set_break_position;
                IFEND;
              FOREND;
              put_source_string (value^.status_value^.text.value
                    (parameter_index, value^.status_value^.text.size + 1 - parameter_index));
            IFEND;
          IFEND;

          put_string (')');

        PROCEND put_status_source;
?? TITLE := 'put_status_structure', EJECT ??

        PROCEDURE put_status_structure;

          VAR
            name: ost$status_condition_name,
            previous_indent_amount: clt$string_size;


          start_structure;

          put_string ('NORMAL: ');
          put_type_identification (clc$boolean);
          IF value^.status_value^.normal THEN
            put_string ('TRUE');
          ELSE
            put_string ('FALSE');
            finish_string;

            put_string ('CONDITION: ');
            put_type_identification (clc$status_code);
            put_status_code (TRUE, value^.status_value^.condition);
            finish_string;

            previous_indent_amount := indent_amount;
            put_string ('TEXT: ');
            put_type_identification (clc$string);
            set_indent_amount;
            put_source_string (value^.status_value^.text.value (1, value^.status_value^.text.size));
            indent_amount := previous_indent_amount;
          IFEND;
          finish_string;

          finish_structure;

        PROCEND put_status_structure;
?? OLDTITLE, EJECT ??

        CASE representation_option OF
        = clc$data_elem_representation =
          put_status_message;
        = clc$compressed_labeled_elem_rep, clc$data_source_representation, clc$labeled_elem_representation =
          put_status_source;
        = clc$data_struct_representation =
          put_status_structure;
        CASEND;

      PROCEND convert_status_to_string;
?? TITLE := 'convert_status_code_to_string', EJECT ??

      PROCEDURE convert_status_code_to_string;


        IF representation_option = clc$data_struct_representation THEN
          put_type_identification (clc$status_code);
        IFEND;

        put_status_code (TRUE, value^.status_code_value);

      PROCEND convert_status_code_to_string;
?? TITLE := 'convert_string_value_to_string', EJECT ??

      PROCEDURE convert_string_value_to_string;

        VAR
          previous_indent_amount: clt$string_size;


        CASE representation_option OF
        = clc$data_elem_representation =
          put_string (value^.string_value^);
          string_may_be_trimmed := FALSE;
        = clc$compressed_labeled_elem_rep, clc$data_source_representation, clc$labeled_elem_representation =
          put_source_string (value^.string_value^);
        = clc$data_struct_representation =
          put_type_identification (clc$string);
          previous_indent_amount := indent_amount;
          set_indent_amount;
          put_source_string (value^.string_value^);
          indent_amount := previous_indent_amount;
        CASEND;

      PROCEND convert_string_value_to_string;
?? TITLE := 'convert_string_pat_to_string', EJECT ??

      PROCEDURE convert_string_pat_to_string;

        VAR
          previous_representation_option: clt$data_representation_option,
          saved_local_work_area: ^clt$work_area,
          str: ^clt$string_value;


        IF representation_option = clc$data_struct_representation THEN
          put_type_identification (clc$string_pattern);
        IFEND;

        set_up_local_work_area;
*IF NOT $true(osv$unix)
        saved_local_work_area := local_work_area.sequence_pointer;
*ELSE
        saved_local_work_area := local_work_area;
*IFEND

*IF NOT $true(osv$unix)
        clp$sp_convert_to_string (value^.string_pattern_value, local_work_area.sequence_pointer, str, status);
*ELSE
        clp$sp_convert_to_string (value^.string_pattern_value, local_work_area, str, status);
*IFEND
        IF NOT status.normal THEN
          IF status.condition <> cle$bad_string_pattern THEN
            EXIT clp$internal_convert_to_string;
          IFEND;
          status.normal := TRUE;
          put_string_translated ('BAD STRING_PATTERN VALUE.');
          RETURN;
        IFEND;

        previous_representation_option := representation_option;
        representation_option := clc$data_source_representation;

        put_string (str^);

        representation_option := previous_representation_option;

*IF NOT $true(osv$unix)
        local_work_area.sequence_pointer := saved_local_work_area;
*ELSE
        local_work_area := saved_local_work_area;
*IFEND

      PROCEND convert_string_pat_to_string;
?? TITLE := 'convert_time_incr_to_string', EJECT ??

      PROCEDURE convert_time_incr_to_string;

?? NEWTITLE := 'put_time_incr_element', EJECT ??

        PROCEDURE put_time_incr_element
          (    element: integer);


          IF element < 0 THEN
            put_string ('(');
          IFEND;

          put_integer (element);

          IF element < 0 THEN
            put_string (')');
          IFEND;

        PROCEND put_time_incr_element;
?? TITLE := 'put_time_incr_structure', EJECT ??

        PROCEDURE put_time_incr_structure;


          start_structure;

          put_string ('YEARS: ');
          put_type_identification (clc$integer);
          put_integer (value^.time_increment_value^.year);
          finish_string;
          put_string ('MONTHS: ');
          put_type_identification (clc$integer);
          put_integer (value^.time_increment_value^.month);
          finish_string;
          put_string ('DAYS: ');
          put_type_identification (clc$integer);
          put_integer (value^.time_increment_value^.day);
          finish_string;

          put_string ('HOURS: ');
          put_type_identification (clc$integer);
          put_integer (value^.time_increment_value^.hour);
          finish_string;
          put_string ('MINUTES: ');
          put_type_identification (clc$integer);
          put_integer (value^.time_increment_value^.minute);
          finish_string;
          put_string ('SECONDS: ');
          put_type_identification (clc$integer);
          put_integer (value^.time_increment_value^.second);
          finish_string;
          put_string ('MILLISECONDS: ');
          put_type_identification (clc$integer);
          put_integer (value^.time_increment_value^.millisecond);
          finish_string;

          finish_structure;

        PROCEND put_time_incr_structure;
?? TITLE := 'put_time_incr_value', EJECT ??

        PROCEDURE put_time_incr_value;


          put_time_incr_element (value^.time_increment_value^.year);
          put_string ('-');
          put_time_incr_element (value^.time_increment_value^.month);
          put_string ('-');
          put_time_incr_element (value^.time_increment_value^.day);

          put_string ('.');

          put_time_incr_element (value^.time_increment_value^.hour);
          put_string (':');
          put_time_incr_element (value^.time_increment_value^.minute);
          put_string (':');
          put_time_incr_element (value^.time_increment_value^.second);
          put_string ('.');
          put_time_incr_element (value^.time_increment_value^.millisecond);

        PROCEND put_time_incr_value;
?? OLDTITLE, EJECT ??

        CASE representation_option OF
        = clc$compressed_labeled_elem_rep, clc$data_elem_representation, clc$data_source_representation,
              clc$labeled_elem_representation =
          put_time_incr_value;
        = clc$data_struct_representation =
          put_time_incr_structure;
        CASEND;

      PROCEND convert_time_incr_to_string;
?? TITLE := 'convert_time_zone_to_string', EJECT ??

      PROCEDURE convert_time_zone_to_string;

?? NEWTITLE := 'put_time_zone_structure', EJECT ??

        PROCEDURE put_time_zone_structure;


          start_structure;

          put_string ('HOURS_FROM_GMT: ');
          put_type_identification (clc$integer);
          put_integer (value^.time_zone_value.hours_from_gmt);
          finish_string;
          put_string ('MINUTES_OFFSET: ');
          put_type_identification (clc$integer);
          put_integer (value^.time_zone_value.minutes_offset);
          finish_string;
          put_string ('DAYLIGHT_SAVING_TIME: ');
          put_type_identification (clc$boolean);
          put_boolean (value^.time_zone_value.daylight_saving_time, clc$true_false_boolean);
          finish_string;

          finish_structure;

        PROCEND put_time_zone_structure;
?? TITLE := 'put_time_zone_value', EJECT ??

        PROCEDURE put_time_zone_value;


          put_integer (value^.time_zone_value.hours_from_gmt);
          put_string (':');
          put_integer (value^.time_zone_value.minutes_offset);
          put_string ('.');
          IF value^.time_zone_value.daylight_saving_time THEN
            put_string_translated ('DAYLIGHT_SAVING_TIME');
          ELSE
            put_string_translated ('STANDARD_TIME');
          IFEND;

        PROCEND put_time_zone_value;
?? OLDTITLE, EJECT ??

        CASE representation_option OF
        = clc$compressed_labeled_elem_rep, clc$data_elem_representation, clc$data_source_representation,
              clc$labeled_elem_representation =
          put_time_zone_value;
        = clc$data_struct_representation =
          put_time_zone_structure;
        CASEND;

      PROCEND convert_time_zone_to_string;
?? TITLE := 'convert_type_spec_to_string', EJECT ??

      PROCEDURE convert_type_spec_to_string;

        VAR
          saved_local_work_area: ^clt$work_area,
          type_description: clt$type_description;


        IF representation_option = clc$data_struct_representation THEN
          put_type_identification (clc$type_specification);
        IFEND;

        set_up_local_work_area;
*IF NOT $true(osv$unix)
        saved_local_work_area := local_work_area.sequence_pointer;
*ELSE
        saved_local_work_area := local_work_area;
*IFEND

*IF NOT $true(osv$unix)
        clp$convert_type_spec_to_desc (value^.type_specification_value, local_work_area.sequence_pointer,
*ELSE
        clp$convert_type_spec_to_desc (value^.type_specification_value, local_work_area,
*IFEND
              type_description, status);
        IF NOT status.normal THEN
          EXIT clp$internal_convert_to_string;
        IFEND;

        put_type (FALSE, TRUE, multi_line_format, type_description);

*IF NOT $true(osv$unix)
        local_work_area.sequence_pointer := saved_local_work_area;
*ELSE
        local_work_area := saved_local_work_area;
*IFEND

      PROCEND convert_type_spec_to_string;
?? TITLE := 'finish_structure', EJECT ??

      PROCEDURE finish_structure;


        indent_amount := indent_at_start_of_structure;
        start_string;
        put_string ('"');
        put_type_name;
        put_string (' END"');
        finish_string;

      PROCEND finish_structure;
?? TITLE := 'increment_colon_indent', EJECT ??

      PROCEDURE increment_colon_indent
        (    increment: clt$string_size);

        IF indent_amount + increment > colon_indent THEN
          IF (indent_amount + increment) <= (max_string DIV 2) THEN
            colon_indent := indent_amount + increment;
          ELSE
            colon_indent := max_string DIV 2;
            IF colon_indent > increment THEN
              indent_amount := ((colon_indent - increment) DIV 2) * 2;
            ELSE
              indent_amount := initial_indentation;
            IFEND;
            IF indent_amount < label_indent_limit THEN
              label_indent_limit := indent_amount;
            IFEND;
          IFEND;
        IFEND;

      PROCEND increment_colon_indent;
?? TITLE := 'put_blanks_and_colon', EJECT ??

      PROCEDURE put_blanks_and_colon;


        IF colon_indent > string_size^ THEN
          string_ptr^ (string_size^ +1, colon_indent - string_size^) := ' ';
          string_size^ := colon_indent + 2;
          string_ptr^ (string_size^ -1, 2) := ': ';
        IFEND;

      PROCEND put_blanks_and_colon;
?? TITLE := 'put_boolean', EJECT ??

      VAR
*IF NOT $true(osv$unix)
        booleans: [STATIC, READ, oss$job_paged_literal] array [boolean] of array [clt$boolean_kinds] of
*ELSE
        booleans: [STATIC, READ] array [boolean] of array [clt$boolean_kinds] of
*IFEND
              string (5) := [['FALSE', 'NO', 'OFF'], ['TRUE', 'YES', 'ON']],
*IF NOT $true(osv$unix)
        lower_case_booleans: [STATIC, READ, oss$job_paged_literal] array [boolean] of
*ELSE
        lower_case_booleans: [STATIC, READ] array [boolean] of
*IFEND
              array [clt$boolean_kinds] of string (5) := [['false', 'no', 'off'], ['true', 'yes', 'on']];

?? SKIP := 3 ??

      PROCEDURE [INLINE] put_boolean
        (    boolean_value: boolean;
             boolean_kind: clt$boolean_kinds);


        IF (boolean_value < FALSE) OR (boolean_value > TRUE) OR
              (boolean_kind < LOWERVALUE (clt$boolean_kinds)) OR
              (boolean_kind > UPPERVALUE (clt$boolean_kinds)) THEN
          bad_data_value;
        IFEND;

        IF convert_to_lower_case THEN
          put_trimmed_string (lower_case_booleans [boolean_value] [boolean_kind]);
        ELSE
          put_trimmed_string (booleans [boolean_value] [boolean_kind]);
        IFEND;

      PROCEND put_boolean;
?? TITLE := 'put_field_name_as_label', EJECT ??

      PROCEDURE put_field_name_as_label
        (    field_name: ost$name);

        VAR
          i: 1 .. osc$max_name_size,
          label: string (osc$max_name_size),
          label_size: 0 .. osc$max_name_size,
          new_word: boolean;


        label_size := osc$max_name_size;
        new_word := TRUE;

      /make_label/
        FOR i := 1 TO osc$max_name_size DO
          IF field_name (i) = ' ' THEN
            IF field_name (i + 1, * ) = ' ' THEN
              label_size := i - 1;
              EXIT /make_label/;
            IFEND;
            label (i) := ' ';
            new_word := TRUE;
          ELSEIF field_name (i) = '_' THEN
            label (i) := '_';
            new_word := TRUE;
          ELSEIF new_word THEN
            label (i) := field_name (i);
            new_word := FALSE;
          ELSE
            label (i) := osv$upper_to_lower ($INTEGER (field_name (i)) + 1);
          IFEND;
        FOREND /make_label/;

        put_string (label (1, label_size));

      PROCEND put_field_name_as_label;
?? TITLE := 'put_program_name', EJECT ??

      PROCEDURE put_program_name
        (    program_name: pmt$program_name;
             check_for_cobol_name: boolean;
             representation_option: clt$data_representation_option);

        VAR
          ignore_is_only_cobol_name: boolean,
          is_cobol_name: boolean,
          is_scl_name: boolean,
          name_size: ost$name_size,
          translated_name: ost$name;


        name_size := clp$trimmed_string_size (program_name);
        #TRANSLATE (osv$lower_to_upper, program_name, translated_name);
        IF program_name = translated_name THEN

          clp$validate_name (program_name, translated_name, is_scl_name);
          IF is_scl_name THEN
            put_string (program_name (1, name_size));
            RETURN;
          IFEND;

          IF check_for_cobol_name THEN
            clp$recognize_cobol_name (program_name, name_size, ignore_is_only_cobol_name, is_cobol_name);
            IF is_cobol_name THEN
              put_string (program_name (1, name_size));
              RETURN;
            IFEND;
          IFEND;

        IFEND;

        IF representation_option = clc$data_elem_representation THEN
          put_string (program_name (1, name_size));
        ELSE
          put_source_string (program_name (1, name_size));
        IFEND;

      PROCEND put_program_name;
?? TITLE := 'put_source_string', EJECT ??

      PROCEDURE put_source_string
        (    s: clt$string_value);

        VAR
          graphic: ost$string,
          i: clt$string_index,
          in_$char: boolean,
          in_string: boolean,
          previous_representation_option: clt$data_representation_option;


        IF STRLENGTH (s) = 0 THEN
          put_string ('''''');
          RETURN;
        IFEND;

        previous_representation_option := representation_option;
        representation_option := clc$data_source_representation;

        #SCAN (clv$non_graphic, s, i, in_$char);
        IF in_$char THEN
          put_string_translated ('$CHAR(');
        IFEND;

        in_string := FALSE;
        FOR i := 1 TO STRLENGTH (s) DO
          CASE s (i) OF

          = ' ' .. '~' =
            IF NOT in_string THEN
              IF (i > 1) AND in_$char THEN
                put_string (' ');
                set_secondary_break_position;
              IFEND;
              put_string ('''');
              in_string := TRUE;
            IFEND;
            IF s (i) = '''' THEN
              put_string ('''');
            IFEND;
            put_string (s (i));

          ELSE
            IF i > 1 THEN
              IF in_string THEN
                put_string ('''');
                in_string := FALSE;
              IFEND;
              put_string (' ');
              set_secondary_break_position;
            IFEND;
            clp$convert_char_to_graphic (s (i), graphic, status);
            IF NOT status.normal THEN
              EXIT clp$internal_convert_to_string;
            IFEND;
            put_string (graphic.value (1, graphic.size));
          CASEND;
        FOREND;

        IF in_string THEN
          put_string ('''');
        IFEND;

        IF in_$char THEN
          put_string (')');
        IFEND;

        representation_option := previous_representation_option;

      PROCEND put_source_string;
?? TITLE := 'put_status_code', EJECT ??

      PROCEDURE put_status_code
        (    is_status_code: boolean;
             code: ost$status_condition_code);

        VAR
          identifier_is_valid: boolean,
          name: ost$status_condition_name,
          name_is_valid: boolean,
          str: ost$string,
          validated_identifier: ost$name;

        name_is_valid := FALSE;
        IF is_status_code THEN
          osp$get_status_condition_name (code, name, status);
          IF status.normal AND (name <> 'UNKNOWN_CONDITION') THEN
            IF representation_option = clc$data_source_representation THEN
              put_trimmed_string (name);
              RETURN;
            IFEND;
            name_is_valid := TRUE;
          IFEND;
          status.normal := TRUE;
        IFEND;

        osp$get_status_condition_string (code, str, status);
        IF status.normal THEN
          clp$validate_name (str.value (1, STRLENGTH (ost$status_identifier)), validated_identifier,
                identifier_is_valid);
          IF NOT identifier_is_valid THEN
            str.size := 0;
          IFEND;
        ELSE
          status.normal := TRUE;
          str.size := 0;
        IFEND;

        IF str.size > 0 THEN
          IF representation_option = clc$data_source_representation THEN
            put_string ('''');
          IFEND;
          put_string (str.value (1, str.size));
          IF representation_option = clc$data_source_representation THEN
            put_string ('''');
          IFEND;
        ELSE
          put_integer (code);
        IFEND;

        IF name_is_valid THEN
          put_string (' "');
          put_string_translated (name);
          put_string ('"');
        IFEND;

      PROCEND put_status_code;
?? TITLE := 'put_type_name', EJECT ??

      PROCEDURE [INLINE] put_type_name;

        VAR
          name: clt$type_name;


        IF value^.kind <> clc$date_time THEN
          name := clv$type_kind_names [clv$value_type_kinds [value^.kind]];
        ELSEIF value^.date_time_value.date_specified AND value^.date_time_value.time_specified THEN
          name := 'DATE_TIME';
        ELSEIF value^.date_time_value.date_specified THEN
          name := 'DATE';
        ELSEIF value^.date_time_value.time_specified THEN
          name := 'TIME';
        ELSE
          name := 'UNRECOGNIZABLE_DATE_TIME_VALUE';
        IFEND;
        put_trimmed_string (name);

      PROCEND put_type_name;
?? TITLE := 'start_structure', EJECT ??

      PROCEDURE start_structure;


        put_string ('"');
        put_type_name;
        put_string ('"  ');

        indent_at_start_of_structure := indent_amount;
        increment_indent (structure_indentation);
        start_string;

      PROCEND start_structure;
?? OLDTITLE, EJECT ??

      IF value = NIL THEN
        IF convert_to_lower_case THEN
          put_string ('"uninitialized value"');
        ELSE
          put_string ('"UNINITIALIZED VALUE"');
        IFEND;
        RETURN;
      IFEND;

      WHILE TRUE DO
        CASE value^.kind OF
        = clc$application =
          convert_application_to_string;
        = clc$array =
          convert_array_to_string;
        = clc$boolean =
          convert_boolean_to_string;
        = clc$cobol_name =
          convert_cobol_name_to_string;
        = clc$command_reference =
          convert_command_ref_to_string;
        = clc$data_name =
          convert_data_name_to_string;
        = clc$date_time =
          convert_date_time_to_string;
        = clc$deferred =
          convert_deferred_val_to_string;
*IF NOT $true(osv$unix)
        = clc$entry_point_reference =
          convert_entry_point_ref_to_str;
*IFEND
*IF NOT $true(osv$unix)
        = clc$file =
*ELSE
        = clc$unix_file, clc$nos_ve_file =
*IFEND
          convert_file_to_string;
        = clc$integer =
          convert_integer_to_string;
        = clc$keyword =
          convert_keyword_to_string;
        = clc$list =
          convert_list_to_string;
        = clc$lock =
          convert_lock_to_string;
        = clc$name =
          convert_name_to_string;
        = clc$network_title =
          convert_network_title_to_string;
        = clc$program_name =
          convert_program_name_to_string;
        = clc$range =
          convert_range_to_string;
*IF NOT $true(osv$unix)
        = clc$real =
          convert_real_to_string;
*IFEND
        = clc$record =
          convert_record_to_string;
        = clc$scu_line_identifier =
          convert_scu_line_id_to_string;
        = clc$statistic_code =
          convert_statistic_code_to_str;
        = clc$status =
          convert_status_to_string;
        = clc$status_code =
          convert_status_code_to_string;
        = clc$string =
          convert_string_value_to_string;
        = clc$string_pattern =
          convert_string_pat_to_string;
        = clc$time_increment =
          convert_time_incr_to_string;
        = clc$time_zone =
          convert_time_zone_to_string;
        = clc$type_specification =
          convert_type_spec_to_string;
        = clc$unspecified =
          IF convert_to_lower_case THEN
            put_string ('"unspecified value"');
          ELSE
            put_string ('"UNSPECIFIED VALUE"');
          IFEND;
        ELSE
          IF convert_to_lower_case THEN
            put_string ('"unrecognizable value"');
          ELSE
            put_string ('"UNRECOGNIZABLE VALUE"');
          IFEND;
        CASEND;
        IF (representation_option <> clc$labeled_elem_representation) OR
              (level_of_nesting > 0) OR (NOT (value^.kind IN labeled_structures)) OR (NOT first_pass) THEN
          RETURN;
        IFEND;
        first_pass := FALSE;
      WHILEND;

    PROCEND convert_value_to_string;
?? TITLE := 'finish_representation', EJECT ??

    PROCEDURE finish_representation;

      VAR
*IF $true(osv$unix)
        kludge_data_representation: ^array [*] of cell,
*IFEND
        final_position: integer;


      IF string_started THEN
        finish_string;
      IFEND;

      final_position := i#current_sequence_position (work_area);
      RESET work_area TO string_count;
*IF $true(osv$unix)
      NEXT kludge_data_representation: [1 .. (final_position - i#current_sequence_position (work_area))] IN
            work_area;
      data_representation := #SEQ (kludge_data_representation^);
*ELSE
      NEXT data_representation: [[REP final_position - i#current_sequence_position (work_area) OF cell]] IN
            work_area;
*IFEND
      RESET data_representation;

    PROCEND finish_representation;
?? TITLE := 'finish_string', EJECT ??

    PROCEDURE finish_string;


      IF NOT string_started THEN
        RETURN;
      IFEND;

      IF string_may_be_trimmed THEN
        WHILE (string_size^ > 0) AND (string_ptr^ (string_size^) = ' ') DO
          string_size^ := string_size^ -1;
        WHILEND;
      IFEND;

      RESET work_area TO string_ptr;
      NEXT string_ptr: [string_size^] IN work_area;
      space_remaining := space_remaining - #SIZE (string_ptr^);

      string_started := FALSE;

    PROCEND finish_string;
?? TITLE := 'increment_indent', EJECT ??

    PROCEDURE [INLINE] increment_indent
      (    increment: clt$string_size);

      VAR
        max_indent_amount: clt$string_size;


      IF representation_option = clc$labeled_elem_representation THEN
        max_indent_amount := label_indent_limit;
      ELSE
        max_indent_amount := STRLENGTH (string_ptr^) DIV 2;
      IFEND;

      IF (indent_amount + increment) <= max_indent_amount THEN
        indent_amount := indent_amount + increment;
      ELSE
        indent_amount := max_indent_amount;
      IFEND;

    PROCEND increment_indent;
*IF NOT $true(osv$unix)
?? TITLE := 'put_evaluated_parameters', EJECT ??

    PROCEDURE put_evaluated_parameters
      (    initial_text: ^clt$command_line;
           include_secure_parameters: boolean;
           pdt: clt$unbundled_pdt;
           pvt: ^clt$parameter_value_table;
           parameter_substitutions: ^clt$parameter_substitutions);

      VAR
        first_parameter: boolean,
        parameter_number: clt$parameter_number,
        parameter_put: boolean,
        parameters_skipped: clt$parameter_count,
        sorted_substitutions: ^array [1 .. * ] of record
          case substitute: boolean of
          = TRUE =
            text: ^clt$expression_text,
          casend,
        recend,
        text: ^clt$expression_text,
        value: ^clt$data_value;

?? NEWTITLE := 'put_parameter', EJECT ??

      PROCEDURE put_parameter;

        VAR
          lower_case_name: ost$name;


        IF first_parameter THEN
          first_parameter := FALSE;
          IF pdt.header^.command_or_function = clc$function THEN
            put_string ('(');
            IF parameters_skipped > 0 THEN
              WHILE parameters_skipped > 1 DO
                put_string (',');
                parameters_skipped := parameters_skipped - 1;
              WHILEND;
              put_string (', ');
            IFEND;
          ELSEIF initial_text <> NIL THEN
            put_string (' ');
          IFEND;
        ELSE
          IF (pdt.header^.command_or_function = clc$function) AND (parameters_skipped > 0) THEN
            WHILE parameters_skipped >= 1 DO
              put_string (',');
              parameters_skipped := parameters_skipped - 1;
            WHILEND;
          IFEND;
          put_string (', ');
        IFEND;

        IF pdt.header^.command_or_function = clc$command THEN
          #TRANSLATE (osv$upper_to_lower, pdt.names^ [pdt.parameters^ [parameter_number].name_index].name,
                lower_case_name);
          put_trimmed_string (lower_case_name);
          put_string ('=');
        IFEND;

        IF value <> NIL THEN
          convert_value_to_string (value);
        ELSE
          put_string (text^);
        IFEND;

      PROCEND put_parameter;
?? TITLE := 'sort_parameter_substitutions', EJECT ??

      PROCEDURE [INLINE] sort_parameter_substitutions;

        VAR
          found: boolean,
          i: clt$parameter_name_index,
          index: clt$parameter_name_index;


        FOR i := 1 TO UPPERBOUND (sorted_substitutions^) DO
          sorted_substitutions^ [i].substitute := FALSE;
        FOREND;

        FOR i := 1 TO UPPERBOUND (parameter_substitutions^) DO
          clp$search_parameter_names (parameter_substitutions^ [i].name, pdt.names, index, found);
          IF NOT found THEN
            osp$set_status_abnormal ('CL', cle$unknown_parameter_name, parameter_substitutions^ [i].name,
                  status);
            EXIT put_evaluated_parameters;
          IFEND;
          sorted_substitutions^ [pdt.names^ [index].position].substitute := TRUE;
          sorted_substitutions^ [pdt.names^ [index].position].text := parameter_substitutions^ [i].text;
        FOREND

      PROCEND sort_parameter_substitutions;
?? OLDTITLE, EJECT ??

      IF initial_text <> NIL THEN
        put_trimmed_string (initial_text^);
      IFEND;

      IF pdt.header^.number_of_parameters > 0 THEN
        IF parameter_substitutions = NIL THEN
          sorted_substitutions := NIL;
        ELSE
          PUSH sorted_substitutions: [1 .. pdt.header^.number_of_parameters];
          sort_parameter_substitutions;
        IFEND;

        first_parameter := TRUE;
        parameter_put := FALSE;
        parameter_number := 1;
        parameters_skipped := 0;
        WHILE parameter_number <= pdt.header^.number_of_parameters DO
          text := NIL;
          value := NIL;
          IF (pdt.parameters^ [parameter_number].security = clc$non_secure_parameter) OR
                include_secure_parameters THEN
            IF (sorted_substitutions <> NIL) AND sorted_substitutions^ [parameter_number].substitute THEN
              text := sorted_substitutions^ [parameter_number].text;
            ELSEIF pvt^ [parameter_number].specified THEN
              IF pvt^ [parameter_number].passing_method = clc$pass_by_value THEN
                value := pvt^ [parameter_number].value;
              ELSE
                text := pvt^ [parameter_number].variable;
              IFEND;
            IFEND;
          IFEND;
          IF (value = NIL) AND (text = NIL) THEN
            parameters_skipped := parameters_skipped + 1;
          ELSE

            put_parameter;

            parameter_put := TRUE;
            parameters_skipped := 0;
          IFEND;
          parameter_number := parameter_number + 1;
        WHILEND;

        IF parameter_put AND (pdt.header^.command_or_function = clc$function) THEN
          put_string (')');
        IFEND;
      IFEND;

    PROCEND put_evaluated_parameters;
*IFEND
?? TITLE := 'put_file_reference', EJECT ??

    PROCEDURE put_file_reference
      (    file_reference: fst$file_reference);

      CONST
        first_character_of_full_path = ':';

      VAR
        file_path: ^fst$path;

*IF NOT $true(osv$unix)
      IF (STRLENGTH (file_reference) > 1) AND (file_reference (1) = first_character_of_full_path) THEN
*IFEND
        put_string_translated (file_reference);
*IF NOT $true(osv$unix)
      ELSE
        PUSH file_path;
        clp$get_path_name (file_reference, osc$full_message_level, file_path^);
        put_string_translated (file_path^);
      IFEND;
*IFEND

    PROCEND put_file_reference;
?? TITLE := 'put_integer', EJECT ??

    PROCEDURE put_integer
      (    int: integer);

      VAR
        str: ost$string;


      clp$convert_integer_to_string (int, 10, FALSE, str, status);
      IF NOT status.normal THEN
        EXIT clp$internal_convert_to_string;
      IFEND;
      put_string (str.value (1, str.size));

    PROCEND put_integer;
*IF NOT $true(osv$unix)
?? TITLE := 'put_old_pdt', EJECT ??

    PROCEDURE put_old_pdt
      (    multi_line_format: boolean;
           proc_or_pdt: ost$name;
           proc_names: clt$proc_names;
           pdt: clt$parameter_descriptor_table;
           symbolic_parameters: ^clt$symbolic_parameters);

      VAR
        lower_case_name: ost$name,
        parameter_name: clt$parameter_name,
        parameter_name_index: clt$parameter_name_index,
        parameter_number: clt$parameter_number,
        status_parameter_number: 0 .. clc$max_parameters;

?? NEWTITLE := 'put_parameter', EJECT ??

      PROCEDURE put_parameter
        (    parameter: clt$parameter_descriptor);

?? NEWTITLE := 'put_parameter_default', EJECT ??

        PROCEDURE put_parameter_default;

          VAR
            default_size: clt$expression_text_size,
            previous_indent_amount: clt$string_size;


          put_string (' = ');

          CASE parameter.required_or_optional.selector OF
          = clc$required =
            put_string ('$required');
            RETURN;
          = clc$optional =
            put_string ('$optional');
            RETURN;
          = clc$optional_with_default =
            ;
          ELSE
            put_string ('"UNRECOGNIZABLE DEFAULT OPTION" ');
            RETURN;
          CASEND;

          previous_indent_amount := indent_amount;
          default_size := STRLENGTH (parameter.required_or_optional.default^);

          IF default_size > 0 THEN
            IF multi_line_format AND ((string_size^ +default_size) > max_string) AND
                  (default_size <= (max_string - continuation_indentation)) THEN
              IF default_size > (max_string - indent_amount) THEN
                indent_amount := max_string - default_size;
              IFEND;
{ If the string size of the parameter name + string size of default parameter
{ value is greater than page width size specified on the command then break
{ the string appending the continuation marks.
              break_string;
            IFEND;
            put_string (parameter.required_or_optional.default^);
          IFEND;

          indent_amount := previous_indent_amount;

        PROCEND put_parameter_default;
?? TITLE := 'put_parameter_names', EJECT ??

        PROCEDURE put_parameter_names;

          VAR
            lower_case_name: ost$name,
            i: 1 .. clc$max_parameter_names + 1;


          i := parameter_name_index;
          REPEAT
            #TRANSLATE (osv$upper_to_lower, pdt.names^ [i].name, lower_case_name);
            IF i = parameter_name_index THEN
              parameter_name := pdt.names^ [i].name;
            ELSE
              put_string (', ');
            IFEND;
            put_trimmed_string (lower_case_name);
            i := i + 1;
          UNTIL NOT ((i <= UPPERBOUND (pdt.names^)) AND (pdt.names^ [i].number = parameter_number));
          parameter_name_index := i;

        PROCEND put_parameter_names;
?? OLDTITLE, EJECT ??

        VAR
          i: 1 .. clc$max_keyword_values,
          list_specified: boolean,
          max_qualifier_text: ^string ( * ),
          max_value_sets_text: ^string ( * ),
          max_values_per_set_text: ^string ( * ),
          min_qualifier_text: ^string ( * ),
          min_value_sets_text: ^string ( * ),
          min_values_per_set_text: ^string ( * ),
          previous_indent_amount: clt$string_size,
          separator: ^separator_string,
          sub_list_specified: boolean;


        IF multi_line_format THEN
          previous_indent_amount := indent_amount;
          increment_indent (continuation_indentation);
        IFEND;

        put_parameter_names;

        IF (parameter_name = 'STATUS') AND (parameter.value_kind_specifier.kind = clc$variable_reference) AND
              (parameter.value_kind_specifier.variable_kind = clc$status_value) THEN
          status_parameter_number := parameter_number;
          RETURN;
        IFEND;

        put_string (': ');

        IF multi_line_format THEN
          indent_amount := previous_indent_amount;
          increment_indent (nesting_indentation);
        IFEND;

        IF symbolic_parameter = NIL THEN
          min_value_sets_text := NIL;
          max_value_sets_text := NIL;
          min_values_per_set_text := NIL;
          max_values_per_set_text := NIL;
          min_qualifier_text := NIL;
          max_qualifier_text := NIL;
        ELSE
          min_value_sets_text := symbolic_parameter^.min_value_sets;
          max_value_sets_text := symbolic_parameter^.max_value_sets;
          min_values_per_set_text := symbolic_parameter^.min_values_per_set;
          max_values_per_set_text := symbolic_parameter^.max_values_per_set;
          min_qualifier_text := symbolic_parameter^.value_kind_qualifier_low;
          max_qualifier_text := symbolic_parameter^.value_kind_qualifier_high;
        IFEND;

        sub_list_specified := (parameter.max_values_per_set > 1) OR (max_values_per_set_text <> NIL);
        IF (parameter.max_value_sets > 1) OR (parameter.max_values_per_set > 1) OR
              (max_value_sets_text <> NIL) OR sub_list_specified THEN
          put_string ('list');
          IF (parameter.min_value_sets > 1) OR (parameter.max_value_sets < clc$max_value_sets) OR
                (max_value_sets_text <> NIL) OR sub_list_specified THEN
            put_string (' ');
            IF min_value_sets_text <> NIL THEN
              put_string (min_value_sets_text^);
            ELSEIF parameter.min_value_sets = clc$max_value_sets THEN
              put_string ('$max_value_sets');
            ELSE
              put_integer (parameter.min_value_sets);
            IFEND;

            IF (parameter.max_value_sets <> parameter.min_value_sets) OR
                  (max_value_sets_text <> min_value_sets_text) THEN
              put_string ('..');
              IF max_value_sets_text <> NIL THEN
                put_string (max_value_sets_text^);
              ELSEIF parameter.max_value_sets = clc$max_value_sets THEN
                put_string ('$max_value_sets');
              ELSE
                put_integer (parameter.max_value_sets);
              IFEND;
            IFEND;
          IFEND;

          IF (parameter.max_values_per_set > 1) OR (max_values_per_set_text <> NIL) THEN
            put_string (', ');
            IF min_values_per_set_text <> NIL THEN
              put_string (min_values_per_set_text^);
            ELSEIF parameter.min_values_per_set = clc$max_values_per_set THEN
              put_string ('$max_values');
            ELSE
              put_integer (parameter.min_values_per_set);
            IFEND;

            IF (parameter.max_values_per_set <> parameter.min_values_per_set) OR
                  (max_values_per_set_text <> min_values_per_set_text) THEN
              put_string ('..');
              IF max_values_per_set_text <> NIL THEN
                put_string (max_values_per_set_text^);
              ELSEIF parameter.max_values_per_set = clc$max_values_per_set THEN
                put_string ('$max_values');
              ELSE
                put_integer (parameter.max_values_per_set);
              IFEND;
            IFEND;
          IFEND;

          IF parameter.value_range_allowed = clc$value_range_allowed THEN
            put_string (' range of ');
          ELSE
            put_string (' of ');
          IFEND;
          set_break_position;

        ELSEIF parameter.value_range_allowed = clc$value_range_allowed THEN
          put_string ('range of ');
          set_break_position;
        IFEND;

        CASE parameter.value_kind_specifier.kind OF

        = clc$keyword_value =
          { handled below } ;

        = clc$any_value =
          put_string ('any');

        = clc$variable_reference =
          IF parameter.value_kind_specifier.array_allowed = clc$array_allowed THEN
            put_string ('array of ');
          ELSE
            put_string ('var of ');
          IFEND;
          set_break_position;
          CASE parameter.value_kind_specifier.variable_kind OF
          = clc$string_value =
            put_string ('string');
          = clc$real_value =
            put_string ('real');
          = clc$integer_value =
            put_string ('integer');
          = clc$boolean_value =
            put_string ('boolean');
          = clc$status_value =
            put_string ('status');
          = clc$any_value =
            put_string ('any');
          ELSE
            put_string ('BAD VARIABLE KIND');
          CASEND;

        = clc$application_value =
          #TRANSLATE (osv$upper_to_lower, parameter.value_kind_specifier.value_name, lower_case_name);
          put_trimmed_string (lower_case_name);
          CASE parameter.value_kind_specifier.scanner.kind OF
          = clc$unlinked_av_scanner =
            #TRANSLATE (osv$upper_to_lower, parameter.value_kind_specifier.scanner.name, lower_case_name);
            put_string (' ');
            put_trimmed_string (lower_case_name);
          ELSE
           ;
          CASEND;

        = clc$file_value =
          put_string ('file');

        = clc$name_value =
          put_string ('name');
          IF (parameter.value_kind_specifier.min_name_size > 1) OR
                (parameter.value_kind_specifier.max_name_size < osc$max_name_size) OR
                (max_qualifier_text <> NIL) THEN
            put_string (' ');
            IF min_qualifier_text <> NIL THEN
              IF min_qualifier_text <> max_qualifier_text THEN
                put_string (min_qualifier_text^);
              ELSE
                put_string ('1');
              IFEND;
            ELSEIF parameter.value_kind_specifier.min_name_size = osc$max_name_size THEN
              put_string ('$max_name');
            ELSE
              put_integer (parameter.value_kind_specifier.min_name_size);
            IFEND;
            put_string ('..');
            IF max_qualifier_text <> NIL THEN
              put_string (max_qualifier_text^);
            ELSEIF parameter.value_kind_specifier.max_name_size = osc$max_name_size THEN
              put_string ('$max_name');
            ELSE
              put_integer (parameter.value_kind_specifier.max_name_size);
            IFEND;
          IFEND;

        = clc$string_value =
          put_string ('string');
          IF (parameter.value_kind_specifier.min_string_size > 0) OR
                (parameter.value_kind_specifier.max_string_size < osc$max_string_size) OR
                (max_qualifier_text <> NIL) THEN
            put_string (' ');
            IF min_qualifier_text <> NIL THEN
              put_string (min_qualifier_text^);
            ELSE
              put_integer (parameter.value_kind_specifier.min_string_size);
            IFEND;

            IF (parameter.value_kind_specifier.max_string_size <>
                  parameter.value_kind_specifier.min_string_size) OR
                  (max_qualifier_text <> min_qualifier_text) THEN
              put_string ('..');
              IF max_qualifier_text <> NIL THEN
                put_string (max_qualifier_text^);
              ELSE
                put_integer (parameter.value_kind_specifier.max_string_size);
              IFEND;
            IFEND;
          IFEND;

        = clc$integer_value =
          put_string ('integer');
          IF (parameter.value_kind_specifier.min_integer_value > clc$min_integer) OR
                (parameter.value_kind_specifier.max_integer_value < clc$max_integer) OR
                (max_qualifier_text <> NIL) THEN
            put_string (' ');
            IF min_qualifier_text <> NIL THEN
              put_string (min_qualifier_text^);
            ELSEIF parameter.value_kind_specifier.min_integer_value = clc$min_integer THEN
              put_string ('$min_integer');
            ELSE
              put_integer (parameter.value_kind_specifier.min_integer_value);
            IFEND;
            put_string ('..');
            IF max_qualifier_text <> NIL THEN
              put_string (max_qualifier_text^);
            ELSEIF parameter.value_kind_specifier.max_integer_value = clc$max_integer THEN
              put_string ('$max_integer');
            ELSE
              put_integer (parameter.value_kind_specifier.max_integer_value);
            IFEND;
          IFEND;

        = clc$real_value =
          put_string ('real');

        = clc$boolean_value =
          put_string ('boolean');

        = clc$status_value =
          put_string ('status');

        ELSE
          put_string ('"BAD VALUE KIND"');
        CASEND;

        IF parameter.value_kind_specifier.keyword_values <> NIL THEN
          #TRANSLATE (osv$upper_to_lower, parameter.value_kind_specifier.keyword_values^ [1],
                lower_case_name);
          IF parameter.value_kind_specifier.kind <> clc$keyword_value THEN
            put_string (' or ');
            set_break_position;
          IFEND;
          put_string ('key ');
          put_trimmed_string (lower_case_name);
          FOR i := 2 TO UPPERBOUND (parameter.value_kind_specifier.keyword_values^) DO
            #TRANSLATE (osv$upper_to_lower, parameter.value_kind_specifier.keyword_values^ [i],
                  lower_case_name);
            put_string (', ');
            put_trimmed_string (lower_case_name);
          FOREND;
        IFEND;

        put_parameter_default;

        IF multi_line_format THEN
          indent_amount := previous_indent_amount
        IFEND;

      PROCEND put_parameter;
?? TITLE := 'put_pdt_names', EJECT ??

      PROCEDURE put_pdt_names;

        VAR
          index: 1 .. clc$max_proc_names;


        #TRANSLATE (osv$upper_to_lower, proc_names [1], lower_case_name);
        put_trimmed_string (lower_case_name);

        FOR index := 2 TO UPPERBOUND (proc_names) DO
          put_string (', ');

          #TRANSLATE (osv$upper_to_lower, proc_names [index], lower_case_name);
          put_trimmed_string (lower_case_name);
        FOREND;

      PROCEND put_pdt_names;
?? OLDTITLE, EJECT ??

      VAR
        previous_indent_amount: clt$string_size,
        symbolic_parameter: ^clt$symbolic_parameter;


      IF multi_line_format THEN
        start_string;
        previous_indent_amount := indent_amount;
        increment_indent (continuation_indentation);
      IFEND;

      IF proc_or_pdt <> osc$null_name THEN
        put_trimmed_string (proc_or_pdt);
        put_string (' ');
      IFEND;

      put_pdt_names;

      IF pdt.parameters <> NIL THEN
        put_string (' (');

        IF multi_line_format THEN
          indent_amount := previous_indent_amount;
          increment_indent (nesting_indentation);
        IFEND;

        status_parameter_number := 0;
        parameter_name_index := 1;

      /put_parameters/
        FOR parameter_number := 1 TO UPPERBOUND (pdt.parameters^) DO
          IF multi_line_format THEN
            start_string;
          ELSEIF parameter_number > 1 THEN
            put_string ('; ');
          IFEND;

          IF symbolic_parameters = NIL THEN
            symbolic_parameter := NIL;
          ELSE
            symbolic_parameter := ^symbolic_parameters^ [parameter_number];
          IFEND;
          put_parameter (pdt.parameters^ [parameter_number]);
        FOREND /put_parameters/;

        IF multi_line_format AND (status_parameter_number <> UPPERBOUND (pdt.parameters^)) THEN
          start_string;
        IFEND;

        put_string (')');
      IFEND;

      IF multi_line_format THEN
        indent_amount := previous_indent_amount;
        finish_string;
      IFEND;

    PROCEND put_old_pdt;
*IFEND
?? TITLE := 'put_pdt', EJECT ??

    PROCEDURE put_pdt
      (    multi_line_format: boolean;
           parameter_starts_line: boolean;
           individual_parameter: boolean;
           individual_parameter_number: clt$parameter_number;
           include_header: boolean;
           include_implementation_info: boolean;
           command_or_function_name: pmt$program_name;
           aliases: ^array [1 .. * ] of pmt$program_name;
           availability: clt$named_entry_availability;
           command_or_function_scope: clt$command_or_function_scope;
           pdt: clt$unbundled_pdt;
           pvt: ^clt$parameter_value_table);

      VAR
        lower_case_name: ost$name,
        parameter_number: clt$parameter_number;

?? NEWTITLE := 'put_parameter', EJECT ??

      PROCEDURE put_parameter;

?? NEWTITLE := 'put_parameter_attributes', EJECT ??

        PROCEDURE put_parameter_attributes;

          VAR
            separator: ^separator_string;


          separator := ^left_parenthesis;

          IF pdt.parameters^ [parameter_number].passing_method = clc$pass_by_reference THEN
            put_string (separator^);
            separator := ^comma;
            put_string ('VAR');
          IFEND;

          IF NOT (clc$specify_positionally IN pdt.parameters^ [parameter_number].specification_methods) THEN
            put_string (separator^);
            separator := ^comma;
            put_string ('BY_NAME');
          IFEND;

          IF include_implementation_info AND (pdt.parameters^ [parameter_number].evaluation_method =
                clc$deferred_evaluation) THEN
            put_string (separator^);
            separator := ^comma;
            put_string ('DEFER');
          IFEND;

          IF include_implementation_info AND (pdt.parameters^ [parameter_number].checking_level =
                clc$extended_parameter_checking) THEN
            put_string (separator^);
            separator := ^comma;
            put_string ('CHECK');
          IFEND;

          CASE pdt.parameters^ [parameter_number].availability OF
          = clc$advanced_usage_entry =
            put_string (separator^);
            separator := ^comma;
            put_string ('ADVANCED');
          = clc$hidden_entry =
            put_string (separator^);
            separator := ^comma;
            put_string ('HIDDEN');
          ELSE
            ;
          CASEND;

          IF pdt.parameters^ [parameter_number].security = clc$secure_parameter THEN
            put_string (separator^);
            separator := ^comma;
            put_string ('SECURE');
          IFEND;

          IF pdt.type_descriptions^ [parameter_number].name <> NIL THEN
            put_string (separator^);
            separator := ^comma;
            #TRANSLATE (osv$upper_to_lower, pdt.type_descriptions^ [parameter_number].name^, lower_case_name);
            put_string (lower_case_name (1, STRLENGTH (pdt.type_descriptions^ [parameter_number].name^)));
          IFEND;

          IF separator = ^comma THEN
            put_string (') ');
          IFEND;

        PROCEND put_parameter_attributes;
?? TITLE := 'put_parameter_default', EJECT ??

        PROCEDURE put_parameter_default;

          VAR
            default_size: clt$expression_text_size,
            previous_indent_amount: clt$string_size,
            use_parameter_value: boolean;


          previous_indent_amount := indent_amount;

          put_string (' = ');

          IF pvt = NIL THEN
            use_parameter_value := FALSE;
          ELSEIF pvt^ [parameter_number].passing_method = clc$pass_by_value THEN
            use_parameter_value := pvt^ [parameter_number].value <> NIL;
          ELSE { pvt^ [parameter_number].passing_method = clc$pass_by_reference
            use_parameter_value := pvt^ [parameter_number].variable <> NIL;
          IFEND;

          IF use_parameter_value THEN
            IF pvt^ [parameter_number].passing_method = clc$pass_by_value THEN
              convert_value_to_string (pvt^ [parameter_number].value);
            ELSE { pvt^ [parameter_number].passing_method = clc$pass_by_reference
              put_string (pvt^ [parameter_number].variable^);
            IFEND;
          ELSE
            CASE pdt.parameters^ [parameter_number].requirement OF
            = clc$required_parameter =
              put_string ('$required');
              RETURN;
            = clc$optional_parameter =
              put_string ('$optional');
              RETURN;
            = clc$optional_default_parameter =
              ;
            = clc$confirm_default_parameter =
              put_string ('$confirm ');
            ELSE
              put_string ('"UNRECOGNIZABLE DEFAULT OPTION" ');
            CASEND;

            IF pdt.parameters^ [parameter_number].default_name_size > 0 THEN
*IF $true(osv$unix)
              put_trimmed_string (pdt.default_names^ [parameter_number]^);
*ELSE
              #TRANSLATE (osv$upper_to_lower, pdt.default_names^ [parameter_number]^, lower_case_name);
              put_trimmed_string (lower_case_name);
*IFEND
              put_string (', ');
            IFEND;

            default_size := pdt.parameters^ [parameter_number].default_value_size;

            IF default_size > 0 THEN
              IF multi_line_format AND ((string_size^ +default_size) > max_string) AND
                    (default_size <= (max_string - continuation_indentation)) THEN
                IF default_size > (max_string - indent_amount) THEN
                  indent_amount := max_string - default_size;
                IFEND;
                start_string;
              IFEND;
              put_string (pdt.default_values^ [parameter_number]^);
            IFEND;
          IFEND;

          indent_amount := previous_indent_amount;

        PROCEND put_parameter_default;
?? TITLE := 'put_parameter_names', EJECT ??

        PROCEDURE put_parameter_names;

          VAR
            abbreviation_index: clt$parameter_name_count,
            alias_count: clt$parameter_name_count,
            alias_index: clt$parameter_name_count,
            index: clt$parameter_name_index,
            nominal_index: clt$parameter_name_count;


          nominal_index := 0;
          alias_count := 0;
          alias_index := 0;
          abbreviation_index := 0;

        /search_for_number/
          FOR index := 1 TO UPPERBOUND (pdt.names^) DO
            IF pdt.names^ [index].position = parameter_number THEN
              CASE pdt.names^ [index].class OF

              = clc$nominal_entry =
                IF nominal_index = 0 THEN
                  nominal_index := index;
                ELSE
                  put_string ('"DUPLICATE NOMINAL PARAMETER NAME"');
                  EXIT put_pdt;
                IFEND;

              = clc$alias_entry =
                IF alias_index = 0 THEN
                  alias_index := index;
                IFEND;
                alias_count := alias_count + 1;

              = clc$abbreviation_entry =
                IF abbreviation_index = 0 THEN
                  abbreviation_index := index;
                ELSE
                  put_string ('"DUPLICATE PARAMETER ABBREVIATION"');
                  EXIT put_pdt;
                IFEND;

              ELSE
                put_string ('"BAD PARAMETER NAME DESCRIPTION"');
                EXIT put_pdt;
              CASEND;
            IFEND;
          FOREND /search_for_number/;

          IF nominal_index = 0 THEN
            put_string ('"MISSING PARAMETER NAME"');
            EXIT put_pdt;
          IFEND;

          #TRANSLATE (osv$upper_to_lower, pdt.names^ [nominal_index].name, lower_case_name);
          put_trimmed_string (lower_case_name);

          IF alias_index > 0 THEN

          /put_alias/
            FOR index := alias_index TO pdt.header^.number_of_parameter_names DO
              IF (pdt.names^ [index].position = parameter_number) AND
                    (pdt.names^ [index].class = clc$alias_entry) THEN
                put_string (', ');
                #TRANSLATE (osv$upper_to_lower, pdt.names^ [index].name, lower_case_name);
                put_trimmed_string (lower_case_name);
                IF alias_count <= 1 THEN
                  EXIT /put_alias/;
                IFEND;
                alias_count := alias_count - 1;
              IFEND;
            FOREND /put_alias/;
          IFEND;

          IF abbreviation_index > 0 THEN
            put_string (', ');
            #TRANSLATE (osv$upper_to_lower, pdt.names^ [abbreviation_index].name, lower_case_name);
            put_trimmed_string (lower_case_name);
          IFEND;

        PROCEND put_parameter_names;
?? OLDTITLE, EJECT ??

        VAR
          previous_indent_amount: clt$string_size,
          separator: ^separator_string;


        IF multi_line_format OR parameter_starts_line THEN
          previous_indent_amount := indent_amount;
          increment_indent (continuation_indentation);
        IFEND;

        put_parameter_names;

        IF (parameter_number <> pdt.header^.status_parameter_number) OR (NOT include_implementation_info) THEN
          put_string (': ');

          put_parameter_attributes;

          IF multi_line_format THEN
            indent_amount := previous_indent_amount;
            increment_indent (nesting_indentation);
          IFEND;

          put_type (TRUE, include_implementation_info, multi_line_format,
                pdt.type_descriptions^ [parameter_number]);

          put_parameter_default;
        IFEND;

        IF multi_line_format OR parameter_starts_line THEN
          indent_amount := previous_indent_amount
        IFEND;

      PROCEND put_parameter;
?? TITLE := 'put_pdt_header', EJECT ??

      PROCEDURE put_pdt_header;

        VAR
          include_help_module_name: boolean,
          separator: ^separator_string;


        IF pdt.header^.command_or_function = clc$command THEN
          put_string ('PROCEDURE ');
        ELSE
          put_string ('FUNCTION ');
        IFEND;

        separator := ^left_parenthesis;

        CASE command_or_function_scope OF
        = clc$local_command_or_function =
          put_string (separator^);
          separator := ^comma;
          put_string ('LOCAL');
        = clc$gate_command_or_function =
          put_string (separator^);
          separator := ^comma;
          put_string ('GATE');
        = clc$xdcl_command_or_function =
          ;
        ELSE
          put_string (separator^);
          separator := ^comma;
          put_string ('UNRECOGNIZABLE_SCOPE');
        CASEND;

        CASE availability OF
        = clc$advanced_usage_entry =
          put_string (separator^);
          separator := ^comma;
          put_string ('ADVANCED');
        = clc$hidden_entry =
          put_string (separator^);
          separator := ^comma;
          put_string ('HIDDEN');
        ELSE
          ;
        CASEND;

        IF pdt.header^.help_module_name = osc$null_name THEN
          include_help_module_name := FALSE;
        ELSEIF aliases <> NIL THEN
          include_help_module_name := pdt.header^.help_module_name <> aliases^ [UPPERBOUND (aliases^)];
        ELSE
          include_help_module_name := pdt.header^.help_module_name <> command_or_function_name;
        IFEND;
        IF include_help_module_name THEN
          put_string (separator^);
          separator := ^comma;
          #TRANSLATE (osv$upper_to_lower, pdt.header^.help_module_name, lower_case_name);
          put_trimmed_string (lower_case_name);
        IFEND;

        IF separator = ^comma THEN
          put_string (') ');
        IFEND;

      PROCEND put_pdt_header;
?? TITLE := 'put_pdt_names', EJECT ??

      PROCEDURE put_pdt_names;

        VAR
          index: 1 .. clc$max_proc_names;


        #TRANSLATE (osv$upper_to_lower, command_or_function_name, lower_case_name);
        put_trimmed_string (lower_case_name);

        IF aliases <> NIL THEN
          FOR index := 1 TO UPPERBOUND (aliases^) DO
            put_string (', ');

            #TRANSLATE (osv$upper_to_lower, aliases^ [index], lower_case_name);
            put_trimmed_string (lower_case_name);
          FOREND;
        IFEND;

      PROCEND put_pdt_names;
?? OLDTITLE, EJECT ??

      VAR
        previous_indent_amount: clt$string_size;


      IF multi_line_format OR parameter_starts_line THEN
        start_string;
        previous_indent_amount := indent_amount;
        increment_indent (continuation_indentation);
      IFEND;

      IF individual_parameter THEN
        parameter_number := individual_parameter_number;
        put_parameter;
      ELSE

        IF include_header THEN
          put_pdt_header;
        IFEND;

        IF command_or_function_name <> osc$null_name THEN
          put_pdt_names;
        IFEND;

        IF pdt.header^.number_of_parameters > 0 THEN
          IF command_or_function_name <> osc$null_name THEN
            put_string (' (');
            IF multi_line_format OR parameter_starts_line THEN
              indent_amount := previous_indent_amount;
              increment_indent (nesting_indentation);
              start_string;
            IFEND;
          ELSEIF multi_line_format OR parameter_starts_line THEN
            indent_amount := previous_indent_amount;
          IFEND;

        /put_parameters/
          FOR parameter_number := 1 TO pdt.header^.number_of_parameters DO

            CASE pdt.parameters^ [parameter_number].availability OF
            = clc$advanced_usage_entry =
              IF NOT include_advanced_items THEN
                CYCLE /put_parameters/;
              IFEND;
            = clc$hidden_entry =
              IF NOT include_hidden_items THEN
                CYCLE /put_parameters/;
              IFEND;
            ELSE
              ;
            CASEND;

            IF parameter_number > 1 THEN
              IF multi_line_format OR parameter_starts_line THEN
                start_string;
              ELSE
                put_string ('; ');
              IFEND;
            IFEND;

            put_parameter;
          FOREND /put_parameters/;

          IF command_or_function_name <> osc$null_name THEN
            IF multi_line_format AND (pdt.header^.status_parameter_number <> pdt.header^.number_of_parameters)
                  THEN
              start_string;
            IFEND;
            put_string (')');
          IFEND;
        IFEND;
      IFEND;

      IF multi_line_format THEN
        indent_amount := previous_indent_amount;
        finish_string;
      IFEND;

    PROCEND put_pdt;
*IF NOT $true(osv$unix)
?? TITLE := 'put_real', EJECT ??

    PROCEDURE put_real
      (    real_number: longreal);

      VAR
        str: ost$string;


      clp$convert_real_to_string (real_number, clc$max_real_number_digits, str, status);
      IF NOT status.normal THEN
        EXIT clp$internal_convert_to_string;
      IFEND;
      put_string (str.value (1, str.size));

    PROCEND put_real;
*IFEND
?? TITLE := 'put_string', EJECT ??

    PROCEDURE put_string
      (    s: clt$string_value);

      VAR
        i: clt$string_index,
        truncate_leading_spaces: boolean;

      IF STRLENGTH (s) = 0 THEN
        IF NOT string_started THEN
          start_string;
        IFEND;
        RETURN;
      IFEND;

      truncate_leading_spaces := FALSE;
      FOR i := 1 TO STRLENGTH (s) DO
        IF NOT string_started THEN
          start_string;
        ELSEIF string_size^ >= STRLENGTH (string_ptr^) THEN
          IF STRLENGTH (string_ptr^) < max_string THEN
            work_area_overflow;
          IFEND;
          break_string;
          truncate_leading_spaces := indent_amount > 0;
        IFEND;

        string_size^ := string_size^ +1;
        CASE s (i) OF

        = $CHAR (0) .. $CHAR (31), $CHAR (127) =
          IF clv$retain_unprintable_char THEN
            string_ptr^ (string_size^) := s (i);
          ELSE
            string_ptr^ (string_size^) := '?';
          IFEND;
          IF NOT break_pending THEN
            IF representation_option = clc$data_source_representation THEN
              IF string_size^ < (STRLENGTH (string_ptr^) - continuation_size) THEN
                break.index := string_size^;
                break.mark_continuation := TRUE;
                break.indent := indent_amount;
              IFEND;
            ELSE
              IF string_size^ < STRLENGTH (string_ptr^) THEN
                break.index := string_size^;
                break.mark_continuation := FALSE;
                break.indent := indent_amount;
              IFEND;
            IFEND;
          IFEND;

        = 'A' .. 'Z', 'a' .. 'z', '0' .. '9', '$', '#', '@', '[', '\', ']', '^', '`', '{', '|', '}', '~' =
          string_ptr^ (string_size^) := s (i);

        = '_', '.', '(', ':' =
          string_ptr^ (string_size^) := s (i);
          IF NOT secondary_break_pending THEN
            secondary_break.index := string_size^;
            secondary_break.mark_continuation := (representation_option = clc$data_source_representation);
            secondary_break.indent := indent_amount;
          IFEND;

        ELSE
          IF (s(i) = ' ') AND truncate_leading_spaces AND (string_ptr^ (string_size^ - 1) = ' ') THEN
            string_size^ := string_size^ - 1;
          ELSE
            string_ptr^ (string_size^) := s (i);
            IF NOT break_pending THEN
              IF representation_option = clc$data_source_representation THEN
                IF string_size^ < (STRLENGTH (string_ptr^) - continuation_size) THEN
                  break.index := string_size^;
                  break.mark_continuation := TRUE;
                  break.indent := indent_amount;
                IFEND;
              ELSE
                IF string_size^ < STRLENGTH (string_ptr^) THEN
                  break.index := string_size^;
                  break.mark_continuation := FALSE;
                  break.indent := indent_amount;
                IFEND;
              IFEND;
            IFEND;
          IFEND;

        CASEND;
      FOREND;

      string_may_be_trimmed := TRUE;

    PROCEND put_string;
?? TITLE := 'put_string_translated', EJECT ??

    PROCEDURE [INLINE] put_string_translated
      (    s: clt$string_value);

      VAR
        size: clt$string_size,
        translated_string: ^clt$string_value;

      size := STRLENGTH (s);
      WHILE (size > 0) AND (s (size) = ' ') DO
        size := size - 1;
      WHILEND;
      translated_string := ^s (1, size);

      IF convert_to_lower_case THEN
        PUSH translated_string: [size];
        #TRANSLATE (osv$upper_to_lower, s (1, size), translated_string^);
      IFEND;

      put_string (translated_string^);

    PROCEND put_string_translated;
?? TITLE := 'put_trimmed_string', EJECT ??

    PROCEDURE [INLINE] put_trimmed_string
      (    s: clt$string_value);

      VAR
        size: clt$string_size;


      size := STRLENGTH (s);
      WHILE (size > 0) AND (s (size) = ' ') DO
        size := size - 1;
      WHILEND;

      put_string (s (1, size));

    PROCEND put_trimmed_string;
?? TITLE := 'put_type', EJECT ??

    PROCEDURE put_type
      (    parameter_type: boolean;
           include_implementation_info: boolean;
           multi_line_format: boolean;
           type_description: clt$type_description);

?? NEWTITLE := 'put_application_type', EJECT ??

      PROCEDURE put_application_type;


        put_string ('application');
        IF type_description.balance_brackets THEN
          put_string (' balance_brackets');
        IFEND;

      PROCEND put_application_type;
?? TITLE := 'put_array_type', EJECT ??

      PROCEDURE put_array_type;

        VAR
          lowerbound_text: ^clt$expression_text,
          symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier,
          upperbound_text: ^clt$expression_text;


        put_string ('array');

        IF type_description.array_bounds_defined THEN
          IF symbolic_qualifiers_work_area = NIL THEN
            lowerbound_text := NIL;
            upperbound_text := NIL;
          ELSE
            NEXT symbolic_subrange_qualifier IN symbolic_qualifiers_work_area;
            IF symbolic_subrange_qualifier^.low_text_size = 0 THEN
              lowerbound_text := NIL;
            ELSE
              NEXT lowerbound_text: [symbolic_subrange_qualifier^.low_text_size] IN
                    symbolic_qualifiers_work_area;
            IFEND;
            IF symbolic_subrange_qualifier^.high_text_size = 0 THEN
              upperbound_text := lowerbound_text;
            ELSE
              NEXT upperbound_text: [symbolic_subrange_qualifier^.high_text_size] IN
                    symbolic_qualifiers_work_area;
            IFEND;
          IFEND;

          put_string (' ');

          IF lowerbound_text <> NIL THEN
            put_string (lowerbound_text^);
          ELSE
            put_integer (type_description.bounds.lower);
          IFEND;

          put_string ('..');

          IF upperbound_text <> NIL THEN
            put_string (upperbound_text^);
          ELSE
            put_integer (type_description.bounds.upper);
          IFEND;
        IFEND;

        IF type_description.array_element_type_description <> NIL THEN
          put_string (' of ');
          set_break_position;
          put_type (FALSE, include_implementation_info, multi_line_format,
                type_description.array_element_type_description^);
        IFEND;

      PROCEND put_array_type;
?? TITLE := 'put_date_time_type', EJECT ??

      PROCEDURE put_date_time_type;

        VAR
          separator: ^separator_string;


        IF type_description.date_and_or_time = $clt$date_and_or_time [clc$date, clc$time] THEN
          put_string ('date_time');
        ELSEIF type_description.date_and_or_time = $clt$date_and_or_time [clc$date] THEN
          put_string ('date');
        ELSEIF type_description.date_and_or_time = $clt$date_and_or_time [clc$time] THEN
          put_string ('time');
        ELSE
          put_string ('UNRECOGNIZABLE_DATE_TIME_TYPE');
        IFEND;

        IF type_description.tenses <> $clt$date_time_tenses [clc$past, clc$present, clc$future] THEN
          separator := ^space;

          IF clc$past IN type_description.tenses THEN
            put_string (separator^);
            separator := ^comma;
            put_string ('past');
          IFEND;
          IF clc$present IN type_description.tenses THEN
            put_string (separator^);
            separator := ^comma;
            put_string ('present');
          IFEND;
          IF clc$future IN type_description.tenses THEN
            put_string (separator^);
            separator := ^comma;
            put_string ('future');
          IFEND;
        IFEND;

      PROCEND put_date_time_type;
?? TITLE := 'put_integer_type', EJECT ??

      PROCEDURE put_integer_type;

        CONST
          default_radix = 10;

        VAR
          max_integer_text: ^clt$expression_text,
          min_integer_text: ^clt$expression_text,
          symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier;


        IF symbolic_qualifiers_work_area = NIL THEN
          min_integer_text := NIL;
          max_integer_text := NIL;
        ELSE
          NEXT symbolic_subrange_qualifier IN symbolic_qualifiers_work_area;
          IF symbolic_subrange_qualifier^.low_text_size = 0 THEN
            min_integer_text := NIL;
          ELSE
            NEXT min_integer_text: [symbolic_subrange_qualifier^.low_text_size] IN
                  symbolic_qualifiers_work_area;
          IFEND;
          IF symbolic_subrange_qualifier^.high_text_size = 0 THEN
            max_integer_text := min_integer_text;
          ELSE
            NEXT max_integer_text: [symbolic_subrange_qualifier^.high_text_size] IN
                  symbolic_qualifiers_work_area;
          IFEND;
        IFEND;

        put_string ('integer');

        IF (min_integer_text <> NIL) OR (max_integer_text <> NIL) OR
              (type_description.min_integer_value > clc$min_integer) OR
              (type_description.max_integer_value < clc$max_integer) THEN
          put_string (' ');

          IF min_integer_text <> NIL THEN
            put_string (min_integer_text^);
          ELSEIF type_description.min_integer_value = clc$min_integer THEN
            put_string ('$min_integer');
          ELSEIF type_description.min_integer_value = clc$max_integer THEN
            put_string ('$max_integer');
          ELSE
            put_integer (type_description.min_integer_value);
          IFEND;

          put_string ('..');

          IF max_integer_text <> NIL THEN
            put_string (max_integer_text^);
          ELSEIF type_description.max_integer_value = clc$min_integer THEN
            put_string ('$min_integer');
          ELSEIF type_description.max_integer_value = clc$max_integer THEN
            put_string ('$max_integer');
          ELSE
            put_integer (type_description.max_integer_value);
          IFEND;
        IFEND;

        IF type_description.default_radix <> default_radix THEN
          put_string (' ');
          put_string ('radix ');
          put_integer (type_description.default_radix);
        IFEND;

      PROCEND put_integer_type;
?? TITLE := 'put_keyword_type', EJECT ??

      PROCEDURE put_keyword_type;

        VAR
          first_group_ordinal: clt$named_entry_ordinal,
          first_keyword_in_group: boolean,
          index: 1 .. clc$max_keywords,
          keyword: clt$keyword,
          keywords: ^clt$keyword_specifications,
          keyword_in_group: boolean,
          keyword_size: ost$name_size,
          last_keyword_in_group: boolean,
          new_keyword: boolean,
          new_line_desired: boolean,
          previous_indent_amount: clt$string_size;

?? NEWTITLE := 'sort_keywords', EJECT ??

{
{ This routine sorts the keywords according to:
{
{     1)     availability   (normal, advanced, hidden)
{     2)     class          (nominal, alias, abbreviation)
{     3)     ordinal
{

        PROCEDURE [INLINE] sort_keywords;

          VAR
            current: -clc$max_keywords .. clc$max_keywords,
            do_swap: boolean,
            gap: 1 .. clc$max_keywords,
            start: 1 .. clc$max_keywords,
            swap: clt$keyword_specification;


          gap := UPPERBOUND (keywords^);
          WHILE gap > 1 DO
            gap := 2 * (gap DIV 4) + 1;
            FOR start := 1 TO UPPERBOUND (keywords^) - gap DO
              current := start;

            /inner_loop/
              WHILE current > 0 DO
                CASE keywords^ [current].availability OF
                = clc$normal_usage_entry =
                  do_swap := FALSE;
                = clc$advanced_usage_entry =
                  do_swap := keywords^ [current + gap].availability = clc$normal_usage_entry;
                ELSE { clc$hidden_entry }
                  do_swap := keywords^ [current + gap].availability <> clc$hidden_entry;
                CASEND;
                IF (NOT do_swap) AND (keywords^ [current].availability =
                      keywords^ [current + gap].availability) THEN
                  IF keywords^ [current].ordinal > keywords^ [current + gap].ordinal THEN
                    do_swap := TRUE;
                  ELSEIF (keywords^ [current].ordinal = keywords^ [current + gap].ordinal) AND
                        (keywords^ [current].class > keywords^ [current + gap].class) THEN
                    do_swap := TRUE;
                  IFEND;
                IFEND;
                IF NOT do_swap THEN
                  EXIT /inner_loop/;
                IFEND;

                swap := keywords^ [current];
                keywords^ [current] := keywords^ [current + gap];
                keywords^ [current + gap] := swap;
                current := current - gap;
              WHILEND /inner_loop/;
            FOREND;
          WHILEND;

        PROCEND sort_keywords;
?? OLDTITLE, EJECT ??

        put_string ('key');

        IF multi_line_format THEN
          previous_indent_amount := indent_amount;
          increment_indent (nesting_indentation);
        IFEND;

        PUSH keywords: [1 .. UPPERBOUND (type_description.keyword_specifications^)];
        keywords^ := type_description.keyword_specifications^;
        sort_keywords;

      /put_keys/
        FOR index := 1 TO UPPERBOUND (keywords^) DO
          IF (keywords^ [index].availability = clc$advanced_usage_entry) AND (NOT include_advanced_items) THEN
            CYCLE /put_keys/;
          ELSEIF (keywords^ [index].availability = clc$hidden_entry) AND (NOT include_hidden_items) THEN
            EXIT /put_keys/;
          IFEND;

          #TRANSLATE (osv$upper_to_lower, keywords^ [index].keyword, keyword);
          keyword_size := clp$trimmed_string_size (keyword);
          new_keyword := (index = 1) OR (keywords^ [index].ordinal <> keywords^ [index - 1].ordinal);
          keyword_in_group := ((index < UPPERBOUND (keywords^)) AND
                (keywords^ [index].ordinal = keywords^ [index + 1].ordinal)) OR
                ((index > 1) AND (keywords^ [index].ordinal = keywords^ [index - 1].ordinal));
          first_keyword_in_group := new_keyword AND keyword_in_group;
          last_keyword_in_group := keyword_in_group AND ((index = UPPERBOUND (keywords^)) OR
                (keywords^ [index].ordinal <> keywords^ [index + 1].ordinal));

          IF new_keyword THEN
            new_line_desired := FALSE;

            IF (keywords^ [index].availability = clc$normal_usage_entry) AND (index = 1) THEN
              first_group_ordinal := keywords^ [index].ordinal;
              new_line_desired := TRUE;

            ELSEIF (keywords^ [index].availability = clc$advanced_usage_entry) AND
                  (keywords^ [index - 1].availability <> clc$advanced_usage_entry) THEN
              first_group_ordinal := keywords^ [index].ordinal;
              IF multi_line_format THEN
                indent_amount := previous_indent_amount;
                start_string;
              ELSE
                put_string (', ');
                set_break_position;
              IFEND;
              put_string ('advanced_key');
              IF multi_line_format THEN
                increment_indent (nesting_indentation);
              IFEND;
              new_line_desired := TRUE;

            ELSEIF (keywords^ [index].availability = clc$hidden_entry) AND
                  (keywords^ [index - 1].availability <> clc$hidden_entry) THEN
              first_group_ordinal := keywords^ [index].ordinal;
              IF multi_line_format THEN
                indent_amount := previous_indent_amount;
                start_string;
              ELSE
                put_string (', ');
                set_break_position;
              IFEND;
              put_string ('hidden_key');
              IF multi_line_format THEN
                increment_indent (nesting_indentation);
              IFEND;
              new_line_desired := TRUE;

            ELSEIF first_keyword_in_group OR ((string_size^ +2 + keyword_size) > max_string) THEN
              new_line_desired := TRUE;
            IFEND;

            IF NOT keyword_in_group THEN
              first_keyword_in_group := (keyword = 'key') OR (keyword = 'advanced_key') OR (keyword =
                    'hidden_key') OR (keyword = 'keyend');
              IF first_keyword_in_group THEN
                last_keyword_in_group := TRUE;
                new_line_desired := TRUE;
              IFEND;
            IFEND;

            IF multi_line_format AND new_line_desired THEN
              start_string;
            ELSEIF string_started THEN
              IF keywords^ [index].ordinal <> first_group_ordinal THEN
                put_string (', ');
              ELSE
                put_string (' ');
              IFEND;
              set_break_position;
            IFEND;

          ELSE
            put_string (', ');
            set_secondary_break_position;
          IFEND;

          IF first_keyword_in_group THEN
            put_string ('(');
          IFEND;

          put_string (keyword (1, keyword_size));

          IF last_keyword_in_group THEN
            put_string (')');
            IF multi_line_format THEN
              finish_string;
            IFEND;
          IFEND;
        FOREND /put_keys/;

        IF multi_line_format THEN
          indent_amount := previous_indent_amount;
          start_string;
        ELSE
          put_string (', ');
          set_break_position;
        IFEND;

        put_string ('keyend');

      PROCEND put_keyword_type;
?? TITLE := 'put_list_type', EJECT ??

      PROCEDURE put_list_type;

        VAR
          default_min_list_size: 0 .. 1,
          max_list_text: ^clt$expression_text,
          min_list_text: ^clt$expression_text,
          symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier;


        IF symbolic_qualifiers_work_area = NIL THEN
          min_list_text := NIL;
          max_list_text := NIL;
        ELSE
          NEXT symbolic_subrange_qualifier IN symbolic_qualifiers_work_area;
          IF symbolic_subrange_qualifier^.low_text_size = 0 THEN
            min_list_text := NIL;
          ELSE
            NEXT min_list_text: [symbolic_subrange_qualifier^.low_text_size] IN symbolic_qualifiers_work_area;
          IFEND;
          IF symbolic_subrange_qualifier^.high_text_size = 0 THEN
            max_list_text := min_list_text;
          ELSE
            NEXT max_list_text: [symbolic_subrange_qualifier^.high_text_size] IN
                  symbolic_qualifiers_work_area;
          IFEND;
        IFEND;

        put_string ('list');

        IF type_description.list_rest THEN
          put_string (' rest');
        IFEND;

        IF include_implementation_info AND type_description.defer_expansion THEN
          put_string (' defer_expansion');
        IFEND;

        default_min_list_size := $INTEGER (parameter_type);

        IF (min_list_text <> NIL) OR (max_list_text <> NIL) OR
              (type_description.min_list_size <> default_min_list_size) OR
              (type_description.max_list_size <> clc$max_list_size) THEN
          put_string (' ');

          IF min_list_text <> NIL THEN
            put_string (min_list_text^);
          ELSEIF type_description.min_list_size = clc$max_list_size THEN
            put_string ('$max_list');
          ELSE
            put_integer (type_description.min_list_size);
          IFEND;

          put_string ('..');

          IF max_list_text <> NIL THEN
            put_string (max_list_text^);
          ELSEIF type_description.max_list_size = clc$max_list_size THEN
            put_string ('$max_list');
          ELSE
            put_integer (type_description.max_list_size);
          IFEND;
        IFEND;

        IF type_description.list_element_type_description <> NIL THEN
          put_string (' of ');
          set_break_position;
          put_type (FALSE, include_implementation_info, multi_line_format,
                type_description.list_element_type_description^);
        IFEND;

      PROCEND put_list_type;
?? TITLE := 'put_name_type', EJECT ??

      PROCEDURE put_name_type;

        VAR
          max_name_text: ^clt$expression_text,
          min_name_text: ^clt$expression_text,
          symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier;


        IF symbolic_qualifiers_work_area = NIL THEN
          min_name_text := NIL;
          max_name_text := NIL;
        ELSE
          NEXT symbolic_subrange_qualifier IN symbolic_qualifiers_work_area;
          IF symbolic_subrange_qualifier^.low_text_size = 0 THEN
            min_name_text := NIL;
          ELSE
            NEXT min_name_text: [symbolic_subrange_qualifier^.low_text_size] IN symbolic_qualifiers_work_area;
          IFEND;
          IF symbolic_subrange_qualifier^.high_text_size = 0 THEN
            max_name_text := min_name_text;
          ELSE
            NEXT max_name_text: [symbolic_subrange_qualifier^.high_text_size] IN
                  symbolic_qualifiers_work_area;
          IFEND;
        IFEND;

        put_string ('name');

        IF (min_name_text <> NIL) OR (max_name_text <> NIL) OR (type_description.min_name_size > 1) OR
              (type_description.max_name_size < osc$max_name_size) THEN
          put_string (' ');

          IF min_name_text <> NIL THEN
            IF min_name_text <> max_name_text THEN
              put_string (min_name_text^);
            ELSE
              put_string ('1');
            IFEND;
          ELSEIF type_description.min_name_size = osc$max_name_size THEN
            put_string ('$max_name');
          ELSE
            put_integer (type_description.min_name_size);
          IFEND;

          put_string ('..');

          IF max_name_text <> NIL THEN
            put_string (max_name_text^);
          ELSEIF type_description.max_name_size = osc$max_name_size THEN
            put_string ('$max_name');
          ELSE
            put_integer (type_description.max_name_size);
          IFEND;
        IFEND;

      PROCEND put_name_type;
?? TITLE := 'put_range_type', EJECT ??

      PROCEDURE put_range_type;


        put_string ('range');

        IF type_description.range_element_type_description <> NIL THEN
          put_string (' of ');
          set_break_position;
          put_type (FALSE, include_implementation_info, multi_line_format,
                type_description.range_element_type_description^);
        IFEND;

      PROCEND put_range_type;
*IF NOT $true(osv$unix)
?? TITLE := 'put_real_type', EJECT ??

      PROCEDURE put_real_type;


        put_string ('real');

        IF (clp$longreal_classify (type_description.min_real_value.long_real) <>
              clc$real_negative_infinite) OR (clp$longreal_classify
              (type_description.max_real_value.long_real) <> clc$real_positive_infinite) THEN
          put_string (' ');

          put_real (type_description.min_real_value.long_real);

          put_string ('..');

          put_real (type_description.max_real_value.long_real);
        IFEND;

      PROCEND put_real_type;
*IFEND
?? TITLE := 'put_record_type', EJECT ??

      PROCEDURE put_record_type;

        VAR
          field_name: clt$field_name,
          index: clt$field_number,
          previous_indent_amount: clt$string_size;


        put_string ('record');

        IF multi_line_format THEN
          previous_indent_amount := indent_amount;
          increment_indent (nesting_indentation);
        IFEND;

        FOR index := 1 TO type_description.fields_pdt^.header^.number_of_parameters DO
          IF multi_line_format THEN
            start_string;
          ELSE
            IF index > 1 THEN
              put_string ('; ');
            ELSE
              put_string (' ');
            IFEND;
            set_break_position;
          IFEND;

          #TRANSLATE (osv$upper_to_lower, type_description.fields_pdt^.names^ [index].name, field_name);
          put_trimmed_string (field_name);
          put_string (': ');

          put_type (FALSE, include_implementation_info, multi_line_format,
                type_description.fields_pdt^.type_descriptions^ [index]);

          IF type_description.fields_pdt^.parameters^ [index].requirement = clc$optional_field THEN
            put_string (' = $optional');
          IFEND;
        FOREND;

        IF multi_line_format THEN
          indent_amount := previous_indent_amount;
          start_string;
        ELSE
          put_string ('; ');
          set_break_position;
        IFEND;

        put_string ('recend');

      PROCEND put_record_type;
?? TITLE := 'put_string_type', EJECT ??

      PROCEDURE put_string_type;

        VAR
          max_string_text: ^clt$expression_text,
          min_string_text: ^clt$expression_text,
          symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier;


        IF symbolic_qualifiers_work_area = NIL THEN
          min_string_text := NIL;
          max_string_text := NIL;
        ELSE
          NEXT symbolic_subrange_qualifier IN symbolic_qualifiers_work_area;
          IF symbolic_subrange_qualifier^.low_text_size = 0 THEN
            min_string_text := NIL;
          ELSE
            NEXT min_string_text: [symbolic_subrange_qualifier^.low_text_size] IN
                  symbolic_qualifiers_work_area;
          IFEND;
          IF symbolic_subrange_qualifier^.high_text_size = 0 THEN
            max_string_text := min_string_text;
          ELSE
            NEXT max_string_text: [symbolic_subrange_qualifier^.high_text_size] IN
                  symbolic_qualifiers_work_area;
          IFEND;
        IFEND;

        put_string ('string');

        IF type_description.literal THEN
          put_string (' literal');
        IFEND;

        IF (min_string_text <> NIL) OR (max_string_text <> NIL) OR (type_description.min_string_size > 0) OR
              (type_description.max_string_size < clc$max_string_size) THEN
          put_string (' ');

          IF min_string_text <> NIL THEN
            put_string (min_string_text^);
          ELSEIF type_description.min_string_size = clc$max_string_size THEN
            put_string ('$max_string');
          ELSE
            put_integer (type_description.min_string_size);
          IFEND;

          IF (max_string_text <> min_string_text) OR (type_description.max_string_size <>
                type_description.min_string_size) THEN
            put_string ('..');

            IF max_string_text <> NIL THEN
              put_string (max_string_text^);
            ELSEIF type_description.max_string_size = clc$max_string_size THEN
              put_string ('$max_string');
            ELSE
              put_integer (type_description.max_string_size);
            IFEND;
          IFEND;
        IFEND;

      PROCEND put_string_type;
?? TITLE := 'put_union_type', EJECT ??

      PROCEDURE put_union_type;

        VAR
          index: clt$union_member_number,
          previous_indent_amount: clt$string_size;


        put_string ('any');

        IF (type_description.member_descriptions <> NIL) AND
              ((symbolic_qualifiers_work_area <> NIL) OR (NOT clp$type_desc_is_for_old_union
              (^type_description))) THEN
          put_string (' of');
          IF multi_line_format THEN
            previous_indent_amount := indent_amount;
            increment_indent (nesting_indentation);
          IFEND;

          FOR index := 1 TO UPPERBOUND (type_description.member_descriptions^) DO
            IF multi_line_format THEN
              start_string;
            ELSEIF index > 1 THEN
              put_string ('; ');
            ELSE
              put_string (' ');
            IFEND;
            set_break_position;
            put_type (parameter_type, include_implementation_info, multi_line_format,
                  type_description.member_descriptions^ [index]);
          FOREND;

          IF multi_line_format THEN
            indent_amount := previous_indent_amount;
            start_string;
          ELSE
            put_string ('; ');
            set_break_position;
          IFEND;

          put_string ('anyend');
        IFEND;

      PROCEND put_union_type;
?? OLDTITLE, EJECT ??

      VAR
        type_name: clt$type_name;


      IF (NOT parameter_type) AND (type_description.name <> NIL) THEN
        put_string ('"');
        #TRANSLATE (osv$upper_to_lower, type_description.name^, type_name);
        put_string (type_name (1, STRLENGTH (type_description.name^)));
        put_string ('" ');
      IFEND;

      CASE type_description.kind OF

      = clc$application_type =
        put_application_type;

      = clc$array_type =
        put_array_type;

      = clc$boolean_type =
        put_string ('boolean');

      = clc$cobol_name_type =
        put_string ('cobol_name');

      = clc$command_reference_type =
        put_string ('command_reference');

      = clc$data_name_type =
        put_string ('data_name');

      = clc$date_time_type =
        put_date_time_type;

      = clc$entry_point_reference_type =
        put_string ('entry_point_reference');

      = clc$file_type =
        put_string ('file');

      = clc$integer_type =
        put_integer_type;

      = clc$keyword_type =
        put_keyword_type;

      = clc$list_type =
        put_list_type;

      = clc$lock_type =
        put_string ('lock');

      = clc$name_type =
        put_name_type;

      = clc$program_name_type =
        put_string ('program_name');

      = clc$range_type =
        put_range_type;

*IF NOT $true(osv$unix)
      = clc$real_type =
        put_real_type;
*IFEND

      = clc$record_type =
        put_record_type;

      = clc$scu_line_identifier_type =
        put_string ('line_identifier');

      = clc$statistic_code_type =
        put_string ('statistic_code');

      = clc$status_type =
        put_string ('status');

      = clc$status_code_type =
        put_string ('status_code');

      = clc$string_type =
        put_string_type;

      = clc$string_pattern_type =
        put_string ('string_pattern');

      = clc$time_increment_type =
        put_string ('time_increment');

      = clc$time_zone_type =
        put_string ('time_zone');

      = clc$type_specification_type =
        put_string ('type');

      = clc$union_type =
        put_union_type;

      ELSE
        put_string ('UNRECOGNIZABLE_TYPE');
      CASEND;

    PROCEND put_type;
?? TITLE := 'put_type_identification', EJECT ??

    PROCEDURE put_type_identification
      (    value_kind: clt$data_kind);


      put_string ('"');
      put_trimmed_string (clv$type_kind_names [clv$value_type_kinds [value_kind]]);
      put_string ('"  ');

    PROCEND put_type_identification;
?? TITLE := 'set_break_position', EJECT ??

    PROCEDURE [INLINE] set_break_position;


      IF string_started THEN
        IF (representation_option = clc$data_source_representation) AND
              (string_size^ >= (STRLENGTH (string_ptr^) - continuation_size)) THEN
          break_string;
        ELSE
          break.index := string_size^;
          break.mark_continuation := (representation_option = clc$data_source_representation);
          break.indent := indent_amount;
          break_pending := TRUE;
        IFEND;
      IFEND;

    PROCEND set_break_position;
?? TITLE := 'set_indent_amount', EJECT ??

    PROCEDURE [INLINE] set_indent_amount;


      IF string_started THEN
        IF string_size^ <= (STRLENGTH (string_ptr^) DIV 2) THEN
          indent_amount := string_size^;
        ELSE
          indent_amount := STRLENGTH (string_ptr^) DIV 2;
        IFEND;
      ELSE
        indent_amount := initial_indentation;
      IFEND;

    PROCEND set_indent_amount;
?? TITLE := 'set_secondary_break_position', EJECT ??

    PROCEDURE [INLINE] set_secondary_break_position;


      IF string_started THEN
        secondary_break.index := string_size^;
        secondary_break.mark_continuation := (representation_option = clc$data_source_representation);
        secondary_break.indent := indent_amount;
        secondary_break_pending := TRUE;
      IFEND;

    PROCEND set_secondary_break_position;
?? TITLE := 'set_up_local_work_area', EJECT ??

    PROCEDURE set_up_local_work_area;


*IF NOT $true(osv$unix)
      IF local_work_area.sequence_pointer = NIL THEN
        mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, local_work_area, status);
        IF NOT status.normal THEN
          local_work_area.sequence_pointer := NIL;
          EXIT clp$internal_convert_to_string;
        IFEND;
      IFEND;
*ELSE
      IF local_work_area = NIL THEN
        ALLOCATE local_work_area: [[REP 1000000(16) OF cell]];
        RESET local_work_area;
      IFEND;
*IFEND

    PROCEND set_up_local_work_area;
?? TITLE := 'start_representation', EJECT ??

    PROCEDURE start_representation;


      data_representation := NIL;

      NEXT string_count IN work_area;
      IF string_count = NIL THEN
        work_area_overflow;
      IFEND;
      string_count^ := 0;

      space_remaining := #SIZE (work_area^) - i#current_sequence_position (work_area);

      string_started := FALSE;

    PROCEND start_representation;
?? TITLE := 'start_string', EJECT ??

    PROCEDURE start_string;

      VAR
        size: clt$string_size;


      IF string_started THEN
        finish_string;
      IFEND;

      IF space_remaining <= #SIZE (clt$string_size) THEN
        work_area_overflow;
      IFEND;
      NEXT string_size IN work_area;
      space_remaining := space_remaining - #SIZE (clt$string_size);

      IF max_string <= space_remaining THEN
        size := max_string;
      ELSE
        size := space_remaining;
        indent_amount := initial_indentation;
      IFEND;
      NEXT string_ptr: [size] IN work_area;

      string_size^ := indent_amount;
      string_ptr^ (1, indent_amount) := '';

      break_pending := FALSE;
      break.index := 0;
      secondary_break_pending := FALSE;
      secondary_break.index := 0;

      string_count^ := string_count^ +1;
      string_started := TRUE;
      string_may_be_trimmed := TRUE;

    PROCEND start_string;
?? TITLE := 'work_area_overflow', EJECT ??

    PROCEDURE work_area_overflow;


      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      EXIT clp$internal_convert_to_string;

    PROCEND work_area_overflow;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    IF (request.kind = clc$convert_data_value) AND ((request.representation_option <
          LOWERVALUE (clt$data_representation_option)) OR (request.representation_option >
          UPPERVALUE (clt$data_representation_option))) THEN
      osp$set_status_abnormal ('CL', cle$bad_data_rep_option, '', status);
      RETURN;
    IFEND;

    IF request.max_string < 3 THEN
      osp$set_status_abnormal ('CL', cle$string_too_short, '', status);
      RETURN;
    IFEND;

    comma := ', ';
    left_parenthesis := '(';
    space := ' ';

    initial_indentation := request.initial_indentation;
    indent_amount := initial_indentation;
    continuation_indentation := request.continuation_indentation;
    max_string := request.max_string;
    include_advanced_items := request.include_advanced_items;
    include_hidden_items := request.include_hidden_items;

    colon_indent := initial_indentation;
    first_pass := TRUE;
    label_indent_limit := (max_string DIV 2) - 2;
    level_of_nesting := 0;

    start_representation;

*IF NOT $true(osv$unix)
    local_work_area.kind := amc$sequence_pointer;
    local_work_area.sequence_pointer := NIL;
*ELSE
    local_work_area := NIL;
*IFEND
    convert_to_lower_case := FALSE;

*IF $true(osv$unix)
    handler_established := #establish_condition_handler (-1, ^abort_handler);
*ELSE
    osp$establish_condition_handler (^abort_handler, TRUE);
*IFEND

    CASE request.kind OF

    = clc$convert_data_value =
      representation_option := request.representation_option;
      convert_to_lower_case := (representation_option = clc$labeled_elem_representation) OR
            (representation_option = clc$compressed_labeled_elem_rep) OR
            (representation_option = clc$display_elem_representation) OR
            (representation_option = clc$display_srce_representation);
      IF representation_option = clc$display_elem_representation THEN
        representation_option := clc$data_elem_representation;
      ELSEIF representation_option = clc$display_srce_representation THEN
        representation_option := clc$data_source_representation;
      IFEND;
      multi_line_format := representation_option <> clc$data_source_representation;
      symbolic_qualifiers_work_area := NIL;
      convert_value_to_string (request.value);

*IF NOT $true(osv$unix)
    = clc$convert_type_description =
      multi_line_format := request.multi_line_type_format;
      representation_option := clc$data_source_representation;
      symbolic_qualifiers_work_area := request.symbolic_type_qualifiers_area;
      put_type (FALSE, TRUE, multi_line_format, request.type_description^);
*IFEND

    = clc$convert_unbundled_pdt =
      multi_line_format := request.multi_line_pdt_format;
      representation_option := clc$data_source_representation;
      symbolic_qualifiers_work_area := request.symbolic_pdt_qualifiers_area;
      put_pdt (multi_line_format, request.parameter_starts_line, request.individual_parameter,
            request.individual_parameter_number, request.include_header, request.include_implementation_info,
            request.command_or_function_name, request.aliases, request.availability,
            request.command_or_function_scope, request.pdt^, request.pvt);

*IF NOT $true(osv$unix)
    = clc$convert_old_pdt =
      multi_line_format := request.multi_line_old_pdt_format;
      representation_option := clc$data_source_representation;
      symbolic_qualifiers_work_area := NIL;
      put_old_pdt (multi_line_format, request.proc_or_pdt, request.proc_names^, request.old_pdt,
            request.symbolic_parameters);

    = clc$convert_parameters =
      multi_line_format := FALSE;
      representation_option := clc$data_source_representation;
      symbolic_qualifiers_work_area := NIL;
      put_evaluated_parameters (request.initial_text, request.include_secure_parameters,
            request.evaluated_pdt^, request.evaluated_pvt, request.parameter_substitutions);

*IFEND
    ELSE
      ;
    CASEND;

*IF NOT $true(osv$unix)
    IF local_work_area.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (local_work_area, local_status);
      local_work_area.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;
*ELSE
    IF local_work_area <> NIL THEN
      FREE local_work_area;
    IFEND;
*IFEND

*IF $true(osv$unix)
    IF handler_established THEN
      handler_established := NOT #disestablish_condition_handler (-1);
    IFEND;
*ELSE
    osp$disestablish_cond_handler;
*IFEND

    IF NOT status.normal THEN
      EXIT clp$internal_convert_to_string;
    IFEND;

    finish_representation;

  PROCEND clp$internal_convert_to_string;

MODEND clm$convert_to_string;
*DECK DECK=CLM$CONVERT_VALUE_TO_STRING EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter: Convert Value to String' ??
MODULE clm$convert_value_to_string ALIAS 'clmv2s';

{
{ PURPOSE:
{   This module contains the procedure that converts the internal representation of a command language
{   value to its string representation.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc cle$unknown_variable
*copyc clk$procedure_keypoints
*copyc clt$external_radix_spec
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc clp$check_name_for_boolean
*copyc clp$convert_integer_to_string
*copyc clp$convert_real_to_string
*copyc clp$convert_to_ost$status
*copyc clp$get_path_name
*copyc clp$read_variable
*copyc clp$trimmed_string_size
*copyc osp$format_message

?? TITLE := 'clp$convert_value_to_string', EJECT ??
*copyc clh$convert_value_to_string

  PROCEDURE [XDCL, #GATE] clp$convert_value_to_string ALIAS 'clpcv2s'
    (    value: clt$value;
     VAR str: ost$string;
     VAR status: ost$status);

    VAR
      external_radix_spec: clt$external_radix_spec,
      local_status: ost$status;

    #KEYPOINT (osk$entry, 0, clk$convert_value_to_string);

    status.normal := TRUE;
    external_radix_spec.override_radix_in_value := FALSE;
    clp$value_to_string (value, external_radix_spec, str, local_status);
    status := local_status;

    #KEYPOINT (osk$exit, 0, clk$convert_value_to_string);

  PROCEND clp$convert_value_to_string;
?? TITLE := 'clp$value_to_string', EJECT ??

  PROCEDURE [XDCL] clp$value_to_string
    (    value: clt$value;
         external_radix_spec: clt$external_radix_spec;
     VAR str: ost$string;
     VAR status: ost$status);

    VAR
      booleans: [STATIC, READ, oss$job_paged_literal] array [boolean] of array [clt$boolean_kinds] of record
        size: 2 .. 5,
        value: string (5),
      recend := [[{} [5, 'FALSE'], {} [2, 'NO   '], {} [3, 'OFF  ']],
            [{} [4, 'TRUE '], {} [3, 'YES  '], {} [2, 'ON   ']]];

?? NEWTITLE := 'convert_status_to_string', EJECT ??

    PROCEDURE convert_status_to_string
      (    status_value: ost$status;
       VAR str: ost$string;
       VAR status: ost$status);

      VAR
        message: ost$status_message,
        message_area: ^ost$status_message,
        message_line_count: ^ost$status_message_line_count,
        message_line_size: ^ost$status_message_line_size,
        message_line: ^string ( * );

      osp$format_message (status_value, osc$current_message_level, osc$max_string_size, message, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      message_area := ^message;
      RESET message_area;
      NEXT message_line_count IN message_area;
      IF message_line_count^ = 0 THEN
        str.size := 13;
        str.value := 'NORMAL STATUS';
        RETURN;
      IFEND;
      NEXT message_line_size IN message_area;
      NEXT message_line: [message_line_size^] IN message_area;
      str.size := message_line_size^;
      str.value := message_line^;
      IF (message_line_count^ = 1) OR (str.size > (osc$max_string_size - 2)) THEN
        RETURN;
      IFEND;
      str.value (str.size + 1, 2) := '..';
      str.size := str.size + 2;

    PROCEND convert_status_to_string;
?? TITLE := 'convert_variable_to_string', EJECT ??

    PROCEDURE convert_variable_to_string
      (    variable: clt$variable_reference;
       VAR str: ost$string;
       VAR status: ost$status);

      VAR
        boolean_kind: clt$boolean_kinds,
        radix: 2 .. 16,
        include_radix_specifier: boolean,
        status_value: ost$status,
        string_ptr: ^ost$string;

      status.normal := TRUE;
      IF variable.upper_bound > variable.lower_bound THEN
        str.size := 7 + variable.reference.size;
        str.value (1, 7) := 'ARRAY: ';
        str.value (8, * ) := variable.reference.value (1, variable.reference.size);
      ELSE
        CASE variable.value.kind OF
        = clc$string_value =
          string_ptr := #LOC (variable.value.string_value^ [1]);
          str.size := string_ptr^.size;
          str.value := string_ptr^.value (1, str.size);
        = clc$real_value =
          clp$convert_real_to_string (variable.value.real_value^ [1].value,
                variable.value.real_value^ [1].number_of_digits, str, status);
        = clc$integer_value =
          IF external_radix_spec.override_radix_in_value THEN
            radix := external_radix_spec.radix;
            include_radix_specifier := external_radix_spec.include_radix_specifier;
          ELSE
            radix := variable.value.integer_value^ [1].radix;
            include_radix_specifier := variable.value.integer_value^ [1].radix_specified;
          IFEND;
          clp$convert_integer_to_string (variable.value.integer_value^ [1].value, radix,
                include_radix_specifier, str, status);
        = clc$boolean_value =
          IF (LOWERVALUE (clt$boolean_kinds) <= variable.value.boolean_value^ [1].kind) AND
                (variable.value.boolean_value^ [1].kind <= UPPERVALUE (clt$boolean_kinds)) THEN
            boolean_kind := variable.value.boolean_value^ [1].kind;
          ELSE
            boolean_kind := clc$true_false_boolean;
          IFEND;
          str.size := booleans [variable.value.boolean_value^ [1].value = TRUE] [boolean_kind].size;
          str.value := booleans [variable.value.boolean_value^ [1].value = TRUE] [boolean_kind].value;
        = clc$status_value =
          clp$convert_to_ost$status (variable.value.status_value^ [1], status_value);
          convert_status_to_string (status_value, str, status);
        CASEND;
      IFEND;

    PROCEND convert_variable_to_string;
?? OLDTITLE, EJECT ??

    VAR
      boolean_kind: clt$boolean_kinds,
      radix: 2 .. 16,
      include_radix_specifier: boolean,
      file_reference: fst$path,
      variable: clt$variable_reference,
      bool: clt$boolean,
      name_is_boolean: boolean;

    status.normal := TRUE;
    CASE value.kind OF

    = clc$file_value =
      clp$get_path_name (value.file.local_file_name, osc$current_message_level, file_reference);
      str.value := file_reference;
      str.size := clp$trimmed_string_size (str.value);

    = clc$name_value =
      clp$check_name_for_boolean (value.name.value, bool, name_is_boolean);
      IF name_is_boolean THEN
        str.size := booleans [bool.value] [bool.kind].size;
        str.value := booleans [bool.value] [bool.kind].value;
      ELSE
        clp$read_variable (value.name.value, variable, status);
        IF status.normal THEN
          convert_variable_to_string (variable, str, status);
        ELSEIF status.condition = cle$unknown_variable THEN
          status.normal := TRUE;
          str.size := value.name.size;
          str.value := value.name.value;
        IFEND;
      IFEND;

    = clc$boolean_value =
      IF (LOWERVALUE (clt$boolean_kinds) <= value.bool.kind) AND
            (value.bool.kind <= UPPERVALUE (clt$boolean_kinds)) THEN
        boolean_kind := value.bool.kind;
      ELSE
        boolean_kind := clc$true_false_boolean;
      IFEND;
      str.size := booleans [value.bool.value = TRUE] [boolean_kind].size;
      str.value := booleans [value.bool.value = TRUE] [boolean_kind].value;

    = clc$integer_value =
      IF external_radix_spec.override_radix_in_value THEN
        radix := external_radix_spec.radix;
        include_radix_specifier := external_radix_spec.include_radix_specifier;
      ELSE
        radix := value.int.radix;
        include_radix_specifier := value.int.radix_specified;
      IFEND;
      clp$convert_integer_to_string (value.int.value, radix, include_radix_specifier, str, status);

    = clc$status_value =
      convert_status_to_string (value.status, str, status);

    = clc$unknown_value =
      str.size := 23;
      str.value := 'UNKNOWN VALUE.';

    = clc$variable_reference =
      convert_variable_to_string (value.var_ref, str, status);

    = clc$real_value =
      clp$convert_real_to_string (value.rnum.value, value.rnum.number_of_digits, str, status);

    = clc$string_value =
      str.size := value.str.size;
      str.value := value.str.value (1, value.str.size);

    = clc$application_value =
      str.size := STRLENGTH (value.descriptor);
      str.value := value.descriptor;
      WHILE (str.size > 0) AND (str.value (str.size) = ' ') DO
        str.size := str.size - 1;
      WHILEND;
      IF str.size = 0 THEN
        str.size := 18;
        str.value := 'APPLICATION VALUE.';
      IFEND;

    CASEND;

  PROCEND clp$value_to_string;

MODEND clm$convert_value_to_string;
*DECK DECK=CLM$COPY_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter: Copy Command Processor' ??
MODULE clm$copy_command;

{
{ PURPOSE:
{   This module contains the processor for the copy command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_parsing
*copyc clt$parameter_list
*copyc nfe$ptf_condition_codes
*copyc ost$status
?? POP ??
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc clp$find_current_block
*copyc clp$get_work_area
*copyc fsp$copy_file
*copyc fsp$path_element
*copyc nfp$check_implicit_access
*copyc nfp$perform_implicit_access
*copyc osp$set_status_abnormal
?? TITLE := 'clp$_copy_file', EJECT ??

  PROCEDURE [XDCL] clp$_copy_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$copf) copy_file, copf (
{   input, i: file = $input
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          default_value: string (6),
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 20, 12, 30, 50, 281], clc$command, 5, 3, 0, 0, 0, 0, 3, 'OSM$COPF'],
            [['I                              ', clc$abbreviation_entry, 1],
            ['INPUT                          ', clc$nominal_entry, 1],
            ['O                              ', clc$abbreviation_entry, 2],
            ['OUTPUT                         ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3]], [
{ PARAMETER 1
      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 6],
{ PARAMETER 2
      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$file_type], '$input'],
{ PARAMETER 2
      [[1, 0, clc$file_type], '$output'],
{ PARAMETER 3
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$input = 1,
      p$output = 2,
      p$status = 3;

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

    VAR
      block: ^clt$block,
      evaluated_file_reference: fst$evaluated_file_reference,
      input_family: ost$family_name,
      input_remote: boolean,
      output_family: ost$family_name,
      output_remote: boolean,
      work_area: ^^clt$work_area;


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

    IF (NOT pvt [p$input].specified) AND (NOT pvt [p$output].specified) THEN
      osp$set_status_abnormal ('CL', cle$required_parameter_omitted, 'INPUT or OUTPUT', status);
      RETURN;
    IFEND;

    clp$evaluate_file_reference (pvt [p$input].value^.file_value^, $clt$file_ref_parsing_options [],
          FALSE, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    input_family := fsp$path_element (^evaluated_file_reference, 1) ^;
    nfp$check_implicit_access (input_family, input_remote, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_file_reference (pvt [p$output].value^.file_value^, $clt$file_ref_parsing_options [],
          FALSE, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output_family := fsp$path_element (^evaluated_file_reference, 1) ^;
    nfp$check_implicit_access (output_family, output_remote, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT (input_remote OR output_remote) THEN
      fsp$copy_file (pvt [p$input].value^.file_value^, pvt [p$output].value^.file_value^, NIL, NIL, NIL,
            status);
      RETURN;
    IFEND;

    IF input_remote AND output_remote THEN
      osp$set_status_abnormal (nfc$status_id, nfe$both_files_remote, '', status);
      RETURN;
    IFEND;

{
{ One of the files is on a remote family.
{
    clp$find_current_block (block);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_work_area (#RING (^work_area), work_area, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF output_remote THEN
      nfp$perform_implicit_access (output_family, pvt [p$input].value^.file_value^, pvt [p$output].
            value^.file_value^, nfc$take, osc$null_name, block^.parameters.unbundled_pdt, ^pvt, NIL,
            work_area^, status);

    ELSE {Input remote
      nfp$perform_implicit_access (input_family, pvt [p$output].value^.file_value^, pvt [p$input].
            value^.file_value^, nfc$give, osc$null_name, block^.parameters.unbundled_pdt, ^pvt, NIL,
            work_area^, status);
    IFEND;

  PROCEND clp$_copy_file;

MODEND clm$copy_command;
*DECK DECK=CLM$DATA_VALUE_COMPARE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Data Value Comparison Functions' ??
MODULE clm$data_value_compare;

{
{ PURPOSE:
{   This module contains a number of functions that compare various types
{   of SCL data values.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$comparison_result
*copyc clt$data_value
*copyc cyc$max_string_size
?? POP ??
*copyc clp$boolean_compare
*IF NOT $true(osv$unix)
*copyc clp$get_path_name
*IFEND
*copyc clp$integer_compare
*IF NOT $true(osv$unix)
*copyc clp$longreal_compare
*IFEND
*copyc clp$string_compare
*copyc osv$lower_to_upper

?? TITLE := 'clp$array_value_compare', EJECT ??

  FUNCTION [XDCL, UNSAFE] clp$array_value_compare
    (    left_value: ^clt$data_value;
         right_value: ^clt$data_value): clt$comparison_result;

    VAR
      comparison_result: clt$comparison_result,
      i: clt$array_bound;


    IF (left_value^.array_value = NIL) OR (right_value^.array_value = NIL) OR
          (LOWERBOUND (left_value^.array_value^) <> LOWERBOUND (right_value^.array_value^)) OR
          (UPPERBOUND (left_value^.array_value^) <> UPPERBOUND (right_value^.array_value^)) THEN
      comparison_result := clc$unordered;
    ELSE
      comparison_result := clc$equal;

    /check_array_elements/
      FOR i := LOWERBOUND (left_value^.array_value^) TO UPPERBOUND (left_value^.array_value^) DO
        IF clp$data_value_compare (left_value^.array_value^ [i], right_value^.array_value^ [i]) <>
              clc$equal THEN
          comparison_result := clc$unordered;
          EXIT /check_array_elements/;
        IFEND;
      FOREND /check_array_elements/;
    IFEND;

    clp$array_value_compare := comparison_result;

  FUNCEND clp$array_value_compare;
?? TITLE := 'clp$command_reference_compare', EJECT ??

  FUNCTION [XDCL, UNSAFE] clp$command_reference_compare
    (    left_command_reference: clt$command_reference;
         right_command_reference: clt$command_reference): clt$comparison_result;

    VAR
      comparison_result: clt$comparison_result;


    IF (left_command_reference.name = right_command_reference.name) THEN

      CASE left_command_reference.form OF
      = clc$name_only_command_ref, clc$skip_1st_entry_command_ref, clc$system_command_ref =
        comparison_result := clc$equal;
      = clc$utility_command_ref =
        IF left_command_reference.utility = right_command_reference.utility THEN
          comparison_result := clc$equal;
        ELSE
          comparison_result := clc$unordered;
        IFEND;
      = clc$module_or_file_command_ref =
        comparison_result := clp$file_compare (^left_command_reference.library_or_catalog,
              ^right_command_reference.library_or_catalog);
        IF comparison_result <> clc$equal THEN
          comparison_result := clc$unordered;
        IFEND;
      = clc$file_cycle_command_ref =
        IF (clp$file_compare (^left_command_reference.catalog, ^right_command_reference.catalog) =
              clc$equal) AND (left_command_reference.cycle_number = right_command_reference.cycle_number) THEN
          comparison_result := clc$equal;
        ELSE
          comparison_result := clc$unordered;
        IFEND;
      ELSE
        comparison_result := clc$unordered;
      CASEND;

      clp$command_reference_compare := comparison_result;
    ELSE
      clp$command_reference_compare := clc$unordered;
    IFEND;

  FUNCEND clp$command_reference_compare;
?? TITLE := 'clp$data_value_compare', EJECT ??

  FUNCTION [XDCL, UNSAFE] clp$data_value_compare
    (    left_value: ^clt$data_value;
         right_value: ^clt$data_value): clt$comparison_result;

    VAR
      comparison_result: clt$comparison_result;


    IF left_value = NIL THEN
      IF right_value = NIL THEN
        comparison_result := clc$equal;
      ELSE
        comparison_result := clc$unordered;
      IFEND;
    ELSEIF (right_value = NIL) OR (left_value^.kind <> right_value^.kind) THEN
      comparison_result := clc$unordered;
    ELSE
      CASE left_value^.kind OF
      = clc$application =
        comparison_result := clc$unordered;
      = clc$array =
        comparison_result := clp$array_value_compare (left_value, right_value);
      = clc$boolean =
        comparison_result := clp$boolean_compare (left_value^.boolean_value.value,
              right_value^.boolean_value.value);
      = clc$cobol_name =
        comparison_result := clp$string_compare (^left_value^.cobol_name_value,
              ^right_value^.cobol_name_value);
      = clc$command_reference =
        IF (left_value^.command_reference_value = NIL) OR (right_value^.command_reference_value = NIL) THEN
          comparison_result := clc$unordered;
        ELSE
          comparison_result := clp$command_reference_compare
                (left_value^.command_reference_value^, right_value^.command_reference_value^);
        IFEND;
      = clc$data_name =
        comparison_result := clp$string_compare (^left_value^.data_name_value, ^right_value^.data_name_value);
      = clc$date_time =
        comparison_result := clp$date_time_compare (left_value^.date_time_value,
              right_value^.date_time_value);
      = clc$entry_point_reference =
        IF (left_value^.entry_point_reference_value = NIL) OR
              (right_value^.entry_point_reference_value = NIL) THEN
          comparison_result := clc$unordered;
        ELSE
          comparison_result := clp$entry_point_ref_compare (left_value^.entry_point_reference_value^,
                right_value^.entry_point_reference_value^);
        IFEND;
*IF NOT $true(osv$unix)
      = clc$file =
*ELSE
      = clc$nos_ve_file =
*IFEND
        comparison_result := clp$file_compare (left_value^.file_value, right_value^.file_value);
*IF $true(osv$unix)
      = clc$unix_file =
        comparison_result := clp$string_compare (left_value^.file_value, right_value^.file_value);
*IFEND
      = clc$integer =
        comparison_result := clp$integer_compare (left_value^.integer_value.value,
              right_value^.integer_value.value);
      = clc$keyword =
        comparison_result := clp$string_compare (^left_value^.keyword_value, ^right_value^.keyword_value);
      = clc$list =
        comparison_result := clp$list_value_compare (left_value, right_value);
      = clc$lock =
        comparison_result := clc$unordered;
      = clc$name =
        comparison_result := clp$string_compare (^left_value^.name_value, ^right_value^.name_value);
      = clc$network_title =
        comparison_result := clp$string_compare (left_value^.network_title_value,
              right_value^.network_title_value);
      = clc$program_name =
        comparison_result := clp$string_compare (^left_value^.program_name_value,
              ^right_value^.program_name_value);
      = clc$range =
        comparison_result := clp$range_value_compare (left_value, right_value);
*IF NOT $true(osv$unix)
      = clc$real =
        comparison_result := clp$longreal_compare (left_value^.real_value.value,
              right_value^.real_value.value, clc$infinities_equal);
*IFEND
      = clc$record =
        comparison_result := clp$record_value_compare (left_value, right_value);
      = clc$scu_line_identifier =
        IF left_value^.scu_line_identifier_value = right_value^.scu_line_identifier_value THEN
          comparison_result := clc$equal;
        ELSE
          comparison_result := clc$unordered;
        IFEND;
      = clc$statistic_code =
        comparison_result := clp$integer_compare (left_value^.statistic_code_value,
              right_value^.statistic_code_value);
      = clc$status =
        IF (left_value^.status_value = NIL) OR (right_value^.status_value = NIL) THEN
          comparison_result := clc$unordered;
        ELSE
          comparison_result := clp$status_compare (left_value^.status_value^, right_value^.status_value^);
        IFEND;
      = clc$status_code =
        comparison_result := clp$integer_compare (left_value^.status_code_value,
              right_value^.status_code_value);
      = clc$string =
        comparison_result := clp$string_compare (left_value^.string_value, right_value^.string_value);
      = clc$string_pattern =
        comparison_result := clp$sequence_compare (left_value^.string_pattern_value,
              right_value^.string_pattern_value);
      = clc$time_increment =
        IF (left_value^.time_increment_value = NIL) OR (right_value^.time_increment_value = NIL) THEN
          comparison_result := clc$unordered;
        ELSE
          comparison_result := clp$time_increment_compare (left_value^.time_increment_value^,
                right_value^.time_increment_value^);
        IFEND;
      = clc$time_zone =
        IF left_value^.time_zone_value = right_value^.time_zone_value THEN
          comparison_result := clc$equal;
        ELSE
          comparison_result := clc$unordered;
        IFEND;
      = clc$type_specification =
        comparison_result := clp$sequence_compare (left_value^.type_specification_value,
              right_value^.type_specification_value);
      ELSE {clc$unspecified}
        comparison_result := clc$equal;
      CASEND;
    IFEND;

    clp$data_value_compare := comparison_result;

  FUNCEND clp$data_value_compare;
?? TITLE := 'clp$date_time_compare', EJECT ??

  FUNCTION [XDCL] clp$date_time_compare
    (    left_date_time: clt$date_time;
         right_date_time: clt$date_time): clt$comparison_result;

    VAR
      comparison_result: clt$comparison_result;


    comparison_result := clc$equal;

    IF left_date_time.date_specified AND right_date_time.date_specified THEN
      IF left_date_time.value.year < right_date_time.value.year THEN
        comparison_result := clc$right_is_greater;
      ELSEIF left_date_time.value.year > right_date_time.value.year THEN
        comparison_result := clc$left_is_greater;
      ELSEIF left_date_time.value.month < right_date_time.value.month THEN
        comparison_result := clc$right_is_greater;
      ELSEIF left_date_time.value.month > right_date_time.value.month THEN
        comparison_result := clc$left_is_greater;
      ELSEIF left_date_time.value.day < right_date_time.value.day THEN
        comparison_result := clc$right_is_greater;
      ELSEIF left_date_time.value.day > right_date_time.value.day THEN
        comparison_result := clc$left_is_greater;
      IFEND;
    IFEND;

    IF (comparison_result = clc$equal) AND left_date_time.time_specified AND
          right_date_time.time_specified THEN
      IF left_date_time.value.hour < right_date_time.value.hour THEN
        comparison_result := clc$right_is_greater;
      ELSEIF left_date_time.value.hour > right_date_time.value.hour THEN
        comparison_result := clc$left_is_greater;
      ELSEIF left_date_time.value.minute < right_date_time.value.minute THEN
        comparison_result := clc$right_is_greater;
      ELSEIF left_date_time.value.minute > right_date_time.value.minute THEN
        comparison_result := clc$left_is_greater;
      ELSEIF left_date_time.value.second < right_date_time.value.second THEN
        comparison_result := clc$right_is_greater;
      ELSEIF left_date_time.value.second > right_date_time.value.second THEN
        comparison_result := clc$left_is_greater;
      ELSEIF left_date_time.value.millisecond < right_date_time.value.millisecond THEN
        comparison_result := clc$right_is_greater;
      ELSEIF left_date_time.value.millisecond > right_date_time.value.millisecond THEN
        comparison_result := clc$left_is_greater;
      IFEND;
    IFEND;

    clp$date_time_compare := comparison_result;

  FUNCEND clp$date_time_compare;
?? TITLE := 'clp$entry_point_ref_compare', EJECT ??

  FUNCTION [XDCL, UNSAFE] clp$entry_point_ref_compare
    (    left_entry_point_reference: pmt$entry_point_reference;
         right_entry_point_reference: pmt$entry_point_reference): clt$comparison_result;


    IF (left_entry_point_reference.entry_point = right_entry_point_reference.entry_point) AND
          (clp$file_compare (^left_entry_point_reference.object_library,
          ^right_entry_point_reference.object_library) = clc$equal) THEN
      clp$entry_point_ref_compare := clc$equal;
    ELSE
      clp$entry_point_ref_compare := clc$unordered;
    IFEND;

  FUNCEND clp$entry_point_ref_compare;
?? TITLE := 'clp$file_compare', EJECT ??

  FUNCTION [UNSAFE] clp$file_compare
    (    left_file: ^fst$file_reference;
         right_file: ^fst$file_reference): clt$comparison_result;

    CONST
      first_character_of_full_path = ':';

    VAR
      comparison_result: clt$comparison_result,
      left_path: fst$path,
      right_path: fst$path;


    IF (left_file = NIL) OR (right_file = NIL) OR (STRLENGTH (left_file^) = 0) OR
          (STRLENGTH (right_file^) = 0) THEN
      comparison_result := clc$unordered;
    ELSE

*IF NOT $true(osv$unix)
      IF left_file^ (1) = first_character_of_full_path THEN
*IFEND
        #TRANSLATE (osv$lower_to_upper, left_file^, left_path);
*IF NOT $true(osv$unix)
      ELSE
        clp$get_path_name (left_file^, osc$full_message_level, left_path);
      IFEND;
*IFEND

*IF NOT $true(osv$unix)
      IF right_file^ (1) = first_character_of_full_path THEN
*IFEND
        #TRANSLATE (osv$lower_to_upper, right_file^, right_path);
*IF NOT $true(osv$unix)
      ELSE
        clp$get_path_name (right_file^, osc$full_message_level, right_path);
      IFEND;
*IFEND

      IF left_path = right_path THEN
        comparison_result := clc$equal;
      ELSEIF left_path > right_path THEN
        comparison_result := clc$left_is_greater;
      ELSE
        comparison_result := clc$right_is_greater;
      IFEND;
    IFEND;

    clp$file_compare := comparison_result;

  FUNCEND clp$file_compare;
?? TITLE := 'clp$list_value_compare', EJECT ??

  FUNCTION [XDCL, UNSAFE] clp$list_value_compare
    (    left_value: ^clt$data_value;
         right_value: ^clt$data_value): clt$comparison_result;

    VAR
      comparison_result: clt$comparison_result,
      left_node: ^clt$data_value,
      right_node: ^clt$data_value;


    IF (left_value^.element_value = NIL) AND (left_value^.link = NIL) AND
          (right_value^.element_value = NIL) AND (right_value^.link = NIL) THEN
      comparison_result := clc$equal;
    ELSE
      left_node := left_value;
      right_node := right_value;

    /check_list_elements/
      WHILE TRUE DO
        IF clp$data_value_compare (left_node^.element_value, right_node^.element_value) <> clc$equal THEN
          comparison_result := clc$unordered;
          EXIT /check_list_elements/;
        ELSEIF left_node^.link = NIL THEN
          IF right_node^.link = NIL THEN
            comparison_result := clc$equal;
          ELSE
            comparison_result := clc$unordered;
          IFEND;
          EXIT /check_list_elements/;
        ELSEIF right_node^.link = NIL THEN
          comparison_result := clc$unordered;
          EXIT /check_list_elements/;
        IFEND;
        left_node := left_node^.link;
        right_node := right_node^.link;
      WHILEND /check_list_elements/;
    IFEND;

    clp$list_value_compare := comparison_result;

  FUNCEND clp$list_value_compare;
?? TITLE := 'clp$range_value_compare', EJECT ??

  FUNCTION [XDCL, UNSAFE] clp$range_value_compare
    (    left_value: ^clt$data_value;
         right_value: ^clt$data_value): clt$comparison_result;

    VAR
      comparison_result: clt$comparison_result;


    IF clp$data_value_compare (left_value^.low_value, right_value^.low_value) <> clc$equal THEN
      comparison_result := clc$unordered;
    ELSEIF left_value^.high_value = left_value^.low_value THEN
      IF right_value^.high_value = right_value^.low_value THEN
        comparison_result := clc$equal;
      ELSE
        comparison_result := clc$unordered;
      IFEND;
    ELSEIF right_value^.high_value = right_value^.low_value THEN
      comparison_result := clc$unordered;
    ELSE
      comparison_result := clp$data_value_compare (left_value^.high_value, right_value^.high_value);
      IF comparison_result <> clc$equal THEN
        comparison_result := clc$unordered;
      IFEND;
    IFEND;

    clp$range_value_compare := comparison_result;

  FUNCEND clp$range_value_compare;
?? TITLE := 'clp$record_value_compare', EJECT ??

  FUNCTION [XDCL, UNSAFE] clp$record_value_compare
    (    left_value: ^clt$data_value;
         right_value: ^clt$data_value): clt$comparison_result;

    VAR
      comparison_result: clt$comparison_result,
      i: clt$field_number;


    IF (left_value^.field_values = NIL) OR (right_value^.field_values = NIL) OR
          (UPPERBOUND (left_value^.field_values^) <> UPPERBOUND (right_value^.field_values^)) THEN
      comparison_result := clc$unordered;
    ELSE
      comparison_result := clc$equal;

    /check_fields/
      FOR i := LOWERBOUND (left_value^.field_values^) TO UPPERBOUND (left_value^.field_values^) DO
        IF (left_value^.field_values^ [i].name <> right_value^.field_values^ [i].name) OR
              (clp$data_value_compare (left_value^.field_values^ [i].value,
              right_value^.field_values^ [i].value) <> clc$equal) THEN
          comparison_result := clc$unordered;
          EXIT /check_fields/;
        IFEND;
      FOREND /check_fields/;
    IFEND;

    clp$record_value_compare := comparison_result;

  FUNCEND clp$record_value_compare;
?? TITLE := 'clp$sequence_compare', EJECT ??

  FUNCTION clp$sequence_compare
    (    left_sequence: ^SEQ ( * );
         right_sequence: ^SEQ ( * )): clt$comparison_result;

    VAR
      comparison_result: clt$comparison_result,
      left_seq: ^SEQ ( * ),
      left_string: ^string ( * ),
      right_seq: ^SEQ ( * ),
      right_string: ^string ( * ),
      size: integer;


    IF (left_sequence = NIL) OR (right_sequence = NIL) OR (#SIZE (left_sequence^) <> #SIZE (right_sequence^))
          THEN
      comparison_result := clc$unordered;
    ELSE

    /compare_sequence_contents/
      BEGIN
        size := #SIZE (left_sequence^);
        left_seq := left_sequence;
        RESET left_seq;
        right_seq := right_sequence;
        RESET right_seq;
        WHILE size > cyc$max_string_size DO
          NEXT left_string: [cyc$max_string_size] IN left_seq;
          NEXT right_string: [cyc$max_string_size] IN right_seq;
          IF left_string^ > right_string^ THEN
            comparison_result := clc$left_is_greater;
            EXIT /compare_sequence_contents/;
          ELSEIF left_string^ < right_string^ THEN
            comparison_result := clc$right_is_greater;
            EXIT /compare_sequence_contents/;
          IFEND;
          size := size - cyc$max_string_size;
        WHILEND;
        IF size > 0 THEN
          NEXT left_string: [size] IN left_seq;
          NEXT right_string: [size] IN right_seq;
          IF left_string^ > right_string^ THEN
            comparison_result := clc$left_is_greater;
            EXIT /compare_sequence_contents/;
          ELSEIF left_string^ < right_string^ THEN
            comparison_result := clc$right_is_greater;
            EXIT /compare_sequence_contents/;
          IFEND;
        IFEND;
        comparison_result := clc$equal;
      END /compare_sequence_contents/;
    IFEND;

    clp$sequence_compare := comparison_result;

  FUNCEND clp$sequence_compare;
?? TITLE := 'clp$status_compare', EJECT ??

  FUNCTION [XDCL] clp$status_compare
    (    left_status: ost$status;
         right_status: ost$status): clt$comparison_result;

    VAR
      comparison_result: clt$comparison_result;


    IF left_status.normal <> right_status.normal THEN
      comparison_result := clc$unordered;
    ELSE
      CASE left_status.normal OF
      = TRUE =
        comparison_result := clc$equal;
      = FALSE =
        IF (left_status.condition = right_status.condition) AND
              (left_status.text.value (1, left_status.text.size) =
              right_status.text.value (1, right_status.text.size)) THEN
          comparison_result := clc$equal;
        ELSE
          comparison_result := clc$unordered;
        IFEND;
      CASEND;
    IFEND;

    clp$status_compare := comparison_result;

  FUNCEND clp$status_compare;
?? TITLE := 'clp$time_increment_compare', EJECT ??

  FUNCTION [XDCL] clp$time_increment_compare
    (    left_time_increment: pmt$time_increment;
         right_time_increment: pmt$time_increment): clt$comparison_result;

    VAR
      comparison_result: clt$comparison_result;


    IF left_time_increment.year < right_time_increment.year THEN
      comparison_result := clc$right_is_greater;
    ELSEIF left_time_increment.year > right_time_increment.year THEN
      comparison_result := clc$left_is_greater;
    ELSEIF left_time_increment.month < right_time_increment.month THEN
      comparison_result := clc$right_is_greater;
    ELSEIF left_time_increment.month > right_time_increment.month THEN
      comparison_result := clc$left_is_greater;
    ELSEIF left_time_increment.day < right_time_increment.day THEN
      comparison_result := clc$right_is_greater;
    ELSEIF left_time_increment.day > right_time_increment.day THEN
      comparison_result := clc$left_is_greater;
    ELSEIF left_time_increment.hour < right_time_increment.hour THEN
      comparison_result := clc$right_is_greater;
    ELSEIF left_time_increment.hour > right_time_increment.hour THEN
      comparison_result := clc$left_is_greater;
    ELSEIF left_time_increment.minute < right_time_increment.minute THEN
      comparison_result := clc$right_is_greater;
    ELSEIF left_time_increment.minute > right_time_increment.minute THEN
      comparison_result := clc$left_is_greater;
    ELSEIF left_time_increment.second < right_time_increment.second THEN
      comparison_result := clc$right_is_greater;
    ELSEIF left_time_increment.second > right_time_increment.second THEN
      comparison_result := clc$left_is_greater;
    ELSEIF left_time_increment.millisecond < right_time_increment.millisecond THEN
      comparison_result := clc$right_is_greater;
    ELSEIF left_time_increment.millisecond > right_time_increment.millisecond THEN
      comparison_result := clc$left_is_greater;
    ELSE
      comparison_result := clc$equal;
    IFEND;

    clp$time_increment_compare := comparison_result;

  FUNCEND clp$time_increment_compare;

MODEND clm$data_value_compare;
*DECK DECK=CLM$DATA_VALUE_CONVERSION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Data Value Conversion Procedures' ??
MODULE clm$data_value_conversion;

{
{ PURPOSE:
{   This module contains the procedures that convert data values between their
{   external and internal forms.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$bad_data_value
*IF NOT $true(osv$unix)
*copyc cle$bad_internal_value
*IFEND
*copyc cle$work_area_overflow
*IF $true(osv$unix)
*copyc clt$data_kinds
*IFEND
*copyc clt$data_value
*IF NOT $true(osv$unix)
*copyc clt$expression_eval_method
*copyc clt$internal_data_value
*copyc clt$internal_data_value_size
*copyc clt$i_data_value
*copyc clt$type_description
*IFEND
*copyc clt$work_area
*IF NOT $true(osv$unix)
*copyc cyd$run_time_error_condition
*ELSE
*copyc cyt$mips_signal_handler
*IFEND
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*IF NOT $true(osv$unix)
*copyc clp$longreal_compare_gt
*copyc clp$longreal_compare_lt
*ELSE
*copyc clp$make_a_file_value
*IFEND
*IF NOT $true(osv$unix)
*copyc clp$make_application_value
*copyc clp$make_array_value
*copyc clp$make_clt$boolean_value
*copyc clp$make_clt$integer_value
*copyc clp$make_clt$real_value
*copyc clp$make_cobol_name_value
*copyc clp$make_command_ref_value
*copyc clp$make_data_name_value
*copyc clp$make_date_time_value
*copyc clp$make_deferred_value
*copyc clp$make_entry_point_ref_value
*copyc clp$make_file_value
*copyc clp$make_keyword_value
*copyc clp$make_list_value
*copyc clp$make_lock_value
*copyc clp$make_name_value
*copyc clp$make_network_title_value
*copyc clp$make_program_name_value
*copyc clp$make_range_value
*copyc clp$make_record_value
*copyc clp$make_scu_line_id_value
*copyc clp$make_statistic_code_value
*copyc clp$make_status_value
*copyc clp$make_status_code_value
*copyc clp$make_string_value
*copyc clp$make_string_pattern_value
*copyc clp$make_time_increment_value
*copyc clp$make_time_zone_value
*copyc clp$make_type_spec_value
*copyc clp$make_unspecified_value
*copyc clp$trimmed_string_size
*copyc clv$max_variable_allocation
*copyc clv$real_zero
*copyc i#current_sequence_position
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*IFEND
*copyc osp$set_status_abnormal
*IF NOT $true(osv$unix)
*copyc pmp$continue_to_cause
?? TITLE := 'size estimating constatnts', EJECT ??

  CONST
    application_size_increment = 16,
    deferred_size_increment = 16,
    file_size_increment = 32,
    max_increment_size = 0fff(16),
    max_unused_space = 0ffff(16),
    network_title_size_increment = 16,
    nominal_application_size = 32,
    nominal_deferred_value_size = 32,
    nominal_file_size = 96,
    nominal_list_size = 25,
    nominal_network_title_size = 31,
    nominal_string_size = 128,
    string_size_increment = 64;

*IFEND
*IF NOT $true(osv$unix)
?? TITLE := 'clp$change_internal_value', EJECT ??

  PROCEDURE [XDCL] clp$change_internal_value
    (    change_in_place: boolean;
         old_value: ^clt$internal_data_value;
         graft_address: ^ REL (clt$internal_data_value) ^clt$i_data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR new_value {input, output} : ^clt$internal_data_value;
     VAR status: ost$status);

    VAR
      actual_graft_address: ^ REL (clt$internal_data_value) ^clt$i_data_value,
      copy_new_into_old: boolean,
      ignore_graft_address: ^ REL (clt$internal_data_value) ^clt$i_data_value,
      minimum_new_value_size: clt$internal_data_value_size,
      new_space: ^SEQ ( * ),
      new_value_size: clt$internal_data_value_size,
      old_allocated_space: ^SEQ ( * ),
      old_space: ^SEQ ( * ),
      original_work_area: ^clt$work_area,
      replacement_value: ^clt$internal_data_value,
      skip_space: ^array [1 .. * ] of cell;

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

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


      CASE condition.selector OF

      = pmc$block_exit_processing =
        work_area := original_work_area;
        #SPOIL (work_area);
        RETURN;

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          bad_internal_value;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          bad_internal_value;
        IFEND;

      = mmc$segment_access_condition =
        CASE condition.segment_access_condition.identifier OF
        = mmc$sac_read_beyond_eoi =
          bad_internal_value;
        = mmc$sac_read_write_beyond_msl, mmc$sac_no_append_permission =
*IF $true(osv$unix)
          bad_internal_value;
*ELSE
          IF #SEGMENT (condition.segment_access_condition.segment) = #SEGMENT (work_area) THEN
            work_area_overflow;
          ELSE
            bad_internal_value;
          IFEND;
*IFEND
        ELSE
          ;
        CASEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? TITLE := 'bad_internal_value', EJECT ??

    PROCEDURE [INLINE] bad_internal_value;


      osp$set_status_abnormal ('CL', cle$bad_internal_value, '', status);
      EXIT clp$change_internal_value;

    PROCEND bad_internal_value;
?? TITLE := 'copy_internal_value', EJECT ??

    PROCEDURE copy_internal_value
      (    source_value: ^clt$internal_data_value;
           source_component: ^ REL (clt$internal_data_value) ^clt$i_data_value;
           new_value: ^clt$internal_data_value;
           new_component: ^ REL (clt$internal_data_value) ^clt$i_data_value;
       VAR migrate_graft_address {input, output} : ^ REL (clt$internal_data_value) ^clt$i_data_value;
       VAR new_space {input, output} : ^SEQ ( * ));

      VAR
        new_i_value: ^clt$i_data_value,
        source_i_value: ^clt$i_data_value;

?? NEWTITLE := 'copy_application_value', EJECT ??

      PROCEDURE [INLINE] copy_application_value;

        VAR
          new_application_value: ^clt$application_value_text,
          source_application_value: ^clt$application_value_text;


        source_application_value := #PTR (source_i_value^.application_value, source_value^);

        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$application;
          NEXT new_application_value: [STRLENGTH (source_application_value^)] IN new_space;
        ELSEIF new_i_value^.kind <> clc$application THEN
          new_i_value^.kind := clc$application;
          NEXT new_application_value: [STRLENGTH (source_application_value^)] IN new_space;
        ELSE
          new_application_value := #PTR (new_i_value^.application_value, new_value^);
          IF STRLENGTH (new_application_value^) < STRLENGTH (source_application_value^) THEN
            NEXT new_application_value: [STRLENGTH (source_application_value^)] IN new_space;
          ELSEIF STRLENGTH (new_application_value^) > STRLENGTH (source_application_value^) THEN
            new_application_value := ^new_application_value^ (1, STRLENGTH (source_application_value^));
          IFEND;
        IFEND;

        IF new_application_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_application_value^ := source_application_value^;
        new_i_value^.application_value := #REL (new_application_value, new_value^);

      PROCEND copy_application_value;
?? TITLE := 'copy_array_value', EJECT ??

      PROCEDURE [INLINE] copy_array_value;

        VAR
          i: clt$array_bound,
          new_array_value: ^array [ * ] of REL (clt$internal_data_value) ^clt$i_data_value,
          overwrite_array: boolean,
          source_array_value: ^array [ * ] of REL (clt$internal_data_value) ^clt$i_data_value;


        source_array_value := #PTR (source_i_value^.array_value, source_value^);

        overwrite_array := TRUE;
        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$array;
          NEXT new_array_value: [LOWERBOUND (source_array_value^) .. UPPERBOUND (source_array_value^)] IN
                new_space;
          overwrite_array := FALSE;
        ELSEIF new_i_value^.kind <> clc$array THEN
          new_i_value^.kind := clc$array;
          NEXT new_array_value: [LOWERBOUND (source_array_value^) .. UPPERBOUND (source_array_value^)] IN
                new_space;
          overwrite_array := FALSE;
        ELSE
          new_array_value := #PTR (new_i_value^.array_value, new_value^);
          IF (LOWERBOUND (new_array_value^) <> LOWERBOUND (source_array_value^)) OR
                (UPPERBOUND (new_array_value^) <> UPPERBOUND (source_array_value^)) THEN
            NEXT new_array_value: [LOWERBOUND (source_array_value^) .. UPPERBOUND (source_array_value^)] IN
                  new_space;
            overwrite_array := FALSE;
          IFEND;
        IFEND;

        IF new_array_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_i_value^.array_value := #REL (new_array_value, new_value^);

        FOR i := LOWERBOUND (new_array_value^) TO UPPERBOUND (new_array_value^) DO
          IF source_array_value^ [i] = NIL THEN
            new_array_value^ [i] := NIL;
            IF migrate_graft_address = ^source_array_value^ [i] THEN
              migrate_graft_address := ^new_array_value^ [i];
            IFEND;
          ELSE
            IF NOT overwrite_array THEN
              new_array_value^ [i] := NIL;
            IFEND;
            copy_internal_value (source_value, ^source_array_value^ [i], new_value, ^new_array_value^ [i],
                  migrate_graft_address, new_space);
          IFEND;
        FOREND;

      PROCEND copy_array_value;
?? TITLE := 'copy_cobol_name_value', EJECT ??

      PROCEDURE [INLINE] copy_cobol_name_value;

        VAR
          new_cobol_name_value: ^clt$cobol_name,
          source_cobol_name_value: ^clt$cobol_name;


        source_cobol_name_value := #PTR (source_i_value^.cobol_name_value, source_value^);

        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$cobol_name;
          NEXT new_cobol_name_value IN new_space;
        ELSEIF new_i_value^.kind <> clc$cobol_name THEN
          new_i_value^.kind := clc$cobol_name;
          NEXT new_cobol_name_value IN new_space;
        ELSE
          new_cobol_name_value := #PTR (new_i_value^.cobol_name_value, new_value^);
        IFEND;

        IF new_cobol_name_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_cobol_name_value^ := source_cobol_name_value^;
        new_i_value^.cobol_name_value := #REL (new_cobol_name_value, new_value^);

      PROCEND copy_cobol_name_value;
?? TITLE := 'copy_command_reference_value', EJECT ??

      PROCEDURE [INLINE] copy_command_reference_value;

        VAR
          new_command_reference_value: ^clt$command_reference,
          source_command_reference_value: ^clt$command_reference;


        source_command_reference_value := #PTR (source_i_value^.command_reference_value, source_value^);

        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$command_reference;
          NEXT new_command_reference_value IN new_space;
        ELSEIF new_i_value^.kind <> clc$command_reference THEN
          new_i_value^.kind := clc$command_reference;
          NEXT new_command_reference_value IN new_space;
        ELSE
          new_command_reference_value := #PTR (new_i_value^.command_reference_value, new_value^);
        IFEND;

        IF new_command_reference_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_command_reference_value^ := source_command_reference_value^;
        new_i_value^.command_reference_value := #REL (new_command_reference_value, new_value^);

      PROCEND copy_command_reference_value;
?? TITLE := 'copy_data_name_value', EJECT ??

      PROCEDURE [INLINE] copy_data_name_value;

        VAR
          new_data_name_value: ^ost$name,
          source_data_name_value: ^ost$name;


        source_data_name_value := #PTR (source_i_value^.data_name_value, source_value^);

        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$data_name;
          NEXT new_data_name_value IN new_space;
        ELSEIF new_i_value^.kind <> clc$data_name THEN
          new_i_value^.kind := clc$data_name;
          NEXT new_data_name_value IN new_space;
        ELSE
          new_data_name_value := #PTR (new_i_value^.data_name_value, new_value^);
        IFEND;

        IF new_data_name_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_data_name_value^ := source_data_name_value^;
        new_i_value^.data_name_value := #REL (new_data_name_value, new_value^);

      PROCEND copy_data_name_value;
?? TITLE := 'copy_deferred_value', EJECT ??

      PROCEDURE [INLINE] copy_deferred_value;

        VAR
          new_deferred_value: ^clt$expression_text,
          source_deferred_value: ^clt$expression_text;


        source_deferred_value := #PTR (source_i_value^.deferred_value, source_value^);
        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$deferred;
          NEXT new_deferred_value: [STRLENGTH (source_deferred_value^)] IN new_space;
        ELSEIF new_i_value^.kind <> clc$deferred THEN
          new_i_value^.kind := clc$deferred;
          NEXT new_deferred_value: [STRLENGTH (source_deferred_value^)] IN new_space;
        ELSE
          new_deferred_value := #PTR (new_i_value^.deferred_value, new_value^);
          IF STRLENGTH (new_deferred_value^) < STRLENGTH (source_deferred_value^) THEN
            NEXT new_deferred_value: [STRLENGTH (source_deferred_value^)] IN new_space;
          ELSEIF STRLENGTH (new_deferred_value^) > STRLENGTH (source_deferred_value^) THEN
            new_deferred_value := ^new_deferred_value^ (1, STRLENGTH (source_deferred_value^));
          IFEND;
        IFEND;

        IF new_deferred_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_deferred_value^ := source_deferred_value^;
        new_i_value^.deferred_value := #REL (new_deferred_value, new_value^);

{ Since the only values that can be deferred are those of entire
{ variables and parameters (i.e. NOT components of structured values),
{ the deferred_type field is not stored internally since it can be
{ obtained from the descriptor of the variable or parameter when needed.

      PROCEND copy_deferred_value;
?? TITLE := 'copy_entry_point_ref_value', EJECT ??

      PROCEDURE [INLINE] copy_entry_point_ref_value;

        VAR
          new_entry_point_ref_value: ^pmt$entry_point_reference,
          source_entry_point_ref_value: ^pmt$entry_point_reference;


        source_entry_point_ref_value := #PTR (source_i_value^.entry_point_reference_value, source_value^);

        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$entry_point_reference;
          NEXT new_entry_point_ref_value IN new_space;
        ELSEIF new_i_value^.kind <> clc$entry_point_reference THEN
          new_i_value^.kind := clc$entry_point_reference;
          NEXT new_entry_point_ref_value IN new_space;
        ELSE
          new_entry_point_ref_value := #PTR (new_i_value^.entry_point_reference_value, new_value^);
        IFEND;

        IF new_entry_point_ref_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_entry_point_ref_value^ := source_entry_point_ref_value^;
        new_i_value^.entry_point_reference_value := #REL (new_entry_point_ref_value, new_value^);

      PROCEND copy_entry_point_ref_value;
?? TITLE := 'copy_file_value', EJECT ??

      PROCEDURE [INLINE] copy_file_value;

        VAR
          new_file_value: ^fst$file_reference,
          source_file_value: ^fst$file_reference;


        source_file_value := #PTR (source_i_value^.file_value, source_value^);
        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
*IF NOT $true(osv$unix)
          new_i_value^.kind := clc$file;
*ELSE
          new_i_value^.kind := source_i_value^.kind;
*IFEND
          NEXT new_file_value: [STRLENGTH (source_file_value^)] IN new_space;
*IF NOT $true(osv$unix)
        ELSEIF new_i_value^.kind <> clc$file THEN
          new_i_value^.kind := clc$file;
*ELSE
        ELSEIF NOT (new_i_value^.kind IN $clt$data_kinds [clc$nos_ve_file, clc$unix_file]) THEN
          new_i_value^.kind := source_i_value^.kind;
*IFEND
          NEXT new_file_value: [STRLENGTH (source_file_value^)] IN new_space;
        ELSE
*IF $true(osv$unix)
          new_i_value^.kind := source_i_value^.kind;
*IFEND
          new_file_value := #PTR (new_i_value^.file_value, new_value^);
          IF STRLENGTH (new_file_value^) < STRLENGTH (source_file_value^) THEN
            NEXT new_file_value: [STRLENGTH (source_file_value^)] IN new_space;
          ELSEIF STRLENGTH (new_file_value^) > STRLENGTH (source_file_value^) THEN
            new_file_value := ^new_file_value^ (1, STRLENGTH (source_file_value^));
          IFEND;
        IFEND;

        IF new_file_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_file_value^ := source_file_value^;
        new_i_value^.file_value := #REL (new_file_value, new_value^);

      PROCEND copy_file_value;
?? TITLE := 'copy_keyword_value', EJECT ??

      PROCEDURE [INLINE] copy_keyword_value;

        VAR
          new_keyword_value: ^clt$keyword,
          source_keyword_value: ^clt$keyword;


        source_keyword_value := #PTR (source_i_value^.keyword_value, source_value^);

        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$keyword;
          NEXT new_keyword_value IN new_space;
        ELSEIF new_i_value^.kind <> clc$keyword THEN
          new_i_value^.kind := clc$keyword;
          NEXT new_keyword_value IN new_space;
        ELSE
          new_keyword_value := #PTR (new_i_value^.keyword_value, new_value^);
        IFEND;

        IF new_keyword_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_keyword_value^ := source_keyword_value^;
        new_i_value^.keyword_value := #REL (new_keyword_value, new_value^);

      PROCEND copy_keyword_value;
?? TITLE := 'copy_list_value', EJECT ??

      PROCEDURE [INLINE] copy_list_value;

        VAR
          current_new_node: ^clt$i_data_value,
          current_source_node: ^clt$i_data_value,
          previous_new_node_link: ^ REL (clt$internal_data_value) ^clt$i_data_value;


        current_source_node := source_i_value;
        previous_new_node_link := NIL;
        current_new_node := new_i_value;

        REPEAT
          IF current_new_node = NIL THEN
            NEXT current_new_node IN new_space;
            IF current_new_node = NIL THEN
              work_area_overflow;
            IFEND;
            current_new_node^.kind := clc$list;
            current_new_node^.element_value := NIL;
            current_new_node^.link := NIL;
            current_new_node^.generated_via_list_rest := FALSE;
          ELSEIF current_new_node^.kind <> clc$list THEN
            current_new_node^.kind := clc$list;
            current_new_node^.element_value := NIL;
            current_new_node^.link := NIL;
            current_new_node^.generated_via_list_rest := FALSE;
          IFEND;

          IF previous_new_node_link = NIL THEN
            new_i_value := current_new_node;
            new_i_value^.generated_via_list_rest := source_i_value^.generated_via_list_rest;
          ELSE
            previous_new_node_link^ := #REL (current_new_node, new_value^);
          IFEND;

          IF current_source_node^.element_value = NIL THEN
            current_new_node^.element_value := NIL;
            IF migrate_graft_address = ^current_source_node^.element_value THEN
              migrate_graft_address := ^current_new_node^.element_value;
            IFEND;
          ELSE
            copy_internal_value (source_value, ^current_source_node^.element_value, new_value,
                  ^current_new_node^.element_value, migrate_graft_address, new_space);
          IFEND;

          previous_new_node_link := ^current_new_node^.link;
          current_new_node := #PTR (current_new_node^.link, new_value^);
          current_source_node := #PTR (current_source_node^.link, source_value^);
        UNTIL current_source_node = NIL;

        previous_new_node_link^ := NIL;

      PROCEND copy_list_value;
?? TITLE := 'copy_lock_value', EJECT ??

      PROCEDURE [INLINE] copy_lock_value;

        VAR
          new_lock_value: ^clt$lock,
          source_lock_value: ^clt$lock;


        source_lock_value := #PTR (source_i_value^.lock_value, source_value^);

        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$lock;
          NEXT new_lock_value IN new_space;
        ELSEIF new_i_value^.kind <> clc$lock THEN
          new_i_value^.kind := clc$lock;
          NEXT new_lock_value IN new_space;
        ELSE
          new_lock_value := #PTR (new_i_value^.lock_value, new_value^);
        IFEND;

        IF new_lock_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_lock_value^ := source_lock_value^;
        new_i_value^.lock_value := #REL (new_lock_value, new_value^);

      PROCEND copy_lock_value;
?? TITLE := 'copy_name_value', EJECT ??

      PROCEDURE [INLINE] copy_name_value;

        VAR
          new_name_value: ^ost$name,
          source_name_value: ^ost$name;


        source_name_value := #PTR (source_i_value^.name_value, source_value^);

        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$name;
          NEXT new_name_value IN new_space;
        ELSEIF new_i_value^.kind <> clc$name THEN
          new_i_value^.kind := clc$name;
          NEXT new_name_value IN new_space;
        ELSE
          new_name_value := #PTR (new_i_value^.name_value, new_value^);
        IFEND;

        IF new_name_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_name_value^ := source_name_value^;
        new_i_value^.name_value := #REL (new_name_value, new_value^);

      PROCEND copy_name_value;
?? TITLE := 'copy_network_title_value', EJECT ??

      PROCEDURE [INLINE] copy_network_title_value;

        VAR
          new_network_title_value: ^nat$title,
          source_network_title_value: ^nat$title;


        source_network_title_value := #PTR (source_i_value^.network_title_value, source_value^);
        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$network_title;
          NEXT new_network_title_value: [STRLENGTH (source_network_title_value^)] IN new_space;
        ELSEIF new_i_value^.kind <> clc$network_title THEN
          new_i_value^.kind := clc$network_title;
          NEXT new_network_title_value: [STRLENGTH (source_network_title_value^)] IN new_space;
        ELSE
          new_network_title_value := #PTR (new_i_value^.network_title_value, new_value^);
          IF STRLENGTH (new_network_title_value^) < STRLENGTH (source_network_title_value^) THEN
            NEXT new_network_title_value: [STRLENGTH (source_network_title_value^)] IN new_space;
          ELSEIF STRLENGTH (new_network_title_value^) > STRLENGTH (source_network_title_value^) THEN
            new_network_title_value := ^new_network_title_value^ (1, STRLENGTH (source_network_title_value^));
          IFEND;
        IFEND;

        IF new_network_title_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_network_title_value^ := source_network_title_value^;
        new_i_value^.network_title_value := #REL (new_network_title_value, new_value^);

      PROCEND copy_network_title_value;
?? TITLE := 'copy_program_name_value', EJECT ??

      PROCEDURE [INLINE] copy_program_name_value;

        VAR
          new_program_name_value: ^pmt$program_name,
          source_program_name_value: ^pmt$program_name;


        source_program_name_value := #PTR (source_i_value^.program_name_value, source_value^);

        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$program_name;
          NEXT new_program_name_value IN new_space;
        ELSEIF new_i_value^.kind <> clc$program_name THEN
          new_i_value^.kind := clc$program_name;
          NEXT new_program_name_value IN new_space;
        ELSE
          new_program_name_value := #PTR (new_i_value^.program_name_value, new_value^);
        IFEND;

        IF new_program_name_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_program_name_value^ := source_program_name_value^;
        new_i_value^.program_name_value := #REL (new_program_name_value, new_value^);

      PROCEND copy_program_name_value;
?? TITLE := 'copy_range_value', EJECT ??

      PROCEDURE [INLINE] copy_range_value;


        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$range;
          new_i_value^.low_value := NIL;
          new_i_value^.high_value := NIL;
        ELSEIF new_i_value^.kind <> clc$range THEN
          new_i_value^.kind := clc$range;
          new_i_value^.low_value := NIL;
          new_i_value^.high_value := NIL;
        IFEND;

        IF source_i_value^.low_value = NIL THEN
          new_i_value^.low_value := NIL;
          IF migrate_graft_address = ^source_i_value^.low_value THEN
            migrate_graft_address := ^new_i_value^.low_value;
          IFEND;
        ELSE
          copy_internal_value (source_value, ^source_i_value^.low_value, new_value, ^new_i_value^.low_value,
                migrate_graft_address, new_space);
        IFEND;

        IF source_i_value^.high_value = source_i_value^.low_value THEN
          new_i_value^.high_value := new_i_value^.low_value;
          IF migrate_graft_address = ^source_i_value^.high_value THEN
            migrate_graft_address := ^new_i_value^.high_value;
          IFEND;
        ELSE
          copy_internal_value (source_value, ^source_i_value^.high_value, new_value, ^new_i_value^.high_value,
                migrate_graft_address, new_space);
        IFEND;

      PROCEND copy_range_value;
?? TITLE := 'copy_record_value', EJECT ??

      PROCEDURE [INLINE] copy_record_value;

        VAR
          i: clt$field_number,
          new_field_values: ^array [1 .. * ] of clt$internal_field_value,
          overwrite_fields: boolean,
          source_field_values: ^array [1 .. * ] of clt$internal_field_value;


        source_field_values := #PTR (source_i_value^.field_values, source_value^);

        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$record;
          NEXT new_field_values: [1 .. UPPERBOUND (source_field_values^)] IN new_space;
          overwrite_fields := FALSE;
        ELSEIF new_i_value^.kind <> clc$record THEN
          new_i_value^.kind := clc$record;
          NEXT new_field_values: [1 .. UPPERBOUND (source_field_values^)] IN new_space;
          overwrite_fields := FALSE;
        ELSE
          new_field_values := #PTR (new_i_value^.field_values, new_value^);
          overwrite_fields := UPPERBOUND (new_field_values^) = UPPERBOUND (source_field_values^);
          IF NOT overwrite_fields THEN
            NEXT new_field_values: [1 .. UPPERBOUND (source_field_values^)] IN new_space;
          IFEND;
        IFEND;

        IF new_field_values = NIL THEN
          work_area_overflow;
        IFEND;

        new_i_value^.field_values := #REL (new_field_values, new_value^);

        FOR i := 1 TO UPPERBOUND (new_field_values^) DO
          new_field_values^ [i].name := source_field_values^ [i].name;
          IF source_field_values^ [i].value = NIL THEN
            new_field_values^ [i].value := NIL;
            IF migrate_graft_address = ^source_field_values^ [i].value THEN
              migrate_graft_address := ^new_field_values^ [i].value;
            IFEND;
          ELSE
            IF NOT overwrite_fields THEN
              new_field_values^ [i].value := NIL;
            IFEND;
            copy_internal_value (source_value, ^source_field_values^ [i].value, new_value,
                  ^new_field_values^ [i].value, migrate_graft_address, new_space);
          IFEND;
        FOREND;

      PROCEND copy_record_value;
?? TITLE := 'copy_status_value', EJECT ??

      PROCEDURE [INLINE] copy_status_value;

        VAR
          new_status_value: ^ost$status,
          source_status_value: ^ost$status;


        source_status_value := #PTR (source_i_value^.status_value, source_value^);

        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$status;
          NEXT new_status_value IN new_space;
        ELSEIF new_i_value^.kind <> clc$status THEN
          new_i_value^.kind := clc$status;
          NEXT new_status_value IN new_space;
        ELSE
          new_status_value := #PTR (new_i_value^.status_value, new_value^);
        IFEND;

        IF new_status_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_status_value^ := source_status_value^;
        new_i_value^.status_value := #REL (new_status_value, new_value^);

      PROCEND copy_status_value;
?? TITLE := 'copy_string_value', EJECT ??

      PROCEDURE [INLINE] copy_string_value;

        VAR
          new_string_value: ^clt$string_value,
          source_string_value: ^clt$string_value;


        source_string_value := #PTR (source_i_value^.string_value, source_value^);
        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$string;
          NEXT new_string_value: [STRLENGTH (source_string_value^)] IN new_space;
        ELSEIF new_i_value^.kind <> clc$string THEN
          new_i_value^.kind := clc$string;
          NEXT new_string_value: [STRLENGTH (source_string_value^)] IN new_space;
        ELSE
          new_string_value := #PTR (new_i_value^.string_value, new_value^);
          IF STRLENGTH (new_string_value^) < STRLENGTH (source_string_value^) THEN
            NEXT new_string_value: [STRLENGTH (source_string_value^)] IN new_space;
          ELSEIF STRLENGTH (new_string_value^) > STRLENGTH (source_string_value^) THEN
            new_string_value := ^new_string_value^ (1, STRLENGTH (source_string_value^));
          IFEND;
        IFEND;

        IF new_string_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_string_value^ := source_string_value^;
        new_i_value^.string_value := #REL (new_string_value, new_value^);

      PROCEND copy_string_value;
?? TITLE := 'copy_string_pattern_value', EJECT ??

      PROCEDURE [INLINE] copy_string_pattern_value;

        VAR
          new_string_pattern_value: ^clt$string_pattern,
          source_string_pattern_value: ^clt$string_pattern;


        source_string_pattern_value := #PTR (source_i_value^.string_pattern_value, source_value^);
        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$string_pattern;
          NEXT new_string_pattern_value: [[REP #SIZE (source_string_pattern_value^) OF cell]] IN new_space;
        ELSEIF new_i_value^.kind <> clc$string_pattern THEN
          new_i_value^.kind := clc$string_pattern;
          NEXT new_string_pattern_value: [[REP #SIZE (source_string_pattern_value^) OF cell]] IN new_space;
        ELSE
          new_string_pattern_value := #PTR (new_i_value^.string_pattern_value, new_value^);
          IF #SIZE (new_string_pattern_value^) <> #SIZE (source_string_pattern_value^) THEN
            NEXT new_string_pattern_value: [[REP #SIZE (source_string_pattern_value^) OF cell]] IN new_space;
          IFEND;
        IFEND;

        IF new_string_pattern_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_string_pattern_value^ := source_string_pattern_value^;
        new_i_value^.string_pattern_value := #REL (new_string_pattern_value, new_value^);

      PROCEND copy_string_pattern_value;
?? TITLE := 'copy_time_increment_value', EJECT ??

      PROCEDURE [INLINE] copy_time_increment_value;

        VAR
          new_time_increment_value: ^pmt$time_increment,
          source_time_increment_value: ^pmt$time_increment;


        source_time_increment_value := #PTR (source_i_value^.time_increment_value, source_value^);

        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$time_increment;
          NEXT new_time_increment_value IN new_space;
        ELSEIF new_i_value^.kind <> clc$time_increment THEN
          new_i_value^.kind := clc$time_increment;
          NEXT new_time_increment_value IN new_space;
        ELSE
          new_time_increment_value := #PTR (new_i_value^.time_increment_value, new_value^);
        IFEND;

        IF new_time_increment_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_time_increment_value^ := source_time_increment_value^;
        new_i_value^.time_increment_value := #REL (new_time_increment_value, new_value^);

      PROCEND copy_time_increment_value;
?? TITLE := 'copy_type_spec_value', EJECT ??

      PROCEDURE [INLINE] copy_type_spec_value;

        VAR
          new_type_specification_value: ^clt$type_specification,
          source_type_specification_value: ^clt$type_specification;


        source_type_specification_value := #PTR (source_i_value^.type_specification_value, source_value^);
        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
          new_i_value^.kind := clc$type_specification;
          NEXT new_type_specification_value: [[REP #SIZE (source_type_specification_value^) OF cell]] IN
                new_space;
        ELSEIF new_i_value^.kind <> clc$type_specification THEN
          new_i_value^.kind := clc$type_specification;
          NEXT new_type_specification_value: [[REP #SIZE (source_type_specification_value^) OF cell]] IN
                new_space;
        ELSE
          new_type_specification_value := #PTR (new_i_value^.type_specification_value, new_value^);
          IF #SIZE (new_type_specification_value^) <> #SIZE (source_type_specification_value^) THEN
            NEXT new_type_specification_value: [[REP #SIZE (source_type_specification_value^) OF cell]] IN
                  new_space;
          IFEND;
        IFEND;

        IF new_type_specification_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_type_specification_value^ := source_type_specification_value^;
        new_i_value^.type_specification_value := #REL (new_type_specification_value, new_value^);

      PROCEND copy_type_spec_value;
?? OLDTITLE, EJECT ??

      source_i_value := #PTR (source_component^, source_value^);
      new_i_value := #PTR (new_component^, new_value^);

      CASE source_i_value^.kind OF
      = clc$boolean, clc$date_time, clc$integer, clc$real, clc$scu_line_identifier, clc$statistic_code,
            clc$status_code, clc$time_zone, clc$unspecified =

        IF new_i_value = NIL THEN
          NEXT new_i_value IN new_space;
          IF new_i_value = NIL THEN
            work_area_overflow;
          IFEND;
        IFEND;
        new_i_value^ := source_i_value^;

      = clc$application =
        copy_application_value;
      = clc$array =
        copy_array_value;
      = clc$cobol_name =
        copy_cobol_name_value;
      = clc$command_reference =
        copy_command_reference_value;
      = clc$data_name =
        copy_data_name_value;
      = clc$deferred =
        copy_deferred_value;
      = clc$entry_point_reference =
        copy_entry_point_ref_value;
*IF NOT $true(osv$unix)
      = clc$file =
*ELSE
      = {clc$file} clc$nos_ve_file, clc$unix_file =
*IFEND
        copy_file_value;
      = clc$keyword =
        copy_keyword_value;
      = clc$list =
        copy_list_value;
      = clc$lock =
        copy_lock_value;
      = clc$name =
        copy_name_value;
      = clc$network_title =
        copy_network_title_value;
      = clc$program_name =
        copy_program_name_value;
      = clc$range =
        copy_range_value;
      = clc$record =
        copy_record_value;
      = clc$status =
        copy_status_value;
      = clc$string =
        copy_string_value;
      = clc$string_pattern =
        copy_string_pattern_value;
      = clc$time_increment =
        copy_time_increment_value;
      = clc$type_specification =
        copy_type_spec_value;
      ELSE
        bad_internal_value;
      CASEND;

      IF new_i_value = NIL THEN
        work_area_overflow;
      IFEND;

      new_component^ := #REL (new_i_value, new_value^);

      IF migrate_graft_address = source_component THEN
        migrate_graft_address := new_component;
      IFEND;

    PROCEND copy_internal_value;
?? TITLE := 'work_area_overflow', EJECT ??

    PROCEDURE [INLINE] work_area_overflow;


      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      EXIT clp$change_internal_value;

    PROCEND work_area_overflow;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    original_work_area := work_area;
    #SPOIL (original_work_area);
    osp$establish_condition_handler (^abort_handler, TRUE);

    new_value_size := #OFFSET (work_area) + i#current_sequence_position (work_area) - #OFFSET (new_value) -
          #SIZE (clt$internal_data_value_header);

    IF old_value = NIL THEN
      RESET work_area TO new_value;
      NEXT new_value: [[REP new_value_size OF cell]] IN work_area;

    ELSEIF graft_address = NIL THEN
      IF change_in_place AND (new_value_size <= #SIZE (old_value^.allocated_space)) THEN
        RESET work_area TO new_value;
        NEXT new_value: [[REP new_value_size OF cell]] IN work_area;
        old_allocated_space := ^old_value^.allocated_space;
        RESET old_allocated_space;
        NEXT old_space: [[REP new_value_size OF cell]] IN old_allocated_space;
        old_space^ := new_value^.allocated_space;
        old_value^.header.value := new_value^.header.value;
        old_value^.header.unused_space := #SIZE (old_value^.allocated_space) - new_value_size;
        new_value := old_value;

      ELSE
        minimum_new_value_size := #SIZE (old_value^.allocated_space) +
              old_value^.header.minimum_allocation_increment;
        IF new_value_size < minimum_new_value_size THEN
          new_value^.header.unused_space := minimum_new_value_size - new_value_size;
          NEXT skip_space: [1 .. new_value^.header.unused_space] IN work_area;
          new_value_size := minimum_new_value_size;
        IFEND;
        RESET work_area TO new_value;
        NEXT new_value: [[REP new_value_size OF cell]] IN work_area;
      IFEND;

    ELSE
      replacement_value := new_value;
      minimum_new_value_size := #SIZE (old_value^.allocated_space) +
            old_value^.header.minimum_allocation_increment;
      IF NOT change_in_place THEN
        copy_new_into_old := FALSE;
      ELSEIF graft_address^ = NIL THEN
        copy_new_into_old := new_value_size <= old_value^.header.unused_space;
      ELSE
        copy_new_into_old := (new_value_size - #SIZE (clt$i_data_value)) <= old_value^.header.unused_space;
      IFEND;
      actual_graft_address := graft_address;

      IF copy_new_into_old THEN
        new_value := old_value;
        new_space := ^new_value^.allocated_space;
        RESET new_space;
        IF new_value^.header.unused_space < #SIZE (new_value^.allocated_space) THEN
          NEXT skip_space: [1 .. #SIZE (new_value^.allocated_space) - new_value^.header.unused_space] IN
                new_space;
        IFEND;
      ELSE
        new_value_size := #SIZE (old_value^.allocated_space) + new_value_size;
        IF new_value_size < minimum_new_value_size THEN
          new_value_size := minimum_new_value_size;
        IFEND;
        NEXT new_value: [[REP new_value_size OF cell]] IN work_area;
        IF new_value = NIL THEN
          work_area_overflow;
        IFEND;
        new_value^.header.value := NIL;
        new_value^.header.unused_space := new_value_size;
        new_value^.header.minimum_allocation_increment := old_value^.header.minimum_allocation_increment;
        new_space := ^new_value^.allocated_space;
        RESET new_space;
        copy_internal_value (old_value, ^old_value^.header.value, new_value, ^new_value^.header.value,
              actual_graft_address, new_space);
      IFEND;

      ignore_graft_address := NIL;
      copy_internal_value (replacement_value, ^replacement_value^.header.value, new_value,
            actual_graft_address, ignore_graft_address, new_space);

      new_value^.header.unused_space := #SIZE (new_value^.allocated_space) -
            i#current_sequence_position (new_space);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND clp$change_internal_value;
?? TITLE := 'clp$convert_ext_value_to_int', EJECT ??

  PROCEDURE [XDCL] clp$convert_ext_value_to_int
    (    initializing_type_description: ^clt$type_description;
         external_value: ^clt$data_value;
         internal_component_address: ^ REL (clt$internal_data_value) ^clt$i_data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR internal_value {input, output} : ^clt$internal_data_value;
     VAR status: ost$status);

    VAR
*IF NOT $true(osv$unix)
      value_kinds: [STATIC, READ, oss$job_paged_literal] array [clt$type_kind] of
            clt$data_kind := [clc$application, clc$array, clc$boolean, clc$cobol_name, clc$command_reference,
            clc$data_name, clc$date_time, clc$entry_point_reference, clc$file, clc$integer, clc$keyword,
            clc$list, clc$lock, clc$name, clc$network_title, clc$program_name, clc$range, clc$real,
            clc$record, clc$scu_line_identifier, clc$statistic_code, clc$status, clc$status_code, clc$string,
            clc$string_pattern, clc$time_increment, clc$time_zone, clc$type_specification, clc$unspecified];
*ELSE
      value_kinds: [STATIC, READ, oss$job_paged_literal] array [clc$application_type .. clc$unix_file_type] of
            clt$data_kind := [clc$application, clc$array, clc$boolean, clc$cobol_name, clc$command_reference,
            clc$data_name, clc$date_time, clc$entry_point_reference, clc$nos_ve_file, clc$integer,
            clc$keyword, clc$list, clc$lock, clc$name, clc$network_title, clc$program_name, clc$range,
            clc$real, clc$record, clc$scu_line_identifier, clc$statistic_code, clc$status, clc$status_code,
            clc$string, clc$string_pattern, clc$time_increment, clc$time_zone, clc$type_specification,
            clc$unspecified, clc$unix_file];
*IFEND

    VAR
      component_address: ^ REL (clt$internal_data_value) ^clt$i_data_value,
      header: ^clt$internal_data_value_header,
      i_value: ^clt$i_data_value,
      increment_size: clt$internal_data_value_size,
      initial_conversion: boolean,
      initial_position: integer,
      kind: clt$data_kind,
      original_work_area: ^clt$work_area,
      space_size: integer,
      unused_space: clt$internal_data_value_size;

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

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


      CASE condition.selector OF

      = pmc$block_exit_processing =
        work_area := original_work_area;
        #SPOIL (work_area);
        RETURN;

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          bad_external_value;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          bad_external_value;
        IFEND;

      = mmc$segment_access_condition =
        CASE condition.segment_access_condition.identifier OF
        = mmc$sac_read_beyond_eoi =
          bad_external_value;
        = mmc$sac_read_write_beyond_msl, mmc$sac_no_append_permission =
*IF $true(osv$unix)
          bad_external_value;
*ELSE
          IF #SEGMENT (condition.segment_access_condition.segment) = #SEGMENT (work_area) THEN
            work_area_overflow;
          ELSE
            bad_external_value;
          IFEND;
*IFEND
        ELSE
          ;
        CASEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? TITLE := 'bad_external_value', EJECT ??

    PROCEDURE bad_external_value;


      osp$set_status_abnormal ('CL', cle$bad_data_value, '', status);
      EXIT clp$convert_ext_value_to_int;

    PROCEND bad_external_value;
?? TITLE := 'convert_ext_value_to_int', EJECT ??

    PROCEDURE convert_ext_value_to_int
      (    type_description: ^clt$type_description;
           external_value: ^clt$data_value;
       VAR rel_i_value: REL (clt$internal_data_value) ^clt$i_data_value;
       VAR unused_space: clt$internal_data_value_size;
       VAR increment_size: clt$internal_data_value_size);

      VAR
        computed_increment_size: integer,
        computed_unused_space: integer,
        element_increment_size: clt$internal_data_value_size,
        element_type_description: ^clt$type_description,
        element_unused_space: clt$internal_data_value_size,
        ignore_rel_i_value: REL (clt$internal_data_value) ^clt$i_data_value,
        i_value: ^clt$i_data_value;

?? NEWTITLE := 'convert_application_value', EJECT ??

      PROCEDURE [INLINE] convert_application_value;

        VAR
          application_value: ^clt$application_value_text;


        IF external_value = NIL THEN
          unused_space := unused_space + nominal_application_size;
        ELSE

          NEXT application_value: [STRLENGTH (external_value^.application_value^)] IN work_area;
          IF application_value = NIL THEN
            work_area_overflow;
          IFEND;

          application_value^ := external_value^.application_value^;

          i_value^.application_value := #REL (application_value, internal_value^);
        IFEND;

        increment_size := application_size_increment;

      PROCEND convert_application_value;
?? TITLE := 'convert_array_value', EJECT ??

      PROCEDURE [INLINE] convert_array_value;

        VAR
          elements: ^array [ * ] of REL (clt$internal_data_value) ^clt$i_data_value,
          i: clt$array_bound,
          number_of_elements: integer;


        number_of_elements := 1;
        IF (type_description <> NIL) AND (type_description^.kind = clc$array_type) THEN
          IF type_description^.array_bounds_defined THEN
            number_of_elements := type_description^.bounds.upper - type_description^.bounds.lower + 1;
          IFEND;
          element_type_description := type_description^.array_element_type_description;
        ELSE
          element_type_description := NIL;
        IFEND;

        IF number_of_elements > (osc$max_segment_length DIV #SIZE (clt$data_value)) THEN
          work_area_overflow;
        IFEND;

        IF external_value = NIL THEN
          convert_ext_value_to_int (element_type_description, NIL, ignore_rel_i_value, element_unused_space,
                element_increment_size);
          computed_unused_space := unused_space + (number_of_elements * element_unused_space);
          computed_increment_size := number_of_elements * element_increment_size;

        ELSE
          NEXT elements: [LOWERBOUND (external_value^.array_value^) .. UPPERBOUND (external_value^.
                array_value^)] IN work_area;
          IF elements = NIL THEN
            work_area_overflow;
          IFEND;
          IF (i#current_sequence_position (work_area) - initial_position) > clv$max_variable_allocation THEN
            work_area_overflow;
          IFEND;
          i_value^.array_value := #REL (elements, internal_value^);

          computed_unused_space := unused_space;
          computed_increment_size := 0;
          FOR i := LOWERBOUND (external_value^.array_value^) TO UPPERBOUND (external_value^.array_value^) DO
            IF external_value^.array_value^ [i] = NIL THEN
              elements^ [i] := NIL;
            ELSE
              convert_ext_value_to_int (element_type_description, external_value^.array_value^ [i],
                    elements^ [i], element_unused_space, element_increment_size);
              computed_unused_space := computed_unused_space + element_unused_space;
              computed_increment_size := computed_increment_size + element_increment_size;
              IF (i#current_sequence_position (work_area) - initial_position) > clv$max_variable_allocation
                    THEN
                work_area_overflow;
              IFEND;
            IFEND;
          FOREND;
        IFEND;

        IF computed_unused_space <= max_unused_space THEN
          unused_space := computed_unused_space;
        ELSE
          unused_space := max_unused_space;
        IFEND;

        IF computed_increment_size <= max_increment_size THEN
          increment_size := computed_increment_size;
        ELSE
          increment_size := max_increment_size;
        IFEND;

      PROCEND convert_array_value;
?? TITLE := 'convert_boolean_value', EJECT ??

      PROCEDURE [INLINE] convert_boolean_value;


        IF external_value <> NIL THEN
          i_value^.boolean_value := external_value^.boolean_value;
        IFEND;

      PROCEND convert_boolean_value;
?? TITLE := 'convert_cobol_name_value', EJECT ??

      PROCEDURE [INLINE] convert_cobol_name_value;

        VAR
          cobol_name: ^clt$cobol_name;


        IF external_value = NIL THEN
          unused_space := unused_space + #SIZE (clt$cobol_name);
        ELSE

          NEXT cobol_name IN work_area;
          IF cobol_name = NIL THEN
            work_area_overflow;
          IFEND;

          cobol_name^ := external_value^.cobol_name_value;

          i_value^.cobol_name_value := #REL (cobol_name, internal_value^);
        IFEND;

      PROCEND convert_cobol_name_value;
?? TITLE := ' convert_command_reference_value', EJECT ??

      PROCEDURE [INLINE] convert_command_reference_value;

        VAR
          command_reference: ^clt$command_reference;


        IF external_value = NIL THEN
          unused_space := unused_space + #SIZE (clt$command_reference);
        ELSE

          NEXT command_reference IN work_area;
          IF command_reference = NIL THEN
            work_area_overflow;
          IFEND;

          command_reference^ := external_value^.command_reference_value^;

          i_value^.command_reference_value := #REL (command_reference, internal_value^);
        IFEND;

      PROCEND convert_command_reference_value;
?? TITLE := 'convert_data_name_value', EJECT ??

      PROCEDURE [INLINE] convert_data_name_value;

        VAR
          data_name: ^ost$name;


        IF external_value = NIL THEN
          unused_space := unused_space + #SIZE (ost$name);
        ELSE

          NEXT data_name IN work_area;
          IF data_name = NIL THEN
            work_area_overflow;
          IFEND;

          data_name^ := external_value^.data_name_value;

          i_value^.data_name_value := #REL (data_name, internal_value^);
        IFEND;

      PROCEND convert_data_name_value;
?? TITLE := 'convert_date_time_value', EJECT ??

      PROCEDURE [INLINE] convert_date_time_value;


        IF external_value <> NIL THEN
          i_value^.date_time_value := external_value^.date_time_value;
        IFEND;

      PROCEND convert_date_time_value;
?? TITLE := 'convert_deferred_value', EJECT ??

      PROCEDURE [INLINE] convert_deferred_value;

        VAR
          deferred_value: ^clt$expression_text;


        IF external_value = NIL THEN
          unused_space := unused_space + nominal_deferred_value_size;
        ELSE

          NEXT deferred_value: [clp$trimmed_string_size (external_value^.deferred_value^)] IN work_area;
          IF deferred_value = NIL THEN
            work_area_overflow;
          IFEND;

          deferred_value^ := external_value^.deferred_value^;

          i_value^.deferred_value := #REL (deferred_value, internal_value^);
        IFEND;

        increment_size := deferred_size_increment;

{ Since the only values that can be deferred are those of entire
{ variables and parameters (i.e. NOT components of structured values),
{ the deferred_type field is not stored internally since it can be
{ obtained from the descriptor of the variable or parameter when needed.

      PROCEND convert_deferred_value;
?? TITLE := 'convert_entry_point_ref_value', EJECT ??

      PROCEDURE [INLINE] convert_entry_point_ref_value;

        VAR
          entry_point_reference: ^pmt$entry_point_reference;


        IF external_value = NIL THEN
          unused_space := unused_space + #SIZE (pmt$entry_point_reference);
        ELSE

          NEXT entry_point_reference IN work_area;
          IF entry_point_reference = NIL THEN
            work_area_overflow;
          IFEND;

          entry_point_reference^ := external_value^.entry_point_reference_value^;

          i_value^.entry_point_reference_value := #REL (entry_point_reference, internal_value^);
        IFEND;

      PROCEND convert_entry_point_ref_value;
?? TITLE := 'convert_file_value', EJECT ??

      PROCEDURE [INLINE] convert_file_value;

        VAR
          file_value: ^fst$file_reference;


        IF external_value = NIL THEN
          unused_space := unused_space + nominal_file_size;
        ELSE

          NEXT file_value: [clp$trimmed_string_size (external_value^.file_value^)] IN work_area;
          IF file_value = NIL THEN
            work_area_overflow;
          IFEND;

          file_value^ := external_value^.file_value^;

          i_value^.file_value := #REL (file_value, internal_value^);
        IFEND;

        increment_size := file_size_increment;

      PROCEND convert_file_value;
?? TITLE := 'convert_integer_value', EJECT ??

      PROCEDURE [INLINE] convert_integer_value;


        IF external_value <> NIL THEN
          i_value^.integer_value := external_value^.integer_value;
        IFEND;

      PROCEND convert_integer_value;
?? TITLE := 'convert_keyword_value', EJECT ??

      PROCEDURE [INLINE] convert_keyword_value;

        VAR
          keyword: ^clt$keyword;


        IF external_value = NIL THEN
          unused_space := unused_space + #SIZE (clt$keyword);
        ELSE

          NEXT keyword IN work_area;
          IF keyword = NIL THEN
            work_area_overflow;
          IFEND;

          keyword^ := external_value^.keyword_value;

          i_value^.keyword_value := #REL (keyword, internal_value^);
        IFEND;

      PROCEND convert_keyword_value;
?? TITLE := 'convert_list_value', EJECT ??

      PROCEDURE [INLINE] convert_list_value;

        VAR
          current_i_node: ^clt$i_data_value,
          current_node: ^clt$data_value,
          computed_list_size: clt$list_size,
          previous_i_node: ^clt$i_data_value;


        IF (type_description <> NIL) AND (type_description^.kind = clc$list_type) THEN
          IF type_description^.max_list_size < nominal_list_size THEN
            computed_list_size := type_description^.max_list_size;
          ELSEIF type_description^.min_list_size > nominal_list_size THEN
            computed_list_size := type_description^.min_list_size;
          ELSE
            computed_list_size := nominal_list_size;
          IFEND;
          element_type_description := type_description^.list_element_type_description;
        ELSE
          element_type_description := NIL;
          computed_list_size := nominal_list_size;
        IFEND;

        IF external_value = NIL THEN
          convert_ext_value_to_int (element_type_description, NIL, ignore_rel_i_value, element_unused_space,
                element_increment_size);
          computed_unused_space := unused_space + (computed_list_size * element_unused_space);
          computed_increment_size := computed_list_size * element_increment_size;

        ELSE
          computed_unused_space := unused_space;
          computed_increment_size := 0;

          i_value^.element_value := NIL;
          i_value^.link := NIL;
          i_value^.generated_via_list_rest := external_value^.generated_via_list_rest;
          current_i_node := i_value;
          current_node := external_value;

          REPEAT
            IF current_node^.element_value = NIL THEN
              current_i_node^.element_value := NIL;
            ELSE
              convert_ext_value_to_int (element_type_description, current_node^.element_value,
                    current_i_node^.element_value, element_unused_space, element_increment_size);
              computed_unused_space := computed_unused_space + element_unused_space;
              computed_increment_size := computed_increment_size + element_increment_size;
              IF (i#current_sequence_position (work_area) - initial_position) > clv$max_variable_allocation
                    THEN
                work_area_overflow;
              IFEND;
            IFEND;

            current_node := current_node^.link;
            IF current_node <> NIL THEN
              previous_i_node := current_i_node;
              NEXT current_i_node IN work_area;
              IF current_i_node = NIL THEN
                work_area_overflow;
              IFEND;
              current_i_node^.kind := clc$list;
              current_i_node^.element_value := NIL;
              current_i_node^.link := NIL;
              current_i_node^.generated_via_list_rest := FALSE;
              previous_i_node^.link := #REL (current_i_node, internal_value^);
            IFEND;
          UNTIL current_node = NIL;
        IFEND;

        IF computed_unused_space <= max_unused_space THEN
          unused_space := computed_unused_space;
        ELSE
          unused_space := max_unused_space;
        IFEND;

        IF computed_increment_size <= max_increment_size THEN
          increment_size := computed_increment_size;
        ELSE
          increment_size := max_increment_size;
        IFEND;

      PROCEND convert_list_value;
?? TITLE := 'convert_lock_value', EJECT ??

      PROCEDURE [INLINE] convert_lock_value;

        VAR
          lock_value: ^clt$lock;


        IF external_value = NIL THEN
          unused_space := unused_space + #SIZE (clt$lock);
        ELSE

          NEXT lock_value IN work_area;
          IF lock_value = NIL THEN
            work_area_overflow;
          IFEND;

          lock_value^ := external_value^.lock_value^;

          i_value^.lock_value := #REL (lock_value, internal_value^);
        IFEND;

      PROCEND convert_lock_value;
?? TITLE := 'convert_name_value', EJECT ??

      PROCEDURE [INLINE] convert_name_value;


        VAR
          name: ^ost$name;


        IF external_value = NIL THEN
          unused_space := unused_space + #SIZE (ost$name);
        ELSE

          NEXT name IN work_area;
          IF name = NIL THEN
            work_area_overflow;
          IFEND;

          name^ := external_value^.name_value;

          i_value^.name_value := #REL (name, internal_value^);
        IFEND;

      PROCEND convert_name_value;
?? TITLE := 'convert_network_title_value', EJECT ??

      PROCEDURE [INLINE] convert_network_title_value;

        VAR
          network_title_value: ^nat$title;


        IF external_value = NIL THEN
          unused_space := unused_space + nominal_network_title_size;
        ELSE

          NEXT network_title_value: [clp$trimmed_string_size (external_value^.network_title_value^)] IN
                work_area;
          IF network_title_value = NIL THEN
            work_area_overflow;
          IFEND;

          network_title_value^ := external_value^.network_title_value^;

          i_value^.network_title_value := #REL (network_title_value, internal_value^);
        IFEND;

        increment_size := network_title_size_increment;

      PROCEND convert_network_title_value;
?? TITLE := 'convert_program_name_value', EJECT ??

      PROCEDURE [INLINE] convert_program_name_value;

        VAR
          program_name: ^pmt$program_name;


        IF external_value = NIL THEN
          unused_space := unused_space + #SIZE (pmt$program_name);
        ELSE

          NEXT program_name IN work_area;
          IF program_name = NIL THEN
            work_area_overflow;
          IFEND;

          program_name^ := external_value^.program_name_value;

          i_value^.program_name_value := #REL (program_name, internal_value^);
        IFEND;

      PROCEND convert_program_name_value;
?? TITLE := 'convert_range_value', EJECT ??

      PROCEDURE [INLINE] convert_range_value;


        IF (type_description <> NIL) AND (type_description^.kind = clc$range_type) THEN
          element_type_description := type_description^.range_element_type_description;
        ELSE
          element_type_description := NIL;
        IFEND;

        IF external_value = NIL THEN
          convert_ext_value_to_int (element_type_description, NIL, ignore_rel_i_value, element_unused_space,
                element_increment_size);
          computed_unused_space := unused_space + (2 * element_unused_space);
          computed_increment_size := 2 * element_increment_size;

        ELSE
          computed_unused_space := unused_space;
          computed_increment_size := 0;
          IF external_value^.low_value = NIL THEN
            i_value^.low_value := NIL;
          ELSE
            convert_ext_value_to_int (element_type_description, external_value^.low_value, i_value^.low_value,
                  element_unused_space, element_increment_size);
            computed_unused_space := computed_unused_space + element_unused_space;
            computed_increment_size := computed_increment_size + element_increment_size;
            IF (i#current_sequence_position (work_area) - initial_position) > clv$max_variable_allocation THEN
              work_area_overflow;
            IFEND;
          IFEND;

          IF external_value^.high_value = external_value^.low_value THEN
            i_value^.high_value := i_value^.low_value;
          ELSE
            convert_ext_value_to_int (element_type_description, external_value^.high_value,
                  i_value^.high_value, element_unused_space, element_increment_size);
            computed_unused_space := computed_unused_space + element_unused_space;
            computed_increment_size := computed_increment_size + element_increment_size;
            IF (i#current_sequence_position (work_area) - initial_position) > clv$max_variable_allocation THEN
              work_area_overflow;
            IFEND;
          IFEND;
        IFEND;

        IF computed_unused_space <= max_unused_space THEN
          unused_space := computed_unused_space;
        ELSE
          unused_space := max_unused_space;
        IFEND;

        IF computed_increment_size <= max_increment_size THEN
          increment_size := computed_increment_size;
        ELSE
          increment_size := max_increment_size;
        IFEND;

      PROCEND convert_range_value;
?? TITLE := 'convert_real_value', EJECT ??

      PROCEDURE [INLINE] convert_real_value;


        IF external_value <> NIL THEN
          i_value^.real_value := external_value^.real_value;
        IFEND;

      PROCEND convert_real_value;
?? TITLE := 'convert_record_value', EJECT ??

      PROCEDURE [INLINE] convert_record_value;

        VAR
          fields: ^array [1 .. * ] of clt$internal_field_value,
          i: clt$field_number,
          number_of_fields: clt$field_number;


        IF external_value = NIL THEN
          number_of_fields := type_description^.fields_pdt^.header^.number_of_parameters;
        ELSE
          NEXT fields: [1 .. UPPERBOUND (external_value^.field_values^)] IN work_area;
          IF fields = NIL THEN
            work_area_overflow;
          IFEND;
          IF (i#current_sequence_position (work_area) - initial_position) > clv$max_variable_allocation THEN
            work_area_overflow;
          IFEND;
          i_value^.field_values := #REL (fields, internal_value^);
          number_of_fields := UPPERBOUND (external_value^.field_values^);
        IFEND;

        computed_unused_space := unused_space;
        computed_increment_size := 0;
        FOR i := 1 TO number_of_fields DO
          IF (type_description <> NIL) AND (type_description^.kind = clc$record_type) AND ((external_value =
                NIL) OR ((UPPERBOUND (external_value^.field_values^) = type_description^.fields_pdt^.header^.
                number_of_parameters) AND (external_value^.field_values^ [i].name =
                type_description^.fields_pdt^.names^ [i].name))) THEN
            element_type_description := ^type_description^.fields_pdt^.type_descriptions^ [i];
          ELSE
            element_type_description := NIL;
          IFEND;

          IF external_value = NIL THEN
            convert_ext_value_to_int (element_type_description, NIL, ignore_rel_i_value, element_unused_space,
                  element_increment_size);
          ELSE

            fields^ [i].name := external_value^.field_values^ [i].name;
            IF external_value^.field_values^ [i].value = NIL THEN
              fields^ [i].value := NIL;
            ELSE
              convert_ext_value_to_int (element_type_description, external_value^.field_values^ [i].value,
                    fields^ [i].value, element_unused_space, element_increment_size);
              IF (i#current_sequence_position (work_area) - initial_position) > clv$max_variable_allocation
                    THEN
                work_area_overflow;
              IFEND;
            IFEND;
          IFEND;

          computed_unused_space := unused_space + element_unused_space;
          computed_increment_size := computed_increment_size + element_increment_size;
        FOREND;

        IF computed_unused_space <= max_unused_space THEN
          unused_space := computed_unused_space;
        ELSE
          unused_space := max_unused_space;
        IFEND;

        IF computed_increment_size <= max_increment_size THEN
          increment_size := computed_increment_size;
        ELSE
          increment_size := max_increment_size;
        IFEND;

      PROCEND convert_record_value;
?? TITLE := 'convert_scu_line_id_value', EJECT ??

      PROCEDURE [INLINE] convert_scu_line_id_value;


        IF external_value <> NIL THEN
          i_value^.scu_line_identifier_value := external_value^.scu_line_identifier_value;
        IFEND;

      PROCEND convert_scu_line_id_value;
?? TITLE := 'convert_statistic_code_value', EJECT ??

      PROCEDURE [INLINE] convert_statistic_code_value;


        IF external_value <> NIL THEN
          i_value^.statistic_code_value := external_value^.statistic_code_value;
        IFEND;

      PROCEND convert_statistic_code_value;
?? TITLE := 'convert_status_value', EJECT ??

      PROCEDURE [INLINE] convert_status_value;

        VAR
          status_value: ^ost$status;


        IF external_value = NIL THEN
          unused_space := unused_space + #SIZE (ost$status);
        ELSE

          NEXT status_value IN work_area;
          IF status_value = NIL THEN
            work_area_overflow;
          IFEND;

          status_value^ := external_value^.status_value^;

          i_value^.status_value := #REL (status_value, internal_value^);
        IFEND;

      PROCEND convert_status_value;
?? TITLE := 'convert_status_code_value', EJECT ??

      PROCEDURE [INLINE] convert_status_code_value;

        IF external_value <> NIL THEN
          i_value^.status_code_value := external_value^.status_code_value;
        IFEND;

      PROCEND convert_status_code_value;
?? TITLE := 'convert_string_value', EJECT ??

      PROCEDURE [INLINE] convert_string_value;

        VAR
          computed_string_size: clt$string_size,
          string_value: ^clt$string_value;


        IF (type_description <> NIL) AND (type_description^.kind = clc$string_type) THEN
          IF type_description^.max_string_size < nominal_string_size THEN
            computed_string_size := type_description^.max_string_size;
          ELSEIF type_description^.min_string_size > nominal_string_size THEN
            computed_string_size := type_description^.min_string_size;
          ELSE
            computed_string_size := nominal_string_size;
          IFEND;
        ELSE
          computed_string_size := nominal_string_size;
        IFEND;

        IF external_value = NIL THEN
          unused_space := unused_space + computed_string_size;
        ELSE
          IF computed_string_size > STRLENGTH (external_value^.string_value^) THEN
            unused_space := computed_string_size - STRLENGTH (external_value^.string_value^);
          IFEND;

          NEXT string_value: [STRLENGTH (external_value^.string_value^)] IN work_area;
          IF string_value = NIL THEN
            work_area_overflow;
          IFEND;

          string_value^ := external_value^.string_value^;

          i_value^.string_value := #REL (string_value, internal_value^);
        IFEND;

        IF computed_string_size <= string_size_increment THEN
          increment_size := computed_string_size;
        ELSE
          increment_size := string_size_increment;
        IFEND;

      PROCEND convert_string_value;
?? TITLE := 'convert_string_pattern_value', EJECT ??

      PROCEDURE [INLINE] convert_string_pattern_value;

        VAR
          string_pattern: ^clt$string_pattern;


        IF external_value <> NIL THEN
          NEXT string_pattern: [[REP #SIZE (external_value^.string_pattern_value^) OF cell]] IN work_area;
          IF string_pattern = NIL THEN
            work_area_overflow;
          IFEND;

          string_pattern^ := external_value^.string_pattern_value^;

          i_value^.string_pattern_value := #REL (string_pattern, internal_value^);
        IFEND;

      PROCEND convert_string_pattern_value;
?? TITLE := 'convert_time_increment_value', EJECT ??

      PROCEDURE [INLINE] convert_time_increment_value;

        VAR
          time_increment_value: ^pmt$time_increment;


        IF external_value = NIL THEN
          unused_space := unused_space + #SIZE (pmt$time_increment);
        ELSE

          NEXT time_increment_value IN work_area;
          IF time_increment_value = NIL THEN
            work_area_overflow;
          IFEND;

          time_increment_value^ := external_value^.time_increment_value^;

          i_value^.time_increment_value := #REL (time_increment_value, internal_value^);
        IFEND;

      PROCEND convert_time_increment_value;
?? TITLE := 'convert_time_zone_value', EJECT ??

      PROCEDURE [INLINE] convert_time_zone_value;


        IF external_value <> NIL THEN
          i_value^.time_zone_value := external_value^.time_zone_value;
        IFEND;

      PROCEND convert_time_zone_value;
?? TITLE := 'convert_type_spec_value', EJECT ??

      PROCEDURE [INLINE] convert_type_spec_value;

        VAR
          type_specification: ^clt$type_specification;


        IF external_value = NIL THEN
          unused_space := unused_space + #SIZE (clt$type_specification_header);
        ELSE

          NEXT type_specification: [[REP #SIZE (external_value^.type_specification_value^) OF cell]] IN
                work_area;
          IF type_specification = NIL THEN
            work_area_overflow;
          IFEND;

          type_specification^ := external_value^.type_specification_value^;

          i_value^.type_specification_value := #REL (type_specification, internal_value^);
        IFEND;

      PROCEND convert_type_spec_value;
?? OLDTITLE, EJECT ??

      increment_size := 0;
      unused_space := 0;
      IF external_value = NIL THEN
        i_value := NIL;
        rel_i_value := NIL;
        IF type_description = NIL THEN
          RETURN;
        IFEND;
        unused_space := #SIZE (clt$i_data_value);
        kind := value_kinds [type_description^.kind];
      ELSE
        NEXT i_value IN work_area;
        IF i_value = NIL THEN
          work_area_overflow;
        IFEND;
        rel_i_value := #REL (i_value, internal_value^);
        i_value^.kind := external_value^.kind;
        kind := i_value^.kind;
      IFEND;

      CASE kind OF
      = clc$application =
        convert_application_value;
      = clc$array =
        convert_array_value;
      = clc$boolean =
        convert_boolean_value;
      = clc$cobol_name =
        convert_cobol_name_value;
      = clc$command_reference =
        convert_command_reference_value;
      = clc$data_name =
        convert_data_name_value;
      = clc$date_time =
        convert_date_time_value;
      = clc$deferred =
        convert_deferred_value;
      = clc$entry_point_reference =
        convert_entry_point_ref_value;
*IF NOT $true(osv$unix)
      = clc$file =
*ELSE
      = {clc$file} clc$nos_ve_file, clc$unix_file =
*IFEND
        convert_file_value;
      = clc$integer =
        convert_integer_value;
      = clc$keyword =
        convert_keyword_value;
      = clc$list =
        convert_list_value;
      = clc$lock =
        convert_lock_value;
      = clc$name =
        convert_name_value;
      = clc$network_title =
        convert_network_title_value;
      = clc$program_name =
        convert_program_name_value;
      = clc$range =
        convert_range_value;
      = clc$real =
        convert_real_value;
      = clc$record =
        convert_record_value;
      = clc$scu_line_identifier =
        convert_scu_line_id_value;
      = clc$statistic_code =
        convert_statistic_code_value;
      = clc$status =
        convert_status_value;
      = clc$status_code =
        convert_status_code_value;
      = clc$string =
        convert_string_value;
      = clc$string_pattern =
        convert_string_pattern_value;
      = clc$time_increment =
        convert_time_increment_value;
      = clc$time_zone =
        convert_time_zone_value;
      = clc$type_specification =
        convert_type_spec_value;
      = clc$unspecified =
        ;
      ELSE
        bad_external_value;
      CASEND;

    PROCEND convert_ext_value_to_int;
?? TITLE := 'work_area_overflow', EJECT ??

    PROCEDURE work_area_overflow;


      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      EXIT clp$convert_ext_value_to_int;

    PROCEND work_area_overflow;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    original_work_area := work_area;
    #SPOIL (original_work_area);
    osp$establish_condition_handler (^abort_handler, TRUE);

    initial_conversion := internal_value = NIL;
    IF initial_conversion THEN
      initial_position := i#current_sequence_position (work_area);
      space_size := #SIZE (work_area^) - initial_position - #SIZE (clt$internal_data_value_header);
      IF space_size <= 0 THEN
        work_area_overflow;
      IFEND;
      NEXT internal_value: [[REP space_size OF cell]] IN work_area;
      RESET work_area TO internal_value;
      NEXT header IN work_area;
      header^.value := NIL;
      header^.unused_space := 0;
      header^.minimum_allocation_increment := 0;
    ELSE
      initial_position := #OFFSET (internal_value) - #OFFSET (work_area);
    IFEND;

    IF internal_component_address <> NIL THEN
      component_address := internal_component_address;
    ELSE
      component_address := ^internal_value^.header.value;
    IFEND;

    convert_ext_value_to_int (initializing_type_description, external_value, component_address^, unused_space,
          increment_size);

    IF initial_conversion THEN
      space_size := i#current_sequence_position (work_area) -
            initial_position - #SIZE (clt$internal_data_value_header);
      IF initializing_type_description <> NIL THEN
        space_size := space_size + unused_space;
        header^.unused_space := unused_space;
        header^.minimum_allocation_increment := increment_size;
      IFEND;
      RESET work_area TO header;
      NEXT internal_value: [[REP space_size OF cell]] IN work_area;
      IF internal_value = NIL THEN
        work_area_overflow;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND clp$convert_ext_value_to_int;
?? TITLE := 'clp$convert_int_value_to_ext', EJECT ??

  PROCEDURE [XDCL] clp$convert_int_value_to_ext
    (    internal_value: ^clt$internal_data_value;
         initial_component: REL (clt$internal_data_value) ^clt$i_data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR external_value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      original_work_area: ^clt$work_area;

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

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


      CASE condition.selector OF

      = pmc$block_exit_processing =
        work_area := original_work_area;
        #SPOIL (work_area);
        RETURN;

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          bad_internal_value;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          bad_internal_value;
        IFEND;

      = mmc$segment_access_condition =
        CASE condition.segment_access_condition.identifier OF
        = mmc$sac_read_beyond_eoi =
          bad_internal_value;
        = mmc$sac_read_write_beyond_msl, mmc$sac_no_append_permission =
*IF $true(osv$unix)
          bad_internal_value;
*ELSE
          IF #SEGMENT (condition.segment_access_condition.segment) = #SEGMENT (work_area) THEN
            work_area_overflow;
          ELSE
            bad_internal_value;
          IFEND;
*IFEND
        ELSE
          ;
        CASEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? TITLE := 'bad_internal_value', EJECT ??

    PROCEDURE bad_internal_value;


      osp$set_status_abnormal ('CL', cle$bad_internal_value, '', status);
      EXIT clp$convert_int_value_to_ext;

    PROCEND bad_internal_value;
?? TITLE := 'convert_int_value_to_ext', EJECT ??

    PROCEDURE convert_int_value_to_ext
      (    i_value: ^clt$i_data_value;
       VAR external_value: ^clt$data_value);

?? NEWTITLE := 'convert_application_value', EJECT ??

      PROCEDURE [INLINE] convert_application_value;

        VAR
          application_value: ^clt$application_value_text;


        application_value := #PTR (i_value^.application_value, internal_value^);

        clp$make_application_value (application_value^, work_area, external_value);

      PROCEND convert_application_value;
?? TITLE := 'convert_array_value', EJECT ??

      PROCEDURE [INLINE] convert_array_value;

        VAR
          element: ^clt$i_data_value,
          elements: ^array [ * ] of REL (clt$internal_data_value) ^clt$i_data_value,
          i: clt$array_bound;


        elements := #PTR (i_value^.array_value, internal_value^);

        clp$make_array_value (LOWERBOUND (elements^), UPPERBOUND (elements^), work_area, external_value);
        IF external_value = NIL THEN
          work_area_overflow;
        IFEND;

        FOR i := LOWERBOUND (elements^) TO UPPERBOUND (elements^) DO
          IF elements^ [i] = NIL THEN
            external_value^.array_value^ [i] := NIL;
          ELSE
            convert_int_value_to_ext (#PTR (elements^ [i], internal_value^),
                  external_value^.array_value^ [i]);
          IFEND;
        FOREND;

      PROCEND convert_array_value;
?? TITLE := 'convert_boolean_value', EJECT ??

      PROCEDURE [INLINE] convert_boolean_value;


        clp$make_clt$boolean_value (i_value^.boolean_value, work_area, external_value);

      PROCEND convert_boolean_value;
?? TITLE := 'convert_cobol_name_value', EJECT ??

      PROCEDURE [INLINE] convert_cobol_name_value;

        VAR
          cobol_name: ^clt$cobol_name;


        cobol_name := #PTR (i_value^.cobol_name_value, internal_value^);

        clp$make_cobol_name_value (cobol_name^, work_area, external_value);

      PROCEND convert_cobol_name_value;
?? TITLE := 'convert_command_reference_value', EJECT ??

      PROCEDURE [INLINE] convert_command_reference_value;

        VAR
          command_reference: ^clt$command_reference;


        command_reference := #PTR (i_value^.command_reference_value, internal_value^);

        clp$make_command_ref_value (command_reference, work_area, external_value);

      PROCEND convert_command_reference_value;
?? TITLE := 'convert_data_name_value', EJECT ??

      PROCEDURE [INLINE] convert_data_name_value;

        VAR
          data_name: ^ost$name;


        data_name := #PTR (i_value^.data_name_value, internal_value^);

        clp$make_data_name_value (data_name^, work_area, external_value);

      PROCEND convert_data_name_value;
?? TITLE := 'convert_date_time_value', EJECT ??

      PROCEDURE [INLINE] convert_date_time_value;


        clp$make_date_time_value (i_value^.date_time_value, work_area, external_value);

      PROCEND convert_date_time_value;
?? TITLE := 'convert_deferred_value', EJECT ??

      PROCEDURE [INLINE] convert_deferred_value;

        VAR
          expression_text: ^clt$expression_text;


        expression_text := #PTR (i_value^.deferred_value, internal_value^);

{ Since the only values that can be deferred are those of entire
{ variables and parameters (i.e. NOT components of structured values),
{ the deferred_type field is not stored internally since it can be
{ obtained from the descriptor of the variable or parameter when needed.

        clp$make_deferred_value (expression_text^, NIL, work_area, external_value);

      PROCEND convert_deferred_value;
?? TITLE := 'convert_entry_point_ref_value', EJECT ??

      PROCEDURE [INLINE] convert_entry_point_ref_value;

        VAR
          entry_point_reference: ^pmt$entry_point_reference;


        entry_point_reference := #PTR (i_value^.entry_point_reference_value, internal_value^);

        clp$make_entry_point_ref_value (entry_point_reference^.entry_point,
              entry_point_reference^.object_library, work_area, external_value);

      PROCEND convert_entry_point_ref_value;
?? TITLE := 'convert_file_value', EJECT ??

      PROCEDURE [INLINE] convert_file_value;

        VAR
          file_value: ^fst$file_reference;


        file_value := #PTR (i_value^.file_value, internal_value^);

*IF NOT $true(osv$unix)
        clp$make_file_value (file_value^, work_area, external_value);
*ELSE
        clp$make_a_file_value (i_value^.kind, file_value^, work_area, external_value);
*IFEND

      PROCEND convert_file_value;
?? TITLE := 'convert_integer_value', EJECT ??

      PROCEDURE [INLINE] convert_integer_value;


        clp$make_clt$integer_value (i_value^.integer_value, work_area, external_value);

      PROCEND convert_integer_value;
?? TITLE := 'convert_keyword_value', EJECT ??

      PROCEDURE [INLINE] convert_keyword_value;

        VAR
          keyword: ^clt$keyword;


        keyword := #PTR (i_value^.keyword_value, internal_value^);

        clp$make_keyword_value (keyword^, work_area, external_value);

      PROCEND convert_keyword_value;
?? TITLE := 'convert_list_value', EJECT ??

      PROCEDURE [INLINE] convert_list_value;

        VAR
          current_i_node: ^clt$i_data_value,
          current_node: ^clt$data_value,
          previous_node: ^clt$data_value;


        current_i_node := i_value;
        external_value := NIL;

        REPEAT
          clp$make_list_value (work_area, current_node);
          IF current_node = NIL THEN
            work_area_overflow;
          IFEND;

          IF external_value = NIL THEN
            external_value := current_node;
            external_value^.generated_via_list_rest := i_value^.generated_via_list_rest;
          ELSE
            previous_node^.link := current_node;
          IFEND;

          IF current_i_node^.element_value <> NIL THEN
            convert_int_value_to_ext (#PTR (current_i_node^.element_value, internal_value^),
                  current_node^.element_value);
          IFEND;

          previous_node := current_node;
          current_i_node := #PTR (current_i_node^.link, internal_value^);
        UNTIL current_i_node = NIL;

      PROCEND convert_list_value;
?? TITLE := 'convert_lock_value', EJECT ??

      PROCEDURE [INLINE] convert_lock_value;

        VAR
          lock_value: ^clt$lock;


        lock_value := #PTR (i_value^.lock_value, internal_value^);

        clp$make_lock_value (lock_value, work_area, external_value);

      PROCEND convert_lock_value;
?? TITLE := 'convert_name_value', EJECT ??

      PROCEDURE [INLINE] convert_name_value;

        VAR
          name: ^ost$name;


        name := #PTR (i_value^.name_value, internal_value^);

        clp$make_name_value (name^, work_area, external_value);

      PROCEND convert_name_value;
?? TITLE := 'convert_network_title_value', EJECT ??

      PROCEDURE [INLINE] convert_network_title_value;

        VAR
          network_title_value: ^nat$title;


        network_title_value := #PTR (i_value^.network_title_value, internal_value^);

        clp$make_network_title_value (network_title_value^, work_area, external_value);

      PROCEND convert_network_title_value;
?? TITLE := 'convert_program_name_value', EJECT ??

      PROCEDURE [INLINE] convert_program_name_value;

        VAR
          program_name: ^pmt$program_name;


        program_name := #PTR (i_value^.program_name_value, internal_value^);

        clp$make_program_name_value (program_name^, work_area, external_value);

      PROCEND convert_program_name_value;
?? TITLE := 'convert_range_value', EJECT ??

      PROCEDURE [INLINE] convert_range_value;


        clp$make_range_value (work_area, external_value);
        IF external_value = NIL THEN
          work_area_overflow;
        IFEND;

        convert_int_value_to_ext (#PTR (i_value^.low_value, internal_value^), external_value^.low_value);

        IF i_value^.high_value = i_value^.low_value THEN
          external_value^.high_value := external_value^.low_value;
        ELSE
          convert_int_value_to_ext (#PTR (i_value^.high_value, internal_value^), external_value^.high_value);
        IFEND;

      PROCEND convert_range_value;
?? TITLE := 'convert_real_value', EJECT ??

      PROCEDURE [INLINE] convert_real_value;


        clp$make_clt$real_value (i_value^.real_value, work_area, external_value);

      PROCEND convert_real_value;
?? TITLE := 'convert_record_value', EJECT ??

      PROCEDURE [INLINE] convert_record_value;

        VAR
          element: ^clt$i_data_value,
          fields: ^array [1 .. * ] of clt$internal_field_value,
          i: clt$field_number;


        fields := #PTR (i_value^.field_values, internal_value^);

        clp$make_record_value (UPPERBOUND (fields^), work_area, external_value);
        IF external_value = NIL THEN
          work_area_overflow;
        IFEND;

        FOR i := 1 TO UPPERBOUND (fields^) DO
          external_value^.field_values^ [i].name := fields^ [i].name;
          IF fields^ [i].value = NIL THEN
            external_value^.field_values^ [i].value := NIL;
          ELSE
            convert_int_value_to_ext (#PTR (fields^ [i].value, internal_value^),
                  external_value^.field_values^ [i].value);
          IFEND;
        FOREND;

      PROCEND convert_record_value;
?? TITLE := 'convert_scu_line_id_value', EJECT ??

      PROCEDURE [INLINE] convert_scu_line_id_value;


        clp$make_scu_line_id_value (i_value^.scu_line_identifier_value, work_area, external_value);

      PROCEND convert_scu_line_id_value;
?? TITLE := 'convert_statistic_code_value', EJECT ??

      PROCEDURE [INLINE] convert_statistic_code_value;


        clp$make_statistic_code_value (i_value^.statistic_code_value, work_area, external_value);

      PROCEND convert_statistic_code_value;
?? TITLE := 'convert_status_value', EJECT ??

      PROCEDURE [INLINE] convert_status_value;

        VAR
          status_value: ^ost$status;


        status_value := #PTR (i_value^.status_value, internal_value^);

        clp$make_status_value (status_value^, work_area, external_value);

      PROCEND convert_status_value;
?? TITLE := 'convert_status_code_value', EJECT ??

      PROCEDURE [INLINE] convert_status_code_value;


        clp$make_status_code_value (i_value^.status_code_value, work_area, external_value);

      PROCEND convert_status_code_value;
?? TITLE := 'convert_string_value', EJECT ??

      PROCEDURE [INLINE] convert_string_value;

        VAR
          string_value: ^clt$string_value;


        string_value := #PTR (i_value^.string_value, internal_value^);

        clp$make_string_value (string_value^, work_area, external_value);

      PROCEND convert_string_value;
?? TITLE := 'convert_string_pattern_value', EJECT ??

      PROCEDURE [INLINE] convert_string_pattern_value;

        VAR
          string_pattern: ^clt$string_pattern;


        string_pattern := #PTR (i_value^.string_pattern_value, internal_value^);

        clp$make_string_pattern_value (string_pattern^, work_area, external_value);

      PROCEND convert_string_pattern_value;
?? TITLE := 'convert_time_increment_value', EJECT ??

      PROCEDURE [INLINE] convert_time_increment_value;

        VAR
          time_increment: ^pmt$time_increment;


        time_increment := #PTR (i_value^.time_increment_value, internal_value^);

        clp$make_time_increment_value (time_increment, work_area, external_value);

      PROCEND convert_time_increment_value;
?? TITLE := 'convert_time_zone_value', EJECT ??

      PROCEDURE [INLINE] convert_time_zone_value;


        clp$make_time_zone_value (i_value^.time_zone_value, work_area, external_value);

      PROCEND convert_time_zone_value;
?? TITLE := 'convert_type_spec_value', EJECT ??

      PROCEDURE [INLINE] convert_type_spec_value;

        VAR
          internal_type_specification: ^clt$type_specification,
          type_specification: ^clt$type_specification;


        internal_type_specification := #PTR (i_value^.type_specification_value, internal_value^);

        NEXT type_specification: [[REP #SIZE (internal_type_specification^) OF cell]] IN work_area;
        IF type_specification <> NIL THEN
          type_specification^ := internal_type_specification^;
          clp$make_type_spec_value (type_specification, work_area, external_value);
        IFEND;

      PROCEND convert_type_spec_value;
?? TITLE := 'convert_unspecified_value', EJECT ??

      PROCEDURE [INLINE] convert_unspecified_value;


        clp$make_unspecified_value (work_area, external_value);

      PROCEND convert_unspecified_value;
?? OLDTITLE, EJECT ??

      CASE i_value^.kind OF
      = clc$application =
        convert_application_value;
      = clc$array =
        convert_array_value;
      = clc$boolean =
        convert_boolean_value;
      = clc$cobol_name =
        convert_cobol_name_value;
      = clc$command_reference =
        convert_command_reference_value;
      = clc$data_name =
        convert_data_name_value;
      = clc$date_time =
        convert_date_time_value;
      = clc$deferred =
        convert_deferred_value;
      = clc$entry_point_reference =
        convert_entry_point_ref_value;
*IF NOT $true(osv$unix)
      = clc$file =
*ELSE
      = {clc$file} clc$nos_ve_file, clc$unix_file =
*IFEND
        convert_file_value;
      = clc$integer =
        convert_integer_value;
      = clc$keyword =
        convert_keyword_value;
      = clc$list =
        convert_list_value;
      = clc$lock =
        convert_lock_value;
      = clc$name =
        convert_name_value;
      = clc$network_title =
        convert_network_title_value;
      = clc$program_name =
        convert_program_name_value;
      = clc$range =
        convert_range_value;
      = clc$real =
        convert_real_value;
      = clc$record =
        convert_record_value;
      = clc$scu_line_identifier =
        convert_scu_line_id_value;
      = clc$statistic_code =
        convert_statistic_code_value;
      = clc$status =
        convert_status_value;
      = clc$status_code =
        convert_status_code_value;
      = clc$string =
        convert_string_value;
      = clc$string_pattern =
        convert_string_pattern_value;
      = clc$time_increment =
        convert_time_increment_value;
      = clc$time_zone =
        convert_time_zone_value;
      = clc$type_specification =
        convert_type_spec_value;
      = clc$unspecified =
        convert_unspecified_value;
      ELSE
        bad_internal_value;
      CASEND;

      IF external_value = NIL THEN
        work_area_overflow;
      IFEND;

    PROCEND convert_int_value_to_ext;
?? TITLE := 'work_area_overflow', EJECT ??

    PROCEDURE work_area_overflow;


      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      EXIT clp$convert_int_value_to_ext;

    PROCEND work_area_overflow;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    external_value := NIL;

    original_work_area := work_area;
    #SPOIL (original_work_area);
    osp$establish_condition_handler (^abort_handler, TRUE);

    IF (internal_value = NIL) OR (initial_component = NIL) THEN
      bad_internal_value;
    IFEND;

    convert_int_value_to_ext (#PTR (initial_component, internal_value^), external_value);

    osp$disestablish_cond_handler;

  PROCEND clp$convert_int_value_to_ext;
*IFEND
?? TITLE := 'clp$copy_data_value', EJECT ??

  PROCEDURE [XDCL] clp$copy_data_value
    (    old_value: ^clt$data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR new_value: ^clt$data_value;
     VAR status: ost$status);

    VAR
*IF $true(osv$unix)
      handler_established: boolean,
*IFEND
      original_work_area: ^clt$work_area;

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

    PROCEDURE abort_handler
*IF $true(osv$unix)
      (    signal_no: integer;
           code: integer;
           p_sigcontext: ^cyt$mips_sigcontext);
*ELSE
      (    condition: pmt$condition;
           ignore_condition_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      CASE condition.selector OF

      = pmc$block_exit_processing =
*IFEND
        work_area := original_work_area;
        #SPOIL (work_area);
        RETURN;

*IF NOT $true(osv$unix)
      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          bad_data_value;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          bad_data_value;
        IFEND;

      = mmc$segment_access_condition =
        CASE condition.segment_access_condition.identifier OF
        = mmc$sac_read_beyond_eoi =
          bad_data_value;
        = mmc$sac_read_write_beyond_msl, mmc$sac_no_append_permission =
*IF $true(osv$unix)
          bad_data_value;
*ELSE
          IF #SEGMENT (condition.segment_access_condition.segment) = #SEGMENT (work_area) THEN
            work_area_overflow;
          ELSE
            bad_data_value;
          IFEND;
*IFEND
        ELSE
          ;
        CASEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
*IFEND

    PROCEND abort_handler;
?? TITLE := 'bad_data_value', EJECT ??

    PROCEDURE [INLINE] bad_data_value;


      osp$set_status_abnormal ('CL', cle$bad_data_value, '', status);
      EXIT clp$copy_data_value;

    PROCEND bad_data_value;
?? TITLE := 'copy_data_value', EJECT ??

    PROCEDURE copy_data_value
      (    old_value: ^clt$data_value;
       VAR new_value: ^clt$data_value);

?? NEWTITLE := 'copy_application_value', EJECT ??

      PROCEDURE [INLINE] copy_application_value;

        VAR
          new_application_value: ^clt$application_value_text,
          old_application_value: ^clt$application_value_text;


        NEXT new_value^.application_value: [STRLENGTH (old_value^.application_value^)] IN work_area;
        IF new_value^.application_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_value^.application_value^ := old_value^.application_value^;

      PROCEND copy_application_value;
?? TITLE := 'copy_array_value', EJECT ??

      PROCEDURE [INLINE] copy_array_value;

        VAR
          i: clt$array_bound;


        NEXT new_value^.array_value: [LOWERBOUND (old_value^.array_value^) .. UPPERBOUND (old_value^.
              array_value^)] IN work_area;
        IF new_value^.array_value = NIL THEN
          work_area_overflow;
        IFEND;

        FOR i := LOWERBOUND (old_value^.array_value^) TO UPPERBOUND (old_value^.array_value^) DO
          IF old_value^.array_value^ [i] = NIL THEN
            new_value^.array_value^ [i] := NIL;
          ELSE
            copy_data_value (old_value^.array_value^ [i], new_value^.array_value^ [i]);
          IFEND;
        FOREND;

      PROCEND copy_array_value;
?? TITLE := 'copy_command_reference_value', EJECT ??

      PROCEDURE [INLINE] copy_command_reference_value;


        NEXT new_value^.command_reference_value IN work_area;
        IF new_value^.command_reference_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_value^.command_reference_value^ := old_value^.command_reference_value^;

      PROCEND copy_command_reference_value;
?? TITLE := 'copy_deferred_value', EJECT ??

      PROCEDURE [INLINE] copy_deferred_value;


        NEXT new_value^.deferred_value: [STRLENGTH (old_value^.deferred_value^)] IN work_area;
        NEXT new_value^.deferred_type: [[REP #SIZE (old_value^.deferred_type^) OF cell]] IN work_area;
        IF (new_value^.deferred_value = NIL) OR (new_value^.deferred_type = NIL) THEN
          work_area_overflow;
        IFEND;

        new_value^.deferred_value^ := old_value^.deferred_value^;
        new_value^.deferred_type^ := old_value^.deferred_type^;

      PROCEND copy_deferred_value;
?? TITLE := 'copy_entry_point_ref_value', EJECT ??

      PROCEDURE [INLINE] copy_entry_point_ref_value;


        NEXT new_value^.entry_point_reference_value IN work_area;
        IF new_value^.entry_point_reference_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_value^.entry_point_reference_value^ := old_value^.entry_point_reference_value^;

      PROCEND copy_entry_point_ref_value;
?? TITLE := 'copy_file_value', EJECT ??

      PROCEDURE [INLINE] copy_file_value;


        NEXT new_value^.file_value: [STRLENGTH (old_value^.file_value^)] IN work_area;
        IF new_value^.file_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_value^.file_value^ := old_value^.file_value^;

      PROCEND copy_file_value;
?? TITLE := 'copy_list_value', EJECT ??

      PROCEDURE [INLINE] copy_list_value;

        VAR
          current_new_node: ^clt$data_value,
          current_old_node: ^clt$data_value,
          previous_new_node_link: ^^clt$data_value;


        current_old_node := old_value;
        current_new_node := new_value;

        REPEAT
          IF current_old_node^.element_value = NIL THEN
            current_new_node^.element_value := NIL;
          ELSE
            copy_data_value (current_old_node^.element_value, current_new_node^.element_value);
          IFEND;

          current_old_node := current_old_node^.link;
          IF current_old_node <> NIL THEN
            previous_new_node_link := ^current_new_node^.link;
            NEXT current_new_node IN work_area;
            IF current_new_node = NIL THEN
              work_area_overflow;
            IFEND;
            previous_new_node_link^ := current_new_node;
            current_new_node^.kind := clc$list;
            current_new_node^.link := NIL;
            current_new_node^.generated_via_list_rest := FALSE;
          IFEND;
        UNTIL current_old_node = NIL;

      PROCEND copy_list_value;
?? TITLE := 'copy_lock_value', EJECT ??

      PROCEDURE [INLINE] copy_lock_value;


        NEXT new_value^.lock_value IN work_area;
        IF new_value^.lock_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_value^.lock_value^ := old_value^.lock_value^;

      PROCEND copy_lock_value;
?? TITLE := 'copy_network_title_value', EJECT ??

      PROCEDURE [INLINE] copy_network_title_value;


        NEXT new_value^.network_title_value: [STRLENGTH (old_value^.network_title_value^)] IN work_area;
        IF new_value^.network_title_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_value^.network_title_value^ := old_value^.network_title_value^;

      PROCEND copy_network_title_value;
?? TITLE := 'copy_range_value', EJECT ??

      PROCEDURE [INLINE] copy_range_value;


        IF old_value^.low_value <> NIL THEN
          copy_data_value (old_value^.low_value, new_value^.low_value);
        IFEND;

        IF old_value^.high_value = old_value^.low_value THEN
          new_value^.high_value := new_value^.low_value;
        ELSE
          copy_data_value (old_value^.high_value, new_value^.high_value);
        IFEND;

      PROCEND copy_range_value;
?? TITLE := 'copy_record_value', EJECT ??

      PROCEDURE [INLINE] copy_record_value;

        VAR
          i: clt$field_number;


        NEXT new_value^.field_values: [1 .. UPPERBOUND (old_value^.field_values^)] IN work_area;
        IF new_value^.field_values = NIL THEN
          work_area_overflow;
        IFEND;

        FOR i := 1 TO UPPERBOUND (old_value^.field_values^) DO
          new_value^.field_values^ [i].name := old_value^.field_values^ [i].name;
          IF old_value^.field_values^ [i].value = NIL THEN
            new_value^.field_values^ [i].value := NIL;
          ELSE
            copy_data_value (old_value^.field_values^ [i].value, new_value^.field_values^ [i].value);
          IFEND;
        FOREND;

      PROCEND copy_record_value;
?? TITLE := 'copy_status_value', EJECT ??

      PROCEDURE [INLINE] copy_status_value;


        NEXT new_value^.status_value IN work_area;
        IF new_value^.status_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_value^.status_value^ := old_value^.status_value^;

      PROCEND copy_status_value;
?? TITLE := 'copy_string_value', EJECT ??

      PROCEDURE [INLINE] copy_string_value;


        NEXT new_value^.string_value: [STRLENGTH (old_value^.string_value^)] IN work_area;
        IF new_value^.string_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_value^.string_value^ := old_value^.string_value^;

      PROCEND copy_string_value;
?? TITLE := 'copy_string_pattern_value', EJECT ??

      PROCEDURE [INLINE] copy_string_pattern_value;


        NEXT new_value^.string_pattern_value: [[REP #SIZE (old_value^.string_pattern_value^) OF cell]] IN
              work_area;
        IF new_value^.string_pattern_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_value^.string_pattern_value^ := old_value^.string_pattern_value^;

      PROCEND copy_string_pattern_value;
?? TITLE := 'copy_time_increment_value', EJECT ??

      PROCEDURE [INLINE] copy_time_increment_value;


        NEXT new_value^.time_increment_value IN work_area;
        IF new_value^.time_increment_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_value^.time_increment_value^ := old_value^.time_increment_value^;

      PROCEND copy_time_increment_value;
?? TITLE := 'copy_type_spec_value', EJECT ??

      PROCEDURE [INLINE] copy_type_spec_value;


        NEXT new_value^.type_specification_value: [[REP #SIZE (old_value^.type_specification_value^) OF
              cell]] IN work_area;
        IF new_value^.type_specification_value = NIL THEN
          work_area_overflow;
        IFEND;

        new_value^.type_specification_value^ := old_value^.type_specification_value^;

      PROCEND copy_type_spec_value;
?? OLDTITLE, EJECT ??

      NEXT new_value IN work_area;
      IF new_value = NIL THEN
        work_area_overflow;
      IFEND;
      new_value^ := old_value^;

      CASE old_value^.kind OF
      = clc$boolean, clc$cobol_name, clc$data_name, clc$date_time, clc$integer, clc$keyword, clc$name,
            clc$program_name, clc$real, clc$scu_line_identifier, clc$statistic_code, clc$status_code,
            clc$time_zone, clc$unspecified =

      = clc$application =
        copy_application_value;
      = clc$array =
        copy_array_value;
      = clc$command_reference =
        copy_command_reference_value;
      = clc$deferred =
        copy_deferred_value;
      = clc$entry_point_reference =
        copy_entry_point_ref_value;
*IF NOT $true(osv$unix)
      = clc$file =
*ELSE
      = {clc$file} clc$nos_ve_file, clc$unix_file =
*IFEND
        copy_file_value;
      = clc$list =
        copy_list_value;
      = clc$lock =
        copy_lock_value;
      = clc$network_title =
        copy_network_title_value;
      = clc$range =
        copy_range_value;
      = clc$record =
        copy_record_value;
      = clc$status =
        copy_status_value;
      = clc$string =
        copy_string_value;
      = clc$string_pattern =
        copy_string_pattern_value;
      = clc$time_increment =
        copy_time_increment_value;
      = clc$type_specification =
        copy_type_spec_value;
      ELSE
        bad_data_value;
      CASEND;

    PROCEND copy_data_value;
?? TITLE := 'work_area_overflow', EJECT ??

    PROCEDURE [INLINE] work_area_overflow;


      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      EXIT clp$copy_data_value;

    PROCEND work_area_overflow;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    original_work_area := work_area;
    #SPOIL (original_work_area);
*IF $true(osv$unix)
    handler_established := #establish_condition_handler (-1, ^abort_handler);
*ELSE
    osp$establish_condition_handler (^abort_handler, TRUE);
*IFEND

    IF old_value = NIL THEN
      bad_data_value;
    IFEND;

    copy_data_value (old_value, new_value);

*IF $true(osv$unix)
    IF handler_established THEN
      handler_established := NOT #disestablish_condition_handler (-1);
    IFEND;
*ELSE
    osp$disestablish_cond_handler;
*IFEND

  PROCEND clp$copy_data_value;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$create_default_init_value', EJECT ??

  PROCEDURE [XDCL] clp$create_default_init_value
    (    type_description: ^clt$type_description;
     VAR work_area {input, output} : ^clt$work_area;
     VAR internal_value: ^clt$internal_data_value;
     VAR status: ost$status);

    VAR
      element_type_description: ^clt$type_description,
      header: ^clt$internal_data_value_header,
      i_value: ^clt$i_data_value,
      initial_position: integer,
      original_work_area: ^clt$work_area,
      space_size: integer;

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

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


      CASE condition.selector OF

      = pmc$block_exit_processing =
        work_area := original_work_area;
        #SPOIL (work_area);
        RETURN;

      = mmc$segment_access_condition =
        CASE condition.segment_access_condition.identifier OF
        = mmc$sac_read_write_beyond_msl, mmc$sac_no_append_permission =
*IF NOT $true(osv$unix)
          IF #SEGMENT (condition.segment_access_condition.segment) = #SEGMENT (work_area) THEN
            work_area_overflow;
          IFEND;
*IFEND
        ELSE
          ;
        CASEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? TITLE := 'create_array_value', EJECT ??

    PROCEDURE [INLINE] create_array_value;

      VAR
        array_space: integer,
        elements: ^array [ * ] of REL (clt$internal_data_value) ^clt$i_data_value,
        elements_space: integer,
        i: clt$array_bound,
        increment_size: integer,
        number_of_elements: integer,
        unused_space: integer;


      IF (NOT type_description^.array_bounds_defined) OR (type_description^.array_element_type_description =
            NIL) THEN
        no_initial_value;
      IFEND;

      number_of_elements := type_description^.bounds.upper - type_description^.bounds.lower + 1;
      IF number_of_elements > (osc$max_segment_length DIV #SIZE (clt$data_value)) THEN
        work_area_overflow;
      IFEND;

      NEXT elements: [type_description^.bounds.lower .. type_description^.bounds.upper] IN work_area;
      IF elements = NIL THEN
        work_area_overflow;
      IFEND;

      array_space := i#current_sequence_position (work_area) - initial_position;
      IF array_space > clv$max_variable_allocation THEN
        work_area_overflow;
      IFEND;

      element_type_description := type_description^.array_element_type_description;
      i_value^.kind := clc$array;
      i_value^.array_value := #REL (elements, internal_value^);

      FOR i := LOWERBOUND (elements^) TO UPPERBOUND (elements^) DO
        NEXT i_value IN work_area;
        IF elements = NIL THEN
          work_area_overflow;
        IFEND;
        elements^ [i] := #REL (i_value, internal_value^);

        CASE type_description^.array_element_type_description^.kind OF
        = clc$boolean_type =
          create_boolean_value;
        = clc$integer_type =
          create_integer_value;
        = clc$real_type =
          create_real_value;
        = clc$status_type =
          create_status_value;
        = clc$string_type =

          IF i = LOWERBOUND (elements^) THEN
            determine_string_size;
            unused_space := header^.unused_space * number_of_elements;
            IF unused_space <= max_unused_space THEN
              header^.unused_space := unused_space;
            ELSE
              header^.unused_space := max_unused_space;
            IFEND;
            increment_size := header^.minimum_allocation_increment * number_of_elements;
            IF increment_size <= max_increment_size THEN
              header^.minimum_allocation_increment := increment_size;
            ELSE
              header^.minimum_allocation_increment := max_increment_size;
            IFEND;
          IFEND;

          create_string_value;
        ELSE
          no_initial_value;
        CASEND;
        IF i = 1 THEN
          elements_space := (i#current_sequence_position (work_area) - initial_position - array_space) *
                number_of_elements;
          IF (array_space + elements_space) > clv$max_variable_allocation THEN
            work_area_overflow;
          IFEND;
        IFEND;
      FOREND;

    PROCEND create_array_value;
?? TITLE := 'create_boolean_value', EJECT ??

    PROCEDURE [INLINE] create_boolean_value;


      i_value^.kind := clc$boolean;
      i_value^.boolean_value.value := FALSE;
      i_value^.boolean_value.kind := clc$true_false_boolean;

    PROCEND create_boolean_value;
?? TITLE := 'create_integer_value', EJECT ??

    PROCEDURE [INLINE] create_integer_value;


      IF (0 < element_type_description^.min_integer_value) OR
            (0 > element_type_description^.max_integer_value) THEN
        no_initial_value;
      IFEND;

      i_value^.kind := clc$integer;
      i_value^.integer_value.value := 0;
      i_value^.integer_value.radix := 10;
      i_value^.integer_value.radix_specified := FALSE;

    PROCEND create_integer_value;
?? TITLE := 'create_list_value', EJECT ??

    PROCEDURE [INLINE] create_list_value;

      VAR
        empty_list_value: ^clt$data_value;


      IF type_description^.min_list_size <> 0 THEN
        no_initial_value;
      IFEND;

      RESET work_area TO internal_value;
      internal_value := NIL;
      PUSH empty_list_value;

      empty_list_value^.kind := clc$list;
      empty_list_value^.element_value := NIL;;
      empty_list_value^.link := NIL;
      empty_list_value^.generated_via_list_rest := FALSE;

      clp$convert_ext_value_to_int (type_description, empty_list_value, NIL, work_area, internal_value,
            status);
      IF NOT status.normal THEN
        EXIT clp$create_default_init_value;
      IFEND;

    PROCEND create_list_value;
?? TITLE := 'create_real_value', EJECT ??

    PROCEDURE [INLINE] create_real_value;


      IF clp$longreal_compare_lt (clv$real_zero^, element_type_description^.min_real_value.long_real) OR
            clp$longreal_compare_gt (clv$real_zero^, element_type_description^.max_real_value.long_real) THEN
        no_initial_value;
      IFEND;

      i_value^.kind := clc$real;
      i_value^.real_value.value := clv$real_zero^;
      i_value^.real_value.number_of_digits := 1;

    PROCEND create_real_value;
?? TITLE := 'create_status_value', EJECT ??

    PROCEDURE [INLINE] create_status_value;

      VAR
        status_value: ^ost$status;


      NEXT status_value IN work_area;
      IF status_value = NIL THEN
        work_area_overflow;
      IFEND;

      i_value^.kind := clc$status;
      i_value^.status_value := #REL (status_value, internal_value^);
      status_value^.normal := TRUE;

    PROCEND create_status_value;
?? TITLE := 'create_string_value', EJECT ??

    PROCEDURE [INLINE] create_string_value;

      VAR
        string_index: integer,
        string_value: ^clt$string_value;

      i_value^.kind := clc$string;

      IF element_type_description^.min_string_size > 0 THEN
        NEXT string_value: [element_type_description^.min_string_size] IN work_area;
        FOR string_index := 1 TO element_type_description^.min_string_size DO
          string_value^ (string_index) := ' ';
        FOREND;
      ELSE
        NEXT string_value: [0] IN work_area;
      IFEND;

      i_value^.string_value := #REL (string_value, internal_value^);

    PROCEND create_string_value;
?? TITLE := 'determine_string_size', EJECT ??

    PROCEDURE [INLINE] determine_string_size;


      IF element_type_description^.min_string_size > 0 THEN
        header^.unused_space := element_type_description^.max_string_size;
      ELSEIF element_type_description^.max_string_size < nominal_string_size THEN
        header^.unused_space := element_type_description^.max_string_size;
      ELSE
        header^.unused_space := nominal_string_size;
      IFEND;

      IF header^.unused_space <= string_size_increment THEN
        header^.minimum_allocation_increment := header^.unused_space;
      ELSE
        header^.minimum_allocation_increment := string_size_increment;
      IFEND;

    PROCEND determine_string_size;
?? TITLE := 'no_initial_value', EJECT ??

    PROCEDURE [INLINE] no_initial_value;


      internal_value := NIL;
      EXIT clp$create_default_init_value;

    PROCEND no_initial_value;
?? TITLE := 'work_area_overflow', EJECT ??

    PROCEDURE work_area_overflow;


      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      EXIT clp$create_default_init_value;

    PROCEND work_area_overflow;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    internal_value := NIL;

    original_work_area := work_area;
    #SPOIL (original_work_area);
    osp$establish_condition_handler (^abort_handler, TRUE);

    initial_position := i#current_sequence_position (work_area);
    space_size := #SIZE (work_area^) - initial_position - #SIZE (clt$internal_data_value_header);
    IF space_size <= 0 THEN
      work_area_overflow;
    IFEND;

    NEXT internal_value: [[REP space_size OF cell]] IN work_area;
    RESET work_area TO internal_value;
    NEXT header IN work_area;
    NEXT i_value IN work_area;
    IF i_value = NIL THEN
      work_area_overflow;
    IFEND;
    header^.value := #REL (i_value, internal_value^);
    header^.unused_space := 0;
    header^.minimum_allocation_increment := 0;

    element_type_description := type_description;

    CASE type_description^.kind OF
    = clc$array_type =
      create_array_value;
    = clc$boolean_type =
      create_boolean_value;
    = clc$integer_type =
      create_integer_value;
    = clc$list_type =
      create_list_value;
    = clc$real_type =
      create_real_value;
    = clc$status_type =
      create_status_value;
    = clc$string_type =
      create_string_value;
    ELSE
      no_initial_value;
    CASEND;

    space_size := i#current_sequence_position (work_area) -
          initial_position - #SIZE (clt$internal_data_value_header) + header^.unused_space;
    RESET work_area TO header;
    NEXT internal_value: [[REP space_size OF cell]] IN work_area;
    IF internal_value = NIL THEN
      work_area_overflow;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND clp$create_default_init_value;
*IFEND

MODEND clm$data_value_conversion;

*DECK DECK=CLM$DATE_TIME_CONVERSION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL : Conversions between the "binary" and string forms for dates and times.' ??
MODULE clm$date_time_conversion;

{
{ PURPOSE:
{   This module contains the requests CLP$CONVERT_DATE_TIME_TO_STRING,
{   CLP$CONVERT_STRING_TO_DATE_TIME, etc.  These requests handle the
{   transformation between the myriad formats for date and time data.
{

?? NEWTITLE := 'Global declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_date_time_format
*copyc clt$date_or_time
*copyc clt$date_time
*copyc clt$date_time_form_string
*copyc clt$day_and_month_names
*copyc clt$name
*copyc ose$message_gen_exceptions
*copyc oss$job_paged_literal
*copyc ost$date
*copyc ost$day_of_week
*copyc ost$name
*copyc ost$status
*copyc ost$string
*copyc ost$time
*copyc ost$time_zone
*copyc pmt$time_increment
?? POP ??
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_unsigned_decimal
*IF NOT $true(osv$unix)
*copyc clp$find_help_module
*IFEND
*copyc clp$find_day_and_month_names
*copyc clp$get_day_and_month_names
*copyc clp$initialize_parse_state
*copyc clp$scan_lexical_unit
*copyc clp$trimmed_string_size
*copyc clp$validate_name
*copyc clv$day_and_month_names_list
*copyc clv$english_day_and_month_names
*copyc clv$non_decimal_digit
*copyc clv$non_space
*IF NOT $true(osv$unix)
*copyc osp$find_natural_language
*copyc osp$find_parameter_prompt
*copyc osp$generate_log_message
*ELSE
*copyc clt$parameter_name
*copyc ost$natural_language
*IFEND
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc pmp$compute_day_of_week
*copyc pmp$get_compact_date_time
*copyc pmp$get_default_date_time_form
*copyc pmp$get_time_zone
*IF NOT $true(osv$unix)
*copyc pmp$log
*IFEND
*copyc pmp$this_is_a_leap_year
?? EJECT ??

  TYPE
    clt$large_dt_form_string = string ( * <= clc$max_date_time_form_string + 3);

  CONST
    clc$max_day_name = 9,
    clc$max_month_name = 9;


  VAR
    clv$last_day_of_month: [STATIC, READ, oss$job_paged_literal] array [1 .. 12] of
          28 .. 31 := [31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31];

  VAR
    clv$cumulative_days: [STATIC, READ, oss$job_paged_literal] array [0 .. 12] of
          0 .. 365 := [0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365];

  VAR
    clv$cumulative_leap_days: [STATIC, READ, oss$job_paged_literal] array [0 .. 12] of
          0 .. 366 := [0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366];

  VAR
    clv$right_paren: [STATIC, READ, oss$job_paged_literal] packed array [char] of boolean := [
          {---} REP 41 of FALSE, { ) } TRUE, {---} REP 214 of FALSE];

  VAR
    clv$non_international_letter: [STATIC, READ, oss$job_paged_literal] packed array [char] of boolean := [
          {---} REP 65 of TRUE, {A..Z} REP 26 of FALSE, { [ } FALSE, { \ } FALSE, { ] } FALSE, { ^ } FALSE,
    {---}
    REP 2 of TRUE, {a..z} REP 26 of FALSE, { { } FALSE, { | } FALSE, { } FALSE, { ~ } FALSE,
          {---} REP 129 of TRUE];

  VAR
    clv$non_date_time_separator: [STATIC, READ, oss$job_paged_literal] packed array [char] of boolean := [
          {---} REP 32 of TRUE, {   } FALSE, {---} REP 11 of TRUE, { , } FALSE, { - } FALSE, { . } FALSE,
    { / }
    FALSE, {---} REP 10 of TRUE, { : } FALSE, {---} REP 36 of TRUE, { _ } FALSE, {---} REP 160 of TRUE];

  TYPE
    clt$date_time_pieces = (clc$undefined, clc$mn_lang, clc$mn, clc$ma_lang, clc$ma, clc$m2, clc$dn_lang,
          clc$dn, clc$da_lang, clc$da, clc$d2, clc$y2, clc$y4, clc$year, clc$j3, clc$dot, clc$hyphen,
          clc$comma, clc$colon, clc$space, clc$slash, clc$date_name, clc$date_number, clc$h24, clc$h12,
          clc$mm, clc$ss, clc$s10, clc$s100, clc$s1000, clc$month, clc$mdy, clc$dmy, clc$isod, clc$ordinal,
          clc$amorpm, clc$millisecond, clc$tz, clc$tz_lang, clc$tza, clc$tza_lang),

    clt$date_time_set = set of clt$date_time_pieces;

  TYPE
    clt$ampm_specification = (clc$no_ampm, clc$am, clc$pm);

  TYPE
    clt$hours_specification = (clc$hours_12, clc$hours_24);

  CONST
    dst_string = 'DAYLIGHT_SAVING_TIME',
    dst_string_length = 20,
    st_string = 'STANDARD_TIME',
    st_string_length = 13,
    clc$max_time_string = 12,
    clc$max_date_string = 18,
    clc$time_substring = 8,
    clc$max_date_or_time_pieces = 7,
    clc$max_total_date_time_pieces = (clc$max_date_or_time_pieces * 2) + 1 + 10,
    {+ 10 for extraneous separators that a user might decide to throw in.}
    clc$max_built_in_formats = 15;

  TYPE
    clt$input_format = record
      piece: array [1 .. clc$max_total_date_time_pieces] of clt$date_time_pieces,
      size: array [1 .. clc$max_total_date_time_pieces] of 0 .. 31,
      index: array [1 .. clc$max_total_date_time_pieces] of 0 .. 255,
    recend;

  TYPE
    clt$format_types = record
      num_of_elements: 1 .. clc$max_date_or_time_pieces,
      date_or_time: clt$date_or_time,
      elements: array [1 .. clc$max_date_or_time_pieces] of clt$date_time_pieces,
      format: array [1 .. clc$max_date_or_time_pieces] of clt$date_time_pieces,
    recend;

?? FMT (FORMAT := OFF) ??

  VAR
    built_in_formats: [STATIC, READ, oss$job_paged_literal] array [1 .. clc$max_built_in_formats] of
      clt$format_types := [
         [7, clc$time,
         [clc$date_number, clc$colon, clc$date_number, clc$colon, clc$date_number, clc$dot,
          clc$date_number],
         [clc$h24, clc$colon, clc$mm, clc$colon, clc$ss, clc$dot, clc$s1000]],
         [7, clc$time,
         [clc$date_number, clc$dot, clc$date_number, clc$dot, clc$date_number, clc$comma, clc$date_number],
         [clc$h24, clc$dot, clc$mm, clc$dot, clc$ss, clc$comma, clc$s100]],
         [5, clc$time,
         [clc$date_number, clc$colon, clc$date_number, clc$space, clc$date_name, clc$undefined,
          clc$undefined],
         [clc$h12, clc$colon, clc$mm, clc$space, clc$amorpm, clc$undefined, clc$undefined]],
         [5, clc$time,
         [clc$date_number, clc$colon, clc$date_number, clc$colon, clc$date_number, clc$undefined,
          clc$undefined],
         [clc$h24, clc$colon, clc$mm, clc$colon, clc$ss, clc$undefined, clc$undefined]],
         [5, clc$date,
         [clc$date_name, clc$space, clc$date_number, clc$comma, clc$date_number, clc$undefined,
          clc$undefined],
         [clc$mn, clc$space, clc$d2, clc$comma, clc$year, clc$undefined, clc$undefined]],
         [5, clc$date,
         [clc$date_number, clc$space, clc$date_name, clc$space, clc$date_number, clc$undefined,
          clc$undefined],
         [clc$d2, clc$space, clc$mn, clc$space, clc$year, clc$undefined, clc$undefined]],
         [5, clc$date,
         [clc$date_number, clc$hyphen, clc$date_name, clc$hyphen, clc$date_number, clc$undefined,
          clc$undefined],
         [clc$d2, clc$hyphen, clc$mn, clc$hyphen, clc$year, clc$undefined, clc$undefined]],
         [5, clc$date,
         [clc$date_number, clc$slash, clc$date_number, clc$slash, clc$date_number, clc$undefined,
          clc$undefined],
         [clc$m2, clc$slash, clc$d2, clc$slash, clc$year, clc$undefined, clc$undefined]],
         [5, clc$date,
         [clc$date_number, clc$hyphen, clc$date_number, clc$hyphen, clc$date_number, clc$undefined,
          clc$undefined],
         [clc$year, clc$hyphen, clc$m2, clc$hyphen, clc$d2, clc$undefined, clc$undefined]],
         [5, clc$date,
         [clc$date_number, clc$dot, clc$date_number, clc$dot, clc$date_number, clc$undefined,
          clc$undefined],
         [clc$d2, clc$dot, clc$m2, clc$dot, clc$year, clc$undefined, clc$undefined]],
         [3, clc$date,
         [clc$date_number, clc$date_name, clc$date_number, clc$undefined, clc$undefined, clc$undefined,
          clc$undefined],
         [clc$d2, clc$mn, clc$year, clc$undefined, clc$undefined, clc$undefined, clc$undefined]],
         [3, clc$date,
         [clc$date_number, clc$date_number, clc$date_number, clc$undefined, clc$undefined, clc$undefined,
          clc$undefined],
         [clc$year, clc$m2, clc$d2, clc$undefined, clc$undefined, clc$undefined, clc$undefined]],
         [3, clc$date,
         [clc$date_number, clc$hyphen, clc$date_number, clc$undefined, clc$undefined, clc$undefined,
          clc$undefined],
         [clc$year, clc$hyphen, clc$j3, clc$undefined, clc$undefined, clc$undefined, clc$undefined]],
         [1, clc$date,
         [clc$date_number, clc$undefined, clc$undefined, clc$undefined, clc$undefined, clc$undefined,
          clc$undefined],
         [clc$undefined, clc$undefined, clc$undefined, clc$undefined, clc$undefined, clc$undefined,
          clc$undefined]],
         [1, clc$date,
         [clc$date_name, clc$undefined, clc$undefined, clc$undefined, clc$undefined, clc$undefined,
          clc$undefined],
         [clc$undefined, clc$undefined, clc$undefined, clc$undefined, clc$undefined, clc$undefined,
          clc$undefined]]];

?? FMT (FORMAT := ON) ??
?? TITLE := 'interpret_language', EJECT ??

  PROCEDURE [INLINE] interpret_language
    (    format_string: clt$large_dt_form_string;
         start_index: 0 .. clc$max_date_time_form_string;
     VAR language_size: 0 .. 31;
     VAR status: ost$status);

    VAR
      name_ok: boolean,
      separator_index: integer,
      separator_found: boolean,
      valid_language: ost$natural_language;


    status.normal := TRUE;

    name_ok := FALSE;
    separator_index := 0;
    separator_found := FALSE;
    valid_language := '';

    #SCAN (clv$right_paren, format_string (start_index, * ), separator_index, separator_found);
    IF NOT separator_found THEN
      osp$set_status_abnormal ('CL', cle$language_delimiter_missing, '', status);
      RETURN;
    IFEND;
    language_size := separator_index - 1;
    clp$validate_name (format_string (start_index, language_size), valid_language, name_ok);
    IF NOT name_ok THEN
      osp$set_status_abnormal ('CL', ose$bad_natural_language, format_string (start_index, language_size),
            status);
    IFEND;

  PROCEND interpret_language;
?? TITLE := 'convert_integer_to_rj_string', EJECT ??

  CONST
    max_digits_to_convert_to_string = 4;

?? SKIP := 3 ??

  PROCEDURE [INLINE] convert_integer_to_rj_string
    (    intger: integer;
         fill_character: char;
     VAR strng: string ( * <= max_digits_to_convert_to_string));

    VAR
      int: integer,
      length: 0 .. max_digits_to_convert_to_string,
      i: integer;


    int := intger;
    length := STRLENGTH (strng);

    REPEAT
      strng (length) := $CHAR ((int MOD 10) + $INTEGER ('0'));
      length := length - 1;
      int := int DIV 10;
    UNTIL (int = 0);

    FOR i := 1 TO length DO
      strng (i) := fill_character;
    FOREND;

  PROCEND convert_integer_to_rj_string;
?? TITLE := 'read_format_string', EJECT ??

  PROCEDURE read_format_string
    (    format_string: clt$date_time_form_string;
     VAR format_data: clt$input_format;
     VAR array_index: integer;
     VAR leading_zeroes: boolean;
     VAR need_preferred_language: boolean;
     VAR status: ost$status);

    VAR
      char_found: boolean,
      char_position: integer,
      date_format: string (clc$max_date_time_form_string + 3),
      {Make sure there is room in the date_format to look past end.}
      format_length: integer,
      ignore_status: ost$status,
      language: ost$natural_language,
      language_start: integer,
      log_status: ost$status;


    status.normal := TRUE;

    char_found := FALSE;
    char_position := 0;
    date_format := '';
    format_length := clp$trimmed_string_size (format_string);
    language_start := 0;
    leading_zeroes := TRUE;
    need_preferred_language := FALSE;

    #TRANSLATE (osv$lower_to_upper, format_string, date_format);

    #SCAN (clv$non_space, date_format, char_position, char_found);
    IF NOT char_found THEN
      osp$set_status_abnormal ('CL', cle$date_time_format_null, format_string, status);
    IFEND;

{ Step through format string to see what version of the date and time is
{wanted.}

    array_index := 0;
    REPEAT
      array_index := array_index + 1;

      IF date_format (char_position, 2) = 'MS' THEN
        format_data.piece [array_index] := clc$h24;
        format_data.piece [array_index + 1] := clc$colon;
        format_data.piece [array_index + 2] := clc$mm;
        format_data.piece [array_index + 3] := clc$colon;
        format_data.piece [array_index + 4] := clc$ss;
        format_data.piece [array_index + 5] := clc$dot;
        format_data.piece [array_index + 6] := clc$s1000;
        array_index := array_index + 6;
        char_position := char_position + 2;

      ELSEIF date_format (char_position, 11) = 'MILLISECOND' THEN
        format_data.piece [array_index] := clc$h24;
        format_data.piece [array_index + 1] := clc$colon;
        format_data.piece [array_index + 2] := clc$mm;
        format_data.piece [array_index + 3] := clc$colon;
        format_data.piece [array_index + 4] := clc$ss;
        format_data.piece [array_index + 5] := clc$dot;
        format_data.piece [array_index + 6] := clc$s1000;
        array_index := array_index + 6;
        char_position := char_position + 11;

      ELSEIF date_format (char_position, 3) = 'HMS' THEN
        format_data.piece [array_index] := clc$h24;
        format_data.piece [array_index + 1] := clc$colon;
        format_data.piece [array_index + 2] := clc$mm;
        format_data.piece [array_index + 3] := clc$colon;
        format_data.piece [array_index + 4] := clc$ss;
        array_index := array_index + 4;
        char_position := char_position + 3;

      ELSEIF date_format (char_position, 4) = 'AMPM' THEN
        format_data.piece [array_index] := clc$h12;
        format_data.piece [array_index + 1] := clc$colon;
        format_data.piece [array_index + 2] := clc$mm;
        format_data.piece [array_index + 3] := clc$space;
        format_data.piece [array_index + 4] := clc$amorpm;
        array_index := array_index + 4;
        char_position := char_position + 4;

      ELSEIF date_format (char_position, 6) = 'AMORPM' THEN
        format_data.piece [array_index] := clc$amorpm;
        char_position := char_position + 6;

      ELSEIF date_format (char_position, 4) = 'ISOT' THEN
        format_data.piece [array_index] := clc$h24;
        format_data.piece [array_index + 1] := clc$dot;
        format_data.piece [array_index + 2] := clc$mm;
        format_data.piece [array_index + 3] := clc$dot;
        format_data.piece [array_index + 4] := clc$ss;
        format_data.piece [array_index + 5] := clc$comma;
        format_data.piece [array_index + 6] := clc$s100;
        array_index := array_index + 6;
        char_position := char_position + 4;

      ELSEIF date_format (char_position, 4) = 'ISOD' THEN
        format_data.piece [array_index] := clc$y4;
        format_data.piece [array_index + 1] := clc$hyphen;
        format_data.piece [array_index + 2] := clc$m2;
        format_data.piece [array_index + 3] := clc$hyphen;
        format_data.piece [array_index + 4] := clc$d2;
        array_index := array_index + 4;
        char_position := char_position + 4;

      ELSEIF date_format (char_position, 7) = 'ORDINAL' THEN
        format_data.piece [array_index] := clc$y4;
        format_data.piece [array_index + 1] := clc$j3;
        array_index := array_index + 1;
        char_position := char_position + 7;

      ELSEIF date_format (char_position) = 'D' THEN
        char_position := char_position + 1;

        IF date_format (char_position) = '2' THEN
          format_data.piece [array_index] := clc$d2;
          char_position := char_position + 1;

        ELSEIF date_format (char_position) = 'N' THEN
          IF date_format (char_position + 1) = '(' THEN
            format_data.index [array_index] := char_position + 2; {Beginning of language string.}
            interpret_language (date_format, format_data.index [array_index], format_data.size [array_index],
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            char_position := format_data.index [array_index] + format_data.size [array_index] + 1;
            format_data.piece [array_index] := clc$dn_lang;

          ELSE
            need_preferred_language := TRUE;
            format_data.piece [array_index] := clc$dn;
            char_position := char_position + 1;
          IFEND;

        ELSEIF date_format (char_position) = 'A' THEN
          IF date_format (char_position + 1) = '(' THEN
            format_data.index [array_index] := char_position + 2; {Beginning of language string.}
            interpret_language (date_format, format_data.index [array_index], format_data.size [array_index],
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            char_position := format_data.index [array_index] + format_data.size [array_index] + 1;
            format_data.piece [array_index] := clc$da_lang;

          ELSE
            need_preferred_language := TRUE;
            format_data.piece [array_index] := clc$da;
            char_position := char_position + 1;
          IFEND

        ELSEIF date_format (char_position, 2) = 'MY' THEN
{Format is DMY}
          format_data.piece [array_index] := clc$d2;
          format_data.piece [array_index + 1] := clc$dot;
          format_data.piece [array_index + 2] := clc$m2;
          format_data.piece [array_index + 3] := clc$dot;
          format_data.piece [array_index + 4] := clc$y2;
          array_index := array_index + 4;
          char_position := char_position + 2;

        ELSE
          osp$set_status_abnormal ('CL', cle$unexpected_dt_format_char, date_format (char_position - 1, 2),
                status);
          RETURN;
        IFEND;

      ELSEIF date_format (char_position) = 'M' THEN
        char_position := char_position + 1;

        IF date_format (char_position) = '2' THEN
          format_data.piece [array_index] := clc$m2;
          char_position := char_position + 1;

        ELSEIF date_format (char_position) = 'N' THEN
          IF date_format (char_position + 1) = '(' THEN
            format_data.index [array_index] := char_position + 2; {Beginning of language string.}
            interpret_language (date_format, format_data.index [array_index], format_data.size [array_index],
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            char_position := format_data.index [array_index] + format_data.size [array_index] + 1;
            format_data.piece [array_index] := clc$mn_lang;

          ELSE
            need_preferred_language := TRUE;
            format_data.piece [array_index] := clc$mn;
            char_position := char_position + 1;
          IFEND;

          IF (date_format (char_position) = ' ') OR (date_format (char_position) = '-') THEN
            leading_zeroes := FALSE;
          IFEND;

        ELSEIF date_format (char_position) = 'A' THEN
          IF date_format (char_position + 1) = '(' THEN
            format_data.index [array_index] := char_position + 2; {Beginning of language string.}
            interpret_language (date_format, format_data.index [array_index], format_data.size [array_index],
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            char_position := format_data.index [array_index] + format_data.size [array_index] + 1;
            format_data.piece [array_index] := clc$ma_lang;

          ELSE
            need_preferred_language := TRUE;
            format_data.piece [array_index] := clc$ma;
            char_position := char_position + 1;
          IFEND;

          IF (date_format (char_position) = ' ') OR (date_format (char_position) = '-') THEN
            leading_zeroes := FALSE;
          IFEND;

        ELSEIF date_format (char_position, 2) = 'DY' THEN
{Format is MDY}
          format_data.piece [array_index] := clc$m2;
          format_data.piece [array_index + 1] := clc$slash;
          format_data.piece [array_index + 2] := clc$d2;
          format_data.piece [array_index + 3] := clc$slash;
          format_data.piece [array_index + 4] := clc$y2;
          array_index := array_index + 4;
          char_position := char_position + 2;

        ELSEIF date_format (char_position, 4) = 'ONTH' THEN
{Format is MONTH}
          format_data.piece [array_index] := clc$mn;
          format_data.piece [array_index + 1] := clc$space;
          format_data.piece [array_index + 2] := clc$d2;
          format_data.piece [array_index + 3] := clc$comma;
          format_data.piece [array_index + 4] := clc$y4;
          array_index := array_index + 4;
          char_position := char_position + 4;
          need_preferred_language := TRUE;
          leading_zeroes := FALSE;

        ELSEIF date_format (char_position) = 'M' THEN
          format_data.piece [array_index] := clc$mm;
          char_position := char_position + 1;

        ELSE
          osp$set_status_abnormal ('CL', cle$unexpected_dt_format_char, date_format (char_position - 1, 2),
                status);
          RETURN;
        IFEND;

      ELSEIF date_format (char_position) = 'T' THEN
        char_position := char_position + 1;

        IF date_format (char_position) = 'Z' THEN
          IF date_format (char_position + 1) = 'A' THEN
            IF date_format (char_position + 2) = '(' THEN
              format_data.index [array_index] := char_position + 3; {Beginning of language string.}
              interpret_language (date_format, format_data.index [array_index],
                    format_data.size [array_index], status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              char_position := format_data.index [array_index] + format_data.size [array_index] + 1;
              format_data.piece [array_index] := clc$tza_lang;

            ELSE
              need_preferred_language := TRUE;
              format_data.piece [array_index] := clc$tza;
              char_position := char_position + 2;
            IFEND;

          ELSEIF date_format (char_position + 1) = '(' THEN
            format_data.index [array_index] := char_position + 2; {Beginning of language string.}
            interpret_language (date_format, format_data.index [array_index], format_data.size [array_index],
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            char_position := format_data.index [array_index] + format_data.size [array_index] + 1;
            format_data.piece [array_index] := clc$tz_lang;

          ELSE
            need_preferred_language := TRUE;
            format_data.piece [array_index] := clc$tz;
            char_position := char_position + 1;
          IFEND;

        ELSE
          osp$set_status_abnormal ('CL', cle$unexpected_dt_format_char, date_format (char_position - 1, 2),
                status);
          RETURN;
        IFEND;

      ELSEIF date_format (char_position) = 'H' THEN
        char_position := char_position + 1;

        IF date_format (char_position, 2) = '12' THEN
          format_data.piece [array_index] := clc$h12;
          char_position := char_position + 2;

        ELSEIF date_format (char_position, 2) = '24' THEN
          format_data.piece [array_index] := clc$h24;
          char_position := char_position + 2;

        ELSE
          osp$set_status_abnormal ('CL', cle$unexpected_dt_format_char, date_format (char_position - 1, 2),
                status);
          RETURN;
        IFEND;

      ELSEIF date_format (char_position) = 'Y' THEN
        char_position := char_position + 1;

        IF date_format (char_position) = '2' THEN
          format_data.piece [array_index] := clc$y2;
          char_position := char_position + 1;

        ELSEIF date_format (char_position) = '4' THEN
          format_data.piece [array_index] := clc$y4;
          char_position := char_position + 1;

        ELSE
          osp$set_status_abnormal ('CL', cle$unexpected_dt_format_char, date_format (char_position - 1, 2),
                status);
          RETURN;
        IFEND;

      ELSEIF date_format (char_position) = 'S' THEN
        char_position := char_position + 1;

        IF date_format (char_position) = 'S' THEN
          format_data.piece [array_index] := clc$ss;
          char_position := char_position + 1;

        ELSEIF date_format (char_position) = '1' THEN
          IF date_format (char_position + 3) = '0' THEN
            format_data.piece [array_index] := clc$s1000;
            char_position := char_position + 3;

          ELSEIF date_format (char_position + 2) = '0' THEN
            format_data.piece [array_index] := clc$s100;
            char_position := char_position + 2;

          ELSEIF date_format (char_position + 1) = '0' THEN
            format_data.piece [array_index] := clc$s10;
            char_position := char_position + 1;
          IFEND;

        ELSE
          osp$set_status_abnormal ('CL', cle$unexpected_dt_format_char, date_format (char_position - 1, 2),
                status);
          RETURN;
        IFEND;

      ELSEIF date_format (char_position, 2) = 'J3' THEN
        format_data.piece [array_index] := clc$j3;
        char_position := char_position + 2;

      ELSEIF date_format (char_position) = '-' THEN
        format_data.piece [array_index] := clc$hyphen;
        char_position := char_position + 1;

      ELSEIF date_format (char_position) = ' ' THEN
        format_data.piece [array_index] := clc$space;
        WHILE (date_format (char_position) = ' ') AND (char_position < format_length) DO
          char_position := char_position + 1;
        WHILEND;

      ELSEIF date_format (char_position) = '/' THEN
        format_data.piece [array_index] := clc$slash;
        char_position := char_position + 1;

      ELSEIF date_format (char_position) = ':' THEN
        format_data.piece [array_index] := clc$colon;
        char_position := char_position + 1;

      ELSEIF date_format (char_position) = '.' THEN
        format_data.piece [array_index] := clc$dot;
        char_position := char_position + 1;

      ELSEIF date_format (char_position) = ',' THEN
        IF (array_index > 1) AND (format_data.piece [array_index - 1] = clc$space) THEN
          array_index := array_index - 1;
        IFEND;
        format_data.piece [array_index] := clc$comma;
        char_position := char_position + 1;
        WHILE (date_format (char_position) = ' ') AND (char_position < format_length) DO
          char_position := char_position + 1;
        WHILEND;

      ELSE
        osp$set_status_abnormal ('CL', cle$unexpected_dt_format_char, date_format (char_position), status);
        RETURN;
      IFEND;
    UNTIL (char_position >= format_length);

    IF format_data.piece [array_index] = clc$space THEN
      array_index := array_index - 1;
    IFEND;

  PROCEND read_format_string;
?? TITLE := 'compare_format_arrays', EJECT ??

  PROCEDURE [INLINE] compare_format_arrays
    (    input_format: clt$input_format;
     VAR piece_index: 1 .. clc$max_total_date_time_pieces;
     VAR matching_index: 1 .. clc$max_built_in_formats;
     VAR status: ost$status);

    VAR
      index: 1 .. clc$max_date_or_time_pieces + 1,
      temp_matching_index: 1 .. clc$max_built_in_formats + 1,
      temp_piece: 1 .. clc$max_total_date_time_pieces;


    status.normal := TRUE;
    matching_index := 1;
    temp_matching_index := 1;
    index := 1;

    IF piece_index > clc$max_total_date_time_pieces THEN
      osp$set_status_abnormal ('CL', cle$unknown_date_time_format, '', status);
      RETURN;
    IFEND;

    WHILE temp_matching_index <= clc$max_built_in_formats DO
      temp_piece := piece_index;

    /check_formats/
      WHILE TRUE DO
        IF index > built_in_formats [temp_matching_index].num_of_elements THEN
          piece_index := piece_index + built_in_formats [temp_matching_index].num_of_elements;
          matching_index := temp_matching_index;
          RETURN;
        ELSEIF input_format.piece [temp_piece] <> built_in_formats [temp_matching_index].elements [index] THEN
          EXIT /check_formats/;
        ELSE
          temp_piece := temp_piece + 1;
          index := index + 1;
        IFEND;
      WHILEND /check_formats/;

      index := 1;
      temp_matching_index := temp_matching_index + 1;
    WHILEND;

    osp$set_status_abnormal ('CL', cle$unknown_date_time_format, '', status);

  PROCEND compare_format_arrays;
?? TITLE := 'clp$convert_string_to_date_time', EJECT ??
*copyc clh$convert_string_to_date_time

  PROCEDURE [XDCL, #GATE] clp$convert_string_to_date_time
    (    str: string ( * );
         format: clt$date_time_form_string;
     VAR date_time: clt$date_time;
     VAR status: ost$status);

    VAR
      am_pm: string (2),
      ampm_spec: clt$ampm_specification,
      char_position: integer,
      date_name: string (clc$max_date_string),
      language: ost$natural_language,
      end_index: integer,
      fill_match: integer, {fill_match holds position in format_data array}
      format_index: integer,
      found: boolean,
      hours_spec: clt$hours_specification,
      temp_data: integer,
      i: integer,
      count: integer,
      j3: integer,
      j3_specified: boolean,
      leading_zeroes: boolean,
      log_status: ost$status,
      format_data: clt$input_format,
      {} {holds date_time format extracted from built_in_formats}
            matching_index: 1 .. clc$max_built_in_formats,
      {} {matching_index indicates matching format in built_in_formats}
            need_preferred_language: boolean,
      piece_index: 1 .. clc$max_total_date_time_pieces,
      {} {piece_index keeps track of location in str_format}
            preferred_language: ost$natural_language,
      selected_language: ^ost$natural_language,
      str_format: clt$input_format,
      str_length: integer,
      today: ost$date_time;

?? NEWTITLE := 'interpret_input_string', EJECT ??

    PROCEDURE interpret_input_string
      (VAR status: ost$status);

?? NEWTITLE := 'shift_str_format_array', EJECT ??

      PROCEDURE [INLINE] shift_str_format_array
        (    size: integer);


{Shift everything in the array over one position to the right.}
        FOR i := clc$max_total_date_time_pieces DOWNTO piece_index + 1 + 1 DO
          str_format.piece [i] := str_format.piece [i - 1];
          str_format.size [i] := str_format.size [i - 1];
          str_format.index [i] := str_format.index [i - 1];
        FOREND;

        str_format.piece [piece_index + 1] := clc$date_number;
        str_format.size [piece_index + 1] := str_format.size [piece_index] - size;
        str_format.index [piece_index + 1] := str_format.index [piece_index] + size;

        str_format.size [piece_index] := size;
        {Index and type of piece for first piece is OK}

      PROCEND shift_str_format_array;
?? OLDTITLE, EJECT ??

      piece_index := 1;
      FOR format_index := 1 TO count DO
        CASE format_data.piece [format_index] OF

        = clc$h12 =
          clp$evaluate_unsigned_decimal (str (str_format.index [piece_index], str_format.size [piece_index]),
                temp_data, status);
          IF NOT status.normal THEN
            RETURN;
          ELSEIF (temp_data < 1) OR (temp_data > 12) OR (date_time.time_specified) THEN
            osp$set_status_abnormal ('CL', cle$impossible_date_or_time, str, status);
            RETURN;
          IFEND;
          hours_spec := clc$hours_12;
          date_time.time_specified := TRUE;
          date_time.value.hour := temp_data;
          piece_index := piece_index + 1;

        = clc$h24 =
          IF (format_index + 1 <= count) AND (str_format.size [piece_index] > 2) THEN
            shift_str_format_array (2);
          IFEND;
          clp$evaluate_unsigned_decimal (str (str_format.index [piece_index], str_format.size [piece_index]),
                temp_data, status);
          IF NOT status.normal THEN
            RETURN;
          ELSEIF (temp_data < 0) OR (temp_data > 23) OR (date_time.time_specified) THEN
            osp$set_status_abnormal ('CL', cle$impossible_date_or_time, str, status);
            RETURN;
          IFEND;
          hours_spec := clc$hours_24;
          date_time.time_specified := TRUE;
          date_time.value.hour := temp_data;
          piece_index := piece_index + 1;

        = clc$s10 =
          clp$evaluate_unsigned_decimal (str (str_format.index [piece_index], str_format.size [piece_index]),
                temp_data, status);
          IF NOT status.normal THEN
            RETURN;
          ELSEIF (temp_data < 0) OR (temp_data > 9) THEN
            osp$set_status_abnormal ('CL', cle$impossible_date_or_time, str, status);
            RETURN;
          IFEND;
          date_time.time_specified := TRUE;
          date_time.value.millisecond := temp_data * 100;
          piece_index := piece_index + 1;

        = clc$s100 =
          clp$evaluate_unsigned_decimal (str (str_format.index [piece_index], str_format.size [piece_index]),
                temp_data, status);
          IF NOT status.normal THEN
            RETURN;
          ELSEIF (temp_data < 0) OR (temp_data > 99) THEN
            osp$set_status_abnormal ('CL', cle$impossible_date_or_time, str, status);
            RETURN;
          IFEND;
          date_time.time_specified := TRUE;
          date_time.value.millisecond := temp_data * 10;
          piece_index := piece_index + 1;

        = clc$s1000 =
          clp$evaluate_unsigned_decimal (str (str_format.index [piece_index], str_format.size [piece_index]),
                temp_data, status);
          IF NOT status.normal THEN
            RETURN;
          ELSEIF (temp_data < 0) OR (temp_data > 999) THEN
            osp$set_status_abnormal ('CL', cle$impossible_date_or_time, str, status);
            RETURN;
          IFEND;
          date_time.time_specified := TRUE;
          date_time.value.millisecond := temp_data;
          piece_index := piece_index + 1;

        = clc$mm =
          IF (format_index + 1 <= count) AND (str_format.size [piece_index] > 2) THEN
            shift_str_format_array (2);
          IFEND;
          clp$evaluate_unsigned_decimal (str (str_format.index [piece_index], str_format.size [piece_index]),
                temp_data, status);
          IF NOT status.normal THEN
            RETURN;
          ELSEIF (temp_data < 0) OR (temp_data > 59) THEN
            osp$set_status_abnormal ('CL', cle$impossible_date_or_time, str, status);
            RETURN;
          IFEND;
          date_time.time_specified := TRUE;
          date_time.value.minute := temp_data;
          piece_index := piece_index + 1;

        = clc$ss =
          IF (format_index + 1 <= count) AND (str_format.size [piece_index] > 2) THEN
            shift_str_format_array (2);
          IFEND;
          clp$evaluate_unsigned_decimal (str (str_format.index [piece_index], str_format.size [piece_index]),
                temp_data, status);
          IF NOT status.normal THEN
            RETURN;
          ELSEIF (temp_data < 0) OR (temp_data > 59) THEN
            osp$set_status_abnormal ('CL', cle$impossible_date_or_time, str, status);
            RETURN;
          IFEND;
          date_time.time_specified := TRUE;
          date_time.value.second := temp_data;
          piece_index := piece_index + 1;

        = clc$d2 =
          IF str_format.piece [piece_index] <> clc$date_number THEN
            osp$set_status_abnormal ('CL', cle$unknown_date_time_format, str, status);
            RETURN;
          IFEND;

          IF (format_index + 1 <= count) AND (str_format.size [piece_index] > 2) THEN
            shift_str_format_array (2);
          IFEND;

          clp$evaluate_unsigned_decimal (str (str_format.index [piece_index], str_format.size [piece_index]),
                temp_data, status);
          IF NOT status.normal THEN
            RETURN;
          ELSEIF (temp_data < 1) OR (temp_data > 31) THEN
            osp$set_status_abnormal ('CL', cle$impossible_date_or_time, str, status);
            RETURN;
          IFEND;
          date_time.value.day := temp_data;
          piece_index := piece_index + 1;

        = clc$dn, clc$da, clc$dn_lang, clc$da_lang =
{When converting a string to a date time, the day of the week is irrelevant information.
{No processing needs to take place except for some checking.
          IF (str_format.piece [piece_index] <> clc$date_name) THEN
            osp$set_status_abnormal ('CL', cle$unknown_date_time_format, str, status);
            RETURN;
          IFEND;
          piece_index := piece_index + 1;

        = clc$mn, clc$ma =
          IF str_format.piece [piece_index] <> clc$date_name THEN
            osp$set_status_abnormal ('CL', cle$unknown_date_time_format, str, status);
            RETURN;
          IFEND;
          #TRANSLATE (osv$lower_to_upper, str (str_format.index [piece_index], str_format.size [piece_index]),
                date_name);
          get_month_number (preferred_language, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          piece_index := piece_index + 1;

        = clc$ma_lang, clc$mn_lang =
          IF str_format.piece [piece_index] <> clc$date_name THEN
            osp$set_status_abnormal ('CL', cle$unknown_date_time_format, str, status);
            RETURN;
          IFEND;
          #TRANSLATE (osv$lower_to_upper, str (str_format.index [piece_index], str_format.size [piece_index]),
                date_name);
          language := format (format_data.index [format_index], format_data.size [format_index]);
          get_month_number (language, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          piece_index := piece_index + 1;

        = clc$m2 =
          IF str_format.piece [piece_index] <> clc$date_number THEN
            osp$set_status_abnormal ('CL', cle$unknown_date_time_format, str, status);
            RETURN;
          IFEND;

          IF (format_index + 1 <= count) AND (str_format.size [piece_index] > 2) THEN
            shift_str_format_array (2);
          IFEND;

          clp$evaluate_unsigned_decimal (str (str_format.index [piece_index], str_format.size [piece_index]),
                temp_data, status);
          IF NOT status.normal THEN
            RETURN;
          ELSEIF (temp_data < 1) OR (temp_data > 12) THEN
            osp$set_status_abnormal ('CL', cle$impossible_date_or_time, str, status);
            RETURN;
          IFEND;
          date_time.value.month := temp_data;
          piece_index := piece_index + 1;

        = clc$y2, clc$y4, clc$year =
          IF (str_format.piece [piece_index] <> clc$date_number) OR (date_time.date_specified) THEN
            osp$set_status_abnormal ('CL', cle$unknown_date_time_format, str, status);
            RETURN;
          IFEND;

          {Check to see if one of the 'all number' formats has been given.}
          IF format_index + 1 <= count THEN
            IF (format_data.piece [format_index] = clc$y4) AND (str_format.size [piece_index] > 4) THEN
              shift_str_format_array (4);
            ELSEIF (format_data.piece [format_index] = clc$y2) AND (str_format.size [piece_index] > 6) THEN
{Assume that the format is the MAIL/VE required format of Y2M2D2H24MMSS.}
              shift_str_format_array (2);
            ELSEIF (format_data.piece [format_index] = clc$y2) AND (str_format.size [piece_index] > 2) THEN
              shift_str_format_array (2);
            ELSEIF format_data.piece [format_index] = clc$year THEN {One of the built_in formats.}
              CASE str_format.size [piece_index] OF
              = 5, 6 =
                shift_str_format_array (2);

              = 7, 8 =
                shift_str_format_array (4);

              ELSE
                ;
              CASEND;
            IFEND;
          IFEND;

          clp$evaluate_unsigned_decimal (str (str_format.index [piece_index], str_format.size [piece_index]),
                temp_data, status);
          IF NOT status.normal THEN
            RETURN;
          ELSEIF (temp_data >= 0) AND (temp_data <= 99) THEN
            date_time.value.year := temp_data;

{ This code allows NOS/VE to work until the year 2079.  It is neccessary because
{ otherwise the year value will be off by 100 years.

            IF (temp_data < 80) THEN
              date_time.value.year := date_time.value.year + 100;
            IFEND;
          ELSEIF (temp_data >= 1900) AND (temp_data <= 2155) THEN
            date_time.value.year := temp_data - 1900;
          ELSE
            osp$set_status_abnormal ('CL', cle$impossible_date_or_time, str, status);
            RETURN;
          IFEND;
          date_time.date_specified := TRUE;
          piece_index := piece_index + 1;

        = clc$j3 =
          IF str_format.piece [piece_index] <> clc$date_number THEN
            osp$set_status_abnormal ('CL', cle$unknown_date_time_format, str, status);
            RETURN;
          IFEND;

          IF (format_index + 1 <= count) AND (str_format.size [piece_index] > 3) THEN
            shift_str_format_array (3);
          IFEND;

          j3_specified := TRUE;
          j3 := piece_index;
          piece_index := piece_index + 1;

        = clc$amorpm =
          #TRANSLATE (osv$lower_to_upper, str (str_format.index [piece_index], 2), am_pm);
          IF am_pm = 'AM' THEN
            ampm_spec := clc$am;
          ELSEIF am_pm = 'PM' THEN
            ampm_spec := clc$pm;
          ELSE
            osp$set_status_abnormal ('CL', cle$impossible_date_or_time, str, status);
            RETURN;
          IFEND;
          piece_index := piece_index + 1;

        = clc$tz, clc$tz_lang, clc$tza, clc$tza_lang =
{If a time zone is present in the string, the date_time is not modified.}
          piece_index := piece_index + 1;

        = clc$slash, clc$dot, clc$hyphen, clc$colon, clc$comma, clc$space =
          piece_index := piece_index + 1;
          {don't need to do anything

        ELSE
          osp$set_status_abnormal ('CL', cle$unknown_date_time_format, '', status);
          RETURN;
        CASEND;
      FOREND;

    PROCEND interpret_input_string;
?? TITLE := 'get_month_number', EJECT ??

    PROCEDURE [INLINE] get_month_number
      (    language: ost$natural_language;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status,
        days_and_months_ptr: ^clt$day_and_month_names,
        month: string (clc$max_date_string),
        using_english: boolean;


      days_and_months_ptr := NIL;
      month := '';
      using_english := FALSE;

      clp$find_day_and_month_names (language, days_and_months_ptr);
      IF days_and_months_ptr = NIL THEN
        clp$get_day_and_month_names (language, days_and_months_ptr, status);
        IF NOT status.normal THEN
*IF NOT $true(osv$unix)
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], status, ignore_status);
*IFEND
          status.normal := TRUE;
          IF preferred_language = '' THEN
*IF NOT $true(osv$unix)
            osp$find_natural_language (selected_language);
            preferred_language := selected_language^;
*ELSE
            preferred_language := osc$english;
*IFEND
          IFEND;
          IF preferred_language <> language THEN
            clp$get_day_and_month_names (preferred_language, days_and_months_ptr, status);
            IF NOT status.normal THEN
*IF NOT $true(osv$unix)
              osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], status,
                    ignore_status);
*IFEND
              status.normal := TRUE;
              days_and_months_ptr := ^clv$english_day_and_month_names;
              using_english := TRUE;
            IFEND;
          ELSE
            days_and_months_ptr := ^clv$english_day_and_month_names;
            using_english := TRUE;
          IFEND;
        IFEND;
      IFEND;

    /find_month/
      WHILE TRUE DO
        FOR i := 1 TO 12 DO
          #TRANSLATE (osv$lower_to_upper, days_and_months_ptr^.months [i].value, month);
          IF date_name = month THEN
            date_time.value.month := i;
            RETURN;
          ELSE
            #TRANSLATE (osv$lower_to_upper, days_and_months_ptr^.months_abbrev [i].value, month);
            IF date_name = month THEN
              date_time.value.month := i;
              RETURN;
            IFEND;
          IFEND;
        FOREND;
        IF using_english THEN
{ English is what we just looked at - give up.}
          EXIT /find_month/;
        IFEND;
        days_and_months_ptr := ^clv$english_day_and_month_names;
        using_english := TRUE;
      WHILEND /find_month/;

      osp$set_status_abnormal ('CL', cle$name_not_month_or_day, date_name, status);

    PROCEND get_month_number;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    am_pm := '';
    ampm_spec := clc$no_ampm;
    char_position := 0;
    count := 0;
    date_name := '';
    language := '';
    end_index := 0;
    found := FALSE;
    hours_spec := clc$hours_12;
    j3 := 0;
    j3_specified := FALSE;
    leading_zeroes := TRUE;
    matching_index := 1;
    need_preferred_language := FALSE;
    piece_index := 1;
    preferred_language := '';
    str_length := STRLENGTH (str);
    temp_data := 0;

    {Initialize date_time variable.}
    date_time.value.year := 0;
    date_time.value.month := 1;
    date_time.value.day := 1;
    date_time.value.hour := 0;
    date_time.value.minute := 0;
    date_time.value.second := 0;
    date_time.value.millisecond := 0;
    date_time.date_specified := FALSE;
    date_time.time_specified := FALSE;

    {Initialize str_format variable.}
    FOR i := 1 TO clc$max_total_date_time_pieces DO
      str_format.piece [i] := clc$undefined;
      str_format.size [i] := 0;
      str_format.index [i] := 0;
    FOREND;

    {Initialize format_data variable.}
    FOR i := 1 TO clc$max_total_date_time_pieces DO
      format_data.piece [i] := clc$undefined;
      format_data.size [i] := 0;
      format_data.index [i] := 0;
    FOREND;

{Read input string to get data on date pieces.}

    #SCAN (clv$non_space, str, char_position, found);
    IF NOT found THEN
      osp$set_status_abnormal ('CL', cle$impossible_date_or_time, '"NULL STRING"', status);
      RETURN;
    IFEND;

    REPEAT
      count := count + 1;
      IF count > clc$max_total_date_time_pieces THEN
        osp$set_status_abnormal ('CL', cle$date_time_string_too_long, str, status);
        RETURN;
      IFEND;

      CASE str (char_position) OF
      = 'A' .. 'Z', 'a' .. 'z' =
        #SCAN (clv$non_international_letter, str (char_position, * ), end_index, found);
        str_format.size [count] := end_index - 1;
        str_format.index [count] := char_position;
        str_format.piece [count] := clc$date_name;
        char_position := char_position + end_index - 1;
      = '0' .. '9' =
        #SCAN (clv$non_decimal_digit, str (char_position, * ), end_index, found);
        str_format.piece [count] := clc$date_number;
        str_format.size [count] := end_index - 1;
        str_format.index [count] := char_position;
        char_position := char_position + end_index - 1;
      = ' ' =
        #SCAN (clv$non_space, str (char_position, * ), end_index, found);
        str_format.piece [count] := clc$space;
        str_format.size [count] := end_index - 1;
        str_format.index [count] := char_position;
        char_position := char_position + end_index - 1;
      = '/' =
        str_format.piece [count] := clc$slash;
        str_format.size [count] := 1;
        str_format.index [count] := char_position;
        char_position := char_position + 1;
      = ':' =
        str_format.piece [count] := clc$colon;
        str_format.size [count] := 1;
        str_format.index [count] := char_position;
        char_position := char_position + 1;
      = '.' =
        str_format.piece [count] := clc$dot;
        str_format.size [count] := 1;
        str_format.index [count] := char_position;
        char_position := char_position + 1;
      = ',' =
        IF (count > 1) AND (str_format.piece [count - 1] = clc$space) THEN
          #SCAN (clv$non_space, str (char_position + 1, * ), end_index, found);
          str_format.piece [count - 1] := clc$comma;
          str_format.size [count - 1] := end_index;
          str_format.index [count - 1] := char_position;
          char_position := char_position + end_index;
          count := count - 1;
        ELSE
          #SCAN (clv$non_space, str (char_position + 1, * ), end_index, found);
          str_format.piece [count] := clc$comma;
          str_format.size [count] := end_index;
          str_format.index [count] := char_position;
          char_position := char_position + end_index;
        IFEND;
      = '-' =
        str_format.piece [count] := clc$hyphen;
        str_format.size [count] := 1;
        str_format.index [count] := char_position;
        char_position := char_position + 1;
      ELSE
        osp$set_status_abnormal ('CL', cle$unexpected_dt_format_char, str (char_position), status);
        RETURN;
      CASEND;

    UNTIL (char_position > str_length);

    count := 0;
    fill_match := 1;
    piece_index := 1;

    IF format = '' THEN
      {If no format is supplied check data gathered above to determine}
      {format of input string.}
      need_preferred_language := TRUE;
      WHILE (piece_index <= clc$max_total_date_time_pieces) AND
            (str_format.piece [piece_index] <> clc$undefined) DO
        WHILE str_format.piece [piece_index] IN $clt$date_time_set
              [clc$space, clc$comma, clc$dot, clc$colon, clc$hyphen, clc$slash] DO
          piece_index := piece_index + 1;
          format_data.piece [fill_match] := clc$space;
          fill_match := fill_match + 1;
          count := count + 1;
        WHILEND;
        compare_format_arrays (str_format, piece_index, matching_index, status);
        IF NOT status.normal THEN
          RETURN;
        ELSEIF (built_in_formats [matching_index].elements [1] = clc$date_number) AND
              (built_in_formats [matching_index].format [1] = clc$undefined) THEN
          CASE str_format.size [piece_index - 1] OF
          = 5 =
            format_data.piece [fill_match] := clc$y2;
            format_data.piece [fill_match + 1] := clc$j3;
            fill_match := fill_match + 2;
            count := count + 2;
          = 6 =
            format_data.piece [fill_match] := clc$y2;
            format_data.piece [fill_match + 1] := clc$m2;
            format_data.piece [fill_match + 2] := clc$d2;
            fill_match := fill_match + 3;
            count := count + 3;
          = 7 =
            format_data.piece [fill_match] := clc$y4;
            format_data.piece [fill_match + 1] := clc$j3;
            fill_match := fill_match + 2;
            count := count + 2;
          = 8 =
            format_data.piece [fill_match] := clc$y4;
            format_data.piece [fill_match + 1] := clc$m2;
            format_data.piece [fill_match + 2] := clc$d2;
            fill_match := fill_match + 3;
            count := count + 3;
          ELSE
            ;
          CASEND;
        ELSEIF (built_in_formats [matching_index].elements [1] = clc$date_name) AND
              (built_in_formats [matching_index].format [1] = clc$undefined) THEN
          format_data.piece [fill_match] := clc$dn;
          fill_match := fill_match + 1;
          count := count + 1;
        ELSE
          i := 1;
          WHILE (i <= clc$max_date_or_time_pieces) AND (built_in_formats [matching_index].format [i] <>
                clc$undefined) DO
            format_data.piece [fill_match] := built_in_formats [matching_index].format [i];
            i := i + 1;
            fill_match := fill_match + 1;
            count := count + 1;
          WHILEND;
        IFEND;
      WHILEND;
    ELSE
      {If format is supplied call routine that interprets it.}
      read_format_string (format, format_data, count, leading_zeroes, need_preferred_language, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    FOR i := 1 TO piece_index - 1 DO
      IF format_data.piece [i] = clc$undefined THEN
        osp$set_status_abnormal ('CL', cle$unknown_date_time_format, format, status);
        RETURN;
      IFEND;
    FOREND;

    IF need_preferred_language THEN
*IF NOT $true(osv$unix)
      osp$find_natural_language (selected_language);
      preferred_language := selected_language^;
*ELSE
      preferred_language := osc$english;
*IFEND
    IFEND;

    {Read input string and determine contents based on format}
    {that was either deduced or supplied.}

    interpret_input_string (status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (hours_spec = clc$hours_12) THEN
      IF (ampm_spec = clc$pm) THEN
        IF date_time.value.hour <> 12 THEN
          date_time.value.hour := date_time.value.hour + 12;
        IFEND;
      ELSEIF ampm_spec = clc$am THEN
        IF date_time.value.hour = 12 THEN
          date_time.value.hour := 0;
        IFEND;
      IFEND;
    IFEND;

    IF j3_specified THEN
      i := 1;
      clp$evaluate_unsigned_decimal (str (str_format.index [j3], str_format.size [j3]), temp_data, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF NOT (pmp$this_is_a_leap_year (date_time.value.year + 1900)) THEN
        WHILE (i <= UPPERBOUND (clv$cumulative_days)) AND (temp_data > clv$cumulative_days [i]) DO
          i := i + 1;
        WHILEND;
        temp_data := temp_data - clv$cumulative_days [i - 1];
      ELSE
        WHILE (i <= UPPERBOUND (clv$cumulative_leap_days)) AND (temp_data > clv$cumulative_leap_days [i]) DO
          i := i + 1;
        WHILEND;
        temp_data := temp_data - clv$cumulative_leap_days [i - 1];
      IFEND;
      date_time.value.month := i;
      date_time.value.day := temp_data;

    IFEND;

    clp$validate_date_time (date_time, str, status);

  PROCEND clp$convert_string_to_date_time;
?? TITLE := 'clp$convert_date_time_to_string', EJECT ??
*copyc clh$convert_date_time_to_string

  PROCEDURE [XDCL, #GATE] clp$convert_date_time_to_string
    (    date_time: clt$date_time;
         format: clt$date_time_form_string;
     VAR str: ost$string;
     VAR status: ost$status);

    VAR
      adjust: integer,
      count: integer,
      char_position: integer,
      day_name: clt$name,
      date_str: ost$string,
      default_date_format: ost$default_date_format,
      default_date_format_size: integer,
      default_time_format: ost$default_time_format,
      default_time_format_size: integer,
      default_format_string: string (clc$max_date_time_form_string),
      format_data: clt$input_format,
      format_index: integer,
      format_length: integer,
      format_string: ^clt$date_time_form_string,
      found: boolean,
      hour: integer,
      identifier: ost$string,
      language: ost$natural_language,
      converted_language: ost$natural_language,
      leading_zeroes: boolean,
      log_status: ost$status,
      month_name: clt$name,
      need_preferred_language: boolean,
      preferred_language: ost$natural_language,
      rounded_up_millisecond_value: integer,
      selected_language: ^ost$natural_language,
      str_index: integer;

?? NEWTITLE := 'get_day_or_month_name', EJECT ??

    PROCEDURE [INLINE] get_day_or_month_name
      (    language: ost$natural_language;
       VAR day_or_month_name: clt$name;
       VAR status: ost$status);

      VAR
        day_ordinal: ost$day_of_week,
        day_number: 0 .. 6,
        ignore_status: ost$status,
        using_english: boolean,
        days_and_months_ptr: ^clt$day_and_month_names;


      day_or_month_name.value := '';
      days_and_months_ptr := NIL;
      using_english := FALSE;

      clp$find_day_and_month_names (language, days_and_months_ptr);
      IF days_and_months_ptr = NIL THEN
        clp$get_day_and_month_names (language, days_and_months_ptr, status);
        IF NOT status.normal THEN
*IF NOT $true(osv$unix)
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], status, ignore_status);
*IFEND
          status.normal := TRUE;
          IF preferred_language = '' THEN
*IF NOT $true(osv$unix)
            osp$find_natural_language (selected_language);
            preferred_language := selected_language^;
*ELSE
            preferred_language := osc$english;
*IFEND
          IFEND;
          IF preferred_language <> language THEN
            clp$get_day_and_month_names (preferred_language, days_and_months_ptr, status);
            IF NOT status.normal THEN
*IF NOT $true(osv$unix)
              osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], status,
                    ignore_status);
*IFEND
              status.normal := TRUE;
              days_and_months_ptr := ^clv$english_day_and_month_names;
              using_english := TRUE;
            IFEND;
          ELSE
            days_and_months_ptr := ^clv$english_day_and_month_names;
            using_english := TRUE;
          IFEND;
        IFEND;
      IFEND;

    /find_day_or_month/
      WHILE TRUE DO
        IF (format_data.piece [format_index] = clc$ma) OR (format_data.piece [format_index] =
              clc$ma_lang) THEN
          day_or_month_name.value := days_and_months_ptr^.months_abbrev [date_time.value.month].value;
          day_or_month_name.size := days_and_months_ptr^.months_abbrev [date_time.value.month].size;
          EXIT /find_day_or_month/;
        ELSEIF (format_data.piece [format_index] = clc$mn) OR (format_data.piece [format_index] =
              clc$mn_lang) THEN
          day_or_month_name.value := days_and_months_ptr^.months [date_time.value.month].value;
          day_or_month_name.size := days_and_months_ptr^.months [date_time.value.month].size;
          EXIT /find_day_or_month/;
        ELSEIF (format_data.piece [format_index] = clc$da) OR (format_data.piece [format_index] =
              clc$da_lang) THEN
          pmp$compute_day_of_week (date_time.value, day_ordinal, status);
          IF NOT status.normal THEN
            EXIT /find_day_or_month/;
          IFEND;
          #UNCHECKED_CONVERSION (day_ordinal, day_number);
          day_or_month_name.value := days_and_months_ptr^.days_abbrev [day_number + 1].value;
          day_or_month_name.size := days_and_months_ptr^.days_abbrev [day_number + 1].size;
          EXIT /find_day_or_month/;
        ELSEIF (format_data.piece [format_index] = clc$dn) OR (format_data.piece [format_index] =
              clc$dn_lang) THEN
          pmp$compute_day_of_week (date_time.value, day_ordinal, status);
          IF NOT status.normal THEN
            EXIT /find_day_or_month/;
          IFEND;
          #UNCHECKED_CONVERSION (day_ordinal, day_number);
          day_or_month_name.value := days_and_months_ptr^.days [day_number + 1].value;
          day_or_month_name.size := days_and_months_ptr^.days [day_number + 1].size;
          EXIT /find_day_or_month/;
        ELSEIF using_english THEN
          day_or_month_name.value := '';
          EXIT /find_day_or_month/;
        ELSE
          osp$set_status_abnormal ('CL', cle$unknown_date_time_format, format, status);
          EXIT /find_day_or_month/;
        IFEND;
        days_and_months_ptr := ^clv$english_day_and_month_names;
        using_english := TRUE;
      WHILEND /find_day_or_month/;

    PROCEND get_day_or_month_name;
?? TITLE := 'get_time_zone', EJECT ??

    PROCEDURE [INLINE] get_time_zone
      (    language: ost$natural_language;
           full_form: boolean;
       VAR tz_identifier: ost$string);

      VAR
        time_zone: ost$time_zone;


      pmp$get_time_zone (time_zone, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$get_time_zone_identifier (time_zone, full_form, language, tz_identifier, status);

    PROCEND get_time_zone;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    adjust := 0;
    count := 1;
    char_position := 1;
    default_format_string := '';
    format_string := NIL;
    found := FALSE;
    hour := 0;
    language := '';
    leading_zeroes := TRUE;
    need_preferred_language := FALSE;
    preferred_language := '';
    str.size := 0;
    str.value := '';
    str_index := 1;

    IF format = '' THEN
      pmp$get_default_date_time_form (default_date_format, default_time_format);
      default_date_format_size := clp$trimmed_string_size (default_date_format.format_string);
      default_time_format_size := clp$trimmed_string_size (default_time_format.format_string);
      IF date_time.date_specified THEN
        IF date_time.time_specified THEN
          STRINGREP (default_format_string, format_length, default_date_format.
                format_string (1, default_date_format_size), '.', default_time_format.
                format_string (1, default_time_format_size));
          format_string := ^default_format_string;
        ELSE
          format_string := ^default_date_format.format_string;
          format_length := default_date_format_size;
        IFEND;
      ELSEIF date_time.time_specified THEN
        format_string := ^default_time_format.format_string;
        format_length := default_time_format_size;
      ELSE
        osp$set_status_abnormal ('CL', cle$date_time_format_null, '', status);
        RETURN;
      IFEND;
    ELSE
      format_string := ^format;
      format_length := clp$trimmed_string_size (format_string^);
    IFEND;

{Verify input data.}
    clp$validate_date_time (date_time, '', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{Initialize format_data.}
    FOR count := 1 TO clc$max_total_date_time_pieces DO
      format_data.piece [count] := clc$undefined;
      format_data.index [count] := 0;
      format_data.size [count] := 0;
    FOREND;

{Find first character of format string.}
    #SCAN (clv$non_space, format_string^, char_position, found);

    count := char_position;

    read_format_string (format_string^, format_data, count, leading_zeroes, need_preferred_language, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF need_preferred_language THEN
*IF NOT $true(osv$unix)
      osp$find_natural_language (selected_language);
      preferred_language := selected_language^;
*ELSE
      preferred_language := osc$english;
*IFEND
    IFEND;

{ Now use pieces of format to transform date and time.}

    FOR format_index := 1 TO count DO
      CASE format_data.piece [format_index] OF

      = clc$h12 =
        hour := date_time.value.hour;
        IF hour > 12 THEN
          hour := hour - 12;
        ELSEIF hour = 0 THEN
          hour := 12;
        IFEND;
        adjust := $INTEGER (hour >= 10);
        convert_integer_to_rj_string (hour, '0', str.value (str_index, 1 + adjust));
        str_index := str_index + 1 + adjust;

      = clc$h24 =
        convert_integer_to_rj_string (date_time.value.hour, '0', str.value (str_index, 2));
        str_index := str_index + 2;

      = clc$mm =
        convert_integer_to_rj_string (date_time.value.minute, '0', str.value (str_index, 2));
        str_index := str_index + 2;

      = clc$ss =
        convert_integer_to_rj_string (date_time.value.second, '0', str.value (str_index, 2));
        str_index := str_index + 2;

      = clc$s10 =
        convert_integer_to_rj_string (date_time.value.millisecond DIV 100, '0', str.value (str_index));
        str_index := str_index + 1;

      = clc$s100 =
        IF (date_time.value.millisecond < 990) AND ((date_time.value.millisecond MOD 10) >= 5) THEN
          rounded_up_millisecond_value := (date_time.value.millisecond DIV 10) + 1;
        ELSE
          rounded_up_millisecond_value := (date_time.value.millisecond DIV 10);
        IFEND;
        convert_integer_to_rj_string (rounded_up_millisecond_value, '0', str.value (str_index, 2));
        str_index := str_index + 2;

      = clc$s1000 =
        convert_integer_to_rj_string (date_time.value.millisecond, '0', str.value (str_index, 3));
        str_index := str_index + 3;

      = clc$amorpm =
        IF date_time.value.hour < 12 THEN
          str.value (str_index, 2) := 'AM';
        ELSE
          str.value (str_index, 2) := 'PM';
        IFEND;
        str_index := str_index + 2;

      = clc$d2 =
        convert_integer_to_rj_string (date_time.value.day, '0', date_str.value (1, 2));
        IF (date_time.value.day < 10) AND NOT leading_zeroes THEN
          str.value (str_index) := date_str.value (2);
          str_index := str_index + 1;
        ELSE
          str.value (str_index, 2) := date_str.value;
          str_index := str_index + 2;
        IFEND;

      = clc$dn_lang, clc$da_lang =
        language := format (format_data.index [format_index], format_data.size [format_index]);
        #TRANSLATE (osv$lower_to_upper, language, converted_language);
        get_day_or_month_name (converted_language, day_name, status);
        IF NOT status.normal THEN
          RETURN;
        ELSEIF day_name.value = '' THEN
          osp$set_status_abnormal ('CL', cle$impossible_date_or_time, '', status);
          RETURN;
        IFEND;
        str.value (str_index, day_name.size) := day_name.value;
        str_index := str_index + day_name.size;

      = clc$dn, clc$da =
        get_day_or_month_name (preferred_language, day_name, status);
        IF NOT status.normal THEN
          RETURN;
        ELSEIF day_name.value = '' THEN
          osp$set_status_abnormal ('CL', cle$impossible_date_or_time, '', status);
          RETURN;
        IFEND;
        str.value (str_index, day_name.size) := day_name.value;
        str_index := str_index + day_name.size;

      = clc$m2 =
        convert_integer_to_rj_string (date_time.value.month, '0', date_str.value (1, 2));
        str.value (str_index, 2) := date_str.value;
        str_index := str_index + 2;

      = clc$mn, clc$ma =
        get_day_or_month_name (preferred_language, month_name, status);
        IF NOT status.normal THEN
          RETURN;
        ELSEIF month_name.value = '' THEN
          osp$set_status_abnormal ('CL', cle$impossible_date_or_time, '', status);
          RETURN;
        IFEND;
        str.value (str_index, month_name.size) := month_name.value;
        str_index := str_index + month_name.size;

      = clc$mn_lang, clc$ma_lang =
        language := format (format_data.index [format_index], format_data.size [format_index]);
        get_day_or_month_name (language, month_name, status);
        IF NOT status.normal THEN
          RETURN;
        ELSEIF month_name.value = '' THEN
          RETURN;
        IFEND;
        str.value (str_index, month_name.size) := month_name.value;
        str_index := str_index + month_name.size;

      = clc$tz =
        get_time_zone (preferred_language, TRUE, identifier);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        str.value (str_index, identifier.size) := identifier.value;
        str_index := str_index + identifier.size;

      = clc$tza =
        get_time_zone (preferred_language, FALSE, identifier);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        str.value (str_index, identifier.size) := identifier.value;
        str_index := str_index + identifier.size;

      = clc$tz_lang =
        language := format (format_data.index [format_index], format_data.size [format_index]);
        get_time_zone (language, TRUE, identifier);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        str.value (str_index, identifier.size) := identifier.value;
        str_index := str_index + identifier.size;

      = clc$tza_lang =
        language := format (format_data.index [format_index], format_data.size [format_index]);
        get_time_zone (language, FALSE, identifier);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        str.value (str_index, identifier.size) := identifier.value;
        str_index := str_index + identifier.size;

      = clc$y2 =
        convert_integer_to_rj_string (date_time.value.year, '0', date_str.value (1, 2));
        str.value (str_index, 2) := date_str.value;
        str_index := str_index + 2;

      = clc$y4 =
        convert_integer_to_rj_string (date_time.value.year + 1900, '0', date_str.value (1, 4));
        str.value (str_index, 4) := date_str.value;
        str_index := str_index + 4;

      = clc$j3 =
        IF NOT pmp$this_is_a_leap_year (date_time.value.year + 1900) THEN
          convert_integer_to_rj_string (clv$cumulative_days [date_time.value.month - 1] + date_time.value.day,
                '0', date_str.value (1, 3));
        ELSE
          convert_integer_to_rj_string (clv$cumulative_leap_days [date_time.value.month - 1] +
                date_time.value.day, '0', date_str.value (1, 3));
        IFEND;
        str.value (str_index, 3) := date_str.value;
        str_index := str_index + 3;

      = clc$hyphen =
        str.value (str_index) := '-';
        str_index := str_index + 1;

      = clc$space =
        str.value (str_index) := ' ';
        str_index := str_index + 1;

      = clc$slash =
        str.value (str_index) := '/';
        str_index := str_index + 1;

      = clc$dot =
        str.value (str_index) := '.';
        str_index := str_index + 1;

      = clc$colon =
        str.value (str_index) := ':';
        str_index := str_index + 1;

      = clc$comma =
        IF (format_data.piece [format_index + 1] = clc$s1000) OR
              (format_data.piece [format_index + 1] = clc$s100) OR
              (format_data.piece [format_index + 1] = clc$s10) THEN
          str.value (str_index) := ',';
          str_index := str_index + 1;
        ELSE
          str.value (str_index, 2) := ', ';
          str_index := str_index + 2;
        IFEND;
      CASEND;

    FOREND;
    str.size := str_index - 1;

  PROCEND clp$convert_date_time_to_string;
?? TITLE := 'clp$validate_date_time', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$validate_date_time
    (    date_time: clt$date_time;
         str: string ( * );
     VAR status: ost$status);


    status.normal := TRUE;

?? FMT (FORMAT := OFF) ??

    IF ((date_time.value.month < 1) OR (date_time.value.month > 12))
       OR ((date_time.value.month = 2) AND pmp$this_is_a_leap_year (date_time.value.year + 1900) AND
            (date_time.value.day > 29))
       OR ((date_time.value.month = 2) AND
            NOT pmp$this_is_a_leap_year (date_time.value.year + 1900) AND (date_time.value.day > 28))
       OR ((date_time.value.day < 1) OR (date_time.value.day > clv$last_day_of_month [date_time.value.month]))
       OR (((date_time.value.hour < 0) OR (date_time.value.hour > 23)) OR
             ((date_time.value.minute < 0) OR (date_time.value.hour > 59)) OR
             ((date_time.value.second < 0) OR (date_time.value.second > 59)) OR
             ((date_time.value.millisecond < 0) OR (date_time.value.millisecond > 999))) THEN
      osp$set_status_abnormal ('CL', cle$impossible_date_or_time, str, status);
    ELSEIF (NOT date_time.date_specified) AND (NOT date_time.time_specified) THEN
      osp$set_status_abnormal ('CL', cle$date_time_format_null, str, status);
    IFEND;

?? FMT (FORMAT := ON) ??

  PROCEND clp$validate_date_time;
?? TITLE := 'clp$get_date_string', EJECT ??
*copyc clh$get_date_string

  PROCEDURE [XDCL, #GATE] clp$get_date_string
    (VAR str: ost$string;
     VAR status: ost$status);

    VAR
      clt_date_time: clt$date_time,
      time_format: ost$default_time_format,
      date_format: ost$default_date_format;


    pmp$get_default_date_time_form (date_format, time_format);

    pmp$get_compact_date_time (clt_date_time.value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clt_date_time.time_specified := FALSE;
    clt_date_time.date_specified := TRUE;

    clp$convert_date_time_to_string (clt_date_time, date_format.format_string, str, status);

  PROCEND clp$get_date_string;
?? TITLE := 'clp$get_time_string', EJECT ??
*copyc clh$get_time_string

  PROCEDURE [XDCL, #GATE] clp$get_time_string
    (VAR str: ost$string;
     VAR status: ost$status);

    VAR
      clt_date_time: clt$date_time,
      date_format: ost$default_date_format,
      time_format: ost$default_time_format;


    pmp$get_default_date_time_form (date_format, time_format);

    pmp$get_compact_date_time (clt_date_time.value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clt_date_time.time_specified := TRUE;
    clt_date_time.date_specified := FALSE;

    clp$convert_date_time_to_string (clt_date_time, time_format.format_string, str, status);

  PROCEND clp$get_time_string;
?? TITLE := 'clp$get_date_time_string', EJECT ??
*copyc clh$get_date_time_string

  PROCEDURE [XDCL, #GATE] clp$get_date_time_string
    (    format: clt$date_time_form_string;
     VAR str: ost$string;
     VAR status: ost$status);

    VAR
      clt_date_time: clt$date_time;


    pmp$get_compact_date_time (clt_date_time.value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clt_date_time.time_specified := TRUE;
    clt_date_time.date_specified := TRUE;
    clp$convert_date_time_to_string (clt_date_time, format, str, status);

  PROCEND clp$get_date_time_string;
?? TITLE := 'clp$get_day_name', EJECT ??
*copyc clh$get_day_name

  PROCEDURE [XDCL, #GATE] clp$get_day_name
    (    day_of_week: ost$day_of_week;
         full_form: boolean;
         natural_language: ost$natural_language;
     VAR day_name: ost$string;
     VAR status: ost$status);

    VAR
      day_number: 0 .. 6,
      ignore_status: ost$status,
      days_and_months_ptr: ^clt$day_and_month_names,
      log_status: ost$status,
      name_is_valid: boolean,
      preferred_language: ost$natural_language,
*IF NOT $true(osv$unix)
      selected_language: ^ost$natural_language,
      seed_name: pmt$program_name;
*ELSE
      selected_language: ^ost$natural_language;
*IFEND


    status.normal := TRUE;

    IF (day_of_week < LOWERVALUE (ost$day_of_week)) OR (day_of_week > UPPERVALUE (ost$day_of_week)) THEN
      osp$set_status_abnormal ('OS', ose$bad_day_of_week, '', status);
      RETURN;
    IFEND;

    IF natural_language = osc$null_name THEN
*IF NOT $true(osv$unix)
      osp$find_natural_language (selected_language);
      preferred_language := selected_language^;
*ELSE
      preferred_language := osc$english;
*IFEND
    ELSE
      clp$validate_name (natural_language, preferred_language, name_is_valid);
      IF NOT name_is_valid THEN
        osp$set_status_abnormal ('CL', ose$bad_natural_language, natural_language, status);
        RETURN;
      IFEND;
    IFEND;

    clp$find_day_and_month_names (preferred_language, days_and_months_ptr);
    IF days_and_months_ptr = NIL THEN
      clp$get_day_and_month_names (preferred_language, days_and_months_ptr, status);
      IF NOT status.normal THEN
*IF NOT $true(osv$unix)
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], status, ignore_status);
*IFEND
        status.normal := TRUE;
        days_and_months_ptr := ^clv$english_day_and_month_names;
      IFEND;
    IFEND;

    #UNCHECKED_CONVERSION (day_of_week, day_number);

    IF full_form THEN
      day_name.value := days_and_months_ptr^.days [day_number + 1].value;
      day_name.size := days_and_months_ptr^.days [day_number + 1].size;
    ELSE
      day_name.value := days_and_months_ptr^.days_abbrev [day_number + 1].value;
      day_name.size := days_and_months_ptr^.days_abbrev [day_number + 1].size;
    IFEND;

  PROCEND clp$get_day_name;
?? TITLE := 'clp$get_month_name', EJECT ??
*copyc clh$get_month_name

  PROCEDURE [XDCL, #GATE] clp$get_month_name
    (    month_number: 1 .. 12;
         full_form: boolean;
         natural_language: ost$natural_language;
     VAR month_name: ost$string;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      days_and_months_ptr: ^clt$day_and_month_names,
      log_status: ost$status,
      name_is_valid: boolean,
      preferred_language: ost$natural_language,
*IF NOT $true(osv$unix)
      selected_language: ^ost$natural_language,
      seed_name: pmt$program_name;
*ELSE
      selected_language: ^ost$natural_language;
*IFEND


    status.normal := TRUE;

    IF natural_language = osc$null_name THEN
*IF NOT $true(osv$unix)
      osp$find_natural_language (selected_language);
      preferred_language := selected_language^;
*ELSE
      preferred_language := osc$english;
*IFEND
    ELSE
      clp$validate_name (natural_language, preferred_language, name_is_valid);
      IF NOT name_is_valid THEN
        osp$set_status_abnormal ('CL', ose$bad_natural_language, natural_language, status);
        RETURN;
      IFEND;
    IFEND;

    IF (month_number < 1) OR (month_number > 12) THEN
      osp$set_status_abnormal ('CL', cle$bad_month_number, '', status);
      RETURN;
    IFEND;

    clp$find_day_and_month_names (preferred_language, days_and_months_ptr);
    IF days_and_months_ptr = NIL THEN
      clp$get_day_and_month_names (preferred_language, days_and_months_ptr, status);
      IF NOT status.normal THEN
*IF NOT $true(osv$unix)
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], status, ignore_status);
*IFEND
        status.normal := TRUE;
        days_and_months_ptr := ^clv$english_day_and_month_names;
      IFEND;
    IFEND;

    IF full_form THEN
      month_name.value := days_and_months_ptr^.months [month_number].value;
      month_name.size := days_and_months_ptr^.months [month_number].size;
    ELSE
      month_name.value := days_and_months_ptr^.months_abbrev [month_number].value;
      month_name.size := days_and_months_ptr^.months_abbrev [month_number].size;
    IFEND;

  PROCEND clp$get_month_name;
?? TITLE := 'clp$get_time_zone_identifier', EJECT ??
*copyc clh$get_time_zone_identifier

  PROCEDURE [XDCL, #GATE] clp$get_time_zone_identifier
    (    time_zone: ost$time_zone;
         full_form: boolean;
         natural_language: ost$natural_language;
     VAR time_zone_identifier: ost$string;
     VAR status: ost$status);

    VAR
      current_end: ost$string_size,
*IF NOT $true(osv$unix)
      help_module: ^ost$help_module,
*IFEND
      hours_string: ost$string,
*IF NOT $true(osv$unix)
      ignore_online_manual: ost$online_manual_name,
*IFEND
      index: ost$string_size,
      minutes_string: ost$string,
*IF NOT $true(osv$unix)
      time_zone_template: ^ost$message_template,
*IFEND
      name_is_valid: boolean,
      parameter_index: ost$string_size,
      parameter_name: clt$parameter_name,
      parse: clt$parse_state,
      preferred_language: ost$natural_language,
      selected_language: ^ost$natural_language,
      prompt_begin: ost$string_size,
*IF NOT $true(osv$unix)
      seed_name: pmt$program_name,
*IFEND
      time_zone_abbrev: string (osc$max_string_size);


    status.normal := TRUE;
    parameter_index := 1;
    current_end := 0;
    parameter_name := '';
    prompt_begin := 0;
    time_zone_abbrev := '';
    time_zone_identifier.value := '';
    time_zone_identifier.size := 0;

    IF natural_language = osc$null_name THEN
*IF NOT $true(osv$unix)
      osp$find_natural_language (selected_language);
      preferred_language := selected_language^;
    ELSE
      clp$validate_name (natural_language, preferred_language, name_is_valid);
      IF NOT name_is_valid THEN
        osp$set_status_abnormal ('CL', ose$bad_natural_language, natural_language, status);
        RETURN;
      IFEND;
*ELSE
      preferred_language := osc$english;
*IFEND
    IFEND;

{Construct parameter prompt name.}
    IF time_zone.daylight_saving_time THEN
      parameter_name (1, dst_string_length) := dst_string;
      parameter_index := parameter_index + dst_string_length;
    ELSE
      parameter_name (1, st_string_length) := st_string;
      parameter_index := parameter_index + st_string_length;
    IFEND;
    clp$convert_integer_to_string (time_zone.hours_from_gmt, 10, FALSE, hours_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF hours_string.value (1) = '-' THEN
      hours_string.value (1) := '_';
    IFEND;
    parameter_name (parameter_index) := '$';
    parameter_index := parameter_index + 1;
    parameter_name (parameter_index, hours_string.size) := hours_string.value;
    parameter_index := parameter_index + hours_string.size;
    IF time_zone.minutes_offset <> 0 THEN
      clp$convert_integer_to_string (time_zone.minutes_offset, 10, FALSE, minutes_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF minutes_string.value (1) = '-' THEN
        minutes_string.value (1) := '_';
      IFEND;
      parameter_name (parameter_index) := '$';
      parameter_index := parameter_index + 1;
      parameter_name (parameter_index, minutes_string.size) := minutes_string.value;
    IFEND;

  /find_time_zone/
    BEGIN
*IF NOT $true(osv$unix)
      seed_name := 'TIME_ZONES';
      clp$find_help_module (seed_name, preferred_language, help_module, ignore_online_manual, status);
      IF (NOT status.normal) OR (help_module = NIL) THEN
        IF (preferred_language <> 'ENGLISH') OR (preferred_language <> 'US_ENGLISH') THEN
          preferred_language := 'US_ENGLISH';
          clp$find_help_module (seed_name, preferred_language, help_module, ignore_online_manual, status);
          IF (NOT status.normal) OR (help_module = NIL) THEN
            EXIT /find_time_zone/;
          IFEND;
        ELSE
          EXIT /find_time_zone/;
        IFEND;
      IFEND;
      osp$find_parameter_prompt (help_module, parameter_name, time_zone_template, status);
      IF NOT (status.normal) OR (time_zone_template = NIL) THEN
        IF (preferred_language <> 'ENGLISH') OR (preferred_language <> 'US_ENGLISH') THEN
          preferred_language := 'US_ENGLISH';
          clp$find_help_module (seed_name, preferred_language, help_module, ignore_online_manual, status);
          IF (NOT status.normal) OR (help_module = NIL) THEN
            EXIT /find_time_zone/;
          IFEND;
          osp$find_parameter_prompt (help_module, parameter_name, time_zone_template, status);
          IF NOT (status.normal) OR (time_zone_template = NIL) THEN
            EXIT /find_time_zone/;
          IFEND;
        ELSE
          EXIT /find_time_zone/;
        IFEND;
      IFEND;

      clp$initialize_parse_state (time_zone_template, NIL, parse);
{Looking for something that could look like: Central Standard Time, CDT}
      clp$scan_lexical_unit (clc$slu_non_space, parse);
      IF parse.unit.kind <> clc$lex_name THEN
        EXIT /find_time_zone/;
      IFEND;
      prompt_begin := parse.unit_index;
      time_zone_abbrev (1) := time_zone_template^ (parse.unit_index);
      index := 2;

      WHILE TRUE DO
        clp$scan_lexical_unit (clc$slu_non_space, parse);
        CASE parse.unit.kind OF

        = clc$lex_name =
          IF parse.previous_non_space_unit.kind = clc$lex_comma THEN
            time_zone_abbrev := time_zone_template^ (parse.unit_index, parse.unit.size);
          ELSE
            time_zone_identifier.size := parse.index - prompt_begin;
            time_zone_identifier.value := time_zone_template^ (prompt_begin, parse.index - 1);
            time_zone_abbrev (index) := time_zone_template^ (parse.unit_index);
          IFEND;

        = clc$lex_comma =
          {Don't need to do anything.}

        = clc$lex_subtract =
          time_zone_identifier.size := parse.index - prompt_begin;
          time_zone_identifier.value := time_zone_template^ (prompt_begin, parse.index - 1);

        = clc$lex_end_of_line =
          EXIT /find_time_zone/;

        ELSE
          time_zone_identifier.value := '';
          time_zone_identifier.size := 0;
          EXIT /find_time_zone/;
        CASEND;
        index := index + 1;
      WHILEND;
*IFEND
    END /find_time_zone/;

    IF time_zone_identifier.size <> 0 THEN
      IF NOT full_form THEN
        time_zone_identifier.value := time_zone_abbrev;
        time_zone_identifier.size := clp$trimmed_string_size (time_zone_abbrev);
      IFEND;
    IFEND;

  PROCEND clp$get_time_zone_identifier;

?? TITLE := 'clp$verify_time_increment', EJECT ??
*copyc clh$verify_time_increment

  PROCEDURE [XDCL, #GATE] clp$verify_time_increment
    (    time_increment: pmt$time_increment;
     VAR status: ost$status);

    VAR
      ms: integer;

    ms := time_increment.year * 366 * 24 * 60 * 60 * 1000 +
          time_increment.month * 31 * 24 * 60 * 60 * 1000 +
          time_increment.day * 24 * 60 * 60 * 1000 +
          time_increment.hour * 60 * 60 * 1000 +
          time_increment.minute * 60 * 1000 +
          time_increment.second * 1000 +
          time_increment.millisecond;

    IF (ms < -1000*60*60*24*366*255) OR (ms > 1000*60*60*24*366*255) THEN
      osp$set_status_abnormal ('CL', cle$invalid_time_increment, '', status);
    ELSE
      status.normal := TRUE;
    IFEND;

  PROCEND clp$verify_time_increment;

MODEND clm$date_time_conversion;
*DECK DECK=CLM$DATE_TIME_FUNCTIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Date Time Functions' ??
MODULE clm$date_time_functions;

{
{ PURPOSE:
{   This module contains the functions that concern date and time.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$compiling_for_test_harness
*copyc cle$work_area_overflow
?? POP ??

*copyc clp$convert_date_time_to_string
*copyc clp$convert_string_to_date_time
*copyc clp$get_time_zone_identifier
*copyc clp$make_date_time_value
*copyc clp$make_string_value
*copyc clp$make_time_zone_value
*copyc clp$evaluate_parameters
*copyc osp$set_status_abnormal
*copyc pmp$compute_local_date_time
*copyc pmp$compute_universal_date_time
*copyc pmp$get_compact_date_time
*copyc pmp$get_time_zone

?? TITLE := 'clp$$date', EJECT ??

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

{ FUNCTION (osm$$date) $date (
{   format: any of
{       key
{         default
{         dmy
{         (isod, iso)
{         mdy
{         month
{         ordinal
{       keyend
{       string
{     anyend = default
{   date: date = $now
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] 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 .. 7] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
          default_value: string (7),
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$date_time_type_qualifier,
          default_value: string (4),
        recend,
      recend := [[1, [88, 1, 20, 9, 6, 26, 671], clc$function, 2, 2, 0, 0, 0, 0, 0, 'OSM$$DATE'],
            [['DATE                           ', clc$nominal_entry, 2],
            ['FORMAT                         ', clc$nominal_entry, 1]], [
{ PARAMETER 1
      [2, 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, 294, clc$optional_default_parameter, 0,
            7],
{ PARAMETER 2
      [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, 5, clc$optional_default_parameter, 0,
            4]],
{ PARAMETER 1
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$string_type], FALSE, 2], 266,
            [[1, 0, clc$keyword_type], [7], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['DMY                            ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['ISO                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['ISOD                           ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['MDY                            ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['MONTH                          ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['ORDINAL                        ', clc$nominal_entry,
            clc$normal_usage_entry, 6]]], 8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
            'default'],
{ PARAMETER 2
      [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date], $clt$date_time_tenses
            [clc$past, clc$present, clc$future]], '$now']];

?? POP ??

    CONST
      p$format = 1,
      p$date = 2;

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

    VAR
      date_string: ost$string,
      format: string (clc$max_date_time_form_string);

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

    IF pvt [p$format].value^.kind = clc$keyword THEN
      IF pvt [p$format].value^.keyword_value = 'DEFAULT' THEN
        format := '';
      ELSE
        format := pvt [p$format].value^.keyword_value;
      IFEND;
    ELSE
      format := pvt [p$format].value^.string_value^;
    IFEND;

    clp$convert_date_time_to_string (pvt [p$date].value^.date_time_value, format, date_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_string_value (date_string.value (1, date_string.size), work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$date;
?? TITLE := 'clp$$date_time', EJECT ??

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

{ FUNCTION (osm$$date_time) $date_time (
{   string: string = $required
{   format: string = $optional
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend := [[1, [87, 12, 11, 12, 6, 2, 357], clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$DATE_TIME'],
            [['FORMAT                         ', clc$nominal_entry, 2],
            ['STRING                         ', clc$nominal_entry, 1]], [
{ PARAMETER 1
      [2, 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, 8, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [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, 8, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 2
      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]];

?? POP ??

    CONST
      p$string = 1,
      p$format = 2;

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

    VAR
      date_time: clt$date_time,
      format: string (clc$max_date_time_form_string);

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

    IF pvt [p$format].value <> NIL THEN
      format := pvt [p$format].value^.string_value^;
    ELSE
      format := '';
    IFEND;
    clp$convert_string_to_date_time (pvt [p$string].value^.string_value^, format, date_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_date_time_value (date_time, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$date_time;
?? TITLE := 'clp$$date_time_string', EJECT ??

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

{ FUNCTION (osm$$datts) $date_time_string (
{   format: any of
{       key
{         default, ampm, dmy, hms
{         (isod, iso)
{         isot, mdy
{         (millisecond, ms)
{         month, ordinal
{       keyend
{       string
{     anyend = default
{   date_time: date_time = $now
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] 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 .. 12] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
          default_value: string (7),
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$date_time_type_qualifier,
          default_value: string (4),
        recend,
      recend := [[1, [88, 9, 23, 13, 41, 12, 733], clc$function, 2, 2, 0, 0, 0, 0, 0, 'OSM$$DATTS'],
            [['DATE_TIME                      ', clc$nominal_entry, 2],
            ['FORMAT                         ', clc$nominal_entry, 1]], [
{ PARAMETER 1
      [2, 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, 479, clc$optional_default_parameter, 0,
            7],
{ PARAMETER 2
      [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, 5, clc$optional_default_parameter, 0,
            4]],
{ PARAMETER 1
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$string_type], FALSE, 2], 451,
            [[1, 0, clc$keyword_type], [12], [['AMPM                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['DMY                            ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['HMS                            ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['ISO                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ISOD                           ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['ISOT                           ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['MDY                            ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['MILLISECOND                    ', clc$nominal_entry,
            clc$normal_usage_entry, 8], ['MONTH                          ', clc$nominal_entry,
            clc$normal_usage_entry, 9], ['MS                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 8], ['ORDINAL                        ', clc$nominal_entry,
            clc$normal_usage_entry, 10]]], 8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
            'default'],
{ PARAMETER 2
      [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time],
            $clt$date_time_tenses [clc$past, clc$present, clc$future]], '$now']];

?? POP ??

    CONST
      p$format = 1,
      p$date_time = 2;

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

    VAR
      format: string (clc$max_date_time_form_string),
      date_time_string: ost$string;


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

    IF pvt [p$format].value^.kind = clc$keyword THEN
      IF pvt [p$format].value^.keyword_value = 'DEFAULT' THEN
        format := '';
      ELSE
        format := pvt [p$format].value^.keyword_value;
      IFEND;
    ELSE
      format := pvt [p$format].value^.string_value^;
    IFEND;

    clp$convert_date_time_to_string (pvt [p$date_time].value^.date_time_value, format, date_time_string,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_string_value (date_time_string.value (1, date_time_string.size), work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$date_time_string;
?? TITLE := 'clp$$day', EJECT ??

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

{ FUNCTION (osm$$day) $day (
{   format: any of
{       key
{         (full, dn, f)
{         (brief, da, b)
{       keyend
{       string
{     anyend = full
{   date: date = $now
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] 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 .. 6] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
          default_value: string (4),
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$date_time_type_qualifier,
          default_value: string (4),
        recend,
      recend := [[1, [87, 12, 11, 12, 6, 22, 534], clc$function, 2, 2, 0, 0, 0, 0, 0, 'OSM$$DAY'],
            [['DATE                           ', clc$nominal_entry, 2],
            ['FORMAT                         ', clc$nominal_entry, 1]], [
{ PARAMETER 1
      [2, 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, 257, clc$optional_default_parameter, 0,
            4],
{ PARAMETER 2
      [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, 5, clc$optional_default_parameter, 0,
            4]],
{ PARAMETER 1
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$string_type], FALSE, 2], 229,
            [[1, 0, clc$keyword_type], [6], [['B                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['BRIEF                          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['DA                             ', clc$alias_entry,
            clc$normal_usage_entry, 2], ['DN                             ', clc$alias_entry,
            clc$normal_usage_entry, 1], ['F                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['FULL                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
            'full'],
{ PARAMETER 2
      [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date], $clt$date_time_tenses
            [clc$past, clc$present, clc$future]], '$now']];

?? POP ??

    CONST
      p$format = 1,
      p$date = 2;

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

    VAR
      day_string: ost$string,
      format: string (clc$max_date_time_form_string);


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

    IF pvt [p$format].value^.kind = clc$string THEN
      format := pvt [p$format].value^.string_value^;
    ELSEIF pvt [p$format].value^.keyword_value = 'FULL' THEN
      format := 'DN';
    ELSE
      format := 'DA';
    IFEND;

    clp$convert_date_time_to_string (pvt [p$date].value^.date_time_value, format, day_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_string_value (day_string.value (1, day_string.size), work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$day;
?? TITLE := 'clp$$local_date_time', EJECT ??

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



{ FUNCTION (osm$$local_date_time) $local_date_time (
{   universal_date_time: date_time = $required
{   time_zone: time_zone = $required
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$date_time_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 12, 11, 12, 6, 41, 2], clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$LOCAL_DATE_TIME'],
            [['TIME_ZONE                      ', clc$nominal_entry, 2],
            ['UNIVERSAL_DATE_TIME            ', clc$nominal_entry, 1]], [
{ PARAMETER 1
      [2, 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, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [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, 3, clc$required_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time],
            $clt$date_time_tenses [clc$past, clc$present, clc$future]]],
{ PARAMETER 2
      [[1, 0, clc$time_zone_type]]];

?? POP ??

    CONST
      p$universal_date_time = 1,
      p$time_zone = 2;

    VAR
      local_date_time: clt$date_time,
      pvt: array [1 .. 2] of clt$parameter_value;

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

    pmp$compute_local_date_time (pvt [p$universal_date_time].value^.date_time_value.value,
          pvt [p$time_zone].value^.time_zone_value, local_date_time.value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_date_time.time_specified := TRUE;
    local_date_time.date_specified := TRUE;

    clp$make_date_time_value (local_date_time, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$local_date_time;
?? TITLE := 'clp$$time', EJECT ??

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

{ FUNCTION (osm$$time) $time (
{   format: any of
{       key
{         default
{         ampm
{         hms
{         isot
{         (millisecond, ms)
{       keyend
{       string
{     anyend = default
{   time: time = $now
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] 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 .. 6] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
          default_value: string (7),
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$date_time_type_qualifier,
          default_value: string (4),
        recend,
      recend := [[1, [88, 1, 20, 9, 11, 22, 567], clc$function, 2, 2, 0, 0, 0, 0, 0, 'OSM$$TIME'],
            [['FORMAT                         ', clc$nominal_entry, 1],
            ['TIME                           ', clc$nominal_entry, 2]], [
{ 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, 257, clc$optional_default_parameter, 0,
            7],
{ PARAMETER 2
      [2, 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, 5, clc$optional_default_parameter, 0,
            4]],
{ PARAMETER 1
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$string_type], FALSE, 2], 229,
            [[1, 0, clc$keyword_type], [6], [['AMPM                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['HMS                            ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['ISOT                           ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['MILLISECOND                    ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['MS                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5]]], 8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
            'default'],
{ PARAMETER 2
      [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$time], $clt$date_time_tenses
            [clc$past, clc$present, clc$future]], '$now']];

?? POP ??

    CONST
      p$format = 1,
      p$time = 2;

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

    VAR
      format: string (clc$max_date_time_form_string),
      time_string: ost$string;


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

    IF pvt [p$format].value^.kind = clc$keyword THEN
      IF pvt [p$format].value^.keyword_value = 'DEFAULT' THEN
        format := '';
      ELSE
        format := pvt [p$format].value^.keyword_value;
      IFEND;
    ELSE
      format := pvt [p$format].value^.string_value^;
    IFEND;

    clp$convert_date_time_to_string (pvt [p$time].value^.date_time_value, format, time_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_string_value (time_string.value (1, time_string.size), work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$time;
?? TITLE := 'clp$$time_zone', EJECT ??

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

{ FUNCTION (osm$$time_zone) $time_zone ()

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [87, 11, 9, 15, 22, 7, 434], clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$TIME_ZONE']];

?? POP ??

    VAR
      time_zone: ost$time_zone;

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

    pmp$get_time_zone (time_zone, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_time_zone_value (time_zone, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$time_zone;
?? TITLE := 'clp$$time_zone_identifier', EJECT ??

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


{ FUNCTION (osm$$timzi) $time_zone_identifier, $time_zone_id (
{   format: any of
{       key
{         (full, tz, f)
{         (brief, tza, b)
{       keyend
{       string
{     anyend = full
{   time_zone: time_zone = $time_zone
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] 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 .. 6] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
          default_value: string (4),
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (10),
        recend,
      recend := [[1, [88, 9, 23, 13, 42, 11, 887], clc$function, 2, 2, 0, 0, 0, 0, 0, 'OSM$$TIMZI'],
            [['FORMAT                         ', clc$nominal_entry, 1],
            ['TIME_ZONE                      ', clc$nominal_entry, 2]], [
{ 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, 257, clc$optional_default_parameter, 0,
            4],
{ PARAMETER 2
      [2, 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, 3, clc$optional_default_parameter, 0,
            10]],
{ PARAMETER 1
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$string_type], FALSE, 2], 229,
            [[1, 0, clc$keyword_type], [6], [['B                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['BRIEF                          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['F                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['FULL                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['TZ                             ', clc$alias_entry,
            clc$normal_usage_entry, 1], ['TZA                            ', clc$alias_entry,
            clc$normal_usage_entry, 2]]], 8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
            'full'],
{ PARAMETER 2
      [[1, 0, clc$time_zone_type], '$time_zone']];

?? POP ??

    CONST
      p$format = 1,
      p$time_zone = 2;

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

    VAR
      date_time: clt$date_time,
      time_zone_ident: ost$string;

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

    IF pvt [p$format].value^.kind = clc$keyword THEN
      IF pvt [p$format].value^.keyword_value = 'FULL' THEN
        clp$get_time_zone_identifier (pvt [p$time_zone].value^.time_zone_value, TRUE, osc$null_name,
              time_zone_ident, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE {BRIEF}
        clp$get_time_zone_identifier (pvt [p$time_zone].value^.time_zone_value, FALSE, osc$null_name,
              time_zone_ident, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    ELSE
      pmp$get_compact_date_time (date_time.value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      date_time.time_specified := TRUE;
      date_time.date_specified := TRUE;
      clp$convert_date_time_to_string (date_time, pvt [p$format].value^.string_value^, time_zone_ident,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    clp$make_string_value (time_zone_ident.value (1, time_zone_ident.size), work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$time_zone_identifier;
?? TITLE := 'clp$$universal_date_time', EJECT ??

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

{ FUNCTION (osm$$unidt) $universal_date_time (
{   local_date_time: date_time = $required
{   time_zone: time_zone = $required
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$date_time_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 23, 13, 42, 47, 190], clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$UNIDT'],
            [['LOCAL_DATE_TIME                ', clc$nominal_entry, 1],
            ['TIME_ZONE                      ', clc$nominal_entry, 2]], [
{ 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, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [2, 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, 3, clc$required_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time],
            $clt$date_time_tenses [clc$past, clc$present, clc$future]]],
{ PARAMETER 2
      [[1, 0, clc$time_zone_type]]];

?? POP ??

    CONST
      p$local_date_time = 1,
      p$time_zone = 2;

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

    VAR
      universal_date_time: clt$date_time;

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

    pmp$compute_universal_date_time (pvt [p$local_date_time].value^.date_time_value.value,
          pvt [p$time_zone].value^.time_zone_value, universal_date_time.value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    universal_date_time.time_specified := TRUE;
    universal_date_time.date_specified := TRUE;

    clp$make_date_time_value (universal_date_time, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$universal_date_time;

MODEND clm$date_time_functions;
*DECK DECK=CLM$DAY_AND_MONTH_NAMES_MGR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL : Module to provide interfaces needed by clm$date_time_conversion.' ??


MODULE clm$day_and_month_names_mgr;

{
{ PURPOSE:
{    This module contains the interface CLP$GET_DAY_AND_MONTH_NAMES and the
{ declaration of shared variable CLV$DAY_AND_MONTH_NAMES_LIST that are needed by
{ the date_time conversion routines.


?? NEWTITLE := 'Global declarations', EJECT ??

*IF NOT $true(osv$unix)
*copyc clp$find_help_module
*IFEND
*copyc clp$initialize_parse_state
*copyc clp$scan_lexical_unit
*IF NOT $true(osv$unix)
*copyc osp$find_parameter_prompt
*IFEND
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc oss$task_shared
*copyc oss$job_paged_literal
*copyc osv$task_shared_heap


*copyc clt$day_and_month_names

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_date_time_format
?? POP ??

  VAR
    clv$day_and_month_names_list: [XDCL, #GATE, oss$task_shared] ^clt$day_and_month_names :=
          ^clv$english_day_and_month_names;

  VAR
  clv$english_day_and_month_names: [XDCL, #GATE, READ, oss$job_paged_literal] clt$day_and_month_names := [NIL,
          'US_ENGLISH', [[7, 'January'], [8, 'February'], [5, 'March'], [5, 'April'], [3, 'May'], [4, 'June'],
          [4, 'July'], [6, 'August'], [9, 'September'], [7, 'October'], [8, 'November'], [8, 'December']],
          [[3, 'Jan'], [3, 'Feb'], [3, 'Mar'], [3, 'Apr'], [3, 'May'], [3, 'Jun'], [3, 'Jul'], [3, 'Aug'], [3,
          'Sep'], [3, 'Oct'], [3, 'Nov'], [3, 'Dec']], [[6, 'Monday'], [7, 'Tuesday'], [9, 'Wednesday'], [8,
          'Thursday'], [6, 'Friday'], [8, 'Saturday'], [6, 'Sunday']],
          [[3, 'Mon'], [3, 'Tue'], [3, 'Wed'], [3, 'Thu'], [3, 'Fri'], [3, 'Sat'], [3, 'Sun']]];


?? TITLE := 'clp$get_day_and_month_names', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$get_day_and_month_names
    (    language: ost$natural_language;
     VAR new_days_and_months_ptr: ^clt$day_and_month_names;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
    VAR
      day_number: 1 .. 7,
      help_module: ^ost$help_module,
      ignore_online_manual: ost$online_manual_name,
      month_number: 1 .. 12,
      parameter_name: clt$parameter_name,
      parse: clt$parse_state,
      seed_name: pmt$program_name,
      temp_days_and_months_ptr: ^clt$day_and_month_names,
      template: ^ost$message_template;
*IFEND

    status.normal := TRUE;
*IF NOT $true(osv$unix)
    seed_name := 'MONTHS_AND_DAYS';

    clp$find_help_module (seed_name, language, help_module, ignore_online_manual, status);
    IF (NOT status.normal) OR (help_module = NIL) THEN
      osp$set_status_abnormal ('CL', cle$language_module_not_found, language, status);
      RETURN;
    IFEND;

    ALLOCATE temp_days_and_months_ptr IN osv$task_shared_heap^;

  /find_months_and_days/
    BEGIN
      temp_days_and_months_ptr^.language := language;
      temp_days_and_months_ptr^.next_entry := clv$day_and_month_names_list;

      FOR month_number := 1 TO 12 DO

        parameter_name := clv$english_day_and_month_names.months [month_number].value;
        osp$find_parameter_prompt (help_module, parameter_name, template, status);
        IF (NOT status.normal) OR (template = NIL) THEN
          EXIT /find_months_and_days/;
        IFEND;
        clp$initialize_parse_state (template, NIL, parse);
        clp$scan_lexical_unit (clc$slu_non_space, parse);
        IF parse.unit.kind <> clc$lex_name THEN
{Not a valid month template.}
          EXIT /find_months_and_days/;
        IFEND;
        temp_days_and_months_ptr^.months [month_number].value :=
              template^ (parse.unit_index, parse.unit.size);
        temp_days_and_months_ptr^.months [month_number].size := parse.unit.size;
        clp$scan_lexical_unit (clc$slu_non_space, parse);
        IF parse.unit.kind = clc$lex_comma THEN
          clp$scan_lexical_unit (clc$slu_non_space, parse);
          IF parse.unit.kind <> clc$lex_name THEN
{Not a valid month template.}
            EXIT /find_months_and_days/;
          IFEND;
          temp_days_and_months_ptr^.months_abbrev [month_number].
                value := template^ (parse.unit_index, parse.unit.size);
          temp_days_and_months_ptr^.months_abbrev [month_number].size := parse.unit.size;
          clp$scan_lexical_unit (clc$slu_non_space, parse);
        ELSE
          IF temp_days_and_months_ptr^.months [month_number].size < 3 THEN
            temp_days_and_months_ptr^.months_abbrev [month_number].
                  value := temp_days_and_months_ptr^.months [month_number].value;
            temp_days_and_months_ptr^.months_abbrev [month_number].
                  size := temp_days_and_months_ptr^.months [month_number].size;
          ELSE
            temp_days_and_months_ptr^.months_abbrev [month_number].
                  value := temp_days_and_months_ptr^.months [month_number].value (1, 3);
            temp_days_and_months_ptr^.months_abbrev [month_number].size := 3;
          IFEND;
        IFEND;
        IF parse.unit.kind <> clc$lex_end_of_line THEN
{Not a valid month template.}
          EXIT /find_months_and_days/;
        IFEND;
      FOREND;

      FOR day_number := 1 TO 7 DO

        parameter_name := clv$english_day_and_month_names.days [day_number].value;
        osp$find_parameter_prompt (help_module, parameter_name, template, status);
        IF (NOT status.normal) OR (template = NIL) THEN
          EXIT /find_months_and_days/;
        IFEND;
        clp$initialize_parse_state (template, NIL, parse);
        clp$scan_lexical_unit (clc$slu_non_space, parse);
        IF parse.unit.kind <> clc$lex_name THEN
          {Not a valid month template.}
          EXIT /find_months_and_days/;
        IFEND;
        temp_days_and_months_ptr^.days [day_number].value := template^ (parse.unit_index, parse.unit.size);
        temp_days_and_months_ptr^.days [day_number].size := parse.unit.size;
        clp$scan_lexical_unit (clc$slu_non_space, parse);
        IF parse.unit.kind = clc$lex_comma THEN
          clp$scan_lexical_unit (clc$slu_non_space, parse);
          IF parse.unit.kind <> clc$lex_name THEN
            {Not a valid month template.}
            EXIT /find_months_and_days/;
          IFEND;
          temp_days_and_months_ptr^.days_abbrev [day_number].
                value := template^ (parse.unit_index, parse.unit.size);
          temp_days_and_months_ptr^.days_abbrev [day_number].size := parse.unit.size;
          clp$scan_lexical_unit (clc$slu_non_space, parse);
        ELSE
          IF temp_days_and_months_ptr^.days [day_number].size < 3 THEN
            temp_days_and_months_ptr^.days_abbrev [day_number].
                  value := temp_days_and_months_ptr^.days [day_number].value;
            temp_days_and_months_ptr^.days_abbrev [day_number].
                  size := temp_days_and_months_ptr^.days [day_number].size;
          ELSE
            temp_days_and_months_ptr^.days_abbrev [day_number].
                  value := temp_days_and_months_ptr^.days [day_number].value (1, 3);
            temp_days_and_months_ptr^.days_abbrev [day_number].size := 3;
          IFEND;
        IFEND;
        IF parse.unit.kind <> clc$lex_end_of_line THEN
          {Not a valid month template.}
          EXIT /find_months_and_days/;
        IFEND;
      FOREND;

      new_days_and_months_ptr := temp_days_and_months_ptr;
      clv$day_and_month_names_list := new_days_and_months_ptr;
      RETURN;

    END /find_months_and_days/;

{If we get here, we could not find either day names or month names for the
{ specified language. English will be used.

    FREE temp_days_and_months_ptr IN osv$task_shared_heap^;
    osp$set_status_abnormal ('CL', cle$bad_template_for_month_day, parameter_name, status);
    osp$append_status_parameter (osc$status_parameter_delimiter, language, status);
*ELSE
    new_days_and_months_ptr := clv$day_and_month_names_list;
*IFEND

  PROCEND clp$get_day_and_month_names;

MODEND clm$day_and_month_names_mgr;
*DECK DECK=CLM$DEBUG_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Debug Commands and Functions' ??
MODULE clm$debug_commands;

{
{ PURPOSE:
{   This module contains processors for the debug environment commands.
{
?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc cld$value
*copyc cle$ecc_miscellaneous
*copyc clt$name
*copyc ost$status
?? POP ??
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc osp$set_status_abnormal
*copyc pmp$change_debug_library_list
*copyc pmp$set_job_debug_ring

?? TITLE := 'clp$set_debug_ring_command', EJECT ??

  PROCEDURE [XDCL] clp$set_debug_ring_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT set_debug_ring_pdt (
{   ring, r : INTEGER osc$min_ring .. osc$max_ring = $REQUIRED
{   STATUS)

?? PUSH (LISTEXT := ON) ??

    VAR
      set_debug_ring_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^set_debug_ring_pdt_names, ^set_debug_ring_pdt_params];

    VAR
      set_debug_ring_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['RING', 1], ['R', 1], ['STATUS', 2]];

    VAR
      set_debug_ring_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ RING R }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$integer_value, osc$min_ring, osc$max_ring]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      value: clt$value;

    clp$scan_parameter_list (parameter_list, set_debug_ring_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('RING', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$set_job_debug_ring (value.int.value, status);

  PROCEND clp$set_debug_ring_command;
?? TITLE := 'clp$set_debug_list_command', EJECT ??

  PROCEDURE [XDCL] clp$set_debug_list_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT set_debug_list_pdt (
{   delete_libraries, delete_library, dl : LIST OF FILE OR KEY all
{   add_libraries, add_library, al : LIST OF FILE
{   STATUS)

?? PUSH (LISTEXT := ON) ??

    VAR
      set_debug_list_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^set_debug_list_pdt_names, ^set_debug_list_pdt_params];

    VAR
      set_debug_list_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
            clt$parameter_name_descriptor := [['DELETE_LIBRARIES', 1], ['DELETE_LIBRARY', 1], ['DL', 1],
            ['ADD_LIBRARIES', 2], ['ADD_LIBRARY', 2], ['AL', 2], ['STATUS', 3]];

    VAR
      set_debug_list_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
            clt$parameter_descriptor := [

{ DELETE_LIBRARIES DELETE_LIBRARY DL }
      [[clc$optional], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed,
            [^set_debug_list_pdt_kv1, clc$file_value]],

{ ADD_LIBRARIES ADD_LIBRARY AL }
      [[clc$optional], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      set_debug_list_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            ost$name := ['ALL'];

?? POP ??

    VAR
      add_count: 0 .. clc$max_value_sets,
      add_libraries: ^pmt$object_library_list,
      delete_count: 0 .. clc$max_value_sets,
      delete_libraries: ^pmt$object_library_list,
      library_index: 1 .. clc$max_value_sets,
      value: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, set_debug_list_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('ADD_LIBRARY', add_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('DELETE_LIBRARY', delete_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (add_count + delete_count) = 0 THEN
      osp$set_status_abnormal ('CL', cle$required_parameter_omitted, 'DELETE_LIBRARY or ADD_LIBRARY', status);
      RETURN;
    IFEND;

    IF delete_count > 0 THEN
      PUSH delete_libraries: [1 .. delete_count];
      FOR library_index := 1 TO delete_count DO
        clp$get_value ('DELETE_LIBRARY', library_index, 1, clc$low, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF value.kind = clc$name_value {AND value.name.value = 'ALL'} THEN
          IF delete_count <> 1 THEN
            osp$set_status_abnormal ('CL', cle$all_must_be_used_alone, 'DELETE_LIBRARY', status);
            RETURN;
          IFEND;
          delete_libraries^ [library_index] := value.name.value;
        ELSE
          delete_libraries^ [library_index] := value.file.local_file_name;
        IFEND;
      FOREND;
    ELSE
      delete_libraries := NIL;
    IFEND;

    IF add_count > 0 THEN
      PUSH add_libraries: [1 .. add_count];
      FOR library_index := 1 TO add_count DO
        clp$get_value ('ADD_LIBRARY', library_index, 1, clc$low, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        add_libraries^ [library_index] := value.file.local_file_name;
      FOREND;
    ELSE
      add_libraries := NIL;
    IFEND;

    pmp$change_debug_library_list (delete_libraries, add_libraries, status);

  PROCEND clp$set_debug_list_command;

MODEND clm$debug_commands;
*DECK DECK=CLM$DEFAULT_UNSEEN_MAIL_HANDLER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter: Default UNSEEN_MAIL Condition Handler' ??
MODULE clm$default_unseen_mail_handler;

{
{ PURPOSE:
{   This module contains the default unseen_mail condition handler.
{

?? NEWTITLE := 'Global Declarations Referenced in this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc cle$unseen_mail_condition
*copyc clt$unseen_mail_action
*copyc clt$when_conditions
*copyc ost$status
*copyc pmt$condition
?? POP ??
*copyc amp$flush
*copyc clp$find_unseen_mail_action
*copyc clp$get_system_file_id
*copyc osp$generate_message
*copyc osp$set_status_condition
*copyc pmp$post_unseen_mail
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] clp$default_unseen_mail_handler', EJECT ??

{
{ PURPOSE:
{   This procedure is the default unseen_mail condition handler.
{

  PROCEDURE [XDCL] clp$default_unseen_mail_handler
    (    ignore_condition: pmt$condition;
     VAR status: ost$status);

    VAR
      action: ^clt$unseen_mail_action,
      condition_status: ost$status,
      file_id: amt$file_identifier;


    status.normal := TRUE;

    clp$find_unseen_mail_action (action);
    IF action^ = clc$post_unseen_mail THEN
      pmp$post_unseen_mail;
      RETURN;
    IFEND;

    osp$set_status_condition (cle$unseen_mail_condition, condition_status);
    osp$generate_message (condition_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_system_file_id (clc$job_command_response, file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    amp$flush (file_id, osc$wait, status);

  PROCEND clp$default_unseen_mail_handler;

MODEND clm$default_unseen_mail_handler;
*DECK DECK=CLM$DEFINE_APPLICATION_MENU EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Define_Application_Menu' ??
MODULE clm$define_application_menu;

{
{ PURPOSE:
{   This module contains the processors of the CREATE_APPLICATION_MENU sub_utility subcommands.
{

?? NEWTITLE := 'GLOBAL DECLARATIONS', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_mt_generator
*copyc csc$max_classes
*copyc csc$max_items_per_class
*copyc csc$max_menu_items
*copyc cst$application_functions
*copyc cst$class_name
*copyc cst$key_type
*copyc cst$menu_class
*copyc cst$menu_item
*copyc cst$menu_item_number
*copyc cst$menu_list
*copyc cst$screen_events
*copyc cst$standard_functions
*copyc oss$job_paged_literal
*copyc ost$status_condition_name
*copyc osv$lower_to_upper
*copyc pmt$program_name
?? POP ??
*copyc clp$begin_utility
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$include_file
*copyc clp$evaluate_parameters
*copyc osp$set_status_abnormal
?? EJECT ??

  TYPE
    standard_keys = set of cst$standard_functions,
    application_keys = set of cst$application_functions,
    screen_keys = set of cst$screen_events;

  TYPE
    key_type = record
      case cs_key_type: cst$key_type of
      = csc$standard_function =
        standard: cst$standard_functions,
      = csc$application_function =
        application: cst$application_functions,
      = csc$screen_function =
        screen: cst$screen_events,
      casend,
    recend;

  TYPE
    menu_record = record
      name: ost$status_condition_name,
      number_of_classes: cst$max_classes,
      number_of_items: cst$menu_item_number,
    recend;

  TYPE
    classes = record
      name: cst$class_name,
      number_of_items: 0 .. csc$max_items_per_class,
    recend;

  CONST
    number_of_key_types = 34,
    max_key_type_size = 21;

  VAR
    table: [STATIC, READ, oss$job_paged_literal] array [1 .. number_of_key_types] of record
      name: string (max_key_type_size),
      key_type: key_type,
    recend := [
          {} ['BACK                 ', [csc$standard_function, csc$back]],
          {} ['BACKWARD             ', [csc$standard_function, csc$backward]],
          {} ['CLEAR                ', [csc$screen_function, csc$clear]],
          {} ['CLEAR_EOL_MENU_ITEM  ', [csc$screen_function, csc$clear_eol_menu_item]],
          {} ['DATA                 ', [csc$standard_function, csc$data]],
          {} ['DELETE_CHAR_MENU_ITEM', [csc$screen_function, csc$delete_char_menu_item]],
          {} ['DELETE_LINE          ', [csc$screen_function, csc$delete_line]],
          {} ['DOWN                 ', [csc$standard_function, csc$down]],
          {} ['EDIT                 ', [csc$standard_function, csc$edit]],
          {} ['F1                   ', [csc$application_function, csc$f1]],
          {} ['F10                  ', [csc$application_function, csc$f10]],
          {} ['F11                  ', [csc$application_function, csc$f11]],
          {} ['F12                  ', [csc$application_function, csc$f12]],
          {} ['F13                  ', [csc$application_function, csc$f13]],
          {} ['F14                  ', [csc$application_function, csc$f14]],
          {} ['F15                  ', [csc$application_function, csc$f15]],
          {} ['F16                  ', [csc$application_function, csc$f16]],
          {} ['F2                   ', [csc$application_function, csc$f2]],
          {} ['F3                   ', [csc$application_function, csc$f3]],
          {} ['F4                   ', [csc$application_function, csc$f4]],
          {} ['F5                   ', [csc$application_function, csc$f5]],
          {} ['F6                   ', [csc$application_function, csc$f6]],
          {} ['F7                   ', [csc$application_function, csc$f7]],
          {} ['F8                   ', [csc$application_function, csc$f8]],
          {} ['F9                   ', [csc$application_function, csc$f9]],
          {} ['FORWARD              ', [csc$standard_function, csc$forward]],
          {} ['HELP                 ', [csc$standard_function, csc$help]],
          {} ['HOME                 ', [csc$screen_function, csc$home]],
          {} ['INSERT_CHAR_MENU_ITEM', [csc$screen_function, csc$insert_char_menu_item]],
          {} ['INSERT_LINE          ', [csc$screen_function, csc$insert_line]],
          {} ['NEXT                 ', [csc$standard_function, csc$next]],
          {} ['STOP                 ', [csc$standard_function, csc$stop]],
          {} ['UNDO                 ', [csc$standard_function, csc$undo]],
          {} ['UP                   ', [csc$standard_function, csc$up]]];

  CONST
    prompt_string = 'CAM',
    prompt_string_size = 3;

  VAR
    class_number: cst$max_classes,
    item_number: cst$menu_item_number,
    menu_classes: ^array [1 .. * ] of classes,
    message_module_name: pmt$program_name,
    store_info_status: ost$status,
    utility_name: [STATIC, READ, oss$job_paged_literal] ost$name := 'create_application_menu',
    selected_standard_keys: standard_keys,
    selected_application_keys: application_keys,
    selected_screen_keys: screen_keys,
    work_area_ptr: ^SEQ ( * );

?? TITLE := 'check_classes_for_name', EJECT ??

  PROCEDURE [INLINE] check_classes_for_name
    (    name: cst$class_name;
     VAR name_found: boolean;
     VAR class_index: cst$max_classes);

    FOR class_index := 1 TO csc$max_classes DO
      IF menu_classes^ [class_index].name = name THEN
        name_found := TRUE;
        RETURN;
      IFEND;
    FOREND;

    name_found := FALSE;
    class_index := 0;

  PROCEND check_classes_for_name;
?? TITLE := 'find_key_type', EJECT ??

  PROCEDURE find_key_type
    (    key_name: ost$name;
         shift: boolean;
     VAR menu_item: cst$menu_item;
     VAR status: ost$status);

    VAR
      low_index: 1 .. number_of_key_types,
      high_index: 0 .. number_of_key_types,
      temp: integer,
      current_index: 1 .. number_of_key_types + 1;

    status.normal := TRUE;
    low_index := 1;
    high_index := number_of_key_types;

    REPEAT
      temp := low_index + high_index;
      current_index := temp DIV 2;
      IF key_name = table [current_index].name THEN

      /search/
        BEGIN
          menu_item.menu_type := table [current_index].key_type.cs_key_type;
          CASE table [current_index].key_type.cs_key_type OF
          = csc$standard_function =
            menu_item.standard_function := table [current_index].key_type.standard;
            IF shift THEN
              menu_item.standard_function := SUCC (menu_item.standard_function);
            IFEND;
            IF menu_item.standard_function IN selected_standard_keys THEN
              EXIT /search/;
            IFEND;
            selected_standard_keys := selected_standard_keys + $standard_keys [menu_item.standard_function];
            RETURN;
          = csc$application_function =
            menu_item.application_function := table [current_index].key_type.application;
            IF shift THEN
              menu_item.application_function := SUCC (menu_item.application_function);
            IFEND;
            IF menu_item.application_function IN selected_application_keys THEN
              EXIT /search/;
            IFEND;
            selected_application_keys := selected_application_keys + $application_keys
                  [menu_item.application_function];
            RETURN;
          = csc$screen_function =
            menu_item.screen_function := table [current_index].key_type.screen;
            IF menu_item.screen_function IN selected_screen_keys THEN
              EXIT /search/;
            IFEND;
            selected_screen_keys := selected_screen_keys + $screen_keys [menu_item.screen_function];
            RETURN;
          ELSE
          CASEND;
        END /search/;
        IF shift THEN
          osp$set_status_abnormal ('CL', cle$duplicate_shifted_keys, key_name, status);
        ELSE
          osp$set_status_abnormal ('CL', cle$duplicate_keys, key_name, status);
        IFEND;
        RETURN;
      ELSEIF key_name < table [current_index].name THEN
        high_index := current_index - 1;
      ELSE
        low_index := current_index + 1;
      IFEND;
    UNTIL low_index > high_index;

  PROCEND find_key_type;
?? TITLE := 'clp$_create_menu_class', EJECT ??

  PROCEDURE clp$_create_menu_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$cream_cremc) create_menu_class, cremc (
{   name, n: string 1..31 = $required
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 30, 15, 10, 26, 820],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OCM$CREAM_CREMC'], [
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [1, 31, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

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

    CONST
      p$name = 1,
      p$status = 2;

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

    VAR
      menu_class: cst$class_name,
      name_found: boolean,
      ignore_class_index: cst$max_classes;

    status.normal := TRUE;

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

    menu_class := pvt [p$name].value^.string_value^;
    IF menu_class = osc$null_name THEN
      osp$set_status_abnormal ('CL', cle$null_not_allowed, menu_class, status);
      RETURN;
    IFEND;

    check_classes_for_name (menu_class, name_found, ignore_class_index);
    IF name_found THEN
      osp$set_status_abnormal ('CL', cle$duplicate_menu_class, menu_class, status);
      RETURN;
    IFEND;

    IF (class_number + 1) > csc$max_classes THEN
      osp$set_status_abnormal ('CL', cle$max_menu_classes_exceeded, '', status);
      RETURN;
    IFEND;

    class_number := class_number + 1;
    menu_classes^ [class_number].name := menu_class;

  PROCEND clp$_create_menu_class;
?? TITLE := 'clp$_create_menu_item', EJECT ??

  PROCEDURE clp$_create_menu_item
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$cream_cremi) create_menu_item, cremi (
{   key, k: key
{       f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11, f12, f13, f14, f15, f16..
{ , next, help, stop, back, up, down
{       forward, backward, edit, data, insert_line, delete_line, home, clear,..
{  clear_eol_menu_item
{       delete_char_menu_item, insert_char_menu_item, undo
{     keyend = $optional
{   shift: boolean = no
{   class, c: string 1..31 = $optional
{   short_label, sl: string 1..6 = $required
{   alternate_short_label, asl: string 1..6 = $optional
{   long_label, ll: string 1..31 = $optional
{   alternate_long_label, all: string 1..31 = $optional
{   pair_with_previous, pwp: boolean = no
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 16] of clt$pdt_parameter_name,
      parameters: array [1 .. 9] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 34] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (2),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type8: record
        header: clt$type_specification_header,
        default_value: string (2),
      recend,
      type9: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 30, 15, 23, 4, 502],
    clc$command, 16, 9, 1, 0, 0, 0, 9, 'OCM$CREAM_CREMI'], [
    ['ALL                            ',clc$abbreviation_entry, 7],
    ['ALTERNATE_LONG_LABEL           ',clc$nominal_entry, 7],
    ['ALTERNATE_SHORT_LABEL          ',clc$nominal_entry, 5],
    ['ASL                            ',clc$abbreviation_entry, 5],
    ['C                              ',clc$abbreviation_entry, 3],
    ['CLASS                          ',clc$nominal_entry, 3],
    ['K                              ',clc$abbreviation_entry, 1],
    ['KEY                            ',clc$nominal_entry, 1],
    ['LL                             ',clc$abbreviation_entry, 6],
    ['LONG_LABEL                     ',clc$nominal_entry, 6],
    ['PAIR_WITH_PREVIOUS             ',clc$nominal_entry, 8],
    ['PWP                            ',clc$abbreviation_entry, 8],
    ['SHIFT                          ',clc$nominal_entry, 2],
    ['SHORT_LABEL                    ',clc$nominal_entry, 4],
    ['SL                             ',clc$abbreviation_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 9]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 1265, clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 2],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$required_parameter, 0, 0],
{ PARAMETER 5
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 2],
{ PARAMETER 9
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [34], [
    ['BACK                           ', clc$nominal_entry,
  clc$normal_usage_entry, 20],
    ['BACKWARD                       ', clc$nominal_entry,
  clc$normal_usage_entry, 24],
    ['CLEAR                          ', clc$nominal_entry,
  clc$normal_usage_entry, 30],
    ['CLEAR_EOL_MENU_ITEM            ', clc$nominal_entry,
  clc$normal_usage_entry, 31],
    ['DATA                           ', clc$nominal_entry,
  clc$normal_usage_entry, 26],
    ['DELETE_CHAR_MENU_ITEM          ', clc$nominal_entry,
  clc$normal_usage_entry, 32],
    ['DELETE_LINE                    ', clc$nominal_entry,
  clc$normal_usage_entry, 28],
    ['DOWN                           ', clc$nominal_entry,
  clc$normal_usage_entry, 22],
    ['EDIT                           ', clc$nominal_entry,
  clc$normal_usage_entry, 25],
    ['F1                             ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['F10                            ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
    ['F11                            ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
    ['F12                            ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
    ['F13                            ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
    ['F14                            ', clc$nominal_entry,
  clc$normal_usage_entry, 14],
    ['F15                            ', clc$nominal_entry,
  clc$normal_usage_entry, 15],
    ['F16                            ', clc$nominal_entry,
  clc$normal_usage_entry, 16],
    ['F2                             ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['F3                             ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['F4                             ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['F5                             ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
    ['F6                             ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
    ['F7                             ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
    ['F8                             ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
    ['F9                             ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
    ['FORWARD                        ', clc$nominal_entry,
  clc$normal_usage_entry, 23],
    ['HELP                           ', clc$nominal_entry,
  clc$normal_usage_entry, 18],
    ['HOME                           ', clc$nominal_entry,
  clc$normal_usage_entry, 29],
    ['INSERT_CHAR_MENU_ITEM          ', clc$nominal_entry,
  clc$normal_usage_entry, 33],
    ['INSERT_LINE                    ', clc$nominal_entry,
  clc$normal_usage_entry, 27],
    ['NEXT                           ', clc$nominal_entry,
  clc$normal_usage_entry, 17],
    ['STOP                           ', clc$nominal_entry,
  clc$normal_usage_entry, 19],
    ['UNDO                           ', clc$nominal_entry,
  clc$normal_usage_entry, 34],
    ['UP                             ', clc$nominal_entry,
  clc$normal_usage_entry, 21]]
    ],
{ PARAMETER 2
    [[1, 0, clc$boolean_type],
    'no'],
{ PARAMETER 3
    [[1, 0, clc$string_type], [1, 31, FALSE]],
{ PARAMETER 4
    [[1, 0, clc$string_type], [1, 6, FALSE]],
{ PARAMETER 5
    [[1, 0, clc$string_type], [1, 6, FALSE]],
{ PARAMETER 6
    [[1, 0, clc$string_type], [1, 31, FALSE]],
{ PARAMETER 7
    [[1, 0, clc$string_type], [1, 31, FALSE]],
{ PARAMETER 8
    [[1, 0, clc$boolean_type],
    'no'],
{ PARAMETER 9
    [[1, 0, clc$status_type]]];

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

    CONST
      p$key = 1,
      p$shift = 2,
      p$class = 3,
      p$short_label = 4,
      p$alternate_short_label = 5,
      p$long_label = 6,
      p$alternate_long_label = 7,
      p$pair_with_previous = 8,
      p$status = 9;

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

    VAR
      menu_class: cst$class_name,
      name_found: boolean,
      class_index: cst$max_classes,
      key_name: ost$name,
      shift: boolean,
      item: cst$menu_item,
      menu_item: ^cst$menu_item;

    status.normal := TRUE;

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

    IF pvt [p$class].specified THEN { must be a string
      menu_class := pvt [p$class].value^.string_value^;
      IF menu_class = osc$null_name THEN
        osp$set_status_abnormal ('CL', cle$null_not_allowed, 'MENU CLASS', status);
        RETURN;
      IFEND;

      check_classes_for_name (menu_class, name_found, class_index);
      IF NOT name_found THEN
        osp$set_status_abnormal ('CL', cle$menu_class_not_defined, menu_class, status);
        RETURN;
      IFEND;
    ELSE
      class_index := class_number;
      IF class_index = 0 THEN
        osp$set_status_abnormal ('CL', cle$no_menu_class_defined, '', status);
        RETURN;
      IFEND;
    IFEND;

    item.pair_with_previous := pvt [p$pair_with_previous].value^.boolean_value.value;

    item.short_label := pvt [p$short_label].value^.string_value^;
    IF item.short_label = osc$null_name THEN
      osp$set_status_abnormal ('CL', cle$null_not_allowed, 'SHORT_LABEL', status);
      RETURN;
    IFEND;

    IF pvt [p$alternate_short_label].specified THEN { must be a string
      item.alternate_short_label := pvt [p$alternate_short_label].value^.string_value^;
      IF item.alternate_short_label = osc$null_name THEN
        osp$set_status_abnormal ('CL', cle$null_not_allowed, 'ALTERNATE_SHORT_LABEL', status);
        RETURN;
      IFEND;
    ELSE
      item.alternate_short_label := item.short_label;
    IFEND;

    IF pvt [p$long_label].specified THEN
      item.long_label := pvt [p$long_label].value^.string_value^;
      IF item.long_label = osc$null_name THEN
        osp$set_status_abnormal ('CL', cle$null_not_allowed, 'LONG_LABEL', status);
        RETURN;
      IFEND;

    ELSE
      item.long_label := item.short_label;
    IFEND;

    IF pvt [p$alternate_long_label].specified THEN
      item.alternate_long_label := pvt [p$alternate_long_label].value^.string_value^;
      IF item.alternate_long_label = osc$null_name THEN
        osp$set_status_abnormal ('CL', cle$null_not_allowed, 'ALTERNATE_LONG_LABEL', status);
        RETURN;
      IFEND;
    ELSE
      item.alternate_long_label := item.long_label;
    IFEND;

    IF pvt [p$key].specified THEN
      key_name := pvt [p$key].value^.keyword_value;

      shift := pvt [p$shift].value^.boolean_value.value;

      find_key_type (key_name, shift, item, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      item.item_assigned := TRUE;
    ELSE

{ item.menu_type := csc$unused_entry;

      item.item_assigned := FALSE;
    IFEND;

    IF (menu_classes^ [class_index].number_of_items + 1) > csc$max_items_per_class THEN
      osp$set_status_abnormal ('CL', cle$max_menu_items_exceeded, '', status);
      RETURN;
    IFEND;

    item.menu_parent := class_index;
    menu_classes^ [class_index].number_of_items := menu_classes^ [class_index].number_of_items + 1;
    item_number := item_number + 1;
    NEXT menu_item IN work_area_ptr;
    IF menu_item = NIL THEN
      osp$set_status_abnormal ('CL', cle$module_too_large, message_module_name, store_info_status);
    ELSE
      menu_item^ := item;
    IFEND;

  PROCEND clp$_create_menu_item;
?? TITLE := 'clp$_end_application_menu', EJECT ??

  PROCEDURE clp$_end_application_menu
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$cream_endam) end_application_menu, endam

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 11, 30, 15, 43, 26, 841],
    clc$command, 0, 0, 0, 0, 0, 0, 0, 'OCM$CREAM_ENDAM']];

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

    VAR
      ignore_status: ost$status;

    status.normal := TRUE;

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

    clp$end_include (utility_name, ignore_status);

  PROCEND clp$_end_application_menu;
?? TITLE := 'clp$define_application_menu', EJECT ??

  PROCEDURE [XDCL] clp$define_application_menu
    (VAR work_area: ^SEQ ( * );
         menu_name: ost$status_condition_name;
         module_name: pmt$program_name;
     VAR number_of_classes: cst$max_classes;
     VAR number_of_items: cst$menu_item_number;
     VAR status: ost$status);

{ table command_table sn=oss$job_paged_literal
{ command (create_menu_class   , cremc)       p=clp$_create_menu_class    ..
{   cm=local
{ command (create_menu_item    , cremi)       p=clp$_create_menu_item     ..
{   cm=local
{ command (end_application_menu, quit, endam) p=clp$_end_application_menu ..
{   cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  command_table: [STATIC, READ, oss$job_paged_literal]
      ^clt$command_table := ^command_table_entries,

  command_table_entries: [STATIC, READ, oss$job_paged_literal] array [1
      .. 7] of clt$command_table_entry := [
  {} ['CREATE_MENU_CLASS              ', clc$nominal_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^clp$_create_menu_class],
  {} ['CREATE_MENU_ITEM               ', clc$nominal_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^clp$_create_menu_item],
  {} ['CREMC                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^clp$_create_menu_class],
  {} ['CREMI                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^clp$_create_menu_item],
  {} ['ENDAM                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^clp$_end_application_menu],
  {} ['END_APPLICATION_MENU           ', clc$nominal_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^clp$_end_application_menu],
  {} ['QUIT                           ', clc$alias_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^clp$_end_application_menu]];

?? POP ??

    VAR
      menu_info: ^menu_record,
      i: cst$max_classes,
      utility_attributes: array [1 .. 3] of clt$utility_attribute;

    status.normal := TRUE;
    store_info_status.normal := TRUE;
    class_number := 0;
    item_number := 0;
    work_area_ptr := work_area;
    message_module_name := module_name;
    selected_standard_keys := $standard_keys [];
    selected_application_keys := $application_keys [];
    selected_screen_keys := $screen_keys [];


    NEXT menu_info IN work_area_ptr;
    IF menu_info = NIL THEN
      osp$set_status_abnormal ('CL', cle$module_too_large, module_name, status);
      RETURN;
    IFEND;

    menu_info^.name := menu_name;
    NEXT menu_classes: [1 .. csc$max_classes] IN work_area_ptr;
    IF menu_classes = NIL THEN
      osp$set_status_abnormal ('CL', cle$module_too_large, module_name, status);
      RETURN;
    IFEND;

    FOR i := 1 TO csc$max_classes DO
      menu_classes^ [i].name := osc$null_name;
      menu_classes^ [i].number_of_items := 0;
    FOREND;

    utility_attributes [1].key := clc$utility_command_search_mode;
    utility_attributes [1].command_search_mode := clc$global_command_search;
    utility_attributes [2].key := clc$utility_command_table;
    utility_attributes [2].command_table := command_table;
    utility_attributes [3].key := clc$utility_prompt;
    utility_attributes [3].prompt.value := prompt_string;
    utility_attributes [3].prompt.size := prompt_string_size;
    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, prompt_string, utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    ELSEIF status.normal AND (NOT store_info_status.normal) THEN
      status := store_info_status;
      RETURN;
    IFEND;

    clp$end_utility (utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF class_number < 1 THEN
      osp$set_status_abnormal ('CL', cle$too_few_classes, menu_name, status);
      RETURN;
    IFEND;

    IF item_number < 1 THEN
      osp$set_status_abnormal ('CL', cle$too_few_items, menu_name, status);
      RETURN;
    IFEND;

    menu_info^.number_of_classes := class_number;
    menu_info^.number_of_items := item_number;

    number_of_classes := class_number;
    number_of_items := item_number;
    work_area := work_area_ptr;

  PROCEND clp$define_application_menu;

MODEND clm$define_application_menu;
*DECK DECK=CLM$DEFINE_MESSAGE_MODULE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Define_Message_Module' ??
MODULE clm$define_message_module;

{
{ PURPOSE:
{   This module contains the processors of the CREATE_MESSAGE_MODULE utility subcommands.
{

?? NEWTITLE := 'GLOBAL DECLARATIONS', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_mt_generator
*copyc cle$ecc_parameter_list
*copyc clt$command_line_size
*copyc csc$max_menu_items
*copyc cst$class_name
*copyc cst$key_type
*copyc cst$menu_class
*copyc cst$menu_item
*copyc cst$menu_item_number
*copyc cst$menu_list
*copyc cst$screen_events
*copyc cst$standard_functions
*copyc llt$object_library_header
*copyc osc$max_status_condition_number
*copyc osc$max_status_message
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc ost$message_template
*copyc ost$message_template_index
*copyc ost$message_template_module
*copyc ost$mtm_menu_header
?? POP ??
*copyc clp$begin_utility
*copyc clp$convert_integer_to_string
*IF NOT $true(osv$unix_tools_on_ve)
*copyc clp$define_application_menu
*IFEND
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*IF $true(osv$unix_tools_on_ve)
*copyc clp$extract_message_module
*copyc fsp$close_file
*copyc fsp$open_file
*IFEND
*copyc clp$get_line_from_command_file
*copyc clp$include_file
*copyc clp$trimmed_string_size
*copyc i#current_sequence_position
*IF NOT $true(osv$unix_tools_on_ve)
*copyc ocp$generate_message
*IFEND
*copyc osp$append_status_parameter
*copyc osp$get_status_condition_string
*copyc osp$set_status_abnormal
*copyc osp$status_condition_code
?? EJECT ??

  TYPE
    menu_record = record
      name: ost$status_condition_name,
      number_of_classes: cst$max_classes,
      number_of_items: cst$menu_item_number,
    recend;

  TYPE
    message_record = record
      code: ost$status_condition_code,
      name: ost$status_condition_name,
      severity: ost$message_module_severity,
      size: 0 .. osc$max_status_message,
    recend;

  CONST
    prompt_string = 'CMM',
    prompt_string_size = 3;

  VAR
    create_module: boolean,
    in_create_message_module: [STATIC] boolean := FALSE,
    message_module_name: pmt$program_name,
    module_has_errors: boolean,
    number_of_application_menus: ost$message_template_index,
    number_of_codes: ost$message_template_index,
    number_of_names: ost$message_template_index,
    store_info_status: ost$status,
    total_number_of_classes: ost$message_template_index,
    total_number_of_items: ost$message_template_index,
    total_template_size: ost$segment_length,
    utility_name: [STATIC, READ, oss$job_paged_literal] ost$name := 'CREATE_MESSAGE_MODULE',
    work_area_ptr: ^SEQ ( * );

?? TITLE := 'collect_template', EJECT ??

  PROCEDURE collect_template
    (    kind: ost$message_template_kind;
         sub_command: string ( * <= osc$max_name_size);
         name: ost$name;
         until_string: ^clt$string_value;
     VAR template_size: 0 .. osc$max_status_message;
     VAR status: ost$status);

    VAR
      converted_integer: ost$string,
      culprit: ost$name,
      beginning_of_template: ^ost$message_template,
      line: ^clt$command_line,
      line_size: clt$command_line_size,
      local_status: ost$status,
      number_of_classes: cst$max_classes,
      number_of_items: cst$menu_item_number,
      message_status: ost$status,
      template_too_long: boolean,
      template_pointer: ^ost$message_template;

    status.normal := TRUE;
    template_size := 0;
    template_too_long := FALSE;

    IF store_info_status.normal THEN
      NEXT template_pointer: [0] IN work_area_ptr;
      beginning_of_template := template_pointer;
      IF (number_of_names + 1) > osc$max_status_condition_code THEN
        clp$convert_integer_to_string (osc$max_status_condition_code, 10, FALSE, converted_integer,
              store_info_status);
        osp$set_status_abnormal ('CL', cle$too_many_entries_for_module, converted_integer.
              value (1, converted_integer.size), store_info_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, message_module_name, store_info_status);
      ELSE
        number_of_names := number_of_names + 1;
        IF kind = osc$status_message THEN
          number_of_codes := number_of_codes + 1;
        IFEND;
      IFEND;
    IFEND;

  /collect_template_loop/
    WHILE TRUE DO
      clp$get_line_from_command_file ('? ', line, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      ELSEIF NOT status.normal THEN
        EXIT /collect_template_loop/;
      ELSEIF line = NIL THEN
        IF status.normal THEN
          osp$set_status_abnormal ('CL', cle$encountered_eoi, sub_command, status);
        IFEND;
        EXIT /collect_template_loop/;
      ELSEIF (STRLENGTH (line^) = STRLENGTH (until_string^)) AND (line^ = until_string^) THEN
        EXIT /collect_template_loop/;
      ELSEIF (NOT template_too_long) AND store_info_status.normal THEN
        line_size := STRLENGTH (line^);
        IF line_size > 0 THEN
          IF (line_size > 1) AND (line^ (STRLENGTH (line^) - 1, 2) = '..') THEN
            WHILE (line_size >= 1) AND (line^ (line_size) = '.') DO
              line_size := line_size - 1;
            WHILEND;
          IFEND;
          IF line_size > 0 THEN
            template_too_long := (template_size + line_size) > osc$max_status_message;
            IF template_too_long THEN
              IF kind = osc$brief_help THEN
                culprit := 'BRIEF HELP MESSAGE';
              ELSEIF kind = osc$full_help THEN
                culprit := 'FULL HELP MESSAGE';
              ELSE
                culprit := name;
              IFEND;
              NEXT template_pointer: [osc$max_status_message - template_size] IN work_area_ptr;
              IF template_pointer = NIL THEN
                osp$set_status_abnormal ('CL', cle$module_too_large, message_module_name, store_info_status);
              ELSE
                template_pointer^ := line^ (1, osc$max_status_message - template_size);
                template_size := osc$max_status_message;
                clp$convert_integer_to_string (osc$max_status_message, 10, FALSE, converted_integer,
                      message_status);
                osp$set_status_abnormal ('CL', cle$template_too_long, culprit, message_status);
                osp$append_status_parameter (osc$status_parameter_delimiter, message_module_name,
                      message_status);
                osp$append_status_parameter (osc$status_parameter_delimiter, converted_integer.value,
                      message_status);
*IF NOT $true(osv$unix_tools_on_ve)
                ocp$generate_message (message_status);
*IFEND
                module_has_errors := TRUE;
              IFEND;
            ELSE
              template_size := template_size + line_size;
              NEXT template_pointer: [line_size] IN work_area_ptr;
              IF template_pointer = NIL THEN
                osp$set_status_abnormal ('CL', cle$module_too_large, message_module_name, store_info_status);
              ELSE
                template_pointer^ (1, line_size) := line^ (1, line_size);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    WHILEND /collect_template_loop/;

    IF store_info_status.normal THEN
      RESET work_area_ptr TO beginning_of_template;
      NEXT template_pointer: [template_size] IN work_area_ptr;
      total_template_size := total_template_size + template_size;
    ELSE
      IF status.normal THEN
        status := store_info_status;
      IFEND;
    IFEND;

  PROCEND collect_template;
?? TITLE := 'clp$_create_status_message', EJECT ??

  PROCEDURE clp$_create_status_message
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$cremm_cresm) create_status_message, cresm (
{   name, n: name = $required
{   code, c: integer 0..0ffffffffff(16) = $required
{   identifier, i: string 2 = $optional
{   severity, s: key
{       (informative, i)
{       (warning, w)
{       (error, e)
{       (fatal, f)
{       (catastrophic, c)
{       (non_standard, ns)
{       (dependent, d)
{     keyend = error
{   collect_template_until, ctu: string literal = '**'
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 14] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (4),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 30, 17, 21, 43, 698],
    clc$command, 11, 6, 2, 0, 0, 0, 6, 'OCM$CREMM_CRESM'], [
    ['C                              ',clc$abbreviation_entry, 2],
    ['CODE                           ',clc$nominal_entry, 2],
    ['COLLECT_TEMPLATE_UNTIL         ',clc$nominal_entry, 5],
    ['CTU                            ',clc$abbreviation_entry, 5],
    ['I                              ',clc$abbreviation_entry, 3],
    ['IDENTIFIER                     ',clc$nominal_entry, 3],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['S                              ',clc$abbreviation_entry, 4],
    ['SEVERITY                       ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 525, clc$optional_default_parameter, 0, 5],
{ PARAMETER 5
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 4],
{ PARAMETER 6
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, 0ffffffffff(16), 10]],
{ PARAMETER 3
    [[1, 0, clc$string_type], [2, 2, FALSE]],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [14], [
    ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
    ['CATASTROPHIC                   ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
    ['D                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
    ['DEPENDENT                      ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
    ['E                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['ERROR                          ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['F                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
    ['FATAL                          ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['I                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['INFORMATIVE                    ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['NON_STANDARD                   ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
    ['NS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
    ['W                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['WARNING                        ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'error'],
{ PARAMETER 5
    [[1, 0, clc$string_type], [0, clc$max_string_size, TRUE],
    '''**'''],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

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

    CONST
      p$name = 1,
      p$code = 2,
      p$identifier = 3,
      p$severity = 4,
      p$collect_template_until = 5,
      p$status = 6;

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

    VAR
      code: ost$status_condition_code,
      message_info_p: ^message_record,
      message_kind_p: ^ost$message_template_kind,
      severity: ost$message_module_severity,
      template_size: 0 .. osc$max_status_message,
      until_string_p: ^clt$string_value;

    status.normal := TRUE;

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

    IF pvt [p$code].value^.integer_value.value <= osc$max_status_condition_number THEN
      IF NOT pvt [p$identifier].specified THEN
        osp$set_status_abnormal ('CL', cle$required_parameter_omitted, 'IDENTIFIER', status);
        RETURN;
      IFEND;
      code := osp$status_condition_code (pvt [p$identifier].value^.string_value^, pvt [p$code].
            value^.integer_value.value);
    ELSE
      code := pvt [p$code].value^.integer_value.value;
    IFEND;

    IF pvt [p$severity].value^.keyword_value = 'INFORMATIVE' THEN
      severity := osc$mm_informative_severity;
    ELSEIF pvt [p$severity].value^.keyword_value = 'WARNING' THEN
      severity := osc$mm_warning_severity;
    ELSEIF pvt [p$severity].value^.keyword_value = 'ERROR' THEN
      severity := osc$mm_error_severity;
    ELSEIF pvt [p$severity].value^.keyword_value = 'FATAL' THEN
      severity := osc$mm_fatal_severity;
    ELSEIF pvt [p$severity].value^.keyword_value = 'CATASTROPHIC' THEN
      severity := osc$mm_catastrophic_severity;
    ELSEIF pvt [p$severity].value^.keyword_value = 'NON_STANDARD' THEN
      severity := osc$mm_non_standard_severity;
    ELSE {pvt [p$severity].value^.keyword_value = 'DEPENDENT'
      severity := osc$mm_dependent_severity;
    IFEND;

    until_string_p := pvt [p$collect_template_until].value^.string_value;

    NEXT message_kind_p IN work_area_ptr;
    IF message_kind_p = NIL THEN
      osp$set_status_abnormal ('CL', cle$module_too_large, message_module_name, store_info_status);
    ELSE
      message_kind_p^ := osc$status_message;
    IFEND;

    IF store_info_status.normal THEN
      NEXT message_info_p IN work_area_ptr;
      IF message_info_p = NIL THEN
        osp$set_status_abnormal ('CL', cle$module_too_large, message_module_name, store_info_status);
      IFEND;
    IFEND;
    collect_template (osc$status_message, 'CREATE_STATUS_MESSAGE', pvt [p$name].value^.name_value,
          until_string_p, template_size, status);

    IF store_info_status.normal THEN
      message_info_p^.name := pvt [p$name].value^.name_value;
      message_info_p^.code := code;
      message_info_p^.severity := severity;
      message_info_p^.size := template_size;
    IFEND;

    IF NOT status.normal THEN
      RESET work_area_ptr TO message_kind_p;
    IFEND;

  PROCEND clp$_create_status_message;
?? TITLE := 'clp$_create_brief_help_message', EJECT ??

  PROCEDURE clp$_create_brief_help_message
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$cremm_crebhm) create_brief_help_message, crebhm (
{   collect_template_until, ctu: string literal = '**'
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 30, 17, 23, 8, 219],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OCM$CREMM_CREBHM'], [
    ['COLLECT_TEMPLATE_UNTIL         ',clc$nominal_entry, 1],
    ['CTU                            ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, clc$max_string_size, TRUE],
    '''**'''],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

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

    CONST
      p$collect_template_until = 1,
      p$status = 2;

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

    VAR
      message_info_p: ^message_record,
      message_kind_p: ^ost$message_template_kind,
      template_size: 0 .. osc$max_status_message,
      until_string_p: ^clt$string_value;

    status.normal := TRUE;

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

    until_string_p := pvt [p$collect_template_until].value^.string_value;

    NEXT message_kind_p IN work_area_ptr;
    IF message_kind_p = NIL THEN
      osp$set_status_abnormal ('CL', cle$module_too_large, message_module_name, store_info_status);
    ELSE
      message_kind_p^ := osc$brief_help;
    IFEND;

    IF store_info_status.normal THEN
      NEXT message_info_p IN work_area_ptr;
      IF message_info_p = NIL THEN
        osp$set_status_abnormal ('CL', cle$module_too_large, message_module_name, store_info_status);
      IFEND;
    IFEND;

    collect_template (osc$brief_help, 'CREATE_BRIEF_HELP_MESSAGE', { name = } osc$null_name, until_string_p,
          template_size, status);

    IF store_info_status.normal THEN
      message_info_p^.name := osc$null_name;
      message_info_p^.code := 0; { not used for brief help message
      message_info_p^.severity := osc$mm_informative_severity; { not used for brief help message
      message_info_p^.size := template_size;
    IFEND;

    IF NOT status.normal THEN
      RESET work_area_ptr TO message_kind_p;
    IFEND;

  PROCEND clp$_create_brief_help_message;
?? TITLE := 'clp$_create_full_help_message', EJECT ??

  PROCEDURE clp$_create_full_help_message
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$cremm_crefhm) create_full_help_message, crefhm (
{   collect_template_until, ctu: string literal = '**'
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 30, 17, 24, 27, 728],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OCM$CREMM_CREFHM'], [
    ['COLLECT_TEMPLATE_UNTIL         ',clc$nominal_entry, 1],
    ['CTU                            ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, clc$max_string_size, TRUE],
    '''**'''],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

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

    CONST
      p$collect_template_until = 1,
      p$status = 2;

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

    VAR
      message_info_p: ^message_record,
      message_kind_p: ^ost$message_template_kind,
      template_size: 0 .. osc$max_status_message,
      until_string_p: ^clt$string_value;

    status.normal := TRUE;

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

    until_string_p := pvt [p$collect_template_until].value^.string_value;

    NEXT message_kind_p IN work_area_ptr;
    IF message_kind_p = NIL THEN
      osp$set_status_abnormal ('CL', cle$module_too_large, message_module_name, store_info_status);
    ELSE
      message_kind_p^ := osc$full_help;
    IFEND;

    IF store_info_status.normal THEN
      NEXT message_info_p IN work_area_ptr;
      IF message_info_p = NIL THEN
        osp$set_status_abnormal ('CL', cle$module_too_large, message_module_name, store_info_status);
      IFEND;
    IFEND;

    collect_template (osc$full_help, 'CREATE_FULL_HELP_MESSAGE', { name = } osc$null_name, until_string_p,
          template_size, status);

    IF store_info_status.normal THEN
      message_info_p^.name := osc$null_name;
      message_info_p^.code := 0; { not used for full help message
      message_info_p^.severity := osc$mm_informative_severity; { not used for full help message
      message_info_p^.size := template_size;
    IFEND;

    IF NOT status.normal THEN
      RESET work_area_ptr TO message_kind_p;
    IFEND;

  PROCEND clp$_create_full_help_message;
?? TITLE := 'clp$_create_application_menu', EJECT ??

  PROCEDURE clp$_create_application_menu
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$cremm_cream) create_application_menu, cream (
{   name, n: name = $required
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 30, 15, 59, 50, 759],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OCM$CREMM_CREAM'], [
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

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

    CONST
      p$name = 1,
      p$status = 2;

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

    VAR
      converted_integer: ost$string,
      message_kind_p: ^ost$message_template_kind,
      number_of_classes: cst$max_classes,
      number_of_items: cst$menu_item_number;

    status.normal := TRUE;

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

*IF NOT $true(osv$unix_tools_on_ve)
    NEXT message_kind_p IN work_area_ptr;
    IF message_kind_p = NIL THEN
      osp$set_status_abnormal ('CL', cle$module_too_large, message_module_name, status);
      RETURN;
    ELSE
      message_kind_p^ := osc$application_menu;
    IFEND;

  /store_info/
    BEGIN
      clp$define_application_menu (work_area_ptr, pvt [p$name].value^.name_value, message_module_name,
            number_of_classes, number_of_items, status);
      IF NOT status.normal THEN
        EXIT /store_info/;
      IFEND;

      IF (number_of_names + 1) > osc$max_status_condition_code THEN
        clp$convert_integer_to_string (osc$max_status_condition_code, 10, FALSE, converted_integer, status);
        osp$set_status_abnormal ('CL', cle$too_many_entries_for_module, converted_integer.
              value (1, converted_integer.size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, message_module_name, status);
        EXIT /store_info/;
      ELSE
        number_of_names := number_of_names + 1;
        total_number_of_classes := total_number_of_classes + number_of_classes;
        total_number_of_items := total_number_of_items + number_of_items;
        number_of_application_menus := number_of_application_menus + 1;
        RETURN;
      IFEND;
    END /store_info/;
    RESET work_area_ptr TO message_kind_p;
*IFEND

  PROCEND clp$_create_application_menu;
?? TITLE := 'clp$_create_parameter_prompt_me', EJECT ??

  PROCEDURE clp$_create_parameter_prompt_me
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$cremm_creppm) create_parameter_prompt_message, creppm (
{   name, n: name = $required
{   collect_template_until, ctu: string literal = '**'
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (4),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 30, 17, 25, 59, 214],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'OCM$CREMM_CREPPM'], [
    ['COLLECT_TEMPLATE_UNTIL         ',clc$nominal_entry, 2],
    ['CTU                            ',clc$abbreviation_entry, 2],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 4],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [0, clc$max_string_size, TRUE],
    '''**'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

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

    CONST
      p$name = 1,
      p$collect_template_until = 2,
      p$status = 3;

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

    VAR
      message_info_p: ^message_record,
      message_kind_p: ^ost$message_template_kind,
      template_size: 0 .. osc$max_status_message,
      until_string_p: ^clt$string_value;

    status.normal := TRUE;

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

    until_string_p := pvt [p$collect_template_until].value^.string_value;

    NEXT message_kind_p IN work_area_ptr;
    IF message_kind_p = NIL THEN
      osp$set_status_abnormal ('CL', cle$module_too_large, message_module_name, store_info_status);
    ELSE
      message_kind_p^ := osc$parameter_prompt;
    IFEND;

    IF store_info_status.normal THEN
      NEXT message_info_p IN work_area_ptr;
      IF message_info_p = NIL THEN
        osp$set_status_abnormal ('CL', cle$module_too_large, message_module_name, store_info_status);
      IFEND;
    IFEND;

    collect_template (osc$parameter_prompt, 'CREATE_PARAMETER_PROMPT_MESSAGE', pvt [p$name].value^.name_value,
          until_string_p, template_size, status);

    IF store_info_status.normal THEN
      message_info_p^.name := pvt [p$name].value^.name_value;
      message_info_p^.code := 0; { not used for parameter prompt message
      message_info_p^.severity := osc$mm_informative_severity; { not used for parameter prompt message
      message_info_p^.size := template_size;
    IFEND;

    IF NOT status.normal THEN
      RESET work_area_ptr TO message_kind_p;
    IFEND;

  PROCEND clp$_create_parameter_prompt_me;
?? TITLE := 'clp$_create_parameter_assist_me', EJECT ??

  PROCEDURE clp$_create_parameter_assist_me
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$cremm_crepam) create_parameter_assist_message, crepam (
{   name, n: name = $required
{   collect_template_until, ctu: string literal = '**'
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (4),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 30, 17, 27, 3, 102],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'OCM$CREMM_CREPAM'], [
    ['COLLECT_TEMPLATE_UNTIL         ',clc$nominal_entry, 2],
    ['CTU                            ',clc$abbreviation_entry, 2],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 4],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [0, clc$max_string_size, TRUE],
    '''**'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

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

    CONST
      p$name = 1,
      p$collect_template_until = 2,
      p$status = 3;

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

    VAR
      message_info_p: ^message_record,
      message_kind_p: ^ost$message_template_kind,
      template_size: 0 .. osc$max_status_message,
      until_string_p: ^clt$string_value;

    status.normal := TRUE;

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

    until_string_p := pvt [p$collect_template_until].value^.string_value;

    NEXT message_kind_p IN work_area_ptr;
    IF message_kind_p = NIL THEN
      osp$set_status_abnormal ('CL', cle$module_too_large, message_module_name, store_info_status);
    ELSE
      message_kind_p^ := osc$parameter_assistance_prompt;
    IFEND;

    IF store_info_status.normal THEN
      NEXT message_info_p IN work_area_ptr;
      IF message_info_p = NIL THEN
        osp$set_status_abnormal ('CL', cle$module_too_large, message_module_name, store_info_status);
      IFEND;
    IFEND;

    collect_template (osc$parameter_assistance_prompt, 'CREATE_PARAMETER_ASSIST_MESSAGE',
          pvt [p$name].value^.name_value, until_string_p, template_size, status);

    IF store_info_status.normal THEN
      message_info_p^.name := pvt [p$name].value^.name_value;
      message_info_p^.code := 0; { not used for parameter assist message
      message_info_p^.severity := osc$mm_informative_severity; { not used for parameter assist message
      message_info_p^.size := template_size;
    IFEND;

    IF NOT status.normal THEN
      RESET work_area_ptr TO message_kind_p;
    IFEND;

  PROCEND clp$_create_parameter_assist_me;
?? TITLE := 'clp$_create_parameter_help_mess', EJECT ??

  PROCEDURE clp$_create_parameter_help_mess
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$cremm_crephm) create_parameter_help_message, crephm (
{   name, n: name = $required
{   collect_template_until, ctu: string literal = '**'
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (4),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 30, 17, 28, 23, 868],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'OCM$CREMM_CREPHM'], [
    ['COLLECT_TEMPLATE_UNTIL         ',clc$nominal_entry, 2],
    ['CTU                            ',clc$abbreviation_entry, 2],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 4],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [0, clc$max_string_size, TRUE],
    '''**'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

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

    CONST
      p$name = 1,
      p$collect_template_until = 2,
      p$status = 3;

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

    VAR
      message_info_p: ^message_record,
      message_kind_p: ^ost$message_template_kind,
      template_size: 0 .. osc$max_status_message,
      until_string_p: ^clt$string_value;

    status.normal := TRUE;

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

    until_string_p := pvt [p$collect_template_until].value^.string_value;

    NEXT message_kind_p IN work_area_ptr;
    IF message_kind_p = NIL THEN
      osp$set_status_abnormal ('CL', cle$module_too_large, message_module_name, store_info_status);
    ELSE
      message_kind_p^ := osc$parameter_help;
    IFEND;

    IF store_info_status.normal THEN
      NEXT message_info_p IN work_area_ptr;
      IF message_info_p = NIL THEN
        osp$set_status_abnormal ('CL', cle$module_too_large, message_module_name, store_info_status);
      IFEND;
    IFEND;

    collect_template (osc$parameter_help, 'CREATE_PARAMETER_HELP_MESSAGE', pvt [p$name].value^.name_value,
          until_string_p, template_size, status);

    IF store_info_status.normal THEN
      message_info_p^.name := pvt [p$name].value^.name_value;
      message_info_p^.code := 0; { not used for parameter help message
      message_info_p^.severity := osc$mm_informative_severity; { not used for parameter help message
      message_info_p^.size := template_size;
    IFEND;

    IF NOT status.normal THEN
      RESET work_area_ptr TO message_kind_p;
    IFEND;

  PROCEND clp$_create_parameter_help_mess;
?? TITLE := 'clp$_quit', EJECT ??

  PROCEDURE clp$_quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$cremm_endmm) end_message_module, endmm (
{   create_module, cm: boolean = YES
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 30, 16, 12, 49, 385],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OCM$CREMM_ENDMM'], [
    ['CM                             ',clc$abbreviation_entry, 1],
    ['CREATE_MODULE                  ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type],
    'YES'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

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

    CONST
      p$create_module = 1,
      p$status = 2;

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

    VAR
      value: clt$value;

    status.normal := TRUE;

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

    create_module := pvt [p$create_module].value^.boolean_value.value;

    clp$end_include (utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND clp$_quit;
?? TITLE := 'clp$define_message_module', EJECT ??

  PROCEDURE [XDCL] clp$define_message_module
*IF NOT $true(osv$unix_tools_on_ve)
    (    module_name: pmt$program_name;
         natural_language: ost$natural_language;
         online_manual_name: ost$online_manual_name;
         work_area: ^SEQ ( * );
     VAR message_module: ^ost$message_template_module;
     VAR status: ost$status);
*ELSE
    (VAR status: ost$status);
*IFEND

?? NEWTITLE := 'sort_condition_codes', EJECT ??

    PROCEDURE sort_condition_codes
      (    codes: ^ost$mtm_condition_codes);

      VAR
        converted_integer: ost$string,
        code_string: ost$string,
        current: integer,
        gap: integer,
        message_status: ost$status,
        ignore_status: ost$status,
        index: ost$message_template_index,
        start: ost$message_template_index,
        last_duplicate: integer,
        swap: ost$mtm_condition_code;

      gap := UPPERBOUND (codes^) + 1;
      WHILE gap > 1 DO
        gap := 2 * (gap DIV 4) + 1;
        FOR start := 0 TO UPPERBOUND (codes^) - gap DO
          current := start;
          WHILE (current > LOWERBOUND (codes^) - 1) AND (codes^ [current].code > codes^ [current + gap].
                code) DO
            swap := codes^ [current];
            codes^ [current] := codes^ [current + gap];
            codes^ [current + gap] := swap;
            current := current - gap;
          WHILEND;
        FOREND;
      WHILEND;

      last_duplicate := -1;

    /find_duplicates/
      FOR index := 1 TO UPPERBOUND (codes^) DO
        IF codes^ [index].code = codes^ [index - 1].code THEN
          IF codes^ [index].code <> last_duplicate THEN
            osp$get_status_condition_string (codes^ [index].code, code_string, ignore_status);
            osp$set_status_abnormal ('CL', cle$duplicate_condition_codes, code_string.
                  value (1, code_string.size), message_status);
            osp$append_status_parameter (osc$status_parameter_delimiter, message_module_name, message_status);
*IF NOT $true(osv$unix_tools_on_ve)
            ocp$generate_message (message_status);
*IFEND
            module_has_errors := TRUE;
            last_duplicate := codes^ [index].code;
          IFEND;
        IFEND;
      FOREND /find_duplicates/;

    PROCEND sort_condition_codes;
?? TITLE := 'sort_condition_names', EJECT ??

    PROCEDURE sort_condition_names
      (    names: ^ost$mtm_condition_names;
           codes: ^ost$mtm_condition_codes);

      VAR
        message_kinds: [READ] array [ost$message_template_kind] of record
          size: 21 .. 35,
          value: string (35),
        recend := [[21, 'CREATE_STATUS_MESSAGE'], [25, 'CREATE_BRIEF_HELP_MESSAGE'], [24,
              'CREATE_FULL_HELP_MESSAGE'], [23, 'CREATE_APPLICATION_MENU'], [31,
              'CREATE_PARAMETER_PROMPT_MESSAGE'], [35, 'CREATE_PARAMETER_ASSISTANCE_MESSAGE'], [29,
              'CREATE_PARAMETER_HELP_MESSAGE']];

      VAR
        current: integer,
        gap: integer,
        index: ost$message_template_index,
        message_status: ost$status,
        start: ost$message_template_index,
        last_duplicate: ost$mtm_condition_name,
        swap: ost$mtm_condition_name;

      gap := UPPERBOUND (names^) + 1;
      WHILE gap > 1 DO
        gap := 2 * (gap DIV 4) + 1;
        FOR start := 0 TO UPPERBOUND (names^) - gap DO
          current := start;
          WHILE (current > LOWERBOUND (names^) - 1) AND (names^ [current].name >= names^ [current + gap].
                name) DO
            IF (names^ [current].name > names^ [current + gap].name) OR
                  (names^ [current].kind > names^ [current + gap].kind) THEN
              swap := names^ [current];
              names^ [current] := names^ [current + gap];
              names^ [current + gap] := swap;
              IF codes <> NIL THEN
                FOR index := 0 TO UPPERBOUND (codes^) DO
                  IF codes^ [index].code = names^ [current].code THEN
                    codes^ [index].name_index := current;
                  ELSEIF codes^ [index].code = names^ [current + gap].code THEN
                    codes^ [index].name_index := current + gap;
                  IFEND;
                FOREND;
              IFEND;
            IFEND;
            current := current - gap;
          WHILEND;
        FOREND;
      WHILEND;

      last_duplicate.name := '?';

    /find_duplicates/
      FOR index := 1 TO UPPERBOUND (names^) DO
        IF (names^ [index].name = names^ [index - 1].name) AND (names^ [index].kind = names^ [index - 1].kind)
              THEN
          IF (names^ [index].name <> last_duplicate.name) OR (names^ [index].kind <> last_duplicate.kind) THEN

          /form_error_message/
            BEGIN
              CASE names^ [index].kind OF
              = osc$status_message, osc$application_menu, osc$parameter_prompt,
                    osc$parameter_assistance_prompt, osc$parameter_help =
                osp$set_status_abnormal ('CL', cle$duplicate_names, message_kinds [names^ [index].kind].value,
                      message_status);
              = osc$brief_help, osc$full_help =
                osp$set_status_abnormal ('CL', cle$duplicate_help_messages,
                      message_kinds [names^ [index].kind].value, message_status);
                EXIT /form_error_message/;
              ELSE
                osp$set_status_abnormal ('CL', cle$duplicate_names, 'UNKNOWN_MESSAGE_KIND', message_status);
              CASEND;
              osp$append_status_parameter (osc$status_parameter_delimiter, names^ [index].name,
                    message_status);
            END /form_error_message/;
            osp$append_status_parameter (osc$status_parameter_delimiter, message_module_name, message_status);
*IF NOT $true(osv$unix_tools_on_ve)
            ocp$generate_message (message_status);
*IFEND
            module_has_errors := TRUE;
            last_duplicate := names^ [index];
          IFEND;
        IFEND;
      FOREND /find_duplicates/;

    PROCEND sort_condition_names;
?? TITLE := 'generate_message_module', EJECT ??

    PROCEDURE generate_message_module
      (VAR status: ost$status);

      VAR
        codes_pointer: ^ost$mtm_condition_codes,
        names_pointer: ^ost$mtm_condition_names,
        template_pointer: ^ost$message_template,
        index: ost$message_template_index,
        j: ost$message_template_index,
        code_index: ost$message_template_index,
        local_status: ost$status,
        menu_classes: cst$menu_class,
        menu_header: ^ost$mtm_menu_header,
        menu_items: cst$menu_list,
        retrieved_classes: ^array [1 .. * ] of record
          name: cst$class_name,
          number_of_items: 0 .. csc$max_items_per_class,
        recend,
        retrieved_items: cst$menu_list,
        retrieved_kind: ^ost$message_template_kind,
        retrieved_menu_info: ^menu_record,
        retrieved_message_info: ^message_record,
        retrieved_template: ^ost$message_template,
        header: ost$mtm_header;

      status.normal := TRUE;
      code_index := 0;

      IF number_of_names = 0 THEN
        osp$set_status_abnormal ('CL', cle$no_module_created, message_module_name, status);
        RETURN;
      IFEND;

      header.version := llc$object_library_version;
      header.language := natural_language;
      header.online_manual_name := online_manual_name;
      header.number_of_codes := number_of_codes;
      header.number_of_names := number_of_names;

      module_size := #SIZE (ost$mtm_header) + number_of_codes *
            #SIZE (ost$mtm_condition_code) + number_of_names *
            #SIZE (ost$mtm_condition_name) + total_template_size + number_of_application_menus *
            #SIZE (ost$mtm_menu_header) + total_number_of_classes *
            #SIZE (cst$class_name) + total_number_of_items * #SIZE (cst$menu_item);
      NEXT result_module: [[REP module_size OF cell]] IN work_area_ptr;
      IF result_module = NIL THEN
        osp$set_status_abnormal ('CL', cle$module_too_large, message_module_name, status);
        RETURN;
      IFEND;
      RESET result_module;
      RESET work_area_ptr;
      NEXT header_pointer IN result_module;
      header_pointer^ := header;

      IF number_of_codes > 0 THEN
        NEXT codes_pointer: [0 .. number_of_codes - 1] IN result_module;
      ELSE
        codes_pointer := NIL;
      IFEND;

      NEXT names_pointer: [0 .. number_of_names - 1] IN result_module;

      FOR index := 0 TO number_of_names - 1 DO
        NEXT retrieved_kind IN work_area_ptr;
        names_pointer^ [index].kind := retrieved_kind^;
        IF retrieved_kind^ = osc$application_menu THEN
          NEXT retrieved_menu_info IN work_area_ptr;
          NEXT menu_header IN result_module;
          menu_header^.number_of_classes := retrieved_menu_info^.number_of_classes;
          menu_header^.number_of_menu_items := retrieved_menu_info^.number_of_items;
          NEXT retrieved_classes: [1 .. csc$max_classes] IN work_area_ptr;
          NEXT retrieved_items: [1 .. retrieved_menu_info^.number_of_items] IN work_area_ptr;
          NEXT menu_classes: [1 .. retrieved_menu_info^.number_of_classes] IN result_module;
          NEXT menu_items: [1 .. retrieved_menu_info^.number_of_items] IN result_module;
          FOR j := 1 TO retrieved_menu_info^.number_of_classes DO
            menu_classes^ [j] := retrieved_classes^ [j].name;
          FOREND;
          menu_items^ := retrieved_items^;
          names_pointer^ [index].name := retrieved_menu_info^.name;
          names_pointer^ [index].menu_header := #REL (menu_header, result_module^);
        ELSE
          NEXT retrieved_message_info IN work_area_ptr;
          NEXT retrieved_template: [retrieved_message_info^.size] IN work_area_ptr;
          NEXT template_pointer: [retrieved_message_info^.size] IN result_module;
          IF names_pointer^ [index].kind = osc$status_message THEN
            codes_pointer^ [code_index].code := retrieved_message_info^.code;
            codes_pointer^ [code_index].name_index := index;
            code_index := code_index + 1;
          IFEND;
          names_pointer^ [index].name := retrieved_message_info^.name;
          names_pointer^ [index].template := #REL (template_pointer, result_module^);
          IF names_pointer^ [index].kind = osc$status_message THEN
            names_pointer^ [index].code := retrieved_message_info^.code;
            names_pointer^ [index].severity := retrieved_message_info^.severity;
          IFEND;
          template_pointer^ := retrieved_template^;
        IFEND;
      FOREND;

      IF number_of_codes > 0 THEN
        sort_condition_codes (codes_pointer);
      IFEND;
      sort_condition_names (names_pointer, codes_pointer);

    PROCEND generate_message_module;
?? OLDTITLE, EJECT ??

{ table command_table sn=oss$job_paged_literal
{ command (create_status_message,cresm) p=clp$_create_status_message cm=local
{ command (create_brief_help_message,crebhm) ..
{   p=clp$_create_brief_help_message cm=local
{ command (create_full_help_message,crefhm) ..
{   p=clp$_create_full_help_message cm=local
{ command (create_application_menu,cream) p=clp$_create_application_menu ..
{   cm=local
{ command (create_parameter_prompt_message,creppm) ..
{   p=clp$_create_parameter_prompt_me cm=local
{ command (create_parameter_assist_message,crepam) ..
{   p=clp$_create_parameter_assist_me cm=local
{ command (create_parameter_help_message,crephm) ..
{   p=clp$_create_parameter_help_mess cm=local
{ command (end_message_module,quit,qui,endmm) p=clp$_quit cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  command_table: [STATIC, READ, oss$job_paged_literal]
      ^clt$command_table := ^command_table_entries,

  command_table_entries: [STATIC, READ, oss$job_paged_literal] array [1
      .. 18] of clt$command_table_entry := [
  {} ['CREAM                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^clp$_create_application_menu],
  {} ['CREATE_APPLICATION_MENU        ', clc$nominal_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^clp$_create_application_menu],
  {} ['CREATE_BRIEF_HELP_MESSAGE      ', clc$nominal_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^clp$_create_brief_help_message],
  {} ['CREATE_FULL_HELP_MESSAGE       ', clc$nominal_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^clp$_create_full_help_message],
  {} ['CREATE_PARAMETER_ASSIST_MESSAGE', clc$nominal_entry,
        clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
        ^clp$_create_parameter_assist_me],
  {} ['CREATE_PARAMETER_HELP_MESSAGE  ', clc$nominal_entry,
        clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
        ^clp$_create_parameter_help_mess],
  {} ['CREATE_PARAMETER_PROMPT_MESSAGE', clc$nominal_entry,
        clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
        ^clp$_create_parameter_prompt_me],
  {} ['CREATE_STATUS_MESSAGE          ', clc$nominal_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^clp$_create_status_message],
  {} ['CREBHM                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^clp$_create_brief_help_message],
  {} ['CREFHM                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^clp$_create_full_help_message],
  {} ['CREPAM                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
        ^clp$_create_parameter_assist_me],
  {} ['CREPHM                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
        ^clp$_create_parameter_help_mess],
  {} ['CREPPM                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
        ^clp$_create_parameter_prompt_me],
  {} ['CRESM                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^clp$_create_status_message],
  {} ['ENDMM                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 8, clc$automatically_log, clc$linked_call,
        ^clp$_quit],
  {} ['END_MESSAGE_MODULE             ', clc$nominal_entry,
        clc$normal_usage_entry, 8, clc$automatically_log, clc$linked_call,
        ^clp$_quit],
  {} ['QUI                            ', clc$alias_entry,
        clc$normal_usage_entry, 8, clc$automatically_log, clc$linked_call,
        ^clp$_quit],
  {} ['QUIT                           ', clc$alias_entry,
        clc$normal_usage_entry, 8, clc$automatically_log, clc$linked_call,
        ^clp$_quit]];

?? POP ??

    VAR
*IF $true(osv$unix_tools_on_ve)
      module_name: pmt$program_name,
      natural_language: ost$natural_language,
      online_manual_name: ost$online_manual_name,
      work_area: ^SEQ ( * ),
      message_module: ^ost$message_template_module,
*IFEND
      header_pointer: ^ost$mtm_header,
      module_size: ost$segment_length,
      result_module: ^ost$message_template_module,
      seq_position: ost$segment_length,
      utility_attributes: array [1 .. 3] of clt$utility_attribute;

*IF $true(osv$unix_tools_on_ve)
    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      default_creation_attributes: array [1 .. 2] of fst$file_cycle_attribute,
      file_id: amt$file_identifier,
      validation_attributes: array [1 .. 4] of fst$file_cycle_attribute;
*IFEND


    status.normal := TRUE;
    store_info_status.normal := TRUE;
*IF $true(osv$unix_tools_on_ve)
    module_name := osc$null_name;
    natural_language := osc$us_english;
    online_manual_name := osc$null_name;
    ALLOCATE work_area: [[REP 1000000(16) OF cell]];
    RESET work_area;
*IFEND

    IF in_create_message_module THEN
      osp$set_status_abnormal ('CL', cle$no_nested_message_modules, message_module_name, status);
      RETURN;
    ELSE
      in_create_message_module := TRUE;
    IFEND;

    number_of_application_menus := 0;
    number_of_codes := 0;
    number_of_names := 0;
    total_number_of_classes := 0;
    total_number_of_items := 0;
    total_template_size := 0;
    module_has_errors := FALSE;
    work_area_ptr := work_area;
    RESET work_area_ptr;
    message_module := NIL;
    message_module_name := module_name;

    utility_attributes [1].key := clc$utility_command_search_mode;
    utility_attributes [1].command_search_mode := clc$global_command_search;
    utility_attributes [2].key := clc$utility_command_table;
    utility_attributes [2].command_table := command_table;
    utility_attributes [3].key := clc$utility_prompt;
    utility_attributes [3].prompt.value := prompt_string;
    utility_attributes [3].prompt.size := prompt_string_size;

  /create_message_module/
    BEGIN

      clp$begin_utility (utility_name, utility_attributes, status);
      IF NOT status.normal THEN
        EXIT /create_message_module/;
      IFEND;

      clp$include_file (clc$current_command_input, prompt_string, utility_name, status);
      IF NOT status.normal THEN
        EXIT /create_message_module/;
      ELSEIF status.normal AND (NOT store_info_status.normal) THEN
        status := store_info_status;
        EXIT /create_message_module/;
      IFEND;

      clp$end_utility (utility_name, status);
      IF NOT status.normal THEN
        EXIT /create_message_module/;
      IFEND;

      IF create_module THEN
        generate_message_module (status);
        IF NOT status.normal THEN
          EXIT /create_message_module/;
        IFEND;

        RESET result_module TO header_pointer;
        NEXT message_module: [[REP module_size OF cell]] IN result_module;
        RESET message_module;

        IF module_has_errors THEN
          osp$set_status_abnormal ('CL', cle$errors_in_module, message_module_name, status);
          EXIT /create_message_module/;
        IFEND;
      IFEND;
    END /create_message_module/;

    in_create_message_module := FALSE;

*IF $true(osv$unix_tools_on_ve)
    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
    attachment_options [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options [1].share_modes.value := $fst$file_access_options [];
    attachment_options [2].selector := fsc$access_and_share_modes;
    attachment_options [2].access_modes.selector := fsc$specific_access_modes;
    attachment_options [2].access_modes.value := $fst$file_access_options [fsc$append];
    attachment_options [2].share_modes.selector := fsc$specific_share_modes;
    attachment_options [2].share_modes.value := $fst$file_access_options [];
    attachment_options [3].selector := fsc$open_share_modes;
    attachment_options [3].open_share_modes := -$fst$file_access_options [];
    validation_attributes [1].selector := fsc$file_contents_and_processor;
    validation_attributes [1].file_contents := fsc$legible_data;
    validation_attributes [1].file_processor := osc$null_name;
    validation_attributes [2].selector := fsc$file_contents_and_processor;
    validation_attributes [2].file_contents := amc$legible;
    validation_attributes [2].file_processor := osc$null_name;
    validation_attributes [3].selector := fsc$file_contents_and_processor;
    validation_attributes [3].file_contents := fsc$data;
    validation_attributes [3].file_processor := osc$null_name;
    validation_attributes [4].selector := fsc$file_contents_and_processor;
    validation_attributes [4].file_contents := fsc$unknown_contents;
    validation_attributes [4].file_processor := osc$null_name;
    default_creation_attributes [1].selector := fsc$file_contents_and_processor;
    default_creation_attributes [1].file_contents := fsc$legible_data;
    default_creation_attributes [1].file_processor := osc$null_name;
    default_creation_attributes [2].selector := fsc$page_format;
    default_creation_attributes [2].page_format := amc$untitled_form;
    fsp$open_file ('$wc.message_template_module', amc$record, ^attachment_options,
          ^default_creation_attributes, NIL, ^validation_attributes, NIL, file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    clp$extract_message_module (file_id, module_name, message_module, status);

    fsp$close_file (file_id, status);
*IFEND

  PROCEND clp$define_message_module;

MODEND clm$define_message_module;
*DECK DECK=CLM$DEFINE_SCL_PROCEDURE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Define SCL Procedure for Object Library' ??
MODULE clm$define_scl_procedure;

{
{ PURPOSE:
{   This module contains the procedure that prepares an SCL Procedure for
{   addition to or replacement on object library.  It is part of the object
{   library generator utility.
{
{ NOTE:
{   A small amount of "compilation" is performed during this process.  This
{   "compilation" consists of capturing the "generated" form of the procedure's
{   parameter description table (PDT) and saving the lexical information for
{   each line of the procedure.
{   For "old style" PROCs, the PDT is translated prior to capturing it.
{

?? NEWTITLE := 'Global Declarations' ??
?? NEWTITLE := 'clt$scl_procedure and clt$input_data', EJECT ??
*copyc clt$scl_procedure
*copyc clt$scl_procedure_header
*copyc clt$input_data
*copyc clt$input_data_line_header
?? OLDTITLE, EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc clc$max_proc_names
*copyc clc$proc_pdt_parameter_limits
*copyc cle$ecc_control_statement
*copyc cle$expecting_proc
*copyc clt$command_log_option
*copyc clt$command_or_function
*copyc clt$named_entry_availability
*copyc llt$command_kind
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*copyc clp$append_status_parse_state
*copyc clp$convert_pdt
*copyc clp$get_collect_text_cmnd_info
*copyc clp$get_variable
*copyc clp$get_work_area
*copyc clp$internal_evaluate_sub_param
*copyc clp$internal_generate_old_pdt
*copyc clp$internal_generate_pdt
*copyc clp$parse_command
*copyc clp$pop_parameters
*copyc clp$push_parameters
*copyc clp$scan_any_lexical_unit
*copyc clp$scan_non_space_lexical_unit
*copyc clp$scan_unnested_cmnd_lex_unit
*copyc clp$trimmed_string_size
*copyc i#current_sequence_position
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc osv$upper_to_lower

?? TITLE := 'clp$define_scl_procedure', EJECT ??
*copyc clh$define_scl_procedure

  PROCEDURE [XDCL] clp$define_scl_procedure
    (    file_id: amt$file_identifier;
         work_area: ^SEQ ( * );
     VAR procedure_name: pmt$program_name;
     VAR aliases: ^array [1 .. * ] of pmt$program_name;
     VAR command_or_function: clt$command_or_function;
     VAR availability: clt$named_entry_availability;
     VAR command_kind: llt$command_kind;
     VAR command_log_option: clt$command_log_option;
     VAR scl_procedure: ^clt$scl_procedure;
     VAR file_position: amt$file_position;
     VAR status: ost$status);

    CONST
      definition_version_variable = 'OCV$SCL_PROCEDURE_VERSION',
      procedure_file_name = 'file_of_scl_procedures         ';

    VAR
      definition_version: [STATIC] clt$declaration_version := clc$declaration_version,
      definition_version_determined: [STATIC] boolean := FALSE;

    VAR
      command_line_header: ^clt$input_data_line_header,
      end_of_input: boolean,
      entire_procedure: ^clt$input_data,
      header: ^clt$scl_procedure_header,
      header_word: ost$name,
      header_word_size: ost$name_size,
      ignore_status: ^ost$status,
      initial_line_for_echoing: ^clt$command_line,
      last_component_line_header: ^clt$input_data_line_header,
      name: ost$name,
      original_work_area_2: ^clt$work_area,
      parse: clt$parse_state,
      parameter_description_table: ^clt$parameter_description_table,
      pdt: ^clt$parameter_description_table,
      procedure_body: ^clt$input_data,
      procedure_body_size: ost$segment_length,
      procedure_declaration: ^clt$input_data,
      procedure_declaration_size: ost$segment_length,
      saved_procedure_declaration: ^clt$input_data,
      scl_procedure_size: ost$segment_length,
      terminator_name: ost$name,
      work_area_1: ^clt$work_area,
      work_area_2: ^^clt$work_area;

?? NEWTITLE := 'capture_command_line', EJECT ??

    PROCEDURE capture_command_line
      (    line: ^clt$command_line;
           lexical_units: ^clt$lexical_units);

      VAR
        command_line: ^clt$command_line,
        command_lexical_units: ^clt$lexical_units,
        component_lines: ^clt$input_data,
        saved_component_lines: ^clt$input_data,
        size_of_component_lines_data: ost$segment_length;


      IF definition_version = 0 THEN
        RETURN;
      IFEND;

      IF last_component_line_header = command_line_header THEN
        command_line_header^.number_of_lexical_units := UPPERBOUND (lexical_units^);
        NEXT command_lexical_units: [1 .. command_line_header^.number_of_lexical_units] IN work_area_1;
        command_lexical_units^ := lexical_units^;

        command_line_header := NIL;
        RETURN;
      IFEND;

      size_of_component_lines_data := i#current_sequence_position (work_area_1);
      RESET work_area_1 TO command_line_header;
      size_of_component_lines_data := size_of_component_lines_data -
            i#current_sequence_position (work_area_1);
      NEXT component_lines: [[REP size_of_component_lines_data OF cell]] IN work_area_1;
      PUSH saved_component_lines: [[REP size_of_component_lines_data OF cell]];
      saved_component_lines^ := component_lines^;

      RESET work_area_1 TO component_lines;
      NEXT command_line_header IN work_area_1;
      command_line_header^.line_size := STRLENGTH (line^);
      command_line_header^.number_of_lexical_units := UPPERBOUND (lexical_units^);
      command_line_header^.size_of_component_lines_data := size_of_component_lines_data;
      NEXT command_line: [command_line_header^.line_size] IN work_area_1;
      command_line^ := line^;
      NEXT command_lexical_units: [1 .. command_line_header^.number_of_lexical_units] IN work_area_1;
      command_lexical_units^ := lexical_units^;
      NEXT component_lines: [[REP size_of_component_lines_data OF cell]] IN work_area_1;
      component_lines^ := saved_component_lines^;

      command_line_header := NIL;

    PROCEND capture_command_line;
?? TITLE := 'capture_data_line', EJECT ??

    PROCEDURE capture_data_line
      (    line: ^clt$command_line);

      VAR
        last_component_line: ^clt$command_line,
        line_size: ^clt$command_line_size;


      IF definition_version = 0 THEN
        NEXT line_size IN work_area_1;
        line_size^ := STRLENGTH (line^);
        NEXT last_component_line: [line_size^] IN work_area_1;
        last_component_line^ := line^;

      ELSE
        NEXT last_component_line_header IN work_area_1;
        last_component_line_header^.line_size := STRLENGTH (line^);
        last_component_line_header^.number_of_lexical_units := 0;
        last_component_line_header^.size_of_component_lines_data := 0;
        NEXT last_component_line: [last_component_line_header^.line_size] IN work_area_1;
        last_component_line^ := line^;

        IF command_line_header = NIL THEN
          command_line_header := last_component_line_header;
        IFEND;
      IFEND;

    PROCEND capture_data_line;
?? TITLE := 'define_old_proc_header', EJECT ??

    PROCEDURE define_old_proc_header;

      VAR
        alias_index: 1 .. clc$max_proc_names - 1,
        extra_info_area: ^SEQ (REP clc$proc_pdt_info_area_size of cell),
        old_pdt: clt$parameter_descriptor_table,
        parameter_area: ^SEQ (REP clc$max_proc_pdt_parameters of clt$parameter_descriptor),
        parameter_name_area: ^SEQ (REP clc$max_proc_pdt_param_names of clt$parameter_name_descriptor),
        proc_name_area: ^SEQ (REP clc$max_proc_names of ost$name),
        proc_names: ^clt$proc_names,
        symbolic_parameter_area: ^SEQ (REP clc$max_proc_pdt_parameters of clt$symbolic_parameter),
        symbolic_parameters: ^clt$symbolic_parameters;


      PUSH proc_name_area;
      PUSH parameter_name_area;
      PUSH parameter_area;
      PUSH symbolic_parameter_area;
      PUSH extra_info_area;

      clp$internal_generate_old_pdt ('PROC', ^clp$input_procedure, work_area_2^, parse, proc_name_area^,
            parameter_name_area^, parameter_area^, symbolic_parameter_area^, extra_info_area^, proc_names,
            old_pdt, symbolic_parameters, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      command_or_function := clc$command;
      availability := clc$advertised_entry;
      command_kind := llc$entry_point;
      command_log_option := clc$automatically_log;

      procedure_name := proc_names^ [1];
      IF UPPERBOUND (proc_names^) > 1 THEN
        NEXT aliases: [1 .. UPPERBOUND (proc_names^) - 1] IN work_area_2^;
        FOR alias_index := 1 TO UPPERBOUND (aliases^) DO
          aliases^ [alias_index] := proc_names^ [alias_index + 1];
        FOREND;
      ELSE
        aliases := NIL;
      IFEND;

      clp$convert_pdt (old_pdt, work_area_2^, pdt, status);

    PROCEND define_old_proc_header;
?? TITLE := 'define_procedure_header', EJECT ??

    PROCEDURE define_procedure_header;

      VAR
        command_or_function_scope: clt$command_or_function_scope;


      clp$scan_non_space_lexical_unit (parse);

      clp$internal_generate_pdt (command_or_function, ^clp$input_procedure, NIL, work_area_2^, parse,
            procedure_name, aliases, availability, command_or_function_scope, command_log_option, pdt,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE command_or_function_scope OF
      = clc$local_command_or_function =
        command_kind := llc$local_to_library;
      = clc$gate_command_or_function =
        command_kind := llc$gate;
      ELSE {clc$xdcl_command_or_function
        command_kind := llc$entry_point;
      CASEND;

    PROCEND define_procedure_header;
?? TITLE := 'determine_definition_version', EJECT ??

    PROCEDURE determine_definition_version;

      VAR
        ignore_access_mode: clt$data_access_mode,
        ignore_class: clt$variable_class,
        ignore_evaluation_method: clt$expression_eval_method,
        ignore_type_specification: ^clt$type_specification,
        value: ^clt$data_value;


      clp$get_variable (definition_version_variable, work_area_2^, ignore_class, ignore_access_mode,
            ignore_evaluation_method, ignore_type_specification, value, status);

      IF NOT status.normal THEN
        status.normal := TRUE;
      ELSEIF (value <> NIL) AND (value^.kind = clc$integer) AND (0 <= value^.integer_value.value) AND
            (value^.integer_value.value <= clc$declaration_version) THEN
        definition_version := value^.integer_value.value;
      IFEND;

    PROCEND determine_definition_version;
?? TITLE := 'read_proc_body', EJECT ??

    PROCEDURE read_proc_body;

      VAR
        collect_text_info: clt$collect_text_command_info,
        collect_text_pvt: ^clt$parameter_value_table,
        command_name: clt$name,
        command_parse: clt$parse_state,
        empty_command: boolean,
        form: clt$command_reference_form,
        ignore_command_ref_parse: clt$parse_state,
        ignore_escaped: boolean,
        ignore_file: clt$file,
        ignore_label: ost$name,
        ignore_prompting_requested: boolean,
        ignore_util_command_list_entry: ^clt$command_list_entry,
        line_size: clt$command_line_size,
        separator: clt$lexical_unit_kind,
        until_string: ^clt$command_line;


      collect_text_pvt := NIL;
      until_string := NIL;

      parse.unit.kind := clc$lex_end_of_line;
      WHILE TRUE DO
        IF parse.unit.kind = clc$lex_end_of_line THEN

          IF until_string <> NIL THEN
            REPEAT
              clp$ip_get_data_line (clv$ip.line^, line_size, end_of_input, status);
              IF NOT status.normal THEN
                RETURN;
              ELSEIF end_of_input THEN
                osp$set_status_abnormal ('CL', cle$unbalanced_block_structure, 'end_of_input', status);
                osp$append_status_parameter (osc$status_parameter_delimiter, until_string^, status);
                RETURN;
              IFEND;
            UNTIL clv$ip.line^ (1, line_size) = until_string^;
            until_string := NIL;
          IFEND;

          clp$input_procedure (parse, end_of_input, status);
          IF (NOT status.normal) OR end_of_input THEN
            RETURN;
          IFEND;
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

        command_parse := parse;
        clp$scan_unnested_cmnd_lex_unit (parse);
        command_parse.index_limit := parse.unit_index;
        IF parse.unit.kind = clc$lex_semicolon THEN
          clp$scan_any_lexical_unit (parse);
        IFEND;

        clp$parse_command (command_parse, ignore_prompting_requested, ignore_escaped, ignore_label,
              ignore_command_ref_parse, ignore_file, form, command_name, ignore_util_command_list_entry,
              separator, empty_command, status);

        IF status.normal AND (NOT empty_command) AND (form = clc$name_only_command_ref) AND
              (separator <> clc$lex_equal) THEN

          IF command_name.value = terminator_name THEN
            CASE separator OF
            = clc$lex_end_of_line =
              RETURN;
            = clc$lex_semicolon   =
              IF parse.unit_is_space THEN
                clp$scan_non_space_lexical_unit (parse);
              IFEND;
              IF parse.unit.kind <> clc$lex_end_of_line THEN
                osp$set_status_abnormal ('CL', cle$unexpected_after_procend, '', status);
                clp$append_status_parse_state ( osc$status_parameter_delimiter, parse, status);
                osp$append_status_parameter (osc$status_parameter_delimiter, terminator_name, status);
              IFEND;
              RETURN;
            = clc$lex_space =
              IF command_parse.unit.kind <> clc$lex_name THEN
                osp$set_status_abnormal ('CL', cle$expecting_label, '', status);
                clp$append_status_parse_state ( osc$status_parameter_delimiter, command_parse, status);
                osp$append_status_parameter (osc$status_parameter_delimiter, terminator_name, status);
                RETURN;
              IFEND;
              #TRANSLATE (osv$lower_to_upper, command_parse.text^
                    (command_parse.unit_index, command_parse.unit.size), name);
              IF name <> procedure_name THEN
                osp$set_status_abnormal ('CL', cle$wrong_statement_label, terminator_name, status);
                RETURN;
              IFEND;
              clp$scan_non_space_lexical_unit (command_parse);
              CASE command_parse.unit.kind OF
              = clc$lex_end_of_line =
                RETURN;
              = clc$lex_semicolon =
                IF parse.unit_is_space THEN
                  clp$scan_non_space_lexical_unit (parse);
                IFEND;
                IF parse.unit.kind <> clc$lex_end_of_line THEN
                  osp$set_status_abnormal ('CL', cle$unexpected_after_end_label, '', status);
                  clp$append_status_parse_state ( osc$status_parameter_delimiter, parse, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, terminator_name, status);
                IFEND;
              ELSE
                osp$set_status_abnormal ('CL', cle$unexpected_after_end_label, '', status);
                clp$append_status_parse_state ( osc$status_parameter_delimiter, command_parse, status);
                osp$append_status_parameter (osc$status_parameter_delimiter, terminator_name, status);
              CASEND;
              RETURN;
            ELSE
              osp$set_status_abnormal ('CL', cle$unexpected_after_procend, '', status);
              clp$append_status_parse_state ( osc$status_parameter_delimiter, command_parse, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, terminator_name, status);
              RETURN;
            CASEND;

          ELSEIF (command_name.value = 'COLLECT_TEXT') OR (command_name.value = 'COLT') THEN
            IF collect_text_pvt = NIL THEN
              clp$get_collect_text_cmnd_info (collect_text_info);
              PUSH collect_text_pvt: [1 .. collect_text_info.number_of_parameters];
            IFEND;
            clp$internal_evaluate_sub_param (command_parse, collect_text_info.pdt, work_area_2^,
                  collect_text_pvt, status);
            IF NOT collect_text_pvt^ [collect_text_info.input_parameter_number].specified THEN
{
{ An input parameter was not specified.
{
              IF collect_text_pvt^ [collect_text_info.until_parameter_number].specified THEN
                IF collect_text_pvt^ [collect_text_info.until_parameter_number].value <> NIL THEN
{
{ An until string was specified and could be evaluated.
{
                  PUSH until_string: [STRLENGTH (collect_text_pvt^ [collect_text_info.until_parameter_number].
                        value^.string_value^)];
                  until_string^ := collect_text_pvt^ [collect_text_info.until_parameter_number].value^.
                        string_value^;
                ELSE
{
{ An until string was specified but could NOT be evaluated.
{ Return with bad status.
{
                  RETURN;
                IFEND;
              ELSE
{
{ An until string was not specified.  The default is assumed.
{
                until_string := collect_text_info.default_until_string;
              IFEND;
            IFEND;
          IFEND;

        IFEND;
      WHILEND;

    PROCEND read_proc_body;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    scl_procedure := NIL;

    work_area_1 := work_area;

    clp$get_work_area (#RING (^work_area_2), work_area_2, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    original_work_area_2 := work_area_2^;

    IF NOT definition_version_determined THEN
      determine_definition_version;
      definition_version_determined := TRUE;
      work_area_2^ := original_work_area_2;
    IFEND;

    clp$ip_initialize (procedure_file_name, file_id, ^file_position, ^capture_command_line,
          ^capture_data_line, work_area_2^, status);

{ Push a sub-parameters block in order to prevent parameter prompting from being
{ activated for functions during the reading of the procedure.
{ Ensure that a corresponding "pop" of the sub-parameters block occurs prior to
{ returning to this routine's caller.

    clp$push_parameters (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /define_scl_procedure/
    BEGIN
      REPEAT
        RESET work_area_1;
        command_line_header := NIL;
        clp$input_procedure (parse, end_of_input, status);
        IF NOT status.normal THEN
          EXIT /define_scl_procedure/;
        ELSEIF end_of_input THEN
          osp$set_status_abnormal ('CL', cle$expecting_proc, 'PROCEDURE / PROC / FUNCTION', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'end of input', status);
          EXIT /define_scl_procedure/;
        IFEND;
        clp$scan_non_space_lexical_unit (parse);
      UNTIL parse.unit.kind <> clc$lex_end_of_line;

      IF parse.unit.kind = clc$lex_name THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        header_word := name;
        header_word_size := parse.unit.size;
        IF name = 'PROC' THEN
          terminator_name := 'PROCEND';
          define_old_proc_header;
        ELSEIF definition_version = 0 THEN
          osp$set_status_abnormal ('CL', cle$expecting_proc, 'PROC', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
          EXIT /define_scl_procedure/;
        ELSE
          IF name = 'PROCEDURE' THEN
            terminator_name := 'PROCEND';
            command_or_function := clc$command;
          ELSEIF name = 'FUNCTION' THEN
            terminator_name := 'FUNCEND';
            command_or_function := clc$function;
          ELSE
            osp$set_status_abnormal ('CL', cle$expecting_proc, 'PROCEDURE / PROC / FUNCTION', status);
            osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
            EXIT /define_scl_procedure/;
          IFEND;
          define_procedure_header;
        IFEND;
        IF NOT status.normal THEN
          EXIT /define_scl_procedure/;
        IFEND;
      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_proc, 'PROCEDURE / PROC / FUNCTION', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT /define_scl_procedure/;
      IFEND;

      IF definition_version > 0 THEN
        procedure_declaration_size := i#current_sequence_position (work_area_1);
        RESET work_area_1;
        NEXT procedure_declaration: [[REP procedure_declaration_size OF cell]] IN work_area_1;
        NEXT saved_procedure_declaration: [[REP procedure_declaration_size OF cell]] IN work_area_2^;
        saved_procedure_declaration^ := procedure_declaration^;
        RESET work_area_1;

        NEXT header IN work_area_1;
        header^.identifying_first_byte := UPPERVALUE (header^.identifying_first_byte);
        header^.version := clc$declaration_version;
        header^.command_or_function_name := procedure_name;

        NEXT initial_line_for_echoing: [header_word_size + 1 + clp$trimmed_string_size (procedure_name)] IN
              work_area_1;
        initial_line_for_echoing^ := header_word;
        #TRANSLATE (osv$upper_to_lower, procedure_name, initial_line_for_echoing^ (header_word_size + 2, * ));

        NEXT parameter_description_table: [[REP #SIZE (pdt^) OF cell]] IN work_area_1;
        RESET parameter_description_table;
        parameter_description_table^ := pdt^;

        NEXT procedure_declaration: [[REP procedure_declaration_size OF cell]] IN work_area_1;
        RESET procedure_declaration;
        procedure_declaration^ := saved_procedure_declaration^;
        RESET work_area_2^ TO saved_procedure_declaration;

        procedure_body := work_area_1;
      IFEND;

      read_proc_body;
      IF NOT status.normal THEN
        EXIT /define_scl_procedure/;
      IFEND;

      IF definition_version > 0 THEN
        procedure_body_size := i#current_sequence_position (work_area_1) -
              i#current_sequence_position (procedure_body);
        work_area_1 := procedure_body;
        NEXT procedure_body: [[REP procedure_body_size OF cell]] IN work_area_1;
        RESET procedure_body;

        RESET work_area_1 TO procedure_declaration;
        NEXT entire_procedure: [[REP procedure_declaration_size + procedure_body_size OF cell]] IN
              work_area_1;
        RESET entire_procedure;
      IFEND;

      scl_procedure_size := i#current_sequence_position (work_area_1);
      RESET work_area_1;
      NEXT scl_procedure: [[REP scl_procedure_size OF cell]] IN work_area_1;
      RESET scl_procedure;

      IF definition_version > 0 THEN
        header^.initial_line_for_echoing := #REL (initial_line_for_echoing, scl_procedure^);
        header^.parameter_description_table := #REL (parameter_description_table, scl_procedure^);
        header^.check_parameter_statements := NIL;
        header^.entire_procedure := #REL (entire_procedure, scl_procedure^);
        header^.procedure_declaration := #REL (procedure_declaration, scl_procedure^);
        header^.check_statement := NIL;
        header^.procedure_body := #REL (procedure_body, scl_procedure^);
      IFEND;

      work_area_2^ := original_work_area_2;

    END /define_scl_procedure/;

    IF status.normal THEN
      clp$pop_parameters (status);
    ELSE
      NEXT ignore_status IN work_area_1;
      clp$pop_parameters (ignore_status^);
    IFEND;

  PROCEND clp$define_scl_procedure;
*copyc cli$input_procedures

MODEND clm$define_scl_procedure;
*DECK DECK=CLM$DETACH_LOCAL_FILES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'DETACH_LOCAL_FILES ' ??
MODULE clm$detach_local_files;
{   PURPOSE: This module contains the procedure for detaching local files.
{   	
*copyc cle$ecc_file_reference
*copyc cld$parameter_list
*copyc ost$status
*copyc pmt$condition
*copyc rae$upgrade_errors

*copyc amp$return
*copyc clp$get_list_of_$local_files
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc clp$get_set_count
*copyc jmp$system_job
*copyc mmp$create_segment
*copyc mmp$delete_segment
*copyc osp$append_status_parameter
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
*copyc osp$set_status_abnormal
*copyc pfp$find_directory_array
*copyc pfp$find_direct_info_record
*copyc pfp$find_next_info_record
*copyc rmp$get_device_class


  CONST
    max_element_in_parameter = 256,
    max_standard_file = 3;

  TYPE

    device_class_set = set of rmt$device_class;


  PROCEDURE [XDCL, #GATE] clp$detach_local_files
    (    parameter_list: clt$parameter_list;

     VAR status: ost$status);

{ PDT detach_local_files_pdt(
{    device_class, dc : list of key magnetic_tape, mt, ...
{                                   mass_storage, ms, ...
{                                   terminal, t, null, n, ...
{                                   all, a = all
{     exclude_unique_files, euf : boolean = false
{     exclude_files, exclude_file, ef : list of name
{     status)



    VAR
      detach_local_files_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^detach_local_files_pdt_names, ^detach_local_files_pdt_params];

    VAR
      detach_local_files_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
            clt$parameter_name_descriptor := [['DEVICE_CLASS', 1], ['DC', 1],
            ['EXCLUDE_UNIQUE_FILES', 2], ['EUF', 2], ['EXCLUDE_FILES', 3], ['EF', 3],
            ['STATUS', 4]];

    VAR
      detach_local_files_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
            clt$parameter_descriptor := [

{ DEVICE_CLASS DC}
      [[clc$optional_with_default, ^detach_local_files_pdt_dv1], 1, clc$max_value_sets, 1, 1,
            clc$value_range_not_allowed, [^detach_local_files_pdt_kv1, clc$keyword_value]],


{ EXCLUDE_UNIQUE_FILES EUF}
      [[clc$optional_with_default, ^detach_local_files_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$boolean_value]],

{EXCLUDE_FILES EF}

      [[clc$optional], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$name_value, 1, osc$max_name_size]],

{STATUS }

      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      detach_local_files_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'ALL';


    VAR
      detach_local_files_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'FALSE';

    VAR
      detach_local_files_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 10] of
            ost$name := ['MAGNETIC_TAPE', 'MT', 'MASS_STORAGE', 'MS', 'TERMINAL', 'T', 'NULL', 'N', 'ALL',
            'A'];



    VAR
      info: pft$p_info,
      info_record: pft$p_info_record,
      directory: pft$p_directory_array,
      ignore_status: ost$status,
      local_status: ost$status,
      info_segment_pointer: mmt$segment_pointer,
      info_segment_open: boolean,
      exclude_files_count: 0 .. max_element_in_parameter,
      exclude_files_list_ptr: ^array [1 .. * ] of ost$name,
      local_file: ost$name,
      j: 1 .. max_standard_file,
      index: 1 .. max_element_in_parameter,
      ef_index: 1 .. max_element_in_parameter,
      specified_device_class: device_class_set,
      returned_device_class: rmt$device_class,
      device_assigned: boolean,
      euf_value: clt$value,
      f: 1 .. max_element_in_parameter,
      i: 1 .. max_element_in_parameter,
      ef_value: clt$value,
      parm_count: 0 .. clc$max_value_sets,
      value: clt$value,
      p_count: 0 .. clc$max_value_sets,
      standard_file: [STATIC, READ] array [1 .. max_standard_file] of ost$name :=
            ['COMMAND                        ', 'INPUT                          ',
            'OUTPUT                         '];

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

      VAR
        ignore_status: ost$status;

      IF info_segment_open THEN
        mmp$delete_segment (info_segment_pointer, 1, ignore_status);
        info_segment_open := FALSE;
      IFEND;

    PROCEND abort_handler;



    status.normal := TRUE;
    info_segment_open := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);
    exclude_files_count := 0;
    specified_device_class := $device_class_set [];
    clp$scan_parameter_list (parameter_list, detach_local_files_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF jmp$system_job () THEN
      osp$set_status_abnormal ('CL', rae$illegal_command_call, 'DETACH_LOCAL_FILES', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'from the operator console', status);
      RETURN;
    IFEND;

    clp$get_set_count ('DEVICE_CLASS', parm_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO parm_count DO
      clp$get_value ('DEVICE_CLASS', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (value.name.value (1)) = 'A' THEN
        IF parm_count <> 1 THEN
          osp$set_status_abnormal ('CL', cle$all_must_be_used_alone, 'DEVICE_CLASS', status);
          RETURN;
        ELSE
          specified_device_class := -$device_class_set [];
        IFEND;
      ELSEIF ((value.name.value (1, 3) = 'MAG') OR (value.name.value (1, 2) = 'MT')) THEN
        specified_device_class := specified_device_class + $device_class_set [rmc$magnetic_tape_device];
      ELSEIF ((value.name.value (1, 3) = 'MAS') OR (value.name.value (1, 2) = 'MS')) THEN
        specified_device_class := specified_device_class + $device_class_set [rmc$mass_storage_device];
      ELSEIF value.name.value (1) = 'T' THEN
        specified_device_class := specified_device_class + $device_class_set [rmc$terminal_device];
      ELSEIF value.name.value (1) = 'N' THEN
        specified_device_class := specified_device_class + $device_class_set [rmc$null_device];
      IFEND;
    FOREND;



    clp$get_value ('EXCLUDE_UNIQUE_FILES', 1, 1, clc$low, euf_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('EXCLUDE_FILES', p_count, status);
    IF p_count > 0 THEN
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      PUSH exclude_files_list_ptr: [1 .. p_count];
      exclude_files_count := p_count;
      FOR f := 1 TO p_count DO
        clp$get_value ('EXCLUDE_FILES', f, 1, clc$low, ef_value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        exclude_files_list_ptr^ [f] := ef_value.name.value (1, 31);
      FOREND;
    IFEND;




  /main/
    BEGIN
      mmp$create_segment (NIL, mmc$sequence_pointer, 1, info_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      info_segment_open := TRUE;
      info := info_segment_pointer.seq_pointer;
      RESET info;


      clp$get_list_of_$local_files (info, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      RESET info;
      pfp$find_next_info_record (info, info_record, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      pfp$find_directory_array (info_record, directory, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      FOR index := LOWERBOUND (directory^) TO UPPERBOUND (directory^) DO
        IF directory^ [index].name_type = pfc$file_name THEN
          local_file := directory^ [index].name;
          rmp$get_device_class (local_file, device_assigned, returned_device_class, status);
          IF NOT status.normal THEN
            EXIT /main/;
          IFEND;

        /return_file/
          BEGIN

            FOR j := LOWERBOUND (standard_file) TO UPPERBOUND (standard_file) DO
              IF local_file = standard_file [j] THEN
                EXIT /return_file/;
              IFEND;
            FOREND;
            IF (local_file (3, 2) = 'F$') AND (returned_device_class <> rmc$magnetic_tape_device) THEN
                EXIT /return_file/;
            IFEND;
            IF (local_file (1) = '$') AND (returned_device_class <> rmc$magnetic_tape_device) THEN
              IF (local_file (11) = 'S') AND (local_file (16) = 'D') AND
                    (local_file (25) = 'T') THEN
                IF euf_value.bool.value THEN
                  EXIT /return_file/;
                IFEND;
              ELSE
                EXIT /return_file/;
              IFEND;
            IFEND;
            IF exclude_files_count <> 0 THEN
              FOR ef_index := LOWERBOUND (exclude_files_list_ptr^) TO UPPERBOUND (exclude_files_list_ptr^) DO
                IF local_file = exclude_files_list_ptr^ [ef_index] THEN
                  EXIT /return_file/;
                IFEND;
              FOREND;
            IFEND;
            IF (returned_device_class IN specified_device_class) THEN
              amp$return (local_file, ignore_status);
              EXIT /return_file/;
            IFEND;

          END /return_file/;
        IFEND;
      FOREND;
    END /main/;
    IF info_segment_open THEN
      mmp$delete_segment (info_segment_pointer, 1, local_status);
      info_segment_open := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;
  PROCEND clp$detach_local_files;

MODEND clm$detach_local_files;
*DECK DECK=CLM$DETACH_LOCAL_FILES_PD EXPAND=TRUE
crepd (detach_local_files detach_local_file detlf) l=:$system.$system.osf$site_command_library ..
       sp=clp$detach_local_files lmo=none dm=off tel=fatal
*DECK DECK=CLM$DETERMINE_LINE_LAYOUT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Determine Layout of Command File Lines' ??
MODULE clm$determine_line_layout;

{
{ PURPOSE:
{   This module contains the procedure that determines the layout of lines from command files according to
{   the attributes of the command file.
{

?? NEWTITLE := 'Global Declarations' ??
?? NEWTITLE := 'Line Layout', EJECT ??
*copyc clt$line_layout
?? OLDTITLE, EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
*copyc amt$line_number
*copyc amt$max_record_length
*copyc amt$statement_identifier
*copyc cle$ecc_command_processing
*copyc ost$status
?? POP ??
*copyc fsp$set_file_reference_abnormal

?? TITLE := 'clp$determine_line_layout', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$determine_line_layout
    (    file_reference: fst$file_reference;
*IF NOT $true(osv$unix)
         record_type: amt$record_type,
         max_record_length: amt$max_record_length;
         line_number_present: boolean;
         line_number: amt$line_number;
         statement_identifier_present: boolean;
         statement_identifier: amt$statement_identifier;
*IFEND
     VAR line_layout: clt$line_layout;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
?? NEWTITLE := 'improper_command_file_attr', EJECT ??

    PROCEDURE [INLINE] improper_command_file_attr
      (    error: string ( * ));

      fsp$set_file_reference_abnormal (file_reference, cle$improper_command_file_attr, amc$open_req, error,
            status);
      EXIT clp$determine_line_layout;

    PROCEND improper_command_file_attr;
?? OLDTITLE, EJECT ??
*IFEND

    status.normal := TRUE;

*IF NOT $true(osv$unix)
    IF NOT (line_number_present OR statement_identifier_present) THEN
*IFEND

{ No Line Numbers or Statement Identifiers

*IF NOT $true(osv$unix)
      IF (record_type = amc$ansi_fixed) AND (max_record_length <= clc$max_command_line_size) THEN
        IF max_record_length < clc$min_text_line_element_size THEN
          improper_command_file_attr ('record length less than minimum command line length');
        IFEND;
        line_layout.physical_line_size := max_record_length;
      ELSE
*IFEND
        line_layout.physical_line_size := clc$max_command_line_size;
*IF NOT $true(osv$unix)
      IFEND;
*IFEND
      line_layout.element [1].kind := clc$text_line_element;
      line_layout.element [1].size := line_layout.physical_line_size;
      line_layout.element [2].kind := clc$null_line_element;
      line_layout.element [2].size := 0;
      line_layout.element [3].kind := clc$null_line_element;
      line_layout.element [3].size := 0;

*IF NOT $true(osv$unix)
    ELSEIF NOT statement_identifier_present THEN
      IF line_number.location = 1 THEN

{ Line Numbers on left

        IF (record_type = amc$ansi_fixed) AND (max_record_length <=
              (clc$max_command_line_size + line_number.length)) THEN
          IF max_record_length < (line_number.length + clc$min_text_line_element_size) THEN
            improper_command_file_attr ('line_number leaves insufficient space in record for data');
          IFEND;
          line_layout.physical_line_size := max_record_length;
        ELSE
          line_layout.physical_line_size := clc$max_command_line_size + line_number.length;
        IFEND;
        line_layout.element [1].kind := clc$line_number_line_element;
        line_layout.element [1].size := line_number.length;
        line_layout.element [2].kind := clc$text_line_element;
        line_layout.element [2].size := line_layout.physical_line_size - line_number.length;
        line_layout.element [3].kind := clc$null_line_element;
        line_layout.element [3].size := 0;

      ELSE

{ Line Numbers on right

        IF line_number.location > (clc$max_command_line_size + 1) THEN
          improper_command_file_attr ('record data length greater than maximum command line length');
        ELSEIF (record_type = amc$ansi_fixed) AND (max_record_length <>
              (line_number.location + line_number.length - 1)) THEN
          improper_command_file_attr ('line_number location conflicts with fixed record length');
        ELSEIF line_number.location < (clc$min_text_line_element_size + 1) THEN
          improper_command_file_attr ('line_number leaves insufficient space in record for data');
        IFEND;

        line_layout.physical_line_size := line_number.location + line_number.length - 1;
        line_layout.element [1].kind := clc$text_line_element;
        line_layout.element [1].size := line_number.location - 1;
        line_layout.element [2].kind := clc$line_number_line_element;
        line_layout.element [2].size := line_number.length;
        line_layout.element [3].kind := clc$null_line_element;
        line_layout.element [3].size := 0;
      IFEND;

    ELSEIF NOT line_number_present THEN
      IF statement_identifier.location = 1 THEN

{ Statement Identifiers on left

        IF (record_type = amc$ansi_fixed) AND (max_record_length <=
              (clc$max_command_line_size + statement_identifier.length)) THEN
          IF max_record_length < (statement_identifier.length + clc$min_text_line_element_size) THEN
            improper_command_file_attr ('statement_identifier leaves insufficient space in record for data');
          IFEND;
          line_layout.physical_line_size := max_record_length;
        ELSE
          line_layout.physical_line_size := clc$max_command_line_size + statement_identifier.length;
        IFEND;
        line_layout.element [1].kind := clc$statement_id_line_element;
        line_layout.element [1].size := statement_identifier.length;
        line_layout.element [2].kind := clc$text_line_element;
        line_layout.element [2].size := line_layout.physical_line_size - statement_identifier.length;
        line_layout.element [3].kind := clc$null_line_element;
        line_layout.element [3].size := 0;

      ELSE

{ Statement Identifiers on right

        IF statement_identifier.location > (clc$max_command_line_size + 1) THEN
          improper_command_file_attr ('record data length greater than maximum command line length');
        ELSEIF (record_type = amc$ansi_fixed) AND (max_record_length <>
              (statement_identifier.location + statement_identifier.length - 1)) THEN
          improper_command_file_attr ('statement_identifier location conflicts with fixed record length');
        ELSEIF statement_identifier.location < (clc$min_text_line_element_size + 1) THEN
          improper_command_file_attr ('statement_identifier leaves insufficient space in record for data');
        IFEND;

        line_layout.physical_line_size := statement_identifier.location + statement_identifier.length - 1;
        line_layout.element [1].kind := clc$text_line_element;
        line_layout.element [1].size := statement_identifier.location - 1;
        line_layout.element [2].kind := clc$statement_id_line_element;
        line_layout.element [2].size := statement_identifier.length;
        line_layout.element [3].kind := clc$null_line_element;
        line_layout.element [3].size := 0;
      IFEND;

    ELSE

{ Both Line Numbers and Statement Identifiers

      IF line_number.location = 1 THEN
        IF statement_identifier.location <= line_number.length THEN
          improper_command_file_attr ('statement_identifier overlaps line_number');

        ELSEIF statement_identifier.location = (line_number.length + 1) THEN

{ Line Numbers, Statement Identifiers on left

          IF (record_type = amc$ansi_fixed) AND (max_record_length <=
                (clc$max_command_line_size + line_number.length + statement_identifier.length)) THEN
            IF (max_record_length - line_number.length - statement_identifier.length) <
                  clc$min_text_line_element_size THEN
              improper_command_file_attr (
                    'line_number and statement_identifier leave insufficient space in record for data');
            IFEND;
            line_layout.physical_line_size := max_record_length;
          ELSE
            line_layout.physical_line_size := clc$max_command_line_size + line_number.length +
                  statement_identifier.length;
          IFEND;
          line_layout.element [1].kind := clc$line_number_line_element;
          line_layout.element [1].size := line_number.length;
          line_layout.element [2].kind := clc$statement_id_line_element;
          line_layout.element [2].size := statement_identifier.length;
          line_layout.element [3].kind := clc$text_line_element;
          line_layout.element [3].size := line_layout.physical_line_size - line_number.length -
                statement_identifier.length;

        ELSE

{ Line Numbers on left, Statement Identifiers on right

          IF (statement_identifier.location - line_number.length) < (clc$min_text_line_element_size + 1) THEN
            improper_command_file_attr (
                  'line_number and statement_identifier leave insufficient space in record for data');
          ELSEIF (record_type = amc$ansi_fixed) AND (max_record_length <>
                (statement_identifier.location + statement_identifier.length - 1)) THEN
            improper_command_file_attr ('statement_identifier location conflicts with fixed record length');
          IFEND;

          line_layout.physical_line_size := statement_identifier.location + statement_identifier.length - 1;
          line_layout.element [1].kind := clc$line_number_line_element;
          line_layout.element [1].size := line_number.length;
          line_layout.element [2].kind := clc$text_line_element;
          line_layout.element [2].size := line_layout.physical_line_size - line_number.length -
                statement_identifier.length;
          line_layout.element [3].kind := clc$statement_id_line_element;
          line_layout.element [3].size := statement_identifier.length;
        IFEND;

      ELSEIF statement_identifier.location = 1 THEN
        IF line_number.location <= statement_identifier.length THEN
          improper_command_file_attr ('line_number overlaps statement_identifier');

        ELSEIF line_number.location = (statement_identifier.length + 1) THEN

{ Statement Identifiers, Line Numbers on left

          IF (record_type = amc$ansi_fixed) AND (max_record_length <=
                (clc$max_command_line_size + statement_identifier.length + line_number.length)) THEN
            IF (max_record_length - statement_identifier.length - line_number.length) <
                  clc$min_text_line_element_size THEN
              improper_command_file_attr (
                    'statement_identifier and line_number leave insufficient space in record for data');
            IFEND;
            line_layout.physical_line_size := max_record_length;
          ELSE
            line_layout.physical_line_size := clc$max_command_line_size + statement_identifier.length +
                  line_number.length;
          IFEND;

          line_layout.element [1].kind := clc$statement_id_line_element;
          line_layout.element [1].size := statement_identifier.length;
          line_layout.element [2].kind := clc$line_number_line_element;
          line_layout.element [2].size := line_number.length;
          line_layout.element [3].kind := clc$text_line_element;
          line_layout.element [3].size := line_layout.physical_line_size - statement_identifier.length -
                line_number.length;

        ELSE

{ Statement Identifiers on left, Line Numbers on right

          IF (line_number.location - statement_identifier.length) < (clc$min_text_line_element_size + 1) THEN
            improper_command_file_attr (
                  'statement_identifier and line_number leave insufficient space in record for data');
          ELSEIF (record_type = amc$ansi_fixed) AND (max_record_length <>
                (line_number.location + line_number.length - 1)) THEN
            improper_command_file_attr ('line_number location conflicts with fixed record length');
          IFEND;

          line_layout.physical_line_size := line_number.location + line_number.length - 1;
          line_layout.element [1].kind := clc$statement_id_line_element;
          line_layout.element [1].size := statement_identifier.length;
          line_layout.element [2].kind := clc$text_line_element;
          line_layout.element [2].size := line_layout.physical_line_size - statement_identifier.length -
                line_number.length;
          line_layout.element [3].kind := clc$line_number_line_element;
          line_layout.element [3].size := line_number.length;
        IFEND;

      ELSEIF line_number.location < statement_identifier.location THEN

{ Line Numbers, Statement Identifiers on right

        IF line_number.location <= clc$min_text_line_element_size THEN
          improper_command_file_attr ('line_number leaves insufficient space in record for data');
        ELSEIF line_number.location > (clc$max_command_line_size + 1) THEN
          improper_command_file_attr ('record data length exceeds maximum command line length');
        ELSEIF statement_identifier.location < (line_number.location + line_number.length) THEN
          improper_command_file_attr ('statement_identifier overlaps line_identifer');
        ELSEIF statement_identifier.location > (line_number.location + line_number.length) THEN
          improper_command_file_attr ('line_number and statement_identifier both on right but not contiguous')
                ;
        ELSEIF (record_type = amc$ansi_fixed) AND (max_record_length <>
              (statement_identifier.location + statement_identifier.length - 1)) THEN
          improper_command_file_attr ('statement_identifier location conflicts with fixed record length');
        IFEND;

        line_layout.physical_line_size := statement_identifier.location + statement_identifier.length - 1;
        line_layout.element [1].kind := clc$text_line_element;
        line_layout.element [1].size := line_layout.physical_line_size - line_number.length -
              statement_identifier.length;
        line_layout.element [2].kind := clc$line_number_line_element;
        line_layout.element [2].size := line_number.length;
        line_layout.element [3].kind := clc$statement_id_line_element;
        line_layout.element [3].size := statement_identifier.length;

      ELSE

{ Statement Identifiers, Line Numbers on right

        IF statement_identifier.location <= clc$min_text_line_element_size THEN
          improper_command_file_attr ('statement_identifier leaves insufficient space in record for data');
        ELSEIF statement_identifier.location > (clc$max_command_line_size + 1) THEN
          improper_command_file_attr ('record data length exceeds maximum command line length');
        ELSEIF line_number.location < (statement_identifier.location + statement_identifier.length) THEN
          improper_command_file_attr ('line_number overlaps statement_identifier');
        ELSEIF line_number.location > (statement_identifier.location + statement_identifier.length) THEN
          improper_command_file_attr ('statement_identifier and line_number both on right but not contiguous')
                ;
        ELSEIF (record_type = amc$ansi_fixed) AND (max_record_length <>
              (line_number.location + line_number.length - 1)) THEN
          improper_command_file_attr ('line_number location conflicts with fixed record length');
        IFEND;

        line_layout.physical_line_size := line_number.location + line_number.length - 1;
        line_layout.element [1].kind := clc$text_line_element;
        line_layout.element [1].size := line_layout.physical_line_size - statement_identifier.length -
              line_number.length;
        line_layout.element [2].kind := clc$statement_id_line_element;
        line_layout.element [2].size := statement_identifier.length;
        line_layout.element [3].kind := clc$line_number_line_element;
        line_layout.element [3].size := line_number.length;
      IFEND;
    IFEND;
*IFEND

  PROCEND clp$determine_line_layout;

MODEND clm$determine_line_layout;
*DECK DECK=CLM$DISPLAY_CMND_OR_FUNC_INFO EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Display Command or Function Info' ??
MODULE clm$display_cmnd_or_func_info;

{
{ PURPOSE:
{   This module contains the processors for the display_command_information and
{   display_function_information commands
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amd$file_contents
*copyc cle$ecc_function_processing
*copyc cle$ecc_parameter_list
*copyc clt$command_name
*copyc clt$command_or_function_source
*copyc clt$parameter_help_context
*copyc clt$parameter_list
*copyc clt$unbundled_pdt
*IF $true(osv$unix)
*copyc cyt$mips_signal_handler
*IFEND
*copyc fst$path_size
*copyc ost$caller_identifier
*IF $true(osv$unix)
*copyc ost$status
*IFEND
?? POP ??
*copyc amp$put_next
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$check_name_for_function
*copyc clp$close_display
*copyc clp$convert_data_to_string
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_name
*copyc clp$data_representation_text
*copyc clp$evaluate_function
*copyc clp$evaluate_parameters
*copyc clp$find_command_entries
*copyc clp$find_command_list
*copyc clp$find_current_block
*IF NOT $true(osv$unix)
*copyc clp$get_path_name
*IFEND
*copyc clp$get_work_area
*copyc clp$horizontal_tab_display
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*copyc clp$internal_convert_to_string
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$process_command
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$scan_non_space_lexical_unit
*copyc clp$set_help_mode
*copyc clp$trimmed_string_size
*IF NOT $true(osv$unix)
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$establish_block_exit_hndlr
*copyc osp$file_access_condition
*copyc osp$find_brief_help_message
*copyc osp$find_full_help_message
*copyc osp$find_help_module
*copyc osp$find_parameter_help_message
*copyc osp$format_help_message
*IFEND
*copyc osp$set_status_abnormal
*copyc clv$nil_display_control
*IF NOT $true(osv$unix)
*copyc clv$system_functions
*copyc clv$system_functions_v0
*ELSE
*copyc cle$ecc_command_processing
*IFEND
*IF NOT $true(osv$unix)
*copyc osv$initial_exception_context
*IFEND
*copyc osv$upper_to_lower

?? TITLE := 'clp$_display_command_informatio', EJECT ??

  PROCEDURE [XDCL] clp$_display_command_informatio
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
{ PROCEDURE (osm$disci) display_command_information, disci (
{   command, c: command_reference = $required
{   output, o: file = $output
{   display_options, display_option, do: list of key
{       all
{       (all_names, all_name, an)
{       (source, s)
{       (brief_help, bh)
{       (full_help, fh)
{       (compact_parameter_descriptions, compact_parameter_description, cpd)
{       (parameter_descriptions, parameter_description, pd)
{       (parameter_help, ph)
{       (advanced_usage, au)
{     advanced_key
{       (help_module_seed, hms)
{     keyend = osd$disci_display_options, (all_names, brief_help, compact_parameter_descriptions)
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 8] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 22] of clt$keyword_specification,
          recend,
          default_name: string (25),
          default_value: string (55),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 11, 17, 44, 34, 983], clc$command, 8, 4, 1, 0, 0, 0, 4, 'OSM$DISCI'],
            [['C                              ', clc$abbreviation_entry, 1],
            ['COMMAND                        ', clc$nominal_entry, 1],
            ['DISPLAY_OPTION                 ', clc$alias_entry, 3],
            ['DISPLAY_OPTIONS                ', clc$nominal_entry, 3],
            ['DO                             ', clc$abbreviation_entry, 3],
            ['O                              ', clc$abbreviation_entry, 2],
            ['OUTPUT                         ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 3

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 837, clc$optional_default_parameter, 25, 55],

{ PARAMETER 4

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$command_reference_type]],

{ PARAMETER 2

      [[1, 0, clc$file_type], '$output'],

{ PARAMETER 3

      [[1, 0, clc$list_type], [821, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [22], [['ADVANCED_USAGE                 ', clc$nominal_entry,
            clc$normal_usage_entry, 9], ['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['ALL_NAME                       ', clc$alias_entry,
            clc$normal_usage_entry, 2], ['ALL_NAMES                      ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['AN                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['AU                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 9], ['BH                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['BRIEF_HELP                     ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['COMPACT_PARAMETER_DESCRIPTION  ', clc$alias_entry,
            clc$normal_usage_entry, 6], ['COMPACT_PARAMETER_DESCRIPTIONS ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['CPD                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['FH                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['FULL_HELP                      ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['HELP_MODULE_SEED               ', clc$nominal_entry,
            clc$advanced_usage_entry, 10], ['HMS                            ', clc$abbreviation_entry,
            clc$advanced_usage_entry, 10], ['PARAMETER_DESCRIPTION          ', clc$alias_entry,
            clc$normal_usage_entry, 7], ['PARAMETER_DESCRIPTIONS         ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['PARAMETER_HELP                 ', clc$nominal_entry,
            clc$normal_usage_entry, 8], ['PD                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['PH                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 8], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['SOURCE                         ', clc$nominal_entry,
            clc$normal_usage_entry, 3]]], 'OSD$DISCI_DISPLAY_OPTIONS',
            '(all_names, brief_help, compact_parameter_descriptions)'],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$command = 1,
      p$output = 2,
      p$display_options = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;
*ELSE
{ PROCEDURE (osm$disci) display_command_information, disci (
{   command, c: command_reference = $required
{   output, o: file = $output
{   display_options, display_option, do: list of key
{       all
{       (all_names, all_name, an)
{       (source, s)
{       (compact_parameter_descriptions, compact_parameter_description, cpd)
{       (parameter_descriptions, parameter_description, pd)
{       (advanced_usage, au)
{       (man, m)
{     keyend = OSD_DISCI_DISPLAY_OPTIONS,
{     (all_names, compact_parameter_descriptions)
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: ALIGNED [0 MOD 4] string (7),
      recend,
      type3: 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 .. 16] of clt$keyword_specification,
        recend,
        default_name: ALIGNED [0 MOD 4] string (25),
        default_value: ALIGNED [0 MOD 4] string (43),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [2,
    [92, 5, 11, 11, 24, 28, 0],
    clc$command, 8, 4, 1, 0, 0, 0, 4, 'OSM$DISCI'], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['COMMAND                        ',clc$nominal_entry, 1],
    ['DISPLAY_OPTION                 ',clc$alias_entry, 3],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 3],
    ['DO                             ',clc$abbreviation_entry, 3],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 676, clc$optional_default_parameter, 25, 43],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[2, 0, clc$command_reference_type]],
{ PARAMETER 2
    [[2, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[2, 0, clc$list_type], [648, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[2, 0, clc$keyword_type], [16], [
      ['ADVANCED_USAGE                 ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['ALL_NAME                       ', clc$alias_entry,
  clc$normal_usage_entry, 2],
      ['ALL_NAMES                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['AN                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
      ['AU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
      ['COMPACT_PARAMETER_DESCRIPTION  ', clc$alias_entry,
  clc$normal_usage_entry, 4],
      ['COMPACT_PARAMETER_DESCRIPTIONS ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['CPD                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
      ['M                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
      ['MAN                            ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
      ['PARAMETER_DESCRIPTION          ', clc$alias_entry,
  clc$normal_usage_entry, 5],
      ['PARAMETER_DESCRIPTIONS         ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
      ['PD                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
      ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
      ['SOURCE                         ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
      ]
    ,
    'OSD_DISCI_DISPLAY_OPTIONS',
    '(all_names, compact_parameter_descriptions)'],
{ PARAMETER 4
    [[2, 0, clc$status_type]]];

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

    CONST
      p$command = 1,
      p$output = 2,
      p$display_options = 3,
      p$status = 4;

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

    VAR
      current_block: ^clt$block,
      display_option: clt$keyword,
      help_output_options: clt$parameter_help_options,
*IF $true(osv$unix)
      file_reference: fst$path,
*IFEND
      ignore_cause_condition: clt$when_condition,
      lexical_units: ^clt$lexical_units,
      options: ^clt$data_value,
      parse: clt$parse_state,
      representation: ^clt$data_representation,
      representation_text: ^clt$command_line,
      work_area: ^^clt$work_area;


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

*IF NOT $true(osv$unix)
    clp$get_work_area (#RING (^work_area), work_area, status);
*ELSE
    clp$get_work_area (osc$user_ring, work_area, status);
*IFEND
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_data_to_string (pvt [p$command].value, clc$data_source_representation, clc$max_string_size,
          work_area^, representation, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    representation_text := clp$data_representation_text (representation);

    clp$identify_lexical_units (representation_text, work_area^, lexical_units, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$initialize_parse_state (representation_text, lexical_units, parse);
    clp$scan_non_space_lexical_unit (parse);

    help_output_options := $clt$parameter_help_options [];
    options := pvt [p$display_options].value;
    WHILE options <> NIL DO
      display_option := options^.element_value^.keyword_value;
      IF display_option = 'ALL' THEN
*IF $true(osv$unix)
        help_output_options := -$clt$parameter_help_options [clc$ph_man];
*ELSE
        help_output_options := -$clt$parameter_help_options [];
*IFEND
      ELSEIF display_option = 'ALL_NAMES' THEN
        help_output_options := help_output_options + $clt$parameter_help_options [clc$ph_all_names];
      ELSEIF display_option = 'SOURCE' THEN
        help_output_options := help_output_options + $clt$parameter_help_options [clc$ph_source];
      ELSEIF display_option = 'BRIEF_HELP' THEN
        help_output_options := help_output_options + $clt$parameter_help_options [clc$ph_brief_help];
      ELSEIF display_option = 'FULL_HELP' THEN
        help_output_options := help_output_options + $clt$parameter_help_options [clc$ph_full_help];
      ELSEIF display_option = 'COMPACT_PARAMETER_DESCRIPTIONS' THEN
        help_output_options := help_output_options + $clt$parameter_help_options
              [clc$ph_compact_par_descriptions];
      ELSEIF display_option = 'PARAMETER_DESCRIPTIONS' THEN
        help_output_options := help_output_options + $clt$parameter_help_options
              [clc$ph_parameter_descriptions];
      ELSEIF display_option = 'PARAMETER_HELP' THEN
        help_output_options := help_output_options + $clt$parameter_help_options [clc$ph_parameter_help];
      ELSEIF display_option = 'ADVANCED_USAGE' THEN
        help_output_options := help_output_options + $clt$parameter_help_options [clc$ph_advanced_usage];
      ELSEIF display_option = 'HELP_MODULE_SEED' THEN
        help_output_options := help_output_options + $clt$parameter_help_options [clc$ph_help_module_name];
*IF $true(osv$unix)
      ELSEIF display_option = 'MAN' THEN
        help_output_options := help_output_options + $clt$parameter_help_options [clc$ph_man];
*IFEND
      IFEND;
      options := options^.link;
    WHILEND;

    clp$set_help_mode (pvt [p$output].value^.file_value, help_output_options);

    clp$find_current_block (current_block);

    clp$process_command (current_block, clc$help_mode, FALSE, FALSE, FALSE, FALSE, parse,
          ignore_cause_condition, status);
    IF (NOT status.normal) AND (status.condition = cle$parameters_displayed) THEN
      status.normal := TRUE;
    IFEND;

  PROCEND clp$_display_command_informatio;
?? TITLE := 'clp$_display_function_informati', EJECT ??

  PROCEDURE [XDCL] clp$_display_function_informati
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
{ PROCEDURE (osm$disfi) display_function_information, disfi (
{   function, f: data_name = $required
{   output, o: file = $output
{   display_options, display_option, do: list of key
{       all
{       (all_names, all_name, an)
{       (source, s)
{       (brief_help, bh)
{       (full_help, fh)
{       (compact_parameter_descriptions, compact_parameter_description, cpd)
{       (parameter_descriptions, parameter_description, pd)
{       (parameter_help, ph)
{       (advanced_usage, au)
{     advanced_key
{       (help_module_seed, hms)
{     keyend = osd$disfi_display_options, (all_names, brief_help, compact_parameter_descriptions)
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 8] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 22] of clt$keyword_specification,
          recend,
          default_name: string (25),
          default_value: string (55),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 11, 17, 44, 8, 796], clc$command, 8, 4, 1, 0, 0, 0, 4, 'OSM$DISFI'],
            [['DISPLAY_OPTION                 ', clc$alias_entry, 3],
            ['DISPLAY_OPTIONS                ', clc$nominal_entry, 3],
            ['DO                             ', clc$abbreviation_entry, 3],
            ['F                              ', clc$abbreviation_entry, 1],
            ['FUNCTION                       ', clc$nominal_entry, 1],
            ['O                              ', clc$abbreviation_entry, 2],
            ['OUTPUT                         ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 3

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 837, clc$optional_default_parameter, 25, 55],

{ PARAMETER 4

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$data_name_type]],

{ PARAMETER 2

      [[1, 0, clc$file_type], '$output'],

{ PARAMETER 3

      [[1, 0, clc$list_type], [821, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [22], [['ADVANCED_USAGE                 ', clc$nominal_entry,
            clc$normal_usage_entry, 9], ['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['ALL_NAME                       ', clc$alias_entry,
            clc$normal_usage_entry, 2], ['ALL_NAMES                      ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['AN                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['AU                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 9], ['BH                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['BRIEF_HELP                     ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['COMPACT_PARAMETER_DESCRIPTION  ', clc$alias_entry,
            clc$normal_usage_entry, 6], ['COMPACT_PARAMETER_DESCRIPTIONS ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['CPD                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['FH                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['FULL_HELP                      ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['HELP_MODULE_SEED               ', clc$nominal_entry,
            clc$advanced_usage_entry, 10], ['HMS                            ', clc$abbreviation_entry,
            clc$advanced_usage_entry, 10], ['PARAMETER_DESCRIPTION          ', clc$alias_entry,
            clc$normal_usage_entry, 7], ['PARAMETER_DESCRIPTIONS         ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['PARAMETER_HELP                 ', clc$nominal_entry,
            clc$normal_usage_entry, 8], ['PD                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['PH                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 8], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['SOURCE                         ', clc$nominal_entry,
            clc$normal_usage_entry, 3]]], 'OSD$DISFI_DISPLAY_OPTIONS',
            '(all_names, brief_help, compact_parameter_descriptions)'],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$function = 1,
      p$output = 2,
      p$display_options = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;
*ELSE
{ PROCEDURE (osm$disfi) display_function_information, disfi (
{   function, f: data_name = $required
{   output, o: file = $output
{   display_options, display_option, do: list of key
{       all
{       (all_names, all_name, an)
{       (source, s)
{       (compact_parameter_descriptions, compact_parameter_description, cpd)
{       (parameter_descriptions, parameter_description, pd)
{       (advanced_usage, au)
{     keyend = OSD_DISFI_DISPLAY_OPTIONS,
{     (all_names, compact_parameter_descriptions)
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: ALIGNED [0 MOD 4] string (7),
      recend,
      type3: 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 .. 14] of clt$keyword_specification,
        recend,
        default_name: ALIGNED [0 MOD 4] string (25),
        default_value: ALIGNED [0 MOD 4] string (43),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [2,
    [92, 5, 11, 11, 27, 26, 0],
    clc$command, 8, 4, 1, 0, 0, 0, 4, 'OSM$DISFI'], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 3],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 3],
    ['DO                             ',clc$abbreviation_entry, 3],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FUNCTION                       ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 596, clc$optional_default_parameter, 25, 43],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[2, 0, clc$data_name_type]],
{ PARAMETER 2
    [[2, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[2, 0, clc$list_type], [568, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[2, 0, clc$keyword_type], [14], [
      ['ADVANCED_USAGE                 ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['ALL_NAME                       ', clc$alias_entry,
  clc$normal_usage_entry, 2],
      ['ALL_NAMES                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['AN                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
      ['AU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
      ['COMPACT_PARAMETER_DESCRIPTION  ', clc$alias_entry,
  clc$normal_usage_entry, 4],
      ['COMPACT_PARAMETER_DESCRIPTIONS ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['CPD                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
      ['PARAMETER_DESCRIPTION          ', clc$alias_entry,
  clc$normal_usage_entry, 5],
      ['PARAMETER_DESCRIPTIONS         ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
      ['PD                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
      ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
      ['SOURCE                         ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
      ]
    ,
    'OSD_DISFI_DISPLAY_OPTIONS',
    '(all_names, compact_parameter_descriptions)'],
{ PARAMETER 4
    [[2, 0, clc$status_type]]];

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

    CONST
      p$function = 1,
      p$output = 2,
      p$display_options = 3,
      p$status = 4;

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

    VAR
      display_option: clt$keyword,
      dummy_text: ^clt$string_value,
*IF $true(osv$unix)
      file_reference: fst$path,
*IFEND
      found: boolean,
      help_output_options: clt$parameter_help_options,
      lexical_units: ^clt$lexical_units,
      lexical_work_area: ^clt$work_area,
      options: ^clt$data_value,
      parse: clt$parse_state,
      result: clt$function_result,
      work_area: ^^clt$work_area;


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

    help_output_options := $clt$parameter_help_options [];
    options := pvt [p$display_options].value;
    WHILE options <> NIL DO
      display_option := options^.element_value^.keyword_value;
      IF display_option = 'ALL' THEN
        help_output_options := -$clt$parameter_help_options [];
      ELSEIF display_option = 'ALL_NAMES' THEN
        help_output_options := help_output_options + $clt$parameter_help_options [clc$ph_all_names];
      ELSEIF display_option = 'SOURCE' THEN
        help_output_options := help_output_options + $clt$parameter_help_options [clc$ph_source];
      ELSEIF display_option = 'BRIEF_HELP' THEN
        help_output_options := help_output_options + $clt$parameter_help_options [clc$ph_brief_help];
      ELSEIF display_option = 'FULL_HELP' THEN
        help_output_options := help_output_options + $clt$parameter_help_options [clc$ph_full_help];
      ELSEIF display_option = 'COMPACT_PARAMETER_DESCRIPTIONS' THEN
        help_output_options := help_output_options + $clt$parameter_help_options
              [clc$ph_compact_par_descriptions];
      ELSEIF display_option = 'PARAMETER_DESCRIPTIONS' THEN
        help_output_options := help_output_options + $clt$parameter_help_options
              [clc$ph_parameter_descriptions];
      ELSEIF display_option = 'PARAMETER_HELP' THEN
        help_output_options := help_output_options + $clt$parameter_help_options [clc$ph_parameter_help];
      ELSEIF display_option = 'ADVANCED_USAGE' THEN
        help_output_options := help_output_options + $clt$parameter_help_options [clc$ph_advanced_usage];
      ELSEIF display_option = 'HELP_MODULE_SEED' THEN
        help_output_options := help_output_options + $clt$parameter_help_options [clc$ph_help_module_name];
      IFEND;
      options := options^.link;
    WHILEND;

    clp$set_help_mode (pvt [p$output].value^.file_value, help_output_options);

    PUSH dummy_text: [0];
    PUSH lexical_work_area: [[REP clc$lexical_units_size_pad OF clt$lexical_unit]];
    RESET lexical_work_area;
    clp$identify_lexical_units (dummy_text, lexical_work_area, lexical_units, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$initialize_parse_state (dummy_text, lexical_units, parse);
    clp$scan_non_space_lexical_unit (parse);

*IF NOT $true(osv$unix)
    clp$get_work_area (#RING (^work_area), work_area, status);
*ELSE
    clp$get_work_area (osc$user_ring, work_area, status);
*IFEND
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$evaluate_function (FALSE, pvt [p$function].value^.data_name_value, NIL, parse, work_area^, result,
          found, status);
    IF status.normal AND (NOT found) THEN
      osp$set_status_abnormal ('CL', cle$unknown_function, pvt [p$function].value^.data_name_value, status);
    ELSEIF (NOT status.normal) AND (status.condition = cle$parameters_displayed) THEN
      status.normal := TRUE;
    IFEND;

  PROCEND clp$_display_function_informati;
?? TITLE := 'clp$display_cmnd_or_func_info', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$display_cmnd_or_func_info
    (    default_file_contents: amt$file_contents;
         help_context: clt$parameter_help_context;
         command_or_function_source: clt$command_or_function_source;
         command_or_function_name: clt$command_name;
         pdt: clt$unbundled_pdt;
     VAR status: ost$status);

*copy clv$display_variables

    CONST
      header_length = 9;

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

    PROCEDURE abort_handler
*IF $true(osv$unix)
      (    signal_no: integer;
           code: integer;
           p_sigcontext: ^cyt$mips_sigcontext);

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);
*ELSE
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      clp$close_display (display_control, handler_status);
      handler_status.normal := TRUE;
*IFEND

    PROCEND abort_handler;
*copy clp$new_page_procedure
?? TITLE := 'put_subtitle ', EJECT ??

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

      VAR
        translated_command_name: ost$name;


      IF pdt.header^.command_or_function = clc$command THEN
        clp$put_partial_display (display_control, 'COMMAND ', clc$no_trim, amc$start, status);
      ELSE
        clp$put_partial_display (display_control, 'FUNCTION ', clc$no_trim, amc$start, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #TRANSLATE (osv$upper_to_lower, command_or_function_name, translated_command_name);
      clp$put_partial_display (display_control, translated_command_name, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND put_subtitle;
?? TITLE := 'display_all_names', EJECT ??

    PROCEDURE display_all_names
      (VAR status: ost$status);

      VAR
        index: integer,
        names: ^array [1 .. * ] of clt$command_name,
        separator: string (3),
        term_option: amt$term_option,
        translated_name: clt$command_name,
        trim_option: clt$trim_display_text_option;


      clp$get_all_cmnd_or_func_names (pdt.header^.command_or_function, command_or_function_source,
            command_or_function_name, work_area^, names, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      skip_line;
      put_partial_display ('Names:   ', clc$no_trim, amc$continue);

      separator := ',  ';
      trim_option := clc$trim;
      term_option := amc$continue;

      FOR index := 1 TO UPPERBOUND (names^) DO
        IF (display_control.column_number + clp$trimmed_string_size (names^ [index]) + 2) >
              display_control.page_width THEN
          clp$new_display_line (display_control, clc$next_display_line, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$horizontal_tab_display (display_control, header_length + 1, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        #TRANSLATE (osv$upper_to_lower, names^ [index], translated_name);
        put_partial_display (translated_name, trim_option, term_option);
        IF index = UPPERBOUND (names^) THEN
          term_option := amc$terminate;
          separator := '   ';
        IFEND;

        put_partial_display (separator, clc$no_trim, term_option);
      FOREND;

    PROCEND display_all_names;
?? TITLE := 'put_partial_display', EJECT ??

    PROCEDURE put_partial_display
      (    str: string ( * );
           trim_option: clt$trim_display_text_option;
           term_option: amt$term_option);


      clp$put_partial_display (display_control, str, trim_option, term_option, status);
      IF NOT status.normal THEN
        EXIT clp$display_cmnd_or_func_info;
      IFEND;

    PROCEND put_partial_display;
?? TITLE := 'display_source', EJECT ??

    PROCEDURE display_source
      (VAR status: ost$status);

      VAR
        chunk_count: 0 .. fsc$max_path_elements,
        display_chunks: clt$path_display_chunks,
        i: 0 .. fsc$max_path_elements,
        source_string: fst$path,
        source_string_size: fst$path_size,
        term_option: amt$term_option,
        terminate_string: string (2);


      clp$get_cmnd_or_func_source_str (command_or_function_source, source_string, source_string_size, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$build_path_subtitle (source_string, source_string_size,
            (display_control.page_width - header_length), chunk_count, display_chunks);

      skip_line;
      put_partial_display ('Source:', clc$no_trim, amc$continue);

      terminate_string := '..';
      term_option := amc$terminate;
      FOR i := 1 TO chunk_count DO
        clp$horizontal_tab_display (display_control, header_length + 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF i = chunk_count THEN
          terminate_string := '  ';
          term_option := amc$terminate;
        IFEND;
        put_partial_display (source_string (display_chunks [i].position, display_chunks [i].length),
              clc$trim, amc$continue);
        put_partial_display (terminate_string, clc$trim, term_option);
      FOREND;

    PROCEND display_source;
*IF NOT $true(osv$unix)
?? TITLE := 'display_help_module_name', EJECT ??

    PROCEDURE [INLINE] display_help_module_name;


      skip_line;

      put_partial_display ('Help Module Seed:  ', clc$no_trim, amc$start);

      IF pdt.header^.help_module_name = '' THEN
        put_partial_display ('none', clc$no_trim, amc$terminate);
      ELSE
        put_partial_display (pdt.header^.help_module_name, clc$trim, amc$terminate);
      IFEND;

    PROCEND display_help_module_name;
?? TITLE := 'get_brief_help', EJECT ??

    PROCEDURE get_brief_help;


      osp$find_brief_help_message (help_module, message_template, ignore_status);
      IF message_template <> NIL THEN
        osp$format_help_message (message_template, NIL, display_control.page_width, message, ignore_status);
        IF NOT ignore_status.normal THEN
          RETURN;
        IFEND;
        put_message (message);
      IFEND;

    PROCEND get_brief_help;
?? TITLE := 'get_full_help', EJECT ??

    PROCEDURE get_full_help;


      osp$find_full_help_message (help_module, message_template, ignore_status);
      IF message_template <> NIL THEN
        osp$format_help_message (message_template, NIL, display_control.page_width, message, ignore_status);
        IF NOT ignore_status.normal THEN
          RETURN;
        IFEND;
        put_message (message);
      ELSE
        get_brief_help;
      IFEND;

    PROCEND get_full_help;
?? TITLE := 'put_message', EJECT ??

    PROCEDURE [INLINE] put_message
      (    message: ost$status_message);

      VAR
        message_line: ^ost$status_message_line,
        message_area: ^ost$status_message,
        message_line_count: ^ost$status_message_line_count,
        message_line_index: 1 .. osc$max_status_message_lines,
        message_line_size: ^ost$status_message_line_size;


      message_area := ^message;
      RESET message_area;
      NEXT message_line_count IN message_area;

      skip_line;
      FOR message_line_index := 1 TO message_line_count^ DO
        NEXT message_line_size IN message_area;
        NEXT message_line: [message_line_size^] IN message_area;
        put_line (message_line^ (2, * ));
      FOREND;

    PROCEND put_message;
*IFEND
?? TITLE := 'put_line', EJECT ??

    PROCEDURE [INLINE] put_line
      (    line: string ( * ));


      clp$put_display (display_control, line, clc$no_trim, status);
      IF NOT status.normal THEN
        EXIT clp$display_cmnd_or_func_info;
      IFEND;

    PROCEND put_line;
?? TITLE := 'skip_line', EJECT ??

    PROCEDURE [INLINE] skip_line;


      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        EXIT clp$display_cmnd_or_func_info;
      IFEND;

    PROCEND skip_line;
*IF NOT $true(osv$unix)
?? TITLE := 'display_help_information', EJECT ??

    PROCEDURE display_help_information
      (    include_advanced_items: boolean;
       VAR status: ost$status);

      VAR
        parameter: clt$parameter_number;


      skip_line;

      IF pdt.header^.number_of_parameters = 0 THEN
        put_line ('No parameters.');
        RETURN;
      IFEND;

      put_line ('Parameters:');

      request.initial_indentation := 0;
      request.continuation_indentation := 8;
      request.max_string := display_control.page_width;
      request.include_advanced_items := include_advanced_items;
      request.include_hidden_items := FALSE;
      request.kind := clc$convert_unbundled_pdt;
      request.multi_line_pdt_format := TRUE;
      request.parameter_starts_line := TRUE;
      request.individual_parameter := TRUE;
      request.include_header := FALSE;
      request.command_or_function_name := osc$null_name;
      request.aliases := NIL;
      request.availability := clc$normal_usage_entry;
      request.command_or_function_scope := clc$xdcl_command_or_function;
      request.pdt := ^pdt;
      request.pvt := NIL;
      request.symbolic_pdt_qualifiers_area := NIL;
      request.include_implementation_info := FALSE;

    /process_parameters/
      FOR parameter := 1 TO pdt.header^.number_of_parameters DO
        CASE pdt.parameters^ [parameter].availability OF
        = clc$normal_usage_entry =
          ;
        = clc$advanced_usage_entry =
          IF NOT include_advanced_items THEN
            CYCLE /process_parameters/;
          IFEND;
        ELSE { hidden
          CYCLE /process_parameters/;
        CASEND;

        parameter_name := pdt.names^ [pdt.parameters^ [parameter].name_index].name;
        osp$find_parameter_help_message (help_module, parameter_name, message_template, ignore_status);
        IF message_template <> NIL THEN
          convert_name_to_message_param (parameter_name);
          message_parameters [1] := ^parameter_name;
          osp$format_help_message (message_template, ^message_parameters, display_control.page_width, message,
                status);
          IF status.normal THEN
            put_message (message);
          ELSE
            request.individual_parameter_number := parameter;
            clp$internal_convert_to_string (request, work_area^, representation, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            put_representation;
          IFEND;
        ELSE
          request.individual_parameter_number := parameter;
          clp$internal_convert_to_string (request, work_area^, representation, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          put_representation;
        IFEND;
      FOREND /process_parameters/;

    PROCEND display_help_information;
*IFEND
?? TITLE := 'display_all_parameters', EJECT ??

    PROCEDURE display_all_parameters
      (    compact_parameter_descriptions: boolean;
           include_advanced_items: boolean;
       VAR status: ost$status);


      skip_line;

      IF pdt.header^.number_of_parameters = 0 THEN
        put_line ('No parameters.');
        RETURN;
      IFEND;

      put_line ('Parameters:');

      request.initial_indentation := 0;
      request.continuation_indentation := 8;
*IF NOT $true(osv$unix)
      request.max_string := display_control.page_width;
*ELSE
      request.max_string := 80;
*IFEND
      request.include_advanced_items := include_advanced_items;
      request.include_hidden_items := FALSE;
      request.kind := clc$convert_unbundled_pdt;
      request.multi_line_pdt_format := NOT compact_parameter_descriptions;
      request.parameter_starts_line := TRUE;
      request.individual_parameter := FALSE;
      request.individual_parameter_number := LOWERVALUE (clt$parameter_number);
      request.include_header := FALSE;
      request.command_or_function_name := osc$null_name;
      request.aliases := NIL;
      request.availability := clc$normal_usage_entry;
      request.command_or_function_scope := clc$xdcl_command_or_function;
      request.pdt := ^pdt;
      request.pvt := NIL;
      request.symbolic_pdt_qualifiers_area := NIL;
      request.include_implementation_info := FALSE;

      clp$internal_convert_to_string (request, work_area^, representation, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      put_representation;

    PROCEND display_all_parameters;
*IF NOT $true(osv$unix)
?? TITLE := 'convert_name_to_message_param', EJECT ??

    PROCEDURE [INLINE] convert_name_to_message_param
      (VAR name {input, output} : ost$name);

      VAR
        i: 1 .. osc$max_name_size,
        new_word: boolean;


      new_word := TRUE;
      FOR i := 1 TO osc$max_name_size DO
        IF name (i) = ' ' THEN
          RETURN;
        ELSEIF name (i) = '_' THEN
          name (i) := ' ';
          new_word := TRUE;
        ELSEIF new_word THEN
          new_word := FALSE;
        ELSE
          name (i) := osv$upper_to_lower ($INTEGER (name (i)) + 1);
        IFEND;
      FOREND;

    PROCEND convert_name_to_message_param;
*IFEND
?? TITLE := 'put_representation', EJECT ??

    PROCEDURE [INLINE] put_representation;

      VAR
        representation_line: ^clt$string_value,
        representation_line_count: ^clt$data_representation_count,
        representation_line_index: clt$data_representation_count,
        representation_line_size: ^clt$string_size;


      RESET representation;
      NEXT representation_line_count IN representation;

      skip_line;
      FOR representation_line_index := 1 TO representation_line_count^ DO
        NEXT representation_line_size IN representation;
        NEXT representation_line: [representation_line_size^] IN representation;
        put_line (representation_line^);
      FOREND;

    PROCEND put_representation;
?? OLDTITLE, EJECT ??

    VAR
      compact_parameter_descriptions: boolean,
*IF NOT $true(osv$unix)
      default_ring_attributes: amt$ring_attributes,
*IFEND
      display_control: clt$display_control,
*IF $true(osv$unix)
      handler_established: boolean,
*ELSE
      help_module: ^ost$help_module,
      ignore_natural_language: ost$natural_language,
*IFEND
      ignore_status: ost$status,
      include_advanced_items: boolean,
*IF NOT $true(osv$unix)
      message: ost$status_message,
      message_parameters: array [1 .. 1] of ^ost$message_parameter,
      message_template: ^ost$message_template,
      online_manual_name: ost$online_manual_name,
*IFEND
      parameters_displayed: boolean,
      parameter_name: clt$parameter_name,
      representation: ^clt$data_representation,
      request: clt$convert_to_string_request,
      work_area: ^^clt$work_area;


    status.normal := TRUE;
*IF NOT $true(osv$unix)
    display_control := clv$nil_display_control;
    #SPOIL (display_control);

*IF NOT $true(osv$unix)
    default_ring_attributes.r1 := help_context.help_output_ring;
    default_ring_attributes.r2 := help_context.help_output_ring;
    default_ring_attributes.r3 := help_context.help_output_ring;
*ELSE
    default_ring_attributes.r1 := osc$user_ring;
    default_ring_attributes.r2 := osc$user_ring;
    default_ring_attributes.r3 := osc$user_ring;
*IFEND

    osp$establish_block_exit_hndlr (^abort_handler);
*IFEND
*IF $true(osv$unix)
    handler_established := #establish_condition_handler (-1, ^abort_handler);
*IFEND

  /display_info/
    BEGIN
*IF NOT $true(osv$unix)
      clp$open_display_reference (help_context.help_output_file^, ^clp$new_page_procedure,
            default_file_contents, default_ring_attributes, display_control, status);
*ELSE
      clp$open_display_reference (help_context.help_output_file^, NIL,
            default_file_contents, display_control, status);
*IFEND
      IF NOT status.normal THEN
*IF NOT $true(osv$unix)
        osp$disestablish_cond_handler;
*ELSE
        IF handler_established THEN
          handler_established := NOT #disestablish_condition_handler (-1);
        IFEND;
*IFEND
        RETURN;
      IFEND;

      clv$titles_built := FALSE;
      IF pdt.header^.command_or_function = clc$command THEN
        clv$command_name := 'display_command_information';
      ELSE {clc$function}
        clv$command_name := 'display_function_information';
      IFEND;

*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^work_area), work_area, status);
*ELSE
      clp$get_work_area (osc$user_ring, work_area, status);
*IFEND
      IF NOT status.normal THEN
        EXIT /display_info/;
      IFEND;

*IF NOT $true(osv$unix)
      IF clc$ph_help_module_name IN help_context.help_output_options THEN
        display_help_module_name;
      IFEND;
*IFEND

      IF clc$ph_all_names IN help_context.help_output_options THEN
        display_all_names (status);
        IF NOT status.normal THEN
          EXIT /display_info/;
        IFEND;
      IFEND;

      IF clc$ph_source IN help_context.help_output_options THEN
        display_source (status);
        IF NOT status.normal THEN
          EXIT /display_info/;
        IFEND;
      IFEND;

      include_advanced_items := clc$ph_advanced_usage IN help_context.help_output_options;

      parameters_displayed := FALSE;
*IF NOT $true(osv$unix)
      IF ($clt$parameter_help_options [clc$ph_brief_help, clc$ph_full_help,
            clc$ph_parameter_help] * help_context.help_output_options) <> $clt$parameter_help_options [] THEN
        osp$find_help_module (pdt.header^.help_module_name, help_module, online_manual_name,
              ignore_natural_language, ignore_status);
        IF help_module <> NIL THEN
          IF clc$ph_full_help IN help_context.help_output_options THEN
            get_full_help;
          ELSEIF clc$ph_brief_help IN help_context.help_output_options THEN
            get_brief_help;
          IFEND;
          IF clc$ph_parameter_help IN help_context.help_output_options THEN
            display_help_information (include_advanced_items, status);
            IF NOT status.normal THEN
              EXIT /display_info/;
            IFEND;
            parameters_displayed := TRUE;
          IFEND;
        IFEND;
      IFEND;
*IFEND
      IF (NOT parameters_displayed) AND (($clt$parameter_help_options
            [clc$ph_parameter_help, clc$ph_parameter_descriptions, clc$ph_compact_par_descriptions,
            clc$ph_advanced_usage] * help_context.help_output_options) <> $clt$parameter_help_options []) THEN
        compact_parameter_descriptions := (clc$ph_compact_par_descriptions IN
              help_context.help_output_options) AND (($clt$parameter_help_options
              [clc$ph_parameter_help, clc$ph_parameter_descriptions] * help_context.help_output_options) =
              $clt$parameter_help_options []);
        display_all_parameters (compact_parameter_descriptions, include_advanced_items, status);
      IFEND;
    END /display_info/;

*IF $true(osv$unix)
    IF clc$ph_man IN help_context.help_output_options THEN
      osp$set_status_abnormal ('CL', cle$unknown_command, '', status);
    IFEND;

*IFEND
    IF status.normal THEN
      clp$close_display (display_control, status);
    ELSE
      clp$close_display (display_control, ignore_status);
    IFEND;

*IF NOT $true(osv$unix)
    osp$disestablish_cond_handler;
*ELSE
    IF handler_established THEN
      handler_established := NOT #disestablish_condition_handler (-1);
    IFEND;
*IFEND

  PROCEND clp$display_cmnd_or_func_info;
?? TITLE := 'clp$get_all_cmnd_or_func_names', EJECT ??

  PROCEDURE [XDCL] clp$get_all_cmnd_or_func_names
    (    command_or_function: clt$command_or_function;
         command_or_function_source: clt$command_or_function_source;
         command_or_function_name: clt$command_name;
     VAR work_area {input, output} : ^clt$work_area;
     VAR names: ^array [1 .. * ] of clt$command_name;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      command_list: ^clt$command_list,
      ignore_cmnd_list_in_this_task: boolean;

?? NEWTITLE := 'get_command_names', EJECT ??

    PROCEDURE get_command_names
      (    entries: ^clt$command_table);

      VAR
        abbrev_count: integer,
        abbreviation: ost$name,
        alias_count: integer,
        aliases: ^array [1 .. * ] of clt$command_name,
        index: integer,
        nominal_name: ost$name;


      alias_count := 0;
      abbrev_count := 0;

      PUSH aliases: [1 .. UPPERBOUND (entries^)];

      FOR index := 1 TO UPPERBOUND (entries^) DO
        IF (entries^ [index].ordinal = command_or_function_source.ordinal) THEN
          IF entries^ [index].class = clc$nominal_entry THEN
            nominal_name := entries^ [index].name;
          ELSEIF entries^ [index].class = clc$alias_entry THEN
            alias_count := alias_count + 1;
            aliases^ [alias_count] := entries^ [index].name;
          ELSE
            abbrev_count := abbrev_count + 1;
            abbreviation := entries^ [index].name;
          IFEND;
        IFEND;
      FOREND;

      NEXT names: [1 .. (alias_count + abbrev_count + 1)] IN work_area;
      IF names = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT clp$get_all_cmnd_or_func_names;
      IFEND;

      names^ [1] := nominal_name;
      FOR index := 1 TO alias_count DO
        names^ [index + 1] := aliases^ [index];
      FOREND;
      IF abbrev_count = 1 THEN
        names^ [UPPERBOUND (names^)] := abbreviation;
      IFEND;

    PROCEND get_command_names;
?? TITLE := 'get_contemporary_func_names', EJECT ??

    PROCEDURE get_contemporary_func_names
      (    entries: ^clt$function_processor_table);

      VAR
        abbrev_count: integer,
        abbreviation: ost$name,
        alias_count: integer,
        aliases: ^array [1 .. * ] of ost$name,
        index: integer,
        nominal_name: ost$name;


      alias_count := 0;
      abbrev_count := 0;

      PUSH aliases: [1 .. UPPERBOUND (entries^)];

      FOR index := 1 TO UPPERBOUND (entries^) DO
        IF (entries^ [index].ordinal = command_or_function_source.ordinal) THEN
          IF entries^ [index].class = clc$nominal_entry THEN
            nominal_name := entries^ [index].name;
          ELSEIF entries^ [index].class = clc$alias_entry THEN
            alias_count := alias_count + 1;
            aliases^ [alias_count] := entries^ [index].name;
          ELSE
            abbrev_count := abbrev_count + 1;
            abbreviation := entries^ [index].name;
          IFEND;
        IFEND;
      FOREND;

      NEXT names: [1 .. (alias_count + abbrev_count + 1)] IN work_area;
      IF names = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT clp$get_all_cmnd_or_func_names;
      IFEND;

      names^ [1] := nominal_name;
      FOR index := 1 TO alias_count DO
        names^ [index + 1] := aliases^ [index];
      FOREND;
      IF abbrev_count = 1 THEN
        names^ [UPPERBOUND (names^)] := abbreviation;
      IFEND;

    PROCEND get_contemporary_func_names;
*IF NOT $true(osv$unix)
?? TITLE := 'get_library_names', EJECT ??

    PROCEDURE get_library_names
      (    local_file_name: fst$path_handle_name;
           caller_id: ost$caller_identifier);

      VAR
        commands: ^clt$command_table,
        command_entries: ^llt$command_dictionary,
        ignore_ring_attributes: amt$ring_attributes,
        functions: ^clt$function_processor_table,
        function_entries: ^llt$function_dictionary;

?? NEWTITLE := 'convert_cmnd_dict_to_cmnds', EJECT ??

      PROCEDURE [INLINE] convert_cmnd_dict_to_cmnds
        (    dictionary_entries: llt$command_dictionary;
             ordinal_offset: integer;
         VAR command_entries: clt$command_table);

        VAR
          index: integer;


        FOR index := 1 TO UPPERBOUND (dictionary_entries) DO
          command_entries [index].name := dictionary_entries [index].name;
          command_entries [index].class := dictionary_entries [index].class;
          command_entries [index].availability := dictionary_entries [index].availability;
          command_entries [index].ordinal := dictionary_entries [index].ordinal + ordinal_offset;
        FOREND;

      PROCEND convert_cmnd_dict_to_cmnds;
?? TITLE := 'convert_func_dict_to_funcs', EJECT ??

      PROCEDURE [INLINE] convert_func_dict_to_funcs
        (    dictionary_entries: llt$function_dictionary;
             ordinal_offset: integer;
         VAR function_entries: clt$function_processor_table);

        VAR
          index: integer;


        FOR index := 1 TO UPPERBOUND (dictionary_entries) DO
          function_entries [index].name := dictionary_entries [index].name;
          function_entries [index].class := dictionary_entries [index].class;
          function_entries [index].availability := dictionary_entries [index].availability;
          function_entries [index].ordinal := dictionary_entries [index].ordinal + ordinal_offset;
        FOREND;

      PROCEND convert_func_dict_to_funcs;
?? OLDTITLE, EJECT ??
      VAR
        context: ^ost$ecp_exception_context;

      context := NIL;

      REPEAT
        clp$find_command_entries (local_file_name, work_area, ignore_ring_attributes, command_entries,
              function_entries, status);
        IF osp$file_access_condition (status) THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_file_reference;
            context^.file.file_reference := ^local_file_name;
          IFEND;

          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
      IF NOT status.normal THEN
        EXIT clp$get_all_cmnd_or_func_names;
      IFEND;

      IF (command_or_function = clc$command) AND (command_entries <> NIL) THEN
        PUSH commands: [1 .. UPPERBOUND (command_entries^)];
        convert_cmnd_dict_to_cmnds (command_entries^, 0, commands^);
        get_command_names (commands);
      IFEND;

      IF (command_or_function = clc$function) AND (function_entries <> NIL) THEN
        PUSH functions: [1 .. UPPERBOUND (function_entries^)];
        convert_func_dict_to_funcs (function_entries^, 0, functions^);
        get_contemporary_func_names (functions);
      IFEND;

    PROCEND get_library_names;
*IFEND
?? TITLE := 'get_original_func_names', EJECT ??

    PROCEDURE get_original_func_names
      (    entries: ^clt$function_table);

      VAR
        abbrev_count: integer,
        abbreviation: ost$name,
        alias_count: integer,
        aliases: ^array [1 .. * ] of ost$name,
        index: integer,
        nominal_name: ost$name;


      alias_count := 0;
      abbrev_count := 0;

      PUSH aliases: [1 .. UPPERBOUND (entries^)];

      FOR index := 1 TO UPPERBOUND (entries^) DO
        IF (entries^ [index].ordinal = command_or_function_source.ordinal) THEN
          IF entries^ [index].class = clc$nominal_entry THEN
            nominal_name := entries^ [index].name;
          ELSEIF entries^ [index].class = clc$alias_entry THEN
            alias_count := alias_count + 1;
            aliases^ [alias_count] := entries^ [index].name;
          ELSE
            abbrev_count := abbrev_count + 1;
            abbreviation := entries^ [index].name;
          IFEND;
        IFEND;
      FOREND;

      NEXT names: [1 .. (alias_count + abbrev_count + 1)] IN work_area;
      IF names = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT clp$get_all_cmnd_or_func_names;
      IFEND;

      names^ [1] := nominal_name;
      FOR index := 1 TO alias_count DO
        names^ [index + 1] := aliases^ [index];
      FOREND;
      IF abbrev_count = 1 THEN
        names^ [UPPERBOUND (names^)] := abbreviation;
      IFEND;

    PROCEND get_original_func_names;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    names := NIL;

    CASE command_or_function_source.kind OF

*IF NOT $true(osv$unix)
    = clc$catalog_commands =
      ;

    = clc$library_commands =
*IF NOT $true(osv$unix)
      #CALLER_ID (caller_id);
*ELSE
      caller_id.ring := osc$user_ring;
*IFEND
      get_library_names (command_or_function_source.local_file_name, caller_id);

*IFEND
    = clc$system_commands =
      IF command_or_function = clc$command THEN
        IF command_or_function_source.system_command_table <> NIL THEN
          get_command_names (command_or_function_source.system_command_table);
*IF NOT $true(osv$unix)
        ELSE
          clp$find_command_list (command_list, ignore_cmnd_list_in_this_task);
*IF NOT $true(osv$unix)
          #CALLER_ID (caller_id);
*ELSE
          caller_id.ring := osc$user_ring;
*IFEND
          get_library_names (command_list^.system_command_library_lfn, caller_id);
*IFEND
        IFEND;
*IF NOT $true(osv$unix)
      ELSEIF command_or_function_source.function_interface = clc$fi_original THEN
        get_original_func_names (clv$system_functions_v0);
      ELSE
        get_contemporary_func_names (clv$system_functions);
*IFEND
      IFEND;

    = clc$sub_commands =
      IF command_or_function = clc$command THEN
        IF command_or_function_source.auxilliary_table THEN
          get_command_names (command_or_function_source.utility_info^.dialog_info.commands);
        ELSE
          get_command_names (command_or_function_source.utility_info^.commands);
        IFEND;
*IF NOT $true(osv$unix)
      ELSEIF command_or_function_source.auxilliary_table THEN
        get_contemporary_func_names (command_or_function_source.utility_info^.dialog_info.functions);
*IFEND
      ELSEIF command_or_function_source.function_interface = clc$fi_original THEN
        get_original_func_names (command_or_function_source.utility_info^.original_functions);
      ELSE
        get_contemporary_func_names (command_or_function_source.utility_info^.contemporary_functions);
      IFEND;

    ELSE
      ;
    CASEND;

    IF names = NIL THEN
      NEXT names: [1 .. 1] IN work_area;
      IF names = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
      names^ [1] := command_or_function_name;
    IFEND;

  PROCEND clp$get_all_cmnd_or_func_names;
?? TITLE := 'clp$get_cmnd_or_func_source_str', EJECT ??

  PROCEDURE [XDCL] clp$get_cmnd_or_func_source_str
    (    command_or_function_source: clt$command_or_function_source;
     VAR source_string: fst$path;
     VAR source_string_size: fst$path_size;
     VAR status: ost$status);

    CONST
      system_indicator = '$SYSTEM',
      utility_indicator = 'Utility ';


    status.normal := TRUE;
    CASE command_or_function_source.kind OF

*IF NOT $true(osv$unix)
    = clc$catalog_commands, clc$library_commands =
      clp$get_path_name (command_or_function_source.local_file_name, osc$full_message_level, source_string);
      source_string_size := clp$trimmed_string_size (source_string);

*IFEND
    = clc$system_commands =
*IF $true(osv$unix)
      source_string := 'control_statements';
      source_string_size := 18;
*ELSE
      source_string := system_indicator;
      source_string_size := STRLENGTH (system_indicator);
*IFEND

    ELSE { clc$sub_commands }
      source_string (1, STRLENGTH (utility_indicator)) := utility_indicator;
      source_string (STRLENGTH (utility_indicator) + 1, * ) := command_or_function_source.utility_name;
      source_string_size := STRLENGTH (utility_indicator) +
            clp$trimmed_string_size (command_or_function_source.utility_name);
    CASEND;

  PROCEND clp$get_cmnd_or_func_source_str;

MODEND clm$display_cmnd_or_func_info;
*DECK DECK=CLM$DISPLAY_COMMAND_ENV_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Display Command Environment Command' ??
MODULE clm$display_command_env_command;

{
{ PURPOSE:
{   This module contains the processor for the display_command_environment command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$established_handler_index
*copyc clt$parameter_list
*copyc ost$status
?? POP ??
*copyc clp$close_display
*copyc clp$evaluate_parameters
*copyc clp$find_current_block
*copyc clp$get_path_name
*copyc clp$environment_object_name
*copyc clp$open_display_reference
*copyc clp$put_partial_display
*copyc clp$trimmed_string_size
*copyc clv$nil_display_control
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr

?? TITLE := 'clp$display_command_env_command', EJECT ??

  PROCEDURE [XDCL] clp$display_command_env_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$discs) display_command_stack, discs (
{   display_options, display_option, do: key
{       (brief, b)
{       (full, f)
{     keyend = brief
{   output, o: file = $output
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 6, 13, 16, 11, 8, 444],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'OSM$DISCS'], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 1],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 1],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BRIEF                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FULL                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'brief'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

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

    CONST
      p$display_options = 1,
      p$output = 2,
      p$status = 3;

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

    TYPE
      clt$command_kinds = set of clt$command_kind;

    VAR
      block: ^clt$block,
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      full_display: boolean,
      ignore_status: ost$status,
      line_number_string: string (16),
      line_number_string_length: integer;

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

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


      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;
?? TITLE := 'put', EJECT ??

    PROCEDURE put
      (    text: string ( * );
           trim_option: clt$trim_display_text_option;
           term_option: amt$term_option);


      clp$put_partial_display (display_control, text, trim_option, term_option, status);
      IF NOT status.normal THEN
        EXIT clp$display_command_env_command;
      IFEND;

    PROCEND put;
?? TITLE := 'put_environment_objects', EJECT ??

    PROCEDURE put_environment_objects
      (    info: ^clt$environment_object_info);

      VAR
        header_put: boolean,
        i: clt$environment_object_ordinal;


      IF info = NIL THEN
        RETURN;
      IFEND;

      header_put := FALSE;

      FOR i := LOWERVALUE (clt$environment_object_ordinal) TO UPPERVALUE (clt$environment_object_ordinal) DO
        IF info^.defined [i] THEN
          IF NOT header_put THEN
            put ('    Environment Objects ...', clc$no_trim, amc$terminate);
            header_put := TRUE;
          IFEND;
          put ('        ', clc$no_trim, amc$start);
          put (clp$environment_object_name (i) ^, clc$trim, amc$terminate);
        IFEND;
      FOREND;

    PROCEND put_environment_objects;
?? TITLE := 'put_established_handlers', EJECT ??

    PROCEDURE put_established_handlers
      (    info: clt$established_handler_info);

      VAR
        i: clt$established_handler_index;


      IF (info.specific_handler_count = 0) AND (info.any_fault_handler = NIL) AND
            (info.any_condition_handler = NIL) THEN
        RETURN;
      IFEND;

      put ('    Condition Handlers ...', clc$no_trim, amc$terminate);
      FOR i := 1 TO info.specific_handler_count DO
        put ('        ', clc$no_trim, amc$start);
        put (info.specific_handlers^ [i].condition, clc$trim, amc$terminate);
      FOREND;

      IF info.any_fault_handler <> NIL THEN
        put ('        ANY_FAULT', clc$no_trim, amc$terminate);
      IFEND;

      IF info.any_condition_handler <> NIL THEN
        put ('        ANY_CONDITION', clc$no_trim, amc$terminate);
      IFEND;

    PROCEND put_established_handlers;
?? TITLE := 'put_path_name', EJECT ??

    PROCEDURE put_path_name
      (    local_file_name: amt$local_file_name);

      VAR
        file_reference: fst$path;


      clp$get_path_name (local_file_name, osc$full_message_level, file_reference);
      put (file_reference (1, clp$trimmed_string_size (file_reference)), clc$no_trim, amc$continue);

    PROCEND put_path_name;
?? OLDTITLE, EJECT ??

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

    full_display := pvt [p$display_options].value^.keyword_value = 'FULL';

    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    osp$establish_block_exit_hndlr (^abort_handler);

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
    clp$open_display_reference (pvt [p$output].value^.file_value^, NIL, fsc$list, default_ring_attributes,
          display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

    clp$find_current_block (block);
    block := block^.previous_block;
    WHILE block <> NIL DO
      CASE block^.kind OF

      = clc$block_block =
        put ('BLOCK statement', clc$no_trim, amc$start);
        IF block^.label <> '' THEN
          put (', labelled: ', clc$no_trim, amc$continue);
          put (block^.label, clc$trim, amc$continue);
        IFEND;
        put ('.', clc$no_trim, amc$terminate);

      = clc$command_block =
        IF full_display OR (block^.command_kind IN $clt$command_kinds
              [clc$command_is_include_file, clc$command_is_include_line,
              clc$command_is_execute_task]) OR (block^.started_application) THEN
          put (block^.label, clc$trim, amc$start);
          put (' command', clc$no_trim, amc$continue);
          IF (block^.started_application) AND (block^.application_info <> NIL) THEN
            put ('(application identifier = ', clc$no_trim, amc$continue);
            put (block^.application_info^.identifier.name, clc$trim, amc$continue);
            put (', nested application identifier = ', clc$no_trim, amc$continue);
            put (block^.application_info^.nested_identifier.name, clc$trim, amc$continue);
            IF block^.application_info^.application_scheduling THEN
              put (', application scheduling = TRUE', clc$trim, amc$continue);
            IFEND;
            put (')', clc$no_trim, amc$continue);
          IFEND;
          put ('.', clc$no_trim, amc$terminate);
        IFEND;

      = clc$for_block =
        put ('FOR statement', clc$no_trim, amc$start);
        IF block^.label <> '' THEN
          put (', labelled: ', clc$no_trim, amc$continue);
          put (block^.label, clc$trim, amc$continue);
        IFEND;
        put (', control variable: ', clc$no_trim, amc$continue);
        put (block^.for_variable^, clc$trim, amc$continue);
        put ('.', clc$no_trim, amc$terminate);

      = clc$if_block =
        put ('IF statement', clc$no_trim, amc$start);
        put ('.', clc$no_trim, amc$terminate);

      = clc$input_block =
        IF full_display THEN
          CASE block^.input.kind OF
          = clc$line_input =
            put ('Input from line', clc$no_trim, amc$start);
          = clc$sequence_input =
            IF block^.label <> '' THEN
              put (block^.label, clc$trim, amc$start);
              put (' input from internal file', clc$no_trim, amc$continue);
            ELSE
              put ('Input from internal file', clc$no_trim, amc$start);
            IFEND;
          = clc$file_input =
            IF block^.label <> '' THEN
              put (block^.label, clc$trim, amc$start);
              put (' input from file ', clc$no_trim, amc$continue);
            ELSE
              put ('Input from file ', clc$no_trim, amc$start);
            IFEND;
            put_path_name (block^.input.local_file_name);
            STRINGREP (line_number_string, line_number_string_length, ' at line', block^.input.record_number);
            put (line_number_string (1, line_number_string_length), clc$no_trim, amc$continue);
          CASEND;
          put ('.', clc$no_trim, amc$terminate);
        IFEND;

      = clc$loop_block =
        put ('LOOP statement', clc$no_trim, amc$start);
        IF block^.label <> '' THEN
          put (', labelled: ', clc$no_trim, amc$continue);
          put (block^.label, clc$trim, amc$continue);
        IFEND;
        put ('.', clc$no_trim, amc$terminate);

      = clc$command_proc_block =
        put ('PROCEDURE ', clc$no_trim, amc$start);
        put (block^.label, clc$trim, amc$continue);
        put (' from file ', clc$no_trim, amc$continue);
        put_path_name (block^.input.local_file_name);
        STRINGREP (line_number_string, line_number_string_length, ' at line', block^.input.record_number);
        put (line_number_string (1, line_number_string_length), clc$no_trim, amc$continue);
        IF (block^.started_application) AND (block^.application_info <> NIL) THEN
          put ('(application identifier = ', clc$no_trim, amc$continue);
          put (block^.application_info^.identifier.name, clc$trim, amc$continue);
          put (', nested application identifier = ', clc$no_trim, amc$continue);
          put (block^.application_info^.nested_identifier.name, clc$trim, amc$continue);
          put (')', clc$no_trim, amc$continue);
        IFEND;
        put ('.', clc$no_trim, amc$terminate);

      = clc$repeat_block =
        put ('REPEAT statement', clc$no_trim, amc$start);
        IF block^.label <> '' THEN
          put (', labelled: ', clc$no_trim, amc$continue);
          put (block^.label, clc$trim, amc$continue);
        IFEND;
        put ('.', clc$no_trim, amc$terminate);

      = clc$sub_parameters_block =
        IF full_display THEN
          put ('"Sub-parameters" block', clc$no_trim, amc$start);
          put ('.', clc$no_trim, amc$terminate);
        IFEND;

      = clc$task_block =
        CASE block^.task_kind OF
        = clc$job_monitor_task =
          put ('Job', clc$no_trim, amc$start);
          put ('.', clc$no_trim, amc$terminate);
        = clc$task_statement_task =
          IF block^.synchronous_with_parent THEN
            put ('Synchronous TASK statement', clc$no_trim, amc$start);
          ELSE
            put ('Asynchronous TASK statement', clc$no_trim, amc$start);
          IFEND;
          put ('.', clc$no_trim, amc$terminate);
        = clc$other_task =
          IF full_display THEN
            IF block^.synchronous_with_parent THEN
              put ('Synchronous task', clc$no_trim, amc$start);
            ELSE
              put ('Asynchronous task', clc$no_trim, amc$start);
            IFEND;
            put ('.', clc$no_trim, amc$terminate);
          IFEND;
        CASEND;

      = clc$utility_block =
        put (block^.label, clc$trim, amc$start);
        put (' utility.', clc$no_trim, amc$terminate);

      = clc$when_block =
        put ('WHEN statement for condition ', clc$no_trim, amc$start);
        put (block^.when_condition^.name, clc$trim, amc$continue);
        put ('.', clc$no_trim, amc$terminate);

      = clc$while_block =
        put ('WHILE statement', clc$no_trim, amc$start);
        IF block^.label <> '' THEN
          put (', labelled: ', clc$no_trim, amc$continue);
          put (block^.label, clc$trim, amc$continue);
        IFEND;
        put ('.', clc$no_trim, amc$terminate);

      ELSE
        IF full_display THEN
          put ('"Unknown" block type.', clc$no_trim, amc$terminate);
        IFEND;
      CASEND;

      IF full_display THEN
        put_environment_objects (block^.environment_object_info);
        put_established_handlers (block^.established_handler_info);
      IFEND;

      block := block^.previous_block;
    WHILEND;

    clp$close_display (display_control, status);

    osp$disestablish_cond_handler;

  PROCEND clp$display_command_env_command;

MODEND clm$display_command_env_command;
*DECK DECK=CLM$DISPLAY_COMMAND_LIST EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Display Command List' ??
MODULE clm$display_command_list;

{
{ PURPOSE:
{   This module contains the processor for the display_command_list command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$parameter_list
*copyc clt$path_display_chunks
*copyc clt$work_area
*IF $true(osv$unix)
*copyc cyt$mips_signal_handler
*IFEND
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$find_command_list
*copyc clp$find_current_block
*IF NOT $true(osv$unix)
*copyc clp$get_command_search_mode
*copyc clp$get_path_name
*IFEND
*copyc clp$horizontal_tab_display
*copyc clp$make_file_value
*copyc clp$make_keyword_value
*copyc clp$make_list_value
*copyc clp$make_name_value
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$trimmed_string_size
*copyc clv$nil_display_control
*IF NOT $true(osv$unix)
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*IFEND
*copyc osp$set_status_abnormal
*copyc osv$upper_to_lower

?? TITLE := 'clp$_display_command_list', EJECT ??

  PROCEDURE [XDCL] clp$_display_command_list
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
{ PROCEDURE (osm$discl) display_command_list, discl (
{   display_options, display_option, do: list of key
{       all
{       (entries, entry, e)
{       (search_mode, sm)
{     keyend = entries
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 6] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 6] of clt$keyword_specification,
          recend,
          default_value: string (7),
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 20, 13, 54, 55, 895], clc$command, 6, 3, 0, 0, 0, 0, 3, 'OSM$DISCL'],
            [['DISPLAY_OPTION                 ', clc$alias_entry, 1],
            ['DISPLAY_OPTIONS                ', clc$nominal_entry, 1],
            ['DO                             ', clc$abbreviation_entry, 1],
            ['O                              ', clc$abbreviation_entry, 2],
            ['OUTPUT                         ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 245, clc$optional_default_parameter, 0, 7],

{ PARAMETER 2

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 3

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$list_type], [229, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [6], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['E                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['ENTRIES                        ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['ENTRY                          ', clc$alias_entry,
            clc$normal_usage_entry, 2], ['SEARCH_MODE                    ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['SM                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3]]], 'entries'],

{ PARAMETER 2

      [[1, 0, clc$file_type], '$output'],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$display_options = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;
*ELSE
{ PROCEDURE (osm$discl) display_command_list, discl (
{   display_options, display_option, do: list of key
{       all
{       (entries, entry, e)
{     keyend = entries
{   output, o: file = $output
{   status)



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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: 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 .. 4] of clt$keyword_specification,
        recend,
        default_value: ALIGNED [0 MOD 4] string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: ALIGNED [0 MOD 4] string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [2,
    [91, 8, 1, 8, 20, 33, 0],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'OSM$DISCL'], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 1],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 1],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 196, clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[2, 0, clc$list_type], [168, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[2, 0, clc$keyword_type], [4], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['E                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
      ['ENTRIES                        ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['ENTRY                          ', clc$alias_entry,
  clc$normal_usage_entry, 2]]
      ]
    ,
    'entries'],
{ PARAMETER 2
    [[2, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[2, 0, clc$status_type]]];

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

    CONST
      p$display_options = 1,
      p$output = 2,
      p$status = 3;

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

*copyc clv$display_variables

    CONST
      minimum_display_line = osc$max_name_size + 3,
      minimum_line_size = osc$max_name_size + 3,
      brief_header_length = 13,
      full_header_length = 7,
      system_entry_length = 7,
      subentry_column = 3,
      entry_name_size = osc$max_name_size + 1;

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

    PROCEDURE abort_handler
*IF $true(osv$unix)
      (    signal_no: integer;
           code: integer;
           p_sigcontext: ^cyt$mips_sigcontext);

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);
*ELSE
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      clp$close_display (display_control, handler_status);
      handler_status.normal := TRUE;
*IFEND

    PROCEND abort_handler;
*copyc clp$new_page_procedure
?? TITLE := 'put_partial_display', EJECT ??

    PROCEDURE put_partial_display
      (    str: string ( * );
           trim_option: clt$trim_display_text_option;
           term_option: amt$term_option);


      clp$put_partial_display (display_control, str, trim_option, term_option, status);
      IF NOT status.normal THEN
        EXIT clp$_display_command_list;
      IFEND;

    PROCEND put_partial_display;
?? TITLE := 'put_path_chunks', EJECT ??

    PROCEDURE put_path_chunks
      (    path_name: string ( * );
           display_chunks: clt$path_display_chunks;
           chunk_count: 0 .. fsc$max_path_elements;
           column: amt$page_width);

      VAR
        i: 0 .. fsc$max_path_elements,
        terminate_string: string (2);


      terminate_string := '..';
      FOR i := 1 TO chunk_count DO
        clp$horizontal_tab_display (display_control, column, status);
        IF NOT status.normal THEN
          EXIT clp$_display_command_list;
        IFEND;
        IF i = chunk_count THEN
          terminate_string := '  ';
        IFEND;
        put_partial_display (path_name (display_chunks [i].position, display_chunks [i].length),
              clc$trim, amc$continue);
        put_partial_display (terminate_string, clc$trim, amc$terminate);
      FOREND;

    PROCEND put_path_chunks;
?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

{ The display_command_list command has no subtitles,
{ this is merely a dummy routine used to keep
{ the module consistent with those that do produce subtitles.

    PROCEND put_subtitle;
?? TITLE := 'display_entry_names', EJECT ??

    PROCEDURE display_entry_names
      (    start_of_list: ^clt$command_list_entry;
           end_of_list: ^clt$command_list_entry;
       VAR status: ost$status);

      CONST
        unaccessible = '     "UNACCESSIBLE"';

      VAR
        chunk_count: 0 .. fsc$max_path_elements,
        current_entry: ^clt$command_list_entry,
        display_chunks: clt$path_display_chunks,
        display_line: ^string (*),
        display_line_length: integer,
        entries_written: boolean,
        line_size: amt$page_width,
        utility_name: clt$utility_name;


      status.normal := TRUE;
      current_entry := start_of_list;
      IF display_control.page_width < minimum_display_line THEN
        line_size := minimum_line_size;
      ELSE
        line_size := display_control.page_width;
      IFEND;
      entries_written := FALSE;

      WHILE current_entry <> end_of_list DO
        IF NOT entries_written THEN
          put_partial_display ('Entries are', clc$no_trim, amc$continue);
        IFEND;

        CASE current_entry^.kind OF

*IF NOT $true(osv$unix)
        = clc$catalog_commands, clc$library_commands =
          clp$get_path_name (current_entry^.local_file_name, osc$full_message_level, file_reference);
          display_line_length := clp$trimmed_string_size (file_reference);
          IF current_entry^.unaccessible_entry THEN
            PUSH display_line: [display_line_length + STRLENGTH (unaccessible)];
            STRINGREP (display_line^, display_line_length, file_reference (1,display_line_length),
                  unaccessible);
          ELSE
            display_line := ^file_reference;
          IFEND;
          clp$build_path_subtitle (display_line^, display_line_length,
                (line_size - brief_header_length), chunk_count, display_chunks);
          put_path_chunks (display_line^, display_chunks, chunk_count, brief_header_length + 1);

        = clc$working_catalog_commands =
          clp$horizontal_tab_display (display_control, brief_header_length + 1, status);
          IF NOT status.normal THEN
            EXIT clp$_display_command_list;
          IFEND;
          put_partial_display (':$working_catalog', clc$trim, amc$terminate);
*IFEND

        = clc$system_commands =
          clp$horizontal_tab_display (display_control, brief_header_length + 1, status);
          IF NOT status.normal THEN
            EXIT clp$_display_command_list;
          IFEND;
          put_partial_display ('$system', clc$trim, amc$terminate);

        = clc$sub_commands =
          clp$horizontal_tab_display (display_control, brief_header_length + 1, status);
          IF NOT status.normal THEN
            EXIT clp$_display_command_list;
          IFEND;
          #TRANSLATE (osv$upper_to_lower, current_entry^.utility_name, utility_name);
          put_partial_display (utility_name, clc$trim, amc$terminate);

        = clc$command_list_fence =
          clp$horizontal_tab_display (display_control, brief_header_length + 1, status);
          IF NOT status.normal THEN
            EXIT clp$_display_command_list;
          IFEND;
          put_partial_display ('fence', clc$trim, amc$terminate);

        ELSE
          ;
        CASEND;

        entries_written := TRUE;

        current_entry := current_entry^.next_entry;
      WHILEND;

      IF NOT entries_written THEN
        put_partial_display ('The command list is empty.', clc$no_trim, amc$terminate);
      IFEND;

    PROCEND display_entry_names;
?? OLDTITLE, EJECT ??

    VAR
      block: ^clt$block,
      command_list: ^clt$command_list,
      current_node: ^clt$data_value,
*IF NOT $true(osv$unix)
      default_ring_attributes: amt$ring_attributes,
*IFEND
      display_control: clt$display_control,
      effective_search_mode: clt$command_search_modes,
      end_of_list: ^clt$command_list_entry,
      entries: boolean,
      file_reference: fst$path,
*IF $true(osv$unix)
      handler_established: boolean,
*IFEND
      index: integer,
      ignore_cmnd_list_found_in_task: boolean,
      local_status: ost$status,
      search: boolean,
*IF NOT $true(osv$unix)
      search_modes: [STATIC, READ, oss$job_paged_literal] array [clt$command_search_modes] of string (10) :=
            ['global', 'restricted', 'exclusive'],
*IFEND
      start_of_list: ^clt$command_list_entry;


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

    entries := FALSE;
    search := FALSE;

    current_node := pvt [p$display_options].value;
    WHILE current_node <> NIL DO
      IF current_node^.element_value^.keyword_value = 'ENTRIES' THEN
        entries := TRUE;
      ELSEIF current_node^.element_value^.keyword_value = 'SEARCH_MODE' THEN
        search := TRUE;
      ELSE {ALL}
        entries := TRUE;
        search := TRUE;
      IFEND;
      current_node := current_node^.link;
    WHILEND;

    display_control := clv$nil_display_control;
    #SPOIL (display_control);
*IF NOT $true(osv$unix)
    osp$establish_block_exit_hndlr (^abort_handler);

*IF NOT $true(osv$unix)
    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
*ELSE
    default_ring_attributes.r1 := osc$user_ring;
    default_ring_attributes.r2 := osc$user_ring;
    default_ring_attributes.r3 := osc$user_ring;
*IFEND

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          default_ring_attributes, display_control, status);
*ELSE
    handler_established := #establish_condition_handler (-1, ^abort_handler);

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          display_control, status);
*IFEND
    IF NOT status.normal THEN
*IF $true(osv$unix)
      IF handler_established THEN
        handler_established := NOT #disestablish_condition_handler (-1);
      IFEND;
*ELSE
      osp$disestablish_cond_handler;
*IFEND
      RETURN;
    IFEND;
    clv$titles_built := FALSE;
    clv$command_name := 'display_command_list';

    clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);

*IF NOT $true(osv$unix)
    IF search THEN
      put_partial_display ('Search Mode is ', clc$no_trim, amc$start);
      put_partial_display (search_modes [command_list^.search_mode], clc$trim, amc$terminate);
    IFEND;
*IFEND

    IF entries THEN
      clp$find_current_block (block);
      start_of_list := command_list^.entries.first_entry;
      IF block^.previous_block^.use_command_search_mode THEN
        effective_search_mode := command_list^.search_mode;
      ELSE
        effective_search_mode := clc$global_command_search;
      IFEND;
      IF effective_search_mode = clc$exclusive_command_search THEN
        end_of_list := command_list^.entries.entry_after_fence;
      ELSE
        end_of_list := NIL;
      IFEND;
      display_entry_names (start_of_list, end_of_list, status);
    IFEND;

    clp$close_display (display_control, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

*IF $true(osv$unix)
    IF handler_established THEN
      handler_established := NOT #disestablish_condition_handler (-1);
    IFEND;
*ELSE
    osp$disestablish_cond_handler;
*IFEND

  PROCEND clp$_display_command_list;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$$command_list', EJECT ??

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

{ FUNCTION (osm$$coml) $command_list

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 3, 30, 15, 15, 19, 104],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$COML']];

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

    VAR
      command_list: ^clt$command_list,
      current_entry: ^clt$command_list_entry,
      file_reference: fst$path,
      ignore_cmnd_list_found_in_task: boolean,
      result_node: ^^clt$data_value;


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

    clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);

    current_entry := command_list^.entries.first_entry;
    result_node := ^result;

    WHILE current_entry <> NIL DO
      clp$make_list_value (work_area, result_node^);
      IF result_node^ = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;

      CASE current_entry^.kind OF
      = clc$catalog_commands, clc$library_commands =
        clp$get_path_name (current_entry^.local_file_name, osc$full_message_level, file_reference);
        clp$make_file_value (file_reference (1, clp$trimmed_string_size (file_reference)), work_area,
              result_node^^.element_value);
      = clc$working_catalog_commands =
        clp$make_file_value (':$WORKING_CATALOG', work_area, result_node^^.element_value);
      = clc$system_commands =
        clp$make_keyword_value ('$SYSTEM', work_area, result_node^^.element_value);
      = clc$sub_commands =
        clp$make_name_value (current_entry^.utility_name, work_area, result_node^^.element_value);
      = clc$command_list_fence =
        clp$make_keyword_value ('FENCE', work_area, result_node^^.element_value);
      ELSE
        ;
      CASEND;

      IF result_node^^.element_value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;

      result_node := ^result_node^^.link;
      current_entry := current_entry^.next_entry;
    WHILEND;

    IF result = NIL THEN
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
    IFEND;

  PROCEND clp$$command_list;
?? TITLE := 'clp$$command_search_mode', EJECT ??

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

{ FUNCTION (osm$$comsm) $command_search_mode

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 3, 30, 15, 15, 19, 104],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$COMSM']];

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

    VAR
      result_node: ^^clt$data_value,
      search_mode: clt$command_search_modes,
      search_modes: [STATIC, READ, oss$job_paged_literal] array [clt$command_search_modes] of string (10) :=
            ['GLOBAL', 'RESTRICTED', 'EXCLUSIVE'];


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

    clp$get_command_search_mode (search_mode);

    clp$make_keyword_value (search_modes [search_mode], work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$command_search_mode;
*IFEND

MODEND clm$display_command_list;
*DECK DECK=CLM$DISPLAY_COMMAND_LIST_ENTRY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL interpreter : Display Command List Entry' ??
MODULE clm$display_command_list_entry;

{
{ PURPOSE:
{   This module contains the processor for the display_command_list_entry command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$compiling_for_test_harness
*IF $true(osv$unix)
*copyc cle$ecc_utilities
*IFEND
*copyc cle$work_area_overflow
*copyc clt$command_list
*copyc clt$data_value
*copyc clt$parameter_list
*copyc clt$path_display_chunks
*copyc clt$work_area
*IF $true(osv$unix)
*copyc cyt$mips_signal_handler
*ELSE
*copyc fsc$compiling_for_test_harness
*copyc fst$path_handle_name
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*IFEND
*copyc ost$name_reference
*IF NOT $true(osv$unix)
*copyc pfe$error_condition_codes
*IFEND
?? POP ??
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$close_command_library
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*IF NOT $true(osv$unix)
*copyc clp$convert_string_to_file
*copyc clp$convert_string_to_file_ref
*IFEND
*copyc clp$evaluate_parameters
*IF NOT $true(osv$unix)
*copyc clp$find_command_entries
*IFEND
*copyc clp$find_command_list
*copyc clp$find_current_block
*copyc clp$get_work_area
*copyc clp$horizontal_tab_display
*copyc clp$make_command_ref_value
*copyc clp$make_list_value
*copyc clp$make_name_value
*copyc clp$new_display_line
*copyc clp$new_display_page
*IF NOT $true(osv$unix)
*copyc clp$open_command_library
*IFEND
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$trimmed_string_size
*copyc clv$intrinsic_commands
*copyc clv$nil_display_control
*IF NOT $true(osv$unix)
*copyc clv$operator_commands
*copyc clv$system_commands
*IFEND
*copyc clv$system_functions
*copyc clv$system_functions_v0
*IF NOT $true(osv$unix)
  ?IF fsc$compiling_for_test_harness AND clc$compiling_for_test_harness THEN
*copyc fsv$test_harness_cmnds
*copyc fsv$test_harness_fnctns
  ?IFEND
*copyc jmp$system_job
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$establish_block_exit_hndlr
*copyc osp$file_access_condition
*IFEND
*copyc osp$set_status_abnormal
*IF NOT $true(osv$unix)
*copyc osv$initial_exception_context
*IFEND
*copyc osv$upper_to_lower
?? EJECT ??

  TYPE
    entry_type = record
      name: ost$name,
      class: clt$named_entry_class,
      availability: clt$named_entry_availability,
      ordinal: clt$named_entry_ordinal,
    recend;

  TYPE
    entry_array = array [1 .. * ] of entry_type;

  TYPE
    option_type = record
      all_entries: boolean,
      first: boolean,
      control_statements: boolean,
      commands: boolean,
      functions: boolean,
      names: boolean,
      all_names: boolean,
      advanced_usage: boolean,
      starting_procedures: boolean,
    recend;

  TYPE
    individual_entry_type = record
      case kind: (system_entry, utility_entry, file_entry) of
      = system_entry =
        ,
      = utility_entry =
        utility_name: clt$utility_name,
        utility_info: ^clt$utility_command_environment,
      = file_entry =
        path_handle_name: fst$path_handle_name,
      casend,
    recend;

?? TITLE := 'clp$_display_command_list_entry', EJECT ??

  PROCEDURE [XDCL] clp$_display_command_list_entry
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
{ PROCEDURE (osm$discle) display_command_list_entry, display_command_list_entries, discle (
{   entry, entries, e: list of any of
{       key
{         all
{         (control_statements, control_statement, cs)
{         (first, f)
{         $system
{       keyend
{       name
{       file
{     anyend = first
{   display_options, display_option, do: list of key
{       all
{       (all_names, all_name, an)
{       (commands, command, c)
{       (functions, function, f)
{       (names, name, n)
{       (advanced_usage, au)
{       (starting_procedures, starting_procedure, sp)
{     keyend = osd$discle_display_options, (commands, names)
{   output, o: file = $output
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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 .. 7] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          type_size_3: clt$type_specification_size,
          element_type_spec_3: record
            header: clt$type_specification_header,
          recend,
        recend,
        default_value: string (5),
      recend,
      type2: 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 .. 18] of clt$keyword_specification,
        recend,
        default_name: string (26),
        default_value: string (17),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 2, 21, 16, 15, 43, 681],
    clc$command, 9, 4, 0, 0, 0, 0, 4, 'OSM$DISCLE'], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['E                              ',clc$abbreviation_entry, 1],
    ['ENTRIES                        ',clc$alias_entry, 1],
    ['ENTRY                          ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 314,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 689,
  clc$optional_default_parameter, 26, 17],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [298, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type, clc$name_type],
      FALSE, 3],
      266, [[1, 0, clc$keyword_type], [7], [
        ['$SYSTEM                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['CONTROL_STATEMENT              ', clc$alias_entry, clc$normal_usage_entry, 2],
        ['CONTROL_STATEMENTS             ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['CS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['FIRST                          ', clc$nominal_entry, clc$normal_usage_entry, 3]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
      3, [[1, 0, clc$file_type]]
      ]
    ,
    'first'],
{ PARAMETER 2
    [[1, 0, clc$list_type], [673, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [18], [
      ['ADVANCED_USAGE                 ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['ALL_NAME                       ', clc$alias_entry, clc$normal_usage_entry, 2],
      ['ALL_NAMES                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['AN                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['AU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['COMMAND                        ', clc$alias_entry, clc$normal_usage_entry, 3],
      ['COMMANDS                       ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['FUNCTION                       ', clc$alias_entry, clc$normal_usage_entry, 4],
      ['FUNCTIONS                      ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['NAME                           ', clc$alias_entry, clc$normal_usage_entry, 5],
      ['NAMES                          ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['SP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['STARTING_PROCEDURE             ', clc$alias_entry, clc$normal_usage_entry, 7],
      ['STARTING_PROCEDURES            ', clc$nominal_entry, clc$normal_usage_entry, 7]]
      ]
    ,
    'OSD$DISCLE_DISPLAY_OPTIONS',
    '(commands, names)'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

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

    CONST
      p$entry = 1,
      p$display_options = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;
*ELSE
{ PROCEDURE (osm$discle) display_command_list_entry, display_command_list_entr..
{ ies, discle (
{   entry, entries, e: list of any of
{       key
{         all
{         (control_statements, control_statement, cs)
{         (first, f)
{       keyend
{       name
{     anyend = first
{   display_options, display_option, do: list of key
{       all
{       (all_names, all_name, an)
{       (commands, command, c)
{       (functions, function, f)
{       (names, name, n)
{       (advanced_usage, au)
{     keyend = (commands, names)
{   output, o: file = $output
{   status)



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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$union_type_qualifier_v2,
          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 .. 6] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: ALIGNED [0 MOD 4] string (5),
      recend,
      type2: 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 .. 15] of clt$keyword_specification,
        recend,
        default_value: ALIGNED [0 MOD 4] string (17),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: ALIGNED [0 MOD 4] string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [2,
    [91, 9, 16, 8, 48, 24, 0],
    clc$command, 9, 4, 0, 0, 0, 0, 4, 'OSM$DISCLE'], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['E                              ',clc$abbreviation_entry, 1],
    ['ENTRIES                        ',clc$alias_entry, 1],
    ['ENTRY                          ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 306, clc$optional_default_parameter, 0, 5],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 636, clc$optional_default_parameter, 0, 17],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[2, 0, clc$list_type], [278, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[2, 0, clc$union_type], [[clc$keyword_type,
      clc$name_type],
      FALSE, 2],
      248, [[2, 0, clc$keyword_type], [6], [
        ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['CONTROL_STATEMENT              ', clc$alias_entry,
  clc$normal_usage_entry, 2],
        ['CONTROL_STATEMENTS             ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['CS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['F                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['FIRST                          ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
        ],
      6, [[2, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'first'],
{ PARAMETER 2
    [[2, 0, clc$list_type], [608, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[2, 0, clc$keyword_type], [15], [
      ['ADVANCED_USAGE                 ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['ALL_NAME                       ', clc$alias_entry,
  clc$normal_usage_entry, 2],
      ['ALL_NAMES                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['AN                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
      ['AU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
      ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
      ['COMMAND                        ', clc$alias_entry,
  clc$normal_usage_entry, 3],
      ['COMMANDS                       ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['F                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
      ['FUNCTION                       ', clc$alias_entry,
  clc$normal_usage_entry, 4],
      ['FUNCTIONS                      ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['N                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
      ['NAME                           ', clc$alias_entry,
  clc$normal_usage_entry, 5],
      ['NAMES                          ', clc$nominal_entry,
  clc$normal_usage_entry, 5]]
      ]
    ,
    '(commands, names)'],
{ PARAMETER 3
    [[2, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[2, 0, clc$status_type]]];

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

    CONST
      p$entry = 1,
      p$display_options = 2,
      p$output = 3,
      p$status = 4;

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

*copyc clv$display_variables

    CONST
      minimum_all_names_line_size = minimum_line_size + osc$max_name_size + 1,
      minimum_display_line = osc$max_name_size + 3,
      minimum_line_size = osc$max_name_size + 3,
      display_name_size = osc$max_name_size + 2;

    TYPE
      control_type = record
        put_subtitle_header: boolean,
        file_name: ^fst$file_reference,
        entry_name: ost$name,
        entry_kind: ost$name,
      recend;

    VAR
      block: ^clt$block,
      command_list: ^clt$command_list,
      command_reference: clt$command_reference,
      current_node: ^clt$data_value,
*IF NOT $true(osv$unix)
      default_ring_attributes: amt$ring_attributes,
*IFEND
      display_control: clt$display_control,
*IF NOT $true(osv$unix)
      effective_search_mode: clt$command_search_modes,
*IFEND
      end_of_list: ^clt$command_list_entry,
      file: clt$file,
*IF $true(osv$unix)
      handler_established: boolean,
*IFEND
      ignore_cmnd_list_found_in_task: boolean,
      individual_entries: ^array [1 .. * ] of individual_entry_type,
      individual_entry_count: integer,
      individual_file_reference: ^fst$file_reference,
      line_size: amt$page_width,
      local_status: ost$status,
      names_per_line: integer,
      options: option_type,
      output_control: control_type,
      start_of_list: ^clt$command_list_entry,
      utility_info: ^clt$utility_command_environment,
      work_area: ^^clt$work_area;

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

    PROCEDURE abort_handler
*IF $true(osv$unix)
      (    signal_no: integer;
           code: integer;
           p_sigcontext: ^cyt$mips_sigcontext);

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);
*ELSE
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      clp$close_display (display_control, handler_status);
      handler_status.normal := TRUE;
*IFEND

    PROCEND abort_handler;
*copyc clp$new_page_procedure
?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

      CONST
        header = 'ENTRY  ';

      VAR
        chunk_count: 0 .. fsc$max_path_elements,
        display_chunks: clt$path_display_chunks,
        header_length: integer;


      status.normal := TRUE;
      IF output_control.put_subtitle_header THEN
        put_partial_display (header, clc$no_trim, amc$continue);
        header_length := STRLENGTH (header);
      ELSE
        header_length := 0;
      IFEND;

      IF output_control.file_name <> NIL THEN
        clp$build_path_subtitle (output_control.file_name^,
              clp$trimmed_string_size (output_control.file_name^), line_size - header_length, chunk_count,
              display_chunks);
        put_path_chunks (output_control.file_name^, display_chunks, chunk_count, header_length + 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSEIF output_control.entry_name <> '' THEN
        put_partial_display (output_control.entry_name, clc$trim, amc$terminate);
      IFEND;

      IF output_control.entry_kind <> '' THEN
        clv$subtitles_built := FALSE;
        put_partial_display (output_control.entry_kind, clc$trim, amc$terminate);
      IFEND;

    PROCEND put_subtitle;
?? TITLE := 'put_path_chunks', EJECT ??

    PROCEDURE put_path_chunks
      (    path_name: fst$file_reference;
           display_chunks: clt$path_display_chunks;
           chunk_count: 0 .. fsc$max_path_elements;
           column: amt$page_width;
       VAR status: ost$status);

      VAR
        i: 0 .. fsc$max_path_elements,
        terminate_string: string (2);


      terminate_string := '..';
      FOR i := 1 TO chunk_count DO
        clp$horizontal_tab_display (display_control, column, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF i = chunk_count THEN
          terminate_string := '  ';
        IFEND;
        put_partial_display (path_name (display_chunks [i].position, display_chunks [i].length),
              clc$trim, amc$continue);
        put_partial_display (terminate_string, clc$trim, amc$terminate);
      FOREND;

    PROCEND put_path_chunks;
?? TITLE := 'put_partial_display', EJECT ??

    PROCEDURE [INLINE] put_partial_display
      (    str: string ( * );
           trim_option: clt$trim_display_text_option;
           term_option: amt$term_option);


      clp$put_partial_display (display_control, str, trim_option, term_option, status);
      IF NOT status.normal THEN
        EXIT clp$_display_command_list_entry;
      IFEND;

    PROCEND put_partial_display;
?? TITLE := 'display_command_list_entries', EJECT ??

    PROCEDURE display_command_list_entries;

*IF NOT $true(osv$unix)
      VAR
        control_statements: [STATIC, READ, oss$job_paged_literal] array [1 .. 30] of entry_type := [
              {} ['BLOCK / BLOCKEND               ', clc$nominal_entry, clc$normal_usage_entry, 1],
              {} ['CANCEL                         ', clc$nominal_entry, clc$normal_usage_entry, 2],
              {} ['CASE / selector / ELSE / CASEND', clc$nominal_entry, clc$hidden_entry, 3],
              {} ['CAUSE                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
              {} ['CHECK / CHECKEND               ', clc$nominal_entry, clc$hidden_entry, 5],
              {} ['COLLECT_TEXT                   ', clc$nominal_entry, clc$normal_usage_entry, 6],
              {} ['COLT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
              {} ['CONTINUE                       ', clc$nominal_entry, clc$normal_usage_entry, 7],
              {} ['CYCLE                          ', clc$nominal_entry, clc$normal_usage_entry, 8],
              {} ['EXIT                           ', clc$nominal_entry, clc$normal_usage_entry, 9],
              {} ['EXIT_PROC                      ', clc$nominal_entry, clc$hidden_entry, 10],
              {} ['FOR / FOREND                   ', clc$nominal_entry, clc$normal_usage_entry, 11],
              {} ['FUNCTION / FUNCEND             ', clc$nominal_entry, clc$hidden_entry, 12],
              {} ['IF / ELSEIF / ELSE / IFEND     ', clc$nominal_entry, clc$normal_usage_entry, 13],
              {} ['JOB / JOBEND                   ', clc$nominal_entry, clc$normal_usage_entry, 14],
              {} ['LOCK                           ', clc$nominal_entry, clc$hidden_entry, 15],
              {} ['LOOP / LOOPEND                 ', clc$nominal_entry, clc$normal_usage_entry, 16],
              {} ['PIPE / PIPEND                  ', clc$nominal_entry, clc$hidden_entry, 17],
              {} ['POP                            ', clc$nominal_entry, clc$normal_usage_entry, 18],
              {} ['PROCEDURE / PROCEND            ', clc$nominal_entry, clc$normal_usage_entry, 19],
              {} ['PUSH                           ', clc$nominal_entry, clc$normal_usage_entry, 20],
              {} ['PUSH_COMMANDS                  ', clc$nominal_entry, clc$normal_usage_entry, 21],
              {} ['REPEAT / UNTIL                 ', clc$nominal_entry, clc$normal_usage_entry, 22],
              {} ['TASK / TASKEND                 ', clc$nominal_entry, clc$normal_usage_entry, 23],
              {} ['TYPE / TYPEND                  ', clc$nominal_entry, clc$normal_usage_entry, 24],
              {} ['UNLOCK                         ', clc$nominal_entry, clc$hidden_entry, 25],
              {} ['UTILITY / UTILITYEND           ', clc$nominal_entry, clc$normal_usage_entry, 26],
              {} ['VAR / VAREND                   ', clc$nominal_entry, clc$normal_usage_entry, 27],
              {} ['WHEN / WHENEND                 ', clc$nominal_entry, clc$normal_usage_entry, 28],
              {} ['WHILE / WHILEND                ', clc$nominal_entry, clc$normal_usage_entry, 29]];
*IFEND

      VAR
        command_entries: ^entry_array,
        current_entry: ^clt$command_list_entry,
        function_entries: ^entry_array,
        i: integer,
        library_accessable: boolean,
        original_work_area: ^clt$work_area,
        system_entry_found: boolean;

?? NEWTITLE := 'display_all_names', EJECT ??

      PROCEDURE display_all_names
        (    entries: entry_array);

        VAR
          abbrev_count: 0 .. clc$max_command_table_size,
          abbreviations: ^entry_array,
          alias_count: 0 .. clc$max_command_table_size,
          aliases: ^entry_array,
          i: 1 .. clc$max_command_table_size,
          index: 1 .. clc$max_command_table_size,
          j: 1 .. clc$max_command_table_size,
          k: 1 .. clc$max_command_table_size,
          name_count: 0 .. clc$max_command_table_size,
          names: ^array [1 .. * ] of ost$name,
          nominal_count: 0 .. clc$max_command_table_size,
          nominals: ^entry_array,
          number_of_entries: 0 .. clc$max_command_table_size;

?? NEWTITLE := 'put_names', EJECT ??

        PROCEDURE put_names;

          CONST
            tab_over = osc$max_name_size + 2;

          VAR
            index: 2 .. clc$max_command_table_size,
            nominal_name: string (osc$max_name_size + 1),
            seperator: string (3),
            term_option: amt$term_option,
            trim_option: clt$trim_display_text_option;


          nominal_name := names^ [1];
          seperator := ',  ';

          IF name_count = 1 THEN
            put_name (names^ [1], clc$trim, amc$terminate);
          ELSE
            put_name (nominal_name, clc$no_trim, amc$start);

            trim_option := clc$trim;
            term_option := amc$continue;

            FOR index := 2 TO name_count DO
              IF (display_control.column_number + clp$trimmed_string_size (names^ [index]) + 2) >
                    line_size THEN
                clp$new_display_line (display_control, clc$next_display_line, status);
                IF NOT status.normal THEN
                  EXIT clp$_display_command_list_entry;
                IFEND;
                clp$horizontal_tab_display (display_control, tab_over, status);
                IF NOT status.normal THEN
                  EXIT clp$_display_command_list_entry;
                IFEND;
              IFEND;

              put_name (names^ [index], trim_option, term_option);
              IF index = name_count THEN
                term_option := amc$terminate;
                seperator := '   ';
              IFEND;

              put_partial_display (seperator, clc$no_trim, term_option);
            FOREND;
          IFEND;

        PROCEND put_names;
?? OLDTITLE, EJECT ??

        nominal_count := 0;
        alias_count := 0;
        abbrev_count := 0;

        number_of_entries := UPPERBOUND (entries);

        PUSH nominals: [1 .. number_of_entries];
        PUSH aliases: [1 .. number_of_entries];
        PUSH abbreviations: [1 .. number_of_entries];

        FOR index := 1 TO number_of_entries DO
          IF (entries [index].availability = clc$normal_usage_entry) OR
                ((entries [index].availability = clc$advanced_usage_entry) AND options.advanced_usage) THEN
            IF entries [index].class = clc$nominal_entry THEN
              nominal_count := nominal_count + 1;
              nominals^ [nominal_count] := entries [index];
            ELSEIF entries [index].class = clc$alias_entry THEN
              alias_count := alias_count + 1;
              aliases^ [alias_count] := entries [index];
            ELSE
              abbrev_count := abbrev_count + 1;
              abbreviations^ [abbrev_count] := entries [index];
            IFEND;
          IFEND;
        FOREND;

        PUSH names: [1 .. number_of_entries];
        FOR i := 1 TO nominal_count DO
          name_count := 1;
          names^ [name_count] := nominals^ [i].name;
          FOR j := 1 TO alias_count DO
            IF aliases^ [j].ordinal = nominals^ [i].ordinal THEN
              name_count := name_count + 1;
              names^ [name_count] := aliases^ [j].name;
            IFEND;
          FOREND;
          FOR k := 1 TO abbrev_count DO
            IF abbreviations^ [k].ordinal = nominals^ [i].ordinal THEN
              name_count := name_count + 1;
              names^ [name_count] := abbreviations^ [k].name;
            IFEND;
          FOREND;
          put_names;
        FOREND;

      PROCEND display_all_names;
*IF NOT $true(osv$unix)
?? TITLE := 'display_catalog_entries', EJECT ??

      PROCEDURE display_catalog_entries;


        output_control.file_name := ^command_reference.catalog;
        output_control.entry_name := '';
        output_control.entry_kind := '';

        IF options.commands THEN
          reset_display;
          put_partial_display ('--  Potential commands within a catalog are not shown.', clc$no_trim,
                amc$terminate);
        IFEND;

        IF options.functions THEN
          reset_display;
          put_partial_display ('--  Catalogs do not contain functions.', clc$no_trim, amc$terminate);
        IFEND;

      PROCEND display_catalog_entries;
*IFEND
?? TITLE := 'display_command_entries', EJECT ??

      PROCEDURE display_command_entries;


        IF command_entries = NIL THEN
          output_control.entry_kind := '';
          reset_display;
          put_partial_display ('--  No commands.', clc$no_trim, amc$terminate);
        ELSE
          output_control.entry_kind := 'Commands';
          reset_display;
          IF options.all_names THEN
            display_all_names (command_entries^);
          ELSE
            display_nominal_names (command_entries^);
          IFEND;
        IFEND;

      PROCEND display_command_entries;
?? TITLE := 'display_control_entries', EJECT ??

      PROCEDURE display_control_entries
        (    name: ost$name_reference;
             entries: entry_array);


        output_control.put_subtitle_header := FALSE;
        output_control.file_name := NIL;
        output_control.entry_kind := '';
        output_control.entry_name := name;
        reset_display;

        IF options.all_names THEN
          display_all_names (entries);
        ELSE
          display_nominal_names (entries);
        IFEND;

      PROCEND display_control_entries;
*IF NOT $true(osv$unix)
?? TITLE := 'display_fence', EJECT ??

      PROCEDURE [INLINE] display_fence;


        output_control.file_name := NIL;
        output_control.entry_name := 'fence';
        output_control.entry_kind := '';

        reset_display;
        put_partial_display ('--  Exclusive or restricted command searches do not go beyond this entry.',
              clc$no_trim, amc$terminate);

      PROCEND display_fence;
*IFEND
?? TITLE := 'display_function_entries', EJECT ??

      PROCEDURE display_function_entries;


        IF function_entries = NIL THEN
          output_control.entry_kind := '';
          reset_display;
          put_partial_display ('--  No functions.', clc$no_trim, amc$terminate);
        ELSE
          output_control.entry_kind := 'Functions';
          reset_display;
          IF options.all_names THEN
            display_all_names (function_entries^);
          ELSE
            display_nominal_names (function_entries^);
          IFEND;
        IFEND;

      PROCEND display_function_entries;
*IF NOT $true(osv$unix)
?? TITLE := 'display_library_entries', EJECT ??

      PROCEDURE [INLINE] display_library_entries;


        output_control.file_name := ^command_reference.library_or_catalog;
        output_control.entry_name := '';

        IF library_accessable THEN
          IF options.commands THEN
            display_command_entries;
          IFEND;

          IF options.functions THEN
            display_function_entries;
          IFEND;

        ELSE
          output_control.entry_kind := '';
          reset_display;

{         put_partial_display ('--  Requestor does not have sufficient privilege to read this file.',
{               clc$no_trim, amc$terminate);

          put_partial_display ('--  Requestor currently does not have sufficient privilege to read this file',
                clc$no_trim, amc$terminate);
          put_partial_display ('    or the file is currently unavailable.', clc$no_trim, amc$terminate);
        IFEND;

      PROCEND display_library_entries;
*IFEND
?? TITLE := 'display_nominal_names', EJECT ??

      PROCEDURE display_nominal_names
        (    entries: entry_array);

        VAR
          desired_entries: integer,
          display_name: string (display_name_size),
          index: integer,
          number_of_entries: integer,
          term_option: amt$term_option,
          trim: clt$trim_display_text_option;


        term_option := amc$continue;
        number_of_entries := UPPERBOUND (entries);
        desired_entries := 0;

        FOR index := 1 TO number_of_entries DO
          IF (entries [index].class = clc$nominal_entry) AND
                ((entries [index].availability = clc$normal_usage_entry) OR
                ((entries [index].availability = clc$advanced_usage_entry) AND options.advanced_usage)) THEN
            desired_entries := desired_entries + 1;
            IF (desired_entries MOD names_per_line) = 0 THEN
              term_option := amc$terminate;
              trim := clc$trim;
            ELSE
              term_option := amc$continue;
              trim := clc$no_trim;
            IFEND;
            display_name := entries [index].name;
            put_name (display_name, trim, term_option);
          IFEND;
        FOREND;

      PROCEND display_nominal_names;
?? TITLE := 'display_system_entries', EJECT ??

      PROCEDURE [INLINE] display_system_entries;


        system_entry_found := TRUE;

        output_control.file_name := NIL;
        output_control.entry_name := '$system';

        IF options.commands THEN
          display_command_entries;
        IFEND;

        IF options.functions THEN
          display_function_entries;
        IFEND;

      PROCEND display_system_entries;
?? TITLE := 'display_utility_entries', EJECT ??

      PROCEDURE [INLINE] display_utility_entries
        (    name: ost$name);


        output_control.file_name := NIL;
        #TRANSLATE (osv$upper_to_lower, name, output_control.entry_name);

        IF options.commands THEN
          display_command_entries;
        IFEND;

        IF options.functions THEN
          display_function_entries;
        IFEND;

      PROCEND display_utility_entries;
?? TITLE := 'put_name', EJECT ??

      PROCEDURE [INLINE] put_name
        (    name: string ( * <= display_name_size);
             trim_option: clt$trim_display_text_option;
             term_option: amt$term_option);

        VAR
          translated_name: string (display_name_size);


        #TRANSLATE (osv$upper_to_lower, name, translated_name);

        put_partial_display (translated_name (1, STRLENGTH (name)), trim_option, term_option);

      PROCEND put_name;
?? TITLE := 'reset_display', EJECT ??

      PROCEDURE reset_display;


        IF (display_control.page_format = amc$continuous_form) OR
              (display_control.page_format = amc$untitled_form) THEN
          clp$new_display_line (display_control, 3, status);
          IF NOT status.normal THEN
            EXIT clp$_display_command_list_entry;
          IFEND;
          put_subtitle (display_control, status);
          IF NOT status.normal THEN
            EXIT clp$_display_command_list_entry;
          IFEND;
          clp$new_display_line (display_control, 1, status);
        ELSE
          clp$new_display_page (display_control, status);
        IFEND;
        IF NOT status.normal THEN
          EXIT clp$_display_command_list_entry;
        IFEND;

      PROCEND reset_display;
?? OLDTITLE, EJECT ??

      current_entry := start_of_list;
      system_entry_found := FALSE;
      original_work_area := work_area^;


*IF NOT $true(osv$unix)
      IF options.control_statements AND options.commands THEN
        display_control_entries ('Control Statements', control_statements);
      IFEND;
*IFEND

      IF options.first OR options.all_entries THEN
        output_control.put_subtitle_header := TRUE;

        WHILE current_entry <> end_of_list DO
          clv$subtitles_built := FALSE;
          get_command_and_func_entries (options, command_list, current_entry, NIL, FALSE, TRUE, work_area^,
                command_entries, function_entries, command_reference, library_accessable, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          CASE current_entry^.kind OF
*IF NOT $true(osv$unix)
          = clc$library_commands =
            display_library_entries;
          = clc$catalog_commands, clc$working_catalog_commands =
            display_catalog_entries;
*IFEND
          = clc$system_commands =
            display_system_entries;
          = clc$sub_commands =
            display_utility_entries (current_entry^.utility_name);
*IF NOT $true(osv$unix)
          = clc$command_list_fence =
            display_fence;
*IFEND
          CASEND;

          work_area^ := original_work_area;
          IF options.first THEN
            current_entry := end_of_list;
          ELSE
            current_entry := current_entry^.next_entry;
          IFEND;
        WHILEND;
      IFEND;

      IF individual_entry_count > 0 THEN
        output_control.put_subtitle_header := TRUE;

        FOR i := 1 TO individual_entry_count DO
          get_command_and_func_entries (options, command_list, NIL, ^individual_entries^ [i], FALSE, FALSE,
                work_area^, command_entries, function_entries, command_reference, library_accessable, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          CASE individual_entries^ [i].kind OF
          = system_entry =
            display_system_entries;
          = utility_entry =
            display_utility_entries (individual_entries^ [i].utility_name);
*IF NOT $true(osv$unix)
          = file_entry =
            IF command_reference.form = clc$file_cycle_command_ref THEN
              display_catalog_entries;
            ELSE
              display_library_entries;
            IFEND;
*IFEND
          CASEND;

          work_area^ := original_work_area;
        FOREND;
      IFEND;

      IF options.control_statements THEN
        get_command_and_func_entries (options, command_list, NIL, NIL, FALSE, FALSE, work_area^,
              command_entries, function_entries, command_reference, library_accessable, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF options.commands THEN
          display_control_entries ('Control Commands', command_entries^);
        IFEND;
        IF options.functions AND (NOT system_entry_found) THEN
          display_control_entries ('System Supplied Functions', function_entries^);
        IFEND;

        work_area^ := original_work_area;

*IF NOT $true(osv$unix)
        ?IF fsc$compiling_for_test_harness AND clc$compiling_for_test_harness THEN
          get_command_and_func_entries (options, command_list, NIL, NIL, TRUE, FALSE, work_area^,
                command_entries, function_entries, command_reference, library_accessable, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF options.commands THEN
            display_control_entries ('Test Harness Commands', command_entries^);
          IFEND;
          IF options.functions THEN
            display_control_entries ('Test Harness Functions', function_entries^);
          IFEND;

          work_area^ := original_work_area;
        ?IFEND
*IFEND
      IFEND;

    PROCEND display_command_list_entries;
?? OLDTITLE, EJECT ??

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

    clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);
    clp$find_current_block (block);
    start_of_list := command_list^.entries.first_entry;
*IF NOT $true(osv$unix)
    IF block^.previous_block^.use_command_search_mode THEN
      effective_search_mode := command_list^.search_mode;
    ELSE
      effective_search_mode := clc$global_command_search;
    IFEND;
    IF effective_search_mode = clc$exclusive_command_search THEN
      end_of_list := command_list^.entries.entry_after_fence;
    ELSE
*IFEND
      end_of_list := NIL;
*IF NOT $true(osv$unix)
    IFEND;
*IFEND

    options.all_entries := FALSE;
    options.first := FALSE;
    options.control_statements := FALSE;
    options.commands := FALSE;
    options.functions := FALSE;
    options.names := FALSE;
    options.all_names := FALSE;
    options.advanced_usage := FALSE;
    options.starting_procedures := FALSE;

    display_control := clv$nil_display_control;
    #SPOIL (display_control);

    individual_entry_count := 0;
    current_node := pvt [p$entry].value;
    WHILE current_node <> NIL DO
      IF (current_node^.element_value^.kind <> clc$keyword) OR (current_node^.element_value^.keyword_value =
            '$SYSTEM') THEN
        individual_entry_count := individual_entry_count + 1;
      IFEND;
      current_node := current_node^.link;
    WHILEND;
    IF individual_entry_count = 0 THEN
      individual_entries := NIL;
    ELSE
      PUSH individual_entries: [1 .. individual_entry_count];
    IFEND;

    individual_entry_count := 0;
    current_node := pvt [p$entry].value;
    WHILE current_node <> NIL DO

    /get_entry/
      BEGIN
        CASE current_node^.element_value^.kind OF

        = clc$keyword =
          IF current_node^.element_value^.keyword_value = 'ALL' THEN
            options.control_statements := TRUE;
            options.all_entries := TRUE;
          ELSEIF current_node^.element_value^.keyword_value = 'CONTROL_STATEMENTS' THEN
            options.control_statements := TRUE;
          ELSEIF current_node^.element_value^.keyword_value = 'FIRST' THEN
            options.first := TRUE;
          ELSE {$SYSTEM}
            individual_entry_count := individual_entry_count + 1;
            individual_entries^ [individual_entry_count].kind := system_entry;
          IFEND;
          EXIT /get_entry/;

        = clc$name =
          utility_info := utility_command_environment (start_of_list,
                current_node^.element_value^.name_value);
          IF utility_info <> NIL THEN
            individual_entry_count := individual_entry_count + 1;
            individual_entries^ [individual_entry_count].kind := utility_entry;
            individual_entries^ [individual_entry_count].utility_name :=
                  current_node^.element_value^.name_value;
            individual_entries^ [individual_entry_count].utility_info := utility_info;
            EXIT /get_entry/;
*IF $true(osv$unix)
          ELSEIF current_node^.element_value^.name_value = '$SYSTEM' THEN
            individual_entry_count := individual_entry_count + 1;
            individual_entries^ [individual_entry_count].kind := system_entry;
          ELSE
            osp$set_status_abnormal ('CL', cle$unknown_utility, current_node^.element_value^.name_value,
                  status);
            RETURN;
*IFEND
          IFEND;
          individual_file_reference := ^current_node^.element_value^.name_value;

        ELSE {clc$file}
*IF NOT $true(osv$unix)
          individual_file_reference := current_node^.element_value^.file_value;
*IFEND
        CASEND;

*IF NOT $true(osv$unix)
        individual_entry_count := individual_entry_count + 1;
        individual_entries^ [individual_entry_count].kind := file_entry;
        clp$convert_string_to_file (individual_file_reference^, file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        individual_entries^ [individual_entry_count].path_handle_name := file.local_file_name;
*IFEND
      END /get_entry/;

      #SPOIL (individual_entries^ [individual_entry_count]);
      current_node := current_node^.link;
    WHILEND;
    #SPOIL (individual_entry_count, individual_entries);

    current_node := pvt [p$display_options].value;
    WHILE current_node <> NIL DO
      IF current_node^.element_value^.keyword_value = 'ALL_NAMES' THEN
        options.all_names := TRUE;
      ELSEIF current_node^.element_value^.keyword_value = 'ADVANCED_USAGE' THEN
        options.advanced_usage := TRUE;
      ELSEIF current_node^.element_value^.keyword_value = 'COMMANDS' THEN
        options.commands := TRUE;
      ELSEIF current_node^.element_value^.keyword_value = 'FUNCTIONS' THEN
        options.functions := TRUE;
      ELSEIF current_node^.element_value^.keyword_value = 'NAMES' THEN
        options.names := TRUE;
*IF NOT $true(osv$unix)
      ELSEIF current_node^.element_value^.keyword_value = 'STARTING_PROCEDURES' THEN
        options.starting_procedures := TRUE;
*IFEND
      ELSE {ALL}
        options.all_names := TRUE;
        options.advanced_usage := TRUE;
        options.commands := TRUE;
        options.functions := TRUE;
        options.starting_procedures := TRUE;
      IFEND;
      current_node := current_node^.link;
    WHILEND;

    IF NOT (options.commands OR options.functions) THEN
      options.commands := TRUE;
    IFEND;
    IF NOT (options.names OR options.all_names) THEN
      options.names := TRUE;
    IFEND;

*IF NOT $true(osv$unix)
    clp$get_work_area (#RING (^work_area), work_area, status);
*ELSE
    clp$get_work_area (osc$user_ring, work_area, status);
*IFEND
    IF NOT status.normal THEN
      RETURN;
    IFEND;

*IF $true(osv$unix)
    handler_established := #establish_condition_handler (-1, ^abort_handler);
*ELSE
    osp$establish_block_exit_hndlr (^abort_handler);
*IFEND

  /display_entries/
    BEGIN
*IF NOT $true(osv$unix)
*IF NOT $true(osv$unix)
      default_ring_attributes.r1 := #RING (^default_ring_attributes);
      default_ring_attributes.r2 := #RING (^default_ring_attributes);
      default_ring_attributes.r3 := #RING (^default_ring_attributes);
*ELSE
      default_ring_attributes.r1 := osc$user_ring;
      default_ring_attributes.r2 := osc$user_ring;
      default_ring_attributes.r3 := osc$user_ring;
*IFEND

      clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
            default_ring_attributes, display_control, status);
*ELSE
      clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure,
            fsc$list,
            display_control, status);
*IFEND
      IF NOT status.normal THEN
        EXIT /display_entries/;
      IFEND;
      clv$titles_built := FALSE;
      clv$command_name := 'display_command_list_entry';

      IF display_control.page_width < clc$narrow_page_width THEN
        clv$page_width := clc$narrow_page_width;
      ELSEIF display_control.page_width > clc$wide_page_width THEN
        clv$page_width := clc$wide_page_width;
      ELSE
        clv$page_width := display_control.page_width;
      IFEND;

      IF options.all_names THEN
        IF display_control.page_width < minimum_all_names_line_size THEN
          line_size := minimum_all_names_line_size;
        ELSE
          line_size := display_control.page_width;
        IFEND;
      ELSEIF display_control.page_width < minimum_display_line THEN
        line_size := minimum_line_size;
      ELSE
        line_size := display_control.page_width;
      IFEND;
      names_per_line := line_size DIV display_name_size;

      display_command_list_entries;

      clp$close_display (display_control, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;

    END /display_entries/;

*IF $true(osv$unix)
    IF handler_established THEN
      handler_established := NOT #disestablish_condition_handler (-1);
    IFEND;
*ELSE
    osp$disestablish_cond_handler;
*IFEND

  PROCEND clp$_display_command_list_entry;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$$command_list_entry', EJECT ??

  PROCEDURE [XDCL] clp$$command_list_entry
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$comle) $command_list_entry (
{   entry: any of
{       key
{         (first, f)
{         $system
{       keyend
{       name
{       file
{     anyend = first
{   commands_or_functions: key
{       (commands, command, c)
{       (command_references, command_reference, cr)
{       (functions, function, f)
{     keyend = commands
{   options: list rest of key
{       (aliases, alias, abbreviation, a)
{       (advanced_usage, au)
{       (starting_procedures, starting_procedure, sp)
{     keyend = $optional
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
        recend,
        default_value: string (5),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 9] of clt$keyword_specification,
        default_value: string (8),
      recend,
      type3: 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 .. 9] of clt$keyword_specification,
        recend,
      recend,
    recend := [
    [1,
    [90, 2, 21, 16, 25, 55, 891],
    clc$function, 3, 3, 0, 0, 0, 0, 0, 'OSM$$COMLE'], [
    ['COMMANDS_OR_FUNCTIONS          ',clc$nominal_entry, 2],
    ['ENTRY                          ',clc$nominal_entry, 1],
    ['OPTIONS                        ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, 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, 150,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 2
    [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, 340,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 3
    [3, 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, 356,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type, clc$name_type],
    FALSE, 3],
    118, [[1, 0, clc$keyword_type], [3], [
      ['$SYSTEM                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['FIRST                          ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$file_type]]
    ,
    'first'],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [9], [
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['COMMAND                        ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['COMMANDS                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['COMMAND_REFERENCE              ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['COMMAND_REFERENCES             ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['CR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FUNCTION                       ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['FUNCTIONS                      ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ,
    'commands'],
{ PARAMETER 3
    [[1, 0, clc$list_type], [340, 1, clc$max_list_size, 0, FALSE, TRUE],
      [[1, 0, clc$keyword_type], [9], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ABBREVIATION                   ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['ADVANCED_USAGE                 ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['ALIAS                          ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['ALIASES                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['AU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['SP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['STARTING_PROCEDURE             ', clc$alias_entry, clc$normal_usage_entry, 3],
      ['STARTING_PROCEDURES            ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ]
    ]];

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

    CONST
      p$entry = 1,
      p$commands_or_functions = 2,
      p$options = 3;

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


    VAR
      command_entries: ^entry_array,
      command_list: ^clt$command_list,
      command_reference: clt$command_reference,
      current_node: ^clt$data_value,
      entries: ^entry_array,
      file: clt$file,
      function_entries: ^entry_array,
      ignore_cmnd_list_found_in_task: boolean,
      ignore_library_accessable: boolean,
      individual_entry: ^individual_entry_type,
      individual_file_reference: ^fst$file_reference,
      local_status: ost$status,
      options: option_type,
      result_node: ^^clt$data_value,
      return_command_references: boolean,
      start_of_list: ^clt$command_list_entry,
      utility_info: ^clt$utility_command_environment;

?? NEWTITLE := 'append_name_to_result', EJECT ??

    PROCEDURE append_name_to_result
      (    name: ost$name;
       VAR node {input, output} : ^^clt$data_value);


      clp$make_list_value (work_area, node^);
      IF node^ = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT clp$$command_list_entry;
      IFEND;

      IF return_command_references THEN
        command_reference.name := name;
        clp$make_command_ref_value (^command_reference, work_area, node^^.element_value);
      ELSE
        clp$make_name_value (name, work_area, node^^.element_value);
      IFEND;

      IF node^^.element_value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT clp$$command_list_entry;
      IFEND;

      node := ^node^^.link;

    PROCEND append_name_to_result;
?? TITLE := 'return_all_names', EJECT ??

    PROCEDURE return_all_names;

      VAR
        abbrev_count: integer,
        abbreviations: ^entry_array,
        alias_count: integer,
        aliases: ^entry_array,
        i: integer,
        index: integer,
        j: integer,
        k: integer,
        nominal_count: integer,
        nominals: ^entry_array,
        result_sub_node: ^^clt$data_value;


      nominal_count := 0;
      alias_count := 0;
      abbrev_count := 0;

      PUSH nominals: [1 .. UPPERBOUND (entries^)];
      PUSH aliases: [1 .. UPPERBOUND (entries^)];
      PUSH abbreviations: [1 .. UPPERBOUND (entries^)];

      FOR index := 1 TO UPPERBOUND (entries^) DO
        IF (entries^ [index].availability = clc$normal_usage_entry) OR
              ((entries^ [index].availability = clc$advanced_usage_entry) AND options.advanced_usage) THEN
          IF entries^ [index].class = clc$nominal_entry THEN
            nominal_count := nominal_count + 1;
            nominals^ [nominal_count] := entries^ [index];
          ELSEIF entries^ [index].class = clc$alias_entry THEN
            alias_count := alias_count + 1;
            aliases^ [alias_count] := entries^ [index];
          ELSE
            abbrev_count := abbrev_count + 1;
            abbreviations^ [abbrev_count] := entries^ [index];
          IFEND;
        IFEND;
      FOREND;

      FOR i := 1 TO nominal_count DO
        clp$make_list_value (work_area, result_node^);
        IF result_node^ = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          EXIT clp$$command_list_entry;
        IFEND;
        result_sub_node := ^result_node^^.element_value;
        result_node := ^result_node^^.link;

        append_name_to_result (nominals^ [i].name, result_sub_node);
        FOR j := 1 TO alias_count DO
          IF aliases^ [j].ordinal = nominals^ [i].ordinal THEN
            append_name_to_result (aliases^ [j].name, result_sub_node);
          IFEND;
        FOREND;
        FOR k := 1 TO abbrev_count DO
          IF abbreviations^ [k].ordinal = nominals^ [i].ordinal THEN
            append_name_to_result (abbreviations^ [k].name, result_sub_node);
          IFEND;
        FOREND;
      FOREND;

    PROCEND return_all_names;
?? TITLE := 'return_nominal_names', EJECT ??

    PROCEDURE return_nominal_names;

      VAR
        index: integer;


      FOR index := 1 TO UPPERBOUND (entries^) DO
        IF (entries^ [index].class = clc$nominal_entry) AND
              ((entries^ [index].availability = clc$normal_usage_entry) OR
              ((entries^ [index].availability = clc$advanced_usage_entry) AND options.advanced_usage)) THEN
          append_name_to_result (entries^ [index].name, result_node);
        IFEND;
      FOREND;

    PROCEND return_nominal_names;
?? OLDTITLE, EJECT ??

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

    clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);
    start_of_list := command_list^.entries.first_entry;

    options.all_entries := FALSE;
    options.first := FALSE;
    options.control_statements := FALSE;
    options.commands := FALSE;
    options.functions := FALSE;
    options.names := TRUE;
    options.all_names := FALSE;
    options.advanced_usage := FALSE;
    options.starting_procedures := FALSE;
    return_command_references := FALSE;

    IF (pvt [p$entry].value^.kind <> clc$keyword) OR (pvt [p$entry].value^.keyword_value = '$SYSTEM') THEN
      PUSH individual_entry;
    ELSE
      individual_entry := NIL;
    IFEND;

  /get_entry/
    BEGIN
      CASE pvt [p$entry].value^.kind OF

      = clc$keyword =
        IF pvt [p$entry].value^.keyword_value = 'FIRST' THEN
          options.first := TRUE;
        ELSE {$SYSTEM}
          individual_entry^.kind := system_entry;
        IFEND;
        EXIT /get_entry/;

      = clc$name =
        utility_info := utility_command_environment (start_of_list, pvt [p$entry].value^.name_value);
        IF utility_info <> NIL THEN
          individual_entry^.kind := utility_entry;
          individual_entry^.utility_name := pvt [p$entry].value^.name_value;
          individual_entry^.utility_info := utility_info;
          EXIT /get_entry/;
        IFEND;
        individual_file_reference := ^pvt [p$entry].value^.name_value;

      ELSE {clc$file}
        individual_file_reference := pvt [p$entry].value^.file_value;
      CASEND;

      individual_entry^.kind := file_entry;
      clp$convert_string_to_file (individual_file_reference^, file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      individual_entry^.path_handle_name := file.local_file_name;
    END /get_entry/;

    #SPOIL (individual_entry);

    IF pvt [p$commands_or_functions].value^.keyword_value = 'COMMANDS' THEN
      options.commands := TRUE;
    ELSEIF pvt [p$commands_or_functions].value^.keyword_value = 'COMMAND_REFERENCES' THEN
      options.commands := TRUE;
      return_command_references := TRUE;
    ELSE {FUNCTIONS}
      options.functions := TRUE;
    IFEND;

    current_node := pvt [p$options].value;
    WHILE current_node <> NIL DO
      IF current_node^.element_value^.keyword_value = 'ALIASES' THEN
        options.all_names := TRUE;
      ELSEIF current_node^.element_value^.keyword_value = 'STARTING_PROCEDURES' THEN
        options.starting_procedures := TRUE;
      ELSE {ADVANCED_USAGE}
        options.advanced_usage := TRUE;
      IFEND;
      current_node := current_node^.link;
    WHILEND;

    result_node := ^result;

    IF (individual_entry <> NIL) OR (options.first AND (start_of_list <> NIL)) THEN
      get_command_and_func_entries (options, command_list, start_of_list, individual_entry, FALSE,
            options.first, work_area, command_entries, function_entries, command_reference,
            ignore_library_accessable, status);
      IF NOT status.normal THEN
        RETURN;
      ELSEIF options.commands AND (command_entries <> NIL) THEN
        entries := command_entries;
      ELSEIF options.functions AND (function_entries <> NIL) THEN
        entries := function_entries;
      ELSE
        entries := NIL;
      IFEND;

      IF entries <> NIL THEN
        IF options.all_names THEN
          return_all_names;
        ELSE
          return_nominal_names;
        IFEND;
      IFEND;
    IFEND;

    IF result = NIL THEN
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
    IFEND;

  PROCEND clp$$command_list_entry;
*IFEND
?? TITLE := 'get_command_and_func_entries', EJECT ??

  PROCEDURE get_command_and_func_entries
    (    options: option_type;
         command_list: ^clt$command_list;
         list_entry: ^clt$command_list_entry;
         individual_entry: ^individual_entry_type;
         test_harness: boolean;
         searching_command_list: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR command_entries: ^entry_array;
     VAR function_entries: ^entry_array;
     VAR command_reference: clt$command_reference;
     VAR library_accessable: boolean;
     VAR status: ost$status);

    VAR
*IF NOT $true(osv$unix)
      caller_id: ost$caller_identifier,
*IFEND
      i: integer,
      ignore_library_list_entry: ^clt$command_library_list_entry,
      individual_entry_open: boolean,
*IF NOT $true(osv$unix)
      local_file_name: amt$local_file_name,
      ring_attributes: amt$ring_attributes;
*ELSE
      local_file_name: amt$local_file_name;
*IFEND

*IF NOT $true(osv$unix)
?? NEWTITLE := 'abort_handler', EJECT ??

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


      IF individual_entry_open THEN
        clp$close_command_library (local_file_name, handler_status);
        individual_entry_open := FALSE;
        handler_status.normal := TRUE;
      IFEND;

    PROCEND abort_handler;
*IFEND
?? TITLE := 'convert_command_dictionary', EJECT ??

    PROCEDURE convert_command_dictionary
      (    commands: llt$command_dictionary;
       VAR largest_ordinal: clt$named_entry_ordinal;
       VAR converted_commands: ^entry_array);

      VAR
        index: integer;


      NEXT converted_commands: [1 .. UPPERBOUND (commands)] IN work_area;
      IF converted_commands = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT get_command_and_func_entries;
      IFEND;

      largest_ordinal := 1;

      FOR index := 1 TO UPPERBOUND (commands) DO
        converted_commands^ [index].name := commands [index].name;
        converted_commands^ [index].class := commands [index].class;
        IF (commands [index].kind = llc$local_to_library) OR
*IF NOT $true(osv$unix)
              ((commands [index].kind = llc$entry_point) AND (ring_attributes.r2 < caller_id.ring)) OR
*ELSE
              ((commands [index].kind = llc$entry_point)) OR
*IFEND
              ((commands [index].module_kind = llc$load_module) AND (NOT options.starting_procedures)) THEN
          converted_commands^ [index].availability := clc$hidden_entry;
        ELSE
          converted_commands^ [index].availability := commands [index].availability;
        IFEND;
        converted_commands^ [index].ordinal := commands [index].ordinal;
        IF commands [index].ordinal > largest_ordinal THEN
          largest_ordinal := commands [index].ordinal;
        IFEND;
      FOREND;

    PROCEND convert_command_dictionary;
?? TITLE := 'convert_command_table', EJECT ??

    PROCEDURE convert_command_table
      (    commands: clt$command_table;
       VAR largest_ordinal: clt$named_entry_ordinal;
       VAR converted_commands: ^entry_array);

      VAR
        index: integer;


      NEXT converted_commands: [1 .. UPPERBOUND (commands)] IN work_area;
      IF converted_commands = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT get_command_and_func_entries;
      IFEND;

      largest_ordinal := 1;

      FOR index := 1 TO UPPERBOUND (commands) DO
        converted_commands^ [index].name := commands [index].name;
        converted_commands^ [index].class := commands [index].class;
        converted_commands^ [index].availability := commands [index].availability;
        converted_commands^ [index].ordinal := commands [index].ordinal;
        IF commands [index].ordinal > largest_ordinal THEN
          largest_ordinal := commands [index].ordinal;
        IFEND;
      FOREND;

    PROCEND convert_command_table;
?? TITLE := 'convert_function_dictionary', EJECT ??

    PROCEDURE convert_function_dictionary
      (    functions: llt$function_dictionary;
       VAR largest_ordinal: clt$named_entry_ordinal;
       VAR converted_functions: ^entry_array);

      VAR
        index: integer;


      NEXT converted_functions: [1 .. UPPERBOUND (functions)] IN work_area;
      IF converted_functions = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT get_command_and_func_entries;
      IFEND;

      largest_ordinal := 1;

      FOR index := 1 TO UPPERBOUND (functions) DO
        converted_functions^ [index].name := functions [index].name;
        converted_functions^ [index].class := functions [index].class;
        IF functions [index].kind = llc$local_to_library THEN
          converted_functions^ [index].availability := clc$hidden_entry;
        ELSE
          converted_functions^ [index].availability := functions [index].availability;
        IFEND;
        converted_functions^ [index].ordinal := functions [index].ordinal;
        IF functions [index].ordinal > largest_ordinal THEN
          largest_ordinal := functions [index].ordinal;
        IFEND;
      FOREND;

    PROCEND convert_function_dictionary;
?? TITLE := 'convert_function_proc_table', EJECT ??

    PROCEDURE convert_function_proc_table
      (    functions: clt$function_processor_table;
       VAR largest_ordinal: clt$named_entry_ordinal;
       VAR converted_functions: ^entry_array);

      VAR
        index: integer;


      NEXT converted_functions: [1 .. UPPERBOUND (functions)] IN work_area;
      IF converted_functions = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT get_command_and_func_entries;
      IFEND;

      largest_ordinal := 1;

      FOR index := 1 TO UPPERBOUND (functions) DO
        converted_functions^ [index].name := functions [index].name;
        converted_functions^ [index].class := functions [index].class;
        converted_functions^ [index].availability := functions [index].availability;
        converted_functions^ [index].ordinal := functions [index].ordinal;
        IF functions [index].ordinal > largest_ordinal THEN
          largest_ordinal := functions [index].ordinal;
        IFEND;
      FOREND;

    PROCEND convert_function_proc_table;
?? TITLE := 'convert_function_table', EJECT ??

    PROCEDURE convert_function_table
      (    functions: clt$function_table;
       VAR largest_ordinal: clt$named_entry_ordinal;
       VAR converted_functions: ^entry_array);

      VAR
        index: integer;


      NEXT converted_functions: [1 .. UPPERBOUND (functions)] IN work_area;
      IF converted_functions = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT get_command_and_func_entries;
      IFEND;

      largest_ordinal := 1;

      FOR index := 1 TO UPPERBOUND (functions) DO
        converted_functions^ [index].name := functions [index].name;
        converted_functions^ [index].class := functions [index].class;
        converted_functions^ [index].availability := functions [index].availability;
        converted_functions^ [index].ordinal := functions [index].ordinal;
        IF functions [index].ordinal > largest_ordinal THEN
          largest_ordinal := functions [index].ordinal;
        IFEND;
      FOREND;

    PROCEND convert_function_table;
*IF NOT $true(osv$unix)
?? TITLE := 'get_catalog_entries', EJECT ??

    PROCEDURE get_catalog_entries
      (    local_file_name: amt$local_file_name);

      VAR
        parsed_file_reference: fst$parsed_file_reference;


      command_reference.form := clc$file_cycle_command_ref;
      clp$convert_string_to_file_ref (local_file_name, parsed_file_reference, status);
      IF NOT status.normal THEN
        EXIT get_command_and_func_entries;
      IFEND;
      command_reference.catalog := parsed_file_reference.path (1, parsed_file_reference.file_path_size);
      command_reference.cycle_number := 1 {not used} ;

{ No entries are returned for a catalog.

    PROCEND get_catalog_entries;
*IFEND
?? TITLE := 'get_intrinsic_entries', EJECT ??

    PROCEDURE get_intrinsic_entries;

      VAR
        function_dictionary: ^llt$function_dictionary,
        ignore_command_dictionary: ^llt$command_dictionary,
        largest_primary_ordinal: clt$named_entry_ordinal,
        largest_secondary_ordinal: clt$named_entry_ordinal,
        primary_entries: ^entry_array,
        secondary_entries: ^entry_array;

*IF NOT $true(osv$unix)
      VAR
        context: ^ost$ecp_exception_context;

      context := NIL;
*IFEND

      command_reference.form := clc$system_command_ref;

      IF options.commands THEN
        convert_command_table (clv$intrinsic_commands^, largest_primary_ordinal, command_entries);
      IFEND;

      IF options.functions THEN
        convert_function_proc_table (clv$system_functions^, largest_primary_ordinal, primary_entries);
        convert_function_table (clv$system_functions_v0^, largest_secondary_ordinal, secondary_entries);
        merge_entries (primary_entries^, largest_primary_ordinal, secondary_entries^, function_entries);
*IF NOT $true(osv$unix)
        IF (command_list^.system_command_library_lfn <> osc$null_name) AND
              command_list^.system_library_contains.functions THEN
          REPEAT
            clp$find_command_entries (command_list^.system_command_library_lfn, work_area, ring_attributes,
                  ignore_command_dictionary, function_dictionary, status);
            IF osp$file_access_condition (status) THEN
              IF context = NIL THEN
                PUSH context;
                context^ := osv$initial_exception_context;
                context^.file.selector := osc$ecp_file_reference;
                context^.file.file_reference := ^command_list^.system_command_library_lfn;
              IFEND;
              context^.condition_status := status;
              osp$enforce_exception_policies (context^);
              status := context^.condition_status;
            IFEND;
          UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
          library_accessable := TRUE;
          IF NOT status.normal THEN
            EXIT get_command_and_func_entries;
          IFEND;
          IF function_dictionary <> NIL THEN
            secondary_entries := function_entries;
            convert_function_dictionary (function_dictionary^, largest_primary_ordinal, primary_entries);
            merge_entries (primary_entries^, largest_primary_ordinal, secondary_entries^, function_entries);
          IFEND;
        IFEND;
*IFEND
      IFEND;

    PROCEND get_intrinsic_entries;
*IF NOT $true(osv$unix)
?? TITLE := 'get_library_entries', EJECT ??

    PROCEDURE get_library_entries
      (    local_file_name: amt$local_file_name);

      VAR
        command_dictionary: ^llt$command_dictionary,
        context: ^ost$ecp_exception_context,
        function_dictionary: ^llt$function_dictionary,
        ignore_largest_ordinal: clt$named_entry_ordinal,
        parsed_file_reference: fst$parsed_file_reference;

      context := NIL;

      command_reference.form := clc$module_or_file_command_ref;
      clp$convert_string_to_file_ref (local_file_name, parsed_file_reference, status);
      IF NOT status.normal THEN
        EXIT get_command_and_func_entries;
      IFEND;
      command_reference.library_or_catalog := parsed_file_reference.
            path (1, parsed_file_reference.file_path_size);

      REPEAT
        clp$find_command_entries (local_file_name, work_area, ring_attributes, command_dictionary,
              function_dictionary, status);
        IF osp$file_access_condition (status) THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_file_reference;
            context^.file.file_reference := ^local_file_name;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
      IF NOT status.normal THEN
        IF searching_command_list THEN
          library_accessable := FALSE;
          status.normal := TRUE;
        IFEND;
        RETURN;
      ELSEIF caller_id.ring > ring_attributes.r3 THEN
        library_accessable := FALSE;
      IFEND;

      IF options.commands AND (command_dictionary <> NIL) THEN
        convert_command_dictionary (command_dictionary^, ignore_largest_ordinal, command_entries);
      IFEND;
      IF options.functions AND (function_dictionary <> NIL) THEN
        convert_function_dictionary (function_dictionary^, ignore_largest_ordinal, function_entries);
      IFEND;

    PROCEND get_library_entries;
*IFEND
?? TITLE := 'get_system_entries', EJECT ??

    PROCEDURE get_system_entries;

      VAR
        command_dictionary: ^llt$command_dictionary,
        function_dictionary: ^llt$function_dictionary,
        largest_primary_ordinal: clt$named_entry_ordinal,
        largest_secondary_ordinal: clt$named_entry_ordinal,
        primary_entries: ^entry_array,
        secondary_entries: ^entry_array;

*IF NOT $true(osv$unix)
      VAR
        context: ^ost$ecp_exception_context;

      context := NIL;

*IFEND

      command_reference.form := clc$system_command_ref;

*IF NOT $true(osv$unix)
      IF command_list^.system_command_library_lfn = osc$null_name THEN
*IFEND
        command_dictionary := NIL;
        function_dictionary := NIL;
*IF NOT $true(osv$unix)
      ELSE
        REPEAT
          clp$find_command_entries (command_list^.system_command_library_lfn, work_area, ring_attributes,
                command_dictionary, function_dictionary, status);
          IF osp$file_access_condition (status) THEN
            IF context = NIL THEN
              PUSH context;
              context^ := osv$initial_exception_context;
              context^.file.selector := osc$ecp_file_reference;
              context^.file.file_reference := ^command_list^.system_command_library_lfn;
            IFEND;

            context^.condition_status := status;
            osp$enforce_exception_policies (context^);
            status := context^.condition_status;
          IFEND;
        UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
        library_accessable := TRUE;
        IF NOT status.normal THEN
          EXIT get_command_and_func_entries;
        IFEND;
      IFEND;
*IFEND

      IF options.commands THEN
*IF NOT $true(osv$unix)
{Add this back in when we have a real $SYSTEM
        convert_command_table (clv$system_commands^, largest_secondary_ordinal, command_entries);
*ELSE
        command_entries := NIL;
*IFEND
        IF command_dictionary <> NIL THEN
          secondary_entries := command_entries;
          convert_command_dictionary (command_dictionary^, largest_primary_ordinal, primary_entries);
          merge_entries (primary_entries^, largest_primary_ordinal, secondary_entries^, command_entries);
*IF NOT $true(osv$unix)
          IF jmp$system_job () THEN
            secondary_entries := command_entries;
            convert_command_table (clv$operator_commands^, largest_primary_ordinal, primary_entries);
            merge_entries (primary_entries^, largest_primary_ordinal, secondary_entries^, command_entries);
          IFEND;
*IFEND
        IFEND;
      IFEND;

      IF options.functions THEN
*IF NOT $true(osv$unix)
{Add this back in when have real $SYSTEM entry
        convert_function_proc_table (clv$system_functions^, largest_primary_ordinal, primary_entries);
        convert_function_table (clv$system_functions_v0^, largest_secondary_ordinal, secondary_entries);
        merge_entries (primary_entries^, largest_primary_ordinal, secondary_entries^, function_entries);
        IF function_dictionary <> NIL THEN
          secondary_entries := function_entries;
          convert_function_dictionary (function_dictionary^, largest_primary_ordinal, primary_entries);
          merge_entries (primary_entries^, largest_primary_ordinal, secondary_entries^, function_entries);
        IFEND;
*ELSE
        function_entries := NIL;
*IFEND
      IFEND;

    PROCEND get_system_entries;
*IF NOT $true(osv$unix)
?? TITLE := 'get_test_harness_entries', EJECT ??

    ?IF fsc$compiling_for_test_harness AND clc$compiling_for_test_harness THEN



      PROCEDURE get_test_harness_entries;

        VAR
          ignore_largest_ordinal: clt$named_entry_ordinal;


        command_reference.form := clc$system_command_ref;

        IF options.commands THEN
          convert_command_table (fsv$test_harness_cmnds^, ignore_largest_ordinal, command_entries);
        IFEND;

        IF options.functions THEN
          convert_function_table (fsv$test_harness_fnctns^, ignore_largest_ordinal, function_entries);
        IFEND;

      PROCEND get_test_harness_entries;

    ?IFEND
*IFEND
?? TITLE := 'get_utility_entries', EJECT ??

    PROCEDURE get_utility_entries
      (    utility_name: clt$utility_name;
           utility_info: clt$utility_command_environment);

      VAR
        largest_primary_ordinal: clt$named_entry_ordinal,
        largest_secondary_ordinal: clt$named_entry_ordinal,
        primary_entries: ^entry_array,
        secondary_entries: ^entry_array;


      command_reference.form := clc$utility_command_ref;
      command_reference.utility := utility_name;

      IF options.commands THEN
        IF utility_info.commands <> NIL THEN
          convert_command_table (utility_info.commands^, largest_primary_ordinal, command_entries);
        ELSE
          command_entries := NIL;
        IFEND;

        IF utility_info.dialog_info.commands <> NIL THEN
          convert_command_table (utility_info.dialog_info.commands^, largest_secondary_ordinal,
                secondary_entries);
          IF command_entries <> NIL THEN
            primary_entries := command_entries;
            merge_entries (primary_entries^, largest_primary_ordinal, secondary_entries^, command_entries);
          IFEND;
        IFEND;
      IFEND;

      IF options.functions THEN
        IF utility_info.contemporary_functions = NIL THEN
          primary_entries := NIL;
        ELSE
          convert_function_proc_table (utility_info.contemporary_functions^, largest_primary_ordinal,
                primary_entries);
        IFEND;
        IF utility_info.original_functions = NIL THEN
          secondary_entries := NIL;
        ELSE
          convert_function_table (utility_info.original_functions^, largest_secondary_ordinal,
                secondary_entries);
        IFEND;
        IF primary_entries <> NIL THEN
          IF secondary_entries <> NIL THEN
            merge_entries (primary_entries^, largest_primary_ordinal, secondary_entries^, function_entries);
            largest_primary_ordinal := largest_primary_ordinal + largest_secondary_ordinal;
          ELSE
            function_entries := primary_entries;
          IFEND;
        ELSEIF secondary_entries <> NIL THEN
          function_entries := secondary_entries;
          largest_primary_ordinal := largest_secondary_ordinal;
        IFEND;

        IF utility_info.dialog_info.functions <> NIL THEN
          convert_function_proc_table (utility_info.dialog_info.functions^, largest_secondary_ordinal,
                secondary_entries);
          IF function_entries <> NIL THEN
            primary_entries := function_entries;
            merge_entries (primary_entries^, largest_primary_ordinal, secondary_entries^, function_entries);
          ELSE
            function_entries := secondary_entries;
          IFEND;
        IFEND;
      IFEND;

    PROCEND get_utility_entries;
*IF NOT $true(osv$unix)
?? TITLE := 'get_working_catalog_entries', EJECT ??

    PROCEDURE [INLINE] get_working_catalog_entries;


      command_reference.form := clc$file_cycle_command_ref;
      command_reference.catalog := ':$WORKING_CATALOG';
      command_reference.cycle_number := 1 {not used} ;

{ No entries are returned for a catalog.

    PROCEND get_working_catalog_entries;
*IFEND
?? TITLE := 'merge_entries', EJECT ??

    PROCEDURE merge_entries
      (    primary_entries: entry_array;
           largest_primary_ordinal: clt$named_entry_ordinal;
           secondary_entries: entry_array;
       VAR merged_entries: ^entry_array);

      VAR
        i: integer,
        j: integer,
        k: integer;


      NEXT merged_entries: [1 .. UPPERBOUND (primary_entries) + UPPERBOUND (secondary_entries)] IN work_area;
      IF merged_entries = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT get_command_and_func_entries;
      IFEND;

      j := 1;
      k := 1;
      FOR i := 1 TO UPPERBOUND (merged_entries^) DO
        IF (k > UPPERBOUND (secondary_entries)) OR ((j <= UPPERBOUND (primary_entries)) AND
              (primary_entries [j].name <= secondary_entries [k].name)) THEN
          merged_entries^ [i].name := primary_entries [j].name;
          merged_entries^ [i].class := primary_entries [j].class;
          merged_entries^ [i].availability := primary_entries [j].availability;
          merged_entries^ [i].ordinal := primary_entries [j].ordinal;
          j := j + 1;
        ELSE
          merged_entries^ [i].name := secondary_entries [k].name;
          merged_entries^ [i].class := secondary_entries [k].class;
          IF (i > 1) AND (merged_entries^ [i].name = merged_entries^ [i - 1].name) THEN
            merged_entries^ [i].availability := clc$hidden_entry;
          ELSE
            merged_entries^ [i].availability := secondary_entries [k].availability;
          IFEND;
          merged_entries^ [i].ordinal := secondary_entries [k].ordinal + largest_primary_ordinal;
          k := k + 1;
        IFEND;
      FOREND;

    PROCEND merge_entries;
?? OLDTITLE, EJECT ??
*IF NOT $true(osv$unix)
    VAR
      context: ^ost$ecp_exception_context;
*IFEND

    status.normal := TRUE;
*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);

    context := NIL;

*IFEND
    library_accessable := TRUE;
    command_entries := NIL;
    function_entries := NIL;

    IF individual_entry <> NIL THEN
      CASE individual_entry^.kind OF
      = system_entry =
        get_system_entries;
      = utility_entry =
        get_utility_entries (individual_entry^.utility_name, individual_entry^.utility_info^);
*IF NOT $true(osv$unix)
      = file_entry =
        REPEAT
          clp$open_command_library (caller_id.ring, individual_entry^.path_handle_name,
                ignore_library_list_entry, local_file_name, status);
          IF osp$file_access_condition (status) THEN
            IF context = NIL THEN
              PUSH context;
              context^.file.selector := osc$ecp_file_reference;
              context^.file.file_reference := ^individual_entry^.path_handle_name;
            IFEND;
            context^.condition_status := status;
            osp$enforce_exception_policies (context^);
            status := context^.condition_status;
          IFEND;
        UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
        IF NOT status.normal THEN
          IF (status.condition = pfe$path_too_short) OR (status.condition = pfe$name_not_permanent_file) THEN
            status.normal := TRUE;
            get_catalog_entries (individual_entry^.path_handle_name);
          IFEND;
        ELSE

          individual_entry_open := TRUE;
          #SPOIL (individual_entry_open);
          osp$establish_block_exit_hndlr (^abort_handler);
          get_library_entries (local_file_name);
          REPEAT
            clp$close_command_library (local_file_name, status);
            IF osp$file_access_condition (status) THEN
              IF context = NIL THEN
                PUSH context;
                context^.file.selector := osc$ecp_file_reference;
                context^.file.file_reference := ^local_file_name;
              IFEND;
              context^.condition_status := status;
              osp$enforce_exception_policies (context^);
              status := context^.condition_status;
            IFEND;
          UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
          individual_entry_open := FALSE;
          #SPOIL (individual_entry_open);
          osp$disestablish_cond_handler;
        IFEND;
*IFEND
      CASEND;

    ELSEIF list_entry <> NIL THEN
      CASE list_entry^.kind OF
*IF NOT $true(osv$unix)
      = clc$library_commands =
        get_library_entries (list_entry^.local_file_name);
      = clc$catalog_commands =
        get_catalog_entries (list_entry^.local_file_name);
      = clc$working_catalog_commands =
        get_working_catalog_entries;
*IFEND
      = clc$system_commands =
        get_system_entries;
      = clc$sub_commands =
        get_utility_entries (list_entry^.utility_name, list_entry^.utility_info^);
      ELSE {clc$command_list_fence}
        ;
      CASEND;

*IF NOT $true(osv$unix)
    ELSEIF test_harness THEN
      ?IF fsc$compiling_for_test_harness AND clc$compiling_for_test_harness THEN
        get_test_harness_entries;
      ?IFEND
*IFEND

    ELSE
      get_intrinsic_entries;
    IFEND;


  PROCEND get_command_and_func_entries;
?? TITLE := 'utility_command_environment', EJECT ??

  FUNCTION [INLINE] utility_command_environment
    (    start_of_list: ^clt$command_list_entry;
         candidate_name: ost$name): ^clt$utility_command_environment;

    VAR
      current_entry: ^clt$command_list_entry;


    current_entry := start_of_list;
    WHILE current_entry <> NIL DO
      IF (current_entry^.kind = clc$sub_commands) AND (candidate_name = current_entry^.utility_name) THEN

        utility_command_environment := current_entry^.utility_info;
        RETURN;

      IFEND;
      current_entry := current_entry^.next_entry;
    WHILEND;

    utility_command_environment := NIL;

  FUNCEND utility_command_environment;

MODEND clm$display_command_list_entry;
*DECK DECK=CLM$DISPLAY_FILE_ATTB_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Display_File_Attributes Command and $FILE Function' ??
MODULE clm$display_file_attb_command;

{
{ PURPOSE:
{   This module contains the processors of the display_file_attributes command and $file function.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc ame$lfn_program_actions
*copyc ame$ring_validation_errors
*copyc bat$static_label_attributes
*copyc cle$ecc_file_reference
*copyc cle$work_area_overflow
*copyc clt$parameter_list
*copyc fsc$local
*copyc fse$get_info_validation_errors
*copyc fse$system_conditions
*copyc fst$cycle_damage_symptoms
*copyc fst$goi_object
*copyc fst$goi_object_information
*copyc fst$path
*copyc nfe$ptf_condition_codes
*copyc osd$exception_policies
*copyc osd$integer_limits
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc rmc$unspecified_file_class
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$return
*copyc amv$nil_file_identifier
*copyc avp$system_administrator
*copyc bap$get_default_file_attribs
*copyc bap$is_file_registered
*copyc bap$process_pt_request
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_cyc_ref_to_cyc_sel
*copyc clp$convert_data_to_string
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_integer_to_string
*copyc clp$convert_str_to_path_handle
*copyc clp$convert_string_to_file_ref
*copyc clp$count_list_elements
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc clp$find_current_block
*copyc clp$get_fs_path_elements
*copyc clp$get_ultimate_connection
*copyc clp$get_work_area
*copyc clp$get_working_catalog
*copyc clp$horizontal_tab_display
*copyc clp$make_boolean_value
*copyc clp$make_date_time_value
*copyc clp$make_entry_point_ref_value
*copyc clp$make_date_time_value
*copyc clp$make_file_value
*copyc clp$make_integer_value
*copyc clp$make_keyword_value
*copyc clp$make_list_value
*copyc clp$make_name_value
*copyc clp$make_record_value
*copyc clp$make_keyword_value
*copyc clp$make_list_value
*copyc clp$make_record_value
*copyc clp$make_string_value
*copyc clp$make_unspecified_value
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$open_display_reference
*copyc clp$put_data_representation
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$scan_argument_list
*copyc clp$trimmed_string_size
*copyc clv$nil_display_control
*copyc clv$value_descriptors
*copyc fsp$adjust_tape_defaults
*copyc fsp$convert_file_contents
*copyc fsp$convert_fs_structure_to_pf
*copyc fsp$determine_global_access
*copyc fsp$expand_file_label
*copyc fsp$file_is_$job_log
*copyc fsp$path_element
*copyc fsv$evaluated_file_reference
*copyc ifp$get_page_length_width
*copyc i#current_sequence_position
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc nfp$check_implicit_access
*copyc nfp$perform_implicit_access
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$establish_block_exit_hndlr
*copyc osp$find_access_condition_entry
*copyc osp$file_access_condition
*copyc osp$format_message
*copyc osp$format_wait_message
*copyc osp$generate_log_message
*copyc osp$get_status_condition_name
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osv$initial_exception_context
*copyc osv$lower_to_upper
*copyc osv$upper_to_lower
*copyc pfp$get_object_information
*copyc pfp$r3_get_object_information
*copyc pfp$utility_attach
*copyc pfv$null_unique_name
*copyc pmp$compute_date_time
*copyc pmp$date_time_compare
*copyc pmp$convert_binary_unique_name
*copyc pmp$get_compact_date_time
*copyc pmp$get_unique_name
*copyc pmp$get_user_identification
*copyc rmp$get_device_class

?? EJECT ??

  CONST
    max_access_share_mode_size = 7, {shorten,execute
    max_block_type_size = 16, {system_specified
    max_class_size = 15, {interstate_link,memory_resident
    max_file_contents = 15,
    max_file_organization_size = 18, {indexed_sequential
    max_file_processor = 18,
    max_forced_write_size = 26, {forced_if_structure_change
    max_global_file_position_size = 15, {end_of_key_list
    max_internal_code_size = 13, {ftam2 general
    max_job_file_position_size = 16, {$end_of_key_list
    max_key_type_size = 10, {uncollated
    max_label_type_size = 20, {non_standard_labeled
    max_logging_option_size = 23, {enable_request_recovery
    max_message_control_size = 14, {trivial_errors
    max_mf_attachment_size = 20, {requesting_mainframe
    max_open_position_size = 5, {$asis
    max_page_format_size = 13, {non_burstable
    max_record_type_size = 28, {trailing_character_delimited
    max_tape_density_size = 10, {mt18$38000
    max_write_concurrency_size = 22; {not_attached_for_write

  VAR
    access_share_modes: [STATIC, READ, oss$job_paged_literal] array [fst$file_access_option] of
          string (max_access_share_mode_size) := ['READ', 'SHORTEN', 'APPEND', 'MODIFY', 'EXECUTE'],
    block_types: [STATIC, READ, oss$job_paged_literal] array [amt$block_type] of
          string (max_block_type_size) := ['SYSTEM_SPECIFIED', 'USER_SPECIFIED'],
    class: [STATIC, READ, oss$job_paged_literal] array [rmt$device_class] of string (max_class_size) :=
          ['CONNECTED_FILE', 'INTERSTATE_LINK', 'LOCAL_QUEUE', 'LOG', 'MAGNETIC_TAPE', 'MASS_STORAGE',
          'MEMORY_RESIDENT', 'NETWORK', 'NULL', 'PIPELINE', 'RHFAM', 'TERMINAL'],
    file_organizations: [STATIC, READ, oss$job_paged_literal] array [amt$file_organization] of
          string (max_file_organization_size) := ['SEQUENTIAL', 'BYTE_ADDRESSABLE', 'INDEXED_SEQUENTIAL',
          'DIRECT_ACCESS', 'SYSTEM_KEY'],
    global_file_positions: [STATIC, READ, oss$job_paged_literal] array [amt$file_position] of
          string (max_global_file_position_size) := ['BOI', 'BOP', 'MID_RECORD', 'EOR', 'EOP', 'EOI',
          'END_OF_KEY_LIST'],
    internal_codes: [STATIC, READ, oss$job_paged_literal] array [amt$internal_code] of
          string (max_internal_code_size) := ['A6', 'A8', 'ASCII', 'D64', 'EBCDIC', 'BCD', 'D63', 'FTAM1 IA5',
          'FTAM1 VISIBLE', 'FTAM1 GRAPHIC', 'FTAM1 GENERAL', 'FTAM2 IA5', 'FTAM2 VISIBLE', 'FTAM2 GRAPHIC',
          'FTAM2 GENERAL'],
    job_file_positions: [STATIC, READ, oss$job_paged_literal] array [amt$file_position] of
          string (max_job_file_position_size) := ['$BOI', '$BOP', '$MID_RECORD', '$EOR', '$EOP', '$EOI',
          '$END_OF_KEY_LIST'],
    key_types: [STATIC, READ, oss$job_paged_literal] array [amt$key_type] of string (max_key_type_size) :=
          ['COLLATED', 'INTEGER', 'UNCOLLATED'],
    label_types: [STATIC, READ, oss$job_paged_literal] array [amt$label_type] of
          string (max_label_type_size) := ['LABELED', 'NON_STANDARD_LABELED', 'UNLABELED'],
    logging_possibilities: [STATIC, READ, oss$job_paged_literal] array
          [amc$enable_parcels .. amc$enable_request_recovery] of string (max_logging_option_size) :=
          ['ENABLE_PARCELS', 'ENABLE_MEDIA_RECOVERY', 'ENABLE_REQUEST_RECOVERY'],
    mainframe_attachments: [STATIC, READ, oss$job_paged_literal] array [fst$mf_usage_concurrency_scope] of
          string (max_mf_attachment_size) := ['REQUESTING_MAINFRAME', 'DIFFERENT_MAINFRAME'],
    mainframe_write_concurrencies: [STATIC, READ, oss$job_paged_literal]
          array [fst$mainframe_write_concurrency] of string (max_write_concurrency_size) :=
          ['NOT_ATTACHED_FOR_WRITE', 'SHARED_MEMORY', 'SHARED_MASS_STORAGE'],
    message_controls: [STATIC, READ, oss$job_paged_literal] array [amc$trivial_errors .. amc$statistics] of
          string (max_message_control_size) := ['TRIVIAL_ERRORS', 'MESSAGES', 'STATISTICS'],
    page_formats: [STATIC, READ, oss$job_paged_literal] array [amt$page_format] of
          string (max_page_format_size) := ['CONTINUOUS', 'BURSTABLE', 'NON_BURSTABLE', 'UNTITLED'],
    permit_share_options: [STATIC, READ, oss$job_paged_literal] array [pft$permit_options] of
          string (max_access_share_mode_size) := ['READ', 'SHORTEN', 'APPEND', 'MODIFY', 'EXECUTE', 'CYCLE',
          'CONTROL'],
    record_types: [STATIC, READ, oss$job_paged_literal] array [amt$record_type] of
          string (max_record_type_size) := ['VARIABLE', 'UNDEFINED', 'ANSI_FIXED', 'ANSI_SPANNED',
          'ANSI_VARIABLE', 'TRAILING_CHARACTER_DELIMITED'],
    reserved_file_processors: [STATIC, READ, oss$job_paged_literal] array [1 .. max_file_processor] of
          amt$file_processor := ['ADA', 'APL', 'ASSEMBLER', 'BASIC', 'C', 'COBOL', 'CYBIL', 'DEBUGGER',
          'FORTRAN', 'LISP', 'PASCAL', 'PLI', 'PPU_ASSEMBLER', 'PROLOG', 'SCL', 'SCU', 'VS', 'UNKNOWN'],
    tape_densities: [STATIC, READ, oss$job_paged_literal] array [rmc$200 .. rmc$38000] of
          string (max_tape_density_size) := ['MT9$200', 'MT9$556', 'MT9$800', 'MT9$1600', 'MT9$6250',
          'MT18$38000'];

  VAR
    clv$open_positions: [XDCL, #GATE, READ, oss$job_paged_literal] array [amt$open_position] of
          string (max_open_position_size) := ['$ASIS', '$BOI', '$BOP', '$EOI'];

?? EJECT ??

  CONST
    access_control_list = 1,
    account_project = 2,
    actual_job_access = 3,
    attached = 4,
    attached_external_vsn_list = 5,
    attached_recorded_vsn_list = 6,
    attached_transfer_size = 7,
    attached_vol_overflow_allowed = 8,
    attached_volume_number = 9,
    attachment_log = 10,
    attachment_logging_selected = 11,
    average_record_length = 12,
    block_type = 13,
    character_conversion = 14,
    collate_table_name = 15,
    compression_procedure_name = 16,
    connected_files = 17,
    creation_date_time = 18,
    cycle_number = 19,
    data_padding = 20,
    device_class = 21,
    dynamic_home_block_space = 22,
    embedded_key = 23,
    error_exit_procedure_name = 24,
    error_limit = 25,
    estimated_record_count = 26,
    exception_conditions = 27,
    expiration_date = 28,
    external_vsn_list = 29,
    file_access_procedure_name = 30,
    file_contents = 31,
    file_label_type = 32,
    file_limit = 33,
    file_organization = 34,
    file_previously_opened = 35,
    file_processor = 36,
    forced_write = 37,
    hashing_procedure_name = 38,
    index_levels = 39,
    index_padding = 40,
    initial_home_block_count = 41,
    internal_code = 42,
    job_file_address = 43,
    job_file_position = 44,
    job_instances_of_open = 45,
    job_write_concurrency = 46,
    key_length = 47,
    key_position = 48,
    key_type = 49,
    last_access_date_time = 50,
    last_data_modification_time = 51,
    last_modification_date_time = 52,
    lifetime = 53,
    lifetime_attachment_count = 54,
    line_number = 55,
    loading_factor = 56,
    lock_expiration_time = 57,
    log_residence = 58,
    logging_options = 59,
    mainframe_attachment = 60,
    mainframe_write_concurrency = 61,
    mass_storage_allocation_size = 62,
    mass_storage_bytes_allocated = 63,
    mass_storage_class = 64,
    mass_storage_free_behind = 65,
    mass_storage_initial_volume = 66,
    mass_storage_sequential_access = 67,
    mass_storage_transfer_size = 68,
    maximum_block_length = 69,
    maximum_record_length = 70,
    message_control = 71,
    minimum_block_length = 72,
    minimum_record_length = 73,
    object_type = 74,
    open_position = 75,
    padding_character = 76,
    page_format = 77,
    page_length = 78,
    page_width = 79,
    path = 80,
    permitted_access = 81,
    potential_job_access = 82,
    preset_value = 83,
    private_read = 84,
    record_delimiting_character = 85,
    record_limit = 86,
    record_type = 87,
    recorded_vsn_list = 88,
    records_per_block = 89,
    registered = 90,
    retrieve_option = 91,
    ring_attributes = 92,
    secondary_residence = 93,
    set_name = 94,
    shared_queue = 95,
    site_archive_option = 96,
    site_backup_option = 97,
    site_release_option = 98,
    size = 99,
    statement_identifier = 100,
    tape_density = 101,
    unique_data_name = 102,
    unique_name = 103,
    user_information = 104,
    vertical_print_density = 105,
    volume_overflow_allowed = 106,

    attribute_key_max = 106,
    catalog_attribute_max = 19,
    cycle_attribute_max = 101,
    file_attribute_max = 11;

  TYPE
    file_attribute_key = 1 .. attribute_key_max,
    file_attribute_keys = set of file_attribute_key,
    object_type_counts = record
      catalog_type: 0 .. catalog_attribute_max,
      file_type: 0 .. file_attribute_max,
      cycle_type: 0 .. cycle_attribute_max,
    recend,
    object_types = (catalog_object_type, cycle_object_type, file_object_type),
    unknown_object_pf_condition = pfe$unknown_cycle .. pfe$unknown_item;

  VAR
    catalog_and_cycle_identity: [READ, oss$job_paged_literal] file_attribute_keys :=
          [device_class, lifetime, object_type, path, registered, set_name, unique_data_name, unique_name],
    catalog_device_attributes: [READ, oss$job_paged_literal] file_attribute_keys :=
          [exception_conditions, mass_storage_allocation_size, mass_storage_bytes_allocated,
          mass_storage_class, recorded_vsn_list],
    cycle_info: [READ, oss$job_paged_literal] file_attribute_keys :=
          [creation_date_time, exception_conditions, expiration_date, last_access_date_time,
          last_data_modification_time, last_modification_date_time, lifetime_attachment_count,
          mainframe_attachment, mainframe_write_concurrency, potential_job_access, retrieve_option,
          site_archive_option, site_backup_option, site_release_option],
    device_info: [READ, oss$job_paged_literal] file_attribute_keys :=
          [exception_conditions, external_vsn_list, file_label_type, mass_storage_allocation_size,
          mass_storage_bytes_allocated, mass_storage_class, mass_storage_initial_volume,
          mass_storage_transfer_size, maximum_block_length, recorded_vsn_list, shared_queue, tape_density,
          volume_overflow_allowed],
    file_info: [READ, oss$job_paged_literal] file_attribute_keys :=
          [attachment_log, attachment_logging_selected],
    file_label_attributes: [READ, oss$job_paged_literal] file_attribute_keys :=
          [average_record_length, block_type, character_conversion, collate_table_name,
          compression_procedure_name, data_padding, dynamic_home_block_space, embedded_key,
          estimated_record_count, file_access_procedure_name, file_contents, file_label_type, file_limit,
          file_organization, file_previously_opened, file_processor, forced_write, hashing_procedure_name,
          index_levels, index_padding, initial_home_block_count, internal_code, key_length, key_position,
          key_type, line_number, loading_factor, lock_expiration_time, log_residence, logging_options,
          maximum_block_length, maximum_record_length, minimum_block_length, minimum_record_length,
          padding_character, page_format, page_length, page_width, preset_value, record_delimiting_character,
          record_limit, record_type, records_per_block, ring_attributes, statement_identifier,
          user_information, vertical_print_density],
    job_environment_info: [READ, oss$job_paged_literal] file_attribute_keys :=
          [actual_job_access, attached, attached_external_vsn_list, attached_recorded_vsn_list,
          attached_transfer_size, attached_vol_overflow_allowed, attached_volume_number, connected_files,
          error_exit_procedure_name, error_limit, job_file_address, job_file_position, job_instances_of_open,
          job_write_concurrency, mass_storage_free_behind, mass_storage_sequential_access, message_control,
          open_position, potential_job_access, private_read];

  VAR
    boolean_kind: [READ, oss$job_paged_literal] clt$boolean_kinds := clc$yes_no_boolean,
    file_label_info_request: [oss$job_paged_literal, READ] fst$goi_information_request :=
          [[fsc$specific_depth, 1], [fsc$goi_file_label]],
    initial_information_request: [oss$job_paged_literal, READ] fst$goi_information_request :=
          [[fsc$specific_depth, 1], []],
    null_unique_name: [oss$job_paged_literal, READ] ost$binary_unique_name :=
          [0, 0, 1980, 1, 1, 0, 0, 0, 0, 0],
    unknown_object_pf_conditions: [READ, oss$job_paged_literal] set of unknown_object_pf_condition :=
          [pfe$unknown_cycle, pfe$unknown_item, pfe$unknown_nth_subcatalog];

  CONST
    attribute_category_max = 7,
    nil_object_info_text = 'NEXT of object_information in work_area resulted in a NIL pointer in ' CAT
          'DISPLAY_FILE_ATTRIBUTES',
    old_$file_attb_max = 18;

  VAR
    attb_table_for_$file: [STATIC, READ, oss$job_paged_literal] array [1 .. old_$file_attb_max] of record
      name: ost$name,
      key: amt$file_attribute_keys,
    recend := [
          {} ['APPLICATION_INFORMATION        ', amc$application_info],
          {} ['ASSIGNED                       ', amc$null_attribute],
          {} ['ATTACHED                       ', amc$null_attribute],
          {} ['CATALOG                        ', amc$null_attribute],
          {} ['CYCLE_NUMBER                   ', amc$null_attribute],
          {} ['DEVICE_CLASS                   ', amc$null_attribute],
          {} ['FILE_CONTENTS                  ', amc$file_contents],
          {} ['FILE_LABEL_TYPE                ', amc$label_type],
          {} ['FILE_ORGANIZATION              ', amc$file_organization],
          {} ['FILE_PROCESSOR                 ', amc$file_processor],
          {} ['FILE_STRUCTURE                 ', amc$file_structure],
          {} ['GLOBAL_FILE_POSITION           ', amc$global_file_position],
          {} ['OPENED                         ', amc$null_attribute],
          {} ['OPEN_POSITION                  ', amc$open_position],
          {} ['PERMANENT                      ', amc$null_attribute],
          {} ['SIZE                           ', amc$file_length],
          {} ['TEMPORARY                      ', amc$null_attribute],
          {} ['USER_INFORMATION               ', amc$user_info]];

  VAR

{ The order of the entries in this array correspond to the order of the attribute constants defined above.

    attribute_choices: [STATIC, READ, oss$job_paged_literal] array [1 .. attribute_key_max] of record
      name: ost$name,
      applicable_object_types: set of object_types,
    recend := [
          {} ['ACCESS_CONTROL_LIST            ', [catalog_object_type, file_object_type]],
          {} ['ACCOUNT_PROJECT                ', [catalog_object_type, file_object_type]],
          {} ['ACTUAL_JOB_ACCESS              ', [cycle_object_type]],
          {} ['ATTACHED                       ', [cycle_object_type]],
          {} ['ATTACHED_EXTERNAL_VSN_LIST     ', [cycle_object_type]],
          {} ['ATTACHED_RECORDED_VSN_LIST     ', [cycle_object_type]],
          {} ['ATTACHED_TRANSFER_SIZE         ', [cycle_object_type]],
          {} ['ATTACHED_VOL_OVERFLOW_ALLOWED  ', [cycle_object_type]],
          {} ['ATTACHED_VOLUME_NUMBER         ', [cycle_object_type]],
          {} ['ATTACHMENT_LOG                 ', [file_object_type]],
          {} ['ATTACHMENT_LOGGING_SELECTED    ', [file_object_type]],
          {} ['AVERAGE_RECORD_LENGTH          ', [cycle_object_type]],
          {} ['BLOCK_TYPE                     ', [cycle_object_type]],
          {} ['CHARACTER_CONVERSION           ', [cycle_object_type]],
          {} ['COLLATE_TABLE_NAME             ', [cycle_object_type]],
          {} ['COMPRESSION_PROCEDURE_NAME     ', [cycle_object_type]],
          {} ['CONNECTED_FILES                ', [cycle_object_type]],
          {} ['CREATION_DATE_TIME             ', [catalog_object_type, cycle_object_type]],
          {} ['CYCLE_NUMBER                   ', [cycle_object_type]],
          {} ['DATA_PADDING                   ', [cycle_object_type]],
          {} ['DEVICE_CLASS                   ', [catalog_object_type, cycle_object_type]],
          {} ['DYNAMIC_HOME_BLOCK_SPACE       ', [cycle_object_type]],
          {} ['EMBEDDED_KEY                   ', [cycle_object_type]],
          {} ['ERROR_EXIT_PROCEDURE_NAME      ', [cycle_object_type]],
          {} ['ERROR_LIMIT                    ', [cycle_object_type]],
          {} ['ESTIMATED_RECORD_COUNT         ', [cycle_object_type]],
          {} ['EXCEPTION_CONDITIONS           ', [catalog_object_type, cycle_object_type]],
          {} ['EXPIRATION_DATE                ', [cycle_object_type]],
          {} ['EXTERNAL_VSN_LIST              ', [cycle_object_type]],
          {} ['FILE_ACCESS_PROCEDURE_NAME     ', [cycle_object_type]],
          {} ['FILE_CONTENTS                  ', [cycle_object_type]],
          {} ['FILE_LABEL_TYPE                ', [cycle_object_type]],
          {} ['FILE_LIMIT                     ', [cycle_object_type]],
          {} ['FILE_ORGANIZATION              ', [cycle_object_type]],
          {} ['FILE_PREVIOUSLY_OPENED         ', [cycle_object_type]],
          {} ['FILE_PROCESSOR                 ', [cycle_object_type]],
          {} ['FORCED_WRITE                   ', [cycle_object_type]],
          {} ['HASHING_PROCEDURE_NAME         ', [cycle_object_type]],
          {} ['INDEX_LEVELS                   ', [cycle_object_type]],
          {} ['INDEX_PADDING                  ', [cycle_object_type]],
          {} ['INITIAL_HOME_BLOCK_COUNT       ', [cycle_object_type]],
          {} ['INTERNAL_CODE                  ', [cycle_object_type]],
          {} ['JOB_FILE_ADDRESS               ', [cycle_object_type]],
          {} ['JOB_FILE_POSITION              ', [cycle_object_type]],
          {} ['JOB_INSTANCES_OF_OPEN          ', [cycle_object_type]],
          {} ['JOB_WRITE_CONCURRENCY          ', [cycle_object_type]],
          {} ['KEY_LENGTH                     ', [cycle_object_type]],
          {} ['KEY_POSITION                   ', [cycle_object_type]],
          {} ['KEY_TYPE                       ', [cycle_object_type]],
          {} ['LAST_ACCESS_DATE_TIME          ', [cycle_object_type]],
          {} ['LAST_DATA_MODIFICATION_TIME    ', [cycle_object_type]],
          {} ['LAST_MODIFICATION_DATE_TIME    ', [cycle_object_type]],
          {} ['LIFETIME                       ', [catalog_object_type, file_object_type, cycle_object_type]],
          {} ['LIFETIME_ATTACHMENT_COUNT      ', [cycle_object_type]],
          {} ['LINE_NUMBER                    ', [cycle_object_type]],
          {} ['LOADING_FACTOR                 ', [cycle_object_type]],
          {} ['LOCK_EXPIRATION_TIME           ', [cycle_object_type]],
          {} ['LOG_RESIDENCE                  ', [cycle_object_type]],
          {} ['LOGGING_OPTIONS                ', [cycle_object_type]],
          {} ['MAINFRAME_ATTACHMENT           ', [cycle_object_type]],
          {} ['MAINFRAME_WRITE_CONCURRENCY    ', [cycle_object_type]],
          {} ['MASS_STORAGE_ALLOCATION_SIZE   ', [catalog_object_type, cycle_object_type]],
          {} ['MASS_STORAGE_BYTES_ALLOCATED   ', [catalog_object_type, cycle_object_type]],
          {} ['MASS_STORAGE_CLASS             ', [catalog_object_type, cycle_object_type]],
          {} ['MASS_STORAGE_FREE_BEHIND       ', [cycle_object_type]],
          {} ['MASS_STORAGE_INITIAL_VOLUME    ', [cycle_object_type]],
          {} ['MASS_STORAGE_SEQUENTIAL_ACCESS ', [cycle_object_type]],
          {} ['MASS_STORAGE_TRANSFER_SIZE     ', [cycle_object_type]],
          {} ['MAXIMUM_BLOCK_LENGTH           ', [cycle_object_type]],
          {} ['MAXIMUM_RECORD_LENGTH          ', [cycle_object_type]],
          {} ['MESSAGE_CONTROL                ', [cycle_object_type]],
          {} ['MINIMUM_BLOCK_LENGTH           ', [cycle_object_type]],
          {} ['MINIMUM_RECORD_LENGTH          ', [cycle_object_type]],
          {} ['OBJECT_TYPE                    ', [catalog_object_type, file_object_type, cycle_object_type]],
          {} ['OPEN_POSITION                  ', [cycle_object_type]],
          {} ['PADDING_CHARACTER              ', [cycle_object_type]],
          {} ['PAGE_FORMAT                    ', [cycle_object_type]],
          {} ['PAGE_LENGTH                    ', [cycle_object_type]],
          {} ['PAGE_WIDTH                     ', [cycle_object_type]],
          {} ['PATH                           ', [catalog_object_type, file_object_type, cycle_object_type]],
          {} ['PERMITTED_ACCESS               ', [catalog_object_type, file_object_type]],
          {} ['POTENTIAL_JOB_ACCESS           ', [cycle_object_type]],
          {} ['PRESET_VALUE                   ', [cycle_object_type]],
          {} ['PRIVATE_READ                   ', [cycle_object_type]],
          {} ['RECORD_DELIMITING_CHARACTER    ', [cycle_object_type]],
          {} ['RECORD_LIMIT                   ', [cycle_object_type]],
          {} ['RECORD_TYPE                    ', [cycle_object_type]],
          {} ['RECORDED_VSN_LIST              ', [catalog_object_type, cycle_object_type]],
          {} ['RECORDS_PER_BLOCK              ', [cycle_object_type]],
          {} ['REGISTERED                     ', [catalog_object_type, file_object_type, cycle_object_type]],
          {} ['RETRIEVE_OPTION                ', [cycle_object_type]],
          {} ['RING_ATTRIBUTES                ', [cycle_object_type]],
          {} ['SECONDARY_RESIDENCE            ', [cycle_object_type]],
          {} ['SET_NAME                       ', [catalog_object_type, file_object_type, cycle_object_type]],
          {} ['SHARED_QUEUE                   ', [cycle_object_type]],
          {} ['SITE_ARCHIVE_OPTION            ', [cycle_object_type]],
          {} ['SITE_BACKUP_OPTION             ', [cycle_object_type]],
          {} ['SITE_RELEASE_OPTION            ', [cycle_object_type]],
          {} ['SIZE                           ', [catalog_object_type, cycle_object_type]],
          {} ['STATEMENT_IDENTIFIER           ', [cycle_object_type]],
          {} ['TAPE_DENSITY                   ', [cycle_object_type]],
          {} ['UNIQUE_DATA_NAME               ', [catalog_object_type, cycle_object_type]],
          {} ['UNIQUE_NAME                    ', [catalog_object_type, file_object_type, cycle_object_type]],
          {} ['USER_INFORMATION               ', [cycle_object_type]],
          {} ['VERTICAL_PRINT_DENSITY         ', [cycle_object_type]],
          {} ['VOLUME_OVERFLOW_ALLOWED        ', [catalog_object_type, cycle_object_type]]];

  VAR
    category_choices: [STATIC, READ, oss$job_paged_literal] array [1 .. attribute_category_max] of record
      name: ost$name,
      associated_attributes: file_attribute_keys,
      attribute_sums: object_type_counts,
    recend := [
          ['ALL',
          [access_control_list, account_project, actual_job_access, attached,
          attached_external_vsn_list, attached_recorded_vsn_list, attached_transfer_size,
          attached_vol_overflow_allowed, attached_volume_number, attachment_log, attachment_logging_selected,
          average_record_length, block_type, character_conversion, collate_table_name,
          compression_procedure_name, connected_files, creation_date_time, cycle_number, data_padding,
          device_class, dynamic_home_block_space, embedded_key, error_exit_procedure_name, error_limit,
          estimated_record_count, exception_conditions, expiration_date, external_vsn_list,
          file_access_procedure_name, file_contents, file_label_type, file_limit, file_organization,
          file_previously_opened, file_processor, forced_write, hashing_procedure_name, index_levels,
          index_padding, initial_home_block_count, internal_code, job_file_address, job_file_position,
          job_instances_of_open, job_write_concurrency, key_length, key_position, key_type,
          last_access_date_time, last_data_modification_time, last_modification_date_time, lifetime,
          lifetime_attachment_count, line_number, loading_factor, lock_expiration_time, log_residence,
          logging_options, mainframe_attachment, mainframe_write_concurrency, mass_storage_allocation_size,
          mass_storage_bytes_allocated, mass_storage_class, mass_storage_free_behind,
          mass_storage_initial_volume, mass_storage_sequential_access, mass_storage_transfer_size,
          maximum_block_length, maximum_record_length, message_control, minimum_block_length,
          minimum_record_length, object_type, open_position, padding_character, page_format, page_length,
          page_width, path, permitted_access, potential_job_access, preset_value, private_read,
          record_delimiting_character, record_limit, record_type, recorded_vsn_list, records_per_block,
          registered, ring_attributes, retrieve_option, secondary_residence, set_name, shared_queue,
          site_archive_option, site_backup_option, site_release_option, size, statement_identifier,
          tape_density, unique_data_name, unique_name, user_information, vertical_print_density,
          volume_overflow_allowed],
          [catalog_attribute_max, file_attribute_max, cycle_attribute_max]],

          ['CATALOG_REGISTRATION_ATTRIBUTES',
          [access_control_list, account_project, attachment_log, attachment_logging_selected,
          creation_date_time, cycle_number, exception_conditions, expiration_date, file_previously_opened,
          last_access_date_time, last_data_modification_time, last_modification_date_time, lifetime,
          lifetime_attachment_count, mainframe_attachment, mainframe_write_concurrency, object_type, path,
          permitted_access, potential_job_access, registered, secondary_residence, set_name, unique_data_name,
          unique_name],
          [12, 11, 20]],

          ['COMMON_FILE_ATTRIBUTES',
          [block_type, character_conversion, file_access_procedure_name, file_contents, file_label_type,
          file_limit, file_organization, file_processor, forced_write, internal_code, maximum_block_length,
          maximum_record_length, minimum_block_length, minimum_record_length, padding_character, preset_value,
          record_delimiting_character, record_type, ring_attributes, user_information],
          [0, 0, 20]],

          ['DEVICE_CLASS_ATTRIBUTES',
          [device_class, external_vsn_list, mass_storage_allocation_size, mass_storage_bytes_allocated,
          mass_storage_class, mass_storage_initial_volume, mass_storage_transfer_size, recorded_vsn_list,
          shared_queue, size, tape_density, volume_overflow_allowed],
          [7, 0, 12]],

          ['JOB_ENVIRONMENT_ATTRIBUTES',
          [actual_job_access, attached, attached_external_vsn_list, attached_recorded_vsn_list,
          attached_transfer_size, attached_vol_overflow_allowed, attached_volume_number, connected_files,
          error_exit_procedure_name, error_limit, job_file_address, job_file_position, job_instances_of_open,
          job_write_concurrency, mass_storage_free_behind, mass_storage_sequential_access, message_control,
          open_position, private_read],
          [0, 0, 19]],

          ['KEYED_FILE_ATTRIBUTES',
          [average_record_length, collate_table_name, compression_procedure_name, data_padding,
          dynamic_home_block_space, embedded_key, estimated_record_count, hashing_procedure_name,
          index_levels, index_padding, initial_home_block_count, key_length, key_position, key_type,
          loading_factor, lock_expiration_time, log_residence, logging_options, record_limit,
          records_per_block],
          [0, 0, 20]],

          ['PRESENTATION_FILE_ATTRIBUTES',
          [line_number, page_format, page_length, page_width, statement_identifier, vertical_print_density],
          [0, 0, 6]]];

  VAR

{ Each entry in this table represents a letter of the alphabet.  Assuming that the third character is unique
{ among each of the category keyword names, the entry that represents the third character of a category name,
{ contains the corresponding category's index in the table of category choices.

    category_hash_table: [STATIC, READ, oss$job_paged_literal] array [1 .. 26] of
          0 .. attribute_category_max := [
          {A} 0,
          {B} 5, {JOB_ENVIRONMENT_ATTRIBUTES}
          {C} 0,
          {D} 0,
          {E} 7, {PRESENTATION_FILE_ATTRIBUTES}
          {F} 0,
          {G} 0,
          {H} 0,
          {I} 0,
          {J} 0,
          {K} 0,
          {L} 1, {ALL}
          {M} 3, {COMMON_FILE_ATTRIBUTES}
          {N} 0,
          {O} 0,
          {P} 0,
          {Q} 0,
          {R} 0,
          {S} 0,
          {T} 2, {CATALOG_REGISTRATION_ATTRIBUTES}
          {U} 0,
          {V} 4, {DEVICE_CLASS_ATTRIBUTES}
          {W} 0,
          {X} 0,
          {Y} 6, {KEYED_FILE_ATTRIBUTES}
          {Z} 0];

  VAR

{ This table contains the indices into the table of attribute_choices, of the first attribute in the group of
{ attributes beginning with the same character.

    attribute_hash_table: [STATIC, READ, oss$job_paged_literal] array [1 .. 22] of 0 .. attribute_key_max := [
          {A} 1,
          {B} 13,
          {C} 14,
          {D} 20,
          {E} 23,
          {F} 30,
          {G} 0,
          {H} 38,
          {I} 39,
          {J} 43,
          {K} 47,
          {L} 50,
          {M} 60,
          {N} 0,
          {O} 74,
          {P} 76,
          {Q} 0,
          {R} 85,
          {S} 93,
          {T} 101,
          {U} 102,
          {V} 105];

  VAR
    catalog_attributes: [READ, oss$job_paged_literal] array [1 .. catalog_attribute_max] of
          file_attribute_key := [path, object_type, access_control_list, account_project, creation_date_time,
          device_class, exception_conditions, lifetime, mass_storage_allocation_size,
          mass_storage_bytes_allocated, mass_storage_class, permitted_access, recorded_vsn_list, registered,
          set_name, size, unique_data_name, unique_name, volume_overflow_allowed],

    file_attributes: [READ, oss$job_paged_literal] array [1 .. file_attribute_max] of file_attribute_key :=
          [path, object_type, access_control_list, account_project, attachment_log,
          attachment_logging_selected, lifetime, permitted_access, registered, set_name, unique_name],

    cycle_attributes: [READ, oss$job_paged_literal] array [1 .. cycle_attribute_max] of
          file_attribute_key := [cycle_number, object_type, actual_job_access, attached,
          attached_external_vsn_list, attached_recorded_vsn_list, attached_transfer_size,
          attached_vol_overflow_allowed, attached_volume_number, average_record_length, block_type,
          character_conversion, collate_table_name, compression_procedure_name, connected_files,
          creation_date_time, data_padding, device_class, dynamic_home_block_space, embedded_key,
          error_exit_procedure_name, error_limit, estimated_record_count, exception_conditions,
          expiration_date, external_vsn_list, file_access_procedure_name, file_contents, file_label_type,
          file_limit, file_organization, file_previously_opened, file_processor, forced_write,
          hashing_procedure_name, index_levels, index_padding, initial_home_block_count, internal_code,
          job_file_address, job_file_position, job_instances_of_open, job_write_concurrency, key_length,
          key_position, key_type, last_access_date_time, last_data_modification_time,
          last_modification_date_time, lifetime, lifetime_attachment_count, line_number, loading_factor,
          lock_expiration_time, log_residence, logging_options, mainframe_attachment,
          mainframe_write_concurrency, mass_storage_allocation_size, mass_storage_bytes_allocated,
          mass_storage_class, mass_storage_free_behind, mass_storage_initial_volume,
          mass_storage_sequential_access, mass_storage_transfer_size, maximum_block_length,
          maximum_record_length, message_control, minimum_block_length, minimum_record_length, open_position,
          padding_character, page_format, page_length, page_width, path, potential_job_access, preset_value,
          private_read, record_delimiting_character, record_limit, record_type, recorded_vsn_list,
          records_per_block, registered, retrieve_option, ring_attributes, secondary_residence, set_name,
          shared_queue, size, site_archive_option, site_backup_option, site_release_option,
          statement_identifier, tape_density, unique_data_name, unique_name, user_information,
          vertical_print_density, volume_overflow_allowed];

{ Damage Symptoms

  CONST
    parent_catalog_restored = 1,
    respf_modification_mismatch = 2,

{   cycle_restored = 3,
{   media_image_inconsistent = 4,

    max_damage_symptoms = 2;

  CONST
    access_condition_string = 'ACCESS_CONDITION',
    damage_symptom_string = 'DAMAGE_SYMPTOM';

  VAR
    damage_symptoms_table: [STATIC, READ, oss$job_paged_literal] array [1 .. max_damage_symptoms] of record
      damage_symptom: fst$cycle_damage_symptom,
      name: ost$name,
      status_condition: ost$name,
    recend := [[fsc$parent_catalog_restored, 'OSC$PARENT_CATALOG_RESTORED    ',
          'PFE$PARENT_CATALOG_RESTORED    '], [fsc$respf_modification_mismatch,
          'OSC$RESPF_MODIFICATION_MISMATCH', 'PFE$RESPF_MODIFICATION_MISMATCH']];

?? TITLE := 'determine_attributes_requested', EJECT ??

  PROCEDURE determine_attributes_requested
    (    option_value: ^clt$data_value;
     VAR attributes_requested: file_attribute_keys;
     VAR number_of_requested_attributes: object_type_counts;
     VAR all_requested: boolean);

    CONST
      all_index = 1,
      attribute_hash_index = 1,
      category_hash_index = 3; {unique character position}

    VAR
      attribute_index: ost$non_negative_integers,
      category_attributes: file_attribute_keys,
      current_option: ^clt$data_value,
      highest_attribute_index: ost$non_negative_integers,
      individual_attributes: file_attribute_keys,
      non_redundant_attributes: file_attribute_keys;

?? NEWTITLE := 'process_all_or_source_request', EJECT ??

    PROCEDURE [INLINE] process_all_or_source_request;

      attributes_requested := -$file_attribute_keys [];
      number_of_requested_attributes.catalog_type := catalog_attribute_max;
      number_of_requested_attributes.file_type := file_attribute_max;
      number_of_requested_attributes.cycle_type := cycle_attribute_max;
      all_requested := TRUE;

    PROCEND process_all_or_source_request;
?? OLDTITLE, EJECT ??
    all_requested := FALSE;

    IF (option_value^.element_value^.keyword_value = 'SOURCE') AND (option_value^.link = NIL) THEN
      process_all_or_source_request;
    ELSE
      number_of_requested_attributes.catalog_type := 0;
      number_of_requested_attributes.file_type := 0;
      number_of_requested_attributes.cycle_type := 0;
      category_attributes := $file_attribute_keys [];
      individual_attributes := $file_attribute_keys [];
      highest_attribute_index := 1;
      current_option := option_value;

      WHILE current_option <> NIL DO

{ First determine if the given keyword is a category name.  The following hashing algorithm assumes that the
{ third character of each category keyword name is unique.  If the given keyword is not a category name, then
{ the table of all the attribute names is searched.  Initially, the hashing is done on the first character of
{ the attribute and a linear search is performed on the rest of the attributes beginning with that same
{ character.

        attribute_index := category_hash_table [$INTEGER (current_option^.element_value^.
              keyword_value (category_hash_index)) - $INTEGER ('A') + 1];
        IF (attribute_index > 0) AND (current_option^.element_value^.keyword_value =
              category_choices [attribute_index].name) THEN
          IF attribute_index = all_index THEN
            process_all_or_source_request;
            RETURN;
          IFEND;
          category_attributes := category_attributes + category_choices [attribute_index].
                associated_attributes;
          number_of_requested_attributes.catalog_type := number_of_requested_attributes.catalog_type +
                category_choices [attribute_index].attribute_sums.catalog_type;
          number_of_requested_attributes.file_type := number_of_requested_attributes.file_type +
                category_choices [attribute_index].attribute_sums.file_type;
          number_of_requested_attributes.cycle_type := number_of_requested_attributes.cycle_type +
                category_choices [attribute_index].attribute_sums.cycle_type;
        ELSE { not a category }
          attribute_index := attribute_hash_table [($INTEGER (current_option^.element_value^.
                keyword_value (attribute_hash_index))) - $INTEGER ('A') + 1];

        /search_attribute_table/
          BEGIN
            WHILE current_option^.element_value^.keyword_value <> attribute_choices [attribute_index].name DO
              attribute_index := attribute_index + 1;
              IF current_option^.element_value^.keyword_value (1) <> attribute_choices [attribute_index].
                    name (1) THEN
                EXIT /search_attribute_table/;
              IFEND;
            WHILEND;

            IF NOT (attribute_index IN category_attributes) THEN
              individual_attributes := individual_attributes + $file_attribute_keys [attribute_index];
              IF attribute_index > highest_attribute_index THEN
                highest_attribute_index := attribute_index;
              IFEND;
            IFEND;
          END /search_attribute_table/;
        IFEND;

        current_option := current_option^.link;
      WHILEND;

      non_redundant_attributes := individual_attributes - category_attributes;
      IF non_redundant_attributes <> $file_attribute_keys [] THEN
        FOR attribute_index := 1 TO highest_attribute_index DO
          IF attribute_index IN non_redundant_attributes THEN
            number_of_requested_attributes.catalog_type := number_of_requested_attributes.
                  catalog_type + $INTEGER (catalog_object_type IN
                  attribute_choices [attribute_index].applicable_object_types);
            number_of_requested_attributes.cycle_type := number_of_requested_attributes.cycle_type +
                  $INTEGER (cycle_object_type IN attribute_choices [attribute_index].applicable_object_types);
            number_of_requested_attributes.file_type := number_of_requested_attributes.file_type +
                  $INTEGER (file_object_type IN attribute_choices [attribute_index].applicable_object_types);
          IFEND;
        FOREND;
      IFEND;
      attributes_requested := category_attributes + non_redundant_attributes;
    IFEND;

  PROCEND determine_attributes_requested;

?? TITLE := 'determine_object_info_requests', EJECT ??

  PROCEDURE determine_object_info_requests
    (    attributes_requested: file_attribute_keys;
     VAR info_request: {input, output} fst$goi_object_info_requests);

    IF (catalog_and_cycle_identity * attributes_requested) <> $file_attribute_keys [] THEN
      info_request := info_request + $fst$goi_object_info_requests
            [fsc$goi_catalog_identity, fsc$goi_cycle_identity];
    IFEND;
    IF (cycle_info * attributes_requested) <> $file_attribute_keys [] THEN
      info_request := info_request + $fst$goi_object_info_requests [fsc$goi_cycle_info];
    IFEND;
    IF (device_info * attributes_requested) <> $file_attribute_keys [] THEN
      info_request := info_request + $fst$goi_object_info_requests [fsc$goi_cycle_device_info];
      IF (catalog_device_attributes * attributes_requested) <> $file_attribute_keys [] THEN
        info_request := info_request + $fst$goi_object_info_requests [fsc$goi_catalog_device_info];
      IFEND;
    IFEND;
    IF (file_label_attributes * attributes_requested) <> $file_attribute_keys [] THEN
      info_request := info_request + $fst$goi_object_info_requests [fsc$goi_file_label];
    IFEND;
    IF (job_environment_info * attributes_requested) <> $file_attribute_keys [] THEN
      info_request := info_request + $fst$goi_object_info_requests [fsc$goi_job_environment_info];
      IF potential_job_access IN attributes_requested THEN
        info_request := info_request + $fst$goi_object_info_requests
              [fsc$goi_applicable_file_permit, fsc$goi_file_label];
      IFEND;
    IFEND;

    IF access_control_list IN attributes_requested THEN
      info_request := info_request + $fst$goi_object_info_requests
            [fsc$goi_catalog_permits, fsc$goi_file_permits];
    IFEND;
    IF account_project IN attributes_requested THEN
      info_request := info_request + $fst$goi_object_info_requests [fsc$goi_catalog_info, fsc$goi_file_info];
    IFEND;
    IF attachment_log IN attributes_requested THEN
      info_request := info_request + $fst$goi_object_info_requests [fsc$goi_file_log];
    IFEND;
    IF attachment_logging_selected IN attributes_requested THEN
      info_request := info_request + $fst$goi_object_info_requests [fsc$goi_file_info];
    IFEND;
    IF creation_date_time IN attributes_requested THEN
      info_request := info_request + $fst$goi_object_info_requests [fsc$goi_catalog_info, fsc$goi_cycle_info];
    IFEND;
    IF cycle_number IN attributes_requested THEN
      info_request := info_request + $fst$goi_object_info_requests [fsc$goi_cycle_identity];
    IFEND;
    IF permitted_access IN attributes_requested THEN
      info_request := info_request + $fst$goi_object_info_requests
            [fsc$goi_applicable_cat_permit, fsc$goi_applicable_file_permit];
    IFEND;
    IF (secondary_residence IN attributes_requested) THEN
      info_request := info_request + $fst$goi_object_info_requests [fsc$goi_archive_info];
    IFEND;
    IF set_name IN attributes_requested THEN
      info_request := info_request + $fst$goi_object_info_requests [fsc$goi_set_name];
    IFEND;
    IF size IN attributes_requested THEN
      info_request := info_request + $fst$goi_object_info_requests [fsc$goi_catalog_size, fsc$goi_cycle_size];
    IFEND;

  PROCEND determine_object_info_requests;

?? TITLE := 'get_$file_attribute_key', EJECT ??

  PROCEDURE get_$file_attribute_key
    (    name: ost$name;
     VAR key: amt$file_attribute_keys);

    VAR
      temp: integer,
      current_index: 1 .. old_$file_attb_max,
      low_index: 1 .. old_$file_attb_max + 1,
      high_index: 0 .. old_$file_attb_max;

    low_index := 1;
    high_index := old_$file_attb_max;

    REPEAT
      temp := low_index + high_index;
      current_index := temp DIV 2;
      IF name = attb_table_for_$file [current_index].name THEN
        key := attb_table_for_$file [current_index].key;
        RETURN;
      ELSEIF name > attb_table_for_$file [current_index].name THEN
        low_index := current_index + 1;
      ELSE
        high_index := current_index - 1;
      IFEND;
    UNTIL low_index > high_index;

    key := amc$null_attribute;

  PROCEND get_$file_attribute_key;

?? TITLE := 'get_connected_file_attributes', EJECT ??

  PROCEDURE get_connected_file_attributes
    (    object_information: ^fst$goi_object_information;
         validation_criteria: ^fst$goi_validation_criteria;
     VAR work_area_p: ^SEQ ( * );
     VAR file_label_p: ^SEQ ( * );
     VAR target_device_class: rmt$device_class;
     VAR status: ost$status);

    VAR
      connected_file: fst$path,
      local_evaluated_file_ref: fst$evaluated_file_reference,
      object_info_sequence_p: ^SEQ ( * ),
      path_handle_name: fst$path_handle_name,
      target_handle_name: fst$path_handle_name,
      target_object_information: ^fst$goi_object_information;

    connected_file := object_information^.resolved_path^;
    clp$convert_str_to_path_handle (connected_file, {deleted_allowed} TRUE, {resolved_path} FALSE,
          {include_open_pos_in_handle} FALSE, path_handle_name, local_evaluated_file_ref, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_ultimate_connection (path_handle_name, target_handle_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF path_handle_name <> target_handle_name THEN {target file found}
      clp$get_fs_path_elements (target_handle_name, local_evaluated_file_ref, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      object_info_sequence_p := work_area_p;
      get_object_information (local_evaluated_file_ref, file_label_info_request, validation_criteria,
            work_area_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      NEXT target_object_information IN object_info_sequence_p;
      IF target_object_information = NIL THEN
        osp$set_status_abnormal (amc$access_method_id, fse$system_error, nil_object_info_text, status);
        RETURN;
      IFEND;

      IF target_object_information^.object^.object_type = fsc$goi_file_object THEN
        IF target_object_information^.object^.cycle_object_list = NIL THEN
          file_label_p := NIL;
        ELSE
          file_label_p := target_object_information^.object^.cycle_object_list^ [1].file_label;
          target_device_class := target_object_information^.object^.cycle_object_list^ [1].cycle_device_class;
        IFEND;
      ELSE
        file_label_p := target_object_information^.object^.file_label;
        target_device_class := target_object_information^.object^.cycle_device_class;
      IFEND;

    IFEND; {path_handle_name <> target_handle_name}

  PROCEND get_connected_file_attributes;

?? TITLE := 'get_object_information', EJECT ??

  PROCEDURE [INLINE] get_object_information
    (    evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
         validation_criteria_p: ^fst$goi_validation_criteria;
     VAR object_info_sequence_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context,
      local_evaluated_file_reference: fst$evaluated_file_reference,
      local_sequence_p: ^SEQ ( * ),
      process_pt_results: bat$process_pt_results;

    context := NIL;
    local_evaluated_file_reference := evaluated_file_reference;

    IF (fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local) THEN
      bap$process_pt_request ($bat$process_pt_work_list [], {local_file_name} osc$null_name,
            local_evaluated_file_reference, process_pt_results, status);
    IFEND;

    REPEAT
      local_sequence_p := object_info_sequence_p;
      pfp$r3_get_object_information (local_evaluated_file_reference, information_request,
            validation_criteria_p, local_sequence_p, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_evaluated_file_ref;
          context^.file.evaluated_file_reference := local_evaluated_file_reference;
          IF validation_criteria_p <> NIL THEN
            context^.password := validation_criteria_p^ [1].password;
          IFEND;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
    object_info_sequence_p := local_sequence_p;

  PROCEND get_object_information;

?? TITLE := 'process_object_information', EJECT ??

  PROCEDURE process_object_information
    (    evaluated_file_reference: fst$evaluated_file_reference;
         caller_ring: ost$valid_ring;
         validation_criteria: ^fst$goi_validation_criteria;
         all_requested: boolean;
         requested_attribute_counts: object_type_counts;
         attributes_requested: file_attribute_keys;
     VAR object_info_sequence_p: ^SEQ ( * );
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? NEWTITLE := 'add_lifetime', EJECT ??

    PROCEDURE add_lifetime;

      VAR
        parsed_file_reference: fst$parsed_file_reference;

      IF evaluated_file_reference.path_structure_size <> 0 THEN
        IF fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local THEN
          IF (object_information_p <> NIL) AND (object_information_p^.resolved_path <> NIL) THEN
            clp$convert_string_to_file_ref (object_information_p^.resolved_path^, parsed_file_reference,
                  status);
            IF (parsed_file_reference.file_path_size <= fsc$local_size + 1) OR
                  (parsed_file_reference.path (1, fsc$local_size + 1) <> ':$LOCAL') THEN
              clp$make_keyword_value ('UNLIMITED', work_area, field_values^ [current_field_number].value);
            ELSE
              clp$make_keyword_value ('JOB', work_area, field_values^ [current_field_number].value);
            IFEND;
          ELSE
            clp$make_keyword_value ('JOB', work_area, field_values^ [current_field_number].value);
          IFEND;
        ELSE
          clp$make_keyword_value ('UNLIMITED', work_area, field_values^ [current_field_number].value);
        IFEND;
      ELSE
        clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
      IFEND;

    PROCEND add_lifetime;

?? TITLE := 'add_path', EJECT ??

    PROCEDURE add_path;

      VAR
        parsed_file_reference: fst$parsed_file_reference;

      IF (object_information_p <> NIL) AND (object_information_p^.resolved_path <> NIL) THEN
        clp$convert_string_to_file_ref (object_information_p^.resolved_path^, parsed_file_reference, status);
        clp$make_file_value (parsed_file_reference.path (1, parsed_file_reference.file_path_size), work_area,
              field_values^ [current_field_number].value);
      ELSEIF evaluated_file_reference.path_structure_size <> 0 THEN
        convert_file_ref_to_string (evaluated_file_reference, str, path_size);
        clp$make_file_value (str (1, path_size), work_area, field_values^ [current_field_number].value);
      ELSE
        clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
      IFEND;

    PROCEND add_path;

?? TITLE := 'add_set_name', EJECT ??

    PROCEDURE add_set_name;

      IF (object_information_p <> NIL) AND (object_information_p^.set_name <> osc$null_name) THEN
        clp$make_name_value (object_information_p^.set_name, work_area,
              field_values^ [current_field_number].value);
      ELSE
        clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
      IFEND;

    PROCEND add_set_name;

?? TITLE := 'build_catalog_attrib_record', EJECT ??

    PROCEDURE build_catalog_attrib_record
      (VAR result: ^clt$data_value);

?? TITLE := 'add_exception_conditions', EJECT ??

      PROCEDURE add_exception_conditions;

        VAR
          access_condition_entry: fst$access_condition_entry,
          catalog_device_info: ^fst$mass_storage_device_info,
          criteria: ost$ecp_criteria,
          entry_found: boolean,
          ignore_status: ost$status,
          status_condition_name: ost$status_condition_name,
          wait_message: oft$display_message;

        IF (object_information_p <> NIL) AND (object_information_p^.object^.catalog_device_information <> NIL)
              THEN
          catalog_device_info := ^object_information_p^.object^.catalog_device_information^.
                mass_storage_device_info;
          field_values^ [current_field_number].value := NIL;
          node := ^field_values^ [current_field_number].value;
          IF (catalog_device_info^.object_condition IN -$fst$file_access_conditions
                [fsc$space_unavailable, fsc$null_file_access_condition]) THEN

            osp$find_access_condition_entry (catalog_device_info^.object_condition, access_condition_entry,
                  entry_found);

            IF entry_found THEN
              clp$make_list_value (work_area, node^);
              clp$make_record_value (4, work_area, node^^.element_value);
              node^^.element_value^.field_values^ [1].name := 'NAME';
              clp$make_name_value (access_condition_entry.user_defined_condition, work_area,
                    node^^.element_value^.field_values^ [1].value);
              node^^.element_value^.field_values^ [2].name := 'STATUS_CONDITION';
              osp$get_status_condition_name (access_condition_entry.status_condition, status_condition_name,
                    ignore_status);
              clp$make_name_value (status_condition_name, work_area,
                    node^^.element_value^.field_values^ [2].value);
              node^^.element_value^.field_values^ [3].name := 'TYPE';
              clp$make_keyword_value (access_condition_string, work_area,
                    node^^.element_value^.field_values^ [3].value);
              node^^.element_value^.field_values^ [4].name := 'WAIT_MESSAGE_TEXT';
              IF catalog_device_info^.resides_online THEN
                osp$format_wait_message (^access_condition_entry, object_information_p^.resolved_path,
                      catalog_device_info^.mass_storage_class, catalog_device_info^.volume_condition_list,
                      catalog_device_info^.volume_list, wait_message);
              ELSE
                osp$format_wait_message (^access_condition_entry, object_information_p^.resolved_path,
                      rmc$unspecified_file_class, {volume_condition_list} NIL, {volume_list} NIL,
                      wait_message);
              IFEND;
              clp$make_string_value (wait_message.text (1, wait_message.size), work_area,
                    node^^.element_value^.field_values^ [4].value);
              node := ^node^^.link;
            IFEND;
          ELSE
            clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
          IFEND;
        ELSE
          clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
        IFEND;

      PROCEND add_exception_conditions;

      VAR
        permit_array: array [1 .. 1] of pft$permit_array_entry,
        volume_index: ost$positive_integers;

      clp$make_list_value (work_area, result);
      clp$make_record_value (number_of_requested_attributes.catalog_type, work_area, result^.element_value);
      field_values := result^.element_value^.field_values;
      current_field_number := 1;

      FOR attribute := 1 TO catalog_attribute_max DO
        IF current_field_number > number_of_requested_attributes.catalog_type THEN
          RETURN;
        IFEND;
        IF catalog_attributes [attribute] IN local_attributes_requested THEN
          field_values^ [current_field_number].name := attribute_choices [catalog_attributes [attribute]].
                name;
          CASE catalog_attributes [attribute] OF
          = access_control_list =
            IF (object_information_p <> NIL) AND (object_information_p^.object^.catalog_permits <> NIL) THEN
              get_permits (object_information_p^.object^.catalog_permits,
                    field_values^ [current_field_number].value);
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = account_project =
            IF (object_information_p <> NIL) AND (object_information_p^.object^.catalog_information <> NIL)
                  THEN
              clp$make_record_value (2, work_area, field_values^ [current_field_number].value);
              field_values^ [current_field_number].value^.field_values^ [1].name := 'ACCOUNT';
              clp$make_name_value (object_information_p^.object^.catalog_information^.account, work_area,
                    field_values^ [current_field_number].value^.field_values^ [1].value);
              field_values^ [current_field_number].value^.field_values^ [2].name := 'PROJECT';
              clp$make_name_value (object_information_p^.object^.catalog_information^.project, work_area,
                    field_values^ [current_field_number].value^.field_values^ [2].value);
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = creation_date_time =
            IF (object_information_p <> NIL) AND (object_information_p^.object^.catalog_information <> NIL)
                  THEN
              date_time.date_specified := TRUE;
              date_time.time_specified := TRUE;
              date_time.value := object_information_p^.object^.catalog_information^.creation_date_time;
              clp$make_date_time_value (date_time, work_area, field_values^ [current_field_number].value);
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = device_class =
            IF object_information_p <> NIL THEN
              clp$make_keyword_value ('MASS_STORAGE', work_area, field_values^ [current_field_number].value);
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = exception_conditions =
            add_exception_conditions;

          = lifetime =
            add_lifetime;

          = mass_storage_allocation_size =
            IF (object_information_p <> NIL) AND (object_information_p^.object^.catalog_device_information <>
                  NIL) THEN
              clp$make_integer_value (object_information_p^.object^.catalog_device_information^.
                    mass_storage_device_info.allocation_unit_size, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = mass_storage_bytes_allocated =
            IF (object_information_p <> NIL) AND (object_information_p^.object^.catalog_device_information <>
                  NIL) THEN
              clp$make_integer_value (object_information_p^.object^.catalog_device_information^.
                    mass_storage_device_info.bytes_allocated, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = mass_storage_class =
            IF (object_information_p <> NIL) AND (object_information_p^.object^.catalog_device_information <>
                  NIL) THEN
              character_string := object_information_p^.object^.catalog_device_information^.
                    mass_storage_device_info.mass_storage_class;
              clp$make_name_value (character_string, work_area, field_values^ [current_field_number].value);
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = object_type =
            IF (object_information_p <> NIL) AND (object_information_p^.object <> NIL) THEN
              clp$make_keyword_value ('CATALOG', work_area, field_values^ [current_field_number].value);
            ELSE { system_default_values requested or object not registered }
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = path =
            add_path;

          = permitted_access =
            IF (object_information_p <> NIL) AND (object_information_p^.object^.applicable_catalog_permit <>
                  NIL) THEN
              permit_array [1] := object_information_p^.object^.applicable_catalog_permit^;
              get_permits (^permit_array, field_values^ [current_field_number].value);
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = recorded_vsn_list =
            IF (object_information_p <> NIL) AND (object_information_p^.object^.catalog_device_information <>
                  NIL) THEN
              node := ^field_values^ [current_field_number].value;
              FOR volume_index := 1 TO UPPERBOUND (object_information_p^.object^.catalog_device_information^.
                    mass_storage_device_info.volume_list^) DO
                clp$make_list_value (work_area, node^);
                clp$make_name_value (object_information_p^.object^.catalog_device_information^.
                      mass_storage_device_info.volume_list^ [volume_index].recorded_vsn, work_area,
                      node^^.element_value);
                node := ^node^^.link;
              FOREND;
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = registered =
            IF object_information_p <> NIL THEN
              clp$make_boolean_value ((object_information_p^.object <> NIL), boolean_kind, work_area,
                    field_values^ [current_field_number].value);
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = set_name =
            add_set_name;

          = size =
            IF (object_information_p <> NIL) AND (object_information_p^.object^.catalog_size <> NIL) THEN
              clp$make_integer_value (object_information_p^.object^.catalog_size^, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = unique_data_name =
            IF object_information_p <> NIL THEN
              pmp$convert_binary_unique_name (object_information_p^.object^.catalog_global_file_name, gfn,
                    status);
              IF status.normal THEN
                clp$make_name_value (gfn, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
                status.normal := TRUE;
              IFEND;
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = unique_name =
            IF object_information_p <> NIL THEN
              pmp$convert_binary_unique_name (object_information_p^.object^.catalog_global_file_name, gfn,
                    status);
              IF status.normal THEN
                clp$make_name_value (gfn, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
                status.normal := TRUE;
              IFEND;
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = volume_overflow_allowed =
            IF object_information_p <> NIL THEN
              clp$make_boolean_value (FALSE, boolean_kind, work_area,
                    field_values^ [current_field_number].value);
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          ELSE
          CASEND;
          current_field_number := current_field_number + 1;
        IFEND;
      FOREND
    PROCEND build_catalog_attrib_record;

?? TITLE := 'build_cycle_attrib_record', EJECT ??

    PROCEDURE build_cycle_attrib_record
      (    cycle_object: ^fst$goi_object;
       VAR result: ^clt$data_value);

      CONST
        max_wait_message_length = 51, { osc$max_name_size + 20 }
        output_path_length = 14;

      VAR
        max_date_time: [STATIC, READ, oss$job_paged_literal] ost$date_time := [255, 12, 31, 23, 59, 59, 999],
        zero_date_time: [STATIC, READ, oss$job_paged_literal] ost$date_time := [0, 1, 1, 0, 0, 0, 0];

      VAR
        catalog_reference: clt$file_reference,
        combined_file_contents: amt$file_contents,
        conversion_status: ost$status,
        default_new_retention: fst$retention,
        default_new_retention_specified: boolean,
        determined_potential_access: pft$usage_selections,
        entry: ost$positive_integers,
        file_label_p: ^SEQ ( * ),
        fs_option: fst$file_access_option,
        logging_option: amt$logging_possibilities,
        message_control_value: amc$trivial_errors .. amc$statistics,
        mf_attachment: fst$mf_usage_concurrency_scope,
        now: ost$date_time,
        page_length_width: array [1 .. 2] of ift$terminal_attribute,
        parsed_file_reference: fst$parsed_file_reference,
        pf_option: pft$usage_options,
        previously_opened: boolean,
        required_share_modes: pft$share_selections,
        static_label_attributes: bat$static_label_attributes,
        target_device_class: rmt$device_class,
        time_increment: pmt$time_increment,
        volume_list: ^rmt$volume_list,
        wait_message: string (max_wait_message_length),
        wait_message_length: integer;

?? NEWTITLE := 'add_actual_job_access', EJECT ??

      PROCEDURE add_actual_job_access;

        IF (cycle_object <> NIL) AND (cycle_object^.job_environment_information <> NIL) THEN
          clp$make_record_value (2, work_area, field_values^ [current_field_number].value);

          field_values^ [current_field_number].value^.field_values^ [1].name := 'ACCESS_MODES';
          node := ^field_values^ [current_field_number].value^.field_values^ [1].value;
          IF cycle_object^.job_environment_information^.attached_access_modes = $fst$file_access_options
                [] THEN
            clp$make_keyword_value ('NONE', work_area, node^);
          ELSE
            FOR fs_option := LOWERVALUE (fst$file_access_option) TO UPPERVALUE (fst$file_access_option) DO
              IF fs_option IN cycle_object^.job_environment_information^.attached_access_modes THEN
                clp$make_list_value (work_area, node^);
                clp$make_keyword_value (access_share_modes [fs_option], work_area, node^^.element_value);
                node := ^node^^.link;
              IFEND;
            FOREND;
          IFEND;

          field_values^ [current_field_number].value^.field_values^ [2].name := 'SHARE_MODES';
          IF cycle_object^.job_environment_information^.attached_share_modes = $fst$file_access_options
                [] THEN
            clp$make_keyword_value ('NONE', work_area, field_values^ [current_field_number].value^.
                  field_values^ [2].value);
          ELSE
            node := ^field_values^ [current_field_number].value^.field_values^ [2].value;
            FOR fs_option := LOWERVALUE (fst$file_access_option) TO UPPERVALUE (fst$file_access_option) DO
              IF fs_option IN cycle_object^.job_environment_information^.attached_share_modes THEN
                clp$make_list_value (work_area, node^);
                clp$make_keyword_value (access_share_modes [fs_option], work_area, node^^.element_value);
                node := ^node^^.link;
              IFEND;
            FOREND;
          IFEND;
        ELSE
          clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
        IFEND;

      PROCEND add_actual_job_access;

?? TITLE := 'add_exception_conditions', EJECT ??

      PROCEDURE add_exception_conditions;

        VAR
          access_condition_entry: fst$access_condition_entry,
          criteria: ost$ecp_criteria,
          entry_found: boolean,
          ignore_status: ost$status,
          status_condition_name: ost$status_condition_name,
          wait_message: oft$display_message;

        IF cycle_object <> NIL THEN
          field_values^ [current_field_number].value := NIL;
          node := ^field_values^ [current_field_number].value;
          IF (cycle_object^.cycle_device_class = rmc$mass_storage_device) AND
                (cycle_object^.cycle_device_information <> NIL) AND
                (cycle_object^.cycle_device_information^.mass_storage_device_info.object_condition IN
                -$fst$file_access_conditions [fsc$null_file_access_condition, fsc$space_unavailable]) THEN

            osp$find_access_condition_entry (cycle_object^.cycle_device_information^.mass_storage_device_info.
                  object_condition, access_condition_entry, entry_found);

            IF entry_found THEN
              clp$make_list_value (work_area, node^);
              clp$make_record_value (4, work_area, node^^.element_value);
              node^^.element_value^.field_values^ [1].name := 'NAME';
              clp$make_name_value (access_condition_entry.user_defined_condition, work_area,
                    node^^.element_value^.field_values^ [1].value);
              node^^.element_value^.field_values^ [2].name := 'STATUS_CONDITION';
              osp$get_status_condition_name (access_condition_entry.status_condition, status_condition_name,
                    ignore_status);
              clp$make_name_value (status_condition_name, work_area,
                    node^^.element_value^.field_values^ [2].value);
              node^^.element_value^.field_values^ [3].name := 'TYPE';
              clp$make_keyword_value (access_condition_string, work_area,
                    node^^.element_value^.field_values^ [3].value);
              node^^.element_value^.field_values^ [4].name := 'WAIT_MESSAGE_TEXT';
              IF cycle_object^.cycle_device_information^.mass_storage_device_info.resides_online THEN
                osp$format_wait_message (^access_condition_entry, object_information_p^.resolved_path,
                      cycle_object^.cycle_device_information^.mass_storage_device_info.mass_storage_class,
                      cycle_object^.cycle_device_information^.mass_storage_device_info.volume_condition_list,
                      cycle_object^.cycle_device_information^.mass_storage_device_info.volume_list,
                      wait_message);
              ELSE
                osp$format_wait_message (^access_condition_entry, object_information_p^.resolved_path,
                      rmc$unspecified_file_class, {volume_condition_list} NIL, {volume_list} NIL,
                      wait_message);
              IFEND;
              clp$make_string_value (wait_message.text (1, wait_message.size), work_area,
                    node^^.element_value^.field_values^ [4].value);
              node := ^node^^.link;
            IFEND;
          IFEND;

          IF (cycle_object^.cycle_information <> NIL) AND (cycle_object^.cycle_information^.
                damage_symptoms <> $fst$cycle_damage_symptoms []) THEN
            FOR entry := 1 TO max_damage_symptoms DO
              IF damage_symptoms_table [entry].damage_symptom IN
                    cycle_object^.cycle_information^.damage_symptoms THEN
                clp$make_list_value (work_area, node^);
                clp$make_record_value (4, work_area, node^^.element_value);
                node^^.element_value^.field_values^ [1].name := 'NAME';
                clp$make_name_value (damage_symptoms_table [entry].name, work_area,
                      node^^.element_value^.field_values^ [1].value);
                node^^.element_value^.field_values^ [2].name := 'STATUS_CONDITION';
                clp$make_name_value (damage_symptoms_table [entry].status_condition, work_area,
                      node^^.element_value^.field_values^ [2].value);
                node^^.element_value^.field_values^ [3].name := 'TYPE';
                clp$make_keyword_value (damage_symptom_string, work_area,
                      node^^.element_value^.field_values^ [3].value);
                node^^.element_value^.field_values^ [4].name := 'WAIT_MESSAGE_TEXT';
                clp$make_unspecified_value (work_area, node^^.element_value^.field_values^ [4].value);
                node := ^node^^.link;
              IFEND;
            FOREND;
          ELSEIF field_values^ [current_field_number].value = NIL THEN
            clp$make_unspecified_value (work_area, node^);
          IFEND;
        ELSE
          clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
        IFEND;

      PROCEND add_exception_conditions;

?? TITLE := 'add_open_position', EJECT ??

      PROCEDURE add_open_position;

        IF cycle_object <> NIL THEN
          IF ((STRLENGTH (object_information_p^.resolved_path^) >= output_path_length) AND
                (object_information_p^.resolved_path^ (1, output_path_length) = ':$LOCAL.OUTPUT')) AND
                ((cycle_object^.job_environment_information = NIL) OR
                (cycle_object^.job_environment_information^.attachment_options_sources.open_position_source =
                amc$access_method_default)) THEN
            clp$make_keyword_value ('$EOI', work_area, field_values^ [current_field_number].value);
          ELSEIF cycle_object^.job_environment_information <> NIL THEN
            IF evaluated_file_reference.path_handle_info.path_handle.open_position.specified AND
                  (cycle_object^.job_environment_information^.attachment_options_sources.
                  open_position_source > amc$file_reference) THEN
              clp$make_keyword_value (clv$open_positions [evaluated_file_reference.path_handle_info.
                    path_handle.open_position.value], work_area, field_values^ [current_field_number].value);
            ELSE
              clp$make_keyword_value (clv$open_positions [cycle_object^.job_environment_information^.
                    open_position], work_area, field_values^ [current_field_number].value);
            IFEND
          ELSEIF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
            clp$make_keyword_value (clv$open_positions [evaluated_file_reference.path_handle_info.path_handle.
                  open_position.value], work_area, field_values^ [current_field_number].value);
          ELSE
            clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
          IFEND
        ELSEIF (evaluated_file_reference.path_structure_size <> 0) AND
              evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
          clp$make_keyword_value (clv$open_positions [evaluated_file_reference.path_handle_info.path_handle.
                open_position.value], work_area, field_values^ [current_field_number].value);
        ELSE
          clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
        IFEND;

      PROCEND add_open_position;

?? TITLE := 'add_potential_job_access', EJECT ??

      PROCEDURE add_potential_job_access;

        IF object_information_p <> NIL THEN
          clp$make_record_value (2, work_area, field_values^ [current_field_number].value);

          field_values^ [current_field_number].value^.field_values^ [1].name := 'ACCESS_MODES';
          node := ^field_values^ [current_field_number].value^.field_values^ [1].value;

{ The following special casing will no longer be necessary when get_object_information is enhanced to
{ return the applicable_file_permit for an unregistered object, to the owner or a nonowner with CYCLE
{ permission.

          IF (cycle_object = NIL) OR (object_information_p^.object^.object_type <> fsc$goi_file_object) THEN
            determined_potential_access := fmv$system_file_attributes.descriptive_label.global_access_mode;
            required_share_modes := fmv$system_file_attributes.descriptive_label.global_share_mode;
          ELSE
            IF fsp$file_is_$job_log (object_information_p^.resolved_path) AND
                  (cycle_object^.job_environment_information^.prevented_open_access_modes =
                  $fst$file_access_options []) THEN
              determined_potential_access := $pft$usage_selections [pfc$read, pfc$append];
            ELSE
              fsp$determine_global_access (caller_ring, cycle_object^.job_environment_information,
                    object_information_p^.object, cycle_object, static_label_attributes.ring_attributes,
                    determined_potential_access);
            IFEND;
            IF (cycle_object^.job_environment_information <> NIL) AND
                  cycle_object^.job_environment_information^.cycle_attached THEN
              #UNCHECKED_CONVERSION (cycle_object^.job_environment_information^.attached_share_modes,
                    required_share_modes);
            ELSEIF object_information_p^.object^.applicable_file_permit <> NIL THEN
              IF cycle_object^.cycle_information <> NIL THEN
                required_share_modes := object_information_p^.object^.applicable_file_permit^.
                      share_requirements + cycle_object^.cycle_information^.outstanding_access_modes;
              ELSE
                required_share_modes := object_information_p^.object^.applicable_file_permit^.
                      share_requirements;
              IFEND;
            ELSE
              required_share_modes := fmv$system_file_attributes.descriptive_label.global_share_mode;
            IFEND;
          IFEND;

          IF determined_potential_access = $pft$usage_selections [] THEN
            clp$make_keyword_value ('NONE', work_area, node^);
          ELSE
            FOR pf_option := LOWERVALUE (pft$usage_options) TO UPPERVALUE (pft$usage_options) DO
              IF pf_option IN determined_potential_access THEN
                clp$make_list_value (work_area, node^);
                clp$make_keyword_value (permit_share_options [pf_option], work_area, node^^.element_value);
                node := ^node^^.link;
              IFEND;
            FOREND;
          IFEND;

          field_values^ [current_field_number].value^.field_values^ [2].name := 'SHARE_MODES';
          node := ^field_values^ [current_field_number].value^.field_values^ [2].value;
          IF required_share_modes = $pft$share_requirements [] THEN
            clp$make_keyword_value ('NONE', work_area, node^);
          ELSE
            FOR pf_option := LOWERVALUE (pft$share_options) TO UPPERVALUE (pft$share_options) DO
              IF pf_option IN required_share_modes THEN
                clp$make_list_value (work_area, node^);
                clp$make_keyword_value (permit_share_options [pf_option], work_area, node^^.element_value);
                node := ^node^^.link;
              IFEND;
            FOREND;
          IFEND;
        ELSE
          clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
        IFEND;

      PROCEND add_potential_job_access;

?? TITLE := 'add_recorded_vsn_list', EJECT ??

      PROCEDURE add_recorded_vsn_list;

        IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_information <> NIL) THEN
          IF (cycle_object^.cycle_device_class = rmc$magnetic_tape_device) AND
                (cycle_object^.cycle_device_information^.magnetic_tape_device_info.volume_list <> NIL) THEN
            make_list_of_recorded_vsns (cycle_object^.cycle_device_information^.magnetic_tape_device_info.
                  volume_list);
          ELSEIF (cycle_object^.cycle_device_class = rmc$mass_storage_device) AND
                cycle_object^.cycle_device_information^.mass_storage_device_info.resides_online AND
                (cycle_object^.cycle_device_information^.mass_storage_device_info.volume_list <> NIL) THEN
            node := ^field_values^ [current_field_number].value;
            FOR entry := 1 TO UPPERBOUND (cycle_object^.cycle_device_information^.mass_storage_device_info.
                  volume_list^) DO
              clp$make_list_value (work_area, node^);
              clp$make_name_value (cycle_object^.cycle_device_information^.mass_storage_device_info.
                    volume_list^ [entry].recorded_vsn, work_area, node^^.element_value);
              node := ^node^^.link;
            FOREND;
          ELSE
            clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
          IFEND;
        ELSE
          clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
        IFEND;

      PROCEND add_recorded_vsn_list;

?? TITLE := 'add_retrieve_option', EJECT ??

    PROCEDURE add_retrieve_option;

      IF (cycle_object <> NIL) AND (cycle_object^.cycle_information <> NIL) THEN
        CASE cycle_object^.cycle_information^.retrieve_option OF
        = pfc$always_retrieve =
          clp$make_keyword_value ('ALWAYS_RETRIEVE', work_area, field_values^ [current_field_number].value);
        = pfc$explicit_retrieve_only =
          clp$make_keyword_value ('EXPLICIT_RETRIEVE_ONLY', work_area,
                field_values^ [current_field_number].value);
        = pfc$admin_retrieve_only =
          clp$make_keyword_value ('ADMINISTRATIVE_RETRIEVE_ONLY', work_area,
                field_values^ [current_field_number].value);
        ELSE
          clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
        CASEND;
      ELSE
        clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
      IFEND;

    PROCEND add_retrieve_option;

?? TITLE := 'add_secondary_residence', EJECT ??

      PROCEDURE add_secondary_residence;

        IF (cycle_object <> NIL) AND (cycle_object^.archive_information_list <> NIL) THEN
          node := ^field_values^ [current_field_number].value;
          date_time.date_specified := TRUE;
          date_time.time_specified := TRUE;
          FOR entry := 1 TO UPPERBOUND (cycle_object^.archive_information_list^) DO
            clp$make_list_value (work_area, node^);
            clp$make_record_value (6, work_area, node^^.element_value);
            node^^.element_value^.field_values^ [1].name := 'DEVICE_CLASS';
            clp$make_name_value (cycle_object^.archive_information_list^ [entry].archive_entry.
                  archive_identification.media_identifier.media_device_class, work_area,
                  node^^.element_value^.field_values^ [1].value);
            node^^.element_value^.field_values^ [2].name := 'DUPLICATION_DATE_TIME';
            date_time.value := cycle_object^.archive_information_list^ [entry].archive_entry.
                  archive_date_time;
            clp$make_date_time_value (date_time, work_area, node^^.element_value^.field_values^ [2].value);
            node^^.element_value^.field_values^ [3].name := 'LAST_DATA_MODIFICATION_TIME';
            date_time.value := cycle_object^.archive_information_list^ [entry].archive_entry.
                  modification_date_time;
            clp$make_date_time_value (date_time, work_area, node^^.element_value^.field_values^ [3].value);
            node^^.element_value^.field_values^ [4].name := 'LAST_DATA_RETRIEVAL_DATE_TIME';
            IF cycle_object^.archive_information_list^ [entry].archive_entry.last_retrieval_status.
                  retrieval_date_time = zero_date_time THEN
              clp$make_keyword_value ('NONE', work_area, node^^.element_value^.field_values^ [4].value);
            ELSE
              date_time.value := cycle_object^.archive_information_list^ [entry].archive_entry.
                    last_retrieval_status.retrieval_date_time;
              clp$make_date_time_value (date_time, work_area, node^^.element_value^.field_values^ [4].value);
            IFEND;
            node^^.element_value^.field_values^ [5].name := 'LAST_RETRIEVAL_STATUS_NORMAL';
            clp$make_boolean_value (cycle_object^.archive_information_list^ [entry].archive_entry.
                  last_retrieval_status.normal, boolean_kind, work_area, node^^.element_value^.
                  field_values^ [5].value);
            node^^.element_value^.field_values^ [6].name := 'SIZE';
            clp$make_integer_value (cycle_object^.archive_information_list^ [entry].archive_entry.file_size,
                  10, FALSE, work_area, node^^.element_value^.field_values^ [6].value);
            node := ^node^^.link;
          FOREND;
        ELSE
          clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
        IFEND;

      PROCEND add_secondary_residence;

?? TITLE := 'make_list_of_external_vsns', EJECT ??

      PROCEDURE make_list_of_external_vsns
        (    volume_list: ^rmt$volume_list);

        node := ^field_values^ [current_field_number].value;
        IF volume_list = NIL THEN
          clp$make_list_value (work_area, node^);
        ELSEIF volume_list^ [1].external_vsn = ' ' THEN
          clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
        ELSE
          FOR entry := 1 TO UPPERBOUND (volume_list^) DO
            clp$make_list_value (work_area, node^);
            clp$make_string_value (volume_list^ [entry].external_vsn, work_area, node^^.element_value);
            node := ^node^^.link;
          FOREND;
        IFEND;

      PROCEND make_list_of_external_vsns;

?? TITLE := 'make_list_of_recorded_vsns', EJECT ??

      PROCEDURE make_list_of_recorded_vsns
        (    volume_list: ^rmt$volume_list);

        node := ^field_values^ [current_field_number].value;
        IF volume_list = NIL THEN
          clp$make_list_value (work_area, node^);
        ELSEIF volume_list^ [1].recorded_vsn = ' ' THEN
          clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
        ELSE
          FOR entry := 1 TO UPPERBOUND (volume_list^) DO
            clp$make_list_value (work_area, node^);
            clp$make_string_value (volume_list^ [entry].recorded_vsn, work_area, node^^.element_value);
            node := ^node^^.link;
          FOREND;
        IFEND;

      PROCEND make_list_of_recorded_vsns;

?? OLDTITLE, EJECT ??

      clp$make_list_value (work_area, result);
      clp$make_record_value (number_of_requested_attributes.cycle_type, work_area, result^.element_value);
      field_values := result^.element_value^.field_values;

      IF object_information_p = NIL THEN { defaults requested }
        bap$get_default_file_attribs (static_label_attributes, default_new_retention_specified,
              default_new_retention, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSEIF (cycle_object <> NIL) AND (((file_label_attributes * local_attributes_requested) <>
            $file_attribute_keys []) OR (potential_job_access IN local_attributes_requested)) THEN
        file_label_p := cycle_object^.file_label;

        IF cycle_object^.cycle_device_class = rmc$connected_file_device THEN
          target_device_class := cycle_object^.cycle_device_class;
          get_connected_file_attributes (object_information_p, validation_criteria, work_area, file_label_p,
                target_device_class, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        fsp$expand_file_label (file_label_p, static_label_attributes, previously_opened, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF (NOT previously_opened) AND (cycle_object^.cycle_device_class = rmc$magnetic_tape_device) AND
              (($file_attribute_keys [file_label_type, maximum_block_length] * local_attributes_requested) <>
              $file_attribute_keys []) AND (cycle_object^.cycle_device_information <> NIL) THEN
          fsp$adjust_tape_defaults (cycle_object^.cycle_device_information^.magnetic_tape_device_info.density,
                static_label_attributes);
        IFEND;
      IFEND;

      IF (cycle_object <> NIL) AND ((cycle_object^.cycle_device_class = rmc$terminal_device) OR
            ((cycle_object^.cycle_device_class = rmc$connected_file_device) AND
            (target_device_class = rmc$terminal_device))) AND
            ((static_label_attributes.page_length_source = amc$access_method_default) OR
            (static_label_attributes.page_width_source = amc$access_method_default)) THEN
        ifp$get_page_length_width (evaluated_file_reference.path_handle_info.path_handle, page_length_width,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF static_label_attributes.page_length_source = amc$access_method_default THEN
          IF page_length_width [1].page_length = 0 THEN
            static_label_attributes.page_length := UPPERVALUE (amt$page_length);
          ELSE
            static_label_attributes.page_length := page_length_width [1].page_length;
          IFEND;
        IFEND;
        IF static_label_attributes.page_width_source = amc$access_method_default THEN
          IF page_length_width [2].page_width = 0 THEN
            static_label_attributes.page_width := amc$max_page_width;
          ELSE
            static_label_attributes.page_width := page_length_width [2].page_width;
          IFEND;
        IFEND;
      IFEND;

      current_field_number := 1;

      FOR attribute := 1 TO cycle_attribute_max DO
        IF current_field_number > number_of_requested_attributes.cycle_type THEN
          RETURN;
        IFEND;

        IF cycle_attributes [attribute] IN local_attributes_requested THEN
          field_values^ [current_field_number].name := attribute_choices [cycle_attributes [attribute]].name;
          IF (object_information_p <> NIL) AND (cycle_object = NIL) AND
                NOT (cycle_attributes [attribute] IN $file_attribute_keys
                [cycle_number, lifetime, open_position, path, potential_job_access, registered, set_name])
                THEN { attribute is not applicable for an unregistered object }
            clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
          ELSE
            CASE cycle_attributes [attribute] OF
            = actual_job_access =
              add_actual_job_access;

            = attached =
              IF cycle_object <> NIL THEN
                clp$make_boolean_value (((cycle_object^.job_environment_information <> NIL) AND
                      cycle_object^.job_environment_information^.cycle_attached), boolean_kind, work_area,
                      field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = attached_external_vsn_list =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$magnetic_tape_device) AND
                    (cycle_object^.job_environment_information <> NIL) AND
                    (cycle_object^.job_environment_information^.cycle_attached) THEN
                make_list_of_external_vsns (cycle_object^.job_environment_information^.volume_list);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = attached_recorded_vsn_list =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$magnetic_tape_device) AND
                    (cycle_object^.job_environment_information <> NIL) AND
                    (cycle_object^.job_environment_information^.cycle_attached) THEN
                make_list_of_recorded_vsns (cycle_object^.job_environment_information^.volume_list);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = attached_transfer_size =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$mass_storage_device) AND
                    (cycle_object^.job_environment_information <> NIL) AND
                    (cycle_object^.job_environment_information^.cycle_attached) AND
                    (fsc$transfer_size_ao IN cycle_object^.job_environment_information^.
                    specified_attachment_options) THEN
                clp$make_integer_value (cycle_object^.job_environment_information^.transfer_size, 10, FALSE,
                      work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = attached_vol_overflow_allowed =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$magnetic_tape_device) AND
                    (cycle_object^.job_environment_information <> NIL) AND
                    (cycle_object^.job_environment_information^.cycle_attached) THEN
                clp$make_boolean_value (cycle_object^.job_environment_information^.volume_overflow_allowed,
                      boolean_kind, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = attached_volume_number =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$magnetic_tape_device) AND
                    (cycle_object^.job_environment_information <> NIL) AND
                    (cycle_object^.job_environment_information^.cycle_attached) THEN
                clp$make_integer_value (cycle_object^.job_environment_information^.volume_number, 10, FALSE,
                      work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = average_record_length =
              IF static_label_attributes.average_record_length_source <> amc$undefined_attribute THEN
                clp$make_integer_value (static_label_attributes.average_record_length, 10, FALSE, work_area,
                      field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = block_type =
              clp$make_keyword_value (block_types [static_label_attributes.block_type], work_area,
                    field_values^ [current_field_number].value);

            = character_conversion =
              clp$make_boolean_value (static_label_attributes.character_conversion, boolean_kind, work_area,
                    field_values^ [current_field_number].value);

            = collate_table_name =
              IF static_label_attributes.collate_table_name = osc$null_name THEN
                clp$make_keyword_value ('NONE', work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_entry_point_ref_value (static_label_attributes.collate_table_name, '', work_area,
                      field_values^ [current_field_number].value);
              IFEND;

            = compression_procedure_name =
              IF static_label_attributes.compression_procedure_name.name = osc$null_name THEN
                clp$make_keyword_value ('NONE', work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_entry_point_ref_value (static_label_attributes.compression_procedure_name.name,
                      static_label_attributes.compression_procedure_name.object_library, work_area,
                      field_values^ [current_field_number].value);
              IFEND;

            = connected_files =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$connected_file_device) THEN
                node := ^field_values^ [current_field_number].value;
                IF (cycle_object^.job_environment_information <> NIL) AND
                      (cycle_object^.job_environment_information^.connected_files <> NIL) THEN
                  FOR entry := 1 TO UPPERBOUND (cycle_object^.job_environment_information^.connected_files^)
                        DO
                    clp$make_list_value (work_area, node^);
                    clp$make_file_value (cycle_object^.job_environment_information^.connected_files^ [entry]
                          (1, clp$trimmed_string_size (cycle_object^.job_environment_information^.
                          connected_files^ [entry])), work_area, node^^.element_value);
                    node := ^node^^.link;
                  FOREND;
                ELSE
                  clp$make_list_value (work_area, node^);
                IFEND;
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = creation_date_time =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_information <> NIL) THEN
                date_time.date_specified := TRUE;
                date_time.time_specified := TRUE;
                date_time.value := cycle_object^.cycle_information^.creation_date_time;
                clp$make_date_time_value (date_time, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = cycle_number =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_global_file_name <> null_unique_name) THEN
                clp$make_integer_value (cycle_object^.cycle_number, 10, FALSE, work_area,
                      field_values^ [current_field_number].value);
              ELSEIF (evaluated_file_reference.path_structure_size <> 0) AND
                    (evaluated_file_reference.cycle_reference.specification = fsc$cycle_number) THEN
                clp$make_integer_value (evaluated_file_reference.cycle_reference.cycle_number, 10, FALSE,
                      work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = data_padding =
              clp$make_integer_value (static_label_attributes.data_padding, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);

            = device_class =
              IF cycle_object <> NIL THEN
                clp$make_keyword_value (class [cycle_object^.cycle_device_class],
                      work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = dynamic_home_block_space =
              clp$make_boolean_value (static_label_attributes.dynamic_home_block_space, boolean_kind,
                    work_area, field_values^ [current_field_number].value);

            = embedded_key =
              clp$make_boolean_value (static_label_attributes.embedded_key, boolean_kind, work_area,
                    field_values^ [current_field_number].value);

            = error_exit_procedure_name =
              IF cycle_object <> NIL THEN
                IF (cycle_object^.job_environment_information = NIL) OR
                      (cycle_object^.job_environment_information^.error_exit_procedure_name = osc$null_name)
                      THEN
                  clp$make_keyword_value ('NONE', work_area, field_values^ [current_field_number].value);
                ELSE
                  clp$make_entry_point_ref_value (cycle_object^.job_environment_information^.
                        error_exit_procedure_name, '', work_area, field_values^ [current_field_number].value);
                IFEND;
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = error_limit =
              IF (cycle_object <> NIL) AND (cycle_object^.job_environment_information <> NIL) THEN
                clp$make_integer_value (cycle_object^.job_environment_information^.error_limit, 10, FALSE,
                      work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = estimated_record_count =
              IF static_label_attributes.estimated_record_count_source <> amc$undefined_attribute THEN
                clp$make_integer_value (static_label_attributes.estimated_record_count, 10, FALSE, work_area,
                      field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = exception_conditions =
              add_exception_conditions;

            = expiration_date =
              IF cycle_object <> NIL THEN
                clp$convert_string_to_file_ref (object_information_p^.resolved_path^, parsed_file_reference,
                      status);
                IF (parsed_file_reference.file_path_size > fsc$local_size + 1) AND
                      (parsed_file_reference.path (1, fsc$local_size + 1) = ':$LOCAL') THEN
                  clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
                ELSEIF (cycle_object^.cycle_information = NIL) OR
                      (cycle_object^.cycle_information^.expiration_date_time = max_date_time) THEN
                  clp$make_keyword_value ('INFINITE', work_area, field_values^ [current_field_number].value);
                ELSE
                  date_time.value := cycle_object^.cycle_information^.expiration_date_time;
                  date_time.date_specified := TRUE;
                  date_time.time_specified := FALSE;
                  clp$make_date_time_value (date_time, work_area, field_values^ [current_field_number].value);
                IFEND;
              ELSE
                IF NOT default_new_retention_specified THEN
                  clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
                ELSE
                  CASE default_new_retention.selector OF
                  = fsc$retention_day_increment =
                    time_increment.year := 0;
                    time_increment.month := 0;
                    time_increment.day := default_new_retention.day_increment;
                    time_increment.hour := 0;
                    time_increment.minute := 0;
                    time_increment.second := 0;
                    time_increment.millisecond := 0;
                  = fsc$retention_time_increment =
                    time_increment := default_new_retention.time_increment;
                  = fsc$retention_expiration_date =
                    ;
                  CASEND;
                  IF default_new_retention.selector = fsc$retention_expiration_date THEN
                    date_time.value := default_new_retention.expiration_date;
                  ELSE
                    pmp$get_compact_date_time (now, status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;
                    pmp$compute_date_time (now, time_increment, date_time.value, status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;
                  IFEND;
                  IF (default_new_retention.selector = fsc$retention_day_increment) AND
                        (default_new_retention.day_increment = UPPERVALUE (pft$retention)) THEN
                    clp$make_keyword_value ('INFINITE', work_area,
                          field_values^ [current_field_number].value);
                  ELSE
                    date_time.date_specified := TRUE;
                    date_time.time_specified := FALSE;
                    clp$make_date_time_value (date_time, work_area,
                          field_values^ [current_field_number].value);
                  IFEND;
                IFEND;
              IFEND;

            = external_vsn_list =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$magnetic_tape_device) AND
                    (cycle_object^.cycle_device_information <> NIL) AND
                    (cycle_object^.cycle_device_information^.magnetic_tape_device_info.volume_list <> NIL)
                    THEN
                make_list_of_external_vsns (cycle_object^.cycle_device_information^.magnetic_tape_device_info.
                      volume_list);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = file_access_procedure_name =
              IF static_label_attributes.file_access_procedure = osc$null_name THEN
                clp$make_keyword_value ('NONE', work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_entry_point_ref_value (static_label_attributes.file_access_procedure, '', work_area,
                      field_values^ [current_field_number].value);
              IFEND;

            = file_contents =
              fsp$convert_file_contents (static_label_attributes.file_contents,
                    static_label_attributes.file_structure, combined_file_contents, conversion_status);
              IF conversion_status.normal THEN
                clp$make_keyword_value (combined_file_contents, work_area,
                      field_values^ [current_field_number].value);
              ELSE
                clp$make_name_value (static_label_attributes.file_contents, work_area,
                      field_values^ [current_field_number].value);
              IFEND;

            = file_label_type =
              clp$make_keyword_value (label_types [static_label_attributes.label_type], work_area,
                    field_values^ [current_field_number].value);

            = file_limit =
              clp$make_integer_value (static_label_attributes.file_limit, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);

            = file_organization =
              clp$make_keyword_value (file_organizations [static_label_attributes.file_organization],
                    work_area, field_values^ [current_field_number].value);

            = file_previously_opened =
              IF cycle_object <> NIL THEN
                clp$make_boolean_value (previously_opened, boolean_kind, work_area,
                      field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = file_processor =

            /search_reserved_file_processors/
              BEGIN
                FOR entry := 1 TO UPPERBOUND (reserved_file_processors) DO
                  IF static_label_attributes.file_processor = reserved_file_processors [entry] THEN
                    clp$make_keyword_value (static_label_attributes.file_processor, work_area,
                          field_values^ [current_field_number].value);
                    EXIT /search_reserved_file_processors/;
                  IFEND;
                FOREND;
                clp$make_name_value (static_label_attributes.file_processor, work_area,
                      field_values^ [current_field_number].value);
              END /search_reserved_file_processors/;


            = forced_write =
              IF static_label_attributes.forced_write = amc$forced_if_structure_change THEN
                clp$make_keyword_value ('FORCED_IF_STRUCTURE_CHANGE', work_area,
                      field_values^ [current_field_number].value);
              ELSE
                clp$make_boolean_value ((static_label_attributes.forced_write = amc$forced), boolean_kind,
                      work_area, field_values^ [current_field_number].value);
              IFEND;

            = hashing_procedure_name =
              IF (static_label_attributes.hashing_procedure_name_source = amc$undefined_attribute) OR
                    (static_label_attributes.hashing_procedure_name.name = osc$null_name) THEN
                clp$make_keyword_value ('NONE', work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_entry_point_ref_value (static_label_attributes.hashing_procedure_name.name,
                      static_label_attributes.hashing_procedure_name.object_library, work_area,
                      field_values^ [current_field_number].value);
              IFEND;

            = index_levels =
              clp$make_integer_value (static_label_attributes.index_levels, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);

            = index_padding =
              clp$make_integer_value (static_label_attributes.index_padding, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);

            = initial_home_block_count =
              clp$make_integer_value (static_label_attributes.initial_home_block_count, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);

            = internal_code =
              clp$make_keyword_value (internal_codes [static_label_attributes.internal_code], work_area,
                    field_values^ [current_field_number].value);

            = job_file_address =
              IF (cycle_object <> NIL) AND (cycle_object^.job_environment_information <> NIL) THEN
                clp$make_integer_value (cycle_object^.job_environment_information^.job_file_address, 10,
                      FALSE, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = job_file_position =
              IF (cycle_object <> NIL) AND (cycle_object^.job_environment_information <> NIL) THEN
                clp$make_keyword_value (job_file_positions [cycle_object^.job_environment_information^.
                      job_file_position], work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = job_instances_of_open =
              IF (cycle_object <> NIL) AND (cycle_object^.job_environment_information <> NIL) THEN
                clp$make_integer_value (cycle_object^.job_environment_information^.concurrent_open_count, 10,
                      FALSE, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = job_write_concurrency =
              IF (cycle_object <> NIL) AND (cycle_object^.job_environment_information <> NIL) AND
                    (fsc$job_write_concurrency_ao IN cycle_object^.job_environment_information^.
                    specified_attachment_options) THEN
                clp$make_boolean_value (cycle_object^.job_environment_information^.job_write_concurrency,
                      boolean_kind, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = key_length =
              IF static_label_attributes.key_length_source <> amc$undefined_attribute THEN
                clp$make_integer_value (static_label_attributes.key_length, 10, FALSE, work_area,
                      field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = key_position =
              clp$make_integer_value (static_label_attributes.key_position, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);

            = key_type =
              clp$make_keyword_value (key_types [static_label_attributes.key_type],
                    work_area, field_values^ [current_field_number].value);

            = last_access_date_time =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_information <> NIL) THEN
                date_time.date_specified := TRUE;
                date_time.time_specified := TRUE;
                date_time.value := cycle_object^.cycle_information^.last_access_date_time;
                clp$make_date_time_value (date_time, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = last_data_modification_time =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_information <> NIL) THEN
                date_time.date_specified := TRUE;
                date_time.time_specified := TRUE;
                date_time.value := cycle_object^.cycle_information^.data_modification_date_time;
                clp$make_date_time_value (date_time, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = last_modification_date_time =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_information <> NIL) THEN
                date_time.date_specified := TRUE;
                date_time.time_specified := TRUE;
                date_time.value := cycle_object^.cycle_information^.last_modification_date_time;
                clp$make_date_time_value (date_time, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = lifetime =
              add_lifetime;

            = lifetime_attachment_count =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_information <> NIL) THEN
                clp$make_integer_value (cycle_object^.cycle_information^.lifetime_attachment_count, 10, FALSE,
                      work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = line_number =
              IF static_label_attributes.line_number_source <> amc$undefined_attribute THEN
                clp$make_record_value (2, work_area, field_values^ [current_field_number].value);
                field_values^ [current_field_number].value^.field_values^ [1].name := 'LOCATION';
                clp$make_integer_value (static_label_attributes.line_number.location, 10, FALSE, work_area,
                      field_values^ [current_field_number].value^.field_values^ [1].value);
                field_values^ [current_field_number].value^.field_values^ [2].name := 'LENGTH';
                clp$make_integer_value (static_label_attributes.line_number.length, 10, FALSE, work_area,
                      field_values^ [current_field_number].value^.field_values^ [2].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = loading_factor =
              clp$make_integer_value (static_label_attributes.loading_factor, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);

            = lock_expiration_time =
              clp$make_integer_value (static_label_attributes.lock_expiration_time, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);

            = logging_options =
              IF static_label_attributes.logging_options <> $amt$logging_options [] THEN
                node := ^field_values^ [current_field_number].value;
                FOR logging_option := LOWERVALUE (amt$logging_possibilities)
                      TO UPPERVALUE (amt$logging_possibilities) DO
                  IF logging_option IN static_label_attributes.logging_options THEN
                    clp$make_list_value (work_area, node^);
                    clp$make_keyword_value (logging_possibilities [logging_option], work_area,
                          node^^.element_value);
                    node := ^node^^.link;
                  IFEND;
                FOREND;
              ELSE
                clp$make_keyword_value ('NONE', work_area, field_values^ [current_field_number].value);
              IFEND;

            = log_residence =
              IF static_label_attributes.log_residence <> ' ' THEN
                clp$make_file_value (static_label_attributes.log_residence, work_area,
                      field_values^ [current_field_number].value);
              ELSE
                clp$make_keyword_value ('NONE', work_area, field_values^ [current_field_number].value);
              IFEND;

            = mainframe_attachment =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_information <> NIL) AND
                    (cycle_object^.cycle_information^.mainframe_usage_concurrency <>
                    $fst$mainframe_usage_concurrency []) THEN
                node := ^field_values^ [current_field_number].value;
                FOR mf_attachment := LOWERVALUE (fst$mf_usage_concurrency_scope)
                      TO UPPERVALUE (fst$mf_usage_concurrency_scope) DO
                  IF mf_attachment IN cycle_object^.cycle_information^.mainframe_usage_concurrency THEN
                    clp$make_list_value (work_area, node^);
                    clp$make_keyword_value (mainframe_attachments [mf_attachment], work_area,
                          node^^.element_value);
                    node := ^node^^.link;
                  IFEND;
                FOREND;
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = mainframe_write_concurrency =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_information <> NIL) AND
                    (cycle_object^.cycle_information^.mainframe_write_concurrency <>
                    fsc$not_attached_for_write) THEN
                clp$make_keyword_value (mainframe_write_concurrencies
                      [cycle_object^.cycle_information^.mainframe_write_concurrency], work_area,
                      field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = mass_storage_allocation_size =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$mass_storage_device) AND
                    (cycle_object^.cycle_device_information <> NIL) AND
                    cycle_object^.cycle_device_information^.mass_storage_device_info.resides_online THEN
                clp$make_integer_value (cycle_object^.cycle_device_information^.mass_storage_device_info.
                      allocation_unit_size, 10, FALSE, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = mass_storage_bytes_allocated =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$mass_storage_device) AND
                    (cycle_object^.cycle_device_information <> NIL) AND
                    cycle_object^.cycle_device_information^.mass_storage_device_info.resides_online THEN
                clp$make_integer_value (cycle_object^.cycle_device_information^.mass_storage_device_info.
                      bytes_allocated, 10, FALSE, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = mass_storage_class =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$mass_storage_device) AND
                    (cycle_object^.cycle_device_information <> NIL) AND
                    cycle_object^.cycle_device_information^.mass_storage_device_info.resides_online THEN
                character_string := cycle_object^.cycle_device_information^.mass_storage_device_info.
                      mass_storage_class;
                clp$make_name_value (character_string, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = mass_storage_free_behind =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$mass_storage_device) AND
                    (cycle_object^.job_environment_information <> NIL) AND
                    (fsc$free_behind_ao IN cycle_object^.job_environment_information^.
                    specified_attachment_options) THEN
                clp$make_boolean_value (cycle_object^.job_environment_information^.mass_storage_free_behind,
                      boolean_kind, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = mass_storage_initial_volume =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$mass_storage_device) AND
                    (cycle_object^.cycle_device_information <> NIL) AND
                    cycle_object^.cycle_device_information^.mass_storage_device_info.resides_online AND
                    (cycle_object^.cycle_device_information^.mass_storage_device_info.initial_volume <> ' ')
                    THEN
                clp$make_string_value (cycle_object^.cycle_device_information^.mass_storage_device_info.
                      initial_volume, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = mass_storage_sequential_access =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$mass_storage_device) AND
                    (cycle_object^.job_environment_information <> NIL) AND
                    (fsc$sequential_access_ao IN cycle_object^.job_environment_information^.
                    specified_attachment_options) THEN
                clp$make_boolean_value (cycle_object^.job_environment_information^.
                      mass_storage_sequential_access, boolean_kind, work_area,
                      field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = mass_storage_transfer_size =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$mass_storage_device) AND
                    (cycle_object^.cycle_device_information <> NIL) AND
                    cycle_object^.cycle_device_information^.mass_storage_device_info.resides_online THEN
                clp$make_integer_value (cycle_object^.cycle_device_information^.mass_storage_device_info.
                      transfer_size, 10, FALSE, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = maximum_block_length =
              clp$make_integer_value (static_label_attributes.max_block_length, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);

            = maximum_record_length =
              clp$make_integer_value (static_label_attributes.max_record_length, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);

            = message_control =
              IF (cycle_object <> NIL) AND (cycle_object^.job_environment_information <> NIL) THEN
                IF cycle_object^.job_environment_information^.message_control <> $amt$message_control [] THEN
                  node := ^field_values^ [current_field_number].value;
                  FOR message_control_value := amc$trivial_errors TO amc$statistics DO
                    IF message_control_value IN cycle_object^.job_environment_information^.
                          message_control THEN
                      clp$make_list_value (work_area, node^);
                      clp$make_keyword_value (message_controls [message_control_value], work_area,
                            node^^.element_value);
                      node := ^node^^.link;
                    IFEND;
                  FOREND;
                ELSE
                  clp$make_keyword_value ('NONE', work_area, field_values^ [current_field_number].value);
                IFEND;
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = minimum_block_length =
              clp$make_integer_value (static_label_attributes.min_block_length, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);

            = minimum_record_length =
              clp$make_integer_value (static_label_attributes.min_record_length, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);

            = object_type =
              IF (object_information_p <> NIL) AND (cycle_object <> NIL) THEN
                clp$make_keyword_value ('CYCLE', work_area, field_values^ [current_field_number].value);
              ELSE { system_default_values requested or object not registered }
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = open_position =
              add_open_position;

            = padding_character =
              character_string := static_label_attributes.padding_character;
              clp$make_string_value (character_string, work_area, field_values^ [current_field_number].value);

            = page_format =
              clp$make_keyword_value (page_formats [static_label_attributes.page_format], work_area,
                    field_values^ [current_field_number].value);

            = page_length =
              clp$make_integer_value (static_label_attributes.page_length, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);

            = page_width =
              clp$make_integer_value (static_label_attributes.page_width, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);

            = path =
              add_path;

            = potential_job_access =
              add_potential_job_access;

            = preset_value =
              clp$make_integer_value (static_label_attributes.preset_value, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);

            = private_read =
              IF (cycle_object <> NIL) AND (cycle_object^.job_environment_information <> NIL) AND
                    cycle_object^.job_environment_information^.private_read.specified_on_attach THEN
                clp$make_boolean_value (cycle_object^.job_environment_information^.private_read.value,
                      boolean_kind, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = record_delimiting_character =
              character_string := static_label_attributes.record_delimiting_character;
              clp$make_string_value (character_string, work_area, field_values^ [current_field_number].value);

            = record_limit =
              IF static_label_attributes.record_limit_source <> amc$undefined_attribute THEN
                clp$make_integer_value (static_label_attributes.record_limit, 10, FALSE, work_area,
                      field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = record_type =
              clp$make_keyword_value (record_types [static_label_attributes.record_type], work_area,
                    field_values^ [current_field_number].value);

            = recorded_vsn_list =
              add_recorded_vsn_list;

            = records_per_block =
              IF static_label_attributes.records_per_block_source <> amc$undefined_attribute THEN
                clp$make_integer_value (static_label_attributes.records_per_block, 10, FALSE, work_area,
                      field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = registered =
              IF (object_information_p <> NIL) THEN
                clp$make_boolean_value (((cycle_object <> NIL) AND
                      (cycle_object^.cycle_global_file_name <> null_unique_name)), boolean_kind, work_area,
                      field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = retrieve_option =
              add_retrieve_option;

            = ring_attributes =
              clp$make_record_value (3, work_area, field_values^ [current_field_number].value);
              field_values^ [current_field_number].value^.field_values^ [1].name := 'R1';
              clp$make_integer_value (static_label_attributes.ring_attributes.r1, 10, FALSE, work_area,
                    field_values^ [current_field_number].value^.field_values^ [1].value);
              field_values^ [current_field_number].value^.field_values^ [2].name := 'R2';
              clp$make_integer_value (static_label_attributes.ring_attributes.r2, 10, FALSE, work_area,
                    field_values^ [current_field_number].value^.field_values^ [2].value);
              field_values^ [current_field_number].value^.field_values^ [3].name := 'R3';
              clp$make_integer_value (static_label_attributes.ring_attributes.r3, 10, FALSE, work_area,
                    field_values^ [current_field_number].value^.field_values^ [3].value);

            = secondary_residence =
              add_secondary_residence;

            = set_name =
              add_set_name;

            = shared_queue =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$mass_storage_device) AND
                    (cycle_object^.cycle_device_information <> NIL) AND
                    (cycle_object^.cycle_device_information^.mass_storage_device_info.shared_queue <>
                    osc$null_name) THEN
                clp$make_keyword_value (cycle_object^.cycle_device_information^.mass_storage_device_info.
                      shared_queue, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = site_archive_option =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_information <> NIL) AND
                    (cycle_object^.cycle_information^.site_archive_option <> 0) THEN
                clp$make_integer_value (cycle_object^.cycle_information^.site_archive_option, 10,
                      FALSE, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_keyword_value ('NULL', work_area, field_values^ [current_field_number].value);
              IFEND;

            = site_backup_option =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_information <> NIL) AND
                    (cycle_object^.cycle_information^.site_backup_option <> 0) THEN
                clp$make_integer_value (cycle_object^.cycle_information^.site_backup_option, 10,
                      FALSE, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_keyword_value ('NULL', work_area, field_values^ [current_field_number].value);
              IFEND;

            = site_release_option =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_information <> NIL) AND
                    (cycle_object^.cycle_information^.site_release_option <> 0) THEN
                clp$make_integer_value (cycle_object^.cycle_information^.site_release_option, 10,
                      FALSE, work_area, field_values^ [current_field_number].value);
              ELSE
                clp$make_keyword_value ('NULL', work_area, field_values^ [current_field_number].value);
              IFEND;

            = size =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_size <> NIL) THEN
                clp$make_integer_value (cycle_object^.cycle_size^, 10, FALSE, work_area,
                      field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = statement_identifier =
              IF static_label_attributes.statement_identifier_source <> amc$undefined_attribute THEN
                clp$make_record_value (2, work_area, field_values^ [current_field_number].value);
                field_values^ [current_field_number].value^.field_values^ [1].name := 'LOCATION';
                clp$make_integer_value (static_label_attributes.statement_identifier.location, 10, FALSE,
                      work_area, field_values^ [current_field_number].value^.field_values^ [1].value);
                field_values^ [current_field_number].value^.field_values^ [2].name := 'LENGTH';
                clp$make_integer_value (static_label_attributes.statement_identifier.length, 10, FALSE,
                      work_area, field_values^ [current_field_number].value^.field_values^ [2].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = tape_density =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$magnetic_tape_device) AND
                    (cycle_object^.cycle_device_information <> NIL) THEN
                clp$make_keyword_value (tape_densities [cycle_object^.cycle_device_information^.
                      magnetic_tape_device_info.density], work_area,
                      field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = unique_data_name =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$mass_storage_device) THEN
                pmp$convert_binary_unique_name (cycle_object^.cycle_global_file_name, gfn, status);
                IF status.normal THEN
                  clp$make_name_value (gfn, work_area, field_values^ [current_field_number].value);
                ELSE
                  clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
                  status.normal := TRUE;
                IFEND;
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = unique_name =
              IF cycle_object <> NIL THEN
                pmp$convert_binary_unique_name (cycle_object^.cycle_global_file_name, gfn, status);
                IF status.normal THEN
                  clp$make_name_value (gfn, work_area, field_values^ [current_field_number].value);
                ELSE
                  clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
                  status.normal := TRUE;
                IFEND;
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            = user_information =
              IF static_label_attributes.user_info <> ' ' THEN
                clp$make_string_value (static_label_attributes.user_info
                      (1, clp$trimmed_string_size (static_label_attributes.user_info)), work_area,
                      field_values^ [current_field_number].value);
              ELSE
                clp$make_string_value ('', work_area, field_values^ [current_field_number].value);
              IFEND;

            = vertical_print_density =
              clp$make_integer_value (static_label_attributes.vertical_print_density, 10, FALSE, work_area,
                    field_values^ [current_field_number].value);

            = volume_overflow_allowed =
              IF (cycle_object <> NIL) AND (cycle_object^.cycle_device_class = rmc$mass_storage_device) AND
                    (cycle_object^.cycle_device_information <> NIL) THEN
                clp$make_boolean_value (cycle_object^.cycle_device_information^.mass_storage_device_info.
                      volume_overflow_allowed, boolean_kind, work_area,
                      field_values^ [current_field_number].value);
              ELSE
                clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
              IFEND;

            ELSE
            CASEND;
          IFEND; {unregistered object}
          current_field_number := current_field_number + 1;
        IFEND; {attribute requested}
      FOREND;

    PROCEND build_cycle_attrib_record;

?? TITLE := 'build_file_attrib_record', EJECT ??

    PROCEDURE build_file_attrib_record
      (VAR result: ^clt$data_value);

      VAR
        entry: ost$positive_integers,
        permit_array: array [1 .. 1] of pft$permit_array_entry;

      clp$make_list_value (work_area, result);
      clp$make_record_value (number_of_requested_attributes.file_type, work_area, result^.element_value);
      field_values := result^.element_value^.field_values;
      current_field_number := 1;

      FOR attribute := 1 TO file_attribute_max DO
        IF current_field_number > number_of_requested_attributes.file_type THEN
          RETURN;
        IFEND;
        IF file_attributes [attribute] IN local_attributes_requested THEN
          field_values^ [current_field_number].name := attribute_choices [file_attributes [attribute]].name;
          CASE file_attributes [attribute] OF
          = access_control_list =
            IF (object_information_p <> NIL) AND (object_information_p^.object <> NIL) AND
                  (object_information_p^.object^.file_permits <> NIL) THEN
              get_permits (object_information_p^.object^.file_permits,
                    field_values^ [current_field_number].value);
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = account_project =
            IF (object_information_p <> NIL) AND (object_information_p^.object <> NIL) AND
                  (object_information_p^.object^.file_information <> NIL) THEN
              clp$make_record_value (2, work_area, field_values^ [current_field_number].value);
              field_values^ [current_field_number].value^.field_values^ [1].name := 'ACCOUNT';
              clp$make_name_value (object_information_p^.object^.file_information^.account, work_area,
                    field_values^ [current_field_number].value^.field_values^ [1].value);
              field_values^ [current_field_number].value^.field_values^ [2].name := 'PROJECT';
              clp$make_name_value (object_information_p^.object^.file_information^.project, work_area,
                    field_values^ [current_field_number].value^.field_values^ [2].value);
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = attachment_log =
            IF (object_information_p <> NIL) AND (object_information_p^.object <> NIL) THEN
              node := ^field_values^ [current_field_number].value;
              IF object_information_p^.object^.file_log <> NIL THEN
                FOR entry := 1 TO UPPERBOUND (object_information_p^.object^.file_log^) DO
                  clp$make_list_value (work_area, node^);
                  clp$make_record_value (5, work_area, node^^.element_value);
                  node^^.element_value^.field_values^ [1].name := 'USER';
                  clp$make_name_value (object_information_p^.object^.file_log^ [entry].user_id.user,
                        work_area, node^^.element_value^.field_values^ [1].value);
                  node^^.element_value^.field_values^ [2].name := 'FAMILY';
                  clp$make_name_value (object_information_p^.object^.file_log^ [entry].user_id.family,
                        work_area, node^^.element_value^.field_values^ [2].value);
                  node^^.element_value^.field_values^ [3].name := 'FILE_ACCESS_COUNT';
                  clp$make_integer_value (object_information_p^.object^.file_log^ [entry].access_count, 10,
                        FALSE, work_area, node^^.element_value^.field_values^ [3].value);
                  node^^.element_value^.field_values^ [4].name := 'LAST_ACCESS_DATE_TIME';
                  date_time.date_specified := TRUE;
                  date_time.time_specified := TRUE;
                  date_time.value := object_information_p^.object^.file_log^ [entry].access_date_time;
                  clp$make_date_time_value (date_time, work_area,
                        node^^.element_value^.field_values^ [4].value);
                  node^^.element_value^.field_values^ [5].name := 'LAST_CYCLE_REFERENCED';
                  clp$make_integer_value (object_information_p^.object^.file_log^ [entry].last_cycle, 10,
                        FALSE, work_area, node^^.element_value^.field_values^ [5].value);
                  node := ^node^^.link;
                FOREND;
              ELSE
                IF NOT all_requested THEN { this procedure call was already made if all_requested is true }
                  pmp$get_user_identification (user_id, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;
                IFEND;
                IF (NOT avp$system_administrator ()) AND (fsp$path_element (^evaluated_file_reference,
                      2) ^ <> user_id.user) AND (fsp$path_element (^evaluated_file_reference,
                      1) ^ <> fsc$local) THEN
                  osp$set_status_abnormal (amc$access_method_id, fse$attribute_not_available,
                        'ATTACHMENT_LOG', status);
                  osp$append_status_file (osc$status_parameter_delimiter,
                        object_information_p^.resolved_path^, status);
                ELSE
                  clp$make_list_value (work_area, node^);
                IFEND;
              IFEND;
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = attachment_logging_selected =
            IF (object_information_p <> NIL) AND (object_information_p^.object <> NIL) AND
                  (object_information_p^.object^.file_information <> NIL) THEN
              IF object_information_p^.object^.file_information^.logging_selection = NIL THEN
                IF NOT all_requested THEN { this procedure call was already made if all_requested is true }
                  pmp$get_user_identification (user_id, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;
                IFEND;
                IF (NOT avp$system_administrator ()) AND (fsp$path_element (^evaluated_file_reference,
                      2) ^ <> user_id.user) AND (fsp$path_element (^evaluated_file_reference,
                      1) ^ <> fsc$local) THEN
                  osp$set_status_abnormal (amc$access_method_id, fse$attribute_not_available,
                        'ATTACHMENT_LOGGING_SELECTED', status);
                  osp$append_status_file (osc$status_parameter_delimiter,
                        object_information_p^.resolved_path^, status);
                ELSE
                  clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
                IFEND;
              ELSE
                clp$make_boolean_value ((object_information_p^.object^.file_information^.logging_selection^ =
                      pfc$log), boolean_kind, work_area, field_values^ [current_field_number].value);
              IFEND;
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = lifetime =
            add_lifetime;

          = object_type =
            IF (object_information_p <> NIL) AND (object_information_p^.object <> NIL) THEN
              clp$make_keyword_value ('FILE', work_area, field_values^ [current_field_number].value);
            ELSE { system_default_values requested or object not registered }
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = path =
            add_path;

          = permitted_access =
            IF (object_information_p <> NIL) AND (object_information_p^.object <> NIL) AND
                  (object_information_p^.object^.applicable_file_permit <> NIL) THEN
              permit_array [1] := object_information_p^.object^.applicable_file_permit^;
              get_permits (^permit_array, field_values^ [current_field_number].value);
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = registered =
            IF object_information_p <> NIL THEN
              clp$make_boolean_value ((object_information_p^.object <> NIL), boolean_kind, work_area,
                    field_values^ [current_field_number].value);
            ELSE
              clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);
            IFEND;

          = set_name =
            add_set_name;

          = unique_name =
            clp$make_unspecified_value (work_area, field_values^ [current_field_number].value);

          ELSE
          CASEND;
          current_field_number := current_field_number + 1;
        IFEND;
      FOREND;

    PROCEND build_file_attrib_record;

?? TITLE := 'convert_file_ref_to_string', EJECT ??

    PROCEDURE [INLINE] convert_file_ref_to_string
      (    evaluated_file_reference: fst$evaluated_file_reference;
       VAR str: fst$path;
       VAR size: fst$path_size);

      VAR
        i: fst$path_index;

      size := evaluated_file_reference.path_structure_size;
      str := evaluated_file_reference.path_structure (1, size);
      str (1) := ':';
      i := $INTEGER (evaluated_file_reference.path_structure (1)) + 2;
      WHILE i < size DO
        str (i) := '.';
        i := i + $INTEGER (evaluated_file_reference.path_structure (i)) + 1;
      WHILEND;

    PROCEND convert_file_ref_to_string;

?? TITLE := 'get_permits', EJECT ??

    PROCEDURE get_permits
      (    permits: ^pft$permit_array;
       VAR access_control_list_p: ^clt$data_value);

      VAR
        access_control_list_pp: ^^clt$data_value,
        i: ost$positive_integers,
        option_list_pp: ^^clt$data_value;

      access_control_list_pp := ^access_control_list_p;

      FOR i := 1 TO UPPERBOUND (permits^) DO
        clp$make_list_value (work_area, access_control_list_pp^);
        clp$make_record_value (4, work_area, access_control_list_pp^^.element_value);
        access_control_list_pp^^.element_value^.field_values^ [1].name := 'SUBJECT';
        clp$make_record_value (5, work_area, access_control_list_pp^^.element_value^.field_values^ [1].value);
        access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [1].name := 'GROUP';
        access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [2].name := 'FAMILY';
        clp$make_unspecified_value (work_area, access_control_list_pp^^.element_value^.field_values^ [1].
              value^.field_values^ [2].value);
        access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [3].name := 'ACCOUNT';
        clp$make_unspecified_value (work_area, access_control_list_pp^^.element_value^.field_values^ [1].
              value^.field_values^ [3].value);
        access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [4].name := 'PROJECT';
        clp$make_unspecified_value (work_area, access_control_list_pp^^.element_value^.field_values^ [1].
              value^.field_values^ [4].value);
        access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [5].name := 'USER';
        clp$make_unspecified_value (work_area, access_control_list_pp^^.element_value^.field_values^ [1].
              value^.field_values^ [5].value);

        CASE permits^ [i].group.group_type OF
        = pfc$public =
          clp$make_keyword_value ('PUBLIC', work_area, access_control_list_pp^^.element_value^.
                field_values^ [1].value^.field_values^ [1].value);
        = pfc$family =
          clp$make_keyword_value ('FAMILY', work_area, access_control_list_pp^^.element_value^.
                field_values^ [1].value^.field_values^ [1].value);
          clp$make_name_value (permits^ [i].group.family_description.family, work_area,
                access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [2].value);
        = pfc$account =
          clp$make_keyword_value ('ACCOUNT', work_area, access_control_list_pp^^.element_value^.
                field_values^ [1].value^.field_values^ [1].value);
          clp$make_name_value (permits^ [i].group.account_description.family, work_area,
                access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [2].value);
          clp$make_name_value (permits^ [i].group.account_description.account, work_area,
                access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [3].value);
        = pfc$project =
          clp$make_keyword_value ('PROJECT', work_area, access_control_list_pp^^.element_value^.
                field_values^ [1].value^.field_values^ [1].value);
          clp$make_name_value (permits^ [i].group.project_description.family, work_area,
                access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [2].value);
          clp$make_name_value (permits^ [i].group.project_description.account, work_area,
                access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [3].value);
          clp$make_name_value (permits^ [i].group.project_description.project, work_area,
                access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [4].value);
        = pfc$user =
          clp$make_keyword_value ('USER', work_area, access_control_list_pp^^.element_value^.
                field_values^ [1].value^.field_values^ [1].value);
          clp$make_name_value (permits^ [i].group.user_description.family, work_area,
                access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [2].value);
          clp$make_name_value (permits^ [i].group.user_description.user, work_area,
                access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [5].value);
        = pfc$user_account =
          clp$make_keyword_value ('USER_ACCOUNT', work_area,
                access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [1].value);
          clp$make_name_value (permits^ [i].group.user_account_description.family, work_area,
                access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [2].value);
          clp$make_name_value (permits^ [i].group.user_account_description.account, work_area,
                access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [3].value);
          clp$make_name_value (permits^ [i].group.user_account_description.user, work_area,
                access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [5].value);
        = pfc$member =
          clp$make_keyword_value ('MEMBER', work_area, access_control_list_pp^^.element_value^.
                field_values^ [1].value^.field_values^ [1].value);
          clp$make_name_value (permits^ [i].group.member_description.family, work_area,
                access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [2].value);
          clp$make_name_value (permits^ [i].group.member_description.account, work_area,
                access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [3].value);
          clp$make_name_value (permits^ [i].group.member_description.project, work_area,
                access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [4].value);
          clp$make_name_value (permits^ [i].group.member_description.user, work_area,
                access_control_list_pp^^.element_value^.field_values^ [1].value^.field_values^ [5].value);
        ELSE
        CASEND;

        access_control_list_pp^^.element_value^.field_values^ [2].name := 'ACCESS_MODES';
        IF permits^ [i].usage_permissions = $pft$permit_selections [] THEN
          clp$make_keyword_value ('NONE', work_area, access_control_list_pp^^.element_value^.
                field_values^ [2].value);
        ELSE
          option_list_pp := ^access_control_list_pp^^.element_value^.field_values^ [2].value;
          FOR option := LOWERVALUE (pft$permit_options) TO UPPERVALUE (pft$permit_options) DO
            IF option IN permits^ [i].usage_permissions THEN
              clp$make_list_value (work_area, option_list_pp^);
              clp$make_keyword_value (permit_share_options [option], work_area,
                    option_list_pp^^.element_value);
              option_list_pp := ^option_list_pp^^.link;
            IFEND;
          FOREND;
        IFEND;

        access_control_list_pp^^.element_value^.field_values^ [3].name := 'APPLICATION_INFORMATION';
        clp$make_string_value (permits^ [i].application_info
              (1, clp$trimmed_string_size (permits^ [i].application_info)), work_area,
              access_control_list_pp^^.element_value^.field_values^ [3].value);

        access_control_list_pp^^.element_value^.field_values^ [4].name := 'REQUIRED_SHARE_MODES';
        IF permits^ [i].share_requirements = $pft$share_requirements [] THEN
          clp$make_keyword_value ('NONE', work_area, access_control_list_pp^^.element_value^.
                field_values^ [4].value);
        ELSE
          option_list_pp := ^access_control_list_pp^^.element_value^.field_values^ [4].value;
          FOR option := LOWERVALUE (pft$share_options) TO UPPERVALUE (pft$share_options) DO
            IF option IN permits^ [i].share_requirements THEN
              clp$make_list_value (work_area, option_list_pp^);
              clp$make_keyword_value (permit_share_options [option], work_area,
                    option_list_pp^^.element_value);
              option_list_pp := ^option_list_pp^^.link;
            IFEND;
          FOREND;
        IFEND;
        access_control_list_pp := ^access_control_list_pp^^.link;
      FOREND;

    PROCEND get_permits;
?? OLDTITLE, EJECT ??

    CONST
      owner_only_catalog_attributes = 1,
      owner_only_file_attributes = 3;

    VAR
      file_only_attributes: [STATIC, READ, oss$job_paged_literal] file_attribute_keys :=
            [access_control_list, account_project, attachment_log, attachment_logging_selected,
            permitted_access],
      file_type_attributes: [STATIC, READ, oss$job_paged_literal] file_attribute_keys :=
            [access_control_list, account_project, attachment_log, attachment_logging_selected, lifetime,
            object_type, path, permitted_access, registered, set_name, unique_name],
      owner_only_attributes: [STATIC, READ, oss$job_paged_literal] file_attribute_keys :=
            [access_control_list, attachment_log, attachment_logging_selected];

    VAR
      attribute: file_attribute_key,
      character_string: string (1),
      current_field_number: file_attribute_key,
      cycle_element: ost$positive_integers,
      date_time: clt$date_time,
      field_values: ^array [1 .. * ] of clt$field_value,
      gfn: ost$name,
      local_attributes_requested: file_attribute_keys,
      node: ^^clt$data_value,
      number_of_requested_attributes: object_type_counts,
      object_information_p: ^fst$goi_object_information,
      object_registered_and_permitted: boolean,
      option: pft$permit_options,
      path_size: fst$path_size,
      result_pp: ^^clt$data_value,
      str: fst$path,
      user_id: ost$user_identification;

    object_registered_and_permitted := status.normal;
    status.normal := TRUE;

    IF object_info_sequence_p <> NIL THEN
      NEXT object_information_p IN object_info_sequence_p;
      IF object_information_p = NIL THEN
        osp$set_status_condition (fse$system_error, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, nil_object_info_text, status);
        RETURN;
      IFEND;
    ELSE
      object_information_p := NIL;
    IFEND;

    local_attributes_requested := attributes_requested;
    number_of_requested_attributes := requested_attribute_counts;
    IF all_requested THEN
      IF NOT avp$system_administrator () THEN
        pmp$get_user_identification (user_id, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF (fsp$path_element (^evaluated_file_reference, 1) ^ <> fsc$local) AND
              (fsp$path_element (^evaluated_file_reference, 2) ^ <> user_id.user) THEN
          local_attributes_requested := local_attributes_requested - owner_only_attributes;
          number_of_requested_attributes.file_type := number_of_requested_attributes.file_type -
                owner_only_file_attributes;
          number_of_requested_attributes.catalog_type := number_of_requested_attributes.catalog_type -
                owner_only_catalog_attributes;
        IFEND;
      IFEND;
    IFEND;

    IF (object_info_sequence_p = NIL) {system_default_values specified} OR
          NOT object_registered_and_permitted THEN
      result_pp := ^result;
      IF (local_attributes_requested * file_only_attributes) <> $file_attribute_keys [] THEN
        build_file_attrib_record (result_pp^);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF (local_attributes_requested - file_type_attributes) = $file_attribute_keys [] THEN
          RETURN;
        ELSE
          result_pp := ^result_pp^^.link;
        IFEND;
      IFEND;
      IF number_of_requested_attributes.cycle_type > 0 THEN
        build_cycle_attrib_record ({cycle_object} NIL, result_pp^);
      IFEND;
    ELSEIF object_information_p^.object = NIL THEN
      osp$set_status_condition (fse$attributes_not_defined, status);
      RETURN;
    ELSEIF object_information_p^.object^.object_type = fsc$goi_catalog_object THEN
      IF number_of_requested_attributes.catalog_type > 0 THEN
        build_catalog_attrib_record (result);
      ELSE
        osp$set_status_condition (fse$attributes_not_defined, status);
        RETURN;
      IFEND;
    ELSEIF object_information_p^.object^.object_type = fsc$goi_file_object THEN
      IF (local_attributes_requested * file_only_attributes) <> $file_attribute_keys [] THEN
        build_file_attrib_record (result);
        IF (NOT status.normal) OR ((local_attributes_requested - file_type_attributes) =
              $file_attribute_keys []) THEN

{ Attributes that are common to both file and cycle objects, such as lifetime, object_type, path,
{ registered, set_name and unique_name, would cause cycle object information to be requested.  But if no other
{ cycle attributes were requested, it would not be necessary to return a record of type cycle attributes in
{ addition to one of type file attributes.

          RETURN;
        IFEND;
      IFEND;

      IF object_information_p^.object^.cycle_object_list <> NIL THEN
        result_pp := ^result;
        IF (local_attributes_requested * file_only_attributes) <> $file_attribute_keys [] THEN

{ A file type record was built.  It is possible for get_object_information to return a file object even if
{ no file type attributes were requested, in which case it would not be necessary to return a record of
{ file attributes type.  This would occur if potential_job_access was requested, because it requires file
{ object information such as applicable_permits to determine its value.

          IF NOT (cycle_number IN local_attributes_requested) THEN

{ Cycle_number must be added to the display to differentiate the file's cycles.

            local_attributes_requested := local_attributes_requested + $file_attribute_keys [cycle_number];
            number_of_requested_attributes.cycle_type := number_of_requested_attributes.cycle_type + 1;
          IFEND;
          result_pp := ^result_pp^^.link;
        IFEND;

        FOR cycle_element := 1 TO UPPERBOUND (object_information_p^.object^.cycle_object_list^) DO
          build_cycle_attrib_record (^object_information_p^.object^.cycle_object_list^ [cycle_element],
                result_pp^);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          result_pp := ^result_pp^^.link;
        FOREND;
      IFEND;
    ELSE { cycle object }
      build_cycle_attrib_record (object_information_p^.object, result);
    IFEND;

  PROCEND process_object_information;

?? TITLE := 'status_condition_ignorable', EJECT ??

  FUNCTION [INLINE] status_condition_ignorable
    (    condition: ost$status_condition_code;
         attributes_requested: file_attribute_keys;
         evaluated_file_reference: fst$evaluated_file_reference): boolean;

    status_condition_ignorable := (condition IN unknown_object_pf_conditions) OR
          (condition = ame$file_not_known) OR ((condition = pfe$unknown_permanent_file) AND
          (((-$file_attribute_keys [lifetime, path, set_name]) * attributes_requested =
          $file_attribute_keys []) OR (((-$file_attribute_keys [cycle_number, lifetime, path,
          set_name]) * attributes_requested = $file_attribute_keys []) AND
          (evaluated_file_reference.cycle_reference.specification = fsc$cycle_number)) OR
          (((-$file_attribute_keys [cycle_number, open_position, lifetime, path,
          set_name]) * attributes_requested = $file_attribute_keys []) AND
          evaluated_file_reference.path_handle_info.path_handle.open_position.specified)));

  FUNCEND status_condition_ignorable;

?? TITLE := 'clp$_display_file_attributes', EJECT ??

  PROCEDURE [XDCL] clp$_display_file_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_file_attributes, display_file_attribute, disfa (
{   file, f: any of
{       key
{         (system_default_values, system_default_value, sdv)
{       keyend
{       list of file
{     anyend = $required
{   display_options, display_option, do: list of key
{       all
{       (access_control_list, acl)
{       (account_project, ap)
{       (actual_job_access, am, access_mode, access_modes, aja)
{       (attached, a)
{       (catalog_registration_attributes, cra)
{       (common_file_attributes, cfa)
{       (creation_date_time, cdt)
{       (cycle_number, cn)
{       (device_class_attributes, dca)
{       (exception_conditions, exception_condition, ec)
{       (expiration_date, ed)
{       (file_contents, file_structure, file_content, fs, fc)
{       (file_processor, fp)
{       (job_environment_attributes, jea)
{       (keyed_file_attributes, kfa)
{       (last_access_date_time, ladt)
{       (last_modification_date_time, lmdt)
{       (object_type, ot)
{       (path, p)
{       (permitted_access, application_info, application_information, ai, pa)
{       (potential_job_access, global_access_mode, global_share_modes, gsm, global_share_mode, gam, ..
{       global_access_modes, pja)
{       (presentation_file_attributes, pfa)
{       (registered, r)
{       (size, s)
{     advanced_key
{       (attached_external_vsn_list, aevl)
{       (attached_recorded_vsn_list, arvl)
{       (attached_transfer_size, ats)
{       (attached_vol_overflow_allowed, avoa)
{       (attached_volume_number, avn)
{       (attachment_log, al)
{       (attachment_logging_selected, als)
{       (average_record_length, arl)
{       (block_type, bt)
{       (character_conversion, cc)
{       (collate_table_name, ctn)
{       (compression_procedure_name, cpn)
{       (connected_files, cf)
{       (data_padding, dp)
{       (device_class, dc)
{       (dynamic_home_block_space, dhbs)
{       (embedded_key, ek)
{       (error_exit_procedure_name, error_exit_name, een, eepn)
{       (error_limit, el)
{       (estimated_record_count, erc)
{       (external_vsn_list, evsnl, evl)
{       (file_access_procedure_name, fap, file_access_procedure, fapn)
{       (file_label_type, flt)
{       (file_limit, fl)
{       (file_organization, fo)
{       (file_previously_opened, fpo)
{       (forced_write, fw)
{       (hashing_procedure_name, hpn)
{       (index_levels, index_level, il)
{       (index_padding, ip)
{       (initial_home_block_count, ihbc)
{       (internal_code, ic)
{       (job_file_address, gfa, global_file_address, jfa)
{       (job_file_position, global_file_position, gfp, jfp)
{       (job_instances_of_open, jioo)
{       (job_write_concurrency, jwc)
{       (key_length, kl)
{       (key_position, kp)
{       (key_type, kt)
{       (last_data_modification_time, ldmd, ldmdt, last_data_modification_date, ldmt)
{       (lifetime, permanent, l)
{       (lifetime_attachment_count, lac)
{       (line_number, ln)
{       (loading_factor, lf)
{       (lock_expiration_time, let)
{       (log_residence, lr)
{       (logging_options, lo)
{       (mainframe_attachment, ma)
{       (mainframe_write_concurrency, mwc)
{       (mass_storage_allocation_size, msas)
{       (mass_storage_bytes_allocated, msba)
{       (mass_storage_class, msc)
{       (mass_storage_free_behind, msfb)
{       (mass_storage_initial_volume, msiv)
{       (mass_storage_sequential_access, mssa)
{       (mass_storage_transfer_size, msts)
{       (maximum_block_length, maxbl)
{       (maximum_record_length, maxrl)
{       (message_control, mc)
{       (minimum_block_length, minbl)
{       (minimum_record_length, minrl)
{       (open_position, op)
{       (padding_character, pc)
{       (page_format, pf)
{       (page_length, pl)
{       (page_width, pw)
{       (preset_value, pv)
{       (private_read, pr)
{       (record_delimiting_character, rdc)
{       (record_limit, rl)
{       (record_type, rt)
{       (recorded_vsn_list, rvsnl, rvl)
{       (records_per_block, rpb)
{       (retrieve_option, ro)
{       (ring_attributes, ring_attribute, ra)
{       (secondary_residence, sr)
{       (set_name, sn)
{       (shared_queue, sq)
{       (site_archive_option, sao)
{       (site_backup_option, sbo)
{       (site_release_option, sro)
{       (statement_identifier, si)
{       (tape_density, td)
{       (unique_data_name, gfn, global_file_name, udn)
{       (unique_name, un)
{       (user_information, ui)
{       (vertical_print_density, vpd)
{       (volume_overflow_allowed, voa)
{     hidden_key
{       source
{     keyend = osd$disfa_display_options,
{     (attached, file_contents, file_processor, potential_job_access, size)
{   output, o: file = $output
{   password, pw: (BY_NAME, SECURE) any of
{       key
{         none
{       keyend
{       name
{     anyend = none
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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 .. 3] 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,
          recend,
        recend,
      recend,
      type2: 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 .. 260] of clt$keyword_specification,
        recend,
        default_name: string (25),
        default_value: string (69),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: 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$name_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [97, 1, 7, 13, 47, 36, 849],
    clc$command, 10, 5, 1, 0, 0, 0, 5, ''], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['PASSWORD                       ',clc$nominal_entry, 4],
    ['PW                             ',clc$abbreviation_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 157,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 9643,
  clc$optional_default_parameter, 25, 69],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SDV                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['SYSTEM_DEFAULT_VALUE           ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['SYSTEM_DEFAULT_VALUES          ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$file_type]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [9627, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [260], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['ACCESS_CONTROL_LIST            ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['ACCESS_MODE                    ', clc$alias_entry, clc$normal_usage_entry, 4],
      ['ACCESS_MODES                   ', clc$alias_entry, clc$normal_usage_entry, 4],
      ['ACCOUNT_PROJECT                ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['ACL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['ACTUAL_JOB_ACCESS              ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['AEVL                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 26],
      ['AI                             ', clc$alias_entry, clc$normal_usage_entry, 21],
      ['AJA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['AL                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 31],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['ALS                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 32],
      ['AM                             ', clc$alias_entry, clc$normal_usage_entry, 4],
      ['AP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['APPLICATION_INFO               ', clc$alias_entry, clc$normal_usage_entry, 21],
      ['APPLICATION_INFORMATION        ', clc$alias_entry, clc$normal_usage_entry, 21],
      ['ARL                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 33],
      ['ARVL                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 27],
      ['ATS                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 28],
      ['ATTACHED                       ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['ATTACHED_EXTERNAL_VSN_LIST     ', clc$nominal_entry, clc$advanced_usage_entry, 26],
      ['ATTACHED_RECORDED_VSN_LIST     ', clc$nominal_entry, clc$advanced_usage_entry, 27],
      ['ATTACHED_TRANSFER_SIZE         ', clc$nominal_entry, clc$advanced_usage_entry, 28],
      ['ATTACHED_VOLUME_NUMBER         ', clc$nominal_entry, clc$advanced_usage_entry, 30],
      ['ATTACHED_VOL_OVERFLOW_ALLOWED  ', clc$nominal_entry, clc$advanced_usage_entry, 29],
      ['ATTACHMENT_LOG                 ', clc$nominal_entry, clc$advanced_usage_entry, 31],
      ['ATTACHMENT_LOGGING_SELECTED    ', clc$nominal_entry, clc$advanced_usage_entry, 32],
      ['AVERAGE_RECORD_LENGTH          ', clc$nominal_entry, clc$advanced_usage_entry, 33],
      ['AVN                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 30],
      ['AVOA                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 29],
      ['BLOCK_TYPE                     ', clc$nominal_entry, clc$advanced_usage_entry, 34],
      ['BT                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 34],
      ['CATALOG_REGISTRATION_ATTRIBUTES', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['CC                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 35],
      ['CDT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
      ['CF                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 38],
      ['CFA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['CHARACTER_CONVERSION           ', clc$nominal_entry, clc$advanced_usage_entry, 35],
      ['CN                             ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
      ['COLLATE_TABLE_NAME             ', clc$nominal_entry, clc$advanced_usage_entry, 36],
      ['COMMON_FILE_ATTRIBUTES         ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['COMPRESSION_PROCEDURE_NAME     ', clc$nominal_entry, clc$advanced_usage_entry, 37],
      ['CONNECTED_FILES                ', clc$nominal_entry, clc$advanced_usage_entry, 38],
      ['CPN                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 37],
      ['CRA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['CREATION_DATE_TIME             ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['CTN                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 36],
      ['CYCLE_NUMBER                   ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['DATA_PADDING                   ', clc$nominal_entry, clc$advanced_usage_entry, 39],
      ['DC                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 40],
      ['DCA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
      ['DEVICE_CLASS                   ', clc$nominal_entry, clc$advanced_usage_entry, 40],
      ['DEVICE_CLASS_ATTRIBUTES        ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['DHBS                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 41],
      ['DP                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 39],
      ['DYNAMIC_HOME_BLOCK_SPACE       ', clc$nominal_entry, clc$advanced_usage_entry, 41],
      ['EC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
      ['ED                             ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
      ['EEN                            ', clc$alias_entry, clc$advanced_usage_entry, 43],
      ['EEPN                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 43],
      ['EK                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 42],
      ['EL                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 44],
      ['EMBEDDED_KEY                   ', clc$nominal_entry, clc$advanced_usage_entry, 42],
      ['ERC                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 45],
      ['ERROR_EXIT_NAME                ', clc$alias_entry, clc$advanced_usage_entry, 43],
      ['ERROR_EXIT_PROCEDURE_NAME      ', clc$nominal_entry, clc$advanced_usage_entry, 43],
      ['ERROR_LIMIT                    ', clc$nominal_entry, clc$advanced_usage_entry, 44],
      ['ESTIMATED_RECORD_COUNT         ', clc$nominal_entry, clc$advanced_usage_entry, 45],
      ['EVL                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 46],
      ['EVSNL                          ', clc$alias_entry, clc$advanced_usage_entry, 46],
      ['EXCEPTION_CONDITION            ', clc$alias_entry, clc$normal_usage_entry, 11],
      ['EXCEPTION_CONDITIONS           ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['EXPIRATION_DATE                ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['EXTERNAL_VSN_LIST              ', clc$nominal_entry, clc$advanced_usage_entry, 46],
      ['FAP                            ', clc$alias_entry, clc$advanced_usage_entry, 47],
      ['FAPN                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 47],
      ['FC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
      ['FILE_ACCESS_PROCEDURE          ', clc$alias_entry, clc$advanced_usage_entry, 47],
      ['FILE_ACCESS_PROCEDURE_NAME     ', clc$nominal_entry, clc$advanced_usage_entry, 47],
      ['FILE_CONTENT                   ', clc$alias_entry, clc$normal_usage_entry, 13],
      ['FILE_CONTENTS                  ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['FILE_LABEL_TYPE                ', clc$nominal_entry, clc$advanced_usage_entry, 48],
      ['FILE_LIMIT                     ', clc$nominal_entry, clc$advanced_usage_entry, 49],
      ['FILE_ORGANIZATION              ', clc$nominal_entry, clc$advanced_usage_entry, 50],
      ['FILE_PREVIOUSLY_OPENED         ', clc$nominal_entry, clc$advanced_usage_entry, 51],
      ['FILE_PROCESSOR                 ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['FILE_STRUCTURE                 ', clc$alias_entry, clc$normal_usage_entry, 13],
      ['FL                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 49],
      ['FLT                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 48],
      ['FO                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 50],
      ['FORCED_WRITE                   ', clc$nominal_entry, clc$advanced_usage_entry, 52],
      ['FP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
      ['FPO                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 51],
      ['FS                             ', clc$alias_entry, clc$normal_usage_entry, 13],
      ['FW                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 52],
      ['GAM                            ', clc$alias_entry, clc$normal_usage_entry, 22],
      ['GFA                            ', clc$alias_entry, clc$advanced_usage_entry, 58],
      ['GFN                            ', clc$alias_entry, clc$advanced_usage_entry, 109],
      ['GFP                            ', clc$alias_entry, clc$advanced_usage_entry, 59],
      ['GLOBAL_ACCESS_MODE             ', clc$alias_entry, clc$normal_usage_entry, 22],
      ['GLOBAL_ACCESS_MODES            ', clc$alias_entry, clc$normal_usage_entry, 22],
      ['GLOBAL_FILE_ADDRESS            ', clc$alias_entry, clc$advanced_usage_entry, 58],
      ['GLOBAL_FILE_NAME               ', clc$alias_entry, clc$advanced_usage_entry, 109],
      ['GLOBAL_FILE_POSITION           ', clc$alias_entry, clc$advanced_usage_entry, 59],
      ['GLOBAL_SHARE_MODE              ', clc$alias_entry, clc$normal_usage_entry, 22],
      ['GLOBAL_SHARE_MODES             ', clc$alias_entry, clc$normal_usage_entry, 22],
      ['GSM                            ', clc$alias_entry, clc$normal_usage_entry, 22],
      ['HASHING_PROCEDURE_NAME         ', clc$nominal_entry, clc$advanced_usage_entry, 53],
      ['HPN                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 53],
      ['IC                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 57],
      ['IHBC                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 56],
      ['IL                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 54],
      ['INDEX_LEVEL                    ', clc$alias_entry, clc$advanced_usage_entry, 54],
      ['INDEX_LEVELS                   ', clc$nominal_entry, clc$advanced_usage_entry, 54],
      ['INDEX_PADDING                  ', clc$nominal_entry, clc$advanced_usage_entry, 55],
      ['INITIAL_HOME_BLOCK_COUNT       ', clc$nominal_entry, clc$advanced_usage_entry, 56],
      ['INTERNAL_CODE                  ', clc$nominal_entry, clc$advanced_usage_entry, 57],
      ['IP                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 55],
      ['JEA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
      ['JFA                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 58],
      ['JFP                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 59],
      ['JIOO                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 60],
      ['JOB_ENVIRONMENT_ATTRIBUTES     ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['JOB_FILE_ADDRESS               ', clc$nominal_entry, clc$advanced_usage_entry, 58],
      ['JOB_FILE_POSITION              ', clc$nominal_entry, clc$advanced_usage_entry, 59],
      ['JOB_INSTANCES_OF_OPEN          ', clc$nominal_entry, clc$advanced_usage_entry, 60],
      ['JOB_WRITE_CONCURRENCY          ', clc$nominal_entry, clc$advanced_usage_entry, 61],
      ['JWC                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 61],
      ['KEYED_FILE_ATTRIBUTES          ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['KEY_LENGTH                     ', clc$nominal_entry, clc$advanced_usage_entry, 62],
      ['KEY_POSITION                   ', clc$nominal_entry, clc$advanced_usage_entry, 63],
      ['KEY_TYPE                       ', clc$nominal_entry, clc$advanced_usage_entry, 64],
      ['KFA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
      ['KL                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 62],
      ['KP                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 63],
      ['KT                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 64],
      ['L                              ', clc$abbreviation_entry, clc$advanced_usage_entry, 66],
      ['LAC                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 67],
      ['LADT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
      ['LAST_ACCESS_DATE_TIME          ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['LAST_DATA_MODIFICATION_DATE    ', clc$alias_entry, clc$advanced_usage_entry, 65],
      ['LAST_DATA_MODIFICATION_TIME    ', clc$nominal_entry, clc$advanced_usage_entry, 65],
      ['LAST_MODIFICATION_DATE_TIME    ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['LDMD                           ', clc$alias_entry, clc$advanced_usage_entry, 65],
      ['LDMDT                          ', clc$alias_entry, clc$advanced_usage_entry, 65],
      ['LDMT                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 65],
      ['LET                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 70],
      ['LF                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 69],
      ['LIFETIME                       ', clc$nominal_entry, clc$advanced_usage_entry, 66],
      ['LIFETIME_ATTACHMENT_COUNT      ', clc$nominal_entry, clc$advanced_usage_entry, 67],
      ['LINE_NUMBER                    ', clc$nominal_entry, clc$advanced_usage_entry, 68],
      ['LMDT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
      ['LN                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 68],
      ['LO                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 72],
      ['LOADING_FACTOR                 ', clc$nominal_entry, clc$advanced_usage_entry, 69],
      ['LOCK_EXPIRATION_TIME           ', clc$nominal_entry, clc$advanced_usage_entry, 70],
      ['LOGGING_OPTIONS                ', clc$nominal_entry, clc$advanced_usage_entry, 72],
      ['LOG_RESIDENCE                  ', clc$nominal_entry, clc$advanced_usage_entry, 71],
      ['LR                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 71],
      ['MA                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 73],
      ['MAINFRAME_ATTACHMENT           ', clc$nominal_entry, clc$advanced_usage_entry, 73],
      ['MAINFRAME_WRITE_CONCURRENCY    ', clc$nominal_entry, clc$advanced_usage_entry, 74],
      ['MASS_STORAGE_ALLOCATION_SIZE   ', clc$nominal_entry, clc$advanced_usage_entry, 75],
      ['MASS_STORAGE_BYTES_ALLOCATED   ', clc$nominal_entry, clc$advanced_usage_entry, 76],
      ['MASS_STORAGE_CLASS             ', clc$nominal_entry, clc$advanced_usage_entry, 77],
      ['MASS_STORAGE_FREE_BEHIND       ', clc$nominal_entry, clc$advanced_usage_entry, 78],
      ['MASS_STORAGE_INITIAL_VOLUME    ', clc$nominal_entry, clc$advanced_usage_entry, 79],
      ['MASS_STORAGE_SEQUENTIAL_ACCESS ', clc$nominal_entry, clc$advanced_usage_entry, 80],
      ['MASS_STORAGE_TRANSFER_SIZE     ', clc$nominal_entry, clc$advanced_usage_entry, 81],
      ['MAXBL                          ', clc$abbreviation_entry, clc$advanced_usage_entry, 82],
      ['MAXIMUM_BLOCK_LENGTH           ', clc$nominal_entry, clc$advanced_usage_entry, 82],
      ['MAXIMUM_RECORD_LENGTH          ', clc$nominal_entry, clc$advanced_usage_entry, 83],
      ['MAXRL                          ', clc$abbreviation_entry, clc$advanced_usage_entry, 83],
      ['MC                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 84],
      ['MESSAGE_CONTROL                ', clc$nominal_entry, clc$advanced_usage_entry, 84],
      ['MINBL                          ', clc$abbreviation_entry, clc$advanced_usage_entry, 85],
      ['MINIMUM_BLOCK_LENGTH           ', clc$nominal_entry, clc$advanced_usage_entry, 85],
      ['MINIMUM_RECORD_LENGTH          ', clc$nominal_entry, clc$advanced_usage_entry, 86],
      ['MINRL                          ', clc$abbreviation_entry, clc$advanced_usage_entry, 86],
      ['MSAS                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 75],
      ['MSBA                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 76],
      ['MSC                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 77],
      ['MSFB                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 78],
      ['MSIV                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 79],
      ['MSSA                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 80],
      ['MSTS                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 81],
      ['MWC                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 74],
      ['OBJECT_TYPE                    ', clc$nominal_entry, clc$normal_usage_entry, 19],
      ['OP                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 87],
      ['OPEN_POSITION                  ', clc$nominal_entry, clc$advanced_usage_entry, 87],
      ['OT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
      ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 20],
      ['PA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 21],
      ['PADDING_CHARACTER              ', clc$nominal_entry, clc$advanced_usage_entry, 88],
      ['PAGE_FORMAT                    ', clc$nominal_entry, clc$advanced_usage_entry, 89],
      ['PAGE_LENGTH                    ', clc$nominal_entry, clc$advanced_usage_entry, 90],
      ['PAGE_WIDTH                     ', clc$nominal_entry, clc$advanced_usage_entry, 91],
      ['PATH                           ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['PC                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 88],
      ['PERMANENT                      ', clc$alias_entry, clc$advanced_usage_entry, 66],
      ['PERMITTED_ACCESS               ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['PF                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 89],
      ['PFA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 23],
      ['PJA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 22],
      ['PL                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 90],
      ['POTENTIAL_JOB_ACCESS           ', clc$nominal_entry, clc$normal_usage_entry, 22],
      ['PR                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 93],
      ['PRESENTATION_FILE_ATTRIBUTES   ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['PRESET_VALUE                   ', clc$nominal_entry, clc$advanced_usage_entry, 92],
      ['PRIVATE_READ                   ', clc$nominal_entry, clc$advanced_usage_entry, 93],
      ['PV                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 92],
      ['PW                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 91],
      ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 24],
      ['RA                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 100],
      ['RDC                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 94],
      ['RECORDED_VSN_LIST              ', clc$nominal_entry, clc$advanced_usage_entry, 97],
      ['RECORDS_PER_BLOCK              ', clc$nominal_entry, clc$advanced_usage_entry, 98],
      ['RECORD_DELIMITING_CHARACTER    ', clc$nominal_entry, clc$advanced_usage_entry, 94],
      ['RECORD_LIMIT                   ', clc$nominal_entry, clc$advanced_usage_entry, 95],
      ['RECORD_TYPE                    ', clc$nominal_entry, clc$advanced_usage_entry, 96],
      ['REGISTERED                     ', clc$nominal_entry, clc$normal_usage_entry, 24],
      ['RETRIEVE_OPTION                ', clc$nominal_entry, clc$advanced_usage_entry, 99],
      ['RING_ATTRIBUTE                 ', clc$alias_entry, clc$advanced_usage_entry, 100],
      ['RING_ATTRIBUTES                ', clc$nominal_entry, clc$advanced_usage_entry, 100],
      ['RL                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 95],
      ['RO                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 99],
      ['RPB                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 98],
      ['RT                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 96],
      ['RVL                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 97],
      ['RVSNL                          ', clc$alias_entry, clc$advanced_usage_entry, 97],
      ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 25],
      ['SAO                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 104],
      ['SBO                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 105],
      ['SECONDARY_RESIDENCE            ', clc$nominal_entry, clc$advanced_usage_entry, 101],
      ['SET_NAME                       ', clc$nominal_entry, clc$advanced_usage_entry, 102],
      ['SHARED_QUEUE                   ', clc$nominal_entry, clc$advanced_usage_entry, 103],
      ['SI                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 107],
      ['SITE_ARCHIVE_OPTION            ', clc$nominal_entry, clc$advanced_usage_entry, 104],
      ['SITE_BACKUP_OPTION             ', clc$nominal_entry, clc$advanced_usage_entry, 105],
      ['SITE_RELEASE_OPTION            ', clc$nominal_entry, clc$advanced_usage_entry, 106],
      ['SIZE                           ', clc$nominal_entry, clc$normal_usage_entry, 25],
      ['SN                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 102],
      ['SOURCE                         ', clc$nominal_entry, clc$hidden_entry, 114],
      ['SQ                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 103],
      ['SR                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 101],
      ['SRO                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 106],
      ['STATEMENT_IDENTIFIER           ', clc$nominal_entry, clc$advanced_usage_entry, 107],
      ['TAPE_DENSITY                   ', clc$nominal_entry, clc$advanced_usage_entry, 108],
      ['TD                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 108],
      ['UDN                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 109],
      ['UI                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 111],
      ['UN                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 110],
      ['UNIQUE_DATA_NAME               ', clc$nominal_entry, clc$advanced_usage_entry, 109],
      ['UNIQUE_NAME                    ', clc$nominal_entry, clc$advanced_usage_entry, 110],
      ['USER_INFORMATION               ', clc$nominal_entry, clc$advanced_usage_entry, 111],
      ['VERTICAL_PRINT_DENSITY         ', clc$nominal_entry, clc$advanced_usage_entry, 112],
      ['VOA                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 113],
      ['VOLUME_OVERFLOW_ALLOWED        ', clc$nominal_entry, clc$advanced_usage_entry, 113],
      ['VPD                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 112]]
      ]
    ,
    'OSD$DISFA_DISPLAY_OPTIONS',
    '(attached, file_contents, file_processor, potential_job_access, size)'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'none'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

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

    CONST
      p$file = 1,
      p$display_options = 2,
      p$output = 3,
      p$password = 4,
      p$status = 5;

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

*copy clv$display_variables
?? NEWTITLE := 'abort_handler', EJECT ??

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

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;

*copy clp$new_page_procedure
*copy clp$put_path_reference_subtitle
?? TITLE := 'put_subtitle ', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);


      IF pvt [p$file].value^.kind = clc$keyword THEN
        clp$put_partial_display (display_control, 'System Default Values:', clc$trim, amc$terminate, status);
      ELSE
        clv$subtitles_built := FALSE;
        clp$put_path_reference_subtitle (current_file^.element_value^.file_value^, 'FILE ', status);
      IFEND;

    PROCEND put_subtitle;
?? OLDTITLE, EJECT ??

    CONST
      remote_path_prefix = ':$LOCAL.',
      remote_path_prefix_size = 8,
      remote_path_size = remote_path_prefix_size + osc$max_name_size;

    VAR
      all_requested: boolean,
      attrib_work_area_p: ^SEQ ( * ),
      attributes_requested: file_attribute_keys,
      block: ^clt$block,
      caller_id: ost$caller_identifier,
      current_file: ^clt$data_value,
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      evaluated_file_reference: fst$evaluated_file_reference,
      family_name: ost$family_name,
      information_request: fst$goi_information_request,
      local_status: ost$status,
      number_of_requested_attributes: object_type_counts,
      object_info_work_area: ^SEQ ( * ),
      remote: boolean,
      remote_parameters: array [1 .. 2] of clt$parameter_substitution,
      remote_path: string (remote_path_size),
      representation: ^clt$data_representation,
      result: ^clt$data_value,
      scratch_segment: amt$segment_pointer,
      unique_name: ost$name,
      validation_criteria: ^fst$goi_validation_criteria,
      work_area: ^^clt$work_area;

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

    clp$evaluate_file_reference (pvt [p$output].value^.file_value^, $clt$file_ref_parsing_options [], FALSE,
          evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    family_name := fsp$path_element (^evaluated_file_reference, 1) ^;

    nfp$check_implicit_access (family_name, remote, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF remote THEN
      osp$set_status_abnormal (nfc$status_id, nfe$display_output_remote, 'DISPLAY_FILE_ATTRIBUTES', status);
      RETURN;
    IFEND;

    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    osp$establish_block_exit_hndlr (^abort_handler);

    #CALLER_ID (caller_id);

    determine_attributes_requested (pvt [p$display_options].value, attributes_requested,
          number_of_requested_attributes, all_requested);

    information_request := initial_information_request;
    determine_object_info_requests (attributes_requested, information_request.object_information_requests);

  /form_file_attribute_display/
    BEGIN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, scratch_segment, status);
      IF NOT status.normal THEN
        EXIT /form_file_attribute_display/;
      IFEND;

      attrib_work_area_p := scratch_segment.sequence_pointer;
      default_ring_attributes.r1 := #RING (^default_ring_attributes);
      default_ring_attributes.r2 := #RING (^default_ring_attributes);
      default_ring_attributes.r3 := #RING (^default_ring_attributes);
      clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
            default_ring_attributes, display_control, status);
      IF NOT status.normal THEN
        EXIT /form_file_attribute_display/;
      IFEND;
      clv$titles_built := FALSE;
      clv$command_name := 'DISPLAY_FILE_ATTRIBUTES';

      IF display_control.page_width < clc$narrow_page_width THEN
        clv$page_width := clc$narrow_page_width;
      ELSEIF display_control.page_width > clc$wide_page_width THEN
        clv$page_width := clc$wide_page_width;
      ELSE
        clv$page_width := display_control.page_width;
      IFEND;

      IF pvt [p$file].value^.kind = clc$keyword THEN { system_default_values }
        object_info_work_area := NIL;
        process_object_information (fsv$evaluated_file_reference, caller_id.ring, {validation_criteria} NIL,
              all_requested, number_of_requested_attributes, attributes_requested, object_info_work_area,
              attrib_work_area_p, result, status);
        IF NOT status.normal THEN
          EXIT /form_file_attribute_display/;
        IFEND;

        IF (display_control.page_format = amc$burstable_form) OR
              (display_control.page_format = amc$non_burstable_form) THEN
          clp$new_display_page (display_control, status);
          IF NOT status.normal THEN
            EXIT /form_file_attribute_display/;
          IFEND;
        IFEND;

        WHILE result <> NIL DO
          clp$convert_data_to_string (result^.element_value, clc$labeled_elem_representation,
                display_control.page_width, attrib_work_area_p, representation, status);
          IF NOT status.normal THEN
            EXIT /form_file_attribute_display/;
          IFEND;
          clp$put_data_representation (display_control, representation, status);
          IF NOT status.normal THEN
            EXIT /form_file_attribute_display/;
          IFEND;
          result := result^.link;
          IF result <> NIL THEN
            clp$new_display_line (display_control, 1, status);
            IF NOT status.normal THEN
              EXIT /form_file_attribute_display/;
            IFEND;
          IFEND;
        WHILEND;

      ELSE
        IF (pvt [p$password].specified) AND (pvt [p$password].value^.kind = clc$name) THEN
          PUSH validation_criteria: [1 .. 1];
          validation_criteria^ [1].validation_selection := fsc$goi_password;
          validation_criteria^ [1].password := pvt [p$password].value^.name_value;
        ELSE
          validation_criteria := NIL;
        IFEND;

        block := NIL;
        current_file := pvt [p$file].value;

      /process_file_list/
        WHILE current_file <> NIL DO
          clp$evaluate_file_reference (current_file^.element_value^.file_value^,
                $clt$file_ref_parsing_options [], FALSE, evaluated_file_reference, status);
          IF NOT status.normal THEN
            EXIT /form_file_attribute_display/;
          IFEND;

          family_name := fsp$path_element (^evaluated_file_reference, 1) ^;

          nfp$check_implicit_access (family_name, remote, status);
          IF NOT status.normal THEN
            EXIT /form_file_attribute_display/;
          IFEND;

          IF remote THEN
            IF block = NIL THEN
              clp$find_current_block (block);

              clp$get_work_area (#RING (^work_area), work_area, status);
              IF NOT status.normal THEN
                EXIT /form_file_attribute_display/;
              IFEND;

              pmp$get_unique_name (unique_name, status);
              IF NOT status.normal THEN
                EXIT /form_file_attribute_display/;
              IFEND;

              remote_path (1, remote_path_prefix_size) := remote_path_prefix;
              remote_path (remote_path_prefix_size + 1, osc$max_name_size) := unique_name;
              remote_parameters [1].text := ^remote_path;
              remote_parameters [1].name := 'OUTPUT';
              remote_parameters [2].name := 'STATUS';
              remote_parameters [2].text := NIL;
            IFEND;

            nfp$perform_implicit_access (family_name, pvt [p$output].value^.file_value^, remote_path,
                  nfc$give, 'DISPLAY_FILE_ATTRIBUTES', block^.parameters.unbundled_pdt, ^pvt,
                  ^remote_parameters, work_area^, status);
            IF NOT status.normal THEN
              EXIT /form_file_attribute_display/;
            IFEND;
            current_file := current_file^.link;
            CYCLE /process_file_list/;
          IFEND;

          object_info_work_area := attrib_work_area_p;

          get_object_information (evaluated_file_reference, information_request, validation_criteria,
                object_info_work_area, status);
          IF NOT status.normal AND NOT status_condition_ignorable
                (status.condition, attributes_requested, evaluated_file_reference) THEN
            EXIT /form_file_attribute_display/;
          ELSE
            process_object_information (evaluated_file_reference, caller_id.ring, validation_criteria,
                  all_requested, number_of_requested_attributes, attributes_requested, attrib_work_area_p,
                  object_info_work_area, result, status);
            IF NOT status.normal THEN
              IF status.condition = fse$attributes_not_defined THEN
                osp$append_status_file (osc$status_parameter_delimiter,
                      current_file^.element_value^.file_value^, status);
              IFEND;
              EXIT /form_file_attribute_display/;
            IFEND;
          IFEND;

          IF (display_control.page_format = amc$burstable_form) OR
                (display_control.page_format = amc$non_burstable_form) THEN
            clp$new_display_page (display_control, status);
            IF NOT status.normal THEN
              EXIT /form_file_attribute_display/;
            IFEND;
          ELSEIF current_file <> pvt [p$file].value THEN
            clp$new_display_line (display_control, 2, status);
            IF NOT status.normal THEN
              EXIT /form_file_attribute_display/;
            IFEND;
          IFEND;
          IF pvt [p$file].value^.link <> NIL THEN
            put_subtitle (display_control, status);
            IF NOT status.normal THEN
              EXIT /form_file_attribute_display/;
            IFEND;
            clp$new_display_line (display_control, 1, status);
            IF NOT status.normal THEN
              EXIT /form_file_attribute_display/;
            IFEND;
          IFEND;

          WHILE result <> NIL DO
            clp$convert_data_to_string (result^.element_value, clc$labeled_elem_representation,
                  display_control.page_width, object_info_work_area, representation, status);
            IF NOT status.normal THEN
              EXIT /form_file_attribute_display/;
            IFEND;

            clp$put_data_representation (display_control, representation, status);
            result := result^.link;
            IF result <> NIL THEN
              clp$new_display_line (display_control, 1, status);
              IF NOT status.normal THEN
                EXIT /form_file_attribute_display/;
              IFEND;
            IFEND;
          WHILEND;

          current_file := current_file^.link;
        WHILEND /process_file_list/;
      IFEND;
      mmp$delete_scratch_segment (scratch_segment, status);
    END /form_file_attribute_display/;

    IF display_control.file_id <> amv$nil_file_identifier THEN
      clp$close_display (display_control, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND clp$_display_file_attributes;
?? TITLE := 'clp$$file', EJECT ??

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

{  FUNCTION (osm$$file) $file (
{    file: file = $required
{    attribute: key
{        (application_information, ai)
{        (assigned, a)
{        attached
{        (catalog, c)
{        (cycle_number, cn)
{        (device_class, dc)
{        (file_contents, file_content, fc)
{        (file_label_type, flt)
{        (file_organization, fo)
{        (file_processor, fp)
{        (file_structure, fs)
{        (global_file_position, gfp)
{        (opened, o)
{        (open_position, op)
{        (permanent, p)
{        (resolved_path, rp)
{        (size, s)
{        (temporary, t)
{        (user_information, ui)
{      keyend = $required
{    )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 38] of clt$keyword_specification,
        recend,
      recend := [[1, [88, 8, 8, 8, 41, 17, 615], clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$FILE'],
            [['ATTRIBUTE                      ', clc$nominal_entry, 2],
            ['FILE                           ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [2, 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, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [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, 1413, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [38], [['A                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['AI                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['APPLICATION_INFORMATION        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['ASSIGNED                       ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['ATTACHED                       ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['C                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['CATALOG                        ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['CN                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['CYCLE_NUMBER                   ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['DC                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['DEVICE_CLASS                   ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['FC                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['FILE_CONTENT                   ', clc$alias_entry,
            clc$normal_usage_entry, 7], ['FILE_CONTENTS                  ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['FILE_LABEL_TYPE                ', clc$nominal_entry,
            clc$normal_usage_entry, 8], ['FILE_ORGANIZATION              ', clc$nominal_entry,
            clc$normal_usage_entry, 9], ['FILE_PROCESSOR                 ', clc$nominal_entry,
            clc$normal_usage_entry, 10], ['FILE_STRUCTURE                 ', clc$nominal_entry,
            clc$normal_usage_entry, 11], ['FLT                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 8], ['FO                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 9], ['FP                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 10], ['FS                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 11], ['GFP                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 12], ['GLOBAL_FILE_POSITION           ', clc$nominal_entry,
            clc$normal_usage_entry, 12], ['O                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 13], ['OP                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 14], ['OPENED                         ', clc$nominal_entry,
            clc$normal_usage_entry, 13], ['OPEN_POSITION                  ', clc$nominal_entry,
            clc$normal_usage_entry, 14], ['P                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 15], ['PERMANENT                      ', clc$nominal_entry,
            clc$normal_usage_entry, 15], ['RESOLVED_PATH                  ', clc$nominal_entry,
            clc$normal_usage_entry, 16], ['RP                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 16], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 17], ['SIZE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 17], ['T                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 18], ['TEMPORARY                      ', clc$nominal_entry,
            clc$normal_usage_entry, 18], ['UI                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 19], ['USER_INFORMATION               ', clc$nominal_entry,
            clc$normal_usage_entry, 19]]]];

?? POP ??

    CONST
      p$file = 1,
      p$attribute = 2;

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

    VAR
      attached: boolean,
      local_file: boolean,
      evaluated_file_reference: fst$evaluated_file_reference,
      existing_file: boolean,
      ignore_contains_data: boolean,
      device_assigned: boolean,
      device_class: rmt$device_class,
      path_handle_name: fst$path_handle_name,
      file_attribute: array [1 .. 1] of amt$get_item,
      perm_file: boolean,
      str: fst$path,
      str_size: fst$path_size;


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

    get_$file_attribute_key (pvt [p$attribute].value^.keyword_value, file_attribute [1].key);

    IF (pvt [p$attribute].value^.keyword_value = 'DEVICE_CLASS') OR (pvt [p$attribute].value^.keyword_value =
          'ASSIGNED') OR (pvt [p$attribute].value^.keyword_value = 'PERMANENT') OR
          (pvt [p$attribute].value^.keyword_value = 'TEMPORARY') THEN
      rmp$get_device_class (pvt [p$file].value^.file_value^, device_assigned, device_class, status);
      IF pvt [p$attribute].value^.keyword_value = 'DEVICE_CLASS' THEN
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$make_string_value (class [device_class] (1, clp$trimmed_string_size (class [device_class])),
              work_area, result);
      ELSE
        IF NOT status.normal THEN
          device_assigned := FALSE;
          status.normal := TRUE;
        IFEND;
        IF NOT (pvt [p$attribute].value^.keyword_value = 'ASSIGNED') AND device_assigned THEN
          clp$convert_str_to_path_handle (pvt [p$file].value^.file_value^, FALSE, TRUE, FALSE,
                path_handle_name, evaluated_file_reference, status);
          device_assigned := (pvt [p$attribute].value^.keyword_value = 'PERMANENT') XOR
                (fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local);
        IFEND;
        clp$make_boolean_value (device_assigned, clc$true_false_boolean, work_area, result);

      IFEND;

    ELSEIF pvt [p$attribute].value^.keyword_value = 'CATALOG' THEN
      clp$convert_str_to_path_handle (pvt [p$file].value^.file_value^, FALSE, TRUE, FALSE, path_handle_name,
            evaluated_file_reference, status);

      clp$make_boolean_value (status.normal AND (evaluated_file_reference.path_resolution = fsc$catalog_path),
            clc$true_false_boolean, work_area, result);
      status.normal := TRUE;

    ELSEIF (pvt [p$attribute].value^.keyword_value = 'CYCLE_NUMBER') THEN
      clp$convert_str_to_path_handle (pvt [p$file].value^.file_value^, FALSE, TRUE, FALSE, path_handle_name,
            evaluated_file_reference, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF evaluated_file_reference.path_resolution = fsc$catalog_path THEN
        osp$set_status_abnormal ('CL', pfe$name_not_permanent_file, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$file].value^.file_value^, status);
        RETURN;
      IFEND;

      clp$make_integer_value (evaluated_file_reference.cycle_reference.cycle_number, 10, FALSE, work_area,
            result);

    ELSEIF pvt [p$attribute].value^.keyword_value = 'ATTACHED' THEN
      clp$convert_str_to_path_handle (pvt [p$file].value^.file_value^, FALSE, TRUE, FALSE, path_handle_name,
            evaluated_file_reference, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF evaluated_file_reference.path_resolution = fsc$catalog_path THEN
        osp$set_status_abnormal ('CL', pfe$name_not_permanent_file, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$file].value^.file_value^, status);
        RETURN;
      ELSEIF evaluated_file_reference.path_resolution = fsc$command_file_path THEN
        attached := TRUE;
      ELSE
        bap$is_file_registered (evaluated_file_reference.path_handle_info.path_handle, attached, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      clp$make_boolean_value (attached, clc$true_false_boolean, work_area, result);

    ELSEIF pvt [p$attribute].value^.keyword_value = 'RESOLVED_PATH' THEN
      clp$convert_str_to_path_handle (pvt [p$file].value^.file_value^, FALSE, TRUE, TRUE, path_handle_name,
            evaluated_file_reference, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_file_ref_to_string (evaluated_file_reference, TRUE, str, str_size, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$make_file_value (str (1, str_size), work_area, result);

    ELSE
      amp$get_file_attributes (pvt [p$file].value^.file_value^, file_attribute, local_file, existing_file,
            ignore_contains_data, status);
      IF NOT status.normal THEN
        RETURN
      IFEND;

      CASE file_attribute [1].key OF

      = amc$application_info =
        clp$make_string_value (file_attribute [1].application_info
              (1, clp$trimmed_string_size (file_attribute [1].application_info)), work_area, result);

      = amc$file_contents =
        clp$make_string_value (file_attribute [1].file_contents
              (1, clp$trimmed_string_size (file_attribute [1].file_contents)), work_area, result);

      = amc$file_length = {SIZE}
        clp$make_integer_value (file_attribute [1].file_length, 10, FALSE, work_area, result);

      = amc$file_organization =
        clp$make_string_value (file_organizations [file_attribute [1].file_organization]
              (1, clp$trimmed_string_size (file_organizations [file_attribute [1].file_organization])),
              work_area, result);

      = amc$file_processor =
        clp$make_string_value (file_attribute [1].file_processor
              (1, clp$trimmed_string_size (file_attribute [1].file_processor)), work_area, result);

      = amc$file_structure =
        clp$make_string_value (file_attribute [1].file_structure
              (1, clp$trimmed_string_size (file_attribute [1].file_structure)), work_area, result);

      = amc$global_file_position =
        clp$make_string_value (global_file_positions [file_attribute [1].global_file_position]
              (1, clp$trimmed_string_size (global_file_positions [file_attribute [1].global_file_position])),
              work_area, result);

      = amc$label_type =
        clp$make_string_value (label_types [file_attribute [1].label_type]
              (1, clp$trimmed_string_size (label_types [file_attribute [1].label_type])), work_area, result);

      = amc$null_attribute = {OPENED}
        clp$make_boolean_value (existing_file, clc$true_false_boolean, work_area, result);

      = amc$open_position =
        clp$make_string_value (clv$open_positions [file_attribute [1].open_position]
              (1, clp$trimmed_string_size (clv$open_positions [file_attribute [1].open_position])),
              work_area, result);

      = amc$user_info =
        clp$make_string_value (file_attribute [1].user_info
              (1, clp$trimmed_string_size (file_attribute [1].user_info)), work_area, result);

      ELSE
      CASEND;
    IFEND;

    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$file;

?? TITLE := 'clp$$file_attributes', EJECT ??

  PROCEDURE [XDCL] clp$$file_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$$file_attributes) $file_attributes (
{   file: any of
{       key
{         (system_default_values, system_default_value, sdv)
{       keyend
{       list of file
{     anyend = $required
{   attributes: list of key
{       all
{       (access_control_list, acl)
{       (account_project, ap)
{       (actual_job_access, aja)
{       (attached, a)
{       (catalog_registration_attributes, cra)
{       (common_file_attributes, cfa)
{       (creation_date_time, cdt)
{       (cycle_number, cn)
{       (device_class_attributes, dca)
{       (exception_conditions, exception_condition, ec)
{       (expiration_date, ed)
{       (file_contents, fc)
{       (file_processor, fp)
{       (job_environment_attributes, jea)
{       (keyed_file_attributes, kfa)
{       (last_access_date_time, ladt)
{       (last_modification_date_time, lmdt)
{       (object_type, ot)
{       (path, p)
{       (permitted_access, pa)
{       (potential_job_access, pja)
{       (presentation_file_attributes, pfa)
{       (registered, r)
{       (size, s)
{     advanced_key
{       (attached_external_vsn_list, aevl)
{       (attached_recorded_vsn_list, arvl)
{       (attached_transfer_size, ats)
{       (attached_vol_overflow_allowed, avoa)
{       (attached_volume_number, avn)
{       (attachment_log, al)
{       (attachment_logging_selected, als)
{       (average_record_length, arl)
{       (block_type, bt)
{       (character_conversion, cc)
{       (collate_table_name, ctn)
{       (compression_procedure_name, cpn)
{       (connected_files, cf)
{       (data_padding, dp)
{       (device_class, dc)
{       (dynamic_home_block_space, dhbs)
{       (embedded_key, ek)
{       (error_exit_procedure_name, een, error_exit_name, eepn)
{       (error_limit, el)
{       (estimated_record_count, erc)
{       (external_vsn_list, evsnl, evl)
{       (file_access_procedure_name, file_access_procedure, fap, fapn)
{       (file_label_type, flt)
{       (file_limit, fl)
{       (file_organization, fo)
{       (file_previously_opened, fpo)
{       (forced_write, fw)
{       (hashing_procedure_name, hpn)
{       (index_levels, index_level, il)
{       (index_padding, ip)
{       (initial_home_block_count, ihbc)
{       (internal_code, ic)
{       (job_file_address, jfa)
{       (job_file_position, jfp)
{       (job_instances_of_open, jioo)
{       (job_write_concurrency, jwc)
{       (key_length, kl)
{       (key_position, kp)
{       (key_type, kt)
{       (last_data_modification_time, ldmd, ldmdt, last_data_modification_date, ldmt)
{       (lifetime, l)
{       (lifetime_attachment_count, lac)
{       (line_number, ln)
{       (loading_factor, lf)
{       (lock_expiration_time, let)
{       (log_residence, lr)
{       (logging_options, lo)
{       (mainframe_attachment, ma)
{       (mainframe_write_concurrency, mwc)
{       (mass_storage_allocation_size, msas)
{       (mass_storage_bytes_allocated, msba)
{       (mass_storage_class, msc)
{       (mass_storage_free_behind, msfb)
{       (mass_storage_initial_volume, msiv)
{       (mass_storage_sequential_access, mssa)
{       (mass_storage_transfer_size, msts)
{       (maximum_block_length, maxbl)
{       (maximum_record_length, maxrl)
{       (message_control, mc)
{       (minimum_block_length, minbl)
{       (minimum_record_length, minrl)
{       (open_position, op)
{       (padding_character, pc)
{       (page_format, pf)
{       (page_length, pl)
{       (page_width, pw)
{       (preset_value, pv)
{       (private_read, pr)
{       (record_delimiting_character, rdc)
{       (record_limit, rl)
{       (record_type, rt)
{       (recorded_vsn_list, rvsnl, rvl)
{       (records_per_block, rpb)
{       (retrieve_option, ro)
{       (ring_attributes, ring_attribute, ra)
{       (secondary_residence, sr)
{       (set_name, sn)
{       (shared_queue, sq)
{       (site_archive_option, sao)
{       (site_backup_option, sbo)
{       (site_release_option, sro)
{       (statement_identifier, si)
{       (tape_density, td)
{       (unique_data_name, udn)
{       (unique_name, un)
{       (user_information, ui)
{       (vertical_print_density, vpd)
{       (volume_overflow_allowed, voa)
{     keyend = $required
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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 .. 3] 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,
          recend,
        recend,
      recend,
      type2: 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 .. 237] of clt$keyword_specification,
        recend,
      recend,
    recend := [
    [1,
    [97, 1, 7, 11, 36, 7, 608],
    clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$FILE_ATTRIBUTES'], [
    ['ATTRIBUTES                     ',clc$nominal_entry, 2],
    ['FILE                           ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 157,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [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, 8792,
  clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SDV                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['SYSTEM_DEFAULT_VALUE           ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['SYSTEM_DEFAULT_VALUES          ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$file_type]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [8776, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [237], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['ACCESS_CONTROL_LIST            ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['ACCOUNT_PROJECT                ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['ACL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['ACTUAL_JOB_ACCESS              ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['AEVL                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 26],
      ['AJA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['AL                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 31],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['ALS                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 32],
      ['AP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['ARL                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 33],
      ['ARVL                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 27],
      ['ATS                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 28],
      ['ATTACHED                       ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['ATTACHED_EXTERNAL_VSN_LIST     ', clc$nominal_entry, clc$advanced_usage_entry, 26],
      ['ATTACHED_RECORDED_VSN_LIST     ', clc$nominal_entry, clc$advanced_usage_entry, 27],
      ['ATTACHED_TRANSFER_SIZE         ', clc$nominal_entry, clc$advanced_usage_entry, 28],
      ['ATTACHED_VOLUME_NUMBER         ', clc$nominal_entry, clc$advanced_usage_entry, 30],
      ['ATTACHED_VOL_OVERFLOW_ALLOWED  ', clc$nominal_entry, clc$advanced_usage_entry, 29],
      ['ATTACHMENT_LOG                 ', clc$nominal_entry, clc$advanced_usage_entry, 31],
      ['ATTACHMENT_LOGGING_SELECTED    ', clc$nominal_entry, clc$advanced_usage_entry, 32],
      ['AVERAGE_RECORD_LENGTH          ', clc$nominal_entry, clc$advanced_usage_entry, 33],
      ['AVN                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 30],
      ['AVOA                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 29],
      ['BLOCK_TYPE                     ', clc$nominal_entry, clc$advanced_usage_entry, 34],
      ['BT                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 34],
      ['CATALOG_REGISTRATION_ATTRIBUTES', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['CC                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 35],
      ['CDT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
      ['CF                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 38],
      ['CFA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['CHARACTER_CONVERSION           ', clc$nominal_entry, clc$advanced_usage_entry, 35],
      ['CN                             ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
      ['COLLATE_TABLE_NAME             ', clc$nominal_entry, clc$advanced_usage_entry, 36],
      ['COMMON_FILE_ATTRIBUTES         ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['COMPRESSION_PROCEDURE_NAME     ', clc$nominal_entry, clc$advanced_usage_entry, 37],
      ['CONNECTED_FILES                ', clc$nominal_entry, clc$advanced_usage_entry, 38],
      ['CPN                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 37],
      ['CRA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['CREATION_DATE_TIME             ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['CTN                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 36],
      ['CYCLE_NUMBER                   ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['DATA_PADDING                   ', clc$nominal_entry, clc$advanced_usage_entry, 39],
      ['DC                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 40],
      ['DCA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
      ['DEVICE_CLASS                   ', clc$nominal_entry, clc$advanced_usage_entry, 40],
      ['DEVICE_CLASS_ATTRIBUTES        ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['DHBS                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 41],
      ['DP                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 39],
      ['DYNAMIC_HOME_BLOCK_SPACE       ', clc$nominal_entry, clc$advanced_usage_entry, 41],
      ['EC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
      ['ED                             ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
      ['EEN                            ', clc$alias_entry, clc$advanced_usage_entry, 43],
      ['EEPN                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 43],
      ['EK                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 42],
      ['EL                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 44],
      ['EMBEDDED_KEY                   ', clc$nominal_entry, clc$advanced_usage_entry, 42],
      ['ERC                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 45],
      ['ERROR_EXIT_NAME                ', clc$alias_entry, clc$advanced_usage_entry, 43],
      ['ERROR_EXIT_PROCEDURE_NAME      ', clc$nominal_entry, clc$advanced_usage_entry, 43],
      ['ERROR_LIMIT                    ', clc$nominal_entry, clc$advanced_usage_entry, 44],
      ['ESTIMATED_RECORD_COUNT         ', clc$nominal_entry, clc$advanced_usage_entry, 45],
      ['EVL                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 46],
      ['EVSNL                          ', clc$alias_entry, clc$advanced_usage_entry, 46],
      ['EXCEPTION_CONDITION            ', clc$alias_entry, clc$normal_usage_entry, 11],
      ['EXCEPTION_CONDITIONS           ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['EXPIRATION_DATE                ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['EXTERNAL_VSN_LIST              ', clc$nominal_entry, clc$advanced_usage_entry, 46],
      ['FAP                            ', clc$alias_entry, clc$advanced_usage_entry, 47],
      ['FAPN                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 47],
      ['FC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
      ['FILE_ACCESS_PROCEDURE          ', clc$alias_entry, clc$advanced_usage_entry, 47],
      ['FILE_ACCESS_PROCEDURE_NAME     ', clc$nominal_entry, clc$advanced_usage_entry, 47],
      ['FILE_CONTENTS                  ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['FILE_LABEL_TYPE                ', clc$nominal_entry, clc$advanced_usage_entry, 48],
      ['FILE_LIMIT                     ', clc$nominal_entry, clc$advanced_usage_entry, 49],
      ['FILE_ORGANIZATION              ', clc$nominal_entry, clc$advanced_usage_entry, 50],
      ['FILE_PREVIOUSLY_OPENED         ', clc$nominal_entry, clc$advanced_usage_entry, 51],
      ['FILE_PROCESSOR                 ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['FL                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 49],
      ['FLT                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 48],
      ['FO                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 50],
      ['FORCED_WRITE                   ', clc$nominal_entry, clc$advanced_usage_entry, 52],
      ['FP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
      ['FPO                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 51],
      ['FW                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 52],
      ['HASHING_PROCEDURE_NAME         ', clc$nominal_entry, clc$advanced_usage_entry, 53],
      ['HPN                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 53],
      ['IC                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 57],
      ['IHBC                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 56],
      ['IL                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 54],
      ['INDEX_LEVEL                    ', clc$alias_entry, clc$advanced_usage_entry, 54],
      ['INDEX_LEVELS                   ', clc$nominal_entry, clc$advanced_usage_entry, 54],
      ['INDEX_PADDING                  ', clc$nominal_entry, clc$advanced_usage_entry, 55],
      ['INITIAL_HOME_BLOCK_COUNT       ', clc$nominal_entry, clc$advanced_usage_entry, 56],
      ['INTERNAL_CODE                  ', clc$nominal_entry, clc$advanced_usage_entry, 57],
      ['IP                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 55],
      ['JEA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
      ['JFA                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 58],
      ['JFP                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 59],
      ['JIOO                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 60],
      ['JOB_ENVIRONMENT_ATTRIBUTES     ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['JOB_FILE_ADDRESS               ', clc$nominal_entry, clc$advanced_usage_entry, 58],
      ['JOB_FILE_POSITION              ', clc$nominal_entry, clc$advanced_usage_entry, 59],
      ['JOB_INSTANCES_OF_OPEN          ', clc$nominal_entry, clc$advanced_usage_entry, 60],
      ['JOB_WRITE_CONCURRENCY          ', clc$nominal_entry, clc$advanced_usage_entry, 61],
      ['JWC                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 61],
      ['KEYED_FILE_ATTRIBUTES          ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['KEY_LENGTH                     ', clc$nominal_entry, clc$advanced_usage_entry, 62],
      ['KEY_POSITION                   ', clc$nominal_entry, clc$advanced_usage_entry, 63],
      ['KEY_TYPE                       ', clc$nominal_entry, clc$advanced_usage_entry, 64],
      ['KFA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
      ['KL                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 62],
      ['KP                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 63],
      ['KT                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 64],
      ['L                              ', clc$abbreviation_entry, clc$advanced_usage_entry, 66],
      ['LAC                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 67],
      ['LADT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
      ['LAST_ACCESS_DATE_TIME          ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['LAST_DATA_MODIFICATION_DATE    ', clc$alias_entry, clc$advanced_usage_entry, 65],
      ['LAST_DATA_MODIFICATION_TIME    ', clc$nominal_entry, clc$advanced_usage_entry, 65],
      ['LAST_MODIFICATION_DATE_TIME    ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['LDMD                           ', clc$alias_entry, clc$advanced_usage_entry, 65],
      ['LDMDT                          ', clc$alias_entry, clc$advanced_usage_entry, 65],
      ['LDMT                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 65],
      ['LET                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 70],
      ['LF                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 69],
      ['LIFETIME                       ', clc$nominal_entry, clc$advanced_usage_entry, 66],
      ['LIFETIME_ATTACHMENT_COUNT      ', clc$nominal_entry, clc$advanced_usage_entry, 67],
      ['LINE_NUMBER                    ', clc$nominal_entry, clc$advanced_usage_entry, 68],
      ['LMDT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
      ['LN                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 68],
      ['LO                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 72],
      ['LOADING_FACTOR                 ', clc$nominal_entry, clc$advanced_usage_entry, 69],
      ['LOCK_EXPIRATION_TIME           ', clc$nominal_entry, clc$advanced_usage_entry, 70],
      ['LOGGING_OPTIONS                ', clc$nominal_entry, clc$advanced_usage_entry, 72],
      ['LOG_RESIDENCE                  ', clc$nominal_entry, clc$advanced_usage_entry, 71],
      ['LR                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 71],
      ['MA                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 73],
      ['MAINFRAME_ATTACHMENT           ', clc$nominal_entry, clc$advanced_usage_entry, 73],
      ['MAINFRAME_WRITE_CONCURRENCY    ', clc$nominal_entry, clc$advanced_usage_entry, 74],
      ['MASS_STORAGE_ALLOCATION_SIZE   ', clc$nominal_entry, clc$advanced_usage_entry, 75],
      ['MASS_STORAGE_BYTES_ALLOCATED   ', clc$nominal_entry, clc$advanced_usage_entry, 76],
      ['MASS_STORAGE_CLASS             ', clc$nominal_entry, clc$advanced_usage_entry, 77],
      ['MASS_STORAGE_FREE_BEHIND       ', clc$nominal_entry, clc$advanced_usage_entry, 78],
      ['MASS_STORAGE_INITIAL_VOLUME    ', clc$nominal_entry, clc$advanced_usage_entry, 79],
      ['MASS_STORAGE_SEQUENTIAL_ACCESS ', clc$nominal_entry, clc$advanced_usage_entry, 80],
      ['MASS_STORAGE_TRANSFER_SIZE     ', clc$nominal_entry, clc$advanced_usage_entry, 81],
      ['MAXBL                          ', clc$abbreviation_entry, clc$advanced_usage_entry, 82],
      ['MAXIMUM_BLOCK_LENGTH           ', clc$nominal_entry, clc$advanced_usage_entry, 82],
      ['MAXIMUM_RECORD_LENGTH          ', clc$nominal_entry, clc$advanced_usage_entry, 83],
      ['MAXRL                          ', clc$abbreviation_entry, clc$advanced_usage_entry, 83],
      ['MC                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 84],
      ['MESSAGE_CONTROL                ', clc$nominal_entry, clc$advanced_usage_entry, 84],
      ['MINBL                          ', clc$abbreviation_entry, clc$advanced_usage_entry, 85],
      ['MINIMUM_BLOCK_LENGTH           ', clc$nominal_entry, clc$advanced_usage_entry, 85],
      ['MINIMUM_RECORD_LENGTH          ', clc$nominal_entry, clc$advanced_usage_entry, 86],
      ['MINRL                          ', clc$abbreviation_entry, clc$advanced_usage_entry, 86],
      ['MSAS                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 75],
      ['MSBA                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 76],
      ['MSC                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 77],
      ['MSFB                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 78],
      ['MSIV                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 79],
      ['MSSA                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 80],
      ['MSTS                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 81],
      ['MWC                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 74],
      ['OBJECT_TYPE                    ', clc$nominal_entry, clc$normal_usage_entry, 19],
      ['OP                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 87],
      ['OPEN_POSITION                  ', clc$nominal_entry, clc$advanced_usage_entry, 87],
      ['OT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
      ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 20],
      ['PA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 21],
      ['PADDING_CHARACTER              ', clc$nominal_entry, clc$advanced_usage_entry, 88],
      ['PAGE_FORMAT                    ', clc$nominal_entry, clc$advanced_usage_entry, 89],
      ['PAGE_LENGTH                    ', clc$nominal_entry, clc$advanced_usage_entry, 90],
      ['PAGE_WIDTH                     ', clc$nominal_entry, clc$advanced_usage_entry, 91],
      ['PATH                           ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['PC                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 88],
      ['PERMITTED_ACCESS               ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['PF                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 89],
      ['PFA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 23],
      ['PJA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 22],
      ['PL                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 90],
      ['POTENTIAL_JOB_ACCESS           ', clc$nominal_entry, clc$normal_usage_entry, 22],
      ['PR                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 93],
      ['PRESENTATION_FILE_ATTRIBUTES   ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['PRESET_VALUE                   ', clc$nominal_entry, clc$advanced_usage_entry, 92],
      ['PRIVATE_READ                   ', clc$nominal_entry, clc$advanced_usage_entry, 93],
      ['PV                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 92],
      ['PW                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 91],
      ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 24],
      ['RA                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 100],
      ['RDC                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 94],
      ['RECORDED_VSN_LIST              ', clc$nominal_entry, clc$advanced_usage_entry, 97],
      ['RECORDS_PER_BLOCK              ', clc$nominal_entry, clc$advanced_usage_entry, 98],
      ['RECORD_DELIMITING_CHARACTER    ', clc$nominal_entry, clc$advanced_usage_entry, 94],
      ['RECORD_LIMIT                   ', clc$nominal_entry, clc$advanced_usage_entry, 95],
      ['RECORD_TYPE                    ', clc$nominal_entry, clc$advanced_usage_entry, 96],
      ['REGISTERED                     ', clc$nominal_entry, clc$normal_usage_entry, 24],
      ['RETRIEVE_OPTION                ', clc$nominal_entry, clc$advanced_usage_entry, 99],
      ['RING_ATTRIBUTE                 ', clc$alias_entry, clc$advanced_usage_entry, 100],
      ['RING_ATTRIBUTES                ', clc$nominal_entry, clc$advanced_usage_entry, 100],
      ['RL                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 95],
      ['RO                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 99],
      ['RPB                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 98],
      ['RT                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 96],
      ['RVL                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 97],
      ['RVSNL                          ', clc$alias_entry, clc$advanced_usage_entry, 97],
      ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 25],
      ['SAO                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 104],
      ['SBO                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 105],
      ['SECONDARY_RESIDENCE            ', clc$nominal_entry, clc$advanced_usage_entry, 101],
      ['SET_NAME                       ', clc$nominal_entry, clc$advanced_usage_entry, 102],
      ['SHARED_QUEUE                   ', clc$nominal_entry, clc$advanced_usage_entry, 103],
      ['SI                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 107],
      ['SITE_ARCHIVE_OPTION            ', clc$nominal_entry, clc$advanced_usage_entry, 104],
      ['SITE_BACKUP_OPTION             ', clc$nominal_entry, clc$advanced_usage_entry, 105],
      ['SITE_RELEASE_OPTION            ', clc$nominal_entry, clc$advanced_usage_entry, 106],
      ['SIZE                           ', clc$nominal_entry, clc$normal_usage_entry, 25],
      ['SN                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 102],
      ['SQ                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 103],
      ['SR                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 101],
      ['SRO                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 106],
      ['STATEMENT_IDENTIFIER           ', clc$nominal_entry, clc$advanced_usage_entry, 107],
      ['TAPE_DENSITY                   ', clc$nominal_entry, clc$advanced_usage_entry, 108],
      ['TD                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 108],
      ['UDN                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 109],
      ['UI                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 111],
      ['UN                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 110],
      ['UNIQUE_DATA_NAME               ', clc$nominal_entry, clc$advanced_usage_entry, 109],
      ['UNIQUE_NAME                    ', clc$nominal_entry, clc$advanced_usage_entry, 110],
      ['USER_INFORMATION               ', clc$nominal_entry, clc$advanced_usage_entry, 111],
      ['VERTICAL_PRINT_DENSITY         ', clc$nominal_entry, clc$advanced_usage_entry, 112],
      ['VOA                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 113],
      ['VOLUME_OVERFLOW_ALLOWED        ', clc$nominal_entry, clc$advanced_usage_entry, 113],
      ['VPD                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 112]]
      ]
    ]];

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

    CONST
      p$file = 1,
      p$attributes = 2;

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

    CONST
      nil_object_info_text = 'NEXT of object_information in sequence resulted in a NIL pointer in ' CAT
            '$FILE_ATTRIBUTES';

    VAR
      all_requested: boolean,
      attributes_requested: file_attribute_keys,
      caller_id: ost$caller_identifier,
      current_file: ^clt$data_value,
      current_value: ^clt$data_value,
      evaluated_file_reference: fst$evaluated_file_reference,
      information_request: fst$goi_information_request,
      number_of_requested_attributes: object_type_counts,
      object_info_sequence_p: ^SEQ ( * ),
      object_information_p: ^fst$goi_object_information,
      result_node: ^^clt$data_value;

    #CALLER_ID (caller_id);

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

    determine_attributes_requested (pvt [p$attributes].value, attributes_requested,
          number_of_requested_attributes, all_requested);

    information_request := initial_information_request;
    determine_object_info_requests (attributes_requested, information_request.object_information_requests);

    IF pvt [p$file].value^.kind = clc$keyword THEN { system_default_values }
      object_info_sequence_p := NIL;
      process_object_information (fsv$evaluated_file_reference, caller_id.ring, {validation_criteria} NIL,
            all_requested, number_of_requested_attributes, attributes_requested, object_info_sequence_p,
            work_area, result, status);
    ELSE
      result_node := ^result;
      current_file := pvt [p$file].value;
      WHILE current_file <> NIL DO
        clp$evaluate_file_reference (current_file^.element_value^.file_value^,
              $clt$file_ref_parsing_options [], FALSE, evaluated_file_reference, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        object_info_sequence_p := work_area;
        get_object_information (evaluated_file_reference, information_request, NIL, work_area, status);
        IF NOT status.normal AND NOT status_condition_ignorable
              (status.condition, attributes_requested, evaluated_file_reference) THEN
          RETURN;
        ELSE
          process_object_information (evaluated_file_reference, caller_id.ring, {validation_criteria} NIL,
                all_requested, number_of_requested_attributes, attributes_requested, object_info_sequence_p,
                work_area, result_node^, status);
          IF NOT status.normal AND (status.condition = fse$attributes_not_defined) THEN
            osp$append_status_file (osc$status_parameter_delimiter, current_file^.element_value^.file_value^,
                  status);
            RETURN;
          IFEND;
        IFEND;

        current_file := current_file^.link;
        REPEAT
          result_node := ^result_node^^.link;
        UNTIL result_node^ = NIL;
      WHILEND;
    IFEND;

  PROCEND clp$$file_attributes;

?? TITLE := 'clp$$access_mode', EJECT ??

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

{ FUNCTION (osm$$access_mode) $access_mode (
{   file: file = $required
{   access_modes: list rest of key
{       all
{       (append, a)
{       (execute, e)
{       (modify, m)
{       (read, r)
{       (shorten, s)
{       (write, w)
{     keyend = $required
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 13] of clt$keyword_specification,
        recend,
      recend,
    recend := [
    [1,
    [89, 6, 12, 13, 46, 37, 964],
    clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$ACCESS_MODE'], [
    ['ACCESS_MODES                   ',clc$nominal_entry, 2],
    ['FILE                           ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [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, 504,
  clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [488, 1, clc$max_list_size, TRUE],
      [[1, 0, clc$keyword_type], [13], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['APPEND                         ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['EXECUTE                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['MODIFY                         ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['READ                           ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['SHORTEN                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['WRITE                          ', clc$nominal_entry, clc$normal_usage_entry, 7]]
      ]
    ]];

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

    CONST
      p$file = 1,
      p$access_modes = 2;

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

    VAR
      ignore_local_file: boolean,
      ignore_existing_file: boolean,
      ignore_contains_data: boolean,
      file_attribute: array [1 .. 1] of amt$get_item,
      access_mode: pft$usage_selections,
      node: ^clt$data_value;


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

    file_attribute [1].key := amc$global_access_mode;
    amp$get_file_attributes (pvt [p$file].value^.file_value^, file_attribute, ignore_local_file,
          ignore_existing_file, ignore_contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    access_mode := $pft$usage_selections [];

    node := pvt [p$access_modes].value;
    WHILE node <> NIL DO
      IF node^.element_value^.keyword_value = 'ALL' THEN
        access_mode := -$pft$usage_selections [];
      ELSEIF node^.element_value^.keyword_value = 'APPEND' THEN
        access_mode := access_mode + $pft$usage_selections [pfc$append];
      ELSEIF node^.element_value^.keyword_value = 'EXECUTE' THEN
        access_mode := access_mode + $pft$usage_selections [pfc$execute];
      ELSEIF node^.element_value^.keyword_value = 'MODIFY' THEN
        access_mode := access_mode + $pft$usage_selections [pfc$modify];
      ELSEIF node^.element_value^.keyword_value = 'READ' THEN
        access_mode := access_mode + $pft$usage_selections [pfc$read];
      ELSEIF node^.element_value^.keyword_value = 'SHORTEN' THEN
        access_mode := access_mode + $pft$usage_selections [pfc$shorten];
      ELSEIF node^.element_value^.keyword_value = 'WRITE' THEN
        access_mode := access_mode + $pft$usage_selections [pfc$append, pfc$modify, pfc$shorten];
      IFEND;
      node := node^.link;
    WHILEND;

    clp$make_boolean_value (access_mode <= file_attribute [1].global_access_mode, clc$true_false_boolean,
          work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$access_mode;

MODEND clm$display_file_attb_command;
*DECK DECK=CLM$DISPLAY_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Command Display Interfaces' ??
MODULE clm$display_interfaces;

{
{ PURPOSE:
{   This module contains the display interfaces for the SCL command processors.
{

?? NEWTITLE := 'Global Declarations' ??
?? NEWTITLE := 'Display Interface Types', EJECT ??
*copyc clc$page_widths
*copyc clt$display_control
*copyc clt$path_display_chunks
?? OLDTITLE, EJECT ??
?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc amd$file_attributes
*IFEND
*copyc clt$data_representation
*copyc clt$file
*copyc clt$path_name
*copyc fsc$max_path_size
*IF NOT $true(osv$unix)
*copyc fst$attachment_options
*copyc fst$file_cycle_attributes
*ELSE
*copyc amc_standard_files
*copyc clv$standard_files
*IFEND
*copyc fst$path
*IF NOT $true(osv$unix)
*copyc oss$job_paged_literal
*IFEND
*copyc ost$status
?? POP ??
*IF NOT $true(osv$unix)
*copyc amp$fetch
*copyc amp$get_file_attributes
*IFEND
*copyc amp$put_next
*copyc amp$put_partial
*copyc clp$get_date_string
*IF $true(osv$unix)
*copyc clp$get_screen_mode
*IFEND
*copyc clp$get_time_string
*copyc clp$right_justify_string
*copyc clp$trimmed_string_size
*IF $true(osv$unix)
*copyc osp_screen_output
*IFEND
*copyc fsp$close_file
*IF NOT $true(osv$unix)
*copyc fsp$get_open_information
*IFEND
*copyc fsp$open_file
*copyc osv$upper_to_lower
*copyc pmp$get_os_version
*IF $true(osv$unix)
*copyc osv$signal
*copyc osv$signal_status
*copyc csp$output_window
*copyc amd$file_contents
*IFEND

?? TITLE := 'clv$nil_display_control', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$nil_display_control: [XDCL, #GATE, READ, oss$job_paged_literal] clt$display_control :=
          [ * , * , * , 0, * , 1, [0, 1], * , * , FALSE, * , FALSE, FALSE, [0, * ], FALSE];
*ELSE
    clv$nil_display_control: [XDCL, #GATE, READ] clt$display_control :=
          [ * , * , * , 0, * , 1, -1, * , * , FALSE, * , FALSE, FALSE, [0, * ], FALSE];
*IFEND

*IF NOT $true(osv$unix)
  VAR
    clv$call_from_colt_command: [XREF] boolean;
*IFEND

?? TITLE := 'clp$close_display', EJECT ??
*copy clh$close_display

  PROCEDURE [XDCL, #GATE] clp$close_display
    (    display_control: clt$display_control;
     VAR status: ost$status);

    VAR
*IF $true(osv$unix)
      in_screen_mode: boolean,
*IFEND
      scratch_display_control: clt$display_control;


    status.normal := TRUE;
    IF display_control.data_in_line THEN
      scratch_display_control := display_control;
      flush_line (scratch_display_control, status);
    IFEND;
*IF $true(osv$unix)

{ Don't close any of the standard files
    CASE display_control.file_id OF
    = amc_stdin_fid, amc_stdout_fid, amc_stderr_fid =
      ;
    ELSE
      IF display_control.file_id <> clv$standard_files [clc$sf_null_file].file_id THEN
*IFEND
    fsp$close_file (display_control.file_id, status);
*IF $true(osv$unix)
      IFEND;
    CASEND;
*IFEND

*IF $true(osv$unix)
    clp$get_screen_mode (in_screen_mode);
{   IF in_screen_mode AND display_control.output_window  THEN
    IF in_screen_mode THEN
      csp_output_window;
    IFEND;
*IFEND
  PROCEND clp$close_display;
?? TITLE := 'clp$discard_accumulated_display', EJECT ??
*copy clh$discard_accumulated_display

  PROCEDURE [XDCL, #GATE] clp$discard_accumulated_display
    (VAR display_control {input, output} : clt$display_control;
     VAR status: ost$status);


    status.normal := TRUE;
    display_control.column_number := 1;
    display_control.data_in_line := FALSE;
    display_control.new_line_started := FALSE;
    display_control.new_page_proc_called := FALSE;
    display_control.line.size := 0;
    display_control.put_partial_line := FALSE;

  PROCEND clp$discard_accumulated_display;
?? TITLE := 'clp$horizontal_tab_display', EJECT ??
*copy clh$horizontal_tab_display

  PROCEDURE [XDCL, #GATE] clp$horizontal_tab_display
    (VAR display_control {input, output} : clt$display_control;
         column_number: amt$page_width;
     VAR status: ost$status);

    VAR
      term_option: amt$term_option,
      count: 0 .. amc$max_page_width,
      spaces: ^string ( * );


    status.normal := TRUE;
    IF NOT display_control.data_in_line THEN
      count := column_number - 1;
      term_option := amc$start;
    ELSEIF column_number > display_control.column_number THEN
      count := column_number - display_control.column_number;
      term_option := amc$continue;
    ELSE
      RETURN;
    IFEND;
    PUSH spaces: [count];
    spaces^ := '';
    clp$put_partial_display (display_control, spaces^, clc$no_trim, term_option, status);

  PROCEND clp$horizontal_tab_display;
?? TITLE := 'flush_line', EJECT ??

  PROCEDURE [INLINE] flush_line
    (VAR display_control {input, output} : clt$display_control;
     VAR status: ost$status);

    VAR
      ignore_byte_address: amt$file_byte_address;


*IF $true(osv$unix)
    IF osv$signal <> $ost$signals [] THEN
      status := osv$signal_status;
      RETURN;
    IFEND;
*IFEND

    IF display_control.put_partial_line THEN
      amp$put_partial (display_control.file_id, ^display_control.line.value, display_control.line.size,
            ignore_byte_address, amc$terminate, status);
    ELSE
      amp$put_next (display_control.file_id, ^display_control.line.value, display_control.line.size,
            ignore_byte_address, status);
    IFEND;

{ Clean out information about the line even if the put fails.

    display_control.put_partial_line := FALSE;
    display_control.line.size := 0;
    display_control.data_in_line := FALSE;

  PROCEND flush_line;
?? TITLE := 'collect_display_line', EJECT ??

  PROCEDURE [INLINE] collect_display_line
    (VAR display_control {input, output} : clt$display_control;
         str: string ( * );
         term_option: amt$term_option;
     VAR status: ost$status);

    VAR
      ignore_byte_address: amt$file_byte_address,
      str_length: integer,
      line_length: integer,
      new_line_length: integer,
      bam_term_option: amt$term_option,
      start_string: integer,
      end_string: integer;


*IF $true(osv$unix)
    IF osv$signal <> $ost$signals [] THEN
      status := osv$signal_status;
      RETURN;
    IFEND;
*IFEND

    str_length := STRLENGTH (str);
    line_length := display_control.line.size;
    new_line_length := line_length + str_length;

{ Check to make sure that new string does not cause line to exceed allowed length.

    IF new_line_length > osc$max_string_size THEN
      IF display_control.put_partial_line THEN
        bam_term_option := amc$continue;
      ELSE
        display_control.put_partial_line := TRUE;
        bam_term_option := amc$start;
      IFEND;
      display_control.line.value (display_control.line.size + 1,
            osc$max_string_size - display_control.line.size) :=
            str (1, osc$max_string_size - display_control.line.size);
      start_string := osc$max_string_size - display_control.line.size;
      amp$put_partial (display_control.file_id, ^display_control.line.value, osc$max_string_size,
            ignore_byte_address, bam_term_option, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      new_line_length := new_line_length - osc$max_string_size;
      WHILE new_line_length > osc$max_string_size DO
*IF NOT $true(osv$unix)
        amp$put_partial (display_control.file_id, ^str (start_string + 1), osc$max_string_size,
*ELSE
        amp$put_partial (display_control.file_id, ^str (start_string + 1, *), osc$max_string_size,
*IFEND
              ignore_byte_address, amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        start_string := start_string + osc$max_string_size;
        new_line_length := new_line_length - osc$max_string_size;
      WHILEND;
      display_control.line.value (1, new_line_length) := str (start_string + 1, new_line_length);
      display_control.line.size := new_line_length;

    ELSE

{ Add text that is passed in to line being stored in display_control.

      display_control.line.value (line_length + 1, str_length) := str;
      line_length := line_length + str_length;
      display_control.line.size := line_length;

    IFEND;

{ If procedure is called with terminate option then put the collected line out.

    IF term_option = amc$terminate THEN
      flush_line (display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND collect_display_line;
?? TITLE := 'new_display_line', EJECT ??

  PROCEDURE new_display_line
    (VAR display_control {input, output} : clt$display_control;
         skip_count: clt$new_display_line_skip;
     VAR bam_term_option {input, output} : amt$term_option;
     VAR status: ost$status);

    VAR
      ignore_byte_address: amt$file_byte_address,
*IF NOT $true(osv$unix)
      format_effector: char,
*ELSE
      format_effector: string (1),
*IFEND
      count: integer;


*IF $true(osv$unix)
    IF osv$signal <> $ost$signals [] THEN
      status := osv$signal_status;
      RETURN;
    IFEND;
*IFEND

    status.normal := TRUE;
    IF bam_term_option = amc$start THEN
      bam_term_option := amc$continue;
    IFEND;
    IF display_control.new_line_started THEN
      RETURN
    IFEND;
    count := skip_count;
    IF display_control.data_in_line THEN
      flush_line (display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    IF (count + display_control.line_number >= display_control.page_length) AND
          ((display_control.page_format = amc$burstable_form) OR
          (display_control.page_format = amc$non_burstable_form)) THEN
      clp$new_display_page (display_control, status);

      IF (NOT status.normal) OR display_control.new_line_started THEN
        RETURN;
      IFEND;
      count := 0;
    IFEND;
    IF display_control.include_format_effectors THEN
      format_effector := '-';
      WHILE count >= 3 DO
        amp$put_next (display_control.file_id, ^format_effector, 1, ignore_byte_address, status);
        IF NOT status.normal THEN
          RETURN
        IFEND;
        count := count - 3;
      WHILEND;
      IF count = 1 THEN
        format_effector := '0';
      ELSEIF count = 0 THEN
        format_effector := ' ';
      ELSEIF count = -1 THEN
        format_effector := '+';
      IFEND;
      count := 1;
      display_control.line.size := 1;
      display_control.line.value (1) := format_effector;
    ELSE
      WHILE count > 0 DO
        amp$put_next (display_control.file_id, ^format_effector, 0, ignore_byte_address, status);
        IF NOT status.normal THEN
          RETURN
        IFEND;
        count := count - 1;
      WHILEND;
      display_control.line.size := 0;
    IFEND;
    display_control.line_number := display_control.line_number + skip_count + 1;
    display_control.column_number := 1;
    display_control.new_line_started := TRUE;
    display_control.data_in_line := TRUE;

  PROCEND new_display_line;
?? TITLE := 'clp$new_display_line', EJECT ??
*copy clh$new_display_line

  PROCEDURE [XDCL, #GATE] clp$new_display_line
    (VAR display_control {input, output} : clt$display_control;
         skip_count: clt$new_display_line_skip;
     VAR status: ost$status);

    VAR
      count: integer,
      dummy_term_option: amt$term_option;


    status.normal := TRUE;
    dummy_term_option := amc$start;
    IF display_control.new_line_started THEN
      count := skip_count - 1;
      IF count < 0 THEN
        RETURN;
      IFEND;
      display_control.new_line_started := FALSE;
    ELSE
      count := skip_count;
    IFEND;
    new_display_line (display_control, count, dummy_term_option, status);

  PROCEND clp$new_display_line;
?? TITLE := 'clp$new_display_page', EJECT ??
*copy clh$new_display_page

  PROCEDURE [XDCL, #GATE] clp$new_display_page
    (VAR display_control {input, output} : clt$display_control;
     VAR status: ost$status);


    status.normal := TRUE;
    IF NOT display_control.new_page_proc_called THEN
      display_control.new_page_proc_called := TRUE;
      display_control.page_number := display_control.page_number + 1;
      IF display_control.new_page_procedure = NIL THEN
        clp$reset_for_next_display_page (display_control, status);
      ELSE
        display_control.new_page_procedure^ (display_control, display_control.page_number, status);
      IFEND;
      display_control.new_page_proc_called := FALSE;
    IFEND;

  PROCEND clp$new_display_page;
?? TITLE := 'clp$open_display', EJECT ??
*copy clh$open_display

  PROCEDURE [XDCL, #GATE] clp$open_display
    (    file: clt$file;
         new_page_procedure: clt$new_display_page_procedure;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
    VAR
      default_ring_attributes: amt$ring_attributes;


*IF NOT $true(osv$unix)
    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
*ELSE
    default_ring_attributes.r1 := osc$user_ring;
    default_ring_attributes.r2 := osc$user_ring;
    default_ring_attributes.r3 := osc$user_ring;
*IFEND

    clp$open_display_reference (file.local_file_name, new_page_procedure, fsc$list, default_ring_attributes,
          display_control, status);
*ELSE
    clp$open_display_reference (file.local_file_name, new_page_procedure, fsc$list,
          display_control, status);
*IFEND

  PROCEND clp$open_display;
?? TITLE := 'clp$open_display_file', EJECT ??
*copy clh$open_display_file

  PROCEDURE [XDCL, #GATE] clp$open_display_file
    (    file: clt$file;
         new_page_procedure: clt$new_display_page_procedure;
         default_file_contents: amt$file_contents;
*IF NOT $true(osv$unix)
         default_ring_attributes: amt$ring_attributes;
*IFEND
     VAR display_control: clt$display_control;
     VAR status: ost$status);


*IF NOT $true(osv$unix)
    clp$open_display_reference (file.local_file_name, new_page_procedure, default_file_contents,
          default_ring_attributes, display_control, status);
*ELSE
    clp$open_display_reference (file.local_file_name, new_page_procedure, default_file_contents,
          display_control, status);
*IFEND

  PROCEND clp$open_display_file;
?? TITLE := 'clp$open_display_reference', EJECT ??
*copy clh$open_display_reference

  PROCEDURE [XDCL, #GATE] clp$open_display_reference
    (    file: fst$file_reference;
         new_page_procedure: clt$new_display_page_procedure;
         default_file_contents: amt$file_contents;
*IF NOT $true(osv$unix)
         default_ring_attributes: amt$ring_attributes;
*IFEND
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    CONST
      list_unknown = 'LIST_UNKNOWN                   ';

    VAR
*IF NOT $true(osv$unix)
      attachment_option: array [1 .. 4] of fst$attachment_option,
      catalog_information: fst$catalog_information,
      cycle_attribute_values: fst$cycle_attribute_values,
      default_creation_attributes: array [1 .. 3] of fst$file_cycle_attribute,
      fetch_attributes: ^array [1 .. 2] of amt$fetch_item,
      user_defined_attribute_size: fst$user_defined_attribute_size,
      validation_attributes: array [1 .. 9] of fst$file_cycle_attribute;
*ELSE
      attachment_option: array [1 .. 1] of fst$attachment_option,
      in_screen_mode: boolean,
      length: ost_c_integer,
      screen_output: ost_c_fixed_string;
*IFEND


*IF $true(osv$unix)
    IF osv$signal <> $ost$signals [] THEN
      status := osv$signal_status;
      RETURN;
    IFEND;

*IFEND
    status.normal := TRUE;
    display_control := clv$nil_display_control;
    attachment_option [1].selector := fsc$access_and_share_modes;
    attachment_option [1].access_modes.selector := fsc$specific_access_modes;
    attachment_option [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
*IF NOT $true(osv$unix)
    attachment_option [1].share_modes.selector := fsc$specific_share_modes;
    attachment_option [1].share_modes.value := $fst$file_access_options [];
    attachment_option [2].selector := fsc$access_and_share_modes;
    attachment_option [2].access_modes.selector := fsc$specific_access_modes;
    attachment_option [2].access_modes.value := $fst$file_access_options [fsc$append];
    attachment_option [2].share_modes.selector := fsc$specific_share_modes;
    attachment_option [2].share_modes.value := $fst$file_access_options [];
    attachment_option [3].selector := fsc$open_share_modes;
    attachment_option [3].open_share_modes := -$fst$file_access_options [];
    IF clv$call_from_colt_command THEN
      attachment_option [4].selector := fsc$delete_data;
      attachment_option [4].delete_data := TRUE;
    ELSE
      attachment_option [4].selector := fsc$null_attachment_option;
    IFEND;

    default_creation_attributes [1].selector := fsc$file_contents_and_processor;
    default_creation_attributes [1].file_contents := default_file_contents;
    default_creation_attributes [1].file_processor := osc$null_name;
    default_creation_attributes [2].selector := fsc$page_format;
    IF default_file_contents = fsc$list THEN
      default_creation_attributes [2].page_format := amc$burstable_form;
    ELSE
      default_creation_attributes [2].page_format := amc$untitled_form;
    IFEND;
    default_creation_attributes [3].selector := fsc$ring_attributes;
    default_creation_attributes [3].ring_attributes := default_ring_attributes;
*IF NOT $true(osv$unix)
    IF #RING (^default_creation_attributes) > default_creation_attributes [3].ring_attributes.r1 THEN
      default_creation_attributes [3].ring_attributes.r1 := #RING (^default_creation_attributes);
    IFEND;
    IF #RING (^default_creation_attributes) > default_creation_attributes [3].ring_attributes.r2 THEN
      default_creation_attributes [3].ring_attributes.r2 := #RING (^default_creation_attributes);
    IFEND;
    IF #RING (^default_creation_attributes) > default_creation_attributes [3].ring_attributes.r3 THEN
      default_creation_attributes [3].ring_attributes.r3 := #RING (^default_creation_attributes);
    IFEND;
*IFEND

    validation_attributes [1].selector := fsc$file_contents_and_processor;
    validation_attributes [1].file_contents := fsc$list;
    validation_attributes [1].file_processor := osc$null_name;
    validation_attributes [2].selector := fsc$file_contents_and_processor;
    validation_attributes [2].file_contents := fsc$legible_data;
    validation_attributes [2].file_processor := osc$null_name;
    validation_attributes [3].selector := fsc$file_contents_and_processor;
    validation_attributes [3].file_contents := fsc$legible_scl_procedure;
    validation_attributes [3].file_processor := osc$null_name;
    validation_attributes [4].selector := fsc$file_contents_and_processor;
    validation_attributes [4].file_contents := fsc$legible_scl_include;
    validation_attributes [4].file_processor := osc$null_name;
    validation_attributes [5].selector := fsc$file_contents_and_processor;
    validation_attributes [5].file_contents := fsc$legible_scl_job;
    validation_attributes [5].file_processor := osc$null_name;
    validation_attributes [6].selector := fsc$file_contents_and_processor;
    validation_attributes [6].file_contents := list_unknown;
    validation_attributes [6].file_processor := osc$null_name;
    validation_attributes [7].selector := fsc$file_contents_and_processor;
    validation_attributes [7].file_contents := amc$legible;
    validation_attributes [7].file_processor := osc$null_name;
    validation_attributes [8].selector := fsc$file_contents_and_processor;
    validation_attributes [8].file_contents := fsc$data;
    validation_attributes [8].file_processor := osc$null_name;
    validation_attributes [9].selector := fsc$file_contents_and_processor;
    validation_attributes [9].file_contents := fsc$unknown_contents;
    validation_attributes [9].file_processor := osc$null_name;
*IFEND

*IF NOT $true(osv$unix)
    fsp$open_file (file, amc$record, ^attachment_option, ^default_creation_attributes, NIL,
          ^validation_attributes, NIL, display_control.file_id, status);
*ELSE
    fsp$open_file (file, amc$record, ^attachment_option, display_control.file_id, status);

{ If in screen mode, write to OSF$SCREEN_OUTPUT instead of STDOUT.  The output
{ will be displayed in the output window.

    clp$get_screen_mode (in_screen_mode);
    IF (display_control.file_id = amc_stdout_fid) AND in_screen_mode THEN

{ ??? find out what to check BEFORE attempting to open the file.

      osp_screen_output (screen_output, length);
      IF length < 1 THEN
        {???
      IFEND;
      fsp$open_file (screen_output(1, length), amc$record, ^attachment_option, display_control.file_id,
            status);
{     display_control.output_window := TRUE;
{   ELSE
{     display_control.output_window := FALSE;
    IFEND;

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

*IF NOT $true(osv$unix)
    fsp$get_open_information (display_control.file_id, NIL, ^catalog_information, NIL,
          ^cycle_attribute_values, NIL, NIL, NIL, user_defined_attribute_size, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display_control.include_format_effectors := (cycle_attribute_values.file_contents = fsc$list);
    display_control.page_format := cycle_attribute_values.page_format;
    display_control.new_page_procedure := new_page_procedure;
    display_control.device_class := catalog_information.cycle_registration.residence.device_class;
    IF catalog_information.cycle_registration.residence.device_class = rmc$connected_file_device THEN
      PUSH fetch_attributes;
      fetch_attributes^ [1].key := amc$page_length;
      fetch_attributes^ [2].key := amc$page_width;
      amp$fetch (display_control.file_id, fetch_attributes^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      display_control.page_length := fetch_attributes^ [1].page_length;
      display_control.page_width := fetch_attributes^ [2].page_width;
    ELSE
      display_control.page_length := cycle_attribute_values.page_length;
      display_control.page_width := cycle_attribute_values.page_width;
    IFEND;
    display_control.line_number := display_control.page_length + 1;
*ELSE
    display_control.include_format_effectors := FALSE;
{
{ ********  Force fsc$legible_data until SCL file i/o is done **********
{
{   IF default_file_contents = fsc$list THEN
{     display_control.page_format := amc$burstable_form;
{   ELSE
      display_control.page_format := amc$continuous_form;
{   IFEND;
    display_control.new_page_procedure := new_page_procedure;
{   IF NOT display_control.output_window THEN
    display_control.page_length := 24;
    display_control.page_width := 80;
{   ELSE
{     display_control.page_length := ???
{     display_control.page_width := 77;
{   IFEND
    display_control.line_number := display_control.page_length + 1;
*IFEND

  PROCEND clp$open_display_reference;
?? TITLE := 'clp$put_data_representation', EJECT ??
*copy clh$put_data_representation

  PROCEDURE [XDCL, #GATE] clp$put_data_representation
    (VAR display_control {input, output} : clt$display_control;
     VAR data_representation {input, output} : ^clt$data_representation;
     VAR status: ost$status);

    VAR
      i: clt$data_representation_count,
      string_count: ^clt$data_representation_count,
      string_ptr: ^clt$string_value,
      string_size: ^clt$string_size;

    status.normal := TRUE;

    NEXT string_count IN data_representation;
    FOR i := 1 TO string_count^ DO
      NEXT string_size IN data_representation;
      NEXT string_ptr: [string_size^] IN data_representation;
      clp$put_display (display_control, string_ptr^, clc$no_trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND clp$put_data_representation;
?? TITLE := 'clp$put_display', EJECT ??
*copy clh$put_display

  PROCEDURE [XDCL, #GATE] clp$put_display
    (VAR display_control {input, output} : clt$display_control;
         str: string ( * );
         trim_option: clt$trim_display_text_option;
     VAR status: ost$status);

    VAR
      dummy_term_option: amt$term_option;


    status.normal := TRUE;
    dummy_term_option := amc$start;
    new_display_line (display_control, 0, dummy_term_option, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$put_partial_display (display_control, str, trim_option, amc$terminate, status);

  PROCEND clp$put_display;
?? TITLE := 'clp$put_partial_display', EJECT ??
*copy clh$put_partial_display

  PROCEDURE [XDCL, #GATE] clp$put_partial_display
    (VAR display_control {input, output} : clt$display_control;
         str: string ( * );
         trim_option: clt$trim_display_text_option;
         term_option: amt$term_option;
     VAR status: ost$status);

    VAR
      bam_term_option: amt$term_option,
      ignore_byte_address: amt$file_byte_address,
      length: integer;


    status.normal := TRUE;
    bam_term_option := term_option;
    IF (NOT display_control.data_in_line) OR (term_option = amc$start) THEN
      new_display_line (display_control, 0, bam_term_option, status);
      IF NOT status.normal THEN
        RETURN
      IFEND;
    IFEND;
    length := STRLENGTH (str);
    IF trim_option = clc$trim THEN
      WHILE (length > 0) AND (str (length) = ' ') DO
        length := length - 1;
      WHILEND;
    IFEND;
    collect_display_line (display_control, str (1, length), bam_term_option, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    display_control.new_line_started := FALSE;
    IF term_option = amc$terminate THEN
      display_control.data_in_line := FALSE;
      display_control.column_number := 1;
    ELSE
      display_control.data_in_line := TRUE;
      display_control.column_number := display_control.column_number + length;
    IFEND;

  PROCEND clp$put_partial_display;
?? TITLE := 'clp$reset_for_next_display_page', EJECT ??
*copy clh$reset_for_next_display_page

  PROCEDURE [XDCL, #GATE] clp$reset_for_next_display_page
    (VAR display_control {input, output} : clt$display_control;
     VAR status: ost$status);

    CONST
      non_burstable_min_lines = 6;

    VAR
*IF NOT $true(osv$unix)
      format_effector: char,
*ELSE
      format_effector: string (1),
*IFEND
      ignore_byte_address: amt$file_byte_address,
      i: 1 .. 3;


*IF $true(osv$unix)
    IF osv$signal <> $ost$signals [] THEN
      status := osv$signal_status;
      RETURN;
    IFEND;
*IFEND

    status.normal := TRUE;
    IF display_control.data_in_line THEN
      flush_line (display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;



    IF display_control.include_format_effectors THEN
      IF (display_control.page_format = amc$burstable_form) OR
            ((display_control.page_format = amc$non_burstable_form) AND
            (display_control.line_number + non_burstable_min_lines >= display_control.page_length)) THEN
        format_effector := '1';
        display_control.line_number := 1;
      ELSE
        format_effector := '-';
        amp$put_next (display_control.file_id, ^format_effector, 1, ignore_byte_address, status);
        IF NOT status.normal THEN
          RETURN
        IFEND;
        display_control.line_number := display_control.line_number + 3;
        format_effector := ' ';
      IFEND;
      display_control.line.size := 1;
      display_control.line.value (1) := format_effector;
    ELSE
      FOR i := 1 TO 3 DO
*IF $true(osv$unix)
        format_effector := ' ';
*IFEND

        amp$put_next (display_control.file_id, ^format_effector, 0, ignore_byte_address, status);
        IF NOT status.normal THEN
          RETURN
        IFEND;
      FOREND;
      display_control.line.size := 0;
      display_control.line_number := 1;
    IFEND;
    display_control.data_in_line := TRUE;
    display_control.new_line_started := TRUE;
    display_control.column_number := 1;

  PROCEND clp$reset_for_next_display_page;
?? TITLE := 'clp$vertical_tab_display', EJECT ??
*copy clh$vertical_tab_display

  PROCEDURE [XDCL, #GATE] clp$vertical_tab_display
    (VAR display_control {input, output} : clt$display_control;
         line_number: amt$page_length;
     VAR status: ost$status);


    status.normal := TRUE;
    IF (line_number = display_control.line_number) AND (display_control.data_in_line) THEN
      RETURN;
    IFEND;
    IF line_number <= display_control.line_number THEN
      clp$new_display_page (display_control, status);
      IF (NOT status.normal) OR (line_number <= display_control.line_number) THEN
        RETURN
      IFEND;
    IFEND;
    clp$new_display_line (display_control, line_number - display_control.line_number, status);

  PROCEND clp$vertical_tab_display;
?? TITLE := 'clp$build_path_subtitle ', EJECT ??
*copy clh$build_path_subtitle

  PROCEDURE [XDCL, #GATE] clp$build_path_subtitle
    (VAR path_name {input,output} : fst$file_reference;
         length: 1 .. fsc$max_path_size;
         width: amt$page_width;
     VAR count: 0 .. fsc$max_path_elements;
     VAR display_array: clt$path_display_chunks);

    VAR
      temp_path: ^string ( * ),
      current_character_position: 0 .. fsc$max_path_size,
      break_position: 0 .. fsc$max_path_size,
      current_length: 0 .. fsc$max_path_size,
      remaining_text: 0 .. fsc$max_path_size,
      starting_position: 1 .. fsc$max_path_size;


    current_character_position := 0;
    remaining_text := length;
    count := 0;
    starting_position := 1;

    PUSH temp_path: [clp$trimmed_string_size (path_name)];
    #TRANSLATE (osv$upper_to_lower, path_name, temp_path^);
    path_name := temp_path^;
    WHILE remaining_text > 0 DO
      count := count + 1;
      IF remaining_text <= width THEN
        display_array [count].position := starting_position;
        display_array [count].length := remaining_text;
        RETURN;
      IFEND;

      break_position := 0;
      REPEAT
        current_character_position := current_character_position + 1;
*IF NOT $true(osv$unix)
        IF path_name (current_character_position) = '.' THEN
*ELSE
        IF path_name (current_character_position) = '/' THEN
*IFEND
          break_position := current_character_position;
        IFEND;
      UNTIL (current_character_position - starting_position) >= (width - 2);

      IF break_position > 0 THEN
        current_character_position := break_position;
      IFEND;

      current_length := current_character_position - starting_position;
      display_array [count].position := starting_position;
      display_array [count].length := current_length;
      starting_position := current_character_position;
      remaining_text := length - starting_position + 1;
    WHILEND;

  PROCEND clp$build_path_subtitle;
?? TITLE := 'clp$build_standard_title ', EJECT ??
*copy clh$build_standard_title

  PROCEDURE [XDCL, #GATE] clp$build_standard_title
    (    wide: boolean;
         command_name: string (osc$max_name_size);
     VAR wide_title: string (clc$wide_page_width);
     VAR narrow_title1: string (clc$narrow_page_width);
     VAR narrow_title2: string (clc$narrow_page_width);
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    CONST
      max_date_length = 18,
      max_time_length = 12,
      max_page_number_length = 6;

    VAR
      date_substring: string (max_date_length),
      date_time_string: ost$string,
      time_substring: string (max_time_length),
      os_version: pmt$os_name;


    pmp$get_os_version (os_version, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_date_string (date_time_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    date_substring := date_time_string.value (1, date_time_string.size);
    clp$get_time_string (date_time_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    time_substring := date_time_string.value (1, date_time_string.size);

    IF display_control.include_format_effectors THEN
      IF wide THEN

        wide_title := '';
        wide_title (1, 46) := command_name;
        wide_title (48, 22) := os_version;
        clp$right_justify_string (date_substring);
        wide_title (91, 18) := date_substring;
        clp$right_justify_string (time_substring);
        wide_title (110, 12) := time_substring;

      ELSE

        narrow_title1 := '';
        narrow_title2 := '';
        narrow_title1 (1, 46) := command_name;
        clp$right_justify_string (date_substring);
        narrow_title1 (48, 18) := date_substring;
        narrow_title2 (1, 22) := os_version;
        clp$right_justify_string (time_substring);
        narrow_title2 (54, 12) := time_substring;

      IFEND;
    ELSE
      IF wide THEN

        wide_title := '';
        wide_title (1, 46) := command_name;
        wide_title (48, 40) := os_version;
        wide_title (91, 18) := date_substring;
        wide_title (110, 12) := time_substring;

      ELSE

        narrow_title1 := '';
        narrow_title2 := '';
        narrow_title1 (1, 46) := command_name;
        narrow_title1 (48, 18) := date_substring;
        narrow_title2 (1, 22) := os_version;
        narrow_title2 (48, 12) := time_substring;

      IFEND;
    IFEND;

  PROCEND clp$build_standard_title;

MODEND clm$display_interfaces;
*DECK DECK=CLM$DISPLAY_JOB_HISTORY_COMMAND EXPAND=TRUE
MODULE clm$display_job_history_command;
?? RIGHT := 110 ??
?? NEWTITLE := '  CLM$DISPLAY_JOB_HISTORY_COMMAND' ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc clt$keyword
*copyc fst$file_reference
*copyc jme$job_history_conditions
*copyc jmt$beginning_log_position
*copyc jmt$job_attribute_results
*copyc jmt$job_history_sorted_order
*copyc jmt$job_status_count
*copyc jmt$name
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc ost$name
*copyc ost$user_identification
?? POP ??
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc dfp$get_served_family_names
*copyc jmp$determine_name_kind
*copyc jmp$get_job_attributes
*copyc jmp$process_job_history
*copyc osp$set_status_abnormal
*copyc pmp$get_family_names
*copyc pmp$get_job_names
?? NEWTITLE := '[XDCL] clp$display_job_history_command', EJECT ??

  PROCEDURE [XDCL] clp$display_job_history_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (osm$disjh) display_job_history (
{   job_name, jn: any of
{       key
{         current, all
{       keyend
{       list of name
{     anyend = current
{   login_family, family_name, fn, lf: any of
{       key
{         current, local, all
{       keyend
{       list of name
{     anyend = all
{   trace_job_children, tjc: boolean = false
{   trace_job_output, tjo: boolean = false
{   beginning_log_position, blp: key
{       (session, s)
{       (boi, b)
{       (today, t)
{     keyend = session
{   sorted_order, so: key
{       (time, t)
{       (job, j)
{       (family, f)
{     keyend = family
{   output, o: file = $output
{   input, i: (BY_NAME, HIDDEN) file = $optional
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 19] of clt$pdt_parameter_name,
      parameters: array [1 .. 9] 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 .. 2] 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (7),
      recend,
      type2: 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 .. 3] 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (6),
      recend,
      type7: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
      type9: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 8, 19, 17, 27, 28, 459],
    clc$command, 19, 9, 0, 0, 1, 0, 9, 'OSM$DISJH'], [
    ['BEGINNING_LOG_POSITION         ',clc$nominal_entry, 5],
    ['BLP                            ',clc$abbreviation_entry, 5],
    ['FAMILY_NAME                    ',clc$alias_entry, 2],
    ['FN                             ',clc$alias_entry, 2],
    ['I                              ',clc$abbreviation_entry, 8],
    ['INPUT                          ',clc$nominal_entry, 8],
    ['JN                             ',clc$abbreviation_entry, 1],
    ['JOB_NAME                       ',clc$nominal_entry, 1],
    ['LF                             ',clc$abbreviation_entry, 2],
    ['LOGIN_FAMILY                   ',clc$nominal_entry, 2],
    ['O                              ',clc$abbreviation_entry, 7],
    ['OUTPUT                         ',clc$nominal_entry, 7],
    ['SO                             ',clc$abbreviation_entry, 6],
    ['SORTED_ORDER                   ',clc$nominal_entry, 6],
    ['STATUS                         ',clc$nominal_entry, 9],
    ['TJC                            ',clc$abbreviation_entry, 3],
    ['TJO                            ',clc$abbreviation_entry, 4],
    ['TRACE_JOB_CHILDREN             ',clc$nominal_entry, 3],
    ['TRACE_JOB_OUTPUT               ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 122,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 159,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 5
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 6
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 7
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 8
    [6, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 9
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['CURRENT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'current'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['CURRENT                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['LOCAL                          ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 4
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [6], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['BOI                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SESSION                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['TODAY                          ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ,
    'session'],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [6], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FAMILY                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['TIME                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'family'],
{ PARAMETER 7
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 8
    [[1, 0, clc$file_type]],
{ PARAMETER 9
    [[1, 0, clc$status_type]]];

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

    CONST
      p$job_name = 1,
      p$login_family = 2,
      p$trace_job_children = 3,
      p$trace_job_output = 4,
      p$beginning_log_position = 5,
      p$sorted_order = 6,
      p$output = 7,
      p$input = 8,
      p$status = 9;

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

?? POP ??

    VAR
      current_control_user: ost$user_identification,
      current_login_user: ost$user_identification,
      display_output_history_command: boolean,
      family_names_requested: ^pmt$family_name_list,
      foreign_count: integer,
      get_attribute_p: ^jmt$job_attribute_results,
      index: integer,
      input_file: ^fst$file_reference,
      job_name: jmt$name,
      job_names_requested: ^array [1 .. * ] of ost$name,
      local_families: ^pmt$family_name_list,
      name_count: pmt$family_name_count,
      name_list: ^clt$data_value,
      number_of_jobs_found: jmt$job_status_count,
      number_of_names: clt$list_size,
      output_file_name: ^fst$file_reference,
      output_files_requested: ^array [1 .. * ] of jmt$name,
      requested_sort_order: jmt$job_history_sorted_order,
      start_log_search: jmt$beginning_log_position,
      served_families: ^pmt$family_name_list,
      served_family_count: pmt$family_name_count,
      ssn: jmt$system_supplied_name,
      trace_all_jobs: boolean,
      trace_all_output: boolean,
      trace_job_children: boolean,
      trace_job_output: boolean,
      ujn: jmt$user_supplied_name;


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

{ control user and login user

    PUSH get_attribute_p: [1 .. 4];
    get_attribute_p^ [1].key := jmc$control_user;
    get_attribute_p^ [2].key := jmc$control_family;
    get_attribute_p^ [3].key := jmc$login_user;
    get_attribute_p^ [4].key := jmc$login_family;
    jmp$get_job_attributes (get_attribute_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    trace_all_jobs := FALSE;
    current_control_user.user := get_attribute_p^ [1].control_user;
    current_control_user.family := get_attribute_p^ [2].control_family;
    current_login_user.user := get_attribute_p^ [3].login_user;
    current_login_user.family := get_attribute_p^ [4].login_family;

    IF ((pvt [p$job_name].value^.kind = clc$keyword) AND (pvt [p$job_name].value^.keyword_value = 'CURRENT'))
          THEN
      PUSH job_names_requested: [1 .. 1];
      pmp$get_job_names (ujn, ssn, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      job_names_requested^ [1] := ssn;
    ELSEIF ((pvt [p$job_name].value^.kind = clc$keyword) AND (pvt [p$job_name].value^.keyword_value = 'ALL'))
          THEN
      trace_all_jobs := TRUE;
      job_names_requested := NIL;
    ELSE
      number_of_names := clp$count_list_elements (pvt [p$job_name].value);
      PUSH job_names_requested: [1 .. number_of_names];
      name_list := pvt [p$job_name].value;
      FOR index := 1 TO number_of_names DO
        jmp$determine_name_kind (name_list^.element_value^.name_value, job_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF job_name.kind = jmc$system_supplied_name THEN
          job_names_requested^ [index] := job_name.system_supplied_name;
        ELSE {user supplied name}
          job_names_requested^ [index] := job_name.user_supplied_name;
        IFEND;
        name_list := name_list^.link;
      FOREND;
    IFEND;


    IF (pvt [p$sorted_order].value^.keyword_value = 'TIME') THEN
      requested_sort_order := jmc$sort_by_time;
    ELSEIF (pvt [p$sorted_order].value^.keyword_value = 'JOB') THEN
      requested_sort_order := jmc$sort_by_job;
    ELSE
      requested_sort_order := jmc$sort_by_family;
    IFEND;

{ Processing family name value

    foreign_count := 0;
    IF (pvt [p$login_family].value^.kind = clc$keyword) THEN
      IF (pvt [p$login_family].value^.keyword_value = 'CURRENT') THEN
        PUSH family_names_requested: [1 .. 1];
        family_names_requested^ [1] := current_login_user.family;
      ELSE
        name_count := 10; { arbitrary constant greater (?) than the number of families }

{ on the system

        IF (pvt [p$login_family].value^.keyword_value = 'ALL') THEN
          foreign_count := 1;
        IFEND;

      /get_local_family_list/
        REPEAT

          PUSH family_names_requested: [1 .. (name_count + foreign_count)];
          pmp$get_family_names (family_names_requested^, name_count, status);
          IF NOT status.normal THEN
            IF status.condition = pme$result_array_too_small THEN
              CYCLE /get_local_family_list/;

{ if the number of families exceeds the value in name_count (10) we will retry the
{ interface pmp$get_family_names using the new value in name_count that was returned

            IFEND;
            RETURN;
          IFEND;
        UNTIL status.normal;
        IF (foreign_count = 1) THEN
          name_count := name_count + 1;
          family_names_requested^ [name_count] := osc$null_name;
        IFEND;

        served_family_count := 5;

      /get_served_family_list/
        REPEAT
          PUSH served_families: [1 .. served_family_count];
          dfp$get_served_family_names (served_families^, served_family_count, status);
          IF NOT status.normal THEN
            IF status.condition = pme$result_array_too_small THEN
              CYCLE /get_served_family_list/;

{ if the number of families exceeds the value in served_family_count (5) we will retry the
{ interface dfp$get_served_family_names using the new value in served_family_count that was returned

            IFEND;
            RETURN;
          IFEND;
        UNTIL status.normal;

        IF served_family_count = 0 THEN

{ We have all of the families.

        ELSEIF (served_family_count + name_count) <= UPPERBOUND (family_names_requested^) THEN
          FOR index := (name_count + 1) TO (name_count + served_family_count) DO
            family_names_requested^ [index] := served_families^ [index - name_count];
          FOREND;
        ELSE
          local_families := family_names_requested;
          PUSH family_names_requested: [1 .. (name_count + served_family_count)];
          FOR index := 1 TO name_count DO
            family_names_requested^ [index] := local_families^ [index];
          FOREND;
          FOR index := (name_count + 1) TO (name_count + served_family_count) DO
            family_names_requested^ [index] := served_families^ [index - name_count];
          FOREND;
        IFEND;
      IFEND;
    ELSE
      name_list := pvt [p$login_family].value;
      number_of_names := clp$count_list_elements (pvt [p$login_family].value);
      PUSH family_names_requested: [1 .. number_of_names];
      family_names_requested^ [1] := name_list^.element_value^.name_value;
      index := 2;
      WHILE index <= number_of_names DO
        name_list := name_list^.link;
        family_names_requested^ [index] := name_list^.element_value^.name_value;
        index := index + 1;
      WHILEND;
    IFEND;

{ PROCESSING BEGINNING_LOG_POSITION PARAMETER

    IF (pvt [p$beginning_log_position].value^.keyword_value = 'TODAY') THEN
      start_log_search := jmc$today;
    ELSEIF (pvt [p$beginning_log_position].value^.keyword_value = 'BOI') THEN
      start_log_search := jmc$boi;
    ELSE
      start_log_search := jmc$session;
    IFEND;

{ PROCESSING  OUTPUT PARAMETER

    output_file_name := pvt [p$output].value^.file_value;

{ Process TRACE JOB CHILDREN parameter.

    trace_job_children := pvt [p$trace_job_children].value^.boolean_value.value;

{ Process TRACE JOB OUTPUT parameter.

    trace_job_output := pvt [p$trace_job_output].value^.boolean_value.value;

{ Process INPUT parameter

    IF pvt [p$input].specified THEN
      input_file := pvt [p$input].value^.file_value;
    ELSE;
      input_file := NIL;
    IFEND;
    display_output_history_command := FALSE;
    trace_all_output := (trace_all_jobs AND trace_job_output);
    output_files_requested := NIL;


    jmp$process_job_history (current_control_user, current_login_user, requested_sort_order,
          trace_job_children, trace_job_output, trace_all_jobs, trace_all_output,
          display_output_history_command, job_names_requested, family_names_requested, output_files_requested,
          start_log_search, output_file_name, input_file, status);

  PROCEND clp$display_job_history_command;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] clp$display_output_history_cmd', EJECT ??

  PROCEDURE [XDCL] clp$display_output_history_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{
{ PROCEDURE (osm$disoh) display_output_history_pdt (
{   output_file_name, ofn: any of
{       key
{         all
{       keyend
{       list of name
{     anyend = all
{   job_name, jn: any of
{       key
{         current, all
{       keyend
{       list of name
{     anyend = current
{   login_family, family_name, fn, lf: any of
{       key
{         current, local, all
{       keyend
{       list of name
{     anyend = all
{   beginning_log_position, blp: key
{       (session, s)
{       (boi, b)
{       (today, t)
{     keyend = session
{   sorted_order, so: key
{       (time, t)
{       (job, j)
{       (family, f)
{     keyend = family
{   output, o: file = $output
{   input, i: (BY_NAME, HIDDEN) file = $optional
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 17] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: 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 .. 2] 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (7),
      recend,
      type3: 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 .. 3] 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (6),
      recend,
      type6: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 8, 26, 13, 55, 46, 848],
    clc$command, 17, 8, 0, 0, 1, 0, 8, 'OSM$DISOH'], [
    ['BEGINNING_LOG_POSITION         ',clc$nominal_entry, 4],
    ['BLP                            ',clc$abbreviation_entry, 4],
    ['FAMILY_NAME                    ',clc$alias_entry, 3],
    ['FN                             ',clc$alias_entry, 3],
    ['I                              ',clc$abbreviation_entry, 7],
    ['INPUT                          ',clc$nominal_entry, 7],
    ['JN                             ',clc$abbreviation_entry, 2],
    ['JOB_NAME                       ',clc$nominal_entry, 2],
    ['LF                             ',clc$abbreviation_entry, 3],
    ['LOGIN_FAMILY                   ',clc$nominal_entry, 3],
    ['O                              ',clc$abbreviation_entry, 6],
    ['OFN                            ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 6],
    ['OUTPUT_FILE_NAME               ',clc$nominal_entry, 1],
    ['SO                             ',clc$abbreviation_entry, 5],
    ['SORTED_ORDER                   ',clc$nominal_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 8]],
    [
{ PARAMETER 1
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 122,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 159,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 6
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 7
    [6, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 8
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['CURRENT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'current'],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['CURRENT                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['LOCAL                          ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [6], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['BOI                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SESSION                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['TODAY                          ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ,
    'session'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [6], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FAMILY                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['TIME                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'family'],
{ PARAMETER 6
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 7
    [[1, 0, clc$file_type]],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

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

    CONST
      p$output_file_name = 1,
      p$job_name = 2,
      p$login_family = 3,
      p$beginning_log_position = 4,
      p$sorted_order = 5,
      p$output = 6,
      p$input = 7,
      p$status = 8;

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

    VAR
      current_control_user: ost$user_identification,
      current_login_user: ost$user_identification,
      display_output_history_command: boolean,
      family_names_requested: ^pmt$family_name_list,
      foreign_count: integer,
      get_attribute_p: ^jmt$job_attribute_results,
      index: integer,
      input_file: ^fst$file_reference,
      job_name: jmt$name,
      job_names_requested: ^array [1 .. * ] of ost$name,
      local_families: ^pmt$family_name_list,
      name_count: pmt$family_name_count,
      name_list: ^clt$data_value,
      number_of_jobs_found: jmt$job_status_count,
      number_of_names: clt$list_size,
      output_file_name: ^fst$file_reference,
      output_files_requested: ^array [1 .. * ] of jmt$name,
      requested_sort_order: jmt$job_history_sorted_order,
      start_log_search: jmt$beginning_log_position,
      served_families: ^pmt$family_name_list,
      served_family_count: pmt$family_name_count,
      ssn: jmt$system_supplied_name,
      trace_all_jobs: boolean,
      trace_all_output: boolean,
      trace_job_children: boolean,
      trace_job_output: boolean,
      ujn: jmt$user_supplied_name;


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

{ get control user and login user

    PUSH get_attribute_p: [1 .. 4];
    get_attribute_p^ [1].key := jmc$control_user;
    get_attribute_p^ [2].key := jmc$control_family;
    get_attribute_p^ [3].key := jmc$login_user;
    get_attribute_p^ [4].key := jmc$login_family;
    jmp$get_job_attributes (get_attribute_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    trace_all_jobs := FALSE;
    current_control_user.user := get_attribute_p^ [1].control_user;
    current_control_user.family := get_attribute_p^ [2].control_family;
    current_login_user.user := get_attribute_p^ [3].login_user;
    current_login_user.family := get_attribute_p^ [4].login_family;


    IF ((pvt [p$job_name].value^.kind = clc$keyword) AND (pvt [p$job_name].value^.keyword_value = 'CURRENT'))
          THEN
      PUSH job_names_requested: [1 .. 1];
      pmp$get_job_names (ujn, ssn, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      job_names_requested^ [1] := ssn;
    ELSEIF ((pvt [p$job_name].value^.kind = clc$keyword) AND (pvt [p$job_name].value^.keyword_value = 'ALL'))
          THEN
      trace_all_jobs := TRUE;
      job_names_requested := NIL;
    ELSE
      number_of_names := clp$count_list_elements (pvt [p$job_name].value);
      PUSH job_names_requested: [1 .. number_of_names];
      name_list := pvt [p$job_name].value;
      FOR index := 1 TO number_of_names DO
        jmp$determine_name_kind (name_list^.element_value^.name_value, job_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF job_name.kind = jmc$system_supplied_name THEN
          job_names_requested^ [index] := job_name.system_supplied_name;
        ELSE {user supplied name}
          job_names_requested^ [index] := job_name.user_supplied_name;
        IFEND;
        name_list := name_list^.link;
      FOREND;
    IFEND;


    IF (pvt [p$sorted_order].value^.keyword_value = 'TIME') THEN
      requested_sort_order := jmc$sort_by_time;
    ELSEIF (pvt [p$sorted_order].value^.keyword_value = 'JOB') THEN
      requested_sort_order := jmc$sort_by_job;
    ELSE
      requested_sort_order := jmc$sort_by_family;
    IFEND;

{ If Family name is keyword ALL then the following code is required.
{  Processing family name value

    foreign_count := 0;
    IF (pvt [p$login_family].value^.kind = clc$keyword) THEN
      IF (pvt [p$login_family].value^.keyword_value = 'CURRENT') THEN
        PUSH family_names_requested: [1 .. 1];
        family_names_requested^ [1] := current_login_user.family;
      ELSE
        name_count := 10; { arbitrary constant greater (?) than the number of families }

{ on the system

        IF (pvt [p$login_family].value^.keyword_value = 'ALL') THEN
          foreign_count := 1;
        IFEND;

      /get_local_family_list/
        REPEAT

          PUSH family_names_requested: [1 .. (name_count + foreign_count)];
          pmp$get_family_names (family_names_requested^, name_count, status);
          IF NOT status.normal THEN
            IF status.condition = pme$result_array_too_small THEN
              CYCLE /get_local_family_list/;

{ if the number of families exceeds the value in name_count (10) we will retry the
{ interface pmp$get_family_names using the new value in name_count that was returned

            IFEND;
            RETURN;
          IFEND;
        UNTIL status.normal;
        IF (foreign_count = 1) THEN
          name_count := name_count + 1;
          family_names_requested^ [name_count] := osc$null_name;
        IFEND;

        served_family_count := 5;

      /get_served_family_list/
        REPEAT
          PUSH served_families: [1 .. served_family_count];
          dfp$get_served_family_names (served_families^, served_family_count, status);
          IF NOT status.normal THEN
            IF status.condition = pme$result_array_too_small THEN
              CYCLE /get_served_family_list/;

{ if the number of families exceeds the value in served_family_count (5) we will retry the
{ interface dfp$get_served_family_names using the new value in served_family_count that was returned

            IFEND;
            RETURN;
          IFEND;
        UNTIL status.normal;

        IF served_family_count = 0 THEN

{ We have all of the families.

        ELSEIF (served_family_count + name_count) <= UPPERBOUND (family_names_requested^) THEN
          FOR index := (name_count + 1) TO (name_count + served_family_count) DO
            family_names_requested^ [index] := served_families^ [index - name_count];
          FOREND;
        ELSE
          local_families := family_names_requested;
          PUSH family_names_requested: [1 .. (name_count + served_family_count)];
          FOR index := 1 TO name_count DO
            family_names_requested^ [index] := local_families^ [index];
          FOREND;
          FOR index := (name_count + 1) TO (name_count + served_family_count) DO
            family_names_requested^ [index] := served_families^ [index - name_count];
          FOREND;
        IFEND;
      IFEND;
    ELSE
      name_list := pvt [p$login_family].value;
      number_of_names := clp$count_list_elements (pvt [p$login_family].value);
      PUSH family_names_requested: [1 .. number_of_names];
      family_names_requested^ [1] := name_list^.element_value^.name_value;
      index := 2;
      WHILE index <= number_of_names DO
        name_list := name_list^.link;
        family_names_requested^ [index] := name_list^.element_value^.name_value;
        index := index + 1;
      WHILEND;
    IFEND;

{ PROCESSING BEGINNING_LOG_POSITION PARAMETER

    IF (pvt [p$beginning_log_position].value^.keyword_value = 'TODAY') THEN
      start_log_search := jmc$today;
    ELSEIF (pvt [p$beginning_log_position].value^.keyword_value = 'BOI') THEN
      start_log_search := jmc$boi;
    ELSE
      start_log_search := jmc$session;
    IFEND;

{ PROCESSING  OUTPUT PARAMETER

    output_file_name := pvt [p$output].value^.file_value;

    trace_job_children := FALSE;

{ Process INPUT parameter

    IF pvt [p$input].specified THEN
      input_file := pvt [p$input].value^.file_value;
    ELSE;
      input_file := NIL;
    IFEND;

{ Processing Output parameter value

    IF ((pvt [p$output_file_name].value^.kind = clc$keyword) AND
          (pvt [p$output_file_name].value^.keyword_value = 'ALL')) THEN
      trace_all_output := TRUE;
    ELSE
      number_of_names := clp$count_list_elements (pvt [p$output_file_name].value);
      name_list := pvt [p$output_file_name].value;
      trace_all_output := FALSE;
      PUSH output_files_requested: [1 .. number_of_names];
      FOR index := 1 TO number_of_names DO
        jmp$determine_name_kind (name_list^.element_value^.name_value, job_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        output_files_requested^ [index] := job_name;
        name_list := name_list^.link;
      FOREND;
    IFEND;

    trace_job_output := TRUE;
    display_output_history_command := TRUE;

    jmp$process_job_history (current_control_user, current_login_user, requested_sort_order,
          trace_job_children, trace_job_output, trace_all_jobs, trace_all_output,
          display_output_history_command, job_names_requested, family_names_requested, output_files_requested,
          start_log_search, output_file_name, input_file, status);

  PROCEND clp$display_output_history_cmd;

MODEND clm$display_job_history_command;
*DECK DECK=CLM$DISPLAY_SCL_PROC_PARAMETERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Display Parameters of SCL Procedure in Object Library' ??
MODULE clm$display_scl_proc_parameters;

{
{ PURPOSE:
{   This module contains the procedure that displays the parameters for an
{   SCL Procedure that resides on an object library.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$max_proc_names
*copyc clc$proc_pdt_parameter_limits
*copyc cle$ecc_command_processing
*copyc cle$expecting_proc
*copyc clt$display_control
*copyc clt$scl_procedure
*copyc clt$scl_procedure_header
*copyc ost$status
?? POP ??
*copyc clp$append_status_parse_state
*copyc clp$get_work_area
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*copyc clp$internal_convert_to_string
*copyc clp$internal_generate_old_pdt
*copyc clp$put_display
*copyc clp$scan_non_space_lexical_unit
*copyc clp$translate_pdt
*copyc clp$unbundle_pdt
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper

?? TITLE := 'clp$display_scl_proc_parameters', EJECT ??

  PROCEDURE [XDCL] clp$display_scl_proc_parameters
    (VAR display_control {input, output} : clt$display_control;
         scl_procedure: ^clt$scl_procedure;
     VAR status: ost$status);

    VAR
      local_scl_procedure: ^clt$scl_procedure,
      original_work_area: ^clt$work_area,
      pdt: clt$unbundled_pdt,
      representation: ^clt$data_representation,
      scl_procedure_header: ^clt$scl_procedure_header,
      version: clt$declaration_version,
      work_area: ^^clt$work_area;

?? NEWTITLE := 'format_pdt', EJECT ??

    PROCEDURE [INLINE] format_pdt;

      VAR
        request: clt$convert_to_string_request;


      request.initial_indentation := 2;
      request.continuation_indentation := 8;
      request.max_string := display_control.page_width;
      request.include_advanced_items := TRUE;
      request.include_hidden_items := TRUE;
      request.kind := clc$convert_unbundled_pdt;
      request.multi_line_pdt_format := TRUE;
      request.parameter_starts_line := TRUE;
      request.individual_parameter := FALSE;
      request.individual_parameter_number := LOWERVALUE (clt$parameter_number);
      request.include_header := FALSE;
      request.command_or_function_name := osc$null_name;
      request.aliases := NIL;
      request.availability := clc$normal_usage_entry;
      request.command_or_function_scope := clc$xdcl_command_or_function;
      request.pdt := ^pdt;
      request.pvt := NIL;
      request.symbolic_pdt_qualifiers_area := NIL;
      request.include_implementation_info := TRUE;

      clp$internal_convert_to_string (request, work_area^, representation, status);

    PROCEND format_pdt;
?? TITLE := 'prepare_old_pdt', EJECT ??

    PROCEDURE prepare_old_pdt;

      VAR
        end_of_input: boolean,
        extra_info_area: ^SEQ (REP clc$proc_pdt_info_area_size of cell),
        ignore_application_type_present: boolean,
        lexical_units_work_area: ^clt$work_area,
        line: ost$string,
        name: ost$name,
        old_pdt: clt$parameter_descriptor_table,
        parameter_area: ^SEQ (REP clc$max_proc_pdt_parameters of clt$parameter_descriptor),
        parameter_name_area: ^SEQ (REP clc$max_proc_pdt_param_names of clt$parameter_name_descriptor),
        parse: clt$parse_state,
        proc_name_area: ^SEQ (REP clc$max_proc_names of ost$name),
        proc_names: ^clt$proc_names,
        symbolic_parameter_area: ^SEQ (REP clc$max_proc_pdt_parameters of clt$symbolic_parameter),
        symbolic_parameters: ^clt$symbolic_parameters;

?? NEWTITLE := 'get_command_line', EJECT ??

      PROCEDURE get_command_line
        (VAR line: ost$string;
         VAR end_of_input: boolean;
         VAR status: ost$status);

        VAR
          line_continued: boolean,
          continuation_line: ost$string;


        get_data_line (line, end_of_input, status);
        IF (NOT status.normal) OR end_of_input THEN
          RETURN;
        IFEND;

        IF (line.size >= 2) AND (line.value (line.size - 1, 2) = '..') THEN
          line.size := line.size - 2;
          WHILE (line.size > 0) AND (line.value (line.size) = '.') DO
            line.size := line.size - 1;
          WHILEND;
          REPEAT
            get_data_line (continuation_line, end_of_input, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF end_of_input THEN
              osp$set_status_abnormal ('CL', cle$expecting_continuation_line, '', status);
              RETURN;
            IFEND;
            line_continued := (continuation_line.size >= 2) AND
                  (continuation_line.value (continuation_line.size - 1, 2) = '..');
            IF line_continued THEN
              continuation_line.size := continuation_line.size - 2;
              WHILE (continuation_line.size > 0) AND (continuation_line.value (continuation_line.size) =
                    '.') DO
                continuation_line.size := continuation_line.size - 1;
              WHILEND;
            IFEND;
            IF (line.size + continuation_line.size) > osc$max_string_size THEN
              osp$set_status_abnormal ('CL', cle$continued_line_too_long, '', status);
              RETURN;
            IFEND;
            line.value (line.size + 1, continuation_line.size) :=
                  continuation_line.value (1, continuation_line.size);
            line.size := line.size + continuation_line.size;
          UNTIL NOT line_continued;
        IFEND;

      PROCEND get_command_line;
?? TITLE := 'get_data_line', EJECT ??

      PROCEDURE get_data_line
        (VAR line: ost$string;
         VAR end_of_input: boolean;
         VAR status: ost$status);

        VAR
          procedure_line_size: ^ost$string_size,
          procedure_line: ^string ( * );


        status.normal := TRUE;
        end_of_input := TRUE;
        NEXT procedure_line_size IN local_scl_procedure;
        IF procedure_line_size = NIL THEN
          RETURN;
        IFEND;
        NEXT procedure_line: [procedure_line_size^] IN local_scl_procedure;
        IF procedure_line = NIL THEN
          RETURN;
        IFEND;
        line.size := procedure_line_size^;
        line.value := procedure_line^;
        end_of_input := FALSE;

      PROCEND get_data_line;
?? TITLE := 'get_old_proc_line', EJECT ??

      PROCEDURE get_old_proc_line
        (VAR parse: clt$parse_state;
         VAR end_of_input: boolean;
         VAR status: ost$status);

        VAR
          lexical_units: ^clt$lexical_units;


        get_command_line (line, end_of_input, status);
        IF (NOT status.normal) OR end_of_input THEN
          RETURN;
        IFEND;

        RESET lexical_units_work_area;
        clp$identify_lexical_units (^line.value (1, line.size), lexical_units_work_area, lexical_units,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$initialize_parse_state (^line.value (1, line.size), lexical_units, parse);

      PROCEND get_old_proc_line;
?? OLDTITLE, EJECT ??

      PUSH lexical_units_work_area: [[REP osc$max_string_size + clc$lexical_units_size_pad OF cell]];

      PUSH proc_name_area;
      PUSH parameter_name_area;
      PUSH parameter_area;
      PUSH symbolic_parameter_area;
      PUSH extra_info_area;

      REPEAT
        get_old_proc_line (parse, end_of_input, status);
        IF (NOT status.normal) OR end_of_input THEN
          RETURN;
        IFEND;
        clp$scan_non_space_lexical_unit (parse);
      UNTIL parse.unit.kind <> clc$lex_end_of_line;

      IF parse.unit.kind = clc$lex_name THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        IF name <> 'PROC' THEN
          osp$set_status_abnormal ('CL', cle$expecting_proc, 'PROC', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
          RETURN;
        IFEND;
      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_proc, 'PROC', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        RETURN;
      IFEND;

      clp$internal_generate_old_pdt ('PROC', ^get_old_proc_line, work_area^, parse, proc_name_area^,
            parameter_name_area^, parameter_area^, symbolic_parameter_area^, extra_info_area^, proc_names,
            old_pdt, symbolic_parameters, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$translate_pdt (old_pdt, FALSE, FALSE, NIL, NIL, NIL, work_area^, ignore_application_type_present,
            pdt, status);

    PROCEND prepare_old_pdt;
?? TITLE := 'prepare_pdt', EJECT ??

    PROCEDURE [INLINE] prepare_pdt;

      VAR
        parameter_description_table: ^clt$parameter_description_table;


      parameter_description_table := #PTR (scl_procedure_header^.parameter_description_table,
            local_scl_procedure^);
      RESET parameter_description_table;

      clp$unbundle_pdt (parameter_description_table, work_area^, pdt, status);

    PROCEND prepare_pdt;
?? TITLE := 'put_representation', EJECT ??

    PROCEDURE [INLINE] put_representation;

      VAR
        representation_line: ^clt$string_value,
        representation_line_count: ^clt$data_representation_count,
        representation_line_index: clt$data_representation_count,
        representation_line_size: ^clt$string_size;


      RESET representation;
      NEXT representation_line_count IN representation;

      FOR representation_line_index := 1 TO representation_line_count^ DO
        NEXT representation_line_size IN representation;
        NEXT representation_line: [representation_line_size^] IN representation;
        clp$put_display (display_control, representation_line^, clc$no_trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

    PROCEND put_representation;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    local_scl_procedure := scl_procedure;
    RESET local_scl_procedure;

    NEXT scl_procedure_header IN local_scl_procedure;
    IF (scl_procedure_header = NIL) OR (scl_procedure_header^.identifying_first_byte <>
          UPPERVALUE (scl_procedure_header^.identifying_first_byte)) THEN
      version := 0;
      RESET local_scl_procedure;
    ELSE
      version := scl_procedure_header^.version;
    IFEND;

    clp$get_work_area (#RING (^work_area), work_area, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    original_work_area := work_area^;

  /display_scl_proc_parameters/
    BEGIN
      IF version = 0 THEN
        prepare_old_pdt;
      ELSE
        prepare_pdt;
      IFEND;
      IF NOT status.normal THEN
        EXIT /display_scl_proc_parameters/;
      IFEND;

      format_pdt;
      IF NOT status.normal THEN
        EXIT /display_scl_proc_parameters/;
      IFEND;

      put_representation;
    END /display_scl_proc_parameters/;

    work_area^ := original_work_area;

  PROCEND clp$display_scl_proc_parameters;

MODEND clm$display_scl_proc_parameters;
*DECK DECK=CLM$DISPLAY_SYSTEM_DATA EXPAND=TRUE
?? RIGHT := 110 ??

MODULE clm$display_system_data;

{
{PURPOSE:
{        This module is the command language interface to display
{        system and job statistics.
{
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmt$dispatching_priority
*copyc jmt$job_scheduler_statistics
*copyc mmt$page_frame_queue_id
*copyc ost$data_id
*copyc oss$job_paged_literal
*copyc syc$monitor_request_codes
*copyc ost$stack_frame_save_area
*copyc pmt$condition_information
*copyc sye$command_processor_errors
?? POP ??
*copyc jsv$swap_status_id_array

  VAR
    sys_data_id_set: [READ, STATIC, oss$job_paged_literal] ost$data_id_set :=
      [osc$page_faults, osc$mtr_requests, osc$aging_statistics,
      osc$jm_mm_statistics, osc$swap_statistics, osc$cpu_statistics, osc$pio_stats,
      osc$job_sched_statistics, osc$swap_file_statistics],
    job_data_id_set: [READ, STATIC, oss$job_paged_literal] ost$data_id_set := [osc$job_data];

*copyc avp$configuration_administrator
*copyc avp$system_administrator
*copyc clp$convert_integer_to_rjstring
*copyc clp$open_display
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$close_display
*copyc clp$scan_parameter_list
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$put_display
*copyc clv$nil_display_control
*copyc pmp$get_time
*copyc pmp$get_date
*copyc osp$get_pp_unit_count
*copyc osp$get_page_stats
*copyc osp$get_paging_stats
*copyc osp$get_mtr_stats
*copyc osp$get_aging_stats
*copyc osp$get_swap_stats
*copyc osp$get_swap_file_statistics
*copyc osp$get_cpu_stats
*copyc osp$get_job_stats
*copyc osp$get_jm_mm_stats
*copyc osp$get_sched_stats
*copyc osp$get_pio_pp_stats
*copyc osp$get_pio_unit_stats
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
*copyc osp$reset_maximum_time
*copyc osp$set_status_abnormal
*copyc clt$path_display_chunks
*copyc clp$build_standard_title
*copyc clp$reset_for_next_display_page
*copyc clp$convert_integer_to_string
*copyc ost$page_size
*copyc osc$processor_defined_registers
?? EJECT, TITLE := 'PROCEDURE clp$display_system_data_command' ??

  PROCEDURE [XDCL] clp$display_system_data_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? RIGHT := 110 ??

{      PDT display_system_data_pdt(
{          display_option, display_options, do : list of key page_faults, pf, monitor_requests, mr, ..
{            cpu_statistics, cs, pio_statistics, ps, aging_statistics, as, jm_mm_statistics, jms, ..
{            swap_statistics, ss, job_sched_statistics, jss, swap_file_statistics, sfs, all = all
{          display_format, df : key incremental, i, total, t = incremental
{          reset_maximum_time, rmt : boolean = false
{          output, o : file = $output
{          status)

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

  VAR
    display_system_data_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
  ^display_system_data_pdt_names, ^display_system_data_pdt_params];

  VAR
    display_system_data_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 10] of
  clt$parameter_name_descriptor := [['DISPLAY_OPTION', 1], ['DISPLAY_OPTIONS', 1], ['DO', 1], [
  'DISPLAY_FORMAT', 2], ['DF', 2], ['RESET_MAXIMUM_TIME', 3], ['RMT', 3], ['OUTPUT', 4], ['O', 4], ['STATUS',
  5]];

  VAR
    display_system_data_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of
  clt$parameter_descriptor := [

{ DISPLAY_OPTION DISPLAY_OPTIONS DO }
    [[clc$optional_with_default, ^display_system_data_pdt_dv1], 1, clc$max_value_sets,1, 1,
  clc$value_range_not_allowed, [^display_system_data_pdt_kv1, clc$keyword_value]],

{ DISPLAY_FORMAT DF }
    [[clc$optional_with_default, ^display_system_data_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [^
  display_system_data_pdt_kv2, clc$keyword_value]],

{ RESET_MAXIMUM_TIME RMT }
    [[clc$optional_with_default, ^display_system_data_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed,
  [NIL, clc$boolean_value]],

{ OUTPUT O }
    [[clc$optional_with_default, ^display_system_data_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed,
  [NIL, clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    display_system_data_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 19] of ost$name := [
  'PAGE_FAULTS','PF','MONITOR_REQUESTS','MR','CPU_STATISTICS','CS','PIO_STATISTICS','PS','AGING_STATISTICS',
  'AS','JM_MM_STATISTICS','JMS','SWAP_STATISTICS','SS','JOB_SCHED_STATISTICS','JSS','SWAP_FILE_STATISTICS',
  'SFS','ALL'];

  VAR
    display_system_data_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := [
  'INCREMENTAL','I','TOTAL','T'];

  VAR
    display_system_data_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

  VAR
    display_system_data_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (11) := 'incremental';

  VAR
    display_system_data_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';

  VAR
    display_system_data_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$output';

?? FMT (FORMAT := ON) ??
?? POP ??
    display_data (parameter_list, display_system_data_pdt, sys_data_id_set, status);

  PROCEND clp$display_system_data_command;

?? EJECT, TITLE := 'PROCEDURE clp$display_job_data_command' ??

  PROCEDURE [XDCL] clp$display_job_data_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT display_job_data_pdt(
{ display_option, display_options, do: KEY job_data = job_data
{ display_format, df: KEY incremental, i, total, t = incremental
{ output, o: FILE = $output
{ STATUS)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_job_data_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^display_job_data_pdt_names, ^display_job_data_pdt_params];

    VAR
      display_job_data_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 8] of
        clt$parameter_name_descriptor := [['DISPLAY_OPTION', 1], ['DISPLAY_OPTIONS', 1], ['DO', 1], [
        'DISPLAY_FORMAT', 2], ['DF', 2], ['OUTPUT', 3], ['O', 3], ['STATUS', 4]];

    VAR
      display_job_data_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
        clt$parameter_descriptor := [

{ DISPLAY_OPTION DISPLAY_OPTIONS DO }
      [[clc$optional_with_default, ^display_job_data_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
        [^display_job_data_pdt_kv1, clc$keyword_value]],

{ DISPLAY_FORMAT DF }
      [[clc$optional_with_default, ^display_job_data_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
        [^display_job_data_pdt_kv2, clc$keyword_value]],

{ OUTPUT O }
      [[clc$optional_with_default, ^display_job_data_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      display_job_data_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := [
        'JOB_DATA'];

    VAR
      display_job_data_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := [
        'INCREMENTAL', 'I', 'TOTAL', 'T'];

    VAR
      display_job_data_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (8) := 'job_data';

    VAR
      display_job_data_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (11) := 'incremental';

    VAR
      display_job_data_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$output';

?? POP ??

    display_data (parameter_list, display_job_data_pdt, job_data_id_set, status);

  PROCEND clp$display_job_data_command;


?? EJECT, TITLE := 'PROCEDURE display_data' ??

  PROCEDURE display_data (parameter_list: clt$parameter_list;
        display_data_pdt: clt$parameter_descriptor_table;
        id_set: ost$data_id_set;
    VAR status: ost$status);


    CONST
      table_length = 19;

    TYPE
      converted_names = record
        name: string (20),
        id: ost$data_id,
        title_name: string (30),
        data_title: string (20),
      recend,
      option_set = set of ost$data_id;

    VAR
      i,
      j: integer,
      count: 0 .. clc$max_value_sets,
      k: ost$data_id,
      table: [STATIC, READ, oss$job_paged_literal] array [1 .. table_length] of converted_names :=
{              } [['PAGE_FAULTS', osc$page_faults, 'PAGE_FAULTS, PAGING STATISTICS', ' system data- '],
{              } ['PF', osc$page_faults, 'PAGE_FAULTS, PAGING STATISTICS', ' system data- '],
{              } ['MONITOR_REQUESTS', osc$mtr_requests, 'MONITOR_REQUESTS', ' system data- '],
{              } ['MR', osc$mtr_requests, 'MONITOR_REQUESTS', ' system data- '],
{              } ['AGING_STATISTICS', osc$aging_statistics, 'AGING_STATISTICS', ' system data- '],
{              } ['AS', osc$aging_statistics, 'AGING_STATISTICS', ' system data- '],
{              } ['JM_MM_STATISTICS', osc$jm_mm_statistics, 'JOB/MEMORY STATISTICS', ' system data- '],
{              } ['JMS', osc$jm_mm_statistics, 'JOB/MEMORY STATISTICS', ' system_data- '],
{              } ['JOB_DATA', osc$job_data, '    ', ' job data- '],
{              } ['SWAP_STATISTICS', osc$swap_statistics, 'SWAPPING STATISTICS', ' system data- '],
{              } ['SS', osc$swap_statistics, 'SWAPPING STATISTICS', ' system data- '],
{              } ['CPU_STATISTICS', osc$cpu_statistics, 'CPU STATISTICS', ' system data- '],
{              } ['CS', osc$cpu_statistics, 'CPU STATISTICS', ' system data- '],
{              } ['PIO_STATISTICS', osc$pio_stats, 'PIO_STATISTICS', ' system data- '],
{              } ['PS', osc$pio_stats, 'PIO_STATISTICS', ' system data- '],
{              } ['JOB_SCHED_STATISTICS', osc$job_sched_statistics, 'SCHEDULER STATISTICS',' system data- '],
{              } ['JSS', osc$job_sched_statistics, 'SCHEDULER STATISTICS', ' system data- '],
{              } ['SWAP_FILE_STATISTICS', osc$swap_file_statistics, 'SWAP FILE STATISTICS', ' system_data- '],
{              } ['SFS', osc$swap_file_statistics, 'SWAP FILE STATISTICS', ' system_data- ']],

      requested_options: option_set,
      value: clt$value,
      reset_maximum_time: boolean,
      file_name: clt$file,
      display_control: clt$display_control,
      display_format: ost$display_format;

*copy clv$display_variables
*copy clp$new_page_procedure

?? TITLE := 'PROCEDURE display_data' ??
?? NEWTITLE := 'abort_handler' ??
?? EJECT ??

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

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;
?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle (VAR display_control: clt$display_control;
      VAR status: ost$status);

      { The display_system_data and display_job_data commands have
      { subtitles but they are written in another procedure.  This is
      { merely a dummy routine used to keep the module consistent
      { with those that do produce subtitles.

    PROCEND put_subtitle;
?? OLDTITLE ??
?? EJECT, NEWTITLE := '    PROCEDURE format_data' ??

    PROCEDURE format_data (table_entry: converted_names;
          display_format: ost$display_format;
      VAR display_control: clt$display_control;
      VAR status: ost$status);


      VAR
        line: string (75),
        string_rep1: string (30),
        time_increment,
        length: integer,
        current_date: ost$date,
        current_time: ost$time,
        unit_count: integer,
        pp_count: integer,
        swap_file_stats_enabled: boolean,
        user_swap_stats: ost$swap_stats,
        user_page_stats: ost$page_fault_stats,
        user_server_page_stats: ost$page_fault_stats,
        user_paging_stats: ost$paging_stats,
        user_mtr_stats: ost$mtr_stats,
        user_aging_stats: ost$aging_stats,
        user_cpu_stats: ost$cpu_stats,
        user_job_stats: ost$job_stats,
        user_jm_mm_stats: ost$jm_mm_stats,
        user_sched_stats: ost$sched_stats,
        user_swap_file_stats: ost$swap_file_stats,
        user_pp_stats_p: ^ost$disk_pp_stats,
        user_unit_stats_p: ^ost$disk_unit_stats;

      clp$new_display_page (display_control, status);
      IF NOT status.normal THEN
        EXIT display_data;
      IFEND;

      IF table_entry.id <> osc$swap_file_statistics THEN
        line (1, * ) := '   ';
        line (1, 21) := table_entry.data_title;
        line (22, * ) := table_entry.title_name;
        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          EXIT display_data;
        IFEND;
      IFEND;

      CASE table_entry.id OF
      = osc$page_faults =
        osp$get_page_stats (display_format = osc$incremental, user_page_stats, user_server_page_stats,
              status);
        osp$get_paging_stats (display_format = osc$incremental, user_paging_stats, status);
        time_increment := user_page_stats.time div 1000000;
      = osc$mtr_requests =
        osp$get_mtr_stats (display_format = osc$incremental, user_mtr_stats, status);
        time_increment := user_mtr_stats.time div 1000000;
      = osc$aging_statistics =
        osp$get_aging_stats (display_format = osc$incremental, user_aging_stats, status);
        time_increment := user_aging_stats.time div 1000000;
      = osc$swap_statistics =
        osp$get_swap_stats (display_format = osc$incremental, user_swap_stats, status);
        time_increment := user_swap_stats.time div 1000000;
      = osc$cpu_statistics =
        osp$get_cpu_stats (display_format = osc$incremental, user_cpu_stats, status);
        time_increment := user_cpu_stats.time div 1000000;
      = osc$job_data =
        osp$get_job_stats (display_format = osc$incremental, user_job_stats, status);
        time_increment := user_job_stats.time div 1000000;
      = osc$jm_mm_statistics =
        osp$get_jm_mm_stats (display_format = osc$incremental, user_jm_mm_stats, status);
        time_increment := user_jm_mm_stats.time div 1000000;
      = osc$pio_stats =
        osp$get_pp_unit_count (pp_count, unit_count, status);
        IF (pp_count <> 0) AND (unit_count <> 0) THEN
          PUSH user_pp_stats_p: [1 .. pp_count];
          PUSH user_unit_stats_p: [1 .. unit_count];
          osp$get_pio_pp_stats (display_format = osc$incremental, user_pp_stats_p^, status);
          osp$get_pio_unit_stats (display_format = osc$incremental, user_unit_stats_p^, status);
          time_increment := user_pp_stats_p^.time div 1000000;
        IFEND;
      = osc$job_sched_statistics =
        osp$get_sched_stats (display_format = osc$incremental, user_sched_stats, status);
        time_increment := user_sched_stats.time div 1000000;
      = osc$swap_file_statistics =
        osp$get_swap_file_statistics (display_format = osc$incremental, swap_file_stats_enabled,
              user_swap_file_stats, status);
        IF NOT swap_file_stats_enabled THEN
          line (1, * ) := ' Swap File Statistics Not Currently Enabled.';
          clp$put_display (display_control, line, clc$trim, status);
          RETURN;
        ELSE
          line (1, * ) := '   ';
          line (1, 21) := table_entry.data_title;
          line (22, * ) := table_entry.title_name;
          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT display_data;
          IFEND;
        IFEND;
        time_increment := user_swap_file_stats.time div 1000000;
      CASEND;

      pmp$get_date (osc$mdy_date, current_date, status);
      IF NOT status.normal THEN
        EXIT display_data;
      IFEND;

      pmp$get_time (osc$hms_time, current_time, status);
      IF NOT status.normal THEN
        EXIT display_data;
      IFEND;

      line (1, * ) := '   ';
      line (2, 8) := current_date.mdy;
      line (10, 4) := '    ';
      line (14, 8) := current_time.hms;

      IF (display_format = osc$incremental) AND (table_entry.id <> osc$jm_mm_statistics) THEN
        line (22, 6) := '      ';
        line (28, 19) := '[time increment of ';
        STRINGREP (string_rep1, length, time_increment);
        line (47, length) := string_rep1;
        line (47 + length, * ) := ' seconds]';
      ELSE
        line (22, * ) := '    ';
      IFEND;

      clp$put_display (display_control, line, clc$trim, status);
      IF NOT status.normal THEN
        EXIT display_data;
      IFEND;

      clp$new_display_line (display_control, 2, status);
      IF NOT status.normal THEN
        EXIT display_data;
      IFEND;

      CASE table_entry.id OF
      = osc$page_faults =
        format_system_pf_data (user_page_stats, user_server_page_stats, display_control, status);
        format_system_paging_data (user_paging_stats, display_control, status);
      = osc$mtr_requests =
        format_system_mr_data (user_mtr_stats, display_control, status);
      = osc$aging_statistics =
        format_system_as_data (user_aging_stats, display_control, status);
      = osc$swap_statistics =
        format_swap_statistics (user_swap_stats, display_control, status);
      = osc$cpu_statistics =
        format_cpu_statistics (user_cpu_stats, display_control, status);
      = osc$job_data =
        format_job_data (user_job_stats, display_control, status);
      = osc$jm_mm_statistics =
        format_jm_mm_statistics (user_jm_mm_stats, display_control, status);
      = osc$pio_stats =
        format_pio_stats (user_pp_stats_p, user_unit_stats_p,
                          pp_count, unit_count, display_control, status);
      = osc$job_sched_statistics =
        format_scheduler_data (user_sched_stats, display_control, status);
      = osc$swap_file_statistics =
        format_swap_file_statistics (user_swap_file_stats, display_control, status);
      CASEND;
      IF NOT status.normal THEN
        EXIT display_data;
      IFEND;

    PROCEND format_data;
?? TITLE := '    PROCEDURE format_swap_statistics', EJECT ??

    PROCEDURE format_swap_statistics (
          user_copy_of_data: ost$swap_stats;
      VAR display_control: clt$display_control;
      VAR status: ost$status);

      VAR
        s: string (60),
        interval_in_seconds,
        swap_rate: real,
        from_state,
        to_state: jmt$ijl_swap_status,
        len: integer;

      s := ' TRANSITION   COUNT   AVER-US  COUNT/SEC        MAX-US';
      clp$put_display (display_control, s, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      s := ' ';
      clp$put_display (display_control, s, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      interval_in_seconds := $real(user_copy_of_data.time)/1000000.0;
      FOR from_state := LOWERVALUE (jmt$ijl_swap_status) TO UPPERVALUE (jmt$ijl_swap_status) DO
        FOR to_state := LOWERVALUE (jmt$ijl_swap_status) TO UPPERVALUE (jmt$ijl_swap_status) DO
          IF user_copy_of_data.swap_stats [from_state] [to_state].count <> 0 THEN
            s := ' ';
            s (5, 2) := jsv$swap_status_id_array [from_state];
            s (10, 2) := jsv$swap_status_id_array [to_state];
            IF interval_in_seconds <> 0.0 THEN
                swap_rate := $real(user_copy_of_data.swap_stats [from_state] [to_state].count)
                              / interval_in_seconds;
              ELSE
                swap_rate := 0.0;
            IFEND;
            STRINGREP (s (12, 8), len, user_copy_of_data.swap_stats [from_state] [to_state].count);
            STRINGREP (s (20, 10), len, user_copy_of_data.swap_stats [from_state] [to_state].total_time DIV
                  user_copy_of_data.swap_stats [from_state] [to_state].count);
            STRINGREP (s (30, 11), len, swap_rate:11:1);
            STRINGREP (s (44, 11), len, user_copy_of_data.swap_stats [from_state] [to_state].maximum_time);
            clp$put_display (display_control, s, clc$trim, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        FOREND;
      FOREND;


      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      s := ' Average swap file size:';
      IF user_copy_of_data.swap_file_page_count.swap_count > 0 THEN
        STRINGREP (s (26, 9), len, $REAL(user_copy_of_data.swap_file_page_count.page_count)/
              $REAL(user_copy_of_data.swap_file_page_count.swap_count):9:2);
      ELSE
        s (26, 1) := '0';
      IFEND;
      clp$put_display (display_control, s, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND format_swap_statistics;
?? EJECT, TITLE := '    PROCEDURE format_system_pf_data' ??

    PROCEDURE format_system_pf_data (
          user_copy_of_data: ost$page_fault_stats;
          user_copy_of_server_data: ost$page_fault_stats;
      VAR display_control: clt$display_control;
      VAR status: ost$status);

      VAR
        line: string (80),
        string_rep2: string (20),
        pf_sum,
        i,
        length: integer,
        time_interval_sec,
        pf_rate: real,
        queue_id: [STATIC, READ, oss$job_paged_literal] array [1 .. 17] of string (28) :=
{              } ['   available queue          ',
{               } '   available modified queue ',
{               } '   valid in page table      ',
{               } '   no memory                ',
{               } '   low on memory            ',
{               } '   locked                   ',
{               } '   on disk                  ',
{               } '   page table full          ',
{               } '   io temporary reject      ',
{               } '   new page assigned        ',
{               } '   beyond file limit        ',
{               } '   beyond end of segment    ',
{               } '   no extend permission     ',
{               } '   volume unavailable       ',
{               } '   found on server          ',
{               } '   alloc required on server ',
{               } '   server terminated        '];

      line := ' ';
      line(4,15) := 'Page Fault Type';
      line(34,16) := 'Page Fault Count';
      line(54,18) := 'Page Faults/Second';
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := '  ';
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


      time_interval_sec := $real(user_copy_of_data.time) / 1000000.0;
      pf_sum := 0;
      FOR i := LOWERBOUND (queue_id) TO UPPERBOUND (queue_id) DO
        line (1, * ) := '     ';
        pf_sum := pf_sum + user_copy_of_data.pf_stats [i];
        IF time_interval_sec <> 0.0 THEN
            pf_rate := $real(user_copy_of_data.pf_stats [i]) / time_interval_sec;
          ELSE
            pf_rate := 0.0;
        IFEND;
        STRINGREP (line,length,
                        ' ',queue_id [i],
                        ' ',user_copy_of_data.pf_stats [i]:20,
                        ' ',pf_rate:20:1);
        clp$put_display (display_control, line (1, 80), clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      FOREND;

      line := ' ';
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF time_interval_sec <> 0.0 THEN
          pf_rate := $real(pf_sum) / time_interval_sec;
        ELSE
          pf_rate := 0.0;
      IFEND;
      STRINGREP (line,length,
                      ' ','   Total Page Faults        ',
                      ' ',pf_sum:20,
                      ' ',pf_rate:20:1);
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := ' ';
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := ' ';
      line(22, 18) := 'SERVER PAGE_FAULTS';
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := ' ';
      line(4,15) := 'Page Fault Type';
      line(34,16) := 'Page Fault Count';
      line(54,18) := 'Page Faults/Second';
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := '  ';
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


      time_interval_sec := $real(user_copy_of_server_data.time) / 1000000.0;
      pf_sum := 0;
      FOR i := LOWERBOUND (queue_id) TO UPPERBOUND (queue_id) DO
        line (1, * ) := '     ';
        pf_sum := pf_sum + user_copy_of_server_data.pf_stats [i];
        IF time_interval_sec <> 0.0 THEN
            pf_rate := $real(user_copy_of_server_data.pf_stats [i]) / time_interval_sec;
          ELSE
            pf_rate := 0.0;
        IFEND;
        STRINGREP (line,length,
                        ' ',queue_id [i],
                        ' ',user_copy_of_server_data.pf_stats [i]:20,
                        ' ',pf_rate:20:1);
        clp$put_display (display_control, line (1, 80), clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      FOREND;

      line := ' ';
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF time_interval_sec <> 0.0 THEN
          pf_rate := $real(pf_sum) / time_interval_sec;
        ELSE
          pf_rate := 0.0;
      IFEND;
      STRINGREP (line,length,
                      ' ','   Total Server Page Faults ',
                      ' ',pf_sum:20,
                      ' ',pf_rate:20:1);
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND format_system_pf_data;


?? EJECT, TITLE := '    PROCEDURE format_system_paging_data ' ??

    PROCEDURE format_system_paging_data (
          user_copy_of_data: ost$paging_stats;
      VAR display_control: clt$display_control;
      VAR status: ost$status);

      VAR
        line: string (80),
        i,
        length: integer,
        time_interval_sec,
        ps_rate: real,
        ps_count: array [1..mmc$page_streaming_counters+1] of integer,
        ps_source_header1: [STATIC, READ, oss$job_paged_literal] string(40) :=
          '   PAGING STATISTICS, SOURCE OF PAGES ',
        ps_source_header2: [STATIC, READ, oss$job_paged_literal] string(42) :=
          'Number of pages acquired by each process',
        ps_source_header3: [STATIC, READ, oss$job_paged_literal] string(78) :=
{                      } '  Page Source           Nominal        Page         Advise          TOTALS',
        ps_source_header4: [STATIC, READ, oss$job_paged_literal] string(78) :=
{                      } '                      Page Fault    Streaming         IN          PAGES   /sec',
        total_pf: integer,
        total_ps: integer,
        total_ai: integer,
        source_title: [STATIC, READ, oss$job_paged_literal] array[1..5] of string(17):=
{              } ['Pages from disk  ',
{               } 'Pages reclaimed  ',
{               } 'Pages assigned   ',
{               } 'Pages from server',
{               } '   Process TOTALS'  ],
        ps_title:[STATIC, READ, oss$job_paged_literal] array[1..mmc$page_streaming_counters+1] of string(52):=
{              } ['   Page Streaming prestream mode initiated ',
{               } '   Page Streaming mode initiated   ',
{               } '   Prestream mode ended without initiating streaming',
{               } '   Page Streaming mode ended by random page faults',
{               } '   Pages read in page streaming prestream mode',
{               } '   Pages read in page streaming mode',
{               } '   Task slower than rate of page streaming',
{               } '   Page fault at lower address in same transfer unit',
{               } '   Pages freed behind ',
{               } '   Page Streaming mode continued after random fault'   ],
        ps_title2:[STATIC, READ, oss$job_paged_literal] array[1..2] of string(52):=
{              } ['   Average number of pages per prestream mode:',
{               } '   Average number of pages per page streaming mode:'   ];

      time_interval_sec := $real(user_copy_of_data.time) / 1000000.0;
      clp$new_display_page (display_control, status);
      line := ' ';
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := ' ';
      line(22, 40) := ps_source_header1;
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := '  ';
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := ' ';
      line(22,42) := ps_source_header2;
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line(2,79) := ps_source_header3;
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line(2,79) := ps_source_header4;
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := ' ';
      IF time_interval_sec <> 0.0 THEN
        ps_rate := $real(user_copy_of_data.p_stats.pf_pages.disk + user_copy_of_data.p_stats.ps_pages.disk +
              user_copy_of_data.p_stats.ai_pages.disk ) / time_interval_sec;
      ELSE
        ps_rate := 0.0;
      IFEND;
      STRINGREP (line,length, ' ',source_title [1],                             { Page from disk}
            '   ', user_copy_of_data.p_stats.pf_pages.disk:12,
            ' ', user_copy_of_data.p_stats.ps_pages.disk:12,
            ' ', user_copy_of_data.p_stats.ai_pages.disk:12,
            ' ', (user_copy_of_data.p_stats.pf_pages.disk + user_copy_of_data.p_stats.ps_pages.disk +
                 user_copy_of_data.p_stats.ai_pages.disk ):12,
            ' ',ps_rate:7:1);
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := ' ';
      IF time_interval_sec <> 0.0 THEN
        ps_rate := $real(user_copy_of_data.p_stats.pf_pages.reclaim +
              user_copy_of_data.p_stats.ps_pages.reclaim  +
              user_copy_of_data.p_stats.ai_pages.reclaim ) / time_interval_sec;
      ELSE
        ps_rate := 0.0;
      IFEND;
      STRINGREP (line,length, ' ',source_title [2],                             { Pages reclaimed}
            '   ', user_copy_of_data.p_stats.pf_pages.reclaim:12,
            ' ', user_copy_of_data.p_stats.ps_pages.reclaim:12,
            ' ', user_copy_of_data.p_stats.ai_pages.reclaim:12,
            ' ', (user_copy_of_data.p_stats.pf_pages.reclaim + user_copy_of_data.p_stats.ps_pages.reclaim +
                 user_copy_of_data.p_stats.ai_pages.reclaim ):12,
            ' ',ps_rate:7:1);
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := ' ';
      IF time_interval_sec <> 0.0 THEN
        ps_rate := $real(user_copy_of_data.p_stats.pf_pages.new +
              user_copy_of_data.p_stats.ps_pages.new  +
              user_copy_of_data.p_stats.ai_pages.new ) / time_interval_sec;
      ELSE
        ps_rate := 0.0;
      IFEND;
      STRINGREP (line,length, ' ',source_title [3],                             { Pages assigned}
            '   ', user_copy_of_data.p_stats.pf_pages.new:12,
            ' ', user_copy_of_data.p_stats.ps_pages.new:12,
            ' ', user_copy_of_data.p_stats.ai_pages.new:12,
            ' ', (user_copy_of_data.p_stats.pf_pages.new + user_copy_of_data.p_stats.ps_pages.new +
                 user_copy_of_data.p_stats.ai_pages.new ):12,
            ' ',ps_rate:7:1);
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := ' ';
      IF time_interval_sec <> 0.0 THEN
        ps_rate := $real(user_copy_of_data.p_stats.pf_pages.server +
              user_copy_of_data.p_stats.ps_pages.server +
              user_copy_of_data.p_stats.ai_pages.server ) / time_interval_sec;
      ELSE
        ps_rate := 0.0;
      IFEND;
      STRINGREP (line,length, ' ',source_title [4],                             { Pages from server}
            '   ', user_copy_of_data.p_stats.pf_pages.server:12,
            ' ', user_copy_of_data.p_stats.ps_pages.server:12,
            ' ', user_copy_of_data.p_stats.ai_pages.server:12,
            ' ', (user_copy_of_data.p_stats.pf_pages.server + user_copy_of_data.p_stats.ps_pages.server +
                 user_copy_of_data.p_stats.ai_pages.server ):12,
            ' ',ps_rate:7:1);
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := '  ';
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      total_pf := user_copy_of_data.p_stats.pf_pages.disk + user_copy_of_data.p_stats.pf_pages.reclaim +
                  user_copy_of_data.p_stats.pf_pages.new + user_copy_of_data.p_stats.pf_pages.server;
      total_ps := user_copy_of_data.p_stats.ps_pages.disk + user_copy_of_data.p_stats.ps_pages.reclaim +
                  user_copy_of_data.p_stats.ps_pages.new + user_copy_of_data.p_stats.ps_pages.server;
      total_ai := user_copy_of_data.p_stats.ai_pages.disk + user_copy_of_data.p_stats.ai_pages.reclaim +
                  user_copy_of_data.p_stats.ai_pages.new + user_copy_of_data.p_stats.ai_pages.server;

      line := ' ';
      IF time_interval_sec <> 0.0 THEN
        ps_rate := $real(total_pf + total_ps + total_ai)  / time_interval_sec;
      ELSE
        ps_rate := 0.0;
      IFEND;
      STRINGREP (line,length, ' ',source_title [5], '   ',                               {   Process TOTALS}
            total_pf:12, ' ', total_ps:12, ' ', total_ai:12,  ' ',
            ( total_pf + total_ps + total_ai ):12,
            ' ',ps_rate:7:1);
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := '  ';
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := ' ';
      line(22, 39) := 'PAGING STATISTICS, PAGE STREAMING DATA';
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := ' ';
      line(4,15) := 'Page Streaming Counter';
      line(60,5) := 'Count';
      line(68,13) := 'Counts/Second';
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := '  ';
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      ps_count[1] := user_copy_of_data.p_stats.page_streaming.initiated +
                     user_copy_of_data.p_stats.page_streaming.prestream_only;
      ps_count[2] := user_copy_of_data.p_stats.page_streaming.initiated;
      ps_count[3] := user_copy_of_data.p_stats.page_streaming.prestream_only;
      ps_count[4] := user_copy_of_data.p_stats.page_streaming.terminated;
      ps_count[5] := user_copy_of_data.p_stats.page_streaming.pages_prestream;
      ps_count[6] := user_copy_of_data.p_stats.page_streaming.pages_streaming;
      ps_count[7] := user_copy_of_data.p_stats.page_streaming.task_slow;
      ps_count[8] := user_copy_of_data.p_stats.page_streaming.page_faults_tu;
      ps_count[9]:= user_copy_of_data.p_stats.page_streaming.pages_freed_behind;
      ps_count[10]:= user_copy_of_data.p_stats.page_streaming.random_faults;
      FOR i := LOWERBOUND (ps_count) TO UPPERBOUND (ps_count) DO
        line (1, * ) := '     ';
        IF time_interval_sec <> 0.0 THEN
          ps_rate := $real(ps_count [i]) / time_interval_sec;
        ELSE
          ps_rate := 0.0;
        IFEND;
        STRINGREP (line,length, ' ',ps_title [i],
                        ' ',ps_count [i]:12,
                        '  ',ps_rate:12:1);
        clp$put_display (display_control, line (1, 80), clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

      line := '  ';
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF ps_count[1] > 0 THEN
        ps_rate := $real(user_copy_of_data.p_stats.page_streaming.pages_prestream) / $real(ps_count[1]);
      ELSE
        ps_rate := 0.0;
      IFEND;
      STRINGREP (line,length, ' ',ps_title2[1], '  ',ps_rate:8:1);
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      line := '  ';
      IF ps_count[2] > 0 THEN
        ps_rate := $real(user_copy_of_data.p_stats.page_streaming.pages_streaming) / $real(ps_count[2]);
      ELSE
        ps_rate := 0.0;
      IFEND;
      STRINGREP (line,length, ' ',ps_title2[2], '  ',ps_rate:8:1);
      clp$put_display (display_control, line (1, 80), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND format_system_paging_data;


?? EJECT, TITLE := '    PROCEDURE format_system_mr_data' ??

    PROCEDURE format_system_mr_data (
          user_copy_of_data: ost$mtr_stats;
      VAR display_control: clt$display_control;
      VAR status: ost$status);

*copyc syc$monitor_request_codes

      VAR
        first_time: boolean,
        title_line: string (75),
        line: string (100),
        string_rep2: string (10),
        string_rep3: string (10),
        string_rep4: string (15),
        string_rep5: string (10),
        aver,
        mtr_cpu_sum,
        mtr_count_sum,
        sum: integer,
        percent,
        aver_real,
        interval_in_seconds,
        request_rate,
        sum_real: real,
        aver_time,
        length,
        i: integer,
        request_id: [STATIC, READ, oss$job_paged_literal] array [0 .. syc$rc_maximum_value] of string (20) :=
{ 0           } ['illegal_request     ',
{ 1            } 'cycle               ',
{ 2            } 'delay               ',
{ 3            } 'unused 03           ',
{ 4            } 'device_io           ',
{ 5            } 'advise_in           ',
{ 6            } 'advise_out          ',
{ 7            } 'advise_out_in       ',
{ 8            } 'initiate_task       ',
{ 9            } 'page_fault          ',
{10            } 'initiate_job        ',
{11            } 'exit_job            ',
{12            } 'free_pages          ',
{13            } 'write_modified_pages',
{14            } 'change_segment_table',
{15            } 'check_active_pps    ',
{16            } 'unused 16           ',
{17            } 'unused 17           ',
{18            } 'job_swapping_fns    ',
{19            } 'idle_resume_system  ',
{20            } 'mcr/ucr_fault       ',
{21            } 'system_error        ',
{22            } 'update_task_stats   ',
{23            } 'unused 23           ',
{24            } 'unused 24           ',
{25            } 'ready_task          ',
{26            } 'set_system_flag     ',
{27            } 'wait                ',
{28            } 'lock_ring_1_stack   ',
{29            } 'mtr_send_signal     ',
{30            } 'set_get_sgmnt_length',
{31            } 'read_write_io       ',
{32            } 'job_recovery        ',
{33            } 'ring_1_sgmnt_request',
{34            } 'task_exit           ',
{35            } 'unused 35           ',
{36            } 'update_xp_register  ',
{37            } 'segment_request     ',
{38            } 'lock_pages          ',
{39            } 'unlock_pages        ',
{40            } 'fetch_unwritten_pgs ',
{41            } 'allocate_front_end  ',
{42            } 'deallocate_front_end',
{43            } 'apply_mat_changes   ',
{44            } 'tape_io             ',
{45            } 'translate_byte_addr ',
{46            } 'config_mgmt_request ',
{47            } 'manage_system_tasks ',
{48            } 'lock_unlock_segment ',
{49            } 'issue_dft_request   ',
{50            } 'wait_io_completion  ',
{51            } 'switch_task         ',
{52            } 'short_warning       ',
{53            } 'monitor_sys_status  ',
{54            } 'process_io          ',
{55            } 'display_request     ',
{56            } 'process_scd_block   ',
{57            } 'keypoint_recorder   ',
{58            } 'periodic_call       ',
{59            } 'process_due         ',
{60            } 'unused 60           ',
{61            } 'monitor_swap_reqs   ',
{62            } 'monitor_mode_ei     ',
{63            } 'unused 63           ',
{64            } 'io_subsys_processor ',
{65            } 'access_logging_data ',
{66            } 'process_dft_entry   ',
{67            } 'job_scheduler_req   ',
{68            } 'fetch_offset_mod_pgs',
{69            } 'assign pages        ',
{70            } 'conditional free    ',
{71            } 'rhfam queue I/O data',
{72            } 'unused 72           ',
{73            } 'file server request ',
{74            } 'move pages          ',
{75            } 'assign contiguous   ',
{76            } 'reallocate file     ',
{77            } 'ring_1_server_seg_rq',
{78            } 'mntr_cpu_self_state ',
{79            } 'stats facility req  ',
{80            } 'sys deadstart status',
{81            } 'service class stats ',
{82            } 'unused request_82   ',
{83            } 'unused request_83   ',
{84            } 'unused request_84   ',
{85            } 'unused request_85   ',
{86            } 'unused request_86   '];

   sum := 0;
   aver := 0;
   percent := 0.0;
   mtr_cpu_sum := 0;
   mtr_count_sum := 0;
      line (1, * ) := '    ';
      line (10, 7) := 'Request';
      line (27, 5) := 'Count';
      line (36, 7) := 'Aver_us';
      line (51, 6) := 'Max_us';
      line (64,6) := 'Pct_us';
      line (73,7) := 'Cnt/Sec';


      IF display_control.page_width > 80 THEN
         line (90, 8) := 'Total_us';
         clp$put_display (display_control, line (1, 100), clc$trim, status);
         IF NOT status.normal THEN
            RETURN;
         IFEND;
      ELSE
         clp$put_display (display_control, line (1, 80), clc$trim, status);
         IF NOT status.normal THEN
            RETURN;
         IFEND;
      IFEND;

      line (1, * ) := '    ';
      clp$put_display (display_control, line (1, 58), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

  FOR i := LOWERBOUND (request_id) TO UPPERBOUND (request_id) DO
    IF user_copy_of_data.mtr_reqs [i].count <> 0 THEN
      mtr_cpu_sum := mtr_cpu_sum + user_copy_of_data.mtr_reqs [i].total_cpu_time;
      mtr_count_sum := mtr_count_sum + user_copy_of_data.mtr_reqs [i].count;
    IFEND;
  FOREND;

  interval_in_seconds := $real(user_copy_of_data.time)/1000000.0;
  FOR i := LOWERBOUND (request_id) TO UPPERBOUND (request_id) DO
    IF user_copy_of_data.mtr_reqs [i].count <> 0 THEN
      line (1, * ) := '    ';
      line (2, 20) := request_id [i];
      STRINGREP (string_rep2, length, user_copy_of_data.mtr_reqs [i].count);
      line ((32 - length), length) := string_rep2;

      aver_time := user_copy_of_data.mtr_reqs [i].total_cpu_time DIV user_copy_of_data.mtr_reqs [i].count;
      STRINGREP (string_rep3, length, aver_time);
      line ((43 - length), length) := string_rep3;

      STRINGREP (string_rep4, length, user_copy_of_data.mtr_reqs [i].max_time);
      line ((59 - length), length) := string_rep4;

      IF mtr_cpu_sum <> 0 THEN
          percent := 100.0 * $real(user_copy_of_data.mtr_reqs [i].total_cpu_time) / $real(mtr_cpu_sum);
        ELSE
          percent := 0.0;
      IFEND;
      STRINGREP(string_rep5, length, percent:10:2);
      line((70 - length), length) := string_rep5;

      string_rep2 := ' ';
      IF interval_in_seconds <> 0.0 THEN
          request_rate := $real(user_copy_of_data.mtr_reqs [i].count)/interval_in_seconds;
        ELSE
          request_rate := 0.0;
      IFEND;
      STRINGREP (string_rep2, length, request_rate:10:1);
      line ((80 - length), length) := string_rep2;

      IF display_control.page_width > 80 THEN
         string_rep4 := '  ';
         STRINGREP (string_rep4, length, user_copy_of_data.mtr_reqs [i].total_cpu_time);
         line ((96 - length), length) := string_rep4;

         clp$put_display (display_control, line (1, 100), clc$trim, status);
         IF NOT status.normal THEN
            RETURN;
         IFEND;
       ELSE
         clp$put_display (display_control, line (1, 80), clc$trim, status);
         IF NOT status.normal THEN
            RETURN;
         IFEND;
       IFEND;
    IFEND;
  FOREND;

  line := '  ';
  line(2,5) := 'Total';
  string_rep2 := ' ';
  STRINGREP (string_rep2, length, mtr_count_sum);
  line ((32 - length), length) := string_rep2;

  string_rep2 := ' ';
  IF interval_in_seconds <> 0.0 THEN
      request_rate := $real(mtr_count_sum)/interval_in_seconds;
    ELSE
      request_rate := 0.0;
  IFEND;
  STRINGREP (string_rep2, length, request_rate:10:1);
  line ((80 - length), length) := string_rep2;

  IF display_control.page_width > 80 THEN
     string_rep4 := '  ';
     STRINGREP(string_rep4, length, mtr_cpu_sum);
     line((96 - length), length) := string_rep4;

     clp$put_display (display_control, line (1, 100), clc$trim, status);
     IF NOT status.normal THEN
        RETURN;
     IFEND;
  ELSE
     clp$put_display (display_control, line (1, 80), clc$trim, status);
     IF NOT status.normal THEN
        RETURN;
     IFEND;
  IFEND;


    PROCEND format_system_mr_data;

?? EJECT, TITLE := '    PROCEDURE format_system_as_data' ??

    PROCEDURE format_system_as_data (
          user_copy_of_data: ost$aging_stats;
      VAR display_control: clt$display_control;
      VAR status: ost$status);

      VAR
        line: string (75),
        string_rep2: string (20),
        length: integer;

      line (1, * ) := '     ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.force_aggressive_aging);
      line ((22 - length), length) := string_rep2;
      line (24, 25) := '   force_aggressive_aging';
      clp$put_display (display_control, line (1, 48), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '     ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.aggressive_age_shared_queue);
      line ((22 - length), length) := string_rep2;
      line (24, 30) := '   aggressive_age_shared_queue';
      clp$put_display (display_control, line (1, 53), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '     ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.aggressive_age_job_queues);
      line ((22 - length), length) := string_rep2;
      line (24, 28) := '   aggressive_age_job_queues';
      clp$put_display (display_control, line (1, 51), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '     ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.aggressive_aging_failed);
      line ((22 - length), length) := string_rep2;
      line (24, 26) := '   aggressive_aging_failed';
      clp$put_display (display_control, line (1, 49), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '     ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.age_cp_bound_job);
      line ((22 - length), length) := string_rep2;
      line (24, 19) := '   age_cp_bound_job';
      clp$put_display (display_control, line (1, 42), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '     ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.remove_unmodified_page_from_ws);
      line ((22 - length), length) := string_rep2;
      line (24, 33) := '   remove_unmodified_page_from_ws';
      clp$put_display (display_control, line (1, 56), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '     ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.remove_modified_page_from_ws);
      line ((22 - length), length) := string_rep2;
      line (24, 31) := '   remove_modified_page_from_ws';
      clp$put_display (display_control, line (1, 54), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '     ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.page_written_to_disk);
      line ((22 - length), length) := string_rep2;
      line (24, 23) := '   page_written_to_disk';
      clp$put_display (display_control, line (1, 46), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '     ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.multiple_pages_written_to_disk);
      line ((22 - length), length) := string_rep2;
      line (24, 33) := '   multiple_pages_written_to_disk';
      clp$put_display (display_control, line (1, 56), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '     ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.calls_to_age_jws);
      line ((22 - length), length) := string_rep2;
      line (24, 19) := '   calls_to_age_jws';
      clp$put_display (display_control, line (1, 42), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '     ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.age_exceeds_aif);
      line ((22 - length), length) := string_rep2;
      line (24, 18) := '   age_exceeds_aif';
      clp$put_display (display_control, line (1, 41), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '     ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.age_exceeds_aic);
      line ((22 - length), length) := string_rep2;
      line (24, 18) := '   age_exceeds_aic';
      clp$put_display (display_control, line (1, 41), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '     ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.age_unused_page_in_shared_queue);
      line ((22 - length), length) := string_rep2;
      line (24, 34) := '   age_unused_page_in_shared_queue';
      clp$put_display (display_control, line (1, 57), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '   ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.write_aged_out_page);
      line ((22 - length), length) := string_rep2;
      line (24, 22) := '   write_aged_out_page';
      clp$put_display (display_control, line (1, 45), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '   ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.write_forced_out_page);
      line ((22 - length), length) := string_rep2;
      line (24, 24) := '   write_forced_out_page';
      clp$put_display (display_control, line (1, 47), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '   ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.write_pt_full_page);
      line ((22 - length), length) := string_rep2;
      line (24, 21) := '   write_pt_full_page';
      clp$put_display (display_control, line (1, 44), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '   ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.write_avail_mod_page);
      line ((22 - length), length) := string_rep2;
      line (24, 23) := '   write_avail_mod_page';
      clp$put_display (display_control, line (1, 46), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '   ';
      STRINGREP (string_rep2, length, user_copy_of_data.aging_stats.write_page_failed);
      line ((22 - length), length) := string_rep2;
      line (24, 20) := '   write_page_failed';
      clp$put_display (display_control, line (1, 43), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


    PROCEND format_system_as_data;

?? EJECT, TITLE := '    PROCEDURE format_job_data' ??

    PROCEDURE format_job_data (
          user_copy_of_data: ost$job_stats;
      VAR display_control: clt$display_control;
      VAR status: ost$status);

      VAR
        line: string (75),
        temp1,
        temp2,
        length1,
        length2,
        length: integer,
        string_rep1,
        string_rep2,
        string_rep3,
        string_rep4,
        string_rep5,
        string_rep6,
        string_rep7,
        string_rep8,
        string_rep9: string (15);

      line (1, * ) := '     ';
      line (16, 40) := '000000     time spent in job mode (secs)';
      temp1 := user_copy_of_data.job_data.cp_time.time_spent_in_job_mode DIV 1000000;
      STRINGREP (string_rep1, length1, temp1);
      temp2 := user_copy_of_data.job_data.cp_time.time_spent_in_job_mode MOD 1000000;
      STRINGREP (string_rep2, length2, temp2);
      line ((15 - length1), length1) := string_rep1;
      line ((23 - length2), (length2 - 1)) := string_rep2 (2, (length2 - 1));
      line (15, 1) := '.';
      clp$put_display (display_control, line (1, 56), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '     ';
      line (16, 40) := '000000     time spent in mtr mode (secs)';
      temp1 := user_copy_of_data.job_data.cp_time.time_spent_in_mtr_mode DIV 1000000;
      STRINGREP (string_rep3, length1, temp1);
      temp2 := user_copy_of_data.job_data.cp_time.time_spent_in_mtr_mode MOD 1000000;
      STRINGREP (string_rep4, length2, temp2);
      line ((15 - length1), length1) := string_rep3;
      line ((23 - length2), (length2 - 1)) := string_rep4 (2, (length2 - 1));
      line (15, 1) := '.';
      clp$put_display (display_control, line (1, 56), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '    ';
      STRINGREP (string_rep5, length, user_copy_of_data.job_data.paging_statistics.page_in_count);
      line ((22 - length), length) := string_rep5;
      line (24, 38) := '   page in count(pages read from disk)';
      clp$put_display (display_control, line (1, 61), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


      line (1, * ) := '    ';
      STRINGREP (string_rep6, length, user_copy_of_data.job_data.paging_statistics.
            pages_reclaimed_from_queue);
      line ((22 - length), length) := string_rep6;
      line (24, 37) := '   pages reclaimed from queue ';
      clp$put_display (display_control, line (1, 60), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '    ';
      STRINGREP (string_rep7, length, user_copy_of_data.job_data.paging_statistics.new_pages_assigned);
      line ((22 - length), length) := string_rep7;
      line (24, 29) := '   new pages assigned ';
      clp$put_display (display_control, line (1, 52), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '    ';
      STRINGREP (string_rep5, length, user_copy_of_data.job_data.paging_statistics.pages_from_server);
      line ((22 - length), length) := string_rep5;
      line (24, 28) := '   pages read in from server';
      clp$put_display (display_control, line (1, 51), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '    ';
      STRINGREP (string_rep5, length, user_copy_of_data.job_data.paging_statistics.page_fault_count);
      line ((22 - length), length) := string_rep5;
      line (24, 30) := '   total number of page faults';
      clp$put_display (display_control, line (1, 53), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (line, length, user_copy_of_data.job_data.paging_statistics.working_set_max_used:21,
                       '     maximum working set actually used (pages)');
      clp$put_display (display_control, line (1, length), clc$no_trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '    ';
      STRINGREP (string_rep8, length, user_copy_of_data.job_data.working_set_size);
      line ((22 - length), length) := string_rep8;
      line (24, 27) := '   working set size (pages)';
      clp$put_display (display_control, line (1, 50), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


      line (1, * ) := '    ';
      STRINGREP (string_rep9, length, user_copy_of_data.job_data.ready_task_count);
      line ((22 - length), length) := string_rep9;
      line (24, 19) := '   ready task count';
      clp$put_display (display_control, line (1, 42), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND format_job_data;

?? EJECT, TITLE := '    PROCEDURE format_jm_mm_statistics' ??

    PROCEDURE format_jm_mm_statistics (
          user_copy_of_data: ost$jm_mm_stats;
      VAR display_control: clt$display_control;
      VAR status: ost$status);

      VAR
        bytes: integer,
        byte_sum: integer,
        bytes_per_page: ost$page_size,
        job_info_returned: boolean,
        length: integer,
        line: string (75),
        local_copy: ost$jm_mm_stats,
        page_sum: integer,
        pages: integer,
        queue_id: mmt$page_frame_queue_id,
        site_queues_active: 0 ..255,
        string_rep: string (20);

      VAR
        queues: [STATIC, READ, oss$job_paged_literal] array [mmt$page_frame_queue_id] OF
              string (25) := [
{             } 'Free Queue',
{             } 'Available Queue',
{             } 'Available Modified Queue',
{             } 'Wired Queue',
{             } 'Task Service Shared Queue',
{             } 'Executable File Shared Q.',
{             } 'Non-Executable File S. Q.',
{             } 'Device File Shared Queue',
{             } 'File Server Shared Queue',
{             } 'Other System Shared Queue',
{             } 'Site_01 Shared Queue',
{             } 'Site_02 Shared Queue',
{             } 'Site_03 Shared Queue',
{             } 'Site_04 Shared Queue',
{             } 'Site_05 Shared Queue',
{             } 'Site_06 Shared Queue',
{             } 'Site_07 Shared Queue',
{             } 'Site_08 Shared Queue',
{             } 'Site_09 Shared Queue',
{             } 'Site_10 Shared Queue',
{             } 'Site_11 Shared Queue',
{             } 'Site_12 Shared Queue',
{             } 'Site_13 Shared Queue',
{             } 'Site_14 Shared Queue',
{             } 'Site_15 Shared Queue',
{             } 'Site_16 Shared Queue',
{             } 'Site_17 Shared Queue',
{             } 'Site_18 Shared Queue',
{             } 'Site_19 Shared Queue',
{             } 'Site_20 Shared Queue',
{             } 'Site_21 Shared Queue',
{             } 'Site_22 Shared Queue',
{             } 'Site_23 Shared Queue',
{             } 'Site_24 Shared Queue',
{             } 'Site_25 Shared Queue',
{             } 'Shared IO Error Queue',
{             } 'Swapped IO Error Queue',
{             } 'Flawed Queue',
{             } 'Job Fixed Queue',
{             } 'Job IO Error Queue',
{             } 'Job Working Set Queue'];

      bytes_per_page := 512 * (128 - #read_register(osc$pr_page_size_mask));
      status.normal := TRUE;
      local_copy := user_copy_of_data;
      line (1, * ) := '   ';
      line (2, 35) := 'Size of Memory Manager Page Queues:';
      clp$put_display (display_control, line (1, 36), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := ' ';
      line(5,10) := 'Page Queue';
      line(40,10) := 'Page Count';
      line(60,10) := 'Byte Count';
      clp$put_display (display_control, line (1, 75), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      page_sum := 0;
      site_queues_active := local_copy.jm_mm_stats.page_q_counts.site_defined_queues_active;

    /queue_loop/
      FOR queue_id := LOWERBOUND (queues) TO UPPERBOUND (queues) DO
        line (1, * ) := '   ';
        pages := local_copy.jm_mm_stats.page_q_counts.q_counts [queue_id];
        IF (queue_id >= mmc$pq_shared_first_site) AND
              (queue_id > mmc$pq_shared_last_sys + site_queues_active) AND
              (queue_id <= mmc$pq_shared_last_site) THEN
          CYCLE /queue_loop/;
        IFEND;
        bytes := bytes_per_page * pages;
        page_sum := page_sum + pages;
        STRINGREP (string_rep, length, pages);
        line ((50 - length), length) := string_rep;
        STRINGREP (string_rep, length, bytes);
        line ((70 - length), length) := string_rep;
        line (2, 25) := queues [queue_id];
        clp$put_display (display_control, line (1, 75), clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND /queue_loop/;

      line (1, * ) := ' Swap Resident Queue';
      page_sum := page_sum + local_copy.jm_mm_stats.page_q_counts.swap_resident_count;
      STRINGREP (string_rep, length, local_copy.jm_mm_stats.page_q_counts.swap_resident_count);
      line ((50 - length), length) := string_rep;
      bytes := bytes_per_page * local_copy.jm_mm_stats.page_q_counts.swap_resident_count;
      STRINGREP (string_rep, length, bytes);
      line ((70 - length), length) := string_rep;
      clp$put_display (display_control, line (1, 75), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      line (1, * ) := ' Long Wait Queue';
      page_sum := page_sum + local_copy.jm_mm_stats.page_q_counts.long_wait_count;
      STRINGREP (string_rep, length, local_copy.jm_mm_stats.page_q_counts.long_wait_count);
      line ((50 - length), length) := string_rep;
      bytes := bytes_per_page * local_copy.jm_mm_stats.page_q_counts.long_wait_count;
      STRINGREP (string_rep, length, bytes);
      line ((70 - length), length) := string_rep;
      clp$put_display (display_control, line (1, 75), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line := '  ';
      STRINGREP (string_rep, length, page_sum);
      line ((50 - length), length) := string_rep;
      byte_sum := page_sum * bytes_per_page;
      STRINGREP (string_rep, length, byte_sum);
      line ((70 - length), length) := string_rep;
      line (2, 14) := '   Totals     ';
      clp$put_display (display_control, line (1, 75), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := ' Subtotal of the System Shared Queues';
      pages := 0;
      FOR j := mmc$pq_shared_first  TO  mmc$pq_shared_last_sys  DO
        pages := pages + local_copy.jm_mm_stats.page_q_counts.q_counts [j];
      FOREND;
      bytes := bytes_per_page * pages;
      STRINGREP (string_rep, length, pages);
      line ((50 - length), length) := string_rep;
      STRINGREP (string_rep, length, bytes);
      line ((70 - length), length) := string_rep;
      clp$put_display (display_control, line (1, 75), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF site_queues_active <> 0 THEN
        line (1, * ) := ' Subtotal of the Site Defined Shared Queues';
        pages := 0;
        FOR j := mmc$pq_shared_first_site TO mmc$pq_shared_first_site +
              site_queues_active - 1 DO
          pages := pages + local_copy.jm_mm_stats.page_q_counts.q_counts [j];
        FOREND;
        bytes := bytes_per_page * pages;
        STRINGREP (string_rep, length, pages);
        line ((50 - length), length) := string_rep;
        STRINGREP (string_rep, length, bytes);
        line ((70 - length), length) := string_rep;
        clp$put_display (display_control, line (1, 75), clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;


      job_info_returned := (local_copy.jm_mm_stats.total_system_class > 0) OR (local_copy.jm_mm_stats.
            total_interactive_jobs > 0) OR (local_copy.jm_mm_stats.total_non_interactive_jobs > 0);

      IF job_info_returned THEN
        line (1, * ) := '   ';
        line (2, 34) := 'Jobs in the System (by Job Mode): ';
        clp$put_display (display_control, line (1, 35), clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF local_copy.jm_mm_stats.total_system_class > 0 THEN
          line (1, * ) := '   ';
          STRINGREP (string_rep, length, local_copy.jm_mm_stats.total_system_class);
          line ((22 - length), length) := string_rep;
          line (24, 6) := 'System';
          clp$put_display (display_control, line (1, 30), clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF local_copy.jm_mm_stats.total_interactive_jobs > 0 THEN
          line (1, * ) := '   ';
          STRINGREP (string_rep, length, local_copy.jm_mm_stats.total_interactive_jobs);
          line ((22 - length), length) := string_rep;
          line (24, 11) := 'Interactive';
          clp$put_display (display_control, line (1, 35), clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF local_copy.jm_mm_stats.total_non_interactive_jobs > 0 THEN
          line (1, * ) := '   ';
          STRINGREP (string_rep, length, local_copy.jm_mm_stats.total_non_interactive_jobs);
          line ((22 - length), length) := string_rep;
          line (24, 15) := 'Non Interactive';
          clp$put_display (display_control, line (1, 39), clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;


        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      line (1, * ) := '   ';
      line (2, 22) := 'Number of Active Jobs:';
      STRINGREP (string_rep, length, local_copy.jm_mm_stats.total_active_jobs);
      line (26, length) := string_rep;
      clp$put_display (display_control, line (1, (26 + length)), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '   ';
      STRINGREP (string_rep, length, local_copy.jm_mm_stats.total_swapped_jobs);
      line (31, length) := string_rep;
      line (2, 27) := 'Number of Jobs Swapped Out:';
      clp$put_display (display_control, line (1, (31 + length)), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '   ';
      line (2, 32) := 'Number of Ready/Executing Tasks:';
      STRINGREP (string_rep, length, local_copy.jm_mm_stats.total_ready_tasks);
      line (36, length) := string_rep;
      clp$put_display (display_control, line (1, (37 + length)), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (1, * ) := '   ';
      line (2, 34) := 'Number of Ready But Swapped Tasks:';
      STRINGREP (string_rep, length, local_copy.jm_mm_stats.total_ready_but_swapped_tasks);
      line (38, length) := string_rep;
      clp$put_display (display_control, line (1, (38 + length)), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND format_jm_mm_statistics;

?? EJECT, TITLE := '    PROCEDURE format_cpu_statistics' ??

    PROCEDURE format_cpu_statistics (
          user_copy_of_data: ost$cpu_stats;
      VAR display_control: clt$display_control;
      VAR status: ost$status);

      VAR
        average: integer,
        cpu_count: integer,
        dp: jmt$dispatching_priority,
        i: integer,
        job_mode_cp_sum : integer,
        job_mode_percentage_sum: real,
        length: integer,
        mtr_mode_cp_sum : integer,
        mtr_mode_percentage_sum: real,
        percentage: real,
        percentage2: real,
        percentage3: real,
        percentage_divisor: real,
        s: string (65),
        string_rep2: string (20),
        string_rep3: string (6),
        priority_id: [STATIC, READ, oss$job_paged_literal] array
              [jmc$min_dispatching_priority .. jmc$max_dispatching_priority] of string (3) :=
{ 2            } ['P1 ',
{ 3             } 'P2 ',
{ 4             } 'P3 ',
{ 5             } 'P4 ',
{ 6             } 'P5 ',
{ 7             } 'P6 ',
{ 8             } 'P7 ',
{ 9             } 'P8 ',
{10             } 'P9 ',
{11             } 'P10',
{12             } 'P11',
{13             } 'P12',
{14             } 'P13',
{15             } 'P14'];


{ Display statistics for each dispatching priority.

      s (1, * ) := '  ';
      s (1, 60) := ' DISPATCHING     PERCENT CPU           MICROSECONDS CPU TIME';

      clp$put_display (display_control, s, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      s (1, * ) := '  ';
      s (1, 60) := '  PRIORITY       JOB     MTR              JOB            MTR';

      clp$put_display (display_control, s, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      cpu_count := 0;
      FOR i := 0 TO user_copy_of_data.cpu_stats.cpu_count DO
        IF user_copy_of_data.cpu_stats.processor_defined [i] THEN
          cpu_count := cpu_count + 1;
        IFEND;
      FOREND;

      percentage_divisor := $real(user_copy_of_data.time * cpu_count);

      job_mode_cp_sum := 0;
      job_mode_percentage_sum := 0.0;
      mtr_mode_cp_sum := 0;
      mtr_mode_percentage_sum := 0.0;

      FOR dp := jmc$max_dispatching_priority DOWNTO jmc$min_dispatching_priority DO
        s (1, *) := ' ';
        s (7, 3) := priority_id [dp];
        STRINGREP (string_rep2, length, user_copy_of_data.cpu_stats.cpu_execution_stats [dp].
              time_spent_in_job_mode);
        s ((47 - length), length) := string_rep2;
        IF percentage_divisor <> 0.0 THEN
          percentage := ($real(user_copy_of_data.cpu_stats.cpu_execution_stats [dp].time_spent_in_job_mode *
                100) ) / percentage_divisor  ;
        ELSE
          percentage := 0.0;
        IFEND;
        STRINGREP (s(15,7), length, percentage:6:1, '%');
        job_mode_cp_sum := job_mode_cp_sum + user_copy_of_data.cpu_stats.cpu_execution_stats [dp].
              time_spent_in_job_mode;
        job_mode_percentage_sum := job_mode_percentage_sum + percentage;

        STRINGREP (string_rep2, length, user_copy_of_data.cpu_stats.cpu_execution_stats [dp].
              time_spent_in_mtr_mode);
        s ((62 - length), length) := string_rep2;
        IF percentage_divisor <> 0.0 THEN
          percentage := ($real(user_copy_of_data.cpu_stats.cpu_execution_stats [dp].time_spent_in_mtr_mode *
                100) )  /  percentage_divisor;
        ELSE
          percentage := 0.0;
        IFEND;
        STRINGREP (s(23,7), length, percentage:6:1, '%');
        mtr_mode_cp_sum := mtr_mode_cp_sum + user_copy_of_data.cpu_stats.cpu_execution_stats [dp].
              time_spent_in_mtr_mode;
        mtr_mode_percentage_sum := mtr_mode_percentage_sum + percentage;

        clp$put_display (display_control, s, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      FOREND;

      s (1, * ) := '  ';
      clp$put_display (display_control, s, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      s(3,5) := 'TOTAL';
      STRINGREP (s(15,7), length, job_mode_percentage_sum:6:1,'%');
      STRINGREP (s(23,7), length, mtr_mode_percentage_sum:6:1,'%');
      STRINGREP (s(32,15), length, job_mode_cp_sum:15);
      STRINGREP (s(47,15), length, mtr_mode_cp_sum:15);

      clp$put_display (display_control, s, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Display IDLE statistics.

      s (1, * ) := '  ';
      clp$put_display (display_control, s, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      s (1, * ) := '  ';
      s (1, 61) := '  CPU IDLE       WITH  WITHOUT           WITH         WITHOUT';

      clp$put_display (display_control, s, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      s (1, * ) := '  ';
      s (1, 61) := '                  IO     IO               IO             IO  ';

      clp$put_display (display_control, s, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      percentage_divisor := $real(user_copy_of_data.time) ;

      FOR i := 0 TO user_copy_of_data.cpu_stats.cpu_count DO
        IF user_copy_of_data.cpu_stats.processor_defined [i] THEN

          s (1, *) := ' ';
          STRINGREP (s (6, 2), length, i);
          STRINGREP (string_rep2, length, user_copy_of_data.cpu_stats.idle_stats [i].idle_io_active);
          s ((47 - length), length) := string_rep2;
          IF percentage_divisor <> 0.0 THEN
            percentage := ($real(user_copy_of_data.cpu_stats.idle_stats [i].idle_io_active * 100)  /
                  percentage_divisor);
          ELSE
            percentage := 0.0;
          IFEND;
          STRINGREP (s(15,7), length, percentage:6:1, '%');

          STRINGREP (string_rep2, length, user_copy_of_data.cpu_stats.idle_stats [i].idle_no_io_active);
          s ((62 - length), length) := string_rep2;
          IF percentage_divisor  <> 0.0 THEN
            percentage := ($real(user_copy_of_data.cpu_stats.idle_stats [i].idle_no_io_active * 100)  /
                  percentage_divisor);
          ELSE
            percentage := 0.0;
          IFEND;
          STRINGREP (s(23,7), length, percentage:6:1, '%');

          clp$put_display (display_control, s, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND;

{ Display NOS statistics.

      IF user_copy_of_data.cpu_stats.nos_stats.nos_on THEN
        s (1, * ) := '  ';
        clp$new_display_line (display_control, 3, status);    { skip 3 lines to space NOS data from idle data
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        s := '  NOS state CPU time as a percentage ';
        clp$put_display (display_control, s, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        s := '    of the Dual-State CPU                   MICROSECONDS CPU TIME';
        clp$put_display (display_control, s, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF percentage_divisor <> 0.0 THEN
          percentage := ($real(user_copy_of_data.cpu_stats.nos_stats.nos_time_ve_idle * 100) ) /
                percentage_divisor;
          percentage2 := ($real((user_copy_of_data.cpu_stats.nos_stats.nos_time -
                user_copy_of_data.cpu_stats.nos_stats.nos_time_ve_idle) * 100) ) / percentage_divisor;
          percentage3 := ($real(user_copy_of_data.cpu_stats.nos_stats.nos_time * 100) ) / percentage_divisor;
          IF percentage3 > 100.0  THEN
            percentage3 := 100.0  { ensure we do not print something dumb
          IFEND;
          IF percentage2 > 100.0  THEN
            percentage2 := 100.0  { ensure we do not print something dumb
          IFEND;
          IF percentage  > 100.0  THEN
            percentage  := 100.0  { ensure we do not print something dumb
          IFEND;
        ELSE
          percentage := 0.0;
          percentage2:= 0.0;
          percentage3:= 0.0;
        IFEND;
        s := ' ';
        STRINGREP (s,length, '  While NOS/VE idle     ',
                     '  ', percentage:6:1, '%   ',
                     '       ', user_copy_of_data.cpu_stats.nos_stats.nos_time_ve_idle:16);
        clp$put_display (display_control, s, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        STRINGREP (s,length, '  While NOS/VE NOT idle ',
                     '  ', percentage2:6:1, '%   ',
                     '       ', (user_copy_of_data.cpu_stats.nos_stats.nos_time -
                     user_copy_of_data.cpu_stats.nos_stats.nos_time_ve_idle):16);
        clp$put_display (display_control, s, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        STRINGREP (s,length, '  Total NOS time        ',
                     '  ', percentage3:6:1, '%   ',
                     '       ', user_copy_of_data.cpu_stats.nos_stats.nos_time:16);
        clp$put_display (display_control, s, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND format_cpu_statistics;

?? EJECT, TITLE := '    PROCEDURE format_pio_stats' ??

  PROCEDURE format_pio_stats
    (    user_pp_stats_p: ^ost$disk_pp_stats;
         user_unit_stats_p: ^ost$disk_unit_stats;
         pp_count: integer;
         unit_count: integer;
     VAR display_control: clt$display_control;
     VAR status: ost$status);


    VAR
      length: integer,
      line: string (132),
      local_status: ost$status,
      time_interval: real,
      time_interval_sec: real;

?? EJECT, NEWTITLE := '        PROCEDURE report_path_and_pp_data' ??

    PROCEDURE report_path_and_pp_data;

      TYPE
        path_data_record = record
          line_1: string (132),
          line_2: string (132),
          line_3: string (132),
        recend,

        pp_data_record = record
          line_1: string (132),
          line_2: string (132),
        recend;

      VAR
        active_pp_count: integer,
        active_path_count: integer,
        channel_name: string (5),
        iou_name: string (4),

        path_avg_byte_count_per_req_sum: integer,
        path_avg_response_time_sum: real,
        path_data_p: ^path_data_record,
        path_data_seq_p: ^SEQ ( * ),
        path_id_data: string (26),
        path_intermediate_errors_sum: integer,
        path_read_byte_count_sum: integer,
        path_recovered_errors_sum: integer,
        path_total_byte_count_sum: integer,
        path_total_reads_sum: integer,
        path_total_requests_sum: integer,
        path_total_writes_sum: integer,
        path_unrecovered_errors_sum: integer,
        path_wrt_and_pre_byte_count_sum: integer,

        pp_avg_data_transfer_sum: real,
        pp_avg_q_size_sum: real,
        pp_avg_response_time_sum: real,
        pp_avg_seek_and_latency_sum: real,
        pp_avg_wait_in_q_sum: real,
        pp_data_p: ^pp_data_record,
        pp_data_seq_p: ^SEQ ( * ),
        pp_id_data: string (11),
        pp_index: integer,
        pp_str_req_count_read_sum: integer,
        pp_str_req_count_total_sum: integer,
        pp_str_req_count_write_sum: integer,
        pp_str_req_failed_read_sum: integer,
        pp_str_req_failed_total_sum: integer,
        pp_str_req_failed_write_sum: integer,
        pp_streamed_success_sum: real,
        pp_time_per_request_sum: real,
        pp_total_requests: integer,
        pp_total_requests_sum: integer,
        pp_total_response_time: integer,
        pp_utilization_sum: real,

        port_name: string (1),
        port_index: integer,
        temp_string: string (4);

?? EJECT, NEWTITLE := '            PROCEDURE initialize_pp_sums' ??

      PROCEDURE initialize_pp_sums;

        pp_avg_data_transfer_sum := 0.0;
        pp_avg_q_size_sum := 0.0;
        pp_avg_response_time_sum := 0.0;
        pp_avg_seek_and_latency_sum := 0.0;
        pp_avg_wait_in_q_sum := 0.0;
        pp_streamed_success_sum := 0.0;
        pp_str_req_count_read_sum := 0;
        pp_str_req_count_write_sum := 0;
        pp_str_req_count_total_sum := 0;
        pp_str_req_failed_read_sum := 0;
        pp_str_req_failed_write_sum := 0;
        pp_str_req_failed_total_sum := 0;
        pp_time_per_request_sum := 0.0;
        pp_total_requests_sum := 0;
        pp_utilization_sum := 0.0;

      PROCEND initialize_pp_sums;
?? OLDTITLE ??

?? EJECT, NEWTITLE := '            PROCEDURE initialize_path_sums' ??

      PROCEDURE initialize_path_sums;

        path_avg_byte_count_per_req_sum := 0;
        path_avg_response_time_sum := 0.0;
        path_read_byte_count_sum := 0;
        path_intermediate_errors_sum := 0;
        path_recovered_errors_sum := 0;
        path_total_byte_count_sum := 0;
        path_total_reads_sum := 0;
        path_total_requests_sum := 0;
        path_total_writes_sum := 0;
        path_unrecovered_errors_sum := 0;
        path_wrt_and_pre_byte_count_sum := 0;

      PROCEND initialize_path_sums;
?? OLDTITLE ??

?? EJECT, NEWTITLE := '            PROCEDURE format_path_data' ??

      PROCEDURE format_path_data;

        VAR
          controller_name: string (5),
          equip_index: integer,
          path_avg_byte_count_per_req: integer,
          path_avg_response_time: real,
          path_read_byte_count: integer,
          path_total_byte_count: integer,
          path_total_requests: integer,
          path_usage_record: iot$path_usage,
          path_wrt_and_preset_byte_count: integer;


?? EJECT, NEWTITLE := '                PROCEDURE increment_path_sums' ??

        PROCEDURE increment_path_sums;

          path_total_reads_sum := path_total_reads_sum + path_usage_record.read_requests;
          path_total_writes_sum := path_total_writes_sum + path_usage_record.write_requests;
          path_total_requests_sum := path_total_requests_sum + path_total_requests;
          path_avg_response_time_sum := path_avg_response_time_sum + path_avg_response_time;
          path_read_byte_count_sum := path_read_byte_count_sum + path_read_byte_count;
          path_wrt_and_pre_byte_count_sum := path_wrt_and_pre_byte_count_sum + path_wrt_and_preset_byte_count;
          path_total_byte_count_sum := path_total_byte_count_sum + path_total_byte_count;
          path_avg_byte_count_per_req_sum := path_avg_byte_count_per_req_sum + path_avg_byte_count_per_req;
          path_recovered_errors_sum := path_recovered_errors_sum + path_usage_record.recovered_errors;
          path_unrecovered_errors_sum := path_unrecovered_errors_sum + path_usage_record.unrecovered_errors;
          path_intermediate_errors_sum := path_intermediate_errors_sum +
                path_usage_record.intermediate_errors;

        PROCEND increment_path_sums;
?? OLDTITLE ??


?? EJECT ??

      /equip_loop/
        FOR equip_index := 0 TO 7 DO
          path_usage_record := user_pp_stats_p^.disk_pp_stats [pp_index].path_usage [port_index]
                [equip_index];
          IF path_usage_record.path_used THEN
            NEXT path_data_p IN path_data_seq_p;
            path_data_p^.line_1 := ' ';
            path_data_p^.line_2 := ' ';
            path_data_p^.line_3 := ' ';

            active_path_count := active_path_count + 1;

            CASE path_usage_record.path_type OF
            = cmc$ms7154_x =
              controller_name := '7154';
            = cmc$ms7155_1, cmc$ms7155_1x =
              controller_name := '7155';
            = cmc$ms7165_2x =
              controller_name := '7165';
            = cmc$ms7255_1_1, cmc$ms7255_1_2 =
              controller_name := '7255';
            = cmc$mscm3_ct =
              controller_name := 'CM3';
            = cmc$mshydra_ct =
              controller_name := 'HYDRA';
            = cmc$ms5831_x =
              controller_name := '5831';
            ELSE
              controller_name := '    ';
            CASEND;

            path_total_requests := path_usage_record.read_requests + path_usage_record.write_requests;
            path_read_byte_count := path_usage_record.read_maus * path_usage_record.bytes_per_mau;
            path_wrt_and_preset_byte_count := path_usage_record.written_and_preset_maus *
                  path_usage_record.bytes_per_mau;
            path_total_byte_count := path_read_byte_count + path_wrt_and_preset_byte_count;

            IF path_total_requests <> 0 THEN
              path_avg_response_time := $REAL (path_usage_record.total_request_qtime) /
                    $REAL (path_total_requests) / 1000.0;
              path_avg_byte_count_per_req := path_total_byte_count DIV path_total_requests;
            ELSE
              path_avg_response_time := 0.0;
              path_avg_byte_count_per_req := 0;
            IFEND;

            pp_total_requests := pp_total_requests + path_total_requests;
            pp_total_response_time := pp_total_response_time + path_usage_record.total_request_qtime;

            STRINGREP (path_id_data, length, iou_name: 4, '  ', channel_name: 5, port_name: 1, '  ',
                  controller_name: 5, '  ', equip_index: 5);

            STRINGREP (path_data_p^.line_1, length, '  ', path_id_data, '  ',
                  path_usage_record.read_requests: 15, '  ', path_usage_record.write_requests: 15, '  ',
                  path_total_requests: 15, '  ', path_avg_response_time: 10: 2);

            STRINGREP (path_data_p^.line_2, length, '  ', path_id_data, '  ', path_read_byte_count: 15, '  ',
                  path_wrt_and_preset_byte_count: 15, '  ', path_total_byte_count: 15, '  ',
                  path_avg_byte_count_per_req: 15);

            STRINGREP (path_data_p^.line_3, length, '  ', path_id_data, '  ',
                  path_usage_record.recovered_errors: 15, '  ', path_usage_record.intermediate_errors: 15,
                  '  ', path_usage_record.unrecovered_errors: 15);

            increment_path_sums;

          IFEND;
        FOREND /equip_loop/;
      PROCEND format_path_data;
?? OLDTITLE ??

?? EJECT, NEWTITLE := '            PROCEDURE format_pp_data' ??

      PROCEDURE format_pp_data;

        VAR
          pp_avg_data_transfer: real,
          pp_avg_q_size: real,
          pp_avg_response_time: real,
          pp_avg_seek_and_latency: real,
          pp_avg_wait_in_q: real,
          pp_busy_total: real,
          pp_str_req_count_total: integer,
          pp_str_req_failed_total: integer,
          pp_streamed_success: real,
          pp_time_per_request: real,
          pp_total_seeks: integer,
          pp_utilization: real;

?? EJECT, NEWTITLE := '                PROCEDURE increment_pp_sums' ??

        PROCEDURE increment_pp_sums;

          pp_utilization_sum := pp_utilization_sum + pp_utilization;
          pp_total_requests_sum := pp_total_requests_sum + pp_total_requests;
          pp_avg_response_time_sum := pp_avg_response_time_sum + pp_avg_response_time;
          pp_avg_seek_and_latency_sum := pp_avg_seek_and_latency_sum + pp_avg_seek_and_latency;
          pp_avg_data_transfer_sum := pp_avg_data_transfer_sum + pp_avg_data_transfer;
          pp_time_per_request_sum := pp_time_per_request_sum + pp_time_per_request;
          pp_avg_q_size_sum := pp_avg_q_size_sum + pp_avg_q_size;
          pp_avg_wait_in_q_sum := pp_avg_wait_in_q_sum + pp_avg_wait_in_q;
          pp_str_req_count_read_sum := pp_str_req_count_read_sum +
                user_pp_stats_p^.disk_pp_stats [pp_index].streamed_req_count_read;
          pp_str_req_count_write_sum := pp_str_req_count_write_sum + user_pp_stats_p^.
                disk_pp_stats [pp_index].streamed_req_count_write;
          pp_str_req_count_total_sum := pp_str_req_count_total_sum + pp_str_req_count_total;
          pp_str_req_failed_read_sum := pp_str_req_failed_read_sum + user_pp_stats_p^.
                disk_pp_stats [pp_index].streamed_req_failed_count_read;
          pp_str_req_failed_write_sum := pp_str_req_failed_write_sum + user_pp_stats_p^.
                disk_pp_stats [pp_index].streamed_req_failed_count_write;
          pp_str_req_failed_total_sum := pp_str_req_failed_total_sum + pp_str_req_failed_total;
          pp_streamed_success_sum := pp_streamed_success_sum + pp_streamed_success;

        PROCEND increment_pp_sums;
?? OLDTITLE ??

?? EJECT ??
        NEXT pp_data_p IN pp_data_seq_p;
        pp_data_p^.line_1 := ' ';
        pp_data_p^.line_2 := ' ';

        active_pp_count := active_pp_count + 1;

        pp_busy_total := $REAL (user_pp_stats_p^.disk_pp_stats [pp_index].seek_and_latency_time +
              user_pp_stats_p^.disk_pp_stats [pp_index].computed_data_transfer_time);
        IF time_interval <> 0.0 THEN
          pp_utilization := 100.0 * pp_busy_total / time_interval;
        ELSE
          pp_utilization := 0.0;
        IFEND;

        IF pp_total_requests <> 0 THEN
          pp_avg_response_time := $REAL(pp_total_response_time) / $REAL(pp_total_requests) / 1000.0;
          pp_time_per_request := pp_busy_total / $REAL (pp_total_requests) / 1000.0;
          pp_avg_data_transfer :=
                $REAL(user_pp_stats_p^.disk_pp_stats [pp_index].computed_data_transfer_time) /
                $REAL(pp_total_requests) / 1000.0;
          pp_avg_wait_in_q := ($REAL(pp_total_response_time) - pp_busy_total) /
                $REAL(pp_total_requests) / 1000.0;
        IFEND;

        IF pp_busy_total <> 0.0 THEN
          pp_avg_q_size := ($REAL (pp_total_response_time) / pp_busy_total);
        ELSE
          pp_avg_q_size := 0.0;
        IFEND;

        pp_str_req_count_total := user_pp_stats_p^.disk_pp_stats [pp_index].streamed_req_count_read +
              user_pp_stats_p^.disk_pp_stats [pp_index].streamed_req_count_write;
        pp_str_req_failed_total := user_pp_stats_p^.disk_pp_stats [pp_index].streamed_req_failed_count_read +
              user_pp_stats_p^.disk_pp_stats [pp_index].streamed_req_failed_count_write;

        IF (pp_str_req_count_total + pp_str_req_failed_total) <> 0 THEN
          pp_streamed_success := $REAL (pp_str_req_count_total) /
                $REAL (pp_str_req_count_total + pp_str_req_failed_total) * 100.0;
        ELSE
          pp_streamed_success := 0.0;
        IFEND;

        pp_total_seeks := pp_total_requests - pp_str_req_count_total;
        IF pp_total_seeks <> 0 THEN
          pp_avg_seek_and_latency := $REAL (user_pp_stats_p^.disk_pp_stats [pp_index].seek_and_latency_time) /
                $REAL (pp_total_seeks) / 1000.0;
        ELSE
          pp_avg_seek_and_latency := 0.0;
        IFEND;

        STRINGREP (pp_id_data, length, iou_name: 4, '  ', channel_name: 5);

        STRINGREP (pp_data_p^.line_1, length, '  ', pp_id_data, '  ', pp_utilization: 7: 1, '  ',
              pp_total_requests: 15, '  ', pp_avg_q_size: 10: 2, '  ',  pp_avg_response_time: 10:2, '  ',
              pp_avg_wait_in_q: 10: 2, '  ',  pp_time_per_request: 10: 2, '  ',
              pp_avg_seek_and_latency: 10: 2, '  ', pp_avg_data_transfer: 10: 2);

        STRINGREP (pp_data_p^.line_2, length, '  ', pp_id_data, '  ', user_pp_stats_p^.
              disk_pp_stats [pp_index].streamed_req_count_read: 15, '  ', user_pp_stats_p^.
              disk_pp_stats [pp_index].streamed_req_count_write: 15, '  ', pp_str_req_count_total: 15, '  ',
              user_pp_stats_p^.disk_pp_stats [pp_index].streamed_req_failed_count_read: 15, '  ',
              user_pp_stats_p^.disk_pp_stats [pp_index].streamed_req_failed_count_write: 15, '  ',
              pp_str_req_failed_total: 15, '  ', pp_streamed_success: 7: 1);

        increment_pp_sums;

      PROCEND format_pp_data;
?? OLDTITLE ??

?? EJECT, NEWTITLE := '            PROCEDURE output_path_data' ??

      PROCEDURE output_path_data;

        VAR
          dashes: string (40),
          path_read_bytes_per_read_req: integer,
          path_total_bytes_per_total_req: integer,
          path_wrt_pr_bytes_per_wrt_req: integer;


        dashes (1, 40) := '--------------------------------------';

        clp$new_display_line (display_control, 3, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_display (display_control, '  PATH STATISTICS', clc$trim, status);

{Output Block 1 of Path Statistics

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', 'IOU': 4, '  ', ' CH': 6, '  ', 'Cntrl': 5, '  ', 'Equip': 5, '  ',
              '   Path Read': 15, '  ', '  Path Write': 15, '  ', '  Total Path': 15, '  ', ' Average': 10);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', 'Name': 4, '  ', ' Name': 6, '  ', ' Type': 5, '  ', ' No.': 5, '  ',
              '   Requests': 15, '  ', '   Requests': 15, '  ', '   Requests': 15, '  ', 'Resp Time': 10);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 4): 4, '  ', dashes (1, 6): 6, '  ', dashes (1, 5): 5, '  ',
              dashes (1, 5): 5, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 10): 10);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        RESET path_data_seq_p;

        FOR i := 1 TO active_path_count DO
          NEXT path_data_p IN path_data_seq_p;
          clp$put_display (display_control, path_data_p^.line_1, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 4): 4, '  ', dashes (1, 6): 6, '  ', dashes (1, 5): 5, '  ',
              dashes (1, 5): 5, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 10): 10);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', ' sum': #SIZE (path_id_data), '  ', path_total_reads_sum: 15, '  ',
              path_total_writes_sum: 15, '  ', path_total_requests_sum: 15, '  ', '': 10);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF time_interval_sec <> 0.0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/sec': #SIZE (path_id_data), '  ',
                $REAL (path_total_reads_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (path_total_writes_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (path_total_requests_sum) / time_interval_sec: 15: 2, '  ', '': 10);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF path_total_requests_sum <> 0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/total req': #SIZE (path_id_data),
                '  ', $REAL (path_total_reads_sum) / $REAL (path_total_requests_sum): 15: 2,
                '  ', $REAL (path_total_writes_sum) / $REAL (path_total_requests_sum): 15: 2,
                '  ', $REAL (path_total_requests_sum) / $REAL (path_total_requests_sum): 15: 2, '  ', '': 10);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF active_path_count <> 0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', ' avg': #SIZE (path_id_data), '  ',
                path_total_reads_sum DIV active_path_count: 15, '  ',
                path_total_writes_sum DIV active_path_count: 15, '  ',
                path_total_requests_sum DIV active_path_count: 15, '  ',
                $REAL (path_avg_response_time_sum) / $REAL (active_path_count): 10: 2);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF time_interval_sec <> 0.0 THEN
            line (1, * ) := '  ';
            STRINGREP (line, length, '  ', '/sec': #SIZE (path_id_data), '  ',
                  $REAL (path_total_reads_sum) / $REAL (active_path_count) / time_interval_sec: 15: 2, '  ',
                  $REAL (path_total_writes_sum) / $REAL (active_path_count) / time_interval_sec: 15: 2, '  ',
                  $REAL (path_total_requests_sum) / $REAL (active_path_count) / time_interval_sec: 15: 2);

            clp$put_display (display_control, line, clc$trim, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;


{Output Block 2 of Path Statistics

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', 'IOU': 4, '  ', ' CH': 6, '  ', 'Cntrl': 5, '  ', 'Equip': 5, '  ',
              '     Read': 15, '  ', 'Write Byte_Cnt': 15, '  ', '  Total Path': 15, '  ',
              'Avg Byte_Count ': 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', 'Name': 4, '  ', ' Name': 6, '  ', ' Type': 5, '  ', ' No.': 5, '  ',
              '  Byte_Count': 15, '  ', 'Data and Preset': 15, '  ', '  Byte_Count': 15, '  ',
              '  per Request': 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 4): 4, '  ', dashes (1, 6): 6, '  ', dashes (1, 5): 5, '  ',
              dashes (1, 5): 5, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 15): 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        RESET path_data_seq_p;

        FOR i := 1 TO active_path_count DO
          NEXT path_data_p IN path_data_seq_p;
          clp$put_display (display_control, path_data_p^.line_2, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 4): 4, '  ', dashes (1, 6): 6, '  ', dashes (1, 5): 5, '  ',
              dashes (1, 5): 5, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 15): 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', ' sum': #SIZE (path_id_data), '  ', path_read_byte_count_sum: 15, '  ',
              path_wrt_and_pre_byte_count_sum: 15, '  ', path_total_byte_count_sum: 15, '  ', '': 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF time_interval_sec <> 0.0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/sec': #SIZE (path_id_data),
                '  ', $INTEGER ($REAL (path_read_byte_count_sum) / time_interval_sec):
                15: 2, '  ', $INTEGER ($REAL (path_wrt_and_pre_byte_count_sum) / time_interval_sec): 15: 2,
                '  ', $INTEGER ($REAL (path_total_byte_count_sum) / time_interval_sec): 15: 2, '  ', '': 15);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF path_total_requests_sum <> 0 THEN
          path_total_bytes_per_total_req := path_total_byte_count_sum DIV path_total_requests_sum;
          IF path_total_reads_sum <> 0 THEN
            path_read_bytes_per_read_req := path_read_byte_count_sum DIV path_total_reads_sum;
          ELSE
            path_read_bytes_per_read_req := 0;
          IFEND;

          IF path_total_writes_sum <> 0 THEN
            path_wrt_pr_bytes_per_wrt_req := path_wrt_and_pre_byte_count_sum DIV path_total_writes_sum;
          ELSE
            path_wrt_pr_bytes_per_wrt_req := 0;
          IFEND;

          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/req type': #SIZE (path_id_data), '  ',
                path_read_bytes_per_read_req: 15, '  ', path_wrt_pr_bytes_per_wrt_req: 15, '  ',
                path_total_bytes_per_total_req: 15, '  ', '': 15);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF path_total_byte_count_sum <> 0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', ' pct': #SIZE (path_id_data),
                '  ', $REAL (path_read_byte_count_sum) / $REAL (path_total_byte_count_sum) * 100.0: 15: 2,
                '  ', $REAL (path_wrt_and_pre_byte_count_sum) / $REAL (path_total_byte_count_sum) *
                100.0: 15: 2, '  ', $REAL (path_total_byte_count_sum) / $REAL (path_total_byte_count_sum) *
                100.0: 15: 2, '  ', '': 15);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF active_path_count <> 0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', ' avg': #SIZE (path_id_data), '  ',
                path_read_byte_count_sum DIV active_path_count: 15, '  ',
                path_wrt_and_pre_byte_count_sum DIV active_path_count: 15, '  ',
                path_total_byte_count_sum DIV active_path_count: 15, '  ',
                path_avg_byte_count_per_req_sum DIV active_path_count: 15, '  ', '': 15);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF time_interval_sec <> 0.0 THEN
            line (1, * ) := '  ';
            STRINGREP (line, length, '  ', '/sec': #SIZE (path_id_data),
                  '  ', $INTEGER ($REAL (path_read_byte_count_sum DIV active_path_count) /
                  time_interval_sec): 15: 2, '  ', $INTEGER ($REAL (path_wrt_and_pre_byte_count_sum DIV
                  active_path_count) / time_interval_sec): 15: 2, '  ',
                  $INTEGER ($REAL (path_total_byte_count_sum DIV active_path_count) /
                  time_interval_sec): 15: 2, '  ', '': 15);

            clp$put_display (display_control, line, clc$trim, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;

{Output Block 3 of Path Statisitcs

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', 'IOU': 4, '  ', ' CH': 6, '  ', 'Cntrl': 5, '  ', 'Equip': 5, '  ',
              '   Recovered': 15, '  ', '  Intermediate': 15, '  ', '  Unrecovered': 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', 'Name': 4, '  ', ' Name': 6, '  ', ' Type': 5, '  ', ' No.': 5, '  ',
              '     Errors': 15, '  ', '     Errors': 15, '  ', '     Errors': 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 4): 4, '  ', dashes (1, 6): 6, '  ', dashes (1, 5): 5, '  ',
              dashes (1, 5): 5, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        RESET path_data_seq_p;

        FOR i := 1 TO active_path_count DO
          NEXT path_data_p IN path_data_seq_p;
          clp$put_display (display_control, path_data_p^.line_3, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 4): 4, '  ', dashes (1, 6): 6, '  ', dashes (1, 5): 5, '  ',
              dashes (1, 5): 5, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', ' sum': #SIZE (path_id_data), '  ', path_recovered_errors_sum: 15,
              '  ', path_intermediate_errors_sum: 15, '  ', path_unrecovered_errors_sum: 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      PROCEND output_path_data;
?? OLDTITLE ??

?? EJECT, NEWTITLE := '            PROCEDURE output_pp_data' ??

      PROCEDURE output_pp_data;

        VAR
          dashes: string (40),
          pp_fail_str_reads_per_read_req: real,
          pp_fail_str_reqs_per_total_req: real,
          pp_fail_str_wrts_per_wrt_req: real,
          pp_str_reads_per_read_req: real,
          pp_str_reqs_per_total_req: real,
          pp_str_wrts_per_wrt_req: real;


        dashes (1, 40) := '--------------------------------------';

        clp$new_display_line (display_control, 3, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_display (display_control, '  PP and CHANNEL STATISTICS', clc$trim, status);

{Output Block 1 of PP Statistics

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', 'IOU': 4, '  ', ' CH': 5, '  ', ' PP': 7, '  ', '     Total': 15, '  ',
              ' Average': 10, '  ',' Average': 10, '  ',' Average': 10, '  ', ' Time per': 10, '  ',
              ' Average': 10, '  ',' Average': 10);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', 'Name': 4, '  ', ' Name': 5, '  ', ' Util': 7, '  ',
              '    Requests': 15, '  ', '  Q Size': 10, '  ', 'Resp Time':10, '  ', 'Wait in Q':10, '  ',
              ' Request': 10, '  ','Seek & Lat': 10, '  ', 'Data XFer':10);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;


        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 4): 4, '  ', dashes (1, 5): 5, '  ', dashes (1, 7): 7, '  ',
              dashes (1, 15): 15, '  ', dashes (1, 10): 10, '  ', dashes (1, 10): 10, '  ', dashes (1,
              10): 10, '  ', dashes (1, 10): 10,'  ', dashes (1, 10): 10,'  ', dashes (1, 10): 10);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        RESET pp_data_seq_p;

        FOR i := 1 TO active_pp_count DO
          NEXT pp_data_p IN pp_data_seq_p;
          clp$put_display (display_control, pp_data_p^.line_1, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 4): 4, '  ', dashes (1, 5): 5, '  ', dashes (1, 7): 7, '  ',
              dashes (1, 15): 15, '  ', dashes (1, 10): 10, '  ', dashes (1, 10): 10, '  ', dashes (1,
              10): 10, '  ', dashes (1, 10): 10,'  ', dashes (1, 10): 10,'  ', dashes (1, 10): 10);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', ' sum': #SIZE (pp_id_data), '  ', '': 7, '  ',
              pp_total_requests_sum: 15, '  ', pp_avg_q_size_sum: 10: 2);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF time_interval_sec <> 0.0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/sec': #SIZE (pp_id_data),
                '  ', '': 7, '  ', $REAL (pp_total_requests_sum) / time_interval_sec: 15: 2);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF active_pp_count <> 0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', ' avg': #SIZE (pp_id_data),
                '  ', pp_utilization_sum / $REAL (active_pp_count): 7: 1, '  ',
                pp_total_requests_sum DIV active_pp_count: 15, '  ',
                pp_avg_q_size_sum / $REAL (active_pp_count): 10: 2, '  ',
                pp_avg_response_time_sum / $REAL (active_pp_count): 10: 2, '  ',
                pp_avg_wait_in_q_sum / $REAL (active_pp_count): 10: 2, '  ',
                pp_time_per_request_sum / $REAL (active_pp_count): 10: 2, '  ',
                pp_avg_seek_and_latency_sum / $REAL (active_pp_count): 10: 2, '  ',
                pp_avg_data_transfer_sum / $REAL (active_pp_count): 10: 2);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF time_interval_sec <> 0.0 THEN
            line (1, * ) := '  ';
            STRINGREP (line, length, '  ', '/sec': #SIZE (pp_id_data),
                  '  ', '': 7, '  ', $REAL (pp_total_requests_sum DIV active_pp_count) /
                  time_interval_sec: 15: 2);

            clp$put_display (display_control, line, clc$trim, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;

{Output Block 2 of PP Statistics

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', 'IOU': 4, '  ', ' CH': 5, '  ', ' Read Requests': 15, '  ',
              'Write Requests': 15, '  ', 'Total Requests': 15, '  ', ' Read Req that': 15, '  ',
              'Write Req that': 15, '  ', 'Total Req that': 15, '  ', 'Stream': 7);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', 'Name': 4, '  ', ' Name': 5, '  ', ' that Streamed': 15, '  ',
              'that Streamed': 15, '  ', 'that Streamed': 15, '  ', ' Failed to Str': 15, '  ',
              'Failed to Str': 15, '  ', 'Failed to Str': 15, '  ', 'Success': 7);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 4): 4, '  ', dashes (1, 5): 5, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1,
              15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 7): 7);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        RESET pp_data_seq_p;

        FOR i := 1 TO active_pp_count DO
          NEXT pp_data_p IN pp_data_seq_p;
          clp$put_display (display_control, pp_data_p^.line_2, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 4): 4, '  ', dashes (1, 5): 5, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1,
              15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 7): 7);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', ' sum': #SIZE (pp_id_data), '  ', pp_str_req_count_read_sum: 15, '  ',
              pp_str_req_count_write_sum: 15, '  ', pp_str_req_count_total_sum: 15, '  ',
              pp_str_req_failed_read_sum: 15, '  ', pp_str_req_failed_write_sum: 15, '  ',
              pp_str_req_failed_total_sum: 15, '  ', '': 7);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF time_interval_sec <> 0.0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/sec': #SIZE (pp_id_data), '  ',
                $REAL (pp_str_req_count_read_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (pp_str_req_count_write_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (pp_str_req_count_total_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (pp_str_req_failed_read_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (pp_str_req_failed_write_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (pp_str_req_failed_total_sum) / time_interval_sec: 15: 2, '  ', '': 7);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF pp_total_requests_sum <> 0 THEN
          pp_str_reqs_per_total_req := $REAL (pp_str_req_count_total_sum) / $REAL (pp_total_requests_sum);
          pp_fail_str_reqs_per_total_req := $REAL (pp_str_req_failed_total_sum) /
                $REAL (pp_total_requests_sum);

          IF path_total_reads_sum <> 0 THEN
            pp_str_reads_per_read_req := $REAL (pp_str_req_count_read_sum) / $REAL (path_total_reads_sum);
            pp_fail_str_reads_per_read_req := $REAL (pp_str_req_failed_read_sum) /
                  $REAL (path_total_reads_sum);
          ELSE
            pp_str_reads_per_read_req := 0.0;
            pp_fail_str_reads_per_read_req := 0.0;
          IFEND;

          IF path_total_writes_sum <> 0 THEN
            pp_str_wrts_per_wrt_req := $REAL (pp_str_req_count_write_sum) / $REAL (path_total_writes_sum);
            pp_fail_str_wrts_per_wrt_req := $REAL (pp_str_req_failed_write_sum) /
                  $REAL (path_total_writes_sum);
          ELSE
            pp_str_wrts_per_wrt_req := 0.0;
            pp_fail_str_wrts_per_wrt_req := 0.0;
          IFEND;

          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/req type': #SIZE (pp_id_data), '  ',
                pp_str_reads_per_read_req: 15: 2, '  ', pp_str_wrts_per_wrt_req: 15: 2, '  ',
                pp_str_reqs_per_total_req: 15: 2, '  ', pp_fail_str_reads_per_read_req: 15: 2, '  ',
                pp_fail_str_wrts_per_wrt_req: 15: 2, '  ', pp_fail_str_reqs_per_total_req: 15: 2);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF active_pp_count <> 0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', ' avg': #SIZE (pp_id_data), '  ',
                pp_str_req_count_read_sum DIV active_pp_count: 15, '  ',
                pp_str_req_count_write_sum DIV active_pp_count: 15, '  ',
                pp_str_req_count_total_sum DIV active_pp_count: 15, '  ',
                pp_str_req_failed_read_sum DIV active_pp_count: 15, '  ',
                pp_str_req_failed_write_sum DIV active_pp_count: 15, '  ',
                pp_str_req_failed_total_sum DIV active_pp_count: 15, '  ',
                $REAL (pp_streamed_success_sum) / $REAL (active_pp_count): 7: 1);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF time_interval_sec <> 0.0 THEN
            line (1, * ) := '  ';
            STRINGREP (line, length, '  ', '/sec': #SIZE (pp_id_data),
                  '  ', $REAL (pp_str_req_count_read_sum DIV active_pp_count) / time_interval_sec: 15: 2,
                  '  ', $REAL (pp_str_req_count_write_sum DIV active_pp_count) / time_interval_sec: 15: 2,
                  '  ', $REAL (pp_str_req_count_total_sum DIV active_pp_count) / time_interval_sec: 15: 2,
                  '  ', $REAL (pp_str_req_failed_read_sum DIV active_pp_count) / time_interval_sec: 15: 2,
                  '  ', $REAL (pp_str_req_failed_write_sum DIV active_pp_count) / time_interval_sec: 15: 2,
                  '  ', $REAL (pp_str_req_failed_total_sum DIV active_pp_count) / time_interval_sec: 15: 2,
                  '  ', '': 7);

            clp$put_display (display_control, line, clc$trim, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;

      PROCEND output_pp_data;
?? OLDTITLE ??

?? EJECT ??
      PUSH pp_data_seq_p: [[REP pp_count OF pp_data_record]];
      PUSH path_data_seq_p: [[REP pp_count * 2 * 8 OF path_data_record]];
      active_pp_count := 0;
      active_path_count := 0;

      initialize_pp_sums;
      initialize_path_sums;

    /pp_loop/
      FOR pp_index := 1 TO pp_count DO
        iou_name := 'IOU0';
        IF user_pp_stats_p^.disk_pp_stats [pp_index].iou_number = 1 THEN
          iou_name := 'IOU1';
        IFEND;

        clp$convert_integer_to_rjstring (user_pp_stats_p^.disk_pp_stats [pp_index].channel.number, 10, FALSE,
              '0', channel_name, local_status);
        IF NOT local_status.normal THEN
          channel_name := '     ';
        IFEND;
        IF user_pp_stats_p^.disk_pp_stats [pp_index].channel.concurrent THEN
          channel_name (1, 3) := 'CCH';
        ELSE
          channel_name (1, 3) := ' CH';
        IFEND;

{ pp_total_requests and pp_total_response_time is calculated for each pp
{ by summing the appropriate values for each path on the pp

        pp_total_requests := 0;
        pp_total_response_time := 0;

      /port_loop/
        FOR port_index := 0 TO 1 DO
          IF user_pp_stats_p^.disk_pp_stats [pp_index].channel.concurrent THEN
            IF user_pp_stats_p^.disk_pp_stats [pp_index].channel.port = cmc$unspecified_port THEN
              port_name := ' ';
            ELSE
              IF port_index = 0 THEN
                port_name := 'A';
              ELSE
                port_name := 'B';
              IFEND;
            IFEND;
          ELSE
            port_name := ' ';
          IFEND;

          format_path_data;

        FOREND /port_loop/;
        IF pp_total_requests > 0 THEN

          format_pp_data;

        IFEND;
      FOREND /pp_loop/;
      output_pp_data;
      output_path_data;

    PROCEND report_path_and_pp_data;
?? OLDTITLE ??

?? EJECT, NEWTITLE := '        PROCEDURE report_unit_data' ??

    PROCEDURE report_unit_data;

      TYPE
        unit_data_record = record
          line_1: string (132),
          line_2: string (132),
          line_3: string (132),
          line_4: string (132),
          line_5: string (132),
          line_6: string (132),
        recend;


      VAR
        active_unit_count: integer,
        unit_avg_byte_count_per_req: integer,
        unit_avg_byte_count_per_req_sum: integer,
        unit_data_p: ^unit_data_record,
        unit_data_seq_p: ^SEQ ( * ),
        unit_id_data: string (15),
        unit_intermediate_errors_sum: integer,
        unit_qtime_per_read_req: real,
        unit_qtime_per_read_req_sum: real,
        unit_qtime_per_swap_in_req: real,
        unit_qtime_per_swap_in_req_sum: real,
        unit_qtime_per_swap_out_req: real,
        unit_qtime_per_swap_out_req_sum: real,
        unit_qtime_per_total_req: real,
        unit_qtime_per_total_req_sum: real,
        unit_qtime_per_write_req: real,
        unit_qtime_per_write_req_sum: real,
        unit_read_bytes_sum: integer,
        unit_read_requests_sum: integer,
        unit_recovered_errors_sum: integer,
        unit_req_caus_skipped_cyl_sum: integer,
        unit_str_req_count_read_sum: integer,
        unit_str_req_count_total_sum: integer,
        unit_str_req_count_write_sum: integer,
        unit_str_req_failed_read_sum: integer,
        unit_str_req_failed_total_sum: integer,
        unit_str_req_failed_write_sum: integer,
        unit_streamed_success_sum: real,
        unit_swap_in_bytes_sum: integer,
        unit_swap_in_requests_sum: integer,
        unit_swap_out_data_bytes_sum: integer,
        unit_swap_out_data_pr_bytes_sum: integer,
        unit_swap_out_requests_sum: integer,
        unit_total_bytes_sum: integer,
        unit_total_cyl_skipped_sum: integer,
        unit_total_input_bytes_sum: integer,
        unit_total_input_requests_sum: integer,
        unit_total_output_bytes_sum: integer,
        unit_total_output_requests_sum: integer,
        unit_total_requests_sum: integer,
        unit_total_seeks_sum: integer,
        unit_unrecovered_errors_sum: integer,
        unit_write_data_bytes_sum: integer,
        unit_write_data_pr_bytes_sum: integer,
        unit_write_requests_sum: integer;

?? EJECT, NEWTITLE := '            PROCEDURE initialize_unit_sums' ??

      PROCEDURE initialize_unit_sums;

        unit_avg_byte_count_per_req_sum := 0;
        unit_qtime_per_read_req_sum := 0.0;
        unit_qtime_per_swap_in_req_sum := 0.0;
        unit_qtime_per_swap_out_req_sum := 0.0;
        unit_qtime_per_total_req_sum := 0.0;
        unit_qtime_per_write_req_sum := 0.0;
        unit_read_requests_sum := 0;
        unit_write_requests_sum := 0;
        unit_swap_in_requests_sum := 0;
        unit_swap_out_requests_sum := 0;
        unit_total_requests_sum := 0;
        unit_write_data_bytes_sum := 0;
        unit_write_data_pr_bytes_sum := 0;
        unit_swap_out_data_bytes_sum := 0;
        unit_swap_out_data_pr_bytes_sum := 0;
        unit_total_output_bytes_sum := 0;
        unit_read_bytes_sum := 0;
        unit_swap_in_bytes_sum := 0;
        unit_total_input_bytes_sum := 0;
        unit_total_bytes_sum := 0;
        unit_str_req_count_read_sum := 0;
        unit_str_req_count_write_sum := 0;
        unit_str_req_count_total_sum := 0;
        unit_str_req_failed_read_sum := 0;
        unit_str_req_failed_write_sum := 0;
        unit_str_req_failed_total_sum := 0;
        unit_total_seeks_sum := 0;
        unit_req_caus_skipped_cyl_sum := 0;
        unit_total_cyl_skipped_sum := 0;
        unit_recovered_errors_sum := 0;
        unit_intermediate_errors_sum := 0;
        unit_unrecovered_errors_sum := 0;
        unit_streamed_success_sum := 0.0;
        unit_total_output_requests_sum := 0;
        unit_total_input_requests_sum := 0;

      PROCEND initialize_unit_sums;
?? OLDTITLE ??

?? EJECT, NEWTITLE := '            PROCEDURE format_unit_data' ??

      PROCEDURE format_unit_data;

        VAR
          unit_index: integer,
          unit_seeks: integer,
          unit_str_req_count_total: integer,
          unit_str_req_failed_total: integer,
          unit_streamed_success: real,
          unit_total_bytes: integer,
          unit_total_input_bytes: integer,
          unit_total_output_bytes: integer,
          unit_total_qtime: integer,
          unit_total_requests: integer,
          unit_type: string (7);


?? EJECT, NEWTITLE := '                PROCEDURE increment_unit_sums' ??

        PROCEDURE increment_unit_sums;

          unit_read_requests_sum := unit_read_requests_sum +
                user_unit_stats_p^.disk_unit_stats [unit_index].read_requests;
          unit_write_requests_sum := unit_write_requests_sum + user_unit_stats_p^.
                disk_unit_stats [unit_index].write_requests;
          unit_swap_in_requests_sum := unit_swap_in_requests_sum + user_unit_stats_p^.
                disk_unit_stats [unit_index].swap_in_requests;
          unit_swap_out_requests_sum := unit_swap_out_requests_sum + user_unit_stats_p^.
                disk_unit_stats [unit_index].swap_out_requests;
          unit_total_requests_sum := unit_total_requests_sum + unit_total_requests;
          unit_write_data_bytes_sum := unit_write_data_bytes_sum +
                (user_unit_stats_p^.disk_unit_stats [unit_index].write_data_mau_count *
                user_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau);
          unit_write_data_pr_bytes_sum := unit_write_data_pr_bytes_sum +
                (user_unit_stats_p^.disk_unit_stats [unit_index].write_data_and_preset_maus *
                user_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau);
          unit_swap_out_data_bytes_sum := unit_swap_out_data_bytes_sum +
                (user_unit_stats_p^.disk_unit_stats [unit_index].swap_out_data_mau_count *
                user_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau);
          unit_swap_out_data_pr_bytes_sum := unit_swap_out_data_pr_bytes_sum +
                (user_unit_stats_p^.disk_unit_stats [unit_index].swap_out_data_and_preset_maus *
                user_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau);
          unit_total_output_bytes_sum := unit_total_output_bytes_sum + unit_total_output_bytes;
          unit_read_bytes_sum := unit_read_bytes_sum + (user_unit_stats_p^.disk_unit_stats [unit_index].
                read_mau_count * user_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau);
          unit_swap_in_bytes_sum := unit_swap_in_bytes_sum +
                (user_unit_stats_p^.disk_unit_stats [unit_index].swap_in_mau_count *
                user_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau);
          unit_total_input_bytes_sum := unit_total_input_bytes_sum + unit_total_input_bytes;
          unit_total_bytes_sum := unit_total_bytes_sum + unit_total_bytes;
          unit_avg_byte_count_per_req_sum := unit_avg_byte_count_per_req_sum + unit_avg_byte_count_per_req;
          unit_qtime_per_read_req_sum := unit_qtime_per_read_req_sum + unit_qtime_per_read_req;
          unit_qtime_per_write_req_sum := unit_qtime_per_write_req_sum + unit_qtime_per_write_req;
          unit_qtime_per_swap_in_req_sum := unit_qtime_per_swap_in_req_sum + unit_qtime_per_swap_in_req;
          unit_qtime_per_swap_out_req_sum := unit_qtime_per_swap_out_req_sum + unit_qtime_per_swap_out_req;
          unit_qtime_per_total_req_sum := unit_qtime_per_total_req_sum + unit_qtime_per_total_req;
          unit_str_req_count_read_sum := unit_str_req_count_read_sum + user_unit_stats_p^.
                disk_unit_stats [unit_index].streamed_req_count_read;
          unit_str_req_count_write_sum := unit_str_req_count_write_sum + user_unit_stats_p^.
                disk_unit_stats [unit_index].streamed_req_count_write;
          unit_str_req_count_total_sum := unit_str_req_count_total_sum + unit_str_req_count_total;
          unit_str_req_failed_read_sum := unit_str_req_failed_read_sum + user_unit_stats_p^.
                disk_unit_stats [unit_index].streamed_req_failed_count_read;
          unit_str_req_failed_write_sum := unit_str_req_failed_write_sum +
                user_unit_stats_p^.disk_unit_stats [unit_index].streamed_req_failed_count_write;
          unit_str_req_failed_total_sum := unit_str_req_failed_total_sum + unit_str_req_failed_total;
          unit_streamed_success_sum := unit_streamed_success_sum + unit_streamed_success;
          unit_total_seeks_sum := unit_total_seeks_sum + (unit_total_requests - unit_str_req_count_total);
          unit_req_caus_skipped_cyl_sum := unit_req_caus_skipped_cyl_sum +
                user_unit_stats_p^.disk_unit_stats [unit_index].requests_causing_skipped_cyl;
          unit_total_cyl_skipped_sum := unit_total_cyl_skipped_sum + user_unit_stats_p^.
                disk_unit_stats [unit_index].total_cylinders_skipped;
          unit_recovered_errors_sum := unit_recovered_errors_sum + user_unit_stats_p^.
                disk_unit_stats [unit_index].recovered_errors;
          unit_intermediate_errors_sum := unit_intermediate_errors_sum + user_unit_stats_p^.
                disk_unit_stats [unit_index].intermediate_errors;
          unit_unrecovered_errors_sum := unit_unrecovered_errors_sum + user_unit_stats_p^.
                disk_unit_stats [unit_index].unrecovered_errors;

        PROCEND increment_unit_sums;
?? OLDTITLE ??

?? EJECT ??

      /unit_loop/
        FOR unit_index := 1 TO unit_count DO
          IF user_unit_stats_p^.disk_unit_stats [unit_index].unit_used THEN
            NEXT unit_data_p IN unit_data_seq_p;
            unit_data_p^.line_1 := ' ';
            unit_data_p^.line_2 := ' ';
            unit_data_p^.line_3 := ' ';
            unit_data_p^.line_4 := ' ';
            unit_data_p^.line_5 := ' ';
            unit_data_p^.line_6 := ' ';

            active_unit_count := active_unit_count + 1;

            CASE user_unit_stats_p^.disk_unit_stats [unit_index].unit_type OF
            = ioc$dt_ms844_4x =
              unit_type := '  844';
            = ioc$dt_ms885_1x, ioc$dt_ms885_42 =
              unit_type := '  885';
            = ioc$dt_ms834_2 =
              unit_type := '  834';
            = ioc$dt_msfsd_2 =
              unit_type := '  836';
            = ioc$dt_ms895_2 =
              unit_type := '  895';
            = ioc$dt_mshydra =
              unit_type := '  887';
            = ioc$dt_ms9836_1 =
              unit_type := ' 9836';
            = ioc$dt_msxmd_3 =
              unit_type := ' 9853';
            = ioc$dt_ms5832_1 =
              unit_type := '5832_1';
            = ioc$dt_ms5832_2 =
              unit_type := '5832_2';
            = ioc$dt_ms5833_1 =
              unit_type := '5833_1';
            = ioc$dt_ms5833_1p =
              unit_type := '5833_1P';
            = ioc$dt_ms5833_2 =
              unit_type := '5833_2';
            = ioc$dt_ms5833_3p =
              unit_type := '5833_3P';
            = ioc$dt_ms5833_4 =
              unit_type := '5833_4';
            = ioc$dt_ms5838_1 =
              unit_type := '5838_1';
            = ioc$dt_ms5838_1p =
              unit_type := '5838_1P';
            = ioc$dt_ms5838_2 =
              unit_type := '5838_2';
            = ioc$dt_ms5838_3p =
              unit_type := '5838_3P';
            = ioc$dt_ms5838_4 =
              unit_type := '5838_4';
            = ioc$dt_ms47444_1 =
              unit_type := '47444_1';
            = ioc$dt_ms47444_1p =
              unit_type := '47444_1P';
            = ioc$dt_ms47444_2 =
              unit_type := '47444_2';
            = ioc$dt_ms47444_3p =
              unit_type := '47444_3P';
            = ioc$dt_ms47444_4 =
              unit_type := '47444_4';
            ELSE
              unit_type := '    ';
            CASEND;

            STRINGREP (unit_id_data, length, user_unit_stats_p^.disk_unit_stats [unit_index].recorded_vsn: 6,
                  '  ', unit_type: 7);

            unit_total_requests := user_unit_stats_p^.disk_unit_stats [unit_index].read_requests +
                  user_unit_stats_p^.disk_unit_stats [unit_index].write_requests +
                  user_unit_stats_p^.disk_unit_stats [unit_index].swap_in_requests +
                  user_unit_stats_p^.disk_unit_stats [unit_index].swap_out_requests;

            unit_total_output_bytes := (user_unit_stats_p^.disk_unit_stats [unit_index].
                  write_data_and_preset_maus + user_unit_stats_p^.disk_unit_stats [unit_index].
                  swap_out_data_and_preset_maus) * user_unit_stats_p^.disk_unit_stats [unit_index].
                  bytes_per_mau;

            unit_total_input_bytes := (user_unit_stats_p^.disk_unit_stats [unit_index].read_mau_count +
                  user_unit_stats_p^.disk_unit_stats [unit_index].swap_in_mau_count) *
                  user_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau;

            unit_total_bytes := unit_total_output_bytes + unit_total_input_bytes;

            IF unit_total_requests <> 0 THEN
              unit_avg_byte_count_per_req := unit_total_bytes DIV unit_total_requests;
            ELSE
              unit_avg_byte_count_per_req := 0;
            IFEND;

            unit_total_qtime := user_unit_stats_p^.disk_unit_stats [unit_index].read_qtime +
                  user_unit_stats_p^.disk_unit_stats [unit_index].write_qtime +
                  user_unit_stats_p^.disk_unit_stats [unit_index].swap_in_qtime +
                  user_unit_stats_p^.disk_unit_stats [unit_index].swap_out_qtime;

            IF user_unit_stats_p^.disk_unit_stats [unit_index].read_requests <> 0 THEN
              unit_qtime_per_read_req := $REAL (user_unit_stats_p^.disk_unit_stats [unit_index].read_qtime) /
                    $REAL (user_unit_stats_p^.disk_unit_stats [unit_index].read_requests) / 1000.0;
            ELSE
              unit_qtime_per_read_req := 0.0;
            IFEND;

            IF user_unit_stats_p^.disk_unit_stats [unit_index].write_requests <> 0 THEN
              unit_qtime_per_write_req := $REAL (user_unit_stats_p^.disk_unit_stats [unit_index].
                    write_qtime) / $REAL (user_unit_stats_p^.disk_unit_stats [unit_index].write_requests) /
                    1000.0;
            ELSE
              unit_qtime_per_write_req := 0.0;
            IFEND;

            IF user_unit_stats_p^.disk_unit_stats [unit_index].swap_in_requests <> 0 THEN
              unit_qtime_per_swap_in_req := $REAL (user_unit_stats_p^.disk_unit_stats [unit_index].
                    swap_in_qtime) / $REAL (user_unit_stats_p^.disk_unit_stats [unit_index].
                    swap_in_requests) / 1000.0;
            ELSE
              unit_qtime_per_swap_in_req := 0.0;
            IFEND;

            IF user_unit_stats_p^.disk_unit_stats [unit_index].swap_out_requests <> 0 THEN
              unit_qtime_per_swap_out_req := $REAL (user_unit_stats_p^.disk_unit_stats [unit_index].
                    swap_out_qtime) / $REAL (user_unit_stats_p^.disk_unit_stats [unit_index].
                    swap_out_requests) / 1000.0;
            ELSE
              unit_qtime_per_swap_out_req := 0.0;
            IFEND;

            IF unit_total_qtime <> 0 THEN
              unit_qtime_per_total_req := $REAL (unit_total_qtime) / $REAL (unit_total_requests) / 1000.0;
            ELSE
              unit_qtime_per_total_req := 0.0;
            IFEND;

            unit_str_req_count_total := user_unit_stats_p^.disk_unit_stats [unit_index].
                  streamed_req_count_read + user_unit_stats_p^.disk_unit_stats [unit_index].
                  streamed_req_count_write;

            unit_str_req_failed_total := user_unit_stats_p^.disk_unit_stats [unit_index].
                  streamed_req_failed_count_read + user_unit_stats_p^.disk_unit_stats [unit_index].
                  streamed_req_failed_count_write;

            IF (unit_str_req_count_total + unit_str_req_failed_total) <> 0 THEN
              unit_streamed_success := $REAL (unit_str_req_count_total) /
                    $REAL (unit_str_req_count_total + unit_str_req_failed_total) * 100.0;
            ELSE
              unit_streamed_success := 0.0;
            IFEND;

            unit_seeks := unit_total_requests - unit_str_req_count_total;

            STRINGREP (unit_data_p^.line_1, length, '  ', unit_id_data, '  ',
                  user_unit_stats_p^.disk_unit_stats [unit_index].read_requests: 15, '  ',
                  user_unit_stats_p^.disk_unit_stats [unit_index].write_requests: 15, '  ',
                  user_unit_stats_p^.disk_unit_stats [unit_index].swap_in_requests: 15, '  ',
                  user_unit_stats_p^.disk_unit_stats [unit_index].swap_out_requests: 15, '  ',
                  unit_total_requests: 15);


            STRINGREP (unit_data_p^.line_2, length, '  ', unit_id_data, '  ',
                  user_unit_stats_p^.disk_unit_stats [unit_index].write_data_mau_count *
                  user_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau: 15, '  ',
                  user_unit_stats_p^.disk_unit_stats [unit_index].write_data_and_preset_maus *
                  user_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau: 15, '  ',
                  user_unit_stats_p^.disk_unit_stats [unit_index].swap_out_data_mau_count *
                  user_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau: 15, '  ',
                  user_unit_stats_p^.disk_unit_stats [unit_index].swap_out_data_and_preset_maus *
                  user_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau: 15, '  ',
                  unit_total_output_bytes: 15);


            STRINGREP (unit_data_p^.line_3, length, '  ', unit_id_data, '  ',
                  user_unit_stats_p^.disk_unit_stats [unit_index].read_mau_count *
                  user_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau: 15, '  ',
                  user_unit_stats_p^.disk_unit_stats [unit_index].swap_in_mau_count *
                  user_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau: 15, '  ',
                  unit_total_input_bytes: 15, '  ', unit_total_bytes: 15, '  ',
                  unit_avg_byte_count_per_req: 15);


            STRINGREP (unit_data_p^.line_4, length, '  ', unit_id_data, '  ', unit_qtime_per_read_req: 15: 2,
                  '  ', unit_qtime_per_write_req: 15: 2, '  ', unit_qtime_per_swap_in_req: 15: 2, '  ',
                  unit_qtime_per_swap_out_req: 15: 2, '  ', unit_qtime_per_total_req: 15: 2);

            STRINGREP (unit_data_p^.line_5, length, '  ', unit_id_data, '  ',
                  user_unit_stats_p^.disk_unit_stats [unit_index].streamed_req_count_read: 15, '  ',
                  user_unit_stats_p^.disk_unit_stats [unit_index].streamed_req_count_write: 15, '  ',
                  unit_str_req_count_total: 15, '  ', user_unit_stats_p^.disk_unit_stats [unit_index].
                  streamed_req_failed_count_read: 15, '  ', user_unit_stats_p^.disk_unit_stats [unit_index].
                  streamed_req_failed_count_write: 15, '  ', unit_str_req_failed_total: 15, '  ',
                  unit_streamed_success: 7: 1);


            STRINGREP (unit_data_p^.line_6, length, '  ', unit_id_data, '  ',
                  unit_total_requests - unit_str_req_count_total: 15, '  ',
                  user_unit_stats_p^.disk_unit_stats [unit_index].requests_causing_skipped_cyl: 15, '  ',
                  user_unit_stats_p^.disk_unit_stats [unit_index].total_cylinders_skipped: 15, '  ',
                  user_unit_stats_p^.disk_unit_stats [unit_index].recovered_errors: 15, '  ',
                  user_unit_stats_p^.disk_unit_stats [unit_index].intermediate_errors: 15, '  ',
                  user_unit_stats_p^.disk_unit_stats [unit_index].unrecovered_errors: 15);


            increment_unit_sums;

          IFEND;
        FOREND /unit_loop/;
      PROCEND format_unit_data;
?? OLDTITLE ??

?? EJECT, NEWTITLE := '            PROCEDURE output_unit_data' ??

      PROCEDURE output_unit_data;

        VAR
          dashes: string (40),
          unit_input_bytes_per_input_req: integer,
          unit_read_bytes_per_read: integer,
          unit_read_qtime_per_read: integer,
          unit_si_bytes_per_si: integer,
          unit_si_qtime_per_si: integer,
          unit_so_data_bytes_per_so: integer,
          unit_so_data_pr_bytes_per_so: integer,
          unit_so_qtime_per_so: integer,
          unit_str_reads_per_read: real,
          unit_str_reads_fail_per_read: real,
          unit_str_req_count_read_pct: real,
          unit_str_req_count_write_pct: real,
          unit_str_req_count_total_pct: real,
          unit_str_req_failed_read_pct: real,
          unit_str_req_failed_write_pct: real,
          unit_str_req_failed_total_pct: real,
          unit_str_tot_fail_per_tot_req: real,
          unit_str_tot_per_tot_req: real,
          unit_str_writes_fail_per_write: real,
          unit_str_writes_per_write: real,
          unit_tot_bytes_per_tot_req: integer,
          unit_tot_out_bytes_per_tot_out: integer,
          unit_tot_qtime_per_tot_req: integer,
          unit_write_data_bytes_per_write: integer,
          unit_write_qtime_per_write: integer,
          unit_wrt_data_pr_bytes_per_wrt: integer;

        dashes (1, 40) := '--------------------------------------';

        clp$new_display_line (display_control, 3, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_display (display_control, '  UNIT STATISTICS', clc$trim, status);

{Output Block 1 of Unit Statistics

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', ' Unit': 6, '  ', ' Unit': 7, '  ', ' Read Requests': 15, '  ',
              'Write Requests': 15, '  ', '    Swapin': 15, '  ', '    Swapout': 15, '  ', '     Total': 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', '  VSN': 6, '  ', ' Type': 7, '  ', ' (w/o Swapin)': 15, '  ',
              ' (w/o Swapout)': 15, '  ', '   Requests': 15, '  ', '   Requests': 15, '  ',
              '   Requests': 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 6): 6, '  ', dashes (1, 7): 7, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1,
              15): 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        RESET unit_data_seq_p;

        FOR i := 1 TO active_unit_count DO
          NEXT unit_data_p IN unit_data_seq_p;
          clp$put_display (display_control, unit_data_p^.line_1, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 6): 6, '  ', dashes (1, 7): 7, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1,
              15): 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', ' sum': #SIZE (unit_id_data), '  ', unit_read_requests_sum: 15, '  ',
              unit_write_requests_sum: 15, '  ', unit_swap_in_requests_sum: 15, '  ',
              unit_swap_out_requests_sum: 15, '  ', unit_total_requests_sum: 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF time_interval_sec <> 0.0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/sec': #SIZE (unit_id_data), '  ',
                $REAL (unit_read_requests_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (unit_write_requests_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (unit_swap_in_requests_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (unit_swap_out_requests_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (unit_total_requests_sum) / time_interval_sec: 15: 2);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF unit_total_requests_sum <> 0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/total req': #SIZE (unit_id_data),
                '  ', $REAL (unit_read_requests_sum) / $REAL (unit_total_requests_sum): 15: 2,
                '  ', $REAL (unit_write_requests_sum) / $REAL (unit_total_requests_sum): 15: 2,
                '  ', $REAL (unit_swap_in_requests_sum) / $REAL (unit_total_requests_sum): 15: 2, '  ',
                $REAL (unit_swap_out_requests_sum) / $REAL (unit_total_requests_sum): 15: 2,
                '  ', $REAL ($REAL (unit_total_requests_sum)) / $REAL (unit_total_requests_sum): 15: 2);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF unit_total_seeks_sum <> 0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/sk': #SIZE (unit_id_data), '  ', '': 15, '  ', '': 15, '  ',
                '': 15, '  ', '': 15, '  ', $REAL (unit_total_requests_sum) / $REAL (unit_total_seeks_sum):
                15: 2);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF active_unit_count <> 0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', ' avg': #SIZE (unit_id_data), '  ',
                unit_read_requests_sum DIV active_unit_count: 15, '  ',
                unit_write_requests_sum DIV active_unit_count: 15, '  ',
                unit_swap_in_requests_sum DIV active_unit_count: 15, '  ',
                unit_swap_out_requests_sum DIV active_unit_count: 15, '  ',
                unit_total_requests_sum DIV active_unit_count: 15);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF time_interval_sec <> 0.0 THEN
            line (1, * ) := '  ';
            STRINGREP (line, length, '  ', '/sec': #SIZE (unit_id_data),
                  '  ', $REAL (unit_read_requests_sum DIV active_unit_count) / time_interval_sec: 15: 2, '  ',
                  $REAL (unit_write_requests_sum DIV active_unit_count) / time_interval_sec: 15: 2, '  ',
                  $REAL (unit_swap_in_requests_sum DIV active_unit_count) / time_interval_sec: 15: 2, '  ',
                  $REAL (unit_swap_out_requests_sum DIV active_unit_count) / time_interval_sec: 15: 2, '  ',
                  $REAL (unit_total_requests_sum DIV active_unit_count) / time_interval_sec: 15: 2);

            clp$put_display (display_control, line, clc$trim, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;

{Output Block 2 of Unit Statistics

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', ' Unit': 6, '  ', ' Unit': 7, '  ', 'Write w/o Swap': 15, '  ',
              'Write w/o Swap': 15, '  ', '    Swapout': 15, '  ', '    Swapout': 15, '  ',
              '  Total Write': 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', '  VSN': 6, '  ', ' Type': 7, '  ', 'Byt_Cnt (Data)': 15, '  ',
              'Byt_Cnt (D&PR)': 15, '  ', 'Byt_Cnt (Data)': 15, '  ', 'Byt_Cnt (D&PR)': 15, '  ',
              'Byt_Cnt (D&PR)': 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 6): 6, '  ', dashes (1, 7): 7, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1,
              15): 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        RESET unit_data_seq_p;

        FOR i := 1 TO active_unit_count DO
          NEXT unit_data_p IN unit_data_seq_p;
          clp$put_display (display_control, unit_data_p^.line_2, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 6): 6, '  ', dashes (1, 7): 7, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1,
              15): 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', ' sum': #SIZE (unit_id_data), '  ', unit_write_data_bytes_sum: 15,
              '  ', unit_write_data_pr_bytes_sum: 15, '  ', unit_swap_out_data_bytes_sum: 15, '  ',
              unit_swap_out_data_pr_bytes_sum: 15, '  ', unit_total_output_bytes_sum: 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF time_interval_sec <> 0.0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/sec': #SIZE (unit_id_data),
                '  ', $INTEGER ($REAL (unit_write_data_bytes_sum) / time_interval_sec): 15: 2, '  ',
                $INTEGER ($REAL (unit_write_data_pr_bytes_sum) / time_interval_sec):
                15: 2, '  ', $INTEGER ($REAL (unit_swap_out_data_bytes_sum) / time_interval_sec): 15: 2, '  ',
                $INTEGER ($REAL (unit_swap_out_data_pr_bytes_sum) / time_interval_sec): 15: 2, '  ',
                $INTEGER ($REAL (unit_total_output_bytes_sum) / time_interval_sec): 15: 2);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        unit_total_output_requests_sum := unit_write_requests_sum + unit_swap_out_requests_sum;
        IF unit_total_output_requests_sum <> 0 THEN
          unit_tot_out_bytes_per_tot_out := unit_total_output_bytes_sum DIV unit_total_output_requests_sum;

          IF unit_swap_out_requests_sum <> 0 THEN
            unit_so_data_bytes_per_so := unit_swap_out_data_bytes_sum DIV unit_swap_out_requests_sum;
            unit_so_data_pr_bytes_per_so := unit_swap_out_data_pr_bytes_sum DIV unit_swap_out_requests_sum;
          ELSE
            unit_so_data_bytes_per_so := 0;
            unit_so_data_pr_bytes_per_so := 0;
          IFEND;

          IF unit_write_requests_sum <> 0 THEN
            unit_write_data_bytes_per_write := unit_write_data_bytes_sum DIV unit_write_requests_sum;
            unit_wrt_data_pr_bytes_per_wrt := unit_write_data_pr_bytes_sum DIV unit_write_requests_sum;
          ELSE
            unit_write_data_bytes_per_write := 0;
            unit_wrt_data_pr_bytes_per_wrt := 0;
          IFEND;

          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/req type': #SIZE (unit_id_data), '  ',
                unit_write_data_bytes_per_write: 15, '  ', unit_wrt_data_pr_bytes_per_wrt: 15, '  ',
                unit_so_data_bytes_per_so: 15, '  ', unit_so_data_pr_bytes_per_so: 15, '  ',
                unit_tot_out_bytes_per_tot_out: 15);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;


        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF active_unit_count <> 0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', ' avg': #SIZE (unit_id_data), '  ',
                unit_write_data_bytes_sum DIV active_unit_count: 15, '  ',
                unit_write_data_pr_bytes_sum DIV active_unit_count: 15, '  ',
                unit_swap_out_data_bytes_sum DIV active_unit_count: 15, '  ',
                unit_swap_out_data_pr_bytes_sum DIV active_unit_count: 15, '  ',
                unit_total_output_bytes_sum DIV active_unit_count: 15);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF time_interval_sec <> 0.0 THEN
            line (1, * ) := '  ';
            STRINGREP (line, length, '  ', '/sec': #SIZE (unit_id_data),
                  '  ', $INTEGER ($REAL (unit_write_data_bytes_sum DIV active_unit_count) /
                  time_interval_sec): 15, '  ', $INTEGER ($REAL (unit_write_data_pr_bytes_sum DIV
                  active_unit_count) / time_interval_sec): 15, '  ',
                  $INTEGER ($REAL (unit_swap_out_data_bytes_sum DIV active_unit_count) /
                  time_interval_sec): 15, '  ', $INTEGER ($REAL (unit_swap_out_data_pr_bytes_sum DIV
                  active_unit_count) / time_interval_sec): 15, '  ',
                  $INTEGER ($REAL (unit_total_output_bytes_sum DIV active_unit_count) /
                  time_interval_sec): 15);

            clp$put_display (display_control, line, clc$trim, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;

{Output Block 3 of Unit Statistics

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', ' Unit': 6, '  ', ' Unit': 7, '  ', ' Read w/o Swap': 15, '  ',
              '    Swapin': 15, '  ', '  Total Read': 15, '  ', '  Total Unit': 15, '  ',
              'Avg Byte_Count': 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', '  VSN': 6, '  ', ' Type': 7, '  ', '  Byte_Count': 15, '  ',
              '  Byte_Count': 15, '  ', '  Byte_Count': 15, '  ', '  Byte_Count': 15, '  ',
              '  per Request': 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 6): 6, '  ', dashes (1, 7): 7, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1,
              15): 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        RESET unit_data_seq_p;

        FOR i := 1 TO active_unit_count DO
          NEXT unit_data_p IN unit_data_seq_p;
          clp$put_display (display_control, unit_data_p^.line_3, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 6): 6, '  ', dashes (1, 7): 7, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1,
              15): 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', ' sum': #SIZE (unit_id_data), '  ', unit_read_bytes_sum: 15, '  ',
              unit_swap_in_bytes_sum: 15, '  ', unit_total_input_bytes_sum: 15, '  ',
              unit_total_bytes_sum: 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF time_interval_sec <> 0.0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/sec': #SIZE (unit_id_data),
                '  ', $INTEGER ($REAL (unit_read_bytes_sum) / time_interval_sec): 15, '  ',
                $INTEGER ($REAL (unit_swap_in_bytes_sum) / time_interval_sec): 15, '  ',
                $INTEGER ($REAL (unit_total_input_bytes_sum) / time_interval_sec): 15, '  ',
                $INTEGER ($REAL (unit_total_bytes_sum) / time_interval_sec): 15);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF unit_total_requests_sum <> 0 THEN
          unit_tot_bytes_per_tot_req := unit_total_bytes_sum DIV unit_total_requests_sum;
          unit_total_input_requests_sum := unit_read_requests_sum + unit_swap_in_requests_sum;
          IF unit_total_input_requests_sum <> 0 THEN
            unit_input_bytes_per_input_req := unit_total_input_bytes_sum DIV unit_total_input_requests_sum;
            IF unit_swap_in_requests_sum <> 0 THEN
              unit_si_bytes_per_si := unit_swap_in_bytes_sum DIV unit_swap_in_requests_sum;
            ELSE
              unit_si_bytes_per_si := 0;
            IFEND;
            IF unit_read_requests_sum <> 0 THEN
              unit_read_bytes_per_read := unit_read_bytes_sum DIV unit_read_requests_sum;
            ELSE
              unit_read_bytes_per_read := 0;
            IFEND;
          ELSE
            unit_si_bytes_per_si := 0;
            unit_read_bytes_per_read := 0;
            unit_input_bytes_per_input_req := 0;
          IFEND;

          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/req type': #SIZE (unit_id_data), '  ',
                unit_read_bytes_per_read: 15, '  ', unit_si_bytes_per_si: 15, '  ',
                unit_input_bytes_per_input_req: 15, '  ', unit_tot_bytes_per_tot_req: 15);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF active_unit_count <> 0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', ' avg': #SIZE (unit_id_data), '  ',
                unit_read_bytes_sum DIV active_unit_count: 15, '  ',
                unit_swap_in_bytes_sum DIV active_unit_count: 15, '  ',
                unit_total_input_bytes_sum DIV active_unit_count: 15, '  ',
                unit_total_bytes_sum DIV active_unit_count: 15, '  ',
                unit_avg_byte_count_per_req_sum DIV active_unit_count: 15);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF time_interval_sec <> 0.0 THEN
            line (1, * ) := '  ';
            STRINGREP (line, length, '  ', '/sec': #SIZE (unit_id_data),
                  '  ', $INTEGER ($REAL (unit_read_bytes_sum DIV active_unit_count) / time_interval_sec): 15,
                  '  ', $INTEGER ($REAL (unit_swap_in_bytes_sum DIV active_unit_count) /
                  time_interval_sec): 15, '  ', $INTEGER ($REAL (unit_total_input_bytes_sum DIV
                  active_unit_count) / time_interval_sec): 15, '  ',
                  $INTEGER ($REAL (unit_total_bytes_sum DIV active_unit_count) / time_interval_sec): 15);

            clp$put_display (display_control, line, clc$trim, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;

{Output Block 4 of Unit Statistics

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', ' Unit': 6, '  ', ' Unit': 7, '  ', ' Read w/o Swap': 15, '  ',
              'Write w/o Swap': 15, '  ', '    Swapin': 15, '  ', '    Swapout': 15, '  ',
              '  Total Unit': 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', '  VSN': 6, '  ', ' Type': 7, '  ', ' Avg Resp Time': 15, '  ',
              ' Avg Resp Time': 15, '  ',' Avg Resp Time': 15, '  ',' Avg Resp Time': 15, '  ',
              ' Avg Resp Time': 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 6): 6, '  ', dashes (1, 7): 7, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1,
              15): 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        RESET unit_data_seq_p;

        FOR i := 1 TO active_unit_count DO
          NEXT unit_data_p IN unit_data_seq_p;
          clp$put_display (display_control, unit_data_p^.line_4, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 6): 6, '  ', dashes (1, 7): 7, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1,
              15): 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF active_unit_count <> 0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', ' avg': #SIZE (unit_id_data), '  ',
                unit_qtime_per_read_req_sum / $REAL (active_unit_count): 15: 2, '  ',
                unit_qtime_per_write_req_sum / $REAL (active_unit_count): 15: 2, '  ',
                unit_qtime_per_swap_in_req_sum / $REAL (active_unit_count): 15: 2, '  ',
                unit_qtime_per_swap_out_req_sum / $REAL (active_unit_count): 15: 2, '  ',
                unit_qtime_per_total_req_sum / $REAL (active_unit_count): 15: 2);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

{Output Block 5 of Unit Statistics

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', ' Unit': 6, '  ', ' Unit': 7, '  ', ' Read Requests': 15, '  ',
              'Write Requests': 15, '  ', 'Total Requests': 15, '  ', ' Read Req that': 15, '  ',
              'Write Req that': 15, '  ', 'Total Req that': 15, '  ', 'Stream': 7);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', '  VSN': 6, '  ', ' Type': 7, '  ', ' that Streamed': 15, '  ',
              ' that Streamed': 15, '  ', ' that Streamed': 15, '  ', ' Failed to Str': 15, '  ',
              ' Failed to Str': 15, '  ', ' Failed to Str': 15, '  ', 'Success': 7);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 6): 6, '  ', dashes (1, 7): 7, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1,
              15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 7): 7);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        RESET unit_data_seq_p;

        FOR i := 1 TO active_unit_count DO
          NEXT unit_data_p IN unit_data_seq_p;
          clp$put_display (display_control, unit_data_p^.line_5, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 6): 6, '  ', dashes (1, 7): 7, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1,
              15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 7): 7);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', ' sum': #SIZE (unit_id_data), '  ', unit_str_req_count_read_sum: 15,
              '  ', unit_str_req_count_write_sum: 15, '  ', unit_str_req_count_total_sum: 15, '  ',
              unit_str_req_failed_read_sum: 15, '  ', unit_str_req_failed_write_sum: 15, '  ',
              unit_str_req_failed_total_sum: 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF time_interval_sec <> 0.0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/sec': #SIZE (unit_id_data),
                '  ', $REAL (unit_str_req_count_read_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (unit_str_req_count_write_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (unit_str_req_count_total_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (unit_str_req_failed_read_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (unit_str_req_failed_write_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (unit_str_req_failed_total_sum) / time_interval_sec: 15: 2);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF unit_total_requests_sum <> 0 THEN

          unit_str_tot_per_tot_req := $REAL (unit_str_req_count_total_sum) / $REAL (unit_total_requests_sum);
          unit_str_tot_fail_per_tot_req := $REAL (unit_str_req_failed_total_sum) /
                $REAL (unit_total_requests_sum);

          IF unit_total_input_requests_sum <> 0 THEN
            unit_str_reads_per_read := $REAL (unit_str_req_count_read_sum) /
                  $REAL (unit_total_input_requests_sum);
            unit_str_reads_fail_per_read := $REAL (unit_str_req_failed_read_sum) /
                  $REAL (unit_total_input_requests_sum);
          ELSE
            unit_str_reads_per_read := 0.0;
            unit_str_reads_fail_per_read := 0.0;
          IFEND;

          IF unit_total_output_requests_sum <> 0 THEN
            unit_str_writes_per_write := $REAL (unit_str_req_count_write_sum) /
                  $REAL (unit_total_output_requests_sum);
            unit_str_writes_fail_per_write := $REAL (unit_str_req_failed_write_sum) /
                  $REAL (unit_total_output_requests_sum);
          ELSE
            unit_str_writes_per_write := 0.0;
            unit_str_writes_fail_per_write := 0.0;
          IFEND;

          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/req type': #SIZE (unit_id_data), '  ',
                unit_str_reads_per_read: 15: 2, '  ', unit_str_writes_per_write: 15: 2, '  ',
                unit_str_tot_per_tot_req: 15: 2, '  ', unit_str_reads_fail_per_read: 15: 2, '  ',
                unit_str_writes_fail_per_write: 15: 2, '  ', unit_str_tot_fail_per_tot_req: 15: 2);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF unit_total_requests_sum <> 0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/total req': #SIZE (unit_id_data),
                '  ', $REAL (unit_str_req_count_read_sum) / $REAL (unit_total_requests_sum): 15: 2, '  ',
                $REAL (unit_str_req_count_write_sum) / $REAL (unit_total_requests_sum): 15: 2,
                '  ', $REAL (unit_str_req_count_total_sum) / $REAL (unit_total_requests_sum): 15: 2, '  ',
                $REAL (unit_str_req_failed_read_sum) / $REAL (unit_total_requests_sum): 15: 2,
                '  ', $REAL (unit_str_req_failed_write_sum) / $REAL (unit_total_requests_sum): 15: 2, '  ',
                $REAL (unit_str_req_failed_total_sum) / $REAL (unit_total_requests_sum): 15: 2);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF unit_str_req_count_total_sum <> 0 THEN
          unit_str_req_count_read_pct := $REAL (unit_str_req_count_read_sum) /
                $REAL (unit_str_req_count_total_sum) * 100.0;
          unit_str_req_count_write_pct := $REAL (unit_str_req_count_write_sum) /
                $REAL (unit_str_req_count_total_sum) * 100.0;
          unit_str_req_count_total_pct := $REAL (unit_str_req_count_total_sum) /
                $REAL (unit_str_req_count_total_sum) * 100.0;
        ELSE
          unit_str_req_count_read_pct := 0.0;
          unit_str_req_count_write_pct := 0.0;
          unit_str_req_count_total_pct := 0.0;
        IFEND;

        IF unit_str_req_failed_total_sum <> 0 THEN
          unit_str_req_failed_read_pct := $REAL (unit_str_req_failed_read_sum) /
                $REAL (unit_str_req_failed_total_sum) * 100.0;
          unit_str_req_failed_write_pct := $REAL (unit_str_req_failed_write_sum) /
                $REAL (unit_str_req_failed_total_sum) * 100.0;
          unit_str_req_failed_total_pct := $REAL (unit_str_req_failed_total_sum) /
                $REAL (unit_str_req_failed_total_sum) * 100.0;
        ELSE
          unit_str_req_failed_read_pct := 0.0;
          unit_str_req_failed_write_pct := 0.0;
          unit_str_req_failed_total_pct := 0.0;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', ' pct': #SIZE (unit_id_data), '  ', unit_str_req_count_read_pct: 15: 2,
              '  ', unit_str_req_count_write_pct: 15: 2, '  ', unit_str_req_count_total_pct: 15: 2, '  ',
              unit_str_req_failed_read_pct: 15: 2, '  ', unit_str_req_failed_write_pct: 15: 2, '  ',
              unit_str_req_failed_total_pct: 15: 2);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF active_unit_count <> 0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', ' avg': #SIZE (unit_id_data), '  ',
                unit_str_req_count_read_sum DIV active_unit_count: 15, '  ',
                unit_str_req_count_write_sum DIV active_unit_count: 15, '  ',
                unit_str_req_count_total_sum DIV active_unit_count: 15, '  ',
                unit_str_req_failed_read_sum DIV active_unit_count: 15, '  ',
                unit_str_req_failed_write_sum DIV active_unit_count: 15, '  ',
                unit_str_req_failed_total_sum DIV active_unit_count: 15, '  ',
                unit_streamed_success_sum / $REAL (active_unit_count): 7: 1);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF time_interval_sec <> 0.0 THEN
            line (1, * ) := '  ';
            STRINGREP (line, length, '  ', '/sec': #SIZE (unit_id_data),
                  '  ', $REAL (unit_str_req_count_read_sum DIV active_unit_count) / time_interval_sec: 15: 2,
                  '  ', $REAL (unit_str_req_count_write_sum DIV active_unit_count) / time_interval_sec: 15: 2,
                  '  ', $REAL (unit_str_req_count_total_sum DIV active_unit_count) / time_interval_sec: 15: 2,
                  '  ', $REAL (unit_str_req_failed_read_sum DIV active_unit_count) / time_interval_sec: 15: 2,
                  '  ', $REAL (unit_str_req_failed_write_sum DIV active_unit_count) /
                  time_interval_sec: 15: 2, '  ', $REAL (unit_str_req_failed_total_sum DIV
                  active_unit_count) / time_interval_sec: 15: 2);

            clp$put_display (display_control, line, clc$trim, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;

{Output Block 6 of Unit Statistics

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', ' Unit': 6, '  ', ' Unit': 7, '  ', '     Total': 15, '  ',
              '  Req Causing': 15, '  ', '  Total Cyls': 15, '  ', '   Recovered': 15, '  ',
              ' Intermediate': 15, '  ', '  Unrecovered': 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', '  VSN': 6, '  ', ' Type': 7, '  ', '     Seeks': 15, '  ',
              '  Skipped Cyls': 15, '  ', '    Skipped': 15, '  ', '     Errors': 15, '  ', '     Errors': 15,
              '  ', '     Errors': 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 6): 6, '  ', dashes (1, 7): 7, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1,
              15): 15, '  ', dashes (1, 15): 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        RESET unit_data_seq_p;

        FOR i := 1 TO active_unit_count DO
          NEXT unit_data_p IN unit_data_seq_p;
          clp$put_display (display_control, unit_data_p^.line_6, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', dashes (1, 6): 6, '  ', dashes (1, 7): 7, '  ', dashes (1, 15): 15,
              '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1, 15): 15, '  ', dashes (1,
              15): 15, '  ', dashes (1, 15): 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (1, * ) := '  ';
        STRINGREP (line, length, '  ', ' sum': #SIZE (unit_id_data), '  ', unit_total_seeks_sum: 15, '  ',
              unit_req_caus_skipped_cyl_sum: 15, '  ', unit_total_cyl_skipped_sum: 15, '  ',
              unit_recovered_errors_sum: 15, '  ', unit_intermediate_errors_sum: 15, '  ',
              unit_unrecovered_errors_sum: 15);

        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF time_interval_sec <> 0.0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/sec': #SIZE (unit_id_data), '  ',
                $REAL (unit_total_seeks_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (unit_req_caus_skipped_cyl_sum) / time_interval_sec: 15: 2, '  ',
                $REAL (unit_total_cyl_skipped_sum) / time_interval_sec: 15: 2);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF unit_total_requests_sum <> 0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/total req': #SIZE (unit_id_data),
                '  ', $REAL (unit_total_seeks_sum) / $REAL (unit_total_requests_sum): 15: 2,
                '  ', $REAL (unit_req_caus_skipped_cyl_sum) / $REAL (unit_total_requests_sum): 15: 2, '  ',
                $REAL (unit_total_cyl_skipped_sum) / $REAL (unit_total_requests_sum): 15: 2);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF unit_total_seeks_sum <> 0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', '/sk': #SIZE (unit_id_data), '  ', '': 15, '  ', '': 15, '  ',
                $REAL (unit_total_cyl_skipped_sum) / $REAL (unit_total_seeks_sum): 15: 2, '  ', '': 15, '  ',
                '': 15, '  ', '': 15);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF active_unit_count <> 0 THEN
          line (1, * ) := '  ';
          STRINGREP (line, length, '  ', ' avg': #SIZE (unit_id_data), '  ',
                unit_total_seeks_sum DIV active_unit_count: 15, '  ',
                unit_req_caus_skipped_cyl_sum DIV active_unit_count: 15, '  ',
                unit_total_cyl_skipped_sum DIV active_unit_count: 15, '  ', '': 15, '  ', '': 15, '  ',
                '': 15);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF time_interval_sec <> 0.0 THEN
            line (1, * ) := '  ';
            STRINGREP (line, length, '  ', '/sec': #SIZE (unit_id_data),
                  '  ', $REAL (unit_total_seeks_sum DIV active_unit_count) / time_interval_sec: 15: 2, '  ',
                  $REAL (unit_req_caus_skipped_cyl_sum DIV active_unit_count) / time_interval_sec: 15: 2,
                  '  ', $REAL (unit_total_cyl_skipped_sum DIV active_unit_count) / time_interval_sec: 15: 2,
                  '  ', '': 15, '  ', '': 15, '  ', '': 15, '  ');

            clp$put_display (display_control, line, clc$trim, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      PROCEND output_unit_data;
?? OLDTITLE ??

?? EJECT ??
      PUSH unit_data_seq_p: [[REP unit_count OF unit_data_record]];
      active_unit_count := 0;
      initialize_unit_sums;
      format_unit_data;
      output_unit_data;
    PROCEND report_unit_data;
?? OLDTITLE ??

?? EJECT ??
    time_interval := $REAL (user_pp_stats_p^.time);
    time_interval_sec := time_interval / 1000000.0;


    report_path_and_pp_data;
    report_unit_data;


  PROCEND format_pio_stats;

?? EJECT, TITLE := 'PROCEDURE format_scheduler_data' ??

    PROCEDURE format_scheduler_data (
          user_copy_of_data: ost$sched_stats;
      VAR display_control: clt$display_control;
      VAR status: ost$status);

      VAR
        line: string (75),
        string_rep: string (20),
        index: jmt$sched_statistic_elements,
        length: integer,
        statistic_id: [STATIC, READ, oss$job_paged_literal] array [jmt$sched_statistic_elements]
              of string (32) :=
{ 0            } ['  lower priority swap count     ',
{ 1             } '  thrashing in activate jobs    ',
{ 2             } '  queues emptied count          ',
{ 3             } '  none left--activation viol    ',
{ 4             } '  bad status on activate        ',
{ 5             } '  ready task event count        ',
{ 6             } '  advance swap event count      ',
{ 7             } '  job terminated event count    ',
{ 8             } '  idle system event count       ',
{ 9             } '  lower maxaj event count       ',
{10             } '  swap for memory request count ',
{11             } '  swapout candidate event count ',
{12             } '  system thrashing event count  ',
{13             } '  exit thrashing none to swap   ',
{14             } '  operator request event count  ',
{15             } '  activate event count          ',
{16             } '  memory available in lw q      ',
{17             } '  wait for memory               ',
{18             } '  memory wait-no preempt        ',
{19             } '  memory wait-activation viol   ',
{20             } '  wait for ajlo                 ',
{21             } '  wait for ajlo-no preempt      ',
{22             } '  wait for ajlo-activation viol ',
{23             } '  short wait                    ',
{24             } '  long wait                     ',
{25             } '  restore job already in memory ',
{26             } '  called advance lw jobs        ',
{27             } '  large ws bad status on swapin ',
{28             } '  large ws job activated        ',
{29             } '  large ws mem avail in lw q    ',
{30             } '  large ws preempt for memory   ',
{31             } '  large ws relink no preempt    ',
{32             } '  large ws relink job too big   ',
{33             } '  age shared q bad status       ',
{34             } '  age shared q activated        ',
{35             } '  change dispatching controls   ',
{36             } '  recovery swapin io error      ',
{37             } '  subsystem lock priority change',
{38             } '  recovered jobs swapin         ',
{39             } '  bad status after age job      ',
{40             } '  activate after age job        '];


      status.normal := TRUE;

      FOR  index := LOWERBOUND (statistic_id) TO UPPERBOUND (statistic_id) DO
        line (1, * ) := ' ';
        line (2, 32) := statistic_id [index];
        STRINGREP (string_rep, length, user_copy_of_data.job_scheduler_statistics [index]);
        line (36, length) := string_rep;
        clp$put_display (display_control, line (1, (36 + length)), clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND format_scheduler_data;

?? EJECT, TITLE := 'PROCEDURE format_swap_file_statistics' ??

   PROCEDURE format_swap_file_statistics
     (    user_copy_of_data: ost$swap_file_stats;
      VAR display_control: clt$display_control;
      VAR status: ost$status);

     VAR
       interval_in_seconds: real,
       length: integer,
       line: string (80),
       pages_per_swap: real,
       segnum: ost$segment;

     line := '  ';
     line := '   SEGMENT NUMBER     TOTAL PAGES      PAGES PER SWAP   ';
     clp$put_display (display_control, line, clc$trim, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

     line := '  ';
     clp$put_display (display_control, line, clc$trim, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

     interval_in_seconds := $real(user_copy_of_data.time) / 1000000.0;
     IF user_copy_of_data.swap_file_stats.total_swaps > 0 THEN
       FOR segnum := 1 TO 40(16) DO
         line := '  ';
         STRINGREP (line (10, 6), length, segnum);
         STRINGREP (line (26, 10), length,
               user_copy_of_data.swap_file_stats.total_pages_per_segment [segnum]);
         pages_per_swap := $real (user_copy_of_data.swap_file_stats.
            total_pages_per_segment [segnum]) / $real (user_copy_of_data.swap_file_stats.total_swaps);
         STRINGREP (line (44, 10), length, pages_per_swap:6:2);
         clp$put_display (display_control, line (1, 80), clc$trim, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;
       FOREND;
     IFEND;

     line := '  ';
     clp$put_display (display_control, line, clc$trim, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;
     line (1, 25) := ' TOTAL NUMBER OF SWAPS ';
     STRINGREP (line (35, 10), length, user_copy_of_data.swap_file_stats.total_swaps);
     clp$put_display (display_control, line, clc$trim, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

   PROCEND format_swap_file_statistics;
?? EJECT, OLDTITLE, TITLE := 'PROCEDURE display_data    { main procedure }' ??

{**************************}
{main proc of module}


    clp$scan_parameter_list (parameter_list, display_data_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('RESET_MAXIMUM_TIME', 1, 1, clc$low, value, status);
    IF status.normal THEN
      reset_maximum_time := value.bool.value;
      IF (reset_maximum_time) AND (NOT (avp$system_administrator() OR
            avp$configuration_administrator())) THEN
        osp$set_status_abnormal ('CL', sye$rmt_restricted_to_sys_job, ' ', status);
        RETURN;
      IFEND;
    ELSE
      reset_maximum_time := FALSE;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_name := value.file;

    clp$get_value ('DISPLAY_FORMAT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (value.name.value = 'INCREMENTAL') OR (value.name.value = 'I') THEN
      display_format := osc$incremental;
    ELSE
      display_format := osc$total;
    IFEND;

{********************************************************}
{establishes a set with the requested options in it}


    requested_options := $option_set [];
    clp$get_set_count ('DISPLAY_OPTION', count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO count DO
      clp$get_value ('DISPLAY_OPTION', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF value.name.value = 'ALL' THEN
        requested_options := id_set;
      ELSE
        FOR j := 1 TO table_length DO
          IF table [j].name = value.name.value THEN
            requested_options := requested_options + $option_set [table [j].id];
          IFEND;
        FOREND;
      IFEND;
    FOREND ;

{**************************************************************************}
{passes the requested options to a proc that formats and outputs the data}

    display_control := clv$nil_display_control;
    #spoil (display_control);
    osp$establish_block_exit_hndlr (^abort_handler);

    clp$open_display (file_name, ^clp$new_page_procedure, display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    clv$titles_built := FALSE;

  /display/
    FOR k := LOWERVALUE (ost$data_id) TO UPPERVALUE (ost$data_id) DO
      IF k IN requested_options THEN
        i := LOWERBOUND (table);
        WHILE table [i].id <> k DO
          i := i + 1;
        WHILEND;

        IF table [i].name = 'JOB_DATA' THEN
          clv$command_name := 'display_job_data';
        ELSE { system_job_data }
          clv$command_name := 'display_system_data';
        IFEND;

        format_data (table [i], display_format, display_control, status);
        IF NOT status.normal THEN
          EXIT /display/;
        IFEND;

        IF reset_maximum_time THEN
          CASE table [i].id of
          = osc$mtr_requests, osc$swap_statistics =
            osp$reset_maximum_time (table [i].id);
          ELSE
            ;
          CASEND;
        IFEND;

      IFEND;
    FOREND /display/;

    clp$close_display (display_control, status);

    osp$disestablish_cond_handler;

  PROCEND display_data;

MODEND clm$display_system_data;

*DECK DECK=CLM$DISPLAY_SYSTEM_TASK_DATA EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Command Language : Command Processor for display_system_task_data' ??
MODULE clm$display_system_task_data;

{ PURPOSE:
{   This module contains the command processor for the command DISPLAY_SYSTEM_TASK_DATA.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc jme$queued_file_conditions
*copyc osc$processor_defined_registers
*copyc ost$status
?? POP ??
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc clv$nil_display_control
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
*copyc osp$get_system_task_data
*copyc osp$set_status_abnormal
?? OLDTITLE, NEWTITLE := '[XDCL, #GATE] clp$display_system_task_command', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$display_system_task_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{   PROCEDURE (osm$disstd) display_system_task_data, disstd (
{     task_name, task_names, tn:
{       any of
{         key
{           all
{         keyend
{         list of name
{       anyend = all
{     display_option, do:
{       key
{        (brief, b)
{        (full, f)
{       keyend = brief
{     output, o: file = $output
{     status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 31, 14, 6, 11, 369],
    clc$command, 8, 4, 0, 0, 0, 0, 4, 'OSM$DISSTD'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['TASK_NAME                      ',clc$nominal_entry, 1],
    ['TASK_NAMES                     ',clc$alias_entry, 1],
    ['TN                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['BRIEF                          ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['F                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['FULL                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'brief'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

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

    CONST
      p$task_name = 1,
      p$display_option = 2,
      p$output = 3,
      p$status = 4;

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

    VAR
      ignore_status: ost$status;

*copy clv$display_variables
?? NEWTITLE := '  abort_handler', EJECT ??

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

      clp$close_display (display_control, ignore_status);
      handler_status.normal := TRUE;

    PROCEND abort_handler;
*copy clp$new_page_procedure
?? TITLE := '  put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle (VAR display_control: clt$display_control;
      VAR status: ost$status);

      { This command does not produce subtitles. This procedure is declared
      { for consistancy and to provide a no-op for calls to this procedure.

      status.normal := TRUE;

    PROCEND put_subtitle;
?? OLDTITLE ??
?? EJECT, NEWTITLE := '  format_system_task_data' ??

    PROCEDURE format_system_task_data (
          criteria: ost$system_task_data_criteria;
          display_all_info: boolean;
      VAR display_control: clt$display_control;
      VAR status: ost$status);

      VAR
        i: integer,
        length: integer,
        s: string (80),
        system_task_count: integer,
        system_task_data: ^ost$system_task_display_data,
        temp: string(9);

      system_task_count := 1;
      REPEAT
        PUSH system_task_data: [1 .. system_task_count];
        osp$get_system_task_data (criteria, system_task_data^, system_task_count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      UNTIL system_task_count <= UPPERBOUND (system_task_data^);
      FOR i := 1 TO system_task_count DO
        s := '  ';
        s (1, *) := system_task_data^[i].task_name;
        IF display_all_info THEN
          IF system_task_data^[i].automatic_restart THEN
            s (34) := 'T';
          ELSE
            s (34) := 'F';
          IFEND;
          IF system_task_data^[i].deactivate_task_option = osc$tt_terminate THEN
            s (39) := 'T';
          ELSEIF system_task_data^[i].deactivate_task_option = osc$tt_voluntary THEN
            s (39) := 'V';
          ELSE { system_task_data^[i].deactivate_task_option = osc$tt_ignore_or_prohibited }
            s (39) := 'P';
          IFEND;
          IF system_task_data^[i].idle_task_option = osc$tt_terminate THEN
            s (43) := 'T';
          ELSEIF system_task_data^[i].idle_task_option = osc$tt_voluntary THEN
            s (43) := 'V';
          ELSE { system_task_data^[i].idle_task_option = osc$tt_ignore_or_prohibited }
            s (43) := 'I';
          IFEND;
          IF system_task_data^[i].restart_after_idle THEN
            s (48) := 'T';
          ELSE
            s (48) := 'F';
          IFEND;
          STRINGREP (s (52,3), length, system_task_data^[i].spy_identifier);
          STRINGREP (s (56,4), length, system_task_data^[i].execution_ring);
          IF system_task_data^[i].active THEN
            s (62) := 'T';
          ELSE
            s (62) := 'F';
          IFEND;
          IF system_task_data^[i].task_status.complete THEN
            s (68) := 'T';
            IF system_task_data^[i].task_status.status.normal THEN
              s (71, *) := '  Normal';
            ELSE
              s (71) := $CHAR((system_task_data^[i].task_status.status.condition DIV 1000000(16))
                    DIV 100(16));
              s (72) := $CHAR((system_task_data^[i].task_status.status.condition DIV 1000000(16))
                    MOD 100(16));
              STRINGREP (temp, length, (system_task_data^[i].task_status.status.condition
                    MOD 1000000(16)));
              s (73, length - 1) := temp (2, length - 1)
            IFEND;
          ELSE
            s (68) := 'F';
          IFEND;
        IFEND; { display all information }
        clp$put_display (display_control, s, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    PROCEND format_system_task_data;
?? OLDTITLE, EJECT ??
    VAR
      criteria: ost$system_task_data_criteria,
      default_ring_attributes: amt$ring_attributes,
      display_all_info: boolean,
      display_control: clt$display_control,
      node: ^clt$data_value,
      s: string (80);

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

    criteria.all_tasks := pvt [p$task_name].value^.kind = clc$keyword;
    display_all_info := pvt [p$display_option].value^.keyword_value = 'FULL';

{ Open the specified file and get it ready to accept output.

    display_control := clv$nil_display_control;
    #spoil (display_control);
    osp$establish_block_exit_hndlr (^abort_handler);

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          default_ring_attributes, display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    clv$titles_built := FALSE;
    clv$command_name := 'display_system_task_data';

/display/
  BEGIN

{ Display header format:
{
{TASK NAME                      AUTO  OPTIONS: RE-  SPY      AC-  COM-  STATUS IF
{                               TERM   D   I   STRT ID  RING TIVE PLETE COMPLETE
{xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx  T    t   t    T   xxx  xx   T     T   F #ZZZZZZ
{12345678901234567890123456789012345678901234567890123456789012345678901234567890
{         1         2         3         4         5         6         7         8

    s (1, *) := 'TASK NAME';
    IF display_all_info THEN
      s (32, *) := 'AUTO  OPTIONS: RE-  SPY      AC-  COM-  STATUS IF';
    IFEND;
    clp$put_display (display_control, s, clc$trim, status);
    IF NOT status.normal THEN
      EXIT /display/;
    IFEND;
    IF display_all_info THEN
      s := ' ';
      s (32, *) := 'TERM   D   I   STRT ID  RING TIVE PLETE COMPLETE ';
      clp$put_display (display_control, s, clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display/;
      IFEND;
    IFEND;

    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      EXIT /display/;
    IFEND;

    IF criteria.all_tasks THEN
      format_system_task_data (criteria, display_all_info, display_control, status);
    ELSE
      node := pvt [p$task_name].value;
      WHILE node <> NIL DO
        criteria.task_name := node^.element_value^.name_value;
        format_system_task_data (criteria, display_all_info, display_control, status);
        IF NOT status.normal THEN
          EXIT /display/;
        IFEND;
        node := node^.link;
      WHILEND;
    IFEND;
  END /display/;

    IF status.normal THEN
      clp$close_display (display_control, status);
    ELSE
      clp$close_display (display_control, ignore_status);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND clp$display_system_task_command;
?? OLDTITLE ??
MODEND clm$display_system_task_data;
*DECK DECK=CLM$DISPLAY_TASK_STATUS_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Display Task Status' ??
MODULE clm$display_task_status_command;

{
{ PURPOSE:
{   This module provides the source for the display_task_status command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc clt$path_display_chunks
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc ost$status
*copyc ost$status_message
*copyc ost$status_message_line_count
*copyc ost$status_message_line_size
?? POP ??
*copyc clp$find_named_task_group_list
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$fetch_named_task_entry
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clv$named_task_group_list
*copyc clv$nil_display_control
*copyc clv$value_descriptors
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc osv$upper_to_lower
?? OLDTITLE ??
?? NEWTITLE := 'clp$_display_task_status', EJECT ??

  PROCEDURE [XDCL] clp$_display_task_status
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? RIGHT := 110 ??

{ PROCEDURE (osm$dists) display_task_status, dists (
{   task_name, task_names, tn: list of any of
{       key
{         all
{       keyend
{       name
{     anyend = $required
{   output, o: file = $output
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 1, 25, 14, 11, 33, 662],
    clc$command, 6, 3, 1, 0, 0, 0, 3, 'OSM$DISTS'], [
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['TASK_NAME                      ',clc$nominal_entry, 1],
    ['TASK_NAMES                     ',clc$alias_entry, 1],
    ['TN                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

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

    CONST
      p$task_name = 1,
      p$output = 2,
      p$status = 3;

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

*copy clv$display_variables
*copy clp$new_page_procedure

?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

{ The display_program command has no subtitles,
{ this is merely a dummy routine used to keep
{ the module consistent with those that do produce subtitles.

    PROCEND put_subtitle;
?? TITLE := 'put_partial_display', EJECT ??

    PROCEDURE [INLINE] put_partial_display
      (    str: string ( * );
           trim_option: clt$trim_display_text_option;
           term_option: amt$term_option);

      VAR
        local_status: ost$status;

      clp$put_partial_display (display_control, str, trim_option, term_option, local_status);
      IF NOT local_status.normal THEN
        EXIT clp$_display_task_status;
      IFEND;

    PROCEND put_partial_display;
?? TITLE := 'generate_message_display', EJECT ??

    PROCEDURE generate_message_display
      (    message_status: ost$status);

      VAR
        message: ost$status_message,
        message_area: ^ost$status_message,
        message_line_count: ^ost$status_message_line_count,
        message_line_index: 1 .. osc$max_status_message_lines,
        message_line_size: ^ost$status_message_line_size,
        message_line: ^string ( * );

      status.normal := TRUE;

      osp$format_message (message_status, osc$full_message_level, clv$page_width, message, status);
      IF NOT status.normal THEN
        EXIT clp$_display_task_status;
      IFEND;
      message_area := ^message;
      RESET message_area;
      NEXT message_line_count IN message_area;
      FOR message_line_index := 1 TO message_line_count^ DO
        NEXT message_line_size IN message_area;
        NEXT message_line: [message_line_size^] IN message_area;
        clp$put_display (display_control, message_line^, clc$trim, status);
        IF NOT status.normal THEN
          EXIT clp$_display_task_status;
        IFEND;
      FOREND;

    PROCEND generate_message_display;
?? TITLE := 'abort_handler', EJECT ??

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

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;
?? TITLE := 'put_task_status', EJECT ??

    PROCEDURE [INLINE] put_task_status
      (    task_name: ost$name);

{ This procedure will never return with bad status, thus no status
{ parameter is passed. A non-local exit occurs instead.

      clp$new_display_line (display_control, 0, status);
      IF NOT status.normal THEN
        EXIT clp$_display_task_status;
      IFEND;
      put_partial_display (task_name, clc$trim, amc$continue);

      IF task_name = named_task.name THEN
        IF named_task.status.complete THEN
          IF named_task.status.status.normal THEN
            put_partial_display (' completed normally.', clc$no_trim, amc$terminate);
          ELSE
            put_partial_display (' terminated with ..', clc$no_trim, amc$continue);
            clp$new_display_line (display_control, 0, status);
            IF NOT status.normal THEN
              EXIT clp$_display_task_status;
            IFEND;
            generate_message_display (named_task.status.status);
          IFEND;
        ELSE
          put_partial_display (' still executing.', clc$no_trim, amc$terminate);
        IFEND;
      ELSE
        put_partial_display (' is not known to the requesting task.', clc$no_trim, amc$terminate);
      IFEND;

    PROCEND put_task_status;
?? OLDTITLE, EJECT ??

    VAR
      current_task_name: ^clt$data_value,
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      index: integer,
      local_status: ost$status,
      named_task: clt$named_task,
      named_task_group_list: ^^clt$named_task,
      named_task_list: ^clt$named_task;


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

    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    osp$establish_block_exit_hndlr (^abort_handler);

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          default_ring_attributes, display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    clv$titles_built := FALSE;
    clv$command_name := 'display_task_status';

    IF display_control.page_width < clc$narrow_page_width THEN
      clv$page_width := clc$narrow_page_width;
    ELSEIF display_control.page_width > clc$wide_page_width THEN
      clv$page_width := clc$wide_page_width;
    ELSE
      clv$page_width := display_control.page_width;
    IFEND;

  /display/
    BEGIN
      current_task_name := pvt [p$task_name].value;
      WHILE current_task_name <> NIL DO
        IF current_task_name^.element_value^.kind = clc$keyword THEN
          clp$find_named_task_group_list (named_task_group_list);
          named_task_list := named_task_group_list^;
          WHILE named_task_list <> NIL DO
            named_task := named_task_list^;
            put_task_status (named_task.name);
            named_task_list := named_task_list^.link;
            IF named_task_list <> NIL THEN
              clp$new_display_line (display_control, 1, status);
              IF NOT status.normal THEN
                EXIT /display/;
              IFEND;
            IFEND;
          WHILEND;
        ELSE
          clp$fetch_named_task_entry (current_task_name^.element_value^.name_value, named_task);
          put_task_status (current_task_name^.element_value^.name_value);
        IFEND;
        current_task_name := current_task_name^.link;
        IF (current_task_name <> NIL) THEN
          clp$new_display_line (display_control, 1, status);
          IF NOT status.normal THEN
            EXIT /display/;
          IFEND;
        IFEND;
      WHILEND;
    END /display/;

    clp$close_display (display_control, local_status);

    osp$disestablish_cond_handler;

  PROCEND clp$_display_task_status;

MODEND clm$display_task_status_command;
*DECK DECK=CLM$DISPLAY_VALUE_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter: Display Value Command' ??
MODULE clm$display_value_command;

{
{ PURPOSE:
{   This module contains the processor for the display_value command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc clt$parameter_list_text_size
*copyc clt$path_display_chunks
*IF $true(osv$unix)
*copyc cyt$mips_signal_handler
*IFEND
*copyc ost$status
?? POP ??
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$convert_data_to_string
*copyc clp$evaluate_parameters
*copyc clp$get_work_area
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_data_representation
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*IF NOT $true(osv$unix)
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
*IFEND

?? TITLE := 'clp$_display_value', EJECT ??

  PROCEDURE [XDCL] clp$_display_value
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
{   PROCEDURE (osm$disv) display_value, display_values, disv (
{     value, values, v: any = $required
{     output, o: file = $output
{     display_options, display_option, do: list of key
{         (elements, element, e)
{         (compressed_labeled_elements, cle)
{         (data_structure, das, ds)
{         (display_elements, display_element, de)
{         (display_source, dis)
{         (labeled_elements, le)
{         (source, s)
{       keyend = osd$disv_display_options, elements
{     status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: 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 .. 17] of clt$keyword_specification,
        recend,
        default_name: string (24),
        default_value: string (8),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 2, 22, 11, 24, 0, 623],
    clc$command, 9, 4, 1, 0, 0, 0, 4, 'OSM$DISV'], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 3],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 3],
    ['DO                             ',clc$abbreviation_entry, 3],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['V                              ',clc$abbreviation_entry, 1],
    ['VALUE                          ',clc$nominal_entry, 1],
    ['VALUES                         ',clc$alias_entry, 1]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 12, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 652,
  clc$optional_default_parameter, 24, 8],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [-$clt$type_kinds [],
    FALSE, 0]],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$list_type], [636, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [17], [
      ['CLE                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['COMPRESSED_LABELED_ELEMENTS    ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['DAS                            ', clc$alias_entry, clc$normal_usage_entry, 3],
      ['DATA_STRUCTURE                 ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['DE                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['DIS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['DISPLAY_ELEMENT                ', clc$alias_entry, clc$normal_usage_entry, 4],
      ['DISPLAY_ELEMENTS               ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['DISPLAY_SOURCE                 ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['DS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ELEMENT                        ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['ELEMENTS                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['LABELED_ELEMENTS               ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['LE                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['SOURCE                         ', clc$nominal_entry, clc$normal_usage_entry, 7]]
      ]
    ,
    'OSD$DISV_DISPLAY_OPTIONS',
    'elements'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

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

    CONST
      p$value = 1,
      p$output = 2,
      p$display_options = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;
*ELSE
{  PROCEDURE (osm$disv) display_value, display_values, disv (
{    value, values, v: any = $required
{    output, o: file = $output
{    display_options, display_option, do: list of key
{        (elements, element, e)
{        (compressed_labeled_elements, cle)
{        (data_structure, das, ds)
{        (display_elements, display_element, de)
{        (display_source, dis)
{        (labeled_elements, le)
{        (source, s)
{      keyend = OSD_DISV_DISPLAY_OPTIONS, elements
{    status)


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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier_v2,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: ALIGNED [0 MOD 4] string (7),
      recend,
      type3: 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 .. 17] of clt$keyword_specification,
        recend,
        default_name: ALIGNED [0 MOD 4] string (24),
        default_value: ALIGNED [0 MOD 4] string (8),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [2,
    [92, 3, 5, 15, 32, 22, 0],
    clc$command, 9, 4, 1, 0, 0, 0, 4, 'OSM$DISV'], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 3],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 3],
    ['DO                             ',clc$abbreviation_entry, 3],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['V                              ',clc$abbreviation_entry, 1],
    ['VALUE                          ',clc$nominal_entry, 1],
    ['VALUES                         ',clc$alias_entry, 1]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 16, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 716, clc$optional_default_parameter, 24, 8],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[2, 0, clc$union_type], [-$clt$type_kinds_v2 [],
    FALSE, 0]],
{ PARAMETER 2
    [[2, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[2, 0, clc$list_type], [688, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[2, 0, clc$keyword_type], [17], [
      ['CLE                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
      ['COMPRESSED_LABELED_ELEMENTS    ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['DAS                            ', clc$alias_entry,
  clc$normal_usage_entry, 3],
      ['DATA_STRUCTURE                 ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['DE                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
      ['DIS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
      ['DISPLAY_ELEMENT                ', clc$alias_entry,
  clc$normal_usage_entry, 4],
      ['DISPLAY_ELEMENTS               ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['DISPLAY_SOURCE                 ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
      ['DS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
      ['E                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
      ['ELEMENT                        ', clc$alias_entry,
  clc$normal_usage_entry, 1],
      ['ELEMENTS                       ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['LABELED_ELEMENTS               ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
      ['LE                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
      ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
      ['SOURCE                         ', clc$nominal_entry,
  clc$normal_usage_entry, 7]]
      ]
    ,
    'OSD_DISV_DISPLAY_OPTIONS',
    'elements'],
{ PARAMETER 4
    [[2, 0, clc$status_type]]];

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

    CONST
      p$value = 1,
      p$output = 2,
      p$display_options = 3,
      p$status = 4;

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

*copy clv$display_variables
?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
*IF $true(osv$unix)
      (    signal_no: integer;
           code: integer;
           p_sigcontext: ^cyt$mips_sigcontext);

      VAR
        ignore_status: ost$status;
*ELSE
      (    ignore_condition: pmt$condition;
           ignore_condition_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);
*IFEND

      IF output_open THEN
*IF $true(osv$unix)
        clp$close_display (display_control, ignore_status);
*ELSE
        clp$close_display (display_control, handler_status);
*IFEND
        output_open := FALSE;
      IFEND;
*IF NOT $true(osv$unix)
      handler_status.normal := TRUE;
*IFEND

    PROCEND abort_handler;
*copy clp$new_page_procedure
?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);


      { The display_value command has no subtitles,
      { this is merely a dummy routine used to keep
      { the module consistent with those that do produce subtitles.

    PROCEND put_subtitle;
?? OLDTITLE, EJECT ??

    CONST
      subtitle_header = 'display option: ',
      subtitle_header_size = 16;

    VAR
      current_option: ^clt$data_value,
*IF NOT $true(osv$unix)
      default_ring_attributes: amt$ring_attributes,
*IFEND
      display_control: clt$display_control,
*IF $true(osv$unix)
      handler_established: boolean,
*IFEND
      i: clt$data_representation_count,
      local_status: ost$status,
      option: clt$data_representation_option,
      option_name: clt$keyword,
      output_open: boolean,
      representation: ^clt$data_representation,
      string_count: ^clt$data_representation_count,
      string_ptr: ^clt$string_value,
      string_size: ^clt$string_size,
      subtitle: string (subtitle_header_size + osc$max_name_size),
      work_area: ^^clt$work_area;


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

*IF NOT $true(osv$unix)
    clp$get_work_area (#RING (^work_area), work_area, status);
*ELSE
    clp$get_work_area (osc$user_ring, work_area, status);
*IFEND
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_open := FALSE;
*IF NOT $true(osv$unix)
    osp$establish_block_exit_hndlr (^abort_handler);

*IF NOT $true(osv$unix)
    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
*ELSE
    default_ring_attributes.r1 := osc$user_ring;
    default_ring_attributes.r2 := osc$user_ring;
    default_ring_attributes.r3 := osc$user_ring;
*IFEND
    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          default_ring_attributes, display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
*ELSE
    handler_established := #establish_condition_handler (-1, ^abort_handler);

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          display_control, status);
    IF NOT status.normal THEN
      IF handler_established THEN
        handler_established := NOT #disestablish_condition_handler (-1);
      IFEND;
*IFEND
      RETURN;
    IFEND;
    output_open := TRUE;
    clv$titles_built := FALSE;
    clv$command_name := 'display_value';

    subtitle := subtitle_header;

    current_option := pvt [p$display_options].value;

  /option_loop/
    WHILE current_option <> NIL DO
      option_name := current_option^.element_value^.keyword_value;

*IF NOT $true(osv$unix)
      IF (display_control.page_format <> amc$untitled_form) AND pvt [p$display_options].specified AND
            (pvt [p$display_options].value^.link <> NIL) THEN
*ELSE
      IF pvt [p$display_options].specified AND
            (pvt [p$display_options].value^.link <> NIL) THEN
*IFEND
        subtitle (subtitle_header_size + 1, * ) := option_name;
        IF current_option <> pvt [p$display_options].value THEN
          clp$new_display_line (display_control, 2, status);
          IF NOT status.normal THEN
            EXIT /option_loop/;
          IFEND;
        IFEND;
        clp$put_display (display_control, subtitle, clc$trim, status);
        IF NOT status.normal THEN
          EXIT /option_loop/;
        IFEND;
        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          EXIT /option_loop/;
        IFEND;
      IFEND;

      IF option_name = 'ELEMENTS' THEN
        option := clc$data_elem_representation;
      ELSEIF option_name = 'COMPRESSED_LABELED_ELEMENTS' THEN
        option := clc$compressed_labeled_elem_rep;
      ELSEIF option_name = 'DISPLAY_ELEMENTS' THEN
        option := clc$display_elem_representation;
      ELSEIF option_name = 'DISPLAY_SOURCE' THEN
        option := clc$display_srce_representation;
      ELSEIF option_name = 'DATA_STRUCTURE' THEN
        option := clc$data_struct_representation;
      ELSEIF option_name = 'LABELED_ELEMENTS' THEN
        option := clc$labeled_elem_representation;
      ELSE { option_name = 'SOURCE' }
        option := clc$data_source_representation;
      IFEND;

*IF NOT $true(osv$unix)
      clp$convert_data_to_string (pvt [p$value].value, option, display_control.page_width, work_area^,
*ELSE
      clp$convert_data_to_string (pvt [p$value].value, option, 80, work_area^,
*IFEND
            representation, status);
      IF NOT status.normal THEN
        EXIT /option_loop/;
      IFEND;
      clp$put_data_representation (display_control, representation, status);
      IF NOT status.normal THEN
        EXIT /option_loop/;
      IFEND;

      RESET work_area^ TO representation;
      current_option := current_option^.link;
    WHILEND /option_loop/;

    clp$close_display (display_control, local_status);
    output_open := FALSE;
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

*IF $true(osv$unix)
    IF handler_established THEN
      handler_established := NOT #disestablish_condition_handler (-1);
    IFEND;
*ELSE
    osp$disestablish_cond_handler;
*IFEND

  PROCEND clp$_display_value;

MODEND clm$display_value_command;
*DECK DECK=CLM$DISPLAY_VAR_LIST_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Display Variable List' ??
MODULE clm$display_var_list_command;

{
{ PURPOSE:
{   This module contains the processor for the display_variable_list variable.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc clt$command_list
*copyc clt$path_display_chunks
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc ost$status
?? POP ??
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$find_first_var_block
*copyc clp$find_next_var_block
*copyc clp$horizontal_tab_display
*copyc clp$make_file_clt$value
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$unhash_variable_name
*copyc clv$intrinsic_commands
*copyc clv$nil_display_control
*copyc clv$operator_commands
*copyc jmp$system_job
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osv$upper_to_lower

  CONST
    variable_name_size = osc$max_name_size + 1,
    column = 2,
    minimum_display_line = variable_name_size + 2;

?? TITLE := 'clp$display_var_list_command', EJECT ??

  PROCEDURE [XDCL] clp$_display_variable_list
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$disvl) display_variable_list, disvl (
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [87, 10, 22, 10, 1, 17, 755],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$DISVL'], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

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

    CONST
      minimum_display_line = osc$max_name_size + 3,
      minimum_line_size = osc$max_name_size + 3,
      brief_header_length = 13,
      full_header_length = 7,
      system_entry_length = 7,
      subentry_column = 3,
      entry_name_size = osc$max_name_size + 1;

*copy clv$display_variables
?? NEWTITLE := 'abort_handler', EJECT ??

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

      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;
*copyc clp$new_page_procedure
?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

{ The display_variable_list variable has no subtitles,
{ this is merely a dummy routine used to keep
{ the module consistent with those that do produce subtitles.

    PROCEND put_subtitle;
?? OLDTITLE, EJECT ??

    VAR
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      full_display: boolean,
      ignore_status: ost$status,
      search_modes: [STATIC, READ, oss$job_paged_literal] array [clt$command_search_modes] of string (10) :=
            ['global', 'restricted', 'exclusive'],
      search_mode: clt$command_search_modes,
      start_of_list: ^clt$command_list_entry,
      system_command_library_lfn: amt$local_file_name,
      value: clt$value;

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

    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    osp$establish_block_exit_hndlr (^abort_handler);

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure,
          fsc$list, default_ring_attributes, display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    clv$titles_built := FALSE;
    clv$command_name := 'display_variable_list';

    display_variable_list (display_control, status);

    IF status.normal THEN
      clp$close_display (display_control, status);
    ELSE
      clp$close_display (display_control, ignore_status);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND clp$_display_variable_list;
?? TITLE := 'display_variable_list', EJECT ??

  PROCEDURE display_variable_list
    (VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      allowed_classes: clt$internal_variable_classes,
      associated_utility: boolean,
      block: ^clt$block,
      index: integer,
      inherited_block: ^clt$block,
      inherited_classes: clt$internal_variable_classes,
      line_size: amt$page_width,
      term_option: amt$term_option,
      title_printed: boolean,
      translated_label: string (osc$max_name_size),
      translated_variable_name: string (variable_name_size),
      trim: clt$trim_display_text_option,
      variable_access: ^clt$variable_access,
      variable_name: clt$variable_name,
      variables_per_line: integer;

    IF display_control.page_width < minimum_display_line THEN
      line_size := minimum_display_line;
    ELSE
      line_size := display_control.page_width;
    IFEND;

    allowed_classes := -$clt$internal_variable_classes[clc$param_variable];
    clp$find_first_var_block (allowed_classes, inherited_classes, inherited_block, block,
          associated_utility);
    IF block = NIL THEN
      RETURN;
    IFEND;
    variables_per_line := line_size DIV variable_name_size;
    term_option := amc$continue;

    clp$put_partial_display (display_control, 'VARIABLES', clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /put_block_header/
    BEGIN
      CASE block^.kind OF
      = clc$task_block =
        IF block^.task_kind = clc$job_monitor_task THEN
          clp$put_partial_display (display_control, ' IN JOB', clc$trim, amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          clp$put_partial_display (display_control, ' IN TASK', clc$trim, amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        EXIT /put_block_header/;

      = clc$utility_block =
        clp$put_partial_display (display_control, ' IN UTILITY', clc$trim, amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = clc$when_block =
        clp$put_partial_display (display_control, ' IN ', clc$no_trim, amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, block^.kind_name, clc$trim, amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        EXIT /put_block_header/;

      = clc$command_proc_block, clc$function_proc_block =
        clp$put_partial_display (display_control, ' IN ', clc$no_trim, amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, block^.kind_name, clc$trim, amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSE
        ;
      CASEND;
      clp$put_partial_display (display_control, ' : ', clc$no_trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #TRANSLATE (osv$upper_to_lower, block^.label, translated_label);
      clp$put_partial_display (display_control, translated_label, clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    END /put_block_header/;

    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$horizontal_tab_display (display_control, column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    variable_access := block^.variables.thread;
    title_printed := FALSE;

    WHILE TRUE DO

      index := 1;
      IF (inherited_block <> NIL) AND (NOT associated_utility) AND  (block^.kind IN $clt$block_kinds
            [clc$command_proc_block, clc$function_proc_block]) THEN
        allowed_classes := $clt$internal_variable_classes [clc$env_variable, clc$lib_variable,
            clc$pushed_variable];
      IFEND;

      WHILE variable_access <> NIL DO
        IF variable_access^.info.class IN allowed_classes THEN
          IF ((index MOD variables_per_line) = 0) OR (variable_access^.forward_thread = NIL) THEN
            term_option := amc$terminate;
            trim := clc$trim;
          ELSE
            term_option := amc$continue;
            trim := clc$no_trim;
          IFEND;
          clp$unhash_variable_name (variable_access^.hashed_name, variable_name);
          #TRANSLATE (osv$upper_to_lower, variable_name, translated_variable_name);
          clp$put_partial_display (display_control, translated_variable_name, trim, term_option, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          index := index + 1;
          IF term_option = amc$terminate THEN
            clp$horizontal_tab_display (display_control, column, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
        variable_access := variable_access^.forward_thread;
      WHILEND;

      IF block^.kind IN $clt$block_kinds [clc$command_proc_block, clc$function_proc_block] THEN
        allowed_classes := $clt$internal_variable_classes [clc$env_variable, clc$lib_variable,
            clc$pushed_variable];
      IFEND;
      clp$find_next_var_block (allowed_classes, inherited_classes, inherited_block, block,
            associated_utility);
      IF block = NIL THEN
        RETURN;
      IFEND;
      variable_access := block^.variables.thread;
      IF (NOT title_printed) AND (variable_access <> NIL) THEN
        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, 'ACCESSIBLE VARIABLES', clc$no_trim, amc$terminate,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$horizontal_tab_display (display_control, column, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        title_printed := TRUE;
      IFEND;
    WHILEND;

  PROCEND display_variable_list;

MODEND clm$display_var_list_command;
*DECK DECK=CLM$DISPLAY_WORKING_CATALOG EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter: Display Working Catalog' ??
MODULE clm$display_working_catalog;

{
{ PURPOSE:
{   This module contains the processor for the display_working_catalog command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc ost$status
?? POP ??
*copyc bap$get_path_string
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$find_working_catalog
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
*copyc clv$nil_display_control

?? TITLE := 'clp$_display_working_catalog', EJECT ??

  PROCEDURE [XDCL] clp$_display_working_catalog
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$diswc) display_working_catalog, diswc (
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 23, 12, 42, 58, 957], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$DISWC'],
            [['O                              ', clc$abbreviation_entry, 1],
            ['OUTPUT                         ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 2]], [
{ PARAMETER 1
      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$file_type], '$output'],
{ PARAMETER 2
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

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

*copy clv$display_variables
?? NEWTITLE := 'abort_handler', EJECT ??

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


      IF output_open THEN
        clp$close_display (display_control, handler_status);
        output_open := FALSE;
      IFEND;
      handler_status.normal := TRUE;

    PROCEND abort_handler;
*copy clp$new_page_procedure
?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);


      { The display_working_catalog command has no subtitles,
      { this is merely a dummy routine used to keep
      { the module consistent with those that do produce subtitles.

    PROCEND put_subtitle;
?? TITLE := 'put_path_chunks', EJECT ??

    PROCEDURE put_path_chunks
      (    path_name: string ( * );
           display_chunks: clt$path_display_chunks;
           chunk_count: 0 .. fsc$max_path_elements;
           column: amt$page_width;
       VAR status: ost$status);

      VAR
        i: 0 .. fsc$max_path_elements,
        term_option: amt$term_option,
        terminate_string: string (2);

      terminate_string := '..';
      term_option := amc$terminate;
      FOR i := 1 TO chunk_count DO
        clp$horizontal_tab_display (display_control, column, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF i = chunk_count THEN
          terminate_string := '  ';
          term_option := amc$terminate;
        IFEND;
        clp$put_partial_display (display_control, path_name
              (display_chunks [i].position, display_chunks [i].length), clc$trim, amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, terminate_string, clc$trim, term_option, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

    PROCEND put_path_chunks;
?? OLDTITLE, EJECT ??

    VAR
      chunk_count: 0 .. fsc$max_path_elements,
      default_ring_attributes: amt$ring_attributes,
      display_chunks: clt$path_display_chunks,
      display_control: clt$display_control,
      local_status: ost$status,
      output_open: boolean,
      path: fst$path,
      path_size: fst$path_size,
      working_catalog: ^^clt$working_catalog;

    status.normal := TRUE;

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

    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
    output_open := FALSE;

    osp$establish_block_exit_hndlr (^abort_handler);

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          default_ring_attributes, display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    output_open := TRUE;
    clv$titles_built := FALSE;
    clv$command_name := 'display_working_catalog';

    clp$find_working_catalog (working_catalog);
    IF working_catalog^ <> NIL THEN
      bap$get_path_string (working_catalog^^.evaluated_file_reference.path_handle_info.path_handle, path,
            path_size, status);
      IF status.normal THEN
        clp$build_path_subtitle (path, path_size, display_control.page_width, chunk_count, display_chunks);
        put_path_chunks (path, display_chunks, chunk_count, 1, status);
      IFEND;
    IFEND;

    clp$close_display (display_control, local_status);
    output_open := FALSE;
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND clp$_display_working_catalog;

MODEND clm$display_working_catalog;

*DECK DECK=CLM$DUMP_FILE_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Dump File Command Processor' ??
MODULE clm$dump_file_command;

{
{ PURPOSE:
{   This module contains the processor for the dump_file command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$improper_random_access
*copyc clc$page_widths
*copyc cld$parameter_list
*copyc cle$ecc_lexical
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_proc_declaration
*copyc clt$file_reference
*copyc clt$path_name
*copyc ost$status
?? POP ??
*copyc amv$nil_file_identifier
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$trimmed_string_size
*copyc clv$nil_display_control
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??

  CONST
    address_size = 13,
    address_start = 1,
    bytes_per_word = 8,
    hex_start = 15,
    max_output_line_size = 114,
    max_words_per_line = 8,
    non_printable = ' ';

  TYPE
    dump_formats = (ascii, ascii_hex, hex);

  VAR
    output_descriptor: [STATIC, READ, oss$job_paged_literal] array [boolean] of array [dump_formats] of record
      words_per_line: 2 .. max_words_per_line,
      ascii_start: 2 .. max_output_line_size,
      line_size: 2 .. max_output_line_size,
    recend := [[[4, 15, 46], [2, 49, 64], [2, * , 47]], [[8, 15, 78], [4, 83, 114], [4, * , 81]]];

*copyc cli$compare_display_file_input

?? TITLE := 'clp$_display_file', EJECT ??

  PROCEDURE [XDCL] clp$_display_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$disf) display_file, disf (
{   input, i: file = $required
{   output, o: file = $output
{   formats, format, f: list of key
{       ascii, hex
{     keyend = (ascii, hex)
{   byte_addresses, byte_address, ba: list of range of integer 0..amc$file_byte_limit = $optional
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 2] of clt$keyword_specification,
        recend,
        default_value: string (12),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$range_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 1, 25, 14, 12, 12, 768],
    clc$command, 11, 5, 1, 0, 0, 0, 5, 'OSM$DISF'], [
    ['BA                             ',clc$abbreviation_entry, 4],
    ['BYTE_ADDRESS                   ',clc$alias_entry, 4],
    ['BYTE_ADDRESSES                 ',clc$nominal_entry, 4],
    ['F                              ',clc$abbreviation_entry, 3],
    ['FORMAT                         ',clc$alias_entry, 3],
    ['FORMATS                        ',clc$nominal_entry, 3],
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 97,
  clc$optional_default_parameter, 0, 12],
{ PARAMETER 4
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 43, clc$optional_parameter,
  0, 0],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$list_type], [81, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [2], [
      ['ASCII                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['HEX                            ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ]
    ,
    '(ascii, hex)'],
{ PARAMETER 4
    [[1, 0, clc$list_type], [27, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$range_type], [20],
        [[1, 0, clc$integer_type], [0, amc$file_byte_limit, 10]]
      ]
    ],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

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

    CONST
      p$input = 1,
      p$output = 2,
      p$formats = 3,
      p$byte_addresses = 4,
      p$status = 5;

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

*copy clv$display_variables
?? NEWTITLE := 'abort_handler', EJECT ??

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


      clean_up;

    PROCEND abort_handler;
?? TITLE := 'clean_up', EJECT ??

    PROCEDURE clean_up;

      VAR
        ignore_status: ost$status;


      IF get_control.file_id <> amv$nil_file_identifier THEN
        clp$close_for_get (get_control, ignore_status);
      IFEND;
      clp$close_display (display_control, ignore_status);

    PROCEND clean_up;
*copy clp$new_page_procedure
?? TITLE := 'put_subtitle ', EJECT ??

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);


      clp$put_path_reference_subtitle (pvt [p$input].value^.file_value^, 'FILE ', status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      put_column_headers (display_control, status);

    PROCEND put_subtitle;
?? TITLE := 'put_column_headers', EJECT ??

    PROCEDURE put_column_headers
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

      CONST
        ascii_title_centering = 8,
        ascii_title_only = 13,
        ascii_header_length = 5,
        hex_title_centering = 17,
        hex_header_length = 11;

      VAR
        display_column: 1 .. max_output_line_size;


      clp$put_partial_display (display_control, ' BYTE ADDRESS', clc$no_trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF dump_format = hex THEN
        display_column := hex_start + hex_header_length + (hex_title_centering * $INTEGER (clv$wide));
        clp$horizontal_tab_display (display_control, display_column, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, 'HEXADECIMAL', clc$no_trim, amc$terminate, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSEIF dump_format = ascii THEN
        display_column := output_descriptor [clv$wide] [dump_format].ascii_start + ascii_header_length +
              ascii_title_centering + (ascii_title_only * $INTEGER (clv$wide));
        clp$horizontal_tab_display (display_control, display_column, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, 'ASCII', clc$no_trim, amc$terminate, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSEIF dump_format = ascii_hex THEN
        display_column := hex_start + hex_header_length + (hex_title_centering * $INTEGER (clv$wide));
        clp$horizontal_tab_display (display_control, display_column, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, 'HEXADECIMAL', clc$no_trim, amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        display_column := output_descriptor [clv$wide] [dump_format].ascii_start + ascii_header_length +
              (ascii_title_centering * $INTEGER (clv$wide));
        clp$horizontal_tab_display (display_control, display_column, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, 'ASCII', clc$no_trim, amc$terminate, status);
      IFEND;

    PROCEND put_column_headers;
*copy clp$put_path_reference_subtitle
?? TITLE := 'dump_part_of_file', EJECT ??

    PROCEDURE dump_part_of_file
      (    low_byte_address: amt$file_byte_address;
           high_byte_address: amt$file_byte_address;
           dump_format: dump_formats;
       VAR display_control {input, output} : clt$display_control;
       VAR get_control: clt$get_control_record;
       VAR status: ost$status);

       VAR
         v$non_legible_chars_to_spaces: [STATIC, READ, oss$job_paged_literal]
               string (256) := '                                 !"#$%&''()*+,-'
               CAT './0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcd' CAT
               'efghijkl' CAT 'mnopqrstuvwxyz{|}~';
       VAR
         hex_digits: [STATIC, READ, oss$job_paged_literal] array [0 .. 255] of
               string (2) := [{}
               '00', '01', '02', '03', '04', '05', '06', '07', '08', '09', '0a',
               '0b', '0c', '0d', '0e', '0f', '10', '11', '12', '13', '14', '15',
               '16', '17', '18', '19', '1a', '1b', '1c', '1d', '1e', '1f', '20',
               '21', '22', '23', '24', '25', '26', '27', '28', '29', '2a', '2b',
               '2c', '2d', '2e', '2f', '30', '31', '32', '33', '34', '35', '36',
               '37', '38', '39', '3a', '3b', '3c', '3d', '3e', '3f', '40', '41',
               '42', '43', '44', '45', '46', '47', '48', '49', '4a', '4b', '4c',
               '4d', '4e', '4f', '50', '51', '52', '53', '54', '55', '56', '57',
               '58', '59', '5a', '5b', '5c', '5d', '5e', '5f', '60', '61', '62',
               '63', '64', '65', '66', '67', '68', '69', '6a', '6b', '6c', '6d',
               '6e', '6f', '70', '71', '72', '73', '74', '75', '76', '77', '78',
               '79', '7a', '7b', '7c', '7d', '7e', '7f', '80', '81', '82', '83',
               '84', '85', '86', '87', '88', '89', '8a', '8b', '8c', '8d', '8e',
               '8f', '90', '91', '92', '93', '94', '95', '96', '97', '98', '99',
               '9a', '9b', '9c', '9d', '9e', '9f', 'a0', 'a1', 'a2', 'a3', 'a4',
               'a5', 'a6', 'a7', 'a8', 'a9', 'aa', 'ab', 'ac', 'ad', 'ae', 'af',
               'b0', 'b1', 'b2', 'b3', 'b4', 'b5', 'b6', 'b7', 'b8', 'b9', 'ba',
               'bb', 'bc', 'bd', 'be', 'bf', 'c0', 'c1', 'c2', 'c3', 'c4', 'c5',
               'c6', 'c7', 'c8', 'c9', 'ca', 'cb', 'cc', 'cd', 'ce', 'cf', 'd0',
               'd1', 'd2', 'd3', 'd4', 'd5', 'd6', 'd7', 'd8', 'd9', 'da', 'db',
               'dc', 'dd', 'de', 'df', 'e0', 'e1', 'e2', 'e3', 'e4', 'e5', 'e6',
               'e7', 'e8', 'e9', 'ea', 'eb', 'ec', 'ed', 'ee', 'ef', 'f0', 'f1',
               'f2', 'f3', 'f4', 'f5', 'f6', 'f7', 'f8', 'f9', 'fa', 'fb', 'fc',
               'fd', 'fe', 'ff'];

      VAR
        local_status: ost$status,
        line_size: integer,
        line: string (max_output_line_size),
        data: ^string (max_words_per_line * bytes_per_word),
        previous_data: string (max_words_per_line * bytes_per_word),
        duplicate_line_count: amt$file_byte_address,
        request_count: 2 * bytes_per_word .. max_words_per_line * bytes_per_word,
        current_byte_address: 0 .. amc$file_byte_limit + 1,
        line_index: 1 .. max_output_line_size + 1,
        data_index: 1 .. max_words_per_line * bytes_per_word,
        transfer_count: amt$transfer_count,
        ignore_byte_address: amt$file_byte_address,
        ignore_file_position: amt$file_position;

?? NEWTITLE := 'put_duplicate_line_count', EJECT ??

      PROCEDURE [INLINE] put_duplicate_line_count;


        IF duplicate_line_count <= 1 THEN
          RETURN;
        IFEND;
        IF duplicate_line_count = 2 THEN
          STRINGREP (line, line_size, '  ': hex_start + 1, 'Above line repeated 1 time.')
        ELSE
          STRINGREP (line, line_size, '  ': hex_start + 1, 'Above line repeated', duplicate_line_count - 1,
                ' times.');
        IFEND;
        clp$put_display (display_control, line (1, line_size), clc$no_trim, local_status);
        IF NOT local_status.normal THEN
          IF status.normal THEN
            status := local_status;
          IFEND;
          EXIT dump_part_of_file;
        IFEND;

      PROCEND put_duplicate_line_count;
?? OLDTITLE, EJECT ??

      status.normal := TRUE;
      clv$wide := display_control.page_width >= clc$wide_page_width;
      request_count := output_descriptor [clv$wide] [dump_format].words_per_line * bytes_per_word;
      duplicate_line_count := 0;

      current_byte_address := low_byte_address;
      WHILE current_byte_address <= high_byte_address DO
        clp$get_next_bytes (request_count, transfer_count, ignore_file_position, get_control, data, status);
        IF (NOT status.normal) OR (transfer_count = 0) THEN
          put_duplicate_line_count;
          IF status.normal AND (transfer_count = 0) THEN
            STRINGREP (line, line_size, '  ': hex_start + 1, 'End Of Information encountered.');
            clp$put_display (display_control, line (1, line_size), clc$no_trim, status);
          IFEND;
          RETURN;
        IFEND;
        IF transfer_count > (high_byte_address - current_byte_address + 1) THEN
          transfer_count := high_byte_address - current_byte_address + 1;
        IFEND;

        IF (duplicate_line_count > 0) AND (transfer_count = request_count) AND
              (data^ (1, request_count) = previous_data (1, request_count)) THEN
          duplicate_line_count := duplicate_line_count + 1;
        ELSE
          put_duplicate_line_count;
          duplicate_line_count := 1;
          previous_data (1, transfer_count) := data^ (1, transfer_count);

          line := '';
          clp$convert_integer_to_rjstring (current_byte_address, 10, FALSE, ' ',
                line (address_start, address_size), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF dump_format >= ascii_hex THEN
            line_index := hex_start - 1;
            FOR data_index := 1 TO transfer_count DO
              IF (data_index MOD bytes_per_word) = 1 THEN
                line_index := line_index + 1;
              IFEND;
              line (line_index, 2) := hex_digits [$INTEGER (data^ (data_index))];
              line_index := line_index + 2;
            FOREND;
          IFEND;
          IF dump_format <= ascii_hex THEN
            line_index := output_descriptor [clv$wide] [dump_format].ascii_start;
            #TRANSLATE (v$non_legible_chars_to_spaces, data^ (1, transfer_count),
                  line (line_index, transfer_count));
          IFEND;
          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        IFEND;
        current_byte_address := current_byte_address + transfer_count;
      WHILEND;

    PROCEND dump_part_of_file;
?? OLDTITLE, EJECT ??

    TYPE
      dump_format_selections = set of (select_ascii, select_hex);

    VAR
      buffer_required: boolean,
      current_byte_address: ^clt$data_value,
      current_format: ^clt$data_value,
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      dump_format: dump_formats,
      dump_format_selection: dump_format_selections,
      get_control: clt$get_control_record,
      high_byte_address: amt$file_byte_address,
      ignore_file_position: amt$file_position,
      ignore_status: ost$status,
      low_byte_address: amt$file_byte_address;


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

    current_format := pvt [p$formats].value;
    dump_format_selection := $dump_format_selections [];
    WHILE current_format <> NIL DO
      IF current_format^.element_value^.keyword_value = 'ASCII' THEN
        IF select_ascii IN dump_format_selection THEN
          osp$set_status_abnormal ('CL', cle$redundancy_in_selections, 'FORMAT', status);
          RETURN;
        IFEND;
        dump_format_selection := dump_format_selection + $dump_format_selections [select_ascii];
      ELSE {current_format^.element_value^.keyword_value = 'HEX'
        IF select_hex IN dump_format_selection THEN
          osp$set_status_abnormal ('CL', cle$redundancy_in_selections, 'FORMAT', status);
          RETURN;
        IFEND;
        dump_format_selection := dump_format_selection + $dump_format_selections [select_hex];
      IFEND;
      current_format := current_format^.link;
    WHILEND;

    IF dump_format_selection = $dump_format_selections [select_ascii, select_hex] THEN
      dump_format := ascii_hex;
    ELSEIF dump_format_selection = $dump_format_selections [select_ascii] THEN
      dump_format := ascii;
    ELSE
      dump_format := hex;
    IFEND;

    get_control.file_id := amv$nil_file_identifier;
    #SPOIL (get_control);
    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    osp$establish_block_exit_hndlr (^abort_handler);

  /dump_file/
    BEGIN
      clp$open_for_get (pvt [p$input].value^.file_value^, 'DISPLAY_FILE', pvt [p$byte_addresses].value <> NIL,
            ignore_file_position, get_control, buffer_required, status);
      IF NOT status.normal THEN
        EXIT /dump_file/;
      IFEND;
      IF buffer_required THEN
        PUSH get_control.sequence_pointer: [[REP clc$input_buffer_size OF cell]];
        #SPOIL (get_control);
      IFEND;

      default_ring_attributes.r1 := #RING (^default_ring_attributes);
      default_ring_attributes.r2 := #RING (^default_ring_attributes);
      default_ring_attributes.r3 := #RING (^default_ring_attributes);

      clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
            default_ring_attributes, display_control, status);
      IF NOT status.normal THEN
        clp$close_for_get (get_control, ignore_status);
        EXIT /dump_file/;
      IFEND;
      clv$titles_built := FALSE;
      clv$subtitles_built := FALSE;
      clv$command_name := 'display_file';

      IF (get_control.access_level = amc$segment) AND (get_control.sequence_pointer = NIL) THEN
        clp$put_display (display_control, '     Input file is empty.', clc$no_trim, ignore_status);
        clean_up;
        EXIT /dump_file/;
      IFEND;

      IF display_control.page_format = amc$continuous_form THEN
        clv$wide := display_control.page_width >= clc$wide_page_width;
        put_column_headers (display_control, status);
        IF NOT status.normal THEN
          clean_up;
          EXIT /dump_file/;
        IFEND;
      IFEND;

    /dump/
      BEGIN
        current_byte_address := pvt [p$byte_addresses].value;
        IF current_byte_address = NIL THEN
          dump_part_of_file (0, amc$file_byte_limit, dump_format, display_control, get_control, status);
        ELSE
          WHILE current_byte_address <> NIL DO
            low_byte_address := current_byte_address^.element_value^.low_value^.integer_value.value;
            high_byte_address := current_byte_address^.element_value^.high_value^.integer_value.value;
            IF low_byte_address <= high_byte_address THEN
              clp$seek_byte (low_byte_address, get_control, status);
              IF status.normal THEN
                dump_part_of_file (low_byte_address, high_byte_address, dump_format, display_control,
                      get_control, status);
              IFEND;
            ELSE
              osp$set_status_abnormal ('CL', cle$low_greater_than_high, 'BYTE_ADDRESS', status);
            IFEND;
            IF NOT status.normal THEN
              EXIT /dump/;
            IFEND;
            current_byte_address := current_byte_address^.link;
          WHILEND;
        IFEND;
      END /dump/;

      IF status.normal THEN
        clp$close_display (display_control, status);
      ELSE
        clp$close_display (display_control, ignore_status);
      IFEND;

      IF status.normal THEN
        clp$close_for_get (get_control, status);
      ELSE
        clp$close_for_get (get_control, ignore_status);
      IFEND;
    END /dump_file/;

    osp$disestablish_cond_handler;

  PROCEND clp$_display_file;

MODEND clm$dump_file_command;
*DECK DECK=CLM$EDIT_PARAMETER_LIST EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Display Command or Function Info' ??
MODULE clm$edit_parameter_list;

{
{ PURPOSE:
{   This module contains the procedures that support "editing" the parameter
{   list for a command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$parameters_displayed
*copyc cle$work_area_overflow
*copyc clt$command_line
*copyc clt$data_representation
*copyc clt$string_size
*copyc clt$work_area
*copyc ost$status
?? POP ??
*copyc clp$get_work_area
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*copyc clp$pop_block_stack
*copyc clp$pop_terminated_blocks
*copyc clp$process_command
*copyc clp$push_edit_parameters_block
*copyc clp$scan_non_space_lexical_unit
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal

?? TITLE := 'clp$edit_command_parameter_list', EJECT ??
*copyc clh$edit_command_parameter_list

  PROCEDURE [XDCL, #GATE] clp$edit_command_parameter_list
    (    command_and_parameters: clt$command_line;
         max_string: clt$string_size;
     VAR work_area {input, output} : ^clt$work_area;
     VAR edited_parameters: ^clt$data_representation;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      ignore_cause_condition: clt$when_condition,
      lexical_units: ^clt$lexical_units,
      local_status: ost$status,
      local_work_area: ^^clt$work_area,
      original_local_work_area: ^clt$work_area,
      parse: clt$parse_state;

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

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


      IF original_local_work_area <> NIL THEN
        local_work_area^ := original_local_work_area;
      IFEND;

      IF block <> NIL THEN
        clp$pop_terminated_blocks (block, local_status);
        clp$pop_block_stack (block);
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    edited_parameters := NIL;

    local_status.normal := TRUE;
    block := NIL;
    original_local_work_area := NIL;
    #SPOIL (block, original_local_work_area);

    osp$establish_block_exit_hndlr (^abort_handler);

  /edit_command_parameter_list/
    BEGIN
      clp$get_work_area (#RING (^local_work_area), local_work_area, local_status);
      IF NOT local_status.normal THEN
        EXIT /edit_command_parameter_list/;
      IFEND;
      original_local_work_area := local_work_area^;
      #SPOIL (original_local_work_area);

      clp$identify_lexical_units (^command_and_parameters, local_work_area^, lexical_units, local_status);
      IF NOT local_status.normal THEN
        EXIT /edit_command_parameter_list/;
      IFEND;
      clp$initialize_parse_state (^command_and_parameters, lexical_units, parse);
      clp$scan_non_space_lexical_unit (parse);

      clp$push_edit_parameters_block (max_string, block);

      clp$process_command (block, clc$help_mode, FALSE, FALSE, FALSE, FALSE, parse, ignore_cause_condition,
            local_status);
      IF NOT local_status.normal THEN
        IF local_status.condition <> cle$parameters_displayed THEN
          IF local_status.condition = cle$work_area_overflow THEN
            local_status.text.size := 0;
            osp$append_status_parameter (osc$status_parameter_delimiter, 'clp$edit_command_parameter_list',
                  local_status);
          IFEND;
          EXIT /edit_command_parameter_list/;
        IFEND;
        local_status.normal := TRUE;
      ELSEIF block^.edited_parameters = NIL THEN
        EXIT /edit_command_parameter_list/;
      IFEND;

      local_work_area^ := original_local_work_area;

      NEXT edited_parameters: [[REP #SIZE (block^.edited_parameters^) OF cell]] IN work_area;
      IF edited_parameters = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, 'clp$edit_command_parameter_list',
              local_status);
        EXIT /edit_command_parameter_list/;
      IFEND;

      edited_parameters^ := block^.edited_parameters^;
    END /edit_command_parameter_list/;

    IF (original_local_work_area <> NIL) AND (#SEGMENT (work_area) <> #SEGMENT (local_work_area^)) THEN
      local_work_area^ := original_local_work_area;
    IFEND;

    IF block <> NIL THEN
      clp$pop_terminated_blocks (block, local_status);
      clp$pop_block_stack (block);
    IFEND;

    osp$disestablish_cond_handler;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND clp$edit_command_parameter_list;

MODEND clm$edit_parameter_list;
*DECK DECK=CLM$ENABLE_COMMAND_REDO EXPAND=TRUE
PROC enable_command_redo, enacr (full_duplex,fd: boolean = no
     insert_mode,im: boolean = no)
IF $JOB(mode) = 'INTERACTIVE' THEN
  create_variable ss k=status
  create_variable params k=string
  setpa al=$system.tdu.terminal_definitions status=ss
  setpa al=$system.osf$command_library status=ss
  params = ' '
  IF $VALUE(full_duplex) = YES THEN
    params = 'F'
  IFEND;
  IF $VALUE(insert_mode) = YES THEN
    params = params // 'I'
  IFEND;
  IF $FILE($Local.command, opened) THEN
    chafa $local.command fap=clp$redo_operation ui=params status=ss
  ELSE
    setfa $local.command fap=clp$redo_operation ui=params status=ss
  IFEND
  IF NOT ss.normal THEN
    disv 'Command redo may only be enabled during the Login PROLOG.'
  IFEND
IFEND
PROCEND enable_command_redo
*DECK DECK=CLM$ENABLE_REDO_PROCESSOR EXPAND=TRUE
?? RIGHT := 110 ??
MODULE clm$enable_redo_processor;

{
{ PURPOSE:
{   This module sets flags in the shared segment access file to notify
{   Redo (which must already be active as a FAP) that it needs to reload
{   its TDU module. This may be because the user had not terminal type
{   established at login or because the user has switched terminal types
{   midsession. The flags also allow changing the insert_mode and the
{   full_duplex settings of redo.

?? NEWTITLE := '  Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$scan_parameter_list
*copyc clp$get_value
*copyc clp$read_variable
*copyc amp$fetch
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$put_next
*copyc clp$scan_command_line
*copyc ost$status
*copyc pmp$abort
*copyc pmp$exit
?? POP ??

?? TITLE := 'clp$enable_redo', EJECT ??

  PROGRAM clp$enable_redo
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{PDT for clm$enable_redo_processor}

{ PDT enable_redo_pdt (
{ full_duplex, fd : boolean = no
{ insert_mode, im : boolean = no
{ STATUS)

?? PUSH (LISTEXT := ON) ??

    VAR
      enable_redo_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^enable_redo_pdt_names, ^enable_redo_pdt_params];

    VAR
      enable_redo_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
            clt$parameter_name_descriptor := [['FULL_DUPLEX', 1], ['FD', 1], ['INSERT_MODE', 2], ['IM', 2],
            ['STATUS', 3]];

    VAR
      enable_redo_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
            clt$parameter_descriptor := [

{ FULL_DUPLEX FD }
      [[clc$optional_with_default, ^enable_redo_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$boolean_value]],

{ INSERT_MODE IM }
      [[clc$optional_with_default, ^enable_redo_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$boolean_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      enable_redo_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := 'no';

    VAR
      enable_redo_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := 'no';

?? POP ??

{End of PDT}

    VAR
      ba: amt$file_byte_address,
      file_id: amt$file_identifier,
      full_duplex_on: ^boolean,
      full_duplex_value: clt$value,
      insert_mode_on: ^boolean,
      insert_mode_value: clt$value,
      lfn: amt$local_file_name,
      log_ptr: amt$segment_pointer,
      redo_not_established: [STATIC] string (80) :=
            'enable_command_redo must be in login prolog to allow post-login use.',
      reset_tdu: ^boolean,
      seg_file_id: amt$file_identifier;


    lfn := 'OUTPUT';
    amp$open (lfn, amc$record, NIL, file_id, status);
    IF NOT status.normal THEN
      pmp$abort (status);
    IFEND;

{Crack the command for the parameter values.}

    clp$scan_parameter_list (parameter_list, enable_redo_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_value ('FULL_DUPLEX', 1, 1, clc$low, full_duplex_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_value ('INSERT_MODE', 1, 1, clc$low, insert_mode_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{Setup the shared segment access file for inter-task communication.}

    lfn := 'clf$redo_log';
    amp$open (lfn, amc$segment, NIL, seg_file_id, status);
    IF NOT status.normal THEN
      amp$put_next (file_id, ^redo_not_established, 80, ba, status);
      pmp$abort (status);
    IFEND;
    amp$get_segment_pointer (seg_file_id, amc$sequence_pointer, log_ptr, status);
    IF NOT status.normal THEN
      amp$put_next (file_id, ^redo_not_established, 80, ba, status);
      pmp$abort (status);
    IFEND;

    NEXT reset_tdu IN log_ptr.sequence_pointer;
    NEXT full_duplex_on IN log_ptr.sequence_pointer;
    NEXT insert_mode_on IN log_ptr.sequence_pointer;
    IF full_duplex_value.bool.value THEN
      full_duplex_on^ := TRUE;
    ELSE
      full_duplex_on^ := FALSE;
    IFEND;
    IF insert_mode_value.bool.value THEN
      insert_mode_on^ := TRUE;
    ELSE
      insert_mode_on^ := FALSE;
    IFEND;
    reset_tdu^ := TRUE;
    status.normal := TRUE;
    pmp$exit (status);

  PROCEND clp$enable_redo;

MODEND clm$enable_redo_processor;
*DECK DECK=CLM$ENVIRONMENT_OBJECT_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Environment Object Manager' ??
MODULE clm$environment_object_manager;

{
{ PURPOSE:
{   This module contains the tables that describe SCL "environment objects,"
{   CLV$ENVIRONMENT_OBJECT_DESCS and CLV$ENVIRONMENT_OBJECT_NAMES, and the
{   procedures that manage those environment objects.
{
{ NOTE:
{   The procedures in this module are common to all environment objects and
{   contain no "special case" code for any object.
{

*IF NOT $true(osv$unix)
{
{ WHAT IS AN ENVIRONMENT OBJECT?
{
{   An "environment object" is a named data item or structure that forms
{   part of a job's command environment.  Typical environment objects are the
{   working catalog, the preferred natural language for messages and the
{   command list.  What distinguishes an environment object from an "ordinary"
{   data item or structure is its ability to be "pushed" and "popped," i.e.
{   to have a "local copy" made of itself within a particular context, make
{   changes to that copy, and have the original state of the object restored
{   either by explicit request or when the context is exited.
{
{   An environment object typically has associated with it a command to change
{   its value, a command to display its value, and a function to return its
{   value.  Also, typically program interfaces are provided to interrogate and
{   change the object.
{
{   In addition to these "standard" environment objects, all SCL variables with
{   a scope of ENVIRONMENT (or any of its derivitives, e.g. JOB) can be treated
{   as environment objects, in the sense that they can be explicitly "pushed"
{   and "popped."
{

{
{ HOW TO IMPLEMENT AN ENVIRONMENT OBJECT:
{
{   Externally an environment object is known by a name.  Normally there is
{   only one name for an environment object; but occasionally an object is
{   redefined to an extent that its original name no longer acurately describes
{   it.  When this occurs, a new name is given to the object but its original
{   name is retained as an alias.  The names of the environment objects are
{   declared as constants in deck CLT$ENVIRONMENT_OBJECT.
{
{   Internally an implemented environment object is known by an ordinal
{   constant of type CLT$ENVIRONMENT_OBJECT_ORDINAL.  The correspondence
{   between the names (and aliases) of the objects and their ordinals is
{   defined in the variable CLV$ENVIRONMENT_OBJECT_NAMES, declared later in
{   this module.  This table defines the NAMEs of each the objects, whether
{   an object is IMPLEMENTED and, if it is, what its ORDINAL is.
{
{   Implemented environment objects are described to SCL in the variable
{   CLV$ENVIRONMENT_OBJECT_DESCS, also declared later in this module.  Each
{   entry in this table contains the index of the "nominal" name (NAME_INDEX)
{   of the object in the CLV$ENVIRONMENT_OBJECT_NAMES variable and pointers to
{   the procedures provided by the implementor of the object and called by the
{   environment object management routines under appropriate circumstances.
{
{   The SCL Interpreter provides a common protocol for handling the "pushing"
{   and "popping" for environment objects.  The implementor of an environment
{   object MUST call the CLP$FIND_ENVIRONMENT_OBJECT interface whenever it
{   needs to manipulate that object outside the context of the procedures
{   pointed to from the CLV$ENVIRONMENT_OBJECT_DESCS table.
{
{   An enironment object is always accessed via a pointer to cell, therefore
{   the implementor of a particular environment object must map this generic
{   pointer to a pointer of the appropriate type for the object.
{
{
{   The procedures provided by the implementor of an environment object that
{   are used by the environment object management routines are described below.
{   A SIZE_OF_OBJECT function and an INITIALIZE_OBJECT procedure must be
{   provided for an object.  All of the other procedures are optional, i.e.
{   their pointers may be NIL.
{
{
{   The SIZE_OF_OBJECT function returns the size (in CELLs) of the environment
{ object.  It is called once during job initialization; therefore the size of
{ an object, as known to the environment object management routines, cannot
{ change.
{
{       SIZE_OF_OBJECT: SIZE
{
{ This function has no parameters.
{
{
{   The INITIALIZE_OBJECT procedure is used to supply an initial value in a
{ job for an environment object.  The implementor of each environment object
{ must provide an INITIALIZE_OBJECT procedure which will be called during job
{ initialization.
{
{   This procedure should not do anything that depends on any other environment
{ object either directly or indirectly.  The initialization performed by this
{ procedure should be analogous to what could be done statically, at compile
{ time.
{
{       INITIALIZE_OBJECT (OBJECT)
{
{ OBJECT (input) :  This parameter points to the object to be initialized.
{
{
{   The PUSH_OBJECT procedure is used to perform the object-specific portion
{ of a "push" operation.  This procedure is passed a pointer to the new
{ instance of the object (which is a copy of the pushed instance), and is
{ responsible for performing any additional actions needed to copy a "complex"
{ object or otherwise complete the "push."
{
{   If this procedure is not provided for an object, all that happens for a "push"
{ operation is that the object is copied.
{
{       PUSH_OBJECT (PUSH_REASON, NEW_OBJECT, NEW_OBJECT_IN_CURRENT_TASK,
{             PUSHED_OBJECT_IN_CURRENT_TASK, PUSHED_OBJECT, STATUS)
{
{ PUSH_REASON (input) :  This parameter specifies the reason for the "push"
{       operation.
{
{       CLC$EO_PUSH_REQUESTED:  This indicates that the push resulted from
{             an explicit request.
{
{       CLC$EO_PUSH_FOR_TASK:  This indicates that the push is being done
{             automatically on behalf of a new asynchronous task by its parent
{             task.
{
{ NEW_OBJECT (input) :  This parameter points to the new instance of the
{       object.
{
{ NEW_OBJECT_IN_CURRENT_TASK (input) :  This parameter indicates whether the
{       new instance of the object resides in a block owned by the current
{       task.  (It is always FALSE when PUSH_REASON is CLC$EO_PUSH_FOR_TASK.)
{
{ PUSHED_OBJECT_IN_CURRENT_TASK (input) :  This parameter indicates whether the
{       pushed instance of the object resides in a block owned by the current
{       task.  (It is always FALSE when PUSH_REASON is CLC$EO_PUSH_FOR_TASK.)
{
{ PUSHED_OBJECT (input) :  This parameter points to the pushed instance of the
{       object.
{
{ STATUS (output) :  This parameter specifies the request status.
{
{
{   The POP_OBJECT procedure is used to perform the object-specific part of a
{ "pop" operation.  This procedure is passed a pointer to the instance of the
{ object being popped, as well as a pointer to the pushed instance.  It is
{ responsible for performing any additional actions needed to delete a "complex"
{ object and/or do any needed synchronizing activities.
{
{   If this procedure is not provided for an object, all that happens for a "pop"
{ operation is that the object is deleted.
{
{       POP_OBJECT (POP_REASON, OBJECT, OBJECT_IN_CURRENT_TASK,
{             PUSHED_OBJECT_IN_CURRENT_TASK, PUSHED_OBJECT, STATUS)
{
{ POP_REASON (input) :  This parameter specifies the reason for the "pop"
{       operation.
{
{       CLC$EO_POP_REQUESTED:  This indicates that the pop resulted from an
{             explicit request.
{
{       CLC$EO_POP_FOR_BLOCK:  This indicates that the pop is being done
{             automatically because the block containing its definition is
{             being popped.
{
{       CLC$EO_POP_FOR_TASK:  This indicates that the pop is being done
{             automatically because the block containing its definition belongs
{             to a task that has terminated and is being done by the parent of
{             of that task.
{
{       CLC$EO_POP_FOR_CLEANUP:  This indicates that the pop is being done
{             automatically as part of cleaning up an unsuccessful attempt to
{             create a new (asynchronous task) block by that task's parent.
{
{ OBJECT (input) :  This parameter points to the instance of the object being
{       popped.
{
{ OBJECT_IN_CURRENT_TASK (input) :  This parameter indicates whether the
{       instance of the object being popped resides in a block owned by the
{       current task.  (It is always FALSE when POP_REASON is
{       CLC$EO_POP_FOR_CLEANUP.)
{
{ PUSHED_OBJECT_IN_CURRENT_TASK (input) :  This parameter indicates whether the
{       pushed instance of the object resides in a block owned by the current
{       task.  (It is always FALSE when POP_REASON is CLC$EO_POP_FOR_CLEANUP or
{       when OBJECT is in an asynchronous task block.)
{
{ PUSHED_OBJECT (input) :  This parameter points to the instance of the object
{       that was pushed and will become the current instance as a result of the
{       "pop".  (It is always NIL when POP_REASON is CLC$EO_POP_FOR_CLEANUP or
{       when OBJECT is in an asynchronous task block.)
{
{ STATUS (output) :  This parameter specifies the request status.
{
{
{   The UPDATE_AFTER_TASK_TERMINATION procedure is used to to any needed
{ synchronizing activities for an environment object after a task has
{ terminated.
{
{   If this procedure is not provided for an object, no action is taken for the
{ object when a task terminates.
{
{       UPDATE_AFTER_TASK_TERMINATION (SYNCHRONOUS_WITH_PARENT,
{             SYNCHRONOUS_WITH_JOB, CURRENT_OBJECT,
{             CURRENT_OBJECT_IN_CURRENT_TASK, STATUS)
{
{ SYNCHRONOUS_WITH_PARENT (input) :  This parameter indicates whether the task
{       that terminated was running synchronously with respect to its parent
{       task.
{
{ SYNCHRONOUS_WITH_JOB (input) :  This parameter indicates whether the task
{       that terminated was running synchronously with respect to the job.
{
{ CURRENT_OBJECT (input) :  This parameter points to the current instance of
{       the object.
{
{ CURRENT_OBJECT_IN_CURRENT_TASK (input) :  This parameter indicates whether
{       the current instance of the object resides in a block owned by the
{       current task (the parent of the task that terminated).
{
{ STATUS (output) :  This parameter specifies the request status.
{
*IFEND

?? NEWTITLE := 'Global Declarations', EJECT ??
*copyc clt$environment_object
*copyc clt$environment_object_contents
*copyc clt$environment_object_location
*copyc clt$environment_object_ordinal
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_control_statement
*copyc cle$not_yet_implemented
*copyc cle$unknown_variable
*IF NOT $true(osv$unix)
*copyc cle$var_already_created
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc oss$task_shared
*ELSE
*copyc ost$status_message_level
*copyc clp$eo_init_command_list
*copyc clp$eo_size_command_list
*copyc osv$task_shared_heap
*copyc clt$environment_object_size
*copyc clp$find_current_block
*copyc clt$block
?? TITLE := 'osp$eo_size_message_level', EJECT ??

  FUNCTION [XDCL] osp$eo_size_message_level: clt$environment_object_size;


    osp$eo_size_message_level := #SIZE (ost$status_message_level);

  FUNCEND osp$eo_size_message_level;
?? TITLE := 'osp$eo_init_message_level', EJECT ??

  PROCEDURE [XDCL] osp$eo_init_message_level
    (    object: ^clt$environment_object_contents);

    VAR
      status_message_level: ^ost$status_message_level;


    status_message_level := object;
    status_message_level^ := osc$full_message_level;

  PROCEND osp$eo_init_message_level;
*IFEND
*copyc ost$status
?? SKIP := 3 ??

{
{ PURPOSE:
{   The following procedure exists solely to provide a "shelter" for the
{   declarations contained in certain decks that are *COPYC'd into this
{   deck.  For example, this module defines an XDCL'd variable that is
{   referenced by an INLINE procedure.  In order to make the deck containing
{   the INLINE procedure "self-contained" it *COPYCs the deck containing the
{   XREF declaration of the variable.  Since the INLINE procedure is needed
{   in this module, both the XDCL and XREF declaration will appear in this
{   module.  The following "dummy" procedure is used to hide the XREF
{   declaration of the variable from the rest of the module.
{

  PROCEDURE [INLINE] dummy;

*copyc clp$find_env_object_first_time
*copyc clv$environment_object_location

  PROCEND dummy;
?? SKIP := 3 ??
*IF NOT $true(osv$unix)
*copyc clp$eo_init_command_list
*copyc clp$eo_init_file_connections
*copyc clp$eo_init_scl_options
*copyc clp$eo_init_unseen_mail_action
*copyc clp$eo_init_working_catalog
*copyc clp$eo_pop_command_list
*copyc clp$eo_pop_file_connections
*copyc clp$eo_pop_unseen_mail_action
*copyc clp$eo_pop_working_catalog
*copyc clp$eo_push_command_list
*copyc clp$eo_push_file_connections
*copyc clp$eo_push_working_catalog
*copyc clp$eo_size_command_list
*copyc clp$eo_size_file_connections
*copyc clp$eo_size_scl_options
*copyc clp$eo_size_unseen_mail_action
*copyc clp$eo_size_working_catalog
*copyc clp$eo_updt_command_list
*copyc clp$eo_updt_unseen_mail_action
*copyc osp$eo_init_interaction_info
*copyc osp$eo_init_message_level
*copyc osp$eo_init_natural_language
*copyc osp$eo_size_interaction_info
*copyc osp$eo_size_message_level
*copyc osp$eo_size_natural_language
*copyc pmp$eo_init_program_attributes
*copyc pmp$eo_pop_program_attributes
*copyc pmp$eo_push_program_attributes
*copyc pmp$eo_size_program_attributes
?? POP ??
*copyc clp$create_var_from_type_spec
*copyc clp$find_current_block
*copyc clp$find_environment_object
*copyc clp$get_work_area
*copyc clp$internal_delete_variable
*copyc clp$validate_name
*copyc i#move
*copyc osp$set_status_abnormal
*copyc osv$task_shared_heap
*ELSE
*copyc osp$eo_init_interaction_info
*copyc osp$eo_size_interaction_info
*IFEND
?? OLDTITLE ??
?? NEWTITLE := 'Local Declarations', EJECT ??

{
{ CLC$EO_IMPLEMENTED represents the number of implemented environemnt objects.
{
{ NOTE: If the CLT$ENVIRONMENT_OBJECT_ORDINAL type is changed such that there
{ is a new "uppervalue," the definition of CLC$EO_IMPLEMENTED must be updated.
{

  CONST
*IF NOT $true(osv$unix)
    clc$eo_implemented = $INTEGER (clc$eo_working_catalog) + 1;
*ELSE
    clc$eo_implemented = $INTEGER (clc$eo_message_level) + 1;
*IFEND

{
{ CLC$EO_NOT_IMPLEMENTED represents the number of unimplemented environemnt
{ objects.
{

  CONST
*IF NOT $true(osv$unix)
    clc$eo_not_implemented = 4;
*ELSE
    clc$eo_not_implemented = 0;
*IFEND

{
{ CLC$EO_ALIASES represents the number of alias names for environemnt objects.
{ Such aliases arise when an environment object is renamed (for whatever
{ reason) and the old name is retained as an alias for the new.
{

  CONST
*IF NOT $true(osv$unix)
    clc$eo_aliases = 1;
*ELSE
    clc$eo_aliases = 0;
*IFEND

*IF NOT $true(osv$unix)
{
{ The following constant defines the alias for the INTERACTION_INFORMATION
{ environment object.
{

  CONST
    clc$old_interaction_style = 'INTERACTION_STYLE              ';

*IFEND
{
{ CLC$EO_DEFINED_NAMES represents the number of defined names for environemnt
{ objects.
{

  CONST
    clc$eo_defined_names = clc$eo_implemented + clc$eo_not_implemented + clc$eo_aliases;

{
{ The following type is used for indices (offsets) into the CLT$ENVIRONMENT_OBJECT_INFO.CONTENTS array and
{ for the total size of that array.
{

  TYPE
    clt$environment_object_index = 0 .. 0ffff(16);

?? OLDTITLE ??
?? NEWTITLE := 'clv$environment_object_names', EJECT ??

{
{ The CLV$ENVIRONMENT_OBJECT_NAMES table contains an entry for each defined
{ environment object.  Each entry contains the object's NAME (or an alias),
{ a boolean indicating whether the object is IMPLEMENTED and, if it is, its
{ ORDINAL.
{
{ This table must be maintained in alphabetical order by name.
{

?? FMT (FORMAT := OFF) ??

  VAR
*IF NOT $true(osv$unix)
    clv$environment_object_names: [STATIC, READ, oss$job_paged_literal]
*ELSE
    clv$environment_object_names: [STATIC, READ]
*IFEND
          array [1 .. clc$eo_defined_names] of record
            name: clt$environment_object,
            case implemented: boolean of
            = FALSE =
              ,
            = TRUE =
              ordinal: clt$environment_object_ordinal,
            casend,
          recend := [

*IF NOT $true(osv$unix)
          [clc$attach_file_defaults,        FALSE],
          [clc$command_list,                TRUE, clc$eo_command_list],
          [clc$file_attribute_defaults,     FALSE],
          [clc$file_connections,            TRUE, clc$eo_file_connections],
          [clc$interaction_information,     TRUE, clc$eo_interaction_information],
          [clc$old_interaction_style,       TRUE, clc$eo_interaction_information],
          [clc$link_attributes,             FALSE],
          [clc$message_level,               TRUE, clc$eo_message_level],
          [clc$message_receipt_action,      FALSE],
          [clc$natural_language,            TRUE, clc$eo_natural_language],
          [clc$program_attributes,          TRUE, clc$eo_program_attributes],
          [clc$scl_options,                 TRUE, clc$eo_scl_options],
          [clc$unseen_mail_action,          TRUE, clc$eo_unseen_mail_action],
          [clc$working_catalog,             TRUE, clc$eo_working_catalog]];
*ELSE
          [clc$command_list,                TRUE, clc$eo_command_list],
          [clc$interaction_information,     TRUE, clc$eo_interaction_information],
          [clc$message_level,               TRUE, clc$eo_message_level]];
*IFEND

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
?? NEWTITLE := 'clv$environment_object_descs', EJECT ??

{
{ The CLV$ENVIRONMNT_OBJECT_DESCS table describes the specifics for all of the
{ implemented environment objects.  Each entry contains the NAME_INDEX into the
{ CLV$ENVIRONMENT_OBJECT_NAMES table (in order to be able to determine an
{ object's name given its ordinal) and pointers to the procedures (described in
{ the commentary at the beginning of this module) for the particular objects.
{

?? FMT (FORMAT := OFF) ??

  VAR
*IF NOT $true(osv$unix)
    clv$environment_object_descs: [STATIC, READ, oss$job_paged_literal]
*ELSE
    clv$environment_object_descs: [STATIC, READ]
*IFEND
          array [clt$environment_object_ordinal] of record
            name_index: 1 .. clc$eo_defined_names,
            size_of_object: ^function: clt$environment_object_size,
            initialize_object: ^procedure
                  (    object: ^clt$environment_object_contents),
*IF NOT $true(osv$unix)
            push_object: ^procedure
                  (    push_reason: clt$env_object_push_reason;
                       new_object: ^clt$environment_object_contents;
                       new_object_in_current_task: boolean;
                       pushed_object_in_current_task: boolean;
                       pushed_object: ^clt$environment_object_contents;
                   VAR status: ost$status),
            pop_object: ^procedure
                  (    pop_reason: clt$env_object_pop_reason;
                       object: ^clt$environment_object_contents;
                       object_in_current_task: boolean;
                       pushed_object_in_current_task: boolean;
                       pushed_object: ^clt$environment_object_contents;
                   VAR status: ost$status),
            update_after_task_termination: ^procedure
                  (    synchronous_with_parent: boolean;
                       synchronous_with_job: boolean;
                       current_object: ^clt$environment_object_contents;
                       current_object_in_current_task: boolean;
                   VAR status: ost$status),
*IFEND
          recend := [

*IF NOT $true(osv$unix)
          { attach_file_defaults            } { 1, *** NOT IMPLEMENTED }
          { command_list                    } [ 2,
                                              ^clp$eo_size_command_list,
                                              ^clp$eo_init_command_list,
                                              ^clp$eo_push_command_list,
                                              ^clp$eo_pop_command_list,
                                              ^clp$eo_updt_command_list],
          { file_attribute_defaults         } { 3, *** NOT IMPLEMENTED }
          { file_connections                } [ 4,
                                              ^clp$eo_size_file_connections,
                                              ^clp$eo_init_file_connections,
                                              ^clp$eo_push_file_connections,
                                              ^clp$eo_pop_file_connections,
                                              NIL],
          { interaction_information         } [ 5,
                                              ^osp$eo_size_interaction_info,
                                              ^osp$eo_init_interaction_info,
                                              NIL,
                                              NIL,
                                              NIL],
          { link_attributes                 } { 7, *** NOT IMPLEMENTED }
          { message_level                   } [ 8,
                                              ^osp$eo_size_message_level,
                                              ^osp$eo_init_message_level,
                                              NIL,
                                              NIL,
                                              NIL],
          { message_receipt_action          } { 9, *** NOT IMPLEMENTED }
          { natural_language                } [10,
                                              ^osp$eo_size_natural_language,
                                              ^osp$eo_init_natural_language,
                                              NIL,
                                              NIL,
                                              NIL],
          { program_attributes              } [11,
                                              ^pmp$eo_size_program_attributes,
                                              ^pmp$eo_init_program_attributes,
                                              ^pmp$eo_push_program_attributes,
                                              ^pmp$eo_pop_program_attributes,
                                              NIL],
          { scl_options                     } [12,
                                              ^clp$eo_size_scl_options,
                                              ^clp$eo_init_scl_options,
                                              NIL,
                                              NIL,
                                              NIL],
          { unseen_mail_action              } [13,
                                              ^clp$eo_size_unseen_mail_action,
                                              ^clp$eo_init_unseen_mail_action,
                                              NIL,
                                              ^clp$eo_pop_unseen_mail_action,
                                              ^clp$eo_updt_unseen_mail_action],
          { working_catalog                 } [14,
                                              ^clp$eo_size_working_catalog,
                                              ^clp$eo_init_working_catalog,
                                              ^clp$eo_push_working_catalog,
                                              ^clp$eo_pop_working_catalog,
                                              NIL]];
*ELSE
          { command_list                    } [ 1,
                                              ^clp$eo_size_command_list,
                                              ^clp$eo_init_command_list],
          { interaction_information         } [ 5,
                                              ^osp$eo_size_interaction_info,
                                              ^osp$eo_init_interaction_info],
          { message_level                   } [ 2,
                                              ^osp$eo_size_message_level,
                                              ^osp$eo_init_message_level]];
*IFEND

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
?? NEWTITLE := 'clv$environment_object_location', EJECT ??

{
{ The CLV$ENVIRONMENT_OBJECT_LOCATION table is used to optimize access to the
{ environment objects within a task.  Each task has its own copy of this table.
{ The OBJECT field points to the current instance of the object and the
{ OBJECT_IN_CURRENT_TASK field indicates whether the current instance of the
{ object is in a block owned by the task which owns the table.  If the OBJECT
{ field is NIL, the current instance of the object must be located by searching
{ the block stack for it.
{

  VAR
*IF NOT $true(osv$unix)
    clv$environment_object_location: [XDCL, #GATE, oss$task_private] clt$environment_object_location :=
*ELSE
    clv$environment_object_location: [XDCL, #GATE] clt$environment_object_location :=
*IFEND
          [REP clc$eo_implemented of [NIL, * ]];

?? OLDTITLE ??
?? NEWTITLE := 'clv$environment_object_slices', EJECT ??

{
{ The CLV$ENVIRONMENT_OBJECT_SLICES table is used to hold the indices and cell
{ count of the data for the environment objects within the CONTENTS field of a
{ CLT$ENVIRONMENT_OBJECTS_INFO record.  These are determined during job
{ initialization via calls to the SIZE_OF_OBJECTS functions defined for each
{ environment object.
{

  VAR
*IF NOT $true(osv$unix)
    clv$environment_object_slices: [STATIC, oss$task_shared] array [clt$environment_object_ordinal] of record
*ELSE
    clv$environment_object_slices: [STATIC] array [clt$environment_object_ordinal] of record
*IFEND
      index: clt$environment_object_index,
      size: clt$environment_object_size,
    recend;

?? OLDTITLE ??
?? NEWTITLE := 'clv$environment_objects_size', EJECT ??

{
{ The CLV$ENVIRONMENT_OBJECTS_SIZE variable is used to hold the total number of
{ cells needed for the CONTENTS field of a CLT$ENVIRONMENT_OBJECTS_INFO
{ record.  This value is determined during job initialization via calls to the
{ SIZE_OF_OBJECTS functions defined for each environment object.
{

  VAR
*IF NOT $true(osv$unix)
    clv$environment_objects_size: [STATIC, oss$task_shared] clt$environment_object_index;
*ELSE
    clv$environment_objects_size: [STATIC] clt$environment_object_index;
*IFEND

?? OLDTITLE ??
?? NEWTITLE := 'clp$environment_object_in_block', EJECT ??

{
{ PURPOSE:
{   This function is used to locate an environment object in a particular
{   block.
{

  FUNCTION [XDCL] clp$environment_object_in_block
    (    object_ordinal: clt$environment_object_ordinal;
         block: ^clt$block): ^clt$environment_object_contents;


    IF (block^.environment_object_info = NIL) OR (NOT block^.environment_object_info^.
          defined [object_ordinal]) THEN
      clp$environment_object_in_block := NIL;
    ELSE
      clp$environment_object_in_block := ^block^.environment_object_info^.
            contents [clv$environment_object_slices [object_ordinal].index];
    IFEND;

  FUNCEND clp$environment_object_in_block;
?? OLDTITLE ??
?? NEWTITLE := 'clp$environment_object_name', EJECT ??

{
{ PURPOSE:
{   This function is used to get the name of an environment object given its
{   ordinal.
{

  FUNCTION [XDCL, #GATE] clp$environment_object_name
    (    object_ordinal: clt$environment_object_ordinal): ^clt$environment_object;


    clp$environment_object_name := ^clv$environment_object_names
          [clv$environment_object_descs [object_ordinal].name_index].name;

  FUNCEND clp$environment_object_name;
?? OLDTITLE ??
?? NEWTITLE := 'clp$find_env_object_first_time', EJECT ??

{
{ PURPOSE:
{   This procedure is used by CLP$FIND_ENVIRONMENT_OBJECT to search for
{   an object in the block stack when its entry in the requesting tasks'
{   CLV$ENVIRONMENT_OBJECT_LOCATION table is NIL.  It stores the location
{   information in that table as well as returning it to its caller.
{

  PROCEDURE [XDCL, #GATE] clp$find_env_object_first_time
    (    object_ordinal: clt$environment_object_ordinal;
     VAR object_in_current_task: boolean;
     VAR object: ^clt$environment_object_contents);

    VAR
      block: ^clt$block;


    find_block_containing_object (object_ordinal, block, clv$environment_object_location [object_ordinal].
          object_in_current_task);

    clv$environment_object_location [object_ordinal].object := ^block^.environment_object_info^.
          contents [clv$environment_object_slices [object_ordinal].index];

    object := clv$environment_object_location [object_ordinal].object;
    object_in_current_task := clv$environment_object_location [object_ordinal].object_in_current_task;

  PROCEND clp$find_env_object_first_time;
?? OLDTITLE ??
?? NEWTITLE := 'clp$init_all_environment', EJECT ??

{
{ PURPOSE:
{   This procedure is called during job initialization to get the initial
{   "values" for all of the environment objects.
{
{ DESIGN:
{   The SIZE_OF_OBJECT function for each object is called to initialize the
{   CLV$ENVIRONMENT_OBJECT_SLICES and CLV$ENVIRONMENT_OBJECTS_SIZE variables
{   for the job.  Then space is allocated space for the job block's
{   ENVIRONMENT_OBJECT_INFO.  Finally the INITIALIZE_OBJECT procedure is
{   called for each object.
{
{ NOTE:
{   Subrange checking is forced on for this procedure in order to more easily
{   detect a bad size returned for a particular environment object.
{

?? PUSH (CHKRNG := ON) ??

  PROCEDURE [XDCL] clp$init_all_environment
    (VAR environment_object_info: ^clt$environment_object_info);

    VAR
      i: clt$environment_object_ordinal,
      object: ^clt$environment_object_contents;


    clv$environment_objects_size := 0;

    FOR i := LOWERVALUE (clt$environment_object_ordinal) TO UPPERVALUE (clt$environment_object_ordinal) DO
      clv$environment_object_slices [i].index := clv$environment_objects_size;
      clv$environment_object_slices [i].size := clv$environment_object_descs [i].size_of_object^ ();
      clv$environment_objects_size := clv$environment_objects_size + clv$environment_object_slices [i].size;
    FOREND;

    ALLOCATE environment_object_info: [0 .. clv$environment_objects_size - 1] IN osv$task_shared_heap^;

    FOR i := LOWERVALUE (clt$environment_object_ordinal) TO UPPERVALUE (clt$environment_object_ordinal) DO
      environment_object_info^.defined [i] := TRUE;
      object := ^environment_object_info^.contents [clv$environment_object_slices [i].index];
      clv$environment_object_descs [i].initialize_object^ (object);
      clv$environment_object_location [i].object := object;
      clv$environment_object_location [i].object_in_current_task := TRUE;
    FOREND;

  PROCEND clp$init_all_environment;
?? POP ??
?? OLDTITLE ??
*IF NOT $true(osv$unix)
?? NEWTITLE := 'clp$pop_all_environment', EJECT ??

{
{ PURPOSE:
{   This procedure is called to pop all environment objects in a block
{   and release the space they occupied.  It can be called when a block
{   is being popped within a task or when a task has terminated and all
{   of its blocks are being popped by its parent.
{

  PROCEDURE [XDCL, #GATE] clp$pop_all_environment
    (    pop_reason: clc$eo_pop_for_block .. clc$eo_pop_for_task;
         block: ^clt$block);

    VAR
      i: clt$environment_object_ordinal,
      ignore_status: ost$status,
      popped_object: ^clt$environment_object_contents,
      popped_object_in_current_task: boolean,
      pushed_object: ^clt$environment_object_contents,
      pushed_object_in_current_task: boolean;


    IF block^.environment_object_info = NIL THEN
      RETURN;
    IFEND;

    popped_object_in_current_task := pop_reason = clc$eo_pop_for_block;

    FOR i := LOWERVALUE (clt$environment_object_ordinal) TO UPPERVALUE (clt$environment_object_ordinal) DO
      IF block^.environment_object_info^.defined [i] THEN
        popped_object := ^block^.environment_object_info^.contents [clv$environment_object_slices [i].index];
        block^.environment_object_info^.defined [i] := FALSE;

        find_pushed_object (i, block, popped_object_in_current_task, pushed_object,
              pushed_object_in_current_task);

        IF popped_object_in_current_task THEN
          clv$environment_object_location [i].object := pushed_object;
          clv$environment_object_location [i].object_in_current_task := pushed_object_in_current_task;
        IFEND;

        IF clv$environment_object_descs [i].pop_object <> NIL THEN
          clv$environment_object_descs [i].pop_object^ (pop_reason, popped_object,
                popped_object_in_current_task, pushed_object_in_current_task, pushed_object, ignore_status);
        IFEND;
      IFEND;
    FOREND;

    FREE block^.environment_object_info IN osv$task_shared_heap^;

  PROCEND clp$pop_all_environment;
?? OLDTITLE ??
?? NEWTITLE := 'clp$pop_environment', EJECT ??
*copyc clh$pop_environment

  PROCEDURE [XDCL, #GATE] clp$pop_environment
    (    object: clt$environment_object;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      name_is_valid: boolean,
      object_implemented: boolean,
      object_name: ost$name,
      object_name_found: boolean,
      object_ordinal: clt$environment_object_ordinal,
      popped_object: ^clt$environment_object_contents,
      popped_object_in_current_task: boolean,
      pushed_object: ^clt$environment_object_contents,
      pushed_object_in_current_task: boolean;


    status.normal := TRUE;

    clp$validate_name (object, object_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal ('CL', cle$improper_env_object_name, object, status);
      RETURN;
    IFEND;

    search_environment_object_names (object_name, object_ordinal, object_implemented, object_name_found);

    IF NOT object_name_found THEN
      clp$internal_delete_variable (object_name, $clt$internal_variable_classes [clc$pushed_variable],
            status);
      IF (NOT status.normal) AND (status.condition = cle$unknown_variable) THEN
        osp$set_status_abnormal ('CL', cle$no_object_to_pop, object, status);
      IFEND;
      RETURN;

    ELSEIF NOT object_implemented THEN
      osp$set_status_abnormal ('CL', cle$not_yet_implemented, object, status);
      RETURN;
    IFEND;

    find_block_containing_object (object_ordinal, block, popped_object_in_current_task);
    IF (block^.kind = clc$task_block) AND (NOT block^.synchronous_with_parent) THEN
      osp$set_status_abnormal ('CL', cle$no_object_to_pop, object, status);
      RETURN;
    IFEND;

    popped_object := ^block^.environment_object_info^.contents
          [clv$environment_object_slices [object_ordinal].index];
    block^.environment_object_info^.defined [object_ordinal] := FALSE;

    find_pushed_object (object_ordinal, block, popped_object_in_current_task, pushed_object,
          pushed_object_in_current_task);

    clv$environment_object_location [object_ordinal].object := pushed_object;
    clv$environment_object_location [object_ordinal].object_in_current_task := pushed_object_in_current_task;

    IF clv$environment_object_descs [object_ordinal].pop_object <> NIL THEN
      clv$environment_object_descs [object_ordinal].pop_object^
            (clc$eo_pop_requested, popped_object, popped_object_in_current_task,
            pushed_object_in_current_task, pushed_object, status);
    IFEND;

  PROCEND clp$pop_environment;
?? OLDTITLE ??
?? NEWTITLE := 'clp$push_all_environment', EJECT ??

{
{ PURPOSE:
{   This procedure is used to make a copy of all environment objects for a new
{   asynchronous task by that task's parent.
{

  PROCEDURE [XDCL, #GATE] clp$push_all_environment
    (    child_task_block: ^clt$block;
     VAR status: ost$status);

    VAR
      i: clt$environment_object_ordinal,
      ignore_object_in_current_task: boolean,
      ignore_status: ^ost$status,
      new_object: ^clt$environment_object_contents,
      pushed_object: ^clt$environment_object_contents;


    status.normal := TRUE;

    ALLOCATE child_task_block^.environment_object_info: [0 .. clv$environment_objects_size - 1] IN
          osv$task_shared_heap^;

  /push_objects/
    FOR i := LOWERVALUE (clt$environment_object_ordinal) TO UPPERVALUE (clt$environment_object_ordinal) DO
      clp$find_environment_object (i, pushed_object, ignore_object_in_current_task);

      child_task_block^.environment_object_info^.defined [i] := TRUE;
      new_object := ^child_task_block^.environment_object_info^.
            contents [clv$environment_object_slices [i].index];

      IF clv$environment_object_descs [i].push_object = NIL THEN
        i#move (pushed_object, new_object, clv$environment_object_slices [i].size);
      ELSE
        clv$environment_object_descs [i].push_object^ (clc$eo_push_for_task, new_object, FALSE, FALSE,
              pushed_object, status);
        IF NOT status.normal THEN
          child_task_block^.environment_object_info^.defined [i] := FALSE;
          EXIT /push_objects/;
        IFEND;
      IFEND;
    FOREND /push_objects/;

    IF status.normal THEN
      RETURN;
    IFEND;

    PUSH ignore_status;
    FOR i := LOWERVALUE (clt$environment_object_ordinal) TO i DO
      IF child_task_block^.environment_object_info^.defined [i] AND
            (clv$environment_object_descs [i].pop_object <> NIL) THEN
        clv$environment_object_descs [i].pop_object^ (clc$eo_pop_for_cleanup, new_object, FALSE, FALSE, NIL,
              ignore_status^);
      IFEND;
    FOREND;

  PROCEND clp$push_all_environment;
?? OLDTITLE ??
?? NEWTITLE := 'clp$push_environment', EJECT ??
*copyc clh$push_environment

  PROCEDURE [XDCL, #GATE] clp$push_environment
    (    object: clt$environment_object;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      i: clt$environment_object_ordinal,
      name_is_valid: boolean,
      new_object: ^clt$environment_object_contents,
      new_object_in_current_task: boolean,
      object_implemented: boolean,
      object_name: ost$name,
      object_name_found: boolean,
      object_ordinal: clt$environment_object_ordinal,
      original_work_area: ^clt$work_area,
      pushed_object: ^clt$environment_object_contents,
      pushed_object_in_current_task: boolean,
      work_area_ptr: ^^clt$work_area;


    status.normal := TRUE;

    clp$validate_name (object, object_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal ('CL', cle$improper_env_object_name, object, status);
      RETURN;
    IFEND;

    search_environment_object_names (object_name, object_ordinal, object_implemented, object_name_found);

    IF NOT object_name_found THEN
*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^work_area_ptr), work_area_ptr, status);
*ELSE
      clp$get_work_area (osc$user_ring, work_area_ptr, status);
*IFEND
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      original_work_area := work_area_ptr^;
      clp$create_var_from_type_spec (object_name, clc$push_scope, clc$read_write, clc$immediate_evaluation,
            NIL, NIL, TRUE, work_area_ptr^, status);
      IF NOT status.normal THEN
        IF status.condition = cle$var_already_created THEN
          osp$set_status_abnormal ('CL', cle$object_already_pushed, object, status);
        ELSEIF status.condition = cle$unknown_variable THEN
          osp$set_status_abnormal ('CL', cle$not_an_environment_object, object, status);
        IFEND;
      IFEND;
      work_area_ptr^ := original_work_area;
      RETURN;

    ELSEIF NOT object_implemented THEN
      osp$set_status_abnormal ('CL', cle$not_yet_implemented, object, status);
      RETURN;
    IFEND;

    find_environment_block (block, new_object_in_current_task);

    IF block^.environment_object_info = NIL THEN
      ALLOCATE block^.environment_object_info: [0 .. clv$environment_objects_size - 1] IN
            osv$task_shared_heap^;
      FOR i := LOWERVALUE (clt$environment_object_ordinal) TO UPPERVALUE (clt$environment_object_ordinal) DO
        block^.environment_object_info^.defined [i] := FALSE;
      FOREND;

    ELSEIF block^.environment_object_info^.defined [object_ordinal] THEN
      osp$set_status_abnormal ('CL', cle$object_already_pushed, object, status);
      RETURN;
    IFEND;

    clp$find_environment_object (object_ordinal, pushed_object, pushed_object_in_current_task);

    block^.environment_object_info^.defined [object_ordinal] := TRUE;
    new_object := ^block^.environment_object_info^.contents
          [clv$environment_object_slices [object_ordinal].index];

    clv$environment_object_location [object_ordinal].object := new_object;
    clv$environment_object_location [object_ordinal].object_in_current_task := new_object_in_current_task;

    IF clv$environment_object_descs [object_ordinal].push_object = NIL THEN
      i#move (pushed_object, new_object, clv$environment_object_slices [object_ordinal].size);
    ELSE
      clv$environment_object_descs [object_ordinal].push_object^
            (clc$eo_push_requested, new_object, new_object_in_current_task, pushed_object_in_current_task,
            pushed_object, status);
      IF NOT status.normal THEN
        block^.environment_object_info^.defined [object_ordinal] := FALSE;
        clv$environment_object_location [object_ordinal].object := pushed_object;
        clv$environment_object_location [object_ordinal].object_in_current_task :=
              pushed_object_in_current_task;
        RETURN;
      IFEND;
    IFEND;

  PROCEND clp$push_environment;
?? OLDTITLE ??
?? NEWTITLE := 'clp$update_all_environment', EJECT ??

{
{ PURPOSE:
{   This procedure is called by the parent task of a child task that has just
{   terminated to allow for any needed updating  or processing of state
{   information for the objects in the parent task.
{

  PROCEDURE [XDCL] clp$update_all_environment
    (    synchronous_with_parent: boolean;
         synchronous_with_job: boolean;
     VAR status: ost$status);

    VAR
      i: clt$environment_object_ordinal,
      local_status: ost$status,
      object: ^clt$environment_object_contents,
      object_in_current_task: boolean;


    status.normal := TRUE;

    FOR i := LOWERVALUE (clt$environment_object_ordinal) TO UPPERVALUE (clt$environment_object_ordinal) DO
      IF synchronous_with_parent THEN
        clv$environment_object_location [i].object := NIL;
      IFEND;

      IF clv$environment_object_descs [i].update_after_task_termination <> NIL THEN
        clp$find_environment_object (i, object, object_in_current_task);
        clv$environment_object_descs [i].update_after_task_termination^
              (synchronous_with_parent, synchronous_with_job, object, object_in_current_task, local_status);
        IF (NOT local_status.normal) AND status.normal THEN
          status := local_status;
        IFEND;
      IFEND;
    FOREND;

  PROCEND clp$update_all_environment;
?? OLDTITLE ??
*IFEND
?? NEWTITLE := 'find_block_containing_object', EJECT ??

{
{ PURPOSE:
{   This procedure searches the block stack to find a block containing the
{   definition of a specified environment object.
{

  PROCEDURE [INLINE] find_block_containing_object
    (    object_ordinal: clt$environment_object_ordinal;
     VAR block: ^clt$block;
     VAR block_in_current_task: boolean);


    clp$find_current_block (block);
    block_in_current_task := TRUE;

    WHILE (block <> NIL) AND ((block^.environment_object_info = NIL) OR
          (NOT block^.environment_object_info^.defined [object_ordinal])) DO
      IF block^.kind = clc$task_block THEN
        block_in_current_task := FALSE;
        IF NOT block^.synchronous_with_parent THEN
          block := NIL;
          RETURN;
        IFEND;
      IFEND;
      block := block^.previous_block;
    WHILEND;

  PROCEND find_block_containing_object;
?? OLDTITLE ??
*IF NOT $true(osv$unix)
?? NEWTITLE := 'find_environment_block', EJECT ??

{
{ PURPOSE:
{   This procedure searches the block stack for a block that can hold
{   environment objects.
{

  PROCEDURE [INLINE] find_environment_block
    (VAR block: ^clt$block;
     VAR block_found_in_current_task: boolean);


    clp$find_current_block (block);
    block_found_in_current_task := TRUE;

    WHILE TRUE DO
      CASE block^.kind OF
      = clc$command_proc_block, clc$function_proc_block, clc$utility_block, clc$when_block =
        RETURN;
      = clc$command_block =
        CASE block^.command_kind OF
        = clc$command_is_include_file, clc$command_is_include_line =
          ;
        ELSE
          RETURN;
        CASEND;
      = clc$task_block =
        IF (block^.task_kind <> clc$other_task) OR (NOT block^.synchronous_with_parent) THEN
          RETURN;
        IFEND;
        block_found_in_current_task := FALSE;
      ELSE
        ;
      CASEND;
      block := block^.previous_block;
    WHILEND;

  PROCEND find_environment_block;
?? OLDTITLE ??
?? NEWTITLE := 'find_pushed_object', EJECT ??

{
{ PURPOSE:
{   This procedure is called when an object is being popped in order to find
{   the previous (pushed) instance of that object.
{

  PROCEDURE [INLINE] find_pushed_object
    (    object_ordinal: clt$environment_object_ordinal;
         popped_object_block: ^clt$block;
         popped_object_in_current_task: boolean;
     VAR pushed_object: ^clt$environment_object_contents;
     VAR pushed_object_in_current_task: boolean);

    VAR
      block: ^clt$block;


    pushed_object := NIL;
    pushed_object_in_current_task := popped_object_in_current_task;
    block := popped_object_block;

    WHILE TRUE DO
      IF block^.kind = clc$task_block THEN
        pushed_object_in_current_task := FALSE;
        IF NOT block^.synchronous_with_parent THEN
          RETURN;
        IFEND;
      IFEND;
      block := block^.previous_block;
      IF (block^.environment_object_info <> NIL) AND block^.environment_object_info^.
            defined [object_ordinal] THEN
        pushed_object := ^block^.environment_object_info^.contents
              [clv$environment_object_slices [object_ordinal].index];
        RETURN;
      IFEND;
    WHILEND;

  PROCEND find_pushed_object;
?? OLDTITLE ??
?? NEWTITLE := 'search_environment_object_names', EJECT ??

{
{ PURPOSE:
{   This procedure is called to find the ordinal of an environment object given
{   its name.  It performs a binary search on the CLV$ENVIRONMENT_OBJECT_NAMES
{   table, therefore that table must be maintained in alphabetical order.
{

  PROCEDURE [INLINE] search_environment_object_names
    (    object_name: ost$name;
     VAR object_ordinal: clt$environment_object_ordinal;
     VAR object_implemented: boolean;
     VAR object_name_found: boolean);

    VAR
      lower: 1 .. clc$eo_defined_names + 1,
      upper: 0 .. clc$eo_defined_names,
      temp: integer,
      index: 1 .. clc$eo_defined_names;


    lower := 1;
    upper := clc$eo_defined_names;

    WHILE (lower <= upper) DO
      temp := lower + upper;
      index := temp DIV 2;
      IF object_name = clv$environment_object_names [index].name THEN

        object_name_found := TRUE;
        object_implemented := clv$environment_object_names [index].implemented;
        IF object_implemented THEN
          object_ordinal := clv$environment_object_names [index].ordinal;
        IFEND;
        RETURN;

      ELSEIF object_name > clv$environment_object_names [index].name THEN
        lower := index + 1;
      ELSE
        upper := index - 1;
      IFEND;
    WHILEND;

    object_name_found := FALSE;

  PROCEND search_environment_object_names;
?? OLDTITLE ??
*IFEND

MODEND clm$environment_object_manager;
*DECK DECK=CLM$EVALUATE_EXPRESSION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Expression Evaluator' ??
MODULE clm$evaluate_expression;

{
{ PURPOSE:
{   This module contains the procedures that evaluate expressions.  The
{   evaluation is guided by a "type description" (derived from a "type
{   specification").  The output is a "data value".
{
{ DESIGN:
{   The expression is parsed using the technique known as "recursive descent".
{   This means that "knowledge" of the syntax of expressions is embodied in the
{   code rather than in syntax tables and that, in general, for each syntactic
{   construct there is a corresponding procedure to process it.
{
{ NOTE:
{   In addition to the routines within this module, there are a number of
{   inline procedures (in their own decks) that evaluate specific types of
{   expressions.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$max_integer
*copyc clc$min_integer
*copyc clc$reset_dereference_name
*copyc cle$bad_data_value
*copyc cle$bad_keyword_type_spec
*copyc cle$bad_type_description
*copyc cle$ecc_command_processing
*copyc cle$ecc_file_reference
*copyc cle$ecc_lexical
*copyc cle$ecc_parsing
*copyc cle$no_match_for_wild_card_name
*copyc cle$not_supported
*copyc cle$string_too_short
*copyc cle$unknown_variable
*copyc cle$wild_card_not_allowed
*copyc cle$work_area_overflow
*copyc clk$scan_expression
*copyc clt$data_value
*copyc clt$data_kinds
*copyc clt$expression_text
*copyc clt$expression_text_index
*copyc clt$keyword_index
*copyc clt$lexical_unit_kinds
*copyc clt$longreal
*copyc clt$parse_state
*copyc clt$type_description
*copyc clt$type_specification
*copyc clt$work_area
*copyc oss$job_paged_literal
*copyc ost$status
*copyc pme$system_time_exceptions
?? SKIP := 3 ??

{
{ PURPOSE:
{   The following procedure exists solely to provide a "shelter" for the
{   declarations contained in certain decks that are *COPYC'd into this
{   deck.  For example, this module defines an XDCL'd procedure that is
{   referenced by an INLINE procedure.  In order to make the deck containing
{   the INLINE procedure "self-contained" it *COPYCs the deck containing the
{   XREF declaration of the procedure.  Since the INLINE procedure is needed
{   in this module, both the XDCL and XREF declaration will appear in this
{   module.  The following "dummy" procedure is used to hide the XREF
{   declaration of the variable from the rest of the module.
{

  PROCEDURE [INLINE] dummy;

*copyc clp$internal_evaluate_expr

  PROCEND dummy;
?? SKIP := 3 ??
?? POP ??
*copyc bap$process_pt_request
*copyc clp$append_status_parse_state
*copyc clp$append_status_string
*copyc clp$append_status_type_desc
*copyc clp$append_status_value_type
*copyc clp$array_value_compare
*copyc clp$boolean_compare
*copyc clp$build_pattern_for_wild_card
*copyc clp$command_reference_compare
*copyc clp$complete_file_ref_eval
*copyc clp$complete_file_ref_parse
*IF NOT $true(osv$unix)
*copyc clp$construct_path_handle_name
*IFEND
*copyc clp$convert_date_time_to_string
*IF NOT $true(osv$unix)
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_integer_to_real
*copyc clp$convert_real_to_integer
*IFEND
*copyc clp$convert_string_to_date_time
*IF NOT $true(osv$unix)
*copyc clp$convert_string_to_file
*IFEND
*copyc clp$convert_string_to_integer
*copyc clp$convert_type_spec_to_desc
*IF $true(osv$unix)
*copyc clp$conv_unix_file_ref_to_str
*IFEND
*copyc clp$copy_data_value
*copyc clp$count_list_elements
*copyc clp$date_time_compare
*copyc clp$derive_type_desc_from_value
*copyc clp$entry_point_ref_compare
*copyc clp$evaluate_boolean_expression
*copyc clp$evaluate_integer_expression
*copyc clp$evaluate_list_expression
*copyc clp$evaluate_name
*copyc clp$evaluate_name_for_read
*copyc clp$evaluate_numeric_literal
*copyc clp$evaluate_type_conformance
*copyc clp$evaluate_unqual_union_expr
*copyc clp$evaluate_unsigned_decimal
*copyc clp$evaluate_value_conformance
*IF NOT $true(osv$unix)
*copyc clp$file_ref_is_pre_evaluated
*IFEND
*copyc clp$find_command_list
*copyc clp$find_command_source
*IF NOT $true(osv$unix)
*copyc clp$find_scl_options
*IFEND
*copyc clp$first_list_element
*IF NOT $true(osv$unix)
*copyc clp$get_path_name
*IFEND
*copyc clp$get_work_area
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*copyc clp$integer_compare
*copyc clp$internal_convert_to_string
*copyc clp$internal_evaluate_params
*copyc clp$internal_gen_type_spec
*copyc clp$isolate_application_value
*copyc clp$list_value_compare
*IF NOT $true(osv$unix)
*copyc clp$longreal_compare
*copyc clp$longreal_compare_eq
*copyc clp$longreal_compare_gt
*copyc clp$longreal_compare_le
*copyc clp$longreal_compare_lt
*copyc clp$longreal_compare_ne
*IFEND
*copyc clp$make_application_value
*copyc clp$make_array_value
*copyc clp$make_boolean_value
*copyc clp$make_clt$boolean_value
*copyc clp$make_clt$number_value
*copyc clp$make_cobol_name_value
*copyc clp$make_command_ref_value
*copyc clp$make_data_name_value
*copyc clp$make_date_time_value
*copyc clp$make_entry_point_ref_value
*IF $true(osv$unix)
*copyc clp$make_file_value
*IFEND
*copyc clp$make_file_value
*copyc clp$make_integer_value
*copyc clp$make_keyword_value
*copyc clp$make_list_value
*copyc clp$make_name_value
*IF $true(osv$unix)
*copyc clp$make_nos_ve_file_value
*IFEND
*copyc clp$make_program_name_value
*copyc clp$make_range_value
*copyc clp$make_record_value
*copyc clp$make_scu_line_id_value
*copyc clp$make_sized_string_value
*copyc clp$make_time_increment_value
*copyc clp$make_time_zone_value
*copyc clp$make_type_spec_value
*copyc clp$make_unspecified_value
*copyc clp$match_string_pattern
*copyc clp$next_list_element
*copyc clp$number_compare
*IF NOT $true(osv$unix)
*copyc clp$parse_file_reference
*IFEND
*copyc clp$perform_numeric_operation
*copyc clp$range_value_compare
*copyc clp$recognize_cobol_name
*copyc clp$record_value_compare
*copyc clp$remove_last_path_element
*copyc clp$rescan_wild_card_lex_unit
*copyc clp$scan_any_lexical_unit
*copyc clp$scan_bal_paren_lexical_unit
*copyc clp$scan_non_space_lexical_unit
*copyc clp$scan_operand
*copyc clp$scan_unnested_sep_lex_unit
*copyc clp$sp_pattern_concat_pattern
*copyc clp$sp_pattern_concat_string
*copyc clp$sp_string_concat_pattern
*copyc clp$sp_string_literal
*copyc clp$status_compare
*copyc clp$string_compare
*copyc clp$time_increment_compare
*copyc clp$trimmed_string_size
*copyc clp$validate_date_time
*copyc clp$validate_type_conformance
*copyc clp$validate_value_conformance
*copyc clv$max_integer_as_real
*copyc clv$min_integer_as_real
*copyc clv$negative_infinity
*copyc clv$positive_infinity
*copyc clv$real_one
*copyc clv$real_zero
*copyc clv$type_kind_names
*copyc clv$user_identification
*copyc clv$value_type_kinds
*IF NOT $true(osv$unix)
*copyc mlp$convert_float_to_intege
*copyc mlp$convert_integer_to_float
*IFEND
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$append_status_real
*IF NOT $true(osv$unix)
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$establish_condition_handler
*IFEND
*copyc osp$get_status_condition_code
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$status_condition_code
*copyc osv$lower_to_upper
*copyc osv$lower_to_upper_26
*IF NOT $true(osv$unix)
*copyc osv$initial_exception_context
*IFEND
*copyc pmp$compute_date_time
*copyc pmp$compute_date_time_increment
*IF NOT $true(osv$unix)
*copyc pmp$continue_to_cause
*IFEND
*copyc pmp$get_compact_date_time

?? TITLE := 'clp$check_name_for_boolean', EJECT ??

{ The following variable is declared outside of clp$check_name_for_boolean so
{ that procedure may be INLINE.

  CONST
    number_of_boolean_value_names = 6,
    max_boolean_name_size = 5;

  VAR
    booleans: [STATIC, READ, oss$job_paged_literal] array [1 .. number_of_boolean_value_names] of record
      name: string (max_boolean_name_size),
      value: clt$boolean,
    recend := [
          {} ['FALSE', [FALSE, clc$true_false_boolean]],
          {} ['NO   ', [FALSE, clc$yes_no_boolean]],
          {} ['OFF  ', [FALSE, clc$on_off_boolean]],
          {} ['ON   ', [TRUE, clc$on_off_boolean]],
          {} ['TRUE ', [TRUE, clc$true_false_boolean]],
          {} ['YES  ', [TRUE, clc$yes_no_boolean]]];

?? SKIP := 3 ??

  PROCEDURE [XDCL, INLINE] clp$check_name_for_boolean
    (    name: ost$name;
     VAR bool: clt$boolean;
     VAR name_is_boolean: boolean);

    VAR
      current_index: 1 .. number_of_boolean_value_names,
      low_index: 1 .. number_of_boolean_value_names + 1,
      temp: integer,
      high_index: 0 .. number_of_boolean_value_names;


    name_is_boolean := FALSE;

    low_index := 1;
    high_index := number_of_boolean_value_names;
    REPEAT
      temp := low_index + high_index;
      current_index := temp DIV 2;
      IF name = booleans [current_index].name THEN

        name_is_boolean := TRUE;
        bool := booleans [current_index].value;
        RETURN;

      ELSEIF name > booleans [current_index].name THEN
        low_index := current_index + 1;
      ELSE
        high_index := current_index - 1;
      IFEND;
    UNTIL low_index > high_index;

  PROCEND clp$check_name_for_boolean;
?? TITLE := 'clp$convert_array_to_list', EJECT ??

  PROCEDURE [XDCL] clp$convert_array_to_list
    (    array_value: ^clt$data_value;
         array_type_description: ^clt$type_description;
         list_type_description: ^clt$type_description;
     VAR work_area {input, output} : ^clt$work_area;
     VAR list_value {input, output} : ^clt$data_value;
     VAR status: ost$status);

    VAR
      check_elements: boolean,
      current_list_node: ^clt$data_value,
      i: clt$array_bound,
      list_size: clt$list_size,
      original_work_area: ^clt$work_area,
      type_conformance: clt$type_conformance;


    status.normal := TRUE;

    check_elements := (list_type_description <> NIL) AND (list_type_description^.
          list_element_type_description <> NIL);
    IF check_elements AND (array_type_description <> NIL) AND
          (array_type_description^.array_element_type_description <> NIL) THEN
      clp$evaluate_type_conformance (array_type_description^.array_element_type_description,
            list_type_description^.list_element_type_description, clc$conforms_to_type, status);
      IF NOT status.normal THEN
        IF status.condition = cle$wrong_kind_of_value THEN
          status.condition := cle$wrong_kind_of_element_type;
        IFEND;
        RETURN;
      IFEND;
      check_elements := FALSE;
    IFEND;

    original_work_area := work_area;

    IF list_value = NIL THEN
      clp$make_list_value (work_area, list_value);
      IF list_value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, 'clp$convert_array_to_list', status);
        RETURN;
      IFEND;
    IFEND;

    list_size := 0;
    current_list_node := list_value;
    FOR i := LOWERBOUND (array_value^.array_value^) TO UPPERBOUND (array_value^.array_value^) DO
      IF array_value^.array_value^ [i] <> NIL THEN
        IF check_elements THEN
          clp$validate_value_conformance (array_value^.array_value^ [i],
                list_type_description^.list_element_type_description, type_conformance);
          IF type_conformance < clc$conforms_to_type THEN
            osp$set_status_condition (cle$wrong_kind_of_element_value, status);
            clp$append_status_type_desc (osc$status_parameter_delimiter,
                  list_type_description^.list_element_type_description, status);
            clp$append_status_value_type (osc$status_parameter_delimiter, array_value^.array_value^ [i],
                  status);
            osp$append_status_integer (osc$status_parameter_delimiter, i, 10, FALSE, status);
            work_area := original_work_area;
            RETURN;
          IFEND;
        IFEND;

        current_list_node^.element_value := array_value^.array_value^ [i];
        list_size := list_size + 1;

        IF i < UPPERBOUND (array_value^.array_value^) THEN
          clp$make_list_value (work_area, current_list_node^.link);
          IF current_list_node^.link = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, 'clp$convert_array_to_list', status);
            work_area := original_work_area;
            RETURN;
          IFEND;
          current_list_node := current_list_node^.link;
        IFEND;
      ELSE
        osp$set_status_condition (cle$unknown_array_to_list_value, status);
        RETURN;
      IFEND;
    FOREND;

    IF (list_type_description <> NIL) AND ((list_size < list_type_description^.min_list_size) OR
          (list_size > list_type_description^.max_list_size)) THEN
      osp$set_status_condition (cle$too_few_or_many_list_elems, status);
      osp$append_status_integer (osc$status_parameter_delimiter, list_size, 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, list_type_description^.min_list_size, 10,
            FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, list_type_description^.max_list_size, 10,
            FALSE, status);
      work_area := original_work_area;
    IFEND;

  PROCEND clp$convert_array_to_list;
?? TITLE := 'clp$convert_list_to_array', EJECT ??

  PROCEDURE [XDCL] clp$convert_list_to_array
    (    list_value: ^clt$data_value;
         list_type_description: ^clt$type_description;
         array_type_description: ^clt$type_description;
     VAR work_area {input, output} : ^clt$work_area;
     VAR array_value {input, output} : ^clt$data_value;
     VAR status: ost$status);

    VAR
      check_elements: boolean,
      current_list_node: ^clt$data_value,
      i: clt$array_bound,
      list_size: clt$list_size,
      original_work_area: ^clt$work_area,
      type_conformance: clt$type_conformance;


    status.normal := TRUE;

    check_elements := (array_type_description <> NIL) AND
          (array_type_description^.array_element_type_description <> NIL);
    IF check_elements AND (list_type_description <> NIL) AND
          (list_type_description^.list_element_type_description <> NIL) THEN
      clp$evaluate_type_conformance (list_type_description^.list_element_type_description,
            array_type_description^.array_element_type_description, clc$conforms_to_type, status);
      IF NOT status.normal THEN
        IF status.condition = cle$wrong_kind_of_value THEN
          status.condition := cle$wrong_kind_of_element_type;
        IFEND;
        RETURN;
      IFEND;
      check_elements := FALSE;
    IFEND;

    original_work_area := work_area;

    IF check_elements OR (array_value = NIL) THEN
      list_size := 0;
      current_list_node := clp$first_list_element (list_value);
      WHILE current_list_node <> NIL DO
        list_size := list_size + 1;
        IF check_elements THEN
          clp$validate_value_conformance (current_list_node^.element_value,
                array_type_description^.array_element_type_description, type_conformance);
          IF type_conformance < clc$conforms_to_type THEN
            osp$set_status_condition (cle$wrong_kind_of_element_value, status);
            clp$append_status_type_desc (osc$status_parameter_delimiter,
                  array_type_description^.array_element_type_description, status);
            clp$append_status_value_type (osc$status_parameter_delimiter, list_value^.element_value, status);
            osp$append_status_integer (osc$status_parameter_delimiter, list_size, 10, FALSE, status);
            RETURN;
          IFEND;
        IFEND;
        current_list_node := clp$next_list_element (current_list_node);
      WHILEND;

      IF array_value = NIL THEN
        clp$make_array_value (1, list_size, work_area, array_value);
        IF array_value = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, 'clp$convert_list_to_array', status);
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    current_list_node := clp$first_list_element (list_value);
    FOR i := LOWERBOUND (array_value^.array_value^) TO UPPERBOUND (array_value^.array_value^) DO
      array_value^.array_value^ [i] := current_list_node^.element_value;
      current_list_node := clp$next_list_element (current_list_node);
    FOREND;

  PROCEND clp$convert_list_to_array;
?? TITLE := 'clp$evaluate_command_reference', EJECT ??

  PROCEDURE [XDCL] clp$evaluate_command_reference
    (VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
         get_path_handle_name: boolean;
     VAR path_handle_name: fst$path_handle_name;
     VAR command_reference: clt$command_reference;
     VAR utility_command_list_entry: ^clt$command_list_entry;
     VAR parameter_name: clt$parameter_name;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      command_name: clt$name,
      command_source: ost$name,
      command_source_is_utility: boolean,
*IF NOT $true(osv$unix)
      context: ^ost$ecp_exception_context,
*IFEND
      evaluated_file_reference: fst$evaluated_file_reference,
*IF NOT $true(osv$unix)
      ignore_pt_results: bat$process_pt_results,
*IFEND
      initial_path: ^fst$file_reference,
      local_parse: clt$parse_state,
      path_name: fst$path,
      path_name_size: fst$path_size,
*IF NOT $true(osv$unix)
      saved_evaluated_file_reference: fst$evaluated_file_reference,
      work_list: bat$process_pt_work_list;
*ELSE
      saved_evaluated_file_reference: fst$evaluated_file_reference;
*IFEND

?? NEWTITLE := 'find_utility', EJECT ??

    PROCEDURE find_utility
      (    candidate_name: ost$name;
       VAR command_source_is_utility: boolean;
       VAR utility_command_list_entry: ^clt$command_list_entry);

      VAR
        command_list: ^clt$command_list,
        ignore_cmnd_list_found_in_task: boolean;


      clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);
      utility_command_list_entry := command_list^.entries.first_entry;

      WHILE utility_command_list_entry <> NIL DO
        IF (utility_command_list_entry^.kind = clc$sub_commands) AND
              (candidate_name = utility_command_list_entry^.utility_name) THEN

          command_source_is_utility := TRUE;
          RETURN;

        IFEND;
        utility_command_list_entry := utility_command_list_entry^.next_entry;
      WHILEND;

      command_source_is_utility := FALSE;

    PROCEND find_utility;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    parameter_name := osc$null_name;
    command_reference.form := clc$name_only_command_ref;
    utility_command_list_entry := NIL;
    path_handle_name := osc$null_name;

    IF parse.unit.kind = clc$lex_name THEN
      local_parse := parse;
      clp$scan_any_lexical_unit (local_parse);
      IF local_parse.unit.kind = clc$lex_dot THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), command_source);
        clp$scan_any_lexical_unit (local_parse);
        IF local_parse.unit.kind = clc$lex_name THEN
          clp$scan_any_lexical_unit (local_parse);
          IF (local_parse.unit.kind <> clc$lex_dot) AND (local_parse.unit.kind <> clc$lex_concatenate) THEN
            IF (command_source = '$SOURCE') OR (command_source = '$SOURCE_OF_CALLER') THEN
              clp$find_command_source (command_source, block);
              IF block <> NIL THEN
                CASE block^.source.kind OF
                = clc$system_commands =
                  command_source := '$SYSTEM';
                = clc$sub_commands =

{ UTILITY_COMMAND_LIST_ENTRY will be set later in NAME_IS_UTILITY.

                  command_source := block^.source.utility_name;
                ELSE
                  ;
                CASEND;
              ELSE
                osp$set_status_condition (cle$unable_to_find_cmnd_source, status);
                RETURN;
              IFEND;
            IFEND;
            IF command_source = '$SYSTEM' THEN
              command_reference.form := clc$system_command_ref;
              #TRANSLATE (osv$lower_to_upper, local_parse.text^
                    (local_parse.previous_non_space_unit_index, local_parse.previous_non_space_unit.size),
                    command_reference.name);
              parse := local_parse;
              RETURN;
            ELSE
              find_utility (command_source, command_source_is_utility, utility_command_list_entry);

              IF command_source_is_utility THEN
                command_reference.form := clc$utility_command_ref;
                #TRANSLATE (osv$lower_to_upper, local_parse.text^
                      (local_parse.previous_non_space_unit_index, local_parse.previous_non_space_unit.size),
                      command_reference.name);
                command_reference.utility := command_source;
                parse := local_parse;
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    initial_path := NIL;

{ The call to clp$file_ref_is_pre_evaluated (and subsequent call to clp$parse_file_reference) is not
{ necessary since the file ref parsing options are not valid for those requests.

*IF NOT $true(osv$unix)
    clp$complete_file_ref_parse (initial_path, parse, work_area,
          $clt$file_ref_parsing_options [clc$evaluating_command_ref, clc$command_file_ref_allowed],
          clv$user_identification, evaluated_file_reference, command_name, command_reference.form,
          parameter_name, status);
*ELSE
      clp$complete_file_ref_parse (initial_path, parse, work_area, $clt$file_ref_parsing_options
            [clc$unix_path_syntax, clc$evaluating_command_ref, clc$command_file_ref_allowed],
            clv$user_identification, evaluated_file_reference, command_name, command_reference.form,
            parameter_name, status);
*IFEND
    IF NOT status.normal OR (parameter_name <> osc$null_name) THEN
      RETURN;
    IFEND;

    command_reference.name := command_name.value (1, command_name.size);

    IF command_reference.form = clc$module_or_file_command_ref THEN

{ Clp$complete_file_ref_parse will append each path element if no cycle path element was found, so
{ the last path element must be removed.

*IF NOT $true(osv$unix)
      IF evaluated_file_reference.cycle_reference.specification = fsc$cycle_omitted THEN
*IFEND
        clp$remove_last_path_element (evaluated_file_reference, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
*IF NOT $true(osv$unix)
      IFEND;
*IFEND
      saved_evaluated_file_reference := evaluated_file_reference;
*IF NOT $true(osv$unix)
      clp$convert_file_ref_to_string (evaluated_file_reference, FALSE, path_name, path_name_size, status);
*ELSE
        clp$conv_unix_file_ref_to_str (evaluated_file_reference, path_name, path_name_size, status);
*IFEND
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      command_reference.library_or_catalog := path_name (1, path_name_size);
    ELSE {command_reference.form = clc$file_cycle_command_ref}
      saved_evaluated_file_reference := evaluated_file_reference;
      clp$remove_last_path_element (evaluated_file_reference, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
*IF NOT $true(osv$unix)
      command_reference.cycle_number := evaluated_file_reference.cycle_reference.cycle_number;
      evaluated_file_reference.cycle_reference.specification := fsc$cycle_omitted;
      clp$convert_file_ref_to_string (evaluated_file_reference, FALSE, path_name, path_name_size, status);
*ELSE
        clp$conv_unix_file_ref_to_str (evaluated_file_reference, path_name, path_name_size, status);
*IFEND
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      command_reference.catalog := path_name (1, path_name_size);
    IFEND;

*IF NOT $true(osv$unix)
    IF get_path_handle_name THEN
      work_list := $bat$process_pt_work_list [bac$externalize_path_handle, bac$record_path];
      IF (saved_evaluated_file_reference.cycle_reference.specification <> fsc$cycle_omitted) AND
            (saved_evaluated_file_reference.cycle_reference.specification <> fsc$cycle_number) THEN
        work_list := work_list + $bat$process_pt_work_list [bac$resolve_path, bac$resolve_to_catalog];
      IFEND;

      saved_evaluated_file_reference.path_handle_info.path_handle_present := FALSE;
      bap$process_pt_request (work_list, osc$null_name, saved_evaluated_file_reference, ignore_pt_results,
            status);
      IF NOT status.normal THEN
        IF osp$file_access_condition (status) THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_evaluated_file_ref;
          context^.file.evaluated_file_reference := evaluated_file_reference;
          REPEAT
            bap$process_pt_request (work_list, osc$null_name, saved_evaluated_file_reference,
                  ignore_pt_results, status);
            context^.condition_status := status;
            osp$enforce_exception_policies (context^);
            status := context^.condition_status;
          UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
        IFEND;
      IFEND;

      IF status.normal THEN
        clp$construct_path_handle_name (saved_evaluated_file_reference.path_handle_info.path_handle,
              path_handle_name);
      IFEND;
    IFEND;
*IFEND

  PROCEND clp$evaluate_command_reference;
?? TITLE := 'clp$evaluate_expression', EJECT ??
*copyc clh$evaluate_expression

  PROCEDURE [XDCL, #GATE] clp$evaluate_expression
    (    expression: clt$expression_text;
         type_specification: ^clt$type_specification;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    CONST
      clc$evaluate_expression = 'clp$evaluate_expression';

    VAR
      ignore_result_type_description: ^clt$type_description,
      lexical_units: ^clt$lexical_units,
      local_result: ^clt$data_value,
      local_status: ost$status,
      local_work_area: ^^clt$work_area,
      original_local_work_area: ^clt$work_area,
      parse: clt$parse_state,
      type_description: clt$type_description;


    #KEYPOINT (osk$entry, 1, clk$scan_expression);

    status.normal := TRUE;
    result := NIL;

    local_status.normal := TRUE;
    original_local_work_area := NIL;

  /evaluate/
    BEGIN

      IF work_area = NIL THEN
        osp$set_status_condition (cle$work_area_overflow, local_status);
        EXIT /evaluate/;
      IFEND;

*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^local_work_area), local_work_area, local_status);
*ELSE
      clp$get_work_area (osc$user_ring, local_work_area, local_status);
*IFEND
      IF NOT local_status.normal THEN
        EXIT /evaluate/;
      IFEND;
      original_local_work_area := local_work_area^;

      clp$convert_type_spec_to_desc (type_specification, local_work_area^, type_description, local_status);
      IF NOT local_status.normal THEN
        EXIT /evaluate/;
      IFEND;

      clp$identify_lexical_units (^expression, local_work_area^, lexical_units, local_status);
      IF NOT local_status.normal THEN
        EXIT /evaluate/;
      IFEND;

      clp$initialize_parse_state (^expression, lexical_units, parse);
      clp$scan_non_space_lexical_unit (parse);

      clp$internal_evaluate_expr (parse, ^type_description, local_work_area^, ignore_result_type_description,
            local_result, local_status);
      IF NOT local_status.normal THEN
        EXIT /evaluate/;
      IFEND;

      IF parse.unit_is_space THEN
        clp$scan_non_space_lexical_unit (parse);
      IFEND;
      IF parse.unit.kind <> clc$lex_end_of_line THEN
        osp$set_status_condition (cle$expecting_end_of_expression, local_status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, local_status);
        EXIT /evaluate/;
      IFEND;

      IF local_result^.kind = clc$unspecified THEN
        osp$set_status_abnormal ('CL', cle$unspecified_value_for_req, clc$evaluate_expression, local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, expression, local_status);
        EXIT /evaluate/;
      IFEND;

*IF NOT $true(osv$unix)
      IF #SEGMENT (work_area) = #SEGMENT (local_work_area^) THEN
*ELSE
      IF #LOC (work_area^) = #LOC (local_work_area^^) THEN
*IFEND
        result := local_result;
      ELSE
        clp$copy_data_value (local_result, work_area, result, local_status);
        local_work_area^ := original_local_work_area;
      IFEND;

    END /evaluate/;

    IF NOT local_status.normal THEN
      IF local_status.condition = cle$work_area_overflow THEN
        local_status.text.size := 0;
        osp$append_status_parameter (osc$status_parameter_delimiter, clc$evaluate_expression, local_status);
      IFEND;
      status := local_status;

      IF original_local_work_area <> NIL THEN
        local_work_area^ := original_local_work_area;
      IFEND;
    IFEND;

    #KEYPOINT (osk$exit, 1, clk$scan_expression);

  PROCEND clp$evaluate_expression;
*IF NOT $true(osv$unix)

{ This routine is not called by the system.

?? TITLE := 'clp$evaluate_expression_to_str', EJECT ??
*copyc clh$evaluate_expression_to_str

  PROCEDURE [XDCL, #GATE] clp$evaluate_expression_to_str
    (    expression: clt$expression_text;
     VAR result_string: clt$string_value;
     VAR type_name: clt$type_name;
     VAR status: ost$status);

    VAR
      ignore_result_type_description: ^clt$type_description,
      lexical_units: ^clt$lexical_units,
      original_work_area: ^clt$work_area,
      parse: clt$parse_state,
      representation: ^clt$data_representation,
      representation_text: ^clt$string_value,
      representation_text_size: ^clt$string_size,
      request: clt$convert_to_string_request,
      result: ^clt$data_value,
      string_count: ^clt$data_representation_count,
      work_area_ptr: ^^clt$work_area;


    status.normal := TRUE;
    result_string := '';
    type_name := '';

    original_work_area := NIL;

  /evaluate/
    BEGIN
*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^work_area_ptr), work_area_ptr, status);
*ELSE
      clp$get_work_area (osc$user_ring, work_area_ptr, status);
*IFEND
      IF NOT status.normal THEN
        EXIT /evaluate/;
      IFEND;
      original_work_area := work_area_ptr^;

      clp$identify_lexical_units (^expression, work_area_ptr^, lexical_units, status);
      IF NOT status.normal THEN
        EXIT /evaluate/;
      IFEND;
      clp$initialize_parse_state (^expression, lexical_units, parse);
      clp$scan_non_space_lexical_unit (parse);

      clp$evaluate_unqual_union_expr (work_area_ptr^, parse, ignore_result_type_description, result, status);
      IF NOT status.normal THEN
        EXIT /evaluate/;
      IFEND;

    /get_representation_text/
      BEGIN
        request.initial_indentation := 0;
        request.continuation_indentation := 0;
        request.max_string := clc$max_string_size;
        request.include_advanced_items := TRUE;
        request.include_hidden_items := TRUE;
        request.kind := clc$convert_data_value;
        CASE result^.kind OF
        = clc$application =
          representation_text := result^.application_value;
          EXIT /get_representation_text/;
        = clc$array, clc$deferred, clc$list, clc$range, clc$record, clc$string_pattern,
              clc$type_specification =
          request.representation_option := clc$data_source_representation;
        = clc$boolean, clc$cobol_name, clc$command_reference, clc$data_name, clc$date_time,
*IF NOT $true(osv$unix)
              clc$entry_point_reference, clc$file, clc$integer, clc$keyword, clc$lock, clc$name,
*ELSE
              clc$entry_point_reference, clc$nos_ve_file, clc$integer, clc$keyword, clc$lock, clc$name,
*IFEND
              clc$network_title, clc$program_name, clc$real, clc$scu_line_identifier, clc$statistic_code,
*IF NOT $true(osv$unix)
              clc$status, clc$status_code, clc$time_increment, clc$time_zone, clc$unspecified =
*ELSE
              clc$status, clc$status_code, clc$time_increment, clc$time_zone, clc$unspecified, clc$unix_file =
*IFEND
          request.representation_option := clc$data_elem_representation;
        = clc$string =
          representation_text := result^.string_value;
          EXIT /get_representation_text/;
        ELSE
          osp$set_status_condition (cle$bad_data_value, status);
          EXIT /evaluate/;
        CASEND;
        request.value := result;

        clp$internal_convert_to_string (request, work_area_ptr^, representation, status);
        IF NOT status.normal THEN
          EXIT /evaluate/;
        IFEND;

        NEXT string_count IN representation;
        IF string_count^ <> 1 THEN
          osp$set_status_condition (cle$string_too_short, status);
          EXIT /evaluate/;
        IFEND;
        NEXT representation_text_size IN representation;
        NEXT representation_text: [representation_text_size^] IN representation;
      END /get_representation_text/;

      type_name := clv$type_kind_names [clv$value_type_kinds [result^.kind]];

      result_string := representation_text^;

      IF STRLENGTH (representation_text^) > STRLENGTH (result_string) THEN
        osp$set_status_condition (cle$string_too_short, status);
      IFEND;
    END /evaluate/;

    IF original_work_area <> NIL THEN
      work_area_ptr^ := original_work_area;
    IFEND;

  PROCEND clp$evaluate_expression_to_str;
*IFEND
?? TITLE := 'clp$internal_evaluate_expr', EJECT ??
*copyc clh$internal_evaluate_expr

  PROCEDURE [XDCL] clp$internal_evaluate_expr
    (VAR parse {input, output} : clt$parse_state;
         type_description: ^clt$type_description;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result_type_description: ^clt$type_description;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    CONST
      clc$max_operator_size = 3,
      clc$not_operator_representation = 'NOT',
      clc$not_operator_size = 3,
      clc$or_operator_size = 2;

    TYPE
      clt$arithmetic_operator = clc$lex_exponentiate .. clc$lex_subtract,
      clt$logical_operator = (clc$not_operator, clc$and_operator, clc$or_operator, clc$xor_operator),
      clt$operator = record
        representation: clt$operator_representation,
        case kind: clt$operator_kind of
        = clc$not_an_operator =
          ,
        = clc$arithmetic_operator =
          arithmetic_kind: clc$lex_exponentiate .. clc$lex_subtract,
        = clc$logical_operator =
          logical_kind: clt$logical_operator,
        = clc$relational_operator =
          relational_kind: clt$relational_operator,
        = clc$string_operator =
          ,
        casend,
      recend,
      clt$operator_kind = (clc$not_an_operator, clc$arithmetic_operator, clc$logical_operator,
            clc$relational_operator, clc$string_operator),
      clt$operator_kinds = set of clt$operator_kind,
      clt$operator_representation = string (clc$max_operator_size),
      clt$relational_operator = clc$lex_greater_than .. clc$lex_not_equal,
      clt$relational_operators = set of clt$relational_operator;

    TYPE
      clt$numeric_operand_info = record
        case initialized: boolean of
        = FALSE =
          ,
        = TRUE =
          sign: -1 .. 1,
          min_real_value: longreal,
          max_real_value: longreal,
          min_integer_value: integer,
          max_integer_value: integer,
          radix: record
            default: 2 .. 16,
            case established: boolean of
            = FALSE =
              ,
            = TRUE =
              value: 2 .. 16,
              specified: boolean,
            casend,
          recend,
        casend,
      recend;

    TYPE
      clt$list_expansion = (clc$no_expansion, clc$defer_expansion, clc$normal_expansion);

    VAR
      expression_type_name: ^clt$type_name_reference,
      got_present_date_time: boolean,
      ignore_sub_list_tail: ^clt$data_value,
      numeric_info: clt$numeric_operand_info,
      operator: clt$operator,
      present_date_time: clt$date_time;

{ The following variables are for use by the dereference_name routine (within
{ evaluate_expression) in order to optimize repeated evaluations of the same
{ variable or function which can occur in evaluating an expression of type
{ union, etc.

    VAR
      last_deref_result_type_desc: ^clt$type_description,
      last_dereference_result: ^clt$data_value,
      last_dereference_index: clt$string_index,
      last_dereference_name: clt$variable_name,
      last_dereference_parse: clt$parse_state;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'dereference_name_reset_handler', EJECT ??

{
{ PURPOSE:
{   This procedure handles condition clc$reset_dereference_name which is
{   "cause"d by clp$get_expected_type.  The idea is to ensure that if a
{   function cares about the type under which it is being evaluated, that
{   it will be recalled to do the evaluation again for a different type.
{   This situation could arise as a result of a clc$union_type.
{

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


      IF (condition.selector = pmc$user_defined_condition) AND
            (condition.user_condition_name = clc$reset_dereference_name) THEN
        last_dereference_name := '';
        RETURN;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND dereference_name_reset_handler;
*IFEND
?? TITLE := 'evaluate_expression', EJECT ??

    PROCEDURE evaluate_expression
      (VAR parse {input, output} : clt$parse_state;
           type_description: ^clt$type_description;
           evaluating_sub_expression: boolean;
           list_expansion: clt$list_expansion;
       VAR numeric_info {input, output} : clt$numeric_operand_info;
       VAR result: ^clt$data_value;
       VAR result_sub_list_tail: ^clt$data_value;
       VAR status: ost$status);

      VAR
        unqual_union_type_description: [STATIC, READ, oss$job_paged_literal] clt$type_description :=
*IF NOT $true(osv$unix)
              [NIL, NIL, FALSE, FALSE, -$clt$type_kinds [], clc$union_type, NIL, ^unqual_union_information],
*ELSE
              [NIL, NIL, FALSE, FALSE, -$clt$type_kinds_v2 [], clc$union_type, NIL,
              ^unqual_union_information],
*IFEND
        unqual_union_information: [STATIC, READ, oss$job_paged_literal] clt$union_type_information :=
              [FALSE, clc$min_integer, clc$max_integer, 10,
*IF NOT $true(osv$unix)
              [{-$INFINITY} 3, [[0d000(16), 0], [0d000(16), 0]]],
              [{$INFINITY} 3, [[5000(16), 0], [5000(16), 0]]]];
*ELSE
*copy cli$longreal_negative_infinity
              ,
*copy cli$longreal_positive_infinity
              ];
*IFEND

      VAR
        access_variable_requests: clt$access_variable_requests,
        current_type_description: ^clt$type_description,
        defer_expansion: boolean,
        last_qualifier_is_field: boolean,
        operand_is_string_literal: boolean,
        operand_type_description: ^clt$type_description,
        operator_encountered: boolean,
        parse_saved_at_equal_operator: clt$parse_state,
        recognize_wild_cards: boolean;

?? NEWTITLE := 'check_for_variable_or_function', EJECT ??

      PROCEDURE check_for_variable_or_function
        (    element_type_description: ^clt$type_description;
         VAR result_conforms_to_element_type: boolean;
         VAR result_conforms_to_type: boolean;
         VAR type_description: ^clt$type_description;
         VAR result: ^clt$data_value;
         VAR result_sub_list_tail: ^clt$data_value);

        VAR
          initial_path: ^fst$file_reference,
          local_status: ost$status,
          name: ost$name,
          type_conformance: clt$type_conformance;


        type_description := NIL;

        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        clp$scan_any_lexical_unit (parse);

        dereference_name (name, result);
        IF (NOT status.normal) OR (result = NIL) THEN
          status.normal := TRUE;
          result := NIL;
          RETURN;
        IFEND;

*IF NOT $true(osv$unix)
*IF NOT $true(osv$unix)
        IF ((result^.kind = clc$file) OR (result^.kind = clc$name)) AND
              (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_dot, clc$lex_concatenate]) THEN
          evaluate_file (result, result_sub_list_tail);
*ELSE
        IF (result^.kind IN $clt$data_kinds [clc$nos_ve_file, clc$unix_file, clc$name]) AND
              (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_dot, clc$lex_divide, clc$lex_concatenate])
              THEN
          evaluate_file (clc$file = clc$unix_file, result, result_sub_list_tail);
*IFEND
          IF NOT status.normal THEN
            status.normal := TRUE;
            result := NIL;
            RETURN;
          IFEND;
*IF NOT $true(osv$unix)
        ELSEIF result^.kind = clc$file THEN
*ELSE
        ELSEIF result^.kind = clc$nos_ve_file THEN
*IFEND
          IF current_type_description^.derived_from_value_kind_spec THEN
            initial_path := result^.file_value;
*IF NOT $true(osv$unix)
            clp$complete_file_ref_eval (recognize_wild_cards, defer_expansion, TRUE,
*ELSE
            clp$complete_file_ref_eval (FALSE, recognize_wild_cards, defer_expansion, TRUE,
*IFEND
                  initial_path, parse, work_area, result, result_sub_list_tail, status);
            IF NOT status.normal THEN
              status.normal := TRUE;
              result := NIL;
              RETURN;
            IFEND;
          IFEND;
          recognize_binary_operator;
        ELSE
          recognize_binary_operator;
          IF (result^.kind = clc$unspecified) AND (operand_type_description = NIL) THEN
            result_conforms_to_type := TRUE;
            RETURN;
          IFEND;
        IFEND;

        IF operand_type_description <> NIL THEN
          type_description := operand_type_description;
          clp$validate_type_conformance (operand_type_description, current_type_description,
                type_conformance);
          result_conforms_to_type := type_conformance >= clc$conforms_to_type;
          IF result_conforms_to_type THEN
            RETURN;
          IFEND;
        IFEND;

        IF result^.kind <> clc$unspecified THEN
          clp$validate_value_conformance (result, current_type_description, type_conformance);
          result_conforms_to_type := type_conformance >= clc$conforms_to_type;
          IF result_conforms_to_type THEN
            RETURN;
          IFEND;
        IFEND;

        IF (element_type_description = NIL) OR (element_type_description^.kind = clc$union_type)
              OR (operator.kind <> clc$not_an_operator) THEN
          result_conforms_to_type := FALSE;
          RETURN;
        IFEND;

        IF operand_type_description <> NIL THEN
          clp$validate_type_conformance (operand_type_description, element_type_description,
                type_conformance);
          result_conforms_to_element_type := type_conformance >= clc$conforms_to_type;
          IF result_conforms_to_element_type THEN
            RETURN;
          IFEND;
        IFEND;

        IF result^.kind = clc$unspecified THEN
          result_conforms_to_element_type := FALSE;
        ELSE
          clp$validate_value_conformance (result, element_type_description, type_conformance);
          result_conforms_to_element_type := type_conformance >= clc$conforms_to_type;
        IFEND;
*IFEND

      PROCEND check_for_variable_or_function;
?? TITLE := 'convert_fs_file_ref_to_cl_file', EJECT ??

      PROCEDURE convert_fs_file_ref_to_cl_file
        (VAR value: ^clt$data_value);

        VAR
          current_list_node: ^clt$data_value,
          file: clt$file;


        CASE value^.kind OF

        = clc$list =
          current_list_node := clp$first_list_element (value);
          WHILE current_list_node <> NIL DO
            convert_fs_file_ref_to_cl_file (current_list_node^.element_value);
            current_list_node := clp$next_list_element (current_list_node);
          WHILEND;

        = clc$range =
          IF value^.low_value = value^.high_value THEN
            convert_fs_file_ref_to_cl_file (value^.low_value);
            value^.high_value := value^.low_value;
          ELSE
            convert_fs_file_ref_to_cl_file (value^.low_value);
            convert_fs_file_ref_to_cl_file (value^.high_value);
          IFEND;

*IF NOT $true(osv$unix)
        = clc$file =
          clp$convert_string_to_file (value^.file_value^, file, status);
          IF NOT status.normal THEN
            EXIT evaluate_expression;
          IFEND;
          clp$make_file_value (file.local_file_name, work_area, value);
*ELSE
        = clc$nos_ve_file =
          clp$make_nos_ve_file_value (value^.file_value^, work_area, value);
*IFEND
          IF value = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;

        ELSE
          ;

        CASEND;

      PROCEND convert_fs_file_ref_to_cl_file;
?? TITLE := 'convert_string_to_stat_code', EJECT ??

{
{ PURPOSE:
{   Convert a string in one of the following forms to a status or statistic
{   code:
{                   XXnnn
{                   XX_nnn
{                   XX nnn
{   where XX is the code's 2 character product identifier (e.g. CL for
{   "command language") and nnn is the code's numeric part (an unsigned
{   decimal integer in the range 0..0ffffff(16)).
{
{ NOTE:
{   1. If the space_separator_required parameter is given as TRUE, the string
{      must be in the last of the above forms.
{   2. This procedure can be used for status and statistic codes because the
{      structure and size of the two are identical.
{

      PROCEDURE convert_string_to_stat_code
        (    str: clt$string_value;
             space_separator_required: boolean;
         VAR status_code: ost$status_condition_code;
         VAR converted: boolean);

        VAR
          conversion_status: ost$status,
          identifier: ost$status_identifier,
          index: clt$string_index,
          int: clt$integer,
          size: clt$string_size;


        converted := FALSE;

        size := clp$trimmed_string_size (str);
        IF (size < 3) OR (str (1) = ' ') OR (str (2) = ' ') OR (space_separator_required AND (str (3) <> ' '))
              THEN
          RETURN;
        IFEND;
        index := 3 + $INTEGER ((str (3) = ' ') OR (str (3) = '_'));
        IF index > size THEN
          RETURN;
        IFEND;
        size := size - index + 1;

        clp$convert_string_to_integer (str (index, size), int, conversion_status);
        IF (NOT conversion_status.normal) OR (int.value < 0) OR
              (int.value > osc$max_status_condition_number) THEN
          RETURN;
        IFEND;

        #TRANSLATE (osv$lower_to_upper, str (1, 2), identifier);

        status_code := osp$status_condition_code (identifier, int.value);
        converted := TRUE;

      PROCEND convert_string_to_stat_code;
?? TITLE := 'dereference_name', EJECT ??

      PROCEDURE [INLINE] dereference_name
        (    name: ost$name;
         VAR result: ^clt$data_value);

        VAR
          found: boolean,
          index_limit: clt$string_index,
          variable_information: clt$variable_information,
          variable_name: clt$variable_name,
          variable_value: ^clt$data_value;


        status.normal := TRUE;

        IF (name = last_dereference_name) AND (parse.text = last_dereference_parse.text) AND
              (parse.unit_index = last_dereference_index) AND (last_dereference_parse.unit_index <=
              parse.index_limit) THEN
          result := last_dereference_result;
          operand_type_description := last_deref_result_type_desc;
          index_limit := parse.index_limit;
          parse := last_dereference_parse;
          parse.index_limit := index_limit;

        ELSE
          last_dereference_name := name;
          last_dereference_index := parse.unit_index;

          result := NIL;
          operand_type_description := NIL;
          clp$evaluate_name_for_read (name, current_type_description, access_variable_requests, parse,
                work_area, variable_name, variable_information, variable_value, found,
                last_qualifier_is_field, status);
          IF found THEN
            operand_type_description := variable_information.type_description;
          IFEND;
          IF NOT status.normal THEN
            last_dereference_name := '';
          ELSEIF found THEN
            result := variable_value;
            IF result = NIL THEN
              osp$set_status_abnormal ('CL', cle$variable_never_given_value, variable_name, status);
              last_dereference_name := '';
            IFEND;
          IFEND;

          last_dereference_parse := parse;
          last_deref_result_type_desc := operand_type_description;
          last_dereference_result := result;
        IFEND;

      PROCEND dereference_name;
?? TITLE := 'determine_structure_status', EJECT ??

      PROCEDURE [INLINE] determine_structure_status
        (    result: ^clt$data_value;
             structure_kind: clt$data_kind;
             type_description: ^clt$type_description;
             current_type_description: ^clt$type_description;
         VAR status: {input output} ost$status);

        VAR
          local_status: ost$status;

        IF (status.condition <> cle$unknown_keyword) AND (result <> NIL) AND
              (result^.kind = structure_kind) THEN
          IF type_description <> NIL THEN
            clp$evaluate_type_conformance (type_description, current_type_description, clc$conforms_to_type,
                  local_status);
            IF NOT local_status.normal THEN
              status := local_status;
            IFEND;
          ELSE
            clp$evaluate_value_conformance (result, current_type_description, clc$conforms_to_type, status);
          IFEND;
        IFEND;

      PROCEND determine_structure_status;
?? TITLE := 'evaluate_application_value', EJECT ??

      PROCEDURE evaluate_application_value
        (VAR result: ^clt$data_value);

        VAR
          end_index: clt$string_index,
          ignore_conforms_to_element_type: boolean,
          ignore_sub_list_tail: ^clt$data_value,
          result_conforms_to_type: boolean,
          start_index: clt$string_index,
          type_description: ^clt$type_description;


        IF parse.unit.kind = clc$lex_space THEN
          clp$scan_any_lexical_unit (parse);
        IFEND;

        start_index := parse.unit_index;
        clp$isolate_application_value (current_type_description^.balance_brackets, parse.text^, start_index,
              end_index);
        IF end_index > parse.index_limit THEN
          parse.index_limit := end_index;
        IFEND;

        result_conforms_to_type := FALSE;
        operand_type_description := NIL;
        IF parse.unit.kind = clc$lex_name THEN
          check_for_variable_or_function (NIL, ignore_conforms_to_element_type, result_conforms_to_type,
                type_description, result, ignore_sub_list_tail);
          IF (result <> NIL) AND ((result_conforms_to_type AND (operator.kind = clc$not_an_operator) AND
                (parse.unit_index >= end_index)) OR ((result^.kind = clc$unspecified) AND
                (type_description <> NIL) AND (type_description^.kind = clc$application_type))) THEN
            RETURN;
          IFEND;
          status.normal := TRUE;
        IFEND;

        clp$make_application_value (parse.text^ (start_index, end_index - start_index), work_area, result);
        IF result = NIL THEN
          osp$set_status_condition (cle$work_area_overflow, status);
          EXIT evaluate_expression;
        IFEND;

        WHILE (parse.unit_index < end_index) AND (parse.unit_index < parse.index_limit) DO
          clp$scan_any_lexical_unit (parse);
        WHILEND;

        recognize_binary_operator;

      PROCEND evaluate_application_value;
?? TITLE := 'evaluate_array', EJECT ??

      PROCEDURE evaluate_array
        (VAR result: ^clt$data_value);

        VAR
          element_type_description: ^clt$type_description,
          ignore_conforms_to_element_type: boolean,
          ignore_sub_list_tail: ^clt$data_value,
          ignore_type_description: ^clt$type_description,
          list_size: clt$list_size,
          list_value: ^clt$data_value,
          local_parse: clt$parse_state,
          lower: clt$array_bound,
          name: ost$name,
          result_conforms_to_type: boolean,
          upper: clt$array_bound;


        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

        local_parse := parse;

        result_conforms_to_type := FALSE;
        operand_type_description := NIL;
        IF parse.unit.kind = clc$lex_name THEN
          check_for_variable_or_function (NIL, ignore_conforms_to_element_type, result_conforms_to_type,
                ignore_type_description, result, ignore_sub_list_tail);
          IF result = NIL THEN
            parse := local_parse;
          ELSEIF result_conforms_to_type THEN
            RETURN;
          ELSE
            IF result^.kind = clc$array THEN
              clp$evaluate_value_conformance (result, current_type_description, clc$conforms_to_type, status);
            ELSE
              osp$set_status_condition (cle$wrong_kind_of_value, status);
              clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
              clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
            IFEND;
            EXIT evaluate_expression;
          IFEND;
        IFEND;

        IF parse.unit.kind <> clc$lex_left_parenthesis THEN
          local_parse := parse;
          IF parse.unit.kind = clc$lex_name THEN
            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
            clp$scan_any_lexical_unit (parse);
            dereference_name (name, result);
          IFEND;
          IF status.normal THEN
            parse := local_parse;
            osp$set_status_condition (cle$wrong_kind_of_value, status);
            clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          IFEND;
          EXIT evaluate_expression;
        IFEND;

        clp$make_list_value (work_area, list_value);
        IF list_value = NIL THEN
          osp$set_status_condition (cle$work_area_overflow, status);
          EXIT evaluate_expression;
        IFEND;
        list_size := 0;
        clp$scan_non_space_lexical_unit (parse);
        IF current_type_description^.array_element_type_description <> NIL THEN
          element_type_description := current_type_description^.array_element_type_description;
        ELSE
          element_type_description := ^unqual_union_type_description;
        IFEND;
        evaluate_parenthesized_list (element_type_description, NIL, NIL, clc$array, clc$no_expansion, NIL,
              list_size, list_value);
        IF NOT current_type_description^.array_bounds_defined THEN
          IF list_size < 1 THEN
            osp$set_status_condition (cle$unexpected_empty_array, status);
            RETURN;
          IFEND;
          lower := 1;
          upper := list_size;
        ELSE
          lower := current_type_description^.bounds.lower;
          upper := current_type_description^.bounds.upper;
          IF list_size <> (upper - lower + 1) THEN
            osp$set_status_condition (cle$too_few_or_many_array_elems, status);
            osp$append_status_integer (osc$status_parameter_delimiter, list_size, 10, FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter, lower, 10, FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter, upper, 10, FALSE, status);
            RETURN;
          IFEND;
        IFEND;

        clp$make_array_value (lower, upper, work_area, result);
        IF result = NIL THEN
          osp$set_status_condition (cle$work_area_overflow, status);
          EXIT evaluate_expression;
        IFEND;

        clp$convert_list_to_array (list_value, NIL, NIL, work_area, result, status);

      PROCEND evaluate_array;
?? TITLE := 'evaluate_boolean', EJECT ??

      PROCEDURE evaluate_boolean
        (    check_result_value: boolean;
         VAR result {input, output} : ^clt$data_value);

?? NEWTITLE := 'handle_and', EJECT ??

        PROCEDURE handle_and
          (VAR result {input, output} : ^clt$data_value);

          VAR
            current_operator_representation: clt$operator_representation,
            right_operand: ^clt$data_value;


          CASE result^.kind OF
          = clc$boolean =
            ;
          = clc$unspecified =
            osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, last_dereference_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, operator.representation, status);
            EXIT evaluate_expression;
          ELSE
            osp$set_status_condition (cle$and_operand_not_boolean, status);
            clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
            EXIT evaluate_expression;
          CASEND;

          WHILE (operator.kind = clc$logical_operator) AND (operator.logical_kind = clc$and_operator) DO
            current_operator_representation := operator.representation;

            IF NOT result^.boolean_value.value THEN

{ Skip right operand of AND operator since left operand is FALSE.

              REPEAT
                scan_partial_expression;
              UNTIL (operator.kind = clc$not_an_operator) OR ((operator.kind = clc$logical_operator) AND
                    (operator.logical_kind <> clc$and_operator));
              RETURN;
            IFEND;

            evaluate_boolean_operand (right_operand);

            IF operator.kind = clc$relational_operator THEN
              handle_comparison (right_operand);
            IFEND;

            CASE right_operand^.kind OF
            = clc$boolean =
              ;
            = clc$unspecified =
              osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, last_dereference_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, current_operator_representation,
                    status);
              EXIT evaluate_expression;
            ELSE
              osp$set_status_condition (cle$and_operand_not_boolean, status);
              clp$append_status_value_type (osc$status_parameter_delimiter, right_operand, status);
              EXIT evaluate_expression;
            CASEND;

            clp$make_boolean_value (right_operand^.boolean_value.value, result^.boolean_value.kind, work_area,
                  result);
            IF result = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              EXIT evaluate_expression;
            IFEND;

          WHILEND;

        PROCEND handle_and;
?? TITLE := 'handle_or_and_xor', EJECT ??

        PROCEDURE handle_or_and_xor
          (VAR result {input, output} : ^clt$data_value);

          VAR
            current_operator: clt$operator,
            right_operand: ^clt$data_value;


          CASE result^.kind OF
          = clc$boolean =
            ;
          = clc$unspecified =
            osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, last_dereference_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, operator.representation, status);
            EXIT evaluate_expression;
          ELSE
            IF operator.logical_kind = clc$or_operator THEN
              osp$set_status_condition (cle$or_operand_not_boolean, status);
            ELSE
              osp$set_status_condition (cle$xor_operand_not_boolean, status);
            IFEND;
            clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
            EXIT evaluate_expression;
          CASEND;

          WHILE (operator.kind = clc$logical_operator) AND ((operator.logical_kind = clc$or_operator) OR
                (operator.logical_kind = clc$xor_operator)) DO

            IF (operator.logical_kind = clc$or_operator) AND result^.boolean_value.value THEN

{ Skip right operand of OR operator since left operand is TRUE.

              REPEAT
                scan_partial_expression;
                IF operator.kind = clc$not_an_operator THEN
                  RETURN;
                IFEND;
              UNTIL (operator.kind = clc$logical_operator) AND (operator.logical_kind = clc$xor_operator);
            IFEND;

            current_operator := operator;

            evaluate_boolean_operand (right_operand);

            IF operator.kind = clc$relational_operator THEN
              handle_comparison (right_operand);
            IFEND;

            IF (operator.kind = clc$logical_operator) AND (operator.logical_kind = clc$and_operator) THEN
              handle_and (right_operand);
            IFEND;

            CASE right_operand^.kind OF
            = clc$boolean =
              ;
            = clc$unspecified =
              osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, last_dereference_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, current_operator.representation,
                    status);
              EXIT evaluate_expression;
            ELSE
              IF current_operator.logical_kind = clc$or_operator THEN
                osp$set_status_condition (cle$or_operand_not_boolean, status);
              ELSE
                osp$set_status_condition (cle$xor_operand_not_boolean, status);
              IFEND;
              clp$append_status_value_type (osc$status_parameter_delimiter, right_operand, status);
              EXIT evaluate_expression;
            CASEND;

            clp$make_boolean_value (result^.boolean_value.value, result^.boolean_value.kind, work_area,
                  result);
            IF result = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              EXIT evaluate_expression;
            IFEND;

            IF current_operator.logical_kind = clc$or_operator THEN
              result^.boolean_value.value := right_operand^.boolean_value.value;
            ELSE
              result^.boolean_value.value := result^.boolean_value.value XOR
                    right_operand^.boolean_value.value;
            IFEND;

          WHILEND;

        PROCEND handle_or_and_xor;
?? TITLE := 'scan_partial_expression', EJECT ??

        PROCEDURE [INLINE] scan_partial_expression;


          REPEAT
            WHILE recognize_not_operator () DO
              clp$scan_non_space_lexical_unit (parse);
            WHILEND;
            clp$scan_operand (clc$separator, parse);
            recognize_binary_operator;
          UNTIL operator.kind IN $clt$operator_kinds [clc$not_an_operator, clc$logical_operator];

        PROCEND scan_partial_expression;
?? OLDTITLE, EJECT ??

        evaluate_boolean_operand (result);

        IF operator.kind = clc$relational_operator THEN
          handle_comparison (result);
        IFEND;

        IF (operator.kind = clc$logical_operator) AND (operator.logical_kind = clc$and_operator) THEN
          handle_and (result);
        IFEND;

        IF operator.kind = clc$logical_operator THEN
          handle_or_and_xor (result);
        IFEND;

        IF check_result_value AND (NOT evaluating_sub_expression) AND
              (NOT (result^.kind IN $clt$data_kinds [clc$boolean, clc$unspecified])) THEN
          osp$set_status_condition (cle$wrong_kind_of_value, status);
          clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
          clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
        IFEND;

      PROCEND evaluate_boolean;
?? TITLE := 'evaluate_boolean_operand', EJECT ??

      PROCEDURE [INLINE] evaluate_boolean_operand
        (VAR result: ^clt$data_value);


        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

        CASE parse.unit.kind OF

        = clc$lex_add, clc$lex_subtract =
          result := NIL;
          evaluate_number (FALSE, result);

        ELSE
          evaluate_operand (result);

          CASE operator.kind OF
          = clc$arithmetic_operator =
            IF (current_type_description^.kind = clc$boolean_type) AND
                  (result^.kind = clc$date_time) THEN
              clp$validate_date_time (result^.date_time_value, ' ', status);
              IF status.normal THEN
*IF NOT $true(osv$unix)
                current_type_description^.kinds := $clt$type_kinds [clc$date_time_type];
*ELSE
                current_type_description^.kinds := $clt$type_kinds_v2 [clc$date_time_type];
*IFEND
                current_type_description^.kind := clc$date_time_type;
                current_type_description^.date_and_or_time := $clt$date_and_or_time [clc$date, clc$time];
                current_type_description^.tenses := $clt$date_time_tenses [clc$past, clc$present, clc$future];
                evaluate_date_time (result);
              ELSE
                EXIT evaluate_expression;
              IFEND;
            ELSE
              evaluate_number (FALSE, result);
            IFEND;
          = clc$string_operator =
            evaluate_string_or_pattern (FALSE, result);
          ELSE
            ;
          CASEND;
        CASEND;

      PROCEND evaluate_boolean_operand;
?? TITLE := 'evaluate_cobol_name', EJECT ??

      PROCEDURE evaluate_cobol_name
        (VAR result: ^clt$data_value);

        VAR
          cobol_name: clt$cobol_name,
          cobol_name_size: ost$name_size,
          hyphen_encountered: boolean,
          is_cobol_name: boolean,
          is_only_cobol_name: boolean,
          saved_parse: clt$parse_state;


        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

        saved_parse := parse;
        hyphen_encountered := FALSE;

        WHILE (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_name, clc$lex_unsigned_decimal,
              clc$lex_alpha_number, clc$lex_subtract]) AND (parse.unit_index < parse.index_limit) DO
          IF parse.unit.kind = clc$lex_subtract THEN
            hyphen_encountered := TRUE;
          IFEND;
          clp$scan_any_lexical_unit (parse);
        WHILEND;

        IF parse.unit_index = saved_parse.unit_index THEN
          osp$set_status_condition (cle$expecting_cobol_name_expr, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT evaluate_expression;
        IFEND;

        clp$recognize_cobol_name (parse.text^ (saved_parse.unit_index,
              parse.unit_index - saved_parse.unit_index), cobol_name_size, is_only_cobol_name, is_cobol_name);
        is_cobol_name := is_cobol_name AND (cobol_name_size = (parse.unit_index - saved_parse.unit_index));
        IF is_cobol_name AND is_only_cobol_name AND (cobol_name_size =
              (parse.unit_index - saved_parse.unit_index)) THEN
          clp$make_cobol_name_value (parse.text^ (saved_parse.unit_index, cobol_name_size), work_area,
                result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;
          recognize_binary_operator;
          RETURN;
        IFEND;

        IF (saved_parse.unit.kind <> clc$lex_name) OR hyphen_encountered THEN
          osp$set_status_abnormal ('CL', cle$not_a_cobol_name, parse.
                text^ (saved_parse.unit_index, parse.unit_index - saved_parse.unit_index), status);
          EXIT evaluate_expression;
        IFEND;

        parse := saved_parse;
        evaluate_operand (result);

        IF result^.kind = clc$name THEN
          clp$recognize_cobol_name (result^.name_value, cobol_name_size, is_only_cobol_name, is_cobol_name);
          IF is_cobol_name AND (result^.name_value (cobol_name_size + 1, * ) = '') THEN
            clp$make_cobol_name_value (result^.name_value (1, cobol_name_size), work_area, result);
            IF result = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              EXIT evaluate_expression;
            IFEND;
            RETURN;
          IFEND;
        IFEND;

        CASE result^.kind OF
        = clc$cobol_name =
          ;
        = clc$unspecified =
          ;
        ELSE
          osp$set_status_condition (cle$wrong_kind_of_value, status);
          clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
          clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
          EXIT evaluate_expression;
        CASEND;

      PROCEND evaluate_cobol_name;
?? TITLE := 'evaluate_command_reference', EJECT ??

      PROCEDURE evaluate_command_reference
        (VAR result: ^clt$data_value);

        VAR
          access_variable_requests: clt$access_variable_requests,
          command_reference: clt$command_reference,
          command_reference_name: clt$command_name,
          escaped: boolean,
          found: boolean,
          ignore_path_handle_name: fst$path_handle_name,
          ignore_util_command_list_entry: ^clt$command_list_entry,
          parameter_name: clt$parameter_name,
          saved_parse: clt$parse_state,
          value: ^clt$data_value;


      /evaluate_command_reference_blk/
        BEGIN
          escaped := parse.unit.kind = clc$lex_divide;
          parameter_name := osc$null_name;

          IF escaped THEN
            clp$scan_non_space_lexical_unit (parse);
          IFEND;
          saved_parse := parse;

        /evaluate_command_ref/
          BEGIN
            CASE parse.unit.kind OF
            = clc$lex_colon, clc$lex_dot =
              ;
            = clc$lex_long_name =
              osp$set_status_abnormal ('CL', cle$name_too_long, parse.
                    text^ (parse.unit_index, parse.unit.size), status);
              EXIT evaluate_expression;
            = clc$lex_name =
              clp$scan_any_lexical_unit (parse);
              IF (parse.unit.kind <> clc$lex_dot) AND (parse.unit.kind <> clc$lex_concatenate) AND
                    (parse.unit.kind <> clc$lex_left_parenthesis) THEN
                #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.previous_non_space_unit_index,
                      parse.previous_non_space_unit.size), command_reference_name);
                access_variable_requests := $clt$access_variable_requests [];
                clp$evaluate_name (command_reference_name, access_variable_requests, parse, work_area, value,
                      found, status);
                IF NOT status.normal THEN
                  EXIT evaluate_expression;
                IFEND;
                IF found THEN
                  IF value <> NIL THEN
                    IF (value^.kind = clc$command_reference) OR (value^.kind = clc$unspecified) THEN
                      result := value;
                      EXIT /evaluate_command_reference_blk/;
                    IFEND;
                  IFEND;
                IFEND;
                command_reference.name := command_reference_name;
                IF escaped THEN
                  command_reference.form := clc$skip_1st_entry_command_ref;
                ELSE
                  command_reference.form := clc$name_only_command_ref;
                IFEND;
                EXIT /evaluate_command_ref/;
              IFEND;
            ELSE
              osp$set_status_abnormal ('CL', cle$expecting_command_reference, parse.
                    text^ (parse.unit_index, parse.unit.size), status);
              EXIT evaluate_expression;
            CASEND;

            IF escaped THEN
              osp$set_status_abnormal ('CL', cle$file_dot_cmnd_not_allowed, parse.
                    text^ (parse.unit_index, parse.unit.size), status);
              EXIT evaluate_expression;
            IFEND;

            parse := saved_parse;
            clp$evaluate_command_reference (parse, work_area, FALSE, ignore_path_handle_name,
                  command_reference, ignore_util_command_list_entry, parameter_name, status);
            IF NOT status.normal THEN
              EXIT evaluate_expression;
            IFEND;
          END /evaluate_command_ref/;

          IF parameter_name <> osc$null_name THEN
            clp$make_unspecified_value (work_area, result);
          ELSE
            clp$make_command_ref_value (^command_reference, work_area, result);
          IFEND;
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;
        END /evaluate_command_reference_blk/;
        recognize_binary_operator;

      PROCEND evaluate_command_reference;
?? TITLE := 'evaluate_data_name', EJECT ??

      PROCEDURE evaluate_data_name
        (VAR result: ^clt$data_value;
         VAR result_sub_list_tail: ^clt$data_value);

        VAR
          saved_parse: clt$parse_state;


        IF recognize_wild_cards THEN
          handle_wild_card_name (result, result_sub_list_tail);
          IF result <> NIL THEN
            RETURN;
          IFEND;
        IFEND;

        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

        CASE parse.unit.kind OF
        = clc$lex_name =
          ;
        = clc$lex_long_name =
          osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                status);
          EXIT evaluate_expression;
        ELSE
          osp$set_status_condition (cle$wrong_kind_of_value, status);
          clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT evaluate_expression;
        CASEND;

      /data_name_literal/
        BEGIN
          saved_parse := parse;
          clp$scan_any_lexical_unit (parse);
          IF parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_left_parenthesis, clc$lex_dot] THEN
            parse := saved_parse;
            EXIT /data_name_literal/;
          IFEND;

          clp$make_data_name_value (parse.text^ (saved_parse.unit_index, saved_parse.unit.size), work_area,
                result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;

          recognize_binary_operator;
          RETURN;
        END /data_name_literal/;


        evaluate_operand (result);

        CASE result^.kind OF
        = clc$data_name =
          ;
        = clc$keyword =
          clp$make_data_name_value (result^.keyword_value, work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;
        = clc$name =
          clp$make_data_name_value (result^.name_value, work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;
        = clc$unspecified =
          ;
        ELSE
          osp$set_status_condition (cle$wrong_kind_of_value, status);
          clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
          clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
          EXIT evaluate_expression;
        CASEND;

      PROCEND evaluate_data_name;
?? TITLE := 'get_present_date_time', EJECT ??

      PROCEDURE [INLINE] get_present_date_time;


        IF NOT got_present_date_time THEN
          pmp$get_compact_date_time (present_date_time.value, status);
          IF NOT status.normal THEN
            EXIT evaluate_expression;
          IFEND;
          present_date_time.date_specified := TRUE;
          present_date_time.time_specified := TRUE;

          got_present_date_time := TRUE;
        IFEND;

      PROCEND get_present_date_time;
?? TITLE := 'evaluate_date_time', EJECT ??

      PROCEDURE evaluate_date_time
        (VAR result: ^clt$data_value);

        VAR
          date_time: clt$date_time,
          start_index: clt$string_index;

?? NEWTITLE := 'complete_date_time', EJECT ??

        PROCEDURE complete_date_time;


          IF NOT (clc$date IN current_type_description^.date_and_or_time) THEN
            IF NOT result^.date_time_value.time_specified THEN
              osp$set_status_abnormal ('CL', cle$wrong_kind_of_value, 'TIME', status);
              osp$append_status_parameter (osc$status_parameter_delimiter, 'DATE', status);
              EXIT evaluate_expression;
            IFEND;
            get_present_date_time;
            result^.date_time_value.date_specified := FALSE;
            result^.date_time_value.value.year := present_date_time.value.year;
            result^.date_time_value.value.month := present_date_time.value.month;
            result^.date_time_value.value.day := present_date_time.value.day;
          IFEND;

          IF NOT (clc$time IN current_type_description^.date_and_or_time) THEN
            IF NOT result^.date_time_value.date_specified THEN
              osp$set_status_abnormal ('CL', cle$wrong_kind_of_value, 'DATE', status);
              osp$append_status_parameter (osc$status_parameter_delimiter, 'TIME', status);
              EXIT evaluate_expression;
            IFEND;
            result^.date_time_value.time_specified := FALSE;
            result^.date_time_value.value.hour := 0;
            result^.date_time_value.value.minute := 0;
            result^.date_time_value.value.second := 0;
            result^.date_time_value.value.millisecond := 0;
          IFEND;

        PROCEND complete_date_time;
?? TITLE := 'evaluate_variable_or_function', EJECT ??

        PROCEDURE evaluate_variable_or_function;

?? NEWTITLE := 'negate_time_increment', EJECT ??

          PROCEDURE negate_time_increment;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'arithmetic_condition_handler', EJECT ??

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


              IF (condition.selector = pmc$system_conditions) AND
                    (pmc$arithmetic_overflow IN condition.system_conditions) THEN
                osp$set_status_condition (pme$compute_overflow, status);
                EXIT evaluate_expression;
              IFEND;

              pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

            PROCEND arithmetic_condition_handler;
?? OLDTITLE, EJECT ??

            osp$establish_condition_handler (^arithmetic_condition_handler, FALSE);
*IFEND

            right_operand^.time_increment_value^.year := -right_operand^.time_increment_value^.year;
            right_operand^.time_increment_value^.month := -right_operand^.time_increment_value^.month;
            right_operand^.time_increment_value^.day := -right_operand^.time_increment_value^.day;
            right_operand^.time_increment_value^.hour := -right_operand^.time_increment_value^.hour;
            right_operand^.time_increment_value^.minute := -right_operand^.time_increment_value^.minute;
            right_operand^.time_increment_value^.second := -right_operand^.time_increment_value^.second;
            right_operand^.time_increment_value^.millisecond :=
                  -right_operand^.time_increment_value^.millisecond;

          PROCEND negate_time_increment;
?? OLDTITLE, EJECT ??

          VAR
            computed_date_time: ost$date_time,
            current_operator: clt$operator,
            right_operand: ^clt$data_value;


          IF result = NIL THEN
            evaluate_operand (result);
          IFEND;

          CASE result^.kind OF
          = clc$date_time =
            ;
          = clc$unspecified =
            ;
          ELSE
            osp$set_status_condition (cle$wrong_kind_of_value, status);
            clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
            clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
            EXIT evaluate_expression;
          CASEND;

          IF (operator.kind = clc$arithmetic_operator) AND (operator.arithmetic_kind IN
                $clt$lexical_unit_kinds [clc$lex_add, clc$lex_subtract]) THEN
            IF result^.kind = clc$unspecified THEN
              osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, last_dereference_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, operator.representation, status);
              EXIT evaluate_expression;
            IFEND;

            REPEAT
              current_operator := operator;
              right_operand := NIL;

              IF parse.unit.kind = clc$lex_left_parenthesis THEN
                osp$set_status_abnormal ('CL', cle$expecting_time_incr_operand,
                      current_operator.representation, status);
                clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
                EXIT evaluate_expression;
              IFEND;

              evaluate_operand (right_operand);

              CASE right_operand^.kind OF
              = clc$time_increment =
                ;
              = clc$unspecified =
                osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, last_dereference_name, status);
                osp$append_status_parameter (osc$status_parameter_delimiter, operator.representation, status);
                EXIT evaluate_expression;
              ELSE
                osp$set_status_abnormal ('CL', cle$expecting_time_incr_operand,
                      current_operator.representation, status);
                clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
                EXIT evaluate_expression;
              CASEND;

              IF current_operator.arithmetic_kind = clc$lex_subtract THEN
                negate_time_increment;
              IFEND;

              pmp$compute_date_time (result^.date_time_value.value, right_operand^.time_increment_value^,
                    computed_date_time, status);

{ This is commented out in order to prevent clobbering of LAST_DEREFERENCE_NAME.
{             RESET work_area TO right_operand;

              IF NOT status.normal THEN
                EXIT evaluate_expression;
              IFEND;
              result^.date_time_value.value := computed_date_time;

            UNTIL (operator.kind <> clc$arithmetic_operator) OR
                  (NOT (operator.arithmetic_kind IN $clt$lexical_unit_kinds [clc$lex_add, clc$lex_subtract]));
          IFEND;

        PROCEND evaluate_variable_or_function;
?? TITLE := 'evaluate_string', EJECT ??

        PROCEDURE evaluate_string;


          evaluate_operand (result);

          clp$convert_string_to_date_time (result^.string_value^, '', date_time, status);
          IF NOT status.normal THEN
            EXIT evaluate_expression;
          IFEND;

          clp$make_date_time_value (date_time, work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;

        PROCEND evaluate_string;
?? TITLE := 'validate_date_time_tense', EJECT ??

        PROCEDURE validate_date_time_tense;

          CONST
            max_tense_size = 7 {PRESENT} ;

          VAR
            tense_strings: [STATIC, READ, oss$job_paged_literal] array [clt$date_time_tense] of
                  string (max_tense_size) := ['PAST', 'PRESENT', 'FUTURE'];

          VAR
            date_time_string: ost$string,
            date_time_string_ptr: ^string ( * ),
            delimiter: char,
            tense: clt$date_time_tense;


          get_present_date_time;

          CASE clp$date_time_compare (result^.date_time_value, present_date_time) OF
          = clc$left_is_greater =
            tense := clc$future;
          = clc$right_is_greater =
            tense := clc$past;
          ELSE
            tense := clc$present;
          CASEND;

          IF tense IN current_type_description^.tenses THEN
            RETURN;
          IFEND;

          clp$convert_date_time_to_string (result^.date_time_value, '', date_time_string, status);
          IF status.normal THEN
            date_time_string_ptr := ^date_time_string.value (1, date_time_string.size);
          ELSE
            date_time_string_ptr := ^parse.text^ (start_index, parse.index - start_index);
          IFEND;

          osp$set_status_condition (cle$wrong_date_time_tense, status);
          clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, tense_strings [tense], status);
          delimiter := osc$status_parameter_delimiter;
          FOR tense := LOWERVALUE (clt$date_time_tense) TO UPPERVALUE (clt$date_time_tense) DO
            IF tense IN current_type_description^.tenses THEN
              osp$append_status_parameter (delimiter, tense_strings [tense], status);
              delimiter := ',';
            IFEND;
          FOREND;
          osp$append_status_parameter (osc$status_parameter_delimiter, date_time_string_ptr^, status);
          EXIT evaluate_expression;

        PROCEND validate_date_time_tense;
?? OLDTITLE, EJECT ??

        start_index := parse.unit_index;

        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

        CASE parse.unit.kind OF

        = clc$lex_name, clc$lex_long_name =
          evaluate_variable_or_function;

        = clc$lex_string, clc$lex_unterminated_string =
          evaluate_string;

        = clc$lex_unsigned_decimal, clc$lex_left_parenthesis, clc$lex_subtract, clc$lex_colon, clc$lex_dot =
          get_present_date_time;
          date_time.value := present_date_time.value;
          date_time.date_specified := FALSE;
          date_time.time_specified := FALSE;
          clp$make_date_time_value (date_time, work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;
          evaluate_date_time_literal (result, ^present_date_time);

        ELSE
          osp$set_status_condition (cle$expecting_date_time_expr, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT evaluate_expression;
        CASEND;

        complete_date_time;

        IF current_type_description^.tenses <> $clt$date_time_tenses [clc$past, clc$present, clc$future] THEN
          validate_date_time_tense;
        IFEND;

      PROCEND evaluate_date_time;
?? TITLE := 'evaluate_date_time_literal', EJECT ??

{
{ PURPOSE:
{   This routine evaluates the "literal" form of a date_time or time_increment.
{   The literal parameter is assumed to point to a pre-initialized
{   clc$date_time or clc$time_increment.  For a date_time, the
{   value subfield is assumed to be set to the present date and time, and both
{   the date_specified and time_specified subfields are assumed to be set to
{   FALSE.  For a time_increment, all subfields are assumed to be set to zero
{   and the present_date_time parameter is not used.
{

      PROCEDURE evaluate_date_time_literal
        (    literal: ^clt$data_value;
             present_date_time: ^clt$date_time);

        CONST
          min_year = 1900,
          max_year = 2155,
          max_month = 12,
          max_day = 31,
          max_hour = 23,
          max_minute = 59,
          max_second = 59,
          max_millisecond = 999;

        VAR
          component: integer,
          component_available: boolean,
          start_index: clt$string_index;

?? NEWTITLE := 'evaluate_integer_expression', EJECT ??

        PROCEDURE evaluate_integer_expression;

          VAR
            value: clt$integer;


          clp$scan_non_space_lexical_unit (parse);

          clp$evaluate_integer_expression (clc$min_integer, clc$max_integer, work_area, parse, value, status);
          IF NOT status.normal THEN
            EXIT evaluate_expression;
          IFEND;

          IF parse.unit.kind <> clc$lex_right_parenthesis THEN
            osp$set_status_condition (cle$expecting_rparen_of_subexpr, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT evaluate_expression;
          IFEND;

          clp$scan_any_lexical_unit (parse);

          component := value.value;
          component_available := TRUE;

        PROCEND evaluate_integer_expression;
?? TITLE := 'evaluate_unsigned_decimal', EJECT ??

        PROCEDURE evaluate_unsigned_decimal;


          clp$evaluate_unsigned_decimal (parse.text^ (parse.unit_index, parse.unit.size), component, status);
          IF NOT status.normal THEN
            EXIT evaluate_expression;
          IFEND;

          clp$scan_any_lexical_unit (parse);

          component_available := TRUE;

        PROCEND evaluate_unsigned_decimal;
?? TITLE := 'impossible', EJECT ??

        PROCEDURE impossible;


          osp$set_status_abnormal ('CL', cle$impossible_date_or_time, parse.
                text^ (start_index, parse.unit_index - start_index), status);
          EXIT evaluate_expression;

        PROCEND impossible;
?? TITLE := 'unrecognizable', EJECT ??

        PROCEDURE unrecognizable;

          VAR
            condition: ost$status_condition_code;


          IF literal^.kind = clc$time_increment THEN
            condition := cle$unrecognizable_time_incr;
          ELSE
            condition := cle$unrecognizable_date_time;
          IFEND;
          osp$set_status_abnormal ('CL', condition, parse.text^ (start_index, parse.index - start_index),
                status);
          EXIT evaluate_expression;

        PROCEND unrecognizable;
?? OLDTITLE, EJECT ??

        start_index := parse.unit_index;

      /handle_date_and_time_parts/
        BEGIN

        /handle_date_part/
          BEGIN

{ Handle year (or possibly hour) component.

            CASE parse.unit.kind OF
            = clc$lex_left_parenthesis =
              evaluate_integer_expression;
            = clc$lex_unsigned_decimal =
              evaluate_unsigned_decimal;
            ELSE
              component_available := FALSE;
            CASEND;
            CASE parse.unit.kind OF
            = clc$lex_colon =

{ Date omitted, this is just a time literal.

              EXIT /handle_date_part/;
            = clc$lex_subtract =
              ;
            ELSE
              unrecognizable;
            CASEND;

            IF literal^.kind = clc$date_time THEN
              literal^.date_time_value.date_specified := TRUE;
            IFEND;

            IF component_available THEN
              IF literal^.kind = clc$time_increment THEN
                literal^.time_increment_value^.year := component;
              ELSEIF (min_year <= component) AND (component <= max_year) THEN
                literal^.date_time_value.value.year := component - min_year;
              ELSE
                impossible;
              IFEND;
            IFEND;
            clp$scan_any_lexical_unit (parse);

{ Handle month component.

            CASE parse.unit.kind OF
            = clc$lex_left_parenthesis =
              evaluate_integer_expression;
            = clc$lex_unsigned_decimal =
              evaluate_unsigned_decimal;
            ELSE
              component_available := FALSE;
            CASEND;
            IF parse.unit.kind <> clc$lex_subtract THEN
              unrecognizable;
            IFEND;
            IF component_available THEN
              IF literal^.kind = clc$time_increment THEN
                literal^.time_increment_value^.month := component;
              ELSEIF (1 <= component) AND (component <= max_month) THEN
                literal^.date_time_value.value.month := component;
              ELSE
                impossible;
              IFEND;
            IFEND;
            clp$scan_any_lexical_unit (parse);

{ Handle day component.

            CASE parse.unit.kind OF
            = clc$lex_left_parenthesis =
              evaluate_integer_expression;
            = clc$lex_unsigned_decimal =
              evaluate_unsigned_decimal;
            ELSE
              component_available := FALSE;
            CASEND;
            IF component_available THEN
              IF literal^.kind = clc$time_increment THEN
                literal^.time_increment_value^.day := component;
              ELSEIF (1 <= component) AND (component <= max_day) THEN
                literal^.date_time_value.value.day := component;
              ELSE
                impossible;
              IFEND;
            IFEND;

{ Handle transition to time part or end of date_time literal.

            IF parse.unit.kind <> clc$lex_dot THEN
              IF literal^.kind = clc$date_time THEN
                literal^.date_time_value.value.hour := 0;
                literal^.date_time_value.value.minute := 0;
                literal^.date_time_value.value.second := 0;
                literal^.date_time_value.value.millisecond := 0;
              IFEND;
              EXIT /handle_date_and_time_parts/;
            IFEND;

            clp$scan_any_lexical_unit (parse);
            CASE parse.unit.kind OF
            = clc$lex_left_parenthesis =
              evaluate_integer_expression;
            = clc$lex_unsigned_decimal =
              evaluate_unsigned_decimal;
            ELSE
              component_available := FALSE;
            CASEND;
            IF parse.unit.kind <> clc$lex_colon THEN
              unrecognizable;
            IFEND;

          END /handle_date_part/;


{ Handle time part.

          IF literal^.kind = clc$date_time THEN
            literal^.date_time_value.time_specified := TRUE;
          IFEND;

{ Handle hour component.

          IF component_available THEN
            IF literal^.kind = clc$time_increment THEN
              literal^.time_increment_value^.hour := component;
            ELSEIF (0 <= component) AND (component <= max_hour) THEN
              literal^.date_time_value.value.hour := component;
            ELSE
              impossible;
            IFEND;
          IFEND;
          clp$scan_any_lexical_unit (parse);

{ Handle minute component.

          CASE parse.unit.kind OF
          = clc$lex_left_parenthesis =
            evaluate_integer_expression;
          = clc$lex_unsigned_decimal =
            evaluate_unsigned_decimal;
          ELSE
            component_available := FALSE;
          CASEND;
          IF component_available THEN
            IF literal^.kind = clc$time_increment THEN
              literal^.time_increment_value^.minute := component;
            ELSEIF (0 <= component) AND (component <= max_minute) THEN
              literal^.date_time_value.value.minute := component;
            ELSE
              impossible;
            IFEND;
          IFEND;

{ Handle second component.

          IF parse.unit.kind = clc$lex_colon THEN
            clp$scan_any_lexical_unit (parse);
            CASE parse.unit.kind OF
            = clc$lex_left_parenthesis =
              evaluate_integer_expression;
            = clc$lex_unsigned_decimal =
              evaluate_unsigned_decimal;
            ELSE
              component_available := FALSE;
            CASEND;
            IF component_available THEN
              IF literal^.kind = clc$time_increment THEN
                literal^.time_increment_value^.second := component;
              ELSEIF (0 <= component) AND (component <= max_second) THEN
                literal^.date_time_value.value.second := component;
              ELSE
                impossible;
              IFEND;
            ELSEIF literal^.kind = clc$date_time THEN
              literal^.date_time_value.value.second := 0;
              present_date_time^.value.second := 0;
            IFEND;

{ Handle millisecond component.

            IF parse.unit.kind = clc$lex_dot THEN
              clp$scan_any_lexical_unit (parse);
              CASE parse.unit.kind OF
              = clc$lex_left_parenthesis =
                evaluate_integer_expression;
              = clc$lex_unsigned_decimal =
                evaluate_unsigned_decimal;
              ELSE
                component_available := FALSE;
              CASEND;
              IF component_available THEN
                IF literal^.kind = clc$time_increment THEN
                  literal^.time_increment_value^.millisecond := component;
                ELSEIF (0 <= component) AND (component <= max_millisecond) THEN
                  literal^.date_time_value.value.millisecond := component;
                ELSE
                  impossible;
                IFEND;

              ELSEIF literal^.kind = clc$date_time THEN
                literal^.date_time_value.value.millisecond := 0;
                present_date_time^.value.millisecond := 0;
              IFEND;

            ELSEIF literal^.kind = clc$date_time THEN
              literal^.date_time_value.value.millisecond := 0;
              present_date_time^.value.millisecond := 0;
            IFEND;

          ELSEIF literal^.kind = clc$date_time THEN
            literal^.date_time_value.value.second := 0;
            present_date_time^.value.second := 0;
            literal^.date_time_value.value.millisecond := 0;
            present_date_time^.value.millisecond := 0;
          IFEND;

        END /handle_date_and_time_parts/;

        IF literal^.kind = clc$date_time THEN
          clp$validate_date_time (literal^.date_time_value, parse.
                text^ (start_index, parse.unit_index - start_index), status);
          IF NOT status.normal THEN
            EXIT evaluate_expression;
          IFEND;
        IFEND;

        recognize_binary_operator;

      PROCEND evaluate_date_time_literal;
?? TITLE := 'evaluate_entry_point_reference', EJECT ??

      PROCEDURE evaluate_entry_point_reference
        (VAR result: ^clt$data_value);

{
{ The following is a decision table which demonstrates the logic of this
{ procedure.  It should be self-explanatory except perhaps for a few
{ areas:
{    1. "value^.kind valid" means that the value kind is either an
{       entry_point_reference, program_name, cobol_name, data_name, keyword,
{       name, or string.
{    2. "parse moved" means that the parse.unit_index advanced during
{       dereference_name, which indicates the presence of qualifiers -
{       parenthesis or dot.
{    3. "last qualifier field" means that a variable was found and a
{       (record) field qualifier was the last qualifier encountered.
{    4. "special eval file" means don't evaluate file variables or functions
{       while evaluating the file reference - evaluate the file relative to
{       the working catalog.
{
?? EJECT ??
{
{ possible cobol name  |y|n|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|
{                      | | | | | | | | | | | | | | | | | | | | | | | | | | |
{ start with : or .    |n|n|y|n|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|
{                      | | | | | | | | | | | | | | | | | | | | | | | | | | |
{ parse.unit.kind=name |y|y|n|n|y|y|y|y|y|y|y|y|y|y|y|y|y|y|y|y|y|y|y|y|y|y|
{                      | | | | | | | | | | | | | | | | | | | | | | | | | | |
{ value <> NIL         |-|-|-|-|y|y|y|y|y|y|y|y|y|y|y|y|y|n|n|n|y|y|y|y|y|y|
{                      | | | | | | | | | | | | | | | | | | | | | | | | | | |
{ value^.kind valid    |-|-|-|-|y|y|y|y|y|y|n|n|n|n|n|n|n|-|-|-|n|n|n|n|n|n|
{                      | | | | | | | | | | | | | | | | | | | | | | | | | | |
{ value^.kind file     |-|-|-|-|-|-|-|-|-|-|y|y|y|y|y|y|n|-|-|-|n|n|n|n|n|n|
{                      | | | | | | | | | | | | | | | | | | | | | | | | | | |
{ value^.kind unspec   |-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|y|-|-|-|n|n|n|n|n|n|
{                      | | | | | | | | | | | | | | | | | | | | | | | | | | |
{ . or // follows val  |-|-|-|-|n|y|y|y|n|n|n|n|n|y|y|y|-|n|y|n|n|n|n|y|y|y|
{                      | | | | | | | | | | | | | | | | | | | | | | | | | | |
{ any parenthesis?     |-|-|-|-|y|n|y|n|n|n|y|n|n|n|y|n|-|-|-|-|y|n|n|n|n|y|
{                      | | | | | | | | | | | | | | | | | | | | | | | | | | |
{ parse moved          |-|-|-|-|y|n|y|y|n|y|y|n|y|n|y|y|-|-|-|-|y|n|y|n|y|y|
{                      | | | | | | | | | | | | | | | | | | | | | | | | | | |
{ last qualifier field |-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|-|y|-|-|-|-|-|-|
{ ____________________________________________________________________________
{
{ recognize cobol name |x| | | | | | | | | | | | | | | | | | | | | | | | | |
{                      |---------------------------------------------------|
{ dereference name     | |x| | | | | | | | | | | | | | | | | | | | | | | | |
{                      |---------------------------------------------------|
{ treat name literally | | | | | | | | | | | |x| | | | | |x| | | |x| | | | |
{                      |---------------------------------------------------|
{ evaluate file ref    | | |x| | | | | | | | | | |x|x|x| | | | | | | | | | |
{                      |---------------------------------------------------|
{ special eval file    | | | | | |x| |x| | | | |x| | | | | |x|x| | |x|x|x| |
{                      |---------------------------------------------------|
{ error                | | | |x| | |x| | | |x| | | | | | | | | |x| | | | |x|
{                      |---------------------------------------------------|
{ entry pt var or fcn  | | | | |x| | | |x|x| | | | | | | | | | | | | | | | |
{                      |---------------------------------------------------|
{ unspecified value    | | | | | | | | | | | | | | | | |x| | | | | | | | | |
{

*IF NOT $true(osv$unix)
        TYPE
          chars = set of char;

        VAR
          cobol_name_size: ost$name_size,
          entry_point: pmt$program_name,
          entry_point_size: clt$string_size,
          evaluated_file_reference: fst$evaluated_file_reference,
          file_ref_parsing_options: clt$file_ref_parsing_options,
          found: boolean,
          ignore_form: clt$command_reference_form,
          ignore_scan_index: integer,
          index_after_name: integer,
          initial_path: ^fst$file_reference,
          is_cobol_name: boolean,
          is_only_cobol_name: boolean,
          parameter_name: clt$parameter_name,
          parenthesis: chars,
          parse_moved: boolean,
          path_name: fst$path,
          path_name_size: fst$path_size,
          saved_parse: clt$parse_state,
          scan_found_parenthesis: boolean,
          value: ^clt$data_value;

?? NEWTITLE := 'evaluate_file_reference', EJECT ??

        PROCEDURE [INLINE] evaluate_file_reference;

          VAR
            entry_point_name: clt$name;

          clp$complete_file_ref_parse (initial_path, parse, work_area, file_ref_parsing_options,
                clv$user_identification, evaluated_file_reference, entry_point_name, ignore_form,
                parameter_name, status);
          IF NOT status.normal THEN
            EXIT evaluate_expression;
          IFEND;
          IF parameter_name <> osc$null_name THEN
            clp$make_unspecified_value (work_area, result);
            IF result = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              EXIT evaluate_expression;
            IFEND;
            RETURN;
          IFEND;

{ Clp$complete_file_ref_parse will append each path element if no cycle path element was found, so
{ the last path element must be removed.

          IF evaluated_file_reference.cycle_reference.specification = fsc$cycle_omitted THEN
            clp$remove_last_path_element (evaluated_file_reference, status);
            IF NOT status.normal THEN
              EXIT evaluate_expression;
            IFEND;
          IFEND;
*IF NOT $true(osv$unix)
          clp$convert_file_ref_to_string (evaluated_file_reference, FALSE, path_name, path_name_size, status);
*ELSE
            clp$conv_unix_file_ref_to_str (evaluated_file_reference, path_name, path_name_size, status);
*IFEND
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          entry_point := entry_point_name.value;
          entry_point_size := entry_point_name.size;

        PROCEND evaluate_file_reference;
?? OLDTITLE, EJECT ??


      /evaluate_entry_point_ref_blk/
        BEGIN

          saved_parse := parse;
*IF NOT $true(osv$unix)
          file_ref_parsing_options := $clt$file_ref_parsing_options
                [clc$evaluating_entry_point_ref, clc$command_file_ref_allowed];
*ELSE
            file_ref_parsing_options := $clt$file_ref_parsing_options [clc$unix_path_syntax,
                  clc$evaluating_entry_point_ref, clc$command_file_ref_allowed];
*IFEND
          WHILE (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_name, clc$lex_unsigned_decimal,
                clc$lex_alpha_number, clc$lex_subtract]) AND (parse.unit_index < parse.index_limit) DO
            clp$scan_any_lexical_unit (parse);
          WHILEND;

          IF parse.unit_index > saved_parse.unit_index THEN
            clp$recognize_cobol_name (parse.text^ (saved_parse.unit_index,
                  parse.unit_index - saved_parse.unit_index), cobol_name_size, is_only_cobol_name,
                  is_cobol_name);
            IF is_cobol_name AND is_only_cobol_name THEN
              #TRANSLATE (osv$lower_to_upper, parse.text^ (saved_parse.unit_index, cobol_name_size),
                    entry_point);
              clp$make_entry_point_ref_value (entry_point (1, cobol_name_size), osc$null_name,
                    work_area, result);
              IF result = NIL THEN
                osp$set_status_condition (cle$work_area_overflow, status);
                EXIT evaluate_expression;
              IFEND;
              EXIT /evaluate_entry_point_ref_blk/;
            IFEND;
          IFEND;

          path_name := osc$null_name;
          path_name_size := 0;
          parse := saved_parse;
          initial_path := NIL;
          parenthesis := $chars ['('];

        /make_entry_point_value/
          BEGIN

          /evaluate_file_ref/
            BEGIN

            /special_evaluate_file_ref/
              BEGIN
                IF parse.unit.kind = clc$lex_name THEN
                  clp$scan_any_lexical_unit (parse);
                  index_after_name := parse.unit_index;
                  #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.previous_non_space_unit_index,
                        parse.previous_non_space_unit.size), entry_point);
                  entry_point_size := parse.previous_non_space_unit.size;
                  access_variable_requests := access_variable_requests +
                        $clt$access_variable_requests [clc$return_value_qualifiers];
                  dereference_name (entry_point, value);
                  parse_moved := parse.unit_index <> index_after_name;
                  IF NOT status.normal OR (value = NIL) THEN
                    status.normal := TRUE;
                    value := NIL;
                  IFEND;

                  IF (value <> NIL) THEN
                    #SCAN (parenthesis, saved_parse.text^ (saved_parse.unit_index,
                          parse.unit_index - saved_parse.unit_index), ignore_scan_index,
                          scan_found_parenthesis);
                    IF value^.kind IN $clt$data_kinds [clc$entry_point_reference, clc$program_name,
                          clc$cobol_name, clc$data_name, clc$keyword, clc$name, clc$string] THEN
                      IF parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_dot, clc$lex_concatenate] THEN
                        IF scan_found_parenthesis THEN
                          osp$set_status_condition (cle$wrong_kind_of_value, status);
                          clp$append_status_type_desc (osc$status_parameter_delimiter,
                                current_type_description, status);
                          clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
                          EXIT evaluate_expression;
                        IFEND;
                        EXIT /special_evaluate_file_ref/;
                      ELSE
                        CASE value^.kind OF
                        = clc$entry_point_reference =
                          result := value;
                          EXIT /evaluate_entry_point_ref_blk/;
                        = clc$program_name =
                          entry_point := value^.program_name_value;
                        = clc$cobol_name =
                          entry_point := value^.cobol_name_value;
                        = clc$data_name =
                          entry_point := value^.data_name_value;
                        = clc$keyword =
                          entry_point := value^.keyword_value;
                        = clc$name =
                          entry_point := value^.name_value;
                        = clc$string =
                          evaluate_string_or_pattern (FALSE, value);
                          entry_point_size := clp$trimmed_string_size (value^.string_value^);
                          IF entry_point_size = 0 THEN
                            osp$set_status_condition (cle$null_program_name, status);
                            EXIT evaluate_expression;
                          ELSEIF entry_point_size > STRLENGTH (pmt$program_name) THEN
                            osp$set_status_abnormal ('CL', cle$program_name_too_long, value^.string_value^,
                                  status);
                            EXIT evaluate_expression;
                          IFEND;
                          entry_point := value^.string_value^;
                          EXIT /make_entry_point_value/;
                        CASEND;
                        entry_point_size := clp$trimmed_string_size (entry_point);
                        EXIT /make_entry_point_value/;
                      IFEND;
                    ELSEIF value^.kind = clc$file THEN
*IF NOT $true(osv$unix)
                      IF parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_dot, clc$lex_concatenate] THEN
*ELSE
                      IF parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_dot, clc$lex_divide,
                            clc$lex_concatenate] THEN
*IFEND
                        initial_path := value^.file_value;
                        EXIT /evaluate_file_ref/;
                      ELSEIF scan_found_parenthesis THEN
                        osp$set_status_condition (cle$wrong_kind_of_value, status);
                        clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description,
                              status);
                        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
                        EXIT evaluate_expression;
                      ELSEIF parse_moved THEN
                        EXIT /special_evaluate_file_ref/;
                      ELSE
                        EXIT /make_entry_point_value/;
                      IFEND;
                    ELSEIF value^.kind = clc$unspecified THEN
                      result := value;
                      EXIT /evaluate_entry_point_ref_blk/;
                    ELSE
                      IF scan_found_parenthesis THEN
                        osp$set_status_condition (cle$wrong_kind_of_value, status);
                        clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description,
                              status);
                        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
                        EXIT evaluate_expression;
                      ELSEIF (parse.unit.kind IN $clt$lexical_unit_kinds
                            [clc$lex_dot, clc$lex_concatenate]) OR parse_moved THEN
                        EXIT /special_evaluate_file_ref/;
                      ELSE
                        EXIT /make_entry_point_value/;
                      IFEND;
                    IFEND;
*IF NOT $true(osv$unix)
                  ELSEIF (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_dot,
*ELSE
                  ELSEIF (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_dot, clc$lex_divide,
*IFEND
                        clc$lex_concatenate]) OR last_qualifier_is_field THEN
                    EXIT /special_evaluate_file_ref/;
                  ELSE
                    EXIT /make_entry_point_value/;
                  IFEND;
*IF NOT $true(osv$unix)
                ELSEIF parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_colon, clc$lex_dot] THEN
*ELSE
                ELSEIF parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_colon, clc$lex_dot, clc$lex_divide]
                      THEN
*IFEND
                  EXIT /evaluate_file_ref/;
                ELSE
                  osp$set_status_abnormal ('CL', cle$expecting_entry_point_ref, parse.
                        text^ (parse.unit_index, parse.unit.size), status);
                  EXIT evaluate_expression;
                IFEND;
              END /special_evaluate_file_ref/;
              parse := saved_parse;

{ If initial_path = NIL and clc$evaluating_entry_point_ref is in parsing options,
{ clp$complete_file_ref_parse will not try to evaluate the first path element as a
{ variable or function.

              initial_path := NIL;
            END /evaluate_file_ref/;
            evaluate_file_reference;
            IF NOT status.normal THEN
              RETURN;
            IFEND;

          END /make_entry_point_value/;
          clp$make_entry_point_ref_value (entry_point (1, entry_point_size),
                path_name (1, path_name_size), work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;
        END /evaluate_entry_point_ref_blk/;
        recognize_binary_operator;
*ELSE
        osp$set_status_abnormal ('CL', cle$not_supported, 'entry points', status);
        EXIT evaluate_expression;
*IFEND

      PROCEND evaluate_entry_point_reference;

?? TITLE := 'evaluate_file', EJECT ??

      PROCEDURE evaluate_file
*IF NOT $true(osv$unix)
        (VAR result {input, output} : ^clt$data_value;
*ELSE
        (    unix_path: boolean;
         VAR result {input, output} : ^clt$data_value;
*IFEND
         VAR result_sub_list_tail: ^clt$data_value);

        VAR
          began_with_left_parenthesis: boolean,
*IF NOT $true(osv$unix)
          func_name: clt$variable_name,
*IFEND
          initial_path: ^fst$file_reference;


      /evaluate_file_blk/
        BEGIN
*IF NOT $true(osv$unix)
          began_with_left_parenthesis := FALSE;
          IF (result <> NIL) AND (result^.kind = clc$file) THEN
            initial_path := result^.file_value;
          ELSE
            initial_path := NIL;
            IF (parse.text^ (parse.unit_index) = '$') AND
                  (last_dereference_result <> NIL) AND (last_dereference_result^.kind = clc$file) AND
                  ((parse.unit_index + parse.unit.size = parse.index_limit) OR
                  (parse.text^ (parse.unit_index + parse.unit.size) <> '.')) THEN
              #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), func_name);
              IF (func_name = last_dereference_name) AND
                    (parse.text = last_dereference_parse.text) AND ((parse.unit_index =
                    last_dereference_index) OR (last_dereference_index = parse.index_limit)) AND
                    (last_dereference_parse.unit_index <= parse.index_limit) THEN
                result := last_dereference_result;
                result_sub_list_tail := NIL;
                clp$scan_any_lexical_unit (parse);
                IF parse.unit.kind = clc$lex_left_parenthesis THEN
                  clp$scan_bal_paren_lexical_unit (parse);
                  IF parse.unit.kind <> clc$lex_right_parenthesis THEN
                    osp$set_status_condition (cle$expecting_rparen_of_subexpr, status);
                    clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
                    RETURN;
                  IFEND;
                  clp$scan_any_lexical_unit (parse);
                IFEND;
                IF parse.unit.kind <> clc$lex_space THEN
                  initial_path := result^.file_value;
                ELSE
                  EXIT /evaluate_file_blk/;
                IFEND;
              IFEND;
            ELSEIF parse.unit.kind = clc$lex_left_parenthesis THEN
              began_with_left_parenthesis := TRUE;
              clp$scan_non_space_lexical_unit (parse);
            IFEND;
*ELSE
          initial_path := NIL;
          IF result <> NIL THEN
            IF unix_path THEN
              IF result^.kind = clc$unix_file THEN
                initial_path := result^.file_value;
              IFEND;
            ELSE
              IF result^.kind = clc$nos_ve_file THEN
                initial_path := result^.file_value;
              IFEND;
            IFEND;
          IFEND;
          began_with_left_parenthesis := (initial_path = NIL) AND
                (parse.unit.kind = clc$lex_left_parenthesis);
          IF began_with_left_parenthesis THEN
            clp$scan_non_space_lexical_unit (parse);
*IFEND
          IFEND;

*IF NOT $true(osv$unix)
          clp$complete_file_ref_eval (recognize_wild_cards, defer_expansion,
*ELSE
          clp$complete_file_ref_eval (unix_path, recognize_wild_cards, defer_expansion,
*IFEND
                current_type_description^.derived_from_value_kind_spec,
                initial_path, parse, work_area, result, result_sub_list_tail, status);
          IF NOT status.normal THEN
            IF status.condition = cle$work_area_overflow THEN
              EXIT evaluate_expression;
            IFEND;
            RETURN;
          IFEND;

          IF began_with_left_parenthesis THEN
            IF parse.unit_is_space THEN
              clp$scan_non_space_lexical_unit (parse);
            IFEND;
            IF parse.unit.kind <> clc$lex_right_parenthesis THEN
              osp$set_status_condition (cle$expecting_rparen_of_subexpr, status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              RETURN;
            IFEND;
            clp$scan_any_lexical_unit (parse);
          IFEND;
        END /evaluate_file_blk/;
        recognize_binary_operator;

      PROCEND evaluate_file;
?? TITLE := 'evaluate_keyword', EJECT ??

      PROCEDURE evaluate_keyword
        (VAR result: ^clt$data_value);


        IF recognize_wild_cards THEN
          handle_wild_card_name (result, result_sub_list_tail);
          IF result <> NIL THEN
            RETURN;
          IFEND;
        IFEND;

        evaluate_operand (result);

        CASE result^.kind OF
        = clc$keyword =
          { checking for allowed keywords is done within evaluate_operand } ;
        = clc$unspecified =
          ;
        = clc$data_name =
          osp$set_status_abnormal ('CL', cle$unknown_keyword, result^.data_name_value, status);
          EXIT evaluate_expression;
        = clc$name =
          osp$set_status_abnormal ('CL', cle$unknown_keyword, result^.name_value, status);
          EXIT evaluate_expression;
        ELSE
          osp$set_status_condition (cle$wrong_kind_of_value, status);
          clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
          clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
          EXIT evaluate_expression;
        CASEND;

      PROCEND evaluate_keyword;
?? TITLE := 'evaluate_list', EJECT ??

      PROCEDURE evaluate_list
        (VAR result: ^clt$data_value);

        VAR
          element_expansion: clt$list_expansion,
          element_type_description: ^clt$type_description,
          list_size: clt$list_size,
          local_numeric_info: clt$numeric_operand_info,
          local_parse: clt$parse_state,
          local_result: ^clt$data_value,
          local_status: ^ost$status,
          result_conforms_to_element_type: boolean,
          result_conforms_to_type: boolean,
          type_description: ^clt$type_description,
          sub_list_tail: ^clt$data_value;

?? NEWTITLE := 'validate_list_size', EJECT ??

        PROCEDURE [INLINE] validate_list_size;


          IF (list_size < current_type_description^.min_list_size) OR
                (list_size > current_type_description^.max_list_size) THEN
            osp$set_status_condition (cle$too_few_or_many_list_elems, status);
            osp$append_status_integer (osc$status_parameter_delimiter, list_size, 10, FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  current_type_description^.min_list_size, 10, FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  current_type_description^.max_list_size, 10, FALSE, status);
            EXIT evaluate_list;
          IFEND;

        PROCEND validate_list_size;
?? OLDTITLE, EJECT ??

        defer_expansion := current_type_description^.defer_expansion;
        IF defer_expansion THEN
          element_expansion := clc$defer_expansion;
        ELSE
          element_expansion := clc$normal_expansion;
        IFEND;
        IF current_type_description^.list_element_type_description <> NIL THEN
          element_type_description := current_type_description^.list_element_type_description;
          CASE element_type_description^.kind OF
*IF NOT $true(osv$unix)
          = clc$file_type, clc$keyword_type =
*ELSE
          = clc$nos_ve_file_type =
            recognize_wild_cards := (clc$file_type = clc$nos_ve_file_type) OR defer_expansion OR
                  (expression_type_name <> NIL);
          = clc$unix_file_type =
            recognize_wild_cards := (clc$file_type = clc$unix_file_type) OR defer_expansion OR
                  (expression_type_name <> NIL);
          = clc$keyword_type =
*IFEND
            recognize_wild_cards := TRUE;
          = clc$data_name_type, clc$name_type, clc$program_name_type =
            recognize_wild_cards := defer_expansion OR (expression_type_name <> NIL);
          ELSE
            recognize_wild_cards := FALSE;
            element_expansion := clc$no_expansion;
          CASEND;
        ELSE
          element_type_description := ^unqual_union_type_description;
          recognize_wild_cards := FALSE;
          element_expansion := clc$no_expansion;
        IFEND;
        sub_list_tail := NIL;

        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;
        IF recognize_wild_cards THEN
          clp$rescan_wild_card_lex_unit (parse);
        IFEND;

        local_parse := parse;

        type_description := NIL;
        result := NIL;
        result_conforms_to_type := FALSE;
        result_conforms_to_element_type := FALSE;
        operand_type_description := NIL;
        IF parse.unit.kind = clc$lex_name THEN
          check_for_variable_or_function (element_type_description, result_conforms_to_element_type,
                result_conforms_to_type, type_description, result, sub_list_tail);
          IF (result <> NIL) AND result_conforms_to_type THEN
            IF (current_type_description^.derived_from_value_kind_spec) THEN
              convert_fs_file_ref_to_cl_file (result);
            IFEND;
            RETURN;
          IFEND;
        IFEND;

        IF ((result <> NIL) AND (result^.kind = clc$unspecified) AND result_conforms_to_element_type) AND
              ((NOT current_type_description^.list_rest) OR (parse.unit.kind = clc$lex_right_parenthesis))
              THEN
          RETURN;
        IFEND;

        IF result_conforms_to_element_type AND (operator.kind = clc$not_an_operator) THEN
          IF sub_list_tail <> NIL THEN
            local_result := result^.element_value;
            list_size := clp$count_list_elements (result);
          ELSE
            local_result := result;
            clp$make_list_value (work_area, result);
            IF result = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              EXIT evaluate_expression;
            IFEND;
            result^.element_value := local_result;
            list_size := 1;
          IFEND;

          IF current_type_description^.list_rest THEN

{ check for unspecified list element value

            IF (result^.element_value <> NIL) AND (result^.element_value^.kind = clc$unspecified) THEN
              osp$set_status_abnormal ('CL', cle$unspecified_value_for_list, last_dereference_name, status);
              EXIT evaluate_expression;
            IFEND;
            result^.generated_via_list_rest := TRUE;
            IF parse.unit_is_space THEN
              clp$scan_non_space_lexical_unit (parse);
            IFEND;
            evaluate_parenthesized_list (element_type_description, type_description, local_result, clc$list,
                  element_expansion, sub_list_tail, list_size, result);
          IFEND;
          validate_list_size;
          RETURN;
        IFEND;

        local_result := result;
        clp$make_list_value (work_area, result);
        IF result = NIL THEN
          osp$set_status_condition (cle$work_area_overflow, status);
          EXIT evaluate_expression;
        IFEND;

        IF current_type_description^.list_rest THEN
          list_size := 0;
          parse := local_parse;
          IF parse.unit_is_space THEN
            clp$scan_non_space_lexical_unit (parse);
          IFEND;
          evaluate_parenthesized_list (element_type_description, type_description, local_result, clc$list,
                element_expansion, NIL, list_size, result);
          result^.generated_via_list_rest := TRUE;
          validate_list_size;
          RETURN;
        IFEND;

        IF local_parse.unit.kind = clc$lex_left_parenthesis THEN
          list_size := 0;
          clp$scan_non_space_lexical_unit (parse);
          evaluate_parenthesized_list (element_type_description, type_description, local_result, clc$list,
                element_expansion, NIL, list_size, result);
          validate_list_size;
          RETURN;
        IFEND;

        local_status := NIL;
        IF (local_result <> NIL) AND (operator.kind = clc$not_an_operator) THEN
          CASE local_result^.kind OF
          = clc$array =
            clp$convert_array_to_list (local_result, operand_type_description, current_type_description,
                  work_area, result, status);
            IF status.normal THEN
              RETURN;
            ELSEIF (status.condition <> cle$wrong_kind_of_element_type) AND
                  (status.condition <> cle$wrong_kind_of_element_value) THEN
              EXIT evaluate_expression;
            IFEND;
            PUSH local_status;
            local_status^ := status;

          = clc$unspecified =
            IF (type_description <> NIL) AND (type_description^.kind = clc$array_type) THEN
              clp$evaluate_type_conformance (type_description^.array_element_type_description,
                    current_type_description^.list_element_type_description, clc$conforms_to_type, status);
              IF status.normal THEN
                result := local_result;
                RETURN;
              IFEND;
            IFEND;
          ELSE
            ;
          CASEND;
        IFEND;

        parse := local_parse;
        local_numeric_info.initialized := FALSE;
        evaluate_expression (parse, element_type_description, FALSE, element_expansion, local_numeric_info,
              result^.element_value, sub_list_tail, status);
        IF NOT status.normal THEN
          IF local_status <> NIL THEN
            status := local_status^;
          ELSE
            determine_structure_status (local_result, clc$list, type_description, current_type_description,
                  status);
          IFEND;
          EXIT evaluate_expression;
        ELSEIF sub_list_tail <> NIL THEN
          result := result^.element_value;
          list_size := clp$count_list_elements (result);
        ELSE
          list_size := 1;
        IFEND;

{ check for unspecified element_value for list

        IF (result^.element_value <> NIL) AND (result^.element_value^.kind = clc$unspecified) THEN
          osp$set_status_abnormal ('CL', cle$unspecified_value_for_list, last_dereference_name, status);
          RETURN;
        IFEND;

        validate_list_size;

        recognize_binary_operator;

      PROCEND evaluate_list;
?? TITLE := 'evaluate_lock', EJECT ??

      PROCEDURE evaluate_lock
        (VAR result: ^clt$data_value);


        osp$set_status_abnormal ('CL', cle$not_supported, 'lock expressions', status);
        EXIT evaluate_expression;

      PROCEND evaluate_lock;
?? TITLE := 'evaluate_name', EJECT ??

      PROCEDURE evaluate_name
        (VAR result: ^clt$data_value;
         VAR result_sub_list_tail: ^clt$data_value);

        VAR
          name_size: ost$name_size;


        IF recognize_wild_cards THEN
          handle_wild_card_name (result, result_sub_list_tail);
          IF result <> NIL THEN
            RETURN;
          IFEND;
        IFEND;

        evaluate_operand (result);

        CASE result^.kind OF
        = clc$data_name =
          clp$make_name_value (result^.data_name_value, work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;
        = clc$keyword =
          clp$make_name_value (result^.keyword_value, work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;
        ELSE
          ;
        CASEND;

        CASE result^.kind OF
        = clc$name =
          name_size := clp$trimmed_string_size (result^.name_value);
          IF name_size > current_type_description^.max_name_size THEN
            osp$set_status_condition (cle$name_value_too_long, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  current_type_description^.max_name_size, 10, FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter, name_size, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, result^.name_value, status);
            EXIT evaluate_expression;
          ELSEIF name_size < current_type_description^.min_name_size THEN
            osp$set_status_condition (cle$name_value_too_short, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  current_type_description^.min_name_size, 10, FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter, name_size, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, result^.name_value, status);
            EXIT evaluate_expression;
          IFEND;
        = clc$unspecified =
          ;
        ELSE
          osp$set_status_condition (cle$wrong_kind_of_value, status);
          clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
          clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
          EXIT evaluate_expression;
        CASEND;

      PROCEND evaluate_name;
?? TITLE := 'evaluate_network_title', EJECT ??

      PROCEDURE evaluate_network_title
        (VAR result: ^clt$data_value);


        osp$set_status_abnormal ('CL', cle$not_supported, 'network_title expressions', status);
        EXIT evaluate_expression;

      PROCEND evaluate_network_title;
?? TITLE := 'evaluate_number', EJECT ??

      PROCEDURE evaluate_number
        (    finalize_result: boolean;
         VAR result {input, output} : ^clt$data_value);

        VAR
          integer_result: clt$data_value,
          real_convertable_to_integer: boolean;

?? NEWTITLE := 'complete_numeric_result', EJECT ??

        PROCEDURE complete_numeric_result;

          VAR
            converted_stat_code: integer,
            real_number: clt$real,
            result_kind: clt$type_kind;


          CASE result^.kind OF
          = clc$integer =
            result_kind := clc$integer_type;
          = clc$real =
            result_kind := clc$real_type;
          = clc$statistic_code =
            converted_stat_code := result^.statistic_code_value;
            result^.kind := clc$integer;
            result^.integer_value.value := converted_stat_code;
            result^.integer_value.radix := 10;
            result^.integer_value.radix_specified := FALSE;
            result_kind := clc$integer_type;
          = clc$status_code =
            converted_stat_code := result^.status_code_value;
            result^.kind := clc$integer;
            result^.integer_value.value := converted_stat_code;
            result^.integer_value.radix := 10;
            result^.integer_value.radix_specified := FALSE;
            result_kind := clc$integer_type;
          = clc$unspecified =
            RETURN;
          ELSE
            CASE current_type_description^.kind OF
            = clc$integer_type, clc$real_type =
              osp$set_status_condition (cle$wrong_kind_of_value, status);
              clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
              clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
              EXIT evaluate_expression;
            ELSE
              RETURN;
            CASEND;
          CASEND;

          IF NOT (result_kind IN current_type_description^.kinds) THEN
*IF NOT $true(osv$unix)
            IF clc$real_type IN current_type_description^.kinds THEN
              clp$convert_integer_to_real (result^.integer_value.value, real_number, status);
              IF NOT status.normal THEN
                EXIT evaluate_expression;
              IFEND;
              result^.kind := clc$real;
              result^.real_value := real_number;
            ELSEIF real_convertable_to_integer THEN

{ Since the real number has a fractional part, it can't be treated as an integer without loss of significance.

              osp$set_status_condition (cle$wrong_kind_of_value, status);
              clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
              clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
              EXIT evaluate_expression;
            ELSE
              osp$set_status_condition (cle$real_greater_than_integer, status);
              osp$append_status_real (osc$status_parameter_delimiter, result^.real_value.value,
                    result^.real_value.number_of_digits, status);
              EXIT evaluate_expression;
            IFEND;
*IFEND
          IFEND;

          IF result^.kind = clc$integer THEN
            IF (result^.integer_value.value < numeric_info.min_integer_value) OR
                  (result^.integer_value.value > numeric_info.max_integer_value) THEN
              osp$set_status_condition (cle$integer_out_of_range, status);
              osp$append_status_integer (osc$status_parameter_delimiter, result^.integer_value.value,
                    result^.integer_value.radix, result^.integer_value.radix_specified, status);
              osp$append_status_integer (osc$status_parameter_delimiter, numeric_info.min_integer_value,
                    result^.integer_value.radix, result^.integer_value.radix_specified, status);
              osp$append_status_integer (osc$status_parameter_delimiter, numeric_info.max_integer_value,
                    result^.integer_value.radix, result^.integer_value.radix_specified, status);
              EXIT evaluate_expression;
            IFEND;
*IF NOT $true(osv$unix)
          ELSE {result^.kind = clc$real}
            IF NOT (clp$longreal_compare_le (numeric_info.min_real_value,
                  result^.real_value.value) AND clp$longreal_compare_le
                  (result^.real_value.value, numeric_info.max_real_value)) THEN
              osp$set_status_condition (cle$real_number_out_of_range, status);
              osp$append_status_real (osc$status_parameter_delimiter, result^.real_value.value,
                    result^.real_value.number_of_digits, status);
              osp$append_status_real (osc$status_parameter_delimiter, numeric_info.min_real_value,
                    clc$max_real_number_digits, status);
              osp$append_status_real (osc$status_parameter_delimiter, numeric_info.max_real_value,
                    clc$max_real_number_digits, status);
              EXIT evaluate_expression;
            IFEND;
*IFEND
          IFEND;

        PROCEND complete_numeric_result;
?? TITLE := 'handle_add_and_subtract', EJECT ??

        PROCEDURE handle_add_and_subtract
          (VAR result {input, output} : ^clt$data_value);

          VAR
            current_operator: clt$operator,
            left_operand: ^clt$data_value,
            right_operand: ^clt$data_value;


          PUSH left_operand;
          left_operand^ := result^;
          IF result = last_dereference_result THEN

{ Make a copy of the result so that LAST_DEREFERENCE_RESULT won't get overwritten

            NEXT result IN work_area;
            IF result = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              EXIT evaluate_expression;
            IFEND;
            result^ := left_operand^;
          IFEND;

          WHILE (operator.kind = clc$arithmetic_operator) AND
                (operator.arithmetic_kind IN $clt$lexical_unit_kinds [clc$lex_add, clc$lex_subtract]) DO
            current_operator := operator;

            IF current_operator.arithmetic_kind = clc$lex_subtract THEN
              numeric_info.sign := -1;
            IFEND;

            evaluate_operand (right_operand);

            CASE right_operand^.kind OF
            = clc$integer, clc$real =
              ;
            = clc$unspecified =
              osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, last_dereference_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, current_operator.representation,
                    status);
              EXIT evaluate_expression;
            ELSE
              osp$set_status_abnormal ('CL', cle$arithmetic_operand_not_num, current_operator.representation,
                    status);
              clp$append_status_value_type (osc$status_parameter_delimiter, right_operand, status);
              EXIT evaluate_expression;
            CASEND;

            IF current_operator.arithmetic_kind = clc$lex_subtract THEN
              IF numeric_info.sign = -1 THEN
                numeric_info.sign := 1;
              ELSE

{ right operand was a numeric literal

                IF (operator.kind = clc$arithmetic_operator) AND
                      (operator.arithmetic_kind = clc$lex_exponentiate) THEN
                  handle_unary_minus (right_operand^);
                ELSE
                  current_operator.arithmetic_kind := clc$lex_add;
                  current_operator.representation := '+';
                IFEND;
              IFEND;
            IFEND;

            IF (operator.kind = clc$arithmetic_operator) AND (operator.arithmetic_kind = clc$lex_exponentiate)
                  THEN
              handle_exponentiate (right_operand);
            IFEND;

            IF (operator.kind = clc$arithmetic_operator) AND (operator.arithmetic_kind IN
                  $clt$lexical_unit_kinds [clc$lex_multiply, clc$lex_divide]) THEN
              handle_multiply_and_divide (right_operand);
            IFEND;

            clp$perform_numeric_operation (current_operator.representation, left_operand^, right_operand^,
                  result^, status);
            IF NOT status.normal THEN
              EXIT evaluate_expression;
            IFEND;

            left_operand^ := result^;
          WHILEND;

        PROCEND handle_add_and_subtract;
?? TITLE := 'handle_exponentiate', EJECT ??

        PROCEDURE handle_exponentiate
          (VAR result {input, output} : ^clt$data_value);

          VAR
            current_operator_representation: clt$operator_representation,
            left_operand: ^clt$data_value,
            right_operand: ^clt$data_value;


          current_operator_representation := operator.representation;

          evaluate_operand (right_operand);

          CASE right_operand^.kind OF
          = clc$integer, clc$real =
            ;
          = clc$unspecified =
            osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, last_dereference_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, current_operator_representation,
                  status);
            EXIT evaluate_expression;
          ELSE
            osp$set_status_abnormal ('CL', cle$arithmetic_operand_not_num, current_operator_representation,
                  status);
            clp$append_status_value_type (osc$status_parameter_delimiter, right_operand, status);
            EXIT evaluate_expression;
          CASEND;

          IF (operator.kind = clc$arithmetic_operator) AND (operator.arithmetic_kind = clc$lex_exponentiate)
                THEN
            handle_exponentiate (right_operand);
          IFEND;


          PUSH left_operand;
          left_operand^ := result^;
          IF result = last_dereference_result THEN

{ Make a copy of the result so that LAST_DEREFERENCE_RESULT won't get overwritten

            NEXT result IN work_area;
            IF result = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              EXIT evaluate_expression;
            IFEND;
            result^ := left_operand^;
          IFEND;

          clp$perform_numeric_operation (current_operator_representation, left_operand^, right_operand^,
                result^, status);
          IF NOT status.normal THEN
            EXIT evaluate_expression;
          IFEND;

        PROCEND handle_exponentiate;
?? TITLE := 'handle_multiply_and_divide', EJECT ??

        PROCEDURE handle_multiply_and_divide
          (VAR result {input, output} : ^clt$data_value);

          VAR
            current_operator: clt$operator,
            left_operand: ^clt$data_value,
            right_operand: ^clt$data_value;


          PUSH left_operand;
          left_operand^ := result^;
          IF result = last_dereference_result THEN

{ Make a copy of the result so that LAST_DEREFERENCE_RESULT won't get overwritten

            NEXT result IN work_area;
            IF result = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              EXIT evaluate_expression;
            IFEND;
            result^ := left_operand^;
          IFEND;

          WHILE (operator.kind = clc$arithmetic_operator) AND
                (operator.arithmetic_kind IN $clt$lexical_unit_kinds [clc$lex_multiply, clc$lex_divide]) DO
            current_operator := operator;

            evaluate_operand (right_operand);

            CASE right_operand^.kind OF
            = clc$integer, clc$real =
              ;
            = clc$unspecified =
              osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, last_dereference_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, current_operator.representation,
                    status);
              EXIT evaluate_expression;
            ELSE
              osp$set_status_abnormal ('CL', cle$arithmetic_operand_not_num, current_operator.representation,
                    status);
              clp$append_status_value_type (osc$status_parameter_delimiter, right_operand, status);
              EXIT evaluate_expression;
            CASEND;

            IF (operator.kind = clc$arithmetic_operator) AND (operator.arithmetic_kind = clc$lex_exponentiate)
                  THEN
              handle_exponentiate (right_operand);
            IFEND;

            clp$perform_numeric_operation (current_operator.representation, left_operand^, right_operand^,
                  result^, status);
            IF NOT status.normal THEN
              EXIT evaluate_expression;
            IFEND;

            left_operand^ := result^;
          WHILEND;

        PROCEND handle_multiply_and_divide;
?? OLDTITLE, EJECT ??

        IF result = NIL THEN
          evaluate_operand (result);
        IFEND;

        IF operator.kind = clc$arithmetic_operator THEN
          CASE result^.kind OF
          = clc$integer, clc$real =
            ;
          = clc$unspecified =
            osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, last_dereference_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, operator.representation, status);
            EXIT evaluate_expression;
          ELSE
            osp$set_status_abnormal ('CL', cle$arithmetic_operand_not_num, operator.representation, status);
            clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
            EXIT evaluate_expression;
          CASEND;

          IF (operator.kind = clc$arithmetic_operator) AND (operator.arithmetic_kind = clc$lex_exponentiate)
                THEN
            handle_exponentiate (result);
          IFEND;

          IF (operator.kind = clc$arithmetic_operator) AND (operator.arithmetic_kind IN
                $clt$lexical_unit_kinds [clc$lex_multiply, clc$lex_divide]) THEN
            handle_multiply_and_divide (result);
          IFEND;

          IF (operator.kind = clc$arithmetic_operator) AND (operator.arithmetic_kind IN
                $clt$lexical_unit_kinds [clc$lex_add, clc$lex_subtract]) THEN
            handle_add_and_subtract (result);
          IFEND;
        IFEND;

        IF evaluating_sub_expression OR ((NOT finalize_result) AND (operator.kind <> clc$not_an_operator))
              THEN
          RETURN;
        IFEND;

        simplify_real_to_integer (result, integer_result, real_convertable_to_integer);

*IF NOT $true(osv$unix)
        IF finalize_result AND (($clt$type_kinds [clc$integer_type, clc$real_type] *
              current_type_description^.kinds) <> $clt$type_kinds []) THEN
*ELSE
        IF finalize_result AND (($clt$type_kinds_v2 [clc$integer_type, clc$real_type] *
              current_type_description^.kinds) <> $clt$type_kinds_v2 []) THEN
*IFEND
          complete_numeric_result;
        IFEND;

      PROCEND evaluate_number;
?? TITLE := 'evaluate_operand', EJECT ??

      PROCEDURE evaluate_operand
        (VAR operand: ^clt$data_value);

        CONST
          min_boolean_operand_name_size = 2,
          max_boolean_operand_name_size = 5;

        VAR
          number: clt$number,
          number_allowed: boolean,
          operand_was_signed: boolean,
          sign: -1 .. 1,
          sign_representation: clt$operator_representation;

?? NEWTITLE := 'complete_numeric_operand', EJECT ??

        PROCEDURE complete_numeric_operand;


          IF NOT numeric_info.radix.established THEN
            numeric_info.radix.established := TRUE;
            IF operand^.kind = clc$integer THEN
              numeric_info.radix.value := operand^.integer_value.radix;
              numeric_info.radix.specified := operand^.integer_value.radix_specified;
            ELSE
              numeric_info.radix.value := 10;
              numeric_info.radix.specified := numeric_info.radix.default <> 10;
            IFEND;
          IFEND;

          IF operand_was_signed AND (sign = -1) THEN
            handle_unary_minus (operand^);
          IFEND;

        PROCEND complete_numeric_operand;
*IF NOT $true(osv$unix)
?? TITLE := 'evaluate_file_operand', EJECT ??

        PROCEDURE evaluate_file_operand
*ELSE
?? TITLE := 'evaluate_nos_ve_file_operand', EJECT ??

        PROCEDURE evaluate_nos_ve_file_operand
*IFEND
          (VAR operand: ^clt$data_value);

          VAR
            ignore_sub_list_tail: ^clt$data_value,
            initial_path: ^fst$file_reference;


*IF NOT $true(osv$unix)
          IF (operand <> NIL) AND (operand^.kind = clc$file) THEN
*ELSE
          IF (operand <> NIL) AND (operand^.kind = clc$nos_ve_file) THEN
*IFEND
            initial_path := operand^.file_value;
          ELSE
            initial_path := NIL;
          IFEND;

*IF NOT $true(osv$unix)
          clp$complete_file_ref_eval (FALSE, FALSE, current_type_description^.derived_from_value_kind_spec,
                initial_path, parse, work_area, operand, ignore_sub_list_tail, status);
*ELSE
          clp$complete_file_ref_eval (FALSE, FALSE, FALSE,
                current_type_description^.derived_from_value_kind_spec, initial_path, parse, work_area,
                operand, ignore_sub_list_tail, status);
*IFEND
          IF NOT status.normal THEN
            EXIT evaluate_expression;
          IFEND;

*IF NOT $true(osv$unix)
        PROCEND evaluate_file_operand;
*ELSE
        PROCEND evaluate_nos_ve_file_operand;
*IFEND
?? TITLE := 'evaluate_name_operand', EJECT ??

        PROCEDURE evaluate_name_operand;

          VAR
            element_type_description: ^clt$type_description,
            i: clt$union_member_number,
            name: ost$name,
            name_size: ost$name_size,
            parse_index_after_name: clt$string_index,
            saved_parse: clt$parse_state,
            type_conformance: clt$type_conformance,
            unknown_name_condition: ost$status_condition;

?? NEWTITLE := 'check_for_and_handle_boolean', EJECT ??

          PROCEDURE check_for_and_handle_boolean
            (    name: ost$name);

            VAR
              bool: clt$boolean,
              name_is_boolean: boolean;


            clp$check_name_for_boolean (name, bool, name_is_boolean);
            IF (NOT name_is_boolean) OR
                  ((parse.unit.kind >= clc$lex_greater_than) AND (parse.unit.kind <= clc$lex_not_equal)) THEN
              RETURN;
            IFEND;

            clp$make_clt$boolean_value (bool, work_area, operand);
            IF operand = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              EXIT evaluate_expression;
            IFEND;

            EXIT evaluate_name_operand;

          PROCEND check_for_and_handle_boolean;
?? TITLE := 'check_for_and_handle_keyword', EJECT ??

          PROCEDURE check_for_and_handle_keyword
            (    name: ost$name);

            VAR
              current_index: 1 .. clc$max_keywords,
              high_index: 0 .. clc$max_keywords,
              keyword: clt$keyword,
              keyword_ordinal: clt$named_entry_ordinal,
              temp: integer,
              low_index: 1 .. clc$max_keywords + 1;


            keyword := name;
            low_index := 1;
            high_index := UPPERBOUND (current_type_description^.keyword_specifications^);
            REPEAT
              temp := low_index + high_index;
              current_index := temp DIV 2;
              IF current_type_description^.keyword_specifications^ [current_index].keyword = keyword THEN

              /normalize_keyword/
                BEGIN
                  IF current_type_description^.keyword_specifications^ [current_index].class =
                        clc$nominal_entry THEN
                    EXIT /normalize_keyword/;
                  IFEND;

                  keyword_ordinal := current_type_description^.keyword_specifications^ [current_index].
                        ordinal;
                  low_index := current_index + 1;
                  high_index := current_index - 1;

                  FOR current_index := low_index TO UPPERBOUND (current_type_description^.
                        keyword_specifications^) DO
                    IF (current_type_description^.keyword_specifications^ [current_index].ordinal =
                          keyword_ordinal) AND (current_type_description^.
                          keyword_specifications^ [current_index].class = clc$nominal_entry) THEN
                      keyword := current_type_description^.keyword_specifications^ [current_index].keyword;
                      EXIT /normalize_keyword/;
                    IFEND;
                  FOREND;

                  FOR current_index := high_index DOWNTO 1 DO
                    IF (current_type_description^.keyword_specifications^ [current_index].ordinal =
                          keyword_ordinal) AND (current_type_description^.
                          keyword_specifications^ [current_index].class = clc$nominal_entry) THEN
                      keyword := current_type_description^.keyword_specifications^ [current_index].keyword;
                      EXIT /normalize_keyword/;
                    IFEND;
                  FOREND;

                  osp$set_status_condition (cle$bad_keyword_type_spec, status);
                  EXIT evaluate_expression;
                END /normalize_keyword/;

                clp$make_keyword_value (keyword, work_area, operand);
                IF operand = NIL THEN
                  osp$set_status_condition (cle$work_area_overflow, status);
                  EXIT evaluate_expression;
                IFEND;
                EXIT evaluate_name_operand;

              ELSEIF current_type_description^.keyword_specifications^ [current_index].keyword < keyword THEN
                low_index := current_index + 1;
              ELSE
                high_index := current_index - 1;
              IFEND;
            UNTIL low_index > high_index;

          PROCEND check_for_and_handle_keyword;
?? TITLE := 'handle_$max', EJECT ??

          PROCEDURE handle_$max;

            VAR
              real_number: clt$real;


            clp$make_integer_value (numeric_info.max_integer_value, numeric_info.radix.default, FALSE,
                  work_area, operand);
            IF operand = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              EXIT evaluate_expression;
            IFEND;

            IF clc$integer_type IN current_type_description^.kinds THEN
*IF NOT $true(osv$unix)
              IF clc$real_type IN current_type_description^.kinds THEN
                clp$convert_integer_to_real (operand^.integer_value.value, real_number, status);
                IF NOT status.normal THEN
                  EXIT evaluate_expression;
                IFEND;
                IF clp$longreal_compare_gt (numeric_info.max_real_value, real_number.value) THEN
                  operand^.kind := clc$real;
                  operand^.real_value.value := numeric_info.max_real_value;
                  operand^.real_value.number_of_digits := clc$max_real_number_digits;
                IFEND;
              IFEND;
*IFEND
            ELSEIF clc$real_type IN current_type_description^.kinds THEN
              operand^.kind := clc$real;
              operand^.real_value.value := numeric_info.max_real_value;
              operand^.real_value.number_of_digits := clc$max_real_number_digits;
            IFEND;

            EXIT evaluate_name_operand;

          PROCEND handle_$max;
?? TITLE := 'handle_$min', EJECT ??

          PROCEDURE handle_$min;

            VAR
              real_number: clt$real;


            clp$make_integer_value (numeric_info.min_integer_value, numeric_info.radix.default, FALSE,
                  work_area, operand);
            IF operand = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              EXIT evaluate_expression;
            IFEND;

            IF clc$integer_type IN current_type_description^.kinds THEN
*IF NOT $true(osv$unix)
              IF clc$real_type IN current_type_description^.kinds THEN
                clp$convert_integer_to_real (operand^.integer_value.value, real_number, status);
                IF NOT status.normal THEN
                  EXIT evaluate_expression;
                IFEND;
                IF clp$longreal_compare_lt (numeric_info.min_real_value, real_number.value) THEN
                  operand^.kind := clc$real;
                  operand^.real_value.value := numeric_info.min_real_value;
                  operand^.real_value.number_of_digits := clc$max_real_number_digits;
                IFEND;
              IFEND;
*IFEND
            ELSEIF clc$real_type IN current_type_description^.kinds THEN
              operand^.kind := clc$real;
              operand^.real_value.value := numeric_info.min_real_value;
              operand^.real_value.number_of_digits := clc$max_real_number_digits;
            IFEND;

            EXIT evaluate_name_operand;

          PROCEND handle_$min;
?? TITLE := 'handle_$now', EJECT ??

          PROCEDURE handle_$now;

            VAR
              date_time: clt$date_time,
              saved_parse: clt$parse_state;

            IF parse.unit.kind = clc$lex_left_parenthesis THEN

{  Check for $now().  Note that an arbitrary number of spaces may be between
{  the parentheses.  If the syntax is correct, advance the parse state past
{  the right parenthesis, else ignore $now for now and let an error be
{  generated later.

              saved_parse := parse;
              clp$scan_non_space_lexical_unit (parse);
              IF parse.unit.kind <> clc$lex_right_parenthesis THEN
                parse := saved_parse;
                RETURN;
              ELSE
                clp$scan_any_lexical_unit (parse);
              IFEND;
            IFEND;

            get_present_date_time;
            date_time.value := present_date_time.value;
            date_time.date_specified := TRUE;
            date_time.time_specified := TRUE;
            clp$make_date_time_value (date_time, work_area, operand);
            IF operand = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              EXIT evaluate_expression;
            IFEND;

            EXIT evaluate_name_operand;

          PROCEND handle_$now;
?? TITLE := 'handle_not', EJECT ??

          PROCEDURE handle_not
            (VAR result: ^clt$data_value);


            clp$scan_non_space_lexical_unit (parse);
            IF NOT parse.previous_unit_is_space THEN
              osp$set_status_abnormal ('CL', cle$missing_spaces_after, 'NOT', status);
              EXIT evaluate_expression;
            IFEND;

            evaluate_boolean_operand (result);

            IF operator.kind = clc$relational_operator THEN
              handle_comparison (result);
            IFEND;

            CASE result^.kind OF
            = clc$boolean =
              ;
            = clc$unspecified =
              osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, last_dereference_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, clc$not_operator_representation,
                    status);
              EXIT evaluate_expression;
            ELSE
              osp$set_status_condition (cle$not_operand_not_boolean, status);
              clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
              EXIT evaluate_expression;
            CASEND;

            clp$make_boolean_value (NOT result^.boolean_value.value, result^.boolean_value.kind, work_area,
                  result);
            IF result = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              EXIT evaluate_expression;
            IFEND;

{ The following EXIT avoids a redundant call to recognize_binary_operator.

            EXIT evaluate_operand;

          PROCEND handle_not;
?? OLDTITLE, EJECT ??

          saved_parse := parse;
          name_size := parse.unit.size;
          #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, name_size), name);
          clp$scan_any_lexical_unit (parse);

          IF recognize_wild_cards AND (parse.unit.kind IN $clt$lexical_unit_kinds
                [clc$lex_query, clc$lex_multiply]) THEN
            evaluate_wild_card_operand (name (1, name_size), operand);
            RETURN;
          IFEND;

          IF current_type_description^.kind = clc$keyword_type THEN
            check_for_and_handle_keyword (name);

{ check_for_and_handle_keyword exits evaluate_name_operand if the name is a keyword

          IFEND;

          IF name (1) = '$' THEN
            IF parse.unit.kind <> clc$lex_dot THEN
              IF number_allowed AND (parse.unit.kind <> clc$lex_left_parenthesis) THEN
                IF name (2, * ) = 'MAX' THEN
                  handle_$max;

{ handle_$max exits evaluate_name_operand

                ELSEIF name (2, * ) = 'MIN' THEN
                  handle_$min;

{ handle_$min exits evaluate_name_operand

                IFEND;
              ELSEIF (clc$date_time_type IN current_type_description^.kinds) AND (name (2, * ) = 'NOW') THEN
                handle_$now;

{ handle_$now exits evaluate_name_operand unless it finds a syntax error.  In that case it
{ returns here so that the error can get handled by more general logic.

              IFEND;
            IFEND;
            unknown_name_condition := cle$unknown_function;
          ELSE
            IF (clc$boolean_type IN current_type_description^.kinds) AND
                  (min_boolean_operand_name_size <= name_size) AND
                  (name_size <= max_boolean_operand_name_size) THEN
              IF name = 'NOT' THEN
                handle_not (operand);

{ handle_not EXITs from evaluate_operand

              IFEND;
              check_for_and_handle_boolean (name);

{ check_for_and_handle_boolean exits evaluate_name_operand if the name is a boolean constant

            IFEND;
            unknown_name_condition := cle$unknown_variable;
          IFEND;

          parse_index_after_name := parse.unit_index;

          dereference_name (name, operand);
          IF NOT status.normal THEN
            EXIT evaluate_expression;
          IFEND;

          IF operand <> NIL THEN
            CASE operand^.kind OF
            = clc$unspecified =
              IF operand_type_description = NIL THEN
                RETURN;
              IFEND;
              IF (operand_type_description^.kind = clc$union_type) AND
                    (operand_type_description^.member_descriptions <> NIL) THEN
                FOR i := 1 TO UPPERBOUND (operand_type_description^.member_descriptions^) DO
                  clp$validate_type_conformance (^operand_type_description^.member_descriptions^ [i],
                        current_type_description, type_conformance);
                  IF type_conformance >= clc$conforms_to_generic_type THEN
                    RETURN;
                  IFEND;
                FOREND;
              ELSEIF (current_type_description^.kind = clc$union_type) AND
                    (current_type_description^.member_descriptions <> NIL) THEN
                FOR i := 1 TO UPPERBOUND (current_type_description^.member_descriptions^) DO
                  clp$validate_type_conformance (^current_type_description^.member_descriptions^ [i],
                        operand_type_description, type_conformance);
                  IF type_conformance >= clc$conforms_to_generic_type THEN
                    RETURN;
                  IFEND;
                FOREND;
              IFEND;
              clp$validate_type_conformance (operand_type_description, current_type_description,
                    type_conformance);
              IF type_conformance >= clc$conforms_to_type THEN
                RETURN;
              IFEND;

*IF NOT $true(osv$unix)
            = clc$file =
              evaluate_file_operand (operand);
*ELSE
            = clc$nos_ve_file =
              evaluate_nos_ve_file_operand (operand);
*IFEND
            ELSE
              ;
            CASEND;

            CASE current_type_description^.kind OF

            = clc$keyword_type =
              CASE operand^.kind OF
              = clc$data_name =
                name := operand^.data_name_value;
              = clc$keyword =
                name := operand^.keyword_value;
              = clc$name =
                name := operand^.name_value;
              ELSE
                RETURN;
              CASEND;
              check_for_and_handle_keyword (name);

{ check_for_and_handle_keyword exits evaluate_name_operand if the name is a keyword

            = clc$name_type =
              IF (operand^.kind IN $clt$data_kinds [clc$name, clc$data_name, clc$keyword]) OR
                    (parse.unit_index <> parse_index_after_name) THEN
                RETURN;
              IFEND;

            = clc$program_name_type =
              IF (operand^.kind IN $clt$data_kinds [clc$cobol_name, clc$name, clc$data_name, clc$keyword,
                    clc$program_name, clc$string]) OR (parse.unit_index <> parse_index_after_name) THEN
                RETURN;
              IFEND;

            ELSE

              IF (operand^.kind = clc$name) AND (clc$boolean_type IN current_type_description^.kinds) THEN
                check_for_and_handle_boolean (operand^.name_value);

{ check_for_and_handle_boolean exits evaluate_name_operand if the name is a boolean constant

              IFEND;

              IF (clv$value_type_kinds [operand^.kind] IN current_type_description^.kinds) OR
                    (NOT (clc$name_type IN current_type_description^.kinds)) OR
                    (parse.unit_index <> parse_index_after_name) THEN
                RETURN;
              IFEND;

              CASE operand^.kind OF
              = clc$data_name =
                name := operand^.data_name_value;
              = clc$keyword =
                name := operand^.keyword_value;
              = clc$name =
                name := operand^.name_value;
              ELSE
                ;
              CASEND;
            CASEND;
          IFEND;

*IF NOT $true(osv$unix)
          IF ($clt$type_kinds [clc$application_type, clc$boolean_type, clc$cobol_name_type,
                clc$data_name_type, clc$file_type, clc$keyword_type, clc$name_type, clc$program_name_type,
                clc$statistic_code_type, clc$status_code_type] * current_type_description^.kinds) =
                $clt$type_kinds [] THEN
*ELSE
          IF ($clt$type_kinds_v2 [clc$application_type, clc$boolean_type, clc$cobol_name_type,
                clc$data_name_type, clc$nos_ve_file_type, clc$keyword_type, clc$name_type,
                clc$program_name_type, clc$statistic_code_type, clc$status_code_type, clc$unix_file_type] *
                current_type_description^.kinds) = $clt$type_kinds_v2 [] THEN
*IFEND
            IF (current_type_description^.kind = clc$keyword_type) AND
                  (NOT (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_left_parenthesis, clc$lex_dot]))
                  THEN
              unknown_name_condition := cle$unknown_keyword;
            IFEND;
            osp$set_status_abnormal ('CL', unknown_name_condition, name, status);
            EXIT evaluate_expression;
          IFEND;

          clp$make_name_value (name, work_area, operand);
          IF operand = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;

*IF NOT $true(osv$unix)
          IF (parse.unit.kind = clc$lex_dot) OR (parse.unit.kind = clc$lex_concatenate) THEN
*ELSE
          IF (parse.unit.kind = clc$lex_dot) OR (parse.unit.kind = clc$lex_concatenate) OR
                (parse.unit.kind = clc$lex_divide) THEN
*IFEND
            parse := saved_parse;
*IF NOT $true(osv$unix)
            evaluate_file_operand (operand);
*ELSE
            evaluate_nos_ve_file_operand (operand);
*IFEND
          IFEND;

        PROCEND evaluate_name_operand;
?? TITLE := 'evaluate_string_literal', EJECT ??

        PROCEDURE evaluate_string_literal;


          clp$make_sized_string_value (parse.unit.size - 2, work_area, operand);
          IF operand <> NIL THEN

            operand^.string_value^ (1, parse.unit.size - 2) :=
                  parse.text^ (parse.unit_index + 1, parse.unit.size - 2);

          /complete_string_literal/
            WHILE parse.unit_index < parse.index_limit DO
              clp$scan_any_lexical_unit (parse);
              CASE parse.unit.kind OF
              = clc$lex_string =
                RESET work_area TO operand^.string_value;
                NEXT operand^.string_value: [STRLENGTH (operand^.string_value^) + parse.unit.size - 1] IN
                      work_area;
                IF operand^.string_value = NIL THEN
                  RESET work_area TO operand;
                  operand := NIL;
                  EXIT /complete_string_literal/;
                IFEND;

                operand^.string_value^ (STRLENGTH (operand^.string_value^) - parse.unit.size + 2,
                      parse.unit.size - 1) := parse.text^ (parse.unit_index, parse.unit.size - 1);

              = clc$lex_unterminated_string =
                osp$set_status_abnormal ('CL', cle$missing_string_delimiter, parse.
                      text^ (parse.unit_index, parse.unit.size), status);
                EXIT evaluate_expression;
              ELSE
                operand_is_string_literal := TRUE;
                RETURN;
              CASEND;
            WHILEND /complete_string_literal/;
          IFEND;

          osp$set_status_condition (cle$work_area_overflow, status);
          EXIT evaluate_expression;

        PROCEND evaluate_string_literal;
?? TITLE := 'evaluate_sub_expression', EJECT ??

{
{ NOTE:
{   This routine pre-scans for the closing right parenthesis of the
{   sub-expression in order to establish the "index_limit" for the sub-
{   expression.  This limit is required if the evaluation is being done
{   for a union (ANY) type.
{

        PROCEDURE evaluate_sub_expression;

          VAR
            ignore_sub_list_tail: ^clt$data_value,
            saved_parse: clt$parse_state,
            sub_parse: clt$parse_state,
            union_info: clt$union_type_information,
            union_type_description: clt$type_description;


          sub_parse := parse;
          clp$scan_bal_paren_lexical_unit (sub_parse);
          IF sub_parse.unit.kind <> clc$lex_right_parenthesis THEN
            osp$set_status_condition (cle$expecting_rparen_of_subexpr, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, sub_parse, status);
            EXIT evaluate_expression;
          IFEND;

          parse.index_limit := sub_parse.unit_index;
          clp$scan_non_space_lexical_unit (parse);

{ If we are evaluating a string, then we must evaluate the expression within
{ the parenthesis as a union type in order to correctly process operators which
{ may be in the expression, i.e. string_var = 'hi'//(4+3).

          IF current_type_description^.kind = clc$string_type THEN
            union_type_description.specification := NIL;
            union_type_description.name := NIL;
            union_type_description.derived_from_value_kind_spec := FALSE;
            union_type_description.advanced_keywords_present := FALSE;
*IF NOT $true(osv$unix)
            union_type_description.kinds := -$clt$type_kinds [];
*ELSE
            union_type_description.kinds := -$clt$type_kinds_v2 [];
*IFEND
            union_type_description.kind := clc$union_type;
            union_type_description.member_descriptions := NIL;
            union_type_description.union_information := ^union_info;

            union_info.only_standard_types_in_union := TRUE;
            union_info.min_integer_value := clc$min_integer;
            union_info.max_integer_value := clc$max_integer;
            union_info.default_radix := 10;
*IF NOT $true(osv$unix)
            #UNCHECKED_CONVERSION (clv$negative_infinity^,
                  union_info.min_real_value.long_real);
            #UNCHECKED_CONVERSION (clv$positive_infinity^,
                  union_info.max_real_value.long_real);
*ELSE
            union_info.min_real_value.long_real := clv$negative_infinity^;
            union_info.max_real_value.long_real := clv$positive_infinity^;
*IFEND
          ELSE
            union_type_description := current_type_description^;
          IFEND;

          saved_parse := parse;
          evaluate_expression (parse, ^union_type_description, TRUE, list_expansion, numeric_info,
                operand, ignore_sub_list_tail, status);

{ If the status is abnormal, re-evaluate the subexpression as a string, in order
{ to get a more meaningful error message.

          IF NOT status.normal AND (status.condition = cle$expression_not_union_type) THEN
            parse := saved_parse;
            evaluate_expression (parse, current_type_description, TRUE,
                  list_expansion, numeric_info, operand, ignore_sub_list_tail,
                  status);
          IFEND;
          IF NOT status.normal THEN
            parse.index_limit := sub_parse.index_limit;
            EXIT evaluate_expression;
          IFEND;

          IF parse.unit_is_space THEN
            clp$scan_non_space_lexical_unit (parse);
          IFEND;
          IF parse.unit_index < sub_parse.unit_index THEN
            osp$set_status_condition (cle$expecting_rparen_of_subexpr, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            parse.index_limit := sub_parse.index_limit;
            EXIT evaluate_expression;
          IFEND;

          parse := sub_parse;
          clp$scan_any_lexical_unit (parse);

          numeric_info.sign := sign;

        PROCEND evaluate_sub_expression;
?? TITLE := 'evaluate_wild_card_operand', EJECT ??

        PROCEDURE evaluate_wild_card_operand
          (    first_component: string ( * <= osc$max_name_size);
           VAR operand: ^clt$data_value);


          osp$set_status_condition (cle$wild_card_not_allowed, status);
          EXIT evaluate_expression;

        PROCEND evaluate_wild_card_operand;
?? OLDTITLE, EJECT ??

        operand := NIL;
        operand_is_string_literal := FALSE;
        operand_type_description := NIL;

*IF NOT $true(osv$unix)
        number_allowed := (current_type_description^.kinds * $clt$type_kinds
              [clc$integer_type, clc$real_type, clc$boolean_type]) <> $clt$type_kinds [];
*ELSE
        number_allowed := (current_type_description^.kinds * $clt$type_kinds_v2
              [clc$integer_type, clc$real_type, clc$boolean_type]) <> $clt$type_kinds_v2 [];
*IFEND
        operand_was_signed := FALSE;
        sign := numeric_info.sign;

        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

        IF number_allowed THEN
          WHILE parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_add, clc$lex_subtract] DO
            operand_was_signed := TRUE;
            sign_representation := parse.text^ (parse.unit_index, parse.unit.size);
            IF parse.unit.kind = clc$lex_subtract THEN
              sign := -sign;
            IFEND;
            clp$scan_non_space_lexical_unit (parse);
          WHILEND;
        IFEND;

        CASE parse.unit.kind OF

*IF NOT $true(osv$unix)
        = clc$lex_colon, clc$lex_dot, clc$lex_concatenate =
          evaluate_file_operand (operand);
*ELSE
        = clc$lex_colon, clc$lex_dot, clc$lex_concatenate, clc$lex_divide =
          evaluate_nos_ve_file_operand (operand);
*IFEND

        = clc$lex_left_parenthesis =
          evaluate_sub_expression;

        = clc$lex_query, clc$lex_multiply =
          evaluate_wild_card_operand ('', operand);

        = clc$lex_name =
          evaluate_name_operand;

        = clc$lex_long_name =
          osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                status);
          EXIT evaluate_expression;

        = clc$lex_string =
          evaluate_string_literal;

        = clc$lex_unterminated_string =
          osp$set_status_abnormal ('CL', cle$missing_string_delimiter, parse.
                text^ (parse.unit_index, parse.unit.size), status);
          EXIT evaluate_expression;

        = clc$lex_alpha_number, clc$lex_unsigned_decimal =
          clp$evaluate_numeric_literal (sign, numeric_info.radix.default, parse, number, status);
          IF NOT status.normal THEN
            IF NOT number_allowed THEN
              osp$set_status_abnormal ('CL', cle$improper_parameter_value, parse.
                    text^ (parse.previous_non_space_unit_index, parse.previous_non_space_unit.size),
                    status);
              EXIT evaluate_expression;
            ELSE
              EXIT evaluate_expression;
            IFEND;
          IFEND;
          clp$make_clt$number_value (number, work_area, operand);
          IF operand = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;
          sign := 1;
          numeric_info.sign := 1;

        ELSE
          operand := NIL;
        CASEND;

        IF operand = NIL THEN
          osp$set_status_condition (cle$expecting_operand, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT evaluate_expression;
        ELSEIF operand^.kind IN $clt$data_kinds [clc$integer, clc$real] THEN
          complete_numeric_operand;
        ELSEIF operand_was_signed THEN
          osp$set_status_abnormal ('CL', cle$arithmetic_operand_not_num, sign_representation, status);
          clp$append_status_value_type (osc$status_parameter_delimiter, operand, status);
          EXIT evaluate_expression;
        IFEND;

        recognize_binary_operator;

      PROCEND evaluate_operand;
?? TITLE := 'evaluate_parenthesized_list', EJECT ??

      PROCEDURE evaluate_parenthesized_list
        (    element_type_description: ^clt$type_description;
             type_description: ^clt$type_description;
             temp_result: ^clt$data_value;
             structure_kind: clt$data_kind;
             element_expansion: clt$list_expansion;
             initial_sub_list_tail: ^clt$data_value;
         VAR list_size {input, output} : clt$list_size;
         VAR result {input, output} : ^clt$data_value);

        VAR
          current_list_node: ^clt$data_value,
          evaluate_list_element: boolean,
          local_numeric_info: clt$numeric_operand_info,
          local_parse: clt$parse_state,
          sub_list_tail: ^clt$data_value;


        IF initial_sub_list_tail = NIL THEN
          current_list_node := result;
        ELSE
          current_list_node := initial_sub_list_tail;
        IFEND;
        evaluate_list_element := (list_size = 0) AND (parse.unit.kind <> clc$lex_right_parenthesis);

        WHILE TRUE DO
          IF evaluate_list_element THEN
            local_parse := parse;
            clp$scan_unnested_sep_lex_unit (clc$ignore_ellipsis, parse);
            local_parse.index_limit := parse.unit_index;
            local_numeric_info.initialized := FALSE;
            evaluate_expression (local_parse, element_type_description, FALSE, element_expansion,
                  local_numeric_info, current_list_node^.element_value, sub_list_tail, status);
            IF NOT status.normal THEN
              determine_structure_status (temp_result, structure_kind, type_description,
                    current_type_description, status);
              EXIT evaluate_expression;
            IFEND;

            IF sub_list_tail = NIL THEN
              list_size := list_size + 1;
            ELSE
              IF sub_list_tail = current_list_node^.element_value THEN
                list_size := list_size + 1;
                sub_list_tail := current_list_node;
              ELSE
                list_size := list_size + clp$count_list_elements (current_list_node^.element_value);
              IFEND;
              current_list_node^.link := current_list_node^.element_value^.link;
              current_list_node^.element_value := current_list_node^.element_value^.element_value;
              current_list_node := sub_list_tail;
            IFEND;

            IF local_parse.unit_is_space THEN
              clp$scan_non_space_lexical_unit (local_parse);
            IFEND;
            IF local_parse.unit_index < local_parse.index_limit THEN
              osp$set_status_condition (cle$expecting_end_of_expression, status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, local_parse, status);
              EXIT evaluate_expression;
            IFEND;

{ check for unspecified list element value

            IF (current_list_node^.element_value <> NIL) AND (current_list_node^.element_value^.kind =
                  clc$unspecified) THEN
              osp$set_status_abnormal ('CL', cle$unspecified_value_for_list, last_dereference_name, status);
              EXIT evaluate_expression;
            IFEND;

            IF parse.unit_is_space THEN
              clp$scan_non_space_lexical_unit (parse);
            IFEND;
          IFEND;

          CASE parse.unit.kind OF
          = clc$lex_right_parenthesis =
            clp$scan_any_lexical_unit (parse);
            recognize_binary_operator;
            RETURN;
          = clc$lex_comma =
            clp$scan_non_space_lexical_unit (parse);
          = clc$lex_end_of_line =
            IF (current_type_description^.kind <> clc$list_type) OR
                  (NOT current_type_description^.list_rest) THEN
              osp$set_status_condition (cle$expecting_rparen_of_list, status);
              EXIT evaluate_expression;
            IFEND;
            recognize_binary_operator;
            RETURN;
          ELSE
            IF NOT parse.previous_unit_is_space THEN
              osp$set_status_condition (cle$expecting_list_elem_sep, status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT evaluate_expression;
            IFEND;
          CASEND;

          clp$make_list_value (work_area, current_list_node^.link);
          IF current_list_node^.link = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;
          current_list_node := current_list_node^.link;
          evaluate_list_element := TRUE;
        WHILEND;

      PROCEND evaluate_parenthesized_list;
?? TITLE := 'evaluate_program_name', EJECT ??

      PROCEDURE evaluate_program_name
        (VAR result: ^clt$data_value;
         VAR result_sub_list_tail: ^clt$data_value);

        VAR
          cobol_name_size: ost$name_size,
          is_cobol_name: boolean,
          is_only_cobol_name: boolean,
          program_name: pmt$program_name,
          program_name_size: clt$string_size,
          saved_parse: clt$parse_state;


        IF recognize_wild_cards THEN
          handle_wild_card_name (result, result_sub_list_tail);
          IF result <> NIL THEN
            RETURN;
          IFEND;
        IFEND;

        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

        saved_parse := parse;

        WHILE (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_name, clc$lex_unsigned_decimal,
              clc$lex_alpha_number, clc$lex_subtract]) AND (parse.unit_index < parse.index_limit) DO
          clp$scan_any_lexical_unit (parse);
        WHILEND;

        IF parse.unit_index > saved_parse.unit_index THEN
          clp$recognize_cobol_name (parse.text^ (saved_parse.unit_index,
                parse.unit_index - saved_parse.unit_index), cobol_name_size, is_only_cobol_name,
                is_cobol_name);
          IF is_cobol_name AND is_only_cobol_name THEN
            #TRANSLATE (osv$lower_to_upper, parse.text^ (saved_parse.unit_index, cobol_name_size),
                  program_name);
            clp$make_program_name_value (program_name, work_area, result);
            IF result = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              EXIT evaluate_expression;
            IFEND;
            recognize_binary_operator;
            RETURN;
          IFEND;
          parse := saved_parse;
        IFEND;

        evaluate_operand (result);
        CASE result^.kind OF

        = clc$cobol_name =
          program_name := result^.cobol_name_value;

        = clc$data_name =
          program_name := result^.data_name_value;

        = clc$keyword =
          program_name := result^.keyword_value;

        = clc$name =
          program_name := result^.name_value;

        = clc$program_name =
          RETURN;

        = clc$string =
          evaluate_string_or_pattern (FALSE, result);
          program_name_size := clp$trimmed_string_size (result^.string_value^);
          IF program_name_size = 0 THEN
            osp$set_status_condition (cle$null_program_name, status);
            EXIT evaluate_expression;
          ELSEIF program_name_size > STRLENGTH (pmt$program_name) THEN
            osp$set_status_abnormal ('CL', cle$program_name_too_long, result^.string_value^, status);
            EXIT evaluate_expression;
          IFEND;
          program_name := result^.string_value^;

        = clc$unspecified =
          RETURN;

        ELSE
          osp$set_status_condition (cle$wrong_kind_of_value, status);
          clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
          clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
          EXIT evaluate_expression;
        CASEND;

        result^.kind := clc$program_name;
        result^.program_name_value := program_name;

      PROCEND evaluate_program_name;
?? TITLE := 'evaluate_range', EJECT ??

{
{ NOTE:
{   Unlike most other expression evaluators, the one for range types assumes
{   that the INDEX_LIMIT field of the CLT$PARSE_STATE designates the end of the
{   expression being evaluated.  This restriction is necessary in order for
{   this evaluator to recognize when its an expression is enclosed in
{   parentheses.
{

      PROCEDURE evaluate_range
        (VAR result: ^clt$data_value);

        VAR
          element_type_description: ^clt$type_description,
          high_value: ^clt$data_value,
          ignore_sub_list_tail: ^clt$data_value,
          local_numeric_info: clt$numeric_operand_info,
          local_parse: clt$parse_state,
          low_value: ^clt$data_value,
          result_conforms_to_element_type: boolean,
          result_conforms_to_type: boolean,
          local_result: ^clt$data_value,
          type_description: ^clt$type_description;

?? NEWTITLE := 'check_for_and_handle_sub_expr', EJECT ??

{
{ PURPOSE:
{   To check whether the range expression is (unnecessarily) parenthesized and
{   if so, to evaluate the sub-expression.  This routine is only called if the
{   expression starts with a left parenthesis.
{
{ NOTE 1:
{   If the expression ends with a right parenthesis that balances the left one
{   it begins with, the expression is treated as a sub-expression by
{   recursively calling evaluate_range to process the sub-expression (with the
{   parentheses removed).  Control is NOT returned to the caller in this case.
{

        PROCEDURE check_for_and_handle_sub_expr;

          VAR
            final_parse: clt$parse_state,
            right_parenthesis_index: clt$expression_text_index;


          clp$scan_bal_paren_lexical_unit (parse);
          IF parse.unit.kind <> clc$lex_right_parenthesis THEN
            RETURN;
          IFEND;
          right_parenthesis_index := parse.unit_index;

          clp$scan_non_space_lexical_unit (parse);
          IF parse.unit_index < parse.index_limit THEN
            RETURN;
          IFEND;
          final_parse := parse;

          parse := local_parse;
          clp$scan_non_space_lexical_unit (parse);
          parse.index_limit := right_parenthesis_index;
          local_parse := parse;
          complete_range;
          IF operator.kind <> clc$not_an_operator THEN
            osp$set_status_abnormal ('CL', cle$expecting_end_of_expression, operator.representation, status);
            EXIT evaluate_expression;
          IFEND;
          IF parse.unit_index < right_parenthesis_index THEN
            osp$set_status_condition (cle$expecting_end_of_expression, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT evaluate_expression;
          IFEND;
          parse := final_parse;
          recognize_binary_operator;

          EXIT evaluate_range;

        PROCEND check_for_and_handle_sub_expr;
?? TITLE := 'complete_range', EJECT ??

        PROCEDURE complete_range;


          IF current_type_description^.range_element_type_description <> NIL THEN
            element_type_description := current_type_description^.range_element_type_description;
          ELSE
            element_type_description := ^unqual_union_type_description;
          IFEND;

          result_conforms_to_type := FALSE;
          result_conforms_to_element_type := FALSE;
          type_description := NIL;
          local_result := NIL;
          operand_type_description := NIL;
          IF parse.unit.kind = clc$lex_name THEN
            check_for_variable_or_function (element_type_description, result_conforms_to_element_type,
                  result_conforms_to_type, type_description, result, ignore_sub_list_tail);
            IF result <> NIL THEN
              IF result_conforms_to_type THEN
                IF (current_type_description^.derived_from_value_kind_spec) THEN
                  convert_fs_file_ref_to_cl_file (result);
                IFEND;
                RETURN;
              IFEND;
              local_result := result;
              IF result_conforms_to_element_type AND (operator.kind = clc$not_an_operator) THEN
                low_value := result;
              IFEND;
            IFEND;
          IFEND;

          IF low_value = NIL THEN
            parse := local_parse;
            clp$scan_operand (clc$ellipsis, parse);
            local_parse.index_limit := parse.unit_index;
            local_numeric_info.initialized := FALSE;
            evaluate_expression (local_parse, element_type_description, FALSE, clc$no_expansion,
                  local_numeric_info, low_value, ignore_sub_list_tail, status);
            IF (NOT status.normal) THEN
              determine_structure_status (local_result, clc$range, type_description, current_type_description,
                    status);
              EXIT evaluate_expression;
            ELSEIF local_parse.unit_index < local_parse.index_limit THEN
              osp$set_status_condition (cle$expecting_end_of_expression, status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, local_parse, status);
              EXIT evaluate_expression;
            IFEND;
          IFEND;

          IF parse.unit_is_space THEN
            clp$scan_non_space_lexical_unit (parse);
          IFEND;

          IF parse.unit.kind = clc$lex_ellipsis THEN

{ check low value for unspecified

            IF (low_value <> NIL) AND (low_value^.kind = clc$unspecified) THEN
              osp$set_status_abnormal ('CL', cle$unspecified_value_for_range, last_dereference_name, status);
              RETURN;
            IFEND;
            clp$scan_non_space_lexical_unit (parse);
            local_numeric_info.initialized := FALSE;
            evaluate_expression (parse, element_type_description, FALSE, clc$no_expansion,
                  local_numeric_info, high_value, ignore_sub_list_tail, status);
            IF NOT status.normal THEN
              determine_structure_status (local_result, clc$range, type_description, current_type_description,
                    status);
              EXIT evaluate_expression;
            IFEND;

{ check high value for unspecified

            IF (high_value <> NIL) AND (high_value^.kind = clc$unspecified) THEN
              osp$set_status_abnormal ('CL', cle$unspecified_value_for_range, last_dereference_name, status);
              RETURN;
            IFEND;
          ELSE

{ IF only one value is given and it is unspecified, then return with result^.kind=clc$unspecified

            IF (low_value <> NIL) AND (low_value^.kind = clc$unspecified) THEN
              RETURN;
            IFEND;
            high_value := low_value;
          IFEND;

          clp$make_range_value (work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;

          result^.low_value := low_value;
          result^.high_value := high_value;

{ This call to recognize_binary_operator is not necessary because
{ evaluate_expression makes the call

{         recognize_binary_operator;

        PROCEND complete_range;
?? OLDTITLE, EJECT ??

        low_value := NIL;

        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

        local_parse := parse;

        IF parse.unit.kind = clc$lex_left_parenthesis THEN
          check_for_and_handle_sub_expr;

{ Control is not returned if the expression is a sub-expression.

          parse := local_parse;
        IFEND;

        complete_range;

      PROCEND evaluate_range;
?? TITLE := 'evaluate_record', EJECT ??

      PROCEDURE evaluate_record
        (VAR result: ^clt$data_value);

        VAR
          field_number: clt$field_number,
          ignore_sub_list_tail: ^clt$data_value;

?? NEWTITLE := 'check_remaining_fields_optional', EJECT ??

        PROCEDURE check_remaining_fields_optional
          (    next_field_number: clt$field_number;
           VAR status: ost$status);


          FOR field_number := next_field_number TO current_type_description^.fields_pdt^.header^.
                number_of_parameters DO
            IF current_type_description^.fields_pdt^.parameters^ [field_number].requirement =
                  clc$required_field THEN
              osp$set_status_abnormal ('CL', cle$required_field_omitted,
                    current_type_description^.fields_pdt^.names^ [field_number].name, status);
              clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
              RETURN;
            IFEND;
          FOREND;

        PROCEND check_remaining_fields_optional;
?? TITLE := 'evaluate_field_list', EJECT ??

        PROCEDURE evaluate_field_list;

          VAR
            fields_evaluation_context: clt$parameter_eval_context,
            fields_parse: clt$parse_state,
            pvt: ^clt$parameter_value_table,
            record_name: clt$type_name;


          IF current_type_description^.name <> NIL THEN
            record_name := current_type_description^.name^;
          ELSE
            record_name := clv$type_kind_names [clc$record_type];
          IFEND;

          fields_parse := parse;
          clp$scan_bal_paren_lexical_unit (parse);
          IF parse.unit_index >= parse.index_limit THEN
            osp$set_status_abnormal ('CL', cle$expecting_rparen_of_flist, record_name, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT evaluate_expression;
          IFEND;
          fields_parse.index_limit := parse.unit_index;
          clp$scan_non_space_lexical_unit (fields_parse);
          clp$scan_any_lexical_unit (parse);

          PUSH pvt: [1 .. current_type_description^.fields_pdt^.header^.number_of_parameters];

          fields_evaluation_context.interpreter_mode := clc$interpret_mode;
          fields_evaluation_context.interactive_origin := FALSE;
          fields_evaluation_context.interaction_style := osc$line_interaction;
          fields_evaluation_context.prompting_requested := FALSE;
          fields_evaluation_context.command_or_function_name := record_name;
          fields_evaluation_context.command_or_function := clc$function;
          fields_evaluation_context.procedure_parameters := FALSE;
          fields_evaluation_context.command_or_function_source := NIL;

          clp$internal_evaluate_params (fields_evaluation_context, current_type_description^.fields_pdt^, NIL,
                fields_parse, work_area, pvt, status);
          IF NOT status.normal THEN
            IF status.condition = cle$expecting_rparen_of_plist THEN
              status.condition := cle$expecting_rparen_of_flist;
            ELSEIF status.condition = cle$only_string_literal_for_par THEN
              status.condition := cle$only_string_literal_for_fld;
              osp$append_status_parameter (osc$status_parameter_delimiter, record_name, status);
            ELSEIF status.condition = cle$param_expr_not_union_type THEN
              status.condition := cle$field_expr_not_union_type;
            ELSEIF status.condition = cle$required_parameter_omitted THEN
              status.condition := cle$required_field_omitted;
              osp$append_status_parameter (osc$status_parameter_delimiter, record_name, status);
            ELSEIF status.condition = cle$required_parameter_unspec THEN
              status.condition := cle$required_field_unspecified;
              osp$append_status_parameter (osc$status_parameter_delimiter, record_name, status);
            ELSEIF status.condition = cle$too_many_parameters THEN
              status.condition := cle$too_many_fields;
              osp$append_status_parameter (osc$status_parameter_delimiter, record_name, status);
            ELSEIF status.condition = cle$unexpected_in_param_list THEN
              status.condition := cle$unexpected_in_field_list;
              osp$append_status_parameter (osc$status_parameter_delimiter, record_name, status);
            ELSEIF status.condition = cle$unknown_parameter_keyword THEN
              status.condition := cle$unknown_field_keyword;
              osp$append_status_parameter (osc$status_parameter_delimiter, record_name, status);
            ELSEIF status.condition = cle$wrong_kind_of_param_value THEN
              status.condition := cle$wrong_kind_of_field_value;
              osp$append_status_parameter (osc$status_parameter_delimiter, record_name, status);
            IFEND;
            EXIT evaluate_expression;
          IFEND;

          FOR field_number := 1 TO current_type_description^.fields_pdt^.header^.number_of_parameters DO
            result^.field_values^ [field_number].value := pvt^ [field_number].value;
          FOREND;

        PROCEND evaluate_field_list;
?? OLDTITLE, EJECT ??

        VAR
          local_numeric_info: clt$numeric_operand_info,
          local_parse: clt$parse_state,
          local_result: ^clt$data_value,
          result_conforms_to_element_type: boolean,
          result_conforms_to_type: boolean,
          type_description: ^clt$type_description;


        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

        local_parse := parse;

        result := NIL;
        result_conforms_to_type := FALSE;
        result_conforms_to_element_type := FALSE;
        operand_type_description := NIL;
        type_description := NIL;

        IF parse.unit.kind = clc$lex_name THEN
          check_for_variable_or_function (^current_type_description^.fields_pdt^.type_descriptions^ [1],
                result_conforms_to_element_type, result_conforms_to_type, type_description, result,
                ignore_sub_list_tail);
          IF (result <> NIL) AND result_conforms_to_type THEN
            RETURN;
          IFEND;
        IFEND;

        local_result := result;

        clp$make_record_value (current_type_description^.fields_pdt^.header^.number_of_parameters, work_area,
              result);
        IF result = NIL THEN
          osp$set_status_condition (cle$work_area_overflow, status);
          EXIT evaluate_expression;
        IFEND;

        FOR field_number := 1 TO current_type_description^.fields_pdt^.header^.number_of_parameters DO
          result^.field_values^ [field_number].name := current_type_description^.fields_pdt^.
                names^ [field_number].name;
          result^.field_values^ [field_number].value := NIL;
        FOREND;

{ If the value is unspecified, the first field is NIL and all fields are checked for 'optional'

        IF result_conforms_to_element_type AND (operator.kind = clc$not_an_operator) THEN
          IF local_result^.kind = clc$unspecified THEN
            check_remaining_fields_optional (1, status);
          ELSE
            result^.field_values^ [1].value := local_result;
            check_remaining_fields_optional (2, status);
          IFEND;
          RETURN;
        IFEND;

        parse := local_parse;
        IF parse.unit.kind = clc$lex_left_parenthesis THEN
          evaluate_field_list;
        ELSE
          local_numeric_info.initialized := FALSE;
          evaluate_expression (parse, ^current_type_description^.fields_pdt^.type_descriptions^ [1], FALSE,
                clc$no_expansion, local_numeric_info, result^.field_values^ [1].value, ignore_sub_list_tail,
                status);
          IF status.normal THEN
            check_remaining_fields_optional (2, status);
          IFEND;
          IF (NOT status.normal) THEN
            determine_structure_status (local_result, clc$record, type_description, current_type_description,
                  status);
            EXIT evaluate_expression;
          IFEND;
        IFEND;

        recognize_binary_operator;

      PROCEND evaluate_record;
?? TITLE := 'evaluate_scu_line_identifier', EJECT ??

      PROCEDURE evaluate_scu_line_identifier
        (VAR result: ^clt$data_value);

        VAR
          line_identifier: clt$scu_line_identifier,
          number: integer,
          saved_parse: clt$parse_state;


        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

        CASE parse.unit.kind OF
        = clc$lex_name =
          ;
        = clc$lex_long_name =
          osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                status);
          EXIT evaluate_expression;
        ELSE
          osp$set_status_condition (cle$wrong_kind_of_value, status);
          clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT evaluate_expression;
        CASEND;

        saved_parse := parse;

      /line_identifier_literal/
        BEGIN
          clp$scan_any_lexical_unit (parse);
          IF parse.unit.kind <> clc$lex_dot THEN
            EXIT /line_identifier_literal/;
          IFEND;
          clp$scan_any_lexical_unit (parse);
          CASE parse.unit.kind OF
          = clc$lex_unsigned_decimal =
            ;
          = clc$lex_name, clc$lex_long_name =
            EXIT /line_identifier_literal/;
          ELSE
            osp$set_status_condition (cle$expecting_sequence_number, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT evaluate_expression;
          CASEND;

          clp$evaluate_unsigned_decimal (parse.text^ (parse.unit_index, parse.unit.size), number, status);
          clp$scan_any_lexical_unit (parse);
          IF NOT status.normal THEN
            EXIT evaluate_expression;
          ELSEIF saved_parse.unit.size > clc$max_scu_modification_name THEN
            osp$set_status_abnormal ('CL', cle$modification_name_too_long, parse.
                  text^ (saved_parse.unit_index, saved_parse.unit.size), status);
            osp$append_status_integer (osc$status_parameter_delimiter, saved_parse.unit.size, 10, FALSE,
                  status);
            EXIT evaluate_expression;
          ELSEIF (number < 1) OR (number > clc$max_scu_sequence_number) THEN
            osp$set_status_condition (cle$sequence_num_out_of_range, status);
            osp$append_status_integer (osc$status_parameter_delimiter, number, 10, FALSE, status);
            EXIT evaluate_expression;
          IFEND;

          #TRANSLATE (osv$lower_to_upper, parse.text^ (saved_parse.unit_index, saved_parse.unit.size),
                line_identifier.modification_name);
          line_identifier.sequence_number := number;
          clp$make_scu_line_id_value (line_identifier, work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;

          recognize_binary_operator;
          RETURN;
        END /line_identifier_literal/;

        parse := saved_parse;


        evaluate_operand (result);

        CASE result^.kind OF
        = clc$scu_line_identifier =
          ;
        = clc$unspecified =
          ;
        ELSE
          osp$set_status_condition (cle$wrong_kind_of_value, status);
          clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
          clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
          EXIT evaluate_expression;
        CASEND;

      PROCEND evaluate_scu_line_identifier;
?? TITLE := 'evaluate_statistic_code', EJECT ??

      PROCEDURE evaluate_statistic_code
        (VAR result: ^clt$data_value);

        VAR
          converted: boolean,
          statistic_code: sft$statistic_code;


        evaluate_operand (result);

        CASE result^.kind OF

        = clc$integer =
          IF (result^.integer_value.value < 0) OR (result^.integer_value.value > sfc$max_statistic_code) THEN
            osp$set_status_condition (cle$statistic_code_out_of_range, status);
            osp$append_status_integer (osc$status_parameter_delimiter, result^.integer_value.value, 16, TRUE,
                  status);
            EXIT evaluate_expression;
          IFEND;
          statistic_code := result^.integer_value.value;

        = clc$name =
          convert_string_to_stat_code (result^.name_value, FALSE, statistic_code, converted);
          IF NOT converted THEN
            osp$set_status_abnormal ('CL', cle$unrecognizable_statist_name, result^.name_value, status);
            EXIT evaluate_expression;
          IFEND;

        = clc$statistic_code =
          RETURN;

        = clc$string =
          convert_string_to_stat_code (result^.string_value^, TRUE, statistic_code, converted);
          IF NOT converted THEN
            osp$set_status_abnormal ('CL', cle$unrecognizable_statist_str, result^.string_value^, status);
            EXIT evaluate_expression;
          IFEND;

        = clc$unspecified =
          RETURN;

        ELSE
          osp$set_status_condition (cle$wrong_kind_of_value, status);
          clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
          clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
          EXIT evaluate_expression;
        CASEND;

        result^.kind := clc$statistic_code;
        result^.statistic_code_value := statistic_code;

      PROCEND evaluate_statistic_code;
?? TITLE := 'evaluate_status', EJECT ??

      PROCEDURE evaluate_status
        (VAR result: ^clt$data_value);


        evaluate_operand (result);

        CASE result^.kind OF

        = clc$status =
          ;

        = clc$unspecified =
          ;

        ELSE
          osp$set_status_condition (cle$wrong_kind_of_value, status);
          clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
          clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
          EXIT evaluate_expression;
        CASEND;

      PROCEND evaluate_status;
?? TITLE := 'evaluate_status_code', EJECT ??

      PROCEDURE evaluate_status_code
        (VAR result: ^clt$data_value);

        VAR
          converted: boolean,
          status_code: ost$status_condition_code;


        evaluate_operand (result);

        CASE result^.kind OF

        = clc$integer =
          IF (result^.integer_value.value < 0) OR (result^.integer_value.value >
                osc$max_status_condition_code) THEN
            osp$set_status_condition (cle$status_code_out_of_range, status);
            osp$append_status_integer (osc$status_parameter_delimiter, result^.integer_value.value, 16, TRUE,
                  status);
            EXIT evaluate_expression;
          IFEND;
          status_code := result^.integer_value.value;

        = clc$name =
          convert_string_to_stat_code (result^.name_value, FALSE, status_code, converted);
          IF NOT converted THEN
            osp$get_status_condition_code (result^.name_value, status_code, status);
            IF (NOT status.normal) OR (status_code = 0) THEN
              IF (clp$trimmed_string_size (result^.name_value) >= 4) AND
                    (result^.name_value (3) = 'E') AND ((result^.name_value (4) = '$') OR
                    (result^.name_value (4) = '#')) THEN
                osp$set_status_abnormal ('CL', cle$unknown_status_code_name, result^.name_value, status);
              ELSE
                osp$set_status_abnormal ('CL', cle$unrecognizable_status_name, result^.name_value, status);
              IFEND;
              EXIT evaluate_expression;
            IFEND;
          IFEND;

        = clc$status_code =
          RETURN;

        = clc$string =
          convert_string_to_stat_code (result^.string_value^, TRUE, status_code, converted);
          IF NOT converted THEN
            osp$set_status_abnormal ('CL', cle$unrecognizable_status_str, result^.string_value^, status);
            EXIT evaluate_expression;
          IFEND;

        = clc$unspecified =
          RETURN;

        ELSE
          osp$set_status_condition (cle$wrong_kind_of_value, status);
          clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
          clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
          EXIT evaluate_expression;
        CASEND;

        result^.kind := clc$status_code;
        result^.status_code_value := status_code;

      PROCEND evaluate_status_code;
?? TITLE := 'evaluate_string_or_pattern', EJECT ??

      PROCEDURE evaluate_string_or_pattern
        (    finalize_result: boolean;
         VAR result {input, output} : ^clt$data_value);

?? NEWTITLE := 'complete_string_or_pattern', EJECT ??

        PROCEDURE complete_string_or_pattern;

          VAR
            pattern_string: ^clt$string_value;


          CASE result^.kind OF

          = clc$string =
            IF current_type_description^.kind = clc$string_type THEN
              IF STRLENGTH (result^.string_value^) > current_type_description^.max_string_size THEN
                osp$set_status_condition (cle$string_value_too_long, status);
                osp$append_status_integer (osc$status_parameter_delimiter,
                      current_type_description^.max_string_size, 10, FALSE, status);
                osp$append_status_integer (osc$status_parameter_delimiter, STRLENGTH (result^.string_value^),
                      10, FALSE, status);
                clp$append_status_string (osc$status_parameter_delimiter, result^.string_value^, status);
                EXIT evaluate_expression;
              ELSEIF STRLENGTH (result^.string_value^) < current_type_description^.min_string_size THEN
                osp$set_status_condition (cle$string_value_too_short, status);
                osp$append_status_integer (osc$status_parameter_delimiter,
                      current_type_description^.min_string_size, 10, FALSE, status);
                osp$append_status_integer (osc$status_parameter_delimiter, STRLENGTH (result^.string_value^),
                      10, FALSE, status);
                clp$append_status_string (osc$status_parameter_delimiter, result^.string_value^, status);
                EXIT evaluate_expression;
              IFEND;
              EXIT evaluate_string_or_pattern;
            IFEND;

            pattern_string := result^.string_value;
            clp$make_value (clc$string_pattern, work_area, result);
            IF result = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              EXIT evaluate_expression;
            IFEND;
            clp$sp_string_literal (pattern_string, TRUE, work_area, result^.string_pattern_value, status);
            IF NOT status.normal THEN
              EXIT evaluate_expression;
            IFEND;

          = clc$string_pattern =
            IF current_type_description^.kind = clc$string_pattern_type THEN
              EXIT evaluate_string_or_pattern;
            IFEND;
            osp$set_status_condition (cle$wrong_kind_of_value, status);
            clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
            clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
            EXIT evaluate_expression;

          = clc$unspecified =
            ;

          ELSE
            osp$set_status_condition (cle$wrong_kind_of_value, status);
            clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
            clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
            EXIT evaluate_expression;
          CASEND;

        PROCEND complete_string_or_pattern;
?? TITLE := 'handle_concatenate', EJECT ??

        PROCEDURE handle_concatenate
          (VAR result: ^clt$data_value);

          VAR
            current_operator_representation: clt$operator_representation,
            left_operand: ^clt$data_value,
            result_size: integer,
            right_operand: ^clt$data_value,
            right_string: ^clt$string_value;

?? NEWTITLE := 'convert_right_operand_to_string', EJECT ??

          PROCEDURE convert_right_operand_to_string;

            VAR
              representation: ^clt$data_representation,
              request: clt$convert_to_string_request,
              right_string_size: ^clt$string_size,
              string_count: ^clt$data_representation_count;


            right_string := NIL;

            request.initial_indentation := 0;
            request.continuation_indentation := 0;
            request.max_string := clc$max_string_size;
            request.include_advanced_items := TRUE;
            request.include_hidden_items := TRUE;
            request.kind := clc$convert_data_value;
            request.representation_option := clc$data_elem_representation;
            request.value := right_operand;
            clp$internal_convert_to_string (request, work_area, representation, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            NEXT string_count IN representation;
            IF string_count^ <> 1 THEN
              RETURN;
            IFEND;

            NEXT right_string_size IN representation;
            NEXT right_string: [right_string_size^] IN representation;

          PROCEND convert_right_operand_to_string;
?? OLDTITLE, EJECT ??

          CASE result^.kind OF
          = clc$string =
            ;
          = clc$string_pattern =
            ;
          = clc$unspecified =
            osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, last_dereference_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, operator.representation, status);
            EXIT evaluate_expression;
          ELSE
            osp$set_status_condition (cle$concat_left_op_not_str, status);
            clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
            EXIT evaluate_expression;
          CASEND;

          WHILE operator.kind = clc$string_operator DO
            current_operator_representation := operator.representation;

            CASE parse.unit.kind OF
            = clc$lex_add, clc$lex_subtract =
              right_operand := NIL;
              evaluate_number (FALSE, right_operand);
            ELSE
              evaluate_operand (right_operand);
              IF operator.kind = clc$arithmetic_operator THEN
                evaluate_number (FALSE, right_operand);
              IFEND;
            CASEND;

            CASE right_operand^.kind OF
            = clc$string =
              right_string := right_operand^.string_value;
            = clc$string_pattern =
              right_string := NIL;
            = clc$unspecified =
              osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, last_dereference_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, current_operator_representation,
                    status);
              EXIT evaluate_expression;
            ELSE
              convert_right_operand_to_string;
              IF right_string = NIL THEN
                osp$set_status_condition (cle$concat_right_op_not_str, status);
                clp$append_status_value_type (osc$status_parameter_delimiter, right_operand, status);
                EXIT evaluate_expression;
              IFEND;
            CASEND;

            left_operand := result;

            IF (left_operand^.kind = clc$string) AND (right_string <> NIL) THEN
              result_size := STRLENGTH (left_operand^.string_value^) + STRLENGTH (right_string^);
              IF result_size > clc$max_string_size THEN
                osp$set_status_condition (cle$concatenated_str_too_long, status);
                EXIT evaluate_expression;
              IFEND;
              clp$make_sized_string_value (result_size, work_area, result);
              IF result = NIL THEN
                osp$set_status_condition (cle$work_area_overflow, status);
                EXIT evaluate_expression;
              IFEND;
              result^.string_value^ (1, STRLENGTH (left_operand^.string_value^)) :=
                    left_operand^.string_value^;
              result^.string_value^ (STRLENGTH (left_operand^.string_value^) + 1,
                    STRLENGTH (right_string^)) := right_string^;

            ELSE
              clp$make_value (clc$string_pattern, work_area, result);
              IF result = NIL THEN
                osp$set_status_condition (cle$work_area_overflow, status);
                EXIT evaluate_expression;
              IFEND;
              IF left_operand^.kind = clc$string THEN
                clp$sp_string_concat_pattern (left_operand^.string_value,
                      right_operand^.string_pattern_value, work_area, result^.string_pattern_value, status);
              ELSEIF right_string <> NIL THEN
                clp$sp_pattern_concat_string (left_operand^.string_pattern_value, right_string, work_area,
                      result^.string_pattern_value, status);
              ELSE
                clp$sp_pattern_concat_pattern (left_operand^.string_pattern_value,
                      right_operand^.string_pattern_value, work_area, result^.string_pattern_value, status);
              IFEND;
              IF NOT status.normal THEN
                EXIT evaluate_expression;
              IFEND;
            IFEND;

          WHILEND;

        PROCEND handle_concatenate;
?? OLDTITLE, EJECT ??

        IF result = NIL THEN
          evaluate_operand (result);
        IFEND;

        IF (current_type_description^.kind = clc$string_type) AND current_type_description^.literal AND
              ((NOT operand_is_string_literal) OR (operator.kind = clc$string_operator)) THEN
          osp$set_status_condition (cle$only_string_literal_allowed, status);
          EXIT evaluate_expression;
        IFEND;

        IF operator.kind = clc$string_operator THEN
          handle_concatenate (result);
        IFEND;

        IF finalize_result AND (NOT evaluating_sub_expression) THEN
          complete_string_or_pattern;
        IFEND;

      PROCEND evaluate_string_or_pattern;
?? TITLE := 'evaluate_time_increment', EJECT ??

      PROCEDURE evaluate_time_increment
        (VAR result: ^clt$data_value);

        VAR
          right_operand: ^clt$data_value,
          time_increment: pmt$time_increment;

?? NEWTITLE := 'combine_time_increments', EJECT ??

        PROCEDURE combine_time_increments;

?? NEWTITLE := 'add_to_time_increment', EJECT ??

          PROCEDURE add_to_time_increment;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'arithmetic_condition_handler', EJECT ??

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


              IF (condition.selector = pmc$system_conditions) AND
                    (pmc$arithmetic_overflow IN condition.system_conditions) THEN
                osp$set_status_condition (pme$compute_overflow, status);
                EXIT evaluate_expression;
              IFEND;

              pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

            PROCEND arithmetic_condition_handler;
?? OLDTITLE, EJECT ??

            osp$establish_condition_handler (^arithmetic_condition_handler, FALSE);
*IFEND

            result^.time_increment_value^.year := result^.time_increment_value^.year +
                  right_operand^.time_increment_value^.year;
            result^.time_increment_value^.month := result^.time_increment_value^.month +
                  right_operand^.time_increment_value^.month;
            result^.time_increment_value^.day := result^.time_increment_value^.day +
                  right_operand^.time_increment_value^.day;
            result^.time_increment_value^.hour := result^.time_increment_value^.hour +
                  right_operand^.time_increment_value^.hour;
            result^.time_increment_value^.minute := result^.time_increment_value^.minute +
                  right_operand^.time_increment_value^.minute;
            result^.time_increment_value^.second := result^.time_increment_value^.second +
                  right_operand^.time_increment_value^.second;
            result^.time_increment_value^.millisecond := result^.time_increment_value^.millisecond +
                  right_operand^.time_increment_value^.millisecond;

          PROCEND add_to_time_increment;
?? TITLE := 'subtract_from_time_increment', EJECT ??

          PROCEDURE subtract_from_time_increment;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'arithmetic_condition_handler', EJECT ??

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


              IF (condition.selector = pmc$system_conditions) AND
                    (pmc$arithmetic_overflow IN condition.system_conditions) THEN
                osp$set_status_condition (pme$compute_overflow, status);
                EXIT evaluate_expression;
              IFEND;

              pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

            PROCEND arithmetic_condition_handler;
?? OLDTITLE, EJECT ??

            osp$establish_condition_handler (^arithmetic_condition_handler, FALSE);
*IFEND


            result^.time_increment_value^.year := result^.time_increment_value^.year -
                  right_operand^.time_increment_value^.year;
            result^.time_increment_value^.month := result^.time_increment_value^.month -
                  right_operand^.time_increment_value^.month;
            result^.time_increment_value^.day := result^.time_increment_value^.day -
                  right_operand^.time_increment_value^.day;
            result^.time_increment_value^.hour := result^.time_increment_value^.hour -
                  right_operand^.time_increment_value^.hour;
            result^.time_increment_value^.minute := result^.time_increment_value^.minute -
                  right_operand^.time_increment_value^.minute;
            result^.time_increment_value^.second := result^.time_increment_value^.second -
                  right_operand^.time_increment_value^.second;
            result^.time_increment_value^.millisecond := result^.time_increment_value^.millisecond -
                  right_operand^.time_increment_value^.millisecond;

          PROCEND subtract_from_time_increment;
?? OLDTITLE, EJECT ??

          VAR
            current_operator: clt$operator;


          REPEAT
            IF parse.unit.kind = clc$lex_left_parenthesis THEN
              osp$set_status_abnormal ('CL', cle$expecting_time_incr_operand, current_operator.representation,
                    status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT evaluate_expression;
            IFEND;

            current_operator := operator;

            evaluate_operand (right_operand);

            CASE right_operand^.kind OF
            = clc$time_increment =
              ;
            = clc$unspecified =
              osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, last_dereference_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, current_operator.representation,
                    status);
              EXIT evaluate_expression;
            ELSE
              osp$set_status_abnormal ('CL', cle$expecting_time_incr_operand, current_operator.representation,
                    status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT evaluate_expression;
            CASEND;

            IF current_operator.arithmetic_kind = clc$lex_add THEN
              add_to_time_increment;
            ELSE
              subtract_from_time_increment;
            IFEND;

{ This is commented out in order to prevent clobbering of LAST_DEREFERENCE_NAME.
{           RESET work_area TO right_operand;

          UNTIL (operator.kind <> clc$arithmetic_operator) OR
                (NOT (operator.arithmetic_kind IN $clt$lexical_unit_kinds [clc$lex_add, clc$lex_subtract]));

        PROCEND combine_time_increments;
?? TITLE := 'evaluate_date_time_difference', EJECT ??

        PROCEDURE evaluate_date_time_difference;

          VAR
            operator_representation: clt$operator_representation;


          IF (operator.kind <> clc$arithmetic_operator) OR (operator.arithmetic_kind <> clc$lex_subtract) THEN
            osp$set_status_condition (cle$expecting_date_time_subtrct, status);
            IF operator.kind = clc$not_an_operator THEN
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            ELSE
              osp$append_status_parameter (osc$status_parameter_delimiter, operator.representation, status);
            IFEND;
            EXIT evaluate_expression;
          ELSEIF parse.unit.kind = clc$lex_left_parenthesis THEN
            osp$set_status_abnormal ('CL', cle$expecting_date_time_operand, operator_representation, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT evaluate_expression;
          IFEND;

          operator_representation := operator.representation;

          evaluate_operand (right_operand);

          CASE right_operand^.kind OF
          = clc$date_time =
            ;
          = clc$unspecified =
            osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, last_dereference_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, operator_representation, status);
            EXIT evaluate_expression;
          ELSE
            osp$set_status_abnormal ('CL', cle$expecting_date_time_operand, operator.representation, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT evaluate_expression;
          CASEND;

          pmp$compute_date_time_increment (right_operand^.date_time_value.value,
                result^.date_time_value.value, time_increment, status);
          IF NOT status.normal THEN
            EXIT evaluate_expression;
          IFEND;

{ This is commented out in order to prevent clobbering of LAST_DEREFERENCE_NAME.
{         RESET work_area TO result;

          clp$make_time_increment_value (^time_increment, work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;

        PROCEND evaluate_date_time_difference;
?? TITLE := 'evaluate_time_zone_difference', EJECT ??

        PROCEDURE evaluate_time_zone_difference;

?? NEWTITLE := 'subtract_time_zones', EJECT ??

          PROCEDURE subtract_time_zones;

            CONST
              hours_per_day = 24,
              minutes_per_hour = 60;


            time_increment.year := 0;
            time_increment.month := 0;
            time_increment.day := 0;
            time_increment.hour := (result^.time_zone_value.hours_from_gmt +
                  $INTEGER (result^.time_zone_value.daylight_saving_time)) -
                  (right_operand^.time_zone_value.hours_from_gmt +
                  $INTEGER (right_operand^.time_zone_value.daylight_saving_time));
            time_increment.minute := result^.time_zone_value.minutes_offset -
                  right_operand^.time_zone_value.minutes_offset;
            time_increment.second := 0;
            time_increment.millisecond := 0;

            time_increment.hour := (time_increment.hour + (time_increment.minute DIV minutes_per_hour)) MOD
                  hours_per_day;
            time_increment.minute := time_increment.minute MOD minutes_per_hour;

          PROCEND subtract_time_zones;
?? OLDTITLE, EJECT ??

          VAR
            operator_representation: clt$operator_representation;


          IF (operator.kind <> clc$arithmetic_operator) OR (operator.arithmetic_kind <> clc$lex_subtract) THEN
            osp$set_status_condition (cle$expecting_time_zone_subtrct, status);
            IF operator.kind = clc$not_an_operator THEN
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            ELSE
              osp$append_status_parameter (osc$status_parameter_delimiter, operator.representation, status);
            IFEND;
            EXIT evaluate_expression;
          ELSEIF parse.unit.kind = clc$lex_left_parenthesis THEN
            osp$set_status_abnormal ('CL', cle$expecting_time_zone_operand, operator_representation, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT evaluate_expression;
          IFEND;

          operator_representation := operator.representation;

          evaluate_operand (right_operand);

          CASE right_operand^.kind OF
          = clc$time_zone =
            ;
          = clc$unspecified =
            osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, last_dereference_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, operator_representation, status);
            EXIT evaluate_expression;
          ELSE
            osp$set_status_abnormal ('CL', cle$expecting_time_zone_operand, operator_representation, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT evaluate_expression;
          CASEND;

          subtract_time_zones;

{ This is commented out in order to prevent clobbering of LAST_DEREFERENCE_NAME.
{         RESET work_area TO result;

          clp$make_time_increment_value (^time_increment, work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;

        PROCEND evaluate_time_zone_difference;
?? OLDTITLE, EJECT ??

        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

        CASE parse.unit.kind OF

        = clc$lex_name, clc$lex_long_name =
          evaluate_operand (result);
          CASE result^.kind OF

          = clc$date_time =
            evaluate_date_time_difference;

          = clc$time_increment =
            IF (operator.kind = clc$arithmetic_operator) AND (operator.arithmetic_kind IN
                  $clt$lexical_unit_kinds [clc$lex_add, clc$lex_subtract]) THEN
              combine_time_increments;
            IFEND;

          = clc$time_zone =
            evaluate_time_zone_difference;

          = clc$unspecified =
            IF (operator.kind = clc$arithmetic_operator) AND (operator.arithmetic_kind IN
                  $clt$lexical_unit_kinds [clc$lex_add, clc$lex_subtract]) THEN
              osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, last_dereference_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, operator.representation, status);
              EXIT evaluate_expression;
            IFEND;

          ELSE
            osp$set_status_condition (cle$wrong_kind_of_value, status);
            clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
            clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
            EXIT evaluate_expression;
          CASEND;

        = clc$lex_unsigned_decimal, clc$lex_left_parenthesis, clc$lex_subtract, clc$lex_colon, clc$lex_dot =
          time_increment.year := 0;
          time_increment.month := 0;
          time_increment.day := 0;
          time_increment.hour := 0;
          time_increment.minute := 0;
          time_increment.second := 0;
          time_increment.millisecond := 0;
          clp$make_time_increment_value (^time_increment, work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;
          evaluate_date_time_literal (result, NIL);

        ELSE
          osp$set_status_condition (cle$expecting_time_incr_expr, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT evaluate_expression;
        CASEND;

      PROCEND evaluate_time_increment;
?? TITLE := 'evaluate_time_zone', EJECT ??

      PROCEDURE evaluate_time_zone
        (VAR result: ^clt$data_value);

?? NEWTITLE := 'evaluate_time_zone_literal', EJECT ??

        PROCEDURE evaluate_time_zone_literal;

          VAR
            component: integer,
            start_index: clt$string_index,
            time_zone: ost$time_zone;

?? NEWTITLE := 'evaluate_dst_expression', EJECT ??

          PROCEDURE evaluate_dst_expression;

            VAR
              value: clt$boolean;


            clp$scan_non_space_lexical_unit (parse);

            clp$evaluate_boolean_expression (work_area, parse, value, status);
            IF NOT status.normal THEN
              EXIT evaluate_expression;
            IFEND;

            IF parse.unit.kind <> clc$lex_right_parenthesis THEN
              osp$set_status_condition (cle$expecting_rparen_of_subexpr, status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT evaluate_expression;
            IFEND;

            time_zone.daylight_saving_time := value.value;

          PROCEND evaluate_dst_expression;
?? TITLE := 'evaluate_dst_keyword', EJECT ??

          PROCEDURE evaluate_dst_keyword;

            VAR
              keyword: clt$keyword;


            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), keyword);
            IF (keyword = 'DAYLIGHT_SAVING_TIME') OR (keyword = 'DST') THEN
              time_zone.daylight_saving_time := TRUE;
            ELSEIF (keyword = 'STANDARD_TIME') OR (keyword = 'ST') THEN
              time_zone.daylight_saving_time := FALSE;
            ELSE
              unrecognizable;
            IFEND;

          PROCEND evaluate_dst_keyword;
?? TITLE := 'evaluate_integer_expression', EJECT ??

          PROCEDURE evaluate_integer_expression;

            VAR
              value: clt$integer;


            clp$scan_non_space_lexical_unit (parse);

            clp$evaluate_integer_expression (clc$min_integer, clc$max_integer, work_area, parse, value,
                  status);
            IF NOT status.normal THEN
              EXIT evaluate_expression;
            IFEND;

            IF parse.unit.kind <> clc$lex_right_parenthesis THEN
              osp$set_status_condition (cle$expecting_rparen_of_subexpr, status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT evaluate_expression;
            IFEND;

            component := value.value;

          PROCEND evaluate_integer_expression;
?? TITLE := 'evaluate_signed_decimal', EJECT ??

          PROCEDURE evaluate_signed_decimal;

            VAR
              negative: boolean;


            negative := parse.unit.kind = clc$lex_subtract;

            clp$scan_any_lexical_unit (parse);

            evaluate_unsigned_decimal;

            IF negative THEN
              component := -component;
            IFEND;

          PROCEND evaluate_signed_decimal;
?? TITLE := 'evaluate_unsigned_decimal', EJECT ??

          PROCEDURE evaluate_unsigned_decimal;


            clp$evaluate_unsigned_decimal (parse.text^ (parse.unit_index, parse.unit.size), component,
                  status);
            IF NOT status.normal THEN
              EXIT evaluate_expression;
            IFEND;

          PROCEND evaluate_unsigned_decimal;
?? TITLE := 'impossible', EJECT ??

          PROCEDURE impossible;


            osp$set_status_abnormal ('CL', cle$impossible_time_zone, parse.
                  text^ (start_index, parse.unit_index - start_index), status);
            EXIT evaluate_expression;

          PROCEND impossible;
?? TITLE := 'unrecognizable', EJECT ??

          PROCEDURE unrecognizable;


            osp$set_status_abnormal ('CL', cle$unrecognizable_time_zone, parse.
                  text^ (start_index, parse.index_limit - start_index), status);
            EXIT evaluate_expression;

          PROCEND unrecognizable;
?? OLDTITLE, EJECT ??

          start_index := parse.unit_index;

{ Handle hours_from_gmt (Greenwich Mean Time) component.

          CASE parse.unit.kind OF
          = clc$lex_left_parenthesis =
            evaluate_integer_expression;
          = clc$lex_unsigned_decimal =
            evaluate_unsigned_decimal;
          = clc$lex_add, clc$lex_subtract =
            evaluate_signed_decimal;
          ELSE
            unrecognizable;
          CASEND;
          IF (component < LOWERVALUE (time_zone.hours_from_gmt)) OR
                (component > UPPERVALUE (time_zone.hours_from_gmt)) THEN
            impossible;
          IFEND;
          time_zone.hours_from_gmt := component;
          clp$scan_any_lexical_unit (parse);

{ Handle minutes_offset component.

          IF parse.unit.kind = clc$lex_colon THEN
            clp$scan_any_lexical_unit (parse);
            CASE parse.unit.kind OF
            = clc$lex_left_parenthesis =
              evaluate_integer_expression;
            = clc$lex_unsigned_decimal =
              evaluate_unsigned_decimal;
            = clc$lex_add, clc$lex_subtract =
              evaluate_signed_decimal;
            ELSE
              unrecognizable;
            CASEND;
            IF (component < LOWERVALUE (time_zone.minutes_offset)) OR
                  (component > UPPERVALUE (time_zone.minutes_offset)) THEN
              impossible;
            IFEND;
            time_zone.minutes_offset := component;
            clp$scan_any_lexical_unit (parse);
          ELSE
            time_zone.minutes_offset := 0;
          IFEND;

{ Handle daylight_saving_time component.

          IF parse.unit.kind = clc$lex_dot THEN
            clp$scan_any_lexical_unit (parse);
            CASE parse.unit.kind OF
            = clc$lex_left_parenthesis =
              evaluate_dst_expression;
            = clc$lex_name, clc$lex_long_name =
              evaluate_dst_keyword;
            ELSE
              unrecognizable;
            CASEND;
            clp$scan_any_lexical_unit (parse);
          ELSE
            time_zone.daylight_saving_time := FALSE;
          IFEND;


          clp$make_time_zone_value (time_zone, work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;

          recognize_binary_operator;

        PROCEND evaluate_time_zone_literal;
?? OLDTITLE, EJECT ??

        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

        CASE parse.unit.kind OF

        = clc$lex_name, clc$lex_long_name =
          evaluate_operand (result);
          CASE result^.kind OF
          = clc$time_zone =
            ;
          = clc$unspecified =
            ;
          ELSE
            osp$set_status_condition (cle$wrong_kind_of_value, status);
            clp$append_status_type_desc (osc$status_parameter_delimiter, current_type_description, status);
            clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
            EXIT evaluate_expression;
          CASEND;

        = clc$lex_unsigned_decimal, clc$lex_add, clc$lex_subtract, clc$lex_left_parenthesis, clc$lex_colon,
              clc$lex_dot =
          evaluate_time_zone_literal;

        ELSE
          osp$set_status_condition (cle$expecting_time_zone_expr, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT evaluate_expression;
        CASEND;

      PROCEND evaluate_time_zone;
?? TITLE := 'evaluate_type_specification', EJECT ??

      PROCEDURE evaluate_type_specification
        (VAR result: ^clt$data_value);

        VAR
          type_specification: ^clt$type_specification;


        clp$internal_gen_type_spec (osc$null_name, TRUE, NIL, NIL, work_area, parse, type_specification,
              status);
        IF NOT status.normal THEN
          EXIT evaluate_expression;
        IFEND;

        IF type_specification = NIL THEN
          clp$make_unspecified_value (work_area, result);
        ELSE
          clp$make_type_spec_value (type_specification, work_area, result);
        IFEND;
        IF result = NIL THEN
          osp$set_status_condition (cle$work_area_overflow, status);
          EXIT evaluate_expression;
        IFEND;

        recognize_binary_operator;

      PROCEND evaluate_type_specification;
?? TITLE := 'evaluate_union', EJECT ??

{
{ NOTE:
{   Unlike most other expression evaluators, the one for union (ANY) types
{   assumes that the INDEX_LIMIT field of the CLT$PARSE_STATE designates the
{   end of the expression being evaluated.  This restriction is necessary in
{   order for this evaluator to distinguish between the myriad possible types
{   of expressions, particularly those involving lists.
{

      PROCEDURE evaluate_union
        (VAR result: ^clt$data_value);

        VAR
          evaluate_as_standard_type: boolean,
          i: clt$union_member_number,
          kinds: clt$type_kinds,
          list_type_description: ^clt$type_description,
          local_numeric_info: clt$numeric_operand_info,
          numeric_union_type_description: clt$type_description,
          saved_parse: clt$parse_state,
          tried_numeric_evaluate: boolean,
          try_numeric_evaluate: boolean,
          type_conformance: clt$type_conformance;

?? NEWTITLE := 'check_for_and_handle_list', EJECT ??

{
{ PURPOSE:
{   To check whether the form of the expression matches that of a parenthesized
{   list and if so, to evaluate it as such.  This routine is only called if the
{   expression begins with a left parenthesis.
{
{ NOTE 1:
{   The check is made by determining whether the expression ends with a right
{   parenthesis that balances the left one it begins with.  If so, a further
{   check is made to determine whether a list element separator (comma or
{   space) can be found withn the parentheses.  If so, the expression is
{   considered to be a list.  During this analysis special allowance is made
{   for the logical operators (NOT, AND, OR and XOR) because of their need for
{   surrounding spaces.
{
{ NOTE 2:
{   If the expression is determined to be a list, control is NOT returned to
{   the caller.
{
{ NOTE 3:
{   If the expression is determined to be "unnecessarily" parenthesized, i.e.
{   is enclosed in a pair of parentheses but is not a list, evaluate_union is
{   recursively called to process the sub-expression (with the parentheses
{   removed.  Control is NOT returned to the caller in this case.
{

        PROCEDURE check_for_and_handle_list;

          VAR
            empty_list: boolean,
            final_parse: clt$parse_state,
            ignore_list_size: clt$list_size,
            right_parenthesis_index: clt$expression_text_index;


          clp$scan_bal_paren_lexical_unit (parse);
          IF parse.unit.kind <> clc$lex_right_parenthesis THEN
            RETURN;
          IFEND;
          right_parenthesis_index := parse.unit_index;
          empty_list := parse.previous_non_space_unit.kind = clc$lex_left_parenthesis;

          clp$scan_non_space_lexical_unit (parse);
          IF parse.unit_index < parse.index_limit THEN
            RETURN;
          IFEND;
          final_parse := parse;

        /is_list/
          BEGIN
            IF NOT empty_list THEN
              parse := saved_parse;
              clp$scan_non_space_lexical_unit (parse);
              IF recognize_not_operator () THEN
                EXIT /is_list/;
              IFEND;

              clp$scan_unnested_sep_lex_unit (clc$ignore_ellipsis, parse);
              IF parse.unit_is_space THEN
                clp$scan_non_space_lexical_unit (parse);
              IFEND;
              IF parse.unit_index >= right_parenthesis_index THEN
                EXIT /is_list/;
              IFEND;

              recognize_binary_operator;
              IF (operator.kind <> clc$not_an_operator) OR (NOT (parse.previous_unit_is_space OR
                    (parse.unit.kind = clc$lex_comma))) THEN
                EXIT /is_list/;
              IFEND;
            IFEND;

{ At this point the expression is known to be a (possibly empty) list.

            parse := saved_parse;
            clp$make_list_value (work_area, result);
            IF result = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              EXIT evaluate_expression;
            IFEND;
            ignore_list_size := 0;
            clp$scan_non_space_lexical_unit (parse);
            evaluate_parenthesized_list (current_type_description, NIL, NIL, clc$list, clc$no_expansion, NIL,
                  ignore_list_size, result);

            EXIT evaluate_union;
          END /is_list/;

{ At this point it is known that a pair of parentheses surround the expression
{ but that the expression is not a list, i.e. the expression is unnecessarily
{ parenthesized.  Therefore evaluate_union is called recursively to process the
{ expression with the parentheses removed.

          parse := saved_parse;
          clp$scan_non_space_lexical_unit (parse);
          parse.index_limit := right_parenthesis_index;
          evaluate_union (result);
          parse := final_parse;
          recognize_binary_operator;

          EXIT evaluate_union;

        PROCEND check_for_and_handle_list;
?? TITLE := 'check_for_solely_name_deref', EJECT ??

{
{ PURPOSE:
{   To check whether the expression consists solely of a reference to a
{   variable or function.
{

        PROCEDURE check_for_solely_name_deref;

          VAR
            ignore_sub_list_tail: ^clt$data_value,
            initial_path: ^fst$file_reference,
            local_parse: clt$parse_state;


        /check/
          BEGIN
            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);

            local_parse := parse;
            clp$scan_any_lexical_unit (parse);
            dereference_name (name, result);
            IF NOT status.normal THEN
              EXIT evaluate_expression;
            ELSEIF result = NIL THEN
              EXIT /check/;
            IFEND;

*IF NOT $true(osv$unix)
*IF NOT $true(osv$unix)
            IF ((result^.kind = clc$name) OR (result^.kind = clc$file)) AND
                  (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_dot, clc$lex_concatenate]) THEN
*ELSE
            IF (result^.kind IN $clt$data_kinds [clc$nos_ve_file, clc$unix_file, clc$name]) AND
                  (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_dot, clc$lex_divide,
                  clc$lex_concatenate]) THEN
*IFEND
              IF result^.kind = clc$name THEN
                parse := local_parse;
              IFEND;
*IF NOT $true(osv$unix)
              evaluate_file (result, ignore_sub_list_tail);
*ELSE
              evaluate_file (clc$file = clc$unix_file, result, ignore_sub_list_tail);
*IFEND
              IF NOT status.normal THEN
                EXIT /check/;
              IFEND;
*IF NOT $true(osv$unix)
            ELSEIF result^.kind = clc$file THEN
*ELSE
            ELSEIF result^.kind = clc$nos_ve_file THEN
*IFEND
              IF current_type_description^.derived_from_value_kind_spec THEN
                initial_path := result^.file_value;
*IF NOT $true(osv$unix)
                clp$complete_file_ref_eval (FALSE, FALSE, TRUE, initial_path, parse, work_area, result,
                      ignore_sub_list_tail, status);
*ELSE
                clp$complete_file_ref_eval (FALSE, FALSE, FALSE, TRUE, initial_path, parse, work_area, result,
                      ignore_sub_list_tail, status);
*IFEND
                IF NOT status.normal THEN
                  EXIT /check/;
                IFEND;
              IFEND;
              recognize_binary_operator;
            ELSE
*IFEND
              recognize_binary_operator;
*IF NOT $true(osv$unix)
            IFEND;
*IFEND

            IF (operator.kind = clc$not_an_operator) AND (parse.unit_index >= parse.index_limit) THEN
              RETURN;
            IFEND;
          END /check/;

          result := NIL;
          parse := saved_parse;

        PROCEND check_for_solely_name_deref;
?? TITLE := 'check_for_and_handle_range', EJECT ??

{
{ PURPOSE:
{   To check whether the form of the expression matches that of a range and if
{   so, to evaluate it as such.
{
{ NOTE 1:
{   The check is made by looking for an unnested ellipsis within the expression.
{   If one is found, the expression is considered to be a range.  During this
{   analysis special allowance is made for the logical operators (NOT, AND, OR
{   and XOR) because of their need for surrounding spaces.
{
{ NOTE 2:
{   If the expression is determined to be a range, control is NOT returned to
{   the caller.
{

        PROCEDURE check_for_and_handle_range;


          clp$scan_operand (clc$ellipsis, parse);

          IF (parse.unit_index >= parse.index_limit) OR (parse.unit.kind <> clc$lex_ellipsis) THEN
            RETURN;
          IFEND;

          clp$make_range_value (work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;

          saved_parse.index_limit := parse.unit_index;
          local_numeric_info.initialized := FALSE;
          evaluate_expression (saved_parse, current_type_description, FALSE, clc$no_expansion,
                local_numeric_info, result^.low_value, ignore_sub_list_tail, status);
          IF NOT status.normal THEN

{ Do not evaluate expression as a range.

            saved_parse.index_limit := parse.index_limit;
            RETURN;
          IFEND;

*IF $true(osv$unix)
{ Check if the ellipsis was eaten up as part of a unix file reference.
{ If so, do not evaluate expression as a range.

          IF (saved_parse.unit_index = saved_parse.index_limit) AND
                (saved_parse.previous_non_space_unit.kind = clc$lex_divide) THEN
            saved_parse := parse_before_handle_range;
            RETURN;
          IFEND;
*IFEND

          IF saved_parse.unit_is_space THEN
            clp$scan_non_space_lexical_unit (saved_parse);
          IFEND;
          IF saved_parse.unit_index < saved_parse.index_limit THEN
            osp$set_status_condition (cle$expecting_end_of_expression, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, saved_parse, status);
            EXIT evaluate_expression;
          IFEND;

          clp$scan_non_space_lexical_unit (parse);
          local_numeric_info.initialized := FALSE;
          evaluate_expression (parse, current_type_description, FALSE, clc$no_expansion,
                local_numeric_info, result^.high_value, ignore_sub_list_tail, status);
          IF NOT status.normal THEN

{ Do not evaluate expression as a range.

            RETURN;
          IFEND;
          IF parse.unit_is_space THEN
            clp$scan_non_space_lexical_unit (parse);
          IFEND;
          IF parse.unit_index < parse.index_limit THEN
            osp$set_status_condition (cle$expecting_end_of_expression, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT evaluate_expression;
          IFEND;

          EXIT evaluate_union;

        PROCEND check_for_and_handle_range;
?? OLDTITLE, EJECT ??

        VAR
          standard_union_type_description: [STATIC, READ, oss$job_paged_literal] clt$type_description :=
*IF NOT $true(osv$unix)
                [NIL, NIL, FALSE, FALSE, -$clt$type_kinds [], clc$union_type, ^standard_union_members,
*ELSE
                [NIL, NIL, FALSE, FALSE, -$clt$type_kinds_v2 [], clc$union_type, ^standard_union_members,
*IFEND
                ^standard_union_information],
          standard_union_members: [STATIC, READ, oss$job_paged_literal] array [1 .. 8] of
                clt$type_description := [
                {BOOLEAN} [NIL, NIL, FALSE, FALSE, [clc$boolean_type], clc$boolean_type],
*IF NOT $true(osv$unix)
                {FILE} [NIL, NIL, FALSE, FALSE, [clc$file_type], clc$file_type],
*ELSE
                {NOS_VE_FILE} [NIL, NIL, FALSE, FALSE, [clc$nos_ve_file_type], clc$nos_ve_file_type],
*IFEND
                {INTEGER} [NIL, NIL, FALSE, FALSE, [clc$integer_type], clc$integer_type, clc$min_integer,
                clc$max_integer, 10],
                {NAME} [NIL, NIL, FALSE, FALSE, [clc$name_type], clc$name_type, 1, osc$max_name_size],
                {REAL} [NIL, NIL, FALSE, FALSE, [clc$real_type], clc$real_type,
*IF NOT $true(osv$unix)
                [{-$INFINITY} 3, [[0d000(16), 0], [0d000(16), 0]]],
                [{$INFINITY} 3, [[5000(16), 0], [5000(16), 0]]]],
*ELSE
*copy cli$longreal_negative_infinity
                ,
*copy cli$longreal_positive_infinity
                ],
*IFEND
                {STATUS} [NIL, NIL, FALSE, FALSE, [clc$status_type], clc$status_type],
                {STRING} [NIL, NIL, FALSE, FALSE, [clc$string_type], clc$string_type, 0, clc$max_string_size,
                FALSE],
                {STRING_PATTERN} [NIL, NIL, FALSE, FALSE, [clc$string_pattern_type],
                clc$string_pattern_type]],
          standard_union_information: [STATIC, READ, oss$job_paged_literal] clt$union_type_information :=
*IF NOT $true(osv$unix)
                [TRUE, clc$min_integer, clc$max_integer, 10, [{-$INFINITY} 3, [[0d000(16), 0], [0d000(16),
                0]]], [{$INFINITY} 3, [[5000(16), 0], [5000(16), 0]]]];
*ELSE
                [TRUE, clc$min_integer, clc$max_integer, 10,
*copy cli$longreal_negative_infinity
                ,
*copy cli$longreal_positive_infinity
                ];
*IFEND

        VAR
          non_standard_union_type_desc: [STATIC, READ, oss$job_paged_literal] clt$type_description :=
                [NIL, NIL, FALSE, FALSE, [clc$cobol_name_type, clc$command_reference_type, clc$date_time_type,
                clc$scu_line_identifier_type, clc$time_increment_type, clc$time_zone_type,
                clc$type_specification_type], clc$union_type, ^non_standard_union_members,
                ^non_standard_union_information],
          non_standard_union_members: [STATIC, READ, oss$job_paged_literal] array [1 .. 7] of
                clt$type_description := [
                {DATE_TIME} [NIL, NIL, FALSE, FALSE, [clc$date_time_type], clc$date_time_type,
                [clc$date, clc$time], [clc$past, clc$present, clc$future]],
                {TIME_INCREMENT} [NIL, NIL, FALSE, FALSE, [clc$time_increment_type], clc$time_increment_type],
                {TIME_ZONE} [NIL, NIL, FALSE, FALSE, [clc$time_zone_type], clc$time_zone_type],
                {COBOL_NAME} [NIL, NIL, FALSE, FALSE, [clc$cobol_name_type], clc$cobol_name_type],
                {COMMAND_REFERENCE} [NIL, NIL, FALSE, FALSE, [clc$command_reference_type],
                clc$command_reference_type],
                {LINE_IDENTIFIER} [NIL, NIL, FALSE, FALSE, [clc$scu_line_identifier_type],
                clc$scu_line_identifier_type],
                {TYPE} [NIL, NIL, FALSE, FALSE, [clc$type_specification_type], clc$type_specification_type]],
          non_standard_union_information: [STATIC, READ, oss$job_paged_literal]
                clt$union_type_information := [FALSE, clc$min_integer, clc$max_integer, 10,
*IF NOT $true(osv$unix)
                [{-$INFINITY} 3, [[0d000(16), 0], [0d000(16), 0]]],
                [{$INFINITY} 3, [[5000(16), 0], [5000(16), 0]]]];
*ELSE
*copy cli$longreal_negative_infinity
                ,
*copy cli$longreal_positive_infinity
                ];
*IFEND

?? EJECT ??

        VAR
          ignore_real_convertable_to_int: boolean,
          ignore_integer_result: clt$data_value,
          name: ost$name,
*IF $true(osv$unix)
          parse_before_handle_range: clt$parse_state,
*IFEND
          saved_status: ^ost$status;


        saved_parse := parse;
        saved_status := NIL;

        IF current_type_description^.member_descriptions = NIL THEN

          IF parse.unit.kind = clc$lex_name THEN
            check_for_solely_name_deref;
            IF result <> NIL THEN
              RETURN;
            IFEND;
            IF NOT status.normal THEN
              PUSH saved_status;
              saved_status^ := status;
            IFEND;
            status.normal := TRUE;
          IFEND;

          IF parse.unit.kind = clc$lex_left_parenthesis THEN
            check_for_and_handle_list;

{ Control is not returned if the expression is a list.

          IFEND;

          parse := saved_parse;
*IF $true(osv$unix)
          parse_before_handle_range := saved_parse;
*IFEND
          check_for_and_handle_range;

{ Control is not returned if the expression is a range.

{ Now try evaluating the expression as if it were one of the "standard" types.

          parse := saved_parse;
          local_numeric_info.initialized := FALSE;
          evaluate_expression (parse, ^standard_union_type_description, evaluating_sub_expression,
                clc$no_expansion, local_numeric_info, result, ignore_sub_list_tail, status);
          IF status.normal THEN
            RETURN;
          IFEND;

{ Now try evaluating the expression as if it were not a "standard" types.  Not
{ all of the "non-standard" types are included in the type description used
{ because of the "overlapping" nature of the syntax of the various types of
{ expressions.

          parse := saved_parse;
          local_numeric_info.initialized := FALSE;
          evaluate_expression (parse, ^non_standard_union_type_desc, evaluating_sub_expression,
                clc$no_expansion, local_numeric_info, result, ignore_sub_list_tail, status);
          IF status.normal THEN
            RETURN;
          IFEND;

          IF saved_status <> NIL THEN
            status := saved_status^;
          ELSE
            osp$set_status_abnormal ('CL', cle$expression_not_union_type, saved_parse.
                  text^ (saved_parse.unit_index, saved_parse.index_limit - saved_parse.unit_index), status);
          IFEND;
          EXIT evaluate_expression;
        IFEND;

      /try_member_types/
        BEGIN
          evaluate_as_standard_type := current_type_description^.union_information^.
                only_standard_types_in_union;
          IF evaluate_as_standard_type THEN
*IF NOT $true(osv$unix)
            IF clc$file_type IN current_type_description^.kinds THEN
*ELSE
            IF clc$nos_ve_file_type IN current_type_description^.kinds THEN
*IFEND
              evaluate_as_standard_type := clc$name_type IN current_type_description^.kinds;
            IFEND;
          IFEND;
          IF evaluate_as_standard_type THEN

{ The "standard" types have non-conflicting expression forms, therefore an
{ expression for a union of them can be evaluated without the need for trying
{ each type individually.  The "standard" types are: boolean, file, integer (if
{ default radix is 10), name, real, status, string (if not literal),
{ string_pattern, and union (consisting only of these "standard" types).

            evaluate_boolean (FALSE, result);
            IF parse.unit_index < parse.index_limit THEN
              osp$set_status_condition (cle$expecting_end_of_expression, status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT evaluate_expression;
            IFEND;

          /standardize_result/
            BEGIN
              CASE result^.kind OF
              = clc$data_name =
                name := result^.data_name_value;
              = clc$keyword =
                name := result^.keyword_value;
              = clc$real =
                simplify_real_to_integer (result, ignore_integer_result, ignore_real_convertable_to_int);
                EXIT /standardize_result/;
              = clc$unspecified =
                RETURN;
              ELSE
                EXIT /standardize_result/;
              CASEND;
              result^.kind := clc$name;
              result^.name_value := name;
            END /standardize_result/;

            IF current_type_description <> ^standard_union_type_description THEN
              clp$evaluate_value_conformance (result, current_type_description, clc$conforms_to_type, status);
              IF NOT status.normal THEN
                EXIT evaluate_expression;
              IFEND;
            IFEND;

            RETURN;
          IFEND;

          tried_numeric_evaluate := FALSE;
          FOR i := 1 TO UPPERBOUND (current_type_description^.member_descriptions^) DO
            parse := saved_parse;
            local_numeric_info.initialized := FALSE;
            CASE current_type_description^.member_descriptions^ [i].kind OF
            = clc$integer_type =
              try_numeric_evaluate := clc$real_type IN current_type_description^.kinds;
            = clc$real_type =
              try_numeric_evaluate := clc$integer_type IN current_type_description^.kinds;
            ELSE
              try_numeric_evaluate := FALSE;
            CASEND;
            IF try_numeric_evaluate THEN
              IF NOT tried_numeric_evaluate THEN
                numeric_union_type_description := current_type_description^;
*IF NOT $true(osv$unix)
                numeric_union_type_description.kinds := $clt$type_kinds [clc$integer_type, clc$real_type];
*ELSE
                numeric_union_type_description.kinds := $clt$type_kinds_v2 [clc$integer_type, clc$real_type];
*IFEND
                numeric_union_type_description.union_information^.only_standard_types_in_union := TRUE;
                evaluate_expression (parse, ^numeric_union_type_description, evaluating_sub_expression,
                      clc$no_expansion, local_numeric_info, result, ignore_sub_list_tail, status);
                IF status.normal AND (parse.unit_index >= parse.index_limit) THEN
                  IF result^.kind = clc$unspecified THEN
                    RETURN;
                  ELSEIF evaluating_sub_expression THEN
                    IF result^.kind IN $clt$data_kinds [clc$integer, clc$real] THEN
                      RETURN;
                    IFEND;
                  ELSE
                    clp$validate_value_conformance (result, current_type_description, type_conformance);
                    IF type_conformance >= clc$conforms_to_type THEN
                      RETURN;
                    IFEND;
                  IFEND;
                IFEND;
                tried_numeric_evaluate := TRUE;
              IFEND;
            ELSE
              evaluate_expression (parse, ^current_type_description^.member_descriptions^ [i],
                    evaluating_sub_expression, clc$no_expansion, local_numeric_info, result,
                    ignore_sub_list_tail, status);
              IF status.normal AND (parse.unit_index >= parse.index_limit) THEN
                RETURN;
              IFEND;
            IFEND;
          FOREND;

        END /try_member_types/;

{ The following call to check_for_solely_name_deref is made in order to take a
{ stab at producing a more useful status than cle$expression_not_union_type.
{ If the expression consists solely of a reference to a variable or function
{ that for whatever reason fails, this will ensure that the failing status is
{ reported and not disguised by the more generic status.

        IF saved_parse.unit.kind = clc$lex_name THEN
          parse := saved_parse;
          check_for_solely_name_deref;
        IFEND;
        IF status.normal THEN
          osp$set_status_abnormal ('CL', cle$expression_not_union_type, saved_parse.
                text^ (saved_parse.unit_index, saved_parse.index_limit - saved_parse.unit_index), status);
        IFEND;
        EXIT evaluate_expression;

      PROCEND evaluate_union;
?? TITLE := 'handle_comparison', EJECT ??

      PROCEDURE handle_comparison
        (VAR result {input, output} : ^clt$data_value);

        VAR
          comparison_order: clt$comparison_result,
          current_operator: clt$operator,
          ignore_result_type_description: ^clt$type_description,
          local_numeric_info: clt$numeric_operand_info,
          result_table: [STATIC, READ, oss$job_paged_literal] array [clt$relational_operator] of
                array [clt$comparison_result] of boolean := [
                {op} {equal, left>, ?????, right>}
                {> } [FALSE, TRUE, FALSE, FALSE],
                {>=} [TRUE, TRUE, FALSE, FALSE],
                {< } [FALSE, FALSE, FALSE, TRUE],
                {<=} [TRUE, FALSE, FALSE, TRUE],
                {= } [TRUE, FALSE, FALSE, FALSE],
                {<>} [FALSE, TRUE, TRUE, TRUE]],
          right_operand: ^clt$data_value,
          right_type_description: clt$type_description;

?? NEWTITLE := 'compare_arrays', EJECT ??

        PROCEDURE compare_arrays;


          IF NOT (current_operator.relational_kind IN $clt$relational_operators
                [clc$lex_equal, clc$lex_not_equal]) THEN
            only_compare_for_equality;
          IFEND;

          IF (operand_type_description <> NIL) AND (operand_type_description^.kind <> clc$union_type) THEN
            right_type_description := operand_type_description^;
          ELSE
            clp$derive_type_desc_from_value (result, work_area, right_type_description, status);
            IF NOT status.normal THEN
              EXIT evaluate_expression;
            IFEND;
          IFEND;

          evaluate_right_operand_type (^right_type_description);

          IF right_operand^.kind = clc$unspecified THEN
            RETURN;
          IFEND;

          comparison_order := clp$array_value_compare (result, right_operand);

        PROCEND compare_arrays;
?? TITLE := 'compare_booleans', EJECT ??

        PROCEDURE compare_booleans;


          evaluate_boolean_operand (right_operand);

          CASE right_operand^.kind OF

          = clc$boolean =
            comparison_order := clp$boolean_compare (result^.boolean_value.value,
                  right_operand^.boolean_value.value);

          = clc$unspecified =
            comparison_order := clc$unordered;
            RETURN;

          ELSE
            non_comparable_values;
          CASEND;

        PROCEND compare_booleans;
?? TITLE := 'compare_cobol_names', EJECT ??

        PROCEDURE compare_cobol_names;

          VAR
            right_string: ^clt$string_value;


          IF parse.unit.kind = clc$lex_string THEN
            evaluate_operand (right_operand);

            PUSH right_string: [STRLENGTH (right_operand^.string_value^)];
            #TRANSLATE (osv$lower_to_upper, right_operand^.string_value^, right_string^);

          ELSE
            evaluate_right_operand_kind (clc$cobol_name_type);

            IF right_operand^.kind = clc$unspecified THEN
              RETURN;
            IFEND;

            right_string := ^right_operand^.cobol_name_value;
          IFEND;

          comparison_order := clp$string_compare (^result^.cobol_name_value, right_string);

        PROCEND compare_cobol_names;
?? TITLE := 'compare_command_references', EJECT ??

        PROCEDURE compare_command_references;


          IF NOT (current_operator.relational_kind IN $clt$relational_operators
                [clc$lex_equal, clc$lex_not_equal]) THEN
            only_compare_for_equality;
          IFEND;

          evaluate_right_operand_kind (clc$command_reference_type);

          IF right_operand^.kind = clc$unspecified THEN
            RETURN;
          IFEND;

          comparison_order := clp$command_reference_compare (result^.command_reference_value^,
                right_operand^.command_reference_value^);

        PROCEND compare_command_references;
?? TITLE := 'compare_data_names', EJECT ??

        PROCEDURE compare_data_names;

          VAR
            right_string: ^clt$string_value;


          IF parse.unit.kind = clc$lex_string THEN
            evaluate_operand (right_operand);

            PUSH right_string: [STRLENGTH (right_operand^.string_value^)];
            #TRANSLATE (osv$lower_to_upper, right_operand^.string_value^, right_string^);

          ELSE
            evaluate_right_operand_kind (clc$data_name_type);

            IF right_operand^.kind = clc$unspecified THEN
              RETURN;
            IFEND;

            right_string := ^right_operand^.data_name_value;
          IFEND;

          comparison_order := clp$string_compare (^result^.data_name_value, right_string);

        PROCEND compare_data_names;
?? TITLE := 'compare_date_times', EJECT ??

        PROCEDURE compare_date_times;


          right_type_description.specification := NIL;
          right_type_description.name := NIL;
          right_type_description.derived_from_value_kind_spec := FALSE;
          right_type_description.advanced_keywords_present := FALSE;
*IF NOT $true(osv$unix)
          right_type_description.kinds := $clt$type_kinds [clc$date_time_type];
*ELSE
          right_type_description.kinds := $clt$type_kinds_v2 [clc$date_time_type];
*IFEND
          right_type_description.kind := clc$date_time_type;
          right_type_description.date_and_or_time := $clt$date_and_or_time [clc$date, clc$time];
          right_type_description.tenses := $clt$date_time_tenses [clc$past, clc$present, clc$future];

          evaluate_right_operand_type (^right_type_description);

          IF right_operand^.kind = clc$unspecified THEN
            RETURN;
          IFEND;

          comparison_order := clp$date_time_compare (result^.date_time_value, right_operand^.date_time_value);

        PROCEND compare_date_times;
?? TITLE := 'compare_entry_point_references', EJECT ??

        PROCEDURE compare_entry_point_references;


          IF NOT (current_operator.relational_kind IN $clt$relational_operators
                [clc$lex_equal, clc$lex_not_equal]) THEN
            only_compare_for_equality;
          IFEND;

          evaluate_right_operand_kind (clc$entry_point_reference_type);

          IF right_operand^.kind = clc$unspecified THEN
            RETURN;
          IFEND;

          comparison_order := clp$entry_point_ref_compare (result^.entry_point_reference_value^,
                right_operand^.entry_point_reference_value^);

        PROCEND compare_entry_point_references;
*IF NOT $true(osv$unix)
?? TITLE := 'compare_files', EJECT ??

        PROCEDURE compare_files;


          evaluate_right_operand_kind (clc$file_type);
*ELSE
?? TITLE := 'compare_nos_ve_files', EJECT ??

        PROCEDURE compare_nos_ve_files;


          evaluate_right_operand_kind (clc$nos_ve_file_type);
*IFEND

          IF right_operand^.kind = clc$unspecified THEN
            RETURN;
          IFEND;

          compare_path_names (result^.file_value^, right_operand^.file_value^);

*IF NOT $true(osv$unix)
        PROCEND compare_files;
*ELSE
        PROCEND compare_nos_ve_files;
?? TITLE := 'compare_unix_files', EJECT ??

        PROCEDURE compare_unix_files;


          evaluate_right_operand_kind (clc$unix_file_type);

          IF right_operand^.kind = clc$unspecified THEN
            RETURN;
          IFEND;

          comparison_order := clp$string_compare (result^.file_value, right_operand^.file_value);

        PROCEND compare_unix_files;
*IFEND
?? TITLE := 'compare_keywords', EJECT ??
{ Note:
{
{   This is the only compare_xxx procedure in which right_type_description is NOT initialized.
{ (The compare_xxx procs which call evaluate_right_operand_kind do it indirectly.)  However,
{ initializing it (like in compare_arrays) caused the following SCL procedure to no longer work.
{
{ PROCEDURE p (
{   a: any of
{        key
{          one
{          two
{        keyend
{        file
{      anyend = two)
{
{   IF a=one THEN
{     ....
{   ELSEIF a=$user THEN
{     ....
{
{   This would get error CL 2015  Values of types KEYWORD and FILE may not be compared.

        PROCEDURE compare_keywords;

          VAR
            right_string: ^clt$string_value;


          IF parse.unit.kind = clc$lex_string THEN
            evaluate_operand (right_operand);

            PUSH right_string: [STRLENGTH (right_operand^.string_value^)];
            #TRANSLATE (osv$lower_to_upper, right_operand^.string_value^, right_string^);

          ELSEIF operand_type_description <> NIL THEN
            evaluate_right_operand_type (operand_type_description);

            IF right_operand^.kind = clc$unspecified THEN
              RETURN;
            IFEND;

            right_string := ^right_operand^.keyword_value;

          ELSE
            evaluate_right_operand_kind (clc$data_name_type);

            IF right_operand^.kind = clc$unspecified THEN
              RETURN;
            IFEND;

            right_string := ^right_operand^.data_name_value;
          IFEND;

          comparison_order := clp$string_compare (^result^.keyword_value, right_string);

        PROCEND compare_keywords;
?? TITLE := 'compare_lists', EJECT ??

        PROCEDURE compare_lists;


          IF NOT (current_operator.relational_kind IN $clt$relational_operators
                [clc$lex_equal, clc$lex_not_equal]) THEN
            only_compare_for_equality;
          IFEND;

          IF (operand_type_description <> NIL) AND (operand_type_description^.kind <> clc$union_type) THEN
            right_type_description := operand_type_description^;
          ELSE
            clp$derive_type_desc_from_value (result, work_area, right_type_description, status);
            IF NOT status.normal THEN
              EXIT evaluate_expression;
            IFEND;
          IFEND;

          right_type_description.min_list_size := 0;
          right_type_description.max_list_size := clc$max_list_size;
          right_type_description.list_rest := FALSE;
          evaluate_right_operand_type (^right_type_description);

          IF right_operand^.kind = clc$unspecified THEN
            RETURN;
          IFEND;

          comparison_order := clp$list_value_compare (result, right_operand);

        PROCEND compare_lists;
?? TITLE := 'compare_names', EJECT ??

        PROCEDURE compare_names;

          VAR
            right_string: ^clt$string_value;


          IF parse.unit.kind = clc$lex_string THEN
            evaluate_operand (right_operand);

            PUSH right_string: [STRLENGTH (right_operand^.string_value^)];
            #TRANSLATE (osv$lower_to_upper, right_operand^.string_value^, right_string^);

          ELSE
            right_type_description.specification := NIL;
            right_type_description.name := NIL;
            right_type_description.derived_from_value_kind_spec := FALSE;
            right_type_description.advanced_keywords_present := FALSE;
*IF NOT $true(osv$unix)
            right_type_description.kinds := $clt$type_kinds [clc$name_type];
*ELSE
            right_type_description.kinds := $clt$type_kinds_v2 [clc$name_type];
*IFEND
            right_type_description.kind := clc$name_type;
            right_type_description.min_name_size := 1;
            right_type_description.max_name_size := osc$max_name_size;
            evaluate_right_operand_type (^right_type_description);

            IF right_operand^.kind = clc$unspecified THEN
              RETURN;
            IFEND;

            right_string := ^right_operand^.name_value;
          IFEND;

          comparison_order := clp$string_compare (^result^.name_value, right_string);

        PROCEND compare_names;
?? TITLE := 'compare_network_titles', EJECT ??

        PROCEDURE compare_network_titles;


          osp$set_status_abnormal ('CL', cle$not_supported, 'Comparison of network titles', status);
          EXIT evaluate_expression;

        PROCEND compare_network_titles;
?? TITLE := 'compare_numbers', EJECT ??

        PROCEDURE compare_numbers;

          VAR
            real_operand: clt$data_value;


          right_operand := NIL;
          evaluate_number (FALSE, right_operand);

          CASE right_operand^.kind OF

          = clc$integer, clc$real =
            ;

          = clc$unspecified =
            comparison_order := clc$unordered;
            RETURN;

          ELSE
            non_comparable_values;
          CASEND;

          comparison_order := clp$number_compare (result^, right_operand^);

        PROCEND compare_numbers;
?? TITLE := 'compare_path_names', EJECT ??

        PROCEDURE compare_path_names
          (    left_file_reference: fst$file_reference;
               right_file_reference: fst$file_reference);

          CONST
            first_character_of_full_path = ':';

          VAR
            left_full_path: fst$path,
            right_full_path: fst$path;


*IF NOT $true(osv$unix)
          IF (STRLENGTH (left_file_reference) > 1) AND (left_file_reference (1) =
                first_character_of_full_path) THEN
*IFEND
            #TRANSLATE (osv$lower_to_upper, left_file_reference, left_full_path);
*IF NOT $true(osv$unix)
          ELSE
            clp$get_path_name (left_file_reference, osc$full_message_level, left_full_path);
          IFEND;
*IFEND

*IF NOT $true(osv$unix)
          IF (STRLENGTH (right_file_reference) > 1) AND (right_file_reference (1) =
                first_character_of_full_path) THEN
*IFEND
            #TRANSLATE (osv$lower_to_upper, right_file_reference, right_full_path);
*IF NOT $true(osv$unix)
          ELSE
            clp$get_path_name (right_file_reference, osc$full_message_level, right_full_path);
          IFEND;
*IFEND

          comparison_order := clp$string_compare (^left_full_path, ^right_full_path);

        PROCEND compare_path_names;
?? TITLE := 'compare_program_names', EJECT ??

        PROCEDURE compare_program_names;


          evaluate_right_operand_kind (clc$program_name_type);

          IF right_operand^.kind = clc$unspecified THEN
            RETURN;
          IFEND;

          comparison_order := clp$string_compare (^result^.program_name_value,
                ^right_operand^.program_name_value);

        PROCEND compare_program_names;
?? TITLE := 'compare_ranges', EJECT ??

        PROCEDURE compare_ranges;


          IF NOT (current_operator.relational_kind IN $clt$relational_operators
                [clc$lex_equal, clc$lex_not_equal]) THEN
            only_compare_for_equality;
          IFEND;

          IF (operand_type_description <> NIL) AND (operand_type_description^.kind <> clc$union_type) THEN
            right_type_description := operand_type_description^;
          ELSE
            clp$derive_type_desc_from_value (result, work_area, right_type_description, status);
            IF NOT status.normal THEN
              EXIT evaluate_expression;
            IFEND;
          IFEND;

          evaluate_right_operand_type (^right_type_description);

          IF right_operand^.kind = clc$unspecified THEN
            RETURN;
          IFEND;

          comparison_order := clp$range_value_compare (result, right_operand);

        PROCEND compare_ranges;
?? TITLE := 'compare_records', EJECT ??

        PROCEDURE compare_records;


          IF NOT (current_operator.relational_kind IN $clt$relational_operators
                [clc$lex_equal, clc$lex_not_equal]) THEN
            only_compare_for_equality;
          IFEND;

          IF (operand_type_description <> NIL) AND (operand_type_description^.kind <> clc$union_type) THEN
            right_type_description := operand_type_description^;
          ELSE
            clp$derive_type_desc_from_value (result, work_area, right_type_description, status);
            IF NOT status.normal THEN
              EXIT evaluate_expression;
            IFEND;
          IFEND;

          evaluate_right_operand_type (^right_type_description);

          IF right_operand^.kind = clc$unspecified THEN
            RETURN;
          IFEND;

          comparison_order := clp$record_value_compare (result, right_operand);

        PROCEND compare_records;
?? TITLE := 'compare_scu_line_identifiers', EJECT ??

        PROCEDURE compare_scu_line_identifiers;


          IF NOT (current_operator.relational_kind IN $clt$relational_operators
                [clc$lex_equal, clc$lex_not_equal]) THEN
            only_compare_for_equality;
          IFEND;

          evaluate_right_operand_kind (clc$scu_line_identifier_type);

          IF right_operand^.kind = clc$unspecified THEN
            RETURN;
          IFEND;

          IF result^.scu_line_identifier_value = right_operand^.scu_line_identifier_value THEN
            comparison_order := clc$equal;
          ELSE
            comparison_order := clc$unordered;
          IFEND;

        PROCEND compare_scu_line_identifiers;
?? TITLE := 'compare_statistic_codes', EJECT ??

        PROCEDURE compare_statistic_codes;


          evaluate_right_operand_kind (clc$statistic_code_type);

          IF right_operand^.kind = clc$unspecified THEN
            RETURN;
          IFEND;

          comparison_order := clp$integer_compare (result^.statistic_code_value,
                right_operand^.statistic_code_value);

        PROCEND compare_statistic_codes;
?? TITLE := 'compare_statuses', EJECT ??

        PROCEDURE compare_statuses;


          IF NOT (current_operator.relational_kind IN $clt$relational_operators
                [clc$lex_equal, clc$lex_not_equal]) THEN
            only_compare_for_equality;
          IFEND;

          evaluate_right_operand_kind (clc$status_type);

          IF right_operand^.kind = clc$unspecified THEN
            RETURN;
          IFEND;

          comparison_order := clp$status_compare (result^.status_value^, right_operand^.status_value^);

        PROCEND compare_statuses;
?? TITLE := 'compare_status_codes', EJECT ??

        PROCEDURE compare_status_codes;


          evaluate_right_operand_kind (clc$status_code_type);

          IF right_operand^.kind = clc$unspecified THEN
            RETURN;
          IFEND;

          comparison_order := clp$integer_compare (result^.status_code_value,
                right_operand^.status_code_value);

        PROCEND compare_status_codes;
?? TITLE := 'compare_strings', EJECT ??

        PROCEDURE compare_strings;


          right_operand := NIL;
          evaluate_string_or_pattern (FALSE, right_operand);

          CASE right_operand^.kind OF

          = clc$string =
            ;

          = clc$unspecified =
            comparison_order := clc$unordered;
            RETURN;

          ELSE
            non_comparable_values;
          CASEND;

          comparison_order := clp$string_compare (result^.string_value, right_operand^.string_value);

        PROCEND compare_strings;
?? TITLE := 'compare_time_increments', EJECT ??

        PROCEDURE compare_time_increments;


          evaluate_right_operand_kind (clc$time_increment_type);

          IF right_operand^.kind = clc$unspecified THEN
            RETURN;
          IFEND;

          comparison_order := clp$time_increment_compare (result^.time_increment_value^,
                right_operand^.time_increment_value^);

        PROCEND compare_time_increments;
?? TITLE := 'compare_time_zones', EJECT ??

        PROCEDURE compare_time_zones;


          IF NOT (current_operator.relational_kind IN $clt$relational_operators
                [clc$lex_equal, clc$lex_not_equal]) THEN
            only_compare_for_equality;
          IFEND;

          evaluate_right_operand_kind (clc$time_zone_type);

          IF right_operand^.kind = clc$unspecified THEN
            RETURN;
          IFEND;

          IF result^.time_zone_value = right_operand^.time_zone_value THEN
            comparison_order := clc$equal;
          ELSE
            comparison_order := clc$unordered;
          IFEND;

        PROCEND compare_time_zones;
?? TITLE := 'compare_type_specifications', EJECT ??

        PROCEDURE compare_type_specifications;

          VAR
            left_type_description: clt$type_description,
            right_type_description: clt$type_description,
            type_conformance: clt$type_conformance;


          IF NOT (current_operator.relational_kind IN $clt$relational_operators
                [clc$lex_equal, clc$lex_not_equal]) THEN
            only_compare_for_equality;
          IFEND;

          evaluate_right_operand_kind (clc$type_specification_type);

          IF right_operand^.kind = clc$unspecified THEN
            RETURN;
          IFEND;

          clp$convert_type_spec_to_desc (result^.type_specification_value, work_area, left_type_description,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$convert_type_spec_to_desc (right_operand^.type_specification_value, work_area,
                right_type_description, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$validate_type_conformance (^left_type_description, ^right_type_description, type_conformance);

          IF type_conformance = clc$identical_types THEN
            comparison_order := clc$equal;
          ELSE
            comparison_order := clc$unordered;
          IFEND;

        PROCEND compare_type_specifications;
?? TITLE := 'compare_unspecified_value', EJECT ??

        PROCEDURE compare_unspecified_value;


{ Skip over right operand.

          REPEAT
            clp$scan_operand (clc$separator, parse);
            recognize_binary_operator;
          UNTIL operator.kind IN $clt$operator_kinds [clc$not_an_operator, clc$logical_operator,
                clc$relational_operator];

          comparison_order := clc$unordered;

        PROCEND compare_unspecified_value;
?? TITLE := 'evaluate_right_operand_kind', EJECT ??

        PROCEDURE [INLINE] evaluate_right_operand_kind
          (    type_kind: clt$type_kind);


          right_type_description.specification := NIL;
          right_type_description.name := NIL;
          right_type_description.derived_from_value_kind_spec := FALSE;
          right_type_description.advanced_keywords_present := FALSE;
*IF NOT $true(osv$unix)
          right_type_description.kinds := $clt$type_kinds [type_kind];
*ELSE
          right_type_description.kinds := $clt$type_kinds_v2 [type_kind];
*IFEND
          right_type_description.kind := type_kind;

          evaluate_right_operand_type (^right_type_description);

        PROCEND evaluate_right_operand_kind;
?? TITLE := 'evaluate_right_operand_type', EJECT ??

        PROCEDURE [INLINE] evaluate_right_operand_type
          (    type_description: ^clt$type_description);

          VAR
            ignore_sub_list_tail: ^clt$data_value;


          local_numeric_info.initialized := FALSE;
          evaluate_expression (parse, type_description, FALSE, clc$no_expansion, local_numeric_info,
                right_operand, ignore_sub_list_tail, status);

          IF NOT status.normal THEN
            IF status.condition = cle$wrong_kind_of_value THEN
              status.condition := cle$non_comparable_values;
            ELSEIF (status.condition = cle$unknown_keyword) AND
                  (type_description^.kind = clc$keyword_type) THEN

{ The following code deals with the attempt to compare a name with a
{ keyword and the name is not one of the allowed values for the keyword
{ type.  For purposes of comparison, we don't want this to be treated as
{ an error, rather just report that the name is not equal to the keyword.
{ The right operand is "kludged up" as a "null keyword" which can't
{ possibly (legitimately) compare equal to the left operand.

              clp$make_keyword_value (osc$null_name, work_area, right_operand);
              IF right_operand = NIL THEN
                osp$set_status_condition (cle$work_area_overflow, status);
                EXIT evaluate_expression;
              IFEND;
              status.normal := TRUE;
              RETURN;
            IFEND;
            EXIT evaluate_expression;

          ELSEIF right_operand^.kind = clc$unspecified THEN
            comparison_order := clc$unordered;
          IFEND;

        PROCEND evaluate_right_operand_type;
?? TITLE := 'non_comparable_values', EJECT ??

        PROCEDURE non_comparable_values;


          osp$set_status_condition (cle$non_comparable_values, status);
          clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
          clp$append_status_value_type (osc$status_parameter_delimiter, right_operand, status);
          EXIT evaluate_expression;

        PROCEND non_comparable_values;
?? TITLE := 'only_compare_for_equality', EJECT ??

        PROCEDURE only_compare_for_equality;


          osp$set_status_condition (cle$only_compare_for_equality, status);
          clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
          EXIT evaluate_expression;

        PROCEND only_compare_for_equality;
?? OLDTITLE, EJECT ??

        REPEAT
          current_operator := operator;

          CASE result^.kind OF
          = clc$application, clc$lock, clc$string_pattern =
            osp$set_status_condition (cle$non_comparable_type, status);
            clp$append_status_value_type (osc$status_parameter_delimiter, result, status);
            EXIT evaluate_expression;
          = clc$array =
            compare_arrays;
          = clc$boolean =
            compare_booleans;
          = clc$cobol_name =
            compare_cobol_names;
          = clc$command_reference =
            compare_command_references;
          = clc$data_name =
            compare_data_names;
          = clc$date_time =
            compare_date_times;
          = clc$entry_point_reference =
            compare_entry_point_references;
*IF NOT $true(osv$unix)
          = clc$file =
            compare_files;
*ELSE
          = clc$nos_ve_file =
            compare_nos_ve_files;
          = clc$unix_file =
            compare_unix_files;
*IFEND
          = clc$integer, clc$real =
            compare_numbers;
          = clc$keyword =
            compare_keywords;
          = clc$list =
            compare_lists;
          = clc$name =
            compare_names;
          = clc$network_title =
            compare_network_titles;
          = clc$program_name =
            compare_program_names;
          = clc$range =
            compare_ranges;
          = clc$record =
            compare_records;
          = clc$scu_line_identifier =
            compare_scu_line_identifiers;
          = clc$statistic_code =
            compare_statistic_codes;
          = clc$status =
            compare_statuses;
          = clc$status_code =
            compare_status_codes;
          = clc$string =
            compare_strings;
          = clc$time_increment =
            compare_time_increments;
          = clc$time_zone =
            compare_time_zones;
          = clc$type_specification =
            compare_type_specifications;
          = clc$unspecified =
            compare_unspecified_value;
          ELSE
            osp$set_status_abnormal ('CL', cle$unrecognizable_data_value, current_operator.representation,
                  status);
            EXIT evaluate_expression;
          CASEND;

          clp$make_boolean_value (result_table [current_operator.relational_kind] [comparison_order],
                clc$true_false_boolean, work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;
        UNTIL operator.kind <> clc$relational_operator;

        IF (operator.kind = clc$not_an_operator) AND (parse.unit.kind = clc$lex_name) THEN
          recognize_binary_operator;
        IFEND;

      PROCEND handle_comparison;
?? TITLE := 'handle_unary_minus', EJECT ??

      PROCEDURE handle_unary_minus
        (VAR operand {input, output} : clt$data_value);

        CONST
          unary_minus_representation = '-';

        VAR
          dummy_operand: clt$data_value,
          original_operand: clt$data_value;


        dummy_operand.kind := clc$unspecified;
        original_operand := operand;

        clp$perform_numeric_operation (unary_minus_representation, dummy_operand, original_operand, operand,
              status);
        IF NOT status.normal THEN
          EXIT evaluate_expression;
        IFEND;

      PROCEND handle_unary_minus;
?? TITLE := 'handle_wild_card_name', EJECT ??

      PROCEDURE handle_wild_card_name
        (VAR result: ^clt$data_value;
         VAR result_sub_list_tail: ^clt$data_value);

        TYPE
          chars = set of char;

        VAR
          candidate_list: ^clt$data_value,
          ignore_scan_index: integer,
          match_info: clt$string_pattern_match_info,
          result_node: ^^clt$data_value,
          scan_found_char: boolean,
*IF NOT $true(osv$unix)
          scl_options: ^clt$scl_options,
*IFEND
          string_pattern: ^clt$string_pattern,
          wild_card_chars: chars,
          wild_card_name: ^clt$application_value_text;

?? NEWTITLE := 'expand_wild_card_keyword', EJECT ??

        PROCEDURE expand_wild_card_keyword;

          VAR
            k: clt$keyword_index,
            keywords: ^clt$keyword_specifications,
            matched_keywords: ^array [1 .. * ] {indexed by keyword's ordinal} of record
              matched: boolean,
              nominal_index: 0 .. clc$max_keywords,
            recend;


          keywords := current_type_description^.keyword_specifications;
          PUSH matched_keywords: [1 .. UPPERBOUND (keywords^)];
          FOR k := 1 TO UPPERBOUND (matched_keywords^) DO
            matched_keywords^ [k].matched := FALSE;
            matched_keywords^ [k].nominal_index := 0;
          FOREND;

          FOR k := 1 TO UPPERBOUND (keywords^) DO
            IF (keywords^ [k].ordinal < 1) OR (keywords^ [k].ordinal > UPPERBOUND (keywords^)) THEN
              osp$set_status_condition (cle$bad_keyword_type_spec, status);
              EXIT evaluate_expression;
            IFEND;

            IF keywords^ [k].availability <> clc$hidden_entry THEN
              clp$match_string_pattern (keywords^ [k].keyword (1, clp$trimmed_string_size
                    (keywords^ [k].keyword)), string_pattern, clc$sp_anchored, clc$sp_quick_scan, match_info,
                    status);
              IF NOT status.normal THEN
                EXIT evaluate_expression;
              ELSEIF match_info.result = clc$sp_success THEN
                matched_keywords^ [keywords^ [k].ordinal].matched := TRUE;
              IFEND;

              IF keywords^ [k].class = clc$nominal_entry THEN
                matched_keywords^ [keywords^ [k].ordinal].nominal_index := k;
              IFEND;
            IFEND;
          FOREND;

          result := NIL;
          result_node := ^result;
          FOR k := 1 TO UPPERBOUND (matched_keywords^) DO
            IF matched_keywords^ [k].matched THEN
              IF matched_keywords^ [k].nominal_index = 0 THEN
                osp$set_status_condition (cle$bad_keyword_type_spec, status);
                EXIT evaluate_expression;
              IFEND;

              clp$make_list_value (work_area, result_node^);
              clp$make_keyword_value (keywords^ [matched_keywords^ [k].nominal_index].keyword, work_area,
                    result_node^^.element_value);

              result_sub_list_tail := result_node^;
              result_node := ^result_node^^.link;
            IFEND;
          FOREND;

        PROCEND expand_wild_card_keyword;
?? TITLE := 'expand_wild_card_name', EJECT ??

        PROCEDURE [INLINE] expand_wild_card_name;

          VAR
            candidate: ^ost$name_reference,
            node: ^clt$data_value;


          result := NIL;
          node := candidate_list;
          result_node := ^result;
          WHILE node <> NIL DO
            CASE node^.element_value^.kind OF
            = clc$data_name =
              candidate := ^node^.element_value^.data_name_value;
            = clc$name =
              candidate := ^node^.element_value^.name_value;
            ELSE { clc$program_name }
              candidate := ^node^.element_value^.program_name_value;
            CASEND;

            clp$match_string_pattern (candidate^ (1, clp$trimmed_string_size (candidate^)), string_pattern,
                  clc$sp_anchored, clc$sp_quick_scan, match_info, status);
            IF NOT status.normal THEN
              EXIT evaluate_expression;
            ELSEIF match_info.result = clc$sp_success THEN
              result_node^ := node;
              result_sub_list_tail := result_node^;
              result_node := ^node^.link;
            IFEND;
            node := node^.link;
          WHILEND;

        PROCEND expand_wild_card_name;
?? TITLE := 'get_candidate_names', EJECT ??

        PROCEDURE get_candidate_names;

          VAR
            expression: ^clt$expression_text,
            function_name: clt$function_name,
            ignore_type_description: ^clt$type_description,
            lexical_units: ^clt$lexical_units,
            local_parse: clt$parse_state;


          IF expression_type_name = NIL THEN
            osp$set_status_condition (cle$wild_card_not_allowed, status);
            EXIT evaluate_expression;
          IFEND;

          IF expression_type_name^ (1) = '$' THEN
            function_name := expression_type_name^;
          ELSE
            function_name (1) := '$';
            function_name (2, * ) := expression_type_name^;
          IFEND;
          expression := ^function_name (1, clp$trimmed_string_size (function_name));

          clp$identify_lexical_units (expression, work_area, lexical_units, status);
          IF NOT status.normal THEN
            EXIT evaluate_expression;
          IFEND;
          clp$initialize_parse_state (expression, lexical_units, local_parse);
          clp$scan_non_space_lexical_unit (local_parse);

          clp$evaluate_list_expression (1, clc$max_list_size, FALSE, current_type_description,
                work_area, local_parse, ignore_type_description,  candidate_list, status);
          IF NOT status.normal THEN
            EXIT evaluate_expression;
          IFEND;

          IF local_parse.unit_is_space THEN
            clp$scan_non_space_lexical_unit (local_parse);
          IFEND;

          IF (local_parse.unit.kind <> clc$lex_end_of_line) OR (candidate_list^.kind = clc$unspecified) THEN
            osp$set_status_abnormal ('CL', cle$no_match_for_wild_card_name, wild_card_name^, status);
            EXIT evaluate_expression;
          IFEND;

        PROCEND get_candidate_names;
?? OLDTITLE, EJECT ??

*IF NOT $true(osv$unix)
        clp$find_scl_options (scl_options);
*IFEND

        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;
        clp$rescan_wild_card_lex_unit (parse);

        CASE parse.unit.kind OF
        = clc$lex_string, clc$lex_unterminated_string =
          RETURN;
        = clc$lex_wild_card_name =
          ;
        ELSE
*IF NOT $true(osv$unix)
          IF scl_options^.wild_card_pattern_type = clc$wc_basic_pattern THEN
            RETURN;
          IFEND;
*IFEND
          wild_card_chars := $chars ['[', '{'];
          #SCAN (wild_card_chars, parse.text^ (parse.unit_index, parse.unit.size), ignore_scan_index,
                scan_found_char);
          IF NOT scan_found_char THEN
            RETURN;
          IFEND;
        CASEND;

        PUSH wild_card_name: [parse.unit.size];
*IF NOT $true(osv$unix)
        IF scl_options^.wild_card_pattern_type = clc$wc_basic_pattern THEN
          #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), wild_card_name^);
        ELSE
*IFEND
          #TRANSLATE (osv$lower_to_upper_26, parse.text^ (parse.unit_index, parse.unit.size),
                wild_card_name^);
*IF NOT $true(osv$unix)
        IFEND;
*IFEND

        clp$scan_any_lexical_unit (parse);
        recognize_binary_operator;

        IF defer_expansion THEN
          clp$make_application_value (wild_card_name^, work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT evaluate_expression;
          IFEND;
          RETURN;
        IFEND;

        IF current_type_description^.kind <> clc$keyword_type THEN
          get_candidate_names;
        IFEND;

*IF NOT $true(osv$unix)
        clp$build_pattern_for_wild_card (scl_options^.wild_card_pattern_type,
*ELSE
        clp$build_pattern_for_wild_card (clc$wc_extended_pattern,
*IFEND
              $clt$string_pattern_build_opts [clc$sp_match_at_right, clc$sp_ignore_matched_substring],
              wild_card_name^, work_area, string_pattern, status);
        IF NOT status.normal THEN
          EXIT evaluate_expression;
        IFEND;

        IF current_type_description^.kind = clc$keyword_type THEN
          expand_wild_card_keyword;
        ELSE
          expand_wild_card_name;
        IFEND;

        IF result = NIL THEN
          osp$set_status_abnormal ('CL', cle$no_match_for_wild_card_name, wild_card_name^, status);
          EXIT evaluate_expression;
        IFEND;

        result_node^ := NIL;
        result^.generated_via_list_rest := FALSE;

      PROCEND handle_wild_card_name;
?? TITLE := 'recognize_binary_operator', EJECT ??

      PROCEDURE recognize_binary_operator;


        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

        CASE parse.unit.kind OF

        = clc$lex_greater_than .. clc$lex_not_equal =
          operator.representation := parse.text^ (parse.unit_index, parse.unit.size);
          operator.kind := clc$relational_operator;
          operator.relational_kind := parse.unit.kind;
          IF parse.unit.kind = clc$lex_equal THEN
            parse_saved_at_equal_operator := parse;
          IFEND;

        = clc$lex_concatenate =
          operator.representation := parse.text^ (parse.unit_index, parse.unit.size);
          operator.kind := clc$string_operator;

        = clc$lex_exponentiate .. clc$lex_subtract =
          operator.representation := parse.text^ (parse.unit_index, parse.unit.size);
          operator.kind := clc$arithmetic_operator;
          operator.arithmetic_kind := parse.unit.kind;

        = clc$lex_name =
          IF (clc$boolean_type IN current_type_description^.kinds) AND
                (clc$or_operator_size <= parse.unit.size) AND (parse.unit.size <= clc$max_operator_size) THEN
            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size),
                  operator.representation);
            IF operator.representation = 'AND' THEN
              operator.kind := clc$logical_operator;
              operator.logical_kind := clc$and_operator;
            ELSEIF operator.representation = 'OR ' THEN
              operator.kind := clc$logical_operator;
              operator.logical_kind := clc$or_operator;
            ELSEIF operator.representation = 'XOR' THEN
              operator.kind := clc$logical_operator;
              operator.logical_kind := clc$xor_operator;
            ELSE
              operator.kind := clc$not_an_operator;
              RETURN;
            IFEND;

            IF NOT parse.previous_unit_is_space THEN
              osp$set_status_abnormal ('CL', cle$missing_spaces_before, operator.representation, status);
              EXIT evaluate_expression;
            IFEND;
            clp$scan_non_space_lexical_unit (parse);
            IF NOT parse.previous_unit_is_space THEN
              osp$set_status_abnormal ('CL', cle$missing_spaces_after, operator.representation, status);
              EXIT evaluate_expression;
            IFEND;

            operator_encountered := TRUE;

          ELSE
            operator.kind := clc$not_an_operator;
          IFEND;
          RETURN;

        ELSE
          operator.kind := clc$not_an_operator;
          RETURN;
        CASEND;

        clp$scan_non_space_lexical_unit (parse);

        operator_encountered := TRUE;

      PROCEND recognize_binary_operator;
?? TITLE := 'recognize_not_operator', EJECT ??

      FUNCTION [INLINE] recognize_not_operator: boolean;

        VAR
          name: string (clc$not_operator_size);


        recognize_not_operator := FALSE;
        IF (parse.unit.kind = clc$lex_name) AND (parse.unit.size = clc$not_operator_size) THEN
          #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
          IF name = clc$not_operator_representation THEN
            recognize_not_operator := TRUE;
          IFEND;
        IFEND;

      FUNCEND recognize_not_operator;
?? TITLE := 'simplify_real_to_integer', EJECT ??

      PROCEDURE simplify_real_to_integer
        (VAR result {input, output} : ^clt$data_value;
         VAR integer_result: clt$data_value;
         VAR real_convertable_to_integer: boolean);

        VAR
          integer_as_real: clt$real,
          real_as_integer: integer;


        integer_result.kind := clc$unspecified;

*IF NOT $true(osv$unix)
        IF NOT ((result^.kind = clc$real) AND (clc$integer_type IN current_type_description^.kinds)) THEN
          real_convertable_to_integer := FALSE;
          RETURN;
        IFEND;

        clp$convert_real_to_integer (result^.real_value.value, real_as_integer, status);
        IF NOT status.normal THEN
          real_convertable_to_integer := FALSE;
          status.normal := TRUE;
          RETURN;
        IFEND;

        real_convertable_to_integer := TRUE;

        integer_result.kind := clc$integer;
        integer_result.integer_value.value := real_as_integer;
        integer_result.integer_value.radix := 10;
        integer_result.integer_value.radix_specified := FALSE;

        clp$convert_integer_to_real (real_as_integer, integer_as_real, status);
        IF NOT status.normal THEN
          EXIT evaluate_expression;
        IFEND;

        IF clp$longreal_compare_ne (result^.real_value.value, integer_as_real.value) THEN
          RETURN;
        IFEND;

        result^ := integer_result;
*ELSE
        real_convertable_to_integer := FALSE;
*IFEND

      PROCEND simplify_real_to_integer;
?? OLDTITLE, EJECT ??

      status.normal := TRUE;
      result := NIL;
      result_sub_list_tail := NIL;
      result_type_description := NIL;

      current_type_description := type_description;
      recognize_wild_cards := FALSE;
      defer_expansion := list_expansion = clc$defer_expansion;
      operand_type_description := NIL;
      operator.kind := clc$not_an_operator;
      operator_encountered := FALSE;
      access_variable_requests := $clt$access_variable_requests [clc$return_type_description];

      IF NOT numeric_info.initialized THEN
        numeric_info.initialized := TRUE;
        numeric_info.min_real_value := clv$negative_infinity^;
        numeric_info.max_real_value := clv$positive_infinity^;
        numeric_info.min_integer_value := clc$min_integer;
        numeric_info.max_integer_value := clc$max_integer;
        numeric_info.radix.default := 10;
        numeric_info.radix.established := FALSE;
      IFEND;
      numeric_info.sign := 1;

      CASE current_type_description^.kind OF
      = clc$application_type =
        evaluate_application_value (result);
      = clc$array_type =
        evaluate_array (result);
      = clc$boolean_type =
        evaluate_boolean (TRUE, result);
      = clc$cobol_name_type =
        evaluate_cobol_name (result);
      = clc$command_reference_type =
        evaluate_command_reference (result);
      = clc$data_name_type =
        recognize_wild_cards := (list_expansion <> clc$no_expansion) AND (defer_expansion OR
              (expression_type_name <> NIL));
        evaluate_data_name (result, result_sub_list_tail);
      = clc$date_time_type =
        evaluate_date_time (result);
      = clc$entry_point_reference_type =
        evaluate_entry_point_reference (result);
*IF NOT $true(osv$unix)
      = clc$file_type =
*ELSE
      = {clc$file_type} clc$nos_ve_file_type, clc$unix_file_type =
*IFEND
        recognize_wild_cards := list_expansion <> clc$no_expansion;
*IF NOT $true(osv$unix)
        evaluate_file (result, result_sub_list_tail);
*ELSE
        evaluate_file (TRUE, result, result_sub_list_tail);
*IFEND
      = clc$integer_type =
        numeric_info.min_integer_value := current_type_description^.min_integer_value;
        numeric_info.max_integer_value := current_type_description^.max_integer_value;
        numeric_info.radix.default := current_type_description^.default_radix;
        evaluate_number (TRUE, result);
      = clc$keyword_type =
        recognize_wild_cards := list_expansion <> clc$no_expansion;
        evaluate_keyword (result);
      = clc$list_type =
        evaluate_list (result);
      = clc$lock_type =
        evaluate_lock (result);
      = clc$name_type =
        recognize_wild_cards := (list_expansion <> clc$no_expansion) AND (defer_expansion OR
              (expression_type_name <> NIL));
        evaluate_name (result, result_sub_list_tail);
      = clc$network_title_type =
        evaluate_network_title (result);
      = clc$program_name_type =
        recognize_wild_cards := (list_expansion <> clc$no_expansion) AND (defer_expansion OR
              (expression_type_name <> NIL));
        evaluate_program_name (result, result_sub_list_tail);
      = clc$range_type =
        evaluate_range (result);
      = clc$real_type =
        numeric_info.min_real_value := current_type_description^.min_real_value.long_real;
        numeric_info.max_real_value := current_type_description^.max_real_value.long_real;
        evaluate_number (TRUE, result);
      = clc$record_type =
        evaluate_record (result);
      = clc$scu_line_identifier_type =
        evaluate_scu_line_identifier (result);
      = clc$statistic_code_type =
        evaluate_statistic_code (result);
      = clc$status_type =
        evaluate_status (result);
      = clc$status_code_type =
        evaluate_status_code (result);
      = clc$string_type, clc$string_pattern_type =
        evaluate_string_or_pattern (TRUE, result);
      = clc$time_increment_type =
        evaluate_time_increment (result);
      = clc$time_zone_type =
        evaluate_time_zone (result);
      = clc$type_specification_type =
        evaluate_type_specification (result);
      = clc$union_type =
        numeric_info.min_integer_value := current_type_description^.union_information^.min_integer_value;
        numeric_info.max_integer_value := current_type_description^.union_information^.max_integer_value;
        numeric_info.radix.default := current_type_description^.union_information^.default_radix;
        numeric_info.min_real_value := current_type_description^.union_information^.min_real_value.long_real;
        numeric_info.max_real_value := current_type_description^.union_information^.max_real_value.long_real;
        evaluate_union (result);
      ELSE
        osp$set_status_condition (cle$bad_type_description, status);
      CASEND;

      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF operator.kind <> clc$not_an_operator THEN
        IF parse.previous_non_space_unit.kind <> clc$lex_equal THEN
          osp$set_status_abnormal ('CL', cle$expecting_end_of_expression, operator.representation, status);
          RETURN;
        IFEND;
        parse := parse_saved_at_equal_operator;
      IFEND;

      IF (operand_type_description <> NIL) AND (NOT operator_encountered) THEN
        result_type_description := operand_type_description;
      ELSE
        result_type_description := NIL;
      IFEND;

    PROCEND evaluate_expression;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    expression_type_name := type_description^.name;

    last_deref_result_type_desc := NIL;
    last_dereference_result := NIL;
    last_dereference_index := 1;
    last_dereference_name := '';
    last_dereference_parse.text := NIL;

    numeric_info.initialized := FALSE;
    got_present_date_time := FALSE;

*IF NOT $true(osv$unix)
    osp$establish_condition_handler (^dereference_name_reset_handler, FALSE);
*IFEND

    evaluate_expression (parse, type_description, FALSE, clc$no_expansion, numeric_info, result,
          ignore_sub_list_tail, status);

  PROCEND clp$internal_evaluate_expr;

MODEND clm$evaluate_expression;
*DECK DECK=CLM$EVALUATE_PARAMETERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Parameter List Evaluators' ??
MODULE clm$evaluate_parameters;

{
{ PURPOSE:
{   This module contains the procedures that evaluate command and function
{   parameter lists under control of a Parameter Description Table (PDT - see
{   below).  The output of these procedures is a Parameter Value Table (PVT -
{   see below) that represents the evaluated parameter list.  The routines in
{   this module are also responsible for performing interactive prompting for
{   parameters and related information.  Also in this module is the routine
{   that prepares a PDT for processing (i.e., "unbundles" it).
{
{ DESIGN:
{   The parameter list is parsed using the technique known as "recursive
{   descent".  This means that "knowledge" of the syntax of parameter lists is
{   embodied in the code rather than in syntax tables and that, in general, for
{   each syntactic construct there is a corresponding procedure to process it.
{   Evaluation of parameter values is the job of the SCL expression evaluator
{   and is therefore to be found in module clm$evaluate_expression.
{
{ NOTE:
{   The internal parameter evaluation routine is used to evaluate an expression
{   for a "record" type.  This is because such expressions have the form and
{   many of the characteristics of a parameter list for a function.  In aid of
{   this, the "type description" for a "record" type is in the form of an
{   "unbundled" PDT.
{

?? NEWTITLE := 'Global Declarations' ??
?? NEWTITLE := 'Parameter List', EJECT ??
*copyc clt$parameter_list
*copyc clt$parameter_list_text
*copyc clt$parameter_list_text_index
*copyc clt$parameter_list_text_size
*copyc clt$i_parameter_list_contents
?? TITLE := 'Parameter Description Table (PDT)', EJECT ??
*copyc clt$parameter_description_table
?? TITLE := 'Unbundled Parameter Description Table', EJECT ??
*copyc clt$unbundled_pdt
?? TITLE := 'Parameter Value Table (PVT)', EJECT ??
*copyc clt$parameter_value_table
?? TITLE := 'clt$parameter_dialog_manager', EJECT ??
*copyc clh$parameter_dialog_manager
*copyc clt$parameter_dialog_manager
?? OLDTITLE, EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc cle$bad_declaration_version
*copyc cle$bad_parameter_list
*copyc cle$bad_pdt
*copyc cle$bad_pvt
*copyc cle$command_cancelled
*copyc cle$command_terminated
*copyc cle$ecc_file_reference
*copyc cle$ecc_lexical
*copyc cle$ecc_parsing
*copyc cle$function_cancelled
*IF $true(osv$unix)
*copyc cle$not_supported
*IFEND
*copyc cle$param_dialog_not_privileged
*copyc cle$parameters_displayed
*copyc cle$unable_to_call_check_proc
*copyc cle$unable_to_call_parm_dlg_mgr
*copyc cle$unexpected_call_to
*copyc cle$var_sub_params_not_allowed
*IF $true(osv$unix)
*copyc cle$work_area_overflow
*IFEND
*copyc clk$pop_parameters
*copyc clk$push_parameters
*copyc clk$scan_parameter_list
*copyc clt$check_parameters_procedure
*copyc clt$command_line
*copyc clt$command_line_index
*copyc clt$command_line_size
*copyc clt$interpreter_modes
*copyc clt$parameter_index
*copyc clt$parameter_name_index
*copyc clt$parameter_reference
*copyc clt$pdt_changes
*copyc clt$scl_procedure
*copyc clt$scl_procedure_header
*copyc clt$work_area
*copyc ift$format_effectors
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc ost$help_module
*copyc ost$status
?? POP ??
*IF NOT $true(osv$unix)
*copyc amp$fetch
*copyc amp$put_next
*copyc amp$put_partial
*copyc avp$ring_min
*IFEND
*copyc clp$append_status_parse_state
*IF NOT $true(osv$unix)
*copyc clp$append_status_type_desc
*copyc clp$change_type_specification
*IFEND
*copyc clp$convert_type_spec_to_desc
*IF NOT $true(osv$unix)
*copyc clp$copy_data_value
*IFEND
*copyc clp$data_representation_text
*copyc clp$display_cmnd_or_func_info
*IF NOT $true(osv$unix)
*copyc clp$echo_command
*copyc clp$evaluate_name
*copyc clp$evaluate_name_for_write
*copyc clp$find_current_block
*copyc clp$find_scl_options
*copyc clp$get_all_cmnd_or_func_names
*copyc clp$get_cmnd_or_func_source_str
*copyc clp$get_command_line
*copyc clp$get_parameter_list_parse
*copyc clp$get_system_file_id
*copyc clp$get_work_area
*ELSE
*copyc clc$declaration_version
*copyc cle$pdt_processor_mismatch
*copyc clp_getenv
*copyc clp$get_parameter_list_parse
*IFEND
*copyc clp$identify_lexical_units
*IF NOT $true(osv$unix)
*copyc clp$include_line
*IFEND
*copyc clp$initialize_parse_state
*IF NOT $true(osv$unix)
*copyc clp$internal_convert_to_string
*IFEND
*copyc clp$internal_evaluate_expr
*IF NOT $true(osv$unix)
*copyc clp$load_system_entry_point
*copyc clp$log_command_line
*IFEND
*copyc clp$make_deferred_value
*IF NOT $true(osv$unix)
*copyc clp$pass_variable_parameter
*copyc clp$pop_block_stack
*copyc clp$pop_interactive_input
*IFEND
*copyc clp$produce_variable_ref_expr
*IF NOT $true(osv$unix)
*copyc clp$push_interactive_input
*copyc clp$push_sub_parameters_block
*IFEND
*copyc clp$save_evaluated_parameters
*copyc clp$scan_any_lexical_unit
*IF NOT $true(osv$unix)
*copyc clp$scan_bal_paren_lexical_unit
*IFEND
*copyc clp$scan_non_space_lexical_unit
*copyc clp$scan_to_lexical_limit
*copyc clp$scan_unnested_sep_lex_unit
*copyc clp$search_parameter_names
*copyc clp$reset_input_state
*copyc clp$setup_parameter_evaluation
*IF NOT $true(osv$unix)
*copyc clp$set_prompting_input
*IFEND
*copyc clp$trimmed_string_size
*IF NOT $true(osv$unix)
*copyc clp$unpass_variable_parameter
*copyc clp$validate_var_conformance
*copyc clv$standard_files
*copyc ifp$change_terminal_attributes
*copyc ifp$discard_suspended_output
*copyc ifp$fetch_context
*copyc ifp$get_terminal_attributes
*IFEND
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*IF NOT $true(osv$unix)
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$file_access_condition
*copyc osp$find_brief_help_message
*copyc osp$find_full_help_message
*copyc osp$find_help_module
*copyc osp$find_parameter_prompt
*copyc osp$find_param_assist_prompt
*copyc osp$find_parameter_help_message
*copyc osp$format_help_message
*copyc osp$generate_message
*copyc osp$generate_output_message
*IFEND
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*IF NOT $true(osv$unix)
*copyc osv$initial_exception_context
*IFEND
*copyc osv$lower_to_upper
*copyc osv$upper_to_lower
*IF NOT $true(osv$unix)
*copyc pmp$change_term_error_level
*copyc pmp$continue_to_cause
*copyc pmp$load
?? EJECT ??
*copyc clc$system_messages_module

{
{ The following constants define the names of particular prompts within
{ the standard prompts and messages module.
{

  CONST
    clc$all_command_params_correct = 'CLC$ALL_COMMAND_PARAMS_CORRECT ',
    clc$confirm_new_param_version = 'CLC$CONFIRM_NEW_PARAM_VERSION  ',
    clc$confirm_param_default_value = 'CLC$CONFIRM_PARAM_DEFAULT_VALUE',
    clc$confirm_parameter_name = 'CLC$CONFIRM_PARAMETER_NAME     ',
    clc$correct_command_params_msg = 'CLC$CORRECT_COMMAND_PARAMS_MSG ',
    clc$correct_function_params_msg = 'CLC$CORRECT_FUNCTION_PARAMS_MSG',
    clc$correct_parameters_prompt = 'CLC$CORRECT_PARAMETERS_PROMPT  ',
    clc$default_param_assist_prompt = 'CLC$DEFAULT_PARAM_ASSIST_PROMPT',
    clc$default_parameter_prompt = 'CLC$DEFAULT_PARAMETER_PROMPT   ',
    clc$enter_command_params_msg = 'CLC$ENTER_COMMAND_PARAMS_MSG   ',
    clc$enter_function_params_msg = 'CLC$ENTER_FUNCTION_PARAMS_MSG  ',
    clc$no_command_params_msg = 'CLC$NO_COMMAND_PARAMS_MSG      ',
    clc$no_function_params_msg = 'CLC$NO_FUNCTION_PARAMS_MSG     ',
    clc$prompt_for_advanced_param = 'CLC$PROMPT_FOR_ADVANCED_PARAM  ',
    clc$prompt_for_parameter_name = 'CLC$PROMPT_FOR_PARAMETER_NAME  ';

{
{ The following constants define the entry point names for the dynamically
{ loaded parameter dialog managers.
{

  CONST
    clc$desktop_param_dialog_mgr = 'DEP$SCL_PARAMETER_DIALOG_MGR   ',
    clc$screen_param_dialog_mgr = 'CLP$SCL_PARAMETER_DIALOG_MGR   ';

?? TITLE := 'clp$get_parameter_list_text', EJECT ??
*copyc clh$get_parameter_list_text

  PROCEDURE [XDCL, #GATE] clp$get_parameter_list_text
    (    parameter_list: ^clt$parameter_list;
     VAR parameter_list_text: ^clt$parameter_list_text;
     VAR status: ost$status);

    VAR
      parameter_list_area: ^clt$parameter_list,
      parameter_list_contents: ^clt$i_parameter_list_contents;

?? NEWTITLE := 'get_text_from_block', EJECT ??

    PROCEDURE [INLINE] get_text_from_block
      (VAR parameter_list_text: ^clt$parameter_list_text);

      VAR
        block: ^clt$block,
        parameters_block: ^clt$block;


      parameter_list_text := NIL;

      clp$find_current_block (block);
      parameters_block := NIL;
      CASE block^.kind OF
      = clc$command_block, clc$function_block, clc$sub_parameters_block =
        parameters_block := block;
      = clc$task_block =
        IF block^.task_kind = clc$other_task THEN
          IF block^.synchronous_with_parent AND (block^.previous_block^.kind = clc$command_block) AND
                (block^.previous_block^.command_kind = clc$program_command) THEN
            parameters_block := block^.previous_block;
          ELSE
            parameters_block := block;
          IFEND;
        IFEND;
      ELSE
        ;
      CASEND;
      IF parameters_block = NIL THEN
        RETURN;
      IFEND;

      parameter_list_text := ^parameters_block^.line_parse.
            text^ (parameters_block^.line_parse.unit_index, parameters_block^.line_parse.index_limit -
            parameters_block^.line_parse.unit_index);

    PROCEND get_text_from_block;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    parameter_list_text := NIL;

  /get_text/
    BEGIN
      IF parameter_list = NIL THEN
        EXIT /get_text/;
      IFEND;

      parameter_list_area := parameter_list;
      RESET parameter_list_area;
      NEXT parameter_list_contents IN parameter_list_area;

      IF parameter_list_contents = NIL THEN
        EXIT /get_text/;
      IFEND;

      IF (parameter_list_contents^.identifying_size_field =
            UPPERVALUE (parameter_list_contents^.identifying_size_field)) AND
            (#SIZE (parameter_list^) = #SIZE (clt$i_parameter_list_contents)) THEN
        get_text_from_block (parameter_list_text);
      ELSE
        NEXT parameter_list_text: [parameter_list_contents^.identifying_size_field] IN parameter_list_area;
      IFEND;
    END /get_text/;

    IF parameter_list_text = NIL THEN
      osp$set_status_condition (cle$bad_parameter_list, status);
    IFEND;

  PROCEND clp$get_parameter_list_text;
?? TITLE := 'clp$get_reason_for_call', EJECT ??
*copyc clh$get_reason_for_call

  PROCEDURE [XDCL, #GATE] clp$get_reason_for_call
    (VAR information_request: boolean;
     VAR display_file: fst$path;
     VAR prompting_activated: boolean;
     VAR status: ost$status);

    VAR
      evaluation_context: clt$parameter_eval_context,
      help_context: clt$parameter_help_context,
      ignore_parse: clt$parse_state,
      ignore_prompting_style: ost$interaction_style,
      ignore_work_area_ptr: ^^clt$work_area,
      local_status: ost$status;


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

  /get_reason_for_call/
    BEGIN
      clp$setup_parameter_evaluation (NIL, osc$null_name, FALSE, ignore_parse,
            ignore_work_area_ptr, evaluation_context, help_context, local_status);
      IF NOT local_status.normal THEN
        EXIT /get_reason_for_call/;
      IFEND;

      information_request := evaluation_context.interpreter_mode = clc$help_mode;

      IF help_context.help_output_file = NIL THEN
        display_file := '';
      ELSE
        display_file := help_context.help_output_file^;
      IFEND;

      determine_prompting_style (evaluation_context, prompting_activated, ignore_prompting_style,
            local_status);
      local_status.normal := TRUE;
    END /get_reason_for_call/;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSEIF local_status.condition = cle$unexpected_call_to THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$get_reason_for_call', status);
    ELSE
      status := local_status;
    IFEND;

  PROCEND clp$get_reason_for_call;
?? TITLE := 'clp$log_and_or_echo_command', EJECT ??
*copyc clh$log_and_or_echo_command

  PROCEDURE [XDCL, #GATE] clp$log_and_or_echo_command
    (    edited_parameter_list_text: clt$parameter_list_text;
     VAR status: ost$status);

    VAR
      edited_command: ^clt$command_line,
      edited_command_size: integer,
      edited_parameter_list_text_size: clt$parameter_list_text_size,
      evaluation_context: clt$parameter_eval_context,
      help_context: clt$parameter_help_context,
      ignore_work_area_ptr: ^^clt$work_area,
      local_status: ost$status,
      parse: clt$parse_state;


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

  /log_and_or_echo_command/
    BEGIN
      clp$setup_parameter_evaluation (NIL, osc$null_name, TRUE, parse, ignore_work_area_ptr,
            evaluation_context, help_context, local_status);
      IF NOT local_status.normal THEN
        EXIT /log_and_or_echo_command/;
      IFEND;

      edited_parameter_list_text_size := clp$trimmed_string_size (edited_parameter_list_text);
      edited_command_size := evaluation_context.command_or_function_source^.reference_size + 1 +
            edited_parameter_list_text_size;
      IF edited_command_size > clc$max_command_line_size THEN
        edited_command_size := clc$max_command_line_size;
      IFEND;

      PUSH edited_command: [edited_command_size];
      edited_command^ (1, evaluation_context.command_or_function_source^.reference_size) :=
            parse.text^ (evaluation_context.command_or_function_source^.reference_index,
            evaluation_context.command_or_function_source^.reference_size);
      IF evaluation_context.command_or_function_source^.reference_size < edited_command_size THEN
        edited_command^ (evaluation_context.command_or_function_source^.reference_size + 1) := ' ';
        edited_command^ (evaluation_context.command_or_function_source^.reference_size + 2, * ) :=
              edited_parameter_list_text (1, edited_parameter_list_text_size);
      IFEND;

      IF NOT evaluation_context.command_logging_completed THEN
        clp$log_command_line (edited_command^, local_status);
        local_status.normal := TRUE;
      IFEND;

      IF NOT evaluation_context.command_echoing_completed THEN
        clp$echo_command (evaluation_context.interpreter_mode, edited_command^, {ignore} local_status);
        local_status.normal := TRUE;
      IFEND;
    END /log_and_or_echo_command/;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSEIF local_status.condition = cle$unexpected_call_to THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$log_and_or_echo_command', status);
    ELSE
      status := local_status;
    IFEND;

  PROCEND clp$log_and_or_echo_command;
*IFEND
?? TITLE := 'clp$evaluate_parameters', EJECT ??
*copyc clh$evaluate_parameters

  PROCEDURE [XDCL, #GATE] clp$evaluate_parameters
    (    parameter_list: clt$parameter_list;
         parameter_description_table: ^clt$parameter_description_table;
         check_parameters_procedure: clt$check_parameters_procedure;
         parameter_value_table: ^clt$parameter_value_table;
     VAR status: ost$status);

    VAR
      command_reference_text: ^clt$command_line,
      edited_command: ^clt$command_line,
      evaluation_context: clt$parameter_eval_context,
      help_context: clt$parameter_help_context,
      ignore_status: ^ost$status,
      local_status: ost$status,
      parse: clt$parse_state,
      pdt: ^clt$unbundled_pdt,
      work_area_ptr: ^^clt$work_area;


    #KEYPOINT (osk$entry, 1, clk$scan_parameter_list);

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

  /evaluate/
    BEGIN
      clp$setup_parameter_evaluation (NIL, osc$null_name, TRUE, parse, work_area_ptr,
            evaluation_context, help_context, local_status);
      IF NOT local_status.normal THEN
        IF local_status.condition = cle$unexpected_call_to THEN
          local_status.text.size := 0;
          osp$append_status_parameter (osc$status_parameter_delimiter, 'clp$evaluate_parameters',
                local_status);
        IFEND;
        EXIT /evaluate/;
      IFEND;

      IF parse.text = NIL THEN
        command_reference_text := NIL;
      ELSE
        IF (evaluation_context.interpreter_mode = clc$interpret_mode) AND
              (evaluation_context.prompting_requested) THEN
          command_reference_text := ^parse.text^ (evaluation_context.command_or_function_source^.
                reference_index-1, evaluation_context.command_or_function_source^.reference_size+1);
        ELSE
          command_reference_text := ^parse.text^ (evaluation_context.command_or_function_source^.
                reference_index, evaluation_context.command_or_function_source^.reference_size);
        IFEND;
      IFEND;

      clp$get_parameter_list_parse (^parameter_list, work_area_ptr^, parse, local_status);
      IF NOT local_status.normal THEN
        EXIT /evaluate/;
      IFEND;

      NEXT pdt IN work_area_ptr^;
      clp$unbundle_pdt (parameter_description_table, work_area_ptr^, pdt^, local_status);
      IF NOT local_status.normal THEN
        EXIT /evaluate/;
      IFEND;

      IF evaluation_context.command_or_function <> pdt^.header^.command_or_function THEN
        osp$set_status_condition (cle$pdt_processor_mismatch, local_status);
        EXIT /evaluate/;
      IFEND;

      IF (evaluation_context.interpreter_mode = clc$help_mode) AND (help_context.help_output_file <> NIL) THEN
*IF NOT $true(osv$unix)
        clp$display_cmnd_or_func_info (fsc$list, help_context, evaluation_context.command_or_function_source^,
              evaluation_context.command_or_function_name, pdt^, local_status);
*ELSE
        clp$display_cmnd_or_func_info (fsc$legible_data, help_context,
              evaluation_context.command_or_function_source^,
              evaluation_context.command_or_function_name, pdt^, local_status);
*IFEND
        IF local_status.normal THEN
          osp$set_status_condition (cle$parameters_displayed, local_status);
        IFEND;
        EXIT /evaluate/;
      IFEND;

      clp$internal_evaluate_params (evaluation_context, pdt^, check_parameters_procedure, parse,
            work_area_ptr^, parameter_value_table, local_status);
      IF (NOT local_status.normal) AND (local_status.condition = cle$bad_pvt) THEN
        EXIT /evaluate/;
      IFEND;

      IF NOT (evaluation_context.command_logging_completed AND evaluation_context.command_echoing_completed)
            THEN
*IF NOT $true(osv$unix)
        clp$prepare_for_log_and_or_echo (command_reference_text, pdt, parameter_value_table, work_area_ptr^,
                edited_command);
        PUSH ignore_status;
        IF NOT evaluation_context.command_logging_completed THEN
          clp$log_command_line (edited_command^, ignore_status^);
        IFEND;
        IF NOT evaluation_context.command_echoing_completed THEN
          clp$echo_command (evaluation_context.interpreter_mode, edited_command^, ignore_status^);
        IFEND;
*IFEND
      IFEND;

      clp$save_evaluated_parameters (pdt, parameter_value_table, FALSE, work_area_ptr^, local_status);
    END /evaluate/;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 1, clk$scan_parameter_list);

  PROCEND clp$evaluate_parameters;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$prepare_for_log_and_or_echo', EJECT ??

  PROCEDURE [XDCL] clp$prepare_for_log_and_or_echo
    (    command_reference_text: ^clt$command_line;
         pdt: ^clt$unbundled_pdt;
         pvt: ^clt$parameter_value_table;
     VAR work_area {input, output} : ^clt$work_area;
     VAR edited_command: ^clt$command_line);

    VAR
      representation: ^clt$data_representation,
      request: clt$convert_to_string_request,
      status: ost$status;


    edited_command := command_reference_text;

    request.initial_indentation := 0;
    request.continuation_indentation := 0;
    request.max_string := clc$max_command_line_size;
    request.include_advanced_items := TRUE;
    request.include_hidden_items := TRUE;
    request.kind := clc$convert_parameters;
    request.initial_text := command_reference_text;
    request.include_secure_parameters := FALSE;
    request.evaluated_pdt := pdt;
    request.evaluated_pvt := pvt;
    request.parameter_substitutions := NIL;

    clp$internal_convert_to_string (request, work_area, representation, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    edited_command := clp$data_representation_text (representation);

  PROCEND clp$prepare_for_log_and_or_echo;
*IFEND
?? TITLE := 'clp$get_parameter_number', EJECT ??
*copyc clh$get_parameter_number

  PROCEDURE [XDCL, #GATE] clp$get_parameter_number
    (    parameter_description_table: ^clt$parameter_description_table;
         parameter_name: clt$parameter_reference;
     VAR parameter_number: clt$parameter_number;
     VAR status: ost$status);

    VAR
      found: boolean,
      header: ^clt$pdt_header,
      index: clt$parameter_name_index,
      names: ^clt$pdt_parameter_names,
      pdt_area: ^clt$parameter_description_table,
      translated_name: clt$parameter_name;


    status.normal := TRUE;

  /get_parameter_number/
    BEGIN
      pdt_area := parameter_description_table;
      NEXT header IN pdt_area;
      IF header = NIL THEN
        osp$set_status_condition (cle$bad_pdt, status);
        EXIT /get_parameter_number/;
      IFEND;

      IF header^.number_of_parameter_names = 0 THEN
        found := FALSE;
      ELSE
        NEXT names: [1 .. header^.number_of_parameter_names] IN pdt_area;
        IF names = NIL THEN
          osp$set_status_condition (cle$bad_pdt, status);
          EXIT /get_parameter_number/;
        IFEND;
        #TRANSLATE (osv$lower_to_upper, parameter_name, translated_name);
        clp$search_parameter_names (translated_name, names, index, found);
      IFEND;

      IF NOT found THEN
        osp$set_status_abnormal ('CL', cle$unknown_parameter_name, parameter_name, status);
        EXIT /get_parameter_number/;
      IFEND;

      IF (names^ [index].position < 1) OR (names^ [index].position > header^.number_of_parameters) THEN
        osp$set_status_condition (cle$bad_pdt, status);
        EXIT /get_parameter_number/;
      IFEND;

      parameter_number := names^ [index].position;
    END /get_parameter_number/;

  PROCEND clp$get_parameter_number;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$push_parameters', EJECT ??
*copyc clh$push_parameters

  PROCEDURE [XDCL, #GATE] clp$push_parameters
    (VAR status: ost$status);


    #KEYPOINT (osk$entry, 0, clk$push_parameters);

    status.normal := TRUE;
    clp$push_sub_parameters_block (TRUE);

    #KEYPOINT (osk$exit, 0, clk$push_parameters);

  PROCEND clp$push_parameters;
?? TITLE := 'clp$pop_parameters', EJECT ??
*copyc clh$pop_parameters

  PROCEDURE [XDCL, #GATE] clp$pop_parameters
    (VAR status: ost$status);

    VAR
      block: ^clt$block;


    #KEYPOINT (osk$entry, 0, clk$pop_parameters);

    status.normal := TRUE;
    clp$find_current_block (block);
    IF block^.kind <> clc$sub_parameters_block THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$pop_parameters', status);
    ELSE
      clp$pop_block_stack (block);
    IFEND;

    #KEYPOINT (osk$exit, 0, clk$pop_parameters);

  PROCEND clp$pop_parameters;
?? TITLE := 'clp$evaluate_sub_parameters', EJECT ??
*copyc clh$evaluate_sub_parameters

  PROCEDURE [XDCL, #GATE] clp$evaluate_sub_parameters
    (    parameter_list_text: clt$parameter_list_text;
         parameter_description_table: ^clt$parameter_description_table;
     VAR work_area {input, output} : ^clt$work_area;
         parameter_value_table: ^clt$parameter_value_table;
     VAR status: ost$status);

    VAR
      i: clt$parameter_number,
      lexical_units: ^clt$lexical_units,
      local_status: ost$status,
      local_work_area: ^^clt$work_area,
      local_value: ^clt$data_value,
      local_variable: ^clt$variable_ref_expression,
      original_local_work_area: ^clt$work_area,
      parse: clt$parse_state;


    #KEYPOINT (osk$entry, 2, clk$scan_parameter_list);

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

  /evaluate/
    BEGIN
*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^local_work_area), local_work_area, local_status);
*ELSE
      clp$get_work_area (osc$user_ring, local_work_area, local_status);
*IFEND
      IF NOT local_status.normal THEN
        EXIT /evaluate/;
      IFEND;
      original_local_work_area := local_work_area^;

      clp$identify_lexical_units (^parameter_list_text, local_work_area^, lexical_units, local_status);
      IF NOT local_status.normal THEN
        EXIT /evaluate/;
      IFEND;
      clp$initialize_parse_state (^parameter_list_text, lexical_units, parse);
      clp$scan_non_space_lexical_unit (parse);

      clp$internal_evaluate_sub_param (parse, parameter_description_table, local_work_area^,
            parameter_value_table, local_status);
      IF NOT local_status.normal THEN
        EXIT /evaluate/;
      IFEND;

*IF NOT $true(osv$unix)
      IF #SEGMENT (work_area) = #SEGMENT (local_work_area^) THEN
*ELSE
      IF #LOC (work_area^) = #LOC (local_work_area^^) THEN
*IFEND
        EXIT /evaluate/;
      IFEND;

    /copy_values/
      FOR i := 1 TO UPPERBOUND (parameter_value_table^) DO
        IF parameter_value_table^ [i].passing_method = clc$pass_by_value THEN
          local_value := parameter_value_table^ [i].value;
          IF local_value <> NIL THEN
            clp$copy_data_value (local_value, work_area, parameter_value_table^ [i].value, local_status);
            IF NOT local_status.normal THEN
              EXIT /copy_values/;
            IFEND;
          IFEND;
        ELSE {clc$pass_by_reference }
          local_variable := parameter_value_table^ [i].variable;
          IF local_variable <> NIL THEN
            NEXT parameter_value_table^ [i].variable: [STRLENGTH (local_variable^)] IN work_area;
            IF parameter_value_table^ [i].variable = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, local_status);
              EXIT /copy_values/;
            IFEND;
            parameter_value_table^ [i].variable^ := local_variable^;
          IFEND;
        IFEND;
      FOREND /copy_values/;

      local_work_area^ := original_local_work_area;
    END /evaluate/;

    IF NOT local_status.normal THEN
      IF local_status.condition = cle$work_area_overflow THEN
        local_status.text.size := 0;
        osp$append_status_parameter (osc$status_parameter_delimiter, 'clp$evaluate_sub_parameters',
              local_status);
      IFEND;
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 2, clk$scan_parameter_list);

  PROCEND clp$evaluate_sub_parameters;
?? TITLE := 'clp$internal_evaluate_sub_param', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$internal_evaluate_sub_param
    (VAR parse {input, output} : clt$parse_state;
         parameter_description_table: ^clt$parameter_description_table;
     VAR work_area {input, output} : ^clt$work_area;
         parameter_value_table: ^clt$parameter_value_table;
     VAR status: ost$status);

    VAR
      evaluation_context: clt$parameter_eval_context,
      pdt: clt$unbundled_pdt;


    clp$unbundle_pdt (parameter_description_table, work_area, pdt, status);
    IF NOT status.normal THEN
      RETURN;
    ELSEIF pdt.header^.number_of_var_parameters > 0 THEN
      osp$set_status_condition (cle$var_sub_params_not_allowed, status);
      RETURN;
    IFEND;

    evaluation_context.interpreter_mode := clc$interpret_mode;
    evaluation_context.interactive_origin := FALSE;
    evaluation_context.interaction_style := osc$line_interaction;
    evaluation_context.prompting_requested := FALSE;
    evaluation_context.command_or_function_name := osc$null_name;
    evaluation_context.command_or_function := clc$command;
    evaluation_context.procedure_parameters := FALSE;
    evaluation_context.command_logging_completed := TRUE;
    evaluation_context.command_echoing_completed := TRUE;

    clp$internal_evaluate_params (evaluation_context, pdt, NIL, parse, work_area, parameter_value_table,
          status);

  PROCEND clp$internal_evaluate_sub_param;
*IFEND
?? TITLE := 'clp$internal_evaluate_params', EJECT ??

  PROCEDURE [XDCL] clp$internal_evaluate_params
    (    evaluation_context: clt$parameter_eval_context;
         pdt: clt$unbundled_pdt;
         check_parameters_procedure: clt$check_parameters_procedure;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
         pvt: ^clt$parameter_value_table;
     VAR status: ost$status);

    CONST
      clc$escape_prefix = '/',
      clc$help_request = '?',
      clc$terminator_suffix = ';';

    TYPE
      clt$dialog_control = record
        prompted_for_parameter: ^array [1 .. * ] of boolean,
        parameters_to_prompt_for: boolean,
        activated: boolean,
        command_or_function_name: clt$command_name,
        cancelled_status_code: ost$status_condition_code,
        searched_for_help_module: boolean,
        help_module: ^ost$help_module,
        online_manual_name: ost$online_manual_name,
        default_help_module: ^ost$help_module,
        open: boolean,
        case interaction_style: ost$interaction_style of
        = osc$line_interaction =
          reply_parse: clt$parse_state,
          null_reply: boolean,
          terminator_in_reply: boolean,
          output_file_id: amt$file_identifier,
          page_width: ost$max_status_message_line,
          prompting_for_advanced_params: boolean,
        = osc$screen_interaction =
          ,
        = osc$desktop_interaction =
          ,
        casend,
      recend;

    VAR
      check_procedure_called: boolean,
      dialog_control: clt$dialog_control,
      general_param_checks_performed: boolean,
      ignore_terminate_breaks: boolean,
      ignore_status: ost$status,
      parameter_defaults_evaluated: boolean,
      prompt_for_all_parameters: boolean,
      required_parameters_checked: boolean,
      save_source_of_expressions: boolean;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'abort_handler', EJECT ??

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


      CASE condition.selector OF

      = pmc$block_exit_processing =
        close_dialog;
        RETURN;

      = ifc$interactive_condition =
        IF (condition.interactive_condition = ifc$terminate_break) AND ignore_terminate_breaks THEN
          RETURN;
        IFEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
*IFEND
?? TITLE := 'check_reply_for_name', EJECT ??

    PROCEDURE check_reply_for_name
      (VAR name: ost$name;
       VAR local_status: ost$status);


      local_status.normal := TRUE;

      clp$scan_non_space_lexical_unit (dialog_control.reply_parse);
      CASE dialog_control.reply_parse.unit.kind OF

      = clc$lex_name =
        #TRANSLATE (osv$lower_to_upper, dialog_control.reply_parse.
              text^ (dialog_control.reply_parse.unit_index, dialog_control.reply_parse.unit.size), name);
        clp$scan_non_space_lexical_unit (dialog_control.reply_parse);
        IF dialog_control.reply_parse.unit_index >= dialog_control.reply_parse.index_limit THEN
          RETURN;
        IFEND;

      = clc$lex_long_name =
        osp$set_status_abnormal ('CL', cle$name_too_long, dialog_control.reply_parse.
              text^ (dialog_control.reply_parse.unit_index, dialog_control.reply_parse.unit.size),
              local_status);
        RETURN;

      ELSE
        ;
      CASEND;

      osp$set_status_abnormal ('CL', cle$improper_name, dialog_control.reply_parse.
            text^ (1, dialog_control.reply_parse.index_limit - 1), local_status);

    PROCEND check_reply_for_name;
?? TITLE := 'check_required_parameters_given', EJECT ??

    PROCEDURE check_required_parameters_given
      (VAR which_parameter: clt$which_parameter;
       VAR local_status: ost$status);

      VAR
        parameter_number: clt$parameter_number;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'prompt_for_required_parameter', EJECT ??

      PROCEDURE [INLINE] prompt_for_required_parameter;

        VAR
          message: ost$status_message,
          which_parameter: clt$which_parameter;


        open_line_style_dialog;
        get_parameter_prompt (parameter_number, dialog_control.page_width, message);
        REPEAT
          which_parameter.specific := TRUE;
          which_parameter.number := parameter_number;
          put_prompt_and_get_reply (message, which_parameter);
          dialog_control.prompted_for_parameter^ [parameter_number] := TRUE;
          IF NOT dialog_control.null_reply THEN
            evaluate_nested_parameters (parameter_number);
          IFEND;
        UNTIL pvt^ [parameter_number].specified;

      PROCEND prompt_for_required_parameter;
?? OLDTITLE, EJECT ??
*IFEND

      local_status.normal := TRUE;

      FOR parameter_number := 1 TO pdt.header^.number_of_parameters DO
        IF (NOT pvt^ [parameter_number].specified) AND (pdt.parameters^ [parameter_number].requirement =
              clc$required_parameter) THEN

*IF NOT $true(osv$unix)
          IF (NOT dialog_control.activated) OR (dialog_control.interaction_style <> osc$line_interaction) THEN
*IFEND
            which_parameter.specific := TRUE;
            which_parameter.number := parameter_number;
            osp$set_status_abnormal ('CL', cle$required_parameter_omitted, pdt.
                  names^ [pdt.parameters^ [parameter_number].name_index].name, local_status);
            RETURN;
*IF NOT $true(osv$unix)
          IFEND;
          REPEAT
            prompt_for_required_parameter;
          UNTIL pvt^ [parameter_number].specified;
*IFEND

        IFEND;
      FOREND;

      required_parameters_checked := TRUE;

    PROCEND check_required_parameters_given;
*IF NOT $true(osv$unix)
?? TITLE := 'close_dialog', EJECT ??

    PROCEDURE [INLINE] close_dialog;


      IF NOT dialog_control.open THEN
        RETURN;
      IFEND;

      clp$pop_interactive_input (ignore_status);

      dialog_control.open := FALSE;

    PROCEND close_dialog;
?? TITLE := 'convert_name_to_message_param', EJECT ??

    PROCEDURE [INLINE] convert_name_to_message_param
      (VAR name {input, output} : ost$name);

      VAR
        i: 1 .. osc$max_name_size,
        new_word: boolean;


      new_word := TRUE;
      FOR i := 1 TO osc$max_name_size DO
        IF name (i) = ' ' THEN
          RETURN;
        ELSEIF name (i) = '_' THEN
          name (i) := ' ';
          new_word := TRUE;
        ELSEIF new_word THEN
          new_word := FALSE;
        ELSE
          name (i) := osv$upper_to_lower ($INTEGER (name (i)) + 1);
        IFEND;
      FOREND;

    PROCEND convert_name_to_message_param;
*IFEND
?? TITLE := 'evaluate_nested_parameters', EJECT ??

    PROCEDURE evaluate_nested_parameters
      (    first_parameter_number: clt$parameter_number);

      VAR
        local_status: ost$status,
        parse: clt$parse_state;


      local_status.normal := TRUE;

      parse := dialog_control.reply_parse;
      PUSH parse.text: [STRLENGTH (dialog_control.reply_parse.text^)];
      parse.text^ := dialog_control.reply_parse.text^;
      PUSH parse.units_array: [1 .. UPPERBOUND (dialog_control.reply_parse.units_array^)];
      parse.units_array^ := dialog_control.reply_parse.units_array^;

      clp$scan_non_space_lexical_unit (parse);

      evaluate_parameters (FALSE, first_parameter_number, parse, local_status);
*IF NOT $true(osv$unix)
      IF NOT local_status.normal THEN
        put_status (local_status);
      IFEND;
*IFEND

    PROCEND evaluate_nested_parameters;
?? TITLE := 'evaluate_parameters', EJECT ??

    PROCEDURE evaluate_parameters
      (    original_parameters: boolean;
           first_parameter_number: clt$parameter_number;
       VAR parse {input, output} : clt$parse_state;
       VAR local_status: ost$status);

      VAR
        parameter_number: clt$parameter_index,
        error_found: boolean,
        evaluating_first_parameter: boolean;

?? NEWTITLE := 'evaluate_parameter', EJECT ??

      PROCEDURE evaluate_parameter;

        VAR
          expression_parse: clt$parse_state,
          expression_text: ^clt$expression_text,
          confirmed: boolean,
          list_rest_parameter: boolean,
          parameter_given_by_name: boolean,
          parameter_name: clt$parameter_name,
          which_parameter: clt$which_parameter;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'confirm_parameter_name', EJECT ??

        PROCEDURE confirm_parameter_name;

          VAR
            message: ost$status_message;

?? NEWTITLE := 'get_confirm_param_name_prompt', EJECT ??

          PROCEDURE [INLINE] get_confirm_param_name_prompt;

            VAR
              message_parameters: array [1 .. 1] of ^ost$message_parameter,
              message_template: ^ost$message_template;


            find_default_help_module;

            osp$find_param_assist_prompt (dialog_control.default_help_module, clc$confirm_parameter_name,
                  message_template, ignore_status);

            message_parameters [1] := ^parameter_name;
            format_message (message_template, dialog_control.page_width, ^message_parameters, message);

          PROCEND get_confirm_param_name_prompt;
?? OLDTITLE, EJECT ??

          open_line_style_dialog;
          get_confirm_param_name_prompt;
          put_status (local_status);
          put_prompt_and_get_yn_reply (message, which_parameter, confirmed);

        PROCEND confirm_parameter_name;
*IFEND
?? TITLE := 'evaluate_parameter_name', EJECT ??

        PROCEDURE evaluate_parameter_name;

?? NEWTITLE := 'prompt_for_parameter_name', EJECT ??

          PROCEDURE prompt_for_parameter_name;

*IF NOT $true(osv$unix)
            VAR
              message: ost$status_message,
              message_template: ^ost$message_template,
              which_parameter: clt$which_parameter;


            open_line_style_dialog;

            find_default_help_module;
            osp$find_param_assist_prompt (dialog_control.default_help_module, clc$prompt_for_parameter_name,
                  message_template, ignore_status);
            format_message (message_template, dialog_control.page_width, NIL, message);

            REPEAT
              IF NOT local_status.normal THEN
                put_status (local_status);
              IFEND;
              which_parameter.specific := FALSE;
              put_prompt_and_get_reply (message, which_parameter);
              IF dialog_control.null_reply THEN
                local_status.normal := TRUE;
*IFEND
                EXIT evaluate_parameter;
*IF NOT $true(osv$unix)
              IFEND;
              check_reply_for_name (parameter_name, local_status);
            UNTIL local_status.normal;
*IFEND

          PROCEND prompt_for_parameter_name;
?? OLDTITLE, EJECT ??

          VAR
            name_is_parameter_name: boolean,
            parameter_name_index: clt$parameter_name_index;


          WHILE TRUE DO
            IF parameter_name <> '' THEN
              clp$search_parameter_names (parameter_name, pdt.names, parameter_name_index,
                    name_is_parameter_name);
              IF name_is_parameter_name THEN
                parameter_number := pdt.names^ [parameter_name_index].position;
                which_parameter.specific := TRUE;
                which_parameter.number := parameter_number;
                parameter_name := pdt.names^ [pdt.parameters^ [parameter_number].name_index].name;
                RETURN;
              IFEND;

              osp$set_status_abnormal ('CL', cle$unknown_parameter_name, parameter_name, local_status);
*IF NOT $true(osv$unix)
              IF (NOT dialog_control.activated) OR (dialog_control.interaction_style <> osc$line_interaction)
                    THEN
*IFEND
                EXIT evaluate_parameter;
*IF NOT $true(osv$unix)
              IFEND;
*IFEND
            IFEND;

            prompt_for_parameter_name;
          WHILEND;

        PROCEND evaluate_parameter_name;
*IF NOT $true(osv$unix)
?? TITLE := 'resolve_redundancy', EJECT ??

        PROCEDURE resolve_redundancy;

?? NEWTITLE := 'confirm_new_version', EJECT ??

          PROCEDURE confirm_new_version;

            VAR
              message: ost$status_message,
              message_template: ^ost$message_template;


            open_line_style_dialog;

            find_default_help_module;
            osp$find_param_assist_prompt (dialog_control.default_help_module, clc$confirm_new_param_version,
                  message_template, ignore_status);
            format_message (message_template, dialog_control.page_width, NIL, message);

            put_status (local_status);
            put_prompt_and_get_yn_reply (message, which_parameter, confirmed);
            confirmed := dialog_control.null_reply OR confirmed;

          PROCEND confirm_new_version;
?? OLDTITLE, EJECT ??

          confirm_new_version;

          IF confirmed THEN
            unspecify_parameter (parameter_number);

          ELSE
            local_status.normal := TRUE;
            parameter_name := '';
            evaluate_parameter_name;
          IFEND;

        PROCEND resolve_redundancy;
?? OLDTITLE, EJECT ??
*IFEND

        parameter_given_by_name := FALSE;
        IF (pdt.header^.command_or_function = clc$command) AND (parse.unit.kind = clc$lex_name) THEN
          expression_parse := parse;
          #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), parameter_name);
          clp$scan_non_space_lexical_unit (parse);
          IF parse.unit.kind <> clc$lex_equal THEN
            parse := expression_parse;
          ELSE
            clp$scan_non_space_lexical_unit (parse);
            parameter_given_by_name := TRUE;
          IFEND;
        IFEND;

        list_rest_parameter := (NOT parameter_given_by_name) AND
              (parameter_number <= pdt.header^.number_of_parameters) AND
              (pdt.type_descriptions^ [parameter_number].kind = clc$list_type) AND
              pdt.type_descriptions^ [parameter_number].list_rest;

        expression_parse := parse;
        REPEAT
          clp$scan_unnested_sep_lex_unit (clc$ignore_ellipsis, parse);
          expression_parse.index_limit := parse.unit_index;
        UNTIL (parse.unit_index >= parse.index_limit) OR (NOT list_rest_parameter);
        expression_text := ^expression_parse.text^ (expression_parse.unit_index,
              expression_parse.index_limit - expression_parse.unit_index);

        IF parameter_given_by_name THEN
          evaluate_parameter_name;

        ELSEIF parameter_number > pdt.header^.number_of_parameters THEN
          IF (NOT dialog_control.activated) OR (dialog_control.interaction_style <> osc$line_interaction) THEN
            osp$set_status_condition (cle$too_many_parameters, local_status);
            RETURN;
          IFEND;
          osp$set_status_abnormal ('CL', cle$value_given_positionally, expression_text^, local_status);
          parameter_name := '';
          evaluate_parameter_name;

        ELSE
          which_parameter.specific := TRUE;
          which_parameter.number := parameter_number;
          parameter_name := pdt.names^ [pdt.parameters^ [parameter_number].name_index].name;
          IF (NOT (clc$specify_positionally IN pdt.parameters^ [parameter_number].specification_methods)) AND
                (original_parameters OR (NOT evaluating_first_parameter)) THEN
            IF pdt.parameters^ [parameter_number].availability = clc$hidden_entry THEN
              osp$set_status_condition (cle$by_name_not_by_name, local_status);
              RETURN;
            ELSE
              osp$set_status_abnormal ('CL', cle$param_not_spec_by_name, parameter_name, local_status);
              osp$append_status_parameter (osc$status_parameter_delimiter, expression_text^, local_status);
            IFEND;
*IF NOT $true(osv$unix)
            IF (NOT dialog_control.activated) OR (dialog_control.interaction_style <> osc$line_interaction)
                  THEN
              RETURN;
            IFEND;
            confirm_parameter_name;
            local_status.normal := TRUE;
            IF dialog_control.null_reply THEN
              EXIT evaluate_parameter;
            ELSEIF NOT confirmed THEN
              parameter_name := '';
              evaluate_parameter_name;
            IFEND;
*ELSE
            RETURN;
*IFEND
          IFEND;
        IFEND;

        WHILE pvt^ [parameter_number].specified DO
          osp$set_status_abnormal ('CL', cle$doubly_defined_parameter, parameter_name, local_status);
*IF NOT $true(osv$unix)
          IF (NOT dialog_control.activated) OR (dialog_control.interaction_style <> osc$line_interaction) THEN
            RETURN;
          IFEND;
          resolve_redundancy;
*ELSE
          RETURN;
*IFEND
        WHILEND;

        evaluate_value (which_parameter, expression_parse, parse, pvt^ [parameter_number].specified,
              local_status);
*IF NOT $true(osv$unix)
        IF local_status.normal OR (NOT dialog_control.activated) OR
              (dialog_control.interaction_style <> osc$line_interaction) OR
              (pdt.parameters^ [parameter_number].availability = clc$hidden_entry) THEN
          RETURN;
        IFEND;

        prompt_for_correction (which_parameter, local_status);
        local_status.normal := TRUE;
*IFEND;

      PROCEND evaluate_parameter;
?? OLDTITLE, EJECT ??

      local_status.normal := TRUE;
      error_found := FALSE;
      parameter_number := first_parameter_number;
      evaluating_first_parameter := TRUE;

    /evaluate/
      WHILE TRUE DO
        CASE parse.unit.kind OF

        = clc$lex_end_of_line =
          EXIT /evaluate/;

        = clc$lex_semicolon =
          IF local_status.normal AND ((parse.unit_index < parse.index_limit) OR
                (original_parameters AND (pdt.header^.command_or_function = clc$function))) THEN
            osp$set_status_condition (cle$unexpected_in_param_list, local_status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, local_status);
            IF status.normal THEN
              status := local_status;
            IFEND;
          IFEND;
          clp$scan_non_space_lexical_unit (parse);
          EXIT /evaluate/;

        = clc$lex_right_parenthesis =
          IF local_status.normal AND ((parse.unit_index < parse.index_limit) OR (NOT original_parameters) OR
                (pdt.header^.command_or_function = clc$command)) THEN
            osp$set_status_condition (cle$unexpected_in_param_list, local_status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, local_status);
            IF status.normal THEN
              status := local_status;
            IFEND;
          IFEND;
          clp$scan_non_space_lexical_unit (parse);
          EXIT /evaluate/;

        = clc$lex_comma =
          evaluating_first_parameter := FALSE;
          REPEAT
            parameter_number := parameter_number + 1;
            clp$scan_non_space_lexical_unit (parse);
          UNTIL parse.unit.kind <> clc$lex_comma;

        ELSE
          evaluate_parameter;
          evaluating_first_parameter := FALSE;
          IF parse.unit_is_space THEN
            clp$scan_non_space_lexical_unit (parse);
          IFEND;
          IF parse.unit.kind = clc$lex_comma THEN
            clp$scan_non_space_lexical_unit (parse);
          IFEND;

          IF NOT local_status.normal THEN
            IF evaluation_context.interpreter_mode = clc$help_mode THEN
              local_status.normal := TRUE;
            ELSE
              IF status.normal THEN
                status := local_status;
              IFEND;
              error_found := TRUE;
            IFEND;
          IFEND;

          IF parameter_number <= pdt.header^.number_of_parameters THEN
            parameter_number := parameter_number + 1;
          IFEND;
        CASEND;
      WHILEND /evaluate/;

      IF error_found AND local_status.normal THEN
        local_status := status;
      IFEND;

    PROCEND evaluate_parameters;
?? TITLE := 'evaluate_parameter_defaults', EJECT ??

    PROCEDURE evaluate_parameter_defaults
      (VAR which_parameter: clt$which_parameter;
       VAR local_status: ost$status);

      VAR
        confirmed: boolean,
        parameter_number: clt$parameter_number;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'confirm_default_value', EJECT ??

      PROCEDURE confirm_default_value;

        VAR
          message: ost$status_message;

?? NEWTITLE := 'get_confirm_default_prompt', EJECT ??

        PROCEDURE [INLINE] get_confirm_default_prompt;

          VAR
            message_parameters: array [1 .. 2] of ^ost$message_parameter,
            message_template: ^ost$message_template,
            parameter_name: clt$parameter_name,
            representation: ^clt$data_representation;


          find_default_help_module;

          osp$find_param_assist_prompt (dialog_control.default_help_module, clc$confirm_param_default_value,
                message_template, ignore_status);

          parameter_name := pdt.names^ [pdt.parameters^ [parameter_number].name_index].name;
          convert_name_to_message_param (parameter_name);
          message_parameters [1] := ^parameter_name;

          get_parameter_value_rep (parameter_number, dialog_control.page_width, representation, local_status);
          IF local_status.normal THEN
            message_parameters [2] := clp$data_representation_text (representation);
          ELSE
            message_parameters [2] := NIL;
            local_status.normal := TRUE;
          IFEND;

          format_message (message_template, dialog_control.page_width, ^message_parameters, message);

        PROCEND get_confirm_default_prompt;
?? OLDTITLE, EJECT ??

        open_line_style_dialog;
        get_confirm_default_prompt;
        put_prompt_and_get_yn_reply (message, which_parameter, confirmed);
        confirmed := dialog_control.null_reply OR confirmed;

      PROCEND confirm_default_value;
?? OLDTITLE, EJECT ??
*IFEND

      VAR
        default_value: ^clt$expression_text,
        default_value_from_name: ^clt$expression_text,
        default_value_specified: boolean,
        expression_parse: clt$parse_state,
        lexical_units: ^clt$lexical_units,
        parse: clt$parse_state,
        value_from_default_name: boolean;


      local_status.normal := TRUE;

      IF evaluation_context.interpreter_mode = clc$help_mode THEN
        parameter_defaults_evaluated := TRUE;
        RETURN;
      IFEND;

      FOR parameter_number := 1 TO pdt.header^.number_of_parameters DO
        IF (NOT pvt^ [parameter_number].specified) AND (pdt.parameters^ [parameter_number].requirement >=
              clc$optional_default_parameter) THEN
          which_parameter.specific := TRUE;
          which_parameter.number := parameter_number;

          get_parameter_default (parameter_number, default_value, value_from_default_name, local_status);
          IF NOT local_status.normal THEN
            RETURN;
          IFEND;

          IF value_from_default_name THEN
            default_value_from_name := default_value;
            PUSH default_value: [STRLENGTH (default_value_from_name^)];
            default_value^ := default_value_from_name^;
          IFEND;

          clp$identify_lexical_units (default_value, work_area, lexical_units, local_status);
          IF NOT local_status.normal THEN
            RETURN;
          IFEND;
          clp$initialize_parse_state (default_value, lexical_units, parse);
          clp$scan_non_space_lexical_unit (parse);
          expression_parse := parse;
          clp$scan_to_lexical_limit (parse);

          evaluate_value (which_parameter, expression_parse, parse, default_value_specified, local_status);
          IF NOT local_status.normal THEN
            RETURN;
          ELSEIF parse.unit.kind <> clc$lex_end_of_line THEN
            osp$set_status_abnormal ('CL', cle$expecting_default_term, pdt.
                  names^ [pdt.parameters^ [parameter_number].name_index].name, local_status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, local_status);
            RETURN;
          ELSEIF NOT default_value_specified THEN
            osp$set_status_abnormal ('CL', cle$defaulted_parameter_unspec, pdt.
                  names^ [pdt.parameters^ [parameter_number].name_index].name, local_status);
            RETURN;
*IF NOT $true(osv$unix)
          ELSEIF dialog_control.activated AND (dialog_control.interaction_style = osc$line_interaction) AND
                (pdt.parameters^ [parameter_number].requirement = clc$confirm_default_parameter) THEN
            confirm_default_value;
            IF NOT confirmed THEN
              local_status.normal := TRUE;
              prompt_for_correction (which_parameter, local_status);
              local_status.normal := TRUE;
            IFEND;
*IFEND
          IFEND;

        IFEND;
      FOREND;

      parameter_defaults_evaluated := TRUE;

    PROCEND evaluate_parameter_defaults;
?? TITLE := 'evaluate_value', EJECT ??

    PROCEDURE evaluate_value
      (    which_parameter: clt$which_parameter;
       VAR expression_parse {input} : clt$parse_state;
       VAR parse {input, output} : clt$parse_state;
       VAR parameter_specified: boolean;
       VAR status: ost$status);

      VAR
        bad_expression_text: ^clt$expression_text,
        expression_text: ^clt$expression_text,
        ignore_result_type_description: ^clt$type_description,
        parameter_passed: boolean;

?? NEWTITLE := 'save_parameter_value_source', EJECT ??

      PROCEDURE save_parameter_value_source;


        IF pvt^ [which_parameter.number].passing_method = clc$pass_by_value THEN
          clp$make_deferred_value (expression_text^, pdt.type_descriptions^ [which_parameter.number].
                specification, work_area, pvt^ [which_parameter.number].value);
          IF pvt^ [which_parameter.number].value = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT clp$internal_evaluate_params;
          IFEND;

        ELSE
          NEXT pvt^ [which_parameter.number].variable: [STRLENGTH (expression_text^)] IN work_area;
          IF pvt^ [which_parameter.number].variable = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            EXIT clp$internal_evaluate_params;
          IFEND;
          pvt^ [which_parameter.number].variable^ := expression_text^;
        IFEND;

        parameter_specified := TRUE;

      PROCEND save_parameter_value_source;
?? TITLE := 'pass_variable_parameter', EJECT ??

      PROCEDURE pass_variable_parameter;

        VAR
*IF NOT $true(osv$unix)
          access_handle: clt$variable_access_handle,
          access_variable_requests: clt$access_variable_requests,
          ignore_type_description: ^clt$type_description,
          i: 1 .. clc$max_union_members,
          found: boolean,
*IFEND
          name: clt$variable_name,
*IF NOT $true(osv$unix)
          variable_conforms: boolean,
          variable_information: clt$variable_information,
*IFEND
          variable_name: clt$variable_name;

        parameter_passed := TRUE;

        CASE expression_parse.unit.kind OF
        = clc$lex_name =
          ;
        = clc$lex_long_name =
          osp$set_status_abnormal ('CL', cle$name_too_long, expression_parse.
                text^ (expression_parse.unit_index, expression_parse.unit.size), status);
          RETURN;
        ELSE
          osp$set_status_abnormal ('CL', cle$expecting_var_for_param, pdt.
                names^ [pdt.parameters^ [which_parameter.number].name_index].name, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, expression_parse, status);
          RETURN;
        CASEND;

        #TRANSLATE (osv$lower_to_upper, expression_parse.text^
              (expression_parse.unit_index, expression_parse.unit.size), name);

        clp$scan_any_lexical_unit (expression_parse);
*IF NOT $true(osv$unix)
        access_variable_requests := $clt$access_variable_requests[clc$return_type_description,
              clc$return_value_qualifiers];
        clp$evaluate_name_for_write (name, access_variable_requests, TRUE, expression_parse, work_area,
              variable_name, variable_information, access_handle, ignore_type_description, found,
              status);
        IF NOT status.normal THEN
          RETURN;
        ELSEIF NOT found THEN
          osp$set_status_abnormal ('CL', cle$unknown_variable, variable_name, status);
          RETURN;
        ELSEIF variable_information.type_description = NIL THEN
          osp$set_status_abnormal ('CL', cle$indeterminate_param_var, variable_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, pdt.
                names^ [pdt.parameters^ [which_parameter.number].name_index].name, status);
          RETURN;
        ELSEIF (NOT variable_information.parameter_passed) AND variable_information.value_qualifiers_present
              THEN
          osp$set_status_abnormal ('CL', cle$omited_param_cant_have_qual, variable_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, pdt.
                names^ [pdt.parameters^ [which_parameter.number].name_index].name, status);
        IFEND;

        clp$validate_var_conformance (variable_information.type_description, ^pdt.
              type_descriptions^ [which_parameter.number], status);
        IF NOT status.normal THEN
          translate_status (pdt.names^ [pdt.parameters^ [which_parameter.number].name_index].name, status);
          RETURN;
        IFEND;

*ELSE
        variable_name := name;

*IFEND
        IF expression_parse.unit_index < expression_parse.index_limit THEN
          osp$set_status_condition (cle$expecting_end_of_expression, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, expression_parse, status);
          RETURN;
        IFEND;

*IF NOT $true(osv$unix)
        IF NOT variable_information.parameter_passed THEN

{ Passing an omitted parameter results in the receiving parameter being omitted.

          parameter_passed := FALSE;
          RETURN;
        IFEND;
*IFEND

*IF NOT $true(osv$unix)
        clp$produce_variable_ref_expr (variable_information.class, variable_name,
              variable_information.value_qualifiers, work_area, pvt^ [which_parameter.number].variable,
*ELSE
        clp$produce_variable_ref_expr (clc$param_variable, variable_name,
              NIL, work_area, pvt^ [which_parameter.number].variable,
*IFEND
              status);

*IF NOT $true(osv$unix)
        IF status.normal AND evaluation_context.procedure_parameters THEN
          clp$pass_variable_parameter (which_parameter.number, access_handle,
                variable_information.value_qualifiers, variable_name, work_area, status);
        IFEND;
*IFEND

      PROCEND pass_variable_parameter;
?? TITLE := 'translate_status', EJECT ??

      PROCEDURE [INLINE] translate_status
        (    parameter_name: ost$name;
         VAR status: {input, output} ost$status);


        CASE status.condition OF
        = cle$application_name_mismatch =
          status.condition := cle$p_application_name_mismatch;
        = cle$array_bounds_dont_match =
          status.condition := cle$p_array_bounds_dont_match;
        = cle$balance_brackets_dont_match =
          status.condition := cle$p_balance_brackets_mismatch;
        = cle$date_time_tenses_dont_match =
          status.condition := cle$p_date_time_tenses_mismatch;
        = cle$date_time_types_dont_match =
          status.condition := cle$p_date_time_types_mismatch;
        = cle$field_names_dont_match =
          status.condition := cle$p_field_names_dont_match;
        = cle$field_requirements_mismatch =
          status.condition := cle$p_field_requiremnt_mismatch;
        = cle$field_types_dont_match =
          status.condition := cle$p_field_types_dont_match;
        = cle$integer_radices_dont_match =
          status.condition := cle$p_integer_radices_mismatch;
        = cle$integer_ranges_dont_match =
          status.condition := cle$p_integer_ranges_dont_match;
        = cle$keywords_dont_match =
          status.condition := cle$p_keywords_dont_match;
        = cle$list_rest_doesnt_match =
          status.condition := cle$p_list_rest_doesnt_match;
        = cle$list_sizes_dont_match =
          status.condition := cle$p_list_sizes_dont_match;
        = cle$name_sizes_dont_match =
          status.condition := cle$p_name_sizes_dont_match;
        = cle$number_of_fields_dont_match =
          status.condition := cle$p_number_of_fields_mismatch;
        = cle$only_string_literal_allowed =
          status.condition := cle$only_string_literal_for_par;
        = cle$range_types_dont_match =
          status.condition := cle$p_range_types_dont_match;
        = cle$real_subranges_dont_match =
          status.condition := cle$p_real_subranges_dont_match;
        = cle$string_literals_dont_match =
          status.condition := cle$p_string_literals_mismatch;
        = cle$string_sizes_dont_match =
          status.condition := cle$p_string_sizes_dont_match;
        = cle$undefined_type =
          status.condition := cle$p_undefined_type;
        = cle$undefined_value =
          status.condition := cle$p_undefined_value;
        = cle$unexpected_oper_for_unspec =
          status.condition := cle$p_unexpect_oper_for_unspec;
        = cle$unknown_array_element_type =
          status.condition := cle$p_unknown_array_elem_type;
        = cle$unknown_keyword =
          status.condition := cle$unknown_parameter_keyword;
        = cle$unknown_list_element_type =
          status.condition := cle$p_unknown_list_element_type;
        = cle$unknown_range_element_type =
          status.condition := cle$p_unknown_range_elem_type;
        = cle$value_not_union_type =
          status.condition := cle$p_value_not_union_type;
        = cle$variable_not_union_type =
          ;
        = cle$wrong_kind_of_element_type =
          status.condition := cle$p_wrong_kind_of_elem_type;
        = cle$wrong_kind_of_value =
          status.condition := cle$wrong_kind_of_param_value;
        ELSE
          RETURN;
        CASEND;

        osp$append_status_parameter (osc$status_parameter_delimiter, parameter_name, status);

      PROCEND translate_status;
?? OLDTITLE, EJECT ??

      status.normal := TRUE;
      parameter_specified := FALSE;
      expression_text := ^expression_parse.text^ (expression_parse.unit_index,
            expression_parse.index_limit - expression_parse.unit_index);

      IF pdt.parameters^ [which_parameter.number].evaluation_method = clc$deferred_evaluation THEN
        save_parameter_value_source;

      ELSEIF pvt^ [which_parameter.number].passing_method = clc$pass_by_reference THEN
*IF $true(osv$unix)
        IF which_parameter.number = pdt.header^.status_parameter_number THEN
*IFEND
        pass_variable_parameter;
*IF NOT $true(osv$unix)
        IF parameter_passed THEN
          parameter_specified := status.normal OR (evaluation_context.interpreter_mode = clc$skip_mode) OR
              (NOT dialog_control.activated);
*ELSE
          parameter_specified := status.normal;
        ELSE
          osp$set_status_abnormal ('CL', cle$not_supported, 'VAR parameters are', status);
          parameter_specified := FALSE;
        IFEND;
*IFEND
*IF NOT $true(osv$unix)
        ELSE
          parameter_specified := FALSE;
        IFEND;
*IFEND
      ELSE
        clp$internal_evaluate_expr (expression_parse, ^pdt.type_descriptions^ [which_parameter.number],
              work_area, ignore_result_type_description, pvt^ [which_parameter.number].value, status);
        IF NOT status.normal THEN
          IF pdt.parameters^ [which_parameter.number].security = clc$secure_parameter THEN
            osp$set_status_abnormal ('CL', cle$secure_parameter_incorrect, pdt.
                  names^ [pdt.parameters^ [which_parameter.number].name_index].name, status);
          ELSEIF status.condition = cle$expression_not_union_type THEN
            IF status.text.size > 0 THEN
              PUSH bad_expression_text: [status.text.size - 1];
              bad_expression_text^ := status.text.value (2, status.text.size - 1);
            ELSE
              bad_expression_text := NIL;
            IFEND;
            osp$set_status_abnormal ('CL', cle$param_expr_not_union_type, pdt.
                  names^ [pdt.parameters^ [which_parameter.number].name_index].name, status);
            IF bad_expression_text <> NIL THEN
              osp$append_status_parameter (osc$status_parameter_delimiter, bad_expression_text^, status);
            IFEND;
          ELSE
            translate_status (pdt.names^ [pdt.parameters^ [which_parameter.number].name_index].name, status);
          IFEND;
        ELSEIF expression_parse.unit_index < expression_parse.index_limit THEN
          osp$set_status_condition (cle$expecting_end_of_expression, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, expression_parse, status);
        ELSEIF expression_parse.index_limit > parse.unit_index THEN
          parse := expression_parse;
        IFEND;

        IF NOT status.normal THEN
          CASE evaluation_context.interpreter_mode OF
          = clc$help_mode =
            save_parameter_value_source;
          = clc$skip_mode =

{  In interpret or skip mode, if we have a bad status we signal a bad, SPECIFIED
{  parameter by setting the value to NIL.

            pvt^ [which_parameter.number].value := NIL;
            parameter_specified := TRUE;
          ELSE {clc$interpret_mode}

{  If we are in interpret mode we want to indicate that the parameter was
{  specified ONLY if parameter prompting is turned off; otherwise, we want
{  to reprompt the user for a correct parameter.

            pvt^ [which_parameter.number].value := NIL;
            parameter_specified := NOT dialog_control.activated;
          CASEND;
        ELSEIF pvt^ [which_parameter.number].value^.kind = clc$unspecified THEN
          pvt^ [which_parameter.number].value := NIL;
          parameter_specified := FALSE;
        ELSE
          parameter_specified := pvt^ [which_parameter.number].value <> NIL;
        IFEND;
      IFEND;

*IF NOT $true(osv$unix)
      IF status.normal AND parameter_specified AND (check_parameters_procedure <> NIL) AND
            (pdt.parameters^ [which_parameter.number].checking_level = clc$extended_parameter_checking) THEN
        perform_parameter_checks (which_parameter, status);
      IFEND;
*IFEND

      IF ((NOT status.normal) AND (evaluation_context.interpreter_mode = clc$help_mode)) OR
            save_source_of_expressions THEN
        save_parameter_value_source;
      IFEND;

      CASE pdt.parameters^ [which_parameter.number].requirement OF
      = clc$required_parameter =
        required_parameters_checked := FALSE;
      = clc$optional_default_parameter, clc$confirm_default_parameter =
        parameter_defaults_evaluated := FALSE;
      ELSE
        ;
      CASEND;

      IF parameter_specified THEN
        general_param_checks_performed := FALSE;
      IFEND;

    PROCEND evaluate_value;
*IF NOT $true(osv$unix)
?? TITLE := 'explain_command_or_function', EJECT ??

    PROCEDURE explain_command_or_function
      (VAR explanation_available: boolean;
       VAR local_status: ost$status);

      CONST
        disable_echoing = FALSE,
        max_explain_command_size = 88;

      VAR
        explain_command: string (max_explain_command_size),
        explain_command_size: integer;


      local_status.normal := TRUE;
      explanation_available := FALSE;

      IF dialog_control.online_manual_name <> '' THEN
        STRINGREP (explain_command, explain_command_size, 'EXPLAIN SUBJECT=''',
              evaluation_context.command_or_function_name (1, clp$trimmed_string_size
              (evaluation_context.command_or_function_name)), ''' MANUAL=',
              dialog_control.online_manual_name);
        clp$include_line (explain_command (1, explain_command_size), disable_echoing, osc$null_name,
              local_status);
        explanation_available := local_status.normal;
      IFEND;

    PROCEND explain_command_or_function;
?? TITLE := 'find_default_help_module', EJECT ??

    PROCEDURE [INLINE] find_default_help_module;

      VAR
        ignore_natural_language: ost$natural_language,
        ignore_online_manual_name: ost$online_manual_name;


      IF dialog_control.default_help_module <> NIL THEN
        RETURN;
      IFEND;

      osp$find_help_module (clc$system_messages_module, dialog_control.default_help_module,
            ignore_online_manual_name, ignore_natural_language, ignore_status);

    PROCEND find_default_help_module;
?? TITLE := 'find_help_module', EJECT ??

    PROCEDURE [INLINE] find_help_module;

      VAR
        ignore_natural_language: ost$natural_language;


      IF dialog_control.searched_for_help_module THEN
        RETURN;
      IFEND;

      dialog_control.searched_for_help_module := TRUE;

      osp$find_help_module (pdt.header^.help_module_name, dialog_control.help_module,
            dialog_control.online_manual_name, ignore_natural_language, ignore_status);

    PROCEND find_help_module;
?? TITLE := 'format_message', EJECT ??

    PROCEDURE [INLINE] format_message
      (    message_template: ^ost$message_template;
           max_message_line: ost$max_status_message_line;
           message_parameters: ^ost$message_parameters;
       VAR message: ost$status_message);


      osp$format_help_message (message_template, message_parameters, max_message_line, message, status);
      IF NOT status.normal THEN
        EXIT clp$internal_evaluate_params;
      IFEND;

    PROCEND format_message;
*IFEND
?? TITLE := 'get_parameter_default', EJECT ??

    PROCEDURE [INLINE] get_parameter_default
      (    parameter_number: clt$parameter_number;
       VAR default_value: ^clt$expression_text;
       VAR value_from_default_name: boolean;
       VAR local_status: ost$status);

      VAR
*IF NOT $true(osv$unix)
        access_variable_requests: clt$access_variable_requests,
*IFEND
        default_name: clt$variable_name,
        default_name_parse: clt$parse_state,
        default_name_result: ^clt$data_value,
        default_name_text: ^clt$string_value,
*IF $true(osv$unix)
        env_name: ost_c_name,
        env_name_length: integer,
        env_value: ost_c_fixed_string,
        env_value_length: ost_c_integer,
*IFEND
        lexical_units: ^clt$lexical_units;


      local_status.normal := TRUE;
      value_from_default_name := FALSE;
      default_value := NIL;
      IF pdt.default_names = NIL THEN
        default_name := '';
      ELSE
        default_name := pdt.default_names^ [parameter_number]^;
      IFEND;

      IF default_name <> '' THEN
*IF $true(osv$unix)
        STRINGREP (env_name, env_name_length, default_name, $CHAR(0));
        env_name (4) := '_';
        clp_getenv (env_name, env_value, env_value_length);
        IF env_value_length > 0 THEN
          default_value := ^env_value (1, env_value_length);
          value_from_default_name := TRUE;
        IFEND;
*ELSE
        PUSH default_name_text: [0];
        clp$identify_lexical_units (default_name_text, work_area, lexical_units, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
        clp$initialize_parse_state (default_name_text, lexical_units, default_name_parse);
        clp$scan_non_space_lexical_unit (default_name_parse);
        access_variable_requests := $clt$access_variable_requests[];
        clp$evaluate_name (default_name, access_variable_requests, default_name_parse, work_area,
              default_name_result, value_from_default_name, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
        IF value_from_default_name THEN
          IF default_name_result^.kind <> clc$string THEN
            osp$set_status_abnormal ('CL', cle$default_name_not_string, default_name, local_status);
            osp$append_status_parameter (osc$status_parameter_delimiter, pdt.
                  names^ [pdt.parameters^ [parameter_number].name_index].name, local_status);
            RETURN;
          IFEND;
          default_value := default_name_result^.string_value;
        IFEND;
*IFEND
      IFEND;

      IF default_value = NIL THEN
        value_from_default_name := FALSE;
        default_value := pdt.default_values^ [parameter_number];
      IFEND;

      default_value := ^default_value^ (1, clp$trimmed_string_size (default_value^));


    PROCEND get_parameter_default;
*IF NOT $true(osv$unix)
?? TITLE := 'get_parameter_prompt', EJECT ??

    PROCEDURE [INLINE] get_parameter_prompt
      (    parameter_number: clt$parameter_number;
           max_message_line: ost$max_status_message_line;
       VAR message: ost$status_message);

      VAR
        message_parameters: array [1 .. 1] of ^ost$message_parameter,
        message_template: ^ost$message_template,
        parameter_name: clt$parameter_name;


      parameter_name := pdt.names^ [pdt.parameters^ [parameter_number].name_index].name;

    /find_parameter_prompt/
      BEGIN
        find_help_module;

        IF dialog_control.help_module <> NIL THEN
          osp$find_parameter_prompt (dialog_control.help_module, parameter_name, message_template,
                ignore_status);
          IF message_template <> NIL THEN
            EXIT /find_parameter_prompt/;
          IFEND;
        IFEND;

        find_default_help_module;

        osp$find_parameter_prompt (dialog_control.default_help_module, clc$default_parameter_prompt,
              message_template, ignore_status);
      END /find_parameter_prompt/;

      convert_name_to_message_param (parameter_name);
      message_parameters [1] := ^parameter_name;
      format_message (message_template, max_message_line, ^message_parameters, message);

    PROCEND get_parameter_prompt;
?? TITLE := 'get_parameter_value_rep', EJECT ??

    PROCEDURE [INLINE] get_parameter_value_rep
      (    parameter_number: clt$parameter_number;
           max_representation_line: clt$string_size;
       VAR representation: ^clt$data_representation;
       VAR local_status: ost$status);

      VAR
        request: clt$convert_to_string_request;


      local_status.normal := TRUE;

      request.initial_indentation := 0;
      request.continuation_indentation := 0;
      request.max_string := max_representation_line;
      request.include_advanced_items := TRUE;
      request.include_hidden_items := TRUE;
      request.kind := clc$convert_data_value;
      request.representation_option := clc$data_source_representation;
      IF pvt^ [parameter_number].passing_method = clc$pass_by_value THEN
        request.value := pvt^ [parameter_number].value;
      ELSE { pvt^ [parameter_number].passing_method = clc$pass_by_reference

{ Use "dummy" application value to get the variable reference in the desired format.

        PUSH request.value;
        request.value^.kind := clc$application;
        request.value^.application_value := pvt^ [parameter_number].variable;
      IFEND;

      clp$internal_convert_to_string (request, work_area, representation, local_status);

    PROCEND get_parameter_value_rep;
?? TITLE := 'initialize_dialog_control', EJECT ??

    PROCEDURE [INLINE] initialize_dialog_control;

      VAR
        p: clt$parameter_number,
        parameters_not_supplied_on_call: boolean;


      dialog_control.parameters_to_prompt_for := TRUE;

      determine_prompting_style (evaluation_context, dialog_control.activated,
            dialog_control.interaction_style, ignore_status);

      IF evaluation_context.command_or_function = clc$command THEN
        dialog_control.cancelled_status_code := cle$command_cancelled;
      ELSE
        dialog_control.cancelled_status_code := cle$function_cancelled;
      IFEND;

      dialog_control.searched_for_help_module := FALSE;
      dialog_control.help_module := NIL;
      dialog_control.online_manual_name := '';
      dialog_control.default_help_module := NIL;
      dialog_control.open := FALSE;

      FOR p := 1 TO pdt.header^.number_of_parameters DO
        dialog_control.prompted_for_parameter^ [p] := FALSE;
      FOREND;

      IF NOT dialog_control.activated THEN
        prompt_for_all_parameters := FALSE;
      ELSE
        parameters_not_supplied_on_call := parse.unit_index >= parse.index_limit;
        prompt_for_all_parameters := (evaluation_context.prompting_requested AND
              ((evaluation_context.command_or_function = clc$command) OR
              (evaluation_context.command_or_function_source = NIL))) OR
              ((pdt.header^.number_of_required_parameters > 0) AND parameters_not_supplied_on_call);
      IFEND;

    PROCEND initialize_dialog_control;
?? TITLE := 'initialize_line_style_dialog', EJECT ??

    PROCEDURE initialize_line_style_dialog;

      VAR
        file_attributes: array [1 .. 1] of amt$fetch_item,
        file_id: amt$file_identifier,
        ignore_last_line_of_message: ^ost$status_message_line,
        message: ost$status_message,
        message_name: ost$name,
        message_parameters: array [1 .. 1] of ^ost$message_parameter,
        message_template: ^ost$message_template;


      dialog_control.open := TRUE;
      dialog_control.null_reply := TRUE;
      dialog_control.terminator_in_reply := FALSE;
      dialog_control.prompting_for_advanced_params := FALSE;

      clp$get_system_file_id (clc$job_output, dialog_control.output_file_id, status);
      IF NOT status.normal THEN
        EXIT clp$internal_evaluate_params;
      IFEND;
      file_attributes [1].key := amc$page_width;
      amp$fetch (dialog_control.output_file_id, file_attributes, status);
      IF NOT status.normal THEN
        EXIT clp$internal_evaluate_params;
      IFEND;
      IF file_attributes [1].page_width < osc$min_status_message_line THEN
        dialog_control.page_width := osc$min_status_message_line;
      ELSEIF file_attributes [1].page_width > osc$max_status_message_line THEN
        dialog_control.page_width := osc$max_status_message_line;
      ELSE
        dialog_control.page_width := file_attributes [1].page_width;
      IFEND;

      clp$push_interactive_input (status);
      IF NOT status.normal THEN
        EXIT clp$internal_evaluate_params;
      IFEND;

      clp$set_prompting_input;

      IF dialog_control.parameters_to_prompt_for AND (NOT evaluation_context.prompting_requested) THEN
        IF prompt_for_all_parameters THEN
          IF evaluation_context.command_or_function = clc$command THEN
            message_name := clc$enter_command_params_msg;
          ELSE
            message_name := clc$enter_function_params_msg;
          IFEND;
        ELSE
          IF evaluation_context.command_or_function = clc$command THEN
            message_name := clc$correct_command_params_msg;
          ELSE
            message_name := clc$correct_function_params_msg;
          IFEND;
        IFEND;
        find_default_help_module;
        osp$find_param_assist_prompt (dialog_control.default_help_module, message_name, message_template,
              ignore_status);
        message_parameters [1] := ^evaluation_context.command_or_function_name;
        format_message (message_template, dialog_control.page_width, ^message_parameters, message);
        put_message (message, ignore_last_line_of_message);
      IFEND;

    PROCEND initialize_line_style_dialog;
*IFEND
?? TITLE := 'initialize_pvt', EJECT ??

    PROCEDURE [INLINE] initialize_pvt;

      VAR
        p: clt$parameter_number;


      FOR p := 1 TO pdt.header^.number_of_parameters DO
        pvt^ [p].specified := FALSE;
        pvt^ [p].passing_method := pdt.parameters^ [p].passing_method;
        IF pvt^ [p].passing_method = clc$pass_by_value THEN
          pvt^ [p].value := NIL;
        ELSE
          pvt^ [p].variable := NIL;
        IFEND;
      FOREND;

    PROCEND initialize_pvt;
*IF NOT $true(osv$unix)
?? TITLE := 'invoke_parameter_dialog_manager', EJECT ??

    PROCEDURE invoke_parameter_dialog_manager
      (    dialog_manager_name: pmt$program_name;
           load_from_system: boolean;
       VAR local_status: ost$status);

      VAR
        callers_save_area: ^ost$stack_frame_save_area,
        ignore_term_error_level: ost$status_severity,
        original_term_error_level: ost$status_severity;

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

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


        IF condition.selector = pmc$block_exit_processing THEN
          pmp$change_term_error_level (original_term_error_level, ignore_term_error_level, handler_status);
          handler_status.normal := TRUE;
          RETURN;
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      PROCEND abort_handler;
?? TITLE := 'invoke_condition_handler', EJECT ??

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


        IF (condition.selector = pmc$system_conditions) AND
              (($pmt$system_conditions [pmc$instruction_specification, pmc$address_specification,
              pmc$access_violation, pmc$environment_specification, pmc$invalid_segment_ring_0,
              pmc$out_call_in_return] * condition.system_conditions) <> $pmt$system_conditions []) AND
              (save_area^.minimum_save_area.a2_previous_save_area = callers_save_area) THEN
          osp$set_status_condition (cle$unable_to_call_parm_dlg_mgr, local_status);
          EXIT invoke_parameter_dialog_manager;
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      PROCEND invoke_condition_handler;
?? TITLE := 'support_change_expression_save', EJECT ??

      PROCEDURE support_change_expression_save
        (    save_expression_source: boolean;
         VAR support_status: ost$status);


        status.normal := TRUE;

        save_source_of_expressions := save_expression_source;

      PROCEND support_change_expression_save;
?? TITLE := 'support_evaluate_parameter', EJECT ??

      PROCEDURE support_evaluate_parameter
        (    parameter_number: clt$parameter_number;
             text: clt$expression_text;
         VAR support_status: ost$status);

        VAR
          expression_parse: clt$parse_state,
          expression_text: ^clt$expression_text,
          ignore_parameter_specified: boolean,
          lexical_units: ^clt$lexical_units,
          parse: clt$parse_state,
          which_parameter: clt$which_parameter;


        support_status.normal := TRUE;

        unspecify_parameter (parameter_number);

        expression_text := ^text (1, clp$trimmed_string_size (text));
        clp$identify_lexical_units (expression_text, work_area, lexical_units, support_status);
        clp$initialize_parse_state (expression_text, lexical_units, parse);
        clp$scan_non_space_lexical_unit (parse);
        expression_parse := parse;
        clp$scan_to_lexical_limit (parse);

        which_parameter.specific := TRUE;
        which_parameter.number := parameter_number;
        evaluate_value (which_parameter, expression_parse, parse, pvt^ [parameter_number].specified,
              support_status);

      PROCEND support_evaluate_parameter;
?? TITLE := 'support_explain', EJECT ??

      PROCEDURE support_explain
        (VAR explanation_available: boolean;
         VAR support_status: ost$status);


        explain_command_or_function (explanation_available, support_status);

      PROCEND support_explain;
?? TITLE := 'support_get_all_names', EJECT ??

      PROCEDURE support_get_all_names
        (VAR names: ^array [1 .. * ] of clt$command_name;
         VAR support_status: ost$status);


        clp$get_all_cmnd_or_func_names (pdt.header^.command_or_function,
              evaluation_context.command_or_function_source^, evaluation_context.command_or_function_name,
              work_area, names, support_status);
        IF NOT support_status.normal THEN
          RETURN;
        IFEND;

        RESET work_area TO names;

      PROCEND support_get_all_names;
?? TITLE := 'support_get_all_parameter_specs', EJECT ??

      PROCEDURE support_get_all_parameter_specs
        (    include_advanced_items: boolean;
             max_representation_line: clt$string_size;
         VAR representation: ^clt$data_representation;
         VAR support_status: ost$status);

        VAR
          request: clt$convert_to_string_request;


        support_status.normal := TRUE;

        request.initial_indentation := 0;
        request.continuation_indentation := 6;
        request.max_string := max_representation_line;
        request.include_advanced_items := include_advanced_items;
        request.include_hidden_items := FALSE;
        request.kind := clc$convert_unbundled_pdt;
        request.multi_line_pdt_format := TRUE;
        request.parameter_starts_line := TRUE;
        request.individual_parameter := FALSE;
        request.individual_parameter_number := LOWERVALUE (clt$parameter_number);
        request.include_header := FALSE;
        request.command_or_function_name := evaluation_context.command_or_function_name;
        request.aliases := NIL;
        request.availability := clc$normal_usage_entry;
        request.command_or_function_scope := clc$xdcl_command_or_function;
        request.pdt := ^pdt;
        request.pvt := NIL;
        request.symbolic_pdt_qualifiers_area := NIL;
        request.include_implementation_info := FALSE;

        clp$internal_convert_to_string (request, work_area, representation, support_status);
        IF NOT support_status.normal THEN
          RETURN;
        IFEND;

        RESET work_area TO representation;

      PROCEND support_get_all_parameter_specs;
?? TITLE := 'support_get_brief_help', EJECT ??

      PROCEDURE support_get_brief_help
        (    max_message_line: ost$max_status_message_line;
         VAR message: ^ost$status_message;
         VAR support_status: ost$status);

        VAR
          message_template: ^ost$message_template;


        support_status.normal := TRUE;
        message := NIL;

        find_help_module;
        IF dialog_control.help_module <> NIL THEN
          osp$find_brief_help_message (dialog_control.help_module, message_template, ignore_status);
          IF message_template <> NIL THEN
            NEXT message IN work_area;
            IF message = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, support_status);
              RETURN;
            IFEND;
            RESET message;
            format_message (message_template, max_message_line, NIL, message^);
            RESET work_area TO message;
          IFEND;
        IFEND;

      PROCEND support_get_brief_help;
?? TITLE := 'support_get_full_help', EJECT ??

      PROCEDURE support_get_full_help
        (    max_message_line: ost$max_status_message_line;
         VAR message: ^ost$status_message;
         VAR support_status: ost$status);

        VAR
          message_template: ^ost$message_template;


        support_status.normal := TRUE;
        message := NIL;

        find_help_module;
        IF dialog_control.help_module <> NIL THEN
          osp$find_full_help_message (dialog_control.help_module, message_template, ignore_status);
          IF message_template <> NIL THEN
            NEXT message IN work_area;
            IF message = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, support_status);
              RETURN;
            IFEND;
            RESET message;
            format_message (message_template, max_message_line, NIL, message^);
            RESET work_area TO message;
          IFEND;
        IFEND;

      PROCEND support_get_full_help;
?? TITLE := 'support_get_param_assist_prompt', EJECT ??

      PROCEDURE support_get_param_assist_prompt
        (    parameter_number: clt$parameter_number;
             max_message_line: ost$max_status_message_line;
         VAR message: ^ost$status_message;
         VAR support_status: ost$status);

        VAR
          message_parameters: array [1 .. 1] of ^ost$message_parameter,
          message_template: ^ost$message_template,
          parameter_name: clt$parameter_name;


        support_status.normal := TRUE;
        message := NIL;

        find_help_module;
        IF dialog_control.help_module <> NIL THEN
          parameter_name := pdt.names^ [pdt.parameters^ [parameter_number].name_index].name;
          osp$find_param_assist_prompt (dialog_control.help_module, parameter_name, message_template,
                ignore_status);
          IF message_template <> NIL THEN
            convert_name_to_message_param (parameter_name);
            message_parameters [1] := ^parameter_name;
            NEXT message IN work_area;
            IF message = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, support_status);
              RETURN;
            IFEND;
            RESET message;
            format_message (message_template, max_message_line, ^message_parameters, message^);
            RESET work_area TO message;
          IFEND;
        IFEND;

      PROCEND support_get_param_assist_prompt;
?? TITLE := 'support_get_parameter_default', EJECT ??

      PROCEDURE support_get_parameter_default
        (    parameter_number: clt$parameter_number;
         VAR text: ^clt$expression_text;
         VAR support_status: ost$status);

        VAR
          ignore_value_from_default_name: boolean;


        get_parameter_default (parameter_number, text, ignore_value_from_default_name, support_status);

      PROCEND support_get_parameter_default;
?? TITLE := 'support_get_parameter_help', EJECT ??

      PROCEDURE support_get_parameter_help
        (    parameter_number: clt$parameter_number;
             max_message_line: ost$max_status_message_line;
         VAR message: ^ost$status_message;
         VAR support_status: ost$status);

        VAR
          message_parameters: array [1 .. 1] of ^ost$message_parameter,
          message_template: ^ost$message_template,
          parameter_name: clt$parameter_name;


        support_status.normal := TRUE;
        message := NIL;

        find_help_module;
        IF dialog_control.help_module <> NIL THEN
          parameter_name := pdt.names^ [pdt.parameters^ [parameter_number].name_index].name;
          osp$find_parameter_help_message (dialog_control.help_module, parameter_name, message_template,
                ignore_status);
          IF message_template <> NIL THEN
            convert_name_to_message_param (parameter_name);
            message_parameters [1] := ^parameter_name;
            NEXT message IN work_area;
            IF message = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, support_status);
              RETURN;
            IFEND;
            RESET message;
            format_message (message_template, max_message_line, ^message_parameters, message^);
            RESET work_area TO message;
          IFEND;
        IFEND;

      PROCEND support_get_parameter_help;
?? TITLE := 'support_get_parameter_prompt', EJECT ??

      PROCEDURE support_get_parameter_prompt
        (    parameter_number: clt$parameter_number;
             max_message_line: ost$max_status_message_line;
         VAR message: ^ost$status_message;
         VAR support_status: ost$status);


        support_status.normal := TRUE;

        NEXT message IN work_area;
        IF message = NIL THEN
          osp$set_status_condition (cle$work_area_overflow, support_status);
          RETURN;
        IFEND;
        RESET message;
        get_parameter_prompt (parameter_number, max_message_line, message^);
        RESET work_area TO message;

      PROCEND support_get_parameter_prompt;
?? TITLE := 'support_get_parameter_spec', EJECT ??

      PROCEDURE support_get_parameter_spec
        (    parameter_number: clt$parameter_number;
             include_advanced_keywords: boolean;
             max_representation_line: clt$string_size;
         VAR representation: ^clt$data_representation;
         VAR support_status: ost$status);

        VAR
          request: clt$convert_to_string_request;


        support_status.normal := TRUE;

        request.initial_indentation := 0;
        request.continuation_indentation := 6;
        request.max_string := max_representation_line;
        request.include_advanced_items := include_advanced_keywords;
        request.include_hidden_items := FALSE;
        request.kind := clc$convert_unbundled_pdt;
        request.multi_line_pdt_format := TRUE;
        request.parameter_starts_line := TRUE;
        request.individual_parameter := TRUE;
        request.individual_parameter_number := parameter_number;
        request.include_header := FALSE;
        request.command_or_function_name := evaluation_context.command_or_function_name;
        request.aliases := NIL;
        request.availability := clc$normal_usage_entry;
        request.command_or_function_scope := clc$xdcl_command_or_function;
        request.pdt := ^pdt;
        request.pvt := NIL;
        request.symbolic_pdt_qualifiers_area := NIL;
        request.include_implementation_info := FALSE;

        clp$internal_convert_to_string (request, work_area, representation, support_status);
        IF NOT support_status.normal THEN
          RETURN;
        IFEND;

        RESET work_area TO representation;

      PROCEND support_get_parameter_spec;
?? TITLE := 'support_get_parameter_value', EJECT ??

      PROCEDURE support_get_parameter_value
        (    parameter_number: clt$parameter_number;
         VAR value: clt$parameter_value;
         VAR support_status: ost$status);


        support_status.normal := TRUE;

        value := pvt^ [parameter_number];

      PROCEND support_get_parameter_value;
?? TITLE := 'support_get_param_value_source', EJECT ??

      PROCEDURE support_get_param_value_source
        (    parameter_number: clt$parameter_number;
             max_representation_line: clt$string_size;
         VAR representation: ^clt$data_representation;
         VAR support_status: ost$status);


        get_parameter_value_rep (parameter_number, max_representation_line, representation, support_status);
        IF NOT support_status.normal THEN
          RETURN;
        IFEND;

        RESET work_area TO representation;

      PROCEND support_get_param_value_source;
?? TITLE := 'support_get_source', EJECT ??

      PROCEDURE support_get_source
        (VAR source_string: fst$path;
         VAR source_string_size: fst$path_size;
         VAR support_status: ost$status);


        clp$get_cmnd_or_func_source_str (evaluation_context.command_or_function_source^, source_string,
              source_string_size, support_status);

      PROCEND support_get_source;
?? TITLE := 'support_nested_dialog', EJECT ??

      PROCEDURE support_nested_dialog
        (    text: clt$expression_text;
             dialog_pdt: clt$unbundled_pdt;
             dialog_title: clt$string_value;
             max_representation_line: clt$string_size;
         VAR representation: ^clt$data_representation;
         VAR support_status: ost$status);

        VAR
          dialog_evaluation_context: clt$parameter_eval_context,
          dialog_pvt: ^clt$parameter_value_table,
          lexical_units: ^clt$lexical_units,
          original_work_area: ^clt$work_area,
          parameters_parse: clt$parse_state,
          parameters_text: ^clt$expression_text,
          parse: clt$parse_state,
          request: clt$convert_to_string_request;


        support_status.normal := TRUE;
        original_work_area := work_area;

        parameters_text := ^text (1, clp$trimmed_string_size (text));
        clp$identify_lexical_units (parameters_text, work_area, lexical_units, support_status);
        clp$initialize_parse_state (parameters_text, lexical_units, parse);
        clp$scan_non_space_lexical_unit (parse);
        parameters_parse := parse;
        IF parse.unit.kind = clc$lex_left_parenthesis THEN
          clp$scan_bal_paren_lexical_unit (parse);
          parameters_parse.index_limit := parse.unit_index;
          clp$scan_non_space_lexical_unit (parameters_parse);
        IFEND;

        PUSH dialog_pvt: [1 .. dialog_pdt.header^.number_of_parameters];

        dialog_evaluation_context.interpreter_mode := clc$interpret_mode;
        dialog_evaluation_context.interactive_origin := TRUE;
        dialog_evaluation_context.interaction_style := dialog_control.interaction_style;
        dialog_evaluation_context.prompting_requested := TRUE;
        dialog_evaluation_context.command_or_function_name := dialog_title;
        dialog_evaluation_context.command_or_function := clc$function;
        dialog_evaluation_context.procedure_parameters := FALSE;
        dialog_evaluation_context.command_or_function_source := NIL;

        clp$internal_evaluate_params (dialog_evaluation_context, dialog_pdt, NIL, parameters_parse, work_area,
              dialog_pvt, support_status);
        IF NOT support_status.normal THEN
          work_area := original_work_area;
          RETURN;
        IFEND;

        request.initial_indentation := 0;
        request.continuation_indentation := 6;
        request.max_string := max_representation_line;
        request.include_advanced_items := TRUE;
        request.include_hidden_items := TRUE;
        request.kind := clc$convert_parameters;
        request.initial_text := NIL;
        request.include_secure_parameters := TRUE;
        request.evaluated_pdt := ^dialog_pdt;
        request.evaluated_pvt := dialog_pvt;
        request.parameter_substitutions := NIL;

        clp$internal_convert_to_string (request, work_area, representation, support_status);

        work_area := original_work_area;

      PROCEND support_nested_dialog;
?? TITLE := 'support_restore_param_default', EJECT ??

      PROCEDURE support_restore_param_default
        (    parameter_number: clt$parameter_number;
         VAR support_status: ost$status);


        support_status.normal := TRUE;

        unspecify_parameter (parameter_number);

      PROCEND support_restore_param_default;
?? TITLE := 'support_verify_all_parameters', EJECT ??

      PROCEDURE support_verify_all_parameters
        (VAR which_parameter: clt$which_parameter;
         VAR support_status: ost$status);


        support_status.normal := TRUE;

        IF pdt.header^.number_of_parameters = 0 THEN
          RETURN;
        IFEND;

        IF (pdt.header^.number_of_required_parameters > 0) AND (NOT required_parameters_checked) THEN
          check_required_parameters_given (which_parameter, support_status);
          IF NOT support_status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF NOT parameter_defaults_evaluated THEN
          evaluate_parameter_defaults (which_parameter, support_status);
          IF NOT support_status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF (NOT general_param_checks_performed) AND (check_parameters_procedure <> NIL) THEN
          which_parameter.specific := FALSE;
          perform_parameter_checks (which_parameter, support_status);
        IFEND;

      PROCEND support_verify_all_parameters;
?? OLDTITLE, EJECT ??

      VAR
        cancel: boolean,
        context: ^ost$ecp_exception_context,
        initial_status: ^ost$status,
        loaded_address: pmt$loaded_address,
        parameter_dialog_manager: clt$parameter_dialog_manager,
        support: clt$parameter_dialog_support;

      context := NIL;

      IF local_status.normal THEN
        initial_status := NIL;
      ELSE
        PUSH initial_status;
        initial_status^ := local_status;
        local_status.normal := TRUE;
      IFEND;

      loaded_address.kind := pmc$procedure_address;
      loaded_address.pointer_to_procedure := NIL;

    /load_dialog_manager/
      BEGIN
        original_term_error_level := osc$fatal_status;
        #SPOIL (original_term_error_level);
        osp$establish_block_exit_hndlr (^abort_handler);

        pmp$change_term_error_level (osc$fatal_status, original_term_error_level, local_status);
        IF NOT local_status.normal THEN
          EXIT /load_dialog_manager/;
        IFEND;

        IF load_from_system THEN
          REPEAT
            clp$load_system_entry_point (dialog_manager_name, pmc$procedure_address, loaded_address,
                  local_status);
            IF osp$file_access_condition (local_status) THEN
              IF context = NIL THEN
                PUSH context;
                context^ := osv$initial_exception_context;
              IFEND;
              context^.condition_status := local_status;
              osp$enforce_exception_policies (context^);
              local_status := context^.condition_status;
            IFEND;
          UNTIL local_status.normal OR (NOT osp$file_access_condition (local_status)) OR (NOT context^.wait);
        ELSE
          pmp$load (dialog_manager_name, pmc$procedure_address, loaded_address, local_status);
        IFEND;
        IF NOT local_status.normal THEN
          loaded_address.pointer_to_procedure := NIL;
        IFEND;

        pmp$change_term_error_level (original_term_error_level, ignore_term_error_level, local_status);

        osp$disestablish_cond_handler;
      END /load_dialog_manager/;

      IF (NOT local_status.normal) OR (loaded_address.pointer_to_procedure = NIL) THEN
        osp$set_status_abnormal ('CL', cle$unable_to_call_parm_dlg_mgr, dialog_manager_name, local_status);
        RETURN;
      IFEND;

      #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, parameter_dialog_manager);

      cancel := FALSE;

      find_help_module;

      support.get_brief_help := ^support_get_brief_help;
      support.get_full_help := ^support_get_full_help;
      support.get_parameter_prompt := ^support_get_parameter_prompt;
      support.get_parameter_assist_prompt := ^support_get_param_assist_prompt;
      support.get_parameter_help := ^support_get_parameter_help;
      support.get_all_parameter_specs := ^support_get_all_parameter_specs;
      support.get_parameter_spec := ^support_get_parameter_spec;
      support.get_parameter_default := ^support_get_parameter_default;
      support.get_parameter_value := ^support_get_parameter_value;
      support.get_parameter_value_source := ^support_get_param_value_source;
      support.evaluate_parameter := ^support_evaluate_parameter;
      support.restore_parameter_default := ^support_restore_param_default;
      support.verify_all_parameters := ^support_verify_all_parameters;
      support.explain := ^support_explain;
      support.get_all_names := ^support_get_all_names;
      support.get_source := ^support_get_source;
      support.help_module := dialog_control.help_module;
      IF evaluation_context.interpreter_mode = clc$help_mode THEN
        support.change_expression_save := ^support_change_expression_save;
      ELSE
        support.change_expression_save := NIL;
      IFEND;
      support.nested_dialog := ^support_nested_dialog;
      IF evaluation_context.command_or_function_source = NIL THEN
        support.nested_dialog_title := ^evaluation_context.command_or_function_name;
      ELSE
        support.nested_dialog_title := NIL;
      IFEND;

      IF initial_status <> NIL THEN
        local_status := initial_status^;
      IFEND;

      save_source_of_expressions := FALSE;
*IF NOT $true(osv$unix)
      callers_save_area := #PREVIOUS_SAVE_AREA ();
*ELSE
      callers_save_area := NIL;
*IFEND
      #SPOIL (save_source_of_expressions, callers_save_area);
      osp$establish_condition_handler (^invoke_condition_handler, FALSE);

      parameter_dialog_manager^ (support, evaluation_context.command_or_function_name,
            dialog_control.online_manual_name, pdt, cancel, local_status);

      osp$disestablish_cond_handler;

      save_source_of_expressions := evaluation_context.interpreter_mode = clc$help_mode;

      IF local_status.normal AND cancel THEN
        osp$set_status_abnormal ('CL', dialog_control.cancelled_status_code,
              evaluation_context.command_or_function_name, status);
        EXIT clp$internal_evaluate_params;
      IFEND;

    PROCEND invoke_parameter_dialog_manager;
?? TITLE := 'open_line_style_dialog', EJECT ??

    PROCEDURE [INLINE] open_line_style_dialog;


      IF NOT dialog_control.open THEN
        initialize_line_style_dialog;
      IFEND;

    PROCEND open_line_style_dialog;
?? TITLE := 'perform_parameter_checks', EJECT ??

    PROCEDURE perform_parameter_checks
      (    which_parameter: clt$which_parameter;
       VAR local_status: ost$status);

      VAR
        callers_save_area: ^ost$stack_frame_save_area;

?? NEWTITLE := 'bad_check_proc_pointer_handler', EJECT ??

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


        IF (condition.selector = pmc$system_conditions) AND
              (($pmt$system_conditions [pmc$instruction_specification, pmc$address_specification,
              pmc$access_violation, pmc$environment_specification, pmc$invalid_segment_ring_0,
              pmc$out_call_in_return] * condition.system_conditions) <> $pmt$system_conditions []) AND
              (save_area^.minimum_save_area.a2_previous_save_area = callers_save_area) THEN
          osp$set_status_condition (cle$unable_to_call_check_proc, status);
          EXIT clp$internal_evaluate_params;
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      PROCEND bad_check_proc_pointer_handler;
?? OLDTITLE, EJECT ??

      local_status.normal := TRUE;

      IF (evaluation_context.interpreter_mode = clc$help_mode) AND (NOT which_parameter.specific) THEN
        general_param_checks_performed := TRUE;
        RETURN;
      IFEND;

      IF NOT check_procedure_called THEN
*IF NOT $true(osv$unix)
        callers_save_area := #PREVIOUS_SAVE_AREA ();
*ELSE
        callers_save_area := NIL;
*IFEND
        #SPOIL (callers_save_area);
        osp$establish_condition_handler (^bad_check_proc_pointer_handler, FALSE);
      IFEND;

      WHILE TRUE DO
        check_parameters_procedure^ (pvt, which_parameter, local_status);

        IF NOT check_procedure_called THEN
          osp$disestablish_cond_handler;
          check_procedure_called := TRUE;
        IFEND;

        IF local_status.normal OR (NOT dialog_control.activated) OR
              (dialog_control.interaction_style <> osc$line_interaction) OR
              (which_parameter.specific AND (pdt.parameters^ [which_parameter.number].availability =
              clc$hidden_entry)) THEN
          general_param_checks_performed := NOT which_parameter.specific;
          RETURN;
        IFEND;

        prompt_for_correction (which_parameter, local_status);
        local_status.normal := TRUE;

        IF which_parameter.specific THEN
          RETURN;
        IFEND;
      WHILEND;

    PROCEND perform_parameter_checks;
?? TITLE := 'prompt_for_all_desktop_style', EJECT ??

    PROCEDURE [INLINE] prompt_for_all_desktop_style
      (VAR local_status: ost$status);


      invoke_parameter_dialog_manager (clc$desktop_param_dialog_mgr, FALSE, local_status);

    PROCEND prompt_for_all_desktop_style;
?? TITLE := 'prompt_for_all_line_style', EJECT ??

    PROCEDURE prompt_for_all_line_style
      (VAR local_status: ost$status);

      VAR
        message: ost$status_message,
        parameter_number: clt$parameter_number;

?? NEWTITLE := 'prompt_for_parameter', EJECT ??

      PROCEDURE [INLINE] prompt_for_parameter;

        VAR
          which_parameter: clt$which_parameter;


        open_line_style_dialog;
        get_parameter_prompt (parameter_number, dialog_control.page_width, message);
        WHILE TRUE DO
          which_parameter.specific := TRUE;
          which_parameter.number := parameter_number;
          put_prompt_and_get_reply (message, which_parameter);
          dialog_control.prompted_for_parameter^ [parameter_number] := TRUE;
          IF NOT dialog_control.null_reply THEN
            evaluate_nested_parameters (parameter_number);
          IFEND;
          IF pdt.parameters^ [parameter_number].requirement = clc$required_parameter THEN
            IF pvt^ [parameter_number].specified THEN
              IF dialog_control.terminator_in_reply THEN
                EXIT prompt_for_all_line_style;
              IFEND;
              RETURN;
            IFEND;
          ELSEIF dialog_control.terminator_in_reply THEN
            EXIT prompt_for_all_line_style;
          ELSEIF dialog_control.null_reply OR pvt^ [parameter_number].specified THEN
            RETURN;
          IFEND;
        WHILEND;

      PROCEND prompt_for_parameter;
?? OLDTITLE, EJECT ??

      VAR
        message_name: ost$name,
        message_parameters: array [1 .. 1] of ^ost$message_parameter,
        message_template: ^ost$message_template,
        which_parameter: clt$which_parameter;


      IF (pdt.header^.number_of_parameters - pdt.header^.number_of_hidden_parameters -
            $INTEGER (pdt.header^.status_parameter_number <> 0)) <= 0 THEN

        IF (NOT general_param_checks_performed) AND (check_parameters_procedure <> NIL) THEN
          which_parameter.specific := FALSE;
          perform_parameter_checks (which_parameter, local_status);
          IF NOT local_status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        dialog_control.parameters_to_prompt_for := FALSE;
        open_line_style_dialog;
        IF evaluation_context.command_or_function = clc$command THEN
          message_name := clc$no_command_params_msg;
        ELSE
          message_name := clc$no_function_params_msg;
        IFEND;
        find_default_help_module;
        osp$find_param_assist_prompt (dialog_control.default_help_module, message_name, message_template,
              ignore_status);
        message_parameters [1] := ^evaluation_context.command_or_function_name;
        format_message (message_template, dialog_control.page_width, ^message_parameters, message);
        which_parameter.specific := FALSE;
        put_prompt_and_get_reply (message, which_parameter);

{ Ignore the reply to the above prompt.

        RETURN;
      IFEND;

      FOR parameter_number := 1 TO pdt.header^.number_of_parameters DO
        IF (NOT pvt^ [parameter_number].specified) AND (pdt.parameters^ [parameter_number].availability =
              clc$normal_usage_entry) AND (parameter_number <> pdt.header^.status_parameter_number) AND
              (NOT dialog_control.prompted_for_parameter^ [parameter_number]) THEN
          prompt_for_parameter;
        IFEND;
      FOREND;

      IF pdt.header^.number_of_advanced_parameters > 0 THEN
        FOR parameter_number := 1 TO pdt.header^.number_of_parameters DO
          IF (NOT pvt^ [parameter_number].specified) AND (pdt.parameters^ [parameter_number].availability =
                clc$advanced_usage_entry) AND (NOT dialog_control.prompted_for_parameter^ [parameter_number])
                THEN

            IF NOT dialog_control.prompting_for_advanced_params THEN
              open_line_style_dialog;

              find_default_help_module;
              osp$find_param_assist_prompt (dialog_control.default_help_module, clc$prompt_for_advanced_param,
                    message_template, ignore_status);
              format_message (message_template, dialog_control.page_width, NIL, message);

              which_parameter.specific := FALSE;
              put_prompt_and_get_yn_reply (message, which_parameter,
                    dialog_control.prompting_for_advanced_params);
              IF NOT dialog_control.prompting_for_advanced_params THEN
                RETURN;
              IFEND;
            IFEND;

            prompt_for_parameter;
          IFEND;
        FOREND;
      IFEND;

      IF (pdt.header^.number_of_required_parameters > 0) AND (NOT required_parameters_checked) THEN
        check_required_parameters_given (which_parameter, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF NOT parameter_defaults_evaluated THEN
        evaluate_parameter_defaults (which_parameter, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF (NOT general_param_checks_performed) AND (check_parameters_procedure <> NIL) THEN
        which_parameter.specific := FALSE;
        perform_parameter_checks (which_parameter, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF evaluation_context.prompting_requested AND (NOT dialog_control.open) THEN
        dialog_control.parameters_to_prompt_for := FALSE;
        initialize_line_style_dialog;
        message_name := clc$all_command_params_correct;
        find_default_help_module;
        osp$find_param_assist_prompt (dialog_control.default_help_module, message_name, message_template,
              ignore_status);
        message_parameters [1] := ^evaluation_context.command_or_function_name;
        format_message (message_template, dialog_control.page_width, ^message_parameters, message);
        which_parameter.specific := FALSE;
        put_prompt_and_get_reply (message, which_parameter);

{ Ignore the reply to the above prompt.

      IFEND;

    PROCEND prompt_for_all_line_style;
?? TITLE := 'prompt_for_all_screen_style', EJECT ??

    PROCEDURE [INLINE] prompt_for_all_screen_style
      (VAR local_status: ost$status);


      invoke_parameter_dialog_manager (clc$screen_param_dialog_mgr, TRUE, local_status);

    PROCEND prompt_for_all_screen_style;
?? TITLE := 'prompt_for_correction', EJECT ??

    PROCEDURE prompt_for_correction
      (    which_parameter: clt$which_parameter;
           local_status: ost$status);

      VAR
        message: ost$status_message,
        parameter_number: clt$parameter_number;

?? NEWTITLE := 'get_correct_parameters_prompt', EJECT ??

      PROCEDURE get_correct_parameters_prompt;

        VAR
          message_template: ^ost$message_template;


        find_default_help_module;
        osp$find_param_assist_prompt (dialog_control.default_help_module, clc$correct_parameters_prompt,
              message_template, ignore_status);
        format_message (message_template, dialog_control.page_width, NIL, message);

      PROCEND get_correct_parameters_prompt;
?? TITLE := 'get_param_assist_prompt', EJECT ??

      PROCEDURE get_param_assist_prompt;

        VAR
          converted_parameter_name: clt$parameter_name,
          ignore_last_line_of_message: ^ost$status_message_line,
          message_parameters: array [1 .. 1] of ^ost$message_parameter,
          message_template: ^ost$message_template,
          parameter_name: clt$parameter_name;


        parameter_name := pdt.names^ [pdt.parameters^ [parameter_number].name_index].name;
        converted_parameter_name := parameter_name;
        convert_name_to_message_param (converted_parameter_name);
        message_parameters [1] := ^converted_parameter_name;

      /find_param_assist_prompt/
        BEGIN
          find_help_module;

          IF dialog_control.help_module <> NIL THEN
            osp$find_param_assist_prompt (dialog_control.help_module, parameter_name, message_template,
                  ignore_status);
            IF message_template <> NIL THEN
              format_message (message_template, dialog_control.page_width, ^message_parameters, message);
              put_message (message, ignore_last_line_of_message);
            IFEND;

            osp$find_parameter_prompt (dialog_control.help_module, parameter_name, message_template,
                  ignore_status);
            IF message_template <> NIL THEN
              EXIT /find_param_assist_prompt/;
            IFEND;
          IFEND;

          find_default_help_module;

          osp$find_parameter_prompt (dialog_control.default_help_module, clc$default_parameter_prompt,
                message_template, ignore_status);
        END /find_param_assist_prompt/;

        format_message (message_template, dialog_control.page_width, ^message_parameters, message);

      PROCEND get_param_assist_prompt;
?? OLDTITLE, EJECT ??

      VAR
        correction_supplied: boolean;


      open_line_style_dialog;

      IF NOT local_status.normal THEN
        put_status (local_status);
      IFEND;

      IF which_parameter.specific THEN
        parameter_number := which_parameter.number;
        unspecify_parameter (parameter_number);
        get_param_assist_prompt;
        dialog_control.prompted_for_parameter^ [parameter_number] := TRUE;
      ELSE
        parameter_number := 1;
        get_correct_parameters_prompt;
      IFEND;

      correction_supplied := FALSE;
      REPEAT
        put_prompt_and_get_reply (message, which_parameter);
        IF NOT dialog_control.null_reply THEN
          correction_supplied := TRUE;
          evaluate_nested_parameters (parameter_number);
        IFEND;
      UNTIL which_parameter.specific OR correction_supplied OR
            (evaluation_context.interpreter_mode = clc$help_mode);

    PROCEND prompt_for_correction;
?? TITLE := 'put_line', EJECT ??

    PROCEDURE [INLINE] put_line
      (    line: string ( * ));

      VAR
        ignore_byte_address: amt$file_byte_address;


      amp$put_next (dialog_control.output_file_id, ^line, STRLENGTH (line), ignore_byte_address, status);
      IF NOT status.normal THEN
        EXIT clp$internal_evaluate_params;
      IFEND;

    PROCEND put_line;
?? TITLE := 'put_message', EJECT ??

    PROCEDURE [INLINE] put_message
      (    message: ost$status_message;
       VAR last_line_of_message: ^ost$status_message_line);

      VAR
        message_area: ^ost$status_message,
        message_line_count: ^ost$status_message_line_count,
        message_line_index: 1 .. osc$max_status_message_lines,
        message_line_size: ^ost$status_message_line_size;


      message_area := ^message;
      RESET message_area;
      NEXT message_line_count IN message_area;

      IF message_line_count^ = 0 THEN
        last_line_of_message := NIL;
      ELSE
        FOR message_line_index := 1 TO message_line_count^ DO
          NEXT message_line_size IN message_area;
          NEXT last_line_of_message: [message_line_size^] IN message_area;
          put_line (last_line_of_message^);
        FOREND;
      IFEND;

    PROCEND put_message;
?? TITLE := 'put_prompt_and_get_reply', EJECT ??

    PROCEDURE put_prompt_and_get_reply
      (    prompt: ost$status_message;
           which_parameter: clt$which_parameter);

      VAR
        help_level: (clc$parameter_help, clc$advanced_parameter_help, clc$brief_help, clc$full_help,
              clc$advanced_help, clc$online_manual_help),
        last_line_of_prompt: ^ost$status_message_line,
        local_status: ost$status,
        original_terminal_attributes: array [1 .. 2] of ift$terminal_attribute,
        retry_get: boolean,
        secure_prompt: ^ost$status_message_line,
        secure_terminal_attributes: array [1 .. 2] of ift$terminal_attribute;

?? NEWTITLE := 'get_prompting_reply', EJECT ??

      PROCEDURE get_prompting_reply;

?? NEWTITLE := 'get_reply_break_handler', EJECT ??

        PROCEDURE get_reply_break_handler
          (    condition: pmt$condition;
               ignore_condition_information: ^pmt$condition_information;
               ignore_save_area: ^ost$stack_frame_save_area;
           VAR handler_status: ost$status);


          CASE condition.selector OF

          = pmc$block_exit_processing =
            IF (secure_prompt <> NIL) AND (NOT retry_get) THEN
              ifp$change_terminal_attributes (clv$standard_files [clc$sf_command_file].path_handle_name,
                    original_terminal_attributes, ignore_status);
            IFEND;
            RETURN;

          = ifc$interactive_condition =
            IF condition.interactive_condition = ifc$terminate_break THEN
              IF evaluation_context.prompting_requested THEN
                osp$set_status_abnormal ('CL', dialog_control.cancelled_status_code,
                      evaluation_context.command_or_function_name, status);
                EXIT clp$internal_evaluate_params;
              IFEND;
              ignore_terminate_breaks := FALSE;
              #SPOIL (ignore_terminate_breaks);
            IFEND;

          ELSE
            ;
          CASEND;

          IF secure_prompt <> NIL THEN
            ifp$change_terminal_attributes (clv$standard_files [clc$sf_command_file].path_handle_name,
                  original_terminal_attributes, ignore_status);
          IFEND;

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

          ignore_terminate_breaks := TRUE;
          #SPOIL (ignore_terminate_breaks);

          IF handler_status.normal AND (condition.selector = ifc$interactive_condition) THEN
            IF condition.interactive_condition = ifc$pause_break THEN
              retry_get := TRUE;
              #SPOIL (retry_get);
              EXIT get_prompting_reply;
            ELSEIF condition.interactive_condition = ifc$terminate_break THEN
              osp$set_status_abnormal ('CL', dialog_control.cancelled_status_code,
                    evaluation_context.command_or_function_name, status);
              EXIT clp$internal_evaluate_params;
            IFEND;
          IFEND;

          IF secure_prompt <> NIL THEN
            ifp$change_terminal_attributes (clv$standard_files [clc$sf_command_file].path_handle_name,
                  secure_terminal_attributes, ignore_status);
          IFEND;

        PROCEND get_reply_break_handler;
?? TITLE := 'overwrite_secure_reply', EJECT ??

        CONST
          overwrite_multiple = 3,
          overwrite_pattern_size = overwrite_multiple * (osc$max_name_size - 1);

        VAR
          blank_overwrite: [STATIC, READ, oss$job_paged_literal] string (overwrite_pattern_size) := ' ',
          overwrite_pattern: [STATIC, READ, oss$job_paged_literal] string
                (overwrite_pattern_size + overwrite_multiple - 1) :=
                'HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI' CAT
                '#HI#HI';

?? SKIP := 3 ??

        PROCEDURE [INLINE] overwrite_secure_reply;

          VAR
            i: integer,
            ignore_byte_address: amt$file_byte_address,
            j: integer,
            overwrite_size: clt$command_line_size;


          overwrite_size := STRLENGTH (dialog_control.reply_parse.text^);
          IF overwrite_size < osc$max_name_size THEN
            overwrite_size := osc$max_name_size;
          IFEND;

          FOR i := 1 TO overwrite_multiple DO
            amp$put_partial (dialog_control.output_file_id, secure_prompt, STRLENGTH (secure_prompt^),
                  ignore_byte_address, amc$start, ignore_status);
            FOR j := 1 TO (overwrite_size DIV overwrite_pattern_size) DO
              amp$put_partial (dialog_control.output_file_id, ^overwrite_pattern (i), overwrite_pattern_size,
                    ignore_byte_address, amc$continue, ignore_status);
            FOREND;
            amp$put_partial (dialog_control.output_file_id, ^overwrite_pattern (i),
                  overwrite_size MOD overwrite_pattern_size, ignore_byte_address, amc$terminate,
                  ignore_status);
          FOREND;

          amp$put_partial (dialog_control.output_file_id, secure_prompt, STRLENGTH (secure_prompt^),
                ignore_byte_address, amc$start, ignore_status);
          FOR j := 1 TO (overwrite_size DIV overwrite_pattern_size) DO
            amp$put_partial (dialog_control.output_file_id, ^blank_overwrite, overwrite_pattern_size,
                  ignore_byte_address, amc$continue, ignore_status);
          FOREND;
          amp$put_partial (dialog_control.output_file_id, ^blank_overwrite,
                overwrite_size MOD overwrite_pattern_size, ignore_byte_address, amc$terminate, ignore_status);

        PROCEND overwrite_secure_reply;
?? OLDTITLE, EJECT ??

        VAR
          end_of_input: boolean;


        osp$establish_condition_handler (^get_reply_break_handler, TRUE);

        IF secure_prompt <> NIL THEN
          ifp$change_terminal_attributes (clv$standard_files [clc$sf_command_file].path_handle_name,
                secure_terminal_attributes, ignore_status);
        IFEND;

        clp$get_command_line (dialog_control.reply_parse, end_of_input, local_status);

        IF end_of_input AND local_status.normal THEN
          IF status.normal THEN
            osp$set_status_abnormal ('CL', cle$interactive_eoi_ignored, '', status);
            osp$generate_output_message(status,ignore_status);
            clp$reset_input_state;
            retry_get := TRUE;
            status.normal := TRUE;
          IFEND;
        IFEND;

        IF secure_prompt <> NIL THEN
          ifp$change_terminal_attributes (clv$standard_files [clc$sf_command_file].path_handle_name,
                original_terminal_attributes, ignore_status);
        IFEND;

        osp$disestablish_cond_handler;

        IF secure_prompt <> NIL THEN
          overwrite_secure_reply;
        IFEND;

        IF NOT local_status.normal THEN
          status := local_status;
          EXIT clp$internal_evaluate_params;
        IFEND;

      PROCEND get_prompting_reply;
?? TITLE := 'process_command_line', EJECT ??

      PROCEDURE process_command_line;

        VAR
          terminate_break_detected: boolean;

?? NEWTITLE := 'terminate_command_handler', EJECT ??

        PROCEDURE terminate_command_handler
          (    condition: pmt$condition;
               ignore_condition_information: ^pmt$condition_information;
               ignore_save_area: ^ost$stack_frame_save_area;
           VAR handler_status: ost$status);


          CASE condition.selector OF

          = pmc$block_exit_processing =
            IF terminate_break_detected THEN
              ifp$discard_suspended_output;
              osp$set_status_condition (cle$command_terminated, local_status);
              put_status (local_status);
            IFEND;
            RETURN;

          = ifc$interactive_condition =
            IF condition.interactive_condition = ifc$terminate_break THEN
              terminate_break_detected := TRUE;
              EXIT process_command_line;
            IFEND;

          ELSE
            ;
          CASEND;

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

        PROCEND terminate_command_handler;
?? OLDTITLE, EJECT ??

        CONST
          enable_echoing = TRUE;


*IF NOT $true(osv$unix)
        IF #RING (^dialog_control) < avp$ring_min () THEN
          osp$set_status_condition (cle$param_dialog_not_privileged, local_status);
          put_status (local_status);
          RETURN;
        IFEND;
*IFEND

        terminate_break_detected := FALSE;
        #SPOIL (terminate_break_detected);
        osp$establish_condition_handler (^terminate_command_handler, TRUE);

        clp$include_line (dialog_control.reply_parse.text^ (2, * ), enable_echoing, osc$null_name,
              local_status);
        IF NOT local_status.normal THEN
          put_status (local_status);
        IFEND;

      PROCEND process_command_line;
?? TITLE := 'process_help_request', EJECT ??

      PROCEDURE process_help_request;

        VAR
          request: clt$convert_to_string_request,
          representation: ^clt$data_representation,
          terminate_break_detected: boolean;

?? NEWTITLE := 'display_all_parameters', EJECT ??

        PROCEDURE display_all_parameters
          (    include_advanced_items: boolean);


          request.initial_indentation := 1;
          request.continuation_indentation := 7;
          request.max_string := dialog_control.page_width + 1;
          request.include_advanced_items := include_advanced_items;
          request.include_hidden_items := FALSE;
          request.kind := clc$convert_unbundled_pdt;
          request.multi_line_pdt_format := FALSE;
          request.parameter_starts_line := TRUE;
          request.individual_parameter := FALSE;
          request.individual_parameter_number := LOWERVALUE (clt$parameter_number);
          request.include_header := FALSE;
          request.command_or_function_name := evaluation_context.command_or_function_name;
          request.aliases := NIL;
          request.availability := clc$normal_usage_entry;
          request.command_or_function_scope := clc$xdcl_command_or_function;
          request.pdt := ^pdt;
          request.pvt := pvt;
          request.symbolic_pdt_qualifiers_area := NIL;
          request.include_implementation_info := FALSE;

          clp$internal_convert_to_string (request, work_area, representation, local_status);
          IF NOT local_status.normal THEN
            RETURN;
          IFEND;

          put_representation;

          RESET work_area TO representation;

        PROCEND display_all_parameters;
?? TITLE := 'display_current_parameter', EJECT ??

        PROCEDURE display_current_parameter
          (    include_advanced_items: boolean);


          request.initial_indentation := 1;
          request.continuation_indentation := 7;
          request.max_string := dialog_control.page_width + 1;
          request.include_advanced_items := include_advanced_items;
          request.include_hidden_items := FALSE;
          request.kind := clc$convert_unbundled_pdt;
          request.multi_line_pdt_format := TRUE;
          request.parameter_starts_line := TRUE;
          request.individual_parameter := TRUE;
          request.individual_parameter_number := which_parameter.number;
          request.include_header := FALSE;
          request.command_or_function_name := evaluation_context.command_or_function_name;
          request.aliases := NIL;
          request.availability := clc$normal_usage_entry;
          request.command_or_function_scope := clc$xdcl_command_or_function;
          request.pdt := ^pdt;
          request.pvt := pvt;
          request.symbolic_pdt_qualifiers_area := NIL;
          request.include_implementation_info := FALSE;

          clp$internal_convert_to_string (request, work_area, representation, local_status);
          IF NOT local_status.normal THEN
            RETURN;
          IFEND;

          put_representation;

          RESET work_area TO representation;

        PROCEND display_current_parameter;
?? TITLE := 'put_representation', EJECT ??

        PROCEDURE [INLINE] put_representation;

          VAR
            representation_line: ^clt$string_value,
            representation_line_count: ^clt$data_representation_count,
            representation_line_index: clt$data_representation_count,
            representation_line_size: ^clt$string_size;


          RESET representation;
          NEXT representation_line_count IN representation;

          FOR representation_line_index := 1 TO representation_line_count^ DO
            NEXT representation_line_size IN representation;
            NEXT representation_line: [representation_line_size^] IN representation;
            put_line (representation_line^);
          FOREND;

        PROCEND put_representation;
?? TITLE := 'terminate_help_handler', EJECT ??

        PROCEDURE terminate_help_handler
          (    condition: pmt$condition;
               ignore_condition_information: ^pmt$condition_information;
               ignore_save_area: ^ost$stack_frame_save_area;
           VAR handler_status: ost$status);


          CASE condition.selector OF

          = pmc$block_exit_processing =
            IF terminate_break_detected THEN
              ifp$discard_suspended_output;
            IFEND;
            RETURN;

          = ifc$interactive_condition =
            IF condition.interactive_condition = ifc$terminate_break THEN
              terminate_break_detected := TRUE;
              EXIT process_help_request;
            IFEND;

          ELSE
            ;
          CASEND;

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

        PROCEND terminate_help_handler;
?? OLDTITLE, EJECT ??

        VAR
          help_given: boolean,
          ignore_last_line_of_message: ^ost$status_message_line,
          message: ost$status_message,
          message_parameters: array [1 .. 1] of ^ost$message_parameter,
          message_template: ^ost$message_template,
          parameter_name: clt$parameter_name;


        terminate_break_detected := FALSE;
        #SPOIL (terminate_break_detected);
        osp$establish_condition_handler (^terminate_help_handler, TRUE);

        help_given := FALSE;
        REPEAT
          CASE help_level OF

          = clc$parameter_help =
            IF which_parameter.specific THEN

            /process_parameter_help_request/
              BEGIN
                find_help_module;
                IF dialog_control.help_module <> NIL THEN
                  parameter_name := pdt.names^ [pdt.parameters^ [which_parameter.number].name_index].name;
                  osp$find_parameter_help_message (dialog_control.help_module, parameter_name,
                        message_template, ignore_status);
                  IF message_template <> NIL THEN
                    convert_name_to_message_param (parameter_name);
                    message_parameters [1] := ^parameter_name;
                    format_message (message_template, dialog_control.page_width, ^message_parameters,
                          message);
                    put_message (message, ignore_last_line_of_message);
                    EXIT /process_parameter_help_request/;
                  IFEND;
                IFEND;

                display_current_parameter (FALSE);
              END /process_parameter_help_request/;
              help_given := TRUE;
            IFEND;

          = clc$advanced_parameter_help =

            IF which_parameter.specific AND pdt.type_descriptions^ [which_parameter.number].
                  advanced_keywords_present THEN
              display_current_parameter (TRUE);
              help_given := TRUE;
            IFEND;

          = clc$brief_help =

            find_help_module;
            IF dialog_control.help_module <> NIL THEN
              osp$find_brief_help_message (dialog_control.help_module, message_template, ignore_status);
              IF message_template <> NIL THEN
                format_message (message_template, dialog_control.page_width, NIL, message);
                put_message (message, ignore_last_line_of_message);
                help_given := TRUE;
              IFEND;
            IFEND;

          = clc$full_help =

            find_help_module;
            IF dialog_control.help_module <> NIL THEN
              osp$find_full_help_message (dialog_control.help_module, message_template, ignore_status);
              IF message_template <> NIL THEN
                format_message (message_template, dialog_control.page_width, NIL, message);
                put_message (message, ignore_last_line_of_message);
              IFEND;
            IFEND;

            display_all_parameters (dialog_control.prompting_for_advanced_params);
            help_given := TRUE;

          = clc$advanced_help =

            IF (pdt.header^.number_of_advanced_parameters > 0) AND
                  (NOT dialog_control.prompting_for_advanced_params) THEN
              display_all_parameters (TRUE);
              help_given := TRUE;
            IFEND;

          = clc$online_manual_help =

            explain_command_or_function (help_given, local_status);
            help_given := local_status.normal AND help_given;

          CASEND;
          IF help_level < UPPERVALUE (help_level) THEN
            help_level := SUCC (help_level);
          ELSE
            help_level := LOWERVALUE (help_level);
          IFEND;
        UNTIL help_given;

        osp$disestablish_cond_handler;

      PROCEND process_help_request;
?? OLDTITLE, EJECT ??

      IF which_parameter.specific THEN
        help_level := clc$parameter_help;
      ELSE
        help_level := clc$full_help;
      IFEND;

      secure_prompt := NIL;
      ignore_terminate_breaks := TRUE;
      #SPOIL (secure_prompt, ignore_terminate_breaks);

    /put_prompt_and_get_reply_loop/
      WHILE TRUE DO
        put_message (prompt, last_line_of_prompt);

        IF which_parameter.specific AND (pdt.parameters^ [which_parameter.number].security =
              clc$secure_parameter) AND (secure_prompt = NIL) THEN
          IF last_line_of_prompt = NIL THEN
            PUSH secure_prompt: [2];
            secure_prompt^ (2) := ' ';
          ELSE
            PUSH secure_prompt: [STRLENGTH (last_line_of_prompt^) + 1];
            secure_prompt^ := last_line_of_prompt^;
          IFEND;
          secure_prompt^ (1) := ifc$pre_print_start_of_line;
          #SPOIL (secure_prompt, secure_prompt^);

          original_terminal_attributes [1].key := ifc$echoplex;
          original_terminal_attributes [2].key := ifc$end_line_positioning;
          ifp$get_terminal_attributes (clv$standard_files [clc$sf_command_file].path_handle_name,
                original_terminal_attributes, local_status);
          IF NOT local_status.normal THEN
            status := local_status;
            EXIT clp$internal_evaluate_params;
          IFEND;

          secure_terminal_attributes [1].key := ifc$echoplex;
          secure_terminal_attributes [1].echoplex := FALSE;
          secure_terminal_attributes [2].key := ifc$end_line_positioning;
          secure_terminal_attributes [2].end_line_positioning := ifc$elp_none;
          #SPOIL (secure_terminal_attributes);
        IFEND;

        retry_get := FALSE;
        #SPOIL (retry_get);

        get_prompting_reply;

        IF retry_get THEN
          CYCLE /put_prompt_and_get_reply_loop/;

        ELSEIF STRLENGTH (dialog_control.reply_parse.text^) = 0 THEN
          dialog_control.null_reply := TRUE;
          dialog_control.terminator_in_reply := FALSE;
          EXIT /put_prompt_and_get_reply_loop/;

        ELSEIF (STRLENGTH (dialog_control.reply_parse.text^) = 1) AND
              (dialog_control.reply_parse.text^ (1) = clc$help_request) THEN
          process_help_request;

        ELSEIF dialog_control.reply_parse.text^ (1) = clc$escape_prefix THEN
          process_command_line;

        ELSE
          dialog_control.terminator_in_reply := dialog_control.reply_parse.
                text^ (STRLENGTH (dialog_control.reply_parse.text^)) = clc$terminator_suffix;
          IF dialog_control.terminator_in_reply THEN
            dialog_control.reply_parse.index_limit := dialog_control.reply_parse.index_limit - 1;
          IFEND;
          dialog_control.null_reply := STRLENGTH (dialog_control.reply_parse.text^) =
                $INTEGER (dialog_control.terminator_in_reply);
          EXIT /put_prompt_and_get_reply_loop/;

        IFEND;
      WHILEND /put_prompt_and_get_reply_loop/;

      ignore_terminate_breaks := FALSE;

    PROCEND put_prompt_and_get_reply;
?? TITLE := 'put_prompt_and_get_yn_reply', EJECT ??

    PROCEDURE put_prompt_and_get_yn_reply
      (    prompt: ost$status_message;
           which_parameter: clt$which_parameter;
       VAR yes_or_no: boolean);

      VAR
        local_status: ost$status,
        name: ost$name;


      WHILE TRUE DO
        put_prompt_and_get_reply (prompt, which_parameter);
        IF dialog_control.null_reply THEN
          RETURN;
        IFEND;
        check_reply_for_name (name, local_status);
        IF local_status.normal THEN
          IF (name = 'YES') OR (name = 'Y') THEN
            yes_or_no := TRUE;
            RETURN;
          ELSEIF (name = 'NO') OR (name = 'N') THEN
            yes_or_no := FALSE;
            RETURN;
          IFEND;
        IFEND;
      WHILEND;

    PROCEND put_prompt_and_get_yn_reply;
?? TITLE := 'put_status', EJECT ??

    PROCEDURE [INLINE] put_status
      (    message_status: ost$status);

      osp$generate_output_message (message_status, ignore_status);

    PROCEND put_status;
?? TITLE := 'unspecify_parameter', EJECT ??

    PROCEDURE [INLINE] unspecify_parameter
      (    parameter_number: clt$parameter_number);


      pvt^ [parameter_number].specified := FALSE;
      IF pvt^ [parameter_number].passing_method = clc$pass_by_value THEN
        pvt^ [parameter_number].value := NIL;
      ELSE
        pvt^ [parameter_number].variable := NIL;
        IF evaluation_context.procedure_parameters THEN
          clp$unpass_variable_parameter (parameter_number);
        IFEND;
      IFEND;

      CASE pdt.parameters^ [parameter_number].requirement OF
      = clc$required_parameter =
        required_parameters_checked := FALSE;
      = clc$optional_default_parameter, clc$confirm_default_parameter =
        parameter_defaults_evaluated := FALSE;
      ELSE
        ;
      CASEND;

      general_param_checks_performed := FALSE;

    PROCEND unspecify_parameter;
?? OLDTITLE, EJECT ??
*IFEND

    VAR
      local_status: ost$status,
      which_parameter: clt$which_parameter;


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

    parameter_defaults_evaluated := FALSE;
    required_parameters_checked := FALSE;
    check_procedure_called := FALSE;
    general_param_checks_performed := FALSE;
    save_source_of_expressions := evaluation_context.interpreter_mode = clc$help_mode;

  /evaluate/
    BEGIN
      IF ((pdt.header^.number_of_parameters = 0) AND (pvt <> NIL)) OR
            ((pdt.header^.number_of_parameters > 0) AND ((pvt = NIL) OR
            (UPPERBOUND (pvt^) <> pdt.header^.number_of_parameters))) THEN
        osp$set_status_condition (cle$bad_pvt, status);
        EXIT /evaluate/;
      IFEND;

      initialize_pvt;

*IF NOT $true(osv$unix)
      IF pdt.header^.number_of_parameters = 0 THEN
        dialog_control.prompted_for_parameter := NIL;
      ELSE
        PUSH dialog_control.prompted_for_parameter: [1 .. pdt.header^.number_of_parameters];
      IFEND;
      initialize_dialog_control;

      IF dialog_control.activated THEN
        ignore_terminate_breaks := FALSE;
        #SPOIL (ignore_terminate_breaks);
        osp$establish_condition_handler (^abort_handler, TRUE);
      IFEND;
*IFEND

      IF parse.unit_index < parse.index_limit THEN
        evaluate_parameters (TRUE, 1, parse, local_status);
        IF local_status.normal AND (NOT prompt_for_all_parameters) AND
              (pdt.header^.number_of_required_parameters > 0) AND (NOT required_parameters_checked) THEN
          check_required_parameters_given (which_parameter, local_status);
        IFEND;
      IFEND;

*IF NOT $true(osv$unix)
      IF prompt_for_all_parameters OR ((NOT local_status.normal) AND
            (dialog_control.interaction_style <> osc$line_interaction)) THEN
        CASE dialog_control.interaction_style OF
        = osc$line_interaction =
          IF local_status.normal AND (NOT (dialog_control.open AND dialog_control.terminator_in_reply)) THEN
            prompt_for_all_line_style (local_status);
          IFEND;
        = osc$screen_interaction =
          prompt_for_all_screen_style (local_status);
          dialog_control.interaction_style := osc$line_interaction;
          IF (NOT local_status.normal) AND (local_status.condition = cle$unable_to_call_parm_dlg_mgr) THEN
            local_status.normal := TRUE;
            prompt_for_all_line_style (local_status);
          IFEND;
        = osc$desktop_interaction =
          prompt_for_all_desktop_style (local_status);
          dialog_control.activated := FALSE;
        CASEND;
      IFEND;
*IFEND

      IF (NOT local_status.normal) OR (pdt.header^.number_of_parameters = 0) THEN
        EXIT /evaluate/;
      IFEND;

      IF (pdt.header^.number_of_required_parameters > 0) AND (NOT required_parameters_checked) THEN
        check_required_parameters_given (which_parameter, local_status);
        IF NOT local_status.normal THEN
          EXIT /evaluate/;
        IFEND;
      IFEND;

      IF NOT parameter_defaults_evaluated THEN
        evaluate_parameter_defaults (which_parameter, local_status);
        IF NOT local_status.normal THEN
          EXIT /evaluate/;
        IFEND;
      IFEND;

*IF NOT $true(osv$unix)
      IF (NOT general_param_checks_performed) AND (check_parameters_procedure <> NIL) THEN
        which_parameter.specific := FALSE;
        perform_parameter_checks (which_parameter, local_status);
      IFEND;
*IFEND
    END /evaluate/;

    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

*IF NOT $true(osv$unix)
    IF dialog_control.activated THEN
      close_dialog;
      osp$disestablish_cond_handler;
    IFEND;
*IFEND

  PROCEND clp$internal_evaluate_params;
?? TITLE := 'clp$unbundle_pdt', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$unbundle_pdt
    (    parameter_description_table: ^clt$parameter_description_table;
     VAR work_area {input, output} : ^clt$work_area;
     VAR unbundled_pdt: clt$unbundled_pdt;
     VAR status: ost$status);

    VAR
      i: clt$parameter_number,
      pdt: ^clt$parameter_description_table,
*IF $true(osv$unix)
      kludge_type_spec: ^ array [*] of cell,
*IFEND
      type_specification: ^clt$type_specification;


    status.normal := TRUE;

  /ok/
    BEGIN
      IF parameter_description_table = NIL THEN
        EXIT /ok/;
      IFEND;
      pdt := parameter_description_table;
      RESET pdt;
      NEXT unbundled_pdt.header IN pdt;
      IF unbundled_pdt.header = NIL THEN
        EXIT /ok/;
      IFEND;

*IF NOT $true(osv$unix)
      IF unbundled_pdt.header^.version <> clc$declaration_version THEN
*ELSE
      IF (unbundled_pdt.header^.version < 1) OR
            (unbundled_pdt.header^.version > clc$declaration_version) THEN
*IFEND
        osp$set_status_condition (cle$bad_declaration_version, status);
        osp$append_status_integer (osc$status_parameter_delimiter, unbundled_pdt.header^.version, 10, FALSE,
              status);
        RETURN;
      IFEND;

      IF (unbundled_pdt.header^.number_of_parameter_names > clc$max_parameter_names) OR
            (unbundled_pdt.header^.number_of_parameters > unbundled_pdt.header^.number_of_parameter_names)
            THEN
        EXIT /ok/;
      IFEND;

      IF unbundled_pdt.header^.number_of_parameter_names = 0 THEN
        IF unbundled_pdt.header^.number_of_parameters <> 0 THEN
          EXIT /ok/;
        IFEND;
        unbundled_pdt.names := NIL;
        unbundled_pdt.parameters := NIL;
        unbundled_pdt.type_descriptions := NIL;
        unbundled_pdt.default_names := NIL;
        unbundled_pdt.default_values := NIL;
        RETURN;
      IFEND;

      IF unbundled_pdt.header^.number_of_parameters <= 0 THEN
        EXIT /ok/;
      IFEND;
      NEXT unbundled_pdt.names: [1 .. unbundled_pdt.header^.number_of_parameter_names] IN pdt;
      NEXT unbundled_pdt.parameters: [1 .. unbundled_pdt.header^.number_of_parameters] IN pdt;
      IF (unbundled_pdt.names = NIL) OR (unbundled_pdt.parameters = NIL) THEN
        EXIT /ok/;
      IFEND;
      NEXT unbundled_pdt.type_descriptions: [1 .. unbundled_pdt.header^.number_of_parameters] IN work_area;
      NEXT unbundled_pdt.default_names: [1 .. unbundled_pdt.header^.number_of_parameters] IN work_area;
      NEXT unbundled_pdt.default_values: [1 .. unbundled_pdt.header^.number_of_parameters] IN work_area;
      FOR i := 1 TO unbundled_pdt.header^.number_of_parameters DO
*IF NOT $true(osv$unix)
        NEXT type_specification: [[REP unbundled_pdt.parameters^ [i].type_specification_size OF cell]] IN pdt;
        NEXT unbundled_pdt.default_names^ [i]: [unbundled_pdt.parameters^ [i].default_name_size] IN pdt;
        NEXT unbundled_pdt.default_values^ [i]: [unbundled_pdt.parameters^ [i].default_value_size] IN pdt;
        IF (unbundled_pdt.default_names^ [i] = NIL) OR (unbundled_pdt.default_values^ [i] = NIL) THEN
          EXIT /ok/;
        IFEND;
*ELSE
        NEXT kludge_type_spec: [1 .. unbundled_pdt.parameters^ [i].type_specification_size] IN pdt;
        type_specification := #SEQ (kludge_type_spec^);
        NEXT unbundled_pdt.default_names^ [i]: [unbundled_pdt.parameters^ [i].default_name_size] IN pdt;
        NEXT unbundled_pdt.default_values^ [i]: [unbundled_pdt.parameters^ [i].default_value_size] IN pdt;
*IFEND
        clp$convert_type_spec_to_desc (type_specification, work_area, unbundled_pdt.type_descriptions^ [i],
              status);
        IF NOT status.normal THEN
          EXIT /ok/;
        IFEND;
      FOREND;

      RETURN;
    END /ok/;

    osp$set_status_condition (cle$bad_pdt, status);

  PROCEND clp$unbundle_pdt;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$change_pdt', EJECT ??
*copyc clh$change_pdt

  PROCEDURE [XDCL, #GATE] clp$change_pdt
    (    parameter_description_table: ^clt$parameter_description_table;
         pdt_changes: clt$pdt_changes;
     VAR status: ost$status);

    VAR
      default_name: ^clt$variable_name_reference,
      default_values: ^array [1 .. * ] of ^clt$expression_text,
      header: ^clt$pdt_header,
      i: clt$parameter_number,
      names: ^clt$pdt_parameter_names,
      parameters: ^clt$pdt_parameters,
      pdt: ^clt$parameter_description_table,
      type_specifications: ^array [1 .. * ] of ^clt$type_specification;


    status.normal := TRUE;

  /ok/
    BEGIN
      IF parameter_description_table = NIL THEN
        EXIT /ok/;
      IFEND;
      pdt := parameter_description_table;
      RESET pdt;
      NEXT header IN pdt;
      IF header = NIL THEN
        EXIT /ok/;
      IFEND;

*IF NOT $true(osv$unix)
      IF header^.version <> clc$declaration_version THEN
*ELSE
      IF (header^.version < 1) OR (header^.version > clc$declaration_version) THEN
*IFEND
        osp$set_status_condition (cle$bad_declaration_version, status);
        osp$append_status_integer (osc$status_parameter_delimiter, header^.version, 10, FALSE, status);
        RETURN;
      IFEND;

      IF (header^.number_of_parameter_names > clc$max_parameter_names) OR
            (header^.number_of_parameters > header^.number_of_parameter_names) THEN
        EXIT /ok/;
      IFEND;

      IF header^.number_of_parameter_names = 0 THEN
        IF header^.number_of_parameters <> 0 THEN
          EXIT /ok/;
        IFEND;
        RETURN;
      IFEND;

      IF header^.number_of_parameters <= 0 THEN
        EXIT /ok/;
      IFEND;
      NEXT names: [1 .. header^.number_of_parameter_names] IN pdt;
      NEXT parameters: [1 .. header^.number_of_parameters] IN pdt;
      IF (names = NIL) OR (parameters = NIL) THEN
        EXIT /ok/;
      IFEND;
      PUSH type_specifications: [1 .. header^.number_of_parameters];
      PUSH default_values: [1 .. header^.number_of_parameters];
      FOR i := 1 TO header^.number_of_parameters DO
        NEXT type_specifications^ [i]: [[REP parameters^ [i].type_specification_size OF cell]] IN pdt;
        NEXT default_name: [parameters^ [i].default_name_size] IN pdt;
        NEXT default_values^ [i]: [parameters^ [i].default_value_size] IN pdt;
        IF (type_specifications^ [i] = NIL) OR (default_name = NIL) OR (default_values^ [i] = NIL) THEN
          EXIT /ok/;
        IFEND;
      FOREND;

      FOR i := 1 TO UPPERBOUND (pdt_changes) DO
        IF pdt_changes [i].number > header^.number_of_parameters THEN
          EXIT /ok/;
        IFEND;
        CASE pdt_changes [i].kind OF

        = clc$pdtc_availability =
          CASE parameters^ [pdt_changes [i].number].availability OF
          = clc$hidden_entry =
            header^.number_of_hidden_parameters := header^.number_of_hidden_parameters - 1;
          = clc$advanced_usage_entry =
            header^.number_of_advanced_parameters := header^.number_of_advanced_parameters - 1;
          ELSE
            ;
          CASEND;
          parameters^ [pdt_changes [i].number].availability := pdt_changes [i].availability;
          CASE parameters^ [pdt_changes [i].number].availability OF
          = clc$hidden_entry =
            header^.number_of_hidden_parameters := header^.number_of_hidden_parameters + 1;
          = clc$advanced_usage_entry =
            header^.number_of_advanced_parameters := header^.number_of_advanced_parameters + 1;
          ELSE
            ;
          CASEND;

        = clc$pdtc_security =
          parameters^ [pdt_changes [i].number].security := pdt_changes [i].security;

        = clc$pdtc_type =
          clp$change_type_specification (type_specifications^ [pdt_changes [i].number],
                pdt_changes [i].type_changes^, status);

        = clc$pdtc_default_value =
          default_values^ [pdt_changes [i].number]^ := pdt_changes [i].default_value^;

        = clc$pdtc_null =
          ;

        ELSE
          EXIT /ok/;
        CASEND;
      FOREND;

      RETURN;
    END /ok/;

    osp$set_status_condition (cle$bad_pdt, status);

  PROCEND clp$change_pdt;
?? TITLE := 'determine_prompting_style', EJECT ??

  PROCEDURE [INLINE] determine_prompting_style
    (    evaluation_context: clt$parameter_eval_context;
     VAR prompting_activated: boolean;
     VAR prompting_style: ost$interaction_style;
     VAR ignore_status: ost$status);

    VAR
      interactive_context: array [1 .. 1] of ift$fetch_context_attribute,
      scl_options: ^clt$scl_options;


    prompting_activated := FALSE;
    prompting_style := osc$line_interaction;

    IF evaluation_context.prompting_requested OR evaluation_context.interactive_origin THEN
      IF evaluation_context.prompting_requested OR
            (evaluation_context.interaction_style = osc$desktop_interaction) THEN
        prompting_activated := TRUE;
        prompting_style := evaluation_context.interaction_style;
      ELSE
        interactive_context [1].key := ifc$previous_mode;
        interactive_context [1].previous_mode := ifc$line;
        ifp$fetch_context (interactive_context, ignore_status);
        clp$find_scl_options (scl_options);
        IF interactive_context [1].previous_mode = ifc$screen THEN
          IF scl_options^.screen_style_correction_prompts.selected THEN
            prompting_activated := TRUE;
            prompting_style := osc$screen_interaction;
          IFEND;
        ELSE {ifc$line}
          IF scl_options^.line_style_correction_prompts.selected THEN
            prompting_activated := TRUE;
            prompting_style := scl_options^.line_style_correction_prompts.prompting_style;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND determine_prompting_style;
*IFEND

MODEND clm$evaluate_parameters;
*DECK DECK=CLM$EXCEPTION_CONDITION_CODES EXPAND=TRUE
?? RIGHT := 110 ??
MODULE clm$exception_condition_codes;

*copyc cle$exception_condition_codes

MODEND clm$exception_condition_codes;
*DECK DECK=CLM$EXTRACT_MESSAGE_MODULE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Extract_Message_Module' ??
MODULE clm$extract_message_module;

{
{  PURPOSE:
{    This module contains the code to extract the subcommands which produced the message module.
{
?? NEWTITLE := 'GLOBAL DECLARATIONS', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$page_widths
*copyc osc$max_status_message
*copyc osc$min_status_message_line
*copyc ost$message_template
*copyc ost$message_template_index
*copyc ost$message_template_module
*copyc osv$upper_to_lower
?? POP ??
*copyc amp$close
*copyc amp$fetch
*copyc amp$get_file_attributes
*copyc amp$put_next
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$extract_msg_module_contents
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc clp$trimmed_string_size
*copyc osp$find_application_menu
*copyc osp$unpack_status_condition

  TYPE
    key_record = record
      size: 1 .. 21,
      value: string (21),
    recend;

  CONST
    clc$max_command_chunk = osc$max_string_size DIV 2,
    min_page_width = 64;

  TYPE
    chunk_array = array [1 .. clc$max_command_chunk] of record
      position: integer,
      length: integer,
    recend;

  VAR
    osv$message_module_severities: [READ, oss$job_paged_literal] array [ost$message_module_severity] of record
*IF NOT $true(osv$unix_tools_on_ve)
      size: 5 .. 12,
      value: string (12),
    recend := [[11, 'INFORMATIVE'], [7, 'WARNING'], [5, 'ERROR'], [5, 'FATAL'], [12, 'CATASTROPHIC'], [12,
          'NON_STANDARD'], [9, 'DEPENDENT']];
*ELSE
      size: 21 .. 28,
      value: string (28),
    recend := [[27, 'osc$mm_informative_severity'], [23, 'osc$mm_warning_severity'],
          [21, 'osc$mm_error_severity'], [21, 'osc$mm_fatal_severity'],
          [28, 'osc$mm_catastrophic_severity'], [28, 'osc$mm_non_standard_severity'],
          [25, 'osc$mm_dependent_severity']];
*IFEND

?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
*copyc ost$message_module_severity
?? POP ??
?? TITLE := 'clp$get_message_module_info', EJECT ??

  PROCEDURE [XDCL] clp$get_message_module_info
    (    message_template_module: ^ost$message_template_module;
     VAR natural_language: ost$natural_language;
     VAR online_manual_name: ost$online_manual_name;
     VAR help_module: boolean;
     VAR message_module: boolean;
     VAR lowest_message_code: ost$status_condition_code;
     VAR highest_message_code: ost$status_condition_code;
     VAR status: ost$status);

    VAR
      header: ^ost$mtm_header,
      names: ^ost$mtm_condition_names,
      codes: ^ost$mtm_condition_codes;

    status.normal := TRUE;

    clp$extract_msg_module_contents (message_template_module, header, codes, names);

    natural_language := header^.language;
    online_manual_name := header^.online_manual_name;
    message_module := header^.number_of_codes > 0;
    help_module := header^.number_of_names > header^.number_of_codes;
    CASE header^.number_of_codes OF
    = 0 =
      lowest_message_code := 0;
      highest_message_code := 0;
    ELSE
      lowest_message_code := codes^ [LOWERBOUND (codes^)].code;
      highest_message_code := codes^ [UPPERBOUND (codes^)].code;
    CASEND;

  PROCEND clp$get_message_module_info;
?? TITLE := 'extract_message_templates', EJECT ??

  PROCEDURE extract_message_templates
    (    file_id: amt$file_identifier;
         page_width: amt$page_width;
         module_name: pmt$program_name;
         language: ost$natural_language;
         online_manual_name: ost$online_manual_name;
         names: ost$mtm_condition_names;
*IF $true(osv$unix_tools_on_ve)
         header: ost$mtm_header;
         codes: ost$mtm_condition_codes;
*IFEND
         message_template_module: ^ost$message_template_module;
     VAR status: ost$status);

?? NEWTITLE := 'put_line', EJECT ??

    PROCEDURE [INLINE] put_line
      (    line: string ( * ));

      VAR
        ignore_byte_address: amt$file_byte_address;

      amp$put_next (file_id, ^line, clp$trimmed_string_size (line), ignore_byte_address, status);
      IF NOT status.normal THEN
        EXIT extract_message_templates;
      IFEND;

    PROCEND put_line;
?? TITLE := 'put_text', EJECT ??

    PROCEDURE put_text
      (    template: ost$message_template;
           template_text: boolean);

      CONST
*IF NOT $true(osv$unix_tools_on_ve)
        terminate_string = '..';
*ELSE
        terminate_string = ''' CAT';
*IFEND

      VAR
        break_at_elipses: boolean,
        space_found: boolean,
        other_character_found: boolean,
        chunk_end: 0 .. osc$max_status_message,
        current: 0 .. osc$max_status_message + clc$wide_page_width,
        number_of_periods: 0 .. osc$max_status_message,
        result_length: integer,
        result_line: string (clc$wide_page_width),
        start: 0 .. osc$max_status_message;

      IF STRLENGTH (template) > 0 THEN
*IF NOT $true(osv$unix_tools_on_ve)
        IF (STRLENGTH (template) <= page_width) AND (template (STRLENGTH (template)) <> ' ') THEN
          put_line (template);
*ELSE
        IF (STRLENGTH (template) + 2 <= page_width) THEN
          STRINGREP (result_line, result_length, '''', template, '''');
          put_line (result_line (1, result_length));
*IFEND
*IF NOT $true(osv$unix_tools_on_ve)
        ELSEIF (template (STRLENGTH (template)) = ' ') AND ((STRLENGTH (template) + 2) <= page_width) THEN
          STRINGREP (result_line, result_length, template, '..');
          put_line (result_line (1, result_length));
*IFEND
        ELSE
          start := 1;
*IF NOT $true(osv$unix_tools_on_ve)
          IF STRLENGTH (template) > (page_width - 2) THEN
            current := page_width - 2;
*ELSE
          IF STRLENGTH (template) > (page_width - 6) THEN
            current := page_width - 6;
*IFEND
          ELSE
            current := STRLENGTH (template);
          IFEND;

          WHILE current <= STRLENGTH (template) DO

          /find_break_point/
            BEGIN
              break_at_elipses := FALSE;
              other_character_found := FALSE;
              space_found := FALSE;
              chunk_end := current;
              number_of_periods := 0;

              FOR current := chunk_end DOWNTO start DO
                CASE template (current) OF
                = ' ' =
                  space_found := TRUE;
                  EXIT /find_break_point/;
                = '.' =
                  IF current = chunk_end THEN
                    break_at_elipses := TRUE;
                  IFEND;
                  IF (break_at_elipses) AND (NOT other_character_found) THEN
                    number_of_periods := number_of_periods + 1;
                  IFEND;
                ELSE
                  other_character_found := TRUE;
                CASEND;
              FOREND;
            END /find_break_point/;
            IF NOT space_found THEN
              IF break_at_elipses THEN
                current := chunk_end - number_of_periods;
              ELSE
                current := chunk_end;
              IFEND;
            IFEND;
*IF NOT $true(osv$unix_tools_on_ve)
            STRINGREP (result_line, result_length, template (start, (current - start + 1)), terminate_string);
*ELSE
            STRINGREP (result_line, result_length, '''', template (start, (current - start + 1)),
                  terminate_string);
*IFEND
            put_line (result_line (1, result_length));
            start := current + 1;
*IF NOT $true(osv$unix_tools_on_ve)
            current := current + page_width - 2;
*ELSE
            current := current + page_width - 6;
*IFEND
          WHILEND;
*IF NOT $true(osv$unix_tools_on_ve)
          IF template (STRLENGTH (template)) = ' ' THEN
            STRINGREP (result_line, result_length, template (start, * ), terminate_string);
            put_line (result_line (1, result_length));
          ELSE
            put_line (template (start, * ));
          IFEND;
*ELSE
          STRINGREP (result_line, result_length, '''', template (start, * ), '''');
          put_line (result_line (1, result_length));
*IFEND
        IFEND;
      IFEND;
      IF template_text THEN
        put_line ('**');
      IFEND;

    PROCEND put_text;
?? TITLE := 'put_command_line', EJECT ??

    PROCEDURE put_command_line
      (    line: string ( * );
*IF NOT $true(osv$unix_tools_on_ve)
           indentation: 0 .. 4);
*ELSE
           indentation: 0 .. 10);
*IFEND

      CONST
        continuation = 6;

      VAR
        chunk_index: 0 .. clc$max_command_chunk,
        command: string (osc$max_string_size),
        command_chunk_array: chunk_array,
        command_chunk_count: 0 .. clc$max_command_chunk,
        command_size: integer,
        command_length: integer,
        command_line: string (osc$max_string_size),
*IF NOT $true(osv$unix_tools_on_ve)
        indentation_string: string (10),
*ELSE
        indentation_string: string (16),
*IFEND
        terminate_string: string (2);

*IF NOT $true(osv$unix_tools_on_ve)
      terminate_string := '..';
*ELSE
      terminate_string := '  ';
*IFEND
      indentation_string := ' ';
      command := line;
      command_size := clp$trimmed_string_size (line);

      IF command_size <= (page_width - indentation) THEN
        STRINGREP (command_line, command_length, indentation_string (1, indentation),
              command (1, command_size));
        put_line (command_line (1, command_length));
        RETURN;
      IFEND;

      build_chunks (command, command_size, (page_width - (indentation + continuation + 2)),
            command_chunk_count, command_chunk_array);

      FOR chunk_index := 1 TO command_chunk_count DO
        IF chunk_index = command_chunk_count THEN
          terminate_string := ' ';
        IFEND;
        IF chunk_index = 1 THEN
          STRINGREP (command_line, command_length, indentation_string (1, indentation),
                command (command_chunk_array [chunk_index].position, command_chunk_array [chunk_index].
                length), terminate_string);
        ELSE

          STRINGREP (command_line, command_length, indentation_string (1, indentation + continuation),
                command (command_chunk_array [chunk_index].position, command_chunk_array [chunk_index].
                length), terminate_string);
        IFEND;
        put_line (command_line (1, command_length));

      FOREND;

    PROCEND put_command_line;
?? TITLE := 'build_chunks', EJECT ??

    PROCEDURE build_chunks
      (VAR line: string ( * );
           length: 1 .. osc$max_string_size;
           width: amt$page_width;
       VAR count: 0 .. clc$max_command_chunk;
       VAR line_array: chunk_array);

      VAR
        break_position: 0 .. osc$max_string_size,
        current_character_position: 0 .. osc$max_string_size,
        current_length: 0 .. osc$max_string_size,
        remaining_text: 0 .. osc$max_string_size,
        starting_position: 1 .. osc$max_string_size,
        number_of_quotes: integer,
        break_allowed: boolean;

      current_character_position := 0;
      break_position := 0;
      remaining_text := length;
      count := 0;
      starting_position := 1;

      WHILE remaining_text > 0 DO
        break_allowed := TRUE;
        number_of_quotes := 0;
        count := count + 1;
        IF remaining_text <= width THEN
          line_array [count].position := starting_position;
          line_array [count].length := remaining_text;
          RETURN;
        IFEND;

        REPEAT
          current_character_position := current_character_position + 1;
          IF line (current_character_position) = '''' THEN
            number_of_quotes := number_of_quotes + 1;
            break_allowed := (number_of_quotes MOD 2) = 0;
          IFEND;
          IF break_allowed AND (line (current_character_position) = ' ') THEN
            break_position := current_character_position + 1;
          IFEND;
        UNTIL (current_character_position - starting_position = width);

        IF break_position > 0 THEN
          current_character_position := break_position;
        IFEND;

        IF count <> 1 THEN
          WHILE line (starting_position) = ' ' DO
            starting_position := starting_position + 1;
          WHILEND;
        IFEND;

        current_length := current_character_position - starting_position;
        line_array [count].position := starting_position;
        line_array [count].length := current_length;
        starting_position := current_character_position;
        remaining_text := length - starting_position + 1;
      WHILEND;

    PROCEND build_chunks;
?? TITLE := 'edit_string', EJECT ??

    PROCEDURE [INLINE] edit_string
      (    string_line: string ( * );
       VAR edited_line: string (osc$max_string_size);
       VAR edited_line_size: integer);

      VAR
        i: integer,
        string_size: integer;

      string_size := STRLENGTH (string_line);
      edited_line_size := 0;
      edited_line := ' ';

      FOR i := 1 TO string_size DO
        edited_line_size := edited_line_size + 1;
        edited_line (edited_line_size) := string_line (i);
        IF string_line (i) = '''' THEN
          edited_line_size := edited_line_size + 1;
          edited_line (edited_line_size) := '''';
        IFEND;
      FOREND;

    PROCEND edit_string;
?? TITLE := 'put_classes_and_items', EJECT ??

    PROCEDURE put_classes_and_items;

      VAR
        command_line: string (osc$max_string_size),
        command_length: integer,
        edited_string: string (osc$max_string_size),
        edited_string_size: integer,
        edited_string2: string (osc$max_string_size),
        edited_string2_size: integer,
        menu_header: ^ost$mtm_menu_header,
        menu_classes: cst$menu_class,
        menu_items: cst$menu_list,
        module_pointer: ^ost$message_template_module,
        parameter_line: string (osc$max_string_size),
        parameter_length: integer,
        i: cst$max_classes,
        j: cst$menu_item_number,
        key: key_record,
        shift: boolean;

      module_pointer := message_template_module;
      menu_header := #PTR (names [index].menu_header, message_template_module^);
      RESET module_pointer TO menu_header;
      NEXT menu_header IN module_pointer;
      NEXT menu_classes: [1 .. menu_header^.number_of_classes] IN module_pointer;
      NEXT menu_items: [1 .. menu_header^.number_of_menu_items] IN module_pointer;

      FOR i := 1 TO UPPERBOUND (menu_classes^) DO
        edit_string (menu_classes^ [i] (1, clp$trimmed_string_size (menu_classes^ [i])),
              edited_string, edited_string_size);
        STRINGREP (command_line, command_length, 'CREATE_MENU_CLASS NAME=''',
              edited_string (1, edited_string_size), '''');
        put_command_line (command_line (1, command_length), 4);
      FOREND;

      FOR j := 1 TO UPPERBOUND (menu_items^) DO
        IF menu_items^ [j].item_assigned THEN
          CASE menu_items^ [j].menu_type OF
          = csc$standard_function =
            search_standard_functions (menu_items^ [j].standard_function, key, shift);
          = csc$application_function =
            search_application_functions (menu_items^ [j].application_function, key, shift);
          = csc$screen_function =
            search_screen_functions (menu_items^ [j].screen_function, key);
            shift := FALSE;
          ELSE
          CASEND;
          IF shift THEN
            STRINGREP (parameter_line, parameter_length, 'CREATE_MENU_ITEM', ' KEY=', key.value (1, key.size),
                  ' SHIFT=YES');
          ELSE
            STRINGREP (parameter_line, parameter_length, 'CREATE_MENU_ITEM', ' KEY=', key.
                  value (1, key.size));
          IFEND;
        ELSE
          parameter_line := 'CREATE_MENU_ITEM';
          parameter_length := 20;
        IFEND;

        edit_string (menu_classes^ [menu_items^ [j].menu_parent]
              (1, clp$trimmed_string_size (menu_classes^ [menu_items^ [j].menu_parent])),
              edited_string, edited_string_size);
        edit_string (menu_items^ [j].short_label (1, clp$trimmed_string_size (menu_items^ [j].short_label)),
              edited_string2, edited_string2_size);

        STRINGREP (command_line, command_length, parameter_line (1, parameter_length), ' CLASS=''',
              edited_string (1, edited_string_size), ''' SHORT_LABEL=''',
              edited_string2 (1, edited_string2_size), '''');

        IF menu_items^ [j].alternate_short_label <> menu_items^ [j].short_label THEN
          parameter_line := command_line;
          parameter_length := command_length;
          edit_string (menu_items^ [j].alternate_short_label
                (1, clp$trimmed_string_size (menu_items^ [j].alternate_short_label)), edited_string,
                edited_string_size);
          STRINGREP (command_line, command_length, parameter_line (1, parameter_length),
                ' ALTERNATE_SHORT_LABEL=''', edited_string (1, edited_string_size), '''');
        IFEND;

        IF menu_items^ [j].long_label <> menu_items^ [j].short_label THEN
          parameter_line := command_line;
          parameter_length := command_length;
          edit_string (menu_items^ [j].long_label (1, clp$trimmed_string_size (menu_items^ [j].long_label)),
                edited_string, edited_string_size);
          STRINGREP (command_line, command_length, parameter_line (1, parameter_length), ' LONG_LABEL=''',
                edited_string (1, edited_string_size), '''');
        IFEND;

        IF menu_items^ [j].alternate_long_label <> menu_items^ [j].long_label THEN
          parameter_line := command_line;
          parameter_length := command_length;
          edit_string (menu_items^ [j].alternate_long_label (1,
                clp$trimmed_string_size (menu_items^ [j].alternate_long_label)), edited_string,
                edited_string_size);
          STRINGREP (command_line, command_length, parameter_line (1, parameter_length),
                ' ALTERNATE_LONG_LABEL=''', edited_string (1, edited_string_size), '''');
        IFEND;

        IF menu_items^ [j].pair_with_previous THEN
          parameter_line := command_line;
          parameter_length := command_length;
          STRINGREP (command_line, command_length, parameter_line (1, parameter_length),
                ' PAIR_WITH_PREVIOUS=YES');
        IFEND;

        put_command_line (command_line (1, command_length), 4);
      FOREND;

      put_line ('  END_APPLICATION_MENU');

    PROCEND put_classes_and_items;
?? TITLE := 'search_standard_functions', EJECT ??

    PROCEDURE search_standard_functions
      (    standard_function: cst$standard_functions;
       VAR key: key_record;
       VAR shift: boolean);

      TYPE
        shifted_standard_fcns = set of cst$standard_functions;

      VAR
        shifted_standard_functions: shifted_standard_fcns;

      shifted_standard_functions := $shifted_standard_fcns
            [csc$sh_next, csc$sh_help, csc$sh_stop, csc$sh_back, csc$sh_down, csc$sh_forward, csc$sh_backward,
            csc$edit, csc$data, csc$sh_undo];

      CASE standard_function OF
      = csc$next, csc$sh_next =
        key.value := 'NEXT';
        key.size := 4;
      = csc$undo, csc$sh_undo =
        key.value := 'UNDO';
        key.size := 4;
      = csc$help, csc$sh_help =
        key.value := 'HELP';
        key.size := 4;
      = csc$stop, csc$sh_stop =
        key.value := 'STOP';
        key.size := 4;
      = csc$back, csc$sh_back =
        key.value := 'BACK';
        key.size := 4;
      = csc$up, csc$sh_up =
        key.value := 'UP';
        key.size := 2;
      = csc$down, csc$sh_down =
        key.value := 'DOWN';
        key.size := 4;
      = csc$forward, csc$sh_forward =
        key.value := 'FORWARD';
        key.size := 7;
      = csc$backward, csc$sh_backward =
        key.value := 'BACKWARD';
        key.size := 8;
      = csc$edit, csc$sh_edit =
        key.value := 'EDIT';
        key.size := 4;
      = csc$data, csc$sh_data =
        key.value := 'DATA';
        key.size := 4;
      ELSE
        key.value := 'NEXT';
        key.size := 4;
      CASEND;

      shift := standard_function IN shifted_standard_functions;

    PROCEND search_standard_functions;
?? TITLE := 'search_application_functions', EJECT ??

    PROCEDURE search_application_functions
      (    application_function: cst$application_functions;
       VAR key: key_record;
       VAR shift: boolean);

      TYPE
        shifted_application_fcns = set of cst$application_functions;

      VAR
        shifted_application_functions: shifted_application_fcns,
        ignore_status: ost$status,
        integer_string: ost$string;

      shifted_application_functions := $shifted_application_fcns
            [csc$sf1, csc$sf2, csc$sf3, csc$sf4, csc$sf5, csc$sf6, csc$sf7, csc$sf8, csc$sf9, csc$sf10,
            csc$sf11, csc$sf12, csc$sf13, csc$sf14, csc$sf15, csc$sf16];
      key.value (1) := 'F';

      clp$convert_integer_to_string ((($INTEGER (application_function) + 2) DIV 2), 10, FALSE, integer_string,
            ignore_status);
      key.value (2, integer_string.size) := integer_string.value (1, integer_string.size);
      key.size := integer_string.size + 1;
      shift := application_function IN shifted_application_functions;

    PROCEND search_application_functions;
?? TITLE := 'search_screen_functions', EJECT ??

    PROCEDURE search_screen_functions
      (    screen_function: cst$screen_events;
       VAR key: key_record);

      CASE screen_function OF
      = csc$insert_line =
        key.size := 11;
        key.value := 'INSERT_LINE';
      = csc$insert_char_menu_item =
        key.size := 21;
        key.value := 'INSERT_CHAR_MENU_ITEM';
      = csc$delete_char_menu_item =
        key.size := 21;
        key.value := 'DELETE_CHAR_MENU_ITEM';
      = csc$clear_eol_menu_item =
        key.size := 19;
        key.value := 'CLEAR_EOL_MENU_ITEM';
      = csc$delete_line =
        key.size := 11;
        key.value := 'DELETE_LINE';
      = csc$home =
        key.size := 4;
        key.value := 'HOME';
      = csc$clear =
        key.size := 5;
        key.value := 'CLEAR';
      ELSE
        key.size := 4;
        key.value := 'HOME';
      CASEND;

    PROCEND search_screen_functions;
?? OLDTITLE, EJECT ??

    VAR
      collect_until: string (osc$max_name_size),
      command: ost$name,
      command_length: integer,
      command_line: string (osc$max_string_size),
      identifier: ost$status_identifier,
      index: ost$message_template_index,
      manual_line: string (osc$max_string_size),
      manual_length: integer,
      name_parameter: string (6 + osc$max_string_size),
      name_parameter_length: integer,
      number_of_quotes: integer,
      number: ost$status_condition_number,
      number_string: ost$string,
      template: ^ost$message_template,
*IF $true(osv$unix_tools_on_ve)
      edited_line: string (osc$max_string_size),
      edited_line_size: integer,
      terminator: string (2),
*IFEND
      parameter_line: string (6 + osc$max_string_size),
      parameter_length: integer;

    status.normal := TRUE;

*IF NOT $true(osv$unix_tools_on_ve)
    IF online_manual_name = '' THEN
      manual_line := online_manual_name;
      manual_length := 0;
    ELSE
      STRINGREP (manual_line, manual_length, ' MANUAL=', online_manual_name
            (1, clp$trimmed_string_size (online_manual_name)));
    IFEND;

    STRINGREP (command_line, command_length, 'CREATE_MESSAGE_MODULE NAME=',
          module_name (1, clp$trimmed_string_size (module_name)), manual_line (1, manual_length),
          ' NATURAL_LANGUAGE=', language (1, clp$trimmed_string_size (language)));
    put_command_line (command_line (1, command_length), 0);

    FOR index := 0 TO UPPERBOUND (names) DO
      collect_until := ' COLLECT_TEMPLATE_UNTIL=''**''';
      command_line := ' ';
      template := #PTR (names [index].template, message_template_module^);
      STRINGREP (name_parameter, name_parameter_length, ' NAME=', names [index].
            name (1, clp$trimmed_string_size (names [index].name)));
      parameter_line := name_parameter;
      parameter_length := name_parameter_length;

      CASE names [index].kind OF
      = osc$status_message =
        command := 'CREATE_STATUS_MESSAGE';
        osp$unpack_status_condition (names [index].code, identifier, number);
        clp$convert_integer_to_string (number, 10, FALSE, number_string, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        STRINGREP (parameter_line, parameter_length, name_parameter (1, name_parameter_length),
              ' IDENTIFIER=''', identifier, ''' CODE=', number_string.value (1, number_string.size),
              ' SEVERITY=', osv$message_module_severities [names [index].severity].
              value (1, osv$message_module_severities [names [index].severity].size));
      = osc$brief_help =
        command := 'CREATE_BRIEF_HELP_MESSAGE';
        parameter_line := ' ';
        parameter_length := 0;
      = osc$full_help =
        command := 'CREATE_FULL_HELP_MESSAGE';
        parameter_line := ' ';
        parameter_length := 0;
      = osc$application_menu =
        command := 'CREATE_APPLICATION_MENU';
        collect_until := ' ';
      = osc$parameter_prompt =
        command := 'CREATE_PARAMETER_PROMPT_MESSAGE';
      = osc$parameter_assistance_prompt =
        command := 'CREATE_PARAMETER_ASSIST_MESSAGE';
      = osc$parameter_help =
        command := 'CREATE_PARAMETER_HELP_MESSAGE';
      CASEND;

      STRINGREP (command_line, command_length, command, ' ', parameter_line (1, parameter_length),
            collect_until (1, clp$trimmed_string_size (collect_until)));
      put_command_line (command_line (1, command_length), 2);

      IF names [index].kind = osc$application_menu THEN
        put_classes_and_items;
      ELSE
        put_text (template^, TRUE);
      IFEND;
    FOREND;
    put_text ('END_MESSAGE_MODULE CREATE_MODULE=YES', FALSE);
*ELSE
    put_command_line ('VAR', 4);
    put_command_line (
          'osv$built_in_templates: [XDCL, STATIC] record', 6);
    put_command_line ('header: ost$mtm_header,', 8);
    STRINGREP (command_line, command_length, 'condition_codes: array [0 .. ',
          UPPERBOUND (codes), '] of ost$mtm_condition_code,');
    put_command_line (command_line (1, command_length), 8);
    STRINGREP (command_line, command_length, 'condition_names: array [0 .. ',
          UPPERBOUND (names), '] of ost$mtm_condition_name,');
    put_command_line (command_line (1, command_length), 8);
    put_command_line ('recend :=[',6);
    STRINGREP (command_line, command_length, '[''', header.version,
          ''', ''', header.language, ''', ''', online_manual_name (
          1, clp$trimmed_string_size (online_manual_name)),
          ''', ', header.number_of_codes, ' ,', header.number_of_names, '],');
    put_command_line (command_line (1, command_length), 6);
    put_command_line ('[', 6);
    terminator := '],';
    FOR index:= 0 to UPPERBOUND (codes) DO
      IF index = UPPERBOUND (codes) THEN
        terminator := ']';
      IFEND;
      STRINGREP (command_line, command_length, '[', codes [index].code,
            ', ', codes [index].name_index, terminator);
      put_command_line (command_line (1, command_length), 6);
    FOREND;
    put_command_line ('],', 6);
    put_command_line ('[', 6);
    terminator := '],';
    FOR index:= 0 to UPPERBOUND (names) DO
      STRINGREP (command_line, command_length, '[''', names [index].name,
            ''', ', names [index].code, ', ',
osv$message_module_severities[ names [index].severity].value (1,
osv$message_module_severities[ names [index].severity].size), ',');
      put_command_line (command_line (1, command_length), 6);
      template := #PTR (names [index].template, message_template_module^);
      IF index = UPPERBOUND (names) THEN
        terminator := ']';
      IFEND;
      edit_string (template^, edited_line, edited_line_size);
      put_text (edited_line (1, edited_line_size), FALSE);
      put_command_line (terminator, 6);
    FOREND;
    put_command_line (']];', 6);
*IFEND

  PROCEND extract_message_templates;
?? TITLE := 'clp$extract_message_module', EJECT ??

  PROCEDURE [XDCL] clp$extract_message_module
    (    file_id: amt$file_identifier;
         module_name: pmt$program_name;
         message_module: ^ost$message_template_module;
     VAR status: ost$status);

    VAR
      codes: ^ost$mtm_condition_codes,
      file_attributes: array [1 .. 1] of amt$fetch_item,
      header: ^ost$mtm_header,
      page_width: amt$page_width,
      names: ^ost$mtm_condition_names;

    status.normal := TRUE;
    file_attributes [1].key := amc$page_width;

    amp$fetch (file_id, file_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

*IF NOT $true(osv$unix_tools_on_ve)
    IF file_attributes [1].page_width < min_page_width THEN
      page_width := min_page_width;
    ELSEIF file_attributes [1].page_width > clc$wide_page_width THEN
      page_width := clc$wide_page_width;
    ELSE
      page_width := file_attributes [1].page_width;
    IFEND;
*ELSE
    page_width := 110;
*IFEND

    clp$extract_msg_module_contents (message_module, header, codes, names);

    extract_message_templates (file_id, page_width, module_name, header^.language, header^.online_manual_name,
*IF NOT $true(osv$unix_tools_on_ve)
          names^, message_module, status);
*ELSE
          names^, header^, codes^, message_module, status);
*IFEND
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND clp$extract_message_module;

MODEND clm$extract_message_module;
*DECK DECK=CLM$EXTRACT_SCL_PROCEDURE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Extract SCL Procedure from Object Library' ??
MODULE clm$extract_scl_procedure;

{
{ PURPOSE:
{   This module contains the code for extracting an SCL procedure from an
{   object library.
{

?? NEWTITLE := 'Global Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc clt$command_line
*copyc clt$scl_procedure
*copyc ost$status
?? POP ??
*copyc amp$put_next
*copyc clp$get_next_scl_proc_line

?? TITLE := 'clp$extract_scl_procedure', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$extract_scl_procedure
    (    file_identifier: amt$file_identifier;
         scl_procedure: ^clt$scl_procedure;
     VAR status: ost$status);

    VAR
      line: ^clt$command_line,
      local_scl_procedure: ^clt$scl_procedure,
      ignore_byte_address: amt$file_byte_address;


    status.normal := TRUE;
    local_scl_procedure := scl_procedure;
    RESET local_scl_procedure;

    WHILE TRUE DO
      clp$get_next_scl_proc_line (local_scl_procedure, line, status);
      IF (NOT status.normal) OR (line = NIL) THEN
        RETURN;
      IFEND;
      amp$put_next (file_identifier, line, #SIZE (line^), ignore_byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    WHILEND;

  PROCEND clp$extract_scl_procedure;

MODEND clm$extract_scl_procedure;
*DECK DECK=CLM$FILE_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Set / Change File Attribute Commands' ??
MODULE clm$file_command;

{
{ PURPOSE:
{   This module contains the processors for the SET_FILE_ATTRIBUTES and
{   CHANGE_FILE_ATTRIBUTES commands.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$tape_program_actions
*copyc amt$error_count
*copyc clc$standard_file_names
*copyc cle$all_must_be_used_alone
*copyc cle$none_must_be_used_alone
*copyc clt$parameter_list
*copyc fst$evaluated_file_reference
*copyc ost$status
*copyc pfe$error_condition_codes
?? POP ??
*copyc amp$change_file_attributes
*copyc avp$removable_media_admin
*copyc bap$change_default_file_attribs
*copyc bap$file_command
*copyc bap$set_file_reference_abnormal
*copyc clp$convert_str_to_path_handle
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc clp$find_current_block
*copyc clp$get_work_area
*copyc clp$verify_time_increment
*copyc fsp$path_element
*copyc nfp$check_implicit_access
*copyc nfp$perform_implicit_access
*copyc osp$append_status_file
*copyc osp$set_status_abnormal
*copyc pmp$compute_date_time
*copyc pmp$get_compact_date_time
*copyc pmp$verify_compact_date
*copyc pmp$verify_compact_time
?? TITLE := 'clp$_set_file_attributes', EJECT ??

  PROCEDURE [XDCL] clp$_set_file_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$setfa) set_file_attributes, set_file_attribute, setfa (
{   file, f: file = $required
{   access_modes, access_mode, am: (BY_NAME) list of key
{       none, read, execute, append, modify, shorten, write
{     keyend = $optional
{   average_record_length, arl: (BY_NAME) integer 1..amc$maximum_record = $optional
{   block_type, bt: (BY_NAME) key
{       (user_specified, us)
{       (system_specified, ss)
{     keyend = $optional
{   character_conversion, cc: (BY_NAME) boolean = $optional
{   collate_table_name, ctn: (BY_NAME) any of
{       key
{         none
{       keyend
{       name
{     anyend = $optional
{   compression_procedure_name, cpn: (BY_NAME) any of
{       key
{         none
{       keyend
{       entry_point_reference
{     anyend = $optional
{   data_padding, dp: (BY_NAME) integer 0..99 = $optional
{   dynamic_home_block_space, dhbs: (BY_NAME) boolean = $optional
{   embedded_key, ek: (BY_NAME) boolean = $optional
{   error_exit_procedure_name, eepn, error_exit_name, een: (BY_NAME) any of
{       key
{         none
{       keyend
{       name
{     anyend = $optional
{   error_limit, el: (BY_NAME) integer 0..amc$max_error_count = $optional
{   estimated_record_count, erc: (BY_NAME) integer 0..amc$file_byte_limit = $optional
{   file_access_procedure_name, fapn, file_access_procedure, fap: (BY_NAME) any of
{       key
{         none
{       keyend
{       name
{     anyend = $optional
{   file_contents, file_content, fc: (BY_NAME) any of
{       key
{         ascii_log, binary_log, data, file_backup, legible_data, legible_library, legible_scl_include
{         legible_scl_job, legible_scl_procedure, list, object_data, object_library, screen_form, source_map
{         unknown
{       keyend
{       name
{     anyend = $optional
{   file_label_type, flt: (BY_NAME) any of
{       key
{         (labeled, labelled, l)
{         (unlabeled, unlabelled, u)
{       advanced_key
{         (non_standard_labeled, nsl)
{       keyend
{     anyend = $optional
{   file_limit, fl: (BY_NAME) integer 0..amc$file_byte_limit = $optional
{   file_organization, fo: (BY_NAME) key
{       (sequential, sq)
{       (byte_addressable, ba)
{       (indexed_sequential, is)
{       (direct_access, da)
{       (system_key, sk)
{     keyend = $optional
{   file_processor, fp: (BY_NAME) any of
{       key
{         ada, apl, assembler, basic, c, cobol, cybil, debugger, fortran, lisp, pascal, pli, ppu_assembler
{         prolog, scl, scu, vs, unknown
{       keyend
{       name
{     anyend = $optional
{   file_structure, fs: (BY_NAME, HIDDEN) any of
{       key
{         data, library, unknown
{       keyend
{       name
{     anyend = $optional
{   forced_write, fw: (BY_NAME) any of
{       key
{         (forced_if_structure_change, fisc)
{       keyend
{       boolean
{     anyend = $optional
{   hashing_procedure_name, hpn: (BY_NAME) any of
{       key
{         none
{       keyend
{       entry_point_reference
{     anyend = $optional
{   index_levels, index_level, il: (BY_NAME) integer 0..amc$max_index_level = $optional
{   initial_home_block_count, ihbc: (BY_NAME) integer 1..amc$max_home_blocks = $optional
{   index_padding, ip: (BY_NAME) integer 0..99 = $optional
{   internal_code, ic: (BY_NAME) key
{       a6, a8, ascii, d63, d64, ebcdic, ftam1_general, ftam1_graphic, ftam1_ia5, ftam1_visible, ftam2_general
{       ftam2_graphic, ftam2_ia5, ftam2_visible
{     keyend = $optional
{   key_length, kl: (BY_NAME) integer 1..amc$max_key_length = $optional
{   key_position, kp: (BY_NAME) integer 0..amc$max_key_position = $optional
{   key_type, kt: (BY_NAME) key
{       (integer, i)
{       (collated, c)
{       (uncollated, uc)
{     keyend = $optional
{   line_number, ln: (BY_NAME) record
{       location: integer 1..amc$max_page_width
{       length: integer 1..amc$max_line_number
{     recend = $optional
{   loading_factor, lf: (BY_NAME) integer 0..100 = $optional
{   lock_expiration_time, let: (BY_NAME) integer 0..604800000 = $optional
{   logging_options, logging_option, lo: (BY_NAME) list of key
{       (enable_parcels, ep)
{       (enable_media_recovery, emr)
{       (enable_request_recovery, err)
{       all, none
{     keyend = $optional
{   log_residence, lr: (BY_NAME) any of
{       key
{         none
{       keyend
{       file
{     anyend = $optional
{   maximum_block_length, maxbl: (BY_NAME) integer 1..amc$maximum_block-1 = $optional
{   maximum_record_length, maxrl: (BY_NAME) integer 0..amc$maximum_record = $optional
{   message_control, mc: (BY_NAME) list of key
{       (messages, m)
{       (statistics, s)
{       (trivial_errors, t)
{       none
{     keyend = $optional
{   minimum_block_length, minbl: (BY_NAME) integer 1..amc$maximum_block-1 = $optional
{   minimum_record_length, minrl: (BY_NAME) integer 0..amc$maximum_record = $optional
{   open_position, op: (BY_NAME) key
{       $asis, $boi, $bop, $eoi
{     keyend = $optional
{   padding_character, pc: (BY_NAME) any of
{       name 1..1
{       string 1
{     anyend = $optional
{   page_format, pf: (BY_NAME) key
{       (burstable, b)
{       (continuous, c)
{       (non_burstable, nb)
{       (untitled, u)
{     keyend = $optional
{   page_length, pl: (BY_NAME) integer 1..amc$file_byte_limit = $optional
{   page_width, pw: (BY_NAME) integer 1..amc$max_page_width = $optional
{   preset_value, pv: (BY_NAME) integer = $optional
{   record_limit, rl: (BY_NAME) integer 1..amc$file_byte_limit = $optional
{   record_type, rt: (BY_NAME) key
{       (ansi_fixed, fixed, f, af)
{       (ansi_spanned, s, as)
{       (ansi_variable, d, av)
{       (variable, v)
{       (undefined, u)
{       (trailing_character_delimited, tcd, trailing, t)
{     keyend = $optional
{   records_per_block, rpb: (BY_NAME) integer 1..amc$max_records_per_block = $optional
{   statement_identifier, si: (BY_NAME) record
{       location: integer 1..amc$max_page_width
{       length: integer 1..amc$max_statement_id_length
{     recend = $optional
{   user_information, ui: (BY_NAME) string 0..amc$max_user_info = $optional
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 109] of clt$pdt_parameter_name,
      parameters: array [1 .. 51] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: 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 .. 7] of clt$keyword_specification,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
      type6: 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$name_type_qualifier,
        recend,
      recend,
      type7: 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,
        recend,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type9: record
        header: clt$type_specification_header,
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
      type11: 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$name_type_qualifier,
        recend,
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type13: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type14: 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$name_type_qualifier,
        recend,
      recend,
      type15: 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 .. 15] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type16: 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 .. 8] of clt$keyword_specification,
        recend,
      recend,
      type17: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type18: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 10] of clt$keyword_specification,
      recend,
      type19: 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 .. 18] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type20: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type21: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type22: 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,
        recend,
      recend,
      type23: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type24: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type25: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type26: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 14] of clt$keyword_specification,
      recend,
      type27: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type28: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type29: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type30: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type31: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type32: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type33: 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 .. 8] of clt$keyword_specification,
        recend,
      recend,
      type34: 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,
        recend,
      recend,
      type35: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type36: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type37: 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 .. 7] of clt$keyword_specification,
        recend,
      recend,
      type38: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type39: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type40: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type41: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type42: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
      recend,
      type43: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type44: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type45: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type46: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type47: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 18] of clt$keyword_specification,
      recend,
      type48: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type49: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type50: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type51: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 10, 13, 11, 30, 8, 616],
    clc$command, 109, 51, 1, 0, 1, 0, 51, 'OSM$SETFA'], [
    ['ACCESS_MODE                    ',clc$alias_entry, 2],
    ['ACCESS_MODES                   ',clc$nominal_entry, 2],
    ['AM                             ',clc$abbreviation_entry, 2],
    ['ARL                            ',clc$abbreviation_entry, 3],
    ['AVERAGE_RECORD_LENGTH          ',clc$nominal_entry, 3],
    ['BLOCK_TYPE                     ',clc$nominal_entry, 4],
    ['BT                             ',clc$abbreviation_entry, 4],
    ['CC                             ',clc$abbreviation_entry, 5],
    ['CHARACTER_CONVERSION           ',clc$nominal_entry, 5],
    ['COLLATE_TABLE_NAME             ',clc$nominal_entry, 6],
    ['COMPRESSION_PROCEDURE_NAME     ',clc$nominal_entry, 7],
    ['CPN                            ',clc$abbreviation_entry, 7],
    ['CTN                            ',clc$abbreviation_entry, 6],
    ['DATA_PADDING                   ',clc$nominal_entry, 8],
    ['DHBS                           ',clc$abbreviation_entry, 9],
    ['DP                             ',clc$abbreviation_entry, 8],
    ['DYNAMIC_HOME_BLOCK_SPACE       ',clc$nominal_entry, 9],
    ['EEN                            ',clc$abbreviation_entry, 11],
    ['EEPN                           ',clc$alias_entry, 11],
    ['EK                             ',clc$abbreviation_entry, 10],
    ['EL                             ',clc$abbreviation_entry, 12],
    ['EMBEDDED_KEY                   ',clc$nominal_entry, 10],
    ['ERC                            ',clc$abbreviation_entry, 13],
    ['ERROR_EXIT_NAME                ',clc$alias_entry, 11],
    ['ERROR_EXIT_PROCEDURE_NAME      ',clc$nominal_entry, 11],
    ['ERROR_LIMIT                    ',clc$nominal_entry, 12],
    ['ESTIMATED_RECORD_COUNT         ',clc$nominal_entry, 13],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FAP                            ',clc$abbreviation_entry, 14],
    ['FAPN                           ',clc$alias_entry, 14],
    ['FC                             ',clc$abbreviation_entry, 15],
    ['FILE                           ',clc$nominal_entry, 1],
    ['FILE_ACCESS_PROCEDURE          ',clc$alias_entry, 14],
    ['FILE_ACCESS_PROCEDURE_NAME     ',clc$nominal_entry, 14],
    ['FILE_CONTENT                   ',clc$alias_entry, 15],
    ['FILE_CONTENTS                  ',clc$nominal_entry, 15],
    ['FILE_LABEL_TYPE                ',clc$nominal_entry, 16],
    ['FILE_LIMIT                     ',clc$nominal_entry, 17],
    ['FILE_ORGANIZATION              ',clc$nominal_entry, 18],
    ['FILE_PROCESSOR                 ',clc$nominal_entry, 19],
    ['FILE_STRUCTURE                 ',clc$nominal_entry, 20],
    ['FL                             ',clc$abbreviation_entry, 17],
    ['FLT                            ',clc$abbreviation_entry, 16],
    ['FO                             ',clc$abbreviation_entry, 18],
    ['FORCED_WRITE                   ',clc$nominal_entry, 21],
    ['FP                             ',clc$abbreviation_entry, 19],
    ['FS                             ',clc$abbreviation_entry, 20],
    ['FW                             ',clc$abbreviation_entry, 21],
    ['HASHING_PROCEDURE_NAME         ',clc$nominal_entry, 22],
    ['HPN                            ',clc$abbreviation_entry, 22],
    ['IC                             ',clc$abbreviation_entry, 26],
    ['IHBC                           ',clc$abbreviation_entry, 24],
    ['IL                             ',clc$abbreviation_entry, 23],
    ['INDEX_LEVEL                    ',clc$alias_entry, 23],
    ['INDEX_LEVELS                   ',clc$nominal_entry, 23],
    ['INDEX_PADDING                  ',clc$nominal_entry, 25],
    ['INITIAL_HOME_BLOCK_COUNT       ',clc$nominal_entry, 24],
    ['INTERNAL_CODE                  ',clc$nominal_entry, 26],
    ['IP                             ',clc$abbreviation_entry, 25],
    ['KEY_LENGTH                     ',clc$nominal_entry, 27],
    ['KEY_POSITION                   ',clc$nominal_entry, 28],
    ['KEY_TYPE                       ',clc$nominal_entry, 29],
    ['KL                             ',clc$abbreviation_entry, 27],
    ['KP                             ',clc$abbreviation_entry, 28],
    ['KT                             ',clc$abbreviation_entry, 29],
    ['LET                            ',clc$abbreviation_entry, 32],
    ['LF                             ',clc$abbreviation_entry, 31],
    ['LINE_NUMBER                    ',clc$nominal_entry, 30],
    ['LN                             ',clc$abbreviation_entry, 30],
    ['LO                             ',clc$abbreviation_entry, 33],
    ['LOADING_FACTOR                 ',clc$nominal_entry, 31],
    ['LOCK_EXPIRATION_TIME           ',clc$nominal_entry, 32],
    ['LOGGING_OPTION                 ',clc$alias_entry, 33],
    ['LOGGING_OPTIONS                ',clc$nominal_entry, 33],
    ['LOG_RESIDENCE                  ',clc$nominal_entry, 34],
    ['LR                             ',clc$abbreviation_entry, 34],
    ['MAXBL                          ',clc$abbreviation_entry, 35],
    ['MAXIMUM_BLOCK_LENGTH           ',clc$nominal_entry, 35],
    ['MAXIMUM_RECORD_LENGTH          ',clc$nominal_entry, 36],
    ['MAXRL                          ',clc$abbreviation_entry, 36],
    ['MC                             ',clc$abbreviation_entry, 37],
    ['MESSAGE_CONTROL                ',clc$nominal_entry, 37],
    ['MINBL                          ',clc$abbreviation_entry, 38],
    ['MINIMUM_BLOCK_LENGTH           ',clc$nominal_entry, 38],
    ['MINIMUM_RECORD_LENGTH          ',clc$nominal_entry, 39],
    ['MINRL                          ',clc$abbreviation_entry, 39],
    ['OP                             ',clc$abbreviation_entry, 40],
    ['OPEN_POSITION                  ',clc$nominal_entry, 40],
    ['PADDING_CHARACTER              ',clc$nominal_entry, 41],
    ['PAGE_FORMAT                    ',clc$nominal_entry, 42],
    ['PAGE_LENGTH                    ',clc$nominal_entry, 43],
    ['PAGE_WIDTH                     ',clc$nominal_entry, 44],
    ['PC                             ',clc$abbreviation_entry, 41],
    ['PF                             ',clc$abbreviation_entry, 42],
    ['PL                             ',clc$abbreviation_entry, 43],
    ['PRESET_VALUE                   ',clc$nominal_entry, 45],
    ['PV                             ',clc$abbreviation_entry, 45],
    ['PW                             ',clc$abbreviation_entry, 44],
    ['RECORDS_PER_BLOCK              ',clc$nominal_entry, 48],
    ['RECORD_LIMIT                   ',clc$nominal_entry, 46],
    ['RECORD_TYPE                    ',clc$nominal_entry, 47],
    ['RL                             ',clc$abbreviation_entry, 46],
    ['RPB                            ',clc$abbreviation_entry, 48],
    ['RT                             ',clc$abbreviation_entry, 47],
    ['SI                             ',clc$abbreviation_entry, 49],
    ['STATEMENT_IDENTIFIER           ',clc$nominal_entry, 49],
    ['STATUS                         ',clc$nominal_entry, 51],
    ['UI                             ',clc$abbreviation_entry, 50],
    ['USER_INFORMATION               ',clc$nominal_entry, 50]],
    [
{ PARAMETER 1
    [32, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 282,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 6
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 7
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 67, clc$optional_parameter,
  0, 0],
{ PARAMETER 8
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 9
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 10
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 11
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 12
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 13
    [27, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 14
    [34, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 15
    [36, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 587,
  clc$optional_parameter, 0, 0],
{ PARAMETER 16
    [37, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 319,
  clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [38, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 18
    [39, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 377,
  clc$optional_parameter, 0, 0],
{ PARAMETER 19
    [40, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 698,
  clc$optional_parameter, 0, 0],
{ PARAMETER 20
    [41, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 143,
  clc$optional_parameter, 0, 0],
{ PARAMETER 21
    [45, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 104,
  clc$optional_parameter, 0, 0],
{ PARAMETER 22
    [49, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 67, clc$optional_parameter,
  0, 0],
{ PARAMETER 23
    [55, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 24
    [57, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 25
    [56, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 26
    [58, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
  clc$optional_parameter, 0, 0],
{ PARAMETER 27
    [60, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 28
    [61, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 29
    [62, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 30
    [68, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 119,
  clc$optional_parameter, 0, 0],
{ PARAMETER 31
    [71, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 32
    [72, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 33
    [74, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 319,
  clc$optional_parameter, 0, 0],
{ PARAMETER 34
    [75, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 67, clc$optional_parameter,
  0, 0],
{ PARAMETER 35
    [78, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 36
    [79, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 37
    [82, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 282,
  clc$optional_parameter, 0, 0],
{ PARAMETER 38
    [84, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 39
    [85, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 40
    [88, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 41
    [89, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 33, clc$optional_parameter,
  0, 0],
{ PARAMETER 42
    [90, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_parameter, 0, 0],
{ PARAMETER 43
    [91, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 44
    [92, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 45
    [96, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 46
    [100, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 47
    [101, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 673,
  clc$optional_parameter, 0, 0],
{ PARAMETER 48
    [99, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 49
    [106, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 119,
  clc$optional_parameter, 0, 0],
{ PARAMETER 50
    [109, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 51
    [107, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [266, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [7], [
      ['APPEND                         ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['EXECUTE                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['MODIFY                         ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['READ                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['SHORTEN                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['WRITE                          ', clc$nominal_entry, clc$normal_usage_entry, 7]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, amc$maximum_record, 10]],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [4], [
    ['SS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SYSTEM_SPECIFIED               ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['US                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['USER_SPECIFIED                 ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 5
    [[1, 0, clc$boolean_type]],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$entry_point_reference_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$entry_point_reference_type]]
    ],
{ PARAMETER 8
    [[1, 0, clc$integer_type], [0, 99, 10]],
{ PARAMETER 9
    [[1, 0, clc$boolean_type]],
{ PARAMETER 10
    [[1, 0, clc$boolean_type]],
{ PARAMETER 11
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 12
    [[1, 0, clc$integer_type], [0, amc$max_error_count, 10]],
{ PARAMETER 13
    [[1, 0, clc$integer_type], [0, amc$file_byte_limit, 10]],
{ PARAMETER 14
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 15
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    562, [[1, 0, clc$keyword_type], [15], [
      ['ASCII_LOG                      ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['BINARY_LOG                     ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['DATA                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['FILE_BACKUP                    ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['LEGIBLE_DATA                   ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['LEGIBLE_LIBRARY                ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['LEGIBLE_SCL_INCLUDE            ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['LEGIBLE_SCL_JOB                ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['LEGIBLE_SCL_PROCEDURE          ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['LIST                           ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['OBJECT_DATA                    ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['OBJECT_LIBRARY                 ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['SCREEN_FORM                    ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['SOURCE_MAP                     ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['UNKNOWN                        ', clc$nominal_entry, clc$normal_usage_entry, 15]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 16
    [[1, 0, clc$union_type], [[clc$keyword_type],
    FALSE, 1],
    303, [[1, 0, clc$keyword_type], [8], [
      ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['LABELED                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['LABELLED                       ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['NON_STANDARD_LABELED           ', clc$nominal_entry, clc$advanced_usage_entry, 3],
      ['NSL                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 3],
      ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['UNLABELED                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['UNLABELLED                     ', clc$alias_entry, clc$normal_usage_entry, 2]]
      ]
    ],
{ PARAMETER 17
    [[1, 0, clc$integer_type], [0, amc$file_byte_limit, 10]],
{ PARAMETER 18
    [[1, 0, clc$keyword_type], [10], [
    ['BA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['BYTE_ADDRESSABLE               ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['DA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['DIRECT_ACCESS                  ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['INDEXED_SEQUENTIAL             ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['IS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['SEQUENTIAL                     ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['SK                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['SQ                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SYSTEM_KEY                     ', clc$nominal_entry, clc$normal_usage_entry, 5]]
    ],
{ PARAMETER 19
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    673, [[1, 0, clc$keyword_type], [18], [
      ['ADA                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['APL                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['ASSEMBLER                      ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['BASIC                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['C                              ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['COBOL                          ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['CYBIL                          ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['DEBUGGER                       ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['FORTRAN                        ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['LISP                           ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['PASCAL                         ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['PLI                            ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['PPU_ASSEMBLER                  ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['PROLOG                         ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['SCL                            ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['SCU                            ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['UNKNOWN                        ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['VS                             ', clc$nominal_entry, clc$normal_usage_entry, 17]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 20
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['DATA                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['LIBRARY                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['UNKNOWN                        ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 21
    [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['FISC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['FORCED_IF_STRUCTURE_CHANGE     ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 22
    [[1, 0, clc$union_type], [[clc$entry_point_reference_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$entry_point_reference_type]]
    ],
{ PARAMETER 23
    [[1, 0, clc$integer_type], [0, amc$max_index_level, 10]],
{ PARAMETER 24
    [[1, 0, clc$integer_type], [1, amc$max_home_blocks, 10]],
{ PARAMETER 25
    [[1, 0, clc$integer_type], [0, 99, 10]],
{ PARAMETER 26
    [[1, 0, clc$keyword_type], [14], [
    ['A6                             ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['A8                             ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['ASCII                          ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['D63                            ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['D64                            ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['EBCDIC                         ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['FTAM1_GENERAL                  ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['FTAM1_GRAPHIC                  ', clc$nominal_entry, clc$normal_usage_entry, 8],
    ['FTAM1_IA5                      ', clc$nominal_entry, clc$normal_usage_entry, 9],
    ['FTAM1_VISIBLE                  ', clc$nominal_entry, clc$normal_usage_entry, 10],
    ['FTAM2_GENERAL                  ', clc$nominal_entry, clc$normal_usage_entry, 11],
    ['FTAM2_GRAPHIC                  ', clc$nominal_entry, clc$normal_usage_entry, 12],
    ['FTAM2_IA5                      ', clc$nominal_entry, clc$normal_usage_entry, 13],
    ['FTAM2_VISIBLE                  ', clc$nominal_entry, clc$normal_usage_entry, 14]]
    ],
{ PARAMETER 27
    [[1, 0, clc$integer_type], [1, amc$max_key_length, 10]],
{ PARAMETER 28
    [[1, 0, clc$integer_type], [0, amc$max_key_position, 10]],
{ PARAMETER 29
    [[1, 0, clc$keyword_type], [6], [
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['COLLATED                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['INTEGER                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['UC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['UNCOLLATED                     ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 30
    [[1, 0, clc$record_type], [2],
    ['LOCATION                       ', clc$required_field, 20], [[1, 0, clc$integer_type], [1,
  amc$max_page_width, 10]],
    ['LENGTH                         ', clc$required_field, 20], [[1, 0, clc$integer_type], [1,
  amc$max_line_number, 10]]
    ],
{ PARAMETER 31
    [[1, 0, clc$integer_type], [0, 100, 10]],
{ PARAMETER 32
    [[1, 0, clc$integer_type], [0, 604800000, 10]],
{ PARAMETER 33
    [[1, 0, clc$list_type], [303, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [8], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['EMR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['ENABLE_MEDIA_RECOVERY          ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['ENABLE_PARCELS                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['ENABLE_REQUEST_RECOVERY        ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ERR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 5]]
      ]
    ],
{ PARAMETER 34
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ],
{ PARAMETER 35
    [[1, 0, clc$integer_type], [1, amc$maximum_block-1, 10]],
{ PARAMETER 36
    [[1, 0, clc$integer_type], [0, amc$maximum_record, 10]],
{ PARAMETER 37
    [[1, 0, clc$list_type], [266, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [7], [
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['MESSAGES                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['STATISTICS                     ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['TRIVIAL_ERRORS                 ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ]
    ],
{ PARAMETER 38
    [[1, 0, clc$integer_type], [1, amc$maximum_block-1, 10]],
{ PARAMETER 39
    [[1, 0, clc$integer_type], [0, amc$maximum_record, 10]],
{ PARAMETER 40
    [[1, 0, clc$keyword_type], [4], [
    ['$ASIS                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['$BOI                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['$BOP                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['$EOI                           ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ],
{ PARAMETER 41
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, 1]],
    8, [[1, 0, clc$string_type], [1, 1, FALSE]]
    ],
{ PARAMETER 42
    [[1, 0, clc$keyword_type], [8], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BURSTABLE                      ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['CONTINUOUS                     ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['NB                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['NON_BURSTABLE                  ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['UNTITLED                       ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ],
{ PARAMETER 43
    [[1, 0, clc$integer_type], [1, amc$file_byte_limit, 10]],
{ PARAMETER 44
    [[1, 0, clc$integer_type], [1, amc$max_page_width, 10]],
{ PARAMETER 45
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
{ PARAMETER 46
    [[1, 0, clc$integer_type], [1, amc$file_byte_limit, 10]],
{ PARAMETER 47
    [[1, 0, clc$keyword_type], [18], [
    ['AF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ANSI_FIXED                     ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ANSI_SPANNED                   ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['ANSI_VARIABLE                  ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['AS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['AV                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['D                              ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['F                              ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['FIXED                          ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['S                              ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['TCD                            ', clc$alias_entry, clc$normal_usage_entry, 6],
    ['TRAILING                       ', clc$alias_entry, clc$normal_usage_entry, 6],
    ['TRAILING_CHARACTER_DELIMITED   ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['UNDEFINED                      ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['V                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['VARIABLE                       ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ],
{ PARAMETER 48
    [[1, 0, clc$integer_type], [1, amc$max_records_per_block, 10]],
{ PARAMETER 49
    [[1, 0, clc$record_type], [2],
    ['LOCATION                       ', clc$required_field, 20], [[1, 0, clc$integer_type], [1,
  amc$max_page_width, 10]],
    ['LENGTH                         ', clc$required_field, 20], [[1, 0, clc$integer_type], [1,
  amc$max_statement_id_length, 10]]
    ],
{ PARAMETER 50
    [[1, 0, clc$string_type], [0, amc$max_user_info, FALSE]],
{ PARAMETER 51
    [[1, 0, clc$status_type]]];

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

    CONST
      p$file = 1,
      p$access_modes = 2,
      p$average_record_length = 3,
      p$block_type = 4,
      p$character_conversion = 5,
      p$collate_table_name = 6,
      p$compression_procedure_name = 7,
      p$data_padding = 8,
      p$dynamic_home_block_space = 9,
      p$embedded_key = 10,
      p$error_exit_procedure_name = 11,
      p$error_limit = 12,
      p$estimated_record_count = 13,
      p$file_access_procedure_name = 14,
      p$file_contents = 15,
      p$file_label_type = 16,
      p$file_limit = 17,
      p$file_organization = 18,
      p$file_processor = 19,
      p$file_structure = 20,
      p$forced_write = 21,
      p$hashing_procedure_name = 22,
      p$index_levels = 23,
      p$initial_home_block_count = 24,
      p$index_padding = 25,
      p$internal_code = 26,
      p$key_length = 27,
      p$key_position = 28,
      p$key_type = 29,
      p$line_number = 30,
      p$loading_factor = 31,
      p$lock_expiration_time = 32,
      p$logging_options = 33,
      p$log_residence = 34,
      p$maximum_block_length = 35,
      p$maximum_record_length = 36,
      p$message_control = 37,
      p$minimum_block_length = 38,
      p$minimum_record_length = 39,
      p$open_position = 40,
      p$padding_character = 41,
      p$page_format = 42,
      p$page_length = 43,
      p$page_width = 44,
      p$preset_value = 45,
      p$record_limit = 46,
      p$record_type = 47,
      p$records_per_block = 48,
      p$statement_identifier = 49,
      p$user_information = 50,
      p$status = 51;

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

    VAR
      access_mode: pft$usage_selections,
      attributes: ^amt$file_attributes,
      attribute_count: 0 .. p$status - 2,
      attribute_index: 0 .. p$status - 1,
      compression_procedure_name_ptr: ^amt$compression_procedure_name,
      current_access_mode: ^clt$data_value,
      current_message: ^clt$data_value,
      evaluated_file_reference: fst$evaluated_file_reference,
      hashing_procedure_name_ptr: ^amt$hashing_procedure_name,
      label_option: amt$label_options,
      logging_options: amt$logging_options,
      log_options: ^clt$data_value,
      log_residence_ptr: ^amt$log_residence,
      message_control: amt$message_control,
      path_handle_name: fst$path_handle_name,
      remote: boolean;


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

    evaluate_path_and_handle_remote ('SET_FILE_ATTRIBUTES', pvt [p$file].value^.file_value^, ^pvt, remote,
          status);
    IF (NOT status.normal) OR remote THEN
      RETURN;
    IFEND;

    clp$convert_str_to_path_handle (pvt [p$file].value^.file_value^, FALSE, TRUE, FALSE, path_handle_name,
          evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF evaluated_file_reference.path_resolution = fsc$catalog_path THEN
      osp$set_status_abnormal ('CL', pfe$name_not_permanent_file, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, pvt [p$file].value^.file_value^, status);
      RETURN;
    IFEND;

  /determine_attributes/
    BEGIN

      attribute_count := 0;
      FOR attribute_index := 2 TO p$status - 1 DO
        IF pvt [attribute_index].specified THEN
          attribute_count := attribute_count + 1;
        IFEND;
      FOREND;
      IF attribute_count = 0 THEN
        attributes := NIL;
        EXIT /determine_attributes/;
      ELSE
        PUSH attributes: [1 .. attribute_count];
      IFEND;
      attribute_index := 0;

      IF pvt [p$access_modes].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$access_mode;
        attributes^ [attribute_index].access_mode := $pft$usage_selections [];

        current_access_mode := pvt [p$access_modes].value;

      /get_access_mode/
        WHILE current_access_mode <> NIL DO
          IF current_access_mode^.element_value^.keyword_value = 'APPEND' THEN
            access_mode := $pft$usage_selections [pfc$append];
          ELSEIF current_access_mode^.element_value^.keyword_value = 'EXECUTE' THEN
            access_mode := $pft$usage_selections [pfc$execute];
          ELSEIF current_access_mode^.element_value^.keyword_value = 'MODIFY' THEN
            access_mode := $pft$usage_selections [pfc$modify];
          ELSEIF current_access_mode^.element_value^.keyword_value = 'NONE' THEN
            IF pvt [p$access_modes].value^.link <> NIL THEN
              osp$set_status_abnormal ('CL', cle$none_must_be_used_alone, 'ACCESS_MODE', status);
              RETURN;
            IFEND;
            EXIT /get_access_mode/;
          ELSEIF current_access_mode^.element_value^.keyword_value = 'READ' THEN
            access_mode := $pft$usage_selections [pfc$read];
          ELSEIF current_access_mode^.element_value^.keyword_value = 'SHORTEN' THEN
            access_mode := $pft$usage_selections [pfc$shorten];
          ELSEIF current_access_mode^.element_value^.keyword_value = 'WRITE' THEN
            access_mode := $pft$usage_selections [pfc$append, pfc$modify, pfc$shorten];
          IFEND;
          attributes^ [attribute_index].access_mode := attributes^ [attribute_index].access_mode +
                access_mode;
          current_access_mode := current_access_mode^.link;
        WHILEND /get_access_mode/;
      IFEND;

      IF pvt [p$average_record_length].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$average_record_length;
        attributes^ [attribute_index].average_record_length :=
              pvt [p$average_record_length].value^.integer_value.value;
      IFEND;

      IF pvt [p$block_type].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$block_type;
        IF pvt [p$block_type].value^.keyword_value = 'USER_SPECIFIED' THEN
          attributes^ [attribute_index].block_type := amc$user_specified;
        ELSE {SYSTEM_SPECIFIED
          attributes^ [attribute_index].block_type := amc$system_specified;
        IFEND;
      IFEND;

      IF pvt [p$character_conversion].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$character_conversion;
        attributes^ [attribute_index].character_conversion :=
              pvt [p$character_conversion].value^.boolean_value.value;
      IFEND;

      IF pvt [p$collate_table_name].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$collate_table_name;
        IF pvt [p$collate_table_name].value^.kind = clc$keyword {AND keyword = NONE} THEN
          attributes^ [attribute_index].collate_table_name := osc$null_name;
        ELSE
          attributes^ [attribute_index].collate_table_name := pvt [p$collate_table_name].value^.name_value;
        IFEND;
      IFEND;

      IF pvt [p$compression_procedure_name].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$compression_procedure_name;
        PUSH compression_procedure_name_ptr;

        IF pvt [p$compression_procedure_name].value^.kind = clc$keyword {AND keyword = NONE} THEN
          compression_procedure_name_ptr^.name := osc$null_name;
          compression_procedure_name_ptr^.object_library := '';
        ELSE {clc$entry_point_reference}
          compression_procedure_name_ptr^.name := pvt [p$compression_procedure_name].value^.
                entry_point_reference_value^.entry_point;
          compression_procedure_name_ptr^.object_library := pvt [p$compression_procedure_name].value^.
                entry_point_reference_value^.object_library;
        IFEND;

        attributes^ [attribute_index].compression_procedure_name := compression_procedure_name_ptr;
      IFEND;

      IF pvt [p$data_padding].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$data_padding;
        attributes^ [attribute_index].data_padding := pvt [p$data_padding].value^.integer_value.value;
      IFEND;

      IF pvt [p$dynamic_home_block_space].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$dynamic_home_block_space;
        attributes^ [attribute_index].dynamic_home_block_space :=
              pvt [p$dynamic_home_block_space].value^.boolean_value.value;
      IFEND;

      IF pvt [p$embedded_key].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$embedded_key;
        attributes^ [attribute_index].embedded_key := pvt [p$embedded_key].value^.boolean_value.value;
      IFEND;

      IF pvt [p$error_exit_procedure_name].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$error_exit_name;
        IF pvt [p$error_exit_procedure_name].value^.kind = clc$keyword {AND keyword = NONE} THEN
          attributes^ [attribute_index].error_exit_name := osc$null_name;
        ELSE
          attributes^ [attribute_index].error_exit_name := pvt [p$error_exit_procedure_name].value^.
                name_value;
        IFEND;
      IFEND;

      IF pvt [p$error_limit].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$error_limit;
        attributes^ [attribute_index].error_limit := pvt [p$error_limit].value^.integer_value.value;
      IFEND;

      IF pvt [p$estimated_record_count].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$estimated_record_count;
        attributes^ [attribute_index].estimated_record_count :=
              pvt [p$estimated_record_count].value^.integer_value.value;
      IFEND;

      IF pvt [p$file_access_procedure_name].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$file_access_procedure;
        IF pvt [p$file_access_procedure_name].value^.kind = clc$keyword {AND keyword = NONE} THEN
          attributes^ [attribute_index].file_access_procedure := osc$null_name;
        ELSE
          attributes^ [attribute_index].file_access_procedure :=
                pvt [p$file_access_procedure_name].value^.name_value;
        IFEND;
      IFEND;

      IF pvt [p$file_contents].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$file_contents;
        IF pvt [p$file_contents].value^.kind = clc$keyword {AND keyword = NONE} THEN
          attributes^ [attribute_index].file_contents := pvt [p$file_contents].value^.keyword_value;
        ELSE
          attributes^ [attribute_index].file_contents := pvt [p$file_contents].value^.name_value;
        IFEND;
      IFEND;

      IF pvt [p$file_label_type].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$label_type;
        IF pvt [p$file_label_type].value^.keyword_value = 'LABELED' THEN
          attributes^ [attribute_index].label_type := amc$labelled;
        ELSEIF pvt [p$file_label_type].value^.keyword_value = 'UNLABELED' THEN
          attributes^ [attribute_index].label_type := amc$unlabelled;
        ELSEIF pvt [p$file_label_type].value^.keyword_value = 'NON_STANDARD_LABELED' THEN
          IF avp$removable_media_admin () THEN
            attributes^ [attribute_index].label_type := amc$non_standard_labelled;
          ELSE
            bap$set_file_reference_abnormal (pvt [p$file].value^.file_value^, ame$security_conflict,
                  '', 'FILE_LABEL_TYPE', status);
            RETURN;
          IFEND;
        IFEND;
      IFEND;

      IF pvt [p$file_limit].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$file_limit;
        attributes^ [attribute_index].file_limit := pvt [p$file_limit].value^.integer_value.value;
      IFEND;

      IF pvt [p$file_organization].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$file_organization;
        IF pvt [p$file_organization].value^.keyword_value = 'SEQUENTIAL' THEN
          attributes^ [attribute_index].file_organization := amc$sequential;
        ELSEIF pvt [p$file_organization].value^.keyword_value = 'BYTE_ADDRESSABLE' THEN
          attributes^ [attribute_index].file_organization := amc$byte_addressable;
        ELSEIF pvt [p$file_organization].value^.keyword_value = 'INDEXED_SEQUENTIAL' THEN
          attributes^ [attribute_index].file_organization := amc$indexed_sequential;
        ELSEIF pvt [p$file_organization].value^.keyword_value = 'DIRECT_ACCESS' THEN
          attributes^ [attribute_index].file_organization := amc$direct_access;
        ELSEIF pvt [p$file_organization].value^.keyword_value = 'SYSTEM_KEY' THEN
          attributes^ [attribute_index].file_organization := amc$system_key;
        IFEND;
      IFEND;

      IF pvt [p$file_processor].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$file_processor;
        IF pvt [p$file_processor].value^.kind = clc$keyword {AND keyword = NONE} THEN
          attributes^ [attribute_index].file_processor := pvt [p$file_processor].value^.keyword_value;
        ELSE
          attributes^ [attribute_index].file_processor := pvt [p$file_processor].value^.name_value;
        IFEND;
      IFEND;

      IF pvt [p$file_structure].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$file_structure;
        IF pvt [p$file_structure].value^.kind = clc$keyword {AND keyword = NONE} THEN
          attributes^ [attribute_index].file_structure := pvt [p$file_structure].value^.keyword_value;
        ELSE
          attributes^ [attribute_index].file_structure := pvt [p$file_structure].value^.name_value;
        IFEND;
      IFEND;

      IF pvt [p$forced_write].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$forced_write;
        IF pvt [p$forced_write].value^.kind = clc$keyword {AND keyword = NONE} THEN
          attributes^ [attribute_index].forced_write := amc$forced_if_structure_change;
        ELSEIF pvt [p$forced_write].value^.boolean_value.value THEN
          attributes^ [attribute_index].forced_write := amc$forced;
        ELSE
          attributes^ [attribute_index].forced_write := amc$unforced;
        IFEND;
      IFEND;

      IF pvt [p$hashing_procedure_name].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$hashing_procedure_name;
        PUSH hashing_procedure_name_ptr;
        IF pvt [p$hashing_procedure_name].value^.kind = clc$keyword {AND keyword = NONE} THEN
          hashing_procedure_name_ptr^.name := osc$null_name;
          hashing_procedure_name_ptr^.object_library := '';
        ELSE {clc$entry_point_reference}
          hashing_procedure_name_ptr^.name := pvt [p$hashing_procedure_name].value^.
                entry_point_reference_value^.entry_point;
          hashing_procedure_name_ptr^.object_library := pvt [p$hashing_procedure_name].value^.
                entry_point_reference_value^.object_library;
        IFEND;
        attributes^ [attribute_index].hashing_procedure_name := hashing_procedure_name_ptr;
      IFEND;

      IF pvt [p$index_levels].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$index_levels;
        attributes^ [attribute_index].index_levels := pvt [p$index_levels].value^.integer_value.value;
      IFEND;

      IF pvt [p$index_padding].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$index_padding;
        attributes^ [attribute_index].index_padding := pvt [p$index_padding].value^.integer_value.value;
      IFEND;

      IF pvt [p$initial_home_block_count].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$initial_home_block_count;
        attributes^ [attribute_index].initial_home_block_count :=
              pvt [p$initial_home_block_count].value^.integer_value.value;
      IFEND;

      IF pvt [p$internal_code].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$internal_code;
        IF pvt [p$internal_code].value^.keyword_value = 'A6' THEN
          attributes^ [attribute_index].internal_code := amc$as6;
        ELSEIF pvt [p$internal_code].value^.keyword_value = 'A8' THEN
          attributes^ [attribute_index].internal_code := amc$as8;
        ELSEIF pvt [p$internal_code].value^.keyword_value = 'ASCII' THEN
          attributes^ [attribute_index].internal_code := amc$ascii;
        ELSEIF pvt [p$internal_code].value^.keyword_value = 'D63' THEN
          attributes^ [attribute_index].internal_code := amc$d63;
        ELSEIF pvt [p$internal_code].value^.keyword_value = 'D64' THEN
          attributes^ [attribute_index].internal_code := amc$d64;
        ELSEIF pvt [p$internal_code].value^.keyword_value = 'EBCDIC' THEN
          attributes^ [attribute_index].internal_code := amc$ebcdic;
        ELSEIF pvt [p$internal_code].value^.keyword_value = 'FTAM1_GENERAL' THEN
          attributes^ [attribute_index].internal_code := amc$ftam1_general;
        ELSEIF pvt [p$internal_code].value^.keyword_value = 'FTAM1_GRAPHIC' THEN
          attributes^ [attribute_index].internal_code := amc$ftam1_graphic;
        ELSEIF pvt [p$internal_code].value^.keyword_value = 'FTAM1_IA5' THEN
          attributes^ [attribute_index].internal_code := amc$ftam1_ia5;
        ELSEIF pvt [p$internal_code].value^.keyword_value = 'FTAM1_VISIBLE' THEN
          attributes^ [attribute_index].internal_code := amc$ftam1_visible;
        ELSEIF pvt [p$internal_code].value^.keyword_value = 'FTAM2_GENERAL' THEN
          attributes^ [attribute_index].internal_code := amc$ftam2_general;
        ELSEIF pvt [p$internal_code].value^.keyword_value = 'FTAM2_GRAPHIC' THEN
          attributes^ [attribute_index].internal_code := amc$ftam2_graphic;
        ELSEIF pvt [p$internal_code].value^.keyword_value = 'FTAM2_IA5' THEN
          attributes^ [attribute_index].internal_code := amc$ftam2_ia5;
        ELSEIF pvt [p$internal_code].value^.keyword_value = 'FTAM2_VISIBLE' THEN
          attributes^ [attribute_index].internal_code := amc$ftam2_visible;
        IFEND;
      IFEND;

      IF pvt [p$key_length].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$key_length;
        attributes^ [attribute_index].key_length := pvt [p$key_length].value^.integer_value.value;
      IFEND;

      IF pvt [p$key_position].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$key_position;
        attributes^ [attribute_index].key_position := pvt [p$key_position].value^.integer_value.value;
      IFEND;

      IF pvt [p$key_type].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$key_type;
        IF pvt [p$key_type].value^.keyword_value = 'INTEGER' THEN
          attributes^ [attribute_index].key_type := amc$integer_key;
        ELSEIF pvt [p$key_type].value^.keyword_value = 'COLLATED' THEN
          attributes^ [attribute_index].key_type := amc$collated_key;
        ELSEIF pvt [p$key_type].value^.keyword_value = 'UNCOLLATED' THEN
          attributes^ [attribute_index].key_type := amc$uncollated_key;
        IFEND;
      IFEND;

      IF pvt [p$line_number].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$line_number;
        attributes^ [attribute_index].line_number.location :=
              pvt [p$line_number].value^.field_values^ [1].value^.integer_value.value;
        attributes^ [attribute_index].line_number.length := pvt [p$line_number].value^.field_values^ [2].
              value^.integer_value.value;
      IFEND;

      IF pvt [p$loading_factor].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$loading_factor;
        attributes^ [attribute_index].loading_factor := pvt [p$loading_factor].value^.integer_value.value;
      IFEND;

      IF pvt [p$lock_expiration_time].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$lock_expiration_time;
        attributes^ [attribute_index].lock_expiration_time :=
              pvt [p$lock_expiration_time].value^.integer_value.value;
      IFEND;

      IF pvt [p$logging_options].specified THEN
        attribute_index := attribute_index + 1;
        log_options := pvt [p$logging_options].value;
        attributes^ [attribute_index].key := amc$logging_options;
        attributes^ [attribute_index].logging_options := $amt$logging_options [];

      /get_logging_options/
        WHILE log_options <> NIL DO
          IF log_options^.element_value^.keyword_value = 'ALL' THEN
            IF pvt [p$logging_options].value^.link <> NIL THEN
              osp$set_status_abnormal ('CL', cle$all_must_be_used_alone, 'LOGGING_OPTIONS', status);
              RETURN;
            IFEND;
            logging_options := $amt$logging_options [amc$enable_parcels, amc$enable_media_recovery,
                  amc$enable_request_recovery];
          ELSEIF log_options^.element_value^.keyword_value = 'ENABLE_PARCELS' THEN
            logging_options := $amt$logging_options [amc$enable_parcels];
          ELSEIF log_options^.element_value^.keyword_value = 'ENABLE_MEDIA_RECOVERY' THEN
            logging_options := $amt$logging_options [amc$enable_media_recovery];
          ELSEIF log_options^.element_value^.keyword_value = 'ENABLE_REQUEST_RECOVERY' THEN
            logging_options := $amt$logging_options [amc$enable_request_recovery];
          ELSEIF log_options^.element_value^.keyword_value = 'NONE' THEN
            IF pvt [p$logging_options].value^.link <> NIL THEN
              osp$set_status_abnormal ('CL', cle$none_must_be_used_alone, 'LOGGING_OPTIONS', status);
              RETURN;
            IFEND;
            EXIT /get_logging_options/;
          IFEND;
          attributes^ [attribute_index].logging_options := attributes^ [attribute_index].logging_options +
                logging_options;
          log_options := log_options^.link;
        WHILEND /get_logging_options/;
      IFEND;

      IF pvt [p$log_residence].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$log_residence;
        PUSH log_residence_ptr;
        IF pvt [p$log_residence].value^.kind = clc$keyword {AND keyword = NONE} THEN
          log_residence_ptr^ := '';
        ELSE
          log_residence_ptr^ := pvt [p$log_residence].value^.file_value^;
        IFEND;
        attributes^ [attribute_index].log_residence := log_residence_ptr;
      IFEND;

      IF pvt [p$maximum_block_length].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$max_block_length;
        attributes^ [attribute_index].max_block_length := pvt [p$maximum_block_length].value^.integer_value.
              value;
      IFEND;

      IF pvt [p$maximum_record_length].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$max_record_length;
        attributes^ [attribute_index].max_record_length := pvt [p$maximum_record_length].value^.integer_value.
              value;
      IFEND;

      IF pvt [p$message_control].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$message_control;
        attributes^ [attribute_index].message_control := $amt$message_control [];
        current_message := pvt [p$message_control].value;

      /get_message_control/
        WHILE current_message <> NIL DO
          IF current_message^.element_value^.keyword_value = 'TRIVIAL_ERRORS' THEN
            message_control := $amt$message_control [amc$trivial_errors];
          ELSEIF current_message^.element_value^.keyword_value = 'MESSAGES' THEN
            message_control := $amt$message_control [amc$messages];
          ELSEIF current_message^.element_value^.keyword_value = 'STATISTICS' THEN
            message_control := $amt$message_control [amc$statistics];
          ELSEIF current_message^.element_value^.keyword_value = 'NONE' THEN
            IF pvt [p$message_control].value^.link <> NIL THEN
              osp$set_status_abnormal ('CL', cle$none_must_be_used_alone, 'MESSAGE_CONTROL', status);
              RETURN;
            IFEND;
            EXIT /get_message_control/;
          IFEND;
          attributes^ [attribute_index].message_control := attributes^ [attribute_index].message_control +
                message_control;
          current_message := current_message^.link;
        WHILEND /get_message_control/;
      IFEND;

      IF pvt [p$minimum_block_length].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$min_block_length;
        attributes^ [attribute_index].min_block_length := pvt [p$minimum_block_length].value^.integer_value.
              value;
      IFEND;

      IF pvt [p$minimum_record_length].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$min_record_length;
        attributes^ [attribute_index].min_record_length := pvt [p$minimum_record_length].value^.integer_value.
              value;
      IFEND;

      IF pvt [p$open_position].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$open_position;
        IF pvt [p$open_position].value^.keyword_value = '$ASIS' THEN
          attributes^ [attribute_index].open_position := amc$open_no_positioning;
        ELSEIF pvt [p$open_position].value^.keyword_value = '$BOI' THEN
          attributes^ [attribute_index].open_position := amc$open_at_boi;
        ELSEIF pvt [p$open_position].value^.keyword_value = '$BOP' THEN
          attributes^ [attribute_index].open_position := amc$open_at_bop;
        ELSEIF pvt [p$open_position].value^.keyword_value = '$EOI' THEN
          attributes^ [attribute_index].open_position := amc$open_at_eoi;
        IFEND;
      IFEND;

      IF pvt [p$padding_character].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$padding_character;
        IF pvt [p$padding_character].value^.kind = clc$name THEN
          attributes^ [attribute_index].padding_character := pvt [p$padding_character].value^.name_value (1);
        ELSE
          attributes^ [attribute_index].padding_character := pvt [p$padding_character].value^.
                string_value^ (1);
        IFEND;
      IFEND;

      IF pvt [p$page_format].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$page_format;
        IF pvt [p$page_format].value^.keyword_value = 'BURSTABLE' THEN
          attributes^ [attribute_index].page_format := amc$burstable_form;
        ELSEIF pvt [p$page_format].value^.keyword_value = 'CONTINUOUS' THEN
          attributes^ [attribute_index].page_format := amc$continuous_form;
        ELSEIF pvt [p$page_format].value^.keyword_value = 'NON_BURSTABLE' THEN
          attributes^ [attribute_index].page_format := amc$non_burstable_form;
        ELSEIF pvt [p$page_format].value^.keyword_value = 'UNTITLED' THEN
          attributes^ [attribute_index].page_format := amc$untitled_form;
        IFEND;
      IFEND;

      IF pvt [p$page_length].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$page_length;
        attributes^ [attribute_index].page_length := pvt [p$page_length].value^.integer_value.value;
      IFEND;

      IF pvt [p$page_width].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$page_width;
        attributes^ [attribute_index].page_width := pvt [p$page_width].value^.integer_value.value;
      IFEND;

      IF pvt [p$preset_value].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$preset_value;
        attributes^ [attribute_index].preset_value := pvt [p$preset_value].value^.integer_value.value;
      IFEND;

      IF pvt [p$record_limit].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$record_limit;
        attributes^ [attribute_index].record_limit := pvt [p$record_limit].value^.integer_value.value;
      IFEND;

      IF pvt [p$record_type].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$record_type;
        IF pvt [p$record_type].value^.keyword_value = 'ANSI_FIXED' THEN
          attributes^ [attribute_index].record_type := amc$ansi_fixed;
        ELSEIF pvt [p$record_type].value^.keyword_value = 'ANSI_SPANNED' THEN
          attributes^ [attribute_index].record_type := amc$ansi_spanned;
        ELSEIF pvt [p$record_type].value^.keyword_value = 'ANSI_VARIABLE' THEN
          attributes^ [attribute_index].record_type := amc$ansi_variable;
        ELSEIF pvt [p$record_type].value^.keyword_value = 'UNDEFINED' THEN
          attributes^ [attribute_index].record_type := amc$undefined;
        ELSEIF pvt [p$record_type].value^.keyword_value = 'TRAILING_CHARACTER_DELIMITED' THEN
          attributes^ [attribute_index].record_type := amc$trailing_char_delimited;
        ELSEIF pvt [p$record_type].value^.keyword_value = 'VARIABLE' THEN
          attributes^ [attribute_index].record_type := amc$variable;
        IFEND;
      IFEND;

      IF pvt [p$records_per_block].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$records_per_block;
        attributes^ [attribute_index].records_per_block := pvt [p$records_per_block].value^.integer_value.
              value;
      IFEND;

      IF pvt [p$statement_identifier].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$statement_identifier;
        attributes^ [attribute_index].statement_identifier.location :=
              pvt [p$statement_identifier].value^.field_values^ [1].value^.integer_value.value;
        attributes^ [attribute_index].statement_identifier.length :=
              pvt [p$statement_identifier].value^.field_values^ [2].value^.integer_value.value;
      IFEND;

      IF pvt [p$user_information].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$user_info;
        attributes^ [attribute_index].user_info := pvt [p$user_information].value^.string_value^;
      IFEND;

    END /determine_attributes/;

    bap$file_command (pvt [p$file].value^.file_value^, attributes, status);

  PROCEND clp$_set_file_attributes;
?? TITLE := 'clp$_change_file_attributes', EJECT ??

  PROCEDURE [XDCL] clp$_change_file_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$chafa) change_file_attributes, change_file_attribute, chafa (
{   file, f: file = $required
{   file_access_procedure_name, fapn, file_access_procedure, fap: (BY_NAME) any of
{       key
{         none
{       keyend
{       name
{     anyend = $optional
{   file_contents, file_content, fc: (BY_NAME) any of
{       key
{         ascii_log, binary_log, data, file_backup, legible_data, legible_library, legible_scl_include
{         legible_scl_job, legible_scl_procedure, list, object_data, object_library, screen_form, source_map
{         unknown
{       keyend
{       name
{     anyend = $optional
{   file_limit, fl: (BY_NAME) integer 0..amc$file_byte_limit = $optional
{   file_processor, fp: (BY_NAME) any of
{       key
{         ada, apl, assembler, basic, c, cobol, cybil, debugger, fortran, lisp, pascal, pli, ppu_assembler
{         prolog, scl, scu, vs, unknown
{       keyend
{       name
{     anyend = $optional
{   file_structure, fs: (BY_NAME, HIDDEN) any of
{       key
{         data, library, unknown
{       keyend
{       name
{     anyend = $optional
{   forced_write, fw: (BY_NAME) any of
{       key
{         (forced_if_structure_change, fisc)
{       keyend
{       boolean
{     anyend = $optional
{   line_number, ln: (BY_NAME) record
{       location: integer 1..amc$max_page_width
{       length: integer 1..amc$max_line_number
{     recend = $optional
{   loading_factor, lf: (BY_NAME) integer 0..100 = $optional
{   lock_expiration_time, let: (BY_NAME) integer 0..604800000 = $optional
{   logging_options, logging_option, lo: (BY_NAME) list of key
{       (enable_parcels, ep)
{       (enable_media_recovery, emr)
{       (enable_request_recovery, err)
{       all, none
{     keyend = $optional
{   log_residence, lr: (BY_NAME) any of
{       key
{         none
{       keyend
{       file
{     anyend = $optional
{   record_limit, rl: (BY_NAME) integer 1..amc$file_byte_limit = $optional
{   ring_attributes, ring_attribute, ra: (BY_NAME) list 1..3 of integer osc$min_ring..osc$max_ring = $optional
{   statement_identifier, si: (BY_NAME) record
{       location: integer 1..amc$max_page_width
{       length: integer 1..amc$max_statement_id_length
{     recend = $optional
{   user_information, ui: (BY_NAME) string 0..amc$max_user_info = $optional
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 38] of clt$pdt_parameter_name,
      parameters: array [1 .. 17] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: 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$name_type_qualifier,
        recend,
      recend,
      type3: 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 .. 15] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: 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 .. 18] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type6: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type7: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 8] of clt$keyword_specification,
        recend,
      recend,
      type12: 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,
        recend,
      recend,
      type13: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type14: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type15: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type17: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 1, 8, 15, 27, 50, 559],
    clc$command, 38, 17, 1, 0, 1, 0, 17, 'OSM$CHAFA'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FAP                            ',clc$abbreviation_entry, 2],
    ['FAPN                           ',clc$alias_entry, 2],
    ['FC                             ',clc$abbreviation_entry, 3],
    ['FILE                           ',clc$nominal_entry, 1],
    ['FILE_ACCESS_PROCEDURE          ',clc$alias_entry, 2],
    ['FILE_ACCESS_PROCEDURE_NAME     ',clc$nominal_entry, 2],
    ['FILE_CONTENT                   ',clc$alias_entry, 3],
    ['FILE_CONTENTS                  ',clc$nominal_entry, 3],
    ['FILE_LIMIT                     ',clc$nominal_entry, 4],
    ['FILE_PROCESSOR                 ',clc$nominal_entry, 5],
    ['FILE_STRUCTURE                 ',clc$nominal_entry, 6],
    ['FL                             ',clc$abbreviation_entry, 4],
    ['FORCED_WRITE                   ',clc$nominal_entry, 7],
    ['FP                             ',clc$abbreviation_entry, 5],
    ['FS                             ',clc$abbreviation_entry, 6],
    ['FW                             ',clc$abbreviation_entry, 7],
    ['LET                            ',clc$abbreviation_entry, 10],
    ['LF                             ',clc$abbreviation_entry, 9],
    ['LINE_NUMBER                    ',clc$nominal_entry, 8],
    ['LN                             ',clc$abbreviation_entry, 8],
    ['LO                             ',clc$abbreviation_entry, 11],
    ['LOADING_FACTOR                 ',clc$nominal_entry, 9],
    ['LOCK_EXPIRATION_TIME           ',clc$nominal_entry, 10],
    ['LOGGING_OPTION                 ',clc$alias_entry, 11],
    ['LOGGING_OPTIONS                ',clc$nominal_entry, 11],
    ['LOG_RESIDENCE                  ',clc$nominal_entry, 12],
    ['LR                             ',clc$abbreviation_entry, 12],
    ['RA                             ',clc$abbreviation_entry, 14],
    ['RECORD_LIMIT                   ',clc$nominal_entry, 13],
    ['RING_ATTRIBUTE                 ',clc$alias_entry, 14],
    ['RING_ATTRIBUTES                ',clc$nominal_entry, 14],
    ['RL                             ',clc$abbreviation_entry, 13],
    ['SI                             ',clc$abbreviation_entry, 15],
    ['STATEMENT_IDENTIFIER           ',clc$nominal_entry, 15],
    ['STATUS                         ',clc$nominal_entry, 17],
    ['UI                             ',clc$abbreviation_entry, 16],
    ['USER_INFORMATION               ',clc$nominal_entry, 16]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 587,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 698,
  clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [12, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 143,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 104,
  clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 119,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 10
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 11
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 319,
  clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [27, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 67, clc$optional_parameter,
  0, 0],
{ PARAMETER 13
    [30, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 14
    [32, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 36, clc$optional_parameter,
  0, 0],
{ PARAMETER 15
    [35, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 119,
  clc$optional_parameter, 0, 0],
{ PARAMETER 16
    [38, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 17
    [36, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    562, [[1, 0, clc$keyword_type], [15], [
      ['ASCII_LOG                      ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['BINARY_LOG                     ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['DATA                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['FILE_BACKUP                    ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['LEGIBLE_DATA                   ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['LEGIBLE_LIBRARY                ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['LEGIBLE_SCL_INCLUDE            ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['LEGIBLE_SCL_JOB                ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['LEGIBLE_SCL_PROCEDURE          ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['LIST                           ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['OBJECT_DATA                    ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['OBJECT_LIBRARY                 ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['SCREEN_FORM                    ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['SOURCE_MAP                     ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['UNKNOWN                        ', clc$nominal_entry, clc$normal_usage_entry, 15]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [0, amc$file_byte_limit, 10]],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    673, [[1, 0, clc$keyword_type], [18], [
      ['ADA                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['APL                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['ASSEMBLER                      ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['BASIC                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['C                              ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['COBOL                          ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['CYBIL                          ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['DEBUGGER                       ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['FORTRAN                        ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['LISP                           ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['PASCAL                         ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['PLI                            ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['PPU_ASSEMBLER                  ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['PROLOG                         ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['SCL                            ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['SCU                            ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['UNKNOWN                        ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['VS                             ', clc$nominal_entry, clc$normal_usage_entry, 17]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['DATA                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['LIBRARY                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['UNKNOWN                        ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['FISC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['FORCED_IF_STRUCTURE_CHANGE     ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 8
    [[1, 0, clc$record_type], [2],
    ['LOCATION                       ', clc$required_field, 20], [[1, 0, clc$integer_type], [1,
  amc$max_page_width, 10]],
    ['LENGTH                         ', clc$required_field, 20], [[1, 0, clc$integer_type], [1,
  amc$max_line_number, 10]]
    ],
{ PARAMETER 9
    [[1, 0, clc$integer_type], [0, 100, 10]],
{ PARAMETER 10
    [[1, 0, clc$integer_type], [0, 604800000, 10]],
{ PARAMETER 11
    [[1, 0, clc$list_type], [303, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [8], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['EMR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['ENABLE_MEDIA_RECOVERY          ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['ENABLE_PARCELS                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['ENABLE_REQUEST_RECOVERY        ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ERR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 5]]
      ]
    ],
{ PARAMETER 12
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ],
{ PARAMETER 13
    [[1, 0, clc$integer_type], [1, amc$file_byte_limit, 10]],
{ PARAMETER 14
    [[1, 0, clc$list_type], [20, 1, 3, FALSE],
      [[1, 0, clc$integer_type], [osc$min_ring, osc$max_ring, 10]]
    ],
{ PARAMETER 15
    [[1, 0, clc$record_type], [2],
    ['LOCATION                       ', clc$required_field, 20], [[1, 0, clc$integer_type], [1,
  amc$max_page_width, 10]],
    ['LENGTH                         ', clc$required_field, 20], [[1, 0, clc$integer_type], [1,
  amc$max_statement_id_length, 10]]
    ],
{ PARAMETER 16
    [[1, 0, clc$string_type], [0, amc$max_user_info, FALSE]],
{ PARAMETER 17
    [[1, 0, clc$status_type]]];

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

    CONST
      p$file = 1,
      p$file_access_procedure_name = 2,
      p$file_contents = 3,
      p$file_limit = 4,
      p$file_processor = 5,
      p$file_structure = 6,
      p$forced_write = 7,
      p$line_number = 8,
      p$loading_factor = 9,
      p$lock_expiration_time = 10,
      p$logging_options = 11,
      p$log_residence = 12,
      p$record_limit = 13,
      p$ring_attributes = 14,
      p$statement_identifier = 15,
      p$user_information = 16,
      p$status = 17;

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

    VAR
      access_mode: pft$usage_selections,
      attributes: ^amt$file_attributes,
      attribute_count: 0 .. p$status - 2,
      attribute_index: 0 .. p$status - 1,
      compression_procedure_name_ptr: ^amt$compression_procedure_name,
      current_access_mode: ^clt$data_value,
      current_message: ^clt$data_value,
      evaluated_file_reference: fst$evaluated_file_reference,
      hashing_procedure_name_ptr: ^amt$hashing_procedure_name,
      label_option: amt$label_options,
      logging_options: amt$logging_options,
      log_options: ^clt$data_value,
      log_residence_ptr: ^amt$log_residence,
      message_control: amt$message_control,
      path_handle_name: fst$path_handle_name,
      remote: boolean,
      ring: ^clt$data_value;


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

    evaluate_path_and_handle_remote ('CHANGE_FILE_ATTRIBUTES', pvt [p$file].value^.file_value^, ^pvt, remote,
          status);
    IF (NOT status.normal) OR remote THEN
      RETURN;
    IFEND;

    clp$convert_str_to_path_handle (pvt [p$file].value^.file_value^, FALSE, TRUE, FALSE, path_handle_name,
          evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF evaluated_file_reference.path_resolution = fsc$catalog_path THEN
      osp$set_status_abnormal ('CL', pfe$name_not_permanent_file, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, pvt [p$file].value^.file_value^, status);
      RETURN;
    IFEND;

  /determine_attributes/
    BEGIN

      attribute_count := 0;
      FOR attribute_index := 2 TO p$status - 1 DO
        IF pvt [attribute_index].specified THEN
          attribute_count := attribute_count + 1;
        IFEND;
      FOREND;
      IF attribute_count = 0 THEN
        attributes := NIL;
        EXIT /determine_attributes/;
      ELSE
        PUSH attributes: [1 .. attribute_count];
      IFEND;
      attribute_index := 0;

      IF pvt [p$file_access_procedure_name].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$file_access_procedure;
        IF pvt [p$file_access_procedure_name].value^.kind = clc$keyword {AND keyword = NONE} THEN
          attributes^ [attribute_index].file_access_procedure := osc$null_name;
        ELSE
          attributes^ [attribute_index].file_access_procedure :=
                pvt [p$file_access_procedure_name].value^.name_value;
        IFEND;
      IFEND;

      IF pvt [p$file_contents].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$file_contents;
        IF pvt [p$file_contents].value^.kind = clc$keyword {AND keyword = NONE} THEN
          attributes^ [attribute_index].file_contents := pvt [p$file_contents].value^.keyword_value;
        ELSE
          attributes^ [attribute_index].file_contents := pvt [p$file_contents].value^.name_value;
        IFEND;
      IFEND;

      IF pvt [p$file_limit].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$file_limit;
        attributes^ [attribute_index].file_limit := pvt [p$file_limit].value^.integer_value.value;
      IFEND;

      IF pvt [p$file_processor].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$file_processor;
        IF pvt [p$file_processor].value^.kind = clc$keyword {AND keyword = NONE} THEN
          attributes^ [attribute_index].file_processor := pvt [p$file_processor].value^.keyword_value;
        ELSE
          attributes^ [attribute_index].file_processor := pvt [p$file_processor].value^.name_value;
        IFEND;
      IFEND;

      IF pvt [p$file_structure].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$file_structure;
        IF pvt [p$file_structure].value^.kind = clc$keyword {AND keyword = NONE} THEN
          attributes^ [attribute_index].file_structure := pvt [p$file_structure].value^.keyword_value;
        ELSE
          attributes^ [attribute_index].file_structure := pvt [p$file_structure].value^.name_value;
        IFEND;
      IFEND;

      IF pvt [p$forced_write].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$forced_write;
        IF pvt [p$forced_write].value^.kind = clc$keyword {AND keyword = NONE} THEN
          attributes^ [attribute_index].forced_write := amc$forced_if_structure_change;
        ELSEIF pvt [p$forced_write].value^.boolean_value.value THEN
          attributes^ [attribute_index].forced_write := amc$forced;
        ELSE
          attributes^ [attribute_index].forced_write := amc$unforced;
        IFEND;
      IFEND;

      IF pvt [p$line_number].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$line_number;
        attributes^ [attribute_index].line_number.location :=
              pvt [p$line_number].value^.field_values^ [1].value^.integer_value.value;
        attributes^ [attribute_index].line_number.length := pvt [p$line_number].value^.field_values^ [2].
              value^.integer_value.value;
      IFEND;

      IF pvt [p$loading_factor].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$loading_factor;
        attributes^ [attribute_index].loading_factor := pvt [p$loading_factor].value^.integer_value.value;
      IFEND;

      IF pvt [p$lock_expiration_time].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$lock_expiration_time;
        attributes^ [attribute_index].lock_expiration_time :=
              pvt [p$lock_expiration_time].value^.integer_value.value;
      IFEND;

      IF pvt [p$logging_options].specified THEN
        attribute_index := attribute_index + 1;
        log_options := pvt [p$logging_options].value;
        attributes^ [attribute_index].key := amc$logging_options;
        attributes^ [attribute_index].logging_options := $amt$logging_options [];

      /get_logging_options/
        WHILE log_options <> NIL DO
          IF log_options^.element_value^.keyword_value = 'ALL' THEN
            IF pvt [p$logging_options].value^.link <> NIL THEN
              osp$set_status_abnormal ('CL', cle$all_must_be_used_alone, 'LOGGING_OPTIONS', status);
              RETURN;
            IFEND;
            logging_options := $amt$logging_options [amc$enable_parcels, amc$enable_media_recovery,
                  amc$enable_request_recovery];
          ELSEIF log_options^.element_value^.keyword_value = 'ENABLE_PARCELS' THEN
            logging_options := $amt$logging_options [amc$enable_parcels];
          ELSEIF log_options^.element_value^.keyword_value = 'ENABLE_MEDIA_RECOVERY' THEN
            logging_options := $amt$logging_options [amc$enable_media_recovery];
          ELSEIF log_options^.element_value^.keyword_value = 'ENABLE_REQUEST_RECOVERY' THEN
            logging_options := $amt$logging_options [amc$enable_request_recovery];
          ELSEIF log_options^.element_value^.keyword_value = 'NONE' THEN
            IF pvt [p$logging_options].value^.link <> NIL THEN
              osp$set_status_abnormal ('CL', cle$none_must_be_used_alone, 'LOGGING_OPTIONS', status);
              RETURN;
            IFEND;
            EXIT /get_logging_options/;
          IFEND;
          attributes^ [attribute_index].logging_options := attributes^ [attribute_index].logging_options +
                logging_options;
          log_options := log_options^.link;
        WHILEND /get_logging_options/;
      IFEND;

      IF pvt [p$log_residence].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$log_residence;
        PUSH log_residence_ptr;
        IF pvt [p$log_residence].value^.kind = clc$keyword {AND keyword = NONE} THEN
          log_residence_ptr^ := '';
        ELSE
          log_residence_ptr^ := pvt [p$log_residence].value^.file_value^;
        IFEND;
        attributes^ [attribute_index].log_residence := log_residence_ptr;
      IFEND;

      IF pvt [p$record_limit].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$record_limit;
        attributes^ [attribute_index].record_limit := pvt [p$record_limit].value^.integer_value.value;
      IFEND;

      IF pvt [p$ring_attributes].specified THEN
        ring := pvt [p$ring_attributes].value;
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$ring_attributes;
        attributes^ [attribute_index].ring_attributes.r1 := ring^.element_value^.integer_value.value;
        IF ring^.link = NIL THEN
          attributes^ [attribute_index].ring_attributes.r2 := attributes^ [attribute_index].ring_attributes.
                r1;
          attributes^ [attribute_index].ring_attributes.r3 := attributes^ [attribute_index].ring_attributes.
                r2;
        ELSE
          ring := ring^.link;
          attributes^ [attribute_index].ring_attributes.r2 := ring^.element_value^.integer_value.value;
          IF ring^.link = NIL THEN
            attributes^ [attribute_index].ring_attributes.r3 :=
                  attributes^ [attribute_index].ring_attributes.r2;
          ELSE
            ring := ring^.link;
            attributes^ [attribute_index].ring_attributes.r3 := ring^.element_value^.integer_value.value;
          IFEND;
        IFEND;
      IFEND;

      IF pvt [p$statement_identifier].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$statement_identifier;
        attributes^ [attribute_index].statement_identifier.location :=
              pvt [p$statement_identifier].value^.field_values^ [1].value^.integer_value.value;
        attributes^ [attribute_index].statement_identifier.length :=
              pvt [p$statement_identifier].value^.field_values^ [2].value^.integer_value.value;
      IFEND;

      IF pvt [p$user_information].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$user_info;
        attributes^ [attribute_index].user_info := pvt [p$user_information].value^.string_value^;
      IFEND;

    END /determine_attributes/;

    amp$change_file_attributes (pvt [p$file].value^.file_value^, attributes, status);

  PROCEND clp$_change_file_attributes;
?? TITLE := '[XDCL, #GATE] clp$_change_default_file_attbs' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] clp$_change_default_file_attbs
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$chadfa) change_default_file_attributes, chadfa (
{   lock_expiration_time, let: (BY_NAME) integer 0..604800000 = $optional
{   page_length, pl: (BY_NAME) integer 1..amc$file_byte_limit = $optional
{   page_width, pw: (BY_NAME) integer 1..amc$max_page_width = $optional
{   record_type, rt: (BY_NAME) key
{       (ansi_fixed, fixed, f, af)
{       (ansi_spanned, s, as)
{       (ansi_variable, d, av)
{       (variable, v)
{       (undefined, u)
{       (trailing_character_delimited, tcd, trailing, t)
{     keyend = $optional
{   retention, new_retention, r, nr: any of
{       integer pfc$minimum_retention..pfc$maximum_retention
{       date
{       date_time
{       time_increment
{     anyend = $optional
{   reset_system_defaults, rsd: boolean = false
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 15] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 18] of clt$keyword_specification,
      recend,
      type5: 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$integer_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$date_time_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$date_time_type_qualifier,
        recend,
        type_size_4: clt$type_specification_size,
        element_type_spec_4: record
          header: clt$type_specification_header,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [97, 1, 14, 14, 1, 19, 214],
    clc$command, 15, 7, 0, 0, 0, 0, 7, 'OSM$CHADFA'], [
    ['LET                            ',clc$abbreviation_entry, 1],
    ['LOCK_EXPIRATION_TIME           ',clc$nominal_entry, 1],
    ['NEW_RETENTION                  ',clc$alias_entry, 5],
    ['NR                             ',clc$abbreviation_entry, 5],
    ['PAGE_LENGTH                    ',clc$nominal_entry, 2],
    ['PAGE_WIDTH                     ',clc$nominal_entry, 3],
    ['PL                             ',clc$abbreviation_entry, 2],
    ['PW                             ',clc$abbreviation_entry, 3],
    ['R                              ',clc$alias_entry, 5],
    ['RECORD_TYPE                    ',clc$nominal_entry, 4],
    ['RESET_SYSTEM_DEFAULTS          ',clc$nominal_entry, 6],
    ['RETENTION                      ',clc$nominal_entry, 5],
    ['RSD                            ',clc$abbreviation_entry, 6],
    ['RT                             ',clc$abbreviation_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 7]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 673,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 61, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 7
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 604800000, 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, amc$file_byte_limit, 10]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, amc$max_page_width, 10]],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [18], [
    ['AF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ANSI_FIXED                     ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ANSI_SPANNED                   ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['ANSI_VARIABLE                  ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['AS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['AV                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['D                              ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['F                              ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['FIXED                          ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['S                              ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['TCD                            ', clc$alias_entry, clc$normal_usage_entry, 6],
    ['TRAILING                       ', clc$alias_entry, clc$normal_usage_entry, 6],
    ['TRAILING_CHARACTER_DELIMITED   ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['UNDEFINED                      ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['V                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['VARIABLE                       ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$date_time_type, clc$integer_type, clc$time_increment_type],
    FALSE, 4],
    20, [[1, 0, clc$integer_type], [pfc$minimum_retention, pfc$maximum_retention, 10]],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date], $clt$date_time_tenses [clc$past,
  clc$present, clc$future]]],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [
  clc$past, clc$present, clc$future]]],
    3, [[1, 0, clc$time_increment_type]]
    ],
{ PARAMETER 6
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

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

    CONST
      p$lock_expiration_time = 1,
      p$page_length = 2,
      p$page_width = 3,
      p$record_type = 4,
      p$retention = 5,
      p$reset_system_defaults = 6,
      p$status = 7;

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

    VAR
      attributes: ^amt$file_attributes,
      attribute_count: 0 .. p$reset_system_defaults - 1,
      attribute_index: 0 .. p$reset_system_defaults - 1,
      date_time: ost$date_time,
      expiration_date: ost$date_time,
      ignore_status: ost$status,
      reset_system_defaults: boolean,
      retention: ^fst$retention;

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

    reset_system_defaults := pvt [p$reset_system_defaults].value^.boolean_value.value;

  /determine_attributes/
    BEGIN

      attribute_count := 0;
      FOR attribute_index := 1 TO p$reset_system_defaults - 1 DO
        IF pvt [attribute_index].specified THEN
          attribute_count := attribute_count + 1;
        IFEND;
      FOREND;
      IF attribute_count = 0 THEN
        attributes := NIL;
        retention := NIL;
        EXIT /determine_attributes/;
      ELSE
        IF pvt [p$retention].specified THEN
          attribute_count := attribute_count - 1;
          PUSH retention;
          IF pvt [p$retention].value^.kind = clc$integer THEN
            retention^.selector := fsc$retention_day_increment;
            retention^.day_increment := pvt [p$retention].value^.integer_value.value;
          ELSEIF pvt [p$retention].value^.kind = clc$time_increment THEN
            retention^.selector := fsc$retention_time_increment;
            retention^.time_increment := pvt [p$retention].value^.time_increment_value^;
            clp$verify_time_increment (retention^.time_increment, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            pmp$get_compact_date_time (date_time, ignore_status);
            pmp$compute_date_time (date_time, retention^.time_increment, expiration_date, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSE
            retention^.selector := fsc$retention_expiration_date;
            retention^.expiration_date := pvt [p$retention].value^.date_time_value.value;
            IF pvt [p$retention].value^.date_time_value.date_specified THEN
              pmp$verify_compact_date (retention^.expiration_date, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
            IF pvt [p$retention].value^.date_time_value.time_specified THEN
              pmp$verify_compact_time (retention^.expiration_date, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        ELSE
          retention := NIL;
        IFEND;

        IF attribute_count = 0 THEN
          attributes := NIL;
          EXIT /determine_attributes/;
        ELSE
          PUSH attributes: [1 .. attribute_count];
        IFEND;
      IFEND;
      attribute_index := 0;

      IF pvt [p$lock_expiration_time].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$lock_expiration_time;
        attributes^ [attribute_index].lock_expiration_time :=
              pvt [p$lock_expiration_time].value^.integer_value.value;
      IFEND;

      IF pvt [p$page_length].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$page_length;
        attributes^ [attribute_index].page_length := pvt [p$page_length].value^.integer_value.value;
      IFEND;

      IF pvt [p$page_width].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$page_width;
        attributes^ [attribute_index].page_width := pvt [p$page_width].value^.integer_value.value;
      IFEND;

      IF pvt [p$record_type].specified THEN
        attribute_index := attribute_index + 1;
        attributes^ [attribute_index].key := amc$record_type;
        IF pvt [p$record_type].value^.keyword_value = 'ANSI_FIXED' THEN
          attributes^ [attribute_index].record_type := amc$ansi_fixed;
        ELSEIF pvt [p$record_type].value^.keyword_value = 'ANSI_SPANNED' THEN
          attributes^ [attribute_index].record_type := amc$ansi_spanned;
        ELSEIF pvt [p$record_type].value^.keyword_value = 'ANSI_VARIABLE' THEN
          attributes^ [attribute_index].record_type := amc$ansi_variable;
        ELSEIF pvt [p$record_type].value^.keyword_value = 'UNDEFINED' THEN
          attributes^ [attribute_index].record_type := amc$undefined;
        ELSEIF pvt [p$record_type].value^.keyword_value = 'TRAILING_CHARACTER_DELIMITED' THEN
          attributes^ [attribute_index].record_type := amc$trailing_char_delimited;
        ELSEIF pvt [p$record_type].value^.keyword_value = 'VARIABLE' THEN
          attributes^ [attribute_index].record_type := amc$variable;
        IFEND;
      IFEND;

    END /determine_attributes/;

    bap$change_default_file_attribs (attributes, retention, reset_system_defaults, status);

  PROCEND clp$_change_default_file_attbs;
?? TITLE := 'evaluate_path_and_handle_remote', EJECT ??

{
{ PURPOSE:
{   This procedure parses a path for a command and determines whether it
{   represents a file on a remote system.  If so it performs the appropriate
{   remote operation.
{

  PROCEDURE evaluate_path_and_handle_remote
    (    command_name: ost$name_reference;
         path: fst$file_reference;
         pvt: ^clt$parameter_value_table;
     VAR remote: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      evaluated_file_reference: fst$evaluated_file_reference,
      family_name: ost$family_name,
      remote_parameter: array [1 .. 1] of clt$parameter_substitution,
      work_area: ^^clt$work_area;


    clp$evaluate_file_reference (path, $clt$file_ref_parsing_options [], FALSE, evaluated_file_reference,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    family_name := fsp$path_element (^evaluated_file_reference, 1) ^;

    nfp$check_implicit_access (family_name, remote, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF remote THEN
      clp$get_work_area (#RING (^work_area), work_area, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$find_current_block (block);

      remote_parameter [1].name := 'STATUS';
      remote_parameter [1].text := NIL;

      nfp$perform_implicit_access (family_name, clc$null_file, path, nfc$null, command_name,
            block^.parameters.unbundled_pdt, pvt, ^remote_parameter, work_area^, status);
    IFEND;

  PROCEND evaluate_path_and_handle_remote;

MODEND clm$file_command;
*DECK DECK=CLM$FILE_FUNCTIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : File Functions' ??
MODULE clm$file_functions;

{
{ PURPOSE:
{   This module contains functions related to files.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$conflicting_options_spec
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$parameter_list
*copyc clt$work_area
*copyc fse$path_exception_conditions
*copyc fst$goi_object_information
*copyc ost$status
?? POP ??
*copyc bap$get_path_string
*copyc clp$build_pattern_for_wild_card
*copyc clp$check_name_for_path_handle
*copyc clp$construct_block_handle_name
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_str_to_path_handle
*copyc clp$convert_string_to_file_ref
*copyc clp$determine_select_result_typ
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc clp$find_caller_input_block
*copyc clp$find_command_source
*copyc clp$find_scl_options
*copyc clp$find_working_catalog
*copyc clp$get_file_cycles
*copyc clp$get_list_of_$local_files
*copyc clp$make_integer_value
*copyc clp$make_keyword_value
*copyc clp$make_file_value
*copyc clp$make_integer_value
*copyc clp$make_list_value
*copyc clp$make_name_value
*copyc clp$make_string_value
*copyc clp$match_string_pattern
*copyc clp$remove_last_path_element
*copyc clp$trimmed_string_size
*copyc clp$wild_card_file_expansion
*copyc clv$open_position_designator
*copyc clv$user_identification
*copyc fsc$local
*copyc fsp$convert_fs_structure_to_pf
*copyc fsp$path_element
*copyc mmp$create_segment
*copyc mmp$delete_segment
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osv$lower_to_upper
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_multi_item_info

?? TITLE := 'clp$$catalog_contents', EJECT ??

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

{ FUNCTION (osm$$catc) $catalog_contents (
{   catalog: file = $working_catalog
{   options: list rest of key
{       (include_catalogs, include_catalog, ic)
{       (include_files, include_file, if)
{       (names, name, n)
{       (paths, path, p)
{     keyend = include_catalogs include_files names
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (16),
      recend,
      type2: 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 .. 12] of clt$keyword_specification,
        recend,
        default_value: string (36),
      recend,
    recend := [
    [1,
    [90, 4, 3, 13, 57, 6, 188],
    clc$function, 2, 2, 0, 0, 0, 0, 0, 'OSM$$CATC'], [
    ['CATALOG                        ',clc$nominal_entry, 1],
    ['OPTIONS                        ',clc$nominal_entry, 2]],
    [
{ 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, 3,
  clc$optional_default_parameter, 0, 16],
{ PARAMETER 2
    [2, 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, 467,
  clc$optional_default_parameter, 0, 36]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$working_catalog'],
{ PARAMETER 2
    [[1, 0, clc$list_type], [451, 1, clc$max_list_size, 0, FALSE, TRUE],
      [[1, 0, clc$keyword_type], [12], [
      ['IC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['IF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['INCLUDE_CATALOG                ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['INCLUDE_CATALOGS               ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['INCLUDE_FILE                   ', clc$alias_entry, clc$normal_usage_entry, 2],
      ['INCLUDE_FILES                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['NAME                           ', clc$alias_entry, clc$normal_usage_entry, 3],
      ['NAMES                          ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['PATH                           ', clc$alias_entry, clc$normal_usage_entry, 4],
      ['PATHS                          ', clc$nominal_entry, clc$normal_usage_entry, 4]]
      ]
    ,
    'include_catalogs include_files names']];

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

    CONST
      p$catalog = 1,
      p$options = 2;

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

    VAR
      catalog_info_selections: pft$catalog_info_selections,
      directory: pft$p_directory_array,
      display_names: boolean,
      display_paths: boolean,
      evaluated_file_reference: fst$evaluated_file_reference,
      file_info_selections: pft$file_info_selections,
      first_path_element_is_$local: boolean,
      group: pft$group,
      include_file_info: boolean,
      include_catalog_info: boolean,
      info: pft$p_info,
      info_record: pft$p_info_record,
      info_segment_pointer: mmt$segment_pointer,
      local_status: ost$status,
      options: ^clt$data_value,
      pf_path: ^pft$path;

?? NEWTITLE := 'make_catalog_contents_list', EJECT ??

    PROCEDURE [INLINE] make_catalog_contents_list;

      VAR
        index: pft$array_index,
        name_size: 0 .. osc$max_name_size,
        node: ^clt$data_value,
        size: fst$path_size,
        str: fst$path;


      IF display_paths THEN
        clp$convert_file_ref_to_string (evaluated_file_reference, FALSE, str, size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    /make/
      BEGIN
        clp$make_list_value (work_area, result);
        IF result = NIL THEN
          EXIT /make/;
        IFEND;

        node := result;
        FOR index := LOWERBOUND (directory^) TO UPPERBOUND (directory^) DO
          IF display_paths THEN
            name_size := clp$trimmed_string_size (directory^ [index].name);
            str (size + 1) := '.';
            str (size + 2, name_size) := directory^ [index].name;
            clp$make_file_value (str (1, size + name_size + 1), work_area, node^.element_value);
          ELSE
            clp$make_name_value (directory^ [index].name, work_area, node^.element_value);
          IFEND;
          IF node^.element_value = NIL THEN
            EXIT /make/;
          IFEND;
          IF index < UPPERBOUND (directory^) THEN
            clp$make_list_value (work_area, node^.link);
            IF node^.link = NIL THEN
              EXIT /make/;
            IFEND;
            node := node^.link;
          IFEND;
        FOREND;
        RETURN;
      END /make/;

      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);

    PROCEND make_catalog_contents_list;
?? OLDTITLE, EJECT ??

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

    clp$evaluate_file_reference (pvt [p$catalog].value^.file_value^, $clt$file_ref_parsing_options [], FALSE,
          evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF evaluated_file_reference.cycle_reference.specification <> fsc$cycle_omitted THEN
      osp$set_status_abnormal ('CL', fse$catalogs_do_not_have_cycles, pvt [p$catalog].value^.file_value^,
            status);
      RETURN;
    IFEND;

    IF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
      osp$set_status_abnormal ('CL', cle$file_position_not_allowed, '', status);
      RETURN;
    IFEND;

    first_path_element_is_$local := fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local;

    IF first_path_element_is_$local AND (evaluated_file_reference.number_of_path_elements > 1) THEN
      osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_file, pvt [p$catalog].value^.file_value^,
            status);
      RETURN;
    IFEND;

    info_segment_pointer.kind := mmc$sequence_pointer;
    info_segment_pointer.seq_pointer := NIL;

    include_catalog_info := FALSE;
    include_file_info := FALSE;
    display_names := FALSE;
    display_paths := FALSE;
    options := pvt [p$options].value;

    WHILE options <> NIL DO
      IF (options^.element_value^.keyword_value (1, 9) = 'INCLUDE_C') OR
            (options^.element_value^.keyword_value = 'IC') THEN
        include_catalog_info := TRUE;
      ELSEIF options^.element_value^.keyword_value (1) = 'I' THEN
        include_file_info := TRUE;
      ELSEIF options^.element_value^.keyword_value (1) = 'N' THEN
        display_names := TRUE;
      ELSE
        display_paths := TRUE;
      IFEND;
      options := options^.link;
    WHILEND;

    IF display_names AND display_paths THEN
      osp$set_status_abnormal ('CL', cle$conflicting_options_spec, '$CATALOG_CONTENTS', status);
      RETURN;
    ELSEIF (NOT display_names) AND (NOT display_paths) THEN
      display_names := TRUE;
    IFEND;
    IF (NOT include_catalog_info) AND (NOT include_file_info) THEN
      include_catalog_info := TRUE;
      include_file_info := TRUE;
    IFEND;

  /main/
    BEGIN

      mmp$create_segment (NIL, mmc$sequence_pointer, 1, info_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      info := info_segment_pointer.seq_pointer;
      RESET info;

      IF first_path_element_is_$local THEN
        IF include_catalog_info AND NOT include_file_info THEN
          make_empty_list (work_area, result, status);
          EXIT /main/;
        IFEND;
        clp$get_list_of_$local_files (info, status);
      ELSE
        PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
        fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);

        group.group_type := pfc$member;
        group.member_description.family := osc$null_name;
        group.member_description.account := osc$null_name;
        group.member_description.project := osc$null_name;
        group.member_description.user := osc$null_name;

        catalog_info_selections := $pft$catalog_info_selections [];
        file_info_selections := $pft$file_info_selections [];
        IF include_catalog_info THEN
          catalog_info_selections := $pft$catalog_info_selections [pfc$catalog_directory];
        IFEND;
        IF include_file_info THEN
          file_info_selections := $pft$file_info_selections [pfc$file_directory];
        IFEND;

        pfp$get_multi_item_info (pf_path^, group, catalog_info_selections, file_info_selections, info,
              status);
        IF NOT status.normal THEN
          IF status.condition = pfe$unknown_last_subcatalog THEN
            status.normal := TRUE;
            make_empty_list (work_area, result, status);
          IFEND;
          EXIT /main/;
        IFEND;
      IFEND;

      RESET info;

      pfp$find_next_info_record (info, info_record, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      pfp$find_directory_array (info_record, directory, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      IF directory = NIL THEN
        make_empty_list (work_area, result, status);
        EXIT /main/;
      IFEND;

      make_catalog_contents_list;
    END /main/;

    mmp$delete_segment (info_segment_pointer, 1, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

  PROCEND clp$$catalog_contents;
?? TITLE := 'find_$command', EJECT ??

  PROCEDURE find_$command
    (    command_flavor: amt$local_file_name;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    CONST
      command_path_element_length = 10; {:$COMMAND.}

    VAR
      block: ^clt$block,
      block_handle: clt$block_handle,
      block_handle_name: fst$path_handle_name,
      ignore_block_in_current_task: boolean,
      path: string (command_path_element_length + osc$max_name_size);


    clp$find_caller_input_block (command_flavor, block, ignore_block_in_current_task);
    IF (block <> NIL) AND (block^.input.kind = clc$file_input) THEN
      block_handle.segment_offset := #OFFSET (block);
      block_handle.assignment_counter := block^.assignment_counter;
      path := ':$COMMAND.';
      clp$construct_block_handle_name (block_handle, block_handle_name);
      path (command_path_element_length + 1, * ) := block_handle_name
            (1, clp$trimmed_string_size (block_handle_name));
    ELSE
      path := ':$LOCAL.$NULL';
    IFEND;

    clp$make_file_value (path (1, clp$trimmed_string_size (path)), work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND find_$command;
?? TITLE := 'find_command_source', EJECT ??

  PROCEDURE [INLINE] find_command_source
    (    command_source_flavor: amt$local_file_name;
     VAR source: fst$path;
     VAR source_size: fst$path_size;
     VAR kind: clt$data_kind;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      path_handle: clt$path_handle;


    clp$find_command_source (command_source_flavor, block);
    IF block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unable_to_find_cmnd_source, '', status);
      RETURN;
    IFEND;

    CASE block^.source.kind OF
    = clc$system_commands =
      source := '$SYSTEM';
      source_size := 7;
      kind := clc$name;
    = clc$sub_commands =
      source := block^.source.utility_name;
      source_size := clp$trimmed_string_size (source);
      kind := clc$name;
    = clc$catalog_commands, clc$library_commands =
      clp$check_name_for_path_handle (block^.source.local_file_name, path_handle);
      bap$get_path_string (path_handle.regular_handle, source, source_size, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      kind := clc$file;
    CASEND;

  PROCEND find_command_source;
?? TITLE := 'clp$$command', EJECT ??

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

{ FUNCTION (osm$command) $command

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [90, 4, 3, 13, 57, 16, 96],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$COMMAND']];

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

    VAR
      command_flavor: amt$local_file_name;


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

    command_flavor := '$COMMAND';
    find_$command (command_flavor, work_area, result, status);

  PROCEND clp$$command;
?? TITLE := 'clp$$command_of_caller', EJECT ??

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

{ FUNCTION (osm$$comoc) $command_of_caller

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [90, 4, 3, 13, 57, 25, 59],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$COMOC']];

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

    VAR
      command_flavor: amt$local_file_name;


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

    command_flavor := '$COMMAND_OF_CALLER';
    find_$command (command_flavor, work_area, result, status);

  PROCEND clp$$command_of_caller;
?? TITLE := 'clp$$command_source', EJECT ??

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

{ FUNCTION (osm$command_source) $command_source

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [90, 4, 3, 13, 57, 33, 190],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$COMMAND_SOURCE']];

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

    VAR
      command_source_flavor: amt$local_file_name,
      ignore_kind: clt$data_kind,
      source: fst$path,
      source_size: fst$path_size;


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

    command_source_flavor := '$SOURCE';
    find_command_source (command_source_flavor, source, source_size, ignore_kind, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_string_value (source (1, source_size), work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$command_source;
?? TITLE := 'clp$$family', EJECT ??

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

{ FUNCTION (osm$family) $family

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [90, 4, 3, 13, 57, 40, 494],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$FAMILY']];

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

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

    clp$make_value (clc$file, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;
    NEXT result^.file_value: [1 + clv$user_identification.family.size] IN work_area;
    IF result^.file_value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.file_value^ (1) := ':';
    result^.file_value^ (2, * ) := clv$user_identification.family.
          value (1, clv$user_identification.family.size);

  PROCEND clp$$family;
?? TITLE := 'clp$$file_cycles', EJECT ??

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

{ FUNCTION (osm$$file_cycles) $file_cycles (
{   file: file = $required
{   option: key
{       (cycles, cycle, c)
{       (paths, path, p)
{     keyend = cycles
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (6),
      recend,
    recend := [
    [1,
    [90, 4, 3, 13, 57, 53, 423],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$FILE_CYCLES'], [
    ['FILE                           ',clc$nominal_entry, 1],
    ['OPTION                         ',clc$nominal_entry, 2]],
    [
{ 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, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, 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, 229,
  clc$optional_default_parameter, 0, 6]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [6], [
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CYCLE                          ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['CYCLES                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['PATH                           ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['PATHS                          ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'cycles']];

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

    CONST
      p$file = 1,
      p$option = 2;

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

    VAR
      cycle_array: ^array [1 .. * ] of fst$cycle_number,
      display_paths: boolean,
      evaluated_file_reference: fst$evaluated_file_reference,
      file_value: fst$path,
      ignore_path_handle_name: fst$path_handle_name;

?? NEWTITLE := 'make_file_cycles_list', EJECT ??

    PROCEDURE [INLINE] make_file_cycles_list;

      VAR
        index: fst$cycle_number,
        node: ^clt$data_value,
        size: fst$path_size,
        str: fst$path;


    /make/
      BEGIN
        clp$make_list_value (work_area, result);
        IF result = NIL THEN
          EXIT /make/;
        IFEND;

        node := result;
        FOR index := 1 TO UPPERBOUND (cycle_array^) DO
          IF display_paths THEN
            evaluated_file_reference.cycle_reference.cycle_number := cycle_array^ [index];
            clp$convert_file_ref_to_string (evaluated_file_reference, FALSE, str, size, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            clp$make_file_value (str (1, size), work_area, node^.element_value);
          ELSE
            clp$make_integer_value (cycle_array^ [index], 10, FALSE, work_area, node^.element_value);
          IFEND;
          IF node^.element_value = NIL THEN
            EXIT /make/;
          IFEND;
          IF index < UPPERBOUND (cycle_array^) THEN
            clp$make_list_value (work_area, node^.link);
            IF node^.link = NIL THEN
              EXIT /make/;
            IFEND;
            node := node^.link;
          IFEND;
        FOREND;
        RETURN;
      END /make/;

      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);

    PROCEND make_file_cycles_list;
?? OLDTITLE, EJECT ??

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

    IF pvt [p$file].value^.file_value^ = ':$LOCAL' THEN
      osp$set_status_abnormal ('CL', pfe$name_not_permanent_file, pvt [p$file].value^.file_value^, status);
      RETURN;
    IFEND;

    file_value := pvt [p$file].value^.file_value^;

    clp$convert_str_to_path_handle (file_value, TRUE, TRUE, FALSE, ignore_path_handle_name,
          evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF evaluated_file_reference.path_resolution = fsc$catalog_path THEN
      osp$set_status_abnormal ('CL', pfe$name_not_permanent_file, pvt [p$file].value^.file_value^, status);
      RETURN;
    IFEND;

    display_paths := pvt [p$option].value^.keyword_value (1) = 'P';

    clp$get_file_cycles (file_value, work_area, cycle_array, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF cycle_array = NIL THEN
      make_empty_list (work_area, result, status);
    ELSE
      sort_cycles (cycle_array);
      make_file_cycles_list;
    IFEND;

  PROCEND clp$$file_cycles;
?? TITLE := 'sort_cycles', EJECT ??

  PROCEDURE sort_cycles
    (    cycle_array: ^array [1 .. * ] of fst$cycle_number);

    VAR
      gap: integer,
      start: integer,
      current: integer,
      swap: fst$cycle_number;

{ Use shell sort technique.

    gap := UPPERBOUND (cycle_array^);
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := 1 TO UPPERBOUND (cycle_array^) - gap DO
        current := start;
        WHILE (current > 0) AND (cycle_array^ [current] < cycle_array^ [current + gap]) DO
          swap := cycle_array^ [current];
          cycle_array^ [current] := cycle_array^ [current + gap];
          cycle_array^ [current + gap] := swap;
          current := current - gap;
        WHILEND;
      FOREND;
    WHILEND;

  PROCEND sort_cycles;
?? TITLE := 'clp$$fname', EJECT ??

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

{ FUNCTION (osm$$fname) $fname (
{   source: any of
{       string
{       list of any of
{         key
{           none, $low, $high, $next, $asis, $boi, $bop, $eoi
{         keyend
{         integer
{         name
{       anyend
{     anyend = $required
{   )

?? 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$string_type_qualifier,
        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$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 .. 8] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
            type_size_3: clt$type_specification_size,
            element_type_spec_3: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
      recend,
    recend := [
    [1,
    [90, 4, 3, 14, 57, 0, 564],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$FNAME'], [
    ['SOURCE                         ',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, 396,
  clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$list_type, clc$string_type],
    FALSE, 2],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
    368, [[1, 0, clc$list_type], [352, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type, clc$name_type],
        FALSE, 3],
        303, [[1, 0, clc$keyword_type], [8], [
          ['$ASIS                          ', clc$nominal_entry, clc$normal_usage_entry, 5],
          ['$BOI                           ', clc$nominal_entry, clc$normal_usage_entry, 6],
          ['$BOP                           ', clc$nominal_entry, clc$normal_usage_entry, 7],
          ['$EOI                           ', clc$nominal_entry, clc$normal_usage_entry, 8],
          ['$HIGH                          ', clc$nominal_entry, clc$normal_usage_entry, 3],
          ['$LOW                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
          ['$NEXT                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
          ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
        5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
        ]
      ]
    ]];

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

    CONST
      p$source = 1;

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

    VAR
      cycle_string: ^ost$string,
      element: ^string (fsc$max_path_element_size),
      element_size: clt$string_size,
      node: ^clt$data_value,
      parsed_file_reference: fst$parsed_file_reference,
      source_size: clt$string_size,
      source: ^clt$string_value;


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

    IF pvt [p$source].value^.kind = clc$string THEN
      source := pvt [p$source].value^.string_value;
    ELSE
      cycle_string := NIL;
      PUSH source: [fsc$max_path_size];
      source_size := 0;
      node := pvt [p$source].value;
      WHILE node <> NIL DO
        CASE node^.element_value^.kind OF
        = clc$keyword =
          IF node^.element_value^.keyword_value = 'NONE' THEN
            element := NIL;
            element_size := 0;
          ELSE
            element := ^node^.element_value^.keyword_value;
            element_size := clp$trimmed_string_size (element^);
          IFEND;
        = clc$integer =
          IF cycle_string = NIL THEN
            PUSH cycle_string;
          IFEND;
          clp$convert_integer_to_string (node^.element_value^.integer_value.value, 10, FALSE, cycle_string^,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          element := ^cycle_string^.value;
          element_size := cycle_string^.size;
        ELSE {clc$name}
          element := ^node^.element_value^.name_value;
          element_size := clp$trimmed_string_size (element^);
        CASEND;
        IF element_size > 0 THEN
          IF (source_size + 1 + element_size) > fsc$max_path_size THEN
            osp$set_status_condition (cle$file_reference_too_long, status);
            RETURN;
          IFEND;
          IF source_size = 0 THEN
            source^ (1) := ':';
          ELSE
            source^ (source_size + 1) := '.';
          IFEND;
          source^ (source_size + 2, element_size) := element^ (1, element_size);
          source_size := source_size + 1 + element_size;
        IFEND;
        node := node^.link;
      WHILEND;
      source := ^source^ (1, source_size);
    IFEND;

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

    clp$make_file_value (parsed_file_reference.path (1, parsed_file_reference.complete_path_size), work_area,
          result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$fname;
?? TITLE := 'clp$$local', EJECT ??

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

{ FUNCTION (osm$local) $local

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [90, 4, 3, 13, 59, 11, 921],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$LOCAL']];

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

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

    clp$make_file_value (':$LOCAL', work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$local;
?? TITLE := 'clp$$path', EJECT ??

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

{ FUNCTION (osm$$path) $path (
{   path: file = $required
{   keyword: key
{       catalog, last, count
{     keyend = $required
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
    recend := [
    [1,
    [90, 4, 3, 13, 59, 26, 73],
    clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$PATH'], [
    ['KEYWORD                        ',clc$nominal_entry, 2],
    ['PATH                           ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [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, 118,
  clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [3], [
    ['CATALOG                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['COUNT                          ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['LAST                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ]];

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

    CONST
      p$path = 1,
      p$keyword = 2;

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

    VAR
      parsed_file_reference: fst$parsed_file_reference;


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

    clp$convert_string_to_file_ref (pvt [p$path].value^.file_value^, parsed_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$keyword].value^.keyword_value = 'CATALOG' THEN
      clp$make_string_value (parsed_file_reference.path (1, parsed_file_reference.catalog_path_size),
            work_area, result);

    ELSE
      IF pvt [p$keyword].value^.keyword_value = 'COUNT' THEN
        clp$make_integer_value (parsed_file_reference.number_of_path_elements, 10, FALSE, work_area, result);

      ELSE {LAST}
        clp$make_string_value (parsed_file_reference.path (parsed_file_reference.last_name.index,
              parsed_file_reference.last_name.size), work_area, result);

      IFEND;
    IFEND;
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$path;
?? TITLE := 'clp$$path_elements', EJECT ??

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

{ FUNCTION (osm$$path_elements) $path_elements (
{   file: file = $required
{   options: list rest of key
{       (names, name, n)
{       (cycle_reference, cr)
{       (open_position, op)
{     keyend = names
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: 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 .. 7] of clt$keyword_specification,
        recend,
        default_value: string (5),
      recend,
    recend := [
    [1,
    [90, 4, 3, 14, 13, 46, 749],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$PATH_ELEMENTS'], [
    ['FILE                           ',clc$nominal_entry, 1],
    ['OPTIONS                        ',clc$nominal_entry, 2]],
    [
{ 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, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, 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, 282,
  clc$optional_default_parameter, 0, 5]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [266, 1, clc$max_list_size, 0, FALSE, TRUE],
      [[1, 0, clc$keyword_type], [7], [
      ['CR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['CYCLE_REFERENCE                ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['NAME                           ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['NAMES                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['OP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['OPEN_POSITION                  ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ]
    ,
    'names']];

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

    CONST
      p$file = 1,
      p$options = 2;

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

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      i: fst$number_of_path_elements,
      include_cycle_reference: boolean,
      include_names: boolean,
      include_open_position: boolean,
      keyword: clt$keyword,
      node: ^^clt$data_value,
      option_node: ^clt$data_value;


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

    include_cycle_reference := FALSE;
    include_names := FALSE;
    include_open_position := FALSE;
    option_node := pvt [p$options].value;
    WHILE option_node <> NIL DO
      IF option_node^.element_value^.keyword_value = 'CYCLE_REFERENCE' THEN
        include_cycle_reference := TRUE;
      ELSEIF option_node^.element_value^.keyword_value = 'OPEN_POSITION' THEN
        include_open_position := TRUE;
      ELSE {NAMES}
        include_names := TRUE;
      IFEND;
      option_node := option_node^.link;
    WHILEND;

    clp$evaluate_file_reference (pvt [p$file].value^.file_value^,
          $clt$file_ref_parsing_options [clc$command_file_ref_allowed], FALSE, evaluated_file_reference,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    node := ^result;

    IF include_names THEN
      FOR i := 1 TO evaluated_file_reference.number_of_path_elements DO
        clp$make_list_value (work_area, node^);
        clp$make_name_value (fsp$path_element (^evaluated_file_reference, i) ^, work_area,
              node^^.element_value);
        node := ^node^^.link;
      FOREND;
    IFEND;

    IF include_cycle_reference THEN
      clp$make_list_value (work_area, node^);

    /make_cycle_reference_element/
      BEGIN
        CASE evaluated_file_reference.cycle_reference.specification OF
        = fsc$cycle_number =
          clp$make_integer_value (evaluated_file_reference.cycle_reference.cycle_number, 10, FALSE, work_area,
                node^^.element_value);
          EXIT /make_cycle_reference_element/;
        = fsc$low_cycle =
          keyword := '$LOW';
        = fsc$high_cycle =
          keyword := '$HIGH';
        = fsc$next_cycle =
          keyword := '$NEXT';
        ELSE {fsc$cycle_omitted}
          keyword := 'NONE';
        CASEND;
        clp$make_keyword_value (keyword, work_area, node^^.element_value);
      END /make_cycle_reference_element/;

      node := ^node^^.link;
    IFEND;

    IF include_open_position THEN
      clp$make_list_value (work_area, node^);
      IF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
        keyword := clv$open_position_designator [evaluated_file_reference.path_handle_info.path_handle.
              open_position.value].value;
      ELSE
        keyword := 'NONE';
      IFEND;
      clp$make_keyword_value (keyword, work_area, node^^.element_value);
    IFEND;

  PROCEND clp$$path_elements;
?? TITLE := 'clp$$select_wild_card_files', EJECT ??

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

{ FUNCTION (osm$$selwcf) $select_wild_card_files, $select_wild_card_file, $select_file, $select_files (
{   candidates: list 0..clc$max_list_size of file = $required
{   pattern: (wild_card_file) application = $required
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        name: string (14),
        qualifier: clt$application_type_qualifier,
      recend,
    recend := [
    [1,
    [90, 4, 3, 13, 59, 52, 260],
    clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$SELWCF'], [
    ['CANDIDATES                     ',clc$nominal_entry, 1],
    ['PATTERN                        ',clc$nominal_entry, 2]],
    [
{ 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, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, 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, 18, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 0, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 14, clc$application_type], 'WILD_CARD_FILE', [FALSE]]];

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

    CONST
      p$candidates = 1,
      p$pattern = 2;

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

    VAR
      candidate: ^fst$file_reference,
      index: clt$list_size,
      match_info: clt$string_pattern_match_info,
      node: ^clt$data_value,
      pattern_path: fst$path,
      pattern_path_size: fst$path_size,
      result_node: ^^clt$data_value,
      return_selected_indices: boolean,
      scl_options: ^clt$scl_options,
      string_pattern: ^clt$string_pattern;


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

    IF (pvt [p$candidates].value^.element_value = NIL) AND (pvt [p$candidates].value^.link = NIL) THEN
      result := pvt [p$candidates].value;
      RETURN;
    IFEND;

    clp$determine_select_result_typ (work_area, return_selected_indices, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    #TRANSLATE (osv$lower_to_upper,pvt[p$pattern].value^.application_value^,pattern_path);
    pattern_path_size  :=  clp$trimmed_string_size(pattern_path);
    clp$find_scl_options (scl_options);

    clp$build_pattern_for_wild_card (scl_options^.wild_card_pattern_type, $clt$string_pattern_build_opts
          [clc$sp_match_at_right, clc$sp_ignore_matched_substring],
          pattern_path (1, pattern_path_size), work_area, string_pattern, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    index := 0;
    result := NIL;
    node := pvt [p$candidates].value;
    result_node := ^result;
    WHILE node <> NIL DO
      candidate := node^.element_value^.file_value;

      clp$match_string_pattern (candidate^ (1, clp$trimmed_string_size (candidate^)), string_pattern,
            clc$sp_anchored, clc$sp_quick_scan, match_info, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      index := index + 1;
      IF match_info.result = clc$sp_success THEN
        IF return_selected_indices THEN
          clp$make_integer_value (index, 10, FALSE, work_area, node^.element_value);
        IFEND;
        result_node^ := node;
        result_node := ^node^.link;
      IFEND;
      node := node^.link;
    WHILEND;

    IF result <> NIL THEN
      result_node^ := NIL;
      result^.generated_via_list_rest := FALSE;
    ELSE
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

  PROCEND clp$$select_wild_card_files;
?? TITLE := 'clp$$source', EJECT ??

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

{  FUNCTION (osm$source) $source

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [87, 12, 9, 9, 43, 32, 948], clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$SOURCE']];

?? POP ??

    VAR
      command_source_flavor: amt$local_file_name,
      kind: clt$data_kind,
      source: fst$path,
      source_size: fst$path_size;


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

    command_source_flavor := '$SOURCE';
    find_command_source (command_source_flavor, source, source_size, kind, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE kind OF
    = clc$name =
      clp$make_name_value (source (1, source_size), work_area, result);
    = clc$file =
      clp$make_file_value (source (1, source_size), work_area, result);
    CASEND;
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$source;
?? TITLE := 'clp$$source_of_caller', EJECT ??

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

{  FUNCTION (osm$source_of_caller) $source_of_caller

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [87, 12, 9, 9, 43, 32, 948], clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$SOURCE_OF_CALLER']];

?? POP ??

    VAR
      command_source_flavor: amt$local_file_name,
      kind: clt$data_kind,
      source: fst$path,
      source_size: fst$path_size;


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

    command_source_flavor := '$SOURCE_OF_CALLER';
    find_command_source (command_source_flavor, source, source_size, kind, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE kind OF
    = clc$name =
      clp$make_name_value (source (1, source_size), work_area, result);
    = clc$file =
      clp$make_file_value (source (1, source_size), work_area, result);
    CASEND;
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$source_of_caller;
?? TITLE := 'clp$$up', EJECT ??

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

{ FUNCTION (osm$up) $up (
{   path: file = $WORKING_CATALOG
{   )

?? 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,
        default_value: string (16),
      recend,
    recend := [
    [1,
    [90, 4, 3, 14, 0, 9, 636],
    clc$function, 1, 1, 0, 0, 0, 0, 0, 'OSM$UP'], [
    ['PATH                           ',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, 3,
  clc$optional_default_parameter, 0, 16]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$WORKING_CATALOG']];

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

    CONST
      p$path = 1;

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

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      path: fst$path,
      path_size: fst$path_size;


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

    clp$evaluate_file_reference (pvt [p$path].value^.file_value^,
          $clt$file_ref_parsing_options [clc$command_file_ref_allowed], FALSE, evaluated_file_reference,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$remove_last_path_element (evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    evaluated_file_reference.cycle_reference.specification := fsc$cycle_omitted;
    clp$convert_file_ref_to_string (evaluated_file_reference, FALSE, path, path_size, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_file_value (path (1, path_size), work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$up;
?? TITLE := 'clp$$user', EJECT ??

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

{ FUNCTION (osm$user) $user

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [90, 4, 3, 14, 0, 18, 122],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$USER']];

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

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

    clp$make_value (clc$file, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;
    NEXT result^.file_value: [2 + clv$user_identification.family.size + clv$user_identification.user.size] IN
          work_area;
    IF result^.file_value = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

    result^.file_value^ (1) := ':';
    result^.file_value^ (2, * ) := clv$user_identification.family.
          value (1, clv$user_identification.family.size);
    result^.file_value^ (2 + clv$user_identification.family.size) := '.';
    result^.file_value^ (3 + clv$user_identification.family.size, * ) :=
          clv$user_identification.user.value (1, clv$user_identification.user.size);

  PROCEND clp$$user;
?? TITLE := 'clp$$vsn_list', EJECT ??

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

{ FUNCTION (osm$$vsnl) $vsn_list (
{   starting_vsn: any of
{       string 1..6
{       name 1..6
{     anyend = $required
{   vsn_count: integer 1..11881376 = $required
{   increment_scheme: key
{       (alphabetic, a)
{       (decimal, d)
{     keyend = decimal
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (7),
      recend,
    recend := [
    [1,
    [90, 4, 3, 14, 0, 31, 343],
    clc$function, 3, 3, 2, 0, 0, 0, 0, 'OSM$$VSNL'], [
    ['INCREMENT_SCHEME               ',clc$nominal_entry, 3],
    ['STARTING_VSN                   ',clc$nominal_entry, 1],
    ['VSN_COUNT                      ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, 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, 33, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, 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, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [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, 155,
  clc$optional_default_parameter, 0, 7]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [1, 6, FALSE]],
    5, [[1, 0, clc$name_type], [1, 6]]
    ],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, 11881376, 10]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ALPHABETIC                     ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['DECIMAL                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'decimal']];

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

    CONST
      p$starting_vsn = 1,
      p$vsn_count = 2,
      p$increment_scheme = 3;

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

    CONST
      max_vsn_size = 6;

    VAR
      max_char: char,
      min_char: char,
      node: ^clt$data_value,
      vsn_count: integer,
      vsn_index: integer,
      vsn_size: 0 .. max_vsn_size,
      work_char_location: 0 .. max_vsn_size,
      work_vsn: string (max_vsn_size);

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

    IF pvt [p$increment_scheme].value^.keyword_value (1) = 'D' THEN
      min_char := '0';
      max_char := '9';
    ELSE
      min_char := 'A';
      max_char := 'Z';
    IFEND;

    IF pvt [p$starting_vsn].value^.kind = clc$name THEN
      work_vsn := pvt [p$starting_vsn].value^.name_value;
    ELSE
      #TRANSLATE (osv$lower_to_upper, pvt [p$starting_vsn].value^.string_value^, work_vsn);
    IFEND;

    vsn_size := clp$trimmed_string_size (work_vsn);
    vsn_count := pvt [p$vsn_count].value^.integer_value.value;
    work_char_location := vsn_size;

    clp$make_list_value (work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;
    node := result;

    IF (work_vsn (work_char_location) < min_char) OR (work_vsn (work_char_location) > max_char) THEN

{
{ Return empty list.
{

      RETURN;
    IFEND;

  /make_vsn_list/
    FOR vsn_index := 1 TO vsn_count DO
      clp$make_string_value (work_vsn (1, vsn_size), work_area, node^.element_value);
      IF node^.element_value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT /make_vsn_list/;
      IFEND;

      WHILE work_vsn (work_char_location) = max_char DO
        work_vsn (work_char_location) := min_char;
        work_char_location := work_char_location - 1;
        IF (work_char_location <= 0) OR (work_vsn (work_char_location) < min_char) OR
              (work_vsn (work_char_location) > max_char) THEN
          EXIT /make_vsn_list/;
        IFEND;
      WHILEND;

      work_vsn (work_char_location) := $CHAR ($INTEGER (work_vsn (work_char_location)) + 1);
      work_char_location := vsn_size;

      IF vsn_index < vsn_count THEN
        clp$make_list_value (work_area, node^.link);
        IF node^.link = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          EXIT /make_vsn_list/;
        IFEND;
        node := node^.link;
      IFEND;
    FOREND /make_vsn_list/;

  PROCEND clp$$vsn_list;
?? TITLE := 'clp$$wild_card_files', EJECT ??

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

{ FUNCTION (osm$$wcf) $wild_card_files, $wild_card_file, $wcf (
{   files: (wild_card_file) application = $required
{   options: list rest of key
{       (include_catalogs, ic)
{       (include_files, if)
{     keyend = include_catalogs include_files
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        name: string (14),
        qualifier: clt$application_type_qualifier,
      recend,
      type2: 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 .. 4] of clt$keyword_specification,
        recend,
        default_value: string (30),
      recend,
    recend := [
    [1,
    [90, 4, 3, 14, 0, 47, 751],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$WCF'], [
    ['FILES                          ',clc$nominal_entry, 1],
    ['OPTIONS                        ',clc$nominal_entry, 2]],
    [
{ 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, 18, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, 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, 171,
  clc$optional_default_parameter, 0, 30]],
{ PARAMETER 1
    [[1, 14, clc$application_type], 'WILD_CARD_FILE', [FALSE]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [155, 1, clc$max_list_size, 0, FALSE, TRUE],
      [[1, 0, clc$keyword_type], [4], [
      ['IC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['IF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['INCLUDE_CATALOGS               ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['INCLUDE_FILES                  ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ]
    ,
    'include_catalogs include_files']];

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

    CONST
      p$files = 1,
      p$options = 2;

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

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      expansion_option: clt$wc_file_expansion_option,
      include_catalogs: boolean,
      include_files: boolean,
      ignore_tail: ^clt$data_value,
      option_node: ^clt$data_value;


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

    clp$evaluate_file_reference (pvt [p$files].value^.application_value^,
          $clt$file_ref_parsing_options [clc$multiple_reference_allowed], FALSE, evaluated_file_reference,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    include_catalogs := FALSE;
    include_files := FALSE;
    option_node := pvt [p$options].value;
    WHILE option_node <> NIL DO
      IF option_node^.element_value^.keyword_value = 'INCLUDE_CATALOGS' THEN
        include_catalogs := TRUE;
      ELSE { INCLUDE_FILES }
        include_files := TRUE;
      IFEND;
      option_node := option_node^.link;
    WHILEND;

    IF include_catalogs THEN
      IF include_files THEN
        expansion_option := clc$wcfe_files_and_catalogs;
      ELSE
        expansion_option := clc$wcfe_only_catalogs;
      IFEND;
    ELSE
      expansion_option := clc$wcfe_only_files;
    IFEND;

    clp$wild_card_file_expansion (evaluated_file_reference, expansion_option, work_area, result, ignore_tail,
          status);
    IF NOT status.normal AND (status.condition = cle$no_match_for_wild_card_file) THEN
      status.normal := TRUE;
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

  PROCEND clp$$wild_card_files;
?? TITLE := 'clp$$working_catalog', EJECT ??

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

{ FUNCTION (osm$$wc) $working_catalog, $catalog, $wc

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [90, 4, 3, 14, 1, 1, 673],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$WC']];

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

    VAR
      path: fst$path,
      path_size: fst$path_size,
      working_catalog: ^^clt$working_catalog;

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

    clp$find_working_catalog (working_catalog);
    bap$get_path_string (working_catalog^^.evaluated_file_reference.path_handle_info.path_handle, path,
          path_size, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_file_value (path (1, path_size), work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$working_catalog;
?? TITLE := 'make_empty_list', EJECT ??

  PROCEDURE make_empty_list
    (VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    clp$make_list_value (work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND make_empty_list;

MODEND clm$file_functions;

*DECK DECK=CLM$FILE_REFERENCE_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : File Reference Manager' ??
MODULE clm$file_reference_manager;

{
{ PURPOSE:
{   This module contains the procedures that deal with file references, path names, and permanent file
{   management parameters.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$path_description
*copyc cle$ecc_command_processing
*copyc cle$ecc_file_reference
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_parsing
*copyc cle$no_cyc_expr_with_wild_card
*IF $true(osv$unix)
*copyc cle$not_supported
*IFEND
*copyc cle$up_cant_follow_wild_card
*copyc cle$wild_card_cant_be_first
*copyc cle$wild_card_not_allowed
*copyc clk$convert_string_to_file
*copyc clk$get_path_description
*copyc clk$get_working_catalog
*copyc clk$set_working_catalog
*copyc clt$file
*copyc clt$file_ref_parsing_options
*copyc clt$file_reference
*copyc clt$lexical_unit_kinds
*copyc clt$parsed_path
*copyc clt$source
*copyc fme$file_management_errors
*copyc fmt$path_handle
*copyc fsc$local
*copyc fse$path_exception_conditions
*copyc fst$cycle_reference
*copyc fst$evaluated_file_reference
*copyc fst$file_reference
*copyc fst$goi_object_information
*copyc fst$goi_object_list
*IF $true(osv$unix)
*copyc fst$open_position
*IFEND
*copyc fst$parsed_file_reference
*copyc fst$path
*IF $true(osv$unix)
*copyc fst$path_element_index
*copyc fst$path_element_size
*IFEND
*copyc fst$path_element_string
*IF $true(osv$unix)
*copyc fst$path_index
*IFEND
*copyc fst$path_size
*IF $true(osv$unix)
*copyc ose$unix_system_error
*copyc clp_getcwd
*copyc clp_getenv
*copyc clp$evaluate_parameters
*copyc clt$working_catalog
*copyc osp$set_status_from_errno
*IFEND
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc ost$caller_identifier
*copyc ost$name_reference
*copyc ost$status
*copyc ost$status_message_level
?? POP ??
*IF NOT $true(osv$unix)
*copyc bap$get_path_elements
*copyc bap$get_path_string
*copyc bap$get_resolved_file_reference
*copyc bap$process_pt_request
*IFEND
*copyc clp$append_status_parse_state
*copyc clp$append_status_type_desc
*copyc clp$append_status_value_type
*copyc clp$check_name_for_path_handle
*copyc clp$construct_block_handle_name
*copyc clp$construct_path_handle_name
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_integer
*copyc clp$convert_string_to_name
*copyc clp$evaluate_name
*copyc clp$evaluate_unsigned_decimal
*copyc clp$find_caller_input_block
*copyc clp$find_command_input_block
*copyc clp$find_current_block
*IF NOT $true(osv$unix)
*copyc clp$find_scl_options
*copyc clp$find_working_catalog
*copyc clp$get_fs_path_elements
*IFEND
*copyc clp$get_work_area
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*IF $true(osv$unix)
*copyc clp$make_a_file_value
*IFEND
*copyc clp$make_application_value
*copyc clp$make_file_value
*copyc clp$make_unspecified_value
*copyc clp$remove_last_path_element
*IF NOT $true(osv$unix)
*copyc clp$rescan_wild_card_lex_unit
*IFEND
*copyc clp$scan_argument_list
*copyc clp$scan_any_lexical_unit
*copyc clp$scan_non_space_lexical_unit
*IF NOT $true(osv$unix)
*copyc clp$scan_wild_card_lexical_unit
*IFEND
*copyc clp$set_working_catalog_path
*copyc clp$trimmed_string_size
*copyc clp$validate_name
*copyc clp$wild_card_file_expansion
*copyc clv$negative_infinity
*copyc clv$positive_infinity
*copyc clv$standard_files
*copyc clv$unique_name
*copyc clv$user_identification
*copyc clv$value_descriptors
*copyc fsp$convert_fs_structure_to_pf
*copyc fsp$path_element
*copyc fsv$evaluated_file_reference
*copyc i#compare_collated
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*IF NOT $true(osv$unix)
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*IFEND
*copyc osp$find_status_message_level
*IF NOT $true(osv$unix)
*copyc osp$generate_log_message
*IFEND
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osv$lower_to_upper
*IF NOT $true(osv$unix)
*copyc osv$initial_exception_context
*copyc pfp$get_object_information
*copyc pmp$log
*IFEND

{
{ PURPOSE:
{   The following procedure exists solely to provide a "shelter" for the
{   declarations contained in certain decks that are *COPYC'd into this
{   deck.  For example, this module defines an XDCL'd variable that is
{   referenced by an INLINE procedure.  In order to make the deck containing
{   the INLINE procedure "self-contained" it *COPYCs the deck containing the
{   XREF declaration of the variable.  Since the INLINE procedure is needed
{   in this module, both the XDCL and XREF declaration will appear in this
{   module.  The following "dummy" procedure is used to hide the XREF
{   declaration of the variable form the rest of the module.
{

  PROCEDURE [INLINE] dummy;

*copyc clv$open_position_designator

  PROCEND dummy;
*IF NOT $true(osv$unix)
*copyc clp$convert_file_ref_to_string
?? TITLE := 'clp$check_valid_catalog', EJECT ??
*copyc clp$check_valid_catalog
*ELSE
?? TITLE := 'clv$open_position_designator', EJECT ??
*IFEND

  VAR
    clv$open_position_designator: [XDCL, #GATE, READ, oss$job_paged_literal] array [amt$open_position] of
          record
      size: 4 .. 5,
      value: string (5),
    recend := [[5, '$ASIS'], [4, '$BOI'], [4, '$BOP'], [4, '$EOI']];

?? TITLE := 'check_for_special_path_element', EJECT ??

  TYPE
*IF NOT $true(osv$unix)
    clt$special_path_elements = (clc$not_a_special_path_element, clc$current_family_path_element,
*ELSE
    clt$special_path_element_kind = (clc$not_a_special_path_element, clc$current_family_path_element,
*IFEND
          clc$local_catalog_path_element, clc$system_path_element, clc$current_user_path_element,
          clc$command_file_path_element, clc$cycle_path_element, clc$position_path_element,
          clc$job_file_path_element, clc$standard_file_path_element, clc$defer_eval_path_element,
          clc$source_path_element, clc$reversal_path_element, clc$workin_catalog_path_element,
*IF NOT $true(osv$unix)
          clc$unsupported_path_element, clc$var_or_fcn_cyc_path_element, clc$traversal_path_element);
*ELSE
          clc$unsupported_path_element, clc$var_or_fcn_cyc_path_element, clc$traversal_path_element,
          clc$no_cycle_path_element, clc$no_position_path_element);
*IFEND

  TYPE
    clt$special_path_element = record
*IF NOT $true(osv$unix)
      case kind: clt$special_path_elements of
*ELSE
      case kind: clt$special_path_element_kind of
*IFEND
      = clc$current_family_path_element .. clc$command_file_path_element,
*IF NOT $true(osv$unix)
            clc$defer_eval_path_element .. clc$traversal_path_element =
*ELSE
            clc$defer_eval_path_element .. clc$traversal_path_element, clc$no_cycle_path_element,
            clc$no_position_path_element =
*IFEND
        ,
      = clc$job_file_path_element, clc$standard_file_path_element =
        standard_file: clt$standard_files,
      = clc$cycle_path_element =
        cycle_reference: fst$cycle_reference,
      = clc$position_path_element =
        position: amt$open_position,
      casend,
    recend;

  CONST
*IF NOT $true(osv$unix)
    min_special_path_element_size = 3 {$UP} ,
    max_special_path_element_size = 18 {$COMMAND_OF_CALLER} ,
    number_of_special_path_elements = 37;
*ELSE
    min_special_path_element_size = 3 {$UP,$WC,$WD} ,
    max_special_path_element_size = 18 {$COMMAND_OF_CALLER,$WORKING_DIRECTORY} ,
    number_of_special_path_elements = 10;
*IFEND

  TYPE
*IF NOT $true(osv$unix)
    clt$new_path_name_elements = set of clt$special_path_elements;
*ELSE
    clt$special_path_element_kinds = set of clt$special_path_element_kind;
*IFEND

  VAR
    table: [STATIC, READ, oss$job_paged_literal] array [1 .. number_of_special_path_elements] of record
      name: string (max_special_path_element_size),
      element: clt$special_path_element,
    recend := [
*IF NOT $true(osv$unix)
          {} ['$ALL              ', [clc$traversal_path_element]],
          {} ['$ASIS             ', [clc$position_path_element, amc$open_no_positioning]],
          {} ['$BOI              ', [clc$position_path_element, amc$open_at_boi]],
          {} ['$BOP              ', [clc$position_path_element, amc$open_at_bop]],
*IFEND
          {} ['$COMMAND          ', [clc$command_file_path_element]],
          {} ['$COMMAND_OF_CALLER', [clc$command_file_path_element]],
*IF NOT $true(osv$unix)
          {} ['$DEFER            ', [clc$defer_eval_path_element]],
          {} ['$ECHO             ', [clc$standard_file_path_element, clc$sf_echo_file]],
          {} ['$EOI              ', [clc$position_path_element, amc$open_at_eoi]],
*IFEND
          {} ['$ERRORS           ', [clc$standard_file_path_element, clc$sf_error_file]],
*IF NOT $true(osv$unix)
          {} ['$FAMILY           ', [clc$current_family_path_element]],
          {} ['$HIGH             ', [clc$cycle_path_element, [fsc$high_cycle]]],
*IFEND
          {} ['$INPUT            ', [clc$standard_file_path_element, clc$sf_standard_input_file]],
*IF NOT $true(osv$unix)
          {} ['$JOB              ', [clc$local_catalog_path_element]],
          {} ['$JOB_LOG          ', [clc$job_file_path_element, clc$sf_job_log_file]],
          {} ['$JOB_MESSAGE      ', [clc$unsupported_path_element]],
          {} ['$LIST             ', [clc$standard_file_path_element, clc$sf_list_file]],
*IFEND
          {} ['$LOCAL            ', [clc$local_catalog_path_element]],
*IF NOT $true(osv$unix)
          {} ['$LOW              ', [clc$cycle_path_element, [fsc$low_cycle]]],
          {} ['$NEXT             ', [clc$cycle_path_element, [fsc$next_cycle]]],
*IFEND
          {} ['$NULL             ', [clc$job_file_path_element, clc$sf_null_file]],
          {} ['$OUTPUT           ', [clc$standard_file_path_element, clc$sf_standard_output_file]],
*IF NOT $true(osv$unix)
          {} ['$PROCEDURE        ', [clc$unsupported_path_element]],
          {} ['$RESPONSE         ', [clc$standard_file_path_element, clc$sf_response_file]],
          {} ['$SOURCE           ', [clc$source_path_element]],
          {} ['$SOURCE_OF_CALLER ', [clc$source_path_element]],
          {} ['$SYSTEM           ', [clc$system_path_element]],
          {} ['$TASK             ', [clc$unsupported_path_element]],
          {} ['$TERMINAL         ', [clc$job_file_path_element, clc$sf_terminal_file]],
          {} ['$UP               ', [clc$reversal_path_element]],
          {} ['$USER             ', [clc$current_user_path_element]],
          {} ['$UTILITY          ', [clc$unsupported_path_element]],
          {} ['$WC               ', [clc$workin_catalog_path_element]],
          {} ['$WORKING_CATALOG  ', [clc$workin_catalog_path_element]],
*IFEND
          {} ['COMMAND           ', [clc$job_file_path_element, clc$sf_command_file]],
          {} ['INPUT             ', [clc$job_file_path_element, clc$sf_job_input_file]],
          {} ['OUTPUT            ', [clc$job_file_path_element, clc$sf_job_output_file]]];

?? SKIP := 4 ??

  PROCEDURE [INLINE] check_for_special_path_element
    (    element_name: fst$path_element_name;
         element_size: fst$path_element_size;
     VAR element: clt$special_path_element);

    VAR
      current_index: 1 .. number_of_special_path_elements,
      high_index: 0 .. number_of_special_path_elements,
      temp: integer,
      low_index: 1 .. number_of_special_path_elements + 1;

    element.kind := clc$not_a_special_path_element;
    CASE element_name (1) OF
    = '$' =
      IF (min_special_path_element_size <= element_size) AND
            (element_size <= max_special_path_element_size) THEN
        low_index := 1;
        high_index := number_of_special_path_elements - 3;
        REPEAT
          temp := low_index + high_index;
          current_index := temp DIV 2;
          IF element_name = table [current_index].name THEN
            element := table [current_index].element;
          ELSEIF element_name < table [current_index].name THEN
            high_index := current_index - 1;
          ELSE
            low_index := current_index + 1;
          IFEND;
        UNTIL (low_index > high_index) OR (element.kind <> clc$not_a_special_path_element);
      IFEND;
    = 'C' =
      IF element_name = table [number_of_special_path_elements - 2].name THEN
        element := table [number_of_special_path_elements - 2].element;
      IFEND;
    = 'I' =
      IF element_name = table [number_of_special_path_elements - 1].name THEN
        element := table [number_of_special_path_elements - 1].element;
      IFEND;
    = 'O' =
      IF element_name = table [number_of_special_path_elements].name THEN
        element := table [number_of_special_path_elements].element;
      IFEND;
    ELSE
    CASEND;

  PROCEND check_for_special_path_element;
*IF NOT $true(osv$unix)
?? TITLE := 'check_for_valid_new_file_name', EJECT ??

  PROCEDURE [INLINE] check_for_valid_new_file_name
    (    file_name: amt$local_file_name;
     VAR name_is_valid_new_file_name: boolean);

    VAR
      element: clt$special_path_element,
      name_size: fst$path_element_size;

    name_size := clp$trimmed_string_size (file_name);
    check_for_special_path_element (file_name, name_size, element);
    name_is_valid_new_file_name := element.kind IN $clt$new_path_name_elements
          [clc$not_a_special_path_element, clc$job_file_path_element, clc$standard_file_path_element,
          clc$system_path_element];

  PROCEND check_for_valid_new_file_name;
?? TITLE := 'clp$validate_new_file_name', EJECT ??

  PROCEDURE [XDCL] clp$validate_new_file_name
    (    file_name: string ( * <= fsc$max_path_element_size);
     VAR validated_file_name: ost$name;
     VAR name_is_valid_new_file_name: boolean);

    VAR
      path_handle: clt$path_handle;

    clp$validate_name (file_name, validated_file_name, name_is_valid_new_file_name);
    IF name_is_valid_new_file_name THEN
      clp$check_name_for_path_handle (validated_file_name, path_handle);
      IF path_handle.kind = clc$not_a_path_handle THEN
        check_for_valid_new_file_name (validated_file_name, name_is_valid_new_file_name);
      ELSE
        name_is_valid_new_file_name := FALSE;
      IFEND;
    IFEND;

  PROCEND clp$validate_new_file_name;
?? TITLE := 'clp$validate_new_lfn', EJECT ??

  PROCEDURE [XDCL] clp$validate_new_lfn
    (    local_file_name: string ( * <= fsc$max_path_element_size);
     VAR validated_local_file_name: ost$name;
     VAR name_is_valid_new_lfn: boolean);

    clp$validate_name (local_file_name, validated_local_file_name, name_is_valid_new_lfn);
    IF name_is_valid_new_lfn THEN
      check_for_valid_new_file_name (validated_local_file_name, name_is_valid_new_lfn);
    IFEND;

  PROCEND clp$validate_new_lfn;
*IFEND
?? TITLE := 'clp$find_command_source', EJECT ??

  PROCEDURE [XDCL] clp$find_command_source
    (    file_name: amt$local_file_name;
     VAR block: ^clt$block);

    clp$find_current_block (block);
    IF file_name = '$SOURCE_OF_CALLER' THEN
*IF NOT $true(osv$unix)
      WHILE (block <> NIL) AND (block^.kind <> clc$command_proc_block) AND
            (block^.kind <> clc$function_proc_block) DO
*ELSE
      WHILE (block <> NIL) DO
*IFEND
        IF block^.kind = clc$task_block THEN
          IF NOT block^.synchronous_with_parent THEN
            IF block^.command_file = osc$null_name THEN
              block := NIL;
            IFEND;
            RETURN;
          IFEND;
        IFEND;
        block := block^.previous_block;
      WHILEND;
      IF block <> NIL THEN
        block := block^.previous_block;
      IFEND;
    IFEND;

  /search/
    WHILE block <> NIL DO
      CASE block^.kind OF
      = clc$command_block =
        CASE block^.command_kind OF
        = clc$command_is_include_file, clc$command_is_include_line =
          ;
        ELSE
          EXIT /search/;
        CASEND;
*IF NOT $true(osv$unix)
      = clc$command_proc_block, clc$function_proc_block =
        EXIT /search/;
      = clc$function_block =
        IF block^.source.kind <> clc$system_commands THEN
          EXIT /search/;
        IFEND;
*IFEND
      ELSE
        ;
      CASEND;
      block := block^.previous_block;
    WHILEND /search/;

  PROCEND clp$find_command_source;
*IF NOT $true(osv$unix)
?? TITLE := 'process_pt_request', EJECT ??

  PROCEDURE process_pt_request
    (    work_list: bat$process_pt_work_list;
         local_file_name: amt$local_file_name;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR process_pt_results: bat$process_pt_results;
     VAR status {input, output} : ost$status);

    VAR
      context: ^ost$ecp_exception_context;

    PUSH context;
    context^ := osv$initial_exception_context;
    context^.file.selector := osc$ecp_evaluated_file_ref;
    context^.file.evaluated_file_reference := evaluated_file_reference;
    REPEAT
      context^.condition_status := status;
      osp$enforce_exception_policies (context^);
      status := context^.condition_status;

      IF (NOT osp$file_access_condition (status)) OR (NOT context^.wait) THEN
        RETURN;
      ELSE
        bap$process_pt_request (work_list, local_file_name, evaluated_file_reference, process_pt_results,
              status);
      IFEND;
    UNTIL status.normal;

  PROCEND process_pt_request;
?? TITLE := 'set and log', EJECT ??

  PROCEDURE [INLINE] set_and_log
    (    procedure_name: ost$name_reference;
         text: string ( * ));

    VAR
      status: ost$status,
      ignore_status: ost$status;

    osp$set_status_abnormal ('CL', fme$system_error, text, status);
    osp$append_status_parameter ($CHAR (32), procedure_name, status);
    osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);

  PROCEND set_and_log;
?? TITLE := 'translate_error', EJECT ??

  PROCEDURE translate_error
    (    procedure_name: ost$name_reference;
     VAR status: {input, output} ost$status);

    VAR
      ignore_status: ost$status;

    osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
    set_and_log (procedure_name, 'bap$process_pt_request returned bad status in');
    osp$set_status_condition (cle$system_error, status);

  PROCEND translate_error;
?? TITLE := 'process_status', EJECT ??

  PROCEDURE process_status
    (    path_handle_info: fst$path_handle_info;
         path_resolution: fst$path_resolution;
         procedure_name: ost$name_reference;
     VAR status: {input, output} ost$status);

    IF status.normal THEN
      IF (NOT path_handle_info.path_handle_present) OR (path_handle_info.path_handle.segment_offset = 0) THEN
        set_and_log (procedure_name, 'bap$process_pt_request returned invalid path handle in');
        osp$set_status_condition (cle$system_error, status);
        RETURN;
      IFEND;
    ELSEIF status.condition = fme$system_error THEN
      translate_error (procedure_name, status);
      RETURN;
    ELSEIF (NOT path_handle_info.path_handle_present) OR (path_handle_info.path_handle.segment_offset = 0)
          THEN
      RETURN;
    ELSEIF path_resolution = fsc$path_resolution_error THEN
      status.normal := TRUE;
    ELSE
      RETURN;
    IFEND;

  PROCEND process_status;
*IFEND
?? TITLE := 'clp$evaluate_file_reference', EJECT ??
*copyc clh$evaluate_file_reference

  PROCEDURE [XDCL, #GATE] clp$evaluate_file_reference
    (    file: fst$file_reference;
         file_reference_parsing_options: clt$file_ref_parsing_options;
         resolve_cycle_number: boolean;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
    VAR
      ignore_pt_results: bat$process_pt_results,
      work_list: bat$process_pt_work_list;
*IFEND


    status.normal := TRUE;

    clp$setup_and_parse_file_ref (file, file_reference_parsing_options, clv$user_identification,
          evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    IF resolve_cycle_number AND (evaluated_file_reference.cycle_reference.specification <>
          fsc$cycle_omitted) AND (evaluated_file_reference.cycle_reference.specification <> fsc$cycle_number)
          THEN
      work_list := $bat$process_pt_work_list [bac$record_path, bac$resolve_path, bac$resolve_to_catalog];
      bap$process_pt_request (work_list, osc$null_name, evaluated_file_reference, ignore_pt_results, status);
      IF NOT status.normal THEN
        IF osp$file_access_condition (status) THEN
          process_pt_request (work_list, osc$null_name, evaluated_file_reference, ignore_pt_results, status);
        IFEND;
        IF evaluated_file_reference.path_resolution <> fsc$path_resolution_error THEN
          translate_error ('clp$evaluate_file_reference', status);
        IFEND;
      IFEND;
    IFEND;
*IFEND

  PROCEND clp$evaluate_file_reference;
?? TITLE := 'clp$complete_file_ref_eval', EJECT ??
*copyc clh$complete_file_ref_eval

  PROCEDURE [XDCL] clp$complete_file_ref_eval
*IF NOT $true(osv$unix)
    (    multiple_reference_allowed: boolean;
*ELSE
    (    unix_path: boolean;
         multiple_reference_allowed: boolean;
*IFEND
         defer_expansion: boolean;
         encode_file_values: boolean;
     VAR initial_path {input, output} : ^fst$file_reference;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR result_sub_list_tail: ^clt$data_value;
     VAR status: ost$status);

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
*IF $true(osv$unix)
      first_delimiter: clt$lexical_unit_kind,
*IFEND
      ignore_command_name: clt$name,
      ignore_form: clt$command_reference_form,
*IF NOT $true(osv$unix)
      ignore_pt_results: bat$process_pt_results,
*IFEND
      local_parse: clt$parse_state,
      node: ^clt$data_value,
      parameter_name: clt$parameter_name,
      parsing_options: clt$file_ref_parsing_options,
      path_handle_name: fst$path_handle_name,
      path_handle_name_size: ost$name_size,
      path_name: fst$path,
      path_name_size: fst$path_size,
      path_parsed: boolean,
*IF NOT $true(osv$unix)
      work_list: bat$process_pt_work_list;
*ELSE
      result_kind: clt$data_kind;
*IFEND


    status.normal := TRUE;
    result_sub_list_tail := NIL;
    result := NIL;

    IF multiple_reference_allowed THEN
      parsing_options := $clt$file_ref_parsing_options [clc$multiple_reference_allowed,
            clc$command_file_ref_allowed];
    ELSE
      parsing_options := $clt$file_ref_parsing_options [clc$command_file_ref_allowed];
    IFEND;

*IF $true(osv$unix)
    IF unix_path THEN
      parsing_options := parsing_options + $clt$file_ref_parsing_options [clc$unix_path_syntax];
      first_delimiter := clc$lex_divide;
    ELSE
      first_delimiter := clc$lex_colon;
    IFEND;

*IFEND
  /parse_file_reference/
    BEGIN
      IF NOT encode_file_values THEN
        parsing_options := parsing_options + $clt$file_ref_parsing_options [clc$file_ref_evaluation_stage];
*IF NOT $true(osv$unix)
        IF (parse.unit.kind = clc$lex_colon) AND clp$file_ref_is_pre_evaluated
              ($clt$file_ref_parsing_options [], parse) THEN
          local_parse := parse;
          clp$parse_file_reference (local_parse, path_parsed, evaluated_file_reference, status);
          IF (NOT status.normal) OR path_parsed THEN
            parameter_name := osc$null_name;
            parse := local_parse;
            EXIT /parse_file_reference/;
          IFEND;
        IFEND;
*IFEND
      IFEND;
      clp$complete_file_ref_parse (initial_path, parse, work_area, parsing_options, clv$user_identification,
            evaluated_file_reference, ignore_command_name, ignore_form, parameter_name, status);
    END /parse_file_reference/;

    IF NOT status.normal THEN
      RETURN;
    ELSEIF parameter_name <> osc$null_name THEN
      clp$make_unspecified_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_condition (cle$work_area_overflow, status);
      IFEND;
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    IF (NOT evaluated_file_reference.multiple_reference_specified) OR defer_expansion THEN
      IF encode_file_values THEN

        IF evaluated_file_reference.path_resolution = fsc$command_file_path THEN
          clp$construct_block_handle_name (evaluated_file_reference.block_handle, path_handle_name);
        ELSE
          IF NOT evaluated_file_reference.path_handle_info.path_handle_present THEN
            work_list := $bat$process_pt_work_list [bac$externalize_path_handle, bac$record_path];
            IF (evaluated_file_reference.cycle_reference.specification <> fsc$cycle_omitted) AND
                  (evaluated_file_reference.cycle_reference.specification <> fsc$cycle_number) THEN
              work_list := work_list + $bat$process_pt_work_list [bac$resolve_path, bac$resolve_to_catalog];
            IFEND;
            bap$process_pt_request (work_list, osc$null_name, evaluated_file_reference, ignore_pt_results,
                  status);
            IF (NOT status.normal) AND osp$file_access_condition (status) THEN
              process_pt_request (work_list, osc$null_name, evaluated_file_reference, ignore_pt_results,
                    status);
            IFEND;
          IFEND;
          clp$construct_path_handle_name (evaluated_file_reference.path_handle_info.path_handle,
                path_handle_name);
          process_status (evaluated_file_reference.path_handle_info, evaluated_file_reference.path_resolution,
                'clp$complete_file_ref_eval', status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        clp$make_file_value (path_handle_name, work_area, result);

      ELSE
        clp$convert_file_ref_to_string (evaluated_file_reference, TRUE, path_name, path_name_size,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF evaluated_file_reference.multiple_reference_specified AND defer_expansion THEN
          clp$make_application_value (path_name (1, path_name_size), work_area, result);
        ELSE
          clp$make_file_value (path_name (1, path_name_size), work_area, result);
        IFEND;
      IFEND;

      IF result = NIL THEN
        osp$set_status_condition (cle$work_area_overflow, status);
      IFEND;
      RETURN;
    IFEND;

    clp$wild_card_file_expansion (evaluated_file_reference, clc$wcfe_only_files, work_area, result,
          result_sub_list_tail, status);
    IF (NOT status.normal) OR (NOT encode_file_values) THEN
      RETURN;
    IFEND;

    node := result;
    WHILE node <> NIL DO
      clp$convert_str_to_path_handle (node^.element_value^.file_value^, FALSE, FALSE, TRUE, path_handle_name,
            evaluated_file_reference, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      path_handle_name_size := clp$trimmed_string_size (path_handle_name);
      IF STRLENGTH (node^.element_value^.file_value^) >= path_handle_name_size THEN
        node^.element_value^.file_value := ^node^.element_value^.file_value^ (1, path_handle_name_size);
      ELSE
        NEXT node^.element_value^.file_value: [path_handle_name_size] IN work_area;
        IF node^.element_value^.file_value = NIL THEN
          osp$set_status_condition (cle$work_area_overflow, status);
          RETURN;
        IFEND;
      IFEND;
      node^.element_value^.file_value^ (1, path_handle_name_size) :=
            path_handle_name (1, path_handle_name_size);

      node := node^.link;
    WHILEND;
*ELSE
    IF evaluated_file_reference.standard_file OR evaluated_file_reference.command_file_path.found THEN
      result_kind := clc$nos_ve_file;
      clp$convert_file_ref_to_string (evaluated_file_reference, TRUE, path_name, path_name_size, status);
    ELSE
      result_kind := clc$unix_file;
      clp$conv_unix_file_ref_to_str (evaluated_file_reference, path_name, path_name_size, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_a_file_value (result_kind, path_name (1, path_name_size), work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;
*IFEND

  PROCEND clp$complete_file_ref_eval;
?? TITLE := 'clp$parse_file_reference', EJECT ??
*IF NOT $true(osv$unix)
*copyc clh$parse_file_reference

  PROCEDURE [XDCL] clp$parse_file_reference
    (VAR parse {input, output} : clt$parse_state;
*ELSE

{
{   This request is used to parse a "pre-evaluated" file reference.
{
{       CLP$PARSE_FILE_REFERENCE (UNIX_PATH, PARSE, PATH_PARSED,
{         EVALUATED_FILE_REFERENCE, STATUS)
{
{ UNIX_PATH: (input)  This option specifies whether the file reference's syntax
{       is that of a UNIX path (TRUE) or a NOS/VE path (FALSE).
{
{ PARSE: (input, output)  This parameter specifies the file expression to be
{       evaluated.
{
{ PATH_PARSED: (output)  This parameter designates whether the file reference
{       had the correct syntax and was consequently successfully parsed.
{
{ EVALUATED_FILE_REFERENCE: (output)  This parameter specifies the information
{       resulting from the evaluation of the file reference.
{
{ STATUS: (output) This parameter specifies the request status.
{

  PROCEDURE clp$parse_file_reference
    (    unix_path: boolean;
     VAR parse {input, output} : clt$parse_state;
*IFEND
     VAR path_parsed {output} : boolean;
     VAR evaluated_file_reference {output} : fst$evaluated_file_reference;
     VAR status: ost$status);

*IF $true(osv$unix)
    VAR
      cycle_element_found: boolean,
      element_index: clt$string_index,
      element_name: fst$path_element_name,
      element_size: fst$path_element_size,
      number: integer;

*IFEND
?? NEWTITLE := 'append_element', EJECT ??

    PROCEDURE [INLINE] append_element
      (    size: fst$path_element_size;
           name: fst$path_element_string);


      evaluated_file_reference.path_structure (evaluated_file_reference.path_structure_size + 1) :=
            $CHAR (size);
      evaluated_file_reference.path_structure (evaluated_file_reference.path_structure_size + 2, size) :=
            name;
      evaluated_file_reference.path_structure_size := evaluated_file_reference.path_structure_size + 1 + size;
      evaluated_file_reference.number_of_path_elements := evaluated_file_reference.number_of_path_elements +
            1;

    PROCEND append_element;
?? OLDTITLE, EJECT ??

*IF NOT $true(osv$unix)
    VAR
      cycle_element_found: boolean,
      element_name: fst$path_element_name,
      element_size: fst$path_element_size,
      number: integer;


*IFEND
    status.normal := TRUE;
    path_parsed := FALSE;
    evaluated_file_reference := fsv$evaluated_file_reference;
    cycle_element_found := FALSE;

*IF NOT $true(osv$unix)
    WHILE (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_colon, clc$lex_dot]) DO
      IF (evaluated_file_reference.number_of_path_elements > 0) AND (parse.unit.kind = clc$lex_colon) THEN
        osp$set_status_condition (cle$unexpected_colon_in_path, status);
        RETURN;
      IFEND;

      clp$scan_any_lexical_unit (parse);

*ELSE
    WHILE TRUE DO
*IFEND
      CASE parse.unit.kind OF
*IF $true(osv$unix)
      = clc$lex_colon =
        IF unix_path OR (evaluated_file_reference.number_of_path_elements > 0) THEN
          osp$set_status_condition (cle$unexpected_colon_in_path, status);
          RETURN;
        IFEND;
      = clc$lex_divide =
        IF NOT unix_path THEN
          RETURN;
        IFEND;
      = clc$lex_dot =
        ;
      ELSE
        path_parsed := TRUE;
        RETURN;
      CASEND;

      clp$scan_any_lexical_unit (parse);
      CASE parse.unit.kind OF

      = clc$lex_name, clc$lex_dot =
*ELSE
      = clc$lex_name =
*IFEND
        IF cycle_element_found THEN
          RETURN;
        IFEND;
*IF $true(osv$unix)
        IF unix_path THEN
          element_size := parse.unit.size;
          element_index := parse.unit_index;
          WHILE parse.units_array^ [parse.units_array_index + 1].kind IN
                $clt$lexical_unit_kinds [clc$lex_dot, clc$lex_name] DO
            clp$scan_any_lexical_unit (parse);
            element_size := element_size + parse.unit.size;
          WHILEND;
          element_name := parse.text^ (element_index, element_size);
        ELSE
*IFEND
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), element_name);
*IF $true(osv$unix)
          element_size := parse.unit.size;
        IFEND;
*IFEND
        IF element_name (1) = '$' THEN
          RETURN;
        IFEND;
*IF NOT $true(osv$unix)
        IF (evaluated_file_reference.path_structure_size + 1 + parse.unit.size)
             > fsc$max_path_size THEN
          osp$set_status_abnormal ('CL', cle$file_reference_too_long, '',
                status);
          RETURN;
        IFEND;
        element_size := parse.unit.size;
*IFEND
        append_element (element_size, element_name);

      = clc$lex_unsigned_decimal =
*IF NOT $true(osv$unix)
        IF evaluated_file_reference.number_of_path_elements <= 1 THEN
*ELSE
        IF unix_path THEN
          RETURN;
        ELSEIF evaluated_file_reference.number_of_path_elements <= 1 THEN
*IFEND
          osp$set_status_condition (cle$cycle_must_follow_file_name, status);
          RETURN;
        IFEND;

        clp$evaluate_unsigned_decimal (parse.text^ (parse.unit_index, parse.unit.size), number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
*IF NOT $true(osv$unix)
        IF (number < pfc$minimum_cycle_number) OR (number > pfc$maximum_cycle_number) THEN
          osp$set_status_condition (pfe$bad_cycle_number, status);
          osp$append_status_integer (osc$status_parameter_delimiter, number, 10, FALSE, status);
          RETURN;
        IFEND;

        evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
        evaluated_file_reference.cycle_reference.cycle_number := number;
        cycle_element_found := TRUE;
*IFEND

*IF $true(osv$unix)
      = clc$lex_end_of_line =
        IF unix_path THEN
          path_parsed := TRUE;
        IFEND;
        RETURN;
*IFEND

      ELSE
        RETURN;
      CASEND;

      clp$scan_any_lexical_unit (parse);
      IF parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_concatenate,
            clc$lex_query, clc$lex_multiply, clc$lex_exponentiate, clc$lex_subtract] THEN
        RETURN;
      IFEND;
    WHILEND;

*IF NOT $true(osv$unix)
    path_parsed := TRUE;

*IFEND
  PROCEND clp$parse_file_reference;
?? TITLE := 'clp$complete_file_ref_parse', EJECT ??
*copyc clh$complete_file_ref_parse

  PROCEDURE [XDCL] clp$complete_file_ref_parse
    (VAR initial_path {input, output} : ^fst$file_reference;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
         file_reference_parsing_options: clt$file_ref_parsing_options;
         user_identification: clt$user_identification;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR command_or_program_name: clt$name;
     VAR form: clt$command_reference_form;
     VAR parameter_name: clt$parameter_name;
     VAR status: ost$status);

    TYPE
      chars = set of char;

    VAR
      unique_name_mask: [STATIC, READ, oss$job_paged_literal] string (256) := $CHAR (00) CAT $CHAR (01) CAT
            $CHAR (02) CAT $CHAR (03) CAT $CHAR (04) CAT $CHAR (05) CAT $CHAR (06) CAT $CHAR (07) CAT
            $CHAR (08) CAT $CHAR (09) CAT $CHAR (10) CAT $CHAR (11) CAT $CHAR (12) CAT $CHAR (13) CAT
            $CHAR (14) CAT $CHAR (15) CAT $CHAR (16) CAT $CHAR (17) CAT $CHAR (18) CAT $CHAR (19) CAT
            $CHAR (20) CAT $CHAR (21) CAT $CHAR (22) CAT $CHAR (23) CAT $CHAR (24) CAT $CHAR (25) CAT
            $CHAR (26) CAT $CHAR (27) CAT $CHAR (28) CAT $CHAR (29) CAT $CHAR (30) CAT $CHAR (31) CAT
            ' !"#$%&''()*+,-./9999999999:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_@ABCDEFGHIJKLMNOPQRSTUVWXYZ{|}~'
            CAT $CHAR (127) CAT $CHAR (128) CAT $CHAR (129) CAT $CHAR (130) CAT $CHAR (131) CAT
            $CHAR (132) CAT $CHAR (133) CAT $CHAR (134) CAT $CHAR (135) CAT $CHAR (136) CAT $CHAR (137) CAT
            $CHAR (138) CAT $CHAR (139) CAT $CHAR (140) CAT $CHAR (141) CAT $CHAR (142) CAT $CHAR (143) CAT
            $CHAR (144) CAT $CHAR (145) CAT $CHAR (146) CAT $CHAR (147) CAT $CHAR (148) CAT $CHAR (149) CAT
            $CHAR (150) CAT $CHAR (151) CAT $CHAR (152) CAT $CHAR (153) CAT $CHAR (154) CAT $CHAR (155) CAT
            $CHAR (156) CAT $CHAR (157) CAT $CHAR (158) CAT $CHAR (159) CAT $CHAR (160) CAT $CHAR (161) CAT
            $CHAR (162) CAT $CHAR (163) CAT $CHAR (164) CAT $CHAR (165) CAT $CHAR (166) CAT $CHAR (167) CAT
            $CHAR (168) CAT $CHAR (169) CAT $CHAR (170) CAT $CHAR (171) CAT $CHAR (172) CAT $CHAR (173) CAT
            $CHAR (174) CAT $CHAR (175) CAT $CHAR (176) CAT $CHAR (177) CAT $CHAR (178) CAT $CHAR (179) CAT
            $CHAR (180) CAT $CHAR (181) CAT $CHAR (182) CAT $CHAR (183) CAT $CHAR (184) CAT $CHAR (185) CAT
            $CHAR (186) CAT $CHAR (187) CAT $CHAR (188) CAT $CHAR (189) CAT $CHAR (190) CAT $CHAR (191) CAT
            $CHAR (192) CAT $CHAR (193) CAT $CHAR (194) CAT $CHAR (195) CAT $CHAR (196) CAT $CHAR (197) CAT
            $CHAR (198) CAT $CHAR (199) CAT $CHAR (200) CAT $CHAR (201) CAT $CHAR (202) CAT $CHAR (203) CAT
            $CHAR (204) CAT $CHAR (205) CAT $CHAR (206) CAT $CHAR (207) CAT $CHAR (208) CAT $CHAR (209) CAT
            $CHAR (210) CAT $CHAR (211) CAT $CHAR (212) CAT $CHAR (213) CAT $CHAR (214) CAT $CHAR (215) CAT
            $CHAR (216) CAT $CHAR (217) CAT $CHAR (218) CAT $CHAR (219) CAT $CHAR (220) CAT $CHAR (221) CAT
            $CHAR (222) CAT $CHAR (223) CAT $CHAR (224) CAT $CHAR (225) CAT $CHAR (226) CAT $CHAR (227) CAT
            $CHAR (228) CAT $CHAR (229) CAT $CHAR (230) CAT $CHAR (231) CAT $CHAR (232) CAT $CHAR (233) CAT
            $CHAR (234) CAT $CHAR (235) CAT $CHAR (236) CAT $CHAR (237) CAT $CHAR (238) CAT $CHAR (239) CAT
            $CHAR (240) CAT $CHAR (241) CAT $CHAR (242) CAT $CHAR (243) CAT $CHAR (244) CAT $CHAR (245) CAT
            $CHAR (246) CAT $CHAR (247) CAT $CHAR (248) CAT $CHAR (249) CAT $CHAR (250) CAT $CHAR (251) CAT
            $CHAR (252) CAT $CHAR (253) CAT $CHAR (254) CAT $CHAR (255),
      no_extra: [STATIC, READ, oss$job_paged_literal] array [boolean] of
            ost$status_condition := [cle$cycle_must_follow_file_name, cle$position_must_be_last];

    VAR
      append: boolean,
      block: ^clt$block,
      block_handle: clt$block_handle,
*IF NOT $true(osv$unix)
      block_handle_name: fst$path_handle_name,
*ELSE
      block_handle_name: fst$path,
      error_line: string (osc$max_string_size),
      error_line_size: integer,
*IFEND
      ignore_block_in_current_task: boolean,
      command_file_reference: boolean,
      command_or_program_name_found: boolean,
      current_parse: clt$parse_state,
      cycle_element_found: boolean,
      cycle_offset: integer,
      cycle_offset_found: boolean,
      element: clt$special_path_element,
      element_name: fst$path_element_name,
      element_size: fst$path_element_size,
*IF $true(osv$unix)
      element_text: ^fst$path_element_string,
*IFEND
      encountered_$defer: boolean,
      found: boolean,
      generic_element_present: boolean,
*IF NOT $true(osv$unix)
      ignore_pt_results: bat$process_pt_results,
      ignore_scan_index: integer,
*IFEND
      initial_path_passed_in: boolean,
      need_to_scan: boolean,
      number: integer,
      path_handle: clt$path_handle,
*IF $true(osv$unix)
      path_syntax, unix_path_syntax, ve_path_syntax: record
        delimiter: clt$lexical_unit_kind,
        delimiter_or_concatenate: clt$lexical_unit_kinds,
        first_path_units: clt$lexical_unit_kinds,
        first_element_units: clt$lexical_unit_kinds,
        element_units: clt$lexical_unit_kinds,
      recend,
*IFEND
      position_element_found: boolean,
      previous_element_is_generic: boolean,
      previous_unit_is_concatenate: boolean,
*IF $true(osv$unix)
      saved_parse: clt$parse_state,
*IFEND
      saved_parse_ptr: ^clt$parse_state,
      saved_work_area: ^clt$work_area,
*IF NOT $true(osv$unix)
      scan_found_char: boolean,
      scl_options: ^clt$scl_options,
*IFEND
      standard_file: clt$standard_files,
*IF NOT $true(osv$unix)
      string_found: boolean,
*IFEND
      string_index: clt$string_index,
*IF NOT $true(osv$unix)
      string_size: 0 .. clc$max_string_size,
      string_value: ^clt$string_value,
*IFEND
      units: ^clt$lexical_units,
      wild_card_chars: chars,
*IF NOT $true(osv$unix)
      working_catalog: ^^clt$working_catalog,
      work_list: bat$process_pt_work_list;
*ELSE
      working_catalog: clt$working_catalog;
*IFEND

?? NEWTITLE := 'append_element', EJECT ??

    PROCEDURE [INLINE] append_element
      (    size: fst$path_element_size;
           name: fst$path_element_string);


      evaluated_file_reference.path_structure (evaluated_file_reference.path_structure_size + 1) :=
            $CHAR (size);
      evaluated_file_reference.path_structure (evaluated_file_reference.path_structure_size + 2, size) :=
            name;
      evaluated_file_reference.path_structure_size := evaluated_file_reference.path_structure_size + 1 + size;
      evaluated_file_reference.number_of_path_elements := evaluated_file_reference.number_of_path_elements +
            1;

    PROCEND append_element;
?? TITLE := 'append_wild_card', EJECT ??

    PROCEDURE [INLINE] append_wild_card
      (    wild_card_element: fst$path_element_string);

      VAR
        size: fst$path_size;


      size := STRLENGTH (wild_card_element);
      evaluated_file_reference.path_structure (evaluated_file_reference.path_structure_size + 1) :=
            $CHAR (size);
*IF NOT $true(osv$unix)
      #TRANSLATE (osv$lower_to_upper, wild_card_element, evaluated_file_reference.
            path_structure (evaluated_file_reference.path_structure_size + 2, size));
*ELSE
      IF path_syntax = unix_path_syntax THEN
        evaluated_file_reference.path_structure (evaluated_file_reference.path_structure_size + 2,
              size) := wild_card_element;
      ELSE
        #TRANSLATE (osv$lower_to_upper, wild_card_element, evaluated_file_reference.
              path_structure (evaluated_file_reference.path_structure_size + 2, size));
      IFEND;
*IFEND
      evaluated_file_reference.path_structure_size := evaluated_file_reference.path_structure_size + 1 + size;
      evaluated_file_reference.number_of_path_elements := evaluated_file_reference.number_of_path_elements +
            1;
*IF NOT $true(osv$unix)
      evaluated_file_reference.multiple_reference_specified := TRUE;
*IFEND

    PROCEND append_wild_card;
?? TITLE := 'append_working_catalog', EJECT ??

    PROCEDURE append_working_catalog
      (    element_size: fst$path_size);


      IF clc$prevent_job_context_element IN file_reference_parsing_options THEN
        IF (user_identification.family.size = 0) OR (user_identification.user.size = 0) THEN
          osp$set_status_condition (cle$undefined_user_ident, status);
        ELSE
          append_element (user_identification.family.size, user_identification.family.value);
          append_element (user_identification.user.size, user_identification.user.value);
        IFEND;
        RETURN;
      IFEND;
      find_working_catalog (element_size);

    PROCEND append_working_catalog;
*IF NOT $true(osv$unix)
?? TITLE := 'check_for_cycle_offset', EJECT ??

    PROCEDURE check_for_cycle_offset;

      IF (current_parse.unit.kind = clc$lex_add) OR (current_parse.unit.kind = clc$lex_subtract) THEN
        clp$scan_any_lexical_unit (current_parse);
        IF current_parse.unit.kind <> clc$lex_unsigned_decimal THEN
          osp$set_status_abnormal ('CL', cle$wrong_kind_of_operand, 'INTEGER', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, current_parse, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, current_parse.
                text^ (current_parse.previous_non_space_unit_index,
                current_parse.previous_non_space_unit.size), status);
          RETURN;
        IFEND;

        clp$evaluate_unsigned_decimal (current_parse.text^ (current_parse.unit_index,
              current_parse.unit.size), cycle_offset, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF current_parse.previous_non_space_unit.kind = clc$lex_subtract THEN
          cycle_offset := -cycle_offset;
        IFEND;

{       cycle_offset_found := TRUE;

        clp$scan_any_lexical_unit (current_parse);
      IFEND;

    PROCEND check_for_cycle_offset;
*IFEND
?? TITLE := 'complete_evaluation', EJECT ??

    PROCEDURE complete_evaluation;

      IF current_parse.unit_is_space THEN
        clp$scan_non_space_lexical_unit (current_parse);
      IFEND;

{ This assignment is needed to restore the parse (input,output) to its correct position.

      parse := current_parse;

      IF path_handle.kind = clc$command_file_handle THEN

{ We got here because one of the following was specified:
{   command_file_handle_name by itself (block=NIL)
{   $COMMAND or $COMMAND_OF_CALLER (block<>NIL)
{   :$COMMAND or :$COMMAND_OF_CALLER (block<>NIL)

        get_path_handle_from_cmnd_file;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
*IF $true(osv$unix)
        get_file_ref_from_path_handle;
*IFEND
      IFEND;

*IF NOT $true(osv$unix)
      IF path_handle.kind = clc$regular_path_handle THEN
        get_file_ref_from_path_handle;
      IFEND;
*IFEND

      IF (($clt$file_ref_parsing_options [clc$evaluating_command_ref,
            clc$evaluating_entry_point_ref] * file_reference_parsing_options) <>
            $clt$file_ref_parsing_options []) AND (NOT command_or_program_name_found) THEN
        determine_cmnd_prog_name_form;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF path_handle.kind = clc$regular_path_handle THEN
        RETURN;
*IF NOT $true(osv$unix)
      ELSEIF path_handle.kind = clc$not_a_path_handle THEN
        evaluated_file_reference.path_handle_info.path_handle_present := FALSE;
*IFEND
      IFEND;

      IF (standard_file = clc$sf_not_a_standard_file) THEN
*IF NOT $true(osv$unix)
        IF ((evaluated_file_reference.cycle_reference.specification = fsc$high_cycle) OR
              (evaluated_file_reference.cycle_reference.specification = fsc$low_cycle) OR
              (evaluated_file_reference.cycle_reference.specification = fsc$next_cycle)) AND
              cycle_offset_found THEN
          determine_cycle_number;
        IFEND;
*IFEND
      ELSE
        get_path_handle_for_stand_file;
      IFEND;

*IF $true(osv$unix)
      IF (NOT evaluated_file_reference.command_file_path.found) AND
         (NOT evaluated_file_reference.standard_file) AND
         (fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local) THEN
        osp$set_status_abnormal ('CL', cle$not_supported, '$LOCAL is', status);
      IFEND;

*IFEND
    PROCEND complete_evaluation;
*IF $true(osv$unix)
?? TITLE := 'contains_wild_card_char', EJECT ??

    FUNCTION [INLINE] contains_wild_card_char
      (    text: clt$string_value): boolean;

      VAR
        ignore_scan_index: integer,
        scan_found_char: boolean;


      scan_found_char := FALSE;
{     IF (clc$multiple_reference_allowed IN file_reference_parsing_options) AND
{           (scl_options^.wild_card_pattern_type = clc$wc_extended_pattern) THEN
{       #SCAN (wild_card_chars, text, ignore_scan_index, scan_found_char);
{     IFEND;
      contains_wild_card_char := scan_found_char;

    FUNCEND contains_wild_card_char;
*IFEND
?? TITLE := 'determine_cmnd_prog_name_form', EJECT ??

    PROCEDURE determine_cmnd_prog_name_form;

      IF command_file_reference THEN
        osp$set_status_condition (cle$inappropriate_cmnd_file_ref, status);
        RETURN;
      IFEND;

      IF evaluated_file_reference.number_of_path_elements = 1 THEN
        osp$set_status_condition (cle$expecting_path_element, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        RETURN;
      IFEND;
      command_or_program_name.value := fsp$path_element (^evaluated_file_reference,
            evaluated_file_reference.number_of_path_elements) ^;
      command_or_program_name.size := clp$trimmed_string_size (command_or_program_name.value);
      IF cycle_element_found OR (standard_file <> clc$sf_not_a_standard_file) THEN
        IF clc$evaluating_entry_point_ref IN file_reference_parsing_options THEN
          osp$set_status_condition (cle$cycle_must_follow_file_name, status);
          RETURN;
        IFEND;
        form := clc$file_cycle_command_ref;
      ELSE
        form := clc$module_or_file_command_ref;
      IFEND;

    PROCEND determine_cmnd_prog_name_form;
*IF NOT $true(osv$unix)
?? TITLE := 'determine_cycle_number', EJECT ??

    PROCEDURE determine_cycle_number;

      VAR
        ignore_parameter_name: clt$parameter_name,
        ignore_pt_results: bat$process_pt_results,
        initial_path: ^fst$file_reference,
        local_parse: clt$parse_state,
        number: integer,
        path_name: fst$path,
        path_name_size: fst$path_size,
        units: ^clt$lexical_units,
        work_list: bat$process_pt_work_list;


      IF generic_element_present THEN
        clp$convert_file_ref_to_string (evaluated_file_reference, TRUE, path_name, path_name_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        initial_path := NIL;
        clp$identify_lexical_units (^path_name, work_area, units, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$initialize_parse_state (^path_name, units, local_parse);
        clp$scan_non_space_lexical_unit (local_parse);

{ We don't need to check for a clc$lex_name, clc$lex_colon, or clc$lex_dot
{ because the file reference has already been evaluated. Thus, the first
{ lexical unit is a clc$lex_colon.

        clp$complete_file_ref_parse (initial_path, local_parse, work_area, file_reference_parsing_options,
              user_identification, evaluated_file_reference, command_or_program_name, form,
              ignore_parameter_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

{ We must consult BAM to get the cycle number.

      work_list := $bat$process_pt_work_list [bac$resolve_path, bac$resolve_to_catalog];


      work_list := work_list + $bat$process_pt_work_list [bac$externalize_path_handle, bac$record_path];
      bap$process_pt_request (work_list, osc$null_name, evaluated_file_reference, ignore_pt_results, status);
      IF (NOT status.normal) AND osp$file_access_condition (status) THEN
        process_pt_request (work_list, osc$null_name, evaluated_file_reference, ignore_pt_results, status);
      IFEND;

{ If the file does not exist, return bad status.  BAP$PROCESS_PT_REQUEST may return other bad statuses --
{ we might have to special case them.

      IF status.normal THEN
        number := evaluated_file_reference.cycle_reference.cycle_number + cycle_offset;
        IF (number < pfc$minimum_cycle_number) OR (number > pfc$maximum_cycle_number) THEN
          osp$set_status_condition (pfe$bad_cycle_number, status);
          osp$append_status_integer (osc$status_parameter_delimiter, number, 10, FALSE, status);
        ELSE
          evaluated_file_reference.cycle_reference.cycle_number := number;
        IFEND;
      IFEND;

    PROCEND determine_cycle_number;
*IFEND
?? TITLE := 'evaluate_$command', EJECT ??

    PROCEDURE evaluate_$command;

      VAR
        cmnd_file_qualifier: fst$path_element_name,
        local_element: clt$special_path_element,
        local_element_name: fst$path_element_name,
        local_element_size: fst$path_element_size,
        local_parse: clt$parse_state;


{ If INITIAL_PATH<>NIL and INITIAL_PATH_PASSED_IN=TRUE then $COMMAND had already been evaluated via
{ CLP$$COMMAND and passed along in INITIAL_PATH.
{ If the PARSE contains more of the file reference, an error occurs.

      IF (initial_path <> NIL) AND initial_path_passed_in AND
*IF NOT $true(osv$unix)
            ((parse.unit.kind = clc$lex_dot) OR (parse.unit.kind = clc$lex_concatenate)) THEN
*ELSE
            (parse.unit.kind IN path_syntax.delimiter_or_concatenate) THEN
*IFEND
        osp$set_status_condition (cle$expecting_end_of_file_ref, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);

{ This check is made in order to allow an open position specified on a $COMMAND reference.
{ Specifying an open position in this case has no bearing, so it is ignored.  We allow
{ the reference for compatability.

*IF NOT $true(osv$unix)
        IF parse.unit.kind = clc$lex_dot THEN
*ELSE
        IF parse.unit.kind = path_syntax.delimiter THEN
*IFEND
          local_parse := parse;
          clp$scan_any_lexical_unit (local_parse);
          IF local_parse.unit.kind = clc$lex_name THEN
            #TRANSLATE (osv$lower_to_upper, local_parse.text^ (local_parse.unit_index, local_parse.unit.size),
                  local_element_name);
            local_element_size := clp$trimmed_string_size (local_element_name);
            check_for_special_path_element (local_element_name, local_element_size, local_element);
*IF NOT $true(osv$unix)
            IF local_element.kind = clc$position_path_element THEN
*ELSE
            IF local_element.kind IN $clt$special_path_element_kinds
                  [clc$position_path_element, clc$no_position_path_element] THEN
*IFEND
              clp$scan_any_lexical_unit (local_parse);
*IF NOT $true(osv$unix)
              IF (local_parse.unit.kind <> clc$lex_dot) AND (local_parse.unit.kind <> clc$lex_concatenate)
                    THEN
*ELSE
              IF NOT (local_parse.unit.kind IN path_syntax.delimiter_or_concatenate) THEN
*IFEND
                status.normal := TRUE;
                parse := local_parse;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      clp$scan_any_lexical_unit (current_parse);
*IF NOT $true(osv$unix)
      IF current_parse.unit.kind = clc$lex_dot THEN
*ELSE
      IF current_parse.unit.kind = path_syntax.delimiter THEN
*IFEND
        IF element_name = '$COMMAND_OF_CALLER' THEN
          osp$set_status_condition (cle$expecting_end_of_file_ref, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, current_parse, status);
          RETURN;
        IFEND;
        clp$scan_any_lexical_unit (current_parse);
        IF current_parse.unit.kind = clc$lex_name THEN
          clp$scan_any_lexical_unit (current_parse);
*IF NOT $true(osv$unix)
          IF (current_parse.unit.kind = clc$lex_dot) OR (current_parse.unit.kind = clc$lex_concatenate) THEN
*ELSE
          IF current_parse.unit.kind IN path_syntax.delimiter_or_concatenate THEN
*IFEND
            osp$set_status_condition (cle$expecting_end_of_file_ref, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, current_parse, status);
            RETURN;
          IFEND;
          #TRANSLATE (osv$lower_to_upper, current_parse.text^
                (current_parse.previous_non_space_unit_index, current_parse.previous_non_space_unit.size),
                cmnd_file_qualifier);
          clp$check_name_for_path_handle (cmnd_file_qualifier, path_handle);
          IF path_handle.kind <> clc$command_file_handle THEN
            osp$set_status_abnormal ('CL', cle$improper_cmd_file_qualifier, cmnd_file_qualifier, status);
            RETURN;
          IFEND;
          IF NOT (clc$file_ref_evaluation_stage IN file_reference_parsing_options) THEN
            clp$find_command_input_block (path_handle.block_handle, block, ignore_block_in_current_task);
            IF block = NIL THEN
              osp$set_status_abnormal ('CL', cle$invalid_cmnd_file_qualifier, cmnd_file_qualifier, status);
              RETURN;
            IFEND;
          ELSE
            path_handle.kind := clc$not_a_path_handle;
            append_element (element_size, element_name);
            append_element (current_parse.previous_non_space_unit.size, cmnd_file_qualifier);
          IFEND;
        ELSE
          osp$set_status_condition (cle$expecting_end_of_file_ref, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, current_parse, status);
          RETURN;
        IFEND;
*IF NOT $true(osv$unix)
      ELSEIF (current_parse.unit.kind = clc$lex_dot) OR (current_parse.unit.kind = clc$lex_concatenate) THEN
*ELSE
      ELSEIF current_parse.unit.kind IN path_syntax.delimiter_or_concatenate THEN
*IFEND
        osp$set_status_condition (cle$expecting_end_of_file_ref, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, current_parse, status);
        RETURN;
      ELSE
        IF NOT (clc$file_ref_evaluation_stage IN file_reference_parsing_options) THEN
*IF NOT $true(osv$unix)
          clp$find_caller_input_block (element_name, block, ignore_block_in_current_task);
*ELSE
          clp$find_caller_input_block (element_name (1, osc$max_name_size), block,
                ignore_block_in_current_task);
*IFEND
          IF block <> NIL THEN
            path_handle.kind := clc$command_file_handle;
            path_handle.block_handle.segment_offset := #OFFSET (block);
            path_handle.block_handle.assignment_counter := block^.assignment_counter;
          ELSE
            append_element (6, '$LOCAL');
            append_element (5, '$NULL');
          IFEND;
        ELSE
          append_element (element_size, element_name);
        IFEND;
      IFEND;

      append := FALSE;
      need_to_scan := FALSE;

    PROCEND evaluate_$command;
*IF NOT $true(osv$unix)
?? TITLE := 'evaluate_$defer', EJECT ??

    PROCEDURE evaluate_$defer;

      clp$scan_any_lexical_unit (current_parse);
      IF current_parse.unit.kind = clc$lex_dot THEN
        clp$scan_any_lexical_unit (current_parse);
        IF current_parse.unit.kind = clc$lex_name THEN
          #TRANSLATE (osv$lower_to_upper, current_parse.text^
                (current_parse.unit_index, current_parse.unit.size), element_name);
          element_size := current_parse.unit.size;
          IF NOT encountered_$defer THEN
            encountered_$defer := TRUE;
          ELSE
            osp$set_status_condition (cle$recursive_$defer, status);
            RETURN;
          IFEND;
          clp$scan_any_lexical_unit (current_parse);
          need_to_scan := FALSE;
          IF NOT (clc$file_ref_evaluation_stage IN file_reference_parsing_options) THEN

{ Update PARSE to same position as CURRENT_PARSE.

            parse := current_parse;
            evaluate_file_var_or_fcn;
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF found THEN
              need_to_scan := FALSE;
              append := FALSE;
            ELSE
              osp$set_status_abnormal ('CL', cle$var_or_fcn_follows_$defer, element_name (1, element_size),
                    status);
            IFEND;
          ELSE
            append_element (6, '$DEFER');
            check_for_special_path_element (element_name, element_size, element);
            IF element.kind IN $clt$new_path_name_elements [clc$current_family_path_element,
                  clc$current_user_path_element, clc$reversal_path_element, clc$source_path_element,
                  clc$workin_catalog_path_element] THEN
              previous_element_is_generic := TRUE;
            IFEND;
          IFEND;
          RETURN;
        IFEND;
      IFEND;
      osp$set_status_abnormal ('CL', cle$var_or_fcn_follows_$defer, current_parse.
            text^ (current_parse.unit_index, current_parse.unit.size), status);

    PROCEND evaluate_$defer;
?? TITLE := 'evaluate_file_var_or_fcn', EJECT ??

    PROCEDURE evaluate_file_var_or_fcn;

      VAR
        access_variable_requests: clt$access_variable_requests,
        file_value: ^fst$file_reference,
        saved_parse: clt$parse_state,
        units: ^clt$lexical_units,
        value: ^clt$data_value;


      saved_parse := current_parse;
      access_variable_requests := $clt$access_variable_requests [clc$possible_file_reference];
      clp$evaluate_name (element_name, access_variable_requests, current_parse, work_area, value, found,
            status);

      IF status.normal THEN
        IF found THEN
          IF value <> NIL THEN
            IF value^.kind = clc$file THEN
              IF value^.file_value^ (1) = ':' THEN
                file_value := ^value^.file_value^ (1, clp$trimmed_string_size (value^.file_value^));
                initial_path := file_value;
                initial_path_passed_in := FALSE;
                NEXT saved_parse_ptr IN work_area;
                IF saved_parse_ptr = NIL THEN
                  osp$set_status_condition (cle$work_area_overflow, status);
                  RETURN;
                IFEND;
                saved_parse_ptr^ := current_parse;
                clp$identify_lexical_units (file_value, work_area, units, status);
                IF status.normal THEN
                  clp$initialize_parse_state (file_value, units, current_parse);
                  clp$scan_non_space_lexical_unit (current_parse);
                  previous_element_is_generic := TRUE;
                IFEND;
              ELSE

{ The file variable or function value was incorrectly initialized (probably thru the program interface).

                osp$set_status_condition (cle$missing_colon_in_var_or_fcn, status);
              IFEND;
            ELSEIF value^.kind = clc$unspecified THEN

{ The current_parse should be pointing to the lexical unit after the variable

              IF (current_parse.unit.kind = clc$lex_concatenate) OR
                    (current_parse.unit.kind = clc$lex_dot) THEN
                osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, element_name, status);
                clp$append_status_parse_state (osc$status_parameter_delimiter, current_parse, status);
              IFEND;
              parameter_name := element_name;
              parse := current_parse;
              EXIT clp$complete_file_ref_parse;
            ELSE
              found := FALSE;
              current_parse := saved_parse;
              IF current_parse.unit.kind = clc$lex_left_parenthesis THEN
                osp$set_status_abnormal ('CL', cle$expecting_file_var_or_fcn, element_name (1, element_size),
                      status);
              IFEND;
            IFEND;
          ELSE
            found := FALSE;
            current_parse := saved_parse;
          IFEND;
        IFEND;
      IFEND;

    PROCEND evaluate_file_var_or_fcn;
*IFEND
?? TITLE := 'evaluate_first_element', EJECT ??

    PROCEDURE evaluate_first_element;

      VAR
*IF $true(osv$unix)
        element_contains_wild_card_char: boolean,
        home_element: ost_c_name,
        home_length: ost_c_integer,
        home_string: ost_c_name,
        home_value: ost_c_fixed_string,
        i: 1 .. 256,
        j: 0 .. 31,
*IFEND
        local_element: clt$special_path_element,
        local_element_name: fst$path_element_name,
        local_element_size: fst$path_element_size,
        local_parse: clt$parse_state;


      CASE element.kind OF

      = clc$command_file_path_element =

        IF clc$prevent_job_context_element IN file_reference_parsing_options THEN
          osp$set_status_abnormal ('CL', cle$no_job_context_elements, element_name (1, element_size), status);
          RETURN;
        IFEND;

*IF NOT $true(osv$unix)
        IF (current_parse.unit.kind = clc$lex_dot) OR (current_parse.unit.kind = clc$lex_concatenate) THEN
*ELSE
        IF current_parse.unit.kind IN path_syntax.delimiter_or_concatenate THEN
*IFEND
          osp$set_status_condition (cle$expecting_end_of_file_ref, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, current_parse, status);

{ This check is made in order to allow an open position specified on a $COMMAND reference.
{ Specifying an open position in this case has no bearing, so it is ignored.  We allow
{ the reference for compatability.

*IF NOT $true(osv$unix)
          IF current_parse.unit.kind = clc$lex_dot THEN
*ELSE
          IF current_parse.unit.kind = path_syntax.delimiter THEN
*IFEND
            local_parse := current_parse;
            clp$scan_any_lexical_unit (local_parse);
            IF local_parse.unit.kind = clc$lex_name THEN
              #TRANSLATE (osv$lower_to_upper, local_parse.text^
                    (local_parse.unit_index, local_parse.unit.size), local_element_name);
              local_element_size := clp$trimmed_string_size (local_element_name);
              check_for_special_path_element (local_element_name, local_element_size, local_element);
*IF NOT $true(osv$unix)
              IF local_element.kind = clc$position_path_element THEN
*ELSE
              IF local_element.kind IN $clt$special_path_element_kinds
                    [clc$position_path_element, clc$no_position_path_element] THEN
*IFEND
                clp$scan_any_lexical_unit (local_parse);
*IF NOT $true(osv$unix)
                IF (local_parse.unit.kind <> clc$lex_dot) AND (local_parse.unit.kind <> clc$lex_concatenate)
                      THEN
*ELSE
                IF NOT (local_parse.unit.kind IN path_syntax.delimiter_or_concatenate) THEN
*IFEND
                  status.normal := TRUE;
                  current_parse := local_parse;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

*IF NOT $true(osv$unix)
        clp$find_caller_input_block (element_name, block, ignore_block_in_current_task);
*ELSE
        clp$find_caller_input_block (element_name (1, osc$max_name_size), block,
              ignore_block_in_current_task);
*IFEND
        IF block <> NIL THEN
          path_handle.kind := clc$command_file_handle;
          path_handle.block_handle.segment_offset := #OFFSET (block);
          path_handle.block_handle.assignment_counter := block^.assignment_counter;
        ELSE
          append_element (6, '$LOCAL');
          append_element (5, '$NULL');
          standard_file := clc$sf_null_file;
        IFEND;

        complete_evaluation;
        work_area := saved_work_area;
        EXIT clp$complete_file_ref_parse;

*IF NOT $true(osv$unix)
      = clc$current_family_path_element =

        IF (user_identification.family.size = 0) THEN
          osp$set_status_condition (cle$undefined_user_ident, status);
          RETURN;
        IFEND;

        append_element (user_identification.family.size, user_identification.family.value);

      = clc$current_user_path_element =

        IF (user_identification.family.size = 0) OR (user_identification.user.size = 0) THEN
          osp$set_status_condition (cle$undefined_user_ident, status);
          RETURN;
        IFEND;

        append_element (user_identification.family.size, user_identification.family.value);
        append_element (user_identification.user.size, user_identification.user.value);

      = clc$cycle_path_element =

        osp$set_status_condition (cle$cycle_must_follow_file_name, status);
        RETURN;

      = clc$defer_eval_path_element =

        osp$set_status_condition (cle$defer_must_follow_colon, status);
        RETURN;
*IFEND

      = clc$job_file_path_element, clc$standard_file_path_element =

        IF clc$prevent_job_context_element IN file_reference_parsing_options THEN
          osp$set_status_abnormal ('CL', cle$no_job_context_elements, element_name (1, element_size), status);
          RETURN;
        IFEND;

        IF element_name (1) <> '$' THEN
*IF NOT $true(osv$unix)
          evaluate_file_var_or_fcn;
          IF NOT status.normal THEN
            IF status.condition = cle$variable_never_given_value THEN
              status.normal := TRUE;
            ELSE
              RETURN;
            IFEND;
          IFEND;
          IF found THEN
            RETURN;
          IFEND;
*IFEND
        IFEND;

        append_element (6, '$LOCAL');
        append_element (element_size, element_name);
        standard_file := element.standard_file;

      = clc$local_catalog_path_element =

        IF clc$prevent_job_context_element IN file_reference_parsing_options THEN
          osp$set_status_abnormal ('CL', cle$no_job_context_elements, element_name (1, element_size), status);
          RETURN;
        IFEND;

        append_element (6, '$LOCAL');

      = clc$not_a_special_path_element =

*IF NOT $true(osv$unix)
        scan_found_char := FALSE;
        IF (clc$multiple_reference_allowed IN file_reference_parsing_options) AND
              (scl_options^.wild_card_pattern_type = clc$wc_extended_pattern) THEN
          #SCAN (wild_card_chars, element_name, ignore_scan_index, scan_found_char);
        IFEND;

        IF clc$prevent_job_context_element IN file_reference_parsing_options THEN
          IF (user_identification.family.size = 0) OR (user_identification.user.size = 0) THEN
            osp$set_status_condition (cle$undefined_user_ident, status);
            RETURN;
          IFEND;
          append_element (user_identification.family.size, user_identification.family.value);
          append_element (user_identification.user.size, user_identification.user.value);
          append_element (element_size, element_name);

{ The only time clc$evaluating_entry_point_ref is in the parsing_options and initial_path
{ is NIL is when we want to bypass evaluating file variables and functions - a file variable
{ or function may be present in file reference, but it is not a valid entry_point_reference.
{ So we want to evaluate the file reference relative to the working catalog.

        ELSEIF (clc$evaluating_entry_point_ref IN file_reference_parsing_options) AND
              (initial_path = NIL) THEN
          append_working_catalog (element_size);
          append_element (element_size, element_name);
        ELSEIF (element_name (1) = '$') AND (i#compare_collated
              (element_name, clv$unique_name, unique_name_mask) = 0) THEN
          append_element (6, '$LOCAL');
          append_element (element_size, element_name);
        ELSE
          clp$check_name_for_path_handle (element_name, path_handle);
          IF path_handle.kind <> clc$not_a_path_handle THEN
            append_element (6, '$LOCAL');
            append_element (element_size, element_name);
          ELSE

{  If the variable or function is not a file, then FOUND is set to false.
{  If it is, the CURRENT_PARSE will represent the value of the variable.

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

            IF NOT found THEN
              IF clc$use_$local_as_working_cat IN file_reference_parsing_options THEN
                append_element (6, '$LOCAL');
                append_element (element_size, element_name);
              ELSE
                find_working_catalog (element_size);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                append_element (element_size, element_name);
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        IF scan_found_char THEN
          evaluated_file_reference.multiple_reference_specified := TRUE;
        IFEND;

      = clc$position_path_element =
*ELSE
        IF (element_size = 5) AND ((element_name (1, element_size) = '$HOME') OR
              (element_name (1, element_size) = '$home')) THEN
          home_string := 'HOME' CAT $CHAR(0);
          clp_getenv (home_string, home_value, home_length);
          j := 0;
          IF home_length > 1 THEN  { ELSE $HOME must = /}
            FOR i := 2 TO home_length DO  { assumes the first character is "/" }
              IF home_value (i) <> '/' THEN
                j := j + 1;
                home_element (j) := home_value (i);
              ELSE
                append_element (j, home_element);
                j := 0;
              IFEND;
            FOREND;
            append_element (j, home_element);
          IFEND;
          RETURN;
        IFEND;
        find_working_catalog (element_size);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        append_element (element_size, element_name);
*IFEND

*IF NOT $true(osv$unix)

        osp$set_status_condition (cle$position_must_be_last, status);
        RETURN;

      = clc$reversal_path_element =

        IF clc$prevent_job_context_element IN file_reference_parsing_options THEN
          IF (user_identification.family.size = 0) OR (user_identification.user.size = 0) THEN
            osp$set_status_condition (cle$undefined_user_ident, status);
            RETURN;
          IFEND;
          append_element (user_identification.family.size, user_identification.family.value);
          append_element (user_identification.user.size, user_identification.user.value);
        ELSE
          clp$find_working_catalog (working_catalog);

          evaluated_file_reference.path_structure := working_catalog^^.evaluated_file_reference.
                path_structure;
          evaluated_file_reference.path_structure_size := working_catalog^^.evaluated_file_reference.
                path_structure_size;
          evaluated_file_reference.number_of_path_elements :=
                working_catalog^^.evaluated_file_reference.number_of_path_elements;
        IFEND;

        clp$remove_last_path_element (evaluated_file_reference, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        path_handle.kind := clc$not_a_path_handle;

      = clc$source_path_element =

        IF clc$prevent_job_context_element IN file_reference_parsing_options THEN
          osp$set_status_abnormal ('CL', cle$no_job_context_elements, element_name (1, element_size), status);
          RETURN;
        IFEND;

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

      = clc$system_path_element =

        append_element (7, '$SYSTEM');
        append_element (7, '$SYSTEM');

      = clc$traversal_path_element =

        IF clc$multiple_reference_allowed IN file_reference_parsing_options THEN
          append_working_catalog (4);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          append_wild_card ('$ALL');
        ELSE
          osp$set_status_condition (cle$wild_card_not_allowed, status);
        IFEND;
*IFEND

      = clc$unsupported_path_element =

        osp$set_status_abnormal ('CL', cle$not_yet_implemented, element_name, status);
        osp$append_status_parameter (' ', 'in file references', status);
        RETURN;

*IF NOT $true(osv$unix)
      = clc$workin_catalog_path_element =

        IF clc$prevent_job_context_element IN file_reference_parsing_options THEN
          osp$set_status_abnormal ('CL', cle$no_job_context_elements, element_name (1, element_size), status);
          RETURN;
        IFEND;

        clp$find_working_catalog (working_catalog);

        evaluated_file_reference.path_structure := working_catalog^^.evaluated_file_reference.path_structure;
        evaluated_file_reference.path_structure_size := working_catalog^^.evaluated_file_reference.
              path_structure_size;
        evaluated_file_reference.number_of_path_elements :=
              working_catalog^^.evaluated_file_reference.number_of_path_elements;
*IFEND

      CASEND;

    PROCEND evaluate_first_element;
*IF NOT $true(osv$unix)
?? TITLE := 'evaluate_name_or_num_var_or_fcn', EJECT ??

    PROCEDURE evaluate_name_or_num_var_or_fcn;

      VAR
        access_variable_requests: clt$access_variable_requests,
        value: ^clt$data_value;


      clp$scan_any_lexical_unit (current_parse);
      need_to_scan := FALSE;

      access_variable_requests := $clt$access_variable_requests [];
      clp$evaluate_name (element_name, access_variable_requests, current_parse, work_area, value, found,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    /evaluate/
      BEGIN
        IF found THEN
          IF value = NIL THEN
            osp$set_status_abnormal ('CL', cle$variable_never_given_value, element_name (1, element_size),
                  status);
            RETURN;
          IFEND;
          CASE value^.kind OF
          = clc$name =
            element_name := value^.name_value;
            EXIT /evaluate/;
          = clc$data_name =
            element_name := value^.data_name_value;
            EXIT /evaluate/;
          = clc$keyword =
            element_name := value^.keyword_value;
            EXIT /evaluate/;
          = clc$integer =
            element.kind := clc$var_or_fcn_cyc_path_element;
            number := value^.integer_value.value;
            RETURN;
          = clc$program_name =
            IF (clc$evaluating_entry_point_ref IN file_reference_parsing_options) THEN
              element_name := value^.program_name_value;
              EXIT /evaluate/;
            IFEND;
          = clc$unspecified =
            osp$set_status_abnormal ('CL', cle$unexpected_oper_for_unspec, element_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, '//', status);
            parameter_name := element_name;
            EXIT clp$complete_file_ref_parse;
          ELSE
            ;
          CASEND;
        IFEND;

        osp$set_status_abnormal ('CL', cle$var_or_fcn_follows_concat, element_name (1, element_size), status);
        RETURN;
      END /evaluate/;

      element_size := clp$trimmed_string_size (element_name);
      check_for_special_path_element (element_name, element_size, element);

    PROCEND evaluate_name_or_num_var_or_fcn;
?? TITLE := 'find_command_source', EJECT ??

    PROCEDURE find_command_source;

      VAR
        block: ^clt$block;


      clp$find_command_source (element_name, block);
      IF block <> NIL THEN
        CASE block^.source.kind OF
        = clc$system_commands =
          osp$set_status_condition (cle$unexpected_sys_cmnd_source, status);
          RETURN;
        = clc$sub_commands =
          osp$set_status_abnormal ('CL', cle$unexpected_util_cmnd_source, block^.source.utility_name, status);
          RETURN;
        = clc$catalog_commands, clc$library_commands =
          clp$check_name_for_path_handle (block^.source.local_file_name, path_handle);
        CASEND;
        bap$get_path_elements (path_handle.regular_handle, evaluated_file_reference, status);
        IF status.normal THEN
          cycle_element_found := evaluated_file_reference.cycle_reference.specification <> fsc$cycle_omitted;
        IFEND;
      ELSE
        osp$set_status_condition (cle$unable_to_find_cmnd_source, status);
      IFEND;

    PROCEND find_command_source;
*IFEND
?? TITLE := 'find_working_catalog', EJECT ??

*IF NOT $true(osv$unix)
    PROCEDURE [INLINE] find_working_catalog (element_size: fst$path_size);
*ELSE
    PROCEDURE [INLINE] find_working_catalog
      (    element_size: fst$path_size);

*IFEND

*IF NOT $true(osv$unix)
      clp$find_working_catalog (working_catalog);
      IF working_catalog^ = NIL THEN
        append_element (6, '$LOCAL');
      ELSEIF (working_catalog^^.evaluated_file_reference.number_of_path_elements >= fsc$max_path_elements) OR
            ((working_catalog^^.evaluated_file_reference.path_structure_size + 1 + element_size) >
*ELSE
      clp$find_working_catalog (working_catalog, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (working_catalog.evaluated_file_reference.number_of_path_elements >= fsc$max_path_elements) OR
            ((working_catalog.evaluated_file_reference.path_structure_size + 1 + element_size) >
*IFEND
            fsc$max_path_size) THEN
        osp$set_status_condition (cle$file_reference_too_long, status);
      ELSE
*IF NOT $true(osv$unix)
        evaluated_file_reference := working_catalog^^.evaluated_file_reference;
        evaluated_file_reference.path_resolution := fsc$unresolved_path;
        evaluated_file_reference.path_handle_info.path_handle_present := FALSE;
*ELSE
        evaluated_file_reference := working_catalog.evaluated_file_reference;
*IFEND
      IFEND;

    PROCEND find_working_catalog;
?? TITLE := 'get_file_ref_from_path_handle', EJECT ??

    PROCEDURE get_file_ref_from_path_handle;

*IF NOT $true(osv$unix)
      IF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
        path_handle.regular_handle.open_position := evaluated_file_reference.path_handle_info.path_handle.
              open_position;
      IFEND;
*IFEND
      IF command_file_reference THEN
*IF NOT $true(osv$unix)
        evaluated_file_reference.path_resolution := fsc$command_file_path;
        evaluated_file_reference.block_handle := block_handle;
*ELSE
        evaluated_file_reference.command_file_path.found := TRUE;
        evaluated_file_reference.command_file_path.block_handle := block_handle;
*IFEND
        IF clc$file_ref_evaluation_stage IN file_reference_parsing_options THEN
*IF NOT $true(osv$unix)
          clp$construct_block_handle_name (evaluated_file_reference.block_handle, block_handle_name);
*ELSE
          clp$construct_block_handle_name (evaluated_file_reference.command_file_path.block_handle,
                block_handle_name);
*IFEND
          append_element (8, '$COMMAND');
          append_element (clp$trimmed_string_size (block_handle_name), block_handle_name);
          RETURN;
        IFEND;
      IFEND;
*IF NOT $true(osv$unix)
      bap$get_path_elements (path_handle.regular_handle, evaluated_file_reference, status);
      IF NOT status.normal THEN

{
{ Bap$get_path_elements initializes evaluated_file_reference even if a bad status was returned.
{ Therefore you lose everything up to this point in evaluated_file_reference when the status is bad.
{

        status.normal := TRUE;
      ELSE
        cycle_element_found := evaluated_file_reference.cycle_reference.specification <> fsc$cycle_omitted;
      IFEND;
      IF command_file_reference THEN
        evaluated_file_reference.path_resolution := fsc$command_file_path;
        evaluated_file_reference.block_handle := block_handle;
      IFEND;
*IFEND

    PROCEND get_file_ref_from_path_handle;
?? TITLE := 'get_path_handle_for_stand_file', EJECT ??

    PROCEDURE get_path_handle_for_stand_file;


*IF NOT $true(osv$unix)
    /get_path_handle/
      BEGIN

        CASE evaluated_file_reference.cycle_reference.specification OF
        = fsc$high_cycle, fsc$low_cycle =
          IF cycle_offset <> 0 THEN
            EXIT /get_path_handle/;
          IFEND;
          evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
          evaluated_file_reference.cycle_reference.cycle_number := 1;
        = fsc$next_cycle =
          IF cycle_offset <> -1 THEN
            EXIT /get_path_handle/;
          IFEND;
          evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
          evaluated_file_reference.cycle_reference.cycle_number := 1;
        = fsc$cycle_number =
          IF evaluated_file_reference.cycle_reference.cycle_number <> 1 THEN
            EXIT /get_path_handle/;
          IFEND;
        ELSE {fsc$cycle_omitted}
          evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
          evaluated_file_reference.cycle_reference.cycle_number := 1;
        CASEND;

        IF clv$standard_files [standard_file].path_handle_name = osc$null_name THEN
          work_list := $bat$process_pt_work_list [bac$externalize_path_handle, bac$record_path];

          bap$process_pt_request (work_list, osc$null_name, evaluated_file_reference, ignore_pt_results,
                status);
          IF (NOT status.normal) AND osp$file_access_condition (status) THEN
            process_pt_request (work_list, osc$null_name, evaluated_file_reference, ignore_pt_results,
                  status);
          IFEND;
          process_status (evaluated_file_reference.path_handle_info, evaluated_file_reference.path_resolution,
                'clp$complete_file_ref_parse', status);
        ELSE
          evaluated_file_reference.path_handle_info.path_handle_present := TRUE;
          evaluated_file_reference.path_handle_info.path_handle :=
                clv$standard_files [standard_file].path_handle;
        IFEND;
        RETURN;
      END /get_path_handle/;

      osp$set_status_abnormal ('CL', cle$only_cycle_one_allowed,
            clv$standard_files [standard_file].path_handle_name, status);
*ELSE
      evaluated_file_reference.standard_file := TRUE;
      evaluated_file_reference.unix_standard_file := clv$standard_files [standard_file];
*IFEND

    PROCEND get_path_handle_for_stand_file;
?? TITLE := 'get_path_handle_from_cmnd_file', EJECT ??

    PROCEDURE get_path_handle_from_cmnd_file;


      IF NOT (clc$command_file_ref_allowed IN file_reference_parsing_options) THEN
        osp$set_status_condition (cle$inappropriate_cmnd_file_ref, status);
        RETURN;
      IFEND;
      IF block = NIL THEN
        clp$find_command_input_block (path_handle.block_handle, block, ignore_block_in_current_task);
      IFEND;
      IF block = NIL THEN
        path_handle.kind := clc$not_a_path_handle;
      ELSEIF (block^.kind = clc$task_block) OR (block^.input.kind <> clc$file_input) THEN
*IF NOT $true(osv$unix)
        evaluated_file_reference.path_resolution := fsc$command_file_path;
        evaluated_file_reference.block_handle := path_handle.block_handle;
*ELSE
        evaluated_file_reference.command_file_path.found := TRUE;
        evaluated_file_reference.command_file_path.block_handle := path_handle.block_handle;
*IFEND
        path_handle.kind := clc$not_a_path_handle;
        evaluated_file_reference.path_structure := '';
        evaluated_file_reference.path_structure_size := 0;
        evaluated_file_reference.number_of_path_elements := 0;
        IF clc$file_ref_evaluation_stage IN file_reference_parsing_options THEN
*IF NOT $true(osv$unix)
          clp$construct_block_handle_name (evaluated_file_reference.block_handle, block_handle_name);
*ELSE
          clp$construct_block_handle_name (evaluated_file_reference.command_file_path.block_handle,
                block_handle_name);
*IFEND
          append_element (8, '$COMMAND');
          append_element (clp$trimmed_string_size (block_handle_name), block_handle_name);
          RETURN;
        IFEND;
        append_element (6, '$LOCAL');
        append_element (5, '$NULL');
        standard_file := clc$sf_null_file;
      ELSE
        command_file_reference := TRUE;
        block_handle := path_handle.block_handle;
        clp$check_name_for_path_handle (block^.input.local_file_name, path_handle);
      IFEND;

    PROCEND get_path_handle_from_cmnd_file;
*IF NOT $true(osv$unix)
?? TITLE := 'process_program_name', EJECT ??

    PROCEDURE [INLINE] process_program_name;

      string_found := TRUE;
      NEXT string_value: [current_parse.unit.size - 2] IN work_area;
      IF string_value = NIL THEN
        osp$set_status_condition (cle$work_area_overflow, status);
        RETURN;
      IFEND;
      string_value^ (1, current_parse.unit.size - 2) := current_parse.
            text^ (current_parse.unit_index + 1, current_parse.unit.size - 2);

      WHILE TRUE DO
        clp$scan_any_lexical_unit (current_parse);
        CASE current_parse.unit.kind OF
        = clc$lex_string =
          RESET work_area TO string_value;
          NEXT string_value: [STRLENGTH (string_value^) + current_parse.unit.size - 1] IN work_area;
          IF string_value = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
            RETURN;
          IFEND;
          string_value^ (STRLENGTH (string_value^) - current_parse.unit.size + 2,
                current_parse.unit.size - 1) := current_parse.text^
                (current_parse.unit_index, current_parse.unit.size - 1);
        = clc$lex_unterminated_string =
          osp$set_status_abnormal ('CL', cle$missing_string_delimiter, current_parse.
                text^ (current_parse.unit_index, current_parse.unit.size), status);
          RETURN;
        ELSE
          string_size := STRLENGTH (string_value^);
          IF string_size > osc$max_name_size THEN
            osp$set_status_abnormal ('CL', cle$program_name_too_long, string_value^ (1, string_size), status);
            RETURN;
          ELSEIF string_size < 1 THEN
            osp$set_status_condition (cle$null_program_name, status);
            RETURN;
          ELSEIF string_value^ = osc$null_name THEN
            osp$set_status_condition (cle$null_program_name, status);
            RETURN;
          IFEND;
          command_or_program_name.value := string_value^ (1, string_size);
          command_or_program_name.size := string_size;
          command_or_program_name_found := TRUE;
          IF NOT cycle_element_found THEN
            IF (evaluated_file_reference.number_of_path_elements >= fsc$max_path_elements) OR
                  ((evaluated_file_reference.path_structure_size + 1 + string_size) > fsc$max_path_size) THEN
              osp$set_status_condition (cle$file_reference_too_long, status);
              RETURN;
            IFEND;
            append_element (string_size, string_value^);
          IFEND;
          RETURN;
        CASEND;
      WHILEND;

    PROCEND process_program_name;
*ELSE
?? TITLE := 'rescan_path_element_lex_unit', EJECT ??

{
{ PURPOSE:
{   This procedure updates its PARSE parameter to designate the lexical
{   unit(s), beginning with the current unit, that represent an element of a
{   file path.
{

    PROCEDURE [INLINE] rescan_path_element_lex_unit
      (VAR parse {input, output} : clt$parse_state);


      IF parse.unit.kind IN path_syntax.first_element_units THEN
        scan_path_element_lex_units (parse);
      IFEND;

    PROCEND rescan_path_element_lex_unit;
?? TITLE := 'scan_next_path_element_lex_unit', EJECT ??

{
{ PURPOSE:
{   This procedure updates its PARSE parameter to designate the next lexical
{   unit(s) that represent an element of a file path.
{

    PROCEDURE [INLINE] scan_next_path_element_lex_unit
      (VAR parse {input, output} : clt$parse_state);


      IF parse.unit_index < parse.index_limit THEN
        IF NOT parse.unit_is_space THEN
          parse.previous_non_space_unit := parse.unit;
          parse.previous_non_space_unit_index := parse.unit_index;
        IFEND;

        parse.previous_unit_is_space := parse.unit_is_space;
        parse.unit_index := parse.index;
        parse.units_array_index := parse.units_array_index + 1;
        parse.unit := parse.units_array^ [parse.units_array_index];
        parse.index := parse.index + parse.unit.size;

        IF parse.unit.kind IN path_syntax.first_element_units THEN
          parse.unit_is_space := FALSE;
          scan_path_element_lex_units (parse);
        ELSE
          parse.unit_is_space := parse.unit.kind IN $clt$lexical_unit_kinds
                [clc$lex_space, clc$lex_comment, clc$lex_unterminated_comment];
        IFEND;
      IFEND;

    PROCEND scan_next_path_element_lex_unit;
?? TITLE := 'scan_path_element_lex_units', EJECT ??

{
{ PURPOSE:
{
{   This procedure is called by RESCAN_PATH_ELEMENT_LEX_UNIT and
{   SCAN_PATH_ELEMENT_LEX_UNIT to perform the bulk of their processing.  It is
{   called when the current lexical unit is one that can start a path element.
{   It updates its PARSE parameter to designate the lexical unit(s) that
{   represent an element of a file path.
{
{   The path element may include "wild card" characters.  The unit kind
{   CLC$LEX_WILD_CARD_NAME can be thought of as a "compound" unit comprised of
{   one or more of the "simple" units:  CLC$LEX_NAME, CLC$LEX_LONG_NAME,
{   CLC$LEX_ALPHA_NUMBER, CLC$LEX_UNSIGNED_DECIMAL, CLC$LEX_QUERY,
{   CLC$LEX_MULTIPLY, CLC$LEX_EXPONENTIATE, CLC$LEX_SUBTRACT and, in the case
{   of a UNIX style path, CLC$LEX_DOT.
{
{   If the resulting unit kind when parsing a UNIX style path is
{   CLC$LEX_ALHA_NUMBER, the first lexical unit of the element is either a
{   CLC$LEX_ALHA_NUMBER or the path element contains a CLC$LEX_DOT.
{

    PROCEDURE [INLINE] scan_path_element_lex_units
      (VAR parse {input, output} : clt$parse_state);

      VAR
        result_unit_kind: clt$lexical_unit_kind;


      result_unit_kind := parse.unit.kind;

    /scan_units/
      WHILE TRUE DO
        IF result_unit_kind <> clc$lex_wild_card_name THEN
          IF parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_query, clc$lex_multiply,
                clc$lex_exponentiate] THEN
            result_unit_kind := clc$lex_wild_card_name;
          ELSEIF parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_dot] THEN
            result_unit_kind := clc$lex_alpha_number;
          IFEND;
        IFEND;

        IF parse.index >= parse.index_limit THEN
          EXIT /scan_units/;
        ELSEIF parse.units_array^ [parse.units_array_index + 1].kind IN path_syntax.element_units THEN
          ;
        ELSEIF parse.units_array^ [parse.units_array_index + 1].kind = clc$lex_subtract THEN

{ Should only get here for a NOS/VE style path since CLC$LEX_SUBTRACT is in
{ PATH_SYNTAX.ELEMENT_UNITS for a UNIX style path.

{ A "-" (clc$lex_subtract) can only be part of a NOS/VE path element if it is
{ used in a "character class" sequence (e.g., [a-b]).  This can only occur if
{ it is followed by other unit(s) that could be part of a path elemnet, unless
{ it is just followed by a clc$lex_unsigned_decimal (which cannot contain a "]").

          CASE parse.units_array^ [parse.units_array_index + 2].kind OF
          = clc$lex_name, clc$lex_long_name, clc$lex_alpha_number, clc$lex_query, clc$lex_multiply,
                clc$lex_exponentiate =
            result_unit_kind := clc$lex_wild_card_name;
          = clc$lex_unsigned_decimal =
            IF NOT (parse.units_array^ [parse.units_array_index + 3].kind IN
                  $clt$lexical_unit_kinds [clc$lex_name, clc$lex_long_name, clc$lex_alpha_number,
                  clc$lex_query, clc$lex_multiply, clc$lex_exponentiate]) THEN
              EXIT /scan_units/;
            IFEND;
            result_unit_kind := clc$lex_wild_card_name;
          ELSE
            EXIT /scan_units/;
          CASEND;
        ELSE
          EXIT /scan_units/;
        IFEND;

        parse.units_array_index := parse.units_array_index + 1;
        parse.unit.kind := parse.units_array^ [parse.units_array_index].kind;
        parse.index := parse.index + parse.units_array^ [parse.units_array_index].size;
      WHILEND /scan_units/;

      parse.unit.kind := result_unit_kind;
      parse.unit.size := parse.index - parse.unit_index;

    PROCEND scan_path_element_lex_units;
?? TITLE := 'setup_path_syntax_descriptor', EJECT ??

{
{ PURPOSE:
{   This procedure initializes the information in the variable PATH_SYNTAX that
{   describes the syntactic differences between a NOS/VE style file path and a
{   UNIX style file path.  This information is then used to make decisions in a
{   more efficient manner than possible by repeatedly asking, "Are we parsing a
{   NOS/VE or UNIX path?"
{

    PROCEDURE [INLINE] setup_path_syntax_descriptor;


    unix_path_syntax.delimiter := clc$lex_divide;
    unix_path_syntax.delimiter_or_concatenate := $clt$lexical_unit_kinds [clc$lex_divide,
          clc$lex_concatenate];
    unix_path_syntax.first_path_units := $clt$lexical_unit_kinds
          [clc$lex_divide, clc$lex_name, clc$lex_long_name, clc$lex_unsigned_decimal,
          clc$lex_alpha_number, clc$lex_dot, clc$lex_query, clc$lex_multiply, clc$lex_exponentiate];
    unix_path_syntax.first_element_units := $clt$lexical_unit_kinds
          [clc$lex_name, clc$lex_long_name, clc$lex_unsigned_decimal, clc$lex_alpha_number, clc$lex_dot,
          clc$lex_query, clc$lex_multiply, clc$lex_exponentiate];
    unix_path_syntax.element_units := $clt$lexical_unit_kinds
          [clc$lex_name, clc$lex_long_name, clc$lex_unsigned_decimal, clc$lex_alpha_number, clc$lex_dot,
          clc$lex_query, clc$lex_multiply, clc$lex_exponentiate,
          clc$lex_add, clc$lex_subtract];

    ve_path_syntax.delimiter := clc$lex_dot;
    ve_path_syntax.delimiter_or_concatenate := $clt$lexical_unit_kinds [clc$lex_dot, clc$lex_concatenate];
    ve_path_syntax.first_path_units := $clt$lexical_unit_kinds
          [clc$lex_colon, clc$lex_dot, clc$lex_name, clc$lex_long_name, clc$lex_query, clc$lex_multiply,
          clc$lex_exponentiate];
    ve_path_syntax.first_element_units := $clt$lexical_unit_kinds
          [clc$lex_name, clc$lex_long_name, clc$lex_query, clc$lex_multiply, clc$lex_exponentiate];
    ve_path_syntax.element_units := $clt$lexical_unit_kinds
          [clc$lex_name, clc$lex_long_name, clc$lex_unsigned_decimal, clc$lex_alpha_number, clc$lex_query,
          clc$lex_multiply, clc$lex_exponentiate];

    PROCEND setup_path_syntax_descriptor;
*IFEND
?? TITLE := 'update_current_parse', EJECT ??

    PROCEDURE [INLINE] update_current_parse;

{ Keep track if there is a generic path element in the file reference (and evaluation was deferrred).

      IF NOT generic_element_present THEN
        generic_element_present := previous_element_is_generic;
      IFEND;

{ We do not "need_to_scan" if we have just checked for a cycle offset or
{ evaluated :$DEFER.file_var_or_fcn.
{ Set the boolean back to TRUE after the test.

      IF need_to_scan THEN
        clp$scan_any_lexical_unit (current_parse);
      IFEND;
      need_to_scan := TRUE;
      IF current_parse.unit.kind = clc$lex_end_of_line THEN

{ If "initial_path" is not NIL, then we just got done parsing it.
{ Reset the current_parse to the original parse state and set "initial_path" to
{   NIL to prevent an additional iteration.

        IF initial_path <> NIL THEN
          IF initial_path_passed_in THEN
            current_parse := parse;
          ELSEIF saved_parse_ptr <> NIL THEN
            current_parse := saved_parse_ptr^;
          IFEND;
          initial_path := NIL;
        IFEND;
      IFEND;

    PROCEND update_current_parse;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    IF (clc$evaluating_command_ref IN file_reference_parsing_options) AND
          (clc$evaluating_entry_point_ref IN file_reference_parsing_options) THEN
      osp$set_status_condition (cle$conflicting_parse_options, status);
      RETURN;
    IFEND;

    path_handle.kind := clc$not_a_path_handle;
    evaluated_file_reference := fsv$evaluated_file_reference;
    standard_file := clc$sf_not_a_standard_file;
    command_file_reference := FALSE;
    block := NIL;
*IF NOT $true(osv$unix)
    previous_element_is_generic := FALSE;
    generic_element_present := FALSE;
    cycle_element_found := FALSE;
    position_element_found := FALSE;
*IFEND
    command_or_program_name_found := FALSE;
    number := 0;
    append := TRUE;
    need_to_scan := TRUE;
    initial_path_passed_in := initial_path <> NIL;
    saved_parse_ptr := NIL;
    saved_work_area := work_area;
    parameter_name := osc$null_name;
    cycle_offset := 0;
*IF NOT $true(osv$unix)
    string_found := FALSE;
    encountered_$defer := FALSE;
*IFEND
    wild_card_chars := $chars ['[', '{'];

*IF NOT $true(osv$unix)
    clp$find_scl_options (scl_options);

*IF NOT $true(osv$unix)
    clp$rescan_wild_card_lex_unit (parse);
*IFEND
*ELSE
    setup_path_syntax_descriptor;
    CASE parse.unit.kind OF
    = clc$lex_colon =
      path_syntax := ve_path_syntax;
      rescan_path_element_lex_unit (parse);
    = clc$lex_ellipsis =
      path_syntax := unix_path_syntax;
      clp$find_working_catalog (working_catalog, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      evaluated_file_reference.path_structure := working_catalog.evaluated_file_reference.
            path_structure;
      evaluated_file_reference.path_structure_size := working_catalog.evaluated_file_reference.
            path_structure_size;
      evaluated_file_reference.number_of_path_elements :=
            working_catalog.evaluated_file_reference.number_of_path_elements;

      clp$remove_last_path_element (evaluated_file_reference, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$scan_any_lexical_unit (parse);
    = clc$lex_divide, clc$lex_dot =
      path_syntax := unix_path_syntax;
      rescan_path_element_lex_unit (parse);
    = clc$lex_alpha_number, clc$lex_unsigned_decimal =
      path_syntax := unix_path_syntax;
      rescan_path_element_lex_unit (parse);
    ELSE
{     path_syntax := unix_path_syntax;
{     rescan_path_element_lex_unit (parse);
      ;
    CASEND;
*IFEND

  /parse_file_reference/
    BEGIN
*IF NOT $true(osv$unix)
      IF (initial_path = NIL) AND NOT (parse.unit.kind IN $clt$lexical_unit_kinds
            [clc$lex_colon, clc$lex_dot, clc$lex_name, clc$lex_wild_card_name,
            clc$lex_long_name]) THEN
        osp$set_status_condition (cle$expecting_file_reference, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT /parse_file_reference/;
      IFEND;

{ If the initial_path is not NIL, then it represents an evaluated file variable or function.
{ The initial_path is an absolute path, i.e. it will begin with a colon.

      IF initial_path <> NIL THEN
        initial_path := ^initial_path^ (1, clp$trimmed_string_size (initial_path^));
        clp$identify_lexical_units (initial_path, work_area, units, status);
        IF NOT status.normal THEN
          EXIT /parse_file_reference/;
        IFEND;
        clp$initialize_parse_state (initial_path, units, current_parse);
        clp$scan_non_space_lexical_unit (current_parse);
      ELSE
*IFEND
        current_parse := parse;
*IF NOT $true(osv$unix)
      IFEND;

*ELSE

      element_text := ^current_parse.text^ (current_parse.unit_index, current_parse.unit.size);
*IFEND
      element.kind := clc$not_a_special_path_element;
      CASE current_parse.unit.kind OF
*IF NOT $true(osv$unix)
      = clc$lex_colon =
        ;
      = clc$lex_dot =
        IF (user_identification.family.size = 0) THEN
          osp$set_status_condition (cle$undefined_user_ident, status);
          EXIT /parse_file_reference/;
        IFEND;

        append_element (user_identification.family.size, user_identification.family.value);
*ELSE

      = clc$lex_colon, clc$lex_divide =
{ Checked at top of /parse_path/ loop.

      = clc$lex_dot =

        path_syntax := unix_path_syntax;
        rescan_path_element_lex_unit (current_parse);
*IFEND

      = clc$lex_name =
*IF NOT $true(osv$unix)
        #TRANSLATE (osv$lower_to_upper, current_parse.text^
              (current_parse.unit_index, current_parse.unit.size), element_name);
*ELSE
        #TRANSLATE (osv$lower_to_upper, element_text^, element_name);
*IFEND
        element_size := current_parse.unit.size;
        found := FALSE;
*IF NOT $true(osv$unix)
        clp$scan_any_lexical_unit (current_parse);
*ELSE
        saved_parse := current_parse;
        clp$scan_any_lexical_unit (saved_parse);
*IFEND
*IF NOT $true(osv$unix)

{ If we find a left parenthesis, then evaluate as a function

        IF (current_parse.unit.kind = clc$lex_left_parenthesis) AND
              NOT (clc$prevent_job_context_element IN file_reference_parsing_options) THEN
          evaluate_file_var_or_fcn;
          IF NOT status.normal THEN
            EXIT /parse_file_reference/;
          IFEND;
        IFEND;
        IF NOT found THEN
*IFEND
          check_for_special_path_element (element_name, element_size, element);
*IF $true(osv$unix)
          IF element.kind = clc$not_a_special_path_element THEN
            path_syntax := unix_path_syntax;
            rescan_path_element_lex_unit (current_parse);
            element_text := ^current_parse.text^ (current_parse.unit_index, current_parse.unit.size);
            element_name := element_text^;
            element_size := current_parse.unit.size;
            clp$scan_any_lexical_unit (current_parse);
          ELSE
            path_syntax := ve_path_syntax;
            rescan_path_element_lex_unit (current_parse);
            element_text := ^current_parse.text^ (current_parse.unit_index, current_parse.unit.size);
            #TRANSLATE (osv$lower_to_upper, element_text^, element_name);
            element_size := current_parse.unit.size;
            current_parse := saved_parse;
          IFEND;
{         clp$scan_any_lexical_unit (current_parse);
*IFEND
          evaluate_first_element;
          IF NOT status.normal THEN
            EXIT /parse_file_reference/;
          IFEND;
*IF NOT $true(osv$unix)
        IFEND;
*IFEND

      = clc$lex_wild_card_name =
*IF NOT $true(osv$unix)
        IF NOT (clc$multiple_reference_allowed IN file_reference_parsing_options) THEN
*IFEND
          osp$set_status_condition (cle$wild_card_not_allowed, status);
          EXIT /parse_file_reference/;
*IF NOT $true(osv$unix)
        IFEND;
        append_working_catalog (current_parse.unit.size);
        IF NOT status.normal THEN
          EXIT /parse_file_reference/;
        IFEND;
        append_wild_card (current_parse.text^ (current_parse.unit_index, current_parse.unit.size));
        clp$scan_any_lexical_unit (current_parse);
*IFEND

      = clc$lex_long_name =
*IF NOT $true(osv$unix)
        #SCAN (wild_card_chars, current_parse.text^ (current_parse.unit_index, current_parse.unit.size),
              ignore_scan_index, scan_found_char);
        IF (clc$multiple_reference_allowed IN file_reference_parsing_options) AND
              (scl_options^.wild_card_pattern_type = clc$wc_extended_pattern) AND scan_found_char THEN
*ELSE
        path_syntax := unix_path_syntax;
        rescan_path_element_lex_unit (current_parse);
*IFEND
          append_working_catalog (current_parse.unit.size);
          IF NOT status.normal THEN
            EXIT /parse_file_reference/;
          IFEND;
*IF NOT $true(osv$unix)
          append_wild_card (current_parse.text^ (current_parse.unit_index, current_parse.unit.size));
*ELSE
        append_wild_card (element_text^);
*IFEND
          clp$scan_any_lexical_unit (current_parse);
*IF NOT $true(osv$unix)
        ELSE
          osp$set_status_abnormal ('CL', cle$name_too_long, current_parse.
                text^ (current_parse.unit_index, current_parse.unit.size), status);
          EXIT /parse_file_reference/;
        IFEND;
*ELSE

      = clc$lex_unterminated_string =
        osp$set_status_abnormal ('CL', cle$missing_string_delimiter, element_text^, status);
        EXIT /parse_file_reference/;

      = clc$lex_alpha_number, clc$lex_unsigned_decimal =
        append_working_catalog (current_parse.unit.size);
        IF NOT status.normal THEN
          EXIT /parse_file_reference/;
        IFEND;
        append_element (current_parse.unit.size, element_text^);
        clp$scan_any_lexical_unit (current_parse);

*IFEND
      ELSE
        osp$set_status_condition (cle$expecting_file_reference, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, current_parse, status);
        EXIT /parse_file_reference/;
      CASEND;


    /parse_path/
*IF NOT $true(osv$unix)
      WHILE (current_parse.unit.kind IN $clt$lexical_unit_kinds
            [clc$lex_colon, clc$lex_dot, clc$lex_concatenate]) AND (NOT string_found) DO
        IF (evaluated_file_reference.number_of_path_elements > 0) AND
              (current_parse.unit.kind = clc$lex_colon) THEN
          osp$set_status_condition (cle$unexpected_colon_in_path, status);
          EXIT /parse_file_reference/;
        IFEND;

        IF (current_parse.unit.kind = clc$lex_concatenate) THEN
          IF (evaluated_file_reference.number_of_path_elements = 0) THEN
            osp$set_status_condition (cle$concatenate_cant_be_first, status);
            EXIT /parse_file_reference/;
          ELSEIF clc$prevent_job_context_element IN file_reference_parsing_options THEN
            osp$set_status_abnormal ('CL', cle$no_concat_in_job_indep_path, element_name (1, element_size),
                  status);
            EXIT /parse_file_reference/;
          IFEND;
        IFEND;
*ELSE
      WHILE TRUE DO
        CASE current_parse.unit.kind OF

        = clc$lex_dot =
          ;

        = clc$lex_divide =
          IF path_syntax = ve_path_syntax THEN
            osp$set_status_condition (cle$expecting_file_reference, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, current_parse, status);
            EXIT /parse_file_reference/;
          IFEND;

        = clc$lex_colon =
          IF (path_syntax = unix_path_syntax) OR
                (evaluated_file_reference.number_of_path_elements > 0) THEN
            osp$set_status_condition (cle$unexpected_colon_in_path, status);
            EXIT /parse_file_reference/;
          IFEND;

        = clc$lex_concatenate =
          osp$set_status_abnormal ('CL', cle$no_concat_in_job_indep_path, element_name (1, element_size),
                  status);
          EXIT /parse_file_reference/;

        = clc$lex_ellipsis =
          IF (path_syntax = unix_path_syntax) AND (current_parse.unit.size = 2) THEN
            osp$set_status_condition (cle$expecting_path_element, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, current_parse, status);
            EXIT /parse_file_reference/;
          IFEND;
          EXIT /parse_path/;

        ELSE
          EXIT /parse_path/;
        CASEND;

*IFEND

*IF NOT $true(osv$unix)
        previous_unit_is_concatenate := FALSE;
        clp$scan_wild_card_lexical_unit (current_parse);

        CASE current_parse.unit.kind OF
*ELSE
        scan_next_path_element_lex_unit (current_parse);
        element_text := ^current_parse.text^ (current_parse.unit_index, current_parse.unit.size);
        CASE current_parse.unit.kind OF

*IFEND
        = clc$lex_name =
*IF NOT $true(osv$unix)
          #TRANSLATE (osv$lower_to_upper, current_parse.text^
                (current_parse.unit_index, current_parse.unit.size), element_name);
*ELSE
          IF path_syntax = ve_path_syntax THEN
            #TRANSLATE (osv$lower_to_upper, element_text^, element_name);
          ELSE
            element_name := element_text^;
          IFEND;
*IFEND
          append := TRUE;
          found := FALSE;

          element_size := current_parse.unit.size;
          check_for_special_path_element (element_name, element_size, element);
*IF NOT $true(osv$unix)
          IF (current_parse.previous_non_space_unit.kind = clc$lex_concatenate) THEN
*ELSE
          IF current_parse.previous_non_space_unit.kind = clc$lex_concatenate THEN
*IFEND

{ If a concatenation operator is found and INITIAL_PATH is not NIL, then the value of the file variable
{ or function was incorrectly initialized (probably thru the program interface).

*IF NOT $true(osv$unix)
            IF initial_path <> NIL THEN
              osp$set_status_condition (cle$no_concat_in_var_or_fcn, status);
              RETURN;
            IFEND;
            IF (element.kind = clc$cycle_path_element) OR (element.kind = clc$position_path_element) THEN
              clp$scan_any_lexical_unit (current_parse);
              need_to_scan := FALSE;
            ELSE
              evaluate_name_or_num_var_or_fcn;
              IF NOT status.normal THEN
                EXIT /parse_file_reference/;
              IFEND;
            IFEND;
            previous_unit_is_concatenate := TRUE;
          ELSEIF (element.kind = clc$cycle_path_element) OR (element.kind = clc$position_path_element) THEN
            clp$scan_any_lexical_unit (current_parse);
            need_to_scan := FALSE;
*ELSE
              osp$set_status_condition (cle$no_concat_in_var_or_fcn, status);
              EXIT /parse_file_reference/;
*IFEND
          IFEND;

          CASE element.kind OF

          = clc$command_file_path_element =

            IF evaluated_file_reference.number_of_path_elements <> 0 THEN
              osp$set_status_abnormal ('CL', cle$special_element_not_first, element_name, status);
              EXIT /parse_file_reference/;
            IFEND;

*IF NOT $true(osv$unix)
            IF clc$prevent_job_context_element IN file_reference_parsing_options THEN
              osp$set_status_abnormal ('CL', cle$no_job_context_elements, element_name (1, element_size),
                    status);
              EXIT /parse_file_reference/;
            IFEND;
*IFEND

            evaluate_$command;
            IF NOT status.normal THEN
              EXIT /parse_file_reference/;
            IFEND;

*IF NOT $true(osv$unix)
          = clc$current_family_path_element =

            IF evaluated_file_reference.number_of_path_elements <> 0 THEN
              osp$set_status_abnormal ('CL', cle$special_element_not_first, element_name, status);
              EXIT /parse_file_reference/;
            IFEND;

            IF NOT (clc$file_ref_evaluation_stage IN file_reference_parsing_options) THEN
              IF (user_identification.family.size = 0) THEN
                osp$set_status_condition (cle$undefined_user_ident, status);
                EXIT /parse_file_reference/;
              IFEND;
              element_name := user_identification.family.value;
              element_size := user_identification.family.size;
            IFEND;
            path_handle.kind := clc$not_a_path_handle;
            previous_element_is_generic := clc$file_ref_evaluation_stage IN file_reference_parsing_options;

          = clc$current_user_path_element =

            IF (NOT (clc$file_ref_evaluation_stage IN file_reference_parsing_options)) AND
                  ((evaluated_file_reference.number_of_path_elements > 1) OR
                  ((evaluated_file_reference.number_of_path_elements = 1) AND
                  (fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local))) THEN
              osp$set_status_abnormal ('CL', cle$special_element_not_first, element_name, status);
              EXIT /parse_file_reference/;
            IFEND;

            IF cycle_element_found OR position_element_found THEN
              osp$set_status_condition (no_extra [position_element_found], status);
              EXIT /parse_file_reference/;
            IFEND;

            IF NOT (clc$file_ref_evaluation_stage IN file_reference_parsing_options) THEN
              IF evaluated_file_reference.number_of_path_elements = 0 THEN
                IF (user_identification.family.size = 0) THEN
                  osp$set_status_condition (cle$undefined_user_ident, status);
                  EXIT /parse_file_reference/;
                IFEND;
                append_element (user_identification.family.size, user_identification.family.value);
              IFEND;
              IF (user_identification.user.size = 0) THEN
                osp$set_status_condition (cle$undefined_user_ident, status);
                EXIT /parse_file_reference/;
              IFEND;
              element_name := user_identification.user.value;
              element_size := user_identification.user.size;
            IFEND;
            path_handle.kind := clc$not_a_path_handle;
            previous_element_is_generic := clc$file_ref_evaluation_stage IN file_reference_parsing_options;

          = clc$cycle_path_element, clc$var_or_fcn_cyc_path_element =

            IF command_or_program_name_found OR (evaluated_file_reference.number_of_path_elements <= 1) THEN
              osp$set_status_condition (cle$cycle_must_follow_file_name, status);
              EXIT /parse_file_reference/;
            IFEND;

            cycle_offset_found := FALSE;
            cycle_offset := 0;

            IF previous_unit_is_concatenate THEN
              IF evaluated_file_reference.multiple_reference_specified THEN
                osp$set_status_condition (cle$no_cyc_expr_with_wild_card, status);
                EXIT /parse_file_reference/;
              IFEND;

              check_for_cycle_offset;
              IF NOT status.normal THEN
                EXIT /parse_file_reference/;
              IFEND;
              cycle_offset_found := TRUE;
            IFEND;

            IF element.kind = clc$cycle_path_element THEN
              evaluated_file_reference.cycle_reference := element.cycle_reference;
            ELSE

{ "element.kind" gets set to clc$var_or_fcn_cyc_path_element if a name was evaluated to be an integer
{ variable or function. "number" will be set to the value of that variable or function.

              IF ((number + cycle_offset) < pfc$minimum_cycle_number) OR
                    ((number + cycle_offset) > pfc$maximum_cycle_number) THEN
                osp$set_status_condition (pfe$bad_cycle_number, status);
                osp$append_status_integer (osc$status_parameter_delimiter, (number + cycle_offset), 10, FALSE,
                      status);
                EXIT /parse_file_reference/;
              IFEND;
              evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
              evaluated_file_reference.cycle_reference.cycle_number := number + cycle_offset;
            IFEND;

            cycle_element_found := TRUE;
            path_handle.kind := clc$not_a_path_handle;

          = clc$defer_eval_path_element =

            IF evaluated_file_reference.number_of_path_elements <> 0 THEN
              osp$set_status_abnormal ('CL', cle$special_element_not_first, element_name, status);
              EXIT /parse_file_reference/;
            IFEND;

            IF clc$prevent_job_context_element IN file_reference_parsing_options THEN
              osp$set_status_abnormal ('CL', cle$no_job_context_elements, element_name (1, element_size),
                    status);
              EXIT /parse_file_reference/;
            IFEND;

            evaluate_$defer;
            IF NOT status.normal THEN
              EXIT /parse_file_reference/;
            IFEND;
*IFEND

          = clc$job_file_path_element, clc$standard_file_path_element =

*IF NOT $true(osv$unix)
            IF clc$prevent_job_context_element IN file_reference_parsing_options THEN
              osp$set_status_abnormal ('CL', cle$no_job_context_elements, element_name (1, element_size),
                    status);
              EXIT /parse_file_reference/;
            IFEND;
*IFEND

            IF standard_file <> clc$sf_not_a_standard_file THEN
              standard_file := clc$sf_not_a_standard_file;
*IF NOT $true(osv$unix)
            ELSEIF evaluated_file_reference.path_structure (1,
                  evaluated_file_reference.path_structure_size) = ($CHAR (6) CAT '$LOCAL') THEN
*ELSE
            ELSEIF evaluated_file_reference.path_structure (1, evaluated_file_reference.path_structure_size) =
                  ($CHAR (6) CAT '$LOCAL') THEN
*IFEND
              standard_file := element.standard_file;
            IFEND;

*IF NOT $true(osv$unix)
            IF standard_file = clc$sf_not_a_standard_file THEN
              IF cycle_element_found OR position_element_found THEN
                IF (($clt$file_ref_parsing_options [clc$evaluating_command_ref,
                      clc$evaluating_entry_point_ref] * file_reference_parsing_options) =
                      $clt$file_ref_parsing_options []) OR command_or_program_name_found THEN
                  osp$set_status_condition (no_extra [position_element_found], status);
                  EXIT /parse_file_reference/;
                IFEND;
                command_or_program_name.value := element_name;
                command_or_program_name.size := element_size;
                command_or_program_name_found := TRUE;
                IF clc$evaluating_command_ref IN file_reference_parsing_options THEN
                  form := clc$module_or_file_command_ref;
                IFEND;
              IFEND;
            IFEND;
*IFEND

            path_handle.kind := clc$not_a_path_handle;
            previous_element_is_generic := FALSE;

          = clc$local_catalog_path_element =

            IF evaluated_file_reference.number_of_path_elements <> 0 THEN
              osp$set_status_abnormal ('CL', cle$special_element_not_first, element_name, status);
              EXIT /parse_file_reference/;
            IFEND;

*IF NOT $true(osv$unix)
            IF clc$prevent_job_context_element IN file_reference_parsing_options THEN
              osp$set_status_abnormal ('CL', cle$no_job_context_elements, element_name (1, element_size),
                    status);
              EXIT /parse_file_reference/;
            IFEND;
*IFEND

            element_name := '$LOCAL';
            element_size := 6;
            path_handle.kind := clc$not_a_path_handle;
            previous_element_is_generic := FALSE;

          = clc$not_a_special_path_element =

*IF NOT $true(osv$unix)
            IF cycle_element_found OR position_element_found THEN
              IF (($clt$file_ref_parsing_options [clc$evaluating_command_ref,
                    clc$evaluating_entry_point_ref] * file_reference_parsing_options) =
                    $clt$file_ref_parsing_options []) OR command_or_program_name_found THEN
                osp$set_status_condition (no_extra [position_element_found], status);
                EXIT /parse_file_reference/;
              IFEND;

              command_or_program_name.value := element_name;
              command_or_program_name.size := element_size;
              command_or_program_name_found := TRUE;
              IF clc$evaluating_command_ref IN file_reference_parsing_options THEN
                form := clc$module_or_file_command_ref;
              IFEND;
            IFEND;

            IF NOT evaluated_file_reference.multiple_reference_specified AND
                  (clc$multiple_reference_allowed IN file_reference_parsing_options) AND
                  (scl_options^.wild_card_pattern_type = clc$wc_extended_pattern) THEN
              #SCAN (wild_card_chars, element_name, ignore_scan_index, scan_found_char);
              IF scan_found_char THEN
                IF evaluated_file_reference.number_of_path_elements = 0 THEN
                  osp$set_status_condition (cle$wild_card_cant_be_first, status);
                  EXIT /parse_file_reference/;
                IFEND;
                evaluated_file_reference.multiple_reference_specified := TRUE;
              IFEND;
*ELSE
            IF path_syntax = unix_path_syntax THEN

{ No folding letters to upper case for a UNIX style path.

              element_name := element_text^;
            IFEND;

            IF contains_wild_card_char (element_name) THEN
              IF evaluated_file_reference.number_of_path_elements = 0 THEN
                osp$set_status_condition (cle$wild_card_cant_be_first, status);
                EXIT /parse_file_reference/;
              IFEND;
*IFEND
            IFEND;

            path_handle.kind := clc$not_a_path_handle;
*IF NOT $true(osv$unix)
            previous_element_is_generic := FALSE;
*IFEND
            standard_file := clc$sf_not_a_standard_file;

*IF NOT $true(osv$unix)
          = clc$position_path_element =

            IF evaluated_file_reference.number_of_path_elements = 0 THEN
              osp$set_status_condition (cle$position_must_be_last, status);
              EXIT /parse_file_reference/;
            IFEND;

            IF (($clt$file_ref_parsing_options [clc$evaluating_command_ref,
                  clc$evaluating_entry_point_ref] * file_reference_parsing_options) <>
                  $clt$file_ref_parsing_options []) THEN
              osp$set_status_condition (cle$no_pos_on_cmnd_entry_pt_ref, status);
              EXIT /parse_file_reference/;
            IFEND;

            position_element_found := TRUE;
            evaluated_file_reference.path_handle_info.path_handle.open_position.specified := TRUE;
            evaluated_file_reference.path_handle_info.path_handle.open_position.value := element.position;

          = clc$reversal_path_element =

            IF evaluated_file_reference.multiple_reference_specified THEN
              osp$set_status_condition (cle$up_cant_follow_wild_card, status);
              EXIT /parse_file_reference/;
            IFEND;

            IF evaluated_file_reference.number_of_path_elements = 0 THEN
              IF NOT (clc$file_ref_evaluation_stage IN file_reference_parsing_options) THEN
                IF clc$prevent_job_context_element IN file_reference_parsing_options THEN
                  IF (user_identification.family.size = 0) OR (user_identification.user.size = 0) THEN
                    osp$set_status_condition (cle$undefined_user_ident, status);
                    EXIT /parse_file_reference/;
                  IFEND;
                  append_element (user_identification.family.size, user_identification.family.value);
                  append_element (user_identification.user.size, user_identification.user.value);
                ELSE
                  clp$find_working_catalog (working_catalog);
                  evaluated_file_reference.path_structure := working_catalog^^.evaluated_file_reference.
                        path_structure;
                  evaluated_file_reference.path_structure_size :=
                        working_catalog^^.evaluated_file_reference.path_structure_size;
                  evaluated_file_reference.number_of_path_elements :=
                        working_catalog^^.evaluated_file_reference.number_of_path_elements;
                IFEND;
                clp$remove_last_path_element (evaluated_file_reference, status);
                IF NOT status.normal THEN
                  EXIT /parse_file_reference/;
                IFEND;
                append := FALSE;
              ELSE
                append_element (16, '$WORKING_CATALOG');
                previous_element_is_generic := TRUE;
              IFEND;
            ELSEIF (NOT (clc$file_ref_evaluation_stage IN file_reference_parsing_options)) OR
                  (NOT previous_element_is_generic) THEN
              clp$remove_last_path_element (evaluated_file_reference, status);
              IF NOT status.normal THEN
                EXIT /parse_file_reference/;
              IFEND;
              evaluated_file_reference.path_handle_info.path_handle_present := FALSE;
              evaluated_file_reference.path_handle_info.path_handle.open_position.specified := FALSE;
              evaluated_file_reference.cycle_reference.specification := fsc$cycle_omitted;
              cycle_element_found := FALSE;
              append := FALSE;
            IFEND;

          = clc$source_path_element =

            IF evaluated_file_reference.number_of_path_elements <> 0 THEN
              osp$set_status_abnormal ('CL', cle$special_element_not_first, element_name, status);
              EXIT /parse_file_reference/;
            IFEND;

            IF clc$prevent_job_context_element IN file_reference_parsing_options THEN
              osp$set_status_abnormal ('CL', cle$no_job_context_elements, element_name (1, element_size),
                    status);
              EXIT /parse_file_reference/;
            IFEND;

            IF NOT (clc$file_ref_evaluation_stage IN file_reference_parsing_options) THEN
              find_command_source;
              IF NOT status.normal THEN
                EXIT /parse_file_reference/;
              IFEND;
              append := FALSE;
            IFEND;
            previous_element_is_generic := clc$file_ref_evaluation_stage IN file_reference_parsing_options;

          = clc$system_path_element =

            IF cycle_element_found OR position_element_found THEN
              osp$set_status_condition (no_extra [position_element_found], status);
              EXIT /parse_file_reference/;
            IFEND;

            path_handle.kind := clc$not_a_path_handle;
            previous_element_is_generic := FALSE;
*IFEND

          = clc$unsupported_path_element =

            osp$set_status_abnormal ('CL', cle$special_element_not_first, element_name, status);
            EXIT /parse_file_reference/;

*IF NOT $true(osv$unix)
          = clc$traversal_path_element =

            IF clc$multiple_reference_allowed IN file_reference_parsing_options THEN
              evaluated_file_reference.multiple_reference_specified := TRUE;
            ELSE
              osp$set_status_condition (cle$wild_card_not_allowed, status);
              EXIT /parse_file_reference/;
            IFEND;

          = clc$workin_catalog_path_element =

            IF evaluated_file_reference.number_of_path_elements <> 0 THEN
              osp$set_status_abnormal ('CL', cle$special_element_not_first, element_name, status);
              EXIT /parse_file_reference/;
            IFEND;

            IF clc$prevent_job_context_element IN file_reference_parsing_options THEN
              osp$set_status_abnormal ('CL', cle$no_job_context_elements, element_name (1, element_size),
                    status);
              EXIT /parse_file_reference/;
            IFEND;

            IF NOT (clc$file_ref_evaluation_stage IN file_reference_parsing_options) THEN
              clp$find_working_catalog (working_catalog);
              evaluated_file_reference.path_structure := working_catalog^^.evaluated_file_reference.
                    path_structure;
              evaluated_file_reference.path_structure_size := working_catalog^^.evaluated_file_reference.
                    path_structure_size;
              evaluated_file_reference.number_of_path_elements :=
                    working_catalog^^.evaluated_file_reference.number_of_path_elements;
              append := FALSE;
            ELSE
              element_name := '$WORKING_CATALOG';
              element_size := 16;
            IFEND;
            path_handle.kind := clc$not_a_path_handle;
            previous_element_is_generic := TRUE;
*IFEND

          CASEND;

*IF NOT $true(osv$unix)
          IF (NOT (path_handle.kind = clc$command_file_handle)) AND (NOT position_element_found) THEN
            path_handle.kind := clc$not_a_path_handle;
            IF (NOT command_or_program_name_found) AND (NOT cycle_element_found) THEN
              IF append THEN
                IF (evaluated_file_reference.number_of_path_elements >= fsc$max_path_elements) OR
                      ((evaluated_file_reference.path_structure_size + 1 + element_size) >
                      fsc$max_path_size) THEN
                  osp$set_status_condition (cle$file_reference_too_long, status);
                  EXIT /parse_file_reference/;
                IFEND;
*ELSE
          IF NOT (path_handle.kind = clc$command_file_handle) THEN
            path_handle.kind := clc$not_a_path_handle;
*IFEND
                append_element (element_size, element_name);
*IF NOT $true(osv$unix)
              IFEND;
            IFEND;
*IFEND
          IFEND;

*IF $true(osv$unix)
        = clc$lex_alpha_number =
          IF path_syntax = ve_path_syntax THEN
            osp$set_status_condition (cle$expecting_path_element, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, current_parse, status);
            EXIT /parse_file_reference/;
          IFEND;
          append_element (current_parse.unit.size, element_text^);

        = clc$lex_ellipsis =
          IF path_syntax = ve_path_syntax THEN
            osp$set_status_condition (cle$expecting_path_element, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, current_parse, status);
            EXIT /parse_file_reference/;
          IFEND;

          clp$remove_last_path_element (evaluated_file_reference, status);
          IF NOT status.normal THEN
            EXIT /parse_file_reference/;
          IFEND;
*IFEND

        = clc$lex_unsigned_decimal =
*IF NOT $true(osv$unix)

          IF current_parse.previous_non_space_unit.kind = clc$lex_concatenate THEN
            osp$set_status_condition (cle$var_or_fcn_follows_concat, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, current_parse, status);
            EXIT /parse_file_reference/;
          IFEND;

          IF command_or_program_name_found OR (evaluated_file_reference.number_of_path_elements <= 1) THEN
            osp$set_status_condition (cle$cycle_must_follow_file_name, status);
            EXIT /parse_file_reference/;
          IFEND;

          clp$evaluate_unsigned_decimal (current_parse.text^
                (current_parse.unit_index, current_parse.unit.size), number, status);
          IF NOT status.normal THEN
            EXIT /parse_file_reference/;
          IFEND;
          IF (number < pfc$minimum_cycle_number) OR (number > pfc$maximum_cycle_number) THEN
            osp$set_status_condition (pfe$bad_cycle_number, status);
            osp$append_status_integer (osc$status_parameter_delimiter, number, 10, FALSE, status);
            EXIT /parse_file_reference/;
          IFEND;
          IF path_handle.kind = clc$command_file_handle THEN
            osp$set_status_condition (cle$inappropriate_cmnd_file_ref, status);
            EXIT /parse_file_reference/;
          IFEND;

          element.kind := clc$cycle_path_element;
          evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
          evaluated_file_reference.cycle_reference.cycle_number := number;
          cycle_element_found := TRUE;
          path_handle.kind := clc$not_a_path_handle;

        = clc$lex_string =

          IF current_parse.previous_non_space_unit.kind = clc$lex_concatenate THEN
            osp$set_status_condition (cle$var_or_fcn_follows_concat, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, current_parse, status);
            EXIT /parse_file_reference/;
          IFEND;

          IF cycle_element_found AND command_or_program_name_found THEN
            osp$set_status_condition (cle$cycle_must_follow_file_name, status);
            EXIT /parse_file_reference/;
          IFEND;

          IF (clc$evaluating_entry_point_ref IN file_reference_parsing_options) AND NOT string_found THEN
            process_program_name;
*ELSE
          IF path_syntax = unix_path_syntax THEN
            append_element (current_parse.unit.size, element_text^);
          ELSE
            IF evaluated_file_reference.number_of_path_elements <= 1 THEN
              osp$set_status_condition (cle$cycle_must_follow_file_name, status);
              EXIT /parse_file_reference/;
            IFEND;
            clp$evaluate_unsigned_decimal (element_text^, number, status);
*IFEND
            IF NOT status.normal THEN
              EXIT /parse_file_reference/;
            IFEND;
*IF NOT $true(osv$unix)
          ELSE
            osp$set_status_condition (cle$expecting_path_element, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, current_parse, status);
            EXIT /parse_file_reference/;
          IFEND;
*ELSE
            element.kind := clc$cycle_path_element;
            path_handle.kind := clc$not_a_path_handle;
          IFEND;


        = clc$lex_unterminated_string =
          osp$set_status_abnormal ('CL', cle$missing_string_delimiter, element_text^, status);
          EXIT /parse_file_reference/;
*IFEND

        = clc$lex_wild_card_name =
*IF NOT $true(osv$unix)

          IF clc$multiple_reference_allowed IN file_reference_parsing_options THEN
            IF current_parse.previous_non_space_unit.kind = clc$lex_concatenate THEN
              osp$set_status_condition (cle$var_or_fcn_follows_concat, status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, current_parse, status);
              EXIT /parse_file_reference/;
            IFEND;

            append_wild_card (current_parse.text^ (current_parse.unit_index, current_parse.unit.size));
          ELSE
*IFEND
            osp$set_status_condition (cle$wild_card_not_allowed, status);
            EXIT /parse_file_reference/;
*IF NOT $true(osv$unix)
          IFEND;
*IFEND

        = clc$lex_long_name =
*IF NOT $true(osv$unix)
          #SCAN (wild_card_chars, current_parse.text^ (current_parse.unit_index, current_parse.unit.size),
                ignore_scan_index, scan_found_char);
          IF (clc$multiple_reference_allowed IN file_reference_parsing_options) AND
                (scl_options^.wild_card_pattern_type = clc$wc_extended_pattern) AND scan_found_char THEN
            append_wild_card (current_parse.text^ (current_parse.unit_index, current_parse.unit.size));
          ELSE
            osp$set_status_abnormal ('CL', cle$name_too_long, current_parse.
                  text^ (current_parse.unit_index, current_parse.unit.size), status);
            EXIT /parse_file_reference/;
          IFEND;

        ELSE

*ELSE
          IF path_syntax <> unix_path_syntax THEN
            osp$set_status_abnormal ('CL', cle$name_too_long, element_text^, status);
            EXIT /parse_file_reference/;
          IFEND;
          append_wild_card (element_text^);

        ELSE
{ Check if a '/' was specified - root directory }
          IF (current_parse.previous_non_space_unit.kind = clc$lex_divide) AND
                (evaluated_file_reference.number_of_path_elements = 0) THEN
            append_wild_card ('/');
            EXIT /parse_path/;
          IFEND;
*IFEND
          osp$set_status_condition (cle$expecting_path_element, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, current_parse, status);
          EXIT /parse_file_reference/;
        CASEND;

        update_current_parse;

      WHILEND /parse_path/;

      complete_evaluation;

    END /parse_file_reference/;

    work_area := saved_work_area;

  PROCEND clp$complete_file_ref_parse;
*IF $true(osv$unix)
?? TITLE := 'clp$convert_file_ref_to_string', EJECT ??
*copyc clh$convert_file_ref_to_string

  PROCEDURE [XDCL, #GATE] clp$convert_file_ref_to_string
    (    evaluated_file_reference: fst$evaluated_file_reference;
         include_open_position: boolean;
     VAR str: fst$path;
     VAR size: fst$path_size;
     VAR status: ost$status);

    TYPE
      chars = set of char;

    VAR
      cycle_string: ^ost$string,
      element: clt$special_path_element,
      element_index: fst$path_element_index,
      element_name: fst$path_element_name,
      element_size: fst$path_element_size,
      i: fst$path_index,
      ignore_scan_index: integer,
      j: fst$path_index,
      non_standard_1st_element_chars: chars,
      non_standard_element_chars: chars,
      open_pos_size: 4 .. 5,
      previous_element_is_generic: boolean,
      quote_element: boolean;


    status.normal := TRUE;

    non_standard_1st_element_chars := -$chars ['#', '$', '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
          'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '[', '\', ']',
          '^', '_', '`', '{', '|', '}', '~'];
    non_standard_element_chars := -$chars ['#', '$', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '@',
          'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',
          'U', 'V', 'W', 'X', 'Y', 'Z', '[', '\', ']', '^', '_', '`', '{', '|', '}', '~'];

    str := '';
    i := 1;
    j := 1;
    size := evaluated_file_reference.path_structure_size;
    element_index := 1;
    previous_element_is_generic := FALSE;
    REPEAT
      element_size := $INTEGER (evaluated_file_reference.path_structure (i));
      i := i + 1;
      str (j) := '.';
      j := j + 1;
      quote_element := evaluated_file_reference.path_structure (i) IN non_standard_1st_element_chars;
      IF quote_element THEN
        previous_element_is_generic := FALSE;
      ELSE
        #SCAN (non_standard_element_chars, evaluated_file_reference.path_structure (i, element_size),
              ignore_scan_index, quote_element);
        IF quote_element OR (evaluated_file_reference.path_structure (i) <> '$') THEN
          previous_element_is_generic := FALSE;
        ELSE
          element_name := evaluated_file_reference.path_structure (i, element_size);
          check_for_special_path_element (element_name, element_size, element);
          CASE element.kind OF
          = clc$current_family_path_element, clc$defer_eval_path_element, clc$source_path_element,
                clc$workin_catalog_path_element, clc$unsupported_path_element =
            previous_element_is_generic := element_index = 1;
            quote_element := NOT previous_element_is_generic;
          = clc$current_user_path_element =
            previous_element_is_generic := element_index <= 2;
            quote_element := NOT previous_element_is_generic;
          = clc$local_catalog_path_element, clc$command_file_path_element =
            previous_element_is_generic := FALSE;
            quote_element := element_index > 1;
          = clc$cycle_path_element, clc$position_path_element, clc$var_or_fcn_cyc_path_element,
                  clc$no_cycle_path_element, clc$no_position_path_element =
            previous_element_is_generic := FALSE;
            quote_element := TRUE;
          = clc$reversal_path_element =
            quote_element := NOT previous_element_is_generic;
          { previous_element_is_generic := previous_element_is_generic;
          = clc$traversal_path_element =
            previous_element_is_generic := FALSE;
          ELSE
          { clc$not_a_special_path_element
          { clc$system_path_element
          { clc$job_file_path_element
          { clc$standard_file_path_element
            previous_element_is_generic := FALSE;
          CASEND;
        IFEND;
      IFEND;
      IF NOT quote_element THEN
        str (j, element_size) := evaluated_file_reference.path_structure (i, element_size);
        j := j + element_size;
        i := i + element_size;
      ELSE
        IF (size + 2) > fsc$max_path_size THEN
          osp$set_status_condition (cle$file_reference_too_long, status);
          RETURN;
        IFEND;
        size := size + 2;
        str (j) := '''';
        j := j + 1;
        REPEAT
          IF evaluated_file_reference.path_structure (i) = '''' THEN
            IF (size + 1) > fsc$max_path_size THEN
              osp$set_status_condition (cle$file_reference_too_long, status);
              RETURN;
            IFEND;
            size := size + 1;
            str (j) := '''';
            j := j + 1;
          IFEND;
          str (j) := evaluated_file_reference.path_structure (i);
          i := i + 1;
          j := j + 1;
          element_size := element_size - 1;
        UNTIL element_size <= 0;
        str (j) := '''';
        j := j + 1;
      IFEND;
      element_index := element_index + 1;
    UNTIL i > evaluated_file_reference.path_structure_size;
    str (1) := ':';

  PROCEND clp$convert_file_ref_to_string;
?? TITLE := 'clp$conv_unix_file_ref_to_str', EJECT ??
*copyc clh$conv_unix_file_ref_to_str

  PROCEDURE [XDCL, #GATE] clp$conv_unix_file_ref_to_str
    (    evaluated_file_reference: fst$evaluated_file_reference;
     VAR str: fst$path;
     VAR size: fst$path_size;
     VAR status: ost$status);

    TYPE
      chars = set of char;

    VAR
      element_size: fst$path_element_size,
      i: fst$path_index,
      ignore_scan_index: integer,
      j: fst$path_index,
      non_standard_1st_element_chars: chars,
      non_standard_element_chars: chars,
      open_pos_size: 4 .. 5,
      quote_element: boolean;


    status.normal := TRUE;

    non_standard_1st_element_chars := -$chars ['#', '$', '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
          'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '[', '\', ']',
          '^', '_', '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q',
          'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', '{', '|', '}', '~'];
    non_standard_element_chars := -$chars ['#', '$', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '@',
          'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',
          'U', 'V', 'W', 'X', 'Y', 'Z', '[', '\', ']', '^', '_', '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h',
          'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', '{', '|',
          '}', '~'];

    str := '';
    i := 1;
    j := 1;
    size := evaluated_file_reference.path_structure_size;
    REPEAT
      element_size := $INTEGER (evaluated_file_reference.path_structure (i));
      i := i + 1;
      str (j) := '/';
      j := j + 1;
      quote_element := evaluated_file_reference.path_structure (i) IN non_standard_1st_element_chars;
      IF quote_element AND (evaluated_file_reference.path_structure (i, element_size) = '/') THEN
        IF size > 1 THEN
          element_size := $INTEGER (evaluated_file_reference.path_structure (i+1));
          i := i + 2;
        ELSE
{ The path consists solely of a '/' - root directory.
          RETURN;
        IFEND;
      IFEND;
      IF NOT quote_element THEN
        #SCAN (non_standard_element_chars, evaluated_file_reference.path_structure (i, element_size),
              ignore_scan_index, quote_element);
      IFEND;
      IF NOT quote_element THEN
        str (j, element_size) := evaluated_file_reference.path_structure (i, element_size);
        j := j + element_size;
        i := i + element_size;
      ELSE
        IF (size + 2) > fsc$max_path_size THEN
          osp$set_status_condition (cle$file_reference_too_long, status);
          RETURN;
        IFEND;
        REPEAT
          IF evaluated_file_reference.path_structure (i) = '''' THEN
            IF (size + 1) > fsc$max_path_size THEN
              osp$set_status_condition (cle$file_reference_too_long, status);
              RETURN;
            IFEND;
            size := size + 1;
            str (j) := '''';
            j := j + 1;
          IFEND;
          str (j) := evaluated_file_reference.path_structure (i);
          i := i + 1;
          j := j + 1;
          element_size := element_size - 1;
        UNTIL element_size <= 0;
      IFEND;
    UNTIL i > evaluated_file_reference.path_structure_size;

  PROCEND clp$conv_unix_file_ref_to_str;
*ELSE
?? TITLE := 'clp$convert_cyc_ref_to_cyc_sel', EJECT ??
*copyc clh$convert_cyc_ref_to_cyc_sel

*copyc clp$convert_cyc_ref_to_cyc_sel
*IFEND

?? TITLE := 'clp$convert_str_to_path_handle', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$convert_str_to_path_handle
    (    str: string ( * );
         delete_allowed: boolean;
         resolve_path: boolean;
         include_open_pos_in_handle: boolean;
*IF NOT $true(osv$unix)
     VAR path_handle_name: fst$path_handle_name;
*ELSE
     VAR path_handle_name: fst$path;
*IFEND
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

    VAR
*IF NOT $true(osv$unix)
      path_handle: fmt$path_handle,
      pt_results: bat$process_pt_results,
      work_list: bat$process_pt_work_list;
*ELSE
      path_handle_size: fst$path_size,
      path_handle: fmt$path_handle;
*IFEND


    status.normal := TRUE;

    clp$setup_and_parse_file_ref (str, $clt$file_ref_parsing_options [clc$command_file_ref_allowed],
          clv$user_identification, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    IF evaluated_file_reference.path_resolution = fsc$command_file_path THEN
      clp$construct_block_handle_name (evaluated_file_reference.block_handle, path_handle_name);
*ELSE
    IF evaluated_file_reference.command_file_path.found THEN
      clp$construct_block_handle_name (evaluated_file_reference.command_file_path.block_handle,
            path_handle_name);
*IFEND
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    work_list := $bat$process_pt_work_list [bac$record_path];
    IF NOT delete_allowed THEN
      work_list := work_list + $bat$process_pt_work_list [bac$externalize_path_handle];
    IFEND;
    IF NOT evaluated_file_reference.path_handle_info.path_handle_present THEN
      IF (resolve_path OR ((evaluated_file_reference.cycle_reference.specification <> fsc$cycle_omitted) AND
            (evaluated_file_reference.cycle_reference.specification <> fsc$cycle_number))) THEN
        work_list := work_list + $bat$process_pt_work_list [bac$resolve_path, bac$resolve_to_catalog];
      IFEND;
      bap$process_pt_request (work_list, osc$null_name, evaluated_file_reference, pt_results, status);
      IF (NOT status.normal) AND osp$file_access_condition (status) THEN
        process_pt_request (work_list, osc$null_name, evaluated_file_reference, pt_results, status);
      IFEND;
    ELSEIF resolve_path AND (evaluated_file_reference.cycle_reference.specification <> fsc$cycle_number) THEN
      work_list := work_list + $bat$process_pt_work_list [bac$resolve_path, bac$resolve_to_catalog];
      bap$process_pt_request (work_list, osc$null_name, evaluated_file_reference, pt_results, status);
      IF (NOT status.normal) AND osp$file_access_condition (status) THEN
        process_pt_request (work_list, osc$null_name, evaluated_file_reference, pt_results, status);
      IFEND;
    IFEND;

    path_handle := evaluated_file_reference.path_handle_info.path_handle;
    IF NOT include_open_pos_in_handle THEN
      path_handle.open_position.specified := FALSE;
    IFEND;

    clp$construct_path_handle_name (path_handle, path_handle_name);

    process_status (evaluated_file_reference.path_handle_info, fsc$unresolved_path,
          'clp$convert_str_to_path_handle', status);
*ELSE
    IF evaluated_file_reference.standard_file THEN
      path_handle_name := evaluated_file_reference.unix_standard_file.unix_file_name;
    ELSE
      clp$conv_unix_file_ref_to_str (evaluated_file_reference, path_handle_name,
            path_handle_size, status);
    IFEND;
*IFEND

  PROCEND clp$convert_str_to_path_handle;
?? TITLE := 'clp$convert_string_to_file', EJECT ??
*copyc clh$convert_string_to_file

  PROCEDURE [XDCL, #GATE] clp$convert_string_to_file
    (    str: string ( * );
*IF NOT $true(osv$unix)
     VAR file: clt$file;
*ELSE
     VAR file: fst$path;
*IFEND
     VAR status: ost$status);

    VAR
      ignore_evaluated_file_reference: fst$evaluated_file_reference;

    #KEYPOINT (osk$entry, 0, clk$convert_string_to_file);

    status.normal := TRUE;

*IF NOT $true(osv$unix)
    clp$convert_str_to_path_handle (str, FALSE, FALSE, TRUE, file.local_file_name,
*ELSE
    clp$convert_str_to_path_handle (str, FALSE, FALSE, TRUE, file,
*IFEND
          ignore_evaluated_file_reference, status);

    #KEYPOINT (osk$exit, 0, clk$convert_string_to_file);

  PROCEND clp$convert_string_to_file;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$convert_string_to_file_path', EJECT ??
*copyc clh$convert_string_to_file_path

  PROCEDURE [XDCL, #GATE] clp$convert_string_to_file_path
    (    str: string ( * );
         use_$local_as_working_catalog: boolean;
         return_path_handle_name: boolean;
     VAR path_handle_name: fst$path_handle_name;
     VAR resolved_path: fst$resolved_file_reference;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context,
      evaluated_file_reference: fst$evaluated_file_reference,
      file_reference_parsing_options: clt$file_ref_parsing_options,
      ignore_pt_results: bat$process_pt_results;


    status.normal := TRUE;

    file_reference_parsing_options := $clt$file_ref_parsing_options [clc$command_file_ref_allowed];
    IF use_$local_as_working_catalog THEN
      file_reference_parsing_options := file_reference_parsing_options +
            $clt$file_ref_parsing_options [clc$use_$local_as_working_cat];
    IFEND;

    clp$evaluate_file_reference (str, file_reference_parsing_options, FALSE, evaluated_file_reference,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    bap$get_resolved_file_reference (evaluated_file_reference, resolved_path, status);
    IF NOT status.normal THEN
      IF osp$file_access_condition (status) THEN
        PUSH context;
        context^ := osv$initial_exception_context;
        context^.file.selector := osc$ecp_evaluated_file_ref;
        context^.file.evaluated_file_reference := evaluated_file_reference;
        REPEAT
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
          bap$get_resolved_file_reference (evaluated_file_reference, resolved_path, status);
        UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
      IFEND;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF return_path_handle_name THEN
      bap$process_pt_request ($bat$process_pt_work_list [bac$record_path, bac$externalize_path_handle],
            osc$null_name, evaluated_file_reference, ignore_pt_results, status);
      IF (NOT status.normal) AND osp$file_access_condition (status) THEN
        process_pt_request ($bat$process_pt_work_list [bac$record_path, bac$externalize_path_handle],
              osc$null_name, evaluated_file_reference, ignore_pt_results, status);
      IFEND;
      process_status (evaluated_file_reference.path_handle_info, fsc$unresolved_path,
            'clp$convert_string_to_file_path', status);
      IF status.normal THEN
        clp$construct_path_handle_name (evaluated_file_reference.path_handle_info.path_handle,
              path_handle_name);
      IFEND;
    ELSE
      path_handle_name := osc$null_name;
    IFEND;

  PROCEND clp$convert_string_to_file_path;
*IFEND
?? TITLE := 'clp$convert_string_to_file_ref', EJECT ??
*copyc clh$convert_string_to_file_ref

  PROCEDURE [XDCL, #GATE] clp$convert_string_to_file_ref
    (    str: string ( * );
     VAR parsed_file_reference: fst$parsed_file_reference;
     VAR status: ost$status);

    VAR
      evaluated_file_reference: fst$evaluated_file_reference;

    status.normal := TRUE;

    clp$setup_and_parse_file_ref (str, $clt$file_ref_parsing_options
          [clc$command_file_ref_allowed, clc$file_ref_evaluation_stage], clv$user_identification,
          evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    convert_eval_to_parsed_file_ref (evaluated_file_reference, TRUE, parsed_file_reference, status);

  PROCEND clp$convert_string_to_file_ref;
?? TITLE := 'clp$file_ref_is_pre_evaluated', EJECT ??
*copyc clh$file_ref_is_pre_evaluated

*copyc clp$file_ref_is_pre_evaluated

*IF NOT $true(osv$unix)
?? TITLE := 'clp$get_file_cycles', EJECT ??

  PROCEDURE [XDCL] clp$get_file_cycles
    (    file: fst$file_reference;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cycle_array: ^array [1 .. * ] of fst$cycle_number;
     VAR status: ost$status);

    VAR
      object_info: ^fst$goi_object_information,
      information_request: fst$goi_information_request,
      saved_work_area: ^clt$work_area,
      cycle_object_list: ^fst$goi_object_list,
      i: pft$cycle_number,
      number_of_cycles: integer,
      catalog_depth: fst$catalog_depth;


    status.normal := TRUE;
    cycle_array := NIL;
    catalog_depth.depth_specification := fsc$entire_subtree;
    information_request.catalog_depth := catalog_depth;
    information_request.object_information_requests := $fst$goi_object_info_requests
          [fsc$goi_cycle_object_list];

    saved_work_area := work_area;

    pfp$get_object_information (file, information_request, NIL, work_area, status);

    IF NOT status.normal THEN
      IF status.condition = pfe$unknown_item THEN
        status.normal := TRUE;
      IFEND;
      RETURN;
    IFEND;

    NEXT object_info IN saved_work_area;
    IF (object_info = NIL) THEN
      RETURN;
    ELSEIF (object_info^.object = NIL) OR (object_info^.object^.object_type = fsc$goi_catalog_object)  THEN
      osp$set_status_condition (pfe$name_not_permanent_file, status);
      osp$append_status_file (osc$status_parameter_delimiter, file, status);
      RETURN;
    IFEND;

    IF object_info^.object^.object_type = fsc$goi_file_object THEN
      cycle_object_list := object_info^.object^.cycle_object_list;
      IF cycle_object_list = NIL THEN
        RETURN;
      IFEND;
      number_of_cycles := UPPERBOUND (cycle_object_list^);
      NEXT cycle_array: [1 .. number_of_cycles] IN work_area;
      FOR i := 1 TO number_of_cycles DO
        cycle_array^ [i] := cycle_object_list^ [i].cycle_number;
      FOREND;
    IFEND;

  PROCEND clp$get_file_cycles;
?? TITLE := 'clp$get_path_description', EJECT ??
*copyc clh$get_path_description

  PROCEDURE [XDCL, #GATE] clp$get_path_description
    (    file: clt$file;
     VAR file_reference: clt$file_reference;
     VAR path_container: clt$path_container;
     VAR path: ^pft$path;
     VAR cycle_selector: clt$cycle_selector;
     VAR open_position: clt$open_position;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      evaluated_file_reference: fst$evaluated_file_reference,
      fs_file_reference: fst$path,
      fs_path: ^fst$path,
      ignore_path_size: fst$path_size,
      path_container_ptr: ^clt$path_container,
      local_file_name: clt$name;

    #KEYPOINT (osk$entry, 0, clk$get_path_description);

    status.normal := TRUE;
    #CALLER_ID (caller_id);

    file_reference.path_name := ' ';
    #TRANSLATE (osv$lower_to_upper, file.local_file_name, local_file_name.value);
    local_file_name.size := clp$trimmed_string_size (local_file_name.value);
    clp$evaluate_file_reference (local_file_name.value, $clt$file_ref_parsing_options
          [clc$command_file_ref_allowed], TRUE, evaluated_file_reference, status);
    IF status.normal THEN
      PUSH fs_path;
      clp$convert_file_ref_to_string (evaluated_file_reference, FALSE, fs_path^, ignore_path_size, status);
      IF status.normal THEN
        open_position := evaluated_file_reference.path_handle_info.path_handle.open_position;
        path_container_ptr := ^path_container;
        RESET path_container_ptr;
        NEXT path: [1 .. evaluated_file_reference.number_of_path_elements] IN path_container_ptr;
        IF path = NIL THEN
          osp$set_status_condition (cle$file_reference_too_long, status);
        ELSE
          fsp$convert_fs_structure_to_pf (evaluated_file_reference, path);
          clp$convert_cyc_ref_to_cyc_sel (evaluated_file_reference.cycle_reference, cycle_selector);

          format_path_name (local_file_name, fs_path, evaluated_file_reference.path_structure_size,
                open_position, osc$full_message_level, fs_file_reference);
          file_reference.path_name := fs_file_reference;
          file_reference.path_name_size := clp$trimmed_string_size (file_reference.path_name);
          file_reference.validation_ring.known := TRUE;
          file_reference.validation_ring.number := caller_id.ring;
        IFEND;
      IFEND;
    IFEND;

    #KEYPOINT (osk$exit, 0, clk$get_path_description);

  PROCEND clp$get_path_description;
*IFEND
?? TITLE := 'clp$get_path_name', EJECT ??
*copyc clh$get_path_name

  PROCEDURE [XDCL, #GATE] clp$get_path_name ALIAS 'clpgpn'
    (    local_file_name: fst$file_reference;
         format: ost$format_message_level;
     VAR file_reference: fst$path);

    VAR
      actual_format: ost$status_message_level,
      current_format: ^ost$status_message_level,
      evaluated_file_reference: fst$evaluated_file_reference,
      ignore_path_size: fst$path_size,
      open_position: clt$open_position,
      cl_path_handle: clt$path_handle,
      pf_path: ^pft$path,
      path: ^fst$path,
      path_name_size: 0 .. fsc$max_path_size,
      status: ost$status,
      file_reference_name: string (fsc$max_path_size),
      file_name: clt$name;


    open_position.specified := FALSE;
    file_reference := ' ';

*IF NOT $true(osv$unix)
    CASE format OF
    = osc$current_message_level =
      osp$find_status_message_level (current_format);
      actual_format := current_format^;
    ELSE
      actual_format := format;
    CASEND;
*ELSE
    actual_format := osc$full_message_level;
*IFEND


*IF NOT $true(osv$unix)
    #TRANSLATE (osv$lower_to_upper, local_file_name, file_reference_name);
*ELSE
    file_reference_name := local_file_name;
*IFEND

  /get_path/
    BEGIN
      clp$evaluate_file_reference (file_reference_name, $clt$file_ref_parsing_options
            [clc$command_file_ref_allowed], TRUE, evaluated_file_reference, status);
      IF status.normal THEN
        IF evaluated_file_reference.number_of_path_elements = 0 THEN
          file_reference := file_reference_name;
          RETURN;
        IFEND;

        PUSH path;
        PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
        fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);
        clp$check_name_for_path_handle (pf_path^ [UPPERBOUND (pf_path^)], cl_path_handle);
        IF cl_path_handle.kind = clc$command_file_handle THEN
          path^ := '$COMMAND';
          path_name_size := 8;
          open_position.specified := FALSE;
          file_name.size := 1;
          file_name.value := ' ';
          EXIT /get_path/;
        ELSE
*IF NOT $true(osv$unix)
          clp$convert_file_ref_to_string (evaluated_file_reference, FALSE, path^, ignore_path_size, status);
*ELSE
          IF evaluated_file_reference.standard_file THEN
            file_reference := evaluated_file_reference.unix_standard_file.unix_file_name;
            RETURN;
          ELSE
            clp$conv_unix_file_ref_to_str (evaluated_file_reference, path^, ignore_path_size, status);
          IFEND;
*IFEND
          IF status.normal THEN
*IF NOT $true(osv$unix)
            open_position := evaluated_file_reference.path_handle_info.path_handle.open_position;
*IFEND
            path_name_size := evaluated_file_reference.path_structure_size;
            file_name.size := 1;
            file_name.value := ' ';
            EXIT /get_path/;
          IFEND;
        IFEND;
      IFEND;
      path_name_size := 0;
      file_name.size := 1;
      file_name.value := '?';
      path := NIL;
    END /get_path/;

    format_path_name (file_name, path, path_name_size, open_position, actual_format, file_reference);

  PROCEND clp$get_path_name;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$get_source', EJECT ??
*copyc clh$get_source

  PROCEDURE [XDCL, #GATE] clp$get_source
    (VAR source: clt$source;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      ignore_path_size: fst$path_size,
      path_handle: clt$path_handle;


    status.normal := TRUE;

    clp$find_current_block (block);
    WHILE (block <> NIL) AND (NOT (block^.kind IN $clt$block_kinds
          [clc$command_block, clc$command_proc_block, clc$function_block, clc$function_proc_block])) DO
      block := block^.previous_block;
    WHILEND;
    IF block = NIL THEN
      osp$set_status_condition (cle$unable_to_find_cmnd_source, status);
      RETURN;
    IFEND;

    CASE block^.source.kind OF
    = clc$system_commands =
      source.kind := clc$system_source;
    = clc$sub_commands =
      source.kind := clc$utility_source;
      source.utility_name := block^.source.utility_name;
    = clc$catalog_commands, clc$library_commands =
      IF block^.source.kind = clc$catalog_commands THEN
        source.kind := clc$catalog_source;
      ELSE
        source.kind := clc$library_source;
      IFEND;

      clp$check_name_for_path_handle (block^.source.local_file_name, path_handle);
      bap$get_path_string (path_handle.regular_handle, source.path_name, ignore_path_size, status);
    CASEND;

  PROCEND clp$get_source;
?? TITLE := 'clp$get_working_catalog', EJECT ??
*copyc clh$get_working_catalog

  PROCEDURE [XDCL, #GATE] clp$get_working_catalog
    (VAR catalog_reference: clt$file_reference;
     VAR path_container: clt$path_container;
     VAR path: ^pft$path;
     VAR status: ost$status);

    VAR
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      path_container_ptr: ^clt$path_container,
      working_catalog: ^^clt$working_catalog;

    #KEYPOINT (osk$entry, 0, clk$get_working_catalog);

    status.normal := TRUE;

    clp$find_working_catalog (working_catalog);

    clp$convert_file_ref_to_string (working_catalog^^.evaluated_file_reference, FALSE, fs_path, fs_path_size,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    catalog_reference.path_name := fs_path;
    catalog_reference.path_name_size := clp$trimmed_string_size (catalog_reference.path_name);
    catalog_reference.validation_ring.known := FALSE;

    path_container_ptr := ^path_container;
    RESET path_container_ptr;
    NEXT path: [1 .. working_catalog^^.evaluated_file_reference.number_of_path_elements] IN
          path_container_ptr;
    fsp$convert_fs_structure_to_pf (working_catalog^^.evaluated_file_reference, path);

    #KEYPOINT (osk$exit, 0, clk$get_working_catalog);

  PROCEND clp$get_working_catalog;
?? TITLE := 'clp$parse_job_independent_path', EJECT ??
*copyc clh$parse_job_independent_path

  PROCEDURE [XDCL, #GATE] clp$parse_job_independent_path
    (    path: fst$file_reference;
         user_identification: ost$user_identification;
         include_open_position: boolean;
     VAR parsed_path: fst$parsed_file_reference;
     VAR status: ost$status);

    VAR
      clt_user_identification: clt$user_identification,
      evaluated_file_reference: fst$evaluated_file_reference;

    status.normal := TRUE;

    clt_user_identification.user.value := user_identification.user;
    clt_user_identification.user.size := clp$trimmed_string_size (user_identification.user);
    clt_user_identification.family.value := user_identification.family;
    clt_user_identification.family.size := clp$trimmed_string_size (user_identification.family);

    clp$setup_and_parse_file_ref (path, $clt$file_ref_parsing_options [clc$prevent_job_context_element],
          clt_user_identification, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    convert_eval_to_parsed_file_ref (evaluated_file_reference, include_open_position, parsed_path, status);

  PROCEND clp$parse_job_independent_path;
?? TITLE := 'clp$set_working_catalog', EJECT ??
*copyc clh$set_working_catalog

  PROCEDURE [XDCL, #GATE] clp$set_working_catalog
    (    catalog: fst$file_reference;
     VAR status: ost$status);

    VAR
      file: clt$file,
      local_status: ost$status,
      evaluated_file_reference: fst$evaluated_file_reference,
      pf_path_elements: ^pft$path;

    #KEYPOINT (osk$entry, 0, clk$set_working_catalog);

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

  /set_working_catalog/
    BEGIN
      clp$convert_string_to_file (catalog, file, local_status);
      IF NOT local_status.normal THEN
        EXIT /set_working_catalog/;
      IFEND;
      clp$get_fs_path_elements (file.local_file_name, evaluated_file_reference, local_status);
      IF NOT local_status.normal THEN
        EXIT /set_working_catalog/;
      IFEND;

      IF fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local THEN
        IF evaluated_file_reference.number_of_path_elements > 1 THEN
          osp$set_status_condition (fse$local_subcatalog_illegal, local_status);
          EXIT /set_working_catalog/;
        IFEND;
      ELSE
        PUSH pf_path_elements: [1 .. evaluated_file_reference.number_of_path_elements];
        fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path_elements);
        clp$check_valid_catalog (pf_path_elements^, local_status);
        IF NOT local_status.normal THEN
          EXIT /set_working_catalog/;
        IFEND;
      IFEND;

      evaluated_file_reference.path_resolution := fsc$catalog_path;

      IF evaluated_file_reference.cycle_reference.specification <> fsc$cycle_omitted THEN
        osp$set_status_abnormal ('CL', fse$catalogs_do_not_have_cycles, file.local_file_name, local_status);
        EXIT /set_working_catalog/;
      IFEND;

      IF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
        osp$set_status_condition (cle$file_position_not_allowed, local_status);
        EXIT /set_working_catalog/;
      IFEND;

      clp$set_working_catalog_path (file.local_file_name, evaluated_file_reference);

    END /set_working_catalog/;
    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, clk$set_working_catalog);

  PROCEND clp$set_working_catalog;
*ELSE

  PROCEDURE [INLINE] clp$getcwd (working_storage_area: ^cell;
    VAR directory_length: ost_c_integer;
    VAR syserrlist_message: string(256);
    VAR stat: ost_c_integer);

    clp_getcwd (working_storage_area, directory_length,
          syserrlist_message, stat);

  PROCEND clp$getcwd;

  PROCEDURE  clp$find_working_catalog
    (VAR working_catalog: clt$working_catalog;
     VAR status: ost$status);

    VAR
      directory_length: ost_c_integer,
      ignore_command_name: clt$name,
      ignore_form: clt$command_reference_form,
      ignore_parameter_name: clt$parameter_name,
      initial_path: ^fst$file_reference,
      parse: clt$parse_state,
      path: ^string(*),
      units: ^clt$lexical_units,
      stat: ost_c_integer,
      syserrlist_message: string(256),
      work_area: ^^clt$work_area;

    status.normal := TRUE;
    stat := 0;
    syserrlist_message := ' ';

    PUSH path: [fsc$max_path_size];
    clp$getcwd (path, directory_length, syserrlist_message, stat);
    IF stat <> 0 THEN
      osp$set_status_from_errno ('WRITE', stat, syserrlist_message, status);
      RETURN;
    IFEND;
    working_catalog.path := path^ (1, directory_length);

    clp$get_work_area (osc$user_ring, work_area, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$identify_lexical_units (^working_catalog.path (1, directory_length), work_area^, units, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$initialize_parse_state (^working_catalog.path (1, directory_length), units, parse);
    clp$scan_non_space_lexical_unit (parse);
    initial_path := NIL;
    clp$complete_file_ref_parse (initial_path, parse, work_area^, $clt$file_ref_parsing_options
            [clc$unix_path_syntax], clv$user_identification, working_catalog.evaluated_file_reference,
            ignore_command_name, ignore_form, ignore_parameter_name, status);

  PROCEND clp$find_working_catalog;
*IFEND
?? TITLE := 'clp$setup_and_parse_file_ref', EJECT ??
*copyc clh$setup_and_parse_file_ref

  PROCEDURE [XDCL, INLINE] clp$setup_and_parse_file_ref
    (    file: fst$file_reference;
         file_reference_parsing_options: clt$file_ref_parsing_options;
         user_identification: clt$user_identification;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

    VAR
      ignore_command_name: clt$name,
      ignore_form: clt$command_reference_form,
      ignore_status: ost$status,
      initial_path: ^fst$file_reference,
      parameter_name: clt$parameter_name,
      parse: clt$parse_state,
      path_parsed: boolean,
*IF $true(osv$unix)
      possibly_pre_evaluated: boolean,
*IFEND
      saved_parse: clt$parse_state,
      units: ^clt$lexical_units,
*IF $true(osv$unix)
      unix_path: boolean,
*IFEND
      work_area: ^^clt$work_area;

    status.normal := TRUE;

*IF NOT $true(osv$unix)
    clp$get_work_area (#RING (^parse), work_area, status);
*ELSE
    clp$get_work_area (osc$user_ring, work_area, status);
*IFEND
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$identify_lexical_units (^file, work_area^, units, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /parse_path/
    BEGIN
      clp$initialize_parse_state (^file, units, parse);
      clp$scan_non_space_lexical_unit (parse);
*IF NOT $true(osv$unix)
      CASE parse.unit.kind OF
      = clc$lex_colon =
*IFEND

{ Check if the file reference is a candidate for clp$parse_file_reference.

*IF NOT $true(osv$unix)
        IF clp$file_ref_is_pre_evaluated (file_reference_parsing_options, parse) THEN
          saved_parse := parse;
          clp$parse_file_reference (saved_parse, path_parsed, evaluated_file_reference, status);
          IF (NOT status.normal) OR path_parsed THEN
            parameter_name := osc$null_name;
            parse := saved_parse;
            EXIT /parse_path/;
          IFEND;
        IFEND;
      ELSE
        ;
      CASEND;
*ELSE
      unix_path := clc$unix_path_syntax IN file_reference_parsing_options;
      possibly_pre_evaluated := FALSE;
      IF possibly_pre_evaluated AND clp$file_ref_is_pre_evaluated (file_reference_parsing_options, parse) THEN
        saved_parse := parse;
        clp$parse_file_reference (unix_path, saved_parse, path_parsed, evaluated_file_reference, status);
        IF (NOT status.normal) OR path_parsed THEN
          parameter_name := osc$null_name;
          parse := saved_parse;
          EXIT /parse_path/;
        IFEND;
      IFEND;
*IFEND

      initial_path := NIL;
      clp$complete_file_ref_parse (initial_path, parse, work_area^, file_reference_parsing_options,
            user_identification, evaluated_file_reference, ignore_command_name, ignore_form, parameter_name,
            status);
    END /parse_path/;
    RESET work_area^ TO units;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter_name <> osc$null_name THEN
      osp$set_status_abnormal ('CL', cle$parameter_never_given_value, parameter_name, status);
      RETURN;
    IFEND;

    IF parse.unit_is_space THEN
      clp$scan_non_space_lexical_unit (parse);
    IFEND;
    IF parse.unit.kind <> clc$lex_end_of_line THEN
      osp$set_status_condition (cle$expecting_end_of_file_ref, status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
    IFEND;

  PROCEND clp$setup_and_parse_file_ref;
?? TITLE := 'convert_eval_to_parsed_file_ref', EJECT ??

  PROCEDURE [INLINE] convert_eval_to_parsed_file_ref
    (    evaluated_file_reference: fst$evaluated_file_reference;
         include_open_position: boolean;
     VAR parsed_file_reference: fst$parsed_file_reference;
     VAR status: ost$status);

    VAR
      cycle_ref_size: fst$path_index,
      cycle_ref_value: string (5),
      cycle_string: ost$string,
      element_index: fst$path_index,
      i: fst$path_index,
      local_status: ost$status,
      open_pos_size: 4 .. 5,
      size: fst$path_size;

    status.normal := TRUE;

    size := evaluated_file_reference.path_structure_size;
    parsed_file_reference.path := evaluated_file_reference.path_structure (1, size);
*IF NOT $true(osv$unix)
    parsed_file_reference.path (1) := ':';
*ELSE
    parsed_file_reference.path (1) := '/';
*IFEND
    i := $INTEGER (evaluated_file_reference.path_structure (1)) + 2;
    element_index := 1;
    WHILE i < size DO
*IF NOT $true(osv$unix)
      parsed_file_reference.path (i) := '.';
*ELSE
      parsed_file_reference.path (i) := '/';
*IFEND
      element_index := i;
      i := i + $INTEGER (evaluated_file_reference.path_structure (i)) + 1;
    WHILEND;
    parsed_file_reference.first_name.index := 2;
    parsed_file_reference.first_name.size := $INTEGER (evaluated_file_reference.path_structure (1));
    parsed_file_reference.last_name.index := element_index + 1;
    parsed_file_reference.last_name.size := $INTEGER (evaluated_file_reference.
          path_structure (element_index));
    parsed_file_reference.file_path_size := size;
    parsed_file_reference.catalog_path_size := element_index - 1;

*IF NOT $true(osv$unix)
    IF evaluated_file_reference.cycle_reference.specification <> fsc$cycle_omitted THEN
      CASE evaluated_file_reference.cycle_reference.specification OF
      = fsc$cycle_number =
        clp$convert_integer_to_string (evaluated_file_reference.cycle_reference.cycle_number, 10, FALSE,
              cycle_string, local_status);
        cycle_ref_size := cycle_string.size;
        cycle_ref_value := cycle_string.value (1, cycle_string.size);
      = fsc$high_cycle =
        cycle_ref_size := 5;
        cycle_ref_value := '$HIGH';
      = fsc$low_cycle =
        cycle_ref_size := 4;
        cycle_ref_value := '$LOW';
      = fsc$next_cycle =
        cycle_ref_size := 5;
        cycle_ref_value := '$NEXT';
      ELSE
        cycle_ref_size := fsc$max_path_size;
      CASEND;

      IF (i + cycle_ref_size) <= fsc$max_path_size THEN
        parsed_file_reference.path (i) := '.';
        parsed_file_reference.path (i + 1, cycle_ref_size) := cycle_ref_value;
        size := i + cycle_ref_size;
      ELSE
        osp$set_status_condition (cle$file_reference_too_long, status);
        RETURN;
      IFEND;
      parsed_file_reference.cycle_reference.index := i + 1;
      parsed_file_reference.cycle_reference.size := cycle_ref_size;
    ELSE
*IFEND
      parsed_file_reference.cycle_reference.index := 1;
      parsed_file_reference.cycle_reference.size := 0;
*IF NOT $true(osv$unix)
    IFEND;
*IFEND
    parsed_file_reference.cycle_path_size := size;

    parsed_file_reference.open_position.index := 1;
    parsed_file_reference.open_position.size := 0;

*IF NOT $true(osv$unix)
    IF evaluated_file_reference.path_handle_info.path_handle.open_position.specified AND
          include_open_position THEN
      open_pos_size := clv$open_position_designator [evaluated_file_reference.path_handle_info.path_handle.
            open_position.value].size;
      IF size + open_pos_size + 1 <= fsc$max_path_size THEN
        parsed_file_reference.path (size + 1) := '.';
        parsed_file_reference.path (size + 2, open_pos_size) :=
              clv$open_position_designator [evaluated_file_reference.path_handle_info.path_handle.
              open_position.value].value (1, open_pos_size);
        parsed_file_reference.open_position.index := size + 2;
        parsed_file_reference.open_position.size := open_pos_size;
        size := size + open_pos_size + 1;
      IFEND;
    IFEND;
*IFEND

    parsed_file_reference.complete_path_size := size;
    parsed_file_reference.number_of_path_elements := evaluated_file_reference.number_of_path_elements;

  PROCEND convert_eval_to_parsed_file_ref;
?? TITLE := 'format_path_name', EJECT ??

  PROCEDURE format_path_name
    (    local_file_name: clt$name;
         path: ^fst$path;
         path_name_size: 0 .. fsc$max_path_size;
         open_position: clt$open_position;
         format: ost$status_message_level;
     VAR file_reference: fst$path);

    VAR
      file_reference_size: 1 .. fsc$max_path_size,
      ignore_status: ost$status,
      index: 1 .. fsc$max_path_size,
      integer_string: ost$string,
*IF NOT $true(osv$unix)
      size: 1 .. fsc$max_path_size,
      working_catalog: ^^clt$working_catalog,
      working_catalog_path: fst$path,
      working_catalog_path_size: fst$path_size;
*ELSE
      size: 1 .. fsc$max_path_size;
*IFEND


*IF NOT $true(osv$unix)
    clp$find_working_catalog (working_catalog);

    IF format = osc$brief_message_level THEN
      clp$convert_file_ref_to_string (working_catalog^^.evaluated_file_reference, FALSE, working_catalog_path,
            working_catalog_path_size, ignore_status);
    IFEND;
*IFEND

    IF path = NIL THEN
*IF NOT $true(osv$unix)
      IF (format = osc$brief_message_level) AND (working_catalog_path = '$LOCAL') THEN
        file_reference := local_file_name.value (1, local_file_name.size);
      ELSE
*IFEND
        file_reference (1, 8) := ':$LOCAL.';
        file_reference (9, local_file_name.size) := local_file_name.value;
*IF NOT $true(osv$unix)
      IFEND;
*IFEND
      RETURN;
    IFEND;

    size := clp$trimmed_string_size (path^);
*IF NOT $true(osv$unix)
    IF format = osc$full_message_level THEN
*IFEND
      index := 1;
*IF NOT $true(osv$unix)
    ELSE
      index := working_catalog_path_size;
      IF (size > index) AND (path^ (1, index) = working_catalog_path) AND (path^ (index + 1) = '.') AND
            (path_name_size > working_catalog_path_size) THEN
        index := index + 2;
        size := size - index + 1;
      ELSE
        index := 1;
      IFEND;
    IFEND;
*IFEND

    file_reference_size := size;
    file_reference := path^ (index, file_reference_size);

*IF NOT $true(osv$unix)
    IF format = osc$full_message_level THEN
      IF open_position.specified THEN
        size := clv$open_position_designator [open_position.value].size;
        IF (file_reference_size + 1 + size) <= fsc$max_path_size THEN
          file_reference (file_reference_size + 1) := '.';
          file_reference (file_reference_size + 2, size) := clv$open_position_designator
                [open_position.value].value (1, size);
        IFEND;
      IFEND;
    IFEND;
*IFEND

  PROCEND format_path_name;

MODEND clm$file_reference_manager;
*DECK DECK=CLM$FORMAT_PROC_HEADER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL PROC Formatter' ??
MODULE clm$format_proc_header;

{
{ PURPOSE:
{   This module contains the routines that format and (optionally) translate
{   an SCL procedure/function header or PDT.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc amt$file_identifier
*copyc amt$page_width
*copyc clc$max_proc_names
*copyc clc$proc_pdt_parameter_limits
*copyc cle$ecc_parsing
*copyc clt$command_line
*copyc clt$command_line_size
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc amp$put_next
*copyc clp$append_status_parse_state
*copyc clp$convert_type_spec_to_desc
*copyc clp$get_statement_to_format
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*copyc clp$internal_convert_to_string
*copyc clp$internal_generate_old_pdt
*copyc clp$internal_generate_pdt
*copyc clp$internal_gen_type_spec
*copyc clp$scan_non_space_lexical_unit
*copyc clp$translate_pdt
*copyc clp$trimmed_string_size
*copyc clp$unbundle_pdt
*copyc mmp$create_scratch_segment
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
?? EJECT ??

  VAR
    lexical_work_area_segment: [STATIC] amt$segment_pointer := [amc$sequence_pointer, NIL],
    saved_line_work_area_segment: [STATIC] amt$segment_pointer := [amc$sequence_pointer, NIL],
    symbolic_work_area_segment: [STATIC] amt$segment_pointer := [amc$sequence_pointer, NIL],
    work_area_segment: [STATIC] amt$segment_pointer := [amc$sequence_pointer, NIL];

?? TITLE := 'clp$format_proc_header', EJECT ??

  PROCEDURE [XDCL] clp$format_proc_header
    (    output_file_id: amt$file_identifier;
         page_width: amt$page_width;
         supplied_first_line: ^clt$command_line;
         translate: boolean;
         indent_column: amt$page_width;
     VAR proc_name: ost$name;
     VAR error_count {input, output} : 0 .. amc$file_byte_limit;
     VAR status: ost$status);

    VAR
      command_or_function: clt$command_or_function,
      end_of_input: boolean,
      line_supplied: boolean,
      name: ost$name,
      parse: clt$parse_state,
      representation: ^clt$data_representation,
      representation_put: boolean,
      request: clt$convert_to_string_request,
      saved_line_count: integer,
      saved_line_work_area: ^clt$work_area,
      symbolic_qualifiers_work_area: ^clt$work_area,
      work_area: ^clt$work_area;

?? NEWTITLE := 'format_old_pdt', EJECT ??

    PROCEDURE format_old_pdt
      (    proc_or_pdt: ost$name);

      VAR
        aliases: ^array [1 .. * ] of pmt$program_name,
        extra_info_area: ^SEQ (REP clc$proc_pdt_info_area_size of cell),
        ignore_application_type_present: boolean,
        name_index: clt$parameter_name_index,
        new_pdt: clt$unbundled_pdt,
        parameter_area: ^SEQ (REP clc$max_proc_pdt_parameters of clt$parameter_descriptor),
        parameter_name_area: ^SEQ (REP clc$max_proc_pdt_param_names of clt$parameter_name_descriptor),
        pdt: clt$parameter_descriptor_table,
        proc_name_area: ^SEQ (REP clc$max_proc_names of ost$name),
        proc_names: ^clt$proc_names,
        symbolic_parameter_area: ^SEQ (REP clc$max_proc_pdt_parameters of clt$symbolic_parameter),
        symbolic_parameters: ^clt$symbolic_parameters,
        symbolic_qualifier_count: integer,
        symbolic_qualifiers_text_size: integer;

?? NEWTITLE := 'put_old_pdt', EJECT ??

      PROCEDURE [INLINE] put_old_pdt;


        request.initial_indentation := indent_column - 1;
        request.continuation_indentation := 0;
        request.max_string := page_width;
        request.include_advanced_items := TRUE;
        request.include_hidden_items := TRUE;
        request.kind := clc$convert_old_pdt;
        request.multi_line_old_pdt_format := TRUE;
        request.proc_or_pdt := proc_or_pdt;
        request.proc_names := proc_names;
        request.old_pdt := pdt;
        request.symbolic_parameters := symbolic_parameters;

        clp$internal_convert_to_string (request, work_area, representation, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        put_representation;

      PROCEND put_old_pdt;
?? OLDTITLE, EJECT ??

      NEXT proc_name_area IN work_area;
      NEXT parameter_name_area IN work_area;
      NEXT parameter_area IN work_area;
      NEXT symbolic_parameter_area IN work_area;
      NEXT extra_info_area IN work_area;

      clp$internal_generate_old_pdt (proc_or_pdt, ^get_line, work_area, parse, proc_name_area^,
            parameter_name_area^, parameter_area^, symbolic_parameter_area^, extra_info_area^, proc_names,
            pdt, symbolic_parameters, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      proc_name := proc_names^ [1];

      IF translate THEN
        clp$translate_pdt (pdt, FALSE, TRUE, ^report_status, symbolic_parameters,
              symbolic_qualifiers_work_area, work_area, ignore_application_type_present, new_pdt, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF UPPERBOUND (proc_names^) > 1 THEN
          PUSH aliases: [1 .. UPPERBOUND (proc_names^) - 1];
          FOR name_index := 1 TO UPPERBOUND (proc_names^) - 1 DO
            aliases^ [name_index] := proc_names^ [name_index + 1];
          FOREND;
        ELSE
          aliases := NIL;
        IFEND;
        put_pdt (aliases, clc$normal_usage_entry, clc$xdcl_command_or_function, ^new_pdt);
      ELSE
        put_old_pdt;
      IFEND;

    PROCEND format_old_pdt;
?? TITLE := 'format_pdt', EJECT ??

    PROCEDURE format_pdt
      (    command_or_function: clt$command_or_function);

      VAR
        aliases: ^array [1 .. * ] of pmt$program_name,
        availability: clt$named_entry_availability,
        command_log_option: clt$command_log_option,
        command_or_function_scope: clt$command_or_function_scope,
        pdt: ^clt$parameter_description_table,
        unbundled_pdt: clt$unbundled_pdt;


      clp$scan_non_space_lexical_unit (parse);

      clp$internal_generate_pdt (command_or_function, ^get_line, symbolic_qualifiers_work_area, work_area,
            parse, proc_name, aliases, availability, command_or_function_scope, command_log_option, pdt,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      RESET pdt;
      clp$unbundle_pdt (pdt, work_area, unbundled_pdt, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      put_pdt (aliases, availability, command_or_function_scope, ^unbundled_pdt);

    PROCEND format_pdt;
?? TITLE := 'format_type', EJECT ??
{
{ This routine is not complete and probably doesn't belong in this module anyway.
{ Its here just as a sketch of how much of the formatting for TYPE/TYPEND
{ might be done.
{

    PROCEDURE format_type;

      VAR
        end_of_input: boolean,
        type_name: clt$type_name,
        type_description: clt$type_description,
        type_specification: ^clt$type_specification;

?? NEWTITLE := 'put_type', EJECT ??

      PROCEDURE [INLINE] put_type
        (    type_description: ^clt$type_description);


        request.initial_indentation := indent_column - 1;
        request.continuation_indentation := 0;
        request.max_string := page_width;
        request.include_advanced_items := TRUE;
        request.include_hidden_items := TRUE;
        request.kind := clc$convert_type_description;
        request.multi_line_type_format := TRUE;
        request.type_description := type_description;
        request.symbolic_type_qualifiers_area := symbolic_qualifiers_work_area;

        clp$internal_convert_to_string (request, work_area, representation, status);
        IF NOT status.normal THEN
          EXIT format_type;
        IFEND;

        put_representation;

      PROCEND put_type;
?? OLDTITLE, EJECT ??

      clp$scan_non_space_lexical_unit (parse);
      WHILE parse.unit.kind = clc$lex_end_of_line DO
        get_line (parse, end_of_input, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF end_of_input THEN
          osp$set_status_abnormal ('CL', cle$expecting_type_name, 'end of input', status);
          RETURN;
        IFEND;
        clp$scan_non_space_lexical_unit (parse);
      WHILEND;

      IF parse.unit.kind <> clc$lex_name THEN
        osp$set_status_abnormal ('CL', cle$expecting_type_name, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        RETURN;
      IFEND;
      #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), type_name);
      clp$scan_non_space_lexical_unit (parse);
      WHILE parse.unit.kind = clc$lex_end_of_line DO
        get_line (parse, end_of_input, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF end_of_input THEN
          osp$set_status_abnormal ('CL', cle$expecting_after_type_name, 'end of input', status);
          RETURN;
        IFEND;
        clp$scan_non_space_lexical_unit (parse);
      WHILEND;

      IF (parse.unit.kind <> clc$lex_colon) AND (parse.unit.kind <> clc$lex_equal) THEN
        osp$set_status_abnormal ('CL', cle$expecting_after_type_name, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        RETURN;
      IFEND;

      clp$scan_non_space_lexical_unit (parse);

      clp$internal_gen_type_spec (type_name, FALSE, ^get_line, symbolic_qualifiers_work_area, work_area,
            parse, type_specification, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_type_spec_to_desc (type_specification, work_area, type_description, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      put_type (^type_description);

      IF (parse.unit.kind = clc$lex_space) OR (parse.unit.kind = clc$lex_semicolon) THEN
        clp$scan_non_space_lexical_unit (parse);
      IFEND;
      IF parse.unit.kind = clc$lex_end_of_line THEN
        get_line (parse, end_of_input, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF NOT end_of_input THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;
      IFEND;
      IF parse.unit.kind = clc$lex_name THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), type_name);
      ELSE
        type_name := '';
      IFEND;
      IF type_name <> 'TYPEND' THEN
        osp$set_status_abnormal ('CL', cle$expecting_typend, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        RETURN;
      IFEND;

    PROCEND format_type;
?? TITLE := 'get_line', EJECT ??

    PROCEDURE get_line
      (VAR parse: clt$parse_state;
       VAR end_of_input: boolean;
       VAR status: ost$status);

      VAR
        got_line: boolean,
        lexical_units: ^clt$lexical_units,
        lexical_work_area: ^clt$work_area,
        line: ^clt$command_line,
        saved_line: ^clt$command_line,
        saved_line_size: ^clt$command_line_size;


      status.normal := TRUE;

      IF line_supplied THEN
        line := supplied_first_line;
        got_line := TRUE;
        line_supplied := FALSE;
      ELSE
        clp$get_statement_to_format (line, got_line, status);
      IFEND;

      end_of_input := NOT got_line;
      IF end_of_input THEN
        RETURN;
      IFEND;

      NEXT saved_line_size IN saved_line_work_area;
      saved_line_size^ := STRLENGTH (line^);
      NEXT saved_line: [saved_line_size^] IN saved_line_work_area;
      saved_line^ := line^;
      saved_line_count := saved_line_count + 1;

      lexical_work_area := lexical_work_area_segment.sequence_pointer;
      clp$identify_lexical_units (line, lexical_work_area, lexical_units, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$initialize_parse_state (line, lexical_units, parse);

    PROCEND get_line;
?? TITLE := 'put_line', EJECT ??

    PROCEDURE [INLINE] put_line
      (    line: string ( * ));

      VAR
        ignore_byte_address: amt$file_byte_address;


      amp$put_next (output_file_id, ^line, STRLENGTH (line), ignore_byte_address, status);
      IF NOT status.normal THEN
        EXIT clp$format_proc_header;
      IFEND;

    PROCEND put_line;
?? TITLE := 'put_pdt', EJECT ??

    PROCEDURE [INLINE] put_pdt
      (    aliases: ^array [1 .. * ] of pmt$program_name;
           availability: clt$named_entry_availability;
           command_or_function_scope: clt$command_or_function_scope;
           pdt: ^clt$unbundled_pdt);


      request.initial_indentation := indent_column - 1;
      request.continuation_indentation := 0;
      request.max_string := page_width;
      request.include_advanced_items := TRUE;
      request.include_hidden_items := TRUE;
      request.kind := clc$convert_unbundled_pdt;
      request.multi_line_pdt_format := TRUE;
      request.parameter_starts_line := TRUE;
      request.individual_parameter := FALSE;
      request.individual_parameter_number := LOWERVALUE (clt$parameter_number);
      request.include_header := TRUE;
      request.command_or_function_name := proc_name;
      request.aliases := aliases;
      request.availability := availability;
      request.command_or_function_scope := command_or_function_scope;
      request.pdt := pdt;
      request.pvt := NIL;
      request.symbolic_pdt_qualifiers_area := symbolic_qualifiers_work_area;
      request.include_implementation_info := TRUE;

      clp$internal_convert_to_string (request, work_area, representation, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      put_representation;

    PROCEND put_pdt;
?? TITLE := 'put_representation', EJECT ??

    PROCEDURE [INLINE] put_representation;

      VAR
        representation_line: ^clt$string_value,
        representation_line_count: ^clt$data_representation_count,
        representation_line_index: clt$data_representation_count,
        representation_line_size: ^clt$string_size;


      RESET representation;
      NEXT representation_line_count IN representation;

      FOR representation_line_index := 1 TO representation_line_count^ DO
        NEXT representation_line_size IN representation;
        NEXT representation_line: [representation_line_size^] IN representation;
        put_line (representation_line^);
      FOREND;

      representation_put := TRUE;

    PROCEND put_representation;
?? TITLE := 'put_saved_lines', EJECT ??

    PROCEDURE put_saved_lines;

      VAR
        saved_line: ^clt$command_line,
        saved_line_size: ^clt$command_line_size,
        saved_status: ost$status;


      saved_status := status;

      RESET saved_line_work_area;

      WHILE saved_line_count > 1 DO
        NEXT saved_line_size IN saved_line_work_area;
        NEXT saved_line: [saved_line_size^] IN saved_line_work_area;
        put_line (saved_line^);
        saved_line_count := saved_line_count - 1;
      WHILEND;

      status := saved_status;

    PROCEND put_saved_lines;
?? TITLE := 'report_status', EJECT ??

    PROCEDURE report_status
      (    parameter_name: ost$name;
           error_status: ost$status;
       VAR status: ost$status);

{ PURPOSE:
{   The purpose of this procedure is to report to the formatter output file any errors
{   detected by clp$translate_pdt.

      VAR
        error_line: string (120),
        size: integer;


      status.normal := TRUE;
      error_count := error_count + 1;

      STRINGREP (error_line, size, ' " Problem with translating PROC parameter - ',
            parameter_name (1, clp$trimmed_string_size (parameter_name)));
      put_line (error_line (1, size));

      STRINGREP (error_line, size, ' --ERROR-- ', error_status.text.value (2, error_status.text.size - 1),
            ' can not be translated.');
      put_line (error_line (1, size));

    PROCEND report_status;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    IF work_area_segment.sequence_pointer = NIL THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, work_area_segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET work_area_segment.sequence_pointer;
    IFEND;
    work_area := work_area_segment.sequence_pointer;

    IF symbolic_work_area_segment.sequence_pointer = NIL THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, symbolic_work_area_segment,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET symbolic_work_area_segment.sequence_pointer;
    IFEND;
    symbolic_qualifiers_work_area := symbolic_work_area_segment.sequence_pointer;

    IF saved_line_work_area_segment.sequence_pointer = NIL THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, saved_line_work_area_segment,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET saved_line_work_area_segment.sequence_pointer;
    IFEND;
    saved_line_work_area := saved_line_work_area_segment.sequence_pointer;

    IF lexical_work_area_segment.sequence_pointer = NIL THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, lexical_work_area_segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET lexical_work_area_segment.sequence_pointer;
    IFEND;

    saved_line_count := 0;
    line_supplied := supplied_first_line <> NIL;
    representation_put := FALSE;

  /format_proc_header/
    BEGIN
      get_line (parse, end_of_input, status);
      IF (NOT status.normal) OR end_of_input THEN
        EXIT /format_proc_header/;
      IFEND;
      clp$scan_non_space_lexical_unit (parse);

      IF parse.unit.kind = clc$lex_name THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        IF (name = 'PROC') OR (name = 'PDT') THEN
          format_old_pdt (name);
        ELSEIF name = 'TYPE' THEN
          format_type;
        ELSE
          IF name = 'PROCEDURE' THEN
            command_or_function := clc$command;
          ELSEIF name = 'FUNCTION' THEN
            command_or_function := clc$function;
          ELSE
            osp$set_status_abnormal ('CL', cle$expecting_proc_func_or_type, name, status);
            EXIT /format_proc_header/;
          IFEND;
          format_pdt (command_or_function);
        IFEND;
      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_proc_func_or_type, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT /format_proc_header/;
      IFEND;
    END /format_proc_header/;

    IF (NOT status.normal) AND (NOT representation_put) THEN
      put_saved_lines;
    IFEND;

  PROCEND clp$format_proc_header;

MODEND clm$format_proc_header;
*DECK DECK=CLM$FORMAT_SCL_PROC EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL PROC Formatter' ??
MODULE clm$format_scl_proc;

{ PURPOSE:
{   The purpose of this module is to provide the basic procedures
{   of the SCL formatter.

{ FORMATTER REQUIREMENTS:

{  .The SCL formatter will read an input file of SCL statements and
{   will output the statements in a more readable - or at least a more
{   consistent - format while also checking for basic syntax errors.

{  .Detailed description of the formatter output is given in the user
{   documentation.

{ DESIGN CONSIDERAIONS:

{   In order to achieve its goal of recognizing SCL tokens (names,
{   strings, etc.), groups of tokens (such as a file reference), and
{   statement types, the formatter uses several modified SCL interpreter
{   procedures. The modified modules, procedures, variables, and CYBIL
{   types have F_ appended to the dollar sign of the original names - for
{   example, the modified clp$scan_expression procedure becomes clp$f_scan_expression.
{   Modification of interpreter procedures and modules will consist, in
{   most cases, of deleting code not needed or used by the formatter and
{   adding calls to interface procedures in this or other formatter
{   modules.
{
{   Data - in the form of input lines - usually flows through three processors:
{
{       .Input line processor.
{          Reads a line from the input file. Data lines - such as those encountered when
{          formatting is turned off - are passed on unmodified. A command line which
{          is continued has all of its continuation lines concatenated.
{
{       .Line scanner.
{          Scans a command line and generates an array of "format tokens" for the
{          line.  An entry in this array describes a clt$lexical_unit (such as
{          clt$lex_name) encountered in the line or it may serve to delineate a
{          group of units such as a file reference or a parameter. It is this
{          processor which makes use of modified interpreter procedures.
{
{       .Output line processor.
{          Generates the formatted output line based upon the contents of the format
{          token array and the formatter "environment" (such as current block
{          structure).

{ NOTES:

{   .As a command line is scanned by the formatter, an array (clv$current_array_ptr^)
{    and a semi-final output line (clv$current_line_ptr^) are built by the interface
{    routines. An entry in the array points to the beginning of the corresponding
{    string in the output line. Each entry also contains information concerning
{    the kind of interpreter unit (clt$lexical_unit_kind), the kind of formatter
{    token (clt$format_type), and the length of the string in the output line
{    associated with the entry.
{
{   .The array is initialized to contain zero entries. The current index into the
{    array is specified by clv$format_token_array_index.
{
{   .Certain entries in the array - called "format markers" - delineate
{    collections of tokens - called "packets" - which are of interest to
{    to the formatter. An example of such packets would be a series of
{    interpreter tokens which describe a file path name.  All such
{    format markers have an interpreter unit kind of clc$lex_unknown
{    and a token length of zero.
{
{   .Output line and array entries are usually generated by calls from
{    the  clp$f_scan_token procedure.  Format markers are usually
{    requested for inclusion by calls from other modified interpreter
{    procedures.

{  COMMENTS:
{   .The formatter has been modified to use clt$lexical_unit instead of clt$token,
{    to process long (up to 65K) command lines, and to (optionally) translate
{    from "old" SCL types, etc. to "new". These modifications do not provide for
{    formatting input in the "new" form so that it is expected that this formatter
{    will eventually be replaced (which serves as an excuse for some of the
{    "loose ends" which have not been cleaned up).

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amd$page_format_declarations
*copyc cle$ecc_command_processing
*copyc cle$ecc_compare_command
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_parsing
*copyc cle$ecc_scl_formatter
*copyc clt$command_line
*copyc clt$command_line_index
*copyc clt$command_line_size
*copyc clt$f_block
*copyc clt$f_command_type
*copyc clt$f_control_statement_desc
*copyc clt$f_node_value
*copyc clt$file_reference
*copyc clt$format_marker_kind
*copyc clt$format_token_type
*copyc clt$interpreter_modes
*copyc clt$lexical_unit_kind
*copyc clt$lexical_unit_kinds
*copyc clt$parameter_list_size
*copyc clt$parse_state
*copyc clt$string_index
*copyc clt$string_size
*copyc clv$comment_delimiter
*copyc clv$non_space
*copyc clv$string_delimiter
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc amp$get_next
*copyc amp$put_next
*copyc clp$append_status_parse_state
*copyc clp$evaluate_parameters
*copyc clp$evaluate_sub_parameters
*copyc clp$f_pop_block_stack
*copyc clp$f_process_command
*copyc clp$f_push_block_stack
*copyc clp$f_scan_expression
*copyc clp$f_scan_token
*copyc clp$f_set_substitution_mark
*copyc clp$format_proc_header
*copyc clp$initialize_parse_state
*copyc clp$isolate_command
*copyc clp$process_utility_def_file
*copyc clp$search_format_utilities
*copyc clp$trimmed_string_size
*copyc clp$translate_function
*copyc fsp$close_file
*copyc fsp$get_open_information
*copyc fsp$open_file
*copyc mmp$create_scratch_segment
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osv$lower_to_upper
*copyc osv$upper_to_lower
?? EJECT ??

  TYPE
    output_line_record = record
      next_output_pointer: ^output_line_record,
      indent_column: clt$command_line_index,
      output_line_size: clt$command_line_size,
      output_line_ptr: ^clt$command_line,
    recend;

  CONST
    continuation_indicator_size = 2,
    min_page_width = 65,
    min_usable_space = 65,
    max_page_width = clc$max_command_line_size;

  VAR
    input_file_id: amt$file_identifier,
    output_file_id: amt$file_identifier;

  VAR
    work_area_segment: [STATIC] amt$segment_pointer := [amc$sequence_pointer, NIL];

  CONST
    clc$max_error_count = 100,
    clc$indent_increment = 2,
    clc$continuation_increment = 6;

  TYPE
    clt$command_header = record
      command_type: clt$f_command_type,
      command_line_ptr: ^clt$command_line,
      labeled: boolean,
      input_line_number: integer,
      output_line_number: integer,
      command_line_size: clt$command_line_size,
    recend;

  VAR
    clv$input_line_ptr: [STATIC] ^clt$command_line; {For use by clp$get_statement_to_format only,}
                                                    {and clp$f_process_var_or_type.}

  VAR
    clv$add_format_tokens: boolean := TRUE,
    clv$collecting_text: boolean := FALSE,
    clv$colt_until_value: string (osc$max_string_size),
    clv$command_header: clt$command_header,
    clv$continuation_indent_bias: 0 .. clc$continuation_increment,
    clv$current_indent_column: clt$command_line_index,
    clv$current_line_ptr: ^clt$command_line,
    clv$current_line_size: clt$command_line_size,
    clv$error_count: 0 .. amc$file_byte_limit,
    clv$file_position: amt$file_position,
    clv$formatting_in_effect: [XDCL] boolean := TRUE,
    clv$format_line: string (clc$max_command_line_size),
    clv$format_token_array_index: clt$token_array_index,
    clv$input_line_index: clt$command_line_index := 1,
    clv$input_line_size: 0 .. clc$max_command_line_size := 0,
    clv$current_array_ptr: ^clt$format_token_array,
    clv$format_token_array: clt$format_token_array,
    clv$key_character: char := '*',
    clv$last_command_blank: boolean,
    clv$last_command_type: clt$f_command_type,
    clv$last_non_zero_size_index: clt$token_array_index,
    clv$output_line_number: integer,
    clv$page_width: clt$command_line_size,
    clv$process_collect_text: boolean,
    clv$processing_crev: boolean := FALSE,
    clv$save_indent_column: clt$command_line_index,
    clv$saved_blank_lines: 0 .. 5000 := 0,
    clv$space: string (1) := ' ',
    clv$translate: [XDCL] boolean,
    clv$warning_count: 0 .. amc$file_byte_limit;

  VAR
    indent_number: integer,
    number_of_structured_types: integer;

?? TITLE := 'clp$format_scl_proc', EJECT ??

  PROGRAM [XDCL] clp$format_scl_proc
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PURPOSE: This procedure provides the starting procedure for the SCL
{   formatter and controls the formatting process.


    VAR
      got_line: boolean,
      line_ptr: ^clt$command_line,
      local_status: ost$status;

    status.normal := TRUE;
    PUSH clv$input_line_ptr: [clc$max_command_line_size];
    initialize (parameter_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_statement_to_format (line_ptr, got_line, status);

  /doit/
    WHILE got_line DO
      IF status.normal THEN
        IF (clv$last_command_type = clc$proc_declaration) AND (NOT clv$last_command_blank) THEN
          put_line ('', local_status);
        IFEND;
        clv$last_command_type := clc$empty_command;
        clp$f_process_command (clc$interpret_mode, line_ptr, status);
      IFEND;
      IF status.normal THEN
        IF (clv$command_header.command_type <> clc$proc_declaration) AND
              (clv$command_header.command_type <> clc$end_colt_command) AND
              (clv$command_header.command_type <> clc$var_or_type_statement) THEN
          clp$format_line (status);
        IFEND;
      IFEND;
      IF NOT status.normal THEN
        report_status (status, clv$input_line_ptr^ (1, clv$input_line_size), local_status);
        status.normal := TRUE;
        IF (status.condition = cle$table_overflow) OR (clv$error_count >= clc$max_error_count) OR
              (clv$file_position = amc$eoi) THEN
          EXIT /doit/;
        IFEND;
      IFEND;
      clv$last_command_type := clv$command_header.command_type;
      clp$get_statement_to_format (line_ptr, got_line, status);
    WHILEND /doit/;

    IF status.normal AND clv$processing_crev THEN

{Windup

      translate_create_variable (1, 1, NIL, clv$current_indent_column, status);
    IFEND;

    fsp$close_file (input_file_id, local_status);
    IF (NOT local_status.normal) AND status.normal THEN
      status := local_status;
    IFEND;
    fsp$close_file (output_file_id, local_status);
    IF (NOT local_status.normal) AND status.normal THEN
      status := local_status;
    IFEND;

    IF status.normal THEN
      IF clv$error_count >= clc$max_error_count THEN
        osp$set_status_abnormal ('CL', cle$max_error_count_reached, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, clv$error_count, 10, FALSE, status);
      ELSEIF (clv$warning_count > 0) AND (clv$error_count = 0) THEN
        osp$set_status_abnormal ('CL', cle$warnings_encountered, '', status);
        osp$append_status_integer (' ', clv$warning_count, 10, FALSE, status);
      ELSEIF (clv$warning_count = 0) AND (clv$error_count > 0) THEN
        osp$set_status_abnormal ('CL', cle$errors_encountered, '', status);
        osp$append_status_integer (' ', clv$error_count, 10, FALSE, status);
      ELSEIF (clv$warning_count > 0) AND (clv$error_count > 0) THEN
        osp$set_status_abnormal ('CL', cle$errors_and_warnings, '', status);
        osp$append_status_integer (' ', clv$error_count, 10, FALSE, status);
        osp$append_status_integer (' ', clv$warning_count, 10, FALSE, status);
      IFEND;
    IFEND;

  PROCEND clp$format_scl_proc;
?? TITLE := 'clp$add_format_token', EJECT ??

  PROCEDURE [XDCL] clp$add_format_token
    (    str_ptr: ^string ( * );
         clt_kind: clt$lexical_unit_kind;
         format_type: clt$format_token_type);

{ PURPOSE:
{     The purpose of this procedure is to add an entry to the format
{     token array and to add to the output line the string representing the token.

    VAR
      old_size: clt$command_line_size,
      size: clt$command_line_size,
      start_index: clt$command_line_size;

    IF NOT clv$add_format_tokens THEN
      RETURN;
    IFEND;

{ Do not enter duplicate spaces.

    IF (clt_kind = clc$lex_space) AND (clv$format_token_array_index > 0) THEN
      IF (clv$current_array_ptr^ [clv$format_token_array_index].clt_kind = clt_kind) AND
            (clv$current_array_ptr^ [clv$format_token_array_index].format_type = format_type) THEN
        RETURN;
      IFEND;
    IFEND;

{ Check for two strings in a row.

    IF (clt_kind IN $clt$lexical_unit_kinds [clc$lex_string, clc$lex_unterminated_string]) AND
          ((clv$current_array_ptr^ [clv$format_token_array_index].clt_kind = clc$lex_unterminated_string) OR
          (clv$current_array_ptr^ [clv$format_token_array_index].clt_kind = clc$lex_string)) THEN
      size := STRLENGTH (str_ptr^);
      old_size := clv$current_array_ptr^ [clv$format_token_array_index].token_size;
      clv$current_line_ptr^ (clv$current_line_size + 1, size) := str_ptr^;
      clv$current_array_ptr^ [clv$format_token_array_index].string_ptr :=
            ^clv$current_line_ptr^ (clv$current_line_size - old_size + 1, old_size + size);
      clv$current_line_size := clv$current_line_size + size;
      size := size + old_size;
      clv$current_array_ptr^ [clv$format_token_array_index].token_size := size;
    ELSE
      clv$format_token_array_index := clv$format_token_array_index + 1;

{move end_of_line indicator

      clv$current_array_ptr^ [clv$format_token_array_index + 1] :=
            clv$current_array_ptr^ [clv$format_token_array_index];

      clv$current_array_ptr^ [clv$format_token_array_index].clt_kind := clt_kind;

      IF clt_kind = clc$lex_space THEN
        size := 1;
      ELSEIF clt_kind = clc$lex_end_of_line THEN
        size := 0;
      ELSE
        size := STRLENGTH (str_ptr^);
      IFEND;
      IF size > 0 THEN
        clv$current_line_ptr^ (clv$current_line_size + 1, size) := str_ptr^;
        clv$current_array_ptr^ [clv$format_token_array_index].string_ptr :=
              ^clv$current_line_ptr^ (clv$current_line_size + 1, size);
        clv$current_line_size := clv$current_line_size + size;
      IFEND;

      clv$current_array_ptr^ [clv$format_token_array_index].token_size := size;
      clv$current_array_ptr^ [clv$format_token_array_index].format_type := format_type;
    IFEND;


  PROCEND clp$add_format_token;
?? TITLE := 'clp$delete_current_format_token', EJECT ??

  PROCEDURE [XDCL] clp$delete_current_format_token;

{ PURPOSE:
{    The purpose of this procedure is to delete the current format token from the
{    format token array.
{

    IF NOT clv$add_format_tokens THEN
      RETURN;
    IFEND;

{ move end_of-line indicator

    clv$current_array_ptr^ [clv$format_token_array_index] :=
          clv$current_array_ptr^ [clv$format_token_array_index + 1];
    clv$format_token_array_index := clv$format_token_array_index - 1;

  PROCEND clp$delete_current_format_token;
?? TITLE := 'clp$delete_node_format_token', EJECT ??

  PROCEDURE [XDCL] clp$delete_node_format_token
    (    index: clt$token_array_index);

{ PURPOSE:
{    The purpose of this procedure is to delete the current format token from the
{    format token array.
{

    VAR
      node_values: [STATIC, READ] set of clt$f_node_value :=
            [clc$null_node, clc$or_node, clc$and_node, clc$not_node, clc$rel_node, clc$cat_node, clc$add_node,
            clc$mul_node, clc$exp_node];

    IF NOT clv$add_format_tokens THEN
      RETURN;
    IFEND;

    CASE clv$current_array_ptr^ [index].format_type OF
    = clc$tree_begin, clc$node, clc$tree_end =
      IF clv$current_array_ptr^ [index].node_value IN node_values THEN
        clv$current_array_ptr^ [index] := clv$current_array_ptr^ [index + 1];
        clv$format_token_array_index := clv$format_token_array_index - 1;
      IFEND;
    ELSE
      ;
    CASEND;

  PROCEND clp$delete_node_format_token;
?? TITLE := 'clp$f_add_node_value', EJECT ??

  PROCEDURE [XDCL] clp$f_add_node_value
    (    node_value: clt$f_node_value);

{ PURPOSE:
{     The purpose of this procedure is to add to the nearest node format token
{     the node value specified.
{

    CONST
      max_node_names = 4,
      max_operator_name_size = 3;

    VAR
      node_kinds: [STATIC, READ] set of clt$lexical_unit_kind :=
            [clc$lex_name, clc$lex_greater_than, clc$lex_greater_equal, clc$lex_less_than, clc$lex_less_equal,
            clc$lex_equal, clc$lex_not_equal, clc$lex_concatenate, clc$lex_add, clc$lex_subtract,
            clc$lex_multiply, clc$lex_divide, clc$lex_exponentiate],

      node_names: [STATIC, READ] array [1 .. max_node_names] of string (max_operator_name_size) := {} ['OR',
            'XOR', 'AND', 'NOT'],
      i: 1 .. max_node_names,
      index: clt$token_array_index,
      temp_name: string (max_operator_name_size),
      current_token: clt$format_token;

    IF NOT clv$add_format_tokens THEN
      RETURN;
    IFEND;

  /find_node/
    FOR index := clv$format_token_array_index DOWNTO 1 DO
      current_token := clv$current_array_ptr^ [index];
      IF current_token.clt_kind IN node_kinds THEN
        IF (current_token.clt_kind = clc$lex_name) AND (current_token.token_size <= max_operator_name_size)
              THEN
          temp_name := '  ';
          #TRANSLATE (osv$lower_to_upper, current_token.string_ptr^, temp_name);
          FOR i := 1 TO max_node_names DO
            IF node_names [i] = temp_name THEN
              current_token.string_ptr^ := temp_name;
              EXIT /find_node/;
            IFEND;
          FOREND;
        ELSE
          EXIT /find_node/;
        IFEND;
      IFEND;
    FOREND /find_node/;

    IF index = 1 THEN
      RETURN;
    IFEND;
    clv$current_array_ptr^ [index].format_type := clc$node;
    clv$current_array_ptr^ [index].node_value := node_value;

  PROCEND clp$f_add_node_value;
?? TITLE := 'clp$f_get_token_index', EJECT ??

  PROCEDURE [XDCL] clp$f_get_token_index
    (VAR index: integer);

{ PURPOSE:
{   The purpose of this procedure is to obtain the current index into the token
{   array for use in a possible future call to clp$f_set_tree_marker.
{

    index := clv$format_token_array_index;

  PROCEND clp$f_get_token_index;
?? TITLE := 'clp$format_line', EJECT ??

  PROCEDURE clp$format_line
    (VAR status: ost$status);

{ PURPOSE:
{   The purpose of this procedure is to generate and output the
{   final formatted line. Procedures called only by this procedure
{   may be nested within this procedure.

    VAR
      begin_count: clt$string_size,
      begin_type: clt$format_token_type,
      continuation_indent_size: clt$command_line_size,
      continuation_lines_with_indent: clt$command_line_size,
      current_string: string (osc$max_string_size),
      escape_encountered: boolean,
      end_type: clt$format_token_type,
      previous_token: clt$format_token,
      current_token: clt$format_token,
      max_array_index: clt$token_array_index,
      temp_name: ost$name,
      temp_index: clt$token_array_index,
      format_index: clt$token_array_index,
      line_ptr: ^clt$command_line,
      line_size: clt$command_line_size,
      indent_size: clt$command_line_size,
      name_size: 0 .. osc$max_name_size,
      final_token_count: clt$token_array_index,
      save_indent: clt$command_line_index,
      first_output_pointer: ^output_line_record,
      current_output_pointer: ^output_line_record,
      last_output_pointer: ^output_line_record,
      packet: ^clt$command_line,
      packet_line_begin: clt$command_line_index,
      packet_size: clt$command_line_size,
      translate_line_ptr: ^clt$command_line,
      translate_line_size: clt$command_line_size,
      first_index: clt$token_array_index,
      line_to_print: ^clt$command_line;

?? NEWTITLE := 'fits_on_current/next_line', EJECT ??

    FUNCTION [INLINE] fits_on_current_line
      (    string_size: clt$string_size;
           reserve_size: 0 .. continuation_indicator_size): boolean;

      fits_on_current_line := (current_output_pointer^.output_line_size + string_size +
            current_output_pointer^.indent_column - 1 + reserve_size) <= clv$page_width;

    FUNCEND fits_on_current_line;

    FUNCTION [INLINE] fits_on_next_line
      (    string_size: clt$string_size;
           indent: clt$command_line_size;
           reserve_size: 0 .. continuation_indicator_size): boolean;

      fits_on_next_line := (string_size + indent - 1 + reserve_size) < clv$page_width;

    FUNCEND fits_on_next_line;
?? OLDTITLE ??
?? NEWTITLE := 'rebuild_array', EJECT ??

    PROCEDURE rebuild_array
      (    array_ptr: ^clt$format_token_array;
           begin_index: clt$token_array_index;
           translate_line_ptr: ^clt$command_line;
       VAR translate_line_size: clt$command_line_size;
       VAR last_non_zero_size_index: clt$token_array_index;
       VAR output_index: clt$token_array_index;
       VAR status: ost$status);

{ PURPOSE:
{   The purpose of this procedure is to modify the specified format token array
{   such that the requirements for spaces are satisifed and that names are set
{   to the required case.

      TYPE
        command_types = set of clt$f_command_type;

      VAR
        upper_case_name_types: [STATIC, READ] command_types :=
              [clc$control_statement_begin, clc$control_statement_end, clc$control_statement_switch,
              clc$control_statement_no_switch, clc$procend_command, clc$collect_text_command,
              clc$utility_begin, clc$utility_end];

      VAR
        end_input_index: clt$token_array_index,
        first_name_found: boolean,
        input_index: clt$token_array_index,
        insert_spaces_for_assignment: boolean,
        parameter_level: 0 .. clc$max_command_line_size DIV 2,
        temp_format_array: ^clt$format_token_array,
        temp_name: ost$name,
        token: clt$format_token;

?? NEWTITLE := 'copy_format_token', EJECT ??

      PROCEDURE copy_format_token;

        output_index := output_index + 1;
        array_ptr^ [output_index] := token;
        IF token.token_size > 0 THEN
          previous_token := token;
          last_non_zero_size_index := output_index;
        IFEND;

      PROCEND copy_format_token;
?? OLDTITLE ??
?? NEWTITLE := 'insert_space_token', EJECT ??

      PROCEDURE insert_space_token;

        output_index := output_index + 1;

        array_ptr^ [output_index].clt_kind := clc$lex_space;
        array_ptr^ [output_index].token_size := 1;
        array_ptr^ [output_index].format_type := clc$unassigned;
        array_ptr^ [output_index].string_ptr := ^clv$space;
        previous_token := array_ptr^ [output_index];

      PROCEND insert_space_token;
?? OLDTITLE ??
?? NEWTITLE := 'delete_last_space_token', EJECT ??

      PROCEDURE delete_last_space_token;

{ PURPOSE:
{   The purpose of this procedure is to provide the rebuild_array
{   procedure the capability of deleting the last space token (which may
{   not be the current token due to format marker tokens existing).

        VAR
          index: clt$token_array_index,
          index2: clt$token_array_index,
          token: clt$format_token;

        FOR index := output_index DOWNTO 1 DO
          token := array_ptr^ [index];
          IF token.token_size > 0 THEN
            IF token.clt_kind = clc$lex_space THEN
              output_index := output_index - 1;
              FOR index2 := index TO output_index DO
                array_ptr^ [index2] := array_ptr^ [index2 + 1];
              FOREND;
              RETURN;
            ELSE
              RETURN;
            IFEND;
          IFEND;
        FOREND;

      PROCEND delete_last_space_token;
?? OLDTITLE, EJECT ??

      PUSH temp_format_array;
      end_input_index := output_index;
      FOR input_index := 1 TO end_input_index DO
        temp_format_array^ [input_index] := array_ptr^ [input_index];
      FOREND;
      temp_format_array^ [end_input_index + 1].clt_kind := clc$lex_end_of_line;
      temp_format_array^ [end_input_index + 1].token_size := 0;

      input_index := begin_index - 1;
      output_index := begin_index - 1;
      IF input_index > 0 THEN
        previous_token := temp_format_array^ [input_index];
      ELSE
        previous_token.clt_kind := clc$lex_unknown;
      IFEND;
      input_index := input_index + 1;
      token := temp_format_array^ [input_index];
      parameter_level := 0;
      first_name_found := FALSE;

    /rebuild/
      WHILE token.clt_kind <> clc$lex_end_of_line DO
        insert_spaces_for_assignment := FALSE;
        IF clv$translate AND (token.format_type = clc$function_begin) THEN
          translate_function (input_index, temp_format_array, translate_line_ptr, end_input_index,
                translate_line_size, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          temp_format_array^ [end_input_index + 1].clt_kind := clc$lex_end_of_line;
          temp_format_array^ [end_input_index + 1].token_size := 0;
          IF temp_format_array^ [input_index + 1].format_type = clc$function_begin THEN
            copy_format_token;
            input_index := input_index + 2;
          IFEND;
          token := temp_format_array^ [input_index];
        IFEND;

        IF (token.clt_kind = clc$lex_name) THEN
          IF NOT first_name_found THEN
            first_name_found := TRUE;
            IF clv$command_header.command_type IN upper_case_name_types THEN
              token.format_type := clc$reserved_name;
            IFEND;
          IFEND;
          temp_name := token.string_ptr^;
          IF (token.format_type <> clc$reserved_name) AND (token.format_type <> clc$node) THEN
            #TRANSLATE (osv$upper_to_lower, temp_name, token.string_ptr^);
          ELSE
            #TRANSLATE (osv$lower_to_upper, temp_name, token.string_ptr^);
          IFEND;
        IFEND;

        IF ((token.format_type = clc$node) AND (token.clt_kind <> clc$lex_name)) OR
              (token.clt_kind = clc$lex_assign) OR (token.clt_kind = clc$lex_ellipsis) THEN
          CASE clv$command_header.command_type OF
          = clc$assignment, clc$control_statement_begin, clc$control_statement_end, clc$proc_declaration,
            clc$control_statement_switch, clc$control_statement_no_switch, clc$var_or_type_statement =
            IF parameter_level = 0 THEN
              IF (token.clt_kind = clc$lex_assign) AND (previous_token.clt_kind <> clc$lex_space) THEN
                insert_space_token;
                insert_spaces_for_assignment := TRUE;
              IFEND;
              copy_format_token;
              input_index := input_index + 1;
              token := temp_format_array^ [input_index];
              IF token.clt_kind = clc$lex_space THEN
                copy_format_token;
                input_index := input_index + 1;
                token := temp_format_array^ [input_index];
              ELSEIF insert_spaces_for_assignment THEN
                insert_space_token;
              IFEND;
            ELSE {parameter_level <> 0}
              IF previous_token.clt_kind = clc$lex_space THEN
                delete_last_space_token;
              IFEND;
              copy_format_token;
              input_index := input_index + 1;
              token := temp_format_array^ [input_index];
              IF token.clt_kind = clc$lex_space THEN
                input_index := input_index + 1;
                token := temp_format_array^ [input_index];
              IFEND;
            IFEND; {if parameter_level = 0}
          ELSE {CASE clv$command_header.command_type}
            IF previous_token.clt_kind = clc$lex_space THEN

{ Don't delete last space token if a parameter begins with a node.

              IF NOT ((output_index >= 2) AND (array_ptr^ [output_index].format_type = clc$tree_begin) AND
                    (array_ptr^ [output_index - 1].format_type = clc$parameter_begin)) THEN
                delete_last_space_token;
              IFEND;
            IFEND;
            copy_format_token;
            input_index := input_index + 1;
            token := temp_format_array^ [input_index];
          CASEND;
        ELSEIF token.clt_kind = clc$lex_comma THEN
          IF previous_token.clt_kind = clc$lex_space THEN
            delete_last_space_token;
          IFEND;
          copy_format_token;
          input_index := input_index + 1;
          token := temp_format_array^ [input_index];
          IF token.clt_kind <> clc$lex_space THEN
            insert_space_token;
          IFEND;
        ELSEIF token.clt_kind = clc$lex_left_parenthesis THEN
          copy_format_token;
          input_index := input_index + 1;
          IF temp_format_array^ [input_index].clt_kind = clc$lex_space THEN
            input_index := input_index + 1;
          IFEND;
          token := temp_format_array^ [input_index];
        ELSEIF (token.clt_kind = clc$lex_right_parenthesis) OR (token.clt_kind = clc$lex_space) THEN
          IF previous_token.clt_kind = clc$lex_space THEN
            delete_last_space_token;
          IFEND;
          copy_format_token;
          input_index := input_index + 1;
          token := temp_format_array^ [input_index];
        ELSE
          CASE token.format_type OF
          = clc$parameter_begin =
            parameter_level := parameter_level + 1;
          = clc$parameter_end =
            parameter_level := parameter_level - 1;
          ELSE
          CASEND;
          copy_format_token;
          input_index := input_index + 1;
          token := temp_format_array^ [input_index];
        IFEND;
      WHILEND /rebuild/;

      array_ptr^ [output_index + 1].clt_kind := clc$lex_end_of_line;
      array_ptr^ [output_index + 1].token_size := 0;

    PROCEND rebuild_array;
?? OLDTITLE ??
?? NEWTITLE := 'process_label', EJECT ??

    PROCEDURE process_label
      (VAR indent: clt$command_line_index;
       VAR current_token: clt$format_token;
       VAR format_index: clt$token_array_index;
       VAR current_output_pointer: ^output_line_record;
       VAR status: ost$status);

      VAR
        current_string: string (osc$max_name_size + 2),
        name_size: 0 .. osc$max_name_size,
        output_size: 0 .. osc$max_name_size + 2;

      IF current_token.clt_kind <> clc$lex_name THEN
        osp$set_status_abnormal ('CL', cle$internal_formatter_error, ' Cant find label ', status);
        RETURN;
      IFEND;
      temp_name := current_token.string_ptr^;
      name_size := clp$trimmed_string_size (temp_name);
      #TRANSLATE (osv$upper_to_lower, temp_name (1, name_size), current_string);
      IF clv$current_indent_column > clc$indent_increment THEN
        current_output_pointer^.indent_column := clv$current_indent_column - clc$indent_increment;
      ELSE
        current_output_pointer^.indent_column := clv$current_indent_column;
      IFEND;
      current_string (name_size + 1) := ':';
      output_size := name_size + 1;
      format_index := format_index + 2;
      IF clv$current_array_ptr^ [format_index].clt_kind = clc$lex_space THEN
        output_size := output_size + 1;
        format_index := format_index + 1;
      IFEND;
      put_string (^current_string (1, output_size), TRUE, 2, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      generate_continuation (TRUE, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      current_output_pointer^.indent_column := clv$current_indent_column;

    PROCEND process_label;
?? OLDTITLE ??
?? NEWTITLE := 'put_it_if_you_can', EJECT ??

    PROCEDURE put_it_if_you_can
      (    str_size: clt$command_line_size;
           begin_index: clt$token_array_index;
           end_index: clt$token_array_index;
           reserve_size: 0 .. 2;
           continuation_okay: boolean;
           array_ptr: ^clt$format_token_array;
       VAR did: boolean;
       VAR status: ost$status);

      did := FALSE;
      IF fits_on_current_line (str_size, reserve_size) THEN
        IF NOT ((str_size = 1) AND (array_ptr^ [begin_index].string_ptr^ = '.')) OR
              fits_on_current_line (array_ptr^ [begin_index + 1].token_size + 1, reserve_size) THEN
          put_string_from_array (str_size, begin_index, end_index, array_ptr, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          did := TRUE;
        IFEND;
      ELSEIF fits_on_next_line (str_size, clv$current_indent_column + clc$continuation_increment,
            reserve_size) THEN
        IF continuation_okay THEN
          IF (array_ptr^ [begin_index].clt_kind = clc$lex_left_parenthesis) AND (begin_index > 2) AND
                (array_ptr^ [begin_index - 2].format_type = clc$function_begin) THEN
            generate_continuation (FALSE, status);
          ELSE
            generate_continuation (TRUE, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          put_string_from_array (str_size, begin_index, end_index, array_ptr, status);
          did := TRUE;
        IFEND;
      IFEND;

    PROCEND put_it_if_you_can;
?? OLDTITLE ??
?? NEWTITLE := 'put_string', EJECT ??

    PROCEDURE put_string
      (    str_ptr: ^clt$command_line;
           ignore_length_restrictions: boolean;
           reserve_size: 0 .. 2;
       VAR status: ost$status);

{ This procedure outputs the specified string. If IGNORE_LENGTH_RESTRICTIONS
{  is true, the string will be added to the current line without checking
{  the resulting line size. Otherwise, if the string will overflow the
{  line, it will be broken, ellipses added, and the remainder placed on the
{  following line.

      VAR
        indent: clt$command_line_index,
        string_size: clt$command_line_size,
        string_index: clt$command_line_index,
        temp_size: clt$command_line_size;

      string_size := STRLENGTH (str_ptr^);
      string_index := 1;

      WHILE string_size > 0 DO
        indent := clv$current_indent_column + clv$continuation_indent_bias;
        IF fits_on_current_line (string_size, reserve_size) OR ignore_length_restrictions THEN
          current_output_pointer^.output_line_ptr^ (current_output_pointer^.output_line_size + 1,
                string_size) := str_ptr^ (string_index, string_size);
          current_output_pointer^.output_line_size := current_output_pointer^.output_line_size + string_size;
          RETURN;
        IFEND;

        temp_size := clv$page_width - current_output_pointer^.output_line_size - indent;
        IF temp_size > continuation_indicator_size THEN
          temp_size := temp_size - continuation_indicator_size;
          WHILE (temp_size > 0) AND (str_ptr^ (string_index + temp_size - 1) = '.') DO
            temp_size := temp_size - 1;
          WHILEND;
          IF (temp_size = 0) AND (current_output_pointer^.indent_column = 1) THEN
            osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'Too many periods.', status);
            RETURN;
          IFEND;
          current_output_pointer^.output_line_ptr^ (current_output_pointer^.output_line_size + 1,
                temp_size) := str_ptr^ (string_index, temp_size);
          current_output_pointer^.output_line_size := current_output_pointer^.output_line_size + temp_size;
          string_size := string_size - temp_size;
          string_index := string_index + temp_size;
        IFEND;
        IF string_size > 0 THEN
          generate_continuation (FALSE, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      WHILEND;

    PROCEND put_string;
?? OLDTITLE ??
?? NEWTITLE := 'generate_continuation', EJECT ??

    PROCEDURE generate_continuation
      (    indent_next: boolean;
       VAR status: ost$status);

      VAR
        indent: clt$command_line_index,
        inhibit_indent: boolean,
        next_output_pointer: ^output_line_record;

{ Inhibit indentation of the continuation line if string concatination is the last operator
{ in the current line.
      inhibit_indent := (current_output_pointer^.output_line_ptr^
            (current_output_pointer^.output_line_size - 1, 2) = '//') OR
            (clv$command_header.command_type = clc$var_or_type_statement);

      current_output_pointer^.output_line_ptr^ (current_output_pointer^.output_line_size + 1,
            continuation_indicator_size) := '..';
      current_output_pointer^.output_line_size := current_output_pointer^.output_line_size +
            continuation_indicator_size;

      ALLOCATE next_output_pointer;
      IF next_output_pointer <> NIL THEN
        ALLOCATE next_output_pointer^.output_line_ptr: [clv$page_width + 5 {|} ];
      IFEND;
      IF next_output_pointer^.output_line_ptr = NIL THEN
        osp$set_status_abnormal ('CL', cle$table_overflow, 'next_output_pointer', status);
        RETURN;
      IFEND;

      IF indent_next AND NOT inhibit_indent THEN
        indent := clv$current_indent_column + clc$continuation_increment;
      ELSE
        indent := 1;
      IFEND;

      current_output_pointer^.next_output_pointer := next_output_pointer;
      next_output_pointer^.next_output_pointer := NIL;
      next_output_pointer^.indent_column := indent;
      next_output_pointer^.output_line_size := 0;
      next_output_pointer^.output_line_ptr^ := '';
      current_output_pointer := next_output_pointer;
      clv$continuation_indent_bias := clc$continuation_increment;

    PROCEND generate_continuation;
?? OLDTITLE ??
?? NEWTITLE := 'put_packet', EJECT ??

    PROCEDURE put_packet
      (    packet_size: clt$command_line_size;
           begin_index: clt$token_array_index;
           end_index: clt$token_array_index;
           max_array_index: clt$token_array_index;
           indent_on_continuation: boolean;
           array_ptr: ^clt$format_token_array;
       VAR status: ost$status);

      VAR
        current_token: clt$format_token,
        did: boolean,
        index: clt$token_array_index,
        index_to_set: clt$token_array_index,
        reserve_size: 0 .. continuation_indicator_size;

      IF end_index >= clv$last_non_zero_size_index THEN
        reserve_size := 0;
      ELSE
        reserve_size := continuation_indicator_size;
      IFEND;

      IF fits_on_current_line (packet_size, reserve_size) THEN
        put_string_from_array (packet_size, begin_index, end_index, array_ptr, status);
        RETURN;
      IFEND;

      index := begin_index;

    /process/
      WHILE index <= end_index DO
        current_token := array_ptr^ [index];
        CASE current_token.format_type OF
        = clc$tree_begin =
          put_tree (index, max_array_index, indent_on_continuation, array_ptr, index_to_set, status);
        = clc$parameter_begin =
          put_parameter (index, max_array_index, array_ptr, index_to_set, status);
        = clc$file_or_var_begin =
          put_file_or_variable (index, max_array_index, array_ptr, { indent_on_continuation } FALSE,
                index_to_set, status);
        ELSE
          IF index >= clv$last_non_zero_size_index THEN
            reserve_size := 0;
          ELSE
            reserve_size := continuation_indicator_size;
          IFEND;
          IF current_token.token_size > 0 THEN
            put_it_if_you_can (current_token.token_size, index, index, reserve_size, indent_on_continuation,
                  array_ptr, did, status);
            IF status.normal AND (NOT did) THEN
              generate_continuation (indent_on_continuation, status);
              IF status.normal THEN
                put_string (current_token.string_ptr, FALSE, reserve_size, status);
              IFEND;
            IFEND;
          IFEND;
          index_to_set := index;
        CASEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        index := index_to_set + 1;
      WHILEND /process/;

    PROCEND put_packet;
?? TITLE := 'put_tree', EJECT ??

    PROCEDURE put_tree
      (    begin_index: clt$token_array_index;
           max_array_index: clt$token_array_index;
           indent_on_continuation: boolean;
           array_ptr: ^clt$format_token_array;
       VAR end_index: clt$token_array_index;
       VAR status: ost$status);

      VAR
        current_token: clt$format_token,
        index: clt$token_array_index,
        local_indent_control: boolean,
        nesting_level: clt$command_line_size,
        node_index: clt$command_line_index,
        node_value: clt$f_node_value,
        nodes_encountered: clt$command_line_size,
        reserve_size: 0 .. continuation_indicator_size,
        size_after_node: clt$command_line_size,
        size_with_node: clt$command_line_size;

      IF array_ptr^ [begin_index].format_type <> clc$tree_begin THEN
        osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'Cant find tree_begin.', status);
        end_index := max_array_index;
        RETURN;
      IFEND;

      nesting_level := 0;
      node_index := 1;
      node_value := array_ptr^ [begin_index].node_value;
      nodes_encountered := 0;
      size_with_node := 0;
      size_after_node := 0;
      end_index := begin_index + 1;

    /isolate_tree/
      WHILE end_index <= max_array_index DO
        current_token := array_ptr^ [end_index];
        nesting_level := nesting_level + $INTEGER (current_token.clt_kind =
              clc$lex_left_parenthesis) - $INTEGER (current_token.clt_kind = clc$lex_right_parenthesis);
        CASE current_token.format_type OF
        = clc$node =
          IF (current_token.node_value = node_value) AND (nesting_level = 0) THEN
            IF array_ptr^ [end_index + 1].clt_kind IN $clt$lexical_unit_kinds
                  [clc$lex_space, clc$lex_comment, clc$lex_unterminated_comment] THEN
              node_index := end_index + 1;
              size_with_node := size_with_node + current_token.token_size + 1 + size_after_node;
              local_indent_control := TRUE;
              end_index := end_index + 1;
            ELSE
              node_index := end_index;
              size_with_node := size_with_node + current_token.token_size + size_after_node;
              local_indent_control := FALSE;
            IFEND;
            size_after_node := 0;
            nodes_encountered := nodes_encountered + 1;
          ELSEIF nodes_encountered = 0 THEN
            size_with_node := size_with_node + current_token.token_size;
          ELSE
            size_after_node := size_after_node + current_token.token_size;
          IFEND;
        = clc$tree_end =
          IF (current_token.node_value = node_value) AND (nesting_level = 0) THEN
            IF nodes_encountered = 0 THEN
              node_index := end_index;
            IFEND;
            EXIT /isolate_tree/;
          IFEND;
        ELSE
          IF current_token.clt_kind = clc$lex_end_of_line THEN
            osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'Cant find tree_end.', status);
            RETURN;
          ELSEIF current_token.token_size > 0 THEN
            IF nodes_encountered = 0 THEN
              node_index := end_index;
              size_with_node := size_with_node + current_token.token_size;
            ELSE
              size_after_node := size_after_node + current_token.token_size;
            IFEND;
          IFEND;
        CASEND;
        end_index := end_index + 1;
      WHILEND /isolate_tree/;

      local_indent_control := local_indent_control AND indent_on_continuation;

      IF end_index >= clv$last_non_zero_size_index THEN
        reserve_size := 0;
      ELSE
        reserve_size := continuation_indicator_size;
      IFEND;

      IF fits_on_current_line (size_with_node + size_after_node, reserve_size) THEN
        put_string_from_array (size_with_node + size_after_node, begin_index, end_index, array_ptr, status);
        RETURN;
      IFEND;

      IF fits_on_current_line (size_with_node, continuation_indicator_size) THEN
        put_string_from_array (size_with_node, begin_index, node_index, array_ptr, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        generate_continuation (local_indent_control, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        current_token := array_ptr^ [node_index + 1];
        IF local_indent_control AND (current_token.clt_kind = clc$lex_space) THEN
          node_index := node_index + 1;
          size_after_node := size_after_node - current_token.token_size;
        IFEND;
      ELSE
        put_packet (size_with_node, begin_index + 1, node_index, max_array_index, local_indent_control,
              array_ptr, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF fits_on_current_line (size_after_node, reserve_size) THEN
        put_string_from_array (size_after_node, node_index + 1, end_index, array_ptr, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        put_packet (size_after_node, node_index + 1, end_index, max_array_index, local_indent_control,
              array_ptr, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    PROCEND put_tree;
?? TITLE := 'put_string_from_array', EJECT ??

    PROCEDURE put_string_from_array
      (    string_size: clt$command_line_size;
           begin_index: clt$token_array_index;
           end_index: clt$token_array_index;
           array_ptr: ^clt$format_token_array;
       VAR status: ost$status);

      VAR
        current_string_size: clt$command_line_size,
        index: clt$token_array_index,
        string_ptr: ^string ( * ),
        token_size: clt$string_size;

{ This procedure assembles a string from the specified tokens in the array
{ and writes the string to the output line. It is assumed that string will
{ fit on the current line.

      PUSH string_ptr: [string_size];
      current_string_size := 0;

      FOR index := begin_index TO end_index DO
        token_size := array_ptr^ [index].token_size;
        IF token_size > 0 THEN
          string_ptr^ (current_string_size + 1, token_size) := array_ptr^ [index].string_ptr^;
          current_string_size := current_string_size + token_size;
        IFEND;
      FOREND;

      put_string (string_ptr, TRUE, 0, status);

    PROCEND put_string_from_array;
?? TITLE := 'put_parameter', EJECT ??

    PROCEDURE put_parameter
      (    begin_index: clt$token_array_index;
           max_array_index: clt$token_array_index;
           array_ptr: ^clt$format_token_array;
       VAR end_index: clt$token_array_index;
       VAR status: ost$status);

      VAR
        did: boolean,
        comment_index: clt$token_array_index,
        comment_size: clt$command_line_size,
        continuation_size: 0 .. continuation_indicator_size,
        index: clt$token_array_index,
        nested_value_set_count: clt$list_size,
        packet: ^clt$command_line,
        packet_size: clt$command_line_size,
        parameter_line_begin: clt$command_line_index,
        parameter_size: clt$command_line_size,
        parameter_begin: clt$token_array_index,
        parameter_end: clt$token_array_index,
        parameter_name: ost$name,
        parameter_name_size: 0 .. osc$max_name_size,
        postlude_line_begin: clt$command_line_index,
        postlude_size: clt$command_line_size,
        postlude_begin: clt$token_array_index,
        postlude_end: clt$token_array_index,
        prelude_line_begin: clt$command_line_index,
        prelude_size: clt$command_line_size,
        prelude_begin: clt$token_array_index,
        prelude_end: clt$token_array_index,
        save_index: clt$token_array_index,
        token: clt$format_token,
        total_size: clt$command_line_size,
        value_line_begin: clt$command_line_index,
        value_set_count: clt$list_size;


      index := begin_index;
      continuation_size := continuation_indicator_size;

    /format_loop/
      BEGIN
        token := array_ptr^ [index];
        IF token.clt_kind = clc$lex_end_of_line THEN
          EXIT /format_loop/;
        IFEND;
        IF token.format_type <> clc$parameter_begin THEN
          osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'Cant find parameter_begin.', status);
          RETURN;
        IFEND;

        isolate_parameter (index, max_array_index, array_ptr, FALSE, comment_index, comment_size,
              parameter_name, parameter_name_size, prelude_size, prelude_begin, prelude_end, parameter_size,
              parameter_begin, parameter_end, postlude_size, postlude_begin, postlude_end, value_set_count,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        end_index := postlude_end;

        IF array_ptr^ [postlude_end + 1].clt_kind = clc$lex_end_of_line THEN
          continuation_size := 0;
        IFEND;

        IF prelude_size = 0 THEN
          prelude_line_begin := parameter_line_begin;
        IFEND;

        total_size := prelude_size + parameter_size + postlude_size + comment_size;

        IF fits_on_current_line (total_size, continuation_size) THEN
          put_string_from_array (total_size, prelude_begin, postlude_end, array_ptr, status);
          RETURN;
        ELSEIF value_set_count = 0 THEN
          IF fits_on_next_line (total_size, clv$current_indent_column + clc$continuation_increment,
                continuation_size) THEN
            generate_continuation (TRUE, status);
            IF status.normal THEN
              put_string_from_array (total_size, prelude_begin, postlude_end, array_ptr, status);
            IFEND;
          ELSE
            put_packet (total_size, prelude_begin, postlude_end, max_array_index, FALSE, array_ptr, status);
          IFEND;
          RETURN;
        IFEND;

        IF prelude_size > 0 THEN
          put_packet (prelude_size, prelude_begin, prelude_end, max_array_index, TRUE, array_ptr, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        index := parameter_begin;
        token := array_ptr^ [index];
        IF token.format_type <> clc$value_set_begin THEN
          put_packet (parameter_size, index, parameter_end, max_array_index, TRUE, array_ptr, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF postlude_size > 0 THEN
            put_packet (postlude_size, postlude_begin, postlude_end, max_array_index, TRUE, array_ptr,
                  status);
          IFEND;
          RETURN;
        IFEND;

      /format_value_sets/
        WHILE value_set_count > 0 DO
          token := array_ptr^ [index];
          packet_size := 0;
          index := index + 1;
          save_index := index;
          token := array_ptr^ [index];
          nested_value_set_count := 1;

          WHILE token.format_type <> clc$value_set_end DO
            IF token.format_type = clc$value_set_begin THEN
              nested_value_set_count := nested_value_set_count + 1;
            IFEND;
            IF token.token_size > 0 THEN
              packet_size := packet_size + token.token_size;
            IFEND;
            index := index + 1;
            token := array_ptr^ [index];
            IF token.format_type = clc$value_set_end THEN
              nested_value_set_count := nested_value_set_count - 1;
              IF nested_value_set_count <> 0 THEN
                index := index + 1;
                token := array_ptr^ [index];
                value_set_count := value_set_count - 1;
              IFEND;
            IFEND;
          WHILEND;

          index := index + 1;
          token := array_ptr^ [index];

          WHILE (token.clt_kind = clc$lex_comma) OR (token.clt_kind = clc$lex_space) DO
            packet_size := packet_size + token.token_size;
            index := index + 1;
            token := array_ptr^ [index];
          WHILEND;

          put_packet (packet_size, save_index, index - 1, max_array_index, TRUE, array_ptr, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          value_set_count := value_set_count - 1;

        WHILEND /format_value_sets/;

        IF postlude_size > 0 THEN
          put_packet (postlude_size, postlude_begin, postlude_end, max_array_index, TRUE, array_ptr, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      END /format_loop/;

    PROCEND put_parameter;
?? TITLE := 'put_file_or_variable', EJECT ??

    PROCEDURE put_file_or_variable
      (    begin_index: clt$token_array_index;
           max_array_index: clt$token_array_index;
           array_ptr: ^clt$format_token_array;
           indent_on_continuation: boolean;
       VAR end_index: clt$token_array_index;
       VAR status: ost$status);

      VAR
        current_token: clt$format_token,
        did: boolean,
        index: clt$token_array_index,
        current_begin_index: clt$token_array_index,
        current_end_index: clt$token_array_index,
        processing_file: boolean,
        string_size: clt$command_line_size;

      string_size := 0;

    /isolate/
      FOR end_index := begin_index + 1 TO max_array_index DO
        current_token := array_ptr^ [end_index];
        IF current_token.format_type = clc$file_or_var_end THEN
          EXIT /isolate/;
        IFEND;

        IF current_token.token_size > 0 THEN
          string_size := string_size + current_token.token_size
        IFEND;

        IF current_token.clt_kind = clc$lex_end_of_line THEN
          osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'Cant find file_or_var_end.', status);
          RETURN;
        IFEND;
      FOREND /isolate/;

      IF fits_on_current_line (string_size, continuation_indicator_size) THEN
        put_string_from_array (string_size, begin_index, end_index, array_ptr, status);
        RETURN;
      ELSE
        put_it_if_you_can (string_size, begin_index, end_index, continuation_indicator_size,
              indent_on_continuation, array_ptr,
              did, status);
        IF did OR (NOT status.normal) THEN
          RETURN;
        IFEND;
      IFEND;

      string_size := 0;
      current_begin_index := begin_index + 1;

{ NOTE: The following ensures that a dot is not placed at (or   near) the
{ end of a line where it may later be absorbed into a
{ continuation ellipses.

    /put_it/
      FOR index := begin_index + 1 TO end_index - 1 DO
        current_token := array_ptr^ [index];
        IF current_token.clt_kind = clc$lex_dot THEN
          IF string_size > 0 THEN
            IF NOT fits_on_current_line (string_size, continuation_indicator_size) THEN
              generate_continuation (FALSE, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
            put_string_from_array (string_size, current_begin_index, index - 1, array_ptr, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
          string_size := current_token.token_size;
          current_begin_index := index;
        ELSE
          IF current_token.token_size > 0 THEN
            string_size := string_size + current_token.token_size;
            IF NOT fits_on_current_line (string_size, continuation_indicator_size) THEN
              generate_continuation (FALSE, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
            put_string_from_array (string_size, current_begin_index, index, array_ptr, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            current_begin_index := index + 1;
            string_size := 0;
          IFEND;
        IFEND;
      FOREND /put_it/;

{ NOTE: At this time the only item not written to the output line must
{ be a dot. Although (currently) this is an error which should  have
{ been detected by the formatter's lexical scanner, the dot will be
{ written to the beginning of the next continuation line.

      IF string_size > 0 THEN
        generate_continuation (FALSE, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        put_string_from_array (string_size, current_begin_index, index, array_ptr, status);
      IFEND;

    PROCEND put_file_or_variable;
?? OLDTITLE ??
?? EJECT ??

    clv$continuation_indent_bias := 0;
    escape_encountered := FALSE;
    status.normal := TRUE;
    IF (clv$command_header.command_line_size = 0) THEN
      put_line ('', status);
      RETURN;
    IFEND;

    max_array_index := clv$format_token_array_index;
    format_index := 1;
    clv$current_array_ptr^ [max_array_index + 1].clt_kind := clc$lex_end_of_line;
    IF clv$processing_crev AND (clv$command_header.command_type <> clc$to_be_translated_command) THEN

{ Wind up translation

      translate_create_variable (format_index, max_array_index, clv$current_array_ptr,
            clv$current_indent_column, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    CASE clv$command_header.command_type OF
    = clc$control_statement_end, clc$control_statement_switch, clc$utility_end, clc$procend_command =
      IF clv$current_indent_column > clc$indent_increment THEN
        clv$current_indent_column := clv$current_indent_column - clc$indent_increment;
      IFEND;
    = clc$end_colt_command =
      clv$collecting_text := FALSE;
      clv$current_indent_column := clv$save_indent_column;
      put_line (clv$colt_until_value (1, clp$trimmed_string_size (clv$colt_until_value)), status);
      RETURN;
    = clc$to_be_translated_command =

{ Wait until leading comments, etc are processed and to check if translating

    ELSE
      ;
    CASEND;
    IF NOT (clv$translate AND (clv$command_header.command_type = clc$to_be_translated_command)) THEN
      process_leading_comments (clv$current_array_ptr, max_array_index, clv$current_indent_column,
            format_index, status);
      IF (NOT status.normal) OR (clv$current_array_ptr^ [format_index].clt_kind = clc$lex_end_of_line) THEN
        IF clv$command_header.command_type = clc$utility_begin THEN
          clv$current_indent_column := clv$current_indent_column + clc$indent_increment;
        IFEND;
        RETURN;
      IFEND;
    IFEND;

    PUSH first_output_pointer;
    PUSH first_output_pointer^.output_line_ptr: [clv$page_width];
    IF first_output_pointer^.output_line_ptr = NIL THEN
      osp$set_status_abnormal ('CL', cle$table_overflow, 'first output pointer', status);
      RETURN;
    IFEND;

    first_output_pointer^.next_output_pointer := NIL;
    first_output_pointer^.indent_column := clv$current_indent_column;
    first_output_pointer^.output_line_size := 0;
    first_output_pointer^.output_line_ptr^ := '';
    current_output_pointer := first_output_pointer;

    current_token := clv$current_array_ptr^ [format_index];

    IF clv$command_header.labeled THEN
      process_label (clv$current_indent_column, current_token, format_index, current_output_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF current_token.clt_kind = clc$lex_divide THEN
      escape_encountered := TRUE;
      put_line ('/ ..', status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      format_index := format_index + 1;
      IF clv$current_array_ptr^ [format_index].clt_kind = clc$lex_space THEN
        format_index := format_index + 1;
      IFEND;
    IFEND;

    IF clv$translate THEN
      PUSH translate_line_ptr: [clc$max_command_line_size];
      translate_line_size := 0;
    IFEND;

    rebuild_array (clv$current_array_ptr, format_index, translate_line_ptr, translate_line_size,
          clv$last_non_zero_size_index, max_array_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_token := clv$current_array_ptr^ [format_index];

    IF clv$command_header.command_type = clc$collect_text_command THEN
      current_output_pointer^.indent_column := 1;
    ELSEIF clv$command_header.command_type = clc$var_or_type_statement THEN
      IF number_of_structured_types < indent_number THEN
        indent_number := number_of_structured_types;
      IFEND;
      current_output_pointer^.indent_column := clv$current_indent_column + 2
           + 2*indent_number;
      indent_number := number_of_structured_types;
    IFEND;

    IF clv$translate AND (clv$command_header.command_type = clc$to_be_translated_command) THEN
      translate_create_variable (format_index, max_array_index, clv$current_array_ptr,
            clv$current_indent_column, status);
      RETURN;
    IFEND;

    IF current_token.clt_kind <> clc$lex_end_of_line THEN
      packet_size := 0;

    /set_size/
      FOR temp_index := format_index TO max_array_index DO
        current_token := clv$current_array_ptr^ [temp_index];
        IF current_token.token_size > 0 THEN
          packet_size := packet_size + clv$current_array_ptr^ [temp_index].token_size;
        IFEND;
      FOREND /set_size/;

      put_packet (packet_size, format_index, max_array_index, max_array_index, TRUE, clv$current_array_ptr,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF (clv$command_header.command_type = clc$procend_command) AND (NOT clv$last_command_blank) THEN
      put_line ('', status);
    IFEND;
    current_output_pointer := first_output_pointer;
    IF escape_encountered THEN
      line_size := 2;
    ELSE
      line_size := 0;
    IFEND;
    indent_size := 0;
    continuation_indent_size := 0;
    continuation_lines_with_indent := 0;

    WHILE current_output_pointer <> NIL DO
      indent_size := indent_size + current_output_pointer^.indent_column - 1;
      IF current_output_pointer^.indent_column = (clv$current_indent_column + clc$continuation_increment) THEN
        continuation_lines_with_indent := continuation_lines_with_indent + 1;
        continuation_indent_size := continuation_indent_size + current_output_pointer^.indent_column - 1;
      IFEND;
      line_size := line_size + current_output_pointer^.output_line_size +
            current_output_pointer^.indent_column - 1;
      current_output_pointer := current_output_pointer^.next_output_pointer;
      IF current_output_pointer <> NIL THEN {subtract for ellipses}
        line_size := line_size - continuation_indicator_size;
      IFEND;
    WHILEND;

    IF line_size > clc$max_command_line_size THEN
      IF (line_size - (continuation_lines_with_indent * (clc$continuation_increment - 1))) <=
            clc$max_command_line_size THEN
        current_output_pointer := first_output_pointer^.next_output_pointer;
        WHILE current_output_pointer <> NIL DO
          current_output_pointer^.indent_column := clv$current_indent_column + 1;
          current_output_pointer := current_output_pointer^.next_output_pointer;
        WHILEND;
      ELSEIF (line_size - indent_size + continuation_lines_with_indent) <= clc$max_command_line_size THEN
        current_output_pointer := first_output_pointer;
        current_output_pointer^.indent_column := 1;
        current_output_pointer := current_output_pointer^.next_output_pointer;
        WHILE current_output_pointer <> NIL DO
          IF current_output_pointer^.indent_column > 1 THEN

{Ensure that space exists at beginning of continuation

            current_output_pointer^.indent_column := 2;
          IFEND;
          current_output_pointer := current_output_pointer^.next_output_pointer;
        WHILEND;
      ELSE
        osp$set_status_abnormal ('CL', cle$internal_formatter_error, ' Line too long', status);
        RETURN;
      IFEND;
    IFEND;

    current_output_pointer := first_output_pointer;
    PUSH line_to_print: [clv$page_width + 5];

    WHILE current_output_pointer <> NIL DO
      IF current_output_pointer^.output_line_size > 0 THEN
        line_to_print^ := '';
        line_to_print^ (current_output_pointer^.indent_column,
              current_output_pointer^.output_line_size) := current_output_pointer^.
              output_line_ptr^ (1, current_output_pointer^.output_line_size);
        put_line (line_to_print^ (1, current_output_pointer^.output_line_size +
              current_output_pointer^.indent_column - 1), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      last_output_pointer := current_output_pointer;
      current_output_pointer := current_output_pointer^.next_output_pointer;
      IF last_output_pointer <> first_output_pointer THEN
        FREE last_output_pointer^.output_line_ptr;
        FREE last_output_pointer;
      IFEND;

    WHILEND;

    CASE clv$command_header.command_type OF
    = clc$control_statement_begin, clc$control_statement_switch, clc$utility_begin =
      clv$current_indent_column := clv$current_indent_column + clc$indent_increment;
    = clc$collect_text_command =
      IF clv$process_collect_text THEN
        clv$collecting_text := TRUE;
        clv$current_indent_column := 1 + clc$indent_increment;
      IFEND;
    ELSE
    CASEND;

  PROCEND clp$format_line;
?? TITLE := 'clp$insert_format_marker', EJECT ??

  PROCEDURE [XDCL] clp$insert_format_marker
    (    format_marker_kind: clt$format_marker_kind;
         offset: 0 .. 15);

{ PURPOSE:
{   The purpose of this procedure is to insert the specified format
{   marker "offset" tokens before the current token.
{

    VAR
      i: 0 .. 16;

    IF NOT clv$add_format_tokens THEN
      RETURN;
    IFEND;

{ move end_of-line indicator

    clv$current_array_ptr^ [clv$format_token_array_index + 2] :=
          clv$current_array_ptr^ [clv$format_token_array_index + 1];

    FOR i := 0 TO offset - 1 DO
      clv$current_array_ptr^ [clv$format_token_array_index - i + 1] :=
            clv$current_array_ptr^ [clv$format_token_array_index - i];
    FOREND;

    clv$current_array_ptr^ [clv$format_token_array_index - offset + 1].clt_kind := clc$lex_unknown;
    clv$current_array_ptr^ [clv$format_token_array_index - offset + 1].token_size := 0;
    clv$current_array_ptr^ [clv$format_token_array_index - offset + 1].format_type := format_marker_kind;

    clv$format_token_array_index := clv$format_token_array_index + 1;

  PROCEND clp$insert_format_marker;
?? TITLE := 'clp$get_statement_to_format', EJECT ??

  PROCEDURE [XDCL] clp$get_statement_to_format
    (VAR line_ptr: ^clt$command_line;
     VAR got_line: boolean;
     VAR status: ost$status);

    VAR
      command_header_pointer: ^clt$command_header,
      input_line_ptr: ^clt$command_line,
      last_input_line_pointer: ^clt$command_line,
      command_too_long: boolean,
      found_char: boolean,
      input_seq_ptr: ^SEQ ( * ),
      line_continued: boolean,
      line_size: clt$command_line_size,
      scan_index: integer,
      start_index: clt$command_line_index,
      continuation_line_ptr: ^clt$command_line,
      continuation_line_size: clt$command_line_size;

    VAR
      input_line_size: [STATIC] clt$command_line_size := 0;

    initialize_command_header (command_header_pointer);
    line_size := 0;
    command_too_long := FALSE;

  /read_block/
    BEGIN
      IF clv$input_line_index > clv$input_line_size THEN
        clv$input_line_index := 1;
        get_data_line (clv$input_line_ptr, line_size, got_line, status);
        IF NOT (status.normal AND got_line) THEN
          RETURN;
        IFEND;

        line_ptr := ^clv$input_line_ptr^ (1, line_size);
        clv$input_line_size := line_size;

        IF line_size > 2 THEN
          #SCAN (clv$non_space, line_ptr^, scan_index, found_char);
          IF found_char AND (scan_index + 1 < line_size) THEN
            IF line_ptr^ (scan_index, 2) = '"$' THEN
              process_pragmat (line_ptr^ (scan_index, line_size - scan_index + 1), status);
              IF NOT status.normal THEN
                EXIT /read_block/;
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        WHILE NOT clv$formatting_in_effect DO
          put_line (line_ptr^, status);
          clv$command_header.command_type := clc$unknown_command;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          get_data_line (clv$input_line_ptr, line_size, got_line, status);
          IF NOT (status.normal AND got_line) THEN
            RETURN;
          IFEND;

          line_ptr := ^clv$input_line_ptr^ (1, line_size);
          clv$input_line_size := line_size;
          command_header_pointer^.command_line_ptr := line_ptr;
          IF line_size > 2 THEN
            #SCAN (clv$non_space, line_ptr^, scan_index, found_char);
            IF found_char AND (scan_index + 1 < line_size) THEN
              IF line_ptr^ (scan_index, 2) = '"$' THEN
                process_pragmat (line_ptr^ (scan_index, line_size - scan_index + 1), status);
                IF NOT status.normal THEN
                  EXIT /read_block/;
                IFEND;
                IF clv$formatting_in_effect THEN
                  clv$last_command_type := clc$empty_command;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        WHILEND;

        IF (line_size >= 2) AND (line_ptr^ (line_size - 1, 2) = '..') THEN
          line_size := line_size - 2;
          WHILE (line_size > 0) AND (line_ptr^ (line_size) = '.') DO
            line_size := line_size - 1;
          WHILEND;

          clv$input_line_size := line_size;
          PUSH continuation_line_ptr: [clc$max_command_line_size];
          IF continuation_line_ptr = NIL THEN
            osp$set_status_abnormal ('CL', cle$table_overflow, 'continuation_line_ptr', status);
            RETURN;
          IFEND;

          REPEAT
            get_data_line (continuation_line_ptr, continuation_line_size, got_line, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF NOT got_line THEN
              osp$set_status_abnormal ('CL', cle$expecting_continuation_line, '', status);
              RETURN;
            IFEND;

            line_continued := (continuation_line_size >= 2) AND
                  (continuation_line_ptr^ (continuation_line_size - 1, 2) = '..');
            IF line_continued THEN
              continuation_line_size := continuation_line_size - 2;
              WHILE (continuation_line_size > 0) AND (continuation_line_ptr^ (continuation_line_size) =
                    '.') DO
                continuation_line_size := continuation_line_size - 1;
              WHILEND;
            IFEND;
            IF (clv$input_line_size + continuation_line_size) > clc$max_command_line_size THEN
              command_too_long := TRUE;
            IFEND;
            IF NOT command_too_long THEN
              clv$input_line_ptr^ (clv$input_line_size + 1, continuation_line_size) :=
                    continuation_line_ptr^ (1, continuation_line_size);
              clv$input_line_size := clv$input_line_size + continuation_line_size;
            IFEND;
          UNTIL NOT line_continued;
        IFEND;
      IFEND;

    END /read_block/;

    IF command_too_long THEN
      clv$current_line_size := 0;
      osp$set_status_abnormal ('CL', cle$continued_line_too_long, '', status);
      RETURN;
    IFEND;

    start_index := clv$input_line_index;
    clp$isolate_command (clv$input_line_ptr^ (1, clv$input_line_size), start_index, clv$input_line_index);

    line_size := clv$input_line_index - start_index;
    line_ptr := ^clv$input_line_ptr^ (start_index, line_size);
    IF clv$input_line_index <= clv$input_line_size THEN
      clv$input_line_index := clv$input_line_index + 1;
    IFEND;

    command_header_pointer^.command_line_ptr := line_ptr;
    command_header_pointer^.command_line_size := line_size;
    got_line := TRUE;

  PROCEND clp$get_statement_to_format;
?? TITLE := 'clp$f_note_unended_block', EJECT ??

  PROCEDURE [XDCL] clp$f_note_unended_block
    (    block_count: integer;
     VAR current_block: ^clt$f_block;
     VAR status: ost$status);

{ PURPOSE:
{   The purpose of this procedure is to write to the output
{   file information concerning blocks which have not been
{   properly terminated.

    VAR
      count: integer,
      error_line: string (150),
      error_line_index: 0 .. 151,
      j: integer,
      name_size: ost$name_size,
      name_size_2: ost$name_size,
      next_block: ^clt$f_block,
      str: string (10);

    error_line := ' ';
    count := block_count;
    WHILE count > 0 DO
      name_size := clp$trimmed_string_size (current_block^.kind_end_name);
      name_size_2 := clp$trimmed_string_size (current_block^.kind_name);
      STRINGREP (error_line, j, ' --ERROR-- No ', current_block^.kind_end_name (1, name_size),
            ' statement for ', current_block^.kind_name (1, name_size_2), ' statement at line ',
            current_block^.output_line_number);
      put_line (error_line (1, j), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      next_block := current_block^.previous_block;
      clp$f_pop_block_stack (current_block);
      count := count - 1;
      current_block := next_block;
      clv$error_count := clv$error_count + 1;
      IF clv$current_indent_column >= clc$indent_increment THEN
        clv$current_indent_column := clv$current_indent_column - clc$indent_increment;
      IFEND;
    WHILEND;

  PROCEND clp$f_note_unended_block;
?? TITLE := 'clp$f_output_line_number', EJECT ??

  FUNCTION [XDCL] clp$f_output_line_number: integer;

    clp$f_output_line_number := clv$output_line_number;

  FUNCEND clp$f_output_line_number;
?? TITLE := 'clp$f_process_collect_text', EJECT ??

  PROCEDURE [XDCL] clp$f_process_collect_text
    (    collect_command: string ( * <= 31);
     VAR status: ost$status);

{ PURPOSE:
{   This procedure handles the various commands that involve collecting text to
{   a file. It determines the termination string of the command (COLLECT_
{   TEMPLATE_UNTIL or UNTIL parameter) and then copies from the
{   input file to the output file until that string is found.  The pdt declarations
{   are given here for documentation purposes.

{ PDT collect_text_pdt (
{   output, o : FILE = $REQUIRED
{   until, u : STRING = '**'
{   prompt, p: string 0..30 = ''
{   substitution_mark, sm: string 1 or key none = none
{   input, i: file = $OPTIONAL
{   STATUS)

{ PDT create_status_message (
{   name, n : NAME = $REQUIRED
{   code, c : INTEGER 0 .. ffffffffff(16) = $REQUIRED
{   identifier, i : STRING 2
{   severity, s : key
{       (informative, i)
{       (warning, w)
{       (error, e)
{       (fatal, f)
{       (catastrophic, c)
{     keyend = error
{   collect_template_until, ctu: STRING = '**'
{   status)

{ PDT create_brief_help_message (
{   collect_template_until, ctu : STRING = '**'
{   status)

{ PDT create_full_help_message (
{   collect_template_until, ctu : STRING = '**'
{   status)

{ PDT create_parameter_prompt_message (
{   name, n : NAME = $REQUIRED
{   collect_template_until, ctu : STRING = '**'
{   status)

{ PDT create_parameter_assist_message (
{   name, n : NAME = $REQUIRED
{   collect_template_until, ctu : STRING = '**'
{   status)

{ PDT create_parameter_help_message (
{   name, n : NAME = $REQUIRED
{   collect_template_until, ctu : string = '**'
{  status)

{ PDT manage_remote_files (
{   location, l : NAME = $REQUIRED
{   file, f : file = $REQUIRED
{   data_declaration, dd  : KEY c8, c6, uu = uu
{   until, u : STRING = '**'
{   substitution_mark, sm : STRING 1 or key none = none
{   status)


    VAR
      array_index: clt$token_array_index,
      current_parameter_number: 0 .. 15,
      until_index: ost$string_index,
      found_character: boolean,
      got_line: boolean,
      line_ptr: ^clt$command_line,
      line_size: clt$command_line_size,
      local_status: ost$status,
      param_begin_count: ost$string_size,
      current_token: clt$format_token,
      parameter_name: ost$name,
      push_line_ptr: ^clt$command_line,
      requested_parameter_number: 0 .. 15,
      scan_index: integer,
      starting_indent_column: clt$command_line_index,
      substitution_mark_found: boolean,
      substitution_mark_parameter: 0 .. 15,
      temp_index: ost$string_index,
      temp_string: string (osc$max_string_size),
      until_value: string (osc$max_string_size);

    array_index := 1;
    current_parameter_number := 0;
    substitution_mark_parameter := 0;
    substitution_mark_found := FALSE;
    IF collect_command = 'COLLECT_TEXT' THEN
      requested_parameter_number := 2;
      substitution_mark_parameter := 4;
    ELSEIF collect_command = 'CREATE_STATUS_MESSAGE' THEN
      requested_parameter_number := 5;
    ELSEIF collect_command = 'CREATE_BRIEF_HELP_MESSAGE' THEN
      requested_parameter_number := 1;
    ELSEIF collect_command = 'CREATE_FULL_HELP_MESSAGE' THEN
      requested_parameter_number := 1;
    ELSEIF collect_command = 'CREATE_PARAMETER_PROMPT_MESSAGE' THEN
      requested_parameter_number := 2;
    ELSEIF collect_command = 'CREATE_PARAMETER_ASSIST_MESSAGE' THEN
      requested_parameter_number := 2;
    ELSEIF collect_command = 'CREATE_PARAMETER_HELP_MESSAGE' THEN
      requested_parameter_number := 2;
    ELSEIF collect_command = 'MANAGE_REMOTE_FILES' THEN
      requested_parameter_number := 4;
      substitution_mark_parameter := 5;
    ELSE
      osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'Unknown command specified.', status);
      RETURN;
    IFEND;

    current_token := clv$current_array_ptr^ [array_index];
    until_value := '**';

  /search/
    WHILE current_token.clt_kind <> clc$lex_end_of_line DO
      IF (current_token.format_type = clc$parameter_begin) THEN
        array_index := array_index + 1;
        current_token := clv$current_array_ptr^ [array_index];
        IF current_token.format_type = clc$parameter_name THEN
          #TRANSLATE (osv$lower_to_upper, current_token.string_ptr^, parameter_name);
          IF collect_command = 'COLLECT_TEXT' THEN
            IF (parameter_name = 'OUTPUT') OR (parameter_name = 'O') THEN
              current_parameter_number := 1;
            ELSEIF (parameter_name = 'UNTIL') OR (parameter_name = 'U') THEN
              current_parameter_number := 2;
            ELSEIF (parameter_name = 'PROMPT') OR (parameter_name = 'P') THEN
              current_parameter_number := 3;
            ELSEIF (parameter_name = 'SUBSTITUTION_MARK') OR (parameter_name = 'SM') THEN
              current_parameter_number := 4;
            ELSEIF (parameter_name = 'INPUT') OR (parameter_name = 'I') THEN
              current_parameter_number := 5;
            ELSEIF (parameter_name = 'STATUS') THEN
              current_parameter_number := 6;
            ELSE
              osp$set_status_abnormal ('CL', cle$unknown_parameter_name, parameter_name, status);
              RETURN;
            IFEND;
          ELSEIF collect_command = 'CREATE_STATUS_MESSAGE' THEN
            IF (parameter_name = 'NAME') OR (parameter_name = 'N') THEN
              current_parameter_number := 1;
            ELSEIF (parameter_name = 'CODE') OR (parameter_name = 'C') THEN
              current_parameter_number := 2;
            ELSEIF (parameter_name = 'IDENTIFIER') OR (parameter_name = 'I') THEN
              current_parameter_number := 3;
            ELSEIF (parameter_name = 'SEVERITY') OR (parameter_name = 'S') THEN
              current_parameter_number := 4;
            ELSEIF (parameter_name = 'COLLECT_TEMPLATE_UNTIL') OR (parameter_name = 'CTU') THEN
              current_parameter_number := 5;
            ELSEIF (parameter_name = 'STATUS') THEN
              current_parameter_number := 6;
            ELSE
              osp$set_status_abnormal ('CL', cle$unknown_parameter_name, parameter_name, status);
              RETURN;
            IFEND;
          ELSEIF (collect_command = 'CREATE_BRIEF_HELP_MESSAGE') OR (collect_command =
                'CREATE_FULL_HELP_MESSAGE') THEN
            IF (parameter_name = 'COLLECT_TEMPLATE_UNTIL') OR (parameter_name = 'CTU') THEN
              current_parameter_number := 1;
            ELSEIF (parameter_name = 'STATUS') THEN
              current_parameter_number := 2;
            ELSE
              osp$set_status_abnormal ('CL', cle$unknown_parameter_name, parameter_name, status);
              RETURN;
            IFEND;
          ELSEIF (collect_command = 'CREATE_PARAMETER_PROMPT_MESSAGE') OR (collect_command =
                'CREATE_PARAMETER_ASSIST_MESSAGE') OR (collect_command = 'CREATE_PARAMETER_HELP_MESSAGE') THEN
            IF (parameter_name = 'NAME') OR (parameter_name = 'N') THEN
              current_parameter_number := 1;
            ELSEIF (parameter_name = 'COLLECT_TEMPLATE_UNTIL') OR (parameter_name = 'CTU') THEN
              current_parameter_number := 2;
            ELSEIF (parameter_name = 'STATUS') THEN
              current_parameter_number := 3;
            ELSE
              osp$set_status_abnormal ('CL', cle$unknown_parameter_name, parameter_name, status);
              RETURN;
            IFEND;
          ELSEIF (collect_command = 'MANAGE_REMOTE_FILES') THEN
            IF (parameter_name = 'LOCATION') OR (parameter_name = 'L') THEN
              current_parameter_number := 1;
            ELSEIF (parameter_name = 'FILE') OR (parameter_name = 'F') THEN
              current_parameter_number := 2;
            ELSEIF (parameter_name = 'DATA_DECLARATION') OR (parameter_name = 'DD') THEN
              current_parameter_number := 3;
            ELSEIF (parameter_name = 'UNTIL') OR (parameter_name = 'U') THEN
              current_parameter_number := 4;
            ELSEIF (parameter_name = 'SUBSTITUTION_MARK') OR (parameter_name = 'SM') THEN
              current_parameter_number := 5;
            ELSEIF (parameter_name = 'IGNORE_REMOTE_VALIDATION') OR (parameter_name = 'IRV') THEN
              current_parameter_number := 6;
            ELSEIF (parameter_name = 'STATUS') THEN
              current_parameter_number := 7;
            ELSE
              osp$set_status_abnormal ('CL', cle$unknown_parameter_name, parameter_name, status);
              RETURN;
            IFEND;
          ELSE
            osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'Unknown command specified.',
                  status);
            RETURN;
          IFEND;
        ELSE
          current_parameter_number := current_parameter_number + 1;
          array_index := array_index - 1;
          current_token := clv$current_array_ptr^ [array_index];
        IFEND;

        IF current_parameter_number <> requested_parameter_number THEN
          param_begin_count := 1;

        /skip_param/
          WHILE current_token.clt_kind <> clc$lex_end_of_line DO
            array_index := array_index + 1;
            current_token := clv$current_array_ptr^ [array_index];
            IF current_parameter_number = substitution_mark_parameter THEN
              IF (current_token.clt_kind = clc$lex_end_of_line) AND
                   (NOT substitution_mark_found) THEN
                osp$set_status_abnormal ('CL', cle$internal_formatter_error,
                     'Cant find parameter_end', status);
                RETURN;
              IFEND;
              IF current_token.clt_kind = clc$lex_string THEN
                clp$f_set_substitution_mark (current_token.string_ptr^ (2, 1));
                substitution_mark_found := TRUE;
              IFEND;
            IFEND;
            CASE current_token.format_type OF
            = clc$parameter_begin =
              param_begin_count := param_begin_count + 1;
            = clc$parameter_end =
              param_begin_count := param_begin_count - 1;
              IF param_begin_count <= 0 THEN
                EXIT /skip_param/;
              IFEND;
            ELSE
            CASEND;
          WHILEND /skip_param/;
        IFEND;
      ELSE
        array_index := array_index + 1;
        current_token := clv$current_array_ptr^ [array_index];
        CYCLE /search/;
      IFEND;

      IF current_parameter_number = requested_parameter_number THEN
        until_index := 1;
        WHILE current_token.format_type <> clc$parameter_end DO
          array_index := array_index + 1;
          current_token := clv$current_array_ptr^ [array_index];
          IF current_token.clt_kind = clc$lex_end_of_line THEN
            osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'Cant find parameter_end', status);
            RETURN;
          IFEND;
          IF current_token.clt_kind = clc$lex_string THEN
            temp_string := current_token.string_ptr^ (2, current_token.token_size - 2);
            temp_index := 1;

          /scan_string/
            WHILE TRUE DO
              #SCAN (clv$string_delimiter, temp_string (temp_index,
                    current_token.token_size - temp_index - 1), scan_index, found_character);
              IF NOT found_character THEN
                until_value (until_index, * ) := temp_string (temp_index, * );
                until_index := until_index + scan_index - 1;
                EXIT /scan_string/;
              IFEND;
              until_value (until_index, scan_index) := temp_string (temp_index, scan_index);
              temp_index := temp_index + scan_index + 1;

{ 1 to skip over assumed double 's

              until_index := until_index + scan_index;
            WHILEND /scan_string/;
          IFEND;
        WHILEND;

        IF until_index = 1 THEN
          osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'No string value for UNTIL parameter',
                status);
          RETURN;
        IFEND;
        IF substitution_mark_found THEN
          EXIT /search/;
        IFEND;
      ELSE
        array_index := array_index + 1;
        current_token := clv$current_array_ptr^ [array_index];
      IFEND;
    WHILEND /search/;

    clv$command_header.command_type := clc$collect_text_command;
    IF clv$process_collect_text THEN
      starting_indent_column := clv$current_indent_column;
    IFEND;
    clp$format_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_statement_to_format (line_ptr, got_line, status);
    IF clv$process_collect_text THEN
      WHILE status.normal AND got_line DO
        IF line_ptr^ = until_value THEN
          clv$colt_until_value := until_value;
          clv$save_indent_column := starting_indent_column;
          clv$command_header.command_type := clc$end_colt_command;
          clp$format_line (status);
          clp$f_set_substitution_mark (' ');
          RETURN;
        ELSE
          IF (clv$last_command_type = clc$proc_declaration) AND (NOT clv$last_command_blank) THEN
            put_line ('', local_status);
            clv$last_command_type := clc$empty_command;
          IFEND;
          clp$f_process_command (clc$interpret_mode, line_ptr, status);
          IF status.normal THEN
            IF (clv$command_header.command_type <> clc$proc_declaration) AND
                  (clv$command_header.command_type <> clc$end_colt_command) AND
                  (clv$command_header.command_type <> clc$var_or_type_statement) THEN
              clp$format_line (status);
            IFEND;
          IFEND;
          clv$last_command_type := clv$command_header.command_type;
        IFEND;
        IF NOT status.normal THEN
          IF (status.condition = cle$table_overflow) OR (clv$error_count >= clc$max_error_count) OR
                (clv$file_position = amc$eoi) THEN
            RETURN;
          IFEND;
          report_status (status, clv$input_line_ptr^ (1, clv$input_line_size), local_status);
          status.normal := TRUE;
        IFEND;
        clp$get_statement_to_format (line_ptr, got_line, status);
      WHILEND;
    ELSE
      clv$collecting_text := TRUE;
      clv$command_header.command_type := clc$collect_text_command;
      PUSH push_line_ptr: [clc$max_command_line_size];
      WHILE status.normal AND got_line DO
        put_line (line_ptr^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF line_ptr^ = until_value THEN
          clv$collecting_text := FALSE;
          clp$f_set_substitution_mark (' ');
          RETURN;
        IFEND;
        get_data_line (push_line_ptr, line_size, got_line, status);
        line_ptr := ^push_line_ptr^ (1, line_size);
      WHILEND;
    IFEND;
    osp$set_status_abnormal ('CL', cle$encountered_eoi, 'Cant find colt terminator string', status);

  PROCEND clp$f_process_collect_text;
?? TITLE := 'clp$f_process_proc_header', EJECT ??

  PROCEDURE [XDCL] clp$f_process_proc_header
    (    parameters: string ( * );
     VAR status: ost$status);

{ PURPOSE:
{   The purpose of this procedure is to provide a link between
{   CLM$F_CONTROL_STATEMENTS and the processor of a PROC header
{    declaration.

    VAR
      proc_block: ^clt$f_block,
      proc_name: ost$name;


    clp$format_proc_header (output_file_id, clv$page_width, ^clv$command_header.
          command_line_ptr^ (1, clv$command_header.command_line_size), clv$translate,
          clv$current_indent_column, proc_name, clv$error_count, status);
    IF status.normal THEN
      clp$f_push_block_stack (clc$proc_block, proc_name, proc_block);
    IFEND;
    clv$command_header.command_type := clc$proc_declaration;
    clv$last_command_blank := FALSE;
    clv$current_indent_column := clv$current_indent_column + clc$indent_increment;

  PROCEND clp$f_process_proc_header;
?? TITLE := 'clp$f_process_task_or_job', EJECT ??

  PROCEDURE [XDCL] clp$f_process_task_or_job
    (    command: string ( * <= 4);
     VAR status: ost$status);

    VAR
      array_index: clt$token_array_index,
      current_parameter_number: 0 .. 25,
      param_begin_count: ost$string_size,
      current_token: clt$format_token,
      parameter_name: ost$name,
      requested_parameter_number: 0 .. 25,
      substitution_mark_specified: boolean;

    array_index := 1;
    current_parameter_number := 0;
    IF command = 'TASK' THEN
      requested_parameter_number := 4;
    ELSEIF command = 'JOB' THEN
      requested_parameter_number := 21;
    ELSE
      osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'Unknown command specified.', status);
      RETURN;
    IFEND;

    substitution_mark_specified := FALSE;
    current_token := clv$current_array_ptr^ [array_index];

{ The following search for a specified substitution mark assumes that either the
{ parameter name is explicitly specified or if specified positionally that all
{ other parameters of the command are also specified.

  /search/
    WHILE current_token.clt_kind <> clc$lex_end_of_line DO
      IF (current_token.format_type = clc$parameter_begin) THEN
        array_index := array_index + 1;
        current_token := clv$current_array_ptr^ [array_index];
        IF current_token.format_type = clc$parameter_name THEN
          #TRANSLATE (osv$lower_to_upper, current_token.string_ptr^, parameter_name);
          IF (parameter_name = 'SUBSTITUTION_MARK') OR (parameter_name = 'SM') THEN
            substitution_mark_specified := TRUE;
            EXIT /search/;
          IFEND;
        ELSE
          current_parameter_number := current_parameter_number + 1;
          array_index := array_index - 1;
          current_token := clv$current_array_ptr^ [array_index];
          IF current_parameter_number = requested_parameter_number THEN
            substitution_mark_specified := TRUE;
            EXIT /search/;
          IFEND;
        IFEND;
        param_begin_count := 1;

      /skip_param/
        WHILE current_token.clt_kind <> clc$lex_end_of_line DO
          array_index := array_index + 1;
          current_token := clv$current_array_ptr^ [array_index];
          CASE current_token.format_type OF
          = clc$parameter_begin =
            param_begin_count := param_begin_count + 1;
          = clc$parameter_end =
            param_begin_count := param_begin_count - 1;
            IF param_begin_count <= 0 THEN
              EXIT /skip_param/;
            IFEND;
          ELSE
          CASEND;
        WHILEND /skip_param/;
      IFEND;
      array_index := array_index + 1;
      current_token := clv$current_array_ptr^ [array_index];
    WHILEND;

    IF substitution_mark_specified THEN
      WHILE current_token.format_type <> clc$parameter_end DO
        array_index := array_index + 1;
        current_token := clv$current_array_ptr^ [array_index];
        IF current_token.clt_kind = clc$lex_end_of_line THEN
          osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'Cant find parameter_end', status);
          RETURN;
        IFEND;
        IF current_token.clt_kind = clc$lex_string THEN
          clp$f_set_substitution_mark (current_token.string_ptr^ (2, 1));
        IFEND;
      WHILEND;
    IFEND;

  PROCEND clp$f_process_task_or_job;
?? TITLE := 'clp$f_find_structured_types', EJECT ??

  PROCEDURE [INLINE] clp$f_find_structured_types
    (    str: string(*);
     VAR number: integer;
     VAR to_quit: boolean;
     VAR status: ost$status);

      to_quit := FALSE;
      #TRANSLATE (osv$lower_to_upper, str(1,*), str);
      IF (str = 'RECORD') OR (str = 'ANY') OR (str = 'KEY') THEN
        number := number + 1;
      ELSEIF (str = 'RECEND') OR (str = 'ANYEND') OR (str = 'KEYEND') THEN
        number := number - 1;
        to_quit := TRUE;
      IFEND;

  PROCEND clp$f_find_structured_types;
?? TITLE := 'clp$f_process_var_or_type', EJECT ??

  PROCEDURE [XDCL] clp$f_process_var_or_type
    (    definition: string ( * <= osc$max_name_size);
     VAR status: ost$status);

    CONST
      message_size = terminator_size + 10,
      terminator_size = 6 {VAREND or TYPEND} ;

    TYPE
      clt$f_var_or_type_definitions = array [1 .. 2] of clt$f_var_or_type_definition;

    TYPE
      clt$f_var_or_type_definition = record
        name: clt$name,
        terminator: string (terminator_size),
      recend;

    VAR
      current_indent_column: clt$command_line_index,
      current_string: string (100),
      found_char: boolean,
      got_line: boolean,
      index: clt$command_line_size,
      line_ptr: ^clt$command_line,
      line_size: clt$command_line_size,
      message: string (message_size),
      number_of_blanks: clt$command_line_size,
      parse: clt$parse_state,
      push_line_ptr: ^clt$command_line,
      scan_index: integer,
      start_index: clt$command_line_index,
      to_exit: boolean,
      var_block: ^clt$f_block,
      var_or_type_definition: clt$f_var_or_type_definition,
      var_or_type_definitions: [STATIC] clt$f_var_or_type_definitions :=
            [[[3, 'VAR'], 'VAREND'], [[4, 'TYPE'], 'TYPEND']];


    status.normal := TRUE;

    IF definition = var_or_type_definitions [1].name.value THEN
      var_or_type_definition := var_or_type_definitions [1];
    ELSE
      var_or_type_definition := var_or_type_definitions [2];
    IFEND;

    current_string := '';
    current_string (clv$current_indent_column, var_or_type_definition.name.size) :=
          var_or_type_definition.name.value (1, var_or_type_definition.name.size);
    put_line (current_string (1, clv$current_indent_column + var_or_type_definition.name.size - 1), status);

    IF clv$input_line_index < clv$input_line_size THEN
      start_index := clv$input_line_index;
      clp$isolate_command (clv$input_line_ptr^ (1, clv$input_line_size), start_index, clv$input_line_index);

      line_size := clv$input_line_index - start_index;
      push_line_ptr := ^clv$input_line_ptr^ (start_index, line_size);
      IF clv$input_line_index <= clv$input_line_size THEN
        clv$input_line_index := clv$input_line_index + 1;
      IFEND;
      got_line := TRUE;
    ELSE
      PUSH push_line_ptr: [clc$max_command_line_size];
      clp$get_statement_to_format (push_line_ptr, got_line, status);
      clv$command_header.command_type := clc$var_or_type_statement;
      line_size := clv$input_line_size;
    IFEND;

    indent_number := 0;
    number_of_structured_types := 0;
    to_exit := FALSE;
    WHILE status.normal AND got_line DO
      index := 1;
      number_of_blanks := 0;
      WHILE push_line_ptr^ (index) = ' ' DO
        number_of_blanks := number_of_blanks + 1;
        index := index + 1;
      WHILEND;
      current_indent_column := clv$current_indent_column + 2;
      PUSH line_ptr: [line_size - number_of_blanks + current_indent_column];
      line_ptr^ := '';
      line_ptr^ (current_indent_column, line_size - number_of_blanks) :=
            push_line_ptr^ (number_of_blanks + 1, * );
      #TRANSLATE (osv$lower_to_upper, push_line_ptr^ (number_of_blanks + 1, * ), push_line_ptr^);
      IF push_line_ptr^ (1, line_size - number_of_blanks) =
            var_or_type_definition.terminator (1, terminator_size) THEN
        line_ptr^ (clv$current_indent_column, * ) := var_or_type_definition.terminator (1, terminator_size);
        put_line (line_ptr^, status);
        RETURN;
      ELSE
        IF (line_size - number_of_blanks) > terminator_size THEN

{ Look for terminator + trailing comment.

          IF push_line_ptr^ (1, terminator_size) = var_or_type_definition.terminator (1, terminator_size)
                THEN
            #SCAN (clv$comment_delimiter, line_ptr^ (1, line_size - number_of_blanks), scan_index,
                  found_char);
            IF found_char THEN
              line_ptr^ (clv$current_indent_column, terminator_size) :=
                    var_or_type_definition.terminator (1, terminator_size);
              line_ptr^ (clv$current_indent_column + 2 + terminator_size, *) := line_ptr^ (scan_index,
                    *);
              line_ptr^ (clv$current_indent_column + terminator_size, 2) := '  ';
              put_line (line_ptr^, status);
              RETURN;
            IFEND;
          ELSE

{ Look for leading comment + terminator.

            IF push_line_ptr^ (1) = '"' THEN

{ Look for end of comment.

              #SCAN (clv$comment_delimiter, push_line_ptr^ (2, line_size - number_of_blanks - 1),
                    scan_index, found_char);
              IF found_char THEN
                index := scan_index + 1;
                WHILE index <= (line_size - number_of_blanks - terminator_size + 1) DO
                  IF push_line_ptr^ (index, terminator_size) = var_or_type_definition.terminator
                        (1, terminator_size) THEN
                    line_ptr^ (clv$current_indent_column, *) := push_line_ptr^ (1, line_size -
                          number_of_blanks);
                    put_line (line_ptr^, status);
                    RETURN;
                  IFEND;
                  index := index + 1;
                WHILEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      clp$initialize_parse_state (line_ptr, NIL, parse);
      clp$f_scan_token (clc$slu_non_space, parse);
      clp$f_find_structured_types (parse.text^(parse.unit_index,parse.unit.size),
            number_of_structured_types,to_exit,status);
      IF to_exit AND (number_of_structured_types <= 0) THEN
        REPEAT
          clp$f_scan_token (clc$slu_any, parse);
          clp$f_find_structured_types (parse.text^(parse.unit_index,parse.unit.size),
                number_of_structured_types,to_exit,status);
        UNTIL parse.unit.kind = clc$lex_end_of_line;
      IFEND;
      WHILE parse.unit.kind <> clc$lex_end_of_line DO
        CASE parse.unit.kind OF
        = clc$lex_name =
          clp$f_scan_token (clc$slu_any, parse);
          clp$f_find_structured_types (parse.text^(parse.unit_index,parse.unit.size),
                number_of_structured_types,to_exit,status);
         /lowblock/
          WHILE parse.unit.kind <> clc$lex_colon DO
            CASE parse.unit.kind OF
            = clc$lex_space =
              IF number_of_structured_types <= 0 THEN
                clp$delete_current_format_token;
              IFEND;
            ELSE
              IF (number_of_structured_types <= 0) THEN
                osp$set_status_condition (cle$expecting_after_var_name, status);
                clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
                RETURN;
              ELSEIF parse.unit.kind = clc$lex_end_of_line THEN
                EXIT /lowblock/;
              IFEND;
            CASEND;
            clp$f_scan_token (clc$slu_any, parse);
            clp$f_find_structured_types (parse.text^(parse.unit_index,parse.unit.size),
                  number_of_structured_types,to_exit,status);
          WHILEND /lowblock/ ;
          WHILE parse.unit.kind <> clc$lex_end_of_line DO
            clp$f_scan_token (clc$slu_any, parse);
            clp$f_find_structured_types (parse.text^(parse.unit_index,parse.unit.size),
                  number_of_structured_types,to_exit,status);
          WHILEND;
        ELSE
          clp$f_scan_token (clc$slu_any, parse);
          clp$f_find_structured_types (parse.text^(parse.unit_index,parse.unit.size),
                number_of_structured_types,to_exit,status);
        CASEND;
      WHILEND;
      IF status.normal THEN
        clp$format_line (status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF clv$input_line_index < clv$input_line_size THEN
        start_index := clv$input_line_index;
        clp$isolate_command (clv$input_line_ptr^ (1, clv$input_line_size), start_index, clv$input_line_index);

        line_size := clv$input_line_index - start_index;
        push_line_ptr := ^clv$input_line_ptr^ (start_index, line_size);
        IF clv$input_line_index <= clv$input_line_size THEN
          clv$input_line_index := clv$input_line_index + 1;
        IFEND;
        got_line := TRUE;
      ELSE
        clp$get_statement_to_format (push_line_ptr, got_line, status);
        clv$command_header.command_type := clc$var_or_type_statement;
        line_size := clv$input_line_size;
      IFEND;
    WHILEND;

    message := 'Cant find ';
    message (11, terminator_size) := var_or_type_definition.terminator (1, terminator_size);
    osp$set_status_abnormal ('CL', cle$encountered_eoi, message, status);

  PROCEND clp$f_process_var_or_type;
?? TITLE := 'clp$recognize_format_tokens', EJECT ??

  PROCEDURE [XDCL] clp$recognize_format_tokens
    (    action: boolean);

{ PURPOSE:
{   This purpose of this procedure is to control whether or not
{   format tokens are to be added to clv$format_token_array.

    clv$add_format_tokens := action;

  PROCEND clp$recognize_format_tokens;
?? TITLE := 'clp$f_set_command_header_type', EJECT ??

  PROCEDURE [XDCL] clp$f_set_command_header_type
    (    command_type: clt$f_command_type);

    IF command_type = clc$labeled_command THEN
      clv$command_header.labeled := TRUE;
    ELSE
      clv$command_header.command_type := command_type;
    IFEND;

  PROCEND clp$f_set_command_header_type;
?? TITLE := 'clp$f_set_tree_marker', EJECT ??

  PROCEDURE [XDCL] clp$f_set_tree_marker
    (    node_value: clt$f_node_value;
         insert_index: integer;
         eoi_encountered: boolean);

{ PURPOSE:
{    This procedure sets into the format_token_array a marker specifying a tree_begin
{    and a tree_end of the specified node type. The node itself should have already
{    been identified.
{
{ NOTES:
{    1. This procedure sets the tree begin format marker at the index of the
{       token array specified.  Since these procedure is called only by the
{       scan_term_x procedures of clp$f_scan_expression, the unit following the
{       tree end has already been read and entered into the array unless an
{       end_of_line was encountered.
{

    VAR
      array_index: clt$token_array_index,
      move_count: 0 .. 3;

    IF (NOT clv$add_format_tokens) OR (insert_index < 1) OR (insert_index > clv$format_token_array_index) THEN
      RETURN;
    IFEND;

    clv$format_token_array_index := clv$format_token_array_index + 1;

    FOR array_index := clv$format_token_array_index DOWNTO insert_index DO
      clv$current_array_ptr^ [array_index + 1] := clv$current_array_ptr^ [array_index];
    FOREND;

    clv$current_array_ptr^ [insert_index].format_type := clc$tree_begin;
    clv$current_array_ptr^ [insert_index].node_value := node_value;
    clv$current_array_ptr^ [insert_index].clt_kind := clc$lex_unknown;
    clv$current_array_ptr^ [insert_index].token_size := 0;

    IF eoi_encountered THEN
      move_count := 0;
    ELSEIF clv$current_array_ptr^ [clv$format_token_array_index].clt_kind = clc$lex_space THEN
      move_count := 1;
    ELSEIF clv$current_array_ptr^ [clv$format_token_array_index - 1].clt_kind = clc$lex_space THEN
      move_count := 2;
    ELSE
      move_count := 1;
    IFEND;

    clv$format_token_array_index := clv$format_token_array_index + 1;
    clv$current_array_ptr^ [clv$format_token_array_index + 1] :=
          clv$current_array_ptr^ [clv$format_token_array_index];
    array_index := clv$format_token_array_index;
    WHILE move_count > 0 DO
      array_index := array_index - 1;
      clv$current_array_ptr^ [array_index + 1] := clv$current_array_ptr^ [array_index];
      move_count := move_count - 1;
    WHILEND;

    clv$current_array_ptr^ [array_index].format_type := clc$tree_end;
    clv$current_array_ptr^ [array_index].node_value := node_value;
    clv$current_array_ptr^ [array_index].clt_kind := clc$lex_unknown;
    clv$current_array_ptr^ [array_index].token_size := 0;

  PROCEND clp$f_set_tree_marker;
?? TITLE := 'clp$set_format_type', EJECT ??

  PROCEDURE [XDCL] clp$set_format_type
    (    format_type: clt$format_token_type);

{ PURPOSE:
{       The purpose of this procedure is to set the format type of the last
{       format token added to the format token array.
{

    VAR
      current_token: clt$format_token,
      temp_name: ost$name;

    IF NOT clv$add_format_tokens THEN
      RETURN;
    IFEND;

    IF clv$format_token_array_index > 0 THEN
      clv$current_array_ptr^ [clv$format_token_array_index].format_type := format_type;
    IFEND;
    current_token := clv$current_array_ptr^ [clv$format_token_array_index];
    IF (format_type = clc$reserved_name) AND (current_token.clt_kind = clc$lex_name) THEN
      temp_name := current_token.string_ptr^;
      #TRANSLATE (osv$lower_to_upper, temp_name, current_token.string_ptr^);
    IFEND;

  PROCEND clp$set_format_type;
?? TITLE := 'get_data_line', EJECT ??

  PROCEDURE get_data_line
    (VAR line_ptr: ^clt$command_line;
     VAR line_size: clt$command_line_size;
     VAR got_line: boolean;
     VAR status: ost$status);

    VAR
      ignore_byte_address: amt$file_byte_address,
      size: integer,
      transfer_count: amt$transfer_count;

    status.normal := TRUE;
    got_line := FALSE;

  /get_line/
    WHILE NOT got_line DO
      amp$get_next (input_file_id, line_ptr, clc$max_command_line_size, transfer_count, ignore_byte_address,
            clv$file_position, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      size := transfer_count;
      got_line := clv$file_position <= amc$eor;
      IF NOT got_line THEN
        line_size := 0;
        RETURN;
      IFEND;
      line_size := clp$trimmed_string_size (line_ptr^ (1, size));
      IF line_size = 0 THEN
        IF clv$processing_crev THEN
          clv$saved_blank_lines := clv$saved_blank_lines + 1;
        ELSE
          put_line ('', status);
        IFEND;
        got_line := FALSE;
      ELSEIF (line_ptr^ (1) = clv$key_character) AND (NOT clv$collecting_text) THEN

{ensure processing of line if collecting_text
{back when collect_text

        IF clv$processing_crev THEN
          windup_translate_crev (clv$current_indent_column, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        put_line (line_ptr^ (1, line_size), status);
        got_line := FALSE;
      IFEND;

    WHILEND /get_line/;

  PROCEND get_data_line;
?? TITLE := 'initialize', EJECT ??

  PROCEDURE initialize
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$forsp) format_scl_procedure, format_scl_procedures, ..
{       format_scl_proc, format_scl_procs, forsclp, forsp (
{   input, i: file = $required
{   output, o: file = $required
{   page_width, pw: integer min_page_width..amc$max_page_width = 110
{   initial_indent_column, iic: integer 1..amc$max_page_width = 1
{   key_character, kc: string 1..1 = '*'
{   utility_definition_file, udf: file = $optional
{   process_collect_text, pct: boolean = false
{   translate, t: boolean = false
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 17] of clt$pdt_parameter_name,
        parameters: array [1 .. 9] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (3),
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (1),
        recend,
        type5: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
          default_value: string (3),
        recend,
        type6: record
          header: clt$type_specification_header,
        recend,
        type7: record
          header: clt$type_specification_header,
          default_value: string (5),
        recend,
        type8: record
          header: clt$type_specification_header,
          default_value: string (5),
        recend,
        type9: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 27, 14, 25, 38, 961], clc$command, 17, 9, 2, 0, 0, 0, 9, 'OSM$FORSP'],
            [['I                              ', clc$abbreviation_entry, 1],
            ['IIC                            ', clc$abbreviation_entry, 4],
            ['INITIAL_INDENT_COLUMN          ', clc$nominal_entry, 4],
            ['INPUT                          ', clc$nominal_entry, 1],
            ['KC                             ', clc$abbreviation_entry, 5],
            ['KEY_CHARACTER                  ', clc$nominal_entry, 5],
            ['O                              ', clc$abbreviation_entry, 2],
            ['OUTPUT                         ', clc$nominal_entry, 2],
            ['PAGE_WIDTH                     ', clc$nominal_entry, 3],
            ['PCT                            ', clc$abbreviation_entry, 7],
            ['PROCESS_COLLECT_TEXT           ', clc$nominal_entry, 7],
            ['PW                             ', clc$abbreviation_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 9],
            ['T                              ', clc$abbreviation_entry, 8],
            ['TRANSLATE                      ', clc$nominal_entry, 8],
            ['UDF                            ', clc$abbreviation_entry, 6],
            ['UTILITY_DEFINITION_FILE        ', clc$nominal_entry, 6]], [

{ PARAMETER 1

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 3

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 3],

{ PARAMETER 4

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 1],

{ PARAMETER 5

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 3],

{ PARAMETER 6

      [17, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 5],

{ PARAMETER 8

      [15, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 5],

{ PARAMETER 9

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type]],

{ PARAMETER 2

      [[1, 0, clc$file_type]],

{ PARAMETER 3

      [[1, 0, clc$integer_type], [min_page_width, amc$max_page_width, 10], '110'],

{ PARAMETER 4

      [[1, 0, clc$integer_type], [1, amc$max_page_width, 10], '1'],

{ PARAMETER 5

      [[1, 0, clc$string_type], [1, 1, FALSE], '''*'''],

{ PARAMETER 6

      [[1, 0, clc$file_type]],

{ PARAMETER 7

      [[1, 0, clc$boolean_type], 'false'],

{ PARAMETER 8

      [[1, 0, clc$boolean_type], 'false'],

{ PARAMETER 9

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$input = 1,
      p$output = 2,
      p$page_width = 3,
      p$initial_indent_column = 4,
      p$key_character = 5,
      p$utility_definition_file = 6,
      p$process_collect_text = 7,
      p$translate = 8,
      p$status = 9;

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

    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      default_creation_attributes: array [1 .. 2] of fst$file_cycle_attribute,
      ignore_user_attribute_size: fst$user_defined_attribute_size,
      ignore_status: ost$status,
      input_attributes: fst$cycle_attribute_values,
      validation_attributes: array [1 .. 7] of fst$file_cycle_attribute;


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

    clv$key_character := pvt [p$key_character].value^.string_value^ (1);

    clv$current_indent_column := pvt [p$initial_indent_column].value^.integer_value.value;

    IF pvt [p$utility_definition_file].specified THEN
      clp$process_utility_def_file (pvt [p$utility_definition_file].value^.file_value^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    clv$output_line_number := 1;
    clv$current_line_size := 0;
    clv$error_count := 0;
    clv$warning_count := 0;

    validation_attributes [1].selector := fsc$file_contents_and_processor;
    validation_attributes [1].file_contents := fsc$legible_scl_procedure;
    validation_attributes [1].file_processor := osc$null_name;
    validation_attributes [2].selector := fsc$file_contents_and_processor;
    validation_attributes [2].file_contents := fsc$legible_scl_include;
    validation_attributes [2].file_processor := osc$null_name;
    validation_attributes [3].selector := fsc$file_contents_and_processor;
    validation_attributes [3].file_contents := fsc$legible_scl_job;
    validation_attributes [3].file_processor := osc$null_name;
    validation_attributes [4].selector := fsc$file_contents_and_processor;
    validation_attributes [4].file_contents := fsc$legible_data;
    validation_attributes [4].file_processor := osc$null_name;
    validation_attributes [5].selector := fsc$file_contents_and_processor;
    validation_attributes [5].file_contents := amc$legible;
    validation_attributes [5].file_processor := osc$null_name;
    validation_attributes [6].selector := fsc$file_contents_and_processor;
    validation_attributes [6].file_contents := fsc$data;
    validation_attributes [6].file_processor := osc$null_name;
    validation_attributes [7].selector := fsc$file_contents_and_processor;
    validation_attributes [7].file_contents := fsc$unknown_contents;
    validation_attributes [7].file_processor := osc$null_name;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_options [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
    attachment_options [2].selector := fsc$open_share_modes;
    attachment_options [2].open_share_modes := $fst$file_access_options [fsc$read, fsc$execute];
    attachment_options [3].selector := fsc$create_file;
    attachment_options [3].create_file := FALSE;
    fsp$open_file (pvt [p$input].value^.file_value^, amc$record, ^attachment_options, NIL, NIL,
          ^validation_attributes, NIL, input_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    fsp$get_open_information (input_file_id, NIL, NIL, NIL, ^input_attributes, NIL, NIL, NIL,
          ignore_user_attribute_size, status);
    IF NOT status.normal THEN
      fsp$close_file (input_file_id, ignore_status);
      RETURN;
    IFEND;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
    attachment_options [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options [1].share_modes.value := $fst$file_access_options [];
    attachment_options [2].selector := fsc$access_and_share_modes;
    attachment_options [2].access_modes.selector := fsc$specific_access_modes;
    attachment_options [2].access_modes.value := $fst$file_access_options [fsc$append];
    attachment_options [2].share_modes.selector := fsc$specific_share_modes;
    attachment_options [2].share_modes.value := $fst$file_access_options [];
    attachment_options [3].selector := fsc$open_share_modes;
    attachment_options [3].open_share_modes := -$fst$file_access_options [];
    default_creation_attributes [1].selector := fsc$file_contents_and_processor;
    default_creation_attributes [1].file_contents := input_attributes.file_contents;
    default_creation_attributes [1].file_processor := osc$null_name;
    default_creation_attributes [2].selector := fsc$page_format;
    default_creation_attributes [2].page_format := amc$untitled_form;
    fsp$open_file (pvt [p$output].value^.file_value^, amc$record, ^attachment_options,
          ^default_creation_attributes, NIL, ^validation_attributes, NIL, output_file_id, status);
    IF NOT status.normal THEN
      fsp$close_file (input_file_id, ignore_status);
      RETURN;
    IFEND;

    clv$page_width := pvt [p$page_width].value^.integer_value.value;
    IF (clv$page_width - clv$current_indent_column + 1) < min_usable_space THEN
      osp$set_status_abnormal ('CL', cle$page_width_too_small, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, min_usable_space - 1, 10, FALSE, status);
      RETURN;
    IFEND;

    clv$process_collect_text := pvt [p$process_collect_text].value^.boolean_value.value;

    clv$translate := pvt [p$translate].value^.boolean_value.value;

  PROCEND initialize;
?? TITLE := 'initialize_command_header', EJECT ??

  PROCEDURE initialize_command_header
    (VAR command_header_pointer: ^clt$command_header);


    clv$command_header.labeled := FALSE;
    clv$command_header.command_type := clc$unknown_command;
    clv$command_header.command_line_size := 0;

    command_header_pointer := ^clv$command_header;
    clv$current_array_ptr := ^clv$format_token_array;
    clv$current_line_ptr := ^clv$format_line;
    clv$format_token_array_index := 0;
    clv$current_array_ptr^ [1].clt_kind := clc$lex_end_of_line;
    clv$current_array_ptr^ [1].token_size := 0;
    clv$current_line_size := 0;

  PROCEND initialize_command_header;
?? TITLE := 'get_string_from_array', EJECT ??

  PROCEDURE get_string_from_array
    (    begin_index: clt$token_array_index;
         end_index: clt$token_array_index;
         array_ptr: ^clt$format_token_array;
         string_ptr: ^string ( * );
     VAR status: ost$status);

    VAR
      current_string_size: clt$command_line_size,
      index: clt$token_array_index,
      token_size: clt$string_size;

    current_string_size := 0;

    FOR index := begin_index TO end_index DO
      token_size := array_ptr^ [index].token_size;
      IF token_size > 0 THEN
        IF current_string_size + token_size >= STRLENGTH (string_ptr^) THEN
          token_size := STRLENGTH (string_ptr^) - current_string_size;
        IFEND;
        string_ptr^ (current_string_size + 1, token_size) := array_ptr^ [index].string_ptr^;
        current_string_size := current_string_size + token_size;
        IF current_string_size >= STRLENGTH (string_ptr^) THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND get_string_from_array;
?? TITLE := 'process_leading_comments', EJECT ??

{ PURPOSE:
{   To process the leading comments of a line. Identation will be the
{   current indentation unless no space precede the first comment, in which
{   case the output comment(s) will start in column 1. If more than one comment
{   is encountered (spaces are ignored), the comments will abut each other
{   on output. If a comment will not fit on the current line but will fit on the
{   next line, it will be placed on the next line.

    PROCEDURE process_leading_comments
      (    array_ptr: ^clt$format_token_array;
           max_array_index: clt$token_array_index;
           current_indent: clt$command_line_index;
       VAR format_index {input, output} : clt$token_array_index;
       VAR status: ost$status);

      VAR
        comment_index: clt$command_line_index,
        remaining_size: clt$command_line_size,
        transfer_size: clt$command_line_size,
        temp_index: clt$command_line_index,
        indent_column: clt$command_line_size,
        output_ptr: ^clt$command_line,
        output_size: clt$command_line_size,
        current_token: clt$format_token;

      status.normal := TRUE;
      output_ptr := NIL;
      output_size := 0;

      current_token := array_ptr^ [format_index];
      WHILE current_token.clt_kind <> clc$lex_end_of_line DO
        CASE current_token.clt_kind OF
        = clc$lex_space =
          ;
        = clc$lex_comment, clc$lex_unterminated_comment =
          IF output_size = 0 THEN
            IF format_index = 1 THEN
              indent_column := 1;
            ELSE
              indent_column := current_indent;
            IFEND;
            output_size := indent_column - 1;
            IF output_ptr = NIL THEN
              PUSH output_ptr: [clv$page_width];
            IFEND;
            output_ptr^ := '';
          IFEND;
          IF (output_size + current_token.token_size) <= clv$page_width THEN
            output_ptr^ (output_size + 1, current_token.token_size) := current_token.string_ptr^;
            output_size := output_size + current_token.token_size;
          ELSEIF current_token.token_size + indent_column - 1 <= clv$page_width THEN

{Fits on new line

            put_line (output_ptr^ (1, output_size), status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            output_ptr^ := '';
            output_ptr^ (indent_column, current_token.token_size) := current_token.string_ptr^;
            output_size := indent_column + current_token.token_size - 1;
            put_line (output_ptr^ (1, output_size), status);
            output_size := indent_column - 1;
          ELSE {Must be broken across lines
            IF output_size >= indent_column THEN {Flush previous
              put_line (output_ptr^ (1, output_size), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
            remaining_size := current_token.token_size;
            comment_index := 1;
            output_ptr^ := '';
            output_size := indent_column - 1;
            WHILE remaining_size > 0 DO
              transfer_size := clv$page_width - output_size;
              IF transfer_size > remaining_size THEN
                transfer_size := remaining_size;
              ELSE

              /find_separator/
                FOR temp_index := comment_index + transfer_size - 1 DOWNTO comment_index DO
                  CASE current_token.string_ptr^ (temp_index) OF
                  = ' ', ',', ')', ';' =
                    EXIT /find_separator/;
                  ELSE
                    ;
                  CASEND;
                FOREND /find_separator/;
                IF temp_index - comment_index > 20 {an arbitrary value} THEN
                  transfer_size := temp_index - comment_index + 1;
                IFEND;
              IFEND;
              output_ptr^ (output_size + 1, transfer_size) := current_token.
                    string_ptr^ (comment_index, transfer_size);
              output_size := output_size + transfer_size;
              put_line (output_ptr^ (1, output_size), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              output_ptr^ := '';
              output_size := indent_column - 1;
              remaining_size := remaining_size - transfer_size;
              IF remaining_size > 0 THEN
                output_ptr^ (indent_column) := '"';
                output_size := indent_column;
                comment_index := comment_index + transfer_size;
              IFEND;
            WHILEND;
          IFEND;
        ELSE {Not space or comment
          RETURN;
        CASEND;
        format_index := format_index + 1;
        current_token := array_ptr^ [format_index];
      WHILEND;
      IF output_size >= indent_column THEN
        put_line (output_ptr^ (1, output_size), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    PROCEND process_leading_comments;
?? TITLE := 'process_pragmat', EJECT ??

  PROCEDURE process_pragmat
    (    line: string ( * );
     VAR status: ost$status);

{ PROCEDURE formatter_pragmat (
{   command, c: name
{   format, fmt, f: boolean
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 19, 17, 17, 15, 989], clc$command, 5, 2, 0, 0, 0, 0, 0, 'FORMATTER_PRAGMAT'],
            [['C                              ', clc$abbreviation_entry, 1],
            ['COMMAND                        ', clc$nominal_entry, 1],
            ['F                              ', clc$abbreviation_entry, 2],
            ['FMT                            ', clc$alias_entry, 2],
            ['FORMAT                         ', clc$nominal_entry, 2]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$boolean_type]]];

?? POP ??

    CONST
      p$command = 1,
      p$format = 2;

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

    VAR
      command_name: clt$name,
      control_statement_descriptor: ^clt$f_control_statement_desc,
      found_char: boolean,
      parameter_list_size: clt$parameter_list_size,
      scan_index: integer,
      work_area: ^clt$work_area;


    status.normal := TRUE;
    #SCAN (clv$comment_delimiter, line (3, * ), scan_index, found_char);
    IF (scan_index - 1) < 2 THEN
      RETURN;
    IFEND;

    IF work_area_segment.sequence_pointer = NIL THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, work_area_segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET work_area_segment.sequence_pointer;
    IFEND;
    work_area := work_area_segment.sequence_pointer;

    clp$evaluate_sub_parameters (line (3, * ), #SEQ (pdt), work_area, ^pvt, status);
    IF NOT status.normal THEN
      status.normal := TRUE;
      RETURN;
    IFEND;

    IF pvt [p$format].specified THEN
      clv$formatting_in_effect := pvt [p$format].value^.boolean_value.value;
    IFEND;

    IF pvt [p$command].specified THEN
      command_name.value := pvt [p$command].value^.name_value;
      command_name.size := clp$trimmed_string_size (command_name.value);
      clp$search_format_utilities (command_name, control_statement_descriptor);
      IF control_statement_descriptor <> NIL THEN

{ NOTE: The format utilities involved serve only to initialize or terminate the formattting
{    of recognized utilities and require no parameters.

        parameter_list_size := 0;
        control_statement_descriptor^.command^ (#SEQ (parameter_list_size) ^, status);
      IFEND;
    IFEND;

  PROCEND process_pragmat;
?? TITLE := 'put_line', EJECT ??

  PROCEDURE put_line
    (    line: string ( * );
     VAR status: ost$status);

    VAR
      ignore_byte_address: amt$file_byte_address;

    amp$put_next (output_file_id, ^line, STRLENGTH (line), ignore_byte_address, status);
    clv$output_line_number := clv$output_line_number + 1;
    clv$last_command_blank := line = '  ';

  PROCEND put_line;
?? TITLE := 'report_status', EJECT ??

  PROCEDURE report_status
    (    msg_status: ost$status;
         command_line_ptr: clt$command_line;
     VAR status: ost$status);

    VAR
      line_count: ost$status_message_line_count,
      line_count_ptr: ^ost$status_message_line_count,
      line_ptr: ^ost$status_message_line,
      line_size_ptr: ^ost$status_message_line_size,
      message_sequence: ost$status_message,
      mes_seq_ptr: ^ost$status_message,
      error_line: string (100),
      j: integer;

    put_line (command_line_ptr, status);
    IF status.normal THEN
      put_line (' " ^^ Problem with preceding line(s) due to -', status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF msg_status.condition = cle$internal_formatter_error THEN
      clv$warning_count := clv$warning_count + 1;
      STRINGREP (error_line, j, '" --WARNING-- ', msg_status.text.value (2, msg_status.text.size - 1));
      put_line (error_line (1, j), status);
    ELSE
      clv$error_count := clv$error_count + 1;
      osp$format_message (msg_status, osc$current_message_level, clv$page_width, message_sequence, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      mes_seq_ptr := ^message_sequence;
      RESET mes_seq_ptr;
      NEXT line_count_ptr IN mes_seq_ptr;
      FOR line_count := 1 TO line_count_ptr^ DO
        NEXT line_size_ptr IN mes_seq_ptr;
        NEXT line_ptr: [line_size_ptr^] IN mes_seq_ptr;
        put_line (line_ptr^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;

  PROCEND report_status;
?? TITLE := 'translate_function', EJECT ??

  PROCEDURE translate_function
    (    begin_index: clt$token_array_index;
         array_ptr: ^clt$format_token_array;
         translate_line_ptr: ^clt$command_line;
     VAR max_array_index: clt$token_array_index;
     VAR translate_line_size: clt$command_line_size;
     VAR status: ost$status);


    VAR
      any_value_kind: [STATIC, READ] clt$value_kind_specifier := [NIL, clc$any_value],
      string_size: clt$command_line_size,
      token: clt$format_token,
      end_index: clt$token_array_index,
      function_begin_count: clt$command_line_size,
      index: clt$token_array_index,
      input_line_ptr: ^clt$command_line,
      output_line_size: clt$command_line_size,
      name_only_translated: boolean,
      name_to_flag: ost$name,
      value: clt$value,
      save_array_ptr: ^clt$format_token_array,
      save_clv_line_ptr: ^clt$command_line,
      save_clv_line_size: clt$command_line_size,
      temp_name: ost$name,
      new_array_ptr: ^clt$format_token_array;


    status.normal := TRUE;
    PUSH input_line_ptr: [clc$max_command_line_size];
    string_size := 0;
    function_begin_count := 1;

  /find_function_end/
    FOR end_index := begin_index + 1 TO max_array_index DO
      token := array_ptr^ [end_index];
      CASE token.format_type OF
      = clc$function_begin, clc$translated_function =
        function_begin_count := function_begin_count + 1;
      = clc$function_end =
        function_begin_count := function_begin_count - 1;
        IF function_begin_count = 0 THEN
          EXIT /find_function_end/;
        IFEND;
      ELSE
        IF token.token_size > 0 THEN
          input_line_ptr^ (string_size + 1, token.token_size) := token.string_ptr^;
          string_size := string_size + token.token_size;
        IFEND;
      CASEND;
    FOREND /find_function_end/;

    IF function_begin_count > 0 THEN
      osp$set_status_abnormal ('CL', cle$internal_formatter_error, ' Cant find function_end', status);
      RETURN;
    IFEND;

    clp$translate_function (^input_line_ptr^ (1, string_size), ^translate_line_ptr^
          (translate_line_size + 1, * ), begin_index, end_index, array_ptr, max_array_index, output_line_size,
          name_only_translated, name_to_flag, status);
    IF (output_line_size = 0) OR (NOT status.normal) THEN
      RETURN;
    IFEND;

    IF name_only_translated THEN
      array_ptr^ [begin_index + 1].token_size := output_line_size;
      array_ptr^ [begin_index + 1].string_ptr := ^translate_line_ptr^
            (translate_line_size + 1, output_line_size);
      translate_line_size := translate_line_size + output_line_size;
      RETURN;
    IFEND;

    save_array_ptr := clv$current_array_ptr;
    save_clv_line_ptr := clv$current_line_ptr;
    save_clv_line_size := clv$current_line_size;
    PUSH new_array_ptr;
    clv$current_array_ptr := new_array_ptr;
    clv$format_token_array_index := 0;
    clv$current_line_ptr := translate_line_ptr;
    clv$current_line_size := translate_line_size + output_line_size;

    clp$f_scan_expression (translate_line_ptr^ (translate_line_size + 1, output_line_size), any_value_kind,
          value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF name_to_flag <> '' THEN

    /flag_translated/
      FOR index := 1 TO clv$format_token_array_index DO
        IF (new_array_ptr^ [index].format_type = clc$function_begin) AND
              (new_array_ptr^ [index + 1].clt_kind = clc$lex_name) THEN
          #TRANSLATE (osv$lower_to_upper, new_array_ptr^ [index + 1].string_ptr^, temp_name);
          IF temp_name = name_to_flag THEN
            new_array_ptr^ [index].format_type := clc$translated_function;
            EXIT /flag_translated/;
          IFEND;
        IFEND;
      FOREND /flag_translated/;
    IFEND;

    delete_from_array (begin_index, end_index, array_ptr, max_array_index);
    insert_into_array (begin_index - 1, new_array_ptr^, clv$format_token_array_index, array_ptr,
          max_array_index);

    array_ptr^ [max_array_index + 1].clt_kind := clc$lex_end_of_line;
    array_ptr^ [max_array_index + 1].token_size := 0;

    clv$current_array_ptr := save_array_ptr;
    clv$current_line_ptr := save_clv_line_ptr;
    translate_line_size := clv$current_line_size;
    clv$current_line_size := save_clv_line_size;
    clv$format_token_array_index := begin_index;

  PROCEND translate_function;
?? TITLE := 'delete_from_array', EJECT ??

  PROCEDURE delete_from_array
    (    first_index: clt$token_array_index;
         last_index: clt$token_array_index,
         array_ptr: ^array [1 .. clc$max_array_tokens] of clt$format_token;
     VAR entry_count: clt$token_array_index);

    VAR
      current_token: clt$format_token,
      get_index: 1 .. clc$max_array_tokens,
      put_index: 1 .. clc$max_array_tokens;

    get_index := last_index + 1;
    put_index := first_index;

    REPEAT
      current_token := array_ptr^ [get_index];
      array_ptr^ [put_index] := current_token;
      get_index := get_index + 1;
      put_index := put_index + 1;
    UNTIL current_token.clt_kind = clc$lex_end_of_line; {?????????
    entry_count := entry_count - (last_index - first_index + 1);

  PROCEND delete_from_array;
?? TITLE := 'insert_into_array', EJECT ??

  PROCEDURE insert_into_array
    (    insert_after_index: clt$token_array_index;
         new_array_entries: array [1 .. clc$max_array_tokens] of clt$format_token;
         new_entry_count: 1 .. clc$max_array_tokens;
         array_ptr: ^array [1 .. clc$max_array_tokens] of clt$format_token;
     VAR total_entry_count {input, output} : clt$token_array_index);

    VAR
      index: 1 .. clc$max_array_tokens;

    FOR index := 1 TO (total_entry_count - insert_after_index) DO
      array_ptr^ [total_entry_count + new_entry_count - index + 1] :=
            array_ptr^ [total_entry_count - index + 1];
    FOREND;

    FOR index := 1 TO new_entry_count DO
      array_ptr^ [insert_after_index + index] := new_array_entries [index];
    FOREND;

    total_entry_count := total_entry_count + new_entry_count;

  PROCEND insert_into_array;
?? TITLE := 'isolate_parameter', EJECT ??

  PROCEDURE isolate_parameter
    (    begin_index: clt$token_array_index;
         end_index: clt$token_array_index;
         array_ptr: ^array [1 .. clc$max_array_tokens] of clt$format_token;
         count_list_elements: boolean;
     VAR comment_index: clt$token_array_index;
     VAR comment_size: clt$command_line_size;
     VAR parameter_name: ost$name;
     VAR parameter_name_size: 0 .. osc$max_name_size;
     VAR prelude_size: clt$command_line_size;
     VAR prelude_begin: clt$token_array_index;
     VAR prelude_end: clt$token_array_index;
     VAR parameter_size: clt$command_line_size;
     VAR parameter_begin: clt$token_array_index;
     VAR parameter_end: clt$token_array_index;
     VAR postlude_size: clt$command_line_size;
     VAR postlude_begin: clt$token_array_index;
     VAR postlude_end: clt$token_array_index;
     VAR value_set_count: clt$list_size;
     VAR status: ost$status);

    VAR
      function_begin_count: 0 .. osc$max_string_size,
      index: clt$token_array_index,
      token: clt$format_token;

    status.normal := TRUE;
    comment_index := 0;
    comment_size := 0;
    parameter_name := '';
    parameter_name_size := 0;
    prelude_size := 0;
    parameter_size := 0;
    postlude_size := 0;
    value_set_count := 0;

    index := begin_index;

    IF array_ptr^ [index].format_type <> clc$parameter_begin THEN
      osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'Cant find parameter begin to isolate.',
            status);
      RETURN;
    IFEND;

    index := index + 1;
    token := array_ptr^ [index];

    IF token.format_type = clc$parameter_name THEN
      prelude_begin := index;
      parameter_name := token.string_ptr^;
      parameter_name_size := token.token_size;
      prelude_size := prelude_size + parameter_name_size;
      index := index + 1;
      token := array_ptr^ [index];
      WHILE token.clt_kind = clc$lex_space DO
        IF token.token_size > 0 THEN
          prelude_size := prelude_size + token.token_size;
        IFEND;
        index := index + 1;
        token := array_ptr^ [index];
      WHILEND;
      IF token.clt_kind <> clc$lex_equal THEN
        osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'Cant find eq_token for parameter.',
              status);
        RETURN;
      IFEND;
      prelude_size := prelude_size + token.token_size;
      index := index + 1;
      token := array_ptr^ [index];
      WHILE token.clt_kind = clc$lex_space DO
        prelude_size := prelude_size + token.token_size;
        index := index + 1;
        token := array_ptr^ [index];
      WHILEND;
    IFEND;

    IF token.clt_kind = clc$lex_left_parenthesis THEN
      IF parameter_name_size = 0 THEN
        prelude_begin := index;
      IFEND;
      prelude_size := prelude_size + token.token_size;
      index := index + 1;
      token := array_ptr^ [index];
      WHILE token.clt_kind = clc$lex_space DO
        prelude_size := prelude_size + token.token_size;
        index := index + 1;
        token := array_ptr^ [index];
      WHILEND;
    IFEND;

    IF prelude_size > 0 THEN
      prelude_end := index - 1;
    ELSE
      prelude_begin := index;
      prelude_end := index;
    IFEND;

    parameter_begin := index;
    function_begin_count := 0;

  /isolate/
    WHILE index <= end_index DO
      token := array_ptr^ [index];
      CASE token.format_type OF
      = clc$parameter_end =
        IF function_begin_count = 0 THEN
          EXIT /isolate/;
        IFEND;
      = clc$function_begin, clc$translated_function =
        function_begin_count := function_begin_count + 1;
      = clc$function_end =
        function_begin_count := function_begin_count - 1;
      = clc$value_begin =
        IF count_list_elements AND (function_begin_count <= 0) THEN
          value_set_count := value_set_count + 1;
        IFEND;
      = clc$value_set_begin =
        IF NOT count_list_elements THEN
          value_set_count := value_set_count + 1;
        IFEND;
      ELSE
        IF token.clt_kind = clc$lex_end_of_line THEN
          osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'Cant find end of parameter.', status);
          RETURN;
        IFEND;
        IF (token.clt_kind = clc$lex_right_parenthesis) AND
              (array_ptr^ [index + 1].format_type = clc$parameter_end) AND (function_begin_count = 0) THEN
          index := index - 1;
          EXIT /isolate/;
        IFEND;
        IF token.token_size > 0 THEN
          IF (token.clt_kind = clc$lex_comment) OR (token.clt_kind = clc$lex_unterminated_comment) THEN
            comment_index := index;
            comment_size := token.token_size;
          ELSE
            parameter_size := parameter_size + token.token_size;
          IFEND;
        IFEND;
      CASEND;
      index := index + 1;
    WHILEND /isolate/;

    parameter_end := index;
    IF (index + 1 >= end_index) OR (array_ptr^ [index + 1].clt_kind = clc$lex_end_of_line) THEN
      postlude_begin := index;
      postlude_end := index;
      RETURN;
    IFEND;
    index := index + 1;
    postlude_begin := index;
    token := array_ptr^ [index];

    IF token.clt_kind = clc$lex_right_parenthesis THEN
      postlude_size := postlude_size + token.token_size;
      index := index + 1;
      token := array_ptr^ [index];
      IF token.format_type = clc$parameter_end THEN
        index := index + 1;
        token := array_ptr^ [index];
      IFEND;
    IFEND;

    WHILE (token.clt_kind = clc$lex_space) OR (token.clt_kind = clc$lex_comma) DO
      postlude_size := postlude_size + token.token_size;
      index := index + 1;
      token := array_ptr^ [index];
    WHILEND;

    IF postlude_size > 0 THEN
      postlude_end := index - 1;
    ELSE
      postlude_end := index;
    IFEND;

  PROCEND isolate_parameter;
?? TITLE := 'translate_create_variable', EJECT ??

  PROCEDURE translate_create_variable
    (    begin_index: clt$token_array_index;
         end_index: clt$token_array_index;
         array_ptr: ^array [1 .. clc$max_array_tokens] of clt$format_token;
         external_indent_column: amt$page_width;
     VAR status: ost$status);

    TYPE
      params = record
        name: ost$name,
        number: 1 .. clc$max_parameters,
      recend;

    CONST
      parameter_name_count = 12;

    VAR
      parameter_names: [STATIC, READ, oss$job_paged_literal] array [1 .. parameter_name_count] of params := [
            {} ['names', 1], ['name', 1], ['n', 1],
            {} ['kind', 2], ['k', 2],
            {} ['dimension', 3], ['d', 3],
            {} ['value', 4], ['v', 4],
            {} ['scope', 5], ['s', 5],
            {} ['status', 6]];

    VAR
      bound_ptr: ^ost$string,
      comment_index: clt$token_array_index,
      comment_size: clt$command_line_size,
      comment_string: ^clt$string_value,
      continued_value_string: ^clt$string_value,
      current_string: string (100), {???? what if indent is LARGE???
      ellipsis_found: boolean,
      indent_size: clt$string_size,
      index: clt$token_array_index,
      j: integer,
      kind_name: ost$name,
      line: ost$string,
      lower_bound: ost$string,
      name: ost$name,
      names_begin_index: clt$token_array_index,
      names_end_index: clt$token_array_index,
      name_index: 1 .. parameter_name_count,
      name_indent_column: amt$page_width,
      name_set_count: clt$list_size,
      name_size: 0 .. osc$max_string_size,
      name_specified: boolean,
      parameter_begin: clt$token_array_index,
      parameter_end: clt$token_array_index,
      parameter_size: clt$command_line_size,
      parameter: ^clt$string_value,
      parameter_name: ost$name,
      parameter_name_size: 0 .. osc$max_name_size,
      parameter_number: 1 .. clc$max_parameters,
      postlude_size: clt$command_line_size,
      postlude: ost$string,
      postlude_begin: clt$token_array_index,
      postlude_end: clt$token_array_index,
      prelude_size: clt$command_line_size,
      prelude: ost$string,
      prelude_begin: clt$token_array_index,
      prelude_end: clt$token_array_index,
      previous_token: clt$format_token,
      scope_name: ost$name,
      start: 0 .. osc$max_string_size,
      string_end: 0 .. osc$max_string_size,
      string_qualifier: ost$string,
      temp_index: clt$token_array_index,
      temp_name: ost$name,
      temp_string: string (osc$max_string_size),
      token: clt$format_token,
      upper_bound: ost$string,
      value_set_count: clt$list_size,
      value_size: clt$string_size,
      value_string: ^clt$string_value;

    status.normal := TRUE;

    IF (clv$command_header.command_type <> clc$to_be_translated_command) AND clv$processing_crev THEN
      windup_translate_crev (external_indent_column, status);
      RETURN;
    IFEND;

    name_set_count := 0;
    kind_name := '';
    string_qualifier.size := 0;
    lower_bound.size := 0;
    upper_bound.size := 0;
    value_size := 0;
    scope_name := '';

    index := begin_index;
    parameter_number := 1;

  /find_parameters/
    WHILE index <= end_index DO
      token := array_ptr^ [index];
      IF token.clt_kind = clc$lex_end_of_line THEN
        EXIT /find_parameters/;
      IFEND;

      WHILE (token.format_type <> clc$parameter_begin) AND (index < end_index) DO
        index := index + 1;
        token := array_ptr^ [index];
      WHILEND;

      IF token.format_type <> clc$parameter_begin THEN
        osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'Cant find parameter_begin.', status);
        RETURN;
      IFEND;

      isolate_parameter (index, end_index, array_ptr, TRUE, comment_index, comment_size, parameter_name,
            parameter_name_size, prelude_size, prelude_begin, prelude_end, parameter_size, parameter_begin,
            parameter_end, postlude_size, postlude_begin, postlude_end, value_set_count, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF parameter_size = 0 THEN
        parameter_number := parameter_number + 1;
        index := postlude_end + 1;
        CYCLE /find_parameters/;
      IFEND;

      PUSH parameter: [parameter_size];
      name_specified := parameter_name_size > 0;
      get_string_from_array (parameter_begin, parameter_end, array_ptr, parameter, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF parameter_name_size > 0 THEN

      /search_for_name/
        FOR name_index := 1 TO parameter_name_count DO
          IF parameter_names [name_index].name = parameter_name THEN
            EXIT /search_for_name/;
          IFEND;
        FOREND /search_for_name/;

        IF parameter_names [name_index].name <> parameter_name THEN
          osp$set_status_abnormal ('CL', cle$unknown_parameter_name, parameter_name (1, parameter_name_size),
                status);
          RETURN;
        IFEND;

        parameter_number := parameter_names [name_index].number;
      ELSE

      /search_for_number/
        FOR name_index := 1 TO parameter_name_count DO
          IF parameter_names [name_index].number = parameter_number THEN
            parameter_name := parameter_names [name_index].name;
            parameter_name_size := clp$trimmed_string_size (parameter_name);
            EXIT /search_for_number/;
          IFEND;
        FOREND /search_for_number/;
      IFEND;

      CASE parameter_number OF
      = 1 = {name
        IF name_set_count > 0 THEN
          osp$set_status_abnormal ('CL', cle$doubly_defined_parameter,
                parameter_name (1, parameter_name_size), status);
          RETURN;
        IFEND;

        names_begin_index := parameter_begin;
        names_end_index := parameter_end;
        name_set_count := value_set_count;
        IF name_set_count = 0 THEN
          name_set_count := 1;
        IFEND;

      = 2 = {kind
        IF kind_name <> '' THEN
          osp$set_status_abnormal ('CL', cle$doubly_defined_parameter,
                parameter_name (1, parameter_name_size), status);
          RETURN;
        IFEND;

        CASE value_set_count OF
        = 1 =
          get_string_from_array (parameter_begin, parameter_end, array_ptr, ^kind_name, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          kind_name := parameter^;
          IF (kind_name <> 'integer') AND (kind_name <> 'boolean') AND (kind_name <> 'string') AND
                (kind_name <> 'status') THEN
            osp$set_status_abnormal ('CL', cle$expecting_var_kind_name, parameter^, status);
            RETURN;
          IFEND;
        = 2 =
          index := parameter_begin + 2;
          IF (array_ptr^ [index].clt_kind = clc$lex_name) AND (array_ptr^ [index].string_ptr^ = 'string') THEN
            kind_name := 'string';
          ELSE
            osp$set_status_abnormal ('CL', cle$only_qualify_string_var, '', status);
            RETURN;
          IFEND;

        /find_qualifier_begin/
          FOR temp_index := parameter_begin + 2 TO parameter_end DO
            token := array_ptr^ [temp_index];
            IF token.format_type = clc$value_begin THEN
              EXIT /find_qualifier_begin/;
            IFEND;
          FOREND /find_qualifier_begin/;

          IF token.format_type <> clc$value_begin THEN
            osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'Cant find string qualifier.',
                  status);
            RETURN;
          IFEND;

          string_qualifier.size := 0;
          string_qualifier.value := '';

        /build_qualifier/
          FOR index := temp_index + 1 TO parameter_end DO
            token := array_ptr^ [index];
            IF token.format_type = clc$value_end THEN
              EXIT /build_qualifier/;
            IFEND;
            IF token.token_size > 0 THEN
              string_qualifier.value (string_qualifier.size + 1, token.token_size) := token.string_ptr^;
              string_qualifier.size := string_qualifier.size + token.token_size;
            IFEND;
          FOREND /build_qualifier/;
        ELSE
          osp$set_status_abnormal ('CL', cle$too_few_or_many_list_elems, parameter^, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, '0', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, '2', status);
          RETURN;
        CASEND;

      = 3 = {dimension
        IF lower_bound.size <> 0 THEN
          osp$set_status_abnormal ('CL', cle$doubly_defined_parameter,
                parameter_name (1, parameter_name_size), status);
          RETURN;
        IFEND;
        IF value_size > 0 THEN
          IF clv$processing_crev THEN {Windup
            windup_translate_crev (external_indent_column, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
          put_line (clv$input_line_ptr^ (1, clv$input_line_size), status);
          RETURN;
        IFEND;

        bound_ptr := ^lower_bound;
        ellipsis_found := FALSE;
        previous_token.clt_kind := clc$lex_unknown;
        index := parameter_begin;

        WHILE index <= parameter_end DO
          token := array_ptr^ [index];
          IF NOT ellipsis_found THEN
            IF token.clt_kind = clc$lex_ellipsis THEN
              ellipsis_found := TRUE;
              IF previous_token.clt_kind = clc$lex_space THEN
                bound_ptr^.size := bound_ptr^.size - previous_token.token_size;
              IFEND;
              bound_ptr := ^upper_bound;
              index := index + 1;
              IF index <= parameter_end THEN
                token := array_ptr^ [index];
                IF token.clt_kind = clc$lex_space THEN
                  index := index + 1;
                  IF index <= parameter_end THEN
                    token := array_ptr^ [index];
                  IFEND;
                IFEND;
              IFEND;
              IF index > parameter_end THEN
                osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'Cant process dimension value.',
                      status);
                RETURN;
              IFEND;
            ELSE
              previous_token := token;
            IFEND;
          IFEND;

          IF token.token_size > 0 THEN
            bound_ptr^.value (bound_ptr^.size + 1, token.token_size) := token.string_ptr^;
            bound_ptr^.size := bound_ptr^.size + token.token_size;
          IFEND;
          index := index + 1;
        WHILEND;
      = 4 = {value
        IF value_size > 0 THEN
          osp$set_status_abnormal ('CL', cle$doubly_defined_parameter,
                parameter_name (1, parameter_name_size), status);
          RETURN;
        IFEND;

        IF lower_bound.size <> 0 THEN
          IF clv$processing_crev THEN {Windup
            windup_translate_crev (external_indent_column, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
          put_line (clv$input_line_ptr^ (1, clv$input_line_size), status);
          RETURN;
        IFEND;

        value_string := parameter;
        value_size := parameter_size;

      = 5 = {scope
        IF (value_set_count > 1) THEN
          osp$set_status_abnormal ('CL', cle$too_few_or_many_list_elems,
                parameter_name (1, parameter_name_size), status);
          osp$append_status_parameter (osc$status_parameter_delimiter, '0', status);
          RETURN;
        IFEND;
        IF scope_name <> '' THEN
          osp$set_status_abnormal ('CL', cle$doubly_defined_parameter,
                parameter_name (1, parameter_name_size), status);
          RETURN;
        IFEND;

        temp_name := parameter^;
        IF (temp_name = 'xdcl') OR (temp_name = 'xref') OR (temp_name = 'job') OR (temp_name = 'local') THEN
          #TRANSLATE (osv$lower_to_upper, temp_name, scope_name);
        ELSE
          scope_name := 'UTILITY';
        IFEND;
      = 6 = {status
        IF clv$processing_crev THEN {Windup
          windup_translate_crev (external_indent_column, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        put_line (clv$input_line_ptr^ (1, clv$input_line_size), status);
        RETURN;
      CASEND;
      parameter_number := parameter_number + 1;
      index := postlude_end + 1;
    WHILEND /find_parameters/;

    IF name_set_count = 0 THEN
      osp$set_status_abnormal ('CL', cle$required_parameter_omitted, 'NAMES', status);
      RETURN;
    IFEND;

    IF clv$command_header.command_type = clc$to_be_translated_command THEN
      IF clv$processing_crev THEN
        WHILE clv$saved_blank_lines > 0 DO
          put_line ('', status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clv$saved_blank_lines := clv$saved_blank_lines - 1;
        WHILEND;
      ELSE
        clv$processing_crev := TRUE;
        clv$saved_blank_lines := 0;
        current_string := '';
        current_string (external_indent_column, 3) := 'VAR';
        put_line (current_string (1, clv$current_indent_column + 2), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    index := 1;
    process_leading_comments (clv$current_array_ptr, clv$format_token_array_index, clv$current_indent_column,
          index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    name_indent_column := external_indent_column + 2;
    index := names_begin_index - 1;

  /process_names/
    WHILE name_set_count > 0 DO
      name := '';
      start := 0;
      string_end := 0;

    /find_name/
      WHILE index < names_end_index DO
        index := index + 1;
        token := array_ptr^ [index];

{      ((token.clt_kind = clc$lex_name) OR (token.clt_kind = clc$lex_left_parenthesis))

        IF (token.format_type = clc$unassigned) THEN
          IF (token.clt_kind = clc$lex_comma) AND (array_ptr^ [index - 1].format_type = clc$value_end) THEN
            CYCLE /find_name/;
          IFEND;

{         name := token.string_ptr^;

          j := clp$trimmed_string_size (token.string_ptr^);
          temp_string (start + 1, string_end + j) := token.string_ptr^;
          start := start + j;
          string_end := start;
          IF array_ptr^ [index + 1].format_type = clc$value_end THEN
            EXIT /find_name/;
          IFEND;
        IFEND;
      WHILEND /find_name/;
      IF temp_string = '' THEN
        EXIT /process_names/;
      IFEND;

{   name_size := clp$trimmed_string_size (name);

      name_size := string_end;
      line.value := '';
      line.size := name_indent_column - 1;
      line.value (name_indent_column, name_size) := temp_string (1, name_size);
      line.size := line.size + name_size;
      line.value (line.size + 1) := ':';
      line.size := line.size + 1;
      IF scope_name <> '' THEN
        line.value (line.size + 1, 2) := ' (';
        line.size := line.size + 2;
        name_size := clp$trimmed_string_size (scope_name);
        line.value (line.size + 1, name_size) := scope_name (1, name_size);
        line.size := line.size + name_size;
        line.value (line.size + 1) := ')';
        line.size := line.size + 1;
      IFEND;

      IF lower_bound.size <> 0 THEN
        IF upper_bound.size = 0 THEN
          upper_bound := lower_bound;
          lower_bound.value := '1';
          lower_bound.size := 1;
        IFEND;
        STRINGREP (temp_string, j, ' array ', lower_bound.value (1, lower_bound.size), ' .. ',
              upper_bound.value (1, upper_bound.size), ' of');
        line.value (line.size + 1, j) := temp_string (1, j);
        line.size := line.size + j;
      IFEND;

      IF kind_name = '' THEN
        kind_name := 'integer'
      IFEND;
      name_size := clp$trimmed_string_size (kind_name);
      line.value (line.size + 2, name_size) := kind_name (1, name_size);
      line.size := line.size + name_size + 1;

      IF string_qualifier.size > 0 THEN
        STRINGREP (temp_string, j, ' 0 .. ', string_qualifier.value (1, string_qualifier.size));
        line.value (line.size + 1, j) := temp_string (1, j);
        line.size := line.size + j;
      IFEND;

      IF value_size > 0 THEN
        line.value (line.size + 1, 3) := ' = ';
        line.size := line.size + 3;
        IF comment_size > 0 THEN
          continued_value_string := value_string;
          PUSH value_string: [value_size + comment_size + 1];
          value_string^ := '';
          value_string^ (1, value_size) := continued_value_string^;
          PUSH comment_string: [comment_size];
          get_string_from_array (comment_index, comment_index+1, array_ptr, comment_string, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          value_string^ (value_size + 2, comment_size) := comment_string^;
          value_size := value_size + comment_size + 1;
        IFEND;
        IF line.size + value_size > clv$page_width THEN
          put_line (line.value (1, line.size), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          indent_size := name_indent_column - 1 + clc$continuation_increment;
          PUSH continued_value_string: [indent_size + value_size];
          continued_value_string^ := '';
          continued_value_string^ (indent_size + 1, value_size) := value_string^;
          put_line (continued_value_string^, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          name_set_count := name_set_count - 1;
          CYCLE /process_names/;
        IFEND;
        line.value (line.size + 1, value_size) := value_string^;
        line.size := line.size + value_size;
      ELSEIF comment_size > 0 THEN
        PUSH comment_string: [comment_size];
        get_string_from_array (comment_index, comment_index+1, array_ptr, comment_string, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        line.value (line.size + 2, comment_size) := comment_string^;
        line.size := line.size + comment_size + 1;
      IFEND;

      put_line (line.value (1, line.size), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      name_set_count := name_set_count - 1;

    WHILEND /process_names/;

  PROCEND translate_create_variable;
?? TITLE := 'windup_translate_crev', EJECT ??

  PROCEDURE [INLINE] windup_translate_crev
    (    external_indent_column: amt$page_width;
     VAR status: ost$status);

    VAR
      current_string: string (100);

    clv$processing_crev := FALSE;
    current_string := '';
    current_string (external_indent_column, 6) := 'VAREND';
    put_line (current_string (1, external_indent_column + 5), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    WHILE clv$saved_blank_lines > 0 DO
      put_line ('', status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clv$saved_blank_lines := clv$saved_blank_lines - 1;
    WHILEND;

  PROCEND windup_translate_crev;
MODEND clm$format_scl_proc;
*DECK DECK=CLM$FORMAT_UTILITY_HANDLERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Formatter : Command Utility Handlers' ??
MODULE clm$format_utility_handlers;

{
{ PURPOSE:
{   The purpose of this module is to supply the SCL formatter
{   with the procedures, etc. needed to process command utilities
{   in a manner similar to SCL structure blocks.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_control_statement
*copyc cle$ecc_scl_formatter
*copyc cle$file_never_opened
*copyc clt$command_line
*copyc clt$f_control_statement_desc
*copyc clt$name
*copyc clt$parameter_list
*copyc ost$status
?? POP ??
*copyc amp$get_next
*copyc clp$evaluate_sub_parameters
*copyc clp$f_find_current_block
*copyc clp$f_note_unended_block
*copyc clp$f_pop_block_stack
*copyc clp$f_push_block_stack
*copyc clp$f_scan_parameter_list
*copyc clp$f_set_command_header_type
*copyc clp$get_work_area
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal

?? EJECT ??

  CONST
    clc$max_utility_count = 500;

  TYPE
    clt$utility_set_range = 1 .. clc$max_utility_count;

  TYPE
    clt$utility_set = set of clt$utility_set_range;

  TYPE
    utility_begin_record = record
      name: ost$name,
      utility_set: clt$utility_set,
    recend;

  VAR
    clv$current_begin_utility_index: 0 .. clc$max_utility_count,
    clv$current_end_index: 0 .. clc$max_utility_count;

{  WARNING:  If the number of utility begin or end commands changes.  The
{  following variable values and the REP clauses at the end of
{  clv$utility_begin_names and clv$utility_end_names need to be changed
{  accordingly.

  VAR
    clv$utility_begin_count: 1 .. clc$max_utility_count := 224,
    clv$utility_end_count: 1 .. clc$max_utility_count := 82;

{  WARNING:  If modifying the next 2 tables, see the warning above.

  VAR
    clv$utility_end_names: [STATIC] array [1 .. clc$max_utility_count] of ost$name := [
          {} 'QUIT                           ',
          {} 'QUI                            ',
          {} 'END                            ',
          {} 'DELETE_INTERSTATE_CONNECTION   ',
          {} 'DELIC                          ',
          {} 'END_MESSAGE_MODULE             ',
          {} 'ENDMM                          ',
          {} 'END_APPLICATION_MENU           ',
          {} 'ENDAM                          ',
          {} 'END_DEFINE_SERVER              ',
          {} 'ENDDS                          ',
          {} 'END_DEFINE_CLIENT              ',
          {} 'ENDDC                          ',
          {} 'END_ADMINISTER_VALIDATIONS     ',
          {} 'ENDAV                          ',
          {} 'END_CHANGE_USER                ',
          {} 'END_CREATE_USER                ',
          {} 'ENDCU                          ',
          {} 'END_CHANGE_ACCOUNT             ',
          {} 'END_CREATE_ACCOUNT             ',
          {} 'ENDCA                          ',
          {} 'END_CHANGE_ACCOUNT_MEMBER      ',
          {} 'END_CREATE_ACCOUNT_MEMBER      ',
          {} 'ENDCAM                         ',
          {} 'END_CHANGE_PROJECT             ',
          {} 'END_CREATE_PROJECT             ',
          {} 'ENDCP                          ',
          {} 'END_CHANGE_PROJECT_MEMBER      ',
          {} 'END_CREATE_PROJECT_MEMBER      ',
          {} 'ENDCPM                         ',
          {} 'END_MANAGE_USER_FIELDS         ',
          {} 'ENDMUF                         ',
          {} 'END_MANAGE_ACCOUNT_FIELDS      ',
          {} 'ENDMAF                         ',
          {} 'END_MANAGE_ACCT_MEMBER_FIELDS  ',
          {} 'ENDMAMF                        ',
          {} 'END_MANAGE_PROJECT_FIELDS      ',
          {} 'ENDMPF                         ',
          {} 'END_MANAGE_PROJ_MEMBER_FIELDS  ',
          {} 'ENDMPMF                        ',
          {} 'END_SYSTEM_OPERATOR_UTILITY    ',
          {} 'ENDSOU                         ',
          {} 'END_FORM_MODULE                ',
          {} 'ENDFM                          ',
          {} 'END_MANAGE_QUEUE_FILE          ',
          {} 'END_MANAGE_QUEUE_FILES         ',
          {} 'ENDMQF                         ',
          {} 'END_ADMINISTER_SECURITY_AUDIT  ',
          {} 'ENDASA                         ',
          {} 'Q                              ',
          {} 'END_MANAGE_EXCEPTION_POLICIES  ',
          {} 'BYE                            ',
          {} 'END_ADMINISTER_MAIL            ',
          {} 'END_EMAIL                      ',
          {} 'ENDE                           ',
          {} 'END_CHANGE_DISTRIBUTION_LIST   ',
          {} 'ENDCDL                         ',
          {} 'END_CHANGE_MAILBOX             ',
          {} 'ENDCM                          ',
          {} 'END_CREATE_DISTRIBUTION_LIST   ',
          {} 'END_CREATE_MAILBOX             ',
          {} 'END_FILTER_MAIL                ',
          {} 'END_FORWARD_LETTER             ',
          {} 'ENDFL                          ',
          {} 'END_MANAGE_LETTER_PARTS        ',
          {} 'ENDMLP                         ',
          {} 'END_WRITE_LETTER               ',
          {} 'ENDWL                          ',
          {} 'END_WRITE_REPLY                ',
          {} 'ENDWR                          ',
          {} 'END_GENERATE_ADDRESS_UPDATES   ',
          {} 'ENDGAU                         ',
          {} 'END_GENERATE_REMOTE_UPDATES    ',
          {} 'ENDGRU                         ',
          {} 'END_MANAGE_MAIL_DIRECTORY      ',
          {} 'ENDMMD                         ',
          {} 'END_MANAGE_MAIL_QUEUES         ',
          {} 'ENDMMQ                         ',
          {} 'END_UPDATE_DISTRIBUTION_LIST   ',
          {} 'ENDUDL                         ',
          {} 'END_UPDATE_MAILBOX             ',
          {} 'ENDUM                          ',
          {} REP (clc$max_utility_count - 82) of '                               '];

  VAR
    clv$utility_begin_names: [STATIC] array [1 .. clc$max_utility_count] of utility_begin_record := [
          {} ['CREATE_OBJECT_LIBRARY          ', [1, 2]],
          {} ['CREOL                          ', [1, 2]],
          {} ['OCU                            ', [1, 2]],
          {} ['EDIF                           ', [1, 2, 3]],
          {} ['EDIT_FILE                      ', [1, 2, 3]],
          {} ['EDID                           ', [1, 2, 3]],
          {} ['EDIT_DECK                      ', [1, 2, 3]],
          {} ['SCU                            ', [1, 2, 3]],
          {} ['SOUCU                          ', [1, 2, 3]],
          {} ['SOURCE_CODE_UTILITY            ', [1, 2, 3]],
          {} ['ANALYZE_DUMP                   ', [1, 2]],
          {} ['ANAD                           ', [1, 2]],
          {} ['DISPLAY_BINARY_LOG             ', [1, 2]],
          {} ['DISBL                          ', [1, 2]],
          {} ['MEASURE_PROGRAM_EXECUTION      ', [1, 2]],
          {} ['MEAPE                          ', [1, 2]],
          {} ['CREATE_INTERSTATE_CONNECTION   ', [1, 2, 4, 5]],
          {} ['CREIC                          ', [1, 2, 4, 5]],
          {} ['LINK_VIRTUAL_ENVIRONMENT       ', [1, 2]],
          {} ['LINVE                          ', [1, 2]],
          {} ['BUILD_REAL_MEMORY              ', [1, 2]],
          {} ['BUIRM                          ', [1, 2]],
          {} ['BACKUP_PERMANENT_FILE          ', [1, 2]],
          {} ['BACKUP_PERMANENT_FILES         ', [1, 2]],
          {} ['BACPF                          ', [1, 2]],
          {} ['RESTORE_PERMANENT_FILE         ', [1, 2]],
          {} ['RESTORE_PERMANENT_FILES        ', [1, 2]],
          {} ['RESPF                          ', [1, 2]],
          {} ['CREATE_MESSAGE_MODULE          ', [1, 2, 6, 7]],
          {} ['CREMM                          ', [1, 2, 6, 7]],
          {} ['CREATE_APPLICATION_MENU        ', [1, 2, 8, 9]],
          {} ['CREAM                          ', [1, 2, 8, 9]],
          {} ['NETWORK_OPERATOR_UTILITY       ', [1, 2]],
          {} ['NETOU                          ', [1, 2]],
          {} ['MANAGE_NETWORK_APPLICATION     ', [1, 2]],
          {} ['MANAGE_NETWORK_APPLICATIONS    ', [1, 2]],
          {} ['MANNA                          ', [1, 2]],
          {} ['DEFINE_SERVER                  ', [1, 2, 10, 11]],
          {} ['DEFS                           ', [1, 2, 10, 11]],
          {} ['DEFINE_CLIENT                  ', [1, 2, 12, 13]],
          {} ['DEFC                           ', [1, 2, 12, 13]],
          {} ['MAIL                           ', [1, 2, 3, 54, 55]],
          {} ['MAI                            ', [1, 2, 3, 54, 55]],
          {} ['PHYSICAL_CONFIGURATION_UTILITY ', [1, 2, 3]],
          {} ['PHYCU                          ', [1, 2, 3]],
          {} ['PCU                            ', [1, 2, 3]],
          {} ['LOGICAL_CONFIGURATION_UTILITY  ', [1, 2, 3]],
          {} ['LOGCU                          ', [1, 2, 3]],
          {} ['LCU                            ', [1, 2, 3]],
          {} ['EDIT_PHYSICAL_CONFIGURATION    ', [1, 2, 3]],
          {} ['EDIPC                          ', [1, 2, 3]],
          {} ['ADMINISTER_VALIDATIONS         ', [1, 2, 14, 15]],
          {} ['ADMINISTER_VALIDATION          ', [1, 2, 14, 15]],
          {} ['ADMV                           ', [1, 2, 14, 15]],
          {} ['CHANGE_USER                    ', [1, 2, 16, 18]],
          {} ['CHAU                           ', [1, 2, 16, 18]],
          {} ['CREATE_USER                    ', [1, 2, 17, 18]],
          {} ['CREU                           ', [1, 2, 17, 18]],
          {} ['CHANGE_ACCOUNT                 ', [1, 2, 19, 21]],
          {} ['CHAA                           ', [1, 2, 19, 21]],
          {} ['CREATE_ACCOUNT                 ', [1, 2, 20, 21]],
          {} ['CREA                           ', [1, 2, 20, 21]],
          {} ['CHANGE_ACCOUNT_MEMBER          ', [1, 2, 22, 24]],
          {} ['CHAAM                          ', [1, 2, 22, 24]],
          {} ['CREATE_ACCOUNT_MEMBER          ', [1, 2, 23, 24]],
          {} ['CREAM                          ', [1, 2, 23, 24]],
          {} ['CHANGE_PROJECT                 ', [1, 2, 25, 27]],
          {} ['CHAP                           ', [1, 2, 25, 27]],
          {} ['CREATE_PROJECT                 ', [1, 2, 26, 27]],
          {} ['CREP                           ', [1, 2, 26, 27]],
          {} ['CHANGE_PROJECT_MEMBER          ', [1, 2, 28, 30]],
          {} ['CHAPM                          ', [1, 2, 28, 30]],
          {} ['CREATE_PROJECT_MEMBER          ', [1, 2, 29, 30]],
          {} ['CREPM                          ', [1, 2, 29, 30]],
          {} ['MANAGE_USER_FIELDS             ', [1, 2, 31, 32]],
          {} ['MANUF                          ', [1, 2, 31, 32]],
          {} ['MANAGE_ACCOUNT_FIELDS          ', [1, 2, 33, 34]],
          {} ['MANAF                          ', [1, 2, 33, 34]],
          {} ['MANAGE_ACCOUNT_MEMBER_FIELDS   ', [1, 2, 35, 36]],
          {} ['MANAMF                         ', [1, 2, 35, 36]],
          {} ['MANAGE_PROJECT_FIELDS          ', [1, 2, 37, 38]],
          {} ['MANPF                          ', [1, 2, 37, 38]],
          {} ['MANAGE_PROJECT_MEMBER_FIELDS   ', [1, 2, 39, 40]],
          {} ['MANPMF                         ', [1, 2, 39, 40]],
          {} ['MANAGE_ACTIVE_SCHEDULING       ', [1, 2]],
          {} ['MANAS                          ', [1, 2]],
          {} ['ADMINISTER_SCHEDULING          ', [1, 2]],
          {} ['ADMS                           ', [1, 2]],
          {} ['ADMINISTER_JOB_CLASS           ', [1, 2]],
          {} ['ADMJC                          ', [1, 2]],
          {} ['ADMINISTER_CONTROLS            ', [1, 2]],
          {} ['ADMC                           ', [1, 2]],
          {} ['ADMINISTER_APPLICATION         ', [1, 2]],
          {} ['ADMA                           ', [1, 2]],
          {} ['ADMINISTER_SERVICE_CLASS       ', [1, 2]],
          {} ['ADMSC                          ', [1, 2]],
          {} ['ADMINISTER_OUTPUT_CLASS        ', [1, 2]],
          {} ['ADMOC                          ', [1, 2]],
          {} ['MANAGE_JOB                     ', [1, 2]],
          {} ['MANAGE_JOBS                    ', [1, 2]],
          {} ['MANJ                           ', [1, 2]],
          {} ['MANAGE_OUTPUT                  ', [1, 2]],
          {} ['MANO                           ', [1, 2]],
          {} ['MANAGE_FILE_SERVER             ', [1, 2]],
          {} ['MANFS                          ', [1, 2]],
          {} ['SYSTEM_OPERATOR_UTILITY        ', [1, 2, 41, 42]],
          {} ['SYSOU                          ', [1, 2, 41, 42]],
          {} ['SOU                            ', [1, 2, 41, 42]],
          {} ['CREATE_FORM_MODULE             ', [1, 2, 43, 44]],
          {} ['CREFM                          ', [1, 2, 43, 44]],
          {} ['ANALYZE_BINARY_LOG             ', [1, 2]],
          {} ['ANABL                          ', [1, 2]],
          {} ['MANAGE_PERIODIC_STATISTICS     ', [1, 2]],
          {} ['MANPS                          ', [1, 2]],
          {} ['MANAGE_QUEUE_FILE              ', [1, 2, 45, 46, 47]],
          {} ['MANAGE_QUEUE_FILES             ', [1, 2, 45, 46, 47]],
          {} ['MANQF                          ', [1, 2, 45, 46, 47]],
          {} ['ADMINISTER_MAIL                ', [1, 2, 3, 9, 53]],
          {} ['ADMM                           ', [1, 2, 3, 9, 53]],
          {} ['ADMINISTER_SECURITY_AUDIT      ', [1, 2, 48, 49]],
          {} ['ADMSA                          ', [1, 2, 48, 49]],
          {} ['ANALYZE_OBJECT_LIBRARY         ', [1, 2]],
          {} ['ANAOL                          ', [1, 2]],
          {} ['ANALYZE_SYSTEM                 ', [1, 2]],
          {} ['ANAS                           ', [1, 2]],
          {} ['ARCHIVE_PERMANENT_FILE         ', [1, 2]],
          {} ['ARCHIVE_PERMANENT_FILES        ', [1, 2]],
          {} ['ARCPF                          ', [1, 2]],
          {} ['BUILD_DIALOG_PROCESSOR         ', [1, 2]],
          {} ['BUIDP                          ', [1, 2]],
          {} ['CHANGE_DISTRIBUTION_LIST       ', [1, 2, 3, 56, 57]],
          {} ['CHADL                          ', [1, 2, 3, 56, 57]],
          {} ['CHANGE_MAILBOX                 ', [1, 2, 3, 58, 59]],
          {} ['CHAM                           ', [1, 2, 3, 58, 59]],
          {} ['CREATE_BINARY_FORMATTED_FILE   ', [1, 2]],
          {} ['CREBFF                         ', [1, 2]],
          {} ['CREATE_CLIENT_FTP_CONNECTION   ', [1, 2, 50, 52]],
          {} ['CRECFC                         ', [1, 2, 50, 52]],
          {} ['FTP                            ', [1, 2, 50, 52]],
          {} ['CREATE_CLIENT_TFTP_CONNECTION  ', [1, 2, 50]],
          {} ['CRECTC                         ', [1, 2, 50]],
          {} ['TFTP                           ', [1, 2, 50]],
          {} ['CREATE_DISTRIBUTION_LIST       ', [1, 2, 3, 57, 60]],
          {} ['CREDL                          ', [1, 2, 3, 57, 60]],
          {} ['CREATE_MAILBOX                 ', [1, 2, 3, 59, 61]],
          {} ['CREM                           ', [1, 2, 3, 59, 61]],
          {} ['CREATE_SUBPRODUCT_CORRECTION   ', [1, 2]],
          {} ['DISPLAY_STATION                ', [1, 2, 3]],
          {} ['DISS                           ', [1, 2, 3]],
          {} ['EMAIL                          ', [1, 2, 3, 54, 55]],
          {} ['EMA                            ', [1, 2, 3, 54, 55]],
          {} ['ENTER_FILE_MANAGER             ', [1, 2]],
          {} ['ENTFM                          ', [1, 2]],
          {} ['ENTER_FTAM_UTILITY             ', [1, 2, 50, 52]],
          {} ['ENTFU                          ', [1, 2, 50, 52]],
          {} ['FTAM                           ', [1, 2, 50, 52]],
          {} ['EXECUTE_INSTALLER_PROCEDURE    ', [1, 2]],
          {} ['FILE_REPAIR_UTILITY            ', [1, 2]],
          {} ['FILTER_MAIL                    ', [1, 2, 3, 44, 62]],
          {} ['FILM                           ', [1, 2, 3, 44, 62]],
          {} ['FORWARD_LETTER                 ', [1, 2, 3, 63, 64]],
          {} ['FORL                           ', [1, 2, 3, 63, 64]],
          {} ['GENERATE_ADDRESS_UPDATES       ', [1, 2, 3, 71, 72]],
          {} ['GENAU                          ', [1, 2, 3, 71, 72]],
          {} ['GENERATE_ARCHIVE_REPORT        ', [1, 2]],
          {} ['GENAR                          ', [1, 2]],
          {} ['GENERATE_REMOTE_UPDATES        ', [1, 2, 3, 73, 74]],
          {} ['GENRU                          ', [1, 2, 3, 73, 74]],
          {} ['INSTALL_SOFTWARE               ', [1, 2]],
          {} ['MAINTAIN_DEADSTART_SOFTWARE    ', [1, 2]],
          {} ['MAIDS                          ', [1, 2]],
          {} ['MANAGE_ARCHIVE_ACTIVITY        ', [1, 2, 50]],
          {} ['MANAA                          ', [1, 2, 50]],
          {} ['MANAGE_ARCHIVE_IMAGES          ', [1, 2, 50]],
          {} ['MANAI                          ', [1, 2, 50]],
          {} ['MANAGE_CARTRIDGE_STORAGE       ', [1, 2]],
          {} ['MANCS                          ', [1, 2]],
          {} ['MANAGE_DEADSTART_FILES         ', [1, 2]],
          {} ['MANDF                          ', [1, 2]],
          {} ['MANAGE_EXCEPTION_POLICIES      ', [1, 2, 51]],
          {} ['MANEP                          ', [1, 2, 51]],
          {} ['MANAGE_FIELD_CHANGES           ', [1, 2]],
          {} ['MANAGE_FORM                    ', [1, 2]],
          {} ['MANAGE_FORMS                   ', [1, 2]],
          {} ['MANF                           ', [1, 2]],
          {} ['MANAGE_LETTER_PARTS            ', [1, 2, 3, 65, 66]],
          {} ['MANLP                          ', [1, 2, 3, 65, 66]],
          {} ['MANAGE_MAIL_DIRECTORY          ', [1, 2, 3, 75, 76]],
          {} ['MANMD                          ', [1, 2, 3, 75, 76]],
          {} ['MANAGE_MAIL_QUEUES             ', [1, 2, 3, 77, 78]],
          {} ['MANMQ                          ', [1, 2, 3, 77, 78]],
          {} ['MANAGE_MEMORY                  ', [1, 2]],
          {} ['MANM                           ', [1, 2]],
          {} ['MANAGE_REMOTE_OUTPUT           ', [1, 2]],
          {} ['MANRO                          ', [1, 2]],
          {} ['MANAGE_RHFAM_NETWORK           ', [1, 2]],
          {} ['MANRN                          ', [1, 2]],
          {} ['MANAGE_STORE_FORWARD_NETWORK   ', [1]],
          {} ['MANSFN                         ', [1]],
          {} ['NETWORK_PERFORMANCE_ANALYZER   ', [1, 2]],
          {} ['NPA                            ', [1, 2]],
          {} ['OPERATE_STATION                ', [1, 2, 3]],
          {} ['OPES                           ', [1, 2, 3]],
          {} ['PACKAGE_CORRECTIONS            ', [1, 2]],
          {} ['PRODUCT_REFERENCE_UTILITY      ', [1, 2]],
          {} ['PRODUCT_REFERENCES_UTILITY     ', [1, 2]],
          {} ['PRORU                          ', [1, 2]],
          {} ['RELEASE_MASS_STORAGE           ', [1, 2]],
          {} ['RELMS                          ', [1, 2]],
          {} ['SYSTEM_TEST_UTILITY            ', [1, 2]],
          {} ['SYSTU                          ', [1, 2]],
          {} ['UPDATE_DISTRIBUTION_LIST       ', [1, 2, 3, 79, 80]],
          {} ['UPDDL                          ', [1, 2, 3, 79, 80]],
          {} ['UPDATE_MAILBOX                 ', [1, 2, 3, 81, 82]],
          {} ['UPDM                           ', [1, 2, 3, 81, 82]],
          {} ['USE_NTF_UTILITY                ', [1, 2]],
          {} ['USE_NTF_UTILITIES              ', [1, 2]],
          {} ['USENU                          ', [1, 2]],
          {} ['VIRTUAL_ENVIRO_DISPLAY_UTILITY ', [1, 2]],
          {} ['VEDU                           ', [1, 2]],
          {} ['WRITE_LETTER                   ', [1, 2, 3, 67, 68]],
          {} ['WRIL                           ', [1, 2, 3, 67, 68]],
          {} ['WRITE_REPLY                    ', [1, 2, 3, 69, 70]],
          {} ['WRIR                           ', [1, 2, 3, 69, 70]],
          {} REP (clc$max_utility_count - 224) of  *];

  VAR
    end_control_statement: [STATIC, READ] clt$f_control_statement_desc :=
          [FALSE, clc$control_command, ^process_end_utility],
    begin_control_statement: [STATIC, READ] clt$f_control_statement_desc :=
          [FALSE, clc$control_command, ^process_begin_utility];

?? TITLE := 'clp$search_format_utilities', EJECT ??

  PROCEDURE [XDCL] clp$search_format_utilities
    (    name: clt$name;
     VAR control_statement_descriptor: ^clt$f_control_statement_desc);

    FOR clv$current_end_index := 1 TO clv$utility_end_count DO
      IF name.value (1, name.size) = clv$utility_end_names [clv$current_end_index] THEN
        control_statement_descriptor := ^end_control_statement;
        RETURN;
      IFEND;
    FOREND;

    clv$current_end_index := 0;

    FOR clv$current_begin_utility_index := 1 TO clv$utility_begin_count DO
      IF name.value (1, name.size) = clv$utility_begin_names [clv$current_begin_utility_index].name THEN
        control_statement_descriptor := ^begin_control_statement;
        RETURN;
      IFEND;
    FOREND;

    clv$current_begin_utility_index := 0;
    control_statement_descriptor := NIL;

  PROCEND clp$search_format_utilities;
?? TITLE := 'process_begin_utility', EJECT ??

  PROCEDURE process_begin_utility
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      utility_block: ^clt$f_block;

    clp$f_set_command_header_type (clc$utility_begin);

    clp$f_push_block_stack (clc$utility_block, osc$null_name, utility_block);
    utility_block^.kind_name := clv$utility_begin_names [clv$current_begin_utility_index].name;

    clp$f_scan_parameter_list (parameter_list, status);

  PROCEND process_begin_utility;
?? TITLE := 'process_end_utility', EJECT ??

  PROCEDURE process_end_utility
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      begin_index: 1 .. clc$max_utility_count,
      block_count: integer,
      block_exists: boolean,
      temp_block: ^clt$f_block,
      utility_block: ^clt$f_block;

    clp$f_find_current_block (utility_block);
    temp_block := utility_block;
    block_count := 0;
    block_exists := FALSE;

  /find_block/
    WHILE temp_block <> NIL DO
      IF temp_block^.kind = clc$utility_block THEN
        FOR begin_index := 1 TO clv$utility_begin_count DO
          IF temp_block^.kind_name = clv$utility_begin_names [begin_index].name THEN
            IF clv$current_end_index IN clv$utility_begin_names [begin_index].utility_set THEN
              block_exists := TRUE;
              EXIT /find_block/;
            IFEND;
          IFEND;
        FOREND;
      IFEND;
      block_count := block_count + 1;
      temp_block := temp_block^.previous_block;
    WHILEND /find_block/;

    IF block_exists THEN
      IF block_count > 0 THEN
        clp$f_note_unended_block (block_count, utility_block, status);
      IFEND;
    ELSE
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt,
            clv$utility_end_names [clv$current_end_index], status);
    IFEND;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$f_pop_block_stack (utility_block);

    clp$f_set_command_header_type (clc$utility_end);

    IF status.normal THEN
      clp$f_scan_parameter_list (parameter_list, status);
    IFEND;

  PROCEND process_end_utility;
?? TITLE := 'clp$process_utility_def_file', EJECT ??

  PROCEDURE [XDCL] clp$process_utility_def_file
    (    file_name: fst$file_reference;
     VAR status: ost$status);

{ PROCEDURE utility_definition (
{   names, name, n: list of data_name = $required
{   terminators, terminator, t: list of data_name = (quit, qui)
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 6] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
          default_value: string (11),
        recend,
      recend := [[1, [87, 10, 19, 17, 38, 7, 243], clc$command, 6, 2, 1, 0, 0, 0, 0, 'UTILITY_DEFINITION'],
            [['N                              ', clc$abbreviation_entry, 1],
            ['NAME                           ', clc$alias_entry, 1],
            ['NAMES                          ', clc$nominal_entry, 1],
            ['T                              ', clc$abbreviation_entry, 2],
            ['TERMINATOR                     ', clc$alias_entry, 2],
            ['TERMINATORS                    ', clc$nominal_entry, 2]], [

{ PARAMETER 1

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 19, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 19, clc$optional_default_parameter, 0, 11]],

{ PARAMETER 1

      [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE], [[1, 0, clc$data_name_type]]],

{ PARAMETER 2

      [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE], [[1, 0, clc$data_name_type]], '(quit, qui)']];

?? POP ??

    CONST
      p$names = 1,
      p$terminators = 2;

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

    VAR
      current_node: ^clt$data_value,
      end_name_index: 1 .. clc$max_utility_count,
      file_attachment: array [1 .. 3] of fst$attachment_option,
      file_id: amt$file_identifier,
      file_position: amt$file_position,
      ignore_byte_address: amt$file_byte_address,
      local_status: ost$status,
      line_ptr: ^clt$command_line,
      original_work_area: ^clt$work_area,
      terminator_name: ost$name,
      terminator_index: 0 .. clc$max_utility_count,
      transfer_count: amt$transfer_count,
      utility_begin_entry: utility_begin_record,
      utility_name: ost$name,
      utility_name_index: 1 .. clc$max_utility_count,
      work_area: ^^clt$work_area;


    status.normal := TRUE;

    file_attachment [1].selector := fsc$access_and_share_modes;
    file_attachment [1].access_modes.selector := fsc$specific_access_modes;
    file_attachment [1].access_modes.value := $fst$file_access_options [fsc$read];
    file_attachment [1].share_modes.selector := fsc$specific_share_modes;
    file_attachment [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
    file_attachment [2].selector := fsc$open_share_modes;
    file_attachment [2].open_share_modes := $fst$file_access_options [fsc$read, fsc$execute];
    file_attachment [3].selector := fsc$create_file;
    file_attachment [3].create_file := FALSE;

    fsp$open_file (file_name, amc$record, ^file_attachment, NIL, NIL, NIL, NIL, file_id, status);
    IF NOT status.normal THEN
      IF status.condition = ame$new_file_requires_append THEN
        osp$set_status_abnormal ('CL', cle$file_never_opened, file_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'FORMAT_SCL_PROC', status);
      IFEND;
      RETURN;
    IFEND;

    clp$get_work_area (#RING (^work_area), work_area, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    original_work_area := work_area^;

  /read_file/
    WHILE TRUE DO
      NEXT line_ptr: [clc$max_command_line_size] IN work_area^;

      amp$get_next (file_id, line_ptr, clc$max_command_line_size, transfer_count, ignore_byte_address,
            file_position, status);
      IF NOT status.normal THEN
        EXIT /read_file/;
      IFEND;
      IF (file_position <> amc$eor) OR (transfer_count = 0) THEN
        EXIT /read_file/;
      IFEND;

      work_area^ := original_work_area;
      NEXT line_ptr: [transfer_count] IN work_area^;

      clp$evaluate_sub_parameters (line_ptr^ (1, transfer_count), #SEQ (pdt), work_area^, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /read_file/;
      IFEND;

      utility_begin_entry.utility_set := $clt$utility_set [];
      current_node := pvt [p$terminators].value;

    /read_terminator_names/
      WHILE current_node <> NIL DO
        terminator_name := current_node^.element_value^.data_name_value;
        terminator_index := 0;

      /check_end_name/
        FOR end_name_index := 1 TO clv$utility_end_count DO
          IF terminator_name = clv$utility_end_names [end_name_index] THEN
            terminator_index := end_name_index;
            EXIT /check_end_name/
          IFEND;
        FOREND /check_end_name/;

        IF terminator_index = 0 THEN
          IF clv$utility_end_count = clc$max_utility_count THEN
            osp$set_status_abnormal ('CL', cle$too_many_names, 'TERMINATOR', status);
            EXIT /read_file/;
          IFEND;
          clv$utility_end_count := clv$utility_end_count + 1;
          terminator_index := clv$utility_end_count;
          clv$utility_end_names [clv$utility_end_count] := terminator_name;
        IFEND;

        utility_begin_entry.utility_set := utility_begin_entry.utility_set +
              $clt$utility_set [terminator_index];

        current_node := current_node^.link;
      WHILEND /read_terminator_names/;

      current_node := pvt [p$names].value;

    /read_utility_names/
      WHILE current_node <> NIL DO
        utility_name := current_node^.element_value^.data_name_value;

        IF utility_name = 'END' THEN
          EXIT /read_file/;
        IFEND;

        FOR utility_name_index := 1 TO clv$utility_begin_count DO
          IF clv$utility_begin_names [utility_name_index].name = utility_name THEN
            osp$set_status_abnormal ('CL', cle$duplicate_utility_name, utility_name, status);
            EXIT /read_file/;
          IFEND;
        FOREND;

        IF clv$utility_begin_count = clc$max_utility_count THEN
          osp$set_status_abnormal ('CL', cle$too_many_names, 'NAME', status);
          EXIT /read_file/;
        IFEND;

        utility_begin_entry.name := utility_name;
        clv$utility_begin_count := clv$utility_begin_count + 1;

        clv$utility_begin_names [clv$utility_begin_count] := utility_begin_entry;

        current_node := current_node^.link;
      WHILEND /read_utility_names/;

      work_area^ := original_work_area;
    WHILEND /read_file/;

    work_area^ := original_work_area;

    fsp$close_file (file_id, local_status);
    IF (NOT local_status.normal) AND status.normal THEN
      status := local_status;
    IFEND;

    IF status.normal THEN
      FOR utility_name_index := 1 TO clv$utility_begin_count DO
        utility_name := clv$utility_begin_names [utility_name_index].name;
        FOR end_name_index := 1 TO clv$utility_end_count DO
          IF clv$utility_end_names [end_name_index] = utility_name THEN
            osp$set_status_abnormal ('CL', cle$utility_same_as_end, utility_name, status);
            RETURN;
          IFEND;
        FOREND;
      FOREND;
    IFEND;

  PROCEND clp$process_utility_def_file;

MODEND clm$format_utility_handlers;
*DECK DECK=CLM$FORMAT_VALUE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Format String' ??
MODULE clm$format_value;

{ PURPOSE:
{   This module contains procedures to build strings suitable for display from
{   clt$data_value-s and a format string.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$max_list_size
*copyc cle$work_area_overflow
*copyc clt$data_representation
*copyc clt$work_area
*copyc clt$string_value
*copyc oss$job_paged_literal
*copyc ost$message_template
*copyc ost$message_template_index
*copyc osc$min_status_message_line
*copyc ost$status
*copyc oss$job_paged_literal
?? POP ??
*copyc clp$convert_data_to_string
*copyc clp$convert_integer_to_string
*copyc clp$data_representation_text
*copyc clp$evaluate_parameters
*copyc clp$evaluate_unsigned_decimal
*copyc clp$make_value
*copyc clp$make_list_value
*copyc clp$trimmed_string_size
*copyc i#current_sequence_position
*copyc osp$set_status_condition

*copyc osv$upper_to_lower
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    value_reference_kind = (no_reference, relative_reference, direct_reference);

  TYPE
    state = record
      first_value_p: ^clt$data_value,
      last_value_index: clt$list_size,
      last_value_p: ^clt$data_value,
      parameters_exhausted: boolean,
      reference_kind: value_reference_kind,
      repeating: boolean,
      token_p: ^clt$format_token,
    recend;

  TYPE
    clt$format_representation = SEQ ( * );

  TYPE
    clt$justification = (clc$j_left, clc$j_center, clc$j_right),
    clt$format_directive = (clc$fd_text, clc$fd_soft_eol, clc$fd_tab, clc$fd_hard_eol, clc$fd_put_source_data,
          clc$fd_put_element_data, clc$fd_put_label, clc$fd_put_spaces, clc$fd_repeat, clc$fd_expand_item,
          clc$fd_group),
    clt$case_conversion = (clc$cc_upper_case, clc$cc_initial_caps, clc$cc_lower_case),
    clt$format_token_reference = REL (clt$format_representation) ^clt$format_token,
    clt$string_value_reference = REL (clt$format_representation) ^clt$string_value,
    clt$format_token = record
      link: clt$format_token_reference,
      case directive: clt$format_directive of
      = clc$fd_text =
        text_p: clt$string_value_reference,
      = clc$fd_soft_eol, clc$fd_hard_eol, clc$fd_tab, clc$fd_put_spaces =
        count: clt$string_size,
        fill_character: char,
      = clc$fd_put_source_data, clc$fd_put_element_data, clc$fd_put_label =
        index: clt$list_size,
        word_fill: char,
        next_value: boolean,
        conversion: clt$case_conversion,
        justification: clt$justification,
        width: clt$string_size,
      = clc$fd_repeat, clc$fd_expand_item =
        sub_format: clt$format_token_reference,

{     = clc$fd_expand_item =
{       sub_format: clt$format_token_reference,

        item: clt$list_size,
        item_specified: boolean,
      = clc$fd_group =
      casend,
    recend;

  VAR
    default_template: [STATIC, READ, oss$job_paged_literal] string (19) := '+S';

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] clp$build_format_representation', EJECT ??
*copyc clh$build_format_representation

  PROCEDURE [XDCL, #GATE] clp$build_format_representation
    (    format_string: ^clt$string_value;
     VAR work_area: ^clt$work_area;
     VAR format_representation: ^clt$format_representation;
     VAR status: ost$status);

    VAR
      field_width: clt$string_size,
      fill_character: char,
      first_token: clt$format_token,
      justification: clt$justification,
      stack_p: ^array [1 .. * ] of ^clt$format_token,
      template: ^ost$message_template,
      template_index: ost$message_template_index,
      text_end_index: clt$string_size,
      text_start_index: clt$string_size,
      token_p: ^clt$format_token,
      top: 0 .. clc$max_string_size;

?? NEWTITLE := 'finish_representation', EJECT ??

{ PURPOSE:
{   Update format_representation to reflect the work done.

    PROCEDURE finish_representation;

      VAR
        final_position: integer,
        token_p: ^clt$format_token;

      final_position := i#current_sequence_position (work_area);
      IF first_token.link <> NIL THEN
        token_p := #PTR (first_token.link, format_representation^);
        RESET work_area TO token_p;
        NEXT format_representation: [[REP final_position - i#current_sequence_position (work_area) OF
              cell]] IN work_area;
        RESET format_representation;
      ELSE
        format_representation := NIL;
      IFEND;
    PROCEND finish_representation;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_count', EJECT ??

{ PURPOSE:
{   Scan for a possible count following the last directive and return its
{   value.

    PROCEDURE [INLINE] get_count
      (VAR count_given: boolean;
       VAR count: integer);

      VAR
        integer_size: 0 .. clc$max_list_size;


      count := 0;
      integer_size := 0;
      template_index := template_index + 2;

      WHILE ((template_index + integer_size) <= STRLENGTH (template^)) AND
            ('0' <= template^ (template_index + integer_size)) AND
            (template^ (template_index + integer_size) <= '9') DO
        integer_size := integer_size + 1;
      WHILEND;

      count_given := integer_size > 0;
      IF count_given THEN
        clp$evaluate_unsigned_decimal (template^ (template_index, integer_size), count, status);

{ status intentionally ignored

        status.normal := TRUE;
        template_index := template_index + integer_size;
      IFEND;

    PROCEND get_count;
?? OLDTITLE ??
?? NEWTITLE := 'get_parameter', EJECT ??

{ PURPOSE:
{   Get the parameter options for parameter number and case conversion.

    PROCEDURE get_parameter
      (    directive: clt$format_directive;
           fill_char: char;
           field_width: clt$string_size;
           justification: clt$justification);

      VAR
        case_conversion: clt$case_conversion,
        count: integer,
        count_given: boolean;

      case_conversion := clc$cc_lower_case;
      IF template_index + 2 <= STRLENGTH (template^) THEN
        CASE template^ (template_index + 2) OF
        = 'L', 'l' =
          template_index := template_index + 1;
        = 'U', 'u' =
          case_conversion := clc$cc_upper_case;
          template_index := template_index + 1;
        = 'I', 'i' =
          case_conversion := clc$cc_initial_caps;
          template_index := template_index + 1;
        ELSE
        CASEND;
        get_count (count_given, count);

      ELSE
        count := 0;
        count_given := FALSE;
        template_index := template_index + 2;
      IFEND;

      put_token (directive);
      token_p^.word_fill := fill_char;
      token_p^.width := field_width;
      token_p^.justification := justification;
      token_p^.conversion := case_conversion;
      token_p^.index := count;
      token_p^.next_value := NOT count_given;

    PROCEND get_parameter;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] pop_item', EJECT ??

{ PURPOSE:
{   Pop the repeat or expand directive off the stack.

    PROCEDURE [INLINE] pop_item;

      IF top > 0 THEN
        token_p := stack_p^ [top];
        top := top - 1;
        token_p^.sub_format := token_p^.link;
        token_p^.link := NIL;
      IFEND;

    PROCEND pop_item;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] push_item', EJECT ??

{ PURPOSE:
{   Push the specified directive on the stack.

    PROCEDURE [INLINE] push_item
      (    directive: clt$format_directive);

      put_token (directive);
      top := top + 1;
      stack_p^ [top] := token_p;

    PROCEND push_item;
?? OLDTITLE ??
?? NEWTITLE := 'put_token', EJECT ??

{ PURPOSE:
{   Add one more directive to the sequence.

    PROCEDURE put_token
      (    directive: clt$format_directive);

      VAR
        local_token_p: ^clt$format_token,
        string_p: ^clt$string_value,
        text_size: clt$string_size;

      IF text_end_index > text_start_index THEN
        NEXT local_token_p IN work_area;
        IF local_token_p = NIL THEN
          osp$set_status_condition (cle$work_area_overflow, status);
          EXIT clp$build_format_representation;
        IFEND;
        text_size := (text_end_index - text_start_index);
        NEXT string_p: [text_size] IN work_area;
        IF string_p = NIL THEN
          osp$set_status_condition (cle$work_area_overflow, status);
          EXIT clp$build_format_representation;
        IFEND;
        string_p^ := template^ (text_start_index, text_size);
        token_p^.link := #REL (local_token_p, format_representation^);
        token_p := local_token_p;
        token_p^.directive := clc$fd_text;
        token_p^.link := NIL;
        token_p^.text_p := #REL (string_p, format_representation^);
      IFEND;

      text_start_index := template_index;

      IF directive <> clc$fd_text THEN
        NEXT local_token_p IN work_area;
        IF local_token_p = NIL THEN
          osp$set_status_condition (cle$work_area_overflow, status);
          EXIT clp$build_format_representation;
        IFEND;
        token_p^.link := #REL (local_token_p, format_representation^);
        token_p := local_token_p;
        token_p^.directive := directive;
        token_p^.link := NIL;
      IFEND;

    PROCEND put_token;
?? OLDTITLE ??
?? EJECT ??

    VAR
      count: integer,
      count_given: boolean,
      current_character: char,
      end_of_message: boolean,
      sequence_end: boolean;

    status.normal := TRUE;
    format_representation := work_area;

    token_p := ^first_token;
    IF (format_string = NIL) OR (format_string^ = '') THEN
      put_token (clc$fd_put_element_data);
      token_p^.word_fill := ' ';
      token_p^.index := 1;
      token_p^.conversion := clc$cc_lower_case;
      token_p^.justification := clc$j_left;
      token_p^.width := 0;
      finish_representation;
      RETURN;
    IFEND;

    template := format_string;
    first_token.directive := clc$fd_tab;
    top := 0;
    PUSH stack_p: [1 .. STRLENGTH (template^) DIV 2];

    template_index := 1;
    text_start_index := template_index;

    WHILE template_index <= STRLENGTH (template^) DO

      current_character := template^ (template_index);
      text_end_index := template_index;
      IF (current_character = '+') AND (template_index < STRLENGTH (template^)) THEN
        field_width := 0;
        fill_character := ' ';
        justification := clc$j_left;
        REPEAT
          sequence_end := TRUE;
          CASE template^ (template_index + 1) OF

          = 'E', 'e' = {soft eol (end of line)
            get_count (count_given, count);
            put_token (clc$fd_soft_eol);
            token_p^.count := count;

          = 'F', 'f' = { Fill Character
            sequence_end := FALSE;
            template_index := template_index + 1;
            IF template_index + 1 <= STRLENGTH (template^) THEN
              fill_character := template^ (template_index + 1);
              template_index := template_index + 1;
            IFEND;

          = 'H', 'h' = {insert spaces to column
            get_count (count_given, count);
            put_token (clc$fd_tab);
            token_p^.fill_character := fill_character;
            token_p^.count := count;

          = 'K', 'k' = {toggle keeping together of a group of characters
            template_index := template_index + 2;
            put_token (clc$fd_group);

          = 'L', 'l' = {Put label
            get_parameter (clc$fd_put_label, fill_character, field_width, justification);

          = 'N', 'n' = {hard eol (end of line)
            get_count (count_given, count);
            put_token (clc$fd_hard_eol);
            token_p^.count := count;

          = 'P', 'p' = {Put parameter with element conversion
            get_parameter (clc$fd_put_element_data, fill_character, field_width, justification);

          = 'R', 'r' = {begin repeating information
            template_index := template_index + 2;
            IF (top > 0) AND (stack_p^ [top]^.directive = clc$fd_repeat) THEN
              put_token (clc$fd_text);
              token_p^.link := #REL (stack_p^ [top], format_representation^);
              pop_item;
            ELSE
              push_item (clc$fd_repeat);
            IFEND;
            current_character := ' ';

          = 'S', 's' = {Put parameter with source conversion
            get_parameter (clc$fd_put_source_data, fill_character, field_width, justification);

          = 'W', 'w' = { Width
            sequence_end := FALSE;
            IF template_index + 2 <= STRLENGTH (template^) THEN
              CASE template^ (template_index + 2) OF
              = 'R', 'r' =
                justification := clc$j_right;
                template_index := template_index + 1;
              = 'L', 'l' =
                justification := clc$j_left;
                template_index := template_index + 1;
              = 'C', 'c' =
                justification := clc$j_center;
                template_index := template_index + 1;
              ELSE
              CASEND;
            IFEND;
            get_count (count_given, count);
            IF count_given THEN
              field_width := count;
            ELSE
              field_width := osc$max_name_size;
            IFEND;
            template_index := template_index - 1;

          = 'X', 'x' = {expand count as blanks
            get_count (count_given, count);
            IF NOT count_given THEN
              count := 1;
            IFEND;
            put_token (clc$fd_put_spaces);
            token_p^.fill_character := fill_character;
            token_p^.count := count;

          = '(' = {process parts of an item
            get_count (count_given, count);
            push_item (clc$fd_expand_item);
            token_p^.item := count;
            token_p^.item_specified := count_given;

          = ')' = {Finish processing an item
            template_index := template_index + 2;
            put_token (clc$fd_text);
            IF (top > 0) AND (stack_p^ [top]^.directive = clc$fd_repeat) THEN
              token_p^.link := #REL (stack_p^ [top], format_representation^);
              pop_item;
            IFEND;
            pop_item;

          = '+' = {the control sequence ++ => +
            template_index := template_index + 1;
            put_token (clc$fd_text);
            template_index := template_index + 1;

          = '-' = {NULL sequence (to allow for concatenation)
            template_index := template_index + 2;
            put_token (clc$fd_text);

          ELSE {this '+' is just another character
            template_index := template_index + 1;
          CASEND;
        UNTIL sequence_end;

      ELSE
        template_index := template_index + 1;
      IFEND;

    WHILEND;

    text_end_index := STRLENGTH (template^) + 1;
    put_token (clc$fd_text);

    WHILE top > 0 DO
      IF stack_p^ [top]^.directive = clc$fd_repeat THEN
        token_p^.link := #REL (stack_p^ [top], format_representation^);
      IFEND;
      pop_item;
    WHILEND;

    finish_representation;

  PROCEND clp$build_format_representation;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] clp$build_formatted_strings', EJECT ??
*copyc clh$build_formatted_strings

  PROCEDURE [XDCL, #GATE] clp$build_formatted_strings
    (    format_representation: ^clt$format_representation;
         value: ^clt$data_value;
         max_string: clt$string_size;
     VAR work_area: ^clt$work_area;
     VAR data_representation: ^clt$data_representation;
     VAR status: ost$status);


    VAR
      delimiter_set: [STATIC, READ, oss$job_paged_literal] packed array [char] of boolean := [
            {---} REP 32 of FALSE,
            {' '} TRUE,
            {---} REP 11 of FALSE,
            {-,-} TRUE,
            {---} REP 211 of FALSE],
      non_delimiter_set: [STATIC, READ, oss$job_paged_literal] packed array [char] of boolean := [
            {---} REP 32 of TRUE,
            {' '} FALSE,
            {---} REP 11 of TRUE,
            {-,-} FALSE,
            {---} REP 211 of TRUE];

    VAR
      empty_string: ^string ( * ),
      first_value_p: ^clt$data_value,
      indent_amount: integer,
      keep_pending: boolean,
      label_data_value: clt$data_value,
      last_space_hard: boolean,
      last_value_index: 0 .. clc$max_list_size,
      last_value_p: ^clt$data_value,
      next_line_break_index: clt$string_size,
      next_line_p: ^clt$string_value,
      next_line_secondary_break_index: clt$string_size,
      next_line_size: clt$string_size,
      parameters: ^clt$data_value,
      parameters_exhausted: boolean,
      reference_kind: value_reference_kind,
      repeating: boolean,
      soft_eol_pending: boolean,
      stack_p: ^array [1 .. * ] of state,
      string_count: ^clt$data_representation_count,
      top: 0 .. clc$max_string_size;

?? NEWTITLE := 'break_line', EJECT ??

{ PURPOSE:
{   Find the best place to end the current line and start a new line.

    PROCEDURE break_line;

      VAR
        extra_chars_p: ^clt$string_value,
        extra_chars_length: clt$string_size,
        i: clt$string_size;


      IF next_line_break_index = 0 THEN
        next_line_break_index := next_line_secondary_break_index;
      IFEND;

      IF next_line_break_index = 0 THEN
        PUSH extra_chars_p: [2];
        extra_chars_p^ := next_line_p^ (max_string - 1, 2);
        next_line_p^ (max_string - 1, 2) := '..';

      ELSEIF next_line_break_index < max_string THEN
        PUSH extra_chars_p: [max_string - next_line_break_index];
        extra_chars_p^ := next_line_p^ (next_line_break_index + 1, * );
        next_line_size := next_line_break_index;

      ELSE
        extra_chars_p := NIL;
      IFEND;

      flush_line;

      IF extra_chars_p = NIL THEN
        RETURN;
      IFEND;

      FOR i := 1 TO STRLENGTH (extra_chars_p^) DO
        put_character (extra_chars_p^ (i));
      FOREND;

    PROCEND break_line;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] fill', EJECT ??

{ PURPOSE:
{   Place the specified number of the fill character into the line.

    PROCEDURE [INLINE] fill
      (    count: integer;
           fill_character: char;
           hard_space: boolean);

      VAR
        i: integer;

      IF (next_line_size + count) > max_string THEN
        indent_amount := 0;
        flush_line;
      ELSEIF fill_character = ' ' THEN
        next_line_size := next_line_size + count;
        last_space_hard := last_space_hard OR hard_space;
      ELSE
        FOR i := 1 TO count DO
          put_character (fill_character);
        FOREND;
      IFEND;
    PROCEND fill;
?? OLDTITLE ??
?? NEWTITLE := 'finish_representation', EJECT ??

{ PURPOSE:
{   Update data_representation to reflect the work done.

    PROCEDURE finish_representation;

      VAR
        final_position: integer;

      IF next_line_size > 0 THEN
        flush_line;
      IFEND;

      final_position := i#current_sequence_position (work_area);
      RESET work_area TO string_count;
      NEXT data_representation: [[REP final_position - i#current_sequence_position (work_area) OF cell]] IN
            work_area;
      RESET data_representation;
    PROCEND finish_representation;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] flush_line', EJECT ??

{ PURPOSE:
{   Add the current line to the work area and start a new line.

    PROCEDURE [INLINE] flush_line;

      VAR
        line: ^clt$string_value,
        line_size: ^clt$string_size;


      IF NOT last_space_hard THEN
        WHILE (next_line_size > 0) AND (next_line_p^ (next_line_size) = ' ') DO
          next_line_size := next_line_size - 1;
        WHILEND;
      IFEND;

      NEXT line_size IN work_area;
      IF line_size = NIL THEN
        finish_representation;
        EXIT clp$build_formatted_strings;
      IFEND;
      NEXT line: [next_line_size] IN work_area;
      IF line = NIL THEN
        finish_representation;
        EXIT clp$build_formatted_strings;
      IFEND;

      string_count^ := string_count^ +1;
      line_size^ := next_line_size;
      line^ := next_line_p^ (1, next_line_size);

      IF indent_amount >= max_string THEN
        NEXT line_size IN work_area;
        IF line_size = NIL THEN
          finish_representation;
          EXIT clp$build_formatted_strings;
        IFEND;
        string_count^ := string_count^ +1;
        line_size^ := 0;
        next_line_size := 0;
      ELSE
        next_line_size := indent_amount;
      IFEND;

      soft_eol_pending := FALSE;
      next_line_break_index := 0;
      next_line_secondary_break_index := 0;
      next_line_p^ := '';

    PROCEND flush_line;
?? OLDTITLE ??
?? NEWTITLE := 'get_label', EJECT ??

{ PURPOSE:
{   Get the label of the specified parameter.

    PROCEDURE get_label
      (    count: clt$list_size;
           next_value: boolean;
       VAR data_p: ^clt$data_value);

      IF NOT next_value AND (count > 0) THEN
        reference_kind := direct_reference;
      ELSEIF reference_kind = no_reference THEN
        reference_kind := relative_reference;
      IFEND;

      data_p := NIL;
      IF next_value AND parameters_exhausted THEN

      ELSEIF first_value_p^.kind = clc$list THEN
        IF next_value THEN
          last_value_index := last_value_index + 1;
          IF last_value_index > 1 THEN
            last_value_p := last_value_p^.link;
          IFEND;

        ELSEIF count > 0 THEN {get a specific parameter
          IF (count < last_value_index) OR (last_value_index = 0) THEN
            last_value_index := 1;
            last_value_p := first_value_p;
          IFEND;

          WHILE (last_value_index < count) AND (last_value_p <> NIL) DO
            last_value_p := last_value_p^.link;
            last_value_index := last_value_index + 1;
          WHILEND;

          IF last_value_p = NIL THEN
            parameters_exhausted := TRUE;
            RETURN;
          IFEND;

        ELSEIF last_value_index = 0 THEN
          last_value_index := 1;

        IFEND;
        parameters_exhausted := last_value_p^.link = NIL;

{ Build a label from last_value_index;

        data_p := ^label_data_value;
        data_p^.kind := clc$integer;
        data_p^.integer_value.value := last_value_index;
        data_p^.integer_value.radix := 10;
        data_p^.integer_value.radix_specified := FALSE;

      ELSEIF first_value_p^.kind = clc$record THEN
        IF next_value THEN
          last_value_index := last_value_index + 1;
        ELSEIF count > 0 THEN
          last_value_index := count;
        IFEND;

        parameters_exhausted := (last_value_index >= UPPERBOUND (first_value_p^.field_values^));
        IF last_value_index <= UPPERBOUND (first_value_p^.field_values^) THEN
          data_p := ^label_data_value;
          data_p^.kind := clc$name;
          data_p^.name_value := last_value_p^.field_values^ [last_value_index].name;
        IFEND;

      ELSEIF first_value_p^.kind = clc$array THEN
        IF next_value THEN
          last_value_index := last_value_index + 1;
        ELSEIF count > 0 THEN
          last_value_index := count;
        ELSEIF last_value_index = 0 THEN
          last_value_index := 1;
        IFEND;

        parameters_exhausted := (last_value_index >= UPPERBOUND (first_value_p^.array_value^));
        IF last_value_index <= UPPERBOUND (first_value_p^.array_value^) THEN
          data_p := ^label_data_value;
          data_p^.kind := clc$integer;
          data_p^.integer_value.value := last_value_index;
          data_p^.integer_value.radix := 10;
          data_p^.integer_value.radix_specified := FALSE;
          data_p := last_value_p^.array_value^ [last_value_index];
        IFEND;

      ELSEIF count <= 1 THEN
        data_p := last_value_p;
        parameters_exhausted := TRUE;

      ELSE
        parameters_exhausted := TRUE;

      IFEND;

    PROCEND get_label;
?? OLDTITLE ??
?? NEWTITLE := 'get_parameter', EJECT ??

{ PURPOSE:
{   Get the the specified parameter.

    PROCEDURE get_parameter
      (    count: clt$list_size;
           next_value: boolean;
       VAR data_p: ^clt$data_value);

      VAR
        i: integer;


      IF NOT next_value AND (count > 0) THEN
        reference_kind := direct_reference;
      ELSEIF reference_kind = no_reference THEN
        reference_kind := relative_reference;
      IFEND;

      data_p := NIL;
      IF next_value AND parameters_exhausted THEN

      ELSEIF first_value_p^.kind = clc$list THEN
        IF next_value THEN
          last_value_index := last_value_index + 1;
          IF last_value_index > 1 THEN
            last_value_p := last_value_p^.link;
          IFEND;

        ELSEIF count > 0 THEN {get a specific parameter
          IF (count < last_value_index) OR (last_value_index = 0) THEN
            last_value_index := 1;
            last_value_p := first_value_p;
          IFEND;

          WHILE (last_value_index < count) AND (last_value_p <> NIL) DO
            last_value_p := last_value_p^.link;
            last_value_index := last_value_index + 1;
          WHILEND;

          IF last_value_p = NIL THEN
            parameters_exhausted := TRUE;
            RETURN;
          IFEND;

        ELSEIF last_value_index = 0 THEN
          last_value_index := 1;

        IFEND;
        parameters_exhausted := last_value_p^.link = NIL;
        data_p := last_value_p^.element_value;

      ELSEIF first_value_p^.kind = clc$record THEN
        IF next_value THEN
          last_value_index := last_value_index + 1;
        ELSEIF count > 0 THEN
          last_value_index := count;
        IFEND;

        parameters_exhausted := (last_value_index >= UPPERBOUND (first_value_p^.field_values^));
        IF last_value_index <= UPPERBOUND (first_value_p^.field_values^) THEN
          data_p := last_value_p^.field_values^ [last_value_index].value;
        IFEND;

      ELSEIF first_value_p^.kind = clc$array THEN
        IF next_value THEN
          last_value_index := last_value_index + 1;
        ELSEIF count > 0 THEN
          last_value_index := count;
        ELSEIF last_value_index = 0 THEN
          last_value_index := 1;
        IFEND;

        parameters_exhausted := (last_value_index >= UPPERBOUND (first_value_p^.array_value^));
        IF last_value_index <= UPPERBOUND (first_value_p^.array_value^) THEN
          data_p := last_value_p^.array_value^ [last_value_index];
        IFEND;

      ELSEIF count <= 1 THEN
        data_p := last_value_p;
        parameters_exhausted := TRUE;

      ELSE
        parameters_exhausted := TRUE;

      IFEND;

    PROCEND get_parameter;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] pop_state', EJECT ??

{ PURPOSE:
{   Restore the state of directive processing when the last nest was done.

    PROCEDURE [INLINE] pop_state;

      IF top > 0 THEN
        first_value_p := stack_p^ [top].first_value_p;
        last_value_index := stack_p^ [top].last_value_index;
        last_value_p := stack_p^ [top].last_value_p;
        parameters_exhausted := stack_p^ [top].parameters_exhausted;
        reference_kind := stack_p^ [top].reference_kind;
        repeating := stack_p^ [top].repeating;
        token_p := stack_p^ [top].token_p;
        top := top - 1;
      IFEND;

    PROCEND pop_state;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] put_character', EJECT ??

{ PURPOSE:
{   Place one character into the display line.

    PROCEDURE [INLINE] put_character
      (    c: char);


      IF next_line_size >= max_string THEN
        break_line;
      IFEND;

      next_line_size := next_line_size + 1;
      CASE c OF

      = $CHAR (0) .. $CHAR (31), $CHAR (127) =
        next_line_p^ (next_line_size) := '?';
        IF NOT (soft_eol_pending OR keep_pending) THEN
          next_line_break_index := next_line_size;
        IFEND;

      = 'A' .. 'Z', 'a' .. 'z', '0' .. '9', '$', '#', '@', '[', '\', ']', '^', '`', '{', '|', '}', '~' =
        next_line_p^ (next_line_size) := c;

      = '_', '.', '(', ':' =
        next_line_p^ (next_line_size) := c;
        next_line_secondary_break_index := next_line_size;

      ELSE
        next_line_p^ (next_line_size) := c;
        IF NOT (soft_eol_pending OR keep_pending) THEN
          next_line_break_index := next_line_size;
        IFEND;

      CASEND;

    PROCEND put_character;
?? OLDTITLE ??
?? NEWTITLE := 'put_data_value', EJECT ??

{ PURPOSE:
{   Put the string representation of the specified data value to the display
{   line.

    PROCEDURE put_data_value
      (    item: clt$format_token;
           data_p: ^clt$data_value);

      VAR
        count: integer,
        conversion_line_p: ^clt$string_value,
        converted: boolean,
        data_representation: ^clt$data_representation,
        i: integer,
        local_work_area: ^clt$work_area,
        option: clt$data_representation_option,
        parameter: ^clt$string_value,
        separator: boolean;


      IF data_p = NIL THEN
        put_string ('', item.width, item.justification, item.word_fill);
        RETURN;
      IFEND;

{ Determine the type of translation to string to use.

      count := item.index;

      IF item.conversion = clc$cc_upper_case THEN
        IF item.directive = clc$fd_put_source_data THEN
          option := clc$data_source_representation;
        ELSE
          option := clc$data_elem_representation;
        IFEND;
      ELSEIF item.directive = clc$fd_put_source_data THEN
        option := clc$display_srce_representation;
      ELSE
        option := clc$display_elem_representation;
      IFEND;

{ Perform the desired conversion.

      converted := FALSE;
      IF item.directive = clc$fd_put_element_data THEN
        CASE data_p^.kind OF

        = clc$string, clc$application =
          parameter := data_p^.string_value;
          IF item.conversion = clc$cc_initial_caps THEN
            PUSH conversion_line_p: [STRLENGTH (parameter^)];
            conversion_line_p^ := parameter^;
            parameter := conversion_line_p;
          IFEND;
          converted := TRUE;

        = clc$name, clc$keyword, clc$data_name, clc$cobol_name =
          parameter := ^data_p^.name_value (1, clp$trimmed_string_size (data_p^.name_value));
          IF item.conversion <> clc$cc_upper_case THEN
            PUSH conversion_line_p: [STRLENGTH (parameter^)];
            #TRANSLATE (osv$upper_to_lower, parameter^, conversion_line_p^);
            parameter := conversion_line_p;
          IFEND;
          converted := TRUE;

        ELSE
        CASEND;
      IFEND;

      IF NOT converted THEN
        local_work_area := work_area;
        clp$convert_data_to_string (data_p, option, clc$max_string_size, local_work_area, data_representation,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        conversion_line_p := clp$data_representation_text (data_representation);
        PUSH parameter: [STRLENGTH (conversion_line_p^)];
        parameter^ := conversion_line_p^;
      IFEND;

      IF item.conversion = clc$cc_initial_caps THEN
        separator := TRUE;
        FOR i := 1 TO STRLENGTH (parameter^) DO
          IF (parameter^ (i) < 'a') OR (parameter^ (i) > 'z') THEN
            separator := TRUE;
          ELSEIF separator THEN
            separator := FALSE;
            parameter^ (i) := $CHAR ($INTEGER (parameter^ (i)) - $INTEGER ('a') + $INTEGER ('A'));
          IFEND;
        FOREND;
      IFEND;

      put_string (parameter^, item.width, item.justification, item.word_fill);

    PROCEND put_data_value;
?? OLDTITLE ??
?? NEWTITLE := 'put_string', EJECT ??

{ PURPOSE:
{   Put a string to the display line taking into account the desired
{   justification.

    PROCEDURE put_string
      (    s: string ( * );
           field_width: clt$string_size;
           justification: clt$justification;
           fill_character: char);

      VAR
        i: clt$string_size,
        left_fill: clt$string_size,
        right_fill: clt$string_size;

      IF field_width = 0 THEN
        FOR i := 1 TO STRLENGTH (s) DO
          put_character (s (i));
        FOREND;

      ELSEIF field_width <= STRLENGTH (s) THEN
        IF justification = clc$j_right THEN
          FOR i := STRLENGTH (s) - field_width + 1 TO STRLENGTH (s) DO
            put_character (s (i));
          FOREND;
        ELSE
          FOR i := 1 TO field_width DO
            put_character (s (i));
          FOREND;
        IFEND;

      ELSE
        right_fill := field_width - STRLENGTH (s);
        CASE justification OF
        = clc$j_right =
          left_fill := right_fill;
          right_fill := 0;
        = clc$j_left =
          left_fill := 0;
        = clc$j_center =
          left_fill := right_fill DIV 2;
          right_fill := right_fill - left_fill;
        CASEND;
        FOR i := 1 TO left_fill DO
          put_character (fill_character);
        FOREND;
        FOR i := 1 TO STRLENGTH (s) DO
          put_character (s (i));
        FOREND;
        FOR i := 1 TO right_fill DO
          put_character (fill_character);
        FOREND;
        IF (right_fill > 0) AND (fill_character = ' ') THEN
          last_space_hard := TRUE;
        IFEND;
      IFEND;

    PROCEND put_string;
?? OLDTITLE ??
?? NEWTITLE := 'push_state', EJECT ??

{ PURPOSE:
{   Push the current state of token processing on the stack.

    PROCEDURE push_state;

      top := top + 1;
      stack_p^ [top].first_value_p := first_value_p;
      stack_p^ [top].last_value_index := last_value_index;
      stack_p^ [top].last_value_p := last_value_p;
      stack_p^ [top].parameters_exhausted := parameters_exhausted;
      stack_p^ [top].reference_kind := reference_kind;
      stack_p^ [top].repeating := repeating;
      stack_p^ [top].token_p := #PTR (token_p^.link, format_representation^);
      parameters_exhausted := (last_value_p = NIL);
      last_value_index := 0;
      repeating := FALSE;
      reference_kind := no_reference;

    PROCEND push_state;
?? OLDTITLE ??
?? EJECT ??

    VAR
      count: integer,
      data_value_p: ^clt$data_value,
      dummy_item: clt$format_token,
      local_format_rep: ^clt$format_representation,
      string_p: ^clt$string_value,
      token_p: ^clt$format_token;

    status.normal := TRUE;

    NEXT string_count IN work_area;
    IF string_count = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    string_count^ := 0;

    local_format_rep := format_representation;
    NEXT token_p IN local_format_rep;
    IF token_p = NIL THEN
      finish_representation;
      RETURN;
    IFEND;

    parameters_exhausted := (value = NIL);
    first_value_p := value;
    last_value_p := value;
    last_value_index := 0;
    top := 0;

    PUSH stack_p: [1 .. #SIZE (format_representation^) DIV #SIZE (clt$format_token)];

    PUSH empty_string: [0];
    next_line_size := 0;
    PUSH next_line_p: [max_string];
    next_line_p^ := '';
    next_line_break_index := 0;
    next_line_secondary_break_index := 0;
    indent_amount := 0;
    soft_eol_pending := FALSE;
    keep_pending := FALSE;
    last_space_hard := FALSE;
    repeating := FALSE;
    reference_kind := no_reference;

  /for_each_list_element/
    REPEAT

      CASE token_p^.directive OF

      = clc$fd_soft_eol =
        soft_eol_pending := TRUE;
        next_line_break_index := next_line_size;
        indent_amount := token_p^.count;

      = clc$fd_tab =
        IF token_p^.count = 0 THEN
          count := 8 - (next_line_size MOD 8);
        ELSEIF next_line_size >= token_p^.count THEN
          count := 1;
        ELSE
          count := token_p^.count - next_line_size - 1;
        IFEND;
        fill (count, token_p^.fill_character, {Hard space} FALSE);

      = clc$fd_group =
        keep_pending := NOT keep_pending;

      = clc$fd_hard_eol =
        next_line_break_index := next_line_size;
        indent_amount := token_p^.count;
        flush_line;
        indent_amount := 0;

      = clc$fd_put_element_data, clc$fd_put_source_data =
        get_parameter (token_p^.index, token_p^.next_value, data_value_p);
        put_data_value (token_p^, data_value_p);

      = clc$fd_put_label =
        get_label (token_p^.index, token_p^.next_value, data_value_p);
        put_data_value (token_p^, data_value_p);

      = clc$fd_repeat =
        IF parameters_exhausted OR repeating AND (reference_kind <> relative_reference) THEN
          repeating := FALSE;
        ELSE
          repeating := TRUE;
          reference_kind := no_reference;
          dummy_item.link := token_p^.sub_format;
          token_p := ^dummy_item;
        IFEND;

      = clc$fd_put_spaces =
        fill (token_p^.count, token_p^.fill_character, {Hard space} TRUE);

      = clc$fd_expand_item =
        get_parameter (token_p^.item, NOT token_p^.item_specified, data_value_p);
        IF data_value_p <> NIL THEN
          push_state;
          first_value_p := data_value_p;
          last_value_p := data_value_p;
          dummy_item.link := token_p^.sub_format;
          token_p := ^dummy_item;
        IFEND;

      = clc$fd_text =
        string_p := #PTR (token_p^.text_p, format_representation^);
        put_string (string_p^, 0, clc$j_left, ' ');

      ELSE
      CASEND;
      token_p := #PTR (token_p^.link, format_representation^);
      WHILE (token_p = NIL) AND (top > 0) DO
        pop_state;
      WHILEND;
    UNTIL token_p = NIL;

    finish_representation;

  PROCEND clp$build_formatted_strings;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] clp$format_value', EJECT ??
*copy clh$format_value

  PROCEDURE [XDCL, #GATE] clp$format_value
    (    format_string: ^clt$string_value;
         value: ^clt$data_value;
         max_string: clt$string_size;
     VAR work_area: ^clt$work_area;
     VAR data_representation: ^clt$data_representation;
     VAR status: ost$status);

    VAR
      format_representation: ^clt$format_representation,
      local_work_area: ^clt$work_area;


    status.normal := TRUE;
    IF (format_string <> NIL) AND (format_string^ <> '') THEN
      PUSH local_work_area: [[REP STRLENGTH (format_string^) + STRLENGTH (format_string^) *
            3 DIV 2 OF clt$format_token]];
    ELSE
      PUSH local_work_area: [[REP 5 OF clt$format_token]];
    IFEND;

    clp$build_format_representation (format_string, local_work_area, format_representation, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$build_formatted_strings (format_representation, value, max_string, work_area, data_representation,
          status);

  PROCEND clp$format_value;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] clp$$format_value', EJECT ??

{ PURPOSE:
{   Function processor for the $format_value function.

  PROCEDURE [XDCL] clp$$format_value
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (CLM$$FORMAT_VALUE) $format_value (
{   format_string: string = $required
{   values: any = $required
{   max_string: integer 3..clc$max_string_size = $max_string)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (11),
      recend,
    recend := [
    [1,
    [90, 3, 23, 16, 28, 58, 912],
    clc$function, 3, 3, 2, 0, 0, 0, 0, 'CLM$$FORMAT_VALUE'], [
    ['FORMAT_STRING                  ',clc$nominal_entry, 1],
    ['MAX_STRING                     ',clc$nominal_entry, 3],
    ['VALUES                         ',clc$nominal_entry, 2]],
    [
{ 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, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, 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, 12, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [2, 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, 20,
  clc$optional_default_parameter, 0, 11]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [-$clt$type_kinds [],
    FALSE, 0]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [3, clc$max_string_size, 10],
    '$max_string']];

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

    CONST
      p$format_string = 1,
      p$values = 2,
      p$max_string = 3;

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

    VAR
      i: clt$data_representation_count,
      node: ^clt$data_value,
      representation: ^clt$data_representation,
      string_count: ^clt$data_representation_count,
      string_size: ^clt$string_size;

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

    clp$format_value (pvt [p$format_string].value^.string_value, pvt [p$values].value,
          pvt [p$max_string].value^.integer_value.value, work_area, representation, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /work_area_ok/
    BEGIN
      NEXT string_count IN representation;
      IF string_count^ = 1 THEN
        clp$make_value (clc$string, work_area, result);
        IF result = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        NEXT string_size IN representation;
        NEXT result^.string_value: [string_size^] IN representation;
      ELSE
        clp$make_list_value (work_area, result);
        IF result = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        node := result;

        FOR i := 1 TO string_count^ DO
          clp$make_value (clc$string, work_area, node^.element_value);
          IF node^.element_value = NIL THEN
            EXIT /work_area_ok/;
          IFEND;
          NEXT string_size IN representation;
          NEXT node^.element_value^.string_value: [string_size^] IN representation;
          IF i < string_count^ THEN
            clp$make_list_value (work_area, node^.link);
            IF node^.link = NIL THEN
              EXIT /work_area_ok/;
            IFEND;
            node := node^.link;
          IFEND;
        FOREND;
      IFEND;

      RETURN;
    END /work_area_ok/;
    osp$set_status_condition (cle$work_area_overflow, status);

  PROCEND clp$$format_value;
?? OLDTITLE ??
MODEND clm$format_value;
*DECK DECK=CLM$FUNCTION_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Function Manager' ??
MODULE clm$function_manager;

{
{ PURPOSE:
{   This module contains the procedures that support the processing of
{   functions.
{
{ NOTE:
{   The clp$scan_argument_list interface has been moved to module
{   clm$scan_parameter_list.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$compiling_for_test_harness
*copyc clc$exiting_condition
*copyc clc$reset_dereference_name
*copyc cle$ecc_command_processing
*copyc cle$ecc_parsing
*copyc cle$ecc_utilities
*copyc cle$not_yet_implemented
*copyc cle$unable_to_call_function
*copyc cle$unexpected_call_to
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$function_name
*copyc clt$function_result
*copyc clt$i_parameter_list_contents
*copyc clt$parse_state
*copyc clt$type_description
*copyc clt$type_specification
*copyc clt$variable_access_info
*copyc clt$variable_ref_expression
*copyc clt$work_area
*copyc cyd$run_time_error_condition
*IF $true(osv$unix)
*copyc cyt$mips_signal_handler
*IFEND
*copyc fsc$compiling_for_test_harness
*copyc llt$function_description
*copyc ost$caller_identifier
*copyc ost$status
*IF NOT $true(osv$unix)
*copyc pfe$error_condition_codes
*IFEND
?? POP ??
*IF NOT $true(osv$unix)
*copyc amv$nil_file_identifier
*IFEND
*copyc clp$append_status_parse_state
*copyc clp$convert_clt$value_to_value
*copyc clp$convert_int_value_to_ext
*IF NOT $true(osv$unix)
*copyc clp$convert_string_to_file
*IFEND
*copyc clp$convert_type_desc_to_spec
*IF NOT $true(osv$unix)
*copyc clp$echo_trace_information
*IFEND
*copyc clp$evaluate_parameters
*IF NOT $true(osv$unix)
*copyc clp$find_cmnd_or_func_in_prog
*IFEND
*copyc clp$find_command_list
*IF NOT $true(osv$unix)
*copyc clp$find_connected_files
*IFEND
*copyc clp$find_current_block
*IF NOT $true(osv$unix)
*copyc clp$get_interpreter_mode
*copyc clp$get_proc_value
*IFEND
*copyc clp$get_work_area
*IF NOT $true(osv$unix)
*copyc clp$load_from_library
*copyc clp$load_system_entry_point
*IFEND
*copyc clp$make_unspecified_value
*copyc clp$pop_block_stack
*copyc clp$pop_input_stack
*copyc clp$pop_terminated_blocks
*copyc clp$process_command_file
*IF NOT $true(osv$unix)
*copyc clp$process_exit_condition
*copyc clp$process_proc_parameters
*IFEND
*copyc clp$push_function_block
*IF NOT $true(osv$unix)
*copyc clp$push_function_proc_block
*IFEND
*copyc clp$scan_any_lexical_unit
*copyc clp$scan_bal_paren_lexical_unit
*copyc clp$scan_non_space_lexical_unit
*IF NOT $true(osv$unix)
*copyc clp$search_command_library
*IFEND
*copyc clp$trimmed_string_size
*copyc clv$system_functions
*copyc clv$system_functions_v0
*IF NOT $true(osv$unix)
  ?IF fsc$compiling_for_test_harness AND clc$compiling_for_test_harness THEN
*copyc fsv$test_harness_fnctns
  ?IFEND
*IFEND
*copyc osp$append_status_parameter
*IF NOT $true(osv$unix)
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$establish_condition_handler
*copyc osp$file_access_condition
*IFEND
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*IF NOT $true(osv$unix)
*copyc pmp$cause_condition
*copyc pmp$continue_to_cause
*copyc pmp$get_task_id
*copyc pmp$inward_call
*copyc pmp$load
*copyc pmp$pop_task_debug_mode
*copyc pmp$push_task_debug_mode
*ELSE
*copyc osp$set_status_from_errno
*copyc pmp_get_task_id
*IFEND
*IF NOT $true(osv$unix)
*copyc osv$initial_exception_context
*IFEND
?? TITLE := 'Declarations for "special functions"', EJECT ??

{
{ A "special" function is one that can be used in the context of a variable
{ reference, e.g. on the left side of an assignment statement.  The work of
{ such functions is split between the function processor and the caller of
{ clp$evaluate_function.  The function processor simply gathers the parameters
{ it is passed into a clt$function_result.
{
{ The processors for the special functions are at the end of this module.
{

  TYPE
    clt$special_function_processor = ^procedure
           (    evaluate_for_write: boolean;
                parameter_list: clt$parameter_list;
            VAR work_area {input, output} : ^clt$work_area;
            VAR result: clt$function_result;
            VAR status: ost$status);

?? TITLE := 'clp$evaluate_function', EJECT ??

  PROCEDURE [XDCL] clp$evaluate_function
    (    evaluate_for_write: boolean;
         name: clt$function_name;
         context_type_description: ^clt$type_description;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: clt$function_result;
     VAR found: boolean;
     VAR status: ost$status);

    CONST
*IF NOT $true(osv$unix)
      max_functions = 7fffffff(16);
*ELSE
      max_functions = 7ffffffe(16);
*IFEND

    VAR
      block_at_start_of_function: ^clt$block,
      caller_id: ost$caller_identifier,
      callers_save_area: ^ost$stack_frame_save_area,
      command_list: ^clt$command_list,
      current_entry: ^clt$command_list_entry,
      current_task_id: pmt$task_id,
      entry_after_fence: ^clt$command_list_entry,
      function_block: ^clt$block,
      got_task_id: boolean,
*IF $true(osv$unix)
      handler_established: boolean,
*IFEND
      ignore_cmnd_list_found_in_task: boolean,
      index: 1 .. max_functions,
      invoking_function: boolean,
      parameter_list_given: boolean,
      parameters_parse: clt$parse_state,
      search_mode: clt$command_search_modes,
      search_status: ^ost$status,
      source: clt$command_or_function_source,
      system_functions_searched: boolean;

?? NEWTITLE := 'function_condition_handler', EJECT ??

{
{ PURPOSE:
{   This condition handler is established to catch any conditions that occur
{   during the processing of a function.  It is also established for "block
{   exit" conditions and since it cannot disestablish itself, it is during the
{   processing of a block exit condition that cleanup activities are performed.
{

    PROCEDURE function_condition_handler
*IF $true(osv$unix)
      (    signal_no: integer;
           code: integer;
           p_sigcontext: ^cyt$mips_sigcontext);
*ELSE
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        exit_control_block: ^clt$block,
        ignore_status: ost$status,
        run_time_status: ^ost$status;


      CASE condition.selector OF

      = pmc$block_exit_processing =
*IFEND

{ --- Handle block exit.

        IF function_block <> NIL THEN
          clp$pop_terminated_blocks (block_at_start_of_function, status);
        IFEND;
        RETURN;

*IF NOT $true(osv$unix)
      = mmc$segment_access_condition =

{ --- Handle segment access conditions.

        osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
        IF (status.condition = cle$work_area_overflow) AND (status.text.size = 0) THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
        IFEND;
        EXIT clp$evaluate_function;

      = pmc$system_conditions =
        IF pmc$detected_uncorrected_err IN condition.system_conditions THEN

{ --- Handle hardware detected uncorrected error condition.

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
          EXIT clp$evaluate_function;

        ELSEIF invoking_function AND (($pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$environment_specification, pmc$invalid_segment_ring_0, pmc$out_call_in_return] *
              condition.system_conditions) <> $pmt$system_conditions []) AND
              (save_area^.minimum_save_area.a2_previous_save_area = callers_save_area) THEN

{ --- Handle system (hardware detected) conditions resulting from attempt to
{     invoke function processor.

          osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
          EXIT clp$evaluate_function;

        ELSE

{ --- Handle other system (hardware detected) conditions.

          osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
          EXIT clp$evaluate_function;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN

{ --- Handle CYBIL run time error.

          run_time_status := condition_information;
          status := run_time_status^;
          EXIT clp$evaluate_function;

        ELSEIF (condition.user_condition_name = clc$exiting_condition) AND
              (function_block <> NIL) AND function_block^.being_exited THEN

{ --- Handle exit initiated via command level EXIT statement.
{
{ This condition is raised in the task that "owns" the SCL block which is the
{ target of the EXIT statement.
{ This condition is specifically dealt with in the condition handlers that
{ cover processing of the various kinds of input, command and function blocks.
{ The condition_information for this condition is a pointer to the outermost
{ block which is being exited and has such a corresponding condition handler.
{ The handler which is "covering" this "exit_control_block" performs a
{ non-local (CYBIL) exit out of its establishing procedure.
{ Other such handlers simply "continue" the condition.

          exit_control_block := condition_information;
          IF #OFFSET (exit_control_block) <> #OFFSET (function_block) THEN
            pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          IFEND;
          EXIT clp$evaluate_function;

        ELSE

{ --- "Continue" any other user defined condition.

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          RETURN;
        IFEND;

      ELSE

{ --- "Continue" any other condition.

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        RETURN;
      CASEND;
*IFEND

    PROCEND function_condition_handler;
?? TITLE := 'get_task_id', EJECT ??

    PROCEDURE [INLINE] get_task_id;

*IF $true(osv$unix)
      VAR
        c_status: integer;
*IFEND

      IF NOT got_task_id THEN
*IF NOT $true(osv$unix)
        pmp$get_task_id (current_task_id, status);
*ELSE
        pmp_get_task_id (current_task_id, c_status);
        IF c_status = 0 THEN
          status.normal := TRUE;
        ELSE
          osp$set_status_from_errno ('GET_TASK_ID', c_status, '', status);
        IFEND;
*IFEND
        IF NOT status.normal THEN
          EXIT clp$evaluate_function;
        IFEND;
        got_task_id := TRUE;
      IFEND;

    PROCEND get_task_id;
?? TITLE := 'isolate_parameters', EJECT ??

    PROCEDURE [INLINE] isolate_parameter_list;

      VAR
        parameter_list_index: clt$string_index;


      parameters_parse := parse;
      parameter_list_given := parse.unit.kind = clc$lex_left_parenthesis;

      IF parameter_list_given THEN
        parameter_list_index := parse.index;
        clp$scan_bal_paren_lexical_unit (parse);
        IF parse.unit_index >= parse.index_limit THEN
          osp$set_status_abnormal ('CL', cle$expecting_rparen_of_plist, name, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT clp$evaluate_function;
        IFEND;
        parameters_parse.index_limit := parse.unit_index;
        clp$scan_non_space_lexical_unit (parameters_parse);
        clp$scan_any_lexical_unit (parse);
      ELSE
        parameters_parse.index_limit := parse.unit_index;
      IFEND;

    PROCEND isolate_parameter_list;
?? TITLE := 'invoke_contemporary_function', EJECT ??

    PROCEDURE [INLINE] invoke_contemporary_function
      (    loaded_function: clt$function_processor);

      VAR
        parameter_list: clt$i_parameter_list_contents;


      IF evaluate_for_write THEN
        osp$set_status_abnormal ('CL', cle$function_is_read_only, name, status);

      ELSE
        IF function_block = NIL THEN
          clp$push_function_block (caller_id.ring, name, source, parameters_parse, context_type_description,
                function_block);
        IFEND;

*IF NOT $true(osv$unix)
        callers_save_area := #PREVIOUS_SAVE_AREA ();
*ELSE
        callers_save_area := NIL;
*IFEND
        invoking_function := TRUE;
        #SPOIL (callers_save_area, invoking_function);

        parameter_list.identifying_size_field := UPPERVALUE (parameter_list.identifying_size_field);

        loaded_function^ (#SEQ (parameter_list) ^, work_area, result.value, status);

        invoking_function := FALSE;
        #SPOIL (invoking_function);

        IF status.normal AND (result.value = NIL) THEN
          osp$set_status_abnormal ('CL', cle$no_function_result, name, status);
        IFEND;
      IFEND;

    PROCEND invoke_contemporary_function;
?? TITLE := 'invoke_original_function', EJECT ??

    PROCEDURE [INLINE] invoke_original_function
      (    loaded_function: clt$function);

      VAR
        clt_name: clt$name,
        value: clt$value;


      IF evaluate_for_write THEN
        osp$set_status_abnormal ('CL', cle$function_is_read_only, name, status);

      ELSE
        clt_name.value := name;
        clt_name.size := clp$trimmed_string_size (name);

        clp$push_function_block (caller_id.ring, name, source, parameters_parse, context_type_description,
              function_block);

*IF NOT $true(osv$unix)
        callers_save_area := #PREVIOUS_SAVE_AREA ();
*ELSE
        callers_save_area := NIL;
*IFEND
        invoking_function := TRUE;
        #SPOIL (callers_save_area, invoking_function);

        loaded_function^ (clt_name, parameters_parse.text^ (parameters_parse.unit_index,
              parameters_parse.index_limit - parameters_parse.unit_index), value, status);

        invoking_function := FALSE;
        #SPOIL (invoking_function);

        IF status.normal THEN
          clp$convert_clt$value_to_value (value, work_area, result.value, status);
        IFEND;
      IFEND;

    PROCEND invoke_original_function;
?? TITLE := 'invoke_special_function', EJECT ??

    PROCEDURE [INLINE] invoke_special_function
      (    special_function: clt$special_function_processor);

      VAR
        parameter_list: clt$i_parameter_list_contents;


      clp$push_function_block (caller_id.ring, name, source, parameters_parse, context_type_description,
            function_block);

*IF NOT $true(osv$unix)
      callers_save_area := #PREVIOUS_SAVE_AREA ();
*ELSE
      callers_save_area := NIL;
*IFEND
      invoking_function := TRUE;
      #SPOIL (callers_save_area, invoking_function);

      parameter_list.identifying_size_field := UPPERVALUE (parameter_list.identifying_size_field);

      special_function^ (evaluate_for_write, #SEQ (parameter_list) ^, work_area, result, status);

      invoking_function := FALSE;
      #SPOIL (invoking_function);

    PROCEND invoke_special_function;
?? TITLE := 'process_contemporary_function', EJECT ??

    PROCEDURE [INLINE] process_contemporary_function
      (    contemporary_function_entry: clt$function_proc_table_entry);

      VAR
*IF NOT $true(osv$unix)
        contemporary_function: clt$function_processor,
        loaded_address: pmt$loaded_address;
*ELSE
        contemporary_function: clt$function_processor;
*IFEND


      source.function_interface := clc$fi_contemporary;
      source.ordinal := contemporary_function_entry.ordinal;

      CASE contemporary_function_entry.call_method OF

      = clc$linked_call =
        invoke_contemporary_function (contemporary_function_entry.func);

*IF NOT $true(osv$unix)
      = clc$unlinked_call =
        pmp$load (contemporary_function_entry.procedure_name, pmc$procedure_address, loaded_address, status);
        IF status.normal THEN
          #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, contemporary_function);
          invoke_contemporary_function (contemporary_function);
        ELSE
          osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
        IFEND;

      = clc$proc_call, clc$program_call =
        process_utility_lib_function (contemporary_function_entry.procedure_name);
*IFEND

      ELSE
        osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
      CASEND;

    PROCEND process_contemporary_function;
*IF NOT $true(osv$unix)
?? TITLE := 'process_library_function', EJECT ??

    PROCEDURE process_library_function
      (    local_file_name: amt$local_file_name);

      VAR
        context: ^ost$ecp_exception_context,
        file_id: amt$file_identifier,
        library_file: clt$file,
        library_search_info: clt$command_library_search_info,
        nested_commands_can_be_echoed: boolean,
        ring_attributes: amt$ring_attributes;

      context := NIL;

      library_file.local_file_name := local_file_name;

      REPEAT
        clp$search_command_library (name, clc$function, TRUE, work_area, library_file.local_file_name,
              file_id, ring_attributes, nested_commands_can_be_echoed, library_search_info, found, status);
        IF osp$file_access_condition (status) THEN
          IF context = NIL THEN
          PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_file_reference;
            context^.file.file_reference := ^library_file.local_file_name;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

      IF status.normal THEN
        IF found THEN
          IF evaluate_for_write THEN
            osp$set_status_abnormal ('CL', cle$function_is_read_only, name, status);
            RETURN;
          IFEND;

          source.ordinal := library_search_info.ordinal;
          CASE library_search_info.module_kind OF

          = llc$function_procedure =
            invoke_scl_procedure_function (name, context_type_description, source, ring_attributes, file_id,
                  library_file, library_search_info, nested_commands_can_be_echoed, parameters_parse,
                  work_area, result, function_block, status);

          = llc$function_description =
            invoke_described_function (name, context_type_description, source, ring_attributes,
                  parameters_parse, work_area, library_file, library_search_info, result, function_block,
                  status);

          CASEND;
        IFEND;

      IFEND;

    PROCEND process_library_function;
*IFEND
?? TITLE := 'process_original_function', EJECT ??

    PROCEDURE [INLINE] process_original_function
      (    original_function_entry: clt$function_table_entry);

      VAR
*IF NOT $true(osv$unix)
        original_function: clt$function,
        loaded_address: pmt$loaded_address;
*ELSE
        original_function: clt$function;
*IFEND


      source.function_interface := clc$fi_original;
      source.ordinal := original_function_entry.ordinal;

      CASE original_function_entry.call_method OF

      = clc$linked_call =
        invoke_original_function (original_function_entry.func);

*IF NOT $true(osv$unix)
      = clc$unlinked_call =
        pmp$load (original_function_entry.procedure_name, pmc$procedure_address, loaded_address, status);
        IF status.normal THEN
          #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, original_function);
          invoke_original_function (original_function);
        ELSE
          osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
        IFEND;

      = clc$proc_call =
        osp$set_status_abnormal ('CL', cle$not_yet_implemented, 'function procedures (', status);
        osp$append_status_parameter (' ', name, status);
        osp$append_status_parameter (' ', ')', status);
*IFEND

      ELSE
        osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
      CASEND;

    PROCEND process_original_function;
?? TITLE := 'process_system_function', EJECT ??

    PROCEDURE [INLINE] process_system_function;

      VAR
        special_function: clt$special_function_processor;


      source.kind := clc$system_commands;
      source.system_command_table := NIL;

*IF NOT $true(osv$unix)
      IF (command_list^.system_command_library_lfn <> osc$null_name) AND
            command_list^.system_library_contains.functions THEN
        process_library_function (osc$null_name);
        IF found THEN
          RETURN;
        IFEND;
      IFEND;
*IFEND

      search_contemporary_functions (clv$system_functions);
      IF found THEN
*IF NOT $true(osv$unix)
        IF name = '$PARAMETER_VALUE' THEN
          special_function := ^clp$$parameter_value;
        ELSEIF name = '$VALUE' THEN
          special_function := ^clp$$value;
        ELSEIF name = '$VNAME' THEN
          special_function := ^clp$$vname;
        ELSE
          special_function := NIL;
        IFEND;
        IF special_function <> NIL THEN

          source.function_interface := clc$fi_contemporary;
          source.ordinal := clv$system_functions^ [index].ordinal;
          invoke_special_function (special_function);

        ELSE

*IFEND
          process_contemporary_function (clv$system_functions^ [index]);
*IF NOT $true(osv$unix)

        IFEND;
*IFEND
      ELSE
        search_original_functions (clv$system_functions_v0);
        IF found THEN

          process_original_function (clv$system_functions_v0^ [index]);

        IFEND;
      IFEND;

    PROCEND process_system_function;
*IF NOT $true(osv$unix)
?? TITLE := 'process_utility_aux_function', EJECT ??

    PROCEDURE process_utility_aux_function;

      VAR
        index: integer;


      FOR index := 1 TO UPPERBOUND (source.utility_info^.auxiliary_libraries^) DO
        IF source.utility_info^.auxiliary_libraries^ [index].contains.functions THEN
          source.kind := clc$library_commands;
          source.local_file_name := source.utility_info^.auxiliary_libraries^ [index].name;
          process_library_function (source.utility_info^.auxiliary_libraries^ [index].name);
          IF NOT status.normal THEN
            status.normal := TRUE;
          ELSEIF found THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND;

    PROCEND process_utility_aux_function;
*IFEND
?? TITLE := 'process_utility_function', EJECT ??

    PROCEDURE process_utility_function;


      source.kind := clc$sub_commands;
      source.utility_name := current_entry^.utility_name;
      source.utility_info := current_entry^.utility_info;
      source.utility_termination_command := FALSE;
      source.auxilliary_table := FALSE;

      search_contemporary_functions (current_entry^.utility_info^.contemporary_functions);

      IF found THEN
        IF NOT current_entry^.utility_info^.command_level THEN
          get_task_id;
          IF current_entry^.utility_info^.task_id <> current_task_id THEN
            osp$set_status_abnormal ('CL', cle$util_cmds_fctns_unavailable, name, status);
          IFEND;
        IFEND;

        IF status.normal THEN
          process_contemporary_function (current_entry^.utility_info^.contemporary_functions^ [index]);
        IFEND;

      ELSE
        search_original_functions (current_entry^.utility_info^.original_functions);

        IF found THEN
          IF NOT current_entry^.utility_info^.command_level THEN
            get_task_id;
            IF current_entry^.utility_info^.task_id <> current_task_id THEN
              osp$set_status_abnormal ('CL', cle$util_cmds_fctns_unavailable, name, status);
            IFEND;
          IFEND;

          IF status.normal THEN
            process_original_function (current_entry^.utility_info^.original_functions^ [index]);
          IFEND;

        ELSE
          search_contemporary_functions (current_entry^.utility_info^.dialog_info.functions);

          IF found THEN
            IF NOT current_entry^.utility_info^.command_level THEN
              get_task_id;
              IF current_entry^.utility_info^.task_id <> current_task_id THEN
                osp$set_status_abnormal ('CL', cle$util_cmds_fctns_unavailable, name, status);
              IFEND;
            IFEND;

            IF status.normal THEN
              source.auxilliary_table := TRUE;
              process_contemporary_function (current_entry^.utility_info^.dialog_info.functions^ [index]);
            IFEND;

*IF NOT $true(osv$unix)
          ELSEIF source.utility_info^.auxiliary_libraries <> NIL THEN
            process_utility_aux_function;
*IFEND
          IFEND;
        IFEND;
      IFEND;

    PROCEND process_utility_function;
*IF NOT $true(osv$unix)
?? TITLE := 'process_utility_lib_function', EJECT ??

    PROCEDURE process_utility_lib_function
      (    procedure_name: pmt$program_name);

      VAR
        context: ^ost$ecp_exception_context,
        file_id: amt$file_identifier,
        found_function: boolean,
        index: integer,
        library_file: clt$file,
        library_search_info: clt$command_library_search_info,
        nested_commands_can_be_echoed: boolean,
        ring_attributes: amt$ring_attributes;

      context := NIL;

    /search/
      BEGIN
        IF source.utility_info^.libraries <> NIL THEN
          FOR index := 1 TO UPPERBOUND (source.utility_info^.libraries^) DO
            library_file.local_file_name := source.utility_info^.libraries^ [index];

            REPEAT
              clp$search_command_library (procedure_name, clc$function, FALSE, work_area,
                    library_file.local_file_name, file_id, ring_attributes, nested_commands_can_be_echoed,
                    library_search_info, found_function, status);
              IF osp$file_access_condition (status) THEN
                IF context = NIL THEN
                  PUSH context;
                  context^ := osv$initial_exception_context;
                  context^.file.selector := osc$ecp_file_reference;
                  context^.file.file_reference := ^library_file.local_file_name;
                IFEND;
                context^.condition_status := status;
                osp$enforce_exception_policies (context^);
                status := context^.condition_status;
              IFEND;
            UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
            IF NOT status.normal THEN
              EXIT clp$evaluate_function;
            ELSEIF found_function THEN
              EXIT /search/;
            IFEND;
          FOREND;

          osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
          EXIT clp$evaluate_function;

        ELSE
          clp$find_cmnd_or_func_in_prog (procedure_name, clc$function, work_area,
                library_file.local_file_name, ring_attributes, library_search_info, status);
          IF NOT status.normal THEN
            osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
            EXIT clp$evaluate_function;
          IFEND;
          file_id := amv$nil_file_identifier;
          nested_commands_can_be_echoed := FALSE;
        IFEND;
      END /search/;

      IF evaluate_for_write THEN
        osp$set_status_abnormal ('CL', cle$function_is_read_only, name, status);
        EXIT clp$evaluate_function;
      IFEND;

      CASE library_search_info.module_kind OF

      = llc$function_procedure =
        invoke_scl_procedure_function (name, context_type_description, source, ring_attributes, file_id,
              library_file, library_search_info, nested_commands_can_be_echoed, parameters_parse, work_area,
              result, function_block, status);

      = llc$function_description =
        invoke_described_function (name, context_type_description, source, ring_attributes, parameters_parse,
              work_area, library_file, library_search_info, result, function_block, status);

      ELSE
        osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
        EXIT clp$evaluate_function;
      CASEND;

    PROCEND process_utility_lib_function;
*IFEND
?? TITLE := 'search_contemporary_functions', EJECT ??

    PROCEDURE [INLINE] search_contemporary_functions
      (    function_processor_table: ^clt$function_processor_table);

      VAR
        low_index: 1 .. max_functions + 1,
        temp: integer,
        high_index: 0 .. max_functions;


      IF function_processor_table <> NIL THEN
        low_index := 1;
        high_index := UPPERBOUND (function_processor_table^);
        REPEAT
          temp  := low_index + high_index;
          index := temp DIV 2;
          IF name = function_processor_table^ [index].name THEN
            found := TRUE;
          ELSEIF name > function_processor_table^ [index].name THEN
            low_index := index + 1;
          ELSE
            high_index := index - 1;
          IFEND;
        UNTIL found OR (low_index > high_index);
      IFEND;

    PROCEND search_contemporary_functions;
?? TITLE := 'search_original_functions', EJECT ??

    PROCEDURE [INLINE] search_original_functions
      (    function_table: ^clt$function_table);

      VAR
        low_index: 1 .. max_functions + 1,
        temp: integer,
        high_index: 0 .. max_functions;


      IF function_table <> NIL THEN
        low_index := 1;
        high_index := UPPERBOUND (function_table^);
        REPEAT
          temp := low_index + high_index;
          index := temp DIV 2;
          IF name = function_table^ [index].name THEN
            found := TRUE;
          ELSEIF name > function_table^ [index].name THEN
            low_index := index + 1;
          ELSE
            high_index := index - 1;
          IFEND;
        UNTIL found OR (low_index > high_index);
      IFEND;

    PROCEND search_original_functions;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    found := FALSE;
    result.kind := clc$fr_value;
    result.value := NIL;

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND

    search_status := NIL;

    isolate_parameter_list;

    clp$find_current_block (block_at_start_of_function);

    function_block := NIL;
    invoking_function := FALSE;
    #SPOIL (invoking_function, function_block);
*IF $true(osv$unix)
    handler_established := #establish_condition_handler (-1, ^function_condition_handler);
*ELSE
    osp$establish_condition_handler (^function_condition_handler, TRUE);
*IFEND

  /process_function/
    BEGIN
      source.index := 1;
      source.size := 0;
      source.reference_index := 1;
      source.reference_size := 0;

      got_task_id := FALSE;
      system_functions_searched := FALSE;

      clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);
*IF NOT $true(osv$unix)
      IF block_at_start_of_function^.use_command_search_mode THEN
        search_mode := command_list^.search_mode;
      ELSE
        search_mode := clc$global_command_search;
      IFEND;

      IF search_mode = clc$exclusive_command_search THEN
        entry_after_fence := command_list^.entries.entry_after_fence;
      ELSE
        entry_after_fence := NIL;
      IFEND;
*ELSE
      search_mode := clc$global_command_search;
      entry_after_fence := NIL;
*IFEND

      current_entry := command_list^.entries.first_entry;

    /search_list/
      WHILE current_entry <> entry_after_fence DO
        CASE current_entry^.kind OF

*IF NOT $true(osv$unix)
        = clc$library_commands =
          IF current_entry^.library_contains.functions THEN
            source.kind := clc$library_commands;
            source.local_file_name := current_entry^.local_file_name;
            process_library_function (current_entry^.local_file_name);
          IFEND;

*IFEND
        = clc$system_commands =
          process_system_function;
          system_functions_searched := TRUE;

        = clc$sub_commands =
          process_utility_function;
          IF (NOT status.normal) AND (status.condition = cle$util_cmds_fctns_unavailable) THEN
            IF search_status = NIL THEN
              PUSH search_status;
              search_status^ := status;
            IFEND;
            status.normal := TRUE;
            found := FALSE;
          IFEND;

        ELSE
          ;
        CASEND;

        IF (NOT status.normal) OR found THEN
          EXIT /process_function/;
        IFEND;

        current_entry := current_entry^.next_entry;
      WHILEND /search_list/;

      IF NOT system_functions_searched THEN
        process_system_function;
        IF (NOT status.normal) OR found THEN
          EXIT /process_function/;
        IFEND;
      IFEND;

*IF NOT $true(osv$unix)
      ?IF fsc$compiling_for_test_harness AND clc$compiling_for_test_harness THEN
        process_original_function (fsv$test_harness_fnctns);
        IF (NOT status.normal) OR found THEN
          EXIT /process_function/;
        IFEND;
      ?IFEND
*IFEND
    END /process_function/;

    IF function_block <> NIL THEN
      clp$pop_terminated_blocks (block_at_start_of_function, status);
      function_block := NIL;
      #SPOIL (function_block);
    IFEND;

*IF $true(osv$unix)
    IF handler_established THEN
      handler_established := NOT #disestablish_condition_handler (-1);
    IFEND;
*ELSE
    osp$disestablish_cond_handler;
*IFEND

    IF (NOT status.normal) OR found THEN
      RETURN;
    IFEND;

    IF search_status <> NIL THEN
      status := search_status^;
    ELSEIF parameter_list_given THEN
      osp$set_status_abnormal ('CL', cle$unknown_function, name, status);
    IFEND;

  PROCEND clp$evaluate_function;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$get_expected_type', EJECT ??
*copyc clh$get_expected_type

  PROCEDURE [XDCL, #GATE] clp$get_expected_type
    (VAR work_area {input, output} : ^clt$work_area;
     VAR expected_type: ^clt$type_specification;
     VAR status: ost$status);

    VAR
      block: ^clt$block;


    status.normal := TRUE;

  /get_expected_type/
    BEGIN
      clp$find_current_block (block);
      IF (block^.kind = clc$input_block) AND block^.input.prompting_input THEN
        block := block^.previous_block;
      IFEND;
      IF block^.kind <> clc$function_block THEN
        osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$get_expected_type', status);
        EXIT /get_expected_type/;
      IFEND;

      IF block^.expected_function_type = NIL THEN
        expected_type := NIL;
      ELSE
        clp$convert_type_desc_to_spec (block^.expected_function_type, work_area, expected_type, status);
        IF (NOT status.normal) AND (status.condition = cle$work_area_overflow) THEN
          status.text.size := 0;
          osp$append_status_parameter (osc$status_parameter_delimiter, 'clp$get_expected_type', status);
        IFEND;
      IFEND;

{ Inform the expression evaluator that a function processor cared about the
{ current type specification so that the function will be reevaluated if necessary.

      pmp$push_task_debug_mode (pmc$debug_mode_off, status);
      IF NOT status.normal THEN
        EXIT /get_expected_type/;
      IFEND;
      pmp$cause_condition (clc$reset_dereference_name, NIL, {ignore} status);
      pmp$pop_task_debug_mode ( {ignore} status);
      status.normal := TRUE;
    END /get_expected_type/;

  PROCEND clp$get_expected_type;
?? TITLE := 'clp$$parameter_value', EJECT ??

  PROCEDURE clp$$parameter_value
    (    evaluate_for_write: boolean;
         parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: clt$function_result;
     VAR status: ost$status);

{ FUNCTION (osm$$parameter_value) $parameter_value (
{   parameter: data_name = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [87, 10, 20, 17, 15, 25, 421], clc$function, 1, 1, 1, 0, 0, 0, 0,
            'OSM$$PARAMETER_VALUE'], [['PARAMETER                      ', 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, 3, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$data_name_type]]];

?? POP ??

    CONST
      p$parameter = 1;

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


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

    result.kind := clc$fr_parameter_name;
    result.parameter_name := pvt [p$parameter].value^.data_name_value;

  PROCEND clp$$parameter_value;
?? TITLE := 'clp$$value', EJECT ??

  PROCEDURE clp$$value
    (    evaluate_for_write: boolean;
         parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: clt$function_result;
     VAR status: ost$status);

{ FUNCTION (osm$$value) $value (
{   parameter: data_name = $required
{   value_set_number: integer 1..clc$max_value_sets = 1
{   value_number: integer 1..clc$max_values_per_set = 1
{   low_or_high: key
{       low, high
{     keyend = low
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 4] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (1),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (1),
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 2] of clt$keyword_specification,
          default_value: string (3),
        recend,
      recend := [[1, [87, 10, 20, 17, 16, 4, 407], clc$function, 4, 4, 1, 0, 0, 0, 0, 'OSM$$VALUE'],
            [['LOW_OR_HIGH                    ', clc$nominal_entry, 4],
            ['PARAMETER                      ', clc$nominal_entry, 1],
            ['VALUE_NUMBER                   ', clc$nominal_entry, 3],
            ['VALUE_SET_NUMBER               ', clc$nominal_entry, 2]], [

{ PARAMETER 1

      [2, 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, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [4, 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, 20, clc$optional_default_parameter, 0,
            1],

{ PARAMETER 3

      [3, 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, 20, clc$optional_default_parameter, 0,
            1],

{ PARAMETER 4

      [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, 81, clc$optional_default_parameter, 0,
            3]],

{ PARAMETER 1

      [[1, 0, clc$data_name_type]],

{ PARAMETER 2

      [[1, 0, clc$integer_type], [1, clc$max_value_sets, 10], '1'],

{ PARAMETER 3

      [[1, 0, clc$integer_type], [1, clc$max_values_per_set, 10], '1'],

{ PARAMETER 4

      [[1, 0, clc$keyword_type], [2], [['HIGH                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['LOW                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1]], 'low']];

?? POP ??

    CONST
      p$parameter = 1,
      p$value_set_number = 2,
      p$value_number = 3,
      p$low_or_high = 4;

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

    VAR
      access_mode: clt$data_access_mode,
      low_or_high: clt$low_or_high,
      qualifiers_given: boolean;


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

    IF pvt [p$low_or_high].value^.keyword_value = 'LOW' THEN
      low_or_high := clc$low;
    ELSE
      low_or_high := clc$high;
    IFEND;
    qualifiers_given := (pvt [p$value_set_number].value^.integer_value.value <> 1) OR
          (pvt [p$value_number].value^.integer_value.value <> 1) OR (low_or_high <> clc$low);

    IF evaluate_for_write THEN
      result.kind := clc$fr_parameter_name;
      result.parameter_name := pvt [p$parameter].value^.data_name_value;
      IF qualifiers_given THEN
        osp$set_status_abnormal ('CL', cle$qual_$value_is_read_only, '', status);
      IFEND;
    ELSE
      result.kind := clc$fr_value;
      clp$get_proc_value (pvt [p$parameter].value^.data_name_value,
            pvt [p$value_set_number].value^.integer_value.value,
            pvt [p$value_number].value^.integer_value.value, low_or_high, work_area, access_mode,
            result.value, status);
      IF status.normal THEN
        IF access_mode = clc$read_write THEN
          result.kind := clc$fr_parameter_name;
          result.parameter_name := pvt [p$parameter].value^.data_name_value;
          IF qualifiers_given THEN
            osp$set_status_abnormal ('CL', cle$qual_$value_is_read_only, '', status);
          IFEND;
        ELSEIF result.value = NIL THEN
          clp$make_unspecified_value (work_area, result.value);
          IF qualifiers_given THEN
            osp$set_status_abnormal ('CL', cle$cannot_read_component, pvt [p$parameter].value^.
                  data_name_value, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND clp$$value;
?? TITLE := 'clp$$vname', EJECT ??

  PROCEDURE clp$$vname
    (    evaluate_for_write: boolean;
         parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: clt$function_result;
     VAR status: ost$status);

{ FUNCTION (osm$$vname) $vname (
{   variable: string = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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$string_type_qualifier,
        recend,
      recend := [[1, [87, 10, 20, 17, 16, 41, 580], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$VNAME'],
            [['VARIABLE                       ', 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, 8, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]];

?? POP ??

    CONST
      p$variable = 1;

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


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

    result.kind := clc$fr_variable_reference;
    result.variable := pvt [p$variable].value^.string_value;

  PROCEND clp$$vname;
?? TITLE := 'invoke_described_function', EJECT ??

  PROCEDURE invoke_described_function
    (    name: clt$function_name;
         context_type_description: ^clt$type_description;
         source: clt$command_or_function_source;
         ring_attributes: amt$ring_attributes;
         parameters_parse: clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR library_file {input, output} : clt$file;
     VAR library_search_info {input, output} : clt$command_library_search_info;
     VAR result: clt$function_result;
     VAR function_block: ^clt$block;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      callers_save_area: ^ost$stack_frame_save_area,
      converter: record
        case 0 .. 1 of
        = 0 =
          procedure_pointer: ^procedure
            (    name: clt$function_name;
                 context_type_description: ^clt$type_description;
                 source: clt$command_or_function_source;
                 ring_attributes: amt$ring_attributes;
                 parameters_parse: clt$parse_state;
             VAR work_area {input, output} : ^clt$work_area;
             VAR library_file {input, output} : clt$file;
             VAR library_search_info {input, output} : clt$command_library_search_info;
             VAR result: clt$function_result;
             VAR function_block: ^clt$block;
             VAR status: ost$status),
        = 1 =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend,
      function_description_contents: ^llt$function_desc_contents,
      invoking_function: boolean,
      library_path: ^fst$file_reference,
      loaded_address: pmt$loaded_address,
      loaded_function: clt$function_processor,
      parameter_list: clt$i_parameter_list_contents;

?? NEWTITLE := 'described_function_cond_handler', EJECT ??

{
{ PURPOSE:
{   This condition handler duplicates most of the function_condition_handler
{   within clp$evaluate_function.  It is allows any condition that arise to be
{   processed in the ring in which the function processor runs.
{

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

      VAR
        exit_control_block: ^clt$block,
        ignore_status: ost$status,
        run_time_status: ^ost$status;


      CASE condition.selector OF

      = pmc$block_exit_processing =

{ --- Handle block exit.

        RETURN;

      = mmc$segment_access_condition =

{ --- Handle segment access conditions.

        osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
        IF (status.condition = cle$work_area_overflow) AND (status.text.size = 0) THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
        IFEND;
        EXIT invoke_described_function;

      = pmc$system_conditions =
        IF pmc$detected_uncorrected_err IN condition.system_conditions THEN

{ --- Handle hardware detected uncorrected error condition.

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
          EXIT invoke_described_function;

        ELSEIF invoking_function AND (($pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$environment_specification, pmc$invalid_segment_ring_0, pmc$out_call_in_return] *
              condition.system_conditions) <> $pmt$system_conditions []) AND
              (save_area^.minimum_save_area.a2_previous_save_area = callers_save_area) THEN

{ --- Handle system (hardware detected) conditions resulting from attempt to
{     invoke function processor.

          osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
          EXIT invoke_described_function;

        ELSE

{ --- Handle other system (hardware detected) conditions.

          osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
          EXIT invoke_described_function;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN

{ --- Handle CYBIL run time error.

          run_time_status := condition_information;
          status := run_time_status^;
          EXIT invoke_described_function;

        ELSEIF (condition.user_condition_name = clc$exiting_condition) AND
              (function_block <> NIL) AND function_block^.being_exited THEN

{ --- Handle exit initiated via command level EXIT statement.
{
{ This condition is raised in the task that "owns" the SCL block which is the
{ target of the EXIT statement.
{ This condition is specifically dealt with in the condition handlers that
{ cover processing of the various kinds of input, command and function blocks.
{ The condition_information for this condition is a pointer to the outermost
{ block which is being exited and has such a corresponding condition handler.
{ The handler which is "covering" this "exit_control_block" performs a
{ non-local (CYBIL) exit out of its establishing procedure.
{ Other such handlers simply "continue" the condition.

          exit_control_block := condition_information;
          IF #OFFSET (exit_control_block) <> #OFFSET (function_block) THEN
            pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          IFEND;
          EXIT invoke_described_function;

        ELSE

{ --- "Continue" any other user defined condition.

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          RETURN;
        IFEND;

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

    PROCEND described_function_cond_handler;
?? TITLE := 'my_parameter_list', EJECT ??

*IF NOT $true(osv$unix)

    FUNCTION my_parameter_list: ^cell;

      VAR
        psa: ^ost$stack_frame_save_area;


      psa := #PREVIOUS_SAVE_AREA ();
      my_parameter_list := psa^.a4;

    FUNCEND my_parameter_list;
*IFEND
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

*IF NOT $true(osv$unix)
    IF ring_attributes.r2 < #RING (^converter) THEN

{ This routine must call itself at the target ring in order to process the procedure at that ring.

      converter.procedure_pointer := ^invoke_described_function;
      pmp$inward_call (converter.code_base_pointer, ring_attributes.r2, my_parameter_list (),
            #PREVIOUS_SAVE_AREA ());

{ The above call to PMP$INWARD_CALL should result in control being returned
{ directly to this procedure's caller.  The following RETURN statement is
{ here just for "safety's sake".

      RETURN;
    IFEND;

    #CALLER_ID (caller_id);

*ELSE
    caller_id.ring := osc$user_ring;
*IFEND

    NEXT function_description_contents IN library_search_info.command_or_function_module;
    IF function_description_contents = NIL THEN
      osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
      RETURN;
    IFEND;

    clp$push_function_block (caller_id.ring, name, source, parameters_parse, context_type_description,
          function_block);

    osp$establish_condition_handler (^described_function_cond_handler, FALSE);

    IF function_description_contents^.library_path_size > 0 THEN
      NEXT library_path: [function_description_contents^.library_path_size] IN
            library_search_info.command_or_function_module;
      IF library_path = NIL THEN
        osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
        RETURN;
      ELSEIF library_path^ <> 'OSF$CURRENT_LIBRARY' THEN
        clp$convert_string_to_file (library_path^, library_file, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
          RETURN;
        IFEND;
      IFEND;
      IF library_file.local_file_name = osc$null_name THEN
        clp$load_system_entry_point (function_description_contents^.starting_procedure,
              pmc$procedure_address, loaded_address, status);
      ELSE
        clp$load_from_library (function_description_contents^.starting_procedure, pmc$procedure_address,
              library_file.local_file_name, loaded_address, status);
      IFEND;
    ELSE
      pmp$load (function_description_contents^.starting_procedure, pmc$procedure_address, loaded_address,
            status);
    IFEND;

    IF status.normal THEN
      #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, loaded_function);
    IFEND;
    IF (NOT status.normal) OR (loaded_function = NIL) THEN
      osp$set_status_abnormal ('CL', cle$unable_to_call_function, name, status);
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    callers_save_area := #PREVIOUS_SAVE_AREA ();
*ELSE
    callers_save_area := NIL;
*IFEND
    invoking_function := TRUE;
    #SPOIL (callers_save_area, invoking_function);

    parameter_list.identifying_size_field := UPPERVALUE (parameter_list.identifying_size_field);

    loaded_function^ (#SEQ (parameter_list) ^, work_area, result.value, status);
    invoking_function := FALSE;
    #SPOIL (invoking_function);

    IF status.normal AND (result.value = NIL) THEN
      osp$set_status_abnormal ('CL', cle$no_function_result, name, status);
    IFEND;

  PROCEND invoke_described_function;
?? TITLE := 'invoke_scl_procedure_function', EJECT ??

  PROCEDURE invoke_scl_procedure_function
    (    name: clt$function_name;
         context_type_description: ^clt$type_description;
         source: clt$command_or_function_source;
         ring_attributes: amt$ring_attributes;
         file_id: amt$file_identifier;
         library_file: clt$file;
         library_search_info: clt$command_library_search_info;
         nested_commands_can_be_echoed: boolean;
     VAR parameters_parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: clt$function_result;
     VAR function_block: ^clt$block;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      connected_files: ^clt$connected_files,
      context_type_specification: ^clt$type_specification,
      converter: record
        case 0 .. 1 of
        = 0 =
          procedure_pointer: ^procedure
            (    name: clt$function_name;
                 context_type_description: ^clt$type_description;
                 source: clt$command_or_function_source;
                 ring_attributes: amt$ring_attributes;
                 file_id: amt$file_identifier;
                 library_file: clt$file;
                 library_search_info: clt$command_library_search_info;
                 nested_commands_can_be_echoed: boolean;
             VAR parameters_parse {input, output} : clt$parse_state;
             VAR work_area {input, output} : ^clt$work_area;
             VAR result: clt$function_result;
             VAR function_block: ^clt$block;
             VAR status: ost$status),
        = 1 =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend,
      end_proc_block: ^clt$block,
      header: ^clt$scl_procedure_header,
      interpreter_mode: clt$interpreter_modes,
      local_status: ost$status,
      parameters_work_area: ^^clt$work_area,
      proc_data: ^clt$scl_procedure;

?? NEWTITLE := 'function_procedure_cond_handler', EJECT ??

{
{ PURPOSE:
{   This condition handler duplicates most of the function_condition_handler
{   within clp$evaluate_function.  It is allows any condition that arises to be
{   processed in the ring in which the function processor runs.
{

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

      VAR
        exit_control_block: ^clt$block,
        ignore_status: ost$status,
        run_time_status: ^ost$status;


      CASE condition.selector OF

      = pmc$block_exit_processing =

{ --- Handle block exit.

        IF function_block <> NIL THEN
          clp$pop_terminated_blocks (function_block, status);
          handle_exit_from_procedure;
        IFEND;
        RETURN;

      = mmc$segment_access_condition =

{ --- Handle segment access conditions.

        osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
        IF (status.condition = cle$work_area_overflow) AND (status.text.size = 0) THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
        IFEND;
        EXIT invoke_scl_procedure_function;

      = pmc$system_conditions =

{ --- Handle system (hardware detected) conditions.

        IF pmc$detected_uncorrected_err IN condition.system_conditions THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
        osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
        EXIT invoke_scl_procedure_function;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN

{ --- Handle CYBIL run time error.

          run_time_status := condition_information;
          status := run_time_status^;
          EXIT invoke_scl_procedure_function;

        ELSEIF (condition.user_condition_name = clc$exiting_condition) AND
              (function_block <> NIL) AND function_block^.being_exited THEN

{ --- Handle exit initiated via command level EXIT statement.
{
{ This condition is raised in the task that "owns" the SCL block which is the
{ target of the EXIT statement.
{ This condition is specifically dealt with in the condition handlers that
{ cover processing of the various kinds of input, command and function blocks.
{ The condition_information for this condition is a pointer to the outermost
{ block which is being exited and has such a corresponding condition handler.
{ The handler which is "covering" this "exit_control_block" performs a
{ non-local (CYBIL) exit out of its establishing procedure.
{ Other such handlers simply "continue" the condition.

          exit_control_block := condition_information;
          IF #OFFSET (exit_control_block) <> #OFFSET (function_block) THEN
            pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          IFEND;
          EXIT invoke_scl_procedure_function;

        ELSE

{ --- "Continue" any other user defined condition.

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          RETURN;
        IFEND;

      ELSE

{ --- "Continue" any other condition.

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

    PROCEND function_procedure_cond_handler;
?? TITLE := 'handle_exit_from_procedure', EJECT ??

    PROCEDURE [INLINE] handle_exit_from_procedure;


      clp$process_exit_condition (function_block, status);

      IF function_block^.input_can_be_echoed THEN
        clp$find_connected_files (connected_files);
        IF connected_files^.echo_count > 0 THEN
          clp$echo_trace_information ('CLC$ECHO_FUNCTION_PROC_END', ^name,
                ^library_file.local_file_name, ^status, {ignore} local_status);
        IFEND;
      IFEND;

    PROCEND handle_exit_from_procedure;
?? TITLE := 'my_parameter_list', EJECT ??
*IF NOT $true(osv$unix)


    FUNCTION my_parameter_list: ^cell;

      VAR
        psa: ^ost$stack_frame_save_area;


      psa := #PREVIOUS_SAVE_AREA ();
      my_parameter_list := psa^.a4;

    FUNCEND my_parameter_list;
*IFEND
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

*IF NOT $true(osv$unix)
    IF ring_attributes.r2 < #RING (^converter) THEN

{ This routine must call itself at the target ring in order to process the procedure at that ring.

      converter.procedure_pointer := ^invoke_scl_procedure_function;
      pmp$inward_call (converter.code_base_pointer, ring_attributes.r2, my_parameter_list (),
            #PREVIOUS_SAVE_AREA ());

{ The above call to PMP$INWARD_CALL should result in control being returned
{ directly to this procedure's caller.  The following RETURN statement is
{ here just for "safety's sake".

      RETURN;
    IFEND;

    #CALLER_ID (caller_id);

*ELSE
    caller_id.ring := osc$user_ring;
*IFEND

    IF context_type_description = NIL THEN
      context_type_specification := NIL;
    ELSE
      clp$convert_type_desc_to_spec (context_type_description, work_area, context_type_specification,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    proc_data := library_search_info.command_or_function_module;
    IF proc_data = NIL THEN
      header := NIL;
    ELSE
      RESET proc_data;
      NEXT header IN proc_data;
      IF header <> NIL THEN
        proc_data := #PTR (header^.procedure_body, proc_data^);
      IFEND;
      RESET proc_data;
    IFEND;

    clp$get_interpreter_mode (interpreter_mode);

    clp$push_function_proc_block (caller_id.ring, name, source,
          nested_commands_can_be_echoed AND (interpreter_mode <> clc$help_mode),
          library_file.local_file_name, file_id, proc_data, context_type_specification, function_block);

    osp$establish_condition_handler (^function_procedure_cond_handler, TRUE);

    IF function_block^.input_can_be_echoed THEN
      clp$find_connected_files (connected_files);
      IF connected_files^.echo_count > 0 THEN
        clp$echo_trace_information ('CLC$ECHO_FUNCTION_PROC_BEGIN', ^name,
              ^library_file.local_file_name, NIL, {ignore} local_status);
      IFEND;
    IFEND;

    IF status.normal THEN
*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^parameters_work_area), parameters_work_area, status);
*ELSE
      clp$get_work_area (osc$user_ring, parameters_work_area, status);
*IFEND
      IF status.normal THEN
        clp$process_proc_parameters (clc$function, library_search_info.command_or_function_module, header,
              function_block^.input_can_be_echoed, parameters_parse, parameters_work_area^, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      clp$process_command_file (function_block, NIL, status);

      IF status.normal AND (function_block^.function_proc_result <> NIL) THEN
        clp$convert_int_value_to_ext (function_block^.function_proc_result,
              function_block^.function_proc_result^.header.value, work_area, result.value, status);
      IFEND;
    IFEND;

    IF status.normal AND (NOT function_block^.being_exited) THEN
      clp$find_current_block (end_proc_block);
      IF end_proc_block <> function_block THEN
        osp$set_status_abnormal ('CL', cle$unbalanced_block_structure, function_block^.kind_end_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, end_proc_block^.kind_end_name,
              status);
      IFEND;
    IFEND;

    handle_exit_from_procedure;

    osp$disestablish_cond_handler;

    clp$pop_input_stack (end_proc_block, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

    IF status.normal AND (result.value = NIL) THEN
      osp$set_status_abnormal ('CL', cle$no_function_result, name, status);
    IFEND;

  PROCEND invoke_scl_procedure_function;
*IFEND

MODEND clm$function_manager;
*DECK DECK=CLM$F_BLOCK_STACK_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Block Stack Manager' ??
MODULE clm$f_block_stack_manager;

{
{ PURPOSE:
{   This module contains the procedures that manage the Block stack which is used to keep track of the
{   current state of the SCL formatter blocks.
{

?? NEWTITLE := 'Global Declarations' ??
?? NEWTITLE := 'Block Stack', EJECT ??
*copyc clt$f_block
?? OLDTITLE, EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_control_statement
*copyc cle$ecc_miscellaneous
*copyc ose$heap_full_exceptions
*copyc oss$job_paged_literal
*copyc ost$status
?? SKIP := 3 ??

{
{ PURPOSE:
{   The following procedure exists solely to provide a "shelter" for the
{   declarations contained in certain decks that are *COPYC'd into this
{   deck.  For example, this module defines an XDCL'd variable that is
{   referenced by an INLINE procedure.  In order to make the deck containing
{   the INLINE procedure "self-contained" it *COPYCs the deck containing the
{   XREF declaration of the variable.  Since the INLINE procedure is needed
{   in this module, both the XDCL and XREF declaration will appear in this
{   module.  The following "dummy" procedure is used to hide the XREF
{   declaration of the variable form the rest of the module.
{

  PROCEDURE [INLINE] dummy;

*copyc clp$f_find_task_block_1st_time
*copyc clv$f_current_task_block

  PROCEND dummy;
?? SKIP := 3 ??
?? POP ??
*copyc clp$f_find_current_block
*copyc clp$f_find_task_block
*copyc clp$f_output_line_number
*copyc clp$f_set_command_header_type
*copyc osp$append_status_parameter
*copyc osp$generate_message
*copyc osp$set_status_abnormal
*copyc pmp$abort
*copyc pmp$exit

?? TITLE := 'clv$f_current_task_block', EJECT ??

{
{ PURPOSE:
{   This variable contains the pointer to the clc$task_block for the current task.
{   It is initialized by clp$f_find_task_block_1st_time (see below).
{

  VAR
    clv$f_current_task_block: [XDCL, #GATE] ^clt$f_block := NIL;

?? TITLE := 'clp$f_find_task_block_1st_time', EJECT ??

{
{ PURPOSE:
{   This procedure is called the first time in a task that the task's clc$task_block is needed.
{   It is only called by clp$f_find_task_block.
{   If the task list is empty, then this procedure assumes it is being called within the job monitor task
{   for a job and creates a task block for itself and initializes the task list to contain that block.
{

  PROCEDURE [XDCL, #GATE] clp$f_find_task_block_1st_time
    (VAR task_block: ^clt$f_block;
     VAR status: ost$status);

    VAR
      ignore_task_link: ^^clt$f_block;

    status.normal := TRUE;
    IF clv$f_current_task_block = NIL THEN
      create_block (clc$task_block, FALSE, osc$null_name, NIL, clv$f_current_task_block, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    clv$f_current_task_block^.current_block := clv$f_current_task_block;
    task_block := clv$f_current_task_block;

  PROCEND clp$f_find_task_block_1st_time;
?? TITLE := 'clp$f_push_block_stack', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$f_push_block_stack
    (    block_kind: clt$block_kind;
         block_label: ost$name;
     VAR current_block: ^clt$f_block);

    VAR
      task_block: ^clt$f_block,
      block: ^clt$f_block,
      status: ost$status;

    IF (block_kind < LOWERVALUE (clt$block_kind)) OR (block_kind > UPPERVALUE (clt$block_kind)) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$f_push_block_stack', status);
      pmp$abort (status);
    IFEND;

    clp$f_find_task_block (task_block, status);
    IF NOT status.normal THEN
      pmp$abort (status);
    IFEND;

    create_block (block_kind, TRUE, block_label, task_block, block, status);
    IF NOT status.normal THEN
      pmp$abort (status);
    IFEND;

    IF (block_kind <> clc$utility_block) AND (block_kind <> clc$var_block) THEN
      clp$f_set_command_header_type (clc$control_statement_begin);
      IF block_kind = clc$if_block THEN
        block^.if_else_allowed := TRUE;
      IFEND;
    IFEND;

    task_block^.current_block := block;
    current_block := block;

  PROCEND clp$f_push_block_stack;
?? TITLE := 'create_block', EJECT ??

  PROCEDURE create_block
    (    block_kind: clt$block_kind;
         synchronous_with_parent: boolean;
         block_label: ost$name;
         task_block: ^clt$f_block;
     VAR new_block: ^clt$f_block;
     VAR status: ost$status);

    VAR
      block_kind_names: [STATIC, READ, oss$job_paged_literal] array [clt$block_kind] of string (14) :=
            ['BLOCK', 'command', 'FOR', 'JOB', 'LOGIN', 'PIPE', 'TASK', 'UTILITY', 'IF', 'input', 'LOOP',
            'PROC', 'REPEAT', 'sub_parameters', 'task', 'utility', 'VAR', 'WHEN', 'WHILE'],
      block_kind_end_names: [STATIC, READ, oss$job_paged_literal] array [clt$block_kind] of string (18) :=
            ['BLOCKEND', 'command_end', 'FOREND', 'JOBEND', 'LOGOUT', 'PIPEND', 'TASKEND', 'UTILITYEND',
            'IFEND', 'end_of_input', 'LOOPEND', 'PROCEND', 'UNTIL', 'sub_parameters_end', 'end_of_task',
            'end_of_utility', 'VAREND', 'WHENEND', 'WHILEND'],
      var_block: ^clt$f_block,
      input_block: ^clt$f_block;

    status.normal := TRUE;
    ALLOCATE new_block: [block_kind];
    IF new_block = NIL THEN
      osp$set_status_abnormal ('CL', ose$task_shared_full, 'Block Stack', status);
      RETURN;
    IFEND;

    IF task_block <> NIL THEN
      new_block^.previous_block := task_block^.current_block;
    ELSE
      new_block^.previous_block := NIL;
      new_block^.interpreter_mode := clc$interpret_mode;
      input_block := NIL;
    IFEND;

    new_block^.output_line_number := clp$f_output_line_number ();
    new_block^.label := block_label;
    new_block^.kind_name := block_kind_names [block_kind];
    new_block^.kind_end_name := block_kind_end_names [block_kind];

  PROCEND create_block;
?? TITLE := 'clp$f_pop_block_stack', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$f_pop_block_stack
    (VAR current_block: ^clt$f_block);

    VAR
      issued_waiting_message: boolean,
      task_block: ^clt$f_block,
      old_block: ^clt$f_block,
      status: ost$status,
      ignore_status: ost$status,
      ignore_ready_index: integer;

    clp$f_find_task_block (task_block, status);
    IF NOT status.normal THEN
      pmp$abort (status);
    ELSEIF task_block^.current_block = task_block THEN
      RETURN;
    IFEND;
    old_block := task_block^.current_block^.previous_block;

    IF (task_block^.current_block^.kind <> clc$utility_block) AND
          (task_block^.current_block^.kind <> clc$var_block) THEN
      clp$f_set_command_header_type (clc$control_statement_end);
    IFEND;
    free_block (task_block^.current_block);

    task_block^.current_block := old_block;
    current_block := old_block;

  PROCEND clp$f_pop_block_stack;
?? TITLE := 'free_block', EJECT ??

  PROCEDURE free_block
    (VAR block {input} : ^clt$f_block);


    FREE block;

  PROCEND free_block;
?? TITLE := 'clp$f_find_cycle_block', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$f_find_cycle_block
    (    target_label: ost$name;
     VAR current_block: ^clt$f_block;
     VAR target_block: ^clt$f_block;
     VAR status: ost$status);

    status.normal := TRUE;
    clp$f_find_current_block (current_block);
    target_block := current_block;

  /find_block_to_be_cycled/
    WHILE target_block <> NIL DO
      CASE target_block^.kind OF
      = clc$block_block, clc$var_block =
        IF (target_label <> '') AND (target_label = target_block^.label) THEN
          osp$set_status_abnormal ('CL', cle$statement_cant_be_cycled, 'BLOCK', status);
          RETURN;
        IFEND;
      = clc$for_block, clc$loop_block, clc$repeat_block, clc$while_block =
        IF (target_label = '') OR (target_label = target_block^.label) THEN
          RETURN;
        IFEND;
      = clc$if_block =
        ;
      ELSE
        target_block := NIL;
        EXIT /find_block_to_be_cycled/;
      CASEND;
      target_block := target_block^.previous_block;
    WHILEND /find_block_to_be_cycled/;
    IF target_block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'CYCLE', status);
      IF target_label <> '' THEN
        osp$append_status_parameter (' ', target_label, status);
      IFEND;
      RETURN;
    IFEND;

  PROCEND clp$f_find_cycle_block;

MODEND clm$f_block_stack_manager;
*DECK DECK=CLM$F_CONTROL_STATEMENTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Control Statement Processors' ??
MODULE clm$f_control_statements;

{
{ PURPOSE:
{   This module contains the processors for the SCL control statements.  Also, it contains the procedure
{   and table used to search for a control statement or control command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc clc$standard_file_names
*copyc cld$parameter_list
*copyc cle$ecc_command_processing
*copyc cle$ecc_control_statement
*copyc cle$ecc_expression
*copyc cle$ecc_expression_result
*copyc cle$ecc_miscellaneous
*copyc clt$command_processor
*copyc clt$f_control_statement
*copyc clt$f_control_statement_desc
*copyc clt$interpreter_modes
*copyc clt$lexical_unit_kinds
*copyc clt$name
*copyc clt$when_conditions
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc clp$add_format_token
*copyc clp$append_status_parse_state
*copyc clp$f_expression_scanner
*copyc clp$f_find_current_block
*copyc clp$f_find_cycle_block
*copyc clp$f_note_unended_block
*copyc clp$f_pop_block_stack
*copyc clp$f_process_collect_text
*copyc clp$f_process_proc_header
*copyc clp$f_process_task_or_job
*copyc clp$f_process_var_or_type
*copyc clp$f_push_block_stack
*copyc clp$f_scan_parameter_list
*copyc clp$f_scan_token
*copyc clp$f_set_command_header_type
*copyc clp$f_set_substitution_mark
*copyc clp$initialize_parse_state
*copyc clp$search_format_utilities
*copyc clp$set_format_type
*copyc clp$trimmed_string_size
*copyc clv$formatting_in_effect
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper

?? TITLE := 'Control Statements and Commands', EJECT ??

  CONST
    number_of_control_names = 61,
    min_control_name_size = 2 {IF} ,
    max_control_name_size = 31 {CREATE_PARAMETER_PROMPT_MESSAGE} ;

  VAR
    save_format_flag: boolean;

  VAR
    control_statements: [STATIC, READ, oss$job_paged_literal] array [1 .. number_of_control_names] of record
      name: string (max_control_name_size),
      descriptor: clt$f_control_statement_desc,
    recend := [
          {} ['BLOCK                          ', [TRUE, clc$control_statement, TRUE, ^clp$block_statement]],
          {} ['BLOCKEND                       ', [TRUE, clc$control_statement, FALSE,
          ^clp$blockend_statement]],
          {} ['CANCEL                         ', [FALSE, clc$control_statement, FALSE,
          ^clp$cancel_statement]],
          {} ['CAUSE                          ', [FALSE, clc$control_statement, FALSE, ^clp$cause_statement]],
          {} ['COLLECT_TEXT                   ', [TRUE, clc$control_command, ^clp$collect_text_command]],
          {} ['COLT                           ', [TRUE, clc$control_command, ^clp$collect_text_command]],
          {} ['CONTINUE                       ', [FALSE, clc$control_statement, FALSE,
          ^clp$continue_statement]],
          {} ['CREATE_BRIEF_HELP_MESSAGE      ', [TRUE, clc$control_command, ^clp$crebhm]],
          {} ['CREATE_FULL_HELP_MESSAGE       ', [TRUE, clc$control_command, ^clp$crefhm]],
          {} ['CREATE_PARAMETER_ASSIST_MESSAGE', [TRUE, clc$control_command, ^clp$crepam]],
          {} ['CREATE_PARAMETER_HELP_MESSAGE  ', [TRUE, clc$control_command, ^clp$crephm]],
          {} ['CREATE_PARAMETER_PROMPT_MESSAGE', [TRUE, clc$control_command, ^clp$creppm]],
          {} ['CREATE_STATUS_MESSAGE          ', [TRUE, clc$control_command, ^clp$cresm]],
          {} ['CREBHM                         ', [TRUE, clc$control_command, ^clp$crebhm]],
          {} ['CREFHM                         ', [TRUE, clc$control_command, ^clp$crefhm]],
          {} ['CREPAM                         ', [TRUE, clc$control_command, ^clp$crepam]],
          {} ['CREPHM                         ', [TRUE, clc$control_command, ^clp$crephm]],
          {} ['CREPPM                         ', [TRUE, clc$control_command, ^clp$creppm]],
          {} ['CRESM                          ', [TRUE, clc$control_command, ^clp$cresm]],
          {} ['CYCLE                          ', [FALSE, clc$control_statement, FALSE, ^clp$cycle_statement]],
          {} ['ELSE                           ', [TRUE, clc$control_statement, FALSE, ^clp$else_statement]],
          {} ['ELSEIF                         ', [TRUE, clc$control_statement, FALSE, ^clp$elseif_statement]],
          {} ['EXIT                           ', [FALSE, clc$control_statement, FALSE, ^clp$exit_statement]],
          {} ['EXIT_PROC                      ', [FALSE, clc$control_statement, FALSE,
          ^clp$exit_proc_statement]],
          {} ['FOR                            ', [TRUE, clc$control_statement, TRUE, ^clp$for_statement]],
          {} ['FOREND                         ', [TRUE, clc$control_statement, FALSE, ^clp$forend_statement]],
          {} ['FUNCEND                        ', [TRUE, clc$control_statement, FALSE,
          ^clp$procend_statement]],
          {} ['FUNCTION                       ', [TRUE, clc$control_statement, FALSE, ^clp$proc_statement]],
          {} ['IF                             ', [TRUE, clc$control_statement, FALSE, ^clp$if_statement]],
          {} ['IFEND                          ', [TRUE, clc$control_statement, FALSE, ^clp$ifend_statement]],
          {} ['JOB                            ', [TRUE, clc$control_command, ^clp$job_statement]],
          {} ['JOBEND                         ', [TRUE, clc$control_statement, FALSE, ^clp$jobend_statement]],
          {} ['LOGIN                          ', [FALSE, clc$control_command, ^clp$login_command]],
          {} ['LOGOUT                         ', [FALSE, clc$control_command, ^clp$logout_command]],
          {} ['LOOP                           ', [TRUE, clc$control_statement, TRUE, ^clp$loop_statement]],
          {} ['LOOPEND                        ', [TRUE, clc$control_statement, FALSE,
          ^clp$loopend_statement]],
          {} ['MANAGE_REMOTE_FILES            ', [TRUE, clc$control_command, ^clp$manrf_command]],
          {} ['MANRF                          ', [TRUE, clc$control_command, ^clp$manrf_command]],
          {} ['PDT                            ', [TRUE, clc$control_statement, FALSE, ^clp$proc_statement]],
          {} ['PIPE                           ', [TRUE, clc$control_statement, FALSE, ^clp$pipe_statement]],
          {} ['PIPEND                         ', [TRUE, clc$control_statement, FALSE, ^clp$pipend_statement]],
          {} ['POP                            ', [FALSE, clc$control_statement, FALSE, ^clp$push_statement]],
          {} ['PROC                           ', [TRUE, clc$control_statement, FALSE, ^clp$proc_statement]],
          {} ['PROCEDURE                      ', [TRUE, clc$control_statement, FALSE, ^clp$proc_statement]],
          {} ['PROCEND                        ', [TRUE, clc$control_statement, FALSE,
          ^clp$procend_statement]],
          {} ['PUSH                           ', [FALSE, clc$control_statement, FALSE, ^clp$push_statement]],
          {} ['PUSH_COMMANDS                  ', [FALSE, clc$control_statement, FALSE, ^clp$push_commands]],
          {} ['REPEAT                         ', [TRUE, clc$control_statement, TRUE, ^clp$repeat_statement]],
          {} ['TASK                           ', [TRUE, clc$control_command, ^clp$task_statement]],
          {} ['TASKEND                        ', [TRUE, clc$control_statement, FALSE,
          ^clp$taskend_statement]],
          {} ['TYPE                           ', [TRUE, clc$control_statement, FALSE, ^clp$type_statement]],
          {} ['TYPEND                         ', [TRUE, clc$control_statement, FALSE, ^clp$typend_statement]],
          {} ['UNTIL                          ', [TRUE, clc$control_statement, FALSE, ^clp$until_statement]],
          {} ['UTILITY                        ', [TRUE, clc$control_command, ^clp$utility_statement]],
          {} ['UTILITYEND                     ', [TRUE, clc$control_statement, FALSE,
          ^clp$utilityend_statement]],
          {} ['VAR                            ', [TRUE, clc$control_statement, FALSE, ^clp$var_statement]],
          {} ['VAREND                         ', [TRUE, clc$control_statement, FALSE, ^clp$varend_statement]],
          {} ['WHEN                           ', [TRUE, clc$control_statement, FALSE, ^clp$when_statement]],
          {} ['WHENEND                        ', [TRUE, clc$control_statement, FALSE,
          ^clp$whenend_statement]],
          {} ['WHILE                          ', [TRUE, clc$control_statement, TRUE, ^clp$while_statement]],
          {} ['WHILEND                        ', [TRUE, clc$control_statement, FALSE,
          ^clp$whilend_statement]]];

?? TITLE := 'clp$f_check_name_for_control', EJECT ??

  PROCEDURE [XDCL] clp$f_check_name_for_control
    (    name: clt$name;
     VAR control_statement_descriptor: ^clt$f_control_statement_desc);

    VAR
      current_index: 1 .. number_of_control_names,
      low_index: 1 .. number_of_control_names + 1,
      temp: integer,
      high_index: 0 .. number_of_control_names;

    IF (min_control_name_size <= name.size) AND (name.size <= max_control_name_size) THEN
      low_index := 1;
      high_index := UPPERBOUND (control_statements);
      REPEAT
        temp := low_index + high_index;
        current_index := temp DIV 2;
        IF name.value (1, max_control_name_size) = control_statements [current_index].name THEN
          control_statement_descriptor := ^control_statements [current_index].descriptor;
          RETURN;
        ELSEIF name.value (1, max_control_name_size) > control_statements [current_index].name THEN
          low_index := current_index + 1;
        ELSE
          high_index := current_index - 1;
        IFEND;
      UNTIL low_index > high_index;
    IFEND;

    control_statement_descriptor := NIL;

    clp$search_format_utilities (name, control_statement_descriptor);

  PROCEND clp$f_check_name_for_control;
?? TITLE := 'clp$collect_text_command', EJECT ??

  PROCEDURE clp$collect_text_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    clp$f_scan_parameter_list (parameter_list, status);
    IF status.normal THEN
      clp$f_process_collect_text ('COLLECT_TEXT', status);
    IFEND;

  PROCEND clp$collect_text_command;
?? TITLE := 'clp$crebhm', EJECT ??

  PROCEDURE clp$crebhm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    clp$f_scan_parameter_list (parameter_list, status);
    IF status.normal THEN
      clp$f_process_collect_text ('CREATE_BRIEF_HELP_MESSAGE', status);
    IFEND;

  PROCEND clp$crebhm;
?? TITLE := 'clp$crefhm', EJECT ??

  PROCEDURE clp$crefhm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    clp$f_scan_parameter_list (parameter_list, status);
    IF status.normal THEN
      clp$f_process_collect_text ('CREATE_FULL_HELP_MESSAGE', status);
    IFEND;

  PROCEND clp$crefhm;
?? TITLE := 'clp$creppm', EJECT ??

  PROCEDURE clp$creppm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    clp$f_scan_parameter_list (parameter_list, status);
    IF status.normal THEN
      clp$f_process_collect_text ('CREATE_PARAMETER_PROMPT_MESSAGE', status);
    IFEND;

  PROCEND clp$creppm;
?? TITLE := 'clp$crepam', EJECT ??

  PROCEDURE clp$crepam
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    clp$f_scan_parameter_list (parameter_list, status);
    IF status.normal THEN
      clp$f_process_collect_text ('CREATE_PARAMETER_ASSIST_MESSAGE', status);
    IFEND;

  PROCEND clp$crepam;
?? TITLE := 'clp$crephm', EJECT ??

  PROCEDURE clp$crephm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    clp$f_scan_parameter_list (parameter_list, status);
    IF status.normal THEN
      clp$f_process_collect_text ('CREATE_PARAMETER_HELP_MESSAGE', status);
    IFEND;

  PROCEND clp$crephm;
?? TITLE := 'clp$cresm', EJECT ??

  PROCEDURE clp$cresm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    clp$f_scan_parameter_list (parameter_list, status);
    IF status.normal THEN
      clp$f_process_collect_text ('CREATE_STATUS_MESSAGE', status);
    IFEND;

  PROCEND clp$cresm;
?? TITLE := 'clp$manrf_command', EJECT ??

  PROCEDURE clp$manrf_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    clp$f_scan_parameter_list (parameter_list, status);
    IF status.normal THEN
      clp$f_process_collect_text ('MANAGE_REMOTE_FILES', status);
    IFEND;

  PROCEND clp$manrf_command;
?? TITLE := 'clp$login_command', EJECT ??

  PROCEDURE clp$login_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      label: ost$name,
      log_block: ^clt$f_block;

    label := '';
    clp$f_set_command_header_type (clc$control_statement_begin);
    clp$f_push_block_stack (clc$formatter_log_block, label, log_block);
    clp$f_scan_parameter_list (parameter_list, status);

  PROCEND clp$login_command;
?? TITLE := 'clp$logout_command', EJECT ??

  PROCEDURE clp$logout_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      log_block: ^clt$f_block;

    status.normal := TRUE;
    check_statement_terminator ('LOGOUT', clc$formatter_log_block, '', log_block, status);
    IF (NOT status.normal) AND (status.condition = cle$unexpected_control_statemnt) THEN
      status.normal := TRUE;
      RETURN;
    IFEND;
    clp$f_pop_block_stack (log_block);
    clp$f_scan_parameter_list (parameter_list, status);

  PROCEND clp$logout_command;
?? TITLE := 'evaluate_boolean_expression', EJECT ??

  PROCEDURE evaluate_boolean_expression
    (VAR parse {input, output} : clt$parse_state;
         optional_termination_name: string ( * <= osc$max_name_size);
     VAR result: boolean;
     VAR status: ost$status);

    VAR
      boolean_value_specifier: [STATIC, READ, oss$job_paged_literal] clt$value_kind_specifier :=
            [NIL, clc$boolean_value],
      space: [STATIC] string (1) := ' ',
      terminator_name: ost$name,
      value: clt$value;


    IF optional_termination_name <> '' THEN
      clp$f_expression_scanner (boolean_value_specifier, TRUE, parse, value, status);
    ELSE
      clp$f_expression_scanner (boolean_value_specifier, FALSE, parse, value, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    result := value.bool.value;

    IF parse.unit_is_space THEN
      clp$f_scan_token (clc$slu_non_space, parse);
    IFEND;

    CASE parse.unit.kind OF
    = clc$lex_end_of_line =
      IF optional_termination_name <> '' THEN
        clp$add_format_token (^space, clc$lex_space, clc$unassigned);
        clp$add_format_token (^optional_termination_name, clc$lex_name, clc$reserved_name);
      IFEND;
      RETURN;
    = clc$lex_name =
      ;
    = clc$lex_long_name =
      osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
            status);
      RETURN;
    ELSE
      osp$set_status_abnormal ('CL', cle$unexpected_after_bool_expr, '', status);
      RETURN;
    CASEND;

    IF (NOT parse.previous_unit_is_space) OR (optional_termination_name = '') THEN
      osp$set_status_abnormal ('CL', cle$unexpected_after_bool_expr, '', status);
      RETURN;
    IFEND;

    #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), terminator_name);

    IF optional_termination_name <> terminator_name THEN
      osp$set_status_abnormal ('CL', cle$unexpected_after_bool_expr, terminator_name, status);
      RETURN;
    IFEND;

    clp$set_format_type (clc$reserved_name);

    clp$f_scan_token (clc$slu_non_space, parse);

    IF parse.unit.kind <> clc$lex_end_of_line THEN
      osp$set_status_abnormal ('CL', cle$unexpected_after_then_or_do, optional_termination_name, status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      RETURN;
    IFEND;

  PROCEND evaluate_boolean_expression;
?? TITLE := 'check_statement_terminator', EJECT ??

  PROCEDURE check_statement_terminator
    (    statement_name: string ( * );
         block_kind: clt$block_kind;
         parameters: string ( * );
     VAR statement_block: ^clt$f_block;
     VAR status: ost$status);

    VAR
      block_count: integer,
      block_exists: boolean,
      space: [STATIC] string (1) := ' ',
      temp_block: ^clt$f_block,
      terminator_name: ost$name,
      parse: clt$parse_state;

    status.normal := TRUE;
    clp$f_find_current_block (statement_block);
    temp_block := statement_block;
    block_exists := FALSE;
    block_count := 0;

  /find_block/
    WHILE temp_block <> NIL DO
      IF temp_block^.kind = block_kind THEN
        block_exists := TRUE;
        EXIT /find_block/;
      IFEND;
      block_count := block_count + 1;
      temp_block := temp_block^.previous_block;
    WHILEND /find_block/;

    IF block_exists THEN
      IF block_count > 0 THEN
        clp$f_note_unended_block (block_count, statement_block, status);
      IFEND; {block_count > 0
    ELSE {block doesnt exist
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, statement_name, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);
    IF parse.unit.kind <> clc$lex_end_of_line THEN
      IF parse.unit.kind = clc$lex_name THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), terminator_name);
        IF terminator_name <> statement_block^.label THEN
          osp$set_status_abnormal ('CL', cle$wrong_statement_label, statement_name, status);
        ELSE
          clp$f_scan_token (clc$slu_non_space, parse);
          IF parse.unit.kind <> clc$lex_end_of_line THEN
            osp$set_status_abnormal ('CL', cle$unexpected_after_end_label, '', status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, statement_name, status);
          IFEND;
        IFEND;
      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_label, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, statement_name, status);
      IFEND;
    ELSEIF status.normal AND (statement_block^.label <> osc$null_name) THEN
      clp$add_format_token (^space, clc$lex_space, clc$unassigned);
      clp$add_format_token (^statement_block^.label (1, clp$trimmed_string_size (statement_block^.label)),
            clc$lex_name, clc$unassigned);
    IFEND;

  PROCEND check_statement_terminator;
?? TITLE := 'process_when_clause', EJECT ??

  PROCEDURE process_when_clause
    (    statement_name: string ( * <= osc$max_name_size);
     VAR parse {input, output} : clt$parse_state;
     VAR when_condition: boolean;
     VAR status: ost$status);


    status.normal := TRUE;
    clp$set_format_type (clc$reserved_name);
    clp$f_scan_token (clc$slu_any, parse);
    IF NOT parse.previous_unit_is_space THEN
      osp$set_status_abnormal ('CL', cle$unexpected_after_when, '', status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, statement_name, status);
    IFEND;

    evaluate_boolean_expression (parse, '', when_condition, status);

  PROCEND process_when_clause;
?? TITLE := 'process_exit_and_cycle_label', EJECT ??

  PROCEDURE process_exit_and_cycle_label
    (    statement_name: string ( * <= osc$max_name_size);
         parameters: ^string ( * );
     VAR parse: clt$parse_state;
     VAR target_label: ost$name;
     VAR following_clause_name: ost$name;
     VAR status: ost$status);


    VAR

      block_label_matched: boolean,
      temp_block: ^clt$f_block;

    block_label_matched := FALSE;
    status.normal := TRUE;
    target_label := '';
    following_clause_name := '';

    clp$initialize_parse_state (parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);

    CASE parse.unit.kind OF
    = clc$lex_end_of_line =
      RETURN;
    = clc$lex_long_name =
      osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
            status);
      RETURN;
    = clc$lex_name =
      ;
    ELSE
      IF statement_name = 'EXIT' THEN
        osp$set_status_abnormal ('CL', cle$expecting_label_when_with, '', status);
      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_label_or_when, '', status);
      IFEND;
      RETURN;
    CASEND;

    #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), following_clause_name);
    IF (following_clause_name = 'WHEN') OR ((following_clause_name = 'WITH') AND (statement_name = 'EXIT'))
          THEN
      RETURN;
    IFEND;

    target_label := following_clause_name;

    IF (target_label <> ' ') AND (target_label(1,parse.unit.size) <> 'PROCEDURE')
          AND (target_label(1,parse.unit.size) <> 'PROC') AND (target_label(1,parse.unit.size) <> 'UTILITY')
          AND (target_label(1,parse.unit.size) <> 'FUNCTION') THEN
      clp$f_find_current_block(temp_block);
      /find_block/
        WHILE temp_block <> NIL DO
          IF (temp_block^.label = target_label) THEN
            block_label_matched := TRUE;
            EXIT /find_block/;
          IFEND;
          temp_block := temp_block^.previous_block;
        WHILEND /find_block/;
      IF (NOT block_label_matched) then
        osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt,target_label, status);
        RETURN;
      IFEND;
    IFEND;

    clp$f_scan_token (clc$slu_non_space, parse);

    CASE parse.unit.kind OF
    = clc$lex_end_of_line =
      RETURN;
    = clc$lex_long_name =
      osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
            status);
      RETURN;
    = clc$lex_name =
      ;
    ELSE
      IF statement_name = 'EXIT' THEN
        osp$set_status_abnormal ('CL', cle$expecting_with_or_when, '', status);
      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_cycle_when, '', status);
      IFEND;
      RETURN;
    CASEND;

    #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), following_clause_name);
    IF (following_clause_name = 'WHEN') OR ((following_clause_name = 'WITH') AND (statement_name = 'EXIT'))
          THEN
      RETURN;
    IFEND;

    IF statement_name = 'EXIT' THEN
      osp$set_status_abnormal ('CL', cle$expecting_with_or_when, '', status);
    ELSE
      osp$set_status_abnormal ('CL', cle$expecting_cycle_when, '', status);
    IFEND;

  PROCEND process_exit_and_cycle_label;
?? TITLE := 'clp$cycle_statement', EJECT ??

  PROCEDURE clp$cycle_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      clause_name: ost$name,
      for_variable: clt$variable_reference,
      for_value: array [1 .. 1] of clt$integer,
      current_block: ^clt$f_block,
      parse: clt$parse_state,
      target_block: ^clt$f_block,
      target_label: ost$name,
      cycle_condition: boolean;

    status.normal := TRUE;
    process_exit_and_cycle_label ('CYCLE', ^parameters, parse, target_label, clause_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$f_find_cycle_block (target_label, current_block, target_block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$f_set_command_header_type (clc$control_statement_no_switch);

    IF clause_name = 'WHEN' THEN
      process_when_clause ('CYCLE', parse, cycle_condition, status);
      IF NOT status.normal THEN
        RETURN;
      ELSEIF parse.unit.kind <> clc$lex_end_of_line THEN
        osp$set_status_abnormal ('CL', cle$unexpected_after_bool_expr, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        RETURN;
      ELSEIF NOT cycle_condition THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND clp$cycle_statement;
?? TITLE := 'clp$exit_statement', EJECT ??

  PROCEDURE clp$exit_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      parse: clt$parse_state,
      initial_clause_name: ost$name,
      target_label: ost$name,
      exit_condition: boolean;

    status.normal := TRUE;
    process_exit_and_cycle_label ('EXIT', ^parameters, parse, target_label, initial_clause_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    exit_statement (target_label, initial_clause_name, parse, status);

  PROCEND clp$exit_statement;
?? TITLE := 'exit_statement', EJECT ??

  PROCEDURE exit_statement
    (    target_label: ost$name,
         initial_clause_name: ost$name;
     VAR parse {input, output} : clt$parse_state;
     VAR status: ost$status);


?? NEWTITLE := 'process_with_clause', EJECT ??

    PROCEDURE process_with_clause;

      VAR
        status_value_specifier: [STATIC, READ, oss$job_paged_literal] clt$value_kind_specifier :=
              [NIL, clc$status_value],
        value: clt$value;


      clp$f_scan_token (clc$slu_non_space, parse);
      IF NOT parse.previous_unit_is_space THEN
        osp$set_status_abnormal ('CL', cle$unexpected_after_with, '', status);
        EXIT exit_statement;
      IFEND;

      clp$f_expression_scanner (status_value_specifier, TRUE, parse, value, status);
      IF NOT status.normal THEN
        IF (clc$min_ecc_expression_result <= status.condition) AND
              (status.condition <= clc$max_ecc_expression_result) THEN
          osp$append_status_parameter (osc$status_parameter_delimiter,
                ' for WITH value of EXIT PROC statement', status);
        IFEND;
        EXIT exit_statement;
      IFEND;

      CASE parse.unit.kind OF
      = clc$lex_end_of_line =
        RETURN;
      = clc$lex_name =
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$unexpected_after_with_value, '', status);
          RETURN;
        IFEND;
      = clc$lex_long_name =
        osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
              status);
        RETURN;
      ELSE
        osp$set_status_abnormal ('CL', cle$unexpected_after_with_value, '', status);
        RETURN;
      CASEND;

    PROCEND process_with_clause;
?? OLDTITLE, EJECT ??

    VAR
      clause_name: ost$name,
      error_condition: ost$status_condition_code,
      exit_condition: boolean,
      target_block: ^clt$f_block,
      terminating_utility: boolean,
      unexpected_condition: ost$status_condition_code,
      when_clause_specified: boolean,
      with_clause_allowed: boolean,
      with_clause_specified: boolean;


    IF (target_label = '') OR (target_label = 'UTILITY') OR (target_label = 'PROCEDURE') OR (target_label =
          'PROC') OR (target_label = 'FUNCTION') OR (target_label = 'FUNC') OR (target_label = 'CHECK') THEN
      clp$set_format_type (clc$reserved_name);
    IFEND;

    clause_name := initial_clause_name;
    when_clause_specified := FALSE;
    with_clause_specified := FALSE;

    clp$f_set_command_header_type (clc$control_statement_no_switch);

  /process_exit_parameters/
    WHILE parse.unit.kind <> clc$lex_end_of_line DO

      IF clause_name = 'WITH' THEN
        clp$set_format_type (clc$reserved_name);
        IF with_clause_specified THEN
          osp$set_status_abnormal ('CL', cle$duplicate_with_clause, '', status);
          RETURN;
        IFEND;
        with_clause_specified := TRUE;
        process_with_clause;
        unexpected_condition := cle$unexpected_after_with_value;
        error_condition := 0;

      ELSEIF clause_name = 'WHEN' THEN
        clp$set_format_type (clc$reserved_name);
        IF when_clause_specified THEN
          osp$set_status_abnormal ('CL', cle$duplicate_when_clause, '', status);
          RETURN;
        IFEND;
        when_clause_specified := TRUE;
        process_when_clause ('EXIT', parse, exit_condition, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        unexpected_condition := cle$unexpected_after_when_value;
        error_condition := 0;

      ELSEIF with_clause_specified THEN
        IF when_clause_specified THEN
          error_condition := unexpected_condition;
        ELSE
          error_condition := cle$expecting_exit_when;
        IFEND;
      ELSEIF when_clause_specified THEN
        error_condition := cle$expecting_with;
      ELSE
        error_condition := cle$expecting_with_or_when;
      IFEND;

      IF error_condition <> 0 THEN
        osp$set_status_abnormal ('CL', error_condition, '', status);
        RETURN;
      IFEND;

      IF parse.unit.kind = clc$lex_name THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);
      IFEND;

    WHILEND /process_exit_parameters/;

    IF NOT exit_condition THEN
      RETURN;
    IFEND;

  PROCEND exit_statement;
?? TITLE := 'clp$exit_proc_statement', EJECT ??

  PROCEDURE clp$exit_proc_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      status_value_specifier: [STATIC, READ, oss$job_paged_literal] clt$value_kind_specifier :=
            [NIL, clc$status_value],
      clause_name: ost$name,
      parse: clt$parse_state,
      token_status: ost$status,
      expecting_when: ost$status_condition,
      value: clt$value,
      initial_clause_name: ost$name,
      target_label: ost$name,
      proc_status: ost$status,
      exit_proc_condition: boolean;

    status.normal := TRUE;
    proc_status.normal := TRUE;
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);

    CASE parse.unit.kind OF
    = clc$lex_end_of_line =
      initial_clause_name := '';
    = clc$lex_name =
      #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), initial_clause_name);
      IF (initial_clause_name <> 'WHEN') AND (initial_clause_name <> 'WITH') THEN
        osp$set_status_abnormal ('CL', cle$expecting_with_or_when, initial_clause_name, status);
        RETURN;
      IFEND;
    = clc$lex_long_name =
      osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
            status);
      RETURN;
    ELSE
      osp$set_status_abnormal ('CL', cle$expecting_with_or_when, '', status);
      RETURN;
    CASEND;

    target_label := 'PROC';
    exit_statement (target_label, initial_clause_name, parse, status);

  PROCEND clp$exit_proc_statement;
?? TITLE := 'clp$proc_statement', EJECT ??

  PROCEDURE clp$proc_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    clp$f_process_proc_header (parameters, status);

  PROCEND clp$proc_statement;
?? TITLE := 'clp$procend_statement', EJECT ??

  PROCEDURE clp$procend_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      proc_block: ^clt$f_block;

    status.normal := TRUE;
    check_statement_terminator ('PROCEND', clc$proc_block, parameters, proc_block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$f_pop_block_stack (proc_block);
    clp$f_set_command_header_type (clc$procend_command);

  PROCEND clp$procend_statement;
?? TITLE := 'clp$block_statement', EJECT ??

  PROCEDURE clp$block_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      parse: clt$parse_state,
      internal_input_block: ^clt$f_block,
      block_block: ^clt$f_block;

    status.normal := TRUE;
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);
    IF parse.unit.kind <> clc$lex_end_of_line THEN
      osp$set_status_abnormal ('CL', cle$unexpected_statement_params, 'BLOCK', status);
      RETURN;
    IFEND;

    clp$f_push_block_stack (clc$block_block, label, block_block);

  PROCEND clp$block_statement;
?? TITLE := 'clp$blockend_statement', EJECT ??

  PROCEDURE clp$blockend_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      block_block: ^clt$f_block;

    status.normal := TRUE;
    check_statement_terminator ('BLOCKEND', clc$block_block, parameters, block_block, status);
    IF (NOT status.normal) AND (status.condition = cle$unexpected_control_statemnt) THEN
      RETURN;
    IFEND;
    clp$f_pop_block_stack (block_block);

  PROCEND clp$blockend_statement;
?? TITLE := 'clp$var_statement', EJECT ??

  PROCEDURE clp$var_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      parse: clt$parse_state;

    status.normal := TRUE;
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);
    IF parse.unit.kind <> clc$lex_end_of_line THEN
      osp$set_status_abnormal ('CL', cle$unexpected_statement_params, 'VAR', status);
      RETURN;
    IFEND;

    clp$f_set_command_header_type (clc$var_or_type_statement);
    clp$f_process_var_or_type ('VAR', status);

  PROCEND clp$var_statement;
?? TITLE := 'clp$varend_statement', EJECT ??

  PROCEDURE clp$varend_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'VAREND', status);

  PROCEND clp$varend_statement;
?? TITLE := 'clp$type_statement', EJECT ??

  PROCEDURE clp$type_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      parse: clt$parse_state;

    status.normal := TRUE;
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);
    IF parse.unit.kind <> clc$lex_end_of_line THEN
      osp$set_status_abnormal ('CL', cle$unexpected_statement_params, 'TYPE', status);
      RETURN;
    IFEND;

    clp$f_set_command_header_type (clc$var_or_type_statement);
    clp$f_process_var_or_type ('TYPE', status);

  PROCEND clp$type_statement;
?? TITLE := 'clp$typend_statement', EJECT ??

  PROCEDURE clp$typend_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'TYPEND', status);

  PROCEND clp$typend_statement;
?? TITLE := 'clp$if_statement', EJECT ??

  PROCEDURE clp$if_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      if_block: ^clt$f_block,
      internal_input_block: ^clt$f_block,
      parse: clt$parse_state,
      if_condition: boolean;

    status.normal := TRUE;
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);
    evaluate_boolean_expression (parse, 'THEN', if_condition, status);

    clp$f_push_block_stack (clc$if_block, label, if_block);

  PROCEND clp$if_statement;
?? TITLE := 'clp$elseif_statement', EJECT ??

  PROCEDURE clp$elseif_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      if_block: ^clt$f_block,
      parse: clt$parse_state,
      elseif_condition: boolean;

    clp$f_set_command_header_type (clc$control_statement_switch);
    status.normal := TRUE;
    clp$f_find_current_block (if_block);
    IF (if_block^.kind <> clc$if_block) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'ELSEIF', status);
      RETURN;
    IFEND;
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);
    evaluate_boolean_expression (parse, 'THEN', elseif_condition, status);

  PROCEND clp$elseif_statement;
?? TITLE := 'clp$else_statement', EJECT ??

  PROCEDURE clp$else_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      parse: clt$parse_state,
      if_block: ^clt$f_block;

    clp$f_set_command_header_type (clc$control_statement_switch);
    status.normal := TRUE;
    clp$f_find_current_block (if_block);
    IF (if_block^.kind <> clc$if_block) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'ELSE', status);
      RETURN;
    IFEND;
    IF if_block^.if_else_allowed THEN
      if_block^.if_else_allowed := FALSE;
    ELSE
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'ELSE', status);
      RETURN;
    IFEND;
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);
    IF parse.unit.kind <> clc$lex_end_of_line THEN
      osp$set_status_abnormal ('CL', cle$unexpected_statement_params, 'ELSE', status);
      RETURN;
    IFEND;

  PROCEND clp$else_statement;
?? TITLE := 'clp$ifend_statement', EJECT ??

  PROCEDURE clp$ifend_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      if_block: ^clt$f_block;

    status.normal := TRUE;
    check_statement_terminator ('IFEND', clc$if_block, parameters, if_block, status);
    IF (NOT status.normal) AND (status.condition = cle$unexpected_control_statemnt) THEN
      RETURN;
    IFEND;
    clp$f_pop_block_stack (if_block);

  PROCEND clp$ifend_statement;
?? TITLE := 'clp$loop_statement', EJECT ??

  PROCEDURE clp$loop_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      parse: clt$parse_state,
      internal_input_block: ^clt$f_block,
      loop_block: ^clt$f_block;

    status.normal := TRUE;
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);
    IF parse.unit.kind <> clc$lex_end_of_line THEN
      osp$set_status_abnormal ('CL', cle$unexpected_statement_params, 'LOOP', status);
    IFEND;

    clp$f_push_block_stack (clc$loop_block, label, loop_block);

  PROCEND clp$loop_statement;
?? TITLE := 'clp$loopend_statement', EJECT ??

  PROCEDURE clp$loopend_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      loop_block: ^clt$f_block;

    status.normal := TRUE;
    check_statement_terminator ('LOOPEND', clc$loop_block, parameters, loop_block, status);
    IF (NOT status.normal) AND (status.condition = cle$unexpected_control_statemnt) THEN
      RETURN;
    IFEND;
    clp$f_pop_block_stack (loop_block);

  PROCEND clp$loopend_statement;
?? TITLE := 'clp$while_statement', EJECT ??

  PROCEDURE clp$while_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      internal_input_block: ^clt$f_block,
      parse: clt$parse_state,
      while_block: ^clt$f_block,
      while_condition: boolean;

    status.normal := TRUE;
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);
    evaluate_boolean_expression (parse, 'DO', while_condition, status);

    clp$f_push_block_stack (clc$while_block, label, while_block);

  PROCEND clp$while_statement;
?? TITLE := 'clp$whilend_statement', EJECT ??

  PROCEDURE clp$whilend_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      while_block: ^clt$f_block,
      while_condition: boolean;

    status.normal := TRUE;
    check_statement_terminator ('WHILEND', clc$while_block, parameters, while_block, status);
    IF (NOT status.normal) AND (status.condition = cle$unexpected_control_statemnt) THEN
      RETURN;
    IFEND;
    clp$f_pop_block_stack (while_block);

  PROCEND clp$whilend_statement;
?? TITLE := 'clp$repeat_statement', EJECT ??

  PROCEDURE clp$repeat_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      parse: clt$parse_state,
      internal_input_block: ^clt$f_block,
      repeat_block: ^clt$f_block;

    status.normal := TRUE;
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);
    IF parse.unit.kind <> clc$lex_end_of_line THEN
      osp$set_status_abnormal ('CL', cle$unexpected_statement_params, 'REPEAT', status);
    IFEND;

    clp$f_push_block_stack (clc$repeat_block, label, repeat_block);

  PROCEND clp$repeat_statement;
?? TITLE := 'clp$until_statement', EJECT ??

  PROCEDURE clp$until_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      parse: clt$parse_state,
      repeat_block: ^clt$f_block,
      until_condition: boolean;

    status.normal := TRUE;
    clp$f_find_current_block (repeat_block);
    IF repeat_block^.kind <> clc$repeat_block THEN
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'UNTIL', status);
      RETURN;
    IFEND;
    clp$f_pop_block_stack (repeat_block);
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);
    evaluate_boolean_expression (parse, '', until_condition, status);

  PROCEND clp$until_statement;
?? TITLE := 'clp$for_statement', EJECT ??

  PROCEDURE clp$for_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

?? NEWTITLE := 'setup_for_incremental_control', EJECT ??

    PROCEDURE setup_for_incremental_control;


      clp$f_expression_scanner (integer_value_specifier, TRUE, parse, value, status);
      IF NOT status.normal THEN
        EXIT clp$for_statement;
      IFEND;
      IF parse.unit.kind <> clc$lex_equal THEN
        osp$set_status_abnormal ('CL', cle$expecting_for_assign, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT clp$for_statement;
      IFEND;
      clp$f_scan_token (clc$slu_non_space, parse);
      clp$f_expression_scanner (integer_value_specifier, TRUE, parse, value, status);
      IF NOT status.normal THEN
        IF (clc$min_ecc_expression_result <= status.condition) AND
              (status.condition <= clc$max_ecc_expression_result) THEN
          osp$append_status_parameter (osc$status_parameter_delimiter,
                ' for initial value of FOR statement control variable', status);
        IFEND;
        EXIT clp$for_statement;
      IFEND;

      IF parse.unit_is_space THEN
        clp$f_scan_token (clc$slu_non_space, parse);
      IFEND;
      IF NOT parse.previous_unit_is_space THEN
        osp$set_status_abnormal ('CL', cle$unexpected_after_for_init, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT clp$for_statement;
      IFEND;
      IF parse.unit.kind <> clc$lex_name THEN
        osp$set_status_abnormal ('CL', cle$expecting_for_to, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT clp$for_statement;
      IFEND;
      #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);
      IF clause_name <> 'TO' THEN
        osp$set_status_abnormal ('CL', cle$expecting_for_to, clause_name, status);
        EXIT clp$for_statement;
      IFEND;
      clp$set_format_type (clc$reserved_name);
      clp$f_scan_token (clc$slu_non_space, parse);
      IF NOT parse.previous_unit_is_space THEN
        osp$set_status_abnormal ('CL', cle$unexpected_after_for_to, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT clp$for_statement;
      IFEND;
      clp$f_expression_scanner (integer_value_specifier, TRUE, parse, value, status);
      IF NOT status.normal THEN
        IF (clc$min_ecc_expression_result <= status.condition) AND
              (status.condition <= clc$max_ecc_expression_result) THEN
          osp$append_status_parameter (osc$status_parameter_delimiter,
                ' for final value of FOR statement control variable', status);
        IFEND;
        EXIT clp$for_statement;
      IFEND;
      IF parse.unit_is_space THEN
        clp$f_scan_token (clc$slu_non_space, parse);
      IFEND;

      for_increment := 1;
      IF (parse.previous_unit_is_space) AND (parse.unit.kind <> clc$lex_end_of_line) THEN
        IF parse.unit.kind <> clc$lex_name THEN
          osp$set_status_abnormal ('CL', cle$expecting_for_by_or_do, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT clp$for_statement;
        IFEND;
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);
        IF clause_name <> 'DO' THEN
          IF clause_name <> 'BY' THEN
            osp$set_status_abnormal ('CL', cle$expecting_for_by_or_do, clause_name, status);
            EXIT clp$for_statement;
          IFEND;
          clp$set_format_type (clc$reserved_name);
          clp$f_scan_token (clc$slu_non_space, parse);
          IF NOT parse.previous_unit_is_space THEN
            osp$set_status_abnormal ('CL', cle$unexpected_after_for_by, '', status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT clp$for_statement;
          IFEND;
          clp$f_expression_scanner (integer_value_specifier, TRUE, parse, value, status);
          IF NOT status.normal THEN
            IF (clc$min_ecc_expression_result <= status.condition) AND
                  (status.condition <= clc$max_ecc_expression_result) THEN
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    ' for step value of FOR statement control variable', status);
            IFEND;
            EXIT clp$for_statement;
          IFEND;
          for_increment := value.int.value;
          IF parse.unit_is_space THEN
            clp$f_scan_token (clc$slu_non_space, parse);
          IFEND;
          IF (parse.previous_unit_is_space) AND (parse.unit.kind <> clc$lex_end_of_line) THEN
            IF parse.unit.kind <> clc$lex_name THEN
              osp$set_status_abnormal ('CL', cle$unexpected_after_for_step, '', status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$for_statement;
            IFEND;
            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);
            IF clause_name <> 'DO' THEN
              osp$set_status_abnormal ('CL', cle$unexpected_after_for_step, clause_name, status);
              EXIT clp$for_statement;
            IFEND;
            clp$set_format_type (clc$reserved_name);
          ELSEIF parse.unit.kind <> clc$lex_end_of_line THEN
            osp$set_status_abnormal ('CL', cle$unexpected_after_for_step, '', status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT clp$for_statement;
          ELSE
            clp$add_format_token (^space, clc$lex_space, clc$unassigned);
            clp$add_format_token (^do_name, clc$lex_name, clc$reserved_name);
          IFEND;
        ELSE
          clp$set_format_type (clc$reserved_name);
        IFEND;
        IF parse.unit.kind <> clc$lex_end_of_line THEN
          clp$f_scan_token (clc$slu_non_space, parse);
          IF parse.unit.kind <> clc$lex_end_of_line THEN
            osp$set_status_abnormal ('CL', cle$unexpected_after_then_or_do, 'DO', status);
            osp$append_status_parameter (osc$status_parameter_delimiter, '', status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT clp$for_statement;
          IFEND;
        IFEND;
      ELSEIF parse.unit.kind <> clc$lex_end_of_line THEN
        osp$set_status_abnormal ('CL', cle$unexpected_after_for_final, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT clp$for_statement;
      ELSE
        clp$add_format_token (^space, clc$lex_space, clc$unassigned);
        clp$add_format_token (^do_name, clc$lex_name, clc$reserved_name);
      IFEND;
    PROCEND setup_for_incremental_control;
?? TITLE := 'setup_for_list_control', EJECT ??

    PROCEDURE setup_for_list_control;

      VAR
        nesting_level: integer;


      clp$set_format_type (clc$reserved_name);

      clp$f_scan_token (clc$slu_non_space, parse);
      CASE parse.unit.kind OF
      = clc$lex_name =
        ;
      = clc$lex_long_name =
        osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
              status);
        EXIT clp$for_statement;
      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_for_variable, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT clp$for_statement;
      CASEND;

      clp$f_scan_token (clc$slu_non_space, parse);
      IF parse.unit.kind <> clc$lex_name THEN
        osp$set_status_abnormal ('CL', cle$expecting_for_in, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT clp$for_statement;
      IFEND;
      #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);
      IF clause_name <> 'IN' THEN
        osp$set_status_abnormal ('CL', cle$expecting_for_in, clause_name, status);
        EXIT clp$for_statement;
      IFEND;

      clp$set_format_type (clc$reserved_name);

      clp$f_scan_token (clc$slu_non_space, parse);
      IF NOT parse.previous_unit_is_space THEN
        osp$set_status_abnormal ('CL', cle$unexpected_after_for_in, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT clp$for_statement;
      IFEND;
      IF parse.unit.kind = clc$lex_left_parenthesis THEN
        nesting_level := 1;
        WHILE nesting_level <> 0 DO
          clp$f_scan_token (clc$slu_non_space, parse);
          CASE parse.unit.kind OF
          = clc$lex_left_parenthesis =
            nesting_level := nesting_level + 1;
          = clc$lex_right_parenthesis =
            nesting_level := nesting_level - 1;
          = clc$lex_end_of_line =
            osp$set_status_abnormal ('CL', cle$expecting_rparen, '', status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT clp$for_statement;
          ELSE
            ;
          CASEND;
        WHILEND;
        clp$f_scan_token (clc$slu_non_space, parse);
      ELSE
        clp$f_expression_scanner (integer_value_specifier, TRUE, parse, value, status);
        IF NOT status.normal THEN
          EXIT clp$for_statement;
        IFEND;
        IF parse.unit_is_space THEN
          clp$f_scan_token (clc$slu_non_space, parse);
        IFEND;
      IFEND;

      CASE parse.unit.kind OF
      = clc$lex_end_of_line, clc$lex_semicolon =
        clp$add_format_token (^space, clc$lex_space, clc$unassigned);
        clp$add_format_token (^do_name, clc$lex_name, clc$reserved_name);
      = clc$lex_name =
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$unexpected_after_for_list, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT clp$for_statement;
        IFEND;
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);
        IF clause_name <> 'DO' THEN
          osp$set_status_abnormal ('CL', cle$unexpected_after_for_list, clause_name, status);
          EXIT clp$for_statement;
        IFEND;
        clp$set_format_type (clc$reserved_name);
        clp$f_scan_token (clc$slu_non_space, parse);
        IF NOT (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_end_of_line, clc$lex_semicolon]) THEN
          osp$set_status_abnormal ('CL', cle$unexpected_after_then_or_do, 'DO', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT clp$for_statement;
        IFEND;
      ELSE
        osp$set_status_abnormal ('CL', cle$unexpected_after_for_list, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT clp$for_statement;
      CASEND;

    PROCEND setup_for_list_control;
?? OLDTITLE, EJECT ??

    VAR
      integer_value_specifier: [STATIC, READ, oss$job_paged_literal] clt$value_kind_specifier :=
            [NIL, clc$integer_value, -0ffffffffffff(16), 0ffffffffffff(16)],
      interpreter_mode: clt$interpreter_modes,
      internal_input_block: ^clt$f_block,
      for_block: ^clt$f_block,
      for_control_is_incremental: boolean,
      for_variable: ost$name,
      for_value: array [1 .. 1] of clt$integer,
      for_limit: integer,
      for_increment: integer,
      for_condition: boolean,
      value: clt$value,
      do_name: [STATIC] string (2) := 'DO',
      clause_name: ost$name,
      parse: clt$parse_state,
      space: [STATIC] string (1) := ' ',
      scope: clt$variable_scope;

    status.normal := TRUE;
    clp$f_push_block_stack (clc$for_block, label, for_block);
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);
    CASE parse.unit.kind OF
    = clc$lex_name =
      ;
    = clc$lex_long_name =
      osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
            status);
      RETURN;
    ELSE
      osp$set_status_abnormal ('CL', cle$expecting_for_var_or_each, '', status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      RETURN;
    CASEND;
    #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), for_variable);
    for_control_is_incremental := for_variable <> 'EACH';
    IF for_control_is_incremental THEN
      setup_for_incremental_control;
    ELSE
      setup_for_list_control;
    IFEND;


  PROCEND clp$for_statement;
?? TITLE := 'clp$forend_statement', EJECT ??

  PROCEDURE clp$forend_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      for_block: ^clt$f_block,
      for_variable: clt$variable_reference,
      for_value: array [1 .. 1] of clt$integer,
      forend_condition: boolean;

    status.normal := TRUE;
    check_statement_terminator ('FOREND', clc$for_block, parameters, for_block, status);
    IF (NOT status.normal) AND (status.condition = cle$unexpected_control_statemnt) THEN
      RETURN;
    IFEND;
    clp$f_pop_block_stack (for_block);

  PROCEND clp$forend_statement;
?? TITLE := 'when condition names', EJECT ??

  VAR
    condition_names_value_specifier: [STATIC, READ, oss$job_paged_literal] clt$value_kind_specifier :=
          [^condition_names, clc$keyword_value],
    condition_names: [STATIC, READ, oss$job_paged_literal] array [1 .. 6] of ost$name := ['ANY_FAULT',
          'COMMAND_FAULT', 'INTERRUPT', 'LIMIT_FAULT', 'PROGRAM_FAULT', 'RESOURCE_FAULT'];

?? TITLE := 'clp$when_statement', EJECT ??

  PROCEDURE clp$when_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      do_name: [STATIC] string (2) := 'DO',
      space: [STATIC] string (1) := ' ',
      interpreter_mode: clt$interpreter_modes,
      when_file_name: amt$local_file_name,
      terminator_name: ost$name,
      parse: clt$parse_state,
      when_block: ^clt$f_block,
      value: clt$value;

    status.normal := TRUE;
    clp$f_push_block_stack (clc$when_block, label, when_block);
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);

  /scan_condition_names/
    WHILE TRUE DO
      clp$f_expression_scanner (condition_names_value_specifier, TRUE, parse, value, status);
      IF NOT status.normal THEN
        IF (clc$min_ecc_expression_result <= status.condition) AND
              (status.condition <= clc$max_ecc_expression_result) THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, ' for WHEN condition name', status);
        IFEND;
        RETURN;
      IFEND;
      IF parse.unit_is_space THEN
        clp$f_scan_token (clc$slu_non_space, parse);
      IFEND;
      CASE parse.unit.kind OF
      = clc$lex_end_of_line =
        clp$add_format_token (^space, clc$lex_space, clc$unassigned);
        clp$add_format_token (^do_name, clc$lex_name, clc$reserved_name); {||?
        EXIT /scan_condition_names/;
      = clc$lex_comma =
        clp$f_scan_token (clc$slu_non_space, parse);
      ELSE
        IF parse.previous_unit_is_space THEN
          IF parse.unit.kind = clc$lex_name THEN
            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), terminator_name);
            IF terminator_name = 'DO' THEN
              clp$set_format_type (clc$reserved_name);
              clp$f_scan_token (clc$slu_non_space, parse);
              IF parse.unit.kind <> clc$lex_end_of_line THEN
                osp$set_status_abnormal ('CL', cle$unexpected_after_then_or_do, 'DO', status);
                clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
                RETURN;
              IFEND;
              EXIT /scan_condition_names/;
            IFEND;
          IFEND;
        ELSE
          osp$set_status_abnormal ('CL', cle$unexpected_after_cond_name, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          RETURN;
        IFEND;
      CASEND;
    WHILEND /scan_condition_names/;

  PROCEND clp$when_statement;
?? TITLE := 'clp$whenend_statement', EJECT ??

  PROCEDURE clp$whenend_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      when_block: ^clt$f_block;

    status.normal := TRUE;
    check_statement_terminator ('WHENEND', clc$when_block, parameters, when_block, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$f_pop_block_stack (when_block)

  PROCEND clp$whenend_statement;
?? TITLE := 'clp$continue_statement', EJECT ??

  PROCEDURE clp$continue_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      continue_condition: boolean,
      retry: boolean,
      clause_name: ost$name,
      parse: clt$parse_state,
      expecting_when: ost$status_condition;

    clp$f_set_command_header_type (clc$control_statement_no_switch);
    status.normal := TRUE;

  /process_continue_parameters/
    BEGIN
      retry := FALSE;
      clp$initialize_parse_state (^parameters, NIL, parse);
      clp$f_scan_token (clc$slu_non_space, parse);
      IF parse.unit.kind = clc$lex_end_of_line THEN
        EXIT /process_continue_parameters/;
      IFEND;
      IF parse.unit.kind <> clc$lex_name THEN
        osp$set_status_abnormal ('CL', cle$expecting_retry_or_when, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        RETURN;
      IFEND;
      #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);
      expecting_when := cle$expecting_retry_or_when;

      IF (clause_name = 'RETRY') OR (clause_name = 'NEXT') OR (clause_name = 'NEXT_HANDLER') OR
            (clause_name = 'NEXT_USER_HANDLER') THEN
        clp$set_format_type (clc$reserved_name);
        retry := TRUE;
        clp$f_scan_token (clc$slu_non_space, parse);
        IF parse.unit.kind = clc$lex_end_of_line THEN
          EXIT /process_continue_parameters/;
        IFEND;
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$unexpected_after_retry, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          RETURN;
        IFEND;
        IF parse.unit.kind <> clc$lex_name THEN
          osp$set_status_abnormal ('CL', cle$expecting_continue_when, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          RETURN;
        IFEND;
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), clause_name);
        expecting_when := cle$expecting_continue_when;
      IFEND;

      IF clause_name <> 'WHEN' THEN
        osp$set_status_abnormal ('CL', expecting_when, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        RETURN;
      IFEND;
      process_when_clause ('CONTINUE', parse, continue_condition, status);
      IF NOT (status.normal AND continue_condition) THEN
        RETURN;
      IFEND;
    END /process_continue_parameters/;

  PROCEND clp$continue_statement;
?? TITLE := 'clp$push_statement', EJECT ??

  PROCEDURE clp$push_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      object_names_specifier: [STATIC, READ, oss$job_paged_literal] clt$value_kind_specifier :=
            [NIL, clc$name_value, 1, osc$max_name_size],
      parse: clt$parse_state,
      value: clt$value;

    status.normal := TRUE;
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);

  /scan_object_names/
    WHILE TRUE DO
      clp$f_expression_scanner (object_names_specifier, TRUE, parse, value, status);
      IF NOT status.normal THEN
        IF (clc$min_ecc_expression_result <= status.condition) AND
              (status.condition <= clc$max_ecc_expression_result) THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, ' for PUSH object name', status);
        IFEND;
        RETURN
      IFEND;

      IF parse.unit_is_space THEN
        clp$f_scan_token (clc$slu_non_space, parse);
      IFEND;
      CASE parse.unit.kind OF
      = clc$lex_end_of_line =
        EXIT /scan_object_names/;
      = clc$lex_comma =
        clp$f_scan_token (clc$slu_non_space, parse);
      ELSE
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$unexpected_after_obj_name, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        IFEND;
      CASEND;
    WHILEND /scan_object_names/;

    clp$f_set_command_header_type (clc$control_statement_no_switch);

  PROCEND clp$push_statement;
?? TITLE := 'clp$pop_statement', EJECT ??

  PROCEDURE clp$pop_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      object_names_specifier: [STATIC, READ, oss$job_paged_literal] clt$value_kind_specifier :=
            [NIL, clc$name_value, 1, osc$max_name_size],
      parse: clt$parse_state,
      value: clt$value;

    status.normal := TRUE;
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);

  /scan_object_names/
    WHILE TRUE DO
      clp$f_expression_scanner (object_names_specifier, TRUE, parse, value, status);
      IF NOT status.normal THEN
        IF (clc$min_ecc_expression_result <= status.condition) AND
              (status.condition <= clc$max_ecc_expression_result) THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, ' for POP object name', status);
        IFEND;
        RETURN
      IFEND;

      IF parse.unit_is_space THEN
        clp$f_scan_token (clc$slu_non_space, parse);
      IFEND;
      CASE parse.unit.kind OF
      = clc$lex_end_of_line =
        EXIT /scan_object_names/;
      = clc$lex_comma =
        clp$f_scan_token (clc$slu_non_space, parse);
      ELSE
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$unexpected_after_obj_name, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        IFEND;
      CASEND;
    WHILEND /scan_object_names/;

  PROCEND clp$pop_statement;
?? TITLE := 'clp$cancel_statement', EJECT ??

  PROCEDURE clp$cancel_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      parse: clt$parse_state,
      value: clt$value;

    clp$f_set_command_header_type (clc$control_statement_no_switch);
    status.normal := TRUE;
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);

  /scan_condition_names/
    WHILE TRUE DO
      clp$f_expression_scanner (condition_names_value_specifier, TRUE, parse, value, status);
      IF NOT status.normal THEN
        IF (clc$min_ecc_expression_result <= status.condition) AND
              (status.condition <= clc$max_ecc_expression_result) THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, ' for WHEN condition name', status);
        IFEND;
        RETURN;
      IFEND;
      IF parse.unit_is_space THEN
        clp$f_scan_token (clc$slu_non_space, parse);
      IFEND;
      CASE parse.unit.kind OF
      = clc$lex_end_of_line =
        EXIT /scan_condition_names/;
      = clc$lex_comma =
        clp$f_scan_token (clc$slu_non_space, parse);
      ELSE
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$unexpected_after_cond_name, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          RETURN;
        IFEND;
      CASEND;
    WHILEND /scan_condition_names/;

  PROCEND clp$cancel_statement;
?? TITLE := 'clp$cause_statement', EJECT ??

  PROCEDURE clp$cause_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      status_value_specifier: [STATIC, READ, oss$job_paged_literal] clt$value_kind_specifier :=
            [NIL, clc$status_value],
      parse: clt$parse_state,
      value: clt$value;

    status.normal := TRUE;
    clp$f_set_command_header_type (clc$control_statement_no_switch);
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);
    clp$f_expression_scanner (status_value_specifier, TRUE, parse, value, status);
    IF NOT status.normal THEN
      IF (clc$min_ecc_expression_result <= status.condition) AND
            (status.condition <= clc$max_ecc_expression_result) THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, ' for status value of CAUSE statement',
              status);
      IFEND;
      RETURN;
    IFEND;
    IF parse.unit_is_space THEN
      clp$f_scan_token (clc$slu_non_space, parse);
    IFEND;
    IF parse.unit.kind <> clc$lex_end_of_line THEN
      osp$set_status_abnormal ('CL', cle$unexpected_statement_params, 'CAUSE status', status);
      RETURN;
    IFEND;

  PROCEND clp$cause_statement;
?? TITLE := 'TASK/TASKEND processing TYPEs and VARiables', EJECT ??

  TYPE
    clt$task_parameters = record
      local_file_name: amt$local_file_name,
      task_name: ost$name,
    recend;

?? TITLE := 'clp$task_statement', EJECT ??

  PROCEDURE clp$task_statement
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      label: ost$name,
      task_block: ^clt$f_block;

    label := '';
    clp$f_set_command_header_type (clc$control_statement_begin);
    clp$f_push_block_stack (clc$formatter_task_block, label, task_block);
    clp$f_scan_parameter_list (parameter_list, status);
    IF status.normal THEN
      clp$f_process_task_or_job ('TASK', status);
    IFEND;

  PROCEND clp$task_statement;
?? TITLE := 'clp$taskend_statement', EJECT ??

  PROCEDURE clp$taskend_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      task_block: ^clt$f_block;

    status.normal := TRUE;
    check_statement_terminator ('TASKEND', clc$formatter_task_block, '', task_block, status);
    IF (NOT status.normal) AND (status.condition = cle$unexpected_control_statemnt) THEN
      RETURN;
    IFEND;
    clp$f_set_substitution_mark (' ');
    clp$f_pop_block_stack (task_block);

  PROCEND clp$taskend_statement;
?? TITLE := 'clp$utility_statement', EJECT ??

  PROCEDURE clp$utility_statement
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      label: ost$name,
      utility_block: ^clt$f_block;

    label := '';
    clp$f_set_command_header_type (clc$control_statement_begin);
    clp$f_push_block_stack (clc$formatter_utility_block, label, utility_block);
    clp$f_scan_parameter_list (parameter_list, status);

  PROCEND clp$utility_statement;
?? TITLE := 'clp$utilityend_statement', EJECT ??

  PROCEDURE clp$utilityend_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      utility_block: ^clt$f_block;

    status.normal := TRUE;
    check_statement_terminator ('UTILITYEND', clc$formatter_utility_block, '', utility_block, status);
    IF (NOT status.normal) AND (status.condition = cle$unexpected_control_statemnt) THEN
      RETURN;
    IFEND;
    clp$f_pop_block_stack (utility_block);

  PROCEND clp$utilityend_statement;
?? TITLE := 'clp$job_statement', EJECT ??

  PROCEDURE clp$job_statement
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      label: ost$name,
      job_block: ^clt$f_block;

    label := '';
    clp$f_set_command_header_type (clc$control_statement_begin);
    clp$f_push_block_stack (clc$formatter_job_block, label, job_block);
    clp$f_scan_parameter_list (parameter_list, status);
    IF status.normal THEN
      clp$f_process_task_or_job ('JOB', status);
    IFEND;

  PROCEND clp$job_statement;
?? TITLE := 'clp$jobend_statement', EJECT ??

  PROCEDURE clp$jobend_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      job_block: ^clt$f_block;

    status.normal := TRUE;
    check_statement_terminator ('JOBEND', clc$formatter_job_block, '', job_block, status);
    IF (NOT status.normal) AND (status.condition = cle$unexpected_control_statemnt) THEN
      RETURN;
    IFEND;
    clp$f_set_substitution_mark (' ');
    clp$f_pop_block_stack (job_block);

  PROCEND clp$jobend_statement;
?? TITLE := 'clp$push_commands', EJECT ??

  PROCEDURE clp$push_commands
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      parse: clt$parse_state;

    status.normal := TRUE;
    clp$f_set_command_header_type (clc$control_statement_no_switch);
    clp$initialize_parse_state (^parameters, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);
    IF parse.unit.kind <> clc$lex_end_of_line THEN
      osp$set_status_abnormal ('CL', cle$unexpected_statement_params, 'PUSH_COMMANDS', status);
      RETURN;
    IFEND;

  PROCEND clp$push_commands;
?? TITLE := 'clp$pipe_statement', EJECT ??

  PROCEDURE clp$pipe_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      parameter_string: ost$string,
      pipe_block: ^clt$f_block;

    clp$f_set_command_header_type (clc$control_statement_begin);
    clp$f_push_block_stack (clc$formatter_pipe_block, label, pipe_block);

    osp$set_status_abnormal ('CL', cle$not_yet_implemented, 'PIPE statement', status);

  PROCEND clp$pipe_statement;
?? TITLE := 'clp$pipend_statement', EJECT ??

  PROCEDURE clp$pipend_statement
    (    label: ost$name;
         parameters: string ( * );
     VAR status: ost$status);

    VAR
      pipe_block: ^clt$f_block;

    status.normal := TRUE;
    check_statement_terminator ('PIPEND', clc$formatter_pipe_block, '', pipe_block, status);
    IF (NOT status.normal) AND (status.condition = cle$unexpected_control_statemnt) THEN
      RETURN;
    IFEND;
    clp$f_pop_block_stack (pipe_block);

    osp$set_status_abnormal ('CL', cle$not_yet_implemented, 'PIPEND statement', status);

  PROCEND clp$pipend_statement;

MODEND clm$f_control_statements;
*DECK DECK=CLM$F_FUNCTION_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Function Manager' ??
MODULE clm$f_function_manager;

{
{ PURPOSE:
{   This module contains the procedures that support the scanning and evaluation of "built-in" functions.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc cle$ecc_function_processing
*copyc clt$argument_descriptor_table
*copyc clt$argument_value_table
*copyc clt$command_line_index
*copyc clt$command_line_size
*copyc clt$function
*copyc clt$name
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc clp$append_status_parse_state
*copyc clp$delete_current_format_token
*copyc clp$f_scan_expression
*copyc clp$f_scan_token
*copyc clp$initialize_parse_state
*copyc clp$insert_format_marker
*copyc clp$isolate_balanced_text
*copyc clp$recognize_format_tokens
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal

?? TITLE := 'clp$f_scan_argument_list', EJECT ??
*copyc clh$scan_argument_list

  PROCEDURE [XDCL, #GATE] clp$f_scan_argument_list
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR status: ost$status);

    VAR
      spaces_before_not_part_of_token: [STATIC, READ, oss$job_paged_literal] set of clt$lexical_unit_kind :=
            [clc$lex_unknown, clc$lex_dot, clc$lex_colon, clc$lex_left_parenthesis, clc$lex_query,
            clc$lex_add, clc$lex_subtract, clc$lex_string, clc$lex_name, clc$lex_unsigned_decimal,
            clc$lex_alpha_number];

    VAR
      local_status: ost$status,
      scratch_value: clt$value,
      scratch_vks: clt$value_kind_specifier,
      parse: clt$parse_state,
      argument_list_index: clt$command_line_index,
      argument_index: clt$command_line_index,
      argument_size: clt$command_line_size,
      argument_number: 1 .. clc$max_arguments,
      argument_count: 0 .. clc$max_arguments;


    status.normal := TRUE;
    local_status.normal := TRUE;
    IF local_status.normal THEN
      argument_number := 1;
      clp$initialize_parse_state (^argument_list, NIL, parse);
      clp$recognize_format_tokens (FALSE);
      clp$f_scan_token (clc$slu_non_space, parse);
      clp$recognize_format_tokens (TRUE);
      IF parse.unit.kind = clc$lex_end_of_line THEN
        argument_index := parse.index;
      ELSE
        argument_index := parse.unit_index;
      IFEND;

    /scan_arguments/
      WHILE argument_index <= STRLENGTH (argument_list) DO
        clp$isolate_balanced_text (argument_list, argument_index, argument_list_index);
        argument_size := argument_list_index - argument_index;
        scratch_vks.kind := clc$any_value;
        clp$insert_format_marker (clc$parameter_begin, 0);
        clp$f_scan_expression (argument_list (argument_index, argument_size), scratch_vks, scratch_value,
              local_status);
        IF NOT local_status.normal THEN
          IF (clc$min_ecc_expression_result <= local_status.condition) AND
                (local_status.condition <= clc$max_ecc_expression_result) THEN
            osp$append_status_parameter (osc$status_parameter_delimiter, ' for argument', local_status);
            osp$append_status_integer (' ', argument_number, 10, FALSE, local_status);
            osp$append_status_parameter (' ', 'of function', local_status);
            osp$append_status_parameter (' ', function_name.value, local_status);
          IFEND;
          EXIT /scan_arguments/;
        IFEND;
        clp$insert_format_marker (clc$parameter_end, 0);
        parse.index := argument_list_index;
        clp$f_scan_token (clc$slu_non_space, parse);
        CASE parse.unit.kind OF
        = clc$lex_comma =
          clp$f_scan_token (clc$slu_non_space, parse);
        = clc$lex_end_of_line =
          EXIT /scan_arguments/;
        ELSE
          IF NOT (parse.previous_unit_is_space AND (parse.unit.kind IN spaces_before_not_part_of_token)) THEN
            osp$set_status_abnormal ('CL', cle$expecting_argument_term, '', local_status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, local_status);
            osp$append_status_integer (osc$status_parameter_delimiter, argument_number, 10, FALSE,
                  local_status);
            osp$append_status_parameter (osc$status_parameter_delimiter, function_name.value, local_status);
            EXIT /scan_arguments/;
          IFEND;
        CASEND;
        clp$delete_current_format_token;
        argument_number := argument_number + 1;
        argument_index := parse.unit_index;
      WHILEND /scan_arguments/;
    IFEND;
    status := local_status;

  PROCEND clp$f_scan_argument_list;

MODEND clm$f_function_manager;
*DECK DECK=CLM$F_LEXICAL_PROCESSORS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Lexical Processors' ??
MODULE clm$f_lexical_processors;

{
{ PURPOSE:
{   This module contains an interface between the SCL formatter routines
{   and clp$scan_lexical_unit. It provides for generating a "format token"
{   for each clt$lexical_unit encountered.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parse_state
*copyc clt$slu_termination_option
*copyc oss$job_paged_literal
?? POP ??
*copyc clp$add_format_token
*copyc clp$delete_current_format_token
*copyc clp$scan_lexical_unit

  VAR
    spaces_before_not_part_of_token: [STATIC, READ, oss$job_paged_literal] set of clt$lexical_unit_kind :=
          [clc$lex_unknown, clc$lex_dot, clc$lex_colon, clc$lex_left_parenthesis, clc$lex_query, clc$lex_add,
          clc$lex_subtract, clc$lex_string, clc$lex_name, clc$lex_unsigned_decimal, clc$lex_alpha_number];

?? TITLE := 'clp$f_scan_token', EJECT ??

  PROCEDURE [XDCL] clp$f_scan_token
    (    termination_option: clt$slu_termination_option;
     VAR parse { input, output } : clt$parse_state);

    VAR
      last_token_space: boolean;

    CASE termination_option OF
    = clc$slu_any =
      clp$scan_lexical_unit (termination_option, parse);
      IF parse.unit.size > 0 THEN
        clp$add_format_token (^parse.text^ (parse.unit_index, parse.unit.size), parse.unit.kind,
              clc$unassigned);
      IFEND;
    = clc$slu_non_space =
      last_token_space := FALSE;

    /find_non_space/
      WHILE TRUE DO
        clp$scan_lexical_unit (clc$slu_any, parse);
        IF NOT (parse.unit_is_space) THEN
          IF last_token_space AND NOT (parse.unit.kind IN spaces_before_not_part_of_token) THEN
            clp$delete_current_format_token;
          IFEND;
          EXIT /find_non_space/;
        IFEND;
        last_token_space := parse.unit.kind = clc$lex_space;
        clp$add_format_token (^parse.text^ (parse.unit_index, parse.unit.size), parse.unit.kind,
              clc$unassigned);
      WHILEND /find_non_space/;

      IF parse.unit.size > 0 THEN
        clp$add_format_token (^parse.text^ (parse.unit_index, parse.unit.size), parse.unit.kind,
              clc$unassigned);
      IFEND;

    CASEND;

  PROCEND clp$f_scan_token;

MODEND clm$f_lexical_processors;
*DECK DECK=CLM$F_PROCESS_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Process Commands' ??
MODULE clm$f_process_commands;

{
{ PURPOSE:
{   This module contains the routines that interpret an individual command or control statement.
{   This entails parsing the command image, using the command list to search for the appropriate processor,
{   and passing control to that processor in the appropriate fashion (call, load and call, execute, or
{   PROCedure call.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$variable_reference
*copyc cle$ecc_command_processing
*copyc cle$ecc_control_statement
*copyc cle$ecc_miscellaneous
*copyc clt$command_line
*copyc clt$command_line_index
*copyc clt$command_line_size
*copyc clt$f_block
*copyc clt$file
*copyc clt$interpreter_modes
*copyc clt$lexical_unit_kinds
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc clp$append_status_parse_state
*copyc clp$delete_current_format_token
*copyc clp$f_check_name_for_control
*copyc clp$f_complete_file_or_var_scan
*copyc clp$f_find_current_block
*copyc clp$f_evaluate_expression
*copyc clp$f_pop_block_stack
*copyc clp$f_push_block_stack
*copyc clp$f_scan_expression
*copyc clp$f_scan_parameter_list
*copyc clp$f_scan_token
*copyc clp$f_set_command_header_type
*copyc clp$initialize_parse_state
*copyc clp$insert_format_marker
*copyc clp$isolate_text_via_separator
*copyc clp$recognize_format_tokens
*copyc clp$set_format_type
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper

  CONST
    commands_to_translate_count = 3;

  VAR
    commands_to_translate: [STATIC, READ, oss$job_paged_literal] array [1 .. commands_to_translate_count] of
          ost$name := ['CREATE_VARIABLE', 'CREATE_VARIABLES', 'CREV'];

  VAR
    clv$translate: [XREF] boolean;


  VAR
    clv$substitution_mark: [XREF, READ]  string (1) ;


?? TITLE := 'clp$f_process_command', EJECT ??

  PROCEDURE [XDCL] clp$f_process_command
    (    interpreter_mode: clt$interpreter_modes;
         command: ^clt$command_line;
     VAR status: ost$status);

    VAR
      index: 1 .. commands_to_translate_count,
      label: ost$name,
      escaped_command: boolean,
      name_index: clt$command_line_index,
      name_size: clt$command_line_size,
      file: clt$file,
      file_given: boolean,
      command_name: clt$name,
      separator: clt$lexical_unit_kind,
      empty_command: boolean,
      control_statement_descriptor: ^clt$f_control_statement_desc,
      parameter_list: ^clt$parameter_list,
      parameter_list_container: ^clt$parameter_list,
      parse: clt$parse_state,
      space_after_label: boolean,
      found_leading_spaces: boolean,
      value: clt$value,
      right_value_kind: [STATIC, READ] clt$value_kind_specifier := [NIL, clc$any_value],
      parameter_list_contents: ^string ( * );

    ?VAR
      clc$translate: boolean := TRUE?;

    status.normal := TRUE;
    IF STRLENGTH (command^) = 0 THEN
      RETURN;
    IFEND; {write to output ????? ||||

    clp$recognize_format_tokens (FALSE);

    PUSH parameter_list_container: [[REP #SIZE (clt$command_line_size) + #SIZE (command^) OF cell]];
    clp$parse_command (command, parameter_list_container, escaped_command, label, name_index, name_size, file,
          file_given, command_name, separator, parameter_list, parameter_list_contents, empty_command,
          space_after_label, found_leading_spaces, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$recognize_format_tokens (TRUE);

    reparse_command (command, escaped_command, label, name_index, name_size, file, file_given, command_name,
          separator, parameter_list, parameter_list_contents, empty_command, space_after_label,
          found_leading_spaces, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF empty_command THEN
      RETURN;
    IFEND;

  /process_command/
    BEGIN
      IF separator = clc$lex_equal THEN
        IF interpreter_mode = clc$interpret_mode THEN

          IF escaped_command OR (label <> osc$null_name) THEN
            osp$set_status_abnormal ('CL', cle$assignment_cant_be_labelled, '', status);
            EXIT /process_command/;
          IFEND;

          clp$f_set_command_header_type (clc$assignment);
          clp$initialize_parse_state (^parameter_list_contents^, NIL, parse);
          clp$f_scan_token (clc$slu_any, parse);
          clp$f_evaluate_expression (right_value_kind, FALSE, FALSE, parse, value, status);
          IF (parse.unit.kind <> clc$lex_end_of_line) AND (parse.unit.kind <> clc$lex_comma) AND
                (NOT parse.previous_unit_is_space) AND (NOT parse.unit_is_space) THEN
            osp$set_status_abnormal ('CL', cle$expecting_end_of_expression, '', status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          IFEND;
        IFEND;

      ELSEIF file_given THEN

        IF label <> osc$null_name THEN
          osp$set_status_abnormal ('CL', cle$commands_cant_be_labelled, '', status);
          EXIT /process_command/;
        IFEND;

        clp$f_set_command_header_type (clc$file_command);
        clp$f_scan_parameter_list (parameter_list^, status);

      ELSE
        clp$f_check_name_for_control (command_name, control_statement_descriptor);
        IF control_statement_descriptor <> NIL THEN

          CASE control_statement_descriptor^.kind OF
          = clc$control_statement =

            IF (label <> '') AND (NOT control_statement_descriptor^.label_allowed) THEN
              osp$set_status_abnormal ('CL', cle$statement_cant_be_labelled, command_name.value, status);
              EXIT /process_command/;
            IFEND;
            IF escaped_command THEN
              osp$set_status_abnormal ('CL', cle$unexpected_escape, command_name.value, status);
              EXIT /process_command/;
            IFEND;
            IF separator = clc$lex_comma THEN
              osp$set_status_abnormal ('CL', cle$unexpected_comma_after, command_name.value, status);
              EXIT /process_command/;
            IFEND;

            control_statement_descriptor^.statement^ (label, parameter_list_contents^, status);

          = clc$control_command =

            IF label <> osc$null_name THEN
              osp$set_status_abnormal ('CL', cle$commands_cant_be_labelled, '', status);
              EXIT /process_command/;
            IFEND;

            control_statement_descriptor^.command^ (parameter_list^, status);
          CASEND;

        ELSE

          IF label <> osc$null_name THEN
            osp$set_status_abnormal ('CL', cle$commands_cant_be_labelled, '', status);
            EXIT /process_command/;
          IFEND;

          IF clv$translate THEN

          /search_to_translate/
            FOR index := 1 TO commands_to_translate_count DO
              IF command_name.value = commands_to_translate [index] THEN
                clp$f_set_command_header_type (clc$to_be_translated_command);
                EXIT /search_to_translate/;
              IFEND;
            FOREND /search_to_translate/;
          IFEND;

          clp$f_scan_parameter_list (parameter_list^, status);
        IFEND;
      IFEND;
    END /process_command/;

  PROCEND clp$f_process_command;
?? TITLE := 'clp$parse_command', EJECT ??
*copyc clh$parse_command

  PROCEDURE clp$parse_command
    (    command: ^string ( * );
         parameter_list_container: ^clt$parameter_list;
     VAR escaped: boolean;
     VAR label: ost$name;
     VAR name_index: clt$command_line_index;
     VAR name_size: clt$command_line_size;
     VAR file: clt$file;
     VAR file_given: boolean;
     VAR name: clt$name;
     VAR separator: clt$lexical_unit_kind;
     VAR parameter_list: ^clt$parameter_list;
     VAR parameter_list_contents: ^string ( * );
     VAR empty_command: boolean;
     VAR space_after_label: boolean;
     VAR found_leading_spaces: boolean;
     VAR status: ost$status);

    VAR
      parse: clt$parse_state,
      leading_name: clt$name,
      command_index: clt$command_line_index,
      parse_for_separator: clt$parse_state,
      parameter_list_area: ^clt$parameter_list,
      parameter_list_size: ^clt$command_line_size;


    status.normal := TRUE;
    command_index := 1;
    file_given := FALSE;
    found_leading_spaces := FALSE;
    escaped := FALSE;
    clp$initialize_parse_state (command, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);
    found_leading_spaces := parse.previous_unit_is_space;

    IF (clv$substitution_mark <> ' ') AND (parse.text^ (parse.unit_index, parse.unit.size) =
          clv$substitution_mark) THEN
      empty_command := TRUE;
      name_index := parse.unit_index;
      RETURN;
    IFEND;

    CASE parse.unit.kind OF
    = clc$lex_query =
      clp$f_scan_token (clc$slu_non_space, parse);
      escaped := parse.unit.kind = clc$lex_divide;
      IF escaped THEN
        clp$f_scan_token (clc$slu_non_space, parse);
      IFEND;
    = clc$lex_divide =
      escaped := TRUE;
      clp$f_scan_token (clc$slu_non_space, parse);
    = clc$lex_end_of_line =
      empty_command := TRUE;
      name_index := parse.unit_index;
      RETURN;
    ELSE
      escaped := FALSE;
    CASEND;
    empty_command := FALSE;

    label := osc$null_name;
    name_index := parse.unit_index;
    IF parse.unit.kind = clc$lex_name THEN
      clp$f_scan_token (clc$slu_any, parse);
      IF parse.unit.kind = clc$lex_colon THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.previous_non_space_unit_index,
              parse.previous_non_space_unit.size), label);
        clp$f_set_command_header_type (clc$labeled_command);
        clp$f_scan_token (clc$slu_non_space, parse);
        space_after_label := parse.previous_unit_is_space;
        name_index := parse.unit_index;
      IFEND;
    IFEND;
    clp$isolate_text_via_separator (clc$ibt_stop_on_relational, command^, name_index, command_index);
    name_size := command_index - name_index;


    parse.index := command_index;
    clp$f_scan_token (clc$slu_non_space, parse);
    parse_for_separator := parse;
    IF parse.previous_unit_is_space AND (NOT (parse.unit.kind IN $clt$lexical_unit_kinds
          [clc$lex_equal, clc$lex_comma, clc$lex_end_of_line])) THEN
      separator := clc$lex_space;
    ELSE
      separator := parse.unit.kind;
      clp$f_scan_token (clc$slu_non_space, parse);
    IFEND;

    parameter_list := NIL;
    parameter_list_contents := ^command^ (command_index, STRLENGTH (command^) - command_index + 1);
    IF parameter_list_container <> NIL THEN
      parameter_list_area := parameter_list_container;
      RESET parameter_list_area;
      NEXT parameter_list_size IN parameter_list_area;
      IF parameter_list_size <> NIL THEN
        parameter_list_size^ := STRLENGTH (command^) - parse.unit_index + 1;
        NEXT parameter_list_contents: [parameter_list_size^] IN parameter_list_area;
      IFEND;
      IF parameter_list_contents = NIL THEN
        osp$set_status_abnormal ('CL', cle$table_overflow, 'Parameter_List_Area in clp$parse_command',
              status);
        RETURN;
      IFEND;
      parameter_list_contents^ := command^ (parse.unit_index, parameter_list_size^);
      RESET parameter_list_area;
      NEXT parameter_list: [[REP #SIZE (parameter_list_size^) + #SIZE (parameter_list_contents^) OF cell]] IN
            parameter_list_area;
    IFEND;

    CASE separator OF
    = clc$lex_equal =
      name.value := 'assignment';
      name.size := 10;
    = clc$lex_space, clc$lex_comma, clc$lex_end_of_line =

      clp$initialize_parse_state (^command^ (name_index, name_size), NIL, parse);
      clp$f_scan_token (clc$slu_non_space, parse);
      CASE parse.unit.kind OF
      = clc$lex_colon, clc$lex_dot =
        leading_name.value := osc$null_name;
        leading_name.size := 1;
      = clc$lex_name =
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), leading_name.value);
        leading_name.size := parse.unit.size;
        clp$f_scan_token (clc$slu_any, parse);
        IF parse.unit.kind = clc$lex_end_of_line THEN
          file_given := FALSE;
          name := leading_name;
          RETURN;
        IFEND;
      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_command, command^ (name_index, name_size), status);
        RETURN;
      CASEND;

      file_given := TRUE;

    ELSE
      osp$set_status_abnormal ('CL', cle$unexpected_after_command, '', status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse_for_separator, status);
    CASEND;

  PROCEND clp$parse_command;
?? TITLE := 'reparse_command', EJECT ??

  PROCEDURE reparse_command
    (    command: ^string ( * );
         escaped: boolean;
         label: ost$name;
         name_index: clt$command_line_index;
         name_size: clt$command_line_size;
     VAR file: clt$file;
     VAR file_given: boolean;
     VAR name: clt$name;
     VAR separator: clt$lexical_unit_kind;
     VAR parameter_list: ^clt$parameter_list;
     VAR parameter_list_contents: ^string ( * );
     VAR empty_command: boolean;
         space_after_label: boolean;
         found_leading_spaces: boolean;
     VAR status: ost$status);

{ PURPOSE:
{    The purpose of this procedure is to pass on to the SCL formatter
{    the information concerning the command which was gathered by
{    CLP$PARSE_COMMAND.  It would be awkward for that procedure to
{    generate formmatter information via clp$add_format_token, etc.
{    due to the frequent need to "look-ahead".

    VAR
      parse: clt$parse_state,
      file_parse: clt$parse_state,
      leading_name: clt$name,
      left_value_kind: [STATIC, READ] clt$value_kind_specifier :=
            [NIL, clc$variable_reference, clc$array_allowed, clc$any_value],
      variable: clt$value,
      command_index: clt$command_line_index,
      parameter_list_area: ^clt$parameter_list,
      parameter_list_size: ^ost$string_size;

    status.normal := TRUE;
    clp$initialize_parse_state (command, NIL, parse);

    IF empty_command THEN
      IF (clv$substitution_mark <>' ') AND (parse.text^ (name_index, 1) =
            clv$substitution_mark) THEN
        REPEAT
          clp$f_scan_token (clc$slu_non_space, parse);
        UNTIL parse.unit.kind = clc$lex_end_of_line;
        RETURN;
      ELSE
        clp$f_scan_token (clc$slu_non_space, parse); {To record any leading comments
        RETURN;
      IFEND;
    IFEND;

{ Read (and, via clp$f_scan_token, record) all tokens up to the command name.

    IF name_index > 1 THEN
      REPEAT
        clp$f_scan_token (clc$slu_any, parse);
      UNTIL parse.index = name_index;
    IFEND;

    clp$isolate_text_via_separator (clc$ibt_stop_on_relational, command^, name_index, command_index);
    parse.index := command_index;
    IF file_given THEN
      clp$insert_format_marker (clc$file_or_var_begin, 0);
      clp$initialize_parse_state (^command^ (name_index, name_size), NIL, file_parse);
      clp$f_scan_token (clc$slu_any, file_parse);
      CASE file_parse.unit.kind OF
      = clc$lex_colon, clc$lex_dot =
        leading_name.value := osc$null_name;
        leading_name.size := 1;
      = clc$lex_name =
        #TRANSLATE (osv$lower_to_upper, file_parse.text^ (file_parse.unit_index, file_parse.unit.size),
              leading_name.value);
        leading_name.size := file_parse.unit.size;
        clp$f_scan_token (clc$slu_any, file_parse);
      ELSE
      CASEND;

      clp$f_complete_file_or_var_scan (file_parse, status);
      IF status.normal THEN
        IF file_parse.unit.kind <> clc$lex_end_of_line THEN
          osp$set_status_abnormal ('CL', cle$unexpected_after_command, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, file_parse, status);
        IFEND;
      IFEND;
      clp$insert_format_marker (clc$file_or_var_end, 0);

    ELSEIF separator = clc$lex_equal THEN
      clp$f_scan_expression (command^ (name_index, name_size), left_value_kind, variable, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      parse.index := name_index;
      clp$f_scan_token (clc$slu_non_space, parse);
    IFEND;
    IF separator <> clc$lex_space THEN
      IF separator = clc$lex_equal THEN

{ Read and record any spaces before "=".

        clp$f_scan_token (clc$slu_any, parse);
        IF parse.unit_is_space THEN
          clp$f_scan_token (clc$slu_non_space, parse);
        IFEND;

{ Read and record any spaces after "=".

        clp$f_scan_token (clc$slu_any, parse);
        IF NOT parse.unit_is_space THEN
          clp$delete_current_format_token;
        IFEND;
      ELSE
        clp$f_scan_token (clc$slu_non_space, parse);
      IFEND;
    ELSE
      clp$f_scan_token (clc$slu_non_space, parse);
      IF parse.previous_unit_is_space THEN
        clp$delete_current_format_token;
      IFEND;
    IFEND;

  PROCEND reparse_command;

MODEND clm$f_process_commands;
*DECK DECK=CLM$F_SCAN_EXPRESSION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Expression Scanner' ??
MODULE clm$f_scan_expression;

{
{ PURPOSE:
{   This module contains the SCL expression scanner.  This includes both syntactic and semantic analyzers
{   for all of the various kinds of expressions.  In particular, included are the scanners for variable
{   references, as well as evaluators for the operators.
{
{ DESIGN:
{   Expression scanning is accomplished using the technique known as "recursive descent".  This means that
{   "knowledge" of the syntax of expressions is embodied in the code rather than in syntax tables and that,
{   in general, for each syntactic construct there is a corresponding procedure to process it.  The desired
{   kind of result is used to select a starting point for the scan, but apart from that has no influence
{   during expression scanning.  Once a result has been obtained, checking for a match against the desired
{   kind of result is performed and, if appropriate, conversion or variable dereferencing performed.
{     Names encounterred in an expression are evaluated under the following rules:
{       1.  If the name designates a "built-in" function the function is evaluated.
{       2.  If the name is immediately followed by a "(" it assumed that a subscripted variable reference has
{           been found and dereferenceing takes place.
{       3.  If the name is followed a "." then:
{             a.  if the name designates a variable it is assumed that a field reference to that variable
{                 is being made and dereferencing takes place
{             b.  otherwise it is assumed that a file reference has been found and it is evaluated.
{       4.  If the name is the operand of one of the expression operators it is assumed to be a "simple"
{           variable reference and dereferencing takes place.
{       5.  If a name is the result of complete evaluation of the expression then:
{             a.  if the desired kind of result is string, boolean, integer, real or status, variable
{                 dereferenceing takes place
{             b.  if the desired kind of result is file, the name is "converted" to a file reference
{             c.  if the desired kind of result is variable, the name is "converted" to a variable
{                 reference.
{     Each scanning procedure receives the first token of its part of the expression and, in addition
{   to returning its primary result, returns the token that follows its part of the expression, and
{   causes the updating of the text index parameters which keep track of the current scan position.
{

?? NEWTITLE := 'Global Declarations' ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_limits
*copyc cld$value
*copyc cld$variable_reference
*copyc cle$ecc_expression
*copyc cle$ecc_expression_result
*copyc cle$ecc_function_processing
*copyc cle$ecc_lexical
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_scl_formatter
*copyc clt$command_line_size
*copyc clt$lexical_unit_kinds
*copyc clt$value_kind_specifier
*copyc oss$job_paged_literal
*copyc ost$status
*copyc ost$string
?? POP ??
*copyc clp$append_status_parse_state
*copyc clp$delete_current_format_token
*copyc clp$delete_node_format_token
*copyc clp$evaluate_numeric_literal
*copyc clp$f_add_node_value
*copyc clp$f_scan_argument_list
*copyc clp$f_scan_parameter_list
*copyc clp$f_scan_token
*copyc clp$f_set_tree_marker
*copyc clp$initialize_parse_state
*copyc clp$insert_format_marker
*copyc clp$isolate_balanced_text
*copyc clp$isolate_text_via_separator
*copyc clp$recognize_format_tokens
*copyc clp$scan_balanced_parenthesis
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper

  VAR
    clv$substitution_mark: [XDCL]  string (1) := ' ';

?? TITLE := 'clp$f_scan_expression', EJECT ??
*copyc clh$scan_expression

  PROCEDURE [XDCL, #GATE] clp$f_scan_expression
    (    expression: string ( * );
         value_kind_specifier: clt$value_kind_specifier;
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      parse: clt$parse_state,
      new_token_index: integer,
      token: clt$token_array_index,
      token_index: integer;

    status.normal := TRUE;
    clp$initialize_parse_state (^expression, NIL, parse);
    clp$f_scan_token (clc$slu_non_space, parse);
    clp$f_get_token_index (token_index);
    clp$f_evaluate_expression (value_kind_specifier, FALSE, FALSE, parse, value, local_status);
    IF (parse.unit.kind <> clc$lex_end_of_line) AND (parse.unit.kind <> clc$lex_comma) AND
          (NOT parse.previous_unit_is_space) AND (NOT parse.unit_is_space) THEN
      osp$set_status_abnormal ('CL', cle$expecting_end_of_expression, '', local_status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, local_status);
    IFEND;
    IF local_status.normal AND (parse.unit.kind <> clc$lex_end_of_line) THEN
      clp$f_get_token_index (new_token_index);
      FOR token := new_token_index DOWNTO token_index DO
        clp$delete_node_format_token (token);
      FOREND;
    IFEND;
    status := local_status;

  PROCEND clp$f_scan_expression;
?? TITLE := 'clv$value_descriptors', EJECT ??

  VAR
    clv$value_descriptors: [READ, oss$job_paged_literal] array [clc$variable_reference .. clc$status_value] of
          string (8) := ['VARIABLE', 'FILE', 'NAME', 'STRING', 'REAL', 'INTEGER', 'BOOLEAN', 'STATUS'];

?? TITLE := 'expression_scanners table', EJECT ??

  TYPE
    expression_kinds = (operand_expression, numeric_expression, string_expression, general_expression);

  VAR
    expression_kind_selector: [STATIC, READ, oss$job_paged_literal] array
          [clc$unspecified_value .. clc$keyword_value] of expression_kinds := [
          {} operand_expression {clc$unspecified_value} ,
          {} * {clc$application_value} ,
          {} operand_expression {clc$variable_reference} ,
          {} operand_expression {clc$file_value} ,
          {} operand_expression {clc$name_value} ,
          {} string_expression {clc$string_value} ,
          {} numeric_expression {clc$real_value} ,
          {} numeric_expression {clc$integer_value} ,
          {} general_expression {clc$boolean_value} ,
          {} operand_expression {clc$status_value} ,
          {} general_expression {clc$any_value} ,
          {} * {clc$cobol_name_value} ,
          {} * {clc$date_time_value} ,
          {} * {clc$entry_point_reference_value} ,
          {} operand_expression {clc$keyword_value} ];

  VAR
    expression_scanners: [STATIC, READ, oss$job_paged_literal] array [expression_kinds] of ^procedure
           (    expression_kind: expression_kinds;
                evaluate: boolean;
            VAR parse {input, output} : clt$parse_state;
            VAR value: clt$value;
            VAR status: ost$status) := [^scan_operand, ^scan_term_5, ^scan_term_4, ^scan_term_0];

  VAR
    spaces_before_not_part_of_token: [STATIC, READ, oss$job_paged_literal] set of clt$lexical_unit_kind :=
          [clc$lex_unknown, clc$lex_dot, clc$lex_colon, clc$lex_left_parenthesis, clc$lex_query, clc$lex_add,
          clc$lex_subtract, clc$lex_string, clc$lex_name, clc$lex_unsigned_decimal, clc$lex_alpha_number];


  TYPE
    clt$operator_representation = string (3);

?? TITLE := 'clp$f_expression_scanner', EJECT ??
*copyc clh$expression_scanner

  PROCEDURE [XDCL] clp$f_expression_scanner
    (    value_kind_specifier: clt$value_kind_specifier;
         control_expression: boolean;
     VAR parse {input, output} : clt$parse_state;
     VAR value: clt$value;
     VAR status: ost$status);


    status.normal := TRUE;

{ Scan SCL expression or application value.

    expression_scanners [expression_kind_selector [value_kind_specifier.kind]]^
          (expression_kind_selector [value_kind_specifier.kind], TRUE, parse, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT control_expression THEN
      WHILE parse.unit_index < parse.index_limit DO
        scan_operand (expression_kind_selector [value_kind_specifier.kind], TRUE, parse, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      WHILEND;
    IFEND;

  PROCEND clp$f_expression_scanner;
?? TITLE := 'clp$f_evaluate_expression', EJECT ??

{   NOTE: a  flag referred to as EVALUATE is passed among the various parts of
{ the expression scanner.  It is  initially  set  to  TRUE  to  indicate  that
{ operators,  function calls, nested expressions, and variable references will
{ be evaluated.  When it is set to FALSE, these things are only scanned  (i.e.
{ not interpreted or evaluated).  The flag is set to FALSE prior to processing
{ the right operand of an AND operator whose left operand is FALSE  or  an  OR
{ operator whose left operand is TRUE.
{

  PROCEDURE [XDCL] clp$f_evaluate_expression
    (    value_kind_specifier: clt$value_kind_specifier;
         control_expression: boolean;
         parameter: boolean;
     VAR parse {input, output} : clt$parse_state;
     VAR value: clt$value;
     VAR status: ost$status);


?? TITLE := 'check_for_and_handle_range', EJECT ??

    PROCEDURE [INLINE] check_for_and_handle_range;

      VAR
        local_parse: clt$parse_state;


{ scan low value of range

      scan_value;
      IF status.normal AND (parse.index <> parse.index_limit) THEN
        IF parse.unit.kind <> clc$lex_ellipsis THEN
          local_parse := parse;
          clp$recognize_format_tokens (FALSE);
          clp$f_scan_token (clc$slu_non_space, local_parse);
          clp$recognize_format_tokens (TRUE);
          IF local_parse.unit.kind = clc$lex_ellipsis THEN
            clp$f_scan_token (clc$slu_non_space, parse);
          IFEND;
        IFEND;
        IF parse.unit.kind = clc$lex_ellipsis THEN

{ scan high value of range

          clp$f_scan_token (clc$slu_non_space, parse);
          scan_value;
        IFEND;
      IFEND;

    PROCEND check_for_and_handle_range;
?? TITLE := 'scan_value', EJECT ??

    PROCEDURE [INLINE] scan_value;

      VAR
        text_index: clt$command_line_index,
        expression_index: clt$command_line_index;

      IF parameter THEN
        clp$delete_current_format_token;
        expression_index := parse.unit_index;
        clp$isolate_balanced_text (parse.text^, expression_index, text_index);
        parse.index := text_index;
        scan_expression (parse.text^ (expression_index, text_index - expression_index));
      ELSE
        clp$f_expression_scanner (value_kind_specifier, control_expression, parse, value, status);
        clp$f_scan_token (clc$slu_non_space, parse);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND scan_value;
?? TITLE := 'check_for_handle_nested_range', EJECT ??

    PROCEDURE [INLINE] check_for_handle_nested_range;

      VAR
        local_parse: clt$parse_state;


{ scan low value of range

      scan_nested_value;
      IF status.normal AND (parse.index <> parse.index_limit) THEN
        IF parse.unit.kind <> clc$lex_ellipsis THEN
          local_parse := parse;
          clp$recognize_format_tokens (FALSE);
          clp$f_scan_token (clc$slu_non_space, local_parse);
          clp$recognize_format_tokens (TRUE);
          IF local_parse.unit.kind = clc$lex_ellipsis THEN
            clp$f_scan_token (clc$slu_non_space, parse);
          IFEND;
        IFEND;
        IF parse.unit.kind = clc$lex_ellipsis THEN

{ scan high value of range

          clp$f_scan_token (clc$slu_non_space, parse);
          scan_nested_value;
        IFEND;
      IFEND;

    PROCEND check_for_handle_nested_range;
?? TITLE := 'scan_nested_value', EJECT ??

    PROCEDURE [INLINE] scan_nested_value;

      VAR
        text_index: clt$command_line_index,
        expression_index: clt$command_line_index;

      clp$delete_current_format_token;
      expression_index := parse.unit_index;
      clp$isolate_balanced_text (parse.text^, expression_index, text_index);
      parse.index := text_index;
      scan_expression (parse.text^ (expression_index, text_index - expression_index));
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND scan_nested_value;
?? TITLE := 'scan_expression', EJECT ??

    PROCEDURE [INLINE] scan_expression
      (    expression: string ( * ));

      VAR
        new_token_index: integer,
        parse: clt$parse_state,
        token: clt$token_array_index,
        token_index: integer;

      status.normal := TRUE;
      clp$initialize_parse_state (^expression, NIL, parse);
      clp$f_scan_token (clc$slu_non_space, parse);
      clp$f_get_token_index (token_index);

      clp$f_expression_scanner (value_kind_specifier, control_expression, parse, value, status);
      IF (parse.unit.kind <> clc$lex_end_of_line) THEN
        clp$f_get_token_index (new_token_index);
        FOR token := new_token_index DOWNTO token_index DO
          clp$delete_node_format_token (token);
        FOREND;
      IFEND;

    PROCEND scan_expression;
?? TITLE := 'scan_parenthesized_list', EJECT ??

    PROCEDURE scan_parenthesized_list
      (VAR parse: clt$parse_state;
           parameter: boolean);

      VAR
        text_index: clt$command_line_index,
        start_index: integer,
        end_index: integer,
        token: clt$token_array_index,
        expression_index: clt$command_line_index;


      status.normal := TRUE;
      IF parse.unit.kind = clc$lex_left_parenthesis THEN

      /try_list/
        BEGIN
          expression_index := parse.unit_index;
          clp$f_get_token_index (start_index);
          clp$insert_format_marker (clc$value_begin, 1);
          clp$f_scan_token (clc$slu_non_space, parse);
          IF parse.unit.kind = clc$lex_right_parenthesis THEN
            clp$insert_format_marker (clc$value_end, 1);
            clp$f_scan_token (clc$slu_non_space, parse);
            RETURN;
          IFEND;

        /scan_list/
          WHILE TRUE DO
            IF parameter THEN
              scan_parenthesized_list (parse, parameter);
            ELSE
              clp$delete_current_format_token;
              clp$scan_balanced_parenthesis (parse.text^, parse.unit_index, text_index);
              clp$initialize_parse_state (^parse.text^ (parse.unit_index, text_index - parse.unit_index), NIL,
                    local_parse);
              clp$f_scan_token (clc$slu_non_space, local_parse);
              parse.index := text_index;
              scan_parenthesized_list (local_parse, parameter);
            IFEND;
            IF NOT status.normal THEN
              EXIT /try_list/;
            IFEND;
            IF (parse.unit.kind <> clc$lex_right_parenthesis) AND
                  (parse.unit.kind <> clc$lex_left_parenthesis) THEN
              clp$f_scan_token (clc$slu_non_space, parse);
            IFEND;
            CASE parse.unit.kind OF
            = clc$lex_end_of_line =
              osp$set_status_abnormal ('CL', cle$expecting_rparen, '', status);
              EXIT /try_list/;
            = clc$lex_right_parenthesis =
              clp$insert_format_marker (clc$value_end, 1);
              clp$f_scan_token (clc$slu_non_space, parse);
              EXIT /scan_list/;
            = clc$lex_comma, clc$lex_ellipsis =
              clp$insert_format_marker (clc$value_end, 1);
              clp$f_scan_token (clc$slu_non_space, parse);
            ELSE
              IF (parse.unit.kind IN spaces_before_not_part_of_token) AND parse.previous_unit_is_space THEN
                clp$insert_format_marker (clc$value_end, 1);
              ELSE
                osp$set_status_abnormal ('CL', cle$expecting_end_of_expression, '', status);
                clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
                EXIT /try_list/;
              IFEND;
            CASEND;
          WHILEND /scan_list/;
        END /try_list/;

        IF (NOT status.normal) THEN

{ not a list

          status.normal := TRUE;
          clp$f_get_token_index (end_index);
          FOR token := end_index DOWNTO start_index + 1 DO
            clp$delete_node_format_token (token);
            clp$delete_current_format_token;
          FOREND;
          parse.index := expression_index;
          clp$f_scan_token (clc$slu_non_space, parse);
          clp$f_expression_scanner (value_kind_specifier, control_expression, parse, value, status);
        IFEND;
      ELSE
        clp$insert_format_marker (clc$value_begin, 1);
        check_for_handle_nested_range;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    PROCEND scan_parenthesized_list;
?? OLDTITLE, EJECT ??

    VAR
      text_index: clt$command_line_index,
      start_index: integer,
      end_index: integer,
      token: clt$token_array_index,
      expression_index: clt$command_line_index,
      saved_parse: clt$parse_state,
      local_parse: clt$parse_state;


    status.normal := TRUE;
    IF parse.unit.kind = clc$lex_left_parenthesis THEN

    /try_list/
      BEGIN
        expression_index := parse.unit_index;
        clp$f_get_token_index (start_index);
        clp$insert_format_marker (clc$value_set_begin, 0);
        clp$f_scan_token (clc$slu_non_space, parse);
        IF parse.unit.kind = clc$lex_right_parenthesis THEN
          clp$insert_format_marker (clc$value_set_end, 1);
          clp$f_scan_token (clc$slu_non_space, parse);
          RETURN;
        IFEND;

      /scan_list/
        WHILE TRUE DO
          IF parse.unit.kind = clc$lex_left_parenthesis THEN
            saved_parse := parse;
            clp$f_scan_token (clc$slu_non_space, saved_parse);
            clp$delete_current_format_token;
            IF saved_parse.unit.kind = clc$lex_left_parenthesis THEN
              clp$f_evaluate_expression (value_kind_specifier, control_expression, parameter, parse, value,
                    status);
            ELSE
              scan_parenthesized_list (parse, TRUE);
            IFEND;
          ELSE
            scan_parenthesized_list (parse, parameter);
            clp$f_scan_token (clc$slu_any, parse);
          IFEND;
          IF NOT status.normal THEN
            EXIT /try_list/;
          IFEND;
          IF parse.unit.kind = clc$lex_space THEN
            clp$f_scan_token (clc$slu_non_space, parse);
          IFEND;
          CASE parse.unit.kind OF
          = clc$lex_end_of_line =
            osp$set_status_abnormal ('CL', cle$expecting_rparen, '', status);
            EXIT /try_list/;
          = clc$lex_right_parenthesis =
            clp$insert_format_marker (clc$value_set_end, 1);
            clp$f_scan_token (clc$slu_non_space, parse);
            EXIT /scan_list/;
          = clc$lex_comma, clc$lex_ellipsis =
            clp$insert_format_marker (clc$value_end, 1);
            clp$f_scan_token (clc$slu_non_space, parse);
          ELSE
            IF (parse.unit.kind IN spaces_before_not_part_of_token) AND parse.previous_unit_is_space THEN
              clp$insert_format_marker (clc$value_end, 1);
            ELSE
              osp$set_status_abnormal ('CL', cle$expecting_end_of_expression, '', status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT /try_list/;
            IFEND;
          CASEND;
        WHILEND /scan_list/;
      END /try_list/;

      IF (NOT status.normal) OR
            ((NOT parameter) AND (parse.unit.kind <> clc$lex_right_parenthesis) AND
            (parse.unit.kind <> clc$lex_end_of_line)) THEN

{ not a list

        status.normal := TRUE;
        clp$f_get_token_index (end_index);
        FOR token := end_index DOWNTO start_index DO
{         clp$delete_node_format_token (token);
          clp$delete_current_format_token;
        FOREND;
        parse.unit_index := expression_index;
        parse.index := expression_index;
        clp$f_scan_token (clc$slu_non_space, parse);
        clp$f_expression_scanner (value_kind_specifier, control_expression, parse, value, status);
      IFEND;
    ELSE
      clp$insert_format_marker (clc$value_begin, 1);
      check_for_and_handle_range;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$f_scan_token (clc$slu_any, parse);
    IFEND;

  PROCEND clp$f_evaluate_expression;
?? TITLE := 'clp$f_set_substitution_mark', EJECT ??

  PROCEDURE [XDCL] clp$f_set_substitution_mark
    (    substitution_mark: string (1));

    clv$substitution_mark := substitution_mark;

  PROCEND clp$f_set_substitution_mark;
?? TITLE := 'scan_operand', EJECT ??

  PROCEDURE scan_operand
    (    expression_kind: expression_kinds;
         evaluate: boolean;
     VAR parse {input, output} : clt$parse_state;
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      name: clt$name,
      name_is_constant: boolean,
      number: clt$number,
      offset: 0 .. 2,
      sign: -1 .. 1,
      first_string_unit: boolean,
      string_complete: boolean,
      string_unit_size: clt$string_size,
      translate_name_kludge: ^string ( * <= osc$max_name_size),
      parameter_list_string: ost$string,
      save_parse: clt$parse_state,
      text_index: clt$command_line_index,
      ignore_extra_element: clt$name;

    status.normal := TRUE;
    IF parse.unit_is_space THEN
      clp$f_scan_token (clc$slu_non_space, parse);
    IFEND;
    CASE parse.unit.kind OF
    = clc$lex_long_name =
      osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
            status);
      RETURN;
    = clc$lex_unterminated_string =
      osp$set_status_abnormal ('CL', cle$missing_string_delimiter, parse.
            text^ (parse.unit_index, parse.unit.size), status);
      RETURN;
    = clc$lex_colon, clc$lex_dot =
      clp$insert_format_marker (clc$file_or_var_begin, 1);
      clp$f_complete_file_or_var_scan (parse, status);
      IF status.normal THEN
        IF parse.unit.kind <> clc$lex_end_of_line THEN
          clp$insert_format_marker (clc$file_or_var_end, 1);
        ELSE
          clp$insert_format_marker (clc$file_or_var_end, 0);
        IFEND;
      IFEND;
      RETURN;

    = clc$lex_name =
      name.value := parse.text^ (parse.unit_index, parse.unit.size);
      name.size := parse.unit.size;
      clp$f_scan_token (clc$slu_any, parse);
      CASE parse.unit.kind OF

      = clc$lex_left_parenthesis =

        IF name.value (1) = '$' THEN {have function
          clp$insert_format_marker (clc$function_begin, 2);
          IF parse.unit_index + 1 = parse.index_limit THEN
            osp$set_status_abnormal ('CL', cle$expecting_rparen_of_alist, name.value (1, name.size), status);
            RETURN;
          IFEND;
          clp$isolate_text_via_separator (clc$ibt_stop_on_balanced, parse.text^, parse.unit_index,
                text_index);
          clp$f_scan_argument_list (name, parse.text^ (parse.unit_index + 1,
                text_index - parse.unit_index - 2), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          parse.index := text_index - 1;
          clp$f_scan_token (clc$slu_non_space, parse);
          IF parse.unit.kind <> clc$lex_right_parenthesis THEN
            osp$set_status_abnormal ('CL', cle$expecting_rparen_of_alist, ' ', status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            RETURN;
          IFEND;
          clp$insert_format_marker (clc$function_end, 0);
          clp$f_scan_token (clc$slu_any, parse);
          clp$insert_format_marker (clc$file_or_var_begin, 1);
          clp$f_complete_file_or_var_scan (parse, status);
          IF status.normal THEN
            IF parse.unit.kind <> clc$lex_end_of_line THEN
              clp$insert_format_marker (clc$file_or_var_end, 1);
            ELSE
              clp$insert_format_marker (clc$file_or_var_end, 0);
            IFEND;
          IFEND;
        ELSE {variable
          clp$insert_format_marker (clc$file_or_var_begin, 2);
          clp$f_complete_file_or_var_scan (parse, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF parse.unit.kind <> clc$lex_end_of_line THEN
            clp$insert_format_marker (clc$file_or_var_end, 1);
          ELSE
            clp$insert_format_marker (clc$file_or_var_end, 0);
          IFEND;
        IFEND;

      = clc$lex_dot =
        clp$insert_format_marker (clc$file_or_var_begin, 2);
        clp$f_complete_file_or_var_scan (parse, status);
        IF parse.unit.kind <> clc$lex_end_of_line THEN
          clp$insert_format_marker (clc$file_or_var_end, 1);
        ELSE
          clp$insert_format_marker (clc$file_or_var_end, 0);
        IFEND;

      ELSE
        IF name.value (1) = '$' THEN
          IF parse.unit.kind = clc$lex_end_of_line THEN
            offset := 1;
          ELSE
            offset := 2;
          IFEND;
          clp$insert_format_marker (clc$function_begin, offset);
          clp$insert_format_marker (clc$function_end, offset - 1);
        IFEND;
      CASEND;
      IF parse.unit_is_space THEN
        clp$f_scan_token (clc$slu_non_space, parse);
      IFEND;
      RETURN;
    = clc$lex_unsigned_decimal, clc$lex_alpha_number =
      sign := 1;

{ NOTE:
{      Since clp$evaluate_numeric_literal does not add format tokens,
{      that action must be taken here upon return.

      save_parse := parse;
      clp$evaluate_numeric_literal (sign, 10, parse, number, status);
      IF status.normal THEN
        IF number.kind = clc$integer_number THEN
          value.descriptor := clv$value_descriptors [clc$integer_value];
          value.kind := clc$integer_value;
          value.int := number.integer_number;
        ELSE
          value.descriptor := clv$value_descriptors [clc$real_value];
          value.kind := clc$real_value;
          value.rnum := number.real_number
        IFEND;
        WHILE save_parse.index < parse.index DO
          clp$f_scan_token (clc$slu_any, save_parse);
        WHILEND;

{ Check for time_increment

        WHILE parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_unsigned_decimal, clc$lex_subtract,
              clc$lex_colon, clc$lex_dot] DO
          clp$f_scan_token (clc$slu_any, parse);
        WHILEND;

        IF parse.unit_is_space THEN
          clp$f_scan_token (clc$slu_non_space, parse);
        IFEND;
        RETURN;
      IFEND;

    = clc$lex_string =
      value.descriptor := clv$value_descriptors [clc$string_value];
      value.kind := clc$string_value;

      value.str.size := 0;
      value.str.value := ' ';
      first_string_unit := TRUE;
      REPEAT
        IF NOT first_string_unit THEN
          IF value.str.size = osc$max_string_size THEN
            osp$set_status_abnormal ('CL', cle$string_too_long, value.str.value (1, value.str.size), status);
            RETURN;
          IFEND;
          value.str.size := value.str.size + 1;
          value.str.value (value.str.size) := '''';
        IFEND;
        string_unit_size := parse.unit.size - 2;
        IF (value.str.size + string_unit_size) > osc$max_string_size THEN
          osp$set_status_abnormal ('CL', cle$string_too_long, value.str.value (1, value.str.size), status);
          RETURN;
        IFEND;
        value.str.value (value.str.size + 1, string_unit_size) :=
              parse.text^ (parse.unit_index + 1, string_unit_size);
        value.str.size := value.str.size + string_unit_size;
        first_string_unit := FALSE;
        clp$f_scan_token (clc$slu_any, parse);
      UNTIL parse.unit.kind <> clc$lex_string;
      IF parse.unit.kind = clc$lex_unterminated_string THEN
        osp$set_status_abnormal ('CL', cle$missing_string_delimiter, parse.
              text^ (parse.unit_index, parse.unit.size), status);
      IFEND;
      IF parse.unit_is_space THEN
        clp$f_scan_token (clc$slu_non_space, parse);
      IFEND;
      RETURN;

    = clc$lex_left_parenthesis =
      clp$f_scan_token (clc$slu_non_space, parse);
      IF parse.unit.kind <> clc$lex_right_parenthesis THEN
        expression_scanners [expression_kind]^ (expression_kind, TRUE, parse, value, status);
        IF (parse.unit_is_space) OR (parse.unit.kind = clc$lex_name) THEN
          REPEAT
            clp$f_scan_token (clc$slu_non_space, parse);
          UNTIL (parse.unit.kind = clc$lex_right_parenthesis) OR (parse.unit.kind =
                clc$lex_end_of_line);
        IFEND;
      IFEND;
      IF status.normal AND (parse.unit.kind <> clc$lex_right_parenthesis) THEN
        osp$set_status_abnormal ('CL', cle$expecting_rparen, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      IFEND;

    = clc$lex_unknown =
      IF (clv$substitution_mark = ' ') OR (parse.text^ (parse.unit_index, parse.unit.size) <>
            clv$substitution_mark) THEN
        osp$set_status_abnormal ('CL', cle$internal_formatter_error, 'Unknown char in line.', status);
        RETURN;
      ELSE
        REPEAT
          clp$f_scan_token (clc$slu_non_space, parse);
        UNTIL parse.text^ (parse.unit_index, parse.unit.size) = clv$substitution_mark;
      IFEND;

    ELSE
      IF (parse.unit_index + parse.unit.size - 1) <= STRLENGTH (parse.text^) THEN
        value.descriptor := parse.text^ (parse.unit_index, parse.unit.size);
      ELSE
        value.descriptor := '';
      IFEND;
      value.kind := clc$unknown_value;
      IF ((value.descriptor(1,1) = ')') AND (parse.unit.kind = clc$lex_right_parenthesis)) THEN
        osp$set_status_abnormal ('CL', cle$unbalanced_parenthesis, '', status);
        RETURN;
      IFEND;
      clp$f_scan_token (clc$slu_any, parse);
      RETURN;
    CASEND;

    IF status.normal THEN
      clp$f_scan_token (clc$slu_non_space, parse);
    IFEND;

  PROCEND scan_operand;
?? TITLE := 'scan_term_0 (OR and XOR operators)', EJECT ??

  PROCEDURE scan_term_0
    (    expression_kind: expression_kinds;
         evaluate: boolean;
     VAR parse {input, output} : clt$parse_state;
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      insert_index: integer,
      node_encountered: boolean,
      operator_name: ost$name;

    clp$f_get_token_index (insert_index);
    node_encountered := FALSE;
    scan_term_1 (expression_kind, evaluate, parse, value, status);
    WHILE status.normal DO
      IF parse.unit_is_space THEN
        clp$f_scan_token (clc$slu_non_space, parse);
      IFEND;
      IF parse.unit.kind = clc$lex_name THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), operator_name);
        IF NOT ((operator_name = 'OR') OR (operator_name = 'XOR')) THEN
          IF node_encountered THEN
            clp$f_set_tree_marker (clc$or_node, insert_index, parse.unit.kind = clc$lex_end_of_line);
          IFEND;
          RETURN;
        IFEND;
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$missing_spaces_before, operator_name, status);
          RETURN;
        IFEND;
      ELSE
        IF node_encountered THEN
          clp$f_set_tree_marker (clc$or_node, insert_index, parse.unit.kind = clc$lex_end_of_line);
        IFEND;
        RETURN;
      IFEND;
      node_encountered := TRUE;
      clp$f_add_node_value (clc$or_node);
      clp$f_scan_token (clc$slu_non_space, parse);
      IF NOT parse.previous_unit_is_space THEN
        osp$set_status_abnormal ('CL', cle$missing_spaces_after, operator_name, status);
        RETURN;
      IFEND;
      IF status.normal THEN
        scan_term_1 (expression_kind, FALSE, parse, value, status);
      IFEND;
    WHILEND;

  PROCEND scan_term_0;
?? TITLE := 'scan_term_1 (AND operator)', EJECT ??

  PROCEDURE scan_term_1
    (    expression_kind: expression_kinds;
         evaluate: boolean;
     VAR parse {input, output} : clt$parse_state;
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      insert_index: integer,
      node_encountered: boolean,
      operator_name: ost$name;

    node_encountered := FALSE;
    clp$f_get_token_index (insert_index);
    scan_term_2 (expression_kind, evaluate, parse, value, status);
    WHILE status.normal DO
      IF parse.unit_is_space THEN
        clp$f_scan_token (clc$slu_non_space, parse);
      IFEND;
      IF parse.unit.kind = clc$lex_name THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), operator_name);
        IF operator_name <> 'AND' THEN
          IF node_encountered THEN
            clp$f_set_tree_marker (clc$and_node, insert_index, parse.unit.kind = clc$lex_end_of_line);
          IFEND;
          RETURN;
        IFEND;
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$missing_spaces_before, operator_name, status);
          osp$set_status_abnormal ('CL', cle$missing_spaces_before, operator_name, status);
          RETURN;
        IFEND;
      ELSE
        IF node_encountered THEN
          clp$f_set_tree_marker (clc$and_node, insert_index, parse.unit.kind = clc$lex_end_of_line);
        IFEND;
        RETURN;
      IFEND;
      node_encountered := TRUE;
      clp$f_add_node_value (clc$and_node);
      clp$f_scan_token (clc$slu_non_space, parse);
      IF NOT parse.previous_unit_is_space THEN
        osp$set_status_abnormal ('CL', cle$missing_spaces_after, operator_name, status);
        RETURN;
      IFEND;
      scan_term_2 (expression_kind, evaluate, parse, value, status);
    WHILEND;

  PROCEND scan_term_1;
?? TITLE := 'scan_term_2 (NOT operator)', EJECT ??

  PROCEDURE scan_term_2
    (    expression_kind: expression_kinds;
         evaluate: boolean;
     VAR parse {input, output} : clt$parse_state;
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      insert_index: integer,
      operator_name: ost$name;

    IF parse.unit_is_space THEN
      clp$f_scan_token (clc$slu_non_space, parse);
    IFEND;
    IF parse.unit.kind = clc$lex_name THEN
      #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), operator_name);
    ELSE
      operator_name := '';
    IFEND;
    IF operator_name = 'NOT' THEN
      clp$f_get_token_index (insert_index);
      clp$f_add_node_value (clc$not_node);
      status.normal := TRUE;
      clp$f_scan_token (clc$slu_non_space, parse);
      IF NOT parse.previous_unit_is_space THEN
        osp$set_status_abnormal ('CL', cle$missing_spaces_after, operator_name, status);
        RETURN;
      IFEND;
      scan_term_3 (expression_kind, evaluate, parse, value, status);
      IF status.normal THEN
        clp$f_set_tree_marker (clc$not_node, insert_index, parse.unit.kind = clc$lex_end_of_line);
      IFEND;
    ELSE
      scan_term_3 (expression_kind, evaluate, parse, value, status);
    IFEND;

  PROCEND scan_term_2;
?? TITLE := 'scan_term_3 (>, >=, < , <=, = and <> operators)', EJECT ??

  PROCEDURE scan_term_3
    (    expression_kind: expression_kinds;
         evaluate: boolean;
     VAR parse {input, output} : clt$parse_state;
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      relational_operators: [STATIC, READ, oss$job_paged_literal] set of clt$lexical_unit_kind :=
            [clc$lex_greater_than, clc$lex_greater_equal, clc$lex_less_than, clc$lex_less_equal,
            clc$lex_equal, clc$lex_not_equal],
      insert_index: integer,
      node_encountered: boolean;

    clp$f_get_token_index (insert_index);
    node_encountered := FALSE;
    scan_term_4 (expression_kind, evaluate, parse, value, status);
    WHILE status.normal AND (parse.unit.kind IN relational_operators) DO
      node_encountered := TRUE;
      clp$f_add_node_value (clc$rel_node);
      clp$f_scan_token (clc$slu_non_space, parse);
      scan_term_4 (expression_kind, FALSE, parse, value, status);
    WHILEND;
    IF node_encountered THEN
      clp$f_set_tree_marker (clc$rel_node, insert_index, parse.unit.kind = clc$lex_end_of_line);
    IFEND;

  PROCEND scan_term_3;
?? TITLE := 'scan_term_4 (// operator)', EJECT ??

  PROCEDURE scan_term_4
    (    expression_kind: expression_kinds;
         evaluate: boolean;
     VAR parse {input, output} : clt$parse_state;
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      insert_index: integer,
      node_encountered: boolean;

    node_encountered := FALSE;
    clp$f_get_token_index (insert_index);
    IF expression_kind = string_expression THEN
      scan_operand (expression_kind, evaluate, parse, value, status);
    ELSE
      scan_term_5 (expression_kind, evaluate, parse, value, status);
    IFEND;
    WHILE status.normal AND (parse.unit.kind = clc$lex_concatenate) DO
      node_encountered := TRUE;
      clp$f_add_node_value (clc$cat_node);
      clp$f_scan_token (clc$slu_non_space, parse);
      scan_term_5 (expression_kind, TRUE, parse, value, status);
    WHILEND;
    IF node_encountered THEN
      clp$f_set_tree_marker (clc$cat_node, insert_index, parse.unit.kind = clc$lex_end_of_line);
    IFEND;

  PROCEND scan_term_4;
?? TITLE := 'scan_term_5 (+ and - operators)', EJECT ??

  PROCEDURE scan_term_5
    (    expression_kind: expression_kinds;
         evaluate: boolean;
     VAR parse {input, output} : clt$parse_state;
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      add_sub_operators: [STATIC, READ, oss$job_paged_literal] set of clt$lexical_unit_kind :=
            [clc$lex_add, clc$lex_subtract],
      unary_operator: boolean,
      save_parse: clt$parse_state,
      operator: clc$lex_add .. clc$lex_subtract,
      operator_representation: clt$operator_representation,
      insert_index: integer,
      node_encountered: boolean;

    node_encountered := FALSE;
    clp$f_get_token_index (insert_index);
    IF parse.unit_is_space THEN
      clp$f_scan_token (clc$slu_non_space, parse);
      insert_index := insert_index + 1;
    IFEND;
    unary_operator := parse.unit.kind IN add_sub_operators;
    IF unary_operator THEN
      status.normal := TRUE;
      value.descriptor := clv$value_descriptors [clc$integer_value];
      value.kind := clc$integer_value;
      value.int.radix := 10;
      value.int.radix_specified := FALSE;
      value.int.value := 0;
    ELSE
      scan_term_6 (expression_kind, evaluate, parse, value, status);
    IFEND;
    WHILE status.normal DO
      IF parse.unit.kind IN add_sub_operators THEN
        node_encountered := TRUE;
        clp$f_add_node_value (clc$add_node);
      ELSE
        IF node_encountered THEN
          clp$f_set_tree_marker (clc$add_node, insert_index, parse.unit.kind = clc$lex_end_of_line);
        IFEND;
        RETURN;
      IFEND;
      clp$f_scan_token (clc$slu_non_space, parse);
      scan_term_6 (expression_kind, FALSE, parse, value, status);
    WHILEND;

  PROCEND scan_term_5;
?? TITLE := 'scan_term_6 (* and / operators)', EJECT ??

  PROCEDURE scan_term_6
    (    expression_kind: expression_kinds;
         evaluate: boolean;
     VAR parse {input, output} : clt$parse_state;
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      mult_div_operators: [STATIC, READ, oss$job_paged_literal] set of clt$lexical_unit_kind :=
            [clc$lex_multiply, clc$lex_divide],
      insert_index: integer,
      node_encountered: boolean;

    node_encountered := FALSE;
    clp$f_get_token_index (insert_index);
    scan_term_7 (expression_kind, evaluate, parse, value, status);
    WHILE status.normal AND (parse.unit.kind IN mult_div_operators) DO
      clp$f_add_node_value (clc$mul_node);
      node_encountered := TRUE;
      clp$f_scan_token (clc$slu_non_space, parse);
      scan_term_7 (expression_kind, FALSE, parse, value, status);
    WHILEND;
    IF node_encountered THEN
      clp$f_set_tree_marker (clc$mul_node, insert_index, parse.unit.kind = clc$lex_end_of_line);
    IFEND;

  PROCEND scan_term_6;
?? TITLE := 'scan_term_7 (** operator)', EJECT ??

  PROCEDURE scan_term_7
    (    expression_kind: expression_kinds;
         evaluate: boolean;
     VAR parse {input, output} : clt$parse_state;
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      insert_index: integer,
      node_encountered: boolean;

    node_encountered := FALSE;
    clp$f_get_token_index (insert_index);
    scan_operand (expression_kind, evaluate, parse, value, status);
    WHILE status.normal AND (parse.unit.kind = clc$lex_exponentiate) DO
      clp$f_add_node_value (clc$exp_node);
      node_encountered := TRUE;
      clp$f_scan_token (clc$slu_non_space, parse);
      scan_operand (expression_kind, FALSE, parse, value, status);
    WHILEND;
    IF node_encountered THEN
      clp$f_set_tree_marker (clc$exp_node, insert_index, parse.unit.kind = clc$lex_end_of_line);
      RETURN;
    IFEND;

  PROCEND scan_term_7;
?? TITLE := 'clp$f_complete_file_or_var_scan', EJECT ??

  PROCEDURE [XDCL] clp$f_complete_file_or_var_scan
    (VAR parse {input, output} : clt$parse_state;
     VAR status: ost$status);

    VAR
      nesting_level: clt$string_size;

    status.normal := TRUE;

    nesting_level := 0;

  /scan/
    WHILE parse.unit.kind <> clc$lex_end_of_line DO
      CASE parse.unit.kind OF
      = clc$lex_colon, clc$lex_dot, clc$lex_concatenate =
        clp$f_scan_token (clc$slu_any, parse);
      = clc$lex_left_parenthesis =
        nesting_level := nesting_level + 1;
      = clc$lex_right_parenthesis =
        IF nesting_level <= 0 THEN
          EXIT /scan/;
        IFEND;
        nesting_level := nesting_level - 1;
      ELSE
        IF nesting_level <= 0 THEN
          EXIT /scan/;
        IFEND;
      CASEND;
      clp$f_scan_token (clc$slu_any, parse);
    WHILEND /scan/;
    IF nesting_level <> 0 THEN
      osp$set_status_abnormal ('CL', 55555, 'Unbalanced parens', status); {||
    IFEND;

  PROCEND clp$f_complete_file_or_var_scan;

MODEND clm$f_scan_expression;
*DECK DECK=CLM$F_SCAN_PARAMETER_LIST EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Parameter List Scanner' ??
MODULE clm$f_scan_parameter_list;

{ NOTE: This module is a modification of the SCL Interpreter module CLM$SCAN_PARAMETER_LIST


?? NEWTITLE := 'Global Declarations' ??
?? NEWTITLE := 'Parameter Descriptor Table (PDT)', EJECT ??
*copyc clt$parameter_descriptor_table
?? OLDTITLE, EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc cle$ecc_expression_result
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_parameter_list
*copyc clt$command_line
*copyc clt$command_line_index
*copyc clt$command_line_size
*copyc oss$job_paged_literal
*copyc ost$status
*copyc ost$string
?? POP ??
*copyc clp$append_status_parse_state
*copyc clp$delete_current_format_token
*copyc clp$f_evaluate_expression
*copyc clp$f_scan_expression
*copyc clp$f_scan_token
*copyc clp$initialize_parse_state
*copyc clp$insert_format_marker
*copyc clp$recognize_format_tokens
*copyc clp$set_format_type
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper

?? TITLE := 'clp$f_scan_parameter_list', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$f_scan_parameter_list
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      number_of_parameters: 0 .. clc$max_parameters,
      parameter_name_indices: ^array [1 .. * ] of 0 .. clc$max_parameter_names,
      parameter_number: 1 .. clc$max_parameters + 1,
      parameter_list_ptr: ^clt$parameter_list,
      text_ptr: ^string ( * ),
      text_size_ptr: ^clt$command_line_size,
      parse: clt$parse_state,
      local_status: ost$status;

  /scan/
    BEGIN
      local_status.normal := TRUE;
      status.normal := TRUE;
      parameter_list_ptr := ^parameter_list;
      text_ptr := NIL;
      RESET parameter_list_ptr;
      NEXT text_size_ptr IN parameter_list_ptr;
      IF (text_size_ptr <> NIL) AND (text_size_ptr^ <= clc$max_command_line_size) THEN
        NEXT text_ptr: [text_size_ptr^] IN parameter_list_ptr;
      IFEND;
      IF text_ptr = NIL THEN
        osp$set_status_abnormal ('CL', cle$garbled_parameter_list, '', local_status);
        EXIT /scan/;
      IFEND;
      parameter_number := 1;
      clp$initialize_parse_state (text_ptr, NIL, parse);
      clp$f_scan_token (clc$slu_non_space, parse);

      WHILE local_status.normal AND (NOT (parse.unit.kind = clc$lex_end_of_line)) DO
        IF (parse.unit.kind = clc$lex_comma) OR (parse.unit.kind = clc$lex_space) THEN
          REPEAT
            clp$insert_format_marker (clc$parameter_begin, 1);
            clp$insert_format_marker (clc$parameter_end, 1);
            parameter_number := parameter_number + 1;
            clp$f_scan_token (clc$slu_non_space, parse);
          UNTIL NOT ((parse.unit.kind = clc$lex_comma) OR (parse.unit_is_space));
        ELSE
          scan_parameter (parse, local_status);
          IF local_status.normal THEN
            IF (parse.unit.kind = clc$lex_comma) OR (parse.unit.kind = clc$lex_space) THEN
              clp$f_scan_token (clc$slu_non_space, parse);
            IFEND;
            parameter_number := parameter_number + 1;
          IFEND;
        IFEND;
      WHILEND;

    END /scan/;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;

  PROCEND clp$f_scan_parameter_list;
?? TITLE := 'scan_parameter', EJECT ??

  PROCEDURE scan_parameter
    (VAR parse {input, output} : clt$parse_state;
     VAR status: ost$status);

    VAR
      evaluating_list: boolean,
      parameter_given_by_name: boolean,
      parameter_name: ost$name,
      local_status: ost$status,
      next_parse: clt$parse_state,
      value: clt$value,
      value_kind_specifier: clt$value_kind_specifier;


    parameter_given_by_name := FALSE;
    evaluating_list := FALSE;
    clp$insert_format_marker (clc$parameter_begin, 1);
    IF parse.unit.kind = clc$lex_name THEN
      parameter_name := parse.text^ (parse.unit_index, parse.unit.size);
      next_parse := parse;
      clp$recognize_format_tokens (FALSE);
      clp$f_scan_token (clc$slu_non_space, next_parse);
      clp$recognize_format_tokens (TRUE);
      IF next_parse.unit.kind = clc$lex_assign THEN
        clp$set_format_type (clc$parameter_name);
        clp$f_scan_token (clc$slu_non_space, parse); {read the assignment unit
        parameter_given_by_name := TRUE;
        clp$f_scan_token (clc$slu_non_space, parse); {read the first unit of the parameter
      ELSE
        parameter_name := '';
      IFEND;
    IFEND;

    value_kind_specifier.kind := clc$any_value;
    IF parse.unit.kind = clc$lex_left_parenthesis THEN
      evaluating_list := TRUE;
    IFEND;
    clp$f_evaluate_expression (value_kind_specifier, FALSE, TRUE, parse, value, status);
    IF (NOT evaluating_list) AND (parse.unit.kind <> clc$lex_comma) THEN
      clp$f_scan_token (clc$slu_non_space, parse);
    IFEND;
    IF (parse.unit.kind <> clc$lex_end_of_line) AND (parse.unit.kind <> clc$lex_comma) AND
          (NOT parse.previous_unit_is_space) AND (NOT parse.unit_is_space) THEN
      osp$set_status_abnormal ('CL', cle$expecting_end_of_expression, '', status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
    IFEND;

    IF (NOT status.normal) AND (clc$min_ecc_expression_result <= status.condition) AND
          (status.condition <= clc$max_ecc_expression_result) THEN
      osp$append_status_parameter (osc$status_parameter_delimiter, ' for parameter', status);
      osp$append_status_parameter (' ', parameter_name, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF parse.unit.kind = clc$lex_end_of_line THEN
      clp$insert_format_marker (clc$parameter_end, 0);
    ELSE
      IF parse.unit.kind = clc$lex_comma THEN
        clp$insert_format_marker (clc$parameter_end, 1);
      ELSE
        clp$insert_format_marker (clc$parameter_end, 2);
      IFEND;
    IFEND;

  PROCEND scan_parameter;

MODEND clm$f_scan_parameter_list;
*DECK DECK=CLM$GENERATE_COMMAND_TABLE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Command Table Generator' ??
MODULE clm$generate_command_table;

{
{ PURPOSE:
{   This module contains the processors of the command table generator utility.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_ct_generator
*copyc cle$ecc_parsing
*copyc clt$command_table
*copyc clt$function_processor_table
*copyc clt$function_table
*copyc clt$parameter_list
*copyc clt$parameter_list_size
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc amp$fetch
*copyc amp$put_next
*copyc clp$begin_utility
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_name
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$get_command_origin
*copyc clp$get_parameter_list_text
*copyc clp$include_file
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc mmp$create_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc osv$upper_to_lower
*copyc pmp$exit
?? EJECT ??

  TYPE
    entry = record
      name: ost$name,
      class: clt$named_entry_class,
      availability: clt$named_entry_availability,
      ordinal: integer,
      log_option: clt$command_log_option,
      call_method: clt$call_method,
      procedure_name: ost$name,
    recend;

  TYPE
    chunk_array = array [1 .. clc$max_command_chunk] of record
      position: integer,
      length: integer,
    recend;

  TYPE
    type_record = record
      size: 0 .. max_line_size,
      line: string (max_line_size),
    recend;

  CONST
    max_line_size = 79,
    number_of_common_lines = 69,
    number_of_command_lines = 40,
    number_of_function_lines = 185;

  CONST
    prompt_string = 'ctg',
    prompt_string_size = 3;

  CONST
    clc$max_command_chunk = clc$max_parameter_list_size DIV osc$max_name_size,
    min_page_width = 79,
    max_page_width = 110;

  VAR
    entry_array: [STATIC] ^array [1 .. * ] of entry,
    entry_count: [STATIC] integer := 0,
    module_name: [STATIC] ost$name,
    module_name_size: [STATIC] integer,
    name_size: [STATIC] integer,
    new_table_started: [STATIC] boolean := FALSE,
    ordinal_count: [STATIC] integer := 0,
    output_file_id: [STATIC] amt$file_identifier,
    page_width: [STATIC] 0 .. amc$max_page_width,
    scope: [STATIC] ost$name,
    section_name: [STATIC] ost$name := '',
    status: [STATIC] ost$status,
    table_name: [STATIC] ost$name := '',
    table_type: [STATIC] ost$name,
    utility_name: [STATIC, READ, oss$job_paged_literal] ost$name := 'generate_command_table',
    version: [STATIC] 0 .. 1,
    xref_array: [STATIC] ^array [1 .. * ] of ost$name,
    xref_count: [STATIC] integer := 0;

{**************************** CAUTION !!! *****************************
{
{    When modifying the following 'hard-coded' types, use a different
{  MODIFICATION and FEATURE than ones used to modify the logic of
{  this program or any other deck.  This division is neccessary to
{  ensure ease of building various versions of command tables and
{  GENCT.
{
{**********************************************************************

  CONST
    number_of_types_lines = 794,
    max_types_line_size = 77;

  VAR
    types: [STATIC, READ] array [1 .. number_of_types_lines] of string (max_types_line_size) :=
          ['TYPE                                                                         ',
          '  clt$command_table = array [1 .. * ] of clt$command_table_entry;            ',
          'TYPE                                                                         ',
          '  clt$command_table_entry = record                                           ',
          '    name: clt$command_name,                                                  ',
          '    class: clt$named_entry_class,                                            ',
          '    availability: clt$named_entry_availability,                              ',
          '    ordinal: clt$named_entry_ordinal,                                        ',
          '    log_option: clt$command_log_option,                                      ',
          '    case call_method: clt$command_call_method of                             ',
          '    = clc$linked_call =                                                      ',
          '      command: clt$command,                                                  ',
          '    = clc$unlinked_call, clc$proc_call, clc$program_call =                   ',
          '      procedure_name: pmt$program_name,                                      ',
          '    casend,                                                                  ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$command_call_method = clc$linked_call .. clc$program_call;             ',
          'TYPE                                                                         ',
          '  clt$call_method = (clc$unspecified_call, clc$linked_call,                  ',
          '        clc$unlinked_call, clc$proc_call, clc$program_call);                 ',
          'TYPE                                                                         ',
          '  clt$command_log_option = (clc$automatically_log, clc$manually_log);        ',
          'TYPE                                                                         ',
          '  clt$command_name = ost$name;                                               ',
          'CONST                                                                        ',
          '  osc$max_name_size = 31,                                                    ',
          '  osc$null_name = ''                               '';                         ',
          'TYPE                                                                         ',
          '  ost$name_size = 1 .. osc$max_name_size;                                    ',
          'TYPE                                                                         ',
          '  ost$name = string (osc$max_name_size);                                     ',
          'TYPE                                                                         ',
          '  clt$command = ^procedure (    parameter_list: clt$parameter_list;          ',
          '                            VAR status: ost$status);                         ',
          'TYPE                                                                         ',
          '  clt$parameter_list = pmt$program_parameters;                               ',
          'TYPE                                                                         ',
          '  pmt$program_parameters = SEQ ( * );                                        ',
          'TYPE                                                                         ',
          '  clt$parameter_list_contents = clt$parameter_list_text;                     ',
          'TYPE                                                                         ',
          '  clt$parameter_list_text = string ( * <= clc$max_parameter_list_size);      ',
          'CONST                                                                        ',
          '  clc$max_parameter_list_size = clc$max_string_size;                         ',
          'CONST                                                                        ',
          '  clc$max_string_size = cyc$max_string_size;                                 ',
          'CONST                                                                        ',
          '  cyc$max_string_size = 0ffff(16);                                           ',
          'TYPE                                                                         ',
          '  ost$status = record                                                        ',
          '    case normal: boolean of                                                  ',
          '    = FALSE =                                                                ',
          '      condition: ost$status_condition_code,                                  ',
          '      text: ost$string,                                                      ',
          '    = TRUE =                                                                 ',
          '      ,                                                                      ',
          '    casend,                                                                  ',
          '  recend;                                                                    ',
          'CONST                                                                        ',
          '  osc$max_condition = osc$max_status_condition_code;                         ',
          'CONST                                                                        ',
          '  osc$max_status_condition_code = 0ffffffffff(16);                           ',
          'CONST                                                                        ',
          '  osc$status_parameter_delimiter = $CHAR (31) {Unit Separator} ;             ',
          'TYPE                                                                         ',
          '  ost$status_condition = ost$status_condition_code;                          ',
          'TYPE                                                                         ',
          '  ost$status_condition_code = 0 .. osc$max_status_condition_code;            ',
          'CONST                                                                        ',
          '  osc$max_string_size = 256;                                                 ',
          'TYPE                                                                         ',
          '  ost$string_size = 0 .. osc$max_string_size;                                ',
          'TYPE                                                                         ',
          '  ost$string_index = 1 .. osc$max_string_size + 1;                           ',
          'TYPE                                                                         ',
          '  ost$string = record                                                        ',
          '    size: ost$string_size,                                                   ',
          '    value: string (osc$max_string_size),                                     ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$named_entry_availability = (clc$normal_usage_entry, clc$hidden_entry,  ',
          '        clc$advanced_usage_entry);                                           ',
          'CONST                                                                        ',
          '  clc$advertised_entry = clc$normal_usage_entry;                             ',
          'TYPE                                                                         ',
          '  clt$named_entry_class = (clc$nominal_entry, clc$alias_entry,               ',
          '        clc$abbreviation_entry);                                             ',
          'TYPE                                                                         ',
          '  clt$named_entry_ordinal = 1 .. 7fffffff(16);                               ',
          'TYPE                                                                         ',
          '  pmt$program_name = ost$name;                                               ',
          'TYPE                                                                         ',
          '  clt$function_processor_table = array [1 .. * ] of                          ',
          '        clt$function_proc_table_entry;                                       ',
          'TYPE                                                                         ',
          '  clt$function_proc_table_entry = record                                     ',
          '    name: clt$function_name,                                                 ',
          '    class: clt$named_entry_class,                                            ',
          '    availability: clt$named_entry_availability,                              ',
          '    ordinal: clt$named_entry_ordinal,                                        ',
          '    case call_method: clt$function_call_method of                            ',
          '    = clc$linked_call =                                                      ',
          '      func: clt$function_processor,                                          ',
          '    = clc$unlinked_call, clc$proc_call =                                     ',
          '      procedure_name: pmt$program_name,                                      ',
          '    casend,                                                                  ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$function_call_method = clc$linked_call .. clc$proc_call;               ',
          'TYPE                                                                         ',
          '  clt$function_name = ost$name;                                              ',
          'TYPE                                                                         ',
          '  clt$function_processor = ^procedure                                        ',
          '         (    parameter_list: clt$parameter_list;                            ',
          '          VAR work_area {input, output} : ^clt$work_area;                    ',
          '          VAR result: ^clt$data_value;                                       ',
          '          VAR status: ost$status);                                           ',
          'TYPE                                                                         ',
          '  clt$data_value = record                                                    ',
          '    case kind: clt$data_kind of                                              ',
          '    = clc$application =                                                      ',
          '      application_value: ^clt$application_value_text,                        ',
          '    = clc$array =                                                            ',
          '      array_value: ^array [ * ] of ^clt$data_value,                          ',
          '    = clc$boolean =                                                          ',
          '      boolean_value: clt$boolean,                                            ',
          '    = clc$cobol_name =                                                       ',
          '      cobol_name_value: clt$cobol_name,                                      ',
          '    = clc$command_reference =                                                ',
          '      command_reference_value: ^clt$command_reference,                       ',
          '    = clc$data_name =                                                        ',
          '      data_name_value: ost$name,                                             ',
          '    = clc$date_time =                                                        ',
          '      date_time_value: clt$date_time,                                        ',
          '    = clc$deferred =                                                         ',
          '      deferred_value: ^clt$expression_text,                                  ',
          '      deferred_type: ^clt$type_specification,                                ',
          '    = clc$entry_point_reference =                                            ',
          '      entry_point_reference_value: ^pmt$entry_point_reference,               ',
          '    = clc$file =                                                             ',
          '      file_value: ^fst$file_reference,                                       ',
          '    = clc$integer =                                                          ',
          '      integer_value: clt$integer,                                            ',
          '    = clc$keyword =                                                          ',
          '      keyword_value: clt$keyword,                                            ',
          '    = clc$list =                                                             ',
          '      element_value: ^clt$data_value,                                        ',
          '      link: ^clt$data_value,                                                 ',
          '      generated_via_list_rest: boolean,                                      ',
          '    = clc$lock =                                                             ',
          '      lock_value: ^clt$lock,                                                 ',
          '    = clc$name =                                                             ',
          '      name_value: ost$name,                                                  ',
          '    = clc$network_title =                                                    ',
          '      network_title_value: ^nat$title,                                       ',
          '    = clc$program_name =                                                     ',
          '      program_name_value: pmt$program_name,                                  ',
          '    = clc$range =                                                            ',
          '      low_value: ^clt$data_value,                                            ',
          '      high_value: ^clt$data_value,                                           ',
          '    = clc$real =                                                             ',
          '      real_value: clt$real,                                                  ',
          '    = clc$record =                                                           ',
          '      field_values: ^array [1 .. * ] of clt$field_value,                     ',
          '    = clc$scu_line_identifier =                                              ',
          '      scu_line_identifier_value: clt$scu_line_identifier,                    ',
          '    = clc$statistic_code =                                                   ',
          '      statistic_code_value: sft$statistic_code,                              ',
          '    = clc$status =                                                           ',
          '      status_value: ^ost$status,                                             ',
          '    = clc$status_code =                                                      ',
          '      status_code_value: ost$status_condition_code,                          ',
          '    = clc$string =                                                           ',
          '      string_value: ^clt$string_value,                                       ',
          '    = clc$string_pattern =                                                   ',
          '      string_pattern_value: ^clt$string_pattern,                             ',
          '    = clc$time_increment =                                                   ',
          '      time_increment_value: ^pmt$time_increment,                             ',
          '    = clc$time_zone =                                                        ',
          '      time_zone_value: ost$time_zone,                                        ',
          '    = clc$type_specification =                                               ',
          '      type_specification_value: ^clt$type_specification,                     ',
          '    = clc$unspecified =                                                      ',
          '      ,                                                                      ',
          '    casend,                                                                  ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$application_value_text = clt$expression_text;                          ',
          'TYPE                                                                         ',
          '  clt$expression_text = string ( * <= clc$max_expression_text_size);         ',
          'CONST                                                                        ',
          '  clc$max_expression_text_size = clc$max_string_size;                        ',
          'TYPE                                                                         ',
          '  clt$boolean = record                                                       ',
          '    value: boolean,                                                          ',
          '    kind: clt$boolean_kinds,                                                 ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$boolean_kinds = (clc$true_false_boolean, clc$yes_no_boolean,           ',
          '        clc$on_off_boolean);                                                 ',
          'TYPE                                                                         ',
          '  clt$cobol_name = string (clc$max_cobol_name_size);                         ',
          'CONST                                                                        ',
          '  clc$max_cobol_name_size = 30;                                              ',
          'TYPE                                                                         ',
          '  clt$command_reference = record                                             ',
          '    name: clt$command_name,                                                  ',
          '    case form: clt$command_reference_form of                                 ',
          '    = clc$name_only_command_ref =                                            ',
          '      ,                                                                      ',
          '    = clc$skip_1st_entry_command_ref =                                       ',
          '      ,                                                                      ',
          '    = clc$system_command_ref =                                               ',
          '      ,                                                                      ',
          '    = clc$utility_command_ref =                                              ',
          '      utility: clt$utility_name,                                             ',
          '    = clc$module_or_file_command_ref =                                       ',
          '      library_or_catalog: fst$path,                                          ',
          '    = clc$file_cycle_command_ref =                                           ',
          '      catalog: fst$path,                                                     ',
          '      cycle_number: fst$cycle_number,                                        ',
          '    casend,                                                                  ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$command_reference_form = (clc$name_only_command_ref,                   ',
          '        clc$skip_1st_entry_command_ref, clc$system_command_ref,              ',
          '        clc$utility_command_ref, clc$module_or_file_command_ref,             ',
          '        clc$file_cycle_command_ref);                                         ',
          'TYPE                                                                         ',
          '  clt$utility_name = ost$name;                                               ',
          'TYPE                                                                         ',
          '  fst$cycle_number = 1 .. fsc$maximum_cycle_number;                          ',
          'CONST                                                                        ',
          '  fsc$maximum_cycle_number = 65535;                                          ',
          'TYPE                                                                         ',
          '  fst$path = string (fsc$max_path_size);                                     ',
          'CONST                                                                        ',
          '  fsc$max_path_size = 512;                                                   ',
          'TYPE                                                                         ',
          '  clt$date_time = record                                                     ',
          '    value: ost$date_time,                                                    ',
          '    date_specified: boolean,                                                 ',
          '    time_specified: boolean,                                                 ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  ost$date_time = record                                                     ',
          '    year: 0 .. 255, {year minus 1900, e.g. 80 = 1980}                        ',
          '    month: 1 .. 12,                                                          ',
          '    day: 1 .. 31,                                                            ',
          '    hour: 0 .. 23,                                                           ',
          '    minute: 0 .. 59,                                                         ',
          '    second: 0 .. 59,                                                         ',
          '    millisecond: 0 .. 999,                                                   ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$data_kind = (clc$application, clc$array, clc$boolean, clc$cobol_name,  ',
          '        clc$command_reference, clc$data_name, clc$date_time, clc$deferred,   ',
          '        clc$entry_point_reference, clc$file, clc$integer, clc$keyword,       ',
          '        clc$list, clc$lock, clc$name, clc$network_title, clc$program_name,   ',
          '        clc$range, clc$real, clc$record, clc$scu_line_identifier,            ',
          '        clc$statistic_code, clc$status, clc$status_code, clc$string,         ',
          '        clc$string_pattern, clc$time_increment, clc$time_zone,               ',
          '        clc$type_specification, clc$unspecified);                            ',
          'TYPE                                                                         ',
          '  clt$field_value = record                                                   ',
          '    name: clt$field_name,                                                    ',
          '    value: ^clt$data_value,                                                  ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$field_name = ost$name;                                                 ',
          'TYPE                                                                         ',
          '  clt$integer = record                                                       ',
          '    value: integer,                                                          ',
          '    radix: 2 .. 16,                                                          ',
          '    radix_specified: boolean,                                                ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$keyword = ost$name;                                                    ',
          'TYPE                                                                         ',
          '  clt$lock = record                                                          ',
          '    case state: clt$lock_state of                                            ',
          '    = clc$lock_clear =                                                       ',
          '      ,                                                                      ',
          '    = clc$lock_set, clc$lock_expired =                                       ',
          '      set_by_job: jmt$system_supplied_name,                                  ',
          '      set_by_task: pmt$task_id,                                              ',
          '      expiration_date_time_rel_gmt: ost$date_time,                           ',
          '    casend,                                                                  ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$lock_state = (clc$lock_clear, clc$lock_set, clc$lock_expired);         ',
          'TYPE                                                                         ',
          '  jmt$system_supplied_name = string (jmc$system_supplied_name_size);         ',
          'CONST                                                                        ',
          '  jmc$system_supplied_name_size = 19;                                        ',
          'TYPE                                                                         ',
          '  pmt$task_id = 0 .. pmc$max_task_id;                                        ',
          'CONST                                                                        ',
          '  pmc$max_task_id = 0ffffffff(16);                                           ',
          'TYPE                                                                         ',
          '  clt$real = record                                                          ',
          '    value: longreal,                                                         ',
          '    number_of_digits: clt$real_number_digit_count,                           ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$real_number_digit_count = 1 .. clc$max_real_number_digits;             ',
          'CONST                                                                        ',
          '  clc$max_real_number_digits = 28;                                           ',
          'TYPE                                                                         ',
          '  clt$scu_line_identifier = record                                           ',
          '    modification_name: clt$scu_modification_name,                            ',
          '    sequence_number: clt$scu_sequence_number,                                ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$scu_modification_name = string (clc$max_scu_modification_name);        ',
          'CONST                                                                        ',
          '  clc$max_scu_modification_name = 9;                                         ',
          'TYPE                                                                         ',
          '  clt$scu_sequence_number = 1 .. clc$max_scu_sequence_number;                ',
          'CONST                                                                        ',
          '  clc$max_scu_sequence_number = 0ffffff(16);                                 ',
          'TYPE                                                                         ',
          '  clt$string_pattern = SEQ ( * );                                            ',
          'TYPE                                                                         ',
          '  clt$string_value = string ( * <= clc$max_string_size);                     ',
          'TYPE                                                                         ',
          '  clt$type_specification = SEQ ( * );                                        ',
          'SECTION                                                                      ',
          '  cls$declaration_section: READ;                                             ',
          'TYPE                                                                         ',
          '  clt$application_type_qualifier = record                                    ',
          '    balance_brackets: boolean,                                               ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$array_type_qualifier = record                                          ',
          '    element_type_specification_size: clt$type_specification_size,            ',
          '    case array_bounds_defined: boolean of                                    ',
          '    = TRUE =                                                                 ',
          '      bounds: clt$array_bounds,                                              ',
          '    = FALSE =                                                                ',
          '      ,                                                                      ',
          '    casend,                                                                  ',
          '    { A clt$type_specification for the element type follows the }            ',
          '    { clt$array_type_qualifier. }                                            ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$array_bounds = record                                                  ',
          '    lower: clt$array_bound,                                                  ',
          '    upper: clt$array_bound,                                                  ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$array_bound = clc$min_array_bound .. clc$max_array_bound;              ',
          'CONST                                                                        ',
          '  clc$max_array_bound = 7fffffff(16);                                        ',
          'CONST                                                                        ',
          '  clc$min_array_bound = -80000000(16);                                       ',
          'TYPE                                                                         ',
          '  clt$type_specification_size = 0 .. clc$max_type_specification_size;        ',
          'CONST                                                                        ',
          '  clc$max_type_specification_size = 7fffffff(16);                            ',
          'TYPE                                                                         ',
          '  clt$date_time_type_qualifier = record                                      ',
          '    date_and_or_time: clt$date_and_or_time,                                  ',
          '    tenses: clt$date_time_tenses,                                            ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$date_and_or_time = set of clt$date_or_time;                            ',
          'TYPE                                                                         ',
          '  clt$date_or_time = (clc$date, clc$time);                                   ',
          'TYPE                                                                         ',
          '  clt$date_time_tenses = set of clt$date_time_tense;                         ',
          'TYPE                                                                         ',
          '  clt$date_time_tense = (clc$past, clc$present, clc$future);                 ',
          'TYPE                                                                         ',
          '  clt$integer_type_qualifier = record                                        ',
          '    min_integer_value: integer,                                              ',
          '    max_integer_value: integer,                                              ',
          '    default_radix: 2 .. 16,                                                  ',
          '  recend;                                                                    ',
          'CONST                                                                        ',
          '  clc$max_integer = cyc$uppervalue_integer;                                  ',
          'CONST                                                                        ',
          '  cyc$uppervalue_integer = 7fffffffffffffff(16);                             ',
          'CONST                                                                        ',
          '  clc$min_integer = cyc$lowervalue_integer;                                  ',
          'CONST                                                                        ',
          '  cyc$lowervalue_integer = (-cyc$uppervalue_integer) - 1;                    ',
          'TYPE                                                                         ',
          '  clt$keyword_type_qualifier = record                                        ',
          '    number_of_keywords: 1 .. clc$max_keywords,                               ',
          '    { An array [1 .. number_of_keywords] of clt$keyword_specification }      ',
          '    { follows the clt$keyword_type_qualifier. }                              ',
          '  recend;                                                                    ',
          'CONST                                                                        ',
          '  clc$max_keywords = 7fffffff(16);                                           ',
          'TYPE                                                                         ',
          '  clt$keyword_specifications = array [1 .. * ] of clt$keyword_specification; ',
          'TYPE                                                                         ',
          '  clt$keyword_specification = record                                         ',
          '    keyword: clt$keyword,                                                    ',
          '    class: clt$named_entry_class,                                            ',
          '    availability: clt$named_entry_availability,                              ',
          '    ordinal: clt$named_entry_ordinal,                                        ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$list_type_qualifier = record                                           ',
          '    element_type_specification_size: clt$type_specification_size,            ',
          '    min_list_size: clt$list_size,                                            ',
          '    max_list_size: clt$list_size,                                            ',
          '    list_rest: boolean,                                                      ',
          '    { A clt$type_specification for the element type follows the }            ',
          '    { clt$list_type_qualifier. }                                             ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$list_size = 0 .. clc$max_list_size;                                    ',
          'CONST                                                                        ',
          '  clc$max_list_size = 7fffffff(16);                                          ',
          'TYPE                                                                         ',
          '  clt$name_type_qualifier = record                                           ',
          '    min_name_size: ost$name_size,                                            ',
          '    max_name_size: ost$name_size,                                            ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$range_type_qualifier = record                                          ',
          '    element_type_specification_size: clt$type_specification_size,            ',
          '    { A clt$type_specification for the element type follows the }            ',
          '    { clt$range_type_qualifier. }                                            ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$real_type_qualifier = record                                           ',
          '    min_real_value: clt$longreal,                                            ',
          '    max_real_value: clt$longreal,                                            ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$longreal = record                                                      ',
          '    case 1 .. 3 of                                                           ',
          '    = 1 =                                                                    ',
          '      long_real: longreal,                                                   ',
          '    = 2 =                                                                    ',
          '      first_real: real,                                                      ',
          '      second_real: real,                                                     ',
          '    = 3 =                                                                    ',
          '      breakdown: clt$longreal_breakdown,                                     ',
          '    casend,                                                                  ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$longreal_breakdown = record                                            ',
          '    first: clt$real_breakdown,                                               ',
          '    second: clt$real_breakdown,                                              ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$real_breakdown = record                                                ',
          '    exponent: 0 .. 0ffff(16),                                                ',
          '    mantissa: 0 .. 0ffffffffffff(16),                                        ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$record_type_qualifier = record                                         ',
          '    number_of_fields: clt$field_number,                                      ',
          '    { There are number_of_fields occurrences of a clt$field_specification }  ',
          '    { followed by a clt$type_specification following the }                   ',
          '    { clt$record_type_qualifier. }                                           ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$field_number = 1 .. clc$max_fields;                                    ',
          'CONST                                                                        ',
          '  clc$max_fields = 7fffffff(16);                                             ',
          'TYPE                                                                         ',
          '  clt$field_specification = record                                           ',
          '    name: clt$field_name,                                                    ',
          '    requirement: clt$field_requirement,                                      ',
          '    type_specification_size: clt$type_specification_size,                    ',
          '  recend;                                                                    ',
          'CONST                                                                        ',
          '  clc$required_field = clc$required_parameter,                               ',
          '  clc$optional_field = clc$optional_parameter;                               ',
          'TYPE                                                                         ',
          '  clt$field_requirement = clc$required_field .. clc$optional_field;          ',
          'TYPE                                                                         ',
          '  clt$parameter_requirement = (clc$required_parameter,                       ',
          '        clc$optional_parameter, clc$optional_default_parameter,              ',
          '        clc$confirm_default_parameter);                                      ',
          'TYPE                                                                         ',
          '  clt$string_type_qualifier = record                                         ',
          '    min_string_size: clt$string_size,                                        ',
          '    max_string_size: clt$string_size,                                        ',
          '    literal: boolean,                                                        ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$string_size = 0 .. clc$max_string_size;                                ',
          'TYPE                                                                         ',
          '  clt$type_specification_header = record                                     ',
          '    version: clt$declaration_version,                                        ',
          '    name: clt$type_name,                                                     ',
          '    case kind: clt$type_kind of                                              ',
          '    = clc$application_type =                                                 ',
          '      { clt$application_type_qualifier follows header } ,                    ',
          '    = clc$array_type =                                                       ',
          '      { clt$array_type_qualifier follows header } ,                          ',
          '    = clc$boolean_type =                                                     ',
          '      ,                                                                      ',
          '    = clc$cobol_name_type =                                                  ',
          '      ,                                                                      ',
          '    = clc$command_reference_type =                                           ',
          '      ,                                                                      ',
          '    = clc$data_name_type =                                                   ',
          '      ,                                                                      ',
          '    = clc$date_time_type =                                                   ',
          '      { clt$date_time_type_qualifier follows header } ,                      ',
          '    = clc$entry_point_reference_type =                                       ',
          '      ,                                                                      ',
          '    = clc$file_type =                                                        ',
          '      ,                                                                      ',
          '    = clc$integer_type =                                                     ',
          '      { clt$integer_type_qualifier follows header } ,                        ',
          '    = clc$keyword_type =                                                     ',
          '      { clt$keyword_type_qualifier follows header } ,                        ',
          '    = clc$list_type =                                                        ',
          '      { clt$list_type_qualifier follows header } ,                           ',
          '    = clc$lock_type =                                                        ',
          '      ,                                                                      ',
          '    = clc$name_type =                                                        ',
          '      { clt$name_type_qualifier follows header } ,                           ',
          '    = clc$network_title_type =                                               ',
          '      ,                                                                      ',
          '    = clc$program_name_type =                                                ',
          '      ,                                                                      ',
          '    = clc$range_type =                                                       ',
          '      { clt$range_type_qualifier follows header } ,                          ',
          '    = clc$real_type =                                                        ',
          '      { clt$real_type_qualifier follows header } ,                           ',
          '    = clc$record_type =                                                      ',
          '      { clt$record_type_qualifier follows header } ,                         ',
          '    = clc$scu_line_identifier_type =                                         ',
          '      ,                                                                      ',
          '    = clc$statistic_code_type =                                              ',
          '      ,                                                                      ',
          '    = clc$status_type =                                                      ',
          '      ,                                                                      ',
          '    = clc$status_code_type =                                                 ',
          '      ,                                                                      ',
          '    = clc$string_type =                                                      ',
          '      { clt$string_type_qualifier follows header } ,                         ',
          '    = clc$string_pattern_type =                                              ',
          '      ,                                                                      ',
          '    = clc$time_increment_type =                                              ',
          '      ,                                                                      ',
          '    = clc$time_zone_type =                                                   ',
          '      ,                                                                      ',
          '    = clc$type_specification_type =                                          ',
          '      ,                                                                      ',
          '    = clc$union_type =                                                       ',
          '      { clt$union_type_qualifier follows header } ,                          ',
          '    casend,                                                                  ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$declaration_version = 0 .. 255;                                        ',
          'CONST                                                                        ',
          '  clc$declaration_version = 1;                                               ',
          'TYPE                                                                         ',
          '  clt$type_kind = (clc$application_type, clc$array_type, clc$boolean_type,   ',
          '        clc$cobol_name_type, clc$command_reference_type, clc$data_name_type, ',
          '        clc$date_time_type, clc$entry_point_reference_type, clc$file_type,   ',
          '        clc$integer_type, clc$keyword_type, clc$list_type, clc$lock_type,    ',
          '        clc$name_type, clc$network_title_type, clc$program_name_type,        ',
          '        clc$range_type, clc$real_type, clc$record_type,                      ',
          '        clc$scu_line_identifier_type, clc$statistic_code_type,               ',
          '        clc$status_type, clc$status_code_type, clc$string_type,              ',
          '        clc$string_pattern_type, clc$time_increment_type, clc$time_zone_type,',
          '        clc$type_specification_type, clc$union_type);                        ',
          'TYPE                                                                         ',
          '  clt$type_name = clt$variable_name;                                         ',
          'TYPE                                                                         ',
          '  clt$variable_name = ost$name;                                              ',
          'TYPE                                                                         ',
          '  clt$union_type_qualifier = record                                          ',
          '    kinds: clt$type_kinds,                                                   ',
          '    information: clt$union_type_information,                                 ',
          '    case number_of_members: clt$union_member_number of                       ',
          '    = 0 =                                                                    ',
          '      { The union consists of all possible types. } ,                        ',
          '    = 1 .. clc$max_union_members =                                           ',
          '      { There are number_of_members occurrences of a }                       ',
          '      { clt$type_specification_size followed by a clt$type_specification }   ',
          '      { following the clt$union_type_qualifier. }                            ',
          '    casend,                                                                  ',
          '  recend;                                                                    ',
          'CONST                                                                        ',
          '  clc$max_union_members = 7fffffff(16);                                      ',
          'TYPE                                                                         ',
          '  clt$type_kinds = set of clt$type_kind;                                     ',
          'TYPE                                                                         ',
          '  clt$union_member_number = 0 .. clc$max_union_members;                      ',
          'TYPE                                                                         ',
          '  clt$union_type_information = record                                        ',
          '    only_standard_types_in_union: boolean,                                   ',
          '    { The "standard" types have non-conflicting expression forms, therefore  ',
          '    { an expression for a union of them can be evaluated without the need for',
          '    { trying each type individually.  The "standard" types are:  boolean,    ',
          '    { file, integer (if default radix is 10), name, real, status, string (if ',
          '    { not literal), string_pattern, and union (consisting only of these      ',
          '    { "standard" types).                                                     ',
          '    min_integer_value: integer,                                              ',
          '    max_integer_value: integer,                                              ',
          '    default_radix: 2 .. 16,                                                  ',
          '    min_real_value: clt$longreal,                                            ',
          '    max_real_value: clt$longreal,                                            ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  fst$file_reference = string ( * <= fsc$max_path_size);                     ',
          'CONST                                                                        ',
          '  nac$max_title_length = 255;                                                ',
          'TYPE                                                                         ',
          '  nat$title_length = 1 .. nac$max_title_length,                              ',
          '  nat$title = string ( * <= nac$max_title_length);                           ',
          'TYPE                                                                         ',
          '  ost$time_zone = record                                                     ',
          '    hours_from_gmt: -12 .. 12,                                               ',
          '    minutes_offset: -30 .. 30,                                               ',
          '    daylight_saving_time: boolean,                                           ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  pmt$entry_point_reference = record                                         ',
          '    entry_point: pmt$program_name,                                           ',
          '    object_library: fst$path,                                                ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  pmt$time_increment = record                                                ',
          '    year: integer,                                                           ',
          '    month: integer,                                                          ',
          '    day: integer,                                                            ',
          '    hour: integer,                                                           ',
          '    minute: integer,                                                         ',
          '    second: integer,                                                         ',
          '    millisecond: integer,                                                    ',
          '  recend;                                                                    ',
          'CONST                                                                        ',
          '  sfc$max_threshold = 7fffffffffff(16),                                      ',
          '  sfc$max_time_interval = 0ffffffff(16);                                     ',
          'CONST                                                                        ',
          '  sfc$max_statistic_code = osc$max_condition;                                ',
          'TYPE                                                                         ',
          '  sft$statistic_code = 0 .. sfc$max_statistic_code;                          ',
          'TYPE                                                                         ',
          '  sft$statistic_identifier = string (2);                                     ',
          'CONST                                                                        ',
          '  sfc$max_descriptive_data_size = 255;                                       ',
          'TYPE                                                                         ',
          '  sft$descriptive_data = string ( * );                                       ',
          'CONST                                                                        ',
          '  sfc$max_number_of_counters = 255;                                          ',
          'TYPE                                                                         ',
          '  sft$counters = ^array [1 .. * ] of sft$counter;                            ',
          'TYPE                                                                         ',
          '  sft$counter = integer;                                                     ',
          'TYPE                                                                         ',
          '  sft$statistic_record = record                                              ',
          '    statistic_code: sft$statistic_code,                                      ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  sft$statistic_group = array [1 .. * ] of sft$statistic_record;             ',
          'TYPE                                                                         ',
          '  clt$work_area = SEQ ( * );                                                 ',
          'TYPE                                                                         ',
          '  clt$function_table = array [1 .. * ] of clt$function_table_entry;          ',
          'TYPE                                                                         ',
          '  clt$function_table_entry = record                                          ',
          '    name: clt$function_name,                                                 ',
          '    class: clt$named_entry_class,                                            ',
          '    availability: clt$named_entry_availability,                              ',
          '    ordinal: clt$named_entry_ordinal,                                        ',
          '    case call_method: clt$function_call_method of                            ',
          '    = clc$linked_call =                                                      ',
          '      func: clt$function,                                                    ',
          '    = clc$unlinked_call, clc$proc_call =                                     ',
          '      procedure_name: pmt$program_name,                                      ',
          '    casend,                                                                  ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$function = ^procedure (    function_name: clt$name;                    ',
          '                                 argument_list: string ( * );                ',
          '                             VAR value: clt$value;                           ',
          '                             VAR status: ost$status);                        ',
          'TYPE                                                                         ',
          '  clt$value = record                                                         ',
          '    descriptor: string (osc$max_name_size),                                  ',
          '    case kind: clc$unknown_value .. clc$status_value of                      ',
          '    = clc$unknown_value =                                                    ',
          '      ,                                                                      ',
          '    = clc$application_value =                                                ',
          '      application: clt$application_value,                                    ',
          '    = clc$variable_reference =                                               ',
          '      var_ref: clt$variable_reference,                                       ',
          '    = clc$string_value =                                                     ',
          '      str: ost$string,                                                       ',
          '    = clc$file_value =                                                       ',
          '      file: clt$file,                                                        ',
          '    = clc$name_value =                                                       ',
          '      name: clt$name,                                                        ',
          '    = clc$real_value =                                                       ',
          '      rnum: clt$real,                                                        ',
          '    = clc$integer_value =                                                    ',
          '      int: clt$integer,                                                      ',
          '    = clc$boolean_value =                                                    ',
          '      bool: clt$boolean,                                                     ',
          '    = clc$status_value =                                                     ',
          '      status: ost$status,                                                    ',
          '    casend,                                                                  ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$variable_reference = record                                            ',
          '    reference: ost$string,                                                   ',
          '    lower_bound: clt$variable_dimension,                                     ',
          '    upper_bound: clt$variable_dimension,                                     ',
          '    value: clt$variable_value,                                               ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$variable_value = record                                                ',
          '    descriptor: string (osc$max_name_size),                                  ',
          '    case kind: clt$variable_kinds of                                         ',
          '    = clc$string_value =                                                     ',
          '      max_string_size: ost$string_size,                                      ',
          '      string_value: ^array [1 .. * ] of cell,                                ',
          '    = clc$real_value =                                                       ',
          '      real_value: ^array [1 .. * ] of clt$real,                              ',
          '    = clc$integer_value =                                                    ',
          '      integer_value: ^array [1 .. * ] of clt$integer,                        ',
          '    = clc$boolean_value =                                                    ',
          '      boolean_value: ^array [1 .. * ] of clt$boolean,                        ',
          '    = clc$status_value =                                                     ',
          '      status_value: ^array [1 .. * ] of clt$status,                          ',
          '    casend,                                                                  ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$status = record                                                        ',
          '    normal: clt$boolean,                                                     ',
          '    identifier: clt$status_identifier,                                       ',
          '    condition: clt$integer,                                                  ',
          '    text: ost$string,                                                        ',
          '  recend,                                                                    ',
          '  clt$status_identifier = record                                             ',
          '    size: ost$string_size,                                                   ',
          '    value: string (2),                                                       ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  clt$variable_dimension = clc$min_variable_dimension ..                     ',
          '        clc$max_variable_dimension;                                          ',
          'CONST                                                                        ',
          '  clc$min_variable_dimension = -7fffffff(16),                                ',
          '  clc$max_variable_dimension = 7fffffff(16);                                 ',
          'TYPE                                                                         ',
          '  clt$variable_scope = record                                                ',
          '    case kind: clt$variable_scope_kind of                                    ',
          '    = clc$local_variable .. clc$xref_variable =                              ',
          '      ,                                                                      ',
          '    = clc$utility_variable =                                                 ',
          '      utility_name: ost$name,                                                ',
          '    casend,                                                                  ',
          '  recend,                                                                    ',
          '  clt$variable_scope_kind = (clc$local_variable, clc$job_variable,           ',
          '        clc$xdcl_variable, clc$xref_variable, clc$utility_variable);         ',
          'TYPE                                                                         ',
          '  clt$variable_kinds = clc$string_value .. clc$status_value;                 ',
          'TYPE                                                                         ',
          '  clt$value_kinds = clt$data_value_kind;                                     ',
          'CONST                                                                        ',
          '  clc$variable_reference = clc$deferred_value,                               ',
          '  clc$any_value = clc$array_value,                                           ',
          '  clc$unknown_value = clc$unspecified_value;                                 ',
          'TYPE                                                                         ',
          '  clt$data_value_kind = (clc$unspecified_value, clc$application_value,       ',
          '        clc$deferred_value, clc$file_value, clc$name_value, clc$string_value,',
          '        clc$real_value, clc$integer_value, clc$boolean_value,                ',
          '        clc$status_value, clc$array_value, clc$cobol_name_value,             ',
          '        clc$date_time_value, clc$entry_point_reference_value,                ',
          '        clc$keyword_value, clc$list_value, clc$lock_value,                   ',
          '        clc$network_title_value, clc$range_value, clc$record_value,          ',
          '        clc$scu_line_identifier_value, clc$string_pattern_value,             ',
          '        clc$time_increment_value, clc$type_specification_value);             ',
          'TYPE                                                                         ',
          '  clt$application_value = SEQ (ost$string);                                  ',
          'TYPE                                                                         ',
          '  clt$application_value_name = ost$name;                                     ',
          'TYPE                                                                         ',
          '  clt$file = record                                                          ',
          '    local_file_name: amt$local_file_name,                                    ',
          '  recend;                                                                    ',
          'TYPE                                                                         ',
          '  amt$local_file_name = ost$name;                                            ',
          'TYPE                                                                         ',
          '  clt$name = record                                                          ',
          '    size: ost$name_size,                                                     ',
          '    value: ost$name,                                                         ',
          '  recend;                                                                    '];

?? TITLE := 'echo_input', EJECT ??

  PROCEDURE echo_input
    (    parameter_list: clt$parameter_list;
         command: string ( * );
     VAR status: ost$status);

    CONST
      indentation = 8;

    VAR
      command_size: integer,
      echo_length: integer,
      echo_line: string (osc$max_string_size),
      parameter_list_text: ^clt$parameter_list_text,
      parm_list_size: clt$parameter_list_size,
      parm_list_text: ^clt$parameter_list_text,
      terminate_string: string (2);


    terminate_string := '..';

    clp$get_parameter_list_text (^parameter_list, parameter_list_text, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    parm_list_size := STRLENGTH (parameter_list_text^);
    PUSH parm_list_text: [parm_list_size];
    #TRANSLATE (osv$upper_to_lower, parameter_list_text^, parm_list_text^);
    command_size := STRLENGTH (command);

    IF (command_size + parm_list_size + 3) <= (page_width - 2) THEN
      STRINGREP (echo_line, echo_length, '{ ', command (1, command_size),
            ' ', parm_list_text^ (1, parm_list_size));
      put_line (echo_line (1, echo_length));
      RETURN;
    IFEND;

    build_and_put (parm_list_text, parm_list_size, (page_width - indentation - 6), command, 0);

  PROCEND echo_input;
?? TITLE := 'build_and_put', EJECT ??

  PROCEDURE build_and_put
    (    line: ^clt$parameter_list_text;
         line_length: 1 .. clc$max_parameter_list_size;
         width: amt$page_width;
         command: string ( * );
         indentation: integer);

    VAR
      break_position: 0 .. clc$max_parameter_list_size,
      current_character_position: 0 .. clc$max_parameter_list_size,
      current_length: 0 .. clc$max_parameter_list_size,
      remaining_text: 0 .. clc$max_parameter_list_size,
      starting_position: 1 .. clc$max_parameter_list_size,
      terminate_string: string (2),
      command_size: 0 .. osc$max_name_size,
      count: 0 .. clc$max_command_chunk,
      position: 0 .. clc$max_parameter_list_size,
      length: 0 .. clc$max_parameter_list_size,
      indentation_string: string (8);

?? NEWTITLE := 'put', EJECT ??

    PROCEDURE [INLINE] put;

      VAR
        built_line: string (osc$max_string_size),
        built_line_length: integer;


      IF command <> '' THEN
        IF count = 1 THEN
          STRINGREP (built_line, built_line_length, '{ ', command (1, command_size),
                ' ', line^ (position, length), terminate_string);
        ELSE
          IF remaining_text <= width THEN
            terminate_string := '  ';
          IFEND;
          STRINGREP (built_line, built_line_length, '{   ', line^ (position, length), terminate_string);
        IFEND;
        put_line (built_line (1, built_line_length));
      ELSE
        IF count = 1 THEN
          put_line (line^ (position, length));
        ELSE
          STRINGREP (built_line, built_line_length, indentation_string (1, indentation),
                line^ (position, length));
          put_line (built_line (1, built_line_length));
        IFEND;
      IFEND;

    PROCEND put;
?? OLDTITLE, EJECT ??

    current_character_position := 1;  { This is always the next character to examine
    break_position := 1;              { This is the last identified char pos that can start a new line
    remaining_text := line_length;
    count := 0;
    starting_position := 1;           { This is the char position to start the next line to be PUT.
    terminate_string := '..';
    indentation_string := ' ';
    command_size := STRLENGTH (command);

    WHILE remaining_text > 0 DO
      count := count + 1;
      IF remaining_text <= width THEN
        position := starting_position;
        length := remaining_text;
        put;
        RETURN;
      IFEND;

{  FOR loop:
{
{  If we get here then there are more than WIDTH characters left in the line.
{  WIDTH characters are examined to find the last delimiter (space or comma).
{  Whenever a delimiter is found, break_position is set to the following character
{  position.
{
{  Initial conditions:  current_character_position = starting_position
{                       width > 0
{                       break_position = starting_position
{
{  Final conditions:    current_character_position = starting_position + width
{                       current_character_position > starting_position
{                       break_position >= starting_position
{                       break_position <= current_character_position

      break_position := starting_position;
      FOR position := 1 TO width DO
        IF (line^ (current_character_position) = ',') OR (line^ (current_character_position) = ' ') THEN
          break_position := current_character_position + 1;
        IFEND;
        current_character_position := current_character_position + 1;
      FOREND;

      IF break_position > starting_position THEN
        current_character_position := break_position;
      IFEND;

      IF count <> 1 THEN
        WHILE line^ (starting_position) = ' ' DO
          starting_position := starting_position + 1;
        WHILEND;
      IFEND;

      current_length := current_character_position - starting_position;
      position := starting_position;
      length := current_length;
      put;
      starting_position := current_character_position;
      remaining_text := line_length - starting_position + 1;
    WHILEND;

  PROCEND build_and_put;
?? TITLE := 'table_command', EJECT ??

  PROCEDURE table_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$genct_table) table (
{   name, n: name 1..24 = $required
{   type, t: key
{       (command, c)
{       (function, f)
{     keyend = command
{   section_name, sn: data_name = $optional
{   scope, s: key
{       local, xdcl
{     keyend = local
{   module, m: data_name = $optional
{   version, v: integer 0..1 = 1
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 13] of clt$pdt_parameter_name,
        parameters: array [1 .. 7] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
          default_value: string (7),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 2] of clt$keyword_specification,
          default_value: string (5),
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (1),
        recend,
        type7: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 27, 14, 30, 48, 739], clc$command, 13, 7, 1, 0, 0, 0, 7, 'OSM$GENCT_TABLE'],
            [['M                              ', clc$abbreviation_entry, 5],
            ['MODULE                         ', clc$nominal_entry, 5],
            ['N                              ', clc$abbreviation_entry, 1],
            ['NAME                           ', clc$nominal_entry, 1],
            ['S                              ', clc$abbreviation_entry, 4],
            ['SCOPE                          ', clc$nominal_entry, 4],
            ['SECTION_NAME                   ', clc$nominal_entry, 3],
            ['SN                             ', clc$abbreviation_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 7],
            ['T                              ', clc$abbreviation_entry, 2],
            ['TYPE                           ', clc$nominal_entry, 2],
            ['V                              ', clc$abbreviation_entry, 6],
            ['VERSION                        ', clc$nominal_entry, 6]], [

{ PARAMETER 1

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 7],

{ PARAMETER 3

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 81, clc$optional_default_parameter, 0, 5],

{ PARAMETER 5

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 1],

{ PARAMETER 7

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, 24]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [4], [['C                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['COMMAND                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['F                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FUNCTION                       ', clc$nominal_entry,
            clc$normal_usage_entry, 2]], 'command'],

{ PARAMETER 3

      [[1, 0, clc$data_name_type]],

{ PARAMETER 4

      [[1, 0, clc$keyword_type], [2], [['LOCAL                          ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['XDCL                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]], 'local'],

{ PARAMETER 5

      [[1, 0, clc$data_name_type]],

{ PARAMETER 6

      [[1, 0, clc$integer_type], [0, 1, 10], '1'],

{ PARAMETER 7

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$name = 1,
      p$type = 2,
      p$section_name = 3,
      p$scope = 4,
      p$module = 5,
      p$version = 6,
      p$status = 7;

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


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

    IF entry_count > 0 THEN
      complete_current_table;
      new_table_started := FALSE;
    ELSEIF new_table_started = TRUE THEN
      put_table_header;
      new_table_started := FALSE;
    IFEND;

    table_type := pvt [p$type].value^.keyword_value;

    IF pvt [p$section_name].specified THEN
      section_name := pvt [p$section_name].value^.name_value;
    ELSE
      section_name := '';
    IFEND;

    IF pvt [p$scope].value^.keyword_value = 'LOCAL' THEN
      scope := 'STATIC';
    ELSE
      scope := pvt [p$scope].value^.keyword_value;
    IFEND;

    IF pvt [p$module].specified THEN
      #TRANSLATE (osv$upper_to_lower, pvt [p$module].value^.name_value, module_name);
      IF module_name (3, 2) <> 'm$' THEN
        osp$set_status_abnormal ('CL', cle$improper_module_name, module_name, status);
        RETURN;
      IFEND;
      module_name_size := clp$trimmed_string_size (module_name);
      put_line ('?? RIGHT := 110 ??');
    ELSE
      module_name := '';
    IFEND;

    version := pvt [p$version].value^.integer_value.value;

    table_name := pvt [p$name].value^.name_value;
    name_size := clp$trimmed_string_size (table_name);

    echo_input (parameter_list, 'table', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    new_table_started := TRUE;

  PROCEND table_command;
?? TITLE := 'complete_current_table', EJECT ??

  PROCEDURE [INLINE] complete_current_table;


    sort_table_entries;
    put_table_header;
    put_table_entries;

    IF xref_count > 0 THEN
      sort_xref_procedures;
      put_xref_procedures;
    IFEND;

    entry_count := 0;
    xref_count := 0;
    ordinal_count := 0;

  PROCEND complete_current_table;
?? TITLE := 'sort_table_entries', EJECT ??

  PROCEDURE [INLINE] sort_table_entries;

    VAR
      current: integer,
      gap: integer,
      start: integer,
      swap: entry;


    gap := entry_count;
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := 1 TO entry_count - gap DO
        current := start;
        WHILE (current > 0) AND (entry_array^ [current].name > entry_array^ [current + gap].name) DO
          swap := entry_array^ [current];
          entry_array^ [current] := entry_array^ [current + gap];
          entry_array^ [current + gap] := swap;
          current := current - gap;
        WHILEND;
      FOREND;
    WHILEND;

  PROCEND sort_table_entries;
?? TITLE := 'sort_xref_procedures', EJECT ??

  PROCEDURE [INLINE] sort_xref_procedures;

    VAR
      current: integer,
      gap: integer,
      start: integer,
      swap: ost$name;


    gap := xref_count;
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := 1 TO xref_count - gap DO
        current := start;
        WHILE (current > 0) AND (xref_array^ [current] > xref_array^ [current + gap]) DO
          swap := xref_array^ [current];
          xref_array^ [current] := xref_array^ [current + gap];
          xref_array^ [current + gap] := swap;
          current := current - gap;
        WHILEND;
      FOREND;
    WHILEND;

  PROCEND sort_xref_procedures;
?? TITLE := 'put_line', EJECT ??

  PROCEDURE [INLINE] put_line
    (    line: string ( * ));

    VAR
      ignore_byte_address: amt$file_byte_address,
      status: ost$status;


    amp$put_next (output_file_id, ^line, clp$trimmed_string_size (line), ignore_byte_address, status);
    IF NOT status.normal THEN
      pmp$exit (status);
    IFEND;

  PROCEND put_line;
?? TITLE := 'write_line', EJECT ??

  PROCEDURE write_line
    (    line: ^clt$parameter_list_text;
         indentation: integer);


    IF clp$trimmed_string_size (line^) <= page_width THEN
      put_line (line^);
    ELSE
      build_and_put (line, clp$trimmed_string_size (line^), page_width - indentation, '', indentation);
    IFEND;

  PROCEND write_line;
?? TITLE := 'put_table_header', EJECT ??

  PROCEDURE put_table_header;

    VAR
      header_length: integer,
      header_line: string (osc$max_string_size),
      ignore_status: ost$status,
      index: integer,
      number_string: ost$string,
      scope_size: integer,
      section_size: integer,
      section_string: string (max_page_width),
      string_size: integer,
      table_entry_type: ost$name,
      table_entry_type_size: ost$name_size,
      table_pointer_type: ost$name,
      table_pointer_type_size: ost$name_size,
      temp_length: integer,
      temp_line: string (osc$max_string_size),
      temp_name: ost$name,
      temp_section: ost$name;


    status.normal := TRUE;
    #TRANSLATE (osv$upper_to_lower, table_name, temp_name);
    IF table_type = 'COMMAND' THEN
      table_entry_type := 'clt$command_table_entry';
      table_entry_type_size := 23;
      table_pointer_type := 'clt$command_table';
      table_pointer_type_size := 17;
    ELSEIF version = 0 THEN
      table_entry_type := 'clt$function_table_entry';
      table_entry_type_size := 24;
      table_pointer_type := 'clt$function_table';
      table_pointer_type_size := 18;
    ELSE
      table_entry_type := 'clt$function_proc_table_entry';
      table_entry_type_size := 29;
      table_pointer_type := 'clt$function_processor_table';
      table_pointer_type_size := 28;
    IFEND;
    scope_size := clp$trimmed_string_size (scope);

    IF section_name = '' THEN
      section_string := '';
      string_size := 0;
    ELSE
      #TRANSLATE (osv$upper_to_lower, section_name, temp_section);
      section_size := clp$trimmed_string_size (temp_section);
      STRINGREP (section_string, string_size, ', ', temp_section (1, section_size));
    IFEND;

    IF module_name <> '' THEN
      STRINGREP (header_line, header_length, 'MODULE ', module_name (1, module_name_size), ';');
      put_line (header_line (1, header_length));
      put_line ('?? PUSH (LISTEXT := ON) ??');

      FOR index := 1 TO number_of_types_lines DO
        put_line (types [index] (1, clp$trimmed_string_size (types [index])));
      FOREND;

      IF section_name <> '' THEN
        put_line ('');
        put_line ('  SECTION');
        STRINGREP (header_line, header_length, '    ', temp_section (1, section_size), ': READ;');
        put_line (header_line (1, header_length));
      IFEND;
    ELSE
      put_line ('');
      put_line ('?? PUSH (LISTEXT := ON) ??');
    IFEND;

    put_line ('');
    put_line ('VAR');

    STRINGREP (temp_line, temp_length, '  ', temp_name (1, name_size), ': [', scope (1, scope_size),
          ', READ', section_string (1, string_size), '] ^', table_pointer_type (1, table_pointer_type_size),
          ' := ');

    IF entry_count = 0 THEN
      STRINGREP (header_line, header_length, temp_line (1, temp_length), 'NIL;');
      write_line (^header_line (1, header_length), 6);
      put_line ('');
      put_line ('?? POP ??');
      IF module_name <> '' THEN
        STRINGREP (header_line, header_length, 'MODEND ', module_name (1, module_name_size), ';');
        put_line (header_line (1, header_length));
      IFEND;
    ELSE
      STRINGREP (header_line, header_length, temp_line (1, temp_length), '^', temp_name (1, name_size),
            '_entries,');
      write_line (^header_line (1, header_length), 6);

      put_line ('');
      clp$convert_integer_to_string (entry_count, 10, FALSE, number_string, ignore_status);
      STRINGREP (header_line, header_length, '  ', temp_name (1, name_size), '_entries: [STATIC, READ',
            section_string (1, string_size), '] array [1 .. ', number_string.value (1, number_string.size),
            '] of ', table_entry_type (1, table_entry_type_size), ' := [');
      write_line (^header_line (1, header_length), 6);
    IFEND;

  PROCEND put_table_header;
?? TITLE := 'put_table_entries', EJECT ??

  PROCEDURE put_table_entries;

    CONST
      max_availability_size = 24, {clc$advanced_usage_entry
      max_class_size = 22, {clc$abbreviation_entry
      max_call_method_size = 20, {clc$unspecified_call
      max_log_option_size = 21; {clc$automatically_log

    VAR
      availabilities: [STATIC, READ, oss$job_paged_literal] array [clt$named_entry_availability] of record
        size: 1 .. max_availability_size,
        value: string (max_availability_size),
      recend := [[22, 'clc$normal_usage_entry'], [16, 'clc$hidden_entry'], [24, 'clc$advanced_usage_entry']],
      call_methods: [STATIC, READ, oss$job_paged_literal] array [clt$call_method] of record
        size: 1 .. max_call_method_size,
        value: string (max_call_method_size),
      recend := [[20, 'clc$unspecified_call'], [15, 'clc$linked_call'], [17, 'clc$unlinked_call'], [13,
            'clc$proc_call'], [16, 'clc$program_call']],
      classes: [STATIC, READ, oss$job_paged_literal] array [clt$named_entry_class] of record
        size: 1 .. max_class_size,
        value: string (max_class_size),
      recend := [[17, 'clc$nominal_entry'], [15, 'clc$alias_entry'], [22, 'clc$abbreviation_entry']],
      log_options: [STATIC, READ, oss$job_paged_literal] array [clt$command_log_option] of record
        size: 1 .. max_log_option_size,
        value: string (max_log_option_size),
      recend := [[21, 'clc$automatically_log'], [16, 'clc$manually_log']],
      end_delimeter: string (3),
      ignore_status: ost$status,
      index: integer,
      number_string: ost$string,
      log_option_string: ost$name,
      log_option_length: integer,
      partial_line: string (osc$max_string_size),
      partial_length: integer,
      procedure_name: ost$name,
      procedure_name_size: integer,
      result_length: integer,
      result_line: string (osc$max_string_size);


    status.normal := TRUE;
    end_delimeter := '],';

    FOR index := 1 TO entry_count DO
      procedure_name_size := clp$trimmed_string_size (entry_array^ [index].procedure_name);
      clp$convert_integer_to_string (entry_array^ [index].ordinal, 10, FALSE, number_string, ignore_status);

      IF index = entry_count THEN
        end_delimeter := ']];';
      IFEND;

      STRINGREP (partial_line, partial_length, '  {} [''', entry_array^ [index].
            name, ''', ', classes [entry_array^ [index].class].value (1,
            classes [entry_array^ [index].class].size), ', ',
            availabilities [entry_array^ [index].availability].value (1,
            availabilities [entry_array^ [index].availability].size),
            ', ', number_string.value (1, number_string.size), ',');

      IF table_type = 'COMMAND' THEN
        STRINGREP (log_option_string, log_option_length, ' ',
              log_options [entry_array^ [index].log_option].value
              (1, log_options [entry_array^ [index].log_option].size), ',');
      ELSE
        log_option_string := '';
        log_option_length := 0;
      IFEND;
      CASE entry_array^ [index].call_method OF
      = clc$linked_call =
        #TRANSLATE (osv$upper_to_lower, entry_array^ [index].procedure_name, procedure_name);
        STRINGREP (result_line, result_length, partial_line (1, partial_length),
              log_option_string (1, log_option_length), ' ', call_methods [entry_array^ [index].call_method].
              value (1, call_methods [entry_array^ [index].call_method].size),
              ', ^', procedure_name (1, procedure_name_size), end_delimeter);

      = clc$unlinked_call, clc$proc_call, clc$program_call =
        STRINGREP (result_line, result_length, partial_line (1, partial_length),
              log_option_string (1, log_option_length), ' ', call_methods [entry_array^ [index].call_method].
              value (1, call_methods [entry_array^ [index].call_method].size), ', ''',
              entry_array^ [index].procedure_name (1, procedure_name_size), '''', end_delimeter);

      CASEND;
      write_line (^result_line (1, result_length), 8);

    FOREND;

    IF xref_count = 0 THEN
      put_line ('');
      put_line ('?? POP ??');
      IF module_name <> '' THEN
        put_line ('');
        STRINGREP (result_line, result_length, 'MODEND ', module_name (1, module_name_size), ';');
        put_line (result_line (1, result_length));
      IFEND;
    IFEND;

  PROCEND put_table_entries;
?? TITLE := 'put_xref_procedures', EJECT ??

  PROCEDURE put_xref_procedures;

    VAR
      declaration_count: integer,
      length: integer,
      name_size: 0 .. osc$max_name_size,
      temp_name: ost$name,
      xref_line: string (osc$max_string_size);


  /check_for_duplicates/
    FOR declaration_count := 1 TO xref_count DO
      IF declaration_count < xref_count THEN
        IF xref_array^ [declaration_count] = xref_array^ [declaration_count + 1] THEN
          CYCLE /check_for_duplicates/;
        IFEND;
      IFEND;

      #TRANSLATE (osv$upper_to_lower, xref_array^ [declaration_count], temp_name);
      name_size := clp$trimmed_string_size (temp_name);

      put_line ('');
      STRINGREP (xref_line, length, '  PROCEDURE [XREF] ', temp_name (1, name_size));
      write_line (^xref_line (1, length), 4);
      IF table_type = 'COMMAND' THEN
        put_line ('    (    parameter_list: clt$parameter_list;');
      ELSEIF version = 1 THEN
        put_line ('    (    parameter_list: clt$parameter_list;');
        put_line ('     VAR work_area {input, output} : ^clt$work_area;');
        put_line ('     VAR result: ^clt$data_value;');
      ELSE
        put_line ('    (    function_name: clt$name;');
        put_line ('         argument_list: string ( * );');
        put_line ('     VAR value: clt$value;');
      IFEND;
      put_line ('     VAR status: ost$status);');
    FOREND /check_for_duplicates/;

    put_line ('');
    put_line ('?? POP ??');
    put_line ('');
    IF module_name <> '' THEN
      STRINGREP (xref_line, length, 'MODEND ', module_name (1, module_name_size), ';');
      put_line (xref_line (1, length));
      put_line ('');
    IFEND;

  PROCEND put_xref_procedures;
?? TITLE := 'command_command', EJECT ??

  PROCEDURE command_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$genct_command) command (
{   name, names, n: any of
{       data_name
{       list of data_name
{     anyend = $required
{   processor, p: data_name = $required
{   call_method, cm: key
{       local, xref, load, procedure, proc, program
{     keyend = local
{   availability, a: key
{       (normal_usage, a, advertised, nu)
{       (advanced_usage, au)
{       (hidden, h)
{     keyend = normal_usage
{   log, l: key
{       (automatic, a)
{       (manual, m)
{     keyend = automatic
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 12] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
        default_value: string (12),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (9),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 10, 9, 28, 28, 646],
    clc$command, 12, 6, 2, 0, 0, 0, 6, 'OSM$GENCT_COMMAND'], [
    ['A                              ',clc$abbreviation_entry, 4],
    ['AVAILABILITY                   ',clc$nominal_entry, 4],
    ['CALL_METHOD                    ',clc$nominal_entry, 3],
    ['CM                             ',clc$abbreviation_entry, 3],
    ['L                              ',clc$abbreviation_entry, 5],
    ['LOG                            ',clc$nominal_entry, 5],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PROCESSOR                      ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 42, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 303, clc$optional_default_parameter, 0, 12],
{ PARAMETER 5
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 9],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$data_name_type,
    clc$list_type],
    FALSE, 2],
    3, [[1, 0, clc$data_name_type]],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$data_name_type]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$data_name_type]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [6], [
    ['LOAD                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['LOCAL                          ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['PROC                           ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
    ['PROCEDURE                      ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['PROGRAM                        ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
    ['XREF                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'local'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [8], [
    ['A                              ', clc$alias_entry,
  clc$normal_usage_entry, 1],
    ['ADVANCED_USAGE                 ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['ADVERTISED                     ', clc$alias_entry,
  clc$normal_usage_entry, 1],
    ['AU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['H                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['HIDDEN                         ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['NORMAL_USAGE                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['NU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1]]
    ,
    'normal_usage'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [4], [
    ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['AUTOMATIC                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['M                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['MANUAL                         ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'automatic'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

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

    CONST
      p$name = 1,
      p$processor = 2,
      p$call_method = 3,
      p$availability = 4,
      p$log = 5,
      p$status = 6;

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


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

    IF table_name = '' THEN
      osp$set_status_abnormal ('CL', cle$unexpected_entry, 'TABLE', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'COMMAND', status);
      RETURN;
    ELSEIF table_type <> 'COMMAND' THEN
      osp$set_status_abnormal ('CL', cle$unexpected_entry, table_type, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'COMMAND', status);
      RETURN;
    IFEND;

    echo_input (parameter_list, 'command', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    save_entries (pvt [p$name].value, pvt [p$processor].value^.data_name_value,
          pvt [p$call_method].value^.keyword_value, pvt [p$availability].value^.keyword_value,
          pvt [p$log].value^.keyword_value, status);

  PROCEND command_command;
?? TITLE := 'function_command', EJECT ??

  PROCEDURE function_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$genct_function) function (
{   name, names, n: any of
{       data_name
{       list of data_name
{     anyend = $required
{   processor, p: data_name = $required
{   call_method, cm: key
{       local, xref, load, procedure, proc, program
{     keyend = local
{   availability, a: key
{       (normal_usage, a, advertised, nu)
{       (advanced_usage, au)
{       (hidden, h)
{     keyend = normal_usage
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
        default_value: string (12),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 10, 9, 26, 16, 908],
    clc$command, 10, 5, 2, 0, 0, 0, 5, 'OSM$GENCT_FUNCTION'], [
    ['A                              ',clc$abbreviation_entry, 4],
    ['AVAILABILITY                   ',clc$nominal_entry, 4],
    ['CALL_METHOD                    ',clc$nominal_entry, 3],
    ['CM                             ',clc$abbreviation_entry, 3],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PROCESSOR                      ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 42, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 303, clc$optional_default_parameter, 0, 12],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$data_name_type,
    clc$list_type],
    FALSE, 2],
    3, [[1, 0, clc$data_name_type]],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$data_name_type]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$data_name_type]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [6], [
    ['LOAD                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['LOCAL                          ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['PROC                           ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
    ['PROCEDURE                      ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['PROGRAM                        ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
    ['XREF                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'local'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [8], [
    ['A                              ', clc$alias_entry,
  clc$normal_usage_entry, 1],
    ['ADVANCED_USAGE                 ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['ADVERTISED                     ', clc$alias_entry,
  clc$normal_usage_entry, 1],
    ['AU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['H                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['HIDDEN                         ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['NORMAL_USAGE                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['NU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1]]
    ,
    'normal_usage'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

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

    CONST
      p$name = 1,
      p$processor = 2,
      p$call_method = 3,
      p$availability = 4,
      p$status = 5;

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


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

    IF table_name = '' THEN
      osp$set_status_abnormal ('CL', cle$unexpected_entry, 'TABLE', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'FUNCTION', status);
      RETURN;
    ELSEIF table_type <> 'FUNCTION' THEN
      osp$set_status_abnormal ('CL', cle$unexpected_entry, table_type, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'FUNCTION', status);
      RETURN;
    IFEND;

    echo_input (parameter_list, 'function', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    save_entries (pvt [p$name].value, pvt [p$processor].value^.data_name_value,
          pvt [p$call_method].value^.keyword_value, pvt [p$availability].value^.keyword_value, osc$null_name,
          status);

  PROCEND function_command;
?? TITLE := 'save_entries', EJECT ??

  PROCEDURE save_entries
    (    name_parameter: ^clt$data_value;
         processor: ost$name;
         call_method_keyword: clt$keyword;
         availability_keyword: clt$keyword;
         log_option_keyword: clt$keyword;
     VAR status: ost$status);

    VAR
      availability: clt$named_entry_availability,
      call_method: clt$call_method,
      call_method_is_xref: boolean,
      class: clt$named_entry_class,
      first_name: boolean,
      index: integer,
      log_option: clt$command_log_option,
      node: ^clt$data_value;


    status.normal := TRUE;
    ordinal_count := ordinal_count + 1;

    call_method_is_xref := FALSE;
    IF call_method_keyword = 'XREF' THEN
      call_method := clc$linked_call;
      call_method_is_xref := TRUE;
    ELSEIF call_method_keyword = 'LOCAL' THEN
      call_method := clc$linked_call;
    ELSEIF call_method_keyword = 'LOAD' THEN
      call_method := clc$unlinked_call;
    ELSEIF (call_method_keyword = 'PROCEDURE') OR (call_method_keyword = 'PROC') THEN
      call_method := clc$proc_call;
    ELSE {call_method_keyword = 'PROGRAM'}
      call_method := clc$program_call;
    IFEND;

    IF availability_keyword = 'NORMAL_USAGE' THEN
      availability := clc$normal_usage_entry;
    ELSEIF availability_keyword = 'ADVANCED_USAGE' THEN
      availability := clc$advanced_usage_entry;
    ELSE {availability_keyword = 'HIDDEN'}
      availability := clc$hidden_entry;
    IFEND;

    IF log_option_keyword = 'MANUAL' THEN
      log_option := clc$manually_log;
    ELSE {log_option_keyword = 'AUTOMATIC' OR table_type = 'FUNCTION'}
      log_option := clc$automatically_log;
    IFEND;

    IF name_parameter^.kind = clc$data_name THEN
      PUSH node;
      node^.kind := clc$list;
      node^.element_value := name_parameter;
      node^.link := NIL;
      node^.generated_via_list_rest := FALSE;
    ELSE
      node := name_parameter;
    IFEND;

    first_name := TRUE;
    WHILE node <> NIL DO
      IF (table_name = 'FUNCTION') AND (node^.element_value^.data_name_value (1) <> '$') THEN
        osp$set_status_abnormal ('CL', cle$function_name_needs_$, node^.element_value^.data_name_value,
              status);
        RETURN;
      IFEND;

      FOR index := 1 TO entry_count DO
        IF node^.element_value^.data_name_value = entry_array^ [index].name THEN
          osp$set_status_abnormal ('CL', cle$duplicate_cmnd_or_fcn_name, node^.element_value^.data_name_value,
                status);
          RETURN;
        IFEND;
      FOREND;

      entry_count := entry_count + 1;
      entry_array^ [entry_count].name := node^.element_value^.data_name_value;
      entry_array^ [entry_count].availability := availability;
      entry_array^ [entry_count].ordinal := ordinal_count;
      entry_array^ [entry_count].procedure_name := processor;
      entry_array^ [entry_count].call_method := call_method;
      entry_array^ [entry_count].log_option := log_option;
      IF first_name THEN
        entry_array^ [entry_count].class := clc$nominal_entry;
      ELSEIF node^.link = NIL THEN
        entry_array^ [entry_count].class := clc$abbreviation_entry;
      ELSE
        entry_array^ [entry_count].class := clc$alias_entry;
      IFEND;

      first_name := FALSE;
      node := node^.link;
    WHILEND;

    IF call_method_is_xref THEN
      xref_count := xref_count + 1;
      xref_array^ [xref_count] := processor;
    IFEND;

  PROCEND save_entries;
?? TITLE := 'tablend_command', EJECT ??

  PROCEDURE tablend_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$genct_tablend) tablend, end (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 10, 27, 13, 24, 44, 521], clc$command, 1, 1, 0, 0, 0, 0, 1, 'OSM$GENCT_TABLEND'],
            [['STATUS                         ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

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

    VAR
      interactive: boolean;


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

    echo_input (parameter_list, 'tablend', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_command_origin (interactive, status);
    IF status.normal AND interactive THEN
      clp$end_include (utility_name, status);
    IFEND;

  PROCEND tablend_command;
?? TITLE := 'clp$generate_command_table', EJECT ??

  PROGRAM clp$generate_command_table
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$genct) generate_command_table, genct (
{   input, i: file = $required
{   output, o: file = $required
{   page_width, pw: integer 79..110 = 79
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (2),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 28, 11, 51, 42, 665], clc$command, 7, 4, 2, 0, 0, 0, 4, 'OSM$GENCT'],
            [['I                              ', clc$abbreviation_entry, 1],
            ['INPUT                          ', clc$nominal_entry, 1],
            ['O                              ', clc$abbreviation_entry, 2],
            ['OUTPUT                         ', clc$nominal_entry, 2],
            ['PAGE_WIDTH                     ', clc$nominal_entry, 3],
            ['PW                             ', clc$abbreviation_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 2],

{ PARAMETER 4

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type]],

{ PARAMETER 2

      [[1, 0, clc$file_type]],

{ PARAMETER 3

      [[1, 0, clc$integer_type], [79, 110, 10], '79'],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$input = 1,
      p$output = 2,
      p$page_width = 3,
      p$status = 4;

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

{ table command_table t=c sn=oss$job_paged_literal s=local
{ command command        command_command  cm=local
{ command function       function_command cm=local
{ command table          table_command    cm=local
{ command (tablend, end) tablend_command  cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

    VAR
      command_table: [STATIC, READ, oss$job_paged_literal] ^clt$command_table := ^command_table_entries,

      command_table_entries: [STATIC, READ, oss$job_paged_literal] array [1 .. 5] of
            clt$command_table_entry := [
            {} ['COMMAND                        ', clc$nominal_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^command_command],
            {} ['END                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^tablend_command],
            {} ['FUNCTION                       ', clc$nominal_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^function_command],
            {} ['TABLE                          ', clc$nominal_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^table_command],
            {} ['TABLEND                        ', clc$nominal_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^tablend_command]];

?? POP ??

    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      default_creation_attributes: array [1 .. 2] of fst$file_cycle_attribute,
      local_status: ost$status,
      segment_pointer: amt$segment_pointer,
      utility_attributes: array [1 .. 4] of clt$utility_attribute,
      validation_attributes: array [1 .. 4] of fst$file_cycle_attribute;


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

    page_width := pvt [p$page_width].value^.integer_value.value;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
    attachment_options [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options [1].share_modes.value := $fst$file_access_options [];
    attachment_options [2].selector := fsc$access_and_share_modes;
    attachment_options [2].access_modes.selector := fsc$specific_access_modes;
    attachment_options [2].access_modes.value := $fst$file_access_options [fsc$append];
    attachment_options [2].share_modes.selector := fsc$specific_share_modes;
    attachment_options [2].share_modes.value := $fst$file_access_options [];
    attachment_options [3].selector := fsc$open_share_modes;
    attachment_options [3].open_share_modes := -$fst$file_access_options [];
    validation_attributes [1].selector := fsc$file_contents_and_processor;
    validation_attributes [1].file_contents := fsc$legible_data;
    validation_attributes [1].file_processor := osc$null_name;
    validation_attributes [2].selector := fsc$file_contents_and_processor;
    validation_attributes [2].file_contents := amc$legible;
    validation_attributes [2].file_processor := osc$null_name;
    validation_attributes [3].selector := fsc$file_contents_and_processor;
    validation_attributes [3].file_contents := fsc$data;
    validation_attributes [3].file_processor := osc$null_name;
    validation_attributes [4].selector := fsc$file_contents_and_processor;
    validation_attributes [4].file_contents := fsc$unknown_contents;
    validation_attributes [4].file_processor := osc$null_name;
    default_creation_attributes [1].selector := fsc$file_contents_and_processor;
    default_creation_attributes [1].file_contents := fsc$legible_data;
    default_creation_attributes [1].file_processor := osc$null_name;
    default_creation_attributes [2].selector := fsc$page_format;
    default_creation_attributes [2].page_format := amc$untitled_form;
    fsp$open_file (pvt [p$output].value^.file_value^, amc$record, ^attachment_options,
          ^default_creation_attributes, NIL, ^validation_attributes, NIL, output_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /generate_command_table/
    BEGIN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /generate_command_table/;
      IFEND;
      RESET segment_pointer.sequence_pointer;
      NEXT entry_array: [1 .. #SIZE (segment_pointer.sequence_pointer^) DIV #SIZE (entry)] IN
            segment_pointer.sequence_pointer;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /generate_command_table/;
      IFEND;
      RESET segment_pointer.sequence_pointer;
      NEXT xref_array: [1 .. #SIZE (segment_pointer.sequence_pointer^) DIV #SIZE (ost$name)] IN
            segment_pointer.sequence_pointer;

      utility_attributes [1].key := clc$utility_command_search_mode;
      utility_attributes [1].command_search_mode := clc$global_command_search;
      utility_attributes [2].key := clc$utility_command_table;
      utility_attributes [2].command_table := command_table;
      utility_attributes [3].key := clc$utility_termination_command;
      utility_attributes [3].termination_command := 'tablend';
      utility_attributes [4].key := clc$utility_prompt;
      utility_attributes [4].prompt.value := prompt_string;
      utility_attributes [4].prompt.size := prompt_string_size;
      clp$begin_utility (utility_name, utility_attributes, status);
      IF NOT status.normal THEN
        EXIT /generate_command_table/;
      IFEND;

      clp$include_file (pvt [p$input].value^.file_value^, prompt_string, utility_name, status);
      IF NOT status.normal THEN
        EXIT /generate_command_table/;
      IFEND;

      clp$end_utility (utility_name, status);
      IF NOT status.normal THEN
        EXIT /generate_command_table/;
      IFEND;

      IF entry_count > 0 THEN
        complete_current_table;
      ELSEIF new_table_started = TRUE THEN
        put_table_header;
        new_table_started := FALSE;
      IFEND;
    END /generate_command_table/;

    fsp$close_file (output_file_id, local_status);
    IF (NOT local_status.normal) AND status.normal THEN
      status := local_status;
    IFEND;

  PROCEND clp$generate_command_table;

MODEND clm$generate_command_table;
*DECK DECK=CLM$GENERATE_PDT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Parameter Description Table and Type Specification Generator' ??
MODULE clm$generate_pdt;

{
{ PURPOSE:
{   This module contains the program that generates the CYBIL declarations
{   for a Parameter Description Table for a command (PROCEDURE) or FUNCTION
{   processor, or a TYPE specification.  It can also handle "old" (pre- SCL
{   New Types) Parameter Descriptor Table (PDT) specifications.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amd$page_format_declarations
*copyc clc$lexical_units_size_pad
*copyc clc$max_integer
*copyc clc$max_proc_names
*copyc clc$min_integer
*copyc clc$proc_pdt_parameter_limits
*copyc cle$ecc_lexical
*copyc cle$ecc_line_length
*copyc cle$ecc_parsing
*copyc clt$command_line
*copyc clt$command_line_index
*copyc clt$command_line_size
*copyc clt$parameter_description_table
*copyc clt$parameter_descriptor_table
*copyc clt$parameter_list
*copyc clt$parameter_list_text_size
*copyc clt$symbolic_subrange_qualifier
*copyc clt$type_specification
*IF NOT $true(osv$unix)
*copyc oss$job_paged_literal
*ELSE
*copyc clc$declaration_version
*copyc clp$type_kinds_v2
*copyc clt$type_name
*copyc clt$type_kinds_v2
*IFEND
*copyc ost$name_reference
*copyc ost$status
*IF NOT $true(osv$unix)
*copyc pmt$program_name
*IFEND
?? POP ??
*IF NOT $true(osv$unix)
*copyc amv$nil_file_identifier
*IFEND
*copyc clp$append_status_parse_state
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$get_work_area
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*IF NOT $true(osv$unix)
*copyc clp$internal_generate_old_pdt
*IFEND
*copyc clp$internal_generate_pdt
*IF NOT $true(osv$unix)
*copyc clp$internal_gen_type_spec
*IFEND
*copyc clp$scan_non_space_lexical_unit
*copyc clp$trimmed_string_size
*IF NOT $true(osv$unix)
*copyc fsp$close_file
*copyc fsp$open_file
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*IFEND
*copyc osp$append_status_parameter
*IF NOT $true(osv$unix)
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*IFEND
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc osv$upper_to_lower
*IF NOT $true(osv$unix)
*copyc pmp$get_compact_date_time
*IFEND

  CONST
    indent_increment = 2,
    initial_indent = 5,
    max_indent = 41;

  VAR
    current_indent: amt$page_width,
    max_indent_exceeded_count: 0 .. amc$max_page_width := 0,
    max_indent_exceeded_cnt: 0 .. amc$max_page_width;

  VAR
    ignore_status: ost$status;

  VAR
*IF NOT $true(osv$unix)
    type_kind_names: [STATIC, READ, oss$job_paged_literal] array [clt$type_kind] of
          clt$type_name := ['clc$application_type', 'clc$array_type', 'clc$boolean_type',
          'clc$cobol_name_type', 'clc$command_reference_type', 'clc$data_name_type', 'clc$date_time_type',
          'clc$entry_point_reference_type', 'clc$file_type', 'clc$integer_type', 'clc$keyword_type',
          'clc$list_type', 'clc$lock_type', 'clc$name_type', 'clc$network_title_type',
          'clc$program_name_type', 'clc$range_type', 'clc$real_type', 'clc$record_type',
          'clc$scu_line_identifier_type', 'clc$statistic_code_type', 'clc$status_type',
          'clc$status_code_type', 'clc$string_type', 'clc$string_pattern_type', 'clc$time_increment_type',
          'clc$time_zone_type', 'clc$type_specification_type', 'clc$union_type'];
*ELSE
    type_kind_names: [STATIC, READ] array [clc$application_type .. clc$unix_file_type]
          of clt$type_name := ['clc$application_type', 'clc$array_type', 'clc$boolean_type',
          'clc$cobol_name_type', 'clc$command_reference_type', 'clc$data_name_type', 'clc$date_time_type',
          'clc$entry_point_reference_type', 'clc$nos_ve_file_type', 'clc$integer_type', 'clc$keyword_type',
          'clc$list_type', 'clc$lock_type', 'clc$name_type', 'clc$network_title_type',
          'clc$program_name_type', 'clc$range_type', 'clc$real_type', 'clc$record_type',
          'clc$scu_line_identifier_type', 'clc$statistic_code_type', 'clc$status_type',
          'clc$status_code_type', 'clc$string_type', 'clc$string_pattern_type', 'clc$time_increment_type',
          'clc$time_zone_type', 'clc$type_specification_type', 'clc$union_type', 'clc$unix_file_type'];
*IFEND

*IF $true(osv$unix)
  VAR
    file_type_kind_name: [STATIC, READ] clt$type_name := 'clc$file_type';
*IFEND

?? TITLE := 'clp$_generate_pdt', EJECT ??

*IF NOT $true(osv$unix)
  PROGRAM clp$_generate_pdt
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$genpdt) generate_pdt, genpdt (
{   input, i: file = $required
{   output, o: file = $required
{   page_width, pw: integer 79..110 = 79
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (2),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 28, 11, 50, 47, 320], clc$command, 7, 4, 2, 0, 0, 0, 4, 'OSM$GENPDT'],
            [['I                              ', clc$abbreviation_entry, 1],
            ['INPUT                          ', clc$nominal_entry, 1],
            ['O                              ', clc$abbreviation_entry, 2],
            ['OUTPUT                         ', clc$nominal_entry, 2],
            ['PAGE_WIDTH                     ', clc$nominal_entry, 3],
            ['PW                             ', clc$abbreviation_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 2],

{ PARAMETER 4

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type]],

{ PARAMETER 2

      [[1, 0, clc$file_type]],

{ PARAMETER 3

      [[1, 0, clc$integer_type], [79, 110, 10], '79'],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$input = 1,
      p$output = 2,
      p$page_width = 3,
      p$status = 4;

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

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

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


      clean_up;

    PROCEND abort_handler;
?? TITLE := 'clean_up', EJECT ??

    PROCEDURE clean_up;


      IF input_file_id <> amv$nil_file_identifier THEN
        fsp$close_file (input_file_id, ignore_status);
        input_file_id := amv$nil_file_identifier;
      IFEND;
      IF output_file_id <> amv$nil_file_identifier THEN
        fsp$close_file (output_file_id, ignore_status);
        output_file_id := amv$nil_file_identifier;
      IFEND;
      IF symbolic_work_area_segment.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (symbolic_work_area_segment, ignore_status);
        symbolic_work_area_segment.sequence_pointer := NIL;
      IFEND;

    PROCEND clean_up;
*ELSE
  PROGRAM clp_generate_pdt;

*IFEND
?? TITLE := 'get_out', EJECT ??

    PROCEDURE get_out
      (    exit_status: ost$status);


      status := exit_status;
*IF NOT $true(osv$unix)
      EXIT clp$_generate_pdt;
*ELSE
      EXIT clp_generate_pdt;
*IFEND

    PROCEND get_out;
?? OLDTITLE, EJECT ??
*IF NOT $true(osv$unix)

    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      command_or_function: clt$command_or_function,
      default_creation_attributes: array [1 .. 2] of fst$file_cycle_attribute,
      end_of_input: boolean,
      input_file_id: amt$file_identifier,
      input_file_position: amt$file_position,
      name: ost$name,
      output_file_attributes: array [1 .. 1] of amt$fetch_item,
      output_file_id: amt$file_identifier,
      page_width: amt$page_width,
      parse: clt$parse_state,
      symbolic_work_area_segment: amt$segment_pointer,
      validation_attributes: array [1 .. 6] of fst$file_cycle_attribute,
      work_area: ^^clt$work_area;


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

    page_width := pvt [p$page_width].value^.integer_value.value;

    validation_attributes [1].selector := fsc$file_contents_and_processor;
    validation_attributes [1].file_contents := fsc$legible_scl_procedure;
    validation_attributes [1].file_processor := osc$null_name;
    validation_attributes [2].selector := fsc$file_contents_and_processor;
    validation_attributes [2].file_contents := fsc$legible_scl_include;
    validation_attributes [2].file_processor := osc$null_name;
    validation_attributes [3].selector := fsc$file_contents_and_processor;
    validation_attributes [3].file_contents := fsc$legible_data;
    validation_attributes [3].file_processor := osc$null_name;
    validation_attributes [4].selector := fsc$file_contents_and_processor;
    validation_attributes [4].file_contents := amc$legible;
    validation_attributes [4].file_processor := osc$null_name;
    validation_attributes [5].selector := fsc$file_contents_and_processor;
    validation_attributes [5].file_contents := fsc$data;
    validation_attributes [5].file_processor := osc$null_name;
    validation_attributes [6].selector := fsc$file_contents_and_processor;
    validation_attributes [6].file_contents := fsc$unknown_contents;
    validation_attributes [6].file_processor := osc$null_name;

    input_file_id := amv$nil_file_identifier;
    output_file_id := amv$nil_file_identifier;
    symbolic_work_area_segment.kind := amc$sequence_pointer;
    symbolic_work_area_segment.sequence_pointer := NIL;
    #SPOIL (input_file_id, output_file_id, symbolic_work_area_segment);

    osp$establish_block_exit_hndlr (^abort_handler);

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_options [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
    attachment_options [2].selector := fsc$open_share_modes;
    attachment_options [2].open_share_modes := $fst$file_access_options [fsc$read, fsc$execute];
    attachment_options [3].selector := fsc$create_file;
    attachment_options [3].create_file := FALSE;
    fsp$open_file (pvt [p$input].value^.file_value^, amc$record, ^attachment_options, NIL, NIL,
          ^validation_attributes, NIL, input_file_id, status);
    IF NOT status.normal THEN
      clean_up;
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
    attachment_options [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options [1].share_modes.value := $fst$file_access_options [];
    attachment_options [2].selector := fsc$access_and_share_modes;
    attachment_options [2].access_modes.selector := fsc$specific_access_modes;
    attachment_options [2].access_modes.value := $fst$file_access_options [fsc$append];
    attachment_options [2].share_modes.selector := fsc$specific_share_modes;
    attachment_options [2].share_modes.value := $fst$file_access_options [];
    attachment_options [3].selector := fsc$open_share_modes;
    attachment_options [3].open_share_modes := -$fst$file_access_options [];
    validation_attributes [1].selector := fsc$null_attribute;
    validation_attributes [2].selector := fsc$null_attribute;
    default_creation_attributes [1].selector := fsc$file_contents_and_processor;
    default_creation_attributes [1].file_contents := fsc$legible_data;
    default_creation_attributes [1].file_processor := osc$null_name;
    default_creation_attributes [2].selector := fsc$page_format;
    default_creation_attributes [2].page_format := amc$untitled_form;
    fsp$open_file (pvt [p$output].value^.file_value^, amc$record, ^attachment_options,
          ^default_creation_attributes, NIL, ^validation_attributes, NIL, output_file_id, status);
    IF NOT status.normal THEN
      clean_up;
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
*ELSE
    VAR
      command_or_function: clt$command_or_function,
      end_of_input: boolean,
      name: ost$name,
      parse: clt$parse_state,
      status: ost$status,
      symbolic_work_area_segment: ^clt$work_area,
      work_area: ^^clt$work_area;
*IFEND

*IF NOT $true(osv$unix)
    clp$get_work_area (#RING (^work_area), work_area, status);
*ELSE
    clp$get_work_area (osc$user_ring, work_area, status);
*IFEND
    IF NOT status.normal THEN
*IF NOT $true(osv$unix)
      clean_up;
      osp$disestablish_cond_handler;
*IFEND
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    clp$ip_initialize (pvt [p$input].value^.file_value^, input_file_id, ^input_file_position, NIL,
          ^clp$op_echo, work_area^, status);
*ELSE
    clp$ip_initialize ('pdt_in', NIL,
          ^clp$op_echo, work_area^, status);
*IFEND
    IF NOT status.normal THEN
*IF NOT $true(osv$unix)
      clean_up;
      osp$disestablish_cond_handler;
*IFEND
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    clp$op_initialize (output_file_id, page_width, ^get_out);
*ELSE
    clp$op_initialize (80, ^get_out);
*IFEND

    current_indent := initial_indent;

    REPEAT
      clp$input_procedure (parse, end_of_input, status);
      IF (NOT status.normal) OR end_of_input THEN
*IF NOT $true(osv$unix)
        clean_up;
*IFEND
        RETURN;
      IFEND;
      clp$scan_non_space_lexical_unit (parse);
    UNTIL parse.unit.kind <> clc$lex_end_of_line;

    IF parse.unit.kind = clc$lex_name THEN
      #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
*IF NOT $true(osv$unix)
      IF name = 'PDT' THEN
        generate_old_pdt (work_area^, parse, status);
      ELSEIF name = 'TYPE' THEN
        generate_type (symbolic_work_area_segment, work_area^, parse, status);
      ELSE
*IFEND
        IF name = 'PROCEDURE' THEN
          command_or_function := clc$command;
        ELSEIF name = 'FUNCTION' THEN
          command_or_function := clc$function;
        ELSE
          osp$set_status_abnormal ('CL', cle$expecting_proc_func_or_type, name, status);
          RETURN;
        IFEND;
        generate_pdt (command_or_function, symbolic_work_area_segment, work_area^, parse, status);
*IF NOT $true(osv$unix)
      IFEND;
*IFEND
    ELSE
      osp$set_status_abnormal ('CL', cle$expecting_proc_func_or_type, '', status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    clean_up;

  PROCEND clp$_generate_pdt;
*ELSE
  PROCEND clp_generate_pdt;
*IFEND
?? TITLE := 'generate_pdt', EJECT ??

  PROCEDURE generate_pdt
    (    command_or_function: clt$command_or_function;
*IF NOT $true(osv$unix)
     VAR symbolic_work_area_segment {input, output} : amt$segment_pointer;
*ELSE
     VAR symbolic_work_area_segment {input, output} : ^clt$work_area;
*IFEND
     VAR work_area {input, output} : ^clt$work_area;
     VAR parse: clt$parse_state;
     VAR status: ost$status);

?? NEWTITLE := 'put_extra_stuff', EJECT ??

    PROCEDURE put_extra_stuff;

      CONST
        prefix = 'p$',
        prefix_size = 2;

      VAR
        adjusted_name_size: ost$name_size,
        ch: char,
        char_index: ost$name_size,
        name: clt$parameter_name,
        name_changed: boolean,
        name_index: clt$parameter_name_index,
        name_size: ost$name_size,
        parameter_index: clt$parameter_number;


      clp$op_put_line ('');
      clp$op_put_line ('    CONST');
      FOR parameter_index := 1 TO UPPERBOUND (parameters^) DO

        name_index := parameters^ [parameter_index].name_index;
        name_size := clp$trimmed_string_size (parameter_names^ [name_index].name);
        IF name_size <= (osc$max_name_size - prefix_size) THEN
          adjusted_name_size := name_size;
          name_changed := FALSE;
        ELSE
          adjusted_name_size := osc$max_name_size - prefix_size;
          name_changed := TRUE;
        IFEND;
        FOR char_index := 1 TO adjusted_name_size DO
          ch := parameter_names^ [name_index].name (char_index);
          CASE ch OF
          = 'a' .. 'z', '0' .. '9', '_', '$', '#', '@' =
            name (char_index) := ch;
          = 'A' .. 'Z' =
            name (char_index) := $CHAR ($INTEGER (ch) - $INTEGER ('A') + $INTEGER ('a'));
          ELSE
            name (char_index) := '_';
            name_changed := TRUE;
          CASEND;
        FOREND;

        clp$op_add_to_line ('      ' CAT prefix);
        clp$op_add_to_line (name (1, adjusted_name_size));
        clp$op_add_to_line (' = ');
        clp$op_add_integer_to_line (parameter_index);
        IF name_changed THEN
          clp$op_add_to_line (' {');
          clp$op_add_to_line (parameter_names^ [name_index].name (1, name_size));
          clp$op_add_to_line ('} ');
        IFEND;
        IF parameter_index < UPPERBOUND (parameters^) THEN
          clp$op_add_to_line (',');
        ELSE
          clp$op_add_to_line (';');
        IFEND;
        clp$op_flush_line;
      FOREND;

      clp$op_put_line ('');
      clp$op_put_line ('    VAR');
      clp$op_add_to_line ('      pvt: array [1 .. ');
      clp$op_add_integer_to_line (pdt_header^.number_of_parameters);
      clp$op_add_to_line ('] of clt$parameter_value;');
      clp$op_flush_line;

    PROCEND put_extra_stuff;
?? TITLE := 'put_parameter_array_values', EJECT ??

    PROCEDURE put_parameter_array_values;

      VAR
        index: clt$parameter_count;


      clp$op_tab_line (current_indent);
      clp$op_add_to_line ('['); {for parameter array
      clp$op_flush_line;

      FOR index := 1 TO UPPERBOUND (parameters^) DO
        clp$op_add_to_line ('{ PARAMETER ');
        clp$op_add_integer_to_line (index);
        clp$op_flush_line;
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('['); {for parameter entry in array
        clp$op_add_integer_to_line (parameters^ [index].name_index);
        clp$op_add_to_line (', ');
        CASE parameters^ [index].availability OF
        = clc$normal_usage_entry =
          clp$op_add_to_line ('clc$normal_usage_entry, ');
        = clc$advanced_usage_entry =
          clp$op_add_to_line ('clc$advanced_usage_entry, ');
        = clc$hidden_entry =
          clp$op_add_to_line ('clc$hidden_entry, ');
        CASEND;
        IF parameters^ [index].security = clc$non_secure_parameter THEN
          clp$op_add_to_line ('clc$non_secure_parameter,');
        ELSE
          clp$op_add_to_line ('clc$secure_parameter,');
        IFEND;
        clp$op_flush_line;

        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('$clt$parameter_spec_methods[');
        IF clc$specify_by_name IN parameters^ [index].specification_methods THEN
          clp$op_add_to_line ('clc$specify_by_name');
          IF clc$specify_positionally IN parameters^ [index].specification_methods THEN
            clp$op_add_to_line (', ');
          IFEND;
        IFEND;
        IF clc$specify_positionally IN parameters^ [index].specification_methods THEN
          clp$op_add_to_line ('clc$specify_positionally');
        IFEND;
        clp$op_add_to_line ('],');
        clp$op_flush_line;

        clp$op_tab_line (current_indent);
        IF parameters^ [index].passing_method = clc$pass_by_value THEN
          clp$op_add_to_line ('clc$pass_by_value, ');
        ELSE
          clp$op_add_to_line ('clc$pass_by_reference, ');
        IFEND;
        IF parameters^ [index].evaluation_method = clc$immediate_evaluation THEN
          clp$op_add_to_line ('clc$immediate_evaluation, ');
        ELSE
          clp$op_add_to_line ('clc$deferred_evaluation, ');
        IFEND;
        IF parameters^ [index].checking_level = clc$standard_parameter_checking THEN
          clp$op_add_to_line ('clc$standard_parameter_checking, ');
        ELSE
          clp$op_add_to_line ('clc$extended_parameter_checking, ');
        IFEND;
        clp$op_add_integer_to_line (parameters^ [index].type_specification_size);
        clp$op_add_to_line (', ');

        CASE parameters^ [index].requirement OF
        = clc$required_parameter =
          clp$op_add_to_line ('clc$required_parameter, ');
        = clc$optional_parameter =
          clp$op_add_to_line ('clc$optional_parameter, ');
        = clc$optional_default_parameter =
          clp$op_add_to_line ('clc$optional_default_parameter, ');
        = clc$confirm_default_parameter =
          clp$op_add_to_line ('clc$confirm_default_parameter, ');
        CASEND;

        clp$op_add_integer_to_line (parameters^ [index].default_name_size);
        clp$op_add_to_line (', ');
        clp$op_add_integer_to_line (parameters^ [index].default_value_size);
        IF index < UPPERBOUND (parameters^) THEN
          clp$op_add_to_line ('],');
        ELSE
          clp$op_add_to_line (']],');
        IFEND;
        clp$op_flush_line;
      FOREND;

    PROCEND put_parameter_array_values;
?? TITLE := 'put_parameter_names', EJECT ??

    PROCEDURE put_parameter_names;

      VAR
        index: clt$parameter_name_count,
        name_size: ost$name_size;


      clp$op_add_to_line ('[');
      clp$op_flush_line;
      clp$op_tab_line (current_indent);

      FOR index := 1 TO UPPERBOUND (parameter_names^) DO
        clp$op_add_to_line ('[''');
        clp$op_add_to_line (parameter_names^ [index].name);
        clp$op_add_to_line (''',');

        CASE parameter_names^ [index].class OF
        = clc$nominal_entry =
          clp$op_add_to_line ('clc$nominal_entry, ');
        = clc$alias_entry =
          clp$op_add_to_line ('clc$alias_entry, ');
        = clc$abbreviation_entry =
          clp$op_add_to_line ('clc$abbreviation_entry, ');
        CASEND;

        clp$op_add_integer_to_line (parameter_names^ [index].position);
        IF index < UPPERBOUND (parameter_names^) THEN
          clp$op_add_to_line ('],');
          clp$op_flush_line;
          clp$op_tab_line (current_indent);
        ELSE
          clp$op_add_to_line (']');
        IFEND;
      FOREND;
      clp$op_add_to_line ('],');
      clp$op_flush_line;
      clp$op_tab_line (current_indent);

    PROCEND put_parameter_names;
?? TITLE := 'put_parameter_specs', EJECT ??

    PROCEDURE put_parameter_specs;

      VAR
        default: ^clt$expression_text,
        i: 1 .. clc$max_parameters,
        parameter_name_index: 1 .. clc$max_parameter_names + 1;


      FOR i := 1 TO UPPERBOUND (parameters^) DO
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('type');
        clp$op_add_integer_to_line (i);
        clp$op_add_to_line (': record');
        clp$op_flush_line;
        increment_indent;

        put_type_spec (pdt);

        IF parameters^ [i].default_name_size > 0 THEN
          NEXT default: [parameters^ [i].default_name_size] IN pdt;
          clp$op_tab_line (current_indent);
*IF $true(osv$unix)
          clp$op_add_to_line ('default_name: ALIGNED [0 MOD 4] string (');
*ELSEIF ($variable(osv$64_bit_word, declared) = 'LOCAL') AND osv$64_bit_word
          clp$op_add_to_line ('default_name: ALIGNED [0 MOD 8] string (');
*ELSE
          clp$op_add_to_line ('default_name: string (');
*IFEND
          clp$op_add_integer_to_line (parameters^ [i].default_name_size);
          clp$op_add_to_line ('),');
          clp$op_flush_line;
        IFEND;
        IF parameters^ [i].default_value_size > 0 THEN
          NEXT default: [parameters^ [i].default_value_size] IN pdt;
          clp$op_tab_line (current_indent);
*IF $true(osv$unix)
          clp$op_add_to_line ('default_value: ALIGNED [0 MOD 4] string (');
*ELSEIF ($variable(osv$64_bit_word, declared) = 'LOCAL') AND osv$64_bit_word
          clp$op_add_to_line ('default_value: ALIGNED [0 MOD 8] string (');
*ELSE
          clp$op_add_to_line ('default_value: string (');
*IFEND
          clp$op_add_integer_to_line (parameters^ [i].default_value_size);
          clp$op_add_to_line ('),');
          clp$op_flush_line;
        IFEND;
        decrement_indent;
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('recend,');
        clp$op_flush_line;
      FOREND;

    PROCEND put_parameter_specs;
?? TITLE := 'put_pdt_header_spec', EJECT ??

    PROCEDURE put_pdt_header_spec;


      clp$op_put_line ('');
      clp$op_put_line ('?? PUSH (LISTEXT := ON) ??');
      clp$op_put_line ('?? FMT (FORMAT := OFF) ??');
      clp$op_put_line ('');
      clp$op_put_line ('  VAR');
      current_indent := initial_indent;
      clp$op_put_line ('    pdt: [STATIC, READ, cls$declaration_section] record');
      increment_indent;
      clp$op_tab_line (current_indent);
      clp$op_add_to_line ('header: clt$pdt_header,');
      clp$op_flush_line;

      IF parameter_names <> NIL THEN
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('names: array [1 .. ');
        clp$op_add_integer_to_line (pdt_header^.number_of_parameter_names);
        clp$op_add_to_line ('] of clt$pdt_parameter_name,');
        clp$op_flush_line;

        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('parameters: array [1 .. ');
        clp$op_add_integer_to_line (pdt_header^.number_of_parameters);
        clp$op_add_to_line ('] of clt$pdt_parameter,');
        clp$op_flush_line;
      IFEND;

    PROCEND put_pdt_header_spec;
?? TITLE := 'put_type_values', EJECT ??

    PROCEDURE put_type_values;

      VAR
        default: ^string ( * ),
        i: 1 .. clc$max_parameters,
        parameter_name_index: 1 .. clc$max_parameter_names + 1,
        string_index: ost$string_index;


      FOR i := 1 TO UPPERBOUND (parameters^) DO
        clp$op_flush_line;
        clp$op_add_to_line ('{ PARAMETER ');
        clp$op_add_integer_to_line (i);
        clp$op_flush_line;
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('[');

*IF NOT $true(osv$unix)
        put_type_value (pdt, symbolic_work_area_segment.sequence_pointer);
*ELSE
        put_type_value (pdt, symbolic_work_area_segment);
*IFEND

        IF parameters^ [i].default_name_size > 0 THEN
          NEXT default: [parameters^ [i].default_name_size] IN pdt;
          clp$op_add_to_line (',');
          clp$op_flush_line;
          clp$op_tab_line (current_indent);
          clp$op_add_to_line ('''');
          clp$op_add_to_line (default^);
          clp$op_add_to_line ('''');
        IFEND;

        IF parameters^ [i].default_value_size > 0 THEN
          NEXT default: [parameters^ [i].default_value_size] IN pdt;
          clp$op_add_to_line (',');
          clp$op_flush_line;
          clp$op_tab_line (current_indent);
          clp$op_add_to_line ('''');
          FOR string_index := 1 TO STRLENGTH (default^) DO
            IF (clv$op.line_size = clv$op.page_width - 1) OR ((default^ (string_index) = '''') AND
                  (clv$op.line_size + 3 > clv$op.page_width)) THEN
              clp$op_add_to_line ('''');
              clp$op_flush_line;
              clp$op_tab_line (current_indent);
              clp$op_start_line ('CAT ''');
            IFEND;

            clp$op_add_to_line (default^ (string_index));
            IF default^ (string_index) = '''' THEN
              clp$op_add_to_line ('''');
            IFEND;
          FOREND;

          IF clv$op.line_size >= clv$op.page_width THEN
            clp$op_flush_line;
            clp$op_tab_line (current_indent);
            clp$op_add_to_line ('CAT ''''''');
          IFEND;
          clp$op_add_to_line ('''');
        IFEND;
        IF i < UPPERBOUND (parameters^) THEN
          clp$op_add_to_line ('], ');
        ELSE
          clp$op_add_to_line (']');
        IFEND;
      FOREND;

    PROCEND put_type_values;
?? OLDTITLE, EJECT ??

    VAR
      aliases: ^array [1 .. * ] of pmt$program_name,
      availability: clt$named_entry_availability,
      command_or_function_name: pmt$program_name,
      command_log_option: clt$command_log_option,
      command_or_function_scope: clt$command_or_function_scope,
      parameter_names: ^clt$pdt_parameter_names,
      parameters: ^clt$pdt_parameters,
      pdt: ^clt$parameter_description_table,
      pdt_header: ^clt$pdt_header;


*IF NOT $true(osv$unix)
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, symbolic_work_area_segment, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET symbolic_work_area_segment.sequence_pointer;

*ELSE
    ALLOCATE symbolic_work_area_segment :[[REP 5ffff(16) OF cell]];
    RESET symbolic_work_area_segment;
*IFEND

    clp$scan_non_space_lexical_unit (parse);

    clp$internal_generate_pdt (command_or_function, ^clp$input_procedure,
*IF NOT $true(osv$unix)
          symbolic_work_area_segment.sequence_pointer, work_area, parse, command_or_function_name, aliases,
*ELSE
          symbolic_work_area_segment, work_area, parse, command_or_function_name, aliases,
*IFEND
          availability, command_or_function_scope, command_log_option, pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET pdt;
    NEXT pdt_header IN pdt;
    IF pdt_header^.number_of_parameters > 0 THEN
      NEXT parameter_names: [1 .. pdt_header^.number_of_parameter_names] IN pdt;
      NEXT parameters: [1 .. pdt_header^.number_of_parameters] IN pdt;
    ELSE
      parameter_names := NIL;
      parameters := NIL;
    IFEND;
    put_pdt_header_spec;
    IF parameters <> NIL THEN
      put_parameter_specs;
    IFEND;

    current_indent := initial_indent;
    clp$op_tab_line (current_indent);
    clp$op_add_to_line ('recend := [');
    clp$op_flush_line;

    RESET pdt;
    NEXT pdt_header IN pdt;
    IF pdt_header^.number_of_parameters > 0 THEN
      NEXT parameter_names: [1 .. pdt_header^.number_of_parameter_names] IN pdt;
      NEXT parameters: [1 .. pdt_header^.number_of_parameters] IN pdt;
    IFEND;

    clp$op_tab_line (current_indent);
    clp$op_add_to_line ('[');
*IF NOT $true(osv$unix)
    clp$op_add_integer_to_line (pdt_header^.version);
*ELSE
    clp$op_add_integer_to_line (clc$declaration_version);
*IFEND
    clp$op_add_to_line (',');
    clp$op_flush_line;
    clp$op_tab_line (current_indent);
    clp$op_add_to_line ('[');
    clp$op_add_integer_to_line (pdt_header^.generation_date_time.year);
    clp$op_add_to_line (', ');
    clp$op_add_integer_to_line (pdt_header^.generation_date_time.month);
    clp$op_add_to_line (', ');
    clp$op_add_integer_to_line (pdt_header^.generation_date_time.day);
    clp$op_add_to_line (', ');
    clp$op_add_integer_to_line (pdt_header^.generation_date_time.hour);
    clp$op_add_to_line (', ');
    clp$op_add_integer_to_line (pdt_header^.generation_date_time.minute);
    clp$op_add_to_line (', ');
    clp$op_add_integer_to_line (pdt_header^.generation_date_time.second);
    clp$op_add_to_line (', ');
    clp$op_add_integer_to_line (pdt_header^.generation_date_time.millisecond);
    clp$op_add_to_line ('],');
    clp$op_flush_line;
    clp$op_tab_line (current_indent);
    IF pdt_header^.command_or_function = clc$command THEN
      clp$op_add_to_line ('clc$command, ');
    ELSE
      clp$op_add_to_line ('clc$function, ');
    IFEND;
    clp$op_add_integer_to_line (pdt_header^.number_of_parameter_names);
    clp$op_add_to_line (', ');
    clp$op_add_integer_to_line (pdt_header^.number_of_parameters);
    clp$op_add_to_line (', ');
    clp$op_add_integer_to_line (pdt_header^.number_of_required_parameters);
    clp$op_add_to_line (', ');
    clp$op_add_integer_to_line (pdt_header^.number_of_advanced_parameters);
    clp$op_add_to_line (', ');
    clp$op_add_integer_to_line (pdt_header^.number_of_hidden_parameters);
    clp$op_add_to_line (', ');
    clp$op_add_integer_to_line (pdt_header^.number_of_var_parameters);
    clp$op_add_to_line (', ');
    clp$op_add_integer_to_line (pdt_header^.status_parameter_number);
    clp$op_add_to_line (', ''');
    clp$op_add_to_line (pdt_header^.help_module_name (1, clp$trimmed_string_size
          (pdt_header^.help_module_name)));
    clp$op_add_to_line (''']');

    IF pdt_header^.number_of_parameters > 0 THEN
      clp$op_add_to_line (', ');
      put_parameter_names;
      put_parameter_array_values;
      put_type_values;
    IFEND;

    clp$op_add_to_line ('];');
    clp$op_flush_line;

    clp$op_put_line ('');
    clp$op_put_line ('?? FMT (FORMAT := ON) ??');
    clp$op_put_line ('?? POP ??');

    IF pdt_header^.number_of_parameters > 0 THEN
      put_extra_stuff;
    IFEND;

  PROCEND generate_pdt;
?? TITLE := 'generate_old_pdt', EJECT ??

*IF NOT $true(osv$unix)
  PROCEDURE generate_old_pdt
    (VAR work_area {input, output} : ^clt$work_area;
     VAR parse {input, output} : clt$parse_state;
     VAR status: ost$status);

?? NEWTITLE := 'put_pdt_header', EJECT ??

    PROCEDURE put_pdt_header
      (    pdt_name: ost$name_reference;
           parameter_count: clt$parameter_count);

      VAR
        size: integer,
        str: string (100);


      clp$op_put_line ('');
      clp$op_put_line ('?? PUSH (LISTEXT := ON) ??');
      clp$op_put_line ('?? FMT (FORMAT := OFF) ??');
      clp$op_put_line ('');
      clp$op_put_line ('  VAR');
      clp$op_start_line ('    ');
      clp$op_add_to_line (pdt_name);
      clp$op_add_to_line (': [STATIC, READ, cls$pdt] ');
      clp$op_add_to_line ('clt$parameter_descriptor_table ');
      clp$op_add_to_line (':= [');
      IF parameter_count = 0 THEN
        clp$op_add_to_line ('NIL, NIL];');
      ELSE
        STRINGREP (str, size, '^', pdt_name, '_names');
        IF size > (osc$max_name_size + 1) THEN
          osp$set_status_abnormal ('CL', cle$name_too_long, str (1, size), status);
          EXIT generate_old_pdt;
        IFEND;
        clp$op_add_to_line (str (1, size));
        clp$op_add_to_line (', ');
        STRINGREP (str, size, '^', pdt_name, '_params');
        IF size > (osc$max_name_size + 1) THEN
          osp$set_status_abnormal ('CL', cle$name_too_long, str (1, size), status);
          EXIT generate_old_pdt;
        IFEND;
        clp$op_add_to_line (str (1, size));
        clp$op_add_to_line ('];');
      IFEND;
      clp$op_flush_line;

    PROCEND put_pdt_header;
?? TITLE := 'put_pdt_names', EJECT ??

    PROCEDURE put_pdt_names
      (    pdt_name: ost$name_reference;
       VAR parameter_names: {READ} array [1 .. * ] of clt$parameter_name_descriptor);

      VAR
        i: 1 .. clc$max_parameter_names,
        size: integer,
        str: string (100);


      clp$op_put_line ('');
      clp$op_put_line ('  VAR');
      clp$op_start_line ('    ');
      STRINGREP (str, size, pdt_name, '_names');
      clp$op_add_to_line (str (1, size));
      clp$op_add_to_line (': [STATIC, READ, ');
      clp$op_add_to_line ('cls$pdt_names_and_defaults] ');
      clp$op_add_to_line ('array [1 .. ');
      clp$op_add_integer_to_line (UPPERBOUND (parameter_names));
      clp$op_add_to_line ('] ');
      clp$op_add_to_line ('of ');
      clp$op_add_to_line ('clt$parameter_name_descriptor ');
      clp$op_add_to_line (':= ');
      clp$op_add_to_line ('[');
      FOR i := 1 TO UPPERBOUND (parameter_names) DO
        clp$op_add_to_line ('[');
        STRINGREP (str, size, '''', parameter_names [i].name
              (1, clp$trimmed_string_size (parameter_names [i].name)), '''');
        clp$op_add_to_line (str (1, size));
        clp$op_add_to_line (', ');
        clp$op_add_integer_to_line (parameter_names [i].number);
        clp$op_add_to_line (']');
        IF i = UPPERBOUND (parameter_names) THEN
          clp$op_add_to_line ('];');
        ELSE
          clp$op_add_to_line (', ');
        IFEND;
      FOREND;
      clp$op_flush_line;

    PROCEND put_pdt_names;
?? TITLE := 'put_pdt_parameters', EJECT ??

    PROCEDURE put_pdt_parameters
      (    pdt_name: ost$name_reference;
           parameter_names: array [1 .. * ] of clt$parameter_name_descriptor;
           parameters: array [1 .. * ] of clt$parameter_descriptor;
           symbolic_parameters: clt$symbolic_parameters);

      VAR
        i: 1 .. clc$max_parameters,
        ignore_status: ost$status,
        int_str: ost$string,
        size: integer,
        parameter_name_index: 1 .. clc$max_parameter_names + 1,
        scanner_name: ost$name,
        str: string (100);


      clp$op_put_line ('');
      clp$op_put_line ('  VAR');
      clp$op_start_line ('    ');
      STRINGREP (str, size, pdt_name, '_params');
      clp$op_add_to_line (str (1, size));
      clp$op_add_to_line (': [STATIC, READ, ');
      clp$op_add_to_line ('cls$pdt_parameters');
      clp$op_add_to_line ('] ');
      clp$op_add_to_line ('array [');
      clp$op_add_to_line ('1 .. ');
      clp$op_add_integer_to_line (UPPERBOUND (parameters));
      clp$op_add_to_line ('] ');
      clp$op_add_to_line ('of ');
      clp$op_add_to_line ('clt$parameter_descriptor ');
      clp$op_add_to_line (':= [');
      clp$op_flush_line;

      parameter_name_index := 1;
      FOR i := 1 TO UPPERBOUND (parameters) DO
        clp$op_put_line ('');
        clp$op_start_line ('{');
        REPEAT
          clp$op_add_to_line (' ');
          clp$op_add_to_line (parameter_names [parameter_name_index].
                name (1, clp$trimmed_string_size (parameter_names [parameter_name_index].name)));
          parameter_name_index := parameter_name_index + 1;
        UNTIL NOT ((parameter_name_index <= UPPERBOUND (parameter_names)) AND
              (parameter_names [parameter_name_index].number = i));
        clp$op_add_to_line (' }');
        clp$op_flush_line;

        clp$op_start_line ('    [[clc$');
        CASE parameters [i].required_or_optional.selector OF
        = clc$required =
          clp$op_add_to_line ('required], ');
        = clc$optional =
          clp$op_add_to_line ('optional], ');
        = clc$optional_with_default =
          clp$op_add_to_line ('optional_with_default, ^');
          clp$convert_integer_to_string (i, 10, FALSE, int_str, ignore_status);
          STRINGREP (str, size, pdt_name, '_dv', int_str.value (1, int_str.size));
          IF size > osc$max_name_size THEN
            osp$set_status_abnormal ('CL', cle$name_too_long, str (1, size), status);
            EXIT generate_old_pdt;
          IFEND;
          clp$op_add_to_line (str (1, size));
          clp$op_add_to_line ('], ');
        CASEND;

        IF symbolic_parameters [i].min_value_sets = NIL THEN
          clp$op_add_to_line ('1, ');
        ELSE
          clp$op_add_to_line (symbolic_parameters [i].min_value_sets^);
          clp$op_add_to_line (', ');
        IFEND;
        IF symbolic_parameters [i].max_value_sets = NIL THEN
          IF parameters [i].max_value_sets = clc$max_value_sets THEN
            clp$op_add_to_line ('clc$max_value_sets,');
          ELSE
            clp$op_add_to_line ('1, ');
          IFEND;
        ELSE
          clp$op_add_to_line (symbolic_parameters [i].max_value_sets^);
          clp$op_add_to_line (', ');
        IFEND;

        IF symbolic_parameters [i].min_values_per_set = NIL THEN
          clp$op_add_to_line ('1, ');
        ELSE
          clp$op_add_to_line (symbolic_parameters [i].min_values_per_set^);
          clp$op_add_to_line (', ');
        IFEND;
        IF symbolic_parameters [i].max_values_per_set = NIL THEN
          clp$op_add_to_line ('1, ');
        ELSE
          clp$op_add_to_line (symbolic_parameters [i].max_values_per_set^);
          clp$op_add_to_line (', ');
        IFEND;

        IF parameters [i].value_range_allowed = clc$value_range_not_allowed THEN
          clp$op_add_to_line ('clc$value_range_not_allowed, ');
        ELSE
          clp$op_add_to_line ('clc$value_range_allowed, ');
        IFEND;

        IF parameters [i].value_kind_specifier.keyword_values = NIL THEN
          clp$op_add_to_line ('[NIL, ');
        ELSE
          clp$op_add_to_line ('[^');
          clp$convert_integer_to_string (i, 10, FALSE, int_str, ignore_status);
          STRINGREP (str, size, pdt_name, '_kv', int_str.value (1, int_str.size));
          IF size > osc$max_name_size THEN
            osp$set_status_abnormal ('CL', cle$name_too_long, str (1, size), status);
            EXIT generate_old_pdt;
          IFEND;
          clp$op_add_to_line (str (1, size));
          clp$op_add_to_line (', ');
        IFEND;

        CASE parameters [i].value_kind_specifier.kind OF
        = clc$keyword_value =
          clp$op_add_to_line ('clc$keyword_value');
        = clc$any_value =
          clp$op_add_to_line ('clc$any_value');
        = clc$variable_reference =
          clp$op_add_to_line ('clc$variable_reference, ');
          IF parameters [i].value_kind_specifier.array_allowed = clc$array_not_allowed THEN
            clp$op_add_to_line ('clc$array_not_allowed, ');
          ELSE
            clp$op_add_to_line ('clc$array_allowed, ');
          IFEND;
          CASE parameters [i].value_kind_specifier.variable_kind OF
          = clc$string_value =
            clp$op_add_to_line ('clc$string_value');
          = clc$real_value =
            clp$op_add_to_line ('clc$real_value');
          = clc$integer_value =
            clp$op_add_to_line ('clc$integer_value');
          = clc$boolean_value =
            clp$op_add_to_line ('clc$boolean_value');
          = clc$status_value =
            clp$op_add_to_line ('clc$status_value');
          = clc$any_value =
            clp$op_add_to_line ('clc$any_value');
          CASEND;
        = clc$application_value =
          clp$op_add_to_line ('clc$application_value, ');
          STRINGREP (str, size, '''', parameters [i].value_kind_specifier.
                value_name (1, clp$trimmed_string_size (parameters [i].value_kind_specifier.value_name)),
                '''');
          clp$op_add_to_line (str (1, size));
          clp$op_add_to_line (',  [');
          IF parameters [i].value_kind_specifier.scanner.kind = clc$unlinked_av_scanner THEN
            clp$op_add_to_line ('clc$linked_av_scanner, ');
            #TRANSLATE (osv$upper_to_lower, parameters [i].value_kind_specifier.scanner.name, scanner_name);
            STRINGREP (str, size, '^', scanner_name (1, clp$trimmed_string_size (scanner_name)));
            clp$op_add_to_line (str (1, size));
          ELSE
            clp$op_add_to_line ('clc$unspecified_av_scanner');
          IFEND;
          clp$op_add_to_line (']');
        = clc$file_value =
          clp$op_add_to_line ('clc$file_value');
        = clc$name_value =
          clp$op_add_to_line ('clc$name_value, ');
          IF symbolic_parameters [i].value_kind_qualifier_low = NIL THEN
            clp$op_add_to_line ('1, ');
          ELSE
            clp$op_add_to_line (symbolic_parameters [i].value_kind_qualifier_low^);
            clp$op_add_to_line (', ');
          IFEND;
          IF symbolic_parameters [i].value_kind_qualifier_high = NIL THEN
            clp$op_add_to_line ('osc$max_name_size');
          ELSE
            clp$op_add_to_line (symbolic_parameters [i].value_kind_qualifier_high^);
          IFEND;
        = clc$string_value =
          clp$op_add_to_line ('clc$string_value, ');
          IF symbolic_parameters [i].value_kind_qualifier_low = NIL THEN
            clp$op_add_to_line ('0, ');
          ELSE
            clp$op_add_to_line (symbolic_parameters [i].value_kind_qualifier_low^);
            clp$op_add_to_line (', ');
          IFEND;
          IF symbolic_parameters [i].value_kind_qualifier_high = NIL THEN
            clp$op_add_to_line ('osc$max_string_size');
          ELSE
            clp$op_add_to_line (symbolic_parameters [i].value_kind_qualifier_high^);
          IFEND;
        = clc$integer_value =
          clp$op_add_to_line ('clc$integer_value, ');
          IF symbolic_parameters [i].value_kind_qualifier_low = NIL THEN
            clp$op_add_to_line ('clc$min_integer');
          ELSE
            clp$op_add_to_line (symbolic_parameters [i].value_kind_qualifier_low^);
          IFEND;
          clp$op_add_to_line (', ');
          IF symbolic_parameters [i].value_kind_qualifier_high = NIL THEN
            clp$op_add_to_line ('clc$max_integer');
          ELSE
            clp$op_add_to_line (symbolic_parameters [i].value_kind_qualifier_high^);
          IFEND;
        = clc$real_value =
          clp$op_add_to_line ('clc$real_value');
        = clc$boolean_value =
          clp$op_add_to_line ('clc$boolean_value');
        = clc$status_value =
          clp$op_add_to_line ('clc$status_value');
        CASEND;
        IF i = UPPERBOUND (parameters) THEN
          clp$op_add_to_line (']]];');
        ELSE
          clp$op_add_to_line (']],');
        IFEND;
        clp$op_flush_line;
      FOREND;

    PROCEND put_pdt_parameters;
?? TITLE := 'put_pdt_keyword_values', EJECT ??

    PROCEDURE put_pdt_keyword_values
      (    pdt_name: ost$name_reference;
           parameters: array [1 .. * ] of clt$parameter_descriptor);

      VAR
        i: 1 .. clc$max_parameters,
        ignore_status: ost$status,
        int_str: ost$string,
        size: integer,
        k: 1 .. clc$max_keyword_values,
        kv: ^array [1 .. * ] of ost$name,
        str: string (100);


      FOR i := 1 TO UPPERBOUND (parameters) DO
        kv := parameters [i].value_kind_specifier.keyword_values;
        IF kv <> NIL THEN
          clp$op_put_line ('');
          clp$op_put_line ('  VAR');
          clp$op_start_line ('    ');
          clp$convert_integer_to_string (i, 10, FALSE, int_str, ignore_status);
          STRINGREP (str, size, pdt_name, '_kv', int_str.value (1, int_str.size));
          IF size > osc$max_name_size THEN
            osp$set_status_abnormal ('CL', cle$name_too_long, str (1, size), status);
            EXIT generate_old_pdt;
          IFEND;
          clp$op_add_to_line (str (1, size));
          clp$op_add_to_line (': [STATIC, READ, ');
          clp$op_add_to_line ('cls$pdt_names_and_defaults');
          clp$op_add_to_line ('] ');
          clp$op_add_to_line ('array ');
          clp$op_add_to_line ('[1 .. ');
          clp$op_add_integer_to_line (UPPERBOUND (kv^));
          clp$op_add_to_line ('] of ost$name := [');
          FOR k := 1 TO UPPERBOUND (kv^) DO
            STRINGREP (str, size, '''', kv^ [k] (1, clp$trimmed_string_size (kv^ [k])), '''');
            clp$op_add_to_line (str (1, size));
            IF k = UPPERBOUND (kv^) THEN
              clp$op_add_to_line ('];');
            ELSE
              clp$op_add_to_line (',');
            IFEND;
          FOREND;
          clp$op_flush_line;
        IFEND;
      FOREND;

    PROCEND put_pdt_keyword_values;
?? TITLE := 'put_pdt_default_values', EJECT ??

    PROCEDURE put_pdt_default_values
      (    pdt_name: ost$name_reference;
           parameters: array [1 .. * ] of clt$parameter_descriptor);

      VAR
        dv: ^clt$expression_text,
        i: 1 .. clc$max_parameters,
        ignore_status: ost$status,
        int_str: ost$string,
        size: integer,
        string_index: ost$string_index,
        str: string (osc$max_string_size);


      FOR i := 1 TO UPPERBOUND (parameters) DO
        IF parameters [i].required_or_optional.selector = clc$optional_with_default THEN
          dv := parameters [i].required_or_optional.default;
          clp$op_put_line ('');
          clp$op_put_line ('  VAR');
          clp$op_start_line ('    ');
          clp$convert_integer_to_string (i, 10, FALSE, int_str, ignore_status);
          STRINGREP (str, size, pdt_name, '_dv', int_str.value (1, int_str.size));
          IF size > osc$max_name_size THEN
            osp$set_status_abnormal ('CL', cle$name_too_long, str (1, size), status);
            EXIT generate_old_pdt;
          IFEND;
          clp$op_add_to_line (str (1, size));
          clp$op_add_to_line (': [STATIC, READ, ');
          clp$op_add_to_line ('cls$pdt_names_and_defaults');
          clp$op_add_to_line ('] string (');
          clp$op_add_integer_to_line (STRLENGTH (dv^));
          clp$op_add_to_line (') := ');
          IF (clv$op.line_size + 4) > clv$op.page_width THEN
            clp$op_flush_line;
            clp$op_start_line ('      ');
          IFEND;
          clp$op_add_to_line ('''');

          FOR string_index := 1 TO STRLENGTH (dv^) DO
            IF (clv$op.line_size = clv$op.page_width - 1) OR ((dv^ (string_index) = '''') AND
                  (clv$op.line_size + 3 > clv$op.page_width)) THEN
              clp$op_add_to_line ('''');
              clp$op_flush_line;
              clp$op_start_line ('      CAT ''');
            IFEND;

            clp$op_add_to_line (dv^ (string_index));
            IF dv^ (string_index) = '''' THEN
              clp$op_add_to_line ('''');
            IFEND;
          FOREND;

          IF clv$op.line_size >= clv$op.page_width THEN
            clp$op_flush_line;
            clp$op_start_line ('      CAT ''''''');
          IFEND;

          clp$op_add_to_line ('''');
          clp$op_add_to_line (';');
          clp$op_flush_line;
        IFEND;
      FOREND;

    PROCEND put_pdt_default_values;
?? OLDTITLE, EJECT ??

    VAR
      extra_info_area: ^SEQ (REP clc$proc_pdt_info_area_size of cell),
      ignore_status: ost$status,
      message: ost$string,
      parameter_area: ^SEQ (REP clc$max_proc_pdt_parameters of clt$parameter_descriptor),
      parameter_name_area: ^SEQ (REP clc$max_proc_pdt_param_names of clt$parameter_name_descriptor),
      pdt: clt$parameter_descriptor_table,
      pdt_name: ^ost$name_reference,
      proc_name_area: ^SEQ (REP clc$max_proc_names of ost$name),
      proc_names: ^clt$proc_names,
      symbolic_parameter_area: ^SEQ (REP clc$max_proc_pdt_parameters of clt$symbolic_parameter),
      symbolic_parameters: ^clt$symbolic_parameters;


    NEXT proc_name_area IN work_area;
    NEXT parameter_name_area IN work_area;
    NEXT parameter_area IN work_area;
    NEXT symbolic_parameter_area IN work_area;
    NEXT extra_info_area IN work_area;

    clp$internal_generate_old_pdt ('PDT', ^clp$input_procedure, work_area, parse, proc_name_area^,
          parameter_name_area^, parameter_area^, symbolic_parameter_area^, extra_info_area^, proc_names, pdt,
          symbolic_parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    PUSH pdt_name: [clp$trimmed_string_size (proc_names^ [1])];
    #TRANSLATE (osv$upper_to_lower, proc_names^ [1], pdt_name^);
    IF pdt.parameters = NIL THEN
      put_pdt_header (pdt_name^, 0);
    ELSE
      put_pdt_header (pdt_name^, UPPERBOUND (pdt.parameters^));
      put_pdt_names (pdt_name^, pdt.names^);
      put_pdt_parameters (pdt_name^, pdt.names^, pdt.parameters^, symbolic_parameters^);
      put_pdt_keyword_values (pdt_name^, pdt.parameters^);
      put_pdt_default_values (pdt_name^, pdt.parameters^);
    IFEND;
    clp$op_put_line ('');
    clp$op_put_line ('?? FMT (FORMAT := ON) ??');
    clp$op_put_line ('?? POP ??');

  PROCEND generate_old_pdt;
?? TITLE := 'generate_type', EJECT ??

  PROCEDURE generate_type
    (VAR symbolic_work_area_segment {input, output} : amt$segment_pointer;
     VAR work_area {input, output} : ^clt$work_area;
     VAR parse {input, output} : clt$parse_state;
     VAR status: ost$status);

    VAR
      end_of_input: boolean,
      name: ost$name,
      type_name: clt$type_name,
      type_specification: ^clt$type_specification;


    clp$scan_non_space_lexical_unit (parse);
    WHILE parse.unit.kind = clc$lex_end_of_line DO
      clp$input_procedure (parse, end_of_input, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF end_of_input THEN
        osp$set_status_abnormal ('CL', cle$expecting_type_name, 'end of input', status);
        RETURN;
      IFEND;
      clp$scan_non_space_lexical_unit (parse);
    WHILEND;

    IF parse.unit.kind <> clc$lex_name THEN
      osp$set_status_abnormal ('CL', cle$expecting_type_name, '', status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      RETURN;
    IFEND;
    #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), type_name);
    clp$scan_non_space_lexical_unit (parse);
    WHILE parse.unit.kind = clc$lex_end_of_line DO
      clp$input_procedure (parse, end_of_input, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF end_of_input THEN
        osp$set_status_abnormal ('CL', cle$expecting_after_type_name, 'end of input', status);
        RETURN;
      IFEND;
      clp$scan_non_space_lexical_unit (parse);
    WHILEND;

    IF (parse.unit.kind <> clc$lex_colon) AND (parse.unit.kind <> clc$lex_equal) THEN
      osp$set_status_abnormal ('CL', cle$expecting_after_type_name, '', status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      RETURN;
    IFEND;

    clp$scan_non_space_lexical_unit (parse);

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, symbolic_work_area_segment, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET symbolic_work_area_segment.sequence_pointer;

    clp$internal_gen_type_spec (type_name, FALSE, ^clp$input_procedure,
          symbolic_work_area_segment.sequence_pointer, work_area, parse, type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (parse.unit.kind = clc$lex_space) OR (parse.unit.kind = clc$lex_semicolon) THEN
      clp$scan_non_space_lexical_unit (parse);
    IFEND;
    IF parse.unit.kind = clc$lex_end_of_line THEN
      clp$input_procedure (parse, end_of_input, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF NOT end_of_input THEN
        clp$scan_non_space_lexical_unit (parse);
      IFEND;
    IFEND;
    IF parse.unit.kind = clc$lex_name THEN
      #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
    ELSE
      name := '';
    IFEND;
    IF name <> 'TYPEND' THEN
      osp$set_status_abnormal ('CL', cle$expecting_typend, '', status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      RETURN;
    IFEND;

    clp$op_put_line ('');
    clp$op_put_line ('?? PUSH (LISTEXT := ON) ??');
    clp$op_put_line ('?? FMT (FORMAT := OFF) ??');
    clp$op_put_line ('');
    clp$op_put_line ('  VAR');
    current_indent := initial_indent;
    clp$op_tab_line (current_indent);
    clp$op_add_to_line ('type_specification : [STATIC, READ, cls$declaration_section] record');
    clp$op_flush_line;
    increment_indent;
    RESET type_specification;
    put_type_spec (type_specification);
    current_indent := initial_indent;
    clp$op_tab_line (current_indent);
    clp$op_add_to_line ('recend := [');
    clp$op_flush_line;
    increment_indent;
    clp$op_tab_line (current_indent);
    RESET type_specification;
    put_type_value (type_specification, symbolic_work_area_segment.sequence_pointer);
    clp$op_add_to_line ('];');
    clp$op_flush_line;
    clp$op_put_line ('');
    clp$op_put_line ('?? FMT (FORMAT := ON) ??');
    clp$op_put_line ('?? POP ??');

  PROCEND generate_type;
*IFEND
*copyc cli$input_procedures
*copyc cli$output_procedures
?? TITLE := 'decrement_indent', EJECT ??

  PROCEDURE [INLINE] decrement_indent;


    IF max_indent_exceeded_cnt = 0 THEN
      IF current_indent >= indent_increment + 1 THEN
        current_indent := current_indent - indent_increment;
      IFEND;
    ELSE
      max_indent_exceeded_cnt := max_indent_exceeded_cnt - 1;
    IFEND;

  PROCEND decrement_indent;
?? TITLE := 'increment_indent', EJECT ??

  PROCEDURE [INLINE] increment_indent;


    IF current_indent < max_indent THEN
      current_indent := current_indent + indent_increment;
    ELSE
      max_indent_exceeded_cnt := max_indent_exceeded_cnt + 1;
    IFEND;

  PROCEND increment_indent;
?? TITLE := 'put_integer', EJECT ??

  PROCEDURE [INLINE] put_integer
    (    int: integer);


    IF int = clc$min_integer THEN
      clp$op_add_to_line ('clc$min_integer');
    ELSEIF int = clc$max_integer THEN
      clp$op_add_to_line ('clc$max_integer');
    ELSE
      clp$op_add_integer_to_line (int);
    IFEND;

  PROCEND put_integer;
?? TITLE := 'put_type_spec', EJECT ??

  PROCEDURE put_type_spec
    (VAR type_specification: ^clt$type_specification);

?? NEWTITLE := 'put_application_spec', EJECT ??

    PROCEDURE put_application_spec;

      VAR
        application_qualifier: ^clt$application_type_qualifier;


      NEXT application_qualifier IN type_specification;
      clp$op_tab_line (current_indent);
      clp$op_add_to_line ('qualifier: clt$application_type_qualifier,');
      clp$op_flush_line;

    PROCEND put_application_spec;
?? TITLE := 'put_array_spec', EJECT ??

    PROCEDURE put_array_spec;

      VAR
        array_qualifier: ^clt$array_type_qualifier;


      NEXT array_qualifier IN type_specification;

      clp$op_tab_line (current_indent);
      clp$op_add_to_line ('qualifier: clt$array_type_qualifier,');
      clp$op_flush_line;

      IF array_qualifier^.element_type_specification_size > 0 THEN
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('element_type_spec: record');
        clp$op_flush_line;
        increment_indent;
        put_type_spec (type_specification);
        decrement_indent;
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('recend,');
        clp$op_flush_line;
      IFEND;

    PROCEND put_array_spec;
?? TITLE := 'put_date_time_spec', EJECT ??

    PROCEDURE put_date_time_spec;

      VAR
        date_time_qualifier: ^clt$date_time_type_qualifier;


      NEXT date_time_qualifier IN type_specification;

      clp$op_tab_line (current_indent);
      clp$op_add_to_line ('qualifier: clt$date_time_type_qualifier,');
      clp$op_flush_line;

    PROCEND put_date_time_spec;
?? TITLE := 'put_integer_spec', EJECT ??

    PROCEDURE put_integer_spec;

      VAR
        integer_qualifier: ^clt$integer_type_qualifier;


      NEXT integer_qualifier IN type_specification;

      clp$op_tab_line (current_indent);
      clp$op_add_to_line ('qualifier: clt$integer_type_qualifier,');
      clp$op_flush_line;

    PROCEND put_integer_spec;
?? TITLE := 'put_keyword_spec', EJECT ??

    PROCEDURE put_keyword_spec;

      VAR
        index: 1 .. clc$max_keywords,
        keyword_qualifier: ^clt$keyword_type_qualifier,
        keyword_array: ^array [1 .. * ] of clt$keyword_specification,
        number_of_keywords: 1 .. clc$max_keywords;


      NEXT keyword_qualifier IN type_specification;
      number_of_keywords := keyword_qualifier^.number_of_keywords;
      NEXT keyword_array: [1 .. number_of_keywords] IN type_specification;

      clp$op_tab_line (current_indent);
      clp$op_add_to_line ('qualifier: clt$keyword_type_qualifier,');
      clp$op_flush_line;
      clp$op_tab_line (current_indent);
      clp$op_add_to_line ('keyword_specs: array [1 .. ');
      clp$op_add_integer_to_line (number_of_keywords);
      clp$op_add_to_line ('] of clt$keyword_specification,');
      clp$op_flush_line;

    PROCEND put_keyword_spec;
?? TITLE := 'put_list_spec', EJECT ??

    PROCEDURE put_list_spec;

      VAR
        list_qualifier: ^clt$list_type_qualifier_v2;


      NEXT list_qualifier IN type_specification;

      clp$op_tab_line (current_indent);
      clp$op_add_to_line ('qualifier: clt$list_type_qualifier_v2,');
      clp$op_flush_line;

      IF list_qualifier^.element_type_specification_size > 0 THEN
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('element_type_spec: record');
        clp$op_flush_line;
        increment_indent;
        put_type_spec (type_specification);
        decrement_indent;
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('recend,');
        clp$op_flush_line;
      IFEND;

    PROCEND put_list_spec;
?? TITLE := 'put_name_spec', EJECT ??

    PROCEDURE put_name_spec;

      VAR
        name_qualifier: ^clt$name_type_qualifier;


      NEXT name_qualifier IN type_specification;

      clp$op_tab_line (current_indent);
      clp$op_add_to_line ('qualifier: clt$name_type_qualifier,');
      clp$op_flush_line;

    PROCEND put_name_spec;
?? TITLE := 'put_range_spec', EJECT ??

    PROCEDURE put_range_spec;

      VAR
        range_qualifier: ^clt$range_type_qualifier;


      NEXT range_qualifier IN type_specification;
      clp$op_tab_line (current_indent);
      clp$op_add_to_line ('qualifier: clt$range_type_qualifier,');
      clp$op_flush_line;

      IF range_qualifier^.element_type_specification_size > 0 THEN
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('element_type_spec: record');
        clp$op_flush_line;
        increment_indent;
        put_type_spec (type_specification);
        decrement_indent;
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('recend,');
        clp$op_flush_line;
      IFEND;

    PROCEND put_range_spec;
?? TITLE := 'put_real_spec', EJECT ??

    PROCEDURE put_real_spec;

      VAR
        real_qualifier: ^clt$real_type_qualifier;


      NEXT real_qualifier IN type_specification;

      clp$op_tab_line (current_indent);
      clp$op_add_to_line ('qualifier: clt$real_type_qualifier,');
      clp$op_flush_line;

    PROCEND put_real_spec;
?? TITLE := 'put_record_spec', EJECT ??

    PROCEDURE put_record_spec;

      VAR
        field_spec: ^clt$field_specification,
        index: clt$field_number,
        int_string: ost$string,
        record_qualifier: ^clt$record_type_qualifier,
        type_size: clt$type_specification_size;


      NEXT record_qualifier IN type_specification;
      clp$op_tab_line (current_indent);
      clp$op_add_to_line ('qualifier: clt$record_type_qualifier,');
      clp$op_flush_line;

      FOR index := 1 TO record_qualifier^.number_of_fields DO
        clp$convert_integer_to_string (index, 10, FALSE, int_string, ignore_status);
        NEXT field_spec IN type_specification;
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('field_spec_');
        clp$op_add_to_line (int_string.value (1, int_string.size));
        clp$op_add_to_line (': clt$field_specification,');
        clp$op_flush_line;
        type_size := field_spec^.type_specification_size;
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('element_type_spec_');
        clp$op_add_to_line (int_string.value (1, int_string.size));
        clp$op_add_to_line (': record');
        clp$op_flush_line;
        increment_indent;
        put_type_spec (type_specification);
        decrement_indent;
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('recend,');
        clp$op_flush_line;
      FOREND;

    PROCEND put_record_spec;
?? TITLE := 'put_string_spec', EJECT ??

    PROCEDURE put_string_spec;

      VAR
        string_qualifier: ^clt$string_type_qualifier;


      NEXT string_qualifier IN type_specification;

      clp$op_tab_line (current_indent);
      clp$op_add_to_line ('qualifier: clt$string_type_qualifier,');
      clp$op_flush_line;

    PROCEND put_string_spec;
?? TITLE := 'put_union_spec', EJECT ??

    PROCEDURE put_union_spec;

      VAR
        index: clt$union_member_number,
        int_string: ost$string,
*IF NOT $true(osv$unix)
        union_qualifier: ^clt$union_type_qualifier,
*ELSE
        union_qualifier: ^clt$union_type_qualifier_v2,
*IFEND
        number_of_members: clt$union_member_number,
        type_size: ^clt$type_specification_size;


      NEXT union_qualifier IN type_specification;
      number_of_members := union_qualifier^.number_of_members;
      clp$op_tab_line (current_indent);
*IF NOT $true(osv$unix)
      clp$op_add_to_line ('qualifier: clt$union_type_qualifier,');
*ELSE
      clp$op_add_to_line ('qualifier: clt$union_type_qualifier_v2,');
*IFEND
      clp$op_flush_line;

      FOR index := 1 TO number_of_members DO
        clp$convert_integer_to_string (index, 10, FALSE, int_string, ignore_status);
        NEXT type_size IN type_specification;
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('type_size_');
        clp$op_add_to_line (int_string.value (1, int_string.size));
        clp$op_add_to_line (': clt$type_specification_size,');
        clp$op_flush_line;
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('element_type_spec_');
        clp$op_add_to_line (int_string.value (1, int_string.size));
        clp$op_add_to_line (': record');
        clp$op_flush_line;
        increment_indent;
        put_type_spec (type_specification);
        decrement_indent;
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('recend,');
        clp$op_flush_line;
      FOREND;

    PROCEND put_union_spec;
?? OLDTITLE, EJECT ??

    VAR
      type_header: ^clt$type_specification_header,
      type_name: ^clt$type_name_reference;


    NEXT type_header IN type_specification;

    clp$op_tab_line (current_indent);
    clp$op_add_to_line ('header: clt$type_specification_header,');
    clp$op_flush_line;

    IF type_header^.name_size > 0 THEN
      NEXT type_name: [type_header^.name_size] IN type_specification;
      clp$op_tab_line (current_indent);
      clp$op_add_to_line ('name: string (');
      clp$op_add_integer_to_line (type_header^.name_size);
      clp$op_add_to_line ('),');
      clp$op_flush_line;
    IFEND;

    CASE type_header^.kind OF

    = clc$application_type =
      put_application_spec;

    = clc$array_type =
      put_array_spec;

    = clc$boolean_type =
      ;

    = clc$cobol_name_type =
      ;

    = clc$command_reference_type =
      ;

    = clc$data_name_type =
      ;

    = clc$date_time_type =
      put_date_time_spec;

    = clc$entry_point_reference_type =
      ;

*IF NOT $true(osv$unix)
    = clc$file_type =
*ELSE
    = {clc$file_type} clc$nos_ve_file_type, clc$unix_file_type =
*IFEND
      ;

    = clc$integer_type =
      put_integer_spec;

    = clc$keyword_type =
      put_keyword_spec;

    = clc$list_type =
      put_list_spec;

    = clc$lock_type =
      ;

    = clc$name_type =
      put_name_spec;

    = clc$network_title_type =
      ;

    = clc$program_name_type =
      ;

    = clc$range_type =
      put_range_spec;

    = clc$real_type =
      put_real_spec;

    = clc$record_type =
      put_record_spec;

    = clc$scu_line_identifier_type =
      ;

    = clc$statistic_code_type =
      ;

    = clc$status_type =
      ;

    = clc$status_code_type =
      ;

    = clc$string_type =
      put_string_spec;

    = clc$string_pattern_type =
      ;

    = clc$time_increment_type =
      ;

    = clc$time_zone_type =
      ;

    = clc$type_specification_type =
      ;

    = clc$union_type =
      put_union_spec;

    ELSE
      ;
    CASEND;

  PROCEND put_type_spec;
?? TITLE := 'put_type_value', EJECT ??

  PROCEDURE put_type_value
    (VAR type_specification: ^clt$type_specification;
     VAR symbolic_work_area: ^clt$work_area);

?? NEWTITLE := 'put_application_value', EJECT ??

    PROCEDURE put_application_value;

      VAR
        application_qualifier: ^clt$application_type_qualifier;


      NEXT application_qualifier IN type_specification;
      IF application_qualifier^.balance_brackets THEN
        clp$op_add_to_line (', [TRUE]');
      ELSE
        clp$op_add_to_line (', [FALSE]');
      IFEND;

    PROCEND put_application_value;
?? TITLE := 'put_array_value', EJECT ??

    PROCEDURE put_array_value;

      VAR
        array_qualifier: ^clt$array_type_qualifier,
        lowerbound_text: ^clt$expression_text,
        symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier,
        upperbound_text: ^clt$expression_text;


      NEXT array_qualifier IN type_specification;
      NEXT symbolic_subrange_qualifier IN symbolic_work_area;
      NEXT lowerbound_text: [symbolic_subrange_qualifier^.low_text_size] IN symbolic_work_area;
      IF symbolic_subrange_qualifier^.high_text_size = 0 THEN
        upperbound_text := lowerbound_text;
      ELSE
        NEXT upperbound_text: [symbolic_subrange_qualifier^.high_text_size] IN symbolic_work_area;
      IFEND;

      clp$op_add_to_line (', [');
      clp$op_add_integer_to_line (array_qualifier^.element_type_specification_size);
      clp$op_add_to_line (', ');
      IF array_qualifier^.array_bounds_defined THEN
        clp$op_add_to_line ('TRUE, [');
        IF STRLENGTH (lowerbound_text^) > 0 THEN
          clp$op_add_to_line (lowerbound_text^);
        ELSEIF array_qualifier^.bounds.lower = clc$min_array_bound THEN
          clp$op_add_to_line ('clc$min_array_bound');
        ELSEIF array_qualifier^.bounds.lower = clc$max_array_bound THEN
          clp$op_add_to_line ('clc$max_array_bound');
        ELSE
          clp$op_add_integer_to_line (array_qualifier^.bounds.lower);
        IFEND;
        clp$op_add_to_line (', ');
        IF STRLENGTH (upperbound_text^) > 0 THEN
          clp$op_add_to_line (upperbound_text^);
        ELSEIF array_qualifier^.bounds.upper = clc$min_array_bound THEN
          clp$op_add_to_line ('clc$min_array_bound');
        ELSEIF array_qualifier^.bounds.upper = clc$max_array_bound THEN
          clp$op_add_to_line ('clc$max_array_bound');
        ELSE
          clp$op_add_integer_to_line (array_qualifier^.bounds.upper);
        IFEND;
        clp$op_add_to_line (']');
      ELSE
        clp$op_add_to_line ('FALSE');
      IFEND;
      clp$op_add_to_line (']');

      IF array_qualifier^.element_type_specification_size > 0 THEN
        clp$op_add_to_line (',');
        clp$op_flush_line;
        increment_indent;
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('[');
        put_type_value (type_specification, symbolic_work_area);
        clp$op_add_to_line (']');
        clp$op_flush_line;
        decrement_indent;
        clp$op_tab_line (current_indent);
      IFEND;

    PROCEND put_array_value;
?? TITLE := 'put_clt$longreal', EJECT ??

    PROCEDURE put_clt$longreal
      (    clt_longreal: clt$longreal);

      VAR
*IF $true(osv$unix)
        line: string (osc$max_string_size),
        size: integer,
*IFEND
        str: ost$string;


      clp$convert_real_to_string (clt_longreal.long_real, clc$max_real_number_digits, str, ignore_status);
      clp$op_tab_line (current_indent);
      clp$op_add_to_line ('[{');
      clp$op_add_to_line (str.value (1, str.size));
*IF NOT $true(osv$unix)
      clp$op_add_to_line ('} 3, [[');
      clp$convert_integer_to_string (clt_longreal.breakdown.first.exponent, 16, TRUE, str, ignore_status);
      clp$op_add_to_line (str.value (1, str.size));
      clp$op_add_to_line (', ');
      clp$convert_integer_to_string (clt_longreal.breakdown.first.mantissa, 16, TRUE, str, ignore_status);
      clp$op_add_to_line (str.value (1, str.size));
      clp$op_add_to_line ('], [');
      clp$convert_integer_to_string (clt_longreal.breakdown.second.exponent, 16, TRUE, str, ignore_status);
      clp$op_add_to_line (str.value (1, str.size));
      clp$op_add_to_line (', ');
      clp$convert_integer_to_string (clt_longreal.breakdown.second.mantissa, 16, TRUE, str, ignore_status);
      clp$op_add_to_line (str.value (1, str.size));
      clp$op_add_to_line (']]]');
*ELSE
      clp$op_add_to_line ('} 3, [');
      STRINGREP (line, size, $CHAR ($INTEGER ('0') + clt_longreal.breakdown.sign));
{     clp$op_add_to_line ($CHAR ($INTEGER ('0') + clt_longreal.breakdown.sign));
      clp$op_add_to_line (line (1, size));
      clp$op_add_to_line (', ');
      clp$convert_integer_to_string (clt_longreal.breakdown.exponent, 16, TRUE, str, ignore_status);
      clp$op_add_to_line (str.value (1, str.size));
      clp$op_add_to_line (', ');
      clp$convert_integer_to_string (clt_longreal.breakdown.fraction_1, 16, TRUE, str, ignore_status);
      clp$op_add_to_line (str.value (1, str.size));
      clp$op_add_to_line (', ');
      clp$convert_integer_to_string (clt_longreal.breakdown.fraction_2, 16, TRUE, str, ignore_status);
      clp$op_add_to_line (str.value (1, str.size));
      clp$op_add_to_line (']]');
*IFEND

    PROCEND put_clt$longreal;
?? TITLE := 'put_date_time_value', EJECT ??

    PROCEDURE put_date_time_value;

      VAR
        date_time_qualifier: ^clt$date_time_type_qualifier,
        id_specified: boolean;


      NEXT date_time_qualifier IN type_specification;
      clp$op_add_to_line (', [$clt$date_and_or_time [');
      id_specified := FALSE;

      IF clc$date IN date_time_qualifier^.date_and_or_time THEN
        clp$op_add_to_line ('clc$date');
        id_specified := TRUE;
      IFEND;
      IF clc$time IN date_time_qualifier^.date_and_or_time THEN
        IF id_specified THEN
          clp$op_add_to_line (', ');
        IFEND;
        clp$op_add_to_line ('clc$time');
      IFEND;

      clp$op_add_to_line ('], $clt$date_time_tenses [');

      id_specified := FALSE;
      IF clc$past IN date_time_qualifier^.tenses THEN
        clp$op_add_to_line ('clc$past');
        id_specified := TRUE;
      IFEND;
      IF clc$present IN date_time_qualifier^.tenses THEN
        IF id_specified THEN
          clp$op_add_to_line (', ');
        IFEND;
        id_specified := TRUE;
        clp$op_add_to_line ('clc$present');
      IFEND;
      IF clc$future IN date_time_qualifier^.tenses THEN
        IF id_specified THEN
          clp$op_add_to_line (', ');
        IFEND;
        clp$op_add_to_line ('clc$future');
      IFEND;
      clp$op_add_to_line (']]');

    PROCEND put_date_time_value;
?? TITLE := 'put_integer_value', EJECT ??

    PROCEDURE put_integer_value;

      VAR
        integer_qualifier: ^clt$integer_type_qualifier,
        max_integer_text: ^clt$expression_text,
        min_integer_text: ^clt$expression_text,
        symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier;


      NEXT integer_qualifier IN type_specification;
      NEXT symbolic_subrange_qualifier IN symbolic_work_area;
      NEXT min_integer_text: [symbolic_subrange_qualifier^.low_text_size] IN symbolic_work_area;
      IF symbolic_subrange_qualifier^.high_text_size = 0 THEN
        max_integer_text := min_integer_text;
      ELSE
        NEXT max_integer_text: [symbolic_subrange_qualifier^.high_text_size] IN symbolic_work_area;
      IFEND;

      clp$op_add_to_line (', [');
      IF STRLENGTH (min_integer_text^) > 0 THEN
        clp$op_add_to_line (min_integer_text^);
      ELSE
        put_integer (integer_qualifier^.min_integer_value);
      IFEND;
      clp$op_add_to_line (', ');
      IF STRLENGTH (max_integer_text^) > 0 THEN
        clp$op_add_to_line (max_integer_text^);
      ELSE
        put_integer (integer_qualifier^.max_integer_value);
      IFEND;
      clp$op_add_to_line (', ');
      clp$op_add_integer_to_line (integer_qualifier^.default_radix);
      clp$op_add_to_line (']');

    PROCEND put_integer_value;
?? TITLE := 'put_keyword_value', EJECT ??

    PROCEDURE put_keyword_value;

      VAR
        index: 1 .. clc$max_keywords,
        keyword_qualifier: ^clt$keyword_type_qualifier,
        keyword_array: ^array [1 .. * ] of clt$keyword_specification,
        name: ost$name,
        name_size: ost$name_size,
        number_of_keywords: 1 .. clc$max_keywords;


      NEXT keyword_qualifier IN type_specification;
      number_of_keywords := keyword_qualifier^.number_of_keywords;
      clp$op_add_to_line (', [');
      clp$op_add_integer_to_line (number_of_keywords);
      clp$op_add_to_line ('], [');
      clp$op_flush_line;
      clp$op_tab_line (current_indent);

      NEXT keyword_array: [1 .. number_of_keywords] IN type_specification;

      FOR index := 1 TO number_of_keywords DO
        clp$op_add_to_line ('[');
        name := keyword_array^ [index].keyword;
        clp$op_add_to_line ('''');
        clp$op_add_to_line (name);
        clp$op_add_to_line ('''');
        CASE keyword_array^ [index].class OF
        = clc$nominal_entry =
          clp$op_add_to_line (', clc$nominal_entry, ');

        = clc$alias_entry =
          clp$op_add_to_line (', clc$alias_entry, ');

        = clc$abbreviation_entry =
          clp$op_add_to_line (', clc$abbreviation_entry, ');

        CASEND;
        CASE keyword_array^ [index].availability OF
        = clc$normal_usage_entry =
          clp$op_add_to_line ('clc$normal_usage_entry, ');
        = clc$advanced_usage_entry =
          clp$op_add_to_line ('clc$advanced_usage_entry, ');
        = clc$hidden_entry =
          clp$op_add_to_line ('clc$hidden_entry, ');
        CASEND;
        clp$op_add_integer_to_line (keyword_array^ [index].ordinal);
        IF index < number_of_keywords THEN
          clp$op_add_to_line ('],');
          clp$op_flush_line;
          clp$op_tab_line (current_indent);
        ELSE
          clp$op_add_to_line (']]');
        IFEND;

      FOREND;
      clp$op_flush_line;
      clp$op_tab_line (current_indent);

    PROCEND put_keyword_value;
?? TITLE := 'put_list_value', EJECT ??

    PROCEDURE put_list_value;

      VAR
        list_qualifier: ^clt$list_type_qualifier_v2,
        max_list_text: ^clt$expression_text,
        min_list_text: ^clt$expression_text,
        symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier;


      NEXT list_qualifier IN type_specification;
      NEXT symbolic_subrange_qualifier IN symbolic_work_area;
      NEXT min_list_text: [symbolic_subrange_qualifier^.low_text_size] IN symbolic_work_area;
      IF symbolic_subrange_qualifier^.high_text_size = 0 THEN
        max_list_text := min_list_text;
      ELSE
        NEXT max_list_text: [symbolic_subrange_qualifier^.high_text_size] IN symbolic_work_area;
      IFEND;

      clp$op_add_to_line (', [');
      clp$op_add_integer_to_line (list_qualifier^.element_type_specification_size);
      clp$op_add_to_line (', ');
      IF STRLENGTH (min_list_text^) > 0 THEN
        clp$op_add_to_line (min_list_text^);
      ELSEIF list_qualifier^.min_list_size = clc$max_list_size THEN
        clp$op_add_to_line ('clc$max_list_size');
      ELSE
        clp$op_add_integer_to_line (list_qualifier^.min_list_size);
      IFEND;
      clp$op_add_to_line (', ');
      IF STRLENGTH (max_list_text^) > 0 THEN
        IF (STRLENGTH (max_list_text^) = 9) AND (max_list_text^ (1, 9) = '$max_list') THEN
          clp$op_add_to_line ('clc$max_list_size');
        ELSE
          clp$op_add_to_line (max_list_text^);
        IFEND;
      ELSEIF list_qualifier^.max_list_size = clc$max_list_size THEN
        clp$op_add_to_line ('clc$max_list_size');
      ELSE
        clp$op_add_integer_to_line (list_qualifier^.max_list_size);
      IFEND;
      clp$op_add_to_line (', ');
      clp$op_add_integer_to_line (list_qualifier^.reserved);
      IF list_qualifier^.defer_expansion THEN
        clp$op_add_to_line (', TRUE');
      ELSE
        clp$op_add_to_line (', FALSE');
      IFEND;
      IF list_qualifier^.list_rest THEN
        clp$op_add_to_line (', TRUE');
      ELSE
        clp$op_add_to_line (', FALSE');
      IFEND;

      clp$op_add_to_line (']');
      IF list_qualifier^.element_type_specification_size > 0 THEN
        clp$op_add_to_line (',');
        clp$op_flush_line;
        increment_indent;
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('[');
        put_type_value (type_specification, symbolic_work_area);
        clp$op_add_to_line (']');
        clp$op_flush_line;
        decrement_indent;
        clp$op_tab_line (current_indent);
      IFEND;

    PROCEND put_list_value;
?? TITLE := 'put_name_value', EJECT ??

    PROCEDURE put_name_value;

      VAR
        name_qualifier: ^clt$name_type_qualifier,
        max_name_text: ^clt$expression_text,
        min_name_text: ^clt$expression_text,
        symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier;


      NEXT name_qualifier IN type_specification;
      NEXT symbolic_subrange_qualifier IN symbolic_work_area;
      NEXT min_name_text: [symbolic_subrange_qualifier^.low_text_size] IN symbolic_work_area;
      IF symbolic_subrange_qualifier^.high_text_size = 0 THEN
        max_name_text := min_name_text;
      ELSE
        NEXT max_name_text: [symbolic_subrange_qualifier^.high_text_size] IN symbolic_work_area;
      IFEND;

      clp$op_add_to_line (', [');
      IF STRLENGTH (min_name_text^) > 0 THEN
        clp$op_add_to_line (min_name_text^);
      ELSEIF name_qualifier^.min_name_size = osc$max_name_size THEN
        clp$op_add_to_line ('osc$max_name_size');
      ELSE
        clp$op_add_integer_to_line (name_qualifier^.min_name_size);
      IFEND;
      clp$op_add_to_line (', ');
      IF STRLENGTH (max_name_text^) > 0 THEN
        clp$op_add_to_line (max_name_text^);
      ELSEIF name_qualifier^.max_name_size = osc$max_name_size THEN
        clp$op_add_to_line ('osc$max_name_size');
      ELSE
        clp$op_add_integer_to_line (name_qualifier^.max_name_size);
      IFEND;
      clp$op_add_to_line (']');

    PROCEND put_name_value;
?? TITLE := 'put_range_value', EJECT ??

    PROCEDURE put_range_value;

      VAR
        range_qualifier: ^clt$range_type_qualifier;


      NEXT range_qualifier IN type_specification;
      clp$op_add_to_line (', [');
      clp$op_add_integer_to_line (range_qualifier^.element_type_specification_size);
      clp$op_add_to_line (']');
      IF range_qualifier^.element_type_specification_size > 0 THEN
        clp$op_add_to_line (',');
        clp$op_flush_line;
        increment_indent;
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('[');
        put_type_value (type_specification, symbolic_work_area);
        clp$op_add_to_line (']');
        clp$op_flush_line;
        decrement_indent;
        clp$op_tab_line (current_indent);
      IFEND;

    PROCEND put_range_value;
?? TITLE := 'put_real_value', EJECT ??

    PROCEDURE put_real_value;

      VAR
        real_qualifier: ^clt$real_type_qualifier;


      NEXT real_qualifier IN type_specification;
      clp$op_add_to_line (',');
      clp$op_flush_line;
      clp$op_tab_line (current_indent);
      clp$op_add_to_line ('[');
      put_clt$longreal (real_qualifier^.min_real_value);
      clp$op_add_to_line (',');
      clp$op_flush_line;
      clp$op_tab_line (current_indent);
      put_clt$longreal (real_qualifier^.max_real_value);
      clp$op_add_to_line (']');
      clp$op_flush_line;
      clp$op_tab_line (current_indent);

    PROCEND put_real_value;
?? TITLE := 'put_record_value', EJECT ??

    PROCEDURE put_record_value;

      VAR
        field_spec: ^clt$field_specification,
        index: clt$field_number,
        record_qualifier: ^clt$record_type_qualifier;


      NEXT record_qualifier IN type_specification;
      clp$op_add_to_line (', [');
      clp$op_add_integer_to_line (record_qualifier^.number_of_fields);
      clp$op_add_to_line ('],');
      clp$op_flush_line;

      FOR index := 1 TO record_qualifier^.number_of_fields DO
        NEXT field_spec IN type_specification;
        clp$op_tab_line (current_indent);
        clp$op_add_to_line ('[''');
        clp$op_add_to_line (field_spec^.name);

        IF field_spec^.requirement = clc$required_field THEN
          clp$op_add_to_line (''', clc$required_field, ');
        ELSE
          clp$op_add_to_line (''', clc$optional_field, ');
        IFEND;

        clp$op_add_integer_to_line (field_spec^.type_specification_size);
        clp$op_add_to_line ('], [');

        increment_indent;
        put_type_value (type_specification, symbolic_work_area);
        decrement_indent;
        IF index < record_qualifier^.number_of_fields THEN
          clp$op_add_to_line ('],');
        ELSE
          clp$op_add_to_line (']');
        IFEND;
        clp$op_flush_line;
        clp$op_tab_line (current_indent);
      FOREND;

    PROCEND put_record_value;
?? TITLE := 'put_string_value', EJECT ??

    PROCEDURE put_string_value;

      VAR
        string_qualifier: ^clt$string_type_qualifier,
        max_string_text: ^clt$expression_text,
        min_string_text: ^clt$expression_text,
        symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier;


      NEXT string_qualifier IN type_specification;
      NEXT symbolic_subrange_qualifier IN symbolic_work_area;
      NEXT min_string_text: [symbolic_subrange_qualifier^.low_text_size] IN symbolic_work_area;
      IF symbolic_subrange_qualifier^.high_text_size = 0 THEN
        max_string_text := min_string_text;
      ELSE
        NEXT max_string_text: [symbolic_subrange_qualifier^.high_text_size] IN symbolic_work_area;
      IFEND;

      clp$op_add_to_line (', [');
      IF STRLENGTH (min_string_text^) > 0 THEN
        clp$op_add_to_line (min_string_text^);
      ELSEIF string_qualifier^.min_string_size = clc$max_string_size THEN
        clp$op_add_to_line ('clc$max_string_size');
      ELSE
        clp$op_add_integer_to_line (string_qualifier^.min_string_size);
      IFEND;
      clp$op_add_to_line (', ');
      IF STRLENGTH (max_string_text^) > 0 THEN
        clp$op_add_to_line (max_string_text^);
      ELSEIF string_qualifier^.max_string_size = clc$max_string_size THEN
        clp$op_add_to_line ('clc$max_string_size');
      ELSE
        clp$op_add_integer_to_line (string_qualifier^.max_string_size);
      IFEND;
      IF string_qualifier^.literal THEN
        clp$op_add_to_line (', TRUE]');
      ELSE
        clp$op_add_to_line (', FALSE]');
      IFEND;

    PROCEND put_string_value;
?? TITLE := 'put_type_kind', EJECT ??

    PROCEDURE [INLINE] put_type_kind
      (    type_kind: clt$type_kind);


*IF NOT $true(osv$unix)
      clp$op_add_to_line (type_kind_names [type_kind] (1, clp$trimmed_string_size
            (type_kind_names [type_kind])));
*ELSE
      VAR
        type_kind_name: ^clt$type_name;


      IF type_kind = clc$file_type THEN
        type_kind_name := ^file_type_kind_name;
      ELSE
        type_kind_name := ^type_kind_names [type_kind];
      IFEND;
      clp$op_add_to_line (type_kind_name^ (1, clp$trimmed_string_size (type_kind_name^)));
*IFEND

    PROCEND put_type_kind;
?? TITLE := 'put_union_value', EJECT ??

    PROCEDURE put_union_value;

      VAR
        i: clt$union_member_number,
*IF NOT $true(osv$unix)
        kinds: clt$type_kinds,
*ELSE
        kinds: clt$type_kinds_v2,
*IFEND
        t: clt$type_kind,
        type_size: ^clt$type_specification_size,
*IF NOT $true(osv$unix)
        union_qualifier: ^clt$union_type_qualifier;
*ELSE
        union_qualifier: ^clt$union_type_qualifier_v2,
        union_qualifier_v1: ^clt$union_type_qualifier;
*IFEND


      NEXT union_qualifier IN type_specification;
      clp$op_add_to_line (', [');
      IF union_qualifier^.number_of_members = 0 THEN
*IF NOT $true(osv$unix)
        clp$op_add_to_line ('-$clt$type_kinds [],');
*ELSE
        clp$op_add_to_line ('-$clt$type_kinds_v2 [],');
*IFEND
      ELSE
        clp$op_add_to_line ('[');
*IF NOT $true(osv$unix)
        kinds := union_qualifier^.kinds;
*ELSE
        IF type_header^.version = 1 THEN
          union_qualifier_v1 := #LOC (union_qualifier^);
          clp$type_kinds_v2 (union_qualifier_v1^.kinds, kinds);
        ELSE
          kinds := union_qualifier^.kinds;
        IFEND;
*IFEND

      /put_kinds/
        FOR t := LOWERVALUE (clt$type_kind) TO UPPERVALUE (clt$type_kind) DO
          IF t IN kinds THEN
            IF (clv$op.line_size + osc$max_name_size + 2) > clv$op.page_width THEN
              clp$op_flush_line;
              clp$op_tab_line (current_indent);
            IFEND;
            put_type_kind (t);
*IF NOT $true(osv$unix)
            kinds := kinds - $clt$type_kinds [t];
            IF kinds = $clt$type_kinds [] THEN
*ELSE
            kinds := kinds - $clt$type_kinds_v2 [t];
            IF kinds = $clt$type_kinds_v2 [] THEN
*IFEND
              clp$op_add_to_line ('],');
              EXIT /put_kinds/;
            IFEND;
            clp$op_add_to_line (', ');
          IFEND;
        FOREND /put_kinds/;
      IFEND;

      clp$op_flush_line;
      clp$op_tab_line (current_indent);
      IF union_qualifier^.only_standard_types_in_union THEN
        clp$op_add_to_line ('TRUE, ');
      ELSE
        clp$op_add_to_line ('FALSE, ');
      IFEND;
      clp$op_add_integer_to_line (union_qualifier^.number_of_members);
      clp$op_add_to_line (']');

      IF union_qualifier^.number_of_members > 0 THEN
        clp$op_add_to_line (',');
        clp$op_flush_line;
        FOR i := 1 TO union_qualifier^.number_of_members DO
          NEXT type_size IN type_specification;
          clp$op_tab_line (current_indent);
          clp$op_add_integer_to_line (type_size^);
          clp$op_add_to_line (', [');
          increment_indent;
          put_type_value (type_specification, symbolic_work_area);
          decrement_indent;
          IF i < union_qualifier^.number_of_members THEN
            clp$op_add_to_line ('],');
          ELSE
            clp$op_add_to_line (']');
          IFEND;
          clp$op_flush_line;
          clp$op_tab_line (current_indent);
        FOREND;
      IFEND;

    PROCEND put_union_value;
?? OLDTITLE, EJECT ??

    VAR
      type_header: ^clt$type_specification_header,
      type_name: ^clt$type_name_reference;


    NEXT type_header IN type_specification;

    clp$op_add_to_line ('[');
*IF NOT $true(osv$unix)
    clp$op_add_integer_to_line (type_header^.version);
*ELSE
    clp$op_add_integer_to_line (clc$declaration_version);
*IFEND
    clp$op_add_to_line (', ');
    clp$op_add_integer_to_line (type_header^.name_size);
    clp$op_add_to_line (', ');
    put_type_kind (type_header^.kind);
    clp$op_add_to_line (']');

    IF type_header^.name_size > 0 THEN
      NEXT type_name: [type_header^.name_size] IN type_specification;
      clp$op_add_to_line (', ''');
      clp$op_add_to_line (type_name^);
      clp$op_add_to_line ('''');
    IFEND;

    CASE type_header^.kind OF
    = clc$application_type =
      put_application_value;

    = clc$array_type =
      put_array_value;

    = clc$boolean_type =
      ;

    = clc$cobol_name_type =
      ;

    = clc$command_reference_type =
      ;

    = clc$data_name_type =
      ;

    = clc$date_time_type =
      put_date_time_value;

    = clc$entry_point_reference_type =
      ;

*IF NOT $true(osv$unix)
    = clc$file_type =
*ELSE
    = {clc$file_type} clc$nos_ve_file_type, clc$unix_file_type =
*IFEND
      ;

    = clc$integer_type =
      put_integer_value;

    = clc$keyword_type =
      put_keyword_value;

    = clc$list_type =
      put_list_value;

    = clc$lock_type =
      ;

    = clc$name_type =
      put_name_value;

    = clc$network_title_type =
      ;

    = clc$program_name_type =
      ;

    = clc$range_type =
      put_range_value;

    = clc$real_type =
      put_real_value;

    = clc$record_type =
      put_record_value;

    = clc$scu_line_identifier_type =
      ;

    = clc$statistic_code_type =
      ;

    = clc$status_type =
      ;

    = clc$status_code_type =
      ;

    = clc$string_type =
      put_string_value;

    = clc$string_pattern_type =
      ;

    = clc$time_increment_type =
      ;

    = clc$time_zone_type =
      ;

    = clc$type_specification_type =
      ;

    = clc$union_type =
      put_union_value;

    ELSE
      clp$op_add_to_line (' UNKNOWN SPECIFICATION TYPE');
    CASEND;

  PROCEND put_type_value;

MODEND clm$generate_pdt;
*DECK DECK=CLM$GENERATE_PDT_AND_TYPE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Parameter Description Table and TYPE generator' ??
MODULE clm$generate_pdt_and_type;

{
{ PURPOSE:
{   This module contains the Parameter Description Table generator for an SCL
{   command (procedure) or function, and the generator for a TYPE specification.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$declaration_version
*copyc clc$max_integer
*copyc clc$max_proc_names
*copyc clc$min_integer
*copyc cle$ecc_lexical
*copyc cle$ecc_parsing
*copyc cle$eoi_in_declaration
*copyc cle$unable_to_call_input_proc
*copyc cle$work_area_overflow
*copyc clk$procedure_keypoints
*copyc clt$command_log_option
*copyc clt$command_line
*copyc clt$command_line_size
*copyc clt$command_line_index
*copyc clt$command_or_function
*copyc clt$command_or_function_scope
*copyc clt$input_procedure
*copyc clt$internal_input_procedure
*copyc clt$parameter_description_table
*copyc clt$symbolic_subrange_qualifier
*copyc clt$type_name
*copyc clt$type_specification
*copyc clt$variable_name_reference
*copyc clt$work_area
*IF NOT $true(osv$unix)
*copyc oss$job_paged_literal
*IFEND
?? POP ??
*copyc clp$append_status_parse_state
*copyc clp$evaluate_integer_expression
*IF NOT $true(osv$unix)
*copyc clp$evaluate_name
*copyc clp$evaluate_real_expression
*IFEND
*copyc clp$get_work_area
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*IF NOT $true(osv$unix)
*copyc clp$longreal_compare_gt
*copyc clp$longreal_compare_le
*copyc clp$longreal_compare_lt
*IFEND
*copyc clp$scan_any_lexical_unit
*copyc clp$scan_non_space_lexical_unit
*copyc clp$scan_unnested_rel_lex_unit
*copyc clp$scan_unnested_sep_lex_unit
*copyc clp$trimmed_string_size
*copyc clv$negative_infinity
*copyc clv$positive_infinity
*copyc clv$type_kind_names
*copyc i#current_sequence_position
*copyc osp$append_status_parameter
*IF NOT $true(osv$unix)
*copyc osp$establish_condition_handler
*copyc osp$disestablish_cond_handler
*IFEND
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc pmp$get_compact_date_time
*IF NOT $true(osv$unix)
*copyc pmp$continue_to_cause
*IFEND
?? EJECT ??

  TYPE
    clt$declaration_identifier = string (9) {'procedure', 'function', 'type'} ;

  TYPE
    clt$declaration_context = record
      kind: (clc$procedure_declaration, clc$function_declaration, clc$type_declaration),
      identifier: clt$declaration_identifier,
      unspecified_type_allowed: boolean,
      list_rest_allowed: boolean,
      list_rest_encountered: boolean,
    recend;

?? TITLE := 'clp$generate_pdt', EJECT ??
*copyc clh$generate_pdt

  PROCEDURE [XDCL, #GATE] clp$generate_pdt
    (    command_or_function: clt$command_or_function;
         first_line: ^clt$command_line;
         first_line_index: clt$command_line_index;
         get_line: clt$input_procedure;
     VAR work_area {input, output} : ^clt$work_area;
     VAR last_line: ^clt$command_line;
     VAR last_line_index: clt$command_line_index;
     VAR command_or_function_name: pmt$program_name;
     VAR aliases: ^array [1 .. * ] of pmt$program_name;
     VAR availability: clt$named_entry_availability;
     VAR command_or_function_scope: clt$command_or_function_scope;
     VAR command_log_option: clt$command_log_option;
     VAR parameter_description_table: ^clt$parameter_description_table;
     VAR status: ost$status);

    VAR
      declaration_identifier: clt$declaration_identifier,
      get_line_called: boolean,
      lexical_units: ^clt$lexical_units,
      lexical_work_area: ^^clt$work_area,
      local_status: ost$status,
      parse: clt$parse_state;

?? NEWTITLE := 'get_pdt_line', EJECT ??

    PROCEDURE get_pdt_line
      (VAR parse: clt$parse_state;
       VAR end_of_input: boolean;
       VAR status: ost$status);

*IF NOT $true(osv$unix)
      VAR
        callers_save_area: ^ost$stack_frame_save_area;

?? NEWTITLE := 'bad_input_proc_pointer_handler', EJECT ??

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


        IF (condition.selector = pmc$system_conditions) AND
              (($pmt$system_conditions [pmc$instruction_specification, pmc$address_specification,
              pmc$access_violation, pmc$environment_specification, pmc$invalid_segment_ring_0,
              pmc$out_call_in_return] * condition.system_conditions) <> $pmt$system_conditions []) THEN
          IF save_area^.minimum_save_area.a2_previous_save_area = callers_save_area THEN
            osp$set_status_abnormal ('CL', cle$unable_to_call_input_proc, 'clp$generate_pdt', status);
            EXIT get_pdt_line;
          IFEND;
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        handler_status.normal := TRUE;

      PROCEND bad_input_proc_pointer_handler;
?? OLDTITLE, EJECT ??
*IFEND

      VAR
        line: ^clt$command_line;


      end_of_input := FALSE;

      IF get_line = NIL THEN
        end_of_input := TRUE;
        osp$set_status_abnormal ('CL', cle$eoi_in_declaration, declaration_identifier, status);
        RETURN;
      IFEND;

      REPEAT
        REPEAT

*IF NOT $true(osv$unix)
          IF NOT get_line_called THEN
            callers_save_area := #PREVIOUS_SAVE_AREA ();
            osp$establish_condition_handler (^bad_input_proc_pointer_handler, FALSE);
          IFEND;
*IFEND
          get_line^ (line, status);
          IF NOT get_line_called THEN
*IF NOT $true(osv$unix)
            osp$disestablish_cond_handler;
*IFEND
            get_line_called := TRUE;
          IFEND;

          IF NOT status.normal THEN
            RETURN;
          ELSEIF line = NIL THEN
            end_of_input := TRUE;
            osp$set_status_abnormal ('CL', cle$eoi_in_declaration, declaration_identifier, status);
            RETURN;
          IFEND;
        UNTIL STRLENGTH (line^) > 0;

        RESET lexical_work_area^ TO lexical_units;
        clp$identify_lexical_units (line, lexical_work_area^, lexical_units, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$initialize_parse_state (line, lexical_units, parse);
      UNTIL parse.unit.kind <> clc$lex_end_of_line;

    PROCEND get_pdt_line;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    local_status.normal := TRUE;
    get_line_called := FALSE;
    IF command_or_function = clc$command THEN
      declaration_identifier := 'procedure';
    ELSE
      declaration_identifier := 'function';
    IFEND;

  /generate_pdt/
    BEGIN
*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^parse), lexical_work_area, local_status);
*ELSE
      clp$get_work_area (osc$user_ring, lexical_work_area, local_status);
*IFEND
      IF NOT local_status.normal THEN
        EXIT /generate_pdt/;
      IFEND;

      clp$identify_lexical_units (first_line, lexical_work_area^, lexical_units, local_status);
      IF NOT local_status.normal THEN
        EXIT /generate_pdt/;
      IFEND;

      clp$initialize_parse_state (first_line, lexical_units, parse);
      REPEAT
        clp$scan_any_lexical_unit (parse);
      UNTIL (parse.unit_index >= first_line_index) OR (parse.unit_index >= parse.index_limit);

      clp$internal_generate_pdt (command_or_function, ^get_pdt_line, NIL, work_area, parse,
            command_or_function_name, aliases, availability, command_or_function_scope, command_log_option,
            parameter_description_table, local_status);

      RESET lexical_work_area^ TO lexical_units;

      last_line := parse.text;
      last_line_index := parse.unit_index;
    END /generate_pdt/;

    IF NOT local_status.normal THEN
      IF local_status.condition = cle$work_area_overflow THEN
        local_status.text.size := 0;
        osp$append_status_parameter (osc$status_parameter_delimiter, 'clp$generate_pdt', local_status);
      IFEND;
      status := local_status;
    IFEND;

  PROCEND clp$generate_pdt;
?? TITLE := 'clp$internal_generate_pdt', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$internal_generate_pdt
    (    command_or_function: clt$command_or_function;
         get_line: clt$internal_input_procedure;
         symbolic_qualifiers_area: ^clt$work_area;
     VAR work_area {input, output} : ^clt$work_area;
     VAR parse {input, output} : clt$parse_state;
     VAR command_or_function_name: pmt$program_name;
     VAR aliases: ^array [1 .. * ] of pmt$program_name;
     VAR availability: clt$named_entry_availability;
     VAR command_or_function_scope: clt$command_or_function_scope;
     VAR command_log_option: clt$command_log_option;
     VAR parameter_description_table: ^clt$parameter_description_table;
     VAR status: ost$status);


    TYPE
      clt$parameter_header = record
        next_parameter: ^clt$parameter_header,
        number_of_names: clt$parameter_name_count,
        names: ^clt$pdt_parameter_names,
      recend;


    VAR
      context: clt$declaration_context,
      first_parameter: ^clt$parameter_header,
      help_module_name: pmt$program_name,
      number_of_advanced_parameters: clt$parameter_count,
      number_of_hidden_parameters: clt$parameter_count,
      number_of_parameter_names: clt$parameter_name_count,
      number_of_parameters: clt$parameter_count,
      number_of_required_parameters: clt$parameter_count,
      number_of_var_parameters: clt$parameter_count,
      status_parameter_number: 0 .. clc$max_parameters,
      symbolic_qualifiers_work_area: ^clt$work_area;

?? NEWTITLE := 'finalize_pdt', EJECT ??

    PROCEDURE finalize_pdt;

?? NEWTITLE := 'sort_parameter_names', EJECT ??

      PROCEDURE [INLINE] sort_parameter_names;

        VAR
          current: -clc$max_parameter_names .. clc$max_parameter_names,
          gap: clt$parameter_name_index,
          start: clt$parameter_name_index,
          swap: clt$pdt_parameter_name;


        gap := number_of_parameter_names;
        WHILE gap > 1 DO
          gap := 2 * (gap DIV 4) + 1;
          FOR start := 1 TO number_of_parameter_names - gap DO
            current := start;
            WHILE (current > 0) AND (pdt_parameter_names^ [current].
                  name > pdt_parameter_names^ [current + gap].name) DO
              swap := pdt_parameter_names^ [current];
              pdt_parameter_names^ [current] := pdt_parameter_names^ [current + gap];
              pdt_parameter_names^ [current + gap] := swap;
              current := current - gap;
            WHILEND;
          FOREND;
        WHILEND;

      PROCEND sort_parameter_names;
?? OLDTITLE, EJECT ??

      VAR
        default_name: ^clt$variable_name_reference,
        default_value: ^clt$expression_text,
        i: clt$parameter_name_index,
        intermediate_pdt: ^clt$work_area,
*IF $true(osv$unix)
        kludge_pdt: ^array[*] of cell,
*IFEND
        n: clt$parameter_name_count,
        original_intermediate_pdt: ^clt$work_area,
        p: clt$parameter_number,
        parameter: ^clt$pdt_parameter,
        parameter_header: ^clt$parameter_header,
        parameter_names: ^clt$pdt_parameter_names,
        pdt_default_name: ^clt$variable_name_reference,
        pdt_default_value: ^clt$expression_text,
        pdt_header: ^clt$pdt_header,
        pdt_parameters: ^clt$pdt_parameters,
        pdt_parameter_names: ^clt$pdt_parameter_names,
        pdt_size: integer,
        pdt_type_specification: ^clt$type_specification,
        type_specification: ^clt$type_specification;


      IF number_of_parameters = 0 THEN
*IF NOT $true(osv$unix)
        pdt_size := #SIZE (clt$pdt_header);
*ELSE
        pdt_size := ((3 + #SIZE (clt$pdt_header)) DIV 4) * 4;
*IFEND
      ELSE
        pdt_size := i#current_sequence_position (work_area);
        RESET work_area TO first_parameter;
        pdt_size := pdt_size - i#current_sequence_position (work_area);
*IF $true(osv$unix)
        NEXT kludge_pdt: [1 .. pdt_size] IN work_area;
        original_intermediate_pdt := #SEQ (kludge_pdt^);
*ELSE
        NEXT original_intermediate_pdt: [[REP pdt_size OF cell]] IN work_area;
*IFEND
        RESET work_area TO first_parameter;
*IF $true(osv$unix)
        PUSH kludge_pdt: [1 .. pdt_size];
        intermediate_pdt := #SEQ (kludge_pdt^);
*ELSE
        PUSH intermediate_pdt: [[REP pdt_size OF cell]];
*IFEND
        RESET intermediate_pdt;
        intermediate_pdt^ := original_intermediate_pdt^;
*IF NOT $true(osv$unix)
        pdt_size := #SIZE (clt$pdt_header) + pdt_size - (number_of_parameters * #SIZE (clt$parameter_header));
*ELSE
        pdt_size := ((3 + (#SIZE (clt$pdt_header) + pdt_size -
              (number_of_parameters * #SIZE (clt$parameter_header)))) DIV 4) *
              4 + 100;
*IFEND
      IFEND;

      NEXT parameter_description_table: [[REP pdt_size OF cell]] IN work_area;
      IF parameter_description_table = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT clp$internal_generate_pdt;
      IFEND;
      RESET parameter_description_table;
      NEXT pdt_header IN parameter_description_table;

      pdt_header^.version := clc$declaration_version;
      pmp$get_compact_date_time (pdt_header^.generation_date_time, status);
      IF NOT status.normal THEN
        EXIT clp$internal_generate_pdt;
      IFEND;
      pdt_header^.command_or_function := command_or_function;
      pdt_header^.number_of_parameter_names := number_of_parameter_names;
      pdt_header^.number_of_parameters := number_of_parameters;
      pdt_header^.number_of_required_parameters := number_of_required_parameters;
      pdt_header^.number_of_advanced_parameters := number_of_advanced_parameters;
      pdt_header^.number_of_hidden_parameters := number_of_hidden_parameters;
      pdt_header^.number_of_var_parameters := number_of_var_parameters;
      pdt_header^.status_parameter_number := status_parameter_number;
      pdt_header^.help_module_name := help_module_name;

      IF number_of_parameters = 0 THEN
        RESET parameter_description_table;
        RETURN;
      IFEND;


      NEXT pdt_parameter_names: [1 .. number_of_parameter_names] IN parameter_description_table;
      NEXT pdt_parameters: [1 .. number_of_parameters] IN parameter_description_table;
      n := 0;

    /copy_intermediate_to_final/
      FOR p := 1 TO number_of_parameters DO
        NEXT parameter_header IN intermediate_pdt;

        NEXT parameter IN intermediate_pdt;
        pdt_parameters^ [p] := parameter^;

        NEXT parameter_names: [1 .. parameter_header^.number_of_names] IN intermediate_pdt;
        FOR i := 1 TO parameter_header^.number_of_names DO
          n := n + 1;
          pdt_parameter_names^ [n] := parameter_names^ [i];
        FOREND;

*IF $true(osv$unix)
        NEXT kludge_pdt: [1 .. parameter^.type_specification_size] IN intermediate_pdt;
        type_specification := #SEQ (kludge_pdt^);
*ELSE
        NEXT type_specification: [[REP parameter^.type_specification_size OF cell]] IN intermediate_pdt;
*IFEND
*IF NOT $true(osv$unix)
        NEXT pdt_type_specification: [[REP parameter^.type_specification_size OF cell]] IN
              parameter_description_table;
*ELSE
        NEXT kludge_pdt: [1 .. parameter^.type_specification_size] IN parameter_description_table;
        pdt_type_specification := #SEQ (kludge_pdt^);
*IFEND
        pdt_type_specification^ := type_specification^;

        IF parameter^.default_name_size > 0 THEN
          NEXT default_name: [parameter^.default_name_size] IN intermediate_pdt;
          NEXT pdt_default_name: [parameter^.default_name_size] IN parameter_description_table;
          pdt_default_name^ := default_name^;
        IFEND;

        IF parameter^.default_value_size > 0 THEN
          NEXT default_value: [parameter^.default_value_size] IN intermediate_pdt;
          NEXT pdt_default_value: [parameter^.default_value_size] IN parameter_description_table;
          pdt_default_value^ := default_value^;
        IFEND;
      FOREND /copy_intermediate_to_final/;

      sort_parameter_names;

    /set_parameter_name_indices/
      FOR i := 1 TO number_of_parameter_names DO
        IF pdt_parameter_names^ [i].class = clc$nominal_entry THEN
          pdt_parameters^ [pdt_parameter_names^ [i].position].name_index := i;
        IFEND;
      FOREND /set_parameter_name_indices/;

      RESET parameter_description_table;

    PROCEND finalize_pdt;
?? TITLE := 'get_next_line', EJECT ??

    PROCEDURE [INLINE] get_next_line;

      VAR
        end_of_input: boolean;


      IF get_line = NIL THEN
        osp$set_status_abnormal ('CL', cle$eoi_in_declaration, context.identifier, status);
        EXIT clp$internal_generate_pdt;
      IFEND;

      get_line^ (parse, end_of_input, status);

      IF NOT status.normal THEN
        EXIT clp$internal_generate_pdt;
      ELSEIF end_of_input THEN
        osp$set_status_abnormal ('CL', cle$eoi_in_declaration, context.identifier, status);
        EXIT clp$internal_generate_pdt;
      IFEND;
      clp$scan_non_space_lexical_unit (parse);

    PROCEND get_next_line;
?? TITLE := 'process_parameter_definitions', EJECT ??

    PROCEDURE process_parameter_definitions;

      VAR
        current_parameter: ^clt$parameter_header;

?? NEWTITLE := 'process_parameter_definition', EJECT ??

      PROCEDURE process_parameter_definition;

        VAR
          found_end_of_definition: boolean,
          pdt_parameter: ^clt$pdt_parameter,
          type_name: clt$type_name;

?? NEWTITLE := 'process_default_specification', EJECT ??

        PROCEDURE process_default_specification;

          VAR
            default_name: ^clt$variable_name_reference,
            default_name_size: 0 .. osc$max_name_size,
            default_value: ^clt$expression_text,
            default_value_index: clt$string_index,
            name: ost$name;


          pdt_parameter^.requirement := clc$optional_default_parameter;

          IF parse.unit.kind = clc$lex_name THEN
            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);

            IF name = '$REQUIRED' THEN
              pdt_parameter^.requirement := clc$required_parameter;
              number_of_required_parameters := number_of_required_parameters + 1;
              clp$scan_non_space_lexical_unit (parse);
              RETURN;

            ELSEIF name = '$OPTIONAL' THEN
              pdt_parameter^.requirement := clc$optional_parameter;
              clp$scan_non_space_lexical_unit (parse);
              RETURN;

            ELSEIF name = '$CONFIRM' THEN
              pdt_parameter^.requirement := clc$confirm_default_parameter;
              clp$scan_non_space_lexical_unit (parse);
              IF parse.unit.kind = clc$lex_end_of_line THEN
                get_next_line;
              ELSEIF NOT parse.previous_unit_is_space THEN
                osp$set_status_abnormal ('CL', cle$missing_spaces_after, '$CONFIRM', status);
                EXIT clp$internal_generate_pdt;
              IFEND;
              IF parse.unit.kind = clc$lex_name THEN
                #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
              IFEND;
            IFEND;
          IFEND;

          default_value_index := parse.unit_index;

          IF parse.unit.kind = clc$lex_name THEN
            default_name_size := parse.unit.size;
            clp$scan_non_space_lexical_unit (parse);
            IF parse.unit.kind = clc$lex_comma THEN
              NEXT default_name: [default_name_size] IN work_area;
              IF default_name = NIL THEN
                osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
                EXIT clp$internal_generate_pdt;
              IFEND;
              default_name^ := name;
              pdt_parameter^.default_name_size := default_name_size;
              clp$scan_non_space_lexical_unit (parse);
              IF parse.unit.kind = clc$lex_end_of_line THEN
                get_next_line;
              IFEND;
              default_value_index := parse.unit_index;
            IFEND;
          IFEND;

          IF NOT (parse.unit.kind IN $clt$lexical_unit_kinds
                [clc$lex_end_of_line, clc$lex_semicolon, clc$lex_right_parenthesis]) THEN

          /scan_default_expression/
            WHILE TRUE DO
              clp$scan_unnested_sep_lex_unit (clc$ignore_ellipsis, parse);
              IF parse.unit.kind IN $clt$lexical_unit_kinds
                    [clc$lex_end_of_line, clc$lex_semicolon, clc$lex_right_parenthesis] THEN
                EXIT /scan_default_expression/;
              IFEND;
              clp$scan_non_space_lexical_unit (parse);
              IF parse.unit.kind IN $clt$lexical_unit_kinds
                    [clc$lex_end_of_line, clc$lex_semicolon, clc$lex_right_parenthesis] THEN
                EXIT /scan_default_expression/;
              IFEND;
            WHILEND /scan_default_expression/;
          IFEND;

          pdt_parameter^.default_value_size := parse.unit_index - default_value_index;
          NEXT default_value: [pdt_parameter^.default_value_size] IN work_area;
          IF default_value = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            EXIT clp$internal_generate_pdt;
          IFEND;
          default_value^ := parse.text^ (default_value_index, pdt_parameter^.default_value_size);

        PROCEND process_default_specification;
?? TITLE := 'process_parameter_attributes', EJECT ??

        PROCEDURE process_parameter_attributes;

?? NEWTITLE := 'process_parameter_attribute', EJECT ??

          PROCEDURE process_parameter_attribute;

            VAR
              name: ost$name;


            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);

            IF name = 'ADVANCED' THEN
              IF pdt_parameter^.availability = clc$normal_usage_entry THEN
                pdt_parameter^.availability := clc$advanced_usage_entry;
                number_of_advanced_parameters := number_of_advanced_parameters + 1;
                IF context.kind = clc$procedure_declaration THEN
                  pdt_parameter^.specification_methods := $clt$parameter_spec_methods [clc$specify_by_name];
                IFEND;
                RETURN;
              IFEND;

            ELSEIF name = 'BY_NAME' THEN
              IF context.kind = clc$function_declaration THEN
                osp$set_status_abnormal ('CL', cle$by_name_in_function, current_parameter^.names^ [1].name,
                      status);
                EXIT clp$internal_generate_pdt;
              ELSEIF pdt_parameter^.specification_methods <> $clt$parameter_spec_methods
                    [clc$specify_by_name] THEN
                pdt_parameter^.specification_methods := $clt$parameter_spec_methods [clc$specify_by_name];
                RETURN;
              IFEND;

            ELSEIF name = 'CHECK' THEN
              IF pdt_parameter^.checking_level <> clc$extended_parameter_checking THEN
                pdt_parameter^.checking_level := clc$extended_parameter_checking;
                RETURN;
              IFEND;

            ELSEIF name = 'DEFER' THEN
              IF pdt_parameter^.evaluation_method <> clc$deferred_evaluation THEN
                pdt_parameter^.evaluation_method := clc$deferred_evaluation;
                RETURN;
              IFEND;

            ELSEIF name = 'HIDDEN' THEN
              IF pdt_parameter^.availability <> clc$hidden_entry THEN
                pdt_parameter^.availability := clc$hidden_entry;
                number_of_hidden_parameters := number_of_hidden_parameters + 1;
                IF context.kind = clc$procedure_declaration THEN
                  pdt_parameter^.specification_methods := $clt$parameter_spec_methods [clc$specify_by_name];
                IFEND;
                RETURN;
              IFEND;

            ELSEIF name = 'SECURE' THEN
              IF context.kind = clc$function_declaration THEN
                osp$set_status_abnormal ('CL', cle$secure_param_in_function,
                      current_parameter^.names^ [1].name, status);
                EXIT clp$internal_generate_pdt;
              ELSEIF pdt_parameter^.security <> clc$secure_parameter THEN
                pdt_parameter^.security := clc$secure_parameter;
                command_log_option := clc$manually_log;
                RETURN;
              IFEND;

            ELSEIF name = 'VAR' THEN
              IF context.kind = clc$function_declaration THEN
                osp$set_status_abnormal ('CL', cle$var_param_in_function, current_parameter^.names^ [1].name,
                      status);
                EXIT clp$internal_generate_pdt;
              ELSEIF pdt_parameter^.passing_method <> clc$pass_by_reference THEN
                pdt_parameter^.passing_method := clc$pass_by_reference;
                number_of_var_parameters := number_of_var_parameters + 1;
                RETURN;
              IFEND;

            ELSE
              IF type_name = '' THEN
                type_name := name;
                RETURN;
              IFEND;

              name := 'type name';
            IFEND;

            osp$set_status_abnormal ('CL', cle$duplicate_parameter_attr, name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, current_parameter^.names^ [1].name,
                  status);
            EXIT clp$internal_generate_pdt;

          PROCEND process_parameter_attribute;
?? OLDTITLE, EJECT ??

          WHILE TRUE DO
            CASE parse.unit.kind OF

            = clc$lex_right_parenthesis =
              IF parse.previous_non_space_unit.kind <> clc$lex_name THEN
                osp$set_status_abnormal ('CL', cle$expecting_parameter_attr,
                      current_parameter^.names^ [1].name, status);
                clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
                EXIT clp$internal_generate_pdt;
              IFEND;
              clp$scan_non_space_lexical_unit (parse);
              IF parse.unit.kind = clc$lex_end_of_line THEN
                get_next_line;
              IFEND;
              RETURN;

            = clc$lex_name =
              process_parameter_attribute;
              clp$scan_non_space_lexical_unit (parse);
              IF parse.unit.kind = clc$lex_comma THEN
                clp$scan_non_space_lexical_unit (parse);
              IFEND;

            = clc$lex_long_name =
              osp$set_status_abnormal ('CL', cle$name_too_long, parse.
                    text^ (parse.unit_index, parse.unit.size), status);
              EXIT clp$internal_generate_pdt;

            ELSE
              osp$set_status_abnormal ('CL', cle$expecting_parameter_attr, current_parameter^.names^ [1].name,
                    status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$internal_generate_pdt;

            CASEND;
          WHILEND;

        PROCEND process_parameter_attributes;
?? TITLE := 'process_parameter_names', EJECT ??

        PROCEDURE process_parameter_names;

          VAR
            check_parameter: ^clt$parameter_header,
            i: clt$parameter_name_index,
            name: ost$name;


          pdt_parameter^.name_index := number_of_parameter_names + 1;

          WHILE TRUE DO
            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);

            check_parameter := first_parameter;
            WHILE (check_parameter <> NIL) AND (check_parameter^.number_of_names > 0) DO
              FOR i := 1 TO check_parameter^.number_of_names DO
                IF name = check_parameter^.names^ [i].name THEN
                  osp$set_status_abnormal ('CL', cle$duplicate_parameter_name, name, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, context.identifier, status);
                  EXIT clp$internal_generate_pdt;
                IFEND;
              FOREND;
              check_parameter := check_parameter^.next_parameter;
            WHILEND;

            number_of_parameter_names := number_of_parameter_names + 1;
            current_parameter^.number_of_names := current_parameter^.number_of_names + 1;

            IF current_parameter^.number_of_names = 1 THEN
              NEXT current_parameter^.names: [1 .. 1] IN work_area;
            ELSE
              RESET work_area TO current_parameter^.names;
              NEXT current_parameter^.names: [1 .. current_parameter^.number_of_names] IN work_area;
            IFEND;
            IF current_parameter^.names = NIL THEN
              osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
              EXIT clp$internal_generate_pdt;
            IFEND;

            current_parameter^.names^ [current_parameter^.number_of_names].name := name;
            current_parameter^.names^ [current_parameter^.number_of_names].position := number_of_parameters;
            IF current_parameter^.number_of_names = 1 THEN
              current_parameter^.names^ [current_parameter^.number_of_names].class := clc$nominal_entry;
            ELSEIF context.kind = clc$function_declaration THEN
              osp$set_status_abnormal ('CL', cle$function_parameter_one_name,
                    current_parameter^.names^ [1].name, status);
              EXIT clp$internal_generate_pdt;
            ELSE
              current_parameter^.names^ [current_parameter^.number_of_names].class := clc$alias_entry;
            IFEND;

            clp$scan_non_space_lexical_unit (parse);
            IF parse.unit.kind = clc$lex_comma THEN
              clp$scan_non_space_lexical_unit (parse);
            IFEND;

            CASE parse.unit.kind OF
            = clc$lex_right_parenthesis, clc$lex_semicolon, clc$lex_end_of_line, clc$lex_equal,
                  clc$lex_colon =
              IF parse.previous_non_space_unit.kind <> clc$lex_name THEN
                osp$set_status_abnormal ('CL', cle$expecting_parameter_name,
                      current_parameter^.names^ [1].name, status);
                clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
                EXIT clp$internal_generate_pdt;
              ELSEIF current_parameter^.number_of_names > 1 THEN
                current_parameter^.names^ [current_parameter^.number_of_names].class :=
                      clc$abbreviation_entry;
              IFEND;
              RETURN;
            = clc$lex_name =
              ;
            = clc$lex_long_name =
              osp$set_status_abnormal ('CL', cle$name_too_long, parse.
                    text^ (parse.unit_index, parse.unit.size), status);
              EXIT clp$internal_generate_pdt;
            ELSE
              osp$set_status_abnormal ('CL', cle$expecting_parameter_name, current_parameter^.names^ [1].name,
                    status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$internal_generate_pdt;
            CASEND;
          WHILEND;

        PROCEND process_parameter_names;
?? OLDTITLE, EJECT ??

        VAR
          previous_parameter: ^clt$parameter_header,
          type_header: ^clt$type_specification_header,
          type_specification: ^clt$type_specification;

        found_end_of_definition := FALSE;
        previous_parameter := current_parameter;
        NEXT current_parameter IN work_area;
        IF current_parameter = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          EXIT clp$internal_generate_pdt;
        IFEND;

        IF first_parameter = NIL THEN
          first_parameter := current_parameter;
        ELSE
          previous_parameter^.next_parameter := current_parameter;
        IFEND;

        current_parameter^.next_parameter := NIL;
        current_parameter^.number_of_names := 0;
        current_parameter^.names := NIL;
        number_of_parameters := number_of_parameters + 1;

        NEXT pdt_parameter IN work_area;
        IF pdt_parameter = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          EXIT clp$internal_generate_pdt;
        IFEND;

        process_parameter_names;

        pdt_parameter^.availability := clc$normal_usage_entry;
        pdt_parameter^.security := clc$non_secure_parameter;
        IF context.kind = clc$function_declaration THEN
          pdt_parameter^.specification_methods := $clt$parameter_spec_methods [clc$specify_positionally];
        ELSE
          pdt_parameter^.specification_methods := $clt$parameter_spec_methods
                [clc$specify_positionally, clc$specify_by_name];
        IFEND;
        pdt_parameter^.passing_method := clc$pass_by_value;
        pdt_parameter^.evaluation_method := clc$immediate_evaluation;
        pdt_parameter^.checking_level := clc$standard_parameter_checking;
        pdt_parameter^.default_name_size := 0;
        pdt_parameter^.requirement := clc$optional_parameter;
        pdt_parameter^.default_value_size := 0;

        IF parse.unit.kind = clc$lex_end_of_line THEN
          get_next_line;
        IFEND;

        type_name := '';

        IF parse.unit.kind = clc$lex_colon THEN
          clp$scan_non_space_lexical_unit (parse);
          IF parse.unit.kind = clc$lex_end_of_line THEN
            get_next_line;
          IFEND;

          IF parse.unit.kind = clc$lex_left_parenthesis THEN
            clp$scan_non_space_lexical_unit (parse);
            process_parameter_attributes;
          IFEND;

          context.list_rest_allowed := (context.kind = clc$function_declaration) AND
                (pdt_parameter^.passing_method = clc$pass_by_value);
          evaluate_type_expression (type_name, get_line, parse, context, symbolic_qualifiers_work_area,
                work_area, type_specification, status);
          IF NOT status.normal THEN
            EXIT clp$internal_generate_pdt;
          ELSEIF (pdt_parameter^.passing_method = clc$pass_by_reference) AND
                (current_parameter^.names^ [1].name = 'STATUS') THEN
            RESET type_specification;
            NEXT type_header IN type_specification;
            RESET type_specification;
            IF type_header^.kind = clc$status_type THEN
              status_parameter_number := number_of_parameters;
            IFEND;
          IFEND;
          pdt_parameter^.type_specification_size := #SIZE (type_specification^);

        ELSE { no type specification }
          IF context.kind = clc$function_declaration THEN
            osp$set_status_abnormal ('CL', cle$no_type_for_function_param, current_parameter^.names^ [1].name,
                  status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT clp$internal_generate_pdt;
          IFEND;

          NEXT type_header IN work_area;
          IF type_header = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            EXIT clp$internal_generate_pdt;
          IFEND;

          type_header^.version := clc$declaration_version;
          type_header^.name_size := 0;
          IF current_parameter^.names^ [1].name = 'STATUS' THEN
            type_header^.kind := clc$status_type;
            pdt_parameter^.specification_methods := $clt$parameter_spec_methods [clc$specify_by_name];
            pdt_parameter^.passing_method := clc$pass_by_reference;
            status_parameter_number := number_of_parameters;
          ELSE
            type_header^.kind := clc$file_type;
          IFEND;
          pdt_parameter^.type_specification_size := #SIZE (type_header^);
          found_end_of_definition := TRUE;
        IFEND;

        IF parse.unit.kind = clc$lex_end_of_line THEN
          get_next_line;
          found_end_of_definition := TRUE;
        IFEND;

        IF parse.unit.kind = clc$lex_equal THEN
          clp$scan_non_space_lexical_unit (parse);
          IF parse.unit.kind = clc$lex_end_of_line THEN
            get_next_line;
          IFEND;
          process_default_specification;
          found_end_of_definition := parse.unit.kind IN $clt$lexical_unit_kinds
                [clc$lex_end_of_line, clc$lex_semicolon, clc$lex_right_parenthesis];
        ELSE
          found_end_of_definition := found_end_of_definition OR
                (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_end_of_line, clc$lex_semicolon,
                clc$lex_right_parenthesis]);
        IFEND;

        IF pdt_parameter^.passing_method = clc$pass_by_reference THEN
          IF pdt_parameter^.evaluation_method = clc$deferred_evaluation THEN
            osp$set_status_abnormal ('CL', cle$defer_with_var, current_parameter^.names^ [1].name, status);
            EXIT clp$internal_generate_pdt;
          ELSEIF pdt_parameter^.security = clc$secure_parameter THEN
            osp$set_status_abnormal ('CL', cle$secure_with_var, current_parameter^.names^ [1].name, status);
            EXIT clp$internal_generate_pdt;
          IFEND;
        IFEND;

        CASE pdt_parameter^.requirement OF
        = clc$required_parameter, clc$confirm_default_parameter =
          CASE pdt_parameter^.availability OF
          = clc$advanced_usage_entry =
            osp$set_status_abnormal ('CL', cle$advanced_parameter_conflict, current_parameter^.names^ [1].
                  name, status);
            EXIT clp$internal_generate_pdt;
          = clc$hidden_entry =
            osp$set_status_abnormal ('CL', cle$hidden_parameter_conflict, current_parameter^.names^ [1].name,
                  status);
            EXIT clp$internal_generate_pdt;
          ELSE
            ;
          CASEND;
        ELSE
          ;
        CASEND;

        IF NOT found_end_of_definition THEN
          osp$set_status_abnormal ('CL', cle$expecting_end_of_param_spec, current_parameter^.names^ [1].name,
                status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT clp$internal_generate_pdt;
        IFEND;

      PROCEND process_parameter_definition;
?? OLDTITLE, EJECT ??

      IF parse.unit.kind <> clc$lex_left_parenthesis THEN
        RETURN;
      IFEND;

      current_parameter := NIL;

      clp$scan_non_space_lexical_unit (parse);

      WHILE TRUE DO
        CASE parse.unit.kind OF

        = clc$lex_right_parenthesis =
          clp$scan_non_space_lexical_unit (parse);
          RETURN;

        = clc$lex_semicolon =
          clp$scan_non_space_lexical_unit (parse);

        = clc$lex_end_of_line =
          get_next_line;

        = clc$lex_name =
          IF context.list_rest_encountered THEN
            osp$set_status_abnormal ('CL', cle$improper_use_of_list_rest, '', status);
            EXIT clp$internal_generate_pdt;
          IFEND;
          process_parameter_definition;

        = clc$lex_long_name =
          osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                status);
          EXIT clp$internal_generate_pdt;

        ELSE
          osp$set_status_abnormal ('CL', cle$expecting_parameter_spec, context.identifier, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT clp$internal_generate_pdt;

        CASEND;
      WHILEND;

    PROCEND process_parameter_definitions;
?? TITLE := 'process_proc_attributes', EJECT ??

    PROCEDURE process_proc_attributes;

      VAR
        xdcl_attribute_specified: boolean;

?? NEWTITLE := 'process_proc_attribute', EJECT ??

      PROCEDURE process_proc_attribute;

        VAR
          name: ost$name;


        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);

      /no_conflict/
        BEGIN

        /no_duplicate/
          BEGIN

            IF name = 'ADVANCED' THEN
              CASE availability OF
              = clc$hidden_entry =
                ;
              = clc$advanced_usage_entry =
                EXIT /no_duplicate/;
              = clc$normal_usage_entry =
                availability := clc$advanced_usage_entry;
              CASEND;

            ELSEIF name = 'GATE' THEN
              CASE command_or_function_scope OF
              = clc$gate_command_or_function =
                EXIT /no_duplicate/;
              = clc$local_command_or_function =
                EXIT /no_conflict/;
              = clc$xdcl_command_or_function =
                command_or_function_scope := clc$gate_command_or_function;
              CASEND;

            ELSEIF name = 'HIDDEN' THEN
              IF availability = clc$hidden_entry THEN
                EXIT /no_duplicate/;
              IFEND;
              availability := clc$hidden_entry;

            ELSEIF name = 'LOCAL' THEN
              CASE command_or_function_scope OF
              = clc$gate_command_or_function =
                EXIT /no_conflict/;
              = clc$local_command_or_function =
                EXIT /no_duplicate/;
              = clc$xdcl_command_or_function =
                IF xdcl_attribute_specified THEN
                  EXIT /no_conflict/;
                IFEND;
                command_or_function_scope := clc$local_command_or_function;
              CASEND;

            ELSEIF name = 'XDCL' THEN
              CASE command_or_function_scope OF
              = clc$gate_command_or_function =
                ;
              = clc$local_command_or_function =
                EXIT /no_conflict/;
              = clc$xdcl_command_or_function =
                IF xdcl_attribute_specified THEN
                  EXIT /no_duplicate/;
                IFEND;
                xdcl_attribute_specified := TRUE;
              CASEND;

            ELSE
              IF help_module_name <> '' THEN
                name := 'help module name';
                EXIT /no_duplicate/;
              IFEND;
              help_module_name := name;

            IFEND;
            RETURN;

          END /no_duplicate/;
          osp$set_status_abnormal ('CL', cle$duplicate_proc_attribute, name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, context.identifier, status);
          EXIT clp$internal_generate_pdt;

        END /no_conflict/;
        osp$set_status_abnormal ('CL', cle$proc_scope_attr_conflict, context.identifier, status);
        EXIT clp$internal_generate_pdt;

      PROCEND process_proc_attribute;
?? OLDTITLE, EJECT ??

      help_module_name := '';
      availability := clc$normal_usage_entry;
      command_or_function_scope := clc$xdcl_command_or_function;

      IF parse.unit.kind <> clc$lex_left_parenthesis THEN
        RETURN;
      IFEND;

      xdcl_attribute_specified := FALSE;

      clp$scan_non_space_lexical_unit (parse);
      WHILE TRUE DO
        CASE parse.unit.kind OF

        = clc$lex_right_parenthesis =
          IF parse.previous_non_space_unit.kind <> clc$lex_name THEN
            osp$set_status_abnormal ('CL', cle$expecting_proc_attribute, context.identifier, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT clp$internal_generate_pdt;
          IFEND;
          clp$scan_non_space_lexical_unit (parse);
          RETURN;

        = clc$lex_name =
          process_proc_attribute;
          clp$scan_non_space_lexical_unit (parse);
          IF parse.unit.kind = clc$lex_comma THEN
            clp$scan_non_space_lexical_unit (parse);
          IFEND;

        = clc$lex_long_name =
          osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                status);
          EXIT clp$internal_generate_pdt;

        ELSE
          osp$set_status_abnormal ('CL', cle$expecting_proc_attribute, context.identifier, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT clp$internal_generate_pdt;

        CASEND;
      WHILEND;

    PROCEND process_proc_attributes;
?? TITLE := 'process_proc_names', EJECT ??

    PROCEDURE process_proc_names;

      VAR
        name: ost$name,
        proc_name_count: 0 .. clc$max_proc_names,
        i: 1 .. clc$max_proc_names - 1;


      aliases := NIL;
      proc_name_count := 0;
      WHILE TRUE DO
        CASE parse.unit.kind OF
        = clc$lex_left_parenthesis, clc$lex_semicolon, clc$lex_end_of_line =
          IF (proc_name_count = 0) OR (parse.previous_non_space_unit.kind <> clc$lex_name) THEN
            osp$set_status_abnormal ('CL', cle$expecting_proc_name, context.identifier, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT clp$internal_generate_pdt;
          IFEND;
          RETURN;
        = clc$lex_name =
          ;
        = clc$lex_long_name =
          osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                status);
          EXIT clp$internal_generate_pdt;
        ELSE
          osp$set_status_abnormal ('CL', cle$expecting_proc_name, context.identifier, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT clp$internal_generate_pdt;
        CASEND;

        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        IF (context.kind = clc$function_declaration) AND (name (1) <> '$') THEN
          osp$set_status_abnormal ('CL', cle$function_name_needs_$, name, status);
          EXIT clp$internal_generate_pdt;
        IFEND;

        IF (proc_name_count > 0) AND (name = command_or_function_name) THEN
          osp$set_status_abnormal ('CL', cle$duplicate_proc_name, name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, context.identifier, status);
          EXIT clp$internal_generate_pdt;
        IFEND;
        FOR i := 1 TO proc_name_count - 1 DO
          IF name = aliases^ [i] THEN
            osp$set_status_abnormal ('CL', cle$duplicate_proc_name, name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, context.identifier, status);
            EXIT clp$internal_generate_pdt;
          IFEND;
        FOREND;

        proc_name_count := proc_name_count + 1;
        IF proc_name_count = 1 THEN
          command_or_function_name := name;
        ELSE
          IF aliases <> NIL THEN
            RESET work_area TO aliases;
          IFEND;
          NEXT aliases: [1 .. proc_name_count - 1] IN work_area;
          IF aliases = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            EXIT clp$internal_generate_pdt;
          IFEND;
          aliases^ [proc_name_count - 1] := name;
        IFEND;

        clp$scan_non_space_lexical_unit (parse);
        IF parse.unit.kind = clc$lex_comma THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;
      WHILEND;

    PROCEND process_proc_names;
?? OLDTITLE, EJECT ??

    #KEYPOINT (osk$entry, 0, clk$scan_proc_declaration);

    status.normal := TRUE;

  /evaluate_declaration/
    BEGIN
      symbolic_qualifiers_work_area := symbolic_qualifiers_area;

      IF command_or_function = clc$command THEN
        context.kind := clc$procedure_declaration;
        context.identifier := 'procedure';
      ELSE
        context.kind := clc$function_declaration;
        context.identifier := 'function';
      IFEND;
      context.unspecified_type_allowed := FALSE;
      context.list_rest_allowed := FALSE;
      context.list_rest_encountered := FALSE;

      IF parse.unit_is_space THEN
        clp$scan_non_space_lexical_unit (parse);
      IFEND;

      process_proc_attributes;
      process_proc_names;

      first_parameter := NIL;
      number_of_parameters := 0;
      number_of_required_parameters := 0;
      number_of_advanced_parameters := 0;
      number_of_hidden_parameters := 0;
      number_of_parameter_names := 0;
      number_of_var_parameters := 0;
      status_parameter_number := 0;
      command_log_option := clc$automatically_log;
      process_parameter_definitions;

      CASE parse.unit.kind OF
      = clc$lex_semicolon =
        clp$scan_non_space_lexical_unit (parse);
      = clc$lex_end_of_line =
        ;
      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_proc_header_term, context.identifier, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT /evaluate_declaration/;
      CASEND;

      finalize_pdt;
    END /evaluate_declaration/;

    #KEYPOINT (osk$exit, 0, clk$scan_proc_declaration);

  PROCEND clp$internal_generate_pdt;
?? TITLE := 'clp$generate_type_specification', EJECT ??
*copyc clh$generate_type_specification

  PROCEDURE [XDCL, #GATE] clp$generate_type_specification
    (    type_name: clt$type_name;
         first_line: ^clt$command_line;
         first_line_index: clt$command_line_index;
         get_line: clt$input_procedure;
     VAR work_area {input, output} : ^clt$work_area;
     VAR last_line: ^clt$command_line;
     VAR last_line_index: clt$command_line_index;
     VAR type_specification: ^clt$type_specification;
     VAR status: ost$status);

    CONST
      declaration_identifier = 'type';

    VAR
      get_line_called: boolean,
      lexical_units: ^clt$lexical_units,
      lexical_work_area: ^^clt$work_area,
      local_status: ost$status,
      parse: clt$parse_state;

?? NEWTITLE := 'get_type_spec_line', EJECT ??

    PROCEDURE get_type_spec_line
      (VAR parse: clt$parse_state;
       VAR end_of_input: boolean;
       VAR status: ost$status);

*IF NOT $true(osv$unix)
      VAR
        callers_save_area: ^ost$stack_frame_save_area;

?? NEWTITLE := 'bad_input_proc_pointer_handler', EJECT ??

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


        IF (condition.selector = pmc$system_conditions) AND
              (($pmt$system_conditions [pmc$instruction_specification, pmc$address_specification,
              pmc$access_violation, pmc$environment_specification, pmc$invalid_segment_ring_0,
              pmc$out_call_in_return] * condition.system_conditions) <> $pmt$system_conditions []) THEN
          IF save_area^.minimum_save_area.a2_previous_save_area = callers_save_area THEN
            osp$set_status_abnormal ('CL', cle$unable_to_call_input_proc, 'clp$generate_type_specification',
                  status);
            EXIT get_type_spec_line;
          IFEND;
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        handler_status.normal := TRUE;

      PROCEND bad_input_proc_pointer_handler;
?? OLDTITLE, EJECT ??
*IFEND

      VAR
        line: ^clt$command_line;


      end_of_input := FALSE;

      IF get_line = NIL THEN
        end_of_input := TRUE;
        osp$set_status_abnormal ('CL', cle$eoi_in_declaration, declaration_identifier, status);
        RETURN;
      IFEND;

      REPEAT
        REPEAT

*IF NOT $true(osv$unix)
          IF NOT get_line_called THEN
            callers_save_area := #PREVIOUS_SAVE_AREA ();
            osp$establish_condition_handler (^bad_input_proc_pointer_handler, FALSE);
          IFEND;
*IFEND
          get_line^ (line, status);
          IF NOT get_line_called THEN
*IF NOT $true(osv$unix)
            osp$disestablish_cond_handler;
*IFEND
            get_line_called := TRUE;
          IFEND;

          IF NOT status.normal THEN
            RETURN;
          ELSEIF line = NIL THEN
            end_of_input := TRUE;
            osp$set_status_abnormal ('CL', cle$eoi_in_declaration, declaration_identifier, status);
            RETURN;
          IFEND;
        UNTIL STRLENGTH (line^) > 0;

        RESET lexical_work_area^ TO lexical_units;
        clp$identify_lexical_units (line, lexical_work_area^, lexical_units, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$initialize_parse_state (line, lexical_units, parse);
      UNTIL parse.unit.kind <> clc$lex_end_of_line;

    PROCEND get_type_spec_line;
?? OLDTITLE, EJECT ??

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

  /generate_type_specification/
    BEGIN
*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^parse), lexical_work_area, local_status);
*ELSE
      clp$get_work_area (osc$user_ring, lexical_work_area, local_status);
*IFEND
      IF NOT local_status.normal THEN
        EXIT /generate_type_specification/;
      IFEND;

      clp$identify_lexical_units (first_line, lexical_work_area^, lexical_units, local_status);
      IF NOT local_status.normal THEN
        EXIT /generate_type_specification/;
      IFEND;

      clp$initialize_parse_state (first_line, lexical_units, parse);
      REPEAT
        clp$scan_any_lexical_unit (parse);
      UNTIL (parse.unit_index >= first_line_index) OR (parse.unit_index >= parse.index_limit);

      clp$internal_gen_type_spec (type_name, FALSE, ^get_type_spec_line, NIL, work_area, parse,
            type_specification, local_status);

      RESET lexical_work_area^ TO lexical_units;

      last_line := parse.text;
      last_line_index := parse.unit_index;
    END /generate_type_specification/;

    IF NOT local_status.normal THEN
      IF local_status.condition = cle$work_area_overflow THEN
        local_status.text.size := 0;
        osp$append_status_parameter (osc$status_parameter_delimiter, 'clp$generate_type_specification',
              local_status);
      IFEND;
      status := local_status;
    IFEND;

  PROCEND clp$generate_type_specification;
?? TITLE := 'clp$internal_gen_type_spec', EJECT ??
{
{ NOTE:
{   If the unspecified_type_allowed parameter is given as true, then if a
{   clc$unspecified results from the attempt to "lookup" a type name,
{   NIL is returned for the type_specification parameter.
{

  PROCEDURE [XDCL, #GATE] clp$internal_gen_type_spec
    (    type_name: clt$type_name;
         unspecified_type_allowed: boolean;
         get_line: clt$internal_input_procedure;
         symbolic_qualifiers_area: ^clt$work_area;
     VAR work_area {input, output} : ^clt$work_area;
     VAR parse {input, output} : clt$parse_state;
     VAR type_specification: ^clt$type_specification;
     VAR status: ost$status);

    VAR
      context: clt$declaration_context,
      end_of_input: boolean,
      size: clt$type_specification_size,
      symbolic_qualifiers_work_area: ^clt$work_area,
      type_header: ^clt$type_specification_header;


    status.normal := TRUE;

    symbolic_qualifiers_work_area := symbolic_qualifiers_area;

    context.kind := clc$type_declaration;
    context.identifier := 'type';
    context.unspecified_type_allowed := unspecified_type_allowed;
    context.list_rest_allowed := FALSE;
    context.list_rest_encountered := FALSE;

    IF parse.unit_is_space THEN
      clp$scan_non_space_lexical_unit (parse);
    IFEND;
    IF parse.unit.kind = clc$lex_end_of_line THEN
      IF get_line = NIL THEN
        osp$set_status_abnormal ('CL', cle$eoi_in_declaration, context.identifier, status);
        RETURN;
      IFEND;
      get_line^ (parse, end_of_input, status);
      IF NOT status.normal THEN
        RETURN;
      ELSEIF end_of_input THEN
        osp$set_status_abnormal ('CL', cle$eoi_in_declaration, context.identifier, status);
        RETURN;
      IFEND;
      clp$scan_non_space_lexical_unit (parse);
    IFEND;

    evaluate_type_expression (type_name, get_line, parse, context, symbolic_qualifiers_work_area, work_area,
          type_specification, status);

  PROCEND clp$internal_gen_type_spec;
?? TITLE := 'evaluate_type_expression', EJECT ??

  PROCEDURE evaluate_type_expression
    (    type_name: clt$type_name;
         get_line: clt$internal_input_procedure;
     VAR parse {input, output} : clt$parse_state;
     VAR context {input, output} : clt$declaration_context;
     VAR symbolic_qualifiers_work_area {input, output} : ^clt$work_area;
     VAR work_area {input, output} : ^clt$work_area;
     VAR type_specification: ^clt$type_specification;
     VAR status: ost$status);


    CONST
*IF NOT $true(osv$unix)
      max_generic_types = 31,
*ELSE
      max_generic_types = 33,
*IFEND
      min_generic_type_size = 3 {ANY, KEY} ,
      max_generic_type_size = 21 {ENTRY_POINT_REFERENCE} ;

    TYPE
      clt$generic_type_descriptor = record
        name: string (max_generic_type_size),
        case kind: clt$type_kind of
        = clc$application_type .. clc$cobol_name_type =
          ,
        = clc$date_time_type =
          date_and_or_time: clt$date_and_or_time,
        = clc$entry_point_reference_type .. clc$union_type =
          ,
        casend,
      recend;

    VAR
*IF NOT $true(osv$unix)
      generic_type_table: [STATIC, READ, oss$job_paged_literal] array [1 .. max_generic_types] of
*ELSE
      generic_type_table: [STATIC, READ] array [1 .. max_generic_types] of
*IFEND
            clt$generic_type_descriptor := [
            {} ['ANY                            ', clc$union_type],
            {} ['APPLICATION                    ', clc$application_type],
            {} ['ARRAY                          ', clc$array_type],
            {} ['BOOLEAN                        ', clc$boolean_type],
            {} ['COBOL_NAME                     ', clc$cobol_name_type],
            {} ['COMMAND_REFERENCE              ', clc$command_reference_type],
            {} ['DATA_NAME                      ', clc$data_name_type],
            {} ['DATE                           ', clc$date_time_type, [clc$date]],
            {} ['DATE_TIME                      ', clc$date_time_type, [clc$date, clc$time]],
            {} ['ENTRY_POINT_REFERENCE          ', clc$entry_point_reference_type],
            {} ['FILE                           ', clc$file_type],
            {} ['INTEGER                        ', clc$integer_type],
            {} ['KEY                            ', clc$keyword_type],
            {} ['LINE_IDENTIFIER                ', clc$scu_line_identifier_type],
            {} ['LIST                           ', clc$list_type],
            {} ['LOCK                           ', clc$lock_type],
            {} ['NAME                           ', clc$name_type],
            {} ['NETWORK_TITLE                  ', clc$network_title_type],
*IF $true(osv$unix)
            {} ['NOS_VE_FILE                    ', clc$nos_ve_file_type],
*IFEND
            {} ['PROGRAM_NAME                   ', clc$program_name_type],
            {} ['RANGE                          ', clc$range_type],
            {} ['REAL                           ', clc$real_type],
            {} ['RECORD                         ', clc$record_type],
            {} ['STATISTIC_CODE                 ', clc$statistic_code_type],
            {} ['STATUS                         ', clc$status_type],
            {} ['STATUS_CODE                    ', clc$status_code_type],
            {} ['STRING                         ', clc$string_type],
            {} ['STRING_PATTERN                 ', clc$string_pattern_type],
            {} ['TIME                           ', clc$date_time_type, [clc$time]],
            {} ['TIME_INCREMENT                 ', clc$time_increment_type],
            {} ['TIME_ZONE                      ', clc$time_zone_type],
*IF NOT $true(osv$unix)
            {} ['TYPE                           ', clc$type_specification_type]];
*ELSE
            {} ['TYPE                           ', clc$type_specification_type],
            {} ['UNIX_FILE                      ', clc$unix_file_type]];
*IFEND


    VAR
      name: ost$name;

?? NEWTITLE := 'check_for_defined_type', EJECT ??

    PROCEDURE check_for_defined_type
      (    name: ost$name;
       VAR defined_type_specification: ^clt$type_specification);

      VAR
*IF NOT $true(osv$unix)
        access_variable_requests: clt$access_variable_requests,
*IFEND
        found: boolean,
        local_parse: clt$parse_state,
        result: ^clt$data_value;


      local_parse := parse;
      clp$scan_any_lexical_unit (local_parse);

*IF NOT $true(osv$unix)
      access_variable_requests := $clt$access_variable_requests[];
      clp$evaluate_name (name, access_variable_requests, local_parse, work_area, result, found, status);
*ELSE
      found := FALSE;
*IFEND
      IF NOT status.normal THEN
        EXIT evaluate_type_expression;
      ELSEIF NOT found THEN
        osp$set_status_abnormal ('CL', cle$expecting_type_expression, name, status);
        EXIT evaluate_type_expression;
      ELSEIF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$variable_never_given_value, name, status);
        EXIT evaluate_type_expression;
      ELSE
        CASE result^.kind OF
        = clc$type_specification =
          parse := local_parse;
          IF parse.unit_is_space THEN
            clp$scan_non_space_lexical_unit (parse);
          IFEND;
          defined_type_specification := result^.type_specification_value;
        = clc$unspecified =
          IF context.unspecified_type_allowed THEN

            RESET work_area TO type_header;
            EXIT evaluate_type_expression;

          IFEND;
          defined_type_specification := NIL;
        ELSE
          defined_type_specification := NIL;
        CASEND;
      IFEND;

    PROCEND check_for_defined_type;
?? TITLE := 'check_for_generic_type', EJECT ??

    PROCEDURE [INLINE] check_for_generic_type
      (    name: ost$name;
           name_size: ost$name_size;
       VAR generic_type_descriptor: ^clt$generic_type_descriptor);

      VAR
        current_index: 1 .. max_generic_types,
        high_index: 0 .. max_generic_types,
        temp: integer,
        low_index: 1 .. max_generic_types + 1;


      IF (min_generic_type_size <= name_size) AND (name_size <= max_generic_type_size) THEN
        low_index := 1;
        high_index := max_generic_types;
        REPEAT
          temp := low_index + high_index;
          current_index := temp DIV 2;
          IF name (1, max_generic_type_size) = generic_type_table [current_index].name THEN
            generic_type_descriptor := ^generic_type_table [current_index];
            RETURN;

          ELSEIF name (1, max_generic_type_size) > generic_type_table [current_index].name THEN
            low_index := current_index + 1;
          ELSE
            high_index := current_index - 1;
          IFEND;
        UNTIL low_index > high_index;
      IFEND;

      generic_type_descriptor := NIL;

    PROCEND check_for_generic_type;
?? TITLE := 'evaluate_application_type', EJECT ??

    PROCEDURE evaluate_application_type;

      VAR
        application_qualifier: ^clt$application_type_qualifier,
        name: ost$name;


      NEXT application_qualifier IN work_area;
      IF application_qualifier = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT evaluate_type_expression;
      IFEND;

      application_qualifier^.balance_brackets := FALSE;

      clp$scan_non_space_lexical_unit (parse);

      CASE parse.unit.kind OF

      = clc$lex_end_of_line, clc$lex_equal, clc$lex_semicolon, clc$lex_right_parenthesis =
        RETURN;

      = clc$lex_name =
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        IF name <> 'BALANCE_BRACKETS' THEN
          osp$set_status_abnormal ('CL', cle$expecting_applic_type_attr, name, status);
          EXIT evaluate_type_expression;
        IFEND;
        application_qualifier^.balance_brackets := TRUE;
        clp$scan_non_space_lexical_unit (parse);

      = clc$lex_long_name =
        osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
              status);
        EXIT evaluate_type_expression;

      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_applic_type_attr, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT evaluate_type_expression;
      CASEND;

    PROCEND evaluate_application_type;
?? TITLE := 'evaluate_array_type', EJECT ??

    PROCEDURE evaluate_array_type;

      VAR
        array_qualifier: ^clt$array_type_qualifier,
        element_type_specification: ^clt$type_specification,
        elements_context: clt$declaration_context,
        high_integer: integer,
        ignore_range_present: boolean,
        low_integer: integer,
        name: ost$name,
        qualifier_present: boolean,
        symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier;


      NEXT array_qualifier IN work_area;
      IF array_qualifier = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT evaluate_type_expression;
      IFEND;
      init_symbolic_subrange_qual (symbolic_subrange_qualifier);

      array_qualifier^.element_type_specification_size := 0;
      array_qualifier^.array_bounds_defined := FALSE;

      clp$scan_non_space_lexical_unit (parse);
      CASE parse.unit.kind OF
      = clc$lex_end_of_line, clc$lex_equal, clc$lex_semicolon, clc$lex_right_parenthesis =
        IF context.kind = clc$type_declaration THEN
          osp$set_status_abnormal ('CL', cle$array_bounds_required, '', status);
          EXIT evaluate_type_expression;
        IFEND;
        RETURN;

      ELSE
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$missing_spaces_after, 'ARRAY', status);
          EXIT evaluate_type_expression;
        IFEND;
      CASEND;

    /evaluate_array_bounds/
      BEGIN
        IF parse.unit.kind = clc$lex_name THEN
          #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
          IF name = 'OF' THEN
            IF context.kind = clc$type_declaration THEN
              osp$set_status_abnormal ('CL', cle$array_bounds_required, '', status);
              EXIT evaluate_type_expression;
            IFEND;
            EXIT /evaluate_array_bounds/;
          IFEND;
        IFEND;

        evaluate_subrange_qualifier (clc$min_array_bound, clc$max_array_bound, cle$array_bound_out_of_range,
              cle$min_array_bound_gt_max, cle$max_array_bound_omitted, symbolic_subrange_qualifier,
              low_integer, high_integer, ignore_range_present, qualifier_present);
        IF qualifier_present THEN
          array_qualifier^.array_bounds_defined := TRUE;
          array_qualifier^.bounds.lower := low_integer;
          array_qualifier^.bounds.upper := high_integer;
        ELSEIF context.kind = clc$type_declaration THEN
          osp$set_status_abnormal ('CL', cle$array_bounds_required, '', status);
          EXIT evaluate_type_expression;
        IFEND;

        IF parse.unit.kind = clc$lex_name THEN
          #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        IFEND;
      END /evaluate_array_bounds/;

      CASE parse.unit.kind OF
      = clc$lex_end_of_line, clc$lex_equal, clc$lex_semicolon, clc$lex_right_parenthesis =
        IF context.kind = clc$type_declaration THEN
          osp$set_status_abnormal ('CL', cle$array_elem_type_required, '', status);
          EXIT evaluate_type_expression;
        IFEND;

      = clc$lex_name =
        IF name <> 'OF' THEN
          osp$set_status_abnormal ('CL', cle$expecting_of_for_array, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT evaluate_type_expression;
        IFEND;

        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$missing_spaces_before, 'OF', status);
          EXIT evaluate_type_expression;
        IFEND;
        clp$scan_non_space_lexical_unit (parse);
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$missing_spaces_after, 'OF', status);
          EXIT evaluate_type_expression;
        IFEND;

        elements_context.kind := context.kind;
        elements_context.identifier := context.identifier;
        elements_context.unspecified_type_allowed := FALSE;
        elements_context.list_rest_allowed := FALSE;
        elements_context.list_rest_encountered := FALSE;

        evaluate_type_expression (osc$null_name, get_line, parse, elements_context,
              symbolic_qualifiers_work_area, work_area, element_type_specification, status);
        IF NOT status.normal THEN
          EXIT evaluate_type_expression;
        IFEND;
*IF NOT $true(osv$unix)
        array_qualifier^.element_type_specification_size := #SIZE (element_type_specification^);
*ELSE
        array_qualifier^.element_type_specification_size := #SIZE (element_type_specification^);
{       array_qualifier^.element_type_specification_size :=
{             ((3 + #SIZE (element_type_specification^)) DIV 4) * 4;
*IFEND

      = clc$lex_long_name =
        osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
              status);
        EXIT evaluate_type_expression;

      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_of_for_array, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT evaluate_type_expression;
      CASEND;

    PROCEND evaluate_array_type;
?? TITLE := 'evaluate_date_time_type', EJECT ??

    PROCEDURE evaluate_date_time_type
      (    date_and_or_time: clt$date_and_or_time);

      VAR
        date_time_qualifier: ^clt$date_time_type_qualifier;


      NEXT date_time_qualifier IN work_area;
      IF date_time_qualifier = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT evaluate_type_expression;
      IFEND;

      date_time_qualifier^.date_and_or_time := date_and_or_time;

      clp$scan_non_space_lexical_unit (parse);
      date_time_qualifier^.tenses := $clt$date_time_tenses [];

      WHILE TRUE DO
        CASE parse.unit.kind OF
        = clc$lex_end_of_line, clc$lex_semicolon, clc$lex_right_parenthesis, clc$lex_equal,
          clc$lex_comma =
          IF date_time_qualifier^.tenses = $clt$date_time_tenses [] THEN
            date_time_qualifier^.tenses := $clt$date_time_tenses [clc$past, clc$present, clc$future];
          IFEND;
          RETURN;
        = clc$lex_name =
          ;
        = clc$lex_long_name =
          osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                status);
          EXIT evaluate_type_expression;
        ELSE
          osp$set_status_abnormal ('CL', cle$expecting_date_time_tense, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT evaluate_type_expression;
        CASEND;

        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        IF name = 'FUTURE' THEN
          date_time_qualifier^.tenses := date_time_qualifier^.tenses + $clt$date_time_tenses [clc$future];
        ELSEIF name = 'PAST' THEN
          date_time_qualifier^.tenses := date_time_qualifier^.tenses + $clt$date_time_tenses [clc$past];
        ELSEIF name = 'PRESENT' THEN
          date_time_qualifier^.tenses := date_time_qualifier^.tenses + $clt$date_time_tenses [clc$present];
        ELSE
          osp$set_status_abnormal ('CL', cle$expecting_date_time_tense, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT evaluate_type_expression;
        IFEND;

        clp$scan_non_space_lexical_unit (parse);
        IF parse.unit.kind = clc$lex_comma THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;
      WHILEND;

    PROCEND evaluate_date_time_type;
?? TITLE := 'evaluate_integer_type', EJECT ??

    PROCEDURE evaluate_integer_type;

      VAR
        evaluate_radix: boolean,
        ignore_qualifier_present: boolean,
        ignore_range_present: boolean,
        integer_qualifier: ^clt$integer_type_qualifier,
        local_work_area: ^clt$work_area,
        name: ost$name,
        result_integer: clt$integer,
        symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier;


      NEXT integer_qualifier IN work_area;
      IF integer_qualifier = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT evaluate_type_expression;
      IFEND;
      init_symbolic_subrange_qual (symbolic_subrange_qualifier);

      integer_qualifier^.min_integer_value := clc$min_integer;
      integer_qualifier^.max_integer_value := clc$max_integer;
      integer_qualifier^.default_radix := 10;

      evaluate_radix := FALSE;
      clp$scan_non_space_lexical_unit (parse);
      IF parse.unit.kind = clc$lex_name THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        evaluate_radix := name = 'RADIX';
      IFEND;

      IF NOT evaluate_radix THEN
        evaluate_subrange_qualifier (clc$min_integer, clc$max_integer, cle$integer_out_of_range,
              cle$min_of_subrange_not_le_max, cle$max_of_subrange_omitted, symbolic_subrange_qualifier,
              integer_qualifier^.min_integer_value, integer_qualifier^.max_integer_value,
              ignore_range_present, ignore_qualifier_present);

        IF parse.unit.kind = clc$lex_name THEN
          #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
          evaluate_radix := name = 'RADIX';
        IFEND;
      IFEND;

      IF evaluate_radix THEN
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$missing_spaces_before, 'RADIX', status);
          EXIT evaluate_type_expression;
        IFEND;
        clp$scan_non_space_lexical_unit (parse);
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$missing_spaces_after, 'RADIX', status);
          EXIT evaluate_type_expression;
        IFEND;

        local_work_area := work_area;
        clp$evaluate_integer_expression (LOWERVALUE (result_integer.radix), UPPERVALUE (result_integer.radix),
              work_area, parse, result_integer, status);
        IF NOT status.normal THEN
          IF status.condition = cle$integer_out_of_range THEN
            status.condition := cle$radix_out_of_range;
          IFEND;
          EXIT evaluate_type_expression;
        IFEND;
        integer_qualifier^.default_radix := result_integer.value;
      IFEND;

    PROCEND evaluate_integer_type;
?? TITLE := 'evaluate_keyword_type', EJECT ??

    PROCEDURE evaluate_keyword_type;

      VAR
        availability: clt$named_entry_availability,
        first_keyword_specification: ^clt$keyword_specification,
        keywords: ^clt$keyword_specifications,
        name: ost$name,
        number_of_keywords: 0 .. clc$max_keywords,
        ordinal: clt$named_entry_ordinal;

?? NEWTITLE := 'check_for_duplicate_keyword', EJECT ??

      PROCEDURE [INLINE] check_for_duplicate_keyword;

        VAR
          i: 1 .. clc$max_keywords;


        FOR i := 1 TO number_of_keywords DO
          IF keywords^ [i].keyword = name THEN
            osp$set_status_abnormal ('CL', cle$duplicate_keyword, name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, context.identifier, status);
            EXIT evaluate_type_expression;
          IFEND;
        FOREND;

      PROCEND check_for_duplicate_keyword;
?? TITLE := 'evaluate_keyword_group', EJECT ??

      PROCEDURE evaluate_keyword_group;

        VAR
          class: clt$named_entry_class,
          number_of_keywords_in_group: 0 .. clc$max_keywords;


        class := clc$nominal_entry;
        number_of_keywords_in_group := 0;
        clp$scan_non_space_lexical_unit (parse);
        WHILE TRUE DO
          CASE parse.unit.kind OF

          = clc$lex_right_parenthesis =
            IF parse.previous_non_space_unit.kind = clc$lex_comma THEN
              osp$set_status_abnormal ('CL', cle$expecting_key_in_spec, '', status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT evaluate_type_expression;
            IFEND;
            IF number_of_keywords_in_group > 1 THEN
              keywords^ [number_of_keywords].class := clc$abbreviation_entry;
            IFEND;
            RETURN;

          = clc$lex_name =
            ;

          = clc$lex_long_name =
            osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                  status);
            EXIT evaluate_type_expression;

          ELSE
            osp$set_status_abnormal ('CL', cle$expecting_key_in_spec, '', status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT evaluate_type_expression;
          CASEND;

          #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);

          check_for_duplicate_keyword;

          number_of_keywords := number_of_keywords + 1;
          number_of_usage_keywords := number_of_usage_keywords + 1;

          RESET work_area TO first_keyword_specification;
          NEXT keywords: [1 .. number_of_keywords] IN work_area;
          IF keywords = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            EXIT evaluate_type_expression;
          IFEND;

          keywords^ [number_of_keywords].keyword := name;
          keywords^ [number_of_keywords].class := class;
          keywords^ [number_of_keywords].availability := availability;
          keywords^ [number_of_keywords].ordinal := ordinal;
          number_of_keywords_in_group := number_of_keywords_in_group + 1;
          class := clc$alias_entry;

          clp$scan_non_space_lexical_unit (parse);
          IF parse.unit.kind = clc$lex_comma THEN
            clp$scan_non_space_lexical_unit (parse);
          IFEND;
          IF parse.unit.kind = clc$lex_end_of_line THEN
            get_next_line;
          IFEND;
        WHILEND;

      PROCEND evaluate_keyword_group;
?? TITLE := 'sort_keywords', EJECT ??

      PROCEDURE [INLINE] sort_keywords;

        VAR
          current: -clc$max_keywords .. clc$max_keywords,
          gap: 1 .. clc$max_keywords,
          start: 1 .. clc$max_keywords,
          swap: clt$keyword_specification;


        gap := UPPERBOUND (keywords^);
        WHILE gap > 1 DO
          gap := 2 * (gap DIV 4) + 1;
          FOR start := 1 TO UPPERBOUND (keywords^) - gap DO
            current := start;
            WHILE (current > 0) AND (keywords^ [current].keyword > keywords^ [current + gap].keyword) DO
              swap := keywords^ [current];
              keywords^ [current] := keywords^ [current + gap];
              keywords^ [current + gap] := swap;
              current := current - gap;
            WHILEND;
          FOREND;
        WHILEND;

      PROCEND sort_keywords;
?? OLDTITLE, EJECT ??

      VAR
        keyword_qualifier: ^clt$keyword_type_qualifier,
        number_of_usage_keywords: 0 .. clc$max_keywords;


      number_of_keywords := 0;
      number_of_usage_keywords := 0;
      availability := clc$normal_usage_entry;
      ordinal := 1;

      NEXT keyword_qualifier IN work_area;
      IF keyword_qualifier = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT evaluate_type_expression;
      IFEND;

      NEXT first_keyword_specification IN work_area;
      IF first_keyword_specification = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT evaluate_type_expression;
      IFEND;

      clp$scan_non_space_lexical_unit (parse);
      IF parse.unit.kind = clc$lex_end_of_line THEN
        get_next_line;
      IFEND;

    /evaluate_keyword/
      WHILE TRUE DO
        CASE parse.unit.kind OF

        = clc$lex_left_parenthesis =
          evaluate_keyword_group;

        = clc$lex_name =
          #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);

          IF name = 'ADVANCED_KEY' THEN
            IF number_of_usage_keywords = 0 THEN
              osp$set_status_abnormal ('CL', cle$no_normal_usage_keywords, '', status);
              EXIT evaluate_type_expression;
            IFEND;
            availability := clc$advanced_usage_entry;
            number_of_usage_keywords := 0;
            clp$scan_non_space_lexical_unit (parse);
            IF parse.unit.kind = clc$lex_end_of_line THEN
              get_next_line;
            IFEND;
            CYCLE /evaluate_keyword/;

          ELSEIF name = 'HIDDEN_KEY' THEN
            IF number_of_usage_keywords = 0 THEN
              IF availability = clc$normal_usage_entry THEN
                osp$set_status_abnormal ('CL', cle$no_normal_usage_keywords, '', status);
              ELSE
                osp$set_status_abnormal ('CL', cle$no_advanced_usage_keywords, '', status);
              IFEND;
              EXIT evaluate_type_expression;
            IFEND;
            availability := clc$hidden_entry;
            number_of_usage_keywords := 0;
            clp$scan_non_space_lexical_unit (parse);
            IF parse.unit.kind = clc$lex_end_of_line THEN
              get_next_line;
            IFEND;
            CYCLE /evaluate_keyword/;

          ELSEIF name = 'KEYEND' THEN
            IF number_of_usage_keywords = 0 THEN
              CASE availability OF
              = clc$normal_usage_entry =
                osp$set_status_abnormal ('CL', cle$no_keywords, '', status);
              = clc$advanced_usage_entry =
                osp$set_status_abnormal ('CL', cle$no_advanced_usage_keywords, '', status);
              ELSE {= clc$hidden_entry =}
                osp$set_status_abnormal ('CL', cle$no_hidden_keywords, '', status);
              CASEND;
              EXIT evaluate_type_expression;
            IFEND;
            clp$scan_non_space_lexical_unit (parse);
            EXIT /evaluate_keyword/;

          ELSE
            check_for_duplicate_keyword;

            number_of_keywords := number_of_keywords + 1;
            number_of_usage_keywords := number_of_usage_keywords + 1;
            RESET work_area TO first_keyword_specification;
            NEXT keywords: [1 .. number_of_keywords] IN work_area;
            IF keywords = NIL THEN
              osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
              EXIT evaluate_type_expression;
            IFEND;
            keywords^ [number_of_keywords].keyword := name;
            keywords^ [number_of_keywords].class := clc$nominal_entry;
            keywords^ [number_of_keywords].availability := availability;
            keywords^ [number_of_keywords].ordinal := ordinal;
          IFEND;

        = clc$lex_long_name =
          osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                status);
          EXIT evaluate_type_expression;

        ELSE
          osp$set_status_abnormal ('CL', cle$expecting_key_in_spec, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT evaluate_type_expression;
        CASEND;

        ordinal := ordinal + 1;
        clp$scan_non_space_lexical_unit (parse);
        CASE parse.unit.kind OF
        = clc$lex_end_of_line =
          get_next_line;
        = clc$lex_comma =
          clp$scan_non_space_lexical_unit (parse);
          IF parse.unit.kind = clc$lex_end_of_line THEN
            get_next_line;
          IFEND;
        ELSE
          ;
        CASEND;
      WHILEND /evaluate_keyword/;

      keyword_qualifier^.number_of_keywords := number_of_keywords;
      sort_keywords;

    PROCEND evaluate_keyword_type;
?? TITLE := 'evaluate_list_type', EJECT ??

    PROCEDURE evaluate_list_type;

      VAR
        element_type_specification: ^clt$type_specification,
        elements_context: clt$declaration_context,
        high_integer: integer,
        ignore_range_present: boolean,
        list_qualifier: ^clt$list_type_qualifier_v2,
        low_integer: integer,
        name: ost$name,
        qualifier_present: boolean,
*IF $true(osv$unix)
        type_spec_size: integer,
*IFEND
        symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier;


      NEXT list_qualifier IN work_area;
      IF list_qualifier = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT evaluate_type_expression;
      IFEND;
      init_symbolic_subrange_qual (symbolic_subrange_qualifier);

      list_qualifier^.element_type_specification_size := 0;
      list_qualifier^.min_list_size := $INTEGER (context.kind <> clc$type_declaration);
      list_qualifier^.max_list_size := clc$max_list_size;
      list_qualifier^.reserved := 0;
      list_qualifier^.defer_expansion := FALSE;
      list_qualifier^.list_rest := FALSE;

      clp$scan_non_space_lexical_unit (parse);

      IF parse.unit.kind = clc$lex_name THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        IF name = 'REST' THEN
          context.list_rest_encountered := TRUE;
          IF NOT context.list_rest_allowed THEN
            osp$set_status_abnormal ('CL', cle$improper_use_of_list_rest, '', status);
            EXIT evaluate_type_expression;
          IFEND;
          list_qualifier^.list_rest := TRUE;
          clp$scan_non_space_lexical_unit (parse);
        IFEND;
      IFEND;

      IF parse.unit.kind = clc$lex_name THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        IF name = 'DEFER_EXPANSION' THEN
          list_qualifier^.defer_expansion := TRUE;
          clp$scan_non_space_lexical_unit (parse);
        IFEND;
      IFEND;

      CASE parse.unit.kind OF
      = clc$lex_end_of_line, clc$lex_equal, clc$lex_semicolon, clc$lex_right_parenthesis =
        IF context.kind = clc$type_declaration THEN
          osp$set_status_abnormal ('CL', cle$list_elem_type_required, '', status);
          EXIT evaluate_type_expression;
        IFEND;
        RETURN;
      ELSE
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$missing_spaces_after, 'LIST', status);
          EXIT evaluate_type_expression;
        IFEND;
      CASEND;

    /evaluate_list_bounds/
      BEGIN
        IF parse.unit.kind = clc$lex_name THEN
          #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
          IF name = 'OF' THEN
            EXIT /evaluate_list_bounds/;
          IFEND;
        IFEND;

        evaluate_subrange_qualifier (0, clc$max_list_size, cle$list_bound_out_of_range,
              cle$min_list_bound_gt_max, cle$max_list_bound_omitted, symbolic_subrange_qualifier, low_integer,
              high_integer, ignore_range_present, qualifier_present);
        IF qualifier_present THEN
          list_qualifier^.min_list_size := low_integer;
        ELSE
          list_qualifier^.min_list_size := 1;
        IFEND;
        list_qualifier^.max_list_size := high_integer;

        IF parse.unit.kind = clc$lex_name THEN
          #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        IFEND;
      END /evaluate_list_bounds/;

      CASE parse.unit.kind OF

      = clc$lex_end_of_line, clc$lex_equal, clc$lex_semicolon, clc$lex_right_parenthesis =
        IF context.kind = clc$type_declaration THEN
          osp$set_status_abnormal ('CL', cle$list_elem_type_required, '', status);
          EXIT evaluate_type_expression;
        IFEND;

      = clc$lex_name =
        IF name <> 'OF' THEN
          osp$set_status_abnormal ('CL', cle$expecting_of_for_list, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT evaluate_type_expression;
        IFEND;

        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$missing_spaces_before, 'OF', status);
          EXIT evaluate_type_expression;
        IFEND;
        clp$scan_non_space_lexical_unit (parse);
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$missing_spaces_after, 'OF', status);
          EXIT evaluate_type_expression;
        IFEND;

        elements_context.kind := context.kind;
        elements_context.identifier := context.identifier;
        elements_context.unspecified_type_allowed := FALSE;
        elements_context.list_rest_allowed := FALSE;
        elements_context.list_rest_encountered := FALSE;

*IF $true(osv$unix)
        type_spec_size := i#current_sequence_position (work_area);
*IFEND
        evaluate_type_expression (osc$null_name, get_line, parse, elements_context,
              symbolic_qualifiers_work_area, work_area, element_type_specification, status);
        IF NOT status.normal THEN
          EXIT evaluate_type_expression;
        IFEND;
*IF NOT $true(osv$unix)
        list_qualifier^.element_type_specification_size := #SIZE (element_type_specification^);
*ELSE
        list_qualifier^.element_type_specification_size := #SIZE (element_type_specification^);
{       type_spec_size := #SIZE (element_type_specification^);
{       stringrep(line,size,'the size of the element type spec is: ',type_spec_size);
{       print_string(line,size);
{       list_qualifier^.element_type_specification_size :=
{             ((3 + #SIZE (element_type_specification^)) DIV 4) * 4;
{       stringrep(line,size,'the size after fudge is: ',
{             list_qualifier^.element_type_specification_size);
{       print_string(line,size);
{       list_qualifier^.element_type_specification_size :=
{             i#current_sequence_position (work_area) - type_spec_size;
*IFEND

      = clc$lex_long_name =
        osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
              status);
        EXIT evaluate_type_expression;

      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_of_for_list, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT evaluate_type_expression;
      CASEND;

    PROCEND evaluate_list_type;
?? TITLE := 'evaluate_name_type', EJECT ??

    PROCEDURE [INLINE] evaluate_name_type;

      VAR
        ignore_qualifier_present: boolean,
        max_size: integer,
        min_size: integer,
        name_qualifier: ^clt$name_type_qualifier,
        range_present: boolean,
        symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier;


      NEXT name_qualifier IN work_area;
      IF name_qualifier = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT evaluate_type_expression;
      IFEND;
      init_symbolic_subrange_qual (symbolic_subrange_qualifier);

      clp$scan_non_space_lexical_unit (parse);
      evaluate_subrange_qualifier (1, osc$max_name_size, cle$name_size_out_of_range, cle$min_name_size_gt_max,
            0, symbolic_subrange_qualifier, min_size, max_size, range_present, ignore_qualifier_present);
      IF range_present THEN
        name_qualifier^.min_name_size := min_size;
      ELSE
        name_qualifier^.min_name_size := 1;
      IFEND;
      name_qualifier^.max_name_size := max_size;

    PROCEND evaluate_name_type;
?? TITLE := 'evaluate_range_type', EJECT ??

    PROCEDURE evaluate_range_type;

      VAR
        element_type_specification: ^clt$type_specification,
        elements_context: clt$declaration_context,
        name: ost$name,
        range_qualifier: ^clt$range_type_qualifier;


      NEXT range_qualifier IN work_area;
      IF range_qualifier = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT evaluate_type_expression;
      IFEND;

      range_qualifier^.element_type_specification_size := 0;

      clp$scan_non_space_lexical_unit (parse);
      CASE parse.unit.kind OF

      = clc$lex_end_of_line, clc$lex_equal, clc$lex_right_parenthesis, clc$lex_semicolon =
        IF context.kind = clc$type_declaration THEN
          osp$set_status_abnormal ('CL', cle$range_elem_type_required, '', status);
          EXIT evaluate_type_expression;
        IFEND;

      = clc$lex_name =
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        IF name <> 'OF' THEN
          osp$set_status_abnormal ('CL', cle$expecting_of_for_range, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT evaluate_type_expression;
        IFEND;

        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$missing_spaces_before, 'OF', status);
          EXIT evaluate_type_expression;
        IFEND;
        clp$scan_non_space_lexical_unit (parse);
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$missing_spaces_after, 'OF', status);
          EXIT evaluate_type_expression;
        IFEND;

        elements_context.kind := context.kind;
        elements_context.identifier := context.identifier;
        elements_context.unspecified_type_allowed := FALSE;
        elements_context.list_rest_allowed := FALSE;
        elements_context.list_rest_encountered := FALSE;

        evaluate_type_expression (osc$null_name, get_line, parse, elements_context,
              symbolic_qualifiers_work_area, work_area, element_type_specification, status);
        IF NOT status.normal THEN
          EXIT evaluate_type_expression;
        IFEND;
*IF NOT $true(osv$unix)
        range_qualifier^.element_type_specification_size := #SIZE (element_type_specification^);
*ELSE
        range_qualifier^.element_type_specification_size := #SIZE (element_type_specification^);
{       range_qualifier^.element_type_specification_size :=
{             ((3 + #SIZE (element_type_specification^)) DIV 4) * 4;
*IFEND

      = clc$lex_long_name =
        osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
              status);
        EXIT evaluate_type_expression;

      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_of_for_range, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT evaluate_type_expression;
      CASEND;

    PROCEND evaluate_range_type;
*IF NOT $true(osv$unix)
?? TITLE := 'evaluate_real_type', EJECT ??

    PROCEDURE evaluate_real_type;

      VAR
        real_qualifier: ^clt$real_type_qualifier,
        result_real: clt$real;


      NEXT real_qualifier IN work_area;
      IF real_qualifier = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT evaluate_type_expression;
      IFEND;

      clp$scan_non_space_lexical_unit (parse);

      CASE parse.unit.kind OF
      = clc$lex_equal, clc$lex_comma, clc$lex_semicolon, clc$lex_end_of_line, clc$lex_right_parenthesis =
        real_qualifier^.min_real_value.long_real := clv$negative_infinity^;
        real_qualifier^.max_real_value.long_real := clv$positive_infinity^;
        RETURN;
      ELSE
        IF parse.unit_index >= parse.index_limit THEN
          real_qualifier^.min_real_value.long_real := clv$negative_infinity^;
          real_qualifier^.max_real_value.long_real := clv$positive_infinity^;
          RETURN;
        IFEND;
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$missing_spaces_after, 'REAL', status);
          EXIT evaluate_type_expression;
        IFEND;
      CASEND;

      clp$evaluate_real_expression (clv$negative_infinity^, clv$positive_infinity^, work_area, parse,
            result_real, status);
      IF NOT status.normal THEN
        EXIT evaluate_type_expression;
      IFEND;
      real_qualifier^.min_real_value.long_real := result_real.value;

      IF parse.unit.kind <> clc$lex_ellipsis THEN
        osp$set_status_abnormal ('CL', cle$max_of_subrange_omitted, '', status);
        EXIT evaluate_type_expression;
      IFEND;

      clp$scan_non_space_lexical_unit (parse);
      clp$evaluate_real_expression (clv$negative_infinity^, clv$positive_infinity^, work_area, parse,
            result_real, status);
      IF NOT status.normal THEN
        EXIT evaluate_type_expression;
      IFEND;
      real_qualifier^.max_real_value.long_real := result_real.value;

      IF NOT clp$longreal_compare_le (real_qualifier^.min_real_value.long_real,
            real_qualifier^.max_real_value.long_real) THEN
        osp$set_status_abnormal ('CL', cle$min_of_subrange_not_le_max, '', status);
        EXIT evaluate_type_expression;
      IFEND;

    PROCEND evaluate_real_type;
*IFEND
?? TITLE := 'evaluate_record_type', EJECT ??

    PROCEDURE evaluate_record_type;

      VAR
        field_specification: ^clt$field_specification;

?? NEWTITLE := 'evaluate_field_requirement', EJECT ??

      PROCEDURE evaluate_field_requirement;


        clp$scan_non_space_lexical_unit (parse);
        IF parse.unit.kind = clc$lex_end_of_line THEN
          get_next_line;
        IFEND;

        CASE parse.unit.kind OF
        = clc$lex_name =
          ;
        = clc$lex_long_name =
          osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                status);
          EXIT evaluate_type_expression;
        ELSE
          osp$set_status_abnormal ('CL', cle$expecting_field_requirement, field_specification^.name, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT evaluate_type_expression;
        CASEND;

        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        IF name = '$OPTIONAL' THEN
          field_specification^.requirement := clc$optional_field;
        ELSEIF name <> '$REQUIRED' THEN
          osp$set_status_abnormal ('CL', cle$expecting_field_requirement, field_specification^.name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
          EXIT evaluate_type_expression;
        IFEND;

        clp$scan_non_space_lexical_unit (parse);

      PROCEND evaluate_field_requirement;
?? OLDTITLE, EJECT ??

      TYPE
        clt$field_names_list_entry = record
          previous: ^clt$field_names_list_entry,
          name: ^clt$field_name,
        recend;

      VAR
        current_field_name: ^clt$field_names_list_entry,
        field_names_list: ^clt$field_names_list_entry,
        field_type_specification: ^clt$type_specification,
        fields_context: clt$declaration_context,
        name: ost$name,
        number_of_fields: 0 .. clc$max_fields,
        previous_unit_is_end_of_line: boolean,
        record_qualifier: ^clt$record_type_qualifier;


      NEXT record_qualifier IN work_area;
      IF record_qualifier = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT evaluate_type_expression;
      IFEND;

      fields_context.kind := clc$type_declaration;
      fields_context.identifier := context.identifier;
      fields_context.unspecified_type_allowed := FALSE;
      fields_context.list_rest_allowed := TRUE;
      fields_context.list_rest_encountered := FALSE;

      field_names_list := NIL;
      number_of_fields := 0;

      clp$scan_non_space_lexical_unit (parse);
      IF parse.unit.kind = clc$lex_end_of_line THEN
        get_next_line;
      IFEND;

      WHILE TRUE DO
        CASE parse.unit.kind OF
        = clc$lex_name =
          ;
        = clc$lex_long_name =
          osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                status);
          EXIT evaluate_type_expression;
        ELSE
          osp$set_status_abnormal ('CL', cle$expecting_record_field_name, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT evaluate_type_expression;
        CASEND;

        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        IF name = 'RECEND' THEN
          IF number_of_fields = 0 THEN
            osp$set_status_abnormal ('CL', cle$no_record_fields, '', status);
            EXIT evaluate_type_expression;
          IFEND;
          record_qualifier^.number_of_fields := number_of_fields;
          clp$scan_non_space_lexical_unit (parse);
          RETURN;
        IFEND;

        IF fields_context.list_rest_encountered THEN
          osp$set_status_abnormal ('CL', cle$improper_use_of_list_rest, '', status);
          EXIT evaluate_type_expression;
        IFEND;

        current_field_name := field_names_list;
        WHILE current_field_name <> NIL DO
          IF name = current_field_name^.name^ THEN
            osp$set_status_abnormal ('CL', cle$duplicate_field_name, name, status);
            EXIT evaluate_type_expression;
          IFEND;
          current_field_name := current_field_name^.previous;
        WHILEND;

        NEXT field_specification IN work_area;
        IF field_specification = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          EXIT evaluate_type_expression;
        IFEND;

        number_of_fields := number_of_fields + 1;
        field_specification^.name := name;
        field_specification^.requirement := clc$required_field;
        field_specification^.type_specification_size := 0;

        PUSH current_field_name;
        current_field_name^.previous := field_names_list;
        current_field_name^.name := ^field_specification^.name;
        field_names_list := current_field_name;

        clp$scan_non_space_lexical_unit (parse);
        IF parse.unit.kind = clc$lex_end_of_line THEN
          get_next_line;
        IFEND;
        IF parse.unit.kind <> clc$lex_colon THEN
          osp$set_status_abnormal ('CL', cle$expecting_after_field_name, field_specification^.name, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT evaluate_type_expression;
        IFEND;
        clp$scan_non_space_lexical_unit (parse);
        IF parse.unit.kind = clc$lex_end_of_line THEN
          get_next_line;
        IFEND;

        evaluate_type_expression (osc$null_name, get_line, parse, fields_context,
              symbolic_qualifiers_work_area, work_area, field_type_specification, status);
        IF NOT status.normal THEN
          EXIT evaluate_type_expression;
        IFEND;
*IF NOT $true(osv$unix)
        field_specification^.type_specification_size := #SIZE (field_type_specification^);
*ELSE
        field_specification^.type_specification_size := #SIZE (field_type_specification^);
{       field_specification^.type_specification_size :=
{             ((3 + #SIZE (field_type_specification^)) DIV 4) * 4;
*IFEND

        previous_unit_is_end_of_line := parse.unit.kind = clc$lex_end_of_line;
        IF previous_unit_is_end_of_line THEN
          get_next_line;
        IFEND;

        IF parse.unit.kind = clc$lex_equal THEN
          previous_unit_is_end_of_line := FALSE;
          evaluate_field_requirement;
        IFEND;

        CASE parse.unit.kind OF
        = clc$lex_comma, clc$lex_semicolon =
          clp$scan_non_space_lexical_unit (parse);
          IF parse.unit.kind = clc$lex_end_of_line THEN
            get_next_line;
          IFEND;
        = clc$lex_end_of_line =
          get_next_line;
        ELSE
          IF NOT previous_unit_is_end_of_line THEN
            osp$set_status_abnormal ('CL', cle$expecting_after_field_spec, field_specification^.name, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT evaluate_type_expression;
          IFEND;
        CASEND;
      WHILEND;

    PROCEND evaluate_record_type;
?? TITLE := 'evaluate_string_type', EJECT ??

    PROCEDURE [INLINE] evaluate_string_type;

      VAR
        ignore_qualifier_present: boolean,
        ignore_range_present: boolean,
        max_size: integer,
        min_size: integer,
        string_qualifier: ^clt$string_type_qualifier,
        symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier;


      NEXT string_qualifier IN work_area;
      IF string_qualifier = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT evaluate_type_expression;
      IFEND;
      init_symbolic_subrange_qual (symbolic_subrange_qualifier);

      clp$scan_non_space_lexical_unit (parse);

      string_qualifier^.literal := FALSE;
      IF parse.unit.kind = clc$lex_name THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        IF name = 'LITERAL' THEN
          string_qualifier^.literal := TRUE;
          clp$scan_non_space_lexical_unit (parse);
        IFEND;
      IFEND;

      evaluate_subrange_qualifier (0, clc$max_string_size, cle$string_size_out_of_range,
            cle$min_string_size_gt_max, 0, symbolic_subrange_qualifier, min_size, max_size,
            ignore_range_present, ignore_qualifier_present);
      string_qualifier^.min_string_size := min_size;
      string_qualifier^.max_string_size := max_size;

    PROCEND evaluate_string_type;
?? TITLE := 'evaluate_subrange_qualifier', EJECT ??

    PROCEDURE evaluate_subrange_qualifier
      (    nominal_low: integer;
           nominal_high: integer;
           out_of_range: ost$status_condition_code;
           low_greater_than_high: ost$status_condition_code;
           high_omitted: ost$status_condition_code;
           symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier;
       VAR actual_low: integer;
       VAR actual_high: integer;
       VAR range_present: boolean;
       VAR qualifier_present: boolean);

?? NEWTITLE := 'save_subrange_expression', EJECT ??

      PROCEDURE save_subrange_expression
        (VAR size: clt$expression_text_size);

        VAR
          start_index: clt$string_index,
          text: ^clt$expression_text;


        start_index := parse.unit_index;
        clp$scan_unnested_rel_lex_unit (parse);
        size := parse.previous_non_space_unit_index + parse.previous_non_space_unit.size - start_index;

        NEXT text: [size] IN symbolic_qualifiers_work_area;
        IF text = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          EXIT evaluate_type_expression;
        IFEND;
        text^ := parse.text^ (start_index, size);

        IF parse.unit_is_space THEN
          clp$scan_non_space_lexical_unit (parse);
        IFEND;

      PROCEND save_subrange_expression;
?? OLDTITLE, EJECT ??

      VAR
        generic_type_name: clt$type_name,
        result_integer: clt$integer;


      actual_low := nominal_low;
      actual_high := nominal_high;
      range_present := FALSE;

      IF parse.unit_is_space THEN
        clp$scan_non_space_lexical_unit (parse);
      IFEND;

      CASE parse.unit.kind OF
      = clc$lex_equal, clc$lex_comma, clc$lex_semicolon, clc$lex_end_of_line, clc$lex_right_parenthesis =
        qualifier_present := FALSE;
        RETURN;
      ELSE
        IF parse.unit_index >= parse.index_limit THEN
          qualifier_present := FALSE;
          RETURN;
        IFEND;
        IF NOT parse.previous_unit_is_space THEN
          #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.previous_non_space_unit_index,
                parse.previous_non_space_unit.size), generic_type_name);
          osp$set_status_abnormal ('CL', cle$missing_spaces_after, generic_type_name, status);
          EXIT evaluate_type_expression;
        IFEND;
        qualifier_present := TRUE;
      CASEND;

      IF symbolic_qualifiers_work_area <> NIL THEN
        save_subrange_expression (symbolic_subrange_qualifier^.low_text_size);
      ELSE
        clp$evaluate_integer_expression (nominal_low, nominal_high, work_area, parse, result_integer, status);
        IF NOT status.normal THEN
          IF status.condition = cle$integer_out_of_range THEN
            status.condition := out_of_range;
          IFEND;
          EXIT evaluate_type_expression;
        IFEND;
        actual_low := result_integer.value;
      IFEND;

      IF parse.unit.kind <> clc$lex_ellipsis THEN
        IF high_omitted <> 0 THEN
          osp$set_status_abnormal ('CL', high_omitted, '', status);
          EXIT evaluate_type_expression;
        IFEND;
        actual_high := actual_low;
        RETURN;
      IFEND;

      range_present := TRUE;
      clp$scan_non_space_lexical_unit (parse);

      IF symbolic_qualifiers_work_area <> NIL THEN
        save_subrange_expression (symbolic_subrange_qualifier^.high_text_size);
      ELSE
        clp$evaluate_integer_expression (nominal_low, nominal_high, work_area, parse, result_integer, status);
        IF NOT status.normal THEN
          IF status.condition = cle$integer_out_of_range THEN
            status.condition := out_of_range;
          IFEND;
          EXIT evaluate_type_expression;
        IFEND;
        actual_high := result_integer.value;
      IFEND;

      IF actual_low > actual_high THEN
        osp$set_status_abnormal ('CL', low_greater_than_high, '', status);
        EXIT evaluate_type_expression;
      IFEND;

    PROCEND evaluate_subrange_qualifier;
?? TITLE := 'evaluate_union_type', EJECT ??

    PROCEDURE evaluate_union_type;

      VAR
        member_type_specification: ^clt$type_specification,
        name: ost$name,
        type_specification_size: ^clt$type_specification_size,
        union_default_radix: 2 .. 16,
*IF NOT $true(osv$unix)
        union_qualifier: ^clt$union_type_qualifier;
*ELSE
        union_qualifier: ^clt$union_type_qualifier_v2;
*IFEND

?? NEWTITLE := 'merge_member_type', EJECT ??

      PROCEDURE [INLINE] merge_member_type;

        VAR
          integer_qualifier: ^clt$integer_type_qualifier,
*IF NOT $true(osv$unix)
          member_union_qualifier: ^clt$union_type_qualifier,
*ELSE
          member_union_qualifier: ^clt$union_type_qualifier_v2,
*IFEND
          real_qualifier: ^clt$real_type_qualifier,
          string_qualifier: ^clt$string_type_qualifier,
          type_header: ^clt$type_specification_header,
          type_header_name: ^clt$type_name_reference;


        NEXT type_header IN member_type_specification;
        NEXT type_header_name: [type_header^.name_size] IN member_type_specification;
        CASE type_header^.kind OF

        = clc$boolean_type, clc$file_type, clc$status_type, clc$string_pattern_type =
          union_qualifier^.only_standard_types_in_union := union_qualifier^.only_standard_types_in_union AND
                (NOT (clc$name_type IN union_qualifier^.kinds));

        = clc$integer_type =
          NEXT integer_qualifier IN member_type_specification;
*IF NOT $true(osv$unix)
          IF (($clt$type_kinds [clc$integer_type, clc$real_type] * union_qualifier^.kinds) <>
                $clt$type_kinds []) AND (union_default_radix <> integer_qualifier^.default_radix) THEN
*ELSE
          IF (($clt$type_kinds_v2 [clc$integer_type, clc$real_type] * union_qualifier^.kinds) <>
                $clt$type_kinds_v2 []) AND (union_default_radix <> integer_qualifier^.default_radix) THEN
*IFEND
            osp$set_status_abnormal ('CL', cle$inconsistent_radix_in_union, '', status);
            EXIT evaluate_type_expression;
          IFEND;
          union_default_radix := integer_qualifier^.default_radix;

          { The integer type is standard provided its default radix is 10. }
          union_qualifier^.only_standard_types_in_union := union_qualifier^.only_standard_types_in_union AND
                (integer_qualifier^.default_radix = 10) AND (NOT (clc$name_type IN union_qualifier^.kinds));

        = clc$name_type =
          { The name type is standard provided that the file type is not already in the union.
          union_qualifier^.only_standard_types_in_union := union_qualifier^.only_standard_types_in_union AND
                (NOT (clc$file_type IN union_qualifier^.kinds));

        = clc$real_type =
          NEXT real_qualifier IN member_type_specification;
*IF NOT $true(osv$unix)
          IF (($clt$type_kinds [clc$integer_type, clc$real_type] * union_qualifier^.kinds) <>
                $clt$type_kinds []) AND (union_default_radix <> 10) THEN
*ELSE
          IF (($clt$type_kinds_v2 [clc$integer_type, clc$real_type] * union_qualifier^.kinds) <>
                $clt$type_kinds_v2 []) AND (union_default_radix <> 10) THEN
*IFEND
            osp$set_status_abnormal ('CL', cle$inconsistent_radix_in_union, '', status);
            EXIT evaluate_type_expression;
          IFEND;
          union_default_radix := 10;
          union_qualifier^.only_standard_types_in_union := union_qualifier^.only_standard_types_in_union AND
                (NOT (clc$name_type IN union_qualifier^.kinds));

        = clc$string_type =
          NEXT string_qualifier IN member_type_specification;
          { The string type is standard provided the literal qualifier was not present. }
          union_qualifier^.only_standard_types_in_union := union_qualifier^.only_standard_types_in_union AND
                (NOT string_qualifier^.literal) AND (NOT (clc$name_type IN union_qualifier^.kinds));

        = clc$union_type =
          NEXT member_union_qualifier IN member_type_specification;
          union_qualifier^.only_standard_types_in_union := union_qualifier^.only_standard_types_in_union AND
                member_union_qualifier^.only_standard_types_in_union;

          union_qualifier^.kinds := union_qualifier^.kinds + member_union_qualifier^.kinds;

        ELSE
          union_qualifier^.only_standard_types_in_union := FALSE;
        CASEND;

*IF NOT $true(osv$unix)
        union_qualifier^.kinds := union_qualifier^.kinds + $clt$type_kinds [type_header^.kind];
*ELSE
        union_qualifier^.kinds := union_qualifier^.kinds + $clt$type_kinds_v2 [type_header^.kind];
*IFEND
        RESET member_type_specification;
        union_qualifier^.number_of_members := union_qualifier^.number_of_members + 1;

      PROCEND merge_member_type;
?? OLDTITLE, EJECT ??

      VAR
        members_context: clt$declaration_context;


      NEXT union_qualifier IN work_area;
      IF union_qualifier = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT evaluate_type_expression;
      IFEND;

      union_default_radix := 10;
      union_qualifier^.number_of_members := 0;

      clp$scan_non_space_lexical_unit (parse);
      CASE parse.unit.kind OF
      = clc$lex_end_of_line, clc$lex_equal, clc$lex_right_parenthesis, clc$lex_semicolon =
*IF NOT $true(osv$unix)
        union_qualifier^.kinds := -$clt$type_kinds [];
*ELSE
        union_qualifier^.kinds := -$clt$type_kinds_v2 [];
*IFEND
        union_qualifier^.only_standard_types_in_union := FALSE;
        RETURN;
      = clc$lex_name =
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        IF name <> 'OF' THEN
          osp$set_status_abnormal ('CL', cle$expecting_of_for_any, name, status);
          EXIT evaluate_type_expression;
        IFEND;
*IF NOT $true(osv$unix)
        union_qualifier^.kinds := $clt$type_kinds [];
*ELSE
        union_qualifier^.kinds := $clt$type_kinds_v2 [];
*IFEND
        union_qualifier^.only_standard_types_in_union := TRUE;
      = clc$lex_long_name =
        osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
              status);
        EXIT evaluate_type_expression;
      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_of_for_any, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        EXIT evaluate_type_expression;
      CASEND;

      clp$scan_non_space_lexical_unit (parse);
      IF parse.unit.kind = clc$lex_end_of_line THEN
        get_next_line;
      IFEND;

      members_context.kind := context.kind;
      members_context.identifier := context.identifier;
      members_context.unspecified_type_allowed := FALSE;
      members_context.list_rest_allowed := FALSE;
      members_context.list_rest_encountered := FALSE;

      WHILE TRUE DO
        IF parse.unit.kind = clc$lex_name THEN
          #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
          IF name = 'ANYEND' THEN
            IF union_qualifier^.number_of_members = 0 THEN
              osp$set_status_abnormal ('CL', cle$no_union_members, '', status);
              EXIT evaluate_type_expression;
            IFEND;
            clp$scan_non_space_lexical_unit (parse);
            RETURN;
          IFEND;
        IFEND;

        NEXT type_specification_size IN work_area;
        IF type_specification_size = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          EXIT evaluate_type_expression;
        IFEND;

        evaluate_type_expression (osc$null_name, get_line, parse, members_context,
              symbolic_qualifiers_work_area, work_area, member_type_specification, status);
        IF NOT status.normal THEN
          EXIT evaluate_type_expression;
        IFEND;
*IF NOT $true(osv$unix)
        type_specification_size^ := #SIZE (member_type_specification^);
*ELSE
        type_specification_size^ := #SIZE (member_type_specification^);
{       type_specification_size^ := ((3 + #SIZE (member_type_specification^)) DIV 4) * 4;
*IFEND

        merge_member_type;

        CASE parse.unit.kind OF
        = clc$lex_comma, clc$lex_semicolon =
          clp$scan_non_space_lexical_unit (parse);
          IF parse.unit.kind = clc$lex_end_of_line THEN
            get_next_line;
          IFEND;
        = clc$lex_end_of_line =
          get_next_line;
        ELSE
          osp$set_status_abnormal ('CL', cle$expecting_after_member_spec, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT evaluate_type_expression;
        CASEND;
      WHILEND;

    PROCEND evaluate_union_type;
?? TITLE := 'get_next_line', EJECT ??

    PROCEDURE [INLINE] get_next_line;

      VAR
        end_of_input: boolean;


      IF get_line = NIL THEN
        osp$set_status_abnormal ('CL', cle$eoi_in_declaration, context.identifier, status);
        EXIT evaluate_type_expression;
      IFEND;

      get_line^ (parse, end_of_input, status);

      IF NOT status.normal THEN
        EXIT evaluate_type_expression;
      ELSEIF end_of_input THEN
        osp$set_status_abnormal ('CL', cle$eoi_in_declaration, context.identifier, status);
        EXIT evaluate_type_expression;
      IFEND;
      clp$scan_non_space_lexical_unit (parse);

    PROCEND get_next_line;
?? TITLE := 'init_symbolic_subrange_qual', EJECT ??

    PROCEDURE [INLINE] init_symbolic_subrange_qual
      (VAR symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier);


      IF symbolic_qualifiers_work_area <> NIL THEN
        NEXT symbolic_subrange_qualifier IN symbolic_qualifiers_work_area;
        IF symbolic_subrange_qualifier = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          EXIT evaluate_type_expression;
        IFEND;
        symbolic_subrange_qualifier^.low_text_size := 0;
        symbolic_subrange_qualifier^.high_text_size := 0;
      ELSE
        symbolic_subrange_qualifier := NIL;
      IFEND;

    PROCEND init_symbolic_subrange_qual;
?? OLDTITLE, EJECT ??

    VAR
*IF $true(osv$unix)
      i: clt$type_kind,
      kludge_type_specification: ^ array [*] of cell,
*IFEND
      defined_type_specification: ^clt$type_specification,
      generic_type_descriptor: ^clt$generic_type_descriptor,
      temp_type_specification: ^clt$type_specification,
      type_header: ^clt$type_specification_header,
      type_header_name: ^clt$type_name_reference,
      type_specification_size: clt$type_specification_size;


    status.normal := TRUE;
    type_specification := NIL;

    NEXT type_header IN work_area;
    IF type_header = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;
    type_header^.version := clc$declaration_version;
    type_header^.name_size := clp$trimmed_string_size (type_name);
    IF type_header^.name_size > 0 THEN
      NEXT type_header_name: [type_header^.name_size] IN work_area;
      IF type_header = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
      type_header_name^ := type_name;
    IFEND;

    IF parse.unit.kind <> clc$lex_name THEN
      osp$set_status_abnormal ('CL', cle$expecting_type_expression, '', status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      RETURN;
    IFEND;

    #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
    check_for_generic_type (name, parse.unit.size, generic_type_descriptor);

    IF generic_type_descriptor = NIL THEN
      RESET work_area TO type_header;

      check_for_defined_type (name, defined_type_specification);
      IF defined_type_specification = NIL THEN
        osp$set_status_abnormal ('CL', cle$expecting_type_expression, name, status);
        RETURN;
      IFEND;

*IF NOT $true(osv$unix)
      type_specification_size := #SIZE (defined_type_specification^);
*ELSE
      type_specification_size :=
            ((3 + #SIZE (defined_type_specification^)) DIV 4) * 4;
*IFEND
      PUSH temp_type_specification: [[REP type_specification_size OF cell]];
      temp_type_specification^ := defined_type_specification^;
      RESET work_area TO type_header;
      NEXT type_specification: [[REP type_specification_size OF cell]] IN work_area;
      IF type_specification = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
      type_specification^ := temp_type_specification^;
      RETURN;
    IFEND;

    type_header^.kind := generic_type_descriptor^.kind;

    IF type_name = clv$type_kind_names [type_header^.kind] THEN
      RESET work_area TO type_header_name;
      type_header^.name_size := 0;
    IFEND;

    CASE type_header^.kind OF
    = clc$application_type =
      evaluate_application_type;
    = clc$array_type =
      evaluate_array_type;
    = clc$date_time_type =
      evaluate_date_time_type (generic_type_descriptor^.date_and_or_time);
    = clc$integer_type =
      evaluate_integer_type;
    = clc$keyword_type =
      evaluate_keyword_type;
    = clc$list_type =
      evaluate_list_type;
    = clc$name_type =
      evaluate_name_type;
    = clc$range_type =
      evaluate_range_type;
*IF NOT $true(osv$unix)
    = clc$real_type =
      evaluate_real_type;
*IFEND
    = clc$record_type =
      evaluate_record_type;
    = clc$string_type =
      evaluate_string_type;
    = clc$union_type =
      evaluate_union_type;
    ELSE
      clp$scan_non_space_lexical_unit (parse);
    CASEND;

    type_specification_size := i#current_sequence_position (work_area);
    RESET work_area TO type_header;
    type_specification_size := type_specification_size - i#current_sequence_position (work_area);
*IF $true(osv$unix)
    NEXT kludge_type_specification: [1 .. type_specification_size] IN work_area;
    type_specification := #SEQ (kludge_type_specification^);
*ELSE
    NEXT type_specification: [[REP type_specification_size OF cell]] IN work_area;
*IFEND
    RESET type_specification;

  PROCEND evaluate_type_expression;

MODEND clm$generate_pdt_and_type;
*DECK DECK=CLM$GET_JOB_PARAMETERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Get Job Parameters for Pre-validation' ??
MODULE clm$get_job_parameters;

{
{ PURPOSE:
{   This module contains the procedure that is responsible for obtaining the parameters from the login
{   command in a file that has been submitted for processing as a batch job.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amv$nil_file_identifier
*copyc cle$ecc_command_processing
*copyc clt$file_contents
*copyc clt$parameter_list_text
*copyc clt$parameter_list_text_size
*copyc jmt$job_system_label
*copyc osd$virtual_address
*copyc ost$caller_identifier
*copyc ost$status
?? POP ??
*copyc clp$access_command_file
*copyc clp$close_command_file
*copyc clp$get_command_line
*copyc clp$get_login_parameters
*copyc clp$parse_command
*copyc clp$pop_input_stack
*copyc clp$pop_parameters
*copyc clp$push_input_file_block
*copyc clp$push_sub_parameters_block
*copyc clp$scan_any_lexical_unit
*copyc clp$scan_non_space_lexical_unit
*copyc clp$scan_unnested_cmnd_lex_unit
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal

?? TITLE := 'clp$get_job_parameters', EJECT ??

  PROCEDURE [XDCL] clp$get_job_parameters
    (    submitter_ring: ost$valid_ring;
         submitted_file_reference: fst$file_reference;
     VAR job_system_label: {input, output} jmt$job_system_label;
     VAR login_command_in_file: boolean;
     VAR status: ost$status);

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

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

      VAR
        ignore_status: ost$status;


      clp$pop_input_stack (input_block, ignore_status);
      clp$close_command_file (file_id, opened_executable_file, ignore_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      caller_id: ost$caller_identifier,
      can_be_echoed: boolean,
      command_name: clt$name,
      command_parse: clt$parse_state,
      device_class: rmt$device_class,
      empty_command: boolean,
      end_of_input: boolean,
      escaped_command: boolean,
      form: clt$command_reference_form,
      file_has_fap: boolean,
      file_id: amt$file_identifier,
      ignore_can_be_echoed: boolean,
      ignore_command_ref_parse: clt$parse_state,
      ignore_file: clt$file,
      ignore_file_contents: clt$file_contents,
      ignore_ring_attributes: amt$ring_attributes,
      ignore_sequence: ^SEQ ( * ),
      ignore_util_command_list_entry: ^clt$command_list_entry,
      input_block: ^clt$block,
      label: ost$name,
      line_layout: clt$line_layout,
      local_status: ost$status,
      opened_executable_file: boolean,
      parameter_list: ^record
        size: clt$parameter_list_text_size,
        text: clt$parameter_list_text,
      recend,
      parse: clt$parse_state,
      path_handle_name: fst$path_handle_name,
      prompting_requested: boolean,
      separator: clt$lexical_unit_kind;


    status.normal := TRUE;

    #CALLER_ID (caller_id);
    IF submitter_ring > caller_id.ring THEN
      caller_id.ring := submitter_ring;
    IFEND;

    file_id := amv$nil_file_identifier;
    #SPOIL (file_id);
    login_command_in_file := TRUE;
    input_block := NIL;
    #SPOIL (input_block);
    osp$establish_block_exit_hndlr (^abort_handler);

  /get_job_parameters/
    BEGIN
      clp$access_command_file (clc$submit_job, caller_id.ring, submitted_file_reference, file_id,
            ignore_sequence, opened_executable_file, ignore_can_be_echoed, line_layout, ignore_file_contents,
            ignore_ring_attributes, file_has_fap, device_class, path_handle_name, status);
      IF NOT status.normal THEN
        EXIT /get_job_parameters/;
      IFEND;
      clp$push_input_file_block (path_handle_name, file_id, osc$null_name, '', can_be_echoed, line_layout,
            device_class, file_has_fap, TRUE, input_block);

    /find_command/
      WHILE TRUE DO
        empty_command := TRUE;
        clp$get_command_line (parse, end_of_input, status);
        IF (NOT status.normal) OR end_of_input THEN
          EXIT /find_command/;
        IFEND;
        IF parse.unit.kind = clc$lex_beginning_of_line THEN
          clp$scan_any_lexical_unit (parse);
        IFEND;
        REPEAT
          command_parse := parse;
          clp$scan_unnested_cmnd_lex_unit (parse);
          command_parse.index_limit := parse.unit_index;
          clp$parse_command (command_parse, prompting_requested, escaped_command, label,
                ignore_command_ref_parse, ignore_file, form, command_name, ignore_util_command_list_entry,
                separator, empty_command, status);
          IF (NOT status.normal) OR (NOT empty_command) THEN
            EXIT /find_command/;
          IFEND;
          WHILE parse.unit.kind = clc$lex_semicolon DO
            clp$scan_non_space_lexical_unit (parse);
          WHILEND;
        UNTIL parse.unit.kind = clc$lex_end_of_line;
      WHILEND /find_command/;

      IF status.normal AND (NOT empty_command) AND (NOT prompting_requested) AND (NOT escaped_command) AND
            (label = osc$null_name) AND ((form = clc$name_only_command_ref) OR
            (form = clc$system_command_ref)) AND (command_name.value = 'LOGIN') AND
            (separator <> clc$lex_equal) THEN
        login_command_in_file := TRUE;

        clp$close_command_file (file_id, opened_executable_file, status);

        PUSH parameter_list: [command_parse.index_limit - command_parse.unit_index];
        parameter_list^.size := command_parse.index_limit - command_parse.unit_index;
        parameter_list^.text := command_parse.text^ (command_parse.unit_index, parameter_list^.size);

        clp$pop_input_stack (input_block, local_status);
        IF (NOT status.normal) OR (NOT local_status.normal) THEN
          IF status.normal THEN
            status := local_status;
          IFEND;
          EXIT /get_job_parameters/;
        IFEND;

        clp$push_sub_parameters_block ({ lookup_functions_and_variables } FALSE);
        clp$get_login_parameters (#SEQ (parameter_list^) ^, job_system_label, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal ('CL', cle$bad_or_missing_login_in_job, path_handle_name, status);
          EXIT /get_job_parameters/;
        IFEND;

        clp$pop_parameters (local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;

      ELSE
        login_command_in_file := FALSE;
        osp$set_status_abnormal ('CL', cle$bad_or_missing_login_in_job, path_handle_name, status);
        clp$close_command_file (file_id, opened_executable_file, local_status);
        clp$pop_input_stack (input_block, local_status);
      IFEND;
    END /get_job_parameters/;

    osp$disestablish_cond_handler;

  PROCEND clp$get_job_parameters;

MODEND clm$get_job_parameters;
*DECK DECK=CLM$HELP_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : HELP Command' ??
MODULE clm$help_command;

{
{ PURPOSE:
{   This module contains the processor for the HELP command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc cle$ecc_utilities
*copyc clt$command_processor
*copyc clt$path_name
*copyc ost$status
?? POP ??
*copyc clp$begin_utility
*copyc clp$change_variable
*copyc clp$convert_string_to_name
*copyc clp$create_procedure_variable
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$get_utility_attributes
*copyc clp$include_command
*copyc clp$scan_expression
*copyc clp$trimmed_string_size
*copyc osp$get_status_condition_name

  CONST
    clc$command_previous_status = 'CLV$COMMAND_PREV_STATUS        ',
    clc$help_command_utility = 'CLU$HELP_COMMAND_UTILITY       ',
    subject_prefix = 'U$',
    subject_prefix_size = 2;

{
{ Check whether the text of the application value is simply a name.  If it
{ is, use the string form of that name as the evaluated result.  If it isn't,
{ evaluate the application value text as a string expression. If it isn't a
{ string expression, then pass the text back as a string.
{
{ Examples:     Specifying                Yields
{               ----------                ------
{
{               'some subject'            some subject
{               $value                    $VALUE
{               $value(p)                 "the value of parameter P"
{               %1                        %1
{

?? TITLE := 'clp$_help', EJECT ??

  PROCEDURE [XDCL] clp$_help
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$help) help, h (
{   subject, s: any of
{       data_name
{       string
{       application
{     anyend = $optional
{   manual, m: file = $system.manuals.scl
{   list, l: file = manual_pages
{   status: status = $optional
{   clv$previous_status: (BY_NAME, HIDDEN) status = $previous_status
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$application_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (19),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (12),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
      type5: record
        header: clt$type_specification_header,
        default_value: string (16),
      recend,
    recend := [
    [1,
    [88, 7, 11, 10, 15, 14, 537],
    clc$command, 8, 5, 0, 0, 1, 0, 0, 'OSM$HELP'], [
    ['CLV$PREVIOUS_STATUS            ',clc$nominal_entry, 5],
    ['L                              ',clc$abbreviation_entry, 3],
    ['LIST                           ',clc$nominal_entry, 3],
    ['M                              ',clc$abbreviation_entry, 2],
    ['MANUAL                         ',clc$nominal_entry, 2],
    ['S                              ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['SUBJECT                        ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 39, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 19],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 12],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [1, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 16]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$application_type, clc$data_name_type, clc$string_type],
    FALSE, 3],
    3, [[1, 0, clc$data_name_type]],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
    4, [[1, 0, clc$application_type], [FALSE]]
    ],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$system.manuals.scl'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    'manual_pages'],
{ PARAMETER 4
    [[1, 0, clc$status_type]],
{ PARAMETER 5
    [[1, 0, clc$status_type],
    '$previous_status']];

?? POP ??

  CONST
    p$subject = 1,
    p$manual = 2,
    p$list = 3,
    p$status = 4,
    p$clv$previous_status = 5;

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

{ TYPE
{   status_type = status
{ TYPEND

?? PUSH (LISTEXT := ON) ??

    VAR
      status_type: [STATIC, READ, cls$declaration_section] record
        header: clt$type_specification_header,
      recend := [[1, 0, clc$status_type]];

?? POP ??

    VAR
      added_subject_length: integer,
      begin_utility_attributes: array [1 .. 1] of clt$utility_attribute,
      command_line: string (256),
      command_line_length: integer,
      executing_utility: boolean,
      get_utility_attributes: array [1 .. 2] of clt$utility_attribute,
      local_status: ost$status,
      manual_file_name: clt$path_name,
      manual_file_name_size: 1 .. clc$max_path_name_size,
      previous_status_condition_name: ost$status_condition_name,
      subject_string: ^clt$string_value,
      utility_subject_string: string (osc$max_name_size + subject_prefix_size);

    subject_string := NIL;

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

    IF pvt [p$subject].specified THEN
      IF pvt [p$subject].value^.kind = clc$application THEN
        subject_string := pvt [p$subject].value^.application_value;
      ELSEIF pvt [p$subject].value^.kind = clc$data_name THEN
        subject_string := ^pvt [p$subject].value^.data_name_value;
      ELSE {string value}
        subject_string := pvt [p$subject].value^.string_value;
      IFEND;
    IFEND;

    executing_utility := FALSE;

{
{  The following hierarchy is used to build the EXPLAIN command:
{
{ 1.  If the MANUAL parameter is specified, then execute the EXPLAIN
{     command with the other values of the HELP command.
{
{ 2.  If the SUBJECT parameter is specified and the user is executing a
{     utility, use the utility attribute online manual name for the MANUAL
{     parameter on the EXPLAIN command.  If the user is not executing a
{     utility, use the MANUAL value from the HELP command.
{
{ 3.  If $previous_status was abnormal then the diagnostic messages manual
{     is entered, with the subject equaling the condition name of the
{     previous status.
{
{     Create a utility block via CLP$PUSH_UTILITY and then create the SCL
{     variable CLV$COMMAND_PREVIOUS_STATUS for the diagnostic messages
{     manual.  This variable is used within the manual to report a message
{     that is not listed in the messages manual.
{
{ 4.  If the user is currently executing a utility, then execute the
{     EXPLAIN command using the default MANUAL parameter unless the online
{     manual name utility attribute is non-blank and a value of
{     'U$'//utility-name for the SUBJECT.
{
{ 5.  If the user is either executing an asynchronous task or not
{     executing a utility, then execute the EXPLAIN command using the
{     default MANUAL and SUBJECT parameters.
{

  /build_explain_command/
    BEGIN

      IF pvt [p$manual].specified THEN
        STRINGREP (command_line, command_line_length, 'explain manual=', pvt [p$manual].value^.file_value^,
              ' list=', pvt [p$list].value^.file_value^);
        EXIT /build_explain_command/;
      IFEND;

      IF (pvt [p$subject].specified) OR (pvt [p$clv$previous_status].value^.status_value^.normal) THEN
        get_utility_attributes [1].key := clc$utility_name;
        get_utility_attributes [2].key := clc$utility_online_manual;
        clp$get_utility_attributes (osc$null_name, get_utility_attributes, status);
        IF status.normal THEN

{ User is currently executing a utility. Use the default online manual or
{ the utility attribute online manual name.

          IF get_utility_attributes [2].online_manual_name = osc$null_name THEN
            manual_file_name := pvt [p$manual].value^.file_value^;
            manual_file_name_size := clp$trimmed_string_size (pvt [p$manual].value^.file_value^);
          ELSE
            manual_file_name := get_utility_attributes [2].online_manual_name;
            manual_file_name_size := clp$trimmed_string_size (get_utility_attributes [2].online_manual_name);
          IFEND;

{ The help SUBJECT is either what the user specified or 'U$' concatenated
{ with the utility name.

          IF NOT pvt [p$subject].specified THEN
            utility_subject_string := subject_prefix;
            utility_subject_string (subject_prefix_size + 1, * ) := get_utility_attributes
                  [1].name (1, clp$trimmed_string_size (get_utility_attributes [1].name));
            subject_string := ^utility_subject_string;
          IFEND;
          STRINGREP (command_line, command_line_length, 'explain manual=',
                manual_file_name (1, manual_file_name_size), ' list=', pvt [p$list].value^.file_value^);
          EXIT /build_explain_command/;

{ User is not currently executing a utility.

        ELSEIF status.condition = cle$unknown_utility THEN
          STRINGREP (command_line, command_line_length, 'explain manual=', pvt [p$manual].value^.file_value^,
                ' list=', pvt [p$list].value^.file_value^);
          EXIT /build_explain_command/;

{ An unexpected error occurred in the clp$get_utilty_attributes request.

        ELSE
          RETURN;
        IFEND;
      IFEND;

{ $PREVIOUS_STATUS was abnormal - use the MESSAGES manual to explain the
{ previous status message.

      osp$get_status_condition_name (pvt [p$clv$previous_status].value^.status_value^.condition,
            previous_status_condition_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      begin_utility_attributes [1].key := clc$utility_command_search_mode;
      begin_utility_attributes [1].command_search_mode := clc$global_command_search;
      clp$begin_utility (clc$help_command_utility, begin_utility_attributes, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      executing_utility := TRUE;
      clp$create_procedure_variable (clc$command_previous_status, clc$xdcl_scope, clc$read_write,
            clc$immediate_evaluation, #SEQ (status_type), NIL, status);
      IF NOT status.normal THEN
        clp$end_utility (clc$help_command_utility, local_status);
        RETURN;
      IFEND;
      clp$change_variable (clc$command_previous_status, pvt [p$clv$previous_status].value, status);
      IF NOT status.normal THEN
        clp$end_utility (clc$help_command_utility, local_status);
        RETURN;
      IFEND;
      STRINGREP (command_line, command_line_length,
            'explain manual=$system.manuals.messages $child=help subject=''',
            previous_status_condition_name (1, clp$trimmed_string_size (previous_status_condition_name)),
            '''', ' list=', pvt [p$list].value^.file_value^);

    END /build_explain_command/;

{ Add SUBJECT parameter if necessary.

    IF subject_string <> NIL THEN
      STRINGREP (command_line (command_line_length, * ), added_subject_length, ' subject=''',
            subject_string^ (1, clp$trimmed_string_size (subject_string^)), '''');
      command_line_length := command_line_length + added_subject_length - 1;
    IFEND;

    clp$include_command (command_line (1, command_line_length), FALSE, status);

    IF executing_utility THEN
      clp$end_utility (clc$help_command_utility, local_status);
      IF (NOT local_status.normal) AND status.normal THEN
        status := local_status;
      IFEND;
    IFEND;

  PROCEND clp$_help;

MODEND clm$help_command;

*DECK DECK=CLM$HELP_MESSAGE_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Help Message Services' ??
MODULE clm$help_message_interfaces;

{
{ PURPOSE:
{   This module contains routines to search for help modules and information
{   within them.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc cle$ecc_expression_result
*copyc cle$ecc_mt_generator
*copyc cst$menu_class
*copyc cst$menu_list
*copyc llt$object_library_header
*copyc osc$max_system_message_modules
*copyc osd$virtual_address
*copyc ose$message_gen_exceptions
*copyc ost$application_menu_name
*copyc ost$caller_identifier
*copyc ost$help_module
*copyc ost$message_template
*copyc ost$message_template_kind
*copyc ost$message_template_module
*copyc ost$mtm_condition_codes
*copyc ost$mtm_condition_names
*copyc ost$mtm_header
*copyc ost$name
*copyc ost$natural_language
*copyc ost$online_manual_name
*copyc ost$status
*copyc ost$status_condition_code
*copyc ost$status_condition_name
*copyc ost$status_severity
*copyc ost$string
*copyc osv$lower_to_upper
*copyc osv$system_message_modules
*copyc pmt$program_name
?? POP ??
*copyc clp$extract_msg_module_contents
*copyc clp$find_command_list
*copyc clp$search_for_help_module
*copyc clp$search_help_module
*copyc clp$search_module_for_code
*copyc clp$search_module_for_name
*copyc clp$trimmed_string_size
*copyc clp$validate_name
*copyc osp$convert_to_status_severity
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$find_natural_language
*copyc osp$format_help_message
*copyc osp$set_status_abnormal
*copyc osv$initial_exception_context
*copyc pmp$get_library_dictionaries
*copyc pmp$log
?? TITLE := 'osp$find_help_module', EJECT ??
*copy osh$find_help_module

  PROCEDURE [XDCL, #GATE] osp$find_help_module
    (    seed_name: pmt$program_name;
     VAR help_module: ^ost$help_module;
     VAR online_manual_name: ost$online_manual_name;
     VAR natural_language: ost$natural_language;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      command_list: ^clt$command_list,
      current_entry: ^clt$command_list_entry,
      entry_found: boolean,
      i: integer,
      ignore_cmnd_list_found_in_task: boolean,
      local_library_name: amt$local_file_name,
      local_status: ost$status,
      module_index: 1 .. osc$max_system_message_modules,
      module_name: string (2 * osc$max_name_size + 1),
      module_name_length: integer,
      preferred_language: ost$natural_language,
      search_name: ost$name,
      selected_language: ^ost$natural_language,
      system_help_library_searched: boolean;

?? TITLE := 'search_for_help_module', EJECT ??

    PROCEDURE [INLINE] search_for_help_module;

      VAR
        context: ^ost$ecp_exception_context;

      context := NIL;

      REPEAT
        clp$search_for_help_module (caller_id.ring, search_name, local_library_name, entry_found, help_module,
              natural_language, online_manual_name, local_status);
        IF osp$file_access_condition (local_status) THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_file_reference;
            context^.file.file_reference := ^local_library_name;
          IFEND;
          context^.condition_status := local_status;
          osp$enforce_exception_policies (context^);
          local_status := context^.condition_status;
        IFEND;
      UNTIL local_status.normal OR (NOT osp$file_access_condition (local_status)) OR (NOT context^.wait);

    PROCEND search_for_help_module;

    status.normal := TRUE;
    local_status.normal := TRUE;
    #CALLER_ID (caller_id);
    help_module := NIL;
    online_manual_name := osc$null_name;
    natural_language := osc$null_name;
    osp$find_natural_language (selected_language);
    preferred_language := selected_language^;
    entry_found := FALSE;

  /search/
    WHILE TRUE DO
      STRINGREP (module_name, module_name_length, seed_name (1, clp$trimmed_string_size (seed_name)), '$',
            preferred_language (1, clp$trimmed_string_size (preferred_language)));

      #TRANSLATE (osv$lower_to_upper, module_name (1, module_name_length), search_name);

      clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);
      current_entry := command_list^.entries.first_entry;

      WHILE current_entry <> NIL DO
        CASE current_entry^.kind OF

        = clc$library_commands =
          IF current_entry^.library_contains.help_modules AND NOT current_entry^.unaccessible_entry THEN
            local_library_name := current_entry^.local_file_name;
            search_for_help_module;
            IF (NOT local_status.normal) OR entry_found THEN
              EXIT /search/;
            IFEND;
          IFEND;

        = clc$system_commands =
          IF (command_list^.system_command_library_lfn <> osc$null_name) AND
                command_list^.system_library_contains.help_modules THEN
            local_library_name := command_list^.system_command_library_lfn;
            search_for_help_module;
            IF (NOT local_status.normal) OR entry_found THEN
              EXIT /search/;
            IFEND;
          IFEND;

        = clc$sub_commands =
          IF current_entry^.utility_info^.auxiliary_libraries <> NIL THEN
            FOR i := 1 TO UPPERBOUND (current_entry^.utility_info^.auxiliary_libraries^) DO
              IF current_entry^.utility_info^.auxiliary_libraries^ [i].contains.help_modules THEN
                local_library_name := current_entry^.utility_info^.auxiliary_libraries^ [i].name;
                search_for_help_module;
                IF NOT local_status.normal THEN
                  local_status.normal := TRUE;
                ELSEIF entry_found THEN
                  EXIT /search/;
                IFEND;
              IFEND;
            FOREND;
          IFEND;

        ELSE
          ;
        CASEND;

        current_entry := current_entry^.next_entry;
      WHILEND;
      IF preferred_language = osc$default_natural_language THEN
        EXIT /search/;
      IFEND;
      preferred_language := osc$default_natural_language;
    WHILEND /search/;

    IF NOT local_status.normal THEN
      status := local_status;
    ELSEIF NOT entry_found THEN

{ Search table of system message modules defined in osm$message_module_pointers }

      #TRANSLATE (osv$lower_to_upper, seed_name, search_name);
      FOR module_index := 1 TO osc$max_system_message_modules DO
        IF search_name = osv$system_message_modules [module_index].module_name THEN
          help_module := osv$system_message_modules [module_index].module_pointer_p^;
          RETURN;
        IFEND;
      FOREND;
    IFEND;

  PROCEND osp$find_help_module;
?? TITLE := 'osp$find_brief_help_message', EJECT ??
*copy osh$find_brief_help_message

  PROCEDURE [XDCL, #GATE] osp$find_brief_help_message
    (    help_module: ^ost$help_module;
     VAR message_template: ^ost$message_template;
     VAR status: ost$status);

    VAR
      local_help_module: ^ost$help_module,
      ignore_condition_codes: ^ost$mtm_condition_codes,
      names: ^ost$mtm_condition_names,
      blank_name: clt$parameter_name,
      kind: ost$message_template_kind,
      header: ^ost$mtm_header;


    status.normal := TRUE;
    local_help_module := help_module;
    message_template := NIL;
    ignore_condition_codes := NIL;
    names := NIL;
    blank_name := osc$null_name;
    kind := osc$brief_help;

    IF help_module = NIL THEN
      RETURN;
    IFEND;

    clp$extract_msg_module_contents (local_help_module, header, ignore_condition_codes, names);
    IF header = NIL THEN
      osp$set_status_abnormal ('CL', cle$bad_help_module, '', status);
      RETURN;
    IFEND;

    clp$search_help_module (blank_name, kind, names, local_help_module, message_template);

  PROCEND osp$find_brief_help_message;
?? TITLE := 'osp$find_full_help_message', EJECT ??
*copy osh$find_full_help_message

  PROCEDURE [XDCL, #GATE] osp$find_full_help_message
    (    help_module: ^ost$help_module;
     VAR message_template: ^ost$message_template;
     VAR status: ost$status);

    VAR
      local_help_module: ^ost$help_module,
      ignore_condition_codes: ^ost$mtm_condition_codes,
      names: ^ost$mtm_condition_names,
      header: ^ost$mtm_header,
      blank_name: clt$parameter_name,
      kind: ost$message_template_kind;


    status.normal := TRUE;
    local_help_module := help_module;
    message_template := NIL;
    ignore_condition_codes := NIL;
    names := NIL;
    blank_name := osc$null_name;
    kind := osc$full_help;

    IF help_module = NIL THEN
      RETURN;
    IFEND;

    clp$extract_msg_module_contents (local_help_module, header, ignore_condition_codes, names);
    IF header = NIL THEN
      osp$set_status_abnormal ('CL', cle$bad_help_module, '', status);
      RETURN;
    IFEND;

    clp$search_help_module (blank_name, kind, names, local_help_module, message_template);

  PROCEND osp$find_full_help_message;
?? TITLE := 'osp$find_parameter_prompt', EJECT ??
*copy osh$find_parameter_prompt

  PROCEDURE [XDCL, #GATE] osp$find_parameter_prompt
    (    help_module: ^ost$help_module;
         parameter_name: clt$parameter_name;
     VAR prompt_template: ^ost$message_template;
     VAR status: ost$status);

    VAR
      local_help_module: ^ost$help_module,
      ignore_condition_codes: ^ost$mtm_condition_codes,
      names: ^ost$mtm_condition_names,
      header: ^ost$mtm_header,
      kind: ost$message_template_kind;


    status.normal := TRUE;
    local_help_module := help_module;
    prompt_template := NIL;
    ignore_condition_codes := NIL;
    names := NIL;
    kind := osc$parameter_prompt;

    IF help_module = NIL THEN
      RETURN;
    IFEND;

    clp$extract_msg_module_contents (local_help_module, header, ignore_condition_codes, names);
    IF header = NIL THEN
      osp$set_status_abnormal ('CL', cle$bad_help_module, '', status);
      RETURN;
    IFEND;

    clp$search_help_module (parameter_name, kind, names, local_help_module, prompt_template);

  PROCEND osp$find_parameter_prompt;
?? TITLE := 'osp$find_param_assist_prompt', EJECT ??
*copy osh$find_param_assist_prompt

  PROCEDURE [XDCL, #GATE] osp$find_param_assist_prompt
    (    help_module: ^ost$help_module;
         parameter_name: clt$parameter_name;
     VAR prompt_template: ^ost$message_template;
     VAR status: ost$status);

    VAR
      local_help_module: ^ost$help_module,
      ignore_condition_codes: ^ost$mtm_condition_codes,
      names: ^ost$mtm_condition_names,
      header: ^ost$mtm_header,
      kind: ost$message_template_kind;


    status.normal := TRUE;
    local_help_module := help_module;
    prompt_template := NIL;
    ignore_condition_codes := NIL;
    names := NIL;
    kind := osc$parameter_assistance_prompt;

    IF help_module = NIL THEN
      RETURN;
    IFEND;

    clp$extract_msg_module_contents (local_help_module, header, ignore_condition_codes, names);
    IF header = NIL THEN
      osp$set_status_abnormal ('CL', cle$bad_help_module, '', status);
      RETURN;
    IFEND;

    clp$search_help_module (parameter_name, kind, names, local_help_module, prompt_template);

  PROCEND osp$find_param_assist_prompt;
?? TITLE := 'osp$find_parameter_help_message', EJECT ??
*copy osh$find_parameter_help_message

  PROCEDURE [XDCL, #GATE] osp$find_parameter_help_message
    (    help_module: ^ost$help_module;
         parameter_name: clt$parameter_name;
     VAR message_template: ^ost$message_template;
     VAR status: ost$status);

    VAR
      local_help_module: ^ost$help_module,
      ignore_condition_codes: ^ost$mtm_condition_codes,
      names: ^ost$mtm_condition_names,
      header: ^ost$mtm_header,
      kind: ost$message_template_kind;


    status.normal := TRUE;
    local_help_module := help_module;
    message_template := NIL;
    ignore_condition_codes := NIL;
    names := NIL;
    kind := osc$parameter_help;

    IF help_module = NIL THEN
      RETURN;
    IFEND;

    clp$extract_msg_module_contents (local_help_module, header, ignore_condition_codes, names);
    IF header = NIL THEN
      osp$set_status_abnormal ('CL', cle$bad_help_module, '', status);
      RETURN;
    IFEND;

    clp$search_help_module (parameter_name, kind, names, local_help_module, message_template);

  PROCEND osp$find_parameter_help_message;
?? TITLE := 'osp$find_application_menu', EJECT ??
*copy osh$find_application_menu

  PROCEDURE [XDCL, #GATE] osp$find_application_menu
    (    help_module: ^ost$help_module;
         menu_name: ost$application_menu_name;
     VAR menu_classes: cst$menu_class;
     VAR menu_items: cst$menu_list;
     VAR status: ost$status);

    VAR
      local_help_module: ^ost$help_module,
      ignore_condition_codes: ^ost$mtm_condition_codes,
      names: ^ost$mtm_condition_names,
      entry_found: boolean,
      header: ^ost$mtm_header,
      index: ost$status_condition_code,
      lower: 0 .. osc$max_status_condition_code + 1,
      upper: -1 .. osc$max_status_condition_code + 1,
      upper_case_name: ost$name,
      kind: ost$message_template_kind,
      temp: integer,
      menu_header_ptr: ^ost$mtm_menu_header;


    status.normal := TRUE;
    local_help_module := help_module;
    menu_classes := NIL;
    menu_items := NIL;
    ignore_condition_codes := NIL;
    names := NIL;
    kind := osc$application_menu;
    entry_found := FALSE;

    IF local_help_module = NIL THEN
      RETURN;
    IFEND;

  /find_menu/
    BEGIN
      clp$extract_msg_module_contents (local_help_module, header, ignore_condition_codes, names);
      IF header = NIL THEN
        EXIT /find_menu/;
      IFEND;

      #TRANSLATE (osv$lower_to_upper, menu_name, upper_case_name);

      lower := 0;
      upper := UPPERBOUND (names^);

    /search_help_module/

      WHILE lower <= upper DO
        temp := lower + upper;
        index := temp DIV 2;
        IF names^ [index].name = upper_case_name THEN
          IF names^ [index].kind = kind THEN
            menu_header_ptr := #PTR (names^ [index].menu_header, local_help_module^);
            entry_found := TRUE;
            EXIT /search_help_module/;
          ELSEIF names^ [index].kind > kind THEN
            upper := index - 1;
          ELSE
            lower := index + 1;
          IFEND;
        ELSEIF names^ [index].name > upper_case_name THEN
          upper := index - 1;
        ELSE
          lower := index + 1;
        IFEND;
      WHILEND /search_help_module/;

      IF entry_found THEN
        RESET local_help_module TO menu_header_ptr;
        NEXT menu_header_ptr IN local_help_module;
        IF (menu_header_ptr = NIL) OR (menu_header_ptr^.number_of_classes < 0) OR
              (menu_header_ptr^.number_of_classes > csc$max_classes) OR
              (menu_header_ptr^.number_of_menu_items < 0) OR (menu_header_ptr^.number_of_menu_items >
              csc$max_menu_items) THEN
          EXIT /find_menu/;
        IFEND;
        NEXT menu_classes: [1 .. menu_header_ptr^.number_of_classes] IN local_help_module;
        IF menu_classes = NIL THEN
          EXIT /find_menu/;
        IFEND;
        NEXT menu_items: [1 .. menu_header_ptr^.number_of_menu_items] IN local_help_module;
        IF menu_classes = NIL THEN
          EXIT /find_menu/;
        IFEND;
      IFEND;
      RETURN;
    END /find_menu/;
    osp$set_status_abnormal ('CL', cle$bad_help_module, '', status);

  PROCEND osp$find_application_menu;
?? TITLE := 'osp$find_help_module_in_library', EJECT ??
*copy osh$find_help_module_in_library

  PROCEDURE [XDCL, #GATE] osp$find_help_module_in_library
    (    object_library: ^SEQ ( * );
         seed_name: pmt$program_name;
     VAR help_module: ^ost$help_module;
     VAR online_manual_name: ost$online_manual_name;
     VAR natural_language: ost$natural_language;
     VAR status: ost$status);

?? NEWTITLE := 'search_help_dictionary', EJECT ??

    PROCEDURE [INLINE] search_help_dictionary
      (    search_name: ost$name);

      VAR
        lower: 1 .. llc$max_help_modules_in_library + 1,
        upper: 0 .. llc$max_help_modules_in_library,
        member_header: ^llt$library_member_header,
        header: ^ost$mtm_header,
        temp: integer,
        index: llt$help_module_index,
        ignore_condition_codes: ^ost$mtm_condition_codes,
        ignore_condition_names: ^ost$mtm_condition_names;


      found := FALSE;

      IF help_module_dictionary = NIL THEN
        RETURN;
      IFEND;

      lower := 1;
      upper := UPPERBOUND (help_module_dictionary^);

      WHILE (lower <= upper) DO
        temp := lower + upper;
        index := temp DIV 2;
        IF help_module_dictionary^ [index].name = search_name THEN
          found := TRUE;
          member_header := #PTR (help_module_dictionary^ [index].help_header, object_library^);
          help_module := #PTR (member_header^.member, object_library^);
          RESET help_module;
          clp$extract_msg_module_contents (help_module, header, ignore_condition_codes,
                ignore_condition_names);
          natural_language := header^.language;
          online_manual_name := header^.online_manual_name;
          RETURN;
        ELSEIF help_module_dictionary^ [index].name > search_name THEN
          upper := index - 1;
        ELSE
          lower := index + 1;
        IFEND;
      WHILEND;

    PROCEND search_help_dictionary;
?? TITLE := 'search_message_dictionary', EJECT ??

    PROCEDURE [INLINE] search_message_dictionary
      (    search_name: ost$name);

      VAR
        lower: 1 .. llc$max_message_modules_in_lib + 1,
        upper: 0 .. llc$max_message_modules_in_lib,
        member_header: ^llt$library_member_header,
        header: ^ost$mtm_header,
        temp: integer,
        index: llt$message_module_index,
        ignore_condition_codes: ^ost$mtm_condition_codes,
        ignore_condition_names: ^ost$mtm_condition_names;


      found := FALSE;

      IF message_module_dictionary = NIL THEN
        RETURN;
      IFEND;

      lower := 1;
      upper := UPPERBOUND (message_module_dictionary^);

      WHILE (lower <= upper) DO
        temp := lower + upper;
        index := temp DIV 2;
        IF message_module_dictionary^ [index].name = search_name THEN
          found := TRUE;
          member_header := #PTR (message_module_dictionary^ [index].message_header, object_library^);
          help_module := #PTR (member_header^.member, object_library^);
          RESET help_module;
          clp$extract_msg_module_contents (help_module, header, ignore_condition_codes,
                ignore_condition_names);
          natural_language := header^.language;
          online_manual_name := header^.online_manual_name;
          RETURN;
        ELSEIF message_module_dictionary^ [index].name > search_name THEN
          upper := index - 1;
        ELSE
          lower := index + 1;
        IFEND;
      WHILEND;

    PROCEND search_message_dictionary;
?? TITLE := 'search_dictionaries', EJECT ??

    PROCEDURE [INLINE] search_dictionaries;

      VAR
        module_name: string (osc$max_string_size),
        module_name_length: integer,
        search_name: ost$name;


      STRINGREP (module_name, module_name_length, seed_name (1, clp$trimmed_string_size (seed_name)), '$',
            preferred_language (1, clp$trimmed_string_size (preferred_language)));

      #TRANSLATE (osv$lower_to_upper, module_name (1, module_name_length), search_name);

      search_help_dictionary (search_name);
      IF found THEN
        EXIT osp$find_help_module_in_library;
      IFEND;

      search_message_dictionary (search_name);
      IF found THEN
        EXIT osp$find_help_module_in_library;
      IFEND;

    PROCEND search_dictionaries;
?? OLDTITLE, EJECT ??

    VAR
      dictionaries: llt$library_dictionary_pointers,
      preferred_language: ost$natural_language,
      selected_language: ^ost$natural_language,
      found: boolean,
      message_module_dictionary: ^llt$message_module_dictionary,
      help_module_dictionary: ^llt$help_module_dictionary;


    status.normal := TRUE;
    help_module := NIL;
    found := FALSE;
    online_manual_name := osc$null_name;
    natural_language := osc$null_name;
    osp$find_natural_language (selected_language);
    preferred_language := selected_language^;

    pmp$get_library_dictionaries (object_library, dictionaries, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    help_module_dictionary := dictionaries.help_module_dictionary;
    message_module_dictionary := dictionaries.message_module_dictionary;

    search_dictionaries;
    IF preferred_language <> osc$default_natural_language THEN
      preferred_language := osc$default_natural_language;
      search_dictionaries;
    IFEND;

  PROCEND osp$find_help_module_in_library;
?? TITLE := 'osp$find_status_message_by_code', EJECT ??
*copy osh$find_status_message_by_code

  PROCEDURE [XDCL, #GATE] osp$find_status_message_by_code
    (    help_module: ^ost$help_module;
         condition_code: ost$status_condition_code;
     VAR condition_name: ost$status_condition_name;
     VAR condition_severity: ost$status_severity;
     VAR message_template: ^ost$message_template;
     VAR status: ost$status);

    VAR
      ignore_language: ost$natural_language,
      ignore_entry_found: boolean,
      message_module_severity: ost$message_module_severity,
      saved_default: boolean;


    status.normal := TRUE;
    saved_default := FALSE;
    condition_name := 'UNKNOWN_CONDITION';
    condition_severity := osc$error_status;
    message_template := NIL;

    IF help_module = NIL THEN
      RETURN;
    IFEND;

    clp$search_module_for_code (help_module, condition_code, ignore_language, condition_name,
          message_module_severity, message_template, ignore_entry_found, status);

    condition_severity := osp$convert_to_status_severity (message_module_severity);

  PROCEND osp$find_status_message_by_code;
?? TITLE := 'osp$find_status_message_by_name', EJECT ??
*copy osh$find_status_message_by_name

  PROCEDURE [XDCL, #GATE] osp$find_status_message_by_name
    (    help_module: ^ost$help_module;
         condition_name: ost$status_condition_name;
     VAR condition_code: ost$status_condition_code;
     VAR condition_severity: ost$status_severity;
     VAR message_template: ^ost$message_template;
     VAR status: ost$status);

    VAR
      ignore_language: ost$natural_language,
      ignore_entry_found: boolean,
      message_module_severity: ost$message_module_severity,
      saved_default: boolean;


    status.normal := TRUE;
    saved_default := FALSE;
    condition_code := 0;
    condition_severity := osc$error_status;
    message_template := NIL;

    IF help_module = NIL THEN
      RETURN;
    IFEND;

    clp$search_module_for_name (help_module, condition_name, ignore_language, condition_code,
          message_module_severity, message_template, ignore_entry_found, status);

    condition_severity := osp$convert_to_status_severity (message_module_severity);

  PROCEND osp$find_status_message_by_name;
?? TITLE := 'osp$get_full_help_message', EJECT ??
*copy osh$get_full_help_message

  PROCEDURE [XDCL, #GATE] osp$get_full_help_message
    (    seed_name: pmt$program_name;
         message_parameters: ^ost$message_parameters;
         max_message_line: ost$max_status_message_line;
     VAR message: ost$status_message;
     VAR status: ost$status);

    VAR
      help_module: ^ost$help_module,
      message_template: ^ost$message_template,
      natural_language: ost$natural_language,
      online_manual_name: ost$online_manual_name;

    osp$find_help_module (seed_name, help_module, online_manual_name, natural_language, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$find_full_help_message (help_module, message_template, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$format_help_message (message_template, message_parameters, max_message_line, message, status);

  PROCEND osp$get_full_help_message;
?? TITLE := 'osp$get_parameter_prompt', EJECT ??
*copy osh$get_parameter_prompt

  PROCEDURE [XDCL, #GATE] osp$get_parameter_prompt
    (    seed_name: pmt$program_name;
         parameter_name: clt$parameter_name;
         message_parameters: ^ost$message_parameters;
         max_message_line: ost$max_status_message_line;
     VAR message: ost$status_message;
     VAR status: ost$status);

    VAR
      help_module: ^ost$help_module,
      message_template: ^ost$message_template,
      natural_language: ost$natural_language,
      online_manual_name: ost$online_manual_name;

    osp$find_help_module (seed_name, help_module, online_manual_name, natural_language, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$find_parameter_prompt (help_module, parameter_name, message_template, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$format_help_message (message_template, message_parameters, max_message_line, message, status);

  PROCEND osp$get_parameter_prompt;
?? TITLE := 'osp$get_parameter_help_message', EJECT ??
*copy osh$get_parameter_help_message

  PROCEDURE [XDCL, #GATE] osp$get_parameter_help_message
    (    seed_name: pmt$program_name;
         parameter_name: clt$parameter_name;
         message_parameters: ^ost$message_parameters;
         max_message_line: ost$max_status_message_line;
     VAR message: ost$status_message;
     VAR status: ost$status);

    VAR
      help_module: ^ost$help_module,
      message_template: ^ost$message_template,
      natural_language: ost$natural_language,
      online_manual_name: ost$online_manual_name;

    osp$find_help_module (seed_name, help_module, online_manual_name, natural_language, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$find_parameter_help_message (help_module, parameter_name, message_template, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$format_help_message (message_template, message_parameters, max_message_line, message, status);

  PROCEND osp$get_parameter_help_message;
?? TITLE := 'clp$find_help_module', EJECT ??
*copy clh$find_help_module

  PROCEDURE [XDCL, #GATE] clp$find_help_module
    (    seed_name: pmt$program_name;
         natural_language: ost$natural_language;
     VAR help_module: ^ost$help_module;
     VAR online_manual_name: ost$online_manual_name;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      command_list: ^clt$command_list,
      current_entry: ^clt$command_list_entry,
      entry_found: boolean,
      i: integer,
      ignore_cmnd_list_found_in_task: boolean,
      ignore_natural_language: ost$natural_language,
      local_library_name: amt$local_file_name,
      module_name: string (2 * osc$max_name_size + 1),
      module_name_length: integer,
      preferred_language: ost$natural_language,
      search_name: ost$name,
      selected_language: ^ost$natural_language,
      valid_language: boolean;

?? TITLE := 'search_for_help_module', EJECT ??

    PROCEDURE [INLINE] search_for_help_module;

      VAR
        context: ^ost$ecp_exception_context;

      context := NIL;

      REPEAT
        clp$search_for_help_module (caller_id.ring, search_name, local_library_name, entry_found, help_module,
              ignore_natural_language, online_manual_name, status);
        IF osp$file_access_condition (status) THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_file_reference;
            context^.file.file_reference := ^local_library_name;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    PROCEND search_for_help_module;

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    help_module := NIL;
    online_manual_name := osc$null_name;
    entry_found := FALSE;

    clp$validate_name (natural_language, preferred_language, valid_language);
    IF NOT valid_language THEN
      osp$set_status_abnormal ('CL', ose$bad_natural_language, natural_language, status);
      RETURN;
    IFEND;

  /search/
    BEGIN
      STRINGREP (module_name, module_name_length, seed_name (1, clp$trimmed_string_size (seed_name)), '$',
            preferred_language (1, clp$trimmed_string_size (preferred_language)));

      #TRANSLATE (osv$lower_to_upper, module_name (1, module_name_length), search_name);

      clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);
      current_entry := command_list^.entries.first_entry;

      WHILE current_entry <> NIL DO
        CASE current_entry^.kind OF

        = clc$library_commands =
          IF current_entry^.library_contains.help_modules AND NOT current_entry^.unaccessible_entry THEN
            local_library_name := current_entry^.local_file_name;
            search_for_help_module;
            IF (NOT status.normal) OR entry_found THEN
              EXIT /search/;
            IFEND;
          IFEND;

        = clc$system_commands =
          IF (command_list^.system_command_library_lfn <> osc$null_name) AND
                command_list^.system_library_contains.help_modules THEN
            local_library_name := command_list^.system_command_library_lfn;
            search_for_help_module;
            IF (NOT status.normal) OR entry_found THEN
              EXIT /search/;
            IFEND;
          IFEND;

        = clc$sub_commands =
          IF current_entry^.utility_info^.auxiliary_libraries <> NIL THEN
            FOR i := 1 TO UPPERBOUND (current_entry^.utility_info^.auxiliary_libraries^) DO
              IF current_entry^.utility_info^.auxiliary_libraries^ [i].contains.help_modules THEN
                local_library_name := current_entry^.utility_info^.auxiliary_libraries^ [i].name;
                search_for_help_module;
                IF NOT status.normal THEN
                  status.normal := TRUE;
                ELSEIF entry_found THEN
                  EXIT /search/;
                IFEND;
              IFEND;
            FOREND;
          IFEND;

        ELSE
          ;
        CASEND;

        current_entry := current_entry^.next_entry;
      WHILEND;
    END /search/;

  PROCEND clp$find_help_module;

MODEND clm$help_message_interfaces;
*DECK DECK=CLM$HELP_SUBJECT_AVS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : "Subject" Application Value Scanner' ??
MODULE clm$help_subject_avs;

{
{ PURPOSE:
{   This module contains an application value scanner for processing the
{   "subject" parameter of commands like HELP and EXPLAIN.  When the
{   "new types" feature is available this processor will no longer be
{   needed.
{

?? TITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc clt$application_value
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc clp$convert_string_to_name
*copyc clp$scan_expression
?? TITLE := 'clp$help_subject_avs', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$help_subject_avs
    (    avs_name: clt$application_value_name;
         avs_keyword_values: ^array [1 .. * ] of ost$name;
         avs_text: string ( * );
     VAR avs_value: clt$value;
     VAR status: ost$status);

    VAR
      name: clt$name,
      string_kind: clt$value_kind_specifier;

{
{ Check whether the text of the application value is simply a name.  If it
{ is, use the string form of that name as the evaluated result.  Otherwise
{ evaluate the application value text as a string expression.
{
{ Examples:     Specifying                Yields
{               ----------                ------
{
{               'some subject'            some subject
{               $value                    $VALUE
{               $value(p)                 "the value of parameter P"
{

    clp$convert_string_to_name (avs_text, name, status);
    IF status.normal THEN
      avs_value.kind := clc$string_value;
      avs_value.str.size := name.size;
      avs_value.str.value := name.value;
    ELSE
      string_kind.keyword_values := NIL;
      string_kind.kind := clc$string_value;
      string_kind.min_string_size := 0;
      string_kind.max_string_size := osc$max_string_size;
      clp$scan_expression (avs_text, string_kind, avs_value, status);
    IFEND;

  PROCEND clp$help_subject_avs;

MODEND clm$help_subject_avs;
*DECK DECK=CLM$INCLUDE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : INCLUDE Commands and Requests' ??
MODULE clm$include;

{
{ PURPOSE:
{   This module contains the command and program interfaces that initiate and terminate processing
{   of a file or line of commands.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc clc$command_cleanup_completed
*copyc clc$exiting_condition
*copyc clc$lexical_units_size_pad
*copyc cle$command_line_cancelled
*IFEND
*copyc cle$command_terminated
*copyc cle$ecc_command_processing
*copyc cle$ecc_utilities
*IF NOT $true(osv$unix)
*copyc cle$unable_to_call_util_dlg_mgr
*ELSE
*copyc cle$ecc_lexical
*copyc cle$not_supported
*copyc cle$parameters_displayed
*IFEND
*copyc cle$unexpected_call_to
*IF NOT $true(osv$unix)
*copyc clk$end_include
*copyc clk$end_scan_command_file
*copyc clk$execute_command
*copyc clk$include_file
*copyc clk$include_line
*copyc clk$scan_command_file
*copyc clk$scan_command_line
*copyc clt$async_command_parameters
*copyc clt$command_line
*IFEND
*copyc clt$command_line_index
*IF NOT $true(osv$unix)
*copyc clt$command_line_size
*copyc clt$parameter_list
*IFEND
*copyc clt$prompt
*IF NOT $true(osv$unix)
*copyc clt$prompt_string
*copyc clt$task_name
*copyc clt$task_name_reference
*ELSE
*copyc clt$utility_name
*copyc clt$utility_prompt
*copyc clt$when_condition
*IFEND
*copyc fst$file_reference
*IF NOT $true(osv$unix)
*copyc loc$task_services_library_name
*copyc ost$name
*copyc ost$status
*copyc pmt$task_id
*ELSE
*copyc fst$path
*copyc ost$status_severity
*IFEND
?? POP ??
*IF NOT $true(osv$unix)
*copyc amp$seek_direct
*IFEND
*copyc amv$nil_file_identifier
*IF NOT $true(osv$unix)
*copyc clp$change_variable
*copyc clp$convert_str_to_path_handle
*copyc clp$determine_when_condition
*copyc clp$echo_trace_information
*ELSE
*copyc clp$evaluate_file_reference
*IFEND
*copyc clp$evaluate_parameters
*IF NOT $true(osv$unix)
*copyc clp$execute_named_task
*copyc clp$execution_fault_handler_est
*copyc clp$find_connected_files
*copyc clp$find_current_block
*IFEND
*copyc clp$find_external_input_block
*copyc clp$find_input_block
*copyc clp$find_utility_block
*IF $true(osv$unix)
*copyc clp$free_heap
*IFEND
*copyc clp$get_command_line
*IF NOT $true(osv$unix)
*copyc clp$get_command_search_mode
*ELSE
*copyc clp$get_screen_mode
*IFEND
*copyc clp$get_work_area
*copyc clp$identify_lexical_units
*copyc clp$ignore_rest_of_file
*IF NOT $true(osv$unix)
*copyc clp$initialize_parse_state
*copyc clp$load_system_entry_point
*copyc clp$parse_command
*copyc clp$pop_block_stack
*IFEND
*copyc clp$pop_command_line
*copyc clp$pop_input
*copyc clp$pop_input_stack
*copyc clp$pop_terminated_blocks
*copyc clp$preprocess_command_line
*copyc clp$process_command
*IF NOT $true(osv$unix)
*copyc clp$process_command_fault
*copyc clp$process_execution_fault
*copyc clp$process_exit_condition
*copyc clp$process_when_cond_in_block
*IFEND
*copyc clp$push_command_line
*copyc clp$push_input
*IF NOT $true(osv$unix)
*copyc clp$push_input_line_block
*copyc clp$reset_input_position
*IFEND
*copyc clp$scan_any_lexical_unit
*copyc clp$scan_non_space_lexical_unit
*copyc clp$scan_unnested_cmnd_lex_unit
*copyc clp$set_command_kind
*copyc clp$set_include_processor_state
*copyc clp$set_input_line_finished
*copyc clp$set_input_line_parse
*IF NOT $true(osv$unix)
*copyc clp$set_input_line_position
*IFEND
*copyc clp$trimmed_string_size
*copyc clv$nil_block_handle
*copyc clv$standard_files
*IF NOT $true(osv$unix)
*copyc ifp$discard_suspended_output
*IFEND
*copyc osp$append_status_parameter
*IF NOT $true(osv$unix)
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*IFEND
*copyc osp$find_interaction_info
*copyc osp$generate_message
*IF NOT $true(osv$unix)
*copyc osp$generate_output_message
*IFEND
*copyc osp$get_status_severity
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*IF NOT $true(osv$unix)
*copyc osv$initial_exception_context
*IFEND
*copyc osv$lower_to_upper
*IF NOT $true(osv$unix)
*copyc pmp$cause_condition
*copyc pmp$cause_task_condition
*copyc pmp$change_term_error_level
*copyc pmp$continue_to_cause
*copyc pmp$load
*copyc pmp$pop_task_debug_mode
*copyc pmp$push_task_debug_mode
*copyc pmp$task_state
?? TITLE := 'clt$utility_dialog_manager', EJECT ??
*copyc clh$utility_dialog_manager
*copyc clt$utility_dialog_manager
*copyc clt$utility_dialog_info
?? SKIP := 2 ??

{
{ The following constants define the entry point names for the dynamically
{ loaded utility dialog managers.
{

  CONST
    clc$desktop_util_dialog_mgr = 'DEP$SCL_UTILITY_DIALOG_MGR     ',
    clc$screen_util_dialog_mgr = 'CLP$SCL_UTILITY_DIALOG_MGR     ';

?? SKIP := 2 ??

{
{ The following constant defines the name of the DEBUG utility.  DEBUG does not
{ use an "interactive include processor" but does provide its own screen
{ interface.  Therefore the standard utility dialog manager may not be invoked
{ for the DEBUG utility.
{

  CONST
    dbc$debug_utility_name = 'DEBUG                          ';

*ELSE
{
{ The following constant defines the name of the DEBUG utility.  DEBUG does not
{ use an "interactive include processor" but does provide its own screen
{ interface.  Therefore the standard utility dialog manager may not be invoked
{ for the DEBUG utility.
{

  CONST
    dbc$debug_utility_name = 'DEBUG                          ';

*copyc clp_process_shell_cmd
*copyc cyt$mips_signal_handler
*copyc osv$signal
*copyc osv$signal_status

?? TITLE := 'interactive', EJECT ??

  FUNCTION [INLINE] interactive (input_block: ^clt$block): boolean;

    interactive := (input_block <> NIL) AND
              (input_block^.input.kind = clc$file_input) AND input_block^.input.interactive_device;

  FUNCEND interactive;

*IFEND

?? TITLE := 'clp$read_command_file', EJECT ??

  PROCEDURE [XDCL] clp$read_command_file
    (    file: fst$file_reference;
         utility: clt$utility_name;
         prompt: clt$prompt;
         enable_echoing: boolean;
         initial_command: ^clt$command_line;
         continue_after_initial_command: boolean;
     VAR status: ost$status);

    VAR
*IF NOT $true(osv$unix)
      context: ^ost$ecp_exception_context,
*IFEND
      dialog_manager_name: pmt$program_name,
      end_input_block: ^clt$block,
      exit_status: ost$status,
      file_id: amt$file_identifier,
      handle_interactive_include: ^procedure,
*IF $true(osv$unix)
      handler_stat: boolean,
*IFEND
      input_block: ^clt$block,
      input_block_handle: clt$block_handle,
      interaction_information: ^clt$interaction_information,
      load_from_system: boolean,
      local_status: ^ost$status,
      opened_executable_file: boolean,
      severity: ost$status_severity;

*IF $true(osv$unix)
?? NEWTITLE := 'cleanup', EJECT ??

    PROCEDURE cleanup;

      IF input_block <> NIL THEN
        clp$pop_terminated_blocks (input_block, status);
      IFEND;
      clp$pop_input (FALSE, input_block_handle, file_id, opened_executable_file, ^status, exit_status);
      IF status.normal AND (NOT exit_status.normal) THEN
        status := exit_status;
      IFEND;

    PROCEND cleanup;

?? OLDTITLE ??
*IFEND
?? NEWTITLE := 'read_file_condition_handler', EJECT ??

    PROCEDURE read_file_condition_handler
*IF NOT $true(osv$unix)
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      CASE condition.selector OF
      = ifc$interactive_condition =
        IF (condition.interactive_condition = ifc$terminate_break) AND (input_block <> NIL) AND
              (input_block^.input.kind = clc$file_input) AND input_block^.input.interactive_device THEN
          RETURN;
        IFEND;
      = pmc$block_exit_processing =
        IF input_block <> NIL THEN
          clp$pop_terminated_blocks (input_block, status);
          clp$process_exit_condition (input_block, status);
        IFEND;
        clp$pop_input (FALSE, input_block_handle, file_id, opened_executable_file, ^status, exit_status);
        IF status.normal AND (NOT exit_status.normal) THEN
          status := exit_status;
        IFEND;
        RETURN;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
*ELSE
      (    signal_no: integer;
           code: integer;
           p_sigcontext: ^cyt$mips_sigcontext);



      CASE signal_no OF
      { pmc$block_exit_processing    -    block exit
      = -1 =
        cleanup;
        IF osc_sigint IN osv$signal THEN
          osv$signal := osv$signal - $ost$signals [osc_sigint];
          osv$signal_status.normal := TRUE;
        IFEND;
        RETURN;
      ELSE
        ;
      CASEND;
*IFEND

    PROCEND read_file_condition_handler;
?? TITLE := 'interactive_include_handler', EJECT ??

    PROCEDURE interactive_include_handler;

      VAR
*IF NOT $true(osv$unix)
        callers_save_area: ^ost$stack_frame_save_area,
        ignore_term_error_level: ost$status_severity,
        loaded_address: pmt$loaded_address,
*IFEND
        local_status: ost$status,
        original_term_error_level: ost$status_severity,
*IF NOT $true(osv$unix)
        utility_dialog_manager: clt$utility_dialog_manager,
*IFEND
        utility_include_processor: clt$utility_interactive_include;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'abort_handler', EJECT ??

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

        VAR
          ignore_status: ost$status;


        pmp$change_term_error_level (original_term_error_level, ignore_term_error_level, ignore_status);

      PROCEND abort_handler;
?? TITLE := 'invoke_condition_handler', EJECT ??

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


        IF (condition.selector = pmc$system_conditions) AND
              (($pmt$system_conditions [pmc$instruction_specification, pmc$address_specification,
              pmc$access_violation, pmc$environment_specification, pmc$invalid_segment_ring_0,
              pmc$out_call_in_return] * condition.system_conditions) <> $pmt$system_conditions []) AND
              (save_area^.minimum_save_area.a2_previous_save_area = callers_save_area) THEN
          CASE input_block^.associated_utility^.interactive_include_processor.call_method OF
          = clc$unspecified_call =
            osp$set_status_condition (cle$unable_to_call_util_dlg_mgr, status);
          = clc$linked_call =
            osp$set_status_condition (cle$unable_to_call_inc_procesor, status);
          ELSE
            osp$set_status_abnormal ('CL', cle$unable_to_call_inc_procesor,
                  input_block^.associated_utility^.interactive_include_processor.procedure_name, status);
          CASEND;
          EXIT clp$read_command_file;
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      PROCEND invoke_condition_handler;
?? OLDTITLE, EJECT ??
      VAR
        context: ^ost$ecp_exception_context;

      context := NIL;
*IFEND

      IF input_block^.associated_utility^.include_processor_active THEN
        osp$set_status_abnormal ('CL', cle$include_processor_active, utility, local_status);
        osp$generate_message (local_status, status);
        status.normal := TRUE;
        RETURN;
      IFEND;

      CASE input_block^.associated_utility^.interactive_include_processor.call_method OF

*IF NOT $true(osv$unix)
      = clc$unspecified_call =

{ Invoke the standard utility "dialog manager".

        loaded_address.kind := pmc$procedure_address;
        loaded_address.pointer_to_procedure := NIL;
        original_term_error_level := osc$fatal_status;
        #SPOIL (original_term_error_level);

        osp$establish_block_exit_hndlr (^abort_handler);

        pmp$change_term_error_level (osc$fatal_status, original_term_error_level, status);
        IF status.normal THEN
          IF load_from_system THEN
            REPEAT
              clp$load_system_entry_point (dialog_manager_name, pmc$procedure_address, loaded_address,
                    status);
              IF NOT status.normal THEN
                IF context = NIL THEN
                  PUSH context;
                  context^ := osv$initial_exception_context;
                IFEND;
                context^.condition_status := status;
                osp$enforce_exception_policies (context^);
                status := context^.condition_status;
              IFEND;
            UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
          ELSE
            pmp$load (dialog_manager_name, pmc$procedure_address, loaded_address, status);
          IFEND;
          IF NOT status.normal THEN
            loaded_address.pointer_to_procedure := NIL;
          IFEND;
          pmp$change_term_error_level (original_term_error_level, ignore_term_error_level, status);
        IFEND;

        osp$disestablish_cond_handler;

        IF (NOT status.normal) OR (loaded_address.pointer_to_procedure = NIL) THEN
          osp$set_status_abnormal ('CL', cle$unable_to_call_util_dlg_mgr, dialog_manager_name, status);
          RETURN;
        IFEND;

        #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, utility_dialog_manager);
        utility_include_processor := NIL;
*IFEND

      = clc$linked_call =

        utility_include_processor := input_block^.associated_utility^.interactive_include_processor.proc;

*IF NOT $true(osv$unix)
      = clc$unlinked_call =

        pmp$load (input_block^.associated_utility^.interactive_include_processor.procedure_name,
              pmc$procedure_address, loaded_address, status);

        IF NOT status.normal THEN
          osp$set_status_abnormal ('CL', cle$unable_to_call_inc_procesor,
                input_block^.associated_utility^.interactive_include_processor.procedure_name, status);
          EXIT clp$read_command_file;
        IFEND;

        #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, utility_include_processor);
*IFEND

      ELSE

{ Should never get here.

        osp$set_status_condition (cle$unable_to_call_inc_procesor, status);
        EXIT clp$read_command_file;
      CASEND;

      clp$set_include_processor_state (utility, TRUE, status);
      IF NOT status.normal THEN
        EXIT clp$read_command_file;
      IFEND;

*IF NOT $true(osv$unix)
      callers_save_area := #PREVIOUS_SAVE_AREA ();
      #SPOIL (callers_save_area);
      osp$establish_condition_handler (^invoke_condition_handler, FALSE);
*IFEND

      IF utility_include_processor <> NIL THEN
        utility_include_processor^ (interaction_information^.style, status);
*IF NOT $true(osv$unix)
      ELSE
        utility_dialog_manager^ (utility, ^input_block^.associated_utility^.command_environment.dialog_info,
              status);
*IFEND
      IFEND;

*IF NOT $true(osv$unix)
      osp$disestablish_cond_handler;
*IFEND

      clp$set_include_processor_state (utility, FALSE, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
      IF (NOT status.normal) OR input_block_finished (input_block) THEN
        EXIT clp$read_command_file;
      IFEND;

    PROCEND interactive_include_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    exit_status.normal := TRUE;
    input_block_handle := clv$nil_block_handle;
    file_id := amv$nil_file_identifier;
    #SPOIL (input_block_handle, file_id);
    input_block := NIL;
    handle_interactive_include := NIL;

*IF NOT $true(osv$unix)
    context := NIL;
    osp$establish_condition_handler (^read_file_condition_handler, TRUE);
*ELSE
{ Establish condition handler for block exit

    handler_stat := #establish_condition_handler (-1, ^read_file_condition_handler);
*IFEND

  /read_file/
    BEGIN

*IF NOT $true(osv$unix)
      REPEAT
        clp$push_input (file, utility, prompt, enable_echoing, FALSE, input_block_handle, file_id,
              opened_executable_file, status);
        IF NOT status.normal THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_file_reference;
            context^.file.file_reference := ^file;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
*ELSE
      clp$push_input (file, utility, prompt, enable_echoing, FALSE, input_block_handle, file_id,
            opened_executable_file, status);
*IFEND
      IF NOT status.normal THEN
        EXIT /read_file/;
      IFEND;
      clp$find_current_block (input_block);

      IF initial_command <> NIL THEN
*IF $true(osv$unix)

{ If we received a signal and we're interactive, then ignore the signal,
{ i.e. clear it and resume execution. Otherwise, get out and let the signal
{ be cleared by someone interactive (this will have to change for batch jobs??)
        IF (osc_sigint IN osv$signal) THEN
          IF NOT interactive (input_block) THEN
            EXIT /read_file/;
          IFEND;
          osv$signal := osv$signal - $ost$signals [osc_sigint];
          osv$signal_status.normal := TRUE;
        IFEND;

*IFEND
        clp$include_command (initial_command^, enable_echoing, status);
*IF $true(osv$unix)

{ If we received a signal and we're interactive, then ignore the signal,
{ i.e. clear it and resume execution. Otherwise, get out and let the signal
{ be cleared by someone interactive (this will have to change for batch jobs??)
        IF (osc_sigint IN osv$signal) THEN
          IF NOT interactive (input_block) THEN
            EXIT /read_file/;
          IFEND;
          osv$signal := osv$signal - $ost$signals [osc_sigint];
          osv$signal_status.normal := TRUE;
        IFEND;

*IFEND
        IF NOT status.normal THEN
          PUSH local_status;
          severity := osc$error_status;
          osp$get_status_severity (status.condition, severity, local_status^);
          IF (severity >= osc$error_status) AND ((input_block^.input.kind <> clc$file_input) OR
                (NOT input_block^.input.interactive_device)) THEN
            EXIT /read_file/;
*IF NOT $true(osv$unix)
          ELSEIF (input_block^.input.kind = clc$file_input) AND
                (input_block^.input.interactive_device OR (input_block^.input.local_file_name =
                clv$standard_files [clc$sf_command_file].path_handle_name)) THEN
*ELSE
          ELSEIF (input_block^.input.kind = clc$file_input) AND
                (input_block^.input.interactive_device) THEN
*IFEND
            osp$generate_message (status, local_status^);
            IF NOT local_status^.normal THEN
              EXIT /read_file/;
            IFEND;
            status.normal := TRUE;
          IFEND;
        IFEND;
        IF NOT continue_after_initial_command THEN
          EXIT /read_file/;
        IFEND;
      IFEND;

      IF input_block^.input.interactive_device AND (utility <> osc$null_name) AND
            (utility <> dbc$debug_utility_name) THEN
        osp$find_interaction_info (interaction_information);
        IF input_block^.associated_utility^.interactive_include_processor.call_method <>
              clc$unspecified_call THEN
          handle_interactive_include := ^interactive_include_handler;
*IF NOT $true(osv$unix)
        ELSEIF interaction_information^.extend_utility_interaction THEN
          CASE interaction_information^.style OF
          = osc$desktop_interaction =
            dialog_manager_name := clc$desktop_util_dialog_mgr;
            load_from_system := FALSE;
            handle_interactive_include := ^interactive_include_handler;
          = osc$screen_interaction =
            dialog_manager_name := clc$screen_util_dialog_mgr;
            load_from_system := TRUE;
            handle_interactive_include := ^interactive_include_handler;
          ELSE { osc$line_interaction }
            ;
          CASEND;
*IFEND
        IFEND;
      IFEND;

*IF $true(osv$unix)

{ If we received a signal and we're interactive, then ignore the signal,
{ i.e. clear it and resume execution. Otherwise, get out and let the signal
{ be cleared by someone interactive (this will have to change for batch jobs??)
        IF (osc_sigint IN osv$signal) THEN
          IF NOT interactive (input_block) THEN
            EXIT /read_file/;
          IFEND;
          osv$signal := osv$signal - $ost$signals [osc_sigint];
          osv$signal_status.normal := TRUE;
        IFEND;

*IFEND
      clp$process_command_file (input_block, handle_interactive_include, status);
*IF $true(osv$unix)

{ If we received a signal and we're interactive, then ignore the signal,
{ i.e. clear it and resume execution. Otherwise, get out and let the signal
{ be cleared by someone interactive (this will have to change for batch jobs??)
        IF (osc_sigint IN osv$signal) THEN
          IF NOT interactive (input_block) THEN
            EXIT /read_file/;
          IFEND;
          osv$signal := osv$signal - $ost$signals [osc_sigint];
          osv$signal_status.normal := TRUE;
        IFEND;

*IFEND
      IF status.normal AND (NOT input_block^.being_exited) THEN
        clp$find_current_block (end_input_block);
        IF end_input_block <> input_block THEN
          osp$set_status_abnormal ('CL', cle$unbalanced_block_structure, end_input_block^.kind_end_name,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, input_block^.kind_end_name, status);
        IFEND;
      IFEND;
    END /read_file/;

    IF input_block <> NIL THEN
      clp$pop_terminated_blocks (input_block, status);
*IF NOT $true(osv$unix)
      clp$process_exit_condition (input_block, status);
*IFEND
    IFEND;
    clp$pop_input (FALSE, input_block_handle, file_id, opened_executable_file, ^status, exit_status);
    IF status.normal AND (NOT exit_status.normal) THEN
      status := exit_status;
      #SPOIL (status);
    IFEND;

*IF NOT $true(osv$unix)
    osp$disestablish_cond_handler;
*ELSE
    handler_stat := #disestablish_condition_handler (-1);
*IFEND

  PROCEND clp$read_command_file;
?? TITLE := 'clp$include_file', EJECT ??
*copyc clh$include_file

  PROCEDURE [XDCL, #GATE] clp$include_file
    (    file: fst$file_reference;
         prompt: clt$prompt;
         utility: clt$utility_name;
     VAR status: ost$status);

    VAR
      block_in_current_task: boolean,
      prompt_string: clt$utility_prompt,
*IF $true(osv$unix)
      c_status: integer,
*IFEND
      translated_utility_name: clt$utility_name,
      utility_block: ^clt$block;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, 0, clk$include_file);
*IFEND

    status.normal := TRUE;
*IF $true(osv$unix)
    c_status := 0;
*IFEND

  /include_file/
    BEGIN
      #TRANSLATE (osv$lower_to_upper, utility, translated_utility_name);
      IF translated_utility_name <> osc$null_name THEN
        clp$find_utility_block (translated_utility_name, utility_block, block_in_current_task);
        IF (utility_block = NIL) OR (NOT (utility_block^.command_environment.command_level OR
              block_in_current_task)) THEN
          osp$set_status_abnormal ('CL', cle$unknown_utility, utility, status);
          EXIT /include_file/;
        IFEND;
        prompt_string := utility_block^.prompt;
      ELSE
        prompt_string.size := STRLENGTH (prompt);
        prompt_string.value := prompt (1, prompt_string.size);
      IFEND;

    clp$read_command_file (file, translated_utility_name, prompt_string.value (1, prompt_string.size), TRUE,
          NIL, FALSE, status);
    END /include_file/;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, 0, clk$include_file);
*ELSE
    IF (NOT status.normal) AND (status.condition <> 0) THEN
      c_status := status.condition;
    IFEND;

*IFEND

  PROCEND clp$include_file;
?? TITLE := 'clp$end_include', EJECT ??
*copyc clh$end_include

  PROCEDURE [XDCL, #GATE] clp$end_include
    (    utility: clt$utility_name;
     VAR status: ost$status);

    VAR
      translated_utility_name: clt$utility_name;


*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, 0, clk$end_include);
*IFEND

    status.normal := TRUE;

    #TRANSLATE (osv$lower_to_upper, utility, translated_utility_name);
    clp$ignore_rest_of_file (translated_utility_name, status);

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, 0, clk$end_include);
*IFEND

  PROCEND clp$end_include;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$get_include_ended', EJECT ??
*copyc clh$get_include_ended

  PROCEDURE [XDCL, #GATE] clp$get_include_ended
    (    utility: clt$utility_name;
     VAR include_ended: boolean;
     VAR status: ost$status);

    VAR
      input_block: ^clt$block,
      translated_utility_name: clt$utility_name;


    status.normal := TRUE;

    #TRANSLATE (osv$lower_to_upper, utility, translated_utility_name);
    clp$find_input_block (TRUE, input_block);
    IF (input_block = NIL) OR (input_block^.label <> translated_utility_name) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$get_include_ended', status);
      RETURN;
    IFEND;

    include_ended := input_block_finished (input_block);

  PROCEND clp$get_include_ended;
?? TITLE := 'clp$include_line', EJECT ??
*copyc clh$include_line

  PROCEDURE [XDCL, #GATE] clp$include_line
    (    statement_list: clt$command_line;
         enable_echoing: boolean;
         utility: clt$utility_name;
     VAR status: ost$status);

    CONST
      not_input_from_job_command_file = FALSE,
      not_input_origin_is_interactive = FALSE;

    VAR
      block_in_current_task: boolean,
      connected_files: ^clt$connected_files,
      edited_line: ^clt$command_line,
      end_input_block: ^clt$block,
      include_status: ost$status,
      input_block: ^clt$block,
      lexical_units: ^clt$lexical_units,
      lexical_work_area: ^clt$work_area,
      line_size: clt$command_line_size,
      pop_status: ost$status,
      translated_utility: clt$utility_name,
      utility_block: ^clt$block;

?? NEWTITLE := 'handle_condition', EJECT ??

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

      VAR
        condition_processed: boolean,
        exit_control_block: ^clt$block,
        local_status: ost$status,
        when_condition_definition: clt$when_condition_definition;


      IF condition.selector = pmc$block_exit_processing THEN

{ --- Handle block exit.

        IF input_block <> NIL THEN
          clp$pop_terminated_blocks (input_block, include_status);
          clp$process_exit_condition (input_block, include_status);
          IF input_block^.input_can_be_echoed THEN
            clp$find_connected_files (connected_files);
            IF connected_files^.echo_count > 0 THEN
              clp$echo_trace_information ('CLC$ECHO_INCLUDE_LINE_END', ^translated_utility, NIL,
                    ^include_status, pop_status);
            IFEND;
            clp$pop_input_stack (end_input_block, pop_status);
          IFEND;
        IFEND;

      ELSEIF (condition.selector = pmc$user_defined_condition) AND
            (condition.user_condition_name = clc$exiting_condition) THEN

{ --- Handle exit initiated via command level EXIT statement.
{
{ This condition is raised in the task that "owns" the SCL block which is the
{ target of the EXIT statement.
{ This condition is specifically dealt with in the condition handlers that
{ cover processing of the various kinds of input, command and function blocks.
{ The condition_information for this condition is a pointer to the outermost
{ block which is being exited and has such a corresponding condition handler.
{ The handler which is "covering" this "exit_control_block" performs a
{ non-local (CYBIL) exit out of its establishing procedure.
{ Other such handlers simply "continue" the condition.

        IF input_block_finished (input_block) THEN
          exit_control_block := condition_information;
          IF #OFFSET (exit_control_block) <> #OFFSET (input_block) THEN
            pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          IFEND;
          EXIT clp$include_line;
        IFEND;

      ELSE

{ --- Handle command level condition.

        clp$determine_when_condition (condition, condition_information, save_area,
              when_condition_definition, {ignore} local_status);

        IF when_condition_definition.name <> osc$null_name THEN
          clp$process_when_cond_in_block (when_condition_definition, input_block, FALSE,
                condition_processed, local_status);
          IF local_status.normal AND condition_processed THEN
            RETURN;
          IFEND;
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND handle_condition;
?? OLDTITLE, EJECT ??

    #KEYPOINT (osk$entry, 0, clk$include_line);

    status.normal := TRUE;
    input_block := NIL;
    include_status.normal := TRUE;
    #SPOIL (input_block, include_status.normal);

    osp$establish_condition_handler (^handle_condition, TRUE);

  /include_line/
    BEGIN
      #TRANSLATE (osv$lower_to_upper, utility, translated_utility);

      IF translated_utility <> osc$null_name THEN
        clp$find_utility_block (translated_utility, utility_block, block_in_current_task);
        IF (utility_block = NIL) OR (NOT (utility_block^.command_environment.command_level OR
              block_in_current_task)) THEN
          osp$set_status_abnormal ('CL', cle$unknown_utility, translated_utility, status);
          EXIT /include_line/;
        IFEND;

{ If we're in a utility, check for a line preprocessor and if present,
{ preprocess the command line.

        line_size := clp$trimmed_string_size (statement_list);
        clp$preprocess_command_line (utility_block^.line_preprocessor, ^statement_list (1, line_size),
              not_input_origin_is_interactive, edited_line, status);
        IF NOT status.normal THEN
          EXIT /include_line/;
        IFEND;
        IF edited_line = NIL THEN
          edited_line := ^statement_list;
        IFEND;
      ELSE
        edited_line := ^statement_list;
      IFEND;

      input_block := NIL;
      #SPOIL (input_block);

      line_size := clp$trimmed_string_size (edited_line^);
      edited_line := ^edited_line^ (1, line_size);
      PUSH lexical_work_area: [[REP line_size + clc$lexical_units_size_pad OF clt$lexical_unit]];
      RESET lexical_work_area;
      clp$identify_lexical_units (edited_line, lexical_work_area, lexical_units, status);
      IF NOT status.normal THEN
        EXIT /include_line/;
      IFEND;


      clp$push_input_line_block (translated_utility, enable_echoing, edited_line, lexical_units, input_block);
      #SPOIL (input_block);

      clp$find_connected_files (connected_files);
      IF input_block^.input_can_be_echoed AND (connected_files^.echo_count > 0) THEN
        clp$echo_trace_information ('CLC$ECHO_INCLUDE_LINE_BEGIN', ^translated_utility, NIL, NIL, status);
        status.normal := TRUE;
      IFEND;

      process_command_line (input_block, enable_echoing, not_input_origin_is_interactive,
            not_input_from_job_command_file, include_status);

      IF include_status.normal AND (NOT input_block^.being_exited) THEN
        clp$find_current_block (end_input_block);
        IF end_input_block <> input_block THEN
          osp$set_status_abnormal ('CL', cle$unbalanced_block_structure, end_input_block^.kind_end_name,
                include_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, input_block^.kind_end_name,
                include_status);
        IFEND;
      IFEND;

    END /include_line/;

    IF input_block <> NIL THEN
      clp$pop_terminated_blocks (input_block, include_status);
      clp$process_exit_condition (input_block, include_status);
      IF input_block^.input_can_be_echoed THEN
        clp$find_connected_files (connected_files);
        IF connected_files^.echo_count > 0 THEN
          clp$echo_trace_information ('CLC$ECHO_INCLUDE_LINE_END', ^translated_utility, NIL, ^include_status,
                pop_status);
        IFEND;
      IFEND;
      clp$pop_input_stack (end_input_block, pop_status);
    IFEND;

    input_block := NIL;
    #SPOIL (input_block);
    osp$disestablish_cond_handler;

    IF NOT include_status.normal THEN
      status := include_status;
    ELSEIF NOT pop_status.normal THEN
      status := pop_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, clk$include_line);

  PROCEND clp$include_line;
?? TITLE := 'clp$scan_command_file', EJECT ??
*copyc clh$scan_command_file

  PROCEDURE [XDCL, #GATE] clp$scan_command_file
    (    file: fst$file_reference;
         utility_name: ost$name;
         prompt_string: clt$prompt_string;
     VAR status: ost$status);

    VAR
      block_in_current_task: boolean,
      translated_utility_name: clt$utility_name,
      utility_block: ^clt$block;


    #KEYPOINT (osk$entry, 0, clk$scan_command_file);

    status.normal := TRUE;

  /scan_command_file/
    BEGIN
      #TRANSLATE (osv$lower_to_upper, utility_name, translated_utility_name);
      IF translated_utility_name <> osc$null_name THEN
        clp$find_utility_block (translated_utility_name, utility_block, block_in_current_task);
        IF (utility_block = NIL) OR (NOT (utility_block^.command_environment.command_level OR
              block_in_current_task)) THEN
          osp$set_status_abnormal ('CL', cle$unknown_utility, utility_name, status);
          EXIT /scan_command_file/;
        IFEND;
      IFEND;
      clp$read_command_file (file, translated_utility_name, prompt_string, TRUE, NIL, FALSE, status);
    END /scan_command_file/;

    #KEYPOINT (osk$exit, 0, clk$scan_command_file);

  PROCEND clp$scan_command_file;
?? TITLE := 'clp$end_scan_command_file', EJECT ??
*copyc clh$end_scan_command_file

  PROCEDURE [XDCL, #GATE] clp$end_scan_command_file
    (    utility_name: ost$name;
     VAR status: ost$status);

    VAR
      translated_utility_name: ost$name;


    #KEYPOINT (osk$entry, 0, clk$end_scan_command_file);

    status.normal := TRUE;
    clp$end_include (utility_name, status);

    #KEYPOINT (osk$exit, 0, clk$end_scan_command_file);

  PROCEND clp$end_scan_command_file;
?? TITLE := 'clp$scan_command_line', EJECT ??
*copyc clh$scan_command_line

  PROCEDURE [XDCL, #GATE] clp$scan_command_line
    (    text: string ( * );
     VAR status: ost$status);

    VAR
      block: ^clt$block;


    #KEYPOINT (osk$entry, 0, clk$scan_command_line);

    status.normal := TRUE;
    clp$find_current_block (block);
    clp$include_line (text, (block = NIL) OR block^.input_can_be_echoed, osc$null_name, status);

    #KEYPOINT (osk$exit, 0, clk$scan_command_line);

  PROCEND clp$scan_command_line;
?? TITLE := 'clp$execute_command', EJECT ??
*copyc clh$execute_command

  PROCEDURE [XDCL, #GATE] clp$execute_command
    (    command: clt$command_line;
         command_file: fst$file_reference;
         enable_echoing: boolean;
         task_name: clt$task_name_reference;
     VAR task_id: pmt$task_id;
     VAR status: ost$status);

    CONST
      desktop_task_name_prefix = 'DET$',
      desktop_task_name_prefix_size = 4;

    VAR
      command_file_name: fst$path_handle_name,
      command_parameters: ^clt$async_command_parameters,
      command_size: clt$command_line_size,
      command_text: ^clt$command_line,
      evaluated_file_reference: fst$evaluated_file_reference,
      lexical_units: ^clt$lexical_units,
      parse: clt$parse_state,
      program_attributes: ^pmt$program_attributes,
      program_description: ^pmt$program_description,
      program_description_area: SEQ (pmt$program_attributes, amt$local_file_name),
      program_library_list: ^pmt$object_library_list,
      program_parameters: ^pmt$program_parameters,
      translated_task_name: clt$task_name,
      work_area: ^clt$work_area;


    #KEYPOINT (osk$entry, 0, clk$execute_command);

  /execute/
    BEGIN
      status.normal := TRUE;

{ Check the task name

      IF (task_name = osc$null_name) THEN
        osp$set_status_abnormal ('CL', cle$invalid_exec_task_name, '"null"', status);
        EXIT /execute/;
      IFEND;

{ Is the command file name reasonable ?

      IF (command_file = osc$null_name) THEN
        command_file_name := osc$null_name;
      ELSE
        clp$convert_str_to_path_handle (command_file, FALSE, TRUE, FALSE, command_file_name,
              evaluated_file_reference, status);
        IF NOT status.normal THEN
          EXIT /execute/;
        ELSEIF evaluated_file_reference.path_resolution = fsc$command_file_path THEN
          osp$set_status_abnormal ('CL', cle$incorrect_exec_command_file, command_file_name, status);
        IFEND;
      IFEND;

      IF NOT status.normal THEN
        EXIT /execute/;
      IFEND;

{ Is it a nonempty command ?

      IF command = '' THEN
        osp$set_status_abnormal ('CL', cle$invalid_exec_command, 'EMPTY', status);
        EXIT /execute/;
      IFEND;

{ Set up the program parameters including the command's parse state.

      command_size := clp$trimmed_string_size (command);
      PUSH work_area: [[clt$async_command_parameters, REP command_size OF char,
            REP command_size + clc$lexical_units_size_pad OF clt$lexical_unit]];
      RESET work_area;
      NEXT command_parameters IN work_area;
      NEXT command_text: [command_size] IN work_area;
      command_text^ (1, command_size) := command (1, command_size);
      clp$identify_lexical_units (command_text, work_area, lexical_units, status);
      IF NOT status.normal THEN
        EXIT /execute/;
      IFEND;
      clp$initialize_parse_state (command_text, lexical_units, parse);
      clp$scan_non_space_lexical_unit (parse);
      command_parameters^.parse := parse;

{ Is there only one command in the command line ?

      clp$scan_unnested_cmnd_lex_unit (parse);
      IF parse.unit.kind <> clc$lex_end_of_line THEN
        osp$set_status_abnormal ('CL', cle$multiple_execute_command, command, status);
        EXIT /execute/;
      IFEND;

{ Complete setup of program parameters.

      #TRANSLATE (osv$lower_to_upper, task_name, translated_task_name);

      RESET work_area;
      NEXT program_parameters: [[clt$async_command_parameters, REP command_size OF char, REP
            UPPERBOUND (lexical_units^) OF clt$lexical_unit]] IN work_area;
      command_parameters^.command_can_be_echoed := enable_echoing;
      command_parameters^.init_from_desktop_environment :=
            translated_task_name (1, desktop_task_name_prefix_size) = desktop_task_name_prefix;
      command_parameters^.text_size := command_size;
      command_parameters^.units_array_size := UPPERBOUND (lexical_units^);

{ Let's do it!

      program_description := ^program_description_area;
      RESET program_description;
      NEXT program_attributes IN program_description;
      program_attributes^.contents := $pmt$prog_description_contents
            [pmc$starting_proc_specified, pmc$library_list_specified, pmc$load_map_file_specified,
            pmc$load_map_options_specified, pmc$term_error_level_specified, pmc$abort_file_specified,
            pmc$debug_mode_specified];
      program_attributes^.starting_procedure := 'CLP$ASYNCHRONOUS_COMMAND';
      program_attributes^.number_of_libraries := 1;
      NEXT program_library_list: [1 .. 1] IN program_description;
      program_library_list^ [1] := loc$task_services_library_name;
      program_attributes^.load_map_file := clv$standard_files [clc$sf_null_file].path_handle_name;
      program_attributes^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
      program_attributes^.termination_error_level := LOWERVALUE (pmt$termination_error_level);
      program_attributes^.abort_file := clv$standard_files [clc$sf_null_file].path_handle_name;
      program_attributes^.debug_mode := FALSE;

      clp$execute_named_task (translated_task_name, #RING (program_parameters), program_description^,
            program_parameters^, command_file_name, task_id, status);
    END /execute/;

    #KEYPOINT (osk$exit, 0, clk$execute_command);

  PROCEND clp$execute_command;
*IFEND
?? TITLE := 'clp$include_command', EJECT ??
*copyc clh$include_command

  PROCEDURE [XDCL, #GATE] clp$include_command
    (    command: clt$command_line;
         enable_echoing: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      command_size: clt$command_line_size,
      edited_line: ^clt$command_line,
      external_input_block: ^clt$block,
*IF $true(osv$unix)
      handler_established: boolean,
*IFEND
      include_status: ost$status,
      input_block: ^clt$block,
      input_from_external_file: boolean,
      input_from_job_command_file: boolean,
      input_origin_is_interactive: boolean,
      lexical_units: ^clt$lexical_units,
      lexical_work_area: ^clt$work_area;

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

    PROCEDURE abort_handler
*IF $true(osv$unix)
      (    signal_no: integer;
           code: integer;
           p_sigcontext: ^cyt$mips_sigcontext);
*ELSE
      (    condition: pmt$condition;
           ignore_condition_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);
*IFEND

      IF input_block <> NIL THEN
        WHILE (input_block^.line_parse.unit.kind = clc$lex_end_of_line) AND
              (input_block^.input.pushed_line <> NIL) DO
          clp$pop_command_line;
          #SPOIL (input_block^);
        WHILEND;
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, 1, clk$scan_command_line);
*IFEND

    status.normal := TRUE;

    input_block := NIL;
    #SPOIL (input_block);

*IF $true(osv$unix)
    osv$signal := $ost$signals [];
    handler_established := #establish_condition_handler (-1, ^abort_handler);
*ELSE
    osp$establish_block_exit_hndlr (^abort_handler);
*IFEND

  /include_command/
    BEGIN

{ If we're in a utility, check for a line preprocessor and if present,
{ preprocess the command line.

      clp$find_input_block (TRUE, input_block);
      IF (input_block <> NIL) AND (input_block^.associated_utility <> NIL) AND
            (input_block^.line_preprocessor_specified) THEN

        command_size := clp$trimmed_string_size (command);
        clp$preprocess_command_line (input_block^.associated_utility^.line_preprocessor, ^command
              (1, command_size), FALSE {input_origin_is_interactive} , edited_line, status);
        IF NOT status.normal THEN
          EXIT /include_command/;
        IFEND;
        IF edited_line = NIL THEN
          edited_line := ^command;
        IFEND;
      ELSE
        edited_line := ^command;
      IFEND;

      input_block := NIL;
      command_size := clp$trimmed_string_size (edited_line^);
      edited_line := ^edited_line^ (1, command_size);
      PUSH lexical_work_area: [[REP command_size + clc$lexical_units_size_pad OF clt$lexical_unit]];
      RESET lexical_work_area;
      clp$identify_lexical_units (edited_line, lexical_work_area, lexical_units, include_status);
      IF NOT include_status.normal THEN
        EXIT /include_command/;
      IFEND;

      clp$push_command_line (edited_line, lexical_units, input_block);
      IF input_block = NIL THEN
        osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$include_command', include_status);
        EXIT /include_command/;
      IFEND;

      clp$find_current_block (block);
      IF input_block^.input.internal THEN
        clp$find_external_input_block (external_input_block);
      ELSE
        external_input_block := input_block;
      IFEND;
      input_from_external_file := (external_input_block <> NIL) AND
            (external_input_block^.input.kind = clc$file_input);
      input_origin_is_interactive := input_from_external_file AND
            external_input_block^.input.interactive_device;
*IF NOT $true(osv$unix)
      input_from_job_command_file := input_from_external_file AND
            (external_input_block^.input.local_file_name = clv$standard_files [clc$sf_command_file].
            path_handle_name);
      process_command_line (input_block, enable_echoing AND block^.input_can_be_echoed,
*ELSE
      input_from_job_command_file := input_from_external_file;
      process_command_line (input_block, FALSE,
*IFEND
            input_origin_is_interactive, input_from_job_command_file, include_status);

      WHILE (input_block^.line_parse.unit.kind = clc$lex_end_of_line) AND
            (input_block^.input.pushed_line <> NIL) DO
        clp$pop_command_line;
*IF NOT $true(osv$unix)
        #SPOIL (input_block^);
*IFEND
      WHILEND;
    END /include_command/;

*IF $true(osv$unix)
    IF handler_established THEN
      handler_established := NOT #disestablish_condition_handler (-1);
    IFEND;
*ELSE
    osp$disestablish_cond_handler;
*IFEND

    IF NOT include_status.normal THEN
      status := include_status;
    IFEND;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, 1, clk$scan_command_line);
*IFEND

  PROCEND clp$include_command;
?? TITLE := 'input_block_finished', EJECT ??

  FUNCTION [INLINE] input_block_finished
    (    input_block: ^clt$block): boolean;

    input_block_finished := (input_block^.being_exited) AND
          (input_block^.input.interactive_device OR ((input_block^.associated_utility = NIL) OR
          (input_block^.associated_utility^.command_environment.commands = NIL) OR
          input_block^.associated_utility^.termination_command_found));

  FUNCEND input_block_finished;
?? TITLE := 'clp$process_command_file', EJECT ??

  PROCEDURE [XDCL] clp$process_command_file
    (    input_block: ^clt$block;
         handle_interactive_include: ^procedure;
     VAR status: ost$status);

    VAR
      current_block: ^clt$block,
      end_of_input: boolean,
      external_input_block: ^clt$block,
      first_time: boolean,
      input_from_external_file: boolean,
      input_from_job_command_file: boolean,
      input_origin_is_interactive: boolean,
      parse: clt$parse_state,
      reset_line_parse: clt$parse_state,
      retry_get: boolean;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'handle_command_level_condition', EJECT ??

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

      VAR
        condition_processed: boolean,
        exit_control_block: ^clt$block,
        local_status: ost$status,
        when_condition_definition: clt$when_condition_definition;


      IF (condition.selector = pmc$user_defined_condition) AND
            (condition.user_condition_name = clc$exiting_condition) THEN

{ --- Handle exit initiated via command level EXIT statement.
{
{ This condition is raised in the task that "owns" the SCL block which is the
{ target of the EXIT statement.
{ This condition is specifically dealt with in the condition handlers that
{ cover processing of the various kinds of input, command and function blocks.
{ The condition_information for this condition is a pointer to the outermost
{ block which is being exited and has such a corresponding condition handler.
{ The handler which is "covering" this "exit_control_block" performs a
{ non-local (CYBIL) exit out of its establishing procedure.
{ Other such handlers simply "continue" the condition.

        IF input_block_finished (input_block) THEN
          exit_control_block := condition_information;
          IF #OFFSET (exit_control_block) <> #OFFSET (input_block) THEN
            pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          IFEND;
          EXIT clp$process_command_file;
        IFEND;

      ELSE

{ --- Handle command level condition.

        clp$determine_when_condition (condition, condition_information, save_area,
              when_condition_definition, {ignore} local_status);

        IF when_condition_definition.name <> osc$null_name THEN
          clp$process_when_cond_in_block (when_condition_definition, input_block, FALSE,
                condition_processed, local_status);
          IF local_status.normal AND condition_processed THEN
            RETURN;
          IFEND;
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND handle_command_level_condition;
*IFEND
?? TITLE := 'handle_status', EJECT ??

    PROCEDURE handle_status;

      VAR
        local_status: ost$status,
        severity: ost$status_severity;


      severity := osc$error_status;
      osp$get_status_severity (status.condition, severity, local_status);
      IF (severity >= osc$error_status) AND ((input_block^.input.kind <> clc$file_input) OR
            (NOT input_block^.input.interactive_device)) THEN
        EXIT clp$process_command_file;
      IFEND;

*IF NOT $true(osv$unix)
      IF (input_block^.input.kind = clc$file_input) AND (input_block^.input.interactive_device OR
            (input_block^.input.local_file_name = clv$standard_files [clc$sf_command_file].path_handle_name))
            THEN
*ELSE
      IF (input_block^.input.kind = clc$file_input) AND input_block^.input.interactive_device THEN
*IFEND
        osp$generate_message (status, local_status);
        IF NOT local_status.normal THEN
          EXIT clp$process_command_file;
        IFEND;
        status.normal := TRUE;
      IFEND;

    PROCEND handle_status;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

*IF NOT $true(osv$unix)
    osp$establish_condition_handler (^handle_command_level_condition, FALSE);
*IFEND

    first_time := TRUE;

    IF input_block^.input.internal THEN
      clp$find_external_input_block (external_input_block);
    ELSE
      external_input_block := input_block;
    IFEND;
    input_from_external_file := (external_input_block <> NIL) AND
          (external_input_block^.input.kind = clc$file_input);
    input_origin_is_interactive := input_from_external_file AND
          external_input_block^.input.interactive_device;
    input_from_job_command_file := input_from_external_file AND
*IF NOT $true(osv$unix)
          (external_input_block^.input.local_file_name = clv$standard_files [clc$sf_command_file].
          path_handle_name);
*ELSE
          (external_input_block^.input.local_file_name = clv$standard_files [clc$sf_command_file].
          unix_file_name);
*IFEND

    REPEAT
      IF (NOT first_time) OR (input_block^.line_parse.unit.kind <> clc$lex_end_of_line) OR
            (input_block^.input.pushed_line <> NIL) THEN

      /process_line/
        WHILE TRUE DO
          WHILE (input_block^.line_parse.unit.kind = clc$lex_end_of_line) AND
                (input_block^.input.pushed_line <> NIL) DO
            clp$pop_command_line;
            #SPOIL (input_block^);
          WHILEND;
          IF input_block^.line_parse.unit.kind = clc$lex_end_of_line THEN
            EXIT /process_line/;
          IFEND;

          clp$find_current_block (current_block);
*IF NOT $true(osv$unix)
          process_command_line (input_block, current_block^.input_can_be_echoed, input_origin_is_interactive,
*ELSE
          IF (osc_sigint IN osv$signal) THEN
            IF interactive (input_block) THEN
              osv$signal := osv$signal - $ost$signals [osc_sigint];
              osv$signal_status.normal := TRUE;
            ELSE
              RETURN;
            IFEND;
          IFEND;
          process_command_line (input_block, FALSE, input_origin_is_interactive,
*IFEND
                input_from_job_command_file, status);
*IF $true(osv$unix)
          IF (osc_sigint IN osv$signal) THEN
            IF interactive (input_block) THEN
              osv$signal := osv$signal - $ost$signals [osc_sigint];
              osv$signal_status.normal := TRUE;
            ELSE
              RETURN;
            IFEND;
          IFEND;
*IFEND
          IF NOT status.normal THEN
            handle_status;
          IFEND;

          IF input_block_finished (input_block) THEN
            RETURN;
          ELSEIF (input_block^.input.kind <> clc$line_input) AND
                (input_block^.input.state = clc$reset_input) THEN
            WHILE input_block^.input.pushed_line <> NIL DO
              clp$pop_command_line;
              #SPOIL (input_block^);
            WHILEND;
            EXIT /process_line/;
          IFEND;
        WHILEND /process_line/;
      IFEND;

*IF $true(osv$unix)
      IF (osc_sigint IN osv$signal) THEN
        IF interactive (input_block) THEN
          osv$signal := osv$signal - $ost$signals [osc_sigint];
          osv$signal_status.normal := TRUE;
        ELSE
          RETURN;
        IFEND;
      IFEND;
*IFEND
      IF (input_block^.previous_block^.kind = clc$utility_block) AND
            (input_block^.previous_block^.notify_before_command_read <> NIL) THEN
        input_block^.previous_block^.notify_before_command_read^ (status);
        IF NOT status.normal THEN
*IF NOT $true(osv$unix)
          handle_status;
*ELSE
          RETURN;
*IFEND
        IFEND;
      IFEND;

*IF NOT $true(osv$unix)
      IF (input_block^.input.kind <> clc$line_input) AND (input_block^.input.state = clc$reset_input) THEN
        IF (input_block^.input.data = NIL) AND input_block^.input.file_rereadable THEN
          amp$seek_direct (input_block^.input.file_id, input_block^.input.reset_line_identifier.byte_address,
                status);
          IF NOT status.normal THEN
            handle_status;
          IFEND;
        IFEND;
        reset_line_parse := input_block^.input.reset_line_parse;
        clp$set_input_line_position (input_block^.input.reset_line_identifier);
        clp$get_command_line (parse, end_of_input, status);
        IF NOT status.normal THEN
          IF status.condition = cle$unable_to_call_preprocessor THEN
            EXIT clp$process_command_file;
          IFEND;
          handle_status;
        IFEND;
        IF reset_line_parse.text <> NIL THEN
          clp$set_input_line_parse (reset_line_parse);
        IFEND;

      ELSE
*ELSE
        IF (osc_sigint IN osv$signal) THEN
          IF interactive (input_block) THEN
            osv$signal := osv$signal - $ost$signals [osc_sigint];
            osv$signal_status.normal := TRUE;
          ELSE
            RETURN;
          IFEND;
        IFEND;
*IFEND
        IF first_time AND (handle_interactive_include <> NIL) THEN
          handle_interactive_include^;
        IFEND;

        REPEAT
          retry_get := FALSE;
          REPEAT
*IF $true(osv$unix)
          IF (osc_sigint IN osv$signal) THEN
            IF interactive (input_block) THEN
              osv$signal := osv$signal - $ost$signals [osc_sigint];
              osv$signal_status.normal := TRUE;
            ELSE
              RETURN;
            IFEND;
          IFEND;
*IFEND
            clp$get_command_line (parse, end_of_input, status);
*IF NOT $true(osv$unix)
          UNTIL status.normal OR (status.condition <> cle$command_line_cancelled);
*ELSE
          IF (osc_sigint IN osv$signal) THEN
            IF interactive (input_block) THEN
              osv$signal := osv$signal - $ost$signals [osc_sigint];
              osv$signal_status.normal := TRUE;
            ELSE
              RETURN;
            IFEND;
          IFEND;
          UNTIL status.normal;
*IFEND
          IF NOT status.normal THEN
*IF NOT $true(osv$unix)
            IF (status.condition = cle$unable_to_call_preprocessor) OR (pmp$task_state () <> pmc$task_active)
*ELSE
            IF (status.condition = cle$unable_to_call_preprocessor)
*IFEND
                  THEN
              EXIT clp$process_command_file;
            IFEND;
*IF NOT $true(osv$unix)
            handle_status;
*ELSE
            RETURN;
*IFEND
            retry_get := status.normal;
          IFEND;

        UNTIL NOT (status.normal AND retry_get);
*IF NOT $true(osv$unix)
      IFEND;
*IFEND

      first_time := FALSE;
    UNTIL (NOT status.normal) OR end_of_input;

  PROCEND clp$process_command_file;
?? TITLE := 'process_command_line', EJECT ??

{
{ PURPOSE:
{   This routine is responsible for processing a line containing SCL statements.
{
{ NOTES:
{   1. A condition handler is established to catch the aborting of a command due to a programmatic error.
{   2. A condition handler is established for interactive terminate break if the command line came from a
{      terminal file.  This handler provides the means for terminating the last command entered from the
{      teminal.
{   3. The ability to retry a command via the CONTINUE RETRY statement is provided by employing a "user"
{      defined condition handler which provides the means for the CONTINUE RETRY statement to "get back"
{      to this routine.
{

  PROCEDURE process_command_line
    (    input_block: ^clt$block;
         input_can_be_echoed: boolean;
         input_origin_is_interactive: boolean;
         input_from_job_command_file: boolean;
     VAR status: ost$status);

    CONST
      not_from_execute_command = FALSE;

    VAR
      block_at_start_of_command: ^clt$block,
      block_at_start_of_line: ^clt$block,
      cause_condition: clt$when_condition,
      command_parse: clt$parse_state,
*IF NOT $true(osv$unix)
      connected_files: ^clt$connected_files,
*IFEND
      done_with_line: boolean,
*IF $true(osv$unix)
      handler_stat: boolean,
*IFEND
      line_identifier: clt$line_identifier,
      line_index: clt$command_line_index,
      parse: clt$parse_state,
      process_the_command: boolean,
      processing_original_command: boolean,
      retry_command: boolean,
      severity: ost$status_severity,
*IF $true(osv$unix)
      shell_command: ^string(*),
      shell_command_length: integer,
*IFEND
      terminate_break_detected: boolean;

?? NEWTITLE := 'command_line_condition_handler', EJECT ??

{
{ PURPOSE:
{   This condition handler is responsible for dealing with a terminate break
{   entered while processing a command line from an interactive file.  It
{   first checks for a WHEN/WHENEND handler established at this level for
{   TERMINATE.  If no such handler was established or that handler "continued"
{   the condition, this handler halts processing of the entire command line.
{
{ NOTE:
{   The termination of command line processing is accomplished in two stages.
{   First, this handler detects the terminate break and does a non-local
{   exit out the process_command_line routine.  Second, it regains control
{   as a block exit condtion handler at which time it does the remaining
{   cleanup work.  This two step approach is used so that procedures called
{   by process_command_line can perform the cleanup that they are responsible
{   for, thereby getting the command environment back to as close to its state
{   upon entry to process_command_line as possible before doing the last bit
{   of tiddying up.
{

    PROCEDURE command_line_condition_handler
*IF NOT $true(osv$unix)
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);
*ELSE
      (    signal_no: integer;
           code: integer;
           p_sigcontext: ^cyt$mips_sigcontext);
*IFEND

      VAR
*IF NOT $true(osv$unix)
        condition_definition: ^clt$when_condition_definition,
        condition_processed: boolean,
*IFEND
        local_status: ost$status;


*IF NOT $true(osv$unix)
      CASE condition.selector OF

      = pmc$block_exit_processing =
        IF terminate_break_detected THEN

*ELSE

      CASE signal_no OF
      { pmc$block_exit_processing    -    block exit
      = -1 =
        IF osc_sigint IN osv$signal THEN
*IFEND
          status.normal := TRUE;
          clp$pop_terminated_blocks (block_at_start_of_line, status);
          IF input_block^.line_parse.unit.kind <> clc$lex_end_of_line THEN
            clp$set_input_line_finished;
          IFEND;
*IF NOT $true(osv$unix)
          ifp$discard_suspended_output;
*IFEND
          osp$set_status_condition (cle$command_terminated, local_status);
*IF NOT $true(osv$unix)
          osp$generate_output_message (local_status, status);
*ELSE
          osp$generate_message (local_status, status);
          osv$signal := osv$signal - $ost$signals [osc_sigint];
          osv$signal_status.normal := TRUE;
*IFEND
        IFEND;
        RETURN;

*IF NOT $true(osv$unix)
      = ifc$interactive_condition =
        IF (condition.interactive_condition = ifc$terminate_break) AND
              (input_block^.input.kind = clc$file_input) AND input_block^.input.interactive_device THEN
          PUSH condition_definition;
          condition_definition^.name := clc$wc_terminate;
          condition_definition^.status.normal := TRUE;
          condition_definition^.limit_name := osc$null_name;
          clp$process_when_cond_in_block (condition_definition^, input_block, TRUE, condition_processed,
                local_status);
          IF local_status.normal AND condition_processed THEN
            RETURN;
          IFEND;
          terminate_break_detected := TRUE;
          EXIT process_command_line;
        IFEND;
*IFEND

      ELSE
        ;
      CASEND;

*IF NOT $true(osv$unix)
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
*IFEND

    PROCEND command_line_condition_handler;
?? TITLE := 'handle_command_condition', EJECT ??

    PROCEDURE handle_command_condition;

      VAR
*IF NOT $true(osv$unix)
        condition_processed_state: clt$condition_processed_state,
        condition_status: ^ost$status,
        force_command_fault: boolean,
        local_status: ost$status,
        retry_command_image: ^clt$command_line;

?? NEWTITLE := 'initiate_command_retry', EJECT ??

      PROCEDURE initiate_command_retry;

        VAR
          lexical_units: ^clt$lexical_units,
          work_area: ^^clt$work_area;


        status.normal := TRUE;
        clp$pop_terminated_blocks (block_at_start_of_command, status);
        IF NOT status.normal THEN
          EXIT handle_command_condition;
        IFEND;

{ PARSE must be input/output on following call in case text or units_array have moved.

        clp$reset_input_position (line_identifier, parse);

        IF retry_command_image <> NIL THEN
          processing_original_command := FALSE;

          clp$get_work_area (#RING (^work_area), work_area, status);
          IF NOT status.normal THEN
            EXIT handle_command_condition;
          IFEND;
          clp$identify_lexical_units (retry_command_image, work_area^, lexical_units, status);
          IF NOT status.normal THEN
            EXIT handle_command_condition;
          IFEND;
          clp$initialize_parse_state (retry_command_image, lexical_units, command_parse);
          clp$scan_non_space_lexical_unit (command_parse);

        ELSEIF processing_original_command THEN
          command_parse.text := parse.text;
          command_parse.units_array := parse.units_array;
        IFEND;

        retry_command := TRUE;
        EXIT handle_command_condition;

      PROCEND initiate_command_retry;
?? OLDTITLE, EJECT ??
*ELSE
        errno: ost_c_integer,
        in_screen_mode: boolean,
        shell_cmnd: string (256),
        stat: integer,
        syserrlist_message: string (256),
        local_status: ost$status;


      IF status.condition = cle$epix_command_requested THEN
        shell_cmnd := shell_command^ (2, shell_command_length - 1);
        clp$get_screen_mode (in_screen_mode);
        clp_process_shell_cmd (shell_cmnd, shell_command_length - 1, $INTEGER(in_screen_mode), errno,
              syserrlist_message, stat);
        IF stat = 0 THEN
          status.normal := TRUE;
{         RETURN;
        ELSEIF stat = 4 THEN
          status.condition := cle$command_terminated;
        IFEND;
{     ELSEIF status.condition = cle$parameters_displayed THEN
{       status.condition := cle$unknown_command;
      IFEND;

*IFEND

{ Determine condition's status and severity.

      IF status.normal THEN
        severity := osc$informative_status;
*IF NOT $true(osv$unix)
        IF (cause_condition = clc$wc_command_fault) OR (cause_condition = clc$wc_execution_fault) THEN
*IFEND
          RETURN;
*IF NOT $true(osv$unix)
        IFEND;
        force_command_fault := FALSE;
*IFEND
      ELSE
        severity := osc$error_status;
        osp$get_status_severity (status.condition, severity, local_status);
*IF NOT $true(osv$unix)
        IF cause_condition = osc$null_name THEN
          force_command_fault := severity >= osc$error_status;
          cause_condition := clc$wc_command_fault;
        ELSE
          force_command_fault := TRUE;
        IFEND;
*IFEND
      IFEND;

*IF NOT $true(osv$unix)
      condition_status := NIL;

      IF cause_condition = clc$wc_command_fault THEN

      /process_command_fault/
        BEGIN

{ A COMMAND_FAULT for a command that came from clp$inlcude_command should be
{ treated as an EXECUTION_FAULT so that, by default, its termination status
{ can be handled by the caller of that request.

          IF input_block^.input.pushed_line <> NIL THEN
            cause_condition := clc$wc_execution_fault;
            EXIT /process_command_fault/;
          IFEND;

          IF (severity >= osc$error_status) OR force_command_fault THEN
            IF condition_status = NIL THEN
              PUSH condition_status;
            IFEND;
            condition_status^ := status;

{ Make the command line status normal while processing the condition in case a
{ handler EXITs.

            status.normal := TRUE;
            #SPOIL (status.normal);
            clp$process_command_fault (condition_status^, input_block, retry_command_image,
                  condition_processed_state, local_status);

            IF NOT local_status.normal THEN
              status := condition_status^;
              RETURN;
            IFEND;
            CASE condition_processed_state OF
            = clc$continue_next =
              RETURN;
            = clc$continue_retry =
              initiate_command_retry {control not returned } ;
            ELSE {clc$no_handler_established, clc$continue_next_handler, clc$continue_next_user_handler}
              status := condition_status^;
              IF severity >= osc$error_status THEN
                cause_condition := clc$wc_execution_fault;
                EXIT /process_command_fault/
              IFEND;
            CASEND;
          IFEND;

          IF input_origin_is_interactive THEN

{ "Log" informative or warning status for interactive command.

            osp$generate_message (status, local_status);
            IF local_status.normal THEN
              status.normal := TRUE;
            IFEND;
          IFEND;

          RETURN;
        END /process_command_fault/;
      IFEND;

      IF cause_condition = clc$wc_execution_fault THEN

{ Process EXECUTION_FAULT.

        IF clp$execution_fault_handler_est () THEN
          IF condition_status = NIL THEN
            PUSH condition_status;
          IFEND;
          condition_status^ := status;

{ Make the command line status normal while processing the condition in case a
{ handler EXITs.

          status.normal := TRUE;
          #SPOIL (status.normal);
          clp$process_execution_fault (condition_status^, input_block, retry_command_image,
                condition_processed_state, local_status);

          IF local_status.normal THEN
            CASE condition_processed_state OF
            = clc$continue_next =
              ;
            = clc$continue_retry =
              initiate_command_retry {control not returned } ;
            ELSE {clc$no_handler_established, clc$continue_next_handler, clc$continue_next_user_handler}
              status := condition_status^;
            CASEND;
          IFEND;
        IFEND;

        RETURN;
      IFEND;

{ Process other condition raised by the CAUSE statement.

      IF status.normal THEN
        condition_status := NIL;
      ELSE
        IF condition_status = NIL THEN
          PUSH condition_status;
        IFEND;
        condition_status^ := status;
        status.normal := TRUE;
        #SPOIL (status.normal);
      IFEND;
      #SPOIL (cause_condition);

      pmp$cause_task_condition (cause_condition, condition_status, {notify_scl=} TRUE, {notify_debug=} FALSE,
            {propagate_to_parent=} FALSE, {call_default_handler=} TRUE, local_status);
      IF (NOT local_status.normal) AND (local_status.condition <> pme$no_established_handler) THEN
        status := local_status;
        severity := osc$error_status;
        osp$get_status_severity (status.condition, severity, local_status);
      IFEND;

*IFEND
    PROCEND handle_command_condition;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    terminate_break_detected := FALSE;
    cause_condition := osc$null_name;
*IF NOT $true(osv$unix)
    #SPOIL (terminate_break_detected, cause_condition);

    osp$establish_condition_handler (^command_line_condition_handler, TRUE);
*ELSE
    handler_stat := #establish_condition_handler (-1, ^command_line_condition_handler);
*IFEND

    clp$find_current_block (block_at_start_of_line);

    done_with_line := FALSE;

  /process_commands/
    REPEAT
      status.normal := TRUE;

      parse := input_block^.line_parse;
      IF parse.unit.kind = clc$lex_beginning_of_line THEN
        clp$scan_any_lexical_unit (parse);
      IFEND;
      line_identifier := input_block^.line_identifier;
*IF NOT $true(osv$unix)
      #SPOIL (parse, line_identifier);
*IFEND

      command_parse := parse;
      clp$scan_unnested_cmnd_lex_unit (parse);
      command_parse.index_limit := parse.unit_index;
*IF $true(osv$unix)
        shell_command_length := command_parse.index_limit - command_parse.unit_index;

{ This PUSH should be done outside of this routine.

        PUSH shell_command: [shell_command_length];
        shell_command^ := command_parse.text^(command_parse.unit_index,
              shell_command_length);
*IFEND

      process_the_command := TRUE;
      IF (parse.previous_non_space_unit.kind IN $clt$lexical_unit_kinds
            [clc$lex_beginning_of_line, clc$lex_semicolon]) AND (NOT input_from_job_command_file) THEN
        IF input_can_be_echoed THEN
*IF NOT $true(osv$unix)
          clp$find_connected_files (connected_files);
          IF connected_files^.echo_count = 0 THEN
*IFEND
            process_the_command := FALSE;
*IF NOT $true(osv$unix)
          IFEND;
*IFEND
        ELSE
          process_the_command := FALSE;
        IFEND;
      IFEND;

      IF parse.unit.kind <> clc$lex_end_of_line THEN
        clp$scan_any_lexical_unit (parse);
        IF NOT process_the_command THEN
          clp$set_input_line_parse (parse);
          CYCLE /process_commands/;
        IFEND;
      IFEND;
      clp$set_input_line_parse (parse);
      IF NOT process_the_command THEN
        EXIT /process_commands/;
      IFEND;

      processing_original_command := TRUE;
      REPEAT
        retry_command := FALSE;
        cause_condition := osc$null_name;
        clp$find_current_block (block_at_start_of_command);
*IF NOT $true(osv$unix)
        clp$process_command (block_at_start_of_command, block_at_start_of_command^.interpreter_mode,
*ELSE

{ If we received a signal and we're interactive, then return, i.e. go through
{ the block exit handler. Otherwise, exit the loop. In either case, don't
{ clear the signal. If a command processor was executing when the signal occurred
{ then status is probably cle$command_terminated.

        IF (osc_sigint IN osv$signal) THEN
          IF interactive (input_block) THEN
            RETURN;
          ELSE
            EXIT /process_commands/;
          IFEND;
        IFEND;

        clp$process_command (block_at_start_of_command, clc$interpret_mode,
*IFEND
              input_from_job_command_file, not_from_execute_command, input_from_job_command_file,
              input_can_be_echoed, command_parse, cause_condition, status);
*IF $true(osv$unix)

{ If we received a signal and we're interactive, then return, i.e. go through
{ the block exit handler. Otherwise, exit the loop. In either case, don't
{ clear the signal.

        IF (osc_sigint IN osv$signal) THEN
          IF (NOT status.normal) AND (status.condition = cle$command_terminated) THEN
            status.normal := TRUE;
          IFEND;
          IF interactive (input_block) THEN
            RETURN;
          ELSE
            EXIT /process_commands/;
          IFEND;
        IFEND;
*IFEND
        IF (NOT status.normal) OR (cause_condition <> osc$null_name) THEN
          handle_command_condition;
        IFEND;
        done_with_line := (NOT status.normal) AND (severity >= osc$error_status);
      UNTIL done_with_line OR (NOT retry_command);

      IF done_with_line THEN
        IF input_block^.line_parse.unit.kind <> clc$lex_end_of_line THEN
          clp$set_input_line_finished;
          WHILE (input_block^.line_parse.unit.kind = clc$lex_end_of_line) AND
                (input_block^.input.pushed_line <> NIL) DO
            clp$pop_command_line;
            #SPOIL (input_block^);
          WHILEND;
        IFEND;
      ELSEIF (input_block^.line_parse.unit.kind = clc$lex_end_of_line) OR
            ((input_block^.input.kind <> clc$line_input) AND (input_block^.input.state = clc$reset_input)) OR
            input_block_finished (input_block) THEN
        done_with_line := TRUE;
      IFEND;
    UNTIL done_with_line {/process_commands/} ;

*IF NOT $true(osv$unix)
    osp$disestablish_cond_handler;
*ELSE
    handler_stat := #disestablish_condition_handler (-1);
*IFEND

  PROCEND process_command_line;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$_execute_command', EJECT ??

  PROCEDURE [XDCL] clp$_execute_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$exec) execute_command, exec (
{   command, c: string = $required
{   task_name, tn: name = $optional
{   command_file, cf: file = $optional
{   enable_echoing, enable_echo, ee: boolean = yes
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 10] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
        type4: record
          header: clt$type_specification_header,
          default_value: string (3),
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 19, 20, 55, 20, 603], clc$command, 10, 5, 1, 0, 0, 0, 5, 'OSM$EXEC'],
            [['C                              ', clc$abbreviation_entry, 1],
            ['CF                             ', clc$abbreviation_entry, 3],
            ['COMMAND                        ', clc$nominal_entry, 1],
            ['COMMAND_FILE                   ', clc$nominal_entry, 3],
            ['EE                             ', clc$abbreviation_entry, 4],
            ['ENABLE_ECHO                    ', clc$alias_entry, 4],
            ['ENABLE_ECHOING                 ', clc$nominal_entry, 4],
            ['STATUS                         ', clc$nominal_entry, 5],
            ['TASK_NAME                      ', clc$nominal_entry, 2],
            ['TN                             ', clc$abbreviation_entry, 2]], [

{ PARAMETER 1

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 3],

{ PARAMETER 5

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 3

      [[1, 0, clc$file_type]],

{ PARAMETER 4

      [[1, 0, clc$boolean_type], 'yes'],

{ PARAMETER 5

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$command = 1,
      p$task_name = 2,
      p$command_file = 3,
      p$enable_echoing = 4,
      p$status = 5;

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

?? NEWTITLE := 'fetch_command_name', EJECT ??

    PROCEDURE fetch_command_name
      (    command_text: ^clt$command_line;
       VAR command_name: clt$name;
       VAR status: ost$status);

      VAR
        command_size: clt$command_line_size,
        empty_command: boolean,
        ignore_command_ref_parse: clt$parse_state,
        ignore_escaped: boolean,
        ignore_file: clt$file,
        ignore_form: clt$command_reference_form,
        ignore_label: ost$name,
        ignore_prompting_requested: boolean,
        ignore_separator: clt$lexical_unit_kind,
        ignore_util_command_list_entry: ^clt$command_list_entry,
        lexical_units: ^clt$lexical_units,
        lexical_work_area: ^clt$work_area,
        parse: clt$parse_state;


      status.normal := TRUE;

      command_size := clp$trimmed_string_size (command_text^);
      PUSH lexical_work_area: [[REP command_size + clc$lexical_units_size_pad OF clt$lexical_unit]];
      RESET lexical_work_area;
      clp$identify_lexical_units (^command_text^ (1, command_size), lexical_work_area, lexical_units, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$initialize_parse_state (^command_text^ (1, command_size), lexical_units, parse);

      clp$scan_non_space_lexical_unit (parse);
      clp$parse_command (parse, ignore_prompting_requested, ignore_escaped, ignore_label,
            ignore_command_ref_parse, ignore_file, ignore_form, command_name, ignore_util_command_list_entry,
            ignore_separator, empty_command, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF empty_command THEN
        osp$set_status_abnormal ('CL', cle$invalid_exec_command, 'EMPTY', status);
        RETURN;
      IFEND;

    PROCEND fetch_command_name;
?? OLDTITLE, EJECT ??

    VAR
      block: ^clt$block,
      command_file: ^fst$file_reference,
      ignore_task_id: pmt$task_id,
      search_mode: clt$command_search_modes,
      task_name: clt$name;


    clp$find_current_block (block);
    clp$get_command_search_mode (search_mode);
    IF (search_mode = clc$exclusive_command_search) AND block^.use_command_search_mode THEN
      osp$set_status_abnormal ('CL', cle$not_allowed_in_exclusive, 'EXECUTE_COMMAND', status);
      RETURN;
    IFEND;

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

    IF pvt [p$task_name].specified THEN
      task_name.value := pvt [p$task_name].value^.name_value;

{ task_name.size is not needed

    ELSE { Use the command name in the command string as the default task name.
      fetch_command_name (pvt [p$command].value^.string_value, task_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$command_file].specified THEN
      command_file := pvt [p$command_file].value^.file_value;
    ELSE
      PUSH command_file: [0];
    IFEND;

    clp$execute_command (pvt [p$command].value^.string_value^, command_file^,
          pvt [p$enable_echoing].value^.boolean_value.value, task_name.value, ignore_task_id, status);

  PROCEND clp$_execute_command;
*IFEND
?? TITLE := 'clp$_include_file', EJECT ??

  PROCEDURE [XDCL] clp$_include_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
{ PROCEDURE (osm$incf) include_file, incf (
{   file, f: file = $required
{   prompt, p: string = $optional
{   utility, u: any of
{       key
{         none
{       keyend
{       name
{     anyend = none
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type3: 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$name_type_qualifier,
          recend,
          default_value: string (4),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 19, 20, 56, 12, 998], clc$command, 7, 4, 1, 0, 0, 0, 4, 'OSM$INCF'],
            [['F                              ', clc$abbreviation_entry, 1],
            ['FILE                           ', clc$nominal_entry, 1],
            ['P                              ', clc$abbreviation_entry, 2],
            ['PROMPT                         ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 4],
            ['U                              ', clc$abbreviation_entry, 3],
            ['UTILITY                        ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 69, clc$optional_default_parameter, 0, 4],

{ PARAMETER 4

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type]],

{ PARAMETER 2

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]], 'none'],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$file = 1,
      p$prompt = 2,
      p$utility = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;
*ELSE
{  PROCEDURE (osm$incf) include_file, incf (
{    file, f: file = $required
{    prompt, p: string = $optional
{    utility, u: any of
{        key
{          none
{        keyend
{        name
{      anyend = none
{    status)



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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier_v2,
        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$name_type_qualifier,
        recend,
        default_value: ALIGNED [0 MOD 4] string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [2,
    [16, 5, 215, 108, 0, 0, 80],
    clc$command, 7, 4, 1, 0, 0, 0, 4, 'OSM$INCF'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PROMPT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['U                              ',clc$abbreviation_entry, 3],
    ['UTILITY                        ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 9, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 78, clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[2, 0, clc$file_type]],
{ PARAMETER 2
    [[2, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 3
    [[2, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    48, [[2, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    6, [[2, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'none'],
{ PARAMETER 4
    [[2, 0, clc$status_type]]];

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

    CONST
      p$file = 1,
      p$prompt = 2,
      p$utility = 3,
      p$status = 4;

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

    VAR
*IF $true(osv$unix)
      evaluated_file_reference: fst$evaluated_file_reference,
*IFEND
      utility_name: clt$utility_name,
      prompt: ^clt$string_value;


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

    IF pvt [p$prompt].specified THEN
      prompt := pvt [p$prompt].value^.string_value;
    ELSE
      PUSH prompt: [4];
      prompt^ := 'incf';
    IFEND;

    IF pvt [p$utility].value^.kind = clc$keyword {AND pvt [p$utility].keyword_value = 'NONE'} THEN
      utility_name := osc$null_name;
    ELSE
      utility_name := pvt [p$utility].value^.name_value;
    IFEND;

    clp$set_command_kind (clc$command_is_include_file);

*IF $true(osv$unix)
{ Disallow an INCLUDE_FILE of an interactive file - until the EXIT statement is
{ implemented.

    clp$evaluate_file_reference (pvt [p$file].value^.file_value^, $clt$file_ref_parsing_options
          [clc$command_file_ref_allowed], TRUE, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF evaluated_file_reference.standard_file THEN
      osp$set_status_abnormal ('CL', cle$not_supported,
            'INCLUDE_FILE of standard input, standard output, or standard error output is',
            status);
      RETURN;
    IFEND;

    IF evaluated_file_reference.command_file_path.found THEN
      osp$set_status_abnormal ('CL', cle$not_supported,
            'INCLUDE_FILE of $COMMAND or $COMMAND_OF_CALLER is ', status);
      RETURN;
    IFEND;
*IFEND
    clp$include_file (pvt [p$file].value^.file_value^, prompt^, utility_name, status);

  PROCEND clp$_include_file;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$_include_line', EJECT ??

  PROCEDURE [XDCL] clp$_include_line
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$incl) include_line, incl (
{   statement_list, sl: string = $required
{   enable_echoing, enable_echo, ee: boolean = yes
{   utility, u: any of
{       key
{         none
{       keyend
{       name
{     anyend = none
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 8] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (3),
        recend,
        type3: 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$name_type_qualifier,
          recend,
          default_value: string (4),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 19, 20, 57, 44, 198], clc$command, 8, 4, 1, 0, 0, 0, 4, 'OSM$INCL'],
            [['EE                             ', clc$abbreviation_entry, 2],
            ['ENABLE_ECHO                    ', clc$alias_entry, 2],
            ['ENABLE_ECHOING                 ', clc$nominal_entry, 2],
            ['SL                             ', clc$abbreviation_entry, 1],
            ['STATEMENT_LIST                 ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 4],
            ['U                              ', clc$abbreviation_entry, 3],
            ['UTILITY                        ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 3],

{ PARAMETER 3

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 69, clc$optional_default_parameter, 0, 4],

{ PARAMETER 4

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],

{ PARAMETER 2

      [[1, 0, clc$boolean_type], 'yes'],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]], 'none'],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$statement_list = 1,
      p$enable_echoing = 2,
      p$utility = 3,
      p$status = 4;

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

    VAR
      utility_name: clt$utility_name;


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

    IF pvt [p$utility].value^.kind = clc$keyword {AND pvt [p$utility].keyword_value = 'NONE'} THEN
      utility_name := osc$null_name;
    ELSE
      utility_name := pvt [p$utility].value^.name_value;
    IFEND;

    clp$set_command_kind (clc$command_is_include_line);

    clp$include_line (pvt [p$statement_list].value^.string_value^, pvt [p$enable_echoing].value^.
          boolean_value.value, utility_name, status);

  PROCEND clp$_include_line;
*IFEND
?? TITLE := 'clp$_include_command', EJECT ??

{
{ NOTE:
{   The processor for the INCLUDE_COMMAND command is unusual in that after it has obtained all of its
{   parameters, including its status parameter, it pops its own command block.  This is done so that
{   the included command (or statement) can push onto the block stack any blocks it needs and have
{   those added blocks outlive the INCLUDE_COMMAND itself.  If this step was not taken, the additional
{   blocks created by the INCLUDEd COMMAND would be popped as part of the cleanup of this command.
{   As a consequence of removing its command block, this command processor takes on the responsibility
{   of writing its status parameter upon its completion.
{   The routine INVOKE_SUBCOMMAND in module CLM$PROCESS_COMMANDS is the only other part of SCL that
{   is aware of this special case.  It is notified of the special case by this command processor
{   causing condition CLC$COMMAND_CLEANUP_COMPLETED.
{

  PROCEDURE [XDCL] clp$_include_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
{ PROCEDURE (osm$incc) include_command, incc (
{   command, c: string = $required
{   enable_echoing, enable_echo, ee: boolean = yes
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 6] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (3),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 19, 20, 58, 48, 452], clc$command, 6, 3, 1, 0, 0, 0, 3, 'OSM$INCC'],
            [['C                              ', clc$abbreviation_entry, 1],
            ['COMMAND                        ', clc$nominal_entry, 1],
            ['EE                             ', clc$abbreviation_entry, 2],
            ['ENABLE_ECHO                    ', clc$alias_entry, 2],
            ['ENABLE_ECHOING                 ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 3],

{ PARAMETER 3

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],

{ PARAMETER 2

      [[1, 0, clc$boolean_type], 'yes'],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$command = 1,
      p$enable_echoing = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;
*ELSE
{ PROCEDURE (osm$incc) include_command, incc (
{   command, c: string = $required
{   enable_echoing, enable_echo, ee: boolean = yes
{   status)



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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: ALIGNED [0 MOD 4] string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [2,
    [91, 8, 17, 15, 29, 29, 0],
    clc$command, 6, 3, 1, 0, 0, 0, 3, 'OSM$INCC'], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['COMMAND                        ',clc$nominal_entry, 1],
    ['EE                             ',clc$abbreviation_entry, 2],
    ['ENABLE_ECHO                    ',clc$alias_entry, 2],
    ['ENABLE_ECHOING                 ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 9, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[2, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 2
    [[2, 0, clc$boolean_type],
    'yes'],
{ PARAMETER 3
    [[2, 0, clc$status_type]]];

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

    CONST
      p$command = 1,
      p$enable_echoing = 2,
      p$status = 3;

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

    VAR
      command_text: ^clt$command_line,
      enable_echoing: boolean,
      ignore_command_block: ^clt$block,
      status_value: ^clt$data_value,
      status_variable: ^clt$variable_ref_expression;


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

    PUSH command_text: [STRLENGTH (pvt [p$command].value^.string_value^)];
    command_text^ := pvt [p$command].value^.string_value^;

    enable_echoing := pvt [p$enable_echoing].value^.boolean_value.value;

    IF pvt [p$status].specified THEN
      PUSH status_variable: [STRLENGTH (pvt [p$status].variable^)];
      status_variable^ := pvt [p$status].variable^;
    ELSE
      status_variable := NIL;
    IFEND;

*IF NOT $true(osv$unix)
    pmp$push_task_debug_mode (pmc$debug_mode_off, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$cause_condition (clc$command_cleanup_completed, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$pop_task_debug_mode (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$pop_block_stack (ignore_command_block);
*IFEND

    clp$include_command (command_text^, enable_echoing, status);
*IF NOT $true(osv$unix)

    IF status_variable = NIL THEN
      RETURN;
    IFEND;

    PUSH status_value;
    status_value^.kind := clc$status;
    PUSH status_value^.status_value;
    status_value^.status_value^ := status;
    clp$change_variable (status_variable^, status_value, status);
*IFEND

  PROCEND clp$_include_command;

MODEND clm$include;
*DECK DECK=CLM$INPUT_PROCEDURES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Input Procedures' ??
MODULE clm$input_procedures;

{
{ PURPOSE:
{   This module contains the procedures that read data from the current command input file.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$compiling_for_test_harness
*copyc clc$lexical_units_size_pad
*copyc clc$standard_file_names
*copyc cle$ecc_command_processing
*copyc cle$ecc_messages_and_prompts
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_utilities
*copyc clh$utility_line_preprocessor
*IF NOT $true(osv$unix)
*copyc clk$procedure_keypoints
*ELSE
*copyc cyt$mips_signal_handler
*copyc osv$signal
*copyc osv$signal_status
*copyc clp$determine_line_layout
*copyc fst$path_size
*copyc amc_standard_files
*copyc clv$standard_files
*IFEND
*copyc clt$command_line
*IF NOT $true(osv$unix)
*copyc clt$scl_procedure
*copyc clt$scl_procedure_header
*IFEND
*copyc clt$utility_line_preprocessor
*IF NOT $true(osv$unix)
*copyc cyd$run_time_error_condition
*copyc fmt$path_handle
*copyc fst$evaluated_file_reference
*IFEND
*copyc fst$file_reference
*IF NOT $true(osv$unix)
*copyc ife$error_codes
*IFEND
*copyc ift$format_effectors
*IF NOT $true(osv$unix)
*copyc ost$caller_identifier
*IFEND
*copyc ost$status
?? POP ??
*copyc amp$get_next
*copyc amp$get_partial
*IF NOT $true(osv$unix)
*copyc amp$seek_direct
*ELSE
*copyc amp$put_partial
*copyc amc_standard_files
*IFEND
*copyc amv$nil_file_identifier
*copyc clp$access_command_file
*copyc clp$append_continuation_line
*copyc clp$close_command_file
*IF NOT $true(osv$unix)
*copyc clp$convert_file_ref_to_string
*IFEND
*copyc clp$convert_str_to_path_handle
*IF NOT $true(osv$unix)
*copyc clp$echo_trace_information
*copyc clp$find_caller_input_block
*IFEND
*copyc clp$find_command_input_block
*IF NOT $true(osv$unix)
*copyc clp$find_connected_files
*IFEND
*copyc clp$find_current_block
*copyc clp$find_external_input_block
*copyc clp$find_input_block
*copyc clp$get_command_origin
*copyc clp$identify_lexical_units
*IF NOT $true(osv$unix)
*copyc clp$init_input_parse_state
*IFEND
*copyc clp$layout_data_line
*copyc clp$pop_input_stack
*copyc clp$pop_terminated_blocks
*copyc clp$push_input_$command_block
*copyc clp$push_input_file_block
*copyc clp$set_current_prompt_string
*copyc clp$set_input_line
*copyc clp$trimmed_string_size
*copyc clv$nil_block_handle
*IF NOT $true(osv$unix)
*copyc clv$standard_files
*copyc i#build_adaptable_seq_pointer
*IFEND
*copyc i#current_sequence_position
*IF NOT $true(osv$unix)
*copyc ifp$store_term_conn_attributes
*copyc jmp$system_job
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*IFEND
*copyc osp$generate_message
*copyc osp$generate_output_message
*copyc osp$set_status_abnormal
*IF NOT $true(osv$unix)
*copyc osp$set_status_from_condition
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osv$initial_exception_context
*IFEND
*copyc osv$lower_to_upper
*IF NOT $true(osv$unix)
*copyc pmp$continue_to_cause
*copyc pmp$get_job_mode
*copyc pmp$load
*copyc pmp$task_state
*IFEND

  CONST
    clc$continued_same_line_prompt = ifc$pre_print_space_1 CAT '..? ',
    clc$cont_same_line_prompt_size = 5,
    clc$same_line_prompt = ifc$pre_print_no_positioning CAT ' ',
    clc$same_line_prompt_size = 2;

*IF $true(osv$unix)
*copyc osp$append_status_file
*IFEND
?? TITLE := 'clp$push_input', EJECT ??
*copyc clh$push_input

  PROCEDURE [XDCL, #GATE] clp$push_input
    (    file: fst$file_reference;
         utility_name: ost$name;
         prompt_string: clt$prompt_string;
         enable_echoing: boolean;
         read_only: boolean;
     VAR input_block_handle: clt$block_handle;
     VAR file_id: amt$file_identifier;
     VAR opened_executable_file: boolean;
     VAR status: ost$status);

    VAR
*IF NOT $true(osv$unix)
      caller_id: ost$caller_identifier,
*IFEND
      caller_input_block: ^clt$block,
      caller_in_current_task: boolean,
      can_be_echoed: boolean,
*IF NOT $true(osv$unix)
      connected_files: ^clt$connected_files,
*IFEND
      device_class: rmt$device_class,
      evaluated_file_reference: fst$evaluated_file_reference,
      file_has_fap: boolean,
      file_type: clt$command_file_kind,
      file_path: ^fst$path,
      file_path_size: fst$path_size,
*IF $true(osv$unix)
      handler_established: boolean,
*IFEND
      ignore_byte_address: amt$file_byte_address,
*IF NOT $true(osv$unix)
      ignore_data: cell,
      ignore_file_contents: clt$file_contents,
*IFEND
      ignore_file_position: amt$file_position,
*IF NOT $true(osv$unix)
      ignore_ring_attributes: amt$ring_attributes,
*IFEND
      ignore_transfer_count: amt$transfer_count,
      input_block: ^clt$block,
      input_is_via_$command: boolean,
      line_layout: clt$line_layout,
*IF NOT $true(osv$unix)
      open_path_handle_name: fst$path_handle_name,
*ELSE
      open_path_handle_name: fst$path,
*IFEND
      open_the_file: boolean,
*IF NOT $true(osv$unix)
      path_handle_name: fst$path_handle_name,
*ELSE
      path_handle_name: fst$path,
*IFEND
      segment: ^SEQ ( * ),
*IF $true(osv$unix)
      standard_file: clt$standard_files,
*IFEND
      translated_utility_name: ost$name,
      use_path_handle_name_on_open: boolean;


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

    PROCEDURE abort_handler
*IF $true(osv$unix)
      (    signal_no: integer;
           code: integer;
           p_sigcontext: ^cyt$mips_sigcontext);

      VAR
        ignore_status: ost$status;

      clp$pop_input (read_only, input_block_handle, file_id, opened_executable_file, NIL, ignore_status);
*ELSE
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      clp$pop_input (read_only, input_block_handle, file_id, opened_executable_file, NIL, handler_status);
      handler_status.normal := TRUE;
*IFEND

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    input_block_handle := clv$nil_block_handle;
    file_id := amv$nil_file_identifier;
    #SPOIL (input_block_handle, file_id);

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*IFEND
    IF read_only THEN
      file_type := clc$get_file;
    ELSE
      file_type := clc$include_file;
    IFEND;
    can_be_echoed := TRUE;
    open_the_file := TRUE;
    file_has_fap := FALSE;

    clp$convert_str_to_path_handle (file, {delete_allowed} TRUE, {resolve_path} TRUE, {open_position} TRUE,
          path_handle_name, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    #TRANSLATE (osv$lower_to_upper, utility_name, translated_utility_name);

*IF NOT $true(osv$unix)
    IF evaluated_file_reference.path_resolution <> fsc$command_file_path THEN
*ELSE
    IF NOT evaluated_file_reference.command_file_path.found THEN
*IFEND
      input_is_via_$command := FALSE;
*IF NOT $true(osv$unix)
      use_path_handle_name_on_open :=
            (path_handle_name = clv$standard_files [clc$sf_command_file].path_handle_name);
*ELSE
      use_path_handle_name_on_open := FALSE;
*IFEND
    ELSE
      use_path_handle_name_on_open := TRUE;
      input_is_via_$command := TRUE;
*IF NOT $true(osv$unix)
      clp$find_command_input_block (evaluated_file_reference.block_handle, caller_input_block,
*ELSE
      clp$find_command_input_block (evaluated_file_reference.command_file_path.block_handle,
            caller_input_block,
*IFEND
            caller_in_current_task);

      IF caller_input_block = NIL THEN
        osp$set_status_abnormal ('CL', cle$command_file_not_accessible, '', status);
        RETURN;
      ELSEIF (caller_input_block^.kind = clc$task_block) THEN
        path_handle_name := caller_input_block^.command_file;
        input_is_via_$command := FALSE;
      ELSE
*IF NOT $true(osv$unix)
        can_be_echoed := caller_input_block^.input_can_be_echoed;
*IFEND
        IF caller_in_current_task OR (caller_input_block^.input.kind <> clc$file_input) THEN
          open_the_file := FALSE;
        ELSE
          path_handle_name := caller_input_block^.input.local_file_name;
          IF caller_input_block^.input.data = NIL THEN
            IF read_only THEN
              file_type := clc$get_record_caller_file;
            ELSE
              file_type := clc$incf_record_caller_file;
            IFEND;
          ELSE
            IF read_only THEN
              file_type := clc$get_segment_caller_file;
            ELSE
              file_type := clc$incf_segment_caller_file;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

*IF NOT $true(osv$unix)
    IF path_handle_name = clv$standard_files [clc$sf_null_file].path_handle_name THEN
      open_the_file := FALSE;
      device_class := rmc$null_device;
    IFEND;
*ELSE
    /determine_if_standard_file/
    FOR standard_file := clc$sf_null_file TO clc$sf_command_file DO
      IF path_handle_name = clv$standard_files [standard_file].unix_file_name THEN
        open_the_file := FALSE;
        file_id := clv$standard_files [standard_file].file_id;
        IF standard_file = clc$sf_null_file THEN
          device_class := rmc$null_device;
        ELSE
          device_class := rmc$terminal_device;
        IFEND;
        clp$determine_line_layout (file, line_layout, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        EXIT /determine_if_standard_file/;
      IFEND;
    FOREND /determine_if_standard_file/;
*IFEND


*IF $true(osv$unix)
    handler_established := #establish_condition_handler (-1, ^abort_handler);
*ELSE
    osp$establish_block_exit_hndlr (^abort_handler);
*IFEND

  /push_input/
    BEGIN
      IF open_the_file THEN
*IF NOT $true(osv$unix)
        IF use_path_handle_name_on_open THEN
          clp$access_command_file (file_type, caller_id.ring, path_handle_name, file_id, segment,
                opened_executable_file, can_be_echoed, line_layout, ignore_file_contents,
                ignore_ring_attributes, file_has_fap, device_class, open_path_handle_name, status);
*ELSE
          clp$access_command_file (file_type, path_handle_name, file_id, segment,
                opened_executable_file, can_be_echoed, line_layout,
                device_class, open_path_handle_name, status);
*IFEND
*IF NOT $true(osv$unix)
        ELSE
          PUSH file_path;
          clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} TRUE, file_path^,
                file_path_size, status);
          IF NOT status.normal THEN
            EXIT /push_input/;
          IFEND;
          clp$access_command_file (file_type, caller_id.ring, file_path^ (1, file_path_size), file_id,
                segment, opened_executable_file, can_be_echoed, line_layout, ignore_file_contents,
                ignore_ring_attributes, file_has_fap, device_class, open_path_handle_name, status);
        IFEND;
*IFEND
        IF NOT status.normal THEN
          EXIT /push_input/;
        IFEND;

*IF NOT $true(osv$unix)
        path_handle_name := open_path_handle_name;
        CASE file_type OF
        = clc$incf_segment_caller_file, clc$get_segment_caller_file =
          i#build_adaptable_seq_pointer (#RING (segment), #SEGMENT (segment),
                #OFFSET (caller_input_block^.input.data), #SIZE (caller_input_block^.input.data^),
                i#current_sequence_position (caller_input_block^.input.data), segment);
        = clc$incf_record_caller_file, clc$get_record_caller_file =
          IF caller_input_block^.input.file_rereadable THEN
            amp$seek_direct (file_id, caller_input_block^.input.line_address, status);
            IF NOT status.normal THEN
              EXIT /push_input/;
            IFEND;
            IF caller_input_block^.input.line_address_is_for_previous THEN
              amp$get_next (file_id, ^ignore_data, 1, ignore_transfer_count, ignore_byte_address,
                    ignore_file_position, status);
              IF NOT status.normal THEN
                EXIT /push_input/;
              IFEND;
            IFEND;
          IFEND;
        ELSE
          ;
        CASEND;
*IFEND
      IFEND;

*IF NOT $true(osv$unix)
      IF NOT read_only THEN
        clp$find_connected_files (connected_files);
      IFEND;
*IFEND
      IF input_is_via_$command THEN
        clp$push_input_$command_block (#OFFSET (caller_input_block), translated_utility_name, prompt_string,
              file_id, segment, (NOT read_only) AND enable_echoing AND can_be_echoed, caller_in_current_task,
              input_block);
*IF NOT $true(osv$unix)
        IF input_block^.input_can_be_echoed AND (connected_files^.echo_count > 0) THEN
          clp$echo_trace_information ('CLC$ECHO_INCLUDE_$COMMAND_BEGIN', ^translated_utility_name, NIL, NIL,
                status);
          status.normal := TRUE;
        IFEND;
*IFEND
      ELSE
        clp$push_input_file_block (path_handle_name, file_id, translated_utility_name, prompt_string,
              (NOT read_only) AND enable_echoing AND can_be_echoed, line_layout, device_class, file_has_fap,
              TRUE, input_block);
*IF NOT $true(osv$unix)
        IF input_block^.input_can_be_echoed AND (connected_files^.echo_count > 0) THEN
          clp$echo_trace_information ('CLC$ECHO_INCLUDE_FILE_BEGIN', ^translated_utility_name,
                ^path_handle_name, NIL, status);
          status.normal := TRUE;
        IFEND;
*IFEND
      IFEND;
      input_block_handle.segment_offset := #OFFSET (input_block);
      input_block_handle.assignment_counter := input_block^.assignment_counter;
    END /push_input/;

*IF $true(osv$unix)
    IF handler_established THEN
      handler_established := NOT #disestablish_condition_handler (-1);
    IFEND;
*ELSE
    osp$disestablish_cond_handler;
*IFEND

  PROCEND clp$push_input;
?? TITLE := 'clp$pop_input', EJECT ??
*copyc clh$pop_input

  PROCEDURE [XDCL, #GATE] clp$pop_input
    (    read_only: boolean;
         input_block_handle: clt$block_handle,
         file_id: amt$file_identifier;
         opened_executable_file: boolean;
         termination_status: ^ost$status;
     VAR status: ost$status);

    VAR
*IF NOT $true(osv$unix)
      connected_files: ^clt$connected_files,
*IFEND
      ignore_block_in_current_task: boolean,
      ignore_block_is_synchronous: boolean,
      input_block: ^clt$block,
      local_status: ost$status;


    status.normal := TRUE;

    IF input_block_handle <> clv$nil_block_handle THEN
      clp$find_block_via_handle (input_block_handle, input_block, ignore_block_in_current_task,
            ignore_block_is_synchronous);
      IF input_block <> NIL THEN
        clp$pop_terminated_blocks (input_block, status);
        IF status.normal THEN
          IF NOT read_only THEN
*IF NOT $true(osv$unix)
            clp$find_connected_files (connected_files);
            IF input_block^.input_can_be_echoed AND (connected_files^.echo_count > 0) THEN
              IF input_block^.inherited_input.found THEN
                clp$echo_trace_information ('CLC$ECHO_INCLUDE_$COMMAND_END', ^input_block^.label, NIL,
                      termination_status, status);
              ELSE
                clp$echo_trace_information ('CLC$ECHO_INCLUDE_FILE_END', ^input_block^.label,
                      ^input_block^.input.local_file_name, termination_status, status);
              IFEND;
              status.normal := TRUE;
            IFEND;
*IFEND
          IFEND;
          clp$pop_input_stack (input_block, status);
        IFEND;
      IFEND;
    IFEND;

    IF file_id <> amv$nil_file_identifier THEN
      clp$close_command_file (file_id, opened_executable_file, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

  PROCEND clp$pop_input;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$get_next_scl_proc_line', EJECT ??
*copyc clh$get_next_scl_proc_line

  PROCEDURE [XDCL, #GATE] clp$get_next_scl_proc_line
    (VAR scl_procedure {input, output} : ^clt$scl_procedure;
     VAR line: ^clt$command_line;
     VAR status: ost$status);

    VAR
      entire_procedure: ^clt$input_data,
      getting_first_line: boolean,
      lexical_units: ^clt$lexical_units,
      line_header: ^clt$input_data_line_header,
      line_size: ^clt$command_line_size,
      local_scl_procedure: ^clt$scl_procedure,
      scl_procedure_header: ^clt$scl_procedure_header,
      version: clt$declaration_version;


    status.normal := TRUE;

    getting_first_line := i#current_sequence_position (scl_procedure) = 0;
    local_scl_procedure := scl_procedure;
    RESET local_scl_procedure;
    NEXT scl_procedure_header IN local_scl_procedure;
    IF (scl_procedure_header = NIL) OR (scl_procedure_header^.identifying_first_byte <>
          UPPERVALUE (scl_procedure_header^.identifying_first_byte)) THEN
      version := 0;
    ELSE
      version := scl_procedure_header^.version;
    IFEND;

    IF version = 0 THEN
      NEXT line_size IN scl_procedure;
      IF line_size = NIL THEN
        line := NIL;
        RETURN;
      IFEND;

      NEXT line: [line_size^] IN scl_procedure;
      RETURN;
    IFEND;

    IF getting_first_line THEN
      entire_procedure := #PTR (scl_procedure_header^.entire_procedure, scl_procedure^);
      RESET scl_procedure TO entire_procedure;
    IFEND;

    NEXT line_header IN scl_procedure;
    IF line_header = NIL THEN
      line := NIL;
      RETURN;
    IFEND;

    NEXT line: [line_header^.line_size] IN scl_procedure;
    IF line_header^.number_of_lexical_units > 0 THEN
      NEXT lexical_units: [1 .. line_header^.number_of_lexical_units] IN scl_procedure;
    IFEND;

    IF line_header^.size_of_component_lines_data = 0 THEN
      RETURN;
    IFEND;

    NEXT line_header IN scl_procedure;
    IF line_header = NIL THEN
      line := NIL;
      RETURN;
    IFEND;

    NEXT line: [line_header^.line_size] IN scl_procedure;
    IF line_header^.number_of_lexical_units > 0 THEN
      NEXT lexical_units: [1 .. line_header^.number_of_lexical_units] IN scl_procedure;
    IFEND;

  PROCEND clp$get_next_scl_proc_line;
*IFEND

?? TITLE := 'clp$get_non_standard_line', EJECT ??

{
{ PURPOSE:
{   This procedure handles SCL input requests directed toward a "non-standard"
{   record access file.  A "standard" record access file is a mass storage
{   file for which the file_access_procedure (FAP), statement_identifier and
{   line_number attributes are undefined.  This procedure handles requests
{   for files that do not meet those criteria.
{

  PROCEDURE [XDCL] clp$get_non_standard_line
    (    line_kind: clt$input_line_kind;
         prompt_string: clt$prompt_string;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      file_position: amt$file_position,
      first_part_of_line: ^array [1 .. clc$nominal_command_line_size] of cell,
      ignore_data: cell,
      ignore_byte_address: amt$file_byte_address,
      ignore_status: ost$status,
      line_address: amt$file_byte_address,
      line_area: ^SEQ ( * ),
      line_identifier: clt$line_identifier,
      line_text: ^clt$command_line,
*IF NOT $true(osv$unix)
      next_line_area: ^cell,
*ELSE
      next_line_area: ^string(*),
*IFEND
      nominal_line: ^array [1 .. clc$nominal_command_line_size] of cell,
      record_length: amt$max_record_length,
      record_number: amt$file_byte_address,
*IF NOT $true(osv$unix)
      terminal_attributes: array [1 .. 1] of ift$connection_attribute,
*ELSE
      temp_line_area: ^string(*),
      terminal_prompt_string: ift$prompt_string,
      total_count: amt$transfer_count,
*IFEND
      transfer_count: amt$transfer_count;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'abort_handler', EJECT ??

{
{ PURPOSE:
{   This condition handler is established to catch any conditions that occur
{   during the reading of a line.  It is intended to deal with errors caused
{   by a "user supplied" file access procedure (FAP).
{

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

      VAR
        run_time_status: ^ost$status;


      handler_status.normal := TRUE;
      CASE condition.selector OF

      = mmc$segment_access_condition =
        osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);

      = pmc$system_conditions =
        IF pmc$detected_uncorrected_err IN condition.system_conditions THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, ignore_status);
        IFEND;
        osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          run_time_status := condition_information;
          status := run_time_status^;

        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          RETURN;
        IFEND;

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

      EXIT clp$get_non_standard_line;

    PROCEND abort_handler;
*IFEND
?? TITLE := 'retry_input_request', EJECT ??

    FUNCTION [INLINE] retry_input_request: boolean;


      retry_input_request := FALSE;

    FUNCEND retry_input_request;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$find_input_block (TRUE, block);
    IF (block = NIL) OR (block^.input.kind <> clc$file_input) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$get_non_stanard_line', status);
      RETURN;
    IFEND;

    IF block^.input.state = clc$end_of_input THEN
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    osp$establish_condition_handler (^abort_handler, FALSE);

    IF block^.input.state = clc$update_input THEN
      amp$seek_direct (block^.input.file_id, block^.input.line_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF block^.input.line_address_is_for_previous THEN
        amp$get_next (block^.input.file_id, ^ignore_data, 1, transfer_count, ignore_byte_address,
              file_position, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;
*IFEND

    IF block^.input.interactive_device AND ((block^.input.current_prompt_string.size = 0) OR
*IF NOT $true(osv$unix)
          (prompt_string <> block^.input.current_prompt_string.value (2, * ))) THEN
*ELSE
          (prompt_string <> block^.input.current_prompt_string.value)) THEN
*IFEND
*IF NOT $true(osv$unix)
      terminal_attributes [1].key := ifc$prompt_string;
*IFEND
      IF (STRLENGTH (prompt_string) = clc$same_line_prompt_size) AND (prompt_string = (clc$same_line_prompt))
            THEN
*IF NOT $true(osv$unix)
        terminal_attributes [1].prompt_string.size := clc$same_line_prompt_size;
        terminal_attributes [1].prompt_string.value := clc$same_line_prompt;
*ELSE
        terminal_prompt_string.size := clc$same_line_prompt_size;
        terminal_prompt_string.value := clc$same_line_prompt;
*IFEND
      ELSE
        IF (STRLENGTH (prompt_string) + 1) > ifc$max_prompt_string_size THEN
*IF NOT $true(osv$unix)
          terminal_attributes [1].prompt_string.size := ifc$max_prompt_string_size;
*ELSE
          terminal_prompt_string.size := ifc$max_prompt_string_size;
*IFEND
        ELSE
*IF NOT $true(osv$unix)
          terminal_attributes [1].prompt_string.size := STRLENGTH (prompt_string) + 1;
*ELSE
          terminal_prompt_string.size := STRLENGTH (prompt_string);
*IFEND
        IFEND;
*IF NOT $true(osv$unix)
        terminal_attributes [1].prompt_string.value (1) := ' ';
        terminal_attributes [1].prompt_string.value (2, * ) := prompt_string;
*ELSE
        terminal_prompt_string.value := prompt_string;
*IFEND
      IFEND;
*IF NOT $true(osv$unix)
      clp$set_current_prompt_string (terminal_attributes [1].prompt_string);
*ELSE
      clp$set_current_prompt_string (terminal_prompt_string);
*IFEND
*IF NOT $true(osv$unix)
      IF terminal_attributes [1].prompt_string.value = '' THEN
        terminal_attributes [1].prompt_string.size := 0;
      IFEND;
      ifp$store_term_conn_attributes (block^.input.file_id, terminal_attributes, status);
*IFEND
      IF NOT status.normal THEN
        RETURN;
      IFEND;
*IF $true(osv$unix)
    ELSE
      terminal_prompt_string.value := prompt_string;
      terminal_prompt_string.size := STRLENGTH (prompt_string);
*IFEND
    IFEND;
*IF NOT $true(osv$unix)

    PUSH line_area: [[REP clc$nominal_command_line_size OF char]];
*ELSE
    amp$put_partial (amc_stdout_fid, ^terminal_prompt_string.value,
          terminal_prompt_string.size, ignore_byte_address, amc$continue,
          status);
    PUSH temp_line_area: [clc$nominal_command_line_size];
*IFEND
    line_address := 0;

  /get_line/
    WHILE TRUE DO

    /get_first_part_of_line/
      WHILE TRUE DO
*IF NOT $true(osv$unix)
        amp$get_next (block^.input.file_id, line_area, clc$nominal_command_line_size, transfer_count,
*ELSE
        amp$get_next (block^.input.file_id, temp_line_area, clc$nominal_command_line_size, transfer_count,
*IFEND
              line_address, file_position, status);
        IF status.normal THEN
          EXIT /get_first_part_of_line/;
        ELSEIF retry_input_request () THEN
          osp$generate_message (status, ignore_status);
          CYCLE /get_first_part_of_line/;
        ELSE
          RETURN;
        IFEND;
      WHILEND /get_first_part_of_line/;

*IF $true(osv$unix)
      line_area := #SEQ(temp_line_area^);

*IFEND
      IF (file_position < amc$eor) AND (block^.input.line_layout.physical_line_size > #SIZE (line_area^)) THEN
        RESET line_area;
        NEXT nominal_line IN line_area;
        PUSH line_area: [[REP block^.input.line_layout.physical_line_size OF char]];
        RESET line_area;
        NEXT first_part_of_line IN line_area;
        first_part_of_line^ := nominal_line^;
*IF NOT $true(osv$unix)
        NEXT next_line_area IN line_area;
*ELSE
        NEXT next_line_area: [block^.input.line_layout.physical_line_size -
              clc$nominal_command_line_size] IN line_area;
        total_count := transfer_count;
*IFEND
        record_length := clc$nominal_command_line_size;

        amp$get_partial (block^.input.file_id, next_line_area,
              block^.input.line_layout.physical_line_size - clc$nominal_command_line_size, record_length,
              transfer_count, ignore_byte_address, file_position, amc$no_skip, status);
        IF NOT status.normal THEN
          IF retry_input_request () THEN
            osp$generate_message (status, ignore_status);
            CYCLE /get_line/;
          IFEND;
          RETURN;
        IFEND;
*IF NOT $true(osv$unix)
        transfer_count := record_length;
*ELSE
        transfer_count := total_count + transfer_count;
*IFEND
      IFEND;

      IF file_position < amc$eor THEN
*IF NOT $true(osv$unix)
        osp$set_status_abnormal ('CL', cle$line_too_long, block^.input.local_file_name, status);
*ELSE
        osp$set_status_abnormal ('CL', cle$line_too_long, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, block^.input.local_file_name, status);
*IFEND
        RETURN;
      IFEND;

      IF file_position > amc$eor THEN

        IF block^.input.interactive_device AND (block^.previous_block^.kind = clc$task_block) AND
              (block^.previous_block^.task_kind = clc$job_monitor_task) THEN
          IF file_position = amc$eop THEN
            osp$set_status_abnormal ('CL', cle$interactive_eop_ignored, '', status);
          ELSE
            osp$set_status_abnormal ('CL', cle$interactive_eoi_ignored, '', status);
          IFEND;
          osp$generate_message (status, ignore_status);
          CYCLE /get_line/;
        IFEND;

        line_text := NIL;
      ELSE
        clp$layout_data_line (block^.input.local_file_name, transfer_count, block^.input.line_layout,
              line_area, line_text, line_identifier, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        record_number := block^.input.record_number + 1;
        IF line_kind = clc$command_line THEN
          line_identifier.byte_address := line_address;
          line_identifier.record_number := record_number;
        ELSE
          line_identifier.byte_address := block^.input.line_address;
          line_identifier.record_number := block^.input.record_number;
        IFEND;
      IFEND;

      EXIT /get_line/;
    WHILEND /get_line/;

    clp$set_input_line (line_kind, line_text, line_identifier, record_number, line_address);

  PROCEND clp$get_non_standard_line;
?? TITLE := 'clp$get_line_from_command_file', EJECT ??
*copyc clh$get_line_from_command_file

  PROCEDURE [XDCL, #GATE] clp$get_line_from_command_file
    (    prompt_string: clt$prompt_string;
     VAR line: ^clt$command_line;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
*IF NOT $true(osv$unix)
      context: ^ost$ecp_exception_context,
*IFEND
      local_status: ost$status;


*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, 0, clk$get_line_from_command_file);
*IFEND

    status.normal := TRUE;
*IF NOT $true(osv$unix)
    context := NIL;
*IFEND
    local_status.normal := TRUE;
    line := NIL;

  /main/
    BEGIN
      clp$find_input_block (TRUE, block);
      IF block = NIL THEN
        osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$get_line_from_command_file',
              local_status);
        EXIT /main/;
      IFEND;

      IF (block^.input.kind = clc$line_input) OR (block^.input.state = clc$end_of_input) THEN
        EXIT /main/;
      IFEND;

      REPEAT
        block^.input.get_line^ (clc$data_line, prompt_string, local_status);
*IF NOT $true(osv$unix)
        IF NOT local_status.normal THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
          IFEND;
          context^.condition_status := local_status;
          osp$enforce_exception_policies (context^);
          local_status := context^.condition_status;
        IFEND;
      UNTIL local_status.normal OR (NOT osp$file_access_condition (local_status)) OR (NOT context^.wait);
*ELSE
      UNTIL local_status.normal;
*IFEND

      IF (NOT local_status.normal) OR (block^.input.state = clc$end_of_input) THEN
        EXIT /main/;
      IFEND;

      line := block^.input.data_line.text;
    END /main/;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, 0, clk$get_line_from_command_file);
*IFEND

  PROCEND clp$get_line_from_command_file;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$get_data_line', EJECT ??
*copyc clh$get_data_line

  PROCEDURE [XDCL, #GATE] clp$get_data_line
    (    prompt_string: string ( * );
     VAR line: ost$string;
     VAR got_line: boolean;
     VAR status: ost$status);

    VAR
      line_ptr: ^clt$command_line,
      local_status: ost$status;


    status.normal := TRUE;
    local_status.normal := TRUE;
    got_line := FALSE;
    line.size := 0;
    line.value := '';

  /main/
    BEGIN
      clp$get_line_from_command_file (prompt_string, line_ptr, local_status);
      IF NOT (local_status.normal AND (line_ptr <> NIL)) THEN
        EXIT /main/;
      IFEND;

      got_line := TRUE;
      IF STRLENGTH (line_ptr^) > osc$max_string_size THEN
        line.size := osc$max_string_size;
      ELSE
        line.size := STRLENGTH (line_ptr^);
      IFEND;
      line.value := line_ptr^ (1, line.size);
    END /main/;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND clp$get_data_line;
*IFEND
?? TITLE := 'clp$get_non_standard_cmnd_line', EJECT ??

  PROCEDURE [XDCL] clp$get_non_standard_cmnd_line
    (VAR parse: clt$parse_state;
     VAR end_of_input: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      command_prompt_ptr: ^clt$prompt_string,
      command_prompt_string: ift$prompt_string,
      continuation_line: ^clt$command_line,
      continuation_line_size: integer,
*IF $true(osv$unix)
      handler_stat: boolean,
*IFEND
      line: ^clt$command_line,
      line_continued: boolean,
      line_size: integer;

?? NEWTITLE := 'terminate_handler', EJECT ??

    PROCEDURE terminate_handler
*IF NOT $true(osv$unix)
      (    condition: pmt$condition;
           ignore_condition_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN
*ELSE
      (    signal_no: integer;
           code: integer;
           p_sigcontext: ^cyt$mips_sigcontext);

      VAR
        local_status: ost$status;


      CASE signal_no OF
      { pmc$block_exit_processing    -    block exit
      = -1 =
*IFEND
        osp$set_status_abnormal ('CL', cle$command_line_cancelled, '', status);
*IF NOT $true(osv$unix)
        osp$generate_output_message (status, handler_status);
        handler_status.normal := TRUE;
*ELSE
        osp$generate_message (status, local_status);
*IFEND
        clp$set_input_line (clc$command_line, ^line^ (1, 0), block^.line_identifier,
              block^.input.record_number, block^.input.line_address);
        status.normal := TRUE;
        end_of_input := FALSE;
        parse := block^.line_parse;
*IF NOT $true(osv$unix)
        EXIT clp$get_non_standard_cmnd_line;
      IFEND;

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

    PROCEND terminate_handler;
?? OLDTITLE, EJECT ??
*IF NOT $true(osv$unix)
    VAR
      context: ^ost$ecp_exception_context;
*IFEND

    status.normal := TRUE;
*IF NOT $true(osv$unix)
    context := NIL;
*IFEND
    end_of_input := TRUE;

    clp$find_input_block (TRUE, block);
    IF block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$get_non_standard_cmnd_line', status);
      RETURN;
    IFEND;

    IF block^.input.state = clc$end_of_input THEN
      RETURN;
    IFEND;

    IF block^.input.prompting_input THEN
      command_prompt_string.size := clc$same_line_prompt_size;
      command_prompt_string.value := clc$same_line_prompt;
      command_prompt_ptr := ^command_prompt_string.value (1, clc$same_line_prompt_size);
    ELSE
      command_prompt_string.size := block^.input.base_prompt_string.size + 1;
      command_prompt_string.value := block^.input.base_prompt_string.value;
      ?IF clc$compiling_for_test_harness THEN
        command_prompt_string.value (command_prompt_string.size) := '!';
      ?ELSE
        command_prompt_string.value (command_prompt_string.size) := '/';
      ?IFEND;
      command_prompt_ptr := ^command_prompt_string.value (2, command_prompt_string.size - 1);
    IFEND;

    REPEAT
      clp$get_non_standard_line (clc$command_line, command_prompt_ptr^, status);
*IF NOT $true(osv$unix)
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
*ELSE
    UNTIL status.normal;
*IFEND
    IF (NOT status.normal) OR (block^.input.state = clc$end_of_input) THEN
      RETURN;
    IFEND;
    line := block^.input.line.text;

*IF $true(osv$unix)
    IF (STRLENGTH (line^) < 1) OR (line^ (STRLENGTH (line^), 1) <> '\') THEN
*ELSE
    IF (STRLENGTH (line^) < 2) OR (line^ (STRLENGTH (line^) - 1, 2) <> '..') THEN
*IFEND
      parse := block^.line_parse;
      end_of_input := FALSE;
      RETURN;
    IFEND;

    IF block^.input.prompting_input THEN
      command_prompt_string.size := clc$cont_same_line_prompt_size;
      command_prompt_string.value := clc$continued_same_line_prompt;
      command_prompt_ptr := ^command_prompt_string.value (1, clc$cont_same_line_prompt_size);
    ELSE
      ?IF clc$compiling_for_test_harness THEN
        command_prompt_string.value (command_prompt_string.size, 3) := '..!';
      ?ELSE
        command_prompt_string.value (command_prompt_string.size, 3) := '../';
      ?IFEND;
      command_prompt_string.size := command_prompt_string.size + 2;
      command_prompt_ptr := ^command_prompt_string.value (2, command_prompt_string.size - 1);
    IFEND;
*IF $true(osv$unix)
    line_size := STRLENGTH (line^) - 1;
    WHILE (line_size > 0) AND (line^ (line_size) = '\') DO
*ELSE
    line_size := STRLENGTH (line^) - 2;
    WHILE (line_size > 0) AND (line^ (line_size) = '.') DO
*IFEND
      line_size := line_size - 1;
    WHILEND;

    IF (block^.input.kind = clc$file_input) AND block^.input.interactive_device THEN
*IF NOT $true(osv$unix)
      osp$establish_condition_handler (^terminate_handler, FALSE);
*ELSE
{ The following code SHOULD simulate a condition handler for terminate break -
{ a block exit handler is established around the call to clp$get_non_standard_
{ line. If a terminate break is entered during that request, we'll catch it
{ after the fact in the following REPEAT loop and do the cleanup that would
{ normally happen for a terminate break. The condition (signal) is eaten.

      handler_stat := #establish_condition_handler (-1, ^terminate_handler);
{     IF NOT handler_stat THEN
{       stringrep(ps_line,ps_length,'Handler status was ',handler_stat);
{       print_string(ps_line,ps_length);
{     IFEND;
*IFEND
    IFEND;

    REPEAT
      REPEAT
        clp$get_non_standard_line (clc$command_continuation_line, command_prompt_ptr^, status);
*IF NOT $true(osv$unix)
        IF NOT status.normal THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
*ELSE
      IF osc_sigint IN osv$signal THEN
        osv$signal := osv$signal - $ost$signals [osc_sigint];
        RETURN;
      IFEND;
      UNTIL status.normal;
      handler_stat := #disestablish_condition_handler (-1);
*IFEND
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      continuation_line := block^.input.data_line.text;
      IF continuation_line = NIL THEN
        osp$set_status_abnormal ('CL', cle$expecting_continuation_line, '', status);
        RETURN;
      IFEND;
      continuation_line_size := STRLENGTH (continuation_line^);
*IF $true(osv$unix)
      line_continued := (continuation_line_size >= 1) AND (continuation_line^
            (continuation_line_size, 1) = '\');
      IF line_continued THEN
        continuation_line_size := continuation_line_size - 1;
        WHILE (continuation_line_size > 0) AND (continuation_line^ (continuation_line_size) = '\') DO
*ELSE
      line_continued := (continuation_line_size >= 2) AND (continuation_line^
            (continuation_line_size - 1, 2) = '..');
      IF line_continued THEN
        continuation_line_size := continuation_line_size - 2;
        WHILE (continuation_line_size > 0) AND (continuation_line^ (continuation_line_size) = '.') DO
*IFEND
          continuation_line_size := continuation_line_size - 1;
        WHILEND;
      IFEND;
      IF (line_size + continuation_line_size) > clc$max_command_line_size THEN
        osp$set_status_abnormal ('CL', cle$continued_line_too_long, '', status);
        RETURN;
      IFEND;
      clp$append_continuation_line (line_size, continuation_line_size, line);
      line_size := line_size + continuation_line_size;
    UNTIL NOT line_continued;

    clp$set_input_line (clc$command_line, line, block^.line_identifier, block^.input.record_number,
          block^.input.line_address);

    parse := block^.line_parse;
    end_of_input := FALSE;

  PROCEND clp$get_non_standard_cmnd_line;
?? TITLE := 'preprocess_command_line', EJECT ??

  PROCEDURE [XDCL] clp$preprocess_command_line
    (    line_preprocessor_descriptor: clt$utility_line_preproc_desc;
         line: ^clt$command_line;
         interactive_file: boolean;
     VAR edited_line: ^clt$command_line;
     VAR status: ost$status);

    VAR
*IF NOT $true(osv$unix)
      callers_save_area: ^ost$stack_frame_save_area,
*IFEND
      current_block: ^clt$block,
*IF NOT $true(osv$unix)
      line_preprocessor: clt$utility_line_preprocessor,
      loaded_address: pmt$loaded_address;
*ELSE
      line_preprocessor: clt$utility_line_preprocessor;
*IFEND

*IF NOT $true(osv$unix)
?? NEWTITLE := 'bad_line_preprocessor_handler', EJECT ??

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

      VAR
        line_preprocessor_name: pmt$program_name;


      IF (condition.selector = pmc$system_conditions) AND (($pmt$system_conditions
            [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
            pmc$environment_specification, pmc$invalid_segment_ring_0, pmc$out_call_in_return] *
            condition.system_conditions) <> $pmt$system_conditions []) THEN
        IF save_area^.minimum_save_area.a2_previous_save_area = callers_save_area THEN
          IF line_preprocessor_descriptor.call_method = clc$unlinked_call THEN
            line_preprocessor_name := line_preprocessor_descriptor.procedure_name;
          ELSE
            line_preprocessor_name := '';
          IFEND;
          osp$set_status_abnormal ('CL', cle$unable_to_call_preprocessor, line_preprocessor_name, status);
          EXIT clp$preprocess_command_line;
        IFEND;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND bad_line_preprocessor_handler;
*IFEND
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    edited_line := NIL;

    CASE line_preprocessor_descriptor.call_method OF
    = clc$unspecified_call =
      RETURN;
    = clc$linked_call =
      line_preprocessor := line_preprocessor_descriptor.proc;
*IF NOT $true(osv$unix)
    = clc$unlinked_call =
      pmp$load (line_preprocessor_descriptor.procedure_name, pmc$procedure_address, loaded_address, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal ('CL', cle$unable_to_call_preprocessor,
              line_preprocessor_descriptor.procedure_name, status);
        RETURN;
      IFEND;
      #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, line_preprocessor);
*IFEND
    ELSE

{ Should never get here.

      osp$set_status_abnormal ('CL', cle$unable_to_call_preprocessor, '', status);
      RETURN;
    CASEND;

    clp$find_current_block (current_block);

*IF NOT $true(osv$unix)
    callers_save_area := #PREVIOUS_SAVE_AREA ();
    #SPOIL (callers_save_area);
    osp$establish_condition_handler (^bad_line_preprocessor_handler, FALSE);
*IFEND
    line_preprocessor^ (line, interactive_file, (current_block^.interpreter_mode = clc$interpret_mode),
          edited_line, status);
*IF NOT $true(osv$unix)
    osp$disestablish_cond_handler;
*IFEND
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF edited_line <> NIL THEN
      edited_line := ^edited_line^ (1, clp$trimmed_string_size (edited_line^));
    IFEND;

  PROCEND clp$preprocess_command_line;
?? TITLE := 'clp$get_command_line', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$get_command_line
    (VAR parse: clt$parse_state;
     VAR end_of_input: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
*IF NOT $true(osv$unix)
      context: ^ost$ecp_exception_context,
*IFEND
      edited_line: ^clt$command_line;


    status.normal := TRUE;
*IF NOT $true(osv$unix)
    context := NIL;
*IFEND
    end_of_input := TRUE;

    clp$find_input_block (TRUE, block);
    IF block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$get_command_line', status);
      RETURN;
    IFEND;

    IF (block^.input.kind = clc$line_input) OR (block^.input.state = clc$end_of_input) THEN
      RETURN;
    IFEND;

    WHILE TRUE DO
      REPEAT
        block^.input.get_command_line^ (parse, end_of_input, status);
*IF NOT $true(osv$unix)
        IF NOT status.normal THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
*ELSE
      UNTIL status.normal;

*IFEND
      IF (NOT status.normal) OR end_of_input OR block^.input.prompting_input OR
            (NOT block^.line_preprocessor_specified) THEN
        RETURN;
      IFEND;

      clp$preprocess_command_line (block^.associated_utility^.line_preprocessor, parse.text,
            (block^.input.kind = clc$file_input) AND block^.input.interactive_device, edited_line, status);
      IF (NOT status.normal) OR (edited_line = NIL) THEN
        RETURN;
      IFEND;

      IF edited_line^ <> '' THEN
        clp$set_input_line (clc$command_line, edited_line, block^.line_identifier, block^.input.record_number,
              block^.input.line_address);
        parse := block^.line_parse;
        RETURN;
      IFEND;
    WHILEND;

  PROCEND clp$get_command_line;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$get_semicolon_after_command', EJECT ??
*copyc clh$get_semicolon_after_command

  PROCEDURE [XDCL, #GATE] clp$get_semicolon_after_command
    (VAR semicolon_after_command: boolean;
     VAR status: ost$status);

    VAR
      input_block: ^clt$block;


    status.normal := TRUE;
    clp$find_external_input_block (input_block);
    semicolon_after_command := (input_block <> NIL) AND (input_block^.line_parse.previous_non_space_unit.
          kind = clc$lex_semicolon);

  PROCEND clp$get_semicolon_after_command;
?? TITLE := 'clp$push_interactive_input', EJECT ??
*copyc clh$push_interactive_input

  PROCEDURE [XDCL, #GATE] clp$push_interactive_input
    (VAR status: ost$status);

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

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


      clp$close_command_file (file_id, opened_executable_file, handler_status);
      handler_status.normal := TRUE;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      caller_id: ost$caller_identifier,
      can_be_echoed: boolean,
      device_class: rmt$device_class,
      dummy_segment: ^SEQ ( * ),
      file_has_fap: boolean,
      file_id: amt$file_identifier,
      ignore_file_contents: clt$file_contents,
      ignore_path_handle_name: fst$path_handle_name,
      ignore_ring_attributes: amt$ring_attributes,
      input_block: ^clt$block,
      job_mode: jmt$job_mode,
      line_layout: clt$line_layout,
      local_status: ost$status,
      opened_executable_file: boolean,
      utility_name: ost$name;


    status.normal := TRUE;
    local_status.normal := TRUE;
    #CALLER_ID (caller_id);

    input_block := NIL;
    file_id := amv$nil_file_identifier;
    #SPOIL (file_id);

    osp$establish_block_exit_hndlr (^abort_handler);

  /push_input/
    BEGIN
      pmp$get_job_mode (job_mode, local_status);
      IF NOT local_status.normal THEN
        EXIT /push_input/;
      IFEND;
      IF (job_mode = jmc$batch) AND (NOT jmp$system_job ()) THEN
        osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$push_interactive_input', local_status);
        EXIT /push_input/;
      IFEND;

      clp$access_command_file (clc$include_file, caller_id.ring,
            clv$standard_files [clc$sf_command_file].path_handle_name, file_id, dummy_segment,
            opened_executable_file, can_be_echoed, line_layout, ignore_file_contents, ignore_ring_attributes,
            file_has_fap, device_class, ignore_path_handle_name, local_status);
      IF NOT local_status.normal THEN
        EXIT /push_input/;
      IFEND;

      clp$find_input_block (TRUE, input_block);
      IF (input_block <> NIL) AND (input_block^.associated_utility <> NIL) THEN
        utility_name := input_block^.associated_utility^.label;
      ELSE
        utility_name := osc$null_name;
      IFEND;
      input_block := NIL;

      clp$push_input_file_block (clv$standard_files [clc$sf_command_file].path_handle_name, file_id,
            utility_name, '', can_be_echoed, line_layout, device_class, file_has_fap, FALSE,
            input_block);
    END /push_input/;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND clp$push_interactive_input;
?? TITLE := 'clp$pop_interactive_input', EJECT ??
*copyc clh$pop_interactive_input

  PROCEDURE [XDCL, #GATE] clp$pop_interactive_input
    (VAR status: ost$status);

    VAR
      file_id: amt$file_identifier,
      input_block: ^clt$block,
      local_status: ost$status;


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

  /pop_input/
    BEGIN
      clp$find_current_block (input_block);
      IF (input_block = NIL) OR (input_block^.kind <> clc$input_block) OR
            (input_block^.input.kind <> clc$file_input) OR (input_block^.input.local_file_name <>
            clv$standard_files [clc$sf_command_file].path_handle_name) OR
            (NOT input_block^.input.interactive_device) THEN
        osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$pop_interactive_input', local_status);
        EXIT /pop_input/;
      IFEND;
      file_id := input_block^.input.file_id;
      clp$pop_input_stack (input_block, local_status);
      IF NOT local_status.normal THEN
        EXIT /pop_input/;
      IFEND;
      clp$close_command_file (file_id, FALSE, local_status);
    END /pop_input/;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND clp$pop_interactive_input;
*IFEND

MODEND clm$input_procedures;
*DECK DECK=CLM$INPUT_STACK_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Input Stack Manager' ??
MODULE clm$input_stack_manager;

{
{ PURPOSE:
{   This module contains procedures that manage the SCL input stack.
{
{ DESIGN:
{   The input stack consists of a subset of the information in the block stack.
{   Block stack frames of type command/function proc, input or when comprise
{   the input stack.  Each input stack frame is created, used and deleted by a
{   single task and can therefore contain the file_identifier needed to access
{   a file subsequent to opening it.
{
{ NOTE:
{   This module used to contain the procedure that created input stack frames
{   (clp$push_inpout_stack).  This routine has been split up into specialized
{   procedures, one for each of the flavors of input blocks.  These specialized
{   procedures can be found in module clm$block_stack_manager where they are to
{   use common inline routines for creating blocks.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc amt$local_file_name
*IF NOT $true(osv$unix)
*copyc clc$change_secure_logging_name
*IFEND
*copyc clc$compiling_for_test_harness
*copyc clc$lexical_units_size_pad
*IF NOT $true(osv$unix)
*copyc clc$system_logging_active_name
*IFEND
*copyc cle$ecc_command_processing
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_utilities
*IF NOT $true(osv$unix)
*copyc clk$procedure_keypoints
*IFEND
*copyc clt$collect_statement_area
*copyc clt$command_line
*copyc clt$command_line_size
*copyc clt$command_name
*copyc clt$input_line_kind
*copyc clt$lexical_units
*IF NOT $true(osv$unix)
*copyc jmt$job_mode
*copyc ofe$error_codes
*copyc osc$volume_unavailable_cond
*copyc osd$virtual_address
*copyc ose$heap_full_exceptions
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc ost$caller_identifier
*IFEND
*copyc ost$status
?? POP ??
*copyc amp$get_next
*copyc amp$get_partial
*IF NOT $true(osv$unix)
*copyc amp$seek_direct
*IFEND
*copyc amv$nil_file_identifier
*IF NOT $true(osv$unix)
*copyc avp$system_operator
*IFEND
*copyc clp$append_expandable_string
*copyc clp$delete_expandable_string
*copyc clp$find_current_block
*copyc clp$find_input_block
*copyc clp$get_interpreter_mode
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*copyc clp$open_command_file
*copyc clp$pop_block_stack
*copyc clp$store_expandable_string
*copyc clp$update_parse_state
*IF NOT $true(osv$unix)
*copyc clv$system_logging_activated
*IFEND
*copyc fsp$close_file
*copyc i#current_sequence_position
*IF NOT $true(osv$unix)
*copyc jmp$log_edited_login_command
*copyc jmv$executing_within_system_job
*copyc ofp$display_status_message
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$get_condition_status
*ELSE
*copyc osp$append_status_file
*IFEND
*copyc osp$increment_locked_variable
*copyc osp$set_status_abnormal
*IF NOT $true(osv$unix)
*copyc osp$set_status_from_condition
*copyc osp$verify_system_privilege
*IFEND
*copyc osv$task_shared_heap
*IF NOT $true(osv$unix)
*copyc pmp$abort
*copyc pmp$continue_to_cause
*copyc pmp$log_ascii
*copyc syp$store_system_constant
*IFEND

*IF NOT $true(osv$unix)
?? TITLE := 'clp$open_executable_cmnd_file', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$open_executable_cmnd_file
    (    file_reference: fst$file_reference;
         job_mode: jmt$job_mode;
         access_level: amc$record .. amc$segment;
         file_access_modes: clt$command_file_access_modes;
         attribute_validation: ^fst$file_cycle_attributes;
     VAR file_id: amt$file_identifier;
     VAR sequence: ^SEQ ( * );
     VAR status: ost$status);

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

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


      fsp$close_file (file_id, handler_status);
      handler_status.normal := TRUE;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    file_id := amv$nil_file_identifier;
    #SPOIL (file_id);
    osp$establish_block_exit_hndlr (^abort_handler);
    clp$open_command_file (file_reference, job_mode, access_level, file_access_modes, attribute_validation,
          {allowed_device_classes} -$fst$device_classes [], file_id, sequence, status);
    osp$disestablish_cond_handler;

  PROCEND clp$open_executable_cmnd_file;
?? TITLE := 'clp$close_executable_cmnd_file', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$close_executable_cmnd_file
    (    file_id: amt$file_identifier;
     VAR status: ost$status);


    fsp$close_file (file_id, status);

  PROCEND clp$close_executable_cmnd_file;
?? TITLE := 'clp$set_prompting_input', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_prompting_input;

    VAR
      block: ^clt$block,
      status: ^ost$status;


    clp$find_input_block (FALSE, block);
    IF block = NIL THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$set_prompting_input', status^);
      pmp$abort (status^);
    IFEND;

    block^.input.prompting_input := TRUE;

  PROCEND clp$set_prompting_input;
*IFEND
?? TITLE := 'clp$pop_input_stack', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$pop_input_stack
    (VAR block: ^clt$block;
     VAR status: ost$status);

    VAR
      current_block: ^clt$block;


*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, 0, clk$pop_input_stack);
*IFEND

    status.normal := TRUE;
    clp$find_current_block (current_block);

  /pop_non_input_blocks/
    WHILE TRUE DO
      CASE current_block^.kind OF
*IF NOT $true(osv$unix)
      = clc$command_proc_block, clc$function_proc_block, clc$input_block, clc$when_block =
*ELSE
      = clc$input_block =
*IFEND
        EXIT /pop_non_input_blocks/;
      = clc$task_block =
        osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$pop_input_stack', status);
*IF NOT $true(osv$unix)
        pmp$abort (status);
*ELSE
        RETURN;
*IFEND
      ELSE
        clp$pop_block_stack (current_block);
      CASEND;
    WHILEND /pop_non_input_blocks/;

    clp$pop_block_stack (current_block);
    block := current_block;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, 0, clk$pop_input_stack);
*IFEND

  PROCEND clp$pop_input_stack;
?? TITLE := 'clp$push_command_line', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$push_command_line
    (    line: ^clt$command_line;
         lexical_units: ^clt$lexical_units;
     VAR input_block: ^clt$block);

    VAR
      block: ^clt$block,
      pushed_line: ^clt$pushed_line;


    clp$find_input_block (FALSE, block);
    input_block := block;

    IF block = NIL THEN
      RETURN;
    IFEND;

    ALLOCATE pushed_line IN osv$task_shared_heap^;

    pushed_line^.previous := block^.input.pushed_line;
    pushed_line^.line := block^.input.line;
    pushed_line^.parse := block^.line_parse;
    block^.input.pushed_line := pushed_line;

    block^.input.line.area := NIL;
    block^.input.line.text := NIL;
    block^.input.line.lexical_units := NIL;
    clp$store_expandable_string (line, lexical_units, block^.input.line);

    clp$initialize_parse_state (block^.input.line.text, block^.input.line.lexical_units, block^.line_parse);

  PROCEND clp$push_command_line;
?? TITLE := 'clp$pop_command_line', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$pop_command_line;

    VAR
      block: ^clt$block,
      pushed_line: ^clt$pushed_line,
      status: ^ost$status;


    clp$find_input_block (FALSE, block);
    IF (block = NIL) OR (block^.input.pushed_line = NIL) THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$pop_command_line', status^);
*IF NOT $true(osv$unix)
      pmp$abort (status^);
*ELSE
      RETURN;
*IFEND
    IFEND;

    clp$delete_expandable_string (block^.input.line);

    pushed_line := block^.input.pushed_line;
    block^.input.pushed_line := pushed_line^.previous;
    block^.input.line := pushed_line^.line;
    block^.line_parse := pushed_line^.parse;

    FREE pushed_line IN osv$task_shared_heap^;

  PROCEND clp$pop_command_line;
*IF NOT $true(osv$unix)
?? TITLE := 'get_next_segment_line_v0', EJECT ??

  PROCEDURE [INLINE] get_next_segment_line_v0
    (VAR data {input, output} : ^clt$input_data;
     VAR line_text: ^clt$command_line);

    VAR
      line_size: ^clt$command_line_size;


    NEXT line_size IN data;
    IF line_size = NIL THEN
      line_text := NIL;
    ELSE
      NEXT line_text: [line_size^] IN data;
    IFEND;

  PROCEND get_next_segment_line_v0;
?? TITLE := 'clp$get_segment_line_v0', EJECT ??
{
{ PURPOSE:
{   This procedure handles SCL input requests directed toward an "old format"
{   SCL procedure on an object library.
{
{ NOTE:
{   This procedure assumes that the lines it reads have no trailing spaces.
{
{ NOTE:
{   This procedure is #GATEd to allow construction of a pointer to it that
{   allows the procedure to be called from above the ring of execution of
{   this module.
{

  PROCEDURE [XDCL, #GATE] clp$get_segment_line_v0
    (    ignore_line_kind: clt$input_line_kind;
         ignore_prompt_string: clt$prompt_string;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      data: ^clt$input_data,
      line_text: ^clt$command_line;

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

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

      CASE condition.selector OF
      = mmc$segment_access_condition =
        IF condition.segment_access_condition.identifier = mmc$sac_io_read_error THEN
          osp$get_condition_status (condition_information, status);
          EXIT clp$get_segment_line_v0;
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          EXIT clp$get_segment_line_v0;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$find_input_block (TRUE, block);
    IF (block = NIL) OR (block^.input.kind = clc$line_input) OR (block^.input.data = NIL) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$get_segment_line_v0', status);
      RETURN;
    IFEND;

    IF block^.input.state = clc$end_of_input THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^abort_handler, FALSE);

    data := block^.input.data;
    get_next_segment_line_v0 (data, line_text);
    IF line_text = NIL THEN
      block^.input.state := clc$end_of_input;
      RETURN;
    IFEND;

    clp$store_expandable_string (line_text, NIL, block^.input.data_line);

    block^.input.record_number := block^.input.record_number + 1;
    block^.input.line_address_is_for_previous := FALSE;
    block^.input.line_address := i#current_sequence_position (data);
    block^.input.state := clc$continue_input;
    block^.input.data := data;

  PROCEND clp$get_segment_line_v0;
?? TITLE := 'clp$get_segment_cmnd_line_v0', EJECT ??
{
{ PURPOSE:
{   This procedure handles SCL command line input requests directed toward
{   an "old format" SCL procedure on an object library.
{
{ NOTE:
{   This procedure assumes that the lines it reads have no trailing spaces.
{
{ NOTE:
{   This procedure is #GATEd to allow construction of a pointer to it that
{   allows the procedure to be called from above the ring of execution of
{   this module.
{

  PROCEDURE [XDCL, #GATE] clp$get_segment_cmnd_line_v0
    (VAR parse: clt$parse_state;
     VAR end_of_input: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      continuation_line: ^clt$command_line,
      continuation_line_size: clt$command_line_size,
      data: ^clt$input_data,
      lexical_units: ^clt$lexical_units,
      lexical_work_area: ^clt$work_area,
      line: ^clt$command_line,
      line_continued: boolean,
      line_size: clt$command_line_size,
      line_text: ^clt$command_line;

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

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

      CASE condition.selector OF
      = mmc$segment_access_condition =
        IF condition.segment_access_condition.identifier = mmc$sac_io_read_error THEN
          osp$set_status_from_condition ('CL', condition, save_area, status, handler_status);
          EXIT clp$get_segment_cmnd_line_v0;
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          EXIT clp$get_segment_cmnd_line_v0;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    end_of_input := TRUE;

    clp$find_input_block (TRUE, block);
    IF (block = NIL) OR (block^.input.kind = clc$line_input) OR (block^.input.data = NIL) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$get_segment_cmnd_line_v0', status);
      RETURN;
    IFEND;

    IF block^.input.state = clc$end_of_input THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^abort_handler, FALSE);

    data := block^.input.data;
    get_next_segment_line_v0 (data, line);

    IF line = NIL THEN
      block^.input.state := clc$end_of_input;
      RETURN;
    IFEND;

    line_size := STRLENGTH (line^);

    IF (line_size < 2) OR (line^ (line_size - 1, 2) <> '..') THEN
      line_text := line;

    ELSE
      clp$store_expandable_string (line, NIL, block^.input.line);

      line_size := line_size - 2;
      WHILE (line_size > 0) AND (line^ (line_size) = '.') DO
        line_size := line_size - 1;
      WHILEND;

      REPEAT
        get_next_segment_line_v0 (data, continuation_line);
        IF continuation_line = NIL THEN
          osp$set_status_abnormal ('CL', cle$expecting_continuation_line, '', status);
          RETURN;
        IFEND;
        continuation_line_size := STRLENGTH (continuation_line^);
        line_continued := (continuation_line_size >= 2) AND
              (continuation_line^ (continuation_line_size - 1, 2) = '..');
        IF line_continued THEN
          continuation_line_size := continuation_line_size - 2;
          WHILE (continuation_line_size > 0) AND (continuation_line^ (continuation_line_size) = '.') DO
            continuation_line_size := continuation_line_size - 1;
          WHILEND;
        IFEND;
        IF (line_size + continuation_line_size) > clc$max_command_line_size THEN
          osp$set_status_abnormal ('CL', cle$continued_line_too_long, '', status);
          RETURN;
        IFEND;
        clp$append_expandable_string (line_size, ^continuation_line^ (1, continuation_line_size),
              block^.input.line);
        line := block^.input.line.text;
        line_size := line_size + continuation_line_size;
      UNTIL NOT line_continued;

      line_text := line;
      line := NIL;
    IFEND;

    PUSH lexical_work_area: [[REP line_size + clc$lexical_units_size_pad OF clt$lexical_unit]];
    RESET lexical_work_area;
    clp$identify_lexical_units (line_text, lexical_work_area, lexical_units, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$store_expandable_string (line, lexical_units, block^.input.line);

    block^.input.record_number := block^.input.record_number + 1;
    block^.line_identifier.byte_address := block^.input.line_address;
    block^.line_identifier.record_number := block^.input.record_number;
    clp$initialize_parse_state (block^.input.line.text, block^.input.line.lexical_units, block^.line_parse);
    block^.input.line_address_is_for_previous := FALSE;
    block^.input.line_address := i#current_sequence_position (data);
    block^.input.state := clc$continue_input;
    block^.input.data := data;

    parse := block^.line_parse;
    end_of_input := FALSE;

  PROCEND clp$get_segment_cmnd_line_v0;
?? TITLE := 'get_next_segment_line', EJECT ??

  PROCEDURE [INLINE] get_next_segment_line
    (    line_kind: clt$input_line_kind;
     VAR data {input, output} : ^clt$input_data;
     VAR lexical_units_array: ^clt$lexical_units;
     VAR line_text: ^clt$command_line);

    VAR
      data_positioner: ^array [1 .. * ] of cell,
      line_header: ^clt$input_data_line_header;


    NEXT line_header IN data;
    lexical_units_array := NIL;
    IF line_header = NIL THEN
      line_text := NIL;
    ELSE
      NEXT line_text: [line_header^.line_size] IN data;
      IF line_header^.number_of_lexical_units > 0 THEN
        NEXT lexical_units_array: [1 .. line_header^.number_of_lexical_units] IN data;
      IFEND;
      IF line_header^.size_of_component_lines_data > 0 THEN
        IF line_kind = clc$command_line THEN
          NEXT data_positioner: [1 .. line_header^.size_of_component_lines_data] IN data;
        ELSE
          NEXT line_header IN data;
          IF line_header = NIL THEN
            line_text := NIL;
          ELSE
            NEXT line_text: [line_header^.line_size] IN data;
            IF line_header^.number_of_lexical_units > 0 THEN
              NEXT lexical_units_array: [1 .. line_header^.number_of_lexical_units] IN data;
            IFEND;
          IFEND;
          lexical_units_array := NIL;
        IFEND;
      IFEND;
    IFEND;

  PROCEND get_next_segment_line;
?? TITLE := 'clp$get_segment_line', EJECT ??
{
{ PURPOSE:
{   This procedure handles SCL input requests directed toward an object
{   library or "internal file".
{
{ NOTE:
{   This procedure assumes that the lines it reads have no trailing spaces.
{
{ NOTE:
{   This procedure is #GATEd to allow construction of a pointer to it that
{   allows the procedure to be called from above the ring of execution of
{   this module.
{

  PROCEDURE [XDCL, #GATE] clp$get_segment_line
    (    ignore_line_kind: clt$input_line_kind;
         ignore_prompt_string: clt$prompt_string;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      data: ^clt$input_data,
      ignore_lexical_units_array: ^clt$lexical_units,
      line_text: ^clt$command_line;

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

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

      CASE condition.selector OF
      = mmc$segment_access_condition =
        IF condition.segment_access_condition.identifier = mmc$sac_io_read_error THEN
          osp$set_status_from_condition ('CL', condition, save_area, status, handler_status);
          EXIT clp$get_segment_line;
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          EXIT clp$get_segment_line;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$find_input_block (TRUE, block);
    IF (block = NIL) OR (block^.input.kind = clc$line_input) OR (block^.input.data = NIL) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$get_segment_line', status);
      RETURN;
    IFEND;

    IF block^.input.state = clc$end_of_input THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^abort_handler, FALSE);

    data := block^.input.data;
    get_next_segment_line (clc$data_line, data, ignore_lexical_units_array, line_text);

    IF line_text = NIL THEN
      block^.input.state := clc$end_of_input;
      RETURN;
    IFEND;

    clp$store_expandable_string (line_text, NIL, block^.input.data_line);

    block^.input.record_number := block^.input.record_number + 1;
    block^.input.line_address_is_for_previous := FALSE;
    block^.input.line_address := i#current_sequence_position (data);
    block^.input.state := clc$continue_input;
    block^.input.data := data;

  PROCEND clp$get_segment_line;
?? TITLE := 'clp$get_segment_cmnd_line', EJECT ??
{
{ PURPOSE:
{   This procedure handles SCL input requests directed toward an object
{   library or "internal file".
{
{ NOTE:
{   This procedure assumes that the lines it reads have no trailing spaces.
{
{ NOTE:
{   This procedure is #GATEd to allow construction of a pointer to it that
{   allows the procedure to be called from above the ring of execution of
{   this module.
{

  PROCEDURE [XDCL, #GATE] clp$get_segment_cmnd_line
    (VAR parse: clt$parse_state;
     VAR end_of_input: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      continuation_line: ^clt$command_line,
      continuation_line_size: clt$command_line_size,
      data: ^clt$input_data,
      data_positioner: ^array [1 .. * ] of cell,
      expandable_string: ^clt$expandable_string,
      lexical_units: ^clt$lexical_units,
      lexical_work_area: ^clt$work_area,
      line: ^clt$command_line,
      line_address_increment: ost$segment_length,
      line_continued: boolean,
      line_header: ^clt$input_data_line_header,
      line_size: clt$command_line_size,
      line_text: ^clt$command_line;

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

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


      CASE condition.selector OF
      = mmc$segment_access_condition =
        IF condition.segment_access_condition.identifier = mmc$sac_io_read_error THEN
          osp$set_status_from_condition ('CL', condition, save_area, status, handler_status);
          EXIT clp$get_segment_cmnd_line;
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          EXIT clp$get_segment_cmnd_line;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    end_of_input := TRUE;

    clp$find_input_block (TRUE, block);
    IF (block = NIL) OR (block^.input.kind = clc$line_input) OR (block^.input.data = NIL) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$get_segment_cmnd_line', status);
      RETURN;
    IFEND;

    IF block^.input.state = clc$end_of_input THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^abort_handler, FALSE);

    data := block^.input.data;
    get_next_segment_line (clc$command_line, data, lexical_units, line);

    IF line = NIL THEN
      block^.input.state := clc$end_of_input;
      RETURN;
    IFEND;

    line_size := STRLENGTH (line^);

    IF ( line_size < 2) OR (line^ ( line_size - 1, 2) <> '..') THEN
      line_text := line;

    ELSE
      clp$store_expandable_string (line, NIL, block^.input.line);

      line_size :=  line_size - 2;
      WHILE (line_size > 0) AND (line^ (line_size) = '.') DO
        line_size := line_size - 1;
      WHILEND;

      REPEAT
        get_next_segment_line (clc$command_continuation_line, data, lexical_units, continuation_line);
        IF continuation_line = NIL THEN
          osp$set_status_abnormal ('CL', cle$expecting_continuation_line, '', status);
          RETURN;
        IFEND;
        continuation_line_size := STRLENGTH (continuation_line^);
        line_continued := (continuation_line_size >= 2) AND
              (continuation_line^ (continuation_line_size - 1, 2) = '..');
        IF line_continued THEN
          continuation_line_size := continuation_line_size - 2;
          WHILE (continuation_line_size > 0) AND (continuation_line^ (continuation_line_size) = '.') DO
            continuation_line_size := continuation_line_size - 1;
          WHILEND;
        IFEND;
        IF (line_size + continuation_line_size) > clc$max_command_line_size THEN
          osp$set_status_abnormal ('CL', cle$continued_line_too_long, '', status);
          RETURN;
        IFEND;
        clp$append_expandable_string (line_size, ^continuation_line^ (1, continuation_line_size),
              block^.input.line);
        line := block^.input.line.text;
        line_size := line_size + continuation_line_size;
      UNTIL NOT line_continued;

      line_text := line;
      line := NIL;
      lexical_units := NIL;
    IFEND;

    IF lexical_units = NIL THEN
      PUSH lexical_work_area: [[REP line_size + clc$lexical_units_size_pad OF clt$lexical_unit]];
      RESET lexical_work_area;
      clp$identify_lexical_units (line_text, lexical_work_area, lexical_units, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    clp$store_expandable_string (line, lexical_units, block^.input.line);

    block^.input.record_number := block^.input.record_number + 1;
    block^.line_identifier.byte_address := block^.input.line_address;
    block^.line_identifier.record_number := block^.input.record_number;
    clp$initialize_parse_state (block^.input.line.text, block^.input.line.lexical_units, block^.line_parse);
    block^.input.line_address_is_for_previous := FALSE;
    block^.input.line_address := i#current_sequence_position (data);
    block^.input.state := clc$continue_input;
    block^.input.data := data;

    parse := block^.line_parse;
    end_of_input := FALSE;

  PROCEND clp$get_segment_cmnd_line;
*IFEND
?? TITLE := 'clp$get_standard_line', EJECT ??
{
{ PURPOSE:
{   This procedure handles SCL input requests directed toward a "standard"
{   record access file.  A "standard" record access file is a mass storage
{   file for which the file_access_procedure (FAP), statement_identifier and
{   line_number attributes are undefined.
{
{ NOTE:
{   This procedure is #GATEd to allow construction of a pointer to it that
{   allows the procedure to be called from above the ring of execution of
{   this module.
{

  PROCEDURE [XDCL, #GATE] clp$get_standard_line
    (    line_kind: clt$input_line_kind;
         ignore_prompt_string: clt$prompt_string;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      expandable_string: ^clt$expandable_string,
      file_position: amt$file_position,
      first_part_of_line: ^array [1 .. clc$nominal_command_line_size] of cell,
      ignore_data: cell,
      ignore_byte_address: amt$file_byte_address,
      ignore_status: ost$status,
      lexical_units: ^clt$lexical_units,
      lexical_units_array: ^clt$lexical_units,
      lexical_work_area: ^clt$work_area,
      line: ^clt$command_line,
      line_address: amt$file_byte_address,
      line_area: ^SEQ ( * ),
      line_text: ^clt$command_line,
*IF NOT $true(osv$unix)
      next_line_area: ^cell,
*ELSE
      next_line_area: ^string(*),
*IFEND
      nominal_line: ^array [1 .. clc$nominal_command_line_size] of cell,
      record_length: amt$max_record_length,
*IF NOT $true(osv$unix)
      transfer_count: amt$transfer_count;
*ELSE
      total_count: amt$transfer_count,
      temp_line_area: ^string(*),
      transfer_count: amt$transfer_count;
*IFEND


*IF NOT $true(osv$unix)
?? NEWTITLE := 'abort_handler', EJECT ??

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

      CASE condition.selector OF
      = mmc$segment_access_condition =
        IF condition.segment_access_condition.identifier = mmc$sac_io_read_error THEN
          osp$set_status_from_condition ('CL', condition, save_area, status, handler_status);
          EXIT clp$get_standard_line;
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          EXIT clp$get_standard_line;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??
*IFEND

    status.normal := TRUE;
    line := NIL;
    lexical_units := NIL;

    clp$find_input_block (TRUE, block);
    IF (block = NIL) OR (block^.input.kind <> clc$file_input) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$get_standard_line', status);
      RETURN;
    IFEND;

    IF block^.input.state = clc$end_of_input THEN
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    osp$establish_condition_handler (^abort_handler, FALSE);

    IF block^.input.state = clc$update_input THEN
      amp$seek_direct (block^.input.file_id, block^.input.line_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF block^.input.line_address_is_for_previous THEN
        amp$get_next (block^.input.file_id, ^ignore_data, 1, transfer_count, ignore_byte_address,
              file_position, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;
*IFEND

*IF NOT $true(osv$unix)
    PUSH line_area: [[REP clc$nominal_command_line_size OF char]];
*ELSE
    PUSH temp_line_area: [clc$nominal_command_line_size];
*IFEND
    line_address := 0;

*IF NOT $true(osv$unix)
    amp$get_next (block^.input.file_id, line_area, clc$nominal_command_line_size, transfer_count,
*ELSE
    amp$get_next (block^.input.file_id, temp_line_area, clc$nominal_command_line_size, transfer_count,
*IFEND
          line_address, file_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

*IF $true(osv$unix)
    line_area := #SEQ(temp_line_area^);
*IFEND

    IF status.normal AND (file_position < amc$eor) AND (block^.input.line_layout.physical_line_size >
          #SIZE (line_area^)) THEN
      RESET line_area;
      NEXT nominal_line IN line_area;
      PUSH line_area: [[REP block^.input.line_layout.physical_line_size OF char]];
      RESET line_area;
      NEXT first_part_of_line IN line_area;
      first_part_of_line^ := nominal_line^;
*IF NOT $true(osv$unix)
      NEXT next_line_area IN line_area;
*ELSE
      NEXT next_line_area: [block^.input.line_layout.physical_line_size -
            clc$nominal_command_line_size] IN line_area;
*IFEND
*IF $true(osv$unix)
      total_count := transfer_count;
*IFEND
      record_length := clc$nominal_command_line_size;

      amp$get_partial (block^.input.file_id, next_line_area,
            block^.input.line_layout.physical_line_size - clc$nominal_command_line_size, record_length,
            transfer_count, ignore_byte_address, file_position, amc$no_skip, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
*IF NOT $true(osv$unix)
      transfer_count := record_length;
*ELSE
      transfer_count := total_count + transfer_count;
*IFEND
    IFEND;

    IF file_position < amc$eor THEN
*IF NOT $true(osv$unix)
      osp$set_status_abnormal ('CL', cle$line_too_long, block^.input.local_file_name, status);
*ELSE
      osp$set_status_abnormal ('CL', cle$line_too_long, '', status);
      osp$append_status_file (osc$status_parameter_delimiter,block^.input.local_file_name, status);
*IFEND
      RETURN;
    IFEND;

    IF line_kind = clc$command_line THEN
      expandable_string := ^block^.input.line;
    ELSE
      expandable_string := ^block^.input.data_line;
    IFEND;

    IF file_position > amc$eor THEN
      block^.input.state := clc$end_of_input;
      RETURN;
    IFEND;

    RESET line_area;
    NEXT line_text: [transfer_count] IN line_area;
    WHILE (transfer_count > 0) AND (line_text^ (transfer_count) = ' ') DO
      transfer_count := transfer_count - 1;
    WHILEND;
    line_text := ^line_text^ (1, transfer_count);

    IF (line_kind <> clc$command_line) OR ((transfer_count >= 2) AND (line_text^ (transfer_count - 1, 2) =
          '..')) THEN
      lexical_units_array := NIL;
    ELSE
      PUSH lexical_work_area: [[REP transfer_count + clc$lexical_units_size_pad OF clt$lexical_unit]];
      RESET lexical_work_area;
      clp$identify_lexical_units (line_text, lexical_work_area, lexical_units_array, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    clp$store_expandable_string (line_text, lexical_units_array, expandable_string^);

    block^.input.record_number := block^.input.record_number + 1;
    IF line_kind = clc$command_line THEN
      block^.line_identifier.byte_address := line_address;
      block^.line_identifier.record_number := block^.input.record_number;
      clp$initialize_parse_state (expandable_string^.text, expandable_string^.lexical_units,
            block^.line_parse);
    IFEND;
    block^.input.line_address_is_for_previous := TRUE;
    block^.input.line_address := line_address;
    block^.input.state := clc$continue_input;

  PROCEND clp$get_standard_line;
?? TITLE := 'clp$get_standard_cmnd_line', EJECT ??
{
{ PURPOSE:
{   This procedure handles SCL input requests directed toward a "standard"
{   record access file.  A "standard" record access file is a mass storage
{   file for which the file_access_procedure (FAP), statement_identifier and
{   line_number attributes are undefined.
{
{ NOTE:
{   This procedure is #GATEd to allow construction of a pointer to it that
{   allows the procedure to be called from above the ring of execution of
{   this module.
{

  PROCEDURE [XDCL, #GATE] clp$get_standard_cmnd_line
    (VAR parse: clt$parse_state;
     VAR end_of_input: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      continuation_line: ^clt$command_line,
      continuation_line_size: integer,
      lexical_units: ^clt$lexical_units,
      lexical_work_area: ^clt$work_area,
      line: ^clt$command_line,
      line_continued: boolean,
      line_size: integer;


    status.normal := TRUE;
    end_of_input := TRUE;

    clp$find_input_block (TRUE, block);
    IF (block = NIL) OR (block^.input.kind <> clc$file_input) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$get_standard_cmnd_line', status);
      RETURN;
    IFEND;

    IF block^.input.state = clc$end_of_input THEN
      RETURN;
    IFEND;

    clp$get_standard_line (clc$command_line, '', status);
    IF (NOT status.normal) OR (block^.input.state = clc$end_of_input) THEN
      RETURN;
    IFEND;
    line := block^.input.line.text;

*IF $true(osv$unix)
    IF (STRLENGTH (line^) < 1) OR (line^ (STRLENGTH (line^), 1) <> '\') THEN
*ELSE
    IF (STRLENGTH (line^) < 2) OR (line^ (STRLENGTH (line^) - 1, 2) <> '..') THEN
*IFEND
      parse := block^.line_parse;
      end_of_input := FALSE;
      RETURN;
    IFEND;

*IF $true(osv$unix)
    line_size := STRLENGTH (line^) - 1;
    WHILE (line_size > 0) AND (line^ (line_size) = '\') DO
*ELSE
    line_size := STRLENGTH (line^) - 2;
    WHILE (line_size > 0) AND (line^ (line_size) = '.') DO
*IFEND
      line_size := line_size - 1;
    WHILEND;

    REPEAT
      clp$get_standard_line (clc$command_continuation_line, '', status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      continuation_line := block^.input.data_line.text;
      IF (continuation_line = NIL) OR (block^.input.state = clc$end_of_input) THEN
        osp$set_status_abnormal ('CL', cle$expecting_continuation_line, '', status);
        RETURN;
      IFEND;
      continuation_line_size := STRLENGTH (continuation_line^);
*IF $true(osv$unix)
      line_continued := (continuation_line_size >= 1) AND (continuation_line^
            (continuation_line_size, 1) = '\');
      IF line_continued THEN
        continuation_line_size := continuation_line_size - 1;
        WHILE (continuation_line_size > 0) AND (continuation_line^ (continuation_line_size) = '\') DO
*ELSE
      line_continued := (continuation_line_size >= 2) AND (continuation_line^
            (continuation_line_size - 1, 2) = '..');
      IF line_continued THEN
        continuation_line_size := continuation_line_size - 2;
        WHILE (continuation_line_size > 0) AND (continuation_line^ (continuation_line_size) = '.') DO
*IFEND
          continuation_line_size := continuation_line_size - 1;
        WHILEND;
      IFEND;
      IF (line_size + continuation_line_size) > clc$max_command_line_size THEN
        osp$set_status_abnormal ('CL', cle$continued_line_too_long, '', status);
        RETURN;
      IFEND;
      clp$append_expandable_string (line_size, ^block^.input.data_line.text^ (1, continuation_line_size),
            block^.input.line);
      line := block^.input.line.text;
      line_size := line_size + continuation_line_size;
    UNTIL NOT line_continued;

    PUSH lexical_work_area: [[REP line_size + clc$lexical_units_size_pad OF clt$lexical_unit]];
    RESET lexical_work_area;
    clp$identify_lexical_units (line, lexical_work_area, lexical_units, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$store_expandable_string (NIL, lexical_units, block^.input.line);
    clp$initialize_parse_state (block^.input.line.text, block^.input.line.lexical_units, block^.line_parse);

    parse := block^.line_parse;
    end_of_input := FALSE;

  PROCEND clp$get_standard_cmnd_line;
?? TITLE := 'clp$append_continuation_line', EJECT ??
{
{ PURPOSE:
{   This procedure is used by clp$get_non_standard_cmnd_line to append a
{   continuation line (contained in the data_line field of an input block) to
{   the end of the corresponding command line.
{

  PROCEDURE [XDCL, #GATE] clp$append_continuation_line
    (    command_line_size: clt$command_line_size;
         continuation_line_size: clt$command_line_size;
     VAR command_line: ^clt$command_line);

    VAR
      block: ^clt$block,
      status: ^ost$status;


    clp$find_input_block (TRUE, block);
    IF (block = NIL) OR (block^.input.kind = clc$line_input) OR (block^.input.line.text = NIL) OR
          (command_line_size > STRLENGTH (block^.input.line.text^)) OR (block^.input.data_line.text = NIL) OR
          (continuation_line_size > STRLENGTH (block^.input.data_line.text^)) THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$append_continuation_line', status^);
*IF NOT $true(osv$unix)
      pmp$abort (status^);
*ELSE
      RETURN;
*IFEND
    IFEND;

    clp$append_expandable_string (command_line_size, ^block^.input.data_line.
          text^ (1, continuation_line_size), block^.input.line);

    command_line := block^.input.line.text;

  PROCEND clp$append_continuation_line;
?? TITLE := 'clp$set_input_line', EJECT ??
{
{ PURPOSE:
{   This procedure is used by clp$get_non_standard_line to save the line it
{   read, along with any associated information, in the current input block.
{
{ NOTE:
{   If line_text is NIL, end of input is assumed.
{

  PROCEDURE [XDCL, #GATE] clp$set_input_line
    (    line_kind: clt$input_line_kind;
         line_text: ^clt$command_line;
         line_identifier: clt$line_identifier;
         record_number: amt$file_byte_address;
         line_address: amt$file_byte_address);

    VAR
      block: ^clt$block,
      expandable_string: ^clt$expandable_string,
      lexical_units_array: ^clt$lexical_units,
      lexical_work_area: ^clt$work_area,
      status: ost$status;


    clp$find_input_block (TRUE, block);
    IF (block = NIL) OR (block^.input.kind <> clc$file_input) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$set_input_line', status);
*IF NOT $true(osv$unix)
      pmp$abort (status);
*ELSE
      RETURN;
*IFEND
    IFEND;

    block^.input.record_number := record_number;
    block^.input.line_address_is_for_previous := TRUE;
    block^.input.line_address := line_address;

    IF line_kind = clc$command_line THEN
      expandable_string := ^block^.input.line;
    ELSE
      expandable_string := ^block^.input.data_line;
    IFEND;

    IF line_text = NIL THEN
      block^.input.state := clc$end_of_input;
      RETURN;
    IFEND;

    IF (line_kind <> clc$command_line) OR ((STRLENGTH (line_text^) >= 2) AND
          (line_text^ (STRLENGTH (line_text^) - 1, 2) = '..')) THEN
      lexical_units_array := NIL;
    ELSE
      PUSH lexical_work_area: [[REP STRLENGTH (line_text^) + clc$lexical_units_size_pad OF clt$lexical_unit]];
      RESET lexical_work_area;
      clp$identify_lexical_units (line_text, lexical_work_area, lexical_units_array, status);
      IF NOT status.normal THEN
*IF NOT $true(osv$unix)
        pmp$abort (status);
*ELSE
        RETURN;
*IFEND
      IFEND;
    IFEND;

    clp$store_expandable_string (line_text, lexical_units_array, expandable_string^);

    IF line_kind = clc$command_line THEN
      block^.line_identifier := line_identifier;
      IF lexical_units_array <> NIL THEN
        clp$initialize_parse_state (expandable_string^.text, expandable_string^.lexical_units,
              block^.line_parse);
      IFEND;
    IFEND;

  PROCEND clp$set_input_line;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$init_input_parse_state', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$init_input_parse_state
    (    lexical_units: ^clt$lexical_units;
     VAR parse: clt$parse_state);

    VAR
      block: ^clt$block,
      status: ^ost$status;


    clp$find_input_block (FALSE, block);
    IF (block = NIL) THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$init_input_parse_state', status^);
      pmp$abort (status^);
    IFEND;

    clp$store_expandable_string (NIL, lexical_units, block^.input.line);

    clp$initialize_parse_state (block^.input.line.text, block^.input.line.lexical_units, block^.line_parse);

    parse := block^.line_parse;

  PROCEND clp$init_input_parse_state;
?? TITLE := 'clp$set_input_line_position', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_input_line_position
    (    line_identifier: clt$line_identifier);

    VAR
      block: ^clt$block,
      data_positioner: ^array [1 .. * ] of cell,
      status: ^ost$status;


    clp$find_input_block (TRUE, block);
    IF block = NIL THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$set_input_line_position', status^);
      pmp$abort (status^);
    IFEND;

    block^.input.line_address_is_for_previous := FALSE;
    block^.input.line_address := line_identifier.byte_address;

    IF block^.input.data <> NIL THEN
      RESET block^.input.data;
      IF block^.input.line_address > 0 THEN
        NEXT data_positioner: [1 .. block^.input.line_address] IN block^.input.data;
      IFEND;
    IFEND;

    block^.line_identifier := line_identifier;
    IF line_identifier.record_number > 0 THEN
      block^.input.record_number := line_identifier.record_number - 1;
    ELSE
      block^.input.record_number := 0;
    IFEND;

    block^.input.state := clc$continue_input;

  PROCEND clp$set_input_line_position;
?? TITLE := 'clp$reset_input_state', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$reset_input_state;

    VAR
      block: ^clt$block,
      status: ^ost$status;

    clp$find_input_block (TRUE, block);
    IF block = NIL THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$reset_input_state', status^);
      pmp$abort (status^);
    IFEND;

    block^.input.state := clc$continue_input;

  PROCEND clp$reset_input_state;
*IFEND
?? TITLE := 'clp$set_input_line_parse', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_input_line_parse
    (    line_parse: clt$parse_state);

    VAR
      block: ^clt$block,
      status: ^ost$status;


    clp$find_input_block (FALSE, block);
    IF block = NIL THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$set_input_line_parse', status^);
*IF NOT $true(osv$unix)
      pmp$abort (status^);
*ELSE
      RETURN;
*IFEND
    IFEND;

    clp$update_parse_state (line_parse, block^.line_parse);

  PROCEND clp$set_input_line_parse;
?? TITLE := 'clp$set_input_line_finished', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_input_line_finished;

    VAR
      block: ^clt$block,
      status: ^ost$status;


    clp$find_input_block (FALSE, block);
    IF (block = NIL) OR (block^.line_parse.text = NIL) THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$set_input_line_finished', status^);
*IF NOT $true(osv$unix)
      pmp$abort (status^);
*ELSE
      RETURN;
*IFEND
    IFEND;

    block^.line_parse.index := block^.line_parse.index_limit;
    block^.line_parse.units_array_index := UPPERBOUND (block^.line_parse.units_array^);
    block^.line_parse.unit.kind := clc$lex_end_of_line;
    block^.line_parse.unit.size := 0;
    block^.line_parse.unit_index := block^.line_parse.index_limit;

  PROCEND clp$set_input_line_finished;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$reset_input_position', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$reset_input_position
    (    line_identifier: clt$line_identifier;
         line_parse: clt$parse_state);

    VAR
      block: ^clt$block,
      status: ^ost$status;


    clp$find_input_block (FALSE, block);
    IF block = NIL THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$reset_input_position', status^);
      pmp$abort (status^);
    IFEND;

    IF (block^.input.kind = clc$line_input) OR (block^.line_identifier.byte_address =
          line_identifier.byte_address) THEN
      clp$update_parse_state (line_parse, block^.line_parse);
      RETURN;
    IFEND;

    block^.input.state := clc$reset_input;
    block^.input.reset_line_identifier := line_identifier;
    block^.input.reset_line_parse := line_parse;

  PROCEND clp$reset_input_position;
*IFEND
?? TITLE := 'clp$set_current_prompt_string', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_current_prompt_string
    (    prompt_string: ift$prompt_string);

    VAR
      status: ^ost$status,
      block: ^clt$block;


    clp$find_input_block (FALSE, block);
    IF (block = NIL) OR (NOT ((block^.input.kind <> clc$line_input) AND (0 <= prompt_string.size) AND
          (prompt_string.size <= UPPERVALUE (prompt_string.size)))) THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$set_current_prompt_string', status^);
*IF NOT $true(osv$unix)
      pmp$abort (status^);
*ELSE
      RETURN;
*IFEND
    IFEND;
    block^.input.current_prompt_string := prompt_string;

  PROCEND clp$set_current_prompt_string;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$set_prev_cmnd_name_and_stat', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_prev_cmnd_name_and_stat
    (    command: ^clt$command_line;
         command_name: clt$command_name;
         command_status: ost$status);

    VAR
      block: ^clt$block;

{ This request is meaningless if called from an asynchronous task.  If this
{ happens and we don't find the input block, ignore the request.

    clp$find_input_block (FALSE, block);
    IF block <> NIL THEN
      clp$store_expandable_string (command, NIL, block^.previous_command);
      block^.previous_command_name := command_name;
      block^.previous_command_status := command_status;
    IFEND;

  PROCEND clp$set_prev_cmnd_name_and_stat;
*IFEND
?? TITLE := 'clp$ignore_rest_of_file', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$ignore_rest_of_file
    (    utility_name: clt$utility_name;
     VAR status: ost$status);

    VAR
      target_block: ^clt$block,
      block: ^clt$block;


    status.normal := TRUE;
    clp$find_current_block (block);
    target_block := block;

  /find_target_block/
    WHILE target_block <> NIL DO
      CASE target_block^.kind OF
      = clc$task_block =
        IF NOT target_block^.synchronous_with_parent THEN
          target_block := NIL;
          EXIT /find_target_block/;
        IFEND;
      = clc$input_block =
        IF target_block^.label = utility_name THEN
          EXIT /find_target_block/;
        IFEND;
      ELSE
        ;
      CASEND;
      target_block := target_block^.previous_block;
    WHILEND /find_target_block/;

    IF target_block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unknown_utility, utility_name, status);
      RETURN;
    IFEND;

    REPEAT
      block^.interpreter_mode := clc$skip_mode;
      block^.being_exited := TRUE;
      IF (block^.kind = clc$input_block) AND (block^.associated_utility <> NIL) THEN
        block^.associated_utility^.termination_command_found := TRUE;
      IFEND;
      block := block^.previous_block;
    UNTIL block = target_block^.previous_block;

  PROCEND clp$ignore_rest_of_file;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$log_command_line', EJECT ??

  VAR
    clv$command_logging_activated: [XDCL, oss$task_shared] boolean := FALSE;

?? SKIP := 3 ??

  PROCEDURE [XDCL, #GATE] clp$log_command_line
    (    line: string ( * );
     VAR status: ost$status);

    VAR
      display_size: 0 .. ofc$max_display_message,
      interpreter_mode: clt$interpreter_modes,
      ascii_logset: pmt$ascii_logset,
      msg_origin: pmt$log_msg_origin;


    status.normal := TRUE;
    IF NOT (clv$command_logging_activated OR jmv$executing_within_system_job) THEN
      RETURN;
    IFEND;

    ?IF NOT clc$compiling_for_test_harness THEN
      IF clv$system_logging_activated OR jmv$executing_within_system_job THEN
        ascii_logset := $pmt$ascii_logset [pmc$job_log, pmc$system_log];
      ELSE
        ascii_logset := $pmt$ascii_logset [pmc$job_log];
      IFEND;
    ?ELSE
      ascii_logset := $pmt$ascii_logset [pmc$job_log];
    ?IFEND;

    clp$get_interpreter_mode (interpreter_mode);
    IF interpreter_mode = clc$interpret_mode THEN
      msg_origin := pmc$msg_origin_command;
    ELSE
      msg_origin := pmc$msg_origin_command_skip;
    IFEND;

    pmp$log_ascii (line, ascii_logset, msg_origin, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (interpreter_mode = clc$interpret_mode) AND (STRLENGTH (line) > 0) THEN
      IF STRLENGTH (line) <= ofc$max_display_message THEN
        display_size := STRLENGTH (line);
      ELSE
        display_size := ofc$max_display_message;
      IFEND;
      ofp$display_status_message (line (1, display_size), status);
    IFEND;

  PROCEND clp$log_command_line;
?? TITLE := 'clp$log_edited_login_command', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$log_edited_login_command
    (VAR status: ost$status);

    VAR
      block: ^clt$block;

    ?IF NOT clc$compiling_for_test_harness THEN
      osp$verify_system_privilege;
    ?IFEND;
    status.normal := TRUE;

    clv$command_logging_activated := TRUE;

    clp$find_current_block (block);
    IF (block^.kind = clc$command_block) AND (block^.command_kind = clc$login_command) THEN
      block^.command_logging_completed := TRUE;
      block^.command_echoing_completed := TRUE;
    IFEND;

    jmp$log_edited_login_command (status);
  PROCEND clp$log_edited_login_command;
?? TITLE := 'clp$set_system_logging_active', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_system_logging_active
    (    activate: boolean;
     VAR status: ost$status);

    status.normal := TRUE;

    IF NOT avp$system_operator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active,'system_operator',status);
      RETURN;
    IFEND;

    syp$store_system_constant (clc$system_logging_active_name, 0, $INTEGER (activate), status);

  PROCEND clp$set_system_logging_active;
?? TITLE := 'clp$set_secure_logging_active', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_secure_logging_active
    (    activate: boolean;
     VAR status: ost$status);


    status.normal := TRUE;
    IF jmv$executing_within_system_job THEN
      syp$store_system_constant (clc$change_secure_logging_name, 0, $INTEGER (activate), status);
    ELSE
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'CHANGE_SECURE_LOGGING', status);
    IFEND;

  PROCEND clp$set_secure_logging_active;
?? TITLE := 'clp$suppress_command_logging', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$suppress_command_logging;

{ This procedure is no longer useful.  It will be removed when all references
{ to it are eliminated.

  PROCEND clp$suppress_command_logging;
*IFEND
?? TITLE := 'clp$change_prompt_string', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$change_prompt_string
    (    new_prompt_string: string ( * );
     VAR old_prompt_string: string (ifc$max_prompt_string_size));

    VAR
      block: ^clt$block,
      ignore_task: boolean,
      status: ^ost$status;


    clp$find_input_block (FALSE, block);
    IF block = NIL THEN
      PUSH status;
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$change_prompt_string', status^);
*IF NOT $true(osv$unix)
      pmp$abort (status^);
*ELSE
      RETURN;
*IFEND
    IFEND;

    old_prompt_string := block^.input.base_prompt_string.value (2, * );
    clp$set_prompt_string (block, new_prompt_string);

  PROCEND clp$change_prompt_string;
?? TITLE := 'clp$set_prompt_string', EJECT ??

  PROCEDURE [XDCL] clp$set_prompt_string
    (    block: ^clt$block;
         prompt_string: string ( * ));

    VAR
      prompt_string_size: integer;


    IF block^.input.interactive_device THEN
      prompt_string_size := STRLENGTH (prompt_string);
      WHILE (prompt_string_size > 0) AND (prompt_string (prompt_string_size) = ' ') DO
        prompt_string_size := prompt_string_size - 1;
      WHILEND;
      IF prompt_string_size > (ifc$max_prompt_string_size - 3 - 1) THEN
        block^.input.base_prompt_string.size := ifc$max_prompt_string_size - 3;
      ELSE
        block^.input.base_prompt_string.size := prompt_string_size + 1;
      IFEND;
      block^.input.base_prompt_string.value (1) := ' ';
      block^.input.base_prompt_string.value (2, * ) := prompt_string;
    ELSE
      block^.input.base_prompt_string.size := 0;
      block^.input.base_prompt_string.value := '';
    IFEND;

  PROCEND clp$set_prompt_string;

MODEND clm$input_stack_manager;
*DECK DECK=CLM$INTERACTIVE_COMMANDS EXPAND=TRUE
*DECK DECK=CLM$INTERPRET_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Main Routine' ??
MODULE clm$interpret_commands;

{
{ PURPOSE:
{   This module contains the main routine of the command language interpreter,
{   i.e. the routine that is called to process the commands for a job.
{
?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$compiling_for_test_harness
*copyc clc$copyright
*copyc clc$standard_file_names
*IF NOT $true(osv$unix)
*copyc cle$ecc_messages_and_prompts
*copyc ift$format_effectors
*copyc jme$job_monitor_conditions
*copyc jme$queued_file_conditions
*copyc ofc$page_width
*copyc osc$timesharing_terminal_file
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc pmd$local_queues
*ELSE
*copyc amt$local_file_name
*copyc clt$standard_files
*copyc ost_standard_file_name
*IFEND
?? POP ??
*IF NOT $true(osv$unix)
*copyc amp$get_file_attributes
*copyc bap$file_command
*IFEND
*copyc clp$add_file_to_command_list
*IF NOT $true(osv$unix)
*copyc clp$begin_utility
*copyc clp$create_variable
*ELSE
*copyc clp$create_heap
*copyc clp$free_heap
*copyc clp$init_builtin_msg_templates
*copyc ost_c_integer
*copyc ost_c_string_p
*copyc osp$default_signal_handler
*copyc osp_delete_screen_output
*IFEND
*copyc clp$define_initial_application
*IF NOT $true(osv$unix)
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$establish_sys_command_lib
*copyc clp$evaluate_parameters
*copyc clp$get_date_string
*copyc clp$get_time_string
*copyc clp$find_current_block
*copyc clp$find_task_block
*copyc clp$get_user_identification
*copyc clp$include_file
*copyc clp$include_line
*copyc clp$internal_cre_file_connect
*copyc clp$login
*copyc clp$put_job_output
*IFEND
*copyc clp$read_command_file
*IF NOT $true(osv$unix)
*copyc clp$request_log_device
*copyc clp$set_processing_phase
*copyc clp$set_working_catalog
*copyc clp$store_std_path_handle_names
*IFEND
*copyc clp$store_system_file_id
*IF NOT $true(osv$unix)
*copyc clp$system_prolog_phase_1
*copyc clp$system_prolog_phase_2
*copyc clp$trimmed_string_size
*IFEND
*copyc clv$initial_application
*copyc clv$standard_files
*IF NOT $true(osv$unix)
*copyc clv$user_identification
*IFEND
*copyc fsp$close_file
*copyc fsp$open_file
*IF NOT $true(osv$unix)
*copyc iip$xt_create_xterm_files
*copyc iip$xt_execute_xterm_command
*copyc iip$xt_initialize_xterm
*copyc jmp$cluster_attach_job_enabled
*copyc jmp$get_job_status
*copyc jmp$get_result_size
*copyc jmp$is_dual_state_job
*copyc jmp$is_xterm_job
*copyc jmp$job_begin
*copyc jmp$job_initialized
*copyc jmp$logout
*copyc jmp$set_job_termination_status
*copyc jmp$system_job
*copyc jmp$timesharing
*copyc ofp$enable_stop_key
*copyc ofp$report_status_error
*copyc osp$append_status_parameter
*copyc osp$check_for_desired_mf_class
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$generate_log_message
*copyc osp$generate_message
*copyc osp$generate_output_message
*copyc osp$get_job_template_name
*copyc osp$idle_resume_system_job
*copyc osp$initialize_virtual_system
*copyc osp$job_template_init_ph1
*copyc osp$job_template_init_ph2
*copyc osp$job_template_init_ph3
*copyc osp$run_virtual_system
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$system_error
*IF NOT $true(osv$unix)
*copyc osv$initial_exception_context
*IFEND
*copyc pmp$continue_to_cause
*copyc pmp$exit
*copyc pmp$find_executing_task_xcb
*copyc pmp$find_stack_segment
*copyc pmp$get_cpu_attributes
*copyc pmp$get_job_mode
*copyc pmp$get_os_version
*copyc pmp$log
*copyc pmp$outward_call
*copyc rap$establish_variables
*copyc rap$intervene_in_deadstart
*copyc rmp$request_null_device
*copyc pmv$debug_logging_enabled
*ELSE
*IFEND

*IF NOT $true(osv$unix)
?? TITLE := 'clp$job_boot', EJECT ??

  PROCEDURE [XDCL] clp$job_boot;

{ This procedure is called by pmp$task_begin.  It is always called in ring 3.
{ It's purpose is to perform as much job initialization as possible that
{ does not require user specific information.  The results of job initialization
{ up to the call to jmp$initialize_job_mode is captured and replicated
{ into future jobs, allowing those jobs to skip most of this procedure.

    VAR
      scope: [STATIC, READ, oss$job_paged_literal] clt$variable_scope := [clc$job_variable],
      job_mode: jmt$job_mode,
      initial_ring: ost$ring,
      stack_segment: ^pmt$stack_segment,
      original_caller_cbp: ^ost$external_code_base_pointer,
      converter: record
        case 0 .. 1 of
        = 0 =
          procedure_pointer: ^procedure,
        = 1 =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend,
      gtid_converter: record
        case boolean of
        = false =
          global_task_id: ost$global_task_id,
        = true =
          integer_value: 0..0ffffff(16),
        casend,
      recend,
      status: ost$status,
      executing_within_system_job: boolean,
      osv$status: clt$variable_reference;

    clp$get_user_identification (status);

    {Skip job initialization if it has been replicated for this job

    IF NOT jmp$job_initialized () THEN

      IF status.normal THEN
        executing_within_system_job := jmp$system_job ();
        pmp$get_job_mode (job_mode, status);
      IFEND;

      IF status.normal THEN
        clp$set_working_catalog ('$LOCAL', status);
      IFEND;

      IF status.normal THEN
        initialize_command_list (executing_within_system_job, status);
      IFEND;

      IF status.normal THEN
        clp$create_variable ('OSV$STATUS', clc$status_value, 0, 1, 1, scope, osv$status, status);
      IFEND;

      IF status.normal AND executing_within_system_job THEN
        osp$job_template_init_ph1;
      IFEND;

      IF status.normal AND (NOT executing_within_system_job) THEN
        clp$system_prolog_phase_1 (status);
      IFEND;

      IF status.normal AND ((job_mode = jmc$batch) OR
            jmp$timesharing ()) THEN
        {Do for batch and standalone interactive
        {Skip for dualstate and xterm interactive
        initialize_standard_files (job_mode, executing_within_system_job, {first_time=} TRUE, status);
      IFEND;

      IF status.normal AND (job_mode <> jmc$batch) AND
            jmp$timesharing () THEN
        {Do for standalone interactive
        {Skip for batch, dualstate and xterm interactive
        initialize_standard_files (job_mode, executing_within_system_job, {first_time=} FALSE, status);
      IFEND;

    IFEND; {NOT job initialized}

    IF status.normal THEN
      jmp$job_begin (initial_ring);

      {Must now transfer control to the correct ring for the
      {job monitor task.

      pmp$find_stack_segment (initial_ring, stack_segment);
      converter.procedure_pointer := ^clp$interpret_commands;
      original_caller_cbp := converter.code_base_pointer;
      pmp$outward_call (original_caller_cbp, initial_ring, NIL,
            NIL, stack_segment); { does not return }
      osp$system_error ('outward call error', NIL);
    ELSE
      osp$system_error ('Job boot error', ^status);
    IFEND;

  PROCEND clp$job_boot;
*IFEND

?? TITLE := 'clp$interpret_commands', EJECT ??

*IF NOT $true(osv$unix)
  PROCEDURE [XDCL] clp$interpret_commands;
*ELSE
  PROCEDURE [XDCL] clp_interpret_commands (
    VAR command_line: string (256);
    VAR stat: ost_c_integer);
*IFEND

    VAR
      continue_after_initial_command: boolean,
*IF $true(osv$unix)
      initial_application: ^clt$command_line,
*IFEND
      initial_command: ^clt$command_line;

    VAR
*IF NOT $true(osv$unix)
      scope: [STATIC, READ, oss$job_paged_literal] clt$variable_scope := [clc$job_variable],
      job_mode: jmt$job_mode,
*ELSE
      handler_stat: boolean,
      heap_name: ost$name,
      signal_number : 1 .. 31,
*IFEND
      system_restart: boolean,
      status: ost$status;

    VAR
*IF NOT $true(osv$unix)
      deadstart_phase: ost$deadstart_phase,
      deadstart_intervention: boolean,
      executing_within_system_job: boolean,
*ELSE
      executing_within_system_job: boolean;
*IFEND
*IF NOT $true(osv$unix)
      ignore_status: ost$status,
      osv$status: clt$variable_reference,
      restricted_mainframe: boolean;
*IFEND


*IF NOT $true(osv$unix)
    executing_within_system_job := jmp$system_job ();
*ELSE
    executing_within_system_job := FALSE;
    heap_name := 'OSV$TASK_SHARED_HEAP';
    status.normal := TRUE;

    FOR signal_number := 1 to 31 DO
      IF (signal_number <> 9) AND       {sigkill}
            (signal_number <> 18) AND   {sigchld}
            (signal_number <> 20) THEN  {sigstop}
        IF NOT #establish_condition_handler (signal_number, ^osp$default_signal_handler) THEN
{??? Doesn't compile, but is this really the correct action?
{         stringrep (ps_line, ps_length, 'Unable to establish a handler for signal number ', signal_number);
{         print_string (ps_line, ps_length);
        IFEND;
      IFEND;
    FOREND;

    clp$create_heap(heap_name);
    clp$init_builtin_msg_templates;
*IFEND
*IF NOT $true(osv$unix)
    pmp$get_job_mode (job_mode, status);
    restricted_mainframe := FALSE;

    IF status.normal AND jmp$is_xterm_job () THEN

{ Xterm files must be created before standard files are initialized so that the
{ standard files are assigned to a terminal device.

      iip$xt_create_xterm_files (status);
    IFEND;

    ?IF clc$compiling_for_test_harness THEN
      IF status.normal THEN
        clp$get_user_identification (status);
      IFEND;

      IF status.normal THEN
        clp$set_working_catalog ('$LOCAL', status);
      IFEND;
*IFEND

      IF status.normal THEN
        initialize_command_list (executing_within_system_job, status);
      IFEND;

*IF NOT $true(osv$unix)
      IF status.normal THEN
        clp$create_variable ('OSV$STATUS', clc$status_value, 0, 1, 1, scope, osv$status, status);
      IFEND;

      IF status.normal THEN
        clp$store_std_path_handle_names (executing_within_system_job, {first_time=} TRUE, status);
      IFEND;
    ?IFEND;

    IF status.normal AND ((job_mode <> jmc$batch) AND (jmp$is_dual_state_job () OR
          jmp$is_xterm_job ())) THEN

{ Do for dualstate interactive, xterm job.

      initialize_standard_files (job_mode, executing_within_system_job, {first_time=} TRUE, status);

    IFEND;

    IF status.normal AND ((job_mode = jmc$batch) OR jmp$is_dual_state_job ()
          OR jmp$is_xterm_job ()) THEN

{ Do for batch, dualstate interactive, xterm job.

     initialize_standard_files (job_mode, executing_within_system_job, {first_time=} FALSE, status);
*ELSE
    IF status.normal THEN
      initialize_standard_files (status);
*IFEND
    IFEND;

*IF NOT $true(osv$unix)
    IF status.normal AND jmp$is_xterm_job () THEN

{ Standard files must be open before the xterm task  begins execution.  The xterm task
{ uses standard files.

       iip$xt_initialize_xterm (status);
    IFEND;

    IF status.normal AND executing_within_system_job THEN
      osp$check_for_desired_mf_class (osc$mc_china_or_soviet_class, restricted_mainframe);

      { For the Soviet Nuclear Safety Systems and China Weather Systems, do not enable the stop key now.
      { It is done later.

      IF NOT restricted_mainframe THEN
        ofp$enable_stop_key;
      IFEND;
      clp$include_line ('$system.change_scl_options prompt_for_parameter_correction=no', FALSE,
            'DEADSTART                      ', ignore_status);
    IFEND;

    IF status.normal AND executing_within_system_job THEN
      osp$job_template_init_ph2 (deadstart_intervention, deadstart_phase);
      rap$establish_variables (ignore_status);
      IF deadstart_intervention THEN
        IF NOT restricted_mainframe THEN

          { For the Soviet Nuclear Safety Systems, don't allow this.

          rap$intervene_in_deadstart (ignore_status);
        IFEND;
      IFEND;
    IFEND;

    IF status.normal AND (job_mode <> jmc$batch) AND (NOT jmp$is_xterm_job ()) THEN
      put_welcome_banner (status);
    IFEND;

    IF NOT status.normal THEN
      osp$system_error ('job init failed', ^status);
    IFEND;

    IF status.normal AND jmp$is_xterm_job () THEN
      iip$xt_execute_xterm_command (status);
    IFEND;

    IF status.normal AND (NOT executing_within_system_job) THEN
      clp$system_prolog_phase_2 (status);
    IFEND;

    IF status.normal AND (NOT executing_within_system_job) THEN
      clp$login (status);
    IFEND;

    IF status.normal AND executing_within_system_job THEN
      osp$job_template_init_ph3;
      clp$system_prolog_phase_1 (ignore_status);
      clp$set_processing_phase (clc$command_phase, ignore_status);
      osp$initialize_virtual_system (deadstart_phase);
      pmp$log (' ---- SYSTEM DEADSTART COMPLETE ----', ignore_status);
      system_restart := FALSE;

    /system_loop/
      WHILE TRUE DO
        osp$run_virtual_system (system_restart, status);
        IF NOT status.normal THEN
          osp$generate_message (status, ignore_status);
        IFEND;

        osp$idle_resume_system_job (status);
        IF NOT status.normal THEN
          osp$generate_message (status, ignore_status);
        IFEND;

        { Control from a RESUMEing system will then return to this point. }
        system_restart := TRUE;
      WHILEND /system_loop/;

      status.normal := TRUE;
    IFEND;

    IF status.normal THEN

    /command_processing_phase/
      BEGIN
*ELSE
    stat := 0;

    initial_application := ^command_line;
    clp$define_initial_application (initial_application, TRUE, status);
    IF NOT status.normal THEN
      stat := status.condition;
      RETURN;
    IFEND;
*IFEND
        IF clv$initial_application.defined THEN
          initial_command := clv$initial_application.application;
          continue_after_initial_command := NOT clv$initial_application.logout_upon_termination;
        ELSE
          initial_command := NIL;
          continue_after_initial_command := FALSE;
        IFEND;
        clp$read_command_file (':$LOCAL.COMMAND.1', osc$null_name, '', TRUE, initial_command,
              continue_after_initial_command, status);
*IF NOT $true(osv$unix)
      END /command_processing_phase/;
    IFEND;

    IF NOT status.normal THEN
      jmp$set_job_termination_status (status);
    IFEND;

    jmp$logout (ignore_status);
*ELSE
    IF NOT status.normal THEN
      stat := status.condition;
    IFEND;
    clp$free_heap (heap_name);

    FOR signal_number := 1 to 31 DO
      IF (signal_number <> 9) AND       {sigkill}
            (signal_number <> 18) AND   {sigchld}
            (signal_number <> 20) THEN  {sigstop}
        IF NOT #disestablish_condition_handler (signal_number) THEN
{ ??? doesn't compile, but maybe we don't care if we can't disestablish a handler?
{         stringrep (ps_line, ps_length, 'Unable to disestablish a handler for signal number ',
{               signal_number);
{         print_string (ps_line, ps_length);
        IFEND;
      IFEND;
    FOREND;

    osp_delete_screen_output;
*IFEND

*IF NOT $true(osv$unix)
  PROCEND clp$interpret_commands;
*ELSE
  PROCEND clp_interpret_commands;
*IFEND
?? TITLE := 'initialize_command_list', EJECT ??

  PROCEDURE initialize_command_list
    (    executing_within_system_job: boolean;
     VAR status: ost$status);

    VAR
*IF NOT $true(osv$unix)
      command_entry_file: clt$command_list_entry_file,
      context: ^ost$ecp_exception_context,
      local_catalog: [STATIC, READ, oss$job_paged_literal] string (7) := ':$LOCAL',
      test_harness_sys_cmnd_lib: [STATIC, READ, oss$job_paged_literal] string (27) :=
            ':$LOCAL.OSF$COMMAND_LIBRARY';
*ELSE
      command_entry_file: clt$command_list_entry_file;
*IFEND


    command_entry_file.kind := clc$command_list_entry_$system;
*IF NOT $true(osv$unix)
    context := NIL;

{Add this back in when $SYSTEM is a command list entry
    REPEAT
      clp$add_file_to_command_list (command_entry_file, FALSE, status);
*IFEND
*IF NOT $true(osv$unix)
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
*ELSE
    status.normal := TRUE;
{   UNTIL status.normal;
*IFEND
    IF NOT status.normal THEN
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    command_entry_file.kind := clc$command_list_entry_path;
    IF executing_within_system_job THEN
      command_entry_file.path := ^local_catalog;
      REPEAT
        clp$add_file_to_command_list (command_entry_file, FALSE, status);
        IF NOT status.normal THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_file_reference;
            context^.file.file_reference := command_entry_file.path;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
    ELSE

      ?IF clc$compiling_for_test_harness THEN
        command_entry_file.path := ^test_harness_sys_cmnd_lib;
        REPEAT
          clp$establish_sys_command_lib (command_entry_file.path, status);
          IF NOT status.normal THEN
            IF context = NIL THEN
              PUSH context;
              context^ := osv$initial_exception_context;
              context^.file.selector := osc$ecp_file_reference;
              context^.file.file_reference := command_entry_file.path;
            IFEND;
            context^.condition_status := status;
            osp$enforce_exception_policies (context^);
            status := context^.condition_status;
          IFEND;
        UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
      ?IFEND;
    IFEND;
*IFEND

  PROCEND initialize_command_list;
*IF NOT $true(osv$unix)
?? TITLE := 'initialize_standard_files', EJECT ??
{
{  PURPOSE:
{    This procedure will initialize file attributes, create file connections, and open standard files.
{    Listed below are the possible options for each file.
{
{
{  $JOB_LOG                                       $NULL
{  --------                                       -----
{  access modes = append, read                    access modes = read, append, modify, shorten
{  share modes = none                             share modes = none
{  open share modes = all                         open share modes = all
{  ring attributes = 13,13,13                     ring attributes = 13,13,13
{  file contents = unknown_unknown                file contents = unknown_unknown
{  file processor = unknown                       file processor = unknown
{  page format = continuous
{  page width = 132 - 16
{
{  INPUT, $INPUT                                  OUTPUT, $OUTPUT, $ERRORS
{  -------------                                  ------------------------
{  access modes = read                            access modes = append, shorten
{  share modes = none                             share modes = none
{  open share modes = read, execute               open share modes = all
{  ring attributes = 13,13,13                     ring attributes = 13,13,13
{  file contents = legible_data                   file contents = list_data
{  file processor = unknown                       file processor = unknown
{  page width = 79  (INPUT only and system job)   page format = continuous or burstable
{  page length = 30 (INPUT only and system job)   open position = no positioning (OUTPUT and $ERRORS only)
{  connected files = INPUT ($INPUT only)          page width = 79  (OUTPUT only and system job)
{                                                 page length = 30 (OUTPUT only and system job)
{                                                 connected files = OUTPUT ($OUTPUT and $ERRORS only)
{                                                                   $JOB_LOG ($ERRORS only in system job)
{
{  $LIST                                          $ECHO, $RESPONSE
{  -----                                          ----------------
{  access modes = append, shorten                 access modes = append, shorten
{  share modes = none                             share modes = none
{  open share modes = all                         open share modes = all
{  ring attributes = 13,13,13                     ring attributes = 13,13,13
{  file contents = list_data                      file contents = list_data
{  file processor = unknown                       file processor = scl
{  page format = burstable                        page format = continuous
{  connected files = OUTPUT or none               open position = no positioning
{                                                 connected files = none ($ECHO only)
{                                                                   $JOB_LOG and possibly
{                                                                   OUTPUT ($RESPONSE only)
{
{  COMMAND                                        DISPLAY_A, DISPLAY_B (system job files only)
{  -------                                        --------------------
{  access modes = read, execute                   file contents = list
{  file contents = legible_data                   page format = continuous
{  file processor = scl                           user info = 'LOG'
{  page width = 79 (system job)                   page width = 79
{  page length = 30 (system job)                  page length = 30
{
*IFEND

  PROCEDURE initialize_standard_files
*IF NOT $true(osv$unix)
    (    job_mode: jmt$job_mode;
         executing_within_system_job: boolean;
         first_time: boolean;
     VAR status: ost$status);
*ELSE
    (VAR status: ost$status);
*IFEND

*IF NOT $true(osv$unix)
    CONST
      osc$display_a = 'DISPLAY_A                      ',
      osc$display_b = 'DISPLAY_B                      ',
      standard_listing_page_width = 132,
      job_log_entry_header_size = 16,
      operator_file_page_length = 30;
*IFEND

    VAR
*IF NOT $true(osv$unix)
      standard_file_names: [STATIC, READ, oss$job_paged_literal] array [clt$standard_files] of
            amt$local_file_name := [clc$job_log, clc$null_file, clc$job_input, clc$standard_input,
            clc$job_output, clc$standard_output, clc$error_output, clc$listing_output, clc$echoed_commands,
            clc$job_command_response, clc$job_command_input, osc$timesharing_terminal_file, osc$display_a,
            osc$display_b, osc$null_name],
*ELSE
      standard_file_names: [STATIC, READ] array [clt$standard_files] of
            amt$local_file_name := [clc$null_file, clc$job_input, clc$standard_input,
            clc$job_output, clc$standard_output, clc$error_output,
            clc$job_command_input, osc$null_name],
*IFEND
      file_attachment: array [1 .. 4] of fst$attachment_option,
*IF NOT $true(osv$unix)
      mandated_creation_attributes: array [1 .. 5] of fst$file_cycle_attribute,
      file_attributes: array [1 .. 6] of amt$file_item,
      connected_file_names: array [1 .. 2] of amt$local_file_name,
*IFEND
      file: clt$standard_files,
      file_name: amt$local_file_name,
*IF NOT $true(osv$unix)
      file_id: amt$file_identifier,
      setfa_attribute: array [1 .. 1] of amt$file_item,
      standard_file: fst$path_handle_name,
*ELSE
      standard_file: ost_standard_file_name,
*IFEND
*IF NOT $true(osv$unix)
      target_file_open_position: fst$open_position,
      page_format: amt$page_format,
      fap_name: pmt$entry_point_reference,
      index: 1 .. 6,
      error_message: string (61),
      message_length: integer,
*IFEND
      open_file: boolean,
      close_file: boolean,
      system_file: boolean,
*IF NOT $true(osv$unix)
      operator_file: boolean,
      number_of_mandated_attributes: 2 .. 5,
      number_of_file_attributes: 0 .. 6,
      number_of_connected_files: 0 .. 2;
*ELSE
      file_id: amt$file_identifier;
*IFEND


*IF NOT $true(osv$unix)
    IF executing_within_system_job OR (job_mode <> jmc$batch) THEN
      page_format := amc$continuous_form;
    ELSE
      page_format := amc$burstable_form;
    IFEND;

    setfa_attribute [1].key := amc$access_mode;
*IFEND

    file_attachment [1].selector := fsc$create_file;
    file_attachment [1].create_file := TRUE;
    file_attachment [2].selector := fsc$access_and_share_modes;
    file_attachment [2].access_modes.selector := fsc$specific_access_modes;
    file_attachment [2].share_modes.selector := fsc$specific_share_modes;
    file_attachment [2].share_modes.value := $fst$file_access_options [];
    file_attachment [3].selector := fsc$open_share_modes;

*IF NOT $true(osv$unix)
    mandated_creation_attributes [1].selector := fsc$ring_attributes;
    mandated_creation_attributes [1].ring_attributes.r1 := osc$user_ring_2;
    mandated_creation_attributes [1].ring_attributes.r2 := osc$user_ring_2;
    mandated_creation_attributes [1].ring_attributes.r3 := osc$user_ring_2;
    mandated_creation_attributes [2].selector := fsc$file_contents_and_processor;
*IFEND

    system_file := FALSE;
    open_file := TRUE;
    close_file := FALSE;
*IF NOT $true(osv$unix)
    target_file_open_position.specified := FALSE;
*IFEND

  /initialize_files/
*IF NOT $true(osv$unix)
    FOR file := clc$sf_job_log_file TO clc$sf_display_b_file DO
*ELSE
    FOR file := clc$sf_null_file TO clc$sf_command_file DO
*IFEND

*IF NOT $true(osv$unix)
      IF NOT first_time THEN
        IF file <> clc$sf_command_file THEN
          CYCLE /initialize_files/;
        IFEND;
      IFEND;
*ELSE
      IF file <> clc$sf_null_file THEN
        CYCLE /initialize_files/;
      IFEND;
*IFEND

*IF NOT $true(osv$unix)
      standard_file := clv$standard_files [file].path_handle_name;
      operator_file := FALSE;
*ELSE
      standard_file := clv$standard_files [file].unix_file_name;
*IFEND
      file_name := standard_file_names [file];

      CASE file OF

*IF NOT $true(osv$unix)
        {  $JOB_LOG

      = clc$sf_job_log_file =
        setfa_attribute [1].access_mode := $pft$usage_selections [pfc$read, pfc$append];

        file_attachment [2].access_modes.value := $fst$file_access_options [fsc$append];
        file_attachment [3].open_share_modes := -$fst$file_access_options [];

        mandated_creation_attributes [2].file_contents := fsc$unknown_contents;
        mandated_creation_attributes [2].file_processor := fsc$unknown_processor;
        mandated_creation_attributes [3].selector := fsc$page_format;
        mandated_creation_attributes [3].page_format := amc$continuous_form;
        mandated_creation_attributes [4].selector := fsc$page_width;
        mandated_creation_attributes [4].page_width := standard_listing_page_width -
              job_log_entry_header_size;
        number_of_mandated_attributes := 4;

        ?IF NOT clc$compiling_for_test_harness THEN
          clp$request_log_device (status);
          IF NOT status.normal THEN
            osp$system_error ('open failed', ^status);
            RETURN;
          IFEND;
        ?IFEND;

        number_of_connected_files := 0;
        close_file := TRUE;
*IFEND

        {  $NULL

      = clc$sf_null_file =
*IF NOT $true(osv$unix)
        rmp$request_null_device (clc$null_file, status);
        IF NOT status.normal THEN
          osp$system_error ('open failed', ^status);
          RETURN;
        IFEND;

        setfa_attribute [1].access_mode := $pft$usage_selections
              [pfc$read, pfc$shorten, pfc$append, pfc$modify];
*IFEND

        file_attachment [2].access_modes.value := $fst$file_access_options
              [fsc$read, fsc$append, fsc$modify, fsc$shorten];
        file_attachment [3].open_share_modes := -$fst$file_access_options [];

*IF NOT $true(osv$unix)
        mandated_creation_attributes [2].file_contents := fsc$unknown_contents;
        mandated_creation_attributes [2].file_processor := fsc$unknown_processor;
        number_of_mandated_attributes := 2;

        number_of_connected_files := 0;

        {  INPUT

      = clc$sf_job_input_file =
        setfa_attribute [1].access_mode := $pft$usage_selections [pfc$read];

        file_attachment [2].access_modes.value := $fst$file_access_options [fsc$read];
        file_attachment [3].open_share_modes := $fst$file_access_options [fsc$read, fsc$execute];

        mandated_creation_attributes [2].file_contents := fsc$legible_data;
        mandated_creation_attributes [2].file_processor := fsc$unknown_processor;
        number_of_mandated_attributes := 2;

        number_of_connected_files := 0;
        operator_file := executing_within_system_job;

        {  $INPUT
        { Access modes, open share modes, file_contents, and file processor are used
        {from the previous open of file INPUT.

      = clc$sf_standard_input_file =
        setfa_attribute [1].access_mode := $pft$usage_selections [pfc$read];

        file_attachment [2].access_modes.value := $fst$file_access_options [fsc$read];
        file_attachment [3].open_share_modes := $fst$file_access_options [fsc$read, fsc$execute];

        mandated_creation_attributes [2].file_contents := fsc$legible_data;
        mandated_creation_attributes [2].file_processor := fsc$unknown_processor;
        number_of_mandated_attributes := 2;
        connected_file_names [1] := clv$standard_files [clc$sf_job_input_file].path_handle_name;
        number_of_connected_files := 1;

        {  OUTPUT

      = clc$sf_job_output_file =
        setfa_attribute [1].access_mode := $pft$usage_selections [pfc$shorten, pfc$append];

        file_attachment [2].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
        file_attachment [3].open_share_modes := -$fst$file_access_options [];

        mandated_creation_attributes [2].file_contents := fsc$list;
        mandated_creation_attributes [2].file_processor := fsc$unknown_processor;
        mandated_creation_attributes [3].selector := fsc$page_format;
        mandated_creation_attributes [3].page_format := page_format;
        number_of_mandated_attributes := 3;

        number_of_connected_files := 0;
        operator_file := executing_within_system_job;
        system_file := TRUE;

        {  $OUTPUT
        { Access modes, open share modes, file contents, file processor,
        {and page format are used from the previous open of file OUTPUT.

      = clc$sf_standard_output_file =
        mandated_creation_attributes [2].file_contents := fsc$list;
        mandated_creation_attributes [2].file_processor := fsc$unknown_processor;
        mandated_creation_attributes [3].selector := fsc$page_format;
        mandated_creation_attributes [3].page_format := page_format;
        number_of_mandated_attributes := 3;
        connected_file_names [1] := clv$standard_files [clc$sf_job_output_file].path_handle_name;
        number_of_connected_files := 1;

        setfa_attribute [1].access_mode := $pft$usage_selections [pfc$shorten, pfc$append];

        file_attachment [2].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
        file_attachment [3].open_share_modes := -$fst$file_access_options [];

        {  $ERRORS
        { Access modes, open share modes, file contents, file processor,
        {and page format are used from the previous open of file OUTPUT.

      = clc$sf_error_file =
        mandated_creation_attributes [2].file_contents := fsc$list;
        mandated_creation_attributes [2].file_processor := fsc$unknown_processor;
        mandated_creation_attributes [3].selector := fsc$page_format;
        mandated_creation_attributes [3].page_format := page_format;
        number_of_mandated_attributes := 3;
        IF executing_within_system_job THEN
          connected_file_names [1] := clv$standard_files [clc$sf_job_output_file].path_handle_name;
          connected_file_names [2] := clv$standard_files [clc$sf_job_log_file].path_handle_name;
          number_of_connected_files := 2;
        ELSE
          connected_file_names [1] := clv$standard_files [clc$sf_job_output_file].path_handle_name;
          number_of_connected_files := 1;
        IFEND;

        setfa_attribute [1].access_mode := $pft$usage_selections [pfc$shorten, pfc$append];

        file_attachment [2].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
        file_attachment [3].open_share_modes := -$fst$file_access_options [];

        system_file := TRUE;

        {  $LIST
        { Access modes, open share modes, file contents, and file processor
        {are used from the previous open of file OUTPUT.

      = clc$sf_list_file =
        mandated_creation_attributes [2].file_contents := fsc$list;
        mandated_creation_attributes [2].file_processor := fsc$unknown_processor;
        mandated_creation_attributes [3].selector := fsc$page_format;
        mandated_creation_attributes [3].page_format := amc$burstable_form;
        number_of_mandated_attributes := 3;

        IF (job_mode = jmc$batch) AND (NOT executing_within_system_job) THEN
          connected_file_names [1] := clv$standard_files [clc$sf_job_output_file].path_handle_name;
        ELSE
          connected_file_names [1] := osc$null_name;
        IFEND;
        number_of_connected_files := 1;

        setfa_attribute [1].access_mode := $pft$usage_selections [pfc$shorten, pfc$append];

        file_attachment [2].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
        file_attachment [3].open_share_modes := -$fst$file_access_options [];

        {  $ECHO
        { Access modes and open share modes are used from the previous open
        {of file OUTPUT.

      = clc$sf_echo_file =
        mandated_creation_attributes [2].file_contents := fsc$list;
        mandated_creation_attributes [2].file_processor := fsc$scl;
        mandated_creation_attributes [3].selector := fsc$page_format;
        mandated_creation_attributes [3].page_format := amc$continuous_form;
        number_of_mandated_attributes := 3;

        setfa_attribute [1].access_mode := $pft$usage_selections [pfc$shorten, pfc$append];

        file_attachment [2].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
        file_attachment [3].open_share_modes := -$fst$file_access_options [];

        connected_file_names [1] := osc$null_name;
        number_of_connected_files := 1;

        system_file := TRUE;

        {  $RESPONSE
        { Access modes, open share modes, file contents, file processor,
        {and page format are used from the previous open of file $ECHO.

      = clc$sf_response_file =
        mandated_creation_attributes [2].file_contents := fsc$list;
        mandated_creation_attributes [2].file_processor := fsc$scl;
        mandated_creation_attributes [3].selector := fsc$page_format;
        mandated_creation_attributes [3].page_format := amc$continuous_form;
        number_of_mandated_attributes := 3;

        IF executing_within_system_job OR (job_mode <> jmc$batch) THEN
          connected_file_names [1] := clv$standard_files [clc$sf_job_output_file].path_handle_name;
          connected_file_names [2] := clv$standard_files [clc$sf_job_log_file].path_handle_name;
          number_of_connected_files := 2;
        ELSE
          connected_file_names [1] := clv$standard_files [clc$sf_job_log_file].path_handle_name;
          number_of_connected_files := 1;
        IFEND;

        setfa_attribute [1].access_mode := $pft$usage_selections [pfc$shorten, pfc$append];

        file_attachment [2].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
        file_attachment [3].open_share_modes := -$fst$file_access_options [];

        system_file := TRUE;

        {  COMMAND

      = clc$sf_command_file =
        IF first_time THEN
          CYCLE /initialize_files/;
        IFEND;
        file_attributes [1].key := amc$access_mode;
        file_attributes [1].access_mode := $pft$usage_selections [pfc$read, pfc$execute];
        file_attributes [2].key := amc$file_contents;
        file_attributes [2].file_contents := amc$legible;
        file_attributes [3].key := amc$file_processor;
        file_attributes [3].file_processor := amc$scl;
        file_attributes [4].key := amc$file_structure;
        file_attributes [4].file_structure := amc$data;
        number_of_file_attributes := 4;

        operator_file := executing_within_system_job;
        open_file := FALSE;

        {  DISPLAY_A

      = clc$sf_display_a_file =
        IF NOT executing_within_system_job THEN
          CYCLE /initialize_files/;
        IFEND;

        file_attributes [1].key := amc$file_contents;
        file_attributes [1].file_contents := amc$list;
        file_attributes [2].key := amc$page_format;
        file_attributes [2].page_format := amc$continuous_form;
        file_attributes [3].key := amc$user_info;
        file_attributes [3].user_info := 'LOG';
        number_of_file_attributes := 3;

        operator_file := TRUE;
        open_file := FALSE;

        {  DISPLAY _B
        { File contents, page format, and user info are used from the previous attribute
        {initialization of file DISPLAY_A.

      = clc$sf_display_b_file =
        IF NOT executing_within_system_job THEN
          CYCLE /initialize_files/;
        IFEND;

        number_of_file_attributes := 3;
        operator_file := TRUE;
        open_file := FALSE;

      = clc$sf_terminal_file =
        CYCLE /initialize_files/;
*IFEND

      CASEND;

*IF NOT $true(osv$unix)
      IF operator_file THEN
        rmp$request_null_device (standard_file, status);
        IF NOT status.normal THEN
          STRINGREP (error_message, message_length, 'rmp$request_null_device on file ', file_name);
          ofp$report_status_error (status, error_message (1, message_length));
          osp$system_error ('open failed', ^status);
          RETURN;
        IFEND;

        IF open_file THEN
          number_of_mandated_attributes := number_of_mandated_attributes + 1;
          mandated_creation_attributes [number_of_mandated_attributes].selector := fsc$page_width;
          mandated_creation_attributes [number_of_mandated_attributes].page_width := ofc$page_width - 1;
          number_of_mandated_attributes := number_of_mandated_attributes + 1;
          mandated_creation_attributes [number_of_mandated_attributes].selector := fsc$page_length;
          mandated_creation_attributes [number_of_mandated_attributes].page_length :=
                operator_file_page_length;
        ELSE
          number_of_file_attributes := number_of_file_attributes + 1;
          file_attributes [number_of_file_attributes].key := amc$page_width;
          file_attributes [number_of_file_attributes].page_width := ofc$page_width - 1;
          number_of_file_attributes := number_of_file_attributes + 1;
          file_attributes [number_of_file_attributes].key := amc$page_length;
          file_attributes [number_of_file_attributes].page_length := operator_file_page_length;
        IFEND;
      IFEND;

      IF system_file THEN
        file_attachment [4].selector := fsc$open_position;
        file_attachment [4].open_position := amc$open_no_positioning;
      ELSE
        file_attachment [4].selector := fsc$null_attachment_option;
      IFEND;
*IFEND

      IF open_file THEN
*IF NOT $true(osv$unix)
        FOR index := number_of_mandated_attributes + 1 TO UPPERBOUND (mandated_creation_attributes) DO
          mandated_creation_attributes [index].selector := fsc$null_attribute;
        FOREND;

        FOR index := 1 TO number_of_connected_files DO
          clp$internal_cre_file_connect (standard_file, connected_file_names [index],
                target_file_open_position, status);
          IF NOT status.normal THEN
            osp$system_error ('file connection failed', ^status);
            RETURN;
          IFEND;
        FOREND;

        fsp$open_file (standard_file, amc$record, ^file_attachment, NIL, ^mandated_creation_attributes, NIL,
              NIL, file_id, status);
*ELSE
        fsp$open_file (standard_file, amc$record, ^file_attachment, file_id, status);
*IFEND
        IF NOT status.normal THEN
*IF NOT $true(osv$unix)
          IF operator_file THEN
            STRINGREP (error_message, message_length, 'fsp$open_file on file ', file_name);
            ofp$report_status_error (status, error_message (1, message_length));
          IFEND;
          osp$system_error ('open failed', ^status);
*ELSE
          RETURN;
*IFEND
        IFEND;

*IF NOT $true(osv$unix)
        IF system_file THEN
*IFEND
          clp$store_system_file_id (file_name, file_id);
*IF NOT $true(osv$unix)
          system_file := FALSE;
        ELSEIF close_file THEN
          fsp$close_file (file_id, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          close_file := FALSE;
        IFEND;

        bap$file_command (standard_file, ^setfa_attribute, status);
        IF NOT status.normal THEN
          IF operator_file THEN
            STRINGREP (error_message, message_length, 'bap$file_command on file ', file_name);
            ofp$report_status_error (status, error_message (1, message_length));
          IFEND;
          osp$system_error ('file_command failed', ^status);
          RETURN;
        IFEND;
*IFEND

      ELSE { NOT open_file
*IF NOT $true(osv$unix)
        FOR index := number_of_file_attributes + 1 TO UPPERBOUND (file_attributes) DO
          file_attributes [index].key := amc$null_attribute;
        FOREND;

        bap$file_command (standard_file, ^file_attributes, status);
        IF NOT status.normal THEN
          IF operator_file THEN
            STRINGREP (error_message, message_length, 'bap$file_command on file ', file_name);
            ofp$report_status_error (status, error_message (1, message_length));
          IFEND;
          osp$system_error ('open failed', ^status);
          RETURN;
        IFEND;
        open_file := TRUE;
*IFEND
      IFEND;
    FOREND /initialize_files/;

  PROCEND initialize_standard_files;
*IF NOT $true(osv$unix)
?? TITLE := 'put_welcome_banner', EJECT ??

  PROCEDURE put_welcome_banner
    (VAR status: ost$status);

    CONST
      max_job_template_msg_part_size = 3 + osc$max_name_size + 1 {'  (name)'} ,
      site_welcome_banner_file = ':$SYSTEM.$SYSTEM.PROLOGS_AND_EPILOGS.WELCOME_BANNER';

    VAR
      contains_data: boolean,
      cpu_attributes: pmt$cpu_attributes,
      cpu_index: 0 .. osc$maximum_processor_number,
      date: ost$string,
      file_attributes: array [1 .. 1] of amt$get_item,
      file_exists: boolean,
      first_cpu: boolean,
      ignore_file_previously_opened: boolean,
      job_count: ost$non_negative_integers,
      job_status_options_p: ^jmt$job_status_options,
      job_status_results_keys_p: ^jmt$results_keys,
      job_status_results_seq_p: ^jmt$work_area,
      job_status_results_p: ^jmt$job_status_results,
      job_status_count: jmt$job_status_count,
      job_template_message_part: ^string ( * <= max_job_template_msg_part_size),
      job_template_name: ost$name,
      job_index: jmt$job_status_count,
      message_status: ost$status,
      os_name: pmt$os_name,
      size_of_sequence: ost$segment_length,
      time: ost$string;

{ Check first for a site-defined welcome banner.  If the file is not empty, include it.
{ If it is empty, that's OK, just put out the copyright message.  If the file doesn't exist
{ or something went wrong in the include process, then put out the standard welcome banner.

    file_attributes [1].key := amc$null_attribute;
    amp$get_file_attributes (site_welcome_banner_file, file_attributes, file_exists,
          ignore_file_previously_opened, contains_data, status);
    IF status.normal AND contains_data THEN
      clp$include_file (site_welcome_banner_file, '', osc$null_name, status);
    IFEND;

    IF status.normal AND file_exists THEN
      clp$put_job_output (clc$copyright, status);
    ELSE
      pmp$get_cpu_attributes (cpu_attributes, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pmp$get_os_version (os_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$get_date_string (date, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$get_time_string (time, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      osp$get_job_template_name (job_template_name);

      osp$set_status_abnormal ('CL', cle$welcome_banner, cpu_attributes.cpu [0].
            model_type (1, clp$trimmed_string_size (cpu_attributes.cpu [0].model_type)), message_status);
      first_cpu := TRUE;

      FOR cpu_index := 0 TO cpu_attributes.highest_defined_cpu_number DO
        IF cpu_attributes.cpu [cpu_index].state = pmc$processor_state_on THEN
          IF first_cpu THEN
            first_cpu := FALSE;

            osp$append_status_parameter (osc$status_parameter_delimiter,
                  cpu_attributes.cpu [cpu_index].serial_number (1,
                  clp$trimmed_string_size (cpu_attributes.cpu [cpu_index].serial_number)), message_status);
          ELSE

            osp$append_status_parameter (',', cpu_attributes.cpu [cpu_index].
                  serial_number (1, clp$trimmed_string_size (cpu_attributes.cpu [cpu_index].serial_number)),
                  message_status);
          IFEND;
        IFEND;
      FOREND;

      osp$append_status_parameter (osc$status_parameter_delimiter, os_name, message_status);
      IF job_template_name <> '' THEN
        PUSH job_template_message_part: [3 + clp$trimmed_string_size (job_template_name) + 1];
        job_template_message_part^ (1, 3) := '  (';
        job_template_message_part^ (4, * ) := job_template_name;
        job_template_message_part^ (STRLENGTH (job_template_message_part^)) := ')';
        osp$append_status_parameter (' ', job_template_message_part^, message_status);
      IFEND;
      osp$append_status_parameter (osc$status_parameter_delimiter, date.value, message_status);
      osp$append_status_parameter (osc$status_parameter_delimiter, time.value, message_status);

      osp$generate_output_message (message_status, status);
    IFEND;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ?IF NOT clc$compiling_for_test_harness THEN
      PUSH job_status_options_p: [1 .. 5];
      job_status_options_p^ [1].key := jmc$job_mode_set;
      job_status_options_p^ [1].job_mode_set := $jmt$job_mode_set
            [jmc$interactive_cmnd_disconnect, jmc$interactive_line_disconnect,
            jmc$interactive_sys_disconnect];
      job_status_options_p^ [2].key := jmc$job_state_set;
      job_status_options_p^ [2].job_state_set := $jmt$job_state_set [jmc$initiated_job];
      job_status_options_p^ [3].key := jmc$login_user;
      job_status_options_p^ [3].login_user := clv$user_identification.user.value;
      job_status_options_p^ [4].key := jmc$login_family;
      job_status_options_p^ [4].login_family := clv$user_identification.family.value;
      job_status_options_p^ [5].key := jmc$continue_request_to_servers;
      job_status_options_p^ [5].continue_request_to_servers := jmp$cluster_attach_job_enabled ();

      PUSH job_status_results_keys_p: [1 .. 1];
      job_status_results_keys_p^ [1] := jmc$system_job_name;

      job_count := #SIZE (message_status.text.value) DIV #SIZE (jmt$system_supplied_name);
      jmp$get_result_size (job_count, #SEQ (job_status_results_keys_p^), size_of_sequence);
      PUSH job_status_results_seq_p: [[REP size_of_sequence OF cell]];
      jmp$get_job_status (job_status_options_p, job_status_results_keys_p, job_status_results_seq_p,
            job_status_results_p, job_status_count, status);
      WHILE (NOT status.normal) AND (status.condition = jme$work_area_too_small) DO
        jmp$get_result_size (job_status_count + 2, #SEQ (job_status_results_keys_p^), size_of_sequence);
        PUSH job_status_results_seq_p: [[REP size_of_sequence OF cell]];
        jmp$get_job_status (job_status_options_p, job_status_results_keys_p, job_status_results_seq_p,
              job_status_results_p, job_status_count, status);
      WHILEND;

      IF NOT status.normal THEN
        IF status.condition = jme$no_jobs_were_found THEN
          status.normal := TRUE;
        IFEND;
        RETURN;
      IFEND;

      message_status.normal := TRUE;
      FOR job_index := 1 TO job_status_count DO
        IF message_status.normal THEN
          osp$set_status_abnormal ('CL', cle$detached_jobs, job_status_results_p^ [job_index]^ [1].
                system_job_name, message_status)
        ELSE
          osp$append_status_parameter (' ', job_status_results_p^ [job_index]^ [1].system_job_name,
                message_status);
        IFEND;
      FOREND;

      osp$generate_output_message (message_status, status);
    ?IFEND;

  PROCEND put_welcome_banner;
?? TITLE := 'clp$operator_intervention', EJECT ??

  CONST
    operator_intervention_utility = 'OPERATOR_INTERVENTION          ',
    operator_intervention_prompt = 'OI',
    operator_interventn_prompt_size = 2;


  PROCEDURE [XDCL] clp$operator_intervention
    (VAR status: ost$status);

{ table op_intervention_cmnds t=c s=local section_name=oss$job_paged_literal
{ command go                             end_operator_intervention cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

    VAR
      op_intervention_cmnds: [STATIC, READ, oss$job_paged_literal] ^clt$command_table :=
          ^op_intervention_cmnds_entries,

      op_intervention_cmnds_entries: [STATIC, READ, oss$job_paged_literal] array [1 .. 1] of
          clt$command_table_entry := [
            {} ['GO                             ', clc$nominal_entry, clc$advertised_entry, 1,
            clc$automatically_log, clc$linked_call, ^end_operator_intervention]];

?? POP ??

    VAR
      ignore_status: ost$status,
      utility_attributes: array [1 .. 4] of clt$utility_attribute;

    status.normal := TRUE;
    clp$put_job_output (' Processing operator commands......', ignore_status);
    clp$put_job_output (' Enter GO to continue initialization', ignore_status);

    utility_attributes [1].key := clc$utility_command_search_mode;
    utility_attributes [1].command_search_mode := clc$global_command_search;
    utility_attributes [2].key := clc$utility_command_table;
    utility_attributes [2].command_table := op_intervention_cmnds;
    utility_attributes [3].key := clc$utility_termination_command;
    utility_attributes [3].termination_command := 'go';
    utility_attributes [4].key := clc$utility_prompt;
    utility_attributes [4].prompt.value := operator_intervention_prompt;
    utility_attributes [4].prompt.size := operator_interventn_prompt_size;
    clp$begin_utility (operator_intervention_utility, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$include_file (':$LOCAL.COMMAND.1', operator_intervention_prompt, operator_intervention_utility,
          status);
    clp$end_utility (operator_intervention_utility, ignore_status);

  PROCEND clp$operator_intervention;
?? TITLE := 'end_operator_intervention', EJECT ??

  PROCEDURE end_operator_intervention
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$oi_endoi) go, end_operator_intervention

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 7, 10, 14, 47, 22, 935],
    clc$command, 0, 0, 0, 0, 0, 0, 0, 'OSM$OI_ENDOI']];

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

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

    clp$end_include (operator_intervention_utility, status);

  PROCEND end_operator_intervention;
?? TITLE := 'clp$_define_initial_application', EJECT ??

  PROCEDURE [XDCL] clp$_define_initial_application
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$defia) define_initial_application, defia (
{   application, a: string = $required
{   logout_upon_termination, lut: (BY_NAME) boolean = no
{   status)

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (2),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 10, 14, 17, 53, 942],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'OSM$DEFIA'], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['APPLICATION                    ',clc$nominal_entry, 1],
    ['LOGOUT_UPON_TERMINATION        ',clc$nominal_entry, 2],
    ['LUT                            ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$boolean_type],
    'no'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

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

    CONST
      p$application = 1,
      p$logout_upon_termination = 2,
      p$status = 3;

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


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

    clp$define_initial_application (pvt [p$application].value^.string_value,
         pvt [p$logout_upon_termination].value^.boolean_value.value, status);

  PROCEND clp$_define_initial_application;
*IFEND

MODEND clm$interpret_commands;
*DECK DECK=CLM$INTRINSIC_COMMANDS EXPAND=TRUE
table clv$intrinsic_commands type=command section_name=oss$job_paged_literal scope=xdcl ..
      m=clm$intrinsic_commands
command (change_command_search_mode     ,chacsm) clp$_change_command_search_mode xref
command (change_system_command_library  ,chascl) clp$_change_system_command_libr xref advanced_usage
command (create_command_list_entry      ,create_command_list_entries, crecle) ..
                                           clp$_create_command_list_entry xref
command (create_variable                ,create_variables,  crev) clp$_create_variable xref hidden
command (delete_command_list_entry      ,delete_command_list_entries, delcle) ..
                                           clp$_delete_command_list_entry xref
command (delete_variable                ,delete_variables,  delv) clp$_delete_variable xref
command (display_command_information    ,display_command_parameters,  display_command_parameter,  discp,  disci) ..
                                           clp$_display_command_informatio xref
command (display_command_list           ,discl) clp$_display_command_list xref
command (display_command_list_entry     ,discle) clp$_display_command_list_entry xref
command (display_function_information   ,disfi) clp$_display_function_informati xref
command (display_value                  ,display_values,  disv) clp$_display_value xref
command (display_variable_list          ,disvl) clp$_display_variable_list xref
command (display_working_catalog        ,diswc) clp$_display_working_catalog xref
command (get_line                       ,get_lines,  accept_line,  accept_lines,  accl,  getl) clp$_get_line xref
command (include_command                ,incc) clp$_include_command xref
command (include_file                   ,incf) clp$_include_file xref
command (include_line                   ,incl) clp$_include_line xref
command login                           clp$login_command xref l=manual
command logout                          clp$logout_command xref
command (put_line                       ,put_lines,  putl) clp$_put_line xref
command (set_command_list               ,setcl) clp$_set_command_list xref hidden
command (wait                           ) clp$_wait xref
"
" NOTE:
"   The following commands are defined in the control_statements table in
"   module clm$control_statements.  They are defined in this table to allow
"   all relevant information about them to be accessible via the
"   display_command_information command which is geared up to interrogate a
"   clt$command_table.
"
command (collect_text                   ,colt) clp$_collect_text xref hidden
command job                             jmp$_job xref hidden
command task                            clp$_task xref hidden
command utility                         clp$_utility xref hidden
"
" NOTE:
"   The following command ideally belongs in the control_statements table in
"   module clm$control_statements.  It is defined in this table to allow
"   its name to be used for a subcommand of generate_command_table and
"   UTILITY/UTILITYEND.
"
command function                        clp$_function_statement xref hidden
tablend
*DECK DECK=CLM$JOB_HISTORY_OPERATOR_CMDS EXPAND=TRUE
MODULE clm$job_history_operator_cmds;
?? RIGHT := 110 ??
*copyc ofe$error_codes
?? PUSH (LISTEXT := ON) ??
*copyc avp$system_operator
*copyc clp$scan_parameter_list
*copyc jme$queued_file_conditions
*copyc jml$user_id
*copyc jmp$set_job_history_state
*copyc osp$set_status_abnormal
*copyc osp$status_condition_code
*copyc sfp$activate_system_statistic
*copyc sfp$deactivate_system_statistic
?? POP ??
?? NEWTITLE := 'CLM$JOB_HISTORY_OPERATOR_CMDS' ??

?? TITLE := '  CLP$ACTIVATE_JOB_HISTORY', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$activate_job_history (program_parameters: clt$parameter_list;
        VAR status: ost$status);

{ PDT activate_history_pdt (
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      activate_history_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^activate_history_pdt_names, ^activate_history_pdt_params];

    VAR
      activate_history_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
        clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      activate_history_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
        clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      statistic_code: sft$statistic_code;

    status.normal := TRUE;

    IF NOT avp$system_operator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_operator', status);
      RETURN;
    IFEND;

    clp$scan_parameter_list (program_parameters, activate_history_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$set_job_history_state (TRUE);

    FOR statistic_code := jml$first_history_statistic TO jml$last_history_statistic DO

      sfp$activate_system_statistic (statistic_code, $sft$binary_logset [pmc$history_log], status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    FOREND;

  PROCEND clp$activate_job_history;

?? TITLE := '  CLP$DEACTIVATE_JOB_HISTORY' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] clp$deactivate_job_history (program_parameters: clt$parameter_list;
        VAR status: ost$status);

{ PDT deactivate_history_pdt (
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      deactivate_history_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^deactivate_history_pdt_names, ^deactivate_history_pdt_params];

    VAR
      deactivate_history_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
        clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      deactivate_history_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
        clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      statistic_code: sft$statistic_code;

    status.normal := TRUE;

    IF NOT avp$system_operator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_operator', status);
      RETURN;
    IFEND;

    clp$scan_parameter_list (program_parameters, deactivate_history_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR statistic_code := jml$first_history_statistic TO jml$last_history_statistic DO

      sfp$deactivate_system_statistic (statistic_code, $sft$binary_logset [pmc$history_log], status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    FOREND;

    jmp$set_job_history_state (FALSE);

  PROCEND clp$deactivate_job_history;

MODEND clm$job_history_operator_cmds;
*DECK DECK=CLM$JOB_MANAGEMENT_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL interpreter: job management commands' ??
MODULE clm$job_management_commands;

{ PURPOSE:
{   This module contains the SCL command processors for the NOS/VE operator
{ job management commands.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc clt$file_reference
*copyc jme$queued_file_conditions
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc cmp$check_lcu_lock_set
*copyc jmp$change_dispatching_priority
*copyc jmp$convert_string_to_disp_pr
*copyc jmp$system_job
*copyc osp$generate_message
*copyc osp$idle_resume_system_job
*copyc osp$set_status_abnormal
*copyc osp$terminate_system
?? TITLE := 'clp$change_priority_command', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$change_priority_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{    PDT change_priority_pdt (
{      job_name, jn : NAME = $REQUIRED
{      dispatching_priority, dp : KEY default, p1, p2, p3, p4, p5, p6, p7, p8, p9, p10 = ..
{            default
{      STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    change_priority_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^change_priority_pdt_names
  , ^change_priority_pdt_params];

  VAR
    change_priority_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
  clt$parameter_name_descriptor := [['JOB_NAME', 1], ['JN', 1], ['DISPATCHING_PRIORITY', 2], ['DP', 2], [
  'STATUS', 3]];

  VAR
    change_priority_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor
  := [

{ JOB_NAME JN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ DISPATCHING_PRIORITY DP }
    [[clc$optional_with_default, ^change_priority_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [^
  change_priority_pdt_kv2, clc$keyword_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    change_priority_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 11] of ost$name := [
  'DEFAULT','P1','P2','P3','P4','P5','P6','P7','P8','P9','P10'];

  VAR
    change_priority_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := 'default';

?? POP ??

    VAR
      value: clt$value,
      job_name: clt$value,
      supplied: boolean,
      dispatching_priority: jmt$dispatching_priority;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, change_priority_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('JOB_NAME', 1, 1, clc$low, job_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DISPATCHING_PRIORITY', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$convert_string_to_disp_pr (value.name.value, dispatching_priority, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$change_dispatching_priority (job_name, dispatching_priority, status);

  PROCEND clp$change_priority_command;
?? TITLE := 'clp$terminate_system_command', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$terminate_system_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PDT terminate_system_cmd_pdt (
{     status)

?? PUSH (LISTEXT := ON) ??

    VAR
      terminate_system_cmd_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^terminate_system_cmd_pdt_names, ^terminate_system_cmd_pdt_params];

    VAR
      terminate_system_cmd_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      terminate_system_cmd_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
            clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??


    status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, terminate_system_cmd_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the LCU lock is not set before terminating the system.

    cmp$check_lcu_lock_set (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$terminate_system (status);

  PROCEND clp$terminate_system_command;
MODEND clm$job_management_commands;
*DECK DECK=CLM$KEYPOINT_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'clm$keypoint_commands' ??
MODULE clm$keypoint_commands;

{PURPOSE:
{    The purpose of this module is to process the SCL keypoint
{    commands.

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc clt$path_display_chunks
*copyc osc$multiprocessor_constants
*copyc osd$wait
*copyc oss$job_paged_literal
*copyc ost$keypoint_class
*copyc ost$keypoint_control
*copyc pfe$internal_error_conditions
*copyc pmd$local_queues
*copyc syt$perf_keypoints_enabled
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc amv$nil_file_identifier
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$convert_str_to_path_handle
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$open_display
*copyc clp$put_display
*copyc clp$put_job_output
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$scan_parameter_list
*copyc clp$trimmed_string_size
*copyc clp$turn_keypoint_off
*copyc clv$nil_display_control
*copyc dfp$locate_served_family
*copyc fsp$close_file
*copyc fsp$open_file
*copyc fsp$path_element
*copyc osp$collection_file_info
*copyc osp$disestablish_cond_handler
*copyc osp$display_keypoint_status
*copyc osp$establish_block_exit_hndlr
*copyc osp$fetch_collection_file_info
*copyc osp$generate_message
*copyc osp$issue_string_as_keypoint
*copyc osp$release_keypoint_env
*copyc osp$reserve_keypoint_env
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc osp$start_keypoint_collection
*copyc osp$stop_keypoint_collection
*copyc pmp$connect_queue
*copyc pmp$continue_to_cause
*copyc pmp$define_queue
*copyc pmp$disconnect_queue
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pmp$receive_from_queue
*copyc pmp$remove_queue


?? TITLE := 'clp$issue_keypoint', EJECT ??

  PROCEDURE [XDCL] clp$issue_keypoint
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT keypoint_pdt (
{ class: INTEGER 0..15 = 15
{ code: INTEGER 0..0ffffffff(16) = 0
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      keypoint_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^keypoint_pdt_names, ^keypoint_pdt_params];

    VAR
      keypoint_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['CLASS', 1], ['CODE', 2], ['STATUS', 3]];

    VAR
      keypoint_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ CLASS }
      [[clc$optional_with_default, ^keypoint_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$integer_value, 0, 15]],

{ CODE }
      [[clc$optional_with_default, ^keypoint_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$integer_value, 0, 0ffffffff(16)]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      keypoint_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := '15';

    VAR
      keypoint_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

?? POP ??

    VAR
      k_class: integer,
      value: clt$value;


    clp$scan_parameter_list (parameter_list, keypoint_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('CLASS', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    k_class := value.int.value;

    clp$get_value ('CODE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$keypoint (k_class, value.int.value);

  PROCEND clp$issue_keypoint;

{   PDT status_pdt (data_string,ds: string 0..32 = 'keypoint_collection_utility'
{       status)

?? PUSH (LISTEXT := ON) ??

  VAR
    status_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
          [^status_pdt_names, ^status_pdt_params];

  VAR
    status_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
          clt$parameter_name_descriptor := [['DATA_STRING', 1], ['DS', 1], ['STATUS', 2]];

  VAR
    status_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ DATA_STRING DS }
    [[clc$optional_with_default, ^status_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
          [NIL, clc$string_value, 0, 32]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
          [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

  VAR
    status_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (29) :=
          '''keypoint_collection_utility''';

?? POP ??

  CONST
    utility_name = 'KCU                            ';

?? TITLE := 'clp$reserve_keypoint_env', EJECT ??

  PROCEDURE [XDCL] clp$reserve_keypoint_env
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{     PDT actkc_pdt (
{       environment,e: key job, j, system, s, sample_system, ss, sample_job, sj = job
{       collection_files,collection_file,cf: list of file = $required
{       monitor_mask,mm: list of integer 0..15 or key all = all
{       job_mask,jm: list of integer 0..15 or key all = all
{       wait,wai: boolean = true
{       multiprocessor,m: key single, all = single
{       keypoint_count,kc: integer 1..250000000 = 100000
{       keypoint_buffer_size,kbs: integer 1..32 = 1
{       data_string,ds: string 0..32 = 'keypoint collection utility'
{       performance: list of key memory, heap, swapping, aging, swap_trace, age_trace, disk, command, all,..
{            none = none
{       status)

?? PUSH (LISTEXT := ON) ??

  VAR
    actkc_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^actkc_pdt_names, ^actkc_pdt_params
  ];

  VAR
    actkc_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 21] of
  clt$parameter_name_descriptor := [['ENVIRONMENT', 1], ['E', 1], ['COLLECTION_FILES', 2], ['COLLECTION_FILE'
  , 2], ['CF', 2], ['MONITOR_MASK', 3], ['MM', 3], ['JOB_MASK', 4], ['JM', 4], ['WAIT', 5], ['WAI', 5], [
  'MULTIPROCESSOR', 6], ['M', 6], ['KEYPOINT_COUNT', 7], ['KC', 7], ['KEYPOINT_BUFFER_SIZE', 8], ['KBS', 8], [
  'DATA_STRING', 9], ['DS', 9], ['PERFORMANCE', 10], ['STATUS', 11]];

  VAR
    actkc_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 11] of clt$parameter_descriptor := [

{ ENVIRONMENT E }
    [[clc$optional_with_default, ^actkc_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [^actkc_pdt_kv1,
  clc$keyword_value]],

{ COLLECTION_FILES COLLECTION_FILE CF }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ MONITOR_MASK MM }
    [[clc$optional_with_default, ^actkc_pdt_dv3], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [^
  actkc_pdt_kv3, clc$integer_value, 0, 15]],

{ JOB_MASK JM }
    [[clc$optional_with_default, ^actkc_pdt_dv4], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [^
  actkc_pdt_kv4, clc$integer_value, 0, 15]],

{ WAIT WAI }
    [[clc$optional_with_default, ^actkc_pdt_dv5], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ MULTIPROCESSOR M }
    [[clc$optional_with_default, ^actkc_pdt_dv6], 1, 1, 1, 1, clc$value_range_not_allowed, [^actkc_pdt_kv6,
  clc$keyword_value]],

{ KEYPOINT_COUNT KC }
    [[clc$optional_with_default, ^actkc_pdt_dv7], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, 1, 250000000]],

{ KEYPOINT_BUFFER_SIZE KBS }
    [[clc$optional_with_default, ^actkc_pdt_dv8], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, 1, 32]],

{ DATA_STRING DS }
    [[clc$optional_with_default, ^actkc_pdt_dv9], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$string_value, 0, 32]],

{ PERFORMANCE }
    [[clc$optional_with_default, ^actkc_pdt_dv10], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [^
  actkc_pdt_kv10, clc$keyword_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    actkc_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 8] of ost$name := ['JOB','J',
  'SYSTEM','S','SAMPLE_SYSTEM','SS','SAMPLE_JOB','SJ'];

  VAR
    actkc_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['ALL'];

  VAR
    actkc_pdt_kv4: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['ALL'];

  VAR
    actkc_pdt_kv6: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := ['SINGLE','ALL'];

  VAR
    actkc_pdt_kv10: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 10] of ost$name := ['MEMORY','HEAP'
  ,'SWAPPING','AGING','SWAP_TRACE','AGE_TRACE','DISK','COMMAND','ALL','NONE'];

  VAR
    actkc_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'job';

  VAR
    actkc_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

  VAR
    actkc_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

  VAR
    actkc_pdt_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

  VAR
    actkc_pdt_dv6: [STATIC, READ, cls$pdt_names_and_defaults] string (6) := 'single';

  VAR
    actkc_pdt_dv7: [STATIC, READ, cls$pdt_names_and_defaults] string (6) := '100000';

  VAR
    actkc_pdt_dv8: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '1';

  VAR
    actkc_pdt_dv9: [STATIC, READ, cls$pdt_names_and_defaults] string (29) := '''keypoint collection utility'''
  ;

  VAR
    actkc_pdt_dv10: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'none';

?? POP ??

    VAR
      number_of_files: 0 .. 0ff(16),
      keypoint_count,
      keypoint_buffer_size,
      processor_count,
      j,
      i: integer,
      str: string (32),
      ls: ost$status,
      as: [STATIC, READ, oss$job_paged_literal] array [1 .. 2] of fst$attachment_option := [
            {} [fsc$access_and_share_modes, {} [fsc$specific_access_modes,
            [fsc$append, fsc$shorten, fsc$modify]], {} [fsc$specific_share_modes, []]],
            {} [fsc$open_share_modes, [fsc$read, fsc$shorten, fsc$append, fsc$modify, fsc$execute]]],
      environment: ost$keypoint_environment,
      mpo: ost$keypoint_multipro_option,
      wait: ost$wait,
      value: clt$value,
      perf_keypoints: syt$perf_keypoints_enabled,
      count: 0 .. clc$max_value_sets,
      jm,
      mm,
      requested_mask: ost$keypoint_mask,
      mask_value: 0 .. 15,
      segp: amt$segment_pointer,
      fid_array: ^array [ * ] of amt$file_identifier,
      fid: array [1 .. osc$max_number_of_processors] of amt$file_identifier,
      pva: array [1 .. osc$max_number_of_processors] of ^cell,
      termination_complete: boolean,
      pva_array: ^array [ * ] of ^cell;

    clp$scan_parameter_list (parameter_list, actkc_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('ENVIRONMENT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (value.name.value = 'JOB') OR (value.name.value = 'J') THEN
      environment := osc$job_keypoints;
    ELSEIF (value.name.value = 'SAMPLE_JOB') OR (value.name.value = 'SJ') THEN
      environment := osc$job_sample_keypoints;
    ELSEIF (value.name.value = 'SAMPLE_SYSTEM') OR (value.name.value = 'SS') THEN
      environment := osc$system_sample_keypoints;
    ELSE
      environment := osc$system_keypoints;
    IFEND;

    requested_mask := $ost$keypoint_mask [];
    clp$get_set_count ('MONITOR_MASK', count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO count DO
      clp$get_value ('MONITOR_MASK', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.kind = clc$name_value THEN
        requested_mask := -$ost$keypoint_mask [];
      ELSE
        mask_value := value.int.value;
        requested_mask := requested_mask + $ost$keypoint_mask [mask_value];
      IFEND;
    FOREND;
    mm := requested_mask + $ost$keypoint_mask [15];


    requested_mask := $ost$keypoint_mask [];
    clp$get_set_count ('JOB_MASK', count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO count DO
      clp$get_value ('JOB_MASK', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.kind = clc$name_value THEN
        requested_mask := -$ost$keypoint_mask [];
      ELSE
        mask_value := value.int.value;
        requested_mask := requested_mask + $ost$keypoint_mask [mask_value];
      IFEND;
    FOREND;
    jm := requested_mask + $ost$keypoint_mask [15];

    clp$get_value ('WAIT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.bool.value = TRUE THEN
      wait := osc$wait;
    ELSE
      wait := osc$nowait;
    IFEND;

    clp$get_value ('DATA_STRING', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    str := value.str.value (1, value.str.size);

    clp$get_value ('MULTIPROCESSOR', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.name.value = 'SINGLE' THEN
      mpo := osc$keypoints_single_processor;
    ELSE
      mpo := osc$keypoints_multi_processor;
    IFEND;

    clp$get_value ('KEYPOINT_COUNT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    keypoint_count := value.int.value;

    clp$get_value ('KEYPOINT_BUFFER_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    keypoint_buffer_size := value.int.value;

    clp$get_set_count ('COLLECTION_FILES', count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    number_of_files := 0;
    PUSH fid_array: [1 .. count];
    PUSH pva_array: [1 .. count];

    termination_complete := FALSE;

  /files_open/
    BEGIN
      FOR i := 1 TO count DO
        clp$get_value ('COLLECTION_FILES', i, 1, clc$low, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        check_collection_file_location (value.file.local_file_name, status);
        IF NOT status.normal THEN
          EXIT /files_open/;
        IFEND;
        fsp$open_file (value.file.local_file_name, amc$segment, ^as, NIL, NIL, NIL, NIL, fid_array^ [i],
              status);
        IF NOT status.normal THEN
          EXIT /files_open/;
        IFEND;
        number_of_files := number_of_files + 1;
        amp$get_segment_pointer (fid_array^ [i], amc$cell_pointer, segp, status);
        IF NOT status.normal THEN
          EXIT /files_open/;
        IFEND;
        pva_array^ [i] := segp.cell_pointer;
      FOREND;

      clp$get_set_count ('PERFORMANCE', count, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      perf_keypoints.memory_keypoints := FALSE;
      perf_keypoints.heap_keypoints := FALSE;
      perf_keypoints.swapping_keypoints := FALSE;
      perf_keypoints.aging_keypoints := FALSE;
      perf_keypoints.swapping_stack_trace := FALSE;
      perf_keypoints.aging_stack_trace := FALSE;
      perf_keypoints.disk_cache := FALSE;
      perf_keypoints.command_keypoints := FALSE;

      FOR i := 1 TO count DO
        clp$get_value ('PERFORMANCE', i, 1, clc$low, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF value.name.value = 'MEMORY' THEN
          perf_keypoints.memory_keypoints := TRUE;
        ELSEIF value.name.value = 'HEAP' THEN
          perf_keypoints.heap_keypoints := TRUE;
        ELSEIF value.name.value = 'SWAPPING' THEN
          perf_keypoints.swapping_keypoints := TRUE;
        ELSEIF value.name.value = 'AGING' THEN
          perf_keypoints.aging_keypoints := TRUE;
        ELSEIF value.name.value = 'SWAP_TRACE' THEN
          perf_keypoints.swapping_stack_trace := TRUE;
        ELSEIF value.name.value = 'AGE_TRACE' THEN
          perf_keypoints.aging_stack_trace := TRUE;
        ELSEIF value.name.value = 'DISK' THEN
          perf_keypoints.disk_cache := TRUE;
        ELSEIF value.name.value = 'COMMAND' THEN
          perf_keypoints.command_keypoints := TRUE;
        ELSEIF value.name.value = 'NONE' THEN
          perf_keypoints.memory_keypoints := FALSE;
          perf_keypoints.heap_keypoints := FALSE;
          perf_keypoints.swapping_keypoints := FALSE;
          perf_keypoints.aging_keypoints := FALSE;
          perf_keypoints.swapping_stack_trace := FALSE;
          perf_keypoints.aging_stack_trace := FALSE;
          perf_keypoints.disk_cache := FALSE;
          perf_keypoints.command_keypoints := FALSE;
        ELSE {value.name.value = 'ALL' THEN}
          perf_keypoints.memory_keypoints := TRUE;
          perf_keypoints.heap_keypoints := TRUE;
          perf_keypoints.swapping_keypoints := TRUE;
          perf_keypoints.aging_keypoints := TRUE;
          perf_keypoints.swapping_stack_trace := TRUE;
          perf_keypoints.aging_stack_trace := TRUE;
          perf_keypoints.disk_cache := TRUE;
          perf_keypoints.command_keypoints := TRUE;
        IFEND;
      FOREND;

      osp$reserve_keypoint_env (environment, mm, jm, pva_array, wait, mpo, keypoint_count,
            keypoint_buffer_size, str, perf_keypoints, status);
      IF NOT status.normal THEN
        EXIT /files_open/;
      IFEND;
      FOR i := 1 TO number_of_files DO
        pva [i] := pva_array^ [i];
        fid [i] := fid_array^ [i];
      FOREND;
      osp$collection_file_info (number_of_files, fid, pva, status);
    END /files_open/;

    IF NOT status.normal THEN
      FOR i := 1 TO number_of_files DO
        fsp$close_file (fid_array^ [i], ls);
        IF NOT ls.normal THEN
          osp$generate_message (ls, ls);
        IFEND;
      FOREND;
    IFEND;

  PROCEND clp$reserve_keypoint_env;
?? TITLE := 'check_collection_file_location', EJECT ??
{
{ Make sure the collection_file is not a served file.  The file server
{ is not prepared to handle the io requests issued for keypoint collection.
{

  PROCEDURE check_collection_file_location
    (    file: fst$file_reference;
     VAR status: ost$status);

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      family_name: ost$family_name,
      family_ptr: ^fst$path_element_string,
      file_server_family: boolean,
      local_file: amt$local_file_name,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
      served_family_table_index: dft$served_family_table_index,
      server_mainframe_id: pmt$binary_mainframe_id,
      server_state: dft$server_state;

    status.normal := TRUE;
    clp$convert_str_to_path_handle (file, FALSE, FALSE, TRUE, local_file, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    family_ptr := fsp$path_element (^evaluated_file_reference, 1);
    family_name := family_ptr^;

    dfp$locate_served_family (family_name, file_server_family, served_family_table_index, server_mainframe_id,
          p_queue_interface_table, queue_index, server_state);
    IF file_server_family THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unimplemented_server_call,
            ' RESERVE_KEYPOINT_ENVIRONMENT CF=SERVER_FILE', status);
      RETURN;
    IFEND;

  PROCEND check_collection_file_location;

?? TITLE := 'clp$release_keypoint_env', EJECT ??

  PROCEDURE [XDCL] clp$release_keypoint_env
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      ls: ost$status,
      i,
      num_of_files: 0 .. 0ff(16),
      file_id_array: array [1 .. osc$max_number_of_processors] of amt$file_identifier,
      pva_array: array [1 .. osc$max_number_of_processors] of ^cell,
      segp: amt$segment_pointer,
      str: string (32),
      value: clt$value;

    clp$scan_parameter_list (parameter_list, status_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DATA_STRING', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    str := value.str.value (1, value.str.size);

    num_of_files := osc$max_number_of_processors;
    osp$fetch_collection_file_info (pva_array, file_id_array, num_of_files);

    osp$release_keypoint_env (pva_array, str, status);

    FOR i := 1 TO num_of_files DO
      fsp$close_file (file_id_array [i], ls);
      IF NOT ls.normal THEN
        osp$generate_message (ls, ls);
      IFEND;
    FOREND;

  PROCEND clp$release_keypoint_env;
?? TITLE := 'clp$stop_keypoint_collection', EJECT ??

  PROCEDURE [XDCL] clp$stop_keypoint_collection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      str: string (32),
      value: clt$value;

    clp$scan_parameter_list (parameter_list, status_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DATA_STRING', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    str := value.str.value (1, value.str.size);

    osp$stop_keypoint_collection (str, status);

  PROCEND clp$stop_keypoint_collection;
?? TITLE := 'clp$start_keypoint_collection', EJECT ??

  PROCEDURE [XDCL] clp$start_keypoint_collection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      str: string (32),
      value: clt$value;

    clp$scan_parameter_list (parameter_list, status_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DATA_STRING', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    str := value.str.value (1, value.str.size);

    osp$start_keypoint_collection (str, status);

  PROCEND clp$start_keypoint_collection;
?? TITLE := 'clp$issue_string_as_keypoint', EJECT ??

  PROCEDURE [XDCL] clp$issue_string_as_keypoint
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PDT isssak_pdt (
{    data_string, ds: string 1 .. 32
{    status)

?? PUSH (LISTEXT := ON) ??

    VAR
      isssak_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^isssak_pdt_names, ^isssak_pdt_params];

    VAR
      isssak_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['DATA_STRING', 1], ['DS', 1], ['STATUS', 2]];

    VAR
      isssak_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ DATA_STRING DS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 1, 32]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      value: clt$value;

    clp$scan_parameter_list (parameter_list, isssak_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DS', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$issue_string_as_keypoint (value.str.value (1, 32), status);

  PROCEND clp$issue_string_as_keypoint;
?? TITLE := 'clp$display_keypoint_env', EJECT ??

  PROCEDURE [XDCL] clp$display_keypoint_env
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    CONST
      max_attr_size = 31;

{  PDT diske_pdt (
{     output, o: file = OUTPUT
{     status)

?? PUSH (LISTEXT := ON) ??

    VAR
      diske_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^diske_pdt_names, ^diske_pdt_params];

    VAR
      diske_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['OUTPUT', 1], ['O', 1], ['STATUS', 2]];

    VAR
      diske_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ OUTPUT O }
      [[clc$optional_with_default, ^diske_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      diske_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (6) := 'OUTPUT';

?? POP ??
*copyc clv$display_variables

    VAR
      display_control: clt$display_control,
      value: clt$value,
      va: array [1 .. 16] of string (osc$max_name_size),
      ignore_status: ost$status,
      kc: ost$keypoint_control,
      perf_keypoints: syt$perf_keypoints_enabled,
      str: string (132),
      strl,
      vc,
      i,
      j: integer;

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

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

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;
*copyc clp$new_page_procedure
?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

    PROCEND put_subtitle;
?? TITLE := 'put_attribute', EJECT ??

    PROCEDURE put_attribute
      (    header: string ( * );
           value: string ( * ));

      VAR
        start_option: amt$term_option,
        edited_header: string (tab_over);

      CONST
        tab_over = max_attr_size + 3;

      status.normal := TRUE;
      start_option := amc$start;
      edited_header := header;
      edited_header (tab_over - 1) := ':';

      clp$put_partial_display (display_control, edited_header, clc$no_trim, start_option, status);
      IF NOT status.normal THEN
        EXIT clp$display_keypoint_env
      IFEND;
      clp$put_partial_display (display_control, value, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        EXIT clp$display_keypoint_env
      IFEND;

    PROCEND put_attribute;
?? TITLE := 'put_attribute_list', EJECT ??

    PROCEDURE put_attribute_list
      (    header: string ( * );
           value_count: integer;
           value: array [ * ] of string (osc$max_name_size));

      VAR
        start_option: amt$term_option,
        edited_header: string (tab_over),
        value_index: integer;

      CONST
        tab_over = max_attr_size + 4;

      status.normal := TRUE;
      start_option := amc$start;
      edited_header := header;
      edited_header (tab_over) := '(';
      edited_header (tab_over - 2) := ':';

      clp$put_partial_display (display_control, edited_header, clc$no_trim, start_option, status);
      IF NOT status.normal THEN
        EXIT clp$display_keypoint_env
      IFEND;

      FOR value_index := 1 TO value_count DO
        IF (display_control.column_number + clp$trimmed_string_size (value [value_index]) + 2) >
              clv$page_width THEN
          clp$new_display_line (display_control, clc$next_display_line, status);
          IF NOT status.normal THEN
            EXIT clp$display_keypoint_env
          IFEND;
          clp$horizontal_tab_display (display_control, tab_over, status);
          IF NOT status.normal THEN
            EXIT clp$display_keypoint_env
          IFEND;
        IFEND;
        clp$put_partial_display (display_control, value [value_index], clc$trim, amc$continue, status);
        IF NOT status.normal THEN
          EXIT clp$display_keypoint_env
        IFEND;
        IF value_index = value_count THEN
          clp$put_partial_display (display_control, ')', clc$no_trim, amc$terminate, status);
          IF NOT status.normal THEN
            EXIT clp$display_keypoint_env
          IFEND;
        ELSE
          clp$put_partial_display (display_control, ', ', clc$no_trim, amc$continue, status);
          IF NOT status.normal THEN
            EXIT clp$display_keypoint_env
          IFEND;
        IFEND;
      FOREND;

    PROCEND put_attribute_list;
?? OLDTITLE ??
?? EJECT ??

    clp$scan_parameter_list (parameter_list, diske_pdt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$display_keypoint_status (kc, perf_keypoints, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    osp$establish_block_exit_hndlr (^abort_handler);

    clp$open_display (value.file, ^clp$new_page_procedure, display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN
    IFEND;
    clv$titles_built := FALSE;
    clv$subtitles_built := FALSE;
    clv$command_name := 'display_keypoint_environment';

    IF display_control.page_width < clc$narrow_page_width THEN
      clv$page_width := clc$narrow_page_width;
    ELSEIF display_control.page_width > clc$wide_page_width THEN
      clv$page_width := clc$wide_page_width;
    ELSE
      clv$page_width := display_control.page_width;
    IFEND;

    vc := 0;
    FOR i := 0 TO 15 DO
      IF i IN kc.envmm THEN
        vc := vc + 1;
        va [vc] := '   ';
        STRINGREP (va [vc], strl, i);
      IFEND;
    FOREND;
    put_attribute_list ('monitor mask', vc, va);

    vc := 0;
    FOR i := 0 TO 15 DO
      IF i IN kc.envjm THEN
        vc := vc + 1;
        va [vc] := '   ';
        STRINGREP (va [vc], strl, i);
      IFEND;
    FOREND;
    put_attribute_list ('job mask', vc, va);

    CASE kc.environment OF
    = osc$job_keypoints =
      put_attribute ('environment', 'job');
    = osc$system_keypoints =
      put_attribute ('environment', 'system');
    = osc$job_sample_keypoints =
      put_attribute ('environment', 'job sample');
    = osc$system_sample_keypoints =
      put_attribute ('environment', 'system sample');
    CASEND;

    CASE kc.mpo OF
    = osc$keypoints_single_processor =
      put_attribute ('multiprocessor', 'single');
    = osc$keypoints_multi_processor =
      put_attribute ('multiprocessor', 'all');
    CASEND;

    STRINGREP (str, strl, kc.max_pages DIV 4);
    put_attribute ('keypoint buffer size', str (1, strl));

    STRINGREP (str, strl, kc.maximum_keypoints);
    put_attribute ('keypoint count', str (1, strl));

    IF kc.active THEN
      put_attribute ('collection status', 'started');
    ELSE
      put_attribute ('collection status', 'stopped');
    IFEND;

    IF kc.termination_status <> osc$kp_term_not_stopped THEN
      IF kc.termination_status = ose$kpt_coll_term_io_error THEN
        put_attribute ('termination status', 'i/o error');
      ELSEIF kc.termination_status = ose$kpt_coll_term_mbs_error THEN
        put_attribute ('termination status', 'buffer overflow');
      ELSEIF kc.termination_status = ose$kpt_coll_term_max_kpts THEN
        put_attribute ('termination status', 'keypoint count exceeded');
      ELSE
        STRINGREP (str, strl, kc.termination_status);
        put_attribute ('termination status', str (1, strl));
      IFEND;
    IFEND;

    FOR i := kc.first_active_processor TO kc.last_active_processor DO
      STRINGREP (str, strl, kc.cpus [i].offset DIV 8);
      put_attribute ('keypoints collected', str (1, strl));
    FOREND;

    IF perf_keypoints.memory_keypoints THEN
      put_attribute ('memory keypoints', 'enabled');
    IFEND;
    IF perf_keypoints.heap_keypoints THEN
      put_attribute ('heap keypoints', 'enabled');
    IFEND;
    IF perf_keypoints.swapping_keypoints THEN
      put_attribute ('swapping keypoints', 'enabled');
    IFEND;
    IF perf_keypoints.aging_keypoints THEN
      put_attribute ('aging keypoints', 'enabled');
    IFEND;
    IF perf_keypoints.swapping_stack_trace THEN
      put_attribute ('swapping stack trace', 'enabled');
    IFEND;
    IF perf_keypoints.aging_stack_trace THEN
      put_attribute ('aging stack_trace', 'enabled');
    IFEND;
    IF perf_keypoints.disk_cache THEN
      put_attribute ('disk cache keypoints', 'enabled');
    IFEND;
    IF perf_keypoints.command_keypoints THEN
      put_attribute ('command keypoints', 'enabled');
    IFEND;

    clp$close_display (display_control, ignore_status);

    osp$disestablish_cond_handler;

  PROCEND clp$display_keypoint_env;
?? TITLE := 'clp$test_keypoint_collection', EJECT ??

  PROCEDURE [XDCL] clp$test_keypoint_collection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT test_pdt (
{       n: integer
{       status)

?? PUSH (LISTEXT := ON) ??

    VAR
      test_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^test_pdt_names, ^test_pdt_params];

    VAR
      test_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of
            clt$parameter_name_descriptor := [['N', 1], ['STATUS', 2]];

    VAR
      test_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ N }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$integer_value, clc$min_integer, clc$max_integer]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      n,
      i: integer,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, test_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('N', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    n := value.int.value;
    FOR i := 0 TO (n - 1) DO
      #KEYPOINT (13, i, 77);
    FOREND;

  PROCEND clp$test_keypoint_collection;
?? TITLE := 'clp$display_keypoint_file', EJECT ??

  PROCEDURE [XDCL] clp$display_keypoint_file
    (    pl: clt$parameter_list;
     VAR status: ost$status);

{ PDT diskf_pdt (
{   keypoint_file, kf: file = $required
{   display_option, do: key full, brief = brief
{   output, o: file = OUTPUT
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      diskf_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^diskf_pdt_names, ^diskf_pdt_params];

    VAR
      diskf_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
            clt$parameter_name_descriptor := [['KEYPOINT_FILE', 1], ['KF', 1], ['DISPLAY_OPTION', 2],
            ['DO', 2], ['OUTPUT', 3], ['O', 3], ['STATUS', 4]];

    VAR
      diskf_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor := [

{ KEYPOINT_FILE KF }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ DISPLAY_OPTION DO }
      [[clc$optional_with_default, ^diskf_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
            [^diskf_pdt_kv2, clc$keyword_value]],

{ OUTPUT O }
      [[clc$optional_with_default, ^diskf_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      diskf_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of
            ost$name := ['FULL', 'BRIEF'];

    VAR
      diskf_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'brief';

    VAR
      diskf_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (6) := 'OUTPUT';

?? POP ??

    VAR
      as: [STATIC, READ, oss$job_paged_literal] array [1 .. 3] of fst$attachment_option := [
            {} [fsc$access_and_share_modes, {} [fsc$specific_access_modes, [fsc$read]],
            {} [fsc$specific_share_modes, [fsc$read, fsc$execute]]],
            {} [fsc$open_share_modes, [fsc$read, fsc$execute]],
            {} [fsc$create_file, FALSE]],
      as2: [STATIC, READ, oss$job_paged_literal] array [1 .. 2] of fst$attachment_option := [
            {} [fsc$access_and_share_modes, {} [fsc$specific_access_modes,
            [fsc$append, fsc$shorten, fsc$modify]], {} [fsc$specific_share_modes, []]],
            {} [fsc$open_share_modes, [fsc$read, fsc$shorten, fsc$append, fsc$modify, fsc$execute]]],
      value: clt$value,
      segp: amt$segment_pointer,
      seqp: ^SEQ ( * ),
      pcl15kp: ^ost$class_15_keypoint,
      pkp: ^ost$keypoint,
      class: array [0 .. 15] of integer,
      class_error,
      junkl,
      strl,
      i: integer,
      date: ost$date,
      time: ost$time,
      name: string (15),
      str: string (132),
      pjunk: ^array [1 .. * ] of cell,
      display_option: (full, brief),
      ls: ost$status,
      ba: amt$file_byte_address,
      kp_fid,
      output_fid: amt$file_identifier;

?? EJECT ??

    PROCEDURE abort_handler
      (    cond: pmt$condition;
           ci: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR hs: ost$status);

      fsp$close_file (kp_fid, hs);
      fsp$close_file (output_fid, hs);
      hs.normal := TRUE;

    PROCEND abort_handler;
?? EJECT ??

    clp$scan_parameter_list (pl, diskf_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DO', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.name.value = 'FULL' THEN
      display_option := full;
    ELSE
      display_option := brief;
    IFEND;

    class_error := 0;
    FOR i := 0 TO 15 DO
      class [i] := 0;
    FOREND;

    kp_fid := amv$nil_file_identifier;
    #SPOIL (kp_fid);
    output_fid := amv$nil_file_identifier;
    #SPOIL (output_fid);
    osp$establish_block_exit_hndlr (^abort_handler);

  /files_open/
    BEGIN
      clp$get_value ('KEYPOINT_FILE', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /files_open/;
      IFEND;
      fsp$open_file (value.file.local_file_name, amc$segment, ^as, NIL, NIL, NIL, NIL, kp_fid, status);
      IF NOT status.normal THEN
        EXIT /files_open/;
      IFEND;
      amp$get_segment_pointer (kp_fid, amc$sequence_pointer, segp, status);
      IF NOT status.normal THEN
        EXIT /files_open/;
      IFEND;

      clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /files_open/;
      IFEND;
      fsp$open_file (value.file.local_file_name, amc$record, ^as2, NIL, NIL, NIL, NIL, output_fid, status);
      IF NOT status.normal THEN
        EXIT /files_open/;
      IFEND;

      junkl := 8 - (#SIZE (ost$class_15_keypoint) MOD 8);
      IF junkl = 8 THEN
        junkl := 0;
      IFEND;

      seqp := segp.sequence_pointer;
      RESET seqp;
      NEXT pkp IN seqp;

    /kpts/
      WHILE pkp <> NIL DO
        IF pkp^.keypoint_class <= 15 THEN
          class [pkp^.keypoint_class] := class [pkp^.keypoint_class] + 1;
        ELSE
          class_error := class_error + 1;
        IFEND;
        IF pkp^.keypoint_class = 15 THEN
          RESET seqp TO pkp;
          NEXT pcl15kp IN seqp;
          IF pcl15kp = NIL THEN
            EXIT /kpts/;
          IFEND;
          IF junkl <> 0 THEN
{ skip to next kpt
            NEXT pjunk: [1 .. junkl] IN seqp;
          IFEND;
        IFEND;
        IF display_option = full THEN
          IF pkp^.keypoint_class = 15 THEN
            CASE pcl15kp^.keypoint.keypoint_code OF
            = osc$keypoint_cl15_reserve =
              name := 'Reserve';
            = osc$keypoint_cl15_release =
              name := 'Release';
            = osc$keypoint_cl15_start =
              name := 'Start';
            = osc$keypoint_cl15_stop =
              name := 'Stop';
            = osc$keypoint_cl15_issue =
              name := 'Issue';
            ELSE
              name := 'Unknown';
            CASEND;
            pmp$format_compact_time (pcl15kp^.date_time, osc$millisecond_time, time, status);
            pmp$format_compact_date (pcl15kp^.date_time, osc$mdy_date, date, status);
            STRINGREP (str, strl, '  ', name, pcl15kp^.keypoint.keypoint_class: 4, '       ',
                  pcl15kp^.keypoint.keypoint_code: 8, ' ', pcl15kp^.user_data, ' ',
                  pcl15kp^.microsecond_clock, ' ', date.mdy, ' ', time.hms);
          ELSE
            STRINGREP (str, strl, '  ', pkp^.clock: 15, pkp^.keypoint_class: 4, pkp^.keypoint_data: 7: #(16),
                  pkp^.keypoint_code: 8);
          IFEND;
          amp$put_next (output_fid, #LOC (str), strl, ba, status);
        IFEND;
        NEXT pkp IN seqp;
      WHILEND /kpts/;
      IF class_error > 0 THEN
        STRINGREP (str, strl, ' class errors: ', class_error);
        amp$put_next (output_fid, #LOC (str), strl, ba, status);
      IFEND;
      FOR i := 0 TO 15 DO
        STRINGREP (str, strl, ' class: ', i: 4, ' count: ', class [i]);
        amp$put_next (output_fid, #LOC (str), strl, ba, status);
      FOREND;
    END /files_open/;
    fsp$close_file (kp_fid, ls);
    fsp$close_file (output_fid, ls);
    osp$disestablish_cond_handler;

  PROCEND clp$display_keypoint_file;
?? TITLE := 'clp$keypoint', EJECT ??

  PROCEDURE [XDCL] clp$keypoint
    (    keypoint_class: 0 .. 15;
         keypoint_code: 0 .. 0ffffffff(16));

{
{   The purpose of this procedure is to issue a keypoint instruction with
{  the specified keypoint class and keypoint code.
{
{        CLP$KEYPOINT (KEYPOINT_CLASS, KEYPOINT_CODE)
{
{  KEYPOINT_CLASS: (input) This parameter specifies the keypoint class.
{
{  KEYPOINT_CODE: (output) This parameter specifies the keypoint code.
{

    CASE keypoint_class OF
    = 0 =
      #KEYPOINT (0, keypoint_code, 0);
    = 1 =
      #KEYPOINT (1, keypoint_code, 0);
    = 2 =
      #KEYPOINT (2, keypoint_code, 0);
    = 3 =
      #KEYPOINT (3, keypoint_code, 0);
    = 4 =
      #KEYPOINT (4, keypoint_code, 0);
    = 5 =
      #KEYPOINT (5, keypoint_code, 0);
    = 6 =
      #KEYPOINT (6, keypoint_code, 0);
    = 7 =
      #KEYPOINT (7, keypoint_code, 0);
    = 8 =
      #KEYPOINT (8, keypoint_code, 0);
    = 9 =
      #KEYPOINT (9, keypoint_code, 0);
    = 10 =
      #KEYPOINT (10, keypoint_code, 0);
    = 11 =
      #KEYPOINT (11, keypoint_code, 0);
    = 12 =
      #KEYPOINT (12, keypoint_code, 0);
    = 13 =
      #KEYPOINT (13, keypoint_code, 0);
    = 14 =
      #KEYPOINT (14, keypoint_code, 0);
    = 15 =
      #KEYPOINT (15, keypoint_code, 0);
    CASEND;

  PROCEND clp$keypoint;
MODEND clm$keypoint_commands;
*DECK DECK=CLM$LEXICAL_PROCESSORS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Lexical Processors' ??
MODULE clm$lexical_processors;

{
{ PURPOSE:
{   This module contains routines and tables used to perform lexical
{   analysis on SCL input text.
{
{ DESIGN:
{   The design is essentially "ad hoc" in that the definition of the lexical
{   structure of SCL is imbedded in executable code as well as in the tables
{   that are used.  The detailed design of the code is oriented to making
{   extensive use of those CYBER 180 BDP instructions externalized in CYBIL
{   as intrinsics.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
*copyc clc$max_integer
*copyc clc$min_integer
*copyc clt$lexical_token
*copyc clt$lexical_unit
*copyc clt$lexical_unit_kinds
*copyc clt$lexical_units
*copyc clt$parse_state
*copyc clt$token_evaluation_options
?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc clc$max_cobol_name_size
*ELSE
*copyc cle$not_supported
*IFEND
*copyc cle$ecc_lexical
*copyc cle$work_area_overflow
*copyc clk$procedure_keypoints
*IF NOT $true(osv$unix)
*copyc clt$integer
*IFEND
*copyc clt$name
*copyc clt$number
*IF NOT $true(osv$unix)
*copyc clt$number_kind
*copyc clt$number_kinds
*copyc clt$real
*IFEND
*copyc clt$slu_termination_option
*IF NOT $true(osv$unix)
*copyc clt$string_index
*copyc clt$string_value
*IFEND
*copyc clt$work_area
*IF NOT $true(osv$unix)
*copyc cyt$string_size
*copyc osc$processor_defined_registers
*copyc osd$conditions
*copyc oss$job_paged_literal
*IFEND
?? SKIP := 3 ??

{
{ PURPOSE:
{   The following procedure exists solely to provide a "shelter" for the
{   declarations contained in certain decks that are *COPYC'd into this
{   deck.  For example, this module defines an XDCL'd variable that is
{   referenced by an INLINE procedure.  In order to make the deck containing
{   the INLINE procedure "self-contained" it *COPYCs the deck containing the
{   XREF declaration of the variable.  Since the INLINE procedure is needed
{   in this module, both the XDCL and XREF declaration will appear in this
{   module.  The following "dummy" procedure is used to hide the XREF
{   declaration of the variable from the rest of the module.
{

  PROCEDURE [INLINE] dummy;

*copyc clp$identify_lexical_unit

*IF NOT $true(osv$unix)
*copyc clv$comment_delimiter
*copyc clv$letter_char
*copyc clv$non_cobol_name_char
*copyc clv$non_letter_or_digit
*copyc clv$non_space
*IFEND

  PROCEND dummy;
?? SKIP := 3 ??
?? POP ??
*copyc clp$initialize_parse_state
*IF NOT $true(osv$unix)
*copyc clp$recognize_cobol_name
*IFEND
*copyc clp$scan_lexical_unit
*IF NOT $true(osv$unix)
*copyc clv$negative_infinity
*copyc clv$positive_infinity
*copyc mlp$input_floating_number
*IFEND
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper

?? TITLE := 'clv$non_graphic', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$non_graphic: [XDCL, #GATE, READ, oss$job_paged_literal] packed array [char] of boolean := [
*ELSE
    clv$non_graphic: [XDCL, #GATE, READ] packed array [char] of boolean := [
*IFEND
          {---} REP 32 of TRUE,
          { ..~} REP 95 of FALSE,
          {---} REP 129 of TRUE];

?? TITLE := 'clv$non_alphanumeric', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$non_alphanumeric: [XDCL, #GATE, READ, oss$job_paged_literal] packed array [char] of boolean := [
*ELSE
    clv$non_alphanumeric: [XDCL, #GATE, READ] packed array [char] of boolean := [
*IFEND
          {---} REP 35 of TRUE,
          { # } FALSE,
          { $ } FALSE,
          {---} REP 11 of TRUE,
          {0..9} REP 10 of FALSE,
          {---} REP 6 of TRUE,
          { @ } FALSE,
          {A..Z} REP 26 of FALSE,
          { [ } FALSE,
          { \ } FALSE,
          { ] } FALSE,
          { ^ } FALSE,
          { _ } FALSE,
          { ` } FALSE,
          {a..z} REP 26 of FALSE,
          { { } FALSE,
          { | } FALSE,
          { } FALSE,
          { ~ } FALSE,
          {---} REP 129 of TRUE];

?? TITLE := 'clv$non_letter_or_digit', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$non_letter_or_digit: [XDCL, #GATE, READ, oss$job_paged_literal] packed array [char] of boolean := [
*ELSE
    clv$non_letter_or_digit: [XDCL, #GATE, READ] packed array [char] of boolean := [
*IFEND
          {---} REP 48 of TRUE,
          {0..9} REP 10 of FALSE,
          {---} REP 7 of TRUE,
          {A..Z} REP 26 of FALSE,
          {---} REP 6 of TRUE,
          {a..z} REP 26 of FALSE,
          {---} REP 133 of TRUE];

?? TITLE := 'clv$non_space', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$non_space: [XDCL, #GATE, READ, oss$job_paged_literal] packed array [char] of boolean := [
*ELSE
    clv$non_space: [XDCL, #GATE, READ] packed array [char] of boolean := [
*IFEND
          {---} REP 9 of TRUE,
          {HT } FALSE,
          {---} REP 22 of TRUE,
          {- -} FALSE,
          {---} REP 223 of TRUE];

?? TITLE := 'clv$string_delimiter', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$string_delimiter: [XDCL, #GATE, READ, oss$job_paged_literal] packed array [char] of boolean := [
*ELSE
    clv$string_delimiter: [XDCL, #GATE, READ] packed array [char] of boolean := [
*IFEND
          {---} REP 39 of FALSE,
          { ' } TRUE,
          {---} REP 216 of FALSE];

?? TITLE := 'clv$comment_delimiter', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$comment_delimiter: [XDCL, #GATE, READ, oss$job_paged_literal] packed array [char] of boolean := [
*ELSE
    clv$comment_delimiter: [XDCL, #GATE, READ] packed array [char] of boolean := [
*IFEND
          {---} REP 34 of FALSE,
          { " } TRUE,
          {---} REP 221 of FALSE];

?? TITLE := 'clv$non_decimal_digit', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$non_decimal_digit: [XDCL, #GATE, READ, oss$job_paged_literal] packed array [char] of boolean := [
*ELSE
    clv$non_decimal_digit: [XDCL, #GATE, READ] packed array [char] of boolean := [
*IFEND
          {---} REP 48 of TRUE,
          {0..9} REP 10 of FALSE,
          {---} REP 198 of TRUE];

?? TITLE := 'clv$non_zero_digit', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$non_zero_digit: [XDCL, #GATE, READ, oss$job_paged_literal] packed array [char] of boolean := [
*ELSE
    clv$non_zero_digit: [XDCL, #GATE, READ] packed array [char] of boolean := [
*IFEND
          {---} REP 48 of TRUE,
          { 0 } FALSE,
          {---} REP 207 of TRUE];

?? TITLE := 'clv$non_dot', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$non_dot: [XDCL, #GATE, READ, oss$job_paged_literal] packed array [char] of boolean := [
*ELSE
    clv$non_dot: [XDCL, #GATE, READ] packed array [char] of boolean := [
*IFEND
          {---} REP 46 of TRUE,
          { . } FALSE,
          {---} REP 209 of TRUE];

?? TITLE := 'clv$isolate_application_value', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$isolate_application_value: [XDCL, #GATE, READ, oss$job_paged_literal] packed array [char] of
*ELSE
    clv$isolate_application_value: [XDCL, #GATE, READ] packed array [char] of
*IFEND
          boolean := [
          {---} REP 9 of FALSE,
          {HT } TRUE,
          {---} REP 22 of FALSE,
          {- -} TRUE,
          {---} FALSE,
          { " } TRUE,
          {---} REP 4 of FALSE,
          { ' } TRUE,
          { ( } TRUE,
          { ) } TRUE,
          {---} REP 2 of FALSE,
          { , } TRUE,
          {---} FALSE,
          { . } TRUE,
          {---} REP 12 of FALSE,
          { ; } TRUE,
          { < } TRUE,
          { = } TRUE,
          { > } TRUE,
          {---} REP 28 of FALSE,
          { [ } TRUE,
          { \ } FALSE,
          { ] } TRUE,
          { ^ } TRUE,
          { _ } FALSE,
          { ` } TRUE,
          {---} REP 29 of FALSE,
          { { } TRUE,
          { | } FALSE,
          { } TRUE,
          {---} REP 130 of FALSE];

?? TITLE := 'clv$isolate_balanced_text', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$isolate_balanced_text: [XDCL, #GATE, READ, oss$job_paged_literal] packed array [char] of boolean := [
*ELSE
    clv$isolate_balanced_text: [XDCL, #GATE, READ] packed array [char] of boolean := [
*IFEND
          {---} REP 9 of FALSE,
          {HT } TRUE,
          {---} REP 22 of FALSE,
          {- -} TRUE,
          {---} FALSE,
          { " } TRUE,
          {---} REP 4 of FALSE,
          { ' } TRUE,
          { ( } TRUE,
          { ) } TRUE,
          {---} REP 2 of FALSE,
          { , } TRUE,
          {---} FALSE,
          { . } TRUE,
          {---} REP 12 of FALSE,
          { ; } TRUE,
          { < } TRUE,
          { = } TRUE,
          { > } TRUE,
          {---} REP 193 of FALSE];

?? TITLE := 'clv$international_name_char', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$international_name_char: [XDCL, #GATE, READ, oss$job_paged_literal] packed array [char] of boolean :=
*ELSE
    clv$international_name_char: [XDCL, #GATE, READ] packed array [char] of boolean :=
*IFEND
          [
          {---} REP 91 of FALSE,
          { [ } TRUE,
          { \ } TRUE,
          { ] } TRUE,
          { ^ } TRUE,
          { _ } FALSE,
          { ` } TRUE,
          {a..z} REP 26 of FALSE,
          { { } TRUE,
          { | } TRUE,
          { } TRUE,
          { ~ } TRUE,
          {---} REP 129 of FALSE];

?? TITLE := 'clv$letter_char', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$letter_char: [XDCL, #GATE, READ, oss$job_paged_literal] packed array [char] of boolean := [
*ELSE
    clv$letter_char: [XDCL, #GATE, READ] packed array [char] of boolean := [
*IFEND
          {---} REP 65 of FALSE,
          {A..Z} REP 26 of TRUE,
          {---} REP 6 of FALSE,
          {a..z} REP 26 of TRUE,
          {---} REP 133 of FALSE];

?? TITLE := 'clv$non_cobol_name_char', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$non_cobol_name_char: [XDCL, #GATE, READ, oss$job_paged_literal] packed array [char] of boolean := [
*ELSE
    clv$non_cobol_name_char: [XDCL, #GATE, READ] packed array [char] of boolean := [
*IFEND
          {---} REP 45 of TRUE,
          { - } FALSE,
          {---} REP 2 of TRUE,
          {0..9} REP 10 of FALSE,
          {---} REP 7 of TRUE,
          {A..Z} REP 26 of FALSE,
          {---} REP 6 of TRUE,
          {a..z} REP 26 of FALSE,
          {---} REP 133 of TRUE];

?? TITLE := 'clv$special_name_char', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$special_name_char: [XDCL, #GATE, READ, oss$job_paged_literal] packed array [char] of boolean := [
*ELSE
    clv$special_name_char: [XDCL, #GATE, READ] packed array [char] of boolean := [
*IFEND
          {---} REP 35 of FALSE,
          { # } TRUE,
          { $ } TRUE,
          {---} REP 27 of FALSE,
          { @ } TRUE,
          {---} REP 30 of FALSE,
          { _ } TRUE,
          {---} REP 160 of FALSE];


?? TITLE := 'Identify Lexical Unit(s)', EJECT ??
*IF NOT $true(osv$unix)

{
{   These requests are used to determine the kind and size of the next lexical
{ unit in a line.  The bulk of the code is duplicated in the two requests
{ (CLP$IDENTIFY_LEXICAL_UNIT and (CLP$IDENTIFY_LEXICAL_UNITS) because of the
{ frequency of their.  Even the overhead of "calling" an inline procedure is
{ too expensive.
{
{   Name and long name units are syntactically the same; they differ in their
{ allowed sizes.  A name unit may not exceed 31 characters whereas a long name
{ unit does.  Names must be delimited at both ends.  The following BNF
{ definitions illustrate the syntax of name units:
{
{    <clc$lex[_long]_name> ::= <alphabetic char> [<alphanumeric char>]...
{    <alphanumeric char> ::= <alphabetic char> | <digit>
{    <alphabetic char> ::= <letter>
{                        | <special alphabetic char>
{                        | <international letter>
{    <letter> ::= <upper case letter> | <lower case letter>
{    <upper case letter> ::= A | B | C | D | E | F | G | H | I | J | K | L | M
{                          | N | O | P | Q | R | S | T | U | V | W | X | Y | Z
{    <lower case letter> ::= a | b | c | d | e | f | g | h | i | j | k | l | m
{                          | n | o | p | q | r | s | t | u | v | w | x | y | z
{    <international letter> ::= <upper case international letter>
{                             | <lower case international letter>
{    <upper case international letter> ::= @ | '[' |  \  | ^ | ']'
{    <lower case international letter> ::= ` |  {  | '|' | ~ |  }
{    <special alphabetic char> ::= # | $ | _
{    <digit> ::= 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
{
{   The following BNF definition illustrates the syntax of an unsigned decimal
{ unit:
{
{    <clc$lex_unsigned_decimal> ::= <digit>...
{
{   The following BNF definition illustrates the syntax of an alpha number
{ unit:
{
{    <clc$lex_alpha_number> ::= <digit> [<digit>]... <letter> [<digit>]...
{
{   The following BNF definitions illustrate the syntax of string units:
{
{    <clc$lex_string> ::= ' [<string char>]... '
{    <clc$lex_unterminated_string> ::= ' [<string char>]...
{    <string char> ::= <any ascii character except '>
{
{   The following BNF definitions illustrate the syntax of comment units:
{
{    <clc$lex_comment> ::= " [<comment char>]... "
{    <clc$lex_unterminated_comment> ::= " [<comment char>]...
{    <comment char> ::= <any ascii character except ">
{
{   The following BNF definitions illustrate the representation of the
{ delimiter and operator units:
{
{    <clc$lex_semicolon> ::= ;
{    <clc$lex_colon> ::= :
{    <clc$lex_cybil_assign> ::= :=
{    <clc$lex_left_parenthesis> ::= (
{    <clc$lex_right_parenthesis> ::= )
{    <clc$lex_comma> ::= ,
{    <clc$lex_ellipsis> ::= .. [.]...
{    <clc$lex_dot> ::= .
{    <clc$lex_query> ::= ?
{    <clc$lex_greater_than> ::= >
{    <clc$lex_greater_equal> ::= >=
{    <clc$lex_less_than> ::= <
{    <clc$lex_less_equal> ::= <=
{    <clc$lex_equal> ::= =
{    <clc$lex_not_equal> ::= <>
{    <clc$lex_assign> ::= =
{    <clc$lex_concatenate> ::= //
{    <clc$lex_exponentiate> ::= **
{    <clc$lex_multiply> ::= *
{    <clc$lex_divide> ::= /
{    <clc$lex_add> ::= +
{    <clc$lex_subtract> ::= -
{
{   Contiguous spaces are treated collectively as a clc$lex_space.  The
{ horizontal tab (HT) character is treated identically to the space character.
{
{   Any character that does not begin a token previously described, is
{ returned as a clc$lex_unknown.
{

*IFEND
?? NEWTITLE := 'clp$ientify_lexical_unit', EJECT ??

{
{   This request is used to determine the kind and size of the next lexical
{ unit in a line.  On entry, INDEX indicates where to begin scanning TEXT.  On
{ exit, INDEX indicates where scanning stopped (i.e.  the next character, if
{ any, to be scanned).
{
{       CLP$IDENTIFY_LEXICAL_UNIT (TEXT, INDEX, UNIT_IS_SPACE, UNIT)
{
{ TERMINATION_OPTION: (input)  This parameter specifies whether to return with
{       the next unit identified, or to return with the next non space unit.
{
{ TEXT: (input)  This parameter specifies the text to be scanned.
{
{ INDEX: (input, output)  This parameter specifies the next character within
{       text to be scanned.
{
{ UNIT_INDEX: (output)  This parameter specified the index within text of
{       the identified lexical unit.
{
{ UNIT_IS_SPACE: (output)  This parametrer specifies whether the UNIT is
{       normally considerred to be a space (i.e.  clc$lex_space,
{       clc$lex_comment, or clc$lex_unterminated_comment).
{
{ UNIT: (output)  This parameter specifies the identified lexical unit.
{

  PROCEDURE [XDCL, #GATE] clp$identify_lexical_unit
    (    termination_option: clt$slu_termination_option;
         text: ^clt$string_value;
     VAR index {input, output} : clt$string_index;
     VAR unit_index: clt$string_index;
     VAR unit_is_space: boolean;
     VAR unit: clt$lexical_unit);

    VAR
      end_unit_index: clt$string_index,
      scan_found_char: boolean,
      scan_index: integer;


    REPEAT
      unit_index := index;

    /identify_lexical_unit/
      BEGIN
        unit_is_space := FALSE;

        IF index > STRLENGTH (text^) THEN
          unit.kind := clc$lex_end_of_line;
          unit.size := 0;

        ELSE
          CASE text^ (index) OF

          = ' ', $CHAR (9) {HT} =
            unit.kind := clc$lex_space;
            unit_is_space := TRUE;
            #SCAN (clv$non_space, text^ (index + 1, * ), scan_index, scan_found_char);
            end_unit_index := index + scan_index;

          = '"' =
            #SCAN (clv$comment_delimiter, text^ (index + 1, * ), scan_index, scan_found_char);
            IF scan_found_char THEN
              unit.kind := clc$lex_comment;
              end_unit_index := index + scan_index + 1;
            ELSE
              unit.kind := clc$lex_unterminated_comment;
              end_unit_index := index + scan_index;
            IFEND;
            unit_is_space := TRUE;

*IF $true(osv$unix)
          = '#', '$', '@', 'A' .. 'Z', '[', ']', '^', '_', '`', 'a' .. 'z', '{', '|', '}', '~' =
*ELSE
          = '#', '$', '@', 'A' .. 'Z', '[', '\', ']', '^', '_', '`', 'a' .. 'z', '{', '|', '}', '~' =
*IFEND
            #SCAN (clv$non_alphanumeric, text^ (index + 1, * ), scan_index, scan_found_char);
            end_unit_index := index + scan_index;
            IF (end_unit_index - index) > osc$max_name_size THEN
              unit.kind := clc$lex_long_name;
            ELSE
              unit.kind := clc$lex_name;
            IFEND;

          = '''' =
            #SCAN (clv$string_delimiter, text^ (index + 1, * ), scan_index, scan_found_char);
            IF scan_found_char THEN
              unit.kind := clc$lex_string;
              end_unit_index := index + scan_index + 1;
            ELSE
              unit.kind := clc$lex_unterminated_string;
              end_unit_index := index + scan_index;
            IFEND;

          = '(' =
            unit.kind := clc$lex_left_parenthesis;
            end_unit_index := index + 1;

          = ')' =
            unit.kind := clc$lex_right_parenthesis;
            end_unit_index := index + 1;

          = '*' =
            IF (index < STRLENGTH (text^)) AND (text^ (index + 1) = '*') THEN
              unit.kind := clc$lex_exponentiate;
              end_unit_index := index + 2;
            ELSE
              unit.kind := clc$lex_multiply;
              end_unit_index := index + 1;
            IFEND;

          = '+' =
            unit.kind := clc$lex_add;
            end_unit_index := index + 1;

          = ',' =
            unit.kind := clc$lex_comma;
            end_unit_index := index + 1;

          = '-' =
            unit.kind := clc$lex_subtract;
            end_unit_index := index + 1;

          = '.' =
            #SCAN (clv$non_dot, text^ (index + 1, * ), scan_index, scan_found_char);
            IF scan_index > 1 THEN
              unit.kind := clc$lex_ellipsis;
              end_unit_index := index + scan_index;
            ELSE
              unit.kind := clc$lex_dot;
              end_unit_index := index + 1;
            IFEND;

*IF $true(osv$unix)
          = '\' =
            unit.kind := clc$lex_ellipsis;
            end_unit_index := index + 1;

*IFEND
          = '/' =
            IF (index < STRLENGTH (text^)) AND (text^ (index + 1) = '/') THEN
              unit.kind := clc$lex_concatenate;
              end_unit_index := index + 2;
            ELSE
              unit.kind := clc$lex_divide;
              end_unit_index := index + 1;
            IFEND;

          = '0' .. '9' =
            #SCAN (clv$non_letter_or_digit, text^ (index + 1, * ), scan_index, scan_found_char);
            end_unit_index := index + scan_index;
            #SCAN (clv$non_decimal_digit, text^ (index, end_unit_index - index), scan_index,
                  scan_found_char);
            IF scan_found_char THEN
              unit.kind := clc$lex_alpha_number;
            ELSE
              unit.kind := clc$lex_unsigned_decimal;
            IFEND;

          = ':' =
            IF (index < STRLENGTH (text^)) AND (text^ (index + 1) = '=') THEN
              unit.kind := clc$lex_cybil_assign;
              end_unit_index := index + 2;
            ELSE
              unit.kind := clc$lex_colon;
              end_unit_index := index + 1;
            IFEND;

          = ';' =
            unit.kind := clc$lex_semicolon;
            end_unit_index := index + 1;

          = '<' =
            IF (index < STRLENGTH (text^)) AND (text^ (index + 1) = '=') THEN
              unit.kind := clc$lex_less_equal;
              end_unit_index := index + 2;
            ELSEIF (index < STRLENGTH (text^)) AND (text^ (index + 1) = '>') THEN
              unit.kind := clc$lex_not_equal;
              end_unit_index := index + 2;
            ELSE
              unit.kind := clc$lex_less_than;
              end_unit_index := index + 1;
            IFEND;

          = '=' =
            unit.kind := clc$lex_equal;
            end_unit_index := index + 1;

          = '>' =
            IF (index < STRLENGTH (text^)) AND (text^ (index + 1) = '=') THEN
              unit.kind := clc$lex_greater_equal;
              end_unit_index := index + 2;
            ELSE
              unit.kind := clc$lex_greater_than;
              end_unit_index := index + 1;
            IFEND;

          = '?' =
            unit.kind := clc$lex_query;
            end_unit_index := index + 1;

          ELSE
            unit.kind := clc$lex_unknown;
            end_unit_index := index + 1;

          CASEND;

          unit.size := end_unit_index - index;
          index := end_unit_index;
        IFEND;
      END /identify_lexical_unit/;

    UNTIL (termination_option = clc$slu_any) OR (NOT unit_is_space);

  PROCEND clp$identify_lexical_unit;
?? TITLE := 'clp$identify_lexical_units', EJECT ??

{
{   This request constructs an array identifying all of the lexical units in a
{ line.
{
{       CLP$IDENTIFY_LEXICAL_UNITS (TEXT, WORK_AREA, UNITS, STATUS)
{
{ TEXT: (input)  This parameter specifies the text to be scanned.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage into
{       which is constructed the array of lexical units.  The current position
{       of this sequence pointer is updated to reflect the amount of storage
{       used by the request.
{
{ UNITS: (output)  This parameter specifies the array of identified lexical
{       units.
{
{ STATUS: (output)  This parameter specifies the request status.
{

  PROCEDURE [XDCL, #GATE] clp$identify_lexical_units
    (    text: ^clt$string_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR units: ^clt$lexical_units;
     VAR status: ost$status);

    VAR
      count: clt$string_size,
      end_unit_index: clt$string_index,
      index: clt$string_index,
      scan_found_char: boolean,
      scan_index: integer,
      unit: ^clt$lexical_unit,
      work_area_ptr: ^clt$work_area;


    status.normal := TRUE;

    work_area_ptr := work_area;
    NEXT unit IN work_area_ptr;
    IF unit = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;

    unit^.kind := clc$lex_beginning_of_line;
    unit^.size := 0;

    count := 1;
    index := 1;

    REPEAT
      NEXT unit IN work_area_ptr;

      IF unit = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;

    /identify_lexical_unit/
      BEGIN
        IF index > STRLENGTH (text^) THEN
          unit^.kind := clc$lex_end_of_line;
          unit^.size := 0;

        ELSE
          CASE text^ (index) OF

          = ' ', $CHAR (9) {HT} =
            unit^.kind := clc$lex_space;
            #SCAN (clv$non_space, text^ (index + 1, * ), scan_index, scan_found_char);
            end_unit_index := index + scan_index;

          = '"' =
            #SCAN (clv$comment_delimiter, text^ (index + 1, * ), scan_index, scan_found_char);
            IF scan_found_char THEN
              unit^.kind := clc$lex_comment;
              end_unit_index := index + scan_index + 1;
            ELSE
              unit^.kind := clc$lex_unterminated_comment;
              end_unit_index := index + scan_index;
            IFEND;

*IF $true(osv$unix)
          = '#', '$', '@', 'A' .. 'Z', '[', ']', '^', '_', '`', 'a' .. 'z', '{', '|', '}', '~' =
*ELSE
          = '#', '$', '@', 'A' .. 'Z', '[', '\', ']', '^', '_', '`', 'a' .. 'z', '{', '|', '}', '~' =
*IFEND
            #SCAN (clv$non_alphanumeric, text^ (index + 1, * ), scan_index, scan_found_char);
            end_unit_index := index + scan_index;
            IF (end_unit_index - index) > osc$max_name_size THEN
              unit^.kind := clc$lex_long_name;
            ELSE
              unit^.kind := clc$lex_name;
            IFEND;

          = '''' =
            #SCAN (clv$string_delimiter, text^ (index + 1, * ), scan_index, scan_found_char);
            IF scan_found_char THEN
              unit^.kind := clc$lex_string;
              end_unit_index := index + scan_index + 1;
            ELSE
              unit^.kind := clc$lex_unterminated_string;
              end_unit_index := index + scan_index;
            IFEND;

          = '(' =
            unit^.kind := clc$lex_left_parenthesis;
            end_unit_index := index + 1;

          = ')' =
            unit^.kind := clc$lex_right_parenthesis;
            end_unit_index := index + 1;

          = '*' =
            IF (index < STRLENGTH (text^)) AND (text^ (index + 1) = '*') THEN
              unit^.kind := clc$lex_exponentiate;
              end_unit_index := index + 2;
            ELSE
              unit^.kind := clc$lex_multiply;
              end_unit_index := index + 1;
            IFEND;

          = '+' =
            unit^.kind := clc$lex_add;
            end_unit_index := index + 1;

          = ',' =
            unit^.kind := clc$lex_comma;
            end_unit_index := index + 1;

          = '-' =
            unit^.kind := clc$lex_subtract;
            end_unit_index := index + 1;

          = '.' =
            #SCAN (clv$non_dot, text^ (index + 1, * ), scan_index, scan_found_char);
            IF scan_index > 1 THEN
              unit^.kind := clc$lex_ellipsis;
              end_unit_index := index + scan_index;
            ELSE
              unit^.kind := clc$lex_dot;
              end_unit_index := index + 1;
            IFEND;

*IF $true(osv$unix)
          = '\' =
            unit^.kind := clc$lex_ellipsis;
            end_unit_index := index + 1;

*IFEND
          = '/' =
            IF (index < STRLENGTH (text^)) AND (text^ (index + 1) = '/') THEN
              unit^.kind := clc$lex_concatenate;
              end_unit_index := index + 2;
            ELSE
              unit^.kind := clc$lex_divide;
              end_unit_index := index + 1;
            IFEND;

          = '0' .. '9' =
            #SCAN (clv$non_letter_or_digit, text^ (index + 1, * ), scan_index, scan_found_char);
            end_unit_index := index + scan_index;
            #SCAN (clv$non_decimal_digit, text^ (index, end_unit_index - index), scan_index, scan_found_char);
            IF scan_found_char THEN
              unit^.kind := clc$lex_alpha_number;
            ELSE
              unit^.kind := clc$lex_unsigned_decimal;
            IFEND;

          = ':' =
            IF (index < STRLENGTH (text^)) AND (text^ (index + 1) = '=') THEN
              unit^.kind := clc$lex_cybil_assign;
              end_unit_index := index + 2;
            ELSE
              unit^.kind := clc$lex_colon;
              end_unit_index := index + 1;
            IFEND;

          = ';' =
            unit^.kind := clc$lex_semicolon;
            end_unit_index := index + 1;

          = '<' =
            IF (index < STRLENGTH (text^)) AND (text^ (index + 1) = '=') THEN
              unit^.kind := clc$lex_less_equal;
              end_unit_index := index + 2;
            ELSEIF (index < STRLENGTH (text^)) AND (text^ (index + 1) = '>') THEN
              unit^.kind := clc$lex_not_equal;
              end_unit_index := index + 2;
            ELSE
              unit^.kind := clc$lex_less_than;
              end_unit_index := index + 1;
            IFEND;

          = '=' =
            unit^.kind := clc$lex_equal;
            end_unit_index := index + 1;

          = '>' =
            IF (index < STRLENGTH (text^)) AND (text^ (index + 1) = '=') THEN
              unit^.kind := clc$lex_greater_equal;
              end_unit_index := index + 2;
            ELSE
              unit^.kind := clc$lex_greater_than;
              end_unit_index := index + 1;
            IFEND;

          = '?' =
            unit^.kind := clc$lex_query;
            end_unit_index := index + 1;

          ELSE
            unit^.kind := clc$lex_unknown;
            end_unit_index := index + 1;

          CASEND;

          unit^.size := end_unit_index - index;
          index := end_unit_index;
        IFEND;
      END /identify_lexical_unit/;

      count := count + 1;
    UNTIL unit^.kind = clc$lex_end_of_line;

    NEXT units: [1 .. count] IN work_area;

  PROCEND clp$identify_lexical_units;
?? OLDTITLE ??
?? TITLE := 'clp$append_status_parse_state', EJECT ??
*copy clh$append_status_parse_state

  PROCEDURE [XDCL, #GATE] clp$append_status_parse_state
    (    delimiter: char;
         parse: clt$parse_state;
     VAR status {input, output} : ost$status);


    CASE parse.unit.kind OF
    = clc$lex_beginning_of_line =
      osp$append_status_parameter (delimiter, 'beginning of line', status);
    = clc$lex_end_of_line =
      osp$append_status_parameter (delimiter, 'end of line', status);
    = clc$lex_space =
      osp$append_status_parameter (delimiter, 'space', status);
    ELSE
      osp$append_status_parameter (delimiter, parse.text^ (parse.unit_index, parse.unit.size), status);
    CASEND;

  PROCEND clp$append_status_parse_state;
?? TITLE := 'clp$append_status_string', EJECT ??
*copy clh$append_status_string

  PROCEDURE [XDCL, #GATE] clp$append_status_string
    (    delimiter: char;
         text: string ( * );
     VAR status {input, output} : ost$status);

    CONST
      space_constant = ' ';

    VAR
      space: char,
      status_text_size: ost$string_size,
      text_size: integer;


    IF status.normal THEN
      RETURN;
    IFEND;

    status_text_size := status.text.size;
    IF status_text_size >= osc$max_string_size THEN
      RETURN;
    IFEND;
    text_size := STRLENGTH (text);

{ By assigning the value space to a char the CYBIL compiler will place this value in a register.
{ In addition, code motion will move the register load out of the loop.  This should significantly,
{ improve the "stripping" of trailing characters.

    space := space_constant;
    WHILE (text_size > 0) AND (text (text_size) = space) DO
      text_size := text_size - 1;
    WHILEND;
    status_text_size := status_text_size + 1;
    status.text.value (status_text_size) := delimiter;
    IF text_size > osc$max_string_size - status_text_size THEN
      text_size := osc$max_string_size - status_text_size;
    IFEND;
    status.text.value (status_text_size + 1, text_size) := text (1, text_size);
    status.text.size := status_text_size + text_size;

  PROCEND clp$append_status_string;
?? TITLE := 'clp$evaluate_numeric_literal', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$evaluate_numeric_literal
    (    sign: -1 .. 1;
         default_radix: 2 .. 16;
     VAR parse {input, output} : clt$parse_state;
     VAR literal: clt$number;
     VAR status: ost$status);

    VAR
      bad_literal: ost$status_condition,
      check_parse: clt$parse_state,
      first_unit_is_unsigned_decimal: boolean,
      number_index: clt$string_index,
      number_of_digits: clt$string_size,
      number_size: clt$string_size;

    VAR
*IF NOT $true(osv$unix)
      conversion_status: mlt$error,
      exponent: clt$integer,
      ignore_source_length: mlt$string_length,
      ignore_status: ost$status,
*IFEND
      real_number_string: ^clt$string_value,
      scan_found_char: boolean,
      scan_index: integer;

    VAR
      digit: -15 .. 15,
      i: clt$string_index,
      radix_index: clt$string_index,
*IF NOT $true(osv$unix)
      temp_integer: integer,
      user_conditions: ost$user_conditions;
*ELSE
      temp_integer: integer;
*IFEND


    status.normal := TRUE;

    number_index := parse.unit_index;
    number_size := parse.unit.size;
    number_of_digits := number_size;

    first_unit_is_unsigned_decimal := parse.unit.kind = clc$lex_unsigned_decimal;
    clp$scan_lexical_unit (clc$slu_any, parse);

    IF first_unit_is_unsigned_decimal AND (parse.unit.kind = clc$lex_dot) THEN
*IF NOT $true(osv$unix)
      check_parse := parse;
      clp$scan_lexical_unit (clc$slu_any, check_parse);
      IF check_parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_unsigned_decimal, clc$lex_alpha_number]
            THEN

        literal.kind := clc$real_number;
        bad_literal := cle$improper_real;

      /real_ok/
        BEGIN
          parse := check_parse;
          IF parse.unit.kind = clc$lex_unsigned_decimal THEN
            number_size := parse.index - number_index;
            number_of_digits := number_of_digits + parse.unit.size;
          ELSE {clc$lex_alpha_number}
            number_size := parse.index - number_index;
            #SCAN (clv$non_decimal_digit, parse.text^ (parse.unit_index, parse.unit.size), scan_index,
                  scan_found_char);
            number_of_digits := number_of_digits + scan_index - 1;
            CASE parse.text^ (parse.unit_index + scan_index - 1) OF
            = 'E', 'e', 'D', 'd' =
              number_size := parse.index - number_index;
              IF (parse.unit.size - scan_index) > 0 THEN
                #SCAN (clv$non_decimal_digit, parse.text^ (parse.unit_index + scan_index,
                      parse.unit.size - scan_index), scan_index, scan_found_char);
                IF scan_found_char THEN
                  EXIT /real_ok/;
                ELSE
                  clp$convert_string_to_integer (parse.text^ (parse.unit_index + scan_index,
                        parse.unit.size - scan_index), exponent, ignore_status);
                  number_of_digits := exponent.value;
                IFEND;
              ELSE
                clp$scan_lexical_unit (clc$slu_any, parse);
                IF parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_add, clc$lex_subtract] THEN
                  number_size := parse.index - number_index;
                  clp$scan_lexical_unit (clc$slu_any, parse);
                  IF parse.unit.kind <> clc$lex_unsigned_decimal THEN
                    EXIT /real_ok/;
                  ELSE
                    clp$convert_string_to_integer (parse.text^ (parse.unit_index, parse.unit.size),
                          exponent, ignore_status);
                    number_of_digits := exponent.value;
                  IFEND;
                IFEND;
              IFEND;
            ELSE
              EXIT /real_ok/;
            CASEND;
          IFEND;

          number_size := parse.index - number_index;
          clp$scan_lexical_unit (clc$slu_any, parse);

          IF sign >= 0 THEN
            real_number_string := ^parse.text^ (number_index, number_size);
          ELSE
            PUSH real_number_string: [1 + number_size];
            real_number_string^ (1) := '-';
            real_number_string^ (2, number_size) := parse.text^ (number_index, number_size);
          IFEND;

          mlp$input_floating_number (real_number_string, STRLENGTH (real_number_string^),
                ^literal.real_number.value, mlc$double_precision, mlc$ignore_blanks, ignore_source_length,
                conversion_status);
          IF conversion_status = mle$overflow THEN
            osp$set_status_abnormal ('CL', cle$real_literal_too_large, real_number_string^, status);
            RETURN;
          ELSEIF conversion_status <> mle$no_error THEN
            EXIT /real_ok/;
          IFEND;

          IF number_of_digits <= clc$max_real_number_digits THEN
            literal.real_number.number_of_digits := number_of_digits;
          ELSE
            literal.real_number.number_of_digits := clc$max_real_number_digits;
          IFEND;

          RETURN;
        END /real_ok/;
        osp$set_status_abnormal ('CL', bad_literal, parse.text^ (number_index, number_size), status);
        RETURN;

      IFEND;
*ELSE
        osp$set_status_abnormal ('CL', cle$not_supported, 'reals', status);
        RETURN;
*IFEND
    IFEND;

    literal.kind := clc$integer_number;
    literal.integer_number.radix := default_radix;
    literal.integer_number.radix_specified := FALSE;
    bad_literal := cle$improper_integer;

  /integer_ok/
    BEGIN
      IF parse.unit.kind = clc$lex_left_parenthesis THEN
        literal.integer_number.radix_specified := TRUE;
        number_size := parse.index - number_index;
        clp$scan_lexical_unit (clc$slu_non_space, parse);
        number_size := parse.index - number_index;
        IF parse.unit.kind <> clc$lex_unsigned_decimal THEN
          bad_literal := cle$improper_radix_spec;
          EXIT /integer_ok/;
        IFEND;
        radix_index := parse.unit_index;
        temp_integer := 0;
        REPEAT
          temp_integer := (temp_integer * 10) + ($INTEGER (parse.text^ (radix_index)) - $INTEGER ('0'));
          radix_index := radix_index + 1;
        UNTIL (radix_index >= parse.index) OR (temp_integer > UPPERVALUE (literal.integer_number.radix));
        IF (temp_integer < LOWERVALUE (literal.integer_number.radix)) OR
              (temp_integer > UPPERVALUE (literal.integer_number.radix)) THEN
          bad_literal := cle$improper_radix_value;
          EXIT /integer_ok/;
        IFEND;
        literal.integer_number.radix := temp_integer;
        clp$scan_lexical_unit (clc$slu_non_space, parse);
        number_size := parse.index - number_index;
        IF parse.unit.kind <> clc$lex_right_parenthesis THEN
          bad_literal := cle$improper_radix_spec;
          EXIT /integer_ok/;
        IFEND;
        clp$scan_lexical_unit (clc$slu_any, parse);
      IFEND;

      literal.integer_number.value := 0;
      FOR i := number_index TO number_index + number_of_digits - 1 DO
        CASE parse.text^ (i) OF
        = '0' .. '9' =
          digit := $INTEGER (parse.text^ (i)) - $INTEGER ('0');
        = 'A' .. 'F' =
          digit := $INTEGER (parse.text^ (i)) - $INTEGER ('A') + 10;
        = 'a' .. 'f' =
          digit := $INTEGER (parse.text^ (i)) - $INTEGER ('a') + 10;
        ELSE
          bad_literal := cle$alpha_char_in_number;
          EXIT /integer_ok/;
        CASEND;
        IF digit >= literal.integer_number.radix THEN
          bad_literal := cle$digit_too_large;
          EXIT /integer_ok/;
        IFEND;

        IF sign = 1 THEN
          IF ((clc$max_integer - digit) DIV literal.integer_number.radix) < literal.integer_number.value THEN
            osp$set_status_abnormal ('CL', cle$integer_literal_too_large, parse.
                  text^ (number_index, number_size), status);
            RETURN;
          IFEND;
        ELSE
          IF ((clc$min_integer + digit) DIV literal.integer_number.radix) > literal.integer_number.value THEN
            osp$set_status_abnormal ('CL', cle$integer_literal_too_large, parse.
                  text^ (number_index, number_size), status);
            RETURN;
          IFEND;
          digit := -digit;
        IFEND;

        literal.integer_number.value := (literal.integer_number.value * literal.integer_number.radix) + digit;
      FOREND;
      RETURN;
    END /integer_ok/;
    osp$set_status_abnormal ('CL', bad_literal, parse.text^ (number_index, number_size), status);

  PROCEND clp$evaluate_numeric_literal;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$evaluate_token', EJECT ??
*copy clh$evaluate_token

  PROCEDURE [XDCL, #GATE] clp$evaluate_token
    (    text: clt$string_value;
         evaluation_options: clt$token_evaluation_options;
     VAR index {input, output} : clt$string_index;
     VAR spaces_preceded_token: boolean;
     VAR token: clt$lexical_token;
     VAR status: ost$status);

    VAR
      parse: clt$parse_state,
      token_recognized: boolean;

?? NEWTITLE := 'recognize_cobol_name', EJECT ??

    PROCEDURE [INLINE] recognize_cobol_name;

      VAR
        cobol_name_size: ost$name_size,
        is_cobol_name: boolean,
        is_only_cobol_name: boolean;


      clp$recognize_cobol_name (parse.text^ (parse.unit_index, * ), cobol_name_size, is_only_cobol_name,
            is_cobol_name);
      token_recognized := is_cobol_name AND is_only_cobol_name;
      IF token_recognized THEN
        token.kind := clc$cobol_name_token;
        parse.unit.size := cobol_name_size;
      IFEND;

    PROCEND recognize_cobol_name;
?? TITLE := 'recognize_name', EJECT ??

    PROCEDURE recognize_name;

      VAR
        scan_found_char: boolean,
        scan_index: integer;


      #SCAN (clv$international_name_char, parse.text^ (parse.unit_index, parse.unit.size), scan_index,
            scan_found_char);
      IF scan_found_char THEN
        IF (clc$international_char_is_token IN evaluation_options) OR
              (clc$special_char_is_token IN evaluation_options) THEN
          IF scan_index = 1 THEN
            token_recognized := TRUE;
            set_international_char_token;
            RETURN;
          IFEND;
          parse.unit.size := scan_index - 1;
          IF parse.unit.size <= osc$max_name_size THEN
            parse.unit.kind := clc$lex_name;
          IFEND;
        ELSE
          token_recognized := parse.unit.kind = clc$lex_name;
          IF token_recognized THEN
            token.kind := clc$name_token;
          IFEND;
          RETURN;
        IFEND;
      IFEND;

      #SCAN (clv$special_name_char, parse.text^ (parse.unit_index, parse.unit.size), scan_index,
            scan_found_char);
      IF scan_found_char THEN
        IF clc$special_char_is_token IN evaluation_options THEN
          IF scan_index = 1 THEN
            token_recognized := TRUE;
            set_special_char_token;
            RETURN;
          IFEND;
          parse.unit.size := scan_index - 1;
          IF parse.unit.size <= osc$max_name_size THEN
            parse.unit.kind := clc$lex_name;
          IFEND;
        ELSE
          IF (scan_index = 1) AND ((parse.text^ (parse.unit_index) = '$') OR (parse.text^ (parse.unit_index) =
                '#')) AND (clc$special_cybil_name_is_token IN evaluation_options) AND
                (1 < parse.unit.size) AND (parse.unit.size <= (osc$max_name_size + 1)) AND
                clv$letter_char [parse.text^ (parse.unit_index + 1)] THEN
            token_recognized := TRUE;
            token.kind := clc$special_cybil_name_token;
            RETURN;
          IFEND;
          token_recognized := parse.unit.kind = clc$lex_name;
          IF token_recognized THEN
            IF scan_index = 1 THEN
              token.kind := clc$name_token;
            ELSE
              token.kind := clc$cybil_name_token;
            IFEND;
          IFEND;
          RETURN;
        IFEND;
      IFEND;

      IF clc$cobol_name_is_token IN evaluation_options THEN
        recognize_cobol_name;
        IF token_recognized THEN
          RETURN;
        IFEND;
      IFEND;

      token_recognized := parse.unit.kind = clc$lex_name;
      IF token_recognized THEN
        token.kind := clc$simple_name_token;
      IFEND;

    PROCEND recognize_name;
?? TITLE := 'recognize_number', EJECT ??

    PROCEDURE [INLINE] recognize_number
      (    signed: boolean);

      VAR
        number: clt$number;


      clp$evaluate_numeric_literal (sign, 10, parse, number, local_status);
      IF local_status.normal THEN
        IF number.kind = clc$integer_number THEN
          token.descriptor := 'integer';
          IF signed THEN
            token.kind := clc$signed_integer_token;
          ELSE
            token.kind := clc$unsigned_integer_token;
          IFEND;
          token.int := number.integer_number;
        ELSE
          token.descriptor := 'real number';
          IF signed THEN
            token.kind := clc$signed_real_token;
          ELSE
            token.kind := clc$unsigned_real_token;
          IFEND;
          token.rnum := number.real_number;
        IFEND;
        token.text_size := index + parse.unit_index - 1 - token.text_index;
      IFEND;

    PROCEND recognize_number;
?? TITLE := 'set_international_char_token', EJECT ??

    PROCEDURE [INLINE] set_international_char_token;


      token.descriptor := parse.text^ (parse.unit_index, 1);
      CASE parse.text^ (parse.unit_index) OF
      = '[' =
        token.kind := clc$left_bracket_token;
      = '\' =
        token.kind := clc$reverse_slant_token;
      = ']' =
        token.kind := clc$right_bracket_token;
      = '^' =
        token.kind := clc$circumflex_token;
      = '`' =
        token.kind := clc$grave_accent_token;
      = '{' =
        token.kind := clc$left_brace_token;
      = '|' =
        token.kind := clc$vertical_bar_token;
      = '}' =
        token.kind := clc$right_brace_token;
      = '~' =
        token.kind := clc$tilde_token;
      ELSE
        token.kind := clc$unknown_token;
      CASEND;
      token.str.size := 1;
      token.str.value := parse.text^ (parse.unit_index, 1);
      token.str_complete := TRUE;
      token.text_size := 1;
      index := token.text_index + 1;

    PROCEND set_international_char_token;
?? TITLE := 'set_name_token', EJECT ??

    PROCEDURE [INLINE] set_name_token;


      CASE token.kind OF
      = clc$name_token .. clc$simple_name_token =
        token.descriptor := 'name';
      = clc$cobol_name_token =
        token.descriptor := 'COBOL name';
      ELSE
        RETURN;
      CASEND;
      token.str.size := parse.unit.size;
      #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, token.str.size), token.str.value);
      token.str_complete := TRUE;
      token.text_size := parse.unit.size;
      index := token.text_index + token.text_size;

    PROCEND set_name_token;
?? TITLE := 'set_special_char_token', EJECT ??

    PROCEDURE [INLINE] set_special_char_token;


      token.descriptor := parse.text^ (parse.unit_index, 1);
      CASE parse.text^ (parse.unit_index) OF
      = '#' =
        token.kind := clc$number_sign_token;
      = '$' =
        token.kind := clc$dollar_sign_token;
      = '@' =
        token.kind := clc$commercial_at_token;
      = '_' =
        token.kind := clc$underscore_token;
      ELSE
        token.kind := clc$unknown_token;
      CASEND;
      token.str.size := 1;
      token.str.value := parse.text^ (parse.unit_index, 1);
      token.str_complete := TRUE;
      token.text_size := 1;
      index := token.text_index + 1;

    PROCEND set_special_char_token;
?? OLDTITLE, EJECT ??

    VAR
      comment_size: clt$string_size,
      control_characters: [STATIC, READ, oss$job_paged_literal] array [$CHAR (0) .. $CHAR (20(16))] of
            string (3) := ['NUL', 'SOH', 'STX', 'ETX', 'EOT', 'ENQ', 'ACK', 'BEL', 'BS', 'HT', 'LF', 'VT',
            'FF', 'CR', 'SO', 'SI', 'DLE', 'DC1', 'DC2', 'DC3', 'DC4', 'NAK', 'SYN', 'ETB', 'CAN', 'EM',
            'SUB', 'ESC', 'FS', 'GS', 'RS', 'US', 'SP'],
      first_string_unit: boolean,
      hex_digits: [STATIC, READ, oss$job_paged_literal] array [0 .. 15] of char := ['0', '1', '2', '3', '4',
            '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'],
      ignore_spaces: boolean,
      local_status: ost$status,
      sign: -1 .. 1,
      slu_termination_option: clt$slu_termination_option,
      string_unit_size: clt$string_size,
      token_kind_table: [STATIC, READ, oss$job_paged_literal] array [clc$lex_semicolon .. clc$lex_divide] of
            clt$lexical_token_kind := [clc$semicolon_token, clc$colon_token, clc$cybil_assign_token,
            clc$left_parenthesis_token, clc$right_parenthesis_token, clc$comma_token, clc$ellipsis_token,
            clc$dot_token, clc$query_token, clc$greater_than_token, clc$greater_equal_token,
            clc$less_than_token, clc$less_equal_token, clc$equal_token, clc$not_equal_token,
            clc$concatenate_token, clc$exponentiate_token, clc$multiply_token, clc$divide_token],
      treat_comments_as_spaces: boolean;

    #KEYPOINT (osk$entry, 0, clk$evaluate_token);

  /evaluate/
    BEGIN

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

      ignore_spaces := clc$ignore_spaces_before_token IN evaluation_options;
      treat_comments_as_spaces := NOT (clc$comment_is_token IN evaluation_options);
      IF ignore_spaces AND treat_comments_as_spaces THEN
        slu_termination_option := clc$slu_non_space;
      ELSE
        slu_termination_option := clc$slu_any;
      IFEND;
      clp$initialize_parse_state (^text (index, * ), NIL, parse);
      clp$scan_lexical_unit (slu_termination_option, parse);
      IF ignore_spaces AND (parse.unit.kind = clc$lex_space) THEN
        clp$scan_lexical_unit (clc$slu_any, parse);
      IFEND;
      spaces_preceded_token := parse.unit_index > 1;

      token_recognized := FALSE;
      token.text_index := index + parse.unit_index - 1;

      CASE parse.unit.kind OF

      = clc$lex_unknown =
        CASE parse.text^ (parse.unit_index) OF
        = $CHAR (0) .. $CHAR (20(16)) =
          token.descriptor := 'character';
          token.descriptor (11, 3) := control_characters [parse.text^ (parse.unit_index)];
        = $CHAR (21(16)) .. $CHAR (7e(16)) =
          token.descriptor := parse.text^ (parse.unit_index, 1);
        = $CHAR (7f(16)) =
          token.descriptor := 'character DEL';
        = $CHAR (80(16)) .. $CHAR (0ff(16)) =
          token.descriptor := 'character 0xx(16)';
          token.descriptor (12) := hex_digits [$INTEGER (parse.text^ (parse.unit_index)) DIV 16];
          token.descriptor (13) := hex_digits [$INTEGER (parse.text^ (parse.unit_index)) MOD 16];
        CASEND;
        token.kind := clc$unknown_token;
        token.str.size := 1;
        token.str.value := parse.text^ (parse.unit_index, 1);
        token.str_complete := TRUE;
        token.text_size := 1;
        index := token.text_index + 1;

      = clc$lex_beginning_of_line, clc$lex_end_of_line =
        token.descriptor := 'end of line';
        token.kind := clc$end_of_line_token;
        token.str.size := 0;
        token.str.value := '';
        token.str_complete := TRUE;
        token.text_size := 0;
        index := STRLENGTH (text) + 1;

      = clc$lex_space =
        token.descriptor := 'space';
        token.kind := clc$space_token;
        token.str.size := 1;
        token.str.value := ' ';
        token.str_complete := TRUE;
        IF treat_comments_as_spaces THEN
          clp$scan_lexical_unit (clc$slu_non_space, parse);
          token.text_size := index + parse.unit_index - 1 - token.text_index;
        ELSE
          token.text_size := parse.unit.size;
        IFEND;
        index := token.text_index + token.text_size;

      = clc$lex_comment, clc$lex_unterminated_comment =
        IF treat_comments_as_spaces THEN
          token.descriptor := 'space';
          token.kind := clc$space_token;
          clp$scan_lexical_unit (clc$slu_non_space, parse);
          token.text_size := index + parse.unit_index - 1 - token.text_index;
          token.str.size := 1;
          token.str.value := ' ';
          token.str_complete := TRUE;
        ELSE
          token.descriptor := 'comment';
          token.kind := clc$comment_token;
          token.text_size := parse.unit.size;
          comment_size := parse.unit.size - 1 - $INTEGER (parse.unit.kind = clc$lex_comment);
          token.str_complete := comment_size <= osc$max_string_size;
          IF token.str_complete THEN
            token.str.size := comment_size;
          ELSE
            token.str.size := osc$max_string_size;
          IFEND;
          token.str.value := parse.text^ (parse.unit_index + 1, token.str.size);
        IFEND;
        index := token.text_index + token.text_size;

      = clc$lex_semicolon .. clc$lex_divide =
        IF parse.unit.size > 1 THEN
          token.descriptor := parse.text^ (parse.unit_index, 2);
          token.str.size := 2;
          token.str.value := parse.text^ (parse.unit_index, 2);
        ELSE
          token.descriptor := parse.text^ (parse.unit_index, 1);
          token.str.size := 1;
          token.str.value := parse.text^ (parse.unit_index, 1);
        IFEND;
        token.str_complete := TRUE;
        token.kind := token_kind_table [parse.unit.kind];
        token.text_size := parse.unit.size;
        index := token.text_index + token.text_size;

      = clc$lex_add, clc$lex_subtract =
        token.descriptor := parse.text^ (parse.unit_index, 1);
        IF parse.unit.kind = clc$lex_add THEN
          sign := 1;
          token.kind := clc$add_token;
        ELSE
          sign := -1;
          token.kind := clc$subtract_token;
        IFEND;
        token.str.size := 1;
        token.str.value := token.descriptor;
        token.str_complete := TRUE;
        token.text_size := 1;
        clp$scan_lexical_unit (slu_termination_option, parse);
        IF ignore_spaces AND (parse.unit.kind = clc$lex_space) THEN
          clp$scan_lexical_unit (clc$slu_any, parse);
        IFEND;
        IF parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_unsigned_decimal, clc$lex_alpha_number] THEN
          recognize_number (TRUE);
          IF NOT local_status.normal THEN
            local_status.normal := TRUE;
          IFEND;
        IFEND;
        index := token.text_index + token.text_size;

      = clc$lex_name =
        IF clc$classify_name_token IN evaluation_options THEN
          recognize_name;
        ELSE
          token.kind := clc$name_token;
        IFEND;
        set_name_token;

      = clc$lex_long_name =
        IF clc$classify_name_token IN evaluation_options THEN
          recognize_name;
        ELSE
          token_recognized := FALSE;
        IFEND;
        IF token_recognized THEN
          set_name_token;
        ELSE
          osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
                local_status);
        IFEND;

      = clc$lex_alpha_number, clc$lex_unsigned_decimal =
        IF $clt$token_evaluation_options [clc$classify_name_token,
              clc$cobol_name_is_token] <= evaluation_options THEN
          recognize_cobol_name;
        ELSE
          token_recognized := FALSE;
        IFEND;
        IF token_recognized THEN
          set_name_token;
        ELSE
          sign := 1;
          recognize_number (FALSE);
          IF local_status.normal THEN
            index := token.text_index + token.text_size;
          IFEND;
        IFEND;

      = clc$lex_string =
        token.descriptor := 'string';
        token.kind := clc$string_token;
        token.str.size := 0;
        token.str_complete := TRUE;
        first_string_unit := TRUE;
        REPEAT
          IF token.str_complete AND (NOT first_string_unit) THEN
            IF token.str.size = osc$max_string_size THEN
              token.str_complete := FALSE;
            ELSE
              token.str.size := token.str.size + 1;
              token.str.value (token.str.size) := '''';
            IFEND;
          IFEND;
          IF token.str_complete THEN
            string_unit_size := parse.unit.size - 2;
            IF (token.str.size + string_unit_size) > osc$max_string_size THEN
              token.str_complete := FALSE;
              string_unit_size := osc$max_string_size - token.str.size;
            IFEND;
            token.str.value (token.str.size + 1, string_unit_size) :=
                  parse.text^ (parse.unit_index + 1, string_unit_size);
            token.str.size := token.str.size + string_unit_size;
          IFEND;
          first_string_unit := FALSE;
          clp$scan_lexical_unit (clc$slu_any, parse);
        UNTIL parse.unit.kind <> clc$lex_string;
        IF parse.unit.kind = clc$lex_unterminated_string THEN
          osp$set_status_abnormal ('CL', cle$missing_string_delimiter, parse.text^, local_status);
        ELSE
          token.text_size := index + parse.unit_index - 1 - token.text_index;
          index := token.text_index + token.text_size;
        IFEND;

      = clc$lex_unterminated_string =
        osp$set_status_abnormal ('CL', cle$missing_string_delimiter, parse.text^, local_status);

      CASEND;
    END /evaluate/;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, clk$evaluate_token);

  PROCEND clp$evaluate_token;
*IFEND
?? TITLE := 'clp$convert_string_to_integer', EJECT ??
*copy clh$convert_string_to_integer

  PROCEDURE [XDCL, #GATE] clp$convert_string_to_integer
    (    str: string ( * );
     VAR int: clt$integer;
     VAR status: ost$status);

    VAR
      literal: clt$number,
      local_status: ost$status,
      parse: clt$parse_state,
      sign: -1 .. 1;


*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, 0, clk$convert_string_to_integer);
*IFEND

  /convert/
    BEGIN
      status.normal := TRUE;

{Preset literal.kind to ensure that subsequent processing resets it.

      literal.kind := clc$real_number;

      clp$initialize_parse_state (^str, NIL, parse);
      clp$scan_lexical_unit (clc$slu_non_space, parse);

      sign := 1;
      CASE parse.unit.kind OF
      = clc$lex_add =
        clp$scan_lexical_unit (clc$slu_non_space, parse);
      = clc$lex_subtract =
        sign := -1;
        clp$scan_lexical_unit (clc$slu_non_space, parse);
      ELSE
        ;
      CASEND;

      IF parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_unsigned_decimal, clc$lex_alpha_number] THEN
        clp$evaluate_numeric_literal (sign, 10, parse, literal, local_status);
        IF NOT local_status.normal THEN
          status := local_status;
          EXIT /convert/;
        IFEND;
        IF parse.unit_is_space THEN
          clp$scan_lexical_unit (clc$slu_non_space, parse);
        IFEND;
      IFEND;

      IF (parse.unit_index < parse.index_limit) OR (literal.kind <> clc$integer_number) THEN
        osp$set_status_abnormal ('CL', cle$improper_integer, str, status);
        EXIT /convert/;
      IFEND;

      int := literal.integer_number;
    END /convert/;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, 0, clk$convert_string_to_integer);
*IFEND

  PROCEND clp$convert_string_to_integer;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$i_convert_string_to_integer', EJECT ??

{
{ This procedure is the same as the above except for the additon of the
{ DEFAULT_RADIX parameter.
{

  PROCEDURE [XDCL, #GATE] clp$i_convert_string_to_integer
    (    str: string ( * );
         default_radix: 2 .. 16;
     VAR int: clt$integer;
     VAR status: ost$status);

    VAR
      literal: clt$number,
      parse: clt$parse_state,
      sign: -1 .. 1;


    status.normal := TRUE;

{Preset literal.kind to ensure that subsequent processing resets it.

    literal.kind := clc$real_number;

    clp$initialize_parse_state (^str, NIL, parse);
    clp$scan_lexical_unit (clc$slu_non_space, parse);

    sign := 1;
    CASE parse.unit.kind OF
    = clc$lex_add =
      clp$scan_lexical_unit (clc$slu_non_space, parse);
    = clc$lex_subtract =
      sign := -1;
      clp$scan_lexical_unit (clc$slu_non_space, parse);
    ELSE
      ;
    CASEND;

    IF parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_unsigned_decimal, clc$lex_alpha_number] THEN
      clp$evaluate_numeric_literal (sign, default_radix, parse, literal, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF parse.unit_is_space THEN
        clp$scan_lexical_unit (clc$slu_non_space, parse);
      IFEND;
    IFEND;

    IF (parse.unit_index < parse.index_limit) OR (literal.kind <> clc$integer_number) THEN
      osp$set_status_abnormal ('CL', cle$improper_integer, str, status);
      RETURN;
    IFEND;

    int := literal.integer_number;

  PROCEND clp$i_convert_string_to_integer;
*IFEND
?? TITLE := 'clp$convert_string_to_name', EJECT ??
*copyc clh$convert_string_to_name

  PROCEDURE [XDCL, #GATE] clp$convert_string_to_name
    (    str: string ( * );
     VAR name: clt$name;
     VAR status: ost$status);

    VAR
      parse: clt$parse_state;


    #KEYPOINT (osk$entry, 0, clk$convert_string_to_name);

  /convert/
    BEGIN
      status.normal := TRUE;
      clp$initialize_parse_state (^str, NIL, parse);

    /ok/
      BEGIN
        clp$scan_lexical_unit (clc$slu_non_space, parse);
        CASE parse.unit.kind OF
        = clc$lex_name =
          name.size := parse.unit.size;
          #TRANSLATE (osv$lower_to_upper, str (parse.unit_index, parse.unit.size), name.value);
        = clc$lex_long_name =
          osp$set_status_abnormal ('CL', cle$name_too_long, str, status);
          EXIT /convert/;
        ELSE
          EXIT /ok/;
        CASEND;
        clp$scan_lexical_unit (clc$slu_non_space, parse);
        IF parse.unit.kind = clc$lex_end_of_line THEN
          EXIT /convert/;
        IFEND;
      END /ok/;
      osp$set_status_abnormal ('CL', cle$improper_name, str, status);
    END /convert/;

    #KEYPOINT (osk$exit, 0, clk$convert_string_to_name);

  PROCEND clp$convert_string_to_name;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$convert_string_to_real', EJECT ??
*copy clh$convert_string_to_real

  PROCEDURE [XDCL, #GATE] clp$convert_string_to_real
    (    str: string ( * );
     VAR real_number: clt$real;
     VAR status: ost$status);

    VAR
      literal: clt$number,
      local_status: ost$status,
      parse: clt$parse_state,
      name: ost$name,
      sign: -1 .. 1;


    #KEYPOINT (osk$entry, 0, clk$convert_string_to_real);

  /convert/
    BEGIN
      status.normal := TRUE;

{Preset literal.kind to ensure that subsequent processing resets it.

      literal.kind := clc$integer_number;

      clp$initialize_parse_state (^str, NIL, parse);
      clp$scan_lexical_unit (clc$slu_non_space, parse);

      sign := 1;
      CASE parse.unit.kind OF
      = clc$lex_add =
        clp$scan_lexical_unit (clc$slu_non_space, parse);
      = clc$lex_subtract =
        sign := -1;
        clp$scan_lexical_unit (clc$slu_non_space, parse);
      ELSE
        ;
      CASEND;

      CASE parse.unit.kind OF
      = clc$lex_name =
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        IF name = '$INFINITY' THEN
          IF sign = 1 THEN
*IF NOT $true(osv$unix)
            #UNCHECKED_CONVERSION (clv$positive_infinity^, real_number.value);
*ELSE
            real_number.value := clv$positive_infinity^;
*IFEND
          ELSE
*IF NOT $true(osv$unix)
            #UNCHECKED_CONVERSION (clv$negative_infinity^, real_number.value);
*ELSE
            real_number.value := clv$negative_infinity^;
*IFEND
          IFEND;
          real_number.number_of_digits := clc$max_real_number_digits;
          clp$scan_lexical_unit (clc$slu_non_space, parse);
          IF parse.unit_index < parse.index_limit THEN
            osp$set_status_abnormal ('CL', cle$improper_real, str, status);
          IFEND;
          EXIT /convert/;
        IFEND;
      = clc$lex_unsigned_decimal =
        clp$evaluate_numeric_literal (sign, 10, parse, literal, local_status);
        IF NOT local_status.normal THEN
          status := local_status;
          EXIT /convert/;
        IFEND;
        IF parse.unit_is_space THEN
          clp$scan_lexical_unit (clc$slu_non_space, parse);
        IFEND;
      ELSE
        ;
      CASEND;

      IF (parse.unit_index < parse.index_limit) OR (literal.kind <> clc$real_number) THEN
        osp$set_status_abnormal ('CL', cle$improper_real, str, status);
        EXIT /convert/;
      IFEND;

      real_number := literal.real_number;
    END /convert/;

    #KEYPOINT (osk$exit, 0, clk$convert_string_to_real);

  PROCEND clp$convert_string_to_real;
*IFEND

MODEND clm$lexical_processors;
*DECK DECK=CLM$LIST_FUNCTIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : List Functions' ??
MODULE clm$list_functions;

{
{ PURPOSE:
{   This module contains functions related to lists.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$max_list_size
*copyc cle$ecc_parsing
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$parameter_list
*copyc clt$work_area
*copyc ost$status
?? POP ??
*copyc clp$append_status_parse_state
*copyc clp$begin_utility
*copyc clp$build_pattern_for_wild_card
*copyc clp$change_variable
*copyc clp$convert_array_to_list
*copyc clp$convert_list_to_array
*copyc clp$convert_type_spec_to_desc
*copyc clp$count_list_elements
*copyc clp$create_procedure_variable
*copyc clp$data_value_compare
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*copyc clp$internal_evaluate_expr
*copyc clp$get_expected_type
*copyc clp$make_array_value
*copyc clp$make_boolean_value
*copyc clp$make_integer_value
*copyc clp$make_list_value
*copyc clp$make_record_value
*copyc clp$match_string_pattern
*copyc clp$scan_non_space_lexical_unit
*copyc clp$trimmed_string_size
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc osv$lower_to_upper_26

?? TITLE := 'clp$$add', EJECT ??

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

{ FUNCTION (osm$$add) $add (
{   element: any = $required
{   list: list 0..clc$max_list_size = $required
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
      recend,
    recend := [
    [1,
    [90, 4, 3, 9, 59, 31, 50],
    clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$ADD'], [
    ['ELEMENT                        ',clc$nominal_entry, 1],
    ['LIST                           ',clc$nominal_entry, 2]],
    [
{ 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, 12, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, 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, 16, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [-$clt$type_kinds [],
    FALSE, 0]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [0, 0, clc$max_list_size, 0, FALSE, FALSE]]];

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

    CONST
      p$element = 1,
      p$list = 2;

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


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

    clp$make_list_value (work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;

    result^.element_value := pvt [p$element].value;
    IF (pvt [p$list].value^.element_value <> NIL) OR (pvt [p$list].value^.link <> NIL) THEN
      result^.link := pvt [p$list].value;
    IFEND;

  PROCEND clp$$add;
?? TITLE := 'clp$$apply', EJECT ??

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

{ FUNCTION (osm$$apply) $apply (
{   list: list 0..clc$max_list_size = $required
{   expression: (DEFER) any = $required
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend,
    recend := [
    [1,
    [90, 4, 3, 9, 59, 58, 916],
    clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$APPLY'], [
    ['EXPRESSION                     ',clc$nominal_entry, 2],
    ['LIST                           ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 16, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_positionally],
    clc$pass_by_value, clc$deferred_evaluation, clc$standard_parameter_checking, 12, clc$required_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [0, 0, clc$max_list_size, 0, FALSE, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [-$clt$type_kinds [],
    FALSE, 0]]];

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

    CONST
      p$list = 1,
      p$expression = 2;

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

    VAR
      element_type_description: clt$type_description,
      element_type_specification: ^clt$type_specification,
      expression_parse: clt$parse_state,
      ignore_element_type_kind: clt$type_kind,
      node: ^clt$data_value,
      result_node: ^^clt$data_value,
      utility_attributes: array [1 .. 1] of clt$utility_attribute,
      utility_name: clt$utility_name;


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

    IF (pvt [p$list].value^.element_value = NIL) AND (pvt [p$list].value^.link = NIL) THEN
      result := pvt [p$list].value;
      RETURN;
    IFEND;

    get_expected_element_type (pvt [p$expression].value^.deferred_type, work_area, ignore_element_type_kind,
          element_type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    prepare_deferred_expression (pvt [p$expression].value^.deferred_value, element_type_specification,
          work_area, element_type_description, expression_parse, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    utility_name := 'APPLY';
    utility_attributes [1].key := clc$null_utility_attribute;
    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$create_procedure_variable ('X', clc$local_scope, clc$read_write, clc$immediate_evaluation,
          pvt [p$expression].value^.deferred_type, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    node := pvt [p$list].value;
    result_node := ^result;
    WHILE node <> NIL DO
      clp$change_variable ('X', node^.element_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$make_list_value (work_area, result_node^);
      evaluate_deferred_expression (expression_parse, ^element_type_description, work_area,
            result_node^^.element_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      result_node := ^result_node^^.link;
      node := node^.link;
    WHILEND;

    clp$end_utility (utility_name, status);

  PROCEND clp$$apply;
?? TITLE := 'clp$$build_list', EJECT ??

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

{ FUNCTION (osm$$build_list) $build_list (
{   number_of_new_elements: integer 0..clc$max_list_size = $required
{   next_element: (DEFER) any = $required
{   initial_list: list 0..clc$max_list_size = ()
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        default_value: string (2),
      recend,
    recend := [
    [1,
    [90, 4, 6, 12, 48, 58, 727],
    clc$function, 3, 3, 2, 0, 0, 0, 0, 'OSM$$BUILD_LIST'], [
    ['INITIAL_LIST                   ',clc$nominal_entry, 3],
    ['NEXT_ELEMENT                   ',clc$nominal_entry, 2],
    ['NUMBER_OF_NEW_ELEMENTS         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, 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, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_positionally],
    clc$pass_by_value, clc$deferred_evaluation, clc$standard_parameter_checking, 12, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [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, 16,
  clc$optional_default_parameter, 0, 2]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, clc$max_list_size, 10]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [-$clt$type_kinds [],
    FALSE, 0]],
{ PARAMETER 3
    [[1, 0, clc$list_type], [0, 0, clc$max_list_size, 0, FALSE, FALSE],
    '()']];

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

    CONST
      p$number_of_new_elements = 1,
      p$next_element = 2,
      p$initial_list = 3;

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

{ TYPE
{   element_record_type_spec = record
{     result: list of any
{     index: integer 1..clc$max_list_size
{   recend
{ TYPEND

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

  VAR
    element_record_type_spec: [STATIC, READ, cls$declaration_section] record
      header: clt$type_specification_header,
      qualifier: clt$record_type_qualifier,
      field_spec_1: clt$field_specification,
      element_type_spec_1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$union_type_qualifier,
        recend,
      recend,
      field_spec_2: clt$field_specification,
      element_type_spec_2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
    recend := [
      [1, 0, clc$record_type], [2],
      ['RESULT                         ', clc$required_field, 28], [[1, 0, clc$list_type], [12, 0,
  clc$max_list_size, 0, FALSE, FALSE],
          [[1, 0, clc$union_type], [-$clt$type_kinds [],
          FALSE, 0]]
        ],
      ['INDEX                          ', clc$required_field, 20], [[1, 0, clc$integer_type], [1,
  clc$max_list_size, 10]]
      ];

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

    VAR
      element_record_value: ^clt$data_value,
      element_type_description: clt$type_description,
      expression_parse: clt$parse_state,
      index_value: clt$data_value,
      next_element_value: ^clt$data_value,
      result_node: ^^clt$data_value,
      utility_attributes: array [1 .. 1] of clt$utility_attribute,
      utility_name: clt$utility_name;


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

    result := pvt [p$initial_list].value;
    IF pvt [p$number_of_new_elements].value^.integer_value.value <= 0 THEN
      RETURN;
    IFEND;

    prepare_deferred_expression (pvt [p$next_element].value^.deferred_value,
          pvt [p$next_element].value^.deferred_type, work_area, element_type_description, expression_parse,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    utility_name := 'BUILD_LIST';
    utility_attributes [1].key := clc$null_utility_attribute;
    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_record_value (2, work_area, element_record_value);
    element_record_value^.field_values^ [1].name := 'RESULT';
    element_record_value^.field_values^ [1].value := result;
    element_record_value^.field_values^ [2].name := 'INDEX';
    clp$create_procedure_variable ('X', clc$local_scope, clc$read_write, clc$immediate_evaluation,
          #SEQ (element_record_type_spec), NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    index_value.kind := clc$integer;
    index_value.integer_value.value := 1;
    index_value.integer_value.radix := 10;
    index_value.integer_value.radix_specified := FALSE;
    element_record_value^.field_values^ [2].value := ^index_value;

    result_node := ^result;
    IF result^.element_value <> NIL THEN
      WHILE result_node^ <> NIL DO
        index_value.integer_value.value := index_value.integer_value.value + 1;
        result_node := ^result_node^^.link;
      WHILEND;
    IFEND;

    FOR index_value.integer_value.value := index_value.integer_value.value TO
          pvt [p$number_of_new_elements].value^.integer_value.value DO
      clp$change_variable ('X', element_record_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      evaluate_deferred_expression (expression_parse, ^element_type_description, work_area,
            next_element_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF result_node^ = NIL THEN
        clp$make_list_value (work_area, result_node^);
      IFEND;
      result_node^^.element_value := next_element_value;
      result_node := ^result_node^^.link;
    FOREND;

    clp$end_utility (utility_name, status);

  PROCEND clp$$build_list;
?? TITLE := 'clp$$build_result', EJECT ??

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

{ FUNCTION (osm$$build_result) $build_result (
{   list: list = $required
{   expression: (DEFER) any = $required
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend,
    recend := [
    [1,
    [90, 4, 5, 16, 7, 35, 656],
    clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$LIST_RESULT'], [
    ['EXPRESSION                     ',clc$nominal_entry, 2],
    ['LIST                           ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 16, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_positionally],
    clc$pass_by_value, clc$deferred_evaluation, clc$standard_parameter_checking, 12, clc$required_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [0, 1, clc$max_list_size, 0, FALSE, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [-$clt$type_kinds [],
    FALSE, 0]]];

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

    CONST
      p$list = 1,
      p$expression = 2;

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

{ TYPE
{   element_record_type_spec = record
{     result: any
{     current: any
{     index: integer 1..clc$max_list_size
{   recend
{ TYPEND

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

  VAR
    element_record_type_spec: [STATIC, READ, cls$declaration_section] record
      header: clt$type_specification_header,
      qualifier: clt$record_type_qualifier,
      field_spec_1: clt$field_specification,
      element_type_spec_1: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend,
      field_spec_2: clt$field_specification,
      element_type_spec_2: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend,
      field_spec_3: clt$field_specification,
      element_type_spec_3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
    recend := [
      [1, 0, clc$record_type], [3],
      ['RESULT                         ', clc$required_field, 12], [[1, 0, clc$union_type], [
  -$clt$type_kinds [],
        FALSE, 0]],
      ['CURRENT                        ', clc$required_field, 12], [[1, 0, clc$union_type], [
  -$clt$type_kinds [],
        FALSE, 0]],
      ['INDEX                          ', clc$required_field, 20], [[1, 0, clc$integer_type], [1,
  clc$max_list_size, 10]]
      ];

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

    VAR
      element_record_value: ^clt$data_value,
      element_type_description: clt$type_description,
      expression_parse: clt$parse_state,
      index_value: clt$data_value,
      node: ^clt$data_value,
      utility_attributes: array [1 .. 1] of clt$utility_attribute,
      utility_name: clt$utility_name;


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

    result := pvt [p$list].value^.element_value;
    node := pvt [p$list].value^.link;

    IF node = NIL THEN
      RETURN;
    IFEND;

    prepare_deferred_expression (pvt [p$expression].value^.deferred_value,
          pvt [p$expression].value^.deferred_type, work_area, element_type_description, expression_parse,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    utility_name := 'BUILD_RESULT';
    utility_attributes [1].key := clc$null_utility_attribute;
    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_record_value (3, work_area, element_record_value);
    element_record_value^.field_values^ [1].name := 'RESULT';
    element_record_value^.field_values^ [2].name := 'CURRENT';
    element_record_value^.field_values^ [3].name := 'INDEX';
    clp$create_procedure_variable ('X', clc$local_scope, clc$read_write, clc$immediate_evaluation,
          #SEQ (element_record_type_spec), NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    index_value.kind := clc$integer;
    index_value.integer_value.value := 1;
    index_value.integer_value.radix := 10;
    index_value.integer_value.radix_specified := FALSE;
    element_record_value^.field_values^ [3].value := ^index_value;

    REPEAT
      element_record_value^.field_values^ [1].value := result;
      element_record_value^.field_values^ [2].value := node^.element_value;
      index_value.integer_value.value := index_value.integer_value.value + 1;
      clp$change_variable ('X', element_record_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      evaluate_deferred_expression (expression_parse, ^element_type_description, work_area, result, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      node := node^.link;
    UNTIL node = NIL;

    clp$end_utility (utility_name, status);

  PROCEND clp$$build_result;
?? TITLE := 'clp$$combine', EJECT ??

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

{ FUNCTION (osm$$combine) $combine (
{   expression: (DEFER) any = $required
{   lists: list rest of list 0..clc$max_list_size = $required
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier_v2,
        recend,
      recend,
    recend := [
    [1,
    [90, 4, 3, 10, 0, 17, 375],
    clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$COMBINE'], [
    ['EXPRESSION                     ',clc$nominal_entry, 1],
    ['LISTS                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_positionally],
    clc$pass_by_value, clc$deferred_evaluation, clc$standard_parameter_checking, 12, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, 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, 32, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [-$clt$type_kinds [],
    FALSE, 0]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [16, 1, clc$max_list_size, 0, FALSE, TRUE],
      [[1, 0, clc$list_type], [0, 0, clc$max_list_size, 0, FALSE, FALSE]]
    ]];

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

    CONST
      p$expression = 1,
      p$lists = 2;

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

?? POP ??

    CONST
      typical_number_to_combine = 2;

{ TYPE
{   x_type = array 0..typical_number_to_combine of any
{ TYPEND

?? PUSH (LISTEXT := ON) ??

    VAR
      type_specification: [STATIC, READ, cls$declaration_section] record
        header: clt$type_specification_header,
        name: string (6),
        qualifier: clt$array_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$union_type_qualifier,
        recend,
      recend := [[1, 6, clc$array_type], 'X_TYPE', [12, TRUE, [0, typical_number_to_combine]],
            [[1, 0, clc$union_type], [-$clt$type_kinds [], FALSE, 0]]];

?? POP ??

    VAR
      array_type_qualifier: ^clt$array_type_qualifier,
      array_type_specification: ^clt$type_specification,
      array_value: ^clt$data_value,
      element_type_description: clt$type_description,
      element_type_specification: ^clt$type_specification,
      expression_parse: clt$parse_state,
      header: ^clt$type_specification_header,
      ignore_element_type_kind: clt$type_kind,
      ignore_type_name: ^clt$type_name_reference,
      list_node: ^clt$data_value,
      list_number: clt$list_size,
      lists_node: ^clt$data_value,
      number_to_combine: clt$list_size,
      result_node: ^^clt$data_value,
      utility_attributes: array [1 .. 1] of clt$utility_attribute,
      utility_name: clt$utility_name;


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

    get_expected_element_type (pvt [p$expression].value^.deferred_type, work_area, ignore_element_type_kind,
          element_type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    prepare_deferred_expression (pvt [p$expression].value^.deferred_value, element_type_specification,
          work_area, element_type_description, expression_parse, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    utility_name := 'COMBINE';
    utility_attributes [1].key := clc$null_utility_attribute;
    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    number_to_combine := clp$count_list_elements (pvt [p$lists].value);
    IF number_to_combine = typical_number_to_combine THEN
      array_type_specification := #SEQ (type_specification);
    ELSE
      PUSH array_type_specification: [[REP #SIZE (type_specification) OF cell]];
      array_type_specification^ := #SEQ (type_specification) ^;
      RESET array_type_specification;
      NEXT header IN array_type_specification;
      NEXT ignore_type_name: [header^.name_size] IN array_type_specification;
      NEXT array_type_qualifier IN array_type_specification;
      array_type_qualifier^.bounds.upper := number_to_combine;
    IFEND;
    clp$create_procedure_variable ('X', clc$local_scope, clc$read_write, clc$immediate_evaluation,
          array_type_specification, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_array_value (0, number_to_combine, work_area, array_value);
    clp$make_integer_value (0, 10, FALSE, work_area, array_value^.array_value^ [0]);
    result := NIL;
    result_node := ^result;

  /build_result_list/
    WHILE TRUE DO
      array_value^.array_value^ [0]^.integer_value.value := array_value^.array_value^ [0]^.integer_value.
            value + 1;

      lists_node := pvt [p$lists].value;
      FOR list_number := 1 TO number_to_combine DO
        list_node := lists_node^.element_value;
        IF (list_node = NIL) OR (list_node^.element_value = NIL) THEN
          EXIT /build_result_list/;
        IFEND;
        array_value^.array_value^ [list_number] := list_node^.element_value;
        lists_node^.element_value := list_node^.link;
        lists_node := lists_node^.link;
      FOREND;

      clp$change_variable ('X', array_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$make_list_value (work_area, result_node^);
      evaluate_deferred_expression (expression_parse, ^element_type_description, work_area,
            result_node^^.element_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      result_node := ^result_node^^.link;
    WHILEND /build_result_list/;

    IF result = NIL THEN
      clp$make_list_value (work_area, result);
    IFEND;

    clp$end_utility (utility_name, status);

  PROCEND clp$$combine;
?? TITLE := 'clp$$difference', EJECT ??

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

{ FUNCTION (osm$$difference) $difference (
{   first: list 0..clc$max_list_size = $required
{   second: list 0..clc$max_list_size = $required
{   )

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

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
      recend,
    recend := [
    [1,
    [90, 4, 3, 10, 0, 26, 630],
    clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$DIFFERENCE'], [
    ['FIRST                          ',clc$nominal_entry, 1],
    ['SECOND                         ',clc$nominal_entry, 2]],
    [
{ 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, 16, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, 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, 16, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [0, 0, clc$max_list_size, 0, FALSE, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [0, 0, clc$max_list_size, 0, FALSE, FALSE]]];

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

    CONST
      p$first = 1,
      p$second = 2;

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

    VAR
      comparison_node: ^clt$data_value,
      differing_node: ^^clt$data_value,
      first_list: ^clt$data_value,
      second_list: ^clt$data_value;


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

    result := NIL;
    differing_node := ^result;
    first_list := pvt [p$first].value;
    second_list := pvt [p$second].value;

    remove_redundant_elements (first_list);

    comparison_node := second_list;

    WHILE first_list <> NIL DO
      IF clp$data_value_compare (first_list^.element_value, comparison_node^.element_value) = clc$equal THEN
        first_list := first_list^.link;
        comparison_node := second_list;
      ELSEIF comparison_node^.link = NIL THEN
        differing_node^ := first_list;
        differing_node := ^first_list^.link;
        first_list := first_list^.link;
        comparison_node := second_list;
      ELSE
        comparison_node := comparison_node^.link;
      IFEND;
    WHILEND;

    IF result <> NIL THEN
      result^.generated_via_list_rest := FALSE;
      differing_node^ := NIL;
    ELSE
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

  PROCEND clp$$difference;
?? TITLE := 'clp$$first', EJECT ??

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

{ FUNCTION (osm$$first) $first (
{   list: list = $required
{   )

?? 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$list_type_qualifier_v2,
      recend,
    recend := [
    [1,
    [90, 4, 3, 10, 0, 36, 829],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$FIRST'], [
    ['LIST                           ',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, 16, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [0, 1, clc$max_list_size, 0, FALSE, FALSE]]];

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

    CONST
      p$list = 1;

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


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

    result := pvt [p$list].value^.element_value;

  PROCEND clp$$first;
?? TITLE := 'clp$$intersection', EJECT ??

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

{ FUNCTION (osm$$intersection) $intersection (
{   lists: list rest of list 0..clc$max_list_size = $required
{   )

?? 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$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier_v2,
        recend,
      recend,
    recend := [
    [1,
    [90, 4, 3, 10, 0, 44, 448],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$INTERSECTION'], [
    ['LISTS                          ',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, 32, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [16, 1, clc$max_list_size, 0, FALSE, TRUE],
      [[1, 0, clc$list_type], [0, 0, clc$max_list_size, 0, FALSE, FALSE]]
    ]];

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

    CONST
      p$lists = 1;

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

    VAR
      comparison_node: ^clt$data_value,
      intersecting_node: ^^clt$data_value,
      node: ^clt$data_value,
      top_node: ^clt$data_value;


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

    result := NIL;
    intersecting_node := ^result;
    top_node := pvt [p$lists].value;
    node := top_node^.element_value;

    find_non_empty_list (top_node);

  /find_intersection/
    WHILE (top_node <> NIL) AND (top_node^.link <> NIL) DO
      IF result <> NIL THEN
        node := result;
        result := NIL;
        intersecting_node := ^result;
      IFEND;
      top_node := top_node^.link;
      find_non_empty_list (top_node);
      IF top_node <> NIL THEN
        comparison_node := top_node^.element_value;

        WHILE node <> NIL DO
          IF (node^.element_value <> NIL) AND (node^.element_value^.kind = clc$list) AND
                (node^.element_value^.element_value = NIL) THEN
            node := node^.link;
          ELSEIF clp$data_value_compare (node^.element_value, comparison_node^.element_value) = clc$equal THEN
            intersecting_node^ := node;
            intersecting_node := ^node^.link;
            node := node^.link;
            comparison_node := top_node^.element_value;
          ELSEIF comparison_node^.link = NIL THEN
            node := node^.link;
            IF node <> NIL THEN
              comparison_node := top_node^.element_value;
            IFEND;
          ELSE
            comparison_node := comparison_node^.link;
          IFEND;
        WHILEND;

      IFEND;
      IF result = NIL THEN
        EXIT /find_intersection/;
      IFEND;
      intersecting_node^ := NIL;
    WHILEND /find_intersection/;

    IF result <> NIL THEN
      remove_redundant_elements (result);
      result^.generated_via_list_rest := FALSE;
    ELSE
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

  PROCEND clp$$intersection;
?? TITLE := 'clp$$join', EJECT ??

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

{ FUNCTION (osm$$join) $join (
{   lists: list rest of list 0..clc$max_list_size = $required
{   )

?? 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$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier_v2,
        recend,
      recend,
    recend := [
    [1,
    [90, 4, 3, 10, 0, 52, 979],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$JOIN'], [
    ['LISTS                          ',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, 32, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [16, 1, clc$max_list_size, 0, FALSE, TRUE],
      [[1, 0, clc$list_type], [0, 0, clc$max_list_size, 0, FALSE, FALSE]]
    ]];

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

    CONST
      p$lists = 1;

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


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

    join_lists (pvt [p$lists].value, result);

    IF result <> NIL THEN
      result^.generated_via_list_rest := FALSE;
    ELSE
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

  PROCEND clp$$join;
?? TITLE := 'clp$$last', EJECT ??

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

{ FUNCTION (osm$$last) $last (
{   list: list = $required
{   )

?? 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$list_type_qualifier_v2,
      recend,
    recend := [
    [1,
    [90, 4, 3, 10, 1, 2, 340],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$LAST'], [
    ['LIST                           ',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, 16, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [0, 1, clc$max_list_size, 0, FALSE, FALSE]]];

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

    CONST
      p$list = 1;

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


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

    result := pvt [p$list].value;
    WHILE result^.link <> NIL DO
      result := result^.link;
    WHILEND;

    result := result^.element_value;

  PROCEND clp$$last;
?? TITLE := 'clp$$list_of', EJECT ??

  PROCEDURE [XDCL] clp$$list_of
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$list_of) $list_of (
{   elements: list rest of any = $required
{   )

?? 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$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$union_type_qualifier,
        recend,
      recend,
    recend := [
    [1,
    [90, 4, 3, 10, 1, 9, 823],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$LIST_OF'], [
    ['ELEMENTS                       ',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, 28, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [12, 1, clc$max_list_size, 0, FALSE, TRUE],
      [[1, 0, clc$union_type], [-$clt$type_kinds [],
      FALSE, 0]]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$elements = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    result := pvt [p$elements].value;
    result^.generated_via_list_rest := FALSE;

  PROCEND clp$$list_of;
?? TITLE := 'clp$$nil', EJECT ??

  PROCEDURE [XDCL] clp$$nil
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$nil) $nil (
{   list: list 0..clc$max_list_size = $required
{   )

?? 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$list_type_qualifier_v2,
      recend,
    recend := [
    [1,
    [90, 4, 3, 10, 1, 23, 645],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$NIL'], [
    ['LIST                           ',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, 16, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [0, 0, clc$max_list_size, 0, FALSE, FALSE]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$list = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_boolean_value ((pvt [p$list].value^.element_value = NIL), clc$true_false_boolean, work_area,
          result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$nil;
?? TITLE := 'clp$$rest', EJECT ??

  PROCEDURE [XDCL] clp$$rest
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$rest) $rest (
{   list: list = $required
{   )

?? 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$list_type_qualifier_v2,
      recend,
    recend := [
    [1,
    [90, 4, 3, 10, 1, 37, 3],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$REST'], [
    ['LIST                           ',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, 16, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [0, 1, clc$max_list_size, 0, FALSE, FALSE]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$list = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    result := pvt [p$list].value^.link;

    IF result <> NIL THEN
      result^.generated_via_list_rest := FALSE;
    ELSE
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

  PROCEND clp$$rest;
?? TITLE := 'clp$$reverse', EJECT ??

  PROCEDURE [XDCL] clp$$reverse
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$reverse) $reverse (
{   list: list 0..clc$max_list_size = $required
{   )

?? 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$list_type_qualifier_v2,
      recend,
    recend := [
    [1,
    [90, 4, 3, 10, 2, 5, 311],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$REVERSE'], [
    ['LIST                           ',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, 16, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [0, 0, clc$max_list_size, 0, FALSE, FALSE]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$list = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$list].value^.element_value = NIL) AND (pvt [p$list].value^.link = NIL) THEN
      result := pvt [p$list].value;
      RETURN;
    IFEND;

    clp$make_list_value (work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;

    result := pvt [p$list].value;
    clp$reverse_list (result);

    result^.generated_via_list_rest := FALSE;

  PROCEND clp$$reverse;
?? TITLE := 'clp$$select', EJECT ??

  PROCEDURE [XDCL] clp$$select
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$select) $select (
{   list: list 0..clc$max_list_size = $required
{   condition: (DEFER) boolean = $required
{   return_option: key
{       (elements, element, e)
{       (indices, index, indexes, i)
{     keyend = elements
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 7] of clt$keyword_specification,
        default_value: string (8),
      recend,
    recend := [
    [1,
    [90, 9, 20, 14, 51, 6, 660],
    clc$function, 3, 3, 2, 0, 0, 0, 0, 'OSM$$SELECT'], [
    ['CONDITION                      ',clc$nominal_entry, 2],
    ['LIST                           ',clc$nominal_entry, 1],
    ['RETURN_OPTION                  ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, 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, 16, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_positionally],
    clc$pass_by_value, clc$deferred_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [3, 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, 266,
  clc$optional_default_parameter, 0, 8]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [0, 0, clc$max_list_size, 0, FALSE, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$boolean_type]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [7], [
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ELEMENT                        ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['ELEMENTS                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['INDEX                          ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['INDEXES                        ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['INDICES                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'elements']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$list = 1,
      p$condition = 2,
      p$return_option = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

{ TYPE
{   x_type = any
{ TYPEND

?? PUSH (LISTEXT := ON) ??

    VAR
      type_specification: [STATIC, READ, cls$declaration_section] record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend := [[1, 0, clc$union_type], [-$clt$type_kinds [], FALSE, 0]];

?? POP ??

    VAR
      expression_parse: clt$parse_state,
      expression_result: ^clt$data_value,
      expression_type_description: clt$type_description,
      index: clt$list_size,
      node: ^clt$data_value,
      result_node: ^^clt$data_value,
      return_selected_indices: boolean,
      utility_attributes: array [1 .. 1] of clt$utility_attribute,
      utility_name: clt$utility_name;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$list].value^.element_value = NIL) AND (pvt [p$list].value^.link = NIL) THEN
      result := pvt [p$list].value;
      RETURN;
    IFEND;

    return_selected_indices := pvt [p$return_option].value^.keyword_value = 'INDICES';

    prepare_deferred_expression (pvt [p$condition].value^.deferred_value,
          pvt [p$condition].value^.deferred_type, work_area, expression_type_description, expression_parse,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    utility_name := 'SELECT';
    utility_attributes [1].key := clc$null_utility_attribute;
    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$create_procedure_variable ('X', clc$local_scope, clc$read_write, clc$immediate_evaluation,
          #SEQ (type_specification), NIL, status);

    index := 0;
    node := pvt [p$list].value;
    result_node := ^result;
    WHILE node <> NIL DO
      clp$change_variable ('X', node^.element_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      evaluate_deferred_expression (expression_parse, ^expression_type_description, work_area,
            expression_result, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      index := index + 1;
      IF expression_result^.boolean_value.value THEN
        IF return_selected_indices THEN
          clp$make_integer_value (index, 10, FALSE, work_area, node^.element_value);
        IFEND;
        result_node^ := node;
        result_node := ^node^.link;
      IFEND;
      node := node^.link;
    WHILEND;

    clp$end_utility (utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF result <> NIL THEN
      result_node^ := NIL;
      result^.generated_via_list_rest := FALSE;
    ELSE
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

  PROCEND clp$$select;
?? TITLE := 'clp$$select_strings', EJECT ??

  PROCEDURE [XDCL] clp$$select_strings
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sels) $select_strings, $select_string (
{   candidates: list 0..clc$max_list_size of string = $required
{   pattern: string_pattern = $required
{   anchor_option: key
{       (anchored, a)
{       (unanchored, u)
{     keyend = unanchored
{   scan_option: (ADVANCED) key
{       (quick_scan, qs)
{       (full_scan, fs)
{     keyend = quick_scan
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (10),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (10),
      recend,
    recend := [
    [1,
    [90, 4, 12, 12, 35, 16, 735],
    clc$function, 4, 4, 2, 1, 0, 0, 0, 'OSM$$SELS'], [
    ['ANCHOR_OPTION                  ',clc$nominal_entry, 3],
    ['CANDIDATES                     ',clc$nominal_entry, 1],
    ['PATTERN                        ',clc$nominal_entry, 2],
    ['SCAN_OPTION                    ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, 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, 24, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, 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, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [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, 155,
  clc$optional_default_parameter, 0, 10],
{ PARAMETER 4
    [4, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 10]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [8, 0, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 2
    [[1, 0, clc$string_pattern_type]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ANCHORED                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['UNANCHORED                     ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'unanchored'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [4], [
    ['FS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FULL_SCAN                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['QS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['QUICK_SCAN                     ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'quick_scan']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$candidates = 1,
      p$pattern = 2,
      p$anchor_option = 3,
      p$scan_option = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      anchor_option: clt$string_pattern_anchor_opt,
      candidate: ^clt$string_value,
      index: clt$list_size,
      match_info: clt$string_pattern_match_info,
      node: ^clt$data_value,
      result_node: ^^clt$data_value,
      return_selected_indices: boolean,
      scan_option: clt$string_pattern_scan_option;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$candidates].value^.element_value = NIL) AND (pvt [p$candidates].value^.link = NIL) THEN
      result := pvt [p$candidates].value;
      RETURN;
    IFEND;

    clp$determine_select_result_typ (work_area, return_selected_indices, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$anchor_option].value^.keyword_value = 'ANCHORED' THEN
      anchor_option := clc$sp_anchored;
    ELSE
      anchor_option := clc$sp_unanchored;
    IFEND;

    IF pvt [p$scan_option].value^.keyword_value = 'QUICK_SCAN' THEN
      scan_option := clc$sp_quick_scan;
    ELSE
      scan_option := clc$sp_full_scan;
    IFEND;

    index := 0;
    result := NIL;
    node := pvt [p$candidates].value;
    result_node := ^result;
    WHILE node <> NIL DO
      candidate := node^.element_value^.string_value;

      clp$match_string_pattern (candidate^, pvt [p$pattern].value^.string_pattern_value, anchor_option,
            scan_option, match_info, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      index := index + 1;
      IF match_info.result = clc$sp_success THEN
        IF return_selected_indices THEN
          clp$make_integer_value (index, 10, FALSE, work_area, node^.element_value);
        IFEND;
        result_node^ := node;
        result_node := ^node^.link;
      IFEND;
      node := node^.link;
    WHILEND;

    IF result <> NIL THEN
      result_node^ := NIL;
      result^.generated_via_list_rest := FALSE;
    ELSE
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

  PROCEND clp$$select_strings;
?? TITLE := 'clp$$select_wild_card_names', EJECT ??

  PROCEDURE [XDCL] clp$$select_wild_card_names
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$selwcn) $select_wild_card_names, $select_wild_card_name, $select_name, $select_names (
{   candidates: list 0..clc$max_list_size of name = $required
{   pattern: (wild_card_name) application = $required
{   pattern_type: key
{       (basic, b)
{       (extended, e)
{     keyend = $scl_options.wild_card_pattern_type
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        name: string (14),
        qualifier: clt$application_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (35),
      recend,
    recend := [
    [1,
    [90, 4, 3, 10, 3, 52, 312],
    clc$function, 3, 3, 2, 0, 0, 0, 0, 'OSM$$SELWCN'], [
    ['CANDIDATES                     ',clc$nominal_entry, 1],
    ['PATTERN                        ',clc$nominal_entry, 2],
    ['PATTERN_TYPE                   ',clc$nominal_entry, 3]],
    [
{ 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, 21, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, 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, 18, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [3, 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, 155,
  clc$optional_default_parameter, 0, 35]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 0, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 14, clc$application_type], 'WILD_CARD_NAME', [FALSE]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BASIC                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXTENDED                       ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    '$scl_options.wild_card_pattern_type']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$candidates = 1,
      p$pattern = 2,
      p$pattern_type = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      candidate: ^clt$string_value,
      index: clt$list_size,
      match_info: clt$string_pattern_match_info,
      node: ^clt$data_value,
      original_pattern: ^clt$string_value,
      pattern: ^clt$string_value,
      pattern_type: clt$wild_card_pattern_type,
      result_node: ^^clt$data_value,
      return_selected_indices: boolean,
      string_pattern: ^clt$string_pattern;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$candidates].value^.element_value = NIL) AND (pvt [p$candidates].value^.link = NIL) THEN
      result := pvt [p$candidates].value;
      RETURN;
    IFEND;

    clp$determine_select_result_typ (work_area, return_selected_indices, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pattern := pvt [p$pattern].value^.application_value;

    IF pvt [p$pattern_type].value^.keyword_value = 'BASIC' THEN
      pattern_type := clc$wc_basic_pattern;
    ELSE
      pattern_type := clc$wc_extended_pattern;
    IFEND;

    original_pattern := pattern;
    PUSH pattern: [STRLENGTH (original_pattern^)];
    IF pattern_type = clc$wc_basic_pattern THEN
      #TRANSLATE (osv$lower_to_upper, original_pattern^, pattern^);
    ELSE
      #TRANSLATE (osv$lower_to_upper_26, original_pattern^, pattern^);
    IFEND;

    clp$build_pattern_for_wild_card (pattern_type, $clt$string_pattern_build_opts
          [clc$sp_match_at_right, clc$sp_ignore_matched_substring], pattern^, work_area, string_pattern,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    index := 0;
    result := NIL;
    node := pvt [p$candidates].value;
    result_node := ^result;
    WHILE node <> NIL DO
      candidate := ^node^.element_value^.name_value;

      clp$match_string_pattern (candidate^ (1, clp$trimmed_string_size (candidate^)), string_pattern,
            clc$sp_anchored, clc$sp_quick_scan, match_info, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      index := index + 1;
      IF match_info.result = clc$sp_success THEN
        IF return_selected_indices THEN
          clp$make_integer_value (index, 10, FALSE, work_area, node^.element_value);
        IFEND;
        result_node^ := node;
        result_node := ^node^.link;
      IFEND;
      node := node^.link;
    WHILEND;

    IF result <> NIL THEN
      result_node^ := NIL;
      result^.generated_via_list_rest := FALSE;
    ELSE
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

  PROCEND clp$$select_wild_card_names;
?? TITLE := 'clp$$select_wild_card_program_n', EJECT ??

  PROCEDURE [XDCL] clp$$select_wild_card_program_n
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$selwcpn) $select_wild_card_program_names, $select_wild_card_program_name (
{   candidates: list 0..clc$max_list_size of program_name = $required
{   pattern: (wild_card_name) application = $required
{   pattern_type: key
{       (basic, b)
{       (extended, e)
{     keyend = $scl_options.wild_card_pattern_type
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        name: string (14),
        qualifier: clt$application_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (35),
      recend,
    recend := [
    [1,
    [90, 4, 3, 10, 4, 0, 889],
    clc$function, 3, 3, 2, 0, 0, 0, 0, 'OSM$$SELWCPN'], [
    ['CANDIDATES                     ',clc$nominal_entry, 1],
    ['PATTERN                        ',clc$nominal_entry, 2],
    ['PATTERN_TYPE                   ',clc$nominal_entry, 3]],
    [
{ 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, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, 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, 18, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [3, 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, 155,
  clc$optional_default_parameter, 0, 35]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 0, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$program_name_type]]
    ],
{ PARAMETER 2
    [[1, 14, clc$application_type], 'WILD_CARD_NAME', [FALSE]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BASIC                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXTENDED                       ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    '$scl_options.wild_card_pattern_type']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$candidates = 1,
      p$pattern = 2,
      p$pattern_type = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      candidate: ^clt$string_value,
      index: clt$list_size,
      match_info: clt$string_pattern_match_info,
      node: ^clt$data_value,
      pattern: ^clt$string_value,
      pattern_type: clt$wild_card_pattern_type,
      result_node: ^^clt$data_value,
      return_selected_indices: boolean,
      string_pattern: ^clt$string_pattern;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$candidates].value^.element_value = NIL) AND (pvt [p$candidates].value^.link = NIL) THEN
      result := pvt [p$candidates].value;
      RETURN;
    IFEND;

    clp$determine_select_result_typ (work_area, return_selected_indices, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pattern := pvt [p$pattern].value^.application_value;

    IF pvt [p$pattern_type].value^.keyword_value = 'BASIC' THEN
      pattern_type := clc$wc_basic_pattern;
    ELSE
      pattern_type := clc$wc_extended_pattern;
    IFEND;

    clp$build_pattern_for_wild_card (pattern_type, $clt$string_pattern_build_opts
          [clc$sp_match_at_right, clc$sp_ignore_matched_substring], pattern^, work_area, string_pattern,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    index := 0;
    result := NIL;
    node := pvt [p$candidates].value;
    result_node := ^result;
    WHILE node <> NIL DO
      candidate := ^node^.element_value^.program_name_value;

      clp$match_string_pattern (candidate^ (1, clp$trimmed_string_size (candidate^)), string_pattern,
            clc$sp_anchored, clc$sp_quick_scan, match_info, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      index := index + 1;
      IF match_info.result = clc$sp_success THEN
        IF return_selected_indices THEN
          clp$make_integer_value (index, 10, FALSE, work_area, node^.element_value);
        IFEND;
        result_node^ := node;
        result_node := ^node^.link;
      IFEND;
      node := node^.link;
    WHILEND;

    IF result <> NIL THEN
      result_node^ := NIL;
      result^.generated_via_list_rest := FALSE;
    ELSE
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

  PROCEND clp$$select_wild_card_program_n;
?? TITLE := 'clp$$select_wild_card_strings', EJECT ??

  PROCEDURE [XDCL] clp$$select_wild_card_strings
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$selwcs) $select_wild_card_strings, $select_wild_card_string (
{   candidates: list 0..clc$max_list_size of string = $required
{   pattern: (wild_card_pattern) any of
{       string
{       application
{     anyend = $required
{   pattern_type: key
{       (basic, b)
{       (extended, e)
{     keyend = $scl_options.wild_card_pattern_type
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        name: string (17),
        qualifier: clt$union_type_qualifier,
        type_size_1: clt$type_specification_size,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$application_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (35),
      recend,
    recend := [
    [1,
    [90, 4, 3, 10, 4, 10, 295],
    clc$function, 3, 3, 2, 0, 0, 0, 0, 'OSM$$SELWCS'], [
    ['CANDIDATES                     ',clc$nominal_entry, 1],
    ['PATTERN                        ',clc$nominal_entry, 2],
    ['PATTERN_TYPE                   ',clc$nominal_entry, 3]],
    [
{ 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, 24, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, 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, 49, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [3, 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, 155,
  clc$optional_default_parameter, 0, 35]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [8, 0, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 2
    [[1, 17, clc$union_type], 'WILD_CARD_PATTERN', [[clc$application_type, clc$string_type],
    FALSE, 2],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
    4, [[1, 0, clc$application_type], [FALSE]]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BASIC                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXTENDED                       ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    '$scl_options.wild_card_pattern_type']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$candidates = 1,
      p$pattern = 2,
      p$pattern_type = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      candidate: ^clt$string_value,
      index: clt$list_size,
      match_info: clt$string_pattern_match_info,
      node: ^clt$data_value,
      pattern: ^clt$string_value,
      pattern_type: clt$wild_card_pattern_type,
      result_node: ^^clt$data_value,
      return_selected_indices: boolean,
      string_pattern: ^clt$string_pattern;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$candidates].value^.element_value = NIL) AND (pvt [p$candidates].value^.link = NIL) THEN
      result := pvt [p$candidates].value;
      RETURN;
    IFEND;

    clp$determine_select_result_typ (work_area, return_selected_indices, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$pattern].value^.kind = clc$application THEN
      pattern := pvt [p$pattern].value^.application_value;
    ELSE
      pattern := pvt [p$pattern].value^.string_value;
    IFEND;

    IF pvt [p$pattern_type].value^.keyword_value = 'BASIC' THEN
      pattern_type := clc$wc_basic_pattern;
    ELSE
      pattern_type := clc$wc_extended_pattern;
    IFEND;

    clp$build_pattern_for_wild_card (pattern_type, $clt$string_pattern_build_opts
          [clc$sp_match_at_right, clc$sp_ignore_matched_substring], pattern^, work_area, string_pattern,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    index := 0;
    result := NIL;
    node := pvt [p$candidates].value;
    result_node := ^result;
    WHILE node <> NIL DO
      candidate := node^.element_value^.string_value;

      clp$match_string_pattern (candidate^, string_pattern, clc$sp_anchored, clc$sp_quick_scan, match_info,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      index := index + 1;
      IF match_info.result = clc$sp_success THEN
        IF return_selected_indices THEN
          clp$make_integer_value (index, 10, FALSE, work_area, node^.element_value);
        IFEND;
        result_node^ := node;
        result_node := ^node^.link;
      IFEND;
      node := node^.link;
    WHILEND;

    IF result <> NIL THEN
      result_node^ := NIL;
      result^.generated_via_list_rest := FALSE;
    ELSE
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

  PROCEND clp$$select_wild_card_strings;
?? TITLE := 'clp$$sort', EJECT ??

  PROCEDURE [XDCL] clp$$sort
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sort) $sort (
{   list: list 0..clc$max_list_size = $required
{   order: (DEFER) any of
{       key
{         (ascending, a)
{         (descending, d)
{       keyend
{       boolean
{     anyend = ascending
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
      recend,
      type2: 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 .. 4] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
        default_value: string (9),
      recend,
    recend := [
    [1,
    [90, 4, 3, 10, 4, 27, 805],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$SORT'], [
    ['LIST                           ',clc$nominal_entry, 1],
    ['ORDER                          ',clc$nominal_entry, 2]],
    [
{ 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, 16, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_positionally],
    clc$pass_by_value, clc$deferred_evaluation, clc$standard_parameter_checking, 178,
  clc$optional_default_parameter, 0, 9]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [0, 0, clc$max_list_size, 0, FALSE, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type],
    FALSE, 2],
    155, [[1, 0, clc$keyword_type], [4], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ASCENDING                      ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['DESCENDING                     ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ,
    'ascending']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$list = 1,
      p$order = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

{ TYPE
{   x_type = any
{ TYPEND

?? PUSH (LISTEXT := ON) ??

    VAR
      type_specification: [STATIC, READ, cls$declaration_section] record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend := [[1, 0, clc$union_type], [-$clt$type_kinds [], FALSE, 0]];

?? POP ??

    VAR
      converted_array: ^clt$data_value,
      current: integer,
      evaluate_expression: boolean,
      expression_parse: clt$parse_state,
      expression_result: ^clt$data_value,
      expression_type_description: clt$type_description,
      gap: integer,
      start: integer,
      swap: ^clt$data_value,
      swap_values: boolean,
      utility_attributes: array [1 .. 1] of clt$utility_attribute,
      utility_name: clt$utility_name;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$list].value^.element_value = NIL) AND (pvt [p$list].value^.link = NIL) THEN
      result := pvt [p$list].value;
      RETURN;
    IFEND;

    prepare_deferred_expression (pvt [p$order].value^.deferred_value, pvt [p$order].value^.deferred_type,
          work_area, expression_type_description, expression_parse, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    converted_array := NIL;
    clp$convert_list_to_array (pvt [p$list].value, NIL, NIL, work_area, converted_array, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    utility_name := 'SORT';
    utility_attributes [1].key := clc$null_utility_attribute;
    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$create_procedure_variable ('X1', clc$local_scope, clc$read_write, clc$immediate_evaluation,
          #SEQ (type_specification), NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$create_procedure_variable ('X2', clc$local_scope, clc$read_write, clc$immediate_evaluation,
          #SEQ (type_specification), NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Use shell sort technique.

    evaluate_expression := TRUE;
    gap := UPPERBOUND (converted_array^.array_value^);
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := 1 TO UPPERBOUND (converted_array^.array_value^) - gap DO
        current := start;
        swap_values := TRUE;
        WHILE (current > 0) AND swap_values DO
          IF evaluate_expression THEN
            clp$change_variable ('X1', converted_array^.array_value^ [current], status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            clp$change_variable ('X2', converted_array^.array_value^ [current + gap], status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            evaluate_deferred_expression (expression_parse, ^expression_type_description, work_area,
                  expression_result, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF expression_result^.kind = clc$keyword THEN
              evaluate_expression := FALSE;
            IFEND;
          IFEND;
          IF evaluate_expression THEN
            swap_values := NOT expression_result^.boolean_value.value;
          ELSEIF expression_result^.keyword_value = 'ASCENDING' THEN
            swap_values := (clp$data_value_compare (converted_array^.array_value^ [current],
                  converted_array^.array_value^ [current + gap]) = clc$left_is_greater);
          ELSE {DESCENDING}
            swap_values := (clp$data_value_compare (converted_array^.array_value^ [current],
                  converted_array^.array_value^ [current + gap]) = clc$right_is_greater);
          IFEND;
          IF swap_values THEN
            swap := converted_array^.array_value^ [current];
            converted_array^.array_value^ [current] := converted_array^.array_value^ [current + gap];
            converted_array^.array_value^ [current + gap] := swap;
            current := current - gap;
          IFEND;
        WHILEND;
      FOREND;
    WHILEND;

    clp$end_utility (utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    result := NIL;
    clp$convert_array_to_list (converted_array, NIL, NIL, work_area, result, status);
    IF status.normal THEN
      result^.generated_via_list_rest := FALSE;
    IFEND;

  PROCEND clp$$sort;
?? TITLE := 'clp$$sublist', EJECT ??

  PROCEDURE [XDCL] clp$$sublist
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sublist) $sublist (
{   list: list 0..clc$max_list_size = $required
{   selector: list 0..clc$max_list_size of any of
{       integer 1..clc$max_list_size
{       range of integer 1..clc$max_list_size
{       record
{         start: integer 1..clc$max_list_size
{         count: any of
{           key
{             all
{           keyend
{           integer 0..clc$max_list_size
{         anyend
{       recend
{     anyend = $required
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$integer_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
          type_size_3: clt$type_specification_size,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: 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$integer_type_qualifier,
              recend,
            recend,
          recend,
        recend,
      recend,
    recend := [
    [1,
    [90, 4, 13, 9, 28, 56, 674],
    clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$SUBLIST'], [
    ['LIST                           ',clc$nominal_entry, 1],
    ['SELECTOR                       ',clc$nominal_entry, 2]],
    [
{ 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, 16, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, 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, 270,
  clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [0, 0, clc$max_list_size, 0, FALSE, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [254, 0, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$integer_type, clc$range_type, clc$record_type],
      FALSE, 3],
      20, [[1, 0, clc$integer_type], [1, clc$max_list_size, 10]],
      27, [[1, 0, clc$range_type], [20],
          [[1, 0, clc$integer_type], [1, clc$max_list_size, 10]]
        ],
      183, [[1, 0, clc$record_type], [2],
        ['START                          ', clc$required_field, 20], [[1, 0, clc$integer_type], [1,
  clc$max_list_size, 10]],
        ['COUNT                          ', clc$required_field, 84], [[1, 0, clc$union_type], [[
          clc$integer_type, clc$keyword_type],
          FALSE, 2],
          44, [[1, 0, clc$keyword_type], [1], [
            ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
            ],
          20, [[1, 0, clc$integer_type], [0, clc$max_list_size, 10]]
          ]
        ]
      ]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$list = 1,
      p$selector = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      count: integer,
      list_index: 1 .. clc$max_list_size,
      list_node: ^clt$data_value,
      number_of_elements: clt$list_size,
      result_node: ^^clt$data_value,
      selector_node: ^clt$data_value,
      start: 1 .. clc$max_list_size;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    list_node := pvt [p$list].value;
    number_of_elements := clp$count_list_elements (list_node);

    IF number_of_elements = 0 THEN
      result := list_node;
      RETURN;
    IFEND;

    selector_node := pvt [p$selector].value;
    list_index := 1;
    result := NIL;
    result_node := ^result;

    WHILE (selector_node <> NIL) AND (selector_node^.element_value <> NIL) DO
      CASE selector_node^.element_value^.kind OF

      = clc$integer =
        start := selector_node^.element_value^.integer_value.value;
        count := 1;

      = clc$range =
        start := selector_node^.element_value^.low_value^.integer_value.value;
        count := selector_node^.element_value^.high_value^.integer_value.value - start + 1;

      ELSE {clc$record}
        start := selector_node^.element_value^.field_values^ [1].value^.integer_value.value;
        IF selector_node^.element_value^.field_values^ [2].value^.kind = clc$keyword {ALL} THEN
          count := number_of_elements - start + 1;
        ELSE
          count := selector_node^.element_value^.field_values^ [2].value^.integer_value.value;
        IFEND;
      CASEND;

      IF (start <= number_of_elements) AND (count > 0) THEN
        IF start < list_index THEN
          list_node := pvt [p$list].value;
          list_index := 1;
        IFEND;
        WHILE list_index < start DO
          list_index := list_index + 1;
          list_node := list_node^.link;
        WHILEND;
        REPEAT
          clp$make_list_value (work_area, result_node^);
          result_node^^.element_value := list_node^.element_value;
          result_node := ^result_node^^.link;
          list_node := list_node^.link;
          list_index := list_index + 1;
          count := count - 1;
        UNTIL (count = 0) OR (list_node = NIL);
      IFEND;

      selector_node := selector_node^.link;
    WHILEND;

    IF result = NIL THEN
      clp$make_list_value (work_area, result);
      RETURN;
    IFEND;

  PROCEND clp$$sublist;
?? TITLE := 'clp$$subset', EJECT ??

  PROCEDURE [XDCL] clp$$subset
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$subset) $subset (
{   subset: list 0..clc$max_list_size = $required
{   set: list 0..clc$max_list_size = $required
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
      recend,
    recend := [
    [1,
    [90, 4, 3, 10, 5, 7, 629],
    clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$SUBSET'], [
    ['SET                            ',clc$nominal_entry, 2],
    ['SUBSET                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 16, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [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, 16, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [0, 0, clc$max_list_size, 0, FALSE, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [0, 0, clc$max_list_size, 0, FALSE, FALSE]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$subset = 1,
      p$set = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      first_list: ^clt$data_value,
      second_list: ^clt$data_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    first_list := pvt [p$subset].value;

  /traverse_first_list/
    WHILE first_list <> NIL DO
      second_list := pvt [p$set].value;

    /compare_elements/
      WHILE second_list <> NIL DO

{  The check of first_list^.element_value for NIL is necessary for an empty list
{  to be the subset of any list.

        IF (first_list^.element_value = NIL) OR (clp$data_value_compare
              (first_list^.element_value, second_list^.element_value) = clc$equal) THEN
          EXIT /compare_elements/;
        IFEND;
        second_list := second_list^.link;
      WHILEND /compare_elements/;

      IF second_list = NIL THEN
        EXIT /traverse_first_list/;
      IFEND;
      first_list := first_list^.link;
    WHILEND /traverse_first_list/;

    clp$make_boolean_value ((second_list <> NIL), clc$true_false_boolean, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$subset;
?? TITLE := 'clp$$union', EJECT ??

  PROCEDURE [XDCL] clp$$union
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$union) $union (
{   lists: list rest of list 0..clc$max_list_size = $required
{   )

?? 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$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier_v2,
        recend,
      recend,
    recend := [
    [1,
    [90, 4, 3, 10, 5, 15, 550],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$UNION'], [
    ['LISTS                          ',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, 32, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [16, 1, clc$max_list_size, 0, FALSE, TRUE],
      [[1, 0, clc$list_type], [0, 0, clc$max_list_size, 0, FALSE, FALSE]]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$lists = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    join_lists (pvt [p$lists].value, result);

    IF result <> NIL THEN
      remove_redundant_elements (result);
      result^.generated_via_list_rest := FALSE;
    ELSE
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      IFEND;
    IFEND;

  PROCEND clp$$union;
?? TITLE := 'clp$reverse_list', EJECT ??

  PROCEDURE [XDCL] clp$reverse_list
    (VAR list: ^clt$data_value);

    VAR
      previous: ^clt$data_value,
      next_node: ^clt$data_value,
      node: ^clt$data_value;

    previous := NIL;
    node := list;

    WHILE node <> NIL DO
      next_node := node^.link;
      node^.link := previous;
      previous := node;
      node := next_node;
    WHILEND;

    list := previous;

  PROCEND clp$reverse_list;
?? TITLE := 'clp$determine_select_result_typ', EJECT ??

  PROCEDURE [XDCL] clp$determine_select_result_typ
    (VAR work_area {input, output} : ^clt$work_area;
     VAR return_selected_indices: boolean;
     VAR status: ost$status);

    VAR
      element_type_kind: clt$type_kind,
      ignore_element_type_spec: ^clt$type_specification;


    get_expected_element_type (NIL, work_area, element_type_kind, ignore_element_type_spec, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    return_selected_indices := element_type_kind = clc$integer_type;

  PROCEND clp$determine_select_result_typ;
?? TITLE := 'evaluate_deferred_expression', EJECT ??

  PROCEDURE [INLINE] evaluate_deferred_expression
    (    expression_parse: clt$parse_state;
         type_description: ^clt$type_description;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    VAR
      ignore_result_type_description: ^clt$type_description,
      parse: clt$parse_state;


    status.normal := TRUE;
    parse := expression_parse;

    clp$internal_evaluate_expr (parse, type_description, work_area, ignore_result_type_description, result,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parse.unit_is_space THEN
      clp$scan_non_space_lexical_unit (parse);
    IFEND;
    IF parse.unit_index < parse.index_limit THEN
      osp$set_status_abnormal ('CL', cle$expecting_end_of_expression, '', status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      RETURN;
    IFEND;

    IF result^.kind = clc$unspecified THEN
      osp$set_status_abnormal ('CL', cle$unspecified_value_for_req, 'clp$evaluate_expression', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, expression_parse.text^, status);
    IFEND;

  PROCEND evaluate_deferred_expression;
?? TITLE := 'find_non_empty_list', EJECT ??

  PROCEDURE [INLINE] find_non_empty_list
    (VAR node: ^clt$data_value);

    WHILE (node <> NIL) AND (node^.element_value^.kind = clc$list) AND
          (node^.element_value^.element_value = NIL) DO
      node := node^.link;
    WHILEND;

  PROCEND find_non_empty_list;
?? TITLE := 'get_expected_element_type', EJECT ??

  PROCEDURE [INLINE] get_expected_element_type
    (    default_element_type: ^clt$type_specification;
     VAR work_area {input, output} : ^clt$work_area;
     VAR element_type_kind: clt$type_kind;
     VAR element_type_specification: ^clt$type_specification;
     VAR status: ost$status);

    VAR
      expected_type_specification: ^clt$type_specification,
      header: ^clt$type_specification_header,
      ignore_type_name: ^clt$type_name_reference,
      list_type_qualifier: ^clt$list_type_qualifier_v2;


    clp$get_expected_type (work_area, expected_type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    element_type_specification := default_element_type;

  /find_element_type/
    WHILE expected_type_specification <> NIL DO
      RESET expected_type_specification;
      NEXT header IN expected_type_specification;
      IF header^.kind <> clc$list_type THEN
        EXIT /find_element_type/;
      IFEND;
      NEXT ignore_type_name: [header^.name_size] IN expected_type_specification;
      NEXT list_type_qualifier IN expected_type_specification;
      IF list_type_qualifier^.element_type_specification_size = 0 THEN
        element_type_specification := default_element_type;
        EXIT /find_element_type/;
      IFEND;
      NEXT element_type_specification: [[REP list_type_qualifier^.element_type_specification_size OF cell]] IN
            expected_type_specification;
      IF NOT list_type_qualifier^.list_rest THEN
        EXIT /find_element_type/;
      IFEND;
      expected_type_specification := element_type_specification;
    WHILEND /find_element_type/;

    IF element_type_specification = NIL THEN
      element_type_kind := clc$union_type;
    ELSE
      RESET element_type_specification;
      NEXT header IN element_type_specification;
      element_type_kind := header^.kind;
      RESET element_type_specification;
    IFEND;

  PROCEND get_expected_element_type;
?? TITLE := 'join_lists', EJECT ??

  PROCEDURE [INLINE] join_lists
    (    value: ^clt$data_value;
     VAR result: ^clt$data_value);

    VAR
      last_node: ^clt$data_value,
      next_node: ^^clt$data_value,
      top_node: ^clt$data_value;


    result := NIL;
    next_node := ^result;
    top_node := value;

  /join/
    WHILE TRUE DO
      WHILE top_node^.element_value^.element_value = NIL DO
        IF top_node^.link = NIL THEN
          EXIT /join/;
        IFEND;
        top_node := top_node^.link;
      WHILEND;

      next_node^ := top_node^.element_value;

      IF top_node^.link = NIL THEN
        EXIT /join/;
      IFEND;
      last_node := top_node^.element_value;
      WHILE last_node^.link <> NIL DO
        last_node := last_node^.link;
      WHILEND;
      top_node := top_node^.link;

      next_node := ^last_node^.link;
    WHILEND /join/;

  PROCEND join_lists;
?? TITLE := 'prepare_deferred_expression', EJECT ??

  PROCEDURE [INLINE] prepare_deferred_expression
    (    expression_text: ^clt$expression_text;
         type_specification: ^clt$type_specification;
     VAR work_area {input, output} : ^clt$work_area;
     VAR type_description: clt$type_description;
     VAR expression_parse: clt$parse_state;
     VAR status: ost$status);

    VAR
      lexical_units: ^clt$lexical_units;


    clp$convert_type_spec_to_desc (type_specification, work_area, type_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$identify_lexical_units (expression_text, work_area, lexical_units, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$initialize_parse_state (expression_text, lexical_units, expression_parse);
    clp$scan_non_space_lexical_unit (expression_parse);

  PROCEND prepare_deferred_expression;
?? TITLE := 'remove_redundant_elements', EJECT ??

  PROCEDURE [INLINE] remove_redundant_elements
    (VAR node: ^clt$data_value);

    VAR
      local_node: ^clt$data_value,
      previous_node: ^clt$data_value;


    IF (node <> NIL) AND (node^.element_value = NIL) THEN
      node := node^.link;
    IFEND;
    local_node := node;

    WHILE local_node <> NIL DO
      previous_node := local_node;
      WHILE previous_node^.link <> NIL DO
        IF (previous_node^.link^.element_value = NIL) OR (clp$data_value_compare
              (local_node^.element_value, previous_node^.link^.element_value) = clc$equal) THEN
          previous_node^.link := previous_node^.link^.link;
        ELSE
          previous_node := previous_node^.link;
        IFEND;
      WHILEND;
      local_node := local_node^.link;
    WHILEND;

  PROCEND remove_redundant_elements;

MODEND clm$list_functions;

*DECK DECK=CLM$LOCAL_QUEUE_FAP EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : File Access Procedure for local queues' ??
MODULE clm$local_queue_fap;

{
{ PURPOSE:
{   This module contains the file access procedure (FAP) that processes
{   I/O requests for files which have been associated with local queues
{   via a REQUEST_LOCAL_QUEUE. Only open, close, get_next, and put_next
{   requests are processed.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$fap_validation_errors
*copyc amt$fap_declarations
*copyc cle$ecc_expression_result
*copyc cle$ecc_miscellaneous
*copyc fsc$local
*copyc ost$caller_identifier
?? POP ??
*copyc amp$set_file_instance_abnormal
*copyc amp$validate_caller_privilege
*copyc bap$close
*copyc bap$fetch
*copyc clp$get_fs_path_elements
*copyc fsp$path_element
*copyc i#move
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$connect_queue
*copyc pmp$define_queue
*copyc pmp$disconnect_queue
*copyc pmp$receive_from_queue
*copyc pmp$remove_queue
*copyc pmp$send_to_queue

*copyc bav$task_file_table
?? TITLE := 'clp$local_queue_fap', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$local_queue_fap
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);


    VAR
      caller_id: ost$caller_identifier,
      data_area: ^cell,
      data_length: ^amt$file_byte_address,
      evaluated_file_reference: fst$evaluated_file_reference,
      ignore_structure_pointer: ^cell,
      local_status: ost$status,
      message: ^pmt$message_value,
      message_seq: pmt$message,
      queue_id: pmt$queue_connection,
      queue_name: pmt$queue_name;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    amp$validate_caller_privilege (file_identifier, call_block, layer_number,
          $pft$usage_selections [pfc$append], caller_id.ring, ignore_structure_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_fs_path_elements (bav$task_file_table^ [file_identifier.ordinal].local_file_name,
          evaluated_file_reference, status);
    queue_name := fsp$path_element (^evaluated_file_reference, 2) ^;
    CASE call_block.operation OF

    = amc$open_req =
      IF fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local THEN
        pmp$define_queue (queue_name, caller_id.ring, caller_id.ring, status);
        IF NOT status.normal AND (status.condition = pme$queue_already_defined) THEN
          status.normal := TRUE;
        IFEND;
      ELSE
        osp$set_status_condition (cle$only_permitted_on_loc_file, status);
      IFEND;

    = amc$get_next_req =
      pmp$connect_queue (queue_name, queue_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pmp$receive_from_queue (queue_id, osc$nowait, message_seq, status);
      pmp$disconnect_queue (queue_id, local_status);
      IF message_seq.contents = pmc$no_message THEN
        call_block.getn.file_position^ := amc$eoi;
        RETURN;
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF message_seq.contents <> pmc$message_value THEN
        osp$set_status_condition (pme$incorrect_message_type, status);
        RETURN;
      IFEND;
      message := ^message_seq.value;
      RESET message;
      NEXT data_length IN message;
      IF data_length^ > (#SIZE (message_seq.value) - #SIZE (data_length^)) THEN
        osp$set_status_abnormal ('CL', cle$string_too_long, ' for get_next of local queue line', status);
        RETURN;
      IFEND;
      NEXT data_area IN message;
      IF call_block.getn.working_storage_length < data_length^ THEN
        call_block.getn.transfer_count^ := call_block.getn.working_storage_length;
        call_block.getn.file_position^ := amc$mid_record;
      ELSE
        call_block.getn.transfer_count^ := data_length^;
        call_block.getn.file_position^ := amc$eor;
      IFEND;
      i#move (data_area, call_block.getn.working_storage_area, call_block.getn.transfer_count^);
      call_block.getn.byte_address^ := 0;

    = amc$put_next_req =
      IF call_block.putn.working_storage_length > (#SIZE (message_seq.value) - #SIZE (amt$file_byte_address))
            THEN
        osp$set_status_abnormal ('CL', cle$string_too_long, ' for put_next of local queue line', status);
        RETURN;
      IFEND;
      message_seq.contents := pmc$message_value;
      message := ^message_seq.value;
      RESET message;
      NEXT data_length IN message;
      data_length^ := call_block.putn.working_storage_length;
      NEXT data_area IN message;
      i#move (call_block.putn.working_storage_area, data_area, data_length^);

      pmp$connect_queue (queue_name, queue_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pmp$send_to_queue (queue_id, message_seq, status);
      IF status.normal THEN
        call_block.putn.byte_address^ := 0;
      IFEND;

      pmp$disconnect_queue (queue_id, local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;

    = amc$close_req =
      pmp$remove_queue (queue_name, local_status);

      bap$close (file_identifier, status);

    = amc$fetch_req =
      bap$fetch (file_identifier, call_block, layer_number, status);

    ELSE
      amp$set_file_instance_abnormal (file_identifier, ame$improper_fap_operation, call_block.operation, '',
            status);
    CASEND;

  PROCEND clp$local_queue_fap;

MODEND clm$local_queue_fap;
*DECK DECK=CLM$LOCAL_QUEUE_TABLE_MANAGER EXPAND=TRUE
MODULE clm$local_queue_table_manager;
MODEND clm$local_queue_table_manager;
*DECK DECK=CLM$LOG_COMMENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Log Message from Display_Message Command' ??
MODULE clm$log_comment;

{
{ PURPOSE:
{   This module contains the procedure that performs the bulk of the processing
{   for the display_message command.
{
?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cll$comment_command
*copyc jmc$job_management_id
*copyc jml$user_id
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc ost$name
*copyc ost$status
*copyc jme$job_history_conditions
*copyc pme$logging_exceptions
?? POP ??
*copyc avp$accounting_administrator
*copyc avp$configuration_administrator
*copyc avp$get_capability
*copyc avp$system_operator
*copyc ofp$display_status_message
*copyc osp$set_status_abnormal
*copyc pmp$get_job_names
*copyc pmp$log_ascii
*copyc sfp$activate_job_statistic
*copyc sfp$deactivate_job_statistic
*copyc sfp$emit_statistic
*copyc jmv$job_history_active

?? TITLE := 'clp$log_comment', EJECT ??
*copy clh$log_comment

  PROCEDURE [XDCL, #GATE] clp$log_comment
    (    message: string ( * );
         log_name_selections: array [ * ] of ost$name;
     VAR status: ost$status);

    VAR
      data_size: 1 .. osc$max_string_size,

{ The length of history_message_size is the length of the descriptive data minus the job name.

      history_message_size: 0 .. osc$max_string_size - jmc$system_supplied_name_size,
      log_array_index: integer,
      message_size: 0 .. ofc$max_display_message,
      engineering_oper_capability: boolean,
      statistic_data: string (osc$max_string_size),
      system_job_name: jmt$system_supplied_name,
      user_job_name: jmt$user_supplied_name;

    status.normal := TRUE;
    FOR log_array_index := LOWERBOUND (log_name_selections) TO UPPERBOUND (log_name_selections) DO

      IF log_name_selections [log_array_index] = 'SYSTEM' THEN
        IF avp$system_operator () THEN
          pmp$log_ascii (message, $pmt$ascii_logset [pmc$system_log], pmc$msg_origin_program, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal ('PM', pme$cannot_write_in_system_log, '', status);
          RETURN;
        IFEND;

      ELSEIF log_name_selections [log_array_index] = 'STATISTIC' THEN
        IF (avp$system_operator () OR avp$configuration_administrator ()) THEN
          sfp$activate_job_statistic (cll$comment_command, $sft$binary_logset [pmc$statistic_log], status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          sfp$emit_statistic (cll$comment_command, message, NIL, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          sfp$deactivate_job_statistic (cll$comment_command, $sft$binary_logset [pmc$statistic_log], status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal ('PM', pme$cannot_write_to_log, 'STATISTIC_LOG', status);
          RETURN;
        IFEND;

      ELSEIF log_name_selections [log_array_index] = 'ENGINEERING' THEN
        IF NOT avp$system_operator () THEN
          avp$get_capability (avc$engineering_operation, avc$user, engineering_oper_capability,
              status);
          IF NOT status.normal THEN
            RETURN;
          ELSEIF NOT engineering_oper_capability THEN
            osp$set_status_abnormal ('PM', pme$cannot_write_to_log, 'ENGINEERING_LOG', status);
            RETURN;
          IFEND;
        IFEND;
        sfp$activate_job_statistic (cll$comment_command, $sft$binary_logset [pmc$engineering_log], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        sfp$emit_statistic (cll$comment_command, message, NIL, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        sfp$deactivate_job_statistic (cll$comment_command, $sft$binary_logset [pmc$engineering_log],
            status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSEIF log_name_selections [log_array_index] = 'ACCOUNT' THEN
        IF (avp$system_operator () OR avp$accounting_administrator ()) THEN
          sfp$activate_job_statistic (cll$comment_command, $sft$binary_logset [pmc$account_log], status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          sfp$emit_statistic (cll$comment_command, message, NIL, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          sfp$deactivate_job_statistic (cll$comment_command, $sft$binary_logset [pmc$account_log], status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal ('PM', pme$cannot_write_to_log, 'ACCOUNT_LOG', status);
          RETURN;
        IFEND;

      ELSEIF log_name_selections [log_array_index] = 'JOB' THEN
        pmp$log_ascii (message, $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_program, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSEIF log_name_selections [log_array_index] = 'JOB_ACCOUNT' THEN
        IF (avp$system_operator () OR avp$accounting_administrator ()) THEN
          sfp$activate_job_statistic (cll$comment_command, $sft$binary_logset [pmc$job_account_log], status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          sfp$emit_statistic (cll$comment_command, message, NIL, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          sfp$deactivate_job_statistic (cll$comment_command, $sft$binary_logset [pmc$job_account_log],
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      ELSEIF log_name_selections [log_array_index] = 'JOB_STATISTIC' THEN
        sfp$activate_job_statistic (cll$comment_command, $sft$binary_logset [pmc$job_statistic_log], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        sfp$emit_statistic (cll$comment_command, message, NIL, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        sfp$deactivate_job_statistic (cll$comment_command, $sft$binary_logset [pmc$job_statistic_log],
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSEIF log_name_selections [log_array_index] = 'JOB_MESSAGE' THEN
        IF STRLENGTH (message) <= ofc$max_display_message THEN
          message_size := STRLENGTH (message);
        ELSE
          message_size := ofc$max_display_message;
        IFEND;
        ofp$display_status_message (message (1, message_size), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSEIF log_name_selections [log_array_index] = 'HISTORY' THEN
        IF jmv$job_history_active THEN
          pmp$get_job_names (user_job_name, system_job_name, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          data_size := 1;
          statistic_data (data_size, jmc$system_supplied_name_size) :=
                system_job_name (1, jmc$system_supplied_name_size);
          data_size := data_size + jmc$system_supplied_name_size;
          IF STRLENGTH (message) <= osc$max_string_size - jmc$system_supplied_name_size THEN
            history_message_size := STRLENGTH (message);
          ELSE
            history_message_size := osc$max_string_size - jmc$system_supplied_name_size;
          IFEND;
          statistic_data (data_size, history_message_size) := message (1, history_message_size);
          data_size := data_size + history_message_size - 1;
          sfp$emit_statistic (jml$job_history_message, statistic_data (1, data_size), NIL, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal (jmc$job_management_id, jme$jh_job_history_not_active, '', status);
          RETURN;
        IFEND;

      ELSE
        ;
      IFEND;
    FOREND;

  PROCEND clp$log_comment;

MODEND clm$log_comment;
*DECK DECK=CLM$LONGREAL_ARITHMETIC EXPAND=TRUE
.
clm$longreal_arithmetic         IDENT
.
.
.  PURPOSE:
.    This module contains functions that call standard math library
.    functions.  These functions simply load the arguments from the
.    CYBIL parameter list into the appropriate registers and call the
.    corresponding math library function.
.
.
.  Parameter list offsets:
.
left                            equ       0
right                           equ       8
.
.
.  External reference definitions for math library functions:
.
                                use       binding
.
                                ref       mlp$vdtod
dtod                            address   c,mlp$vdtod
.
                                ref       mlp$vdtoi
dtoi                            address   c,mlp$vdtoi
.
                                ref       mlp$vitod
itod                            address   c,mlp$vitod
.
                                ref       mlp$vitoi
itoi                            address   c,mlp$vitoi
.
                                use code
.
                                page
.
. ----------------------------------------------------------------------------
.
. FUNCTION [XDCL] clp$dtod
.   (    left {input} : longreal;
.        right: longreal): longreal;
.
. ----------------------------------------------------------------------------
.
.
clp$dtod                        align     0,8
                                def       clp$dtod
.
                                la        ae,a4,left
                                lbyts,8   x2,ae,x0,0
                                lbyts,8   x3,ae,x0,8
.
                                la        ac,a4,right
                                lbyts,8   x4,ac,x0,0
                                lbyts,8   x5,ac,x0,8
.
                                ente      x0,0040(16)
                                callseg   dtod,a3,a4
.
                                return
.
                                page
.
. ----------------------------------------------------------------------------
.
. FUNCTION [XDCL] clp$dtoi
.   (    left: longreal;
.        right: integer): longreal;
.
. ----------------------------------------------------------------------------
.
.
clp$dtoi                        align     0,8
                                def       clp$dtoi
.
                                la        ae,a4,left
                                lbyts,8   x2,ae,x0,0
                                lbyts,8   x3,ae,x0,8
.
                                lx        x4,a4,right
.
                                ente      x0,0040(16)
                                callseg   dtoi,a3,a4
.
                                return
.
                                page
.
. ----------------------------------------------------------------------------
.
. FUNCTION [XDCL] clp$itod
.   (    left: integer;
.        right: longreal): longreal;
.
. ----------------------------------------------------------------------------
.
.
clp$itod                        align     0,8
                                def       clp$itod
.
                                lx        x2,a4,left
.
                                la        ac,a4,right
                                lbyts,8   x3,ac,x0,0
                                lbyts,8   x4,ac,x0,8
.
                                ente      x0,0040(16)
                                callseg   itod,a3,a4
.
                                return
.
                                page
.
. ----------------------------------------------------------------------------
.
. FUNCTION [XDCL] clp$itoi
.   (    left: integer;
.        right: integer): integer;
.
. ----------------------------------------------------------------------------
.
.
clp$itoi                        align     0,8
                                def       clp$itoi
.
                                lx        x2,a4,left
.
                                lx        x3,a4,right
.
                                ente      x0,0040(16)
                                callseg   itoi,a3,a4
.
                                return
.
                                end
*DECK DECK=CLM$LONGREAL_CONSTANTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : LONGREAL Constants' ??
MODULE clm$longreal_constants;

{
{ PURPOSE:
{   This module contains declarations for certain real number values.  This is
{   necessary because of CYBIL's incomplete support of the LONGREAL data type.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
*copyc clt$longreal
?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
?? POP ??
?? TITLE := 'Initialization of "constants"', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    max_integer_as_real: [STATIC, READ, oss$job_paged_literal] clt$longreal :=
          [3, [[403f(16), 0ffffffffffff(16)], [403f(16), 0fffe00000000(16)]]],
    max_real: [STATIC, READ, oss$job_paged_literal] clt$longreal :=
          [3, [[4fff(16), 0ffffffffffff(16)], [4fff(16), 0ffffffffffff(16)]]],
    min_integer_as_real: [STATIC, READ, oss$job_paged_literal] clt$longreal :=
          [3, [[0c040(16), 800000000000(16)], [0c040(16), 0(16)]]],
    min_real: [STATIC, READ, oss$job_paged_literal] clt$longreal :=
          [3, [[0cfff(16), 0ffffffffffff(16)], [0cfff(16), 0ffffffffffff(16)]]],
    negative_infinity: [STATIC, READ, oss$job_paged_literal] clt$longreal :=
          [3, [[0d000(16), 0], [0d000(16), 0]]],
    positive_infinity: [STATIC, READ, oss$job_paged_literal] clt$longreal :=
          [3, [[5000(16), 0], [5000(16), 0]]],
*ELSE
    max_integer_as_real: [STATIC, READ, oss$job_paged_literal] clt$longreal :=
          [3, [0, 41d(16), 3ffffff(16), 3c00(16)]],
    max_real: [STATIC, READ, oss$job_paged_literal] clt$longreal :=
          [3, [0, 7fe(16), 3ffffff(16), 3ffffff(16)]],
    min_integer_as_real: [STATIC, READ, oss$job_paged_literal] clt$longreal :=
          [3, [1, 41e(16), 0, 0]],
    min_real: [STATIC, READ, oss$job_paged_literal] clt$longreal :=
          [3, [1, 7fe(16), 3ffffff(16), 3ffffff(16)]],
    negative_infinity: [STATIC, READ, oss$job_paged_literal] clt$longreal :=
          [3, [1, 7ff(16), 0, 0]],
    positive_infinity: [STATIC, READ, oss$job_paged_literal] clt$longreal :=
          [3, [0, 7ff(16), 0, 0]],

*IFEND
    real_one: [STATIC, READ, oss$job_paged_literal] longreal := 1.0d0,
    real_zero: [STATIC, READ, oss$job_paged_literal] longreal := 0.0d0;

?? TITLE := 'Pointers to "constants"', EJECT ??

  VAR
    clv$max_integer_as_real: [XDCL, READ, oss$job_paged_literal] ^longreal := ^max_integer_as_real.long_real;

  VAR
    clv$max_real: [XDCL, READ, oss$job_paged_literal] ^longreal := ^max_real.long_real;

  VAR
    clv$min_integer_as_real: [XDCL, READ, oss$job_paged_literal] ^longreal := ^min_integer_as_real.long_real;

  VAR
    clv$min_real: [XDCL, READ, oss$job_paged_literal] ^longreal := ^min_real.long_real;

  VAR
    clv$negative_infinity: [XDCL, READ, oss$job_paged_literal] ^longreal := ^negative_infinity.long_real;

  VAR
    clv$positive_infinity: [XDCL, READ, oss$job_paged_literal] ^longreal := ^positive_infinity.long_real;

  VAR
    clv$real_one: [XDCL, READ, oss$job_paged_literal] ^longreal := ^real_one;

  VAR
    clv$real_zero: [XDCL, READ, oss$job_paged_literal] ^longreal := ^real_zero;

MODEND clm$longreal_constants;
*DECK DECK=CLM$MISCELLANEOUS_FUNCTIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Miscellaneous Functions' ??
MODULE clm$miscellaneous_functions;

{
{ PURPOSE:
{   This module contains miscellaneous "built-in" functions.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$compiling_for_test_harness
*copyc clc$standard_file_names
*copyc cld$value
*copyc cle$bad_data_value
*copyc cle$ecc_file_reference
*copyc cle$ecc_function_processing
*copyc cle$ecc_parsing
*copyc cle$string_too_long
*copyc cle$unexpected_call_to
*copyc cle$work_area_overflow
*copyc clt$name
*copyc jmt$job_class_set
*copyc ose$undefined_condition
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc clp$append_status_value_type
*copyc clp$check_name_for_boolean
*copyc clp$convert_data_to_string
*copyc clp$convert_integer_to_string
*copyc clp$convert_list_to_array
*copyc clp$convert_string_to_name
*copyc clp$count_list_elements
*copyc clp$data_representation_text
*copyc clp$derive_type_desc_from_value
*copyc clp$evaluate_expression
*copyc clp$evaluate_parameters
*copyc clp$find_current_block
*copyc clp$find_input_block
*copyc clp$get_date_time_string
*copyc clp$get_expected_type
*copyc clp$get_path_name
*copyc clp$get_variable
*copyc clp$i_convert_string_to_integer
*copyc clp$internal_convert_to_string
*copyc clp$longreal_classify
*copyc clp$make_application_value
*copyc clp$make_boolean_value
*copyc clp$make_clt$integer_value
*copyc clp$make_clt$real_value
*copyc clp$make_data_name_value
*copyc clp$make_date_time_value
*copyc clp$make_file_value
*copyc clp$make_integer_value
*copyc clp$make_keyword_value
*copyc clp$make_list_value
*copyc clp$make_name_value
*copyc clp$make_program_name_value
*copyc clp$make_range_value
*copyc clp$make_real_value
*copyc clp$make_record_value
*copyc clp$make_sized_string_value
*copyc clp$make_status_value
*copyc clp$make_string_value
*copyc clp$make_type_spec_value
*copyc clp$make_value
*copyc clp$scan_argument_list
*copyc clp$sort_record_fields
*copyc clp$trimmed_string_size
*copyc jmp$get_attribute_defaults
*copyc jmp$get_job_attributes
*copyc nap$namve_active
*copyc nap$namve_config_activated
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$append_status_real
*IF NOT $true(osv$unix)
*copyc osp$find_natural_language
*IFEND
*copyc osp$find_status_message_level
*copyc osp$format_message
*copyc osp$get_diagnostic_severity
*copyc osp$get_job_template_name
*copyc osp$get_status_condition_code
*copyc osp$get_status_condition_name
*copyc osp$get_status_condition_string
*copyc osp$get_status_severity
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$status_condition_code
*copyc pmp$connect_queue
*copyc pmp$define_queue
*copyc pmp$disconnect_queue
*copyc pmp$get_binary_mainframe_id
*copyc pmp$get_cpu_attributes
*copyc pmp$get_compact_date_time
*copyc pmp$get_date
*copyc pmp$get_default_date_time_form
*copyc pmp$get_job_mode
*copyc pmp$get_mainframe_attributes
*copyc pmp$get_microsecond_clock
*copyc pmp$get_processor_id
*copyc pmp$get_termination_status
*copyc pmp$get_unique_name
*copyc pmp$status_queue

*copyc clv$max_real
*copyc clv$min_real
*copyc clv$positive_infinity
*copyc clv$negative_infinity
*copyc clv$string_delimiter
*copyc clv$type_kind_names
*copyc clv$value_descriptors
*copyc jmv$job_termination_status
*copyc osv$control_codes_to_quest_mark
*copyc osv$lower_to_upper
*copyc osv$severities
*copyc osv$upper_to_lower

?? TITLE := 'union_type', EJECT ??

{ TYPE
{   union_type = any
{ TYPEND

  VAR
    union_type: [STATIC, READ, cls$declaration_section] record
      header: clt$type_specification_header,
      qualifier: clt$union_type_qualifier,
    recend := [[1, 0, clc$union_type], [-$clt$type_kinds [], FALSE, 0]];

*IF NOT $true(osv$unix)
?? TITLE := 'clp$$array', EJECT ??

  PROCEDURE [XDCL] clp$$array
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$array) $array (
{   list: list = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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$list_type_qualifier,
        recend,
      recend := [[1, [88, 4, 30, 18, 12, 51, 400], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$ARRAY'],
            [['LIST                           ', 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, 16, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$list_type], [0, 1, clc$max_list_size, FALSE]]];

?? POP ??

    CONST
      p$list = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_list_to_array (pvt [p$list].value, NIL, NIL, work_area, result, status);

  PROCEND clp$$array;
*IFEND
?? TITLE := 'clp$$char', EJECT ??

  PROCEDURE [XDCL] clp$$char
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

*IF $true(osv$unix)
{ FUNCTION (osm$$char) $char (
{   ascii: list rest of any of
{       key
{         (nul, ^@)
{         (soh, ^a)
{         (stx, ^b)
{         (etx, ^c)
{         (eot, ^d)
{         (enq, ^e)
{         (ack, ^f)
{         (bel, ^g)
{         (bs,  ^h)
{         (ht,  ^i)
{         (lf,  ^j)
{         (vt,  ^k)
{         (ff,  ^l)
{         (cr,  ^m)
{         (so,  ^n)
{         (si,  ^o)
{         (dle, ^p)
{         (dc1, ^q)
{         (dc2, ^r)
{         (dc3, ^s)
{         (dc4, ^t)
{         (nak, ^u)
{         (syn, ^v)
{         (etb, ^w)
{         (can, ^x)
{         (em,  ^y)
{         (sub, ^z)
{         (esc, ^[)
{         (fs,  ^\)
{         (gs,  ^])
{         (rs,  ^^)
{         (us,  ^_)
{         sp
{         del
{       keyend
{       integer 0..255
{       string
{     anyend = $required
{   )

?? 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$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$union_type_qualifier_v2,
          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 .. 66] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          type_size_3: clt$type_specification_size,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
      recend,
    recend := [
    [2,
    [92, 7, 1, 8, 57, 26, 0],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$CHAR'], [
    ['ASCII                          ',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, 2729, clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[2, 0, clc$list_type], [2701, 1, clc$max_list_size, 0, FALSE, TRUE],
      [[2, 0, clc$union_type], [[clc$integer_type,
      clc$keyword_type, clc$string_type],
      FALSE, 3],
      2648, [[2, 0, clc$keyword_type], [66], [
        ['ACK                            ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
        ['BEL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
        ['BS                             ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
        ['CAN                            ', clc$nominal_entry,
  clc$normal_usage_entry, 25],
        ['CR                             ', clc$nominal_entry,
  clc$normal_usage_entry, 14],
        ['DC1                            ', clc$nominal_entry,
  clc$normal_usage_entry, 18],
        ['DC2                            ', clc$nominal_entry,
  clc$normal_usage_entry, 19],
        ['DC3                            ', clc$nominal_entry,
  clc$normal_usage_entry, 20],
        ['DC4                            ', clc$nominal_entry,
  clc$normal_usage_entry, 21],
        ['DEL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 34],
        ['DLE                            ', clc$nominal_entry,
  clc$normal_usage_entry, 17],
        ['EM                             ', clc$nominal_entry,
  clc$normal_usage_entry, 26],
        ['ENQ                            ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
        ['EOT                            ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['ESC                            ', clc$nominal_entry,
  clc$normal_usage_entry, 28],
        ['ETB                            ', clc$nominal_entry,
  clc$normal_usage_entry, 24],
        ['ETX                            ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['FF                             ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
        ['FS                             ', clc$nominal_entry,
  clc$normal_usage_entry, 29],
        ['GS                             ', clc$nominal_entry,
  clc$normal_usage_entry, 30],
        ['HT                             ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
        ['LF                             ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
        ['NAK                            ', clc$nominal_entry,
  clc$normal_usage_entry, 22],
        ['NUL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['RS                             ', clc$nominal_entry,
  clc$normal_usage_entry, 31],
        ['SI                             ', clc$nominal_entry,
  clc$normal_usage_entry, 16],
        ['SO                             ', clc$nominal_entry,
  clc$normal_usage_entry, 15],
        ['SOH                            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['SP                             ', clc$nominal_entry,
  clc$normal_usage_entry, 33],
        ['STX                            ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['SUB                            ', clc$nominal_entry,
  clc$normal_usage_entry, 27],
        ['SYN                            ', clc$nominal_entry,
  clc$normal_usage_entry, 23],
        ['US                             ', clc$nominal_entry,
  clc$normal_usage_entry, 32],
        ['VT                             ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
        ['^@                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['^A                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['^B                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['^C                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['^D                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['^E                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['^F                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
        ['^G                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
        ['^H                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
        ['^I                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
        ['^J                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 11],
        ['^K                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 12],
        ['^L                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 13],
        ['^M                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 14],
        ['^N                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 15],
        ['^O                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 16],
        ['^P                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 17],
        ['^Q                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 18],
        ['^R                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 19],
        ['^S                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 20],
        ['^T                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 21],
        ['^U                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 22],
        ['^V                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 23],
        ['^W                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 24],
        ['^X                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 25],
        ['^Y                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 26],
        ['^Z                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 27],
        ['^[                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 28],
        ['^\                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 29],
        ['^]                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 30],
        ['^^                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 31],
        ['^_                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 32]]
        ],
      13, [[2, 0, clc$integer_type], [0, 255, 10]],
      9, [[2, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
      ]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$ascii = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;
*ELSE
{ FUNCTION (osm$$char) $char (
{   ascii: list rest of any of
{       key
{         (nul, ^@)
{         (soh, ^a)
{         (stx, ^b)
{         (etx, ^c)
{         (eot, ^d)
{         (enq, ^e)
{         (ack, ^f)
{         (bel, ^g)
{         (bs,  ^h)
{         (ht,  ^i)
{         (lf,  ^j)
{         (vt,  ^k)
{         (ff,  ^l)
{         (cr,  ^m)
{         (so,  ^n)
{         (si,  ^o)
{         (dle, ^p)
{         (dc1, ^q)
{         (dc2, ^r)
{         (dc3, ^s)
{         (dc4, ^t)
{         (nak, ^u)
{         (syn, ^v)
{         (etb, ^w)
{         (can, ^x)
{         (em,  ^y)
{         (sub, ^z)
{         (esc, ^[)
{         (fs,  ^\)
{         (gs,  ^])
{         (rs,  ^^)
{         (us,  ^_)
{         sp
{         del
{       keyend
{       integer 0..255
{       string
{     anyend = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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$list_type_qualifier,
          element_type_spec: 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 .. 66] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
            type_size_3: clt$type_specification_size,
            element_type_spec_3: record
              header: clt$type_specification_header,
              qualifier: clt$string_type_qualifier,
            recend,
          recend,
        recend,
      recend := [[1, [87, 10, 25, 13, 30, 52, 579], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$CHAR'],
            [['ASCII                          ', 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, 2517, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$list_type], [2501, 1, clc$max_list_size, TRUE],
            [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type, clc$string_type], FALSE, 3], 2449,
            [[1, 0, clc$keyword_type], [66], [['ACK                            ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['BEL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 8], ['BS                             ', clc$nominal_entry,
            clc$normal_usage_entry, 9], ['CAN                            ', clc$nominal_entry,
            clc$normal_usage_entry, 25], ['CR                             ', clc$nominal_entry,
            clc$normal_usage_entry, 14], ['DC1                            ', clc$nominal_entry,
            clc$normal_usage_entry, 18], ['DC2                            ', clc$nominal_entry,
            clc$normal_usage_entry, 19], ['DC3                            ', clc$nominal_entry,
            clc$normal_usage_entry, 20], ['DC4                            ', clc$nominal_entry,
            clc$normal_usage_entry, 21], ['DEL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 34], ['DLE                            ', clc$nominal_entry,
            clc$normal_usage_entry, 17], ['EM                             ', clc$nominal_entry,
            clc$normal_usage_entry, 26], ['ENQ                            ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['EOT                            ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['ESC                            ', clc$nominal_entry,
            clc$normal_usage_entry, 28], ['ETB                            ', clc$nominal_entry,
            clc$normal_usage_entry, 24], ['ETX                            ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['FF                             ', clc$nominal_entry,
            clc$normal_usage_entry, 13], ['FS                             ', clc$nominal_entry,
            clc$normal_usage_entry, 29], ['GS                             ', clc$nominal_entry,
            clc$normal_usage_entry, 30], ['HT                             ', clc$nominal_entry,
            clc$normal_usage_entry, 10], ['LF                             ', clc$nominal_entry,
            clc$normal_usage_entry, 11], ['NAK                            ', clc$nominal_entry,
            clc$normal_usage_entry, 22], ['NUL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['RS                             ', clc$nominal_entry,
            clc$normal_usage_entry, 31], ['SI                             ', clc$nominal_entry,
            clc$normal_usage_entry, 16], ['SO                             ', clc$nominal_entry,
            clc$normal_usage_entry, 15], ['SOH                            ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SP                             ', clc$nominal_entry,
            clc$normal_usage_entry, 33], ['STX                            ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['SUB                            ', clc$nominal_entry,
            clc$normal_usage_entry, 27], ['SYN                            ', clc$nominal_entry,
            clc$normal_usage_entry, 23], ['US                             ', clc$nominal_entry,
            clc$normal_usage_entry, 32], ['VT                             ', clc$nominal_entry,
            clc$normal_usage_entry, 12], ['^@                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['^A                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['^B                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['^C                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['^D                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['^E                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['^F                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['^G                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 8], ['^H                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 9], ['^I                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 10], ['^J                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 11], ['^K                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 12], ['^L                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 13], ['^M                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 14], ['^N                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 15], ['^O                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 16], ['^P                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 17], ['^Q                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 18], ['^R                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 19], ['^S                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 20], ['^T                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 21], ['^U                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 22], ['^V                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 23], ['^W                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 24], ['^X                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 25], ['^Y                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 26], ['^Z                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 27], ['^[                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 28], ['^\                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 29], ['^]                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 30], ['^^                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 31], ['^_                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 32]]], 20, [[1, 0, clc$integer_type], [0, 255, 10]],
            8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]]]];

?? POP ??

    CONST
      p$ascii = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;
*IFEND

?? SKIP := 3 ??

    CONST
      max_mnemonics = 34,
      mnemonic_name_size = 3;

    VAR
      mnemonics_table: [STATIC, READ, oss$job_paged_literal] array [1 .. 34] of record
        name: string (mnemonic_name_size),
        character: char,
      recend := [['ACK', $CHAR (6)], ['BEL', $CHAR (7)], ['BS ', $CHAR (8)], ['CAN', $CHAR (24)],
            ['CR ', $CHAR (13)], ['DC1', $CHAR (17)], ['DC2', $CHAR (18)], ['DC3', $CHAR (19)],
            ['DC4', $CHAR (20)], ['DEL', $CHAR (127)], ['DLE', $CHAR (16)], ['EM ', $CHAR (25)],
            ['ENQ', $CHAR (5)], ['EOT', $CHAR (4)], ['ESC', $CHAR (27)],
            ['ETB', $CHAR (23)], ['ETX', $CHAR (3)], ['FF ', $CHAR (12)],
            ['FS ', $CHAR (28)], ['GS ', $CHAR (29)], ['HT ', $CHAR (9)], ['LF ', $CHAR (10)],
            ['NAK', $CHAR (21)], ['NUL', $CHAR (0)], ['RS ', $CHAR (30)],
            ['SI ', $CHAR (15)], ['SO ', $CHAR (14)], ['SOH', $CHAR (1)], ['SP ', $CHAR (32)],
            ['STX', $CHAR (2)], ['SUB', $CHAR (26)], ['SYN', $CHAR (22)],
            ['US ', $CHAR (31)], ['VT ', $CHAR (11)]];

?? NEWTITLE := 'lookup_mnemonic', EJECT ??

    FUNCTION [INLINE] lookup_mnemonic
      (    name: clt$keyword): char;

      VAR
        low_index: 1 .. max_mnemonics + 1,
        temp: integer,
        high_index: 0 .. max_mnemonics,
        current_index: 1 .. max_mnemonics + max_mnemonics;


      low_index := 1;
      high_index := max_mnemonics;
      REPEAT
        temp := low_index + high_index;
        current_index := temp DIV 2;
        IF name (1, mnemonic_name_size) = mnemonics_table [current_index].name THEN
          lookup_mnemonic := mnemonics_table [current_index].character;
          RETURN;
        ELSEIF name (1, mnemonic_name_size) > mnemonics_table [current_index].name THEN
          low_index := current_index + 1;
        ELSE
          high_index := current_index - 1;
        IFEND;
      UNTIL low_index > high_index;

{ Should never get here.

      lookup_mnemonic := $CHAR (0);

    FUNCEND lookup_mnemonic;
?? OLDTITLE, EJECT ??

    VAR
      new_result_size: clt$string_size,
      node: ^clt$data_value,
      result_size: clt$string_size;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /work_area_ok/
    BEGIN
      clp$make_value (clc$string, work_area, result);
      IF result = NIL THEN
        EXIT /work_area_ok/;
      IFEND;
      NEXT result^.string_value: [0] IN work_area;
      IF result = NIL THEN
        EXIT /work_area_ok/;
      IFEND;
      result_size := 0;
      node := pvt [p$ascii].value;

      WHILE node <> NIL DO
        IF node^.element_value^.kind = clc$string THEN
          new_result_size := result_size + STRLENGTH (node^.element_value^.string_value^);
        ELSE
          new_result_size := result_size + 1;
        IFEND;
        IF new_result_size > clc$max_string_size THEN
          osp$set_status_condition (cle$string_too_long, status);
          RETURN;
        IFEND;
        RESET work_area TO result^.string_value;
        NEXT result^.string_value: [new_result_size] IN work_area;
        IF result = NIL THEN
          EXIT /work_area_ok/;
        IFEND;

        CASE node^.element_value^.kind OF
        = clc$keyword =
          result^.string_value^ (new_result_size) := lookup_mnemonic (node^.element_value^.keyword_value);
        = clc$integer =
          result^.string_value^ (new_result_size) := $CHAR (node^.element_value^.integer_value.value);
        ELSE {clc$string}
          result^.string_value^ (result_size + 1, * ) := node^.element_value^.string_value^;
        CASEND;

        result_size := new_result_size;
        node := node^.link;
      WHILEND;
      RETURN;

    END /work_area_ok/;
    osp$set_status_condition (cle$work_area_overflow, status);

  PROCEND clp$$char;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$$clock', EJECT ??

  PROCEDURE [XDCL] clp$$clock
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

    clp$scan_argument_list (function_name, argument_list, NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    value.descriptor := clv$value_descriptors [clc$integer_value];
    value.kind := clc$integer_value;
    value.int.radix := 10;
    value.int.radix_specified := FALSE;
    pmp$get_microsecond_clock (value.int.value, status);

  PROCEND clp$$clock;
?? TITLE := 'clp$$condition_code', EJECT ??

  PROCEDURE [XDCL] clp$$condition_code
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      condition_code_adt: [STATIC, READ, cls$adt] array [1 .. 2] of clt$argument_descriptor := [
            {1} [[clc$required], [NIL, clc$name_value, 1, osc$max_name_size]],
            {2} [[clc$optional_with_default, ^default_format], [^formats, clc$keyword_value]]],
      formats: [STATIC, READ, cls$adt_names_and_defaults] array [1 .. 4] of ost$name := ['SYMBOLIC', 'S',
            'NUMERIC', 'N'],
      default_format: [STATIC, READ, cls$adt_names_and_defaults] string (7) := 'numeric';

    VAR
      condition_code: ost$status_condition_code,
      condition_code_string: ost$string,
      name: clt$name,
      avt: array [1 .. 2] of clt$value;

    clp$scan_argument_list (function_name, argument_list, ^condition_code_adt, ^avt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$get_status_condition_code (avt [1].name.value, condition_code, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (avt [2].name.value = 'SYMBOLIC') OR (avt [2].name.value = 'S') THEN
      osp$get_status_condition_string (condition_code, condition_code_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      value.descriptor := clv$value_descriptors [clc$string_value];
      value.kind := clc$string_value;
      value.str := condition_code_string;
    ELSE {avt[2].name.value = 'NUMERIC' OR 'N'
      value.descriptor := clv$value_descriptors [clc$integer_value];
      value.kind := clc$integer_value;
      value.int.radix := 10;
      value.int.radix_specified := FALSE;
      value.int.value := condition_code;
    IFEND;

  PROCEND clp$$condition_code;
?? TITLE := 'clp$$condition_name', EJECT ??

  PROCEDURE [XDCL] clp$$condition_name
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} :^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$condition_name) $condition_name $condition (
{   status_code : status_code = $required
{   identifier: string 2
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
    recend := [
    [1,
    [88, 12, 15, 11, 54, 25, 965],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$CONDITION_NAME'], [
    ['IDENTIFIER                     ',clc$nominal_entry, 2],
    ['STATUS_CODE                    ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [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, 8, clc$optional_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$status_code_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [2, 2, FALSE]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status_code = 1,
      p$identifier = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      condition_code: ost$status_condition_code,
      condition_name: ost$status_condition_name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$status_code].value^.status_code_value <= osc$max_status_condition_number THEN
      IF NOT pvt [p$identifier].specified THEN
        osp$set_status_abnormal ('CL', cle$required_argument_omitted, '$CONDITION_NAME', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'IDENTIFIER', status);
        RETURN;
      IFEND;
      condition_code := osp$status_condition_code (pvt [p$identifier].value^.string_value^(1, 2),
            pvt [p$status_code].value^.status_code_value);
    ELSE
      condition_code := pvt [p$status_code].value^.status_code_value;
    IFEND;

    osp$get_status_condition_name (condition_code, condition_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_string_value (condition_name(1,clp$trimmed_string_size(condition_name)), work_area, result);

    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$condition_name;
?? TITLE := 'clp$$data_name', EJECT ??

  PROCEDURE [XDCL] clp$$data_name
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$data_name) $data_name (
{   source: any of
{       string
{       name
{     anyend = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend := [[1, [88, 5, 14, 10, 26, 21, 547], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$DATA_NAME'],
            [['SOURCE                         ', 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, 33, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$name_type, clc$string_type], TRUE, 2], 8,
            [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]], 5,
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]];

?? POP ??

    CONST
      p$source = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      data_name: ^ost$name,
      name: clt$name;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$source].value^.kind = clc$string THEN
      clp$convert_string_to_name (pvt [p$source].value^.string_value^, name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      data_name := ^name.value;
    ELSE {name}
      data_name := ^pvt [p$source].value^.name_value;
    IFEND;

    clp$make_data_name_value (data_name^, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$data_name;
?? TITLE := 'clp$$default_family', EJECT ??

  PROCEDURE [XDCL] clp$$default_family
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      default_attribute_results_p: ^jmt$default_attribute_results,
      job_mode: jmt$job_mode;

    status.normal := TRUE;

    clp$scan_argument_list (function_name, argument_list, NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_job_mode (job_mode, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    PUSH default_attribute_results_p: [1 .. 1];
    default_attribute_results_p^ [1].key := jmc$login_family;
    jmp$get_attribute_defaults (job_mode, default_attribute_results_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    value.descriptor := clv$value_descriptors [clc$name_value];
    value.kind := clc$name_value;
    value.name.size := clp$trimmed_string_size (default_attribute_results_p^ [1].login_family);
    value.name.value := default_attribute_results_p^ [1].login_family (1, value.name.size);

  PROCEND clp$$default_family;
?? TITLE := 'clp$$element_type', EJECT ??

  PROCEDURE [XDCL] clp$$element_type
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{   FUNCTION (osm$$element_type) $element_type (
{     structured_variable: data_name = $required
{     )

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 1, 18, 8, 24, 10, 270], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$ELEMENT_TYPE'],
            [['STRUCTURED_VARIABLE            ', 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, 3, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$data_name_type]]];

?? POP ??

    CONST
      p$structured_variable = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      array_type_qualifier: ^clt$array_type_qualifier,
      element_type_specification: ^clt$type_specification,
      header: ^clt$type_specification_header,
      ignore_access_mode: clt$data_access_mode,
      ignore_class: clt$variable_class,
      ignore_evaluation_method: clt$expression_eval_method,
      ignore_value: ^clt$data_value,
      list_type_qualifier: ^clt$list_type_qualifier,
      name: ^clt$type_name_reference,
      range_type_qualifier: ^clt$range_type_qualifier,
      type_specification: ^clt$type_specification;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_variable (pvt [p$structured_variable].value^.data_name_value, work_area, ignore_class,
          ignore_access_mode, ignore_evaluation_method, type_specification, ignore_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET type_specification;

    NEXT header IN type_specification;
    IF header^.name_size > 0 THEN
      NEXT name: [header^.name_size] IN type_specification;
    IFEND;
    element_type_specification := NIL;
    CASE header^.kind OF

    = clc$array_type =
      NEXT array_type_qualifier IN type_specification;
      IF array_type_qualifier^.element_type_specification_size <> 0 THEN
        NEXT element_type_specification: [[REP array_type_qualifier^.element_type_specification_size OF
              cell]] IN type_specification;
      IFEND;

    = clc$list_type =
      NEXT list_type_qualifier IN type_specification;
      IF list_type_qualifier^.element_type_specification_size <> 0 THEN
        NEXT element_type_specification: [[REP list_type_qualifier^.element_type_specification_size OF
              cell]] IN type_specification;
      IFEND;

    = clc$range_type =
      NEXT range_type_qualifier IN type_specification;
      IF range_type_qualifier^.element_type_specification_size <> 0 THEN
        NEXT element_type_specification: [[REP range_type_qualifier^.element_type_specification_size OF
              cell]] IN type_specification;
      IFEND;

    ELSE
      element_type_specification := type_specification;

    CASEND;

    IF element_type_specification = NIL THEN
      element_type_specification := #SEQ (union_type);
    IFEND;

    clp$make_type_spec_value (element_type_specification, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$element_type;
?? TITLE := 'clp$$evaluate', EJECT ??

  PROCEDURE [XDCL] clp$$evaluate
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$evaluate) $evaluate (
{   expression: any of
{       string
{       application
{     anyend = $required
{   type: type = $optional
{   option: key
{       value, check
{     keyend = value
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$application_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (5),
      recend,
    recend := [
    [1,
    [90, 4, 6, 13, 2, 44, 817],
    clc$function, 3, 3, 1, 0, 0, 0, 0, 'OSM$$EVALUATE'], [
    ['EXPRESSION                     ',clc$nominal_entry, 1],
    ['OPTION                         ',clc$nominal_entry, 3],
    ['TYPE                           ',clc$nominal_entry, 2]],
    [
{ 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, 32, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, 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, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [2, 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, 81,
  clc$optional_default_parameter, 0, 5]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$application_type, clc$string_type],
    FALSE, 2],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
    4, [[1, 0, clc$application_type], [FALSE]]
    ],
{ PARAMETER 2
    [[1, 0, clc$type_specification_type]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [2], [
    ['CHECK                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['VALUE                          ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'value']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$expression = 1,
      p$type = 2,
      p$option = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      expression: ^clt$expression_text,
      type_specification: ^clt$type_specification;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$expression].value^.kind = clc$string THEN
      expression := pvt [p$expression].value^.string_value;
    ELSE {clc$application}
      expression := pvt [p$expression].value^.application_value;
    IFEND;

    IF pvt [p$type].specified THEN
      type_specification := pvt [p$type].value^.type_specification_value;
    ELSE
      clp$get_expected_type (work_area, type_specification, status);
      IF NOT status.normal THEN
        RETURN;
      ELSEIF type_specification = NIL THEN
        type_specification := #SEQ (union_type);
      IFEND;
    IFEND;

    clp$evaluate_expression (expression^, type_specification, work_area, result, status);

    IF pvt [p$option].value^.keyword_value = 'CHECK' THEN
      clp$make_status_value (status, work_area, result);
      status.normal := TRUE;
    IFEND;

  PROCEND clp$$evaluate;
?? TITLE := 'clp$$field', EJECT ??

  PROCEDURE [XDCL] clp$$field
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$field) $field (
{   record: any = $required
{   name: name = $optional
{   option: key
{       defined, initialized, specified, value
{     keyend = value
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (5),
      recend,
    recend := [
    [1,
    [89, 8, 22, 15, 58, 16, 241],
    clc$function, 3, 3, 1, 0, 0, 0, 0, 'OSM$$FIELD'], [
    ['NAME                           ',clc$nominal_entry, 2],
    ['OPTION                         ',clc$nominal_entry, 3],
    ['RECORD                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, 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, 12, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [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, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [2, 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, 155,
  clc$optional_default_parameter, 0, 5]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [-$clt$type_kinds [],
    FALSE, 0]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['DEFINED                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['INITIALIZED                    ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['SPECIFIED                      ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['VALUE                          ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ,
    'value']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$record = 1,
      p$name = 2,
      p$option = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      f: clt$field_number,
      node: ^^clt$data_value,
      option: (all_field_names, field_defined, field_initialized, field_specified, field_value);


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT pvt [p$name].specified THEN
      option := all_field_names;
      clp$make_list_value (work_area, result);
      node := ^result;

    ELSEIF pvt [p$option].value^.keyword_value = 'DEFINED' THEN
      option := field_defined;
      clp$make_boolean_value (FALSE, clc$true_false_boolean, work_area, result);
    ELSEIF pvt [p$option].value^.keyword_value = 'INITIALIZED' THEN
      option := field_initialized;
      clp$make_boolean_value (FALSE, clc$true_false_boolean, work_area, result);
    ELSEIF pvt [p$option].value^.keyword_value = 'SPECIFIED' THEN
      option := field_specified;
      clp$make_boolean_value (FALSE, clc$true_false_boolean, work_area, result);
    ELSE
      option := field_value;
      result := NIL;
    IFEND;

    IF pvt [p$record].value^.kind <> clc$record THEN
      IF option = field_value THEN
        osp$set_status_abnormal ('CL', cle$wrong_kind_of_param_value, 'RECORD', status);
        clp$append_status_value_type (osc$status_parameter_delimiter, pvt [p$record].value, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'RECORD', status);
      IFEND;
      RETURN;
    IFEND;

    FOR f := 1 TO UPPERBOUND (pvt [p$record].value^.field_values^) DO
      IF option = all_field_names THEN
        IF node^ = NIL THEN
          clp$make_list_value (work_area, node^);
        IFEND;
        clp$make_name_value (pvt [p$record].value^.field_values^ [f].name, work_area, node^^.element_value);
        node := ^node^^.link;

      ELSEIF pvt [p$record].value^.field_values^ [f].name = pvt [p$name].value^.name_value THEN
        CASE option OF
        = field_defined =
          result^.boolean_value.value := TRUE;
        = field_initialized =
          result^.boolean_value.value := pvt [p$record].value^.field_values^ [f].value <> NIL;
        = field_specified =
          result^.boolean_value.value := (pvt [p$record].value^.field_values^ [f].value <> NIL) AND
                (pvt [p$record].value^.field_values^ [f].value^.kind <> clc$unspecified);
        ELSE {field_value}
          IF pvt [p$record].value^.field_values^ [f].value <> NIL THEN
            result := pvt [p$record].value^.field_values^ [f].value;
          ELSE
            osp$set_status_abnormal ('CL', cle$undefined_field, pvt [p$name].value^.name_value, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, '$FIELD', status)
          IFEND;
        CASEND;
        RETURN;

      IFEND;
    FOREND;

    IF option = field_value THEN
      osp$set_status_abnormal ('CL', cle$unknown_field, pvt [p$name].value^.name_value, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, '$FIELD', status)
    IFEND;

  PROCEND clp$$field;
?? TITLE := 'clp$$field_list', EJECT ??

  PROCEDURE [XDCL] clp$$field_list
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$field_list) $field_list (
{   record: any = $required
{   options: list rest of key
{       (names, name, n)
{       (values, value, v)
{       (specified_fields_only, sfo)
{     keyend = names values
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend,
      type2: 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 .. 8] of clt$keyword_specification,
        recend,
        default_value: string (12),
      recend,
    recend := [
    [1,
    [90, 4, 3, 16, 41, 45, 778],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$FIELD_LIST'], [
    ['OPTIONS                        ',clc$nominal_entry, 2],
    ['RECORD                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 12, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [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, 319,
  clc$optional_default_parameter, 0, 12]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [-$clt$type_kinds [],
    FALSE, 0]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [303, 1, clc$max_list_size, 0, FALSE, TRUE],
      [[1, 0, clc$keyword_type], [8], [
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['NAME                           ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['NAMES                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['SFO                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['SPECIFIED_FIELDS_ONLY          ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['V                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['VALUE                          ', clc$alias_entry, clc$normal_usage_entry, 2],
      ['VALUES                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ]
    ,
    'names values']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$record = 1,
      p$options = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      f: clt$field_number,
      include_names: boolean,
      include_values: boolean,
      node: ^^clt$data_value,
      option_node: ^clt$data_value,
      specified_fields_only: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$record].value^.kind <> clc$record THEN
      osp$set_status_abnormal ('CL', cle$wrong_kind_of_param_value, 'RECORD', status);
      clp$append_status_value_type (osc$status_parameter_delimiter, pvt [p$record].value, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'RECORD', status);
      RETURN;
    IFEND;

    include_names := FALSE;
    include_values := FALSE;
    specified_fields_only := FALSE;
    option_node := pvt [p$options].value;
    WHILE option_node <> NIL DO
      IF option_node^.element_value^.keyword_value = 'NAMES' THEN
        include_names := TRUE;
      ELSEIF option_node^.element_value^.keyword_value = 'VALUES' THEN
        include_values := TRUE;
      ELSE {OMIT_UNSPECIFIED}
        specified_fields_only := TRUE;
      IFEND;
      option_node := option_node^.link;
    WHILEND;
    IF NOT include_names THEN
      IF include_values THEN
        specified_fields_only := TRUE;
      ELSE
        include_names := TRUE;
        include_values := TRUE;
      IFEND;
    IFEND;

    clp$make_list_value (work_area, result);
    node := ^result;

    FOR f := 1 TO UPPERBOUND (pvt [p$record].value^.field_values^) DO
      IF (NOT specified_fields_only) OR ((pvt [p$record].value^.field_values^ [f].value <> NIL) AND
            (pvt [p$record].value^.field_values^ [f].value^.kind <> clc$unspecified)) THEN
        IF node^ = NIL THEN
          clp$make_list_value (work_area, node^);
        IFEND;
        IF include_names THEN
          IF include_values THEN
            clp$make_record_value (2, work_area, node^^.element_value);
            node^^.element_value^.field_values^ [1].name := 'NAME';
            clp$make_name_value (pvt [p$record].value^.field_values^ [f].name, work_area,
                  node^^.element_value^.field_values^ [1].value);
            node^^.element_value^.field_values^ [2].name := 'VALUE';
            node^^.element_value^.field_values^ [2].value := pvt [p$record].value^.field_values^ [f].value;
          ELSE
            clp$make_name_value (pvt [p$record].value^.field_values^ [f].name, work_area,
                  node^^.element_value);
          IFEND;
        ELSE {include_values}
          node^^.element_value := pvt [p$record].value^.field_values^ [f].value;
        IFEND;
        node := ^node^^.link;
      IFEND;
    FOREND;

  PROCEND clp$$field_list;
?? TITLE := 'clp$$generic_type', EJECT ??

  PROCEDURE [XDCL] clp$$generic_type
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$generic_type) $generic_type (
{   data: any = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [87, 10, 25, 14, 13, 51, 743], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$GENERIC_TYPE'],
            [['DATA                           ', 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, 12, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [-$clt$type_kinds [], FALSE, 0]]];

?? POP ??

    CONST
      p$data = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      keyword: ost$name;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE pvt [p$data].value^.kind OF
    = clc$application =
      keyword := 'APPLICATION';
    = clc$array =
      keyword := 'ARRAY';
    = clc$boolean =
      keyword := 'BOOLEAN';
    = clc$cobol_name =
      keyword := 'COBOL_NAME';
    = clc$command_reference =
      keyword := 'COMMAND_REFERENCE';
    = clc$data_name =
      keyword := 'DATA_NAME';
    = clc$date_time =
      IF pvt [p$data].value^.date_time_value.date_specified AND
            pvt [p$data].value^.date_time_value.time_specified THEN
        keyword := 'DATE_TIME';
      ELSEIF pvt [p$data].value^.date_time_value.date_specified THEN
        keyword := 'DATE';
      ELSEIF pvt [p$data].value^.date_time_value.time_specified THEN
        keyword := 'TIME';
      IFEND;
    = clc$deferred =
      keyword := 'DEFERRED';
    = clc$entry_point_reference =
      keyword := 'ENTRY_POINT_REFERENCE';
    = clc$file =
      keyword := 'FILE';
    = clc$integer =
      keyword := 'INTEGER';
    = clc$keyword =
      keyword := 'KEY';
    = clc$list =
      keyword := 'LIST';
    = clc$lock =
      keyword := 'LOCK';
    = clc$name =
      keyword := 'NAME';
    = clc$network_title =
      keyword := 'NETWORK_TITLE';
    = clc$program_name =
      keyword := 'PROGRAM_NAME';
    = clc$range =
      keyword := 'RANGE';
    = clc$real =
      keyword := 'REAL';
    = clc$record =
      keyword := 'RECORD';
    = clc$scu_line_identifier =
      keyword := 'LINE_IDENTIFIER';
    = clc$statistic_code =
      keyword := 'STATISTIC_CODE';
    = clc$status =
      keyword := 'STATUS';
    = clc$status_code =
      keyword := 'STATUS_CODE';
    = clc$string =
      keyword := 'STRING';
    = clc$string_pattern =
      keyword := 'STRING_PATTERN';
    = clc$time_increment =
      keyword := 'TIME_INCREMENT';
    = clc$time_zone =
      keyword := 'TIME_ZONE';
    = clc$type_specification =
      keyword := 'TYPE';
    = clc$unspecified =
      keyword := 'UNSPECIFIED';
    ELSE
      keyword := '';
    CASEND;

    clp$make_keyword_value (keyword, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$generic_type;
*IFEND
?? TITLE := 'clp$$if', EJECT ??

  PROCEDURE [XDCL] clp$$if
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
{ FUNCTION (osm$$if) $if (
{   condition: boolean = $required
{   result_if_true: (DEFER) any = $required
{   result_if_false: (DEFER) any = $required
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend,
    recend := [
    [1,
    [90, 4, 5, 15, 43, 45, 166],
    clc$function, 3, 3, 3, 0, 0, 0, 0, 'OSM$$IF'], [
    ['CONDITION                      ',clc$nominal_entry, 1],
    ['RESULT_IF_FALSE                ',clc$nominal_entry, 3],
    ['RESULT_IF_TRUE                 ',clc$nominal_entry, 2]],
    [
{ 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, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_positionally],
    clc$pass_by_value, clc$deferred_evaluation, clc$standard_parameter_checking, 12, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_positionally],
    clc$pass_by_value, clc$deferred_evaluation, clc$standard_parameter_checking, 12, clc$required_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [-$clt$type_kinds [],
    FALSE, 0]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [-$clt$type_kinds [],
    FALSE, 0]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$condition = 1,
      p$result_if_true = 2,
      p$result_if_false = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;
*ELSE
{ FUNCTION (osm$$if) $if (
{   condition: boolean = $required
{   result_if_true: any = $required
{   result_if_false: any = $required
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier_v2,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier_v2,
      recend,
    recend := [
    [2,
    [91, 8, 17, 14, 10, 48, 0],
    clc$function, 3, 3, 3, 0, 0, 0, 0, 'OSM$$IF'], [
    ['CONDITION                      ',clc$nominal_entry, 1],
    ['RESULT_IF_FALSE                ',clc$nominal_entry, 3],
    ['RESULT_IF_TRUE                 ',clc$nominal_entry, 2]],
    [
{ 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, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, 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, 16, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [2, 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, 16, clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[2, 0, clc$boolean_type]],
{ PARAMETER 2
    [[2, 0, clc$union_type], [-$clt$type_kinds_v2 [],
    FALSE, 0]],
{ PARAMETER 3
    [[2, 0, clc$union_type], [-$clt$type_kinds_v2 [],
    FALSE, 0]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$condition = 1,
      p$result_if_true = 2,
      p$result_if_false = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;
*IFEND

    VAR
      expression_text: ^clt$expression_text,
      condition_is_true:  boolean,
      type_specification: ^clt$type_specification;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    IF pvt [p$condition].value^.kind = clc$deferred THEN
      expression_text := pvt [p$condition].value^.deferred_value;
      type_specification := pvt [p$condition].value^.deferred_type;
      clp$evaluate_expression (expression_text^, type_specification, work_area, result, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      condition_is_true := result^.boolean_value.value;
    ELSEIF pvt [p$condition].value^.kind = clc$boolean THEN
      condition_is_true := pvt [p$condition].value^.boolean_value.value;
    IFEND;
    IF condition_is_true THEN
      expression_text := pvt [p$result_if_true].value^.deferred_value;
      type_specification := pvt [p$result_if_true].value^.deferred_type;
    ELSE
      expression_text := pvt [p$result_if_false].value^.deferred_value;
      type_specification := pvt [p$result_if_false].value^.deferred_type;
    IFEND;

    clp$evaluate_expression (expression_text^, type_specification, work_area, result, status);
*ELSE
    IF pvt [p$condition].value^.boolean_value.value THEN
      result := pvt [p$result_if_true].value
    ELSE
      result := pvt [p$result_if_false].value
    IFEND;
*IFEND

  PROCEND clp$$if;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$$job_template_name', EJECT ??

  PROCEDURE [XDCL] clp$$job_template_name
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      job_template_name: ost$name;


    clp$scan_argument_list (function_name, argument_list, NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$get_job_template_name (job_template_name);

    value.descriptor := clv$value_descriptors [clc$string_value];
    value.kind := clc$string_value;
    value.str.size := clp$trimmed_string_size (job_template_name);
    value.str.value := job_template_name;

  PROCEND clp$$job_template_name;
?? TITLE := 'clp$$job_termination_status', EJECT ??

  PROCEDURE [XDCL] clp$$job_termination_status
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$jobts) $job_termination_status

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [88, 9, 23, 13, 43, 50, 326], clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$JOBTS']];

?? POP ??


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_status_value (status, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;

    IF jmv$job_termination_status <> NIL THEN
      result^.status_value^ := jmv$job_termination_status^;
    IFEND;

  PROCEND clp$$job_termination_status;
?? TITLE := 'clp$$justify', EJECT ??

  PROCEDURE [XDCL] clp$$justify
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$justify) $justify (
{   subject: string = $required
{   size: integer 0..clc$max_string_size = $required
{   align: key
{       (center, c)
{       (left, l)
{       (right, r)
{     keyend = $required
{   fill: string 1 = ' '
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 4] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 6] of clt$keyword_specification,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
          default_value: string (3),
        recend,
      recend := [[1, [87, 10, 27, 19, 15, 13, 285], clc$function, 4, 4, 3, 0, 0, 0, 0, 'OSM$$JUSTIFY'],
            [['ALIGN                          ', clc$nominal_entry, 3],
            ['FILL                           ', clc$nominal_entry, 4],
            ['SIZE                           ', clc$nominal_entry, 2],
            ['SUBJECT                        ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [4, 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, 8, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, 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, 20, clc$required_parameter, 0, 0],

{ PARAMETER 3

      [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, 229, clc$required_parameter, 0, 0],

{ PARAMETER 4

      [2, 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, 8, clc$optional_default_parameter, 0,
            3]],

{ PARAMETER 1

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],

{ PARAMETER 2

      [[1, 0, clc$integer_type], [0, clc$max_string_size, 10]],

{ PARAMETER 3

      [[1, 0, clc$keyword_type], [6], [['C                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['CENTER                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['L                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['LEFT                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['R                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['RIGHT                          ', clc$nominal_entry,
            clc$normal_usage_entry, 3]]],

{ PARAMETER 4

      [[1, 0, clc$string_type], [1, 1, FALSE], ''' ''']];

?? POP ??

    CONST
      p$subject = 1,
      p$size = 2,
      p$align = 3,
      p$fill = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      c: char,
      i: clt$string_index,
      result_size: clt$string_size,
      s: ^clt$string_value,
      subject_size: clt$string_size;



    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    result_size := pvt [p$size].value^.integer_value.value;
    clp$make_sized_string_value (result_size, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;

    c := pvt [p$fill].value^.string_value^ (1);
    s := pvt [p$subject].value^.string_value;
    subject_size := STRLENGTH (s^);

    IF pvt [p$align].value^.keyword_value = 'LEFT' THEN
      result^.string_value^ := s^;
      IF c <> ' ' THEN
        FOR i := 1 + subject_size TO result_size DO
          result^.string_value^ (i) := c;
        FOREND;
      IFEND;

    ELSEIF pvt [p$align].value^.keyword_value = 'RIGHT' THEN
      i := 1;
      WHILE i <= (result_size - subject_size) DO
        result^.string_value^ (i) := c;
        i := i + 1;
      WHILEND;
      result^.string_value^ (i, * ) := s^;

    ELSE {CENTER}
      i := 1;
      WHILE i <= ((result_size - subject_size) DIV 2) DO
        result^.string_value^ (i) := c;
        i := i + 1;
      WHILEND;
      result^.string_value^ (i, * ) := s^;
      IF c <> ' ' THEN
        FOR i := i + subject_size TO result_size DO
          result^.string_value^ (i) := c;
        FOREND;
      IFEND;
    IFEND;

  PROCEND clp$$justify;
?? TITLE := 'clp$$lower_bound', EJECT ??

  PROCEDURE [XDCL] clp$$lower_bound
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$lower_bound) $lower_bound, $lowerbound (
{   array: array = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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$array_type_qualifier,
        recend,
      recend := [[1, [87, 12, 7, 17, 11, 0, 400], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$LOWER_BOUND'],
            [['ARRAY                          ', 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, 24, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$array_type], [0, FALSE]]];

?? POP ??

    CONST
      p$array = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_integer_value (LOWERBOUND (pvt [p$array].value^.array_value^), 10, FALSE, work_area, result);

  PROCEND clp$$lower_bound;
?? TITLE := 'clp$$lower_value', EJECT ??

  PROCEDURE [XDCL] clp$$lower_value
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$lower_value) $lower_value (
{   numeric_type: type = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 1, 18, 11, 36, 40, 347], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$LOWER_VALUE'],
            [['NUMERIC_TYPE                   ', 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, 3, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$type_specification_type]]];

?? POP ??

    CONST
      p$numeric_type = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      ignore_type_name: ^clt$type_name_reference,
      integer_type_qualifier: ^clt$integer_type_qualifier,
      real_type_qualifier: ^clt$real_type_qualifier,
      type_specification_header: ^clt$type_specification_header;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET pvt [p$numeric_type].value^.type_specification_value;
    NEXT type_specification_header IN pvt [p$numeric_type].value^.type_specification_value;
    IF type_specification_header = NIL THEN
      osp$set_status_condition (cle$bad_data_value, status);
      RETURN;
    IFEND;
    NEXT ignore_type_name: [type_specification_header^.name_size] IN pvt [p$numeric_type].
          value^.type_specification_value;
    IF ignore_type_name = NIL THEN
      osp$set_status_condition (cle$bad_data_value, status);
      RETURN;
    IFEND;
    IF type_specification_header^.kind = clc$integer_type THEN
      NEXT integer_type_qualifier IN pvt [p$numeric_type].value^.type_specification_value;
      IF integer_type_qualifier = NIL THEN
        osp$set_status_condition (cle$bad_data_value, status);
        RETURN;
      IFEND;
      clp$make_integer_value (integer_type_qualifier^.min_integer_value, 10, FALSE, work_area, result);
    ELSEIF type_specification_header^.kind = clc$real_type THEN
      NEXT real_type_qualifier IN pvt [p$numeric_type].value^.type_specification_value;
      IF real_type_qualifier = NIL THEN
        osp$set_status_condition (cle$bad_data_value, status);
        RETURN;
      IFEND;
      clp$make_real_value (real_type_qualifier^.min_real_value.long_real, clc$max_real_number_digits,
            work_area, result);
    ELSE
      clp$make_real_value (clv$negative_infinity^, clc$max_real_number_digits, work_area, result);
    IFEND;

    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$lower_value;
?? TITLE := 'clp$$mainframe', EJECT ??

  PROCEDURE [XDCL] clp$$mainframe
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$mainframe) $mainframe (
{   option: key (active_processors, active_processor, ap) (clock c)
{     (identifier, id, i) (page_size ps) (total_processors total_processor tp)
{     (vector_capability vc) (vectors_degraded vd)
{     (vector_simulation vs)
{    keyend = $required)

?? 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$keyword_type_qualifier,
        keyword_specs: array [1 .. 19] of clt$keyword_specification,
      recend,
    recend := [
    [1,
    [89, 4, 6, 17, 9, 2, 471],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$MAINFRAME'], [
    ['OPTION                         ',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, 710,
  clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [19], [
    ['ACTIVE_PROCESSOR               ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['ACTIVE_PROCESSORS              ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['AP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['CLOCK                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['ID                             ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['IDENTIFIER                     ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['PAGE_SIZE                      ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['PS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['TOTAL_PROCESSOR                ', clc$alias_entry, clc$normal_usage_entry, 5],
    ['TOTAL_PROCESSORS               ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['TP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['VC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['VD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
    ['VECTORS_DEGRADED               ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['VECTOR_CAPABILITY              ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['VECTOR_SIMULATION              ', clc$nominal_entry, clc$normal_usage_entry, 8],
    ['VS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8]]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$option = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      mainframe_attribute: array [1 .. 1] of pmt$mainframe_attribute,
      keyword: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    keyword := pvt [p$option].value^.keyword_value;
    IF (keyword = 'ACTIVE_PROCESSORS') THEN
      mainframe_attribute [1].key := pmc$mak_active_processors;

    ELSEIF (keyword = 'CLOCK') THEN
      mainframe_attribute [1].key := pmc$mak_microsecond_clock;

    ELSEIF (keyword = 'IDENTIFIER') THEN
      mainframe_attribute [1].key := pmc$mak_mainframe_identifier;

    ELSEIF (keyword = 'PAGE_SIZE') THEN
      mainframe_attribute [1].key := pmc$mak_page_size;

    ELSEIF keyword = 'TOTAL_PROCESSORS' THEN
      mainframe_attribute [1].key := pmc$mak_total_processors;

    ELSEIF keyword = 'VECTOR_CAPABILITY' THEN
      mainframe_attribute [1].key := pmc$mak_vector_capability;

    ELSEIF keyword = 'VECTORS_DEGRADED' THEN
      mainframe_attribute [1].key := pmc$mak_vectors_degraded;

    ELSEIF keyword = 'VECTOR_SIMULATION' THEN
      mainframe_attribute [1].key := pmc$mak_vector_simulation;
    IFEND;

    pmp$get_mainframe_attributes (mainframe_attribute, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE mainframe_attribute [1].key OF
    = pmc$mak_active_processors =
      clp$make_integer_value (mainframe_attribute [1].active_processors, { Radix = } 10,
            { Radix_specified = } FALSE, work_area, result);

    = pmc$mak_mainframe_identifier =
      clp$make_string_value (mainframe_attribute [1].mainframe_identifier,
            work_area, result);

    = pmc$mak_microsecond_clock =
      clp$make_integer_value (mainframe_attribute [1].microsecond_clock, { Radix = } 10,
            { Radix_specified = } FALSE, work_area, result);

    = pmc$mak_page_size =
      clp$make_integer_value (mainframe_attribute [1].page_size, { Radix = } 10, { Radix_specified = } FALSE,
            work_area, result);

    = pmc$mak_total_processors =
      clp$make_integer_value (mainframe_attribute [1].total_processors, { Radix = } 10,
            { Radix_specified = } FALSE, work_area, result);

    = pmc$mak_vector_capability =
      CASE mainframe_attribute [1].vector_capability OF
      = pmc$extended_vectors =
        clp$make_name_value ('EXTENDED_VECTORS', work_area, result);
      = pmc$standard_vectors =
        clp$make_name_value ('STANDARD_VECTORS', work_area, result);
      = pmc$no_vectors =
        clp$make_name_value ('NO_VECTORS', work_area, result);
      ELSE
        clp$make_name_value ('UNKNOWN', work_area, result);
      CASEND;

    = pmc$mak_vectors_degraded =
      clp$make_boolean_value (mainframe_attribute [1].vectors_degraded, clc$yes_no_boolean, work_area,
            result);

    = pmc$mak_vector_simulation =
      CASE mainframe_attribute [1].vector_simulation OF
      = pmc$vectors_simulated =
        clp$make_name_value ('VECTORS_SIMULATED', work_area, result);
      = pmc$vectors_suspended =
        clp$make_name_value ('VECTORS_SUSPENDED', work_area, result);
      = pmc$vectors_aborted =
        clp$make_name_value ('VECTORS_ABORTED', work_area, result);
      ELSE
        clp$make_name_value ('UNKNOWN', work_area, result);
      CASEND;
    CASEND;

  PROCEND clp$$mainframe;
?? TITLE := 'clp$$max_headroom', EJECT ??

  PROCEDURE [XDCL] clp$$max_headroom
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);


{ FUNCTION (osm$$max_headroom) $max_headroom

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [87, 11, 4, 13, 18, 12, 835], clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$MAX_HEADROOM']];

?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_string_value ('M-M-M-M-Max here!', work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$max_headroom;
?? TITLE := 'clp$$max_list', EJECT ??

  PROCEDURE [XDCL] clp$$max_list
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$max_list) $max_list

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [87, 10, 24, 16, 58, 19, 648], clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$MAX_LIST']];

?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_integer_value (clc$max_list_size, 10, FALSE, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$max_list;
?? TITLE := 'clp$$max_name', EJECT ??

  PROCEDURE [XDCL] clp$$max_name
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$max_name) $max_name

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [87, 10, 24, 16, 59, 17, 240], clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$MAX_NAME']];

?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_integer_value (osc$max_name_size, 10, FALSE, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$max_name;
?? TITLE := 'clp$$max_string', EJECT ??

  PROCEDURE [XDCL] clp$$max_string
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$max_string) $max_string

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [87, 10, 24, 17, 0, 5, 308], clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$MAX_STRING']];

?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_integer_value (clc$max_string_size, 10, FALSE, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$max_string;
?? TITLE := 'clp$$max_string_size', EJECT ??

  PROCEDURE [XDCL] clp$$max_string_size
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$max_string_size) $max_string_size (
{   string_type: type = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 1, 18, 8, 30, 0, 338], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$MAX_STRING_SIZE'],
            [['STRING_TYPE                    ', 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, 3, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$type_specification_type]]];

?? POP ??

    CONST
      p$string_type = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      ignore_type_name: ^clt$type_name_reference,
      max_string_size: integer,
      string_type_qualifier: ^clt$string_type_qualifier,
      type_specification_header: ^clt$type_specification_header;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET pvt [p$string_type].value^.type_specification_value;
    NEXT type_specification_header IN pvt [p$string_type].value^.type_specification_value;
    IF type_specification_header = NIL THEN
      osp$set_status_condition (cle$bad_data_value, status);
      RETURN;
    IFEND;
    NEXT ignore_type_name: [type_specification_header^.name_size] IN pvt [p$string_type].
          value^.type_specification_value;
    IF ignore_type_name = NIL THEN
      osp$set_status_condition (cle$bad_data_value, status);
      RETURN;
    IFEND;
    IF type_specification_header^.kind = clc$string_type THEN
      NEXT string_type_qualifier IN pvt [p$string_type].value^.type_specification_value;
      IF string_type_qualifier = NIL THEN
        osp$set_status_condition (cle$bad_data_value, status);
        RETURN;
      IFEND;
      max_string_size := string_type_qualifier^.max_string_size;
    ELSE
      max_string_size := clc$max_string_size;
    IFEND;

    clp$make_integer_value (max_string_size, 10, FALSE, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$max_string_size;
?? TITLE := 'clp$$message_level', EJECT ??

  PROCEDURE [XDCL] clp$$message_level
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      message_level_adt: [STATIC, READ, cls$adt] array [1 .. 1] of clt$argument_descriptor := [
            {1} [[clc$required], [^message_level_attb_names, clc$keyword_value]]],
      message_level_attb_names: [STATIC, READ, cls$adt_names_and_defaults] array [1 .. 4] of
            ost$name := ['BRIEF', 'B', 'FULL', 'F'];

    VAR
      message_level: ^ost$status_message_level,
      avt: array [1 .. 1] of clt$value;

    clp$scan_argument_list (function_name, argument_list, ^message_level_adt, ^avt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$find_status_message_level (message_level);

    value.descriptor := clv$value_descriptors [clc$boolean_value];
    value.kind := clc$boolean_value;
    value.bool.kind := clc$true_false_boolean;

    value.bool.value := ((avt [1].name.value (1) = 'B') AND (message_level^ = osc$brief_message_level)) OR
          ((avt [1].name.value (1) = 'F') AND (message_level^ = osc$full_message_level));

  PROCEND clp$$message_level;
?? TITLE := 'clp$$min_string_size', EJECT ??

  PROCEDURE [XDCL] clp$$min_string_size
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$min_string_size) $min_string_size (
{   string_type: type = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 1, 18, 8, 32, 25, 372], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$MIN_STRING_SIZE'],
            [['STRING_TYPE                    ', 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, 3, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$type_specification_type]]];

?? POP ??

    CONST
      p$string_type = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      ignore_type_name: ^clt$type_name_reference,
      min_string_size: integer,
      string_type_qualifier: ^clt$string_type_qualifier,
      type_specification_header: ^clt$type_specification_header;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET pvt [p$string_type].value^.type_specification_value;
    NEXT type_specification_header IN pvt [p$string_type].value^.type_specification_value;
    IF type_specification_header = NIL THEN
      osp$set_status_condition (cle$bad_data_value, status);
      RETURN;
    IFEND;
    NEXT ignore_type_name: [type_specification_header^.name_size] IN pvt [p$string_type].
          value^.type_specification_value;
    IF ignore_type_name = NIL THEN
      osp$set_status_condition (cle$bad_data_value, status);
      RETURN;
    IFEND;
    IF type_specification_header^.kind = clc$string_type THEN
      NEXT string_type_qualifier IN pvt [p$string_type].value^.type_specification_value;
      IF string_type_qualifier = NIL THEN
        osp$set_status_condition (cle$bad_data_value, status);
        RETURN;
      IFEND;
      min_string_size := string_type_qualifier^.min_string_size;
    ELSE
      min_string_size := 0;
    IFEND;

    clp$make_integer_value (min_string_size, 10, FALSE, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$min_string_size;
*IFEND
?? TITLE := 'clp$$name', EJECT ??

  PROCEDURE [XDCL] clp$$name
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
{ FUNCTION (osm$$name) $name (
{   source: any of
{       string
{       program_name
{     anyend = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend := [[1, [88, 5, 14, 10, 10, 9, 627], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$NAME'],
            [['SOURCE                         ', 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, 31, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$program_name_type, clc$string_type], FALSE, 2], 8,
            [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]], 3, [[1, 0, clc$program_name_type]]]];

?? POP ??

    CONST
      p$source = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;
*ELSE
{ FUNCTION (osm$$name) $name (
{   source: any of
{       string
{       program_name
{     anyend = $required
{   )

?? 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_v2,
        type_size_1: clt$type_specification_size,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
    recend := [
    [2,
    [91, 8, 27, 7, 56, 15, 0],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$NAME'], [
    ['SOURCE                         ',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, 39, clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[2, 0, clc$union_type], [[clc$program_name_type,
    clc$string_type],
    FALSE, 2],
    9, [[2, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
    3, [[2, 0, clc$program_name_type]]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$source = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;
*IFEND

    VAR
      name: clt$name,
      source: ^clt$string_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$source].value^.kind = clc$string THEN
      source := pvt [p$source].value^.string_value;
    ELSE {program_name}
      source := ^pvt [p$source].value^.program_name_value;
    IFEND;

    clp$convert_string_to_name (source^, name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_name_value (name.value, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$name;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$$unspecified_value', EJECT ??

  PROCEDURE [XDCL] clp$$unspecified_value
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $unspecified_value (
{   value: any = $optional
{   )

?? 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,
      recend,
    recend := [
    [1,
    [94, 10, 12, 0, 8, 26, 721],
    clc$function, 1, 1, 0, 0, 0, 0, 0, ''], [
    ['VALUE                          ',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, 12, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [-$clt$type_kinds [],
    FALSE, 0]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$value = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$value].specified THEN
      IF (pvt [p$value].value <> NIL) OR (pvt [p$value].value^.kind <> clc$unspecified) THEN
        clp$make_boolean_value(FALSE, clc$true_false_boolean, work_area, result);
        RETURN;
      IFEND;
    IFEND;

    clp$make_boolean_value(TRUE, clc$true_false_boolean, work_area, result);

  PROCEND clp$$unspecified_value;
?? TITLE := 'clp$$keyword', EJECT ??

  PROCEDURE [XDCL] clp$$keyword
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$keyword) $keyword (
{   source: any of
{       string
{       name
{     anyend = $required
{   )

?? 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
    recend := [
    [1,
    [94, 8, 18, 4, 51, 51, 827],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$KEYWORD'], [
    ['SOURCE                         ',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, 33, clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$source = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      keyword: clt$name,
      source: ^clt$string_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$source].value^.kind = clc$string THEN
      source := pvt [p$source].value^.string_value;
    ELSE {name}
      source := ^pvt [p$source].value^.name_value;
    IFEND;

    clp$convert_string_to_name (source^, keyword, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_keyword_value (keyword.value, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$keyword;
?? TITLE := 'clp$$application', EJECT ??

  PROCEDURE [XDCL] clp$$application
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$application) $application (
{   source: string = $required
{   )

?? 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$string_type_qualifier,
      recend,
    recend := [
    [1,
    [94, 8, 18, 4, 52, 47, 294],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$APPLICATION'], [
    ['SOURCE                         ',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, 8, clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$source = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_application_value (pvt [p$source].value^.string_value^, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$application;
?? TITLE := 'nap$$namve_active', EJECT ??

  PROCEDURE [XDCL] nap$$namve_active
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);


    clp$scan_argument_list (function_name, argument_list, NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    value.descriptor := clv$value_descriptors [clc$boolean_value];
    value.kind := clc$boolean_value;
    value.bool.kind := clc$true_false_boolean;
    value.bool.value := nap$namve_active ();

  PROCEND nap$$namve_active;
?? TITLE := 'nap$$namve_config_activated', EJECT ??

  PROCEDURE [XDCL] nap$$namve_config_activated
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);


    clp$scan_argument_list (function_name, argument_list, NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    value.descriptor := clv$value_descriptors [clc$boolean_value];
    value.kind := clc$boolean_value;
    value.bool.kind := clc$true_false_boolean;
    value.bool.value := nap$namve_config_activated ();

  PROCEND nap$$namve_config_activated;
?? TITLE := 'clp$$natural_language', EJECT ??

  PROCEDURE [XDCL] clp$$natural_language
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      natural_language: ^ost$natural_language;

    clp$scan_argument_list (function_name, argument_list, NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$find_natural_language (natural_language);

    value.descriptor := clv$value_descriptors [clc$name_value];
    value.kind := clc$name_value;
    value.name.size := clp$trimmed_string_size (natural_language^);
    value.name.value := natural_language^;

  PROCEND clp$$natural_language;
?? TITLE := 'clp$$not', EJECT ??

  PROCEDURE [XDCL] clp$$not
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{  FUNCTION (osm$$not) $not (
{    value: boolean = $required
{    )

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 3, 17, 11, 41, 4, 899], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$NOT'],
            [['VALUE                          ', 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, 3, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$boolean_type]]];

?? POP ??

    CONST
      p$value = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_boolean_value (NOT (pvt [p$value].value^.boolean_value.value), clc$true_false_boolean, work_area,
          result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$not;
?? TITLE := 'clp$$now', EJECT ??

  PROCEDURE [XDCL] clp$$now
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$now) $now

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [87, 10, 31, 15, 34, 45, 494], clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$NOW']];

?? POP ??

    VAR
      date_time: clt$date_time,
      date_time_value: ost$date_time;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$get_compact_date_time (date_time_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    date_time.value := date_time_value;
    date_time.date_specified := TRUE;
    date_time.time_specified := TRUE;
    clp$make_date_time_value (date_time, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$now;
*IFEND
?? TITLE := 'clp$$ord', EJECT ??

  PROCEDURE [XDCL] clp$$ord
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      ord_adt: [STATIC, READ, cls$adt] array [1 .. 1] of clt$argument_descriptor := [
            {1} [[clc$required], [NIL, clc$string_value, 1, 1]]];

    VAR
      avt: array [1 .. 1] of clt$value;

    clp$scan_argument_list (function_name, argument_list, ^ord_adt, ^avt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    value.descriptor := clv$value_descriptors [clc$integer_value];
    value.kind := clc$integer_value;
    value.int.radix := 10;
    value.int.radix_specified := FALSE;
    value.int.value := $INTEGER (avt [1].str.value (1));

  PROCEND clp$$ord;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$$previous_status', EJECT ??

  PROCEDURE [XDCL] clp$$previous_status
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      block: ^clt$block;

    clp$scan_argument_list (function_name, argument_list, NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$find_input_block (FALSE, block);
    IF block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, '$PREVIOUS_STATUS', status);
      RETURN;
    IFEND;
    IF ((block^.kind = clc$command_proc_block) OR (block^.kind = clc$function_proc_block)) AND
          (NOT block^.parameters.evaluated) THEN
      REPEAT
        block := block^.previous_block;
      UNTIL block^.kind IN $clt$block_kinds [clc$command_proc_block, clc$function_proc_block, clc$input_block,
            clc$when_block];
    IFEND;
    value.descriptor := clv$value_descriptors [clc$status_value];
    value.kind := clc$status_value;
    value.status := block^.previous_command_status;

  PROCEND clp$$previous_status;
?? TITLE := 'clp$$processor', EJECT ??

  PROCEDURE [XDCL] clp$$processor
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);


{ FUNCTION (osm$$processor) $processor (
{   option: key
{       (clock, c)
{       (model_number, mn)
{       (model_type, model, m, mt)
{       (serial_number, serial, sn)
{       (state, s)
{     hidden_key
{       (binary_model_number, bmn)
{     keyend = $required
{   processor_number: integer 0..1 = $optional
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 15] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
    recend := [
    [1,
    [90, 11, 15, 19, 33, 30, 631],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$PROCESSOR'], [
    ['OPTION                         ',clc$nominal_entry, 1],
    ['PROCESSOR_NUMBER               ',clc$nominal_entry, 2]],
    [
{ 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, 562, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, 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, 20, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [15], [
    ['BINARY_MODEL_NUMBER            ', clc$nominal_entry, clc$hidden_entry, 6
  ],
    ['BMN                            ', clc$abbreviation_entry,
  clc$hidden_entry, 6],
    ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['CLOCK                          ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['M                              ', clc$alias_entry,
  clc$normal_usage_entry, 3],
    ['MN                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['MODEL                          ', clc$alias_entry,
  clc$normal_usage_entry, 3],
    ['MODEL_NUMBER                   ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['MODEL_TYPE                     ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['MT                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
    ['SERIAL                         ', clc$alias_entry,
  clc$normal_usage_entry, 4],
    ['SERIAL_NUMBER                  ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['SN                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
    ['STATE                          ', clc$nominal_entry,
  clc$normal_usage_entry, 5]]
    ],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, 1, 10]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$option = 1,
      p$processor_number = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      cpu_attributes: pmt$cpu_attributes,
      mainframe_id: pmt$binary_mainframe_id,
      microsecond_clock: integer,
      model_type: pmt$processor_model_type,
      model_number: pmt$processor_model_number,
      serial_number: pmt$processor_serial_number,
      state: pmt$processor_state;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT pvt [p$processor_number].specified THEN
      pmp$get_processor_id (model_type, model_number, serial_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      state := pmc$processor_state_on;

    ELSE
      pmp$get_cpu_attributes (cpu_attributes, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      model_type := cpu_attributes.cpu [pvt [p$processor_number].value^.integer_value.value].model_type;
      model_number := cpu_attributes.cpu [pvt [p$processor_number].value^.integer_value.value].model_number;
      serial_number := cpu_attributes.cpu [pvt [p$processor_number].value^.integer_value.value].serial_number;
      state := cpu_attributes.cpu [pvt [p$processor_number].value^.integer_value.value].state;
    IFEND;

    IF pvt [p$option].value^.keyword_value = 'BINARY_MODEL_NUMBER' THEN
      pmp$get_binary_mainframe_id (mainframe_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$make_integer_value (mainframe_id.model_number, { Radix = } 16, { Radix_specified = } TRUE,
            work_area, result);

    ELSEIF pvt [p$option].value^.keyword_value = 'CLOCK' THEN
      pmp$get_microsecond_clock (microsecond_clock, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$make_integer_value (microsecond_clock, { Radix = } 10, { Radix_specified = } FALSE, work_area,
            result);

    ELSEIF (pvt [p$option].value^.keyword_value = 'MODEL_NUMBER') THEN
      clp$make_string_value (model_number (1, clp$trimmed_string_size (model_number)), work_area, result);

    ELSEIF (pvt [p$option].value^.keyword_value = 'MODEL_TYPE') THEN
      clp$make_string_value (model_type (1, clp$trimmed_string_size (model_type)), work_area, result);

    ELSEIF (pvt [p$option].value^.keyword_value = 'SERIAL_NUMBER') THEN
      clp$make_string_value (serial_number (1, clp$trimmed_string_size (serial_number)), work_area, result);

    ELSEIF (pvt [p$option].value^.keyword_value = 'STATE') THEN
      clp$make_string_value (state (1, clp$trimmed_string_size (state)), work_area, result);

    IFEND;

  PROCEND clp$$processor;
?? TITLE := 'clp$$program_name', EJECT ??

  PROCEDURE [XDCL] clp$$program_name
    (    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_name) $program_name (
{   source: program_name = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 5, 14, 10, 18, 40, 387], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$PROGRAM_NAME'],
            [['SOURCE                         ', 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, 3, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$program_name_type]]];

?? POP ??

    CONST
      p$source = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      program_name: clt$name,
      source: ^clt$string_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    source := ^pvt [p$source].value^.program_name_value;

    clp$convert_string_to_name (source^, program_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_program_name_value (program_name.value, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$program_name;
?? TITLE := 'clp$$queue', EJECT ??

  PROCEDURE [XDCL] clp$$queue
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$queue) $queue (
{   queue_name: name = $required
{   option: key connect_count, message_count, wait_count keyend = $required
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 3] of clt$keyword_specification,
        recend,
      recend := [[1, [88, 9, 29, 17, 19, 36, 180], clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$QUEUE'],
            [['OPTION                         ', clc$nominal_entry, 2],
            ['QUEUE_NAME                     ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [2, 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, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [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, 118, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [3], [['CONNECT_COUNT                  ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['MESSAGE_COUNT                  ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['WAIT_COUNT                     ', clc$nominal_entry,
            clc$normal_usage_entry, 3]]]];

?? POP ??

    CONST
      p$queue_name = 1,
      p$option = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      counts: pmt$queue_status,
      ignore_status: ost$status,
      queue_id: pmt$queue_connection;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$connect_queue (pvt [p$queue_name].value^.name_value, queue_id, status);
    IF NOT status.normal AND (status.condition = pme$unknown_queue_name) THEN
      pmp$define_queue (pvt [p$queue_name].value^.name_value, osc$user_ring_2, osc$user_ring_2, status);
      IF status.normal OR (status.condition = pme$queue_already_defined) THEN
        pmp$connect_queue (pvt [p$queue_name].value^.name_value, queue_id, status);
      IFEND;
    IFEND;
    IF status.normal THEN
      pmp$status_queue (queue_id, counts, status);
      pmp$disconnect_queue (queue_id, ignore_status);
    ELSEIF status.condition = pme$task_already_connected THEN
      pmp$status_queue (queue_id, counts, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_integer_value (0, 10, FALSE, work_area, result);
    IF pvt [p$option].value^.keyword_value = 'CONNECT_COUNT' THEN
      result^.integer_value.value := counts.connections;
    ELSEIF pvt [p$option].value^.keyword_value = 'MESSAGE_COUNT' THEN
      result^.integer_value.value := counts.messages;
    ELSEIF pvt [p$option].value^.keyword_value = 'WAIT_COUNT' THEN
      result^.integer_value.value := counts.waiting_tasks;
    IFEND;

  PROCEND clp$$queue;
?? TITLE := 'clp$$quote', EJECT ??

  PROCEDURE [XDCL] clp$$quote
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$quote) $quote (
{   string: string = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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$string_type_qualifier,
        recend,
      recend := [[1, [87, 10, 26, 13, 36, 4, 112], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$QUOTE'],
            [['STRING                         ', 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, 8, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]];

?? POP ??

    CONST
      p$string = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      found: boolean,
      i: clt$string_index,
      j: clt$string_index,
      result_size: integer,
      s: ^clt$string_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    s := pvt [p$string].value^.string_value;
    result_size := STRLENGTH (s^) + 2;

  /adjust_for_embedded_quotes/
    WHILE TRUE DO
      #SCAN (clv$string_delimiter, s^, i, found);
      IF NOT found THEN
        EXIT /adjust_for_embedded_quotes/;
      IFEND;
      result_size := result_size + 1;
      s := ^s^ (i + 1, * );
    WHILEND /adjust_for_embedded_quotes/;

    IF result_size > clc$max_string_size THEN
      osp$set_status_condition (cle$string_too_long, status);
      RETURN;
    IFEND;

    clp$make_sized_string_value (result_size, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;

    s := pvt [p$string].value^.string_value;
    result^.string_value^ (1) := '''';
    j := 2;
    WHILE TRUE DO
      #SCAN (clv$string_delimiter, s^, i, found);
      result^.string_value^ (j, i - 1) := s^ (1, i - 1);
      j := j + i - 1;
      result^.string_value^ (j) := '''';
      IF NOT found THEN
        RETURN;
      IFEND;
      result^.string_value^ (j + 1) := '''';
      j := j + 2;
      s := ^s^ (i + 1, * );
    WHILEND;

  PROCEND clp$$quote;
?? TITLE := 'clp$$range_of', EJECT ??

  PROCEDURE [XDCL] clp$$range_of
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$range_of) $range_of (
{   low: any = $required
{   high: any = $optional
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$union_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$union_type_qualifier,
        recend,
      recend := [[1, [88, 4, 30, 17, 6, 28, 68], clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$RANGE_OF'],
            [['HIGH                           ', clc$nominal_entry, 2],
            ['LOW                            ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [2, 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, 12, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [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, 12, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [-$clt$type_kinds [], FALSE, 0]],

{ PARAMETER 2

      [[1, 0, clc$union_type], [-$clt$type_kinds [], FALSE, 0]]];

?? POP ??

    CONST
      p$low = 1,
      p$high = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_range_value (work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;

    result^.low_value := pvt [p$low].value;
    IF pvt [p$high].specified THEN
      result^.high_value := pvt [p$high].value;
    ELSE
      result^.high_value := pvt [p$low].value;
    IFEND;

  PROCEND clp$$range_of;
?? TITLE := 'clp$$range_specified', EJECT ??

  PROCEDURE [XDCL] clp$$range_specified
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$range_specified) $range_specified (
{   range: range = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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$range_type_qualifier,
        recend,
      recend := [[1, [87, 10, 25, 16, 23, 12, 62], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$RANGE_SPECIFIED'],
            [['RANGE                          ', 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, 7, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$range_type], [0]]];

?? POP ??

    CONST
      p$range = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      range_specified: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    range_specified := (pvt [p$range].value^.kind = clc$range) AND
          (pvt [p$range].value^.high_value <> pvt [p$range].value^.low_value);
    clp$make_boolean_value (range_specified, clc$true_false_boolean, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$range_specified;
?? TITLE := 'clp$$record', EJECT ??

  PROCEDURE [XDCL] clp$$record
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$record) $record (
{   fields: list rest of record
{       name: name
{       value: any = $optional
{     recend = $required
{   )

?? 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$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$union_type_qualifier,
          recend,
        recend,
      recend,
    recend := [
    [1,
    [90, 1, 18, 13, 5, 51, 362],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$RECORD'], [
    ['FIELDS                         ',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, 112,
  clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [96, 1, clc$max_list_size, TRUE],
      [[1, 0, clc$record_type], [2],
      ['NAME                           ', clc$required_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['VALUE                          ', clc$optional_field, 12], [[1, 0, clc$union_type], [
  -$clt$type_kinds [],
        FALSE, 0]]
      ]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$fields = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      i: 1 .. clc$max_list_size,
      j: 1 .. clc$max_list_size,
      node: ^clt$data_value,
      number_of_fields: clt$list_size;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    number_of_fields := clp$count_list_elements (pvt [p$fields].value);
    node := pvt [p$fields].value;
    clp$make_record_value (number_of_fields, work_area, result);

    FOR i := 1 TO number_of_fields DO
      result^.field_values^ [i].name := node^.element_value^.field_values^ [1].value^.name_value;
      FOR j := 1 TO i - 1 DO
        IF result^.field_values^ [j].name = result^.field_values^ [i].name THEN
          osp$set_status_abnormal ('CL', cle$duplicate_field_name, result^.field_values^ [i].name, status);
          RESET work_area TO result;
          result := NIL;
          RETURN;
        IFEND;
      FOREND;
      result^.field_values^ [i].value := node^.element_value^.field_values^ [2].value;
      node := node^.link;
    FOREND;

  PROCEND clp$$record;
?? TITLE := 'clp$$scan_any', EJECT ??

  PROCEDURE [XDCL] clp$$scan_any
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$scan_any) $scan_any (
{   characters: string 1..256 = $required
{   string: string = $required
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend := [[1, [87, 10, 28, 9, 6, 6, 582], clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$SCAN_ANY'],
            [['CHARACTERS                     ', clc$nominal_entry, 1],
            ['STRING                         ', clc$nominal_entry, 2]], [

{ 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, 8, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [2, 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, 8, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$string_type], [1, 256, FALSE]],

{ PARAMETER 2

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]];

?? POP ??

    CONST
      p$characters = 1,
      p$string = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    TYPE
      char_set = set of char;

    VAR
      chars: char_set,
      found: boolean,
      i: integer;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    chars := $char_set [];
    FOR i := 1 TO STRLENGTH (pvt [p$characters].value^.string_value^) DO
      chars := chars + $char_set [pvt [p$characters].value^.string_value^ (i)];
    FOREND;

    #SCAN (chars, pvt [p$string].value^.string_value^, i, found);
    IF NOT found THEN
      i := 0;
    IFEND;

    clp$make_integer_value (i, 10, FALSE, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;

  PROCEND clp$$scan_any;
?? TITLE := 'clp$$scan_not_any', EJECT ??

  PROCEDURE [XDCL] clp$$scan_not_any
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$scan_not_any) $scan_not_any, $scan_notany (
{   characters: string 1..256 = $required
{   string: string = $required
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend := [[1, [87, 10, 28, 9, 25, 31, 808], clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$SCAN_NOT_ANY'],
            [['CHARACTERS                     ', clc$nominal_entry, 1],
            ['STRING                         ', clc$nominal_entry, 2]], [

{ 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, 8, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [2, 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, 8, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$string_type], [1, 256, FALSE]],

{ PARAMETER 2

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]];

?? POP ??

    CONST
      p$characters = 1,
      p$string = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    TYPE
      char_set = set of char;

    VAR
      chars: char_set,
      found: boolean,
      i: integer;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    chars := $char_set [];
    FOR i := 1 TO STRLENGTH (pvt [p$characters].value^.string_value^) DO
      chars := chars + $char_set [pvt [p$characters].value^.string_value^ (i)];
    FOREND;
    chars := -chars;

    #SCAN (chars, pvt [p$string].value^.string_value^, i, found);
    IF NOT found THEN
      i := 0;
    IFEND;

    clp$make_integer_value (i, 10, FALSE, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;

  PROCEND clp$$scan_not_any;
?? TITLE := 'clp$$scan_string', EJECT ??

  PROCEDURE [XDCL] clp$$scan_string
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$scan_string) $scan_string (
{   pattern: string = $required
{   string: string = $required
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend := [[1, [87, 10, 28, 9, 31, 49, 390], clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$SCAN_STRING'],
            [['PATTERN                        ', clc$nominal_entry, 1],
            ['STRING                         ', clc$nominal_entry, 2]], [

{ 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, 8, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [2, 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, 8, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],

{ PARAMETER 2

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]];

?? POP ??

    CONST
      p$pattern = 1,
      p$string = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      i: integer,
      p: ^clt$string_value,
      s: ^clt$string_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p := pvt [p$pattern].value^.string_value;
    s := pvt [p$string].value^.string_value;

    i := 1;
    IF STRLENGTH (p^) > 0 THEN

    /scan/
      BEGIN
        WHILE (i <= STRLENGTH (s^)) AND (STRLENGTH (p^) <= (STRLENGTH (s^) - i + 1)) DO
          IF s^ (i, STRLENGTH (p^)) = p^ THEN
            EXIT /scan/;
          IFEND;
          i := i + 1;
        WHILEND;
        i := 0;
      END /scan/;
    IFEND;

    clp$make_integer_value (i, 10, FALSE, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;

  PROCEND clp$$scan_string;
?? TITLE := 'clp$$scl_test_harness_active', EJECT ??

  PROCEDURE [XDCL] clp$$scl_test_harness_active
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

    clp$scan_argument_list (function_name, argument_list, NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    value.descriptor := clv$value_descriptors [clc$boolean_value];
    value.kind := clc$boolean_value;
    value.bool.kind := clc$true_false_boolean;
    value.bool.value := clc$compiling_for_test_harness;

  PROCEND clp$$scl_test_harness_active;
?? TITLE := 'clp$$severity', EJECT ??

  PROCEDURE [XDCL] clp$$severity
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      severity_adt: [STATIC, READ, cls$adt] array [1 .. 1] of clt$argument_descriptor := [
            {1} [[clc$required], [NIL, clc$integer_value, 0, osc$max_condition]]];

    VAR
      severity: ost$status_severity,
      avt: array [1 .. 1] of clt$value;

    clp$scan_argument_list (function_name, argument_list, ^severity_adt, ^avt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    osp$get_status_severity (avt [1].int.value, severity, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    value.descriptor := clv$value_descriptors [clc$string_value];
    value.kind := clc$string_value;
    value.str.size := osv$severities [severity].size;
    value.str.value := osv$severities [severity].value;

  PROCEND clp$$severity;
?? TITLE := 'clp$$size', EJECT ??

  PROCEDURE [XDCL] clp$$size
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$size) $size (
{   value: any of
{       string
{       list 0..clc$max_list_size
{     anyend = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$list_type_qualifier,
          recend,
        recend,
      recend := [[1, [87, 10, 28, 12, 50, 16, 385], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$SIZE'],
            [['VALUE                          ', 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, 44, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$list_type, clc$string_type], FALSE, 2], 8,
            [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]], 16,
            [[1, 0, clc$list_type], [0, 0, clc$max_list_size, FALSE]]]];

?? POP ??

    CONST
      p$value = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      size: integer;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$value].value^.kind = clc$string THEN
      size := STRLENGTH (pvt [p$value].value^.string_value^);
    ELSE
      size := clp$count_list_elements (pvt [p$value].value);
    IFEND;

    clp$make_integer_value (size, 10, FALSE, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;

  PROCEND clp$$size;
?? TITLE := 'clp$$sort_fields', EJECT ??

  PROCEDURE [XDCL] clp$$sort_fields
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sort_fields) $sort_fields (
{   record: any = $required
{   )

?? 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,
      recend,
    recend := [
    [1,
    [90, 4, 3, 19, 50, 54, 707],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$SORT_FIELDS'], [
    ['RECORD                         ',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, 12, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [-$clt$type_kinds [],
    FALSE, 0]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$record = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$record].value^.kind <> clc$record THEN
      osp$set_status_abnormal ('CL', cle$wrong_kind_of_param_value, 'RECORD', status);
      clp$append_status_value_type (osc$status_parameter_delimiter, pvt [p$record].value, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'RECORD', status);
      RETURN;
    IFEND;

    result := pvt [p$record].value;
    clp$sort_record_fields (result^.field_values^);

  PROCEND clp$$sort_fields;
?? TITLE := 'clp$$statistic_code', EJECT ??

  PROCEDURE [XDCL] clp$$statistic_code
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$statistic_code) $statistic_code (
{   statistic_code: statistic_code = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [87, 11, 4, 13, 42, 35, 857], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$STATISTIC_CODE'],
            [['STATISTIC_CODE                 ', 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, 3, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$statistic_code_type]]];

?? POP ??

    CONST
      p$statistic_code = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_integer_value (pvt [p$statistic_code].value^.statistic_code_value, 10, FALSE, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$statistic_code;
?? TITLE := 'clp$$statistic_code_string', EJECT ??

  PROCEDURE [XDCL] clp$$statistic_code_string
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);


{ FUNCTION (sfm$$stacs) $statistic_code_string (
{   statistic_code: statistic_code = $required
{   )

?? 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,
      recend,
    recend := [
    [1,
    [89, 2, 22, 12, 45, 46, 666],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'SFM$$STACS'], [
    ['STATISTIC_CODE                 ',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, 3, clc$required_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$statistic_code_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$statistic_code = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      condition_string: ost$string;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    osp$get_status_condition_string (pvt [p$statistic_code].value^.statistic_code_value, condition_string,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_string_value (condition_string.value (1, condition_string.size), work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$statistic_code_string;
?? TITLE := 'clp$$status', EJECT ??

  PROCEDURE [XDCL] clp$$status
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{   FUNCTION (osm$$status) $status (
{       normal: boolean = $required
{       identifier: string 2
{       condition: status_code
{       text: list rest of any)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 4] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$union_type_qualifier,
          recend,
        recend,
      recend := [[1, [87, 10, 30, 11, 4, 45, 357], clc$function, 4, 4, 1, 0, 0, 0, 0, 'OSM$$STATUS'],
            [['CONDITION                      ', clc$nominal_entry, 3],
            ['IDENTIFIER                     ', clc$nominal_entry, 2],
            ['NORMAL                         ', clc$nominal_entry, 1],
            ['TEXT                           ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [3, 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, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [2, 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, 8, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [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, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [4, 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, 28, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$boolean_type]],

{ PARAMETER 2

      [[1, 0, clc$string_type], [2, 2, FALSE]],

{ PARAMETER 3

      [[1, 0, clc$status_code_type]],

{ PARAMETER 4

      [[1, 0, clc$list_type], [12, 1, clc$max_list_size, TRUE],
            [[1, 0, clc$union_type], [-$clt$type_kinds [], FALSE, 0]]]];

?? POP ??

    CONST
      p$normal = 1,
      p$identifier = 2,
      p$condition = 3,
      p$text = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;


    VAR
      condition: ost$status_condition_code,
      condition_radix: integer,
      integer_string: ost$string,
      next_element: ^clt$data_value,
      next_text: ^clt$data_value,
      result_status: ost$status,
      string_sequence: ^clt$data_representation,
      string_pointer: ^clt$string_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    result_status.normal := pvt [p$normal].value^.boolean_value.value;

    IF NOT result_status.normal THEN

      IF pvt [p$identifier].value = NIL THEN
        osp$set_status_abnormal ('CL', cle$required_argument_omitted, '$STATUS', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'IDENTIFIER', status);
        RETURN;
      IFEND;

      IF pvt [p$condition].value = NIL THEN
        osp$set_status_abnormal ('CL', cle$required_argument_omitted, '$STATUS', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'CONDITION', status);
        RETURN;
      IFEND;

      osp$set_status_abnormal (pvt [p$identifier].value^.string_value^ (1, 2),
            pvt [p$condition].value^.status_code_value, '', result_status);
      next_element := pvt [p$text].value;

    /append_text/
      WHILE next_element <> NIL DO
        next_text := next_element^.element_value;
        CASE next_text^.kind OF
        = clc$string =
          osp$append_status_parameter (osc$status_parameter_delimiter, next_text^.string_value^,
                result_status);

        = clc$name =
          osp$append_status_parameter (osc$status_parameter_delimiter, next_text^.name_value, result_status);

        = clc$integer =
          osp$append_status_integer (osc$status_parameter_delimiter, next_text^.integer_value.value,
                next_text^.integer_value.radix, next_text^.integer_value.radix_specified, result_status);

        = clc$file =
          osp$append_status_file (osc$status_parameter_delimiter, next_text^.file_value^, result_status);

        = clc$real =
          osp$append_status_real (osc$status_parameter_delimiter, next_text^.real_value.value,
                next_text^.real_value.number_of_digits, result_status);

        ELSE
          clp$convert_data_to_string (next_text, clc$data_source_representation, clc$max_string_size,
                work_area, string_sequence, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          string_pointer := clp$data_representation_text (string_sequence);
          osp$append_status_parameter (osc$status_parameter_delimiter, string_pointer^, result_status);
        CASEND;
        next_element := next_element^.link;
      WHILEND /append_text/;
    IFEND;

    clp$make_status_value (result_status, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$status;
?? TITLE := 'clp$$status_code', EJECT ??

  PROCEDURE [XDCL] clp$$status_code
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$status_code) $status_code (
{   status_code: status_code = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [87, 10, 30, 14, 15, 46, 322], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$STATUS_CODE'],
            [['STATUS_CODE                    ', 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, 3, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_code_type]]];

?? POP ??

    CONST
      p$status_code = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_integer_value (pvt [p$status_code].value^.status_code_value, 10, FALSE, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$status_code;
?? TITLE := 'clp$$status_code_name', EJECT ??

  PROCEDURE [XDCL] clp$$status_code_name
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$stacn) $status_code_name (
{   status_code: status_code = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 9, 23, 13, 45, 31, 629], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$STACN'],
            [['STATUS_CODE                    ', 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, 3, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_code_type]]];

?? POP ??

    CONST
      p$status_code = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      name: ost$status_condition_name;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    osp$get_status_condition_name (pvt [p$status_code].value^.status_code_value, name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_value (clc$name, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;
    result^.name_value := name;

  PROCEND clp$$status_code_name;
?? TITLE := 'clp$$status_code_string', EJECT ??

  PROCEDURE [XDCL] clp$$status_code_string
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);


{ FUNCTION (osm$$stacs) $status_code_string (
{   status_code: status_code = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 9, 23, 13, 46, 13, 641], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$STACS'],
            [['STATUS_CODE                    ', 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, 3, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_code_type]]];

?? POP ??

    CONST
      p$status_code = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      condition_string: ost$string;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    osp$get_status_condition_string (pvt [p$status_code].value^.status_code_value, condition_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_string_value (condition_string.value (1, condition_string.size), work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$status_code_string;
?? TITLE := 'clp$$status_message', EJECT ??

  PROCEDURE [XDCL] clp$$status_message
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$status_message) $status_message (
{   status: status = $required
{   maximum_line_size: integer osc$min_status_message_line..osc$max_status_message_line = $required
{   message_level: key
{       (current, c)
{       (brief, b)
{       (full, f)
{     keyend = current
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 6] of clt$keyword_specification,
          default_value: string (7),
        recend,
      recend := [[1, [88, 5, 14, 11, 55, 37, 680], clc$function, 3, 3, 2, 0, 0, 0, 0, 'OSM$$STATUS_MESSAGE'],
            [['MAXIMUM_LINE_SIZE              ', clc$nominal_entry, 2],
            ['MESSAGE_LEVEL                  ', clc$nominal_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [3, 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, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [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, 20, clc$required_parameter, 0, 0],

{ PARAMETER 3

      [2, 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, 229, clc$optional_default_parameter, 0,
            7]],

{ PARAMETER 1

      [[1, 0, clc$status_type]],

{ PARAMETER 2

      [[1, 0, clc$integer_type], [osc$min_status_message_line, osc$max_status_message_line, 10]],

{ PARAMETER 3

      [[1, 0, clc$keyword_type], [6], [['B                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['BRIEF                          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['C                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['CURRENT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['F                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FULL                           ', clc$nominal_entry,
            clc$normal_usage_entry, 3]], 'current']];

?? POP ??

    CONST
      p$status = 1,
      p$maximum_line_size = 2,
      p$message_level = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      i: 1 .. osc$max_status_message_lines,
      message: ^ost$status_message,
      message_level: ost$format_message_level,
      message_line: ^string ( * ),
      message_line_count: ^ost$status_message_line_count,
      message_line_size: ^ost$status_message_line_size,
      node: ^clt$data_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT message IN work_area;
    IF message = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;

    IF pvt [p$message_level].value^.keyword_value = 'CURRENT' THEN
      message_level := osc$current_message_level;
    ELSEIF pvt [p$message_level].value^.keyword_value = 'BRIEF' THEN
      message_level := osc$brief_message_level;
    ELSE { pvt [p$message_level].value^.keyword_value = 'FULL' }
      message_level := osc$full_message_level;
    IFEND;

    osp$format_message (pvt [p$status].value^.status_value^, message_level,
          pvt [p$maximum_line_size].value^.integer_value.value, message^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /work_area_ok/
    BEGIN
      RESET message;
      NEXT message_line_count IN message;
      clp$make_list_value (work_area, result);
      IF result = NIL THEN
        EXIT /work_area_ok/;
      IFEND;
      node := result;

      FOR i := 1 TO message_line_count^ DO
        clp$make_value (clc$string, work_area, node^.element_value);
        IF node^.element_value = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        NEXT message_line_size IN message;
        NEXT message_line: [message_line_size^] IN message;
        node^.element_value^.string_value := ^message_line^ (2, * );
        IF i < message_line_count^ THEN
          clp$make_list_value (work_area, node^.link);
          IF node^.link = NIL THEN
            EXIT /work_area_ok/;
          IFEND;
          node := node^.link;
        IFEND;
      FOREND;

      RETURN;
    END /work_area_ok/;
    osp$set_status_condition (cle$work_area_overflow, status);

  PROCEND clp$$status_message;
?? TITLE := 'clp$$status_severity', EJECT ??

  PROCEDURE [XDCL] clp$$status_severity
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$status_severity) $status_severity (
{   status_code: status_code = $required
{   level: key
{       (non_standard, ns, n)
{       (dependent, d)
{       (informative, i)
{       (warning, w)
{       (error, e)
{       (fatal, f)
{       (catastrophic, c)
{     keyend = $optional
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 15] of clt$keyword_specification,
        recend,
      recend := [[1, [88, 5, 14, 10, 54, 23, 127], clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$STATUS_SEVERITY'],
            [['LEVEL                          ', clc$nominal_entry, 2],
            ['STATUS_CODE                    ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [2, 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, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [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, 562, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_code_type]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [15], [['C                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['CATASTROPHIC                   ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['D                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['DEPENDENT                      ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['E                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['ERROR                          ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['F                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['FATAL                          ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['I                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['INFORMATIVE                    ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['N                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['NON_STANDARD                   ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NS                             ', clc$alias_entry,
            clc$normal_usage_entry, 1], ['W                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['WARNING                        ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]]];

?? POP ??

    CONST
      p$status_code = 1,
      p$level = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      diagnostic_severities: [STATIC, READ, oss$job_paged_literal] array [ost$diagnostic_severity] of
            clt$keyword := ['NON_STANDARD', 'DEPENDENT', 'INFORMATIVE', 'WARNING', 'ERROR', 'FATAL',
            'CATASTROPHIC'];

    VAR
      level: ost$diagnostic_severity,
      severity: ost$diagnostic_severity;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$get_diagnostic_severity (pvt [p$status_code].value^.status_code_value, severity, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$level].specified THEN

    /lookup/
      FOR level := LOWERVALUE (ost$diagnostic_severity) TO UPPERVALUE (ost$diagnostic_severity) DO
        IF pvt [p$level].value^.keyword_value = diagnostic_severities [level] THEN
          EXIT /lookup/;
        IFEND;
      FOREND /lookup/;
      clp$make_boolean_value (severity >= level, clc$true_false_boolean, work_area, result);
    ELSE
      clp$make_keyword_value (diagnostic_severities [severity], work_area, result);
    IFEND;

    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$status_severity;
?? TITLE := 'clp$$string', EJECT ??

  PROCEDURE [XDCL] clp$$string
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$string) $string (
{   value: any = $required
{   format: key
{       (elements, element, e)
{       (compressed_labeled_elements, cle)
{       (data_structure, das, ds)
{       (display_elements, display_element, de)
{       (display_source, dis)
{       (labeled_elements, le)
{       (source, s)
{     keyend = elements
{   max_string: integer 3..clc$max_string_size = $max_string
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 17] of clt$keyword_specification,
        default_value: string (8),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (11),
      recend,
    recend := [
    [1,
    [90, 2, 22, 11, 26, 5, 151],
    clc$function, 3, 3, 1, 0, 0, 0, 0, 'OSM$$STRING'], [
    ['FORMAT                         ',clc$nominal_entry, 2],
    ['MAX_STRING                     ',clc$nominal_entry, 3],
    ['VALUE                          ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, 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, 12, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [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, 636,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 3
    [2, 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, 20,
  clc$optional_default_parameter, 0, 11]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [-$clt$type_kinds [],
    FALSE, 0]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [17], [
    ['CLE                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['COMPRESSED_LABELED_ELEMENTS    ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['DAS                            ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['DATA_STRUCTURE                 ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['DE                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['DIS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['DISPLAY_ELEMENT                ', clc$alias_entry, clc$normal_usage_entry, 4],
    ['DISPLAY_ELEMENTS               ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['DISPLAY_SOURCE                 ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['DS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ELEMENT                        ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['ELEMENTS                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['LABELED_ELEMENTS               ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['LE                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
    ['SOURCE                         ', clc$nominal_entry, clc$normal_usage_entry, 7]]
    ,
    'elements'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [3, clc$max_string_size, 10],
    '$max_string']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$value = 1,
      p$format = 2,
      p$max_string = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      i: clt$data_representation_count,
      node: ^clt$data_value,
      representation: ^clt$data_representation,
      request: clt$convert_to_string_request,
      string_count: ^clt$data_representation_count,
      string_size: ^clt$string_size;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    request.initial_indentation := 0;
    request.continuation_indentation := 0;
    request.max_string := pvt [p$max_string].value^.integer_value.value;
    request.include_advanced_items := TRUE;
    request.include_hidden_items := TRUE;
    request.kind := clc$convert_data_value;
    IF pvt [p$format].value^.keyword_value = 'ELEMENTS' THEN
      request.representation_option := clc$data_elem_representation;
    ELSEIF pvt [p$format].value^.keyword_value = 'DATA_STRUCTURE' THEN
      request.representation_option := clc$data_struct_representation;
    ELSEIF pvt [p$format].value^.keyword_value = 'SOURCE' THEN
      request.representation_option := clc$data_source_representation;
    ELSEIF pvt [p$format].value^.keyword_value = 'LABELED_ELEMENTS' THEN
      request.representation_option := clc$labeled_elem_representation;
    ELSEIF pvt [p$format].value^.keyword_value = 'DISPLAY_ELEMENTS' THEN
      request.representation_option := clc$display_elem_representation;
    ELSEIF pvt [p$format].value^.keyword_value = 'DISPLAY_SOURCE' THEN
      request.representation_option := clc$display_srce_representation;
    ELSE { pvt [p$format].value^.keyword_value = 'COMPRESSED_LABELED_ELEMENTS' }
      request.representation_option := clc$compressed_labeled_elem_rep;
    IFEND;
    request.value := pvt [p$value].value;
    clp$internal_convert_to_string (request, work_area, representation, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /work_area_ok/
    BEGIN
      NEXT string_count IN representation;
      IF string_count^ = 1 THEN
        clp$make_value (clc$string, work_area, result);
        IF result = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        NEXT string_size IN representation;
        NEXT result^.string_value: [string_size^] IN representation;
      ELSE
        clp$make_list_value (work_area, result);
        IF result = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        node := result;

        FOR i := 1 TO string_count^ DO
          clp$make_value (clc$string, work_area, node^.element_value);
          IF node^.element_value = NIL THEN
            EXIT /work_area_ok/;
          IFEND;
          NEXT string_size IN representation;
          NEXT node^.element_value^.string_value: [string_size^] IN representation;
          IF i < string_count^ THEN
            clp$make_list_value (work_area, node^.link);
            IF node^.link = NIL THEN
              EXIT /work_area_ok/;
            IFEND;
            node := node^.link;
          IFEND;
        FOREND;
      IFEND;

      RETURN;
    END /work_area_ok/;
    osp$set_status_condition (cle$work_area_overflow, status);

  PROCEND clp$$string;
*IFEND
?? TITLE := 'clp$$strlen', EJECT ??

  PROCEDURE [XDCL] clp$$strlen
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
{ FUNCTION (osm$$strlen) $strlen (
{   string: string = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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$string_type_qualifier,
        recend,
      recend := [[1, [87, 11, 3, 17, 41, 28, 229], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$STRLEN'],
            [['STRING                         ', 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, 8, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]];

?? POP ??

    CONST
      p$string = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;
*ELSE
{ FUNCTION (osm$$strlen) $strlen (
{   string: string = $required
{   )

?? 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$string_type_qualifier,
      recend,
    recend := [
    [2,
    [91, 8, 17, 14, 18, 26, 0],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$STRLEN'], [
    ['STRING                         ',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, 9, clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[2, 0, clc$string_type], [0, clc$max_string_size, FALSE]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$string = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;
*IFEND


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_integer_value (STRLENGTH (pvt [p$string].value^.string_value^), 10, FALSE, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;

  PROCEND clp$$strlen;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$$strrep', EJECT ??

  PROCEDURE [XDCL] clp$$strrep
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$strrep) $strrep (
{   value: any = $required
{   radix: integer 2..16 = 10
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$union_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (2),
        recend,
      recend := [[1, [87, 10, 26, 10, 8, 5, 510], clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$STRREP'],
            [['RADIX                          ', clc$nominal_entry, 2],
            ['VALUE                          ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [2, 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, 12, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [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, 20, clc$optional_default_parameter, 0,
            2]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [-$clt$type_kinds [], FALSE, 0]],

{ PARAMETER 2

      [[1, 0, clc$integer_type], [2, 16, 10], '10']];

?? POP ??

    CONST
      p$value = 1,
      p$radix = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      representation: ^clt$data_representation,
      request: clt$convert_to_string_request,
      str: ^ost$string;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /work_area_ok/
    BEGIN
      clp$make_value (clc$string, work_area, result);
      IF result = NIL THEN
        EXIT /work_area_ok/;
      IFEND;

      IF pvt [p$value].value^.kind = clc$integer THEN
        NEXT str IN work_area;
        IF str = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        clp$convert_integer_to_string (pvt [p$value].value^.integer_value.value,
              pvt [p$radix].value^.integer_value.value, FALSE, str^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        result^.string_value := ^str^.value (1, str^.size);

      ELSE
        request.initial_indentation := 0;
        request.continuation_indentation := 0;
        request.max_string := clc$max_string_size;
        request.include_advanced_items := TRUE;
        request.include_hidden_items := TRUE;
        request.kind := clc$convert_data_value;
        request.representation_option := clc$data_elem_representation;
        request.value := pvt [p$value].value;
        clp$internal_convert_to_string (request, work_area, representation, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        result^.string_value := clp$data_representation_text (representation);
      IFEND;

      RETURN;
    END /work_area_ok/;
    osp$set_status_condition (cle$work_area_overflow, status);

  PROCEND clp$$strrep;
?? TITLE := 'clp$$substring', EJECT ??

  PROCEDURE [XDCL] clp$$substring
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$substr) $substring, $substr (
{   string: string = $required
{   index: integer 1..clc$max_string_size+1 = $required
{   size: integer 0..clc$max_string_size = 1
{   fill_character: string 1 = ' '
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 4] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (1),
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
          default_value: string (3),
        recend,
      recend := [[1, [87, 10, 26, 11, 0, 15, 667], clc$function, 4, 4, 2, 0, 0, 0, 0, 'OSM$$SUBSTR'],
            [['FILL_CHARACTER                 ', clc$nominal_entry, 4],
            ['INDEX                          ', clc$nominal_entry, 2],
            ['SIZE                           ', clc$nominal_entry, 3],
            ['STRING                         ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [4, 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, 8, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [2, 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, 20, clc$required_parameter, 0, 0],

{ PARAMETER 3

      [3, 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, 20, clc$optional_default_parameter, 0,
            1],

{ PARAMETER 4

      [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, 8, clc$optional_default_parameter, 0,
            3]],

{ PARAMETER 1

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],

{ PARAMETER 2

      [[1, 0, clc$integer_type], [1, clc$max_string_size + 1, 10]],

{ PARAMETER 3

      [[1, 0, clc$integer_type], [0, clc$max_string_size, 10], '1'],

{ PARAMETER 4

      [[1, 0, clc$string_type], [1, 1, FALSE], ''' ''']];

?? POP ??

    CONST
      p$string = 1,
      p$index = 2,
      p$size = 3,
      p$fill_character = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      index: clt$string_index,
      size: clt$string_size;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_sized_string_value (pvt [p$size].value^.integer_value.value, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;

    index := pvt [p$index].value^.integer_value.value;
    size := STRLENGTH (pvt [p$string].value^.string_value^);
    IF index <= size THEN
      size := size - index + 1;
    ELSE
      index := 1;
      size := 0;
    IFEND;

    result^.string_value^ := pvt [p$string].value^.string_value^ (index, size);

    IF pvt [p$fill_character].value^.string_value^ (1) <> ' ' THEN
      FOR index := size + 1 TO STRLENGTH (result^.string_value^) DO
        result^.string_value^ (index) := pvt [p$fill_character].value^.string_value^ (1);
      FOREND;
    IFEND;

  PROCEND clp$$substring;
?? TITLE := 'clp$$system', EJECT ??

  PROCEDURE [XDCL] clp$$system
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$system) $system (
{   attribute: key
{       (catalog, c)
{       (version, v)
{       (dual_state_partner, c170_os_type, dsp)
{     keyend = catalog
{   )

?? 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$keyword_type_qualifier,
        keyword_specs: array [1 .. 7] of clt$keyword_specification,
        default_value: string (7),
      recend,
    recend := [
    [1,
    [90, 2, 28, 16, 43, 8, 309],
    clc$function, 1, 1, 0, 0, 0, 0, 0, 'OSM$SYSTEM'], [
    ['ATTRIBUTE                      ',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, 266,
  clc$optional_default_parameter, 0, 7]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [7], [
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['C170_OS_TYPE                   ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['CATALOG                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['DSP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['DUAL_STATE_PARTNER             ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['V                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['VERSION                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'catalog']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$attribute = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    CONST
      max_os_type_size = 6 {NOS/BE} ;

    VAR
      c170_os_type: [STATIC, READ, oss$job_paged_literal] array [ost$170_os_type] of record
        size: 1 .. max_os_type_size,
        value: string (max_os_type_size),
      recend := [[4, 'NONE'], [3, 'NOS'], [6, 'NOS/BE']],
      attribute: array [1 .. 1] of jmt$job_attribute_result;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$attribute].value^.keyword_value = 'CATALOG' THEN
      clp$make_file_value (':$SYSTEM.$SYSTEM', work_area, result);
      RETURN;

    ELSEIF pvt [p$attribute].value^.keyword_value = 'DUAL_STATE_PARTNER' THEN
      attribute [1].key := jmc$c170_os_type;

    ELSE {VERSION}
      attribute [1].key := jmc$os_version;
    IFEND;

    jmp$get_job_attributes (^attribute, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE attribute [1].key OF

    = jmc$c170_os_type =
      clp$make_string_value (c170_os_type [attribute [1].c170_os_type].value (1,
            c170_os_type [attribute [1].c170_os_type].size), work_area, result);

    = jmc$os_version =
      clp$make_string_value (attribute [1].os_version (1, clp$trimmed_string_size (attribute [1].os_version)),
            work_area, result);

    ELSE
      ;
    CASEND;

  PROCEND clp$$system;
?? TITLE := 'clp$$translate', EJECT ??

  PROCEDURE [XDCL] clp$$translate
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$translate) $translate (
{   translation_table: any of
{       record
{         base: key
{           (lower_to_upper, ltu)
{           (upper_to_lower, utl)
{           (control_codes_to_question_marks, cctqm)
{           none
{         keyend
{         original: string = $optional
{         translated: string = $optional
{       recend
{       string 256
{     anyend = $required
{   string: string = $required
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 7] of clt$keyword_specification,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
    recend := [
    [1,
    [90, 1, 26, 14, 39, 31, 630],
    clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$TRANSLATE'], [
    ['STRING                         ',clc$nominal_entry, 2],
    ['TRANSLATION_TABLE              ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 425,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [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, 8, clc$required_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$record_type, clc$string_type],
    FALSE, 2],
    397, [[1, 0, clc$record_type], [3],
      ['BASE                           ', clc$required_field, 266], [[1, 0, clc$keyword_type], [7], [
        ['CCTQM                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['CONTROL_CODES_TO_QUESTION_MARKS', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['LOWER_TO_UPPER                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['LTU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['UPPER_TO_LOWER                 ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['UTL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2]]
        ],
      ['ORIGINAL                       ', clc$optional_field, 8], [[1, 0, clc$string_type], [0,
  clc$max_string_size, FALSE]],
      ['TRANSLATED                     ', clc$optional_field, 8], [[1, 0, clc$string_type], [0,
  clc$max_string_size, FALSE]]
      ],
    8, [[1, 0, clc$string_type], [256, 256, FALSE]]
    ],
{ PARAMETER 2
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$translation_table = 1,
      p$string = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      i: clt$string_index,
      original: ^clt$string_value,
      predefined_table: ^string (256),
      translated: ^clt$string_value,
      translation_table: ^string (256);


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$translation_table].value^.kind = clc$record THEN
      IF pvt [p$translation_table].value^.field_values^ [1].value^.keyword_value = 'LOWER_TO_UPPER' THEN
        predefined_table := ^osv$lower_to_upper;
      ELSEIF pvt [p$translation_table].value^.field_values^ [1].value^.keyword_value = 'UPPER_TO_LOWER' THEN
        predefined_table := ^osv$upper_to_lower;
      ELSEIF pvt [p$translation_table].value^.field_values^ [1].value^.keyword_value =
            'CONTROL_CODES_TO_QUESTION_MARKS' THEN
        predefined_table := ^osv$control_codes_to_quest_mark;
      ELSE {NONE}
        PUSH predefined_table;
        FOR i := 1 TO 256 DO
          predefined_table^ (i) := $CHAR (i - 1);
        FOREND;
      IFEND;

      IF (pvt [p$translation_table].value^.field_values^ [2].value = NIL) AND
            (pvt [p$translation_table].value^.field_values^ [3].value = NIL) THEN
        translation_table := predefined_table;
      ELSE
        PUSH translation_table;
        translation_table^ := predefined_table^;
        original := pvt [p$translation_table].value^.field_values^ [2].value^.string_value;
        translated := pvt [p$translation_table].value^.field_values^ [3].value^.string_value;
        i := 1;
        WHILE (i <= STRLENGTH (original^)) AND (i <= STRLENGTH (translated^)) DO
          translation_table^ ($INTEGER (original^ (i)) + 1) := translated^ (i);
          i := I + 1;
        WHILEND;
      IFEND;

    ELSE {clc$string}
      translation_table := pvt [p$translation_table].value^.string_value;
    IFEND;

    clp$make_sized_string_value (STRLENGTH (pvt [p$string].value^.string_value^), work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    #TRANSLATE (translation_table^, pvt [p$string].value^.string_value^, result^.string_value^);

  PROCEND clp$$translate;
?? TITLE := 'clp$$trim', EJECT ??

  PROCEDURE [XDCL] clp$$trim
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$trim) $trim (
{   string: string = $required
{   char: string 1 = ' '
{   leading_or_trailing: list of key
{       (trailing, t)
{       (leading, l)
{       all
{     keyend = trailing
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
          default_value: string (3),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 5] of clt$keyword_specification,
          recend,
          default_value: string (8),
        recend,
      recend := [[1, [87, 10, 27, 17, 56, 47, 255], clc$function, 3, 3, 1, 0, 0, 0, 0, 'OSM$$TRIM'],
            [['CHAR                           ', clc$nominal_entry, 2],
            ['LEADING_OR_TRAILING            ', clc$nominal_entry, 3],
            ['STRING                         ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [3, 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, 8, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [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, 8, clc$optional_default_parameter, 0,
            3],

{ PARAMETER 3

      [2, 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, 208, clc$optional_default_parameter, 0,
            8]],

{ PARAMETER 1

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],

{ PARAMETER 2

      [[1, 0, clc$string_type], [1, 1, FALSE], ''' '''],

{ PARAMETER 3

      [[1, 0, clc$list_type], [192, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [5], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['L                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['LEADING                        ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['T                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['TRAILING                       ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 'trailing']];

?? POP ??

    CONST
      p$string = 1,
      p$char = 2,
      p$leading_or_trailing = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      c: char,
      first: clt$string_index,
      last: clt$string_size,
      option: ^clt$data_value,
      s: ^clt$string_value,
      trim_leading: boolean,
      trim_trailing: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    trim_trailing := FALSE;
    trim_leading := FALSE;
    option := pvt [p$leading_or_trailing].value;
    WHILE option <> NIL DO
      IF option^.element_value^.keyword_value = 'TRAILING' THEN
        trim_trailing := TRUE;
      ELSEIF option^.element_value^.keyword_value = 'LEADING' THEN
        trim_leading := TRUE;
      ELSE {ALL}
        trim_trailing := TRUE;
        trim_leading := TRUE;
      IFEND;
      option := option^.link;
    WHILEND;

    c := pvt [p$char].value^.string_value^ (1);
    s := pvt [p$string].value^.string_value;

    last := STRLENGTH (s^);
    IF trim_trailing THEN
      WHILE (last > 0) AND (s^ (last) = c) DO
        last := last - 1;
      WHILEND;
    IFEND;

    first := 1;
    IF trim_leading THEN
      WHILE (first <= last) AND (s^ (first) = c) DO
        first := first + 1;
      WHILEND;
    IFEND;

    clp$make_string_value (s^ (first, last - first + 1), work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;

  PROCEND clp$$trim;
?? TITLE := 'clp$$true', EJECT ??

  PROCEDURE [XDCL] clp$$true
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$true) $true (
{   boolean_value: any = $required
{   )

?? 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,
      recend,
    recend := [
    [1,
    [91, 9, 11, 11, 12, 47, 677],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$TRUE'], [
    ['BOOLEAN_VALUE                  ',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, 12, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [-$clt$type_kinds [],
    FALSE, 0]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$boolean_value = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      boolean_value: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE pvt [p$boolean_value].value^.kind OF
    = clc$boolean =
      boolean_value := pvt [p$boolean_value].value^.boolean_value.value;
    ELSE
      boolean_value := FALSE;
    CASEND;

    clp$make_boolean_value (boolean_value, clc$true_false_boolean, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$true;
?? TITLE := 'clp$$type', EJECT ??

  PROCEDURE [XDCL] clp$$type
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{  FUNCTION (osm$$type) $type (
{    variable: data_name = $required
{    )

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 1, 18, 8, 34, 8, 680], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$TYPE'],
            [['VARIABLE                       ', 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, 3, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$data_name_type]]];

?? POP ??

    CONST
      p$variable = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      ignore_access_mode: clt$data_access_mode,
      ignore_class: clt$variable_class,
      ignore_evaluation_method: clt$expression_eval_method,
      ignore_value: ^clt$data_value,
      type_specification: ^clt$type_specification;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_variable (pvt [p$variable].value^.data_name_value, work_area, ignore_class, ignore_access_mode,
          ignore_evaluation_method, type_specification, ignore_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_type_spec_value (type_specification, work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$type;
?? TITLE := 'clp$$unique', EJECT ??

  PROCEDURE [XDCL] clp$$unique
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$unique) $unique (
{   result: any of
{       key
{         string
{         name
{       keyend
{       file
{     anyend = string
{   )

?? PUSH (LISTEXT := ON) ??

    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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
          default_value: string (6),
        recend,
      recend := [[1, [88, 6, 18, 10, 26, 38, 324], clc$function, 1, 1, 0, 0, 0, 0, 0, 'OSM$$UNIQUE'],
            [['RESULT                         ', 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, 104, clc$optional_default_parameter, 0,
            6]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['NAME                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['STRING                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 3, [[1, 0, clc$file_type]], 'string']];

?? POP ??

    CONST
      p$result = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      path: ^fst$file_reference,
      path_size: fst$path_size,
      unique_name: ost$name;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_unique_name (unique_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$result].value^.kind = clc$file THEN
      path_size := clp$trimmed_string_size (pvt [p$result].value^.file_value^);
      IF (path_size + 1 + osc$max_name_size) > fsc$max_path_size THEN
        osp$set_status_condition (cle$file_reference_too_long, status);
        RETURN;
      IFEND;
      clp$make_value (clc$file, work_area, result);
      IF result <> NIL THEN
        NEXT result^.file_value: [path_size + 1 + osc$max_name_size] IN work_area;
        IF result^.file_value <> NIL THEN
          result^.file_value^ (1, path_size) := pvt [p$result].value^.file_value^ (1, path_size);
          result^.file_value^ (path_size + 1) := '.';
          result^.file_value^ (path_size + 2, osc$max_name_size) := unique_name;
        IFEND;
      IFEND;
    ELSEIF pvt [p$result].value^.keyword_value = 'NAME' THEN
      clp$make_name_value (unique_name, work_area, result);
    ELSE { STRING }
      clp$make_string_value (unique_name, work_area, result);
    IFEND;

    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$unique;
?? TITLE := 'clp$$upper_bound', EJECT ??

  PROCEDURE [XDCL] clp$$upper_bound
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$upper_bound) $upper_bound, $upperbound (
{   array: array = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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$array_type_qualifier,
        recend,
      recend := [[1, [87, 12, 7, 17, 14, 22, 913], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$UPPER_BOUND'],
            [['ARRAY                          ', 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, 24, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$array_type], [0, FALSE]]];

?? POP ??

    CONST
      p$array = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_integer_value (UPPERBOUND (pvt [p$array].value^.array_value^), 10, FALSE, work_area, result);

  PROCEND clp$$upper_bound;
?? TITLE := 'clp$$upper_value', EJECT ??

  PROCEDURE [XDCL] clp$$upper_value
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$upper_value) $upper_value (
{   numeric_type: type = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 1, 18, 11, 40, 55, 495], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$UPPER_VALUE'],
            [['NUMERIC_TYPE                   ', 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, 3, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$type_specification_type]]];

?? POP ??

    CONST
      p$numeric_type = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      ignore_type_name: ^clt$type_name_reference,
      integer_type_qualifier: ^clt$integer_type_qualifier,
      real_type_qualifier: ^clt$real_type_qualifier,
      type_specification_header: ^clt$type_specification_header;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET pvt [p$numeric_type].value^.type_specification_value;
    NEXT type_specification_header IN pvt [p$numeric_type].value^.type_specification_value;
    IF type_specification_header = NIL THEN
      osp$set_status_condition (cle$bad_data_value, status);
      RETURN;
    IFEND;
    NEXT ignore_type_name: [type_specification_header^.name_size] IN pvt [p$numeric_type].
          value^.type_specification_value;
    IF ignore_type_name = NIL THEN
      osp$set_status_condition (cle$bad_data_value, status);
      RETURN;
    IFEND;
    IF type_specification_header^.kind = clc$integer_type THEN
      NEXT integer_type_qualifier IN pvt [p$numeric_type].value^.type_specification_value;
      IF integer_type_qualifier = NIL THEN
        osp$set_status_condition (cle$bad_data_value, status);
        RETURN;
      IFEND;
      clp$make_integer_value (integer_type_qualifier^.max_integer_value, 10, FALSE, work_area, result);
    ELSEIF type_specification_header^.kind = clc$real_type THEN
      NEXT real_type_qualifier IN pvt [p$numeric_type].value^.type_specification_value;
      IF real_type_qualifier = NIL THEN
        osp$set_status_condition (cle$bad_data_value, status);
        RETURN;
      IFEND;
      clp$make_real_value (real_type_qualifier^.max_real_value.long_real, clc$max_real_number_digits,
            work_area, result);
    ELSE
      clp$make_real_value (clv$positive_infinity^, clc$max_real_number_digits, work_area, result);
    IFEND;

    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$upper_value;

*IFEND
MODEND clm$miscellaneous_functions;
*DECK DECK=CLM$NAMED_TASK_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Named Task Manager' ??
MODULE clm$named_task_manager;

{
{ PURPOSE:
{   This module contains the procedures that manage the named task list.
{   Entries are added to the list via an aynchronous EXECUTE_TASK command or TASK/TASKEND statement.
{

?? NEWTITLE := 'Global Declarations' ??
?? NEWTITLE := 'Named Task List', EJECT ??
*copyc clt$named_task
?? OLDTITLE, EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_command_processing
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_named_task
*copyc clt$block
*copyc clt$task_name_reference
*copyc osd$virtual_address
*copyc oss$task_private
*copyc ost$caller_identifier
*copyc ost$name
*copyc ost$status
*copyc pme$execution_exceptions
*copyc pmt$task_id
*copyc pmt$task_status
?? SKIP := 6 ??

{ This is a dummy procedure that will never be called; it's sole
{ purpose is to fool SCU so that the XREF deck for clv$named_task_group_list
{ will not be called in later and cause a conflict between it and the
{ XDCL of the variable.

  PROCEDURE [INLINE] dummy;

*copyc clp$find_nt_group_list_first
*copyc clv$named_task_group_list

  PROCEND dummy;
?? SKIP := 6 ??
?? POP ??
*copyc avp$ring_min
*copyc clp$find_current_block
*copyc clp$find_named_task_group_list
*copyc clp$find_task_block
*copyc clp$validate_name
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osv$lower_to_upper
*copyc osv$task_shared_heap
*copyc pmp$execute_with_command_file
*copyc pmp$get_task_id
?? TITLE := 'clv$named_task_group_list', EJECT ??

  VAR
    clv$named_task_group_list: [XDCL, #GATE, oss$task_private] ^^clt$named_task := NIL;

?? TITLE := 'clp$execute_named_task', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$execute_named_task
    (    task_name: ost$name;
         target_ring: ost$valid_ring;
         program_description: pmt$program_description;
         parameters: pmt$program_parameters;
         command_file: amt$local_file_name;
     VAR task_id: pmt$task_id;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      caller_id: ost$caller_identifier,
      named_task_group_list: ^^clt$named_task,
      interactive: boolean,
      task_status: pmt$task_status,
      named_task: ^clt$named_task,
      named_task_list: ^clt$named_task,
      validated_task_name: ost$name,
      valid_name: boolean;


    #CALLER_ID (caller_id);
    status.normal := TRUE;

    IF target_ring < avp$ring_min () THEN

{ The only caller's of this interface that are expected to specify a ring number other
{ than their own are the TASK command and the invoking of a program command.
{ The latter case is recognized by the current SCL block being a "command block" for
{ a "program command" and allows the target ring to be less than the user's
{ validated minimum ring.

      clp$find_current_block (block);
      IF (block = NIL) OR (block^.kind <> clc$command_block) OR (block^.command_kind <> clc$program_command)
            THEN
        osp$set_status_abnormal ('CL', cle$task_taskend_ring_below_min, '', status);
        RETURN;
      IFEND;
    IFEND;


    clp$find_named_task_group_list (named_task_group_list);

    IF task_name = osc$null_name THEN

{ Synchronous mode - actually not a "named" task.

      pmp$execute_with_command_file (target_ring, program_description, parameters, command_file, osc$wait,
            TRUE, task_id, task_status, status);
      IF status.normal AND (NOT task_status.status.normal) AND
            (task_status.status.condition <> pme$terminated_by_parent) THEN

{ NOTE: The check for pme$terminated_by_parent is included in the above IF
{ statement so that if the task is terminated as a result of an SCL EXIT
{ statement, this procedure's status parameter will not be affected.

        status := task_status.status;
      IFEND;
    ELSE

{ Asynchronous mode.

      clp$validate_name (task_name, validated_task_name, valid_name);
      IF (NOT valid_name) OR (validated_task_name = 'ALL') OR (validated_task_name = 'NONE') THEN
        osp$set_status_abnormal ('CL', cle$invalid_exec_task_name, task_name, status);
      IFEND;

      create_named_task_entry (task_name, named_task_group_list, named_task, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pmp$execute_with_command_file (target_ring, program_description, parameters, command_file, osc$nowait,
            TRUE, named_task^.id, named_task^.status, status);

      IF NOT status.normal THEN
        clp$delete_named_task_entry (task_name);
        RETURN;
      IFEND;
      task_id := named_task^.id;
    IFEND;

  PROCEND clp$execute_named_task;
?? TITLE := 'create_named_task_entry', EJECT ??

  PROCEDURE create_named_task_entry
    (    task_name: ost$name;
         named_task_group_list: ^^clt$named_task;
     VAR named_task: ^clt$named_task;
     VAR status: ost$status);

    VAR
      current_task_id: pmt$task_id,
      new_named_task: ^clt$named_task,
      new_named_task_node: ^^clt$named_task;


    status.normal := TRUE;

    pmp$get_task_id (current_task_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    new_named_task_node := named_task_group_list;
    named_task := new_named_task_node^;

  /search/
    WHILE named_task <> NIL DO
      IF named_task^.name = task_name THEN
        IF named_task^.status.complete THEN
          named_task^.status.complete := FALSE;
          named_task^.status.status.normal := TRUE;
          named_task^.parent_task_id := current_task_id;
          RETURN;
        IFEND;
        osp$set_status_abnormal ('CL', cle$task_name_in_use, task_name, status);
        RETURN;
      ELSE
        IF (named_task^.status.complete) AND
           (named_task^.status.status.normal) THEN
          new_named_task_node^ := named_task^.link;
          FREE named_task IN osv$task_shared_heap^;
          named_task := new_named_task_node^;
        ELSE
          new_named_task_node := ^named_task^.link;
          named_task := new_named_task_node^;
        IFEND;
      IFEND;
    WHILEND /search/;

    ALLOCATE new_named_task IN osv$task_shared_heap^;

    new_named_task^.link := new_named_task_node^;
    new_named_task^.name := task_name;
    new_named_task^.status.complete := FALSE;
    new_named_task^.status.status.normal := TRUE;
    new_named_task^.parent_task_id := current_task_id;

    new_named_task_node^ := new_named_task;
    named_task := new_named_task;

  PROCEND create_named_task_entry;
?? TITLE := 'clp$find_nt_group_list_first', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$find_nt_group_list_first
    (VAR named_task_list: ^^clt$named_task);

    VAR
      block_status: ost$status,
      task_block: ^clt$block;

    clp$find_task_block (task_block, block_status);
    IF NOT block_status.normal THEN
      osp$system_error ('Unable to get pointer to SCL Task Block.', ^block_status);
      RETURN;
    IFEND;

    WHILE task_block^.synchronous_with_parent DO
      task_block := task_block^.parent;
    WHILEND;

    clv$named_task_group_list := ^task_block^.named_task_list;
    named_task_list := clv$named_task_group_list;

  PROCEND clp$find_nt_group_list_first;
?? TITLE := 'clp$fetch_named_task_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$fetch_named_task_entry
    (    task_name: ost$name;
     VAR named_task: clt$named_task);

    VAR
      named_task_group_list: ^^clt$named_task,
      named_task_entry: ^clt$named_task,
      ignore_status: ost$status;

    clp$find_named_task_group_list (named_task_group_list);

    named_task_entry := named_task_group_list^;
    WHILE named_task_entry <> NIL DO
      IF named_task_entry^.name = task_name THEN
        named_task := named_task_entry^;
        RETURN;
      IFEND;
      named_task_entry := named_task_entry^.link;
    WHILEND;

    named_task.link := NIL;
    named_task.name := osc$null_name;
    named_task.status.complete := TRUE;
    named_task.status.status.normal := TRUE;

    pmp$get_task_id (named_task.parent_task_id, ignore_status);

  PROCEND clp$fetch_named_task_entry;
?? TITLE := 'clp$get_task_status', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$get_task_status
    (    task_name: clt$task_name_reference;
     VAR task_status: pmt$task_status;
     VAR status: ost$status);

    VAR
      local_task_name: ost$name,
      named_task: clt$named_task;

    status.normal := TRUE;

    #TRANSLATE (osv$lower_to_upper, task_name, local_task_name);
    clp$fetch_named_task_entry (local_task_name, named_task);

    task_status := named_task.status;

  PROCEND clp$get_task_status;
?? TITLE := 'clp$delete_named_task_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$delete_named_task_entry
    (    task_name: ost$name);

    VAR
      named_task_group_list: ^^clt$named_task,
      named_task: ^clt$named_task;

    clp$find_named_task_group_list (named_task_group_list);

    named_task := named_task_group_list^;
    WHILE named_task <> NIL DO
      IF named_task^.name = task_name THEN
        named_task_group_list^ := named_task^.link;
        FREE named_task IN osv$task_shared_heap^;
        RETURN;
      IFEND;
      named_task_group_list := ^named_task^.link;
      named_task := named_task^.link;
    WHILEND;

  PROCEND clp$delete_named_task_entry;

MODEND clm$named_task_manager;
*DECK DECK=CLM$NUMERIC_OPERATIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Numeric (Arithmetic) Operations' ??
MODULE clm$numeric_operations;

{
{ PURPOSE:
{   This module contains the procedures that perform various numeric
{   (arithmetic) operations.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$max_integer
*copyc clc$min_integer
*copyc cle$bad_data_value
*copyc cle$ecc_parsing
*copyc cle$unexpected_call_to
*copyc clt$data_value
*copyc clt$data_kinds
*copyc clt$parameter_list
*copyc clt$work_area
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*IF NOT $true(osv$unix)
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_integer
*copyc clp$convert_real_to_string
*copyc clp$convert_string_to_real
*copyc clp$dtod
*copyc clp$dtoi
*copyc clp$evaluate_parameters
*copyc clp$itod
*copyc clp$itoi
*copyc clp$i_convert_string_to_integer
*copyc clp$longreal_classify
*copyc clp$longreal_compare
*copyc clp$longreal_compare_gt
*copyc clp$longreal_compare_le
*copyc clp$longreal_compare_ne
*copyc clp$make_boolean_value
*copyc clp$make_clt$integer_value
*copyc clp$make_clt$real_value
*copyc clp$make_integer_value
*copyc clp$make_real_value
*copyc clp$make_string_value
*copyc clv$max_integer_as_real
*copyc clv$max_real
*copyc clv$min_integer_as_real
*copyc clv$min_real
*copyc clv$negative_infinity
*copyc clv$positive_infinity
*copyc clv$real_one
*copyc clv$real_zero
*copyc mlp$convert_float_to_intege
*copyc mlp$convert_integer_to_float
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$append_status_real
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
?? TITLE := 'clp$$indefinite', EJECT ??

  PROCEDURE [XDCL] clp$$indefinite
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$indefinite) $indefinite (
{   real_number: real = $required
{   )

?? 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$real_type_qualifier,
      recend,
    recend := [
    [1,
    [90, 4, 9, 14, 36, 49, 770],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$INDEFINITE'], [
    ['REAL_NUMBER                    ',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, 35, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$real_type],
    [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
    [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$real_number = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      real_indefinite: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    real_indefinite := (clp$longreal_classify (pvt [p$real_number].value^.real_value.value) =
          clc$real_indefinite);
    clp$make_boolean_value (real_indefinite, clc$true_false_boolean, work_area, result);

  PROCEND clp$$indefinite;
?? TITLE := 'clp$$infinite', EJECT ??

  PROCEDURE [XDCL] clp$$infinite
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$infinite) $infinite (
{   real_number: real = $required
{   )

?? 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$real_type_qualifier,
      recend,
    recend := [
    [1,
    [90, 4, 9, 14, 37, 2, 83],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$INFINITE'], [
    ['REAL_NUMBER                    ',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, 35, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$real_type],
    [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
    [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$real_number = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      real_number_class: clt$real_number_class;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    real_number_class := clp$longreal_classify (pvt [p$real_number].value^.real_value.value);
    clp$make_boolean_value ((real_number_class = clc$real_positive_infinite) OR
          (real_number_class = clc$real_negative_infinite), clc$true_false_boolean, work_area, result);

  PROCEND clp$$infinite;
?? TITLE := 'clp$$infinity', EJECT ??

  PROCEDURE [XDCL] clp$$infinity
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$infinity) $infinity

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [90, 4, 9, 14, 37, 12, 251],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$INFINITY']];

?? FMT (FORMAT := ON) ??
?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_real_value (clv$positive_infinity^, clc$max_real_number_digits, work_area, result);

  PROCEND clp$$infinity;
?? TITLE := 'clp$$integer', EJECT ??

  PROCEDURE [XDCL] clp$$integer
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$integer) $integer (
{   source: any of
{       string
{       real
{       boolean
{       integer
{     anyend = $required
{   default_radix: integer 2..16 = 10
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$real_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
        recend,
        type_size_4: clt$type_specification_size,
        element_type_spec_4: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (2),
      recend,
    recend := [
    [1,
    [90, 4, 9, 14, 37, 27, 61],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$INTEGER'], [
    ['DEFAULT_RADIX                  ',clc$nominal_entry, 2],
    ['SOURCE                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 94, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [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, 20,
  clc$optional_default_parameter, 0, 2]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$boolean_type, clc$integer_type, clc$real_type,
    clc$string_type],
    TRUE, 4],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
    35, [[1, 0, clc$real_type],
      [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
      [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]]
      ],
    3, [[1, 0, clc$boolean_type]],
    20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]]
    ],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [2, 16, 10],
    '10']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$source = 1,
      p$default_radix = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      int_value: clt$integer,
      integer_value: integer,
      local_status: ost$status,
      real_value: clt$real;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE pvt [p$source].value^.kind OF
    = clc$boolean =
      IF pvt [p$source].value^.boolean_value.value THEN
        integer_value := 1;
      ELSE
        integer_value := 0;
      IFEND;
      clp$make_integer_value (integer_value, 10, FALSE, work_area, result);
    = clc$integer =
      result := pvt [p$source].value;
    = clc$real =
      clp$convert_real_to_integer (pvt [p$source].value^.real_value.value, integer_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$make_integer_value (integer_value, 10, FALSE, work_area, result);
    = clc$string =
      clp$i_convert_string_to_integer (pvt [p$source].value^.string_value^,
            pvt [p$default_radix].value^.integer_value.value, int_value, status);
      IF NOT status.normal THEN
        clp$convert_string_to_real (pvt [p$source].value^.string_value^, real_value, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
        clp$convert_real_to_integer (real_value.value, int_value.value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      clp$make_clt$integer_value (int_value, work_area, result);
    ELSE
      ;
    CASEND;

  PROCEND clp$$integer;
?? TITLE := 'clp$$integer_string', EJECT ??

  PROCEDURE [XDCL] clp$$integer_string
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$integer_string) $integer_string (
{   integer: integer = $required
{   radix: integer 2..16 = 10
{   include_radix: boolean = no
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (2),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (2),
      recend,
    recend := [
    [1,
    [90, 4, 9, 14, 37, 50, 348],
    clc$function, 3, 3, 1, 0, 0, 0, 0, 'OSM$$INTEGER_STRING'], [
    ['INCLUDE_RADIX                  ',clc$nominal_entry, 3],
    ['INTEGER                        ',clc$nominal_entry, 1],
    ['RADIX                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, 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, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, 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, 20,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 3
    [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, 3,
  clc$optional_default_parameter, 0, 2]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [2, 16, 10],
    '10'],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'no']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$integer = 1,
      p$radix = 2,
      p$include_radix = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      integer_string: ost$string;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (pvt [p$integer].value^.integer_value.value,
          pvt [p$radix].value^.integer_value.value, pvt [p$include_radix].value^.boolean_value.value,
          integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_string_value (integer_string.value (1, integer_string.size), work_area, result);

  PROCEND clp$$integer_string;
?? TITLE := 'clp$$max', EJECT ??

  PROCEDURE [XDCL] clp$$max
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$max) $max (
{   numbers: list rest of any of
{       integer
{       real
{     anyend = $required
{   )

?? 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$list_type_qualifier_v2,
        element_type_spec: 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$integer_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$real_type_qualifier,
          recend,
        recend,
      recend,
    recend := [
    [1,
    [90, 4, 10, 13, 54, 10, 886],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$MAX'], [
    ['NUMBERS                        ',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, 91, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [75, 1, clc$max_list_size, 0, FALSE, TRUE],
      [[1, 0, clc$union_type], [[clc$integer_type, clc$real_type],
      TRUE, 2],
      20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
      35, [[1, 0, clc$real_type],
        [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
        [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]]
        ]
      ]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$numbers = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      node: ^clt$data_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    result := pvt [p$numbers].value^.element_value;
    node := pvt [p$numbers].value^.link;

    WHILE node <> NIL DO
      IF clp$number_compare (node^.element_value^, result^) = clc$left_is_greater THEN
        result := node^.element_value;
      IFEND;
      node := node^.link;
    WHILEND;

  PROCEND clp$$max;
?? TITLE := 'clp$$max_integer', EJECT ??

  PROCEDURE [XDCL] clp$$max_integer
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$max_integer) $max_integer

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [90, 4, 9, 14, 38, 2, 496],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$MAX_INTEGER']];

?? FMT (FORMAT := ON) ??
?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_integer_value (clc$max_integer, 10, FALSE, work_area, result);

  PROCEND clp$$max_integer;
?? TITLE := 'clp$$max_real', EJECT ??

  PROCEDURE [XDCL] clp$$max_real
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$max_real) $max_real

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [90, 4, 9, 14, 38, 19, 392],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$MAX_REAL']];

?? FMT (FORMAT := ON) ??
?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_real_value (clv$max_real^, clc$max_real_number_digits, work_area, result);

  PROCEND clp$$max_real;
?? TITLE := 'clp$$min', EJECT ??

  PROCEDURE [XDCL] clp$$min
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$min) $min (
{   numbers: list rest of any of
{       integer
{       real
{     anyend = $required
{   )

?? 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$list_type_qualifier_v2,
        element_type_spec: 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$integer_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$real_type_qualifier,
          recend,
        recend,
      recend,
    recend := [
    [1,
    [90, 4, 10, 13, 54, 34, 124],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$MIN'], [
    ['NUMBERS                        ',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, 91, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [75, 1, clc$max_list_size, 0, FALSE, TRUE],
      [[1, 0, clc$union_type], [[clc$integer_type, clc$real_type],
      TRUE, 2],
      20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
      35, [[1, 0, clc$real_type],
        [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
        [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]]
        ]
      ]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$numbers = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      node: ^clt$data_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    result := pvt [p$numbers].value^.element_value;
    node := pvt [p$numbers].value^.link;

    WHILE node <> NIL DO
      IF clp$number_compare (node^.element_value^, result^) = clc$right_is_greater THEN
        result := node^.element_value;
      IFEND;
      node := node^.link;
    WHILEND;

  PROCEND clp$$min;
?? TITLE := 'clp$$min_integer', EJECT ??

  PROCEDURE [XDCL] clp$$min_integer
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$min_integer) $min_integer

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [90, 4, 9, 14, 40, 33, 457],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$MIN_INTEGER']];

?? FMT (FORMAT := ON) ??
?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_integer_value (clc$min_integer, 10, FALSE, work_area, result);

  PROCEND clp$$min_integer;
?? TITLE := 'clp$$min_real', EJECT ??

  PROCEDURE [XDCL] clp$$min_real
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$min_real) $min_real

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [90, 4, 9, 14, 40, 48, 471],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$MIN_REAL']];

?? FMT (FORMAT := ON) ??
?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_real_value (clv$min_real^, clc$max_real_number_digits, work_area, result);

  PROCEND clp$$min_real;
?? TITLE := 'clp$$mod', EJECT ??

  PROCEDURE [XDCL] clp$$mod
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$mod) $mod (
{   a: integer = $required
{   b: integer = $required
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
    recend := [
    [1,
    [90, 4, 9, 14, 40, 59, 716],
    clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$MOD'], [
    ['A                              ',clc$nominal_entry, 1],
    ['B                              ',clc$nominal_entry, 2]],
    [
{ 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, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, 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, 20, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$a = 1,
      p$b = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$b].value^.integer_value.value = 0) THEN
      osp$set_status_abnormal ('CL', cle$param_expr_not_union_type, pdt.
            names [p$b].name, status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            pvt [p$b].value^.integer_value.value, 10, false, status);
      RETURN;
    IFEND;

    NEXT result IN work_area;

    clp$perform_numeric_operation ('$MOD', pvt [p$a].value^, pvt [p$b].value^, result^, status);

  PROCEND clp$$mod;
?? TITLE := 'clp$$real', EJECT ??

  PROCEDURE [XDCL] clp$$real
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$real) $real (
{   source: any of
{       string
{       integer
{       real
{     anyend = $required
{   )

?? 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$real_type_qualifier,
        recend,
      recend,
    recend := [
    [1,
    [90, 4, 9, 14, 41, 54, 881],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$REAL'], [
    ['SOURCE                         ',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, 87, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type, clc$real_type, clc$string_type],
    TRUE, 3],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
    20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
    35, [[1, 0, clc$real_type],
      [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
      [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]]
      ]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$source = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      int_value: clt$integer,
      local_status: ost$status,
      real_value: clt$real;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE pvt [p$source].value^.kind OF
    = clc$integer =
      clp$convert_integer_to_real (pvt [p$source].value^.integer_value.value, real_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$make_clt$real_value (real_value, work_area, result);
    = clc$real =
      result := pvt [p$source].value;
    = clc$string =
      clp$convert_string_to_real (pvt [p$source].value^.string_value^, real_value, status);
      IF NOT status.normal THEN
        clp$i_convert_string_to_integer (pvt [p$source].value^.string_value^, 10, int_value, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
        clp$convert_integer_to_real (int_value.value, real_value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      clp$make_clt$real_value (real_value, work_area, result);
    ELSE
      ;
    CASEND;

  PROCEND clp$$real;
?? TITLE := 'clp$$real_string', EJECT ??

  PROCEDURE [XDCL] clp$$real_string
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$real_string) $real_string (
{   real_number: real = $required
{   max_digits: integer 1..28 = 28
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$real_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (2),
      recend,
    recend := [
    [1,
    [90, 4, 9, 14, 42, 4, 889],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$REAL_STRING'], [
    ['MAX_DIGITS                     ',clc$nominal_entry, 2],
    ['REAL_NUMBER                    ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 35, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [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, 20,
  clc$optional_default_parameter, 0, 2]],
{ PARAMETER 1
    [[1, 0, clc$real_type],
    [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
    [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]]
    ],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, 28, 10],
    '28']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$real_number = 1,
      p$max_digits = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      real_string: ost$string;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_real_to_string (pvt [p$real_number].value^.real_value.value,
          pvt [p$max_digits].value^.integer_value.value, real_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_string_value (real_string.value (1, real_string.size), work_area, result);

  PROCEND clp$$real_string;
?? TITLE := 'clp$$sum', EJECT ??

  PROCEDURE [XDCL] clp$$sum
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sum) $sum (
{   numbers: list rest 0..clc$max_list_size of any of
{       integer
{       real
{     anyend = $required
{   )

?? 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$list_type_qualifier_v2,
        element_type_spec: 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$integer_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$real_type_qualifier,
          recend,
        recend,
      recend,
    recend := [
    [1,
    [90, 4, 10, 13, 55, 14, 984],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$SUM'], [
    ['NUMBERS                        ',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, 91, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [75, 0, clc$max_list_size, 0, FALSE, TRUE],
      [[1, 0, clc$union_type], [[clc$integer_type, clc$real_type],
      TRUE, 2],
      20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
      35, [[1, 0, clc$real_type],
        [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
        [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]]
        ]
      ]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$numbers = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      intermediate: clt$data_value,
      node: ^clt$data_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$numbers].value^.element_value = NIL THEN
      clp$make_integer_value (0, 10, FALSE, work_area, result);
      RETURN;
    IFEND;

    NEXT result IN work_area;
    result^ := pvt [p$numbers].value^.element_value^;
    node := pvt [p$numbers].value^.link;

    WHILE node <> NIL DO
      intermediate := result^;
      clp$perform_numeric_operation ('+', intermediate, node^.element_value^, result^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      node := node^.link;
    WHILEND;

  PROCEND clp$$sum;
?? TITLE := 'clp$convert_integer_to_real', EJECT ??

  PROCEDURE [XDCL] clp$convert_integer_to_real
    (    integer_number: integer;
     VAR real_number: clt$real;
     VAR status: ost$status);

    VAR
      ignore_conversion_status: mlt$error;

    VAR
      c: 0 .. clc$max_real_number_digits,
      d: -10 .. 10,
      n: integer;


    status.normal := TRUE;

    IF integer_number = clc$min_integer THEN
      real_number.value := clv$min_integer_as_real^;
    ELSE
      mlp$convert_integer_to_float (^integer_number, #SIZE (integer), mlc$signed_integer, ^real_number.value,
            mlc$double_precision, ignore_conversion_status);
    IFEND;

{ Count the number of decimal digits in the integer.

    n := integer_number;
    c := $INTEGER (n = 0);
    IF n < 0 THEN
      d := -10;
    ELSE
      d := 10;
    IFEND;
    WHILE n <> 0 DO
      n := n DIV d;
      c := c + 1;
    WHILEND;
    real_number.number_of_digits := c;

  PROCEND clp$convert_integer_to_real;
?? TITLE := 'clp$convert_real_to_integer', EJECT ??

  PROCEDURE [XDCL] clp$convert_real_to_integer
    (    real_number: longreal;
     VAR integer_number: integer;
     VAR status: ost$status);

    VAR
      ignore_conversion_status: mlt$error;


    status.normal := TRUE;

    CASE clp$longreal_compare (real_number, clv$min_integer_as_real^, clc$infinities_equal) OF

    = clc$equal =
      integer_number := clc$min_integer;

    = clc$right_is_greater, clc$unordered =
      osp$set_status_condition (cle$real_greater_than_integer, status);
      osp$append_status_real (osc$status_parameter_delimiter, real_number, clc$max_real_number_digits,
            status);
      RETURN;

    ELSE {clc$left_is_greater}

      IF clp$longreal_compare_gt (real_number, clv$max_integer_as_real^) THEN
        osp$set_status_condition (cle$real_greater_than_integer, status);
        osp$append_status_real (osc$status_parameter_delimiter, real_number, clc$max_real_number_digits,
              status);
        RETURN;
      IFEND;

      mlp$convert_float_to_integer (^real_number, mlc$double_precision, ^integer_number, #SIZE (integer),
            mlc$signed_integer, ignore_conversion_status);
    CASEND;

  PROCEND clp$convert_real_to_integer;
*ELSE
*copyc osp$set_status_abnormal
*copyc clt$comparison_result
*IFEND
?? TITLE := 'clp$number_compare', EJECT ??

  FUNCTION [XDCL] clp$number_compare
    (    left_operand: clt$data_value;
         right_operand: clt$data_value): clt$comparison_result;

    VAR
      left_real: clt$real,
      right_real: clt$real,
      status: ost$status;


    IF (left_operand.kind = clc$integer) AND (right_operand.kind = clc$integer) THEN
      IF left_operand.integer_value.value < right_operand.integer_value.value THEN
        clp$number_compare := clc$right_is_greater;
      ELSEIF left_operand.integer_value.value = right_operand.integer_value.value THEN
        clp$number_compare := clc$equal;
      ELSE
        clp$number_compare := clc$left_is_greater;
      IFEND;
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    CASE left_operand.kind OF
    = clc$integer =
      clp$convert_integer_to_real (left_operand.integer_value.value, left_real, status);
      IF NOT status.normal THEN
        clp$number_compare := clc$unordered;
        RETURN;
      IFEND;
    = clc$real =
      left_real := left_operand.real_value;
    ELSE
*IFEND
      clp$number_compare := clc$unordered;
*IF NOT $true(osv$unix)
      RETURN;
    CASEND;

    CASE right_operand.kind OF
    = clc$integer =
      clp$convert_integer_to_real (right_operand.integer_value.value, right_real, status);
      IF NOT status.normal THEN
        clp$number_compare := clc$unordered;
        RETURN;
      IFEND;
    = clc$real =
      right_real := right_operand.real_value;
    ELSE
      clp$number_compare := clc$unordered;
      RETURN;
    CASEND;

    clp$number_compare := clp$longreal_compare (left_real.value, right_real.value, clc$infinities_unordered);
*IFEND

  FUNCEND clp$number_compare;
?? TITLE := 'clp$perform_numeric_operation', EJECT ??

  PROCEDURE [XDCL] clp$perform_numeric_operation
    (    operator: string ( * <= osc$max_name_size);
         left_operand: clt$data_value;
         right_operand: clt$data_value;
     VAR result: clt$data_value;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
    TYPE
      clt$longreal_results_table = array [clt$real_number_class] of array [clt$real_number_class] of
            ^^longreal;

    VAR
      arithmetic_conditions: [STATIC, READ, oss$job_paged_literal] pmt$system_conditions :=
            [pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow, pmc$exponent_underflow,
            pmc$fp_significance_loss, pmc$fp_indefinite, pmc$arithmetic_significance],
      left_real: clt$real,
      operation_successful: boolean,
      result_table: ^clt$longreal_results_table,
      right_real: clt$real;

?? NEWTITLE := 'Tables of results for longreal operations that produce system conditions.', EJECT ??

{ The following variables are used to look up results for longreal arithmetic
{ operations when those operations produce system conditions.
{ A NIL table entry indicates the result is undefined (indefinite) and that an
{ error should be generated.
{ A non-NIL table entry should be used unless: 1) a divide fault occurred, in
{ which case the table entry should be treated as NIL, or 2) an underflow
{ condition occurred, in which case the result should be zero.

?? FMT (FORMAT := OFF) ??

    VAR
      longreal_add_error_results: [STATIC, READ, oss$job_paged_literal] clt$longreal_results_table := [

{    \ right    INDEFINITE              -INFINITY               -number    }
{left \         ZERO                    +number                 +INFINITY  }

{INDEFINITE}   [NIL,                    NIL,                    NIL,
                NIL,                    NIL,                    NIL],

{ -INFINITY}   [NIL,                    ^clv$negative_infinity, ^clv$negative_infinity,
                ^clv$negative_infinity, ^clv$negative_infinity, NIL],

{   -number}   [NIL,                    ^clv$negative_infinity, ^clv$negative_infinity,
                NIL,                    NIL,                    ^clv$positive_infinity],

{      ZERO}   [NIL,                    ^clv$negative_infinity, NIL,
                ^clv$real_zero,         NIL,                    ^clv$positive_infinity],

{   +number}   [NIL,                    ^clv$negative_infinity, NIL,
                NIL,                    ^clv$positive_infinity, ^clv$positive_infinity],

{ +INFINITY}   [NIL,                    NIL,                    ^clv$positive_infinity,
                ^clv$positive_infinity, ^clv$positive_infinity, ^clv$positive_infinity]];

?? EJECT ??

    VAR
      longreal_divide_error_results: [STATIC, READ, oss$job_paged_literal] clt$longreal_results_table := [

{    \ right    INDEFINITE              -INFINITY               -number    }
{left \         ZERO                    +number                 +INFINITY  }

{INDEFINITE}   [NIL,                    NIL,                    NIL,
                NIL,                    NIL,                    NIL],

{ -INFINITY}   [NIL,                    NIL,                    ^clv$positive_infinity,
                NIL,                    ^clv$negative_infinity, NIL],

{   -number}   [NIL,                    ^clv$real_zero,         ^clv$positive_infinity,
                NIL,                    ^clv$negative_infinity, ^clv$real_zero],

{      ZERO}   [NIL,                    ^clv$real_zero,         ^clv$real_zero,
                NIL,                    ^clv$real_zero,         ^clv$real_zero],

{   +number}   [NIL,                    ^clv$real_zero,         ^clv$negative_infinity,
                NIL,                    ^clv$positive_infinity, ^clv$real_zero],

{ +INFINITY}   [NIL,                    NIL,                    ^clv$negative_infinity,
                NIL,                    ^clv$positive_infinity, NIL]];

?? EJECT ??

    VAR
      longreal_exponent_error_results: [STATIC, READ, oss$job_paged_literal] clt$longreal_results_table := [

{    \ right    INDEFINITE              -INFINITY               -number    }
{left \         ZERO                    +number                 +INFINITY  }

{INDEFINITE}   [NIL,                    NIL,                    NIL,
                NIL,                    NIL,                    NIL],

{ -INFINITY}   [NIL,                    NIL,                    NIL,
                NIL,                    NIL,                    NIL],

{   -number}   [NIL,                    NIL,                    NIL,
                NIL,                    NIL,                    NIL],

{      ZERO}   [NIL,                    NIL,                    NIL,
                NIL,                    ^clv$real_zero,         NIL],

{   +number}   [NIL,                    ^clv$real_zero,         ^clv$real_zero,
                ^clv$real_one,          ^clv$positive_infinity, ^clv$positive_infinity],

{ +INFINITY}   [NIL,                    ^clv$real_zero,         ^clv$real_zero,
                NIL,                    ^clv$positive_infinity, ^clv$positive_infinity]];

?? EJECT ??

    VAR
      longreal_multiply_error_results: [STATIC, READ, oss$job_paged_literal] clt$longreal_results_table := [

{    \ right    INDEFINITE              -INFINITY               -number    }
{left \         ZERO                    +number                 +INFINITY  }

{INDEFINITE}   [NIL,                    NIL,                    NIL,
                NIL,                    NIL,                    NIL],

{ -INFINITY}   [NIL,                    ^clv$positive_infinity, ^clv$positive_infinity,
                NIL,                    ^clv$negative_infinity, ^clv$negative_infinity],

{   -number}   [NIL,                    ^clv$positive_infinity, ^clv$positive_infinity,
                ^clv$real_zero,         ^clv$negative_infinity, ^clv$negative_infinity],

{      ZERO}   [NIL,                    NIL,                    ^clv$real_zero,
                ^clv$real_zero,         ^clv$real_zero,         NIL],

{   +number}   [NIL,                    ^clv$negative_infinity, ^clv$negative_infinity,
                ^clv$real_zero,         ^clv$positive_infinity, ^clv$positive_infinity],

{ +INFINITY}   [NIL,                    ^clv$negative_infinity, ^clv$negative_infinity,
                NIL,                    ^clv$positive_infinity, ^clv$positive_infinity]];

?? EJECT ??

    VAR
      longreal_subtract_error_results: [STATIC, READ, oss$job_paged_literal] clt$longreal_results_table := [

{    \ right    INDEFINITE              -INFINITY               -number    }
{left \         ZERO                    +number                 +INFINITY  }

{INDEFINITE}   [NIL,                    NIL,                    NIL,
                NIL,                    NIL,                    NIL],

{ -INFINITY}   [NIL,                    NIL,                    ^clv$negative_infinity,
                ^clv$negative_infinity, ^clv$negative_infinity, ^clv$negative_infinity],

{   -number}   [NIL,                    ^clv$positive_infinity, NIL,
                NIL,                    ^clv$negative_infinity, ^clv$negative_infinity],

{      ZERO}   [NIL,                    ^clv$positive_infinity, NIL,
                ^clv$real_zero,         NIL,                    ^clv$negative_infinity],

{   +number}   [NIL,                    ^clv$positive_infinity, ^clv$positive_infinity,
                NIL,                    NIL,                    ^clv$negative_infinity],

{ +INFINITY}   [NIL,                    ^clv$positive_infinity, ^clv$positive_infinity,
                ^clv$positive_infinity, ^clv$positive_infinity, NIL]];

?? FMT (FORMAT := ON) ??
*IFEND
?? TITLE := 'bad_call', EJECT ??

    PROCEDURE [INLINE] bad_call;


      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$perform_numeric_operation', status);
      EXIT clp$perform_numeric_operation;

    PROCEND bad_call;
*IF NOT $true(osv$unix)
?? TITLE := 'convert_integer_value_to_real', EJECT ??

    PROCEDURE [INLINE] convert_integer_value_to_real
      (    integer_value: clt$data_value;
       VAR real_number: clt$real);


      clp$convert_integer_to_real (integer_value.integer_value.value, real_number, status);
      IF NOT status.normal THEN
        EXIT clp$perform_numeric_operation;
      IFEND;

    PROCEND convert_integer_value_to_real;
?? TITLE := 'perform_exponentiate', EJECT ??

    PROCEDURE perform_exponentiate;

      VAR
        comparison_result: clt$comparison_result,
        left_eq_zero: boolean,
        left_lt_zero: boolean,
        right_le_zero: boolean;

?? NEWTITLE := 'itoi', EJECT ??

      PROCEDURE itoi;

?? NEWTITLE := 'integer_arithmetic_cond_handler', EJECT ??

        PROCEDURE integer_arithmetic_cond_handler
          (    condition: pmt$condition;
               ignore_info: ^pmt$condition_information;
               save_area: ^ost$stack_frame_save_area;
           VAR handler_status: ost$status);


          IF (condition.selector = pmc$system_conditions) AND
                ((arithmetic_conditions * condition.system_conditions) <> $pmt$system_conditions []) THEN
            operation_successful := FALSE;
            EXIT itoi;
          IFEND;

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

        PROCEND integer_arithmetic_cond_handler;
?? OLDTITLE, EJECT ??

        osp$establish_condition_handler (^integer_arithmetic_cond_handler, FALSE);

        result.kind := clc$integer;
        result.integer_value.value := clp$itoi (left_operand.integer_value.value,
              right_operand.integer_value.value);
        result.integer_value.radix := left_operand.integer_value.radix;
        result.integer_value.radix_specified := left_operand.integer_value.radix_specified;

        operation_successful := TRUE;

      PROCEND itoi;
?? TITLE := 'real_arithmetic_cond_handler', EJECT ??

      PROCEDURE real_arithmetic_cond_handler
        (    condition: pmt$condition;
             ignore_info: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);

        VAR
          error_result: ^longreal,
          left_class: clt$real_number_class,
          right_class: clt$real_number_class;

?? NEWTITLE := 'classify_integer_as_real', EJECT ??

        FUNCTION [INLINE] classify_integer_as_real
          (    integer_value: integer): clt$real_number_class;


          IF integer_value < 0 THEN
            classify_integer_as_real := clc$real_negative_standard;
          ELSEIF integer_value = 0 THEN
            classify_integer_as_real := clc$real_zero;
          ELSE {integer_value > 0}
            classify_integer_as_real := clc$real_positive_standard;
          IFEND;

        FUNCEND classify_integer_as_real;
?? OLDTITLE, EJECT ??

        IF (condition.selector = pmc$system_conditions) AND
              ((arithmetic_conditions * condition.system_conditions) <> $pmt$system_conditions []) THEN
          IF left_operand.kind = clc$integer THEN
            left_class := classify_integer_as_real (left_operand.integer_value.value);
          ELSE
            left_class := clp$longreal_classify (left_real.value);
          IFEND;
          IF right_operand.kind = clc$integer THEN
            right_class := classify_integer_as_real (right_operand.integer_value.value);
          ELSE
            right_class := clp$longreal_classify (right_real.value);
          IFEND;
          set_longreal_condition_result ($pmt$system_conditions [],
                longreal_exponent_error_results [left_class] [right_class], error_result);
          IF error_result = NIL THEN
            set_arithmetic_condition (operator, $pmt$system_conditions []);
            EXIT clp$perform_numeric_operation;
          IFEND;
          result.real_value.value := error_result^;
          EXIT perform_exponentiate;
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      PROCEND real_arithmetic_cond_handler;
?? OLDTITLE, EJECT ??

      IF left_operand.kind = clc$real THEN
        left_real := left_operand.real_value;

      ELSEIF right_operand.kind = clc$integer THEN
        IF ((left_operand.integer_value.value = 0) AND (right_operand.integer_value.value <= 0)) OR
              (left_operand.integer_value.value < -1) THEN
          set_arithmetic_condition (operator, $pmt$system_conditions []);
          EXIT clp$perform_numeric_operation;
        IFEND;
        IF right_operand.integer_value.value >= 0 THEN
          itoi;
          IF operation_successful THEN
            RETURN;
          IFEND;
        IFEND;
        convert_integer_value_to_real (left_operand, left_real);

      ELSE
        right_le_zero := clp$longreal_compare_le (right_operand.real_value.value, clv$real_zero^);
        IF ((left_operand.integer_value.value = 0) AND right_le_zero) OR
              (left_operand.integer_value.value < 0) THEN
          set_arithmetic_condition (operator, $pmt$system_conditions []);
          EXIT clp$perform_numeric_operation;
        IFEND;
        right_real := right_operand.real_value;
        result.kind := clc$real;
        result.real_value.number_of_digits := clc$max_real_number_digits;
        osp$establish_condition_handler (^real_arithmetic_cond_handler, FALSE);
        result.real_value.value := clp$itod (left_operand.integer_value.value, right_real.value);
        RETURN;
      IFEND;

      result.kind := clc$real;
      result.real_value.number_of_digits := clc$max_real_number_digits;
      comparison_result := clp$longreal_compare (left_real.value, clv$real_zero^, clc$infinities_equal);
      left_eq_zero := comparison_result = clc$equal;
      left_lt_zero := comparison_result = clc$right_is_greater;

      IF right_operand.kind = clc$integer THEN
        IF (left_eq_zero AND (right_operand.integer_value.value <= 0)) OR left_lt_zero THEN
          set_arithmetic_condition (operator, $pmt$system_conditions []);
          EXIT clp$perform_numeric_operation;
        IFEND;
        osp$establish_condition_handler (^real_arithmetic_cond_handler, FALSE);
        result.real_value.value := clp$dtoi (left_real.value, right_operand.integer_value.value);

      ELSE
        right_le_zero := clp$longreal_compare_le (right_operand.real_value.value, clv$real_zero^);
        IF (left_eq_zero AND right_le_zero) OR left_lt_zero THEN
          set_arithmetic_condition (operator, $pmt$system_conditions []);
          EXIT clp$perform_numeric_operation;
        IFEND;
        right_real := right_operand.real_value;
        osp$establish_condition_handler (^real_arithmetic_cond_handler, FALSE);
        result.real_value.value := clp$dtod (left_real.value, right_real.value);
      IFEND;

    PROCEND perform_exponentiate;
*IFEND
?? TITLE := 'perform_integer_operation', EJECT ??

    PROCEDURE perform_integer_operation;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'integer_arithmetic_cond_handler', EJECT ??

      PROCEDURE integer_arithmetic_cond_handler
        (    condition: pmt$condition;
             ignore_info: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);


        IF (condition.selector = pmc$system_conditions) AND
              ((arithmetic_conditions * condition.system_conditions) <> $pmt$system_conditions []) THEN
          operation_successful := FALSE;
          EXIT perform_integer_operation;
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      PROCEND integer_arithmetic_cond_handler;
?? OLDTITLE, EJECT ??
*IFEND

      result.kind := clc$integer;

*IF NOT $true(osv$unix)
      osp$establish_condition_handler (^integer_arithmetic_cond_handler, FALSE);
*IFEND

      CASE operator (1) OF

      = '+' =
        IF left_operand.kind = clc$unspecified THEN
          result.integer_value.value := right_operand.integer_value.value;
        ELSE
          result.integer_value.value := left_operand.integer_value.value + right_operand.integer_value.value;
        IFEND;

      = '-' =
        IF left_operand.kind = clc$unspecified THEN
          result.integer_value.value := -right_operand.integer_value.value;
        ELSE
          result.integer_value.value := left_operand.integer_value.value - right_operand.integer_value.value;
        IFEND;

      = '*' =
        result.integer_value.value := left_operand.integer_value.value * right_operand.integer_value.value;

      = '/' =
        result.integer_value.value := left_operand.integer_value.value DIV right_operand.integer_value.value;

      ELSE {$MOD}
        result.integer_value.value := left_operand.integer_value.value MOD right_operand.integer_value.value;
      CASEND;

      result.integer_value.radix := left_operand.integer_value.radix;
      result.integer_value.radix_specified := left_operand.integer_value.radix_specified;

*IF NOT $true(osv$unix)
      operation_successful := TRUE;
*IFEND

    PROCEND perform_integer_operation;
*IF NOT $true(osv$unix)
?? TITLE := 'perform_real_operation', EJECT ??

    PROCEDURE perform_real_operation;

?? NEWTITLE := 'real_arithmetic_cond_handler', EJECT ??

      PROCEDURE real_arithmetic_cond_handler
        (    condition: pmt$condition;
             ignore_info: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);

        VAR
          error_result: ^longreal;


        IF (condition.selector = pmc$system_conditions) AND
              ((arithmetic_conditions * condition.system_conditions) <> $pmt$system_conditions []) THEN
          set_longreal_condition_result (condition.system_conditions,
                result_table^ [clp$longreal_classify (left_real.value)]
                [clp$longreal_classify (right_real.value)], error_result);
          IF error_result = NIL THEN
            set_arithmetic_condition (operator, condition.system_conditions);
            EXIT clp$perform_numeric_operation;
          IFEND;
          result.real_value.value := error_result^;
          EXIT perform_real_operation;
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      PROCEND real_arithmetic_cond_handler;
?? OLDTITLE, EJECT ??

      result.kind := clc$real;
      result.real_value.number_of_digits := clc$max_real_number_digits;

      osp$establish_condition_handler (^real_arithmetic_cond_handler, FALSE);

      CASE operator (1) OF

      = '+' =
        IF left_operand.kind = clc$unspecified THEN
          result.real_value.value := right_real.value;
          result.real_value.number_of_digits := right_real.number_of_digits;
        ELSE
          result.real_value.value := left_real.value + right_real.value;
          IF (left_real.number_of_digits + right_real.number_of_digits) < clc$max_real_number_digits THEN
            result.real_value.number_of_digits := left_real.number_of_digits + right_real.number_of_digits;
          IFEND;
        IFEND;

      = '-' =
        IF left_operand.kind = clc$unspecified THEN
          result.real_value.value := -right_real.value;
          result.real_value.number_of_digits := right_real.number_of_digits;
        ELSE
          result.real_value.value := left_real.value - right_real.value;
          IF (left_real.number_of_digits + right_real.number_of_digits) < clc$max_real_number_digits THEN
            result.real_value.number_of_digits := left_real.number_of_digits + right_real.number_of_digits;
          IFEND;
        IFEND;

      = '*' =
        result.real_value.value := left_real.value * right_real.value;

      = '/' =
        result.real_value.value := left_real.value / right_real.value;

      ELSE {$MOD}
        bad_call;
      CASEND;

    PROCEND perform_real_operation;
?? TITLE := 'set_arithmetic_condition', EJECT ??

{
{ PURPOSE:
{   This routine is used to "translate" hardware arithmetic conditions into
{   the corresponding SCL status.
{ NOTE:
{   The status condition cle$exponentiate_fault has no hardware equivalent
{   and so is indicated to this routine by an empty user conditions set.
{

    PROCEDURE set_arithmetic_condition
      (    operator: string ( * <= osc$max_name_size);
           user_conditions: pmt$system_conditions);

      VAR
        status_condition: ost$status_condition;

?? NEWTITLE := 'append_number', EJECT ??

      PROCEDURE [INLINE] append_number
        (    delimiter: char;
             value: clt$data_value);


        IF value.kind = clc$integer THEN
          osp$append_status_integer (delimiter, value.integer_value.value, value.integer_value.radix,
                value.integer_value.radix_specified, status);
        ELSE
          osp$append_status_real (delimiter, value.real_value.value, value.real_value.number_of_digits,
                status);
        IFEND;

      PROCEND append_number;
?? OLDTITLE, EJECT ??

      IF pmc$divide_fault IN user_conditions THEN
        status_condition := cle$divide_fault;
      ELSEIF pmc$arithmetic_overflow IN user_conditions THEN
        status_condition := cle$arithmetic_overflow;
      ELSEIF pmc$exponent_overflow IN user_conditions THEN
        status_condition := cle$exponent_overflow;
      ELSEIF pmc$exponent_underflow IN user_conditions THEN
        status_condition := cle$exponent_underflow;
      ELSEIF pmc$fp_indefinite IN user_conditions THEN
        status_condition := cle$fp_indefinite;
      ELSEIF pmc$arithmetic_significance IN user_conditions THEN
        status_condition := cle$arithmetic_significance;
      ELSEIF pmc$fp_significance_loss IN user_conditions THEN
        status_condition := cle$fp_significance_loss;
      ELSE
        status_condition := cle$exponentiate_fault;
      IFEND;

      osp$set_status_condition (status_condition, status);

      IF operator (1) = '$' THEN {function}
        IF left_operand.kind = clc$unspecified THEN {unary}
          osp$append_status_parameter (osc$status_parameter_delimiter, operator, status);
          append_number ('(', right_operand);
          osp$append_status_parameter (')', '', status);
        ELSE {binary}
          osp$append_status_parameter (osc$status_parameter_delimiter, operator, status);
          append_number ('(', left_operand);
          append_number (',', right_operand);
          osp$append_status_parameter (')', '', status);
        IFEND;
      ELSE {operator}
        IF left_operand.kind = clc$unspecified THEN {unary}
          osp$append_status_parameter (osc$status_parameter_delimiter, operator, status);
          append_number (' ', right_operand);
        ELSE {binary}
          append_number (osc$status_parameter_delimiter, left_operand);
          osp$append_status_parameter (' ', operator, status);
          append_number (' ', right_operand);
        IFEND;
      IFEND;

    PROCEND set_arithmetic_condition;
?? TITLE := 'set_longreal_condition_result', EJECT ??

{
{ PURPOSE:
{   This procedure is used to establish the proper result of a longreal
{   arithmetic operation that produced a system condition.
{   The USER_CONDITIONS parameter represents the hardware detected conditions
{   resulting from the attempted operation.
{   The CANDIDATE_RESULT is looked up in the appropriate table given the
{   "class" of the left and right operands.
{   If the RESULT is returned as NIL, an error should be generated (using
{   set_arithmetic_condition).
{   A non-NIL RESULT should be used as the operation's result.
{

    PROCEDURE [INLINE] set_longreal_condition_result
      (    user_conditions: pmt$system_conditions;
           candidate_result: ^^longreal;
       VAR result: ^longreal);


      IF (candidate_result = NIL) OR (pmc$divide_fault IN user_conditions) THEN
        result := NIL;
      ELSEIF pmc$exponent_underflow IN user_conditions THEN
        result := clv$real_zero;
      ELSE
        result := candidate_result^;
      IFEND;

    PROCEND set_longreal_condition_result;
*IFEND
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    IF (NOT (left_operand.kind IN $clt$data_kinds [clc$integer, clc$real, clc$unspecified])) OR
          (NOT (right_operand.kind IN $clt$data_kinds [clc$integer, clc$real])) THEN
      bad_call;
    IFEND;

*IF NOT $true(osv$unix)
    result_table := NIL;
*IFEND

    IF operator = '**' THEN
*IF NOT $true(osv$unix)
      IF left_operand.kind = clc$unspecified THEN
*IFEND
        bad_call;
*IF NOT $true(osv$unix)
      IFEND;
      perform_exponentiate;
*IFEND
      RETURN;
    IFEND;

    IF operator = '+' THEN
*IF NOT $true(osv$unix)
      result_table := ^longreal_add_error_results;
*ELSE
      ;
*IFEND
    ELSEIF operator = '-' THEN
*IF NOT $true(osv$unix)
      result_table := ^longreal_subtract_error_results;
*ELSE
      ;
*IFEND
    ELSEIF operator = '*' THEN
      IF left_operand.kind = clc$unspecified THEN
        bad_call;
      IFEND;
*IF NOT $true(osv$unix)
      result_table := ^longreal_multiply_error_results;
*IFEND
    ELSEIF operator = '/' THEN
      IF left_operand.kind = clc$unspecified THEN
        bad_call;
      IFEND;
*IF NOT $true(osv$unix)
      result_table := ^longreal_divide_error_results;
*IFEND
    ELSEIF operator = '$MOD' THEN
      IF left_operand.kind = clc$unspecified THEN
        bad_call;
      IFEND;
    ELSE
      bad_call;
    IFEND;

*IF $true(osv$unix)
    IF (left_operand.kind = clc$integer) OR (right_operand.kind = clc$integer) THEN
*ELSE
    IF (left_operand.kind = clc$integer) AND (right_operand.kind = clc$integer) THEN
*IFEND
      perform_integer_operation;
*IF NOT $true(osv$unix)
      IF operation_successful THEN
        RETURN;
      IFEND;
*IFEND
    IFEND;

*IF NOT $true(osv$unix)
    CASE left_operand.kind OF
    = clc$real =
      left_real := left_operand.real_value;
    = clc$integer =
      convert_integer_value_to_real (left_operand, left_real);
    ELSE {clc$unspecified}
      ;
    CASEND;

    IF right_operand.kind = clc$real THEN
      right_real := right_operand.real_value;
    ELSE {clc$integer}
      convert_integer_value_to_real (right_operand, right_real);
    IFEND;

    perform_real_operation;
*IFEND

  PROCEND clp$perform_numeric_operation;

MODEND clm$numeric_operations;
*DECK DECK=CLM$OPERATOR_COMMANDS EXPAND=TRUE
table clv$operator_commands type=command section_name=oss$job_paged_literal scope=xdcl ..
      m=clm$operator_commands
command (activate_set                   ,actset) stp$activate_set_command xref
command (begin_production_environment   ) avp$begin_production_environ xref hidden
command (change_class_attribute         ,change_class_attributes,  chaca) jmp$change_class_attr_cmnd xref
command (change_job_name_counter        ) jmp$change_job_name_counter xref
command (change_operating_system_name   ,chaosn) osp$_change_operating_system_na xref
command (change_scheduler_table         ,chast) jmp$change_scheduler_table_cmnd xref
command (change_secure_logging          ,chasl) clp$change_secure_logging xref
command (change_validation_level              ) avp$change_validation_level xref
command (clear_mass_storage_faults      ,clemsf) osp$clear_disk_faults xref hidden
command (dsp$commit_new_system          ) dsp$commit_new_system xref hidden
command (create_job_class               ,crejc) jmp$create_job_class_command xref
command (debug_network_pp               ) nap$debug_network_pp xref hidden
command (define_family_set              ,deffs) stp$define_family_set xref hidden
command (delete_job_class               ,deljc) jmp$delete_job_class_command xref
command (display_class_attribute        ,display_class_attributes,  disca) jmp$display_class_attribute_cmd xref
command (display_mass_storage           ,disms) dmp$display_mass_store_command xref
command (display_scheduler_table        ,disst) jmp$display_sch_table xref
command (idle_jobs                      ) clp$idle_jobs_command xref
command (inject_hardware_fault          ,injhf) syp$start_injhf_task xref hidden
command (install_deadstart_file         ,insdf) dsp$install_deadstart_file xref a=hidden
command (request_mass_storage           ,reqms) rmp$request_mass_storage_cmd xref
command (resume_jobs                    ) clp$resume_jobs_command xref
command (set_mass_storage_fault         ,setmsf) osp$simulate_disk_fault xref hidden
command (wait_for_system_idle           , waifsi) jmp$wait_system_idle_comnd xref
tablend
*DECK DECK=CLM$OUTPUT_TO_SYSTEM_FILES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Output routines for System Files' ??
MODULE clm$output_to_system_files;

{
{ PURPOSE:
{   This module contains procedures that write a line to a "system file".
{   A "system file" is one that, for certain operations, is (implicitly) opened the first time it is used
{   in a task, has that instance of open used for subsequent accesses in that task, and is closed as part
{   of task termination.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc clc$system_messages_module
*copyc clt$interpreter_modes
*copyc cyt$string_size
*copyc fst$file_reference
*copyc fst$path_element_size
*copyc oss$job_paged_literal
*copyc ost$name_reference
*copyc ost$status
?? POP ??
*copyc amp$put_next
*copyc clp$fetch_system_file_id
*copyc clp$store_system_file_id
*copyc clp$trimmed_string_size
*IF NOT $true(osv$unix)
*copyc clv$system_messages_module
*ELSE
*copyc clp$get_screen_mode
*copyc osp_screen_output
*copyc csp$output_window
*copyc clv$standard_files
*IFEND
*copyc fsp$open_file
*IF NOT $true(osv$unix)
*copyc osp$find_param_assist_prompt
*copyc osp$find_help_module
*copyc osp$format_help_message
*copyc osp$generate_log_message
*IFEND
*copyc osp$get_status_condition_name
*copyc osp$get_status_condition_string
*copyc osv$lower_to_upper
*IF NOT $true(osv$unix)
*copyc pmp$log
*IFEND
?? TITLE := 'clp$get_system_file_id', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$get_system_file_id
    (    file_name: amt$local_file_name;
     VAR file_id: amt$file_identifier;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
    CONST
      path_prefix = ':$LOCAL.',
      path_prefix_size = 8,
      path_cycle = '.1',
      path_cycle_size = 2,
      path_size = path_prefix_size + osc$max_name_size + path_cycle_size;
*IFEND

    VAR
      file_attachment: [STATIC, READ, oss$job_paged_literal] array [1 .. 4] of fst$attachment_option := [
            {} [fsc$create_file, TRUE],
            {} [fsc$open_position, amc$open_no_positioning],
            {} [fsc$access_and_share_modes, {} [fsc$specific_access_modes, [fsc$append, fsc$shorten]],
            {} [fsc$specific_share_modes, []]],
            {} [fsc$open_share_modes, [fsc$read, fsc$shorten, fsc$append, fsc$modify, fsc$execute]]],
      file_id_defined: boolean;

    VAR
*IF NOT $true(osv$unix)
      file: string (path_size),
*IFEND
      file_name_size: fst$path_element_size;


    status.normal := TRUE;
    clp$fetch_system_file_id (file_name, file_id, file_id_defined);
    IF NOT file_id_defined THEN
*IF NOT $true(osv$unix)
      file := ' ';
      file_name_size := clp$trimmed_string_size (file_name);
      file (1, path_prefix_size) := path_prefix;
      file (path_prefix_size + 1, file_name_size) := file_name;
      file (path_prefix_size + 1 + file_name_size, path_cycle_size) := path_cycle;
      fsp$open_file (file, amc$record, ^file_attachment, NIL, NIL, NIL, NIL, file_id, status);
*ELSE
      fsp$open_file (file_name, amc$record, ^file_attachment,
            file_id, status);
*IFEND
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$store_system_file_id (file_name, file_id);
    IFEND;

  PROCEND clp$get_system_file_id;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$put_echoed_commands', EJECT ??

  PROCEDURE [INLINE] clp$put_echoed_commands
    (    text: ^string ( * );
     VAR status: ost$status);

    VAR
      file_id: amt$file_identifier,
      ignore_byte_address: amt$file_byte_address,
      ignore_status: ^ost$status;


    clp$get_system_file_id (clc$echoed_commands, file_id, status);
    IF status.normal THEN
      amp$put_next (file_id, text, clp$trimmed_string_size (text^), ignore_byte_address, status);
    IFEND;

    IF NOT status.normal THEN
      PUSH ignore_status;
      pmp$log (' --  Attempt to write the following line to $ECHO failed:', ignore_status^);
      pmp$log (text^, ignore_status^);
      pmp$log (' --  The reason for the failure was:', ignore_status^);
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status^);
      status.normal := TRUE;
    IFEND;

  PROCEND clp$put_echoed_commands;
?? TITLE := 'clp$echo_command', EJECT ??

  PROCEDURE [XDCL] clp$echo_command
    (    interpreter_mode: clt$interpreter_modes;
         command: string ( * );
     VAR status: ost$status);

    CONST
      echo_header_size = 4;

    VAR
      line: ^string ( * ),
      line_size: cyt$string_size;


    status.normal := TRUE;

    IF (echo_header_size + STRLENGTH (command)) > cyc$max_string_size THEN
      line_size := cyc$max_string_size;
    ELSE
      line_size := echo_header_size + STRLENGTH (command);
    IFEND;
    PUSH line: [line_size];
    IF interpreter_mode = clc$interpret_mode THEN
      line^ (1, echo_header_size) := ' CI ' {Command Interpret} ;
    ELSE
      line^ (1, echo_header_size) := ' CS ' {Command Skip} ;
    IFEND;
    line^ (echo_header_size + 1, * ) := command;

    clp$put_echoed_commands (line, status);

  PROCEND clp$echo_command;
?? TITLE := 'clp$echo_trace_information', EJECT ??

  PROCEDURE [XDCL] clp$echo_trace_information
    (    message_name: ost$name_reference;
         identifying_name: ^ost$name_reference;
         file_reference: ^fst$file_reference;
         message_status: ^ost$status;
     VAR status: ost$status);

    VAR
      ignore_natural_language: ost$natural_language,
      ignore_online_manual_name: ost$online_manual_name,
      message: ^ost$status_message,
      message_line_count: ^ost$status_message_line_count,
      message_parameters: array [1 .. 3] of ^ost$message_parameter,
      message_status_name: ost$status_condition_name,
      message_status_string: ^ost$string,
      message_template: ^ost$message_template,
      message_text: ^ost$status_message_line,
      message_text_size: ^ost$status_message_line_size,
      no_identifying_name: [STATIC, READ, oss$job_paged_literal] string (4) := 'none',
      normal_status: [STATIC, READ, oss$job_paged_literal] string (6) := 'normal',
      system_messages_module: ^ost$help_module,
      translated_message_name: ost$name;


    osp$find_help_module (clc$system_messages_module, system_messages_module, ignore_online_manual_name,
          ignore_natural_language, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF system_messages_module = NIL THEN
      IF clv$system_messages_module = NIL THEN
        RETURN;
      IFEND;
      system_messages_module := clv$system_messages_module;
    IFEND;

    #TRANSLATE (osv$lower_to_upper, message_name, translated_message_name);
    osp$find_param_assist_prompt (system_messages_module, translated_message_name, message_template, status);
    IF (NOT status.normal) OR (message_template = NIL) THEN
      RETURN;
    IFEND;

    IF (identifying_name = NIL) OR (identifying_name^ = '') THEN
      message_parameters [1] := ^no_identifying_name;
    ELSE
      message_parameters [1] := identifying_name;
    IFEND;
    message_parameters [2] := file_reference;
    IF (message_status = NIL) OR message_status^.normal THEN
      message_parameters [3] := ^normal_status;
    ELSE
      osp$get_status_condition_name (message_status^.condition, message_status_name, status);
      IF status.normal AND (message_status_name <> 'UNKNOWN_CONDITION') THEN
        message_parameters [3] := ^message_status_name;
      ELSE
        PUSH message_status_string;
        message_status_string^.size := 0;
        osp$get_status_condition_string (message_status^.condition, message_status_string^, status);
        status.normal := TRUE;
        message_parameters [3] := ^message_status_string^.value (1, message_status_string^.size);
      IFEND;
    IFEND;

      PUSH message;

    osp$format_help_message (message_template, ^message_parameters, osc$max_status_message_line, message^,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET message;
    NEXT message_line_count IN message;
    NEXT message_text_size IN message;
    NEXT message_text: [message_text_size^] IN message;

    clp$put_echoed_commands (message_text, status);

  PROCEND clp$echo_trace_information;
*IFEND
?? TITLE := 'clp$put_error_output', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$put_error_output
    (    text: string ( * );
     VAR status: ost$status);

    VAR
      file_id: amt$file_identifier,
      ignore_byte_address: amt$file_byte_address;


    clp$get_system_file_id (clc$error_output, file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$put_next (file_id, ^text, STRLENGTH (text), ignore_byte_address, status);

  PROCEND clp$put_error_output;
?? TITLE := 'clp$put_job_output', EJECT ??
*copy clh$put_job_output

  PROCEDURE [XDCL, #GATE] clp$put_job_output
    (    text: string ( * );
     VAR status: ost$status);

    VAR
      file_id: amt$file_identifier,
*IF $true(osv$unix)
      attachment_option: array [1 .. 1] of fst$attachment_option,
      in_screen_mode: boolean,
      length: ost_c_integer,
      screen_output: ost_c_fixed_string,
*IFEND
      ignore_byte_address: amt$file_byte_address;


*IF $true(osv$unix)
    clp$get_screen_mode (in_screen_mode);
    IF in_screen_mode THEN
      attachment_option [1].selector := fsc$access_and_share_modes;
      attachment_option [1].access_modes.selector := fsc$specific_access_modes;
      attachment_option [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
      osp_screen_output (screen_output, length);
      IF length < 1 THEN
{???
        RETURN;
      IFEND;
      fsp$open_file (screen_output(1, length), amc$record, ^attachment_option, file_id, status);
    ELSE
*IFEND
    clp$get_system_file_id (clc$job_output, file_id, status);
*IF $true(osv$unix)
    IFEND;
*IFEND
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$put_next (file_id, ^text, STRLENGTH (text), ignore_byte_address, status);
*IF $true(osv$unix)
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF in_screen_mode THEN
      csp_output_window;
    IFEND;
*IFEND
  PROCEND clp$put_job_output;
?? TITLE := 'clp$put_job_command_response', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$put_job_command_response
    (    text: string ( * );
     VAR status: ost$status);

    VAR
      file_id: amt$file_identifier,
*IF $true(osv$unix)
      attachment_option: array [1 .. 1] of fst$attachment_option,
      in_screen_mode: boolean,
      length: ost_c_integer,
      screen_output: ost_c_fixed_string,
*IFEND
      ignore_byte_address: amt$file_byte_address;


*IF NOT $true(osv$unix)
    clp$get_system_file_id (clc$job_command_response, file_id, status);
*ELSE
    clp$get_screen_mode (in_screen_mode);
    IF in_screen_mode THEN
      attachment_option [1].selector := fsc$access_and_share_modes;
      attachment_option [1].access_modes.selector := fsc$specific_access_modes;
      attachment_option [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
      osp_screen_output (screen_output, length);
      IF length < 1 THEN
{???
        RETURN;
      IFEND;
      fsp$open_file (screen_output(1, length), amc$record, ^attachment_option, file_id, status);
    ELSE
    clp$get_system_file_id (clc$job_output, file_id, status);
    IFEND;
*IFEND
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$put_next (file_id, ^text, STRLENGTH (text), ignore_byte_address, status);
*IF $true(osv$unix)
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF in_screen_mode THEN
      csp_output_window;
    IFEND;
*IFEND

  PROCEND clp$put_job_command_response;

MODEND clm$output_to_system_files;
*DECK DECK=CLM$PARAMETER_ACCESS_FUNCTIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : PROC parameter accessing functions' ??
MODULE clm$parameter_access_functions;

{
{ PURPOSE:
{   This module contains the "built-in" functions used to access the parameters of an SCL PROC.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc cle$bad_data_value
*copyc cle$not_supported
*copyc cle$unexpected_value_type
*copyc clt$name
*copyc clt$work_area
*copyc clv$value_descriptors
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$get_proc_parameter
*copyc clp$get_proc_parameter_list
*copyc clp$get_proc_set_count
*copyc clp$get_proc_value_count
*copyc clp$get_proc_value_kind
*copyc clp$make_boolean_value
*copyc clp$make_integer_value
*copyc clp$make_string_value
*copyc clp$test_proc_parameter
*copyc clp$test_proc_range
*copyc osp$append_status_parameter
*copyc clp$append_status_value_type
*copyc osp$set_status_abnormal

?? TITLE := 'clp$$specified', EJECT ??

  PROCEDURE [XDCL] clp$$specified
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$specified) $specified (
{   parameter: data_name = $required
{   )

?? PUSH (LISTEXT := ON) ??

  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,
      recend,
    recend := [
    [1,
    [87, 11, 8, 13, 23, 55, 445],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$SPECIFIED'], [
    ['PARAMETER                      ',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, 3, clc$required_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]]];

?? POP ??

    CONST
      p$parameter = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      parameter_specified: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$test_proc_parameter (pvt [p$parameter].value^.data_name_value, parameter_specified, status);
    IF status.normal THEN
      clp$make_boolean_value (parameter_specified, clc$true_false_boolean, work_area, result);
    IFEND;

  PROCEND clp$$specified;
?? TITLE := 'clp$$set_count', EJECT ??

  PROCEDURE [XDCL] clp$$set_count
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$set_count) $set_count (
{   parameter: data_name = $required
{   )

?? PUSH (LISTEXT := ON) ??

  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,
      recend,
    recend := [
    [1,
    [87, 11, 8, 13, 25, 57, 609],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$SET_COUNT'], [
    ['PARAMETER                      ',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, 3, clc$required_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]]];

?? POP ??

    CONST
      p$parameter = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      value_set_count: 0 .. clc$max_value_sets;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_proc_set_count (pvt [p$parameter].value^.data_name_value, work_area, value_set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$make_integer_value (value_set_count, 10, FALSE, work_area, result);

  PROCEND clp$$set_count;
?? TITLE := 'clp$$value_count', EJECT ??

  PROCEDURE [XDCL] clp$$value_count
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$value_count) $value_count (
{   parameter: data_name = $required
{   value_set_number: integer 1 .. clc$max_value_sets = 1
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
    recend := [
    [1,
    [87, 11, 8, 13, 28, 56, 295],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$VALUE_COUNT'], [
    ['PARAMETER                      ',clc$nominal_entry, 1],
    ['VALUE_SET_NUMBER               ',clc$nominal_entry, 2]],
    [
{ 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, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, 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, 20,
  clc$optional_default_parameter, 0, 1]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, clc$max_value_sets, 10],
    '1']];

?? POP ??

    CONST
      p$parameter = 1,
      p$value_set_number = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      value_count: 0 .. clc$max_values_per_set;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_proc_value_count (pvt [p$parameter].value^.data_name_value,
          pvt [p$value_set_number].value^.integer_value.value, work_area, value_count, status);
    IF status.normal THEN
      clp$make_integer_value (value_count, 10, FALSE, work_area, result);
    IFEND;

  PROCEND clp$$value_count;
?? TITLE := 'clp$$range', EJECT ??

  PROCEDURE [XDCL] clp$$range
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$range) $range (
{   parameter: data_name = $required
{   value_set_number: integer 1 .. clc$max_value_sets = 1
{   value_number: integer 1 .. clc$max_values_per_set = 1
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
    recend := [
    [1,
    [87, 11, 8, 13, 32, 9, 876],
    clc$function, 3, 3, 1, 0, 0, 0, 0, 'OSM$$RANGE'], [
    ['PARAMETER                      ',clc$nominal_entry, 1],
    ['VALUE_NUMBER                   ',clc$nominal_entry, 3],
    ['VALUE_SET_NUMBER               ',clc$nominal_entry, 2]],
    [
{ 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, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, 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, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [2, 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, 20,
  clc$optional_default_parameter, 0, 1]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, clc$max_value_sets, 10],
    '1'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, clc$max_values_per_set, 10],
    '1']];

?? POP ??

    CONST
      p$parameter = 1,
      p$value_set_number = 2,
      p$value_number = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      range_specified: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$test_proc_range (pvt [p$parameter].value^.data_name_value,
          pvt [p$value_set_number].value^.integer_value.value, pvt [p$value_number].value^.integer_value.
          value, work_area, range_specified, status);
    IF status.normal THEN
      clp$make_boolean_value (range_specified, clc$true_false_boolean, work_area, result);
    IFEND;

  PROCEND clp$$range;
?? TITLE := 'clp$$value_kind', EJECT ??

  PROCEDURE [XDCL] clp$$value_kind
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);


{ FUNCTION (osm$$value_kind) $value_kind (
{   parameter: data_name = $required
{   value_set_number: integer 1 .. clc$max_value_sets = 1
{   value_number: integer 1 .. clc$max_values_per_set = 1
{   range_specification: key
{       low, high
{     keyend = low
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (3),
      recend,
    recend := [
    [1,
    [87, 11, 8, 13, 33, 5, 802],
    clc$function, 4, 4, 1, 0, 0, 0, 0, 'OSM$$VALUE_KIND'], [
    ['PARAMETER                      ',clc$nominal_entry, 1],
    ['RANGE_SPECIFICATION            ',clc$nominal_entry, 4],
    ['VALUE_NUMBER                   ',clc$nominal_entry, 3],
    ['VALUE_SET_NUMBER               ',clc$nominal_entry, 2]],
    [
{ 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, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, 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, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [3, 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, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [2, 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, 81,
  clc$optional_default_parameter, 0, 3]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, clc$max_value_sets, 10],
    '1'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, clc$max_values_per_set, 10],
    '1'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [2], [
    ['HIGH                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['LOW                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'low']];

?? POP ??

    CONST
      p$parameter = 1,
      p$value_set_number = 2,
      p$value_number = 3,
      p$range_specification = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      low_or_high: [STATIC, READ, oss$job_paged_literal] array [boolean] of
            clt$low_or_high := [clc$low, clc$high];


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_proc_value_kind (pvt [p$parameter].value^.data_name_value,
          pvt [p$value_set_number].value^.integer_value.value, pvt [p$value_number].value^.integer_value.
          value, low_or_high [pvt [p$range_specification].value^.keyword_value = 'HIGH'], work_area, result,
          status);

  PROCEND clp$$value_kind;
?? TITLE := 'clp$$parameter', EJECT ??

  PROCEDURE [XDCL] clp$$parameter
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$parameter) $parameter (
{   parameter: data_name = $required
{   )

?? PUSH (LISTEXT := ON) ??

  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,
      recend,
    recend := [
    [1,
    [87, 11, 8, 13, 34, 3, 242],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$PARAMETER'], [
    ['PARAMETER                      ',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, 3, clc$required_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]]];

?? POP ??

    CONST
      p$parameter = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF status.normal THEN
      clp$get_proc_parameter (pvt [p$parameter].value^.data_name_value, work_area, result, status);
    IFEND;

  PROCEND clp$$parameter;
?? TITLE := 'clp$$parameter_list', EJECT ??

  PROCEDURE [XDCL] clp$$parameter_list
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$parameter_list) $parameter_list

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [87, 10, 20, 15, 4, 31, 353], clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$PARAMETER_LIST']];

?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF status.normal THEN
      clp$get_proc_parameter_list (work_area, result, status);
    IFEND;

  PROCEND clp$$parameter_list;

?? TITLE := 'clp$$max_value_sets', EJECT ??

  PROCEDURE [XDCL] clp$$max_value_sets
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$max_value_sets) $max_value_sets

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [87, 10, 20, 15, 5, 56, 877], clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$MAX_VALUE_SETS']];

?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF status.normal THEN
      clp$make_integer_value (clc$max_value_sets, 10, FALSE, work_area, result);
    IFEND;

  PROCEND clp$$max_value_sets;

?? TITLE := 'clp$$max_values', EJECT ??

  PROCEDURE [XDCL] clp$$max_values
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$max_values) $max_values

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [87, 10, 20, 15, 6, 45, 741], clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$MAX_VALUES']];

?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF status.normal THEN
      clp$make_integer_value (clc$max_values_per_set, 10, FALSE, work_area, result);
    IFEND;

  PROCEND clp$$max_values;

MODEND clm$parameter_access_functions;
*DECK DECK=CLM$PARSE_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Parse Command' ??
MODULE clm$parse_command;

{
{ PURPOSE:
{   This module contains the routines that parse a command image.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$lexical_units_size_pad
*copyc cle$ecc_command_processing
*copyc cle$ecc_file_reference
*copyc cle$ecc_lexical
*copyc cle$ecc_parsing
*IF $true(osv$unix)
*copyc cle$not_supported
*IFEND
*copyc clt$command_line
*copyc clt$command_line_index
*copyc clt$command_line_size
*copyc clt$command_list
*copyc clt$command_reference_form
*copyc clt$file
*copyc clt$lexical_unit_kind
*copyc clt$name
*copyc clt$parse_state
*copyc clt$utility_name
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc clp$append_status_parse_state
*copyc clp$evaluate_command_reference
*copyc clp$get_work_area
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*copyc clp$scan_any_lexical_unit
*copyc clp$scan_non_space_lexical_unit
*copyc clp$scan_unnested_rel_lex_unit
*copyc clp$trimmed_string_size
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper

?? TITLE := 'clp$parse_command', EJECT ??
*copyc clh$parse_command

  PROCEDURE [XDCL, #GATE] clp$parse_command
    (VAR parse {input, output} : clt$parse_state;
     VAR prompting_requested: boolean;
     VAR escaped: boolean;
     VAR label: ost$name;
     VAR command_reference_parse: clt$parse_state;
     VAR file: clt$file;
     VAR form: clt$command_reference_form;
     VAR name: clt$name;
     VAR utility_command_list_entry: ^clt$command_list_entry;
     VAR separator: clt$lexical_unit_kind;
     VAR empty_command: boolean;
     VAR status: ost$status);

    VAR
      command_reference: clt$command_reference,
      command_reference_size: clt$command_line_size,
      local_parse: clt$parse_state,
      parameter_name: clt$parameter_name,
      space_needed_after_colon: boolean,
      work_area: ^^clt$work_area;


    status.normal := TRUE;

    IF parse.unit_is_space THEN
      clp$scan_non_space_lexical_unit (parse);
    IFEND;

    CASE parse.unit.kind OF
    = clc$lex_query =
      prompting_requested := TRUE;
      clp$scan_non_space_lexical_unit (parse);
      escaped := parse.unit.kind = clc$lex_divide;
      IF escaped THEN
        clp$scan_non_space_lexical_unit (parse);
      IFEND;
    = clc$lex_divide =
      prompting_requested := FALSE;
      escaped := TRUE;
      clp$scan_non_space_lexical_unit (parse);
    = clc$lex_end_of_line, clc$lex_semicolon =
      empty_command := TRUE;
      RETURN;
    ELSE
      prompting_requested := FALSE;
      escaped := FALSE;
    CASEND;
    empty_command := FALSE;
    form := clc$name_only_command_ref;
    utility_command_list_entry := NIL;

    label := osc$null_name;
    command_reference_parse := parse;
    IF parse.unit.kind = clc$lex_name THEN
      clp$scan_non_space_lexical_unit (parse);
      IF parse.unit.kind = clc$lex_colon THEN
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.previous_non_space_unit_index,
              parse.previous_non_space_unit.size), label);
        space_needed_after_colon := parse.previous_unit_is_space;
        clp$scan_non_space_lexical_unit (parse);
        IF parse.previous_unit_is_space OR (NOT space_needed_after_colon) THEN
          command_reference_parse := parse;
        ELSE
          label := osc$null_name;
          parse := command_reference_parse;
        IFEND;
      ELSE
        parse := command_reference_parse;
      IFEND;
    IFEND;

    IF parse.unit.kind = clc$lex_long_name THEN
      osp$set_status_abnormal ('CL', cle$name_too_long, parse.text^ (parse.unit_index, parse.unit.size),
            status);
      RETURN;
    IFEND;

    IF parse.unit.kind = clc$lex_equal THEN
      command_reference_parse.index_limit := parse.unit_index;
      command_reference_size := 0;
      separator := clc$lex_equal;
    ELSE
      clp$scan_unnested_rel_lex_unit (parse);
      command_reference_parse.index_limit := parse.unit_index;
      command_reference_size := parse.unit_index - command_reference_parse.unit_index;
      IF parse.unit_is_space THEN
        clp$scan_non_space_lexical_unit (parse);
      IFEND;
      CASE parse.unit.kind OF
      = clc$lex_equal, clc$lex_comma, clc$lex_end_of_line, clc$lex_semicolon =
        separator := parse.unit.kind;
        clp$scan_non_space_lexical_unit (parse);
      ELSE
        IF NOT parse.previous_unit_is_space THEN
          osp$set_status_abnormal ('CL', cle$unexpected_after_command, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          RETURN;
        IFEND;
        separator := clc$lex_space;
      CASEND;
    IFEND;

    IF separator = clc$lex_equal THEN
      IF command_reference_size = 0 THEN
        name.value := 'CASE selection';
        name.size := 14 { STRLENGTH('CASE selection') } ;
      ELSE
        name.value := 'assignment';
        name.size := 10 { STRLENGTH('assignment') } ;
      IFEND;
      RETURN;
    IFEND;

    local_parse := command_reference_parse;
    CASE local_parse.unit.kind OF
    = clc$lex_colon, clc$lex_dot =
      ;
    = clc$lex_name =
      clp$scan_any_lexical_unit (local_parse);
      IF local_parse.unit_index = local_parse.index_limit THEN
        #TRANSLATE (osv$lower_to_upper, local_parse.text^ (local_parse.previous_non_space_unit_index,
              local_parse.previous_non_space_unit.size), name.value);
        name.size := local_parse.previous_non_space_unit.size;
        RETURN;
      IFEND;
    ELSE
*IF $true(osv$unix)
      IF local_parse.text^ (local_parse.unit_index, 1) = '!' THEN
        osp$set_status_abnormal ('CL', cle$epix_command_requested, '', status);
      ELSE
*IFEND
      osp$set_status_abnormal ('CL', cle$expecting_command, local_parse.
            text^ (local_parse.unit_index, command_reference_size), status);
*IF $true(osv$unix)
      IFEND;
*IFEND
      RETURN;
    CASEND;

    local_parse := command_reference_parse;
*IF NOT $true(osv$unix)
    clp$get_work_area (#RING (^work_area), work_area, status);
*ELSE
    clp$get_work_area (osc$user_ring, work_area, status);
*IFEND
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$evaluate_command_reference (local_parse, work_area^, TRUE, file.local_file_name, command_reference,
          utility_command_list_entry, parameter_name, status);
    IF status.normal THEN
      IF parameter_name <> osc$null_name THEN
        osp$set_status_abnormal ('CL', cle$parameter_never_given_value, parameter_name, status);
        RETURN;
      IFEND;
      IF local_parse.unit_index <> local_parse.index_limit THEN
        osp$set_status_abnormal ('CL', cle$unexpected_after_command, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, local_parse, status);
      IFEND;
      form := command_reference.form;
      name.size := clp$trimmed_string_size (command_reference.name);
      name.value := command_reference.name;
*IF $true(osv$unix)
      IF status.normal AND (form <> clc$name_only_command_ref) THEN
        osp$set_status_abnormal ('CL', cle$not_supported,
              'FILE_CYCLE, SYSTEM, UTILITY, and MODULE_OR_FILE command references are', status);
      IFEND;
*IFEND
    ELSEIF status.condition = cle$expecting_file_reference THEN
      status.condition := cle$expecting_command;
    IFEND;

  PROCEND clp$parse_command;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$analyze_command', EJECT ??
*copyc clh$analyze_command

  PROCEDURE [XDCL, #GATE] clp$analyze_command
    (    command_text: ^clt$command_line;
     VAR prompting_requested: boolean;
     VAR escaped: boolean;
     VAR label: ost$name;
     VAR command_reference_index: clt$command_line_index;
     VAR command_reference_size: clt$command_line_size;
     VAR file: clt$file;
     VAR form: clt$command_reference_form;
     VAR name: clt$name;
     VAR utility_name: clt$utility_name;
     VAR parameter_list_index: clt$command_line_index;
     VAR separator: clt$lexical_unit_kind;
     VAR empty_command: boolean;
     VAR status: ost$status);

    VAR
      command_reference_parse: clt$parse_state,
      lexical_units: ^clt$lexical_units,
      lexical_work_area: ^clt$work_area,
      parse: clt$parse_state,
      utility_command_list_entry: ^clt$command_list_entry;


    status.normal := TRUE;

    PUSH lexical_work_area: [[REP STRLENGTH (command_text^) + clc$lexical_units_size_pad OF
          clt$lexical_unit]];

    clp$identify_lexical_units (command_text, lexical_work_area, lexical_units, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$initialize_parse_state (command_text, lexical_units, parse);
    clp$scan_any_lexical_unit (parse);

    clp$parse_command (parse, prompting_requested, escaped, label, command_reference_parse, file, form, name,
          utility_command_list_entry, separator, empty_command, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT empty_command THEN
      command_reference_index := command_reference_parse.unit_index;
      command_reference_size := command_reference_parse.index_limit - command_reference_parse.unit_index;
      IF utility_command_list_entry <> NIL THEN
        utility_name := utility_command_list_entry^.utility_name;
      ELSE
        utility_name := osc$null_name;
      IFEND;
      parameter_list_index := parse.unit_index;
    IFEND;

  PROCEND clp$analyze_command;
*IFEND

MODEND clm$parse_command;
*DECK DECK=CLM$PERMANENT_FILE_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter: Permanent File Commands', ??
MODULE clm$permanent_file_commands;

{
{ PURPOSE:
{   This module contains the processors for all permanent file commands except those that display
{   information about catalogs and files.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc cle$all_must_be_used_alone
*copyc cle$ecc_file_reference
*copyc cle$ecc_parsing
*copyc cle$incompatible_params_given
*copyc cle$none_must_be_used_alone
*copyc cle$redundancy_in_selections
*copyc clt$parameter_list
*copyc fme$file_management_errors
*copyc fsc$local
*copyc fse$path_exception_conditions
*copyc oss$job_paged_literal
*copyc ost$status
*copyc pfe$internal_error_conditions
*copyc rmc$condition_code_limits
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$return
*copyc bap$create_file
*copyc bap$file_command
*copyc bap$get_default_file_attribs
*copyc bap$process_pt_request
*copyc bap$set_attachment_options
*copyc clp$convert_cyc_ref_to_cyc_sel
*copyc clp$convert_file_ref_to_string
*copyc clp$count_list_elements
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc clp$find_current_block
*copyc clp$get_work_area
*copyc clp$verify_time_increment
*copyc fsp$change_catalog_flush_option
*copyc fsp$change_file
*copyc fsp$convert_fs_structure_to_pf
*copyc fsp$flush_catalog
*copyc fsp$path_element
*copyc nfp$check_implicit_access
*copyc nfp$perform_implicit_access
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$set_status_condition
*copyc osp$set_status_abnormal
*copyc osv$initial_exception_context
*copyc osv$lower_to_upper
*copyc pfp$attach
*copyc pfp$change
*copyc pfp$convert_fs_retention_to_int
*copyc pfp$define
*copyc pfp$define_catalog
*copyc pfp$delete_catalog_permit
*copyc pfp$delete_permit
*copyc pfp$permit
*copyc pfp$permit_catalog
*copyc pfp$purge
*copyc pfp$purge_catalog
*copyc pfp$purge_catalog_contents
*copyc rmp$validate_ansi_string

  VAR
    log_select: [STATIC, READ, oss$job_paged_literal] array [boolean] of pft$log := [pfc$no_log, pfc$log],
    wait_select: [STATIC, READ, oss$job_paged_literal] array [boolean] of pft$wait := [pfc$no_wait, pfc$wait];

?? TITLE := 'clp$_create_file', EJECT ??

  PROCEDURE [XDCL] clp$_create_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$cref) create_file, cref (
{   file, f: file = $required
{   local_file_name, lfn: name = $optional
{   password, pw: (SECURE) any of
{       key
{         none
{       keyend
{       name
{     anyend = none
{   retention, r: integer pfc$minimum_retention..pfc$maximum_retention = 999
{   log, l: boolean = false
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 11] of clt$pdt_parameter_name,
        parameters: array [1 .. 6] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type3: 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$name_type_qualifier,
          recend,
          default_value: string (4),
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (3),
        recend,
        type5: record
          header: clt$type_specification_header,
          default_value: string (5),
        recend,
        type6: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 20, 12, 44, 4, 924], clc$command, 11, 6, 1, 0, 0, 0, 6, 'OSM$CREF'],
            [['F                              ', clc$abbreviation_entry, 1],
            ['FILE                           ', clc$nominal_entry, 1],
            ['L                              ', clc$abbreviation_entry, 5],
            ['LFN                            ', clc$abbreviation_entry, 2],
            ['LOCAL_FILE_NAME                ', clc$nominal_entry, 2],
            ['LOG                            ', clc$nominal_entry, 5],
            ['PASSWORD                       ', clc$nominal_entry, 3],
            ['PW                             ', clc$abbreviation_entry, 3],
            ['R                              ', clc$abbreviation_entry, 4],
            ['RETENTION                      ', clc$nominal_entry, 4],
            ['STATUS                         ', clc$nominal_entry, 6]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [7, clc$normal_usage_entry, clc$secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 69, clc$optional_default_parameter, 0, 4],

{ PARAMETER 4

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 3],

{ PARAMETER 5

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 5],

{ PARAMETER 6

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type]],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]], 'none'],

{ PARAMETER 4

      [[1, 0, clc$integer_type], [pfc$minimum_retention, pfc$maximum_retention, 10], '999'],

{ PARAMETER 5

      [[1, 0, clc$boolean_type], 'false'],

{ PARAMETER 6

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$file = 1,
      p$local_file_name = 2,
      p$password = 3,
      p$retention = 4,
      p$log = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      context: ^ost$ecp_exception_context,
      cycle_number: pft$cycle_number,
      cycle_selector: clt$cycle_selector,
      default_file_attributes: bat$static_label_attributes,
      default_new_retention: fst$retention,
      default_new_retention_specified: boolean,
      evaluated_file_reference: fst$evaluated_file_reference,
      existing_file: boolean,
      file_attributes: array [1 .. 1] of amt$get_item,
      first_path_element_is_$local: boolean,
      ignore_contains_data: boolean,
      ignore_local_file: boolean,
      local_file_name: amt$local_file_name,
      log: pft$log,
      password: pft$password,
      pf_path: ^pft$path,
      remote: boolean,
      resolved_path: fst$path,
      retention_value: integer;


    context := NIL;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    evaluate_path_and_handle_remote ('CREATE_FILE', pvt [p$file].value^.file_value^, ^pvt,
          evaluated_file_reference, first_path_element_is_$local, remote, status);
    IF (NOT status.normal) OR remote THEN
      RETURN;
    IFEND;

    IF pvt [p$password].value^.kind = clc$name THEN
      password := pvt [p$password].value^.name_value;
    ELSE { keyword = NONE }
      password := osc$null_name;
    IFEND;

    log := log_select [pvt [p$log].value^.boolean_value.value];

    IF pvt [p$local_file_name].specified THEN
      IF first_path_element_is_$local AND (evaluated_file_reference.number_of_path_elements = 2) AND
            (fsp$path_element (^evaluated_file_reference, 2) ^ <> pvt [p$local_file_name].
            value^.name_value) THEN
        osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_file, '', status);
        RETURN;
      IFEND;
      local_file_name := pvt [p$local_file_name].value^.name_value;
    ELSE
      local_file_name := fsp$path_element (^evaluated_file_reference,
            evaluated_file_reference.number_of_path_elements) ^;
    IFEND;

    IF first_path_element_is_$local THEN
      IF evaluated_file_reference.number_of_path_elements = 1 THEN
        osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_cat, '', status);
      ELSE
        file_attributes [1].key := amc$null_attribute;
        amp$get_file_attributes (pvt [p$file].value^.file_value^, file_attributes, ignore_local_file,
              existing_file, ignore_contains_data, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF existing_file THEN
          osp$set_status_abnormal ('CL', pfe$name_already_permanent_file, pvt [p$file].value^.file_value^,
                status);
          RETURN;
        IFEND;
        REPEAT
          bap$create_file (NIL, NIL, NIL, NIL, evaluated_file_reference, resolved_path, status);
          IF osp$file_access_condition (status) THEN
            IF context = NIL THEN
              PUSH context;
              context^ := osv$initial_exception_context;
              context^.file.selector := osc$ecp_evaluated_file_ref;
              context^.file.evaluated_file_reference := evaluated_file_reference;
            IFEND;
            context^.condition_status := status;
            osp$enforce_exception_policies (context^);
            status := context^.condition_status;
          IFEND;
        UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
      IFEND;
    ELSE
      PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
      fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);
      clp$convert_cyc_ref_to_cyc_sel (evaluated_file_reference.cycle_reference, cycle_selector);
      bap$get_default_file_attribs (default_file_attributes, default_new_retention_specified,
            default_new_retention, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (pvt [p$retention].specified) OR (NOT default_new_retention_specified) THEN
        retention_value := pvt [p$retention].value^.integer_value.value;
      ELSE
        pfp$convert_fs_retention_to_int (default_new_retention, retention_value, status);
        IF (NOT status.normal) OR (retention_value > pfc$maximum_retention) THEN
          retention_value := pfc$maximum_retention;
        IFEND
      IFEND;

      pfp$define (local_file_name, pf_path^, cycle_selector.value, password,
            retention_value, log, status);
    IFEND;

  PROCEND clp$_create_file;
?? TITLE := 'clp$_attach_file', EJECT ??

  PROCEDURE [XDCL] clp$_attach_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$attf) attach_file, attf (
{   file, f: file = $required
{   local_file_name, lfn: name = $optional
{   access_modes, access_mode, am: (BY_NAME) list of key
{       all
{       (append, a)
{       (execute, e)
{       (modify, m)
{       (read, r)
{       (shorten, s)
{       (write, w)
{     keyend = (read, execute)
{   error_exit_procedure_name, een, error_exit_name, eepn: (BY_NAME, ADVANCED) name = $optional
{   error_limit, el: (BY_NAME, ADVANCED) integer 0..65535 = $optional
{   external_vsn, evsn, ev: (BY_NAME, ADVANCED) list of any of
{       string 1..6
{       name 1..6
{     anyend = $optional
{   free_behind, fb: (BY_NAME, ADVANCED) boolean = $optional
{   job_write_concurrency, jwc: (BY_NAME, ADVANCED) boolean = $optional
{   message_control, mc: (BY_NAME, ADVANCED) list of key
{       none
{       (messages, m)
{       (statistics, s)
{       (trivial_errors, t, te)
{     keyend = $optional
{   open_position, op: (BY_NAME) key
{       $asis, $boi, $bop, $eoi
{     keyend = $optional
{   password, pw: (BY_NAME, SECURE) any of
{       key
{         none
{       keyend
{       name
{     anyend = none
{   private_read, pr: (BY_NAME, ADVANCED) boolean = $optional
{   recorded_vsn, rvsn, rv: (BY_NAME, ADVANCED) list of any of
{       string 1..6
{       name 1..6
{     anyend = $optional
{   sequential_access, sa: (BY_NAME, ADVANCED) boolean = $optional
{   share_modes, share_mode, sm: (BY_NAME) list of key
{       all, none
{       (append, a)
{       (execute, e)
{       (modify, m)
{       (read, r)
{       (shorten, s)
{       (write, w)
{     keyend = $optional
{   transfer_size, ts: (BY_NAME, ADVANCED) integer 16384..2147483648 = $optional
{   volume_overflow_allowed, voa: (BY_NAME, ADVANCED) boolean = true
{   wait, w: (BY_NAME) boolean = false
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 43] of clt$pdt_parameter_name,
      parameters: array [1 .. 19] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 13] of clt$keyword_specification,
        recend,
        default_value: string (15),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 8] of clt$keyword_specification,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type11: 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$name_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type12: record
        header: clt$type_specification_header,
      recend,
      type13: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type14: record
        header: clt$type_specification_header,
      recend,
      type15: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type17: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type18: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type19: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 18, 17, 0, 20, 944],
    clc$command, 43, 19, 1, 11, 0, 0, 19, 'OSM$ATTF'], [
    ['ACCESS_MODE                    ',clc$alias_entry, 3],
    ['ACCESS_MODES                   ',clc$nominal_entry, 3],
    ['AM                             ',clc$abbreviation_entry, 3],
    ['EEN                            ',clc$alias_entry, 4],
    ['EEPN                           ',clc$abbreviation_entry, 4],
    ['EL                             ',clc$abbreviation_entry, 5],
    ['ERROR_EXIT_NAME                ',clc$alias_entry, 4],
    ['ERROR_EXIT_PROCEDURE_NAME      ',clc$nominal_entry, 4],
    ['ERROR_LIMIT                    ',clc$nominal_entry, 5],
    ['EV                             ',clc$abbreviation_entry, 6],
    ['EVSN                           ',clc$alias_entry, 6],
    ['EXTERNAL_VSN                   ',clc$nominal_entry, 6],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FB                             ',clc$abbreviation_entry, 7],
    ['FILE                           ',clc$nominal_entry, 1],
    ['FREE_BEHIND                    ',clc$nominal_entry, 7],
    ['JOB_WRITE_CONCURRENCY          ',clc$nominal_entry, 8],
    ['JWC                            ',clc$abbreviation_entry, 8],
    ['LFN                            ',clc$abbreviation_entry, 2],
    ['LOCAL_FILE_NAME                ',clc$nominal_entry, 2],
    ['MC                             ',clc$abbreviation_entry, 9],
    ['MESSAGE_CONTROL                ',clc$nominal_entry, 9],
    ['OP                             ',clc$abbreviation_entry, 10],
    ['OPEN_POSITION                  ',clc$nominal_entry, 10],
    ['PASSWORD                       ',clc$nominal_entry, 11],
    ['PR                             ',clc$abbreviation_entry, 12],
    ['PRIVATE_READ                   ',clc$nominal_entry, 12],
    ['PW                             ',clc$abbreviation_entry, 11],
    ['RECORDED_VSN                   ',clc$nominal_entry, 13],
    ['RV                             ',clc$abbreviation_entry, 13],
    ['RVSN                           ',clc$alias_entry, 13],
    ['SA                             ',clc$abbreviation_entry, 14],
    ['SEQUENTIAL_ACCESS              ',clc$nominal_entry, 14],
    ['SHARE_MODE                     ',clc$alias_entry, 15],
    ['SHARE_MODES                    ',clc$nominal_entry, 15],
    ['SM                             ',clc$abbreviation_entry, 15],
    ['STATUS                         ',clc$nominal_entry, 19],
    ['TRANSFER_SIZE                  ',clc$nominal_entry, 16],
    ['TS                             ',clc$abbreviation_entry, 16],
    ['VOA                            ',clc$abbreviation_entry, 17],
    ['VOLUME_OVERFLOW_ALLOWED        ',clc$nominal_entry, 17],
    ['W                              ',clc$abbreviation_entry, 18],
    ['WAIT                           ',clc$nominal_entry, 18]],
    [
{ PARAMETER 1
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 504,
  clc$optional_default_parameter, 0, 15],
{ PARAMETER 4
    [8, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [9, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [12, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 49, clc$optional_parameter,
  0, 0],
{ PARAMETER 7
    [16, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 8
    [17, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 9
    [22, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 319,
  clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [25, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 12
    [27, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 13
    [29, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 49, clc$optional_parameter,
  0, 0],
{ PARAMETER 14
    [33, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 15
    [35, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 541,
  clc$optional_parameter, 0, 0],
{ PARAMETER 16
    [38, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 17
    [41, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 18
    [43, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 19
    [37, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$list_type], [488, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [13], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['APPEND                         ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['EXECUTE                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['MODIFY                         ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['READ                           ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['SHORTEN                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['WRITE                          ', clc$nominal_entry, clc$normal_usage_entry, 7]]
      ]
    ,
    '(read, execute)'],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [0, 65535, 10]],
{ PARAMETER 6
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
      TRUE, 2],
      8, [[1, 0, clc$string_type], [1, 6, FALSE]],
      5, [[1, 0, clc$name_type], [1, 6]]
      ]
    ],
{ PARAMETER 7
    [[1, 0, clc$boolean_type]],
{ PARAMETER 8
    [[1, 0, clc$boolean_type]],
{ PARAMETER 9
    [[1, 0, clc$list_type], [303, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [8], [
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['MESSAGES                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['STATISTICS                     ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['T                              ', clc$alias_entry, clc$normal_usage_entry, 4],
      ['TE                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['TRIVIAL_ERRORS                 ', clc$nominal_entry, clc$normal_usage_entry, 4]]
      ]
    ],
{ PARAMETER 10
    [[1, 0, clc$keyword_type], [4], [
    ['$ASIS                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['$BOI                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['$BOP                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['$EOI                           ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ],
{ PARAMETER 11
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'none'],
{ PARAMETER 12
    [[1, 0, clc$boolean_type]],
{ PARAMETER 13
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
      TRUE, 2],
      8, [[1, 0, clc$string_type], [1, 6, FALSE]],
      5, [[1, 0, clc$name_type], [1, 6]]
      ]
    ],
{ PARAMETER 14
    [[1, 0, clc$boolean_type]],
{ PARAMETER 15
    [[1, 0, clc$list_type], [525, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [14], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['APPEND                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['EXECUTE                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['MODIFY                         ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['READ                           ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['SHORTEN                        ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
      ['WRITE                          ', clc$nominal_entry, clc$normal_usage_entry, 8]]
      ]
    ],
{ PARAMETER 16
    [[1, 0, clc$integer_type], [16384, 2147483648, 10]],
{ PARAMETER 17
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 18
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 19
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$local_file_name = 2,
      p$access_modes = 3,
      p$error_exit_procedure_name = 4,
      p$error_limit = 5,
      p$external_vsn = 6,
      p$free_behind = 7,
      p$job_write_concurrency = 8,
      p$message_control = 9,
      p$open_position = 10,
      p$password = 11,
      p$private_read = 12,
      p$recorded_vsn = 13,
      p$sequential_access = 14,
      p$share_modes = 15,
      p$transfer_size = 16,
      p$volume_overflow_allowed = 17,
      p$wait = 18,
      p$status = 19;

    VAR
      pvt: array [1 .. 19] of clt$parameter_value;

    CONST
      max_attributes = 4;

    VAR
      access_mode_selections: pft$usage_selections,
      attribute_count: 0 .. max_attributes,
      attribute_index: 0 .. max_attributes + 1,
      attributes: array [1 .. max_attributes] of amt$file_item,
      block: ^clt$block,
      cd_attachment_options: fmt$cd_attachment_options,
      current_evsn: ^clt$data_value,
      current_message: ^clt$data_value,
      current_rvsn: ^clt$data_value,
      cycle_number: pft$cycle_number,
      cycle_selector: clt$cycle_selector,
      evaluated_file_reference: fst$evaluated_file_reference,
      evsn_count: integer,
      file_attributes: array [1 .. 1] of amt$get_item,
      first_path_element_is_$local: boolean,
      ignore_contains_data: boolean,
      ignore_existing_file: boolean,
      ignore_permit: pft$permit_selections,
      ignore_status: ost$status,
      local_file: boolean,
      local_file_name: amt$local_file_name,
      message_control: amt$message_control,
      p_volume_list: ^rmt$volume_list,
      password: pft$password,
      pf_path: ^pft$path,
      rvsn_count: integer,
      share_selections: pft$share_selections,
      share_specified: boolean,
      usage_selections: pft$usage_selections,
      volume_list: ^rmt$volume_list,
      volume_list_index: integer,
      vsn_count: integer,
      vsn_string: string (rmc$external_vsn_size),
      wait: pft$wait,
      work_area: ^^clt$work_area;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    access_mode_selections := $pft$usage_selections [pfc$append, pfc$shorten, pfc$modify];

    IF pvt [p$password].value^.kind = clc$name THEN
      password := pvt [p$password].value^.name_value;
    ELSE { keyword = NONE }
      password := osc$null_name;
    IFEND;

    handle_access_mode_or_share (pvt [p$access_modes].value, select_usage, usage_selections, ignore_permit,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$share_modes].specified THEN
      handle_access_mode_or_share (pvt [p$share_modes].value, select_share, share_selections, ignore_permit,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSEIF (usage_selections * access_mode_selections) <> $pft$usage_selections [] THEN
      share_selections := $pft$share_selections [];
    ELSE
      share_selections := $pft$share_selections [pfc$read, pfc$execute];
    IFEND;

    wait := wait_select [pvt [p$wait].value^.boolean_value.value];

    clp$evaluate_file_reference (pvt [p$file].value^.file_value^, $clt$file_ref_parsing_options [],
          FALSE, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    first_path_element_is_$local := fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local;

    IF pvt [p$local_file_name].specified THEN
      IF first_path_element_is_$local AND (evaluated_file_reference.number_of_path_elements = 2) AND
            (fsp$path_element (^evaluated_file_reference, 2) ^ <> pvt [p$local_file_name].
            value^.name_value) THEN
        osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_file, '', status);
        RETURN;
      IFEND;
      local_file_name := pvt [p$local_file_name].value^.name_value;
    ELSE
      local_file_name := fsp$path_element (^evaluated_file_reference,
            evaluated_file_reference.number_of_path_elements) ^;
    IFEND;

    IF first_path_element_is_$local THEN
      IF evaluated_file_reference.number_of_path_elements = 1 THEN
        osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_cat, '', status);
        RETURN;
      ELSE
        file_attributes [1].key := amc$null_attribute;
        amp$get_file_attributes (pvt [p$file].value^.file_value^, file_attributes, local_file,
              ignore_existing_file, ignore_contains_data, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF NOT local_file THEN
          osp$set_status_abnormal ('CL', cle$name_not_file, local_file_name, status);
          RETURN;
        IFEND;
      IFEND;
    ELSE
      PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
      fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);
      clp$convert_cyc_ref_to_cyc_sel (evaluated_file_reference.cycle_reference, cycle_selector);
      pfp$attach (local_file_name, pf_path^, cycle_selector.value, password, usage_selections,
            share_selections, wait, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    attribute_count := 0;

    IF pvt [p$error_exit_procedure_name].specified THEN
      attribute_count := attribute_count + 1;
      attributes [attribute_count].key := amc$error_exit_name;
      attributes [attribute_count].error_exit_name := pvt [p$error_exit_procedure_name].value^.name_value;
    IFEND;

    IF pvt [p$error_limit].specified THEN
      attribute_count := attribute_count + 1;
      attributes [attribute_count].key := amc$error_limit;
      attributes [attribute_count].error_limit := pvt [p$error_limit].value^.integer_value.value;
    IFEND;

    IF pvt [p$message_control].specified THEN
      attribute_count := attribute_count + 1;
      attributes [attribute_count].key := amc$message_control;
      message_control := $amt$message_control [];
      current_message := pvt [p$message_control].value;

      WHILE current_message <> NIL DO
        IF current_message^.element_value^.keyword_value = 'NONE' THEN
          IF pvt [p$message_control].value^.link <> NIL THEN
            osp$set_status_abnormal ('CL', cle$none_must_be_used_alone, 'MESSAGE_CONTROL', status);
            RETURN;
          IFEND;
        ELSEIF current_message^.element_value^.keyword_value = 'MESSAGES' THEN
          message_control := message_control + $amt$message_control [amc$messages];
        ELSEIF current_message^.element_value^.keyword_value = 'STATISTICS' THEN
          message_control := message_control + $amt$message_control [amc$statistics];
        ELSEIF current_message^.element_value^.keyword_value = 'TRIVIAL_ERRORS' THEN
          message_control := message_control + $amt$message_control [amc$trivial_errors];
        IFEND;
        current_message := current_message^.link;
      WHILEND;
      attributes [attribute_count].message_control := message_control;
    IFEND;

    IF pvt [p$open_position].specified THEN
      attribute_count := attribute_count + 1;
      attributes [attribute_count].key := amc$open_position;
      IF pvt [p$open_position].value^.keyword_value = '$ASIS' THEN
        attributes [attribute_count].open_position := amc$open_no_positioning;
      ELSEIF pvt [p$open_position].value^.keyword_value = '$BOI' THEN
        attributes [attribute_count].open_position := amc$open_at_boi;
      ELSEIF pvt [p$open_position].value^.keyword_value = '$BOP' THEN
        attributes [attribute_count].open_position := amc$open_at_bop;
      ELSEIF pvt [p$open_position].value^.keyword_value = '$EOI' THEN
        attributes [attribute_count].open_position := amc$open_at_eoi;
      IFEND;
    IFEND;

    IF attribute_count > 0 THEN
      IF attribute_count < max_attributes THEN
        FOR attribute_index := attribute_count + 1 TO max_attributes DO
          attributes [attribute_index].key := amc$null_attribute;
        FOREND;
      IFEND;
      bap$file_command (local_file_name, ^attributes, status);
    IFEND;

    IF pvt [p$external_vsn].specified OR pvt [p$free_behind].specified OR
          pvt [p$job_write_concurrency].specified OR pvt [p$private_read].specified OR
          pvt [p$recorded_vsn].specified OR pvt [p$sequential_access].specified OR
          pvt [p$transfer_size].specified OR pvt [p$volume_overflow_allowed].specified THEN
      cd_attachment_options.free_behind_specified := pvt [p$free_behind].specified;
      IF cd_attachment_options.free_behind_specified THEN
        cd_attachment_options.free_behind := pvt [p$free_behind].value^.boolean_value.value;
      IFEND;
      cd_attachment_options.job_write_concurrency_specified := pvt [p$job_write_concurrency].specified;
      IF cd_attachment_options.job_write_concurrency_specified THEN
        cd_attachment_options.job_write_concurrency :=
              pvt [p$job_write_concurrency].value^.boolean_value.value;
      IFEND;
      cd_attachment_options.private_read_specified := pvt [p$private_read].specified;
      IF cd_attachment_options.private_read_specified THEN
        cd_attachment_options.private_read := pvt [p$private_read].value^.boolean_value.value;
      IFEND;
      cd_attachment_options.sequential_access_specified := pvt [p$sequential_access].specified;
      IF cd_attachment_options.sequential_access_specified THEN
        cd_attachment_options.sequential_access := pvt [p$sequential_access].value^.boolean_value.value;
      IFEND;
      cd_attachment_options.transfer_size_specified := pvt [p$transfer_size].specified;
      IF cd_attachment_options.transfer_size_specified THEN
        cd_attachment_options.transfer_size := pvt [p$transfer_size].value^.integer_value.value;
      IFEND;
      cd_attachment_options.volume_overflow_allowed_spec := pvt [p$volume_overflow_allowed].specified;
      IF cd_attachment_options.volume_overflow_allowed_spec THEN
        cd_attachment_options.volume_overflow_allowed :=
              pvt [p$volume_overflow_allowed].value^.boolean_value.value;
      IFEND;

      cd_attachment_options.external_vsn_specified := pvt [p$external_vsn].specified;
      cd_attachment_options.recorded_vsn_specified := pvt [p$recorded_vsn].specified;

      IF cd_attachment_options.external_vsn_specified OR cd_attachment_options.recorded_vsn_specified THEN
        evsn_count := clp$count_list_elements (pvt [p$external_vsn].value);
        rvsn_count := clp$count_list_elements (pvt [p$recorded_vsn].value);

        IF ((rvsn_count > 0) AND (evsn_count > 0)) AND (rvsn_count <> evsn_count) THEN
          osp$set_status_condition (cle$inconsistent_vsn_lists, status);
          RETURN;
        IFEND;

        IF rvsn_count > evsn_count THEN
          vsn_count := rvsn_count;
        ELSE
          vsn_count := evsn_count;
        IFEND;

        PUSH p_volume_list: [1 .. vsn_count];
        current_evsn := pvt [p$external_vsn].value;
        current_rvsn := pvt [p$recorded_vsn].value;

        FOR volume_list_index := 1 TO vsn_count DO
          IF current_evsn <> NIL THEN
            IF current_evsn^.element_value^.kind = clc$string THEN
              vsn_string := current_evsn^.element_value^.string_value^;
           ELSEIF current_evsn^.element_value^.kind = clc$name THEN
              vsn_string := current_evsn^.element_value^.name_value;
            IFEND;
            rmp$validate_ansi_string (vsn_string, p_volume_list^ [volume_list_index].external_vsn, status);
            IF NOT status.normal THEN
              osp$set_status_abnormal (rmc$resource_management_id, cle$improper_vsn_value,
                     vsn_string, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, 'EXTERNAL_VSN', status);
              RETURN;
            IFEND;
            current_evsn := current_evsn^.link;
          ELSE
            p_volume_list^ [volume_list_index].external_vsn := rmc$unspecified_vsn;
          IFEND;
          IF current_rvsn <> NIL THEN
            IF current_rvsn^.element_value^.kind = clc$string THEN
              vsn_string := current_rvsn^.element_value^.string_value^;
            ELSEIF current_rvsn^.element_value^.kind = clc$name THEN
              vsn_string := current_rvsn^.element_value^.name_value;
            IFEND;
            rmp$validate_ansi_string (vsn_string, p_volume_list^ [volume_list_index].recorded_vsn, status);
            IF NOT status.normal THEN
              osp$set_status_abnormal (rmc$resource_management_id, cle$improper_vsn_value,
                     vsn_string, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, 'RECORDED_VSN', status);
              RETURN;
            IFEND;
            current_rvsn := current_rvsn^.link;
          ELSE
            p_volume_list^ [volume_list_index].recorded_vsn := rmc$unspecified_vsn;
          IFEND;
          IF (p_volume_list^ [volume_list_index].external_vsn = rmc$unspecified_vsn) THEN
            p_volume_list^ [volume_list_index].external_vsn :=
                  p_volume_list^ [volume_list_index].recorded_vsn;
          ELSEIF (p_volume_list^ [volume_list_index].recorded_vsn = rmc$unspecified_vsn) THEN
            p_volume_list^ [volume_list_index].recorded_vsn :=
                  p_volume_list^ [volume_list_index].external_vsn;
          IFEND;
        FOREND;
      ELSE
        p_volume_list := NIL;
      IFEND;

      bap$set_attachment_options (local_file_name, cd_attachment_options, p_volume_list, status);
      IF NOT status.normal THEN
        IF status.condition = fme$no_cycle_description THEN
{ File must have been detached by an asynchronous task.  A permanent file should have been attached by
{ PFP$ATTACH, and a temporary file's existance should have been verified by AMP$GET_FILE_ATTRIBUTES.
{ This situation can be treated as if the asynchronous detach occurred after this request and therefore
{ return a normal status.
          status.normal := TRUE;
        ELSEIF NOT first_path_element_is_$local THEN
          amp$return (local_file_name, ignore_status);
        IFEND;
      IFEND;
    IFEND; {Attachment Option Specified.

  PROCEND clp$_attach_file;
?? TITLE := 'clp$_delete_file', EJECT ??

  PROCEDURE [XDCL] clp$_delete_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$delf) delete_file, delf (
{   file, files, f: list 0..clc$max_list_size of file = $required
{   password, pw: (SECURE) any of
{       key
{         none
{       keyend
{       name
{     anyend = none
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 6] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
        type2: 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$name_type_qualifier,
          recend,
          default_value: string (4),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 6, 18, 39, 53, 773], clc$command, 6, 3, 1, 0, 0, 0, 3, 'OSM$DELF'],
            [['F                              ', clc$abbreviation_entry, 1],
            ['FILE                           ', clc$nominal_entry, 1],
            ['FILES                          ', clc$alias_entry, 1],
            ['PASSWORD                       ', clc$nominal_entry, 2],
            ['PW                             ', clc$abbreviation_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 19, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 69, clc$optional_default_parameter, 0, 4],

{ PARAMETER 3

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$list_type], [3, 0, clc$max_list_size, FALSE], [[1, 0, clc$file_type]]],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]], 'none'],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$file = 1,
      p$password = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      current_file: ^clt$data_value,
      cycle_selector: clt$cycle_selector,
      delete_path: fst$path,
      delete_path_size: fst$path_size,
      evaluated_file_reference: fst$evaluated_file_reference,
      first_path_element_is_$local: boolean,
      password: pft$password,
      pf_path: ^pft$path,
      remote: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$password].value^.kind = clc$name THEN
      password := pvt [p$password].value^.name_value;
    ELSE { keyword = NONE }
      password := osc$null_name;
    IFEND;

    current_file := pvt [p$file].value;

    WHILE (current_file <> NIL) AND (current_file^.element_value <> NIL) DO
      evaluate_path_and_handle_remote ('DELETE_FILE', current_file^.element_value^.file_value^, ^pvt,
            evaluated_file_reference, first_path_element_is_$local, remote, status);
      IF NOT status.normal THEN
        RETURN;
      ELSEIF NOT remote THEN

        IF evaluated_file_reference.cycle_reference.specification = fsc$cycle_omitted THEN
          evaluated_file_reference.cycle_reference.specification := fsc$low_cycle;
        IFEND;

        clp$convert_file_ref_to_string (evaluated_file_reference, FALSE, delete_path, delete_path_size,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF first_path_element_is_$local THEN
          IF evaluated_file_reference.number_of_path_elements = 1 THEN
            osp$set_status_abnormal ('CL', pfe$name_not_permanent_file, fsc$local, status);
            RETURN;
          IFEND;
          amp$return (delete_path (1, delete_path_size), status);
        ELSE
          amp$return (delete_path (1, delete_path_size), status);
          IF NOT status.normal THEN
            IF status.condition <> ame$file_not_known THEN
              RETURN;
            IFEND;
            status.normal := TRUE;
          IFEND;
          PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
          fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);
          clp$convert_cyc_ref_to_cyc_sel (evaluated_file_reference.cycle_reference, cycle_selector);
          pfp$purge (pf_path^, cycle_selector.value, password, status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      IFEND;
      current_file := current_file^.link;
    WHILEND;

  PROCEND clp$_delete_file;

?? TITLE := 'clp$_change_catalog_access', EJECT ??

  PROCEDURE [XDCL] clp$_change_catalog_access
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE [HIDDEN] change_catalog_access (
{   flush_catalogs, fc: any of
{       key
{         $unspecified
{       keyend
{       boolean
{     anyend = $optional
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] 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,
        recend,
      recend,
    recend := [
    [1,
    [90, 3, 9, 11, 27, 11, 994],
    clc$command, 2, 1, 0, 0, 0, 0, 0, ''], [
    ['FC                             ',clc$abbreviation_entry, 1],
    ['FLUSH_CATALOGS                 ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$boolean_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$flush_catalogs = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      flush_catalogs: boolean;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF not status.normal THEN
      RETURN;
    IFEND;
    flush_catalogs := TRUE;

    IF pvt [p$flush_catalogs].specified THEN
      IF pvt [p$flush_catalogs].value^.kind = clc$keyword THEN {$unspeicified}
        flush_catalogs := TRUE;
      ELSE
        flush_catalogs := pvt [p$flush_catalogs].value^.boolean_value.value;
      IFEND;
    IFEND;

    fsp$change_catalog_flush_option (flush_catalogs, status);
  PROCEND clp$_change_catalog_access;

?? TITLE := 'clp$_change_catalog_entry', EJECT ??

  PROCEDURE [XDCL] clp$_change_catalog_entry
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$chace) change_catalog_entry, chace (
{   file, f: file = $required
{   password, pw: (SECURE) any of
{       key
{         none
{       keyend
{       name
{     anyend = none
{   new_file_name, nfn: name = $optional
{   new_cycle, nc: integer pfc$minimum_cycle_number..pfc$maximum_cycle_number = $optional
{   new_password, npw: (SECURE) any of
{       key
{         none
{       keyend
{       name
{     anyend = $optional
{   new_log, nl: boolean = $optional
{   new_retention, nr: (BY_NAME) any of
{       integer pfc$minimum_retention..pfc$maximum_retention
{       date
{       date_time
{       time_increment
{     anyend = $optional
{   new_account_project, nap: boolean = $optional
{   delete_damage_condition, ddc: list of key
{       (media_image_inconsistent, mii)
{       (respf_modification_mismatch, rmm)
{       (parent_catalog_restored, pcr)
{     keyend = $optional
{   new_retrieve_option, nro: (BY_NAME, ADVANCED) key
{       (always_retrieve, ar)
{       (explicit_retrieve_only, ero)
{       (administrative_retrieve_only, aro)
{     keyend = $optional
{   new_shared_queue, nsq: (BY_NAME, ADVANCED) key
{       site_01, site_02, site_03, site_04, site_05, site_06, site_07, site_08, site_09, site_10, site_11
{       site_12, site_13, site_14, site_15, site_16, site_17, site_18, site_19, site_20, site_21, site_22
{       site_23, site_24, site_25, system
{     keyend = $optional
{   new_site_archive_option, nsao: (BY_NAME, ADVANCED) any of
{       integer 1..255
{       key
{         null
{       keyend
{     anyend = $optional
{   new_site_backup_option, nsbo: (BY_NAME, ADVANCED) any of
{       integer 1..255
{       key
{         null
{       keyend
{     anyend = $optional
{   new_site_release_option, nsro: (BY_NAME, ADVANCED) any of
{       integer 1..255
{       key
{         null
{       keyend
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 29] of clt$pdt_parameter_name,
      parameters: array [1 .. 15] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: 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$name_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: 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$name_type_qualifier,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
      type7: 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$integer_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$date_time_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$date_time_type_qualifier,
        recend,
        type_size_4: clt$type_specification_size,
        element_type_spec_4: record
          header: clt$type_specification_header,
        recend,
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
      type9: 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 .. 6] of clt$keyword_specification,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 26] of clt$keyword_specification,
      recend,
      type12: 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$integer_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
      recend,
      type13: 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$integer_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
      recend,
      type14: 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$integer_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
      recend,
      type15: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [97, 1, 20, 14, 28, 48, 497],
    clc$command, 29, 15, 1, 5, 0, 0, 15, 'OSM$CHACE'], [
    ['DDC                            ',clc$abbreviation_entry, 9],
    ['DELETE_DAMAGE_CONDITION        ',clc$nominal_entry, 9],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['NAP                            ',clc$abbreviation_entry, 8],
    ['NC                             ',clc$abbreviation_entry, 4],
    ['NEW_ACCOUNT_PROJECT            ',clc$nominal_entry, 8],
    ['NEW_CYCLE                      ',clc$nominal_entry, 4],
    ['NEW_FILE_NAME                  ',clc$nominal_entry, 3],
    ['NEW_LOG                        ',clc$nominal_entry, 6],
    ['NEW_PASSWORD                   ',clc$nominal_entry, 5],
    ['NEW_RETENTION                  ',clc$nominal_entry, 7],
    ['NEW_RETRIEVE_OPTION            ',clc$nominal_entry, 10],
    ['NEW_SHARED_QUEUE               ',clc$nominal_entry, 11],
    ['NEW_SITE_ARCHIVE_OPTION        ',clc$nominal_entry, 12],
    ['NEW_SITE_BACKUP_OPTION         ',clc$nominal_entry, 13],
    ['NEW_SITE_RELEASE_OPTION        ',clc$nominal_entry, 14],
    ['NFN                            ',clc$abbreviation_entry, 3],
    ['NL                             ',clc$abbreviation_entry, 6],
    ['NPW                            ',clc$abbreviation_entry, 5],
    ['NR                             ',clc$abbreviation_entry, 7],
    ['NRO                            ',clc$abbreviation_entry, 10],
    ['NSAO                           ',clc$abbreviation_entry, 12],
    ['NSBO                           ',clc$abbreviation_entry, 13],
    ['NSQ                            ',clc$abbreviation_entry, 11],
    ['NSRO                           ',clc$abbreviation_entry, 14],
    ['PASSWORD                       ',clc$nominal_entry, 2],
    ['PW                             ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 15]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [27, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 3
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 7
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 61, clc$optional_parameter,
  0, 0],
{ PARAMETER 8
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 9
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 245,
  clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [13, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [14, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 969,
  clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [15, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84, clc$optional_parameter,
  0, 0],
{ PARAMETER 13
    [16, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84, clc$optional_parameter,
  0, 0],
{ PARAMETER 14
    [17, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84, clc$optional_parameter,
  0, 0],
{ PARAMETER 15
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'none'],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [pfc$minimum_cycle_number, pfc$maximum_cycle_number, 10]],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 6
    [[1, 0, clc$boolean_type]],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$date_time_type, clc$integer_type, clc$time_increment_type],
    FALSE, 4],
    20, [[1, 0, clc$integer_type], [pfc$minimum_retention, pfc$maximum_retention, 10]],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date], $clt$date_time_tenses [clc$past,
  clc$present, clc$future]]],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [
  clc$past, clc$present, clc$future]]],
    3, [[1, 0, clc$time_increment_type]]
    ],
{ PARAMETER 8
    [[1, 0, clc$boolean_type]],
{ PARAMETER 9
    [[1, 0, clc$list_type], [229, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [6], [
      ['MEDIA_IMAGE_INCONSISTENT       ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['MII                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['PARENT_CATALOG_RESTORED        ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['PCR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['RESPF_MODIFICATION_MISMATCH    ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['RMM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2]]
      ]
    ],
{ PARAMETER 10
    [[1, 0, clc$keyword_type], [6], [
    ['ADMINISTRATIVE_RETRIEVE_ONLY   ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['ALWAYS_RETRIEVE                ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['AR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ARO                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['ERO                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXPLICIT_RETRIEVE_ONLY         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 11
    [[1, 0, clc$keyword_type], [26], [
    ['SITE_01                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['SITE_02                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['SITE_03                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['SITE_04                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['SITE_05                        ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['SITE_06                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['SITE_07                        ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['SITE_08                        ', clc$nominal_entry, clc$normal_usage_entry, 8],
    ['SITE_09                        ', clc$nominal_entry, clc$normal_usage_entry, 9],
    ['SITE_10                        ', clc$nominal_entry, clc$normal_usage_entry, 10],
    ['SITE_11                        ', clc$nominal_entry, clc$normal_usage_entry, 11],
    ['SITE_12                        ', clc$nominal_entry, clc$normal_usage_entry, 12],
    ['SITE_13                        ', clc$nominal_entry, clc$normal_usage_entry, 13],
    ['SITE_14                        ', clc$nominal_entry, clc$normal_usage_entry, 14],
    ['SITE_15                        ', clc$nominal_entry, clc$normal_usage_entry, 15],
    ['SITE_16                        ', clc$nominal_entry, clc$normal_usage_entry, 16],
    ['SITE_17                        ', clc$nominal_entry, clc$normal_usage_entry, 17],
    ['SITE_18                        ', clc$nominal_entry, clc$normal_usage_entry, 18],
    ['SITE_19                        ', clc$nominal_entry, clc$normal_usage_entry, 19],
    ['SITE_20                        ', clc$nominal_entry, clc$normal_usage_entry, 20],
    ['SITE_21                        ', clc$nominal_entry, clc$normal_usage_entry, 21],
    ['SITE_22                        ', clc$nominal_entry, clc$normal_usage_entry, 22],
    ['SITE_23                        ', clc$nominal_entry, clc$normal_usage_entry, 23],
    ['SITE_24                        ', clc$nominal_entry, clc$normal_usage_entry, 24],
    ['SITE_25                        ', clc$nominal_entry, clc$normal_usage_entry, 25],
    ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 26]]
    ],
{ PARAMETER 12
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    20, [[1, 0, clc$integer_type], [1, 255, 10]],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NULL                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ],
{ PARAMETER 13
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    20, [[1, 0, clc$integer_type], [1, 255, 10]],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NULL                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ],
{ PARAMETER 14
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    20, [[1, 0, clc$integer_type], [1, 255, 10]],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NULL                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ],
{ PARAMETER 15
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$password = 2,
      p$new_file_name = 3,
      p$new_cycle = 4,
      p$new_password = 5,
      p$new_log = 6,
      p$new_retention = 7,
      p$new_account_project = 8,
      p$delete_damage_condition = 9,
      p$new_retrieve_option = 10,
      p$new_shared_queue = 11,
      p$new_site_archive_option = 12,
      p$new_site_backup_option = 13,
      p$new_site_release_option = 14,
      p$status = 15;

    VAR
      pvt: array [1 .. 15] of clt$parameter_value;

    CONST
      max_changes = 13;

    VAR
      cycle_selector: clt$cycle_selector,
      damage_conditions: ^clt$data_value,
      password: pft$password,
      file_change_area: SEQ (REP max_changes of fst$file_change),
      area_pointer: ^SEQ (REP max_changes of fst$file_change),
      change_count: 0 .. max_changes,
      file_changes: ^fst$file_changes,
      evaluated_file_reference: fst$evaluated_file_reference,
      first_path_element_is_$local: boolean,
      parameter: p$new_file_name .. p$new_site_release_option ,
      pf_path: ^pft$path,
      remote: boolean;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    evaluate_path_and_handle_remote ('CHANGE_CATALOG_ENTRY', pvt [p$file].value^.file_value^, ^pvt,
          evaluated_file_reference, first_path_element_is_$local, remote, status);
    IF (NOT status.normal) OR remote THEN
      RETURN;
    IFEND;

    change_count := 0;
    area_pointer := ^file_change_area;

    IF pvt [p$password].value^.kind = clc$name THEN
      password := pvt [p$password].value^.name_value;
    ELSE { keyword = NONE }
      password := osc$null_name;
    IFEND;

    IF first_path_element_is_$local THEN
      IF evaluated_file_reference.number_of_path_elements = 1 THEN
        osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_cat, '', status);
      ELSE
        osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_file, '', status);
      IFEND;
    ELSE

      FOR parameter := p$new_file_name TO p$new_site_release_option DO
        IF pvt [parameter].specified THEN
          change_count := change_count + 1;
        IFEND;
      FOREND;

      IF change_count = 0 THEN
        osp$set_status_abnormal ('CL', cle$required_parameter_omitted,
              'NEW_FILE_NAME..NEW_SITE_RELEASE_OPTION', status);
        RETURN;
      IFEND;

      RESET area_pointer;
      NEXT file_changes: [1 .. change_count] IN area_pointer;

      change_count := 0;
      IF pvt [p$new_file_name].specified THEN
        change_count := change_count + 1;
        file_changes^ [change_count].selector := fsc$pf_name_change;
        file_changes^ [change_count].pfn := pvt [p$new_file_name].value^.name_value;
      IFEND;

      IF pvt [p$new_cycle].specified THEN
        change_count := change_count + 1;
        file_changes^ [change_count].selector := fsc$cycle_number_change;
        file_changes^ [change_count].cycle_number := pvt [p$new_cycle].value^.integer_value.value;
      IFEND;

      IF pvt [p$new_password].specified THEN
        change_count := change_count + 1;
        file_changes^ [change_count].selector := fsc$password_change;
        IF pvt [p$new_password].value^.kind = clc$keyword THEN {keyword = NONE}
          file_changes^ [change_count].password := osc$null_name;
        ELSE
          file_changes^ [change_count].password := pvt [p$new_password].value^.name_value;
        IFEND;
      IFEND;

      IF pvt [p$new_log].specified THEN
        change_count := change_count + 1;
        file_changes^ [change_count].selector := fsc$log_change;
        file_changes^ [change_count].log := log_select [pvt [p$new_log].value^.boolean_value.value];
      IFEND;

      IF pvt [p$new_retention].specified THEN
        change_count := change_count + 1;
        file_changes^ [change_count].selector := fsc$retention_change;
        IF pvt [p$new_retention].value^.kind = clc$integer THEN
          file_changes^ [change_count].retention.selector := fsc$retention_day_increment;
          file_changes^ [change_count].retention.day_increment :=
                pvt [p$new_retention].value^.integer_value.value;
        ELSEIF pvt [p$new_retention].value^.kind = clc$time_increment THEN
          clp$verify_time_increment (pvt [p$new_retention].value^.time_increment_value^, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          file_changes^ [change_count].retention.selector := fsc$retention_time_increment;
          file_changes^ [change_count].retention.time_increment :=
                pvt [p$new_retention].value^.time_increment_value^;
        ELSE
          file_changes^ [change_count].retention.selector := fsc$retention_expiration_date;
          file_changes^ [change_count].retention.expiration_date :=
                pvt [p$new_retention].value^.date_time_value.value;
        IFEND;
      IFEND;

      IF pvt [p$new_account_project].specified AND pvt [p$new_account_project].value^.boolean_value.value THEN
        change_count := change_count + 1;
        file_changes^ [change_count].selector := fsc$charge_change;
      IFEND;

      IF pvt [p$delete_damage_condition].specified THEN
        damage_conditions := pvt [p$delete_damage_condition].value;
        change_count := change_count + 1;
        file_changes^ [change_count].selector := fsc$delete_damage_change;
        file_changes^ [change_count].delete_damage_condition := $fst$cycle_damage_symptoms [];
        WHILE damage_conditions <> NIL DO
          IF damage_conditions^.element_value^.keyword_value = 'MEDIA_IMAGE_INCONSISTENT' THEN
            file_changes^ [change_count].delete_damage_condition :=
                  file_changes^ [change_count].delete_damage_condition +
                  $fst$cycle_damage_symptoms [fsc$media_image_inconsistent];
          ELSEIF damage_conditions^.element_value^.keyword_value = 'RESPF_MODIFICATION_MISMATCH' THEN
            file_changes^ [change_count].delete_damage_condition :=
                  file_changes^ [change_count].delete_damage_condition +
                  $fst$cycle_damage_symptoms [fsc$respf_modification_mismatch];
          ELSE {'PARENT_CATALOG_RESTORED'}
            file_changes^ [change_count].delete_damage_condition :=
                  file_changes^ [change_count].delete_damage_condition +
                  $fst$cycle_damage_symptoms [fsc$parent_catalog_restored];
          IFEND;
          damage_conditions := damage_conditions^.link;
        WHILEND;
      IFEND;

      IF pvt [p$new_shared_queue].specified THEN
        change_count := change_count + 1;
        file_changes^ [change_count].selector := fsc$shared_queue_change;
        file_changes^ [change_count].shared_queue := pvt [p$new_shared_queue].value^.keyword_value;
      IFEND;

      IF pvt [p$new_retrieve_option].specified THEN
        change_count := change_count + 1;
        file_changes^ [change_count].selector := fsc$retrieve_option_change;
        IF (pvt [p$new_retrieve_option].value^.name_value = 'ALWAYS_RETRIEVE') THEN
          file_changes^ [change_count].retrieve_option := pfc$always_retrieve;
        ELSEIF (pvt [p$new_retrieve_option].value^.name_value = 'EXPLICIT_RETRIEVE_ONLY') THEN
          file_changes^ [change_count].retrieve_option := pfc$explicit_retrieve_only;
        ELSE { 'ADMINISTRATIVE_RETRIEVE_ONLY' }
          file_changes^ [change_count].retrieve_option := pfc$admin_retrieve_only;
        IFEND;
      IFEND;

      IF pvt [p$new_site_archive_option].specified THEN
        change_count := change_count + 1;
        file_changes^ [change_count].selector := fsc$site_archive_option_change;
        IF pvt [p$new_site_archive_option].value^.kind = clc$integer THEN
          file_changes^ [change_count].site_archive_option :=
                pvt [p$new_site_archive_option].value^.integer_value.value;
        ELSE { 'NULL' }
          file_changes^ [change_count].site_archive_option := pfc$null_site_archive_option;
        IFEND;
      IFEND;

      IF pvt [p$new_site_backup_option].specified THEN
        change_count := change_count + 1;
        file_changes^ [change_count].selector := fsc$site_backup_option_change;
        IF pvt [p$new_site_backup_option].value^.kind = clc$integer THEN
          file_changes^ [change_count].site_backup_option :=
                pvt [p$new_site_backup_option].value^.integer_value.value;
        ELSE { 'NULL' }
          file_changes^ [change_count].site_backup_option := pfc$null_site_backup_option;
        IFEND;
      IFEND;

      IF pvt [p$new_site_release_option].specified THEN
        change_count := change_count + 1;
        file_changes^ [change_count].selector := fsc$site_release_option_change;
        IF pvt [p$new_site_release_option].value^.kind = clc$integer THEN
          file_changes^ [change_count].site_release_option :=
                pvt [p$new_site_release_option].value^.integer_value.value;
        ELSE { 'NULL' }
          file_changes^ [change_count].site_release_option := pfc$null_site_release_option;
        IFEND;
      IFEND;

      fsp$change_file (pvt[p$file].value^.file_value^, password, file_changes, status);
      IF NOT status.normal THEN
        status.normal := status.condition = pfe$no_media_image_inconsistent;
      IFEND;
    IFEND;

  PROCEND clp$_change_catalog_entry;
?? TITLE := 'clp$_create_file_permit', EJECT ??

  PROCEDURE [XDCL] clp$_create_file_permit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$crefp) create_file_permit, crefp (
{   file, f: file = $required
{   group, g: key
{       public, family, account, project, user, user_account, member
{     keyend = user
{   family_name, fn: name = $optional
{   user, u: name = $optional
{   account, a: name = $optional
{   project, p: name = $optional
{   access_modes, access_mode, am: list of key
{       none, read, execute, append, modify, shorten, write, all, cycle, control
{     keyend = (read, execute)
{   share_modes, share_mode, sm: list of key
{       none, read, execute, append, modify, shorten, write, all
{     keyend = $optional
{   application_information, ai: string 0..osc$max_name_size = ''
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 21] of clt$pdt_parameter_name,
        parameters: array [1 .. 10] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 7] of clt$keyword_specification,
          default_value: string (4),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type5: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type7: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 10] of clt$keyword_specification,
          recend,
          default_value: string (15),
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 8] of clt$keyword_specification,
          recend,
        recend,
        type9: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
          default_value: string (2),
        recend,
        type10: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 20, 12, 46, 12, 676], clc$command, 21, 10, 1, 0, 0, 0, 10, 'OSM$CREFP'],
            [['A                              ', clc$abbreviation_entry, 5],
            ['ACCESS_MODE                    ', clc$alias_entry, 7],
            ['ACCESS_MODES                   ', clc$nominal_entry, 7],
            ['ACCOUNT                        ', clc$nominal_entry, 5],
            ['AI                             ', clc$abbreviation_entry, 9],
            ['AM                             ', clc$abbreviation_entry, 7],
            ['APPLICATION_INFORMATION        ', clc$nominal_entry, 9],
            ['F                              ', clc$abbreviation_entry, 1],
            ['FAMILY_NAME                    ', clc$nominal_entry, 3],
            ['FILE                           ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 3],
            ['G                              ', clc$abbreviation_entry, 2],
            ['GROUP                          ', clc$nominal_entry, 2],
            ['P                              ', clc$abbreviation_entry, 6],
            ['PROJECT                        ', clc$nominal_entry, 6],
            ['SHARE_MODE                     ', clc$alias_entry, 8],
            ['SHARE_MODES                    ', clc$nominal_entry, 8],
            ['SM                             ', clc$abbreviation_entry, 8],
            ['STATUS                         ', clc$nominal_entry, 10],
            ['U                              ', clc$abbreviation_entry, 4],
            ['USER                           ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 266, clc$optional_default_parameter, 0, 4],

{ PARAMETER 3

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [21, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [15, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 393, clc$optional_default_parameter, 0, 15],

{ PARAMETER 8

      [17, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 319, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 2],

{ PARAMETER 10

      [19, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [7], [['ACCOUNT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['FAMILY                         ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['MEMBER                         ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['PROJECT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['PUBLIC                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['USER_ACCOUNT                   ', clc$nominal_entry,
            clc$normal_usage_entry, 6]], 'user'],

{ PARAMETER 3

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 4

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 5

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 6

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 7

      [[1, 0, clc$list_type], [377, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [10], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 8], ['APPEND                         ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['CONTROL                        ', clc$nominal_entry,
            clc$normal_usage_entry, 10], ['CYCLE                          ', clc$nominal_entry,
            clc$normal_usage_entry, 9], ['EXECUTE                        ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['MODIFY                         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['READ                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SHORTEN                        ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['WRITE                          ', clc$nominal_entry,
            clc$normal_usage_entry, 7]]], '(read, execute)'],

{ PARAMETER 8

      [[1, 0, clc$list_type], [303, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [8], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 8], ['APPEND                         ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['EXECUTE                        ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['MODIFY                         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['READ                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SHORTEN                        ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['WRITE                          ', clc$nominal_entry,
            clc$normal_usage_entry, 7]]]],

{ PARAMETER 9

      [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE], ''''''],

{ PARAMETER 10

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$file = 1,
      p$group = 2,
      p$family_name = 3,
      p$user = 4,
      p$account = 5,
      p$project = 6,
      p$access_modes = 7,
      p$share_modes = 8,
      p$application_information = 9,
      p$status = 10;

    VAR
      pvt: array [1 .. 10] of clt$parameter_value;

    VAR
      application_info: pft$application_info,
      evaluated_file_reference: fst$evaluated_file_reference,
      first_path_element_is_$local: boolean,
      group: pft$group,
      ignore_permit: pft$permit_selections,
      ignore_usage_share: pft$usage_selections,
      permit: pft$permit_selections,
      pf_path: ^pft$path,
      remote: boolean,
      share: pft$share_selections,
      share_specified: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    evaluate_path_and_handle_remote ('CREATE_FILE_PERMIT', pvt [p$file].value^.file_value^, ^pvt,
          evaluated_file_reference, first_path_element_is_$local, remote, status);
    IF (NOT status.normal) OR remote THEN
      RETURN;
    IFEND;

    handle_group_specification (^pvt, group, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    handle_access_mode_or_share (pvt [p$access_modes].value, select_permit, ignore_usage_share, permit,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$share_modes].specified THEN
      handle_access_mode_or_share (pvt [p$share_modes].value, select_share, share, ignore_permit, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSEIF (permit * $pft$permit_selections [pfc$append, pfc$shorten,
          pfc$modify]) <> $pft$permit_selections [] THEN
      share := $pft$share_selections [];
    ELSE
      share := $pft$share_selections [pfc$read, pfc$execute];
    IFEND;

    application_info := pvt [p$application_information].value^.string_value^;

    IF first_path_element_is_$local THEN
      IF evaluated_file_reference.number_of_path_elements = 1 THEN
        osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_cat, '', status);
      ELSE
        osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_file, '', status);
      IFEND;
    ELSE
      PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
      fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);
      pfp$permit (pf_path^, group, permit, share, application_info, status);
    IFEND;

  PROCEND clp$_create_file_permit;
?? TITLE := 'clp$_delete_file_permit', EJECT ??

  PROCEDURE [XDCL] clp$_delete_file_permit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$delfp) delete_file_permit, delfp (
{   file, f: file = $required
{   group, g: key
{       public, family, account, project, user, user_account, member
{     keyend = user
{   family_name, fn: name = $optional
{   user, u: name = $optional
{   account, a: name = $optional
{   project, p: name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 13] of clt$pdt_parameter_name,
        parameters: array [1 .. 7] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 7] of clt$keyword_specification,
          default_value: string (4),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type5: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type7: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 20, 12, 46, 35, 368], clc$command, 13, 7, 1, 0, 0, 0, 7, 'OSM$DELFP'],
            [['A                              ', clc$abbreviation_entry, 5],
            ['ACCOUNT                        ', clc$nominal_entry, 5],
            ['F                              ', clc$abbreviation_entry, 1],
            ['FAMILY_NAME                    ', clc$nominal_entry, 3],
            ['FILE                           ', clc$nominal_entry, 1],
            ['FN                             ', clc$abbreviation_entry, 3],
            ['G                              ', clc$abbreviation_entry, 2],
            ['GROUP                          ', clc$nominal_entry, 2],
            ['P                              ', clc$abbreviation_entry, 6],
            ['PROJECT                        ', clc$nominal_entry, 6],
            ['STATUS                         ', clc$nominal_entry, 7],
            ['U                              ', clc$abbreviation_entry, 4],
            ['USER                           ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 266, clc$optional_default_parameter, 0, 4],

{ PARAMETER 3

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [7], [['ACCOUNT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['FAMILY                         ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['MEMBER                         ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['PROJECT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['PUBLIC                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['USER_ACCOUNT                   ', clc$nominal_entry,
            clc$normal_usage_entry, 6]], 'user'],

{ PARAMETER 3

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 4

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 5

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 6

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 7

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$file = 1,
      p$group = 2,
      p$family_name = 3,
      p$user = 4,
      p$account = 5,
      p$project = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

    VAR
      group: pft$group,
      evaluated_file_reference: fst$evaluated_file_reference,
      first_path_element_is_$local: boolean,
      pf_path: ^pft$path,
      remote: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    evaluate_path_and_handle_remote ('DELETE_FILE_PERMIT', pvt [p$file].value^.file_value^, ^pvt,
          evaluated_file_reference, first_path_element_is_$local, remote, status);
    IF (NOT status.normal) OR remote THEN
      RETURN;
    IFEND;

    handle_group_specification (^pvt, group, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF first_path_element_is_$local THEN
      IF evaluated_file_reference.number_of_path_elements = 1 THEN
        osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_cat, '', status);
      ELSE
        osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_file, '', status);
      IFEND;
    ELSE
      PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
      fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);
      pfp$delete_permit (pf_path^, group, status);
    IFEND;

  PROCEND clp$_delete_file_permit;
?? TITLE := 'clp$_create_catalog', EJECT ??

  PROCEDURE [XDCL] clp$_create_catalog
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$crec) create_catalog, crec (
{   catalog, c: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 20, 12, 46, 56, 588], clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$CREC'],
            [['C                              ', clc$abbreviation_entry, 1],
            ['CATALOG                        ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 2]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$catalog = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      first_path_element_is_$local: boolean,
      pf_path: ^pft$path,
      remote: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    evaluate_path_and_handle_remote ('CREATE_CATALOG', pvt [p$catalog].value^.file_value^, ^pvt,
          evaluated_file_reference, first_path_element_is_$local, remote, status);
    IF (NOT status.normal) OR remote THEN
      RETURN;
    IFEND;

    IF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
      osp$set_status_abnormal ('CL', cle$file_position_not_allowed, '', status);
      RETURN;
    IFEND;

    IF first_path_element_is_$local THEN
      IF evaluated_file_reference.number_of_path_elements = 1 THEN
        osp$set_status_abnormal ('CL', cle$name_already_catalog, fsc$local, status);
      ELSE
        osp$set_status_abnormal ('CL', fse$local_subcatalog_illegal, '', status);
      IFEND;
    ELSE
      IF evaluated_file_reference.cycle_reference.specification <> fsc$cycle_omitted THEN
        osp$set_status_abnormal ('CL', fse$catalogs_do_not_have_cycles, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$catalog].value^.file_value^, status);
        RETURN;
      IFEND;

      PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
      fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);
      pfp$define_catalog (pf_path^, status);
    IFEND;

  PROCEND clp$_create_catalog;
?? TITLE := 'clp$_delete_catalog', EJECT ??

  PROCEDURE [XDCL] clp$_delete_catalog
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$delc) delete_catalog, delc (
{   catalog, c: file = $required
{   delete_option, do: key
{       (catalog_and_contents, cac)
{       (contents_only, co)
{       (only_if_empty, oie)
{     keyend = only_if_empty
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 6] of clt$keyword_specification,
          default_value: string (13),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 3, 29, 9, 39, 5, 639], clc$command, 5, 3, 1, 0, 0, 0, 3, 'OSM$DELC'],
            [['C                              ', clc$abbreviation_entry, 1],
            ['CATALOG                        ', clc$nominal_entry, 1],
            ['DELETE_OPTION                  ', clc$nominal_entry, 2],
            ['DO                             ', clc$abbreviation_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 229, clc$optional_default_parameter, 0, 13],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [6], [['CAC                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['CATALOG_AND_CONTENTS           ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['CO                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['CONTENTS_ONLY                  ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['OIE                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['ONLY_IF_EMPTY                  ', clc$nominal_entry,
            clc$normal_usage_entry, 3]], 'only_if_empty'],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$catalog = 1,
      p$delete_option = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      first_path_element_is_$local: boolean,
      pf_path: ^pft$path,
      remote: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    evaluate_path_and_handle_remote ('DELETE_CATALOG', pvt [p$catalog].value^.file_value^, ^pvt,
          evaluated_file_reference, first_path_element_is_$local, remote, status);
    IF (NOT status.normal) OR remote THEN
      RETURN;
    IFEND;

    IF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
      osp$set_status_abnormal ('CL', cle$file_position_not_allowed, '', status);
      RETURN;
    IFEND;

    IF first_path_element_is_$local THEN
      IF evaluated_file_reference.number_of_path_elements = 1 THEN
        osp$set_status_abnormal ('CL', cle$catalog_not_empty, fsc$local, status);
      ELSE
        osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_file, '', status);
      IFEND;
    ELSE
      IF evaluated_file_reference.cycle_reference.specification <> fsc$cycle_omitted THEN
        osp$set_status_abnormal ('CL', fse$catalogs_do_not_have_cycles, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$catalog].value^.file_value^, status);
        RETURN;
      IFEND;

      PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
      fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);

      IF pvt [p$delete_option].value^.keyword_value = 'CATALOG_AND_CONTENTS' THEN
        pfp$purge_catalog_contents (pf_path^, {purge_catalog} TRUE, status);
      ELSEIF pvt [p$delete_option].value^.keyword_value = 'CONTENTS_ONLY' THEN
        pfp$purge_catalog_contents (pf_path^, {purge_catalog} FALSE, status);
      ELSE { ONLY_IF_EMPTY }
        pfp$purge_catalog (pf_path^, status);
      IFEND;
    IFEND;

  PROCEND clp$_delete_catalog;
?? TITLE := 'clp$_create_catalog_permit', EJECT ??

  PROCEDURE [XDCL] clp$_create_catalog_permit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$crecp) create_catalog_permit, crecp (
{   catalog, c: file = $required
{   group, g: key
{       public, family, account, project, user, user_account, member
{     keyend = user
{   family_name, fn: name = $optional
{   user, u: name = $optional
{   account, a: name = $optional
{   project, p: name = $optional
{   access_modes, access_mode, am: list of key
{       none, read, execute, append, modify, shorten, write, all, cycle, control
{     keyend = (read, execute)
{   share_modes, share_mode, sm: list of key
{       none, read, execute, append, modify, shorten, write, all
{     keyend = $optional
{   application_information, ai: string 0..osc$max_name_size = ''
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 21] of clt$pdt_parameter_name,
        parameters: array [1 .. 10] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 7] of clt$keyword_specification,
          default_value: string (4),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type5: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type7: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 10] of clt$keyword_specification,
          recend,
          default_value: string (15),
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 8] of clt$keyword_specification,
          recend,
        recend,
        type9: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
          default_value: string (2),
        recend,
        type10: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 20, 12, 47, 34, 340], clc$command, 21, 10, 1, 0, 0, 0, 10, 'OSM$CRECP'],
            [['A                              ', clc$abbreviation_entry, 5],
            ['ACCESS_MODE                    ', clc$alias_entry, 7],
            ['ACCESS_MODES                   ', clc$nominal_entry, 7],
            ['ACCOUNT                        ', clc$nominal_entry, 5],
            ['AI                             ', clc$abbreviation_entry, 9],
            ['AM                             ', clc$abbreviation_entry, 7],
            ['APPLICATION_INFORMATION        ', clc$nominal_entry, 9],
            ['C                              ', clc$abbreviation_entry, 1],
            ['CATALOG                        ', clc$nominal_entry, 1],
            ['FAMILY_NAME                    ', clc$nominal_entry, 3],
            ['FN                             ', clc$abbreviation_entry, 3],
            ['G                              ', clc$abbreviation_entry, 2],
            ['GROUP                          ', clc$nominal_entry, 2],
            ['P                              ', clc$abbreviation_entry, 6],
            ['PROJECT                        ', clc$nominal_entry, 6],
            ['SHARE_MODE                     ', clc$alias_entry, 8],
            ['SHARE_MODES                    ', clc$nominal_entry, 8],
            ['SM                             ', clc$abbreviation_entry, 8],
            ['STATUS                         ', clc$nominal_entry, 10],
            ['U                              ', clc$abbreviation_entry, 4],
            ['USER                           ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 266, clc$optional_default_parameter, 0, 4],

{ PARAMETER 3

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [21, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [15, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 393, clc$optional_default_parameter, 0, 15],

{ PARAMETER 8

      [17, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 319, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 2],

{ PARAMETER 10

      [19, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [7], [['ACCOUNT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['FAMILY                         ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['MEMBER                         ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['PROJECT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['PUBLIC                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['USER_ACCOUNT                   ', clc$nominal_entry,
            clc$normal_usage_entry, 6]], 'user'],

{ PARAMETER 3

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 4

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 5

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 6

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 7

      [[1, 0, clc$list_type], [377, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [10], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 8], ['APPEND                         ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['CONTROL                        ', clc$nominal_entry,
            clc$normal_usage_entry, 10], ['CYCLE                          ', clc$nominal_entry,
            clc$normal_usage_entry, 9], ['EXECUTE                        ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['MODIFY                         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['READ                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SHORTEN                        ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['WRITE                          ', clc$nominal_entry,
            clc$normal_usage_entry, 7]]], '(read, execute)'],

{ PARAMETER 8

      [[1, 0, clc$list_type], [303, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [8], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 8], ['APPEND                         ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['EXECUTE                        ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['MODIFY                         ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['READ                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SHORTEN                        ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['WRITE                          ', clc$nominal_entry,
            clc$normal_usage_entry, 7]]]],

{ PARAMETER 9

      [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE], ''''''],

{ PARAMETER 10

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$catalog = 1,
      p$group = 2,
      p$family_name = 3,
      p$user = 4,
      p$account = 5,
      p$project = 6,
      p$access_modes = 7,
      p$share_modes = 8,
      p$application_information = 9,
      p$status = 10;

    VAR
      pvt: array [1 .. 10] of clt$parameter_value;

    VAR
      application_info: pft$application_info,
      evaluated_file_reference: fst$evaluated_file_reference,
      first_path_element_is_$local: boolean,
      group: pft$group,
      ignore_permit: pft$permit_selections,
      ignore_usage_share: pft$usage_selections,
      permit: pft$permit_selections,
      pf_path: ^pft$path,
      remote: boolean,
      share: pft$share_selections,
      share_specified: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    evaluate_path_and_handle_remote ('CREATE_CATALOG_PERMIT', pvt [p$catalog].value^.file_value^, ^pvt,
          evaluated_file_reference, first_path_element_is_$local, remote, status);
    IF (NOT status.normal) OR remote THEN
      RETURN;
    IFEND;

    IF evaluated_file_reference.cycle_reference.specification <> fsc$cycle_omitted THEN
      osp$set_status_abnormal ('CL', fse$catalogs_do_not_have_cycles, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, pvt [p$catalog].value^.file_value^, status);
      RETURN;
    IFEND;

    IF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
      osp$set_status_abnormal ('CL', cle$file_position_not_allowed, '', status);
      RETURN;
    IFEND;

    handle_group_specification (^pvt, group, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    handle_access_mode_or_share (pvt [p$access_modes].value, select_permit, ignore_usage_share, permit,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$share_modes].specified THEN
      handle_access_mode_or_share (pvt [p$share_modes].value, select_share, share, ignore_permit, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSEIF (permit * $pft$permit_selections [pfc$append, pfc$shorten,
          pfc$modify]) <> $pft$permit_selections [] THEN
      share := $pft$share_selections [];
    ELSE
      share := $pft$share_selections [pfc$read, pfc$execute];
    IFEND;

    application_info := pvt [p$application_information].value^.string_value^;

    IF first_path_element_is_$local THEN
      IF evaluated_file_reference.number_of_path_elements = 1 THEN
        osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_cat, '', status);
      ELSE
        osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_file, '', status);
      IFEND;
    ELSE
      PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
      fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);
      pfp$permit_catalog (pf_path^, group, permit, share, application_info, status);
    IFEND;

  PROCEND clp$_create_catalog_permit;
?? TITLE := 'clp$_delete_catalog_permit', EJECT ??

  PROCEDURE [XDCL] clp$_delete_catalog_permit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$delcp) delete_catalog_permit, delcp (
{   catalog, c: file = $required
{   group, g: key
{       public, family, account, project, user, user_account, member
{     keyend = user
{   family_name, fn: name = $optional
{   user, u: name = $optional
{   account, a: name = $optional
{   project, p: name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 13] of clt$pdt_parameter_name,
        parameters: array [1 .. 7] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 7] of clt$keyword_specification,
          default_value: string (4),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type5: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type7: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 20, 12, 47, 57, 817], clc$command, 13, 7, 1, 0, 0, 0, 7, 'OSM$DELCP'],
            [['A                              ', clc$abbreviation_entry, 5],
            ['ACCOUNT                        ', clc$nominal_entry, 5],
            ['C                              ', clc$abbreviation_entry, 1],
            ['CATALOG                        ', clc$nominal_entry, 1],
            ['FAMILY_NAME                    ', clc$nominal_entry, 3],
            ['FN                             ', clc$abbreviation_entry, 3],
            ['G                              ', clc$abbreviation_entry, 2],
            ['GROUP                          ', clc$nominal_entry, 2],
            ['P                              ', clc$abbreviation_entry, 6],
            ['PROJECT                        ', clc$nominal_entry, 6],
            ['STATUS                         ', clc$nominal_entry, 7],
            ['U                              ', clc$abbreviation_entry, 4],
            ['USER                           ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 266, clc$optional_default_parameter, 0, 4],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [7], [['ACCOUNT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['FAMILY                         ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['MEMBER                         ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['PROJECT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['PUBLIC                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['USER_ACCOUNT                   ', clc$nominal_entry,
            clc$normal_usage_entry, 6]], 'user'],

{ PARAMETER 3

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 4

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 5

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 6

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 7

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$catalog = 1,
      p$group = 2,
      p$family_name = 3,
      p$user = 4,
      p$account = 5,
      p$project = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      first_path_element_is_$local: boolean,
      group: pft$group,
      pf_path: ^pft$path,
      remote: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    evaluate_path_and_handle_remote ('DELETE_CATALOG_PERMIT', pvt [p$catalog].value^.file_value^, ^pvt,
          evaluated_file_reference, first_path_element_is_$local, remote, status);
    IF (NOT status.normal) OR remote THEN
      RETURN;
    IFEND;

    IF evaluated_file_reference.cycle_reference.specification <> fsc$cycle_omitted THEN
      osp$set_status_abnormal ('CL', fse$catalogs_do_not_have_cycles, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, pvt [p$catalog].value^.file_value^, status);
      RETURN;
    IFEND;

    IF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
      osp$set_status_abnormal ('CL', cle$file_position_not_allowed, '', status);
      RETURN;
    IFEND;

    handle_group_specification (^pvt, group, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF first_path_element_is_$local THEN
      IF evaluated_file_reference.number_of_path_elements = 1 THEN
        osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_cat, '', status);
      ELSE
        osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_file, '', status);
      IFEND;
    ELSE
      PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
      fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);
      pfp$delete_catalog_permit (pf_path^, group, status);
    IFEND;

  PROCEND clp$_delete_catalog_permit;

?? TITLE := 'clp$_flush_catalog', EJECT ??

  PROCEDURE [XDCL] clp$_flush_catalog
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{  PROCEDURE [HIDDEN] flush_catalog, flush_catalogs, fluc (
{    catalog, catalogs, c: list of file = $required
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 3, 19, 13, 41, 57, 314],
    clc$command, 4, 2, 1, 0, 0, 0, 2, ''], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CATALOG                        ',clc$nominal_entry, 1],
    ['CATALOGS                       ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 19, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$catalog = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      file_list: ^clt$data_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_list := pvt [p$catalog].value;
    WHILE file_list <> NIL DO
      fsp$flush_catalog (file_list^.element_value^.file_value^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      file_list := file_list^.link;
    WHILEND;

  PROCEND clp$_flush_catalog;

?? TITLE := 'evaluate_path_and_handle_remote', EJECT ??

{
{ PURPOSE:
{   This procedure parses a path for a command and determines whether it
{   represents a file on a remote system.  If so it performs the appropriate
{   remote operation; otherwise it returns the evaluated_file_reference for the
{   path along with a boolean indicating whether the path is or is in the
{   $LOCAL catalog.
{

  PROCEDURE evaluate_path_and_handle_remote
    (    command_name: ost$name_reference;
         path: fst$file_reference;
         pvt: ^clt$parameter_value_table;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR first_path_element_is_$local: boolean;
     VAR remote: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      family_name: ost$family_name,
      ignore_process_pt_results: bat$process_pt_results,
      remote_parameter: array [1 .. 1] of clt$parameter_substitution,
      work_area: ^^clt$work_area;


    clp$evaluate_file_reference (path, $clt$file_ref_parsing_options [], FALSE, evaluated_file_reference,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    family_name := fsp$path_element (^evaluated_file_reference, 1) ^;

    nfp$check_implicit_access (family_name, remote, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF remote THEN
      clp$get_work_area (#RING (^work_area), work_area, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$find_current_block (block);

      remote_parameter [1].name := 'STATUS';
      remote_parameter [1].text := NIL;

      nfp$perform_implicit_access (family_name, clc$null_file, path, nfc$null, command_name,
            block^.parameters.unbundled_pdt, pvt, ^remote_parameter, work_area^, status);
      RETURN;
    IFEND;

    first_path_element_is_$local := family_name = fsc$local;

{ Return permanent file path if file is attached as a local file.

    IF first_path_element_is_$local THEN
      bap$process_pt_request ($bat$process_pt_work_list [bac$resolve_path],
            osc$null_name, evaluated_file_reference, ignore_process_pt_results,
            status);
      family_name := fsp$path_element (^evaluated_file_reference, 1) ^;
      first_path_element_is_$local := family_name = fsc$local;
    IFEND;

  PROCEND evaluate_path_and_handle_remote;
?? TITLE := 'handle_group_specification', EJECT ??

{
{ PURPOSE:
{   This procedure processes permission values for the parameter 'GROUP', based
{   on the assumption that only input pertinent to a particular permission_type
{   will be processed.  Extraneous parameters cause an error status to be
{   generated.
{
{ NOTE:
{   This routine assumes that the group, family_name, user, account, and
{   project parameters are in the same position for all commands that use it.
{

  PROCEDURE handle_group_specification
    (    pvt: ^clt$parameter_value_table;
     VAR group: pft$group;
     VAR status: ost$status);

    CONST
      p$group = 2,
      p$family_name = 3,
      p$user = 4,
      p$account = 5,
      p$project = 6;

    TYPE
      param_value_set = set of (family_param, account_param, project_param, user_param);

    VAR
      group_value: clt$keyword,
      param_values: param_value_set,
      user: ost$user_name,
      family: ost$family_name,
      account: avt$account_name,
      project: avt$project_name;


    param_values := $param_value_set [];

    IF pvt^ [p$family_name].specified THEN
      param_values := param_values + $param_value_set [family_param];
      family := pvt^ [p$family_name].value^.name_value;
    ELSE
      family := osc$null_name;
    IFEND;

    IF pvt^ [p$user].specified THEN
      param_values := param_values + $param_value_set [user_param];
      user := pvt^ [p$user].value^.name_value;
    ELSE
      user := osc$null_name;
    IFEND;

    IF pvt^ [p$account].specified THEN
      param_values := param_values + $param_value_set [account_param];
      account := pvt^ [p$account].value^.name_value;
    ELSE
      account := osc$null_name;
    IFEND;

    IF pvt^ [p$project].specified THEN
      param_values := param_values + $param_value_set [project_param];
      project := pvt^ [p$project].value^.name_value;
    ELSE
      project := osc$null_name;
    IFEND;

    group_value := pvt^ [p$group].value^.keyword_value;
    IF group_value = 'ACCOUNT' THEN
      IF (param_values - $param_value_set [family_param, account_param]) <> $param_value_set [] THEN
        osp$set_status_abnormal ('CL', cle$incompatible_params_given, 'GROUP=ACCOUNT', status);
        RETURN;
      IFEND;
      group.group_type := pfc$account;
      group.account_description.family := family;
      group.account_description.account := account;
    ELSEIF group_value = 'FAMILY' THEN
      IF (param_values - $param_value_set [family_param]) <> $param_value_set [] THEN
        osp$set_status_abnormal ('CL', cle$incompatible_params_given, 'GROUP=FAMILY', status);
        RETURN;
      IFEND;
      group.group_type := pfc$family;
      group.family_description.family := family;
    ELSEIF group_value = 'MEMBER' THEN
      group.group_type := pfc$member;
      group.member_description.family := family;
      group.member_description.account := account;
      group.member_description.project := project;
      group.member_description.user := user;
    ELSEIF group_value = 'PROJECT' THEN
      IF (param_values - $param_value_set [family_param, account_param, project_param]) <> $param_value_set
            [] THEN
        osp$set_status_abnormal ('CL', cle$incompatible_params_given, 'GROUP=PROJECT', status);
        RETURN;
      IFEND;
      group.group_type := pfc$project;
      group.project_description.family := family;
      group.project_description.account := account;
      group.project_description.project := project;
    ELSEIF group_value = 'PUBLIC' THEN
      IF param_values <> $param_value_set [] THEN
        osp$set_status_abnormal ('CL', cle$incompatible_params_given, 'GROUP=PUBLIC', status);
        RETURN;
      IFEND;
      group.group_type := pfc$public;
    ELSEIF group_value = 'USER_ACCOUNT' THEN
      IF (param_values - $param_value_set [family_param, account_param, user_param]) <> $param_value_set
            [] THEN
        osp$set_status_abnormal ('CL', cle$incompatible_params_given, 'GROUP=USER_ACCOUNT', status);
        RETURN;
      IFEND;
      group.group_type := pfc$user_account;
      group.user_account_description.family := family;
      group.user_account_description.account := account;
      group.user_account_description.user := user;
    ELSEIF group_value = 'USER' THEN
      IF (param_values - $param_value_set [family_param, user_param]) <> $param_value_set [] THEN
        osp$set_status_abnormal ('CL', cle$incompatible_params_given, 'GROUP=USER', status);
        RETURN;
      IFEND;
      group.group_type := pfc$user;
      group.user_description.family := family;
      group.user_description.user := user;
    IFEND;

  PROCEND handle_group_specification;
?? TITLE := 'handle_access_mode_or_share', EJECT ??

{
{ PURPOSE:
{   This procedure processes the 'ACCESS_MODE' and 'SHARE_MODE' parameters for
{   all commands that contain  one or both of them.  One of the command
{   parameters is processed on each call to this procedure.  For any given
{   call, the caller will use only one of the output parameters; however, both
{   are always built since this procedure doesn't know which one the caller
{   wants.
{
{ NOTE:
{   The procedure assumes that pft$usage_selections and pft$share_selections
{   are "really" the same type.
{

  PROCEDURE handle_access_mode_or_share
    (    usage_share_value: ^clt$data_value;
         selections_kind: (select_usage, select_share, select_permit);
     VAR usage_share_selections: pft$usage_selections;
     VAR permit_selections: pft$permit_selections;
     VAR status: ost$status);

    VAR
      access_mode_value: clt$keyword,
      local_usage_share_value: ^clt$data_value,
      permit_option: pft$permit_selections;


    usage_share_selections := $pft$usage_selections [];
    permit_selections := $pft$permit_selections [];

    local_usage_share_value := usage_share_value;
    WHILE local_usage_share_value <> NIL DO
      access_mode_value := local_usage_share_value^.element_value^.keyword_value;
      IF access_mode_value = 'ALL' THEN
        IF usage_share_value^.link <> NIL THEN
          IF selections_kind <> select_permit THEN
            osp$set_status_abnormal ('CL', cle$all_must_be_used_alone, access_mode_value, status);
            RETURN;
          IFEND;
        IFEND;
        permit_option := -$pft$permit_selections [pfc$control, pfc$cycle];
        usage_share_selections := -$pft$usage_selections [];
      ELSEIF access_mode_value = 'APPEND' THEN
        permit_option := $pft$permit_selections [pfc$append];
        usage_share_selections := usage_share_selections + $pft$usage_selections [pfc$append];
      ELSEIF access_mode_value = 'CONTROL' THEN
        permit_option := $pft$permit_selections [pfc$control];
      ELSEIF access_mode_value = 'CYCLE' THEN
        permit_option := $pft$permit_selections [pfc$cycle];
      ELSEIF access_mode_value = 'EXECUTE' THEN
        permit_option := $pft$permit_selections [pfc$execute];
        usage_share_selections := usage_share_selections + $pft$usage_selections [pfc$execute];
      ELSEIF access_mode_value = 'MODIFY' THEN
        permit_option := $pft$permit_selections [pfc$modify];
        usage_share_selections := usage_share_selections + $pft$usage_selections [pfc$modify];
      ELSEIF access_mode_value = 'NONE' THEN
        IF usage_share_value^.link <> NIL THEN
          osp$set_status_abnormal ('CL', cle$none_must_be_used_alone, access_mode_value, status);
        IFEND;
        RETURN;
      ELSEIF access_mode_value = 'READ' THEN
        permit_option := $pft$permit_selections [pfc$read];
        usage_share_selections := usage_share_selections + $pft$usage_selections [pfc$read];
      ELSEIF access_mode_value = 'SHORTEN' THEN
        permit_option := $pft$permit_selections [pfc$shorten];
        usage_share_selections := usage_share_selections + $pft$usage_selections [pfc$shorten];
      ELSEIF access_mode_value = 'WRITE' THEN
        permit_option := $pft$permit_selections [pfc$append, pfc$modify, pfc$shorten];
        usage_share_selections := usage_share_selections + $pft$usage_selections
              [pfc$append, pfc$modify, pfc$shorten];
      IFEND;
      IF permit_option <= permit_selections THEN
        osp$set_status_abnormal ('CL', cle$redundancy_in_selections, access_mode_value, status);
        RETURN;
      IFEND;
      permit_selections := permit_selections + permit_option;
      local_usage_share_value := local_usage_share_value^.link;
    WHILEND;

  PROCEND handle_access_mode_or_share;

MODEND clm$permanent_file_commands;
*DECK DECK=CLM$PF_DISPLAY_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter: Permanent File Display Commands' ??
MODULE clm$pf_display_commands;

{
{ PURPOSE:
{   This module contains the processors for permanent file commands that display information about
{   catalogs and files.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_file_reference
*copyc clt$path_display_chunks
*copyc clt$parameter_list
*copyc fsc$local
*copyc fse$path_exception_conditions
*copyc nfe$ptf_condition_codes
*copyc oss$job_paged_literal
*copyc ost$status
*copyc pmt$os_name
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$return
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc clp$find_current_block
*copyc clp$get_list_of_$local_files
*copyc clp$get_work_area
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$right_justify_string
*copyc clp$trimmed_string_size
*copyc clv$nil_display_control
*copyc fsp$convert_fs_structure_to_pf
*copyc fsp$path_element
*copyc mmp$create_segment
*copyc mmp$delete_segment
*copyc nfp$check_implicit_access
*copyc nfp$perform_implicit_access
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osv$upper_to_lower
*copyc pfe$external_archive_conditions
*copyc pfp$find_archive_info
*copyc pfp$find_catalog_description
*copyc pfp$find_cycle_array_extended
*copyc pfp$find_cycle_array_version_2
*copyc pfp$find_cycle_directory
*copyc pfp$find_cycle_entry
*copyc pfp$find_direct_info_record
*copyc pfp$find_directory_array
*copyc pfp$find_file_description
*copyc pfp$find_log_array
*copyc pfp$find_next_archive_entry
*copyc pfp$find_next_info_record
*copyc pfp$find_permit_array
*copyc pfp$get_item_info
*copyc pfp$get_multi_item_info
*copyc pfp$utility_attach
*copyc pmp$continue_to_cause
*copyc pmp$date_time_compare
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pmp$get_unique_name


  CONST
    highest_cycle_size = 5, { number of digits in pfc$highest_cycle
    max_class_size = 15; {INTERSTATE_LINK, MEMORY_RESIDENT

  VAR
    class: [STATIC, READ, oss$job_paged_literal] array [rmt$device_class] of record
      size: 1 .. max_class_size,
      value: string (max_class_size),
    recend := [[14, 'CONNECTED_FILE'], [15, 'INTERSTATE_LINK'], [11, 'LOCAL_QUEUE'], [3, 'LOG'],
          [13, 'MAGNETIC_TAPE'], [12, 'MASS_STORAGE'], [15, 'MEMORY_RESIDENT'], [7, 'NETWORK'], [4, 'NULL'],
          [8, 'PIPELINE'], [5, 'RHFAM'], [8, 'TERMINAL']];

?? TITLE := 'Types for display_items scratch segment', EJECT ??

  TYPE
    clt$display_catalog_item_kind = (clc$display_catalog_item, clc$display_file_item, clc$display_cycle_item);

  TYPE
    clt$display_catalog_item = record
      level: pft$array_index,
      name_tab: pft$array_index,
      name: pft$name,
      name_size: ost$name_size,
      size: integer,
      size_completely_known: boolean,
      case kind: clt$display_catalog_item_kind of
      = clc$display_catalog_item =
        number_of_files: integer,
        number_of_catalogs: integer,
      = clc$display_file_item =
        number_of_cycles: 0 .. pfc$maximum_cycle_number,
        highest_cycle_number: pft$cycle_number,
      = clc$display_cycle_item =
        cycle_archive_identification: pft$archive_identification,
        cycle_archived: boolean,
        cycle_data_not_defined: boolean,
        cycle_data_released: boolean,
        cycle_device_class: rmt$device_class,
        cycle_has_been_opened: boolean,
        cycle_number: pft$cycle_number,
        cycles_media_missing: boolean,
        cycles_respf_mod_mismatch: boolean,
        media_image_inconsistent: boolean,
        parent_catalog_restored: boolean,
        volume_unavailable: boolean,
      casend,
    recend;

  TYPE
    clt$display_catalog_items = SEQ ( * );

?? TITLE := 'clp$_display_catalog', EJECT ??

  PROCEDURE [XDCL] clp$_display_catalog
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (clm$disc) display_catalog, disc (
{   catalog, c: file = $working_catalog
{   display_options, display_option, do: key
{       (identifier, id, i)
{       (file, f)
{       (permits, permit, p)
{       (contents, content, c)
{     keyend = identifier
{   output, o: file = $output
{   depth, d: any of
{       key
{         all
{       keyend
{       integer 1..100
{     anyend = 2
{   include_exception_conditions, include_exception_condition, iec: (BY_NAME) key
{       all
{       none
{     keyend = none
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (16),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 11] of clt$keyword_specification,
        default_value: string (10),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: 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$integer_type_qualifier,
        recend,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 27, 15, 47, 48, 955],
    clc$command, 13, 6, 0, 0, 0, 0, 6, 'CLM$DISC'], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CATALOG                        ',clc$nominal_entry, 1],
    ['D                              ',clc$abbreviation_entry, 4],
    ['DEPTH                          ',clc$nominal_entry, 4],
    ['DISPLAY_OPTION                 ',clc$alias_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['IEC                            ',clc$abbreviation_entry, 5],
    ['INCLUDE_EXCEPTION_CONDITION    ',clc$alias_entry, 5],
    ['INCLUDE_EXCEPTION_CONDITIONS   ',clc$nominal_entry, 5],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 16],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 414,
  clc$optional_default_parameter, 0, 10],
{ PARAMETER 3
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 6
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$working_catalog'],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [11], [
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['CONTENT                        ', clc$alias_entry, clc$normal_usage_entry, 4],
    ['CONTENTS                       ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FILE                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ID                             ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['IDENTIFIER                     ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['PERMIT                         ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['PERMITS                        ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ,
    'identifier'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, 100, 10]]
    ,
    '2'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [2], [
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'none'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$catalog = 1,
    p$display_options = 2,
    p$output = 3,
    p$depth = 4,
    p$include_exception_conditions = 5,
    p$status = 6;

  VAR
    pvt: array [1 .. 6] of clt$parameter_value;

*copy clv$display_variables
?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      IF info_segment_pointer.seq_pointer <> NIL THEN
        mmp$delete_segment (info_segment_pointer, 1, handler_status);
        info_segment_pointer.seq_pointer := NIL;
      IFEND;

      IF items_segment_pointer.seq_pointer <> NIL THEN
        mmp$delete_segment (items_segment_pointer, 1, handler_status);
        items_segment_pointer.seq_pointer := NIL;
      IFEND;

      clp$close_display (display_control, handler_status);

      handler_status.normal := TRUE;

    PROCEND abort_handler;
*copy clp$new_page_procedure
?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);


      clp$put_path_reference_subtitle (pvt [p$catalog].value^.file_value^, 'CATALOG ', status);

    PROCEND put_subtitle;
*copy clp$put_path_reference_subtitle
?? OLDTITLE, EJECT ??

    VAR
      cycle_lfn: ost$name,
      default_ring_attributes: amt$ring_attributes,
      depth: pft$array_index,
      directory: pft$p_directory_array,
      display_control: clt$display_control,
      display_item: ^clt$display_catalog_item,
      display_items: ^clt$display_catalog_items,
      evaluated_file_reference: fst$evaluated_file_reference,
      first_path_element_is_$local: boolean,
      group: pft$group,
      include_exception_conditions: boolean,
      info: pft$p_info,
      info_record: pft$p_info_record,
      info_segment_pointer: mmt$segment_pointer,
      info_tab: pft$array_index,
      items_segment_pointer: mmt$segment_pointer,
      local_status: ost$status,
      permits: pft$p_permit_array,
      pf_path: ^pft$path,
      remote: boolean;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    evaluate_path_and_handle_remote ('DISPLAY_CATALOG', pvt [p$output].value^.file_value^,
          pvt [p$catalog].value^.file_value^, ^pvt, evaluated_file_reference, first_path_element_is_$local,
          remote, status);
    IF (NOT status.normal) OR remote THEN
      RETURN;
    IFEND;

    IF evaluated_file_reference.cycle_reference.specification <> fsc$cycle_omitted THEN
      osp$set_status_abnormal ('CL', fse$catalogs_do_not_have_cycles, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, pvt [p$catalog].value^.file_value^, status);
      RETURN;
    IFEND;

    IF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
      osp$set_status_abnormal ('CL', cle$file_position_not_allowed, '', status);
      RETURN;
    IFEND;

    IF first_path_element_is_$local AND (evaluated_file_reference.number_of_path_elements > 1) THEN
      osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_file, '', status);
      RETURN;
    IFEND;

    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    items_segment_pointer.kind := mmc$sequence_pointer;
    items_segment_pointer.seq_pointer := NIL;
    #SPOIL (items_segment_pointer);
    info_segment_pointer.kind := mmc$sequence_pointer;
    info_segment_pointer.seq_pointer := NIL;
    #SPOIL (info_segment_pointer);
    osp$establish_block_exit_hndlr (^abort_handler);

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          default_ring_attributes, display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    clv$titles_built := FALSE;
    clv$subtitles_built := FALSE;
    clv$command_name := 'display_catalog';

    group.group_type := pfc$member;
    group.member_description.family := osc$null_name;
    group.member_description.account := osc$null_name;
    group.member_description.project := osc$null_name;
    group.member_description.user := osc$null_name;

    PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
    fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);

  /main/
    BEGIN
      mmp$create_segment (NIL, mmc$sequence_pointer, 1, info_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      info := info_segment_pointer.seq_pointer;
      RESET info;

      include_exception_conditions := pvt [p$include_exception_conditions].value^.keyword_value = 'ALL';

      IF (pvt [p$display_options].value^.keyword_value = 'CONTENTS') AND
            (NOT first_path_element_is_$local) THEN

        mmp$create_segment (NIL, mmc$sequence_pointer, 1, items_segment_pointer, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        display_items := items_segment_pointer.seq_pointer;
        RESET display_items;

        IF pvt [p$depth].value^.kind = clc$integer THEN
          depth := pvt [p$depth].value^.integer_value.value;
        ELSE
          depth := UPPERVALUE (depth);
        IFEND;

        pmp$get_unique_name (cycle_lfn, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        info_tab := 1;
        get_catalog_info (depth, 1, 1, cycle_lfn, pf_path^, group, info, include_exception_conditions,
              info_tab, display_items, display_item, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        put_display_items (display_items, info_tab, depth, display_control, status);

      ELSEIF (pvt [p$display_options].value^.keyword_value = 'IDENTIFIER') OR
            (pvt [p$display_options].value^.keyword_value = 'CONTENTS') THEN

        IF first_path_element_is_$local THEN
          clp$get_list_of_$local_files (info, status);
        ELSE
          pfp$get_multi_item_info (pf_path^, group, $pft$catalog_info_selections [pfc$catalog_directory],
                $pft$file_info_selections [pfc$file_directory], info, status);
        IFEND;
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        RESET info;
        pfp$find_next_info_record (info, info_record, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        pfp$find_directory_array (info_record, directory, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        display_catalog_id (directory, display_control, status);

      ELSEIF pvt [p$display_options].value^.keyword_value = 'PERMITS' THEN

        IF first_path_element_is_$local THEN
          osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_cat, '', status);
        ELSE
          pfp$get_item_info (pf_path^, group, $pft$catalog_info_selections
                [pfc$catalog_directory, pfc$catalog_permits, pfc$indirect_catalog_permits],
                $pft$file_info_selections [], info, status);
        IFEND;
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        RESET info;
        pfp$find_next_info_record (info, info_record, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        pfp$find_directory_array (info_record, directory, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        IF directory = NIL THEN
          IF UPPERBOUND (pf_path^) = pfc$master_catalog_name_index THEN
            osp$set_status_abnormal ('CL', pfe$unknown_master_catalog, pf_path^ [UPPERBOUND (pf_path^)],
                  status);
          ELSE
            osp$set_status_abnormal ('CL', pfe$unknown_last_subcatalog, pf_path^ [UPPERBOUND (pf_path^)],
                  status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  UPPERBOUND (pf_path^) - pfc$master_catalog_name_index, 10, FALSE, status);
          IFEND;
          EXIT /main/;
        IFEND;
        pfp$find_direct_info_record (^info_record^.body, directory^ [1].info_offset, info_record, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        pfp$find_permit_array (info_record, permits, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        display_permits (permits, display_control, status);

      ELSE

        IF first_path_element_is_$local THEN
          osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_cat, '', status);
        ELSE
          pfp$get_multi_item_info (pf_path^, group, $pft$catalog_info_selections [],
                $pft$file_info_selections [pfc$file_directory, pfc$file_description,
                pfc$file_cycles_version_2, pfc$archive_descriptors], info, status);
        IFEND;
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        RESET info;
        pfp$find_next_info_record (info, info_record, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        pfp$find_directory_array (info_record, directory, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        display_file_description (FALSE, ^info_record^.body, directory, display_control, status);

      IFEND;
    END /main/;

    IF items_segment_pointer.seq_pointer <> NIL THEN
      mmp$delete_segment (items_segment_pointer, 1, local_status);
      items_segment_pointer.seq_pointer := NIL;
      #SPOIL (items_segment_pointer.seq_pointer);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF info_segment_pointer.seq_pointer <> NIL THEN
      mmp$delete_segment (info_segment_pointer, 1, local_status);
      info_segment_pointer.seq_pointer := NIL;
      #SPOIL (info_segment_pointer.seq_pointer);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    clp$close_display (display_control, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND clp$_display_catalog;
?? TITLE := 'clp$_display_catalog_entry', EJECT ??

  PROCEDURE [XDCL] clp$_display_catalog_entry
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (clm$disce) display_catalog_entry, disce (
{   file, f: file = $required
{   display_options, display_option, do: key
{       (descriptor, d)
{       (log, l)
{       (permits, permit, p)
{       (cycles, cycle, c)
{     keyend = descriptor
{   output, o: file = $output
{   depth, d: any of
{       key
{         all
{       keyend
{       integer 1..2
{     anyend = all
{   include_exception_conditions, include_exception_condition, iec: (BY_NAME) key
{       all
{       none
{     keyend = none
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 10] of clt$keyword_specification,
        default_value: string (10),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: 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$integer_type_qualifier,
        recend,
        default_value: string (3),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 26, 13, 13, 35, 583],
    clc$command, 13, 6, 1, 0, 0, 0, 6, 'CLM$DISCE'], [
    ['D                              ',clc$abbreviation_entry, 4],
    ['DEPTH                          ',clc$nominal_entry, 4],
    ['DISPLAY_OPTION                 ',clc$alias_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['IEC                            ',clc$abbreviation_entry, 5],
    ['INCLUDE_EXCEPTION_CONDITION    ',clc$alias_entry, 5],
    ['INCLUDE_EXCEPTION_CONDITIONS   ',clc$nominal_entry, 5],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 377,
  clc$optional_default_parameter, 0, 10],
{ PARAMETER 3
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 6
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [10], [
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['CYCLE                          ', clc$alias_entry, clc$normal_usage_entry, 4],
    ['CYCLES                         ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['DESCRIPTOR                     ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['LOG                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['PERMIT                         ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['PERMITS                        ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ,
    'descriptor'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, 2, 10]]
    ,
    'all'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [2], [
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'none'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$file = 1,
    p$display_options = 2,
    p$output = 3,
    p$depth = 4,
    p$include_exception_conditions = 5,
    p$status = 6;

  VAR
    pvt: array [1 .. 6] of clt$parameter_value;

*copy clv$display_variables
?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF info_segment_pointer.seq_pointer <> NIL THEN
        mmp$delete_segment (info_segment_pointer, 1, ignore_status);
        info_segment_pointer.seq_pointer := NIL;
      IFEND;
      IF items_segment_pointer.seq_pointer <> NIL THEN
        mmp$delete_segment (items_segment_pointer, 1, ignore_status);
        items_segment_pointer.seq_pointer := NIL;
      IFEND;
      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;
*copy clp$new_page_procedure
?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);


      clp$put_path_reference_subtitle (pvt [p$file].value^.file_value^, 'FILE ', status);

    PROCEND put_subtitle;
*copy clp$put_path_reference_subtitle
?? OLDTITLE, EJECT ??

    VAR
      cycle_lfn: ost$name,
      default_ring_attributes: amt$ring_attributes,
      depth: pft$array_index,
      directory: pft$p_directory_array,
      display_control: clt$display_control,
      display_item: ^clt$display_catalog_item,
      display_items: ^clt$display_catalog_items,
      evaluated_file_reference: fst$evaluated_file_reference,
      first_path_element_is_$local: boolean,
      group: pft$group,
      include_exception_conditions: boolean,
      info: pft$p_info,
      info_record: pft$p_info_record,
      info_segment_pointer: mmt$segment_pointer,
      info_tab: pft$array_index,
      items_segment_pointer: mmt$segment_pointer,
      local_status: ost$status,
      logs: pft$p_log_array,
      permits: pft$p_permit_array,
      pf_path: ^pft$path,
      remote: boolean;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    evaluate_path_and_handle_remote ('DISPLAY_CATALOG_ENTRY', pvt [p$output].value^.file_value^,
          pvt [p$file].value^.file_value^, ^pvt, evaluated_file_reference, first_path_element_is_$local,
          remote, status);
    IF (NOT status.normal) OR remote THEN
      RETURN;
    IFEND;

    IF first_path_element_is_$local AND (evaluated_file_reference.number_of_path_elements = 1) THEN
      osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_cat, '', status);
      RETURN;
    IFEND;

    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    items_segment_pointer.kind := mmc$sequence_pointer;
    items_segment_pointer.seq_pointer := NIL;
    #SPOIL (items_segment_pointer);
    info_segment_pointer.kind := mmc$sequence_pointer;
    info_segment_pointer.seq_pointer := NIL;
    #SPOIL (info_segment_pointer);
    osp$establish_block_exit_hndlr (^abort_handler);

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          default_ring_attributes, display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    clv$titles_built := FALSE;
    clv$subtitles_built := FALSE;
    clv$command_name := 'display_catalog_entry';

    group.group_type := pfc$member;
    group.member_description.family := osc$null_name;
    group.member_description.account := osc$null_name;
    group.member_description.project := osc$null_name;
    group.member_description.user := osc$null_name;

    PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
    fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);

  /main/
    BEGIN
      mmp$create_segment (NIL, mmc$sequence_pointer, 1, info_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      info := info_segment_pointer.seq_pointer;
      RESET info;

      IF first_path_element_is_$local THEN
        osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_file, '', status);
        EXIT /main/;
      IFEND;

      include_exception_conditions := pvt [p$include_exception_conditions].value^.keyword_value = 'ALL';

      IF pvt [p$display_options].value^.keyword_value = 'LOG' THEN

        pfp$get_item_info (pf_path^, group, $pft$catalog_info_selections [],
              $pft$file_info_selections [pfc$file_directory, pfc$file_log], info, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        RESET info;
        pfp$find_next_info_record (info, info_record, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        pfp$find_directory_array (info_record, directory, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        IF directory = NIL THEN
          osp$set_status_abnormal ('CL', pfe$unknown_permanent_file, pf_path^ [UPPERBOUND (pf_path^)],
                status);
          EXIT /main/;
        IFEND;
        pfp$find_direct_info_record (^info_record^.body, directory^ [1].info_offset, info_record, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        pfp$find_log_array (info_record, logs, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        display_file_log (logs, display_control, status);

      ELSEIF pvt [p$display_options].value^.keyword_value = 'PERMITS' THEN

        pfp$get_item_info (pf_path^, group, $pft$catalog_info_selections [],
              $pft$file_info_selections [pfc$file_directory, pfc$file_permits, pfc$indirect_file_permits],
              info, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        RESET info;
        pfp$find_next_info_record (info, info_record, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        pfp$find_directory_array (info_record, directory, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        IF directory = NIL THEN
          osp$set_status_abnormal ('CL', pfe$unknown_permanent_file, pf_path^ [UPPERBOUND (pf_path^)],
                status);
          EXIT /main/;
        IFEND;
        pfp$find_direct_info_record (^info_record^.body, directory^ [1].info_offset, info_record, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        pfp$find_permit_array (info_record, permits, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        display_permits (permits, display_control, status);

      ELSE

        pfp$get_item_info (pf_path^, group, $pft$catalog_info_selections [],
              $pft$file_info_selections [pfc$file_directory, pfc$file_description, pfc$file_cycles_version_2,
              pfc$archive_descriptors], info, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        RESET info;
        pfp$find_next_info_record (info, info_record, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        pfp$find_directory_array (info_record, directory, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        IF directory = NIL THEN
          osp$set_status_abnormal ('CL', pfe$unknown_permanent_file, pf_path^ [UPPERBOUND (pf_path^)],
                status);
          EXIT /main/;
        IFEND;

        IF (pvt [p$display_options].value^.keyword_value = 'CYCLES') AND
              (NOT first_path_element_is_$local) THEN

          mmp$create_segment (NIL, mmc$sequence_pointer, 1, items_segment_pointer, status);
          IF NOT status.normal THEN
            EXIT /main/;
          IFEND;
          display_items := items_segment_pointer.seq_pointer;
          RESET display_items;

          IF pvt [p$depth].value^.kind = clc$integer THEN
            depth := pvt [p$depth].value^.integer_value.value;
          ELSE
            depth := 2;
          IFEND;

          pmp$get_unique_name (cycle_lfn, status);
          IF NOT status.normal THEN
            EXIT /main/;
          IFEND;

          info_tab := 1;
          get_file_info (depth, 1, 1, cycle_lfn, pf_path^, ^info_record^.body, directory^ [1].info_offset,
                include_exception_conditions, info_tab, display_items, display_item, status);
          IF NOT status.normal THEN
            EXIT /main/;
          IFEND;

          put_display_items (display_items, info_tab, depth, display_control, status);

        ELSE

          display_file_description (TRUE, ^info_record^.body, directory, display_control, status);

        IFEND;

      IFEND;
    END /main/;

    IF items_segment_pointer.seq_pointer <> NIL THEN
      mmp$delete_segment (items_segment_pointer, 1, local_status);
      items_segment_pointer.seq_pointer := NIL;
      #SPOIL (items_segment_pointer.seq_pointer);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF info_segment_pointer.seq_pointer <> NIL THEN
      mmp$delete_segment (info_segment_pointer, 1, local_status);
      info_segment_pointer.seq_pointer := NIL;
      #SPOIL (info_segment_pointer.seq_pointer);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    clp$close_display (display_control, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND clp$_display_catalog_entry;
?? TITLE := 'evaluate_path_and_handle_remote', EJECT ??
{
{ PURPOSE:
{   This procedure parses a path for a command and determines whether it
{   represents a file on a remote system.  If so it performs the appropriate
{   remote operation; otherwise it returns the evaluated_file_reference for the
{   path along with a boolean indicating whether the path is or is in the
{   $LOCAL catalog.
{

  PROCEDURE evaluate_path_and_handle_remote
    (    command_name: ost$name_reference;
         output_file: fst$file_reference;
         path: fst$file_reference;
         pvt: ^clt$parameter_value_table;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR first_path_element_is_$local: boolean;
     VAR remote: boolean;
     VAR status: ost$status);

    CONST
      remote_path_prefix = ':$LOCAL.',
      remote_path_prefix_size = 8,
      remote_path_size = remote_path_prefix_size + osc$max_name_size;

    VAR
      block: ^clt$block,
      family_name: ost$family_name,
      unique_name: ost$name,
      remote_parameters: array [1 .. 2] of clt$parameter_substitution,
      remote_path: string (remote_path_size),
      work_area: ^^clt$work_area;


    clp$evaluate_file_reference (output_file, $clt$file_ref_parsing_options [], FALSE,
          evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    family_name := fsp$path_element (^evaluated_file_reference, 1) ^;

    nfp$check_implicit_access (family_name, remote, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF remote THEN
      osp$set_status_abnormal (nfc$status_id, nfe$display_output_remote, command_name, status);
      RETURN;
    IFEND;


    clp$evaluate_file_reference (path, $clt$file_ref_parsing_options [], FALSE, evaluated_file_reference,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    family_name := fsp$path_element (^evaluated_file_reference, 1) ^;

    nfp$check_implicit_access (family_name, remote, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF remote THEN
      pmp$get_unique_name (unique_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$get_work_area (#RING (^work_area), work_area, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$find_current_block (block);

      remote_path (1, remote_path_prefix_size) := remote_path_prefix;
      remote_path (remote_path_prefix_size + 1, osc$max_name_size) := unique_name;
      remote_parameters [1].name := 'OUTPUT';
      remote_parameters [1].text := ^remote_path;
      remote_parameters [2].name := 'STATUS';
      remote_parameters [2].text := NIL;

      nfp$perform_implicit_access (family_name, output_file, remote_path, nfc$give, command_name,
            block^.parameters.unbundled_pdt, pvt, ^remote_parameters, work_area^, status);
      RETURN;
    IFEND;

    first_path_element_is_$local := family_name = fsc$local;

  PROCEND evaluate_path_and_handle_remote;
?? TITLE := 'display_catalog_id', EJECT ??

  PROCEDURE display_catalog_id
    (    directory: pft$p_directory_array;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      d: pft$array_index;

    IF directory = NIL THEN
      clp$put_display (display_control, 'EMPTY CATALOG', clc$no_trim, status);
      RETURN;
    IFEND;

    FOR d := LOWERBOUND (directory^) TO UPPERBOUND (directory^) DO
      IF directory^ [d].name_type = pfc$catalog_name THEN
        put_item ('CATALOG: ', directory^ [d].name, display_control, 1, amc$terminate, status);
      ELSE
        put_item ('   FILE: ', directory^ [d].name, display_control, 1, amc$terminate, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND display_catalog_id;
?? TITLE := 'display_permits', EJECT ??

  PROCEDURE display_permits
    (VAR permits: pft$p_permit_array;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    CONST
      alignment = 5;

?? NEWTITLE := 'put', EJECT ??

    PROCEDURE put
      (    item_name: string ( * );
           item_value: string ( * );
           term_option: amt$term_option);

      put_item (item_name, item_value, display_control, alignment, term_option, status);
      IF NOT status.normal THEN
        EXIT display_permits;
      IFEND;

    PROCEND put;
?? TITLE := 'put_group_name', EJECT ??

    PROCEDURE put_group_name
      (    group_name: string ( * ));

      clp$horizontal_tab_display (display_control, alignment - 2, status);
      IF NOT status.normal THEN
        EXIT display_permits;
      IFEND;

      clp$put_partial_display (display_control, 'PERMIT_GROUP: ', clc$no_trim, amc$continue, status);
      IF NOT status.normal THEN
        EXIT display_permits;
      IFEND;

      clp$put_partial_display (display_control, group_name, clc$no_trim, amc$terminate, status);
      IF NOT status.normal THEN
        EXIT display_permits;
      IFEND;

    PROCEND put_group_name;
?? TITLE := 'put_usage_share', EJECT ??

    PROCEDURE put_usage_share;

      VAR
        usage: pft$permit_selections,
        share: pft$share_requirements,
        header: ^string ( * ),
        j: pft$permit_options;

      VAR
        permit_names: [STATIC, READ, oss$job_paged_literal] array [pft$permit_options] of string (7) :=
              ['READ', 'SHORTEN', 'APPEND', 'MODIFY', 'EXECUTE', 'CYCLE', 'CONTROL'];

      usage := permits^ [p].usage_permissions;
      share := permits^ [p].share_requirements;

      PUSH header: [9];
      header^ := 'PERMITS: ';
      IF usage = $pft$permit_selections [] THEN
        put (header^, 'NONE', amc$terminate);
      ELSE

      /put_usage/
        FOR j := LOWERVALUE (pft$permit_options) TO UPPERVALUE (pft$permit_options) DO
          IF j IN usage THEN
            usage := usage - $pft$permit_selections [j];
            IF usage = $pft$permit_selections [] THEN
              put (header^, permit_names [j], amc$terminate);
              EXIT /put_usage/;
            IFEND;
            put (header^, permit_names [j], amc$continue);
            header := ^header^ (1, 2);
            header^ (1, 2) := ', ';
          IFEND;
        FOREND /put_usage/;
      IFEND;

      PUSH header: [7];
      header^ := 'SHARE: ';
      IF share = $pft$share_selections [] THEN
        put (header^, 'NONE', amc$terminate);
      ELSE

      /put_share/
        FOR j := LOWERVALUE (pft$share_options) TO UPPERVALUE (pft$share_options) DO
          IF j IN share THEN
            share := share - $pft$share_selections [j];
            IF share = $pft$share_selections [] THEN
              put (header^, permit_names [j], amc$terminate);
              EXIT /put_share/;
            IFEND;
            put (header^, permit_names [j], amc$continue);
            header := ^header^ (1, 2);
            header^ (1, 2) := ', ';
          IFEND;
        FOREND /put_share/;
      IFEND;

    PROCEND put_usage_share;
?? OLDTITLE, EJECT ??

    VAR
      p: pft$array_index;

    IF permits = NIL THEN
      clp$put_display (display_control, '   NO PERMITS', clc$no_trim, status);
      RETURN;
    IFEND;

    sort_permits (permits);

    FOR p := 1 TO UPPERBOUND (permits^) DO
      CASE permits^ [p].group.group_type OF
      = pfc$public =
        put_group_name ('PUBLIC');
      = pfc$family =
        put_group_name ('FAMILY');
        put ('FAMILY: ', permits^ [p].group.family_description.family, amc$terminate);
      = pfc$account =
        put_group_name ('ACCOUNT');
        put ('FAMILY: ', permits^ [p].group.account_description.family, amc$continue);
        put (', ACCOUNT: ', permits^ [p].group.account_description.account, amc$terminate);
      = pfc$project =
        put_group_name ('PROJECT');
        put ('FAMILY: ', permits^ [p].group.project_description.family, amc$continue);
        put (', ACCOUNT: ', permits^ [p].group.project_description.account, amc$continue);
        put (', PROJECT: ', permits^ [p].group.project_description.project, amc$terminate);
      = pfc$user =
        put_group_name ('USER');
        put ('FAMILY: ', permits^ [p].group.user_description.family, amc$continue);
        put (', USER: ', permits^ [p].group.user_description.user, amc$terminate);
      = pfc$user_account =
        put_group_name ('USER_ACCOUNT');
        put ('FAMILY: ', permits^ [p].group.user_account_description.family, amc$continue);
        put (', ACCOUNT: ', permits^ [p].group.user_account_description.account, amc$continue);
        put (', USER: ', permits^ [p].group.user_account_description.user, amc$terminate);
      = pfc$member =
        put_group_name ('MEMBER');
        put ('FAMILY: ', permits^ [p].group.member_description.family, amc$continue);
        put (', ACCOUNT: ', permits^ [p].group.member_description.account, amc$continue);
        put (', PROJECT: ', permits^ [p].group.member_description.project, amc$continue);
        put (', USER: ', permits^ [p].group.member_description.user, amc$terminate);
      CASEND;
      put_usage_share;
      put_item ('APPLICATION_INFORMATION: ', permits^ [p].application_info, display_control, alignment,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND display_permits;
?? TITLE := 'sort_permits', EJECT ??

  PROCEDURE sort_permits
    (    permit_array: pft$p_permit_array);

    VAR
      gap: integer,
      start: integer,
      current: integer,
      swap: pft$permit_array_entry;

?? NEWTITLE := 'swap_entries', EJECT ??

    FUNCTION swap_entries
      (    current: pft$group;
           current_plus_gap: pft$group): boolean;

      IF current.group_type > current_plus_gap.group_type THEN
        swap_entries := TRUE;
      ELSEIF current.group_type < current_plus_gap.group_type THEN
        swap_entries := FALSE;
      ELSE
        CASE current.group_type OF
        = pfc$public =
          swap_entries := FALSE;
        = pfc$family =
          swap_entries := current.family_description.family > current_plus_gap.family_description.family;
        = pfc$account =
          IF current.account_description.family > current_plus_gap.account_description.family THEN
            swap_entries := TRUE;
          ELSEIF current.account_description.family < current_plus_gap.account_description.family THEN
            swap_entries := FALSE;
          ELSE
            swap_entries := current.account_description.account >
                  current_plus_gap.account_description.account;
          IFEND;
        = pfc$project =
          IF current.project_description.family > current_plus_gap.project_description.family THEN
            swap_entries := TRUE;
          ELSEIF current.project_description.family < current_plus_gap.project_description.family THEN
            swap_entries := FALSE;
          ELSEIF current.project_description.account > current_plus_gap.project_description.account THEN
            swap_entries := TRUE;
          ELSEIF current.project_description.account < current_plus_gap.project_description.account THEN
            swap_entries := FALSE;
          ELSE
            swap_entries := current.project_description.project >
                  current_plus_gap.project_description.project;
          IFEND;
        = pfc$user =
          IF current.user_description.family > current_plus_gap.user_description.family THEN
            swap_entries := TRUE;
          ELSEIF current.user_description.family < current_plus_gap.user_description.family THEN
            swap_entries := FALSE;
          ELSE
            swap_entries := current.user_description.user > current_plus_gap.user_description.user;
          IFEND;
        = pfc$user_account =
          IF current.user_account_description.family > current_plus_gap.user_account_description.family THEN
            swap_entries := TRUE;
          ELSEIF current.user_account_description.family < current_plus_gap.user_account_description.
                family THEN
            swap_entries := FALSE;
          ELSEIF current.user_account_description.account > current_plus_gap.user_account_description.
                account THEN
            swap_entries := TRUE;
          ELSEIF current.user_account_description.account < current_plus_gap.user_account_description.
                account THEN
            swap_entries := FALSE;
          ELSE
            swap_entries := current.user_account_description.user >
                  current_plus_gap.user_account_description.user;
          IFEND;
        = pfc$member =
          IF current.member_description.family > current_plus_gap.member_description.family THEN
            swap_entries := TRUE;
          ELSEIF current.member_description.family < current_plus_gap.member_description.family THEN
            swap_entries := FALSE;
          ELSEIF current.member_description.account > current_plus_gap.member_description.account THEN
            swap_entries := TRUE;
          ELSEIF current.member_description.account < current_plus_gap.member_description.account THEN
            swap_entries := FALSE;
          ELSEIF current.member_description.project > current_plus_gap.member_description.project THEN
            swap_entries := TRUE;
          ELSEIF current.member_description.project < current_plus_gap.member_description.project THEN
            swap_entries := FALSE;
          ELSE
            swap_entries := current.member_description.user > current_plus_gap.member_description.user;
          IFEND;
        CASEND;
      IFEND;

    FUNCEND swap_entries;
?? OLDTITLE, EJECT ??

{ Use shell sort technique.

    gap := UPPERBOUND (permit_array^);
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := 1 TO UPPERBOUND (permit_array^) - gap DO
        current := start;
        WHILE (current > 0) AND swap_entries (permit_array^ [current].group,
              permit_array^ [current + gap].group) DO
          swap := permit_array^ [current];
          permit_array^ [current] := permit_array^ [current + gap];
          permit_array^ [current + gap] := swap;
          current := current - gap;
        WHILEND;
      FOREND;
    WHILEND;

  PROCEND sort_permits;
?? TITLE := 'display_file_log', EJECT ??

  PROCEDURE display_file_log
    (    logs: pft$p_log_array;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    CONST
      alignment = 5;

    VAR
      ignore_status: ost$status,
      str: ost$string,
      l: pft$array_index,
      up: pft$array_index,
      low: pft$array_index;

?? NEWTITLE := 'put', EJECT ??

    PROCEDURE put
      (    item_name: string ( * );
           item_value: string ( * );
           term_option: amt$term_option);

      put_item (item_name, item_value, display_control, alignment, term_option, status);
      IF NOT status.normal THEN
        EXIT display_file_log;
      IFEND;

    PROCEND put;
?? OLDTITLE, EJECT ??

    IF logs = NIL THEN
      clp$put_display (display_control, '   NO LOG ENTRIES', clc$no_trim, status);
      RETURN;
    IFEND;

    sort_log (logs);

    FOR l := 1 TO UPPERBOUND (logs^) DO
      convert_date_time (logs^ [l].access_date_time, TRUE, str);
      put ('DATE AND TIME: ', str.value (1, str.size), amc$continue);

      put (', FAMILY: ', logs^ [l].user_id.family, amc$continue);

      put (', USER: ', logs^ [l].user_id.user, amc$continue);

      clp$convert_integer_to_string (logs^ [l].access_count, 10, FALSE, str, ignore_status);
      put (', ACCESS COUNT: ', str.value (1, str.size), amc$continue);

      clp$convert_integer_to_string (logs^ [l].last_cycle, 10, FALSE, str, ignore_status);
      put (', LAST CYCLE: ', str.value (1, str.size), amc$terminate);
    FOREND;

  PROCEND display_file_log;
?? TITLE := 'sort_log', EJECT ??

  PROCEDURE sort_log
    (    log_array: pft$p_log_array);

    VAR
      gap: integer,
      start: integer,
      current: integer,
      swap: pft$log_array_entry;

?? NEWTITLE := 'swap_entries', EJECT ??

    FUNCTION swap_entries
      (    current: pft$log_array_entry;
           current_plus_gap: pft$log_array_entry): boolean;

      IF current.access_date_time.year < current_plus_gap.access_date_time.year THEN
        swap_entries := TRUE;
      ELSEIF current.access_date_time.year > current_plus_gap.access_date_time.year THEN
        swap_entries := FALSE;
      ELSEIF current.access_date_time.month < current_plus_gap.access_date_time.month THEN
        swap_entries := TRUE;
      ELSEIF current.access_date_time.month > current_plus_gap.access_date_time.month THEN
        swap_entries := FALSE;
      ELSEIF current.access_date_time.day < current_plus_gap.access_date_time.day THEN
        swap_entries := TRUE;
      ELSEIF current.access_date_time.day > current_plus_gap.access_date_time.day THEN
        swap_entries := FALSE;
      ELSEIF current.access_date_time.hour < current_plus_gap.access_date_time.hour THEN
        swap_entries := TRUE;
      ELSEIF current.access_date_time.hour > current_plus_gap.access_date_time.hour THEN
        swap_entries := FALSE;
      ELSEIF current.access_date_time.minute < current_plus_gap.access_date_time.minute THEN
        swap_entries := TRUE;
      ELSEIF current.access_date_time.minute > current_plus_gap.access_date_time.minute THEN
        swap_entries := FALSE;
      ELSEIF current.access_date_time.second < current_plus_gap.access_date_time.second THEN
        swap_entries := TRUE;
      ELSEIF current.access_date_time.second > current_plus_gap.access_date_time.second THEN
        swap_entries := FALSE;
      ELSEIF current.access_date_time.millisecond < current_plus_gap.access_date_time.millisecond THEN
        swap_entries := TRUE;
      ELSEIF current.access_date_time.millisecond > current_plus_gap.access_date_time.millisecond THEN
        swap_entries := FALSE;
      ELSEIF current.user_id.family < current_plus_gap.user_id.family THEN
        swap_entries := TRUE;
      ELSEIF current.user_id.family > current_plus_gap.user_id.family THEN
        swap_entries := FALSE;
      ELSE
        swap_entries := current.user_id.user < current_plus_gap.user_id.user;
      IFEND;

    FUNCEND swap_entries;
?? OLDTITLE, EJECT ??

{ Use shell sort technique.

    gap := UPPERBOUND (log_array^);
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := 1 TO UPPERBOUND (log_array^) - gap DO
        current := start;
        WHILE (current > 0) AND swap_entries (log_array^ [current], log_array^ [current + gap]) DO
          swap := log_array^ [current];
          log_array^ [current] := log_array^ [current + gap];
          log_array^ [current + gap] := swap;
          current := current - gap;
        WHILEND;
      FOREND;
    WHILEND;

  PROCEND sort_log;
?? TITLE := 'display_file_description', EJECT ??

  PROCEDURE display_file_description
    (    describe_individual_file: boolean;
         info: pft$p_info;
         directory: pft$p_directory_array;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    CONST
      alignment = 5;

    VAR
      file_description: pft$p_file_description,
      log: string (5),
      cycles: ^pft$cycle_array_version_2,
      d: pft$array_index,
      info_record: pft$p_info_record,
      ignore_status: ost$status,
      str: ost$string;

?? NEWTITLE := 'put', EJECT ??

    PROCEDURE put
      (    item_name: string ( * );
           item_value: string ( * );
           term_option: amt$term_option);

      put_item (item_name, item_value, display_control, alignment, term_option, status);
      IF NOT status.normal THEN
        EXIT display_file_description;
      IFEND;

    PROCEND put;
?? OLDTITLE, EJECT ??

    IF directory = NIL THEN
      clp$put_display (display_control, 'NO FILES', clc$no_trim, status);
      RETURN;
    IFEND;

    FOR d := LOWERBOUND (directory^) TO UPPERBOUND (directory^) DO
      IF NOT describe_individual_file THEN
        clp$put_display (display_control, directory^ [d].name, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      pfp$find_direct_info_record (info, directory^ [d].info_offset, info_record, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pfp$find_cycle_array_version_2 (info_record, cycles, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF cycles = NIL THEN
        str.value (1, highest_cycle_size - 1) := '';
        str.value (highest_cycle_size) := '0';
      ELSE
        clp$convert_integer_to_rjstring (UPPERBOUND (cycles^),
              10, FALSE, ' ', str.value (1, highest_cycle_size), ignore_status);
      IFEND;
      put ('NUMBER OF CYCLES: ', str.value (1, highest_cycle_size), amc$continue);

      pfp$find_file_description (info_record, file_description, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      put (', ACCOUNT: ', file_description^.charge_id.account, amc$continue);
      put (', PROJECT: ', file_description^.charge_id.project, amc$terminate);

      IF describe_individual_file THEN
        put ('PASSWORD: ', file_description^.password, amc$continue);

        IF file_description^.logging_selection = pfc$log THEN
          log := 'TRUE ';
        ELSE
          log := 'FALSE';
        IFEND;
        put (', LOG SELECTION: ', log, amc$terminate);

        display_cycles (cycles, display_control, status);
      IFEND;
    FOREND;

  PROCEND display_file_description;
?? TITLE := 'display_cycles', EJECT ??

  PROCEDURE display_cycles
    (    cycles: ^pft$cycle_array_version_2;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    CONST
      alignment = 5;

    VAR
      ignore_status: ost$status,
      c: pft$array_index,
      str: ost$string;

?? NEWTITLE := 'put', EJECT ??

    PROCEDURE put
      (    item_name: string ( * );
           item_value: string ( * );
           term_option: amt$term_option);

      put_item (item_name, item_value, display_control, alignment, term_option, status);
      IF NOT status.normal THEN
        EXIT display_cycles;
      IFEND;

    PROCEND put;
?? OLDTITLE, EJECT ??

    IF cycles <> NIL THEN
      sort_cycles (cycles);
      FOR c := 1 TO UPPERBOUND (cycles^) DO
        clp$convert_integer_to_rjstring (cycles^ [c].cycle_number, 10, FALSE, ' ', str.
              value (1, highest_cycle_size), ignore_status);
        put ('CYCLE NUMBER: ', str.value (1, highest_cycle_size), amc$continue);

        clp$convert_integer_to_string (cycles^ [c].cycle_statistics.access_count, 10, FALSE, str,
              ignore_status);
        put (', ACCESS COUNT: ', str.value (1, str.size), amc$continue);

        convert_date_time (cycles^ [c].cycle_statistics.creation_date_time, TRUE, str);
        put (', CREATION DATE AND TIME: ', str.value (1, str.size), amc$continue);

        convert_date_time (cycles^ [c].cycle_statistics.access_date_time, TRUE, str);
        put (', LAST ACCESS DATE AND TIME: ', str.value (1, str.size), amc$continue);

        convert_date_time (cycles^ [c].cycle_statistics.modification_date_time, TRUE, str);
        put (', LAST MODIFICATION DATE AND TIME: ', str.value (1, str.size), amc$continue);

        convert_date_time (cycles^ [c].expiration_date_time, FALSE, str);
        put (', EXPIRATION DATE: ', str.value (1, str.size), amc$continue);

        str.value := class [cycles^ [c].device_class].value;
        str.size := class [cycles^ [c].device_class].size;
        put (', DEVICE_CLASS: ', str.value (1, str.size), amc$terminate);
      FOREND;
    IFEND;

  PROCEND display_cycles;

?? TITLE := 'sort_cycles', EJECT ??

  PROCEDURE sort_cycles
    (    cycles: ^pft$cycle_array_version_2);

    VAR
      gap: integer,
      start: integer,
      current: integer,
      swap: pft$cycle_array_entry_version_2;

{ Use shell sort technique.

    gap := UPPERBOUND (cycles^);
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := 1 TO UPPERBOUND (cycles^) - gap DO
        current := start;
        WHILE (current > 0) AND (cycles^ [current].cycle_number < cycles^ [current + gap].cycle_number) DO
          swap := cycles^ [current];
          cycles^ [current] := cycles^ [current + gap];
          cycles^ [current + gap] := swap;
          current := current - gap;
        WHILEND;
      FOREND;
    WHILEND;

  PROCEND sort_cycles;
?? TITLE := 'sort_cycles_extended', EJECT ??

  PROCEDURE sort_cycles_extended
    (    cycles_extended: pft$p_cycle_directory_array);

    VAR
      gap: integer,
      start: integer,
      current: integer,
      swap: pft$cycle_directory_array_entry;

{ Use shell sort technique.

    gap := UPPERBOUND (cycles_extended^);
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := 1 TO UPPERBOUND (cycles_extended^) - gap DO
        current := start;
        WHILE (current > 0) AND (cycles_extended^ [current].cycle_number <
              cycles_extended^ [current + gap].cycle_number) DO
          swap := cycles_extended^ [current];
          cycles_extended^ [current] := cycles_extended^ [current + gap];
          cycles_extended^ [current + gap] := swap;
          current := current - gap;
        WHILEND;
      FOREND;
    WHILEND;

  PROCEND sort_cycles_extended;
?? TITLE := 'put_item', EJECT ??

  PROCEDURE put_item
    (    item_name: string ( * );
         item_value: string ( * );
     VAR display_control: clt$display_control;
         alignment: ost$string_index;
         term_option: amt$term_option;
     VAR status: ost$status);

    VAR
      item_name_index: ost$string_index,
      item_name_size: ost$string_size,
      item_value_size: ost$string_size;

    item_name_index := 1;
    item_name_size := STRLENGTH (item_name);
    item_value_size := size (item_value);

    IF item_name (1, 2) = ', ' THEN
      clp$put_partial_display (display_control, ', ', clc$no_trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      item_name_index := 3;
      item_name_size := item_name_size - 2;
    IFEND;

    IF display_control.column_number = 1 THEN
      clp$horizontal_tab_display (display_control, alignment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSEIF (display_control.column_number + item_name_size + item_value_size) >
          display_control.page_width THEN
      clp$new_display_line (display_control, 0, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$horizontal_tab_display (display_control, alignment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    clp$put_partial_display (display_control, item_name (item_name_index, item_name_size), clc$no_trim,
          amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$put_partial_display (display_control, item_value (1, item_value_size), clc$no_trim, term_option,
          status);

  PROCEND put_item;
?? TITLE := 'convert_date_time', EJECT ??

  PROCEDURE convert_date_time
    (    date_time: ost$date_time;
         include_time: boolean;
     VAR str: ost$string);

    VAR
      date: ost$date,
      time: ost$time,
      status: ost$status;

    IF (date_time.year >= UPPERVALUE (date_time.year)) AND
          (date_time.month >= UPPERVALUE (date_time.month)) AND
          (date_time.day >= UPPERVALUE (date_time.day)) AND (date_time.hour >=
          UPPERVALUE (date_time.hour)) AND (date_time.minute >= UPPERVALUE (date_time.minute)) AND
          (date_time.second >= UPPERVALUE (date_time.second)) AND
          (date_time.millisecond >= UPPERVALUE (date_time.millisecond)) THEN
      str.size := 4;
      str.value := 'NONE';
      RETURN;
    IFEND;

    pmp$format_compact_date (date_time, osc$iso_date, date, status);
    IF status.normal THEN
      str.size := STRLENGTH (date.iso);
      str.value (1, STRLENGTH (date.iso)) := date.iso;
    ELSE
      str.size := 4;
      str.value (1, 4) := '????';
    IFEND;

    IF include_time THEN
      str.value (str.size + 1) := ' ';
      pmp$format_compact_time (date_time, osc$millisecond_time, time, status);
      IF status.normal THEN
        str.value (str.size + 2, STRLENGTH (time.millisecond)) := time.millisecond;
        str.size := str.size + 1 + STRLENGTH (time.millisecond);
      ELSE
        str.value (str.size + 2, 4) := '????';
        str.size := str.size + 1 + 4;
      IFEND;
    IFEND;

  PROCEND convert_date_time;

?? TITLE := 'size', EJECT ??

  FUNCTION size
    (    str: string ( * )): integer;

    VAR
      str_length: ost$string_size;

    str_length := STRLENGTH (str);
    WHILE (str_length > 0) AND (str (str_length) = ' ') DO
      str_length := str_length - 1;
    WHILEND;
    size := str_length;

  FUNCEND size;
?? TITLE := 'get_catalog_info', EJECT ??

  PROCEDURE get_catalog_info
    (    depth: pft$array_index;
         level: pft$array_index;
         name_tab: pft$array_index;
         cycle_lfn: amt$local_file_name;
         path: pft$path;
         group: pft$group;
         info: pft$p_info;
         include_exception_conditions: boolean;
     VAR info_tab {input, output} : pft$array_index;
     VAR display_items {input, output} : ^clt$display_catalog_items;
     VAR catalog_item: ^clt$display_catalog_item;
     VAR status: ost$status);

    VAR
      item: ^clt$display_catalog_item,
      item_info: pft$p_info,
      item_path: ^pft$path,
      info_record: pft$p_info_record,
      directory: pft$p_directory_array,
      name_size: ost$name_size,
      i: pft$array_index;

    status.normal := TRUE;

    name_size := osc$max_name_size;
    WHILE (name_size > 0) AND (path [UPPERBOUND (path)] (name_size) = ' ') DO
      name_size := name_size - 1;
    WHILEND;

    IF level <= depth THEN
      IF (name_tab + name_size) > info_tab THEN
        info_tab := name_tab + name_size;
      IFEND;
    IFEND;

    NEXT catalog_item IN display_items;
    catalog_item^.level := level;
    catalog_item^.name_tab := name_tab;
    #TRANSLATE (osv$upper_to_lower, path [UPPERBOUND (path)], catalog_item^.name);
    catalog_item^.name_size := name_size;
    catalog_item^.size := 0;
    catalog_item^.size_completely_known := TRUE;
    catalog_item^.kind := clc$display_catalog_item;
    catalog_item^.number_of_files := 0;
    catalog_item^.number_of_catalogs := 0;

    item_info := info;
    pfp$get_multi_item_info (path, group, $pft$catalog_info_selections [pfc$catalog_directory],
          $pft$file_info_selections [pfc$file_directory, pfc$file_description, pfc$file_cycles_version_2,
          pfc$archive_descriptors], item_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    item_info := info;
    pfp$find_next_info_record (item_info, info_record, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pfp$find_directory_array (info_record, directory, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF directory = NIL THEN
      RETURN;
    IFEND;

    PUSH item_path: [1 .. UPPERBOUND (path) + 1];
    FOR i := 1 TO UPPERBOUND (path) DO
      item_path^ [i] := path [i];
    FOREND;

    FOR i := 1 TO UPPERBOUND (directory^) DO
      item_path^ [UPPERBOUND (item_path^)] := directory^ [i].name;
      IF directory^ [i].name_type = pfc$file_name THEN
        catalog_item^.number_of_files := catalog_item^.number_of_files + 1;
        get_file_info (depth, level + 1, name_tab + 2, cycle_lfn, item_path^, ^info_record^.body,
              directory^ [i].info_offset, include_exception_conditions, info_tab, display_items, item,
              status);
      ELSE
        catalog_item^.number_of_catalogs := catalog_item^.number_of_catalogs + 1;
        get_catalog_info (depth, level + 1, name_tab + 2, cycle_lfn, item_path^, group, item_info,
              include_exception_conditions, info_tab, display_items, item, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      catalog_item^.size := catalog_item^.size + item^.size;
      IF NOT item^.size_completely_known THEN
        catalog_item^.size_completely_known := FALSE;
      IFEND;
    FOREND;

  PROCEND get_catalog_info;
?? TITLE := 'get_file_info', EJECT ??

  PROCEDURE get_file_info
    (    depth: pft$array_index;
         level: pft$array_index;
         name_tab: pft$array_index;
         cycle_lfn: amt$local_file_name;
         path: pft$path;
         info: pft$p_info;
         info_offset: pft$info_offset;
         include_exception_conditions: boolean;
     VAR info_tab {input, output} : pft$array_index;
     VAR display_items {input, output} : ^clt$display_catalog_items;
     VAR file_item: ^clt$display_catalog_item;
     VAR status: ost$status);

    VAR
      archive_info_record: pft$p_info_record,
      item: ^clt$display_catalog_item,
      info_record: pft$p_info_record,
      file_description: pft$p_file_description,
      cycles: ^pft$cycle_array_version_2,
      cycles_extended: pft$p_cycle_directory_array,
      cycle_str: ost$string,
      directory: pft$p_directory_array,
      name_size: ost$name_size,
      i: pft$array_index,
      p_cycle_array_extended_record: pft$p_info_record;

    status.normal := TRUE;

    name_size := osc$max_name_size;
    WHILE (name_size > 0) AND (path [UPPERBOUND (path)] (name_size) = ' ') DO
      name_size := name_size - 1;
    WHILEND;

    IF level <= depth THEN
      IF (name_tab + name_size) > info_tab THEN
        info_tab := name_tab + name_size;
      IFEND;
    IFEND;

    NEXT file_item IN display_items;
    file_item^.level := level;
    file_item^.name_tab := name_tab;
    #TRANSLATE (osv$upper_to_lower, path [UPPERBOUND (path)], file_item^.name);
    file_item^.name_size := name_size;
    file_item^.size := 0;
    file_item^.size_completely_known := TRUE;
    file_item^.kind := clc$display_file_item;
    file_item^.number_of_cycles := 0;
    file_item^.highest_cycle_number := 1;

    pfp$find_direct_info_record (info, info_offset, info_record, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    archive_info_record := info_record;

    pfp$find_cycle_array_version_2 (info_record, cycles, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycles = NIL THEN
      RETURN;
    IFEND;

    pfp$find_file_description (info_record, file_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$find_cycle_array_extended (archive_info_record, p_cycle_array_extended_record, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$find_cycle_directory (p_cycle_array_extended_record, cycles_extended, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sort_cycles (cycles);

    sort_cycles_extended (cycles_extended);

    file_item^.number_of_cycles := UPPERBOUND (cycles^);
    file_item^.highest_cycle_number := cycles^ [1].cycle_number;
    cycle_str.size := 0;

    FOR i := 1 TO UPPERBOUND (cycles^) DO
      pfp$find_direct_info_record (^p_cycle_array_extended_record^.body, cycles_extended^ [i].info_offset,
            archive_info_record, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      get_cycle_info (depth, level + 1, name_tab, cycle_lfn, path, cycles^ [i], file_description^.password,
            archive_info_record, include_exception_conditions, cycle_str, info_tab, display_items, item,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      file_item^.size := file_item^.size + item^.size;
      IF NOT item^.size_completely_known THEN
        file_item^.size_completely_known := FALSE;
      IFEND;
    FOREND;

  PROCEND get_file_info;
?? TITLE := 'get_cycle_info', EJECT ??

  PROCEDURE get_cycle_info
    (    depth: pft$array_index;
         level: pft$array_index;
         name_tab: pft$array_index;
         cycle_lfn: amt$local_file_name;
         path: pft$path;
         cycle_array_entry: pft$cycle_array_entry_version_2,
         password: pft$password;
         archive_info: pft$p_info_record;
         include_exception_conditions: boolean;
     VAR cycle_str {input, output} : ost$string;
     VAR info_tab {input, output} : pft$array_index;
     VAR display_items {input, output} : ^clt$display_catalog_items;
     VAR cycle_item: ^clt$display_catalog_item;
     VAR status: ost$status);

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF cycle_attached THEN
        amp$return (cycle_lfn, ignore_status);
        cycle_attached := FALSE;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    VAR
      archive_identification: pft$archive_identification,
      archive_status: ost$status,
      attach_status: ost$status,
      compare_status: ost$status,
      comparison_result: pmt$comparison_result,
      cycle_attached: boolean,
      cycle_damage_symptoms: fst$cycle_damage_symptoms,
      cycle_selector: pft$cycle_selector,
      data_modification_date_time: ost$date_time,
      existing_file: boolean,
      file_attributes: array [1 .. 1] of amt$get_item,
      get_file_status: ost$status,
      i: pft$array_index,
      ignore_contains_data: boolean,
      ignore_local_file: boolean,
      ignore_status: ost$status,
      later: boolean,
      p_archive_entry: pft$p_archive_array_entry,
      p_archive_group: pft$p_info_record,
      p_archive_list: pft$p_info_record,
      p_archive_media: pft$p_amd,
      p_info: pft$p_info,
      returned_cycle_number: pft$cycle_number,
      stale_cycle_entry: boolean;

    p_archive_list := NIL;
    later := TRUE;
    status.normal := TRUE;

    edit_integer (cycle_array_entry.cycle_number, TRUE, cycle_str);

    NEXT cycle_item IN display_items;
    cycle_item^.level := level;
    cycle_item^.name_tab := name_tab;
    cycle_item^.name := '--  cycle';
    cycle_item^.name (11, cycle_str.size) := cycle_str.value (1, cycle_str.size);
    cycle_item^.name_size := 10 + cycle_str.size;
    cycle_item^.size := 0;
    cycle_item^.size_completely_known := TRUE;
    cycle_item^.kind := clc$display_cycle_item;
    cycle_item^.cycle_number := cycle_array_entry.cycle_number;
    cycle_item^.cycle_archived := FALSE;
    cycle_item^.cycle_data_not_defined := FALSE;
    cycle_item^.cycle_data_released := FALSE;
    cycle_item^.cycle_device_class := cycle_array_entry.device_class;
    cycle_item^.cycle_has_been_opened := TRUE;
    cycle_item^.cycles_media_missing := FALSE;
    cycle_item^.cycles_respf_mod_mismatch := FALSE;
    cycle_item^.media_image_inconsistent := FALSE;
    cycle_item^.parent_catalog_restored := FALSE;
    cycle_item^.volume_unavailable := FALSE;

    IF level <= depth THEN
      IF (name_tab + cycle_item^.name_size) > info_tab THEN
        info_tab := name_tab + cycle_item^.name_size;
      IFEND;
    IFEND;

    pfp$find_archive_info (archive_info, p_archive_list, archive_status);
    IF status.normal AND (p_archive_list <> NIL) THEN
      p_info := ^p_archive_list^.body;
      archive_identification.application_identifier := osc$null_name;
      archive_identification.media_identifier.media_device_class := osc$null_name;
      archive_identification.media_identifier.media_volume_identifier := '';
      IF cycle_array_entry.data_modification_date_time.year > 0 THEN
        data_modification_date_time := cycle_array_entry.data_modification_date_time;
      ELSE
        data_modification_date_time := cycle_array_entry.cycle_statistics.modification_date_time;
      IFEND;
    /search_archive_list/
      REPEAT
        pfp$find_next_archive_entry (archive_identification, p_info, p_archive_group, p_archive_entry,
              p_archive_media, archive_status);
        IF archive_status.normal AND (p_archive_entry <> NIL) THEN
          pmp$date_time_compare (p_archive_entry^.archive_date_time, data_modification_date_time,
                comparison_result, archive_status);
          IF archive_status.normal AND (comparison_result = pmc$left_is_greater) THEN
            cycle_item^.cycle_archived := TRUE;
            cycle_item^.cycle_archive_identification := p_archive_entry^.archive_identification;
            EXIT /search_archive_list/;
          IFEND;
        IFEND;
      UNTIL (NOT archive_status.normal) OR (p_archive_entry = NIL);
    IFEND;

    IF cycle_array_entry.data_modification_date_time.year > 0 THEN
      pmp$date_time_compare (cycle_array_entry.data_modification_date_time,
            cycle_array_entry.cycle_statistics.modification_date_time, comparison_result, compare_status);
      IF NOT compare_status.normal THEN
        stale_cycle_entry := TRUE;
      ELSE
        stale_cycle_entry := comparison_result = pmc$right_is_greater;
      IFEND;
    ELSE
      stale_cycle_entry := TRUE;
    IFEND;

    cycle_attached := FALSE;
    #SPOIL (cycle_attached);
    IF stale_cycle_entry OR include_exception_conditions THEN
      osp$establish_block_exit_hndlr (^abort_handler);
      cycle_selector.cycle_option := pfc$specific_cycle;
      cycle_selector.cycle_number := cycle_array_entry.cycle_number;
      pfp$utility_attach (cycle_lfn, path, cycle_selector, password, $pft$usage_selections [],
            -$pft$share_selections [], pfc$no_wait, $fst$cycle_damage_symptoms [], cycle_damage_symptoms,
            returned_cycle_number, attach_status);
      IF attach_status.normal THEN
        cycle_attached := TRUE;
        #SPOIL (cycle_attached);
        file_attributes [1].key := amc$file_length;
        amp$get_file_attributes (cycle_lfn, file_attributes, ignore_local_file, existing_file,
              ignore_contains_data, get_file_status);
        amp$return (cycle_lfn, ignore_status);
        cycle_attached := FALSE;
        #SPOIL (cycle_attached);
      IFEND;
      osp$disestablish_cond_handler;

      IF attach_status.normal THEN
        IF get_file_status.normal THEN
          cycle_item^.cycle_has_been_opened := existing_file;
          cycle_item^.size := file_attributes [1].file_length;
        ELSE
          cycle_item^.size_completely_known := FALSE;
        IFEND;
      ELSE
        cycle_item^.size_completely_known := FALSE;
        CASE attach_status.condition OF
        = pfe$cycles_media_missing =
          IF include_exception_conditions THEN
            cycle_item^.cycles_media_missing := TRUE;
          IFEND;
        = pfe$cycle_data_resides_offline =
          cycle_item^.cycle_archived := TRUE;
          cycle_item^.cycle_data_released := TRUE;
          cycle_item^.size := p_archive_entry^.file_size;
          cycle_item^.size_completely_known := TRUE;
        = pfe$media_image_inconsistent =
          IF include_exception_conditions THEN
            cycle_item^.media_image_inconsistent := TRUE;
          IFEND;
        = pfe$parent_catalog_restored =
          IF include_exception_conditions THEN
            cycle_item^.parent_catalog_restored := TRUE;
          IFEND;
        = pfe$respf_modification_mismatch =
          IF include_exception_conditions THEN
            cycle_item^.cycles_respf_mod_mismatch := TRUE;
          IFEND;
        = pfe$undefined_data =
          IF include_exception_conditions THEN
            cycle_item^.cycle_data_not_defined := TRUE;
          IFEND;
        = pfe$volume_not_online =
          IF include_exception_conditions THEN
            cycle_item^.cycles_media_missing := TRUE;
          IFEND;
        = pfe$volume_unavailable =
          IF include_exception_conditions THEN
            cycle_item^.volume_unavailable := TRUE;
          IFEND;
        ELSE
          ;
        CASEND;
      IFEND;
    ELSE
      cycle_item^.size := cycle_array_entry.eoi;
      IF cycle_array_entry.data_residence = pfc$offline_data THEN
        cycle_item^.cycle_archived := TRUE;
        cycle_item^.cycle_data_released := TRUE;
        cycle_item^.size_completely_known := TRUE;
      IFEND;
    IFEND;

  PROCEND get_cycle_info;

?? TITLE := 'put_display_items', EJECT ??

  PROCEDURE put_display_items
    (    display_items: ^clt$display_catalog_items;
         info_tab: pft$array_index;
         depth: pft$array_index;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      catalogs: [STATIC, READ, oss$job_paged_literal] string (9) := ' catalogs',
      files: [STATIC, READ, oss$job_paged_literal] string (6) := ' files';

    VAR
      highest_cycle_number: pft$cycle_number,
      item: ^clt$display_catalog_item,
      items: ^clt$display_catalog_items,
      line: string (osc$max_string_size),
      line_size: integer,
      size_str: ost$string,
      the_end: ^clt$display_catalog_item,
      trimmed_string_size: integer;

    status.normal := TRUE;

    size_str.size := 0;

    items := display_items;
    NEXT the_end IN items;
    RESET items;

  /display_loop/
    WHILE TRUE DO
      NEXT item IN items;
      IF item = the_end THEN
        EXIT /display_loop/;
      IFEND;

      IF item^.level > depth THEN
        CYCLE /display_loop/;
      IFEND;

      edit_integer (item^.size, item^.size_completely_known, size_str);

      clp$horizontal_tab_display (display_control, item^.name_tab, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, item^.name (1, item^.name_size), clc$no_trim, amc$continue,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$horizontal_tab_display (display_control, info_tab + 2, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE item^.kind OF

      = clc$display_catalog_item =
        IF (item^.number_of_files + item^.number_of_catalogs) = 0 THEN
          size_str.value := '';
          STRINGREP (line, line_size, size_str.value (1, size_str.size), '       -- empty catalog');
        ELSEIF item^.number_of_files = 0 THEN
          STRINGREP (line, line_size, size_str.value (1, size_str.size), ' bytes in',
                item^.number_of_catalogs, catalogs (1, 8 + $INTEGER (item^.number_of_catalogs > 1)));
        ELSEIF item^.number_of_catalogs = 0 THEN
          STRINGREP (line, line_size, size_str.value (1, size_str.size), ' bytes in', item^.number_of_files,
                files (1, 5 + $INTEGER (item^.number_of_files > 1)));
        ELSE
          STRINGREP (line, line_size, size_str.value (1, size_str.size), ' bytes in', item^.number_of_files,
                files (1, 5 + $INTEGER (item^.number_of_files > 1)), ' and', item^.number_of_catalogs,
                catalogs (1, 8 + $INTEGER (item^.number_of_catalogs > 1)));
        IFEND;

      = clc$display_file_item =
        IF item^.number_of_cycles = 1 THEN
          highest_cycle_number := item^.highest_cycle_number;
          NEXT item IN items;

          IF highest_cycle_number = 1 THEN
            IF item^.cycle_device_class = rmc$mass_storage_device THEN
              IF item^.cycle_data_released THEN
                trimmed_string_size := clp$trimmed_string_size
                      (item^.cycle_archive_identification.media_identifier.media_device_class);
                STRINGREP (line, line_size, size_str.value (1, size_str.size), ' bytes on ',
                      item^.cycle_archive_identification.media_identifier.media_device_class
                      (1, trimmed_string_size));
              ELSE
                IF item^.cycle_archived THEN
                  trimmed_string_size := clp$trimmed_string_size
                        (item^.cycle_archive_identification.media_identifier.media_device_class);
                  STRINGREP (line, line_size, size_str.value (1, size_str.size), ' bytes duplicated on ',
                        item^.cycle_archive_identification.media_identifier.media_device_class
                        (1, trimmed_string_size));
                ELSE
                  STRINGREP (line, line_size, size_str.value (1, size_str.size), ' bytes');
                IFEND;
              IFEND;
            ELSEIF item^.cycle_device_class = rmc$magnetic_tape_device THEN
              size_str.value := '';
              STRINGREP (line, line_size, size_str.value (1, size_str.size),
                    '       -- device_class is magnetic_tape');
            IFEND;
          ELSE
            IF item^.cycle_device_class = rmc$mass_storage_device THEN
              IF item^.cycle_data_released THEN
                trimmed_string_size := clp$trimmed_string_size
                      (item^.cycle_archive_identification.media_identifier.media_device_class);
                STRINGREP (line, line_size, size_str.value (1, size_str.size), ' bytes in cycle',
                      highest_cycle_number, ' on ',
                      item^.cycle_archive_identification.media_identifier.media_device_class
                      (1, trimmed_string_size));
              ELSE
                IF item^.cycle_archived THEN
                  trimmed_string_size := clp$trimmed_string_size
                        (item^.cycle_archive_identification.media_identifier.media_device_class);
                  STRINGREP (line, line_size, size_str.value (1, size_str.size), ' bytes in cycle',
                        highest_cycle_number, ' duplicated on ',
                        item^.cycle_archive_identification.media_identifier.media_device_class
                        (1, trimmed_string_size));
                ELSE
                  STRINGREP (line, line_size, size_str.value (1, size_str.size), ' bytes in cycle',
                        highest_cycle_number);
                IFEND;
              IFEND;
            ELSEIF item^.cycle_device_class = rmc$magnetic_tape_device THEN
              STRINGREP (line, line_size, '        cycle', highest_cycle_number,
                    ' -- device_class is magnetic_tape');
            IFEND;
          IFEND;

          IF (NOT item^.cycle_has_been_opened) OR (item^.cycles_media_missing) OR
                (item^.cycles_respf_mod_mismatch) OR (item^.media_image_inconsistent) OR
                (item^.parent_catalog_restored) OR (item^.volume_unavailable) OR
                (item^.cycle_data_not_defined) THEN
            RESET items TO item;
          IFEND;
        ELSE
          STRINGREP (line, line_size, size_str.value (1, size_str.size), ' bytes in', item^.number_of_cycles,
                ' cycles');
        IFEND;

      = clc$display_cycle_item =
        IF item^.cycle_device_class = rmc$mass_storage_device THEN
          IF item^.cycles_media_missing THEN
            size_str.value := '';
            STRINGREP (line, line_size, size_str.value (1, size_str.size), '       -- media missing');
          ELSEIF item^.cycles_respf_mod_mismatch THEN
            size_str.value := '';
            STRINGREP (line, line_size, size_str.value (1, size_str.size),
                  '       -- respf modification mismatch');
          ELSEIF item^.media_image_inconsistent THEN
            size_str.value := '';
            STRINGREP (line, line_size, size_str.value (1, size_str.size),
                  '       -- media image inconsistent');
          ELSEIF item^.parent_catalog_restored THEN
            size_str.value := '';
            STRINGREP (line, line_size, size_str.value (1, size_str.size),
                  '       -- parent catalog restored');
          ELSEIF item^.volume_unavailable THEN
            size_str.value := '';
            STRINGREP (line, line_size, size_str.value (1, size_str.size), '       -- volume unavailable');
          ELSEIF item^.cycle_data_not_defined THEN
            size_str.value := '';
            STRINGREP (line, line_size, size_str.value (1, size_str.size), '       -- no data defined');
          ELSEIF item^.cycle_has_been_opened THEN
            IF item^.cycle_data_released THEN
              trimmed_string_size := clp$trimmed_string_size
                    (item^.cycle_archive_identification.media_identifier.media_device_class);
              STRINGREP (line, line_size, size_str.value (1, size_str.size), ' bytes on ',
                    item^.cycle_archive_identification.media_identifier.media_device_class
                    (1, trimmed_string_size));
            ELSE
              IF item^.cycle_archived THEN
                trimmed_string_size := clp$trimmed_string_size
                      (item^.cycle_archive_identification.media_identifier.media_device_class);
                STRINGREP (line, line_size, size_str.value (1, size_str.size), ' bytes duplicated on ',
                      item^.cycle_archive_identification.media_identifier.media_device_class
                      (1, trimmed_string_size));
              ELSE
                STRINGREP (line, line_size, size_str.value (1, size_str.size), ' bytes');
              IFEND;
            IFEND;
          ELSE
            size_str.value := '';
            STRINGREP (line, line_size, size_str.value (1, size_str.size), '       -- cycle never opened');
          IFEND;
        ELSEIF item^.cycle_device_class = rmc$magnetic_tape_device THEN
          size_str.value := '';
          STRINGREP (line, line_size, size_str.value (1, size_str.size),
                '       -- device_class is magnetic_tape');
        IFEND;
      CASEND;

      clp$put_partial_display (display_control, line (1, line_size), clc$no_trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    WHILEND /display_loop/;

  PROCEND put_display_items;
?? TITLE := 'edit_size', EJECT ??

  PROCEDURE edit_integer
    (    int: integer;
         value_completely_known: boolean;
     VAR str {input, output} : ost$string);

    VAR
      ignore_status: ost$status,
      temp_str: ost$string,
      i: ost$string_size,
      j: ost$string_size;

    clp$convert_integer_to_string (int, 10, FALSE, temp_str, ignore_status);
    IF str.size < (temp_str.size + ((temp_str.size - 1) DIV 3) + ($INTEGER (NOT value_completely_known) * 2))
          THEN
      str.size := temp_str.size + ((temp_str.size - 1) DIV 3) + ($INTEGER (NOT value_completely_known) * 2);
    IFEND;
    j := str.size;
    FOR i := temp_str.size DOWNTO 1 DO
      str.value (j) := temp_str.value (i);
      j := j - 1;
      IF (i > 1) AND (((temp_str.size - i) MOD 3) = 2) THEN
        str.value (j) := ',';
        j := j - 1;
      IFEND;
    FOREND;
    IF NOT value_completely_known THEN
      str.value (j - 1, 2) := '> ';
      j := j - 2;
    IFEND;
    str.value (1, j) := '';

  PROCEND edit_integer;

MODEND clm$pf_display_commands;
*DECK DECK=CLM$PROCESS_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Process Commands' ??
MODULE clm$process_commands;

{
{ PURPOSE:
{   This module contains the routines that interpret an individual command or control statement.
{   This entails parsing the command image, using the command list to search for the appropriate processor,
{   and passing control to that processor in the appropriate fashion (call, load and call, execute, or
{   PROCedure call.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc ame$lfn_program_actions
*copyc clc$command_cleanup_completed
*copyc clc$compiling_for_test_harness
*copyc clc$exiting_condition
*copyc clc$standard_file_names
*ELSE
*copyc cle$command_terminated
*IFEND
*copyc cle$ecc_command_processing
*IF NOT $true(osv$unix)
*copyc cle$ecc_control_statement
*copyc cle$ecc_lexical
*IFEND
*copyc cle$ecc_utilities
*IF NOT $true(osv$unix)
*copyc cle$unexpected_call_to
*ELSE
*copyc cle$not_supported
*copyc cle$welcome_banner
*IFEND
*copyc cle$work_area_overflow
*IF NOT $true(osv$unix)
*copyc clk$process_command
*copyc cll$comment_command
*copyc clt$async_command_parameters
*ELSE
*copyc clt$command_library_search_info
*IFEND
*copyc clt$command_line
*copyc clt$command_line_index
*copyc clt$command_line_size
*copyc clt$command_list
*copyc clt$command_or_function_source
*IF NOT $true(osv$unix)
*copyc clt$command_resource_statistics
*IFEND
*copyc clt$i_parameter_list_contents
*copyc clt$interpreter_modes
*copyc clt$lexical_unit_kinds
*IF NOT $true(osv$unix)
*copyc clt$scl_procedure
*copyc clt$scl_procedure_header
*copyc cyd$run_time_error_condition
*copyc fsc$compiling_for_test_harness
*copyc ife$error_codes
*copyc llt$command_description
*copyc llt$program_description
*copyc loc$task_services_library_name
*ELSE
*copyc clt$control_statement_desc
*copyc clt$when_condition
*copyc clt$work_area
*copyc fst$path_size
*IFEND
*copyc ost$caller_identifier
*copyc ost$status
*IF NOT $true(osv$unix)
*copyc pfe$error_condition_codes
*copyc ptk$performance_keypoints
*IFEND
?? POP ??
*copyc amv$nil_file_identifier
*IF NOT $true(osv$unix)
*copyc bap$process_pt_request
*copyc clp$access_command_file
*copyc clp$append_status_parse_state
*copyc clp$assignment_statement
*copyc clp$case_selection_statement
*copyc clp$change_variable
*copyc clp$check_name_for_control
*copyc clp$close_command_file
*copyc clp$close_command_library
*copyc clp$construct_path_handle_name
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_str_to_path_handle
*copyc clp$convert_string_to_file
*copyc clp$echo_command
*copyc clp$echo_trace_information
*copyc clp$execute_named_task
*copyc clp$find_cmnd_or_func_in_prog
*IFEND
*copyc clp$find_command_list
*IF NOT $true(osv$unix)
*copyc clp$find_connected_files
*IFEND
*copyc clp$find_current_block
*copyc clp$find_utility_block
*copyc clp$find_working_catalog
*IF NOT $true(osv$unix)
*copyc clp$get_command_statistics
*copyc clp$get_fs_path_string
*copyc clp$get_log_secure_parameters
*IFEND
*copyc clp$get_work_area
*copyc clp$ignore_rest_of_file
*copyc clp$initialize_application_info
*copyc clp$initialize_parse_state
*IF NOT $true(osv$unix)
*copyc clp$load_from_library
*copyc clp$load_system_entry_point
*copyc clp$log_command_line
*IFEND
*copyc clp$parse_command
*copyc clp$pop_block_stack
*copyc clp$pop_input_stack
*copyc clp$pop_terminated_blocks
*copyc clp$process_command_file
*IF NOT $true(osv$unix)
*copyc clp$process_exit_condition
*copyc clp$process_proc_parameters
*IFEND
*copyc clp$push_command_block
*IF NOT $true(osv$unix)
*copyc clp$push_command_proc_block
*IFEND
*copyc clp$restore_work_area_positions
*copyc clp$save_work_area_positions
*copyc clp$search_command_library
*copyc clp$search_command_table
*IF NOT $true(osv$unix)
*copyc clp$set_prev_cmnd_name_and_stat
*IFEND
*copyc clp$trimmed_string_size
*IF NOT $true(osv$unix)
*copyc clp$validate_local_file_name
*copyc clv$ijl_ordinal
*IFEND
*copyc clv$intrinsic_commands
*IF NOT $true(osv$unix)
*copyc clv$local_catalog_handle_name
*copyc clv$operator_commands
*IFEND
*copyc clv$standard_files
*copyc clv$system_commands
*IF NOT $true(osv$unix)
*copyc fsv$evaluated_file_reference
  ?IF fsc$compiling_for_test_harness AND clc$compiling_for_test_harness THEN
*copyc fsv$test_harness_cmnds
  ?IFEND
*copyc jmp$get_job_attributes
*copyc jmp$logout
*copyc jmp$system_job
*IFEND
*copyc osp$append_status_parameter
*IF NOT $true(osv$unix)
*copyc osp$check_for_desired_mf_class
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$set_desktop_interaction
*IFEND
*copyc osp$set_status_abnormal
*IF $true(osv$unix)
*copyc osp$set_status_condition
*IFEND
*IF NOT $true(osv$unix)
*copyc osp$set_status_from_condition
*copyc osp$system_error
*copyc osv$initial_exception_context
*IFEND
*copyc osv$lower_to_upper
*IF NOT $true(osv$unix)
*copyc pmp$continue_to_cause
*copyc pmp$execute
*copyc pmp$execute_within_task
*copyc pmp$get_job_mode
*copyc pmp$get_program_description
*copyc pmp$get_program_size
*copyc pmp$get_task_id
*copyc pmp$inward_call
*copyc pmp$load
*copyc pmp$log_ascii
*copyc sfp$emit_audit_statistic
*copyc sfp$emit_statistic
*ELSE
*copyc clp$get_screen_mode
*copyc clp_process_shell_cmd
*copyc cyt$mips_signal_handler
*copyc osv$signal
*copyc osv$signal_status
*copyc osp$set_status_from_errno
*copyc pmp_get_task_id
*IFEND

?? TITLE := 'Command Search State / Statistic Types', EJECT ??

  TYPE
    clt$command_search_state = record
      caller_ring: ost$valid_ring,
      cause_condition: ^clt$when_condition,
      command: ^clt$command_line,
      command_block: ^clt$block,
      command_from_execute_command: boolean,
      command_echoing_activated: boolean,
      command_echoing_completed: boolean,
      command_list: ^clt$command_list,
      command_logging_completed: boolean,
      command_log_option: clt$command_log_option,
      command_reference_text: ^clt$command_line,
      data: clt$processed_command_data,
      device_class: rmt$device_class,
      effective_search_mode: clt$command_search_modes,
      escaped_command: boolean,
      file: clt$file,
      file_id: amt$file_identifier,
      found: boolean,
      ignore_status: ost$status,
      interpreter_mode: clt$interpreter_modes,
      label: ost$name,
      library_search_info: clt$command_library_search_info,
      name: clt$name,
      nested_commands_can_be_echoed: boolean,
      parse: clt$parse_state,
      path: fst$path,
      path_description_obtained: boolean,
      path_size: fst$path_size,
      prev_cmnd_name_and_stat_set: boolean,
      prompting_requested: boolean,
      ring_attributes: amt$ring_attributes,
      search_level: clt$search_level,
      search_name: clt$name,
      separator: clt$lexical_unit_kind,
      source: clt$command_or_function_source,
      work_area: ^^clt$work_area,
    recend;

  TYPE
    clt$processed_command_data = record
      filler: 0 .. 255,
      from_job_command_file: boolean,
      generic_source: clt$generic_command_source,
      ordinal: clt$named_entry_ordinal,
      call_method: clt$command_call_method,
    recend;

  TYPE
    clt$generic_command_source = (clc$gcs_system_built_in, clc$gcs_system_library, clc$gcs_library,
          clc$gcs_catalog, clc$gcs_utility);

  TYPE
    clt$processed_command_stat_data = array [1 .. 1] of sft$counter;

  TYPE
    clt$command_resource_stat_data = array [1 .. 7] of sft$counter;

  TYPE
    clt$search_$system_option = (clc$search_system_library, clc$skip_system_library);

  TYPE
    clt$search_level = (clc$direct_search, clc$indirect_search);
*IF $true(osv$unix)

  PROCEDURE [XDCL] xref_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


    osp$set_status_abnormal ('CL', cle$unable_to_call_command,'TEST MY XREF and ERRORS', status);
{   osp$set_status_abnormal ('ES', 1163067912, 'DUMMY', status);
{   clp$include_command ('display_value ''INCLUDE_COMMAND WORKS!!''',false,status);
    osp$set_status_abnormal ('CL', cle$welcome_banner, 'hi', status);

  PROCEND xref_command;
*IFEND

?? TITLE := 'clp$process_command', EJECT ??

  PROCEDURE [XDCL] clp$process_command
    (    block_at_start_of_command: ^clt$block;
         interpreter_mode: clt$interpreter_modes;
         command_from_job_command_file: boolean;
         command_from_execute_command: boolean;
         log_the_command: boolean;
         command_can_be_echoed: boolean;
         parse: clt$parse_state;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

?? NEWTITLE := 'command_condition_handler', EJECT ??

{
{ PURPOSE:
{   This condition handler is established to catch any conditions that occur
{   during the processing of a command.  It is also established for "block
{   exit" conditions and since it cannot disestablish itself, it is during the
{   processing of a block exit condition that cleanup activities are performed.
{

    PROCEDURE command_condition_handler
*IF NOT $true(osv$unix)
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        exit_control_block: ^clt$block,
        ignore_status: ost$status,
        run_time_status: ^ost$status;


      CASE condition.selector OF

      = pmc$block_exit_processing =

{ --- Handle block exit.
*ELSE
      (    signal_no: integer;
           code: integer;
           p_sigcontext: ^cyt$mips_sigcontext);



      CASE signal_no OF
      { pmc$block_exit_processing    -    block exit
      = -1 =
*IFEND
        clp$pop_terminated_blocks (block_at_start_of_command, status);

*IF NOT $true(osv$unix)
        state.prompting_requested := FALSE;
        IF state.command_log_option = clc$manually_log THEN
          state.command := state.command_reference_text;
          state.command_log_option := clc$automatically_log;
        IFEND;
        IF state.command_block <> NIL THEN
          IF state.command_block^.kind = clc$command_proc_block THEN
            state.command_logging_completed := state.command_logging_completed OR
                  state.command_block^.command_proc_logging_completed;
            state.command_echoing_completed := state.command_echoing_completed OR
                  state.command_block^.command_proc_echoing_completed;
          ELSE
            state.command_logging_completed := state.command_logging_completed OR
                  state.command_block^.command_logging_completed;
            state.command_echoing_completed := state.command_echoing_completed OR
                  state.command_block^.command_echoing_completed;
          IFEND;
        IFEND;
        log_and_or_echo_command (state);

        set_prev_cmnd_name_and_stat (state, status);
        IF issue_exit_keypoint THEN
          #KEYPOINT (osk$exit, 0, clk$process_command);
          issue_exit_keypoint := FALSE;
        IFEND;
*IFEND
        clp$restore_work_area_positions (saved_work_area_positions, state.ignore_status);
        RETURN;

*IF NOT $true(osv$unix)
      = mmc$segment_access_condition =

{ --- Handle segment access conditions.

        osp$set_status_from_condition ('CL', condition, save_area, status, state.ignore_status);
        IF (status.condition = cle$work_area_overflow) AND (status.text.size = 0) AND state.found THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, state.name.value, status);
        IFEND;
        EXIT clp$process_command;

      = pmc$system_conditions =

{ --- Handle system (hardware detected) conditions.

        IF pmc$detected_uncorrected_err IN condition.system_conditions THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, state.ignore_status);
        IFEND;
        osp$set_status_from_condition ('CL', condition, save_area, status, state.ignore_status);
        EXIT clp$process_command;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN

{ --- Handle CYBIL run time error.

          run_time_status := condition_information;
          status := run_time_status^;
          EXIT clp$process_command;

        ELSEIF (condition.user_condition_name = clc$exiting_condition) AND (state.command_block <> NIL) AND
              state.command_block^.being_exited THEN

{ --- Handle exit initiated via command level EXIT statement.
{
{ This condition is raised in the task that "owns" the SCL block which is the
{ target of the EXIT statement.
{ This condition is specifically dealt with in the condition handlers that
{ cover processing of the various kinds of input, command and function blocks.
{ The condition_information for this condition is a pointer to the outermost
{ block which is being exited and has such a corresponding condition handler.
{ The handler which is "covering" this "exit_control_block" performs a
{ non-local (CYBIL) exit out of its establishing procedure.
{ Other such handlers simply "continue" the condition.

          exit_control_block := condition_information;
          IF #OFFSET (exit_control_block) <> #OFFSET (state.command_block) THEN
            pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          IFEND;
          EXIT clp$process_command;

        ELSE

{ --- "Continue" any other user defined condition.

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          RETURN;
        IFEND;

*IFEND
      ELSE

{ --- "Continue" any other condition.

*IF NOT $true(osv$unix)
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
*IFEND
        RETURN;
      CASEND;

    PROCEND command_condition_handler;
?? TITLE := 'initialize_command_search_state', EJECT ??

    PROCEDURE [INLINE] initialize_command_search_state;

      VAR
*IF NOT $true(osv$unix)
        connected_files: ^clt$connected_files,
*IFEND
        ignore_command_list_in_task: boolean;


*IF NOT $true(osv$unix)
      clp$find_connected_files (connected_files);
*IFEND

      state.caller_ring := caller_id.ring;
      state.cause_condition := ^cause_condition;

{ Space for state.command PUSHed prior to calling this procedure.

      state.command^ (1, parse.index_limit - parse.unit_index) :=
            parse.text^ (parse.unit_index, parse.index_limit - parse.unit_index);

      state.command_block := NIL;
      state.command_from_execute_command := command_from_execute_command;
*IF NOT $true(osv$unix)
      state.command_echoing_activated := connected_files^.echo_count > 0;
      state.command_echoing_completed := NOT (command_can_be_echoed AND state.command_echoing_activated);
*ELSE
      state.command_echoing_activated := FALSE;
      state.command_echoing_completed := TRUE;
*IFEND

      clp$find_command_list (state.command_list, ignore_command_list_in_task);

      state.command_logging_completed := NOT log_the_command;
      state.command_log_option := clc$automatically_log;
      state.command_reference_text := state.command;
      state.data.filler := 0;
      state.data.from_job_command_file := command_from_job_command_file;

{     state.data.generic_source := ;
{     state.data.ordinal := ;
{     state.data.call_method := ;

      state.device_class := rmc$mass_storage_device;

      IF block_at_start_of_command^.use_command_search_mode THEN
        state.effective_search_mode := state.command_list^.search_mode;
      ELSE
        state.effective_search_mode := clc$global_command_search;
      IFEND;

{     state.escaped_command := ;

      state.file.local_file_name := osc$null_name;
      state.file_id := amv$nil_file_identifier;
      state.found := FALSE;
      state.ignore_status.normal := TRUE;
      state.interpreter_mode := interpreter_mode;

{     state.label := ;

      state.library_search_info.command_or_function_module := NIL;
      state.library_search_info.command_or_function_kind := llc$entry_point;
      state.library_search_info.ordinal := 1;
      state.library_search_info.library_privilege := osc$null_name;
      state.library_search_info.module_kind := llc$command_procedure;
      state.library_search_info.log_option := clc$automatically_log;
      state.library_search_info.application_identifier.name := osc$null_name;
      state.name.size := 10;
      state.name.value := 'not_a_name';
      state.nested_commands_can_be_echoed := command_can_be_echoed;
      state.parse := parse;

{     state.path := ;

      state.path_description_obtained := FALSE;

{     state.path_size := ;

      state.prev_cmnd_name_and_stat_set := interpreter_mode <> clc$interpret_mode;

{     state.prompting_requested := ;
{     state.ring_attributes := ;

      state.search_level := clc$direct_search;

{     state.search_name := ;
{     state.separator := ;

      state.source.index := parse.unit_index;
      state.source.size := parse.index_limit - parse.unit_index;

      state.work_area := work_area;

    PROCEND initialize_command_search_state;
?? OLDTITLE, EJECT ??

    CONST
      invalid_command_attempted = ' User attempted to access a command that is not allowed.' CAT
            '  The job is being terminated.';

*IF NOT $true(osv$unix)
    VAR
      keypoint_command_name: packed record
        first_16: 0 .. 0ffff(16),
        next_32: 0 .. 0ffffffff(16),
      recend;
*IFEND

    VAR
      caller_id: ost$caller_identifier,
*IF NOT $true(osv$unix)
      command_keypoints: boolean,
*IFEND
      command_reference_parse: clt$parse_state,
*IF NOT $true(osv$unix)
      command_resource_data: clt$command_resource_stat_data,
      command_statistics_enabled: boolean,
*IFEND
      command_table_index: clt$command_table_index,
      control_statement_descriptor: ^clt$control_statement_desc,
      empty_command: boolean,
      form: clt$command_reference_form,
*IF NOT $true(osv$unix)
      issue_exit_keypoint: boolean,
      ignore_secure_logging_activated: boolean,
*IFEND
*IF NOT $true(osv$unix)
      job_attribute_results: ^jmt$job_attribute_results,
*IFEND
      log_secure_parameters: boolean,
*IF NOT $true(osv$unix)
      restricted_mainframe: boolean,
*IFEND
      saved_work_area_positions: clt$saved_work_area_positions,
      state: clt$command_search_state,
*IF NOT $true(osv$unix)
      statistics_after_processing: clt$command_resource_statistics,
      statistics_before_processing: clt$command_resource_statistics,
*IFEND
      utility_command_list_entry: ^clt$command_list_entry,
*IF $true(osv$unix)
      errno: ost_c_integer,
      handler_stat: boolean,
      in_screen_mode: boolean,
      stat: integer,
      shell_command: string (256),
      shell_command_length: integer,
      shell_command_name: string (256),
      shell_command_parse: clt$parse_state,
      syserrlist_message: string (256),
*IFEND
      work_area: ^^clt$work_area;


    status.normal := TRUE;

*IF NOT $true(osv$unix)
    clp$get_command_statistics (statistics_before_processing, ignore_secure_logging_activated,
          command_statistics_enabled, command_keypoints);

    #CALLER_ID (caller_id);
    issue_exit_keypoint := FALSE;
    #SPOIL (issue_exit_keypoint);

    clp$get_work_area (#RING (^work_area), work_area, status);
*ELSE
    caller_id.ring := osc$user_ring;
    clp$get_work_area (osc$user_ring, work_area, status);
*IFEND
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$save_work_area_positions (saved_work_area_positions);

    PUSH state.command: [parse.index_limit - parse.unit_index];
    initialize_command_search_state;

*IF NOT $true(osv$unix)
    osp$establish_condition_handler (^command_condition_handler, TRUE);
*ELSE
    handler_stat := #establish_condition_handler (-1, ^command_condition_handler);
*IFEND

  /process_command/
    BEGIN
*IF $true(osv$unix)
      shell_command_parse := block_at_start_of_command^.line_parse;
      shell_command_length:=shell_command_parse.unit.size;
      shell_command_name:=shell_command_parse.text^ (shell_command_parse.unit_index, shell_command_length);
*IFEND
      clp$parse_command (state.parse, state.prompting_requested, state.escaped_command, state.label,
            command_reference_parse, state.file, form, state.name, utility_command_list_entry,
            state.separator, empty_command, status);
      state.search_name := state.name;

      CASE state.interpreter_mode OF
      = clc$interpret_mode =
        IF NOT status.normal THEN
          EXIT /process_command/;
        ELSEIF empty_command THEN
          state.prev_cmnd_name_and_stat_set := TRUE;
          #SPOIL (state.prev_cmnd_name_and_stat_set);
          EXIT /process_command/;
        IFEND;
      = clc$skip_mode =
        IF (NOT status.normal) OR empty_command THEN
          status.normal := TRUE;
          EXIT /process_command/;
        IFEND;
      = clc$help_mode =
        IF NOT status.normal THEN
          EXIT /process_command/;
        ELSEIF empty_command OR (state.label <> osc$null_name) THEN
          osp$set_status_abnormal ('CL', cle$expecting_command, state.command^, status);
          EXIT /process_command/;
        IFEND;
      ELSE
        ;
      CASEND;

      state.source.reference_index := command_reference_parse.unit_index;
      state.source.reference_size := command_reference_parse.index_limit - state.source.reference_index;
      state.command_reference_text := ^state.command^ (state.source.reference_index - state.source.index + 1,
            state.source.reference_size);
      state.source.ordinal := 1;
      state.source.function_interface := clc$fi_contemporary;

*IF NOT $true(osv$unix)
      #UNCHECKED_CONVERSION (state.name.value (1, 6), keypoint_command_name);
      #KEYPOINT (osk$entry, osk$m * keypoint_command_name.first_16, clk$process_command);
      #KEYPOINT (osk$data, keypoint_command_name.next_32, 0);
      IF command_keypoints THEN
        #KEYPOINT (osk$performance, osk$m * keypoint_command_name.first_16, ptk$command_name);
        #KEYPOINT (osk$performance, keypoint_command_name.next_32, 0);
        #KEYPOINT (osk$performance, osk$m * (clv$ijl_ordinal.block_number * 32 + clv$ijl_ordinal.block_index),
              ptk$command_ijl);
      IFEND;
      issue_exit_keypoint := TRUE;
      #SPOIL (issue_exit_keypoint);

      clp$get_log_secure_parameters (log_secure_parameters);

      IF state.separator = clc$lex_equal THEN
        set_control_statement_logging (state);
        log_and_or_echo_command (state);
        IF state.source.reference_size = 0 THEN
          process_case_selection (state, status);
        ELSEIF state.interpreter_mode = clc$interpret_mode THEN
          process_assignment (command_reference_parse, state, status);
        IFEND;
      ELSEIF form <> clc$name_only_command_ref THEN
        clp$check_name_for_control (state.name, control_statement_descriptor);
        IF (state.interpreter_mode <> clc$skip_mode) OR ((control_statement_descriptor <> NIL) AND
              (control_statement_descriptor^.call_in_skip_mode)) THEN
*ELSE
      IF form <> clc$name_only_command_ref THEN
        IF state.interpreter_mode <> clc$skip_mode THEN
*IFEND
*IF NOT $true(osv$unix)
          IF ((state.caller_ring > osc$tsrv_ring) AND (state.effective_search_mode =
                clc$exclusive_command_search)) OR state.escaped_command THEN
*IFEND
            osp$set_status_abnormal ('CL', cle$file_dot_cmnd_not_allowed, state.command_reference_text^,
                  status);

*IF NOT $true(osv$unix)
            { A requirement for the China Weather systems states that if a user in the PRODUCTION job class
            { attempts to execute a command that they are not allowed to execute, the system should log the
            { attempt and terminate the job.

            osp$check_for_desired_mf_class (osc$mc_china_class, restricted_mainframe);
            IF restricted_mainframe THEN
              PUSH job_attribute_results: [1 .. 1];
              job_attribute_results^ [1].key := jmc$job_class;
              jmp$get_job_attributes (job_attribute_results, state.ignore_status);
              IF job_attribute_results^ [1].job_class = 'PRODUCTION' THEN
                pmp$log_ascii (invalid_command_attempted, $pmt$ascii_logset [pmc$system_log, pmc$job_log],
                      pmc$msg_origin_system, state.ignore_status);
                jmp$logout (state.ignore_status);
              IFEND;
            IFEND;
*IFEND
            RETURN;
*IF NOT $true(osv$unix)
          IFEND;
          CASE form OF
          = clc$file_cycle_command_ref =
            process_command_file (state, status);
            IF status.normal AND (NOT state.found) THEN
              osp$set_status_abnormal ('CL', cle$unknown_command, state.name.value, status);
              IF NOT log_secure_parameters THEN
                state.command := state.command_reference_text;
              IFEND;
            IFEND;
          = clc$module_or_file_command_ref =
            process_command_in_file (log_secure_parameters, state, status);
          = clc$system_command_ref =
            state.source.kind := clc$system_commands;
            process_system_command (clc$search_system_library, state, status);
            IF status.normal AND (NOT state.found) THEN
              osp$set_status_abnormal ('CL', cle$unknown_command, state.name.value, status);
              IF NOT log_secure_parameters THEN
                state.command := state.command_reference_text;
              IFEND;
            IFEND;
          = clc$utility_command_ref =
            state.data.generic_source := clc$gcs_utility;
            state.source.kind := clc$sub_commands;
            state.source.utility_name := utility_command_list_entry^.utility_name;
            state.source.utility_info := utility_command_list_entry^.utility_info;
            process_sub_command (state, NIL, status);
            IF status.normal AND (NOT state.found) THEN
              osp$set_status_abnormal ('CL', cle$unknown_command, state.name.value, status);
              IF NOT log_secure_parameters THEN
                state.command := state.command_reference_text;
              IFEND;
            IFEND;
          ELSE
            ;
          CASEND;
*IFEND
        IFEND;
*IF NOT $true(osv$unix)
      ELSE
        clp$check_name_for_control (state.name, control_statement_descriptor);
        IF control_statement_descriptor <> NIL THEN
          IF (state.interpreter_mode <> clc$skip_mode) OR control_statement_descriptor^.call_in_skip_mode THEN
            IF control_statement_descriptor^.kind = clc$control_statement THEN
              process_control_statement (state, control_statement_descriptor^.label_allowed,
                    control_statement_descriptor^.statement, status);
            ELSE
              process_control_command (state, control_statement_descriptor^.command, status);
            IFEND;
          ELSEIF control_statement_descriptor^.kind = clc$control_statement THEN
            set_control_statement_logging (state);
          IFEND;
        ELSEIF state.interpreter_mode = clc$skip_mode THEN
          IF (block_at_start_of_command^.kind = clc$input_block) AND
                block_at_start_of_command^.being_exited AND (block_at_start_of_command^.associated_utility <>
                NIL) AND (block_at_start_of_command^.associated_utility^.command_environment.commands <> NIL)
                THEN
            clp$search_command_table (state.name.value, block_at_start_of_command^.associated_utility^.
                  command_environment.commands, command_table_index, state.found);
            IF state.found AND (block_at_start_of_command^.associated_utility^.command_environment.
                  commands^ [command_table_index].ordinal = block_at_start_of_command^.associated_utility^.
                  command_environment.termination_command_ordinal) THEN
              clp$ignore_rest_of_file (block_at_start_of_command^.label, status);
            IFEND;
          IFEND;
        ELSE
          process_command_in_list (log_secure_parameters, state, status);
        IFEND;
*IFEND
      IFEND;
*IF NOT $true(osv$unix)

      IF (state.interpreter_mode = clc$interpret_mode) AND command_statistics_enabled THEN
        clp$get_command_statistics (statistics_after_processing, ignore_secure_logging_activated,
              command_statistics_enabled, command_keypoints);
        IF command_statistics_enabled THEN
          calculate_command_statistics (statistics_before_processing, statistics_after_processing,
                command_resource_data);
          sfp$emit_statistic (cll$command_resources, state.name.value, ^command_resource_data,
                state.ignore_status);
        IFEND;
      IFEND;
*ELSE
          process_command_in_list (state, status);
          IF osv$signal <> $ost$signals [] THEN
            RETURN;
          IFEND;
*IFEND
    END /process_command/;

*IF NOT $true(osv$unix)
    state.prompting_requested := FALSE;
    IF state.command_log_option = clc$manually_log THEN
      state.command := state.command_reference_text;
      state.command_log_option := clc$automatically_log;
    IFEND;
    log_and_or_echo_command (state);

    set_prev_cmnd_name_and_stat (state, status);

    IF issue_exit_keypoint THEN
      #KEYPOINT (osk$exit, 0, clk$process_command);
      issue_exit_keypoint := FALSE;
    IFEND;
    #SPOIL (issue_exit_keypoint);
*IFEND

    clp$restore_work_area_positions (saved_work_area_positions, state.ignore_status);

*IF NOT $true(osv$unix)
    osp$disestablish_cond_handler;
*ELSE
    IF (NOT status.normal) AND (status.condition = cle$unknown_command) AND
          (state.interpreter_mode = clc$help_mode) AND
          (clc$ph_man IN block_at_start_of_command^.help_output_options) THEN

{Get original text entered and give it to MAN.

      STRINGREP (shell_command, shell_command_length, 'man ',
            shell_command_name (1, shell_command_length));
      clp$get_screen_mode (in_screen_mode);
      clp_process_shell_cmd (shell_command, shell_command_length, $INTEGER(in_screen_mode), errno,
            syserrlist_message, stat);
      IF stat = 0 THEN
        status.normal := TRUE;
      ELSEIF stat = 4 THEN { interrupt }
        status.condition := cle$command_terminated;
      IFEND;
    IFEND;

    handler_stat := #disestablish_condition_handler (-1);
*IFEND


  PROCEND clp$process_command;
?? TITLE := 'verify_prompting_requested', EJECT ??

  PROCEDURE [INLINE] verify_prompting_requested
    (    prompting_requested: boolean;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
    VAR
      job_mode: jmt$job_mode;
*IFEND


    IF prompting_requested THEN
*IF NOT $true(osv$unix)
      pmp$get_job_mode (job_mode, status);
      IF status.normal AND (job_mode = jmc$batch) AND (NOT jmp$system_job ()) THEN
        osp$set_status_abnormal ('CL', ife$current_job_not_interactive, 'Prompting Statement', status);
      IFEND;
*ELSE
      osp$set_status_abnormal ('CL', cle$not_supported, 'Command prompting', status);
*IFEND
    IFEND;

  PROCEND verify_prompting_requested;
*IF NOT $true(osv$unix)
?? TITLE := 'calculate_command_statistics', EJECT ??

  PROCEDURE calculate_command_statistics
    (    statistics_before_processing: clt$command_resource_statistics;
         statistics_after_processing: clt$command_resource_statistics;
     VAR command_resource_data: clt$command_resource_stat_data);

    command_resource_data [1] := statistics_after_processing.cptime.task_time -
          statistics_before_processing.cptime.task_time;
    command_resource_data [2] := statistics_after_processing.cptime.monitor_time -
          statistics_before_processing.cptime.monitor_time;
    command_resource_data [3] := statistics_after_processing.paging_statistics.page_fault_count -
          statistics_before_processing.paging_statistics.page_fault_count;
    command_resource_data [4] := statistics_after_processing.paging_statistics.page_in_count -
          statistics_before_processing.paging_statistics.page_in_count;
    command_resource_data [5] := statistics_after_processing.paging_statistics.pages_reclaimed_from_queue -
          statistics_before_processing.paging_statistics.pages_reclaimed_from_queue;
    command_resource_data [6] := statistics_after_processing.paging_statistics.new_pages_assigned -
          statistics_before_processing.paging_statistics.new_pages_assigned;
    command_resource_data [7] := statistics_after_processing.paging_statistics.pages_from_server -
          statistics_before_processing.paging_statistics.pages_from_server;

  PROCEND calculate_command_statistics;
?? TITLE := 'emit_processed_command_stat', EJECT ??

  PROCEDURE [INLINE] emit_processed_command_stat
    (VAR state {input, output} : clt$command_search_state);

    VAR
      audit_information: sft$audit_information,
      dummy_status: ost$status,
      processed_command_stat_data: clt$processed_command_stat_data;


    #UNCHECKED_CONVERSION (state.data, processed_command_stat_data);
    sfp$emit_statistic (cll$processed_command, state.name.value, ^processed_command_stat_data,
          state.ignore_status);

{ Emit the processed command audit statistic.

    ?IF NOT clc$compiling_for_test_harness THEN
      audit_information.audited_operation := sfc$ao_job_process_command;
      audit_information.process_command.command_name_p := ^state.name.value;
      IF state.data.from_job_command_file THEN
        audit_information.process_command.command_source := sfc$cs_primary_command_file;
      ELSE
        audit_information.process_command.command_source := sfc$cs_secondary_command_file;
      IFEND;
      audit_information.process_command.command_call_method := state.data.call_method;
      dummy_status.normal := TRUE;
      sfp$emit_audit_statistic (audit_information, dummy_status);
    ?IFEND

  PROCEND emit_processed_command_stat;
?? TITLE := 'process_pt_request', EJECT ??

  PROCEDURE process_pt_request
    (    work_list: bat$process_pt_work_list;
         local_file_name: amt$local_file_name;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR process_pt_results: bat$process_pt_results;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context;

    PUSH context;
    context^ := osv$initial_exception_context;
    context^.file.selector := osc$ecp_evaluated_file_ref;
    context^.file.evaluated_file_reference := evaluated_file_reference;
    REPEAT
      context^.condition_status := status;
      osp$enforce_exception_policies (context^);
      status := context^.condition_status;

      IF (NOT osp$file_access_condition (status)) OR (NOT context^.wait) THEN
        RETURN;
      ELSE
        bap$process_pt_request (work_list, local_file_name, evaluated_file_reference, process_pt_results,
              status);
      IFEND;
    UNTIL status.normal;

  PROCEND process_pt_request;
?? TITLE := 'set_control_statement_logging', EJECT ??

  PROCEDURE [INLINE] set_control_statement_logging
    (VAR state {input, output} : clt$command_search_state);

    VAR
      ignore_block_in_current_task: boolean,
      utility_block: ^clt$block;


    IF NOT state.command_logging_completed THEN
      clp$find_utility_block (osc$null_name, utility_block, ignore_block_in_current_task);
      IF (utility_block <> NIL) AND (NOT utility_block^.command_environment.subcommand_logging_enabled) THEN
        state.command_logging_completed := TRUE;
      IFEND;
    IFEND;

  PROCEND set_control_statement_logging;
?? TITLE := 'log_and_or_echo_command', EJECT ??

  PROCEDURE [INLINE] log_and_or_echo_command
    (VAR state {input, output} : clt$command_search_state);


    IF (NOT state.command_logging_completed) AND (state.command_log_option = clc$automatically_log) AND
         (NOT state.prompting_requested) THEN
      clp$log_command_line (state.command^, state.ignore_status);
      state.command_logging_completed := TRUE;
    IFEND;

    IF (NOT state.command_echoing_completed) AND (state.command_log_option = clc$automatically_log) THEN
      clp$echo_command (state.interpreter_mode, state.command^, state.ignore_status);
      state.command_echoing_completed := TRUE;
    IFEND;

  PROCEND log_and_or_echo_command;
?? TITLE := 'initialize_application_info', EJECT ??

  PROCEDURE [INLINE] initialize_application_info
    (VAR state {input, output} : clt$command_search_state;
     VAR status: ost$status);


    status.normal := TRUE;

    IF (state.library_search_info.application_identifier.name <> osc$null_name) AND
          (state.interpreter_mode = clc$interpret_mode) THEN
      clp$initialize_application_info (state.library_search_info.application_identifier,
            state.library_search_info.library_privilege, state.library_search_info.module_kind, status);
    IFEND;

  PROCEND initialize_application_info;
?? TITLE := 'set_prev_cmnd_name_and_stat', EJECT ??

  PROCEDURE [INLINE] set_prev_cmnd_name_and_stat
    (VAR state {input, output} : clt$command_search_state;
     VAR status {input} : ost$status);


    IF NOT state.prev_cmnd_name_and_stat_set THEN
      IF NOT state.command_from_execute_command THEN
        clp$set_prev_cmnd_name_and_stat (state.command, state.name.value, status);
      IFEND;
      state.prev_cmnd_name_and_stat_set := TRUE;
    IFEND;

  PROCEND set_prev_cmnd_name_and_stat;
?? TITLE := 'process_assignment', EJECT ??

  PROCEDURE [INLINE] process_assignment
    (VAR variable_parse {input, output} : clt$parse_state;
     VAR state {input, output} : clt$command_search_state;
     VAR status: ost$status);


    IF state.escaped_command THEN
      osp$set_status_abnormal ('CL', cle$unexpected_escape, state.name.value, status);
    ELSEIF state.label <> osc$null_name THEN
      osp$set_status_abnormal ('CL', cle$assignment_cant_be_labelled, '', status);
    ELSEIF state.prompting_requested THEN
      osp$set_status_abnormal ('CL', cle$unexpected_prompt_statement, state.name.value, status);
    ELSEIF state.command_from_execute_command THEN
      osp$set_status_abnormal ('CL', cle$invalid_exec_command, state.name.value, status);
    ELSE
      sfp$emit_statistic (cll$processed_control_statement, state.name.value, NIL, state.ignore_status);

      clp$assignment_statement (variable_parse, state.parse, state.work_area^, status);
    IFEND;

  PROCEND process_assignment;
?? TITLE := 'process_case_selection', EJECT ??

  PROCEDURE [INLINE] process_case_selection
    (VAR state {input, output} : clt$command_search_state;
     VAR status: ost$status);


    IF state.escaped_command THEN
      osp$set_status_abnormal ('CL', cle$unexpected_escape, state.name.value, status);
    ELSEIF state.label <> osc$null_name THEN
      osp$set_status_abnormal ('CL', cle$case_sel_cant_be_labelled, '', status);
    ELSEIF state.prompting_requested THEN
      osp$set_status_abnormal ('CL', cle$unexpected_prompt_statement, state.name.value, status);
    ELSEIF state.command_from_execute_command THEN
      osp$set_status_abnormal ('CL', cle$invalid_exec_command, state.name.value, status);
    ELSE
      sfp$emit_statistic (cll$processed_control_statement, state.name.value, NIL, state.ignore_status);

      clp$case_selection_statement (state.interpreter_mode, state.parse, state.work_area^, status);
    IFEND;

  PROCEND process_case_selection;
*IFEND
?? TITLE := 'process_control_command', EJECT ??

  PROCEDURE [INLINE] process_control_command
    (VAR state {input, output} : clt$command_search_state;
         command: clt$command;
     VAR status: ost$status);


    IF state.label <> osc$null_name THEN
      osp$set_status_abnormal ('CL', cle$commands_cant_be_labelled, '', status);
    ELSE
      verify_prompting_requested (state.prompting_requested, status);
      IF status.normal THEN
        IF state.command_from_execute_command THEN
          osp$set_status_abnormal ('CL', cle$invalid_exec_command, state.name.value, status);
        ELSE
          state.data.generic_source := clc$gcs_system_built_in;
          state.source.kind := clc$system_commands;
          state.source.system_command_table := clv$intrinsic_commands;
          process_sub_command (state, clv$intrinsic_commands, status);

{ It is assumed that every "control command" has a corresponding entry in the
{ clv$intrinsic_commands.  If this turns out not to be true, call the command
{ anyway.  Certain things will not work for such a command--like the display_
{ command_information command, and the ability to determine the source of the
{ command (the $source function, etc.).

          IF NOT state.found THEN
            invoke_sub_command (state, command, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND process_control_command;
*IF NOT $true(osv$unix)
?? TITLE := 'process_control_statement', EJECT ??

  PROCEDURE [INLINE] process_control_statement
    (VAR state {input, output} : clt$command_search_state;
         label_allowed: boolean;
         statement: clt$control_statement;
     VAR status: ost$status);

    VAR
      info: clt$control_statement_info;


    info.interpreter_mode := state.interpreter_mode;
    info.label := state.label;
    info.logging_required := NOT state.command_logging_completed;
    info.echoing_required := NOT state.command_echoing_completed;

    set_control_statement_logging (state);
    log_and_or_echo_command (state);

    IF state.interpreter_mode = clc$help_mode THEN
      osp$set_status_abnormal ('CL', cle$expecting_command, state.command^, status);
    ELSEIF (state.label <> osc$null_name) AND (NOT label_allowed) THEN
      osp$set_status_abnormal ('CL', cle$statement_cant_be_labelled, state.name.value, status);
    ELSEIF state.escaped_command THEN
      osp$set_status_abnormal ('CL', cle$unexpected_escape, state.name.value, status);
    ELSEIF state.separator = clc$lex_comma THEN
      osp$set_status_abnormal ('CL', cle$unexpected_comma_after, state.name.value, status);
    ELSEIF state.prompting_requested THEN
      osp$set_status_abnormal ('CL', cle$unexpected_prompt_statement, state.name.value, status);
    ELSEIF state.command_from_execute_command THEN
      osp$set_status_abnormal ('CL', cle$invalid_exec_command, state.name.value, status);
    ELSE
*IF NOT $true(osv$unix)
      sfp$emit_statistic (cll$processed_control_statement, state.name.value, NIL, state.ignore_status);
*IFEND

      statement^ (info, state.parse, state.work_area^, state.cause_condition^, status);
    IFEND;

  PROCEND process_control_statement;
*IFEND
?? TITLE := 'process_command_in_list', EJECT ??

  PROCEDURE process_command_in_list
*IF NOT $true(osv$unix)
    (    log_secure_parameters: boolean;
     VAR state {input, output} : clt$command_search_state;
*ELSE
    (VAR state {input, output} : clt$command_search_state;
*IFEND
     VAR status: ost$status);

    VAR
      current_entry: ^clt$command_list_entry,
      entry_after_fence: ^clt$command_list_entry,
*IF NOT $true(osv$unix)
      ignore_path_handle: fmt$path_handle,
*IFEND
      search_status: ^ost$status,
*IF NOT $true(osv$unix)
      system_commands_searched: boolean,
      working_catalog: ^^clt$working_catalog;
*ELSE
      system_commands_searched: boolean;
*IFEND


    status.normal := TRUE;
    search_status := NIL;

    IF state.escaped_command THEN
      IF state.effective_search_mode = clc$exclusive_command_search THEN
        osp$set_status_abnormal ('CL', cle$escape_not_allowed, '', status);
        RETURN;
      IFEND;
    IFEND;
    IF state.label <> osc$null_name THEN
      osp$set_status_abnormal ('CL', cle$commands_cant_be_labelled, '', status);
      RETURN;
    IFEND;
    verify_prompting_requested (state.prompting_requested, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF state.escaped_command THEN
      current_entry := state.command_list^.entries.entry_after_fence;
      entry_after_fence := NIL;
    ELSEIF state.effective_search_mode <> clc$global_command_search THEN
      current_entry := state.command_list^.entries.first_entry;
      entry_after_fence := state.command_list^.entries.entry_after_fence;
    ELSE
      current_entry := state.command_list^.entries.first_entry;
      entry_after_fence := NIL;
    IFEND;

    system_commands_searched := FALSE;

    WHILE current_entry <> entry_after_fence DO
      state.path_description_obtained := FALSE;
      state.source.kind := current_entry^.kind;
      CASE current_entry^.kind OF

      = clc$catalog_commands =
*IF NOT $true(osv$unix)
        state.source.local_file_name := current_entry^.local_file_name;
        clp$get_fs_path_string (current_entry^.local_file_name, state.path, state.path_size,
              ignore_path_handle, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        state.path_description_obtained := TRUE;
        process_command_in_catalog (state, status);
*IFEND

      = clc$working_catalog_commands =
*IF NOT $true(osv$unix)
        clp$find_working_catalog (working_catalog);
        state.source.local_file_name := working_catalog^^.handle;
        clp$convert_file_ref_to_string (working_catalog^^.evaluated_file_reference, FALSE, state.path,
              state.path_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        state.path_description_obtained := TRUE;
        process_command_in_catalog (state, status);
*IFEND

      = clc$library_commands =
*IF NOT $true(osv$unix)
        IF current_entry^.library_contains.commands THEN
          state.file.local_file_name := current_entry^.local_file_name;
          state.source.local_file_name := current_entry^.local_file_name;
          process_command_in_library (TRUE, state, status);
        IFEND;
*IFEND

      = clc$system_commands =
        state.source.system_command_table := NIL;
        process_system_command (clc$search_system_library, state, status);
        system_commands_searched := TRUE;

      = clc$sub_commands =
        state.data.generic_source := clc$gcs_utility;
        state.source.utility_name := current_entry^.utility_name;
        state.source.utility_info := current_entry^.utility_info;
        process_sub_command (state, NIL, status);
        IF (NOT status.normal) AND (status.condition = cle$util_cmds_fctns_unavailable) AND
              (status.text.value (2, status.text.size-1) = state.name.value (1, state.name.size)) THEN
          IF search_status = NIL THEN
            PUSH search_status;
            search_status^ := status;
          IFEND;
          status.normal := TRUE;
          state.found := FALSE;
        IFEND;

      ELSE
        ;
      CASEND;

      IF (NOT status.normal) OR state.found THEN
        RETURN;
      IFEND;

      current_entry := current_entry^.next_entry;
    WHILEND;

    IF NOT system_commands_searched THEN
      state.data.generic_source := clc$gcs_system_built_in;
      state.source.kind := clc$system_commands;
      state.source.system_command_table := clv$intrinsic_commands;
      process_sub_command (state, clv$intrinsic_commands, status);
      IF (NOT status.normal) OR state.found THEN
        RETURN;
      IFEND;
    IFEND;

*IF NOT $true(osv$unix)
    ?IF fsc$compiling_for_test_harness AND clc$compiling_for_test_harness THEN
      state.data.generic_source := clc$gcs_system_built_in;
      state.source.kind := clc$system_commands;
      state.source.system_command_table := fsv$test_harness_cmnds;
      process_sub_command (state, fsv$test_harness_cmnds, status);
      IF (NOT status.normal) OR state.found THEN
        RETURN;
      IFEND;
    ?IFEND
*IFEND

    IF search_status = NIL THEN
      osp$set_status_abnormal ('CL', cle$unknown_command, state.name.value, status);
*IF NOT $true(osv$unix)
      IF NOT log_secure_parameters THEN
        state.command := state.command_reference_text;
      IFEND;
*IFEND
    ELSE
      status := search_status^;
    IFEND;

  PROCEND process_command_in_list;
*IF NOT $true(osv$unix)
?? TITLE := 'process_command_in_file', EJECT ??

  PROCEDURE process_command_in_file
    (    log_secure_parameters: boolean;
     VAR state {input, output} : clt$command_search_state;
     VAR status: ost$status);

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;


      IF state.found THEN
        clp$close_command_library (state.file.local_file_name, ignore_status);
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      ignore_path_handle: fmt$path_handle;


    status.normal := TRUE;

    IF state.label <> osc$null_name THEN
      osp$set_status_abnormal ('CL', cle$commands_cant_be_labelled, '', status);
      RETURN;
    IFEND;
    verify_prompting_requested (state.prompting_requested, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_fs_path_string (state.file.local_file_name, state.path, state.path_size, ignore_path_handle,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    state.path_description_obtained := TRUE;

    IF state.path (1, 8) = ':$LOCAL ' THEN
      state.source.kind := clc$catalog_commands;
      state.source.local_file_name := state.file.local_file_name;
      process_command_in_catalog (state, status);
    ELSE
      state.source.kind := clc$library_commands;
      state.source.local_file_name := state.file.local_file_name;
      state.found := FALSE;
      #SPOIL (state.found);

      osp$establish_block_exit_hndlr (^abort_handler);
      process_command_in_library (FALSE, state, status);
      osp$disestablish_cond_handler;
    IFEND;

    IF status.normal AND (NOT state.found) THEN
      osp$set_status_abnormal ('CL', cle$unknown_command, state.name.value, status);
      IF NOT log_secure_parameters THEN
        state.command := state.command_reference_text;
      IFEND;
    IFEND;

  PROCEND process_command_in_file;
?? TITLE := 'process_command_in_catalog', EJECT ??

  PROCEDURE process_command_in_catalog
    (VAR state {input, output} : clt$command_search_state;
     VAR status: ost$status);

    VAR
      command_path_name: fst$path,
      evaluated_file_reference: fst$evaluated_file_reference,
      local_status: ost$status,
      path_handle_name: fst$path_handle_name,
      pt_results: bat$process_pt_results,
      work_list: bat$process_pt_work_list;


    status.normal := TRUE;
    state.data.generic_source := clc$gcs_catalog;
    state.data.ordinal := 1;
    state.source.ordinal := 1;

    IF state.source.local_file_name = clv$local_catalog_handle_name THEN
      evaluated_file_reference := fsv$evaluated_file_reference;
      evaluated_file_reference.path_structure (1) := $CHAR (6);
      evaluated_file_reference.path_structure (2, 6) := '$LOCAL';
      evaluated_file_reference.path_structure (8) := $CHAR (state.name.size);
      evaluated_file_reference.path_structure (9, state.name.size) := state.name.value;
      evaluated_file_reference.path_structure_size := state.name.size + 8;
      evaluated_file_reference.number_of_path_elements := 2;
      evaluated_file_reference.path_resolution := fsc$unresolved_path;

      work_list := $bat$process_pt_work_list [bac$resolve_path];
      bap$process_pt_request (work_list, osc$null_name, evaluated_file_reference, pt_results, status);
      IF (NOT status.normal) AND osp$file_access_condition (status) THEN
        process_pt_request (work_list, osc$null_name, evaluated_file_reference, pt_results, status);
      IFEND;
      IF (NOT status.normal) OR NOT (bac$cycle_description_exists IN pt_results) THEN
        status.normal := TRUE;
        RETURN;
      IFEND;
      clp$construct_path_handle_name (evaluated_file_reference.path_handle_info.path_handle,
            state.file.local_file_name);

    ELSE
      IF (state.path_size + 1 + state.name.size) > fsc$max_path_size THEN
        osp$set_status_abnormal ('CL', cle$file_reference_too_long, '', status);
        RETURN;
      IFEND;
      command_path_name := state.path (1, state.path_size);
      command_path_name (state.path_size + 1) := '.';
      command_path_name (state.path_size + 2, state.name.size) := state.name.value (1, state.name.size);

{     clp$convert_str_to_path_handle (command_path_name (1, state.path_size + 1 + state.name.size), TRUE,

      clp$convert_str_to_path_handle (command_path_name (1, state.path_size + 1 + state.name.size), FALSE,
            FALSE, FALSE, state.file.local_file_name, evaluated_file_reference, status);
      IF NOT status.normal THEN
        status.normal := TRUE;
        RETURN;
      IFEND;
    IFEND;

    process_command_file (state, status);

  PROCEND process_command_in_catalog;
?? TITLE := 'process_command_file', EJECT ??

  PROCEDURE process_command_file
    (VAR state {input, output} : clt$command_search_state;
     VAR status: ost$status);

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;


      clp$close_command_file (state.file_id, opened_executable_file, ignore_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      close_status: ost$status,
      file_contents: clt$file_contents,
      opened_executable_file: boolean,
      ignore_file_has_fap: boolean,
      ignore_segment: ^SEQ ( * ),
      line_layout: clt$line_layout,
      nested_commands_can_be_echoed: boolean,
      object_file_list: ^pmt$object_file_list,
      path_handle_name: fst$path_handle_name,
      program_description: ^pmt$program_description,
      program_attributes: ^pmt$program_attributes;


    state.file_id := amv$nil_file_identifier;
    #SPOIL (state.file_id);
    osp$establish_block_exit_hndlr (^abort_handler);

    clp$access_command_file (clc$catalog_command, state.caller_ring, state.file.local_file_name,
          state.file_id, ignore_segment, opened_executable_file, nested_commands_can_be_echoed, line_layout,
          file_contents, state.ring_attributes, ignore_file_has_fap, state.device_class, path_handle_name,
          status);
    IF file_contents.path_exists AND (NOT file_contents.is_object) AND
          (path_handle_name <> osc$null_name) THEN
      state.file.local_file_name := path_handle_name;
    IFEND;

    IF NOT status.normal THEN
      IF status.condition = cle$not_a_command_file THEN
        status.normal := TRUE;
      IFEND;
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

    state.found := TRUE;
    state.source.kind := clc$catalog_commands;
    state.command_log_option := clc$automatically_log;
    state.nested_commands_can_be_echoed := state.nested_commands_can_be_echoed AND
          nested_commands_can_be_echoed;

    IF file_contents.is_object THEN
      PUSH program_description: [[pmt$program_attributes, REP 1 OF amt$local_file_name]];
      RESET program_description;
      NEXT program_attributes IN program_description;
      program_attributes^.contents := $pmt$prog_description_contents [pmc$object_file_list_specified];
      program_attributes^.number_of_object_files := 1;
      NEXT object_file_list: [1 .. 1] IN program_description;
      object_file_list^ [1] := state.file.local_file_name;
      invoke_program_command (state, NIL, program_description, status);
    ELSE
      state.library_search_info.command_or_function_module := NIL;
      invoke_scl_procedure (state, line_layout, status);
      clp$close_command_file (state.file_id, opened_executable_file, close_status);
      IF status.normal AND (NOT close_status.normal) THEN
        status := close_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND process_command_file;
?? TITLE := 'process_command_in_library', EJECT ??

  PROCEDURE [INLINE] process_command_in_library
    (    searching_command_list: boolean;
     VAR state {input, output} : clt$command_search_state;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context,
      ignore_path_handle: fmt$path_handle,
      ignore_path_size: fst$path_size,
      local_status: ost$status,
      nested_commands_can_be_echoed: boolean,
      saved_status: ^ost$status;


    status.normal := TRUE;
    context := NIL;
    saved_status := NIL;

    IF state.file.local_file_name = osc$null_name THEN
      state.data.generic_source := clc$gcs_system_library;
    ELSE
      state.data.generic_source := clc$gcs_library;
    IFEND;

    REPEAT
      clp$search_command_library (state.search_name.value, clc$command, searching_command_list,
            state.work_area^, state.file.local_file_name, state.file_id, state.ring_attributes,
            nested_commands_can_be_echoed, state.library_search_info, state.found, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_file_reference;
          context^.file.file_reference := ^state.file.local_file_name;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
    IF status.normal THEN
      IF state.found THEN
        state.command_log_option := state.library_search_info.log_option;
        state.nested_commands_can_be_echoed := state.nested_commands_can_be_echoed AND
              nested_commands_can_be_echoed;
        IF state.search_level = clc$direct_search THEN
          state.source.ordinal := state.library_search_info.ordinal;
          IF state.source.kind = clc$library_commands THEN
            state.source.local_file_name := state.file.local_file_name;
          IFEND;
        IFEND;
        invoke_command_in_library (state, state.search_name.value, FALSE, status);
      IFEND;

      REPEAT
        clp$close_command_library (state.file.local_file_name, local_status);
        IF NOT local_status.normal THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_file_reference;
            context^.file.file_reference := ^state.file.local_file_name;
          IFEND;
          context^.condition_status := local_status;
          osp$enforce_exception_policies (context^);
          local_status := context^.condition_status;
        IFEND;
      UNTIL local_status.normal OR (NOT osp$file_access_condition (local_status)) OR
            (NOT context^.wait);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;

    ELSEIF searching_command_list THEN
      RETURN;

    ELSEIF (status.condition = pfe$path_too_short) OR (status.condition = pfe$name_not_permanent_file) OR
          (status.condition = pfe$unknown_permanent_file) OR (status.condition = ame$file_not_known) THEN

{ !!! KLUDGE !!! This can be removed when CATALOG_NAME_SECURITY is fixed.

      IF (status.condition = pfe$unknown_permanent_file) OR (status.condition = ame$file_not_known) THEN
        PUSH saved_status;
        saved_status^ := status;
      IFEND;

      status.normal := TRUE;
      IF NOT state.path_description_obtained THEN
        clp$get_fs_path_string (state.file.local_file_name, state.path, ignore_path_size, ignore_path_handle,
              status);
      IFEND;

      IF status.normal THEN
        state.path_description_obtained := TRUE;
        process_command_in_catalog (state, status);

{ !!! KLUDGE !!! This can be removed when CATALOG_NAME_SECURITY is fixed.

        IF (NOT status.normal) AND (saved_status <> NIL) THEN
          status := saved_status^;
        IFEND;
      IFEND;

    ELSE
      REPEAT
        clp$close_command_library (state.file.local_file_name, local_status);
        IF NOT local_status.normal THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_file_reference;
            context^.file.file_reference := ^state.file.local_file_name;
          IFEND;
          context^.condition_status := local_status;
          osp$enforce_exception_policies (context^);
          local_status := context^.condition_status;
        IFEND;
      UNTIL local_status.normal OR (NOT osp$file_access_condition (local_status)) OR
            (NOT context^.wait);
    IFEND;

  PROCEND process_command_in_library;
?? TITLE := 'process_command_in_utility_lib', EJECT ??

  PROCEDURE process_command_in_utility_lib
    (VAR state {input, output} : clt$command_search_state;
         processor_name: pmt$program_name;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context,
      found_command: boolean,
      index: integer,
      local_file_name: amt$local_file_name,
      nested_commands_can_be_echoed: boolean;


    context := NIL;
    state.data.generic_source := clc$gcs_library;

    FOR index := 1 TO UPPERBOUND (state.source.utility_info^.libraries^) DO
      local_file_name := state.source.utility_info^.libraries^ [index];
      REPEAT
        clp$search_command_library (processor_name, clc$command, FALSE, state.work_area^, local_file_name,
              state.file_id, state.ring_attributes, nested_commands_can_be_echoed, state.library_search_info,
              found_command, status);
        IF NOT status.normal THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_file_reference;
            context^.file.file_reference := ^local_file_name;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF found_command THEN
        state.file.local_file_name := state.source.utility_info^.libraries^ [index];
        state.command_log_option := state.library_search_info.log_option;
        state.nested_commands_can_be_echoed := state.nested_commands_can_be_echoed AND
              nested_commands_can_be_echoed;
        invoke_command_in_library (state, processor_name, FALSE, status);
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal ('CL', cle$unable_to_call_command, state.name.value, status);

  PROCEND process_command_in_utility_lib;
?? TITLE := 'process_command_in_aux_library', EJECT ??

  PROCEDURE process_command_in_aux_library
    (VAR state {input, output} : clt$command_search_state;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context,
      index: integer,
      local_file_name: amt$local_file_name,
      nested_commands_can_be_echoed: boolean;


    context := NIL;
    state.data.generic_source := clc$gcs_library;

    FOR index := 1 TO UPPERBOUND (state.source.utility_info^.auxiliary_libraries^) DO
      IF state.source.utility_info^.auxiliary_libraries^ [index].contains.commands THEN
        local_file_name := state.source.utility_info^.auxiliary_libraries^ [index].name;
        REPEAT
          clp$search_command_library (state.search_name.value, clc$command, FALSE, state.work_area^,
                local_file_name, state.file_id, state.ring_attributes, nested_commands_can_be_echoed,
                state.library_search_info, state.found, status);
          IF NOT status.normal THEN
            IF context = NIL THEN
              PUSH context;
              context^ := osv$initial_exception_context;
              context^.file.selector := osc$ecp_file_reference;
              context^.file.file_reference := ^local_file_name;
            IFEND;
            context^.condition_status := status;
            osp$enforce_exception_policies (context^);
            status := context^.condition_status;
          IFEND;
        UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
        IF NOT status.normal THEN
          status.normal := TRUE;
        ELSEIF state.found THEN
          state.file.local_file_name := state.source.utility_info^.auxiliary_libraries^ [index].name;
          state.source.kind := clc$library_commands;
          state.source.local_file_name := state.source.utility_info^.auxiliary_libraries^ [index].name;
          state.source.ordinal := state.library_search_info.ordinal;
          state.command_log_option := state.library_search_info.log_option;
          state.command_logging_completed := TRUE;
          state.nested_commands_can_be_echoed := state.nested_commands_can_be_echoed AND
                nested_commands_can_be_echoed;
          invoke_command_in_library (state, state.search_name.value, FALSE, status);
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND process_command_in_aux_library;
*IFEND
?? TITLE := 'process_sub_command', EJECT ??

  PROCEDURE process_sub_command
    (VAR state {input, output} : clt$command_search_state;
         built_in_command_table: ^clt$command_table;
     VAR status: ost$status);

    VAR
      command_table: ^clt$command_table,
*IF NOT $true(osv$unix)
      context: ^ost$ecp_exception_context,
      current_task_id: pmt$task_id,
*ELSE
      current_task_id: integer,
      c_status: integer,
*IFEND
      entry_index: clt$command_table_index,
*IF NOT $true(osv$unix)
      loaded_address: pmt$loaded_address,
*IFEND
      loaded_command: clt$command;


    status.normal := TRUE;
*IF NOT $true(osv$unix)
    context := NIL;
*IFEND

    IF built_in_command_table = NIL THEN
      command_table := state.source.utility_info^.commands;
      state.source.auxilliary_table := FALSE;
    ELSE
      command_table := built_in_command_table;
    IFEND;

  /find_command/
    BEGIN
      IF command_table = NIL THEN
        RETURN;
      IFEND;
      clp$search_command_table (state.search_name.value, command_table, entry_index, state.found);
      IF state.found THEN
        EXIT /find_command/;
      ELSEIF built_in_command_table <> NIL THEN
        RETURN;
      IFEND;
*IF NOT $true(osv$unix)
      IF state.source.utility_info^.dialog_info.commands <> NIL THEN
        command_table := state.source.utility_info^.dialog_info.commands;
        clp$search_command_table (state.search_name.value, command_table, entry_index, state.found);
        IF state.found THEN
          state.source.auxilliary_table := TRUE;
          EXIT /find_command/;
        IFEND;
      IFEND;
      IF state.source.utility_info^.auxiliary_libraries <> NIL THEN
        process_command_in_aux_library (state, status);
      IFEND;
*IFEND
      RETURN;
    END /find_command/;

    IF built_in_command_table = NIL THEN
*IF NOT $true(osv$unix)
      pmp$get_task_id (current_task_id, status);
*ELSE
      c_status := 0;
      pmp_get_task_id (current_task_id, c_status);
      IF c_status <> 0 THEN
        osp$set_status_from_errno ('GET_TASK_ID', c_status, '', status);
      IFEND;
*IFEND
      IF NOT status.normal THEN
        RETURN;
      ELSEIF NOT ((state.source.utility_info^.task_id = current_task_id) OR
            (state.source.utility_info^.command_level AND (NOT state.source.auxilliary_table))) THEN
        osp$set_status_abnormal ('CL', cle$util_cmds_fctns_unavailable, state.name.value, status);
        RETURN;
      IFEND;
      state.command_logging_completed := state.command_logging_completed OR
            (NOT state.source.utility_info^.subcommand_logging_enabled);
      state.source.utility_termination_command := command_table^ [entry_index].ordinal =
            state.source.utility_info^.termination_command_ordinal;
    IFEND;

    state.command_log_option := command_table^ [entry_index].log_option;
    state.data.ordinal := command_table^ [entry_index].ordinal;
    state.data.call_method := command_table^ [entry_index].call_method;
    IF state.search_level = clc$direct_search THEN
      state.source.ordinal := command_table^ [entry_index].ordinal;
    IFEND;

    CASE state.data.call_method OF

    = clc$linked_call =
      invoke_sub_command (state, command_table^ [entry_index].command, status);

    = clc$unlinked_call =
*IF NOT $true(osv$unix)
      IF state.data.generic_source = clc$gcs_system_built_in THEN
        REPEAT
          clp$load_system_entry_point (command_table^ [entry_index].procedure_name, pmc$procedure_address,
                loaded_address, status);
          IF NOT status.normal THEN
            IF context = NIL THEN
              PUSH context;
              context^ := osv$initial_exception_context;
            IFEND;
            context^.condition_status := status;
            osp$enforce_exception_policies (context^);
            status := context^.condition_status;
          IFEND;
        UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
      ELSE
        pmp$load (command_table^ [entry_index].procedure_name, pmc$procedure_address, loaded_address, status);
      IFEND;
      IF status.normal THEN
        #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, loaded_command);
      IFEND;
      IF (NOT status.normal) OR (loaded_command = NIL) THEN
        osp$set_status_abnormal ('CL', cle$unable_to_call_command, state.name.value, status);
        RETURN;
      IFEND;
      invoke_sub_command (state, loaded_command, status);
*IFEND

    = clc$proc_call, clc$program_call =
*IF NOT $true(osv$unix)
      IF (built_in_command_table = NIL) AND (state.source.utility_info^.libraries <> NIL) THEN
        process_command_in_utility_lib (state, command_table^ [entry_index].procedure_name, status);
      ELSE
        clp$find_cmnd_or_func_in_prog (command_table^ [entry_index].procedure_name, clc$command,
              state.work_area^, state.file.local_file_name, state.ring_attributes, state.library_search_info,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal ('CL', cle$unable_to_call_command, state.name.value, status);
          RETURN;
        IFEND;
        state.command_log_option := state.library_search_info.log_option;
        state.file_id := amv$nil_file_identifier;
        state.nested_commands_can_be_echoed := FALSE;
        invoke_command_in_library (state, command_table^ [entry_index].procedure_name, TRUE, status);
      IFEND;
*IFEND
    ELSE
      osp$set_status_abnormal ('CL', cle$unable_to_call_command, state.name.value, status);
    CASEND;

  PROCEND process_sub_command;
*IF NOT $true(osv$unix)
?? TITLE := 'invoke_command_in_library', EJECT ??

  PROCEDURE invoke_command_in_library
    (VAR state {input, output} : clt$command_search_state;
         processor_name: pmt$program_name;
         use_current_program: boolean;
     VAR status: ost$status);

    VAR
      condition_count: 0 .. 1,
      file_count: 0 .. pmc$max_object_file_list,
      ignore_line_layout: clt$line_layout,
      library_count: 0 .. pmc$max_library_list,
      library_program_attributes: ^llt$program_attributes,
      library_program_description: ^llt$program_description,
      module_count: 0 .. pmc$max_module_list,
      object_library_list: ^pmt$object_library_list,
      program_attributes: ^pmt$program_attributes,
      program_description: ^pmt$program_description;


    status.normal := TRUE;
    state.data.ordinal := state.library_search_info.ordinal;
    CASE state.library_search_info.module_kind OF

    = llc$command_procedure, llc$applic_command_procedure =
      invoke_scl_procedure (state, ignore_line_layout, status);

    = llc$program_description, llc$applic_program_description =
      library_program_description := state.library_search_info.command_or_function_module;
      NEXT library_program_attributes IN library_program_description;
      IF pmc$object_file_list_specified IN library_program_attributes^.contents THEN
        file_count := library_program_attributes^.number_of_object_files;
      ELSE
        file_count := 0;
      IFEND;
      IF pmc$module_list_specified IN library_program_attributes^.contents THEN
        module_count := library_program_attributes^.number_of_modules;
      ELSE
        module_count := 0;
      IFEND;
      IF pmc$library_list_specified IN library_program_attributes^.contents THEN
        library_count := library_program_attributes^.number_of_libraries;
      ELSE
        library_count := 0;
      IFEND;
      IF pmc$condition_specified IN library_program_attributes^.contents THEN
        condition_count := 1;
      ELSE
        condition_count := 0;
      IFEND;
      PUSH program_description: [[REP #SIZE (pmt$program_attributes) +
            (file_count * #SIZE (amt$local_file_name)) + (module_count *
            #SIZE (pmt$program_name)) + (library_count * #SIZE (amt$local_file_name)) +
            (condition_count * #SIZE (pmt$enable_inhibit_conditions)) OF cell]];
      invoke_program_command (state, library_program_description, program_description, status);

    = llc$load_module =
      IF use_current_program THEN
        pmp$get_program_size (file_count, module_count, library_count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        PUSH program_description: [[REP #SIZE (pmt$program_attributes) +
              (file_count * #SIZE (amt$local_file_name)) + (module_count *
              #SIZE (pmt$program_name)) + (library_count * #SIZE (amt$local_file_name)) OF cell]];
        pmp$get_program_description (program_description^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        RESET program_description;
        NEXT program_attributes IN program_description;
        program_attributes^.contents := program_attributes^.contents +
              $pmt$prog_description_contents [pmc$starting_proc_specified];
        program_attributes^.starting_procedure := processor_name;
      ELSE
        PUSH program_description: [[pmt$program_attributes, REP 1 OF amt$local_file_name]];
        RESET program_description;
        NEXT program_attributes IN program_description;
        program_attributes^.contents := $pmt$prog_description_contents
              [pmc$starting_proc_specified, pmc$library_list_specified];
        program_attributes^.starting_procedure := processor_name;
        program_attributes^.number_of_libraries := 1;
        NEXT object_library_list: [1 .. 1] IN program_description;
        object_library_list^ [1] := state.file.local_file_name;
      IFEND;
      invoke_program_command (state, NIL, program_description, status);

    = llc$command_description, llc$applic_command_description =
      invoke_described_command (state, status);
    CASEND;

  PROCEND invoke_command_in_library;
?? TITLE := 'convert_program_description', EJECT ??

  PROCEDURE convert_program_description
    (    state: clt$command_search_state;
         original_program_description: ^llt$program_description;
         converted_program_description: ^pmt$program_description;
     VAR status: ost$status);

    VAR
      enable_inhibit_conditions: ^pmt$enable_inhibit_conditions,
      file_count: 0 .. pmc$max_object_file_list,
      file_index: 1 .. pmc$max_object_file_list,
      ignore_evaluated_file_reference: fst$evaluated_file_reference,
      library_count: 0 .. pmc$max_library_list,
      library_enable_inhib_conditions: ^pmt$enable_inhibit_conditions,
      library_index: 1 .. pmc$max_library_list,
      library_module_list: ^pmt$module_list,
      library_object_file_list: ^llt$object_file_list,
      library_object_library_list: ^llt$object_library_list,
      library_program_attributes: ^llt$program_attributes,
      library_program_description: ^llt$program_description,
      module_count: 0 .. pmc$max_module_list,
      module_index: 1 .. pmc$max_module_list,
      module_list: ^pmt$module_list,
      object_file_list: ^pmt$object_file_list,
      object_library_list: ^pmt$object_library_list,
      program_attributes: ^pmt$program_attributes,
      program_description: ^pmt$program_description,
      program_file: clt$file;


    status.normal := TRUE;
    library_program_description := original_program_description;
    RESET library_program_description;
    NEXT library_program_attributes IN library_program_description;
    program_description := converted_program_description;
    RESET program_description;
    NEXT program_attributes IN program_description;
    file_count := 0;
    library_count := 0;

    program_attributes^.contents := library_program_attributes^.contents;
    IF pmc$starting_proc_specified IN program_attributes^.contents THEN
      program_attributes^.starting_procedure := library_program_attributes^.starting_procedure;
    IFEND;

    IF pmc$object_file_list_specified IN program_attributes^.contents THEN
      program_attributes^.number_of_object_files := library_program_attributes^.number_of_object_files;
      NEXT library_object_file_list: [1 .. program_attributes^.number_of_object_files] IN
            library_program_description;
      NEXT object_file_list: [1 .. program_attributes^.number_of_object_files] IN program_description;
      FOR file_index := 1 TO program_attributes^.number_of_object_files DO
        clp$convert_str_to_path_handle (library_object_file_list^ [file_index], FALSE,
              state.interpreter_mode = clc$help_mode, TRUE, program_file.local_file_name,
              ignore_evaluated_file_reference, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal ('CL', cle$unable_to_call_command, state.name.value, status);
          RETURN;
        IFEND;
        object_file_list^ [file_index] := program_file.local_file_name;
      FOREND;
    IFEND;

    IF pmc$module_list_specified IN program_attributes^.contents THEN
      program_attributes^.number_of_modules := library_program_attributes^.number_of_modules;
      NEXT library_module_list: [1 .. program_attributes^.number_of_modules] IN library_program_description;
      NEXT module_list: [1 .. program_attributes^.number_of_modules] IN program_description;
      module_list^ := library_module_list^;
    IFEND;

    IF pmc$library_list_specified IN program_attributes^.contents THEN
      program_attributes^.number_of_libraries := library_program_attributes^.number_of_libraries;
      NEXT library_object_library_list: [1 .. program_attributes^.number_of_libraries] IN
            library_program_description;
      NEXT object_library_list: [1 .. program_attributes^.number_of_libraries] IN program_description;
      FOR library_index := 1 TO program_attributes^.number_of_libraries DO
        IF library_object_library_list^ [library_index] = loc$task_services_library_name THEN
          object_library_list^ [library_index] := loc$task_services_library_name;
        ELSEIF library_object_library_list^ [library_index] = 'OSF$CURRENT_LIBRARY' THEN
          object_library_list^ [library_index] := state.file.local_file_name;
        ELSE
          clp$convert_string_to_file (library_object_library_list^ [library_index], program_file, status);
          IF NOT status.normal THEN
            osp$set_status_abnormal ('CL', cle$unable_to_call_command, state.name.value, status);
            RETURN;
          IFEND;
          object_library_list^ [library_index] := program_file.local_file_name;
        IFEND;
      FOREND;
    IFEND;

    IF pmc$condition_specified IN program_attributes^.contents THEN
      NEXT library_enable_inhib_conditions IN library_program_description;
      NEXT enable_inhibit_conditions IN program_description;
      enable_inhibit_conditions^ := library_enable_inhib_conditions^;
    IFEND;

    IF pmc$load_map_file_specified IN program_attributes^.contents THEN
      clp$convert_string_to_file (library_program_attributes^.load_map_file, program_file, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal ('CL', cle$unable_to_call_command, state.name.value, status);
        RETURN;
      IFEND;
      program_attributes^.load_map_file := program_file.local_file_name;
    IFEND;

    IF pmc$load_map_options_specified IN program_attributes^.contents THEN
      program_attributes^.load_map_options := library_program_attributes^.load_map_options;
    IFEND;
    IF pmc$term_error_level_specified IN program_attributes^.contents THEN
      program_attributes^.termination_error_level := library_program_attributes^.termination_error_level;
    IFEND;
    IF pmc$preset_specified IN program_attributes^.contents THEN
      program_attributes^.preset := library_program_attributes^.preset;
    IFEND;
    IF pmc$max_stack_size_specified IN program_attributes^.contents THEN
      program_attributes^.maximum_stack_size := library_program_attributes^.maximum_stack_size;
    IFEND;

    IF pmc$debug_input_specified IN program_attributes^.contents THEN
      clp$convert_string_to_file (library_program_attributes^.debug_input, program_file, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal ('CL', cle$unable_to_call_command, state.name.value, status);
        RETURN;
      IFEND;
      program_attributes^.debug_input := program_file.local_file_name;
    IFEND;

    IF pmc$debug_output_specified IN program_attributes^.contents THEN
      clp$convert_string_to_file (library_program_attributes^.debug_output, program_file, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal ('CL', cle$unable_to_call_command, state.name.value, status);
        RETURN;
      IFEND;
      program_attributes^.debug_output := program_file.local_file_name;
    IFEND;

    IF pmc$abort_file_specified IN program_attributes^.contents THEN
      clp$convert_string_to_file (library_program_attributes^.abort_file, program_file, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal ('CL', cle$unable_to_call_command, state.name.value, status);
        RETURN;
      IFEND;
      program_attributes^.abort_file := program_file.local_file_name;
    IFEND;

    IF pmc$debug_mode_specified IN program_attributes^.contents THEN
      program_attributes^.debug_mode := library_program_attributes^.debug_mode;
    IFEND;

  PROCEND convert_program_description;
?? TITLE := 'invoke_scl_procedure', EJECT ??

  PROCEDURE invoke_scl_procedure
    (VAR state {input, output} : clt$command_search_state;
         line_layout: clt$line_layout;
     VAR status: ost$status);

    VAR
      converter: record
        case 0 .. 1 of
        = 0 =
          procedure_pointer: ^procedure
                 (VAR state {input, output} : clt$command_search_state;
                      line_layout: clt$line_layout;
                  VAR status: ost$status),
        = 1 =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend,
      end_proc_block: ^clt$block,
      header: ^clt$scl_procedure_header,
      parameters_work_area: ^^clt$work_area,
      pop_status: ost$status,
      proc_data: ^clt$scl_procedure,
      proc_status: ost$status,
      version: clt$declaration_version;

?? NEWTITLE := 'command_procedure_cond_handler', EJECT ??

{
{ PURPOSE:
{   This condition handler duplicates most of the command_condition_handler
{   within clp$process_commands.  It is allows any condition that arise to be
{   processed in the ring in which the command processor runs.
{

    PROCEDURE command_procedure_cond_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        exit_control_block: ^clt$block,
        ignore_status: ost$status,
        run_time_status: ^ost$status;


      CASE condition.selector OF

      = pmc$block_exit_processing =

{ --- Handle block exit.

        IF state.command_block <> NIL THEN
          clp$pop_terminated_blocks (state.command_block, status);
          handle_exit_from_procedure;
        IFEND;
        RETURN;

      = mmc$segment_access_condition =

{ --- Handle segment access conditions.

        osp$set_status_from_condition ('CL', condition, save_area, status, state.ignore_status);
        IF (status.condition = cle$work_area_overflow) AND (status.text.size = 0) AND state.found THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, state.name.value, status);
        IFEND;
        EXIT invoke_scl_procedure;

      = pmc$system_conditions =

{ --- Handle system (hardware detected) conditions.

        IF pmc$detected_uncorrected_err IN condition.system_conditions THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, state.ignore_status);
        IFEND;
        osp$set_status_from_condition ('CL', condition, save_area, status, state.ignore_status);
        EXIT invoke_scl_procedure;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN

{ --- Handle CYBIL run time error.

          run_time_status := condition_information;
          status := run_time_status^;
          EXIT invoke_scl_procedure;

        ELSEIF (condition.user_condition_name = clc$exiting_condition) AND (state.command_block <> NIL) AND
              state.command_block^.being_exited THEN

{ --- Handle exit initiated via command level EXIT statement.
{
{ This condition is raised in the task that "owns" the SCL block which is the
{ target of the EXIT statement.
{ This condition is specifically dealt with in the condition handlers that
{ cover processing of the various kinds of input, command and function blocks.
{ The condition_information for this condition is a pointer to the outermost
{ block which is being exited and has such a corresponding condition handler.
{ The handler which is "covering" this "exit_control_block" performs a
{ non-local (CYBIL) exit out of its establishing procedure.
{ Other such handlers simply "continue" the condition.

          exit_control_block := condition_information;
          IF #OFFSET (exit_control_block) <> #OFFSET (state.command_block) THEN
            pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          IFEND;
          EXIT invoke_scl_procedure;

        ELSE

{ --- "Continue" any other user defined condition.

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          RETURN;
        IFEND;

      ELSE

{ --- "Continue" any other condition.

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        RETURN;
      CASEND;

    PROCEND command_procedure_cond_handler;
?? TITLE := 'handle_exit_from_procedure', EJECT ??

    PROCEDURE [INLINE] handle_exit_from_procedure;

      VAR
        connected_files: ^clt$connected_files,
        ignore_cond_processed_state: clt$condition_processed_state;


      clp$process_exit_condition (state.command_block, status);
      IF status.normal AND (state.command_block^.command_proc_status <> NIL) AND
            (NOT state.command_block^.command_proc_status^.normal) THEN
        status := state.command_block^.command_proc_status^;
      IFEND;
      IF status.normal THEN
        proc_status.normal := TRUE;
      ELSE
        proc_status := status;
      IFEND;

      IF state.command_block^.input_can_be_echoed THEN
        clp$find_connected_files (connected_files);
        IF connected_files^.echo_count > 0 THEN
          clp$echo_trace_information ('CLC$ECHO_COMMAND_PROC_END', ^state.name.value,
                ^state.file.local_file_name, ^proc_status, state.ignore_status);
        IFEND;
      IFEND;

    PROCEND handle_exit_from_procedure;
?? TITLE := 'my_parameter_list', EJECT ??

    FUNCTION my_parameter_list: ^cell;

      VAR
        psa: ^ost$stack_frame_save_area;


      psa := #PREVIOUS_SAVE_AREA ();
      my_parameter_list := psa^.a4;

    FUNCEND my_parameter_list;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    IF (state.source.kind <> clc$catalog_commands) AND (state.ring_attributes.r2 < #RING (^converter)) THEN

{ This routine must call itself at the target ring in order to process the procedure at that ring.

      converter.procedure_pointer := ^invoke_scl_procedure;
      pmp$inward_call (converter.code_base_pointer, state.ring_attributes.r2, my_parameter_list (),
            #PREVIOUS_SAVE_AREA ());

{ The above call to PMP$INWARD_CALL should result in control being returned
{ directly to this procedure's caller.  The following RETURN statement is
{ here just for "safety's sake".

      RETURN;
    IFEND;

    state.data.call_method := clc$proc_call;
    emit_processed_command_stat (state);
    log_and_or_echo_command (state);

    proc_data := state.library_search_info.command_or_function_module;
    IF proc_data = NIL THEN
      header := NIL;
    ELSE
      RESET proc_data;
      NEXT header IN proc_data;
      IF (header = NIL) OR (header^.identifying_first_byte <> UPPERVALUE (header^.identifying_first_byte))
            THEN
        version := 0;
        header := NIL;
      ELSE
        version := header^.version;
        proc_data := #PTR (header^.procedure_body, proc_data^);
      IFEND;
      RESET proc_data;
    IFEND;

    state.nested_commands_can_be_echoed := state.nested_commands_can_be_echoed AND
          (state.command_log_option = clc$automatically_log) AND (state.interpreter_mode <> clc$help_mode);

    clp$push_command_proc_block (state.caller_ring, state.name.value, state.source,
          state.command_logging_completed, state.command_echoing_completed, state.prompting_requested,
          state.nested_commands_can_be_echoed, state.file.local_file_name, state.file_id, line_layout,
          proc_data, version, state.device_class, state.command_block);

    osp$establish_condition_handler (^command_procedure_cond_handler, TRUE);

    IF state.command_block^.input_can_be_echoed AND state.command_echoing_activated THEN
      clp$echo_trace_information ('CLC$ECHO_COMMAND_PROC_BEGIN', ^state.name.value,
            ^state.file.local_file_name, NIL, state.ignore_status);
    IFEND;

    initialize_application_info (state, status);

    IF status.normal THEN
      clp$get_work_area (#RING (^parameters_work_area), parameters_work_area, status);
      IF status.normal THEN
        clp$process_proc_parameters (clc$command, state.library_search_info.command_or_function_module,
              header, state.nested_commands_can_be_echoed, state.parse, parameters_work_area^, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      clp$process_command_file (state.command_block, NIL, status);
      IF status.normal AND (state.command_block^.command_proc_status <> NIL) AND
            (NOT state.command_block^.command_proc_status^.normal) THEN
        status := state.command_block^.command_proc_status^;
      IFEND;
    IFEND;

    IF status.normal AND (NOT state.command_block^.being_exited) THEN
      clp$find_current_block (end_proc_block);
      IF end_proc_block <> state.command_block THEN
        osp$set_status_abnormal ('CL', cle$unbalanced_block_structure, state.command_block^.kind_end_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, end_proc_block^.kind_end_name, status);
      IFEND;
    IFEND;

    verify_block_stack_integrity (state.command_block, status);

    state.command_logging_completed := state.command_logging_completed OR
          state.command_block^.command_proc_logging_completed;
    state.command_echoing_completed := state.command_echoing_completed OR
          state.command_block^.command_proc_echoing_completed;

    handle_exit_from_procedure;

    osp$disestablish_cond_handler;

    IF state.command_block^.parameters.command_status_specified THEN
      process_command_status ('STATUS', status);
    IFEND;

    clp$pop_input_stack (end_proc_block, pop_status);
    IF status.normal AND (NOT pop_status.normal) THEN
      status := pop_status;
    IFEND;

    IF status.normal THEN
      set_prev_cmnd_name_and_stat (state, proc_status);
    ELSE
      set_prev_cmnd_name_and_stat (state, status);
    IFEND;

  PROCEND invoke_scl_procedure;
?? TITLE := 'invoke_program_command', EJECT ??

  PROCEDURE invoke_program_command
    (VAR state {input, output} : clt$command_search_state;
         library_program_description: ^llt$program_description;
         program_description: ^pmt$program_description;
     VAR status: ost$status);

    VAR
      parameter_list: clt$i_parameter_list_contents,
      program_description_pointer: ^pmt$program_description,
      program_attributes: ^pmt$program_attributes,
      target_ring: ost$valid_ring,
      task_id: pmt$task_id,
      task_status: pmt$task_status;


    status.normal := TRUE;
    state.data.call_method := clc$program_call;
    emit_processed_command_stat (state);
    log_and_or_echo_command (state);

    clp$push_command_block (state.caller_ring, state.name.value, state.source,
          state.command_logging_completed, state.command_echoing_completed, state.prompting_requested,
          clc$program_command, state.parse, state.command_block);

    initialize_application_info (state, status);

    IF status.normal AND (library_program_description <> NIL) THEN
      convert_program_description (state, library_program_description, program_description, status);
    IFEND;

    IF status.normal THEN
      IF state.interpreter_mode = clc$help_mode THEN
        program_description_pointer := program_description;
        RESET program_description_pointer;
        NEXT program_attributes IN program_description_pointer;
        program_attributes^.contents := program_attributes^.contents +
              $pmt$prog_description_contents [pmc$load_map_file_specified, pmc$load_map_options_specified,
              pmc$term_error_level_specified, pmc$abort_file_specified, pmc$debug_mode_specified];
        program_attributes^.load_map_file := clv$standard_files [clc$sf_null_file].path_handle_name;
        program_attributes^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
        program_attributes^.termination_error_level := UPPERVALUE (pmt$termination_error_level);
        program_attributes^.abort_file := clv$standard_files [clc$sf_null_file].path_handle_name;
        program_attributes^.debug_mode := FALSE;
      IFEND;

      parameter_list.identifying_size_field := UPPERVALUE (parameter_list.identifying_size_field);

      IF state.source.kind = clc$catalog_commands THEN
        target_ring := state.caller_ring;
      ELSEIF state.caller_ring < state.ring_attributes.r1 THEN
        target_ring := state.ring_attributes.r1;
      ELSEIF state.caller_ring > state.ring_attributes.r2 THEN
        target_ring := state.ring_attributes.r2;
      ELSE
        target_ring := state.caller_ring;
      IFEND;

      IF state.command_from_execute_command THEN

{ If an outward call to the task is made, we will never return from this call.

        pmp$execute_within_task (program_description^, #SEQ (parameter_list) ^, status);
      ELSEIF target_ring <> state.caller_ring THEN
        clp$execute_named_task (osc$null_name, target_ring, program_description^, #SEQ (parameter_list) ^,
              osc$null_name, task_id, status);
      ELSE
        pmp$execute (program_description^, #SEQ (parameter_list) ^, osc$wait, task_id, task_status, status);
        IF status.normal AND (NOT task_status.status.normal) THEN
          status := task_status.status;
        IFEND;
      IFEND;
    IFEND;

    verify_block_stack_integrity (state.command_block, status);

    state.command_logging_completed := state.command_logging_completed OR
          state.command_block^.command_logging_completed;
    state.command_echoing_completed := state.command_echoing_completed OR
          state.command_block^.command_echoing_completed;

    set_prev_cmnd_name_and_stat (state, status);

    IF state.command_block^.parameters.command_status_variable <> NIL THEN
      process_command_status (state.command_block^.parameters.command_status_variable^, status);
    IFEND;

    clp$pop_block_stack (state.command_block);

  PROCEND invoke_program_command;
*IFEND
?? TITLE := 'invoke_sub_command', EJECT ??

  PROCEDURE invoke_sub_command
    (VAR state {input, output} : clt$command_search_state;
         command: clt$command;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
?? NEWTITLE := 'invoke_condition_handler', EJECT ??

    PROCEDURE invoke_condition_handler
      (    condition: pmt$condition;
           ignore_info: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      CASE condition.selector OF
      = pmc$system_conditions =
        IF (($pmt$system_conditions [pmc$instruction_specification, pmc$address_specification,
              pmc$access_violation, pmc$environment_specification, pmc$invalid_segment_ring_0,
              pmc$out_call_in_return] * condition.system_conditions) <> $pmt$system_conditions []) AND
              (save_area^.minimum_save_area.a2_previous_save_area = callers_save_area) THEN
          osp$set_status_abnormal ('CL', cle$unable_to_call_command, state.name.value, status);
          EXIT invoke_sub_command;
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = clc$command_cleanup_completed THEN

{ This deals with the INCLUDE_COMMAND command's need to do its own cleanup.

          command_cleanup_completed := TRUE;
          RETURN;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND invoke_condition_handler;
?? OLDTITLE, EJECT ??
*IFEND

    VAR
*IF NOT $true(osv$unix)
      callers_save_area: ^ost$stack_frame_save_area,
*IFEND
      command_cleanup_completed: boolean,
      parameter_list: clt$i_parameter_list_contents;


    status.normal := TRUE;

    IF state.command_block = NIL THEN
*IF NOT $true(osv$unix)
      emit_processed_command_stat (state);
*IFEND
      log_and_or_echo_command (state);

      clp$push_command_block (state.caller_ring, state.name.value, state.source,
            state.command_logging_completed, state.command_echoing_completed, state.prompting_requested,
            clc$regular_command, state.parse, state.command_block);
    IFEND;

*IF NOT $true(osv$unix)
    initialize_application_info (state, status);

    callers_save_area := #PREVIOUS_SAVE_AREA ();
*IFEND
    command_cleanup_completed := FALSE;
    parameter_list.identifying_size_field := UPPERVALUE (parameter_list.identifying_size_field);

*IF NOT $true(osv$unix)
    osp$establish_condition_handler (^invoke_condition_handler, FALSE);
*IFEND
    command^ (#SEQ (parameter_list) ^, status);
*IF NOT $true(osv$unix)
    osp$disestablish_cond_handler;
*IFEND

    IF (NOT status.normal) AND (status.condition = cle$unknown_command) AND (status.text.size = 0) THEN
      osp$append_status_parameter (osc$status_parameter_delimiter, state.name.value, status);
    IFEND;

*IF NOT $true(osv$unix)
    state.command_logging_completed := state.command_logging_completed OR
          state.command_block^.command_logging_completed;
    state.command_echoing_completed := state.command_echoing_completed OR
          state.command_block^.command_echoing_completed;
*IFEND

    IF command_cleanup_completed AND (state.interpreter_mode <> clc$help_mode) THEN
      RETURN;
    IFEND;

    verify_block_stack_integrity (state.command_block, status);

    IF state.interpreter_mode = clc$interpret_mode THEN
*IF NOT $true(osv$unix)
      set_prev_cmnd_name_and_stat (state, status);
*IFEND

      IF state.command_block^.parameters.command_status_variable <> NIL THEN
*IF NOT $true(osv$unix)
        process_command_status (state.command_block^.parameters.command_status_variable^, status);
*ELSE
        process_command_status (status);
*IFEND
      IFEND;
    IFEND;

    clp$pop_block_stack (state.command_block);

  PROCEND invoke_sub_command;
*IF NOT $true(osv$unix)
?? TITLE := 'invoke_described_command', EJECT ??

  PROCEDURE invoke_described_command
    (VAR state {input, output} : clt$command_search_state;
     VAR status: ost$status);

    VAR
      command_description_contents: ^llt$command_desc_contents,
      converter: record
        case 0 .. 1 of
        = 0 =
          procedure_pointer: ^procedure
                 (VAR state {input, output} : clt$command_search_state;
                  VAR status: ost$status),
        = 1 =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend,
      library_file: clt$file,
      library_path: ^fst$file_reference,
      loaded_address: pmt$loaded_address,
      loaded_command: clt$command,
      search_$system_option: clt$search_$system_option;

?? NEWTITLE := 'described_command_cond_handler', EJECT ??

{
{ PURPOSE:
{   This condition handler duplicates most of the command_condition_handler
{   within clp$process_commands.  It is allows any condition that arise to be
{   processed in the ring in which the command processor runs.
{

    PROCEDURE described_command_cond_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        exit_control_block: ^clt$block,
        ignore_status: ost$status,
        run_time_status: ^ost$status;


      CASE condition.selector OF

      = pmc$block_exit_processing =

{ --- Handle block exit.

        RETURN;

      = mmc$segment_access_condition =

{ --- Handle segment access conditions.

        osp$set_status_from_condition ('CL', condition, save_area, status, state.ignore_status);
        IF (status.condition = cle$work_area_overflow) AND (status.text.size = 0) AND state.found THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, state.name.value, status);
        IFEND;
        EXIT invoke_described_command;

      = pmc$system_conditions =

{ --- Handle system (hardware detected) conditions.

        IF pmc$detected_uncorrected_err IN condition.system_conditions THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, state.ignore_status);
        IFEND;
        osp$set_status_from_condition ('CL', condition, save_area, status, state.ignore_status);
        EXIT invoke_described_command;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN

{ --- Handle CYBIL run time error.

          run_time_status := condition_information;
          status := run_time_status^;
          EXIT invoke_described_command;

        ELSEIF (condition.user_condition_name = clc$exiting_condition) AND (state.command_block <> NIL) AND
              state.command_block^.being_exited THEN

{ --- Handle exit initiated via command level EXIT statement.
{
{ This condition is raised in the task that "owns" the SCL block which is the
{ target of the EXIT statement.
{ This condition is specifically dealt with in the condition handlers that
{ cover processing of the various kinds of input, command and function blocks.
{ The condition_information for this condition is a pointer to the outermost
{ block which is being exited and has such a corresponding condition handler.
{ The handler which is "covering" this "exit_control_block" performs a
{ non-local (CYBIL) exit out of its establishing procedure.
{ Other such handlers simply "continue" the condition.

          exit_control_block := condition_information;
          IF #OFFSET (exit_control_block) <> #OFFSET (state.command_block) THEN
            pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          IFEND;
          EXIT invoke_described_command;

        ELSE

{ --- "Continue" any other user defined condition.

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          RETURN;
        IFEND;

      ELSE

{ --- "Continue" any other condition.

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        RETURN;
      CASEND;

    PROCEND described_command_cond_handler;
?? TITLE := 'my_parameter_list', EJECT ??

    FUNCTION my_parameter_list: ^cell;

      VAR
        psa: ^ost$stack_frame_save_area;


      psa := #PREVIOUS_SAVE_AREA ();
      my_parameter_list := psa^.a4;

    FUNCEND my_parameter_list;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    IF state.ring_attributes.r2 < #RING (^converter) THEN

{ This routine must call itself at the target ring in order to process the command at that ring.

      converter.procedure_pointer := ^invoke_described_command;
      pmp$inward_call (converter.code_base_pointer, state.ring_attributes.r2, my_parameter_list (),
            #PREVIOUS_SAVE_AREA ());

{ The above call to PMP$INWARD_CALL should result in control being returned
{ directly to this procedure's caller.  The following RETURN statement is
{ here just for "safety's sake".

      RETURN;
    IFEND;

    state.data.call_method := clc$unlinked_call;

    NEXT command_description_contents IN state.library_search_info.command_or_function_module;
    IF command_description_contents = NIL THEN
      osp$set_status_abnormal ('CL', cle$unable_to_call_command, state.name.value, status);
      RETURN;
    IFEND;

    IF command_description_contents^.system_command THEN
      IF state.source.kind = clc$system_commands THEN
        search_$system_option := clc$skip_system_library;
      ELSE
        search_$system_option := clc$search_system_library;
      IFEND;
      state.search_level := clc$indirect_search;
      state.search_name.size := clp$trimmed_string_size (command_description_contents^.system_command_name);
      state.search_name.value := command_description_contents^.system_command_name;
      state.found := FALSE;
      process_system_command (search_$system_option, state, status);
      IF status.normal AND (NOT state.found) THEN
        osp$set_status_abnormal ('CL', cle$unable_to_call_command, state.name.value, status);
      IFEND;
      state.found := TRUE;
      RETURN;
    IFEND;

    emit_processed_command_stat (state);
    log_and_or_echo_command (state);

    clp$push_command_block (state.caller_ring, state.name.value, state.source,
          state.command_logging_completed, state.command_echoing_completed, state.prompting_requested,
          clc$regular_command, state.parse, state.command_block);

    osp$establish_condition_handler (^described_command_cond_handler, FALSE);

    IF command_description_contents^.library_path_size > 0 THEN
      NEXT library_path: [command_description_contents^.library_path_size] IN
            state.library_search_info.command_or_function_module;
      IF library_path = NIL THEN
        osp$set_status_abnormal ('CL', cle$unable_to_call_command, state.name.value, status);
        clp$pop_block_stack(state.command_block);
        RETURN;
      ELSEIF library_path^ = 'OSF$CURRENT_LIBRARY' THEN
        library_file.local_file_name := state.file.local_file_name;
      ELSE
        clp$convert_string_to_file (library_path^, library_file, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal ('CL', cle$unable_to_call_command, state.name.value, status);
          clp$pop_block_stack(state.command_block);
          RETURN;
        IFEND;
      IFEND;
      IF state.file.local_file_name = osc$null_name THEN
        clp$load_system_entry_point (command_description_contents^.starting_procedure, pmc$procedure_address,
              loaded_address, status);
      ELSE
        clp$load_from_library (command_description_contents^.starting_procedure, pmc$procedure_address,
              library_file.local_file_name, loaded_address, status);
      IFEND;
    ELSE
      pmp$load (command_description_contents^.starting_procedure, pmc$procedure_address, loaded_address,
            status);
    IFEND;

    IF status.normal THEN
      #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, loaded_command);
    IFEND;
    IF (NOT status.normal) OR (loaded_command = NIL) THEN
      osp$set_status_abnormal ('CL', cle$unable_to_call_command, state.name.value, status);
      clp$pop_block_stack(state.command_block);
      RETURN;
    IFEND;

    invoke_sub_command (state, loaded_command, status);

  PROCEND invoke_described_command;
*IFEND
?? TITLE := 'process_system_command', EJECT ??

  PROCEDURE [INLINE] process_system_command
    (    search_option: clt$search_$system_option;
     VAR state {input, output} : clt$command_search_state;
     VAR status: ost$status);


    status.normal := TRUE;

*IF NOT $true(osv$unix)
    IF jmp$system_job () THEN
      state.data.generic_source := clc$gcs_system_built_in;
      IF state.search_level = clc$direct_search THEN
        state.source.system_command_table := clv$operator_commands;
      IFEND;
      process_sub_command (state, clv$operator_commands, status);
    IFEND;
*IFEND

    IF status.normal AND (NOT state.found) THEN
      IF search_option = clc$search_system_library THEN
*IF NOT $true(osv$unix)
        IF (state.command_list^.system_command_library_lfn <> osc$null_name) AND
              state.command_list^.system_library_contains.commands THEN
          state.file.local_file_name := osc$null_name;
          state.path_description_obtained := FALSE;
          IF state.search_level = clc$direct_search THEN
            state.source.system_command_table := NIL;
          IFEND;
          process_command_in_library (FALSE, state, status);
        IFEND;
*IFEND
      IFEND;

      IF status.normal AND (NOT state.found) THEN
*IF NOT $true(osv$unix)
{Add this back in when we have a $SYSTEM entry
        state.data.generic_source := clc$gcs_system_built_in;
        IF state.search_level = clc$direct_search THEN
          state.source.system_command_table := clv$system_commands;
        IFEND;
        process_sub_command (state, clv$system_commands, status);
*IFEND
      IFEND;
    IFEND;

  PROCEND process_system_command;
?? TITLE := 'process_command_status', EJECT ??

  PROCEDURE [INLINE] process_command_status
*IF NOT $true(osv$unix)
    (    status_variable: clt$variable_ref_expression;
     VAR status {input, output} : ost$status);
*ELSE
    (VAR status {input, output} : ost$status);
*IFEND

    VAR
      status_value: ^clt$data_value;


*IF NOT $true(osv$unix)
    PUSH status_value;
    status_value^.kind := clc$status;
    PUSH status_value^.status_value;
    status_value^.status_value^ := status;

    clp$change_variable (status_variable, status_value, status);
*ELSE
    status.normal := TRUE;
*IFEND

  PROCEND process_command_status;
?? TITLE := 'verify_block_stack_integrity', EJECT ??

  PROCEDURE [INLINE] verify_block_stack_integrity
    (    command_block: ^clt$block;
     VAR status {input,output} : ost$status);

    VAR
      current_block: ^clt$block;


    clp$find_current_block (current_block);
    WHILE current_block <> command_block DO
      IF current_block^.kind = clc$task_block THEN
*IF NOT $true(osv$unix)
        osp$system_error ('SCL Block Stack Corrupted', ^status);
*ELSE
{Change this condition later!!!!
        osp$set_status_condition (cle$work_area_overflow, status);
        RETURN;
*IFEND
      IFEND;
      current_block := current_block^.previous_block;
    WHILEND;

    clp$pop_terminated_blocks (command_block, status);

  PROCEND verify_block_stack_integrity;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$asynchronous_command', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$asynchronous_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    CONST
      not_from_job_command_file = FALSE,
      command_from_execute_command = TRUE,
      dont_log_the_command = FALSE;

    VAR
      block: ^clt$block,
      program_parameters: ^pmt$program_parameters,
      ignore_cause_condition: clt$when_condition,
      command_parameters: ^clt$async_command_parameters;


    status.normal := TRUE;

    program_parameters := ^parameter_list;
    RESET program_parameters;
    NEXT command_parameters IN program_parameters;
    IF (command_parameters = NIL) OR (command_parameters^.text_size = 0) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$asynchronous_command', status);
      RETURN;
    IFEND;

    NEXT command_parameters^.parse.text: [command_parameters^.text_size] IN program_parameters;
    IF command_parameters^.parse.text = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$asynchronous_command', status);
      RETURN;
    IFEND;

    NEXT command_parameters^.parse.units_array: [1 .. command_parameters^.units_array_size] IN
          program_parameters;
    IF command_parameters^.parse.units_array = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$asynchronous_command', status);
      RETURN;
    IFEND;

    IF command_parameters^.init_from_desktop_environment THEN
      osp$set_desktop_interaction (status);
      IF NOT status.normal THEN
        osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$asynchronous_command', status);
        RETURN;
      IFEND;
    IFEND;

    clp$find_current_block (block);
    clp$process_command (block, clc$interpret_mode, not_from_job_command_file, command_from_execute_command,
          dont_log_the_command, command_parameters^.command_can_be_echoed, command_parameters^.parse,
          ignore_cause_condition, status);

  PROCEND clp$asynchronous_command;
*IFEND

MODEND clm$process_commands;
*DECK DECK=CLM$PROCESS_DATA_TYPES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL : Data type processing routines' ??
MODULE clm$process_data_types;

{
{ PURPOSE:
{   This module contains the procedures that perform various processes with
{   data type specification and descriptions.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
*IF NOT $true(osv$unix)
?? PUSH (LISTEXT := ON) ??
*copyc cld$variable_reference
*copyc cle$bad_data_value
*copyc cle$bad_type_description
*copyc cle$bad_type_specification
*copyc cle$ecc_parsing
*copyc clt$comparison_results
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$type_changes
*copyc clt$type_conformance
*copyc clt$type_description
*copyc clt$type_information
*copyc clt$type_specification
*copyc clt$variable_kinds
*copyc clt$work_area
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc clp$check_keyword
*copyc clp$search_keyword_specs
*copyc clp$longreal_compare
*copyc clp$longreal_compare_eq
*copyc clp$longreal_compare_gt
*copyc clp$longreal_compare_le
*copyc clp$longreal_compare_lt
*copyc clp$trimmed_string_size
*copyc clv$negative_infinity
*copyc clv$positive_infinity
*copyc clv$type_kind_names
*copyc clv$value_type_kinds
*copyc i#current_sequence_position
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*ELSE
*copyc i#current_sequence_position
*copyc clp$trimmed_string_size
*copyc clt$comparison_results
*copyc clp$check_keyword
*copyc cle$bad_type_description
*copyc clv$value_type_kinds
*copyc cle$bad_data_value
*copyc clt$type_conformance
*copyc clv$type_kind_names
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc clp$type_kinds_v2
*copyc clt$type_specification
*copyc clt$work_area
*copyc clt$type_description
*copyc cle$work_area_overflow
*copyc cle$bad_type_specification
*copyc ost$status
*copyc clt$data_value
*copyc cle$ecc_parsing
*copyc clv$negative_infinity
*copyc clv$positive_infinity
*copyc clc$declaration_version
*IFEND
?? TITLE := 'clp$append_status_type', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$append_status_type
    (    delimiter: char;
         type_specification: ^clt$type_specification;
     VAR status {input, output} : ost$status);

    VAR
      header: ^clt$type_specification_header,
      name: ^clt$type_name_reference,
      specification: ^clt$type_specification;


    specification := type_specification;
    RESET specification;
    NEXT header IN specification;
    IF header^.name_size = 0 THEN
      osp$append_status_parameter (delimiter, clv$type_kind_names [header^.kind], status);
    ELSE
      NEXT name: [header^.name_size] IN specification;
      osp$append_status_parameter (delimiter, name^, status);
    IFEND;

  PROCEND clp$append_status_type;
?? TITLE := 'clp$append_status_type_desc', EJECT ??

  PROCEDURE [XDCL] clp$append_status_type_desc
    (    delimiter: char;
         type_description: ^clt$type_description;
     VAR status {input, output} : ost$status);


    IF type_description^.name <> NIL THEN
      osp$append_status_parameter (delimiter, type_description^.name^, status);
    ELSE
      osp$append_status_parameter (delimiter, clv$type_kind_names [type_description^.kind], status);
    IFEND;

  PROCEND clp$append_status_type_desc;
?? TITLE := 'clp$append_status_value_type', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$append_status_value_type
    (    delimiter: char;
         value: ^clt$data_value;
     VAR status {input, output} : ost$status);


    IF (value = NIL) OR (value^.kind = clc$unspecified) THEN
      osp$append_status_parameter (delimiter, 'UNSPECIFIED value', status);
    ELSEIF value^.kind = clc$deferred THEN
      clp$append_status_type (delimiter, value^.deferred_type, status);
    ELSE
      osp$append_status_parameter (delimiter, clv$type_kind_names [clv$value_type_kinds [value^.kind]],
            status);
    IFEND;

  PROCEND clp$append_status_value_type;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$change_type_specification', EJECT ??
*copyc clh$change_type_specification

  PROCEDURE [XDCL, #GATE] clp$change_type_specification
    (    type_specification_ptr: ^clt$type_specification;
         type_changes: clt$type_changes;
     VAR status: ost$status);

    VAR
      application_type_qualifier: ^clt$application_type_qualifier,
      array_type_qualifier: ^clt$array_type_qualifier,
      date_time_type_qualifier: ^clt$date_time_type_qualifier,
      element_type_specification: ^clt$type_specification,
      field_specification: ^clt$field_specification,
      field_type_specification: ^clt$type_specification,
      header: ^clt$type_specification_header,
      i: integer,
      integer_type_qualifier: ^clt$integer_type_qualifier,
      k: integer,
      keyword_found: boolean,
      keyword_index: clt$keyword_index,
      keyword_ordinal: clt$named_entry_ordinal,
      keyword_specifications: ^clt$keyword_specifications,
      keyword_type_qualifier: ^clt$keyword_type_qualifier,
      list_type_qualifier: ^clt$list_type_qualifier_v2,
      member_type_specification_size: ^clt$type_specification_size,
      member_type_specification: ^clt$type_specification,
      name_type_qualifier: ^clt$name_type_qualifier,
      range_type_qualifier: ^clt$range_type_qualifier,
      real_type_qualifier: ^clt$real_type_qualifier,
      record_type_qualifier: ^clt$record_type_qualifier,
      string_type_qualifier: ^clt$string_type_qualifier,
      type_name: ^clt$type_name_reference,
      type_specification: ^clt$type_specification,
*IF NOT $true(osv$unix)
      union_type_qualifier: ^clt$union_type_qualifier;
*ELSE
      union_type_qualifier: ^clt$union_type_qualifier_v2;
*IFEND


    status.normal := TRUE;
    type_specification := type_specification_ptr;

  /type_specification_ok/
    BEGIN
      IF type_specification = NIL THEN
        EXIT /type_specification_ok/;
      IFEND;
      RESET type_specification;

      NEXT header IN type_specification;
*IF NOT $true(osv$unix)
      IF (header = NIL) OR (header^.version <> clc$declaration_version) OR
*ELSE
      IF (header = NIL) OR (header^.version < 1) OR (header^.version > clc$declaration_version) OR
*IFEND
            (header^.kind < LOWERVALUE (clt$type_kind)) OR (header^.kind > UPPERVALUE (clt$type_kind)) THEN
        EXIT /type_specification_ok/;
      IFEND;
      NEXT type_name: [header^.name_size] IN type_specification;
      IF type_name = NIL THEN
        EXIT /type_specification_ok/;
      IFEND;
      CASE header^.kind OF

      = clc$application_type =
        NEXT application_type_qualifier IN type_specification;
        IF application_type_qualifier = NIL THEN
          EXIT /type_specification_ok/;
        IFEND;

      = clc$array_type =
        NEXT array_type_qualifier IN type_specification;
        IF array_type_qualifier = NIL THEN
          EXIT /type_specification_ok/;
        IFEND;
        IF array_type_qualifier^.array_bounds_defined AND
              ((clc$min_array_bound > array_type_qualifier^.bounds.lower) OR
              (array_type_qualifier^.bounds.lower > array_type_qualifier^.bounds.upper) OR
              (array_type_qualifier^.bounds.upper > clc$max_array_bound)) THEN
          EXIT /type_specification_ok/;
        IFEND;
        IF array_type_qualifier^.element_type_specification_size > 0 THEN
          NEXT element_type_specification: [[REP array_type_qualifier^.element_type_specification_size OF
                cell]] IN type_specification;
          IF element_type_specification = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          clp$change_type_specification (element_type_specification, type_changes, status);
        IFEND;

      = clc$boolean_type =
        ;

      = clc$cobol_name_type =
        ;

      = clc$command_reference_type =
        ;

      = clc$data_name_type =
        ;

      = clc$date_time_type =
        NEXT date_time_type_qualifier IN type_specification;
        IF date_time_type_qualifier = NIL THEN
          EXIT /type_specification_ok/;
        IFEND;

      = clc$entry_point_reference_type =
        ;

*IF NOT $true(osv$unix)
      = clc$file_type =
*ELSE
      = clc$nos_ve_file_type =
*IFEND
        ;

      = clc$integer_type =
        NEXT integer_type_qualifier IN type_specification;
        IF integer_type_qualifier = NIL THEN
          EXIT /type_specification_ok/;
        IFEND;

      /make_integer_subrange_change/
        FOR k := 1 TO UPPERBOUND (type_changes) DO
          IF type_changes [k].kind = clc$tc_integer_subrange THEN
            integer_type_qualifier^.min_integer_value := type_changes [k].min_integer_value;
            integer_type_qualifier^.max_integer_value := type_changes [k].max_integer_value;
            EXIT /make_integer_subrange_change/;
          IFEND;
        FOREND /make_integer_subrange_change/;

      = clc$keyword_type =
        NEXT keyword_type_qualifier IN type_specification;
        IF (keyword_type_qualifier = NIL) OR (keyword_type_qualifier^.number_of_keywords < 1) OR
              (keyword_type_qualifier^.number_of_keywords > clc$max_keywords) THEN
          EXIT /type_specification_ok/;
        IFEND;
        NEXT keyword_specifications: [1 .. keyword_type_qualifier^.number_of_keywords] IN
              type_specification;
        IF keyword_specifications = NIL THEN
          EXIT /type_specification_ok/;
        IFEND;

      /make_keyword_avail_change/
        FOR k := 1 TO UPPERBOUND (type_changes) DO
          IF type_changes [k].kind = clc$tc_keyword_availability THEN
            clp$search_keyword_specs (type_changes [k].keyword, keyword_specifications, keyword_index,
                  keyword_found);
            IF keyword_found THEN
              keyword_ordinal := keyword_specifications^ [keyword_index].ordinal;
              FOR i := 1 TO keyword_type_qualifier^.number_of_keywords DO
                IF keyword_specifications^ [i].ordinal = keyword_ordinal THEN
                  keyword_specifications^ [i].availability := type_changes [k].availability;
                IFEND;
              FOREND;
            IFEND;
          IFEND;
        FOREND /make_keyword_avail_change/;

      = clc$list_type =
        NEXT list_type_qualifier IN type_specification;
        IF (list_type_qualifier = NIL) OR (list_type_qualifier^.min_list_size >
              list_type_qualifier^.max_list_size) OR (list_type_qualifier^.max_list_size >
              clc$max_list_size) THEN
          EXIT /type_specification_ok/;
        IFEND;

      /make_list_size_change/
        FOR k := 1 TO UPPERBOUND (type_changes) DO
          IF type_changes [k].kind = clc$tc_list_size THEN
            list_type_qualifier^.min_list_size := type_changes [k].min_list_size;
            list_type_qualifier^.max_list_size := type_changes [k].max_list_size;
            EXIT /make_list_size_change/;
          IFEND;
        FOREND /make_list_size_change/;

        IF list_type_qualifier^.element_type_specification_size > 0 THEN
          NEXT element_type_specification: [[REP list_type_qualifier^.element_type_specification_size OF
                cell]] IN type_specification;
          IF element_type_specification = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          clp$change_type_specification (element_type_specification, type_changes, status);
        IFEND;

      = clc$lock_type =
        ;

      = clc$name_type =
        NEXT name_type_qualifier IN type_specification;
        IF (name_type_qualifier = NIL) OR (name_type_qualifier^.min_name_size < 1) OR
              (name_type_qualifier^.min_name_size > name_type_qualifier^.max_name_size) OR
              (name_type_qualifier^.max_name_size > osc$max_name_size) THEN
          EXIT /type_specification_ok/;
        IFEND;

      = clc$network_title_type =
        ;

      = clc$program_name_type =
        ;

      = clc$range_type =
        NEXT range_type_qualifier IN type_specification;
        IF range_type_qualifier = NIL THEN
          EXIT /type_specification_ok/;
        IFEND;
        IF range_type_qualifier^.element_type_specification_size > 0 THEN
          NEXT element_type_specification: [[REP range_type_qualifier^.element_type_specification_size OF
                cell]] IN type_specification;
          IF element_type_specification = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          clp$change_type_specification (element_type_specification, type_changes, status);
        IFEND;

      = clc$real_type =
        NEXT real_type_qualifier IN type_specification;
        IF real_type_qualifier = NIL THEN
          EXIT /type_specification_ok/;
        IFEND;

      /make_real_subrange_change/
        FOR k := 1 TO UPPERBOUND (type_changes) DO
          IF type_changes [k].kind = clc$tc_real_subrange THEN
            real_type_qualifier^.min_real_value.long_real := type_changes [k].min_real_value;
            real_type_qualifier^.max_real_value.long_real := type_changes [k].max_real_value;
            EXIT /make_real_subrange_change/;
          IFEND;
        FOREND /make_real_subrange_change/;

      = clc$record_type =
        NEXT record_type_qualifier IN type_specification;
        IF (record_type_qualifier = NIL) OR (record_type_qualifier^.number_of_fields < 1) OR
              (record_type_qualifier^.number_of_fields > clc$max_fields) THEN
          EXIT /type_specification_ok/;
        IFEND;
        FOR i := 1 TO record_type_qualifier^.number_of_fields DO
          NEXT field_specification IN type_specification;
          IF field_specification = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          NEXT field_type_specification: [[REP field_specification^.type_specification_size OF cell]] IN
                type_specification;
          IF field_type_specification = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          clp$change_type_specification (field_type_specification, type_changes, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;

      = clc$scu_line_identifier_type =
        ;

      = clc$statistic_code_type =
        ;

      = clc$status_type =
        ;

      = clc$status_code_type =
        ;

      = clc$string_type =
        NEXT string_type_qualifier IN type_specification;
        IF (string_type_qualifier = NIL) OR (string_type_qualifier^.min_string_size >
              string_type_qualifier^.max_string_size) OR (string_type_qualifier^.max_string_size >
              clc$max_string_size) THEN
          EXIT /type_specification_ok/;
        IFEND;

      /make_string_size_change/
        FOR k := 1 TO UPPERBOUND (type_changes) DO
          IF type_changes [k].kind = clc$tc_string_size THEN
            string_type_qualifier^.min_string_size := type_changes [k].min_string_size;
            string_type_qualifier^.max_string_size := type_changes [k].max_string_size;
            EXIT /make_string_size_change/;
          IFEND;
        FOREND /make_string_size_change/;

      = clc$string_pattern_type =
        ;

      = clc$time_increment_type =
        ;

      = clc$time_zone_type =
        ;

      = clc$type_specification_type =
        ;

      = clc$union_type =
        NEXT union_type_qualifier IN type_specification;
        IF (union_type_qualifier = NIL) OR (union_type_qualifier^.number_of_members > clc$max_union_members)
              THEN
          EXIT /type_specification_ok/;
        IFEND;
        IF union_type_qualifier^.number_of_members > 0 THEN
          FOR i := 1 TO union_type_qualifier^.number_of_members DO
            NEXT member_type_specification_size IN type_specification;
            IF member_type_specification_size = NIL THEN
              EXIT /type_specification_ok/;
            IFEND;
            NEXT member_type_specification: [[REP member_type_specification_size^ OF cell]] IN
                  type_specification;
            IF member_type_specification = NIL THEN
              EXIT /type_specification_ok/;
            IFEND;
            clp$change_type_specification (member_type_specification, type_changes, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND;
        IFEND;
*IF $true(osv$unix)

      = clc$unix_file_type =
        ;
*IFEND

      ELSE
        EXIT /type_specification_ok/;
      CASEND;
      RETURN;

    END /type_specification_ok/;
    osp$set_status_condition (cle$bad_type_specification, status);

  PROCEND clp$change_type_specification;
*IFEND
?? TITLE := 'clp$convert_type_desc_to_spec', EJECT ??

  PROCEDURE [XDCL] clp$convert_type_desc_to_spec
    (    type_description: ^clt$type_description;
     VAR work_area {input, output} : ^clt$work_area;
     VAR type_specification: ^clt$type_specification;
     VAR status: ost$status);

    VAR
      application_type_qualifier: ^clt$application_type_qualifier,
      array_type_qualifier: ^clt$array_type_qualifier,
      date_time_type_qualifier: ^clt$date_time_type_qualifier,
      element_type_specification: ^clt$type_specification,
      field_specification: ^clt$field_specification,
      field_type_specification: ^clt$type_specification,
      final_work_area_position: integer,
      header: ^clt$type_specification_header,
      i: integer,
      integer_type_qualifier: ^clt$integer_type_qualifier,
      keyword_specifications: ^clt$keyword_specifications,
      keyword_type_qualifier: ^clt$keyword_type_qualifier,
      list_type_qualifier: ^clt$list_type_qualifier_v2,
      member_type_specification_size: ^clt$type_specification_size,
      member_type_specification: ^clt$type_specification,
      name_type_qualifier: ^clt$name_type_qualifier,
      range_type_qualifier: ^clt$range_type_qualifier,
      real_type_qualifier: ^clt$real_type_qualifier,
      record_type_qualifier: ^clt$record_type_qualifier,
      string_type_qualifier: ^clt$string_type_qualifier,
      type_name: ^clt$type_name_reference,
*IF NOT $true(osv$unix)
      union_type_qualifier: ^clt$union_type_qualifier;
*ELSE
      union_type_qualifier: ^clt$union_type_qualifier_v2;
*IFEND


    status.normal := TRUE;
    IF type_description^.specification <> NIL THEN
      type_specification := type_description^.specification;
      RETURN;
    IFEND;

    type_specification := NIL;

  /work_area_ok/
    BEGIN
      NEXT header IN work_area;
      IF header = NIL THEN
        EXIT /work_area_ok/;
      IFEND;
      header^.version := clc$declaration_version;
      IF type_description^.name = NIL THEN
        header^.name_size := 0;
      ELSE
        header^.name_size := STRLENGTH (type_description^.name^);
        NEXT type_name: [header^.name_size] IN work_area;
        IF type_name = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        type_name^ := type_description^.name^;
      IFEND;
      header^.kind := type_description^.kind;
      CASE header^.kind OF

      = clc$application_type =
        NEXT application_type_qualifier IN work_area;
        IF application_type_qualifier = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        application_type_qualifier^.balance_brackets := type_description^.balance_brackets;

      = clc$array_type =
        NEXT array_type_qualifier IN work_area;
        IF array_type_qualifier = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        array_type_qualifier^.array_bounds_defined := type_description^.array_bounds_defined;
        IF array_type_qualifier^.array_bounds_defined THEN
          array_type_qualifier^.bounds.lower := type_description^.bounds.lower;
          array_type_qualifier^.bounds.upper := type_description^.bounds.upper;
        IFEND;
        IF type_description^.array_element_type_description = NIL THEN
          array_type_qualifier^.element_type_specification_size := 0;
        ELSE
          clp$convert_type_desc_to_spec (type_description^.array_element_type_description, work_area,
                element_type_specification, status);
          IF NOT status.normal THEN
            RESET work_area TO header;
            RETURN;
          IFEND;
          array_type_qualifier^.element_type_specification_size := #SIZE (element_type_specification^);
        IFEND;

      = clc$boolean_type =
        ;

      = clc$cobol_name_type =
        ;

      = clc$command_reference_type =
        ;

      = clc$data_name_type =
        ;

      = clc$date_time_type =
        NEXT date_time_type_qualifier IN work_area;
        IF date_time_type_qualifier = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        date_time_type_qualifier^.date_and_or_time := type_description^.date_and_or_time;
        date_time_type_qualifier^.tenses := type_description^.tenses;

      = clc$entry_point_reference_type =
        ;

*IF NOT $true(osv$unix)
      = clc$file_type =
*ELSE
      = clc$nos_ve_file_type =
*IFEND
        ;

      = clc$integer_type =
        NEXT integer_type_qualifier IN work_area;
        IF integer_type_qualifier = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        integer_type_qualifier^.min_integer_value := type_description^.min_integer_value;
        integer_type_qualifier^.max_integer_value := type_description^.max_integer_value;
        integer_type_qualifier^.default_radix := type_description^.default_radix;

      = clc$keyword_type =
        NEXT keyword_type_qualifier IN work_area;
        IF keyword_type_qualifier = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        keyword_type_qualifier^.number_of_keywords := UPPERBOUND (type_description^.keyword_specifications^);
        NEXT keyword_specifications: [1 .. keyword_type_qualifier^.number_of_keywords] IN work_area;
        IF keyword_specifications = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        keyword_specifications^ := type_description^.keyword_specifications^;

      = clc$list_type =
        NEXT list_type_qualifier IN work_area;
        IF list_type_qualifier = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        list_type_qualifier^.min_list_size := type_description^.min_list_size;
        list_type_qualifier^.max_list_size := type_description^.max_list_size;
        list_type_qualifier^.reserved := 0;
        list_type_qualifier^.defer_expansion := type_description^.defer_expansion;
        list_type_qualifier^.list_rest := type_description^.list_rest;
        IF type_description^.list_element_type_description = NIL THEN
          list_type_qualifier^.element_type_specification_size := 0;
        ELSE
          clp$convert_type_desc_to_spec (type_description^.list_element_type_description, work_area,
                element_type_specification, status);
          IF NOT status.normal THEN
            RESET work_area TO header;
            RETURN;
          IFEND;
          list_type_qualifier^.element_type_specification_size := #SIZE (element_type_specification^);
        IFEND;

      = clc$lock_type =
        ;

      = clc$name_type =
        NEXT name_type_qualifier IN work_area;
        IF name_type_qualifier = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        name_type_qualifier^.min_name_size := type_description^.min_name_size;
        name_type_qualifier^.max_name_size := type_description^.max_name_size;

      = clc$network_title_type =
        ;

      = clc$program_name_type =
        ;

      = clc$range_type =
        NEXT range_type_qualifier IN work_area;
        IF range_type_qualifier = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        IF type_description^.range_element_type_description = NIL THEN
          range_type_qualifier^.element_type_specification_size := 0;
        ELSE
          clp$convert_type_desc_to_spec (type_description^.range_element_type_description, work_area,
                element_type_specification, status);
          IF NOT status.normal THEN
            RESET work_area TO header;
            RETURN;
          IFEND;
          range_type_qualifier^.element_type_specification_size := #SIZE (element_type_specification^);
        IFEND;

      = clc$real_type =
        NEXT real_type_qualifier IN work_area;
        IF real_type_qualifier = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        real_type_qualifier^.min_real_value.long_real := type_description^.min_real_value.long_real;
        real_type_qualifier^.max_real_value.long_real := type_description^.max_real_value.long_real;

      = clc$record_type =
        NEXT record_type_qualifier IN work_area;
        IF record_type_qualifier = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        record_type_qualifier^.number_of_fields := type_description^.fields_pdt^.header^.number_of_parameters;
        FOR i := 1 TO record_type_qualifier^.number_of_fields DO
          NEXT field_specification IN work_area;
          IF field_specification = NIL THEN
            EXIT /work_area_ok/;
          IFEND;
          field_specification^.name := type_description^.fields_pdt^.names^ [i].name;
          field_specification^.requirement := type_description^.fields_pdt^.parameters^ [i].requirement;
          clp$convert_type_desc_to_spec (^type_description^.fields_pdt^.type_descriptions^ [i], work_area,
                field_type_specification, status);
          IF NOT status.normal THEN
            RESET work_area TO header;
            RETURN;
          IFEND;
          field_specification^.type_specification_size := #SIZE (field_type_specification^);
        FOREND;

      = clc$scu_line_identifier_type =
        ;

      = clc$statistic_code_type =
        ;

      = clc$status_type =
        ;

      = clc$status_code_type =
        ;

      = clc$string_type =
        NEXT string_type_qualifier IN work_area;
        IF string_type_qualifier = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        string_type_qualifier^.min_string_size := type_description^.min_string_size;
        string_type_qualifier^.max_string_size := type_description^.max_string_size;
        string_type_qualifier^.literal := type_description^.literal;

      = clc$string_pattern_type =
        ;

      = clc$time_increment_type =
        ;

      = clc$time_zone_type =
        ;

      = clc$type_specification_type =
        ;

      = clc$union_type =
        NEXT union_type_qualifier IN work_area;
        IF union_type_qualifier = NIL THEN
          EXIT /work_area_ok/;
        IFEND;
        union_type_qualifier^.kinds := type_description^.kinds;
        union_type_qualifier^.only_standard_types_in_union :=
              type_description^.union_information^.only_standard_types_in_union;
        IF type_description^.member_descriptions = NIL THEN
          union_type_qualifier^.number_of_members := 0;
        ELSE
          union_type_qualifier^.number_of_members := UPPERBOUND (type_description^.member_descriptions^);
          FOR i := 1 TO union_type_qualifier^.number_of_members DO
            NEXT member_type_specification_size IN work_area;
            IF member_type_specification_size = NIL THEN
              EXIT /work_area_ok/;
            IFEND;
            clp$convert_type_desc_to_spec (^type_description^.member_descriptions^ [i], work_area,
                  member_type_specification, status);
            IF NOT status.normal THEN
              RESET work_area TO header;
              RETURN;
            IFEND;
            member_type_specification_size^ := #SIZE (member_type_specification^);
          FOREND;
        IFEND;
*IF $true(osv$unix)

      = clc$unix_file_type =
        ;
*IFEND

      ELSE
        osp$set_status_condition (cle$bad_type_description, status);
        RETURN;
      CASEND;

      final_work_area_position := i#current_sequence_position (work_area);
      RESET work_area TO header;
      NEXT type_specification: [[REP final_work_area_position - i#current_sequence_position (work_area) OF
            cell]] IN work_area;
      RETURN;

    END /work_area_ok/;
    IF header <> NIL THEN
      RESET work_area TO header;
    IFEND;
    osp$set_status_condition (cle$work_area_overflow, status);

  PROCEND clp$convert_type_desc_to_spec;
?? TITLE := 'clp$convert_type_spec_to_desc', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$convert_type_spec_to_desc
    (    type_specification_ptr: ^clt$type_specification;
     VAR work_area {input, output} : ^clt$work_area;
     VAR type_description: clt$type_description;
     VAR status: ost$status);

    VAR
*IF $true(osv$unix)
      kludge_type_spec: ^ array [*] of cell,
      spot: integer,
*IFEND
      application_type_qualifier: ^clt$application_type_qualifier,
      array_type_qualifier: ^clt$array_type_qualifier,
      date_time_type_qualifier: ^clt$date_time_type_qualifier,
      element_type_specification: ^clt$type_specification,
      field_specification: ^clt$field_specification,
      field_type_specification: ^clt$type_specification,
      header: ^clt$type_specification_header,
      i: integer,
      integer_type_qualifier: ^clt$integer_type_qualifier,
      keyword_specifications: ^clt$keyword_specifications,
      keyword_type_qualifier: ^clt$keyword_type_qualifier,
      list_type_qualifier: ^clt$list_type_qualifier_v2,
      member_type_specification_size: ^clt$type_specification_size,
      member_type_specification: ^clt$type_specification,
      name_type_qualifier: ^clt$name_type_qualifier,
      range_type_qualifier: ^clt$range_type_qualifier,
      real_type_qualifier: ^clt$real_type_qualifier,
      record_type_qualifier: ^clt$record_type_qualifier,
      string_type_qualifier: ^clt$string_type_qualifier,
      type_specification: ^clt$type_specification,
*IF NOT $true(osv$unix)
      union_type_qualifier: ^clt$union_type_qualifier;
*ELSE
      union_type_qualifier_v1: ^clt$union_type_qualifier,
      union_type_qualifier: ^clt$union_type_qualifier_v2;
*IFEND


    status.normal := TRUE;
    type_specification := type_specification_ptr;

  /type_specification_ok/
    BEGIN

    /work_area_ok/
      BEGIN
        IF type_specification = NIL THEN
          EXIT /type_specification_ok/;
        IFEND;
        RESET type_specification;

        NEXT header IN type_specification;
*IF NOT $true(osv$unix)
        IF (header = NIL) OR (header^.version <> clc$declaration_version) OR
*ELSE
        IF (header = NIL) OR
              (header^.version <> clc$declaration_version) OR
*IFEND
              (header^.kind < LOWERVALUE (clt$type_kind)) OR (header^.kind > UPPERVALUE (clt$type_kind)) THEN
          EXIT /type_specification_ok/;
        IFEND;
        type_description.specification := type_specification;
        IF header^.name_size = 0 THEN
          type_description.name := NIL;
        ELSE
          NEXT type_description.name: [header^.name_size] IN type_specification;
          IF type_description.name = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
        IFEND;
        type_description.derived_from_value_kind_spec := FALSE;
        type_description.advanced_keywords_present := FALSE;
*IF NOT $true(osv$unix)
        type_description.kinds := $clt$type_kinds [header^.kind];
*ELSE
        type_description.kinds := $clt$type_kinds_v2 [header^.kind];
*IFEND
        type_description.kind := header^.kind;
        CASE header^.kind OF

        = clc$application_type =
          NEXT application_type_qualifier IN type_specification;
          IF application_type_qualifier = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          type_description.balance_brackets := application_type_qualifier^.balance_brackets;

        = clc$array_type =
          NEXT array_type_qualifier IN type_specification;
          IF array_type_qualifier = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          IF array_type_qualifier^.array_bounds_defined THEN
            IF (clc$min_array_bound <= array_type_qualifier^.bounds.lower) AND
                  (array_type_qualifier^.bounds.lower <= array_type_qualifier^.bounds.upper) AND
                  (array_type_qualifier^.bounds.upper <= clc$max_array_bound) THEN
              type_description.array_bounds_defined := TRUE;
              type_description.bounds.lower := array_type_qualifier^.bounds.lower;
              type_description.bounds.upper := array_type_qualifier^.bounds.upper;
            ELSE
              EXIT /type_specification_ok/;
            IFEND;
          ELSE
            type_description.array_bounds_defined := FALSE;
          IFEND;
          IF array_type_qualifier^.element_type_specification_size = 0 THEN
            type_description.array_element_type_description := NIL;
          ELSE
*IF NOT $true(osv$unix)
            NEXT element_type_specification: [[REP array_type_qualifier^.element_type_specification_size OF
                  cell]] IN type_specification;
*ELSE
            NEXT kludge_type_spec: [1 .. array_type_qualifier^.element_type_specification_size] IN
                  type_specification;
            element_type_specification := #SEQ (kludge_type_spec^);
*IFEND
            IF element_type_specification = NIL THEN
              EXIT /type_specification_ok/;
            IFEND;
            NEXT type_description.array_element_type_description IN work_area;
            IF type_description.array_element_type_description = NIL THEN
              EXIT /work_area_ok/;
            IFEND;
            clp$convert_type_spec_to_desc (element_type_specification, work_area,
                  type_description.array_element_type_description^, status);
            IF NOT status.normal THEN
              RESET work_area TO type_description.array_element_type_description;
              RETURN;
            IFEND;
            type_description.advanced_keywords_present := type_description.array_element_type_description^.
                  advanced_keywords_present;
          IFEND;

        = clc$boolean_type =
          ;

        = clc$cobol_name_type =
          ;

        = clc$command_reference_type =
          ;

        = clc$data_name_type =
          ;

        = clc$date_time_type =
          NEXT date_time_type_qualifier IN type_specification;
          IF date_time_type_qualifier = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          type_description.date_and_or_time := date_time_type_qualifier^.date_and_or_time;
          type_description.tenses := date_time_type_qualifier^.tenses;

        = clc$entry_point_reference_type =
          ;

*IF NOT $true(osv$unix)
        = clc$file_type =
*ELSE
        = clc$nos_ve_file_type =
*IFEND
          ;

        = clc$integer_type =
          NEXT integer_type_qualifier IN type_specification;
          IF integer_type_qualifier = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          type_description.min_integer_value := integer_type_qualifier^.min_integer_value;
          type_description.max_integer_value := integer_type_qualifier^.max_integer_value;
          type_description.default_radix := integer_type_qualifier^.default_radix;

        = clc$keyword_type =
          NEXT keyword_type_qualifier IN type_specification;
          IF (keyword_type_qualifier = NIL) OR (keyword_type_qualifier^.number_of_keywords < 1) OR
                (keyword_type_qualifier^.number_of_keywords > clc$max_keywords) THEN
            EXIT /type_specification_ok/;
          IFEND;
          NEXT keyword_specifications: [1 .. keyword_type_qualifier^.number_of_keywords] IN
                type_specification;
          IF keyword_specifications = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          NEXT type_description.keyword_specifications: [1 .. keyword_type_qualifier^.number_of_keywords] IN
                work_area;
          IF type_description.keyword_specifications = NIL THEN
            EXIT /work_area_ok/;
          IFEND;
          FOR i := 1 TO keyword_type_qualifier^.number_of_keywords DO
            type_description.keyword_specifications^ [i] := keyword_specifications^ [i];
            IF type_description.keyword_specifications^ [i].availability = clc$advanced_usage_entry THEN
              type_description.advanced_keywords_present := TRUE;
            IFEND;
          FOREND;

        = clc$list_type =
          NEXT list_type_qualifier IN type_specification;
          IF (list_type_qualifier = NIL) OR (list_type_qualifier^.min_list_size >
                list_type_qualifier^.max_list_size) OR (list_type_qualifier^.max_list_size >
                clc$max_list_size) THEN
            EXIT /type_specification_ok/;
          IFEND;
          type_description.min_list_size := list_type_qualifier^.min_list_size;
          type_description.max_list_size := list_type_qualifier^.max_list_size;
          type_description.defer_expansion := list_type_qualifier^.defer_expansion;
          type_description.list_rest := list_type_qualifier^.list_rest;
          IF list_type_qualifier^.element_type_specification_size = 0 THEN
            type_description.list_element_type_description := NIL;
          ELSE
*IF NOT $true(osv$unix)
            NEXT element_type_specification: [[REP list_type_qualifier^.element_type_specification_size OF
                  cell]] IN type_specification;
*ELSE
            spot := i#current_sequence_position (type_specification);
            NEXT kludge_type_spec : [1 .. list_type_qualifier^.element_type_specification_size] IN
                  type_specification;
            element_type_specification := #SEQ (kludge_type_spec^);
*IFEND
            IF element_type_specification = NIL THEN
              EXIT /type_specification_ok/;
            IFEND;
            NEXT type_description.list_element_type_description IN work_area;
            IF type_description.list_element_type_description = NIL THEN
              EXIT /work_area_ok/;
            IFEND;
            clp$convert_type_spec_to_desc (element_type_specification, work_area,
                  type_description.list_element_type_description^, status);
            IF NOT status.normal THEN
              RESET work_area TO type_description.list_element_type_description;
              RETURN;
            IFEND;
            type_description.advanced_keywords_present := type_description.list_element_type_description^.
                  advanced_keywords_present;
          IFEND;

        = clc$lock_type =
          ;

        = clc$name_type =
          NEXT name_type_qualifier IN type_specification;
          IF (name_type_qualifier <> NIL) AND (1 <= name_type_qualifier^.min_name_size) AND
                (name_type_qualifier^.min_name_size <= name_type_qualifier^.max_name_size) AND
                (name_type_qualifier^.max_name_size <= osc$max_name_size) THEN
            type_description.min_name_size := name_type_qualifier^.min_name_size;
            type_description.max_name_size := name_type_qualifier^.max_name_size;
          ELSE
            EXIT /type_specification_ok/;
          IFEND;

        = clc$network_title_type =
          ;

        = clc$program_name_type =
          ;

        = clc$range_type =
          NEXT range_type_qualifier IN type_specification;
          IF range_type_qualifier = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          IF range_type_qualifier^.element_type_specification_size = 0 THEN
            type_description.range_element_type_description := NIL;
          ELSE
*IF NOT $true(osv$unix)
            NEXT element_type_specification: [[REP range_type_qualifier^.element_type_specification_size OF
                  cell]] IN type_specification;
*ELSE
            NEXT kludge_type_spec: [1 .. range_type_qualifier^.element_type_specification_size] IN
                  type_specification;
            element_type_specification := #SEQ (kludge_type_spec^);
*IFEND
            IF element_type_specification = NIL THEN
              EXIT /type_specification_ok/;
            IFEND;
            NEXT type_description.range_element_type_description IN work_area;
            IF type_description.range_element_type_description = NIL THEN
              EXIT /work_area_ok/;
            IFEND;
            clp$convert_type_spec_to_desc (element_type_specification, work_area,
                  type_description.range_element_type_description^, status);
            IF NOT status.normal THEN
              RESET work_area TO type_description.range_element_type_description;
              RETURN;
            IFEND;
            type_description.advanced_keywords_present := type_description.range_element_type_description^.
                  advanced_keywords_present;
          IFEND;

        = clc$real_type =
          NEXT real_type_qualifier IN type_specification;
          IF real_type_qualifier = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          type_description.min_real_value.long_real := real_type_qualifier^.min_real_value.long_real;
          type_description.max_real_value.long_real := real_type_qualifier^.max_real_value.long_real;

        = clc$record_type =
          NEXT record_type_qualifier IN type_specification;
          IF (record_type_qualifier = NIL) OR (record_type_qualifier^.number_of_fields < 1) OR
                (record_type_qualifier^.number_of_fields > clc$max_fields) THEN
            EXIT /type_specification_ok/;
          IFEND;
          NEXT type_description.fields_pdt IN work_area;
          IF type_description.fields_pdt = NIL THEN
            EXIT /work_area_ok/;
          IFEND;
          NEXT type_description.fields_pdt^.header IN work_area;
          IF type_description.fields_pdt^.header = NIL THEN
            RESET work_area TO type_description.fields_pdt;
            EXIT /work_area_ok/;
          IFEND;
          type_description.fields_pdt^.header^.version := clc$declaration_version;
          type_description.fields_pdt^.header^.generation_date_time.year := 86;
          type_description.fields_pdt^.header^.generation_date_time.month := 10;
          type_description.fields_pdt^.header^.generation_date_time.day := 27;
          type_description.fields_pdt^.header^.generation_date_time.hour := 10;
          type_description.fields_pdt^.header^.generation_date_time.minute := 0;
          type_description.fields_pdt^.header^.generation_date_time.second := 0;
          type_description.fields_pdt^.header^.generation_date_time.millisecond := 0;
          type_description.fields_pdt^.header^.command_or_function := clc$function;
          type_description.fields_pdt^.header^.number_of_parameter_names :=
                record_type_qualifier^.number_of_fields;
          type_description.fields_pdt^.header^.number_of_parameters :=
                record_type_qualifier^.number_of_fields;
          type_description.fields_pdt^.header^.number_of_required_parameters := 0;
          type_description.fields_pdt^.header^.number_of_advanced_parameters := 0;
          type_description.fields_pdt^.header^.number_of_hidden_parameters := 0;
          type_description.fields_pdt^.header^.number_of_var_parameters := 0;
          type_description.fields_pdt^.header^.status_parameter_number := 0;
          type_description.fields_pdt^.header^.help_module_name := osc$null_name;
          NEXT type_description.fields_pdt^.names: [1 .. record_type_qualifier^.number_of_fields] IN
                work_area;
          IF type_description.fields_pdt^.names = NIL THEN
            RESET work_area TO type_description.fields_pdt;
            EXIT /work_area_ok/;
          IFEND;
          NEXT type_description.fields_pdt^.parameters: [1 .. record_type_qualifier^.number_of_fields] IN
                work_area;
          IF type_description.fields_pdt^.parameters = NIL THEN
            RESET work_area TO type_description.fields_pdt;
            EXIT /work_area_ok/;
          IFEND;
          NEXT type_description.fields_pdt^.type_descriptions:
                [1 .. record_type_qualifier^.number_of_fields] IN work_area;
          IF type_description.fields_pdt^.type_descriptions = NIL THEN
            RESET work_area TO type_description.fields_pdt;
            EXIT /work_area_ok/;
          IFEND;
          type_description.fields_pdt^.default_names := NIL;
          type_description.fields_pdt^.default_values := NIL;
          FOR i := 1 TO record_type_qualifier^.number_of_fields DO
            NEXT field_specification IN type_specification;
            IF field_specification = NIL THEN
              RESET work_area TO type_description.fields_pdt;
              EXIT /type_specification_ok/;
            IFEND;
            NEXT field_type_specification: [[REP field_specification^.type_specification_size OF cell]] IN
                  type_specification;
            IF field_type_specification = NIL THEN
              RESET work_area TO type_description.fields_pdt;
              EXIT /type_specification_ok/;
            IFEND;
            type_description.fields_pdt^.names^ [i].name := field_specification^.name;
            type_description.fields_pdt^.names^ [i].class := clc$nominal_entry;
            type_description.fields_pdt^.names^ [i].position := i;
            type_description.fields_pdt^.parameters^ [i].name_index := i;
            type_description.fields_pdt^.parameters^ [i].availability := clc$normal_usage_entry;
            type_description.fields_pdt^.parameters^ [i].security := clc$non_secure_parameter;
            type_description.fields_pdt^.parameters^ [i].specification_methods :=
                  $clt$parameter_spec_methods [clc$specify_positionally];
            type_description.fields_pdt^.parameters^ [i].passing_method := clc$pass_by_value;
            type_description.fields_pdt^.parameters^ [i].evaluation_method := clc$immediate_evaluation;
            type_description.fields_pdt^.parameters^ [i].checking_level := clc$standard_parameter_checking;
            type_description.fields_pdt^.parameters^ [i].type_specification_size :=
                  field_specification^.type_specification_size;
            type_description.fields_pdt^.parameters^ [i].requirement := field_specification^.requirement;
            IF field_specification^.requirement = clc$required_field THEN
              type_description.fields_pdt^.header^.number_of_required_parameters :=
                    type_description.fields_pdt^.header^.number_of_required_parameters + 1;
            IFEND;
            type_description.fields_pdt^.parameters^ [i].default_name_size := 0;
            type_description.fields_pdt^.parameters^ [i].default_value_size := 0;
            clp$convert_type_spec_to_desc (field_type_specification, work_area,
                  type_description.fields_pdt^.type_descriptions^ [i], status);
            IF NOT status.normal THEN
              RESET work_area TO type_description.fields_pdt;
              RETURN;
            ELSEIF type_description.fields_pdt^.type_descriptions^ [i].advanced_keywords_present THEN
              type_description.advanced_keywords_present := TRUE;
            IFEND;
          FOREND;

        = clc$scu_line_identifier_type =
          ;

        = clc$statistic_code_type =
          ;

        = clc$status_type =
          ;

        = clc$status_code_type =
          ;

        = clc$string_type =
          NEXT string_type_qualifier IN type_specification;
          IF (string_type_qualifier <> NIL) AND (string_type_qualifier^.min_string_size <=
                string_type_qualifier^.max_string_size) AND (string_type_qualifier^.max_string_size <=
                clc$max_string_size) THEN
            type_description.min_string_size := string_type_qualifier^.min_string_size;
            type_description.max_string_size := string_type_qualifier^.max_string_size;
            type_description.literal := string_type_qualifier^.literal;
          ELSE
            EXIT /type_specification_ok/;
          IFEND;

        = clc$string_pattern_type =
          ;

        = clc$time_increment_type =
          ;

        = clc$time_zone_type =
          ;

        = clc$type_specification_type =
          ;

        = clc$union_type =
          NEXT union_type_qualifier IN type_specification;
          IF (union_type_qualifier = NIL) OR (union_type_qualifier^.number_of_members > clc$max_union_members)
                THEN
            EXIT /type_specification_ok/;
          IFEND;
*IF NOT $true(osv$unix)
          type_description.kinds := union_type_qualifier^.kinds;
*ELSE
          IF header^.version = 1 THEN
            union_type_qualifier_v1 := #LOC (union_type_qualifier^);
            clp$type_kinds_v2 (union_type_qualifier_v1^.kinds, type_description.kinds);
          ELSE
            type_description.kinds := union_type_qualifier^.kinds;
          IFEND;
*IFEND
          NEXT type_description.union_information IN work_area;
          IF type_description.union_information = NIL THEN
            EXIT /work_area_ok/;
          IFEND;
          type_description.union_information^.only_standard_types_in_union :=
                union_type_qualifier^.only_standard_types_in_union;
          type_description.union_information^.min_integer_value := clc$min_integer;
          type_description.union_information^.max_integer_value := clc$max_integer;
          type_description.union_information^.default_radix := 10;
          type_description.union_information^.min_real_value.long_real := clv$negative_infinity^;
          type_description.union_information^.max_real_value.long_real := clv$positive_infinity^;
          IF union_type_qualifier^.number_of_members = 0 THEN
            type_description.member_descriptions := NIL;
          ELSE
            NEXT type_description.member_descriptions: [1 .. union_type_qualifier^.number_of_members] IN
                  work_area;
            IF type_description.member_descriptions = NIL THEN
              RESET work_area TO type_description.union_information;
              EXIT /work_area_ok/;
            IFEND;
            FOR i := 1 TO union_type_qualifier^.number_of_members DO
              NEXT member_type_specification_size IN type_specification;
              IF member_type_specification_size = NIL THEN
                RESET work_area TO type_description.union_information;
                EXIT /type_specification_ok/;
              IFEND;
*IF NOT $true(osv$unix)
              NEXT member_type_specification: [[REP member_type_specification_size^ OF cell]] IN
                    type_specification;
*ELSE
              NEXT kludge_type_spec: [1 .. member_type_specification_size^] in type_specification;
              member_type_specification := #SEQ (kludge_type_spec^);
*IFEND
              IF member_type_specification = NIL THEN
                RESET work_area TO type_description.union_information;
                EXIT /type_specification_ok/;
              IFEND;
              clp$convert_type_spec_to_desc (member_type_specification, work_area,
                    type_description.member_descriptions^ [i], status);
              IF status.normal THEN

              /merge_member_type/
                BEGIN
                  IF type_description.member_descriptions^ [i].advanced_keywords_present THEN
                    type_description.advanced_keywords_present := TRUE;
                  IFEND;
                  CASE type_description.member_descriptions^ [i].kind OF

                  = clc$integer_type =
                    IF clc$integer_type IN type_description.kinds THEN
                      IF type_description.member_descriptions^ [i].min_integer_value <
                            type_description.union_information^.min_integer_value THEN
                        type_description.union_information^.min_integer_value :=
                              type_description.member_descriptions^ [i].min_integer_value;
                      IFEND;
                      IF type_description.member_descriptions^ [i].max_integer_value >
                            type_description.union_information^.max_integer_value THEN
                        type_description.union_information^.max_integer_value :=
                              type_description.member_descriptions^ [i].max_integer_value;
                      IFEND;
                    ELSE
                      type_description.union_information^.min_integer_value :=
                            type_description.member_descriptions^ [i].min_integer_value;
                      type_description.union_information^.max_integer_value :=
                            type_description.member_descriptions^ [i].max_integer_value;
                      type_description.union_information^.default_radix :=
                            type_description.member_descriptions^ [i].default_radix;
                    IFEND;

                  = clc$real_type =
*IF NOT $true(osv$unix)
                    IF clc$real_type IN type_description.kinds THEN
                      IF clp$longreal_compare_lt (type_description.member_descriptions^ [i].min_real_value.
                            long_real, type_description.union_information^.min_real_value.long_real) THEN
                        type_description.union_information^.min_real_value :=
                              type_description.member_descriptions^ [i].min_real_value;
                      IFEND;
                      IF clp$longreal_compare_gt (type_description.member_descriptions^ [i].max_real_value.
                            long_real, type_description.union_information^.max_real_value.long_real) THEN
                        type_description.union_information^.max_real_value :=
                              type_description.member_descriptions^ [i].max_real_value;
                      IFEND;
                    ELSE
                      type_description.union_information^.min_real_value :=
                            type_description.member_descriptions^ [i].min_real_value;
                      type_description.union_information^.max_real_value :=
                            type_description.member_descriptions^ [i].max_real_value;
                    IFEND;
*IFEND

                  = clc$union_type =
                    IF clc$integer_type IN type_description.kinds THEN
                      IF clc$integer_type IN type_description.member_descriptions^ [i].kinds THEN
                        IF type_description.member_descriptions^ [i].union_information^.min_integer_value <
                              type_description.union_information^.min_integer_value THEN
                          type_description.union_information^.min_integer_value :=
                                type_description.member_descriptions^ [i].union_information^.
                                min_integer_value;
                        IFEND;
                        IF type_description.member_descriptions^ [i].union_information^.max_integer_value >
                              type_description.union_information^.max_integer_value THEN
                          type_description.union_information^.max_integer_value :=
                                type_description.member_descriptions^ [i].union_information^.
                                max_integer_value;
                        IFEND;
                      IFEND;
                    ELSE
                      type_description.union_information^.min_integer_value :=
                            type_description.member_descriptions^ [i].union_information^.min_integer_value;
                      type_description.union_information^.max_integer_value :=
                            type_description.member_descriptions^ [i].union_information^.max_integer_value;
                      type_description.union_information^.default_radix :=
                            type_description.member_descriptions^ [i].union_information^.default_radix;
                    IFEND;

                    IF clc$real_type IN type_description.kinds THEN
*IF NOT $true(osv$unix)
                      IF clc$real_type IN type_description.member_descriptions^ [i].kinds THEN
                        IF clp$longreal_compare_lt (type_description.member_descriptions^ [i].
                              union_information^.min_real_value.long_real,
                              type_description.union_information^.min_real_value.long_real) THEN
                          type_description.union_information^.min_real_value :=
                                type_description.member_descriptions^ [i].union_information^.min_real_value;
                        IFEND;
                        IF clp$longreal_compare_gt (type_description.member_descriptions^ [i].
                              union_information^.max_real_value.long_real,
                              type_description.union_information^.max_real_value.long_real) THEN
                          type_description.union_information^.max_real_value :=
                                type_description.member_descriptions^ [i].union_information^.max_real_value;
                        IFEND;
                      IFEND;
*IFEND
                    ELSE
                      type_description.union_information^.min_real_value :=
                            type_description.member_descriptions^ [i].union_information^.min_real_value;
                      type_description.union_information^.max_real_value :=
                            type_description.member_descriptions^ [i].union_information^.max_real_value;
                    IFEND;

                  ELSE
                    ;
                  CASEND;
                END /merge_member_type/;
              IFEND;
              IF NOT status.normal THEN
                RESET work_area TO type_description.union_information;
                RETURN;
              IFEND;
            FOREND;
          IFEND;
*IF $true(osv$unix)

        = clc$unix_file_type =
          ;
*IFEND

        ELSE
          EXIT /type_specification_ok/;
        CASEND;
        RETURN;

      END /work_area_ok/;
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;

    END /type_specification_ok/;
    osp$set_status_condition (cle$bad_type_specification, status);

  PROCEND clp$convert_type_spec_to_desc;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$create_variable_type', EJECT ??

  PROCEDURE [XDCL] clp$create_variable_type
    (    kind: clt$variable_kinds;
         max_string_size: clt$string_size;
         create_array: boolean;
         lower_bound: clt$variable_dimension;
         upper_bound: clt$variable_dimension;
     VAR work_area {input,output} : ^clt$work_area;
     VAR type_specification: ^clt$type_specification;
     VAR type_description: ^clt$type_description;
     VAR status: ost$status);

    VAR
      local_type_description: ^clt$type_description;


    status.normal := TRUE;
    type_specification := NIL;
    NEXT type_description IN work_area;
    IF type_description = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    local_type_description := type_description;

    IF create_array THEN
      local_type_description^.specification := NIL;
      local_type_description^.name := NIL;
      local_type_description^.derived_from_value_kind_spec := FALSE;
      local_type_description^.advanced_keywords_present := FALSE;
*IF NOT $true(osv$unix)
      local_type_description^.kinds := $clt$type_kinds [clc$array_type];
*ELSE
      local_type_description^.kinds := $clt$type_kinds_v2 [clc$array_type];
*IFEND
      local_type_description^.kind := clc$array_type;
      local_type_description^.array_bounds_defined := TRUE;
      local_type_description^.bounds.lower := lower_bound;
      local_type_description^.bounds.upper := upper_bound;
      NEXT local_type_description^.array_element_type_description IN work_area;
      IF local_type_description^.array_element_type_description = NIL THEN
        osp$set_status_condition (cle$work_area_overflow, status);
        RETURN;
      IFEND;
      local_type_description := local_type_description^.array_element_type_description;
    IFEND;

    local_type_description^.specification := NIL;
    local_type_description^.name := NIL;
    local_type_description^.derived_from_value_kind_spec := FALSE;
    local_type_description^.advanced_keywords_present := FALSE;

    CASE kind OF
    = clc$boolean_value =
*IF NOT $true(osv$unix)
      local_type_description^.kinds := $clt$type_kinds [clc$boolean_type];
*ELSE
      local_type_description^.kinds := $clt$type_kinds_v2 [clc$boolean_type];
*IFEND
      local_type_description^.kind := clc$boolean_type;
    = clc$integer_value =
*IF NOT $true(osv$unix)
      local_type_description^.kinds := $clt$type_kinds [clc$integer_type];
*ELSE
      local_type_description^.kinds := $clt$type_kinds_v2 [clc$integer_type];
*IFEND
      local_type_description^.kind := clc$integer_type;
      local_type_description^.min_integer_value := clc$min_integer;
      local_type_description^.max_integer_value := clc$max_integer;
      local_type_description^.default_radix := 10;
    = clc$real_value =
*IF NOT $true(osv$unix)
      local_type_description^.kinds := $clt$type_kinds [clc$real_type];
*ELSE
      local_type_description^.kinds := $clt$type_kinds_v2 [clc$real_type];
*IFEND
      local_type_description^.kind := clc$real_type;
      local_type_description^.min_real_value.long_real := clv$negative_infinity^;
      local_type_description^.max_real_value.long_real := clv$positive_infinity^;
    = clc$status_value =
*IF NOT $true(osv$unix)
      local_type_description^.kinds := $clt$type_kinds [clc$status_type];
*ELSE
      local_type_description^.kinds := $clt$type_kinds_v2 [clc$status_type];
*IFEND
      local_type_description^.kind := clc$status_type;
    = clc$string_value =
*IF NOT $true(osv$unix)
      local_type_description^.kinds := $clt$type_kinds [clc$string_type];
*ELSE
      local_type_description^.kinds := $clt$type_kinds_v2 [clc$string_type];
*IFEND
      local_type_description^.kind := clc$string_type;
      local_type_description^.min_string_size := 0;
      local_type_description^.max_string_size := max_string_size;
      local_type_description^.literal := FALSE;
    ELSE
{Should not get here.}
      osp$set_status_condition (cle$bad_variable_kind, status);
      RETURN;
    CASEND;

    clp$convert_type_desc_to_spec (type_description, work_area, type_specification, status);

  PROCEND clp$create_variable_type;
*IFEND
?? TITLE := 'clp$derive_type_desc_from_value', EJECT ??

  PROCEDURE [XDCL] clp$derive_type_desc_from_value
    (    value: ^clt$data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR type_description: clt$type_description;
     VAR status: ost$status);

    VAR
*IF NOT $true(osv$unix)
      unqualified_union_type_desc: [STATIC, READ, oss$job_paged_literal] clt$type_description :=
            [NIL, NIL, FALSE, FALSE, -$clt$type_kinds [], clc$union_type, NIL,
*ELSE
      unqualified_union_type_desc: [STATIC, READ] clt$type_description :=
            [NIL, NIL, FALSE, FALSE, -$clt$type_kinds_v2 [], clc$union_type, NIL,
*IFEND
            ^unqualified_union_information],
*IF NOT $true(osv$unix)
      unqualified_union_information: [STATIC, READ, oss$job_paged_literal] clt$union_type_information :=
            [FALSE, clc$min_integer, clc$max_integer, 10, [{-$INFINITY} 3, [[0d000(16), 0], [0d000(16), 0]]],
            [{$INFINITY} 3, [[5000(16), 0], [5000(16), 0]]]];
*ELSE
      unqualified_union_information: [STATIC, READ] clt$union_type_information :=
            [FALSE, clc$min_integer, clc$max_integer, 10,
*copy cli$longreal_negative_infinity
            ,
*copy cli$longreal_positive_infinity
            ];
*IFEND

    VAR
      current_value: ^clt$data_value,
      i: integer,
      type_conformance: clt$type_conformance;


    status.normal := TRUE;

    IF value = NIL THEN
      type_description := unqualified_union_type_desc;
      RETURN;
    IFEND;

    type_description.specification := NIL;
    type_description.name := NIL;
    type_description.derived_from_value_kind_spec := FALSE;
    type_description.advanced_keywords_present := FALSE;

    CASE value^.kind OF

    = clc$application =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$application_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$application_type];
*IFEND
      type_description.kind := clc$application_type;
      type_description.balance_brackets := FALSE;

    = clc$array =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$array_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$array_type];
*IFEND
      type_description.kind := clc$array_type;
      IF value^.array_value = NIL THEN
        osp$set_status_condition (cle$bad_data_value, status);
        RETURN;
      IFEND;
      type_description.array_bounds_defined := TRUE;
      type_description.bounds.lower := LOWERBOUND (value^.array_value^);
      type_description.bounds.upper := UPPERBOUND (value^.array_value^);
      NEXT type_description.array_element_type_description IN work_area;
      IF type_description.array_element_type_description = NIL THEN
        osp$set_status_condition (cle$work_area_overflow, status);
        RETURN;
      IFEND;
      clp$derive_type_desc_from_value (value^.array_value^ [1], work_area,
            type_description.array_element_type_description^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (type_description.array_element_type_description^.kind <> clc$union_type) OR
            (type_description.array_element_type_description^.member_descriptions <> NIL) THEN

      /check_array_elements/
        FOR i := LOWERBOUND (value^.array_value^) + 1 TO UPPERBOUND (value^.array_value^) DO
          clp$validate_value_conformance (value^.array_value^ [i],
                type_description.array_element_type_description, type_conformance);
          IF type_conformance < clc$conforms_to_type THEN
            type_description.array_element_type_description^ := unqualified_union_type_desc;
            EXIT /check_array_elements/;
          IFEND;
        FOREND /check_array_elements/;
      IFEND;

    = clc$boolean =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$boolean_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$boolean_type];
*IFEND
      type_description.kind := clc$boolean_type;

    = clc$cobol_name =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$cobol_name_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$cobol_name_type];
*IFEND
      type_description.kind := clc$cobol_name_type;

    = clc$command_reference =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$command_reference_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$command_reference_type];
*IFEND
      type_description.kind := clc$command_reference_type;

    = clc$data_name =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$data_name_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$data_name_type];
*IFEND
      type_description.kind := clc$data_name_type;

    = clc$date_time =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$date_time_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$date_time_type];
*IFEND
      type_description.kind := clc$date_time_type;
      type_description.date_and_or_time := $clt$date_and_or_time [clc$date, clc$time];
      type_description.tenses := $clt$date_time_tenses [clc$past, clc$present, clc$future];

    = clc$entry_point_reference =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$entry_point_reference_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$entry_point_reference_type];
*IFEND
      type_description.kind := clc$entry_point_reference_type;

*IF NOT $true(osv$unix)
    = clc$file =
      type_description.kinds := $clt$type_kinds [clc$file_type];
      type_description.kind := clc$file_type;
*ELSE
    = clc$nos_ve_file =
      type_description.kinds := $clt$type_kinds_v2 [clc$nos_ve_file_type];
      type_description.kind := clc$nos_ve_file_type;
*IFEND

    = clc$integer =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$integer_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$integer_type];
*IFEND
      type_description.kind := clc$integer_type;
      type_description.min_integer_value := clc$min_integer;
      type_description.max_integer_value := clc$max_integer;
      type_description.default_radix := 10;

    = clc$keyword =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$keyword_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$keyword_type];
*IFEND
      type_description.kind := clc$keyword_type;
      NEXT type_description.keyword_specifications: [1 .. 1] IN work_area;
      IF type_description.keyword_specifications = NIL THEN
        osp$set_status_condition (cle$work_area_overflow, status);
        RETURN;
      IFEND;
      type_description.keyword_specifications^ [1].keyword := value^.keyword_value;
      type_description.keyword_specifications^ [1].class := clc$nominal_entry;
      type_description.keyword_specifications^ [1].availability := clc$normal_usage_entry;
      type_description.keyword_specifications^ [1].ordinal := 1;

    = clc$list =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$list_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$list_type];
*IFEND
      type_description.kind := clc$list_type;
      type_description.min_list_size := 0;
      type_description.max_list_size := clc$max_list_size;
      type_description.list_rest := value^.generated_via_list_rest;
      type_description.defer_expansion := FALSE;
      NEXT type_description.list_element_type_description IN work_area;
      IF type_description.list_element_type_description = NIL THEN
        osp$set_status_condition (cle$work_area_overflow, status);
        RETURN;
      IFEND;
      clp$derive_type_desc_from_value (value^.element_value, work_area,
            type_description.list_element_type_description^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (type_description.list_element_type_description^.kind <> clc$union_type) OR
            (type_description.list_element_type_description^.member_descriptions <> NIL) THEN
        current_value := value^.link;

      /check_list_elements/
        WHILE current_value <> NIL DO
          IF current_value^.kind <> clc$list THEN
            osp$set_status_condition (cle$bad_data_value, status);
            RETURN;
          ELSEIF current_value^.element_value = NIL THEN
            IF current_value^.link <> NIL THEN
              osp$set_status_condition (cle$bad_data_value, status);
              RETURN;
            IFEND;
          ELSE
            clp$validate_value_conformance (current_value^.element_value,
                  type_description.list_element_type_description, type_conformance);
            IF type_conformance < clc$conforms_to_type THEN
              type_description.list_element_type_description^ := unqualified_union_type_desc;
              EXIT /check_list_elements/;
            IFEND;
          IFEND;
          current_value := current_value^.link;
        WHILEND /check_list_elements/;
      IFEND;

    = clc$lock =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$lock_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$lock_type];
*IFEND
      type_description.kind := clc$lock_type;

    = clc$name =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$name_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$name_type];
*IFEND
      type_description.kind := clc$name_type;
      type_description.min_name_size := 1;
      type_description.max_name_size := osc$max_name_size;

    = clc$network_title =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$network_title_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$network_title_type];
*IFEND
      type_description.kind := clc$network_title_type;

    = clc$program_name =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$program_name_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$program_name_type];
*IFEND
      type_description.kind := clc$program_name_type;

    = clc$range =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$range_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$range_type];
*IFEND
      type_description.kind := clc$range_type;
      NEXT type_description.range_element_type_description IN work_area;
      IF type_description.range_element_type_description = NIL THEN
        osp$set_status_condition (cle$work_area_overflow, status);
        RETURN;
      IFEND;
      clp$derive_type_desc_from_value (value^.low_value, work_area,
            type_description.range_element_type_description^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (value^.high_value <> value^.low_value) AND ((type_description.range_element_type_description^.
            kind <> clc$union_type) OR (type_description.range_element_type_description^.
            member_descriptions <> NIL)) THEN
        clp$validate_value_conformance (value^.high_value, type_description.range_element_type_description,
              type_conformance);
        IF type_conformance < clc$conforms_to_type THEN
          type_description.range_element_type_description^ := unqualified_union_type_desc;
        IFEND;
      IFEND;

    = clc$real =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$real_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$real_type];
*IFEND
      type_description.kind := clc$real_type;
      type_description.min_real_value.long_real := clv$negative_infinity^;
      type_description.max_real_value.long_real := clv$positive_infinity^;

    = clc$record =
      IF value^.field_values = NIL THEN
        osp$set_status_condition (cle$bad_data_value, status);
        RETURN;
      IFEND;
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$record_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$record_type];
*IFEND
      type_description.kind := clc$record_type;
      NEXT type_description.fields_pdt IN work_area;
      IF type_description.fields_pdt = NIL THEN
        osp$set_status_condition (cle$work_area_overflow, status);
        RETURN;
      IFEND;
      NEXT type_description.fields_pdt^.header IN work_area;
      IF type_description.fields_pdt^.header = NIL THEN
        RESET work_area TO type_description.fields_pdt;
        osp$set_status_condition (cle$work_area_overflow, status);
        RETURN;
      IFEND;
      type_description.fields_pdt^.header^.version := clc$declaration_version;
      type_description.fields_pdt^.header^.generation_date_time.year := 87;
      type_description.fields_pdt^.header^.generation_date_time.month := 12;
      type_description.fields_pdt^.header^.generation_date_time.day := 10;
      type_description.fields_pdt^.header^.generation_date_time.hour := 11;
      type_description.fields_pdt^.header^.generation_date_time.minute := 55;
      type_description.fields_pdt^.header^.generation_date_time.second := 0;
      type_description.fields_pdt^.header^.generation_date_time.millisecond := 0;
      type_description.fields_pdt^.header^.command_or_function := clc$function;
      type_description.fields_pdt^.header^.number_of_parameter_names := UPPERBOUND (value^.field_values^);
      type_description.fields_pdt^.header^.number_of_parameters := UPPERBOUND (value^.field_values^);
      type_description.fields_pdt^.header^.number_of_required_parameters := 0;
      type_description.fields_pdt^.header^.number_of_advanced_parameters := 0;
      type_description.fields_pdt^.header^.number_of_hidden_parameters := 0;
      type_description.fields_pdt^.header^.number_of_var_parameters := 0;
      type_description.fields_pdt^.header^.status_parameter_number := 0;
      type_description.fields_pdt^.header^.help_module_name := osc$null_name;
      NEXT type_description.fields_pdt^.names: [1 .. UPPERBOUND (value^.field_values^)] IN work_area;
      IF type_description.fields_pdt^.names = NIL THEN
        RESET work_area TO type_description.fields_pdt;
        osp$set_status_condition (cle$work_area_overflow, status);
        RETURN;
      IFEND;
      NEXT type_description.fields_pdt^.parameters: [1 .. UPPERBOUND (value^.field_values^)] IN work_area;
      IF type_description.fields_pdt^.parameters = NIL THEN
        RESET work_area TO type_description.fields_pdt;
        osp$set_status_condition (cle$work_area_overflow, status);
        RETURN;
      IFEND;
      NEXT type_description.fields_pdt^.type_descriptions: [1 .. UPPERBOUND (value^.field_values^)] IN
            work_area;
      IF type_description.fields_pdt^.type_descriptions = NIL THEN
        RESET work_area TO type_description.fields_pdt;
        osp$set_status_condition (cle$work_area_overflow, status);
        RETURN;
      IFEND;
      type_description.fields_pdt^.default_names := NIL;
      type_description.fields_pdt^.default_values := NIL;
      FOR i := 1 TO UPPERBOUND (value^.field_values^) DO
        type_description.fields_pdt^.names^ [i].name := value^.field_values^ [i].name;
        type_description.fields_pdt^.names^ [i].class := clc$nominal_entry;
        type_description.fields_pdt^.names^ [i].position := i;
        type_description.fields_pdt^.parameters^ [i].name_index := i;
        type_description.fields_pdt^.parameters^ [i].availability := clc$normal_usage_entry;
        type_description.fields_pdt^.parameters^ [i].security := clc$non_secure_parameter;
        type_description.fields_pdt^.parameters^ [i].specification_methods :=
              $clt$parameter_spec_methods [clc$specify_positionally];
        type_description.fields_pdt^.parameters^ [i].passing_method := clc$pass_by_value;
        type_description.fields_pdt^.parameters^ [i].evaluation_method := clc$immediate_evaluation;
        type_description.fields_pdt^.parameters^ [i].checking_level := clc$standard_parameter_checking;
        type_description.fields_pdt^.parameters^ [i].type_specification_size := 0;
        type_description.fields_pdt^.parameters^ [i].default_name_size := 0;
        type_description.fields_pdt^.parameters^ [i].default_value_size := 0;
        type_description.fields_pdt^.parameters^ [i].requirement := clc$optional_field;
        IF value^.field_values^ [i].value = NIL THEN
          type_description.fields_pdt^.type_descriptions^ [i] := unqualified_union_type_desc;
        ELSE
          type_description.fields_pdt^.header^.number_of_required_parameters :=
                type_description.fields_pdt^.header^.number_of_required_parameters + 1;
          clp$derive_type_desc_from_value (value^.field_values^ [i].value, work_area,
                type_description.fields_pdt^.type_descriptions^ [i], status);
          IF NOT status.normal THEN
            RESET work_area TO type_description.fields_pdt;
            RETURN;
          IFEND;
        IFEND;
      FOREND;

    = clc$scu_line_identifier =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$scu_line_identifier_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$scu_line_identifier_type];
*IFEND
      type_description.kind := clc$scu_line_identifier_type;

    = clc$statistic_code =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$statistic_code_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$statistic_code_type];
*IFEND
      type_description.kind := clc$statistic_code_type;

    = clc$status =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$status_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$status_type];
*IFEND
      type_description.kind := clc$status_type;

    = clc$status_code =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$status_code_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$status_code_type];
*IFEND
      type_description.kind := clc$status_code_type;

    = clc$string =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$string_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$string_type];
*IFEND
      type_description.kind := clc$string_type;
      type_description.min_string_size := 0;
      type_description.max_string_size := clc$max_string_size;
      type_description.literal := FALSE;

    = clc$string_pattern =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$string_pattern_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$string_pattern_type];
*IFEND
      type_description.kind := clc$string_pattern_type;

    = clc$time_increment =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$time_increment_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$time_increment_type];
*IFEND
      type_description.kind := clc$time_increment_type;

    = clc$time_zone =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$time_zone_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$time_zone_type];
*IFEND
      type_description.kind := clc$time_zone_type;

    = clc$type_specification =
*IF NOT $true(osv$unix)
      type_description.kinds := $clt$type_kinds [clc$type_specification_type];
*ELSE
      type_description.kinds := $clt$type_kinds_v2 [clc$type_specification_type];
*IFEND
      type_description.kind := clc$type_specification_type;

    = clc$unspecified =
      type_description := unqualified_union_type_desc;
*IF $true(osv$unix)

    = clc$unix_file =
      type_description.kinds := $clt$type_kinds_v2 [clc$unix_file_type];
      type_description.kind := clc$unix_file_type;
*IFEND

    ELSE
      osp$set_status_condition (cle$bad_data_value, status);
      RETURN;
    CASEND;

  PROCEND clp$derive_type_desc_from_value;
?? TITLE := 'clp$derive_type_spec_from_value', EJECT ??
*copyc clh$derive_type_spec_from_value

  PROCEDURE [XDCL, #GATE] clp$derive_type_spec_from_value
    (    value: ^clt$data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR type_specification: ^clt$type_specification;
     VAR status: ost$status);

    VAR
      type_description: clt$type_description;


    clp$derive_type_desc_from_value (value, work_area, type_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_type_desc_to_spec (^type_description, work_area, type_specification, status);

  PROCEND clp$derive_type_spec_from_value;
?? TITLE := 'clp$evaluate_type_conformance', EJECT ??

  PROCEDURE [XDCL] clp$evaluate_type_conformance
    (    subject_type_description: ^clt$type_description;
         target_type_description: ^clt$type_description;
         minimum_type_conformance: clt$type_conformance;
     VAR status: ost$status);

    VAR
      i: integer,
      max_real_order: mlt$compare,
      min_real_order: mlt$compare,
      subject_keyword: clt$keyword,
      target_keyword: clt$keyword,
      type_conformance: clt$type_conformance;


    status.normal := TRUE;

    IF (subject_type_description = NIL) OR (target_type_description = NIL) THEN
      osp$set_status_condition (cle$undefined_type, status);
      RETURN;
    IFEND;

    CASE target_type_description^.kind OF

    = clc$application_type =
      IF subject_type_description^.kind = clc$application_type THEN
        IF minimum_type_conformance > clc$conforms_to_generic_type THEN
          IF (subject_type_description^.balance_brackets <> target_type_description^.balance_brackets) THEN
            osp$set_status_condition (cle$balance_brackets_dont_match, status);
            RETURN;
          IFEND;
          IF subject_type_description^.name = NIL THEN
            IF target_type_description^.name = NIL THEN
              RETURN;
            IFEND;
          ELSEIF target_type_description^.name <> NIL THEN
            IF subject_type_description^.name^ = target_type_description^.name^ THEN
              RETURN;
            IFEND;
          IFEND;
          osp$set_status_condition (cle$application_name_mismatch, status);
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$array_type =
      IF subject_type_description^.kind = clc$array_type THEN
        IF target_type_description^.array_bounds_defined THEN
          IF minimum_type_conformance > clc$conforms_to_generic_type THEN
            IF subject_type_description^.array_bounds_defined THEN
              IF (subject_type_description^.bounds.lower <> target_type_description^.bounds.lower) OR
                    (subject_type_description^.bounds.upper <> target_type_description^.bounds.upper) THEN
                osp$set_status_condition (cle$array_bounds_dont_match, status);
                RETURN;
              IFEND;
            ELSE
              osp$set_status_condition (cle$array_bounds_dont_match, status);
              RETURN;
            IFEND;
          IFEND;
        ELSEIF subject_type_description^.array_bounds_defined THEN
          IF minimum_type_conformance > clc$conforms_to_type THEN
            osp$set_status_condition (cle$array_bounds_dont_match, status);
            RETURN;
          IFEND;
        IFEND;

        IF minimum_type_conformance >= clc$conforms_to_type THEN
          IF target_type_description^.array_element_type_description = NIL THEN
            IF subject_type_description^.array_element_type_description <> NIL THEN
              osp$set_status_condition (cle$unknown_array_element_type, status);
            IFEND;
          ELSE
            clp$evaluate_type_conformance (subject_type_description^.array_element_type_description,
                  target_type_description^.array_element_type_description, minimum_type_conformance, status);
            IF NOT status.normal THEN
              IF status.condition = cle$wrong_kind_of_value THEN
                status.condition := cle$wrong_kind_of_element_type;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$boolean_type =
      IF subject_type_description^.kind <> clc$boolean_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$cobol_name_type =
      IF subject_type_description^.kind <> clc$cobol_name_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$command_reference_type =
      IF subject_type_description^.kind <> clc$command_reference_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$data_name_type =
      IF subject_type_description^.kind <> clc$data_name_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$date_time_type =
      IF (subject_type_description^.kind = clc$date_time_type) THEN
        IF minimum_type_conformance > clc$conforms_to_type THEN
          IF (subject_type_description^.date_and_or_time = target_type_description^.date_and_or_time) THEN
            IF (subject_type_description^.tenses <> target_type_description^.tenses) THEN
              osp$set_status_condition (cle$date_time_tenses_dont_match, status);
            IFEND;
          ELSE
            osp$set_status_condition (cle$date_time_types_dont_match, status);
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$entry_point_reference_type =
      IF subject_type_description^.kind <> clc$entry_point_reference_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

*IF NOT $true(osv$unix)
    = clc$file_type =
      IF subject_type_description^.kind <> clc$file_type THEN
*ELSE
    = clc$nos_ve_file_type =
      IF subject_type_description^.kind <> clc$nos_ve_file_type THEN
*IFEND
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$integer_type =
      IF subject_type_description^.kind = clc$integer_type THEN
        IF (subject_type_description^.min_integer_value >= target_type_description^.min_integer_value) AND
              (subject_type_description^.max_integer_value <= target_type_description^.max_integer_value) THEN
          IF minimum_type_conformance > clc$conforms_to_type THEN
            IF (subject_type_description^.min_integer_value <> target_type_description^.min_integer_value) OR
                  (subject_type_description^.max_integer_value <> target_type_description^.max_integer_value)
                  THEN
              osp$set_status_condition (cle$integer_ranges_dont_match, status);
            ELSEIF (subject_type_description^.default_radix <> target_type_description^.default_radix) THEN
              osp$set_status_condition (cle$integer_radices_dont_match, status);
            IFEND;
          IFEND;
        ELSE
          IF minimum_type_conformance > clc$conforms_to_generic_type THEN
            osp$set_status_condition (cle$integer_ranges_dont_match, status);
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$keyword_type =
      IF subject_type_description^.kind = clc$keyword_type THEN
        IF UPPERBOUND (subject_type_description^.keyword_specifications^) <=
              UPPERBOUND (target_type_description^.keyword_specifications^) THEN
          IF minimum_type_conformance > clc$conforms_to_type THEN
            IF UPPERBOUND (subject_type_description^.keyword_specifications^) =
                  UPPERBOUND (target_type_description^.keyword_specifications^) THEN
              FOR i := 1 TO UPPERBOUND (subject_type_description^.keyword_specifications^) DO
                IF subject_type_description^.keyword_specifications^ [i] <>
                      target_type_description^.keyword_specifications^ [i] THEN
                  osp$set_status_condition (cle$keywords_dont_match, status);
                  RETURN;
                IFEND;
              FOREND;
            ELSE
              osp$set_status_condition (cle$keywords_dont_match, status);
              RETURN;
            IFEND;
          IFEND;
          FOR i := 1 TO UPPERBOUND (subject_type_description^.keyword_specifications^) DO
            IF subject_type_description^.keyword_specifications^ [i].class = clc$nominal_entry THEN
              subject_keyword := subject_type_description^.keyword_specifications^ [i].keyword;
            ELSE
              clp$check_keyword (subject_type_description^.keyword_specifications^ [i].keyword,
                    subject_type_description^.keyword_specifications, subject_keyword);
            IFEND;
            clp$check_keyword (subject_type_description^.keyword_specifications^ [i].keyword,
                  target_type_description^.keyword_specifications, target_keyword);
            IF subject_keyword <> target_keyword THEN
              IF minimum_type_conformance > clc$conforms_to_type THEN
                osp$set_status_abnormal ('CL', cle$unknown_keyword, subject_keyword, status);
                RETURN;
              IFEND;
            IFEND;
          FOREND;
        ELSEIF minimum_type_conformance > clc$conforms_to_generic_type THEN
          osp$set_status_condition (cle$keywords_dont_match, status);
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$list_type =
      IF subject_type_description^.kind = clc$list_type THEN
        IF minimum_type_conformance >= clc$conforms_to_type THEN
          IF target_type_description^.list_element_type_description = NIL THEN
            IF minimum_type_conformance > clc$conforms_to_type THEN
              IF subject_type_description^.list_element_type_description <> NIL THEN
                osp$set_status_condition (cle$unknown_list_element_type, status);
                RETURN;
              IFEND;
            IFEND;
          ELSE
            clp$evaluate_type_conformance (subject_type_description^.list_element_type_description,
                  target_type_description^.list_element_type_description, minimum_type_conformance, status);
            IF NOT status.normal THEN
              IF status.condition = cle$wrong_kind_of_value THEN
                IF target_type_description^.list_rest AND
                      (target_type_description^.list_element_type_description^.kind = clc$list_type) THEN
                  status.normal := TRUE;
                ELSE
                  status.condition := cle$wrong_kind_of_element_type;
                IFEND;
              IFEND;
              RETURN;
            IFEND;
          IFEND;
        IFEND;

        IF (target_type_description^.min_list_size <= subject_type_description^.min_list_size) AND
              (subject_type_description^.max_list_size <= target_type_description^.max_list_size) THEN
          IF minimum_type_conformance > clc$conforms_to_type THEN
            IF (target_type_description^.min_list_size <> subject_type_description^.min_list_size) OR
                  (subject_type_description^.max_list_size <> target_type_description^.max_list_size) THEN
              osp$set_status_condition (cle$list_sizes_dont_match, status);
            ELSEIF (subject_type_description^.list_rest <> target_type_description^.list_rest) THEN
              osp$set_status_condition (cle$list_rest_doesnt_match, status);
            ELSEIF subject_type_description^.defer_expansion AND
                  (NOT target_type_description^.defer_expansion) THEN
              osp$set_status_condition (cle$defer_expans_doesnt_match, status);
            IFEND;
          IFEND;
        ELSE
          IF minimum_type_conformance > clc$conforms_to_generic_type THEN
            osp$set_status_condition (cle$list_sizes_dont_match, status);
          IFEND;
        IFEND;

      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$lock_type =
      IF subject_type_description^.kind <> clc$lock_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$name_type =
      IF subject_type_description^.kind = clc$name_type THEN
        IF (target_type_description^.min_name_size <= subject_type_description^.min_name_size) AND
              (subject_type_description^.max_name_size <= target_type_description^.max_name_size) THEN
          IF minimum_type_conformance > clc$conforms_to_type THEN
            IF (target_type_description^.min_name_size <> subject_type_description^.min_name_size) OR
                  (subject_type_description^.max_name_size <> target_type_description^.max_name_size) THEN
              osp$set_status_condition (cle$name_sizes_dont_match, status);
            IFEND;
          IFEND;
        ELSE
          IF minimum_type_conformance > clc$conforms_to_generic_type THEN
            osp$set_status_condition (cle$name_sizes_dont_match, status);
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$network_title_type =
      IF subject_type_description^.kind <> clc$network_title_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$program_name_type =
      IF subject_type_description^.kind <> clc$program_name_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$range_type =
      IF subject_type_description^.kind = clc$range_type THEN
        IF target_type_description^.range_element_type_description = NIL THEN
          IF minimum_type_conformance > clc$conforms_to_type THEN
            IF subject_type_description^.range_element_type_description <> NIL THEN
              osp$set_status_condition (cle$unknown_range_element_type, status);
            IFEND;
          IFEND;
        ELSE
          clp$evaluate_type_conformance (subject_type_description^.range_element_type_description,
                target_type_description^.range_element_type_description, minimum_type_conformance, status);
          IF NOT status.normal THEN
            IF status.condition = cle$wrong_kind_of_value THEN
              status.condition := cle$range_types_dont_match;
            IFEND;
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$real_type =
      IF subject_type_description^.kind = clc$real_type THEN
*IF NOT $true(osv$unix)
        max_real_order := clp$longreal_compare (subject_type_description^.max_real_value.long_real,
              target_type_description^.max_real_value.long_real, clc$infinities_equal);
        min_real_order := clp$longreal_compare (subject_type_description^.min_real_value.long_real,
              target_type_description^.min_real_value.long_real, clc$infinities_equal);
        IF (min_real_order = clc$equal) AND (max_real_order = clc$equal) THEN
          ;
        ELSEIF (min_real_order IN $clt$comparison_results [clc$left_is_greater,
              clc$equal]) AND (max_real_order IN $clt$comparison_results [clc$right_is_greater, clc$equal])
              THEN
          IF minimum_type_conformance > clc$conforms_to_type THEN
            osp$set_status_condition (cle$real_subranges_dont_match, status);
          IFEND;
        ELSE
          IF minimum_type_conformance > clc$conforms_to_generic_type THEN
            osp$set_status_condition (cle$real_subranges_dont_match, status);
          IFEND;
        IFEND;
*IFEND
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$record_type =
      IF subject_type_description^.kind = clc$record_type THEN
        IF subject_type_description^.fields_pdt^.header^.number_of_parameters <=
              target_type_description^.fields_pdt^.header^.number_of_parameters THEN
          IF minimum_type_conformance > clc$conforms_to_type THEN
            IF subject_type_description^.fields_pdt^.header^.number_of_parameters <>
                  target_type_description^.fields_pdt^.header^.number_of_parameters THEN
              osp$set_status_condition (cle$number_of_fields_dont_match, status);
              RETURN;
            IFEND;
          IFEND;
        ELSE
          IF minimum_type_conformance > clc$conforms_to_generic_type THEN
            osp$set_status_condition (cle$number_of_fields_dont_match, status);
            RETURN;
          IFEND;
        IFEND;

        IF minimum_type_conformance >= clc$conforms_to_type THEN
          FOR i := 1 TO subject_type_description^.fields_pdt^.header^.number_of_parameters DO
            IF (subject_type_description^.fields_pdt^.names^ [i].name <>
                  target_type_description^.fields_pdt^.names^ [i].name) THEN
              osp$set_status_condition (cle$field_names_dont_match, status);
              RETURN;
            ELSEIF (subject_type_description^.fields_pdt^.parameters^ [i].requirement >
                  target_type_description^.fields_pdt^.parameters^ [i].requirement) THEN
              osp$set_status_condition (cle$field_requirements_mismatch, status);
              RETURN;
            ELSEIF (minimum_type_conformance = clc$identical_types) AND
                  (subject_type_description^.fields_pdt^.parameters^ [i].requirement <>
                  target_type_description^.fields_pdt^.parameters^ [i].requirement) THEN
              osp$set_status_condition (cle$field_requirements_mismatch, status);
              RETURN;
            IFEND;
            clp$evaluate_type_conformance (^subject_type_description^.fields_pdt^.type_descriptions^ [i],
                  ^target_type_description^.fields_pdt^.type_descriptions^ [i], minimum_type_conformance,
                  status);
            IF NOT status.normal THEN
              IF status.condition = cle$wrong_kind_of_value THEN
                status.condition := cle$field_types_dont_match;
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      subject_type_description^.fields_pdt^.names^ [i].name, status);
              IFEND;
              RETURN;
            IFEND;
          FOREND;
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$scu_line_identifier_type =
      IF subject_type_description^.kind <> clc$scu_line_identifier_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$statistic_code_type =
      IF subject_type_description^.kind <> clc$statistic_code_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$status_type =
      IF subject_type_description^.kind <> clc$status_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$status_code_type =
      IF subject_type_description^.kind <> clc$status_code_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$string_type =
      IF subject_type_description^.kind = clc$string_type THEN
        IF (target_type_description^.min_string_size <= subject_type_description^.min_string_size) AND
              (subject_type_description^.max_string_size <= target_type_description^.max_string_size) AND
              (target_type_description^.literal <= subject_type_description^.literal) THEN
          IF minimum_type_conformance > clc$conforms_to_type THEN
            IF (target_type_description^.min_string_size <> subject_type_description^.min_string_size) OR
                  (subject_type_description^.max_string_size <> target_type_description^.max_string_size) THEN
              osp$set_status_condition (cle$string_sizes_dont_match, status);
            ELSEIF (target_type_description^.literal <> subject_type_description^.literal) THEN
              osp$set_status_condition (cle$string_literals_dont_match, status);
            IFEND;
          IFEND;
        ELSE
          IF minimum_type_conformance > clc$conforms_to_generic_type THEN
            osp$set_status_condition (cle$string_sizes_dont_match, status);
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$string_pattern_type =
      IF subject_type_description^.kind <> clc$string_pattern_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$time_increment_type =
      IF subject_type_description^.kind <> clc$time_increment_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$time_zone_type =
      IF subject_type_description^.kind <> clc$time_zone_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$type_specification_type =
      IF subject_type_description^.kind <> clc$type_specification_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$union_type =
      IF subject_type_description^.kind = clc$union_type THEN
        IF target_type_description^.member_descriptions = NIL THEN
          IF minimum_type_conformance > clc$conforms_to_type THEN
            IF subject_type_description^.member_descriptions <> NIL THEN
              osp$set_status_condition (cle$value_not_union_type, status);
            IFEND;
          IFEND;
        ELSEIF (subject_type_description^.member_descriptions = NIL) OR
              (UPPERBOUND (subject_type_description^.member_descriptions^) >
              UPPERBOUND (target_type_description^.member_descriptions^)) THEN
          IF minimum_type_conformance > clc$conforms_to_generic_type THEN
            osp$set_status_condition (cle$value_not_union_type, status);
          IFEND;
        ELSE
          IF minimum_type_conformance > clc$conforms_to_type THEN
            IF UPPERBOUND (subject_type_description^.member_descriptions^) <>
                  UPPERBOUND (target_type_description^.member_descriptions^) THEN
              osp$set_status_condition (cle$value_not_union_type, status);
            IFEND;
          IFEND;

          FOR i := 1 TO UPPERBOUND (subject_type_description^.member_descriptions^) DO
            IF minimum_type_conformance > clc$conforms_to_type THEN
              clp$validate_type_conformance (^subject_type_description^.member_descriptions^ [i],
                    ^target_type_description^.member_descriptions^ [i], type_conformance);
              IF type_conformance < minimum_type_conformance THEN
                IF type_conformance = clc$conforms_to_type THEN
                  osp$set_status_condition (cle$value_not_union_type, status);
                ELSE
                  clp$validate_type_conformance (^subject_type_description^.member_descriptions^ [i],
                        target_type_description, type_conformance);
                  IF type_conformance < minimum_type_conformance THEN
                    osp$set_status_condition (cle$value_not_union_type, status);
                  IFEND;
                IFEND;
              IFEND;
            ELSEIF minimum_type_conformance = clc$conforms_to_type THEN
              clp$validate_type_conformance (^subject_type_description^.member_descriptions^ [i],
                    target_type_description, type_conformance);
              IF type_conformance < minimum_type_conformance THEN
                osp$set_status_condition (cle$value_not_union_type, status);
              IFEND;
            IFEND;
          FOREND;
        IFEND;
      ELSEIF target_type_description^.member_descriptions = NIL THEN
        IF minimum_type_conformance > clc$conforms_to_type THEN
          osp$set_status_condition (cle$value_not_union_type, status);
        IFEND;
      ELSE
        FOR i := 1 TO UPPERBOUND (target_type_description^.member_descriptions^) DO
          clp$validate_type_conformance (subject_type_description,
                ^target_type_description^.member_descriptions^ [i], type_conformance);
          IF type_conformance < minimum_type_conformance THEN
            osp$set_status_condition (cle$value_not_union_type, status);
            RETURN;
          IFEND;
        FOREND;
      IFEND;
*IF $true(osv$unix)

    = clc$unix_file_type =
      IF subject_type_description^.kind <> clc$unix_file_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;
*IFEND

    ELSE
      ;
    CASEND;

  PROCEND clp$evaluate_type_conformance;
?? TITLE := 'clp$evaluate_value_conformance', EJECT ??

  PROCEDURE [XDCL] clp$evaluate_value_conformance
    (    value: ^clt$data_value;
         type_description: ^clt$type_description;
         minimum_type_conformance: clt$type_conformance;
     VAR status: ost$status);

    VAR
      current_value: ^clt$data_value,
      i: integer,
      local_type_conformance: clt$type_conformance,
      result_keyword: clt$keyword;


    status.normal := TRUE;

    IF value = NIL THEN
      osp$set_status_condition (cle$undefined_value, status);
      RETURN;
    IFEND;

    IF type_description = NIL THEN
      RETURN;
    IFEND;

    CASE type_description^.kind OF

    = clc$application_type =
      IF value^.kind <> clc$application THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$array_type =
      IF value^.kind = clc$array THEN
        IF (value^.array_value <> NIL) AND ((NOT type_description^.array_bounds_defined) OR
              ((type_description^.bounds.lower = LOWERBOUND (value^.array_value^)) AND
              (type_description^.bounds.upper = UPPERBOUND (value^.array_value^)))) THEN
          IF type_description^.array_element_type_description <> NIL THEN

          /check_array_elements/
            FOR i := LOWERBOUND (value^.array_value^) TO UPPERBOUND (value^.array_value^) DO
              clp$evaluate_value_conformance (value^.array_value^ [i],
                    type_description^.array_element_type_description, minimum_type_conformance, status);
              IF (minimum_type_conformance > clc$conforms_to_generic_type) AND NOT status.normal THEN
                IF status.condition = cle$undefined_value THEN
                  status.normal := TRUE;
                ELSE
                  IF status.condition = cle$wrong_kind_of_value THEN
                    status.condition := cle$wrong_kind_of_element_type;
                  IFEND;
                  EXIT /check_array_elements/;
                IFEND;
              IFEND;
            FOREND /check_array_elements/;
          IFEND;
        ELSEIF minimum_type_conformance > clc$conforms_to_generic_type THEN
          osp$set_status_condition (cle$array_bounds_dont_match, status);
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$boolean_type =
      IF value^.kind <> clc$boolean THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$cobol_name_type =
      IF value^.kind <> clc$cobol_name THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$command_reference_type =
      IF value^.kind <> clc$command_reference THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$data_name_type =
      IF value^.kind <> clc$data_name THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$date_time_type =
      IF value^.kind <> clc$date_time THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$entry_point_reference_type =
      IF value^.kind <> clc$entry_point_reference THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

*IF NOT $true(osv$unix)
    = clc$file_type =
      IF value^.kind <> clc$file THEN
*ELSE
    = clc$nos_ve_file_type =
      IF value^.kind <> clc$nos_ve_file THEN
*IFEND
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$integer_type =
      IF value^.kind = clc$integer THEN
        IF (minimum_type_conformance > clc$conforms_to_generic_type) AND
              NOT ((type_description^.min_integer_value <= value^.integer_value.value) AND
              (value^.integer_value.value <= type_description^.max_integer_value)) THEN
          osp$set_status_condition (cle$integer_ranges_dont_match, status);
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$keyword_type =
      IF value^.kind = clc$keyword THEN
        clp$check_keyword (value^.keyword_value, type_description^.keyword_specifications, result_keyword);
        IF (minimum_type_conformance > clc$conforms_to_generic_type) AND
              (value^.keyword_value <> result_keyword) THEN
          osp$set_status_abnormal ('CL', cle$unknown_keyword, value^.keyword_value, status);
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$list_type =
      IF value^.kind = clc$list THEN
        IF type_description^.list_element_type_description <> NIL THEN

        /check_list_elements/
          BEGIN
            i := 0;
            current_value := value;
            REPEAT
              IF current_value^.kind <> clc$list THEN
                osp$set_status_condition (cle$wrong_kind_of_element_type, status);
                clp$append_status_type_desc (osc$status_parameter_delimiter,
                      type_description^.list_element_type_description, status);
                clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
                EXIT /check_list_elements/;
              ELSEIF current_value^.element_value = NIL THEN
                IF (i > 0) OR (current_value^.link <> NIL) THEN
                  osp$set_status_condition (cle$undefined_value_in_list, status);
                  EXIT /check_list_elements/;
                IFEND;
              ELSE
                i := i + 1;
                clp$evaluate_value_conformance (current_value^.element_value,
                      type_description^.list_element_type_description, minimum_type_conformance, status);
                IF NOT status.normal THEN
                  IF status.condition = cle$wrong_kind_of_value THEN
                    status.condition := cle$wrong_kind_of_element_type;
                  ELSEIF status.condition = cle$undefined_value THEN
                    status.condition := cle$undefined_value_in_list;
                  IFEND;
                  EXIT /check_list_elements/;
                IFEND;
              IFEND;
              current_value := current_value^.link;
            UNTIL current_value = NIL {/check_list_elements/} ;
            IF NOT ((type_description^.min_list_size <= i) AND (i <= type_description^.max_list_size)) THEN
              IF minimum_type_conformance > clc$conforms_to_generic_type THEN
                osp$set_status_condition (cle$list_sizes_dont_match, status);
              IFEND;
            IFEND;
          END /check_list_elements/;
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$lock_type =
      IF value^.kind <> clc$lock THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$name_type =
      IF value^.kind = clc$name THEN
        i := clp$trimmed_string_size (value^.name_value);
        IF (minimum_type_conformance > clc$conforms_to_generic_type) AND
              NOT ((type_description^.min_name_size <= i) AND (i <= type_description^.max_name_size)) THEN
          osp$set_status_condition (cle$name_sizes_dont_match, status);
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$network_title_type =
      IF value^.kind <> clc$network_title THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$program_name_type =
      IF value^.kind <> clc$program_name THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$range_type =
      IF value^.kind = clc$range THEN
        IF type_description^.range_element_type_description <> NIL THEN
          clp$evaluate_value_conformance (value^.low_value, type_description^.range_element_type_description,
                minimum_type_conformance, status);
          IF status.normal AND (value^.high_value <> value^.low_value) THEN
            clp$evaluate_value_conformance (value^.high_value,
                  type_description^.range_element_type_description, minimum_type_conformance, status);
          IFEND;
          IF NOT status.normal THEN
            IF status.condition = cle$wrong_kind_of_value THEN
              status.condition := cle$range_types_dont_match;
            ELSEIF status.condition = cle$undefined_value THEN
              status.condition := cle$undefined_value_in_range;
            IFEND;
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$real_type =
*IF NOT $true(osv$unix)
      IF value^.kind = clc$real THEN
        IF (minimum_type_conformance > clc$conforms_to_generic_type) AND
              NOT (clp$longreal_compare_le (type_description^.min_real_value.long_real,
              value^.real_value.value) AND clp$longreal_compare_le
              (value^.real_value.value, type_description^.max_real_value.long_real)) THEN
          osp$set_status_condition (cle$real_subranges_dont_match, status);
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;
*ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
*IFEND

    = clc$record_type =
      IF value^.kind = clc$record THEN
        IF (value^.field_values = NIL) OR (UPPERBOUND (value^.field_values^) >
              type_description^.fields_pdt^.header^.number_of_parameters) THEN
          IF minimum_type_conformance > clc$conforms_to_generic_type THEN
            osp$set_status_condition (cle$number_of_fields_dont_match, status);
          IFEND;
        ELSE

        /check_fields/
          BEGIN
            FOR i := 1 TO UPPERBOUND (value^.field_values^) DO
              IF type_description^.fields_pdt^.names^ [i].name <> value^.field_values^ [i].name THEN
                IF minimum_type_conformance > clc$conforms_to_generic_type THEN
                  osp$set_status_condition (cle$field_names_dont_match, status);
                  EXIT /check_fields/;
                IFEND;
              ELSEIF (value^.field_values^ [i].value = NIL) OR
                    (value^.field_values^ [i].value^.kind = clc$unspecified) THEN
                IF type_description^.fields_pdt^.parameters^ [i].requirement = clc$required_field THEN
                  IF minimum_type_conformance > clc$conforms_to_generic_type THEN
                    osp$set_status_condition (cle$field_requirements_mismatch, status);
                    EXIT /check_fields/;
                  IFEND;
                IFEND;
              ELSE
                clp$evaluate_value_conformance (value^.field_values^ [i].value,
                      ^type_description^.fields_pdt^.type_descriptions^ [i], minimum_type_conformance,
                      status);
                IF NOT status.normal THEN
                  IF status.condition = cle$undefined_value THEN
                    status.normal := TRUE;
                  ELSE
                    IF status.condition = cle$wrong_kind_of_value THEN
                      status.condition := cle$field_types_dont_match;
                      osp$append_status_parameter (osc$status_parameter_delimiter, value^.field_values^ [i].
                            name, status);
                    IFEND;
                    EXIT /check_fields/;
                  IFEND;
                IFEND;
              IFEND;
            FOREND;
            FOR i := UPPERBOUND (value^.field_values^) + 1 TO type_description^.fields_pdt^.header^.
                  number_of_parameters DO
              IF type_description^.fields_pdt^.parameters^ [i].requirement = clc$required_field THEN
                IF minimum_type_conformance > clc$conforms_to_generic_type THEN
                  osp$set_status_condition (cle$field_requirements_mismatch, status);
                  EXIT /check_fields/;
                IFEND;
              IFEND;
            FOREND;
          END /check_fields/;
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$scu_line_identifier_type =
      IF value^.kind <> clc$scu_line_identifier THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$statistic_code_type =
      IF value^.kind <> clc$statistic_code THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$status_type =
      IF value^.kind <> clc$status THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$status_code_type =
      IF value^.kind <> clc$status_code THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$string_type =
      IF value^.kind = clc$string THEN
        IF (minimum_type_conformance > clc$conforms_to_generic_type) AND
              NOT ((type_description^.min_string_size <= STRLENGTH (value^.string_value^)) AND
              (STRLENGTH (value^.string_value^) <= type_description^.max_string_size)) THEN
          osp$set_status_condition (cle$string_sizes_dont_match, status);
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$string_pattern_type =
      IF value^.kind <> clc$string_pattern THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$time_increment_type =
      IF value^.kind <> clc$time_increment THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$time_zone_type =
      IF value^.kind <> clc$time_zone THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$type_specification_type =
      IF value^.kind <> clc$type_specification THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;

    = clc$union_type =
      IF type_description^.member_descriptions <> NIL THEN

      /check_member/
        FOR i := 1 TO UPPERBOUND (type_description^.member_descriptions^) DO
          clp$evaluate_value_conformance (value, ^type_description^.member_descriptions^ [i],
                minimum_type_conformance, status);
          IF status.normal THEN
            RETURN;
          IFEND;
        FOREND /check_member/;
        osp$set_status_condition (cle$value_not_union_type, status);
      IFEND;
*IF $true(osv$unix)

    = clc$unix_file_type =
      IF value^.kind <> clc$unix_file THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, type_description, status);
        clp$append_status_value_type (osc$status_parameter_delimiter, value, status);
      IFEND;
*IFEND

    ELSE
      ;
    CASEND;

  PROCEND clp$evaluate_value_conformance;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$get_type_information', EJECT ??
*copy clh$get_type_information

  PROCEDURE [XDCL, #GATE] clp$get_type_information
    (    type_specification_ptr: ^clt$type_specification;
     VAR work_area {input, output} : ^clt$work_area;
     VAR type_information: clt$type_information;
     VAR status: ost$status);

    VAR
      application_type_qualifier: ^clt$application_type_qualifier,
      array_type_qualifier: ^clt$array_type_qualifier,
      date_time_type_qualifier: ^clt$date_time_type_qualifier,
      element_type_specification: ^clt$type_specification,
      field_specification: ^clt$field_specification,
      field_type_specification: ^clt$type_specification,
      header: ^clt$type_specification_header,
      i: integer,
      integer_type_qualifier: ^clt$integer_type_qualifier,
      keyword_specifications: ^clt$keyword_specifications,
      keyword_type_qualifier: ^clt$keyword_type_qualifier,
      list_type_qualifier: ^clt$list_type_qualifier_v2,
      member_type_specification_size: ^clt$type_specification_size,
      member_type_specification: ^clt$type_specification,
      name_type_qualifier: ^clt$name_type_qualifier,
      range_type_qualifier: ^clt$range_type_qualifier,
      real_type_qualifier: ^clt$real_type_qualifier,
      record_type_qualifier: ^clt$record_type_qualifier,
      string_type_qualifier: ^clt$string_type_qualifier,
      type_name: ^clt$type_name_reference,
      type_specification: ^clt$type_specification,
*IF NOT $true(osv$unix)
      union_type_qualifier: ^clt$union_type_qualifier;
*ELSE
      union_type_qualifier: ^clt$union_type_qualifier_v2;
*IFEND


    status.normal := TRUE;
    type_specification := type_specification_ptr;

  /type_specification_ok/
    BEGIN

    /work_area_ok/
      BEGIN
        IF type_specification = NIL THEN
          EXIT /type_specification_ok/;
        IFEND;
        RESET type_specification;

        NEXT header IN type_specification;
*IF NOT $true(osv$unix)
        IF (header = NIL) OR (header^.version <> clc$declaration_version) OR
*ELSE
        IF (header = NIL) OR (header^.version < 1) OR (header^.version > clc$declaration_version) OR
*IFEND
              (header^.kind < LOWERVALUE (clt$type_kind)) OR (header^.kind > UPPERVALUE (clt$type_kind)) THEN
          EXIT /type_specification_ok/;
        IFEND;
        IF header^.name_size > 0 THEN
          NEXT type_name: [header^.name_size] IN type_specification;
          IF type_name = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
        IFEND;
        type_information.kind := header^.kind;
        CASE header^.kind OF

        = clc$application_type =
          NEXT application_type_qualifier IN type_specification;
          IF application_type_qualifier = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          type_information.balance_brackets := application_type_qualifier^.balance_brackets;

        = clc$array_type =
          NEXT array_type_qualifier IN type_specification;
          IF array_type_qualifier = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          IF array_type_qualifier^.array_bounds_defined THEN
            IF (clc$min_array_bound <= array_type_qualifier^.bounds.lower) AND
                  (array_type_qualifier^.bounds.lower <= array_type_qualifier^.bounds.upper) AND
                  (array_type_qualifier^.bounds.upper <= clc$max_array_bound) THEN
              type_information.array_bounds_defined := TRUE;
              type_information.bounds.lower := array_type_qualifier^.bounds.lower;
              type_information.bounds.upper := array_type_qualifier^.bounds.upper;
            ELSE
              EXIT /type_specification_ok/;
            IFEND;
          ELSE
            type_information.array_bounds_defined := FALSE;
          IFEND;
          IF array_type_qualifier^.element_type_specification_size = 0 THEN
            type_information.array_element_type_information := NIL;
          ELSE
            NEXT element_type_specification: [[REP array_type_qualifier^.element_type_specification_size OF
                  cell]] IN type_specification;
            IF element_type_specification = NIL THEN
              EXIT /type_specification_ok/;
            IFEND;
            NEXT type_information.array_element_type_information IN work_area;
            IF type_information.array_element_type_information = NIL THEN
              EXIT /work_area_ok/;
            IFEND;
            clp$get_type_information (element_type_specification, work_area,
                  type_information.array_element_type_information^, status);
            IF NOT status.normal THEN
              RESET work_area TO type_information.array_element_type_information;
              RETURN;
            IFEND;
          IFEND;

        = clc$boolean_type =
          ;

        = clc$cobol_name_type =
          ;

        = clc$command_reference_type =
          ;

        = clc$data_name_type =
          ;

        = clc$date_time_type =
          NEXT date_time_type_qualifier IN type_specification;
          IF date_time_type_qualifier = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          type_information.date_and_or_time := date_time_type_qualifier^.date_and_or_time;
          type_information.tenses := date_time_type_qualifier^.tenses;

        = clc$entry_point_reference_type =
          ;

*IF NOT $true(osv$unix)
        = clc$file_type =
*ELSE
        = clc$nos_ve_file_type =
*IFEND
          ;

        = clc$integer_type =
          NEXT integer_type_qualifier IN type_specification;
          IF integer_type_qualifier = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          type_information.min_integer_value := integer_type_qualifier^.min_integer_value;
          type_information.max_integer_value := integer_type_qualifier^.max_integer_value;
          type_information.default_radix := integer_type_qualifier^.default_radix;

        = clc$keyword_type =
          NEXT keyword_type_qualifier IN type_specification;
          IF (keyword_type_qualifier = NIL) OR (keyword_type_qualifier^.number_of_keywords < 1) OR
                (keyword_type_qualifier^.number_of_keywords > clc$max_keywords) THEN
            EXIT /type_specification_ok/;
          IFEND;
          NEXT keyword_specifications: [1 .. keyword_type_qualifier^.number_of_keywords] IN
                type_specification;
          IF keyword_specifications = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          NEXT type_information.keyword_specifications: [1 .. keyword_type_qualifier^.number_of_keywords] IN
                work_area;
          IF type_information.keyword_specifications = NIL THEN
            EXIT /work_area_ok/;
          IFEND;
          FOR i := 1 TO keyword_type_qualifier^.number_of_keywords DO
            type_information.keyword_specifications^ [i] := keyword_specifications^ [i];
          FOREND;

        = clc$list_type =
          NEXT list_type_qualifier IN type_specification;
          IF (list_type_qualifier = NIL) OR (list_type_qualifier^.min_list_size >
                list_type_qualifier^.max_list_size) OR (list_type_qualifier^.max_list_size >
                clc$max_list_size) THEN
            EXIT /type_specification_ok/;
          IFEND;
          type_information.min_list_size := list_type_qualifier^.min_list_size;
          type_information.max_list_size := list_type_qualifier^.max_list_size;
          type_information.list_rest := list_type_qualifier^.list_rest;
          type_information.defer_expansion := list_type_qualifier^.defer_expansion;
          IF list_type_qualifier^.element_type_specification_size = 0 THEN
            type_information.list_element_type_information := NIL;
          ELSE
            NEXT element_type_specification: [[REP list_type_qualifier^.element_type_specification_size OF
                  cell]] IN type_specification;
            IF element_type_specification = NIL THEN
              EXIT /type_specification_ok/;
            IFEND;
            NEXT type_information.list_element_type_information IN work_area;
            IF type_information.list_element_type_information = NIL THEN
              EXIT /work_area_ok/;
            IFEND;
            clp$get_type_information (element_type_specification, work_area,
                  type_information.list_element_type_information^, status);
            IF NOT status.normal THEN
              RESET work_area TO type_information.list_element_type_information;
              RETURN;
            IFEND;
          IFEND;

        = clc$lock_type =
          ;

        = clc$name_type =
          NEXT name_type_qualifier IN type_specification;
          IF (name_type_qualifier <> NIL) AND (1 <= name_type_qualifier^.min_name_size) AND
                (name_type_qualifier^.min_name_size <= name_type_qualifier^.max_name_size) AND
                (name_type_qualifier^.max_name_size <= osc$max_name_size) THEN
            type_information.min_name_size := name_type_qualifier^.min_name_size;
            type_information.max_name_size := name_type_qualifier^.max_name_size;
          ELSE
            EXIT /type_specification_ok/;
          IFEND;

        = clc$network_title_type =
          ;

        = clc$program_name_type =
          ;

        = clc$range_type =
          NEXT range_type_qualifier IN type_specification;
          IF range_type_qualifier = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          IF range_type_qualifier^.element_type_specification_size = 0 THEN
            type_information.range_element_type_information := NIL;
          ELSE
            NEXT element_type_specification: [[REP range_type_qualifier^.element_type_specification_size OF
                  cell]] IN type_specification;
            IF element_type_specification = NIL THEN
              EXIT /type_specification_ok/;
            IFEND;
            NEXT type_information.range_element_type_information IN work_area;
            IF type_information.range_element_type_information = NIL THEN
              EXIT /work_area_ok/;
            IFEND;
            clp$get_type_information (element_type_specification, work_area,
                  type_information.range_element_type_information^, status);
            IF NOT status.normal THEN
              RESET work_area TO type_information.range_element_type_information;
              RETURN;
            IFEND;
          IFEND;

        = clc$real_type =
          NEXT real_type_qualifier IN type_specification;
          IF real_type_qualifier = NIL THEN
            EXIT /type_specification_ok/;
          IFEND;
          type_information.min_real_value := real_type_qualifier^.min_real_value.long_real;
          type_information.max_real_value := real_type_qualifier^.max_real_value.long_real;

        = clc$record_type =
          NEXT record_type_qualifier IN type_specification;
          IF (record_type_qualifier = NIL) OR (record_type_qualifier^.number_of_fields < 1) OR
                (record_type_qualifier^.number_of_fields > clc$max_fields) THEN
            EXIT /type_specification_ok/;
          IFEND;
          NEXT type_information.fields_information: [1 .. record_type_qualifier^.number_of_fields] IN
                work_area;
          IF type_information.fields_information = NIL THEN
            EXIT /work_area_ok/;
          IFEND;
          FOR i := 1 TO record_type_qualifier^.number_of_fields DO
            NEXT field_specification IN type_specification;
            IF field_specification = NIL THEN
              RESET work_area TO type_information.fields_information;
              EXIT /type_specification_ok/;
            IFEND;
            NEXT field_type_specification: [[REP field_specification^.type_specification_size OF cell]] IN
                  type_specification;
            IF field_type_specification = NIL THEN
              RESET work_area TO type_information.fields_information;
              EXIT /type_specification_ok/;
            IFEND;
            type_information.fields_information^ [i].name := field_specification^.name;
            type_information.fields_information^ [i].requirement := field_specification^.requirement;
            clp$get_type_information (field_type_specification, work_area,
                  type_information.fields_information^ [i].type_information, status);
            IF NOT status.normal THEN
              RESET work_area TO type_information.fields_information;
              RETURN;
            IFEND;
          FOREND;

        = clc$scu_line_identifier_type =
          ;

        = clc$statistic_code_type =
          ;

        = clc$status_type =
          ;

        = clc$status_code_type =
          ;

        = clc$string_type =
          NEXT string_type_qualifier IN type_specification;
          IF (string_type_qualifier <> NIL) AND (string_type_qualifier^.min_string_size <=
                string_type_qualifier^.max_string_size) AND (string_type_qualifier^.max_string_size <=
                clc$max_string_size) THEN
            type_information.min_string_size := string_type_qualifier^.min_string_size;
            type_information.max_string_size := string_type_qualifier^.max_string_size;
            type_information.literal := string_type_qualifier^.literal;
          ELSE
            EXIT /type_specification_ok/;
          IFEND;

        = clc$string_pattern_type =
          ;

        = clc$time_increment_type =
          ;

        = clc$time_zone_type =
          ;

        = clc$type_specification_type =
          ;

        = clc$union_type =
          NEXT union_type_qualifier IN type_specification;
          IF (union_type_qualifier = NIL) OR (union_type_qualifier^.number_of_members > clc$max_union_members)
                THEN
            EXIT /type_specification_ok/;
          IFEND;
          IF union_type_qualifier^.number_of_members = 0 THEN
            type_information.members_information := NIL;
          ELSE
            NEXT type_information.members_information: [1 .. union_type_qualifier^.number_of_members] IN
                  work_area;
            IF type_information.members_information = NIL THEN
              EXIT /work_area_ok/;
            IFEND;
            FOR i := 1 TO union_type_qualifier^.number_of_members DO
              NEXT member_type_specification_size IN type_specification;
              IF member_type_specification_size = NIL THEN
                RESET work_area TO type_information.members_information;
                EXIT /type_specification_ok/;
              IFEND;
              NEXT member_type_specification: [[REP member_type_specification_size^ OF cell]] IN
                    type_specification;
              IF member_type_specification = NIL THEN
                RESET work_area TO type_information.members_information;
                EXIT /type_specification_ok/;
              IFEND;
              clp$get_type_information (member_type_specification, work_area,
                    type_information.members_information^ [i], status);
              IF NOT status.normal THEN
                RESET work_area TO type_information.members_information;
                RETURN;
              IFEND;
            FOREND;
          IFEND;
*IF $true(osv$unix)

        = clc$unix_file_type =
          ;
*IFEND

        ELSE
          EXIT /type_specification_ok/;
        CASEND;
        RETURN;

      END /work_area_ok/;
      osp$set_status_abnormal ('CL', cle$work_area_overflow, 'clp$get_type_information', status);
      RETURN;

    END /type_specification_ok/;
    osp$set_status_condition (cle$bad_type_specification, status);

  PROCEND clp$get_type_information;
*IFEND
?? TITLE := 'clp$validate_type_conformance', EJECT ??

  PROCEDURE [XDCL] clp$validate_type_conformance
    (    subject_type_description: ^clt$type_description;
         target_type_description: ^clt$type_description;
     VAR type_conformance: clt$type_conformance);

    VAR
      i: integer,
      local_type_conformance: clt$type_conformance,
      max_real_order: mlt$compare,
      min_real_order: mlt$compare,
      subject_keyword: clt$keyword,
      target_keyword: clt$keyword;


    type_conformance := clc$no_conformance_to_type;

    IF (subject_type_description = NIL) OR (target_type_description = NIL) THEN
      RETURN;
    IFEND;

    CASE target_type_description^.kind OF

    = clc$application_type =
      IF subject_type_description^.kind = clc$application_type THEN
        IF (subject_type_description^.balance_brackets <> target_type_description^.balance_brackets) THEN
          type_conformance := clc$conforms_to_generic_type;
          RETURN;
        IFEND;
        IF subject_type_description^.name = NIL THEN
          IF target_type_description^.name = NIL THEN
            type_conformance := clc$identical_types;
            RETURN;
          IFEND;
        ELSEIF target_type_description^.name <> NIL THEN
          IF subject_type_description^.name^ = target_type_description^.name^ THEN
            type_conformance := clc$identical_types;
            RETURN;
          IFEND;
        IFEND;
        type_conformance := clc$conforms_to_generic_type;
      IFEND;

    = clc$array_type =
      IF subject_type_description^.kind = clc$array_type THEN
        IF target_type_description^.array_bounds_defined THEN
          IF subject_type_description^.array_bounds_defined AND
                (subject_type_description^.bounds.lower = target_type_description^.bounds.lower) AND
                (subject_type_description^.bounds.upper = target_type_description^.bounds.upper) THEN
            type_conformance := clc$identical_types;
          ELSE
            type_conformance := clc$conforms_to_generic_type;
          IFEND;
        ELSEIF subject_type_description^.array_bounds_defined THEN
          type_conformance := clc$conforms_to_type;
        ELSE
          type_conformance := clc$identical_types;
        IFEND;
        IF type_conformance >= clc$conforms_to_type THEN
          IF target_type_description^.array_element_type_description = NIL THEN
            IF subject_type_description^.array_element_type_description <> NIL THEN
              type_conformance := clc$conforms_to_generic_type;
            IFEND;
          ELSE
            clp$validate_type_conformance (subject_type_description^.array_element_type_description,
                  target_type_description^.array_element_type_description, local_type_conformance);
            IF local_type_conformance < type_conformance THEN
              type_conformance := local_type_conformance;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

    = clc$boolean_type =
      IF subject_type_description^.kind = clc$boolean_type THEN
        type_conformance := clc$identical_types;
      IFEND;

    = clc$cobol_name_type =
      IF subject_type_description^.kind = clc$cobol_name_type THEN
        type_conformance := clc$identical_types;
      IFEND;

    = clc$command_reference_type =
      IF subject_type_description^.kind = clc$command_reference_type THEN
        type_conformance := clc$identical_types;
      IFEND;

    = clc$data_name_type =
      IF subject_type_description^.kind = clc$data_name_type THEN
        type_conformance := clc$identical_types;
      IFEND;

    = clc$date_time_type =
      IF subject_type_description^.kind = clc$date_time_type THEN
        type_conformance := clc$identical_types;
      IFEND;

    = clc$entry_point_reference_type =
      IF subject_type_description^.kind = clc$entry_point_reference_type THEN
        type_conformance := clc$identical_types;
      IFEND;

*IF NOT $true(osv$unix)
    = clc$file_type =
      IF subject_type_description^.kind = clc$file_type THEN
*ELSE
    = clc$nos_ve_file_type =
      IF subject_type_description^.kind = clc$nos_ve_file_type THEN
*IFEND
        type_conformance := clc$identical_types;
      IFEND;

    = clc$integer_type =
      IF subject_type_description^.kind = clc$integer_type THEN
        IF (subject_type_description^.min_integer_value = target_type_description^.min_integer_value) AND
              (subject_type_description^.max_integer_value = target_type_description^.max_integer_value) AND
              (subject_type_description^.default_radix = target_type_description^.default_radix) THEN
          type_conformance := clc$identical_types;
        ELSEIF (subject_type_description^.min_integer_value >= target_type_description^.min_integer_value) AND
              (subject_type_description^.max_integer_value <= target_type_description^.max_integer_value) THEN
          type_conformance := clc$conforms_to_type;
        ELSE
          type_conformance := clc$conforms_to_generic_type;
        IFEND;
      IFEND;

    = clc$keyword_type =
      IF subject_type_description^.kind = clc$keyword_type THEN
        type_conformance := clc$conforms_to_generic_type;

      /check_keyword_conformance/
        BEGIN
          IF UPPERBOUND (subject_type_description^.keyword_specifications^) <=
                UPPERBOUND (target_type_description^.keyword_specifications^) THEN

            IF UPPERBOUND (subject_type_description^.keyword_specifications^) =
                  UPPERBOUND (target_type_description^.keyword_specifications^) THEN

            /check_keyword_specifications/
              BEGIN
                FOR i := 1 TO UPPERBOUND (subject_type_description^.keyword_specifications^) DO
                  IF subject_type_description^.keyword_specifications^ [i] <>
                        target_type_description^.keyword_specifications^ [i] THEN
                    EXIT /check_keyword_specifications/;
                  IFEND;
                FOREND;
                type_conformance := clc$identical_types;
                EXIT /check_keyword_conformance/;
              END /check_keyword_specifications/;
            IFEND;
            FOR i := 1 TO UPPERBOUND (subject_type_description^.keyword_specifications^) DO
              IF subject_type_description^.keyword_specifications^ [i].class = clc$nominal_entry THEN
                subject_keyword := subject_type_description^.keyword_specifications^ [i].keyword;
              ELSE
                clp$check_keyword (subject_type_description^.keyword_specifications^ [i].keyword,
                      subject_type_description^.keyword_specifications, subject_keyword);
              IFEND;
              clp$check_keyword (subject_type_description^.keyword_specifications^ [i].keyword,
                    target_type_description^.keyword_specifications, target_keyword);
              IF subject_keyword <> target_keyword THEN
                EXIT /check_keyword_conformance/;
              IFEND;
            FOREND;
            type_conformance := clc$conforms_to_type;
          IFEND;
        END /check_keyword_conformance/;
      IFEND;

    = clc$list_type =
      IF subject_type_description^.kind = clc$list_type THEN
        IF (target_type_description^.min_list_size = subject_type_description^.min_list_size) AND
              (subject_type_description^.max_list_size = target_type_description^.max_list_size) THEN
          type_conformance := clc$identical_types;
        ELSEIF (target_type_description^.min_list_size <= subject_type_description^.min_list_size) AND
              (subject_type_description^.max_list_size <= target_type_description^.max_list_size) THEN
          type_conformance := clc$conforms_to_type;
        ELSE
          type_conformance := clc$conforms_to_generic_type;
        IFEND;
        IF type_conformance >= clc$conforms_to_type THEN
          IF target_type_description^.list_element_type_description = NIL THEN
            IF subject_type_description^.list_element_type_description = NIL THEN
              type_conformance := clc$identical_types;
            ELSE
              type_conformance := clc$conforms_to_type;
            IFEND;
          ELSE
            clp$validate_type_conformance (subject_type_description^.list_element_type_description,
                  target_type_description^.list_element_type_description, local_type_conformance);
            IF local_type_conformance < type_conformance THEN
              type_conformance := local_type_conformance;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

    = clc$lock_type =
      IF subject_type_description^.kind = clc$lock_type THEN
        type_conformance := clc$identical_types;
      IFEND;

    = clc$name_type =
      IF subject_type_description^.kind = clc$name_type THEN
        IF (target_type_description^.min_name_size = subject_type_description^.min_name_size) AND
              (subject_type_description^.max_name_size = target_type_description^.max_name_size) THEN
          type_conformance := clc$identical_types;
        ELSEIF (target_type_description^.min_name_size <= subject_type_description^.min_name_size) AND
              (subject_type_description^.max_name_size <= target_type_description^.max_name_size) THEN
          type_conformance := clc$conforms_to_type;
        ELSE
          type_conformance := clc$conforms_to_generic_type;
        IFEND;
      IFEND;

    = clc$network_title_type =
      IF subject_type_description^.kind = clc$network_title_type THEN
        type_conformance := clc$identical_types;
      IFEND;

    = clc$program_name_type =
      IF subject_type_description^.kind = clc$program_name_type THEN
        type_conformance := clc$identical_types;
      IFEND;

    = clc$range_type =
      IF subject_type_description^.kind = clc$range_type THEN
        IF target_type_description^.range_element_type_description = NIL THEN
          IF subject_type_description^.range_element_type_description = NIL THEN
            type_conformance := clc$identical_types;
          ELSE
            type_conformance := clc$conforms_to_type;
          IFEND;
        ELSE
          clp$validate_type_conformance (subject_type_description^.range_element_type_description,
                target_type_description^.range_element_type_description, type_conformance);
          IF type_conformance = clc$no_conformance_to_type THEN
            type_conformance := clc$conforms_to_generic_type;
          IFEND;
        IFEND;
      IFEND;

    = clc$real_type =
      IF subject_type_description^.kind = clc$real_type THEN
*IF NOT $true(osv$unix)
        max_real_order := clp$longreal_compare (subject_type_description^.max_real_value.long_real,
              target_type_description^.max_real_value.long_real, clc$infinities_equal);
        min_real_order := clp$longreal_compare (subject_type_description^.min_real_value.long_real,
              target_type_description^.min_real_value.long_real, clc$infinities_equal);
        IF (min_real_order = clc$equal) AND (max_real_order = clc$equal) THEN
          type_conformance := clc$identical_types;
        ELSEIF (min_real_order IN $clt$comparison_results [clc$left_is_greater,
              clc$equal]) AND (max_real_order IN $clt$comparison_results [clc$right_is_greater, clc$equal])
              THEN
          type_conformance := clc$conforms_to_type;
        ELSE
          type_conformance := clc$conforms_to_generic_type;
        IFEND;
*IFEND
      IFEND;

    = clc$record_type =
      IF subject_type_description^.kind = clc$record_type THEN
        IF subject_type_description^.fields_pdt^.header^.number_of_parameters =
              target_type_description^.fields_pdt^.header^.number_of_parameters THEN
          type_conformance := clc$identical_types;
        ELSEIF subject_type_description^.fields_pdt^.header^.number_of_parameters <=
              target_type_description^.fields_pdt^.header^.number_of_parameters THEN
          type_conformance := clc$conforms_to_type;
        ELSE
          type_conformance := clc$conforms_to_generic_type;
        IFEND;
        IF type_conformance >= clc$conforms_to_type THEN

        /check_fields/
          FOR i := 1 TO subject_type_description^.fields_pdt^.header^.number_of_parameters DO
            IF type_conformance >= clc$conforms_to_type THEN
              IF (subject_type_description^.fields_pdt^.names^ [i].name <>
                    target_type_description^.fields_pdt^.names^ [i].name) OR
                    (subject_type_description^.fields_pdt^.parameters^ [i].requirement >
                    target_type_description^.fields_pdt^.parameters^ [i].requirement) THEN
                type_conformance := clc$conforms_to_generic_type;
              ELSEIF (type_conformance = clc$identical_types) AND
                    (subject_type_description^.fields_pdt^.parameters^ [i].requirement <>
                    target_type_description^.fields_pdt^.parameters^ [i].requirement) THEN
                type_conformance := clc$conforms_to_type;
              IFEND;
            IFEND;
            clp$validate_type_conformance (^subject_type_description^.fields_pdt^.type_descriptions^ [i],
                  ^target_type_description^.fields_pdt^.type_descriptions^ [i], local_type_conformance);
            IF local_type_conformance < type_conformance THEN
              type_conformance := local_type_conformance;
            IFEND;
            IF (type_conformance <= clc$conforms_to_generic_type) THEN
              EXIT /check_fields/;
            IFEND;
          FOREND /check_fields/;
        IFEND;
      IFEND;

    = clc$scu_line_identifier_type =
      IF subject_type_description^.kind = clc$scu_line_identifier_type THEN
        type_conformance := clc$identical_types;
      IFEND;

    = clc$statistic_code_type =
      IF subject_type_description^.kind = clc$statistic_code_type THEN
        type_conformance := clc$identical_types;
      IFEND;

    = clc$status_type =
      IF subject_type_description^.kind = clc$status_type THEN
        type_conformance := clc$identical_types;
      IFEND;

    = clc$status_code_type =
      IF subject_type_description^.kind = clc$status_code_type THEN
        type_conformance := clc$identical_types;
      IFEND;

    = clc$string_type =
      IF subject_type_description^.kind = clc$string_type THEN
        IF (target_type_description^.min_string_size = subject_type_description^.min_string_size) AND
              (subject_type_description^.max_string_size = target_type_description^.max_string_size) AND
              (target_type_description^.literal = subject_type_description^.literal) THEN
          type_conformance := clc$identical_types;
        ELSEIF (target_type_description^.min_string_size <= subject_type_description^.min_string_size) AND
              (subject_type_description^.max_string_size <= target_type_description^.max_string_size) AND
              (target_type_description^.literal <= subject_type_description^.literal) THEN
          type_conformance := clc$conforms_to_type;
        ELSE
          type_conformance := clc$conforms_to_generic_type;
        IFEND;
      IFEND;

    = clc$string_pattern_type =
      IF subject_type_description^.kind = clc$string_pattern_type THEN
        type_conformance := clc$identical_types;
      IFEND;

    = clc$time_increment_type =
      IF subject_type_description^.kind = clc$time_increment_type THEN
        type_conformance := clc$identical_types;
      IFEND;

    = clc$time_zone_type =
      IF subject_type_description^.kind = clc$time_zone_type THEN
        type_conformance := clc$identical_types;
      IFEND;

    = clc$type_specification_type =
      IF subject_type_description^.kind = clc$type_specification_type THEN
        type_conformance := clc$identical_types;
      IFEND;

    = clc$union_type =
      IF subject_type_description^.kind = clc$union_type THEN
        IF target_type_description^.member_descriptions = NIL THEN
          IF subject_type_description^.member_descriptions = NIL THEN
            type_conformance := clc$identical_types;
          ELSE
            type_conformance := clc$conforms_to_type;
          IFEND;
        ELSEIF (subject_type_description^.member_descriptions = NIL) OR
              (UPPERBOUND (subject_type_description^.member_descriptions^) >
              UPPERBOUND (target_type_description^.member_descriptions^)) THEN
          type_conformance := clc$conforms_to_generic_type;
        ELSE
          IF UPPERBOUND (subject_type_description^.member_descriptions^) =
                UPPERBOUND (target_type_description^.member_descriptions^) THEN
            type_conformance := clc$identical_types;
          ELSE
            type_conformance := clc$conforms_to_type;
          IFEND;

        /check_members/
          FOR i := 1 TO UPPERBOUND (subject_type_description^.member_descriptions^) DO
            CASE type_conformance OF
            = clc$identical_types =
              clp$validate_type_conformance (^subject_type_description^.member_descriptions^ [i],
                    ^target_type_description^.member_descriptions^ [i], local_type_conformance);
              CASE local_type_conformance OF
              = clc$identical_types =
                ;
              = clc$conforms_to_type =
                type_conformance := clc$conforms_to_type;
              ELSE
                clp$validate_type_conformance (^subject_type_description^.member_descriptions^ [i],
                      target_type_description, type_conformance);
                IF type_conformance = clc$no_conformance_to_type THEN
                  type_conformance := clc$conforms_to_generic_type;
                IFEND;
              CASEND;
            = clc$conforms_to_type =
              clp$validate_type_conformance (^subject_type_description^.member_descriptions^ [i],
                    target_type_description, type_conformance);
              IF type_conformance = clc$no_conformance_to_type THEN
                type_conformance := clc$conforms_to_generic_type;
              IFEND;
            ELSE
              ;
            CASEND;
            IF (type_conformance <= clc$conforms_to_generic_type) THEN
              EXIT /check_members/;
            IFEND;
          FOREND /check_members/;
        IFEND;
      ELSEIF target_type_description^.member_descriptions = NIL THEN
        type_conformance := clc$conforms_to_type;
      ELSE
        FOR i := 1 TO UPPERBOUND (target_type_description^.member_descriptions^) DO
          clp$validate_type_conformance (subject_type_description,
                ^target_type_description^.member_descriptions^ [i], local_type_conformance);
          IF local_type_conformance > type_conformance THEN
            type_conformance := local_type_conformance;
          IFEND;
        FOREND;
      IFEND;
*IF $true(osv$unix)

    = clc$unix_file_type =
      IF subject_type_description^.kind = clc$unix_file_type THEN
        type_conformance := clc$identical_types;
      IFEND;
*IFEND

    ELSE
      ;
    CASEND;

  PROCEND clp$validate_type_conformance;
?? TITLE := 'clp$validate_value_conformance', EJECT ??

  PROCEDURE [XDCL] clp$validate_value_conformance
    (    value: ^clt$data_value;
         type_description: ^clt$type_description;
     VAR type_conformance: clt$type_conformance);

    VAR
      current_value: ^clt$data_value,
      i: integer,
      local_type_conformance: clt$type_conformance,
      result_keyword: clt$keyword;


    type_conformance := clc$no_conformance_to_type;

    IF value = NIL THEN
      RETURN;
    IFEND;

    IF type_description = NIL THEN
      type_conformance := clc$conforms_to_type;
      RETURN;
    IFEND;

    CASE type_description^.kind OF

    = clc$application_type =
      IF value^.kind = clc$application THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$array_type =
      IF value^.kind = clc$array THEN
        IF (value^.array_value <> NIL) AND ((NOT type_description^.array_bounds_defined) OR
              ((type_description^.bounds.lower = LOWERBOUND (value^.array_value^)) AND
              (type_description^.bounds.upper = UPPERBOUND (value^.array_value^)))) THEN
          type_conformance := clc$conforms_to_type;
          IF type_description^.array_element_type_description <> NIL THEN

          /check_array_elements/
            FOR i := LOWERBOUND (value^.array_value^) TO UPPERBOUND (value^.array_value^) DO
              clp$validate_value_conformance (value^.array_value^ [i],
                    type_description^.array_element_type_description, type_conformance);
              IF type_conformance <= clc$conforms_to_generic_type THEN
                type_conformance := clc$conforms_to_generic_type;
                EXIT /check_array_elements/;
              IFEND;
            FOREND /check_array_elements/;
          IFEND;
        ELSE
          type_conformance := clc$conforms_to_generic_type;
        IFEND;
      IFEND;

    = clc$boolean_type =
      IF value^.kind = clc$boolean THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$cobol_name_type =
      IF value^.kind = clc$cobol_name THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$command_reference_type =
      IF value^.kind = clc$command_reference THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$data_name_type =
      IF value^.kind = clc$data_name THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$date_time_type =
      IF value^.kind = clc$date_time THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$entry_point_reference_type =
      IF value^.kind = clc$entry_point_reference THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

*IF NOT $true(osv$unix)
    = clc$file_type =
      IF value^.kind = clc$file THEN
*ELSE
    = clc$nos_ve_file_type =
      IF value^.kind = clc$nos_ve_file THEN
*IFEND
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$integer_type =
      IF value^.kind = clc$integer THEN
        IF (type_description^.min_integer_value <= value^.integer_value.value) AND
              (value^.integer_value.value <= type_description^.max_integer_value) THEN
          type_conformance := clc$conforms_to_type;
        ELSE
          type_conformance := clc$conforms_to_generic_type;
        IFEND;
      IFEND;

    = clc$keyword_type =
      IF value^.kind = clc$keyword THEN
        clp$check_keyword (value^.keyword_value, type_description^.keyword_specifications, result_keyword);
        IF value^.keyword_value = result_keyword THEN
          type_conformance := clc$conforms_to_type;
        ELSE
          type_conformance := clc$conforms_to_generic_type;
        IFEND;
      IFEND;

    = clc$list_type =
      IF value^.kind = clc$list THEN
        IF type_description^.list_element_type_description = NIL THEN
          type_conformance := clc$conforms_to_type;
        ELSE

        /check_list_elements/
          BEGIN
            i := 0;
            current_value := value;
            REPEAT
              IF current_value^.kind <> clc$list THEN
                type_conformance := clc$no_conformance_to_type;
                EXIT /check_list_elements/;
              ELSEIF current_value^.element_value = NIL THEN
                IF (i > 0) OR (current_value^.link <> NIL) THEN
                  type_conformance := clc$no_conformance_to_type;
                  EXIT /check_list_elements/;
                IFEND;
              ELSE
                i := i + 1;
                clp$validate_value_conformance (current_value^.element_value,
                      type_description^.list_element_type_description, type_conformance);
                IF type_conformance <= clc$conforms_to_generic_type THEN
                  EXIT /check_list_elements/;
                IFEND;
              IFEND;
              current_value := current_value^.link;
            UNTIL current_value = NIL {/check_list_elements/} ;
            IF (type_description^.min_list_size <= i) AND (i <= type_description^.max_list_size) THEN
              type_conformance := clc$conforms_to_type;
            ELSE
              type_conformance := clc$conforms_to_generic_type;
            IFEND;
          END /check_list_elements/;
        IFEND;
      IFEND;

    = clc$lock_type =
      IF value^.kind = clc$lock THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$name_type =
      IF value^.kind = clc$name THEN
        i := clp$trimmed_string_size (value^.name_value);
        IF (type_description^.min_name_size <= i) AND (i <= type_description^.max_name_size) THEN
          type_conformance := clc$conforms_to_type;
        ELSE
          type_conformance := clc$conforms_to_generic_type;
        IFEND;
      IFEND;

    = clc$network_title_type =
      IF value^.kind = clc$network_title THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$program_name_type =
      IF value^.kind = clc$program_name THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$range_type =
      IF value^.kind = clc$range THEN
        IF type_description^.range_element_type_description = NIL THEN
          type_conformance := clc$conforms_to_type;
        ELSE
          clp$validate_value_conformance (value^.low_value, type_description^.range_element_type_description,
                type_conformance);
          IF (type_conformance = clc$conforms_to_type) AND (value^.high_value <> value^.low_value) THEN
            clp$validate_value_conformance (value^.high_value,
                  type_description^.range_element_type_description, type_conformance);
          IFEND;
          IF type_conformance = clc$no_conformance_to_type THEN
            type_conformance := clc$conforms_to_generic_type;
          IFEND;
        IFEND;
      IFEND;

    = clc$real_type =
*IF NOT $true(osv$unix)
      IF value^.kind = clc$real THEN
        IF clp$longreal_compare_le (type_description^.min_real_value.long_real,
              value^.real_value.value) AND clp$longreal_compare_le
              (value^.real_value.value, type_description^.max_real_value.long_real) THEN
          type_conformance := clc$conforms_to_type;
        ELSE
          type_conformance := clc$conforms_to_generic_type;
        IFEND;
      IFEND;
*IFEND


    = clc$record_type =
      IF value^.kind = clc$record THEN
        IF (value^.field_values = NIL) OR (UPPERBOUND (value^.field_values^) >
              type_description^.fields_pdt^.header^.number_of_parameters) THEN
          type_conformance := clc$conforms_to_generic_type;
        ELSE

        /check_fields/
          BEGIN
            FOR i := 1 TO UPPERBOUND (value^.field_values^) DO
              IF type_description^.fields_pdt^.names^ [i].name <> value^.field_values^ [i].name THEN
                type_conformance := clc$conforms_to_generic_type;
                EXIT /check_fields/;
              ELSEIF (value^.field_values^ [i].value = NIL) OR
                    (value^.field_values^ [i].value^.kind = clc$unspecified) THEN
                IF type_description^.fields_pdt^.parameters^ [i].requirement = clc$required_field THEN
                  type_conformance := clc$conforms_to_generic_type;
                  EXIT /check_fields/;
                IFEND;
              ELSE
                clp$validate_value_conformance (value^.field_values^ [i].value,
                      ^type_description^.fields_pdt^.type_descriptions^ [i], type_conformance);
                IF type_conformance <= clc$conforms_to_generic_type THEN
                  type_conformance := clc$conforms_to_generic_type;
                  EXIT /check_fields/;
                IFEND;
              IFEND;
            FOREND;
            FOR i := UPPERBOUND (value^.field_values^) + 1 TO type_description^.fields_pdt^.header^.
                  number_of_parameters DO
              IF type_description^.fields_pdt^.parameters^ [i].requirement = clc$required_field THEN
                type_conformance := clc$conforms_to_generic_type;
                EXIT /check_fields/;
              IFEND;
            FOREND;
          END /check_fields/;
        IFEND;
      IFEND;

    = clc$scu_line_identifier_type =
      IF value^.kind = clc$scu_line_identifier THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$statistic_code_type =
      IF value^.kind = clc$statistic_code THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$status_type =
      IF value^.kind = clc$status THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$status_code_type =
      IF value^.kind = clc$status_code THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$string_type =
      IF value^.kind = clc$string THEN
        IF (type_description^.min_string_size <= STRLENGTH (value^.string_value^)) AND
              (STRLENGTH (value^.string_value^) <= type_description^.max_string_size) THEN
          type_conformance := clc$conforms_to_type;
        ELSE
          type_conformance := clc$conforms_to_generic_type;
        IFEND;
      IFEND;

    = clc$string_pattern_type =
      IF value^.kind = clc$string_pattern THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$time_increment_type =
      IF value^.kind = clc$time_increment THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$time_zone_type =
      IF value^.kind = clc$time_zone THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$type_specification_type =
      IF value^.kind = clc$type_specification THEN
        type_conformance := clc$conforms_to_type;
      IFEND;

    = clc$union_type =
      IF type_description^.member_descriptions = NIL THEN
        type_conformance := clc$conforms_to_type;
      ELSE

      /check_member/
        FOR i := 1 TO UPPERBOUND (type_description^.member_descriptions^) DO
          clp$validate_value_conformance (value, ^type_description^.member_descriptions^ [i],
                local_type_conformance);
          IF local_type_conformance > type_conformance THEN
            type_conformance := local_type_conformance;
          IFEND;
          IF type_conformance = clc$conforms_to_type THEN
            EXIT /check_member/;
          IFEND;
        FOREND /check_member/;
      IFEND;
*IF $true(osv$unix)

    = clc$unix_file_type =
      IF value^.kind = clc$unix_file THEN
        type_conformance := clc$conforms_to_type;
      IFEND;
*IFEND

    ELSE
      ;
    CASEND;

  PROCEND clp$validate_value_conformance;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$validate_var_conformance', EJECT ??

  PROCEDURE [XDCL] clp$validate_var_conformance
    (    subject_type_description: ^clt$type_description;
         target_type_description: ^clt$type_description;
     VAR status: ost$status);

    VAR
      i: integer;


    status.normal := TRUE;

    IF (subject_type_description = NIL) OR (target_type_description = NIL) THEN
      osp$set_status_condition (cle$undefined_type, status);
      RETURN;
    IFEND;

    CASE target_type_description^.kind OF

    = clc$application_type =
      IF (subject_type_description^.kind = clc$application_type) THEN
        IF (subject_type_description^.balance_brackets <> target_type_description^.balance_brackets) THEN
          osp$set_status_condition (cle$balance_brackets_dont_match, status);
          RETURN;
        IFEND;
        IF subject_type_description^.name = NIL THEN
          IF target_type_description^.name = NIL THEN
            RETURN;
          IFEND;
        ELSEIF target_type_description^.name <> NIL THEN
          IF subject_type_description^.name^ = target_type_description^.name^ THEN
            RETURN;
          IFEND;
        IFEND;
        osp$set_status_condition (cle$application_name_mismatch, status);
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$array_type =
      IF subject_type_description^.kind = clc$array_type THEN
        IF target_type_description^.array_bounds_defined THEN
          IF NOT subject_type_description^.array_bounds_defined OR
                (subject_type_description^.bounds.lower <> target_type_description^.bounds.lower) OR
                (subject_type_description^.bounds.upper <> target_type_description^.bounds.upper) THEN
            osp$set_status_condition (cle$array_bounds_dont_match, status);
          IFEND;
        ELSEIF (target_type_description^.array_element_type_description <> NIL) THEN
          clp$validate_var_conformance (subject_type_description^.array_element_type_description,
                target_type_description^.array_element_type_description, status);
          IF NOT status.normal AND (status.condition = cle$wrong_kind_of_value) THEN
            status.condition := cle$wrong_kind_of_element_type;
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$boolean_type =
      IF subject_type_description^.kind <> clc$boolean_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$cobol_name_type =
      IF subject_type_description^.kind <> clc$cobol_name_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$command_reference_type =
      IF subject_type_description^.kind <> clc$command_reference_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$data_name_type =
      IF subject_type_description^.kind <> clc$data_name_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$date_time_type =
      IF (subject_type_description^.kind = clc$date_time_type) THEN
        IF (subject_type_description^.date_and_or_time = target_type_description^.date_and_or_time) THEN
          IF (subject_type_description^.tenses <> target_type_description^.tenses) THEN
            osp$set_status_condition (cle$date_time_tenses_dont_match, status);
          IFEND;
        ELSE
          osp$set_status_condition (cle$date_time_types_dont_match, status);
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$entry_point_reference_type =
      IF subject_type_description^.kind <> clc$entry_point_reference_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

*IF NOT $true(osv$unix)
    = clc$file_type =
      IF subject_type_description^.kind <> clc$file_type THEN
*ELSE
    = clc$nos_ve_file_type =
      IF subject_type_description^.kind <> clc$nos_ve_file_type THEN
*IFEND
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$integer_type =
      IF (subject_type_description^.kind = clc$integer_type) THEN
        IF (target_type_description^.min_integer_value <> subject_type_description^.min_integer_value) OR
              (subject_type_description^.max_integer_value <> target_type_description^.max_integer_value) THEN
          osp$set_status_condition (cle$integer_ranges_dont_match, status);
        ELSEIF (subject_type_description^.default_radix <> target_type_description^.default_radix) THEN
          osp$set_status_condition (cle$integer_radices_dont_match, status);
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$keyword_type =
      IF (subject_type_description^.kind = clc$keyword_type) THEN
        IF (UPPERBOUND (subject_type_description^.keyword_specifications^) =
              UPPERBOUND (target_type_description^.keyword_specifications^)) THEN

        /check_keywords/
          BEGIN
            FOR i := 1 TO UPPERBOUND (subject_type_description^.keyword_specifications^) DO
              IF subject_type_description^.keyword_specifications^ [i] <>
                    target_type_description^.keyword_specifications^ [i] THEN
                osp$set_status_condition (cle$keywords_dont_match, status);
                EXIT /check_keywords/;
              IFEND;
            FOREND;
          END /check_keywords/;
        ELSE
          osp$set_status_condition (cle$keywords_dont_match, status);
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$list_type =
      IF (subject_type_description^.kind = clc$list_type) THEN
        IF (target_type_description^.min_list_size = subject_type_description^.min_list_size) AND
              ((target_type_description^.max_list_size = clc$max_list_size) OR
              (subject_type_description^.max_list_size = target_type_description^.max_list_size)) THEN
          IF (subject_type_description^.list_rest = target_type_description^.list_rest) THEN
            IF (NOT subject_type_description^.defer_expansion) OR
                  target_type_description^.defer_expansion THEN
              IF target_type_description^.list_element_type_description <> NIL THEN
                clp$validate_var_conformance (subject_type_description^.list_element_type_description,
                      target_type_description^.list_element_type_description, status);
                IF NOT status.normal AND (status.condition = cle$wrong_kind_of_value) THEN
                  status.condition := cle$wrong_kind_of_element_type;
                IFEND;
              IFEND;
            ELSE
              osp$set_status_condition (cle$defer_expans_doesnt_match, status);
            IFEND;
          ELSE
            osp$set_status_condition (cle$list_rest_doesnt_match, status);
          IFEND;
        ELSE
          osp$set_status_condition (cle$list_sizes_dont_match, status);
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$lock_type =
      IF subject_type_description^.kind <> clc$lock_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$name_type =
      IF (subject_type_description^.kind = clc$name_type) THEN
        IF (target_type_description^.min_name_size <> subject_type_description^.min_name_size) OR
              (subject_type_description^.max_name_size <> target_type_description^.max_name_size) THEN
          osp$set_status_condition (cle$name_sizes_dont_match, status);
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$network_title_type =
      IF subject_type_description^.kind <> clc$network_title_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$program_name_type =
      IF subject_type_description^.kind <> clc$program_name_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$range_type =
      IF subject_type_description^.kind = clc$range_type THEN
        IF target_type_description^.range_element_type_description <> NIL THEN
          clp$validate_var_conformance (subject_type_description^.range_element_type_description,
                target_type_description^.range_element_type_description, status);
          IF NOT status.normal AND (status.condition = cle$wrong_kind_of_value) THEN
            status.condition := cle$range_types_dont_match;
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$real_type =
      IF (subject_type_description^.kind = clc$real_type) THEN
        IF NOT (clp$longreal_compare_eq (target_type_description^.min_real_value.long_real,
              subject_type_description^.min_real_value.long_real) AND
              clp$longreal_compare_eq (subject_type_description^.max_real_value.long_real,
              target_type_description^.max_real_value.long_real)) THEN
          osp$set_status_condition (cle$real_subranges_dont_match, status);
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$record_type =
      IF (subject_type_description^.kind = clc$record_type) THEN
        IF (subject_type_description^.fields_pdt^.header^.number_of_parameters =
              target_type_description^.fields_pdt^.header^.number_of_parameters) THEN

        /check_fields/
          FOR i := 1 TO subject_type_description^.fields_pdt^.header^.number_of_parameters DO
            IF (subject_type_description^.fields_pdt^.names^ [i].name <>
                  target_type_description^.fields_pdt^.names^ [i].name) THEN
              osp$set_status_condition (cle$field_names_dont_match, status);
            ELSEIF (subject_type_description^.fields_pdt^.parameters^ [i].requirement <>
                  target_type_description^.fields_pdt^.parameters^ [i].requirement) THEN
              osp$set_status_condition (cle$field_requirements_mismatch, status);
              EXIT /check_fields/;
            IFEND;
            clp$validate_var_conformance (^subject_type_description^.fields_pdt^.type_descriptions^ [i],
                  ^target_type_description^.fields_pdt^.type_descriptions^ [i], status);
            IF NOT status.normal THEN
              IF (status.condition = cle$wrong_kind_of_value) THEN
                status.condition := cle$field_types_dont_match;
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      subject_type_description^.fields_pdt^.names^ [i].name, status);
              IFEND;
              EXIT /check_fields/;
            IFEND;
          FOREND /check_fields/;
        ELSE
          osp$set_status_condition (cle$number_of_fields_dont_match, status);
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$scu_line_identifier_type =
      IF subject_type_description^.kind <> clc$scu_line_identifier_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$statistic_code_type =
      IF subject_type_description^.kind <> clc$statistic_code_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$status_type =
      IF subject_type_description^.kind <> clc$status_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$status_code_type =
      IF subject_type_description^.kind <> clc$status_code_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$string_type =
      IF (subject_type_description^.kind = clc$string_type) THEN
        IF NOT ((target_type_description^.min_string_size <= subject_type_description^.min_string_size) AND
              (subject_type_description^.max_string_size <= target_type_description^.max_string_size)) THEN
          osp$set_status_condition (cle$string_sizes_dont_match, status);
        ELSEIF (subject_type_description^.literal <> target_type_description^.literal) THEN
          osp$set_status_condition (cle$string_literals_dont_match, status);
        IFEND;
      ELSE
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$string_pattern_type =
      IF subject_type_description^.kind <> clc$string_pattern_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$time_increment_type =
      IF subject_type_description^.kind <> clc$time_increment_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$time_zone_type =
      IF subject_type_description^.kind <> clc$time_zone_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$type_specification_type =
      IF subject_type_description^.kind <> clc$type_specification_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;

    = clc$union_type =
      IF subject_type_description^.kind = clc$union_type THEN
        IF target_type_description^.member_descriptions <> NIL THEN
          IF (subject_type_description^.member_descriptions <> NIL) AND
                (UPPERBOUND (subject_type_description^.member_descriptions^) =
                UPPERBOUND (target_type_description^.member_descriptions^)) THEN

          /check_members_conform/
            FOR i := 1 TO UPPERBOUND (subject_type_description^.member_descriptions^) DO
              clp$validate_var_conformance (^subject_type_description^.member_descriptions^ [i],
                    ^target_type_description^.member_descriptions^ [i], status);
              IF NOT status.normal THEN

{ This routine assumes that its caller will insert the text into the status record for this particular
{ condition.

                osp$set_status_condition (cle$variable_not_union_type, status);
                EXIT /check_members_conform/;
              IFEND;
            FOREND /check_members_conform/;
          ELSE

{ This routine assumes that its caller will insert the text into the status record for this particular
{ condition.

            osp$set_status_condition (cle$variable_not_union_type, status);
          IFEND;
        IFEND;

      ELSEIF target_type_description^.member_descriptions <> NIL THEN

        FOR i := 1 TO UPPERBOUND (target_type_description^.member_descriptions^) DO
          clp$validate_var_conformance (subject_type_description,
                ^target_type_description^.member_descriptions^ [i], status);
          IF status.normal THEN
            RETURN;
          IFEND;
        FOREND;

{ This routine assumes that its caller will insert the text into the status record for this particular
{ condition.

        osp$set_status_condition (cle$variable_not_union_type, status);
      IFEND;
*IF $true(osv$unix)

    = clc$unix_file_type =
      IF subject_type_description^.kind <> clc$unix_file_type THEN
        osp$set_status_condition (cle$wrong_kind_of_value, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, target_type_description, status);
        clp$append_status_type_desc (osc$status_parameter_delimiter, subject_type_description, status);
      IFEND;
*IFEND

    ELSE
      ;
    CASEND;

  PROCEND clp$validate_var_conformance;
*IFEND

MODEND clm$process_data_types;
*DECK DECK=CLM$PROCESS_PROC_PARAMETERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Process Procedure Parameters' ??
MODULE clm$process_proc_parameters;

{
{ PURPOSE:
{   This module contains the routines that interpret a command or function
{   procedure's parameter declarations (header) and use the resulting
{   parameter description table (PDT) to evaluate the actual parameter of a
{   to the procedure.
{
{ NOTE:
{   The PDTs for "old style" command PROCedures are translated prior to
{   evaluating actual parameters.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$max_proc_names
*copyc clc$proc_pdt_parameter_limits
*copyc cle$expecting_proc
*copyc cle$parameters_displayed
*copyc cle$work_area_overflow
*copyc clt$command_line
*copyc clt$command_or_function
*copyc clt$parse_state
*copyc clt$scl_procedure
*copyc clt$scl_procedure_header
*copyc clt$work_area
*copyc ost$status
?? POP ??
*copyc clp$append_status_parse_state
*copyc clp$convert_type_desc_to_spec
*copyc clp$display_cmnd_or_func_info
*copyc clp$echo_command
*copyc clp$get_command_line
*copyc clp$internal_evaluate_params
*copyc clp$internal_generate_old_pdt
*copyc clp$internal_generate_pdt
*copyc clp$log_command_line
*copyc clp$prepare_for_log_and_or_echo
*copyc clp$scan_non_space_lexical_unit
*copyc clp$save_evaluated_parameters
*copyc clp$set_input_line_parse
*copyc clp$setup_parameter_evaluation
*copyc clp$translate_pdt
*copyc clp$unbundle_pdt
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
?? TITLE := 'clp$process_proc_parameters', EJECT ??

  PROCEDURE [XDCL] clp$process_proc_parameters
    (    command_or_function: clt$command_or_function;
         proc_data: ^clt$scl_procedure;
         header: ^clt$scl_procedure_header;
         can_be_echoed: boolean;
     VAR parameter_list_parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      command_or_function_name: pmt$program_name,
      end_of_input: boolean,
      ignore_aliases: ^array [1 .. * ] of pmt$program_name,
      ignore_availability: clt$named_entry_availability,
      ignore_command_log_option: clt$command_log_option,
      ignore_command_or_func_scope: clt$command_or_function_scope,
      name: ost$name,
      old_style_proc: boolean,
      parse: clt$parse_state,
      parameter_descrioption_table: ^clt$parameter_description_table,
      pdt: clt$unbundled_pdt;

?? NEWTITLE := 'evaluate_proc_parameters', EJECT ??

    PROCEDURE [INLINE] evaluate_proc_parameters
      (    proc_name: clt$command_name;
           check_parameters_procedure: clt$check_parameters_procedure);

      VAR
        command_reference_text: ^clt$command_line,
        edited_command: ^clt$command_line,
        evaluation_context: clt$parameter_eval_context,
        help_context: clt$parameter_help_context,
        ignore_status: ^ost$status,
        ignore_work_area_ptr: ^^clt$work_area,
        pvt: ^clt$parameter_value_table;


      status.normal := TRUE;

    /evaluate/
      BEGIN
        clp$setup_parameter_evaluation (^pdt, proc_name, TRUE, parameter_list_parse,
              ignore_work_area_ptr, evaluation_context, help_context, status);
        IF NOT status.normal THEN
          EXIT /evaluate/;
        IFEND;

        IF (evaluation_context.interpreter_mode = clc$help_mode) AND
              (help_context.help_output_file <> NIL) THEN
          clp$display_cmnd_or_func_info (fsc$list, help_context,
                evaluation_context.command_or_function_source^, evaluation_context.command_or_function_name,
                pdt, status);
          IF status.normal THEN
            osp$set_status_abnormal ('CL', cle$parameters_displayed, '', status);
          IFEND;
          EXIT /evaluate/;
        IFEND;

        IF pdt.header^.number_of_parameters = 0 THEN
          pvt := NIL;
        ELSE
          NEXT pvt: [1 .. pdt.header^.number_of_parameters] IN work_area;
        IFEND;

        clp$internal_evaluate_params (evaluation_context, pdt, check_parameters_procedure,
              parameter_list_parse, work_area, pvt, status);

        IF NOT (evaluation_context.command_logging_completed AND evaluation_context.command_echoing_completed)
              THEN
          IF (evaluation_context.interpreter_mode = clc$interpret_mode) AND
                (evaluation_context.prompting_requested) THEN
            command_reference_text := ^parameter_list_parse.text^
                  (evaluation_context.command_or_function_source^.reference_index-1,
                  evaluation_context.command_or_function_source^.reference_size+1);
          ELSE
            command_reference_text := ^parameter_list_parse.text^
                  (evaluation_context.command_or_function_source^.reference_index,
                  evaluation_context.command_or_function_source^.reference_size);
          IFEND;
          clp$prepare_for_log_and_or_echo (command_reference_text, ^pdt, pvt, work_area, edited_command);
          PUSH ignore_status;
          IF NOT evaluation_context.command_logging_completed THEN
            clp$log_command_line (edited_command^, ignore_status^);
          IFEND;
          IF NOT evaluation_context.command_echoing_completed THEN
            clp$echo_command (evaluation_context.interpreter_mode, edited_command^, ignore_status^);
          IFEND;
        IFEND;

        clp$save_evaluated_parameters (^pdt, pvt, FALSE, work_area, status);
      END /evaluate/;

    PROCEND evaluate_proc_parameters;
?? TITLE := 'get_proc_declaration_line', EJECT ??

    PROCEDURE [INLINE] get_proc_declaration_line
      (VAR procedure_declaration {input, output} : ^clt$input_data;
       VAR line: ^clt$command_line;
       VAR status: ost$status);

      VAR
        component_lines_data: ^array [1 .. * ] of cell,
        lexical_units: ^clt$lexical_units,
        line_header: ^clt$input_data_line_header;


      status.normal := TRUE;

      NEXT line_header IN procedure_declaration;
      IF line_header = NIL THEN
        line := NIL;
        RETURN;
      IFEND;

      NEXT line: [line_header^.line_size] IN procedure_declaration;

      IF line_header^.number_of_lexical_units > 0 THEN
        NEXT lexical_units: [1 .. line_header^.number_of_lexical_units] IN procedure_declaration;
      IFEND;

      IF line_header^.size_of_component_lines_data > 0 THEN
        NEXT component_lines_data: [1 .. line_header^.size_of_component_lines_data] IN procedure_declaration;
      IFEND;

    PROCEND get_proc_declaration_line;
?? TITLE := 'get_proc_line', EJECT ??

    PROCEDURE get_proc_line
      (VAR parse: clt$parse_state;
       VAR end_of_input: boolean;
       VAR status: ost$status);


      status.normal := TRUE;

      clp$get_command_line (parse, end_of_input, status);
      IF (NOT status.normal) OR end_of_input THEN
        RETURN;
      IFEND;

      IF status.normal AND can_be_echoed THEN
        clp$echo_command (clc$interpret_mode, parse.text^, status);
      IFEND;

    PROCEND get_proc_line;
?? TITLE := 'handle_compiled_proc', EJECT ??

    PROCEDURE [INLINE] handle_compiled_proc;

      VAR
        check_parameters_procedure: clt$check_parameters_procedure,
        line: ^clt$command_line,
        procedure_declaration: ^clt$input_data;


      IF can_be_echoed THEN
        procedure_declaration := #PTR (header^.procedure_declaration, proc_data^);
        RESET procedure_declaration;

      /echo_procedure_declaration/
        WHILE TRUE DO
          get_proc_declaration_line (procedure_declaration, line, status);
          IF NOT status.normal THEN
            EXIT clp$process_proc_parameters;
          ELSEIF line = NIL THEN
            EXIT /echo_procedure_declaration/;
          IFEND;
          clp$echo_command (clc$interpret_mode, line^, status);
          IF NOT status.normal THEN
            EXIT clp$process_proc_parameters;
          IFEND;
        WHILEND /echo_procedure_declaration/;
      IFEND;

      parameter_descrioption_table := #PTR (header^.parameter_description_table, proc_data^);
      clp$unbundle_pdt (parameter_descrioption_table, work_area, pdt, status);
      IF NOT status.normal THEN
        EXIT clp$process_proc_parameters;
      IFEND;

      check_parameters_procedure := NIL;

      evaluate_proc_parameters (header^.command_or_function_name, check_parameters_procedure);

    PROCEND handle_compiled_proc;
?? TITLE := 'handle_old_pdt', EJECT ??

    PROCEDURE [INLINE] handle_old_pdt;

      VAR
        extra_info_area: ^SEQ (REP clc$proc_pdt_info_area_size of cell),
        i: clt$parameter_number,
        ignore_application_type_present: boolean,
        old_pdt: clt$parameter_descriptor_table,
        parameter_area: ^SEQ (REP clc$max_proc_pdt_parameters of clt$parameter_descriptor),
        parameter_name_area: ^SEQ (REP clc$max_proc_pdt_param_names of clt$parameter_name_descriptor),
        proc_name_area: ^SEQ (REP clc$max_proc_names of ost$name),
        proc_names: ^clt$proc_names,
        symbolic_parameter_area: ^SEQ (REP clc$max_proc_pdt_parameters of clt$symbolic_parameter),
        symbolic_parameters: ^clt$symbolic_parameters,
        type_specification: ^clt$type_specification;


      NEXT proc_name_area IN work_area;
      NEXT parameter_name_area IN work_area;
      NEXT parameter_area IN work_area;
      NEXT symbolic_parameter_area IN work_area;
      NEXT extra_info_area IN work_area;
      IF (proc_name_area = NIL) OR (parameter_name_area = NIL) OR (parameter_area = NIL) OR
            (symbolic_parameter_area = NIL) OR (extra_info_area = NIL) THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT clp$process_proc_parameters;
      IFEND;

      clp$internal_generate_old_pdt ('PROC', ^get_proc_line, work_area, parse, proc_name_area^,
            parameter_name_area^, parameter_area^, symbolic_parameter_area^, extra_info_area^, proc_names,
            old_pdt, symbolic_parameters, status);
      IF NOT status.normal THEN
        EXIT clp$process_proc_parameters;
      IFEND;

      clp$set_input_line_parse (parse);

      clp$translate_pdt (old_pdt, FALSE, FALSE, NIL, NIL, NIL, work_area, ignore_application_type_present,
            pdt, status);
      IF NOT status.normal THEN
        EXIT clp$process_proc_parameters;
      IFEND;

      FOR i := 1 TO pdt.header^.number_of_parameters DO
        clp$convert_type_desc_to_spec (^pdt.type_descriptions^ [i], work_area, type_specification, status);
        IF NOT status.normal THEN
          EXIT clp$process_proc_parameters;
        IFEND;
        pdt.parameters^ [i].type_specification_size := #SIZE (type_specification^);
        pdt.type_descriptions^ [i].specification := type_specification;
      FOREND;

      evaluate_proc_parameters (proc_names^ [1], NIL);

    PROCEND handle_old_pdt;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    IF header <> NIL THEN
      handle_compiled_proc;
      RETURN;
    IFEND;


    REPEAT
      get_proc_line (parse, end_of_input, status);
      IF NOT status.normal THEN
        RETURN;
      ELSEIF end_of_input THEN
        IF command_or_function = clc$command THEN
          osp$set_status_abnormal ('CL', cle$expecting_proc, 'PROCEDURE', status);
        ELSE
          osp$set_status_abnormal ('CL', cle$expecting_proc, 'FUNCTION', status);
        IFEND;
        osp$append_status_parameter (osc$status_parameter_delimiter, 'end of input', status);
        RETURN;
      IFEND;
      clp$scan_non_space_lexical_unit (parse);
    UNTIL parse.unit.kind <> clc$lex_end_of_line;

    IF parse.unit.kind <> clc$lex_name THEN
      IF command_or_function = clc$command THEN
        osp$set_status_abnormal ('CL', cle$expecting_proc, 'PROCEDURE', status);
      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_proc, 'FUNCTION', status);
      IFEND;
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      RETURN;
    IFEND;
    #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
    IF command_or_function = clc$command THEN
      IF name = 'PROC' THEN
        old_style_proc := TRUE;
      ELSEIF name = 'PROCEDURE' THEN
        old_style_proc := FALSE;
      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_proc, 'PROCEDURE', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
        RETURN;
      IFEND;
    ELSEIF name = 'FUNCTION' THEN
      old_style_proc := FALSE;
    ELSE
      osp$set_status_abnormal ('CL', cle$expecting_proc, 'FUNCTION', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
      RETURN;
    IFEND;


    IF old_style_proc THEN
      handle_old_pdt;
      RETURN;
    IFEND;


    clp$scan_non_space_lexical_unit (parse);

    clp$internal_generate_pdt (command_or_function, ^get_proc_line, NIL, work_area, parse,
          command_or_function_name, ignore_aliases, ignore_availability, ignore_command_or_func_scope,
          ignore_command_log_option, parameter_descrioption_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$set_input_line_parse (parse);

    clp$unbundle_pdt (parameter_descrioption_table, work_area, pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    evaluate_proc_parameters (command_or_function_name, NIL);

  PROCEND clp$process_proc_parameters;

MODEND clm$process_proc_parameters;
*DECK DECK=CLM$PROCESS_REDO_OPERATION EXPAND=TRUE
?? RIGHT := 110 ??
MODULE clm$process_redo_operation;

{
{ PURPOSE:
{   This module contains the FAP that implements redo of SCL commands from
{   the terminal and supports function keys at the SCL level.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc clc$standard_file_names
*copyc lgt$log_read_activity
*copyc osd$virtual_address
*copyc ost$status
*copyc pmd$log_entries
*copyc pmd$system_log_interface
*copyc tut$input_ordinals
*copyc tut$subtable_pointers
?? POP ??
*copyc amp$access_method
*copyc amp$flush
*copyc amp$get_file_attributes
*copyc amp$get_next
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$put_next
*copyc amp$return
*copyc amp$rewind
*copyc amp$seek_direct
*copyc clp$read_variable
*copyc clp$scan_command_line
*copyc fsp$open_file
*copyc i#compare_collated
*copyc ifp$change_terminal_attributes
*copyc ifp$get_terminal_attributes
*copyc ifp$immediate_attribute_flush
*copyc ifp$store_term_conn_attributes
*copyc osv$lower_to_upper
*copyc pmp$load
*copyc pmp$load_from_library

  CONST
    cr = $CHAR (0d(16)),
    lf = $CHAR (0a(16)),
    crlf = cr CAT lf,
    max_commands = 200,
    max_text_length = 256, { An arbitrary limit imposed by Redo.
    input_buffer_length = 80; {minimum allowed by NAM/VE}

  TYPE
    action_requested = (control_action, find_line),
    subtable_pointers = record
      header_ptr: ^tut$header,
      input_ptr: ^tut$input,
      output_ptr: ^tut$output,
      init_ptr: ^tut$init,
    recend,
    tty_command = record
      size: 0 .. 255,
      value: string (50),
    recend;

{ The following code duplicates the definition of lgv$control_codes_to_quest_mark which resides in module
{ lgm$global_log_manager and so is not accessible by Redo.  Redo would use osv$control_codes_to_quest_mark,
{ but it incorrectly converts the top 128 ASCII charcters to question marks.

  VAR
    control_codes_to_quest_mark: string (256) := '????????????' CAT
          '???????????????????? !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTU' CAT
          'VWXYZ[\]^_`abcdefghijkl' CAT 'mnopqrstuvwxyz{|}~?' CAT $CHAR (128) CAT $CHAR (129) CAT
          $CHAR (130) CAT $CHAR (131) CAT $CHAR (132) CAT $CHAR (133) CAT $CHAR (134) CAT $CHAR (135) CAT
          $CHAR (136) CAT $CHAR (137) CAT $CHAR (138) CAT $CHAR (139) CAT $CHAR (140) CAT $CHAR (141) CAT
          $CHAR (142) CAT $CHAR (143) CAT $CHAR (144) CAT $CHAR (145) CAT $CHAR (146) CAT $CHAR (147) CAT
          $CHAR (148) CAT $CHAR (149) CAT $CHAR (150) CAT $CHAR (151) CAT $CHAR (152) CAT $CHAR (153) CAT
          $CHAR (154) CAT $CHAR (155) CAT $CHAR (156) CAT $CHAR (157) CAT $CHAR (158) CAT $CHAR (159) CAT
          $CHAR (160) CAT $CHAR (161) CAT $CHAR (162) CAT $CHAR (163) CAT $CHAR (164) CAT $CHAR (165) CAT
          $CHAR (166) CAT $CHAR (167) CAT $CHAR (168) CAT $CHAR (169) CAT $CHAR (170) CAT $CHAR (171) CAT
          $CHAR (172) CAT $CHAR (173) CAT $CHAR (174) CAT $CHAR (175) CAT $CHAR (176) CAT $CHAR (177) CAT
          $CHAR (178) CAT $CHAR (179) CAT $CHAR (180) CAT $CHAR (181) CAT $CHAR (182) CAT $CHAR (183) CAT
          $CHAR (184) CAT $CHAR (185) CAT $CHAR (186) CAT $CHAR (187) CAT $CHAR (188) CAT $CHAR (189) CAT
          $CHAR (190) CAT $CHAR (191) CAT $CHAR (192) CAT $CHAR (193) CAT $CHAR (194) CAT $CHAR (195) CAT
          $CHAR (196) CAT $CHAR (197) CAT $CHAR (198) CAT $CHAR (199) CAT $CHAR (200) CAT $CHAR (201) CAT
          $CHAR (202) CAT $CHAR (203) CAT $CHAR (204) CAT $CHAR (205) CAT $CHAR (206) CAT $CHAR (207) CAT
          $CHAR (208) CAT $CHAR (209) CAT $CHAR (210) CAT $CHAR (211) CAT $CHAR (212) CAT $CHAR (213) CAT
          $CHAR (214) CAT $CHAR (215) CAT $CHAR (216) CAT $CHAR (217) CAT $CHAR (218) CAT $CHAR (219) CAT
          $CHAR (220) CAT $CHAR (221) CAT $CHAR (222) CAT $CHAR (223) CAT $CHAR (224) CAT $CHAR (225) CAT
          $CHAR (226) CAT $CHAR (227) CAT $CHAR (228) CAT $CHAR (229) CAT $CHAR (230) CAT $CHAR (231) CAT
          $CHAR (232) CAT $CHAR (233) CAT $CHAR (234) CAT $CHAR (235) CAT $CHAR (236) CAT $CHAR (237) CAT
          $CHAR (238) CAT $CHAR (239) CAT $CHAR (240) CAT $CHAR (241) CAT $CHAR (242) CAT $CHAR (243) CAT
          $CHAR (244) CAT $CHAR (245) CAT $CHAR (246) CAT $CHAR (247) CAT $CHAR (248) CAT $CHAR (249) CAT
          $CHAR (250) CAT $CHAR (251) CAT $CHAR (252) CAT $CHAR (253) CAT $CHAR (254) CAT $CHAR (255);

  VAR
    backspace: tty_command,
    bkw_code: tty_command,
    bkw_word: ^char := NIL,
    clr: ^tty_command := NIL,
    clr_up: ^char := NIL,
    commands: ^array [1 .. max_commands] of ost$string := NIL,
    continued_command: boolean := FALSE,
    continued_marker: string (1) := '>',
    cr_delim_key_pushed: boolean := FALSE,
    cr_only: tty_command,
    current_column: integer,
    del_char: ^char := NIL,
    del_word: ^char := NIL,
    device_columns: integer, {number of columns on device
    device_input_length: amt$transfer_count,
    device_input_ndx: integer,
    device_overstrike_high: integer,
    device_overstrike_low: integer,
    device_start_input_search: integer,
    echo_off: array [1 .. 1] of ift$terminal_attribute := [[ifc$echoplex, FALSE]],
    echo_on: array [1 .. 1] of ift$terminal_attribute := [[ifc$echoplex, TRUE]],
    file_id: amt$file_identifier,
    full_duplex: boolean,
    full_duplex_on: ^boolean := NIL,
    fwd_word: ^char := NIL,
    has_cr_delimiter: boolean,
    ibm_3270: boolean := FALSE,
    input_buffer: string (input_buffer_length),
    in_file_id: amt$file_identifier,
    in_ptr: ^integer := NIL,
    insert_mode: boolean,
    insert_mode_on: ^boolean := NIL,
    insert_toggle: ^char := NIL,
    interrupt_char: ^char := NIL,
    job_log_file_id: amt$file_identifier,
    job_log_last_eoi_p: ^amt$file_byte_address := NIL,
    lfn: amt$local_file_name,
    log_ptr: amt$segment_pointer,
    move_to_end: ^char := NIL,
    move_to_start: ^char := NIL,
    non_xparent_file_id: amt$file_identifier,
    out_ptr: ^integer := NIL,
    private_reset_counter: integer,
    redo_is_shutdown:  ^boolean := NIL,
    redo_setup_done : [STATIC] boolean := FALSE,
    reset_counter: ^integer := NIL,
    reset_tdu: ^boolean := NIL,
    secondary_redo: boolean,
    set_line_mode_p: ^ost$string := NIL,
    set_screen_mode_p: ^ost$string := NIL,
    software_insert_default: boolean,
    software_insert_mode: boolean,
    static_shutdown: boolean := TRUE,
    status: ost$status,
    subtable: ^subtable_pointers := NIL,
    sysstat: ost$status,
    tt_header: ^tut$header := NIL,
    tt_init: ^tut$init := NIL,
    tt_input: ^tut$input := NIL,
    tt_input_upperbound: integer,
    tt_output: ^tut$output := NIL,
    up_arrow_code: tty_command;

?? TITLE := 'clp$redo_operation', EJECT ??

  PROCEDURE [XDCL] clp$redo_operation
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      command_ptr: ^string (65535),
      file_id_temporary: amt$file_identifier,
      i: integer,
      first_time: [STATIC] boolean := TRUE;

    IF first_time THEN
      initialize_redo;

{   Bullet-proofing in case somehow the segment access file for the shared
{   redo log could not be opened.

      IF redo_is_shutdown = NIL THEN
        redo_is_shutdown := ^static_shutdown;
      IFEND;
      IF (NOT redo_is_shutdown^) AND (NOT secondary_redo) THEN

{     Go to screen mode and back to line mode. This is necessary on some
{     terminals to download function keys, set auto-CR on function keys, etc.

        setup_terminal_for_redo;
        setup_terminal_for_line_mode;
      IFEND;
      first_time := FALSE;
    IFEND;

  /read_command_from_terminal/
    WHILE TRUE DO

      IF ((redo_is_shutdown = NIL) OR redo_is_shutdown^) AND
            ((reset_tdu = NIL) OR (NOT reset_tdu^)) THEN

{ Redo is in shutdown mode and this is not an attempt to correct the terminal name.  Do no additional
{ processing of command input.  Amp$access_method must still be called so that commands may be entered in the
{ new task.

        amp$access_method (file_identifier, call_block, layer_number, status);
        RETURN;
      IFEND;

{An external agent (clm$enable_redo) sets the first item in the redo shared
{segment if the terminal definition information must be reestablished. Each
{copy of Redo (one in each active task) has a private_reset_counter that
{shows how many terminal type changes had been made when it loaded its
{set of the terminal definitions. If a child copy loads a new set, the
{shared counter will no longer match the parent's private value and thus
{the parent will know to reload the definitions.

      IF reset_tdu^ THEN
        IF in_ptr^ < 0 THEN
          in_ptr^ := 0;
        IFEND;
        full_duplex := full_duplex_on^;
        insert_mode := insert_mode_on^;
        software_insert_mode := insert_mode_on^;
        software_insert_default := insert_mode_on^;
        lfn := 'OUTPUT';
        IF full_duplex THEN
          ifp$change_terminal_attributes (lfn, echo_on, sysstat);
        ELSE
          ifp$change_terminal_attributes (lfn, echo_off, sysstat);
        IFEND;
        establish_terminal_commands;
        reset_counter^ := reset_counter^ +1;
        private_reset_counter := reset_counter^;
      ELSEIF reset_counter^ <> private_reset_counter THEN
        establish_terminal_commands;
        private_reset_counter := reset_counter^;
      IFEND;
      amp$access_method (file_identifier, call_block, layer_number, status);
      IF call_block.operation = amc$get_next_req THEN
        command_ptr := call_block.getn.working_storage_area;
        IF (call_block.getn.transfer_count^ = 0) OR redo_is_shutdown^ THEN
          RETURN;
        IFEND;

{   Check for control code input or BKW code at end of input line.

      /check_for_redo_call/
        BEGIN
          IF command_ptr^ (1) < ' ' THEN
            process_control_codes (call_block, control_action);
            EXIT /check_for_redo_call/;
          ELSEIF call_block.getn.transfer_count^ >= bkw_code.size THEN
            IF command_ptr^ (call_block.getn.transfer_count^ -bkw_code.size + 1, bkw_code.size) =
                  bkw_code.value (1, bkw_code.size) THEN
              call_block.getn.transfer_count^ := call_block.getn.transfer_count^ -bkw_code.size;
              process_control_codes (call_block, find_line);
              EXIT /check_for_redo_call/;
            IFEND;
          IFEND;
          IF call_block.getn.transfer_count^ >= up_arrow_code.size THEN
            IF command_ptr^ (call_block.getn.transfer_count^ -up_arrow_code.size + 1,
                  up_arrow_code.size) = up_arrow_code.value (1, up_arrow_code.size) THEN
              IF call_block.getn.transfer_count^ = up_arrow_code.size THEN
                process_control_codes (call_block, control_action);
              ELSE
                call_block.getn.transfer_count^ := call_block.getn.transfer_count^ -up_arrow_code.size;
                process_control_codes (call_block, find_line);
              IFEND;
            IFEND;
          IFEND;
        END /check_for_redo_call/;
        IF software_insert_mode OR insert_mode THEN
          IF redo_setup_done THEN
             turn_insert_mode_off;
             setup_terminal_for_line_mode;
             redo_setup_done := FALSE;
          IFEND;
        IFEND;

        IF call_block.getn.transfer_count^ = 0 THEN
          CYCLE /read_command_from_terminal/;
        IFEND;
      IFEND;
      RETURN;
    WHILEND /read_command_from_terminal/;

  PROCEND clp$redo_operation;
?? TITLE := 'convert_ordinal_to_ascii', EJECT ??

  PROCEDURE convert_ordinal_to_ascii
    (    ordinal: tut$input_ordinals;
     VAR ascii_seq: tty_command);

{Given a tuc$in_xxxx ordinal, this procedure will return the ascii
{codes sent by the terminal representing that sequence. If no
{sequence is defined for the terminal in the TDU file, ascii_seq.size
{will be zero. It will also be zero if the sequence has no unique
{mapping (as is the case for tuc$overstrike).

    CONST
      single_action_range = $CHAR (3),
      range = $CHAR (2),
      list = $CHAR (1),
      fail = $CHAR (0);

    VAR
      count: integer,
      cur_id: integer,
      i: integer,
      id: integer,
      j: integer,
      next_char: integer,
      num: integer,
      predecessor: integer,
      reversed_codes: string (50);


{   Get biased representation of ordinal in tt_input table.

    ascii_seq.size := 0;
    id := 16383 - $INTEGER (ordinal);
    i := 1;
    num := 1;

  /search_table/
    WHILE (i < tt_input_upperbound) AND (id <> 1) DO
      CASE tt_input^ [i] OF
      = single_action_range =
        predecessor := i;
        i := i + 5;
      = range =

{      IF reached most recently matched entry without finding pointer to it,
{      then presumably, the pointer points at one of the physically preceding
{      entries. Back up one and try to find it.

        IF i = id THEN {step back one leaf node}
          id := predecessor;
          i := 1;
          CYCLE /search_table/;
        IFEND;

        count := 2 * ($INTEGER (tt_input^ [i + 2]) - $INTEGER (tt_input^ [i + 1]));
        j := 0;
        WHILE j <= count DO
          cur_id := ($INTEGER (tt_input^ [i + 3 + j]) * 128) + $INTEGER (tt_input^ [i + 4 + j]);
          IF cur_id = id THEN {ordinal or pointer to previous entry found}
            reversed_codes (num) := $CHAR ($INTEGER (tt_input^ [i + 1]) + (j DIV 2));
            num := num + 1;
            id := i; {now look for something pointing to here}
            i := 1;
            CYCLE /search_table/;
          IFEND;
          j := j + 2;
        WHILEND;
        predecessor := i;
        i := i + 5 + count;
      = list =
        j := i; {save start of list location}

{      IF reached most recently matched entry without finding pointer to it,
{      then presumably, the pointer points at one of the physically preceding
{      entries. Back up one and try to find it.

        IF i = id THEN {step back one leaf node}
          id := predecessor;
          i := 1;
          CYCLE /search_table/;
        IFEND;

        count := $INTEGER (tt_input^ [i + 1]);
        i := i + 2;
        REPEAT
          cur_id := ($INTEGER (tt_input^ [i + 1]) * 128) + $INTEGER (tt_input^ [i + 2]);
          IF cur_id = id THEN
            reversed_codes (num) := tt_input^ [i];
            num := num + 1;
            id := j;
            i := 1;
            CYCLE /search_table/;
          ELSE
            i := i + 3;
            count := count - 1;
          IFEND;
        UNTIL count = 0;
        predecessor := j;
      = fail =

{      If reached most recently matched entry without finding pointer to it,
{      then presumably, the pointer points at one of the physically preceding
{      entries. Back up one and try to find it.

        IF i = id THEN {step back one leaf node}
          id := predecessor;
          i := 1;
          CYCLE /search_table/;
        IFEND;
        predecessor := i;
        i := i + 1;
      CASEND;
    WHILEND /search_table/;
    ascii_seq.size := num - 1;
    FOR i := 1 TO num - 1 DO
      ascii_seq.value (i) := reversed_codes (num - i);
    FOREND;

  PROCEND convert_ordinal_to_ascii;
?? TITLE := 'establish_terminal_commands', EJECT ??

  PROCEDURE establish_terminal_commands;

    TYPE
      ptr_changer = record
        case 0 .. 4 of
        = 0 =
          cell_ptr: ^cell,
        = 1 =
          input_ptr: ^tut$input,
        = 2 =
          output_ptr: ^tut$output,
        = 3 =
          header_ptr: ^tut$header,
        = 4 =
          init_ptr: ^tut$init,
        casend,
      recend;

    VAR
      data_name: ost$name,
      default_attributes: [STATIC] array [1 .. 2] of ift$terminal_attribute :=
            [[ifc$terminal_model, [ * , * ]], [ifc$page_width, * ]],
      fix_ptr: ptr_changer,
      len: integer,
      lfn: amt$local_file_name,
      start: integer;

    lfn := 'OUTPUT';
    default_attributes [1].key := ifc$terminal_model;
    ifp$get_terminal_attributes (lfn, default_attributes, status);
    IF NOT status.normal THEN
      shutdown_redo;
      RETURN;
    IFEND;
    device_columns := default_attributes [2].page_width;

    RESET log_ptr.sequence_pointer;
    NEXT reset_tdu IN log_ptr.sequence_pointer;
    NEXT full_duplex_on IN log_ptr.sequence_pointer;
    NEXT insert_mode_on IN log_ptr.sequence_pointer;
    NEXT redo_is_shutdown IN log_ptr.sequence_pointer;
    NEXT reset_counter IN log_ptr.sequence_pointer;
    NEXT fwd_word IN log_ptr.sequence_pointer;
    NEXT bkw_word IN log_ptr.sequence_pointer;
    NEXT del_word IN log_ptr.sequence_pointer;
    NEXT del_char IN log_ptr.sequence_pointer;
    NEXT clr_up IN log_ptr.sequence_pointer;
    NEXT move_to_end IN log_ptr.sequence_pointer;
    NEXT move_to_start IN log_ptr.sequence_pointer;
    NEXT insert_toggle IN log_ptr.sequence_pointer;
    NEXT interrupt_char IN log_ptr.sequence_pointer;
    NEXT clr IN log_ptr.sequence_pointer;
    NEXT subtable IN log_ptr.sequence_pointer;
    NEXT job_log_last_eoi_p IN log_ptr.sequence_pointer;
    NEXT set_line_mode_p IN log_ptr.sequence_pointer;
    NEXT set_screen_mode_p IN log_ptr.sequence_pointer;
    NEXT in_ptr IN log_ptr.sequence_pointer;
    NEXT out_ptr IN log_ptr.sequence_pointer;
    NEXT commands IN log_ptr.sequence_pointer;

{  Check to see if a copy of Redo is already running. This knowledge is used
{  to avoid reloading the TDU module, issuing screen/line mode transition, etc.

    secondary_redo := FALSE;
    IF in_ptr^ = 0 THEN
      in_ptr^ := 1;
      out_ptr^ := 1;
      redo_is_shutdown^ := FALSE;
    ELSEIF NOT reset_tdu^ THEN
      IF in_ptr^ >= 0 THEN
        secondary_redo := TRUE;
      IFEND;
    IFEND;

    reset_tdu^ := FALSE;
    IF NOT secondary_redo THEN
      data_name := 'CSV$';
      data_name (5, * ) := default_attributes [1].terminal_model.
            value (1, default_attributes [1].terminal_model.size);
      ibm_3270 := (default_attributes [1].terminal_model.size >= 8) AND
            (default_attributes [1].terminal_model.value (1, 8) = 'IBM_3270');
      IF (default_attributes [1].terminal_model.size = 0) OR ibm_3270 THEN
        shutdown_redo;
      ELSE
        load_tdu_module (data_name);
      IFEND;
      IF redo_is_shutdown^ THEN
        RETURN;
      IFEND;
      job_log_last_eoi_p^ := 0;
    ELSE {use tables previously loaded by initial Redo}
      fix_ptr.input_ptr := subtable^.input_ptr;
      fix_ptr.cell_ptr := #ADDRESS (#RING (^tt_input), #SEGMENT (subtable), #OFFSET (subtable^.input_ptr));
      tt_input := fix_ptr.input_ptr;
      fix_ptr.output_ptr := subtable^.output_ptr;
      fix_ptr.cell_ptr := #ADDRESS (#RING (^tt_output), #SEGMENT (subtable), #OFFSET (subtable^.output_ptr));
      tt_output := fix_ptr.output_ptr;
      fix_ptr.header_ptr := subtable^.header_ptr;
      fix_ptr.cell_ptr := #ADDRESS (#RING (^tt_header), #SEGMENT (subtable), #OFFSET (subtable^.header_ptr));
      tt_header := fix_ptr.header_ptr;
      fix_ptr.init_ptr := subtable^.init_ptr;
      fix_ptr.cell_ptr := #ADDRESS (#RING (^tt_init), #SEGMENT (subtable), #OFFSET (subtable^.init_ptr));
      tt_init := fix_ptr.init_ptr;
    IFEND;

    tt_input_upperbound := UPPERBOUND (tt_input^);
    IF ($INTEGER (tt_input^ [1]) = 3) AND {must be a single action range}
          ((16383 - (($INTEGER (tt_input^ [4]) * 128) + $INTEGER (tt_input^ [5]))) =
          $INTEGER (tuc$in_overstrike)) THEN
      device_overstrike_low := $INTEGER (tt_input^ [2]); {low bound of overstrikes}
      device_overstrike_high := $INTEGER (tt_input^ [3]);
      device_start_input_search := 6; {always skip first node}
    ELSE
      device_overstrike_low := 0;
      device_overstrike_high := 0;
      device_start_input_search := 1; {must start trie search at beginning}
    IFEND;

    IF device_columns = 0 THEN
      device_columns := tt_header^.screen_size [tuc$minimum_size_table].columns;
    IFEND;
    device_columns := device_columns - 3; {space for continued marker}
    convert_ordinal_to_ascii (tuc$in_backspace, backspace);
    IF backspace.size = 0 THEN {Terminal has no backspace code defined}
      convert_ordinal_to_ascii (tuc$in_cursor_left, backspace);
    IFEND;
    cr_only.size := tt_output^.ordinals [$INTEGER (tuc$out_return)].length;
    start := tt_output^.ordinals [$INTEGER (tuc$out_return)].start;
    cr_only.value := tt_output^.chars (start, cr_only.size);
    IF cr_only.size = 0 THEN {assume an ASCII CR will do the job}
      cr_only.size := 1;
      cr_only.value := cr;
    IFEND;
    clr^.size := tt_output^.ordinals [$INTEGER (tuc$out_erase_line_bol)].length;
    IF clr^.size <> 0 THEN
      start := tt_output^.ordinals [$INTEGER (tuc$out_erase_line_bol)].start;
      clr^.value (1, * ) := tt_output^.chars (start, clr^.size);
    ELSEIF tt_output^.ordinals [$INTEGER (tuc$out_erase_line_stay)].length <> 0 THEN
      clr^.size := tt_output^.ordinals [$INTEGER (tuc$out_erase_line_stay)].length;
      start := tt_output^.ordinals [$INTEGER (tuc$out_erase_line_stay)].start;
      clr^.value (1, * ) := tt_output^.chars (start, clr^.size);
      clr^.value (clr^.size + 1, * ) := cr_only.value (1, cr_only.size);
      clr^.size := clr^.size + cr_only.size;
    ELSEIF tt_output^.ordinals [$INTEGER (tuc$out_erase_end_of_line)].length <> 0 THEN
      clr^.value (1, * ) := cr_only.value (1, cr_only.size);
      len := tt_output^.ordinals [$INTEGER (tuc$out_erase_end_of_line)].length;
      start := tt_output^.ordinals [$INTEGER (tuc$out_erase_end_of_line)].start;
      clr^.value (cr_only.size + 1, * ) := tt_output^.chars (start, len);
      clr^.size := cr_only.size + len;
    IFEND;

{ Use BKW key if defined, otherwise use up arrow key.

    convert_ordinal_to_ascii (tuc$in_bkw, bkw_code);
    convert_ordinal_to_ascii (tuc$in_cursor_up, up_arrow_code);
    IF bkw_code.size = 0 THEN
      bkw_code := up_arrow_code;
    IFEND;

  PROCEND establish_terminal_commands;
?? TITLE := 'get_key', EJECT ??

  PROCEDURE get_key
    (VAR input_character: char;
     VAR ordinal: 0 .. tuc$in_max_ordinal);

{ get_key reads characters from the terminal and converts them
{ to an ordinal using the TDU table for the terminal.

    CONST
      single_action_range = $CHAR (3),
      range = $CHAR (2),
      list = $CHAR (1),
      fail = $CHAR (0);

    VAR
      action_found: boolean,
      ba: amt$file_byte_address,
      current_char: char,
      fpos: amt$file_position,
      list_counter: 0 .. 255,
      next_char: integer,
      sysstat: ost$status;

?? NEWTITLE := 'next_action', EJECT ??

    PROCEDURE [INLINE] next_action
      (    action_ndx: integer;
       VAR action_is_found: boolean;
       VAR action_ordinal: 0 .. tuc$in_max_ordinal;
       VAR next_character: integer);

      VAR
        action_id: integer;


      action_is_found := TRUE;
      action_id := ($INTEGER (tt_input^ [action_ndx]) * 128) + $INTEGER (tt_input^ [SUCC (action_ndx)]);
      IF action_id > tt_input_upperbound THEN { ordinal }
        action_ordinal := 0 - (action_id - 16383);
      ELSE { offset back into input array }
        next_character := action_id;
      IFEND;

    PROCEND next_action;

?? OLDTITLE, EJECT ??

{ ******  Map the input character in from the device, via terminal tables  ******

    ordinal := $INTEGER (tuc$in_no_input);
    input_character := $CHAR (0);
    next_char := 1; { start trie search at this point }

  /fill_ordinal/
    REPEAT { loop for enough chars to fill ordinal }

{ get character

      IF device_input_ndx < device_input_length THEN
        device_input_ndx := SUCC (device_input_ndx);
      ELSE
        amp$get_next (in_file_id, ^input_buffer, input_buffer_length, device_input_length, ba, fpos, sysstat);
        device_input_ndx := 1;
        IF device_input_length = 0 THEN
          IF cr_delim_key_pushed THEN
            cr_delim_key_pushed := FALSE;
            CYCLE /fill_ordinal/;
          IFEND;
          ordinal := $INTEGER (tuc$in_next); { 'reserved' ordinal for end-of-transctn}
          device_input_length := input_buffer_length; { force a read next time }
          device_input_ndx := device_input_length;
          EXIT /fill_ordinal/;
        IFEND;
      IFEND;
      current_char := input_buffer (device_input_ndx);

      IF (next_char = 1) AND ($INTEGER (current_char) >= device_overstrike_low) AND
            ($INTEGER (current_char) <= device_overstrike_high) THEN
        ordinal := $INTEGER (tuc$in_overstrike);
        input_character := current_char;
      ELSE {do trie search}
        action_found := FALSE;
        REPEAT { search for this char in the table }
          CASE tt_input^ [next_char] OF
          = single_action_range =
            IF (current_char >= tt_input^ [SUCC (next_char)]) AND (current_char <= tt_input^ [next_char + 2])
                  THEN
              next_action (next_char + 3, action_found, ordinal, next_char);
            ELSE
              next_char := next_char + 5;
            IFEND;
          = range =
            IF (current_char >= tt_input^ [SUCC (next_char)]) AND (current_char <= tt_input^ [next_char + 2])
                  THEN
              next_action (next_char + 3 + (($INTEGER (current_char) -
                    $INTEGER (tt_input^ [SUCC (next_char)])) * 2), action_found, ordinal, next_char);
            ELSE
              next_char := next_char + 3 + (2 * (1 + ($INTEGER (tt_input^ [next_char + 2]) -
                    $INTEGER (tt_input^ [SUCC (next_char)]))));
            IFEND;
          = list =
            list_counter := $INTEGER (tt_input^ [SUCC (next_char)]);
            next_char := next_char + 2;

          /list_loop/
            REPEAT
              IF current_char = tt_input^ [next_char] THEN
                next_action (SUCC (next_char), action_found, ordinal, next_char);
                EXIT /list_loop/;
              IFEND;
              next_char := next_char + 3;
              list_counter := PRED (list_counter);
            UNTIL list_counter = 0;
          = fail =
            ordinal := $INTEGER (tuc$in_cursor_pos_begin); {do more syntax analysis }
            EXIT /fill_ordinal/;
          ELSE
            setup_terminal_for_line_mode;
            RETURN;
          CASEND;
        UNTIL action_found;
      IFEND; {do trie search}
    UNTIL ordinal <> $INTEGER (tuc$in_no_input); {/fill_ordinal/}
    IF ordinal = $INTEGER (tuc$in_overstrike) THEN
      input_character := current_char;
    IFEND;

  PROCEND get_key;
?? TITLE := 'initialize_redo', EJECT ??

  PROCEDURE initialize_redo;

    VAR
      command_attributes: [STATIC] array [1 .. 1] of amt$get_item := [[ * , amc$user_info, ' ']],
      contains_data: boolean,
      file_attachment: [STATIC] array [1 .. 2] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes, $fst$file_access_options [fsc$read]],
            [fsc$specific_share_modes, $fst$file_access_options
            [fsc$append, fsc$modify, fsc$shorten, fsc$read]]], [fsc$private_read, FALSE]],
      i: integer,
      lfn: amt$local_file_name,
      local_file: boolean,
      old_file: boolean,
      open_attributes: [STATIC] array [1 .. 1] of amt$access_selection := [[amc$preset_value, 0]],
      file: string (40),
      ring_attributes: [STATIC] array [1 .. 1] of amt$access_selection :=
            [[amc$ring_attributes, [osc$user_ring_2, osc$user_ring_2, osc$user_ring_2]]],
      seg_file_id: amt$file_identifier,
      seg_file_ring_attributes: amt$ring_attributes;


{  Setup the input and output files used by Redo.
{  Create the normal use INPUT file connection and an extra one for
{  doing a zero timeout read to force out terminal attributes.
{  Create a transparent and non-transparent connection to the OUTPUT file
{  so that the non-transparent connection can be used to get out of
{  transparent mode when exiting Redo.
{  Open the log file as a source for previous commands.

    lfn := 'INPUT';
    amp$open (lfn, amc$record, ^open_attributes, in_file_id, sysstat);
    IF NOT sysstat.normal THEN
      shutdown_redo;
      RETURN;
    IFEND;
    lfn := 'OUTPUT';
    amp$open (lfn, amc$record, NIL, file_id, sysstat);
    IF NOT sysstat.normal THEN
      shutdown_redo;
      RETURN;
    IFEND;
    amp$open (lfn, amc$record, NIL, non_xparent_file_id, sysstat);
    IF NOT sysstat.normal THEN
      shutdown_redo;
      RETURN;
    IFEND;

{Extract Redo's parameters from the user_info file attribute of COMMAND.

    lfn := 'COMMAND';
    amp$get_file_attributes (lfn, command_attributes, local_file, old_file, contains_data, status);
    IF NOT status.normal THEN
      shutdown_redo;
      RETURN;
    IFEND;
    IF (command_attributes [1].source = amc$undefined_attribute) OR (command_attributes [1].user_info (1) <>
          'F') THEN
      full_duplex := FALSE;
    ELSE
      full_duplex := TRUE;
    IFEND;
    IF (command_attributes [1].source = amc$undefined_attribute) OR (command_attributes [1].user_info (2) <>
          'I') THEN
      software_insert_default := FALSE;
      software_insert_mode := FALSE;
    ELSE
      software_insert_default := TRUE;
      software_insert_mode := TRUE;
    IFEND;

{ Setup the shared segment access file for inter-task communication.

    lfn := 'clf$redo_log';
    amp$open (lfn, amc$segment, ^ring_attributes, seg_file_id, sysstat);
    IF NOT sysstat.normal THEN
      shutdown_redo;
      RETURN;
    IFEND;
    amp$get_segment_pointer (seg_file_id, amc$sequence_pointer, log_ptr, sysstat);
    IF NOT sysstat.normal THEN
      shutdown_redo;
      RETURN;
    IFEND;

    fsp$open_file (clc$job_log, amc$record, ^file_attachment, {default_creation_attributes} NIL,
          {mandated_creation_attributes} NIL, {attribute_validation} NIL, {attribute_override} NIL,
          job_log_file_id, sysstat);
    IF NOT sysstat.normal THEN
      shutdown_redo;
      RETURN;
    IFEND;

    establish_terminal_commands;

  PROCEND initialize_redo;
?? TITLE := 'load_TDU_module', EJECT ??

  PROCEDURE load_tdu_module
    (    data_name: ost$name);

    VAR
      appl_strings: ^tut$appl_string_pointer,
      data_address: pmt$loaded_address,
      dest_string: tut$application_name,
      i: integer,
      len: integer,
      lfn: amt$local_file_name,
      read_execute_attribs: [STATIC] array [1 .. 1] of amt$access_selection :=
            [[amc$access_mode, $pft$usage_selections [pfc$read, pfc$execute]]],
      seg_file_id: amt$file_identifier,
      seg_ptr: amt$segment_pointer,
      tt_subtable_pointers: ^tut$subtable_pointers;


{Load the TDU module for the terminal type selected by the user.

    pmp$load (data_name, pmc$data_address, data_address, status);
    IF NOT status.normal THEN
      clp$scan_command_line ('attf $system.tdu.terminal_definitions ' CAT 'clf$tdu_library', sysstat);
      IF NOT sysstat.normal THEN
        shutdown_redo;
        RETURN;
      IFEND;
      lfn := 'CLF$TDU_LIBRARY';
      amp$return (lfn, sysstat);
      amp$open (lfn, amc$segment, ^read_execute_attribs, seg_file_id, sysstat);
      IF NOT sysstat.normal THEN
        shutdown_redo;
        RETURN;
      IFEND;
      amp$get_segment_pointer (seg_file_id, amc$sequence_pointer, seg_ptr, sysstat);
      IF NOT sysstat.normal THEN
        shutdown_redo;
        RETURN;
      IFEND;
      pmp$load_from_library (data_name, #RING (^data_name), 0, pmc$data_address, seg_ptr.sequence_pointer,
            lfn, data_address, status);
      IF NOT status.normal THEN
        shutdown_redo;
        RETURN;
      IFEND;
    IFEND;

    tt_subtable_pointers := data_address.pointer_to_data;
    len := STRLENGTH (tt_subtable_pointers^.output^.chars);
    NEXT tt_output: [len] IN log_ptr.sequence_pointer;
    tt_output^ := tt_subtable_pointers^.output^;
    subtable^.output_ptr := tt_output;
    len := UPPERBOUND (tt_subtable_pointers^.input^);
    NEXT tt_input: [1 .. len] IN log_ptr.sequence_pointer;
    tt_input^ := tt_subtable_pointers^.input^;
    subtable^.input_ptr := tt_input;
    NEXT tt_header IN log_ptr.sequence_pointer;
    tt_header^ := tt_subtable_pointers^.header^;
    subtable^.header_ptr := tt_header;
    len := STRLENGTH (tt_subtable_pointers^.init^.chars);
    NEXT tt_init: [len] IN log_ptr.sequence_pointer;
    tt_init^ := tt_subtable_pointers^.init^;
    subtable^.init_ptr := tt_init;
    set_line_mode_p^.size := 0;
    set_screen_mode_p^.size := 0;
    fwd_word^ := $CHAR (06(16));
    bkw_word^ := $CHAR (02(16));
    del_word^ := $CHAR (04(16));
    del_char^ := $CHAR (7F(16));
    clr_up^ := $CHAR (15(16));
    move_to_end^ := $CHAR (05(16));
    move_to_start^ := $CHAR (16(16));
    insert_toggle^ := $CHAR (01(16));
    interrupt_char^ := $CHAR (14(16));
    appl_strings := tt_subtable_pointers^.appl_string_pointer;
    FOR i := 1 TO UPPERBOUND (appl_strings^) DO
      #TRANSLATE (osv$lower_to_upper, appl_strings^ [i].name, dest_string);
      IF dest_string = 'REDO_FORWARD_WORD' THEN
        fwd_word^ := tt_subtable_pointers^.appl_string_char^ (appl_strings^ [i].start);
      ELSEIF dest_string = 'REDO_BACKWARD_WORD' THEN
        bkw_word^ := tt_subtable_pointers^.appl_string_char^ (appl_strings^ [i].start);
      ELSEIF dest_string = 'REDO_DELETE_WORD' THEN
        del_word^ := tt_subtable_pointers^.appl_string_char^ (appl_strings^ [i].start);
      ELSEIF dest_string = 'REDO_DELETE_CHARACTER' THEN
        del_char^ := tt_subtable_pointers^.appl_string_char^ (appl_strings^ [i].start);
      ELSEIF dest_string = 'REDO_CLEAR_TO_CURSOR' THEN
        clr_up^ := tt_subtable_pointers^.appl_string_char^ (appl_strings^ [i].start);
      ELSEIF dest_string = 'REDO_CURSOR_TO_END' THEN
        move_to_end^ := tt_subtable_pointers^.appl_string_char^ (appl_strings^ [i].start);
      ELSEIF dest_string = 'REDO_CURSOR_TO_START' THEN
        move_to_start^ := tt_subtable_pointers^.appl_string_char^ (appl_strings^ [i].start);
      ELSEIF dest_string = 'REDO_INSERT_MODE_TOGGLE' THEN
        insert_toggle^ := tt_subtable_pointers^.appl_string_char^ (appl_strings^ [i].start);
      ELSEIF dest_string = 'REDO_INTERRUPT' THEN
        interrupt_char^ := tt_subtable_pointers^.appl_string_char^ (appl_strings^ [i].start);
      ELSEIF dest_string = 'REDO_SET_LINE_MODE' THEN
        set_line_mode_p^.value := tt_subtable_pointers^.appl_string_char^
              (appl_strings^ [i].start, appl_strings^ [i].length);
        set_line_mode_p^.size := appl_strings^ [i].length;
        IF appl_strings^ [i].length > 256 THEN
          set_line_mode_p^.size := 0;
        IFEND;
      ELSEIF dest_string = 'REDO_SET_SCREEN_MODE' THEN
        set_screen_mode_p^.value := tt_subtable_pointers^.appl_string_char^
              (appl_strings^ [i].start, appl_strings^ [i].length);
        set_screen_mode_p^.size := appl_strings^ [i].length;
        IF appl_strings^ [i].length > 256 THEN
          set_screen_mode_p^.size := 0;
        IFEND;
      IFEND;
    FOREND;

  PROCEND load_tdu_module;
?? TITLE := 'process_control_codes', EJECT ??

  PROCEDURE process_control_codes
    (    call_block: amt$call_block,
         action: action_requested);

    VAR
      ba: amt$file_byte_address,
      cell_ptr: ^cell,
      cmd_shown: 0 .. max_commands,
      column: integer,
      command: ost$string,
      command_string: string (max_text_length),
      count: amt$transfer_count,
      cr_lf: [STATIC] string (2) := crlf,
      in_transparent_mode: boolean,
      input_character: char,
      key_number: integer,
      key_string: string (4),
      left_column: integer,
      len: ^ost$string_size,
      m: integer,
      n: integer,
      no_fkey: [STATIC] string (25) := 'Function key not defined.',
      no_str: [STATIC] string (39) := 'Function key must be a string variable.',
      number_of_commands: integer,
      ordinal: 0 .. tuc$in_max_ordinal,
      scl_word_charset: [STATIC] set of char := ['#', '$', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
            '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S',
            'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '[', '\', ']', '^', '_', '`', 'a', 'b', 'c', 'd', 'e', 'f',
            'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y',
            'z', '{', '|', '}', '~'],
      string_ptr: ^string (max_text_length),
      string_ptr1: ^string (max_text_length),
      temp_string: string (max_text_length),
      v: clt$variable_reference;

?? NEWTITLE := 'backward_word', EJECT ??

    PROCEDURE backward_word;

      VAR
        i: 0 .. 1023,
        original_column: 0 .. 1023;


      IF column = 1 THEN
        left_column := 1;
        display_command;
        carriage_return;
        RETURN;
      IFEND;
      original_column := column;
      column := column - 1;

{  If character to left of cursor is a non-word character, skip it
{  and all preceding non-word characters until a word character or column
{  one is reached.

    /skip_non_word_characters/
      WHILE TRUE DO
        IF command.value (column) IN scl_word_charset THEN
          EXIT /skip_non_word_characters/;
        IFEND;
        column := column - 1;
        IF column = 0 THEN
          column := 1;
          left_column := 1;
          EXIT /skip_non_word_characters/;
        IFEND;
      WHILEND /skip_non_word_characters/;

{     If character is a word character, skip it and
{     all preceding word characters until a non-word character or column
{     one is found.

    /skip_back_over_word/
      WHILE TRUE DO
        column := column - 1;
        IF column = 0 THEN
          column := 1;
          left_column := 1;
          EXIT /skip_back_over_word/;
        IFEND;
        IF NOT (command.value (column) IN scl_word_charset) THEN
          column := column + 1;
          EXIT /skip_back_over_word/;
        IFEND;
      WHILEND /skip_back_over_word/;
      IF column < left_column THEN
        left_column := column - 20;
        display_command;
        move_cursor_to_column;
      ELSE
        FOR i := 1 TO (original_column - column) DO

{Use one character BS code to speed up cursor motion on ANSI terminals.

          IF backspace.size <> 0 THEN
            amp$put_next (file_id, ^backspace.value (1), backspace.size, ba, sysstat);
          ELSE
            output_ascii_from_ordinal (tuc$out_cursor_left);
          IFEND;
        FOREND;
      IFEND;

    PROCEND backward_word;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'Carriage_return', EJECT ??

    PROCEDURE [INLINE] carriage_return;


      amp$put_next (file_id, ^cr_only.value, cr_only.size, ba, sysstat);

    PROCEND carriage_return;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'Command_too_long', EJECT ??

    PROCEDURE command_text_too_long;

      VAR
        ba: amt$file_byte_address,
        message: [STATIC] string (62) :=
              ' Redo cannot be used with commands longer than 256 characters.';


      call_block.getn.transfer_count^ := 0;
      continued_command := FALSE;
{???  amp$put_next (file_id, ^clr^.value, clr^.size, ba, sysstat);
      setup_terminal_for_line_mode;
      amp$flush (file_id, osc$nowait, sysstat);
      amp$put_next (non_xparent_file_id, ^message, STRLENGTH (message), ba, sysstat);

    PROCEND command_text_too_long;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'cursor_bkw', EJECT ??

    PROCEDURE [INLINE] cursor_bkw;


      column := column - 1;
      IF (column - left_column + 1) < 1 THEN
        CASE tt_header^.cursor.behavior [tuc$move_past_left] OF
        = tuc$cursor_wrap_adjacent =
          output_ascii_from_ordinal (tuc$out_cursor_right);
        ELSE
          ;
        CASEND;
        IF left_column > 1 THEN
          left_column := left_column - 20;
          IF left_column < 1 THEN
            left_column := 1;
            column := 1;
          IFEND;
          display_command;
          move_cursor_to_column;
        ELSE
          column := 1;
        IFEND;
      IFEND;

    PROCEND cursor_bkw;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'cursor_forward', EJECT ??

    PROCEDURE [INLINE] cursor_forward;


      IF column < max_text_length THEN
        column := column + 1;
        IF (column - left_column + 1) > device_columns THEN
          left_column := left_column + 20;
          display_command;
          move_cursor_to_column;
        IFEND;
      ELSE

{ Don't move cursor beyond maximum command length.

        display_command;
        move_cursor_to_column;
      IFEND;

    PROCEND cursor_forward;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'delete_char_from_command', EJECT ??

    PROCEDURE [INLINE] delete_char_from_command;


      IF column <= command.size THEN
        temp_string := command.value (column + 1, command.size - column);
        command.value (column, * ) := temp_string;
        command.size := command.size - 1;
        IF command.size < 0 THEN
          command.size := 0;
        IFEND;
      IFEND;

    PROCEND delete_char_from_command;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'delete_word', EJECT ??

    PROCEDURE delete_word;


      IF column = 1 THEN
        left_column := 1;
        display_command;
        carriage_return;
        RETURN;
      IFEND;
      column := column - 1;

{  If character to left of cursor is a non-word character, delete it
{  and all preceding non-word characters until a word character or column
{  one is reached.

    /strip_non_word_characters/
      WHILE TRUE DO
        IF NOT (command.value (column) IN scl_word_charset) THEN
          delete_char_from_command;
          IF column > 1 THEN
            column := column - 1;
          ELSE
            left_column := 1;
            display_command;
            RETURN;
          IFEND;
        ELSE
          EXIT /strip_non_word_characters/;
        IFEND;
      WHILEND /strip_non_word_characters/;

{     If character to left of cursor is a word character, delete it and
{     all preceding word characters until a non-word character or column
{     one is found.

      WHILE TRUE DO
        IF command.value (column) IN scl_word_charset THEN
          delete_char_from_command;
          IF column > 1 THEN
            column := column - 1;
          ELSE
            left_column := 1;
            display_command;
            carriage_return;
            RETURN;
          IFEND;
        ELSE
          column := column + 1;
          IF column < left_column THEN
            left_column := column - 20;
            IF left_column < 1 THEN
              left_column := 1;
            IFEND;
          IFEND;
          display_command;
          move_cursor_to_column;
          RETURN;
        IFEND;
      WHILEND;

    PROCEND delete_word;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'display_command', EJECT ??

    PROCEDURE display_command;

      VAR
        length: integer;


      amp$put_next (file_id, ^clr^.value, clr^.size, ba, sysstat);
      length := min (command.size - left_column + 1, device_columns);
      amp$put_next (file_id, ^command.value (left_column), length, ba, sysstat);
      current_column := left_column + length - 1;

{ Save current_column for later use by move_cursor_to_column.

      IF (command.size - left_column + 1) > device_columns THEN
        amp$put_next (file_id, ^continued_marker, 1, ba, sysstat);
        current_column := current_column + 1
      IFEND;

    PROCEND display_command;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'echo_ascii_from_ordinal', EJECT ??

    PROCEDURE [INLINE] echo_ascii_from_ordinal
      (    ordinal: tut$output_ordinals);


      IF full_duplex THEN
        amp$put_next (file_id, ^tt_output^.chars (tt_output^.ordinals [$INTEGER (ordinal)].start),
              tt_output^.ordinals [$INTEGER (ordinal)].length, ba, sysstat);
      IFEND;

    PROCEND echo_ascii_from_ordinal;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'forward_word', EJECT ??

    PROCEDURE forward_word;

      VAR
        i: 0 .. 1023,
        original_column: 0 .. 1023;


      IF column >= command.size THEN
        RETURN;
      IFEND;
      original_column := column;

    /scan_a_word/
      BEGIN

      /scan_for_next_word/
        WHILE TRUE DO
          IF command.value (column) IN scl_word_charset THEN
            EXIT /scan_for_next_word/;
          IFEND;
          column := column + 1;
          IF column > command.size THEN
            column := command.size + 1;
            EXIT /scan_a_word/;
          IFEND;
        WHILEND /scan_for_next_word/;

      /scan_over_word/
        WHILE TRUE DO
          column := column + 1;
          IF column > command.size THEN
            column := command.size + 1;
            EXIT /scan_a_word/;
          IFEND;
          IF NOT (command.value (column) IN scl_word_charset) THEN
            EXIT /scan_over_word/;
          IFEND;
        WHILEND /scan_over_word/;

      /scan_to_word/
        WHILE TRUE DO
          column := column + 1;
          IF column > command.size THEN
            column := command.size + 1;
            EXIT /scan_a_word/;
          IFEND;
          IF command.value (column) IN scl_word_charset THEN
            EXIT /scan_to_word/;
          IFEND;
        WHILEND /scan_to_word/;

      END /scan_a_word/;

      IF (column - left_column + 1) > device_columns THEN
        left_column := column - device_columns + 20;
        display_command;
        move_cursor_to_column;
      ELSE
        amp$put_next (file_id, ^command.value (original_column), column - original_column, ba, sysstat);
      IFEND;

    PROCEND forward_word;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'min', EJECT ??

    FUNCTION [INLINE] min
      (    arg1: integer,
           arg2: integer): integer;


      IF arg1 < arg2 THEN
        min := arg1;
      ELSE
        min := arg2;
      IFEND;

    FUNCEND min;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'move_cursor_to_column', EJECT ??

    PROCEDURE [INLINE] move_cursor_to_column;

      VAR
        i: integer;


      IF column = left_column THEN
        carriage_return;
      ELSEIF (column - left_column) > (current_column - left_column) DIV 2 THEN
        WHILE column <= current_column DO
          amp$put_next (file_id, ^backspace.value, backspace.size, ba, sysstat);
          current_column := current_column - 1;
        WHILEND;
      ELSE
        carriage_return;
        IF column > left_column THEN
          amp$put_next (file_id, ^command.value (left_column), column - left_column, ba, sysstat);
        IFEND;
      IFEND;

    PROCEND move_cursor_to_column;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'output_ascii_from_ordinal', EJECT ??

    PROCEDURE [INLINE] output_ascii_from_ordinal
      (    ordinal: tut$output_ordinals);


      amp$put_next (file_id, ^tt_output^.chars (tt_output^.ordinals [$INTEGER (ordinal)].start),
            tt_output^.ordinals [$INTEGER (ordinal)].length, ba, sysstat);

    PROCEND output_ascii_from_ordinal;
?? OLDTITLE, EJECT ??

{  Update commands buffer from job log.

    update_commands;

    cmd_shown := in_ptr^;
    command.size := 0;
    column := 1;
    string_ptr := call_block.getn.working_storage_area;
    count := call_block.getn.transfer_count^;
    input_buffer := string_ptr^ (1, count);
    device_input_length := count;
    device_input_ndx := 0;
    software_insert_mode := software_insert_default;
    insert_mode := software_insert_default;
    cr_delim_key_pushed := FALSE;
    in_transparent_mode := FALSE;

{   If input line ended with BKW code, search backward for command
{   starting with the string preceding the BKW code.

    IF action = find_line THEN
      IF (in_ptr^ = out_ptr^) THEN {no search if nothing to search}
        output_ascii_from_ordinal (tuc$out_bell_nak);
        call_block.getn.transfer_count^ := 0;
        RETURN;
      IFEND;
      #TRANSLATE (osv$lower_to_upper, string_ptr^ (1, count), command_string);
      m := in_ptr^ -1;

    /search_for_command/
      WHILE TRUE DO

{       IF commands^[m].value (1, count) = command_string(1, count) THEN

        IF i#compare_collated (commands^ [m].value (1, count), command_string (1, count),
              osv$lower_to_upper) = 0 THEN
          command := commands^ [m];
          left_column := 1;
          cmd_shown := m;
          column := 1;
          device_input_length := 0;
          cr_delim_key_pushed := in_transparent_mode;
          in_transparent_mode := TRUE;
          setup_terminal_for_redo;
          redo_setup_done := TRUE;
          display_command;
          carriage_return;
          get_key (input_character, ordinal);
          EXIT /search_for_command/;
        ELSE
          IF (m = out_ptr^) OR (in_ptr^ = out_ptr^) THEN
            output_ascii_from_ordinal (tuc$out_bell_nak);
            call_block.getn.transfer_count^ := 0;
            RETURN;
          ELSE
            m := m - 1;
            IF m < 1 THEN
              m := max_commands;
            IFEND;
          IFEND;
        IFEND;
      WHILEND /search_for_command/;
    ELSE {control action - initiate only on bkw, cursor up, or F-keys.}
      get_key (input_character, ordinal);
      IF (ordinal <> $INTEGER (tuc$in_bkw)) AND (ordinal <> $INTEGER (tuc$in_cursor_up)) AND
            ((ordinal < $INTEGER (tuc$in_f1)) OR (ordinal > $INTEGER (tuc$in_f16_s))) THEN
        RETURN;
      IFEND;
      setup_terminal_for_redo;
      redo_setup_done := TRUE;
    IFEND;

{   Process user editing actions on the line.

  /process_user_redo/
    WHILE TRUE DO
      CASE ordinal OF
      = $INTEGER (tuc$in_overstrike) =
        IF ($INTEGER (input_character) < 32) OR ($INTEGER (input_character) = 7F(16)) THEN
          IF (input_character = interrupt_char^) OR (cmd_shown = in_ptr^) THEN
            amp$put_next (file_id, ^clr^.value, clr^.size, ba, sysstat);
            call_block.getn.transfer_count^ := 0;
            continued_command := FALSE;
            setup_terminal_for_line_mode;
            RETURN;
          ELSEIF input_character = del_word^ THEN
            delete_word;
          ELSEIF input_character = fwd_word^ THEN
            forward_word;
          ELSEIF input_character = bkw_word^ THEN
            backward_word;
          ELSEIF input_character = clr_up^ THEN
            temp_string := command.value (column, * );
            command.value (1, * ) := temp_string;
            command.size := command.size - column + 1;
            column := 1;
            display_command;
            carriage_return;
          ELSEIF input_character = insert_toggle^ THEN
            software_insert_mode := NOT software_insert_mode;
            insert_mode := software_insert_mode;
          ELSEIF input_character = del_char^ THEN
            IF column <> 1 THEN
              column := column - 1;
              delete_char_from_command;
            IFEND;
            display_command;
            move_cursor_to_column;
          ELSEIF input_character = move_to_end^ THEN
            IF command.size <  max_text_length THEN
              column := command.size + 1;
            ELSE

{ Don't move cursor beyond maximum command length.

              column := max_text_length;
            IFEND;

            IF column > device_columns THEN
              left_column := command.size - device_columns + 20;
            IFEND;
            display_command;
            move_cursor_to_column;
          ELSEIF input_character = move_to_start^ THEN
            column := 1;
            IF left_column <> 1 THEN
              left_column := 1;
              display_command;
            IFEND;
            carriage_return;
          ELSE {unknown control code -- refresh the line}
            display_command;
            move_cursor_to_column;
          IFEND;
        ELSE
          IF insert_mode THEN
            IF command.size < max_text_length THEN
              temp_string := command.value (column, * );
              command.value (column) := input_character;
              command.value (column + 1, * ) := temp_string;
              command.size := command.size + 1;
              column := column + 1;
              IF full_duplex THEN

{ Optimize insert operation to speed up ANSI type terminals.

                IF software_insert_mode AND (column <> command.size + 1) THEN
                  current_column := min (command.size - column + 1, device_columns - (column - left_column));
                  amp$put_next (file_id, ^command.value (column - 1), current_column + 1, ba, sysstat);
                  current_column := column + current_column - 1;
                  IF (command.size - column + 1) > device_columns THEN
                    amp$put_next (file_id, ^continued_marker, 1, ba, sysstat);
                    current_column := current_column + 1;
                  IFEND;
                  move_cursor_to_column;
                ELSE
                  amp$put_next (file_id, ^input_character, 1, ba, sysstat);
                IFEND;
              IFEND;
              column := column - 1;
              cursor_forward;
            ELSE

{ Don't extend command beyond maximum command length.

              command_text_too_long;
              RETURN;
            IFEND;
          ELSE
            IF column <= max_text_length THEN
              IF full_duplex THEN
                amp$put_next (file_id, ^input_character, 1, ba, sysstat);
              IFEND;
              command.value (column) := input_character;
              IF column > command.size THEN
                command.size := column;
              IFEND;
              cursor_forward;
            ELSE

{ Don't extend command beyond maximum command length.

              command_text_too_long;
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      = $INTEGER (tuc$in_cursor_right) =
        IF column <= max_text_length THEN
          IF column > command.size THEN
            command.value (column) := ' ';
            command.size := column;
          IFEND;
          IF full_duplex THEN
            amp$put_next (file_id, ^command.value (column), 1, ba, sysstat);
          IFEND;
          cursor_forward;
        ELSE

{ Don't move cursor beyond maximum command length.

          display_command;
          move_cursor_to_column;
        IFEND;
      = $INTEGER (tuc$in_cursor_left), $INTEGER (tuc$in_backspace) =
        IF backspace.size <> 0 THEN
          IF full_duplex THEN
            amp$put_next (file_id, ^backspace.value (1), backspace.size, ba, sysstat);
          IFEND;
        ELSE
          echo_ascii_from_ordinal (tuc$out_cursor_left);
        IFEND;
        cursor_bkw;
      = $INTEGER (tuc$in_fwd), $INTEGER (tuc$in_cursor_down) =

{IF FWD beyond most recent command or empty buffer, restore line mode.

        IF (NOT full_duplex) AND (ordinal = $INTEGER (tuc$in_cursor_down)) THEN
          output_ascii_from_ordinal (tuc$out_cursor_up);
        IFEND;
        IF (cmd_shown = in_ptr^ -1) OR (in_ptr^ = out_ptr^) OR (cmd_shown = 0) THEN
          call_block.getn.transfer_count^ := 0;
          amp$put_next (file_id, ^clr^.value, clr^.size, ba, sysstat);
          setup_terminal_for_line_mode;
          RETURN;
        IFEND;

        cmd_shown := cmd_shown + 1;
        IF cmd_shown > max_commands THEN {handle buffer wraparound}
          cmd_shown := 1;
        IFEND;

        command := commands^ [cmd_shown];
        left_column := 1;

{   bypass tuc$in_next event if cr_delimited keys

        IF ordinal = $INTEGER (tuc$in_fwd) THEN
          cr_delim_key_pushed := TRUE;
        IFEND;
        display_command;
        carriage_return;
        column := 1;
      = $INTEGER (tuc$in_bkw), $INTEGER (tuc$in_cursor_up) =

{ If buffer empty, or can't back up further, ring bell.

        IF (NOT full_duplex) AND (ordinal = $INTEGER (tuc$in_cursor_up)) THEN
          IF in_transparent_mode THEN
            output_ascii_from_ordinal (tuc$out_cursor_down);
          IFEND;
        IFEND;
        IF cmd_shown = 0 THEN {BKW from F-key generated command}
          cmd_shown := in_ptr^;
        IFEND;
        IF (cmd_shown = out_ptr^) OR (in_ptr^ = out_ptr^) THEN
          output_ascii_from_ordinal (tuc$out_bell_nak);
          IF in_ptr^ = out_ptr^ THEN
            call_block.getn.transfer_count^ := 0;
            setup_terminal_for_line_mode;
            RETURN;
          IFEND;
        ELSE
          cmd_shown := cmd_shown - 1;
          IF cmd_shown < 1 THEN
            cmd_shown := max_commands;
          IFEND;
          command := commands^ [cmd_shown];
          left_column := 1;
        IFEND;

{   bypass tuc$in_next event if cr_delimited key

        IF ordinal = $INTEGER (tuc$in_bkw) THEN
          cr_delim_key_pushed := in_transparent_mode;
        IFEND;
        in_transparent_mode := TRUE;
        left_column := 1;
        column := 1;
        display_command;
        carriage_return;
      = $INTEGER (tuc$in_fwd_s) =
        forward_word;
        cr_delim_key_pushed := TRUE;
      = $INTEGER (tuc$in_up) =
        IF command.size < max_text_length THEN

{ Move cursor one column past the last character.

          column := command.size + 1;
        ELSE

{ Move cursor to the last character if already at the maximum command length.

          column := max_text_length;
        IFEND;
        cr_delim_key_pushed := TRUE;
        IF column > device_columns THEN
          left_column := command.size - device_columns + 20;
        IFEND;
        display_command;
        move_cursor_to_column;
      = $INTEGER (tuc$in_down) =
        column := 1;
        IF left_column <> 1 THEN
          left_column := 1;
          display_command;
        IFEND;
        carriage_return;
        cr_delim_key_pushed := TRUE;
      = $INTEGER (tuc$in_delete_char) =
        echo_ascii_from_ordinal (tuc$out_delete_char);
        delete_char_from_command;
        IF command.size >= device_columns THEN
          display_command;
          move_cursor_to_column;
        IFEND;
      = $INTEGER (tuc$in_insert_char) =
        IF command.size < max_text_length THEN
          echo_ascii_from_ordinal (tuc$out_insert_char);
          temp_string := command.value (column, command.size);
          command.value (column) := ' ';
          command.value (column + 1, * ) := temp_string;
          command.size := command.size + 1;
        ELSE

{ Do not insert a blank if already at the maximum command length.

          command_text_too_long;
          RETURN;
        IFEND;
      = $INTEGER (tuc$in_insert_mode_begin) =
        echo_ascii_from_ordinal (tuc$out_insert_mode_begin);
        insert_mode := TRUE;
      = $INTEGER (tuc$in_insert_mode_end) =
        echo_ascii_from_ordinal (tuc$out_insert_mode_end);
        insert_mode := FALSE;
      = $INTEGER (tuc$in_insert_mode_toggle) =
        echo_ascii_from_ordinal (tuc$out_insert_mode_toggle);
        insert_mode := NOT insert_mode;
      = $INTEGER (tuc$in_erase_end_of_line) =
        echo_ascii_from_ordinal (tuc$out_erase_end_of_line);
        command.size := column;
        command.value (column, * ) := ' ';
      = $INTEGER (tuc$in_erase_line_bol) =
        echo_ascii_from_ordinal (tuc$out_erase_line_bol);
        command.size := 0;
        command.value := ' ';
        column := 1;
        left_column := 1;
        display_command;
        carriage_return;
      = $INTEGER (tuc$in_erase_line_stay) =
        echo_ascii_from_ordinal (tuc$out_erase_line_stay);
        command.size := column;
        command.value := ' ';
        left_column := 1;
        display_command;
        carriage_return;
      = $INTEGER (tuc$in_erase_char) =
        echo_ascii_from_ordinal (tuc$out_erase_char);
        command.value (column - 1) := ' ';
        IF column - 1 = command.size THEN
          command.size := command.size - 1;
        IFEND;
        cursor_bkw;
      = $INTEGER (tuc$in_back), $INTEGER (tuc$in_stop), $INTEGER (tuc$in_stop_s) =
        amp$put_next (file_id, ^clr^.value, clr^.size, ba, sysstat);
        IF ordinal = $INTEGER (tuc$in_back) THEN {strip off CR from BACK}
          get_key (input_character, ordinal);
        IFEND;
        in_transparent_mode := FALSE;
        call_block.getn.transfer_count^ := 0;
        setup_terminal_for_line_mode;
        continued_command := FALSE;
        RETURN;
      = $INTEGER (tuc$in_return) =
        column := 1;
      = $INTEGER (tuc$in_next) =
        IF NOT cr_delim_key_pushed THEN
          string_ptr := call_block.getn.working_storage_area;
          string_ptr^ (1, command.size) := command.value (1, command.size);
          call_block.getn.transfer_count^ := command.size;
          setup_terminal_for_line_mode;
          amp$put_next (non_xparent_file_id, ^cr_only.value, cr_only.size, ba, sysstat);
          amp$flush (non_xparent_file_id, osc$nowait, sysstat);
          RETURN;
        ELSE
          cr_delim_key_pushed := FALSE;
        IFEND;
      = $INTEGER (tuc$in_tab_forward) =
        establish_terminal_commands;
      = $INTEGER (tuc$in_f1) .. $INTEGER (tuc$in_f16_s) =
        key_number := ordinal - $INTEGER (tuc$in_f1) + 1;
        IF key_number > 16 THEN
          key_string := 'SF';
          key_number := key_number - 16;
          n := 3;
        ELSE
          key_string := 'F';
          n := 2;
        IFEND;
        IF key_number >= 10 THEN
          key_string (n) := '1';
          n := n + 1;
          key_number := key_number - 10;
        IFEND;
        key_string (n) := $CHAR (key_number + $INTEGER ('0'));
        clp$read_variable (key_string (1, n), v, sysstat);
        IF sysstat.normal THEN
          IF v.value.kind <> clc$string_value THEN
            amp$put_next (file_id, ^no_str, STRLENGTH (no_str), ba, sysstat);
            setup_terminal_for_line_mode;
            amp$put_next (non_xparent_file_id, ^cr_only.value, cr_only.size, ba, sysstat);
            amp$flush (non_xparent_file_id, osc$nowait, sysstat);
            call_block.getn.transfer_count^ := 0;
            RETURN;
          IFEND;
          string_ptr := call_block.getn.working_storage_area;
          cell_ptr := v.value.string_value;
          string_ptr1 := cell_ptr;
          n := 1;
          len := #LOC (v.value.string_value^ [n]);
          n := n + #SIZE (len^);
          IF (len^ > 1) AND (string_ptr1^ (n + len^ -2, 2) = '..') THEN
            temp_string := command.value (column, *);
            command.value (column, * ) := string_ptr1^ (n, len^ -2);
            command.value (column + len^ -2, * ) := temp_string;
            command.size := command.size + len^ -2;
            column := column + len^ -2;
          ELSE
            temp_string := command.value (column, command.size);
            command.value (column, * ) := string_ptr1^ (n, len^);
            command.value (column + len^, * ) := temp_string;
            command.size := command.size + len^;
            column := column + len^;
          IFEND;
          IF NOT in_transparent_mode THEN
            cmd_shown := 0; {flag command line not in commands buffer}
          IFEND;
          left_column := 1;
          IF (len^ > 1) AND (string_ptr1^ (n + len^ -2, 2) = '..') THEN
            IF command.size > device_columns THEN
              left_column := command.size - device_columns + 20;
            IFEND;
            display_command;
            move_cursor_to_column;
            IF in_transparent_mode THEN
              cr_delim_key_pushed := TRUE;
            IFEND;
          ELSE
            string_ptr^ (1, command.size) := command.value (1, command.size);
            call_block.getn.transfer_count^ := command.size;
            amp$put_next (file_id, ^command.value (1), command.size, ba, sysstat);
            setup_terminal_for_line_mode;
            amp$put_next (non_xparent_file_id, ^cr_only.value, cr_only.size, ba, sysstat);
            amp$flush (non_xparent_file_id, osc$nowait, sysstat);
            RETURN;
          IFEND;
          in_transparent_mode := TRUE;
        ELSE

{ If no function key defined, issue a message

          amp$put_next (file_id, ^no_fkey, STRLENGTH (no_fkey), ba, sysstat);
          setup_terminal_for_line_mode;
          amp$put_next (non_xparent_file_id, ^cr_only.value, cr_only.size, ba, sysstat);
          amp$flush (non_xparent_file_id, osc$nowait, sysstat);
          call_block.getn.transfer_count^ := 0;
          RETURN;
        IFEND;
      ELSE {force redisplay of current command if in doubt}
        IF cmd_shown <> in_ptr^ THEN
          display_command;
          move_cursor_to_column;
        ELSE
          amp$put_next (file_id, ^clr^.value, clr^.size, ba, sysstat);
          call_block.getn.transfer_count^ := 0;
          setup_terminal_for_line_mode;
          RETURN;
        IFEND;
      CASEND;
      get_key (input_character, ordinal);
    WHILEND /process_user_redo/;

  PROCEND process_control_codes;
?? TITLE := 'setup_terminal_for_line_mode', EJECT ??

  PROCEDURE setup_terminal_for_line_mode;

    VAR
      ba: amt$file_byte_address,
      fpos: amt$file_position,
      inbuf: string (1),
      lfn: amt$local_file_name,
      non_xparent_connect_attributes: [STATIC] array [1 .. 8] of ift$connection_attribute :=
            [[ifc$input_block_size, input_buffer_length], [ifc$input_editing_mode, ifc$normal_edit],
            [ifc$trans_character_mode, ifc$trans_char_forward],
            [ifc$trans_timeout_mode, ifc$no_trans_timeout], [ifc$trans_length_mode, ifc$trans_len_forward],
            [ifc$trans_message_length, input_buffer_length], [ifc$trans_forward_character,
            [1, $CHAR (0D(16))]], [ifc$trans_terminate_character, [1, $CHAR (00(16))]]];

    lfn := 'OUTPUT';
    IF full_duplex THEN
      ifp$change_terminal_attributes (lfn, echo_on, sysstat);
    IFEND;
    IF (set_line_mode_p <> NIL) AND (set_line_mode_p^.size > 0) THEN

{ An application string was defined in the terminal definition to set line mode.

      amp$put_next (file_id, ^set_line_mode_p^.value, set_line_mode_p^.size, ba, sysstat);
    ELSE
      amp$put_next (file_id, ^tt_output^.chars (tt_output^.ordinals [$INTEGER (tuc$out_set_line_mode)].start),
            tt_output^.ordinals [$INTEGER (tuc$out_set_line_mode)].length, ba, sysstat);
    IFEND;

{  Establish the terminal attributes to be line mode, non hot key.

    ifp$store_term_conn_attributes (non_xparent_file_id, non_xparent_connect_attributes, sysstat);
    IF NOT sysstat.normal THEN
      shutdown_redo;
      RETURN;
    IFEND;
    ifp$immediate_attribute_flush (non_xparent_file_id, sysstat);
    IF NOT sysstat.normal THEN
      shutdown_redo;
      RETURN;
    IFEND;

  PROCEND setup_terminal_for_line_mode;
?? TITLE := 'setup_terminal_for_redo', EJECT ??

  PROCEDURE setup_terminal_for_redo;

    VAR
      ba: amt$file_byte_address,
      connect_attributes: [STATIC] array [1 .. 8] of ift$connection_attribute :=
            [[ifc$input_block_size, input_buffer_length], [ifc$input_editing_mode, ifc$trans_edit],
            [ifc$input_output_mode, ifc$unsolicited_output], [ifc$trans_character_mode, ifc$no_trans_char],
            [ifc$trans_timeout_mode, ifc$no_trans_timeout], [ifc$trans_length_mode, ifc$trans_len_forward],
            [ifc$trans_message_length, 1], [ifc$trans_terminate_character, [1, $CHAR (00(16))]]],
      lfn: amt$local_file_name;


{  Establish the terminal attributes for Redo's files.

    ifp$store_term_conn_attributes (file_id, connect_attributes, sysstat);
    IF NOT sysstat.normal THEN
      shutdown_redo;
      RETURN;
    IFEND;
    ifp$store_term_conn_attributes (in_file_id, connect_attributes, sysstat);
    IF NOT sysstat.normal THEN
      shutdown_redo;
      RETURN;
    IFEND;
    ifp$immediate_attribute_flush (in_file_id, sysstat);
    IF NOT sysstat.normal THEN
      shutdown_redo;
      RETURN;
    IFEND;
    lfn := 'OUTPUT';
    IF full_duplex THEN
      ifp$change_terminal_attributes (lfn, echo_off, sysstat);
    IFEND;
    IF (set_screen_mode_p <> NIL) AND (set_screen_mode_p^.size > 0) THEN

{ An application string was defined in the terminal definition to set screen mode.

      amp$put_next (file_id, ^set_screen_mode_p^.value, set_screen_mode_p^.size, ba, sysstat);
    ELSE
      amp$put_next (file_id, ^tt_output^.chars (tt_output^.ordinals [$INTEGER (tuc$out_set_screen_mode)].
            start), tt_output^.ordinals [$INTEGER (tuc$out_set_screen_mode)].length, ba, sysstat);
    IFEND;

  PROCEND setup_terminal_for_redo;
?? TITLE := 'shutdown_redo', EJECT ??

  PROCEDURE shutdown_redo;

    VAR
      ba: amt$file_byte_address,
      message_p: ^string ( * ),
      redo_turned_off: [STATIC] string (71) :=
              ' Redo is disabled for the current task because of file access problems.',
      unsupported_terminal: [STATIC] string (42) :=
              ' Redo does not support IBM_3270 terminals.',
      unknown_terminal: [STATIC] string (60) :=
              ' Redo not enabled due to missing or undefined terminal name.';


    IF redo_is_shutdown = NIL THEN
      redo_is_shutdown := ^static_shutdown;
    IFEND;
    redo_is_shutdown^ := TRUE;
    IF in_ptr = NIL THEN
      message_p := ^redo_turned_off;
    ELSE
      IF ibm_3270 THEN
        message_p := ^unsupported_terminal;
      ELSE
        message_p := ^unknown_terminal;
      IFEND;
      in_ptr^ := -1; { To keep secondary redo detection from using bad TDU pointers.
    IFEND;
    amp$put_next (file_id, message_p, STRLENGTH (message_p^), ba, sysstat);

  PROCEND shutdown_redo;
?? TITLE := 'turn_insert_mode_off', EJECT ??

  PROCEDURE turn_insert_mode_off;

    VAR
      ba: amt$file_byte_address;


    IF tt_output^.ordinals [$INTEGER (tuc$out_insert_mode_end)].length <> 0 THEN
      amp$put_next (file_id, ^tt_output^.chars (tt_output^.ordinals [$INTEGER (tuc$out_insert_mode_end)].
            start), tt_output^.ordinals [$INTEGER (tuc$out_insert_mode_end)].length, ba, sysstat);
    ELSE
      amp$put_next (file_id, ^tt_output^.chars (tt_output^.ordinals [$INTEGER (tuc$out_insert_mode_toggle)].
            start), tt_output^.ordinals [$INTEGER (tuc$out_insert_mode_toggle)].length, ba, sysstat);
    IFEND;
    insert_mode := FALSE;

  PROCEND turn_insert_mode_off;
?? TITLE := 'update_commands', EJECT ??

{  PURPOSE:
{     This procedure updates the command buffer by reading job log entries that
{     have been added since the last time this procedure was called.
{
{  DESIGN:
{     This procedure opens the log file, positions the log at the last address
{     read and reads the remainder of the file.  Each log entry of origin type
{     'CI' is added to the command buffer.
{
{  NOTE:
{     The job log is used as the source of previous commands to ensure that Redo
{     does not display the of value of secure parameters.

  PROCEDURE update_commands;

    CONST
      command_too_long = '" Redo cannot handle commands longer than 256 characters.',
      command_too_long_length = 57;

    VAR
      byte_address: amt$file_byte_address,
      current_length: amt$transfer_count,
      file_position: amt$file_position,
      prefix_length: integer,
      text_line: ^pmt$log_msg_text,
      text_line_length: integer,
      text_p: ^pmt$job_log_entry;

?? NEWTITLE := 'update_command_buffer_pointers', EJECT ??

    PROCEDURE [INLINE] update_command_buffer_pointers;


      IF in_ptr^ < max_commands THEN
        in_ptr^ := in_ptr^ +1;
      ELSE
        in_ptr^ := 1;
      IFEND;
      IF in_ptr^ = out_ptr^ THEN

{ Discard the oldest command because there are no unused entries.

        IF out_ptr^ < max_commands THEN
          out_ptr^ := out_ptr^ +1;
        ELSE
          out_ptr^ := 1;
        IFEND;
      IFEND;

    PROCEND update_command_buffer_pointers;
?? OLDTITLE, EJECT ??

    PUSH text_p: [lgc$log_entry_size_limit];
    IF text_p = NIL THEN
      RETURN;
    IFEND;

    prefix_length := #SIZE (pmt$job_log_entry: [0]);

    amp$seek_direct (job_log_file_id, job_log_last_eoi_p^, sysstat);
    IF NOT sysstat.normal THEN
      RETURN;
    IFEND;

  /get_log_records/
    WHILE TRUE DO

      amp$get_next (job_log_file_id, text_p, lgc$log_entry_size_limit, current_length, byte_address,
            file_position, sysstat);
      IF NOT sysstat.normal THEN
        EXIT /get_log_records/;
      IFEND;

      IF (current_length <= prefix_length) OR (job_log_last_eoi_p^ = byte_address) THEN
        job_log_last_eoi_p^ := byte_address;
        CYCLE /get_log_records/;
      IFEND;

      job_log_last_eoi_p^ := byte_address;
      IF text_p^.origin = 'CI' THEN

{  The string 'CI' corresponds to pmc$msg_origin_command which is not accessible to Redo.

        text_line_length := current_length - prefix_length;
        IF text_line_length > max_text_length THEN
          commands^ [in_ptr^].size := command_too_long_length;
          commands^ [in_ptr^].value := command_too_long;
          update_command_buffer_pointers;
        ELSEIF text_p^.text (1, text_line_length) <> '' THEN
          commands^ [in_ptr^].size := text_line_length;
          #TRANSLATE (control_codes_to_quest_mark, text_p^.text (1, text_line_length),
                commands^ [in_ptr^].value (1, text_line_length));
          update_command_buffer_pointers;
        IFEND;
      IFEND;
    WHILEND /get_log_records/;

  PROCEND update_commands;

MODEND clm$process_redo_operation;
*DECK DECK=CLM$PROCESS_VALUE_QUALIFIERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL : Value qualifier processing routines' ??
MODULE clm$process_value_qualifiers;

{
{ PURPOSE:
{   This module contains the procedures that process qualifiers of SCL
{   data value (fields of records, subscripts of arrays and lists,
{   range elements, and substring references).
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$max_integer
*copyc clc$min_integer
*copyc cle$bad_data_value
*copyc cle$ecc_lexical
*copyc cle$ecc_parsing
*IF $true(osv$unix)
*copyc cle$not_supported
*IFEND
*copyc cle$work_area_overflow
*copyc clt$access_variable_requests
*copyc clt$value_qualifiers
*copyc oss$job_paged_literal
?? POP ??
*copyc clp$append_status_parse_state
*copyc clp$append_status_string
*copyc clp$change_internal_value
*copyc clp$convert_ext_value_to_int
*copyc clp$convert_int_value_to_ext
*copyc clp$evaluate_integer_expression
*copyc clp$make_array_value
*copyc clp$make_boolean_value
*copyc clp$make_command_ref_value
*copyc clp$make_date_time_value
*copyc clp$make_entry_point_ref_value
*copyc clp$make_file_value
*copyc clp$make_integer_value
*copyc clp$make_keyword_value
*copyc clp$make_name_value
*copyc clp$make_program_name_value
*copyc clp$make_record_value
*copyc clp$make_scu_line_id_value
*copyc clp$make_status_code_value
*copyc clp$make_status_value
*copyc clp$make_string_value
*copyc clp$make_time_increment_value
*copyc clp$make_time_zone_value
*copyc clp$make_unspecified_value
*copyc clp$make_value
*copyc clp$scan_any_lexical_unit
*copyc clp$scan_non_space_lexical_unit
*copyc clp$trimmed_string_size
*copyc i#current_sequence_position
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*IF NOT $true(osv$unix)
*copyc pmp$get_compact_date_time
*IFEND

?? EJECT ??

{ Variables used by clp$get_write_value_qualifiers and clp$read_qualified_data_value.

  VAR
    clv$boolean_type_description: [XDCL, STATIC, READ, oss$job_paged_literal] clt$type_description :=
*IF NOT $true(osv$unix)
          [NIL, NIL, FALSE, FALSE, $clt$type_kinds [clc$boolean_type], clc$boolean_type],
*ELSE
          [NIL, NIL, FALSE, FALSE, [clc$boolean_type], clc$boolean_type],
*IFEND
    clv$file_type_description: [XDCL, STATIC, READ, oss$job_paged_literal] clt$type_description :=
*IF NOT $true(osv$unix)
          [NIL, NIL, FALSE, FALSE, $clt$type_kinds [clc$file_type], clc$file_type],
*ELSE
          [NIL, NIL, FALSE, FALSE, [clc$file_type], clc$file_type],
*IFEND
    clv$integer_type_description: [XDCL, STATIC, READ, oss$job_paged_literal] clt$type_description :=
*IF NOT $true(osv$unix)
          [NIL, NIL, FALSE, FALSE, $clt$type_kinds [clc$integer_type], clc$integer_type, clc$min_integer,
*ELSE
          [NIL, NIL, FALSE, FALSE, [clc$integer_type], clc$integer_type, clc$min_integer,
*IFEND
          clc$max_integer, 10],
    clv$keyword_type_description: [XDCL, STATIC, READ, oss$job_paged_literal] clt$type_description :=
*IF NOT $true(osv$unix)
          [NIL, NIL, FALSE, FALSE, $clt$type_kinds [clc$keyword_type], clc$keyword_type, ^clv$keyword_names],
*ELSE
          [NIL, NIL, FALSE, FALSE, [clc$keyword_type], clc$keyword_type, ^clv$keyword_names],
*IFEND
    clv$name_type_description: [XDCL, STATIC, READ, oss$job_paged_literal] clt$type_description :=
*IF NOT $true(osv$unix)
          [NIL, NIL, FALSE, FALSE, $clt$type_kinds [clc$name_type], clc$name_type, 1, osc$max_name_size],
*ELSE
          [NIL, NIL, FALSE, FALSE, [clc$name_type], clc$name_type, 1, osc$max_name_size],
*IFEND
    clv$pgm_name_type_description: [XDCL, STATIC, READ, oss$job_paged_literal] clt$type_description :=
*IF NOT $true(osv$unix)
          [NIL, NIL, FALSE, FALSE, $clt$type_kinds [clc$program_name_type], clc$program_name_type],
*ELSE
          [NIL, NIL, FALSE, FALSE, [clc$program_name_type], clc$program_name_type],
*IFEND
    clv$scu_mod_type_description: [XDCL, STATIC, READ, oss$job_paged_literal] clt$type_description :=
*IF NOT $true(osv$unix)
          [NIL, NIL, FALSE, FALSE, $clt$type_kinds [clc$name_type], clc$name_type, 1,
*ELSE
          [NIL, NIL, FALSE, FALSE, [clc$name_type], clc$name_type, 1,
*IFEND
          clc$max_scu_modification_name],
    clv$stat_code_type_description: [XDCL, STATIC, READ, oss$job_paged_literal] clt$type_description :=
*IF NOT $true(osv$unix)
          [NIL, NIL, FALSE, FALSE, $clt$type_kinds [clc$status_code_type], clc$status_code_type],
*ELSE
          [NIL, NIL, FALSE, FALSE, [clc$status_code_type], clc$status_code_type],
*IFEND
    clv$string_type_description: [XDCL, STATIC, READ, oss$job_paged_literal] clt$type_description :=
*IF NOT $true(osv$unix)
          [NIL, NIL, FALSE, FALSE, $clt$type_kinds [clc$string_type], clc$string_type, 0, clc$max_string_size,
*ELSE
          [NIL, NIL, FALSE, FALSE, [clc$string_type], clc$string_type, 0, clc$max_string_size,
*IFEND
          FALSE],
    clv$keyword_names: [XDCL, STATIC, READ, oss$job_paged_literal] array [1 .. 6] of
          clt$keyword_specification := [['FILE_CYCLE', clc$nominal_entry, clc$normal_usage_entry, 1],
          ['MODULE_OR_FILE', clc$nominal_entry, clc$normal_usage_entry, 2],
          ['NAME_ONLY', clc$nominal_entry, clc$normal_usage_entry, 3],
          ['SKIP_FIRST_ENTRY', clc$nominal_entry, clc$normal_usage_entry, 4],
          ['SYSTEM', clc$nominal_entry, clc$normal_usage_entry, 5],
          ['UTILITY', clc$nominal_entry, clc$normal_usage_entry, 6]];

*IF NOT $true(osv$unix)
?? TITLE := 'clp$get_qualified_type_desc', EJECT ??

  PROCEDURE [XDCL] clp$get_qualified_type_desc
    (    value_qualifiers: ^clt$value_qualifiers;
     VAR type_description {input, output} : ^clt$type_description);

    VAR
      index: integer;

?? NEWTITLE := 'evaluate_field_qualifier', EJECT ??

    PROCEDURE evaluate_field_qualifier
      (    field_name: clt$field_name);

      VAR
        field_names: ^clt$pdt_parameter_names,
        i: clt$field_number,
        record_field_name: clt$field_name;


      CASE type_description^.kind OF
      = clc$command_reference_type =
        IF (field_name = 'NAME') OR (field_name = 'UTILITY') THEN
          type_description := ^clv$name_type_description;
        ELSEIF field_name = 'FORM' THEN
          type_description := ^clv$keyword_type_description;
        ELSEIF field_name = 'LIBRARY_OR_CATALOG' THEN
          type_description := ^clv$file_type_description;
        ELSE {IF field_name = 'CYCLE_NUMBER' THEN
          type_description := ^clv$integer_type_description;
        IFEND;
      = clc$date_time_type =
        type_description := ^clv$integer_type_description;
      = clc$entry_point_reference_type =
        IF field_name = 'ENTRY_POINT' THEN
          type_description := ^clv$pgm_name_type_description;
        ELSE {IF field_name = 'OBJECT_LIBRARY' THEN
          type_description := ^clv$file_type_description;
        IFEND;
      = clc$range_type =
        type_description := type_description^.range_element_type_description;
      = clc$record_type =
        IF (type_description^.fields_pdt <> NIL) THEN
          field_names := type_description^.fields_pdt^.names;
          FOR i := 1 TO UPPERBOUND (field_names^) DO
            #TRANSLATE (osv$lower_to_upper, field_names^ [i].name, record_field_name);
            IF record_field_name = field_name THEN
              type_description := ^type_description^.fields_pdt^.type_descriptions^ [i];
              RETURN;
            IFEND;
          FOREND;
        IFEND;
      = clc$scu_line_identifier_type =
        IF field_name = 'MODIFICATION_NAME' THEN
          type_description := ^clv$scu_mod_type_description;
        ELSE {IF field_name = 'SEQUENCE_NUMBER' THEN
          type_description := ^clv$integer_type_description;
        IFEND;
      = clc$status_type =
        IF field_name = 'NORMAL' THEN
          type_description := ^clv$boolean_type_description;
        ELSEIF field_name = 'CONDITION' THEN
          type_description := ^clv$stat_code_type_description;
        ELSE {IF field_name = 'TEXT' THEN
          type_description := ^clv$string_type_description;
        IFEND;
      = clc$time_increment_type =
        type_description := ^clv$integer_type_description;
      = clc$time_zone_type =
        IF (field_name = 'HOURS_FROM_GMT') OR (field_name = 'MINUTES_OFFSET') THEN
          type_description := ^clv$integer_type_description;
        ELSE {IF field_name = 'DAYLIGHT_SAVING_TIME' THEN
          type_description := ^clv$boolean_type_description;
        IFEND;
      CASEND;

    PROCEND evaluate_field_qualifier;
?? OLDTITLE, EJECT ??

{
{ This procedure assumes that:
{   1.  The value qualifiers have been verified against the type description.
{   2.  Currently, the only valid qualifiers are clc$array_subscript,
{       clc$field_qualifier, clc$list_subscript_qualifier, clc$substring_qualifier.
{       Unspecified and invalid qualifiers are NOT allowed because this would
{       constitute a clc$union_type in the type description.  This is not allowed
{       at this point.
{


    FOR index := 1 TO UPPERBOUND (value_qualifiers^) DO
      CASE value_qualifiers^ [index].kind OF
      = clc$array_subscript_qualifier =
        type_description := type_description^.array_element_type_description;
      = clc$field_qualifier =
        evaluate_field_qualifier (value_qualifiers^ [index].field_name);
      = clc$list_subscript_qualifier =
        type_description := type_description^.list_element_type_description;
      = clc$substring_qualifier =
      ELSE
        ;
      CASEND;
    FOREND;

  PROCEND clp$get_qualified_type_desc;
*IFEND
?? TITLE := 'clp$get_read_value_qualifiers', EJECT ??

  PROCEDURE [XDCL] clp$get_read_value_qualifiers
    (    name: clt$variable_name;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value_qualifiers: ^clt$value_qualifiers;
     VAR status: ost$status);

    TYPE
      value_qualifier_list = record
        link: ^value_qualifier_list,
        value: clt$value_qualifier,
      recend;

    VAR
      first_value_qualifier: ^value_qualifier_list,
      i: integer,
      invalid_subscript_defined: boolean,
      invalid_size_defined: boolean,
      invalid_qualifier_created: boolean,
      invalid_qualifier_separator: char,
      invalid_qualifier_subscript: clt$array_bound,
      invalid_qualifier_size: clt$string_size,
      last_value_qualifier: ^value_qualifier_list,
      local_parse: clt$parse_state,
      local_status: ost$status,
      new_value_qualifier: ^value_qualifier_list,
      number_of_value_qualifiers: integer,
      sub_integer: clt$integer;

?? NEWTITLE := 'create_invalid_qualifier', EJECT ??

    PROCEDURE create_invalid_qualifier
      (    kind: clt$value_qualifier_kind);

      VAR
        status_ptr: ^ost$status;


      invalid_qualifier_created := TRUE;

      NEXT status_ptr IN work_area;
      IF status_ptr = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT clp$get_read_value_qualifiers;
      IFEND;
      status_ptr^ := local_status;

      new_value_qualifier^.value.kind := kind;
      CASE kind OF
      = clc$invalid_field_qualifier =
        new_value_qualifier^.value.invalid_field_status := status_ptr;

      = clc$invalid_subscript_qual =
        new_value_qualifier^.value.invalid_subscript_status := status_ptr;
        new_value_qualifier^.value.subscript_defined := invalid_subscript_defined;
        IF invalid_subscript_defined THEN
          new_value_qualifier^.value.invalid_subscript := invalid_qualifier_subscript;
        IFEND;

      = clc$invalid_substring_qual =
        new_value_qualifier^.value.invalid_index := invalid_qualifier_subscript;
        new_value_qualifier^.value.invalid_separator := invalid_qualifier_separator;
        new_value_qualifier^.value.invalid_substring_status := status_ptr;
        new_value_qualifier^.value.size_defined := invalid_size_defined;
        IF invalid_size_defined THEN
          new_value_qualifier^.value.invalid_size := invalid_qualifier_size;
        IFEND;

      CASEND;

    PROCEND create_invalid_qualifier;
?? TITLE := 'evaluate_field_qualifier', EJECT ??

    PROCEDURE evaluate_field_qualifier;

      VAR
        field_name: clt$field_name;


      #TRANSLATE (osv$lower_to_upper, local_parse.text^ (local_parse.unit_index, local_parse.unit.size),
            field_name);

      new_value_qualifier^.value.kind := clc$unspecified_field_qualifier;
      new_value_qualifier^.value.field_name := field_name;
      new_value_qualifier^.value.record_kind := clc$unknown_record;

    PROCEND evaluate_field_qualifier;
?? TITLE := 'evaluate_subscript_qual', EJECT ??

    PROCEDURE evaluate_subscript_qual;

      VAR
        separator: char,
        substring_size_present: boolean,
        sub_index: integer,
        sub_name: ost$name,
        sub_size: integer;


      IF local_parse.unit.kind = clc$lex_comma THEN
        substring_size_present := TRUE;
        separator := ',';
        clp$scan_non_space_lexical_unit (local_parse);
      ELSEIF local_parse.unit.kind = clc$lex_right_parenthesis THEN
        substring_size_present := FALSE;
      ELSEIF local_parse.previous_unit_is_space THEN
        substring_size_present := TRUE;
        separator := ' ';
      ELSE
        substring_size_present := FALSE;
      IFEND;

      IF substring_size_present THEN

        sub_index := sub_integer.value;

      /get_substring_size/
        BEGIN
          IF local_parse.unit.kind = clc$lex_name THEN
            #TRANSLATE (osv$lower_to_upper, local_parse.text^ (local_parse.unit_index, local_parse.unit.size),
                  sub_name);
            IF sub_name = 'ALL' THEN
              sub_size := 0;
              clp$scan_non_space_lexical_unit (local_parse);
              EXIT /get_substring_size/;
            IFEND;
          IFEND;

          clp$evaluate_integer_expression (clc$min_integer, clc$max_integer, work_area, local_parse,
                sub_integer, local_status);
          IF NOT local_status.normal THEN
            invalid_qualifier_subscript := sub_index;
            invalid_qualifier_separator := separator;
            invalid_size_defined := FALSE;
            create_invalid_qualifier (clc$invalid_substring_qual);
            RETURN;
          IFEND;
          IF local_parse.unit_is_space THEN
            clp$scan_non_space_lexical_unit (local_parse);
          IFEND;

          sub_size := sub_integer.value;
        END /get_substring_size/;

        new_value_qualifier^.value.kind := clc$unspecified_substring_qual;
        new_value_qualifier^.value.unspecified_index := sub_index;
        new_value_qualifier^.value.unspecified_size := sub_size;
        new_value_qualifier^.value.unspecified_all_found := sub_name = 'ALL';
        new_value_qualifier^.value.unspecified_separator := separator;

      ELSE

        new_value_qualifier^.value.kind := clc$unspecified_subscript_qual;
        new_value_qualifier^.value.unspecified_subscript := sub_integer.value;

      IFEND;

    PROCEND evaluate_subscript_qual;
?? OLDTITLE, EJECT ??


{
{ This procedure will return unspecified and invalid qualifiers only.
{ Qualifiers are marked as unspecified (i.e. clc$unspecified_substring_qualifier
{ vs clc$substring_qualifier) because the qualifiers are NOT validated against
{ the actual value or type description.
{


    status.normal := TRUE;
    local_parse := parse;
    first_value_qualifier := NIL;
    last_value_qualifier := NIL;
    new_value_qualifier := NIL;
    number_of_value_qualifiers := 0;
    invalid_qualifier_created := FALSE;
    local_status.normal := TRUE;

  /get_qualifiers/
    WHILE NOT invalid_qualifier_created DO

      PUSH new_value_qualifier;
      NEXT new_value_qualifier^.value.parse IN work_area;
      IF new_value_qualifier^.value.parse = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
      new_value_qualifier^.value.parse^ := local_parse;

      CASE local_parse.unit.kind OF
      = clc$lex_left_parenthesis =
        clp$scan_any_lexical_unit (local_parse);
        clp$evaluate_integer_expression (clc$min_integer, clc$max_integer, work_area, local_parse,
              sub_integer, local_status);
        IF NOT local_status.normal THEN
          invalid_subscript_defined := FALSE;
          create_invalid_qualifier (clc$invalid_subscript_qual);
        ELSE
          IF local_parse.unit_is_space THEN
            clp$scan_non_space_lexical_unit (local_parse);
          IFEND;

          evaluate_subscript_qual;

          IF (NOT invalid_qualifier_created) AND (local_parse.unit.kind <> clc$lex_right_parenthesis) THEN
            IF new_value_qualifier^.value.kind = clc$unspecified_substring_qual THEN
              invalid_qualifier_subscript := new_value_qualifier^.value.unspecified_index;
              invalid_qualifier_separator := new_value_qualifier^.value.unspecified_separator;
              invalid_size_defined := NOT new_value_qualifier^.value.unspecified_all_found;
              IF invalid_size_defined THEN
                invalid_qualifier_size := new_value_qualifier^.value.unspecified_size;
              IFEND;
              osp$set_status_abnormal ('CL', cle$expecting_rparen_of_substr, name, local_status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, local_parse, local_status);
              create_invalid_qualifier (clc$invalid_substring_qual);
            ELSE
              invalid_subscript_defined := TRUE;
              invalid_qualifier_subscript := new_value_qualifier^.value.unspecified_subscript;
              osp$set_status_abnormal ('CL', cle$expecting_rparen_of_subscr, name, local_status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, local_parse, local_status);
              create_invalid_qualifier (clc$invalid_subscript_qual);
            IFEND;
          IFEND;
        IFEND;

      = clc$lex_dot =

        clp$scan_any_lexical_unit (local_parse);

        CASE local_parse.unit.kind OF
        = clc$lex_name =
          evaluate_field_qualifier;

        = clc$lex_long_name =
          osp$set_status_abnormal ('CL', cle$name_too_long, local_parse.
                text^ (local_parse.unit_index, local_parse.unit.size), local_status);
          create_invalid_qualifier (clc$invalid_field_qualifier);

        ELSE
          osp$set_status_abnormal ('CL', cle$expecting_field_name, name, local_status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, local_parse, local_status);
          create_invalid_qualifier (clc$invalid_field_qualifier);
        CASEND;

      ELSE
        EXIT /get_qualifiers/;
      CASEND;

      new_value_qualifier^.link := NIL;
      IF first_value_qualifier = NIL THEN
        first_value_qualifier := new_value_qualifier;
      ELSE
        last_value_qualifier^.link := new_value_qualifier;
      IFEND;
      last_value_qualifier := new_value_qualifier;
      number_of_value_qualifiers := number_of_value_qualifiers + 1;

      clp$scan_any_lexical_unit (local_parse);
    WHILEND /get_qualifiers/;

    IF number_of_value_qualifiers > 0 THEN
      NEXT value_qualifiers: [1 .. number_of_value_qualifiers] IN work_area;
      IF value_qualifiers = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
    IFEND;

    new_value_qualifier := first_value_qualifier;
    FOR i := 1 TO number_of_value_qualifiers DO
      value_qualifiers^ [i] := new_value_qualifier^.value;
      new_value_qualifier := new_value_qualifier^.link;
    FOREND;

    parse := local_parse;

  PROCEND clp$get_read_value_qualifiers;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$get_write_value_qualifiers', EJECT ??

  PROCEDURE [XDCL] clp$get_write_value_qualifiers
    (    name: clt$variable_name;
     VAR type_description {input, output} : ^clt$type_description;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value_qualifiers: ^clt$value_qualifiers;
     VAR status: ost$status);

    TYPE
      value_qualifier_list = record
        link: ^value_qualifier_list,
        value: clt$value_qualifier,
      recend;

    VAR
      first_value_qualifier: ^value_qualifier_list,
      i: integer,
      last_value_qualifier: ^value_qualifier_list,
      local_parse: clt$parse_state,
      local_type_description: ^clt$type_description,
      new_value_qualifier: ^value_qualifier_list,
      number_of_value_qualifiers: integer,
      sub_integer: clt$integer,
      unspecified_qualifiers_created: boolean;

?? NEWTITLE := 'evaluate_any_field_qualifier', EJECT ??

    PROCEDURE evaluate_any_field_qualifier;

      VAR
        field_name: clt$field_name;


      #TRANSLATE (osv$lower_to_upper, local_parse.text^ (local_parse.unit_index, local_parse.unit.size),
            field_name);

      new_value_qualifier^.value.kind := clc$unspecified_field_qualifier;
      new_value_qualifier^.value.field_name := field_name;
      new_value_qualifier^.value.record_kind := clc$unknown_record;

    PROCEND evaluate_any_field_qualifier;
?? TITLE := 'evaluate_any_subscript_qual', EJECT ??

    PROCEDURE evaluate_any_subscript_qual;

      VAR
        substring_size_present: boolean,
        sub_index: clt$string_index,
        sub_name: ost$name,
        sub_size: clt$string_size;


      IF local_parse.unit.kind = clc$lex_comma THEN
        substring_size_present := TRUE;
        clp$scan_non_space_lexical_unit (local_parse);
      ELSEIF local_parse.unit.kind = clc$lex_right_parenthesis THEN
        substring_size_present := FALSE;
      ELSEIF local_parse.previous_unit_is_space THEN
        substring_size_present := TRUE;
      ELSE
        substring_size_present := FALSE;
      IFEND;

      IF substring_size_present THEN

        sub_index := sub_integer.value;

      /get_substring_size/
        BEGIN
          IF local_parse.unit.kind = clc$lex_name THEN
            #TRANSLATE (osv$lower_to_upper, local_parse.text^ (local_parse.unit_index, local_parse.unit.size),
                  sub_name);
            IF sub_name = 'ALL' THEN
              sub_size := 0;
              clp$scan_non_space_lexical_unit (local_parse);
              EXIT /get_substring_size/;
            IFEND;
          IFEND;

          clp$evaluate_integer_expression (clc$min_integer, clc$max_integer, work_area, local_parse,
                sub_integer, status);
          IF NOT status.normal THEN
            EXIT clp$get_write_value_qualifiers;
          IFEND;
          IF local_parse.unit_is_space THEN
            clp$scan_non_space_lexical_unit (local_parse);
          IFEND;

          sub_size := sub_integer.value;
        END /get_substring_size/;

        new_value_qualifier^.value.kind := clc$unspecified_substring_qual;
        new_value_qualifier^.value.unspecified_index := sub_index;
        new_value_qualifier^.value.unspecified_size := sub_size;
        new_value_qualifier^.value.unspecified_all_found := sub_name = 'ALL';

      ELSE

        new_value_qualifier^.value.kind := clc$unspecified_subscript_qual;
        new_value_qualifier^.value.unspecified_subscript := sub_integer.value;

      IFEND;

    PROCEND evaluate_any_subscript_qual;
?? TITLE := 'evaluate_array_subscript_qual', EJECT ??

    PROCEDURE evaluate_array_subscript_qual;


      IF (NOT local_type_description^.array_bounds_defined) OR
            (sub_integer.value < local_type_description^.bounds.lower) OR
            (sub_integer.value > local_type_description^.bounds.upper) THEN
        osp$set_status_abnormal ('CL', cle$subscript_out_of_range, name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, sub_integer.value, sub_integer.radix,
              sub_integer.radix_specified, status);
        osp$append_status_integer (osc$status_parameter_delimiter, local_type_description^.bounds.lower,
              sub_integer.radix, sub_integer.radix_specified, status);
        osp$append_status_integer (osc$status_parameter_delimiter, local_type_description^.bounds.upper,
              sub_integer.radix, sub_integer.radix_specified, status);
        EXIT clp$get_write_value_qualifiers;
      IFEND;

      IF local_type_description^.array_element_type_description = NIL THEN
        osp$set_status_abnormal ('CL', cle$undefined_subscr_element, name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, sub_integer.value, sub_integer.radix,
              sub_integer.radix_specified, status);
        EXIT clp$get_write_value_qualifiers;
      IFEND;

      new_value_qualifier^.value.kind := clc$array_subscript_qualifier;
      new_value_qualifier^.value.array_subscript := sub_integer.value;
      new_value_qualifier^.value.bounds := local_type_description^.bounds;
      local_type_description := local_type_description^.array_element_type_description;

    PROCEND evaluate_array_subscript_qual;
?? TITLE := 'evaluate_field_qualifier', EJECT ??

    PROCEDURE evaluate_field_qualifier;

      VAR
        field_name: clt$field_name,
        field_names: ^clt$pdt_parameter_names,
        i: clt$field_number,
        record_field_name: clt$field_name,
        record_kind: clt$value_qualifier_records;


      #TRANSLATE (osv$lower_to_upper, local_parse.text^ (local_parse.unit_index, local_parse.unit.size),
            field_name);

    /find_field/
      BEGIN
        CASE local_type_description^.kind OF
        = clc$command_reference_type =
          IF (field_name = 'NAME') OR (field_name = 'UTILITY') THEN
            local_type_description := ^clv$name_type_description;
          ELSEIF field_name = 'FORM' THEN
            local_type_description := ^clv$keyword_type_description;
          ELSEIF (field_name = 'LIBRARY_OR_CATALOG') THEN
            local_type_description := ^clv$file_type_description;
          ELSEIF (field_name = 'CYCLE_NUMBER') THEN
            local_type_description := ^clv$integer_type_description;
          ELSE
            EXIT /find_field/;
          IFEND;
          record_kind := clc$command_reference_record;
        = clc$date_time_type =
          IF (field_name = 'YEAR') OR (field_name = 'MONTH') OR (field_name = 'DAY') OR
                (field_name = 'HOUR') OR (field_name = 'MINUTE') OR (field_name = 'SECOND') OR (field_name =
                'MILLISECOND') THEN
            local_type_description := ^clv$integer_type_description;
          ELSE
            EXIT /find_field/;
          IFEND;
          record_kind := clc$date_time_record;
        = clc$entry_point_reference_type =
          IF field_name = 'ENTRY_POINT' THEN
            local_type_description := ^clv$pgm_name_type_description;
          ELSEIF field_name = 'OBJECT_LIBRARY' THEN
            local_type_description := ^clv$file_type_description;
          ELSE
            EXIT /find_field/;
          IFEND;
          record_kind := clc$entry_point_ref_record;
        = clc$range_type =
          IF (field_name = 'HIGH') OR (field_name = 'LOW') THEN
            local_type_description := local_type_description^.range_element_type_description;
          ELSE
            EXIT /find_field/;
          IFEND;
          record_kind := clc$unknown_record;

        = clc$record_type =
          IF (local_type_description^.fields_pdt <> NIL) THEN
            field_names := local_type_description^.fields_pdt^.names;

          /find_record/
            BEGIN
              FOR i := 1 TO UPPERBOUND (field_names^) DO
                #TRANSLATE (osv$lower_to_upper, field_names^ [i].name, record_field_name);
                IF record_field_name = field_name THEN
                  IF local_type_description^.fields_pdt^.type_descriptions = NIL THEN
                    osp$set_status_abnormal ('CL', cle$undefined_field, field_name, status);
                    osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
                    EXIT clp$get_write_value_qualifiers;
                  IFEND;
                  local_type_description := ^local_type_description^.fields_pdt^.type_descriptions^ [i];
                  record_kind := clc$record_record;
                  EXIT /find_record/;
                IFEND;
              FOREND;
              EXIT /find_field/;
            END /find_record/;
          ELSE
            EXIT /find_field/;
          IFEND;
        = clc$scu_line_identifier_type =
          IF field_name = 'MODIFICATION_NAME' THEN
            local_type_description := ^clv$scu_mod_type_description;
          ELSEIF field_name = 'SEQUENCE_NUMBER' THEN
            local_type_description := ^clv$integer_type_description;
          ELSE
            EXIT /find_field/;
          IFEND;
          record_kind := clc$scu_line_ident_record;
        = clc$status_type =
          IF field_name = 'NORMAL' THEN
            local_type_description := ^clv$boolean_type_description;
          ELSEIF field_name = 'CONDITION' THEN
            local_type_description := ^clv$stat_code_type_description;
          ELSEIF field_name = 'TEXT' THEN
            local_type_description := ^clv$string_type_description;
          ELSE
            EXIT /find_field/;
          IFEND;
          record_kind := clc$status_record;
        = clc$time_increment_type =
          IF (field_name = 'YEARS') OR (field_name = 'MONTHS') OR (field_name = 'DAYS') OR (field_name =
                'HOURS') OR (field_name = 'MINUTES') OR (field_name = 'SECONDS') OR (field_name =
                'MILLISECONDS') THEN
            local_type_description := ^clv$integer_type_description;
          ELSE
            EXIT /find_field/;
          IFEND;
          record_kind := clc$time_increment_record;
        = clc$time_zone_type =
          IF (field_name = 'HOURS_FROM_GMT') OR (field_name = 'MINUTES_OFFSET') THEN
            local_type_description := ^clv$integer_type_description;
          ELSEIF field_name = 'DAYLIGHT_SAVING_TIME' THEN
            local_type_description := ^clv$boolean_type_description;
          ELSE
            EXIT /find_field/;
          IFEND;
          record_kind := clc$time_zone_record;

        CASEND;

        new_value_qualifier^.value.kind := clc$field_qualifier;
        new_value_qualifier^.value.field_name := field_name;
        new_value_qualifier^.value.record_kind := record_kind;
        IF record_kind = clc$record_record THEN
          new_value_qualifier^.value.field_names := field_names;
        IFEND;
        RETURN;

      END /find_field/;

      IF local_type_description^.kind = clc$range_type THEN
        osp$set_status_abnormal ('CL', cle$unknown_range_selector, field_name, status);
      ELSE
        osp$set_status_abnormal ('CL', cle$unknown_field, field_name, status);
      IFEND;
      osp$append_status_parameter (osc$status_parameter_delimiter, name, status);

    PROCEND evaluate_field_qualifier;
?? TITLE := 'evaluate_list_subscript_qual', EJECT ??

    PROCEDURE evaluate_list_subscript_qual;


      IF sub_integer.value < 1 THEN
        osp$set_status_abnormal ('CL', cle$list_subscript_too_small, name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, sub_integer.value, sub_integer.radix,
              sub_integer.radix_specified, status);
        EXIT clp$get_write_value_qualifiers;
      ELSEIF sub_integer.value > local_type_description^.max_list_size THEN
        osp$set_status_abnormal ('CL', cle$max_list_subscript_error, name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, sub_integer.value, sub_integer.radix,
              sub_integer.radix_specified, status);
        osp$append_status_integer (osc$status_parameter_delimiter, local_type_description^.max_list_size, 10,
              FALSE, status);
        EXIT clp$get_write_value_qualifiers;
      IFEND;

      IF local_type_description^.list_element_type_description = NIL THEN
        osp$set_status_abnormal ('CL', cle$undefined_subscr_element, name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, sub_integer.value, sub_integer.radix,
              sub_integer.radix_specified, status);
        EXIT clp$get_write_value_qualifiers;
      IFEND;
      local_type_description := local_type_description^.list_element_type_description;

      new_value_qualifier^.value.kind := clc$list_subscript_qualifier;
      new_value_qualifier^.value.list_subscript := sub_integer.value;

    PROCEND evaluate_list_subscript_qual;
?? TITLE := 'evaluate_substring_qualifier', EJECT ??

    PROCEDURE evaluate_substring_qualifier;

      VAR
        string_size: clt$string_size,
        substring_size_present: boolean,
        sub_index: clt$string_index,
        sub_name: ost$name,
        sub_size: integer;


      IF local_parse.unit.kind = clc$lex_comma THEN
        substring_size_present := TRUE;
        clp$scan_non_space_lexical_unit (local_parse);
      ELSEIF local_parse.unit.kind = clc$lex_right_parenthesis THEN
        substring_size_present := FALSE;
      ELSEIF local_parse.previous_unit_is_space THEN
        substring_size_present := TRUE;
      ELSE
        substring_size_present := FALSE;
      IFEND;
      sub_name := ' ';

      IF (sub_integer.value < 1) OR (sub_integer.value > (local_type_description^.max_string_size + 1)) THEN
        osp$set_status_abnormal ('CL', cle$max_substr_index_error, name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, sub_integer.value, sub_integer.radix,
              sub_integer.radix_specified, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              local_type_description^.max_string_size + 1, sub_integer.radix, sub_integer.radix_specified,
              status);
        EXIT clp$get_write_value_qualifiers;
      IFEND;

      sub_index := sub_integer.value;
      string_size := local_type_description^.max_string_size + 1 - sub_index;

      IF substring_size_present THEN

      /get_substring_size/
        BEGIN
          IF local_parse.unit.kind = clc$lex_name THEN
            #TRANSLATE (osv$lower_to_upper, local_parse.text^ (local_parse.unit_index, local_parse.unit.size),
                  sub_name);
            IF sub_name = 'ALL' THEN
              sub_size := string_size;
              clp$scan_non_space_lexical_unit (local_parse);
              EXIT /get_substring_size/;
            IFEND;
          IFEND;

          clp$evaluate_integer_expression (clc$min_integer, clc$max_integer, work_area, local_parse,
                sub_integer, status);
          IF NOT status.normal THEN
            EXIT clp$get_write_value_qualifiers;
          IFEND;
          IF local_parse.unit_is_space THEN
            clp$scan_non_space_lexical_unit (local_parse);
          IFEND;
          sub_size := sub_integer.value;
        END /get_substring_size/;

      ELSE
        sub_size := 1;
      IFEND;

      IF (sub_size < 0) OR (sub_size > string_size) THEN
        osp$set_status_abnormal ('CL', cle$substr_size_out_of_range, name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, sub_size, sub_integer.radix,
              sub_integer.radix_specified, status);
        osp$append_status_integer (osc$status_parameter_delimiter, string_size, sub_integer.radix,
              sub_integer.radix_specified, status);
        EXIT clp$get_write_value_qualifiers;
      IFEND;

      new_value_qualifier^.value.kind := clc$substring_qualifier;
      new_value_qualifier^.value.index := sub_index;
      new_value_qualifier^.value.size := sub_size;
      new_value_qualifier^.value.all_specified := sub_name = 'ALL';

    PROCEND evaluate_substring_qualifier;
?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    local_parse := parse;
    local_type_description := type_description;
    unspecified_qualifiers_created := FALSE;
    first_value_qualifier := NIL;
    last_value_qualifier := NIL;
    new_value_qualifier := NIL;
    number_of_value_qualifiers := 0;

  /get_qualifiers/
    WHILE TRUE DO
      CASE local_parse.unit.kind OF
      = clc$lex_left_parenthesis =
        CASE local_type_description^.kind OF
        = clc$array_type, clc$list_type, clc$string_type, clc$union_type =

          clp$scan_any_lexical_unit (local_parse);
          clp$evaluate_integer_expression (clc$min_integer, clc$max_integer, work_area, local_parse,
                sub_integer, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF local_parse.unit_is_space THEN
            clp$scan_non_space_lexical_unit (local_parse);
          IFEND;

          PUSH new_value_qualifier;

          CASE local_type_description^.kind OF
          = clc$array_type =
            evaluate_array_subscript_qual;
          = clc$list_type =
            evaluate_list_subscript_qual;
          = clc$string_type =
            evaluate_substring_qualifier;
          = clc$union_type =
            evaluate_any_subscript_qual;
            unspecified_qualifiers_created := TRUE;
          CASEND;

          IF local_parse.unit.kind <> clc$lex_right_parenthesis THEN
            IF new_value_qualifier^.value.kind = clc$substring_qualifier THEN
              osp$set_status_abnormal ('CL', cle$expecting_rparen_of_substr, name, status);
            ELSE
              osp$set_status_abnormal ('CL', cle$expecting_rparen_of_subscr, name, status);
            IFEND;
            clp$append_status_parse_state (osc$status_parameter_delimiter, local_parse, status);
            RETURN;
          IFEND;

        ELSE
          EXIT /get_qualifiers/;
        CASEND;

      = clc$lex_dot =

        CASE local_type_description^.kind OF
        = clc$command_reference_type, clc$date_time_type, clc$entry_point_reference_type, clc$range_type,
              clc$record_type, clc$scu_line_identifier_type, clc$status_type, clc$time_increment_type,
              clc$time_zone_type, clc$union_type =

          clp$scan_any_lexical_unit (local_parse);
          CASE local_parse.unit.kind OF
          = clc$lex_name =
            PUSH new_value_qualifier;
            IF local_type_description^.kind = clc$union_type THEN
              evaluate_any_field_qualifier;
              unspecified_qualifiers_created := TRUE;
            ELSE
              evaluate_field_qualifier;
            IFEND;

          = clc$lex_long_name =
            osp$set_status_abnormal ('CL', cle$name_too_long, local_parse.
                  text^ (local_parse.unit_index, local_parse.unit.size), status);
            RETURN;

          ELSE
            osp$set_status_abnormal ('CL', cle$expecting_field_name, name, status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, local_parse, status);
            RETURN;
          CASEND;

        ELSE
          EXIT /get_qualifiers/;
        CASEND;

      ELSE
        EXIT /get_qualifiers/;
      CASEND;

      new_value_qualifier^.link := NIL;
      IF first_value_qualifier = NIL THEN
        first_value_qualifier := new_value_qualifier;
      ELSE
        last_value_qualifier^.link := new_value_qualifier;
      IFEND;
      last_value_qualifier := new_value_qualifier;
      number_of_value_qualifiers := number_of_value_qualifiers + 1;

      clp$scan_any_lexical_unit (local_parse);
    WHILEND /get_qualifiers/;

    IF number_of_value_qualifiers > 0 THEN
      NEXT value_qualifiers: [1 .. number_of_value_qualifiers] IN work_area;
      IF value_qualifiers = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
    IFEND;

    new_value_qualifier := first_value_qualifier;
    FOR i := 1 TO number_of_value_qualifiers DO
      value_qualifiers^ [i] := new_value_qualifier^.value;
      new_value_qualifier := new_value_qualifier^.link;
    FOREND;

    parse := local_parse;
    IF unspecified_qualifiers_created THEN
      type_description := NIL;
    ELSE
      type_description := local_type_description;
    IFEND;

  PROCEND clp$get_write_value_qualifiers;
*IFEND
?? TITLE := 'clp$read_qualified_data_value', EJECT ??

  PROCEDURE [XDCL] clp$read_qualified_data_value
    (    name: clt$variable_name;
         access_variable_requests: clt$access_variable_requests;
         var_parameter_value_qualifiers: ^clt$value_qualifiers;
         internal_value: ^clt$internal_data_value;
     VAR data_value {input, output} : ^clt$data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR type_description {input, output} : ^clt$type_description;
     VAR parse_value_qualifiers {input, output} : ^clt$value_qualifiers;
     VAR parse_value_qualifier_index: integer;
     VAR status: ost$status);

    VAR
      all_specified: boolean,
      convert_nil_value_to_unspec: boolean,
      evaluating_parse_qualifiers: boolean,
      i_value: ^clt$i_data_value,
      index: integer,
      kind: clt$data_kind,
      local_type_description: ^clt$type_description,
      local_value: ^clt$data_value,
      local_value_qualifiers: ^clt$value_qualifiers,
      possible_file_reference: boolean,
      reset_parse: boolean,
      return_type_description: boolean,
      return_parse_value_qualifiers: boolean,
{
{ Specified_index, specified_size, and subscript are defined as integer.
{ Unspecified and invalid value_qualifier information has not been validated yet.
{
      specified_index: integer,
      specified_size: integer,
      subscript: integer;

?? NEWTITLE := 'evaluate_array_subscript_qual', EJECT ??

    PROCEDURE evaluate_array_subscript_qual;

      VAR
        elements: ^array [ * ] of REL (clt$internal_data_value) ^clt$i_data_value,
        lower_bound: clt$array_bound,
        upper_bound: clt$array_bound;


      IF i_value <> NIL THEN
        elements := #PTR (i_value^.array_value, internal_value^);
        lower_bound := LOWERBOUND (elements^);
        upper_bound := UPPERBOUND (elements^);
      ELSE
        lower_bound := LOWERBOUND (local_value^.array_value^);
        upper_bound := UPPERBOUND (local_value^.array_value^);
      IFEND;

      IF (subscript < lower_bound) OR (subscript > upper_bound) THEN
        osp$set_status_abnormal ('CL', cle$subscript_out_of_range, name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, subscript, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, lower_bound, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, upper_bound, 10, FALSE, status);
        EXIT clp$read_qualified_data_value;
      IFEND;

      IF i_value <> NIL THEN
        i_value := #PTR (elements^ [subscript], internal_value^);
      ELSE
        local_value := local_value^.array_value^ [subscript];
      IFEND;

      IF (i_value = NIL) AND (local_value = NIL) THEN
        osp$set_status_abnormal ('CL', cle$undefined_subscr_element, name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, subscript, 10, FALSE, status);
        EXIT clp$read_qualified_data_value;
      IFEND;

      IF return_parse_value_qualifiers AND evaluating_parse_qualifiers THEN
        local_value_qualifiers^ [index].kind := clc$array_subscript_qualifier;
        local_value_qualifiers^ [index].array_subscript := subscript;
        local_value_qualifiers^ [index].bounds.lower := lower_bound;
        local_value_qualifiers^ [index].bounds.upper := upper_bound;
        local_value_qualifiers^ [index].parse := NIL;
      IFEND;

    /determine_type_description/
      BEGIN
        IF return_type_description THEN
          IF local_type_description^.kind = clc$union_type THEN
            IF local_type_description^.member_descriptions = NIL THEN
              EXIT /determine_type_description/;
            IFEND;
            evaluate_union_type_description (name, clc$array_type, local_type_description, status);
            IF NOT status.normal THEN
              EXIT clp$read_qualified_data_value;
            IFEND;
          IFEND;
          local_type_description := local_type_description^.array_element_type_description;
        IFEND;
      END /determine_type_description/;

    PROCEND evaluate_array_subscript_qual;
?? TITLE := 'evaluate_field_qualifier', EJECT ??

    PROCEDURE evaluate_field_qualifier;

      VAR
        command_reference_value: ^clt$command_reference,
        date_time_value: ^clt$date_time,
        desired_type_description: clt$type_kind,
        entry_point_reference_value: ^pmt$entry_point_reference,
        field_index: clt$field_number,
        field_name: clt$field_name,
        field_type_description: ^clt$type_description,
        fields: ^array [1 .. * ] of clt$internal_field_value,
        form: clt$keyword,
        n: integer,
        record_kind: clt$value_qualifier_records,
        scu_line_identifier_value: ^clt$scu_line_identifier,
        status_value: ^ost$status,
        time_increment_value: ^pmt$time_increment,
        time_zone_value: ^ost$time_zone;


      field_name := local_value_qualifiers^ [index].field_name;
      field_type_description := NIL;

    /field_known/
      BEGIN

      /field_accessible/
        BEGIN

        /field_defined/
          BEGIN
            CASE kind OF

            = clc$command_reference =
              IF i_value <> NIL THEN
                command_reference_value := #PTR (i_value^.command_reference_value, internal_value^);
                i_value := NIL;
              ELSE
                command_reference_value := local_value^.command_reference_value;
              IFEND;
              IF field_name = 'NAME' THEN
                clp$make_name_value (command_reference_value^.name, work_area, local_value);
                field_type_description := ^clv$name_type_description;
              ELSEIF field_name = 'FORM' THEN
                CASE command_reference_value^.form OF
                = clc$name_only_command_ref =
                  form := 'NAME_ONLY';
                = clc$skip_1st_entry_command_ref =
                  form := 'SKIP_FIRST_ENTRY';
                = clc$system_command_ref =
                  form := 'SYSTEM';
                = clc$utility_command_ref =
                  form := 'UTILITY';
                = clc$module_or_file_command_ref =
                  form := 'MODULE_OR_FILE';
                = clc$file_cycle_command_ref =
                  form := 'FILE_CYCLE';
                ELSE
                  osp$set_status_abnormal ('CL', cle$bad_data_value, '', status);
                  EXIT clp$read_qualified_data_value;
                CASEND;
                clp$make_keyword_value (form, work_area, local_value);
                field_type_description := ^clv$keyword_type_description;
              ELSEIF field_name = 'UTILITY' THEN
                IF command_reference_value^.form <> clc$utility_command_ref THEN
                  EXIT /field_accessible/;
                IFEND;
                clp$make_name_value (command_reference_value^.utility, work_area, local_value);
                field_type_description := ^clv$name_type_description;
              ELSEIF field_name = 'LIBRARY_OR_CATALOG' THEN
                CASE command_reference_value^.form OF
                = clc$module_or_file_command_ref =
                  clp$make_file_value (command_reference_value^.library_or_catalog, work_area, local_value);
                = clc$file_cycle_command_ref =
                  clp$make_file_value (command_reference_value^.catalog, work_area, local_value);
                ELSE
                  EXIT /field_accessible/;
                CASEND;
                field_type_description := ^clv$file_type_description;
              ELSEIF field_name = 'CYCLE_NUMBER' THEN
                IF command_reference_value^.form <> clc$file_cycle_command_ref THEN
                  EXIT /field_accessible/;
                IFEND;
                clp$make_integer_value (command_reference_value^.cycle_number, 10, FALSE, work_area,
                      local_value);
                field_type_description := ^clv$integer_type_description;
              ELSE
                EXIT /field_known/;
              IFEND;
              record_kind := clc$command_reference_record;

            = clc$date_time =
              IF i_value <> NIL THEN
                date_time_value := ^i_value^.date_time_value;
                i_value := NIL;
              ELSE
                date_time_value := ^local_value^.date_time_value;
              IFEND;
              IF field_name = 'YEAR' THEN
                IF NOT date_time_value^.date_specified THEN
                  EXIT /field_defined/;
                IFEND;
                n := date_time_value^.value.year + 1900;
              ELSEIF field_name = 'MONTH' THEN
                IF NOT date_time_value^.date_specified THEN
                  EXIT /field_defined/;
                IFEND;
                n := date_time_value^.value.month;
              ELSEIF field_name = 'DAY' THEN
                IF NOT date_time_value^.date_specified THEN
                  EXIT /field_defined/;
                IFEND;
                n := date_time_value^.value.day;
              ELSEIF field_name = 'HOUR' THEN
                IF NOT date_time_value^.time_specified THEN
                  EXIT /field_defined/;
                IFEND;
                n := date_time_value^.value.hour;
              ELSEIF field_name = 'MINUTE' THEN
                IF NOT date_time_value^.time_specified THEN
                  EXIT /field_defined/;
                IFEND;
                n := date_time_value^.value.minute;
              ELSEIF field_name = 'SECOND' THEN
                IF NOT date_time_value^.time_specified THEN
                  EXIT /field_defined/;
                IFEND;
                n := date_time_value^.value.second;
              ELSEIF field_name = 'MILLISECOND' THEN
                IF NOT date_time_value^.time_specified THEN
                  EXIT /field_defined/;
                IFEND;
                n := date_time_value^.value.millisecond;
              ELSE
                EXIT /field_known/;
              IFEND;
              clp$make_integer_value (n, 10, FALSE, work_area, local_value);
              field_type_description := ^clv$integer_type_description;
              record_kind := clc$date_time_record;

            = clc$entry_point_reference =
              IF i_value <> NIL THEN
                entry_point_reference_value := #PTR (i_value^.entry_point_reference_value, internal_value^);
                i_value := NIL;
              ELSE
                entry_point_reference_value := local_value^.entry_point_reference_value;
              IFEND;
              IF field_name = 'ENTRY_POINT' THEN
                IF entry_point_reference_value^.entry_point = osc$null_name THEN
                  clp$make_program_name_value ('none', work_area, local_value);
                ELSE
                  clp$make_program_name_value (entry_point_reference_value^.entry_point, work_area,
                        local_value);
                IFEND;
                field_type_description := ^clv$pgm_name_type_description;
              ELSEIF field_name = 'OBJECT_LIBRARY' THEN
                IF entry_point_reference_value^.entry_point = osc$null_name THEN
                  EXIT /field_accessible/;
                IFEND;
                IF entry_point_reference_value^.object_library = '' THEN
                  clp$make_file_value ('$NULL', work_area, local_value);
                ELSE
                  clp$make_file_value (entry_point_reference_value^.object_library, work_area, local_value);
                IFEND;
                field_type_description := ^clv$file_type_description;
              ELSE
                EXIT /field_known/;
              IFEND;
              record_kind := clc$entry_point_ref_record;

            = clc$range =
              IF field_name = 'HIGH' THEN
                IF i_value <> NIL THEN
                  IF i_value^.high_value = NIL THEN
                    EXIT /field_defined/;
                  IFEND;
                  i_value := #PTR (i_value^.high_value, internal_value^);
                ELSE
                  IF local_value^.high_value = NIL THEN
                    EXIT /field_defined/;
                  IFEND;
                  local_value := local_value^.high_value;
                IFEND;
              ELSEIF field_name = 'LOW' THEN
                IF i_value <> NIL THEN
                  IF i_value^.low_value = NIL THEN
                    EXIT /field_defined/;
                  IFEND;
                  i_value := #PTR (i_value^.low_value, internal_value^);
                ELSE
                  IF local_value^.low_value = NIL THEN
                    EXIT /field_defined/;
                  IFEND;
                  local_value := local_value^.low_value;
                IFEND;
              ELSE
                EXIT /field_known/;
              IFEND;
              desired_type_description := clc$range_type;
              record_kind := clc$unknown_record;

            = clc$record =

            /find_record_field/
              BEGIN
                IF i_value <> NIL THEN
                  fields := #PTR (i_value^.field_values, internal_value^);
                  FOR field_index := 1 TO UPPERBOUND (fields^) DO
                    IF fields^ [field_index].name = field_name THEN
                      IF fields^ [field_index].value = NIL THEN
                        EXIT /field_defined/;
                      IFEND;
                      i_value := #PTR (fields^ [field_index].value, internal_value^);
                      EXIT /find_record_field/;
                    IFEND;
                  FOREND;
                ELSE
                  FOR field_index := 1 TO UPPERBOUND (local_value^.field_values^) DO
                    IF local_value^.field_values^ [field_index].name = field_name THEN
                      IF local_value^.field_values^ [field_index].value = NIL THEN
                        EXIT /field_defined/;
                      IFEND;
                      local_value := local_value^.field_values^ [field_index].value;
                      EXIT /find_record_field/;
                    IFEND;
                  FOREND;
                IFEND;
                EXIT /field_known/;
              END /find_record_field/;
              desired_type_description := clc$record_type;
              record_kind := clc$record_record;

            = clc$scu_line_identifier =
              IF i_value <> NIL THEN
                scu_line_identifier_value := ^i_value^.scu_line_identifier_value;
                i_value := NIL;
              ELSE
                scu_line_identifier_value := ^local_value^.scu_line_identifier_value;
              IFEND;
              IF field_name = 'MODIFICATION_NAME' THEN
                clp$make_name_value (scu_line_identifier_value^.modification_name, work_area, local_value);
                field_type_description := ^clv$scu_mod_type_description;
              ELSEIF field_name = 'SEQUENCE_NUMBER' THEN
                clp$make_integer_value (scu_line_identifier_value^.sequence_number, 10, FALSE, work_area,
                      local_value);
                field_type_description := ^clv$integer_type_description;
              ELSE
                EXIT /field_known/;
              IFEND;
              record_kind := clc$scu_line_ident_record;

            = clc$status =
              IF i_value <> NIL THEN
                status_value := #PTR (i_value^.status_value, internal_value^);
                i_value := NIL;
              ELSE
                status_value := local_value^.status_value;
              IFEND;
              IF field_name = 'NORMAL' THEN
                clp$make_boolean_value (status_value^.normal, clc$true_false_boolean, work_area, local_value);
                field_type_description := ^clv$boolean_type_description;
              ELSEIF field_name = 'CONDITION' THEN
                IF status_value^.normal THEN
                  EXIT /field_accessible/;
                IFEND;
                clp$make_status_code_value (status_value^.condition, work_area, local_value);
                field_type_description := ^clv$stat_code_type_description;
              ELSEIF field_name = 'TEXT' THEN
                IF status_value^.normal THEN
                  EXIT /field_accessible/;
                IFEND;
                clp$make_string_value (status_value^.text.value (1, status_value^.text.size), work_area,
                      local_value);
                field_type_description := ^clv$string_type_description;
              ELSE
                EXIT /field_known/;
              IFEND;
              record_kind := clc$status_record;

            = clc$time_increment =
              IF i_value <> NIL THEN
                time_increment_value := #PTR (i_value^.time_increment_value, internal_value^);
                i_value := NIL;
              ELSE
                time_increment_value := local_value^.time_increment_value;
              IFEND;
              IF field_name = 'YEARS' THEN
                n := time_increment_value^.year;
              ELSEIF field_name = 'MONTHS' THEN
                n := time_increment_value^.month;
              ELSEIF field_name = 'DAYS' THEN
                n := time_increment_value^.day;
              ELSEIF field_name = 'HOURS' THEN
                n := time_increment_value^.hour;
              ELSEIF field_name = 'MINUTES' THEN
                n := time_increment_value^.minute;
              ELSEIF field_name = 'SECONDS' THEN
                n := time_increment_value^.second;
              ELSEIF field_name = 'MILLISECONDS' THEN
                n := time_increment_value^.millisecond;
              ELSE
                EXIT /field_known/;
              IFEND;
              clp$make_integer_value (n, 10, FALSE, work_area, local_value);
              field_type_description := ^clv$integer_type_description;
              record_kind := clc$time_increment_record;

            = clc$time_zone =
              IF i_value <> NIL THEN
                time_zone_value := ^i_value^.time_zone_value;
                i_value := NIL;
              ELSE
                time_zone_value := ^local_value^.time_zone_value;
              IFEND;
              IF field_name = 'HOURS_FROM_GMT' THEN
                clp$make_integer_value (time_zone_value^.hours_from_gmt, 10, FALSE, work_area, local_value);
                field_type_description := ^clv$integer_type_description;
              ELSEIF field_name = 'MINUTES_OFFSET' THEN
                clp$make_integer_value (time_zone_value^.minutes_offset, 10, FALSE, work_area, local_value);
                field_type_description := ^clv$integer_type_description;
              ELSEIF field_name = 'DAYLIGHT_SAVING_TIME' THEN
                clp$make_boolean_value (time_zone_value^.daylight_saving_time, clc$true_false_boolean,
                      work_area, local_value);
                field_type_description := ^clv$boolean_type_description;
              ELSE
                EXIT /field_known/;
              IFEND;
              record_kind := clc$time_zone_record;

            CASEND;

            IF (i_value = NIL) AND (local_value = NIL) THEN
              osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
              EXIT clp$read_qualified_data_value;
            IFEND;

            IF return_parse_value_qualifiers AND evaluating_parse_qualifiers THEN
              local_value_qualifiers^ [index].record_kind := record_kind;
              IF record_kind = clc$record_record THEN
                local_value_qualifiers^ [index].field_names := NIL;
              IFEND;
              local_value_qualifiers^ [index].parse := NIL;
            IFEND;

          /determine_type_description/
            BEGIN
              IF return_type_description THEN
                IF field_type_description = NIL THEN
                  IF local_type_description^.kind = clc$union_type THEN
                    IF local_type_description^.member_descriptions = NIL THEN
                      EXIT /determine_type_description/;
                    IFEND;
                    evaluate_union_type_description (name, desired_type_description, local_type_description,
                          status);
                    IF NOT status.normal THEN
                      EXIT clp$read_qualified_data_value;
                    IFEND;
                  IFEND;
                  IF desired_type_description = clc$range_type THEN
                    IF (local_type_description^.kind = clc$range_type) THEN
                      local_type_description := local_type_description^.range_element_type_description;
                    IFEND;
                  ELSE
                    local_type_description := ^local_type_description^.fields_pdt^.
                          type_descriptions^ [field_index];
                  IFEND;
                ELSE
                  local_type_description := field_type_description;
                IFEND;
              IFEND;
            END /determine_type_description/;

            RETURN;

          END /field_defined/;

          IF possible_file_reference THEN
            reset_parse := TRUE;
            RETURN;
          ELSEIF kind = clc$range THEN

{ Should never get here.

            osp$set_status_abnormal ('CL', cle$undefined_range_selector, field_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
          ELSE
            osp$set_status_abnormal ('CL', cle$undefined_field, field_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
          IFEND;
          EXIT clp$read_qualified_data_value;

        END /field_accessible/;
        IF possible_file_reference THEN
          reset_parse := TRUE;
          RETURN;
        ELSE
          osp$set_status_abnormal ('CL', cle$unaccessible_field, field_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
        IFEND;
        EXIT clp$read_qualified_data_value;

      END /field_known/;
      IF possible_file_reference THEN
        reset_parse := TRUE;
        RETURN;
      ELSEIF kind = clc$range THEN
        osp$set_status_abnormal ('CL', cle$unknown_range_selector, field_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
      ELSE
        osp$set_status_abnormal ('CL', cle$unknown_field, field_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
      IFEND;
      EXIT clp$read_qualified_data_value;

    PROCEND evaluate_field_qualifier;
?? TITLE := 'evaluate_list_subscript_qual', EJECT ??

    PROCEDURE evaluate_list_subscript_qual;

      VAR
        i: clt$list_size;


      IF subscript < 1 THEN
        osp$set_status_abnormal ('CL', cle$list_subscript_too_small, name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, subscript, 10, FALSE, status);
        EXIT clp$read_qualified_data_value;
      IFEND;

      i := 1;
      IF i_value <> NIL THEN
        WHILE (i < subscript) AND (i_value^.link <> NIL) DO
          i_value := #PTR (i_value^.link, internal_value^);
          i := i + 1;
        WHILEND;
      ELSE
        WHILE (i < subscript) AND (local_value^.link <> NIL) DO
          local_value := local_value^.link;
          i := i + 1;
        WHILEND;
      IFEND;

      IF i < subscript THEN
        osp$set_status_abnormal ('CL', cle$list_subscript_too_large, name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, subscript, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, i, 10, FALSE, status);
        EXIT clp$read_qualified_data_value;
      IFEND;

      IF i_value <> NIL THEN
        i_value := #PTR (i_value^.element_value, internal_value^);
      ELSE
        local_value := local_value^.element_value;
      IFEND;

      IF (i_value = NIL) AND (local_value = NIL) THEN
        osp$set_status_abnormal ('CL', cle$undefined_subscr_element, name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, subscript, 10, FALSE, status);
        EXIT clp$read_qualified_data_value;
      IFEND;

      IF return_parse_value_qualifiers AND evaluating_parse_qualifiers THEN
        local_value_qualifiers^ [index].kind := clc$list_subscript_qualifier;
        local_value_qualifiers^ [index].list_subscript := subscript;
        local_value_qualifiers^ [index].parse := NIL;
      IFEND;

    /determine_type_description/
      BEGIN
        IF return_type_description THEN
          IF local_type_description^.kind = clc$union_type THEN
            IF local_type_description^.member_descriptions = NIL THEN
              EXIT /determine_type_description/;
            IFEND;
            evaluate_union_type_description (name, clc$list_type, local_type_description, status);
            IF NOT status.normal THEN
              EXIT clp$read_qualified_data_value;
            IFEND;
          IFEND;
          local_type_description := local_type_description^.list_element_type_description;
        IFEND;
      END /determine_type_description/;

    PROCEND evaluate_list_subscript_qual;
?? TITLE := 'evaluate_substring_qualifier', EJECT ??

    PROCEDURE evaluate_substring_qualifier;

      VAR
        string_value: ^clt$string_value,
        substring_size_present: boolean,
        sub_index: clt$string_index,
        sub_name: ost$name,
        sub_size: clt$string_size;


      IF i_value <> NIL THEN
        string_value := #PTR (i_value^.string_value, internal_value^);
        i_value := NIL;
      ELSE
        string_value := local_value^.string_value;
      IFEND;

      IF (specified_index < 1) OR (specified_index > (STRLENGTH (string_value^) + 1)) THEN
        osp$set_status_abnormal ('CL', cle$substr_index_out_of_range, name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, specified_index, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, STRLENGTH (string_value^) + 1, 10, FALSE,
              status);
        EXIT clp$read_qualified_data_value;
      IFEND;

      IF all_specified THEN
        specified_size := STRLENGTH (string_value^) + 1 - specified_index;
      ELSEIF (specified_size < 0) OR (specified_size > (STRLENGTH (string_value^) + 1 - specified_index))
            THEN
        osp$set_status_abnormal ('CL', cle$substr_size_out_of_range, name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, specified_size, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              STRLENGTH (string_value^) + 1 - specified_index, 10, FALSE, status);
        EXIT clp$read_qualified_data_value;
      IFEND;

      clp$make_string_value (string_value^ (specified_index, specified_size), work_area, local_value);
      IF local_value = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        EXIT clp$read_qualified_data_value;
      IFEND;

      IF return_parse_value_qualifiers AND evaluating_parse_qualifiers THEN
        local_value_qualifiers^ [index].kind := clc$substring_qualifier;
        local_value_qualifiers^ [index].index := specified_index;
        local_value_qualifiers^ [index].size := specified_size;
        local_value_qualifiers^ [index].all_specified := all_specified;
        local_value_qualifiers^ [index].parse := NIL;
      IFEND;

    PROCEND evaluate_substring_qualifier;
?? TITLE := 'evaluate_var_param_qualifiers', EJECT ??

    PROCEDURE evaluate_var_param_qualifiers;

{
{ Currently, the only kind of qualifiers that can make up the
{ var_parameter_value_qualifiers are clc$array_subscript, clc$field_qualifier,
{ clc$list_subscript_qualifier, clc$substring_qualifier.  Unspecified and
{ invalid qualifiers are NOT allowed because this would constitute a
{ clc$union_type in the type description.  This is not allowed at this point.
{

      FOR index := 1 TO UPPERBOUND (local_value_qualifiers^) DO

        IF i_value <> NIL THEN
          kind := i_value^.kind;
        ELSE
          kind := local_value^.kind;
        IFEND;

        CASE local_value_qualifiers^ [index].kind OF

        = clc$array_subscript_qualifier =
          IF kind <> clc$array THEN
            osp$set_status_abnormal ('CL', cle$undefined_var_subscript, name, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  local_value_qualifiers^ [index].array_subscript, 10, FALSE, status);
            EXIT clp$read_qualified_data_value;
          IFEND;
          subscript := local_value_qualifiers^ [index].array_subscript;
          evaluate_array_subscript_qual;

        = clc$field_qualifier =
          evaluate_field_qualifier;

        = clc$list_subscript_qualifier =
          IF kind <> clc$list THEN
            osp$set_status_abnormal ('CL', cle$undefined_var_subscript, name, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  local_value_qualifiers^ [index].list_subscript, 10, FALSE, status);
            EXIT clp$read_qualified_data_value;
          IFEND;
          subscript := local_value_qualifiers^ [index].list_subscript;
          evaluate_list_subscript_qual;

        = clc$substring_qualifier =
          IF kind <> clc$string THEN
            osp$set_status_abnormal ('CL', cle$undefined_var_substring, name, status);
            EXIT clp$read_qualified_data_value;
          IFEND;
          specified_index := local_value_qualifiers^ [index].index;
          specified_size := local_value_qualifiers^ [index].size;
          all_specified := local_value_qualifiers^ [index].all_specified;
          evaluate_substring_qualifier;

        ELSE

{ Should never get here.

          osp$set_status_abnormal ('CL', cle$internal_read_qualifier_err, name, status);
          EXIT clp$read_qualified_data_value;
        CASEND;
      FOREND;

    PROCEND evaluate_var_param_qualifiers;
?? TITLE := 'evaluate_parse_qualifiers', EJECT ??

    PROCEDURE evaluate_parse_qualifiers;

      VAR
        separator: string (1);


{
{ Currently, the only kind of qualifiers that make up the
{ parse_value_qualifiers are unspecified and invalid qualifiers.
{

    /evaluate_qualifiers/
      FOR index := 1 TO UPPERBOUND (local_value_qualifiers^) DO

        IF i_value <> NIL THEN
          kind := i_value^.kind;
        ELSE
          kind := local_value^.kind;
        IFEND;

        CASE kind OF

        = clc$array =
          CASE local_value_qualifiers^ [index].kind OF
          = clc$unspecified_subscript_qual =
            subscript := local_value_qualifiers^ [index].unspecified_subscript;
          = clc$invalid_subscript_qual =
            IF local_value_qualifiers^ [index].subscript_defined THEN
              subscript := local_value_qualifiers^ [index].invalid_subscript;
              evaluate_array_subscript_qual;
            IFEND;
            status := local_value_qualifiers^ [index].invalid_subscript_status^;
            EXIT clp$read_qualified_data_value;
          = clc$unspecified_substring_qual, clc$invalid_substring_qual =
            IF local_value_qualifiers^ [index].kind = clc$invalid_substring_qual THEN
              subscript := local_value_qualifiers^ [index].invalid_index;
              separator := local_value_qualifiers^ [index].invalid_separator;
            ELSE
              subscript := local_value_qualifiers^ [index].unspecified_index;
              separator := local_value_qualifiers^ [index].unspecified_separator;
            IFEND;
            evaluate_array_subscript_qual;
            osp$set_status_abnormal ('CL', cle$expecting_rparen_of_subscr, name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, separator, status);
            EXIT clp$read_qualified_data_value;
          ELSE
{
{ There is NO clc$array_subscript_qualifier , clc$substring_qualifier, or clc$list_qualifier.
{ This is for clc$unspecified_field_qualifier or clc$invalid_field_qualifier.
{
            reset_parse := TRUE;
            EXIT /evaluate_qualifiers/;
          CASEND;
          evaluate_array_subscript_qual;

        = clc$list =
          CASE local_value_qualifiers^ [index].kind OF
          = clc$unspecified_subscript_qual =
            subscript := local_value_qualifiers^ [index].unspecified_subscript;
          = clc$invalid_subscript_qual =
            IF local_value_qualifiers^ [index].subscript_defined THEN
              subscript := local_value_qualifiers^ [index].invalid_subscript;
              evaluate_list_subscript_qual;
            IFEND;
            status := local_value_qualifiers^ [index].invalid_subscript_status^;
            EXIT clp$read_qualified_data_value;
          = clc$unspecified_substring_qual, clc$invalid_substring_qual =
            IF local_value_qualifiers^ [index].kind = clc$invalid_substring_qual THEN
              subscript := local_value_qualifiers^ [index].invalid_index;
              separator := local_value_qualifiers^ [index].invalid_separator;
            ELSE
              subscript := local_value_qualifiers^ [index].unspecified_index;
              separator := local_value_qualifiers^ [index].unspecified_separator;
            IFEND;
            evaluate_list_subscript_qual;
            osp$set_status_abnormal ('CL', cle$expecting_rparen_of_subscr, name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, separator, status);
            EXIT clp$read_qualified_data_value;
          ELSE
{
{ There is NO clc$array_subscript_qualifier , clc$substring_qualifier, or clc$list_qualifier.
{ This is for clc$unspecified_field_qualifier or clc$invalid_field_qualifier.
{
            reset_parse := TRUE;
            EXIT /evaluate_qualifiers/;
          CASEND;
          evaluate_list_subscript_qual;

        = clc$string =
          CASE local_value_qualifiers^ [index].kind OF
          = clc$unspecified_substring_qual =
            specified_index := local_value_qualifiers^ [index].unspecified_index;
            specified_size := local_value_qualifiers^ [index].unspecified_size;
            all_specified := local_value_qualifiers^ [index].unspecified_all_found;
          = clc$unspecified_subscript_qual =
            specified_index := local_value_qualifiers^ [index].unspecified_subscript;
            specified_size := 1;
            all_specified := FALSE;
          = clc$invalid_substring_qual =
            specified_index := local_value_qualifiers^ [index].invalid_index;
            IF local_value_qualifiers^ [index].size_defined THEN
              specified_size := local_value_qualifiers^ [index].invalid_size;
              all_specified := FALSE;
            ELSE
              all_specified := TRUE;
            IFEND;
            evaluate_substring_qualifier;
            status := local_value_qualifiers^ [index].invalid_substring_status^;
            EXIT clp$read_qualified_data_value;
          = clc$invalid_subscript_qual =
            IF local_value_qualifiers^ [index].subscript_defined THEN
              specified_index := local_value_qualifiers^ [index].invalid_subscript;
              specified_size := 1;
              all_specified := FALSE;
              evaluate_substring_qualifier;
            IFEND;
            status := local_value_qualifiers^ [index].invalid_subscript_status^;
            EXIT clp$read_qualified_data_value;
          ELSE
{
{ There is NO clc$array_subscript_qualifier , clc$substring_qualifier, or clc$list_qualifier.
{ This is for clc$unspecified_field_qualifier or clc$invalid_field_qualifier.
{
            reset_parse := TRUE;
            EXIT /evaluate_qualifiers/;
          CASEND;
          evaluate_substring_qualifier;

        = clc$command_reference, clc$date_time, clc$entry_point_reference, clc$range, clc$record,
              clc$scu_line_identifier, clc$status, clc$time_increment, clc$time_zone =
          CASE local_value_qualifiers^ [index].kind OF
          = clc$unspecified_field_qualifier =
            evaluate_field_qualifier;
          = clc$invalid_field_qualifier =
            IF possible_file_reference AND (local_value_qualifiers^ [index].invalid_field_status^.condition
                 = cle$expecting_field_name) THEN
              reset_parse := TRUE;
            ELSE
              status := local_value_qualifiers^ [index].invalid_field_status^;
              EXIT clp$read_qualified_data_value;
            IFEND;
          ELSE
{
{ There is NO clc$field_qualifier.
{ This is for clc$unspecified_subscript_qualifier, clc$unspecified_substring_qualifier,
{ clc$invalid_subscript_qual, and clc$invalid_substring_qual.
{
            reset_parse := TRUE;
          CASEND;
          IF reset_parse THEN
            EXIT /evaluate_qualifiers/;
          IFEND;

        = clc$unspecified =
          osp$set_status_abnormal ('CL', cle$unexpected_qual_for_unspec, name, status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, local_value_qualifiers^ [index].
                parse^, status);
          EXIT clp$read_qualified_data_value;
        ELSE
          reset_parse := TRUE;
          EXIT /evaluate_qualifiers/;
        CASEND;
      FOREND /evaluate_qualifiers/;

    PROCEND evaluate_parse_qualifiers;
?? OLDTITLE, EJECT ??

{ It is assumed that either "internal_value" is not nil or that the
{ initial state of "data_value" is not nil, but not both.
{ Var_parameter_value_qualifiers were created by the procedure CLP$GET_WRITE_VALUE_QUALIFIERS.
{ Parse_value_qualifiers were created by the procedure CLP$GET_READ_VALUE_QUALIFIERS.
{


    status.normal := TRUE;
    parse_value_qualifier_index := 0;
    local_type_description := type_description;
    reset_parse := FALSE;
    evaluating_parse_qualifiers := FALSE;

    return_type_description := clc$return_type_description IN access_variable_requests;
    return_parse_value_qualifiers := clc$return_value_qualifiers IN access_variable_requests;
    possible_file_reference := clc$possible_file_reference IN access_variable_requests;
    convert_nil_value_to_unspec := clc$convert_nil_value_to_unspec IN access_variable_requests;

    IF internal_value <> NIL THEN
      i_value := #PTR (internal_value^.header.value, internal_value^);
      local_value := NIL;
    ELSE
      i_value := NIL;
      local_value := data_value;
    IFEND;

  /read_value/
    BEGIN
      IF var_parameter_value_qualifiers <> NIL THEN
        local_value_qualifiers := var_parameter_value_qualifiers;
        evaluate_var_param_qualifiers;

        IF (i_value = NIL) AND (local_value = NIL) AND (parse_value_qualifiers <> NIL) THEN
          IF convert_nil_value_to_unspec THEN
            clp$make_unspecified_value (work_area, local_value);
            IF local_value = NIL THEN
              osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
              RETURN;
            IFEND;
          ELSEIF NOT possible_file_reference THEN
*IF NOT $true(osv$unix)
            osp$set_status_abnormal ('CL', cle$cannot_read_component, name, status);
*ELSE
            osp$set_status_abnormal ('CL', cle$not_supported, 'Variables are', status);
*IFEND
            RETURN;
          ELSE
            reset_parse := TRUE;
            EXIT /read_value/;
          IFEND;
        IFEND;
      IFEND;

      IF parse_value_qualifiers <> NIL THEN
        evaluating_parse_qualifiers := TRUE;
        local_value_qualifiers := parse_value_qualifiers;
        evaluate_parse_qualifiers;
      IFEND;

    END /read_value/;

    IF return_type_description THEN
      type_description := local_type_description;
    IFEND;

    IF reset_parse AND (parse_value_qualifiers <> NIL) THEN
      IF evaluating_parse_qualifiers THEN
        parse_value_qualifier_index := index;
      ELSE
        parse_value_qualifier_index := 1;
      IFEND;
    IFEND;

    IF i_value <> NIL THEN
*IF NOT $true(osv$unix)
      clp$convert_int_value_to_ext (internal_value, #REL (i_value, internal_value^), work_area, data_value,
            status);
*ELSE
{ I don't think we should get here for PHASE I, but if we do, just set status
{ to abnormal.
      osp$set_status_abnormal ('CL', cle$not_supported, 'Variables are',
            status);
*IFEND
    ELSE
      data_value := local_value;
    IFEND;

  PROCEND clp$read_qualified_data_value;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$write_qualified_data_value', EJECT ??

  PROCEDURE [XDCL] clp$write_qualified_data_value
    (    name: clt$variable_name;
         value_qualifiers: ^clt$value_qualifiers;
         old_value: ^clt$internal_data_value;
         replacement_value: ^clt$data_value;
         conformance_checked: boolean;
         allow_padding_or_truncation: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR new_value: ^clt$internal_data_value;
     VAR status: ost$status);

    VAR
      all_specified: boolean,
      elements: ^array [ * ] of REL (clt$internal_data_value) ^clt$i_data_value,
      graft_address: ^ REL (clt$internal_data_value) ^clt$i_data_value,
      index: integer,
      initial_position: integer,
      i_value: ^clt$i_data_value,
      max_string_size: clt$string_size,
      min_string_size: clt$string_size,
      new_value_size: integer,
      replacement_value_address: ^ REL (clt$internal_data_value) ^clt$i_data_value,
      replacement_value_string_size: integer,
{
{ Specified_index, specified_size, and subscript are defined as integers.
{ Unspecified value_qualifier information has not been validated yet.
{
      specified_index: integer,
      specified_size: integer,
      status_text_size: ^ost$string_size,
      string_address: ^clt$string_value,
      string_index: clt$string_index,
      string_size: clt$string_size,
      subscript: integer,
      write_complete: boolean;

?? NEWTITLE := 'evaluate_array_subscript_qual', EJECT ??

    PROCEDURE evaluate_array_subscript_qual;

      VAR
        i: clt$array_bound,
        lower_bound: clt$array_bound,
        upper_bound: clt$array_bound;


      IF i_value = NIL THEN
        start_new_value;
        i_value^.kind := clc$array;
        lower_bound := value_qualifiers^ [index].bounds.lower;
        upper_bound := value_qualifiers^ [index].bounds.upper;
        NEXT elements: [lower_bound .. upper_bound] IN work_area;
        IF elements = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          EXIT clp$write_qualified_data_value;
        IFEND;
        i_value^.array_value := #REL (elements, new_value^);
        FOR i := lower_bound TO upper_bound DO
          elements^ [i] := NIL;
        FOREND;
      IFEND;

      IF new_value = NIL THEN
        graft_address := ^elements^ [subscript];
        i_value := #PTR (elements^ [subscript], old_value^);
      ELSE
        replacement_value_address := ^elements^ [subscript];
        i_value := #PTR (elements^ [subscript], new_value^);
      IFEND;

    PROCEND evaluate_array_subscript_qual;
?? TITLE := 'evaluate_field_qualifier', EJECT ??

    PROCEDURE evaluate_field_qualifier;

      VAR
        current_value: ^clt$internal_data_value,
        field_name: clt$field_name,
        fields: ^array [1 .. * ] of clt$internal_field_value,
        i: clt$field_number,
        new_command_reference: ^clt$command_reference,
        new_entry_point_reference: ^pmt$entry_point_reference,
        new_status: ^ost$status,
        new_time_increment: ^pmt$time_increment;


      IF i_value <> NIL THEN
        current_value := old_value;
      ELSE
        start_new_value;
        CASE value_qualifiers^ [index].record_kind OF

        = clc$command_reference_record =
          i_value^.kind := clc$command_reference;
          NEXT new_command_reference IN work_area;
          IF new_command_reference = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            EXIT clp$write_qualified_data_value;
          IFEND;
          new_command_reference^.name := '';
          new_command_reference^.form := clc$name_only_command_ref;
          i_value^.command_reference_value := #REL (new_command_reference, new_value^);

        = clc$date_time_record =
          i_value^.kind := clc$date_time;
          pmp$get_compact_date_time (i_value^.date_time_value.value, status);
          IF NOT status.normal THEN
            EXIT clp$write_qualified_data_value;
          IFEND;
          i_value^.date_time_value.value.hour := 0;
          i_value^.date_time_value.value.minute := 0;
          i_value^.date_time_value.value.second := 0;
          i_value^.date_time_value.value.millisecond := 0;
          i_value^.date_time_value.date_specified := FALSE;
          i_value^.date_time_value.time_specified := FALSE;

        = clc$entry_point_ref_record =
          i_value^.kind := clc$entry_point_reference;
          NEXT new_entry_point_reference IN work_area;
          IF new_entry_point_reference = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            EXIT clp$write_qualified_data_value;
          IFEND;
          new_entry_point_reference^.entry_point := '';
          new_entry_point_reference^.object_library := '';
          i_value^.entry_point_reference_value := #REL (new_entry_point_reference, new_value^);

        = clc$record_record =
          i_value^.kind := clc$record;
          NEXT fields: [1 .. UPPERBOUND (value_qualifiers^ [index].field_names^)] IN work_area;
          IF fields = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            EXIT clp$write_qualified_data_value;
          IFEND;
          FOR i := 1 TO UPPERBOUND (fields^) DO
            fields^ [i].name := value_qualifiers^ [index].field_names^ [i].name;
            fields^ [i].value := NIL;
          FOREND;
          i_value^.field_values := #REL (fields, new_value^);

        = clc$scu_line_ident_record =
          i_value^.kind := clc$scu_line_identifier;
          i_value^.scu_line_identifier_value.modification_name := '';
          i_value^.scu_line_identifier_value.sequence_number := 1;

        = clc$status_record =
          i_value^.kind := clc$status;
          NEXT new_status IN work_area;
          IF new_status = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            EXIT clp$write_qualified_data_value;
          IFEND;
          new_status^.normal := TRUE;
          i_value^.status_value := #REL (new_status, new_value^);

        = clc$time_increment_record =
          i_value^.kind := clc$time_increment;
          NEXT new_time_increment IN work_area;
          IF new_time_increment = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            EXIT clp$write_qualified_data_value;
          IFEND;
          new_time_increment^.year := 0;
          new_time_increment^.month := 0;
          new_time_increment^.day := 0;
          new_time_increment^.hour := 0;
          new_time_increment^.minute := 0;
          new_time_increment^.second := 0;
          new_time_increment^.millisecond := 0;
          i_value^.time_increment_value := #REL (new_time_increment, new_value^);

        = clc$time_zone_record =
          i_value^.kind := clc$time_zone;
          i_value^.time_zone_value.hours_from_gmt := 0;
          i_value^.time_zone_value.minutes_offset := 0;
          i_value^.time_zone_value.daylight_saving_time := FALSE;

        ELSE
          osp$set_status_abnormal ('CL', cle$cannot_initialize_component, name, status);
          EXIT clp$write_qualified_data_value;
        CASEND;

        current_value := new_value;
      IFEND;


      field_name := value_qualifiers^ [index].field_name;

    /field_known/
      BEGIN

      /field_accessible/
        BEGIN

        /field_defined/
          BEGIN

          /valid_replacement_value_kind/
            BEGIN

            /valid_replacement_value/
              BEGIN
                CASE i_value^.kind OF

                = clc$command_reference =

                  new_command_reference := #PTR (i_value^.command_reference_value, current_value^);
                  IF field_name = 'NAME' THEN
                    IF replacement_value^.kind <> clc$name THEN
                      EXIT /valid_replacement_value_kind/;
                    IFEND;
                    new_command_reference^.name := replacement_value^.name_value;
                  ELSEIF field_name = 'FORM' THEN
                    IF replacement_value^.kind <> clc$keyword THEN
                      EXIT /valid_replacement_value_kind/;
                    IFEND;
                    IF replacement_value^.keyword_value = 'NAME_ONLY' THEN
                      new_command_reference^.form := clc$name_only_command_ref;
                    ELSEIF replacement_value^.keyword_value = 'SKIP_FIRST_ENTRY' THEN
                      new_command_reference^.form := clc$skip_1st_entry_command_ref;
                    ELSEIF replacement_value^.keyword_value = 'SYSTEM' THEN
                      new_command_reference^.form := clc$system_command_ref;
                    ELSEIF replacement_value^.keyword_value = 'UTILITY' THEN
                      new_command_reference^.form := clc$utility_command_ref;
                      new_command_reference^.utility := '';
                    ELSEIF replacement_value^.keyword_value = 'MODULE_OR_FILE' THEN
                      new_command_reference^.form := clc$module_or_file_command_ref;
                      new_command_reference^.library_or_catalog := '';
                    ELSEIF replacement_value^.keyword_value = 'FILE_CYCLE' THEN
                      new_command_reference^.form := clc$file_cycle_command_ref;
                      new_command_reference^.catalog := '';
                      new_command_reference^.cycle_number := 1;
                    ELSE
                      EXIT /valid_replacement_value/;
                    IFEND;
                  ELSEIF field_name = 'UTILITY' THEN
                    IF new_command_reference^.form <> clc$utility_command_ref THEN
                      EXIT /field_accessible/;
                    ELSEIF replacement_value^.kind <> clc$name THEN
                      EXIT /valid_replacement_value_kind/;
                    IFEND;
                    new_command_reference^.utility := replacement_value^.name_value;
                  ELSEIF field_name = 'LIBRARY_OR_CATALOG' THEN
                    IF replacement_value^.kind <> clc$file THEN
                      EXIT /valid_replacement_value_kind/;
                    IFEND;
                    CASE new_command_reference^.form OF
                    = clc$module_or_file_command_ref =
                      new_command_reference^.library_or_catalog := replacement_value^.file_value^;
                    = clc$file_cycle_command_ref =
                      new_command_reference^.catalog := replacement_value^.file_value^;
                    ELSE
                      EXIT /field_accessible/;
                    CASEND;
                  ELSEIF field_name = 'CYCLE_NUMBER' THEN
                    IF new_command_reference^.form <> clc$file_cycle_command_ref THEN
                      EXIT /field_accessible/;
                    ELSEIF replacement_value^.kind <> clc$integer THEN
                      EXIT /valid_replacement_value_kind/;
                    ELSEIF (replacement_value^.integer_value.value < 1) OR
                          (replacement_value^.integer_value.value > fsc$maximum_cycle_number) THEN
                      EXIT /valid_replacement_value/;
                    IFEND;
                    new_command_reference^.cycle_number := replacement_value^.integer_value.value;
                  ELSE
                    EXIT /field_known/;
                  IFEND;
                  write_complete := TRUE;

                = clc$date_time =

                  IF replacement_value^.kind <> clc$integer THEN
                    EXIT /valid_replacement_value_kind/;
                  IFEND;
                  IF field_name = 'YEAR' THEN
                    IF (replacement_value^.integer_value.value < 1900) OR
                          (replacement_value^.integer_value.value > 2155) THEN
                      EXIT /valid_replacement_value/;
                    IFEND;
                    i_value^.date_time_value.date_specified := TRUE;
                    i_value^.date_time_value.value.year := replacement_value^.integer_value.value - 1900;
                  ELSEIF field_name = 'MONTH' THEN
                    IF (replacement_value^.integer_value.value < 1) OR
                          (replacement_value^.integer_value.value > 12) THEN
                      EXIT /valid_replacement_value/;
                    IFEND;
                    i_value^.date_time_value.date_specified := TRUE;
                    i_value^.date_time_value.value.month := replacement_value^.integer_value.value;
                  ELSEIF field_name = 'DAY' THEN
                    IF (replacement_value^.integer_value.value < 1) OR
                          (replacement_value^.integer_value.value > 31) THEN
                      EXIT /valid_replacement_value/;
                    IFEND;
                    i_value^.date_time_value.date_specified := TRUE;
                    i_value^.date_time_value.value.day := replacement_value^.integer_value.value;
                  ELSEIF field_name = 'HOUR' THEN
                    IF (replacement_value^.integer_value.value < 0) OR
                          (replacement_value^.integer_value.value > 23) THEN
                      EXIT /valid_replacement_value/;
                    IFEND;
                    i_value^.date_time_value.time_specified := TRUE;
                    i_value^.date_time_value.value.hour := replacement_value^.integer_value.value;
                  ELSEIF field_name = 'MINUTE' THEN
                    IF (replacement_value^.integer_value.value < 0) OR
                          (replacement_value^.integer_value.value > 59) THEN
                      EXIT /valid_replacement_value/;
                    IFEND;
                    i_value^.date_time_value.time_specified := TRUE;
                    i_value^.date_time_value.value.minute := replacement_value^.integer_value.value;
                  ELSEIF field_name = 'SECOND' THEN
                    IF (replacement_value^.integer_value.value < 0) OR
                          (replacement_value^.integer_value.value > 59) THEN
                      EXIT /valid_replacement_value/;
                    IFEND;
                    i_value^.date_time_value.time_specified := TRUE;
                    i_value^.date_time_value.value.second := replacement_value^.integer_value.value;
                  ELSEIF field_name = 'MILLISECOND' THEN
                    IF (replacement_value^.integer_value.value < 0) OR
                          (replacement_value^.integer_value.value > 999) THEN
                      EXIT /valid_replacement_value/;
                    IFEND;
                    i_value^.date_time_value.time_specified := TRUE;
                    i_value^.date_time_value.value.millisecond := replacement_value^.integer_value.value;
                  ELSE
                    EXIT /field_known/;
                  IFEND;
                  write_complete := TRUE;

                = clc$entry_point_reference =

                  new_entry_point_reference := #PTR (i_value^.entry_point_reference_value, current_value^);
                  IF field_name = 'ENTRY_POINT' THEN
                    IF replacement_value^.kind <> clc$program_name THEN
                      EXIT /valid_replacement_value_kind/;
                    IFEND;
                    IF replacement_value^.program_name_value = 'none' THEN
                      new_entry_point_reference^.entry_point := osc$null_name;
                    ELSE
                      new_entry_point_reference^.entry_point := replacement_value^.program_name_value;
                    IFEND;
                  ELSEIF field_name = 'OBJECT_LIBRARY' THEN
                    IF new_entry_point_reference^.entry_point = osc$null_name THEN
                      EXIT /field_accessible/;
                    ELSEIF replacement_value^.kind <> clc$file THEN
                      EXIT /valid_replacement_value_kind/;
                    IFEND;
                    IF replacement_value^.file_value^ = '$NULL' THEN
                      new_entry_point_reference^.object_library := '';
                    ELSE
                      new_entry_point_reference^.object_library := replacement_value^.file_value^;
                    IFEND;
                  ELSE
                    EXIT /field_known/;
                  IFEND;
                  write_complete := TRUE;

                = clc$range =

                  IF field_name = 'HIGH' THEN
                    IF new_value = NIL THEN
                      graft_address := ^i_value^.high_value;
                      i_value := #PTR (i_value^.high_value, old_value^);
                    ELSE
                      replacement_value_address := ^i_value^.high_value;
                      i_value := #PTR (i_value^.high_value, new_value^);
                    IFEND;
                  ELSEIF field_name = 'LOW' THEN
                    IF new_value = NIL THEN
                      graft_address := ^i_value^.low_value;
                      i_value := #PTR (i_value^.low_value, old_value^);
                    ELSE
                      replacement_value_address := ^i_value^.low_value;
                      i_value := #PTR (i_value^.low_value, new_value^);
                    IFEND;
                  ELSE
                    EXIT /field_known/;
                  IFEND;

                = clc$record =

                /find_record_field/
                  BEGIN
                    fields := #PTR (i_value^.field_values, current_value^);
                    FOR i := 1 TO UPPERBOUND (fields^) DO
                      IF fields^ [i].name = field_name THEN
                        IF new_value = NIL THEN
                          graft_address := ^fields^ [i].value;
                          i_value := #PTR (fields^ [i].value, old_value^);
                        ELSE
                          replacement_value_address := ^fields^ [i].value;
                          i_value := #PTR (fields^ [i].value, new_value^);
                        IFEND;
                        EXIT /find_record_field/;
                      IFEND;
                    FOREND;
                    EXIT /field_known/;
                  END /find_record_field/;

                = clc$scu_line_identifier =

                  IF field_name = 'MODIFICATION_NAME' THEN
                    IF replacement_value^.kind <> clc$name THEN
                      EXIT /valid_replacement_value_kind/;
                    ELSEIF clp$trimmed_string_size (replacement_value^.name_value) >
                          clc$max_scu_modification_name THEN
                      EXIT /valid_replacement_value_kind/;
                    IFEND;
                    i_value^.scu_line_identifier_value.modification_name := replacement_value^.name_value;
                  ELSEIF field_name = 'SEQUENCE_NUMBER' THEN
                    IF replacement_value^.kind <> clc$integer THEN
                      EXIT /valid_replacement_value_kind/;
                    ELSEIF (replacement_value^.integer_value.value < 1) OR
                          (replacement_value^.integer_value.value > clc$max_scu_sequence_number) THEN
                      EXIT /valid_replacement_value/;
                    IFEND;
                    i_value^.scu_line_identifier_value.sequence_number :=
                          replacement_value^.integer_value.value;
                  ELSE
                    EXIT /field_known/;
                  IFEND;
                  write_complete := TRUE;

                = clc$status =

                  new_status := #PTR (i_value^.status_value, current_value^);
                  IF field_name = 'NORMAL' THEN
                    IF replacement_value^.kind <> clc$boolean THEN
                      EXIT /valid_replacement_value_kind/;
                    IFEND;
                    new_status^.normal := replacement_value^.boolean_value.value;
                    IF NOT new_status^.normal THEN
                      new_status^.condition := 0;
                      new_status^.text.size := 0;
                    IFEND;
                    write_complete := TRUE;
                  ELSEIF field_name = 'CONDITION' THEN
                    IF new_status^.normal THEN
                      EXIT /field_accessible/;
                    ELSEIF replacement_value^.kind <> clc$status_code THEN
                      EXIT /valid_replacement_value_kind/;
                    IFEND;
                    new_status^.condition := replacement_value^.status_code_value;
                    write_complete := TRUE;
                  ELSEIF field_name = 'TEXT' THEN
                    IF new_status^.normal THEN
                      EXIT /field_accessible/;
                    IFEND;
                    string_address := ^new_status^.text.value;
                    string_index := 1;
                    string_size := new_status^.text.size;
                    IF string_size > osc$max_string_size THEN
                      string_size := 0;
                    IFEND;
                    status_text_size := ^new_status^.text.size;
                  ELSE
                    EXIT /field_known/;
                  IFEND;

                = clc$time_increment =

                  new_time_increment := #PTR (i_value^.time_increment_value, current_value^);
                  IF replacement_value^.kind <> clc$integer THEN
                    EXIT /valid_replacement_value_kind/;
                  IFEND;
                  IF field_name = 'YEARS' THEN
                    new_time_increment^.year := replacement_value^.integer_value.value;
                  ELSEIF field_name = 'MONTHS' THEN
                    new_time_increment^.month := replacement_value^.integer_value.value;
                  ELSEIF field_name = 'DAYS' THEN
                    new_time_increment^.day := replacement_value^.integer_value.value;
                  ELSEIF field_name = 'HOURS' THEN
                    new_time_increment^.hour := replacement_value^.integer_value.value;
                  ELSEIF field_name = 'MINUTES' THEN
                    new_time_increment^.minute := replacement_value^.integer_value.value;
                  ELSEIF field_name = 'SECONDS' THEN
                    new_time_increment^.second := replacement_value^.integer_value.value;
                  ELSEIF field_name = 'MILLISECONDS' THEN
                    new_time_increment^.millisecond := replacement_value^.integer_value.value;
                  ELSE
                    EXIT /field_known/;
                  IFEND;
                  write_complete := TRUE;

                = clc$time_zone =

                  IF field_name = 'HOURS_FROM_GMT' THEN
                    IF replacement_value^.kind <> clc$integer THEN
                      EXIT /valid_replacement_value_kind/;
                    ELSEIF (replacement_value^.integer_value.value < -12) OR
                          (replacement_value^.integer_value.value > 12) THEN
                      EXIT /valid_replacement_value/;
                    IFEND;
                    i_value^.time_zone_value.hours_from_gmt := replacement_value^.integer_value.value;
                  ELSEIF field_name = 'MINUTES_OFFSET' THEN
                    IF replacement_value^.kind <> clc$integer THEN
                      EXIT /valid_replacement_value_kind/;
                    ELSEIF (replacement_value^.integer_value.value < -30) OR
                          (replacement_value^.integer_value.value > 30) THEN
                      EXIT /valid_replacement_value/;
                    IFEND;
                    i_value^.time_zone_value.minutes_offset := replacement_value^.integer_value.value;
                  ELSEIF field_name = 'DAYLIGHT_SAVING_TIME' THEN
                    IF replacement_value^.kind <> clc$boolean THEN
                      EXIT /valid_replacement_value_kind/;
                    IFEND;
                    i_value^.time_zone_value.daylight_saving_time := replacement_value^.boolean_value.value;
                  ELSE
                    EXIT /field_known/;
                  IFEND;
                  write_complete := TRUE;

                CASEND;
                RETURN;

              END /valid_replacement_value/;
              osp$set_status_abnormal ('CL', cle$improper_variable_value, name, status);
              EXIT clp$write_qualified_data_value;

            END /valid_replacement_value_kind/;
            osp$set_status_abnormal ('CL', cle$incompatible_assignment, name, status);
            EXIT clp$write_qualified_data_value;

          END /field_defined/;
          osp$set_status_abnormal ('CL', cle$undefined_field, field_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
          EXIT clp$write_qualified_data_value;

        END /field_accessible/;
        osp$set_status_abnormal ('CL', cle$unaccessible_field, field_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
        EXIT clp$write_qualified_data_value;

      END /field_known/;
      IF i_value^.kind = clc$range THEN
        osp$set_status_abnormal ('CL', cle$unknown_range_selector, field_name, status);
      ELSE
        osp$set_status_abnormal ('CL', cle$unknown_field, field_name, status);
      IFEND;
      osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
      EXIT clp$write_qualified_data_value;

    PROCEND evaluate_field_qualifier;
?? TITLE := 'evaluate_list_subscript_qual', EJECT ??

    PROCEDURE evaluate_list_subscript_qual;

      VAR
        i: clt$list_size;


      i := 1;
      WHILE (i < subscript) AND (i_value^.link <> NIL) DO
        i_value := #PTR (i_value^.link, old_value^);
        i := i + 1;
      WHILEND;

      IF i < subscript THEN
        osp$set_status_abnormal ('CL', cle$cannot_initialize_component, name, status);
        EXIT clp$write_qualified_data_value;
      IFEND;

      graft_address := ^i_value^.element_value;
      i_value := #PTR (i_value^.element_value, old_value^);

    PROCEND evaluate_list_subscript_qual;
?? TITLE := 'evaluate_substring_qualifier', EJECT ??

    PROCEDURE evaluate_substring_qualifier;

      VAR
        new_string: boolean,
        test_size: integer;


      status_text_size := NIL;
      new_string := string_address = NIL;

      IF new_string THEN
        string_address := #PTR (i_value^.string_value, old_value^);
        string_size := STRLENGTH (string_address^);
      IFEND;

      IF (specified_index < 1) OR (specified_index > (string_size + 1)) THEN
        osp$set_status_abnormal ('CL', cle$substr_index_out_of_range, name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, specified_index, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, string_size + 1, 10, FALSE, status);
        EXIT clp$write_qualified_data_value;
      IFEND;

      IF new_string THEN
        string_index := specified_index;
        test_size := string_size - string_index + 1;
      ELSE
        string_index := string_index + specified_index - 1;
        test_size := string_size - specified_index + 1;
      IFEND;

      IF all_specified THEN
        string_size := test_size;
      ELSE
        IF specified_size > test_size THEN
          osp$set_status_abnormal ('CL', cle$substr_size_out_of_range, name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, specified_size, 10, FALSE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, test_size, 10, FALSE, status);
          EXIT clp$write_qualified_data_value;
        IFEND;
        string_size := specified_size;
      IFEND;

    PROCEND evaluate_substring_qualifier;
?? TITLE := 'start_new_value', EJECT ??

    PROCEDURE [INLINE] start_new_value;

      VAR
        header: ^clt$internal_data_value_header;


      IF new_value = NIL THEN
        initial_position := i#current_sequence_position (work_area);
        new_value_size := #SIZE (work_area^) - initial_position - #SIZE (clt$internal_data_value_header);
        IF new_value_size < #SIZE (clt$i_data_value) THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          EXIT clp$write_qualified_data_value;
        IFEND;
        NEXT new_value: [[REP new_value_size OF cell]] IN work_area;
        RESET work_area TO new_value;
        NEXT header IN work_area;
        NEXT i_value IN work_area;
        header^.value := #REL (i_value, new_value^);
        header^.unused_space := 0;
        header^.minimum_allocation_increment := 0;
      ELSE
        NEXT i_value IN work_area;
        IF i_value = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          EXIT clp$write_qualified_data_value;
        IFEND;
        IF replacement_value_address <> NIL THEN
          replacement_value_address^ := #REL (i_value, new_value^);
          replacement_value_address := NIL;
        IFEND;
      IFEND;

    PROCEND start_new_value;
?? OLDTITLE, EJECT ??

{
{ An assumption is made that the initial value of value_qualifiers is NOT NIL.
{ Value_qualifiers were created by the procedure CLP$GET_WRITE_VALUE_QUALIFIERS.
{


    status.normal := TRUE;
    new_value := NIL;
    IF old_value = NIL THEN
      i_value := NIL;
    ELSE
      i_value := #PTR (old_value^.header.value, old_value^);
    IFEND;
    graft_address := NIL;
    replacement_value_address := NIL;
    write_complete := FALSE;
    string_address := NIL;
    status_text_size := NIL;

    FOR index := 1 TO UPPERBOUND (value_qualifiers^) DO

      IF i_value = NIL THEN
        CASE value_qualifiers^ [index].kind OF
        = clc$array_subscript_qualifier, clc$field_qualifier =
{ Initialization "by component" is allowed for an array or record.
        ELSE
          osp$set_status_abnormal ('CL', cle$cannot_initialize_component, name, status);
          RETURN;
        CASEND;
      IFEND;

      CASE value_qualifiers^ [index].kind OF

      = clc$array_subscript_qualifier =
        subscript := value_qualifiers^ [index].array_subscript;
        IF i_value <> NIL THEN
          elements := #PTR (i_value^.array_value, old_value^);
        IFEND;
        evaluate_array_subscript_qual;

      = clc$field_qualifier =
        evaluate_field_qualifier;

      = clc$list_subscript_qualifier =
        subscript := value_qualifiers^ [index].list_subscript;
        evaluate_list_subscript_qual;

      = clc$substring_qualifier =
        specified_index := value_qualifiers^ [index].index;
        specified_size := value_qualifiers^ [index].size;
        all_specified := value_qualifiers^ [index].all_specified;
        evaluate_substring_qualifier;

      = clc$unspecified_field_qualifier =
        CASE i_value^.kind OF
        = clc$command_reference, clc$date_time, clc$entry_point_reference, clc$range, clc$record,
              clc$scu_line_identifier, clc$status, clc$time_increment, clc$time_zone =
          IF string_address <> NIL THEN
            osp$set_status_abnormal ('CL', cle$undefined_variable_field, value_qualifiers^ [index].field_name,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
            RETURN;
          IFEND;
          evaluate_field_qualifier;
          IF write_complete AND (index <> UPPERBOUND (value_qualifiers^)) THEN
            osp$set_status_abnormal ('CL', cle$undefined_var_qualifier, name, status);
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal ('CL', cle$undefined_variable_field, value_qualifiers^ [index].field_name,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
          RETURN;
        CASEND;

      = clc$unspecified_subscript_qual =
        CASE i_value^.kind OF
        = clc$array =
          subscript := value_qualifiers^ [index].unspecified_subscript;
          elements := #PTR (i_value^.array_value, old_value^);
          IF (subscript < LOWERBOUND (elements^)) OR (subscript > UPPERBOUND (elements^)) THEN
            osp$set_status_abnormal ('CL', cle$subscript_out_of_range, name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, subscript, 10, FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter, LOWERBOUND (elements^), 10, FALSE,
                  status);
            osp$append_status_integer (osc$status_parameter_delimiter, UPPERBOUND (elements^), 10, FALSE,
                  status);
            RETURN;
          IFEND;
          evaluate_array_subscript_qual;
        = clc$list =
          subscript := value_qualifiers^ [index].unspecified_subscript;
          evaluate_list_subscript_qual;
        = clc$string =
          specified_index := value_qualifiers^ [index].unspecified_subscript;
          specified_size := 1;
          all_specified := FALSE;
          evaluate_substring_qualifier;
        ELSE
          osp$set_status_abnormal ('CL', cle$undefined_var_subscript, name, status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                value_qualifiers^ [index].unspecified_subscript, 10, FALSE, status);
          RETURN;
        CASEND;

      = clc$unspecified_substring_qual =
        IF i_value^.kind <> clc$string THEN
          osp$set_status_abnormal ('CL', cle$undefined_var_substring, name, status);
          RETURN;
        IFEND;
        specified_index := value_qualifiers^ [index].unspecified_index;
        specified_size := value_qualifiers^ [index].unspecified_size;
        all_specified := value_qualifiers^ [index].unspecified_all_found;
        evaluate_substring_qualifier;

      CASEND;
    FOREND;

{ Change the value component if it has not been changed yet.
{ The only place where the value component could be changed
{ already is in evaluate_field_qualifier.

    IF string_address <> NIL THEN
      IF replacement_value^.kind <> clc$string THEN
        osp$set_status_abnormal ('CL', cle$bad_data_value, name, status);
        RETURN;
      IFEND;
      replacement_value_string_size := STRLENGTH (replacement_value^.string_value^);
      IF status_text_size <> NIL THEN
        max_string_size := osc$max_string_size;
        min_string_size := 0;
        IF replacement_value_string_size > max_string_size THEN
          string_size := max_string_size;
        ELSE
          string_size := replacement_value_string_size;
        IFEND;
      ELSE
        max_string_size := string_size;
        min_string_size := string_size;
      IFEND;
      IF NOT allow_padding_or_truncation THEN
        IF replacement_value_string_size > max_string_size THEN
          osp$set_status_abnormal ('CL', cle$string_value_too_long, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, max_string_size, 10, FALSE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, replacement_value_string_size, 10, FALSE,
                status);
          clp$append_status_string (osc$status_parameter_delimiter, replacement_value^.string_value^, status);
          RETURN;
        ELSEIF replacement_value_string_size < min_string_size THEN
          osp$set_status_abnormal ('CL', cle$string_value_too_short, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, min_string_size, 10, FALSE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, replacement_value_string_size, 10, FALSE,
                status);
          clp$append_status_string (osc$status_parameter_delimiter, replacement_value^.string_value^, status);
          RETURN;
        IFEND;
      IFEND;
      string_address^ (string_index, string_size) := replacement_value^.string_value^;
      IF status_text_size <> NIL THEN
        status_text_size^ := string_size;
      IFEND;

    ELSEIF NOT write_complete THEN
      clp$convert_ext_value_to_int (NIL, replacement_value, replacement_value_address, work_area, new_value,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF old_value <> NIL THEN
      IF new_value <> NIL THEN
        clp$change_internal_value (conformance_checked, old_value, graft_address, work_area, new_value,
              status);
      ELSE
        new_value := old_value;
      IFEND;
    ELSE
      new_value_size := i#current_sequence_position (work_area) -
            initial_position - #SIZE (clt$internal_data_value_header);
      RESET work_area TO new_value;
      NEXT new_value: [[REP new_value_size OF cell]] IN work_area;
    IFEND;

  PROCEND clp$write_qualified_data_value;
*IFEND
?? TITLE := 'evaluate_union_type_description', EJECT ??

  PROCEDURE evaluate_union_type_description
    (    name: clt$variable_name;
         kind: clt$type_kind;
     VAR type_description {input, output} : ^clt$type_description;
     VAR status: ost$status);

    VAR
      index: integer;


    FOR index := 1 TO UPPERBOUND (type_description^.member_descriptions^) DO
      IF type_description^.member_descriptions^ [index].kind = kind THEN
        type_description := ^type_description^.member_descriptions^ [index];
        RETURN;
      IFEND;
    FOREND;

{ Should never get here.
    osp$set_status_abnormal ('CL', cle$internal_read_variable_err, name, status);

  PROCEND evaluate_union_type_description;

MODEND clm$process_value_qualifiers;
*DECK DECK=CLM$PROCESS_WHEN_CONDITION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Process When Condition' ??
MODULE clm$process_when_condition;

{
{ PURPOSE:
{   This module contains the routines that search for and invoke when condition processing.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$exiting_condition
*copyc cle$ecc_command_processing
*copyc clt$established_handler_index
*copyc clt$when_condition
*copyc jme$resource_condition
*copyc jme$time_limit_condition
*copyc osc$unseen_mail_condition
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc pmt$condition
*copyc pmt$condition_information
?? POP ??
*copyc clp$create_procedure_variable
*copyc clp$echo_trace_information
*copyc clp$find_connected_files
*copyc clp$find_current_block
*copyc clp$find_task_block
*copyc clp$get_variable_value
*copyc clp$pop_input_stack
*copyc clp$pop_terminated_blocks
*copyc clp$process_command_file
*copyc clp$push_when_input_block
*copyc clp$put_job_command_response
*copyc clp$restore_work_area_positions
*copyc clp$save_work_area_positions
*copyc clp$trimmed_string_size
*copyc clv$processing_phase
*copyc mmp$verify_access
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$generate_message
*copyc osp$get_status_severity
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$system_error
*copyc pmp$continue_to_cause
*copyc sfp$get_job_limit_name
?? TITLE := 'clp$determine_when_condition', EJECT ??

  PROCEDURE [XDCL] clp$determine_when_condition
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR when_condition: clt$when_condition_definition;
     VAR status: ost$status);

    VAR
      condition_information_status: ^ost$status;


    status.normal := TRUE;
    when_condition.name := osc$null_name;
    when_condition.status.normal := TRUE;
    when_condition.limit_name := osc$null_name;

    CASE condition.selector OF

    = ifc$interactive_condition =
      CASE condition.interactive_condition OF
      = ifc$job_reconnect =
        when_condition.name := clc$wc_reconnect;
      = ifc$pause_break =
        when_condition.name := clc$wc_pause;
      = ifc$terminal_connection_broken =
        when_condition.name := clc$wc_disconnect;
      = ifc$terminate_break =
        when_condition.name := clc$wc_terminate;
      ELSE
        ;
      CASEND;

    = jmc$job_resource_condition =
      when_condition.name := clc$wc_limit_fault;
      IF condition.job_resource_condition = jmc$time_limit_condition THEN
        when_condition.limit_name := 'CPU_TIME';
        osp$set_status_condition (jme$time_limit_condition, when_condition.status);
      ELSE
        sfp$get_job_limit_name (condition.job_resource_condition, when_condition.limit_name, status);
        IF NOT status.normal THEN
          when_condition.limit_name := 'UNKNOWN_LIMIT';
          status.normal := TRUE;
        IFEND;
        osp$set_status_abnormal ('CL', jme$resource_condition, when_condition.limit_name,
              when_condition.status);
      IFEND;

    = pmc$user_defined_condition =
      IF condition.user_condition_name = osc$unseen_mail_condition THEN
        when_condition.name := clc$wc_unseen_mail;
      ELSEIF (condition.user_condition_name <> clc$wc_exit) AND
            (condition.user_condition_name <> clc$wc_command_fault) AND
            (condition.user_condition_name <> clc$wc_execution_fault) THEN
        when_condition.name := condition.user_condition_name;
        IF (condition_information <> NIL) AND mmp$verify_access (^condition_information, mmc$va_read) THEN

{ Assume condition_information is a pointer to a ost$status record.

          condition_information_status := condition_information;
          when_condition.status := condition_information_status^;
        IFEND;
      IFEND;

    ELSE
      ;
    CASEND;

  PROCEND clp$determine_when_condition;
?? TITLE := 'clp$process_command_fault', EJECT ??

  PROCEDURE [XDCL] clp$process_command_fault
    (    condition_status: ost$status;
         input_block: ^clt$block;
     VAR retry_command: ^clt$command_line;
     VAR condition_processed_state: clt$condition_processed_state;
     VAR status: ost$status);

    VAR
      command: ^clt$command_line,
      command_name: clt$command_name,
      condition_definition: ^clt$when_condition_definition,
      handler_block: ^clt$block,
      handler_statements: ^clt$established_handler_stmnts;


    status.normal := TRUE;
    condition_processed_state := clc$no_handler_established;

    find_handler_block_for_input (input_block, handler_block);
    IF handler_block = NIL THEN
      handler_block := input_block;
      find_next_handler_block (inherited_input, handler_block);
    IFEND;

    condition_definition := NIL;

  /find_command_fault_handler/
    WHILE TRUE DO
      IF (handler_block = NIL) OR ((handler_block^.kind = clc$when_block) AND
            (handler_block^.when_condition^.name = clc$wc_command_fault)) THEN
        RETURN;
      IFEND;

      IF condition_definition = NIL THEN
        PUSH condition_definition;
        condition_definition^.name := clc$wc_command_fault;
        condition_definition^.status := condition_status;
        condition_definition^.limit_name := osc$null_name;
      IFEND;

      find_handler_in_block (any_established_handler, condition_definition^, handler_block,
            handler_statements);
      IF handler_statements <> NIL THEN
        EXIT /find_command_fault_handler/;
      IFEND;

      find_next_handler_block (inherited_input, handler_block);
    WHILEND /find_command_fault_handler/;

    process_when_condition (condition_definition^, TRUE, NIL, input_block^.previous_command.text,
          input_block^.previous_command_name, handler_statements, handler_block, retry_command,
          condition_processed_state, status);

  PROCEND clp$process_command_fault;
?? TITLE := 'clp$process_continued_condition', EJECT ??

  PROCEDURE [XDCL] clp$process_continued_condition
    (    when_block: ^clt$block;
         continue_when_condition_option: clt$condition_processed_state;
     VAR status: ost$status);

    VAR
      condition_definition: ^clt$when_condition_definition,
      handler_block: ^clt$block,
      handler_statements: ^clt$established_handler_stmnts,
      ignore_cond_processed_state: clt$condition_processed_state,
      ignore_retry_command: ^clt$command_line;


    status.normal := TRUE;
    handler_block := when_block^.static_link;

    condition_definition := NIL;

  /try_next_handler_block/
    WHILE TRUE DO
      find_next_handler_block (previous_block, handler_block);

      IF handler_block = NIL THEN
        IF (continue_when_condition_option = clc$continue_next_handler) AND
              (when_block^.when_condition^.default_handler <> NIL) THEN
          when_block^.when_condition^.default_handler^ (status);
        IFEND;
        RETURN;
      ELSEIF (handler_block^.kind = clc$when_block) AND (when_block^.when_condition^.name =
            handler_block^.when_condition^.name) AND (NOT when_block^.when_condition^.status.normal) THEN
        CYCLE /try_next_handler_block/;
      IFEND;

      IF condition_definition = NIL THEN
        PUSH condition_definition;
        condition_definition^.name := when_block^.when_condition^.name;
        condition_definition^.status := when_block^.when_condition^.status;
        condition_definition^.limit_name := when_block^.when_condition^.limit_name;
      IFEND;

      find_handler_in_block (any_established_handler, condition_definition^, handler_block,
            handler_statements);
      IF handler_statements = NIL THEN
        CYCLE /try_next_handler_block/;
      IFEND;

      process_when_condition (condition_definition^, FALSE, when_block^.when_condition^.default_handler,
            ^when_block^.when_condition^.command, when_block^.when_condition^.command_name,
            handler_statements, handler_block, ignore_retry_command, ignore_cond_processed_state, status);
      RETURN;
    WHILEND /try_next_handler_block/;

  PROCEND clp$process_continued_condition;
?? TITLE := 'clp$process_execution_fault', EJECT ??

  PROCEDURE [XDCL] clp$process_execution_fault
    (    condition_status: ost$status;
         input_block: ^clt$block;
     VAR retry_command: ^clt$command_line;
     VAR condition_processed_state: clt$condition_processed_state;
     VAR status: ost$status);

    VAR
      condition_definition: ^clt$when_condition_definition,
      handler_block: ^clt$block,
      handler_statements: ^clt$established_handler_stmnts;


    status.normal := TRUE;
    condition_processed_state := clc$no_handler_established;

    find_handler_block_for_input (input_block, handler_block);
    IF handler_block = NIL THEN
      handler_block := input_block;
      find_next_handler_block (previous_block, handler_block);
    IFEND;

    condition_definition := NIL;

  /find_execution_fault_handler/
    WHILE TRUE DO
      IF (handler_block = NIL) OR ((handler_block^.kind = clc$when_block) AND
            (handler_block^.when_condition^.name = clc$wc_execution_fault)) THEN
        RETURN;
      IFEND;

      IF condition_definition = NIL THEN
        PUSH condition_definition;
        condition_definition^.name := clc$wc_execution_fault;
        condition_definition^.status := condition_status;
        condition_definition^.limit_name := osc$null_name;
      IFEND;

      find_handler_in_block (specific_handler_only, condition_definition^, handler_block, handler_statements);
      IF handler_statements <> NIL THEN
        EXIT /find_execution_fault_handler/;
      IFEND;

      find_next_handler_block (previous_block, handler_block);
    WHILEND /find_execution_fault_handler/;

    process_when_condition (condition_definition^, TRUE, NIL, input_block^.previous_command.text,
          input_block^.previous_command_name, handler_statements, handler_block, retry_command,
          condition_processed_state, status);

  PROCEND clp$process_execution_fault;
?? TITLE := 'clp$process_exit_condition', EJECT ??

  PROCEDURE [XDCL] clp$process_exit_condition
    (    input_block: ^clt$block;
         exit_status: ost$status);

    VAR
      condition_definition: ^clt$when_condition_definition,
      handler_block: ^clt$block,
      handler_statements: ^clt$established_handler_stmnts,
      ignore_cond_processed_state: clt$condition_processed_state,
      ignore_retry_command: ^clt$command_line,
      ignore_status: ost$status;


    find_handler_block_for_input (input_block, handler_block);
    IF (handler_block = NIL) OR ((handler_block^.previous_block^.kind = clc$task_block) AND
          (handler_block^.previous_block^.task_kind = clc$job_monitor_task) AND
          (clv$processing_phase <> clc$command_phase)) THEN
      RETURN;
    IFEND;

    PUSH condition_definition;
    condition_definition^.name := clc$wc_exit;
    condition_definition^.status := exit_status;
    condition_definition^.limit_name := osc$null_name;

    find_handler_in_block (specific_handler_only, condition_definition^, handler_block, handler_statements);
    IF handler_statements = NIL THEN
      RETURN;
    IFEND;

    process_when_condition (condition_definition^, TRUE, NIL, NIL, osc$null_name, handler_statements,
          handler_block, ignore_retry_command, ignore_cond_processed_state, ignore_status);

  PROCEND clp$process_exit_condition;
?? TITLE := 'clp$process_when_cond_in_block', EJECT ??

  PROCEDURE [XDCL] clp$process_when_cond_in_block
    (    condition_definition: clt$when_condition_definition;
         input_block: ^clt$block;
         exit_on_continue_condition: boolean;
     VAR condition_processed: boolean;
     VAR status: ost$status);

    VAR
      command: ^clt$command_line,
      command_name: clt$command_name,
      condition_processed_state: clt$condition_processed_state,
      handler_block: ^clt$block,
      handler_statements: ^clt$established_handler_stmnts,
      ignore_retry_command: ^clt$command_line;


    status.normal := TRUE;
    condition_processed := FALSE;

    find_handler_block_for_input (input_block, handler_block);
    IF handler_block = NIL THEN
      RETURN;
    IFEND;

    find_handler_in_block (any_established_handler, condition_definition, handler_block, handler_statements);
    IF handler_statements = NIL THEN
      RETURN;
    IFEND;

    find_current_command (command, command_name);

    process_when_condition (condition_definition, exit_on_continue_condition, NIL, command, command_name,
          handler_statements, handler_block, ignore_retry_command, condition_processed_state, status);
    IF NOT status.normal THEN
      condition_processed := FALSE;
    ELSE
      CASE condition_processed_state OF
      = clc$continue_next_handler, clc$continue_next_user_handler =
        condition_processed := NOT exit_on_continue_condition;
      ELSE
        condition_processed := TRUE;
      CASEND;
    IFEND;

  PROCEND clp$process_when_cond_in_block;
?? TITLE := 'clp$process_when_cond_in_task', EJECT ??
*copyc clh$process_when_cond_in_task

  PROCEDURE [XDCL] clp$process_when_cond_in_task
    (    condition_definition: clt$when_condition_definition;
         default_handler: ^procedure (VAR status: ost$status);
     VAR condition_processed: boolean;
     VAR status: ost$status);

    VAR
      command: ^clt$command_line,
      command_name: clt$command_name,
      handler_block: ^clt$block,
      handler_statements: ^clt$established_handler_stmnts,
      ignore_cond_processed_state: clt$condition_processed_state,
      ignore_retry_command: ^clt$command_line;


    status.normal := TRUE;
    condition_processed := FALSE;

    clp$find_task_block (handler_block, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to get pointer to SCL Task Block', ^status);
    IFEND;

    WHILE TRUE DO

    /try_next_handler_block/
      BEGIN
        IF handler_block = NIL THEN
          RETURN;
        ELSEIF (handler_block^.kind = clc$when_block) AND (handler_block^.when_condition^.name =
              condition_definition.name) AND (NOT condition_definition.status.normal) THEN
          EXIT /try_next_handler_block/;
        IFEND;

        find_handler_in_block (any_established_handler, condition_definition, handler_block,
              handler_statements);
        IF handler_statements = NIL THEN
          EXIT /try_next_handler_block/;
        IFEND;

        find_current_command (command, command_name);

        process_when_condition (condition_definition, FALSE, default_handler, command, command_name,
              handler_statements, handler_block, ignore_retry_command, ignore_cond_processed_state, status);
        condition_processed := status.normal;
        RETURN;
      END /try_next_handler_block/;

      find_next_handler_block (previous_block, handler_block);
    WHILEND;

  PROCEND clp$process_when_cond_in_task;
?? TITLE := 'find_current_command', EJECT ??

  PROCEDURE [INLINE] find_current_command
    (VAR command: ^clt$command_line;
     VAR command_name: clt$command_name);

    VAR
      block: ^clt$block;


    clp$find_current_block (block);

    WHILE block <> NIL DO
      CASE block^.kind OF
      = clc$command_block, clc$command_proc_block =
        command := ^block^.line_parse.text^ (block^.source.index, block^.source.size);
        command_name := block^.label;
        RETURN;
      = clc$function_proc_block, clc$input_block, clc$when_block =
        command := block^.previous_command.text;
        command_name := block^.previous_command_name;
        RETURN;
      ELSE
        ;
      CASEND;
      block := block^.previous_block;
    WHILEND;

    command := NIL;
    command_name := osc$null_name;

  PROCEND find_current_command;
?? TITLE := 'find_handler_block_for_input', EJECT ??

  PROCEDURE [INLINE] find_handler_block_for_input
    (    input_block: ^clt$block;
     VAR handler_block: ^clt$block);


    handler_block := NIL;

    CASE input_block^.kind OF

    = clc$command_proc_block, clc$function_proc_block =
      handler_block := input_block;

    = clc$input_block =
      IF (input_block^.associated_utility <> NIL) OR ((input_block^.previous_block^.kind = clc$task_block) AND
            ((input_block^.previous_block^.task_kind = clc$task_statement_task) OR
            (input_block^.previous_block^.task_kind = clc$job_monitor_task))) THEN
        handler_block := input_block;
      IFEND;

    = clc$when_block =
      handler_block := input_block;

    ELSE
      ;
    CASEND;

  PROCEND find_handler_block_for_input;
?? TITLE := 'find_handler_in_block', EJECT ??

  PROCEDURE [INLINE] find_handler_in_block
    (    specific_or_generic: (specific_handler_only, any_established_handler);
         condition: clt$when_condition_definition;
         handler_block: ^clt$block;
     VAR handler_statements: ^clt$established_handler_stmnts);

    VAR
      current_ring: ost$valid_ring,
      handler_index: clt$established_handler_index,
      high_index: 0 .. clc$max_established_handlers,
      temp: integer,
      low_index: 1 .. clc$max_established_handlers + 1;


    current_ring := #RING (^current_ring);

    IF handler_block^.established_handler_info.specific_handler_count > 0 THEN
      low_index := 1;
      high_index := handler_block^.established_handler_info.specific_handler_count;

    /search_specific_handlers/
      REPEAT
        temp := low_index + high_index;
        handler_index := temp DIV 2;
        IF condition.name = handler_block^.established_handler_info.specific_handlers^ [handler_index].
              condition THEN

          handler_statements := handler_block^.established_handler_info.specific_handlers^ [handler_index].
                statements;
          IF handler_statements^.establishing_ring = current_ring THEN
            RETURN;
          IFEND;
          EXIT /search_specific_handlers/;

        ELSEIF condition.name > handler_block^.established_handler_info.specific_handlers^ [handler_index].
              condition THEN
          low_index := handler_index + 1;
        ELSE
          high_index := handler_index - 1;
        IFEND;
      UNTIL low_index > high_index {/search_specific_handlers/} ;
    IFEND;

    IF specific_or_generic = any_established_handler THEN
      IF (NOT condition.status.normal) AND (handler_block^.established_handler_info.any_fault_handler <> NIL)
            THEN
        handler_statements := handler_block^.established_handler_info.any_fault_handler;
        IF handler_statements^.establishing_ring = current_ring THEN
          RETURN;
        IFEND;
      IFEND;

      IF handler_block^.established_handler_info.any_condition_handler <> NIL THEN
        handler_statements := handler_block^.established_handler_info.any_condition_handler;
        IF handler_statements^.establishing_ring = current_ring THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    handler_statements := NIL;

  PROCEND find_handler_in_block;
?? TITLE := 'find_next_handler_block', EJECT ??

  PROCEDURE [INLINE] find_next_handler_block
    (    follow_linkage: (previous_block, inherited_input);
     VAR handler_block {input, output} : ^clt$block);


    WHILE TRUE DO
      IF follow_linkage = previous_block THEN
        handler_block := handler_block^.previous_block;
        IF handler_block = NIL THEN
          RETURN;
        IFEND;
      ELSEIF handler_block^.inherited_input.found THEN
        handler_block := handler_block^.inherited_input.block;
      ELSE
        handler_block := NIL;
        RETURN;
      IFEND;

      CASE handler_block^.kind OF
      = clc$command_proc_block, clc$function_proc_block, clc$when_block =
        RETURN;
      = clc$input_block =
        IF (handler_block^.associated_utility <> NIL) OR ((handler_block^.previous_block^.kind =
              clc$task_block) AND ((handler_block^.previous_block^.task_kind = clc$task_statement_task) OR
              (handler_block^.previous_block^.task_kind = clc$job_monitor_task))) THEN
          RETURN;
        IFEND;
      ELSE
        ;
      CASEND;
    WHILEND;

  PROCEND find_next_handler_block;
?? TITLE := 'process_when_condition', EJECT ??

  PROCEDURE process_when_condition
    (    condition_definition: clt$when_condition_definition;
         exit_on_continue_condition: boolean;
         default_handler: ^procedure (VAR status: ost$status);
         command: ^clt$command_line;
         command_name: clt$command_name;
         handler_statements: ^clt$established_handler_stmnts;
         handler_block: ^clt$block;
     VAR retry_command: ^clt$command_line;
     VAR condition_processed_state: clt$condition_processed_state;
     VAR status: ost$status);

    VAR
      connected_files: ^clt$connected_files,
      end_when_block: ^clt$block,
      ignore_status: ost$status,
      saved_work_area_positions: clt$saved_work_area_positions,
      severity: ost$status_severity,
      static_link_handle: clt$block_handle,
      when_block: ^clt$block;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        exit_control_block: ^clt$block,
        ignore_status: ost$status,
        run_time_status: ^ost$status;


      CASE condition.selector OF

      = pmc$block_exit_processing =

{ --- Handle block exit.

        IF when_block = NIL THEN
          RETURN;
        IFEND;

        clp$pop_terminated_blocks (when_block, status);
        clp$process_exit_condition (when_block, status);

        IF when_block^.input_can_be_echoed THEN
          clp$find_connected_files (connected_files);
          IF connected_files^.echo_count > 0 THEN
            clp$echo_trace_information ('CLC$ECHO_CONDITION_END', ^when_block^.when_condition^.name, NIL,
                  ^status, ignore_status);
          IFEND;
        IFEND;

        clp$restore_work_area_positions (saved_work_area_positions, ignore_status);

        IF (condition_processed_state = clc$continue_retry) AND
              ((condition_definition.name = clc$wc_command_fault) OR
              (condition_definition.name = clc$wc_execution_fault)) THEN
          get_retry_command;
        IFEND;

        clp$pop_input_stack (end_when_block, ignore_status);

      = pmc$user_defined_condition =
        IF condition.user_condition_name = clc$exiting_condition THEN

{ --- Handle exit initiated via command level EXIT statement.
{
{ This condition is raised in the task that "owns" the SCL block which is the
{ target of the EXIT statement.
{ This condition is specifically dealt with in the condition handlers that
{ cover processing of the various kinds of input, command and function blocks.
{ The condition_information for this condition is a pointer to the outermost
{ block which is being exited and has such a corresponding condition handler.
{ The handler which is "covering" this "exit_control_block" performs a
{ non-local (CYBIL) exit out of its establishing procedure.
{ Other such handlers simply "continue" the condition.

          exit_control_block := condition_information;

          IF (#OFFSET (exit_control_block) = #OFFSET (handler_block)) AND
                (condition_definition.name = clc$wc_exit) THEN

{ This instance of process_when_condition is already dealing with the EXIT
{ condition for the target block of the EXIT statement.  Therefore, the EXIT
{ statement should be treated as though its target was the WHEN/WHENEND block.

            EXIT process_when_condition;
          IFEND;

          IF #OFFSET (exit_control_block) <> #OFFSET (when_block) THEN
            pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          IFEND;
          EXIT process_when_condition;

        ELSE

{ --- "Continue" any other user defined condition.

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          RETURN;
        IFEND;

      ELSE

{ --- "Continue" any other condition.

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        RETURN;
      CASEND;

    PROCEND condition_handler;
?? TITLE := 'get_retry_command', EJECT ??

    PROCEDURE get_retry_command;

      VAR
        local_status: ost$status,
        variable_value: ^clt$data_value;


      clp$get_variable_value ('OSV$COMMAND', variable_value, local_status);
      IF local_status.normal AND (variable_value^.kind = clc$string) AND
            (variable_value^.string_value^ <> when_block^.when_condition^.command) THEN
        retry_command := variable_value^.string_value;
      IFEND;

    PROCEND get_retry_command;
?? TITLE := 'initialize_handler_variables', EJECT ??

    PROCEDURE initialize_handler_variables;

{ TYPE
{   name_string_type = string 0..osc$max_name_size
{ TYPEND

?? PUSH (LISTEXT := ON) ??

      VAR
        name_string_type: [STATIC, READ, cls$declaration_section] record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend := [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]];

?? POP ??

{ TYPE
{   name_type = name
{ TYPEND

?? PUSH (LISTEXT := ON) ??

      VAR
        name_type: [STATIC, READ, cls$declaration_section] record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend := [[1, 0, clc$name_type], [1, osc$max_name_size]];

?? POP ??

{ TYPE
{   status_type = status
{ TYPEND

?? PUSH (LISTEXT := ON) ??

      VAR
        status_type: [STATIC, READ, cls$declaration_section] record
          header: clt$type_specification_header,
        recend := [[1, 0, clc$status_type]];

?? POP ??

{ TYPE
{   string_type = string
{ TYPEND

?? PUSH (LISTEXT := ON) ??

      VAR
        string_type: [STATIC, READ, cls$declaration_section] record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend := [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]];

?? POP ??

      VAR
        initial_value: clt$data_value;


      status.normal := TRUE;

      initial_value.kind := clc$name;
      initial_value.name_value := condition_definition.name;
      clp$create_procedure_variable ('OSV$CONDITION', clc$local_scope, clc$read_write,
            clc$immediate_evaluation, #SEQ (name_type), ^initial_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF condition_definition.name = clc$wc_limit_fault THEN
        initial_value.kind := clc$name;
        initial_value.name_value := condition_definition.limit_name;
        clp$create_procedure_variable ('OSV$LIMIT_NAME', clc$local_scope, clc$read_write,
              clc$immediate_evaluation, #SEQ (name_type), ^initial_value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      initial_value.kind := clc$status;
      initial_value.status_value := ^condition_definition.status;
      clp$create_procedure_variable ('OSV$STATUS', clc$local_scope, clc$read_write,
            clc$immediate_evaluation, #SEQ (status_type), ^initial_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      initial_value.kind := clc$string;
      IF command = NIL THEN
        PUSH initial_value.string_value: [0];
      ELSE
        initial_value.string_value := ^command^ (1, clp$trimmed_string_size (command^));
      IFEND;
      clp$create_procedure_variable ('OSV$COMMAND', clc$local_scope, clc$read_write,
            clc$immediate_evaluation, #SEQ (string_type), ^initial_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF command_name <> osc$null_name THEN

{ OSV$COMMAND_NAME is created just for backward compatibility.

        initial_value.kind := clc$string;
        initial_value.string_value := ^command_name (1, clp$trimmed_string_size (command_name));
        clp$create_procedure_variable ('OSV$COMMAND_NAME', clc$local_scope, clc$read_write,
              clc$immediate_evaluation, #SEQ (name_string_type), ^initial_value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    PROCEND initialize_handler_variables;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    retry_command := NIL;

    clp$save_work_area_positions (saved_work_area_positions);

    when_block := NIL;
    #SPOIL (when_block);
    osp$establish_condition_handler (^condition_handler, TRUE);

  /call_handler/
    BEGIN
      static_link_handle.segment_offset := #OFFSET (handler_block);
      static_link_handle.assignment_counter := handler_block^.assignment_counter;

      clp$push_when_input_block (condition_definition, exit_on_continue_condition, default_handler, command,
            command_name, handler_statements, static_link_handle, when_block);

      initialize_handler_variables;
      IF NOT status.normal THEN
        clp$pop_input_stack (when_block, ignore_status);
        EXIT /call_handler/;
      IFEND;

      IF when_block^.input_can_be_echoed THEN
        clp$find_connected_files (connected_files);
        IF connected_files^.echo_count > 0 THEN
          clp$echo_trace_information ('CLC$ECHO_CONDITION_BEGIN', ^when_block^.when_condition^.name, NIL,
                ^condition_definition.status, ignore_status);
        IFEND;
      IFEND;

      clp$process_command_file (when_block, NIL, status);
      condition_processed_state := when_block^.when_condition^.condition_processed_state;
      IF status.normal AND (NOT when_block^.being_exited) THEN
        clp$find_current_block (end_when_block);
        IF end_when_block <> when_block THEN
          osp$set_status_abnormal ('CL', cle$unbalanced_block_structure, when_block^.kind_end_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, end_when_block^.kind_end_name, status);
        IFEND;
      IFEND;

      clp$pop_terminated_blocks (when_block, status);
      clp$process_exit_condition (when_block, status);

      IF when_block^.input_can_be_echoed THEN
        clp$find_connected_files (connected_files);
        IF connected_files^.echo_count > 0 THEN
          clp$echo_trace_information ('CLC$ECHO_CONDITION_END', ^when_block^.when_condition^.name, NIL,
                ^status, ignore_status);
        IFEND;
      IFEND;

      clp$restore_work_area_positions (saved_work_area_positions, ignore_status);

      IF (condition_processed_state = clc$continue_retry) AND
            ((condition_definition.name = clc$wc_command_fault) OR
            (condition_definition.name = clc$wc_execution_fault)) THEN
        get_retry_command;
      IFEND;

      IF status.normal THEN
        clp$pop_input_stack (end_when_block, status);
      ELSE
        clp$pop_input_stack (end_when_block, ignore_status);
      IFEND;
    END /call_handler/;

    osp$disestablish_cond_handler;

    IF NOT status.normal THEN
      severity := osc$error_status;
      osp$get_status_severity (status.condition, severity, ignore_status);
      IF severity >= osc$error_status THEN
        clp$put_job_command_response (' --WHEN/WHENEND condition handler failed for following reason:',
              ignore_status);
        osp$generate_message (status, ignore_status);
        condition_processed_state := clc$no_handler_established;
      IFEND;
    IFEND;

  PROCEND process_when_condition;

MODEND clm$process_when_condition;
*DECK DECK=CLM$PROGRAM_EXECUTION_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Program Execution Commands' ??
MODULE clm$program_execution_commands;

{
{ PURPOSE:
{   This module contains the processors for wait command and the $task_status,
{   $task_complete, and $ring functions.

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_expression_result
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_parameter_list
*copyc clt$work_area
*copyc osd$virtual_address
*copyc ost$caller_identifier
*copyc ost$status
*copyc pfe$error_condition_codes
?? POP ??
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc clp$fetch_named_task_entry
*copyc clp$make_boolean_value
*copyc clp$make_integer_value
*copyc clp$make_status_value
*copyc osp$await_activity_completion
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
*copyc pmp$connect_queue
*copyc pmp$define_queue
*copyc pmp$disconnect_queue
?? TITLE := 'clp$_wait', EJECT ??

{ PURPOSE:
{   This routine processes the wait command.

  PROCEDURE [XDCL] clp$_wait
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$wai) wait, wai (
{   time, t: any of
{       integer 0..osc$maximum_wait_time
{       time_increment
{     anyend = $optional
{   task_names, task_name, tn: list of name = $optional
{   queue_names, queue_name, qn: list of name = $optional
{   until, u: key
{       all, any
{     keyend = all
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 11] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] 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$integer_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 2] of clt$keyword_specification,
          default_value: string (3),
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 14, 31, 0, 665], clc$command, 11, 5, 0, 0, 0, 0, 5, 'OSM$WAI'],
            [['QN                             ', clc$abbreviation_entry, 3],
            ['QUEUE_NAME                     ', clc$alias_entry, 3],
            ['QUEUE_NAMES                    ', clc$nominal_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 5],
            ['T                              ', clc$abbreviation_entry, 1],
            ['TASK_NAME                      ', clc$alias_entry, 2],
            ['TASK_NAMES                     ', clc$nominal_entry, 2],
            ['TIME                           ', clc$nominal_entry, 1],
            ['TN                             ', clc$abbreviation_entry, 2],
            ['U                              ', clc$abbreviation_entry, 4],
            ['UNTIL                          ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 43, clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 21, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 21, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 81, clc$optional_default_parameter, 0, 3],

{ PARAMETER 5

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$integer_type, clc$time_increment_type], FALSE, 2], 20,
            [[1, 0, clc$integer_type], [0, osc$maximum_wait_time, 10]], 3, [[1, 0, clc$time_increment_type]]],

{ PARAMETER 2

      [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 3

      [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 4

      [[1, 0, clc$keyword_type], [2], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['ANY                            ', clc$nominal_entry,
            clc$normal_usage_entry, 2]], 'all'],

{ PARAMETER 5

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$time = 1,
      p$task_names = 2,
      p$queue_names = 3,
      p$until = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

?? NEWTITLE := 'delete_connected_queues', EJECT ??

{ PURPOSE:
{   Disconnect any queues connected to the task by this command.

    PROCEDURE delete_connected_queues;

      VAR
        local_status: ost$status,
        queue_index: clt$list_size;

      FOR queue_index := 1 TO connected_queues DO
        pmp$disconnect_queue (queue_id_list^ [queue_index], local_status);
      FOREND;
    PROCEND delete_connected_queues;
?? OLDTITLE ??
?? NEWTITLE := 'end_handler', EJECT ??

{ PURPOSE:
{   Cleans up if the procedure exits abnormally.

    PROCEDURE end_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      delete_connected_queues;

    PROCEND end_handler;
?? OLDTITLE, EJECT ??

    VAR
      connected_queues: clt$list_size,
      milliseconds: integer,
      named_task: clt$named_task,
      queue_count: clt$list_size,
      queue_id: pmt$queue_connection,
      queue_id_list: ^array [1 .. * ] of pmt$queue_connection,
      ready_index: integer,
      remaining_activities: integer,
      task_count: clt$list_size,
      time_increment: ^pmt$time_increment,
      value: ^clt$data_value,
      wait_for_any: boolean,
      wait_list: ^ost$wait_list;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT (pvt [p$time].specified OR pvt [p$task_names].specified OR pvt [p$queue_names].specified) THEN
      RETURN;
    IFEND;

    task_count := clp$count_list_elements (pvt [p$task_names].value);
    queue_count := clp$count_list_elements (pvt [p$queue_names].value);

    PUSH wait_list: [1 .. task_count + queue_count + $INTEGER (pvt [p$time].specified)];
    IF pvt [p$time].specified THEN
      wait_list^ [UPPERBOUND (wait_list^)].activity := osc$await_time;
      value := pvt [p$time].value;
      IF value^.kind = clc$integer THEN
        wait_list^ [UPPERBOUND (wait_list^)].milliseconds := value^.integer_value.value;
      ELSE
        time_increment := value^.time_increment_value;
        milliseconds := time_increment^.millisecond + time_increment^.second * 1000 + time_increment^.minute *
              60 * 1000 + time_increment^.hour * 60 * 60 * 1000 + time_increment^.day * 24 * 60 * 60 *
              1000 + time_increment^.month * 30 * 24 * 60 * 60 * 1000 + time_increment^.year * 365 * 24 * 60 *
              60 * 1000;
        IF milliseconds <= 0 THEN
          RETURN; {No point in hanging around for 0 MS }
        ELSEIF milliseconds > osc$maximum_wait_time THEN
          milliseconds := osc$maximum_wait_time;
        IFEND;
        wait_list^ [UPPERBOUND (wait_list^)].milliseconds := milliseconds;
      IFEND;
    IFEND;

    value := pvt [p$task_names].value;
    FOR ready_index := 1 TO task_count DO
      clp$fetch_named_task_entry (value^.element_value^.name_value, named_task);
      IF named_task.name = osc$null_name THEN
        wait_list^ [ready_index].activity := osc$null_activity;
      ELSE
        wait_list^ [ready_index].activity := pmc$await_task_termination;
        wait_list^ [ready_index].task_id := named_task.id;
      IFEND;
      value := value^.link;
    FOREND;

  /wait/
    BEGIN
      connected_queues := 0;
      #SPOIL (connected_queues);
      osp$establish_block_exit_hndlr (^end_handler);

      IF queue_count > 0 THEN
        value := pvt [p$queue_names].value;
        PUSH queue_id_list: [1 .. queue_count];
        FOR ready_index := 1 TO queue_count DO
          pmp$connect_queue (value^.element_value^.name_value, queue_id, status);
          IF NOT status.normal AND (status.condition = pme$unknown_queue_name) THEN
            pmp$define_queue (value^.element_value^.name_value, osc$user_ring_2, osc$user_ring_2, status);
            IF NOT status.normal AND (status.condition <> pme$queue_already_defined) THEN
              EXIT /wait/;
            IFEND;
            status.normal := TRUE;
            pmp$connect_queue (value^.element_value^.name_value, queue_id, status);
          IFEND;
          IF NOT status.normal THEN
            IF NOT (status.condition = pme$task_already_connected) THEN
              EXIT /wait/;
            IFEND;
            status.normal := TRUE;
          ELSE
            queue_id_list^ [connected_queues + 1] := queue_id;
            #SPOIL (queue_id_list^ [connected_queues + 1]);
            connected_queues := connected_queues + 1;
            #SPOIL (connected_queues);
          IFEND;
          wait_list^ [task_count + ready_index].activity := pmc$await_local_queue_message;
          wait_list^ [task_count + ready_index].qid := queue_id;
          value := value^.link;
        FOREND;
      IFEND;

      wait_for_any := (pvt [p$until].value^.keyword_value = 'ANY');
      REPEAT
        osp$await_activity_completion (wait_list^, ready_index, status);
        IF NOT status.normal THEN
          EXIT /wait/;
        IFEND;

        IF wait_for_any THEN
          EXIT /wait/;
        IFEND;

        wait_list^ [ready_index].activity := osc$null_activity;
        remaining_activities := 0;
        FOR ready_index := 1 TO UPPERBOUND (wait_list^) DO
          IF wait_list^ [ready_index].activity <> osc$null_activity THEN
            remaining_activities := remaining_activities + 1;
          IFEND;
        FOREND;
      UNTIL remaining_activities = 0;
    END /wait/;
    delete_connected_queues;
    osp$disestablish_cond_handler;

  PROCEND clp$_wait;
?? TITLE := 'clp$$task_complete', EJECT ??

{ PURPOSE:
{   This command processes the $task_complete function.

  PROCEDURE [XDCL] clp$$task_complete
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$task_complete) $task_complete (
{   task_name: name = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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$name_type_qualifier,
        recend,
      recend := [[1, [88, 9, 26, 14, 31, 50, 187], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$TASK_COMPLETE'],
            [['TASK_NAME                      ', 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, 5, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]]];

?? POP ??

    CONST
      p$task_name = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      named_task: clt$named_task;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$fetch_named_task_entry (pvt [p$task_name].value^.name_value, named_task);

    clp$make_boolean_value (named_task.status.complete, clc$true_false_boolean, work_area, result);

  PROCEND clp$$task_complete;
?? TITLE := 'clp$$task_status', EJECT ??

{ PURPOSE:
{   This command processes the $task_status function.

  PROCEDURE [XDCL] clp$$task_status
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$task_status) $task_status (
{   task_name: name = $required
{   status_information: key
{      (complete, completed, c), (status, s)
{     keyend = status
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 5] of clt$keyword_specification,
          default_value: string (6),
        recend,
      recend := [[1, [88, 9, 26, 14, 32, 32, 764], clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$TASK_STATUS'],
            [['STATUS_INFORMATION             ', clc$nominal_entry, 2],
            ['TASK_NAME                      ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [2, 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, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [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, 192, clc$optional_default_parameter, 0,
            6]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [5], [['C                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['COMPLETE                       ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['COMPLETED                      ', clc$alias_entry,
            clc$normal_usage_entry, 1], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['STATUS                         ', clc$nominal_entry,
            clc$normal_usage_entry, 2]], 'status']];

?? POP ??

    CONST
      p$task_name = 1,
      p$status_information = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      named_task: clt$named_task;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$fetch_named_task_entry (pvt [p$task_name].value^.name_value, named_task);

    IF pvt [p$status_information].value^.keyword_value = 'COMPLETE' THEN
      clp$make_boolean_value (named_task.status.complete, clc$true_false_boolean, work_area, result);
    ELSE {pvt [p$status_information].value^.keyword_value = 'STATUS'
      clp$make_status_value (named_task.status.status, work_area, result);
      IF (named_task.name = osc$null_name) OR (NOT named_task.status.complete) THEN
        result^.status_value^.normal := TRUE;
      IFEND;
    IFEND;

  PROCEND clp$$task_status;
?? TITLE := 'clp$$ring', EJECT ??

{ PURPOSE:
{   This routine processes the $ring function.

  PROCEDURE [XDCL] clp$$ring
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$ring) $ring

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [88, 9, 26, 14, 33, 5, 903], clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$RING']];

?? POP ??

    VAR
      caller_id: ost$caller_identifier;

    #CALLER_ID (caller_id);

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_integer_value (caller_id.ring, 10, FALSE, work_area, result);

  PROCEND clp$$ring;
MODEND clm$program_execution_commands;
*DECK DECK=CLM$PUT_LINE_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter: Put Line Command' ??
MODULE clm$put_line_command;

{
{ PURPOSE:
{   This module contains the processor for the put_line command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc ost$status
?? POP ??
*copyc amp$put_next
*copyc amv$nil_file_identifier
*copyc clp$evaluate_parameters
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
?? TITLE := 'clp$_put_line', EJECT ??

  PROCEDURE [XDCL] clp$_put_line
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$putl) put_line, put_lines, putl (
{   lines, line, l: any of list 0..clc$max_list_size of string
{                          array of string
{                   anyend = $required
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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$list_type_qualifier_v2,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$array_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [94, 2, 7, 5, 12, 24, 617],
    clc$command, 6, 3, 1, 0, 0, 0, 3, 'OSM$PUTL'], [
    ['L                              ',clc$abbreviation_entry, 1],
    ['LINE                           ',clc$alias_entry, 1],
    ['LINES                          ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 76, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$array_type,
    clc$list_type],
    FALSE, 2],
    24, [[1, 0, clc$list_type], [8, 0, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
      ],
    32, [[1, 0, clc$array_type], [8, FALSE],
        [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$lines = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      fsp$close_file (file_id, handler_status);
      handler_status.normal := TRUE;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    CONST
      list_unknown = 'LIST_UNKNOWN                   ';

    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      current_line: ^clt$data_value,
      default_creation_attributes: array [1 .. 2] of fst$file_cycle_attribute,
      file_id: amt$file_identifier,
      ignore_byte_address: amt$file_byte_address,
      ignore_status: ^ost$status,
      validation_attributes: array [1 .. 9] of fst$file_cycle_attribute;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
    attachment_options [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options [1].share_modes.value := $fst$file_access_options [];
    attachment_options [2].selector := fsc$access_and_share_modes;
    attachment_options [2].access_modes.selector := fsc$specific_access_modes;
    attachment_options [2].access_modes.value := $fst$file_access_options [fsc$append];
    attachment_options [2].share_modes.selector := fsc$specific_share_modes;
    attachment_options [2].share_modes.value := $fst$file_access_options [];
    attachment_options [3].selector := fsc$open_share_modes;
    attachment_options [3].open_share_modes := -$fst$file_access_options [];

    default_creation_attributes [1].selector := fsc$file_contents_and_processor;
    default_creation_attributes [1].file_contents := fsc$legible_data;
    default_creation_attributes [1].file_processor := osc$null_name;
    default_creation_attributes [2].selector := fsc$page_format;
    default_creation_attributes [2].page_format := amc$untitled_form;

    validation_attributes [1].selector := fsc$file_contents_and_processor;
    validation_attributes [1].file_contents := fsc$list;
    validation_attributes [1].file_processor := osc$null_name;
    validation_attributes [2].selector := fsc$file_contents_and_processor;
    validation_attributes [2].file_contents := fsc$legible_data;
    validation_attributes [2].file_processor := osc$null_name;
    validation_attributes [3].selector := fsc$file_contents_and_processor;
    validation_attributes [3].file_contents := fsc$legible_scl_procedure;
    validation_attributes [3].file_processor := osc$null_name;
    validation_attributes [4].selector := fsc$file_contents_and_processor;
    validation_attributes [4].file_contents := fsc$legible_scl_include;
    validation_attributes [4].file_processor := osc$null_name;
    validation_attributes [5].selector := fsc$file_contents_and_processor;
    validation_attributes [5].file_contents := fsc$legible_scl_job;
    validation_attributes [5].file_processor := osc$null_name;
    validation_attributes [6].selector := fsc$file_contents_and_processor;
    validation_attributes [6].file_contents := list_unknown;
    validation_attributes [6].file_processor := osc$null_name;
    validation_attributes [7].selector := fsc$file_contents_and_processor;
    validation_attributes [7].file_contents := amc$legible;
    validation_attributes [7].file_processor := osc$null_name;
    validation_attributes [8].selector := fsc$file_contents_and_processor;
    validation_attributes [8].file_contents := fsc$data;
    validation_attributes [8].file_processor := osc$null_name;
    validation_attributes [9].selector := fsc$file_contents_and_processor;
    validation_attributes [9].file_contents := fsc$unknown_contents;
    validation_attributes [9].file_processor := osc$null_name;

    file_id := amv$nil_file_identifier;
    #SPOIL (file_id);
    osp$establish_block_exit_hndlr (^abort_handler);

    fsp$open_file (pvt [p$output].value^.file_value^, amc$record, ^attachment_options,
          ^default_creation_attributes, NIL, ^validation_attributes, NIL, file_id, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

    current_line := pvt [p$lines].value;

  /put/
    WHILE (current_line <> NIL) AND (current_line^.element_value <> NIL) DO
      amp$put_next (file_id, current_line^.element_value^.string_value,
            STRLENGTH (current_line^.element_value^.string_value^), ignore_byte_address, status);
      IF NOT status.normal THEN
        EXIT /put/;
      IFEND;
      current_line := current_line^.link;
    WHILEND /put/;

    IF status.normal THEN
      fsp$close_file (file_id, status);
    ELSE
      PUSH ignore_status;
      fsp$close_file (file_id, ignore_status^);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND clp$_put_line;

MODEND clm$put_line_command;
*DECK DECK=CLM$READ_INPUT_FILE EXPAND=TRUE

*DECK DECK=CLM$REASSIGN_DEVICE_COMMAND EXPAND=TRUE

?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? TITLE := 'NOS/VE SCL Interpreter : Reassign Device Command' ??
MODULE clm$reassign_device_command;


{  PURPOSE:
{    This module contains the processor for the REASSIGN_DEVICE command.
{

?? NEWTITLE := '  Global Declarations', EJECT ??
*copyc clp$scan_parameter_list
*copyc clp$get_value
*copyc iop$reassign_device_command

?? PUSH (LISTEXT := ON) ??
?? POP ??

?? EJECT ??

?? TITLE := 'clp$reassign_device_command', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$reassign_device_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? RIGHT := 110 ??
{  PDT reassd_pdt (
{    element_name, en : name = $required
{    status)

?? PUSH (LISTEXT := ON) ??

    VAR
      reassd_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^reassd_pdt_names, ^reassd_pdt_params];

    VAR
      reassd_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['ELEMENT_NAME', 1], ['EN', 1], ['STATUS', 2]];

    VAR
      reassd_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ ELEMENT_NAME EN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      element_name: ost$name,
      value: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, reassd_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('ELEMENT_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    element_name := value.name.value;

    iop$reassign_device_command (element_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND clp$reassign_device_command;
MODEND clm$reassign_device_command;
*DECK DECK=CLM$REMOTE_HOST_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Remote Host Commands' ??
MODULE clm$remote_host_commands;

{
{ PURPOSE:
{   This module contains the processors for commands that perform file transfers to/from the
{   C170 state via the remote host.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc fsc$local
*copyc ost$status
*copyc rhc$condition_limits
?? POP ??
*copyc clp$convert_cyc_ref_to_cyc_sel
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_integer_to_string
*copyc clp$convert_str_to_path_handle
*copyc clp$evaluate_parameters
*copyc fsp$convert_fs_structure_to_pf
*copyc fsp$path_element
*copyc osp$set_status_abnormal
*copyc pfp$purge
*copyc pmp$get_170_os_type
*copyc rhp$get_file
*copyc rhp$replace
*copyc rhp$save_link_user_description

?? TITLE := 'rhp$_set_link_attributes', EJECT ??

  PROCEDURE [XDCL] rhp$_set_link_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$setla) set_link_attributes, set_link_attribute, setla (
{   user, u: record
{       user: name 1..9
{       family: name 1..9
{     recend = $required
{   password, pw: (SECURE) name 1..31 = $required
{   charge, c: string 0..31 = ' '
{   project, p: string 0..31 = ' '
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 9] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
          default_value: string (3),
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
          default_value: string (3),
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 20, 12, 59, 56, 760], clc$command, 9, 5, 2, 0, 0, 0, 5, 'OSM$SETLA'],
            [['C                              ', clc$abbreviation_entry, 3],
            ['CHARGE                         ', clc$nominal_entry, 3],
            ['P                              ', clc$abbreviation_entry, 4],
            ['PASSWORD                       ', clc$nominal_entry, 2],
            ['PROJECT                        ', clc$nominal_entry, 4],
            ['PW                             ', clc$abbreviation_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 5],
            ['U                              ', clc$abbreviation_entry, 1],
            ['USER                           ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 89, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 3

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 3],

{ PARAMETER 4

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 3],

{ PARAMETER 5

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$record_type], [2], ['USER                           ', clc$required_field, 5],
            [[1, 0, clc$name_type], [1, 9]], ['FAMILY                         ', clc$required_field, 5],
            [[1, 0, clc$name_type], [1, 9]]],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, 31]],

{ PARAMETER 3

      [[1, 0, clc$string_type], [0, 31, FALSE], ''' '''],

{ PARAMETER 4

      [[1, 0, clc$string_type], [0, 31, FALSE], ''' '''],

{ PARAMETER 5

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$user = 1,
      p$password = 2,
      p$charge = 3,
      p$project = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      user: string (31),
      family: string (31),
      password: string (31),
      charge: string (31),
      project: string (31),
      os_type: ost$170_os_type;

    pmp$get_170_os_type (os_type, status);
    IF status.normal THEN

{ If the OS type is none, then the command cannot be executed.

      IF os_type = osc$ot7_none THEN
        osp$set_status_abnormal (rhc$remote_host_id,
                                 rhe$no_partner_exists, 'SET_LINK_ATTRIBUTES', status);
        RETURN;
      IFEND;
    IFEND;

{ Initialize the values to be save as the link descriptor.

    user := ' ';
    family := ' ';

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    user (1, 9) := pvt [p$user].value^.field_values^ [1].value^.name_value;

    family (1, 9) := pvt [p$user].value^.field_values^ [2].value^.name_value;

    password := pvt [p$password].value^.name_value;

    charge := pvt [p$charge].value^.string_value^;

    project := pvt [p$project].value^.string_value^;

    rhp$save_link_user_description (user, family, password, charge, project, status);

  PROCEND rhp$_set_link_attributes;
?? TITLE := 'rhp$_get_file', EJECT ??

  PROCEDURE [XDCL] rhp$_get_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{      PROCEDURE (osm$getf) get_file, getf (
{        to, t: file = $required
{        from, f: any of
{            string 0..osc$max_name_size
{            name
{          anyend = $optional
{        data_conversion, dc: key
{            b60, b56, a6, a8, d64, d63
{            hidden_key a63, b64, b32
{          keyend = a6
{        user, u, id: any of
{            string 0..osc$max_name_size
{            name
{          anyend = $optional
{        password, passwords, pw: (SECURE) list 1..2 of name = $optional
{        cycle, cy, c: integer 1..999 = $optional
{        status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 16] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 9] of clt$keyword_specification,
        default_value: string (2),
      recend,
      type4: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 16, 15, 12, 42, 462],
    clc$command, 16, 7, 1, 0, 0, 0, 7, 'OSM$GETF'], [
    ['C                              ',clc$abbreviation_entry, 6],
    ['CY                             ',clc$alias_entry, 6],
    ['CYCLE                          ',clc$nominal_entry, 6],
    ['DATA_CONVERSION                ',clc$nominal_entry, 3],
    ['DC                             ',clc$abbreviation_entry, 3],
    ['F                              ',clc$abbreviation_entry, 2],
    ['FROM                           ',clc$nominal_entry, 2],
    ['ID                             ',clc$abbreviation_entry, 4],
    ['PASSWORD                       ',clc$nominal_entry, 5],
    ['PASSWORDS                      ',clc$alias_entry, 5],
    ['PW                             ',clc$abbreviation_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 7],
    ['T                              ',clc$abbreviation_entry, 1],
    ['TO                             ',clc$nominal_entry, 1],
    ['U                              ',clc$alias_entry, 4],
    ['USER                           ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 340, clc$optional_default_parameter, 0, 2],
{ PARAMETER 4
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 21, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [9], [
    ['A6                             ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['A63                            ', clc$nominal_entry, clc$hidden_entry, 7
  ],
    ['A8                             ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['B32                            ', clc$nominal_entry, clc$hidden_entry, 9
  ],
    ['B56                            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['B60                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['B64                            ', clc$nominal_entry, clc$hidden_entry, 8
  ],
    ['D63                            ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
    ['D64                            ', clc$nominal_entry,
  clc$normal_usage_entry, 5]]
    ,
    'a6'],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 5
    [[1, 0, clc$list_type], [5, 1, 2, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 6
    [[1, 0, clc$integer_type], [1, 999, 10]],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$to = 1,
      p$from = 2,
      p$data_conversion = 3,
      p$user = 4,
      p$password = 5,
      p$cycle = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

    VAR
      c170_file_name: string (31),
      conversion: syt$data_conversions,
      current_file: ^clt$data_value,
      cycle_selector: clt$cycle_selector,
      evaluated_file_reference: fst$evaluated_file_reference,
      file_cycle: string (3),
      file_password: array [1 .. 2] of string (9),
      file_path: fst$path,
      file_path_size: fst$path_size,
      local_status: ost$status,
      os_type: ost$170_os_type,
      path_handle_name: fst$path_handle_name,
      pf_path: ^pft$path,
      temp_string: ost$string,
      user: string (9);

    pmp$get_170_os_type (os_type, status);
    IF status.normal THEN

{ If the OS type is none, then the command cannot be executed.

      IF os_type = osc$ot7_none THEN
        osp$set_status_abnormal (rhc$remote_host_id, rhe$no_partner_exists, 'GET_FILE', status);
        RETURN;
      IFEND;
    IFEND;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_str_to_path_handle (pvt [p$to].value^.file_value^, TRUE {delete_allowed} ,
          TRUE {resolve_path}, TRUE {include_open_pos_in_handle} , path_handle_name, evaluated_file_reference,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$convert_file_ref_to_string (evaluated_file_reference, TRUE {include_open_position} , file_path,
          file_path_size, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$from].specified THEN
      IF pvt [p$from].value^.kind = clc$name THEN
        c170_file_name := pvt [p$from].value^.name_value;
      ELSE
        c170_file_name := pvt [p$from].value^.string_value^;
      IFEND;
    ELSE
      c170_file_name := fsp$path_element (^evaluated_file_reference,
            evaluated_file_reference.number_of_path_elements) ^;
    IFEND;

    IF pvt [p$data_conversion].value^.name_value = 'A6' THEN
      conversion := syc$64_char_ascii_to_ascii;
    ELSEIF pvt [p$data_conversion].value^.name_value = 'D64' THEN
      conversion := syc$64_display_code_to_ascii;
    ELSEIF pvt [p$data_conversion].value^.name_value = 'A63' THEN
      conversion := syc$63_char_ascii_to_ascii;
    ELSEIF pvt [p$data_conversion].value^.name_value = 'D63' THEN
      conversion := syc$63_display_code_to_ascii;
    ELSEIF pvt [p$data_conversion].value^.name_value = 'A8' THEN
      conversion := syc$8_in_12_to_ascii;
    ELSEIF pvt [p$data_conversion].value^.name_value = 'B56' THEN
      conversion := syc$56_bit_binary_to_64_bit;
    ELSEIF pvt [p$data_conversion].value^.name_value = 'B64' THEN
      conversion := syc$60_bit_binary_to_64_bit;
    ELSEIF pvt [p$data_conversion].value^.name_value = 'B32' THEN
      conversion := syc$32_bit_binary_to_64_bit;
    ELSE { pvt [p$data_conversion].value^.name_value = 'B60' THEN
      conversion := syc$60_bit_binary_to_60_bit;
    IFEND;

    IF pvt [p$user].specified THEN
      IF pvt [p$user].value^.kind = clc$name THEN
        user := pvt [p$user].value^.name_value;
      ELSE
        user := pvt [p$user].value^.string_value^;
      IFEND;
    ELSE
      user := '';
    IFEND;

    IF pvt [p$password].specified THEN
      file_password [1] := pvt [p$password].value^.element_value^.name_value;
      IF pvt [p$password].value^.link <> NIL THEN
        file_password [2] := pvt [p$password].value^.link^.element_value^.name_value;
      ELSE
        file_password [2] := ' ';
      IFEND;
    ELSE
      file_password [1] := ' ';
    IFEND;

    IF pvt [p$cycle].specified THEN
      clp$convert_integer_to_string (pvt [p$cycle].value^.integer_value.value, 10, FALSE, temp_string,
            status);
      IF status.normal THEN
        file_cycle := temp_string.value;
      ELSE
        RETURN;
      IFEND;
    ELSE
      file_cycle := '   ';
    IFEND;

    rhp$get (file_path, c170_file_name, conversion, user, file_cycle, file_password, status);

    IF NOT status.normal THEN

{ If any error occured in getting the file from NOS, the NOS/VE file is deleted.

      current_file := pvt [p$to].value;
      IF (current_file <> NIL) AND (current_file^.element_value <> NIL) THEN
        IF evaluated_file_reference.cycle_reference.specification = fsc$cycle_omitted THEN
          evaluated_file_reference.cycle_reference.specification := fsc$high_cycle;
        IFEND;

        PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
        fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);
        clp$convert_cyc_ref_to_cyc_sel (evaluated_file_reference.cycle_reference, cycle_selector);
        pfp$purge (pf_path^, cycle_selector.value, {password = } osc$null_name, local_status);
      IFEND;

    IFEND;

  PROCEND rhp$_get_file;
?? TITLE := 'rhp$_replace_file', EJECT ??

  PROCEDURE [XDCL] rhp$_replace_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{      PROCEDURE (osm$repf) replace_file, repf (
{        from, f: file = $required
{        to, t: any of
{            string 0..osc$max_name_size
{            name
{          anyend = $optional
{        data_conversion, dc: key
{            b60, b56, a6, a8, d64, d63
{            hidden_key a63, b64, b32
{          keyend = a6
{        user, u, id: any of
{            string 0..osc$max_name_size
{            name
{          anyend = $optional
{        password, pw, turnkey, tk: (SECURE) name = $optional
{        exclusive_access, xr: (SECURE) name = $optional
{        cycle, cy, c: integer 1..999 = $optional
{        status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 19] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 9] of clt$keyword_specification,
        default_value: string (2),
      recend,
      type4: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 16, 15, 12, 47, 691],
    clc$command, 19, 8, 1, 0, 0, 0, 8, 'OSM$REPF'], [
    ['C                              ',clc$abbreviation_entry, 7],
    ['CY                             ',clc$alias_entry, 7],
    ['CYCLE                          ',clc$nominal_entry, 7],
    ['DATA_CONVERSION                ',clc$nominal_entry, 3],
    ['DC                             ',clc$abbreviation_entry, 3],
    ['EXCLUSIVE_ACCESS               ',clc$nominal_entry, 6],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FROM                           ',clc$nominal_entry, 1],
    ['ID                             ',clc$abbreviation_entry, 4],
    ['PASSWORD                       ',clc$nominal_entry, 5],
    ['PW                             ',clc$alias_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 8],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TK                             ',clc$abbreviation_entry, 5],
    ['TO                             ',clc$nominal_entry, 2],
    ['TURNKEY                        ',clc$alias_entry, 5],
    ['U                              ',clc$alias_entry, 4],
    ['USER                           ',clc$nominal_entry, 4],
    ['XR                             ',clc$abbreviation_entry, 6]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 340, clc$optional_default_parameter, 0, 2],
{ PARAMETER 4
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [6, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [9], [
    ['A6                             ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['A63                            ', clc$nominal_entry, clc$hidden_entry, 7
  ],
    ['A8                             ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['B32                            ', clc$nominal_entry, clc$hidden_entry, 9
  ],
    ['B56                            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['B60                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['B64                            ', clc$nominal_entry, clc$hidden_entry, 8
  ],
    ['D63                            ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
    ['D64                            ', clc$nominal_entry,
  clc$normal_usage_entry, 5]]
    ,
    'a6'],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 5
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 6
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 7
    [[1, 0, clc$integer_type], [1, 999, 10]],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$from = 1,
      p$to = 2,
      p$data_conversion = 3,
      p$user = 4,
      p$password = 5,
      p$exclusive_access = 6,
      p$cycle = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    VAR
      c170_file_name: string (31),
      conversion: syt$data_conversions,
      user: string (9),
      evaluated_file_reference: fst$evaluated_file_reference,
      file_path: fst$path,
      file_path_size: fst$path_size,
      path_handle_name: fst$path_handle_name,
      file_cycle: string (3),
      file_password: array [1 .. 2] of string (9),
      temp_string: ost$string,
      os_type: ost$170_os_type;

    pmp$get_170_os_type (os_type, status);
    IF status.normal THEN

{ If the OS type is none, then the command cannot be executed.

      IF os_type = osc$ot7_none THEN
        osp$set_status_abnormal (rhc$remote_host_id, rhe$no_partner_exists, 'REPLACE_FILE', status);
        RETURN;
      IFEND;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_str_to_path_handle (pvt [p$from].value^.file_value^, TRUE {delete_allowed} , TRUE
          {resolve_path} , TRUE {include_open_pos_in_handle} , path_handle_name, evaluated_file_reference,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$convert_file_ref_to_string (evaluated_file_reference, TRUE {include_open_position} , file_path,
          file_path_size, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$to].specified THEN
      IF pvt [p$to].value^.kind = clc$name THEN
        c170_file_name := pvt [p$to].value^.name_value;
      ELSE
        c170_file_name := pvt [p$to].value^.string_value^;
      IFEND;
    ELSE
      c170_file_name := fsp$path_element (^evaluated_file_reference,
            evaluated_file_reference.number_of_path_elements) ^;
    IFEND;

    IF pvt [p$data_conversion].value^.name_value = 'A6' THEN
      conversion := syc$ascii_to_64_char_ascii;
    ELSEIF pvt [p$data_conversion].value^.name_value = 'D64' THEN
      conversion := syc$ascii_to_64_display_code;
    ELSEIF pvt [p$data_conversion].value^.name_value = 'A63' THEN
      conversion := syc$ascii_to_63_char_ascii;
    ELSEIF pvt [p$data_conversion].value^.name_value = 'D63' THEN
      conversion := syc$ascii_to_63_display_code;
    ELSEIF pvt [p$data_conversion].value^.name_value = 'A8' THEN
      conversion := syc$ascii_to_8_in_12;
    ELSEIF pvt [p$data_conversion].value^.name_value = 'B56' THEN
      conversion := syc$64_bit_binary_to_56_bit;
    ELSEIF pvt [p$data_conversion].value^.name_value = 'B64' THEN
      conversion := syc$64_bit_binary_to_60_bit;
    ELSEIF pvt [p$data_conversion].value^.name_value = 'B32' THEN
      conversion := syc$64_bit_binary_to_32_bit;
    ELSE { pvt [p$data_conversion].value^.name_value = 'B60' THEN
      conversion := syc$no_conversion;
    IFEND;

    IF pvt [p$user].specified THEN
      IF pvt [p$user].value^.kind = clc$name THEN
        user := pvt [p$user].value^.name_value;
      ELSE
        user := pvt [p$user].value^.string_value^;
      IFEND;
    ELSE
      user := '';
    IFEND;

    IF pvt [p$password].specified THEN
      file_password [1] := pvt [p$password].value^.name_value;
    ELSE
      file_password [1] := ' ';
    IFEND;

    IF pvt [p$exclusive_access].specified THEN
      file_password [2] := pvt [p$exclusive_access].value^.name_value;
    ELSE
      file_password [2] := ' ';
    IFEND;

    IF pvt [p$cycle].specified THEN
      clp$convert_integer_to_string (pvt [p$cycle].value^.integer_value.value, 10, FALSE, temp_string,
            status);
      IF status.normal THEN
        file_cycle := temp_string.value;
      ELSE
        RETURN;
      IFEND;
    ELSE
      file_cycle := '   ';
    IFEND;

    rhp$replace (file_path, c170_file_name, conversion, user, file_cycle, file_password, status);

  PROCEND rhp$_replace_file;

MODEND clm$remote_host_commands;
*DECK DECK=CLM$REQUEST_LOG_DEVICE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Associate log files with the log device ' ??
MODULE clm$request_log_device;

{
{ PURPOSE:
{   This module contains a procedure to associate the log 'files' with the 'log device'.
{   It is called during SCL's initialization activities for a job.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fst$path_handle_name
*copyc oss$task_shared
*copyc pmd$system_log_interface
?? POP ??
*copyc clp$convert_str_to_path_handle
*copyc fmp$request_null_device
*copyc fsp$close_file
*copyc fsp$open_file
*copyc lgv$critical_log_name
*copyc lgv$log_names

  VAR
    clv$critical_log_path_handle: [XDCL, oss$task_shared] fst$path_handle_name := '',
    clv$log_name_path_handles: [XDCL, oss$task_shared] array [pmt$logs] of
          fst$path_handle_name := ['', '', '', '', '', '', '', '', ''];

?? TITLE := 'clp$request_log_device', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$request_log_device
    (VAR status: ost$status);

    VAR
      attachment_option: array [1 .. 1] of fst$attachment_option,
      mandated_create_attributes: array [1 .. 2] of fst$file_cycle_attribute,
      file_identifier: amt$file_identifier,
      evaluated_file_reference: fst$evaluated_file_reference,
      path_handle_name: fst$path_handle_name,
      log_ordinal: pmt$logs;

    status.normal := TRUE;
    FOR log_ordinal := LOWERBOUND (lgv$log_names) TO UPPERBOUND (lgv$log_names) DO
      clp$convert_str_to_path_handle (lgv$log_names [log_ordinal], FALSE, TRUE, FALSE, path_handle_name,
            evaluated_file_reference, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clv$log_name_path_handles [log_ordinal] := path_handle_name;
      fmp$request_null_device (rmc$log_device, evaluated_file_reference, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

{ Convert critical window log to a path handle.

    clp$convert_str_to_path_handle (lgv$critical_log_name, FALSE, TRUE, FALSE, path_handle_name,
            evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clv$critical_log_path_handle := path_handle_name;
    fmp$request_null_device (rmc$log_device, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    attachment_option [1].selector := fsc$access_and_share_modes;
    attachment_option [1].access_modes.selector := fsc$specific_access_modes;
    attachment_option [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_option [1].share_modes.selector := fsc$specific_share_modes;
    attachment_option [1].share_modes.value := $fst$file_access_options [];
    mandated_create_attributes [1].selector := fsc$ring_attributes;
    mandated_create_attributes [1].ring_attributes.r1 := osc$tsrv_ring;
    mandated_create_attributes [1].ring_attributes.r2 := osc$sj_ring_3;
    mandated_create_attributes [1].ring_attributes.r3 := osc$sj_ring_3;
    mandated_create_attributes [2].selector := fsc$file_contents_and_processor;
    mandated_create_attributes [2].file_processor := fsc$unknown_processor;
    mandated_create_attributes [2].file_contents := fsc$unknown_contents;
    fsp$open_file (lgv$critical_log_name, amc$record, ^attachment_option, NIL,
            ^mandated_create_attributes, NIL, NIL, file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    fsp$close_file (file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    FOR log_ordinal := LOWERVALUE(pmt$global_logs) TO UPPERVALUE (pmt$global_logs) DO
      IF log_ordinal = pmc$system_log THEN
        mandated_create_attributes [2].file_contents := fsc$unknown_contents;
      ELSE
        mandated_create_attributes [2].file_contents := fsc$binary_log;
      IFEND;
      fsp$open_file (lgv$log_names [log_ordinal], amc$record, ^attachment_option, NIL,
            ^mandated_create_attributes, NIL, NIL, file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      fsp$close_file (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;
    mandated_create_attributes [1].ring_attributes.r1 := osc$user_ring_2;
    mandated_create_attributes [1].ring_attributes.r2 := osc$user_ring_2;
    mandated_create_attributes [1].ring_attributes.r3 := osc$user_ring_2;
    mandated_create_attributes [2].selector := fsc$file_contents_and_processor;
    mandated_create_attributes [2].file_contents := fsc$binary_log;
    mandated_create_attributes [2].file_processor := fsc$unknown_processor;
    FOR log_ordinal := pmc$job_account_log TO pmc$job_statistic_log DO
      fsp$open_file (lgv$log_names [log_ordinal], amc$record, ^attachment_option, NIL,
            ^mandated_create_attributes, NIL, NIL, file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      fsp$close_file (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND clp$request_log_device;

MODEND clm$request_log_device;
*DECK DECK=CLM$RESOURCE_MANAGER_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Resource Manager Commands' ??
MODULE clm$resource_manager_commands;

{
{ PURPOSE:
{   This module contains the processors for the resource management commands.
{ NOTE:
{   The request_terminal command is in the module clm$interactive_commands.
{
?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$compiling_for_test_harness
*copyc cld$parameter_list
*copyc cle$ecc_file_reference
*copyc cle$ecc_parsing
*copyc fsc$local
*copyc oss$job_paged_literal
*copyc ost$status
*copyc rmc$condition_code_limits
?? POP ??
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc clp$evaluate_file_reference
*copyc fsp$create_file
*copyc fsp$path_element
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc rmp$release_resource_command
*copyc rmp$request_null_device
*copyc rmp$reserve_resource_command
*copyc rmp$validate_ansi_string

?? TITLE := 'clp$request_tape_command', EJECT ??

  PROCEDURE [XDCL] clp$request_tape_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{
{ PROCEDURE (osm$reqmt) request_magnetic_tape, reqmt (
{   file, f: file = $required
{   external_vsn, evsn, ev: (BY_NAME) list of any of
{       string 1..6
{       name 1..6
{     anyend = $optional
{   log, l: (BY_NAME, ADVANCED) boolean = false
{   password, pw: (BY_NAME, ADVANCED, SECURE) any of
{       key
{         none
{       keyend
{       name
{     anyend = none
{   recorded_vsn, rvsn, rv: (BY_NAME) list of any of
{       string 1..6
{       name 1..6
{     anyend = $optional
{   removable_media_group, rmg: (BY_NAME, ADVANCED) any of
{       key
{         none
{       keyend
{       name
{     anyend = osd$reqmt_removable_media_group, none
{   ring, r: (BY_NAME) boolean = false
{   density, d, type, t: (BY_NAME) key
{       mt9$800, mt9$1600, mt9$6250, mt18$38000
{     keyend = osd$reqmt_default_density, mt9$1600
{   volume_overflow_allowed, voa: (BY_NAME, ADVANCED) boolean = true
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 23] of clt$pdt_parameter_name,
      parameters: array [1 .. 10] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type4: 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$name_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type6: 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$name_type_qualifier,
        recend,
        default_name: string (31),
        default_value: string (4),
      recend,
      type7: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_name: string (25),
        default_value: string (8),
      recend,
      type9: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 10, 6, 9, 18, 29, 726],
    clc$command, 23, 10, 1, 4, 0, 0, 10, 'OSM$REQMT'], [
    ['D                              ',clc$alias_entry, 8],
    ['DENSITY                        ',clc$nominal_entry, 8],
    ['EV                             ',clc$abbreviation_entry, 2],
    ['EVSN                           ',clc$alias_entry, 2],
    ['EXTERNAL_VSN                   ',clc$nominal_entry, 2],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['L                              ',clc$abbreviation_entry, 3],
    ['LOG                            ',clc$nominal_entry, 3],
    ['PASSWORD                       ',clc$nominal_entry, 4],
    ['PW                             ',clc$abbreviation_entry, 4],
    ['R                              ',clc$abbreviation_entry, 7],
    ['RECORDED_VSN                   ',clc$nominal_entry, 5],
    ['REMOVABLE_MEDIA_GROUP          ',clc$nominal_entry, 6],
    ['RING                           ',clc$nominal_entry, 7],
    ['RMG                            ',clc$abbreviation_entry, 6],
    ['RV                             ',clc$abbreviation_entry, 5],
    ['RVSN                           ',clc$alias_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 10],
    ['T                              ',clc$abbreviation_entry, 8],
    ['TYPE                           ',clc$alias_entry, 8],
    ['VOA                            ',clc$abbreviation_entry, 9],
    ['VOLUME_OVERFLOW_ALLOWED        ',clc$nominal_entry, 9]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 49, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [9, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [10, clc$advanced_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 5
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 49, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [14, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 31, 4],
{ PARAMETER 7
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 8
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 25, 8],
{ PARAMETER 9
    [23, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 10
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
      TRUE, 2],
      8, [[1, 0, clc$string_type], [1, 6, FALSE]],
      5, [[1, 0, clc$name_type], [1, 6]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'none'],
{ PARAMETER 5
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
      TRUE, 2],
      8, [[1, 0, clc$string_type], [1, 6, FALSE]],
      5, [[1, 0, clc$name_type], [1, 6]]
      ]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'OSD$REQMT_REMOVABLE_MEDIA_GROUP',
    'none'],
{ PARAMETER 7
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 8
    [[1, 0, clc$keyword_type], [4], [
    ['MT18$38000                     ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['MT9$1600                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['MT9$6250                       ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['MT9$800                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'OSD$REQMT_DEFAULT_DENSITY',
    'mt9$1600'],
{ PARAMETER 9
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 10
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$external_vsn = 2,
      p$log = 3,
      p$password = 4,
      p$recorded_vsn = 5,
      p$removable_media_group = 6,
      p$ring = 7,
      p$density = 8,
      p$volume_overflow_allowed = 9,
      p$status = 10;

    VAR
      pvt: array [1 .. 10] of clt$parameter_value;

    CONST
      ao_access_and_share_modes = 1,
      da_density = 1,
      da_device_class = 2,
      da_removable_media_group = 3,
      da_volume_list = 4,
      da_volume_overflow_allowed = 5,
      fa_attachment_logging = 1,
      fa_file_password = 2,
      max_attachment_options = 1,
      max_device_attributes = 5,
      max_file_attributes = 2;

    VAR
      attachment_options: ^fst$attachment_options,
      current_evsn: ^clt$data_value,
      current_rvsn: ^clt$data_value,
      device_attributes: ^fst$device_attributes,
      evaluated_file_reference: fst$evaluated_file_reference,
      evsn_count: integer,
      file_attributes: ^fst$file_attributes,
      volume_list_index: integer,
      resolved_path: fst$path,
      rvsn_count: integer,
      volume_list: ^rmt$volume_list,
      vsn_count: integer;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_file_reference (pvt [p$file].value^.file_value^, $clt$file_ref_parsing_options [],
          FALSE, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH attachment_options: [1 .. max_attachment_options];
    attachment_options^ [ao_access_and_share_modes].selector := fsc$access_and_share_modes;
    attachment_options^ [ao_access_and_share_modes].access_modes.selector := fsc$specific_access_modes;
    IF pvt [p$ring].value^.boolean_value.value THEN
      attachment_options^ [ao_access_and_share_modes].access_modes.value := - $fst$file_access_options [];
    ELSE
      attachment_options^ [ao_access_and_share_modes].access_modes.value :=
            $fst$file_access_options [fsc$read, fsc$execute];
    IFEND;
    attachment_options^ [ao_access_and_share_modes].share_modes.selector := fsc$specific_share_modes;
    attachment_options^ [ao_access_and_share_modes].share_modes.value := $fst$file_access_options [];

    PUSH file_attributes: [1 .. max_file_attributes];

    file_attributes^ [fa_attachment_logging].selector := fsc$attachment_logging;
    file_attributes^ [fa_attachment_logging].attachment_logging := pvt [p$log].value^.boolean_value.value;

    file_attributes^ [fa_file_password].selector := fsc$file_password;
    IF pvt [p$password].value^.kind = clc$name THEN
      file_attributes^ [fa_file_password].file_password := pvt [p$password].value^.name_value;
    ELSE { keyword = NONE }
      file_attributes^ [fa_file_password].file_password := osc$null_name;
    IFEND;

    PUSH device_attributes: [1 .. max_device_attributes];

    device_attributes^ [da_device_class].selector := fsc$device_class;
    device_attributes^ [da_device_class].device_class := fsc$magnetic_tape_device;

    device_attributes^ [da_removable_media_group].selector := fsc$removable_media_group;
    IF pvt [p$removable_media_group].value^.kind = clc$name THEN
      device_attributes^ [da_removable_media_group].removable_media_group :=
            pvt [p$removable_media_group].value^.name_value;
    ELSE { keyword = NONE }
      device_attributes^ [da_removable_media_group].removable_media_group := osc$null_name;
    IFEND;

    evsn_count := clp$count_list_elements (pvt [p$external_vsn].value);
    rvsn_count := clp$count_list_elements (pvt [p$recorded_vsn].value);

    IF ((rvsn_count > 0) AND (evsn_count > 0)) AND (rvsn_count <> evsn_count) THEN
      osp$set_status_condition (cle$inconsistent_vsn_lists, status);
      RETURN;
    IFEND;

    IF rvsn_count > evsn_count THEN
      vsn_count := rvsn_count;
    ELSE
      vsn_count := evsn_count;
    IFEND;

    IF vsn_count = 0 THEN
      vsn_count := 1;
    IFEND;

    PUSH volume_list: [1 .. vsn_count];

    device_attributes^ [da_volume_list].selector := fsc$volume_list;
    device_attributes^ [da_volume_list].volume_list := volume_list;

    current_evsn := pvt [p$external_vsn].value;
    current_rvsn := pvt [p$recorded_vsn].value;

    FOR volume_list_index := 1 TO vsn_count DO
      IF current_evsn <> NIL THEN
        IF current_evsn^.element_value^.kind = clc$string THEN
          volume_list^ [volume_list_index].external_vsn := current_evsn^.element_value^.string_value^;
        ELSEIF current_evsn^.element_value^.kind = clc$name THEN
          volume_list^ [volume_list_index].external_vsn := current_evsn^.element_value^.name_value;
        IFEND;
        current_evsn := current_evsn^.link;
      ELSE
        volume_list^ [volume_list_index].external_vsn := rmc$unspecified_vsn;
      IFEND;
      IF current_rvsn <> NIL THEN
        IF current_rvsn^.element_value^.kind = clc$string THEN
          volume_list^ [volume_list_index].recorded_vsn := current_rvsn^.element_value^.string_value^;
        ELSEIF current_rvsn^.element_value^.kind = clc$name THEN
          volume_list^ [volume_list_index].recorded_vsn := current_rvsn^.element_value^.name_value;
        IFEND;
        current_rvsn := current_rvsn^.link;
      ELSE
        volume_list^ [volume_list_index].recorded_vsn := rmc$unspecified_vsn;
      IFEND;
    FOREND;

    FOR volume_list_index := 1 TO UPPERBOUND (volume_list^) DO
      rmp$validate_ansi_string (volume_list^ [volume_list_index].external_vsn,
            volume_list^ [volume_list_index].external_vsn, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (rmc$resource_management_id, cle$improper_vsn_value,
              volume_list^ [volume_list_index].external_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'EXTERNAL_VSN', status);
        RETURN;
      IFEND;

      rmp$validate_ansi_string (volume_list^ [volume_list_index].recorded_vsn,
            volume_list^ [volume_list_index].recorded_vsn, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (rmc$resource_management_id, cle$improper_vsn_value,
              volume_list^ [volume_list_index].recorded_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'RECORDED_VSN', status);
        RETURN;
      IFEND;
    FOREND;

    device_attributes^ [da_density].selector := fsc$density;
    IF pvt [p$density].value^.keyword_value = 'MT9$800' THEN
      device_attributes^ [da_density].density := rmc$800;
    ELSEIF pvt [p$density].value^.keyword_value = 'MT9$1600' THEN
      device_attributes^ [da_density].density := rmc$1600;
    ELSEIF pvt [p$density].value^.keyword_value = 'MT9$6250' THEN
      device_attributes^ [da_density].density := rmc$6250;
    ELSEIF pvt [p$density].value^.keyword_value = 'MT18$38000' THEN
      device_attributes^ [da_density].density := rmc$38000;
    IFEND;

    device_attributes^ [da_volume_overflow_allowed].selector := fsc$volume_overflow_allowed;
    device_attributes^ [da_volume_overflow_allowed].volume_overflow_allowed :=
          pvt [p$volume_overflow_allowed].value^.boolean_value.value;

?IF NOT clc$compiling_for_test_harness THEN
    fsp$create_file (pvt [p$file].value^.file_value^, attachment_options, {cycle_attributes} NIL,
          device_attributes, file_attributes, resolved_path, status);
?IFEND

  PROCEND clp$request_tape_command;

?? TITLE := 'clp$reserve_resource_command', EJECT ??

  PROCEDURE [XDCL] clp$reserve_resource_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$resr) reserve_resource, reserve_resources, resr (
{   mt9$800: integer 0..2147483647 = 0
{   mt9$1600: integer 0..2147483647 = 0
{   mt9$6250: integer 0..2147483647 = 0
{   mt18$38000: integer 0..2147483647 = 0
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 2, 10, 11, 46, 4, 60],
    clc$command, 5, 5, 0, 0, 0, 0, 5, 'OSM$RESR'], [
    ['MT18$38000                     ',clc$nominal_entry, 4],
    ['MT9$1600                       ',clc$nominal_entry, 2],
    ['MT9$6250                       ',clc$nominal_entry, 3],
    ['MT9$800                        ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 2147483647, 10],
    '0'],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, 2147483647, 10],
    '0'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, 2147483647, 10],
    '0'],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [0, 2147483647, 10],
    '0'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$mt9$800 = 1,
      p$mt9$1600 = 2,
      p$mt9$6250 = 3,
      p$mt18$38000 = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

  VAR
    reservation: rmt$tape_reservation;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    reservation [rmc$800] := pvt [p$mt9$800].value^.integer_value.value;
    reservation [rmc$1600] := pvt [p$mt9$1600].value^.integer_value.value;
    reservation [rmc$6250] := pvt [p$mt9$6250].value^.integer_value.value;
    reservation [rmc$38000] := pvt [p$mt18$38000].value^.integer_value.value;

    IF (reservation [rmc$800] = 0) AND (reservation [rmc$1600] = 0) AND
          (reservation [rmc$6250] = 0) AND (reservation [rmc$38000] = 0) THEN
      osp$set_status_abnormal ('CL', cle$required_parameter_omitted,
            'MT9$800, MT9$1600, MT9$6250 or MT18$38000', status);
      RETURN;
    IFEND;

    rmp$reserve_resource_command (reservation, status);

  PROCEND clp$reserve_resource_command;
?? TITLE := 'clp$release_resource_command', EJECT ??

  PROCEDURE [XDCL] clp$release_resource_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$relr) release_resource, release_resources, relr (
{   mt9$800: any of
{       key
{         all, a
{       keyend
{       integer 0..2147483647
{     anyend = 0
{   mt9$1600: any of
{       key
{         all, a
{       keyend
{       integer 0..2147483647
{     anyend = 0
{   mt9$6250: any of
{       key
{         all, a
{       keyend
{       integer 0..2147483647
{     anyend = 0
{   mt18$38000: any of
{       key
{         all, a
{       keyend
{       integer 0..2147483647
{     anyend = 0
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (1),
      recend,
      type2: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (1),
      recend,
      type3: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (1),
      recend,
      type4: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 2, 10, 11, 49, 28, 604],
    clc$command, 5, 5, 0, 0, 0, 0, 5, 'OSM$RELR'], [
    ['MT18$38000                     ',clc$nominal_entry, 4],
    ['MT9$1600                       ',clc$nominal_entry, 2],
    ['MT9$6250                       ',clc$nominal_entry, 3],
    ['MT9$800                        ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['A                              ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, 2147483647, 10]]
    ,
    '0'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['A                              ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, 2147483647, 10]]
    ,
    '0'],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['A                              ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, 2147483647, 10]]
    ,
    '0'],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['A                              ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, 2147483647, 10]]
    ,
    '0'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$mt9$800 = 1,
      p$mt9$1600 = 2,
      p$mt9$6250 = 3,
      p$mt18$38000 = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

  VAR
    reservation: rmt$tape_reservation;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$mt9$800].value^.kind = clc$integer THEN
      reservation [rmc$800] := pvt [p$mt9$800].value^.integer_value.value;
    ELSE  { ALL or A entered
      reservation [rmc$800] := UPPERVALUE (reservation [rmc$800]);
    IFEND;

    IF pvt [p$mt9$1600].value^.kind = clc$integer THEN
      reservation [rmc$1600] := pvt [p$mt9$1600].value^.integer_value.value;
    ELSE  { ALL or A entered
      reservation [rmc$1600] := UPPERVALUE (reservation [rmc$1600]);
    IFEND;

    IF pvt [p$mt9$6250].value^.kind = clc$integer THEN
      reservation [rmc$6250] := pvt [p$mt9$6250].value^.integer_value.value;
    ELSE  { ALL or A entered
      reservation [rmc$6250] := UPPERVALUE (reservation [rmc$6250]);
    IFEND;

    IF pvt [p$mt18$38000].value^.kind = clc$integer THEN
      reservation [rmc$38000] := pvt [p$mt18$38000].value^.integer_value.value;
    ELSE  { ALL or A entered
      reservation [rmc$38000] := UPPERVALUE (reservation [rmc$38000]);
    IFEND;

    IF (reservation [rmc$800] = 0) AND (reservation [rmc$1600] = 0) AND
          (reservation [rmc$6250] = 0) AND (reservation [rmc$38000] = 0) THEN
      osp$set_status_abnormal ('CL', cle$required_parameter_omitted,
            'MT9$800, MT9$1600, MT9$6250 or MT18$38000', status);
      RETURN;
    IFEND;

    rmp$release_resource_command (reservation, status);

  PROCEND clp$release_resource_command;
?? TITLE := 'clp$request_null_command', EJECT ??

  PROCEDURE [XDCL] clp$request_null_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$reqn) request_null, reqn (
{   file, f: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 18, 13, 13, 55, 463],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$REQN'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

  VAR
    evaluated_file_reference: fst$evaluated_file_reference;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_file_reference (pvt [p$file].value^.file_value^, $clt$file_ref_parsing_options [],
          FALSE, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (fsp$path_element (^evaluated_file_reference, 1) ^ <> fsc$local) OR
          (evaluated_file_reference.number_of_path_elements = 1) THEN
      osp$set_status_abnormal ('CL', cle$only_permitted_on_loc_file, '', status);
      RETURN;
    IFEND;

    rmp$request_null_device (pvt [p$file].value^.file_value^, status);

  PROCEND clp$request_null_command;

MODEND clm$resource_manager_commands;
*DECK DECK=CLM$RETURN_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Return Command' ??
MODULE clm$return_command;

{
{ PURPOSE:
{   This module contains the processor for the return command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*copyc fsp$detach_file
*copyc clp$evaluate_parameters

?? TITLE := 'clp$_detach_file', EJECT ??

  PROCEDURE [XDCL] clp$_detach_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$detf) detach_file, detach_files, detf (
{   files, file, f: list of file = $required
{   unload_volume, uv: (BY_NAME, ADVANCED) boolean = true
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 7, 22, 11, 41, 55, 190],
    clc$command, 6, 3, 1, 1, 0, 0, 3, 'OSM$DETF'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$alias_entry, 1],
    ['FILES                          ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['UNLOAD_VOLUME                  ',clc$nominal_entry, 2],
    ['UV                             ',clc$abbreviation_entry, 2]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [5, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$files = 1,
      p$unload_volume = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      detachment_options: ^fst$detachment_options,
      file_list: ^clt$data_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$unload_volume].value^.boolean_value.value THEN
      detachment_options := NIL;
    ELSE
      PUSH detachment_options: [1 .. 1];
      detachment_options^ [1].selector := fsc$do_unload_volume;
      detachment_options^ [1].unload_volume := FALSE;
    IFEND;

    file_list := pvt [p$files].value;
    WHILE file_list <> NIL DO
      fsp$detach_file (file_list^.element_value^.file_value^, detachment_options, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      file_list := file_list^.link;
    WHILEND;

  PROCEND clp$_detach_file;

MODEND clm$return_command;
*DECK DECK=CLM$REWIND_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Rewind Command' ??
MODULE clm$rewind_command;

{
{ PURPOSE:
{   This module contains the processor for the rewind command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$lfn_program_actions
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$rewind
*copyc amv$nil_file_identifier
*copyc bap$sl_rewind_file_command
*copyc clp$convert_string_to_file
*copyc clp$evaluate_parameters
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc rmp$get_device_class

?? TITLE := 'clp$rewind_command', EJECT ??

  PROCEDURE [XDCL] clp$rewind_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$rewf) rewind_file, rewind_files, rewf (
{   files, file, f: list of file = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 18, 13, 17, 0, 998],
    clc$command, 4, 2, 1, 0, 0, 0, 2, 'OSM$REWF'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$alias_entry, 1],
    ['FILES                          ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$files = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      fsp$close_file (file_id, handler_status);

      handler_status.normal := TRUE;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      current_file: ^clt$data_value,
      device_assigned: boolean,
      device_class: rmt$device_class,
      file: clt$file,
      file_attachment: array [1 .. 2] of fst$attachment_option,
      file_attributes: array [1 .. 1] of amt$get_item,
      file_exists: boolean,
      file_id: amt$file_identifier,
      file_previously_opened: boolean,
      file_set_position_changed: boolean,
      ignore_contains_data: boolean,
      ignore_status: ost$status,
      tape_file_attributes: array [1 .. 1] of amt$get_item;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_id := amv$nil_file_identifier;
    #SPOIL (file_id);
    osp$establish_block_exit_hndlr (^abort_handler);

    current_file := pvt [p$files].value;

  /rewind_files/
    WHILE current_file <> NIL DO

      file_attributes [1].key := amc$null_attribute;

      file_attachment [1].selector := fsc$create_file;
      file_attachment [1].create_file := FALSE;
      file_attachment [2].selector := fsc$access_and_share_modes;
      file_attachment [2].access_modes.selector := fsc$permitted_access_modes;
      file_attachment [2].share_modes.selector := fsc$required_share_modes;

      amp$get_file_attributes (current_file^.element_value^.file_value^, file_attributes,
            file_exists, file_previously_opened, ignore_contains_data, status);
      IF NOT status.normal THEN
        EXIT /rewind_files/;
      IFEND;
      IF NOT file_exists THEN
        osp$set_status_abnormal ('CL', ame$file_not_known, current_file^.element_value^.file_value^, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'REWIND_FILE', status);
        EXIT /rewind_files/;
      IFEND;
      IF file_previously_opened THEN
        rmp$get_device_class (current_file^.element_value^.file_value^, device_assigned,
              device_class, status);
        IF NOT status.normal THEN
          EXIT /rewind_files/;
        IFEND;
        IF device_assigned AND (device_class = rmc$magnetic_tape_device) THEN
          tape_file_attributes [1].key := amc$label_type;
          amp$get_file_attributes (current_file^.element_value^.file_value^, tape_file_attributes,
                file_exists, file_previously_opened, ignore_contains_data, status);
          IF NOT status.normal THEN
            EXIT /rewind_files/;
          IFEND;
          IF tape_file_attributes [1].label_type = amc$labelled THEN
            clp$convert_string_to_file (current_file^.element_value^.file_value^, file, status);
            IF NOT status.normal THEN
              EXIT /rewind_files/;
            IFEND;
            bap$sl_rewind_file_command (file.local_file_name, status);
            IF NOT status.normal THEN
              EXIT /rewind_files/;
            ELSE
              current_file := current_file^.link;
              CYCLE /rewind_files/;
            IFEND;
          IFEND;
        IFEND;
        fsp$open_file (current_file^.element_value^.file_value^, amc$record, ^file_attachment, NIL, NIL, NIL,
              NIL, file_id, status);
        IF NOT status.normal THEN
          EXIT /rewind_files/;
        IFEND;
        amp$rewind (file_id, osc$wait, status);
        IF status.normal THEN
          fsp$close_file (file_id, status);
        ELSE
          fsp$close_file (file_id, ignore_status);
        IFEND;
        IF NOT status.normal THEN
          EXIT /rewind_files/;
        IFEND;
      IFEND;
      current_file := current_file^.link;
    WHILEND /rewind_files/;

    osp$disestablish_cond_handler;

  PROCEND clp$rewind_command;

MODEND clm$rewind_command;
*DECK DECK=CLM$SCAN_EXPRESSION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Expression Scanner' ??
MODULE clm$scan_expression;

{
{ PURPOSE:
{   This module contains the original SCL command expression evaluation
{   procedure.  This interface has been supplanted by clp$evaluate_expression
{   but still exists for compatibility with system levels prior to NOS/VE
{   release 1.3.1.
{
{ DESIGN:
{   The (old style) value kind specifier is translated to a (new) type
{   description.  The internal version of the (new) expression evaluator is
{   called.  If appropriate, an "old style" application value scanner is called
{   to produce the "old style" result or the data value is simply converted to
{   the "old style" result.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc cle$ecc_parsing
*copyc cle$unable_to_call_av_scanner
*copyc clk$scan_expression
*copyc clt$value_kind_specifier
*IF NOT $true(osv$unix)
*copyc oss$job_paged_literal
*IFEND
*copyc ost$status
?? POP ??
*copyc clp$append_status_parse_state
*copyc clp$convert_value_to_clt$value
*copyc clp$get_work_area
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*copyc clp$internal_evaluate_expr
*copyc clp$scan_non_space_lexical_unit
*copyc clp$translate_vks
*copyc osp$append_status_parameter
*IF NOT $true(osv$unix)
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*IFEND
*copyc osp$set_status_abnormal
*IF NOT $true(osv$unix)
*copyc pmp$continue_to_cause
*copyc pmp$load
*IFEND

?? TITLE := 'clv$value_descriptors', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    clv$value_descriptors: [XDCL, READ, oss$job_paged_literal] array
*ELSE
    clv$value_descriptors: [XDCL, READ] array
*IFEND
          [clc$variable_reference .. clc$status_value] of string (8) := ['VARIABLE', 'FILE', 'NAME', 'STRING',
          'REAL', 'INTEGER', 'BOOLEAN', 'STATUS'];

*IF NOT $true(osv$unix)
?? TITLE := 'clp$scan_expression', EJECT ??
*copyc clh$scan_expression

  PROCEDURE [XDCL, #GATE] clp$scan_expression
    (    expression: string ( * );
         value_kind_specifier: clt$value_kind_specifier;
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      application_type_present: boolean,
      ignore_result_type_description: ^clt$type_description,
      lexical_units: ^clt$lexical_units,
      local_status: ost$status,
      original_work_area: ^clt$work_area,
      parse: clt$parse_state,
      result: ^clt$data_value,
      type_description: clt$type_description,
      work_area_ptr: ^^clt$work_area;

?? NEWTITLE := 'handle_application_value', EJECT ??

    PROCEDURE handle_application_value;

      VAR
        application_value_scanner: ^clt$application_value_scanner,
        callers_save_area: ^ost$stack_frame_save_area,
        loaded_address: pmt$loaded_address;

?? NEWTITLE := 'bad_av_scanner_pointer_handler', EJECT ??

      PROCEDURE bad_av_scanner_pointer_handler
        (    condition: pmt$condition;
             ignore_info: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);


        IF ((condition.selector = pmc$system_conditions) AND
              ((($pmt$system_conditions [pmc$instruction_specification, pmc$address_specification,
              pmc$access_violation, pmc$environment_specification, pmc$invalid_segment_ring_0,
              pmc$out_call_in_return]) * condition.system_conditions) <> $pmt$system_conditions [])) AND
              (save_area^.minimum_save_area.a2_previous_save_area = callers_save_area) THEN
          osp$set_status_abnormal ('CL', cle$unable_to_call_av_scanner, value_kind_specifier.value_name,
                status);
          EXIT handle_application_value;
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      PROCEND bad_av_scanner_pointer_handler;
?? OLDTITLE, EJECT ??

      CASE value_kind_specifier.scanner.kind OF
      = clc$linked_av_scanner =
        application_value_scanner := value_kind_specifier.scanner.proc;
      = clc$unlinked_av_scanner =
        pmp$load (value_kind_specifier.scanner.name, pmc$procedure_address, loaded_address, local_status);
        IF NOT local_status.normal THEN
          osp$set_status_abnormal ('CL', cle$unable_to_call_av_scanner, value_kind_specifier.value_name,
                local_status);
          RETURN;
        IFEND;
        #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, application_value_scanner);
      ELSE
        application_value_scanner := ^clp$unspecified_av_scanner;
      CASEND;

*IF NOT $true(osv$unix)
      callers_save_area := #PREVIOUS_SAVE_AREA ();
*ELSE
      callers_save_area := NIL;
*IFEND
      #SPOIL (callers_save_area);
      osp$establish_condition_handler (^bad_av_scanner_pointer_handler, FALSE);

      value.descriptor := value_kind_specifier.value_name;
      value.kind := clc$application_value;

      application_value_scanner^ (value_kind_specifier.value_name, value_kind_specifier.keyword_values,
            result^.application_value^, value, local_status);

      osp$disestablish_cond_handler;

    PROCEND handle_application_value;
?? OLDTITLE, EJECT ??

    #KEYPOINT (osk$entry, 0, clk$scan_expression);

    status.normal := TRUE;
    local_status.normal := TRUE;
    original_work_area := NIL;

  /evaluate/
    BEGIN
*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^work_area_ptr), work_area_ptr, local_status);
*ELSE
      clp$get_work_area (osc$user_ring, work_area_ptr, local_status);
*IFEND
      IF NOT local_status.normal THEN
        EXIT /evaluate/;
      IFEND;
      original_work_area := work_area_ptr^;

      clp$translate_vks (value_kind_specifier, FALSE, work_area_ptr^, application_type_present,
            type_description, local_status);
      IF NOT local_status.normal THEN
        EXIT /evaluate/;
      IFEND;

      clp$identify_lexical_units (^expression, work_area_ptr^, lexical_units, local_status);
      IF NOT local_status.normal THEN
        EXIT /evaluate/;
      IFEND;

      clp$initialize_parse_state (^expression, lexical_units, parse);
      clp$scan_non_space_lexical_unit (parse);

      clp$internal_evaluate_expr (parse, ^type_description, work_area_ptr^, ignore_result_type_description,
            result, local_status);
      IF NOT local_status.normal THEN
        EXIT /evaluate/;
      IFEND;

      IF parse.unit_is_space THEN
        clp$scan_non_space_lexical_unit (parse);
      IFEND;
      IF parse.unit.kind <> clc$lex_end_of_line THEN
        osp$set_status_abnormal ('CL', cle$expecting_end_of_expression, '', local_status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, local_status);
        EXIT /evaluate/;
      IFEND;

      IF result^.kind = clc$unspecified THEN
        osp$set_status_abnormal ('CL', cle$unspecified_value_for_req, 'clp$scan_expression', local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, expression, local_status);
      IFEND;

      IF application_type_present AND (result^.kind = clc$application) THEN
        handle_application_value;
      ELSE
        clp$convert_value_to_clt$value (result, 1, 1, clc$low, value, local_status);
      IFEND;
    END /evaluate/;

    IF original_work_area <> NIL THEN
      work_area_ptr^ := original_work_area;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, clk$scan_expression);

  PROCEND clp$scan_expression;
?? TITLE := 'clp$unspecified_av_scanner', EJECT ??

  PROCEDURE [XDCL] clp$unspecified_av_scanner
    (    value_name: clt$application_value_name;
         keyword_values: ^array [1 .. * ] of ost$name;
         text: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      application_area: ^clt$application_value,
      application_string: ^ost$string;


    application_area := ^value.application;
    RESET application_area;
    NEXT application_string IN application_area;
    IF STRLENGTH (text) <= osc$max_string_size THEN
      application_string^.size := STRLENGTH (text);
    ELSE
      application_string^.size := osc$max_string_size;
    IFEND;
    application_string^.value := text;

  PROCEND clp$unspecified_av_scanner;
*IFEND

MODEND clm$scan_expression;
*DECK DECK=CLM$SCAN_PARAMETER_LIST EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Parameter List Scanner' ??
MODULE clm$scan_parameter_list;

{
{ PURPOSE:
{   This module contains the original SCL command/function parameter evaluation
{   procedures.  These interfaces have been supplanted by
{   clp$evaluate_parameters but still exist for compatibility with system
{   levels prior to NOS/VE release 1.3.1.
{
{ DESIGN:
{   The (old style) parameter/argument descriptor table (P/ADT) is translated
{   to the internal (unbundled) form of the (new) parameter description table.
{   A "check parameter procedure" is established to handle any "old style"
{   application values.  The internal version of the (new) parameter evaluator
{   is called and (for commands) the results are saved in such a way as to
{   allow the "old style" parameter retrieval routines to work.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc cle$ecc_function_processing
*copyc cle$ecc_parsing
*copyc cle$parameters_displayed
*copyc cle$unable_to_call_av_scanner
*copyc cle$unexpected_call_to
*copyc clk$scan_argument_list
*copyc clk$scan_parameter_list
*copyc clt$argument_descriptor_table
*copyc clt$argument_value_table
*copyc clt$function
*copyc clt$name
*copyc clt$parameter_descriptor_table
*copyc clt$parameter_list
*copyc ost$status
?? POP ??
*copyc clp$convert_clt$value_to_value
*copyc clp$convert_value_to_clt$value
*copyc clp$display_cmnd_or_func_info
*IF NOT $true(osv$unix)
*copyc clp$echo_command
*IFEND
*copyc clp$get_parameter_list_parse
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*copyc clp$internal_evaluate_params
*IF NOT $true(osv$unix)
*copyc clp$log_command_line
*copyc clp$prepare_for_log_and_or_echo
*IFEND
*copyc clp$setup_parameter_evaluation
*copyc clp$save_evaluated_parameters
*copyc clp$scan_non_space_lexical_unit
*copyc clp$translate_adt
*IF NOT $true(osv$unix)
*copyc clp$translate_pdt
*copyc clp$unspecified_av_scanner
*IFEND
*copyc osp$append_status_parameter
*IF NOT $true(osv$unix)
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc pmp$continue_to_cause
*copyc pmp$load
*IFEND

*IF NOT $true(osv$unix)
?? TITLE := 'clp$scan_parameter_list', EJECT ??
*copyc clh$scan_parameter_list

  PROCEDURE [XDCL, #GATE] clp$scan_parameter_list
    (    parameter_list: clt$parameter_list;
         parameter_descriptor_table: clt$parameter_descriptor_table;
     VAR status: ost$status);

    VAR
      application_type_present: boolean,
      check_parameters_procedure: clt$check_parameters_procedure,
      command_reference_text: ^clt$command_line,
      edited_command: ^clt$parameter_list_text,
      evaluation_context: clt$parameter_eval_context,
      help_context: clt$parameter_help_context,
      ignore_status: ^ost$status,
      local_status: ost$status,
      parse: clt$parse_state,
      pdt: ^clt$unbundled_pdt,
      pvt: ^clt$parameter_value_table,
      work_area_ptr: ^^clt$work_area;

?? NEWTITLE := 'handle_application_values', EJECT ??

    PROCEDURE handle_application_values
      (    pvt: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
        application_value_scanner: ^clt$application_value_scanner,
        callers_save_area: ^ost$stack_frame_save_area,
        loaded_address: pmt$loaded_address,
        scanner_called: boolean,
        value: clt$value,
        vks: ^clt$value_kind_specifier;

*copy  clh$application_value_scanner
?? NEWTITLE := 'bad_av_scanner_pointer_handler', EJECT ??

      PROCEDURE bad_av_scanner_pointer_handler
        (    condition: pmt$condition;
             ignore_info: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);


        IF ((condition.selector = pmc$system_conditions) AND
              ((($pmt$system_conditions [pmc$instruction_specification, pmc$address_specification,
              pmc$access_violation, pmc$environment_specification, pmc$invalid_segment_ring_0,
              pmc$out_call_in_return]) * condition.system_conditions) <> $pmt$system_conditions [])) AND
              (save_area^.minimum_save_area.a2_previous_save_area = callers_save_area) THEN
          osp$set_status_abnormal ('CL', cle$unable_to_call_av_scanner, vks^.value_name, status);
          EXIT handle_application_values;
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      PROCEND bad_av_scanner_pointer_handler;
?? TITLE := 'handle_element', EJECT ??

      PROCEDURE [INLINE] handle_element
        (VAR data_value {input, output} : ^clt$data_value);


        IF NOT scanner_called THEN
*IF NOT $true(osv$unix)
          callers_save_area := #PREVIOUS_SAVE_AREA ();
*ELSE
          callers_save_area := NIL;
*IFEND
          #SPOIL (callers_save_area);
          osp$establish_condition_handler (^bad_av_scanner_pointer_handler, FALSE);
        IFEND;

        value.descriptor := vks^.value_name;
        value.kind := clc$application_value;

        application_value_scanner^ (vks^.value_name, vks^.keyword_values, data_value^.application_value^,
              value, status);

        IF NOT scanner_called THEN
          osp$disestablish_cond_handler;
          scanner_called := TRUE;
        IFEND;

        IF status.normal THEN
          clp$convert_clt$value_to_value (value, work_area_ptr^, data_value, status);
        IFEND;

        IF NOT status.normal THEN
          EXIT handle_application_values;
        IFEND;

      PROCEND handle_element;
?? TITLE := 'handle_list', EJECT ??

      PROCEDURE handle_list
        (    list_value: ^clt$data_value);

        VAR
          current_node: ^clt$data_value;


        current_node := list_value;
        REPEAT
          IF current_node^.element_value <> NIL THEN
            CASE current_node^.element_value^.kind OF
            = clc$application =
              handle_element (current_node^.element_value);
            = clc$list =
              handle_list (current_node^.element_value);
            = clc$range =
              handle_range (current_node^.element_value);
            ELSE
              ;
            CASEND;
          IFEND;
          current_node := current_node^.link;
        UNTIL current_node = NIL;

      PROCEND handle_list;
?? TITLE := 'handle_range', EJECT ??

      PROCEDURE [INLINE] handle_range
        (    range_value: ^clt$data_value);

        VAR
          range_specified: boolean;


        IF range_value^.low_value <> NIL THEN
          range_specified := (range_value^.high_value <> NIL) AND
                (range_value^.high_value <> range_value^.low_value);

          IF range_value^.low_value^.kind = clc$application THEN
            handle_element (range_value^.low_value);
          IFEND;

          IF NOT range_specified THEN
            range_value^.high_value := range_value^.low_value;
          ELSEIF range_value^.high_value^.kind = clc$application THEN
            handle_element (range_value^.high_value);
          IFEND;
        IFEND;

      PROCEND handle_range;
?? OLDTITLE, EJECT ??

      status.normal := TRUE;
      IF (NOT which_parameter.specific) OR (pvt^ [which_parameter.number].passing_method =
            clc$pass_by_reference) THEN
        RETURN;
      IFEND;

      vks := ^parameter_descriptor_table.parameters^ [which_parameter.number].value_kind_specifier;

      IF (pvt^ [which_parameter.number].value = NIL) OR (vks^.kind <> clc$application_value) THEN
        RETURN;
      IFEND;

      CASE vks^.scanner.kind OF
      = clc$linked_av_scanner =
        application_value_scanner := vks^.scanner.proc;
      = clc$unlinked_av_scanner =
        pmp$load (vks^.scanner.name, pmc$procedure_address, loaded_address, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal ('CL', cle$unable_to_call_av_scanner, vks^.value_name, status);
          RETURN;
        IFEND;
        #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, application_value_scanner);
      ELSE
        application_value_scanner := ^clp$unspecified_av_scanner;
      CASEND;

      scanner_called := FALSE;

      CASE pvt^ [which_parameter.number].value^.kind OF
      = clc$application =
        handle_element (pvt^ [which_parameter.number].value);
      = clc$list =
        handle_list (pvt^ [which_parameter.number].value);
      = clc$range =
        handle_range (pvt^ [which_parameter.number].value);
      ELSE
        ;
      CASEND;

    PROCEND handle_application_values;
?? OLDTITLE, EJECT ??

    #KEYPOINT (osk$entry, 0, clk$scan_parameter_list);

    status.normal := TRUE;
    local_status.normal := TRUE;

  /scan/
    BEGIN
      clp$setup_parameter_evaluation (NIL, osc$null_name, TRUE, parse, work_area_ptr,
            evaluation_context, help_context, local_status);
      IF NOT local_status.normal THEN
        IF local_status.condition = cle$unexpected_call_to THEN
          local_status.text.size := 0;
          osp$append_status_parameter (osc$status_parameter_delimiter, 'clp$evaluate_parameters',
                local_status);
        IFEND;
        EXIT /scan/;
      IFEND;

      IF parse.text = NIL THEN
        command_reference_text := NIL;
      ELSE
        IF (evaluation_context.interpreter_mode = clc$interpret_mode) AND
              (evaluation_context.prompting_requested) THEN
          command_reference_text := ^parse.text^ (evaluation_context.command_or_function_source^.
                reference_index-1, evaluation_context.command_or_function_source^.reference_size+1);
        ELSE
          command_reference_text := ^parse.text^ (evaluation_context.command_or_function_source^.
                reference_index, evaluation_context.command_or_function_source^.reference_size);
        IFEND;
      IFEND;

      clp$get_parameter_list_parse (^parameter_list, work_area_ptr^, parse, local_status);
      IF NOT local_status.normal THEN
        EXIT /scan/;
      IFEND;

      NEXT pdt IN work_area_ptr^;
      clp$translate_pdt (parameter_descriptor_table, TRUE, FALSE, NIL, NIL, NIL, work_area_ptr^,
            application_type_present, pdt^, local_status);
      IF NOT local_status.normal THEN
        EXIT /scan/;
      ELSEIF application_type_present THEN
        check_parameters_procedure := ^handle_application_values;
      ELSE
        check_parameters_procedure := NIL;
      IFEND;

      IF (evaluation_context.interpreter_mode = clc$help_mode) AND (help_context.help_output_file <> NIL) THEN
        clp$display_cmnd_or_func_info (fsc$list, help_context, evaluation_context.command_or_function_source^,
              evaluation_context.command_or_function_name, pdt^, local_status);
        IF local_status.normal THEN
          osp$set_status_abnormal ('CL', cle$parameters_displayed, '', local_status);
        IFEND;
        EXIT /scan/;
      IFEND;

      IF pdt^.header^.number_of_parameters = 0 THEN
        pvt := NIL;
      ELSE
        NEXT pvt: [1 .. pdt^.header^.number_of_parameters] IN work_area_ptr^;
      IFEND;

      clp$internal_evaluate_params (evaluation_context, pdt^, check_parameters_procedure, parse,
            work_area_ptr^, pvt, local_status);

      IF NOT (evaluation_context.command_logging_completed AND evaluation_context.command_echoing_completed)
            THEN
        clp$prepare_for_log_and_or_echo (command_reference_text, pdt, pvt, work_area_ptr^, edited_command);
        PUSH ignore_status;
        IF NOT evaluation_context.command_logging_completed THEN
          clp$log_command_line (edited_command^, ignore_status^);
        IFEND;
        IF NOT evaluation_context.command_echoing_completed THEN
          clp$echo_command (evaluation_context.interpreter_mode, edited_command^, ignore_status^);
        IFEND;
      IFEND;

      clp$save_evaluated_parameters (pdt, pvt, TRUE, work_area_ptr^, local_status);
    END /scan/;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, clk$scan_parameter_list);

  PROCEND clp$scan_parameter_list;
*IFEND
?? TITLE := 'clp$scan_argument_list', EJECT ??
*copyc clh$scan_argument_list

  PROCEDURE [XDCL, #GATE] clp$scan_argument_list
    (    function_name: clt$name;
         argument_list: string ( * );
         argument_descriptor_table: ^clt$argument_descriptor_table;
         argument_value_table: ^clt$argument_value_table;
     VAR status: ost$status);

    VAR
      application_type_present: boolean,
      check_parameters_procedure: clt$check_parameters_procedure,
      evaluation_context: clt$parameter_eval_context,
      help_context: clt$parameter_help_context,
      lexical_units: ^clt$lexical_units,
      local_status: ost$status,
      p: clt$parameter_number,
      parse: clt$parse_state,
      pdt: ^clt$unbundled_pdt,
      pvt: ^clt$parameter_value_table,
      work_area_ptr: ^^clt$work_area;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'handle_application_values', EJECT ??

    PROCEDURE handle_application_values
      (    pvt: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
        application_value_scanner: ^clt$application_value_scanner,
        callers_save_area: ^ost$stack_frame_save_area,
        loaded_address: pmt$loaded_address,
        scanner_called: boolean,
        value: clt$value,
        vks: ^clt$value_kind_specifier;

*copy  clh$application_value_scanner
?? NEWTITLE := 'bad_av_scanner_pointer_handler', EJECT ??

      PROCEDURE bad_av_scanner_pointer_handler
        (    condition: pmt$condition;
             ignore_info: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);


        IF ((condition.selector = pmc$system_conditions) AND
              ((($pmt$system_conditions [pmc$instruction_specification, pmc$address_specification,
              pmc$access_violation, pmc$environment_specification, pmc$invalid_segment_ring_0,
              pmc$out_call_in_return]) * condition.system_conditions) <> $pmt$system_conditions [])) AND
              (save_area^.minimum_save_area.a2_previous_save_area = callers_save_area) THEN
          osp$set_status_abnormal ('CL', cle$unable_to_call_av_scanner, vks^.value_name, status);
          EXIT handle_application_values;
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      PROCEND bad_av_scanner_pointer_handler;
?? OLDTITLE, EJECT ??

      status.normal := TRUE;
      IF NOT which_parameter.specific THEN
        RETURN;
      IFEND;

      vks := ^argument_descriptor_table^ [which_parameter.number].value_kind_specifier;

      IF (pvt^ [which_parameter.number].value = NIL) OR (pvt^ [which_parameter.number].value^.kind <>
            clc$application) THEN
        RETURN;
      IFEND;

      CASE vks^.scanner.kind OF
      = clc$linked_av_scanner =
        application_value_scanner := vks^.scanner.proc;
      = clc$unlinked_av_scanner =
        pmp$load (vks^.scanner.name, pmc$procedure_address, loaded_address, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal ('CL', cle$unable_to_call_av_scanner, vks^.value_name, status);
          RETURN;
        IFEND;
        #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, application_value_scanner);
      ELSE
        application_value_scanner := ^clp$unspecified_av_scanner;
      CASEND;

*IF NOT $true(osv$unix)
      callers_save_area := #PREVIOUS_SAVE_AREA ();
*ELSE
      callers_save_area := NIL;
*IFEND
      #SPOIL (callers_save_area);
      osp$establish_condition_handler (^bad_av_scanner_pointer_handler, FALSE);

      value.descriptor := vks^.value_name;
      value.kind := clc$application_value;

      application_value_scanner^ (vks^.value_name, vks^.keyword_values,
            pvt^ [which_parameter.number].value^.application_value^, value, status);

      osp$disestablish_cond_handler;

      IF status.normal THEN
        clp$convert_clt$value_to_value (value, work_area_ptr^, pvt^ [which_parameter.number].value, status);
      IFEND;

    PROCEND handle_application_values;
*IFEND
?? OLDTITLE, EJECT ??

    #KEYPOINT (osk$entry, 0, clk$scan_argument_list);

    status.normal := TRUE;
    local_status.normal := TRUE;

  /scan/
    BEGIN
      IF (argument_descriptor_table = NIL) AND (argument_value_table <> NIL) THEN
        osp$set_status_abnormal ('CL', cle$bad_adt, 'ADT is NIL but AVT is not', status);
      ELSEIF (argument_descriptor_table <> NIL) AND (argument_value_table = NIL) THEN
        osp$set_status_abnormal ('CL', cle$bad_adt, 'ADT is not NIL but AVT is', status);
      ELSEIF (argument_descriptor_table <> NIL) AND (UPPERBOUND (argument_descriptor_table^) >
            clc$max_arguments) THEN
        osp$set_status_abnormal ('CL', cle$bad_adt, 'too many arguments', status);
      ELSEIF (argument_descriptor_table <> NIL) AND (UPPERBOUND (argument_descriptor_table^) <>
            UPPERBOUND (argument_value_table^)) THEN
        osp$set_status_abnormal ('CL', cle$bad_adt, 'ADT and AVT are not same size', status);
      IFEND;
      IF NOT status.normal THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, function_name.value, status);
        EXIT /scan/;
      IFEND;

      clp$setup_parameter_evaluation (NIL, osc$null_name, TRUE, parse, work_area_ptr,
            evaluation_context, help_context, local_status);
      IF NOT local_status.normal THEN
        EXIT /scan/;
      IFEND;

      clp$identify_lexical_units (^argument_list, work_area_ptr^, lexical_units, local_status);
      IF NOT local_status.normal THEN
        EXIT /scan/;
      IFEND;
      clp$initialize_parse_state (^argument_list, lexical_units, parse);
      clp$scan_non_space_lexical_unit (parse);

      NEXT pdt IN work_area_ptr^;
      clp$translate_adt (argument_descriptor_table, FALSE, work_area_ptr^, application_type_present, pdt^,
            local_status);
      IF NOT local_status.normal THEN
        EXIT /scan/;
*IF NOT $true(osv$unix)
      ELSEIF application_type_present THEN
        check_parameters_procedure := ^handle_application_values;
*IFEND
      ELSE
        check_parameters_procedure := NIL;
      IFEND;

      IF evaluation_context.interpreter_mode = clc$help_mode THEN
        clp$display_cmnd_or_func_info (fsc$list, help_context, evaluation_context.command_or_function_source^,
              evaluation_context.command_or_function_name, pdt^, local_status);
        IF local_status.normal THEN
          osp$set_status_abnormal ('CL', cle$parameters_displayed, '', local_status);
        IFEND;
        EXIT /scan/;
      IFEND;

      IF pdt^.header^.number_of_parameters = 0 THEN
        pvt := NIL;
      ELSE
        NEXT pvt: [1 .. pdt^.header^.number_of_parameters] IN work_area_ptr^;
      IFEND;

      clp$internal_evaluate_params (evaluation_context, pdt^, check_parameters_procedure, parse,
            work_area_ptr^, pvt, local_status);
      IF NOT local_status.normal THEN
        EXIT /scan/;
      IFEND;

      IF pdt^.header^.number_of_parameters > 0 THEN
        FOR p := 1 TO UPPERBOUND (argument_value_table^) DO
          clp$convert_value_to_clt$value (pvt^ [p].value, 1, 1, clc$low, argument_value_table^ [p],
                local_status);
          IF NOT local_status.normal THEN
            EXIT /scan/;
          IFEND;
        FOREND;
      IFEND;

      clp$save_evaluated_parameters (pdt, pvt, FALSE, work_area_ptr^, local_status);
    END /scan/;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, 0, clk$scan_argument_list);
*IFEND

  PROCEND clp$scan_argument_list;

MODEND clm$scan_parameter_list;
*DECK DECK=CLM$SCAN_PROC_PDT_DECLARATION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : "Old" PROC/PDT declaration scanner' ??
MODULE clm$scan_proc_pdt_declaration;

{
{ PURPOSE:
{   This module contains the scanner for the "old" (pre- SCL New Types)
{   declaration of an SCL PROC or the PDT of a command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$lexical_units_size_pad
*copyc clc$max_proc_names
*copyc clc$proc_pdt_parameter_limits
*copyc cle$ecc_parameter_list
*copyc cle$ecc_parsing
*copyc cle$ecc_proc_declaration
*copyc cle$table_overflow
*copyc cle$work_area_overflow
*copyc clk$scan_proc_declaration
*copyc clt$expression_text
*copyc clt$expression_text_index
*copyc clt$expression_text_size
*copyc clt$internal_input_procedure
*copyc clt$parameter_descriptor_table
*copyc clt$proc_input_procedure
*copyc clt$proc_input_type
*copyc clt$proc_names
*copyc clt$symbolic_parameters
*copyc clt$token
*copyc clt$work_area
*copyc oss$job_paged_literal
*copyc ost$name_reference
?? POP ??
*copyc clp$append_status_parse_state
*copyc clp$echo_command
*copyc clp$evaluate_integer_expression
*copyc clp$get_command_line
*copyc clp$get_work_area
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*copyc clp$scan_non_space_lexical_unit
*copyc clp$scan_unnested_rel_lex_unit
*copyc clp$scan_unnested_sep_lex_unit
*copyc i#current_sequence_position
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper

?? TITLE := 'clp$scan_proc_declaration', EJECT ??
*copyc clh$scan_proc_declaration

  PROCEDURE [XDCL, #GATE] clp$scan_proc_declaration
    (    input_type: clt$proc_input_type;
         get_line: clt$proc_input_procedure;
     VAR proc_name_area: SEQ ( * );
     VAR parameter_name_area: SEQ ( * );
     VAR parameter_area: SEQ ( * );
     VAR symbolic_parameter_area: SEQ ( * );
     VAR extra_info_area: SEQ ( * );
     VAR proc_names: ^clt$proc_names;
     VAR pdt: clt$parameter_descriptor_table;
     VAR symbolic_parameters: ^clt$symbolic_parameters;
     VAR status: ost$status);

    VAR
      lexical_work_area: ^clt$work_area,
      line: ^ost$string;

?? NEWTITLE := 'get_next_line', EJECT ??

    PROCEDURE get_next_line
      (VAR parse: clt$parse_state;
       VAR end_of_input: boolean;
       VAR status: ost$status);

      VAR
        ignore_index: ost$string_index,
        ignore_token: clt$token,
        lexical_units: ^clt$lexical_units;


      get_line^ (line^, ignore_index, ignore_token, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      end_of_input := line^.size = 0;

      RESET lexical_work_area;
      clp$identify_lexical_units (^line^.value (1, line^.size), lexical_work_area, lexical_units, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$initialize_parse_state (^line^.value (1, line^.size), lexical_units, parse);

    PROCEND get_next_line;
?? OLDTITLE, EJECT ??

    VAR
      end_of_input: boolean,
      local_status: ost$status,
      original_work_area: ^^clt$work_area,
      parse: clt$parse_state,
      proc_or_pdt: string (4) {'PROC' or 'PDT'} ,
      work_area: ^clt$work_area;


    #KEYPOINT (osk$entry, 0, clk$scan_proc_declaration);

    status.normal := TRUE;
    local_status.normal := TRUE;

  /scan_declaration/
    BEGIN
      clp$get_work_area (#RING (^parse), original_work_area, local_status);
      IF NOT local_status.normal THEN
        EXIT /scan_declaration/;
      IFEND;
      work_area := original_work_area^;
      NEXT line IN work_area;
      NEXT lexical_work_area: [[REP osc$max_string_size + clc$lexical_units_size_pad OF clt$lexical_unit]] IN
            work_area;
      IF (line = NIL) OR (lexical_work_area = NIL) THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', local_status);
        EXIT /scan_declaration/;
      IFEND;

      IF input_type = clc$pdt_input THEN
        proc_or_pdt := 'PDT ';
      ELSE
        proc_or_pdt := 'PROC';
      IFEND;
      proc_names := NIL;
      pdt.names := NIL;
      pdt.parameters := NIL;
      symbolic_parameters := NIL;

      REPEAT
        get_next_line (parse, end_of_input, status);
        IF NOT status.normal THEN
          EXIT /scan_declaration/;
        ELSEIF end_of_input THEN
          osp$set_status_abnormal ('CL', cle$expecting_proc, proc_or_pdt, local_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'end of input', local_status);
          EXIT /scan_declaration/;
        IFEND;
        clp$scan_non_space_lexical_unit (parse);
      UNTIL parse.unit.kind <> clc$lex_end_of_line;

      clp$internal_generate_old_pdt (proc_or_pdt, ^get_next_line, work_area, parse, proc_name_area,
            parameter_name_area, parameter_area, symbolic_parameter_area, extra_info_area, proc_names,
            pdt, symbolic_parameters, local_status);
    END /scan_declaration/;

    IF NOT local_status.normal THEN
      IF local_status.condition = cle$work_area_overflow THEN
        local_status.text.size := 0;
        osp$append_status_parameter (osc$status_parameter_delimiter, 'clp$scan_proc_declaration',
              local_status);
      IFEND;
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, clk$scan_proc_declaration);

  PROCEND clp$scan_proc_declaration;
?? TITLE := 'clp$internal_generate_old_pdt', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$internal_generate_old_pdt
    (    proc_or_pdt: ost$name_reference;
         get_line: clt$internal_input_procedure;
     VAR work_area {input, output} : ^clt$work_area;
     VAR parse {input, output} : clt$parse_state;
     VAR proc_name_area: SEQ ( * );
     VAR parameter_name_area: SEQ ( * );
     VAR parameter_area: SEQ ( * );
     VAR symbolic_parameter_area: SEQ ( * );
     VAR extra_info_area: SEQ ( * );
     VAR proc_names: ^clt$proc_names;
     VAR pdt: clt$parameter_descriptor_table;
     VAR symbolic_parameters: ^clt$symbolic_parameters;
     VAR status: ost$status);

?? NEWTITLE := 'scan_proc_names', EJECT ??

    PROCEDURE scan_proc_names;

      VAR
        i: 1 .. clc$max_proc_names,
        name: ost$name,
        proc_name_area_ptr: ^SEQ ( * ),
        proc_name_count: 0 .. clc$max_proc_names;


      proc_name_count := 0;
      proc_name_area_ptr := ^proc_name_area;
      WHILE TRUE DO
        IF parse.unit.kind <> clc$lex_name THEN
          osp$set_status_abnormal ('CL', cle$expecting_proc_name, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT clp$internal_generate_old_pdt;
        IFEND;
        #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
        FOR i := 1 TO proc_name_count DO
          IF name = proc_names^ [i] THEN
            osp$set_status_abnormal ('CL', cle$duplicate_proc_name, name, status);
            EXIT clp$internal_generate_old_pdt;
          IFEND;
        FOREND;
        proc_name_count := proc_name_count + 1;
        RESET proc_name_area_ptr;
        NEXT proc_names: [1 .. proc_name_count] IN proc_name_area_ptr;
        IF proc_names = NIL THEN
          osp$set_status_abnormal ('CL', cle$table_overflow, 'Proc Names', status);
          EXIT clp$internal_generate_old_pdt;
        IFEND;
        proc_names^ [proc_name_count] := name;
        clp$scan_non_space_lexical_unit (parse);
        CASE parse.unit.kind OF
        = clc$lex_comma =
          clp$scan_non_space_lexical_unit (parse);
        = clc$lex_left_parenthesis, clc$lex_semicolon, clc$lex_end_of_line =
          RETURN;
        ELSE
          IF NOT parse.previous_unit_is_space THEN
            osp$set_status_abnormal ('CL', cle$unexpected_after_proc_name, '', status);
            clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
            EXIT clp$internal_generate_old_pdt;
          IFEND;
        CASEND;
      WHILEND;

    PROCEND scan_proc_names;
?? TITLE := 'scan_parameter_definitions', EJECT ??

    PROCEDURE scan_parameter_definitions;

      VAR
        extra_info_area_ptr: ^SEQ ( * );

?? NEWTITLE := 'scan_parameter_definition', EJECT ??

      PROCEDURE scan_parameter_definition;

        VAR
          parameter_name: ^ost$name,
          parameter_name_is_status: boolean;

?? NEWTITLE := 'scan_parameter_names', EJECT ??

        PROCEDURE scan_parameter_names
          (    parameter_count: 1 .. clc$max_parameters;
           VAR parameter_names {input, output} : ^array [1 .. * ] of clt$parameter_name_descriptor);

          VAR
            first_name_index: 1 .. clc$max_parameter_names + 1,
            i: 1 .. clc$max_parameter_names,
            name: ost$name,
            parameter_name_area_ptr: ^SEQ ( * ),
            parameter_name_count: 0 .. clc$max_parameter_names;


          #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
          parameter_name_area_ptr := ^parameter_name_area;
          IF parameter_names = NIL THEN
            parameter_name_count := 0;
          ELSE
            parameter_name_count := UPPERBOUND (parameter_names^);
          IFEND;
          first_name_index := parameter_name_count + 1;
          WHILE TRUE DO
            FOR i := 1 TO parameter_name_count DO
              IF name = parameter_names^ [i].name THEN
                osp$set_status_abnormal ('CL', cle$duplicate_parameter_name, name, status);
                EXIT clp$internal_generate_old_pdt;
              IFEND;
            FOREND;
            parameter_name_count := parameter_name_count + 1;
            RESET parameter_name_area_ptr;
            NEXT parameter_names: [1 .. parameter_name_count] IN parameter_name_area_ptr;
            IF parameter_names = NIL THEN
              osp$set_status_abnormal ('CL', cle$too_many_parameter_names, '', status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            parameter_names^ [parameter_name_count].name := name;
            parameter_names^ [parameter_name_count].number := parameter_count;
            IF parameter_name_count = first_name_index THEN
              parameter_name := ^parameter_names^ [parameter_name_count].name;
              parameter_name_is_status := name = 'STATUS';
            IFEND;
            clp$scan_non_space_lexical_unit (parse);
            CASE parse.unit.kind OF
            = clc$lex_right_parenthesis, clc$lex_semicolon, clc$lex_end_of_line, clc$lex_assign,
                  clc$lex_colon =
              RETURN;
            = clc$lex_comma =
              clp$scan_non_space_lexical_unit (parse);
            ELSE
              IF NOT parse.previous_unit_is_space THEN
                osp$set_status_abnormal ('CL', cle$unexpected_after_param_name, '', status);
                clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
                EXIT clp$internal_generate_old_pdt;
              IFEND;
            CASEND;
            IF parse.unit.kind <> clc$lex_name THEN
              osp$set_status_abnormal ('CL', cle$expecting_param_name, '', status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
          WHILEND;

        PROCEND scan_parameter_names;
?? TITLE := 'scan_value_spec', EJECT ??

        PROCEDURE scan_value_spec
          (VAR parameter {input, output} : clt$parameter_descriptor;
           VAR symbolic_parameter {input, output} : clt$symbolic_parameter);

?? NEWTITLE := 'scan_value_list_spec', EJECT ??

          PROCEDURE scan_value_list_spec;

            VAR
              high_integer: integer,
              ignore_range_present: boolean,
              low_integer: integer,
              name: ost$name;


            clp$scan_non_space_lexical_unit (parse);
            IF NOT parse.previous_unit_is_space THEN
              osp$set_status_abnormal ('CL', cle$unexpected_after_list, '', status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;

          /optional_list_stuff/
            BEGIN
              IF parse.unit.kind = clc$lex_name THEN
                #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
                IF (name = 'RANGE') OR (name = 'OF') THEN
                  parameter.max_value_sets := clc$max_value_sets;
                  EXIT /optional_list_stuff/;
                IFEND;
              IFEND;
              scan_integer_range (1, clc$max_value_sets, cle$list_bound_out_of_range,
                    cle$min_list_bound_gt_max, 0, low_integer, high_integer,
                    symbolic_parameter.min_value_sets, symbolic_parameter.max_value_sets,
                    ignore_range_present);
              parameter.min_value_sets := low_integer;
              parameter.max_value_sets := high_integer;

              CASE parse.unit.kind OF
              = clc$lex_name =
                #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
                IF (name = 'RANGE') OR (name = 'OF') THEN
                  EXIT /optional_list_stuff/;
                IFEND;
              = clc$lex_comma =
                clp$scan_non_space_lexical_unit (parse);
                IF parse.unit.kind = clc$lex_name THEN
                  #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
                  IF name = 'RANGE' THEN
                    EXIT /optional_list_stuff/;
                  IFEND;
                  IF name = 'OF' THEN
                    osp$set_status_abnormal ('CL', cle$unexpected_of_after_comma, '', status);
                    EXIT clp$internal_generate_old_pdt;
                  IFEND;
                IFEND;
              ELSE
                IF NOT parse.previous_unit_is_space THEN
                  osp$set_status_abnormal ('CL', cle$unexpected_after_vsc_spec, '', status);
                  clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
                  EXIT clp$internal_generate_old_pdt;
                IFEND;
              CASEND;

              scan_integer_range (1, clc$max_values_per_set, cle$list_bound_out_of_range,
                    cle$min_list_bound_gt_max, 0, low_integer, high_integer,
                    symbolic_parameter.min_values_per_set, symbolic_parameter.max_values_per_set,
                    ignore_range_present);
              parameter.min_values_per_set := low_integer;
              parameter.max_values_per_set := high_integer;

              CASE parse.unit.kind OF
              = clc$lex_name =
                #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
                IF (name = 'RANGE') OR (name = 'OF') THEN
                  EXIT /optional_list_stuff/;
                IFEND;
              = clc$lex_comma =
                clp$scan_non_space_lexical_unit (parse);
                IF parse.unit.kind = clc$lex_name THEN
                  #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
                  IF name = 'RANGE' THEN
                    EXIT /optional_list_stuff/;
                  ELSEIF name = 'OF' THEN
                    osp$set_status_abnormal ('CL', cle$unexpected_of_after_comma, '', status);
                    EXIT clp$internal_generate_old_pdt;
                  ELSE
                    osp$set_status_abnormal ('CL', cle$unexpected_after_vc_spec, name, status);
                    EXIT clp$internal_generate_old_pdt;
                  IFEND;
                IFEND;
              ELSE
                ;
              CASEND;
              osp$set_status_abnormal ('CL', cle$unexpected_after_vc_spec, '', status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$internal_generate_old_pdt;
            END /optional_list_stuff/;

            IF name = 'RANGE' THEN
              parameter.value_range_allowed := clc$value_range_allowed;
              scan_value_range_spec;
            ELSE
              clp$scan_non_space_lexical_unit (parse);
              IF NOT parse.previous_unit_is_space THEN
                osp$set_status_abnormal ('CL', cle$unexpected_after_of, '', status);
                clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
                EXIT clp$internal_generate_old_pdt;
              IFEND;
            IFEND;

          PROCEND scan_value_list_spec;
?? TITLE := 'scan_value_range_spec', EJECT ??

          PROCEDURE scan_value_range_spec;

            VAR
              name: ost$name;


            clp$scan_non_space_lexical_unit (parse);
            IF NOT parse.previous_unit_is_space THEN
              osp$set_status_abnormal ('CL', cle$unexpected_after_range, '', status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            IF parse.unit.kind <> clc$lex_name THEN
              osp$set_status_abnormal ('CL', cle$unexpected_after_range, '', status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
            IF name <> 'OF' THEN
              osp$set_status_abnormal ('CL', cle$unexpected_after_range, name, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            clp$scan_non_space_lexical_unit (parse);
            IF NOT parse.previous_unit_is_space THEN
              osp$set_status_abnormal ('CL', cle$unexpected_after_of, '', status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;

          PROCEND scan_value_range_spec;
?? TITLE := 'scan_var_spec', EJECT ??

          PROCEDURE scan_var_spec
            (    var_or_array: ost$name_reference;
             VAR value_kind_specifier: clt$value_kind_specifier);

            VAR
              name: ost$name;


            clp$scan_non_space_lexical_unit (parse);
            IF NOT parse.previous_unit_is_space THEN
              osp$set_status_abnormal ('CL', cle$unexpected_after_var, '', status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            IF parse.unit.kind <> clc$lex_name THEN
              osp$set_status_abnormal ('CL', cle$unexpected_after_var, '', status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
            IF name <> 'OF' THEN
              osp$set_status_abnormal ('CL', cle$unexpected_after_var, '', status);
              osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            clp$scan_non_space_lexical_unit (parse);
            IF NOT parse.previous_unit_is_space THEN
              osp$set_status_abnormal ('CL', cle$unexpected_after_of, '', status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            IF parse.unit.kind <> clc$lex_name THEN
              osp$set_status_abnormal ('CL', cle$expecting_var_kind, '', status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
            IF name = 'ANY' THEN
              value_kind_specifier.variable_kind := clc$any_value;
            ELSEIF name = 'BOOLEAN' THEN
              value_kind_specifier.variable_kind := clc$boolean_value;
            ELSEIF name = 'INTEGER' THEN
              value_kind_specifier.variable_kind := clc$integer_value;
            ELSEIF name = 'REAL' THEN
              value_kind_specifier.variable_kind := clc$real_value;
            ELSEIF name = 'STATUS' THEN
              value_kind_specifier.variable_kind := clc$status_value;
            ELSEIF name = 'STRING' THEN
              value_kind_specifier.variable_kind := clc$string_value;
            ELSE
              osp$set_status_abnormal ('CL', cle$expecting_var_kind, name, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            clp$scan_non_space_lexical_unit (parse);

            scan_or_key;

          PROCEND scan_var_spec;
?? TITLE := 'scan_value_kind', EJECT ??

          PROCEDURE scan_value_kind
            (VAR value_kind_specifier {input, output} : clt$value_kind_specifier);

            VAR
              name: ost$name,
              low_integer: integer,
              high_integer: integer,
              range_present: boolean;

?? NEWTITLE := 'scan_value_kind_qualifier', EJECT ??

            PROCEDURE scan_value_kind_qualifier
              (    unexpected_after: ost$status_condition;
                   nominal_low: integer;
                   nominal_high: integer;
                   out_of_range: ost$status_condition;
                   low_greater_than_high: ost$status_condition;
                   high_omitted: ost$status_condition);


              clp$scan_non_space_lexical_unit (parse);
              low_integer := nominal_low;
              high_integer := nominal_high;
              range_present := FALSE;

              CASE parse.unit.kind OF
              = clc$lex_equal, clc$lex_semicolon, clc$lex_end_of_line, clc$lex_right_parenthesis =
                RETURN;
              = clc$lex_name =
                #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
                IF name = 'OR' THEN
                  RETURN;
                IFEND;
              ELSE
                IF NOT parse.previous_unit_is_space THEN
                  osp$set_status_abnormal ('CL', unexpected_after, '', status);
                  clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
                  EXIT clp$internal_generate_old_pdt;
                IFEND;
              CASEND;

              scan_integer_range (nominal_low, nominal_high, out_of_range, low_greater_than_high,
                    high_omitted, low_integer, high_integer, symbolic_parameter.value_kind_qualifier_low,
                    symbolic_parameter.value_kind_qualifier_high, range_present);

            PROCEND scan_value_kind_qualifier;
?? OLDTITLE, EJECT ??

            IF parse.unit.kind <> clc$lex_name THEN
              osp$set_status_abnormal ('CL', cle$expecting_value_kind, '', status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;

            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
            IF name = 'KEY' THEN
              value_kind_specifier.kind := clc$keyword_value;
              RETURN;

            ELSEIF name = 'ANY' THEN
              value_kind_specifier.kind := clc$any_value;
              clp$scan_non_space_lexical_unit (parse);

            ELSEIF name = 'BOOLEAN' THEN
              value_kind_specifier.kind := clc$boolean_value;
              clp$scan_non_space_lexical_unit (parse);

            ELSEIF name = 'INTEGER' THEN
              scan_value_kind_qualifier (cle$unexpected_after_integer, clc$min_integer, clc$max_integer,
                    cle$integer_out_of_range, cle$min_of_subrange_not_le_max, cle$max_of_subrange_omitted);
              value_kind_specifier.kind := clc$integer_value;
              value_kind_specifier.min_integer_value := low_integer;
              value_kind_specifier.max_integer_value := high_integer;

            ELSEIF name = 'FILE' THEN
              value_kind_specifier.kind := clc$file_value;
              clp$scan_non_space_lexical_unit (parse);

            ELSEIF name = 'NAME' THEN
              scan_value_kind_qualifier (cle$unexpected_after_integer, 1, osc$max_name_size,
                    cle$name_size_out_of_range, cle$min_name_size_gt_max, 0);
              value_kind_specifier.kind := clc$name_value;
              IF range_present THEN
                value_kind_specifier.min_name_size := low_integer;
              ELSE
                value_kind_specifier.min_name_size := 1;
              IFEND;
              value_kind_specifier.max_name_size := high_integer;

            ELSEIF name = 'REAL' THEN
              value_kind_specifier.kind := clc$real_value;
              clp$scan_non_space_lexical_unit (parse);

            ELSEIF name = 'STATUS' THEN
              value_kind_specifier.kind := clc$status_value;
              clp$scan_non_space_lexical_unit (parse);

            ELSEIF name = 'STRING' THEN
              scan_value_kind_qualifier (cle$unexpected_after_integer, 0, clc$max_string_size,
                    cle$string_size_out_of_range, cle$min_string_size_gt_max, 0);
              value_kind_specifier.kind := clc$string_value;
              IF low_integer >= osc$max_string_size THEN
                value_kind_specifier.min_string_size := osc$max_string_size;
              ELSE
                value_kind_specifier.min_string_size := low_integer;
              IFEND;
              IF high_integer >= osc$max_string_size THEN
                value_kind_specifier.max_string_size := osc$max_string_size;
              ELSE
                value_kind_specifier.max_string_size := high_integer;
              IFEND;

            ELSE
              value_kind_specifier.kind := clc$application_value;
              value_kind_specifier.value_name := name;
              value_kind_specifier.scanner.kind := clc$unspecified_av_scanner;
              clp$scan_non_space_lexical_unit (parse);
              CASE parse.unit.kind OF
              = clc$lex_end_of_line, clc$lex_equal, clc$lex_semicolon, clc$lex_right_parenthesis =
                RETURN;
              = clc$lex_name =
                #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
                IF name <> 'OR' THEN
                  value_kind_specifier.scanner.kind := clc$unlinked_av_scanner;
                  value_kind_specifier.scanner.name := name;
                  clp$scan_non_space_lexical_unit (parse);
                IFEND;
              ELSE
                osp$set_status_abnormal ('CL', cle$expecting_avs_name, '', status);
                clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
                EXIT clp$internal_generate_old_pdt;
              CASEND;
            IFEND;

            scan_or_key;

          PROCEND scan_value_kind;
?? TITLE := 'scan_integer_range', EJECT ??

          PROCEDURE scan_integer_range
            (    nominal_low: integer;
                 nominal_high: integer;
                 out_of_range: ost$status_condition;
                 low_greater_than_high: ost$status_condition;
                 high_omitted: ost$status_condition;
             VAR actual_low: integer;
             VAR actual_high: integer;
             VAR low_string: ^clt$expression_text;
             VAR high_string: ^clt$expression_text;
             VAR range_present: boolean);

?? NEWTITLE := 'save_subrange_expression', EJECT ??

            PROCEDURE [INLINE] save_subrange_expression
              (VAR text: ^clt$expression_text);

              VAR
                size: clt$expression_text_size,
                start_index: clt$expression_text_index;


              start_index := parse.unit_index;
              clp$scan_unnested_rel_lex_unit (parse);
              size := parse.previous_non_space_unit_index + parse.previous_non_space_unit.size - start_index;

              NEXT text: [size] IN extra_info_area_ptr;
              IF text = NIL THEN
                osp$set_status_abnormal ('CL', cle$table_overflow, 'Symbolic PDT Value', status);
                EXIT clp$internal_generate_old_pdt;
              IFEND;
              text^ := parse.text^ (start_index, size);

              IF parse.unit_is_space THEN
                clp$scan_non_space_lexical_unit (parse);
              IFEND;

            PROCEND save_subrange_expression;
?? OLDTITLE, EJECT ??

            VAR
              result_integer: clt$integer;


            actual_low := nominal_low;
            actual_high := nominal_high;
            range_present := FALSE;

            IF proc_or_pdt = 'PDT' THEN
              save_subrange_expression (low_string);
            ELSE
              clp$evaluate_integer_expression (nominal_low, nominal_high, work_area, parse, result_integer,
                    status);
              IF NOT status.normal THEN
                IF status.condition = cle$integer_out_of_range THEN
                  status.condition := out_of_range;
                IFEND;
                EXIT clp$internal_generate_old_pdt;
              IFEND;
              actual_low := result_integer.value;
            IFEND;

            IF parse.unit.kind <> clc$lex_ellipsis THEN
              IF high_omitted <> 0 THEN
                osp$set_status_abnormal ('CL', high_omitted, '', status);
                EXIT clp$internal_generate_old_pdt;
              IFEND;
              actual_high := actual_low;
              high_string := low_string;
              RETURN;
            IFEND;

            range_present := TRUE;
            clp$scan_non_space_lexical_unit (parse);

            IF proc_or_pdt = 'PDT' THEN
              save_subrange_expression (high_string);
            ELSE
              clp$evaluate_integer_expression (nominal_low, nominal_high, work_area, parse, result_integer,
                    status);
              IF NOT status.normal THEN
                IF status.condition = cle$integer_out_of_range THEN
                  status.condition := out_of_range;
                IFEND;
                EXIT clp$internal_generate_old_pdt;
              IFEND;
              actual_high := result_integer.value;
            IFEND;

            IF actual_low > actual_high THEN
              osp$set_status_abnormal ('CL', low_greater_than_high, '', status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;

          PROCEND scan_integer_range;
?? TITLE := 'scan_or_key', EJECT ??

          PROCEDURE scan_or_key;

            VAR
              name: ost$name;


            CASE parse.unit.kind OF
            = clc$lex_end_of_line, clc$lex_equal, clc$lex_semicolon, clc$lex_right_parenthesis =
              RETURN;
            ELSE
              ;
            CASEND;
            IF parse.unit.kind <> clc$lex_name THEN
              osp$set_status_abnormal ('CL', cle$unexpected_after_value_kind, '', status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
            IF name <> 'OR' THEN
              osp$set_status_abnormal ('CL', cle$unexpected_after_value_kind, name, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            clp$scan_non_space_lexical_unit (parse);
            IF NOT parse.previous_unit_is_space THEN
              osp$set_status_abnormal ('CL', cle$unexpected_after_of, '', status); {||?? OF ?}
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            IF parse.unit.kind <> clc$lex_name THEN
              osp$set_status_abnormal ('CL', cle$expecting_key_spec, '', status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
            IF name <> 'KEY' THEN
              osp$set_status_abnormal ('CL', cle$expecting_key_spec, name, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;

          PROCEND scan_or_key;
?? TITLE := 'scan_keyword_values', EJECT ??

          PROCEDURE scan_keyword_values
            (VAR keyword_values: ^array [1 .. * ] of ost$name);

            VAR
              i: 1 .. clc$max_keywords,
              count: 0 .. clc$max_keywords,
              name: ost$name;


            clp$scan_non_space_lexical_unit (parse);
            IF NOT parse.previous_unit_is_space THEN
              osp$set_status_abnormal ('CL', cle$unexpected_after_key, '', status);
              clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;

            NEXT keyword_values: [1 .. (#SIZE (extra_info_area_ptr^) -
                  i#current_sequence_position (extra_info_area_ptr)) DIV osc$max_name_size] IN
                  extra_info_area_ptr;
            IF keyword_values = NIL THEN
              osp$set_status_abnormal ('CL', cle$table_overflow, 'Keyword Values', status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            count := 0;

          /scan_keys/
            WHILE TRUE DO
              IF parse.unit.kind <> clc$lex_name THEN
                osp$set_status_abnormal ('CL', cle$expecting_key_in_spec, '', status);
                clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
                EXIT clp$internal_generate_old_pdt;
              IFEND;
              #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
              FOR i := 1 TO count DO
                IF name = keyword_values^ [i] THEN
                  osp$set_status_abnormal ('CL', cle$duplicate_keyword_value, name, status);
                  EXIT clp$internal_generate_old_pdt;
                IFEND;
              FOREND;
              count := count + 1;
              IF count > UPPERBOUND (keyword_values^) THEN
                osp$set_status_abnormal ('CL', cle$table_overflow, 'Keyword Values', status);
                EXIT clp$internal_generate_old_pdt;
              IFEND;
              keyword_values^ [count] := name;
              clp$scan_non_space_lexical_unit (parse);
              CASE parse.unit.kind OF
              = clc$lex_comma =
                clp$scan_non_space_lexical_unit (parse);
              = clc$lex_end_of_line, clc$lex_equal, clc$lex_semicolon, clc$lex_right_parenthesis =
                EXIT /scan_keys/;
              ELSE
                ;
              CASEND;
            WHILEND /scan_keys/;

            RESET extra_info_area_ptr TO keyword_values;
            NEXT keyword_values: [1 .. count] IN extra_info_area_ptr;

          PROCEND scan_keyword_values;
?? OLDTITLE, EJECT ??

          VAR
            list_or_range_specified: boolean,
            name: ost$name;


          list_or_range_specified := FALSE;
          IF parse.unit.kind = clc$lex_name THEN
            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
            IF name = 'LIST' THEN
              scan_value_list_spec;
              list_or_range_specified := TRUE;
            ELSEIF name = 'RANGE' THEN
              parameter.value_range_allowed := clc$value_range_allowed;
              scan_value_range_spec;
              list_or_range_specified := TRUE;
            IFEND;
          IFEND;

          IF parse.unit.kind = clc$lex_name THEN
            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
            IF (name = 'VAR') OR (name = 'ARRAY') THEN
              IF list_or_range_specified THEN
                osp$set_status_abnormal ('CL', cle$unsupported_parameter_spec, parameter_name^, status);
                EXIT clp$internal_generate_old_pdt;
              IFEND;
              parameter.value_kind_specifier.kind := clc$variable_reference;
              IF name = 'VAR' THEN
                parameter.value_kind_specifier.array_allowed := clc$array_not_allowed;
              ELSE
                parameter.value_kind_specifier.array_allowed := clc$array_allowed;
              IFEND;
              scan_var_spec (name, parameter.value_kind_specifier);
            ELSE
              scan_value_kind (parameter.value_kind_specifier);
            IFEND;
          ELSE
            scan_value_kind (parameter.value_kind_specifier);
          IFEND;

          IF parse.unit.kind = clc$lex_name THEN
            #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
            IF name = 'KEY' THEN
              IF parameter.value_kind_specifier.kind = clc$variable_reference THEN
                osp$set_status_abnormal ('CL', cle$unsupported_parameter_spec, parameter_name^, status);
                EXIT clp$internal_generate_old_pdt;
              IFEND;
              scan_keyword_values (parameter.value_kind_specifier.keyword_values);
            IFEND;
          IFEND;

        PROCEND scan_value_spec;
?? TITLE := 'scan_default_spec', EJECT ??

        PROCEDURE scan_default_spec
          (VAR required_or_optional: clt$required_or_optional);

          VAR
            default_index: clt$expression_text_index,
            name: ost$name;


        /scan_default/
          BEGIN
            clp$scan_non_space_lexical_unit (parse);
            IF parse.unit.kind = clc$lex_name THEN
              #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
              IF name = '$REQUIRED' THEN
                required_or_optional.selector := clc$required;
                clp$scan_non_space_lexical_unit (parse);
                EXIT /scan_default/;
              ELSEIF name = '$OPTIONAL' THEN
                required_or_optional.selector := clc$optional;
                clp$scan_non_space_lexical_unit (parse);
                EXIT /scan_default/;
              IFEND;
            IFEND;
            default_index := parse.unit_index;
            clp$scan_unnested_sep_lex_unit (clc$ignore_ellipsis, parse);
            required_or_optional.selector := clc$optional_with_default;
            NEXT required_or_optional.default: [parse.unit_index - default_index] IN extra_info_area_ptr;
            IF required_or_optional.default = NIL THEN
              osp$set_status_abnormal ('CL', cle$table_overflow, 'Default Value', status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            required_or_optional.default^ := parse.text^ (default_index, parse.unit_index - default_index);
          END /scan_default/;
          IF parse.unit_is_space THEN
            clp$scan_non_space_lexical_unit (parse);
          IFEND;

        PROCEND scan_default_spec;
?? OLDTITLE, EJECT ??

        VAR
          parameter_area_ptr: ^SEQ ( * ),
          parameter_count: 0 .. clc$max_parameters,
          symbolic_parameter_area_ptr: ^SEQ ( * );


        CASE parse.unit.kind OF
        = clc$lex_right_parenthesis, clc$lex_semicolon, clc$lex_end_of_line =
          RETURN;
        = clc$lex_name =
          parameter_area_ptr := ^parameter_area;
          symbolic_parameter_area_ptr := ^symbolic_parameter_area;
          IF pdt.parameters = NIL THEN
            parameter_count := 0;
          ELSE
            parameter_count := UPPERBOUND (pdt.parameters^);
          IFEND;
        ELSE
          osp$set_status_abnormal ('CL', cle$expecting_param_def, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT clp$internal_generate_old_pdt;
        CASEND;

        parameter_count := parameter_count + 1;
        RESET parameter_area_ptr;
        NEXT pdt.parameters: [1 .. parameter_count] IN parameter_area_ptr;
        RESET symbolic_parameter_area_ptr;
        NEXT symbolic_parameters: [1 .. parameter_count] IN symbolic_parameter_area_ptr;
        IF (pdt.parameters = NIL) OR (symbolic_parameters = NIL) THEN
          osp$set_status_abnormal ('CL', cle$too_many_parameter_defs, '', status);
          EXIT clp$internal_generate_old_pdt;
        IFEND;
        symbolic_parameters^ [parameter_count].min_value_sets := NIL;
        symbolic_parameters^ [parameter_count].max_value_sets := NIL;
        symbolic_parameters^ [parameter_count].min_values_per_set := NIL;
        symbolic_parameters^ [parameter_count].max_values_per_set := NIL;
        symbolic_parameters^ [parameter_count].value_kind_qualifier_low := NIL;
        symbolic_parameters^ [parameter_count].value_kind_qualifier_high := NIL;

        scan_parameter_names (parameter_count, pdt.names);

        pdt.parameters^ [parameter_count].required_or_optional.selector := clc$optional;
        pdt.parameters^ [parameter_count].min_value_sets := 1;
        pdt.parameters^ [parameter_count].max_value_sets := 1;
        pdt.parameters^ [parameter_count].min_values_per_set := 1;
        pdt.parameters^ [parameter_count].max_values_per_set := 1;
        pdt.parameters^ [parameter_count].value_range_allowed := clc$value_range_not_allowed;
        pdt.parameters^ [parameter_count].value_kind_specifier.keyword_values := NIL;
        IF parameter_name_is_status THEN
          pdt.parameters^ [parameter_count].value_kind_specifier.kind := clc$variable_reference;
          pdt.parameters^ [parameter_count].value_kind_specifier.array_allowed := clc$array_not_allowed;
          pdt.parameters^ [parameter_count].value_kind_specifier.variable_kind := clc$status_value;
        ELSE
          pdt.parameters^ [parameter_count].value_kind_specifier.kind := clc$file_value;
        IFEND;

        IF parse.unit.kind = clc$lex_colon THEN
          clp$scan_non_space_lexical_unit (parse);
          scan_value_spec (pdt.parameters^ [parameter_count], symbolic_parameters^ [parameter_count]);
        IFEND;

        IF parse.unit.kind = clc$lex_equal THEN
          scan_default_spec (pdt.parameters^ [parameter_count].required_or_optional);
        IFEND;

      PROCEND scan_parameter_definition;
?? OLDTITLE, EJECT ??

      VAR
        end_of_input: boolean;


      extra_info_area_ptr := ^extra_info_area;
      RESET extra_info_area_ptr;
      clp$scan_non_space_lexical_unit (parse);
      WHILE TRUE DO
        scan_parameter_definition;
        CASE parse.unit.kind OF
        = clc$lex_right_parenthesis =
          clp$scan_non_space_lexical_unit (parse);
          RETURN;
        = clc$lex_semicolon =
          clp$scan_non_space_lexical_unit (parse);
        = clc$lex_end_of_line =
          REPEAT
            get_line^ (parse, end_of_input, status);
            IF NOT status.normal THEN
              EXIT clp$internal_generate_old_pdt;
            ELSEIF end_of_input THEN
              osp$set_status_abnormal ('CL', cle$expecting_param_def, 'END OF INPUT', status);
              EXIT clp$internal_generate_old_pdt;
            IFEND;
            clp$scan_non_space_lexical_unit (parse);
          UNTIL parse.unit.kind <> clc$lex_end_of_line;
        ELSE
          osp$set_status_abnormal ('CL', cle$expecting_param_def_sep, '', status);
          clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
          EXIT clp$internal_generate_old_pdt;
        CASEND;
      WHILEND;

    PROCEND scan_parameter_definitions;
?? OLDTITLE, EJECT ??

    VAR
      name: ost$name;


    status.normal := TRUE;

    proc_names := NIL;
    pdt.names := NIL;
    pdt.parameters := NIL;
    symbolic_parameters := NIL;

    IF parse.unit_is_space THEN
      clp$scan_non_space_lexical_unit (parse);
    IFEND;
    IF parse.unit.kind <> clc$lex_name THEN
      osp$set_status_abnormal ('CL', cle$expecting_proc, proc_or_pdt, status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      RETURN;
    IFEND;
    #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
    IF name <> proc_or_pdt THEN
      osp$set_status_abnormal ('CL', cle$expecting_proc, proc_or_pdt, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
      RETURN;
    IFEND;

    clp$scan_non_space_lexical_unit (parse);
    IF NOT parse.previous_unit_is_space THEN
      osp$set_status_abnormal ('CL', cle$unexpected_after_proc, proc_or_pdt, status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      RETURN;
    IFEND;

    scan_proc_names;
    IF (proc_or_pdt = 'PDT') AND (UPPERBOUND (proc_names^) > 1) THEN
      osp$set_status_abnormal ('CL', cle$too_many_names_for_pdt, '', status);
      RETURN;
    IFEND;

    IF parse.unit.kind = clc$lex_left_parenthesis THEN
      scan_parameter_definitions;
    IFEND;

    IF (parse.unit.kind <> clc$lex_semicolon) AND (parse.unit.kind <> clc$lex_end_of_line) THEN
      osp$set_status_abnormal ('CL', cle$expecting_command_separator, '', status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
    IFEND;

  PROCEND clp$internal_generate_old_pdt;

MODEND clm$scan_proc_pdt_declaration;
*DECK DECK=CLM$SCAN_TOKEN EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Token Scanner' ??
MODULE clm$scan_token;

{
{ PURPOSE:
{   This module contains routines  used to perform lexical
{   analysis on SCL input text.
{
{ DESIGN:
{   The design is essentially "ad hoc" in that the definition of the lexical
{   structure of SCL is imbedded in executable code as well as in the tables
{   that are used.  The detailed design of the code is oriented to making
{   extensive use of those CYBER 180 BDP instructions externalized in CYBIL
{   as intrinsics.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_command_processing
*copyc cle$ecc_lexical
*copyc cle$ecc_miscellaneous
*copyc clt$character_class
*copyc clt$command_line
*copyc clt$command_line_index
*copyc clt$token
*copyc oss$job_paged_literal
?? POP ??
*copyc clp$skip_spaces_and_comments
*copyc clv$comment_delimiter
*copyc clv$isolate_balanced_text
*copyc clv$non_alphanumeric
*copyc clv$non_decimal_digit
*copyc clv$non_space
*copyc clv$string_delimiter
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc pmp$continue_to_cause
?? TITLE := 'clv$character_class', EJECT ??

  VAR
    clv$character_class: [XDCL, #GATE, READ, oss$job_paged_literal] array [char] of clt$character_class := [
          {---} REP 9 of clc$other_character,
          {HT } clc$space_character,
          {---} REP 22 of clc$other_character,
          {- -} clc$space_character,
          { ! } clc$other_character,
          { " } clc$comment_delimiter_character,
          { # } clc$alpha_character,
          { $ } clc$alpha_character,
          { % } clc$other_character,
          { & } clc$other_character,
          { ' } clc$string_delimiter_character,
          { ( } clc$token_character,
          { ) } clc$token_character,
          { * } clc$digraph_token_character,
          { + } clc$token_character,
          { , } clc$token_character,
          { - } clc$token_character,
          { . } clc$digraph_token_character,
          { / } clc$digraph_token_character,
          {0..9} REP 10 of clc$digit_character,
          { : } clc$token_character,
          { ; } clc$token_character,
          { < } clc$digraph_token_character,
          { = } clc$token_character,
          { > } clc$digraph_token_character,
          { ? } clc$token_character,
          { @ } clc$alpha_character,
          {A..Z} REP 26 of clc$alpha_character,
          { [ } clc$alpha_character,
          { \ } clc$alpha_character,
          { ] } clc$alpha_character,
          { ^ } clc$alpha_character,
          { _ } clc$alpha_character,
          { ` } clc$alpha_character,
          {a..z} REP 26 of clc$alpha_character,
          { { } clc$alpha_character,
          { | } clc$alpha_character,
          { } clc$alpha_character,
          { ~ } clc$alpha_character,
          {---} REP 129 of clc$other_character];

?? TITLE := 'clv$isolate_command', EJECT ??

  VAR
    clv$isolate_command: [STATIC, READ, oss$job_paged_literal] packed array [char] of boolean := [
          {---} REP 34 of FALSE,
          { " } TRUE,
          {---} REP 4 of FALSE,
          { ' } TRUE,
          { ( } TRUE,
          { ) } TRUE,
          {---} REP 17 of FALSE,
          { ; } TRUE,
          {---} REP 196 of FALSE];

?? TITLE := 'clv$non_hex_digit', EJECT ??

  VAR
    clv$non_hex_digit: [XDCL, #GATE, READ, oss$job_paged_literal] packed array [char] of boolean := [
          {---} REP 48 of TRUE,
          {0..9} REP 10 of FALSE,
          {---} REP 7 of TRUE,
          {A..F} REP 6 of FALSE,
          {---} REP 26 of TRUE,
          {a..f} REP 6 of FALSE,
          {---} REP 153 of TRUE];

?? TITLE := 'clp$scan_token', EJECT ??
*copy clh$scan_token

  PROCEDURE [XDCL, #GATE] clp$scan_token ALIAS 'clpstok'
    (    text: string ( * );
     VAR index {input, output} : ost$string_index;
     VAR token: clt$token;
     VAR status: ost$status);

    VAR
      single_character_tokens: [STATIC, READ, oss$job_paged_literal] array ['(' .. '}'] of
            clt$lexical_kinds := [
            { ( } clc$lparen_token,
            { ) } clc$rparen_token,
            { * } clc$mult_token,
            { + } clc$add_token,
            { , } clc$comma_token,
            { - } clc$sub_token,
            { . } clc$dot_token,
            { / } clc$div_token,
            {0..9} REP 10 of * ,
            { : } clc$colon_token,
            { ; } clc$semicolon_token,
            { < } clc$lt_token,
            { = } clc$eq_token,
            { > } clc$gt_token,
            { ? } clc$query_token,
            { @ } * ,
            {A..Z} REP 26 of * ,
            { [ } clc$lbracket_token,
            { \ } clc$rslant_token,
            { ] } clc$rbracket_token,
            { ^ } clc$uparrow_token,
            { _ } * ,
            { ` } * ,
            {a..z} REP 26 of * ,
            { { } clc$lbrace_token,
            { | } * ,
            { } clc$rbrace_token];

    VAR
      digraph_tokens: [STATIC, READ, oss$job_paged_literal] array [0 .. 5] of record
        digraph: string (2),
        token: clt$lexical_kinds,
      recend := [['**', clc$exp_token], ['..', clc$ellipsis_token], ['//', clc$cat_token],
            ['<=', clc$le_token], ['<>', clc$ne_token], ['>=', clc$ge_token]];

    VAR
      spaces_before_not_part_of_token: [STATIC, READ, oss$job_paged_literal] set of clt$lexical_kinds :=
            [clc$unknown_token, clc$dot_token, clc$colon_token, clc$lparen_token, clc$lbracket_token,
            clc$lbrace_token, clc$uparrow_token, clc$query_token, clc$add_token, clc$sub_token,
            clc$string_token, clc$name_token, clc$integer_token, clc$real_token];

    VAR
      spaces_after_not_part_of_token: [STATIC, READ, oss$job_paged_literal] set of clt$lexical_kinds :=
            [clc$unknown_token, clc$dot_token, clc$colon_token, clc$rparen_token, clc$rbracket_token,
            clc$rbrace_token, clc$uparrow_token, clc$string_token, clc$name_token, clc$integer_token,
            clc$real_token];

    VAR
      control_characters: [STATIC, READ, oss$job_paged_literal] array [$CHAR (0) .. $CHAR (20(16))] of
            string (3) := ['NUL', 'SOH', 'STX', 'ETX', 'EOT', 'ENQ', 'ACK', 'BEL', 'BS', 'HT', 'LF', 'VT',
            'FF', 'CR', 'SO', 'SI', 'DLE', 'DC1', 'DC2', 'DC3', 'DC4', 'NAK', 'SYN', 'ETB', 'CAN', 'EM',
            'SUB', 'ESC', 'FS', 'GS', 'RS', 'US', 'SP'];

    VAR
      hex_digits: [STATIC, READ, oss$job_paged_literal] array [0 .. 15] of char := ['0', '1', '2', '3', '4',
            '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'];

    VAR
      scan_found_char: boolean,
      scan_index: integer;

    VAR
      end_token_index: ost$string_index,
      found_leading_spaces: boolean,
      found_trailing_spaces: boolean,
      ignore_spaces: boolean,
      token_index: ost$string_index;

    VAR
      digraph_index: 0 .. 5;

    VAR
      end_integer_index: ost$string_index,
      end_radix_index: ost$string_index,
      hex_digit_present: boolean,
      lparen_follows: boolean,
      radix: integer,
      radix_index: ost$string_index;

    VAR
      end_fraction_index: ost$string_index,
      exponent: integer,
      exponent_index: ost$string_index,
      exponent_sign: -1 .. 1;

    VAR
      string_index: ost$string_index,
      string_part_size: ost$string_size;

    VAR
      local_status: ost$status;

    VAR
      translate_name_kludge: ^string ( * <= osc$max_name_size);


    IF STRLENGTH (text) > osc$max_string_size THEN
      osp$set_status_abnormal ('CL', cle$line_too_long, '', status);
      RETURN;
    IFEND;

  /scan/
    BEGIN

      status.normal := TRUE;
      local_status.normal := TRUE;
      token.text_index := index;
      clp$skip_spaces_and_comments (text, index, token_index, found_leading_spaces);
      IF token_index > STRLENGTH (text) THEN
        token.descriptor := 'END OF LINE';
        token.kind := clc$eol_token;
        token.str.size := 0;
        token.str.value := '';
        index := token_index;
        token.text_size := index - token.text_index;
        EXIT /scan/;
      IFEND;

    /scan_the_token/
      BEGIN
        CASE clv$character_class [text (token_index)] OF

        = clc$other_character =

          CASE text (token_index) OF
          = $CHAR (0) .. $CHAR (20(16)) =
            token.descriptor := 'CHARACTER';
            token.descriptor (11, 3) := control_characters [text (token_index)];
          = $CHAR (21(16)) .. $CHAR (7e(16)) =
            token.descriptor := ''' ''';
            token.descriptor (2) := text (token_index);
          = $CHAR (7f(16)) =
            token.descriptor := 'CHARACTER DEL';
          = $CHAR (80(16)) .. $CHAR (0ff(16)) =
            token.descriptor := 'CHARACTER 0xx(16)';
            token.descriptor (12) := hex_digits [$INTEGER (text (token_index)) DIV 16];
            token.descriptor (13) := hex_digits [$INTEGER (text (token_index)) MOD 16];
          CASEND;
          token.kind := clc$unknown_token;
          token.str.size := 1;
          token.str.value := text (token_index, 1);
          end_token_index := token_index + 1;

        = clc$token_character =

          token.descriptor := ''' ''';
          token.descriptor (2) := text (token_index);
          token.kind := single_character_tokens [text (token_index)];
          token.str.size := 1;
          token.str.value := text (token_index, 1);
          end_token_index := token_index + 1;

        = clc$digraph_token_character =

          token.descriptor := ''' ''';
          token.descriptor (2) := text (token_index);
          token.kind := single_character_tokens [text (token_index)];
          token.str.size := 1;
          token.str.value := text (token_index, 1);
          end_token_index := token_index + 1;
          IF end_token_index <= STRLENGTH (text) THEN

          /check_digraph/
            FOR digraph_index := LOWERBOUND (digraph_tokens) TO UPPERBOUND (digraph_tokens) DO
              IF text (token_index, 2) = digraph_tokens [digraph_index].digraph THEN
                token.descriptor (3) := text (end_token_index);
                token.descriptor (4) := '''';
                token.kind := digraph_tokens [digraph_index].token;
                token.str.size := 2;
                token.str.value (2) := text (end_token_index);
                end_token_index := end_token_index + 1;
                IF token.kind = clc$ellipsis_token THEN
                  WHILE (end_token_index <= STRLENGTH (text)) AND (text (end_token_index) = '.') DO
                    end_token_index := end_token_index + 1;
                  WHILEND;
                IFEND;
                EXIT /check_digraph/;
              IFEND;
            FOREND /check_digraph/;
          IFEND;

        = clc$digit_character =

          IF found_leading_spaces THEN
            token.kind := clc$integer_token;
            EXIT /scan_the_token/;
          IFEND;
          #SCAN (clv$non_hex_digit, text (token_index, * ), scan_index, scan_found_char);
          end_integer_index := scan_index + token_index - 1;
          IF scan_found_char AND (clv$character_class [text (end_integer_index)] = clc$alpha_character) THEN
            osp$set_status_abnormal ('CL', cle$alpha_char_in_number,
                  text (token_index, end_integer_index - token_index + 1), local_status);
            EXIT /scan_the_token/;
          IFEND;
          lparen_follows := scan_found_char AND (text (end_integer_index) = '(');
          #SCAN (clv$non_decimal_digit, text (token_index, end_integer_index - token_index), scan_index,
                hex_digit_present);
          IF hex_digit_present AND (NOT lparen_follows) THEN
            osp$set_status_abnormal ('CL', cle$missing_radix,
                  text (token_index, end_integer_index - token_index), local_status);
            EXIT /scan_the_token/;
          IFEND;

          IF (end_integer_index <= STRLENGTH (text)) AND (text (end_integer_index) = '.') THEN

          /scan_real/
            BEGIN

              token.descriptor := 'REAL NUMBER';
              token.kind := clc$real_token;
              #SCAN (clv$non_decimal_digit, text (end_integer_index + 1, * ), scan_index, scan_found_char);
              IF scan_index <= 1 THEN
                EXIT /scan_real/;
              IFEND;
              end_fraction_index := scan_index + end_integer_index;
              exponent := 0;
              end_token_index := end_fraction_index;
              IF scan_found_char AND (clv$character_class [text (end_fraction_index)] =
                    clc$alpha_character) THEN
                IF (text (end_fraction_index) <> 'E') AND (text (end_fraction_index) <> 'e') THEN
                  osp$set_status_abnormal ('CL', cle$alpha_char_in_fraction,
                        text (token_index, end_fraction_index - token_index + 1), local_status);
                  EXIT /scan_the_token/;
                IFEND;
                exponent_index := end_fraction_index + 1;
                exponent_sign := 1;
                IF exponent_index <= STRLENGTH (text) THEN
                  IF text (exponent_index) = '-' THEN
                    exponent_sign := -1;
                    exponent_index := exponent_index + 1;
                  ELSE
                    exponent_index := exponent_index + $INTEGER (text (exponent_index) = '+');
                  IFEND;
                IFEND;
                #SCAN (clv$non_decimal_digit, text (exponent_index, * ), scan_index, scan_found_char);
                end_token_index := scan_index + exponent_index - 1;
                IF end_token_index <= exponent_index THEN
                  osp$set_status_abnormal ('CL', cle$missing_exponent,
                        text (token_index, end_token_index - token_index + 1), local_status);
                  EXIT /scan_the_token/;
                ELSEIF scan_found_char AND (clv$character_class [text (end_token_index)] =
                      clc$alpha_character) THEN
                  osp$set_status_abnormal ('CL', cle$alpha_char_in_exponent,
                        text (token_index, end_token_index - token_index + 1), local_status);
                  EXIT /scan_the_token/;
                IFEND;
                convert_to_integer (text (exponent_index, end_token_index - exponent_index), 10, exponent,
                      local_status);
                IF NOT local_status.normal THEN
                  osp$set_status_abnormal ('CL', cle$exponent_too_large,
                        text (token_index, end_token_index - token_index), local_status);
                  EXIT /scan_the_token/;
                IFEND;
                exponent := exponent_sign * exponent;
              IFEND;

              osp$set_status_abnormal ('CL', cle$not_yet_implemented, 'Reals', local_status);
              EXIT /scan_the_token/;

            END /scan_real/;
          IFEND;

          token.descriptor := 'INTEGER';
          token.kind := clc$integer_token;
          token.int.radix := 10;
          token.int.radix_specified := lparen_follows;
          end_token_index := end_integer_index;
          IF lparen_follows THEN
            clp$skip_spaces_and_comments (text, end_integer_index + 1, radix_index, ignore_spaces);
            #SCAN (clv$non_decimal_digit, text (radix_index, * ), scan_index, scan_found_char);
            end_radix_index := scan_index + radix_index - 1;
            clp$skip_spaces_and_comments (text, end_radix_index, end_token_index, ignore_spaces);
            IF NOT ((end_token_index <= STRLENGTH (text)) AND (text (end_token_index) = ')')) THEN
              osp$set_status_abnormal ('CL', cle$improper_radix_spec,
                    text (token_index, end_token_index - token_index), local_status);
              EXIT /scan_the_token/;
            IFEND;
            end_token_index := end_token_index + 1;
            convert_to_integer (text (radix_index, end_radix_index - radix_index), 10, radix, local_status);
            IF local_status.normal AND (2 <= radix) AND (radix <= 16) THEN
              token.int.radix := radix;
            ELSE
              osp$set_status_abnormal ('CL', cle$improper_radix_value,
                    text (token_index, end_token_index - token_index), local_status);
              EXIT /scan_the_token/;
            IFEND;
          IFEND;
          convert_to_integer (text (token_index, end_integer_index - token_index), token.int.radix,
                token.int.value, local_status);

        = clc$alpha_character =

          token.kind := clc$name_token;
          IF found_leading_spaces THEN
            EXIT /scan_the_token/;
          IFEND;
          token.descriptor := 'NAME';
          #SCAN (clv$non_alphanumeric, text (token_index, * ), scan_index, scan_found_char);
          end_token_index := scan_index + token_index - 1;
          IF (end_token_index - token_index) > osc$max_name_size THEN
            osp$set_status_abnormal ('CL', cle$name_too_long,
                  text (token_index, end_token_index - token_index), local_status);
            EXIT /scan_the_token/;
          IFEND;
          token.name.size := end_token_index - token_index;
          translate_name_kludge := ^text (token_index, token.name.size);
          #TRANSLATE (osv$lower_to_upper, translate_name_kludge^, token.name.value);

        = clc$string_delimiter_character =

          token.kind := clc$string_token;
          IF found_leading_spaces THEN
            EXIT /scan_the_token/;
          IFEND;
          token.descriptor := 'STRING';
          token.str.size := 0;
          string_index := token_index + 1;

        /scan_string/
          WHILE TRUE DO
            #SCAN (clv$string_delimiter, text (string_index, * ), scan_index, scan_found_char);
            end_token_index := scan_index + string_index - 1;
            IF NOT scan_found_char THEN
              osp$set_status_abnormal ('CL', cle$missing_string_delimiter,
                    text (token_index, end_token_index - token_index), local_status);
              EXIT /scan_the_token/;
            IFEND;
            string_part_size := scan_index - 1;
            IF string_part_size > 0 THEN
              token.str.value (token.str.size + 1, string_part_size) := text (string_index, string_part_size);
            IFEND;
            token.str.size := token.str.size + string_part_size;
            end_token_index := end_token_index + 1;
            IF NOT ((end_token_index <= STRLENGTH (text)) AND (text (end_token_index) = '''')) THEN
              EXIT /scan_string/;
            IFEND;
            token.str.size := token.str.size + 1;
            token.str.value (token.str.size) := '''';
            string_index := end_token_index + 1;
          WHILEND /scan_string/;

        CASEND;
      END /scan_the_token/;

      IF found_leading_spaces AND (token.kind IN spaces_before_not_part_of_token) THEN
        token.descriptor := 'SPACE';
        token.kind := clc$space_token;
        token.str.size := 1;
        token.str.value := '';
        index := token_index;
        token.text_size := index - token.text_index;
        status.normal := TRUE;
        EXIT /scan/;
      IFEND;
      IF NOT local_status.normal THEN
        status := local_status;
        EXIT /scan/;
      IFEND;
      IF token.kind IN spaces_after_not_part_of_token THEN
        index := end_token_index;
      ELSE
        clp$skip_spaces_and_comments (text, end_token_index, index, found_trailing_spaces);
      IFEND;
      token.text_size := index - token.text_index;

    END /scan/;

  PROCEND clp$scan_token;
?? TITLE := 'convert_to_integer', EJECT ??
{
{ PURPOSE:
{   This procedure converts the string representation of an integer to the
{   corresponding integer value.
{

  PROCEDURE convert_to_integer
    (    text: string ( * );
         radix: 2 .. 16;
     VAR result: integer;
     VAR status: ost$status);

    VAR
      digit: 0 .. 15,
      i: ost$string_index;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           ignore_cond_desc: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF (condition.selector = pmc$system_conditions) AND (pmc$arithmetic_overflow IN
            condition.system_conditions) THEN
        osp$set_status_abnormal ('CL', cle$integer_too_large, text, status);
        EXIT convert_to_integer;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);

    result := 0;
    FOR i := 1 TO STRLENGTH (text) DO
      CASE text (i) OF
      = '0' .. '9' =
        digit := $INTEGER (text (i)) - $INTEGER ('0');
      = 'A' .. 'F' =
        digit := $INTEGER (text (i)) - $INTEGER ('A') + 10;
      = 'a' .. 'f' =
        digit := $INTEGER (text (i)) - $INTEGER ('a') + 10;
      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_digit, text, status);
        RETURN;
      CASEND;
      IF digit >= radix THEN
        osp$set_status_abnormal ('CL', cle$digit_too_large, text, status);
        RETURN;
      IFEND;
      result := (result * radix) + digit;
    FOREND;

  PROCEND convert_to_integer;
?? TITLE := 'clp$isolate_command', EJECT ??
*copyc clh$isolate_command

  PROCEDURE [XDCL, #GATE] clp$isolate_command
    (    text: clt$command_line;
         start_index: clt$command_line_index;
     VAR end_index: clt$command_line_index);

    VAR
      found_char: boolean,
      nesting_level: integer,
      scan_index: integer,
      text_index: clt$command_line_index;


    text_index := start_index;
    nesting_level := 0;
    found_char := TRUE;

  /scan_loop/
    WHILE found_char AND (text_index <= STRLENGTH (text)) DO
      #SCAN (clv$isolate_command, text (text_index, * ), scan_index, found_char);
      text_index := scan_index + text_index - 1;
      IF found_char THEN
        CASE text (text_index) OF
        = '"' =
          #SCAN (clv$comment_delimiter, text (text_index + 1, * ), scan_index, found_char);
          text_index := scan_index + text_index + $INTEGER (found_char);
        = '''' =
          #SCAN (clv$string_delimiter, text (text_index + 1, * ), scan_index, found_char);
          text_index := scan_index + text_index + $INTEGER (found_char);
        = '(' =
          nesting_level := nesting_level + 1;
          text_index := text_index + 1;
        = ')' =
          nesting_level := nesting_level - 1;
          text_index := text_index + 1;
        = ';' =
          IF nesting_level <= 0 THEN
            EXIT /scan_loop/;
          IFEND;
          text_index := text_index + 1;
        ELSE
          text_index := text_index + 1;
        CASEND;
      IFEND;
    WHILEND /scan_loop/;

    end_index := text_index;

  PROCEND clp$isolate_command;

MODEND clm$scan_token;
*DECK DECK=CLM$SCL_OPTIONS_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Change SCL Options Command' ??
MODULE clm$scl_options_command;

{
{ PURPOSE:
{   This module contains the processor for the change_scl_options command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$not_yet_implemented
*copyc clt$data_value
*copyc clt$parameter_list
*copyc clt$work_area
*copyc ost$status
?? POP ??
*copyc clp$build_standard_title
*copyc clp$change_scl_options
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$convert_data_to_string
*copyc clp$evaluate_parameters
*copyc clp$find_current_block
*copyc clp$find_scl_options
*copyc clp$get_work_area
*copyc clp$make_boolean_value
*copyc clp$make_keyword_value
*copyc clp$make_record_value
*copyc clp$make_value
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_data_representation
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc osp$change_translation_tables
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? TITLE := 'clp$change_scl_options_command', EJECT ??

  PROCEDURE [XDCL] clp$_change_scl_options
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{******************************************************************************
{
{ NOTE: If the following PDT is regenerated, the initialization for the first
{ parameter (prompt_for_parameter_correction) must be manually changed to
{ allow that parameter to be given positionally.  This parameter is considered
{ obsolete and therefore has the HIDDEN attribute, and HIDDEN implies BY_NAME.
{ However, for compatibility reasons this parameter should NOT have the
{ BY_NAME attribute.
{ To make this change after the PDT has been regenerated replace the line
{
{     $clt$parameter_spec_methods[clc$specify_by_name],
{
{ with the line
{
{     $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
{
{ in the initialization for the descriptor of PARAMETER 1.
{
{******************************************************************************

{ PROCEDURE (osm$chaso) change_scl_options, change_scl_option, chasclo, chaso (
{   prompt_for_parameter_correction, pfpc: (BY_NAME, HIDDEN) boolean = $optional
{   line_style_correction_prompts, lscp: (BY_NAME) key
{       (line, l)
{       (screen, s)
{       none
{     keyend = $optional
{   screen_style_correction_prompts, sscp: (BY_NAME) key
{       (screen, s)
{       none
{     keyend = $optional
{   name_folding_level, nfl: (BY_NAME) key
{       (standard_folding, sf)
{       (full_folding, ff)
{     keyend = $optional
{   wild_card_pattern_type, wcpt: (BY_NAME) key
{       (basic, b)
{       (extended, e)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 11, 15, 26, 49, 587],
    clc$command, 11, 6, 0, 0, 1, 0, 6, 'OSM$CHASO'], [
    ['LINE_STYLE_CORRECTION_PROMPTS  ',clc$nominal_entry, 2],
    ['LSCP                           ',clc$abbreviation_entry, 2],
    ['NAME_FOLDING_LEVEL             ',clc$nominal_entry, 4],
    ['NFL                            ',clc$abbreviation_entry, 4],
    ['PFPC                           ',clc$abbreviation_entry, 1],
    ['PROMPT_FOR_PARAMETER_CORRECTION',clc$nominal_entry, 1],
    ['SCREEN_STYLE_CORRECTION_PROMPTS',clc$nominal_entry, 3],
    ['SSCP                           ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 6],
    ['WCPT                           ',clc$abbreviation_entry, 5],
    ['WILD_CARD_PATTERN_TYPE         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [6, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [5], [
    ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['LINE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SCREEN                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [3], [
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SCREEN                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [4], [
    ['FF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FULL_FOLDING                   ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['SF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['STANDARD_FOLDING               ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BASIC                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXTENDED                       ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$prompt_for_parameter_correcti = 1 {PROMPT_FOR_PARAMETER_CORRECTION} ,
      p$line_style_correction_prompts = 2,
      p$screen_style_correction_promp = 3 {SCREEN_STYLE_CORRECTION_PROMPTS} ,
      p$name_folding_level = 4,
      p$wild_card_pattern_type = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      block: ^clt$block,
      old_options: ^ clt$scl_options,
      options: clt$scl_options;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$find_scl_options (old_options);
    options := old_options^;

{ The parameters line_style_correction_prompts and screen_style_correction_prompts
{ logically replace the parameter prompt_for_parameter_correction, so if either of
{ the former is specified, the latter is ignored.

    IF pvt [p$line_style_correction_prompts].specified OR
          pvt [p$screen_style_correction_promp].specified THEN

      IF pvt [p$line_style_correction_prompts].specified THEN
        IF pvt [p$line_style_correction_prompts].value^.keyword_value = 'NONE' THEN
          options.line_style_correction_prompts.selected := FALSE;
        ELSE
          options.line_style_correction_prompts.selected := TRUE;
          IF pvt [p$line_style_correction_prompts].value^.keyword_value = 'LINE' THEN
            options.line_style_correction_prompts.prompting_style := osc$line_interaction;
          ELSE
            options.line_style_correction_prompts.prompting_style := osc$screen_interaction;
          IFEND;
        IFEND;
      IFEND;

      IF pvt [p$screen_style_correction_promp].specified THEN
        options.screen_style_correction_prompts.selected :=
              pvt [p$screen_style_correction_promp].value^.keyword_value = 'SCREEN';
      IFEND;

    ELSEIF pvt [p$prompt_for_parameter_correcti].specified THEN

      IF pvt [p$prompt_for_parameter_correcti].value^.boolean_value.value THEN
        options.line_style_correction_prompts.selected := TRUE;
        options.line_style_correction_prompts.prompting_style := osc$line_interaction;
        options.screen_style_correction_prompts.selected := TRUE;
      ELSE
        options.line_style_correction_prompts.selected := FALSE;
        options.screen_style_correction_prompts.selected := FALSE;
      IFEND;
    IFEND;

    IF pvt [p$name_folding_level].specified THEN
      IF pvt [p$name_folding_level].value^.keyword_value = 'FULL_FOLDING' THEN
        options.name_folding_level := clc$full_folding;
      ELSE {STANDARD_FOLDING}
        options.name_folding_level := clc$standard_folding;
      IFEND;
      IF options.name_folding_level <> old_options^.name_folding_level THEN

{ The following code ensures that if the NAME_FOLDING_LEVEL is being changed
{ that the change is being made to the job level instance of the SCL_OPTIONS
{ environment object.
{
{ This restriction is currently necessary because changing this option requires
{ changing the "case translation" tables that are defined on a job-wide basis.
{
{ NOTE that if this restriction is removed, it will be necessary for the
{ SCL_OPTIONS environment object to provide a specialized "pop" procedure
{ that will adjust the transalation tables, if necessary.

        clp$find_current_block (block);
        WHILE (block^.environment_object_info = NIL) OR
              (NOT block^.environment_object_info^.defined [clc$eo_scl_options]) DO
          block := block^.previous_block;
        WHILEND;
        IF (block^.kind <> clc$task_block) OR (block^.task_kind <> clc$job_monitor_task) THEN
          osp$set_status_abnormal ('CL', cle$not_yet_implemented,
                'change of NAME_FOLDING_LEVEL in pushed SCL_OPTIONS', status);
          RETURN;
        IFEND;

        osp$change_translation_tables (options.name_folding_level, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    IF pvt [p$wild_card_pattern_type].specified THEN
      IF pvt [p$wild_card_pattern_type].value^.keyword_value = 'BASIC' THEN
        options.wild_card_pattern_type := clc$wc_basic_pattern;
      ELSE {EXTENDED}
        options.wild_card_pattern_type := clc$wc_extended_pattern;
      IFEND;
    IFEND;

    clp$change_scl_options (options, status);

  PROCEND clp$_change_scl_options;
?? TITLE := 'clp$change_scl_options_command', EJECT ??

  PROCEDURE [XDCL] clp$$scl_options
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sclo) $scl_options

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 2, 17, 17, 56, 30, 877],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$SCLO']];

?? FMT (FORMAT := ON) ??
?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    make_scl_options_record (work_area, result, status);

  PROCEND clp$$scl_options;
?? TITLE := 'clp$_display_scl_options', EJECT ??

  PROCEDURE [XDCL] clp$_display_scl_options
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$disso) display_scl_options, display_scl_option, disso (
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 13, 17, 11, 7, 675],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$DISSO'], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

*copy clv$display_variables
?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    ignore_condition: pmt$condition;
           ignore_condition_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      IF output_open THEN
        clp$close_display (display_control, handler_status);
        output_open := FALSE;
      IFEND;
      handler_status.normal := TRUE;

    PROCEND abort_handler;
*copy clp$new_page_procedure
?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);


      { The display_scl_options command has no subtitles,
      { this is merely a dummy routine used to keep
      { the module consistent with those that do produce subtitles.

    PROCEND put_subtitle;
?? OLDTITLE, EJECT ??

    VAR
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      options_record: ^clt$data_value,
      output_open: boolean,
      representation: ^clt$data_representation,
      work_area: ^^clt$work_area;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_work_area (#RING (^work_area), work_area, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    make_scl_options_record (work_area^, options_record, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_open := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          default_ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output_open := TRUE;
    clv$titles_built := FALSE;
    clv$command_name := 'display_scl_options';

    clp$convert_data_to_string (options_record, clc$labeled_elem_representation, display_control.page_width,
          work_area^, representation, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_data_representation (display_control, representation, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$close_display (display_control, status);

    output_open := FALSE;

    osp$disestablish_cond_handler;

  PROCEND clp$_display_scl_options;
?? TITLE := 'make_scl_options_record', EJECT ??

  PROCEDURE make_scl_options_record
    (VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    VAR
      scl_options: ^clt$scl_options;


    status.normal := TRUE;

    clp$find_scl_options (scl_options);

    clp$make_record_value (4, work_area, result);

    result^.field_values^ [1].name := 'LINE_STYLE_CORRECTION_PROMPTS';
    clp$make_value (clc$keyword, work_area, result^.field_values^ [1].value);
    IF NOT scl_options^.line_style_correction_prompts.selected THEN
      result^.field_values^ [1].value^.keyword_value := 'NONE';
    ELSEIF scl_options^.line_style_correction_prompts.prompting_style = osc$line_interaction THEN
      result^.field_values^ [1].value^.keyword_value := 'LINE';
    ELSE
      result^.field_values^ [1].value^.keyword_value := 'SCREEN';
    IFEND;

    result^.field_values^ [2].name := 'SCREEN_STYLE_CORRECTION_PROMPTS';
    clp$make_value (clc$keyword, work_area, result^.field_values^ [2].value);
    IF scl_options^.screen_style_correction_prompts.selected THEN
      result^.field_values^ [2].value^.keyword_value := 'SCREEN';
    ELSE
      result^.field_values^ [2].value^.keyword_value := 'NONE';
    IFEND;

    result^.field_values^ [3].name := 'NAME_FOLDING_LEVEL';
    clp$make_value (clc$keyword, work_area, result^.field_values^ [3].value);
    IF scl_options^.name_folding_level = clc$full_folding THEN
      result^.field_values^ [3].value^.keyword_value := 'FULL_FOLDING';
    ELSE
      result^.field_values^ [3].value^.keyword_value := 'STANDARD_FOLDING';
    IFEND;

    result^.field_values^ [4].name := 'WILD_CARD_PATTERN_TYPE';
    clp$make_value (clc$keyword, work_area, result^.field_values^ [4].value);
    IF scl_options^.wild_card_pattern_type = clc$wc_extended_pattern THEN
      result^.field_values^ [4].value^.keyword_value := 'EXTENDED';
    ELSE
      result^.field_values^ [4].value^.keyword_value := 'BASIC';
    IFEND;

  PROCEND make_scl_options_record;

MODEND clm$scl_options_command;
*DECK DECK=CLM$SCL_OPTIONS_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Interpreter : SCL Options Manager' ??
MODULE clm$scl_options_manager;

{
{ PURPOSE:
{   This module contains the procedures and variables that maintain the
{   "SCL options" for the job.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc clt$environment_object_size
*copyc clt$scl_options
*copyc ost$status
?? POP ??
*copyc clp$find_scl_options
?? TITLE := 'clp$eo_size_scl_options', EJECT ??

  FUNCTION [XDCL] clp$eo_size_scl_options: clt$environment_object_size;


    clp$eo_size_scl_options := #SIZE (clt$scl_options);

  FUNCEND clp$eo_size_scl_options;
?? TITLE := 'clp$eo_init_scl_options', EJECT ??

  PROCEDURE [XDCL] clp$eo_init_scl_options
    (    object: ^clt$environment_object_contents);

    VAR
      scl_options: ^clt$scl_options;


    scl_options := object;

    scl_options^.line_style_correction_prompts.selected := TRUE;
    scl_options^.line_style_correction_prompts.prompting_style := osc$line_interaction;
    scl_options^.screen_style_correction_prompts.selected := TRUE;
    scl_options^.name_folding_level := clc$standard_folding;
    scl_options^.wild_card_pattern_type := clc$wc_extended_pattern;

  PROCEND clp$eo_init_scl_options;
?? TITLE := 'clp$change_scl_options', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$change_scl_options
    (    options: clt$scl_options;
     VAR status: ost$status);

    VAR
      scl_options: ^clt$scl_options;


    status.normal := TRUE;

    clp$find_scl_options (scl_options);

    scl_options^ := options;

  PROCEND clp$change_scl_options;

MODEND clm$scl_options_manager;
*DECK DECK=CLM$SCL_PARAMETER_DIALOG EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE SCL Interpreter : Screen Style Parameter Dialog Manager' ??
MODULE clm$scl_parameter_dialog;

{
{ PURPOSE:
{   This module contains the standard screen style dialog manager for
{   obtaining parameters for commands and functions from an interactive user.
{

?? LIBRARY := 'TUF$LIBRARY' ??
?? LIBRARY := 'TUF$TERMINAL_DEFINITIONS' ??

*copyc clh$parameter_dialog_manager
?? TITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$bad_pdt
*copyc cle$command_cancelled
*copyc cle$function_cancelled
*copyc cle$unable_to_enter_screen_mode
*copyc clt$parameter_dialog_support
*copyc clt$unbundled_pdt
*copyc ost$status
*copyc osv$upper_to_lower
?? POP ??
*copyc avp$ring_min
*copyc clp$convert_data_to_string
*copyc clp$data_representation_text
*copyc clp$include_command
*copyc clp$include_line
*copyc clp$pop_interactive_input
*copyc clp$push_interactive_input
*copyc clp$right_justify_string
*copyc clp$trimmed_string_size
*copyc csp$allocate_field
*copyc csp$change_cursor_position
*copyc csp$change_device_dimensions
*copyc csp$change_io_position
*copyc csp$change_field_attributes
*copyc csp$change_line_width
*copyc csp$change_page_attributes
*copyc csp$change_partial_screen
*copyc csp$clear_field
*copyc csp$clear_screen
*copyc csp$delete_field
*copyc csp$delete_graphic
*copyc csp$disable_menu_item
*copyc csp$disable_page
*copyc csp$display_menu
*copyc csp$enable_menu_item
*copyc csp$enable_page
*copyc csp$flush_events
*copyc csp$get_device_attributes
*copyc csp$get_event_name
*copyc csp$get_event
*copyc csp$get_field_attributes
*copyc csp$get_io_position
*copyc csp$get_page_attributes
*copyc csp$get_text
*copyc csp$mark_menu_item
*copyc csp$poly_hv_line
*copyc csp$poly_intersect
*copyc csp$pop_page
*copyc csp$push_page
*copyc csp$put_text
*copyc csp$set_standard_menu
*copyc csp$unmark_menu_item
*copyc csp$update_device
*copyc eup$get_file_selection
*copyc eup$get_item_selections
*copyc fsp$close_file
*copyc fsp$open_file
*copyc ifp$fetch_context
*copyc ifp$get_terminal_attributes
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$find_application_menu
*copyc osp$find_help_module
*copyc osp$find_parameter_prompt
*copyc osp$find_param_assist_prompt
*copyc osp$format_help_message
*copyc osp$format_message
*copyc osp$get_interaction_information
*copyc osp$get_status_condition_name
*copyc osp$set_status_condition
*copyc osp$status_message_text
*copyc pmp$continue_to_cause
?? EJECT ??

  TYPE

    clt$dialog_display_info = record
      command_field: cst$field_number,
      command_text: ^string ( * ),
      parameter_count: clt$parameter_count,
      parameters_displayed: 0 .. csc$max_line_number,
      top_parameter: clt$parameter_count,
      screen_height: 0 .. csc$max_line_number,
      screen_width: cst$visible_character_position,
      message_field: cst$field_number,
      current_window: clt$window_kind,
      reserved_rows: cst$lines_used,
      help_module: ^ost$help_module,
      help_window_displayed: boolean,
      message_window_displayed: boolean,
      zoom_window_displayed: boolean,
      line_number_field: cst$field_number,
      mouse_available: boolean,
      buttons: clt$dialog_buttons,
    recend,

    clt$dialog_buttons = record
      first: ^clt$dialog_button,
      page_up_button: clt$dialog_button,
      page_down_button: clt$dialog_button,
    recend,

    clt$dialog_button = record
      link: ^clt$dialog_button,
      name: ost$name,
      name_size: 0 .. osc$max_name_size,
      strong_action: integer,
      weak_action: integer,
      active: boolean,
      field: cst$field_number,
    recend,

    clt$output_window = record
      parent_window: clt$window_kind,
      top: integer,
      line_count: integer,
      lines_displayed: 0 .. csc$max_line_number,
      contents: ^array [1 .. * ] of ^string ( * ),
      text_field: cst$field_number,
      box_id: cst$graphic_identifier,
      background_field: cst$field_number,
      prompt_field: cst$field_number,
      cursor_character_position: 0 .. csc$max_x_position,
      cursor_field_number: cst$field_number,
      cursor_line_number: cst$line_number,
      line_number_field: cst$field_number,
      buttons: clt$dialog_buttons,
    recend,

    clt$input_window = record
      parent_window: clt$window_kind,
      top: integer,
      line_count: integer,
      lines_displayed: integer,
      contents: ^array [1 .. * ] of ^string ( * ),
      text_field: cst$field_number,
      box_id: cst$graphic_identifier,
      background_field: cst$field_number,
      prompt_field: cst$field_number,
      title_field: cst$field_number,
      cursor_character_position: 0 .. csc$max_x_position,
      cursor_field_number: cst$field_number,
      cursor_line_number: cst$line_number,
      line_number_field: cst$field_number,
      buttons: clt$dialog_buttons,
      changeable: boolean,
      case parameter_value: boolean of
      = TRUE =
        parameter_number: integer,
      = FALSE =
        ,
      casend,
    recend,

    clt$parameter_line_information = record
      name: string (clc$prompt_object_width),
      prompt: string (clc$prompt_object_width),
      case advanced_indicator: boolean of
      = TRUE =
        ,
      = FALSE =
        pdt_number: clt$parameter_count,
        evaluation_required: boolean,
        required: boolean,
        secure: boolean,
        too_big_to_edit: boolean,
        case initialized: boolean of
        = FALSE =
          ,
        = TRUE =
          overflow: boolean,
          value: ^string ( * ),
        casend,
      casend,
    recend,

    clt$parameter_display_info = record
      prompt_field_number: cst$field_number,
      value_field_number: cst$field_number,
    recend,

    clt$window_kind = (clc$help_window, clc$message_window, clc$zoom_window, clc$no_window);

{
{ The following constant defines the "seed" name for the help module
{ containing text to be displayed on the screen.
{

  CONST
    clc$spdm_messages_module = 'CLM$SPDM_MESSAGES              ';

{
{ The following constants define the names of messages within the help module.
{

  CONST
    clc$advanced_label = 'CLC$ADVANCED_LABEL             ',
    clc$backward_key_label = 'CLC$BACKWARD_KEY_LABEL         ',
    clc$cancel_key_label = 'CLC$CANCEL_KEY_LABEL           ',
    clc$clear_label = 'CLC$CLEAR_LABEL                ',
    clc$clear_eol_label = 'CLC$CLEAR_EOL_LABEL            ',
    clc$cleared_parameter_ignored = 'CLC$CLEARED_PARAMETER_IGNORED  ',
    clc$command_label = 'CLC$COMMAND_LABEL              ',
    clc$delete_char_label = 'CLC$DELETE_CHAR_LABEL          ',
    clc$down_key_label = 'CLC$DOWN_KEY_LABEL             ',
    clc$enter_command = 'CLC$ENTER_COMMAND              ',
    clc$enter_command_title = 'CLC$ENTER_COMMAND_TITLE        ',
    clc$enter_parameter_value = 'CLC$ENTER_PARAMETER_VALUE      ',
    clc$enter_values = 'CLC$ENTER_VALUES               ',
    clc$error_can_be_ignored = 'CLC$ERROR_CAN_BE_IGNORED       ',
    clc$evaluate_key_label = 'CLC$EVALUATE_KEY_LABEL         ',
    clc$first_key_label = 'CLC$FIRST_KEY_LABEL            ',
    clc$forward_key_label = 'CLC$FORWARD_KEY_LABEL          ',
    clc$function_key_help = 'CLC$FUNCTION_KEY_HELP          ',
    clc$function_label = 'CLC$FUNCTION_LABEL             ',
    clc$help_key_label = 'CLC$HELP_KEY_LABEL             ',
    clc$home_label = 'CLC$HOME_LABEL                 ',
    clc$info_key_label = 'CLC$INFO_KEY_LABEL             ',
    clc$info_display = 'CLC$INFO_DISPLAY               ',
    clc$info_display_with_one_name = 'CLC$INFO_DISPLAY_WITH_ONE_NAME ',
    clc$insert_char_label = 'CLC$INSERT_CHAR_LABEL          ',
    clc$last_key_label = 'CLC$LAST_KEY_LABEL             ',
    clc$lines_l_through_m_size_n = 'CLC$LINES_L_THROUGH_M_SIZE_N   ',
    clc$no_more_help_available = 'CLC$NO_MORE_HELP_AVAILABLE     ',
    clc$no_more_input_space = 'CLC$NO_MORE_INPUT_SPACE        ',
    clc$no_parameters_label = 'CLC$NO_PARAMETERS_LABEL        ',
    clc$ok_key_label = 'CLC$OK_KEY_LABEL               ',
    clc$press_next = 'CLC$PRESS_NEXT                 ',
    clc$press_next_from_pageable = 'CLC$PRESS_NEXT_FROM_PAGEABLE   ',
    clc$press_ok = 'CLC$PRESS_OK                   ',
    clc$press_down = 'CLC$PRESS_DOWN                 ',
    clc$press_up = 'CLC$PRESS_UP                   ',
    clc$reset_key_label = 'CLC$RESET_KEY_LABEL            ',
    clc$spdm_main_menu = 'CLC$SPDM_MAIN_MENU             ',
    clc$too_big_to_edit = 'CLC$TOO_BIG_TO_EDIT            ',
    clc$unable_to_zoom_secure_param = 'CLC$UNABLE_TO_ZOOM_SECURE_PARAM',
    clc$undefined_function_key = 'CLC$UNDEFINED_FUNCTION_KEY     ',
    clc$up_key_label = 'CLC$UP_KEY_LABEL               ',
    clc$zoom_key_label = 'CLC$ZOOM_KEY_LABEL             ';

  CONST
    carriage_return = 0,
    forward_event = 1,
    backward_event = 2,
    help_event = 3,
    ok_event = 4,
    cancel_event = 5,
    evaluate_event = 6,
    reset_event = 7,
    zoom_event = 8,
    edit_zoom_event = 9,
    info_event = 10,
    home_event = 11,
    clear_eol_event = 12,
    insert_char_event = 13,
    delete_char_event = 14,
    clear_event = 15,
    last_event = 16,
    first_event = 17,
    up_event = 18,
    down_event = 19,
    mouse_click_weak = 20,
    mouse_click_strong = 21;

  CONST
    menu_event_bias = 100,
    help_event_from_menu = help_event + menu_event_bias,
    ok_event_from_menu = ok_event + menu_event_bias,
    cancel_event_from_menu = cancel_event + menu_event_bias,
    evaluate_event_from_menu = evaluate_event + menu_event_bias,
    reset_event_from_menu = reset_event + menu_event_bias,
    zoom_event_from_menu = zoom_event + menu_event_bias,
    edit_zoom_event_from_menu = edit_zoom_event + menu_event_bias,
    info_event_from_menu = info_event + menu_event_bias;

  CONST
    x_position_attribute = 1,
    y_position_attribute = 2,
    visible_characters_attribute = 3,
    visible_lines_attribute = 4,
    characters_attribute = 5,
    lines_attribute = 6,
    input_attribute = 7,
    highlighting_attribute = 8,
    logical_highlighting_attribute = 9;

  TYPE
    clt$field_attributes = array [1 .. logical_highlighting_attribute] of cst$field_attribute;

  VAR
    clv$default_field_attributes: clt$field_attributes :=
          [[csc$fld_x_position, 1], [csc$fld_y_position, 1], [csc$fld_visible_characters, 1],
          [csc$fld_visible_lines, 1], [csc$fld_characters, 1], [csc$fld_lines, 1], [csc$fld_input, FALSE],
          [csc$fld_highlighting, csc$logical_highlighting], [csc$fld_logical_highlighting,
          csc$logical_normal]];

  CONST
    clc$advanced_label_line_number = 2,
    clc$blank_lines_after_header = 1,
    clc$dialog_box_inset = 5,
    clc$estimated_overhead_lines = 6,
    clc$left_margin = 3,
    clc$lines_for_advanced = 3,
    clc$lines_for_one_menu_row = 2,
    clc$lines_for_two_menu_rows = 5,
    clc$lines_used_by_title = 1,
    clc$middle_margin = 1,
    clc$minimum_parameter_rows = 4,
    clc$maximum_zoom_lines = 12,
    clc$overflow_indicator = '..',
    clc$prompt_object_width = 32,
    clc$right_margin = 1,
    clc$title_line_number_inset = 2;

?? TITLE := 'clp$scl_parameter_dialog_mgr', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$scl_parameter_dialog_mgr
    (    support: clt$parameter_dialog_support;
         command_or_function_name: clt$command_name;
         ignore_online_manual_name: ost$online_manual_name;
         pdt: clt$unbundled_pdt;
     VAR cancel: boolean;
     VAR status: ost$status);

    VAR
      action_number: integer,
      called_from_screen_mode: boolean,
      cleared_parameters: ^array [1 .. * ] of ^ost$message_parameter,
      command_line_number: 0 .. csc$max_line_number,
      current_file_selection: fst$path,
      cursor_character_position: 0 .. csc$max_x_position,
      cursor_field_number: cst$field_number,
      cursor_line_number: 0 .. csc$max_line_number,
      dialog_box_max_lines: 0 .. csc$max_line_number,
      dialog_box_top: 0 .. csc$max_line_number,
      display: clt$dialog_display_info,
      editing_parameter_list: boolean,
      end_of_line: boolean,
      end_of_parameter_lines: 0 .. csc$max_line_number,
      entered_screen_mode: boolean,
      event: cst$event_identifier,
      event_on_parameter_line: boolean,
      file_identifier: amt$file_identifier,
      help_window: clt$output_window,
      ignore_following_csc$next_event: boolean,
      ignore_tab_caused_by_next: boolean,
      initial_status: ost$status,
      input_file_opened: boolean,
      lines_used_by_trailer: 0 .. csc$max_line_number,
      menu_classes: cst$menu_class,
      menu_classes_copy: cst$menu_class,
      menu_list: cst$menu_list,
      menu_list_copy: cst$menu_list,
      message_displayed: boolean,
      message_field_width: 0 .. csc$max_x_position,
      message_line_number: 0 .. csc$max_line_number,
      message_read: boolean,
      message_window: clt$output_window,
      mouse_event: boolean,
      need_to_clear_command_field: boolean,
      next_event: boolean,
      old_interaction_style: cst$interaction_style,
      parameter_display_info: ^array [1 .. * ] of clt$parameter_display_info,
      parameter_information: ^array [1 .. * ] of clt$parameter_line_information,
      parameter_line: integer,
      parameter_number: integer,
      parameter_selected: boolean,
      parameter_value_column_number: 0 .. csc$max_x_position,
      parameter_value_field_width: 0 .. csc$max_x_position,
      processing_complete: boolean,
      screen_event: boolean,
      start_of_parameter_lines: 0 .. csc$max_line_number,
      status_condition_name: ost$status_condition_name,
      title_box_top: 0 .. csc$max_line_number,
      update_parameters: boolean,
      zoom_window: clt$input_window;

?? NEWTITLE := 'center_parameter_on_screen', EJECT ??

    PROCEDURE center_parameter_on_screen;

      IF (parameter_number < display.top_parameter) OR (parameter_number >
            (display.top_parameter + display.parameters_displayed - 1)) THEN
        IF (parameter_number + (display.parameters_displayed DIV 2) - 1) > display.parameter_count THEN
          display.top_parameter := display.parameter_count - display.parameters_displayed + 1;
        ELSEIF parameter_number < ((display.parameters_displayed DIV 2) - 1) THEN
          display.top_parameter := 1;
        ELSE
          display.top_parameter := parameter_number - (display.parameters_displayed DIV 2) + 1;
        IFEND;
        update_parameters := TRUE;
      IFEND;

      cursor_field_number := parameter_display_info^ [parameter_number - display.top_parameter +
            1].value_field_number;
      cursor_line_number := 1;
      cursor_character_position := 1;

    PROCEND center_parameter_on_screen;
?? TITLE := 'change_menu_items', EJECT ??

    PROCEDURE change_menu_items
      (    old_window: clt$window_kind;
           new_window: clt$window_kind);


      CASE new_window OF
      = clc$zoom_window =
        CASE old_window OF
        = clc$zoom_window =
          ;
        = clc$message_window, clc$help_window =
          csp$enable_menu_item (cancel_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$enable_menu_item (ok_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        ELSE {clc$no_window
          csp$disable_menu_item (down_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$disable_menu_item (evaluate_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$disable_menu_item (info_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$disable_menu_item (reset_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$disable_menu_item (up_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$disable_menu_item (zoom_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$disable_menu_item (edit_zoom_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        CASEND;
      = clc$message_window, clc$help_window =
        CASE old_window OF
        = clc$zoom_window =
          csp$disable_menu_item (cancel_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$disable_menu_item (ok_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        = clc$message_window, clc$help_window =
          ;
        ELSE {clc$no_window
          csp$disable_menu_item (down_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$disable_menu_item (evaluate_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$disable_menu_item (info_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$disable_menu_item (reset_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$disable_menu_item (up_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$disable_menu_item (zoom_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$disable_menu_item (edit_zoom_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$disable_menu_item (cancel_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$disable_menu_item (ok_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        CASEND;
      ELSE {clc$no_window
        csp$enable_menu_item (down_event, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$enable_menu_item (evaluate_event, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        IF support.nested_dialog_title = NIL THEN
          csp$enable_menu_item (info_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        IFEND;
        csp$enable_menu_item (reset_event, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$enable_menu_item (up_event, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$enable_menu_item (zoom_event, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$enable_menu_item (edit_zoom_event, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        CASE old_window OF
        = clc$message_window, clc$help_window =
          csp$enable_menu_item (cancel_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$enable_menu_item (ok_event, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        ELSE
        CASEND;
      CASEND;

    PROCEND change_menu_items;
?? TITLE := 'clear_command_field', EJECT ??

    PROCEDURE clear_command_field;


      csp$clear_field (display.command_field, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      IF display.command_text <> NIL THEN
        FREE display.command_text;
      IFEND;
      need_to_clear_command_field := FALSE;

    PROCEND clear_command_field;
?? TITLE := 'close_window', EJECT ??

    PROCEDURE close_window
      (    window_kind: clt$window_kind);

      VAR
        button: ^clt$dialog_button,
        window_buttons: ^clt$dialog_buttons;


      CASE window_kind OF

      = clc$help_window =
        csp$delete_field (help_window.background_field, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$delete_graphic (help_window.box_id, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$delete_field (help_window.prompt_field, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$delete_field (help_window.text_field, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$delete_field (help_window.line_number_field, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        free_window_contents (help_window.contents);
        cursor_field_number := help_window.cursor_field_number;
        cursor_character_position := help_window.cursor_character_position;
        cursor_line_number := help_window.cursor_line_number;
        display.help_window_displayed := FALSE;
        display.current_window := help_window.parent_window;
        window_buttons := ^help_window.buttons;

      = clc$message_window =
        csp$delete_field (message_window.background_field, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$delete_graphic (message_window.box_id, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$delete_field (message_window.prompt_field, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$delete_field (message_window.text_field, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$delete_field (message_window.line_number_field, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        free_window_contents (message_window.contents);
        cursor_field_number := message_window.cursor_field_number;
        cursor_character_position := message_window.cursor_character_position;
        cursor_line_number := message_window.cursor_line_number;
        display.message_window_displayed := FALSE;
        display.current_window := message_window.parent_window;
        status_condition_name := '';
        window_buttons := ^message_window.buttons;

      = clc$zoom_window =
        csp$delete_field (zoom_window.background_field, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$delete_graphic (zoom_window.box_id, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$delete_field (zoom_window.prompt_field, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$delete_field (zoom_window.text_field, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$delete_field (zoom_window.title_field, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$delete_field (zoom_window.line_number_field, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        free_window_contents (zoom_window.contents);
        cursor_field_number := zoom_window.cursor_field_number;
        cursor_character_position := zoom_window.cursor_character_position;
        cursor_line_number := zoom_window.cursor_line_number;
        display.zoom_window_displayed := FALSE;
        display.current_window := zoom_window.parent_window;
        window_buttons := ^zoom_window.buttons;

      ELSE
        window_buttons := NIL;
      CASEND;

      IF window_buttons <> NIL THEN
        button := window_buttons^.first;
        WHILE button <> NIL DO
          IF button^.field <> 0 THEN
            csp$delete_field (button^.field, status);
            IF NOT status.normal THEN
              EXIT clp$scl_parameter_dialog_mgr;
            IFEND;
            button^.field := 0;
          IFEND;
          button := button^.link;
        WHILEND;
      IFEND;

    PROCEND close_window;
?? TITLE := 'condition_handler', EJECT ??

{
{ PURPOSE:
{   This procedure handles block exit and interactive conditions.
{
{   For a block exit condition it "shuts down" the screen interaction and
{   exits as if cancelled by the user.
{
{   For an ifc$terminate_break condition it EXITs from its establisher, which
{   results in this handler being called again for a "block exit" condition.
{

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           ignore_info: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ^ost$status;


      CASE condition.selector OF

      = pmc$block_exit_processing =
        cancel := TRUE;
        PUSH local_status;
        local_status^ := status;
        status.normal := TRUE;
        shut_down ({ignore_errors=} TRUE);
        status := local_status^;
        RETURN;

      = ifc$interactive_condition =
        CASE condition.interactive_condition OF

        = ifc$terminate_break =
          EXIT clp$scl_parameter_dialog_mgr;

        ELSE
          ;
        CASEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND condition_handler;
?? TITLE := 'construct_parameter_information', EJECT ??

    PROCEDURE construct_parameter_information;

      VAR
        current_parameter: integer,
        first_advanced_parameter: integer,
        i: integer,
        message_text: string (csc$max_x_position),
        text_length: 0 .. csc$max_x_position;


      current_parameter := 0;
      first_advanced_parameter := 0;
      display.parameter_count := pdt.header^.number_of_parameters - pdt.header^.number_of_hidden_parameters +
            (clc$lines_for_advanced * $INTEGER (pdt.header^.number_of_advanced_parameters > 0)) -
            $INTEGER (pdt.header^.status_parameter_number > 0);
      IF display.parameter_count < 1 THEN
        RETURN;
      IFEND;
      ALLOCATE parameter_information: [1 .. display.parameter_count];

      FOR i := 1 TO pdt.header^.number_of_parameters DO
        CASE pdt.parameters^ [i].availability OF

        = clc$normal_usage_entry =
          IF i <> pdt.header^.status_parameter_number THEN
            IF current_parameter < display.parameter_count THEN
              current_parameter := current_parameter + 1;
            ELSE
              osp$set_status_condition (cle$bad_pdt, status);
              EXIT clp$scl_parameter_dialog_mgr;
            IFEND;
            parameter_information^ [current_parameter].advanced_indicator := FALSE;
            parameter_information^ [current_parameter].pdt_number := i;
            parameter_information^ [current_parameter].evaluation_required := FALSE;
            parameter_information^ [current_parameter].required :=
                  pdt.parameters^ [i].requirement = clc$required_parameter;
            parameter_information^ [current_parameter].secure :=
                  pdt.parameters^ [i].security = clc$secure_parameter;
            parameter_information^ [current_parameter].initialized := FALSE;
            parameter_information^ [current_parameter].too_big_to_edit := FALSE;
          IFEND;

        = clc$advanced_usage_entry =

{ Display all advanced usage parameters following normal usage parameters.

          IF first_advanced_parameter = 0 THEN
            first_advanced_parameter := i;
          IFEND;

        ELSE {clc$hidden_usage_entry}

{ Do not display hidden usage parameters.

          ;
        CASEND;

      FOREND;

      IF first_advanced_parameter > 0 THEN
        FOR i := 1 TO clc$lines_for_advanced DO
          IF current_parameter < display.parameter_count THEN
            current_parameter := current_parameter + 1;
          ELSE
            osp$set_status_condition (cle$bad_pdt, status);
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          parameter_information^ [current_parameter].advanced_indicator := TRUE;
          IF i = clc$advanced_label_line_number THEN
            get_message_text (clc$advanced_label, NIL, message_text, text_length);
            parameter_information^ [current_parameter].prompt := message_text (1, text_length);
          ELSE
            parameter_information^ [current_parameter].prompt := ' ';
          IFEND;
        FOREND;

        FOR i := first_advanced_parameter TO pdt.header^.number_of_parameters DO
          CASE pdt.parameters^ [i].availability OF
          = clc$normal_usage_entry =
            ;
          = clc$advanced_usage_entry =
            IF current_parameter < display.parameter_count THEN
              current_parameter := current_parameter + 1;
            ELSE
              osp$set_status_condition (cle$bad_pdt, status);
              EXIT clp$scl_parameter_dialog_mgr;
            IFEND;
            parameter_information^ [current_parameter].advanced_indicator := FALSE;
            parameter_information^ [current_parameter].pdt_number := i;
            parameter_information^ [current_parameter].evaluation_required := FALSE;
            parameter_information^ [current_parameter].required :=
                  pdt.parameters^ [i].requirement = clc$required_parameter;
            parameter_information^ [current_parameter].secure :=
                  pdt.parameters^ [i].security = clc$secure_parameter;
            parameter_information^ [current_parameter].initialized := FALSE;
            parameter_information^ [current_parameter].too_big_to_edit := FALSE;
          ELSE {clc$hidden_usage_entry}
            ;
          CASEND;
        FOREND;
      IFEND;

      IF current_parameter <> display.parameter_count THEN
        osp$set_status_condition (cle$bad_pdt, status);
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

    PROCEND construct_parameter_information;
?? TITLE := 'construct_window_prompt', EJECT ??

    PROCEDURE construct_window_prompt
      (    message_name: clt$parameter_name;
           message_parameters: ^array [1 .. * ] of ^ost$message_parameter;
       VAR message_text: string ( * <= csc$max_x_position);
       VAR text_length: 0 .. csc$max_x_position);


      VAR
        message: ost$status_message,
        message_area: ^ost$status_message,
        message_line: ^ost$status_message_line,
        message_line_count: ^ost$status_message_line_count,
        message_line_size: ^ost$status_message_line_size,
        message_template: ^ost$message_template;

      find_help_module;
      osp$find_param_assist_prompt (display.help_module, message_name, message_template, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      osp$format_help_message (message_template, message_parameters, message_field_width, message, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      message_area := ^message;
      RESET message_area;
      NEXT message_line_count IN message_area;
      IF message_line_count^ = 1 THEN
        NEXT message_line_size IN message_area;
        NEXT message_line: [message_line_size^] IN message_area;
        text_length := message_line_size^;
        message_text := message_line^;
      ELSE
        text_length := 0;
        message_text := '';
      IFEND;

    PROCEND construct_window_prompt;
?? TITLE := 'convert_name_to_message_param', EJECT ??

    PROCEDURE convert_name_to_message_param
      (VAR name {input, output} : ost$name);

      VAR
        i: 1 .. osc$max_name_size,
        new_word: boolean;


      new_word := TRUE;
      FOR i := 1 TO osc$max_name_size DO
        IF name (i) = ' ' THEN
          RETURN;
        ELSEIF name (i) = '_' THEN
          name (i) := ' ';
          new_word := TRUE;
        ELSEIF new_word THEN
          new_word := FALSE;
        ELSE
          name (i) := osv$upper_to_lower ($INTEGER (name (i)) + 1);
        IFEND;
      FOREND;

    PROCEND convert_name_to_message_param;
?? TITLE := 'create_prompt_and_value_fields', EJECT ??

    PROCEDURE create_prompt_and_value_fields;

      VAR
        i: 0 .. csc$max_line_number,
        prompt_field: clt$field_attributes,
        parameter_value_field: clt$field_attributes;


      prompt_field := clv$default_field_attributes;
      prompt_field [x_position_attribute].x_position := clc$left_margin;
      prompt_field [visible_characters_attribute].characters := clc$prompt_object_width;
      prompt_field [visible_lines_attribute].lines := 1;
      prompt_field [characters_attribute].characters := clc$prompt_object_width;
      prompt_field [lines_attribute].lines := 1;

      parameter_value_field := clv$default_field_attributes;
      parameter_value_column_number := clc$left_margin + clc$prompt_object_width + clc$middle_margin + 1;
      parameter_value_field_width := display.screen_width - parameter_value_column_number - clc$right_margin;
      parameter_value_field [x_position_attribute].x_position := parameter_value_column_number;
      parameter_value_field [visible_characters_attribute].characters := parameter_value_field_width;
      parameter_value_field [visible_lines_attribute].lines := 1;
      parameter_value_field [characters_attribute].characters := parameter_value_field_width;
      parameter_value_field [lines_attribute].lines := 1;
      parameter_value_field [input_attribute].input := TRUE;
      parameter_value_field [logical_highlighting_attribute].logical_highlighting := csc$input;

      FOR i := 1 TO display.parameters_displayed DO
        prompt_field [y_position_attribute].y_position := start_of_parameter_lines + i - 1;
        csp$allocate_field (prompt_field, parameter_display_info^ [i].prompt_field_number, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        parameter_value_field [y_position_attribute].y_position := start_of_parameter_lines + i - 1;
        csp$allocate_field (parameter_value_field, parameter_display_info^ [i].value_field_number, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
      FOREND;

    PROCEND create_prompt_and_value_fields;
?? TITLE := 'create_window', EJECT ??

    PROCEDURE create_window
      (    window_kind: clt$window_kind;
           x_position: 0 .. csc$max_x_position;
           y_position: 0 .. csc$max_line_number;
           width: 0 .. csc$max_x_position;
           height: 0 .. csc$max_line_number;
           box_prompt: string ( * <= 256);
           box_title: string ( * <= 256);
           force_protection: boolean);

      VAR
        background_field_number: cst$field_number,
        box_coordinates: array [1 .. 5] of cst$xy_coordinate,
        box_graphic_id: cst$graphic_identifier,
        box_prompt_field: clt$field_attributes,
        box_prompt_field_number: cst$field_number,
        box_prompt_width: 0 .. csc$max_x_position,
        box_title_field: clt$field_attributes,
        box_title_width: 0 .. csc$max_x_position,
        corner_coordinates: array [1 .. 4] of cst$xy_coordinate,
        end_of_text: boolean,
        intersection_types: array [1 .. 4] of cst$intersection_type,
        line_number_field: clt$field_attributes,
        line_number_field_number: cst$field_number,
        text_field: clt$field_attributes,
        text_field_number: cst$field_number,
        window_buttons: ^clt$dialog_buttons;


      csp$change_line_width (csc$fine, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      initialize_background_field (x_position, y_position, width, height, background_field_number);
      box_coordinates [1].x := x_position;
      box_coordinates [1].y := y_position;
      box_coordinates [2].x := x_position + width - 1;
      box_coordinates [2].y := box_coordinates [1].y;
      box_coordinates [3].x := box_coordinates [2].x;
      box_coordinates [3].y := box_coordinates [1].y + height - 1;
      box_coordinates [4].x := box_coordinates [1].x;
      box_coordinates [4].y := box_coordinates [3].y;
      box_coordinates [5] := box_coordinates [1];
      csp$poly_hv_line (box_coordinates, box_graphic_id, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      intersection_types [1] := csc$upper_left;
      intersection_types [2] := csc$upper_right;
      intersection_types [3] := csc$lower_right;
      intersection_types [4] := csc$lower_left;
      corner_coordinates [1].x := box_coordinates [1].x;
      corner_coordinates [1].y := box_coordinates [1].y;
      corner_coordinates [2].x := box_coordinates [2].x;
      corner_coordinates [2].y := box_coordinates [2].y;
      corner_coordinates [3].x := box_coordinates [3].x;
      corner_coordinates [3].y := box_coordinates [3].y;
      corner_coordinates [4].x := box_coordinates [4].x;
      corner_coordinates [4].y := box_coordinates [4].y;
      csp$poly_intersect (box_graphic_id, corner_coordinates, intersection_types, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      box_prompt_width := STRLENGTH (box_prompt);
      box_prompt_field := clv$default_field_attributes;
      box_prompt_field [x_position_attribute].x_position := ((width - box_prompt_width) DIV 2) + 1;
      box_prompt_field [y_position_attribute].y_position := box_coordinates [3].y;
      box_prompt_field [visible_characters_attribute].visible_characters := box_prompt_width;
      box_prompt_field [characters_attribute].characters := box_prompt_field [3].visible_characters;
      box_prompt_field [logical_highlighting_attribute].logical_highlighting := csc$italic;
      csp$allocate_field (box_prompt_field, box_prompt_field_number, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      csp$change_io_position (box_prompt_field_number, 1, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      end_of_text := FALSE;
      csp$put_text (^box_prompt, TRUE, end_of_text, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      text_field := clv$default_field_attributes;
      text_field [x_position_attribute].x_position := clc$left_margin;
      text_field [y_position_attribute].y_position := y_position + 1;
      text_field [visible_characters_attribute].visible_characters := message_field_width;
      text_field [visible_lines_attribute].visible_lines := height - 2;
      text_field [characters_attribute].characters := text_field [visible_characters_attribute].
            visible_characters;
      text_field [lines_attribute].lines := text_field [visible_lines_attribute].visible_lines;

      IF (window_kind = clc$zoom_window) AND (NOT force_protection) THEN
        text_field [input_attribute].input := TRUE;
        text_field [logical_highlighting_attribute].logical_highlighting := csc$input;
      IFEND;

      csp$allocate_field (text_field, text_field_number, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      line_number_field := clv$default_field_attributes;
      line_number_field [x_position_attribute].x_position := width - clc$title_line_number_inset;
      line_number_field [y_position_attribute].y_position := y_position;
      line_number_field [visible_characters_attribute].visible_characters := 1;
      line_number_field [characters_attribute].characters := display.screen_width;

      csp$allocate_field (line_number_field, line_number_field_number, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      CASE window_kind OF
      = clc$help_window =
        display.help_window_displayed := TRUE;
        help_window.parent_window := display.current_window;
        display.current_window := clc$help_window;
        help_window.prompt_field := box_prompt_field_number;
        help_window.text_field := text_field_number;
        help_window.background_field := background_field_number;
        help_window.top := 1;
        help_window.lines_displayed := height - 2;
        help_window.box_id := box_graphic_id;
        help_window.contents := NIL;
        help_window.line_number_field := line_number_field_number;
        help_window.cursor_field_number := cursor_field_number;
        help_window.cursor_character_position := cursor_character_position;
        help_window.cursor_line_number := cursor_line_number;
        window_buttons := ^help_window.buttons;

      = clc$message_window =
        display.message_window_displayed := TRUE;
        message_window.parent_window := display.current_window;
        display.current_window := clc$message_window;
        message_window.prompt_field := box_prompt_field_number;
        message_window.text_field := text_field_number;
        message_window.background_field := background_field_number;
        message_window.top := 1;
        message_window.lines_displayed := height - 2;
        message_window.box_id := box_graphic_id;
        message_window.contents := NIL;
        message_window.line_number_field := line_number_field_number;
        message_window.cursor_field_number := cursor_field_number;
        message_window.cursor_character_position := cursor_character_position;
        message_window.cursor_line_number := cursor_line_number;
        window_buttons := ^message_window.buttons;

      = clc$zoom_window =
        box_title_width := STRLENGTH (box_title);
        box_title_field := clv$default_field_attributes;
        box_title_field [x_position_attribute].x_position :=
              box_coordinates [1].x + clc$title_line_number_inset;
        box_title_field [y_position_attribute].y_position := box_coordinates [1].y;
        box_title_field [visible_characters_attribute].visible_characters := box_title_width;
        box_title_field [visible_lines_attribute].visible_lines := 1;
        box_title_field [characters_attribute].characters :=
              box_title_field [visible_characters_attribute].visible_characters;
        box_title_field [lines_attribute].lines := 1;
        box_title_field [logical_highlighting_attribute].logical_highlighting := csc$logical_normal;
        csp$allocate_field (box_title_field, zoom_window.title_field, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$change_io_position (zoom_window.title_field, 1, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        end_of_text := FALSE;
        csp$put_text (^box_title, TRUE, end_of_text, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        display.zoom_window_displayed := TRUE;
        zoom_window.parent_window := display.current_window;
        display.current_window := clc$zoom_window;
        zoom_window.prompt_field := box_prompt_field_number;
        zoom_window.text_field := text_field_number;
        zoom_window.background_field := background_field_number;
        zoom_window.top := 1;
        zoom_window.lines_displayed := height - 2;
        zoom_window.box_id := box_graphic_id;
        zoom_window.parameter_value := FALSE;
        zoom_window.line_count := text_field [lines_attribute].lines;
        zoom_window.line_number_field := line_number_field_number;
        window_buttons := ^zoom_window.buttons;
        zoom_window.contents := NIL;
        zoom_window.changeable := TRUE;

      ELSE
        window_buttons := NIL;
      CASEND;

      IF window_buttons <> NIL THEN
        initialize_buttons (window_buttons^);
      IFEND;

      cursor_field_number := text_field_number;
      cursor_line_number := 1;
      cursor_character_position := 1;

    PROCEND create_window;
?? TITLE := 'display_help_window', EJECT ??

    PROCEDURE display_help_window
      (    representation: ^clt$data_representation;
       VAR message_area: ^ost$status_message);

      VAR
        events: ^array [1 .. * ] of carriage_return .. down_event,
        i: 0 .. csc$max_line_number,
        message_line: ^ost$status_message_line,
        message_line_count: ^ost$status_message_line_count,
        message_lines: ost$status_message_line_count,
        message_line_size: ^ost$status_message_line_size,
        message_text: string (csc$max_x_position),
        number_of_lines_for_box: 0 .. csc$max_line_number,
        representation_area: ^clt$data_representation,
        representation_line: ^clt$string_value,
        representation_line_count: ^clt$data_representation_count,
        representation_line_size: ^clt$string_size,
        separation_lines: 0 .. csc$max_line_number,
        text_length: 0 .. csc$max_x_position;

      IF display.help_window_displayed THEN
        close_window (clc$help_window);
      IFEND;
      change_menu_items (display.current_window, clc$help_window);
      IF message_area <> NIL THEN
        RESET message_area;
        NEXT message_line_count IN message_area;
        message_lines := message_line_count^;
      ELSE
        message_lines := 0;
      IFEND;
      help_window.line_count := message_lines;

      IF representation <> NIL THEN
        PUSH representation_area: [[REP #SIZE (representation^) OF cell]];
        representation_area^ := representation^;
        RESET representation_area;
        NEXT representation_line_count IN representation_area;
        help_window.line_count := help_window.line_count + representation_line_count^;
      IFEND;

      IF (message_area <> NIL) AND (representation <> NIL) THEN
        separation_lines := 1;
      ELSE
        separation_lines := 0;
      IFEND;
      help_window.line_count := help_window.line_count + separation_lines;

      IF help_window.line_count > dialog_box_max_lines - 2 THEN
        PUSH events: [1 .. 3];
        events^ [1] := carriage_return;
        events^ [2] := forward_event;
        events^ [3] := backward_event;
        get_function_key_message (clc$press_next_from_pageable, events, message_text, text_length);
        number_of_lines_for_box := dialog_box_max_lines;
      ELSE
        PUSH events: [1 .. 1];
        events^ [1] := carriage_return;
        get_function_key_message (clc$press_next, events, message_text, text_length);
        number_of_lines_for_box := help_window.line_count + 2;
      IFEND;
      create_window (clc$help_window, 1, dialog_box_top, display.screen_width, number_of_lines_for_box,
            message_text (1, text_length), '', FALSE);
      update_lines_l_thru_m_of_n (help_window.top, help_window.lines_displayed, help_window.line_count,
            help_window.line_number_field, help_window.buttons);
      ALLOCATE help_window.contents: [1 .. help_window.line_count];

      FOR i := 1 TO message_lines DO
        NEXT message_line_size IN message_area;
        NEXT message_line: [message_line_size^] IN message_area;
        IF message_line_size^ > 1 THEN
          ALLOCATE help_window.contents^ [i]: [message_line_size^ -1];
          help_window.contents^ [i]^ := message_line^ (2, * );
        ELSE
          help_window.contents^ [i] := NIL;
        IFEND;
      FOREND;

      FOR i := message_lines + 1 TO message_lines + separation_lines DO
        help_window.contents^ [i] := NIL;
      FOREND;

      FOR i := message_lines + 1 + separation_lines TO help_window.line_count DO
        NEXT representation_line_size IN representation_area;
        NEXT representation_line: [representation_line_size^] IN representation_area;
        IF representation_line_size^ > 0 THEN
          ALLOCATE help_window.contents^ [i]: [representation_line_size^];
          help_window.contents^ [i]^ := representation_line^;
        ELSE
          help_window.contents^ [i] := NIL;
        IFEND;
      FOREND;

      update_window_display (clc$help_window);

    PROCEND display_help_window;
?? TITLE := 'display_message', EJECT ??

    PROCEDURE display_message
      (    message_text: string ( * ));

      VAR
        end_of_text: boolean,
        message_text_length: 0 .. csc$max_x_position;


      csp$change_io_position (display.message_field, 1, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      message_text_length := clp$trimmed_string_size (message_text);
      IF message_text_length > message_field_width THEN
{ Truncate long messages.
        message_text_length := message_field_width;
      IFEND;
      csp$put_text (^message_text (1, message_text_length), TRUE, end_of_text, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      message_displayed := TRUE;
      message_read := FALSE;

    PROCEND display_message;
?? TITLE := 'display_message_and_status', EJECT ??

    PROCEDURE display_message_and_status
      (    message_status: ost$status);

      VAR
        i: integer,
        message: ost$status_message,
        message_area: ^ost$status_message,
        message_line: ^ost$status_message_line,
        message_line_count: ^ost$status_message_line_count,
        message_line_size: ^ost$status_message_line_size,
        message_parameters: ^array [1 .. * ] of ^ost$message_parameter,
        status_message: ost$status_message;


{ Save status condition name for future HELP processing.

      osp$get_status_condition_name (message_status.condition, status_condition_name, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      osp$format_message (message_status, osc$current_message_level, osc$max_status_message_line,
            status_message, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      message_area := ^status_message;
      RESET message_area;
      NEXT message_line_count IN message_area;
      PUSH message_parameters: [1 .. message_line_count^ +1];
      message_parameters^ [1] := ^parameter_information^ [parameter_number].name;
      FOR i := 2 TO message_line_count^ +1 DO
        NEXT message_line_size IN message_area;
        NEXT message_line: [message_line_size^] IN message_area;
        message_parameters^ [i] := message_line;
      FOREND;
      get_message (clc$error_can_be_ignored, message_parameters, message);
      display_status_message (message, clc$message_window);

    PROCEND display_message_and_status;
?? TITLE := 'display_message_box', EJECT ??

    PROCEDURE display_message_box
      (    message: ost$status_message;
           line_count: 0 .. csc$max_line_number;
           window_kind: clt$window_kind);

      VAR
        events: ^array [1 .. * ] of carriage_return .. down_event,
        message_text: string (csc$max_x_position),
        number_of_lines_for_box: 0 .. csc$max_line_number,
        text_length: 0 .. csc$max_x_position;

?? NEWTITLE := 'display_status_in_box', EJECT ??

      PROCEDURE display_status_in_box
        (    message: ost$status_message;
             line_count: 0 .. csc$max_line_number;
         VAR window: clt$output_window);

        VAR
          end_of_text: boolean,
          i: 0 .. csc$max_line_number,
          message_area: ^ost$status_message,
          message_line: ^ost$status_message_line,
          message_line_count: ^ost$status_message_line_count,
          message_line_size: ^ost$status_message_line_size;


        message_area := ^message;
        RESET message_area;
        NEXT message_line_count IN message_area;
        window.line_count := message_line_count^;
        ALLOCATE window.contents: [1 .. window.line_count];
        FOR i := 1 TO window.line_count DO
          NEXT message_line_size IN message_area;
          NEXT message_line: [message_line_size^] IN message_area;
          IF message_line_size^ > 1 THEN
            ALLOCATE window.contents^ [i]: [message_line_size^ -1];
            window.contents^ [i]^ := message_line^ (2, * );
          ELSE
            window.contents^ [i] := NIL;
          IFEND;
          IF (i <= line_count) AND (window.contents^ [i] <> NIL) THEN
            csp$change_io_position (window.text_field, i, status);
            IF NOT status.normal THEN
              EXIT clp$scl_parameter_dialog_mgr;
            IFEND;
            csp$put_text (window.contents^ [i], TRUE, end_of_text, status);
            IF NOT status.normal THEN
              EXIT clp$scl_parameter_dialog_mgr;
            IFEND;
          IFEND;
        FOREND;

        update_lines_l_thru_m_of_n (window.top, window.lines_displayed, window.line_count,
              window.line_number_field, window.buttons);

      PROCEND display_status_in_box;
?? OLDTITLE, EJECT ??

      CASE window_kind OF
      = clc$help_window =
        IF display.help_window_displayed THEN
          close_window (clc$help_window);
        IFEND;
      = clc$message_window =
        IF display.message_window_displayed THEN
          close_window (clc$message_window);
        IFEND;
      ELSE
      CASEND;
      IF line_count > (dialog_box_max_lines - 2) THEN
        PUSH events: [1 .. 3];
        events^ [1] := carriage_return;
        events^ [2] := forward_event;
        events^ [3] := backward_event;
        get_function_key_message (clc$press_next_from_pageable, events, message_text, text_length);
        number_of_lines_for_box := dialog_box_max_lines;
      ELSE
        PUSH events: [1 .. 1];
        events^ [1] := carriage_return;
        get_function_key_message (clc$press_next, events, message_text, text_length);
        number_of_lines_for_box := line_count + 2;
      IFEND;
      change_menu_items (display.current_window, window_kind);
      create_window (window_kind, 1, dialog_box_top, display.screen_width, number_of_lines_for_box,
            message_text (1, text_length), '', FALSE);
      CASE window_kind OF
      = clc$help_window =
        display_status_in_box (message, number_of_lines_for_box - 2, help_window);
      = clc$message_window =
        display_status_in_box (message, number_of_lines_for_box - 2, message_window);
        message_read := FALSE;
      ELSE
      CASEND;

    PROCEND display_message_box;
?? TITLE := 'display_prompt_and_value', EJECT ??

    PROCEDURE display_prompt_and_value;

      VAR
        end_of_text: boolean,
        prompt_field_attributes: array [1 .. 2] of cst$field_attribute,
        text: ^string ( * ),
        text_length: 0 .. csc$max_character_position,
        value_field_attributes: array [1 .. 3] of cst$field_attribute;


      csp$change_io_position (parameter_display_info^ [parameter_number - display.top_parameter +
            1].prompt_field_number, 1, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      prompt_field_attributes [1].key := csc$fld_highlighting;
      prompt_field_attributes [1].highlighting_style := csc$logical_highlighting;
      prompt_field_attributes [2].key := csc$fld_logical_highlighting;
      IF (NOT parameter_information^ [parameter_number].advanced_indicator) AND
            (parameter_information^ [parameter_number].required) THEN
        prompt_field_attributes [2].logical_highlighting := csc$error;
      ELSE
        prompt_field_attributes [2].logical_highlighting := csc$logical_normal;
      IFEND;
      csp$change_field_attributes (parameter_display_info^ [parameter_number - display.top_parameter +
            1].prompt_field_number, prompt_field_attributes, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      csp$put_text (^parameter_information^ [parameter_number].prompt, TRUE, end_of_text, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      csp$change_io_position (parameter_display_info^ [parameter_number - display.top_parameter +
            1].value_field_number, 1, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      IF parameter_information^ [parameter_number].advanced_indicator OR
            parameter_information^ [parameter_number].secure THEN
        PUSH text: [0];
        parameter_information^ [parameter_number].overflow := FALSE;
      ELSE
        text_length := clp$trimmed_string_size (parameter_information^ [parameter_number].value^);
        IF text_length > parameter_value_field_width THEN
          text_length := parameter_value_field_width;
          PUSH text: [text_length];
          text^ := parameter_information^ [parameter_number].value^ (1, text_length);
          text^ (text_length - 1, 2) := clc$overflow_indicator;
          parameter_information^ [parameter_number].overflow := TRUE;
        ELSE
          PUSH text: [text_length];
          text^ := parameter_information^ [parameter_number].value^;
          parameter_information^ [parameter_number].overflow := FALSE;
        IFEND;
      IFEND;
      IF parameter_information^ [parameter_number].advanced_indicator THEN
        value_field_attributes [1].key := csc$fld_visible;
        value_field_attributes [1].visible := FALSE;
        value_field_attributes [2].key := csc$fld_logical_highlighting;
        value_field_attributes [2].logical_highlighting := csc$logical_normal;
        value_field_attributes [3].key := csc$fld_input;
        value_field_attributes [3].input := FALSE;
      ELSE
        value_field_attributes [1].key := csc$fld_visible;
        value_field_attributes [1].visible := NOT parameter_information^ [parameter_number].secure;
        value_field_attributes [2].key := csc$fld_logical_highlighting;
        value_field_attributes [3].key := csc$fld_input;
        IF parameter_information^ [parameter_number].too_big_to_edit OR
              parameter_information^ [parameter_number].overflow THEN
          value_field_attributes [2].logical_highlighting := csc$logical_normal;
          value_field_attributes [3].input := FALSE;
        ELSE
          value_field_attributes [2].logical_highlighting := csc$input;
          value_field_attributes [3].input := TRUE;
        IFEND;
      IFEND;
      csp$change_field_attributes (parameter_display_info^ [parameter_number - display.top_parameter +
            1].value_field_number, value_field_attributes, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      csp$put_text (text, TRUE, end_of_text, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

    PROCEND display_prompt_and_value;
?? TITLE := 'display_status', EJECT ??

    PROCEDURE display_status
      (    message_status: ost$status);

      VAR
        message: ost$status_message,
        message_area: ^ost$status_message,
        message_line: ^ost$status_message_line,
        message_line_count: ^ost$status_message_line_count,
        message_line_size: ^ost$status_message_line_size,
        message_text: ^string ( * );


{ Save status condition name for future HELP processing.

      osp$get_status_condition_name (message_status.condition, status_condition_name, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      osp$format_message (message_status, osc$current_message_level, message_field_width + 1, message,
            status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      message_area := ^message;
      RESET message_area;
      NEXT message_line_count IN message_area;
      IF message_line_count^ = 1 THEN
        PUSH message_text: [message_field_width];
        NEXT message_line_size IN message_area;
        NEXT message_line: [message_line_size^] IN message_area;
        message_text^ := message_line^ (2, * );
        display_message (message_text^);
      ELSE
        display_message_box (message, message_line_count^, clc$message_window);
      IFEND;

    PROCEND display_status;
?? TITLE := 'display_status_message', EJECT ??

    PROCEDURE display_status_message
      (    status_message: ost$status_message;
           window_kind: clt$window_kind);

      VAR
        message_area: ^ost$status_message,
        message_line: ^ost$status_message_line,
        message_line_count: ^ost$status_message_line_count,
        message_line_size: ^ost$status_message_line_size,
        message_text: ^string ( * );


      message_area := ^status_message;
      RESET message_area;
      NEXT message_line_count IN message_area;
      IF (message_line_count^ = 1) AND (window_kind = clc$message_window) THEN
        PUSH message_text: [message_field_width];
        NEXT message_line_size IN message_area;
        NEXT message_line: [message_line_size^] IN message_area;
        message_text^ := message_line^ (2, * );
        display_message (message_text^);
      ELSE
        display_message_box (status_message, message_line_count^, window_kind);
      IFEND;

    PROCEND display_status_message;
?? TITLE := 'display_text_in_window', EJECT ??

    PROCEDURE display_text_in_window
      (    window_kind: clt$window_kind;
           text: ^string ( * ));

      VAR
        i: integer,
        line_numbers: integer,
        text_length: 0 .. csc$max_character_position;


      CASE window_kind OF
      = clc$help_window =
        text_length := clp$trimmed_string_size (text^);
        line_numbers := (text_length DIV message_field_width) +
              $INTEGER ((text_length MOD message_field_width) <> 0);
        IF help_window.contents <> NIL THEN
          free_window_contents (help_window.contents);
        IFEND;
        ALLOCATE help_window.contents: [1 .. line_numbers];
        help_window.line_count := line_numbers;
        FOR i := 1 TO line_numbers DO
          ALLOCATE help_window.contents^ [i]: [message_field_width];
          IF (i = line_numbers) AND ((text_length MOD message_field_width) > 0) THEN
            help_window.contents^ [i]^ := text^ (((i - 1) * message_field_width + 1),
                  (text_length MOD message_field_width));
          ELSE
            help_window.contents^ [i]^ := text^ (((i - 1) * message_field_width + 1), message_field_width);
          IFEND;
        FOREND;
        update_window_display (clc$help_window);
      = clc$zoom_window =
        IF (text <> NIL) AND (text^ <> '') THEN
          text_length := clp$trimmed_string_size (text^);
          line_numbers := (text_length DIV message_field_width) +
                $INTEGER ((text_length MOD message_field_width) <> 0);
        ELSE
          line_numbers := 0;
        IFEND;
        IF zoom_window.contents <> NIL THEN
          IF line_numbers > zoom_window.line_count THEN
            free_window_contents (zoom_window.contents);
            ALLOCATE zoom_window.contents: [1 .. line_numbers];
          IFEND;
        ELSEIF line_numbers > zoom_window.lines_displayed THEN
          ALLOCATE zoom_window.contents: [1 .. line_numbers];
          zoom_window.line_count := line_numbers;
        ELSE
          ALLOCATE zoom_window.contents: [1 .. zoom_window.lines_displayed];
          zoom_window.line_count := zoom_window.lines_displayed;
        IFEND;
        FOR i := 1 TO line_numbers DO
          ALLOCATE zoom_window.contents^ [i]: [message_field_width];
          IF (i = line_numbers) AND ((text_length MOD message_field_width) > 0) THEN
            zoom_window.contents^ [i]^ := text^ (((i - 1) * message_field_width + 1),
                  (text_length MOD message_field_width));
          ELSE
            zoom_window.contents^ [i]^ := text^ (((i - 1) * message_field_width + 1), message_field_width);
          IFEND;
        FOREND;
        FOR i := line_numbers + 1 TO zoom_window.line_count DO
          zoom_window.contents^ [i] := NIL;
        FOREND;
        update_window_display (clc$zoom_window);
      ELSE
      CASEND;

    PROCEND display_text_in_window;
?? TITLE := 'find_help_module', EJECT ??

    PROCEDURE [INLINE] find_help_module;

      VAR
        ignore_natural_language: ost$natural_language,
        ignore_online_manual_name: ost$online_manual_name;

      IF display.help_module = NIL THEN
        osp$find_help_module (clc$spdm_messages_module, display.help_module, ignore_online_manual_name,
              ignore_natural_language, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
      IFEND;

    PROCEND find_help_module;
?? TITLE := 'free_window_contents', EJECT ??

    PROCEDURE free_window_contents
      (VAR window_contents: ^array [1 .. * ] of ^string ( * ));

      VAR
        i: integer;


      IF window_contents <> NIL THEN
        FOR i := 1 TO UPPERBOUND (window_contents^) DO
          IF window_contents^ [i] <> NIL THEN
            FREE window_contents^ [i];
          IFEND;
        FOREND;
        FREE window_contents;
      IFEND;

    PROCEND free_window_contents;
?? TITLE := 'get_action', EJECT ??

    PROCEDURE get_action
      (VAR got_an_action {input, output} : boolean;
       VAR action: integer);

?? NEWTITLE := 'condition_handler', EJECT ??

{
{ PURPOSE:
{   This procedure handles ifc$job_reconnect conditions during a screen
{   manager "input" request (csp$get_event).
{   It first "continues" the condition to allow the default behavior to occur.
{   It then EXITs from its establisher in order to exit from any outstanding
{   screen manager call.
{   The caller of this handler's establisher is expected to repaint the screen
{   by calling csp$clear_screen, then recall this handler's establisher.
{

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           ignore_info: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      IF handler_status.normal AND (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$job_reconnect) THEN
        EXIT get_action;
      IFEND;

    PROCEND condition_handler;
?? TITLE := 'get_mouse_action', EJECT ??

      PROCEDURE get_mouse_action;

        VAR
          button: ^clt$dialog_button,
          ignore_next_event: cst$event_identifier,
          page_attributes: array [1 .. 1] of cst$page_attribute;


{ ignore the "next" event which always follows a mouse event }

        csp$get_event (ignore_next_event, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;

        CASE event.field_event.mouse_event OF
        = 1 =
          action := mouse_click_strong;
        = 2 =
          action := mouse_click_weak;
        = help_event_from_menu, ok_event_from_menu, cancel_event_from_menu, evaluate_event_from_menu,
              reset_event_from_menu, zoom_event_from_menu, edit_zoom_event_from_menu,
              info_event_from_menu =
          action := event.field_event.mouse_event - menu_event_bias;
          RETURN;
        ELSE
          action := 0;
          RETURN;
        CASEND;

        CASE display.current_window OF
        = clc$help_window =
          button := help_window.buttons.first;
        = clc$message_window =
          button := message_window.buttons.first;
        = clc$zoom_window =
          button := zoom_window.buttons.first;
        ELSE {clc$no_window
          button := display.buttons.first;
        CASEND;

        WHILE button <> NIL DO
          IF button^.field = event.field_event_field_number THEN

            IF action = mouse_click_strong THEN
              action := button^.strong_action;
            ELSE
              action := button^.weak_action;
            IFEND;

            page_attributes [1].key := csc$mouse_reclick_request;
            page_attributes [1].mouse_reclick_request := TRUE;
            csp$change_page_attributes (page_attributes, status);
            IF NOT status.normal THEN
              EXIT clp$scl_parameter_dialog_mgr;
            IFEND;
            RETURN;

          IFEND;
          button := button^.link;
        WHILEND;

        IF action = mouse_click_strong THEN
          CASE display.current_window OF
          = clc$help_window, clc$message_window =
            action := 0;
            next_event := TRUE;
          = clc$zoom_window =
            action := mouse_click_weak {just resolves cursor} ;
          ELSE {clc$no_window
            action := zoom_event;
          CASEND;
        IFEND;

        cursor_field_number := event.field_event_field_number;
        cursor_character_position := event.field_event_character_position;
        cursor_line_number := event.field_event_line_number;

      PROCEND get_mouse_action;
?? OLDTITLE, EJECT ??

      screen_event := FALSE;
      mouse_event := FALSE;
      got_an_action := FALSE;
      action := 0;

      osp$establish_condition_handler (^condition_handler, FALSE);

    /get_event_loop/
      WHILE TRUE DO

        next_event := FALSE;
        csp$get_event (event, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;

        CASE event.event_type OF
        = csc$page_event =
          CASE event.page_event.event_type OF
          = csc$page_screen =
            screen_event := TRUE;
          = csc$page_menu_event =
            action := event.page_event.menu_item;
            ignore_following_csc$next_event := TRUE;
          = csc$page_mouse_event =
            mouse_event := TRUE;
            ignore_following_csc$next_event := TRUE;
          = csc$page_standard_function =
            IF event.page_event.standard_function = csc$next THEN
              next_event := TRUE;
              IF ignore_following_csc$next_event THEN
                ignore_following_csc$next_event := FALSE;
                CYCLE /get_event_loop/;
              IFEND;
              ignore_following_csc$next_event := FALSE;
            ELSE
              ignore_following_csc$next_event := TRUE;
            IFEND;
          ELSE
            ignore_following_csc$next_event := TRUE;
          CASEND;

        = csc$field_event =
          IF event.field_event.event_type <> csc$field_mouse_event THEN
            cursor_field_number := event.field_event_field_number;
            cursor_character_position := event.field_event_character_position;
            cursor_line_number := event.field_event_line_number;
          IFEND;

          CASE event.field_event.event_type OF
          = csc$field_screen =
            screen_event := TRUE;
          = csc$field_menu_event =
            action := event.field_event.menu_item;
            ignore_following_csc$next_event := TRUE;
          = csc$field_mouse_event =
            get_mouse_action;
            mouse_event := TRUE;
            ignore_following_csc$next_event := FALSE;
          = csc$field_standard_function =
            IF event.field_event.standard_function = csc$next THEN
              next_event := TRUE;
              IF ignore_following_csc$next_event THEN
                ignore_following_csc$next_event := FALSE;
                CYCLE /get_event_loop/;
              IFEND;
              ignore_following_csc$next_event := FALSE;
            ELSE
              ignore_following_csc$next_event := TRUE;
            IFEND;
          ELSE
            ignore_following_csc$next_event := TRUE;
          CASEND;

        ELSE
        CASEND;

        got_an_action := TRUE;
        RETURN;

      WHILEND /get_event_loop/;

    PROCEND get_action;
?? TITLE := 'get_cursor_input_field', EJECT ??

    PROCEDURE get_cursor_input_field
      (VAR input_field: boolean;
       VAR command_field: boolean;
       VAR parameter_value: boolean;
       VAR line_number: 0 .. csc$max_line_number);

      input_field := FALSE;
      command_field := FALSE;
      parameter_value := FALSE;
      IF cursor_field_number = display.command_field THEN
        command_field := TRUE;
        input_field := TRUE;
      ELSE
        CASE display.current_window OF
        = clc$zoom_window =
          IF cursor_field_number = zoom_window.text_field THEN
            parameter_value := TRUE;
            line_number := cursor_line_number;
            input_field := zoom_window.changeable;
          IFEND;
        = clc$no_window =
          FOR parameter_line := 1 TO display.parameters_displayed DO
            IF event.field_event_field_number = parameter_display_info^ [parameter_line].
                  value_field_number THEN
              parameter_number := display.top_parameter + parameter_line - 1;
              parameter_value := TRUE;
              input_field := NOT parameter_information^ [parameter_number].too_big_to_edit;
              RETURN;
            IFEND;
          FOREND;
        ELSE
        CASEND;
      IFEND;

    PROCEND get_cursor_input_field;
?? TITLE := 'get_event_parameter', EJECT ??

    PROCEDURE get_event_parameter;


      CASE event.event_type OF
      = csc$page_event =
        parameter_line := event.page_event_y_position - start_of_parameter_lines + 1;
        IF (parameter_line > 0) AND (parameter_line <= display.parameters_displayed) THEN
          parameter_number := display.top_parameter + parameter_line - 1;
          event_on_parameter_line := TRUE;
          parameter_selected := NOT parameter_information^ [parameter_number].advanced_indicator;
          RETURN;
        IFEND;

      = csc$field_event =
        FOR parameter_line := 1 TO display.parameters_displayed DO
          IF (event.field_event_field_number = parameter_display_info^ [parameter_line].
                prompt_field_number) OR (event.field_event_field_number =
                parameter_display_info^ [parameter_line].value_field_number) THEN
            parameter_number := display.top_parameter + parameter_line - 1;
            event_on_parameter_line := TRUE;
            parameter_selected := NOT parameter_information^ [parameter_number].advanced_indicator;
            RETURN;
          IFEND;
        FOREND;

      ELSE
      CASEND;

      event_on_parameter_line := FALSE;
      parameter_selected := FALSE;

    PROCEND get_event_parameter;
?? TITLE := 'get_function_key_message', EJECT ??

    PROCEDURE get_function_key_message
      (    message_name: clt$parameter_name;
           events: ^array [1 .. * ] of carriage_return .. down_event;
       VAR message_text: string ( * <= csc$max_x_position);
       VAR text_length: 0 .. csc$max_x_position);

?? NEWTITLE := 'create_message_parameter', EJECT ??

      PROCEDURE [INLINE] create_message_parameter
        (    event: carriage_return .. down_event);

        VAR
          event_name_identifier: cst$event_name_identifier;

        IF event = carriage_return THEN
          event_name_identifier.event_type := csc$field_event;
          event_name_identifier.field_event.event_type := csc$field_standard_function;
          event_name_identifier.field_event.standard_function := csc$next;
        ELSE
          event_name_identifier.event_type := csc$page_event;
          CASE menu_list_copy^ [event].menu_type OF
          = csc$application_function =
            event_name_identifier.page_event.event_type := csc$page_application_function;
            event_name_identifier.page_event.application_function :=
                  menu_list_copy^ [event].application_function;
          = csc$standard_function =
            event_name_identifier.page_event.event_type := csc$page_standard_function;
            event_name_identifier.page_event.standard_function := menu_list_copy^ [event].standard_function;
          ELSE
          CASEND;
        IFEND;
        csp$get_event_name (event_name_identifier, name, name_length, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;

      PROCEND create_message_parameter;
?? OLDTITLE, EJECT ??

      VAR
        i: integer,
        message: ost$status_message,
        message_area: ^ost$status_message,
        message_line: ^ost$status_message_line,
        message_line_count: ^ost$status_message_line_count,
        message_line_size: ^ost$status_message_line_size,
        message_parameters: ^array [1 .. * ] of ^ost$message_parameter,
        message_template: ^ost$message_template,
        name: ost$name,
        name_length: 0 .. osc$max_name_size;


      find_help_module;
      osp$find_param_assist_prompt (display.help_module, message_name, message_template, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      IF events <> NIL THEN
        PUSH message_parameters: [1 .. #SIZE (events^)];
        FOR i := 1 TO #SIZE (events^) DO
          create_message_parameter (events^ [i]);
          PUSH message_parameters^ [i]: [name_length];
          message_parameters^ [i]^ := name (1, name_length);
        FOREND;
      ELSE
        message_parameters := NIL;
      IFEND;

      osp$format_help_message (message_template, message_parameters, message_field_width, message, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      message_area := ^message;
      RESET message_area;
      NEXT message_line_count IN message_area;
      IF message_line_count^ = 1 THEN
        NEXT message_line_size IN message_area;
        NEXT message_line: [message_line_size^] IN message_area;
        text_length := message_line_size^;
        message_text := message_line^;
      ELSE
        text_length := 0;
        message_text := '';
      IFEND;

    PROCEND get_function_key_message;
?? TITLE := 'get_function_key_label', EJECT ??

    PROCEDURE [INLINE] get_function_key_label
      (    message_name: clt$parameter_name;
       VAR key_label: string (6));

      VAR
        message_template: ^ost$message_template;

      find_help_module;
      osp$find_param_assist_prompt (display.help_module, message_name, message_template, status);
      IF message_template <> NIL THEN
        key_label := message_template^ (1, clp$trimmed_string_size (message_template^));
      ELSE
        key_label := '';
      IFEND;

    PROCEND get_function_key_label;
?? TITLE := 'get_message', EJECT ??

    PROCEDURE get_message
      (    message_name: clt$parameter_name;
           message_parameters: ^array [1 .. * ] of ^ost$message_parameter;
       VAR message: ost$status_message);

      VAR
        message_template: ^ost$message_template;

      find_help_module;
      osp$find_param_assist_prompt (display.help_module, message_name, message_template, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      osp$format_help_message (message_template, message_parameters, message_field_width, message, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

    PROCEND get_message;
?? TITLE := 'get_message_text', EJECT ??

    PROCEDURE get_message_text
      (    message_name: clt$parameter_name;
           message_parameters: ^array [1 .. * ] of ^ost$message_parameter;
       VAR message_text: string ( * <= csc$max_x_position);
       VAR text_length: 0 .. csc$max_x_position);


      VAR
        max_line: 0 .. csc$max_y_position,
        message: ost$status_message,
        message_area: ^ost$status_message,
        message_line: ^ost$status_message_line,
        message_line_count: ^ost$status_message_line_count,
        message_line_size: ^ost$status_message_line_size,
        message_template: ^ost$message_template;

      find_help_module;
      osp$find_param_assist_prompt (display.help_module, message_name, message_template, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      IF message_field_width <> 0 THEN
        max_line := message_field_width;
      ELSE
        max_line := clc$prompt_object_width;
      IFEND;
      osp$format_help_message (message_template, message_parameters, max_line, message, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      message_area := ^message;
      RESET message_area;
      NEXT message_line_count IN message_area;
      IF message_line_count^ = 1 THEN
        NEXT message_line_size IN message_area;
        NEXT message_line: [message_line_size^] IN message_area;
        text_length := message_line_size^;
        message_text := message_line^;
      ELSE
        text_length := 0;
        message_text := '';
      IFEND;

    PROCEND get_message_text;
?? TITLE := 'get_screen_parameter_value', EJECT ??

    PROCEDURE get_screen_parameter_value
      (    field_number: cst$field_number);

      VAR
        end_of_line: boolean,
        end_of_text: boolean,
        found: boolean,
        i: clt$parameter_count,
        text: string (csc$max_x_position),
        text_length: cst$data_string_length;


      found := FALSE;

    /get_parameter_number/
      FOR i := 1 TO display.parameters_displayed DO
        IF field_number = parameter_display_info^ [i].value_field_number THEN
          parameter_number := display.top_parameter + i - 1;
          found := TRUE;
          EXIT /get_parameter_number/;
        IFEND;
      FOREND /get_parameter_number/;
      IF found THEN
        IF parameter_information^ [parameter_number].secure THEN
          update_parameters := TRUE;
        IFEND;
        csp$get_text (text, text_length, end_of_line, end_of_text, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        IF NOT end_of_text THEN
          IF parameter_information^ [parameter_number].value^ <> text (1, text_length) THEN
            IF text (1, text_length) = '' THEN
              update_parameters := TRUE;
              ignore_cleared_parameter (parameter_information^ [parameter_number].name);
              RETURN;
            ELSE
              parameter_information^ [parameter_number].evaluation_required := TRUE;
            IFEND;
          IFEND;
          IF (NOT parameter_information^ [parameter_number].overflow) OR
                (text_length < parameter_value_field_width) OR (text
                (text_length - 1, STRLENGTH (clc$overflow_indicator)) <> clc$overflow_indicator) THEN
            FREE parameter_information^ [parameter_number].value;
            ALLOCATE parameter_information^ [parameter_number].value: [text_length];
            parameter_information^ [parameter_number].value^ := text (1, text_length);
            parameter_information^ [parameter_number].overflow := FALSE;
          ELSE
            parameter_information^ [parameter_number].value^ (1, text_length -
                  STRLENGTH (clc$overflow_indicator)) := text (1, text_length -
                  STRLENGTH (clc$overflow_indicator));
          IFEND;
        IFEND;
      IFEND;

    PROCEND get_screen_parameter_value;
?? TITLE := 'get_screen_values', EJECT ??

    PROCEDURE get_screen_values
      (    defer_command_line_processing: boolean);

      VAR
        end_of_line: boolean,
        end_of_text: boolean,
        field_number: cst$field_number,
        line_number: cst$line_number,
        text: string (csc$max_x_position),
        text_length: cst$data_string_length;


      end_of_text := FALSE;
      WHILE NOT end_of_text DO
        csp$get_io_position (field_number, line_number, end_of_text, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        IF NOT end_of_text THEN
          IF field_number = display.command_field THEN
            process_command_line (defer_command_line_processing);
          ELSEIF display.zoom_window_displayed THEN
            IF field_number = zoom_window.text_field THEN
              process_zoom_input (line_number + zoom_window.top - 1);
            ELSE

{ Ignore text in 'inactive' fields.

              csp$get_text (text, text_length, end_of_line, end_of_text, status);
              IF NOT status.normal THEN
                EXIT clp$scl_parameter_dialog_mgr;
              IFEND;
              update_parameters := TRUE;
            IFEND;
          ELSEIF display.help_window_displayed OR display.message_window_displayed THEN

{ Ignore text in 'inactive' fields.

            csp$get_text (text, text_length, end_of_line, end_of_text, status);
            IF NOT status.normal THEN
              EXIT clp$scl_parameter_dialog_mgr;
            IFEND;
            update_parameters := TRUE;
          ELSE
            get_screen_parameter_value (field_number);
          IFEND;
        IFEND;
      WHILEND;

    PROCEND get_screen_values;
?? TITLE := 'ignore_cleared_parameter', EJECT ??

    PROCEDURE ignore_cleared_parameter
      (    parameter_name: string (clc$prompt_object_width));

      VAR
        hold_parameter_names: ^array [1 .. * ] of ^ost$message_parameter,
        i: clt$parameter_count,
        old_count: clt$parameter_count;


      IF cleared_parameters = NIL THEN
        ALLOCATE cleared_parameters: [1 .. 1];
        ALLOCATE cleared_parameters^ [1]: [clp$trimmed_string_size (parameter_name)];
        cleared_parameters^ [1]^ := parameter_name;
      ELSE
        old_count := UPPERBOUND (cleared_parameters^);
        PUSH hold_parameter_names: [1 .. old_count];
        FOR i := 1 TO old_count DO
          hold_parameter_names^ [i] := cleared_parameters^ [i];
        FOREND;
        FREE cleared_parameters;
        ALLOCATE cleared_parameters: [1 .. old_count + 1];
        FOR i := 1 TO old_count DO
          cleared_parameters^ [i] := hold_parameter_names^ [i];
        FOREND;
        ALLOCATE cleared_parameters^ [old_count + 1]: [clp$trimmed_string_size (parameter_name)];
        cleared_parameters^ [old_count + 1]^ := parameter_name;
      IFEND;

    PROCEND ignore_cleared_parameter;
?? TITLE := 'initialize_buttons', EJECT ??

    PROCEDURE [INLINE] initialize_buttons
      (VAR buttons: clt$dialog_buttons);

      VAR
        event_name_identifier: cst$event_name_identifier;


      buttons.first := ^buttons.page_up_button;
      event_name_identifier.event_type := csc$field_event;
      event_name_identifier.field_event.event_type := csc$field_standard_function;
      event_name_identifier.field_event.standard_function := csc$backward;

      buttons.page_up_button.link := ^buttons.page_down_button;
      csp$get_event_name (event_name_identifier, buttons.page_up_button.name,
            buttons.page_up_button.name_size, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      buttons.page_up_button.strong_action := backward_event;
      buttons.page_up_button.weak_action := down_event;
      buttons.page_up_button.active := FALSE;
      buttons.page_up_button.field := 0;

      event_name_identifier.field_event.standard_function := csc$forward;
      buttons.page_down_button.link := NIL;
      csp$get_event_name (event_name_identifier, buttons.page_down_button.name,
            buttons.page_down_button.name_size, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      buttons.page_down_button.strong_action := forward_event;
      buttons.page_down_button.weak_action := up_event;
      buttons.page_down_button.active := FALSE;
      buttons.page_down_button.field := 0;

    PROCEND initialize_buttons;
?? TITLE := 'initialize_background_field', EJECT ??

    PROCEDURE initialize_background_field
      (    x_position: 0 .. csc$max_x_position;
           y_position: 0 .. csc$max_line_number;
           width: 0 .. csc$max_x_position;
           height: 0 .. csc$max_line_number;
       VAR field_number: cst$field_number);

      VAR
        background_field: clt$field_attributes;


      background_field := clv$default_field_attributes;
      background_field [x_position_attribute].x_position := x_position;
      background_field [y_position_attribute].y_position := y_position;
      background_field [visible_characters_attribute].visible_characters := width;
      background_field [visible_lines_attribute].visible_lines := height;
      background_field [characters_attribute].characters :=
            background_field [visible_characters_attribute].visible_characters;
      background_field [lines_attribute].lines := background_field [visible_lines_attribute].visible_lines;
      csp$allocate_field (background_field, field_number, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

    PROCEND initialize_background_field;
?? TITLE := 'initialize_command_field', EJECT ??

    PROCEDURE initialize_command_field;

      VAR
        background_field_number: cst$field_number,
        command_field: clt$field_attributes,
        command_field_background: clt$field_attributes;


      command_field := clv$default_field_attributes;
      command_field [x_position_attribute].x_position := 1;
      command_field [y_position_attribute].y_position := command_line_number;
      command_field [visible_characters_attribute].visible_characters := display.screen_width - 1;
      command_field [characters_attribute].characters := command_field [visible_characters_attribute].
            visible_characters;
      command_field [input_attribute].input := TRUE;
      command_field [logical_highlighting_attribute].logical_highlighting := csc$logical_normal;
      csp$allocate_field (command_field, display.command_field, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      command_field_background := clv$default_field_attributes;
      command_field_background [x_position_attribute].x_position := display.screen_width;
      command_field_background [y_position_attribute].y_position := command_line_number;
      command_field_background [visible_characters_attribute].visible_characters := 1;
      command_field_background [characters_attribute].characters :=
            command_field_background [visible_characters_attribute].visible_characters;
      command_field_background [input_attribute].input := FALSE;
      command_field_background [logical_highlighting_attribute].logical_highlighting := csc$logical_normal;
      csp$allocate_field (command_field_background, background_field_number, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

    PROCEND initialize_command_field;
?? TITLE := 'initialize_function_key_menu', EJECT ??

    PROCEDURE initialize_function_key_menu
      (    rows_for_menu: cst$number_of_menu_rows);

      VAR
        i: integer;


      find_help_module;
      osp$find_application_menu (display.help_module, clc$spdm_main_menu, menu_classes, menu_list, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      IF (menu_classes = NIL) OR (menu_list = NIL) THEN

{ This should only happen if the help module CLM$SPDM_MESSAGES$US_ENGLISH was not installed.

        cancel := TRUE;
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      ALLOCATE menu_classes_copy: [1 .. UPPERBOUND (menu_classes^)];
      FOR i := 1 TO UPPERBOUND (menu_classes^) DO
        menu_classes_copy^ [i] := menu_classes^ [i];
      FOREND;
      ALLOCATE menu_list_copy: [1 .. UPPERBOUND (menu_list^)];
      FOR i := 1 TO UPPERBOUND (menu_list^) DO
        menu_list_copy^ [i] := menu_list^ [i];
        CASE i OF
        = reset_event, zoom_event, edit_zoom_event =
          menu_list_copy^ [i].item_assigned := TRUE;
        ELSE
          menu_list_copy^ [i].item_assigned := FALSE;
        CASEND;
      FOREND;
      csp$set_standard_menu (menu_classes_copy, menu_list_copy, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      IF support.nested_dialog_title <> NIL THEN
        csp$disable_menu_item (info_event, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
      IFEND;

      csp$display_menu (rows_for_menu, 0, display.reserved_rows, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

    PROCEND initialize_function_key_menu;
?? TITLE := 'initialize_message_field', EJECT ??

    PROCEDURE initialize_message_field;

      VAR
        background_field_number: cst$field_number,
        message_field: clt$field_attributes,
        message_field_background: clt$field_attributes;


      message_field_background := clv$default_field_attributes;
      message_field_background [x_position_attribute].x_position := 1;
      message_field_background [y_position_attribute].y_position := message_line_number;
      message_field_background [visible_characters_attribute].visible_characters := display.screen_width;
      message_field_background [characters_attribute].characters :=
            message_field_background [visible_characters_attribute].visible_characters;
      message_field_background [logical_highlighting_attribute].logical_highlighting := csc$message;
      csp$allocate_field (message_field_background, background_field_number, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      message_field := clv$default_field_attributes;
      message_field [x_position_attribute].x_position := 2;
      message_field [y_position_attribute].y_position := message_line_number;
      message_field [visible_characters_attribute].visible_characters := message_field_width;
      message_field [characters_attribute].characters := message_field [visible_characters_attribute].
            visible_characters;
      message_field [logical_highlighting_attribute].logical_highlighting := csc$message;
      csp$allocate_field (message_field, display.message_field, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

    PROCEND initialize_message_field;
?? TITLE := 'initialize_prompt_and_value', EJECT ??

    PROCEDURE initialize_prompt_and_value
      (    pdt_number: clt$parameter_count);

      VAR
        message: ^ost$status_message,
        parameter_value: clt$parameter_value,
        representation: ^clt$data_representation,
        representation_count: ^clt$data_representation_count,
        text: ^string ( * ),
        text_length: cst$data_string_length;


      support.get_parameter_prompt^ (pdt_number, osc$max_status_message_line, message, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      text := osp$status_message_text (message);
      parameter_information^ [parameter_number].name := text^;
      IF STRLENGTH (text^) > clc$prompt_object_width THEN
        parameter_information^ [parameter_number].prompt := parameter_information^ [parameter_number].
              name (1, clc$prompt_object_width);
      ELSE
        parameter_information^ [parameter_number].prompt := parameter_information^ [parameter_number].name;
        clp$right_justify_string (parameter_information^ [parameter_number].prompt);
      IFEND;

      support.get_parameter_value^ (pdt_number, parameter_value, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      IF parameter_value.specified THEN
        support.get_parameter_value_source^ (pdt_number, clc$max_string_size, representation, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        parameter_information^ [parameter_number].initialized := TRUE;
        parameter_information^ [parameter_number].evaluation_required := FALSE;
        RESET representation;
        NEXT representation_count IN representation;
        text := clp$data_representation_text (representation);
        text_length := clp$trimmed_string_size (text^);
        ALLOCATE parameter_information^ [parameter_number].value: [text_length];
        parameter_information^ [parameter_number].value^ := text^ (1, text_length);
        parameter_information^ [parameter_number].too_big_to_edit := (representation_count^ > 1);
      ELSE
        CASE pdt.parameters^ [pdt_number].requirement OF
        = clc$optional_default_parameter, clc$confirm_default_parameter =
          support.get_parameter_default^ (pdt_number, text, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        ELSE {clc$required_parameter, clc$optional_parameter}
          PUSH text: [0];
        CASEND;
        parameter_information^ [parameter_number].initialized := TRUE;
        parameter_information^ [parameter_number].evaluation_required := FALSE;
        parameter_information^ [parameter_number].too_big_to_edit := FALSE;
        text_length := clp$trimmed_string_size (text^);
        ALLOCATE parameter_information^ [parameter_number].value: [text_length];
        parameter_information^ [parameter_number].value^ := text^ (1, text_length);
      IFEND;
      parameter_information^ [parameter_number].overflow := FALSE;

    PROCEND initialize_prompt_and_value;
?? TITLE := 'initialize_title_box', EJECT ??

    PROCEDURE initialize_title_box;

      VAR
        box_coordinates: array [1 .. 5] of cst$xy_coordinate,
        box_graphic_id: cst$graphic_identifier,
        box_prompt_field: clt$field_attributes,
        box_prompt_field_number: cst$field_number,
        corner_coordinates: array [1 .. 4] of cst$xy_coordinate,
        end_of_text: boolean,
        graphic_identifier: cst$graphic_identifier,
        intersection_types: array [1 .. 4] of cst$intersection_type,
        line_coordinates: array [1 .. 2] of cst$xy_coordinate,
        line_number_field: clt$field_attributes,
        message_parameters: array [1 .. 1] of ^ost$message_parameter,
        message_text: string (csc$max_x_position),
        name: clt$command_name,
        names: ^array [1 .. * ] of clt$command_name,
        text_length: 0 .. csc$max_x_position,
        title_field: clt$field_attributes,
        title_field_number: cst$field_number;


      csp$change_line_width (csc$fine, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      IF NOT called_from_screen_mode THEN
        { Draw line at top of display.
        line_coordinates [1].x := 1;
        line_coordinates [1].y := title_box_top;
        line_coordinates [2].x := display.screen_width;
        line_coordinates [2].y := title_box_top;
        csp$poly_hv_line (line_coordinates, graphic_identifier, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
      ELSE
        IF display.parameter_count > 0 THEN
          get_function_key_message (clc$enter_values, NIL, message_text, text_length);
        ELSE
          get_function_key_message (clc$press_ok, NIL, message_text, text_length);
        IFEND;
        box_coordinates [1].x := 1;
        box_coordinates [1].y := title_box_top;
        box_coordinates [2].x := display.screen_width;
        box_coordinates [2].y := box_coordinates [1].y;
        box_coordinates [3].x := box_coordinates [2].x;
        box_coordinates [3].y := box_coordinates [1].y + display.screen_height - title_box_top + 1;
        box_coordinates [4].x := box_coordinates [1].x;
        box_coordinates [4].y := box_coordinates [3].y;
        box_coordinates [5] := box_coordinates [1];
        csp$poly_hv_line (box_coordinates, box_graphic_id, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;

        intersection_types [1] := csc$upper_left;
        intersection_types [2] := csc$upper_right;
        intersection_types [3] := csc$lower_right;
        intersection_types [4] := csc$lower_left;
        corner_coordinates [1].x := box_coordinates [1].x;
        corner_coordinates [1].y := box_coordinates [1].y;
        corner_coordinates [2].x := box_coordinates [2].x;
        corner_coordinates [2].y := box_coordinates [2].y;
        corner_coordinates [3].x := box_coordinates [3].x;
        corner_coordinates [3].y := box_coordinates [3].y;
        corner_coordinates [4].x := box_coordinates [4].x;
        corner_coordinates [4].y := box_coordinates [4].y;
        csp$poly_intersect (box_graphic_id, corner_coordinates, intersection_types, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        box_prompt_field := clv$default_field_attributes;
        box_prompt_field [x_position_attribute].x_position :=
              ((display.screen_width - text_length) DIV 2) + 1;
        box_prompt_field [y_position_attribute].y_position := box_coordinates [3].y;
        box_prompt_field [visible_characters_attribute].visible_characters := text_length;
        box_prompt_field [characters_attribute].characters := box_prompt_field [3].visible_characters;
        box_prompt_field [logical_highlighting_attribute].logical_highlighting := csc$italic;
        csp$allocate_field (box_prompt_field, box_prompt_field_number, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        csp$change_io_position (box_prompt_field_number, 1, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        end_of_text := FALSE;
        csp$put_text (^message_text (1, text_length), TRUE, end_of_text, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
      IFEND;

      IF support.nested_dialog_title <> NIL THEN
        message_text (1) := ' ';
        message_text (2, * ) := support.nested_dialog_title^;
        text_length := clp$trimmed_string_size (support.nested_dialog_title^) + 2;
        IF text_length > STRLENGTH (message_text) THEN
          text_length := STRLENGTH (message_text);
        IFEND;
      ELSE
        support.get_all_names^ (names, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        name := names^ [1];
        convert_name_to_message_param (name);
        message_parameters [1] := ^name;
        IF pdt.header^.command_or_function = clc$function THEN
          get_message_text (clc$function_label, ^message_parameters, message_text, text_length);
        ELSE
          get_message_text (clc$command_label, ^message_parameters, message_text, text_length);
        IFEND;
      IFEND;

      title_field := clv$default_field_attributes;
      title_field [x_position_attribute].x_position := clc$title_line_number_inset + 1;
      title_field [y_position_attribute].y_position := title_box_top;
      title_field [visible_characters_attribute].visible_characters := text_length;
      title_field [characters_attribute].characters := title_field [visible_characters_attribute].
            visible_characters;
      csp$allocate_field (title_field, title_field_number, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      csp$change_io_position (title_field_number, 1, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      end_of_text := FALSE;
      csp$put_text (^message_text (1, text_length), TRUE, end_of_text, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      line_number_field := clv$default_field_attributes;
      line_number_field [x_position_attribute].x_position :=
            display.screen_width - clc$title_line_number_inset;
      line_number_field [y_position_attribute].y_position := title_box_top;
      line_number_field [visible_characters_attribute].visible_characters := 1;
      line_number_field [characters_attribute].characters := display.screen_width;
      csp$allocate_field (line_number_field, display.line_number_field, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      initialize_buttons (display.buttons);

    PROCEND initialize_title_box;
?? TITLE := 'process_backward_event', EJECT ??

    PROCEDURE process_backward_event;

      VAR
        new_top: clt$parameter_count;


      CASE display.current_window OF
      = clc$help_window =
        IF help_window.lines_displayed <> 0 THEN
          IF help_window.top - help_window.lines_displayed < 1 THEN
            new_top := 1;
          ELSE
            new_top := help_window.top - help_window.lines_displayed + 1;
          IFEND;
          cursor_field_number := help_window.text_field;
          cursor_line_number := (help_window.lines_displayed + 1) DIV 2;
          IF new_top <> help_window.top THEN
            help_window.top := new_top;
            update_window_display (clc$help_window);
          IFEND;
        IFEND;
      = clc$message_window =
        IF message_window.lines_displayed <> 0 THEN
          IF message_window.top - message_window.lines_displayed < 1 THEN
            new_top := 1;
          ELSE
            new_top := message_window.top - message_window.lines_displayed + 1;
          IFEND;
          cursor_field_number := message_window.text_field;
          cursor_line_number := (message_window.lines_displayed + 1) DIV 2;
          IF new_top <> message_window.top THEN
            message_window.top := new_top;
            update_window_display (clc$message_window);
          IFEND;
        IFEND;
      = clc$zoom_window =
        IF zoom_window.lines_displayed <> 0 THEN
          IF zoom_window.top <= zoom_window.lines_displayed THEN
            new_top := 1;
          ELSE
            new_top := zoom_window.top - zoom_window.lines_displayed + 1;
          IFEND;
          cursor_field_number := zoom_window.text_field;
          cursor_line_number := (zoom_window.lines_displayed + 1) DIV 2;
          zoom_window.top := new_top;
          update_window_display (clc$zoom_window);
        IFEND;
      ELSE {clc$no_window
        IF display.parameters_displayed <> 0 THEN
          IF display.top_parameter <= display.parameters_displayed THEN
            new_top := 1;
          ELSE
            new_top := display.top_parameter - display.parameters_displayed + 1;
          IFEND;
          cursor_field_number := parameter_display_info^ [(display.parameters_displayed + 1) DIV
                2].value_field_number;
          cursor_line_number := 1;
          IF new_top <> display.top_parameter THEN
            display.top_parameter := new_top;
            update_parameters := TRUE;
          IFEND;
        IFEND;
      CASEND;

    PROCEND process_backward_event;
?? TITLE := 'process_cancel_event', EJECT ??

    PROCEDURE process_cancel_event;

      CASE display.current_window OF
      = clc$help_window, clc$message_window =
        { The CANCEL event is undefined for help and message windows.
      = clc$zoom_window =
        change_menu_items (clc$zoom_window, zoom_window.parent_window);
        close_window (clc$zoom_window);
      ELSE {clc$no_window
        processing_complete := TRUE;
        cancel := TRUE;
      CASEND;

    PROCEND process_cancel_event;
?? TITLE := 'process_clear_eol_event', EJECT ??

    PROCEDURE process_clear_eol_event;

      VAR
        command_field: boolean,
        ignore_parameter_value: boolean,
        input_field: boolean,
        line_number: 0 .. csc$max_line_number;

?? NEWTITLE := 'clear_eol', EJECT ??

      PROCEDURE clear_eol
        (VAR field_text: ^string ( * ));

        VAR
          text: ^string ( * ),
          text_length: 0 .. csc$max_character_position;


        text_length := clp$trimmed_string_size (field_text^);
        IF display.current_window = clc$zoom_window THEN
          parameter_number := zoom_window.parameter_number;
        IFEND;
        IF (text_length > 0) AND (cursor_character_position <= text_length) THEN
          text_length := cursor_character_position - 1;
          PUSH text: [text_length];
          IF cursor_character_position > 1 THEN
            text^ := field_text^ (1, text_length);
          IFEND;
          IF text^ <> '' THEN
            FREE field_text;
            ALLOCATE field_text: [text_length];
            field_text^ := text^;
            parameter_information^ [parameter_number].evaluation_required := TRUE;
            update_parameters := TRUE;
          ELSE
            update_parameters := TRUE;
            ignore_cleared_parameter (parameter_information^ [parameter_number].name);
          IFEND;
        IFEND;

      PROCEND clear_eol;
?? OLDTITLE, EJECT ??

      get_cursor_input_field (input_field, command_field, ignore_parameter_value, line_number);
      IF input_field THEN
        IF command_field THEN
          IF display.command_text <> NIL THEN
            clear_eol (display.command_text);
          IFEND;
        ELSE
          CASE display.current_window OF
          = clc$zoom_window =
            IF zoom_window.contents^ [line_number + zoom_window.top - 1] <> NIL THEN
              clear_eol (zoom_window.contents^ [line_number + zoom_window.top - 1]);
              update_window_display (clc$zoom_window);
            IFEND;
          = clc$no_window =
            IF (parameter_information^ [parameter_number].value <> NIL) AND
                  (NOT (parameter_information^ [parameter_number].
                  too_big_to_edit OR parameter_information^ [parameter_number].overflow)) THEN
              clear_eol (parameter_information^ [parameter_number].value);
            IFEND;
          ELSE
          CASEND;
        IFEND;
      IFEND;

    PROCEND process_clear_eol_event;
?? TITLE := 'process_clear_event', EJECT ??

    PROCEDURE process_clear_event;


      csp$clear_screen (status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

    PROCEND process_clear_event;
?? TITLE := 'process_command', EJECT ??

    PROCEDURE process_command
      (    command_text: string ( * ));

      VAR
        include_status: ost$status;


      IF #RING (^include_status) < avp$ring_min () THEN
        osp$set_status_condition (cle$param_dialog_not_privileged, include_status);
        display_status (include_status);
        RETURN;
      IFEND;

      clp$push_interactive_input (status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      IF called_from_screen_mode THEN
        csp$disable_page (status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
      IFEND;

      clp$include_command (command_text, {enable_echoing=} TRUE, include_status);
      IF called_from_screen_mode THEN
        csp$enable_page (status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
      IFEND;

      clp$pop_interactive_input (status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      ignore_tab_caused_by_next := TRUE;
      IF NOT include_status.normal THEN
        display_status (include_status);
      ELSE
        clear_command_field;
      IFEND;

    PROCEND process_command;
?? TITLE := 'process_command_line', EJECT ??

    PROCEDURE process_command_line
      (    defer_command_line_processing: boolean);

      VAR
        command_text: string (csc$max_x_position),
        command_text_length: cst$data_string_length,
        end_of_text: boolean;


      need_to_clear_command_field := FALSE;
      csp$get_text (command_text, command_text_length, end_of_line, end_of_text, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      IF (command_text_length > 0) AND (command_text (1, command_text_length) <> ' ') THEN
        IF display.command_text <> NIL THEN
          FREE display.command_text;
        IFEND;
        ALLOCATE display.command_text: [command_text_length];
        display.command_text^ := command_text;
        IF NOT defer_command_line_processing THEN
          IF (command_text_length >= 2) AND (command_text (command_text_length - 1,
                STRLENGTH (clc$overflow_indicator)) = clc$overflow_indicator) THEN
            zoom_command_line;
            display_text_in_window (clc$zoom_window, ^command_text (1, command_text_length));
            RETURN;
          IFEND;
          process_command (command_text (1, command_text_length));
        IFEND;
      IFEND;

    PROCEND process_command_line;
?? TITLE := 'process_delete_char_event', EJECT ??

    PROCEDURE process_delete_char_event;

      VAR
        command_field: boolean,
        ignore_parameter_value: boolean,
        input_field: boolean,
        line_number: 0 .. csc$max_line_number;

?? NEWTITLE := 'delete_char', EJECT ??

      PROCEDURE delete_char
        (VAR field_text: ^string ( * ));

        VAR
          text: ^string ( * ),
          text_length: 0 .. csc$max_character_position;


        text_length := clp$trimmed_string_size (field_text^);
        IF (text_length > 0) AND (cursor_character_position <= text_length) THEN
          text_length := text_length - 1;
          PUSH text: [text_length];
          IF text_length > 0 THEN
            text^ := field_text^ (1, cursor_character_position - 1);
            IF text_length >= cursor_character_position THEN
              text^ (cursor_character_position, text_length - cursor_character_position + 1) :=
                    field_text^ (cursor_character_position + 1, text_length - cursor_character_position + 1);
            IFEND;
          IFEND;
          IF text^ <> '' THEN
            FREE field_text;
            ALLOCATE field_text: [text_length];
            field_text^ := text^;
            parameter_information^ [parameter_number].evaluation_required := TRUE;
          ELSE
            ignore_cleared_parameter (parameter_information^ [parameter_number].name);
          IFEND;
          update_parameters := TRUE;
        IFEND;

      PROCEND delete_char;
?? OLDTITLE, EJECT ??

      get_cursor_input_field (input_field, command_field, ignore_parameter_value, line_number);
      IF input_field THEN
        IF command_field THEN
          IF display.command_text <> NIL THEN
            delete_char (display.command_text);
          IFEND;
        ELSE
          CASE display.current_window OF
          = clc$zoom_window =
            IF zoom_window.contents^ [line_number + zoom_window.top - 1] <> NIL THEN
              delete_char (zoom_window.contents^ [line_number + zoom_window.top - 1]);
              update_window_display (clc$zoom_window);
            IFEND;
          = clc$no_window =
            IF (parameter_information^ [parameter_number].value <> NIL) AND
                  (NOT (parameter_information^ [parameter_number].
                  too_big_to_edit OR parameter_information^ [parameter_number].overflow)) THEN
              delete_char (parameter_information^ [parameter_number].value);
            IFEND;
          ELSE
          CASEND;
        IFEND;
      IFEND;

    PROCEND process_delete_char_event;
?? TITLE := 'process_down_event', EJECT ??

    PROCEDURE process_down_event;

      VAR
        message_text: string (csc$max_x_position),
        new_top_parameter: clt$parameter_count,
        text_length: 0 .. csc$max_x_position;


      get_event_parameter;
      IF NOT event_on_parameter_line THEN
        get_message_text (clc$press_down, NIL, message_text, text_length);
        display_message (message_text (1, text_length));
        RETURN;
      IFEND;

      IF parameter_number < display.parameters_displayed THEN
        new_top_parameter := 1;
      ELSE
        new_top_parameter := parameter_number - display.parameters_displayed + 1;
      IFEND;

      cursor_field_number := parameter_display_info^ [(display.parameters_displayed + 1) DIV
            2].value_field_number;
      cursor_line_number := 1;
      cursor_character_position := 1;
      IF new_top_parameter <> display.top_parameter THEN
        display.top_parameter := new_top_parameter;
        update_parameters := TRUE;
      IFEND;

    PROCEND process_down_event;
?? TITLE := 'process_evaluate_event', EJECT ??

    PROCEDURE process_evaluate_event;

      VAR
        evaluate_status: ost$status;

?? NEWTITLE := 'evaluate_parameter', EJECT ??

      PROCEDURE evaluate_parameter;

        VAR
          parameter_value: clt$parameter_value,
          pdt_number: clt$parameter_count,
          representation: ^clt$data_representation,
          representation_count: ^clt$data_representation_count,
          text: ^string ( * ),
          text_length: clt$string_size;


        IF NOT parameter_information^ [parameter_number].initialized THEN
          initialize_prompt_and_value (parameter_information^ [parameter_number].pdt_number);
        IFEND;
        pdt_number := parameter_information^ [parameter_number].pdt_number;
        IF (parameter_information^ [parameter_number].value = NIL) OR
              (parameter_information^ [parameter_number].value^ = '') THEN
          evaluate_status.normal := TRUE;
          RETURN;
        IFEND;
        support.get_parameter_value^ (pdt_number, parameter_value, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        IF parameter_value.specified AND (NOT (parameter_information^ [parameter_number].
              evaluation_required OR editing_parameter_list)) THEN
          evaluate_status.normal := TRUE;
          RETURN;
        IFEND;
        support.evaluate_parameter^ (pdt_number, parameter_information^ [parameter_number].value^,
              evaluate_status);
        IF NOT evaluate_status.normal THEN
          center_parameter_on_screen;
          IF NOT editing_parameter_list THEN
            display_status (evaluate_status);
            RETURN;
          ELSE
            display_message_and_status (evaluate_status);
          IFEND;
        IFEND;
        support.get_parameter_value_source^ (pdt_number, clc$max_string_size, representation, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        RESET representation;
        NEXT representation_count IN representation;
        text := clp$data_representation_text (representation);
        text_length := clp$trimmed_string_size (text^);
        ALLOCATE parameter_information^ [parameter_number].value: [text_length];
        parameter_information^ [parameter_number].value^ := text^ (1, text_length);
        parameter_information^ [parameter_number].too_big_to_edit := (representation_count^ > 1);
        parameter_information^ [parameter_number].evaluation_required := FALSE;

      PROCEND evaluate_parameter;
?? OLDTITLE, EJECT ??

      get_event_parameter;
      update_parameters := TRUE;
      IF parameter_selected AND NOT parameter_information^ [parameter_number].advanced_indicator THEN
        IF NOT parameter_information^ [parameter_number].too_big_to_edit THEN
          evaluate_parameter;
        IFEND;
      ELSEIF display.parameter_count > 0 THEN
        FOR parameter_number := 1 TO display.parameter_count DO
          IF NOT parameter_information^ [parameter_number].advanced_indicator AND
                (NOT parameter_information^ [parameter_number].too_big_to_edit) THEN
            evaluate_parameter;
            IF NOT evaluate_status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        FOREND;
      IFEND;

    PROCEND process_evaluate_event;
?? TITLE := 'process_first_event', EJECT ??

    PROCEDURE process_first_event;


      CASE display.current_window OF
      = clc$help_window =
        IF help_window.lines_displayed <> 0 THEN
          cursor_field_number := help_window.text_field;
          cursor_line_number := 1;
          IF help_window.top <> 1 THEN
            help_window.top := 1;
            update_window_display (clc$help_window);
          IFEND;
        IFEND;
      = clc$message_window =
        IF message_window.lines_displayed <> 0 THEN
          cursor_field_number := message_window.text_field;
          cursor_line_number := 1;
          IF message_window.top <> 1 THEN
            message_window.top := 1;
            update_window_display (clc$message_window);
          IFEND;
        IFEND;
      = clc$zoom_window =
        IF zoom_window.lines_displayed <> 0 THEN
          cursor_field_number := zoom_window.text_field;
          cursor_line_number := 1;
          IF zoom_window.top <> 1 THEN
            zoom_window.top := 1;
            update_window_display (clc$zoom_window);
          IFEND;
        IFEND;
      ELSE {clc$no_window
        IF display.parameter_count <> 0 THEN
          cursor_field_number := parameter_display_info^ [1].value_field_number;
          cursor_line_number := 1;
          cursor_character_position := 1;
          IF display.top_parameter <> 1 THEN
            display.top_parameter := 1;
            update_parameters := TRUE;
          IFEND;
        IFEND;
      CASEND;

    PROCEND process_first_event;
?? TITLE := 'process_forward_event', EJECT ??

    PROCEDURE process_forward_event;

      VAR
        hold_contents: ^array [1 .. * ] of ^string ( * ),
        i: 0 .. csc$max_line_number,
        message_text: string (csc$max_x_position),
        new_top: 0 .. csc$max_line_number,
        text_length: 0 .. csc$max_x_position;


      CASE display.current_window OF
      = clc$help_window =
        IF help_window.lines_displayed <> 0 THEN
          IF help_window.top + (2 * help_window.lines_displayed) > help_window.line_count THEN
            new_top := help_window.line_count - help_window.lines_displayed + 1;
          ELSE
            new_top := help_window.top + help_window.lines_displayed - 1;
          IFEND;
          cursor_field_number := help_window.text_field;
          cursor_line_number := (help_window.lines_displayed + 1) DIV 2;
          IF new_top <> help_window.top THEN
            help_window.top := new_top;
            update_window_display (clc$help_window);
          IFEND;
        IFEND;
      = clc$message_window =
        IF message_window.lines_displayed <> 0 THEN
          IF message_window.top + (2 * message_window.lines_displayed) > message_window.line_count THEN
            new_top := message_window.line_count - message_window.lines_displayed + 1;
          ELSE
            new_top := message_window.top + message_window.lines_displayed - 1;
          IFEND;
          cursor_field_number := message_window.text_field;
          cursor_line_number := (message_window.lines_displayed + 1) DIV 2;
          IF new_top <> message_window.top THEN
            message_window.top := new_top;
            update_window_display (clc$message_window);
          IFEND;
        IFEND;
      = clc$zoom_window =
        IF zoom_window.lines_displayed <> 0 THEN
          IF zoom_window.top + zoom_window.lines_displayed - 1 + zoom_window.lines_displayed - 1 >
                zoom_window.line_count THEN
            IF zoom_window.top + zoom_window.lines_displayed - 1 + zoom_window.lines_displayed - 1 <=
                  csc$max_line_number THEN
              new_top := zoom_window.top + zoom_window.lines_displayed - 1;
              PUSH hold_contents: [1 .. zoom_window.line_count];
              hold_contents^ := zoom_window.contents^;
              FREE zoom_window.contents;
              ALLOCATE zoom_window.contents: [1 .. new_top + zoom_window.lines_displayed - 1];
              FOR i := 1 TO zoom_window.line_count DO
                zoom_window.contents^ [i] := hold_contents^ [i];
              FOREND;
              FOR i := zoom_window.line_count + 1 TO new_top + zoom_window.lines_displayed - 1 DO
                zoom_window.contents^ [i] := NIL;
              FOREND;
              zoom_window.line_count := new_top + zoom_window.lines_displayed - 1;
            ELSE
              get_message_text (clc$no_more_input_space, NIL, message_text, text_length);
              display_message (message_text (1, text_length));
              RETURN;
            IFEND;
          ELSE
            new_top := zoom_window.top + zoom_window.lines_displayed - 1;
          IFEND;
          cursor_field_number := zoom_window.text_field;
          cursor_line_number := (zoom_window.lines_displayed + 1) DIV 2;
          zoom_window.top := new_top;
          update_window_display (clc$zoom_window);
        IFEND;
      ELSE {clc$no_window
        IF display.parameters_displayed <> 0 THEN
          IF display.top_parameter + (2 * display.parameters_displayed) > display.parameter_count THEN
            new_top := display.parameter_count - display.parameters_displayed + 1;
          ELSE
            new_top := display.top_parameter + display.parameters_displayed - 1;
          IFEND;

          cursor_field_number := parameter_display_info^ [(display.parameters_displayed + 1) DIV
                2].value_field_number;
          cursor_line_number := 1;
          IF new_top <> display.top_parameter THEN
            display.top_parameter := new_top;
            update_parameters := TRUE;
          IFEND;
        IFEND;
      CASEND;

    PROCEND process_forward_event;
?? TITLE := 'process_help_event', EJECT ??

    PROCEDURE process_help_event;

      VAR
        explain_command: string (csc$max_x_position),
        explain_command_size: integer,
        explanation_available: boolean,
        include_status: ost$status,
        message: ^ost$status_message,
        message_area: ^ost$status_message,
        message_text: string (csc$max_x_position),
        representation: ^clt$data_representation,
        text_length: 0 .. csc$max_x_position;


      IF display.current_window = clc$help_window THEN
        support.explain^ (explanation_available, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        IF NOT explanation_available THEN
          get_message_text (clc$no_more_help_available, NIL, message_text, text_length);
          display_message (message_text (1, text_length));
        ELSE
          change_menu_items (clc$help_window, help_window.parent_window);
          close_window (clc$help_window);
        IFEND;
      ELSEIF status_condition_name <> '' THEN
        STRINGREP (explain_command, explain_command_size, 'EXPLAIN SUBJECT=''', status_condition_name,
              ''' MANUAL=MESSAGES');
        clp$include_line (explain_command (1, explain_command_size), FALSE, osc$null_name, include_status);
        IF NOT include_status.normal THEN
          display_status (include_status);
        IFEND;
      ELSE
        IF display.current_window = clc$zoom_window THEN
          parameter_selected := zoom_window.parameter_value;
          parameter_number := zoom_window.parameter_number;
        ELSE
          get_event_parameter;
        IFEND;
        IF parameter_selected THEN
          support.get_parameter_help^ (parameter_information^ [parameter_number].pdt_number,
                message_field_width + 1, message, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          IF message <> NIL THEN
            PUSH message_area;
            message_area^ := message^;
          ELSE
            message_area := NIL;
          IFEND;
          support.get_parameter_spec^ (parameter_information^ [parameter_number].pdt_number, TRUE,
                message_field_width, representation, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          display_help_window (representation, message_area);
          help_window.cursor_field_number := parameter_display_info^
                [parameter_number - display.top_parameter + 1].value_field_number;
        ELSE
          support.get_full_help^ (message_field_width + 1, message, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          IF message = NIL THEN
            support.get_brief_help^ (message_field_width + 1, message, status);
            IF NOT status.normal THEN
              EXIT clp$scl_parameter_dialog_mgr;
            IFEND;
          IFEND;
          IF message <> NIL THEN
            PUSH message_area;
            message_area^ := message^;
          ELSE
            message_area := NIL;
          IFEND;
          support.get_all_parameter_specs^ (TRUE, message_field_width, representation, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          display_help_window (representation, message_area);
          help_window.cursor_field_number := display.command_field;
        IFEND;
        help_window.cursor_character_position := 1;
        help_window.cursor_line_number := 1;
      IFEND;

    PROCEND process_help_event;
?? TITLE := 'process_home_event', EJECT ??

    PROCEDURE process_home_event;


      cursor_field_number := display.command_field;
      cursor_character_position := 1;
      cursor_line_number := 1;

    PROCEND process_home_event;
?? TITLE := 'process_info_event', EJECT ??

    PROCEDURE process_info_event;

      VAR
        i: clt$parameter_name_count,
        message: ost$status_message,
        message_parameters: ^array [1 .. * ] of ^ost$message_parameter,
        names: ^array [1 .. * ] of clt$command_name,
        source_string: fst$path,
        source_string_size: fst$path_size;


      IF support.nested_dialog_title <> NIL THEN
        RETURN;
      IFEND;

      support.get_all_names^ (names, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      PUSH message_parameters: [1 .. UPPERBOUND (names^) + 1];
      FOR i := 1 TO UPPERBOUND (names^) DO
        PUSH message_parameters^ [i + 1]: [clp$trimmed_string_size (names^ [i])];
        #TRANSLATE (osv$upper_to_lower, names^ [i], message_parameters^ [i + 1]^);
      FOREND;
      support.get_source^ (source_string, source_string_size, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      PUSH message_parameters^ [1]: [source_string_size];
      #TRANSLATE (osv$upper_to_lower, source_string (1, source_string_size), message_parameters^ [1]^);
      IF UPPERBOUND (message_parameters^) = 2 THEN
        get_message (clc$info_display_with_one_name, message_parameters, message);
      ELSE
        get_message (clc$info_display, message_parameters, message);
      IFEND;
      display_status_message (message, clc$message_window);

    PROCEND process_info_event;
?? TITLE := 'process_insert_char_event', EJECT ??

    PROCEDURE process_insert_char_event;

      VAR
        command_field: boolean,
        ignore_parameter_value: boolean,
        input_field: boolean,
        line_number: 0 .. csc$max_line_number;

?? NEWTITLE := 'insert_char', EJECT ??

      PROCEDURE insert_char
        (VAR field_text: ^string ( * ));

        VAR
          text: ^string ( * ),
          text_length: 0 .. csc$max_character_position;


        text_length := clp$trimmed_string_size (field_text^);
        IF (text_length > 0) AND (cursor_character_position <= text_length) THEN
          text_length := text_length + 1;
          PUSH text: [text_length];
          IF cursor_character_position > 1 THEN
            text^ := field_text^ (1, cursor_character_position - 1);
          IFEND;
          text^ (cursor_character_position, 1) := ' ';
          text^ (cursor_character_position + 1, text_length - cursor_character_position) :=
                field_text^ (cursor_character_position, text_length - cursor_character_position);
          FREE field_text;
          ALLOCATE field_text: [text_length];
          field_text^ := text^;
        IFEND;

      PROCEND insert_char;
?? OLDTITLE, EJECT ??

      get_cursor_input_field (input_field, command_field, ignore_parameter_value, line_number);
      IF input_field THEN
        IF command_field THEN
          IF display.command_text <> NIL THEN
            insert_char (display.command_text);
          IFEND;
        ELSE
          CASE display.current_window OF
          = clc$zoom_window =
            IF zoom_window.contents^ [line_number + zoom_window.top - 1] <> NIL THEN
              insert_char (zoom_window.contents^ [line_number + zoom_window.top - 1]);
              update_window_display (clc$zoom_window);
            IFEND;
          = clc$no_window =
            IF (parameter_information^ [parameter_number].value <> NIL) AND
                  (NOT (parameter_information^ [parameter_number].
                  too_big_to_edit OR parameter_information^ [parameter_number].overflow)) THEN
              insert_char (parameter_information^ [parameter_number].value);
              parameter_information^ [parameter_number].evaluation_required := TRUE;
              update_parameters := TRUE;
            IFEND;
          ELSE
          CASEND;
        IFEND;
      IFEND;

    PROCEND process_insert_char_event;
?? TITLE := 'process_keyboard', EJECT ??

    PROCEDURE process_keyboard;

      VAR
        action: integer,
        defer_command_line_processing: boolean,
        got_an_action: boolean,
        i: integer,
        message: ost$status_message;


      action_number := 0;
      processing_complete := FALSE;
      ignore_following_csc$next_event := FALSE;
      need_to_clear_command_field := FALSE;

      csp$flush_events (status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      IF NOT initial_status.normal THEN
        display_status (initial_status);
      IFEND;

      WHILE NOT processing_complete DO

        csp$change_cursor_position (cursor_field_number, cursor_character_position, cursor_line_number,
              status);
        status.normal := TRUE;

      /get_action_loop/
        WHILE TRUE DO
          get_action (got_an_action, action);
          IF got_an_action THEN
            EXIT /get_action_loop/;
          IFEND;

{ If control is returned without getting an action, a "job reconnect"
{ condition must have occurred, so repaint the screen and retry the get.

          csp$clear_screen (status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        WHILEND /get_action_loop/;

        message_read := TRUE;
        defer_command_line_processing := (action = zoom_event) OR (action = clear_eol_event) OR
              (action = delete_char_event) OR (action = insert_char_event) OR
              (action = edit_zoom_event);
        get_screen_values (defer_command_line_processing);

        IF need_to_clear_command_field THEN
          clear_command_field;
        IFEND;

        IF action <> 0 THEN
          csp$mark_menu_item (action, status);
          csp$update_device (status);
          status.normal := TRUE;

          CASE action OF
          = backward_event =
            process_backward_event;
          = cancel_event =
            process_cancel_event;
          = clear_event =
            process_clear_event;
          = clear_eol_event =
            process_clear_eol_event;
          = delete_char_event =
            process_delete_char_event;
          = down_event =
            process_down_event;
          = evaluate_event =
            process_evaluate_event;
          = first_event =
            process_first_event;
          = forward_event =
            process_forward_event;
          = help_event =
            process_help_event;
          = home_event =
            process_home_event;
          = info_event =
            process_info_event;
          = insert_char_event =
            process_insert_char_event;
          = last_event =
            process_last_event;
          = mouse_click_strong =
            { turned into appropriate event by get_mouse_action } ;
          = mouse_click_weak =
            { just "resolves" terminal cursor to mouse cursor position} ;
          = ok_event =
            process_ok_event;
          = reset_event =
            process_reset_event;
          = up_event =
            process_up_event;
          = zoom_event =
            process_zoom_event;
          = edit_zoom_event =
            action_number := edit_zoom_event;
            process_zoom_event;
            action_number := 0;
          ELSE
            ;
          CASEND;
          csp$unmark_menu_item (action, status);
          status.normal := TRUE;
        ELSEIF next_event THEN
          process_next_event;
        ELSEIF NOT (mouse_event OR screen_event) THEN
          process_undefined_event;
        IFEND;

        IF update_parameters THEN
          update_parameters := FALSE;
          update_parameter_display;
        IFEND;

        IF (NOT message_displayed) AND (display.current_window <> clc$message_window) AND
              (cleared_parameters <> NIL) THEN
          get_message (clc$cleared_parameter_ignored, cleared_parameters, message);
          display_status_message (message, clc$message_window);
          FOR i := 1 TO UPPERBOUND (cleared_parameters^) DO
            IF cleared_parameters^ [i] <> NIL THEN
              FREE cleared_parameters^ [i];
            IFEND;
          FOREND;
          FREE cleared_parameters;
        IFEND;

        IF message_displayed AND message_read AND NOT screen_event THEN
          csp$clear_field (display.message_field, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          status_condition_name := '';
          message_displayed := FALSE;
          message_read := FALSE;
          clear_command_field;
        IFEND;

        IF defer_command_line_processing AND (action <> zoom_event) AND
              (action <> edit_zoom_event) AND (display.command_text <> NIL) THEN
          process_command (display.command_text^);
        IFEND;

      WHILEND;

    PROCEND process_keyboard;
?? TITLE := 'process_last_event', EJECT ??

    PROCEDURE process_last_event;

      VAR
        new_top: clt$parameter_count;


      CASE display.current_window OF
      = clc$help_window =
        IF help_window.lines_displayed <> 0 THEN
          cursor_field_number := help_window.text_field;
          cursor_line_number := help_window.lines_displayed;
          new_top := help_window.line_count - help_window.lines_displayed + 1;
          IF new_top <> help_window.top THEN
            help_window.top := new_top;
            update_window_display (clc$help_window);
          IFEND;
        IFEND;
      = clc$message_window =
        IF message_window.lines_displayed <> 0 THEN
          cursor_field_number := message_window.text_field;
          cursor_line_number := message_window.lines_displayed;
          new_top := message_window.line_count - message_window.lines_displayed + 1;
          IF new_top <> message_window.top THEN
            message_window.top := new_top;
            update_window_display (clc$message_window);
          IFEND;
        IFEND;
      = clc$zoom_window =
        IF zoom_window.lines_displayed <> 0 THEN
          cursor_field_number := zoom_window.text_field;
          cursor_line_number := zoom_window.lines_displayed;
          new_top := zoom_window.line_count - zoom_window.lines_displayed + 1;
          IF new_top <> zoom_window.top THEN
            zoom_window.top := new_top;
            update_window_display (clc$zoom_window);
          IFEND;
        IFEND;
      ELSE {clc$no_window
        IF display.parameters_displayed <> 0 THEN
          new_top := display.parameter_count - display.parameters_displayed + 1;
          cursor_field_number := parameter_display_info^ [display.parameters_displayed].value_field_number;
          cursor_line_number := 1;
          cursor_character_position := 1;
          IF display.top_parameter <> new_top THEN
            display.top_parameter := new_top;
            update_parameters := TRUE;
          IFEND;
        IFEND;
      CASEND;

    PROCEND process_last_event;
?? TITLE := 'process_next_event', EJECT ??

    PROCEDURE process_next_event;

      VAR
        command_field: boolean,
        input_field: boolean,
        line_number: 0 .. csc$max_line_number,
        new_parameter_line: 0 .. csc$max_line_number,
        parameter_value: boolean;


      CASE display.current_window OF
      = clc$help_window =
        change_menu_items (clc$help_window, help_window.parent_window);
        close_window (clc$help_window);
      = clc$message_window =
        IF message_read THEN
          change_menu_items (clc$message_window, message_window.parent_window);
          close_window (clc$message_window);
          status_condition_name := '';
          need_to_clear_command_field := TRUE;
          message_read := FALSE;
        ELSE
          message_read := TRUE;
        IFEND;
      = clc$zoom_window, clc$no_window =

{ Treat NEXT as a forward tab.

        get_cursor_input_field (input_field, command_field, parameter_value, line_number);
        cursor_character_position := 1;
        cursor_line_number := 1;
        IF command_field THEN
          IF ignore_tab_caused_by_next THEN
            ignore_tab_caused_by_next := FALSE;
            RETURN;
          IFEND;
          CASE display.current_window OF
          = clc$zoom_window =
            IF zoom_window.lines_displayed > 0 THEN
              cursor_field_number := zoom_window.text_field;
            IFEND;
          = clc$no_window =
            IF display.parameters_displayed = 0 THEN
              RETURN;
            IFEND;
            new_parameter_line := 1;

            WHILE parameter_information^ [display.top_parameter + new_parameter_line - 1].
                  advanced_indicator DO
              IF new_parameter_line = display.parameters_displayed THEN
                cursor_field_number := display.command_field;
                RETURN;
              IFEND;
              new_parameter_line := new_parameter_line + 1;
            WHILEND;

            cursor_field_number := parameter_display_info^ [new_parameter_line].value_field_number;
          ELSE
          CASEND;
        ELSEIF parameter_value THEN
          CASE display.current_window OF
          = clc$zoom_window =
            IF line_number = zoom_window.lines_displayed THEN
              scroll_window;
            ELSE
              cursor_line_number := line_number + 1;
            IFEND;
          = clc$no_window =
            IF parameter_number = display.parameter_count THEN
              cursor_field_number := display.command_field;
              RETURN;
            ELSEIF parameter_number = display.top_parameter + display.parameters_displayed - 1 THEN
              scroll_window;
              RETURN;
            ELSE
              new_parameter_line := parameter_line + 1;
            IFEND;

            WHILE parameter_information^ [display.top_parameter + new_parameter_line - 1].
                  advanced_indicator DO
              IF new_parameter_line = display.parameters_displayed THEN
                cursor_field_number := display.command_field;
                RETURN;
              IFEND;
              new_parameter_line := new_parameter_line + 1;
            WHILEND;

            cursor_field_number := parameter_display_info^ [new_parameter_line].value_field_number;
          ELSE
            RETURN;
          CASEND;
        ELSE
          cursor_field_number := display.command_field;
        IFEND;
      ELSE
      CASEND;

    PROCEND process_next_event;
?? TITLE := 'process_ok_event', EJECT ??

    PROCEDURE process_ok_event;

      VAR
        evaluation_status: ost$status,
        pdt_number: clt$parameter_count,
        representation: ^clt$data_representation,
        text: string (csc$max_x_position),
        text_length: cst$data_string_length,
        which_parameter: clt$which_parameter;


      CASE display.current_window OF
      = clc$help_window, clc$message_window =
        { The OK event is undefined for help and message windows.
      = clc$zoom_window =
        IF zoom_window.parameter_value THEN
          process_zoomed_parameter;
          change_menu_items (clc$zoom_window, zoom_window.parent_window);
          close_window (clc$zoom_window);
        ELSE
          process_zoomed_command;
        IFEND;
      ELSE {clc$no_window
        IF cleared_parameters <> NIL THEN
          RETURN;
        IFEND;
        FOR parameter_number := 1 TO display.parameter_count DO
          IF (NOT parameter_information^ [parameter_number].advanced_indicator) AND
                parameter_information^ [parameter_number].evaluation_required THEN
            pdt_number := parameter_information^ [parameter_number].pdt_number;
            IF editing_parameter_list THEN
              support.change_expression_save^ (TRUE, status);
              IF NOT status.normal THEN
                EXIT clp$scl_parameter_dialog_mgr;
              IFEND;
            IFEND;
            support.evaluate_parameter^ (pdt_number, parameter_information^ [parameter_number].value^,
                  evaluation_status);
            IF editing_parameter_list THEN
              support.change_expression_save^ (FALSE, status);
              IF NOT status.normal THEN
                EXIT clp$scl_parameter_dialog_mgr;
              IFEND;
            IFEND;
            IF NOT evaluation_status.normal THEN
              center_parameter_on_screen;
              IF NOT editing_parameter_list THEN
                display_status (evaluation_status);
                update_parameters := TRUE;
                RETURN;
              ELSE
                display_message_and_status (evaluation_status);
                parameter_information^ [parameter_number].evaluation_required := FALSE;
                update_parameters := TRUE;
                RETURN;
              IFEND;
            IFEND;
            support.get_parameter_value_source^ (pdt_number, clc$max_string_size, representation, status);
            IF NOT status.normal THEN
              EXIT clp$scl_parameter_dialog_mgr;
            IFEND;
            text := clp$data_representation_text (representation) ^;
            text_length := clp$trimmed_string_size (text);
            ALLOCATE parameter_information^ [parameter_number].value: [text_length];
            parameter_information^ [parameter_number].value^ := text (1, text_length);
          IFEND;
        FOREND;

        support.verify_all_parameters^ (which_parameter, evaluation_status);
        IF NOT evaluation_status.normal THEN
          IF which_parameter.specific THEN

          /get_field_number/
            FOR parameter_number := 1 TO display.parameter_count DO
              IF (NOT parameter_information^ [parameter_number].advanced_indicator) AND
                    (which_parameter.number = parameter_information^ [parameter_number].pdt_number) THEN
                center_parameter_on_screen;
                EXIT /get_field_number/;
              IFEND;
            FOREND /get_field_number/;
          IFEND;
          update_parameters := TRUE;
          display_status (evaluation_status);
        ELSE
          processing_complete := TRUE;
        IFEND;
      CASEND;

    PROCEND process_ok_event;
?? TITLE := 'process_reset_event', EJECT ??

    PROCEDURE process_reset_event;

?? NEWTITLE := 'restore_parameter_default', EJECT ??

      PROCEDURE restore_parameter_default;

        VAR
          pdt_number: clt$parameter_count,
          restore_default_status: ost$status,
          text: ^string ( * ),
          text_length: clt$string_size;

        pdt_number := parameter_information^ [parameter_number].pdt_number;
        support.restore_parameter_default^ (pdt_number, restore_default_status);
        IF NOT restore_default_status.normal THEN
          display_status (restore_default_status);
          RETURN;
        IFEND;

        CASE pdt.parameters^ [pdt_number].requirement OF
        = clc$optional_default_parameter, clc$confirm_default_parameter =
          support.get_parameter_default^ (pdt_number, text, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        ELSE {clc$required_parameter, clc$optional_parameter}
          PUSH text: [0];
        CASEND;
        parameter_information^ [parameter_number].initialized := TRUE;
        parameter_information^ [parameter_number].evaluation_required := FALSE;
        parameter_information^ [parameter_number].too_big_to_edit := FALSE;
        text_length := clp$trimmed_string_size (text^);
        ALLOCATE parameter_information^ [parameter_number].value: [text_length];
        parameter_information^ [parameter_number].value^ := text^ (1, text_length);

        IF (parameter_number >= display.top_parameter) AND (parameter_number <
              display.top_parameter + display.parameters_displayed) THEN
          update_parameters := TRUE;
        IFEND;
        parameter_information^ [parameter_number].too_big_to_edit := FALSE;

      PROCEND restore_parameter_default;
?? OLDTITLE, EJECT ??

      get_event_parameter;
      IF parameter_selected THEN
        restore_parameter_default;
        cursor_field_number := parameter_display_info^ [parameter_line].value_field_number;
        cursor_line_number := 1;
        cursor_character_position := 1;
      ELSE
        FOR parameter_number := 1 TO display.parameter_count DO
          IF (NOT parameter_information^ [parameter_number].advanced_indicator) AND
                parameter_information^ [parameter_number].initialized THEN
            restore_parameter_default;
          IFEND;
        FOREND;
      IFEND;

    PROCEND process_reset_event;
?? TITLE := 'process_undefined_event', EJECT ??

    PROCEDURE process_undefined_event;

      VAR
        event_name_identifier: cst$event_name_identifier,
        message: ost$status_message,
        message_area: ^ost$status_message,
        message_parameters: array [1 .. 1] of ^ost$message_parameter,
        name: ost$name,
        name_length: 0 .. osc$max_name_size;


      IF display.help_window_displayed THEN
        get_message (clc$function_key_help, NIL, message);
        PUSH message_area;
        message_area^ := message;
        display_help_window (NIL, message_area);
      ELSE
        event_name_identifier.event_type := event.event_type;
        CASE event_name_identifier.event_type OF
        = csc$page_event =
          event_name_identifier.page_event := event.page_event;
        = csc$field_event =
          event_name_identifier.field_event := event.field_event;
        = csc$timeout_event =
          ;
        = csc$end_of_transaction =
          ;
        CASEND;

        csp$get_event_name (event_name_identifier, name, name_length, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        name := name (1, name_length);
        convert_name_to_message_param (name);
        message_parameters [1] := ^name;
        get_message (clc$undefined_function_key, ^message_parameters, message);
        display_status_message (message, clc$message_window);
      IFEND;

    PROCEND process_undefined_event;
?? TITLE := 'process_up_event', EJECT ??

    PROCEDURE process_up_event;

      VAR
        message_text: string (csc$max_x_position),
        new_top_parameter: clt$parameter_count,
        text_length: 0 .. csc$max_x_position;


      get_event_parameter;
      IF NOT event_on_parameter_line THEN
        get_message_text (clc$press_up, NIL, message_text, text_length);
        display_message (message_text (1, text_length));
        RETURN;
      IFEND;

      new_top_parameter := parameter_number;
      IF (display.parameter_count - new_top_parameter + 1) < display.parameters_displayed THEN
        new_top_parameter := display.parameter_count - display.parameters_displayed + 1;
      IFEND;

      cursor_field_number := parameter_display_info^ [(display.parameters_displayed + 1) DIV
            2].value_field_number;
      cursor_line_number := 1;
      cursor_character_position := 1;
      IF new_top_parameter <> display.top_parameter THEN
        display.top_parameter := new_top_parameter;
        update_parameters := TRUE;
      IFEND;

    PROCEND process_up_event;
?? TITLE := 'process_zoom_event', EJECT ??

{ PURPOSE:
{   This procedure generates a ZOOM window for the command line or a parameter
{   value field, in response to the ZOOM event entered by the terminal user.
{ DESIGN:
{   The ZOOM window is generated for the command line if the ZOOM event is not
{   associated with a specific parameter.
{ NOTES:
{   Secure parameters are not ZOOMable so that the contents are not displayed.

    PROCEDURE process_zoom_event;

      VAR
        message_parameter: array [1 .. 1] of ^ost$message_parameter,
        message_text: string (csc$max_x_position),
        text_length: 0 .. csc$max_x_position;


      IF cursor_field_number = display.command_field THEN
        zoom_window.cursor_field_number := display.command_field;
        zoom_window.cursor_character_position := 1;
        zoom_window.cursor_line_number := 1;
        zoom_command_line;

      ELSE
        get_event_parameter;
        IF parameter_selected THEN
          IF parameter_information^ [parameter_number].secure THEN

{ Decline to ZOOM secure parameters, so that secure information is not displayed.

            message_parameter [1] := ^parameter_information^ [parameter_number].name;
            get_message_text (clc$unable_to_zoom_secure_param, ^message_parameter, message_text, text_length);
            display_message (message_text (1, text_length));
          ELSE
            zoom_window.cursor_field_number := cursor_field_number;
            zoom_window.cursor_character_position := cursor_character_position;
            zoom_window.cursor_line_number := cursor_line_number;
            zoom_parameter;
          IFEND;
        IFEND;
      IFEND;

    PROCEND process_zoom_event;
?? TITLE := 'process_zoom_input', EJECT ??

    PROCEDURE process_zoom_input
      (    line_number: integer);

      VAR
        end_of_line: boolean,
        end_of_text: boolean,
        text: string (csc$max_x_position),
        text_length: cst$data_string_length;


      csp$get_text (text, text_length, end_of_line, end_of_text, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      IF NOT end_of_text THEN
        IF zoom_window.contents^ [line_number] <> NIL THEN
          FREE zoom_window.contents^ [line_number];
        IFEND;
        ALLOCATE zoom_window.contents^ [line_number]: [text_length];
        zoom_window.contents^ [line_number]^ := text (1, text_length);
      IFEND;

    PROCEND process_zoom_input;
?? TITLE := 'process_zoomed_command', EJECT ??

    PROCEDURE process_zoomed_command;

      VAR
        command_text: ^string ( * ),
        command_text_length: 0 .. csc$max_character_position,
        include_status: ost$status,
        line_number: integer;


      PUSH command_text: [zoom_window.line_count * message_field_width];
      command_text_length := 0;
      FOR line_number := 1 TO zoom_window.line_count DO
        IF zoom_window.contents^ [line_number] <> NIL THEN
          command_text^ (command_text_length + 1, message_field_width) :=
                zoom_window.contents^ [line_number]^;
          command_text_length := command_text_length + message_field_width;
        IFEND;
      FOREND;

      include_status.normal := TRUE;
      IF command_text^ (1, command_text_length) <> ' ' THEN
        clp$push_interactive_input (status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        IF called_from_screen_mode THEN
          csp$disable_page (status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        IFEND;

        clp$include_command (command_text^ (1, command_text_length), FALSE, include_status);
        IF called_from_screen_mode THEN
          csp$enable_page (status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        IFEND;

        clp$pop_interactive_input (status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
      IFEND;

      IF NOT include_status.normal THEN
        display_status (include_status);
      ELSE
        change_menu_items (clc$zoom_window, zoom_window.parent_window);
        close_window (clc$zoom_window);
        IF display.command_text <> NIL THEN
          FREE display.command_text;
        IFEND;
      IFEND;

    PROCEND process_zoomed_command;
?? TITLE := 'process_zoomed_parameter', EJECT ??

    PROCEDURE process_zoomed_parameter;

      VAR
        line_number: integer,
        message_text: string (csc$max_x_position),
        text: ^string (clc$max_string_size),
        text_size: clt$string_size,
        text_length: 0 .. csc$max_x_position;


      PUSH text;
      text_size := 0;
      FOR line_number := 1 TO zoom_window.line_count DO
        IF zoom_window.contents^ [line_number] <> NIL THEN
          IF text_size + message_field_width <= csc$max_character_position THEN
            text^ (text_size + 1, message_field_width) := zoom_window.contents^ [line_number]^;
            text_size := text_size + message_field_width;
          ELSE
            get_message_text (clc$too_big_to_edit, NIL, message_text, text_length);
            display_message (message_text (1, text_length));
            RETURN;
          IFEND;
        IFEND;
      FOREND;

      IF parameter_information^ [zoom_window.parameter_number].value^ = text^ (1, text_size) THEN
        RETURN;
      IFEND;

      IF text^ (1, text_size) = '' THEN
        ignore_cleared_parameter (parameter_information^ [zoom_window.parameter_number].name);
        RETURN;
      IFEND;

      FREE parameter_information^ [zoom_window.parameter_number].value;
      ALLOCATE parameter_information^ [zoom_window.parameter_number].value: [text_size];
      parameter_information^ [zoom_window.parameter_number].value^ := text^ (1, text_size);
      parameter_information^ [zoom_window.parameter_number].evaluation_required := TRUE;

      update_parameters := TRUE;

    PROCEND process_zoomed_parameter;
?? TITLE := 'put_representation', EJECT ??

    PROCEDURE put_representation
      (    representation: ^clt$data_representation);


      VAR
        end_of_text: boolean,
        events: ^array [1 .. * ] of carriage_return .. down_event,
        i: clt$data_representation_count,
        message_text: string (csc$max_x_position),
        number_of_lines_for_box: 0 .. csc$max_line_number,
        representation_area: ^clt$data_representation,
        representation_line: ^clt$string_value,
        representation_line_count: ^clt$data_representation_count,
        representation_line_size: ^clt$string_size,
        text_length: 0 .. csc$max_x_position;


      IF display.message_window_displayed THEN
        close_window (clc$message_window);
        status_condition_name := '';
      IFEND;
      change_menu_items (display.current_window, clc$help_window);
      PUSH representation_area: [[REP #SIZE (representation^) OF cell]];
      representation_area^ := representation^;
      RESET representation_area;
      NEXT representation_line_count IN representation_area;
      help_window.line_count := representation_line_count^;
      IF help_window.line_count > dialog_box_max_lines - 2 THEN
        PUSH events: [1 .. 3];
        events^ [1] := carriage_return;
        events^ [2] := forward_event;
        events^ [3] := backward_event;
        get_function_key_message (clc$press_next_from_pageable, events, message_text, text_length);
        number_of_lines_for_box := dialog_box_max_lines;
      ELSE
        PUSH events: [1 .. 1];
        events^ [1] := carriage_return;
        get_function_key_message (clc$press_next, events, message_text, text_length);
        number_of_lines_for_box := help_window.line_count + 2;
      IFEND;
      create_window (clc$help_window, 1, dialog_box_top, display.screen_width, number_of_lines_for_box,
            message_text (1, text_length), '', FALSE);
      update_lines_l_thru_m_of_n (help_window.top, help_window.lines_displayed, help_window.line_count,
            help_window.line_number_field, help_window.buttons);
      ALLOCATE help_window.contents: [1 .. help_window.line_count];
      FOR i := 1 TO help_window.line_count DO
        NEXT representation_line_size IN representation_area;
        NEXT representation_line: [representation_line_size^] IN representation_area;
        ALLOCATE help_window.contents^ [i]: [representation_line_size^];
        help_window.contents^ [i]^ := representation_line^;
        IF i <= number_of_lines_for_box - 2 THEN
          csp$change_io_position (help_window.text_field, i, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$put_text (representation_line, TRUE, end_of_text, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        IFEND;
      FOREND;

    PROCEND put_representation;
?? TITLE := 'scroll_window', EJECT ??

    PROCEDURE scroll_window;

      VAR
        hold_contents: ^array [1 .. * ] of ^string ( * ),
        i: 0 .. csc$max_line_number,
        message_text: string (csc$max_x_position),
        new_top: 0 .. csc$max_line_number,
        scroll_increment: 0 .. csc$max_line_number,
        text_length: 0 .. csc$max_x_position;


      CASE display.current_window OF
      = clc$help_window, clc$message_window =

{ Scrolling is not available for HELP or MESSAGE windows.

      = clc$zoom_window =
        IF zoom_window.lines_displayed <> 0 THEN
          scroll_increment := zoom_window.lines_displayed DIV 2;
          IF zoom_window.top + zoom_window.lines_displayed - 1 + scroll_increment >
                zoom_window.line_count THEN

{ Expand window contents to scroll beyond end of current value.

            IF zoom_window.top + zoom_window.lines_displayed - 1 + scroll_increment <=
                  csc$max_line_number THEN
              new_top := zoom_window.top + scroll_increment;
              PUSH hold_contents: [1 .. zoom_window.line_count];
              hold_contents^ := zoom_window.contents^;
              FREE zoom_window.contents;
              ALLOCATE zoom_window.contents: [1 .. new_top + zoom_window.lines_displayed - 1];
              FOR i := 1 TO zoom_window.line_count DO
                zoom_window.contents^ [i] := hold_contents^ [i];
              FOREND;
              FOR i := zoom_window.line_count + 1 TO new_top + zoom_window.lines_displayed - 1 DO
                zoom_window.contents^ [i] := NIL;
              FOREND;
              zoom_window.line_count := new_top + zoom_window.lines_displayed - 1;
            ELSE
              get_message_text (clc$no_more_input_space, NIL, message_text, text_length);
              display_message (message_text (1, text_length));
              RETURN;
            IFEND;
          ELSE
            new_top := zoom_window.top + scroll_increment;
          IFEND;
          cursor_field_number := zoom_window.text_field;
          cursor_line_number := ((zoom_window.lines_displayed + 1) DIV 2) + 1;
          zoom_window.top := new_top;
          update_window_display (clc$zoom_window);
        IFEND;
      ELSE {clc$no_window
        IF display.parameters_displayed <> 0 THEN
          scroll_increment := display.parameters_displayed DIV 2;
          IF display.top_parameter + (display.parameters_displayed - 1) + scroll_increment >
                display.parameter_count THEN

{ Do not scroll beyond last parameter.

            new_top := display.parameter_count - display.parameters_displayed + 1;
          ELSE
            new_top := display.top_parameter + scroll_increment;
          IFEND;

          cursor_field_number := parameter_display_info^ [((display.parameters_displayed + 1) DIV
                2) + 1].value_field_number;
          cursor_line_number := 1;
          IF new_top <> display.top_parameter THEN
            display.top_parameter := new_top;
            update_parameters := TRUE;
          IFEND;
        IFEND;
      CASEND;

    PROCEND scroll_window;
?? TITLE := 'set_screen_dimensions', EJECT ??

    PROCEDURE set_screen_dimensions;

      VAR
        ignore_dimensions_accepted: boolean,
        terminal_attributes: array [1 .. 2] of ift$terminal_attribute;


      terminal_attributes [1].key := ifc$page_width;
      terminal_attributes [2].key := ifc$page_length;
      ifp$get_terminal_attributes (':$LOCAL.OUTPUT.1', terminal_attributes, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      IF (1 <= terminal_attributes [1].page_width) AND (terminal_attributes [1].page_width <=
            csc$max_x_position) THEN
        display.screen_width := terminal_attributes [1].page_width;
        IF (1 <= terminal_attributes [2].page_length) AND (terminal_attributes [2].page_length <=
              csc$max_line_number) THEN
          display.screen_height := terminal_attributes [2].page_length;
        ELSE
          display.screen_height := 1;
        IFEND;
        csp$change_device_dimensions (display.screen_width, display.screen_height, ignore_dimensions_accepted,
              status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
      IFEND;

    PROCEND set_screen_dimensions;
?? TITLE := 'setup_display', EJECT ??

    PROCEDURE setup_display;

      VAR
        attachment_options: ^fst$attachment_options,
        background_field_number: cst$field_number,
        context_attributes: array [1 .. 1] of ift$fetch_context_attribute,
        device_attributes: array [1 .. 2] of cst$device_attribute,
        get_page_attributes: array [1 .. 1] of cst$page_attribute,
        interaction_info: array [1 .. 1] of ost$interaction_info_item,
        lines_for_menu: clc$lines_for_one_menu_row .. clc$lines_for_two_menu_rows,
        lines_used_by_header: 0 .. csc$max_line_number,
        number_of_parameter_lines: 0 .. csc$max_line_number,
        page_attributes: array [1 .. 4] of cst$page_attribute,
        rows_for_menu: cst$number_of_menu_rows,
        rows_to_use: 0 .. csc$max_y_position;

?? NEWTITLE := 'determine_mouse_available', EJECT ??

      PROCEDURE [INLINE] determine_mouse_available;

        VAR
          event_name_identifier: cst$event_name_identifier,
          name: ost$name,
          name_length: 0 .. osc$max_name_size;


        event_name_identifier.event_type := csc$field_event;
        event_name_identifier.field_event.event_type := csc$pick;
        csp$get_event_name (event_name_identifier, name, name_length, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        display.mouse_available := name (1, name_length) = 'PC_SHELL';

      PROCEND determine_mouse_available;
?? OLDTITLE, EJECT ??

      context_attributes [1].key := ifc$previous_mode;
      ifp$fetch_context (context_attributes, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      IF context_attributes [1].previous_mode = ifc$screen THEN
        called_from_screen_mode := TRUE;
        IF display.parameter_count > (csc$max_y_position - clc$estimated_overhead_lines) THEN
          rows_to_use := csc$max_y_position - clc$estimated_overhead_lines;
        ELSEIF display.parameter_count < clc$minimum_parameter_rows THEN
          rows_to_use := clc$minimum_parameter_rows + clc$estimated_overhead_lines;
        ELSE
          rows_to_use := display.parameter_count + clc$estimated_overhead_lines;
        IFEND;
        rows_to_use := rows_to_use + 1; {For surrounding box.
        get_page_attributes [1].key := csc$menu_rows_displayed;
        csp$get_page_attributes (get_page_attributes, status);
        IF NOT status.normal THEN

{ The following check is needed to get around the situation where the underlying
{ screen application has its own instance of screen manager.  In that case there's
{ no way to find out how many menu rows that application is using.  Assume its 1.

          IF status.condition <> cse$illegal_command THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          status.normal := TRUE;
          get_page_attributes [1].menu_rows_displayed := 1;
        IFEND;
        rows_for_menu := get_page_attributes [1].menu_rows_displayed;
      ELSE
        called_from_screen_mode := FALSE;
        rows_to_use := 0; {Use all of the screen.
        interaction_info [1].key := osc$menu_rows;
        osp$get_interaction_information (interaction_info, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        rows_for_menu := interaction_info [1].menu_rows;
      IFEND;

      IF rows_for_menu = 0 THEN
        rows_for_menu := 1;
      IFEND;
      IF rows_for_menu = 2 THEN
        lines_for_menu := clc$lines_for_two_menu_rows;
      ELSE
        lines_for_menu := clc$lines_for_one_menu_row;
      IFEND;

      PUSH attachment_options: [1 .. 2];
      attachment_options^ [1].selector := fsc$access_and_share_modes;
      attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options^ [1].access_modes.value := $fst$file_access_options [fsc$read];
      attachment_options^ [1].share_modes.selector := fsc$determine_from_access_modes;
      attachment_options^ [2].selector := fsc$wait_for_attachment;
      attachment_options^ [2].wait_for_attachment.wait := osc$nowait;

      fsp$open_file (':$LOCAL.INPUT.1', amc$record, attachment_options, NIL, NIL, NIL, NIL, file_identifier,
            status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      input_file_opened := TRUE;

      csp$change_partial_screen (file_identifier, csc$screen_level, rows_to_use, old_interaction_style,
            display.reserved_rows, status);
      IF NOT status.normal THEN
        osp$set_status_condition (cle$unable_to_enter_screen_mode, status);
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      entered_screen_mode := TRUE;

      display.reserved_rows := display.reserved_rows + 1;
      IF NOT called_from_screen_mode THEN
        set_screen_dimensions;
      IFEND;
      device_attributes [1].key := csc$da_number_of_characters;
      device_attributes [2].key := csc$da_number_of_lines;
      csp$get_device_attributes (device_attributes, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      display.screen_width := device_attributes [1].number_of_characters;
      IF display.reserved_rows >= (lines_for_menu + 1) THEN
        display.screen_height := device_attributes [2].number_of_lines - display.reserved_rows;
        lines_used_by_trailer := display.reserved_rows;
      ELSE
        display.screen_height := device_attributes [2].number_of_lines - (lines_for_menu + 1);
        lines_used_by_trailer := lines_for_menu + 1;
      IFEND;
      dialog_box_max_lines := device_attributes [2].number_of_lines - (lines_for_menu + 1);
      message_field_width := display.screen_width - (clc$left_margin + clc$right_margin);

      determine_mouse_available;

      page_attributes [1].key := csc$page_changed_text_mode;
      page_attributes [1].changed_text_mode := TRUE;
      page_attributes [2].key := csc$left_mouse_button;
      page_attributes [2].left_button := 1;
      page_attributes [3].key := csc$right_mouse_button;
      page_attributes [3].right_button := 1;
      page_attributes [4].key := csc$menubar_file;
      IF display.mouse_available THEN
        page_attributes [4].menubar_enabled := TRUE;
        page_attributes [4].menubar_file := ':$LOCAL.CLF$PD_MENUBAR';
        command_line_number := 2;

        clp$include_line ('CLP$PD_BUILD_MENUBAR', FALSE, osc$null_name, status);
        status.normal := TRUE {ignore bad status} ;

      ELSE
        page_attributes [4].menubar_enabled := FALSE;
        command_line_number := 1;
      IFEND;

      csp$change_page_attributes (page_attributes, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      message_line_number := command_line_number + 1;
      IF support.nested_dialog_title <> NIL THEN
        title_box_top := message_line_number + 3;
      ELSEIF called_from_screen_mode THEN
        title_box_top := message_line_number + 2;
      ELSE
        title_box_top := message_line_number + 1;
      IFEND;
      lines_used_by_header := title_box_top + clc$lines_used_by_title - 1;
      dialog_box_top := title_box_top + 1;

      initialize_background_field (1, dialog_box_top, display.screen_width,
            display.screen_height - dialog_box_top + 1, background_field_number);
      initialize_function_key_menu (rows_for_menu);
      initialize_title_box;

      number_of_parameter_lines := display.screen_height - lines_used_by_header;
      IF called_from_screen_mode THEN
        number_of_parameter_lines := number_of_parameter_lines - 1;
      IFEND;
      IF display.parameter_count < number_of_parameter_lines THEN
        display.parameters_displayed := display.parameter_count;
      ELSE
        display.parameters_displayed := number_of_parameter_lines;
      IFEND;
      start_of_parameter_lines := lines_used_by_header + clc$blank_lines_after_header + 1;
      end_of_parameter_lines := start_of_parameter_lines + display.parameters_displayed - 1;
      dialog_box_max_lines := dialog_box_max_lines - lines_used_by_header;

      IF display.parameters_displayed > 0 THEN
        ALLOCATE parameter_display_info: [1 .. display.parameters_displayed];
      IFEND;

      initialize_command_field;
      initialize_message_field;
      IF display.parameter_count > 0 THEN
        create_prompt_and_value_fields;
        display.top_parameter := 1;
        update_parameter_display;
        cursor_field_number := parameter_display_info^ [1].value_field_number;
      ELSE
        cursor_field_number := display.command_field;
        update_lines_l_thru_m_of_n (0, 0, 0, display.line_number_field, display.buttons);
      IFEND;
      cursor_character_position := 1;
      cursor_line_number := 1;

    PROCEND setup_display;
?? TITLE := 'shut_down', EJECT ??

    PROCEDURE shut_down
      (    ignore_errors: boolean);

      VAR
        i: integer,
        ignore_rows: cst$lines_used;


      IF entered_screen_mode THEN
        csp$flush_events (status);
        IF NOT (status.normal OR ignore_errors) THEN
          EXIT clp$scl_parameter_dialog_mgr;
        ELSE
          status.normal := TRUE;
        IFEND;
        csp$change_partial_screen (file_identifier, csc$line_level, display.reserved_rows,
              old_interaction_style, ignore_rows, status);
        IF NOT (status.normal OR ignore_errors) THEN
          EXIT clp$scl_parameter_dialog_mgr;
        ELSE
          status.normal := TRUE;
        IFEND;
        entered_screen_mode := FALSE;
      IFEND;

      IF input_file_opened THEN
        fsp$close_file (file_identifier, status);
        IF NOT (status.normal OR ignore_errors) THEN
          EXIT clp$scl_parameter_dialog_mgr;
        ELSE
          status.normal := TRUE;
        IFEND;
        input_file_opened := FALSE;
      IFEND;

      IF display.help_window_displayed AND (help_window.contents <> NIL) THEN
        free_window_contents (help_window.contents);
      IFEND;

      IF display.message_window_displayed AND (message_window.contents <> NIL) THEN
        free_window_contents (message_window.contents);
      IFEND;

      IF display.zoom_window_displayed AND (zoom_window.contents <> NIL) THEN
        free_window_contents (zoom_window.contents);
      IFEND;

      IF parameter_display_info <> NIL THEN
        FREE parameter_display_info;
      IFEND;

      IF parameter_information <> NIL THEN
        FOR i := 1 TO display.parameter_count DO
          IF (NOT parameter_information^ [i].advanced_indicator) AND parameter_information^ [i].
                initialized AND (parameter_information^ [i].value <> NIL) THEN
            FREE parameter_information^ [i].value;
          IFEND;
        FOREND;
        FREE parameter_information;
      IFEND;

      IF display.command_text <> NIL THEN
        FREE display.command_text;
      IFEND;

      IF cleared_parameters <> NIL THEN
        FOR i := 1 TO UPPERBOUND (cleared_parameters^) DO
          IF cleared_parameters^ [i] <> NIL THEN
            FREE cleared_parameters^ [i];
          IFEND;
        FOREND;
        FREE cleared_parameters;
      IFEND;

      IF menu_list_copy <> NIL THEN
        FREE menu_list_copy;
      IFEND;

      IF menu_classes_copy <> NIL THEN
        FREE menu_classes_copy;
      IFEND;

    PROCEND shut_down;
?? TITLE := 'update_lines_l_thru_m_of_n', EJECT ??

    PROCEDURE update_lines_l_thru_m_of_n
      (    line_number: integer;
           lines_per_page: 0 .. csc$max_line_number;
           total_lines: integer;
           field_number: cst$field_number;
       VAR buttons: clt$dialog_buttons);

      VAR
        button: ^clt$dialog_button,
        button_field: clt$field_attributes,
        button_x_position: cst$x_position,
        end_of_text: boolean,
        field_attributes: array [1 .. 2] of cst$field_attribute,
        l_text: string (csc$max_x_position),
        l_text_length: integer,
        m_text: string (csc$max_x_position),
        m_text_length: integer,
        message_parameters: array [1 .. 3] of ^ost$message_parameter,
        message_text: string (csc$max_x_position),
        n_text: string (csc$max_x_position),
        n_text_length: integer,
        text_length: 0 .. csc$max_x_position;


      IF line_number <> 0 THEN
        STRINGREP (l_text, l_text_length, line_number);
        STRINGREP (m_text, m_text_length, (line_number + lines_per_page - 1));
        STRINGREP (n_text, n_text_length, total_lines);
        message_parameters [1] := ^l_text (1, l_text_length);
        message_parameters [2] := ^m_text (1, m_text_length);
        message_parameters [3] := ^n_text (1, n_text_length);
        get_message_text (clc$lines_l_through_m_size_n, ^message_parameters, message_text, text_length);
      ELSE
        get_message_text (clc$no_parameters_label, NIL, message_text, text_length);
      IFEND;
      field_attributes [1].key := csc$fld_visible_characters;
      field_attributes [1].visible_characters := text_length;
      field_attributes [2].key := csc$fld_x_position;
      field_attributes [2].x_position := display.screen_width - (clc$title_line_number_inset + text_length) +
            1;
      csp$change_field_attributes (field_number, field_attributes, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      csp$change_io_position (field_number, 1, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      end_of_text := FALSE;
      csp$put_text (^message_text (1, text_length), TRUE, end_of_text, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;

      IF NOT display.mouse_available THEN
        RETURN;
      IFEND;

      button_x_position := field_attributes [2].x_position;
      button_field := clv$default_field_attributes;
      field_attributes [2].key := csc$fld_y_position;
      csp$get_field_attributes (field_number, field_attributes, status);
      IF NOT status.normal THEN
        EXIT clp$scl_parameter_dialog_mgr;
      IFEND;
      button_field [y_position_attribute].y_position := field_attributes [2].y_position;

      buttons.page_up_button.active := line_number > 1;
      buttons.page_down_button.active := (line_number + lines_per_page - 1) < total_lines;
      button := buttons.first;
      WHILE button <> NIL DO
        button_x_position := button_x_position - 1 - button^.name_size;
        IF button^.field <> 0 THEN
          csp$delete_field (button^.field, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          button^.field := 0;
        IFEND;
        IF button^.active THEN
          button_field [x_position_attribute].x_position := button_x_position;
          button_field [visible_characters_attribute].visible_characters := button^.name_size;
          button_field [characters_attribute].characters := button_field [3].visible_characters;
          csp$allocate_field (button_field, button^.field, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$change_io_position (button^.field, 1, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          end_of_text := FALSE;
          csp$put_text (^button^.name (1, button^.name_size), TRUE, end_of_text, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        IFEND;
        button := button^.link;
      WHILEND;

    PROCEND update_lines_l_thru_m_of_n;
?? TITLE := 'update_parameter_display', EJECT ??

    PROCEDURE update_parameter_display;


      IF display.parameter_count > 0 THEN
        parameter_number := display.top_parameter;
        WHILE (parameter_number <= display.parameter_count) AND
              ((parameter_number - display.top_parameter) < display.parameters_displayed) DO
          IF (NOT parameter_information^ [parameter_number].advanced_indicator) AND
                (NOT parameter_information^ [parameter_number].initialized) THEN
            initialize_prompt_and_value (parameter_information^ [parameter_number].pdt_number);
          IFEND;
          display_prompt_and_value;
          parameter_number := parameter_number + 1;
        WHILEND;

        update_lines_l_thru_m_of_n (display.top_parameter, display.parameters_displayed,
              display.parameter_count, display.line_number_field, display.buttons);
      IFEND;

    PROCEND update_parameter_display;
?? TITLE := 'update_window_display', EJECT ??

    PROCEDURE update_window_display
      (    window_kind: clt$window_kind);

      VAR
        end_of_text: boolean,
        i: 0 .. csc$max_line_number,
        text: ^string ( * );


      CASE window_kind OF
      = clc$help_window =
        FOR i := 1 TO help_window.lines_displayed DO
          csp$change_io_position (help_window.text_field, i, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          IF help_window.contents^ [i + help_window.top - 1] <> NIL THEN
            text := help_window.contents^ [i + help_window.top - 1];
          ELSE
            PUSH text: [0];
          IFEND;
          csp$put_text (text, TRUE, end_of_text, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        FOREND;
        update_lines_l_thru_m_of_n (help_window.top, help_window.lines_displayed, help_window.line_count,
              help_window.line_number_field, help_window.buttons);
      = clc$message_window =
        FOR i := 1 TO message_window.lines_displayed DO
          csp$change_io_position (message_window.text_field, i, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          csp$put_text (message_window.contents^ [i + message_window.top - 1], TRUE, end_of_text, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        FOREND;
        update_lines_l_thru_m_of_n (message_window.top, message_window.lines_displayed,
              message_window.line_count, message_window.line_number_field, message_window.buttons);
      = clc$zoom_window =
        FOR i := 1 TO zoom_window.lines_displayed DO
          csp$change_io_position (zoom_window.text_field, i, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
          IF zoom_window.contents^ [i + zoom_window.top - 1] <> NIL THEN
            text := zoom_window.contents^ [i + zoom_window.top - 1];
          ELSE
            PUSH text: [0];
          IFEND;
          csp$put_text (text, TRUE, end_of_text, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        FOREND;
        update_lines_l_thru_m_of_n (zoom_window.top, zoom_window.lines_displayed, zoom_window.line_count,
              zoom_window.line_number_field, zoom_window.buttons);
      ELSE
      CASEND;

    PROCEND update_window_display;
?? TITLE := 'zoom_command_line', EJECT ??

    PROCEDURE zoom_command_line;

      VAR
        box_lines: 0 .. csc$max_line_number,
        message_text: string (csc$max_x_position),
        text_length: 0 .. csc$max_x_position,
        title_text: string (csc$max_x_position),
        title_text_length: 0 .. csc$max_x_position;


      IF dialog_box_max_lines < clc$maximum_zoom_lines THEN
        box_lines := dialog_box_max_lines;
      ELSE
        box_lines := clc$maximum_zoom_lines;
      IFEND;

      change_menu_items (display.current_window, clc$zoom_window);
      get_function_key_message (clc$enter_command, NIL, message_text, text_length);
      get_message_text (clc$enter_command_title, NIL, title_text, title_text_length);
      create_window (clc$zoom_window, 1, dialog_box_top, display.screen_width, box_lines,
            message_text (1, text_length), title_text (1, title_text_length), FALSE);
      display_text_in_window (clc$zoom_window, display.command_text);
      update_lines_l_thru_m_of_n (zoom_window.top, zoom_window.lines_displayed, zoom_window.line_count,
            zoom_window.line_number_field, zoom_window.buttons);
      clear_command_field;

    PROCEND zoom_command_line;
?? TITLE := 'zoom_parameter', EJECT ??

    PROCEDURE zoom_parameter;

      VAR
        box_lines: 0 .. csc$max_line_number,
        i: cst$visible_character_position,
        message_text: string (csc$max_x_position),
        pdt_number: clt$parameter_number,
        text_length: 0 .. csc$max_x_position,
        title_text: string (csc$max_x_position),
        title_length: 0 .. csc$max_x_position;

?? NEWTITLE := 'zoom_boolean_parameter', EJECT ??

      PROCEDURE zoom_boolean_parameter;

        VAR
          boolean_items: array [1 .. 4] of clt$data_value,
          evaluate_the_parameter: boolean,
          ignore_selected_action: ^clt$data_value,
          ignore_selected_item_index: ^clt$data_value,
          items: ^clt$data_value,
          item_representation: ^clt$data_representation,
          item_representation_count: ^clt$data_representation_count,
          item_text: ^clt$string_value,
          parameter_value: clt$parameter_value,
          preselected_item: ^clt$data_value,
          reset_the_parameter: boolean,
          selected_item: ^clt$data_value,
          work_area: ^clt$work_area;


{ Create a clc$list clt$data_value to represent the booleans.

        boolean_items [1].kind := clc$list;
        boolean_items [1].element_value := ^boolean_items [2];
        boolean_items [1].link := ^boolean_items [3];
        boolean_items [1].generated_via_list_rest := FALSE;
        boolean_items [2].kind := clc$boolean;
        boolean_items [2].boolean_value.value := TRUE;
        boolean_items [2].boolean_value.kind := clc$yes_no_boolean;
        boolean_items [3].kind := clc$list;
        boolean_items [3].element_value := ^boolean_items [4];
        boolean_items [3].link := NIL;
        boolean_items [3].generated_via_list_rest := FALSE;
        boolean_items [4].kind := clc$boolean;
        boolean_items [4].boolean_value.value := FALSE;
        boolean_items [4].boolean_value.kind := clc$yes_no_boolean;

        items := ^boolean_items [1];
        preselected_item := NIL;

{ In order to obtain the a the item (boolean) to be preselected it may
{ be necessary to evaluate the parameter.  If so, there are two cases:
{ the user entered a value which has not yet been evaluated, or the
{ parameter's default must be evaluated.  In the latter case it is
{ necessary to restore the parameter's default after completing the
{ call to eup$get_item_selections.

      /get_preselected_item/
        BEGIN
          support.get_parameter_value^ (pdt_number, parameter_value, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          ELSEIF parameter_information^ [parameter_number].evaluation_required THEN
            evaluate_the_parameter := TRUE;
            reset_the_parameter := FALSE;
          ELSEIF parameter_value.specified THEN
            evaluate_the_parameter := FALSE;
            reset_the_parameter := FALSE;
          ELSEIF parameter_information^ [parameter_number].value^ <> '' THEN
            evaluate_the_parameter := TRUE;
            reset_the_parameter := TRUE;
          ELSE
            EXIT /get_preselected_item/;
          IFEND;
          IF evaluate_the_parameter THEN
            support.evaluate_parameter^ (pdt_number, parameter_information^ [parameter_number].value^,
                  status);
            IF NOT status.normal THEN
              status.normal := TRUE;
              EXIT /get_preselected_item/;
            IFEND;
            support.get_parameter_value^ (pdt_number, parameter_value, status);
            IF NOT status.normal THEN
              EXIT clp$scl_parameter_dialog_mgr;
            IFEND;
          IFEND;
          IF parameter_value.value <> NIL THEN
            PUSH preselected_item;
            preselected_item^.kind := clc$list;
            preselected_item^.element_value := parameter_value.value;
            preselected_item^.link := NIL;
            preselected_item^.generated_via_list_rest := FALSE;
          IFEND;
        END /get_preselected_item/;

{ Create a work_area large enough to hold a clc$list clt$data_value containing
{ an item (boolean), the source representation of that boolean, and
{ a clc$list clt$data_value containing the index of the selected item.

        PUSH work_area: [[REP 2 * 2 OF clt$data_value, clt$data_representation_count,
              clt$string_size, REP osc$max_name_size OF char]];
        RESET work_area;

        eup$get_item_selections (items, preselected_item, FALSE, NIL,
              ^parameter_information^ [parameter_number].name, clc$dialog_box_inset,
              dialog_box_top + 1, osc$max_name_size, NIL, work_area, ignore_selected_action,
              selected_item, ignore_selected_item_index, status);
        IF NOT status.normal THEN
          IF status.condition = cle$command_cancelled THEN
            status.normal := TRUE;
            IF reset_the_parameter THEN
              support.restore_parameter_default^ (pdt_number, status);
              IF NOT status.normal THEN
                EXIT clp$scl_parameter_dialog_mgr;
              IFEND;
            IFEND;
            RETURN;
          IFEND;
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;

        IF reset_the_parameter THEN
          support.restore_parameter_default^ (pdt_number, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        IFEND;

        IF (selected_item = NIL) OR (selected_item^.element_value = NIL) THEN
          RETURN;
        IFEND;
        selected_item := selected_item^.element_value;

{ clc$labelled_elem_representation is used rather than clc$data_source_representation
{ so that the boolean will be displayed in lower case

        clp$convert_data_to_string (selected_item, clc$labeled_elem_representation, clc$max_string_size,
              work_area, item_representation, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        item_text := clp$data_representation_text (item_representation);

        IF parameter_information^ [parameter_number].value^ = item_text^ THEN
          RETURN;
        IFEND;

        FREE parameter_information^ [parameter_number].value;
        ALLOCATE parameter_information^ [parameter_number].value: [STRLENGTH (item_text^)];
        parameter_information^ [parameter_number].value^ := item_text^;
        parameter_information^ [parameter_number].evaluation_required := TRUE;
        parameter_information^ [parameter_number].too_big_to_edit := FALSE;

        update_parameters := TRUE;

      PROCEND zoom_boolean_parameter;
?? TITLE := 'zoom_file_parameter', EJECT ??

      PROCEDURE zoom_file_parameter;

        VAR
          ignore_selected_action: ^clt$data_value,
          initial_file_reference: ^fst$file_reference,
          selected_file: ^fst$file_reference,
          selected_file_container: string (fsc$max_path_size);


        IF parameter_information^ [parameter_number].value^ <> '' THEN
          initial_file_reference := parameter_information^ [parameter_number].value;
        ELSE
          initial_file_reference := ^current_file_selection;
        IFEND;

        eup$get_file_selection (initial_file_reference^, ^parameter_information^ [parameter_number].name,
              clc$dialog_box_inset, dialog_box_top + 1, NIL, NIL, selected_file_container, selected_file,
              ignore_selected_action, status);
        IF NOT status.normal THEN
          IF status.condition = cle$command_cancelled THEN
            status.normal := TRUE;
            RETURN;
          IFEND;
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;

        IF parameter_information^ [parameter_number].value^ = selected_file^ THEN
          RETURN;
        IFEND;

        current_file_selection := selected_file^;

        FREE parameter_information^ [parameter_number].value;
        ALLOCATE parameter_information^ [parameter_number].value: [STRLENGTH (selected_file^)];
        #TRANSLATE (osv$upper_to_lower, selected_file^, parameter_information^ [parameter_number].value^);
        parameter_information^ [parameter_number].evaluation_required := TRUE;
        parameter_information^ [parameter_number].too_big_to_edit := FALSE;

        update_parameters := TRUE;

      PROCEND zoom_file_parameter;
?? TITLE := 'zoom_keyword_parameter', EJECT ??

      PROCEDURE zoom_keyword_parameter
        (    multiple_selections: boolean;
             keywords: ^clt$keyword_specifications);

        CONST
          advanced_keyword_separator = '-------------------------------';

        VAR
          current_keyword: 0 .. clc$max_keywords,
          evaluate_the_parameter: boolean,
          first_advanced_keyword: 0 .. clc$max_keywords,
          i: 1 .. clc$max_keywords,
          ignore_selected_action: ^clt$data_value,
          ignore_selected_item_indices: ^clt$data_value,
          items: ^clt$data_value,
          item_count: 0 .. clc$max_keywords,
          item_node: ^^clt$data_value,
          items_representation: ^clt$data_representation,
          items_representation_count: ^clt$data_representation_count,
          items_text: ^clt$string_value,
          keyword_items: ^array [1 .. * ] of clt$data_value,
          parameter_value: clt$parameter_value,
          preselected_items: ^clt$data_value,
          reset_the_parameter: boolean,
          selected_items: ^clt$data_value,
          work_area: ^clt$work_area;


{ Count the number of items (keywords) to be presented .

        first_advanced_keyword := 0;
        item_count := 0;

        FOR i := 1 TO UPPERBOUND (keywords^) DO
          IF keywords^ [i].class = clc$nominal_entry THEN
            CASE keywords^ [i].availability OF
            = clc$normal_usage_entry =
              item_count := item_count + 1;
            = clc$advanced_usage_entry =

{ Present all advanced usage keywords following normal usage keywords
{ preceeded by a separating line.

              IF first_advanced_keyword = 0 THEN
                first_advanced_keyword := i;
                item_count := item_count + 1;
              IFEND;
              item_count := item_count + 1;
            ELSE {clc$hidden_usage_entry}

{ Do not present hidden usage keywords.

            CASEND;
          IFEND;
        FOREND;

{ Create a clc$list clt$data_value to represent the keywords to be presented.

        PUSH keyword_items: [1 .. item_count * 2];
        current_keyword := 0;

        FOR i := 1 TO UPPERBOUND (keywords^) DO
          IF (keywords^ [i].class = clc$nominal_entry) AND
                (keywords^ [i].availability = clc$normal_usage_entry) THEN
            current_keyword := current_keyword + 1;
            keyword_items^ [current_keyword].kind := clc$keyword;
            keyword_items^ [current_keyword].keyword_value := keywords^ [i].keyword;
          IFEND;
        FOREND;

        IF first_advanced_keyword > 0 THEN
          current_keyword := current_keyword + 1;
          keyword_items^ [current_keyword].kind := clc$keyword;
          keyword_items^ [current_keyword].keyword_value := advanced_keyword_separator;
          FOR i := first_advanced_keyword TO UPPERBOUND (keywords^) DO
            IF (keywords^ [i].class = clc$nominal_entry) AND
                  (keywords^ [i].availability = clc$advanced_usage_entry) THEN
              current_keyword := current_keyword + 1;
              keyword_items^ [current_keyword].kind := clc$keyword;
              keyword_items^ [current_keyword].keyword_value := keywords^ [i].keyword;
            IFEND;
          FOREND;
        IFEND;

        FOR i := item_count + 1 TO item_count * 2 DO
          keyword_items^ [i].kind := clc$list;
          keyword_items^ [i].element_value := ^keyword_items^ [i - item_count];
          IF i < (item_count * 2) THEN
            keyword_items^ [i].link := ^keyword_items^ [i + 1];
          ELSE
            keyword_items^ [i].link := NIL;
          IFEND;
          keyword_items^ [i].generated_via_list_rest := FALSE;
        FOREND;

        items := ^keyword_items^ [item_count + 1];
        preselected_items := NIL;

{ In order to obtain the a list if the items (keywords) to be preselected
{ it may be necessary to evaluate the parameter.  If so, there are two
{ cases: the user entered a value which has not yet been evaluated, or
{ the parameter's default must be evaluated.  In the latter case it is
{ necessary to restore the parameter's default after completing the
{ call to eup$get_item_selections.

      /get_preselected_items/
        BEGIN
          support.get_parameter_value^ (pdt_number, parameter_value, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          ELSEIF parameter_information^ [parameter_number].evaluation_required THEN
            evaluate_the_parameter := TRUE;
            reset_the_parameter := FALSE;
          ELSEIF parameter_value.specified THEN
            evaluate_the_parameter := FALSE;
            reset_the_parameter := FALSE;
          ELSEIF parameter_information^ [parameter_number].value^ <> '' THEN
            evaluate_the_parameter := TRUE;
            reset_the_parameter := TRUE;
          ELSE
            EXIT /get_preselected_items/;
          IFEND;
          IF evaluate_the_parameter THEN
            support.evaluate_parameter^ (pdt_number, parameter_information^ [parameter_number].value^,
                  status);
            IF NOT status.normal THEN
              status.normal := TRUE;
              EXIT /get_preselected_items/;
            IFEND;
            support.get_parameter_value^ (pdt_number, parameter_value, status);
            IF NOT status.normal THEN
              EXIT clp$scl_parameter_dialog_mgr;
            IFEND;
          IFEND;
          IF parameter_value.value <> NIL THEN
            IF multiple_selections THEN
              preselected_items := parameter_value.value;
            ELSE
              PUSH preselected_items;
              preselected_items^.kind := clc$list;
              preselected_items^.element_value := parameter_value.value;
              preselected_items^.link := NIL;
              preselected_items^.generated_via_list_rest := FALSE;
            IFEND;
          IFEND;
        END /get_preselected_items/;

{ Create a work_area large enough to hold a clc$list clt$data_value containing
{ all presented items (keywords), the source representation of that list, and
{ a clc$list clt$data_value containing indices for all presented items.

        PUSH work_area: [[REP item_count * 2 * 2 OF clt$data_value, clt$data_representation_count,
              clt$string_size, REP item_count * (osc$max_name_size + 2) OF char]];
        RESET work_area;

        eup$get_item_selections (items, preselected_items, multiple_selections, NIL,
              ^parameter_information^ [parameter_number].name, clc$dialog_box_inset,
              dialog_box_top + 1, osc$max_name_size, NIL, work_area, ignore_selected_action,
              selected_items, ignore_selected_item_indices, status);
        IF NOT status.normal THEN
          IF status.condition = cle$command_cancelled THEN
            status.normal := TRUE;
            IF reset_the_parameter THEN
              support.restore_parameter_default^ (pdt_number, status);
              IF NOT status.normal THEN
                EXIT clp$scl_parameter_dialog_mgr;
              IFEND;
            IFEND;
            RETURN;
          IFEND;
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;

        IF reset_the_parameter THEN
          support.restore_parameter_default^ (pdt_number, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        IFEND;

        IF first_advanced_keyword > 0 THEN
          item_node := ^selected_items;

{ Ensure that the separator between "normal" and "advanced" keywords is not
{ present in the result list.

        /remove_separator/
          WHILE item_node^ <> NIL DO
            IF item_node^^.element_value^.keyword_value = advanced_keyword_separator THEN
              item_node^ := item_node^^.link;
              EXIT /remove_separator/;
            IFEND;
            item_node := ^item_node^^.link;
          WHILEND /remove_separator/;
        IFEND;

        IF (selected_items = NIL) OR (selected_items^.element_value = NIL) THEN
          RETURN;
        ELSEIF NOT multiple_selections THEN
          selected_items := selected_items^.element_value;
        IFEND;

{ clc$labelled_elem_representation is used rather than clc$data_source_representation
{ so that the keywords will be displayed in lower case

        clp$convert_data_to_string (selected_items, clc$labeled_elem_representation, clc$max_string_size,
              work_area, items_representation, status);
        IF NOT status.normal THEN
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;
        items_text := clp$data_representation_text (items_representation);

        IF parameter_information^ [parameter_number].value^ = items_text^ THEN
          RETURN;
        IFEND;

        FREE parameter_information^ [parameter_number].value;
        ALLOCATE parameter_information^ [parameter_number].value: [STRLENGTH (items_text^)];
        parameter_information^ [parameter_number].value^ := items_text^;
        parameter_information^ [parameter_number].evaluation_required := TRUE;

        RESET items_representation;
        NEXT items_representation_count IN items_representation;
        parameter_information^ [parameter_number].too_big_to_edit := (items_representation_count^ > 1);

        update_parameters := TRUE;

      PROCEND zoom_keyword_parameter;
?? TITLE := 'zoom_record_parameter', EJECT ??

      PROCEDURE zoom_record_parameter;

        VAR
          evaluate_the_parameter: boolean,
          expression_text: ^clt$expression_text,
          parameter_value: clt$parameter_value,
          reset_the_parameter: boolean,
          value_representation: ^clt$data_representation,
          value_representation_count: ^clt$data_representation_count,
          value_representation_text: ^clt$string_value;


{ In order to obtain the current field values it may be necessary to evaluate
{ the parameter.  If so, there are two cases: the user entered a value which
{ has not yet been evaluated, or the parameter's default must be evaluated.
{ In the latter case it is necessary to restore the parameter's default after
{ completing the call to support.nested_dialog.

      /establish_current_values/
        BEGIN
          support.get_parameter_value^ (pdt_number, parameter_value, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          ELSEIF parameter_information^ [parameter_number].evaluation_required THEN
            evaluate_the_parameter := TRUE;
            reset_the_parameter := FALSE;
          ELSEIF parameter_value.specified THEN
            evaluate_the_parameter := FALSE;
            reset_the_parameter := FALSE;
          ELSEIF parameter_information^ [parameter_number].value^ <> '' THEN
            evaluate_the_parameter := TRUE;
            reset_the_parameter := TRUE;
          ELSE
            EXIT /establish_current_values/;
          IFEND;
          IF evaluate_the_parameter THEN
            support.evaluate_parameter^ (pdt_number, parameter_information^ [parameter_number].value^,
                  status);
            IF NOT status.normal THEN
              status.normal := TRUE;
            IFEND;
          IFEND;
        END /establish_current_values/;

        support.get_parameter_value_source^ (pdt_number, clc$max_string_size, value_representation, status);
        IF status.normal THEN
          value_representation_text := clp$data_representation_text (value_representation);
          PUSH expression_text: [STRLENGTH (value_representation_text^)];
          expression_text^ := value_representation_text^;
        ELSE
          PUSH expression_text: [0];
        IFEND;

        support.nested_dialog^ (expression_text^, pdt.type_descriptions^ [pdt_number].fields_pdt^,
              parameter_information^ [parameter_number].name, clc$max_string_size, value_representation,
              status);
        IF NOT status.normal THEN
          IF (status.condition = cle$command_cancelled) OR (status.condition = cle$function_cancelled) THEN
            status.normal := TRUE;
            IF reset_the_parameter THEN
              support.restore_parameter_default^ (pdt_number, status);
              IF NOT status.normal THEN
                EXIT clp$scl_parameter_dialog_mgr;
              IFEND;
            IFEND;
            RETURN;
          IFEND;
          EXIT clp$scl_parameter_dialog_mgr;
        IFEND;

        value_representation_text := clp$data_representation_text (value_representation);

        IF parameter_information^ [parameter_number].value^ = value_representation_text^ THEN
          IF reset_the_parameter THEN
            support.restore_parameter_default^ (pdt_number, status);
            IF NOT status.normal THEN
              EXIT clp$scl_parameter_dialog_mgr;
            IFEND;
          IFEND;
          RETURN;
        IFEND;

        FREE parameter_information^ [parameter_number].value;
        ALLOCATE parameter_information^ [parameter_number].value: [STRLENGTH (value_representation_text^)];
        parameter_information^ [parameter_number].value^ := value_representation_text^;
        parameter_information^ [parameter_number].evaluation_required := TRUE;

        RESET value_representation;
        NEXT value_representation_count IN value_representation;
        parameter_information^ [parameter_number].too_big_to_edit := (value_representation_count^ > 1);

        update_parameters := TRUE;

        IF reset_the_parameter THEN
          support.restore_parameter_default^ (pdt_number, status);
          IF NOT status.normal THEN
            EXIT clp$scl_parameter_dialog_mgr;
          IFEND;
        IFEND;

      PROCEND zoom_record_parameter;
?? OLDTITLE, EJECT ??

      pdt_number := parameter_information^ [parameter_number].pdt_number;

      IF (pdt.parameters^ [pdt_number].passing_method = clc$pass_by_value) AND
         (action_number <> edit_zoom_event) THEN
        CASE pdt.type_descriptions^ [pdt_number].kind OF
        = clc$boolean_type =
          zoom_boolean_parameter;
          RETURN;
        = clc$file_type =
          zoom_file_parameter;
          RETURN;
        = clc$keyword_type =
          zoom_keyword_parameter (FALSE, pdt.type_descriptions^ [pdt_number].keyword_specifications);
          RETURN;
        = clc$list_type =
          IF (pdt.type_descriptions^ [pdt_number].list_element_type_description <> NIL) AND
                (pdt.type_descriptions^ [pdt_number].list_element_type_description^.kind =
                clc$keyword_type) THEN
            zoom_keyword_parameter (TRUE, pdt.type_descriptions^ [pdt_number].
                  list_element_type_description^.keyword_specifications);
            RETURN;
          IFEND;
        = clc$record_type =
          zoom_record_parameter;
          RETURN;
        ELSE
          ;
        CASEND;
      IFEND;

      IF dialog_box_max_lines < clc$maximum_zoom_lines THEN
        box_lines := dialog_box_max_lines;
      ELSE
        box_lines := clc$maximum_zoom_lines;
      IFEND;
      title_length := STRLENGTH (parameter_information^ [parameter_number].prompt);

      change_menu_items (display.current_window, clc$zoom_window);

    /left_justify_title/
      FOR i := 1 TO STRLENGTH (parameter_information^ [parameter_number].prompt) DO
        IF parameter_information^ [parameter_number].prompt (i) <> ' ' THEN
          EXIT /left_justify_title/;
        IFEND;
        title_length := title_length - 1;
      FOREND /left_justify_title/;
      get_function_key_message (clc$enter_parameter_value, NIL, message_text, text_length);
      title_text := ' ';
      title_text (2, title_length) := parameter_information^ [parameter_number].prompt (i, title_length);
      IF title_length <> 0 THEN
        create_window (clc$zoom_window, 1, dialog_box_top, display.screen_width, box_lines,
              message_text (1, text_length), title_text (1, title_length + 2),
              parameter_information^ [parameter_number].too_big_to_edit);
      ELSE
        create_window (clc$zoom_window, 1, dialog_box_top, display.screen_width, box_lines,
              message_text (1, text_length), ' ', FALSE);
      IFEND;
      display_text_in_window (clc$zoom_window, parameter_information^ [parameter_number].value);
      update_lines_l_thru_m_of_n (zoom_window.top, zoom_window.lines_displayed, zoom_window.line_count,
            zoom_window.line_number_field, zoom_window.buttons);
      zoom_window.parameter_value := TRUE;
      zoom_window.parameter_number := parameter_number;
      zoom_window.changeable := NOT parameter_information^ [parameter_number].too_big_to_edit;
      IF parameter_information^ [parameter_number].too_big_to_edit THEN
        get_message_text (clc$too_big_to_edit, NIL, message_text, text_length);
        display_message (message_text (1, text_length));
      IFEND;

    PROCEND zoom_parameter;
?? OLDTITLE, EJECT ??

    initial_status := status;
    status.normal := TRUE;
    cancel := FALSE;
    cleared_parameters := NIL;
    current_file_selection := ':$WORKING_CATALOG';
    display.command_text := NIL;
    display.help_window_displayed := FALSE;
    display.message_window_displayed := FALSE;
    display.zoom_window_displayed := FALSE;
    display.current_window := clc$no_window;
    display.screen_width := 1;
    display.screen_height := 1;
    display.help_module := NIL;
    entered_screen_mode := FALSE;
    ignore_tab_caused_by_next := FALSE;
    input_file_opened := FALSE;
    menu_classes := NIL;
    menu_classes_copy := NIL;
    menu_list := NIL;
    menu_list_copy := NIL;
    message_displayed := FALSE;
    message_field_width := 0;
    message_read := FALSE;
    parameter_display_info := NIL;
    parameter_information := NIL;
    status_condition_name := '';
    update_parameters := FALSE;

    osp$establish_condition_handler (^condition_handler, TRUE);

    editing_parameter_list := support.change_expression_save <> NIL;
    construct_parameter_information;
    setup_display;
    process_keyboard;
    shut_down ({ignore_errors =} FALSE);
    osp$disestablish_cond_handler;

  PROCEND clp$scl_parameter_dialog_mgr;

MODEND clm$scl_parameter_dialog;
*DECK DECK=CLM$SCL_SIGNAL_HANDLER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Signal Handler Module' ??
MODULE clm$scl_signal_handler;

{
{ PURPOSE:
{
{   This module contains the procedures that send and receive signals
{   on behalf of the SCL interpreter.
{
{   The only SCL signal currently defined is used when processing the EXIT
{   control statement if the "target block" of the exit belongs to an
{   ancester of the task issuing the EXIT statement.  The handler for this
{   signal receives control in the "target task", terminates its synchronous
{   child task (which may in turn have to terminate its descendents), then
{   causes the CLC$EXITING_CONDITION in the "target task".
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$exiting_condition
*copyc clt$block
*copyc clt$scl_signal
*copyc ost$global_task_id
*copyc ost$status
?? POP ??
*copyc pmp$cause_task_condition
*copyc pmp$get_global_task_id
*copyc pmp$log
*copyc pmp$send_signal
*copyc pmp$terminate
?? TITLE := 'clp$scl_signal_handler', EJECT ??
*copyc clh$scl_signal_handler

  PROCEDURE [XDCL] clp$scl_signal_handler
    (    originator: ost$global_task_id;
         signal: pmt$signal);

    VAR
      ignore_status: ost$status,
      scl_signal: clt$scl_signal;


    scl_signal.signal := signal;
    CASE scl_signal.identifier OF

    = clc$scl_signal =
      CASE scl_signal.contents.kind OF

      = clc$signal_exiting =
        pmp$terminate (scl_signal.contents.child_task_id, ignore_status);
        IF scl_signal.contents.exit_control_block <> NIL THEN
          pmp$cause_task_condition (clc$exiting_condition, scl_signal.contents.exit_control_block,
                {notify_scl=} FALSE, {notify_debug=} FALSE, {propagate_to_parent=} FALSE,
                {call_default_handler=} FALSE, ignore_status);
        IFEND;

      ELSE
        pmp$log ('--  Unexpected SCL signal kind: signal ignored', ignore_status);
      CASEND;

    ELSE
      pmp$log ('--  Unexpected SCL signal identifier: signal ignored', ignore_status);
    CASEND;

  PROCEND clp$scl_signal_handler;
?? TITLE := 'clp$send_exiting_signal', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$send_exiting_signal
    (    target_task_id: pmt$task_id;
         targets_child_task_id: pmt$task_id;
         exit_control_block: ^clt$block;
     VAR status: ost$status);

    VAR
      scl_signal: clt$scl_signal,
      target_gtid: ost$global_task_id;


    pmp$get_global_task_id (target_task_id, target_gtid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    scl_signal.identifier := clc$scl_signal;
    scl_signal.contents.kind := clc$signal_exiting;
    scl_signal.contents.child_task_id := targets_child_task_id;
    scl_signal.contents.exit_control_block := exit_control_block;

    pmp$send_signal (target_gtid, scl_signal.signal, status);

  PROCEND clp$send_exiting_signal;

MODEND clm$scl_signal_handler;
*DECK DECK=CLM$SET_COMMAND_LIST EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Command List Manipulation Commands' ??
MODULE clm$set_command_list;

{
{ PURPOSE:
{   This module contains the processors for the follwoing commands:
{
{               change_command_search_mode
{               change_system_command_library     advanced
{               create_command_list_entry
{               delete_command_list_entry
{               set_command_list                  hidden
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$all_must_be_used_alone
*copyc cle$ecc_command_processing
*copyc cle$ecc_parameter_list
*copyc cle$ecc_utilities
*copyc clt$command_list
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc ost$caller_identifier
*copyc ost$name_reference
*copyc ost$status
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$add_file_to_command_list
*copyc clp$delete_all_from_cmnd_list
*copyc clp$delete_file_from_cmnd_list
*copyc clp$establish_sys_command_lib
*copyc clp$reverse_list
*copyc clp$set_job_command_search_mode
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
*copyc osp$generate_output_message
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osv$initial_exception_context
?? TITLE := 'clp$_set_command_list', EJECT ??

  PROCEDURE [XDCL] clp$_set_command_list
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (HIDDEN, osm$setcl) set_command_list, setcl (
{   delete, d: any of
{       key
{         all
{       keyend
{       list of any of
{         key
{           $system
{         advanced_key
{           fence
{         keyend
{         file
{       anyend
{     anyend = $optional
{   add, a: list of any of
{       key
{         $system
{       advanced_key
{         fence
{       keyend
{       file
{     anyend = $optional
{   search_mode, sm: key
{       (global, g)
{       (restricted, r)
{       (exclusive, e)
{     keyend = $optional
{   placement, p: key
{       (after, a)
{       (before, b)
{     keyend = before
{   system_command_library, scl: any of
{       key
{         (standard, s)
{       hidden_key
{         none
{       keyend
{       file
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] 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,
          element_type_spec: 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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (6),
      recend,
      type5: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 1, 30, 14, 43, 56, 772],
    clc$command, 11, 6, 0, 0, 0, 0, 6, 'OSM$SETCL'], [
    ['A                              ',clc$abbreviation_entry, 2],
    ['ADD                            ',clc$nominal_entry, 2],
    ['D                              ',clc$abbreviation_entry, 1],
    ['DELETE                         ',clc$nominal_entry, 1],
    ['P                              ',clc$abbreviation_entry, 4],
    ['PLACEMENT                      ',clc$nominal_entry, 4],
    ['SCL                            ',clc$abbreviation_entry, 5],
    ['SEARCH_MODE                    ',clc$nominal_entry, 3],
    ['SM                             ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 6],
    ['SYSTEM_COMMAND_LIBRARY         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 184,
  clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 120,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 141,
  clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    120, [[1, 0, clc$list_type], [104, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
        FALSE, 2],
        81, [[1, 0, clc$keyword_type], [2], [
          ['$SYSTEM                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
          ['FENCE                          ', clc$nominal_entry, clc$advanced_usage_entry, 2]]
          ],
        3, [[1, 0, clc$file_type]]
        ]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [104, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
      FALSE, 2],
      81, [[1, 0, clc$keyword_type], [2], [
        ['$SYSTEM                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['FENCE                          ', clc$nominal_entry, clc$advanced_usage_entry, 2]]
        ],
      3, [[1, 0, clc$file_type]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [6], [
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['EXCLUSIVE                      ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['G                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['GLOBAL                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['RESTRICTED                     ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [4], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['AFTER                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['BEFORE                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'before'],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['NONE                           ', clc$nominal_entry, clc$hidden_entry, 2],
      ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['STANDARD                       ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$delete = 1,
      p$add = 2,
      p$search_mode = 3,
      p$placement = 4,
      p$system_command_library = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$delete].specified THEN
      delete_command_list_entry (pvt [p$delete].value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$add].specified THEN
      create_command_list_entry (pvt [p$add].value, pvt [p$placement].value^.keyword_value (1), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$system_command_library].specified THEN
      change_system_command_library (pvt [p$system_command_library].value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$search_mode].specified THEN
      change_search_mode (pvt [p$search_mode].value^.keyword_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND clp$_set_command_list;
?? TITLE := 'clp$_delete_command_list_entry', EJECT ??

  PROCEDURE [XDCL] clp$_delete_command_list_entry
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$delcle) delete_command_list_entry, delete_command_list_entries, delcle (
{   entry, entries, e: any of
{       key
{         all
{       keyend
{       list of any of
{         key
{           $system
{         advanced_key
{           fence
{         keyend
{         file
{       anyend
{     anyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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,
          element_type_spec: 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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 1, 30, 14, 10, 55, 404],
    clc$command, 4, 2, 1, 0, 0, 0, 2, 'OSM$DELCLE'], [
    ['E                              ',clc$abbreviation_entry, 1],
    ['ENTRIES                        ',clc$alias_entry, 1],
    ['ENTRY                          ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 184,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    120, [[1, 0, clc$list_type], [104, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
        FALSE, 2],
        81, [[1, 0, clc$keyword_type], [2], [
          ['$SYSTEM                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
          ['FENCE                          ', clc$nominal_entry, clc$advanced_usage_entry, 2]]
          ],
        3, [[1, 0, clc$file_type]]
        ]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$entry = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    delete_command_list_entry (pvt [p$entry].value, status);

  PROCEND clp$_delete_command_list_entry;
?? TITLE := 'clp$_create_command_list_entry', EJECT ??

  PROCEDURE [XDCL] clp$_create_command_list_entry
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$crecle) create_command_list_entry, create_command_list_entries, crecle (
{   entry, entries, e: list of any of
{       key
{         $system
{       advanced_key
{         fence
{       keyend
{       file
{     anyend = $required
{   placement, p: key
{       (after, a)
{       (before, b)
{     keyend = before
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (6),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 1, 30, 14, 16, 27, 671],
    clc$command, 6, 3, 1, 0, 0, 0, 3, 'OSM$CRECLE'], [
    ['E                              ',clc$abbreviation_entry, 1],
    ['ENTRIES                        ',clc$alias_entry, 1],
    ['ENTRY                          ',clc$nominal_entry, 1],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PLACEMENT                      ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 120,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [104, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
      FALSE, 2],
      81, [[1, 0, clc$keyword_type], [2], [
        ['$SYSTEM                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['FENCE                          ', clc$nominal_entry, clc$advanced_usage_entry, 2]]
        ],
      3, [[1, 0, clc$file_type]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['AFTER                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['BEFORE                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'before'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$entry = 1,
      p$placement = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_command_list_entry (pvt [p$entry].value, pvt [p$placement].value^.keyword_value (1), status);

  PROCEND clp$_create_command_list_entry;
?? TITLE := 'clp$_change_command_search_mode', EJECT ??

  PROCEDURE [XDCL] clp$_change_command_search_mode
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$chacsm) change_command_search_mode, chacsm (
{   search_mode, sm: key
{       (global, g)
{       (restricted, r)
{       (exclusive, e)
{     keyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 6, 13, 15, 12, 12, 494],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$CHACSM'], [
    ['SEARCH_MODE                    ',clc$nominal_entry, 1],
    ['SM                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [6], [
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['EXCLUSIVE                      ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['G                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['GLOBAL                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['RESTRICTED                     ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$search_mode = 1,
    p$status = 2;

  VAR
    pvt: array [1 .. 2] of clt$parameter_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    change_search_mode (pvt [p$search_mode].value^.keyword_value, status);

  PROCEND clp$_change_command_search_mode;
?? TITLE := 'clp$_change_system_command_libr', EJECT ??

  PROCEDURE [XDCL] clp$_change_system_command_libr
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ADVANCED, osm$chascl) change_system_command_library, chascl (
{   system_command_library, scl: any of
{       key
{         (standard, s)
{       hidden_key
{         none
{       keyend
{       file
{     anyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 1, 30, 14, 29, 26, 472],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$CHASCL'], [
    ['SCL                            ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2],
    ['SYSTEM_COMMAND_LIBRARY         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 141,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['NONE                           ', clc$nominal_entry, clc$hidden_entry, 2],
      ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['STANDARD                       ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$system_command_library = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    change_system_command_library (pvt [p$system_command_library].value, status);

  PROCEND clp$_change_system_command_libr;
?? TITLE := 'delete_command_list_entry', EJECT ??

  PROCEDURE delete_command_list_entry
    (    delete_list: ^clt$data_value;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context,
      found_error: boolean,
      file: clt$command_list_entry_file,
      ignore_status: ost$status,
      local_status: ost$status,
      node: ^clt$data_value;

    PUSH context;
    found_error := FALSE;
    IF delete_list^.kind = clc$keyword {ALL} THEN
      REPEAT
        clp$delete_all_from_cmnd_list (status);
        IF NOT status.normal THEN
          context^ := osv$initial_exception_context;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
      RETURN;
    IFEND;

    node := delete_list;
    WHILE node <> NIL DO
      IF node^.element_value^.kind = clc$file THEN
        file.kind := clc$command_list_entry_path;
        file.path := node^.element_value^.file_value;
      ELSEIF node^.element_value^.keyword_value = '$SYSTEM' THEN
        file.kind := clc$command_list_entry_$system;
      ELSE {FENCE}
        file.kind := clc$command_list_entry_fence;
      IFEND;

      REPEAT
        clp$delete_file_from_cmnd_list (file, local_status);
        IF NOT local_status.normal THEN
          context^ := osv$initial_exception_context;
          IF file.kind = clc$command_list_entry_path THEN
            context^.file.selector := osc$ecp_file_reference;
            context^.file.file_reference := file.path;
          IFEND;
          context^.condition_status := local_status;
          osp$enforce_exception_policies (context^);
          local_status := context^.condition_status;
        IFEND;
      UNTIL local_status.normal OR (NOT osp$file_access_condition (local_status)) OR (NOT context^.wait);
      IF (NOT local_status.normal) THEN
        IF ((local_status.condition = cle$entry_not_in_command_list) OR
             (local_status.condition = cle$not_in_command_list)) THEN
          IF (NOT found_error) THEN
            found_error := TRUE;
            status := local_status;
          ELSE
            IF node^.element_value^.keyword_value = '$SYSTEM' THEN
              osp$append_status_parameter (',', '$SYSTEM', status);
            ELSE
              osp$append_status_parameter (',', file.path^, status);
            IFEND;
          IFEND;
        ELSE
          IF found_error THEN
            osp$generate_output_message(status,ignore_status);
          IFEND;
          status := local_status;
          RETURN;
        IFEND;
      IFEND;
      node := node^.link;
    WHILEND;

  PROCEND delete_command_list_entry;
?? TITLE := 'create_command_list_entry', EJECT ??

  PROCEDURE create_command_list_entry
    (   add_list: ^clt$data_value;
        placement: char;
     VAR status: ost$status);

    VAR
      append: boolean,
      context: ^ost$ecp_exception_context,
      file: clt$command_list_entry_file,
      node: ^clt$data_value;

    PUSH context;
    node := add_list;
    append := placement = 'A';

    IF NOT append THEN
      clp$reverse_list (node);
    IFEND;

    WHILE node <> NIL DO
      IF node^.element_value^.kind = clc$file THEN
        file.kind := clc$command_list_entry_path;
        file.path := node^.element_value^.file_value;
      ELSEIF node^.element_value^.keyword_value = '$SYSTEM' THEN
        file.kind := clc$command_list_entry_$system;
      ELSE
        file.kind := clc$command_list_entry_fence;
      IFEND;

      REPEAT
        clp$add_file_to_command_list (file, append, status);
        IF NOT status.normal THEN
          context^ := osv$initial_exception_context;
          IF file.kind = clc$command_list_entry_path THEN
            context^.file.selector := osc$ecp_file_reference;
            context^.file.file_reference := file.path;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      node := node^.link;
    WHILEND

  PROCEND create_command_list_entry;
?? TITLE := 'change_search_mode', EJECT ??

  PROCEDURE [INLINE] change_search_mode
    (    search_mode_keyword: clt$keyword;
     VAR status: ost$status);

    VAR
      search_mode: clt$command_search_modes;


    IF search_mode_keyword = 'EXCLUSIVE' THEN
      search_mode := clc$exclusive_command_search;
    ELSEIF search_mode_keyword = 'RESTRICTED' THEN
      search_mode := clc$restricted_command_search;
    ELSE {GLOBAL}
      search_mode := clc$global_command_search;
    IFEND;

    clp$set_job_command_search_mode (search_mode, status);

  PROCEND change_search_mode;
?? TITLE := 'change_system_command_library', EJECT ??

  PROCEDURE change_system_command_library
    (    system_command_library: ^clt$data_value;
     VAR status: ost$status);

    CONST
      standard_system_command_library = ':$SYSTEM.$SYSTEM.OSF$COMMAND_LIBRARY';

    VAR
      context: ^ost$ecp_exception_context,
      file: ^fst$file_reference;


    status.normal := TRUE;
    PUSH context;
    IF system_command_library^.kind = clc$file THEN
      file := system_command_library^.file_value;
    ELSEIF system_command_library^.keyword_value = 'STANDARD' THEN
      PUSH file: [STRLENGTH (standard_system_command_library)];
      file^ := standard_system_command_library;
    ELSE {NONE}
      file := NIL;
    IFEND;

    REPEAT
      clp$establish_sys_command_lib (file, status);
      IF NOT status.normal THEN
        context^ := osv$initial_exception_context;
        IF system_command_library^.kind = clc$file THEN
          context^.file.selector := osc$ecp_file_reference;
          context^.file.file_reference := file;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

  PROCEND change_system_command_library;

MODEND clm$set_command_list;
*DECK DECK=CLM$SET_DISP_MULTIPRO_OPTS_CMDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL_Interpreter: Multiprocessing Options Commands' ??
MODULE clm$set_disp_multipro_opts_cmds;

{ PURPOSE:
{   This module contains the processors for the set_multiprocessing_options command and the
{   display_multiprocessing_options command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc jmp$get_multipro_options_r3
*copyc jmp$set_multiprocessing_r3
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
?? EJECT ??
*copyc clv$nil_display_control
?? OLDTITLE ??
?? NEWTITLE := 'clp$display_multipro_opt_cmd ', EJECT ??

{ PURPOSE:
{   The purpose of this command is to display the multiprocessing permissions imposed on a job.
{
{   DISPLAY_MULTIPROCESSING_OPTIONS, DISMO [ OUTPUT  =  <file reference> ]
{                                          [ STATUS  = <status variable> ]
{           output, o:  This parameter specifies the file to which the information
{                       is displayed.  Omission causes $OUTPUT to be used.
{           status :    see ERROR HANDLING.

  PROCEDURE [XDCL] clp$display_multipro_opt_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status );

{ PROCEDURE display_multiprocessing_options, display_multiprocessing_option, dismo (
{   output, o: file = $output
{   status )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 9, 17, 7, 38, 29, 89],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

*copy clv$display_variables
?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;
*copy clp$new_page_procedure
?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle', EJECT ??

{ PURPOSE:
{   The display_multiprocessing_options command has no subtitles.  This is merely a dummy routine used to
{   keep the module consistant with those that do produce subtitles.

  PROCEDURE put_subtitle
    (VAR display_control: clt$display_control;
     VAR status: ost$status);

    status.normal := TRUE;

  PROCEND put_subtitle;
?? OLDTITLE, EJECT ??

    VAR
      data_string: string(35),
      display_control: clt$display_control,
      ignore_status: ost$status,
      multiprocessing_allowed: boolean,
      ring_attributes: amt$ring_attributes;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$get_multipro_options_r3 (multiprocessing_allowed, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF multiprocessing_allowed THEN
      data_string := ' Multiprocessing allowed';
    ELSE
      data_string := ' Multiprocessing not allowed';
    IFEND;

    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    osp$establish_block_exit_hndlr (^abort_handler);

    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          ring_attributes, display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    clv$titles_built := FALSE;
    clv$command_name := 'display_multiprocessing_options';

    clp$put_display (display_control, data_string, clc$trim, status);
    IF status.normal THEN
      clp$close_display (display_control, status);
    ELSE
      clp$close_display (display_control, ignore_status);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND clp$display_multipro_opt_cmd;
?? OLDTITLE ??
?? NEWTITLE := 'clp$set_multipro_opt_cmd', EJECT ??

{ PURPOSE:
{   The purpose of this command is to change multiprocessing permissions imposed on a job.  The multiprocess
{   option of this command can be used within a job to allow multiprocessing of its tasks.  This means that
{   different tasks from the same job may be executing simultaneously on multiple processors.  The default for
{   this option is OFF because most jobs will not benefit from being able to multiprocess, and there is a
{   small overhead involved in allowing it.
{
{   The CPU Reinstatement feature gives the capability to initialize (or reinitialize) a CPU and return it for
{   use in the active configuration without a system interrupt.  A result of this feature is that turning OFF
{   one CPU on a dual CPU mainframe is NOT equivalent to a single CPU mainframe.  On a dual CPU mainframe
{   certain system segments are made cache-bypass, whether or not both CPUs are ON, allowing for the turning
{   ON of a CPU at a time other then at system deadstart.  Special care should be taken if any programs
{   utilize the SET_MULTIPROCESSING_OPTIONS command with the MP parameter set to ON as it will encounter a
{   performance degradation if used on a dual CPU mainframe with one CPU turned OFF or DOWN.
{
{     SET_MULTIPROCESSING_OPTIONS    MULTIPROCESS = OFF | ON
{                                  [ PROCESSORS = ( P0,P1 ) ]
{                                  [ STATUS = <status variable> ]
{            MULTIPROCESS, MP, M  : This parameter specifies whether a job is to allow simultaneous
{                               processing of its tasks on multiple processors.
{            PROCESSORS, PROCESSOR, P : This parameter specifies the processors desired.
{            STATUS           : see ERROR HANDLING.

  PROCEDURE [XDCL] clp$set_multipro_opt_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE set_multiprocessing_options, set_multiprocessing_option, setmo (
{   multiprocess, mp, m: key on, off keyend = off
{   processors, processor, p: list of key p0, p1 keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (3),
      recend,
      type2: 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 .. 2] of clt$keyword_specification,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 9, 17, 7, 23, 56, 370],
    clc$command, 7, 3, 0, 0, 0, 0, 3, ''], [
    ['M                              ',clc$abbreviation_entry, 1],
    ['MP                             ',clc$alias_entry, 1],
    ['MULTIPROCESS                   ',clc$nominal_entry, 1],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PROCESSOR                      ',clc$alias_entry, 2],
    ['PROCESSORS                     ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 97, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [2], [
    ['OFF                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['ON                             ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'off'],
{ PARAMETER 2
    [[1, 0, clc$list_type], [81, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [2], [
      ['P0                             ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['P1                             ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$multiprocess = 1,
      p$processors = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      list_p: ^clt$data_value,
      option_p: ^clt$data_value,
      processor_id_set: ost$processor_id_set;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Check the value of the PROCESSORS parameter.

    processor_id_set := $ost$processor_id_set[];
    IF pvt [p$processors].specified THEN
      list_p := pvt [p$processors].value;
      WHILE list_p <> NIL DO
        option_p := list_p^.element_value;
        list_p := list_p^.link;
        IF option_p^.keyword_value = 'P0' THEN
          processor_id_set := processor_id_set + $ost$processor_id_set[0];
        ELSEIF option_p^.keyword_value = 'P1' THEN
          processor_id_set := processor_id_set + $ost$processor_id_set[1];
        IFEND;
      WHILEND;
    IFEND;

    jmp$set_multiprocessing_r3 (pvt [p$multiprocess].value^.keyword_value, processor_id_set, status);

  PROCEND clp$set_multipro_opt_cmd;
?? OLDTITLE ??
MODEND clm$set_disp_multipro_opts_cmds
*DECK DECK=CLM$SET_MESSAGE_MODE_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Set Message Mode Command' ??
MODULE clm$set_message_mode_command;

{
{ PURPOSE:
{   This module contains the processor for the change_message_mode command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
*copyc clp$evaluate_parameters
*copyc osp$set_message_level

?? TITLE := 'clp$_change_message_level', EJECT ??

  PROCEDURE [XDCL] clp$_change_message_level
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$chaml) change_message_level, set_message_mode, setmm, chaml (
{   level, il, information_level, l: key
{       (brief, b)
{       (full, f)
{     keyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 1, 26, 6, 11, 39, 562],
    clc$command, 5, 2, 1, 0, 0, 0, 2, 'OSM$CHAML'], [
    ['IL                             ',clc$alias_entry, 1],
    ['INFORMATION_LEVEL              ',clc$alias_entry, 1],
    ['L                              ',clc$abbreviation_entry, 1],
    ['LEVEL                          ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BRIEF                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FULL                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$level = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      message_level: osc$brief_message_level .. osc$full_message_level;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$level].value^.keyword_value = 'BRIEF' THEN
      message_level := osc$brief_message_level;
    ELSE
      message_level := osc$full_message_level;
    IFEND;

    osp$set_message_level (message_level, status);

  PROCEND clp$_change_message_level;

MODEND clm$set_message_mode_command;
*DECK DECK=CLM$SET_PRIMARY_TASK_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Set Primary Task Command' ??
MODULE clm$set_primary_task_command;

{
{ PURPOSE:
{   This module contains the processor for the define_primary_task command.
{   The innermost "child" of, or the "primary task" itself, is the task
{   to which user "break" signals are sent.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
*copyc clp$evaluate_parameters
*copyc clp$set_primary_task

?? TITLE := 'clp$_define_primary_task', EJECT ??

  PROCEDURE [XDCL] clp$_define_primary_task
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$defpt) define_primary_task, defpt (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [89, 1, 25, 14, 14, 45, 919],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'OSM$DEFPT'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$set_primary_task (status);

  PROCEND clp$_define_primary_task;

MODEND clm$set_primary_task_command;
*DECK DECK=CLM$SET_SPY_IDENTIFIER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'Global Declarations', EJECT ??
MODULE clm$set_spy_identifier;

  { Purpose: This module contains the command processor for the
  { SET_SPY_IDENTIFIER command.

  { *callc clxspl }
  { *callc clxgval }

  { *callc pmxssi }
*copyc clp$evaluate_parameters
*copyc pmp$set_spy_identifier
?? OLDTITLE ??
?? NEWTITLE := 'CLP$SET_SPY_IDENTIFIER', EJECT ??

  PROCEDURE [XDCL] clp$set_spy_identifier
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{   PROCEDURE set_spy_identifier, setsi (
{     spy_identifier, si : range of integer 0  .. 3f(16) = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$range_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 4, 26, 14, 31, 49, 768],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['SI                             ',clc$abbreviation_entry, 1],
    ['SPY_IDENTIFIER                 ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 27, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$range_type], [20],
      [[1, 0, clc$integer_type], [0, 3f(16), 10]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$spy_identifier = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;



    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$set_spy_identifier (pvt [p$spy_identifier].value^.low_value^.integer_value.value,
                            pvt [p$spy_identifier].value^.high_value^.integer_value.value, status);

  PROCEND clp$set_spy_identifier;

MODEND clm$set_spy_identifier;
*DECK DECK=CLM$SET_WORKING_CATAOG_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Set Working Catalog Command' ??
MODULE clm$set_working_cataog_command;

{
{ PURPOSE:
{   This module contains the processor for the set_working_catalog command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$set_working_catalog
*IF $true(osv$unix)
*copyc clp_chdir
*copyc osp$set_status_from_errno
*IFEND

?? TITLE := 'clp$_change_working_catalog', EJECT ??

  PROCEDURE [XDCL] clp$_change_working_catalog
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
{ PROCEDURE (osm$chawc) change_working_catalog, set_working_catalog, setwc, chawc (
{   catalog, c: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 6, 13, 13, 56, 2, 764],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$CHAWC'], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CATALOG                        ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$catalog = 1,
    p$status = 2;

  VAR
    pvt: array [1 .. 2] of clt$parameter_value;
*ELSE
{  PROCEDURE (osm$chawc) change_working_catalog, set_working_catalog, setwc, ..
{  chawc, cd (
{    catalog, c, directory, d: file = $HOME
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: ALIGNED [0 MOD 4] string (5),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [2,
    [92, 1, 12, 10, 22, 7, 0],
    clc$command, 5, 2, 0, 0, 0, 0, 2, 'OSM$CHAWC'], [
    ['C                              ',clc$alias_entry, 1],
    ['CATALOG                        ',clc$nominal_entry, 1],
    ['D                              ',clc$abbreviation_entry, 1],
    ['DIRECTORY                      ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 5],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[2, 0, clc$file_type],
    '$HOME'],
{ PARAMETER 2
    [[2, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$catalog = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      errno: ost_c_integer,
      file_reference: fst$path,
      stat: integer,
      syserrlist_message: string (256);

    errno := 0;
    syserrlist_message := ' ';
*IFEND

    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    clp$set_working_catalog (pvt [p$catalog].value^.file_value^, status);
*ELSE
    file_reference := pvt [p$catalog].value^.file_value^;
    clp_chdir (file_reference, errno, syserrlist_message, stat);
    IF stat <> 0 THEN
      osp$set_status_from_errno ('CHDIR', errno, syserrlist_message, status);
      RETURN;
    IFEND;
*IFEND

  PROCEND clp$_change_working_catalog;

MODEND clm$set_working_cataog_command;
*DECK DECK=CLM$SKIP_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Skip Command' ??

MODULE clm$skip_command;

{
{ PURPOSE:
{   This module contains the processor for the SKIP command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc cld$parameter_list
*copyc cle$ecc_file_reference
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$skip_tape_marks
?? POP ?? {This line should be deleted when deck amxstmk has a ??POP?? appended to it.}
*copyc clp$evaluate_parameters
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc rmp$get_device_class
?? POP ??

?? TITLE := 'clp$skip_command', EJECT ??

  PROCEDURE [XDCL] clp$skip_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$skitm) skip_tape_mark, skip_tape_marks, skitm (
{   file, f: file = $required
{   direction, d: key
{       forward, f, backward, b
{     keyend = forward
{   count, c: integer 0..4398046511103 = 1
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 18, 13, 17, 54, 13],
    clc$command, 7, 4, 1, 0, 0, 0, 4, 'OSM$SKITM'], [
    ['C                              ',clc$abbreviation_entry, 3],
    ['COUNT                          ',clc$nominal_entry, 3],
    ['D                              ',clc$abbreviation_entry, 2],
    ['DIRECTION                      ',clc$nominal_entry, 2],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['BACKWARD                       ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['F                              ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['FORWARD                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'forward'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, 4398046511103, 10],
    '1'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$direction = 2,
      p$count = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

  CONST
    max_class_size = 15;

  VAR
    class: [STATIC, READ, oss$job_paged_literal] array [rmt$device_class] of record
      size: 1 .. max_class_size,
      value: string (max_class_size),
    recend := [[14, 'CONNECTED_FILE'], [15, 'INTERSTATE_LINK'], [11, 'LOCAL_QUEUE'], [3, 'LOG'], [13,
          'MAGNETIC_TAPE'], [12, 'MASS_STORAGE'], [15, 'MEMORY_RESIDENT'], [7, 'NETWORK'], [4, 'NULL'], [8,
          'PIPELINE'], [5, 'RHFAM'], [8, 'TERMINAL']];

  VAR
    contains_data: boolean,
    count: amt$tape_mark_count,
    device_assigned: boolean,
    device_class: rmt$device_class,
    direction: amt$skip_direction,
    file_attributes: array [1 .. 1] of amt$get_item,
    file_exists: boolean,
    file_previously_opened: boolean;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /skip_tape_mark/
    BEGIN

      IF (pvt [p$direction].value^.keyword_value = 'F') OR
            (pvt [p$direction].value^.keyword_value = 'FORWARD') THEN
        direction := amc$forward;
      ELSE
        direction := amc$backward;
      IFEND;

      count := pvt [p$count].value^.integer_value.value;

      file_attributes [1].key := amc$label_type;

      amp$get_file_attributes (pvt [p$file].value^.file_value^, file_attributes, file_exists,
            file_previously_opened, contains_data, status);
      IF NOT status.normal THEN
        EXIT /skip_tape_mark/;
      IFEND;

      IF NOT file_exists THEN
        osp$set_status_abnormal ('CL', cle$file_not_assigned_to_device, 'SKIP_TAPE_MARK', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'MAGNETIC_TAPE', status);
        EXIT /skip_tape_mark/;
      IFEND;

      rmp$get_device_class (pvt [p$file].value^.file_value^, device_assigned, device_class, status);
      IF NOT status.normal THEN
        EXIT /skip_tape_mark/;
      IFEND;

      IF NOT device_assigned THEN
        osp$set_status_abnormal ('CL', cle$file_not_assigned_to_device, 'SKIP_TAPE_MARK', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'MAGNETIC_TAPE', status);
        EXIT /skip_tape_mark/;
      IFEND;

      IF device_class <> rmc$magnetic_tape_device THEN
        osp$set_status_abnormal ('CL', cle$improper_device_class, 'SKIP_TAPE_MARK', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, class [device_class].value, status);
        EXIT /skip_tape_mark/;
      IFEND;

      IF file_attributes [1].label_type = amc$labelled THEN
        osp$set_status_abnormal ('CL', cle$improper_labelled_tape_op, 'SKIP_TAPE_MARK', status);
        EXIT /skip_tape_mark/;
      IFEND;

      amp$skip_tape_marks (pvt [p$file].value^.file_value^, direction, count, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    END /skip_tape_mark/;

  PROCEND clp$skip_command;

MODEND clm$skip_command;
*DECK DECK=CLM$SPDM_MESSAGES$US_ENGLISH EXPAND=TRUE
CREATE_MESSAGE_MODULE clm$spdm_messages$us_english

CREATE_PARAMETER_ASSIST_MESSAGE clc$advanced_label
---- Additional Parameters ----
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$backward_key_label
 Bkw
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$cancel_key_label
Cancel
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$clear_label
Clear
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$clear_eol_label
ClrEol
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$cleared_parameter_ignored
An attempt was made to clear out one or more parameter values. The previous ..
values have been reinstated. The RESET function will set a parameter to the ..
default value. The following parameters have been affected:+R+N5'+P'
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$command_label
 Command: +P1+X1
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$delete_char_label
DelChr
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$down_key_label
 Down
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$enter_command
 Enter Command and Press OK or Cancel+X1
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$enter_command_title
 Enter Command+X1
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$enter_parameter_value
 Enter Parameter Value and Press OK or Cancel+X1
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$enter_values
 Enter Values and Press OK or Cancel+X1
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$error_can_be_ignored
An error was encountered evaluating the value supplied for ..
+K'+P1'+K.
+N+NTo ignore the following error, leave the value unchanged. It will be re-evaluated ..
when it is needed.
+N+N+R+P+N
**
CREATE_PARAMETER_ASSIST_MESSAGE clc$evaluate_key_label
 Eval
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$first_key_label
First
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$forward_key_label
 Fwd
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$function_key_help
+NBkw+X4- pages the current window backward.
+n
+NCancel+X1- concludes processing of the command or Zoom window, +E9..
if present, without taking any action.
+n
+NDown+X3- scrolls the current window down.
+n
+NEval+X3- evaluates the expression specified for a parameter value.
+N9If not entered from a parameter, all parameters are evaluated.
+n
+NFwd+X4- pages the current window forward.
+n
+NInfo+X3- gives information about the command being prompted.
+n
+NOK+X5- concludes processing of the command or Zoom window, if present.
+n
+NReset+X2- resets a parameter to the default value. If not entered
+N9from a parameter, all parameters are reset.
+n
+NUp+X5- scrolls the current window up.
+n
+NZoom+X3- expands the data entry field for the current cursor position.
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$function_label
Function: +P1+X1
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$help_key_label
 Help
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$home_label
 Home
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$info_key_label
 Info
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$info_display
Source:+X2+P1
+N
+NNames:+X3+E8+P+R, +E8+P
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$info_display_with_one_name
Source:+X2+P1
+N
+NNames:+X3+E8+P
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$insert_char_label
InsChr
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$last_key_label
 Last
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$lines_l_through_m_size_n
Lines+P1 thru+P2 of+P3+X1
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$no_more_help_available
No more help is available.
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$no_more_input_space
No more space is available for this window.
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$no_parameters_label
 No Parameters+X1
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$ok_key_label
  OK
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$press_down
 Position cursor on the desired parameter and press DOWN+X1
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$press_up
 Position cursor on the desired parameter and press UP+X1
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$press_next_from_pageable
 +P1 to clear, +P2/+P3 to page forward/backward+X1
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$press_next
 +P1 to clear+X1
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$press_ok
 Press OK or Cancel+X1
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$reset_key_label
Reset
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$too_big_to_edit
 The value for this input field is too large to change.
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$unable_to_zoom_secure_param
'+P' is a SECURE parameter and it may not be ZOOMed.
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$undefined_function_key
No function assigned to key +P1.
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$up_key_label
  Up
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$zoom_key_label
 Zoom
**

CREATE_APPLICATION_MENU name=clc$spdm_main_menu
  CREATE_MENU_CLASS name='MAIN'
  CREATE_MENU_ITEM class='MAIN' short_label=' Fwd' k=forward
  CREATE_MENU_ITEM class='MAIN' short_label=' Bkw' k=backward pair_with_previous=yes
  CREATE_MENU_ITEM class='MAIN' short_label=' Help' k=help
  CREATE_MENU_ITEM class='MAIN' short_label='  OK' k=stop
  CREATE_MENU_ITEM class='MAIN' short_label='Cancel' k=stop shift=on pair_with_previous=yes
  CREATE_MENU_ITEM class='MAIN' short_label=' Eval' k=f1
  CREATE_MENU_ITEM class='MAIN' short_label='Reset' k=f5
  CREATE_MENU_ITEM class='MAIN' short_label=' Zoom' k=f7
  CREATE_MENU_ITEM class='MAIN' short_label='EditZm' k=f7 shift=on pair_with_previous=yes
  CREATE_MENU_ITEM class='MAIN' short_label=' Info' k=f2
  CREATE_MENU_ITEM class='MAIN' short_label=' Home' k=home
  CREATE_MENU_ITEM class='MAIN' short_label='ClrEol' k=clear_eol_menu_item
  CREATE_MENU_ITEM class='MAIN' short_label='InsChr' k=insert_char_menu_item
  CREATE_MENU_ITEM class='MAIN' short_label='DelChr' k=delete_char_menu_item pair_with_previous=yes
  CREATE_MENU_ITEM class='MAIN' short_label='Clear' k=clear
  CREATE_MENU_ITEM class='MAIN' short_label=' Last' k=forward shift=on
  CREATE_MENU_ITEM class='MAIN' short_label='First' k=backward shift=on pair_with_previous=yes
  CREATE_MENU_ITEM class='MAIN' short_label='  Up' k=up
  CREATE_MENU_ITEM class='MAIN' short_label=' Down' k=down pair_with_previous=yes
END_APPLICATION_MENU

END_MESSAGE_MODULE
*DECK DECK=CLM$SPI_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE clm$spi_commands;

{Purpose:
{
{      The purpose of this module is to process the SCL SPI commands.
{
?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc clp$get_value
*copyc clp$get_set_count
*copyc clp$convert_integer_to_string
*copyc clp$scan_parameter_list
*copyc osc$multiprocessor_constants
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$generate_message
*copyc osp$release_spi_environment
*copyc osp$reserve_spi_environment
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc osp$start_spi_collection
*copyc osp$stop_spi_collection
*copyc oss$job_paged_literal
*copyc ost$processor_id_set
*copyc pmp$continue_to_cause
?? POP ??

?? TITLE := 'PROCEDURE [XDCL, #GATE] clp$reserve_spi_environment', EJECT ??


  PROCEDURE [XDCL] clp$reserve_spi_environment
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{     PDT resse_pdt (
{         spi_identifier,si: integer 0 .. 63 = 0
{         collection_file, cf: file = $required
{         number_of_spi_samples,noss: integer 100 .. 100000000 = 50000
{         spi_sampling_interval,ssi: integer 1 .. 10000 = 300
{         wait,w: boolean = true
{         processor, processors, p: list of key p0,p1,p2,p3,p4,p5,all = all
{         data_string,ds: string 0 .. 32 = 'spi data collection utility'
{         status)

?? PUSH (LISTEXT := ON) ??

    VAR
      resse_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^resse_pdt_names, ^resse_pdt_params];

    VAR
      resse_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 16] of
            clt$parameter_name_descriptor := [['SPI_IDENTIFIER', 1], ['SI', 1], ['COLLECTION_FILE', 2],
            ['CF', 2], ['NUMBER_OF_SPI_SAMPLES', 3], ['NOSS', 3], ['SPI_SAMPLING_INTERVAL', 4], ['SSI', 4],
            ['WAIT', 5], ['W', 5], ['PROCESSOR', 6], ['PROCESSORS', 6], ['P', 6], ['DATA_STRING', 7],
            ['DS', 7], ['STATUS', 8]];

    VAR
      resse_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 8] of clt$parameter_descriptor := [

{ SPI_IDENTIFIER SI }
      [[clc$optional_with_default, ^resse_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$integer_value, 0, 63]],

{ COLLECTION_FILE CF }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ NUMBER_OF_SPI_SAMPLES NOSS }
      [[clc$optional_with_default, ^resse_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$integer_value, 100, 100000000]],

{ SPI_SAMPLING_INTERVAL SSI }
      [[clc$optional_with_default, ^resse_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$integer_value, 1, 10000]],

{ WAIT W }
      [[clc$optional_with_default, ^resse_pdt_dv5], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$boolean_value]],

{ PROCESSOR PROCESSORS P }
      [[clc$optional_with_default, ^resse_pdt_dv6], 1, clc$max_value_sets, 1, 1,
            clc$value_range_not_allowed, [^resse_pdt_kv6, clc$keyword_value]],

{ DATA_STRING DS }
      [[clc$optional_with_default, ^resse_pdt_dv7], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$string_value, 0, 32]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      resse_pdt_kv6: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of ost$name := ['P0', 'P1',
            'P2', 'P3', 'P4', 'P5', 'ALL'];

    VAR
      resse_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

    VAR
      resse_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := '50000';

    VAR
      resse_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := '300';

    VAR
      resse_pdt_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

    VAR
      resse_pdt_dv6: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

    VAR
      resse_pdt_dv7: [STATIC, READ, cls$pdt_names_and_defaults] string (29) :=
            '''spi data collection utility''';

?? POP ??

    VAR
      collection_file: amt$local_file_name,
      data_string: string (32),
      i: 0 .. clc$max_value_sets,
      number_of_spi_samples: ost$number_of_spi_samples,
      processor_count: 0 .. clc$max_value_sets,
      processor_id_set: ost$processor_id_set,
      processor_value: clt$value,
      spi_identifier: ost$spi_identifier,
      spi_sampling_interval: ost$spi_sampling_interval,
      value: clt$value,
      wait: ost$wait;

    clp$scan_parameter_list (parameter_list, resse_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('SPI_IDENTIFIER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    spi_identifier := value.int.value;

    clp$get_value ('NUMBER_OF_SPI_SAMPLES', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    number_of_spi_samples := value.int.value;

    clp$get_value ('SPI_SAMPLING_INTERVAL', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    spi_sampling_interval := value.int.value;

    clp$get_value ('WAIT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.bool.value = TRUE THEN
      wait := osc$wait;
    ELSE
      wait := osc$nowait;
    IFEND;

    clp$get_value ('DATA_STRING', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    data_string := value.str.value (1, value.str.size);

    clp$get_value ('COLLECTION_FILE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    collection_file := value.file.local_file_name;

{  Check the value of the PROCESSORS parameter.

    processor_id_set := $ost$processor_id_set [];
    clp$get_set_count ('PROCESSORS', processor_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  Check the value processor count.

    FOR i := 1 TO processor_count DO
      clp$get_value ('PROCESSORS', i, 1, clc$low, processor_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF processor_value.name.value (1, 2) = 'P0' THEN
        processor_id_set := processor_id_set + $ost$processor_id_set [0];
      ELSEIF processor_value.name.value (1, 2) = 'P1' THEN
        processor_id_set := processor_id_set + $ost$processor_id_set [1];
      ELSEIF processor_value.name.value (1, 2) = 'P2' THEN
        processor_id_set := processor_id_set + $ost$processor_id_set [2];
      ELSEIF processor_value.name.value (1, 2) = 'P3' THEN
        processor_id_set := processor_id_set + $ost$processor_id_set [3];
      ELSEIF processor_value.name.value (1, 2) = 'P4' THEN
        processor_id_set := processor_id_set + $ost$processor_id_set [4];
      ELSEIF processor_value.name.value (1, 2) = 'P5' THEN
        processor_id_set := processor_id_set + $ost$processor_id_set [5];
      ELSEIF processor_value.name.value (1, 3) = 'ALL' THEN
        processor_id_set := -$ost$processor_id_set [];
      IFEND;
    FOREND;
    osp$reserve_spi_environment (spi_identifier, collection_file, number_of_spi_samples,
          spi_sampling_interval, wait, processor_id_set, data_string, status);

  PROCEND clp$reserve_spi_environment;

?? EJECT, TITLE := 'PROCEDURE clp$start_spi_collection' ??

{ PDT status_pdt (status)

?? PUSH (LISTEXT := ON) ??

  VAR
    status_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
          [^status_pdt_names, ^status_pdt_params];

  VAR
    status_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
          clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    status_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
          [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

  PROCEDURE [XDCL] clp$start_spi_collection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    clp$scan_parameter_list (parameter_list, status_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$start_spi_collection (status);

  PROCEND clp$start_spi_collection;

?? EJECT, TITLE := 'PROCEDURE clp$stop_spi_collection' ??

  PROCEDURE [XDCL] clp$stop_spi_collection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    clp$scan_parameter_list (parameter_list, status_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$stop_spi_collection (status);

  PROCEND clp$stop_spi_collection;

?? EJECT, TITLE := 'PROCEDURE clp$release_spi_environment ' ??

  PROCEDURE [XDCL] clp$release_spi_environment
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    clp$scan_parameter_list (parameter_list, status_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$release_spi_environment (status);
  PROCEND clp$release_spi_environment;

MODEND clm$spi_commands;
*DECK DECK=CLM$STRING_PATTERN_HANDLERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter: String Pattern Procedures' ??
MODULE clm$string_pattern_handlers;

{
{ PURPOSE:
{
{   This module contains the procedures that build string patterns and use them
{   to perform matching operations on strings.
{
{   A string pattern is a data structure that drives the string matching
{   process and is contained within a CLT$STRING_PATTERN sequence.  It
{   represents a pattern of characters which can be as simple as "any 3
{   characters" or "the string 'abc'", or can be very complex.
{
{   The matching process consists of attempting to find a sequence of
{   characters in a SUBJECT string that are MATCHed by the PATTERN.  The RESULT
{   of this process may be FAILURE, i.e.  the pattern could not be found in the
{   subject, or it may be SUCCESS, in which case the INDEX and SIZE of the
{   substring of the subject that matched the pattern are made available.
{
{   A string pattern is composed of any number of PATTERN ELEMENTS.  These
{   elements can be combined in essentially 2 ways:  concatenation and
{   alternation.  When two pattern elements are concatenated, a match for the
{   first must be found in the subject string immediately followed by a match
{   for the second.  The second of the two elements is said to be the SUCCESSOR
{   to the first.
{
{   When two pattern elements are combined via alternation, a match for either
{   the first or the second must be found in the subject string.  The second
{   such element is said to be the ALTERNATIVE to the first.
{
{   Thus, each pattern element has two linkages, one to its successor, and one
{   to its alternative.  Either or both of these linkages may be absent, i.e.
{   an element may have a successor but no alternative, or an alternative but
{   no successor.  An element with no successor is a TERMINAL element or NODE
{   of the pattern.
{
{   The goal of the pattern matching process is to find a sequence of elements
{   within a pattern that match a substring within the subject string.
{
{
{ DESIGN:
{
{   The algorithms and techniques used in this module are derived from those
{   used in the programming language SNOBOL4.  They have been adapted to take
{   advantage of the facilities provided in a modern implementation language,
{   i.e.  CYBIL.  In particular, heavy use is made of the CYBIL run-time stack
{   whereas the original algorithm needed to maintain its own stacks.  This has
{   the effect of simplifying the algorithm considerably, at the expense of
{   increasing its subtlety.
{
{   There are two major steps involved in the use of string patterns.  The
{   first is to build the pattern, either from some form of description of what
{   kinds of strings should be matched, or by combining existing patterns.  The
{   second step is to utilize the pattern to scan a subject string for a match.
{
{   The scanning step iterates through pattern elements following successor
{   links, advancing the subject index past the characters that matched the
{   element, until an element fails to match or a terminal element is reached.
{   In the latter case success is declared.  If an element fails to match, the
{   process backs up until an alternative is found, the subject index is reset
{   to the point where the current element originally matched, then scanning
{   continues by iterating through the alternative and its successors.  When no
{   more alternatives exists, failure is declared.
{
{   During this scanning process, when a point is reached that may require
{   alternatives to be tried, the scanner calls itself recursively in order to
{   make use of the run-time stack to keep track of sufficient information to
{   reset the scan.
{
{   Structurally, the scanning (matching) process consists of a controlling
{   procedure that follows successor links and tries alternatives.  This
{   controlling procedure calls specialized procedures to deal with individual
{   pattern elements, one procedure for each kind of element.  In general the
{   element processors are independent of one another and their only
{   interaction with the controlling procedure is to return success or failure
{   and update the subject index when they succeed.
{
{   However, there are some kinds of elements that are more complex.  Some work
{   in pairs, for example the pattern elements that deal with capturing a piece
{   of the subject during a match (see below).  Some have built-in
{   alternatives, for example the pattern element that matches multiple
{   characters in a row--each time the scan backs up to try an alternative, it
{   increases the number of characters it matches.
{
{   The pattern building process stores extra information in the representation
{   of the pattern to make the matching (scanning) process as efficient as
{   possible.  This causes the building process to be more costly than it would
{   otherwise be.  It is a trade-off based on the idea that a pattern will be
{   used more than once, thereby offsetting the extra cost to build it.  This
{   extra information consists of two pieces of data in each pattern element:
{   1) the minimum number of characters remaining in the subject that are
{   required in order for a match of the current element and all of its
{   successors to be successful, and 2) the minimum number of characters
{   remaining in the subject that are required to match any of the alternatives
{   of the current element along with their corresponding successors.
{
{   This minimum size information is used when the scan backs up to an element
{   to try alternatives after a failure.  If the element is one that advances
{   the subject index and retries its successor, the size information can be
{   used to avoid attempting matches that are doomed to failure.
{
{   An element may fail to match at the current subject index for one of two
{   REASONs:  there are not a sufficient number of characters remaining in the
{   subject for a match to have a chance of success (SIZE FAILure), or the
{   element doesn't correspond to the characters in the subject at that
{   position (MATCH FAILure).  Retrying a match by advancing the subject index
{   after a size failure is (usually) a waste of time.
{
{   Patterns which are recursively defined can be represented using the
{   UNEVALUATED PATTERN element.  A relatively common example of a recursive
{   pattern is one that could match the arithmetic expression of a programming
{   language, since such expressions can have sub-expressions enclosed in
{   parentheses.
{
{   The pattern matching process is not, however, restricted to just looking at
{   a subject string.  With appropriate pattern elements, substrings of the
{   subject that match parts of the pattern can be captured for later use.  The
{   capture can be done either once the entire pattern has been successfully
{   matched, or immediately upon matching the appropriate part of the pattern.
{   The ability to immediately capture part of the subject just matched makes
{   possible some very sophisticated matching.  For example the captured
{   substring could be referred to within an unevaluated pattern.  This
{   provides the capability to match patterns such as:  "pattern A" followed by
{   "pattern B" followed by whatever "pattern A" matched to the left of
{   "pattern B".
{
{   The immediate capture capability in combination with unevaluated patterns
{   is very powerful but requires refining the size information heuristics
{   described above.  If a size failure occurs at or following an unevaluated
{   pattern element, this should be treated the same way as an ordinary size
{   failure unless an immediate capture pattern element is backed into.  When
{   that occurs the size failure should be turned into a match failure, since
{   if in trying alternatives, something different is captured, it may affect
{   what is matched by the subsequent unevaluated pattern, which in turn may
{   yield overall success.
{
{   Attempted matches with some kinds of patterns won't have the intended
{   results if the size information is used during the matching process.  For
{   this reason an option is provided that "shuts off" those checks.  This
{   "full scan" option should only be used when necessary since it can
{   dramatically slow down pattern matching.  The "quick scan" option should
{   normally be used.
{
{   For more details of the pattern building and matching processes see the
{   procedures that implement them.
{
{   How a pattern is represented is private to this module, i.e.  the data
{   structures which describe it are known only within this module.  Outside
{   this module a pattern is simply a CYBIL sequence (CLT$STRING_PATTERN).  The
{   first thing within that sequence is a CLT$STRING_PATTERN_HEADER record
{   which allows the INITIAL_ELEMENT of the pattern to be located.  (The header
{   also contains a VERSION stamp to accommodate future changes that may be
{   binary incompatible.)  The element linkages within the sequence are via
{   relative pointers (CLT$STRING_PATTERN_ELEMENT_LINK).
{
{   There are a number of fields common to all pattern elements
{   (CLT$STRING_PATTERN_ELEMENT).  These are:
{
{   SUCCESSOR:  A link to the successor of this element (NIL if none).
{
{   ALTERNATIVE:  A link to the alternative of this element (NIL if none).
{
{   MIN_SUBJECT_SIZE:  The minimum number of characters that must remain in the
{         subject in order to match this element and all of its successors.
{
{   ALTERNATIVE_MIN_SUBJECT_SIZE:  The minimum number of characters that must
{         remain in the subject in order to match any of this element's
{         alternatives and their corresponding successors.
{
{   COUNT:  The use of this field is dependent on the kind of element.  See the
{         description for each element kind.
{
{   EXTRA_INFO_SIZE:  This field is only used during building a pattern.  It
{         specifies the number of cells occupied by the "extra information'
{         associated with a pattern element.  This information is normally
{         accessed via a relative pointer within the element, but always
{         immediately follows the element itself.  This field is used when
{         sequentially accessing a pattern's elements and provides a
{         convenient means to get to the start of the next element.
{
{   KIND:  The kind of pattern element.
{
{   The individual pattern elements and what they match are described below.
{   For those elements that use the COUNT field, the descriptions indicate its
{   meaning.
{
{   CLC$SP_BALANCED_PAIR:  This element matches any non-null string that is
{         balanced with respect to a pair of characters, usually parentheses,
{         identified by the LEFT_CHARACTER and RIGHT_CHARACTER fields.
{
{   CLC$SP_CAPTURE_BEGIN:  This element works in conjunction with a
{         CLC$SP_CAPTURE_END element to make possible "capturing" part of the
{         subject string during a match.  By itself it matches a null string.
{         The CAPTURE_END_ELEMENT field is a link to the corresponding
{         CLC$SP_CAPTURE_END element and is used by the latter to synchronize
{         its activities with this element.
{
{   CLC$SP_CAPTURE_INDEX:  This element is used to capture the current value
{         of the subject index.  It matches the null string.  The
{         IMMEDIATE_CAPTURE field is ignored.  CLC$SP_CAPTURE_VIA_PROCEDURE
{         passes the subject index, as a string, to the CYBIL procedure pointed
{         to by the CAPTURE_PROCEDURE field.  CLC$SP_CAPTURE_VIA_VARIABLE
{         writes the subject index to an SCL integer variable referred to via
{         the CAPTURE_VARIABLE field.  CLC$SP_CAPTURE_VIA_COMMAND passes the
{         subject index, as a string, to an SCL command referred to via the
{         CAPTURE_COMMAND field.
{
{   CLC$SP_CAPTURE_END:  This element works in conjunction with a
{         CLC$SP_CAPTURE_BEGIN element and does most of the work for capturing
{         matched substrings.  By itself it matches a null string.  The
{         IMMEDIATE_CAPTURE field indicates whether the capture should occur
{         immediately upon reaching this element, or conditionally once the
{         entire pattern has been successfully matched.  The latter is
{         accomplished by the processor for this element delaying the capture
{         until it is backed into with a match result of success.  The
{         CAPTURE_KIND field determines the means by which the matched
{         substring is captured.  CLC$SP_CAPTURE_VIA_PROCEDURE passes the
{         matched substring to the CYBIL procedure pointed to by the
{         CAPTURE_PROCEDURE field.  CLC$SP_CAPTURE_VIA_VARIABLE writes the
{         matched substring to an SCL variable referred to via the
{         CAPTURE_VARIABLE field.  CLC$SP_CAPTURE_VIA_COMMAND passes the
{         matched substring to an SCL command referred to via the
{         CAPTURE_COMMAND field.
{
{   CLC$SP_CHARACTERS:  This element matches COUNT or more of the characters
{         contained in the CHARACTERS set.  (In order to take advantage of the
{         #SCAN procedure of CYBIL, the inverse of the set is actually stored
{         in this pattern element.)
{
{   CLC$SP_COUNT:  This element matches exactly COUNT characters.  Any
{         character contained in the CHARACTERS set is not matched by this
{         element.
{
{   CLC$SP_COUNT_TEST_LEFT:  This element matches the null string if there are
{         exactly COUNT characters to the left of the subject index.  This is
{         most frequently used with a COUNT of zero in order to force its
{         successor to be matched at the left end of the subject.
{
{   CLC$SP_COUNT_TEST_RIGHT:  This element matches the null string if there are
{         exactly COUNT characters to the right of the subject index.  This is
{         most frequently used with a COUNT of zero in order to force its
{         predecessor to be matched at the right end of the subject.
{
{   CLC$SP_FAIL_ELEMENT:  This element always fails to match, causing the
{         scanning process to back up and seek alternatives, i.e. it provides
{         a way to build a structure that does NOT match the pattern to which
{         this element is a successor.
{
{   CLC$SP_FAIL_PATTERN:  This element causes immediate failure termination of
{         the entire matching process.
{
{   CLC$SP_FENCE:  This element matches the null string.  If it is backed into
{         with failure it causes immediate failure termination of the entire
{         matching process.  It can be used to avoid trying alternatives that
{         can't possibly match.  For example consider the pattern "a" or "the"
{         followed by " mousetrap", applied to the subject string "a fleatrap".
{         The first alternative ("a") matches but its successor fails.  There
{         is no point in trying the second alternative, since "the" can't
{         possibly match what "a" matched.  Inserting a CLC$SP_FENCE element
{         after the "a" or "the" alternation pattern avoids attempting the
{         fruitless alternative.
{
{   CLC$SP_MULTIPLE:  This element matches COUNT or more characters.  Any
{         character contained in the CHARACTERS set is not matched by this
{         element.
{
{   CLC$SP_MULTIPLE_PATH_ELEMENTS:  This element is used to represent the
{         special file reference path element $ALL when building a pattern
{         to match an entire file reference.
{
{   CLC$SP_ONE_CHARACTER:  This element matches exactly one of the characters
{         contained in the CHARACTERS set.
{
{   CLC$SP_REPEAT_PATTERN_BEGIN:  This element works in conjunction with a
{         CLC$SP_REPEAT_PATTERN_END element.  They bracket a sub-pattern that
{         must be found at least COUNT times.  By itself this element matches
{         the null string.
{
{   CLC$SP_REPEAT_PATTERN_END:  This element works in conjunction with a
{         CLC$SP_REPEAT_PATTERN_BEGIN element.  They bracket a sub-pattern that
{         must be found at least COUNT times.  By itself this element matches
{         the null string.
{
{   CLC$SP_STRING_LITERAL:  This element matches the string of characters
{         referred to via the STRING_LITERAL field.  If CASE_SENSITIVE is FALSE
{         lower case characters are, in effect, folded to their upper case
{         counterparts prior to attempting the match.  The folding is done
{         according to the SCL option FOLDING_LEVEL.
{
{   CLC$SP_SUCCEED_FORCED:  This element matches the null string.  If it is
{         backed into, it succeeds again, i.e.  it can be thought of as being
{         its own alternative.  Its usefulness is limited but, in combination
{         with immediate capture, the CLC$SP_FAIL_ELEMENT element and the "full
{         scan" option, interesting results can be produced.
{
{   CLC$SP_SUCCEED_PASSIVE:  This element matches the null string.  It is
{         usually employed as a "null node" in a complex pattern, for example a
{         pattern involving nested alternation.
{
{   CLC$SP_TEST:  This element tests the value of the boolean expression
{         referred to via the TEST_EXPRESSION field.  If the result of the
{         expression is TRUE, this element matches the null string.  If the
{         result is FALSE or the expression cannot be evaluated, this element
{         fails.
{
{   CLC$SP_UNEVALUATED_PATTERN:  This element matches the sub-pattern referred
{         to via the UNEVALUATED_PATTERN field, which is in the form of a
{         string pattern expression.  The processor for this element evaluates
{         the expression, i.e.  builds the sub-pattern, then tries to match it.
{
{   CLC$SP_UPTO_CHARACTER:  This element matches up to but not including one of
{         the characters contained in the CHARACTERS set.
{
{   CLC$SP_UPTO_COUNT_LEFT:  This element matches up to and including the
{         COUNT'th character from the left end of the subject.
{
{   CLC$SP_UPTO_COUNT_RIGHT:  This element matches up to and including the
{         COUNT'th character from the right end of the subject.  This is most
{         frequently used with a COUNT of zero in order to match the rest of
{         the subject.
{

?? NEWTITLE := 'Global Declarations' ??
?? NEWTITLE := 'String Pattern Declarations', EJECT ??

{
{ The following string pattern related types are known outside of this module.
{

*copyc clt$string_pattern
*copyc clt$string_pattern_anchor_opt
*copyc clt$string_pattern_build_opts
*copyc clt$string_pattern_match_info
*copyc clt$string_pattern_scan_option
*copyc clt$string_pattern_size
?? SKIP := 6 ??

{
{ The following types are needed for string pattern elements.
{

*copyc clt$command_line
*copyc clt$expression_text
*copyc clt$string_index
*copyc clt$string_size
*copyc clt$string_value
*copyc clt$variable_ref_expression
?? SKIP := 6 ??

{
{ The following string pattern types are known only within this module.
{

  CONST
    clc$string_pattern_version = 1;

  TYPE
    clt$string_pattern_capture = record
      immediate: boolean,
      case kind: clt$string_pattern_capture_kind of
      = clc$sp_capture_via_command =
        command: ^clt$command_line,
      = clc$sp_capture_via_procedure =
        proc: clt$string_pattern_capture_proc,
      = clc$sp_capture_via_variable =
        variable: ^clt$variable_ref_expression,
      casend,
    recend;

  TYPE
    clt$string_pattern_capture_kind = (clc$sp_capture_via_command, clc$sp_capture_via_variable,
          clc$sp_capture_via_procedure);

  TYPE
    clt$string_pattern_capture_proc = ^procedure
           (    matched_string: ^clt$string_value;
            VAR status: ost$status);

  TYPE
    clt$string_pattern_characters = set of char;

  TYPE
    clt$string_pattern_element = record
      successor: clt$string_pattern_element_link,
      alternative: clt$string_pattern_element_link,
      min_subject_size: clt$string_size,
      alternative_min_subject_size: clt$string_size,
      count: clt$string_size,
      extra_info_size: clt$string_size {used only during pattern building} ,
      case kind: clt$string_pattern_element_kind of
      = clc$sp_balanced_pair =
        left_character: char,
        right_character: char,
      = clc$sp_capture_begin =
        capture_end_element: clt$string_pattern_element_link,
      = clc$sp_capture_end, clc$sp_capture_index =
        immediate_capture: boolean,
        case capture_kind: clt$string_pattern_capture_kind of
        = clc$sp_capture_via_command =
          capture_command: REL (clt$string_pattern) ^clt$command_line,
        = clc$sp_capture_via_procedure =
          capture_procedure: clt$string_pattern_capture_proc,
        = clc$sp_capture_via_variable =
          capture_variable: REL (clt$string_pattern) ^clt$variable_ref_expression,
        casend,
      = clc$sp_characters, clc$sp_count, clc$sp_multiple, clc$sp_one_character, clc$sp_upto_character =
        characters: REL (clt$string_pattern) ^clt$string_pattern_characters,

{ the clc$sp_characters and clc$sp_multiple pattern elements use the count field as a minimum count
{ the clc$sp_count pattern element uses the count field as an exact count

      = clc$sp_count_test_left, clc$sp_count_test_right, clc$sp_upto_count_from_left,
            clc$sp_upto_count_from_right =
        { these pattern elements use the count field as an exact count } ,
      = clc$sp_fail_element, clc$sp_fail_pattern, clc$sp_fence, clc$sp_multiple_path_elements,
            clc$sp_succeed_forced, clc$sp_succeed_passive =
        ,
      = clc$sp_repeat_pattern_begin, clc$sp_repeat_pattern_end =
        { these pattern elements use the count field as a minimum count } ,
      = clc$sp_string_literal =
        case_sensitive: boolean,
        string_literal: REL (clt$string_pattern) ^clt$string_value,
      = clc$sp_test =
        test_expression: REL (clt$string_pattern) ^clt$expression_text,
      = clc$sp_unevaluated_pattern =
        unevaluated_pattern: REL (clt$string_pattern) ^clt$expression_text,
      casend,
    recend;

  TYPE
    clt$string_pattern_element_kind = (clc$sp_balanced_pair, clc$sp_capture_begin, clc$sp_capture_end,
          clc$sp_capture_index, clc$sp_characters, clc$sp_count, clc$sp_count_test_left,
          clc$sp_count_test_right, clc$sp_fail_element, clc$sp_fail_pattern, clc$sp_fence, clc$sp_multiple,
          clc$sp_multiple_path_elements, clc$sp_one_character, clc$sp_repeat_pattern_begin,
          clc$sp_repeat_pattern_end, clc$sp_string_literal, clc$sp_succeed_forced, clc$sp_succeed_passive,
          clc$sp_test, clc$sp_unevaluated_pattern, clc$sp_upto_character, clc$sp_upto_count_from_left,
          clc$sp_upto_count_from_right);

  TYPE
    clt$string_pattern_element_link = REL (clt$string_pattern) ^clt$string_pattern_element;

  TYPE
    clt$string_pattern_fail_reason = (clc$sp_fail_size, clc$sp_fail_match, clc$sp_fail_unevaluated,
          clc$sp_fail_immediate_capture);

  TYPE
    clt$string_pattern_header = record
      version: 0 .. 255,
      number_of_elements: clt$string_size,
      initial_element: clt$string_pattern_element_link,
    recend;

?? SKIP := 6 ??

{
{ Constants for wild card characters.
{

  CONST
    clc$wc_alternation_begin = '{',
    clc$wc_alternation_end = '}',
    clc$wc_alternation_separator = '|',
    clc$wc_count_1 = '?',
    clc$wc_multiple = '*',
    clc$wc_path_element_separator = '.',
    clc$wc_quote = '''',
    clc$wc_set_begin = '[',
    clc$wc_set_complement = '^',
    clc$wc_set_end = ']',
    clc$wc_set_range = '-';

?? OLDTITLE, EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$bad_string_pattern
*copyc cle$bad_wild_card_pattern
*copyc cle$string_too_long
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$parameter_list
*copyc clt$wild_card_pattern_type
*copyc clt$work_area
*IF $true(osv$unix)
*copyc cyt$mips_signal_handler
*ELSE
*copyc osd$virtual_address
*IFEND
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*IF NOT $true(osv$unix)
*copyc clp$change_variable
*IFEND
*copyc clp$convert_char_to_graphic
*copyc clp$convert_integer_to_string
*IF NOT $true(osv$unix)
*copyc clp$create_procedure_variable
*IFEND
*copyc clp$evaluate_expression
*copyc clp$evaluate_parameters
*copyc clp$get_work_area
*IF NOT $true(osv$unix)
*copyc clp$include_line
*IFEND
*copyc clp$make_boolean_value
*copyc clp$make_integer_value
*copyc clp$make_record_value
*copyc clp$make_string_pattern_value
*copyc clp$make_value
*copyc clv$non_graphic
*IF NOT $true(osv$unix)
*copyc i#compare_collated
*IFEND
*copyc i#current_sequence_position
*IF NOT $true(osv$unix)
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$disestablish_cond_handler
*IFEND
*copyc osp$set_status_condition
*copyc osv$lower_to_upper
*copyc osv$upper_to_lower
*IF NOT $true(osv$unix)
*copyc pmp$continue_to_cause
*IFEND

?? TITLE := 'clp$$match', EJECT ??

  PROCEDURE [XDCL] clp$$match
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$match) $match (
{   subject: string = $required
{   pattern: string_pattern = $required
{   anchor_option: key
{       (anchored, a)
{       (unanchored, u)
{     keyend = unanchored
{   scan_option: (ADVANCED) key
{       (quick_scan, qs)
{       (full_scan, fs)
{     keyend = quick_scan
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (10),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (10),
      recend,
    recend := [
    [1,
    [90, 1, 11, 18, 13, 28, 158],
    clc$function, 4, 4, 2, 1, 0, 0, 0, 'OSM$$MATCH'], [
    ['ANCHOR_OPTION                  ',clc$nominal_entry, 3],
    ['PATTERN                        ',clc$nominal_entry, 2],
    ['SCAN_OPTION                    ',clc$nominal_entry, 4],
    ['SUBJECT                        ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [4, 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, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, 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, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [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, 155,
  clc$optional_default_parameter, 0, 10],
{ PARAMETER 4
    [3, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 10]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$string_pattern_type]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ANCHORED                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['UNANCHORED                     ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'unanchored'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [4], [
    ['FS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FULL_SCAN                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['QS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['QUICK_SCAN                     ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'quick_scan']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$subject = 1,
      p$pattern = 2,
      p$anchor_option = 3,
      p$scan_option = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      anchor_option: clt$string_pattern_anchor_opt,
      match_info: clt$string_pattern_match_info,
      node: ^clt$data_value,
      scan_option: clt$string_pattern_scan_option;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$anchor_option].value^.keyword_value = 'ANCHORED' THEN
      anchor_option := clc$sp_anchored;
    ELSE
      anchor_option := clc$sp_unanchored;
    IFEND;

    IF pvt [p$scan_option].value^.keyword_value = 'QUICK_SCAN' THEN
      scan_option := clc$sp_quick_scan;
    ELSE
      scan_option := clc$sp_full_scan;
    IFEND;

    clp$match_string_pattern (pvt [p$subject].value^.string_value^,
          pvt [p$pattern].value^.string_pattern_value, anchor_option, scan_option, match_info, status);

    clp$make_record_value (3, work_area, result);

    result^.field_values^ [1].name := 'MATCHED';
    clp$make_boolean_value (status.normal AND (match_info.result = clc$sp_success), clc$yes_no_boolean,
          work_area, result^.field_values^ [1].value);

    result^.field_values^ [2].name := 'INDEX';
    clp$make_integer_value (1, 10, FALSE, work_area, result^.field_values^ [2].value);
    IF match_info.result = clc$sp_success THEN
      result^.field_values^ [2].value^.integer_value.value := match_info.index;
    IFEND;

    result^.field_values^ [3].name := 'SIZE';
    clp$make_integer_value (0, 10, FALSE, work_area, result^.field_values^ [3].value);
    IF match_info.result = clc$sp_success THEN
      result^.field_values^ [3].value^.integer_value.value := match_info.size;
    IFEND;

  PROCEND clp$$match;
?? TITLE := 'clp$$sp_any', EJECT ??

  PROCEDURE [XDCL] clp$$sp_any
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_any) $sp_any (
{   characters: list rest of any of
{       string
{       range of string 1
{     anyend = $required
{   )

?? 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$list_type_qualifier,
        element_type_spec: 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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$string_type_qualifier,
            recend,
          recend,
        recend,
      recend,
    recend := [
    [1,
    [90, 1, 17, 9, 3, 18, 767],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$SP_ANY'], [
    ['CHARACTERS                     ',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, 59, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [43, 1, clc$max_list_size, TRUE],
      [[1, 0, clc$union_type], [[clc$range_type, clc$string_type],
      FALSE, 2],
      8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
      15, [[1, 0, clc$range_type], [8],
          [[1, 0, clc$string_type], [1, 1, FALSE]]
        ]
      ]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$characters = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      characters: clt$string_pattern_characters;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    build_character_set (pvt [p$characters].value, characters);

    clp$make_value (clc$string_pattern, work_area, result);

    clp$sp_one_character (characters, work_area, result^.string_pattern_value, status);

  PROCEND clp$$sp_any;
?? TITLE := 'clp$$sp_balance', EJECT ??

  PROCEDURE [XDCL] clp$$sp_balance
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_balance) $sp_balance (
{   left_character: string 1 = '('
{   right_character: string 1 = ')'
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (3),
      recend,
    recend := [
    [1,
    [89, 9, 29, 15, 57, 41, 325],
    clc$function, 2, 2, 0, 0, 0, 0, 0, 'OSM$$SP_BALANCE'], [
    ['LEFT_CHARACTER                 ',clc$nominal_entry, 1],
    ['RIGHT_CHARACTER                ',clc$nominal_entry, 2]],
    [
{ 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, 8,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [2, 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, 8,
  clc$optional_default_parameter, 0, 3]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [1, 1, FALSE],
    '''('''],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 1, FALSE],
    ''')''']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$left_character = 1,
      p$right_character = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_value (clc$string_pattern, work_area, result);

    clp$sp_balanced_pair (pvt [p$left_character].value^.string_value^ (1),
          pvt [p$right_character].value^.string_value^ (1), work_area, result^.string_pattern_value, status);

  PROCEND clp$$sp_balance;
?? TITLE := 'clp$$sp_capture', EJECT ??

  PROCEDURE [XDCL] clp$$sp_capture
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_capture) $sp_capture (
{   pattern: string_pattern = $required
{   when: key
{       (conditional, c)
{       (unconditional, immediate, i, u)
{     keyend = $required
{   where: string = $required
{   how: key
{       (variable, v)
{       (command, c)
{     keyend = variable
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (8),
      recend,
    recend := [
    [1,
    [89, 9, 22, 16, 57, 38, 778],
    clc$function, 4, 4, 3, 0, 0, 0, 0, 'OSM$$SP_CAPTURE'], [
    ['HOW                            ',clc$nominal_entry, 4],
    ['PATTERN                        ',clc$nominal_entry, 1],
    ['WHEN                           ',clc$nominal_entry, 2],
    ['WHERE                          ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, 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, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, 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, 229,
  clc$required_parameter, 0, 0],
{ PARAMETER 3
    [4, 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, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 4
    [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, 155,
  clc$optional_default_parameter, 0, 8]],
{ PARAMETER 1
    [[1, 0, clc$string_pattern_type]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [6], [
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CONDITIONAL                    ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['I                              ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['IMMEDIATE                      ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['UNCONDITIONAL                  ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 3
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [4], [
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['COMMAND                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['V                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['VARIABLE                       ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'variable']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$pattern = 1,
      p$when = 2,
      p$where = 3,
      p$how = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      capture: clt$string_pattern_capture;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    capture.immediate := pvt [p$when].value^.keyword_value = 'UNCONDITIONAL';
    IF pvt [p$how].value^.keyword_value = 'VARIABLE' THEN
      capture.kind := clc$sp_capture_via_variable;
      capture.variable := pvt [p$where].value^.string_value;
    ELSE {COMMAND}
      capture.kind := clc$sp_capture_via_command;
      capture.command := pvt [p$where].value^.string_value;
    IFEND;

    clp$make_value (clc$string_pattern, work_area, result);

    clp$sp_capture_substring (pvt [p$pattern].value^.string_pattern_value, capture, work_area,
          result^.string_pattern_value, status);

  PROCEND clp$$sp_capture;
?? TITLE := 'clp$$sp_count', EJECT ??

  PROCEDURE [XDCL] clp$$sp_count
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_count) $sp_count (
{   count: integer 0..clc$max_string_size = $required
{   not_any: list rest of any of
{       string
{       range of string 1
{     anyend = $optional
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$string_type_qualifier,
            recend,
          recend,
        recend,
      recend,
    recend := [
    [1,
    [90, 1, 17, 14, 57, 6, 417],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$SP_COUNT'], [
    ['COUNT                          ',clc$nominal_entry, 1],
    ['NOT_ANY                        ',clc$nominal_entry, 2]],
    [
{ 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, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, 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, 59, clc$optional_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, clc$max_string_size, 10]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [43, 1, clc$max_list_size, TRUE],
      [[1, 0, clc$union_type], [[clc$range_type, clc$string_type],
      FALSE, 2],
      8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
      15, [[1, 0, clc$range_type], [8],
          [[1, 0, clc$string_type], [1, 1, FALSE]]
        ]
      ]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$count = 1,
      p$not_any = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      excluded_characters: clt$string_pattern_characters;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$not_any].specified THEN
      build_character_set (pvt [p$not_any].value, excluded_characters);
    ELSE
      excluded_characters := $clt$string_pattern_characters [];
    IFEND;

    clp$make_value (clc$string_pattern, work_area, result);

    clp$sp_count (excluded_characters, pvt [p$count].value^.integer_value.value, work_area,
          result^.string_pattern_value, status);

  PROCEND clp$$sp_count;
?? TITLE := 'clp$$sp_defer', EJECT ??

  PROCEDURE [XDCL] clp$$sp_defer
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_defer) $sp_defer (
{   pattern: (DEFER) string_pattern = $required
{   minimum_match_size: integer 0..clc$max_string_size = 1
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
    recend := [
    [1,
    [89, 9, 29, 16, 6, 7, 345],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$SP_DEFER'], [
    ['MINIMUM_MATCH_SIZE             ',clc$nominal_entry, 2],
    ['PATTERN                        ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_positionally],
    clc$pass_by_value, clc$deferred_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [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, 20,
  clc$optional_default_parameter, 0, 1]],
{ PARAMETER 1
    [[1, 0, clc$string_pattern_type]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, clc$max_string_size, 10],
    '1']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$pattern = 1,
      p$minimum_match_size = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_value (clc$string_pattern, work_area, result);

    clp$sp_unevaluated_pattern (pvt [p$pattern].value^.deferred_value,
          pvt [p$minimum_match_size].value^.integer_value.value, work_area, result^.string_pattern_value,
          status);

  PROCEND clp$$sp_defer;
?? TITLE := 'clp$$sp_fail', EJECT ??

  PROCEDURE [XDCL] clp$$sp_fail
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_fail) $sp_fail

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 9, 29, 16, 7, 0, 11],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$SP_FAIL']];

?? FMT (FORMAT := ON) ??
?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_value (clc$string_pattern, work_area, result);

    clp$sp_fail_element (work_area, result^.string_pattern_value, status);

  PROCEND clp$$sp_fail;
?? TITLE := 'clp$$sp_fence', EJECT ??

  PROCEDURE [XDCL] clp$$sp_fence
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_fence) $sp_fence

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 9, 22, 18, 1, 24, 196],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$SP_FENCE']];

?? FMT (FORMAT := ON) ??
?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_value (clc$string_pattern, work_area, result);

    clp$sp_fence (work_area, result^.string_pattern_value, status);

  PROCEND clp$$sp_fence;
?? TITLE := 'clp$$sp_left', EJECT ??

  PROCEDURE [XDCL] clp$$sp_left
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_left) $sp_left (
{   count: integer 0..clc$max_string_size = 0
{   )

?? 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$integer_type_qualifier,
        default_value: string (1),
      recend,
    recend := [
    [1,
    [89, 9, 29, 16, 1, 10, 633],
    clc$function, 1, 1, 0, 0, 0, 0, 0, 'OSM$$SP_LEFT'], [
    ['COUNT                          ',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, 20,
  clc$optional_default_parameter, 0, 1]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, clc$max_string_size, 10],
    '0']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$count = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_value (clc$string_pattern, work_area, result);

    clp$sp_count_test_left (pvt [p$count].value^.integer_value.value, work_area, result^.string_pattern_value,
          status);

  PROCEND clp$$sp_left;
?? TITLE := 'clp$$sp_index', EJECT ??

  PROCEDURE [XDCL] clp$$sp_index
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_index) $sp_index (
{   where: string = $required
{   how: key
{       (variable, v)
{       (command, c)
{     keyend = variable
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (8),
      recend,
    recend := [
    [1,
    [90, 1, 20, 16, 28, 41, 449],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$SP_INDEX'], [
    ['HOW                            ',clc$nominal_entry, 2],
    ['WHERE                          ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [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, 155,
  clc$optional_default_parameter, 0, 8]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['COMMAND                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['V                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['VARIABLE                       ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'variable']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$where = 1,
      p$how = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      capture: clt$string_pattern_capture;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    capture.immediate := TRUE;
    IF pvt [p$how].value^.keyword_value = 'VARIABLE' THEN
      capture.kind := clc$sp_capture_via_variable;
      capture.variable := pvt [p$where].value^.string_value;
    ELSE {COMMAND}
      capture.kind := clc$sp_capture_via_command;
      capture.command := pvt [p$where].value^.string_value;
    IFEND;

    clp$make_value (clc$string_pattern, work_area, result);

    clp$sp_capture_index (capture, work_area, result^.string_pattern_value, status);

  PROCEND clp$$sp_index;
?? TITLE := 'clp$$sp_not_any', EJECT ??

  PROCEDURE [XDCL] clp$$sp_not_any
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_not_any) $sp_not_any (
{   characters: list rest of any of
{       string
{       range of string 1
{     anyend = $required
{   )

?? 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$list_type_qualifier,
        element_type_spec: 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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$string_type_qualifier,
            recend,
          recend,
        recend,
      recend,
    recend := [
    [1,
    [90, 1, 17, 9, 5, 22, 655],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$SP_NOT_ANY'], [
    ['CHARACTERS                     ',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, 59, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [43, 1, clc$max_list_size, TRUE],
      [[1, 0, clc$union_type], [[clc$range_type, clc$string_type],
      FALSE, 2],
      8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
      15, [[1, 0, clc$range_type], [8],
          [[1, 0, clc$string_type], [1, 1, FALSE]]
        ]
      ]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$characters = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      characters: clt$string_pattern_characters;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    build_character_set (pvt [p$characters].value, characters);

    clp$make_value (clc$string_pattern, work_area, result);

    clp$sp_one_character (-characters, work_area, result^.string_pattern_value, status);

  PROCEND clp$$sp_not_any;
?? TITLE := 'clp$$sp_null', EJECT ??

  PROCEDURE [XDCL] clp$$sp_null
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_null) $sp_null

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 9, 29, 15, 53, 58, 101],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$SP_NULL']];

?? FMT (FORMAT := ON) ??
?? POP ??


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_value (clc$string_pattern, work_area, result);

    clp$sp_succeed_passive (work_area, result^.string_pattern_value, status);

  PROCEND clp$$sp_null;
?? TITLE := 'clp$$sp_or', EJECT ??

  PROCEDURE [XDCL] clp$$sp_or
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_or) $sp_or (
{   patterns: list rest of string_pattern = $required
{   )

?? 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$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
    recend := [
    [1,
    [90, 1, 17, 9, 7, 35, 3],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$SP_OR'], [
    ['PATTERNS                       ',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, 19, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, TRUE],
      [[1, 0, clc$string_pattern_type]]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$patterns = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      left_pattern: ^clt$string_pattern,
      node: ^clt$data_value,
      right_pattern: ^clt$string_pattern;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_string_pattern_value (pvt [p$patterns].value^.element_value^.string_pattern_value^, work_area,
          result);

    node := pvt [p$patterns].value^.link;
    WHILE node <> NIL DO
      left_pattern := result^.string_pattern_value;
      right_pattern := node^.element_value^.string_pattern_value;
      clp$sp_pattern_or_pattern (left_pattern, right_pattern, work_area, result^.string_pattern_value,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      node := node^.link;
    WHILEND;

  PROCEND clp$$sp_or;
?? TITLE := 'clp$$sp_repeat', EJECT ??

  PROCEDURE [XDCL] clp$$sp_repeat
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_repeat) $sp_repeat (
{   what: any of
{       record
{         selection: key
{           any, not_any
{         keyend
{         characters: list rest of any of
{           string
{           range of string 1
{         anyend = $optional
{       recend
{       string_pattern
{     anyend = $required
{   minimum_count: integer 0..clc$max_string_size = 0
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 2] of clt$keyword_specification,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$list_type_qualifier,
            element_type_spec: 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$string_type_qualifier,
              recend,
              type_size_2: clt$type_specification_size,
              element_type_spec_2: record
                header: clt$type_specification_header,
                qualifier: clt$range_type_qualifier,
                element_type_spec: record
                  header: clt$type_specification_header,
                  qualifier: clt$string_type_qualifier,
                recend,
              recend,
            recend,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
    recend := [
    [1,
    [90, 1, 17, 9, 26, 36, 907],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$SP_REPEAT'], [
    ['MINIMUM_COUNT                  ',clc$nominal_entry, 2],
    ['WHAT                           ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 242,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [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, 20,
  clc$optional_default_parameter, 0, 1]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$record_type, clc$string_pattern_type],
    FALSE, 2],
    219, [[1, 0, clc$record_type], [2],
      ['SELECTION                      ', clc$required_field, 81], [[1, 0, clc$keyword_type], [2], [
        ['ANY                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['NOT_ANY                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
        ],
      ['CHARACTERS                     ', clc$optional_field, 59], [[1, 0, clc$list_type], [43, 0,
  clc$max_list_size, TRUE],
          [[1, 0, clc$union_type], [[clc$range_type, clc$string_type],
          FALSE, 2],
          8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
          15, [[1, 0, clc$range_type], [8],
              [[1, 0, clc$string_type], [1, 1, FALSE]]
            ]
          ]
        ]
      ],
    3, [[1, 0, clc$string_pattern_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, clc$max_string_size, 10],
    '0']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$what = 1,
      p$minimum_count = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      characters: clt$string_pattern_characters;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_value (clc$string_pattern, work_area, result);
    IF pvt [p$what].value^.kind = clc$record THEN
      IF pvt [p$what].value^.field_values^ [2].value = NIL THEN
        clp$sp_multiple ($clt$string_pattern_characters [], pvt [p$minimum_count].
              value^.integer_value.value, work_area, result^.string_pattern_value, status);
      ELSE
        build_character_set (pvt [p$what].value^.field_values^ [2].value, characters);
        IF pvt [p$what].value^.field_values^ [1].value^.keyword_value = 'ANY' THEN
          clp$sp_characters (characters, pvt [p$minimum_count].value^.integer_value.value, work_area,
                result^.string_pattern_value, status);
        ELSE {NOT_ANY}
          clp$sp_multiple (characters, pvt [p$minimum_count].value^.integer_value.value, work_area,
                result^.string_pattern_value, status);
        IFEND;
      IFEND;
    ELSE {clc$string_pattern}
      clp$sp_repeat_pattern (pvt [p$what].value^.string_pattern_value,
            pvt [p$minimum_count].value^.integer_value.value, work_area, result^.string_pattern_value,
            status);
    IFEND;

  PROCEND clp$$sp_repeat;
?? TITLE := 'clp$$sp_right', EJECT ??

  PROCEDURE [XDCL] clp$$sp_right
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_right) $sp_right (
{   count: integer 0..clc$max_string_size = 0
{   )

?? 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$integer_type_qualifier,
        default_value: string (1),
      recend,
    recend := [
    [1,
    [89, 9, 29, 16, 2, 24, 300],
    clc$function, 1, 1, 0, 0, 0, 0, 0, 'OSM$$SP_RIGHT'], [
    ['COUNT                          ',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, 20,
  clc$optional_default_parameter, 0, 1]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, clc$max_string_size, 10],
    '0']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$count = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_value (clc$string_pattern, work_area, result);

    clp$sp_count_test_right (pvt [p$count].value^.integer_value.value, work_area,
          result^.string_pattern_value, status);

  PROCEND clp$$sp_right;
?? TITLE := 'clp$$sp_stop', EJECT ??

  PROCEDURE [XDCL] clp$$sp_stop
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_stop) $sp_stop

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 9, 29, 16, 7, 55, 919],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$SP_STOP']];

?? FMT (FORMAT := ON) ??
?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_value (clc$string_pattern, work_area, result);

    clp$sp_fail_pattern (work_area, result^.string_pattern_value, status);

  PROCEND clp$$sp_stop;
?? TITLE := 'clp$$sp_string', EJECT ??

  PROCEDURE [XDCL] clp$$sp_string
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_string) $sp_string (
{   string: string = $required
{   case_option: key
{       (case_sensitive, cs)
{       (ignore_case, ic)
{     keyend = case_sensitive
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (14),
      recend,
    recend := [
    [1,
    [90, 1, 26, 9, 52, 55, 349],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$SP_STRING'], [
    ['CASE_OPTION                    ',clc$nominal_entry, 2],
    ['STRING                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [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, 155,
  clc$optional_default_parameter, 0, 14]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['CASE_SENSITIVE                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['CS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['IC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['IGNORE_CASE                    ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'case_sensitive']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$string = 1,
      p$case_option = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_value (clc$string_pattern, work_area, result);

    clp$sp_string_literal (pvt [p$string].value^.string_value, pvt [p$case_option].value^.keyword_value =
          'CASE_SENSITIVE', work_area, result^.string_pattern_value, status);

  PROCEND clp$$sp_string;
?? TITLE := 'clp$$sp_succeed', EJECT ??

  PROCEDURE [XDCL] clp$$sp_succeed
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_succeed) $sp_succeed

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 9, 22, 18, 1, 24, 196],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$SP_SUCCEED']];

?? FMT (FORMAT := ON) ??
?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_value (clc$string_pattern, work_area, result);

    clp$sp_succeed_forced (work_area, result^.string_pattern_value, status);

  PROCEND clp$$sp_succeed;
?? TITLE := 'clp$$sp_test', EJECT ??

  PROCEDURE [XDCL] clp$$sp_test
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_test) $sp_test (
{   test: (DEFER) boolean = $required
{   )

?? 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,
      recend,
    recend := [
    [1,
    [90, 1, 20, 13, 24, 30, 34],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$SP_TEST'], [
    ['TEST                           ',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$deferred_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$test = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_value (clc$string_pattern, work_area, result);

    clp$sp_test (pvt [p$test].value^.deferred_value, work_area, result^.string_pattern_value, status);

  PROCEND clp$$sp_test;
?? TITLE := 'clp$$sp_upto', EJECT ??

  PROCEDURE [XDCL] clp$$sp_upto
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_upto) $sp_upto (
{   where: any of
{       key
{         (left, l)
{         (right, r)
{       keyend
{       list of any of
{         string
{         range of string 1
{       anyend
{     anyend = $required
{   count: integer 0..clc$max_string_size = 0
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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 .. 4] 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,
          element_type_spec: 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$string_type_qualifier,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$range_type_qualifier,
              element_type_spec: record
                header: clt$type_specification_header,
                qualifier: clt$string_type_qualifier,
              recend,
            recend,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
    recend := [
    [1,
    [89, 9, 29, 16, 14, 59, 700],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$SP_UPTO'], [
    ['COUNT                          ',clc$nominal_entry, 2],
    ['WHERE                          ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 234,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [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, 20,
  clc$optional_default_parameter, 0, 1]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    155, [[1, 0, clc$keyword_type], [4], [
      ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['LEFT                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['RIGHT                          ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    59, [[1, 0, clc$list_type], [43, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$union_type], [[clc$range_type, clc$string_type],
        FALSE, 2],
        8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
        15, [[1, 0, clc$range_type], [8],
            [[1, 0, clc$string_type], [1, 1, FALSE]]
          ]
        ]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, clc$max_string_size, 10],
    '0']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$where = 1,
      p$count = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      characters: clt$string_pattern_characters;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_value (clc$string_pattern, work_area, result);

    IF pvt [p$where].value^.kind = clc$list THEN
      build_character_set (pvt [p$where].value, characters);
      clp$sp_upto_character (characters, work_area, result^.string_pattern_value, status);

    ELSEIF pvt [p$where].value^.keyword_value = 'LEFT' THEN
      clp$sp_upto_count_from_left (pvt [p$count].value^.integer_value.value, work_area,
            result^.string_pattern_value, status);

    ELSE {RIGHT}
      clp$sp_upto_count_from_right (pvt [p$count].value^.integer_value.value, work_area,
            result^.string_pattern_value, status);
    IFEND;

  PROCEND clp$$sp_upto;
?? TITLE := 'clp$$sp_wild_card', EJECT ??

  PROCEDURE [XDCL] clp$$sp_wild_card
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$sp_wild_card) $sp_wild_card, $sp_wc (
{   pattern: (wild_card_pattern) any of
{       string
{       application
{     anyend = $required
{   pattern_type: key
{       (basic, b)
{       (extended, e)
{     keyend = $scl_options.wild_card_pattern_type
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        name: string (17),
        qualifier: clt$union_type_qualifier,
        type_size_1: clt$type_specification_size,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$application_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (35),
      recend,
    recend := [
    [1,
    [89, 9, 22, 16, 23, 37, 463],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$SP_WILD_CARD'], [
    ['PATTERN                        ',clc$nominal_entry, 1],
    ['PATTERN_TYPE                   ',clc$nominal_entry, 2]],
    [
{ 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, 49, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, 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, 155,
  clc$optional_default_parameter, 0, 35]],
{ PARAMETER 1
    [[1, 17, clc$union_type], 'WILD_CARD_PATTERN', [[clc$application_type, clc$string_type],
    FALSE, 2],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
    4, [[1, 0, clc$application_type], [FALSE]]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BASIC                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXTENDED                       ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    '$scl_options.wild_card_pattern_type']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$pattern = 1,
      p$pattern_type = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      pattern_source: ^clt$string_value,
      pattern_type: clt$wild_card_pattern_type;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$pattern].value^.kind = clc$string THEN
      pattern_source := pvt [p$pattern].value^.string_value;
    ELSE {clc$application}
      pattern_source := pvt [p$pattern].value^.application_value;
    IFEND;

    IF pvt [p$pattern_type].value^.keyword_value = 'EXTENDED' THEN
      pattern_type := clc$wc_extended_pattern;
    ELSE {BASIC}
      pattern_type := clc$wc_basic_pattern;
    IFEND;

    clp$make_value (clc$string_pattern, work_area, result);

    clp$build_pattern_for_wild_card (pattern_type, $clt$string_pattern_build_opts [], pattern_source^,
          work_area, result^.string_pattern_value, status);

  PROCEND clp$$sp_wild_card;
?? TITLE := 'clp$build_pattern_for_wild_card', EJECT ??
*copy clh$build_pattern_for_wild_card

{
{ DESIGN:
{
{   Each component of the wild card pattern is represented by a single
{   CLT$STRING_PATTERN_ELEMENT with two exceptions.  The first exception is an
{   optimization that is employed when a "*" is the last thing in the wild card
{   pattern and CLC$SP_IGNORE_MATCHED_SUBSTRING is in the BUILD_OPTIONS set.
{   In this case no pattern element is created for the "*" at all.
{
{   The other exception concerns the representation of an alternation pattern.
{   For this kind of pattern, an element is created for each component of the
{   alternation.  An extra CLC$SP_SUCCESS_PASSIVE element is added when an
{   alternative is empty or begins with another (nested) alternation pattern.
{
{   A contiguous group of non-special character in the wild card pattern is
{   represented by a single CLC$SP_STRING_LITERAL element.  This includes any
{   quoted characters.
{
{   A contiguous group of "?" characters is represented by a single
{   CLC$SP_COUNT element whoose COUNT field specifies the number of "?"
{   characters that appeared in a row.
{
{   A "*" is represented by a CLC$SP_MULTIPLE element if something follows it,
{   or a CLC$SP_UPTO_COUNT_FROM_RIGHT element with a COUNT of zero if it the
{   last thing in the wild card pattern.  As noted above, when the "*" is last
{   and CLC$SP_IGNORE_MATCHED_SUBSTRING is in the BUILD_OPTIONS set, it is
{   entirly ommitted from the representation.
{
{   Both a "[ ]" and "[^ ]" (character class and inverse character class,
{   respectively) are represented by a CLC$SP_ONE_CHARACTER element.
{
{   An alternation pattern is represented by an element for each of its
{   components, as described above.  The first element of each alternative is
{   linked to the next by its ALTERNATIVE field.  (All other linkages are via
{   the SUCCESSOR field.) When alternative is empty or begins with a nested
{   alternation pattern a "place holding" element must be inserted to keep the
{   alternatives properly linked.  The place holder is represented by a
{   CLC$SP_SUCCESS_PASSIVE element.
{
{   A pattern is built by recursive calls to the BUILD_PATTERN_ELEMENT
{   procedure, one call for each element in the resulting pattern.  Recursion
{   is used rather than iteration in order to be able to assign the proper
{   values to the MIN_SUBJECT_SIZE and ALTERNATIVE_MIN_SUBJECT_SIZE fields of
{   the elements.  The MIN_SUBJECT_SIZE is the minimum number of characters
{   remaining in the subject needed to match the current element and its
{   successors.  It is equal to the minimum number of characters needed to match
{   the current element plus the lesser of the successor element's
{   MIN_SUBJECT_SIZE and ALTERNATIVE_MIN_SUBJECT_SIZE fields.  The
{   ALTERNATIVE_MIN_SUBJECT_SIZE is the minimum number of characters remaining
{   in the subject needed to match any of the current element's alternatives
{   along with their corresponding successors.  It is equal to the lesser of the
{   alternative element's MIN_SUBJECT_SIZE and ALTERNATIVE_MIN_SUBJECT_SIZE
{   fields.  If an element has no alternative its ALTERNATIVE_MIN_SUBJECT_SIZE
{   field is set to its MIN_SUBJECT_SIZE field to simplify the above
{   calculations.
{
{   Once the representation for all of the components of the alternation have
{   been built, all of the terminal nodes within the alternation must be linked
{   to the same successor element and the MIN_SUBJECT_SIZE and
{   ALTERNATIVE_MIN_SUBJECT_SIZE fields incremented by the minimum subject size
{   for that successor.
{
{   Were it not for alternation, the pattern builing process would be fairly
{   straightforward.  The complexity at the end of the BUILD_PATTERN_ELEMENT
{   procedure is entirely due to having to deal with alternations.
{
{   If CLC$SP_MATCH_AT_LEFT is in the BUILD_OPTIONS set, a
{   CLC$SP_COUNT_TEST_FROM_LEFT element is added to the front of the pattern.
{   IF CLC$SP_MATCH_AT_RIGHT is in the BUILD_OPTIONS set, a
{   CLC$SP_COUNT_TEST_FROM_RIGHT element is added to the end of the pattern.
{   In both cases the COUNT field of these elements is zero.
{

  PROCEDURE [XDCL, #GATE] clp$build_pattern_for_wild_card
    (    wild_card_pattern_type: clt$wild_card_pattern_type;
         build_options: clt$string_pattern_build_opts;
         source: clt$string_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      new_source_index: clt$string_index,
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header,
      pattern_size: clt$string_pattern_size,
      source_index: clt$string_index;

?? NEWTITLE := 'bad_wild_card_pattern', EJECT ??

{
{ PURPOSE:
{   This procedure is called when an error in the specification of a wild card
{   pattern is detected.  It causes an abnormal status exit from the entire
{   pattern building process.
{

    PROCEDURE [INLINE] bad_wild_card_pattern;


      osp$set_status_condition (cle$bad_wild_card_pattern, status);
      EXIT clp$build_pattern_for_wild_card;

    PROCEND bad_wild_card_pattern;
?? TITLE := 'build_left_end_element', EJECT ??

{
{ PURPOSE:
{   This procedure adds a CLC$SP_COUNT_TEST_LEFT element with a COUNT of zero
{   to the front of the pattern.  This forces the pattern to be matched at the
{   left end of the subject.
{

    PROCEDURE [INLINE] build_left_end_element;

      VAR
        initial_element_link: clt$string_pattern_element_link,
        successor_pattern_element: ^clt$string_pattern_element;


      initial_element_link := pattern_header^.initial_element;
      initialize_pattern_element (pattern, work_area, pattern_header^.number_of_elements,
            pattern_header^.initial_element, pattern_element);
      IF pattern_element = NIL THEN
        work_area_overflow;
      IFEND;
      pattern_element^.successor := initial_element_link;

      IF initial_element_link <> NIL THEN
        successor_pattern_element := #PTR (initial_element_link, pattern^);
        pattern_element^.min_subject_size := min_subject_size (successor_pattern_element);
      IFEND;

      pattern_element^.kind := clc$sp_count_test_left;

    PROCEND build_left_end_element;
?? TITLE := 'build_pattern_element', EJECT ??

{
{ PURPOSE:
{   This procedure builds an individual element of the string pattern.
{
{ DESIGN:
{   It calls itself recursively to build the successor and alternative for an
{   element.  Upon return from these recursive calls the links to the successor
{   and alternatives are added and the minimum subject size for the current
{   element and its alternatives are calculated (see above).
{
{ BUILDING_ALTERNTIVE: (input)  This parameter indicates whether the caller
{       started or continued the building of an alternation pattern group.
{
{ PATTERN_ELEMENT_LINK: (output)  This parameter specifies the linkage field to
{       the element to be built by this call.  This linkage field is set by
{       this call once space for the new pattern element has been allocated.
{
{ PATTERN_ELEMENT: (output)  This parameter is set to point to the new pattern
{       element.
{

    PROCEDURE build_pattern_element
      (    building_alternative: boolean;
       VAR pattern_element_link: clt$string_pattern_element_link;
       VAR pattern_element: ^clt$string_pattern_element);

      VAR
        alternation_successor_link: clt$string_pattern_element_link,
        alternative_pattern_element: ^clt$string_pattern_element,
        element_is_alternative: boolean,
        element_is_first_alternative: boolean,
        element_source_index: clt$string_index,
        group_element_count: clt$string_size,
        previous_element_count: clt$string_size,
        successor_pattern_element: ^clt$string_pattern_element;

?? NEWTITLE := 'build_character_set', EJECT ??

{
{ PURPOSE:
{   This procedure interprets the wild card "character class" notation and
{   builds a set of characters to represent it.  If an "inverse character
{   class" is given, the set is complemented before returning.
{
{ CHARACTERS: (output)  This parameter specifies the set of characters that
{       constitute the "character class" or "inverse character class".
{

      PROCEDURE build_character_set
        (VAR characters: clt$string_pattern_characters);

        VAR
          c: char,
          complement_set: boolean,
          found_end_of_set: boolean,
          in_quotes: boolean,
          range: record
            case state: (no_range, got_low, got_separator) of
            = no_range =
              ,
            = got_low, got_separator =
              low: char,
            casend,
          recend;


        characters := $clt$string_pattern_characters [];

        found_end_of_set := FALSE;
        complement_set := FALSE;
        range.state := no_range;
        in_quotes := FALSE;
        source_index := source_index + 1;

      /scan_set/
        WHILE source_index <= STRLENGTH (source) DO
          CASE source (source_index) OF
          = clc$wc_quote =
            source_index := source_index + 1;
            IF (source_index > STRLENGTH (source)) OR (source (source_index) <> clc$wc_quote) THEN
              in_quotes := NOT in_quotes;
              CYCLE /scan_set/;
            IFEND;
          = clc$wc_set_begin =
            IF NOT in_quotes THEN
              bad_wild_card_pattern;
            IFEND;
          = clc$wc_set_complement =
            IF source_index = (element_source_index + 1) THEN
              complement_set := TRUE;
              source_index := source_index + 1;
              CYCLE /scan_set/;
            IFEND;
          = clc$wc_set_end =
            IF NOT in_quotes THEN
              found_end_of_set := TRUE;
              source_index := source_index + 1;
              EXIT /scan_set/;
            IFEND;
          = clc$wc_set_range =
            IF (NOT in_quotes) AND (range.state = got_low) THEN
              range.state := got_separator;
              source_index := source_index + 1;
              CYCLE /scan_set/;
            IFEND;
          ELSE
            ;
          CASEND;

          IF range.state = got_separator THEN
            IF range.low <= source (source_index) THEN
              FOR c := SUCC (range.low) TO source (source_index) DO
                characters := characters + $clt$string_pattern_characters [c];
              FOREND;
            ELSE
              FOR c := PRED (range.low) DOWNTO source (source_index) DO
                characters := characters + $clt$string_pattern_characters [c];
              FOREND;
            IFEND;
            range.state := no_range;
          ELSE
            range.state := got_low;
            range.low := source (source_index);
            characters := characters + $clt$string_pattern_characters [source (source_index)];
          IFEND;

          source_index := source_index + 1;
        WHILEND /scan_set/;

        IF (NOT found_end_of_set) OR (characters = $clt$string_pattern_characters []) THEN
          bad_wild_card_pattern;
        ELSEIF range.state = got_separator THEN
          characters := characters + $clt$string_pattern_characters [clc$wc_set_range];
        IFEND;

        IF complement_set THEN
          characters := -characters;
        IFEND;

      PROCEND build_character_set;
?? TITLE := 'build_count', EJECT ??

{
{ PURPOSE:
{   This procedure builds a CLC$SP_COUNT element to represent one or more
{   "?" wild cards in a row.
{

      PROCEDURE [INLINE] build_count;

        VAR
          characters: ^clt$string_pattern_characters;


        pattern_element^.kind := clc$sp_count;

        REPEAT
          source_index := source_index + 1;
        UNTIL (source_index > STRLENGTH (source)) OR (source (source_index) <> clc$wc_count_1);

        pattern_element^.count := source_index - element_source_index;
        pattern_element^.min_subject_size := pattern_element^.count;

        WHILE (source_index <= STRLENGTH (source)) AND (source (source_index) = clc$wc_multiple) DO
          pattern_element^.kind := clc$sp_multiple;
          source_index := source_index + 1;
        WHILEND;

        IF clc$sp_file_reference_pattern IN build_options THEN
          NEXT characters IN work_area;
          IF characters = NIL THEN
            work_area_overflow;
          IFEND;
          characters^ := $clt$string_pattern_characters [clc$wc_path_element_separator];
          pattern_element^.characters := #REL (characters, pattern^);
          pattern_element^.extra_info_size := #SIZE (characters^);
        ELSE
          pattern_element^.characters := NIL;
        IFEND;

      PROCEND build_count;
?? TITLE := 'build_multiple', EJECT ??

{
{ PURPOSE:
{   This procedure builds a pattern element to represent the "*" wild card.
{
{ DESIGN:
{   If the "*" is not the last thing in the wild card pattern or
{   CLC$SP_MATCH_AT_RIGHT is not in the BUILD_OPTIONS set, a CLC$SP_MULTIPLE
{   element is built.
{   If the "*" is the last thing in the wild card pattern and
{   CLC$SP_MATCH_AT_RIGHT is in the BUILD_OPTIONS set, what is built depends on
{   whether CLC$SP_IGNORE_MATCHED_SUBSTRING is in the BUILD_OPTIONS set. If it
{   is not, i.e. the INDEX and SIZE fields of the CLT$STRING_PATTERN_MATCH_INFO
{   will be important when the pattern is used in a match operation, a
{   CLC$MATCH_UPTO_RIGHT_END pattern is built.
{   Otherwise no pattern element at all is built and NIL is returned.
{

      PROCEDURE [INLINE] build_multiple;

        VAR
          characters: ^clt$string_pattern_characters;


        REPEAT
          source_index := source_index + 1;
        UNTIL (source_index > STRLENGTH (source)) OR (source (source_index) <> clc$wc_multiple);

        IF (source_index <= STRLENGTH (source)) OR (NOT (clc$sp_match_at_right IN build_options)) OR
              (clc$sp_file_reference_pattern IN build_options) THEN
          pattern_element^.kind := clc$sp_multiple;
          IF clc$sp_file_reference_pattern IN build_options THEN
            NEXT characters IN work_area;
            IF characters = NIL THEN
              work_area_overflow;
            IFEND;
            characters^ := $clt$string_pattern_characters [clc$wc_path_element_separator];
            pattern_element^.characters := #REL (characters, pattern^);
            pattern_element^.extra_info_size := #SIZE (characters^);
          ELSE
            pattern_element^.characters := NIL;
          IFEND;
        ELSEIF NOT (clc$sp_ignore_matched_substring IN build_options) THEN
          pattern_element^.kind := clc$sp_upto_count_from_right;
        ELSE
          RESET work_area TO pattern_element;
          pattern_element := NIL;
          pattern_element_link := NIL;
          pattern_header^.number_of_elements := pattern_header^.number_of_elements + 1;
        IFEND;

      PROCEND build_multiple;
?? TITLE := 'build_multiple_path_elements', EJECT ??

{
{ PURPOSE:
{   This procedure builds a pattern element to represent the special path
{   element $ALL for a file reference pattern.
{
{ NEW_SOURCE_INDEX: (input)  This parameter specifies the value for the
{       SOURCE_INDEX once the pattern element has been built.  If it is
{       beyond the end of the SOURCE string, the pattern element will
{       represent ".$ALL" at the end of a file reference.  Otherwise it
{       will represent ".$ALL." in the middle of a file reference.
{

      PROCEDURE [INLINE] build_multiple_path_elements
        (    new_source_index: clt$string_index);


        pattern_element^.kind := clc$sp_multiple_path_elements;

        pattern_element^.min_subject_size := $INTEGER (new_source_index <= STRLENGTH (source));

        source_index := new_source_index;

      PROCEND build_multiple_path_elements;
?? TITLE := 'build_one_character', EJECT ??

{
{ PURPOSE:
{   This procedure builds a CLC$SP_ONE_CHARACTER element to represent a
{   "character class" or "inverse character class" wild card.
{

      PROCEDURE [INLINE] build_one_character;

        VAR
          characters: ^clt$string_pattern_characters;


        pattern_element^.kind := clc$sp_one_character;

        NEXT characters IN work_area;
        IF characters = NIL THEN
          work_area_overflow;
        IFEND;

        build_character_set (characters^);

        pattern_element^.characters := #REL (characters, pattern^);
        pattern_element^.extra_info_size := #SIZE (characters^);

        pattern_element^.min_subject_size := 1;

      PROCEND build_one_character;
?? TITLE := 'build_string_literal', EJECT ??

{
{ PURPOSE:
{   This procedure builds a CLC$SP_STRING_LITERAL element to represent one or
{   more "non-special" characters in a row from the wild card pattern.  It
{   deals with quoted sequences of characters and stops collecting literal
{   characters when it encounters a "special" character.
{
{ NOTES:
{   This procedure deals with recognizing the special path element $ALL when
{   building a pattern to used for matching file refernces.
{

      PROCEDURE [INLINE] build_string_literal;

        VAR
          in_quotes: boolean,
          string_literal: ^clt$string_value,
          string_literal_index: clt$string_index;


        pattern_element^.kind := clc$sp_string_literal;
        pattern_element^.case_sensitive := TRUE;

        NEXT string_literal: [STRLENGTH (source) - source_index + 1] IN work_area;
        IF string_literal = NIL THEN
          work_area_overflow;
        IFEND;

        string_literal_index := 1;
        in_quotes := FALSE;

      /scan_literal/
        WHILE source_index <= STRLENGTH (source) DO
          CASE source (source_index) OF
          = clc$wc_alternation_begin, clc$wc_set_begin =
            IF (NOT in_quotes) AND (wild_card_pattern_type = clc$wc_extended_pattern) THEN
              EXIT /scan_literal/;
            IFEND;
          = clc$wc_alternation_end =
            IF NOT in_quotes THEN
              IF building_alternative OR element_is_alternative THEN
                EXIT /scan_literal/;
              ELSEIF wild_card_pattern_type = clc$wc_extended_pattern THEN
                bad_wild_card_pattern;
              IFEND;
            IFEND;
          = clc$wc_alternation_separator =
            IF (NOT in_quotes) AND (building_alternative OR element_is_alternative) THEN
              EXIT /scan_literal/;
            IFEND;
          = clc$wc_count_1, clc$wc_multiple =
            IF NOT in_quotes THEN
              EXIT /scan_literal/;
            IFEND;
          = clc$wc_path_element_separator =
            IF (NOT in_quotes) AND (clc$sp_file_reference_pattern IN build_options) THEN
              check_for_multiple_path_element (new_source_index);
              IF new_source_index > source_index THEN
                EXIT /scan_literal/;
              IFEND;
            IFEND;
          = clc$wc_quote =
            source_index := source_index + 1;
            IF (source_index > STRLENGTH (source)) OR (source (source_index) <> clc$wc_quote) THEN
              in_quotes := NOT in_quotes;
              CYCLE /scan_literal/;
            IFEND;
          = clc$wc_set_end =
            IF (NOT in_quotes) AND (wild_card_pattern_type = clc$wc_extended_pattern) THEN
              bad_wild_card_pattern;
            IFEND;
          ELSE
            ;
          CASEND;

          string_literal^ (string_literal_index) := source (source_index);
          string_literal_index := string_literal_index + 1;
          source_index := source_index + 1;
        WHILEND /scan_literal/;

        IF in_quotes THEN
          bad_wild_card_pattern;
        IFEND;

        RESET work_area TO string_literal;
        NEXT string_literal: [string_literal_index - 1] IN work_area;
        pattern_element^.string_literal := #REL (string_literal, pattern^);
        pattern_element^.extra_info_size := #SIZE (string_literal^);

        pattern_element^.min_subject_size := STRLENGTH (string_literal^);

      PROCEND build_string_literal;
?? TITLE := 'build_succeed_passive', EJECT ??

{
{ PURPOSE:
{   This procedure builds a CLC$SP_SUCCEED_PASSIVE element.
{

      PROCEDURE [INLINE] build_succeed_passive;


        pattern_element^.kind := clc$sp_succeed_passive;

      PROCEND build_succeed_passive;
?? TITLE := 'check_for_multiple_path_element', EJECT ??

{
{ PURPOSE:
{   This procedure checks for the presence of the special path element $ALL
{   for a file reference pattern.  It assumes that the current source character
{   is a clc$wc_path_element_separator (".").
{

      PROCEDURE [INLINE] check_for_multiple_path_element
        (VAR new_source_index: clt$string_index);

        CONST
          clc$wc_multiple_path_elements = '$ALL';

        VAR
          remaining_source_size: clt$string_size;


        new_source_index := source_index;
        remaining_source_size := STRLENGTH (source) - source_index;
        IF (remaining_source_size >= STRLENGTH (clc$wc_multiple_path_elements)) AND
              (source (source_index + 1, STRLENGTH (clc$wc_multiple_path_elements)) =
              clc$wc_multiple_path_elements) THEN
          IF remaining_source_size = STRLENGTH (clc$wc_multiple_path_elements) THEN
            new_source_index := STRLENGTH (source) + 1;
          ELSEIF source (source_index + 1 + STRLENGTH (clc$wc_multiple_path_elements)) =
                clc$wc_path_element_separator THEN
            new_source_index := source_index + 1 + STRLENGTH (clc$wc_multiple_path_elements) + 1;
          IFEND;
        IFEND;

      PROCEND check_for_multiple_path_element;
?? OLDTITLE, EJECT ??

{
{ Upon entry to BUILD_PATTERN_ELEMENT, if the current SOURCE character signals
{ The start of an alternation group or the start of an alternative within a
{ group, flags are set to so indicate and the SOURCE_INDEX is incremented past
{ that character.
{
{ ELEMENT_IS_FIRST_ALTERNATIVE is set to TRUE if we're about to build the first
{ element of an alternation pattern gorup.
{ ELEMENT_IS_ALTERNATIVE is set to TRUE if we're about the build the first
{ element of an alternative within an alternation pattern gorup.
{ (ELEMENT_IS_FIRST_ALTERNATIVE implies ELEMENT_IS_ALTERNATIVE.)
{

      element_is_first_alternative := FALSE;
      element_is_alternative := FALSE;
      CASE source (source_index) OF
      = clc$wc_alternation_begin =
        IF wild_card_pattern_type = clc$wc_extended_pattern THEN
          IF source_index = STRLENGTH (source) THEN
            bad_wild_card_pattern;
          IFEND;
          element_is_first_alternative := TRUE;
          element_is_alternative := TRUE;
          source_index := source_index + 1;
        IFEND;
      = clc$wc_alternation_separator =
        IF building_alternative THEN
          IF source_index = STRLENGTH (source) THEN
            bad_wild_card_pattern;
          IFEND;
          element_is_alternative := TRUE;
          source_index := source_index + 1;
        IFEND;
      ELSE
        ;
      CASEND;

{ Remember where the source for this element began.

      element_source_index := source_index;

{ Remember the number of elements that preceded the new one.

      previous_element_count := pattern_header^.number_of_elements;

{ Allocate space for and initialize the new pattern element.

      initialize_pattern_element (pattern, work_area, pattern_header^.number_of_elements,
            pattern_element_link, pattern_element);
      IF pattern_element = NIL THEN
        work_area_overflow;
      IFEND;

{ Check for special wild card characters and select the appropriate pattern
{ element builder.  Some characters are only special when building a
{ CLC$WC_EXTENDED_PATTERN.  If the current SOURCE character is not special in
{ the current context, build a string literal element.

    /build_element/
      BEGIN
        CASE source (source_index) OF
        = clc$wc_alternation_begin =
          IF wild_card_pattern_type = clc$wc_extended_pattern THEN
            build_succeed_passive;
            EXIT /build_element/;
          IFEND;
        = clc$wc_alternation_end, clc$wc_alternation_separator =
          IF building_alternative OR element_is_alternative THEN
            build_succeed_passive;
            EXIT /build_element/;
          IFEND;
        = clc$wc_count_1 =
          build_count;
          EXIT /build_element/;
        = clc$wc_multiple =
          build_multiple;
          EXIT /build_element/;
        = clc$wc_path_element_separator =
          IF clc$sp_file_reference_pattern IN build_options THEN
            check_for_multiple_path_element (new_source_index);
            IF new_source_index > source_index THEN
              build_multiple_path_elements (new_source_index);
              EXIT /build_element/;
            IFEND;
          IFEND;
        = clc$wc_set_begin =
          IF wild_card_pattern_type = clc$wc_extended_pattern THEN
            build_one_character;
            EXIT /build_element/;
          IFEND;
        ELSE
          ;
        CASEND;
        build_string_literal;
      END /build_element/;

{ Pattern_element will be non-NIL unless BUILD_MULTIPLE was called and it
{ determined that no element was needed.

      IF pattern_element <> NIL THEN
        pattern_element^.alternative_min_subject_size := pattern_element^.min_subject_size;
      IFEND;

      IF source_index > STRLENGTH (source) THEN

{ We've reached end of the source of the wild card pattern.

        IF building_alternative OR element_is_alternative THEN
          bad_wild_card_pattern;
        ELSEIF pattern_element <> NIL THEN
          IF (clc$sp_match_at_right IN build_options) AND (pattern_element^.kind <>
                clc$sp_upto_count_from_right) THEN
            build_right_end_element (pattern_element^.successor, successor_pattern_element);
            pattern_element^.min_subject_size := pattern_element^.min_subject_size +
                  min_subject_size (successor_pattern_element);
            pattern_element^.alternative_min_subject_size := pattern_element^.min_subject_size;
          IFEND;
        IFEND;
        RETURN;
      IFEND;

      IF NOT ((building_alternative OR element_is_alternative) AND
            ((source (source_index) = clc$wc_alternation_separator) OR
            (source (source_index) = clc$wc_alternation_end))) THEN

{ Build the successor to this element (if any).

        build_pattern_element (building_alternative OR element_is_alternative, pattern_element^.successor,
              successor_pattern_element);
        IF successor_pattern_element <> NIL THEN
          pattern_element^.min_subject_size := pattern_element^.min_subject_size +
                min_subject_size (successor_pattern_element);
          pattern_element^.alternative_min_subject_size := pattern_element^.min_subject_size;
        IFEND;

        IF source_index > STRLENGTH (source) THEN

{ We've reached end of the source of the wild card pattern.

          IF building_alternative OR element_is_alternative THEN
            bad_wild_card_pattern;
          IFEND;
          RETURN;

        ELSEIF NOT ((building_alternative OR element_is_alternative) AND
              ((source (source_index) = clc$wc_alternation_separator) OR
              (source (source_index) = clc$wc_alternation_end))) THEN
          RETURN;
        IFEND;
      IFEND;

{ We've reached the end of an alternative pattern group.

      IF NOT element_is_alternative THEN

{ Finishing up an alternative pattern must be done in the context of the
{ first pattern element of that alternative.

        RETURN;
      IFEND;

      IF source (source_index) = clc$wc_alternation_separator THEN

{ Build the next alternative within the alternation pattern.

        build_pattern_element (TRUE {building_alternative} , pattern_element^.alternative,
              alternative_pattern_element);
        pattern_element^.alternative_min_subject_size := min_subject_size (alternative_pattern_element);
      IFEND;

{ We should now have reached the end of the entire alternation pattern.

      IF source (source_index) <> clc$wc_alternation_end THEN
        bad_wild_card_pattern;
      ELSEIF NOT element_is_first_alternative THEN
        RETURN;
      IFEND;

{ The entire group of elements that form the alternation pattern must be
{ finished up in the context of the first pattern element of the alternation.

      source_index := source_index + 1;

      group_element_count := pattern_header^.number_of_elements - previous_element_count;

{ Build the successor to the entire alternation pattern (if any).

      IF source_index <= STRLENGTH (source) THEN
        IF building_alternative AND ((source (source_index) = clc$wc_alternation_separator) OR
              (source (source_index) = clc$wc_alternation_end)) THEN
          successor_pattern_element := NIL;
        ELSE
          build_pattern_element (building_alternative, alternation_successor_link, successor_pattern_element);
        IFEND;
      ELSEIF clc$sp_match_at_right IN build_options THEN
        build_right_end_element (alternation_successor_link, successor_pattern_element);
      ELSE
        successor_pattern_element := NIL;
      IFEND;

      IF successor_pattern_element = NIL THEN
        RETURN;
      IFEND;

{ Link the successor to the alternation pattern group to all of the terminal
{ elements within the group.

      link_successor_to_pattern (pattern, pattern_element, group_element_count,
            #REL (successor_pattern_element, pattern^), min_subject_size (successor_pattern_element));

    PROCEND build_pattern_element;
?? TITLE := 'build_right_end_element', EJECT ??

{
{ PURPOSE:
{   This procedure builds a CLC$SP_COUNT_TEST_RIGHT with a COUNT of zero.  It
{   is assumed to be called by the procedure that built the last specified
{   piece of the wild card pattern.
{
{ PATTERN_ELEMENT_LINK: (input)  This parameter points to the linkage field to
{       element to be built by this call.  This linkage field is set by this
{       call once space for the new pattern element has been allocated.
{
{ PATTERN_ELEMENT: (output)  This parameter is set to point to the new pattern
{       element.
{

    PROCEDURE [INLINE] build_right_end_element
      (VAR pattern_element_link: clt$string_pattern_element_link;
       VAR pattern_element: ^clt$string_pattern_element);


      initialize_pattern_element (pattern, work_area, pattern_header^.number_of_elements,
            pattern_element_link, pattern_element);
      IF pattern_element = NIL THEN
        work_area_overflow;
      IFEND;

      pattern_element^.kind := clc$sp_count_test_right;

    PROCEND build_right_end_element;
?? TITLE := 'work_area_overflow', EJECT ??

{
{ PURPOSE:
{   This procedure is called when there is not enough space in the work area to
{   build the representation of the wild card pattern.  It causes an abnormal
{   status exit from the entire pattern building process.
{

    PROCEDURE [INLINE] work_area_overflow;


      osp$set_status_condition (cle$work_area_overflow, status);
      EXIT clp$build_pattern_for_wild_card;

    PROCEND work_area_overflow;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

{ Set up for building the pattern.  Initially the PATTERN sequence is
{ to "cover" all of the remaining space in the work area, then the WORK_AREA
{ pointer is immediately reset to its initial position.  This is done solely so
{ that correct values for relative pointers within the resulting pattern can be
{ generated.

    NEXT pattern: [[REP #SIZE (work_area^) - i#current_sequence_position (work_area) OF cell]] IN work_area;
    IF pattern = NIL THEN
      work_area_overflow;
    IFEND;
    RESET work_area TO pattern;

    initialize_pattern_header (work_area, pattern_header);
    IF pattern_header = NIL THEN
      work_area_overflow;
    IFEND;

    source_index := 1;

{ BUILD_PATTERN_ELEMENT must only be called if there's anything in the SOURCE
{ of the wild card pattern.  BUILD_RIGHT_END_ELEMENT may still have to be
{ called even if SOURCE is empty.

    IF STRLENGTH (source) > 0 THEN
      build_pattern_element (FALSE {NOT building_alternative} , pattern_header^.initial_element,
            pattern_element);
    ELSEIF clc$sp_match_at_right IN build_options THEN
      build_right_end_element (pattern_header^.initial_element, pattern_element);
    IFEND;

{ Call BUILD_LEFT_END_ELEMENT if requested.

    IF clc$sp_match_at_left IN build_options THEN
      build_left_end_element;
    IFEND;

{ Rebuild the sequence pointer to the resulting pattern in order to get the
{ correct size information into it.

    pattern_size := i#current_sequence_position (work_area);
    RESET work_area TO pattern;
    pattern_size := pattern_size - i#current_sequence_position (work_area);
    NEXT pattern: [[REP pattern_size OF cell]] IN work_area;
    RESET pattern;

  PROCEND clp$build_pattern_for_wild_card;
?? TITLE := 'clp$match_string_pattern', EJECT ??
*copy clh$match_string_pattern

{
{ DESIGN:
{
{   For an overview of the string pattern matching algorithm, see the
{   description at the beginning of the modules.
{
{   The processors for the CLC$SP_CAPTURE_BEGIN and CLC$SP_CAPTURE_END elements
{   synchronize their actions through the "capture stack".  The pointer to this
{   stack is kept in the "global" variable CAPTURE_STACK which is initially
{   NIL.  The processor for the CLC$SP_CAPTURE_BEGIN element has a local
{   variable called CAPTURE_STACK_ENTRY.  When that processor is called it
{   "pushes" its entry onto the capture stack and initializes it to hold the
{   SUBJECT_INDEX at the point where the CLC$SP_CAPTURE_BEGIN element was
{   encountered.  When the processor for the CLC$SP_CAPTURE_END element is
{   called, it searches the "capture stack" for the entry created for the
{   corresponding CLC$SP_CAPTURE_BEGIN element.  The substring of the SUBJECT
{   to capture starts at the SUBJECT_INDEX in the stack entry and goes up to,
{   but not including, the SUBJECT_INDEX when the CLC$SP_CAPTURE_END processor
{   was called.  A capture stack entry is "popped" off the capture stack by the
{   CLC$SP_CAPTURE_BEGIN processor that "pushed" it onto the stack.
{
{   The processors for the CLC$SP_REPEAT_PATTERN_BEGIN and
{   CLC$SP_REPEAT_PATTERN_END elements use the "repeat pattern stack" in a
{   similar way.  The pointer to this stack is kept in the "global" variable
{   REPEAT_PATTERN_STACK which is initially NIL.  The processor for the
{   CLC$SP_REPEAT_PATTERN_BEGIN has a local variable called
{   REPEAT_PATTERN_STACK_ENTRY.  When that processor is called it "pushes" its
{   entry onto the repeat pattern stack and initializes it.  The COUNT field
{   indicates the number of times the pattern to be matched repeatedly has
{   actually been matched.  The MATCH_ATTEMPTED field is used to help detect
{   when the pattern to be repeated has matched the null string.  (If it
{   matched the null string once, the chances are good that it will match the
{   null string again.) The SUBJECT_INDEX field keeps track of where the last
{   attempt to match the repeated pattern started.  When the processor for the
{   CLC$SP_REPEAT_PATTERN_END element is called, it searches the "repeat
{   pattern stack" for the entry created for the corresponding
{   CLC$SP_REPEAT_PATTERN_BEGIN element.  It is the CLC$SP_REPEAT_PATTERN_END
{   processor that drives the repeated matching attempts.  A repeat pattern
{   stack entry is "popped" off the repeat pattern stack by the
{   CLC$SP_REPEAT_PATTERN_BEGIN processor that "pushed" it onto the stack.
{
{   For both of the above element pairs, the maintenance of the stacks requires
{   that CYBIL's "rules" about the lifetime of pointers be ignored since the
{   pointers to the stacks must be able to point at variables local to nested
{   procedures.  The points where this ignoring of the "rules" take place are
{   noted in the code.
{
{   The processor for the CLC$SP_UNEVALUATED_PATTERN element requires a stack
{   similar to those for repeating and capturing, described above.  In this
{   case the SUCCESSOR_STACK_ENTRYs keep track of the elements that are the
{   successors of the unevalauted elements.  These successors must be scanned
{   immediately following the corresponding evaluated sub-patterns in order to
{   maintain proper context.
{
{   The other pattern element processors are comparatively straight forward.
{   The processor for CLC$SP_MULTIPLE does look at its successor in an attempt
{   to optimize its own processing.  This same optimization is done when the
{   CLC$SP_UNANCHORED option is specified.
{

  PROCEDURE [XDCL, #GATE] clp$match_string_pattern
    (    subject: clt$string_value;
         pattern: ^clt$string_pattern;
         anchor_option: clt$string_pattern_anchor_opt;
         scan_option: clt$string_pattern_scan_option;
     VAR match_info: clt$string_pattern_match_info;
     VAR status: ost$status);


    TYPE
      clt$capture_stack_entry = record
        link: ^clt$capture_stack_entry,
        end_element: clt$string_pattern_element_link,
        subject_index: clt$string_index,
      recend;

    TYPE
      clt$repeat_pattern_stack_entry = record
        link: ^clt$repeat_pattern_stack_entry,
        end_element: clt$string_pattern_element_link,
        count: clt$string_size,
        match_attempted: boolean,
        subject_index: clt$string_index,
      recend;

    TYPE
      clt$successor_stack_entry = record
        link: ^clt$successor_stack_entry,
        process: boolean,
        pattern: ^clt$string_pattern,
        element: clt$string_pattern_element_link,
      recend;


    VAR
      capture_stack: ^clt$capture_stack_entry,
      initial_characters: ^clt$string_pattern_characters,
      initial_pattern_element: ^clt$string_pattern_element,
      initial_string_literal: ^clt$string_value,
      look_for_initial_characters: ^clt$string_pattern_characters,
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header,
      repeat_pattern_stack: ^clt$repeat_pattern_stack_entry,
      scan_failure_reason: clt$string_pattern_fail_reason,
      scan_found_char: boolean,
      scan_index: clt$string_index,
      subject_index: clt$string_index,
      successor_stack: ^clt$successor_stack_entry;

?? NEWTITLE := 'bad_string_pattern', EJECT ??

{
{ PURPOSE:
{   This procedure is called when an inconsistency in the structure of a string
{   pattern is detected.  It causes an abnormal status exit from the entire
{   pattern matching process.
{

    PROCEDURE [INLINE] bad_string_pattern;


      osp$set_status_condition (cle$bad_string_pattern, status);
      EXIT clp$match_string_pattern;

    PROCEND bad_string_pattern;
?? TITLE := 'scan_string_pattern', EJECT ??

{
{ PURPOSE:
{
{   This procedure controls the matching for one or more pattern elements.
{
{ DESIGN:
{
{   It calls individual processors for each kind of pattern element.  Upon
{   return from one of these, it procedes to the element's successor if the
{   element matched.  If the element failed to match and has an alternative,
{   an attempt to match the alternative is made.
{
{   Whenever this main controlling procedure or one of the individual matching
{   processors might be backed into to try an alternative, this procedure is
{   called recursivly in order to be able to restart the scan in the proper
{   context with the alternative.
{
{ PATTERN: (input)  This parameter specifies the CLT$STRING_PATTERN containing
{       the PATTERN_ELEMENT to be processed.  This is needed to support the
{       processing for the CLC$SP_UNEVALUATED_PATTERN element.
{
{ SUBJECT_INDEX: (input, output)  This parameter specifies the index within the
{       SUBJECT string at which the scanning (matching) process should start.
{       If the match was successful, this value is updated to indicate how much
{       of the SUBJECT was matched.
{
{ PATTERN_ELEMENT: (input, output)  This parameter specifies the elment of the
{       PATTERN to be matched next.  This pointer is updated to designate the
{       last element for which a match attempt was made.
{
{ SCAN_FAILURE_REASON: (output)  This parameter is meaningful only if the match
{       attempt failed, i.e. if SCAN_MATCH_INFO.RESULT is CLC$SP_FAILURE.  In
{       case it indicates the reason for the failure.  See the discussion at
{       beginning of this module for an explanation of the various reasons for
{       failure.
{
{ SCAN_MATCH_INFO: (output)  This parameter specifies the whether the RESULT of
{       the match attempt was CLC$SP_SUCCESS or CLC$SP_FAILURE.  If success,
{       the INDEX and SIZE fields can be used to extract the substring of the
{       SUBJECT which matched the PATTERN.
{

    PROCEDURE scan_string_pattern
      (    pattern: ^clt$string_pattern;
       VAR subject_index {input, output} : clt$string_index;
       VAR pattern_element {input, output} : ^clt$string_pattern_element;
       VAR scan_failure_reason: clt$string_pattern_fail_reason;
       VAR scan_match_info: clt$string_pattern_match_info);

      VAR
        alternative_pattern_element: ^clt$string_pattern_element,
        element_failure_reason: clt$string_pattern_fail_reason,
        element_match_result: clt$string_pattern_match_result,
        local_match_info: clt$string_pattern_match_info,
        local_subject_index: clt$string_index,
        original_subject_index: clt$string_index,
        remaining_subject_size: clt$string_size;

?? NEWTITLE := 'process_balanced_pair', EJECT ??

{
{ PURPOSE:
{   This procedure processes a CLC$SP_BALANCED_PAIR element.
{
{ NOTE:
{   This element has implied alternatives.  If it is backed into with failure
{   it increases the number of characters it matches and retries its
{   successors.
{

      PROCEDURE process_balanced_pair;

        VAR
          found_balanced_pair: boolean,
          left_character: char,
          local_failure_reason: clt$string_pattern_fail_reason,
          local_match_info: clt$string_pattern_match_info,
          local_subject_index: clt$string_index,
          min_successor_size: clt$string_size,
          nesting_count: clt$string_size,
          right_character: char,
          successor_pattern_element: ^clt$string_pattern_element;


        IF remaining_subject_size < pattern_element^.min_subject_size THEN
          element_match_result := clc$sp_failure;
          element_failure_reason := clc$sp_fail_size;
          RETURN;
        ELSEIF subject (subject_index) = pattern_element^.right_character THEN
          element_match_result := clc$sp_failure;
          element_failure_reason := clc$sp_fail_match;
          RETURN;
        ELSEIF pattern_element^.successor = NIL THEN
          element_match_result := clc$sp_success;
          subject_index := subject_index + 1;
          RETURN;
        IFEND;

        successor_pattern_element := #PTR (pattern_element^.successor, pattern^);
        min_successor_size := min_subject_size (successor_pattern_element);
        left_character := pattern_element^.left_character;
        right_character := pattern_element^.right_character;

        found_balanced_pair := FALSE;
        local_subject_index := subject_index;

        WHILE TRUE DO
          nesting_count := 0;

        /match_characters/
          REPEAT
            IF subject (local_subject_index) = left_character THEN
              nesting_count := nesting_count + 1;
              found_balanced_pair := TRUE;
            ELSEIF subject (local_subject_index) = right_character THEN
              IF nesting_count = 0 THEN
                EXIT /match_characters/;
              IFEND;
              nesting_count := nesting_count - 1;
            IFEND;
            local_subject_index := local_subject_index + 1;
          UNTIL (nesting_count = 0) OR (local_subject_index > STRLENGTH (subject)) {/match_characters/} ;

          IF (STRLENGTH (subject) - local_subject_index + 1) < min_successor_size THEN
            element_match_result := clc$sp_failure;
            element_failure_reason := clc$sp_fail_size;
            RETURN;
          ELSEIF nesting_count <> 0 THEN
            element_match_result := clc$sp_failure;
            element_failure_reason := clc$sp_fail_match;
            RETURN;
          IFEND;

{ Call the main scan procedure to deal with this element's successors in order
{ to gain control when the scanning process backs up.

          pattern_element := successor_pattern_element;
          scan_string_pattern (pattern, local_subject_index, pattern_element, local_failure_reason,
                local_match_info);

          IF local_match_info.result = clc$sp_success THEN
            element_match_result := clc$sp_success;
            subject_index := local_subject_index;
            RETURN;
          ELSEIF scan_option = clc$sp_quick_scan THEN
            IF local_failure_reason <> clc$sp_fail_match THEN
              element_match_result := clc$sp_failure;
              IF found_balanced_pair THEN
                element_failure_reason := clc$sp_fail_match;
              ELSE
                element_failure_reason := local_failure_reason;
              IFEND;
              RETURN;
            IFEND;
          IFEND;

          IF (local_subject_index > STRLENGTH (subject)) OR (subject (local_subject_index) =
                right_character) THEN
            element_match_result := clc$sp_failure;
            element_failure_reason := clc$sp_fail_match;
            RETURN;
          IFEND;
        WHILEND;

      PROCEND process_balanced_pair;
?? TITLE := 'process_capture_begin', EJECT ??

{
{ PURPOSE:
{   This procedure processes a CLC$SP_CAPTURE_BEGIN element.
{
{ DESIGN:
{   See the discussion at the beginning of CLP$MATCH_STRING_PATTERN for an
{   explanation of how this processor works in conjunction with the one for
{   a CLC$SP_CAPTURE_END element.
{

      PROCEDURE process_capture_begin;

        VAR
          capture_stack_entry: clt$capture_stack_entry;


{ "Push" an entry onto the capture stack.

        capture_stack_entry.link := capture_stack;
        capture_stack_entry.end_element := pattern_element^.capture_end_element;
        capture_stack_entry.subject_index := subject_index;

{ The following assignment will cause a "pointer lifetime" warning from CYBIL.
{ This is OK!

        capture_stack := ^capture_stack_entry;

        IF pattern_element^.successor = NIL THEN
          bad_string_pattern;
        IFEND;

{ Call the main scan procedure to deal with element's successors in order to
{ gain control when the scanning process backs up.

        pattern_element := #PTR (pattern_element^.successor, pattern^);
        scan_string_pattern (pattern, subject_index, pattern_element, scan_failure_reason, scan_match_info);

        element_match_result := scan_match_info.result;
        IF element_match_result = clc$sp_failure THEN
          element_failure_reason := scan_failure_reason;
          IF element_failure_reason = clc$sp_fail_immediate_capture THEN

{ See the discussion at the beginning of the module for how the failure reason
{ information is used.

            element_failure_reason := clc$sp_fail_match;
          IFEND;
        IFEND;

      PROCEND process_capture_begin;
?? TITLE := 'process_capture_end', EJECT ??

{
{ PURPOSE:
{   This procedure processes a CLC$SP_CAPTURE_END element.
{
{ DESIGN:
{   See the discussion at the beginning of CLP$MATCH_STRING_PATTERN for an
{   explanation of how this processor works in conjunction with the one for
{   a CLC$SP_CAPTURE_BEGIN element.
{

      PROCEDURE process_capture_end;

        VAR
          capture_index: clt$string_index,
          capture_size: clt$string_size,
          capture_stack_entry: ^clt$capture_stack_entry,
          this_element: ^clt$string_pattern_element,
          this_element_link: clt$string_pattern_element_link,
          immediate_capture: boolean;

?? NEWTITLE := 'capture', EJECT ??

{
{ PURPOSE:
{   This procedure does the actual work of capturing a matched substring.
{

        PROCEDURE capture
          (    matched_substring: clt$string_value);

{ TYPE
{   string = string

          VAR
            type_specification: [STATIC, READ, cls$declaration_section] record
              header: clt$type_specification_header,
              qualifier: clt$string_type_qualifier,
            recend := [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]];

{ TYPEND

          VAR
            c: clt$string_index,
*IF NOT $true(osv$unix)
            callers_save_area: ^ost$stack_frame_save_area,
*IFEND
            capture_command: ^clt$command_line,
            capture_command_line: ^clt$command_line,
            capture_command_line_size: integer,
            capture_value: clt$data_value,
            capture_variable: ^clt$variable_ref_expression,
            create_status: ^ost$status,
            m: clt$string_index,
            quote_count: clt$string_size;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'bad_capture_procedure_handler', EJECT ??

{
{ PURPOSE:
{   This condition handler intercepts the conditions that result from trying to
{   use a bad procedure pointer.  If one of these conditions occurs, it is
{   assumed that the CLT$STRING_PATTERN is garbled.
{

          PROCEDURE bad_capture_procedure_handler
            (    condition: pmt$condition;
                 ignore_info: ^pmt$condition_information;
                 save_area: ^ost$stack_frame_save_area;
             VAR handler_status: ost$status);


            IF (condition.selector = pmc$system_conditions) AND
                  (($pmt$system_conditions [pmc$instruction_specification, pmc$address_specification,
                  pmc$access_violation, pmc$environment_specification, pmc$invalid_segment_ring_0,
                  pmc$out_call_in_return] * condition.system_conditions) <> $pmt$system_conditions []) THEN
              IF save_area^.minimum_save_area.a2_previous_save_area = callers_save_area THEN
                bad_string_pattern;
              IFEND;
            IFEND;

            pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
            handler_status.normal := TRUE;

          PROCEND bad_capture_procedure_handler;
?? OLDTITLE, EJECT ??
*IFEND

          CASE this_element^.capture_kind OF

          = clc$sp_capture_via_command =
            quote_count := 0;
            FOR m := 1 TO STRLENGTH (matched_substring) DO
              IF matched_substring (m) = '''' THEN
                quote_count := quote_count + 1;
              IFEND;
            FOREND;
            capture_command := #PTR (this_element^.capture_command, pattern^);
            capture_command_line_size := STRLENGTH (capture_command^) + 2 + STRLENGTH (matched_substring) +
                  quote_count + 1;
            IF capture_command_line_size > clc$max_command_line_size THEN
              osp$set_status_condition (cle$string_too_long, status);
              EXIT clp$match_string_pattern;
            IFEND;
            PUSH capture_command_line: [capture_command_line_size];
            capture_command_line^ (1, STRLENGTH (capture_command^)) := capture_command^;
            c := STRLENGTH (capture_command^) + 1;
            capture_command_line^ (c, 2) := ' ''';
            c := c + 2;
            FOR m := 1 TO STRLENGTH (matched_substring) DO
              IF matched_substring (m) = '''' THEN
                capture_command_line^ (c) := '''';
                c := c + 1;
              IFEND;
              capture_command_line^ (c) := matched_substring (m);
              c := c + 1;
            FOREND;
            capture_command_line^ (capture_command_line_size) := '''';

*IF NOT $true(osv$unix)
            clp$include_line (capture_command_line^, FALSE {disable echoing} , osc$null_name, status);
            IF NOT status.normal THEN
              EXIT clp$match_string_pattern;
            IFEND;
*IFEND

          = clc$sp_capture_via_procedure =
*IF NOT $true(osv$unix)
            callers_save_area := #PREVIOUS_SAVE_AREA ();
            osp$establish_condition_handler (^bad_capture_procedure_handler, FALSE);
*IFEND

            this_element^.capture_procedure^ (^matched_substring, status);
            IF NOT status.normal THEN
              EXIT clp$match_string_pattern;
            IFEND;

          = clc$sp_capture_via_variable =
            capture_value.kind := clc$string;
            capture_value.string_value := ^matched_substring;
            capture_variable := #PTR (this_element^.capture_variable, pattern^);

*IF NOT $true(osv$unix)
            clp$change_variable (capture_variable^, ^capture_value, status);
            IF NOT status.normal THEN
              IF status.condition <> cle$unknown_variable THEN
                EXIT clp$match_string_pattern;
              IFEND;
              PUSH create_status;
              clp$create_procedure_variable (capture_variable^, clc$local_scope, clc$read_write,
                    clc$immediate_evaluation, #SEQ (type_specification), ^capture_value, create_status^);
              IF NOT create_status^.normal THEN
                EXIT clp$match_string_pattern;
              IFEND;
              status.normal := TRUE;
            IFEND;
*IFEND

          ELSE
            bad_string_pattern;
          CASEND;

        PROCEND capture;
?? OLDTITLE, EJECT ??

{ Search the capture stack for the entry that corresponds to this elment.

        capture_stack_entry := capture_stack;
        this_element := pattern_element;
        this_element_link := #REL (this_element, pattern^);
        WHILE (capture_stack_entry <> NIL) AND (capture_stack_entry^.end_element <> this_element_link) DO
          capture_stack_entry := capture_stack_entry^.link;
        WHILEND;

        IF capture_stack_entry = NIL THEN
          bad_string_pattern;
        IFEND;

{ Determine the index and size of the substring of the SUBJECT to be captured.

        capture_index := capture_stack_entry^.subject_index;
        capture_size := subject_index - capture_index;

        immediate_capture := pattern_element^.immediate_capture;

        IF immediate_capture THEN

{ An "immediate capture" is performed as soon as this element is reached.

          capture (subject (capture_index, capture_size));
        IFEND;

        IF pattern_element^.successor = NIL THEN
          element_match_result := clc$sp_success;
        ELSE

{ Call the main scan procedure to deal with this element's successors in order
{ to gain control when the scanning process backs up.

          pattern_element := #PTR (pattern_element^.successor, pattern^);
          scan_string_pattern (pattern, subject_index, pattern_element, scan_failure_reason, scan_match_info);

          element_match_result := scan_match_info.result;
          IF element_match_result = clc$sp_failure THEN
            element_failure_reason := scan_failure_reason;
            IF (element_failure_reason = clc$sp_fail_unevaluated) AND immediate_capture THEN

{ See the discussion at the beginning of the module for how the failure reason
{ information is used.

              element_failure_reason := clc$sp_fail_immediate_capture;
            IFEND;
          IFEND;
        IFEND;

        IF (element_match_result = clc$sp_success) AND (NOT immediate_capture) THEN

{ A "conditional capture" is performed after the entire pattern has been
{ successfully matched.

          capture (subject (capture_index, capture_size));
        IFEND;

      PROCEND process_capture_end;
?? TITLE := 'process_capture_index', EJECT ??

{
{ PURPOSE:
{   This procedure processes a CLC$SP_CAPTURE_INDEX element.
{

      PROCEDURE process_capture_index;

{ TYPE
{   index = integer 1..clc$max_string_size+1

        VAR
          type_specification: [STATIC, READ, cls$declaration_section] record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend := [[1, 0, clc$integer_type], [1, clc$max_string_size + 1, 10]];

{ TYPEND

        VAR
*IF NOT $true(osv$unix)
          callers_save_area: ^ost$stack_frame_save_area,
*IFEND
          capture_command: ^clt$command_line,
          capture_command_line: ^clt$command_line,
          capture_command_line_size: integer,
          capture_value: clt$data_value,
          capture_variable: ^clt$variable_ref_expression,
          create_status: ^ost$status,
          index_string: ost$string;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'bad_capture_procedure_handler', EJECT ??

{
{ PURPOSE:
{   This condition handler intercepts the conditions that result from trying to
{   use a bad procedure pointer.  If one of these conditions occurs, it is
{   assumed that the CLT$STRING_PATTERN is garbled.
{

        PROCEDURE bad_capture_procedure_handler
          (    condition: pmt$condition;
               ignore_info: ^pmt$condition_information;
               save_area: ^ost$stack_frame_save_area;
           VAR handler_status: ost$status);


          IF (condition.selector = pmc$system_conditions) AND
                (($pmt$system_conditions [pmc$instruction_specification, pmc$address_specification,
                pmc$access_violation, pmc$environment_specification, pmc$invalid_segment_ring_0,
                pmc$out_call_in_return] * condition.system_conditions) <> $pmt$system_conditions []) THEN
            IF save_area^.minimum_save_area.a2_previous_save_area = callers_save_area THEN
              bad_string_pattern;
            IFEND;
          IFEND;

          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          handler_status.normal := TRUE;

        PROCEND bad_capture_procedure_handler;
?? OLDTITLE, EJECT ??
*IFEND

        CASE pattern_element^.capture_kind OF

        = clc$sp_capture_via_command =
          clp$convert_integer_to_string (subject_index, 10, FALSE, index_string, status);
          IF NOT status.normal THEN
            EXIT clp$match_string_pattern;
          IFEND;

          capture_command := #PTR (pattern_element^.capture_command, pattern^);
          capture_command_line_size := STRLENGTH (capture_command^) + 2 + index_string.size + 1;
          IF capture_command_line_size > clc$max_command_line_size THEN
            osp$set_status_condition (cle$string_too_long, status);
            EXIT clp$match_string_pattern;
          IFEND;
          PUSH capture_command_line: [capture_command_line_size];
          capture_command_line^ (1, STRLENGTH (capture_command^)) := capture_command^;
          capture_command_line^ (STRLENGTH (capture_command^) + 1, 2) := ' ''';
          capture_command_line^ (STRLENGTH (capture_command^) + 3, index_string.size) :=
                index_string.value (1, index_string.size);
          capture_command_line^ (capture_command_line_size) := '''';

*IF NOT $true(osv$unix)
          clp$include_line (capture_command_line^, FALSE {disable echoing} , osc$null_name, status);
          IF NOT status.normal THEN
            EXIT clp$match_string_pattern;
          IFEND;
*IFEND

        = clc$sp_capture_via_procedure =
          clp$convert_integer_to_string (subject_index, 10, FALSE, index_string, status);
          IF NOT status.normal THEN
            EXIT clp$match_string_pattern;
          IFEND;

*IF NOT $true(osv$unix)
          callers_save_area := #PREVIOUS_SAVE_AREA ();
          osp$establish_condition_handler (^bad_capture_procedure_handler, FALSE);
*IFEND

          pattern_element^.capture_procedure^ (^index_string.value (1, index_string.size), status);
          IF NOT status.normal THEN
            EXIT clp$match_string_pattern;
          IFEND;

        = clc$sp_capture_via_variable =
          capture_value.kind := clc$integer;
          capture_value.integer_value.value := subject_index;
          capture_value.integer_value.radix := 10;
          capture_value.integer_value.radix_specified := FALSE;
          capture_variable := #PTR (pattern_element^.capture_variable, pattern^);

*IF NOT $true(osv$unix)
          clp$change_variable (capture_variable^, ^capture_value, status);
          IF NOT status.normal THEN
            IF status.condition <> cle$unknown_variable THEN
              EXIT clp$match_string_pattern;
            IFEND;
            PUSH create_status;
            clp$create_procedure_variable (capture_variable^, clc$local_scope, clc$read_write,
                  clc$immediate_evaluation, #SEQ (type_specification), ^capture_value, create_status^);
            IF NOT create_status^.normal THEN
              EXIT clp$match_string_pattern;
            IFEND;
            status.normal := TRUE;
          IFEND;
*IFEND

        ELSE
          bad_string_pattern;
        CASEND;

        element_match_result := clc$sp_success;

      PROCEND process_capture_index;
?? TITLE := 'process_characters', EJECT ??

{
{ PURPOSE:
{   This procedure processes a CLC$SP_CHARACTERS element.
{
{ NOTE:
{   The character set for this pattern element must actually be the complement
{   of the set originally specified.  This is because the #SCAN intrinsic is
{   used to skip over characters which are not in the set.
{

      PROCEDURE [INLINE] process_characters;

        VAR
          characters: ^clt$string_pattern_characters,
          scan_found_char: boolean,
          scan_index: clt$string_index;


        IF remaining_subject_size < pattern_element^.count THEN
          element_match_result := clc$sp_failure;
          element_failure_reason := clc$sp_fail_size;
        ELSE
          characters := #PTR (pattern_element^.characters, pattern^);
          #SCAN (characters^, subject (subject_index, * ), scan_index, scan_found_char);
          IF scan_index > pattern_element^.count THEN
            element_match_result := clc$sp_success;
            subject_index := subject_index + scan_index - 1;
          ELSE
            element_match_result := clc$sp_failure;
            element_failure_reason := clc$sp_fail_match;
          IFEND;
        IFEND;

      PROCEND process_characters;
?? TITLE := 'process_count', EJECT ??

{
{ PURPOSE:
{   This procedure processes a CLC$SP_COUNT element.
{

      PROCEDURE [INLINE] process_count;

        VAR
          excluded_characters: ^clt$string_pattern_characters,
          max_subject_index: clt$string_index;


        IF pattern_element^.characters = NIL THEN
          max_subject_index := STRLENGTH (subject) + 1;
          element_failure_reason := clc$sp_fail_size;
        ELSE
          excluded_characters := #PTR (pattern_element^.characters, pattern^);
          #SCAN (excluded_characters^, subject (subject_index, * ), scan_index, scan_found_char);
          max_subject_index := subject_index + scan_index - 1;
          element_failure_reason := clc$sp_fail_match;
        IFEND;

        IF (max_subject_index - subject_index) < pattern_element^.count THEN
          element_match_result := clc$sp_failure;

{ element_failure_reason established above

        ELSE
          element_match_result := clc$sp_success;
          subject_index := subject_index + pattern_element^.count;
        IFEND;

      PROCEND process_count;
?? TITLE := 'process_count_test_left', EJECT ??

{
{ PURPOSE:
{   This procedure processes a CLC$SP_COUNT_TEST_LEFT element.
{

      PROCEDURE [INLINE] process_count_test_left;


        IF (subject_index - 1) = pattern_element^.count THEN
          element_match_result := clc$sp_success;
        ELSEIF (subject_index - 1) > pattern_element^.count THEN
          element_match_result := clc$sp_failure;
          element_failure_reason := clc$sp_fail_size;
        ELSE
          element_match_result := clc$sp_failure;
          element_failure_reason := clc$sp_fail_match;
        IFEND;

      PROCEND process_count_test_left;
?? TITLE := 'process_count_test_right', EJECT ??

{
{ PURPOSE:
{   This procedure processes a CLC$SP_COUNT_TEST_RIGHT element.
{

      PROCEDURE [INLINE] process_count_test_right;


        IF remaining_subject_size = pattern_element^.count THEN
          element_match_result := clc$sp_success;
        ELSEIF remaining_subject_size < pattern_element^.count THEN
          element_match_result := clc$sp_failure;
          element_failure_reason := clc$sp_fail_size;
        ELSE
          element_match_result := clc$sp_failure;
          element_failure_reason := clc$sp_fail_match;
        IFEND;

      PROCEND process_count_test_right;
?? TITLE := 'process_fail_element', EJECT ??

{
{ PURPOSE:
{   This procedure processes a CLC$SP_FAIL_ELEMENT element.
{

      PROCEDURE [INLINE] process_fail_element;


        element_match_result := clc$sp_failure;
        element_failure_reason := clc$sp_fail_match;

      PROCEND process_fail_element;
?? TITLE := 'process_fail_pattern', EJECT ??

{
{ PURPOSE:
{   This procedure processes a CLC$SP_FAIL_PATTERN element.
{
{ NOTE:
{   This element terminates the entire string matching process.
{

      PROCEDURE [INLINE] process_fail_pattern;


        match_info.result := clc$sp_failure;
        EXIT clp$match_string_pattern;

      PROCEND process_fail_pattern;
?? TITLE := 'process_fence', EJECT ??

{
{ PURPOSE:
{   This procedure processes a CLC$SP_FENCE element.
{
{ NOTE:
{   This element terminates the entire string matching process if it is
{   backed into with failure.
{

      PROCEDURE process_fence;


        IF pattern_element^.successor = NIL THEN
          element_match_result := clc$sp_success;
          RETURN;
        IFEND;

{ Call the main scan procedure to deal with this element's successors in order
{ to gain control when the scanning process backs up.

        pattern_element := #PTR (pattern_element^.successor, pattern^);
        scan_string_pattern (pattern, subject_index, pattern_element, scan_failure_reason, scan_match_info);

        IF scan_match_info.result = clc$sp_success THEN
          element_match_result := clc$sp_success;
          RETURN;
        IFEND;

        match_info.result := clc$sp_failure;
        EXIT clp$match_string_pattern;

      PROCEND process_fence;
?? TITLE := 'process_multiple', EJECT ??

{
{ PURPOSE:
{   This procedure processes a CLC$SP_MULTIPLE element.
{
{ NOTE:
{   This element has implied alternatives.  If it is backed into with failure
{   it increases the number of characters it matches and retries its
{   successors.
{

      PROCEDURE process_multiple;

        VAR
          excluded_characters: ^clt$string_pattern_characters,
          local_failure_reason: clt$string_pattern_fail_reason,
          local_match_info: clt$string_pattern_match_info,
          local_subject_index: clt$string_index,
          look_for_characters: ^clt$string_pattern_characters,
          max_subject_index: clt$string_index,
          min_count: clt$string_size,
          min_successor_size: clt$string_size,
          successor_characters: ^clt$string_pattern_characters,
          successor_pattern_element: ^clt$string_pattern_element,
          successor_string_literal: ^clt$string_value;


        min_count := pattern_element^.count;

        IF pattern_element^.characters = NIL THEN
          max_subject_index := STRLENGTH (subject) + 1;
          element_failure_reason := clc$sp_fail_size;
        ELSE
          excluded_characters := #PTR (pattern_element^.characters, pattern^);
          #SCAN (excluded_characters^, subject (subject_index, * ), scan_index, scan_found_char);
          max_subject_index := subject_index + scan_index - 1;
          element_failure_reason := clc$sp_fail_match;
        IFEND;

        IF (max_subject_index - subject_index) < min_count THEN
          element_match_result := clc$sp_failure;

{ element_failure_reason established above

          RETURN;
        ELSEIF pattern_element^.successor = NIL THEN
          element_match_result := clc$sp_success;
          subject_index := max_subject_index;
          RETURN;
        IFEND;

        successor_pattern_element := #PTR (pattern_element^.successor, pattern^);
        min_successor_size := min_subject_size (successor_pattern_element);

{ Examine the successor element to determine whether a look ahead can be done
{ for the first character matched by the successor.

        look_for_characters := NIL;
        IF successor_pattern_element^.alternative = NIL THEN
          CASE successor_pattern_element^.kind OF
          = clc$sp_characters =
            IF successor_pattern_element^.count >= 1 THEN
              PUSH look_for_characters;
              successor_characters := #PTR (successor_pattern_element^.characters, pattern^);
              look_for_characters^ := -successor_characters^;
            IFEND;
          = clc$sp_one_character =
            look_for_characters := #PTR (successor_pattern_element^.characters, pattern^);
          = clc$sp_string_literal =
            PUSH look_for_characters;
            successor_string_literal := #PTR (successor_pattern_element^.string_literal, pattern^);
            IF successor_pattern_element^.case_sensitive THEN
              look_for_characters^ := $clt$string_pattern_characters [successor_string_literal^ (1)];
            ELSE
              look_for_characters^ := $clt$string_pattern_characters
                    [osv$lower_to_upper ($INTEGER (successor_string_literal^ (1)) + 1),
                    osv$upper_to_lower ($INTEGER (successor_string_literal^ (1)) + 1)];
            IFEND;
          ELSE
            ;
          CASEND;
        IFEND;

        local_subject_index := subject_index + min_count;
        IF look_for_characters <> NIL THEN

{ If the look ahead can be done, use the #SCAN intrinsic to do it.

          #SCAN (look_for_characters^, subject (local_subject_index, * ), scan_index, scan_found_char);
          local_subject_index := local_subject_index + scan_index - 1;
          IF (NOT scan_found_char) OR (local_subject_index > max_subject_index) THEN
            element_match_result := clc$sp_failure;
            element_failure_reason := clc$sp_fail_match;
            RETURN;
          IFEND;
        IFEND;

        WHILE TRUE DO
          IF (scan_option = clc$sp_quick_scan) AND ((max_subject_index - local_subject_index + 1) <
                min_successor_size) THEN
            element_match_result := clc$sp_failure;

{ element_failure_reason established above

            RETURN;
          IFEND;

{ Call the main scan procedure to deal with this element's successors in order
{ to gain control when the scanning process backs up.

          pattern_element := successor_pattern_element;
          scan_string_pattern (pattern, local_subject_index, pattern_element, local_failure_reason,
                local_match_info);

          IF local_match_info.result = clc$sp_success THEN
            element_match_result := clc$sp_success;
            subject_index := local_subject_index;
            RETURN;
          ELSEIF scan_option = clc$sp_quick_scan THEN
            IF local_failure_reason <> clc$sp_fail_match THEN
              element_match_result := clc$sp_failure;
              element_failure_reason := local_failure_reason;
              RETURN;
            IFEND;
          IFEND;
          IF local_subject_index >= max_subject_index THEN
            element_match_result := clc$sp_failure;
            element_failure_reason := clc$sp_fail_match;
            RETURN;
          IFEND;

{ Match more characters then retry the successor.

          local_subject_index := local_subject_index + 1;
          IF look_for_characters <> NIL THEN
            #SCAN (look_for_characters^, subject (local_subject_index, * ), scan_index, scan_found_char);
            local_subject_index := local_subject_index + scan_index - 1;
            IF (NOT scan_found_char) OR (local_subject_index > max_subject_index) THEN
              element_match_result := clc$sp_failure;
              element_failure_reason := clc$sp_fail_match;
              RETURN;
            IFEND;
          IFEND;
        WHILEND;

      PROCEND process_multiple;
?? TITLE := 'process_multiple_path_elements', EJECT ??

{
{ PURPOSE:
{   This procedure processes a CLC$SP_MULTIPLE_PATH_ELEMENTS element.
{
{ NOTE:
{   If this element is used at the end of a pattern, its MIN_SUBJECT_SIZE
{   is zero and it matches the null string or a "." followed by anything.
{   When it used other than at the end of a pattern, it has implied
{   alternatives.  Initially is matches a single ".".  If it is backed into
{   with failure it matches up to and including the next "." and retries its
{   successors.
{

      PROCEDURE process_multiple_path_elements;

        VAR
          local_failure_reason: clt$string_pattern_fail_reason,
          local_match_info: clt$string_pattern_match_info,
          local_subject_index: clt$string_index,
          min_successor_size: clt$string_size,
          path_element_separator: [STATIC, READ, oss$job_paged_literal] clt$string_pattern_characters :=
                [clc$wc_path_element_separator],
          successor_pattern_element: ^clt$string_pattern_element;


        IF pattern_element^.min_subject_size = 0 THEN
          IF (remaining_subject_size = 0) OR (subject (subject_index) = '.') THEN
            element_match_result := clc$sp_success;
            subject_index := STRLENGTH (subject) + 1;
          ELSE
            element_match_result := clc$sp_failure;
            element_failure_reason := clc$sp_fail_match;
          IFEND;
          RETURN;
        ELSEIF remaining_subject_size = 0 THEN
          element_match_result := clc$sp_failure;
          element_failure_reason := clc$sp_fail_size;
          RETURN;
        ELSEIF subject (subject_index) <> clc$wc_path_element_separator THEN
          element_match_result := clc$sp_failure;
          element_failure_reason := clc$sp_fail_match;
          RETURN;
        IFEND;

        successor_pattern_element := #PTR (pattern_element^.successor, pattern^);
        min_successor_size := min_subject_size (successor_pattern_element);

        local_subject_index := subject_index + 1;

        WHILE TRUE DO
          IF (scan_option = clc$sp_quick_scan) AND ((STRLENGTH (subject) - local_subject_index + 1) <
                min_successor_size) THEN
            element_match_result := clc$sp_failure;
            element_failure_reason := clc$sp_fail_size;
            RETURN;
          IFEND;

{ Call the main scan procedure to deal with this element's successors in order
{ to gain control when the scanning process backs up.

          pattern_element := successor_pattern_element;
          scan_string_pattern (pattern, local_subject_index, pattern_element, local_failure_reason,
                local_match_info);

          IF local_match_info.result = clc$sp_success THEN
            element_match_result := clc$sp_success;
            subject_index := local_subject_index;
            RETURN;
          ELSEIF scan_option = clc$sp_quick_scan THEN
            IF local_failure_reason <> clc$sp_fail_match THEN
              element_match_result := clc$sp_failure;
              element_failure_reason := local_failure_reason;
              RETURN;
            IFEND;
          ELSEIF local_subject_index >= STRLENGTH (subject) THEN
            element_match_result := clc$sp_failure;
            element_failure_reason := clc$sp_fail_match;
            RETURN;
          IFEND;

{ Match next path element then retry the successor.

          #SCAN (path_element_separator, subject (local_subject_index, * ), scan_index, scan_found_char);
          IF NOT scan_found_char THEN
            element_match_result := clc$sp_failure;
            element_failure_reason := clc$sp_fail_match;
            RETURN;
          IFEND;
          local_subject_index := local_subject_index + scan_index;
        WHILEND;

      PROCEND process_multiple_path_elements;
?? TITLE := 'process_one_character', EJECT ??

{
{ PURPOSE:
{   This procedure processes a CLC$SP_ONE_CHARACTER element.
{

      PROCEDURE [INLINE] process_one_character;

        VAR
          characters: ^clt$string_pattern_characters;


        IF remaining_subject_size < 1 THEN
          element_match_result := clc$sp_failure;
          element_failure_reason := clc$sp_fail_size;
        ELSE
          characters := #PTR (pattern_element^.characters, pattern^);
          IF subject (subject_index) IN characters^ THEN
            element_match_result := clc$sp_success;
            subject_index := subject_index + 1;
          ELSE
            element_match_result := clc$sp_failure;
            element_failure_reason := clc$sp_fail_match;
          IFEND;
        IFEND;

      PROCEND process_one_character;
?? TITLE := 'process_repeat_pattern_begin', EJECT ??

{
{ PURPOSE:
{   This procedure processes a CLC$SP_REPEAT_PATTERN_BEGIN element.
{
{ DESIGN:
{   See the discussion at the beginning of CLP$MATCH_STRING_PATTERN for
{   information on how this processor works in conjunction with the processor
{   for the CLC$SP_REPEAT_PATTERN_END element.
{
{ NOTE:
{   The SUCCESSOR of a CLC$SP_REPEAT_PATTERN_BEGIN element is the corresponding
{   CLC$SP_REPEAT_PATTERN_END element.  The first element of the pattern to be
{   repeated is the ALTERNATIVE of the CLC$SP_REPEAT_PATTERN_END element.  The
{   CLC$SP_REPEAT_PATTERN_END element is also the successor of the repeatable
{   pattern.
{

      PROCEDURE process_repeat_pattern_begin;

        VAR
          repeat_pattern_stack_entry: clt$repeat_pattern_stack_entry;


{ "Push" an entry onto the repeat pattern stack.

        repeat_pattern_stack_entry.link := repeat_pattern_stack;
        repeat_pattern_stack_entry.end_element := pattern_element^.successor;
        repeat_pattern_stack_entry.count := 0;
        repeat_pattern_stack_entry.match_attempted := FALSE;
        repeat_pattern_stack_entry.subject_index := subject_index;

{ The following assignment will cause a "pointer lifetime" warning from CYBIL.
{ This is OK!

        repeat_pattern_stack := ^repeat_pattern_stack_entry;

        IF pattern_element^.successor = NIL THEN
          bad_string_pattern;
        IFEND;
        pattern_element := #PTR (pattern_element^.successor, pattern^);
        IF pattern_element^.kind <> clc$sp_repeat_pattern_end THEN
          bad_string_pattern;
        IFEND;

{ Call the main scan procedure to deal with this element's successors in order
{ to gain control when the scanning process backs up.

        scan_string_pattern (pattern, subject_index, pattern_element, scan_failure_reason, scan_match_info);

        element_match_result := scan_match_info.result;
        IF element_match_result = clc$sp_failure THEN
          element_failure_reason := scan_failure_reason;
        IFEND;

{ "Pop" the repeat pattern stack entry that was "pushed" above.

        repeat_pattern_stack := repeat_pattern_stack_entry.link;

      PROCEND process_repeat_pattern_begin;
?? TITLE := 'process_repeat_pattern_end', EJECT ??

{
{ PURPOSE:
{   This procedure processes a CLC$SP_REPEAT_PATTERN_END element.
{
{ DESIGN:
{   See the discussion at the beginning of CLP$MATCH_STRING_PATTERN for
{   information on how this processor works in conjunction with the processor
{   for the CLC$SP_REPEAT_PATTERN_BEGIN element.
{
{ NOTE:
{   The SUCCESSOR of a CLC$SP_REPEAT_PATTERN_BEGIN element is the corresponding
{   CLC$SP_REPEAT_PATTERN_END element.  The first element of the pattern to be
{   repeated is the ALTERNATIVE of the CLC$SP_REPEAT_PATTERN_END element.  The
{   CLC$SP_REPEAT_PATTERN_END element is also the successor of the repeatable
{   pattern.
{

      PROCEDURE process_repeat_pattern_end;

        VAR
          this_element_link: clt$string_pattern_element_link,
          repeat_pattern_stack_entry: ^clt$repeat_pattern_stack_entry;


{ Search the repeat pattern stack for the entry that corresponds to this elment.

        IF pattern_element^.alternative = NIL THEN
          bad_string_pattern;
        IFEND;

        this_element_link := #REL (pattern_element, pattern^);
        repeat_pattern_stack_entry := repeat_pattern_stack;
        WHILE (repeat_pattern_stack_entry <> NIL) AND (repeat_pattern_stack_entry^.end_element <>
              this_element_link) DO
          repeat_pattern_stack_entry := repeat_pattern_stack_entry^.link;
        WHILEND;

        IF repeat_pattern_stack_entry = NIL THEN
          bad_string_pattern;
        IFEND;

        IF repeat_pattern_stack_entry^.count < pattern_element^.count THEN

{ The repeatable pattern hasn't yet been matched the minimum number of times
{ so try to match it again.

          IF (alternative_pattern_element = NIL) OR (repeat_pattern_stack_entry^.match_attempted AND
                (scan_option = clc$sp_quick_scan) AND (subject_index =
                repeat_pattern_stack_entry^.subject_index)) THEN
            element_match_result := clc$sp_failure;
            element_failure_reason := clc$sp_fail_match;
            alternative_pattern_element := NIL;

          ELSE
            repeat_pattern_stack_entry^.match_attempted := TRUE;
            repeat_pattern_stack_entry^.subject_index := subject_index;
            repeat_pattern_stack_entry^.count := repeat_pattern_stack_entry^.count + 1;

{ Call the main scan procedure to deal with this element's alternative which is
{ the first element of the repeatable pattern.

            pattern_element := alternative_pattern_element;
            scan_string_pattern (pattern, subject_index, pattern_element, scan_failure_reason,
                  scan_match_info);

            element_match_result := scan_match_info.result;
            IF element_match_result = clc$sp_failure THEN
              element_failure_reason := scan_failure_reason;
              repeat_pattern_stack_entry^.count := repeat_pattern_stack_entry^.count - 1;
            IFEND;
          IFEND;

        ELSEIF pattern_element^.successor = NIL THEN
          element_match_result := clc$sp_success;

        ELSE

{ Call the main scan procedure to deal with this element's successors in order
{ to gain control when the scanning process backs up.

          pattern_element := #PTR (pattern_element^.successor, pattern^);
          scan_string_pattern (pattern, subject_index, pattern_element, scan_failure_reason, scan_match_info);

          IF scan_match_info.result = clc$sp_success THEN
            element_match_result := clc$sp_success;
            RETURN;
          ELSEIF scan_option = clc$sp_quick_scan THEN
            IF scan_failure_reason <> clc$sp_fail_match THEN
              element_match_result := clc$sp_failure;
              element_failure_reason := scan_failure_reason;
              RETURN;
            IFEND;
          ELSEIF subject_index > STRLENGTH (subject) THEN
            element_match_result := clc$sp_failure;
            element_failure_reason := clc$sp_fail_match;
            RETURN;
          IFEND;

          repeat_pattern_stack_entry^.match_attempted := TRUE;
          repeat_pattern_stack_entry^.subject_index := subject_index;
          repeat_pattern_stack_entry^.count := repeat_pattern_stack_entry^.count + 1;

{ Call the main scan procedure to deal with this element's alternative which is
{ the first element of the repeatable pattern.

          pattern_element := alternative_pattern_element;
          scan_string_pattern (pattern, subject_index, pattern_element, scan_failure_reason, scan_match_info);

          element_match_result := scan_match_info.result;
          IF element_match_result = clc$sp_failure THEN
            element_failure_reason := scan_failure_reason;
            repeat_pattern_stack_entry^.count := repeat_pattern_stack_entry^.count - 1;
          IFEND;
        IFEND;

      PROCEND process_repeat_pattern_end;
?? TITLE := 'process_stacked_successor', EJECT ??

{
{ PURPOSE:
{   This procedure deals with scanning the successor of a
{   CLC$SP_UNEVALUATED_PATTERN element.
{

      PROCEDURE process_stacked_successor;

        VAR
          local_match_info: clt$string_pattern_match_info,
          successor_element: ^clt$string_pattern_element,
          successor_pattern: ^clt$string_pattern;


        IF (successor_stack = NIL) OR (NOT successor_stack^.process) THEN
          RETURN;
        IFEND;

        successor_pattern := successor_stack^.pattern;
        successor_element := #PTR (successor_stack^.element, successor_pattern^);
        successor_stack^.process := FALSE;

        scan_string_pattern (successor_pattern, subject_index, successor_element, element_failure_reason,
              local_match_info);
        element_match_result := local_match_info.result;

        successor_stack^.process := element_match_result = clc$sp_failure;

      PROCEND process_stacked_successor;
?? TITLE := 'process_string_literal', EJECT ??

{
{ PURPOSE:
{   This is the processor for a CLC$SP_STRING_LITERAL element.
{

      PROCEDURE [INLINE] process_string_literal;

        VAR
          string_literal: ^clt$string_value;


        string_literal := #PTR (pattern_element^.string_literal, pattern^);
        IF remaining_subject_size < STRLENGTH (string_literal^) THEN
          element_match_result := clc$sp_failure;
          element_failure_reason := clc$sp_fail_size;
        ELSEIF pattern_element^.case_sensitive THEN
          IF subject (subject_index, STRLENGTH (string_literal^)) = string_literal^ THEN
            element_match_result := clc$sp_success;
            subject_index := subject_index + STRLENGTH (string_literal^);
          ELSE
            element_match_result := clc$sp_failure;
            element_failure_reason := clc$sp_fail_match;
          IFEND;
        ELSE
*IF NOT $true(osv$unix)
          IF i#compare_collated (subject (subject_index, STRLENGTH (string_literal^)), string_literal^,
                osv$lower_to_upper) = 0 THEN
            element_match_result := clc$sp_success;
            subject_index := subject_index + STRLENGTH (string_literal^);
          ELSE
*IFEND
            element_match_result := clc$sp_failure;
            element_failure_reason := clc$sp_fail_match;
*IF NOT $true(osv$unix)
          IFEND;
*IFEND
        IFEND;

      PROCEND process_string_literal;
?? TITLE := 'process_succeed_forced', EJECT ??

{
{ PURPOSE:
{   This is the processor for a CLC$SP_SUCCEED_FORCED element.
{
{ NOTE:
{   This processor never gives up.  If it is backed into with failure, it
{   tries again.
{

      PROCEDURE process_succeed_forced;

        VAR
          successor_pattern_element: ^clt$string_pattern_element;


        IF pattern_element^.successor = NIL THEN
          element_match_result := clc$sp_success;
          RETURN;
        IFEND;

        successor_pattern_element := #PTR (pattern_element^.successor, pattern^);

        REPEAT

{ Call the main scan procedure to deal with this element's successors in order
{ to gain control when the scanning process backs up.

          pattern_element := successor_pattern_element;
          scan_string_pattern (pattern, subject_index, pattern_element, scan_failure_reason, scan_match_info);
        UNTIL scan_match_info.result = clc$sp_success;

        element_match_result := clc$sp_success;

      PROCEND process_succeed_forced;
?? TITLE := 'process_succeed_passive', EJECT ??

{
{ PURPOSE:
{   This is the processor for a CLC$SP_SUCCEED_PASSIVE element.
{

      PROCEDURE [INLINE] process_succeed_passive;


        element_match_result := clc$sp_success;

      PROCEND process_succeed_passive;
?? TITLE := 'process_test', EJECT ??

{
{ PURPOSE:
{   This is the processor for a CLC$SP_TEST element.
{

      PROCEDURE process_test;

{ TYPE
{   test = boolean

        VAR
          boolean_type_spec: [STATIC, READ, cls$declaration_section] record
            header: clt$type_specification_header,
          recend := [[1, 0, clc$boolean_type]];

{ TYPEND

        VAR
          expression_result: ^clt$data_value,
*IF $true(osv$unix)
          handler_established: boolean,
*IFEND
          original_work_area: ^clt$work_area,
          test_expression: ^clt$expression_text,
          work_area: ^^clt$work_area;

?? NEWTITLE := 'abort_handler', EJECT ??

{
{ PURPOSE:
{   This block exit condition handler is established to ensure that the work
{   area pointer is reset to its original value.
{

        PROCEDURE abort_handler
*IF $true(osv$unix)
          (    signal_no: integer;
               code: integer;
               p_sigcontext: ^cyt$mips_sigcontext);
*ELSE
          (    condition: pmt$condition;
               ignore_info: ^pmt$condition_information;
               save_area: ^ost$stack_frame_save_area;
           VAR handler_status: ost$status);
*IFEND

          work_area^ := original_work_area;

        PROCEND abort_handler;
?? OLDTITLE, EJECT ??

{ Get a work area to use for evaluating the test expression.

*IF NOT $true(osv$unix)
        clp$get_work_area (#RING (^work_area), work_area, status);
*ELSE
        clp$get_work_area (#OFFSET (^work_area), work_area, status);
*IFEND
        IF NOT status.normal THEN
          EXIT clp$match_string_pattern;
        IFEND;
        original_work_area := work_area^;

        #SPOIL (original_work_area);
*IF $true(osv$unix)
        handler_established := #establish_condition_handler (-1, ^abort_handler);
*ELSE
        osp$establish_block_exit_hndlr (^abort_handler);
*IFEND

{ Evaluate the test expression.

        test_expression := #PTR (pattern_element^.test_expression, pattern^);
        clp$evaluate_expression (test_expression^, #SEQ (boolean_type_spec), work_area^, expression_result,
              status);
        IF status.normal AND expression_result^.boolean_value.value THEN
          element_match_result := clc$sp_success;
        ELSE
          status.normal := TRUE;
          element_match_result := clc$sp_failure;
          element_failure_reason := clc$sp_fail_match;
        IFEND;

{ release the work area

        work_area^ := original_work_area;
*IF $true(osv$unix)
        IF handler_established THEN
          handler_established := NOT #disestablish_condition_handler (-1);
        IFEND;
*ELSE
        osp$disestablish_cond_handler;
*IFEND

      PROCEND process_test;
?? TITLE := 'process_unevaluated_pattern', EJECT ??

{
{ PURPOSE:
{   This is the processor for a CLC$SP_UNEVALUATED_PATTERN element.
{

      PROCEDURE process_unevaluated_pattern;

{ TYPE
{   unevaluated_pattern = string_pattern

        VAR
          string_pattern_type_spec: [STATIC, READ, cls$declaration_section] record
            header: clt$type_specification_header,
          recend := [[1, 0, clc$string_pattern_type]];

{ TYPEND

        VAR
          expression_result: ^clt$data_value,
*IF $true(osv$unix)
          handler_established: boolean,
*IFEND
          original_work_area: ^clt$work_area,
          sub_pattern: ^clt$string_pattern,
          sub_pattern_element: ^clt$string_pattern_element,
          sub_pattern_header: ^clt$string_pattern_header,
          successor_stack_entry: clt$successor_stack_entry,
          unevaluated_expression: ^clt$expression_text,
          work_area: ^^clt$work_area;

?? NEWTITLE := 'abort_handler', EJECT ??

{
{ PURPOSE:
{   This block exit condition handler is established to ensure that the work
{   area pointer is reset to its original value.
{

        PROCEDURE abort_handler
*IF $true(osv$unix)
          (    signal_no: integer;
               code: integer;
               p_sigcontext: ^cyt$mips_sigcontext);
*ELSE
          (    condition: pmt$condition;
               ignore_info: ^pmt$condition_information;
               save_area: ^ost$stack_frame_save_area;
           VAR handler_status: ost$status);
*IFEND


          work_area^ := original_work_area;

        PROCEND abort_handler;
?? OLDTITLE, EJECT ??

{ Get a work area to use for evaluating the string pattern.

*IF NOT $true(osv$unix)
        clp$get_work_area (#RING (^work_area), work_area, status);
*ELSE
        clp$get_work_area (#OFFSET (^work_area), work_area, status);
*IFEND
        IF NOT status.normal THEN
          EXIT clp$match_string_pattern;
        IFEND;
        original_work_area := work_area^;

        #SPOIL (original_work_area);
*IF $true(osv$unix)
        handler_established := #establish_condition_handler (-1, ^abort_handler);
*ELSE
        osp$establish_block_exit_hndlr (^abort_handler);
*IFEND

{ Evaluate the string pattern.

        unevaluated_expression := #PTR (pattern_element^.unevaluated_pattern, pattern^);
        clp$evaluate_expression (unevaluated_expression^, #SEQ (string_pattern_type_spec), work_area^,
              expression_result, status);
        IF NOT status.normal THEN
          status.normal := TRUE;
          element_match_result := clc$sp_failure;
          element_failure_reason := clc$sp_fail_match;
          RETURN;
        IFEND;

{ Copy the evaluated string pattern to this procedures stack frame in order to
{ release the work area.

        PUSH sub_pattern: [[REP #SIZE (expression_result^.string_pattern_value^) OF cell]];
        sub_pattern^ := expression_result^.string_pattern_value^;

        work_area^ := original_work_area;
*IF $true(osv$unix)
        IF handler_established THEN
          handler_established := NOT #disestablish_condition_handler (-1);
        IFEND;
*ELSE
        osp$disestablish_cond_handler;
*IFEND


        open_string_pattern (sub_pattern, sub_pattern_header, sub_pattern_element, status);
        IF NOT status.normal THEN
          EXIT clp$match_string_pattern;
        ELSEIF sub_pattern_header^.initial_element = NIL THEN
          element_match_result := clc$sp_success;
          RETURN;
        IFEND;

{ "Push" an entry onto the successor stack.

        successor_stack_entry.link := successor_stack;
        successor_stack_entry.process := TRUE;
        successor_stack_entry.pattern := pattern;
        successor_stack_entry.element := pattern_element^.successor;

{ The following assignment will cause a "pointer lifetime" warning from CYBIL.
{ This is OK!

        successor_stack := ^successor_stack_entry;

{ Call the main scan procedure to deal with the sub-pattern.

        scan_string_pattern (sub_pattern, subject_index, sub_pattern_element, scan_failure_reason,
              scan_match_info);

        element_match_result := scan_match_info.result;
        IF element_match_result = clc$sp_failure THEN
          element_failure_reason := scan_failure_reason;
          IF element_failure_reason = clc$sp_fail_size THEN

{ See the discussion at the beginning of the module for how the failure reason
{ information is used.

            element_failure_reason := clc$sp_fail_unevaluated;
          IFEND;
        IFEND;

{ "Pop" the successor stack entry that was "pushed" above.

        successor_stack := successor_stack_entry.link;

      PROCEND process_unevaluated_pattern;
?? TITLE := 'process_upto_character', EJECT ??

{
{ PURPOSE:
{   This is the processor for a CLC$SP_UPTO_CHARACTER element.
{

      PROCEDURE [INLINE] process_upto_character;

        VAR
          characters: ^clt$string_pattern_characters,
          scan_found_char: boolean,
          scan_index: clt$string_index;


        characters := #PTR (pattern_element^.characters, pattern^);
        #SCAN (characters^, subject (subject_index, * ), scan_index, scan_found_char);
        IF scan_found_char THEN
          element_match_result := clc$sp_success;
          subject_index := subject_index + scan_index - 1;
        ELSE
          element_match_result := clc$sp_failure;
          element_failure_reason := clc$sp_fail_match;
        IFEND;

      PROCEND process_upto_character;
?? TITLE := 'process_upto_count_from_left', EJECT ??

{
{ PURPOSE:
{   This is the processor for a CLC$SP_UPTO_COUNT_FROM_LEFT element.
{

      PROCEDURE [INLINE] process_upto_count_from_left;


        IF (subject_index - 1) > pattern_element^.count THEN
          element_match_result := clc$sp_failure;
          element_failure_reason := clc$sp_fail_size;
        ELSE
          element_match_result := clc$sp_success;
          subject_index := pattern_element^.count + 1;
        IFEND;

      PROCEND process_upto_count_from_left;
?? TITLE := 'process_upto_count_from_right', EJECT ??

{
{ PURPOSE:
{   This is the processor for a CLC$SP_UPTO_COUNT_FROM_RIGHT element.
{

      PROCEDURE [INLINE] process_upto_count_from_right;


        IF remaining_subject_size < pattern_element^.count THEN
          element_match_result := clc$sp_failure;
          element_failure_reason := clc$sp_fail_size;
        ELSE
          element_match_result := clc$sp_success;
          subject_index := STRLENGTH (subject) - pattern_element^.count + 1;
        IFEND;

      PROCEND process_upto_count_from_right;
?? OLDTITLE, EJECT ??

      scan_match_info.result := clc$sp_success;
      original_subject_index := subject_index;

    /scan/
      WHILE TRUE DO
        remaining_subject_size := STRLENGTH (subject) - subject_index + 1;

{ Setup for handling an alternative.

        IF (pattern_element^.alternative <> NIL) AND ((scan_option = clc$sp_full_scan) OR
              (remaining_subject_size >= pattern_element^.alternative_min_subject_size)) THEN
          alternative_pattern_element := #PTR (pattern_element^.alternative, pattern^);
          local_subject_index := subject_index;
        ELSE
          alternative_pattern_element := NIL;
        IFEND;

        IF (scan_option = clc$sp_quick_scan) AND (remaining_subject_size < pattern_element^.min_subject_size)
              THEN
          element_match_result := clc$sp_failure;
          element_failure_reason := clc$sp_fail_size;
        ELSE

{ Match a pattern element.

          CASE pattern_element^.kind OF
          = clc$sp_balanced_pair =
            process_balanced_pair;
          = clc$sp_capture_begin =
            process_capture_begin;
          = clc$sp_capture_end =
            process_capture_end;
          = clc$sp_capture_index =
            process_capture_index;
          = clc$sp_characters =
            process_characters;
          = clc$sp_count =
            process_count;
          = clc$sp_count_test_left =
            process_count_test_left;
          = clc$sp_count_test_right =
            process_count_test_right;
          = clc$sp_fail_element =
            process_fail_element;
          = clc$sp_fail_pattern =
            process_fail_pattern;
          = clc$sp_fence =
            process_fence;
          = clc$sp_multiple =
            process_multiple;
          = clc$sp_multiple_path_elements =
            process_multiple_path_elements;
          = clc$sp_one_character =
            process_one_character;
          = clc$sp_repeat_pattern_begin =
            process_repeat_pattern_begin;
          = clc$sp_repeat_pattern_end =
            process_repeat_pattern_end;
          = clc$sp_string_literal =
            process_string_literal;
          = clc$sp_succeed_forced =
            process_succeed_forced;
          = clc$sp_succeed_passive =
            process_succeed_passive;
          = clc$sp_test =
            process_test;
          = clc$sp_unevaluated_pattern =
            process_unevaluated_pattern;
          = clc$sp_upto_character =
            process_upto_character;
          = clc$sp_upto_count_from_left =
            process_upto_count_from_left;
          = clc$sp_upto_count_from_right =
            process_upto_count_from_right;
          ELSE
            bad_string_pattern;
          CASEND;
        IFEND;

        IF (element_match_result = clc$sp_success) AND (pattern_element^.successor = NIL) AND
              (successor_stack <> NIL) THEN
          process_stacked_successor;
        IFEND;

        IF element_match_result = clc$sp_success THEN
          scan_match_info.result := clc$sp_success;

          IF (pattern_element^.successor = NIL) OR (pattern_element^.kind = clc$sp_unevaluated_pattern) THEN

{ Terminate with success.
{
{ Note that the processor for CLC$SP_UNEVALUATED_PATTERNs has arranged to have
{ all of its successors scanned via the successor stack.

            scan_match_info.index := original_subject_index;
            scan_match_info.size := subject_index - original_subject_index;
            RETURN;
          IFEND;

{ Continue with the successor element.

          pattern_element := #PTR (pattern_element^.successor, pattern^);

          IF alternative_pattern_element = NIL THEN
            CYCLE /scan/;
          IFEND;

{ If this element has an alternative, its successor must be processed via
{ another call so we can back up to deal with the alternative.

          scan_string_pattern (pattern, subject_index, pattern_element, element_failure_reason,
                local_match_info);
          IF local_match_info.result = clc$sp_success THEN

{ Terminate with success.

            scan_match_info.result := clc$sp_success;
            scan_match_info.index := original_subject_index;
            scan_match_info.size := subject_index - original_subject_index;
            RETURN;
          IFEND;

          element_match_result := clc$sp_failure;
        IFEND;

{ Merge this element's failure reason with the overall failure reason.

        IF scan_match_info.result = clc$sp_success THEN
          scan_match_info.result := clc$sp_failure;
          scan_failure_reason := element_failure_reason;
        ELSEIF (scan_failure_reason = clc$sp_fail_match) OR (element_failure_reason = clc$sp_fail_match) THEN
          scan_failure_reason := clc$sp_fail_match;
        ELSEIF element_failure_reason = clc$sp_fail_immediate_capture THEN
          scan_failure_reason := clc$sp_fail_immediate_capture;
        IFEND;

        IF alternative_pattern_element = NIL THEN

{ Terminate with failure.

          subject_index := original_subject_index;
          RETURN;
        IFEND;

{ Continue with the alternative element.

        pattern_element := alternative_pattern_element;
        subject_index := local_subject_index;
      WHILEND /scan/;

    PROCEND scan_string_pattern;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    open_string_pattern (pattern, pattern_header, initial_pattern_element, status);
    IF NOT status.normal THEN
      RETURN;
    ELSEIF initial_pattern_element = NIL THEN
      match_info.result := clc$sp_success;
      match_info.index := 1;
      match_info.size := 0;
      RETURN;
    IFEND;

    capture_stack := NIL;
    repeat_pattern_stack := NIL;
    successor_stack := NIL;

{ For an unanchored scan, examine the initial element to determine whether a
{ look ahead can be done for the first character matched by the initial
{ element.

    look_for_initial_characters := NIL;
    IF (anchor_option = clc$sp_unanchored) AND (initial_pattern_element^.alternative = NIL) THEN
      CASE initial_pattern_element^.kind OF
      = clc$sp_characters =
        IF initial_pattern_element^.count >= 1 THEN
          PUSH look_for_initial_characters;
          initial_characters := #PTR (initial_pattern_element^.characters, pattern^);
          look_for_initial_characters^ := -initial_characters^;
        IFEND;
      = clc$sp_one_character =
        look_for_initial_characters := #PTR (initial_pattern_element^.characters, pattern^);
      = clc$sp_string_literal =
        PUSH look_for_initial_characters;
        initial_string_literal := #PTR (initial_pattern_element^.string_literal, pattern^);
        look_for_initial_characters^ := $clt$string_pattern_characters
              [osv$lower_to_upper ($INTEGER (initial_string_literal^ (1)) + 1),
              osv$upper_to_lower ($INTEGER (initial_string_literal^ (1)) + 1)];
      ELSE
        ;
      CASEND;
    IFEND;

    IF look_for_initial_characters = NIL THEN
      subject_index := 1;
    ELSE

{ If the look ahead can be done, use the #SCAN intrinsic to do it.

      #SCAN (look_for_initial_characters^, subject, scan_index, scan_found_char);
      IF NOT scan_found_char THEN
        match_info.result := clc$sp_failure;
        RETURN;
      IFEND;
      subject_index := scan_index;
    IFEND;

    WHILE TRUE DO
      IF (scan_option = clc$sp_quick_scan) AND ((STRLENGTH (subject) - subject_index + 1) <
            min_subject_size (initial_pattern_element)) THEN
        match_info.result := clc$sp_failure;
        RETURN;
      IFEND;

      pattern_element := initial_pattern_element;
      scan_string_pattern (pattern, subject_index, pattern_element, scan_failure_reason, match_info);

      IF (match_info.result = clc$sp_success) OR (anchor_option = clc$sp_anchored) THEN
        RETURN;
      ELSEIF scan_option = clc$sp_quick_scan THEN
        IF (scan_failure_reason <> clc$sp_fail_match) OR ((STRLENGTH (subject) - subject_index) <
              min_subject_size (initial_pattern_element)) THEN
          RETURN;
        IFEND;
      ELSE {scan_option = clc$sp_full_scan}
        IF subject_index >= STRLENGTH (subject) THEN
          RETURN;
        IFEND;
      IFEND;

{ Skip over more characters then retry the pattern.

      subject_index := subject_index + 1;
      IF look_for_initial_characters <> NIL THEN
        #SCAN (look_for_initial_characters^, subject (subject_index, * ), scan_index, scan_found_char);
        IF NOT scan_found_char THEN
          match_info.result := clc$sp_failure;
          RETURN;
        IFEND;
        subject_index := subject_index + scan_index - 1;
      IFEND;
    WHILEND;

  PROCEND clp$match_string_pattern;
?? TITLE := 'clp$sp_balanced_pair', EJECT ??

{
{   This request builds a string pattern that matches a string balanced
{ with respect to a pair of characters.
{
{       CLP$SP_BALANCED_PAIR (LEFT_CHARACTER, RIGHT_CHARACTER, WORK_AREA,
{         PATTERN, STATUS)
{
{ LEFT_CHARACTER: (input)  This parameter specifies the left character of the
{       pair to be balanced
{
{ RIGHT_CHARACTER: (input)  This parameter specifies the right character of the
{       pair to be balanced
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_balanced_pair
    (    left_character: char;
         right_character: char;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    status.normal := TRUE;

    NEXT pattern: [[REP #SIZE (clt$string_pattern_header) + #SIZE (clt$string_pattern_element) OF cell]] IN
          work_area;
    IF pattern = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    RESET pattern;

    initialize_pattern_header (pattern, pattern_header);

    initialize_pattern_element (pattern, pattern, pattern_header^.number_of_elements,
          pattern_header^.initial_element, pattern_element);

    pattern_element^.kind := clc$sp_balanced_pair;
    pattern_element^.left_character := left_character;
    pattern_element^.right_character := right_character;
    pattern_element^.min_subject_size := 1;

    RESET pattern;

  PROCEND clp$sp_balanced_pair;
?? TITLE := 'clp$sp_capture_index', EJECT ??

{
{   This request creates a string pattern that captures the current substring
{ index when is is encountered during pattern matching.
{
{       CLP$SP_CAPTURE_INDEX (CAPTURE, WORK_AREA, PATTERN, STATUS)
{
{ CAPTURE: (input)  This parameter specified how the capture is to be
{       accomplished.  The IMMEDIATE field is ignored for this request.
{       The KIND field specifies how the capturing is to be done.
{
{       CLC$SP_CAPTURE_VIA_PROCEDURE: specifies that the subject index is
{             passed to the PROCedure as a string.
{
{       CLC$SP_CAPTURE_VIA_VARIABLE: specifies that the subject index is
{             written into the VARIABLE.
{
{       CLC$SP_CAPTURE_VIA_COMMAND: specifies that the subject index is passed
{             to the COMMAND as a string.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_capture_index
    (    capture: clt$string_pattern_capture;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      command: ^clt$command_line,
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header,
      pattern_size: clt$string_pattern_size,
      variable: ^clt$variable_ref_expression;


    status.normal := TRUE;
    pattern_size := #SIZE (clt$string_pattern_header) + #SIZE (clt$string_pattern_element);
    CASE capture.kind OF
    = clc$sp_capture_via_procedure =
      ;
    = clc$sp_capture_via_variable =
      pattern_size := pattern_size + #SIZE (capture.variable^);
    = clc$sp_capture_via_command =
      pattern_size := pattern_size + #SIZE (capture.command^);
    ELSE
      osp$set_status_condition (cle$bad_string_pattern, status);
      RETURN;
    CASEND;
    NEXT pattern: [[REP pattern_size OF cell]] IN work_area;
    IF pattern = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    RESET pattern;

    initialize_pattern_header (pattern, pattern_header);

    initialize_pattern_element (pattern, pattern, pattern_header^.number_of_elements,
          pattern_header^.initial_element, pattern_element);

    pattern_element^.kind := clc$sp_capture_index;
    pattern_element^.immediate_capture := TRUE;
    pattern_element^.capture_kind := capture.kind;
    CASE capture.kind OF
    = clc$sp_capture_via_procedure =
      pattern_element^.capture_procedure := capture.proc;
    = clc$sp_capture_via_variable =
      NEXT variable: [STRLENGTH (capture.variable^)] IN pattern;
      pattern_element^.capture_variable := #REL (variable, pattern^);
      variable^ := capture.variable^;
      pattern_element^.extra_info_size := #SIZE (variable^);
    = clc$sp_capture_via_command =
      NEXT command: [STRLENGTH (capture.command^)] IN pattern;
      pattern_element^.capture_command := #REL (command, pattern^);
      command^ := capture.command^;
      pattern_element^.extra_info_size := #SIZE (command^);
    ELSE
      ;
    CASEND;

    RESET pattern;

  PROCEND clp$sp_capture_index;
?? TITLE := 'clp$sp_capture_substring', EJECT ??

{
{   This request creates a string pattern that captures the substring matched
{ by the specified pattern.
{
{       CLP$SP_CAPTURE_SUBSTRING (PATTERN, CAPTURE, WORK_AREA,
{         RESULT_PATTERN, STATUS)
{
{ PATTERN: (input)  This parameter specifies the pattern whose matched
{       substring is to be captured.
{
{ CAPTURE: (input)  This parameter specified how the capture is to be
{       accomplished.  The IMMEDIATE field specifies whether the capture should
{       occur immediately when the PATTERN is matched, or not until the entire
{       RESULT_PATTERN has been matched.  The KIND field specifies how the
{       capturing is to be done.
{
{       CLC$SP_CAPTURE_VIA_PROCEDURE: specifies that the matched substring is
{             passed to the PROCedure.
{
{       CLC$SP_CAPTURE_VIA_VARIABLE: specifies that the matched substring is
{             written into the VARIABLE.
{
{       CLC$SP_CAPTURE_VIA_COMMAND: specifies that the matched substring is
{             passed to the COMMAND.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ RESULT_PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_capture_substring
    (    pattern: ^clt$string_pattern;
         capture: clt$string_pattern_capture;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result_pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      begin_element: ^clt$string_pattern_element,
      begin_element_link: clt$string_pattern_element_link,
      command: ^clt$command_line,
      copied_pattern: ^clt$string_pattern,
      end_element: ^clt$string_pattern_element,
      end_element_link: clt$string_pattern_element_link,
      first_result_element: ^clt$string_pattern_element,
      initial_copied_element: ^clt$string_pattern_element,
      ignore_initial_element: ^clt$string_pattern_element,
      ignore_pattern_header: ^clt$string_pattern_header,
      result_pattern_header: ^clt$string_pattern_header,
      result_pattern_size: clt$string_pattern_size,
      variable: ^clt$variable_ref_expression;


    status.normal := TRUE;

    open_string_pattern (pattern, ignore_pattern_header, ignore_initial_element, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    result_pattern_size := #SIZE (pattern^) + (2 * #SIZE (clt$string_pattern_element));
    CASE capture.kind OF
    = clc$sp_capture_via_procedure =
      ;
    = clc$sp_capture_via_variable =
      result_pattern_size := result_pattern_size + #SIZE (capture.variable^);
    = clc$sp_capture_via_command =
      result_pattern_size := result_pattern_size + #SIZE (capture.command^);
    ELSE
      osp$set_status_condition (cle$bad_string_pattern, status);
      RETURN;
    CASEND;
    NEXT result_pattern: [[REP result_pattern_size OF cell]] IN work_area;
    IF result_pattern = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    RESET result_pattern;

    NEXT copied_pattern: [[REP #SIZE (pattern^) OF cell]] IN result_pattern;
    copied_pattern^ := pattern^;
    RESET copied_pattern;
    NEXT result_pattern_header IN copied_pattern;

    initialize_pattern_element (result_pattern, result_pattern, result_pattern_header^.number_of_elements,
          end_element_link, end_element);

    end_element^.kind := clc$sp_capture_end;
    end_element^.immediate_capture := capture.immediate;
    end_element^.capture_kind := capture.kind;
    CASE capture.kind OF
    = clc$sp_capture_via_procedure =
      end_element^.capture_procedure := capture.proc;
    = clc$sp_capture_via_variable =
      NEXT variable: [STRLENGTH (capture.variable^)] IN result_pattern;
      end_element^.capture_variable := #REL (variable, result_pattern^);
      variable^ := capture.variable^;
      end_element^.extra_info_size := #SIZE (variable^);
    = clc$sp_capture_via_command =
      NEXT command: [STRLENGTH (capture.command^)] IN result_pattern;
      end_element^.capture_command := #REL (command, result_pattern^);
      command^ := capture.command^;
      end_element^.extra_info_size := #SIZE (command^);
    ELSE
      ;
    CASEND;

    IF result_pattern_header^.number_of_elements = 1 THEN
      result_pattern_header^.initial_element := end_element_link;
    ELSE
      NEXT first_result_element IN copied_pattern;
      link_successor_to_pattern (result_pattern, first_result_element,
            result_pattern_header^.number_of_elements - 1, end_element_link, 0);
    IFEND;

    initialize_pattern_element (result_pattern, result_pattern, result_pattern_header^.number_of_elements,
          begin_element_link, begin_element);

    begin_element^.kind := clc$sp_capture_begin;
    begin_element^.capture_end_element := end_element_link;

    begin_element^.successor := result_pattern_header^.initial_element;
    initial_copied_element := #PTR (result_pattern_header^.initial_element, result_pattern^);
    begin_element^.min_subject_size := min_subject_size (initial_copied_element);
    begin_element^.alternative_min_subject_size := begin_element^.min_subject_size;

    result_pattern_header^.initial_element := begin_element_link;

    RESET result_pattern;

  PROCEND clp$sp_capture_substring;
?? TITLE := 'clp$sp_characters', EJECT ??

{
{   This request builds a string pattern that matches a mimimum number of
{ of a particular set of characters.
{
{       CLP$SP_CHARACTERS (CHAR_SET, MINIMUM_COUNT, WORK_AREA, PATTERN, STATUS)
{
{ CHAR_SET: (input)  This parameter specifies the set of characters.
{
{ MINIMUM_COUNT: (input)  This parameter specifies the minimum number of
{       characters that must be found.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_characters
    (    char_set: clt$string_pattern_characters;
         minimum_count: clt$string_size;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    initialize_char_set_pattern (clc$sp_characters, -char_set, minimum_count, work_area, pattern, status);

  PROCEND clp$sp_characters;
?? TITLE := 'clp$sp_convert_to_string', EJECT ??
*copyc clh$sp_convert_to_string

{
{ DESIGN:
{   The string representation is produced in a two phase process.  The first phase
{   identifies the beinning and ending of sub_pattern.  The second phase produces the
{   string representation of the pattern, with appropriate notation for sub_patterns.
{
{   PHASE 1
{
{   For each element a count of the number of other pattern elements that point to
{   it as a successor, the PREDECESSOR_COUNT, is determined.  An element that has
{   more than one predecessor is the first element following a sub_pattern.
{
{   An element which is this first of a series of alternatives represents the start
{   of one or more sub_patterns.  The SUB_PATTERN_START_COUNT for such an element is
{   equal to the number of unique ways in which the alternatives "terminate".  This
{   count is determined by following the successors of each alternative until there
{   are no more successors or until an element with more than one predecessor is found.
{   A pointer this element in the latter case, or NIL in the former, is propogated
{   back to where the alternatives are being dealt with.  The number of unique such
{   pointers represents the number of unique ways in which the alternatives terminate,
{   and therefore the number of sub_patterns that start at the element in question.
{
{   SInce the string representation of the pattern does not include it, the
{   ALTERNATIVE_MIN_SUBJECT_SIZE field is used to store an index into an array
{   containing these counts for each element in of a copy of the pattern.
{
{   The first group of nested procedures and functions are used to isolate this
{   secondary use of this field.
{
{   PHASE 2
{
{   During the output phase the information determined during the first phase is used
{   to put out the appropriate "parenthesization" of the sub_patterns.  There is a
{   separate output procedure for each kind of pattern element.  The pattern elements
{   that operate in pairs have special processing to deal with their pattern structures.
{

  PROCEDURE [XDCL] clp$sp_convert_to_string
    (    source_pattern: ^clt$string_pattern;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result_string: ^clt$string_value;
     VAR status: ost$status);

    VAR
*IF $true(osv$unix)
      handler_established: boolean,
*IFEND
      ignore_sub_pattern_successor: ^clt$string_pattern_element,
      initial_element: ^clt$string_pattern_element,
      original_work_area: ^clt$work_area,
      pattern: ^clt$string_pattern,
      pattern_end_count: clt$string_size,
      pattern_header: ^clt$string_pattern_header,
      representation_counts: ^array [1 .. * ] of record
        predecessor: clt$string_size,
        sub_pattern_start: clt$string_size,
        sub_pattern_end: clt$string_size,
        reached: clt$string_size,
      recend;

?? NEWTITLE := 'Count Manipulation Procedures and Functions' ??
?? NEWTITLE := 'decrement_sub_pattern_end_count', EJECT ??

{
{ PURPOSE:
{   This procedure decrements the SUB_PATTERN_END_COUNT of an element by 1.
{

    PROCEDURE [INLINE] decrement_sub_pattern_end_count
      (    pattern_element: ^clt$string_pattern_element);


      representation_counts^ [pattern_element^.alternative_min_subject_size].sub_pattern_end :=
            representation_counts^ [pattern_element^.alternative_min_subject_size].sub_pattern_end - 1;

    PROCEND decrement_sub_pattern_end_count;
?? TITLE := 'increment_predecessor_count', EJECT ??

{
{ PURPOSE:
{   This procedure increments the PREDECESSOR_COUNT of an element by 1.
{

    PROCEDURE [INLINE] increment_predecessor_count
      (    pattern_element: ^clt$string_pattern_element);


      representation_counts^ [pattern_element^.alternative_min_subject_size].predecessor :=
            representation_counts^ [pattern_element^.alternative_min_subject_size].predecessor + 1;

    PROCEND increment_predecessor_count;
?? TITLE := 'increment_reached_count', EJECT ??

{
{ PURPOSE:
{   This procedure increments the RECAHED_COUNT of an element by 1.
{

    PROCEDURE [INLINE] increment_reached_count
      (    pattern_element: ^clt$string_pattern_element);


      representation_counts^ [pattern_element^.alternative_min_subject_size].reached :=
            representation_counts^ [pattern_element^.alternative_min_subject_size].reached + 1;

    PROCEND increment_reached_count;
?? TITLE := 'increment_sub_pattern_end_count', EJECT ??

{
{ PURPOSE:
{   This procedure increments the SUB_PATTERN_END_COUNT of an element by 1.
{

    PROCEDURE [INLINE] increment_sub_pattern_end_count
      (    pattern_element: ^clt$string_pattern_element);


      representation_counts^ [pattern_element^.alternative_min_subject_size].sub_pattern_end :=
            representation_counts^ [pattern_element^.alternative_min_subject_size].sub_pattern_end + 1;

    PROCEND increment_sub_pattern_end_count;
?? TITLE := 'initialize_element_counts', EJECT ??

{
{ PURPOSE:
{   This procedure initializes the representation count information for an element.
{

    PROCEDURE [INLINE] initialize_element_counts
      (    pattern_element: ^clt$string_pattern_element;
           index: clt$string_size);


      pattern_element^.alternative_min_subject_size := index;
      representation_counts^ [index].predecessor := 0;
      representation_counts^ [index].sub_pattern_start := 0;
      representation_counts^ [index].sub_pattern_end := 0;
      representation_counts^ [index].reached := 0;

    PROCEND initialize_element_counts;
?? TITLE := 'predecessor_count', EJECT ??

{
{ PURPOSE:
{   This function returns the PREDECESSOR_COUNT of an element.
{

    FUNCTION [INLINE] predecessor_count
      (    pattern_element: ^clt$string_pattern_element): clt$string_size;


      predecessor_count := representation_counts^ [pattern_element^.alternative_min_subject_size].predecessor;

    FUNCEND predecessor_count;
?? TITLE := 'reached_count', EJECT ??

{
{ PURPOSE:
{   This function returns the REACHED_COUNT of an element.
{

    FUNCTION [INLINE] reached_count
      (    pattern_element: ^clt$string_pattern_element): clt$string_size;


      reached_count := representation_counts^ [pattern_element^.alternative_min_subject_size].reached;

    FUNCEND reached_count;
?? TITLE := 'set_sub_pattern_start_count', EJECT ??

{
{ PURPOSE:
{   This procedure sets the SUB_PATTERN_START_COUNT of an element.
{

    PROCEDURE [INLINE] set_sub_pattern_start_count
      (    pattern_element: ^clt$string_pattern_element;
           count: clt$string_size);


      representation_counts^ [pattern_element^.alternative_min_subject_size].sub_pattern_start := count;

    PROCEND set_sub_pattern_start_count;
?? TITLE := 'sub_pattern_end_count', EJECT ??

{
{ PURPOSE:
{   This function returns the SUB_PATTERN_END_COUNT of an element.
{

    FUNCTION [INLINE] sub_pattern_end_count
      (    pattern_element: ^clt$string_pattern_element): clt$string_size;


      sub_pattern_end_count := representation_counts^ [pattern_element^.alternative_min_subject_size].
            sub_pattern_end;

    FUNCEND sub_pattern_end_count;
?? TITLE := 'sub_pattern_start_count', EJECT ??

{
{ PURPOSE:
{   This function returns the SUB_PATTERN_START_COUNT of an element.
{

    FUNCTION [INLINE] sub_pattern_start_count
      (    pattern_element: ^clt$string_pattern_element): clt$string_size;


      sub_pattern_start_count := representation_counts^ [pattern_element^.alternative_min_subject_size].
            sub_pattern_start;

    FUNCEND sub_pattern_start_count;
?? OLDTITLE ??
?? TITLE := 'abort_handler', EJECT ??

{
{ PURPOSE:
{   This block exit condition handler is established to ensure that the work
{   area pointer is reset to its original value.
{

    PROCEDURE abort_handler
*IF $true(osv$unix)
      (    signal_no: integer;
           code: integer;
           p_sigcontext: ^cyt$mips_sigcontext);
*ELSE
      (    condition: pmt$condition;
           ignore_info: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);
*IFEND


      RESET work_area TO result_string;

    PROCEND abort_handler;
?? TITLE := 'bad_string_pattern', EJECT ??

{
{ PURPOSE:
{   This procedure is called when an inconsistency in the structure of a string
{   pattern is detected.  It causes an abnormal status exit from the entire
{   conversion process.
{

    PROCEDURE [INLINE] bad_string_pattern;


      osp$set_status_condition (cle$bad_string_pattern, status);
      EXIT clp$sp_convert_to_string;

    PROCEND bad_string_pattern;
?? TITLE := 'identify_sub_patterns', EJECT ??

{
{ PURPOSE:
{   This procedure identifies sub-patterns within the pattern by establishing the
{   values for each element's PREDECESSOR_COUNT, SUB_PATTERN_START_COUNT and
{   SUB_PATTERN_END_COUNT, as described above.
{

    PROCEDURE identify_sub_patterns
      (    pattern_element: ^clt$string_pattern_element);

      VAR
        alternative_count: clt$string_size,
        alternatives: ^array [1 .. * ] of record
          first: ^clt$string_pattern_element,
          terminal: ^clt$string_pattern_element,
          sub_patterns: clt$string_size,
        recend,
        current_element: ^clt$string_pattern_element,
        i: clt$string_size,
        sub_pattern_index: clt$string_size,
        terminal_element: ^clt$string_pattern_element,
        unique_terminal_count: clt$string_size;


      increment_predecessor_count (pattern_element);

      IF predecessor_count (pattern_element) > 1 THEN

{ An element should only go through the identification process once.

        RETURN;
      IFEND;

      current_element := pattern_element;

{ Identify sub-patterns in this element's successors.

    /process_successors/
      WHILE current_element^.successor <> NIL DO
        current_element := #PTR (current_element^.successor, pattern^);

        IF current_element^.alternative <> NIL THEN

{ Recurse in order to be able to handle the successor's alternatives.

          identify_sub_patterns (current_element);
          EXIT /process_successors/;
        IFEND;

        increment_predecessor_count (current_element);
      WHILEND /process_successors/;

      IF pattern_element^.kind = clc$sp_repeat_pattern_end THEN

{ The ALTERNATIVE of a CLC$SP_REPEAT_PATTERN_END element is the first element
{ of the pattern to be repeated.  Because of this special use of the
{ ALTERNATIVE link, the CLC$SP_REPEAT_PATTERN_END element can never be
{ the start of a sub-pattern.  Therefore, the repeated sub-pattern must be
{ handled in a separate call.

        current_element := #PTR (pattern_element^.alternative, pattern^);
        identify_sub_patterns (current_element);
        RETURN;
      IFEND;

{ Count this element's alternatives and identify the sub-patterns in them.

      current_element := pattern_element;
      alternative_count := 1;
      WHILE current_element^.alternative <> NIL DO
        alternative_count := alternative_count + 1;

        current_element := #PTR (current_element^.alternative, pattern^);
        increment_predecessor_count (current_element);

        IF current_element^.successor <> NIL THEN
          identify_sub_patterns (#PTR (current_element^.successor, pattern^));
        IFEND;
      WHILEND;

      IF alternative_count = 1 THEN

{ Nothing more to do if no alternatives.

        RETURN;
      IFEND;

{ Create an array in which to keep track of sub-patterns for the alternatives.

      PUSH alternatives: [1 .. alternative_count];
      unique_terminal_count := 0;
      alternative_count := 0;

{ Find the "terminal" elements of the alternatives.

      current_element := pattern_element;
      REPEAT
        terminal_element := #PTR (current_element^.successor, pattern^);
        WHILE (terminal_element <> NIL) AND (predecessor_count (terminal_element) = 1) DO
          terminal_element := #PTR (terminal_element^.successor, pattern^);
        WHILEND;
        alternative_count := alternative_count + 1;
        alternatives^ [alternative_count].first := current_element;
        alternatives^ [alternative_count].terminal := terminal_element;
        alternatives^ [alternative_count].sub_patterns := 0;
        current_element := #PTR (current_element^.alternative, pattern^);
      UNTIL current_element = NIL;

{ This element, of course, starts a sub-pattern.  Also, any element which is
{ the first a series of consecutive alternatives with the same terminal element
{ starts a sub-pattern.

      sub_pattern_index := 1;
      REPEAT
        i := sub_pattern_index + 1;
        WHILE (i <= alternative_count) AND (alternatives^ [i].terminal = alternatives^ [i - 1].terminal) DO
          i := i + 1;
        WHILEND;
        IF (i - sub_pattern_index) > 1 THEN
          alternatives^ [sub_pattern_index].sub_patterns := alternatives^ [sub_pattern_index].sub_patterns +
                1;
        IFEND;
        IF (sub_pattern_index = 1) AND (i <= alternative_count) THEN
          alternatives^ [1].sub_patterns := alternatives^ [1].sub_patterns + 1;
        IFEND;
        sub_pattern_index := i;
      UNTIL sub_pattern_index >= alternative_count;

{ Save the sub-pattern start counts.

      FOR i := 1 TO alternative_count DO
        set_sub_pattern_start_count (alternatives^ [i].first, alternatives^ [i].sub_patterns);
      FOREND;

{ Increment the sub-pattern end counts.

    /increment_end_counts/
      FOR sub_pattern_index := 1 TO alternative_count DO

        FOR i := 1 TO sub_pattern_index - 1 DO
          IF alternatives^ [i].terminal = alternatives^ [sub_pattern_index].terminal THEN
            CYCLE /increment_end_counts/;
          IFEND;
        FOREND;

        IF alternatives^ [sub_pattern_index].terminal = NIL THEN
          pattern_end_count := pattern_end_count + 1;
        ELSE
          increment_sub_pattern_end_count (alternatives^ [sub_pattern_index].terminal);
        IFEND;
      FOREND /increment_end_counts/;

    PROCEND identify_sub_patterns;
?? TITLE := 'initialize_counts', EJECT ??

{
{ PURPOSE:
{   This procedure initializes all of the counters needed to produce the string
{   representation of the pattern.
{
{ DESIGN:
{   The pattern elements are sequentially accessed through the pattern, the links
{   are not used.
{

    PROCEDURE [INLINE] initialize_counts;

      VAR
        i: clt$string_size,
        pattern_element: ^clt$string_pattern_element,
        skip_extra_info: ^array [1 .. * ] of cell;


      pattern_end_count := 0;

      RESET pattern;
      NEXT pattern_header IN pattern;

      FOR i := 1 TO pattern_header^.number_of_elements DO
        NEXT pattern_element IN pattern;
        initialize_element_counts (pattern_element, i);

        IF pattern_element^.extra_info_size > 0 THEN

{ Skip over any additional information for the pattern element.

          NEXT skip_extra_info: [1 .. pattern_element^.extra_info_size] IN pattern;
        IFEND;
      FOREND;

    PROCEND initialize_counts;
?? TITLE := 'put_string', EJECT ??

{
{ PURPOSE:
{   This procedure appends a string to the result.
{

    PROCEDURE [INLINE] put_string
      (    s: clt$string_value);

      VAR
        copied_s: ^clt$string_value;


{ Append the string to the result.

      NEXT copied_s: [STRLENGTH (s)] IN work_area;
      IF copied_s = NIL THEN
        osp$set_status_condition (cle$work_area_overflow, status);
        EXIT clp$sp_convert_to_string;
      IFEND;

      copied_s^ := s;

{ Update the RESULT_STRING pointer.

      RESET original_work_area TO result_string;
      NEXT result_string: [STRLENGTH (result_string^) + STRLENGTH (s)] IN original_work_area;

    PROCEND put_string;
?? TITLE := 'put_sub_pattern', EJECT ??

{
{ PURPOSE:
{   This procedure puts out the representation of a pattern element.  It is also
{   responsible for putting out the parentheses, etc. which are needed to represent
{   sub-patterns containing alternatives; and the operators that join successive
{   pattern elements.
{
{ DESIGN:
{   Successor elements are handled via recursive calls to this procedure.
{   Alternative elements are handled directly.
{   This allows for the proper detection of sub-patterns.
{

    PROCEDURE put_sub_pattern
      (    concatenate_pending: boolean;
           sub_pattern_element: ^clt$string_pattern_element;
       VAR sub_pattern_successor: ^clt$string_pattern_element);

      VAR
        i: clt$string_size,
        pattern_element: ^clt$string_pattern_element,
        successor_element: ^clt$string_pattern_element,
        unterminated_count: clt$string_size;

?? NEWTITLE := 'put_balanced_pair', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_BALANCED_PAIR element.
{

      PROCEDURE put_balanced_pair;


        put_string ('$sp_balance(');
        put_quoted_char (pattern_element^.left_character);
        put_string (',');
        put_quoted_char (pattern_element^.right_character);
        put_string (')');

      PROCEND put_balanced_pair;
?? TITLE := 'put_capture_begin', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_CAPTURE_BEGIN element.
{

      PROCEDURE put_capture_begin;


        put_string ('$sp_capture(');

      PROCEND put_capture_begin;
?? TITLE := 'put_capture_end', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_CAPTURE_END element.
{

      PROCEDURE put_capture_end;

        VAR
          capture_command: ^clt$command_line,
          capture_variable: ^clt$variable_ref_expression;


        IF pattern_element^.immediate_capture THEN
          put_string (',unconditional,');
        ELSE
          put_string (',conditional,');
        IFEND;

        CASE pattern_element^.capture_kind OF

        = clc$sp_capture_via_variable =
          capture_variable := #PTR (pattern_element^.capture_variable, pattern^);
          put_quoted_string (capture_variable^);
          put_string (',variable)');

        = clc$sp_capture_via_command =
          capture_command := #PTR (pattern_element^.capture_command, pattern^);
          put_quoted_string (capture_command^);
          put_string (',command)');

        = clc$sp_capture_via_procedure =
          put_string (',"CAPTURE VIA INTERNAL PROCEDURE")');

        ELSE
          bad_string_pattern;
        CASEND;

      PROCEND put_capture_end;
?? TITLE := 'put_capture_index', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_CAPTURE_INDEX element.
{

      PROCEDURE put_capture_index;

        VAR
          capture_command: ^clt$command_line,
          capture_variable: ^clt$variable_ref_expression;


        put_string ('$sp_index(');

        CASE pattern_element^.capture_kind OF

        = clc$sp_capture_via_variable =
          capture_variable := #PTR (pattern_element^.capture_variable, pattern^);
          put_quoted_string (capture_variable^);
          put_string (',variable)');

        = clc$sp_capture_via_command =
          capture_command := #PTR (pattern_element^.capture_command, pattern^);
          put_quoted_string (capture_command^);
          put_string (',command)');

        = clc$sp_capture_via_procedure =
          put_string (',"CAPTURE VIA INTERNAL PROCEDURE")');

        ELSE
          bad_string_pattern;
        CASEND;

      PROCEND put_capture_index;
?? TITLE := 'put_character_set', EJECT ??

{
{ PURPOSE:
{   This procedure the representation of a set of characters.
{
{ DESIGN:
{   A range of characters is produced if more than MIN_CHARS_FOR_RANGE consecutive
{   characters appear in the set; otherwise a string is produced.
{

      PROCEDURE put_character_set
        (    characters: clt$string_pattern_characters);

        CONST
          max_char_ordinal = 255,
          min_chars_for_range = 7;

        VAR
          c: char,
          put_separator: boolean,
          range_count: 0 .. max_char_ordinal,
          short_range: string (min_chars_for_range - 1);


        put_separator := FALSE;
        range_count := 0;
        FOR c := LOWERVALUE (char) TO UPPERVALUE (char) DO

          IF c IN characters THEN
            range_count := range_count + 1;
            IF range_count < min_chars_for_range THEN
              short_range (range_count) := c;
            IFEND;

          ELSEIF range_count > 0 THEN
            IF put_separator THEN
              put_string (',');
            IFEND;

            IF range_count < min_chars_for_range THEN
              put_quoted_string (short_range (1, range_count));
            ELSE
              put_quoted_string (short_range (1));
              put_string ('..');
              put_quoted_char (PRED (c));
            IFEND;

            range_count := 0;
            put_separator := TRUE;
          IFEND;
        FOREND;

        IF range_count > 0 THEN
          IF put_separator THEN
            put_string (',');
          IFEND;

          IF range_count < min_chars_for_range THEN
            put_quoted_string (short_range (1, range_count));
          ELSE
            put_quoted_string (short_range (1));
            put_string ('..');
            put_quoted_char (UPPERVALUE (char));
          IFEND;
        IFEND;

      PROCEND put_character_set;
?? TITLE := 'put_characters', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_CHARACTERS element.
{

      PROCEDURE put_characters;

        VAR
          characters: ^clt$string_pattern_characters;


        put_string ('$sp_repeat((any, ');
        characters := #PTR (pattern_element^.characters, pattern^);
        put_character_set (-characters^);
        put_string (')');
        IF pattern_element^.count > 0 THEN
          put_string (',');
          put_integer (pattern_element^.count);
        IFEND;
        put_string (')');

      PROCEND put_characters;
?? TITLE := 'put_count', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_COUNT element.
{

      PROCEDURE put_count;

        VAR
          excluded_characters: ^clt$string_pattern_characters;


        put_string ('$sp_count(');
        put_integer (pattern_element^.count);
        IF pattern_element^.characters <> NIL THEN
          excluded_characters := #PTR (pattern_element^.characters, pattern^);
          put_string (',');
          put_character_set (excluded_characters^);
        IFEND;
        put_string (')');

      PROCEND put_count;
?? TITLE := 'put_count_test_left', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_COUNT_TEST_LEFT element.
{

      PROCEDURE put_count_test_left;


        put_string ('$sp_left');
        IF pattern_element^.count > 0 THEN
          put_string ('(');
          put_integer (pattern_element^.count);
          put_string (')');
        IFEND;

      PROCEND put_count_test_left;
?? TITLE := 'put_count_test_right', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_COUNT_TEST_RIGHT element.
{

      PROCEDURE put_count_test_right;


        put_string ('$sp_right');
        IF pattern_element^.count > 0 THEN
          put_string ('(');
          put_integer (pattern_element^.count);
          put_string (')');
        IFEND;

      PROCEND put_count_test_right;
?? TITLE := 'put_fail_element', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_FAIL_ELEMENT element.
{

      PROCEDURE put_fail_element;


        put_string ('$sp_fail');

      PROCEND put_fail_element;
?? TITLE := 'put_fail_pattern', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_FAIL_PATTERN element.
{

      PROCEDURE put_fail_pattern;


        put_string ('$sp_stop');

      PROCEND put_fail_pattern;
?? TITLE := 'put_fence', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_FENCE element.
{

      PROCEDURE put_fence;


        put_string ('$sp_fence');

      PROCEND put_fence;
?? TITLE := 'put_integer', EJECT ??

{
{ PURPOSE:
{   This procedure puts out an integer.
{

      PROCEDURE put_integer
        (    i: integer);

        VAR
          str: ost$string;


        clp$convert_integer_to_string (i, 10, FALSE, str, status);
        IF NOT status.normal THEN
          EXIT clp$sp_convert_to_string;
        IFEND;
        put_string (str.value (1, str.size));

      PROCEND put_integer;
?? TITLE := 'put_multiple', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_MULTIPLE element.
{

      PROCEDURE put_multiple;

        VAR
          excluded_characters: ^clt$string_pattern_characters;


        IF pattern_element^.characters = NIL THEN
          put_string ('$sp_repeat(any');
        ELSE
          put_string ('$sp_repeat((not_any,');
          excluded_characters := #PTR (pattern_element^.characters, pattern^);
          put_character_set (excluded_characters^);
          put_string (')');
        IFEND;
        IF pattern_element^.count > 0 THEN
          put_string (',');
          put_integer (pattern_element^.count);
        IFEND;
        put_string (')');

      PROCEND put_multiple;
?? TITLE := 'put_multiple_path_elements', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_MULTIPLE_PATH_ELEMENTS element.
{

      PROCEDURE put_multiple_path_elements;


        put_string ('.$ALL');
        IF pattern_element^.successor <> NIL THEN
          put_string ('.');
        IFEND;

      PROCEND put_multiple_path_elements;
?? TITLE := 'put_one_character', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_ONE_CHARACTER element.
{

      PROCEDURE put_one_character;

        CONST
          max_characters = 256;

        VAR
          c: char,
          characters: ^clt$string_pattern_characters,
          count: 0 .. max_characters;


        characters := #PTR (pattern_element^.characters, pattern^);
        count := 0;
        FOR c := LOWERVALUE (char) TO UPPERVALUE (char) DO
          count := count + $INTEGER (c IN characters^);
        FOREND;
        IF count <= (max_characters DIV 2) THEN
          put_string ('$sp_any(');
          put_character_set (characters^);
        ELSE
          put_string ('$sp_not_any(');
          put_character_set (-characters^);
        IFEND;
        put_string (')');

      PROCEND put_one_character;
?? TITLE := 'put_quoted_char', EJECT ??

{
{ PURPOSE:
{   This procedure adds quotes to a character before putting it out.
{

      PROCEDURE [INLINE] put_quoted_char
        (    c: char);

        VAR
          s: string (1);


        s (1) := c;
        put_quoted_string (s);

      PROCEND put_quoted_char;
?? TITLE := 'put_quoted_string', EJECT ??

{
{ PURPOSE:
{   This procedure adds quotes to a string before putting it out.
{

      PROCEDURE put_quoted_string
        (    s: clt$string_value);

        VAR
          graphic: ost$string,
          i: clt$string_index,
          in_$char: boolean,
          in_string: boolean;


        IF STRLENGTH (s) = 0 THEN
          put_string ('''''');
          RETURN;
        IFEND;

        #SCAN (clv$non_graphic, s, i, in_$char);
        IF in_$char THEN
          put_string ('$CHAR(');
        IFEND;

        in_string := FALSE;
        FOR i := 1 TO STRLENGTH (s) DO
          CASE s (i) OF

          = ' ' .. '~' =
            IF NOT in_string THEN
              IF (i > 1) AND in_$char THEN
                put_string (' ');
              IFEND;
              put_string ('''');
              in_string := TRUE;
            IFEND;
            IF s (i) = '''' THEN
              put_string ('''');
            IFEND;
            put_string (s (i));

          ELSE
            IF i > 1 THEN
              IF in_string THEN
                put_string ('''');
                in_string := FALSE;
              IFEND;
              put_string (' ');
            IFEND;
            clp$convert_char_to_graphic (s (i), graphic, status);
            IF NOT status.normal THEN
              EXIT clp$sp_convert_to_string;
            IFEND;
            put_string (graphic.value (1, graphic.size));
          CASEND;
        FOREND;

        IF in_string THEN
          put_string ('''');
        IFEND;

        IF in_$char THEN
          put_string (')');
        IFEND;

      PROCEND put_quoted_string;
?? TITLE := 'put_repeat_pattern_begin', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_REPEAT_PATTERN_BEGIN element.
{
{ NOTE:
{   The SUCCESSOR of a CLC$SP_REPEAT_PATTERN_BEGIN element is the corresponding
{   CLC$SP_REPEAT_PATTERN_END element.  The first element of the pattern to be
{   repeated is the ALTERNATIVE of the CLC$SP_REPEAT_PATTERN_END element.  The
{   CLC$SP_REPEAT_PATTERN_END element is also the successor of the repeatable
{   pattern.
{
{   For the present purpose, it is necessary to adjust the SUCCESSOR_ELEMENT
{   varibale so that it points the first element of the pattern to be repeated.
{   Having done this the ALTERNATIVE field of the CLC$SP_REPEAT_PATTERN_END
{   element must be set to NIL.  Also, its REACHED_COUNT must be incremented.
{

      PROCEDURE put_repeat_pattern_begin;

        VAR
          end_element: ^clt$string_pattern_element;


        IF (successor_element = NIL) OR (successor_element^.kind <> clc$sp_repeat_pattern_end) THEN
          bad_string_pattern;
        IFEND;

        end_element := successor_element;
        successor_element := #PTR (end_element^.alternative, pattern^);
        end_element^.alternative := NIL;
        increment_reached_count (end_element);

        put_string ('$sp_repeat(');

      PROCEND put_repeat_pattern_begin;
?? TITLE := 'put_repeat_pattern_end', EJECT ??

{
{ PURPOSE:
{   This procedure processes a CLC$SP_REPEAT_PATTERN_END element.
{

      PROCEDURE put_repeat_pattern_end;


        IF pattern_element^.count > 0 THEN
          put_string (',');
          put_integer (pattern_element^.count);
        IFEND;
        put_string (')');

      PROCEND put_repeat_pattern_end;
?? TITLE := 'put_string_literal', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_STRING_LITERAL element.
{

      PROCEDURE put_string_literal;

        VAR
          string_literal: ^clt$string_value;


        string_literal := #PTR (pattern_element^.string_literal, pattern^);

        IF NOT pattern_element^.case_sensitive THEN
          put_string ('$sp_string(');
        IFEND;

        put_quoted_string (string_literal^);

        IF NOT pattern_element^.case_sensitive THEN
          put_string (',ignore_case)');
        IFEND;

      PROCEND put_string_literal;
?? TITLE := 'put_succeed_forced', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_SUCCEED_FORCED element.
{

      PROCEDURE put_succeed_forced;


        put_string ('$sp_succeed');

      PROCEND put_succeed_forced;
?? TITLE := 'put_succeed_passive', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_SUCCEED_PASSIVE element.
{

      PROCEDURE put_succeed_passive;


        put_string ('$sp_null');

      PROCEND put_succeed_passive;
?? TITLE := 'put_successor', EJECT ??

{
{ PURPOSE:
{   This procedure puts out the successor to the current element.  It also
{   puts out a concatenation operator before the successor, if appropriate.
{

      PROCEDURE [INLINE] put_successor;

        VAR
          put_a_concatenate: boolean;


        put_a_concatenate := (pattern_element^.kind <> clc$sp_capture_begin) AND
              (pattern_element^.kind <> clc$sp_repeat_pattern_begin) AND
              (successor_element^.kind <> clc$sp_capture_end) AND
              (successor_element^.kind <> clc$sp_repeat_pattern_end);

{ Put out the successor.

        put_sub_pattern (put_a_concatenate, successor_element, sub_pattern_successor);

      PROCEND put_successor;
?? TITLE := 'put_test', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_TEST element.
{

      PROCEDURE put_test;

        VAR
          test_expression: ^clt$expression_text;


        put_string ('$sp_test(');
        test_expression := #PTR (pattern_element^.test_expression, pattern^);
        put_string (test_expression^);
        put_string (')');

      PROCEND put_test;
?? TITLE := 'put_unevaluated_pattern', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_UNEVALUATED_PATTERN element.
{

      PROCEDURE put_unevaluated_pattern;

        VAR
          unevaluated_expression: ^clt$expression_text;


        put_string ('$sp_defer(');
        unevaluated_expression := #PTR (pattern_element^.unevaluated_pattern, pattern^);
        put_string (unevaluated_expression^);
        IF pattern_element^.min_subject_size <> 1 THEN
          put_string (',');
          put_integer (pattern_element^.min_subject_size);
        IFEND;
        put_string (')');

      PROCEND put_unevaluated_pattern;
?? TITLE := 'put_upto_character', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_UPTO_CHARACTER element.
{

      PROCEDURE put_upto_character;

        VAR
          characters: ^clt$string_pattern_characters;


        put_string ('$sp_upto((');
        characters := #PTR (pattern_element^.characters, pattern^);
        put_character_set (characters^);
        put_string (')');
        IF pattern_element^.count > 0 THEN
          put_string (',');
          put_integer (pattern_element^.count);
        IFEND;
        put_string (')');

      PROCEND put_upto_character;
?? TITLE := 'put_upto_count_from_left', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_UPTO_COUNT_FROM_LEFT element.
{

      PROCEDURE put_upto_count_from_left;


        put_string ('$sp_upto(left');
        IF pattern_element^.count > 0 THEN
          put_string (',');
          put_integer (pattern_element^.count);
        IFEND;
        put_string (')');

      PROCEND put_upto_count_from_left;
?? TITLE := 'put_upto_count_from_right', EJECT ??

{
{ PURPOSE:
{   This procedure puts out a CLC$SP_UPTO_COUNT_FROM_RIGHT element.
{

      PROCEDURE put_upto_count_from_right;


        put_string ('$sp_upto(right');
        IF pattern_element^.count > 0 THEN
          put_string (',');
          put_integer (pattern_element^.count);
        IFEND;
        put_string (')');

      PROCEND put_upto_count_from_right;
?? OLDTITLE, EJECT ??

      sub_pattern_successor := NIL;

      increment_reached_count (sub_pattern_element);

      IF (predecessor_count (sub_pattern_element) > 1) AND
            (reached_count (sub_pattern_element) <= predecessor_count (sub_pattern_element)) THEN

{ This element must be treated as a sub_pattern successor until it has been "reached"
{ after its precedeeing sub_pattern has been completely put out.

        sub_pattern_successor := sub_pattern_element;
        RETURN;
      IFEND;

{ Terminate any sub-patterns that haven't already been terminated.

      unterminated_count := sub_pattern_end_count (sub_pattern_element);
      WHILE unterminated_count > 0 DO
        put_string (')');
        unterminated_count := unterminated_count - 1;
      WHILEND;

      IF concatenate_pending THEN

{ Put out concatenation operator since this element is a successor.

        put_string ('//');
      IFEND;

{ Put out the approriate number of "sub_pattern starters".

      FOR i := 1 TO sub_pattern_start_count (sub_pattern_element) DO
        put_string ('$sp_or(');
      FOREND;

{ Loop through this element and its alternatives.

      pattern_element := sub_pattern_element;

      REPEAT

{ Initialize the successor element pointer.  Some of the specialized "put" procedures
{ may adjust this pointer.

        successor_element := #PTR (pattern_element^.successor, pattern^);

{ Put current pattern element.

        CASE pattern_element^.kind OF
        = clc$sp_balanced_pair =
          put_balanced_pair;
        = clc$sp_capture_begin =
          put_capture_begin;
        = clc$sp_capture_end =
          put_capture_end;
        = clc$sp_capture_index =
          put_capture_index;
        = clc$sp_characters =
          put_characters;
        = clc$sp_count =
          put_count;
        = clc$sp_count_test_left =
          put_count_test_left;
        = clc$sp_count_test_right =
          put_count_test_right;
        = clc$sp_fail_element =
          put_fail_element;
        = clc$sp_fail_pattern =
          put_fail_pattern;
        = clc$sp_fence =
          put_fence;
        = clc$sp_multiple =
          put_multiple;
        = clc$sp_multiple_path_elements =
          put_multiple_path_elements;
        = clc$sp_one_character =
          put_one_character;
        = clc$sp_repeat_pattern_begin =
          put_repeat_pattern_begin;
        = clc$sp_repeat_pattern_end =
          put_repeat_pattern_end;
        = clc$sp_string_literal =
          put_string_literal;
        = clc$sp_succeed_forced =
          put_succeed_forced;
        = clc$sp_succeed_passive =
          put_succeed_passive;
        = clc$sp_test =
          put_test;
        = clc$sp_unevaluated_pattern =
          put_unevaluated_pattern;
        = clc$sp_upto_character =
          put_upto_character;
        = clc$sp_upto_count_from_left =
          put_upto_count_from_left;
        = clc$sp_upto_count_from_right =
          put_upto_count_from_right;
        ELSE
          bad_string_pattern;
        CASEND;

        IF successor_element = NIL THEN
          sub_pattern_successor := NIL;
        ELSE
          put_successor;
        IFEND;

        IF sub_pattern_start_count (sub_pattern_element) > 0 THEN
          IF (pattern_element^.alternative = NIL) OR ((sub_pattern_successor <> NIL) AND
                (reached_count (sub_pattern_successor) = predecessor_count (sub_pattern_successor))) THEN

{ Terminate the sub_pattern.

            put_string (')');
            IF sub_pattern_successor = NIL THEN
              pattern_end_count := pattern_end_count - 1;
            ELSE
              decrement_sub_pattern_end_count (sub_pattern_successor);

              IF reached_count (sub_pattern_successor) = predecessor_count (sub_pattern_successor) THEN

{ Put the sub-pattern's successor.

                successor_element := sub_pattern_successor;
                put_successor;
              IFEND;
            IFEND;
          IFEND;

          IF pattern_element^.alternative <> NIL THEN

{ Put separator between alternatives.

            put_string (',');
          IFEND;
        IFEND;

        pattern_element := #PTR (pattern_element^.alternative, pattern^);

        IF (pattern_element <> NIL) AND (sub_pattern_start_count (pattern_element) > 0) THEN

{ Remaining alternatives must be dealt with via a recursive call because of the
{ start of a new sub-pattern.

          put_sub_pattern (FALSE, pattern_element, sub_pattern_successor);
          RETURN;
        IFEND;

      UNTIL pattern_element = NIL;

    PROCEND put_sub_pattern;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

{ Make a copy of the pattern so that the necessary modifications can be made to it during
{ the representation process.

    PUSH pattern: [[REP #SIZE (source_pattern^) OF cell]];
    pattern^ := source_pattern^;

    open_string_pattern (pattern, pattern_header, initial_element, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Initialize the RESULT_STRING pointer.

    original_work_area := work_area;
    NEXT result_string: [0] IN work_area;

{ If the pattern is empty treat it as a "null" pattern.

    IF pattern_header^.number_of_elements = 0 THEN
      put_string ('$sp_null');
      RETURN;
    IFEND;

*IF $true(osv$unix)
    handler_established := #establish_condition_handler (-1, ^abort_handler);
*ELSE
    osp$establish_block_exit_hndlr (^abort_handler);
*IFEND

{ Phase 1: identify the sub-patterns.

    PUSH representation_counts: [1 .. pattern_header^.number_of_elements];
    initialize_counts;

    identify_sub_patterns (initial_element);

{ Phase 2: put out the string representation of the pattern.

    put_sub_pattern (FALSE, initial_element, ignore_sub_pattern_successor);

    WHILE pattern_end_count > 0 DO
      put_string (')');
      pattern_end_count := pattern_end_count - 1;
    WHILEND;

*IF $true(osv$unix)
    IF handler_established THEN
      handler_established := NOT #disestablish_condition_handler (-1);
    IFEND;
*ELSE
    osp$disestablish_cond_handler;
*IFEND

  PROCEND clp$sp_convert_to_string;
?? TITLE := 'clp$sp_count', EJECT ??

{
{   This request builds a string pattern that matches a particular number of
{ characters.
{
{       CLP$SP_COUNT (COUNT, WORK_AREA, PATTERN, STATUS)
{
{ COUNT: (input)  This parameter specifies the number of characters that must
{       be found.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_count
    (    excluded_chars: clt$string_pattern_characters;
         count: clt$string_size;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    IF excluded_chars = $clt$string_pattern_characters [] THEN
      initialize_count_pattern (clc$sp_count, count, count, work_area, pattern, status);
    ELSE
      initialize_char_set_pattern (clc$sp_count, excluded_chars, count, work_area, pattern, status);
    IFEND;

  PROCEND clp$sp_count;
?? TITLE := 'clp$sp_count_test_left', EJECT ??

{
{   This request builds a string pattern that succeeds when encountered the
{ specified number of characters from the left end of the subject string.
{
{       CLP$SP_COUNT_TEST_LEFT (COUNT, WORK_AREA, PATTERN, STATUS)
{
{ COUNT: (input)  This parameter specifies the number of characters to the
{       left.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_count_test_left
    (    count: clt$string_size;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    initialize_count_pattern (clc$sp_count_test_left, count, 0, work_area, pattern, status);

  PROCEND clp$sp_count_test_left;
?? TITLE := 'clp$sp_count_test_right', EJECT ??

{
{   This request builds a string pattern that succeeds when encountered the
{ specified number of characters from the right end of the subject string.
{
{       CLP$SP_COUNT_TEST_RIGHT (COUNT, WORK_AREA, PATTERN, STATUS)
{
{ COUNT: (input)  This parameter specifies the number of characters to the
{       right.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_count_test_right
    (    count: clt$string_size;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    initialize_count_pattern (clc$sp_count_test_right, count, 0, work_area, pattern, status);

  PROCEND clp$sp_count_test_right;
?? TITLE := 'clp$sp_fail_element', EJECT ??

{
{   This request builds a string pattern consisting of an element that always
{ fails to match.
{
{       CLP$SP_FAIL_ELEMENT (WORK_AREA, PATTERN, STATUS)
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_fail_element
    (VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    initialize_unqualified_pattern (clc$sp_fail_element, work_area, pattern, status);

  PROCEND clp$sp_fail_element;
?? TITLE := 'clp$sp_fail_pattern', EJECT ??

{
{   This request builds a string pattern consisting of an element that will
{ cause immediate failure termination of the entire matching process.
{
{       CLP$SP_FAIL_PATTERN (WORK_AREA, PATTERN, STATUS)
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_fail_pattern
    (VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    initialize_unqualified_pattern (clc$sp_fail_pattern, work_area, pattern, status);

  PROCEND clp$sp_fail_pattern;
?? TITLE := 'clp$sp_fence', EJECT ??

{
{   This request builds a string pattern consisting of a "fence" element.
{
{       CLP$SP_FENCE (WORK_AREA, PATTERN, STATUS)
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_fence
    (VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    initialize_unqualified_pattern (clc$sp_fence, work_area, pattern, status);

  PROCEND clp$sp_fence;
?? TITLE := 'clp$sp_multiple', EJECT ??

{
{   This request builds a string pattern that matches a minimum number of
{ characters.
{
{       CLP$SP_MULTIPLE (MINIMUM_COUNT, WORK_AREA, PATTERN, STATUS)
{
{ MINIMUM_COUNT: (input)  This parameter specifies the minimum number of
{       characters to be matched.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_multiple
    (    excluded_chars: clt$string_pattern_characters;
         minimum_count: clt$string_size;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    IF excluded_chars = $clt$string_pattern_characters [] THEN
      initialize_count_pattern (clc$sp_multiple, minimum_count, minimum_count, work_area, pattern, status);
    ELSE
      initialize_char_set_pattern (clc$sp_multiple, excluded_chars, minimum_count, work_area, pattern,
            status);
    IFEND;

  PROCEND clp$sp_multiple;
?? TITLE := 'clp$sp_one_character', EJECT ??

{
{   This request builds a string pattern that matches exactly one of a
{ particular set of characters.
{
{       CLP$SP_ONE_CHARACTER (CHAR_SET, WORK_AREA, PATTERN, STATUS)
{
{ CHAR_SET: (input)  This parameter specifies the set of characters.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_one_character
    (    char_set: clt$string_pattern_characters;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    initialize_char_set_pattern (clc$sp_one_character, char_set, 1, work_area, pattern, status);

  PROCEND clp$sp_one_character;
?? TITLE := 'clp$sp_pattern_concat_pattern', EJECT ??
*copyc clh$sp_pattern_concat_pattern

  PROCEDURE [XDCL] clp$sp_pattern_concat_pattern
    (    left_pattern: ^clt$string_pattern;
         right_pattern: ^clt$string_pattern;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result_pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      copied_left_pattern: ^clt$string_pattern,
      first_result_element: ^clt$string_pattern_element,
      ignore_initial_element: ^clt$string_pattern_element,
      ignore_pattern_header: ^clt$string_pattern_header,
      number_of_left_elements: clt$string_size,
      result_pattern_header: ^clt$string_pattern_header,
      successor_element: ^clt$string_pattern_element,
      successor_element_link: clt$string_pattern_element_link;


    status.normal := TRUE;

    open_string_pattern (left_pattern, ignore_pattern_header, ignore_initial_element, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    open_string_pattern (right_pattern, ignore_pattern_header, ignore_initial_element, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT result_pattern: [[REP #SIZE (left_pattern^) + #SIZE (right_pattern^) -
          #SIZE (clt$string_pattern_header) OF cell]] IN work_area;
    IF result_pattern = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    RESET result_pattern;

    NEXT copied_left_pattern: [[REP #SIZE (left_pattern^) OF cell]] IN result_pattern;
    copied_left_pattern^ := left_pattern^;
    RESET copied_left_pattern;
    NEXT result_pattern_header IN copied_left_pattern;
    number_of_left_elements := result_pattern_header^.number_of_elements;

    successor_element_link := NIL;
    copy_pattern_elements (right_pattern, result_pattern, successor_element_link);

    IF number_of_left_elements = 0 THEN
      result_pattern_header^.initial_element := successor_element_link;
    ELSE
      NEXT first_result_element IN copied_left_pattern;
      successor_element := #PTR (successor_element_link, result_pattern^);
      link_successor_to_pattern (result_pattern, first_result_element, number_of_left_elements,
            successor_element_link, min_subject_size (successor_element));
    IFEND;

    RESET result_pattern;

  PROCEND clp$sp_pattern_concat_pattern;
?? TITLE := 'clp$sp_pattern_concat_string', EJECT ??
*copyc clh$sp_pattern_concat_string

  PROCEDURE [XDCL] clp$sp_pattern_concat_string
    (    left_pattern: ^clt$string_pattern;
         right_string: ^clt$string_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result_pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      copied_left_pattern: ^clt$string_pattern,
      first_result_element: ^clt$string_pattern_element,
      ignore_initial_element: ^clt$string_pattern_element,
      ignore_pattern_header: ^clt$string_pattern_header,
      number_of_left_elements: clt$string_size,
      result_pattern_header: ^clt$string_pattern_header,
      successor_element: ^clt$string_pattern_element,
      successor_element_link: clt$string_pattern_element_link;


    status.normal := TRUE;

    open_string_pattern (left_pattern, ignore_pattern_header, ignore_initial_element, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT result_pattern: [[REP #SIZE (left_pattern^) + #SIZE (clt$string_pattern_element) +
          #SIZE (right_string^) OF cell]] IN work_area;
    IF result_pattern = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    RESET result_pattern;

    NEXT copied_left_pattern: [[REP #SIZE (left_pattern^) OF cell]] IN result_pattern;
    copied_left_pattern^ := left_pattern^;
    RESET copied_left_pattern;
    NEXT result_pattern_header IN copied_left_pattern;
    number_of_left_elements := result_pattern_header^.number_of_elements;

    initialize_pattern_element (result_pattern, result_pattern, result_pattern_header^.number_of_elements,
          successor_element_link, successor_element);

    initialize_string_lit_element (right_string, TRUE, successor_element, result_pattern, result_pattern);

    IF number_of_left_elements = 0 THEN
      result_pattern_header^.initial_element := successor_element_link;
    ELSE
      NEXT first_result_element IN copied_left_pattern;
      link_successor_to_pattern (result_pattern, first_result_element, number_of_left_elements,
            successor_element_link, min_subject_size (successor_element));
    IFEND;

    RESET result_pattern;

  PROCEND clp$sp_pattern_concat_string;
?? TITLE := 'clp$sp_pattern_or_pattern', EJECT ??
*copyc clh$sp_pattern_or_pattern

  PROCEDURE clp$sp_pattern_or_pattern
    (    first_pattern: ^clt$string_pattern;
         second_pattern: ^clt$string_pattern;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result_pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      alternative_element: ^clt$string_pattern_element,
      alternative_element_link: clt$string_pattern_element_link,
      copied_first_pattern: ^clt$string_pattern,
      first_result_element: ^clt$string_pattern_element,
      ignore_initial_element: ^clt$string_pattern_element,
      ignore_pattern_header: ^clt$string_pattern_header,
      number_of_first_elements: clt$string_size,
      result_pattern_header: ^clt$string_pattern_header;


    status.normal := TRUE;

    open_string_pattern (first_pattern, ignore_pattern_header, ignore_initial_element, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    open_string_pattern (second_pattern, ignore_pattern_header, ignore_initial_element, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT result_pattern: [[REP #SIZE (first_pattern^) + #SIZE (second_pattern^) -
          #SIZE (clt$string_pattern_header) OF cell]] IN work_area;
    IF result_pattern = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    RESET result_pattern;

    NEXT copied_first_pattern: [[REP #SIZE (first_pattern^) OF cell]] IN result_pattern;
    copied_first_pattern^ := first_pattern^;
    RESET copied_first_pattern;
    NEXT result_pattern_header IN copied_first_pattern;
    number_of_first_elements := result_pattern_header^.number_of_elements;

    alternative_element_link := NIL;
    copy_pattern_elements (second_pattern, result_pattern, alternative_element_link);

    IF number_of_first_elements = 0 THEN
      result_pattern_header^.initial_element := alternative_element_link;
    ELSE
      first_result_element := #PTR (result_pattern_header^.initial_element, result_pattern^);
      alternative_element := #PTR (alternative_element_link, result_pattern^);
      link_alternative_to_pattern (result_pattern, first_result_element, alternative_element_link,
            min_subject_size (alternative_element));
    IFEND;

    RESET result_pattern;

  PROCEND clp$sp_pattern_or_pattern;
?? TITLE := 'clp$sp_repeat_pattern', EJECT ??

{
{   This request creates a string pattern that matches a specified pattern a
{ minimum number of times.
{
{       CLP$SP_REPEAT_PATTERN (PATTERN, MINIMUM_COUNT, WORK_AREA,
{         RESULT_PATTERN, STATUS)
{
{ PATTERN: (input)  This parameter specifies the pattern to be matched
{       repeatedly.
{
{ MINIMUM_COUNT: (input)  This parameter specifies the minimum number of
{       repititions required of the PATTERN.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ RESULT_PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_repeat_pattern
    (    pattern: ^clt$string_pattern;
         minimum_count: clt$string_size;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result_pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      begin_element: ^clt$string_pattern_element,
      begin_element_link: clt$string_pattern_element_link,
      copied_pattern: ^clt$string_pattern,
      end_element: ^clt$string_pattern_element,
      end_element_link: clt$string_pattern_element_link,
      first_result_element: ^clt$string_pattern_element,
      initial_copied_element: ^clt$string_pattern_element,
      initial_element: ^clt$string_pattern_element,
      ignore_pattern_header: ^clt$string_pattern_header,
      result_pattern_header: ^clt$string_pattern_header;


    status.normal := TRUE;

    open_string_pattern (pattern, ignore_pattern_header, initial_element, status);
    IF NOT status.normal THEN
      RETURN;
    ELSEIF initial_element = NIL THEN
      result_pattern := pattern;
      RETURN;
    IFEND;

    NEXT result_pattern: [[REP #SIZE (pattern^) + (2 * #SIZE (clt$string_pattern_element)) OF cell]] IN
          work_area;
    IF result_pattern = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    RESET result_pattern;

    NEXT copied_pattern: [[REP #SIZE (pattern^) OF cell]] IN result_pattern;
    copied_pattern^ := pattern^;
    RESET copied_pattern;
    NEXT result_pattern_header IN copied_pattern;
    initial_copied_element := #PTR (result_pattern_header^.initial_element, result_pattern^);

    initialize_pattern_element (result_pattern, result_pattern, result_pattern_header^.number_of_elements,
          end_element_link, end_element);

    end_element^.kind := clc$sp_repeat_pattern_end;
    end_element^.count := minimum_count;
    end_element^.alternative := result_pattern_header^.initial_element;
    end_element^.alternative_min_subject_size := min_subject_size (initial_copied_element);

    NEXT first_result_element IN copied_pattern;
    link_successor_to_pattern (result_pattern, first_result_element,
          result_pattern_header^.number_of_elements - 1, end_element_link, 0);

    initialize_pattern_element (result_pattern, result_pattern, result_pattern_header^.number_of_elements,
          begin_element_link, begin_element);

    begin_element^.kind := clc$sp_repeat_pattern_begin;
    begin_element^.count := minimum_count;

    begin_element^.successor := end_element_link;
    begin_element^.min_subject_size := end_element^.alternative_min_subject_size * minimum_count;
    begin_element^.alternative_min_subject_size := begin_element^.min_subject_size;

    result_pattern_header^.initial_element := begin_element_link;

    RESET result_pattern;

  PROCEND clp$sp_repeat_pattern;
?? TITLE := 'clp$sp_string_concat_pattern', EJECT ??
*copyc clh$sp_string_concat_pattern

  PROCEDURE [XDCL] clp$sp_string_concat_pattern
    (    left_string: ^clt$string_value;
         right_pattern: ^clt$string_pattern;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result_pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      first_result_element: ^clt$string_pattern_element,
      ignore_initial_element: ^clt$string_pattern_element,
      ignore_pattern_header: ^clt$string_pattern_header,
      result_pattern_header: ^clt$string_pattern_header,
      successor_element: ^clt$string_pattern_element,
      successor_element_link: clt$string_pattern_element_link;


    status.normal := TRUE;

    open_string_pattern (right_pattern, ignore_pattern_header, ignore_initial_element, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT result_pattern: [[REP #SIZE (right_pattern^) + #SIZE (clt$string_pattern_element) +
          #SIZE (left_string^) OF cell]] IN work_area;
    IF result_pattern = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    RESET result_pattern;

    initialize_pattern_header (result_pattern, result_pattern_header);

    initialize_pattern_element (result_pattern, result_pattern, result_pattern_header^.number_of_elements,
          result_pattern_header^.initial_element, first_result_element);

    initialize_string_lit_element (left_string, TRUE, first_result_element, result_pattern, result_pattern);

    successor_element_link := NIL;
    copy_pattern_elements (right_pattern, result_pattern, successor_element_link);

    successor_element := #PTR (successor_element_link, result_pattern^);
    link_successor_to_pattern (result_pattern, first_result_element, 1, successor_element_link,
          min_subject_size (successor_element));

    RESET result_pattern;

  PROCEND clp$sp_string_concat_pattern;
?? TITLE := 'clp$sp_string_literal', EJECT ??
*copyc clh$sp_string_literal

  PROCEDURE [XDCL] clp$sp_string_literal
    (    string_literal: ^clt$string_value;
         case_sensitive: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    status.normal := TRUE;

    NEXT pattern: [[REP #SIZE (clt$string_pattern_header) + #SIZE (clt$string_pattern_element) +
          #SIZE (string_literal^) OF cell]] IN work_area;
    IF pattern = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    RESET pattern;

    initialize_pattern_header (pattern, pattern_header);

    initialize_pattern_element (pattern, pattern, pattern_header^.number_of_elements,
          pattern_header^.initial_element, pattern_element);

    initialize_string_lit_element (string_literal, case_sensitive, pattern_element, pattern, pattern);

    RESET pattern;

  PROCEND clp$sp_string_literal;
?? TITLE := 'clp$sp_succeed_forced', EJECT ??

{
{   This request builds a string pattern consisting of an element that always
{ succeeds, even when "backed into".
{
{       CLP$SP_SUCCEED_FORCED (WORK_AREA, PATTERN, STATUS)
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_succeed_forced
    (VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    initialize_unqualified_pattern (clc$sp_succeed_forced, work_area, pattern, status);

  PROCEND clp$sp_succeed_forced;
?? TITLE := 'clp$sp_succeed_passive', EJECT ??

{
{   This request builds a string pattern consisting of an element that matches
{ a null string.
{
{       CLP$SP_SUCCEED_PASSIVE (WORK_AREA, PATTERN, STATUS)
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_succeed_passive
    (VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    initialize_unqualified_pattern (clc$sp_succeed_passive, work_area, pattern, status);

  PROCEND clp$sp_succeed_passive;
?? TITLE := 'clp$sp_test', EJECT ??

{
{   This request builds a string pattern that evaluates a boolean expression
{ during the pattern matching process.
{
{       CLP$SP_TEST (BOOLEAN_EXPRESSION, WORK_AREA, PATTERN, STATUS)
{
{ BOOLEAN_EXPRESSION: (input)  This parameter specifies the expression to be
{       tested.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_test
    (    boolean_expression: ^clt$expression_text;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header,
      test_expression: ^clt$expression_text;


    status.normal := TRUE;

    NEXT pattern: [[REP #SIZE (clt$string_pattern_header) + #SIZE (clt$string_pattern_element) +
          #SIZE (boolean_expression^) OF cell]] IN work_area;
    IF pattern = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    RESET pattern;

    initialize_pattern_header (pattern, pattern_header);

    initialize_pattern_element (pattern, pattern, pattern_header^.number_of_elements,
          pattern_header^.initial_element, pattern_element);

    pattern_element^.kind := clc$sp_test;
    NEXT test_expression: [STRLENGTH (boolean_expression^)] IN pattern;
    pattern_element^.test_expression := #REL (test_expression, pattern^);
    test_expression^ := boolean_expression^;
    pattern_element^.extra_info_size := #SIZE (test_expression^);

    RESET pattern;

  PROCEND clp$sp_test;
?? TITLE := 'clp$sp_unevaluated_pattern', EJECT ??

{
{   This request builds a string pattern that is evaluated during the pattern
{ matching process.
{
{       CLP$SP_UNEVALUATED_PATTERN (PATTERN_EXPRESSION, MIN_SUBJECT_SIZE,
{         WORK_AREA, PATTERN, STATUS)
{
{ PATTERN_EXPRESSION: (input)  This parameter specifies the expression for the
{       unevaluated pattern.
{
{ MIN_SUBJECT_SIZE: (input)  This parameter specifies the minimum number of
{       characters that will be matched by the unevaluated pattern.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_unevaluated_pattern
    (    pattern_expression: ^clt$expression_text;
         min_subject_size: clt$string_size;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header,
      unevaluated_pattern: ^clt$expression_text;


    status.normal := TRUE;

    NEXT pattern: [[REP #SIZE (clt$string_pattern_header) + #SIZE (clt$string_pattern_element) +
          #SIZE (pattern_expression^) OF cell]] IN work_area;
    IF pattern = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    RESET pattern;

    initialize_pattern_header (pattern, pattern_header);

    initialize_pattern_element (pattern, pattern, pattern_header^.number_of_elements,
          pattern_header^.initial_element, pattern_element);

    pattern_element^.kind := clc$sp_unevaluated_pattern;
    NEXT unevaluated_pattern: [STRLENGTH (pattern_expression^)] IN pattern;
    pattern_element^.unevaluated_pattern := #REL (unevaluated_pattern, pattern^);
    unevaluated_pattern^ := pattern_expression^;
    pattern_element^.extra_info_size := #SIZE (unevaluated_pattern^);
    pattern_element^.min_subject_size := min_subject_size;

    RESET pattern;

  PROCEND clp$sp_unevaluated_pattern;
?? TITLE := 'clp$sp_upto_character', EJECT ??

{
{   This request builds a string pattern that matches characters until one of a
{ particular set of characters is found.
{
{       CLP$SP_UPTO_CHARACTER (CHAR_SET, WORK_AREA, PATTERN, STATUS)
{
{ CHAR_SET: (input)  This parameter specifies the set of characters.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_upto_character
    (    char_set: clt$string_pattern_characters;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    initialize_char_set_pattern (clc$sp_upto_character, char_set, 0, work_area, pattern, status);

  PROCEND clp$sp_upto_character;
?? TITLE := 'clp$sp_upto_count_from_left', EJECT ??

{
{   This request builds a string pattern that matches characters upto the
{ specified number of characters from the left end of the subject string.
{
{       CLP$SP_UPTO_COUNT_FROM_LEFT (COUNT, WORK_AREA, PATTERN, STATUS)
{
{ COUNT: (input)  This parameter specifies the number of characters to the
{       left.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_upto_count_from_left
    (    count: clt$string_size;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    initialize_count_pattern (clc$sp_upto_count_from_left, count, 0, work_area, pattern, status);

  PROCEND clp$sp_upto_count_from_left;
?? TITLE := 'clp$sp_upto_count_from_right', EJECT ??

{
{   This request builds a string pattern that matches characters upto the
{ specified number of characters from the right end of the subject string.
{
{       CLP$SP_UPTO_COUNT_FROM_RIGHT (COUNT, WORK_AREA, PATTERN, STATUS)
{
{ COUNT: (input)  This parameter specifies the number of characters to the
{       right.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE clp$sp_upto_count_from_right
    (    count: clt$string_size;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    initialize_count_pattern (clc$sp_upto_count_from_right, count, 0, work_area, pattern, status);

  PROCEND clp$sp_upto_count_from_right;
?? TITLE := 'adjust_relative_pointer', EJECT ??

{
{ PURPOSE:
{   This procedure is used to adjust (increment) a relative pointer.  It
{   is needed when the data referenced by the relative pointer is moved
{   within the structure containing the pointer.
{
{ RELATIVE_POINTER: (input)  This parameter specifies the address of the
{       relative pointer to be adjusted.  The caller must pass the
{       address via the #LOC function.
{
{ OFFSET_AMOUNT: (input)  This parameter specifies the number of cells
{       by which the relative pointer is to be adjusted.
{
{ NOTES:
{   This procedure depends on the fact that a non-NIL relative pointer is
{   represented by a 4-byte non-negative integer.
{

?? SKIP := 3 ??

  TYPE
    clt$adjust_relative_pointer = packed record
      offset: ost$segment_offset,
    recend;

?? SKIP := 3 ??

  PROCEDURE [INLINE] adjust_relative_pointer
    (    relative_pointer: ^clt$adjust_relative_pointer;
         offset_amount: ost$segment_offset);


    IF relative_pointer^.offset >= 0 THEN
      relative_pointer^.offset := relative_pointer^.offset + offset_amount;
    IFEND;

  PROCEND adjust_relative_pointer;
?? TITLE := 'build_character_set', EJECT ??

{
{ PURPOSE:
{   This procedure builds a set of characters from a cl$data_value of type
{
{            list of any of
{                string
{                range of string 1
{              anyend
{
{   Each string element represents all of the characters in the string.  Each
{   range element represents all of the characters between and including the
{   low character of the range and the high character.
{
{ LIST_VALUE: (input)  This parameter specifies the list to be processed.
{
{ CHARACTERS: (output)  This parameter specifies the set of characters.
{

  PROCEDURE build_character_set
    (    list_value: ^clt$data_value;
     VAR characters: clt$string_pattern_characters);

    VAR
      c: char,
      high_char: char,
      i: clt$string_index,
      low_char: char,
      node: ^clt$data_value;


    characters := $clt$string_pattern_characters [];
    node := list_value;
    WHILE (node <> NIL) AND (node^.kind = clc$list) AND (node^.element_value <> NIL) DO

      IF node^.element_value^.kind = clc$string THEN
        FOR i := 1 TO STRLENGTH (node^.element_value^.string_value^) DO
          characters := characters + $clt$string_pattern_characters [node^.element_value^.string_value^ (i)];
        FOREND;

      ELSE {clc$range}
        low_char := node^.element_value^.low_value^.string_value^ (1);
        high_char := node^.element_value^.high_value^.string_value^ (1);

        IF low_char <= high_char THEN
          FOR c := low_char TO high_char DO
            characters := characters + $clt$string_pattern_characters [c];
          FOREND;

        ELSE
          FOR c := high_char DOWNTO low_char DO
            characters := characters + $clt$string_pattern_characters [c];
          FOREND;
        IFEND;
      IFEND;

      node := node^.link;
    WHILEND;

  PROCEND build_character_set;
?? TITLE := 'copy_pattern_elements', EJECT ??

{
{ PURPOSE:
{   This procedure copies all of the element from one pattern, the source to
{   the end of another pattern, the destination.  In the process it adjusts
{   all of the element links and other relative pointers within the copied
{   elements to be correct for their relative position within the destination
{   pattern.  Also, the link to the logically first of the copied elements is
{   returned.
{
{ SOURCE_PATTERN: (input)  This parameter specifies the pattern whose elements
{       are to be copied.
{
{ DESTINATION_PATTERN_AREA: (input, output)  This parameter specifies
{       destination pattern.  This sequence pointer is assumed, on input, to be
{       positioned at the logical end of the destination pattern and is updated
{       to reflect the amount of space occupied by the copied elements.
{
{ INITIAL_COPIED_ELEMENT_LINK: (input, output)  This parameter specifies the
{       link to the logically first element of the copied elements.  If NIL
{       on input, the link is obtained from the source pattern's header.
{

  PROCEDURE copy_pattern_elements
    (    source_pattern: ^clt$string_pattern;
     VAR destination_pattern_area {input, output} : ^clt$string_pattern;
     VAR initial_copied_element_link: clt$string_pattern_element_link);

    VAR
      destination_offset: ost$segment_offset,
      destination_pattern: ^clt$string_pattern,
      destination_pattern_header: ^clt$string_pattern_header,
      i: clt$string_pattern_size,
      new_pattern_elements: ^SEQ ( * ),
      old_pattern_elements: ^SEQ ( * ),
      pattern_element: ^clt$string_pattern_element,
      skip_extra_info: ^array [1 .. * ] of cell,
      source_pattern_area: ^clt$string_pattern,
      source_pattern_header: ^clt$string_pattern_header;


    source_pattern_area := source_pattern;
    RESET source_pattern_area;
    NEXT source_pattern_header IN source_pattern_area;

    IF initial_copied_element_link = NIL THEN
      initial_copied_element_link := source_pattern_header^.initial_element;
    IFEND;

    IF initial_copied_element_link = NIL THEN

{ The pattern is empty, so there's nothing to do.

      RETURN;
    IFEND;

{ Copy all of the source pattern elements to the destination pattern area.

    NEXT old_pattern_elements: [[REP #SIZE (source_pattern_area^) - #SIZE (clt$string_pattern_header) OF
          cell]] IN source_pattern_area;
    NEXT new_pattern_elements: [[REP #SIZE (old_pattern_elements^) OF cell]] IN destination_pattern_area;
    new_pattern_elements^ := old_pattern_elements^;
    RESET destination_pattern_area TO new_pattern_elements;

{ Calculate the amount by which relative pointers in the source pattern must be
{ adjusted once they have been copied into the destination pattern.

    destination_offset := i#current_sequence_position (destination_pattern_area) -
          #SIZE (clt$string_pattern_header);

{ Adjust the link to the logically first element of the copied pattern.

    adjust_relative_pointer (#LOC (initial_copied_element_link), destination_offset);

    FOR i := 1 TO source_pattern_header^.number_of_elements DO
      NEXT pattern_element IN destination_pattern_area;

{ Adjust the links to the successor and alternative elements.

      adjust_relative_pointer (#LOC (pattern_element^.successor), destination_offset);
      adjust_relative_pointer (#LOC (pattern_element^.alternative), destination_offset);

{ Adjust the relative pointer to extra information which follows the element.

      CASE pattern_element^.kind OF
      = clc$sp_capture_begin =
        adjust_relative_pointer (#LOC (pattern_element^.capture_end_element), destination_offset);
      = clc$sp_capture_end, clc$sp_capture_index =
        CASE pattern_element^.capture_kind OF
        = clc$sp_capture_via_command =
          adjust_relative_pointer (#LOC (pattern_element^.capture_command), destination_offset);
        = clc$sp_capture_via_variable =
          adjust_relative_pointer (#LOC (pattern_element^.capture_variable), destination_offset);
        ELSE
        CASEND;
      = clc$sp_characters, clc$sp_multiple, clc$sp_one_character, clc$sp_upto_character =
        adjust_relative_pointer (#LOC (pattern_element^.characters), destination_offset);
      = clc$sp_string_literal =
        adjust_relative_pointer (#LOC (pattern_element^.string_literal), destination_offset);
      = clc$sp_test =
        adjust_relative_pointer (#LOC (pattern_element^.test_expression), destination_offset);
      = clc$sp_unevaluated_pattern =
        adjust_relative_pointer (#LOC (pattern_element^.unevaluated_pattern), destination_offset);
      ELSE
      CASEND;

      IF pattern_element^.extra_info_size > 0 THEN

{ Skip over any additional information for the pattern element.

        NEXT skip_extra_info: [1 .. pattern_element^.extra_info_size] IN destination_pattern_area;
      IFEND;
    FOREND;

{ Update the number of elements in the destination pattern.

    destination_pattern := destination_pattern_area;
    RESET destination_pattern;
    NEXT destination_pattern_header IN destination_pattern;
    destination_pattern_header^.number_of_elements := destination_pattern_header^.number_of_elements +
          source_pattern_header^.number_of_elements;

  PROCEND copy_pattern_elements;
?? TITLE := 'initialize_char_set_element', EJECT ??

{
{ PURPOSE:
{   This procedure initializes a new pattern element as one of the pattern
{   elements that is qualified by a set of characters.  It allocates space for
{   the character set itself.  If there isn't enough space for the character
{   set, the CHARACTERS field of the PATTERN_ELEMENT is set to NIL.
{
{ CHAR_SET: (input)  This parameter specifies the set of characters that
{       qualify the pattern element.
{
{ PATTERN_ELEMENT: (input)  This parameter points to the new pattern element.
{
{ PATTERN: (input)  This parameter specifies the string pattern for which the
{       element is to be initialized.
{
{ WORK_AREA: (input, output)  This parameter specifies the work area in which
{       the character set is to be allocated.
{

  PROCEDURE [INLINE] initialize_char_set_element
    (    char_set: clt$string_pattern_characters;
         pattern_element: ^clt$string_pattern_element;
         pattern: ^clt$string_pattern;
     VAR work_area {input, output} : ^clt$work_area);

    VAR
      characters: ^clt$string_pattern_characters;


    NEXT characters IN work_area;
    pattern_element^.characters := #REL (characters, pattern^);
    IF characters <> NIL THEN
      characters^ := char_set;
      pattern_element^.extra_info_size := #SIZE (clt$string_pattern_characters);
    IFEND;

  PROCEND initialize_char_set_element;
?? TITLE := 'initialize_char_set_pattern', EJECT ??

{
{   This request builds a string pattern consisting of one of the pattern
{ elements which is qualified by a set of characters.
{
{       INITIALIZE_CHAR_SET_PATTERN (KIND, CHAR_SET, COUNT, WORK_AREA, PATTERN,
{         STATUS)
{
{ KIND: (input)  This parameter specifies the kind of the pattern element.
{
{ CHAR_SET: (input)  This parameter specifies the set of characters to be used
{       for the pattern element.
{
{ COUNT: (input)  This parameter specifies the COUNT and MIN_SUBJECT_SIZE
{       fields for the pattern element.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE [INLINE] initialize_char_set_pattern
    (    kind: clt$string_pattern_element_kind;
         char_set: clt$string_pattern_characters;
         count: clt$string_size;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    status.normal := TRUE;

    NEXT pattern: [[REP #SIZE (clt$string_pattern_header) + #SIZE (clt$string_pattern_element) +
          #SIZE (clt$string_pattern_characters) OF cell]] IN work_area;
    IF pattern = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    RESET pattern;

    initialize_pattern_header (pattern, pattern_header);

    initialize_pattern_element (pattern, pattern, pattern_header^.number_of_elements,
          pattern_header^.initial_element, pattern_element);

    pattern_element^.kind := kind;
    initialize_char_set_element (char_set, pattern_element, pattern, pattern);
    pattern_element^.count := count;
    pattern_element^.min_subject_size := count;

    RESET pattern;

  PROCEND initialize_char_set_pattern;
?? TITLE := 'initialize_count_pattern', EJECT ??

{
{   This request builds a string pattern consisting of one of the pattern
{ elements which is qualified by a count.
{
{       INITIALIZE_COUNT_PATTERN (KIND, COUNT, MIN_SUBJECT_SIZE, WORK_AREA,
{         PATTERN, STATUS)
{
{ KIND: (input)  This parameter specifies the kind of the pattern element.
{
{ COUNT: (input)  This parameter specifies the COUNT and MIN_SUBJECT_SIZE
{       fields for the pattern element.
{
{ MIN_SUBJECT_SIZE: (input)  This parameter specifies the minimum number of
{       characters the pattern element matches.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE [INLINE] initialize_count_pattern
    (    kind: clt$string_pattern_element_kind;
         count: clt$string_size;
         min_subject_size: clt$string_size;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    status.normal := TRUE;

    NEXT pattern: [[REP #SIZE (clt$string_pattern_header) + #SIZE (clt$string_pattern_element) OF cell]] IN
          work_area;
    IF pattern = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    RESET pattern;

    initialize_pattern_header (pattern, pattern_header);

    initialize_pattern_element (pattern, pattern, pattern_header^.number_of_elements,
          pattern_header^.initial_element, pattern_element);

    pattern_element^.kind := kind;
    pattern_element^.count := count;
    pattern_element^.min_subject_size := min_subject_size;

    IF (kind = clc$sp_count) OR (kind = clc$sp_multiple) THEN
      pattern_element^.characters := NIL;
    IFEND;

    RESET pattern;

  PROCEND initialize_count_pattern;
?? TITLE := 'initialize_pattern_element', EJECT ??

{
{ PURPOSE:
{   This procedure allocates space for and initializes a new pattern element.
{
{ PATTERN: (input)  This parameter specifies the string pattern for for which
{       the element is to be initialized.
{
{ WORK_AREA: (input, output)  This parameter specifies the work area in which
{       the pattern element is to be allocated.
{
{ NUMBER_OF_ELEMENTS: (input, output)  This parameter specifies the number of
{       elements in the pattern for which this element is being initialized.
{       It is incremented by 1 by this procedure.
{
{ PATTERN_ELEMENT_LINK: (output)  This parameter specifies the linkage field
{       for the element to be initialized.  This linkage field is set by this
{       procedure once space for the new pattern element has been allocated.
{
{ PATTERN_ELEMENT: (output)  This parameter is set to point to the new pattern
{       element.  If there is no room in the work area for the pattern element,
{       NIL is returned.
{

  PROCEDURE [INLINE] initialize_pattern_element
    (    pattern: ^clt$string_pattern;
     VAR work_area {input, output} : ^clt$work_area;
     VAR number_of_elements {input, output} : clt$string_size;
     VAR pattern_element_link: clt$string_pattern_element_link;
     VAR pattern_element: ^clt$string_pattern_element);


    NEXT pattern_element IN work_area;

    IF pattern_element <> NIL THEN
      pattern_element_link := #REL (pattern_element, pattern^);

      pattern_element^.successor := NIL;
      pattern_element^.alternative := NIL;
      pattern_element^.min_subject_size := 0;
      pattern_element^.alternative_min_subject_size := 0;
      pattern_element^.count := 0;
      pattern_element^.extra_info_size := 0;

      number_of_elements := number_of_elements + 1;
    IFEND;

  PROCEND initialize_pattern_element;
?? TITLE := 'initialize_pattern_header', EJECT ??

{
{ PURPOSE:
{   This procedure allocates space for and initializes a new pattern header.
{       It is incremented by 1 by this procedure.
{
{ WORK_AREA: (input, output)  This parameter specifies the work area in which
{       the pattern element is to be allocated.
{
{ PATTERN_HEADER: (output)  This parameter is set to point to the new pattern
{       header.  If there is no room in the work area for the pattern header,
{       NIL is returned.
{

  PROCEDURE [INLINE] initialize_pattern_header
    (VAR work_area {input, output} : ^clt$work_area;
     VAR pattern_header: ^clt$string_pattern_header);


    NEXT pattern_header IN work_area;
    IF pattern_header <> NIL THEN
      pattern_header^.version := clc$string_pattern_version;
      pattern_header^.number_of_elements := 0;
      pattern_header^.initial_element := NIL;
    IFEND;

  PROCEND initialize_pattern_header;
?? TITLE := 'initialize_string_lit_element', EJECT ??

{
{ PURPOSE:
{   This procedure initializes a new pattern element as a string literal
{   pattern element.  It allocates space for the string literal itself.
{   If there isn't enough space for the string literal, the STRING_LITERAL
{   field of the PATTERN_ELEMENT is set to NIL.
{
{ STR: (input)  This parameter specifies the string literal for the pattern
{       element.
{
{ CASE_SENSITIVE: (input)  This parameter specifies whether the case (lower or
{       upper) matters (TRUE) or not (FALSE) when matching STR.
{
{ PATTERN_ELEMENT: (input)  This parameter points to the new pattern element.
{
{ PATTERN: (input)  This parameter specifies the string pattern for which the
{       element is to be initialized.
{
{ WORK_AREA: (input, output)  This parameter specifies the work area in which
{       the pattern element is to be allocated.
{

  PROCEDURE [INLINE] initialize_string_lit_element
    (    str: ^clt$string_value;
         case_sensitive: boolean;
         pattern_element: ^clt$string_pattern_element;
         pattern: ^clt$string_pattern;
     VAR work_area {input, output} : ^clt$work_area);

    VAR
      string_literal: ^clt$string_value;


    pattern_element^.kind := clc$sp_string_literal;
    pattern_element^.case_sensitive := case_sensitive;
    NEXT string_literal: [STRLENGTH (str^)] IN work_area;
    pattern_element^.string_literal := #REL (string_literal, pattern^);
    IF string_literal <> NIL THEN
      string_literal^ := str^;
      pattern_element^.extra_info_size := #SIZE (string_literal^);
      pattern_element^.min_subject_size := STRLENGTH (string_literal^);
    IFEND;

  PROCEND initialize_string_lit_element;
?? TITLE := 'initialize_unqualified_pattern', EJECT ??

{
{   This request builds a string pattern consisting of one of the pattern
{ elements which requires no qualifying information.
{
{       INITIALIZE_UNQUALIFIED_PATTERN (KIND, WORK_AREA, PATTERN, STATUS)
{
{ KIND: (input)  This parameter specifies the kind of the pattern element.
{
{ WORK_AREA: (input, output)  This parameter specifies an area of storage that
{       will be used to construct the resulting string pattern.  The current
{       position of this sequence pointer is updated to reflect the amount of
{       storage used by the request.  The resulting string pattern is contained
{       completely within the used part of this sequence.
{
{ PATTERN: (output)  This parameter specifies the result string pattern.
{
{ STATUS: (output)  This parameter specifies the request completion status.
{

  PROCEDURE [INLINE] initialize_unqualified_pattern
    (    kind: clt$string_pattern_element_kind;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

    VAR
      pattern_element: ^clt$string_pattern_element,
      pattern_header: ^clt$string_pattern_header;


    status.normal := TRUE;

    NEXT pattern: [[REP #SIZE (clt$string_pattern_header) + #SIZE (clt$string_pattern_element) OF cell]] IN
          work_area;
    IF pattern = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    RESET pattern;

    initialize_pattern_header (pattern, pattern_header);

    initialize_pattern_element (pattern, pattern, pattern_header^.number_of_elements,
          pattern_header^.initial_element, pattern_element);

    pattern_element^.kind := kind;

    RESET pattern;

  PROCEND initialize_unqualified_pattern;
?? TITLE := 'link_alternative_to_pattern', EJECT ??

{
{ PURPOSE:
{   This procedure links an alternative pattern to an existing pattern.
{   If the existing pattern already has alternatives, the new one is
{   added to the end of the chain of alternatives.  Also, the
{   ALTERNATIVE_MIN_SUBJECT_SIZE field of every element in the alternative
{   chain is set to the minimum subject size required by the new if the
{   new alternative is shorter.
{
{ PATTERN: (input)  This parameter specifies the string pattern.
{
{ FIRST_PATTERN_ELEMENT: (input)  This parameter specifies the first
{       element of the pattern to which an alternative is being added.
{
{ ALTERNATIVE_ELEMENT_LINK: (input)  This parameter specifies the link to
{       the new alternative.
{
{ MIN_ALTERNATIVE_SIZE: (input)  This parameter specifies the minimum
{       subject size required by the new alternative.
{

  PROCEDURE [INLINE] link_alternative_to_pattern
    (    pattern: ^clt$string_pattern;
         first_pattern_element: ^clt$string_pattern_element;
         alternative_element_link: clt$string_pattern_element_link;
         min_alternative_size: clt$string_size);

    VAR
      linkage_element: ^clt$string_pattern_element;


    linkage_element := first_pattern_element;
    WHILE linkage_element^.alternative <> NIL DO

{ Set the current element's ALTERNATIVE_MIN_SUBJECT_SIZE  to the lesser of its
{ present value and the new alternative's minimum subject size.

      IF min_alternative_size < linkage_element^.alternative_min_subject_size THEN
        linkage_element^.alternative_min_subject_size := min_alternative_size;
      IFEND;

      linkage_element := #PTR (linkage_element^.alternative, pattern^);
    WHILEND;

{ Link the new alternative to the end of the "chain" of existing alternatives.

    linkage_element^.alternative := alternative_element_link;
    linkage_element^.alternative_min_subject_size := min_alternative_size;

  PROCEND link_alternative_to_pattern;
?? TITLE := 'link_successor_to_pattern', EJECT ??

{
{ PURPOSE:
{   This procedure links all of the terminal nodes within a group of
{   pattern elements to the group's successor.  It also increments the
{   MIN_SUBJECT_SIZE and ALTERNATIVE_MIN_SUBJECT_SIZE fields of every
{   element in the group by the minimum subject size required by the
{   group's successor or its alternatives.
{
{ PATTERN: (input)  This parameter specifies the string pattern.
{
{ FIRST_PATTERN_ELEMENT: (input)  This parameter specifies the first
{       element of the group to be updated.
{
{ NUMBER_OF_ELEMENTS: (input)  This parameter specifies the number of
{       elements in the group.
{
{ SUCCESSOR_ELEMENT_LINK: (input)  This parameter specifies the link to
{       the group's successor.
{
{ MIN_SUCCESSOR_SIZE: (input)  This parameter specifies the minimum
{       subject size required by the group's successor or its
{       alternatives.
{

  PROCEDURE [INLINE] link_successor_to_pattern
    (    pattern: ^clt$string_pattern;
         first_pattern_element: ^clt$string_pattern_element;
         number_of_elements: clt$string_pattern_size;
         successor_element_link: clt$string_pattern_element_link;
         min_successor_size: clt$string_size);

    VAR
      i: clt$string_pattern_size,
      pattern_area: ^clt$string_pattern,
      pattern_element: ^clt$string_pattern_element,
      skip_extra_info: ^array [1 .. * ] of cell;


    pattern_area := pattern;
    RESET pattern_area TO first_pattern_element;

    FOR i := 1 TO number_of_elements DO
      NEXT pattern_element IN pattern_area;

{ Add the minimum size of the pattern's successor to the minimum subject
{ size fields of the element.

      pattern_element^.min_subject_size := pattern_element^.min_subject_size + min_successor_size;
      pattern_element^.alternative_min_subject_size := pattern_element^.alternative_min_subject_size +
            min_successor_size;
      IF pattern_element^.successor = NIL THEN

{ Link this terminal node of the pattern to the pattern's successor.

        pattern_element^.successor := successor_element_link;
      IFEND;

      IF (i < number_of_elements) AND (pattern_element^.extra_info_size > 0) THEN

{ Skip over any additional information for the pattern element.

        NEXT skip_extra_info: [1 .. pattern_element^.extra_info_size] IN pattern_area;
      IFEND;
    FOREND;

  PROCEND link_successor_to_pattern;
?? TITLE := 'min_subject_size', EJECT ??

{
{ PURPOSE:
{   This function returns the lesser of a CLT$STRING_PATTERN_ELEMENT's
{   MIN_SUBJECT_SIZE and ALTERNATIVE_MIN_SUBJECT_SIZE fields.
{

  FUNCTION [INLINE] min_subject_size
    (    pattern_element: ^clt$string_pattern_element): clt$string_size;


    IF pattern_element^.min_subject_size <= pattern_element^.alternative_min_subject_size THEN
      min_subject_size := pattern_element^.min_subject_size;
    ELSE
      min_subject_size := pattern_element^.alternative_min_subject_size;
    IFEND;

  FUNCEND min_subject_size;
?? TITLE := 'open_string_pattern', EJECT ??

  PROCEDURE [INLINE] open_string_pattern
    (    pattern: ^clt$string_pattern;
     VAR pattern_header: ^clt$string_pattern_header;
     VAR initial_pattern_element: ^clt$string_pattern_element;
     VAR status: ost$status);

    VAR
      pattern_sequence: ^clt$string_pattern;


    status.normal := TRUE;

    pattern_sequence := pattern;
    RESET pattern_sequence;
    NEXT pattern_header IN pattern_sequence;

    IF (pattern_header = NIL) OR (pattern_header^.version <> clc$string_pattern_version) THEN
      osp$set_status_condition (cle$bad_string_pattern, status);
    ELSE
      initial_pattern_element := #PTR (pattern_header^.initial_element, pattern^);
    IFEND;

  PROCEND open_string_pattern;

MODEND clm$string_pattern_handlers;
*DECK DECK=CLM$SUBSTITUTE_DELIMITED_TEXT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Substitute Delimited Text' ??
MODULE clm$substitute_delimited_text;

{
{ PURPOSE:
{   This module contains a procedure to process delimited text.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$bad_data_value
*copyc cle$string_too_long
*copyc clt$command_line
*copyc clt$command_line_index
*copyc clt$command_line_size
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc clp$data_representation_text
*copyc clp$evaluate_unqual_union_expr
*copyc clp$get_work_area
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*copyc clp$internal_convert_to_string
*copyc clp$scan_non_space_lexical_unit
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal

?? TITLE := 'clp$substitute_delimited_text', EJECT ??
*copyc clh$substitute_delimited_text

  PROCEDURE [XDCL, #GATE] clp$substitute_delimited_text
    (    old_text: clt$command_line;
         delimiter: char;
     VAR new_text: clt$command_line;
     VAR new_text_size: clt$command_line_size;
     VAR status: ost$status);

    TYPE
      char_set = set of char;

    VAR
      char_delimiter: char_set,
      new_text_length: integer,
      old_text_length: clt$command_line_size,
      original_work_area: ^clt$work_area,
      scan_found_char: boolean,
      scan_index: clt$command_line_index,
      start_index: 1 .. clc$max_command_line_size + 2,
      string_size: clt$command_line_size,
      substitution_text: ^clt$string_value,
      work_area_ptr: ^^clt$work_area;

?? NEWTITLE := 'evaluate_substitution_text', EJECT ??
{
{ This procedure was cloned from clp$evaluate_expression_to_str.  This was done
{ (rather than calling the original routine directly) for two reasons: 1) so
{ that the actual length of the result string would be available, and 2) to
{ reduce the amount of run-time stack space needed (avoids the need to set
{ aside a possibly huge string to receive the result.
{

    PROCEDURE evaluate_substitution_text
      (    expression: clt$expression_text);

      VAR
        ignore_result_type_description: ^clt$type_description,
        lexical_units: ^clt$lexical_units,
        parse: clt$parse_state,
        representation: ^clt$data_representation,
        request: clt$convert_to_string_request,
        result: ^clt$data_value;


      status.normal := TRUE;
      substitution_text := NIL;

      IF original_work_area = NIL THEN
        clp$get_work_area (#RING (^work_area_ptr), work_area_ptr, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        original_work_area := work_area_ptr^;
      ELSE
        work_area_ptr^ := original_work_area;
      IFEND;

      clp$identify_lexical_units (^expression, work_area_ptr^, lexical_units, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$initialize_parse_state (^expression, lexical_units, parse);
      clp$scan_non_space_lexical_unit (parse);

      clp$evaluate_unqual_union_expr (work_area_ptr^, parse, ignore_result_type_description, result, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      request.initial_indentation := 0;
      request.continuation_indentation := 0;
      request.max_string := clc$max_string_size;
      request.include_advanced_items := TRUE;
      request.include_hidden_items := TRUE;
      request.kind := clc$convert_data_value;
      CASE result^.kind OF
      = clc$application, clc$boolean, clc$cobol_name, clc$command_reference, clc$data_name, clc$date_time,
            clc$entry_point_reference, clc$file, clc$integer, clc$keyword, clc$lock, clc$name,
            clc$network_title, clc$program_name, clc$real, clc$scu_line_identifier, clc$statistic_code,
            clc$status, clc$status_code, clc$string, clc$time_increment, clc$time_zone, clc$unspecified =
        request.representation_option := clc$data_elem_representation;
      = clc$array, clc$deferred, clc$list, clc$range, clc$record, clc$string_pattern, clc$type_specification =
        request.representation_option := clc$data_source_representation;
      ELSE
        osp$set_status_abnormal ('CL', cle$bad_data_value, '', status);
        RETURN;
      CASEND;
      request.value := result;

      clp$internal_convert_to_string (request, work_area_ptr^, representation, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      substitution_text := clp$data_representation_text (representation);

    PROCEND evaluate_substitution_text;
?? TITLE := 'set_status_line_too_long', EJECT ??

    PROCEDURE [INLINE] set_status_line_too_long;

      new_text_size := old_text_length;
      new_text := old_text;
      osp$set_status_abnormal ('CL', cle$string_too_long, ' for substitution', status);
      EXIT clp$substitute_delimited_text;

    PROCEND set_status_line_too_long;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    char_delimiter := $char_set [delimiter];
    old_text_length := STRLENGTH (old_text);
    start_index := 1;
    new_text_length := 0;
    new_text_size := 0;
    original_work_area := NIL;

  /scan_loop/
    WHILE TRUE DO
      #SCAN (char_delimiter, old_text (start_index, * ), scan_index, scan_found_char);
      string_size := scan_index - 1;

      IF string_size > 0 THEN
        new_text_length := new_text_length + string_size;
        IF new_text_length > clc$max_command_line_size THEN
          set_status_line_too_long;
        IFEND;
        new_text (new_text_size + 1, string_size) := old_text (start_index, string_size);
        new_text_size := new_text_length;
      IFEND;

      start_index := start_index + scan_index;
      IF scan_found_char THEN
        IF (start_index > old_text_length) OR (old_text (start_index) = delimiter) THEN
          new_text_length := new_text_length + 1;
          IF new_text_length > clc$max_command_line_size THEN
            set_status_line_too_long;
          IFEND;
          new_text (new_text_size + 1) := delimiter;
          new_text_size := new_text_length;
          start_index := start_index + 1;
        ELSE
          #SCAN (char_delimiter, old_text (start_index, * ), scan_index, scan_found_char);
          string_size := scan_index - 1;
          evaluate_substitution_text (old_text (start_index, string_size));
          IF NOT status.normal THEN
            new_text_size := old_text_length;
            new_text := old_text;
            EXIT /scan_loop/;
          ELSEIF STRLENGTH (substitution_text^) > 0 THEN
            new_text_length := new_text_length + STRLENGTH (substitution_text^);
            IF new_text_length > clc$max_command_line_size THEN
              set_status_line_too_long;
            IFEND;
            new_text (new_text_size + 1, STRLENGTH (substitution_text^)) := substitution_text^;
            new_text_size := new_text_length;
          IFEND;
          start_index := start_index + scan_index;
        IFEND;
      IFEND;
      IF start_index > old_text_length THEN
        EXIT /scan_loop/;
      IFEND;
    WHILEND /scan_loop/;

    IF original_work_area <> NIL THEN
      work_area_ptr^ := original_work_area;
    IFEND;

  PROCEND clp$substitute_delimited_text;

MODEND clm$substitute_delimited_text;
*DECK DECK=CLM$SYSTEM_ACCESS_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : System Access Commands' ??
MODULE clm$system_access_commands;

{
{ PURPOSE:
{   This module contains the processors for commands that are used to gain and control access to NOS/VE.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$lfn_program_actions
*copyc avc$system_epilog
*copyc avc$system_prolog
*copyc clc$compiling_for_test_harness
*copyc cle$command_terminated
*copyc cle$epilog_file_missing
*copyc cle$login_prolog_file_missing
*copyc clt$parameter_list
*copyc jmc$class_names
*copyc jmc$job_management_id
*copyc jme$job_monitor_conditions
*copyc jmt$job_system_label
*copyc oss$job_paged_literal
*copyc ost$name_reference
*copyc ost$status
?? POP ??
*copyc amp$get_file_attributes
*copyc avp$display_pw_exp_warning
*copyc avp$get_capability
*copyc avp$get_file_value
*copyc clp$add_file_to_command_list
*copyc clp$delete_all_from_cmnd_list
*copyc clp$delete_all_file_connections
*copyc clp$delete_all_targets
*copyc clp$establish_sys_command_lib
*copyc clp$evaluate_parameters
*copyc clp$find_current_block
*copyc clp$free_all_handlers
*copyc clp$get_interpreter_mode
*copyc clp$include_file
*copyc clp$include_line
*copyc clp$log_edited_login_command
*copyc clp$login_command_ring_3
*copyc clp$put_job_command_response
*copyc clp$put_job_output
*copyc clp$set_command_kind
*copyc clp$set_processing_phase
*copyc ifp$discard_suspended_output
*copyc jmp$enable_exit_processing
*copyc jmp$enable_user_breaks
*copyc jmp$get_attribute_defaults
*copyc jmp$get_job_attributes
*copyc jmp$get_job_class_prolog
*copyc jmp$inhibit_exit_processing
*copyc jmp$logout
*copyc jmp$system_job
*copyc osp$append_status_file
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$establish_condition_handler
*copyc osp$generate_message
*copyc osp$generate_log_message
*copyc osp$generate_output_message
*copyc osp$get_status_severity
*copyc osp$set_message_level
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osv$initial_exception_context
*copyc pmp$abort
*copyc pmp$continue_to_cause

*copyc clv$processing_phase
*copyc clv$standard_files
*copyc jmv$initialized_as_disconnected
*copyc pmv$epilog_file

?? TITLE := 'clp$login_command', EJECT ??

  PROCEDURE [XDCL] clp$login_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      interpreter_mode: clt$interpreter_modes,
      job_system_label: jmt$job_system_label;


    status.normal := TRUE;

    clp$set_command_kind (clc$login_command);
    clp$get_interpreter_mode (interpreter_mode);

    IF interpreter_mode = clc$help_mode THEN
      clp$get_login_parameters (parameter_list, job_system_label, status);
    ELSE
      clp$login_command_ring_3 (status);
    IFEND;

  PROCEND clp$login_command;
?? TITLE := 'clp$get_login_data_for_nam', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$get_login_data_for_nam
    (    parameter_list: clt$parameter_list;
     VAR login_user: ost$name;
     VAR login_password: ost$name;
     VAR login_family: ost$name;
     VAR login_account: ost$name;
     VAR login_project: ost$name;
     VAR status: ost$status);

    VAR
      job_system_label: jmt$job_system_label;

    status.normal := TRUE;
    job_system_label.login_account := osc$null_name;
    job_system_label.login_password := osc$null_name;
    job_system_label.login_project := osc$null_name;
    job_system_label.login_user_identification.user := osc$null_name;
    job_system_label.login_user_identification.family := osc$null_name;
    clp$get_login_parameters (parameter_list, job_system_label, status);
    IF status.normal THEN
      login_user := job_system_label.login_user_identification.user;
      login_password := job_system_label.login_password;
      login_family := job_system_label.login_user_identification.family;
      login_account := job_system_label.login_account;
      login_project := job_system_label.login_project;
    IFEND;
  PROCEND clp$get_login_data_for_nam;

?? TITLE := 'clp$get_login_parameters', EJECT ??

  PROCEDURE [XDCL] clp$get_login_parameters
    (    parameter_list: clt$parameter_list;
     VAR job_system_label {input, output} : jmt$job_system_label;
     VAR status: ost$status);

{ PROCEDURE (osm$login) login (
{   login_user, u, user, lu: name = $required
{   password, pw: name = $optional
{   login_family, family_name, fn, lf: name = $optional
{   login_account, a, account, la: name = $optional
{   login_project, p, project, lp: name = $optional
{   cpu_time_limit, ctl: any of
{       key
{         system_default, unlimited
{       keyend
{       integer jmc$lowest_cpu_time_limit..jmc$highest_cpu_time_limit
{     anyend = $optional
{   earliest_run_time, ert: date_time = $optional
{   job_abort_disposition, jad: key
{       (restart, r)
{       (terminate, t)
{     keyend = $optional
{   job_class, jc: name = $optional
{   job_deferred_by_user, jdbu: boolean = false
{   job_destination_usage, jdu: any of
{       key
{         ntf, qtf, ve, ve_family, ve_local, ve_qtf
{       keyend
{       name
{     anyend = $optional
{   job_execution_ring, jer: integer osc$sj_ring_1..osc$user_ring_2 = $optional
{   job_qualifier, job_qualifiers, jq: any of
{       key
{         none, system_default
{       keyend
{       list 1..jmc$maximum_job_qualifiers of name
{     anyend = $optional
{   job_recovery_disposition, jrd: key
{       (continue, c)
{       (restart, r)
{       (terminate, t)
{     keyend = $optional
{   latest_run_time, lrt: date_time = $optional
{   magnetic_tape_limit, mtl: any of
{       key
{         system_default, unlimited, unspecified
{       keyend
{       integer jmc$lowest_magnetic_tape_limit..jmc$highest_magnetic_tape_limit
{     anyend = $optional
{   maximum_working_set, maxws: any of
{       key
{         system_default, unlimited
{       keyend
{       integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{     anyend = $optional
{   sru_limit, sl: any of
{       key
{         system_default, unlimited
{       keyend
{       integer jmc$lowest_sru_limit..jmc$highest_sru_limit
{     anyend = $optional
{   user_information, ui: string 0..jmc$user_information_size = $optional
{   user_job_name, jn, job_name, ujn: name = $optional
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 51] of clt$pdt_parameter_name,
      parameters: array [1 .. 20] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type6: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$date_time_type_qualifier,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type10: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type11: 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 .. 6] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type13: 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 .. 2] 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$name_type_qualifier,
          recend,
        recend,
      recend,
      type14: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type15: record
        header: clt$type_specification_header,
        qualifier: clt$date_time_type_qualifier,
      recend,
      type16: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type17: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type18: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type19: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type20: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
    recend := [
    [1,
    [91, 7, 8, 15, 10, 2, 248],
    clc$command, 51, 20, 1, 0, 0, 0, 0, 'OSM$LOGIN'], [
    ['A                              ',clc$alias_entry, 4],
    ['ACCOUNT                        ',clc$alias_entry, 4],
    ['CPU_TIME_LIMIT                 ',clc$nominal_entry, 6],
    ['CTL                            ',clc$abbreviation_entry, 6],
    ['EARLIEST_RUN_TIME              ',clc$nominal_entry, 7],
    ['ERT                            ',clc$abbreviation_entry, 7],
    ['FAMILY_NAME                    ',clc$alias_entry, 3],
    ['FN                             ',clc$alias_entry, 3],
    ['JAD                            ',clc$abbreviation_entry, 8],
    ['JC                             ',clc$abbreviation_entry, 9],
    ['JDBU                           ',clc$abbreviation_entry, 10],
    ['JDU                            ',clc$abbreviation_entry, 11],
    ['JER                            ',clc$abbreviation_entry, 12],
    ['JN                             ',clc$alias_entry, 20],
    ['JOB_ABORT_DISPOSITION          ',clc$nominal_entry, 8],
    ['JOB_CLASS                      ',clc$nominal_entry, 9],
    ['JOB_DEFERRED_BY_USER           ',clc$nominal_entry, 10],
    ['JOB_DESTINATION_USAGE          ',clc$nominal_entry, 11],
    ['JOB_EXECUTION_RING             ',clc$nominal_entry, 12],
    ['JOB_NAME                       ',clc$alias_entry, 20],
    ['JOB_QUALIFIER                  ',clc$nominal_entry, 13],
    ['JOB_QUALIFIERS                 ',clc$alias_entry, 13],
    ['JOB_RECOVERY_DISPOSITION       ',clc$nominal_entry, 14],
    ['JQ                             ',clc$abbreviation_entry, 13],
    ['JRD                            ',clc$abbreviation_entry, 14],
    ['LA                             ',clc$abbreviation_entry, 4],
    ['LATEST_RUN_TIME                ',clc$nominal_entry, 15],
    ['LF                             ',clc$abbreviation_entry, 3],
    ['LOGIN_ACCOUNT                  ',clc$nominal_entry, 4],
    ['LOGIN_FAMILY                   ',clc$nominal_entry, 3],
    ['LOGIN_PROJECT                  ',clc$nominal_entry, 5],
    ['LOGIN_USER                     ',clc$nominal_entry, 1],
    ['LP                             ',clc$abbreviation_entry, 5],
    ['LRT                            ',clc$abbreviation_entry, 15],
    ['LU                             ',clc$abbreviation_entry, 1],
    ['MAGNETIC_TAPE_LIMIT            ',clc$nominal_entry, 16],
    ['MAXIMUM_WORKING_SET            ',clc$nominal_entry, 17],
    ['MAXWS                          ',clc$abbreviation_entry, 17],
    ['MTL                            ',clc$abbreviation_entry, 16],
    ['P                              ',clc$alias_entry, 5],
    ['PASSWORD                       ',clc$nominal_entry, 2],
    ['PROJECT                        ',clc$alias_entry, 5],
    ['PW                             ',clc$abbreviation_entry, 2],
    ['SL                             ',clc$abbreviation_entry, 18],
    ['SRU_LIMIT                      ',clc$nominal_entry, 18],
    ['U                              ',clc$alias_entry, 1],
    ['UI                             ',clc$abbreviation_entry, 19],
    ['UJN                            ',clc$abbreviation_entry, 20],
    ['USER                           ',clc$alias_entry, 1],
    ['USER_INFORMATION               ',clc$nominal_entry, 19],
    ['USER_JOB_NAME                  ',clc$nominal_entry, 20]],
    [
{ PARAMETER 1
    [32, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [41, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [30, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [31, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 6
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 8
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 10
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 11
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 254,
  clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 13
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 122,
  clc$optional_parameter, 0, 0],
{ PARAMETER 14
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 15
    [27, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 16
    [36, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 158,
  clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [37, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 18
    [45, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 19
    [50, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 20
    [51, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 5
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_cpu_time_limit, jmc$highest_cpu_time_limit, 10]]
    ],
{ PARAMETER 7
    [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [clc$past
  , clc$present, clc$future]]],
{ PARAMETER 8
    [[1, 0, clc$keyword_type], [4], [
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['RESTART                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 9
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 10
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 11
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    229, [[1, 0, clc$keyword_type], [6], [
      ['NTF                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['QTF                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['VE                             ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['VE_FAMILY                      ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['VE_LOCAL                       ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['VE_QTF                         ', clc$nominal_entry, clc$normal_usage_entry, 6]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 12
    [[1, 0, clc$integer_type], [osc$sj_ring_1, osc$user_ring_2, 10]],
{ PARAMETER 13
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, jmc$maximum_job_qualifiers, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 14
    [[1, 0, clc$keyword_type], [6], [
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CONTINUE                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['RESTART                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 15
    [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [clc$past
  , clc$present, clc$future]]],
{ PARAMETER 16
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_magnetic_tape_limit, jmc$highest_magnetic_tape_limit, 10]]
    ],
{ PARAMETER 17
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_working_set_size, jmc$highest_working_set_size, 10]]
    ],
{ PARAMETER 18
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_sru_limit, jmc$highest_sru_limit, 10]]
    ],
{ PARAMETER 19
    [[1, 0, clc$string_type], [0, jmc$user_information_size, FALSE]],
{ PARAMETER 20
    [[1, 0, clc$name_type], [1, osc$max_name_size]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$login_user = 1,
      p$password = 2,
      p$login_family = 3,
      p$login_account = 4,
      p$login_project = 5,
      p$cpu_time_limit = 6,
      p$earliest_run_time = 7,
      p$job_abort_disposition = 8,
      p$job_class = 9,
      p$job_deferred_by_user = 10,
      p$job_destination_usage = 11,
      p$job_execution_ring = 12,
      p$job_qualifier = 13,
      p$job_recovery_disposition = 14,
      p$latest_run_time = 15,
      p$magnetic_tape_limit = 16,
      p$maximum_working_set = 17,
      p$sru_limit = 18,
      p$user_information = 19,
      p$user_job_name = 20;

    VAR
      pvt: array [1 .. 20] of clt$parameter_value;

    VAR
      default_job_attributes_p: ^jmt$default_attribute_results,
      job_qualifier_index: 1 .. jmc$maximum_job_qualifiers,
      value: ^clt$data_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    job_system_label.login_user_identification.user := pvt [p$login_user].value^.name_value;

    IF pvt [p$password].specified THEN
      job_system_label.login_password := pvt [p$password].value^.name_value;
    IFEND;

    IF pvt [p$login_family].specified THEN
      job_system_label.login_user_identification.family := pvt [p$login_family].value^.name_value;
    IFEND;

    IF pvt [p$login_account].specified THEN
      job_system_label.login_account := pvt [p$login_account].value^.name_value;
    IFEND;

    IF pvt [p$login_project].specified THEN
      job_system_label.login_project := pvt [p$login_project].value^.name_value;
    IFEND;

    IF pvt [p$cpu_time_limit].specified THEN
      IF pvt [p$cpu_time_limit].value^.kind = clc$integer THEN
        job_system_label.limit_information.cpu_time_limit_requested :=
              pvt [p$cpu_time_limit].value^.integer_value.value;
      ELSEIF pvt [p$cpu_time_limit].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
        job_system_label.limit_information.cpu_time_limit_requested := jmc$system_default_cpu_time_lim;
      ELSE { IF pvt [p$cpu_time_limit].value^.keyword_value = 'UNLIMITED' THEN
        job_system_label.limit_information.cpu_time_limit_requested := jmc$unlimited_cpu_time_limit;
      IFEND;
      job_system_label.limit_information.cpu_time_limit_specified := TRUE;
    IFEND;

    IF pvt [p$earliest_run_time].specified THEN
      job_system_label.job_attributes.earliest_run_time.specified := TRUE;
      job_system_label.job_attributes.earliest_run_time.date_time :=
            pvt [p$earliest_run_time].value^.date_time_value.value;
    IFEND;

    IF pvt [p$job_abort_disposition].specified THEN
      IF pvt [p$job_abort_disposition].value^.keyword_value = 'RESTART' THEN
        job_system_label.job_abort_disposition := jmc$restart_on_abort;
      ELSE { IF pvt [p$job_abort_disposition].value^.keyword_value = 'TERMINATE' THEN
        job_system_label.job_abort_disposition := jmc$terminate_on_abort;
      IFEND;
    IFEND;

    IF pvt [p$job_class].specified THEN
      job_system_label.job_class_name := pvt [p$job_class].value^.name_value;
    IFEND;

    job_system_label.job_deferred_by_user := pvt [p$job_deferred_by_user].value^.boolean_value.value;

    IF pvt [p$job_destination_usage].specified THEN
      IF pvt [p$job_destination_usage].value^.kind = clc$name THEN
        job_system_label.job_destination_usage := pvt [p$job_destination_usage].value^.name_value;
      ELSE
        job_system_label.job_destination_usage := pvt [p$job_destination_usage].value^.keyword_value;
      IFEND;
    IFEND;

    IF pvt [p$job_execution_ring].specified THEN
      job_system_label.job_execution_ring := pvt [p$job_execution_ring].value^.integer_value.value;
    IFEND;

    IF pvt [p$job_qualifier].specified THEN
      IF pvt [p$job_qualifier].value^.kind = clc$keyword THEN
        IF pvt [p$job_qualifier].value^.keyword_value = 'NONE' THEN
          FOR job_qualifier_index := 1 TO jmc$maximum_job_qualifiers DO
            job_system_label.job_attributes.job_qualifier_list [job_qualifier_index] := osc$null_name;
          FOREND;
        ELSE { IF pvt [p$job_qualifier].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
          PUSH default_job_attributes_p: [1 .. 1];
          default_job_attributes_p^ [1].key := jmc$job_qualifier_list;
          default_job_attributes_p^ [1].job_qualifier_list :=
                ^job_system_label.job_attributes.job_qualifier_list;
          jmp$get_attribute_defaults (job_system_label.job_mode, default_job_attributes_p, status);
        IFEND;

      ELSE { IF pvt [p$job_qualifier].value^.kind = clc$list THEN
        value := pvt [p$job_qualifier].value;
        FOR job_qualifier_index := 1 TO jmc$maximum_job_qualifiers DO
          IF value <> NIL THEN
            job_system_label.job_attributes.job_qualifier_list [job_qualifier_index] :=
                  value^.element_value^.name_value;
            value := value^.link;
          ELSE
            job_system_label.job_attributes.job_qualifier_list [job_qualifier_index] := osc$null_name;
          IFEND;
        FOREND;
      IFEND;
    IFEND;

    IF pvt [p$job_recovery_disposition].specified THEN
      IF pvt [p$job_recovery_disposition].value^.keyword_value = 'CONTINUE' THEN
        job_system_label.job_recovery_disposition := jmc$continue_on_recovery;
      ELSEIF pvt [p$job_recovery_disposition].value^.keyword_value = 'RESTART' THEN
        job_system_label.job_recovery_disposition := jmc$restart_on_recovery;
      ELSE { IF pvt [p$job_recovery_disposition].value^.keyword_value = 'TERMINATE' THEN
        job_system_label.job_recovery_disposition := jmc$terminate_on_recovery;
      IFEND;
    IFEND;

    IF pvt [p$latest_run_time].specified THEN
      job_system_label.job_attributes.latest_run_time.specified := TRUE;
      job_system_label.job_attributes.latest_run_time.date_time :=
            pvt [p$latest_run_time].value^.date_time_value.value;
    IFEND;

    IF pvt [p$magnetic_tape_limit].specified THEN
      IF pvt [p$magnetic_tape_limit].value^.kind = clc$integer THEN
        job_system_label.limit_information.magnetic_tape_limit_requested := pvt [p$magnetic_tape_limit].
              value^.integer_value.value;
        job_system_label.limit_information.magnetic_tape_limit_specified := TRUE;
      ELSEIF pvt [p$magnetic_tape_limit].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
        job_system_label.limit_information.magnetic_tape_limit_requested := jmc$system_default_mag_tape_lim;
      ELSEIF pvt [p$magnetic_tape_limit].value^.keyword_value = 'UNLIMITED' THEN
        job_system_label.limit_information.magnetic_tape_limit_requested := jmc$unlimited_mag_tape_limit;
      ELSE { IF pvt [p$magnetic_tape_limit].value^.keyword_value = 'UNSPECIFIED' THEN
        job_system_label.limit_information.magnetic_tape_limit_requested := jmc$unspecified_mag_tape_limit;
      IFEND;
      job_system_label.limit_information.magnetic_tape_limit_specified := TRUE;
    IFEND;

    IF pvt [p$maximum_working_set].specified THEN
      IF pvt [p$maximum_working_set].value^.kind = clc$integer THEN
        job_system_label.limit_information.maximum_working_set_requested := pvt [p$maximum_working_set].
              value^.integer_value.value;
      ELSEIF pvt [p$maximum_working_set].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
        job_system_label.limit_information.maximum_working_set_requested := jmc$system_default_work_set_siz;
      ELSE { IF pvt [p$maximum_working_set].value^.keyword_value = 'UNLIMITED' THEN
        job_system_label.limit_information.maximum_working_set_requested := jmc$unlimited_working_set_size;
      IFEND;
      job_system_label.limit_information.maximum_working_set_specified := TRUE;
    IFEND;

    IF pvt [p$sru_limit].specified THEN
      IF pvt [p$sru_limit].value^.kind = clc$integer THEN
        job_system_label.limit_information.sru_limit_requested := pvt [p$sru_limit].value^.integer_value.
              value;
      ELSEIF pvt [p$sru_limit].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
        job_system_label.limit_information.sru_limit_requested := jmc$system_default_sru_limit;
      ELSE { IF pvt [p$sru_limit]va.ue^.keyword_value = 'UNLIMITED' THEN
        job_system_label.limit_information.sru_limit_requested := jmc$unlimited_sru_limit;
      IFEND;
      job_system_label.limit_information.sru_limit_specified := TRUE;
    IFEND;

    IF pvt [p$user_information].specified THEN
      job_system_label.job_attributes.user_information := pvt [p$user_information].value^.string_value^;
    IFEND;

    IF pvt [p$user_job_name].specified THEN
      job_system_label.user_job_name := pvt [p$user_job_name].value^.name_value;
    IFEND;

  PROCEND clp$get_login_parameters;
?? TITLE := 'clp$login', EJECT ??

  PROCEDURE [XDCL] clp$login
    (VAR status: ost$status);

?? NEWTITLE := 'process_prolog', EJECT ??

    PROCEDURE process_prolog
      (    prolog: string ( * );
           processing_phase: clt$processing_phase;
       VAR status: ost$status);

?? TITLE := 'login_break_handler', EJECT ??

      PROCEDURE login_break_handler
        (    condition: pmt$condition;
             ignore_condition_information: ^pmt$condition_information;
             ignore_save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);

        VAR
          termination_status: ost$status;

        CASE condition.selector OF
        = ifc$interactive_condition =
          IF condition.interactive_condition = ifc$terminate_break THEN
            terminate_break_detected := TRUE;
            #SPOIL (terminate_break_detected);
            EXIT process_prolog;
          IFEND;
        = pmc$block_exit_processing =
          IF terminate_break_detected THEN
            ifp$discard_suspended_output;
            osp$set_status_abnormal ('CL', cle$command_terminated, '', termination_status);
            osp$generate_output_message (termination_status, status);
          IFEND;
          RETURN;
        ELSE
          ;
        CASEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      PROCEND login_break_handler;
?? OLDTITLE, EJECT ??

      VAR
        file_attributes: array [1 .. 1] of amt$get_item,
        file_exists: boolean,
        ignore_contains_data: boolean,
        ignore_file_previously_opened: boolean,
        p_local_status: ^ost$status,
        terminate_break_detected: boolean;

      IF processing_phase = clc$user_prolog_phase THEN
        terminate_break_detected := FALSE;
        #SPOIL (terminate_break_detected);
        osp$establish_condition_handler (^login_break_handler, TRUE);
      IFEND;

      clp$set_processing_phase (processing_phase, status);
      clp$include_file (prolog, '', osc$null_name, status);
      IF (NOT status.normal) AND (status.condition = ame$file_not_known) THEN
        file_attributes [1].key := amc$null_attribute;
        PUSH p_local_status;
        amp$get_file_attributes (prolog, file_attributes, file_exists, ignore_file_previously_opened,
              ignore_contains_data, p_local_status^);
        IF (NOT p_local_status^.normal) OR (NOT file_exists) THEN
          status.condition := cle$login_prolog_file_missing;
          IF processing_phase = clc$user_prolog_phase THEN
            osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, p_local_status^);
          IFEND;
        IFEND;
      IFEND;

      IF processing_phase = clc$user_prolog_phase THEN
        osp$disestablish_cond_handler;
      IFEND;

    PROCEND process_prolog;
?? OLDTITLE ??
?? NEWTITLE := 'handle_prolog_error_status', EJECT ??

{ PURPOSE:
{   The purpose of this request is to report an error found in a prolog and determine if the login
{ process should continue.

    PROCEDURE handle_prolog_error_status
      (    prolog_name: ost$name_reference);

      VAR
        ignore_status: ost$status,
        local_status: ost$status;

      osp$get_status_severity (status.condition, severity, ignore_status);
      IF severity >= osc$error_status THEN
        IF (get_attribute_p^ [2].job_class = jmc$system_class_name) OR
              ((get_attribute_p^ [1].job_mode <> jmc$batch) AND (prolog_name <> system_prolog_name)) THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$login_error_in_prolog, prolog_name,
                local_status);
          osp$generate_message (local_status, ignore_status);
          osp$generate_message (status, ignore_status);
        ELSE
          osp$set_status_abnormal (jmc$job_management_id, jme$login_abort_in_prolog, prolog_name,
                local_status);
          osp$generate_message (local_status, ignore_status);
          pmp$abort (status);
        IFEND;
      IFEND;
      status.normal := TRUE;

    PROCEND handle_prolog_error_status;
?? OLDTITLE, EJECT ??

    CONST
      system_prolog_name = 'SYSTEM';

    VAR
      account_prolog: string (fsc$max_path_size),
      block_at_login: ^clt$block,
      get_attribute_p: ^jmt$job_attribute_results,
      ignore_status: ost$status,
      interrupt_capability: boolean,
      job_class_prolog: string (fsc$max_path_size),
      processing_phase: clt$processing_phase,
      project_prolog: string (fsc$max_path_size),
      severity: ost$status_severity,
      user_prolog: string (fsc$max_path_size);

    status.normal := TRUE;

    IF NOT jmp$system_job () THEN
      clp$find_current_block (block_at_login);

      PUSH get_attribute_p: [1 .. 2];
      get_attribute_p^ [1].key := jmc$job_mode;
      get_attribute_p^ [2].key := jmc$job_class;
      jmp$get_job_attributes (get_attribute_p, { ignore } status);

{ Begin account/project processing and log the login command.

      clp$log_edited_login_command (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      avp$display_pw_exp_warning (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Execute system prolog

      ?IF clc$compiling_for_test_harness THEN
        clp$set_processing_phase (clc$system_prolog_phase, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$include_line ('system_prolog', TRUE, osc$null_name, status);
      ?ELSE
        process_prolog (avc$system_prolog, clc$system_prolog_phase, status);
      ?IFEND
      IF NOT status.normal THEN
        handle_prolog_error_status (system_prolog_name);
      IFEND;

{ Execute job class prolog.

      jmp$get_job_class_prolog (job_class_prolog, status);
      IF status.normal THEN
        IF (job_class_prolog <> '') THEN
          process_prolog (job_class_prolog, clc$class_prolog_phase, status);
          IF NOT status.normal THEN
            handle_prolog_error_status ('JOB CLASS');
          IFEND;
        IFEND;
      IFEND;

{ Execute account prolog

      avp$get_capability (avc$interrupt_prologs, avc$user, interrupt_capability, status);
      IF NOT status.normal THEN
        IF (status.condition = ave$unknown_field) OR (status.condition = ave$field_was_deleted) THEN
          status.normal := TRUE;
          interrupt_capability := TRUE;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      IF interrupt_capability THEN
        jmp$enable_user_breaks;
      IFEND;

      ?IF NOT clc$compiling_for_test_harness THEN
        avp$get_file_value (avc$account_prolog, avc$account, account_prolog, status);
        IF status.normal THEN
          IF ((account_prolog (1, 5) <> '$NULL') AND (account_prolog (1, 12) <> '$LOCAL.$NULL')) THEN
            process_prolog (account_prolog, clc$account_prolog_phase, status);
          IFEND;
        ELSE
          IF status.condition = ave$account_info_not_found THEN
            status.normal := TRUE;
          IFEND;
        IFEND;
        IF NOT status.normal THEN
          handle_prolog_error_status ('ACCOUNT');
        IFEND;

{ Execute project prolog

        avp$get_file_value (avc$project_prolog, avc$project, project_prolog, status);
        IF status.normal THEN
          IF ((project_prolog (1, 5) <> '$NULL') AND (project_prolog (1, 12) <> '$LOCAL.$NULL')) THEN
            process_prolog (project_prolog, clc$project_prolog_phase, status);
          IFEND;
        ELSE
          IF status.condition = ave$project_info_not_found THEN
            status.normal := TRUE;
          IFEND;
        IFEND;
        IF NOT status.normal THEN
          handle_prolog_error_status ('PROJECT');
        IFEND;
      ?IFEND

      IF get_attribute_p^ [1].job_mode <> jmc$batch THEN
        osp$set_message_level (osc$brief_message_level, status);
      IFEND;

{ Execute user prolog

      avp$get_file_value (avc$user_prolog, avc$user, user_prolog, status);
      IF status.normal THEN
        IF ((user_prolog (1, 5) <> '$NULL') AND (user_prolog (1, 12) <> '$LOCAL.$NULL')) THEN
          process_prolog (user_prolog, clc$user_prolog_phase, status);
        IFEND;
      IFEND;
      IF NOT status.normal THEN
        handle_prolog_error_status ('USER');
      IFEND;
      IF jmv$initialized_as_disconnected THEN

{ Jobs in this state must not escape from the user prolog phase

        jmp$logout (ignore_status);
      IFEND;

      IF NOT interrupt_capability THEN
        jmp$enable_user_breaks;
      IFEND;

    IFEND; {if not executing within system job

    clp$set_processing_phase (clc$command_phase, ignore_status);

  PROCEND clp$login;
?? TITLE := 'clp$logout_command', EJECT ??

  PROCEDURE [XDCL] clp$logout_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$logout) logout

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [87, 10, 29, 15, 5, 52, 981], clc$command, 0, 0, 0, 0, 0, 0, 0, 'OSM$LOGOUT']];

?? POP ??


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$logout (status);

  PROCEND clp$logout_command;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] clp$execute_job_epilog', EJECT ??
*copyc clh$execute_job_epilog

  PROCEDURE [XDCL] clp$execute_job_epilog;

    VAR
      block_at_logout: ^clt$block,
      epilog_file: string (fsc$max_path_size),
      file: clt$command_list_entry_file,
      ignore_status: ost$status,
      severity: ost$status_severity,
      status: ost$status;

    ?IF clc$compiling_for_test_harness THEN

      VAR
        system_command_library: [STATIC, READ, oss$job_paged_literal] string (27) :=
              ':$LOCAL.OSF$COMMAND_LIBRARY';

    ?ELSE

      VAR
        system_command_library: [STATIC, READ, oss$job_paged_literal] string (36) :=
              ':$SYSTEM.$SYSTEM.OSF$COMMAND_LIBRARY';

    ?IFEND

?? NEWTITLE := 'process_epilog', EJECT ??

    PROCEDURE process_epilog
      (VAR status: ost$status);

      VAR
        terminate_break_detected: boolean;

?? NEWTITLE := 'interactive_terminate_handler', ??

      PROCEDURE interactive_terminate_handler
        (    condition: pmt$condition;
             ignore_condition_information: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);


        CASE condition.selector OF

        = pmc$block_exit_processing =
          IF terminate_break_detected THEN
            ifp$discard_suspended_output;
            clp$put_job_output (' Epilog terminated', ignore_status);
          IFEND;
          RETURN;

        = ifc$interactive_condition =
          IF condition.interactive_condition = ifc$terminate_break THEN
            terminate_break_detected := TRUE;
            EXIT process_epilog;
          IFEND;

        ELSE
          ;
        CASEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      PROCEND interactive_terminate_handler;
?? OLDTITLE, EJECT ??

      terminate_break_detected := FALSE;
      #SPOIL (terminate_break_detected);
      osp$establish_condition_handler (^interactive_terminate_handler, TRUE);
      IF clv$processing_phase > clc$user_epilog_phase THEN
        prepare_for_epilog;
      IFEND;
      clp$include_file (pmv$epilog_file, '', osc$null_name, status);
      osp$disestablish_cond_handler;

    PROCEND process_epilog;
?? OLDTITLE ??
?? NEWTITLE := 'prepare_for_epilog', EJECT ??

    PROCEDURE prepare_for_epilog;

{ The job command search mode must be reset to global by ring 3 code before calling
{ this procedure.

      VAR
        context: ^ost$ecp_exception_context;

      PUSH context;

      REPEAT
        clp$delete_all_from_cmnd_list (status);
        IF NOT status.normal THEN
          context^ := osv$initial_exception_context;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
      IF (NOT status.normal) AND (NOT osp$file_access_condition (status)) THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
      IFEND;

      file.kind := clc$command_list_entry_$system;
      REPEAT
        clp$add_file_to_command_list (file, FALSE, status);
        IF NOT status.normal THEN
          context^ := osv$initial_exception_context;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
      IF (NOT status.normal) AND (NOT osp$file_access_condition (status)) THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
      IFEND;

      file.kind := clc$command_list_entry_path;
      file.path := ^system_command_library;
      REPEAT
        clp$establish_sys_command_lib (file.path, status);
        IF NOT status.normal THEN
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_file_reference;
          context^.file.file_reference := file.path;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
      IF (NOT status.normal) AND (NOT osp$file_access_condition (status)) THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
      IFEND;

      IF clv$processing_phase < clc$class_epilog_phase THEN
        clp$delete_all_targets (clv$standard_files [clc$sf_echo_file].path_handle_name, ignore_status);
      ELSE
        clp$delete_all_file_connections;
      IFEND;

      clp$free_all_handlers

    PROCEND prepare_for_epilog;
?? OLDTITLE, EJECT ??

    CASE clv$processing_phase OF

    = clc$user_epilog_phase =

{ Execute user epilog

      jmp$enable_exit_processing;
      process_epilog (status);
      IF NOT status.normal THEN
        IF status.condition = ame$file_not_known THEN
          avp$get_file_value (avc$user_epilog, avc$user, epilog_file, status);
          osp$set_status_condition (cle$epilog_file_missing, status);
          osp$append_status_file (osc$status_parameter_delimiter, epilog_file, status);
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
        ELSE
          osp$get_status_severity (status.condition, severity, ignore_status);
          IF severity >= osc$error_status THEN
            clp$put_job_command_response (' Following error in USER epilog:', ignore_status);
            osp$generate_message (status, ignore_status);
          IFEND;
        IFEND;
        status.normal := TRUE;
      IFEND;
      jmp$inhibit_exit_processing;

    = clc$project_epilog_phase =

{ Execute project epilog

      process_epilog (status);
      IF NOT status.normal THEN
        IF status.condition <> ame$file_not_known THEN
          osp$get_status_severity (status.condition, severity, ignore_status);
          IF severity >= osc$error_status THEN
            clp$put_job_command_response (' Following error in PROJECT epilog:', ignore_status);
            osp$generate_message (status, ignore_status);
          IFEND;
        IFEND;
        status.normal := TRUE;
      IFEND;

    = clc$account_epilog_phase =

{ Execute account epilog

      process_epilog (status);
      IF NOT status.normal THEN
        IF status.condition <> ame$file_not_known THEN
          osp$get_status_severity (status.condition, severity, ignore_status);
          IF severity >= osc$error_status THEN
            clp$put_job_command_response (' Following error in ACCOUNT epilog:', ignore_status);
            osp$generate_message (status, ignore_status);
          IFEND;
        IFEND;
        status.normal := TRUE;
      IFEND;

    = clc$class_epilog_phase =

{ Execute job class epilog.

      process_epilog (status);
      IF NOT status.normal THEN
        IF status.condition <> ame$file_not_known THEN
          osp$get_status_severity (status.condition, severity, ignore_status);
          IF severity >= osc$error_status THEN
            clp$put_job_command_response (' Following error in JOB CLASS epilog:', ignore_status);
            osp$generate_message (status, ignore_status);
          IFEND;
        IFEND;
        status.normal := TRUE;
      IFEND;

    = clc$system_epilog_phase =

      ?IF NOT clc$compiling_for_test_harness THEN

{ Execute system epilog

        epilog_file := avc$system_epilog;
        process_epilog (status);
        IF NOT status.normal THEN
          IF status.condition <> ame$file_not_known THEN
            osp$get_status_severity (status.condition, severity, ignore_status);
            IF severity >= osc$error_status THEN
              clp$put_job_command_response (' Following error in SYSTEM epilog:', ignore_status);
              osp$generate_message (status, ignore_status);
            IFEND;
          IFEND;
          status.normal := TRUE;
        IFEND;
      ?IFEND

    ELSE
      ;
    CASEND;

  PROCEND clp$execute_job_epilog;

MODEND clm$system_access_commands;
*DECK DECK=CLM$SYSTEM_COMMANDS EXPAND=TRUE
table clv$system_commands type=command section_name=oss$job_paged_literal scope=xdcl ..
      m=clm$system_commands
command (activate_job_statistic         ,activate_job_statistics,  actjs) sfp$_activate_job_statistic xref
command (activate_job_template          ,actjt) osp$activate_job_template xref hidden
command (attach_file                    ,attf) clp$_attach_file xref l=manual
command (attach_job                     ,attj) ifp$_attach_job xref
command (change_backup_label_type       ,chablt) pup$change_backup_flt_cmd xref
command (change_catalog_access)          clp$_change_catalog_access xref hidden
command (change_catalog_contents        ,change_catalog_content, chacc) pfp$change_catalog_contents_cmd xref
command (change_catalog_entry           ,chace) clp$_change_catalog_entry xref l=manual
command (change_command_search_mode     ,chacsm) clp$_change_command_search_mode xref
command (change_connection_attributes   ,change_connection_attribute, change_term_conn_attributes , ..
               change_term_conn_attribute, chatca, chaca) ..
               ifp$_change_connection_attribut xref
command (change_default_file_attributes ,chadfa) clp$_change_default_file_attbs xref
command (change_file_attributes         ,change_file_attribute,  chafa) clp$_change_file_attributes xref
command (change_input_attribute         ,change_input_attributes, chaia) jmp$_change_input_attribute xref
command (change_interaction_information ,change_interaction_style, chaii, chais) osp$_change_interaction_informa xref
command (change_job_attribute           ,change_job_attributes, chaja) jmp$_change_job_attribute xref
command (change_job_limit               ,chajl) sfp$_change_job_limit xref
command (change_link_attributes         ,change_link_attribute, chala) rhp$_change_link_attributes xref l=manual
command (change_login_password          ,set_password, setpw, chalpw) avp$change_password_command xref l=manual
command (change_message_level           ,set_message_mode, setmm, chaml) clp$_change_message_level xref
command (change_natural_language        ,chanl) clp$_change_natural_language xref
command (change_output_attribute        ,change_output_attributes, chaoa) jmp$_change_output_attribute xref
command (change_scl_options             ,change_scl_option, chasclo, chaso) clp$_change_scl_options xref
command (change_system_command_library  ,chascl) clp$_change_system_command_libr xref advanced_usage
command (change_tape_debug_mode         ) clp$_change_tape_debug_mode xref hidden
command (change_tape_label_attribute    ,change_tape_label_attributes ,chatla) clp$change_tape_label_attr_cmd xref
command (change_term_conn_defaults      ,change_term_conn_default, chatcd) ifp$_change_term_conn_defaults xref
command (change_terminal_attributes     ,change_terminal_attribute, set_terminal_attributes, ..
               set_terminal_attribute, setta, chata) ifp$_change_terminal_attributes xref
command (change_unseen_mail_action      ,chauma) clp$_change_unseen_mail_action xref
command (change_utility_attributes      ,change_utility_attribute, chaua) clp$_change_utility_attributes xref
command (change_working_catalog         ,set_working_catalog, setwc, chawc) clp$_change_working_catalog xref
command (collect_text                   ,colt) clp$_collect_text xref
command (compare_file                   ,compare_files,  comf) clp$_compare_file xref
command (copy_file                      ,copf) clp$_copy_file xref
command (copy_output_file               ,copof) jmp$_copy_output_file xref
command (create_catalog                 ,crec) clp$_create_catalog xref
command (create_catalog_permit          ,crecp) clp$_create_catalog_permit xref
command (create_command_list_entry      ,create_command_list_entries, crecle) ..
                                           clp$_create_command_list_entry xref
command (create_default_variable        ,credv) clp$_create_default_variable xref
command (create_file                    ,cref) clp$_create_file xref l=manual
command (create_file_connection         ,crefc) clp$_create_file_connection xref
command (create_file_permit             ,crefp) clp$_create_file_permit xref
command (create_file_variable           ,crefv) clp$_create_file_variable xref
command (create_remote_validation       ,crerv) nfp$_create_remote_validation xref l=manual
command (create_telnet_connection       ,telnet, cretc) ifp$_create_telnet_connection xref l=manual
command (create_variable                ,create_variables,  crev) clp$_create_variable xref hidden
command (deactivate_job_statistic       ,deactivate_job_statistics,  deajs) sfp$_deactivate_job_statistic xref
command (deactivate_job_template        ,deajt) osp$deactivate_job_template xref hidden
command (define_initial_application     ,defia) clp$_define_initial_application xref
command (define_primary_task            ,defpt) clp$_define_primary_task xref
command (delete_catalog                 ,delc) clp$_delete_catalog xref
command (delete_catalog_permit          ,delcp) clp$_delete_catalog_permit xref
command (delete_command_list_entry      ,delete_command_list_entries, delcle) ..
                                           clp$_delete_command_list_entry xref
command (delete_file                    ,delete_files,  delf) clp$_delete_file xref l=manual
command (delete_file_connection         ,delfc) clp$_delete_file_connection xref
command (delete_file_permit             ,delfp) clp$_delete_file_permit xref
command (delete_remote_validation       ,delrv) nfp$_delete_remote_validation xref
command (delete_variable                ,delete_variables,  delv) clp$_delete_variable xref
command (detach_file                    ,detach_files,  detf) clp$_detach_file xref
command (detach_job                     ,detj) ifp$_detach_job xref
command (display_active_job_statistic   ,display_active_job_statistics,  disajs) sfp$_display_active_job_statist xref
command (display_active_system_statistic,display_active_system_stats,  disass) sfp$_display_active_system_stat xref
command (display_active_tasks           ,disat) pmp$_display_active_tasks xref
command (display_backup_label_type      ,disblt) pup$display_backup_flt_cmd xref
command (display_bam_tables             ,disbt) amp$display_bam_tables xref hidden
command (display_catalog                ,disc) clp$_display_catalog xref
command (display_catalog_entry          ,disce) clp$_display_catalog_entry xref
command (display_command_information    ,display_command_parameters,  display_command_parameter,  discp,  disci) ..
                                           clp$_display_command_informatio xref
command (display_command_list           ,discl) clp$_display_command_list xref
command (display_command_list_entry     ,discle) clp$_display_command_list_entry xref
command (display_command_stack          ,discs) clp$display_command_env_command xref hidden
command (display_connection_attributes  ,display_connection_attribute, display_term_conn_attributes, ..
               display_term_conn_attribute, distca, disca) ..
               ifp$_display_connection_attribu xref
command (display_family                 ,display_families) avp$display_family_command xref
command (display_file                   ,disf) clp$_display_file xref
command (display_file_attributes        ,display_file_attribute,  disfa) clp$_display_file_attributes xref
command (display_file_connections       ,display_file_connection,  disfc) clp$_display_file_connections xref
command (display_function_information   ,disfi) clp$_display_function_informati xref
command (display_input_attribute        ,display_input_attributes, disia) jmp$_display_input_attribute xref
command (display_interaction_information,disii) osp$_display_interaction_inform xref
command (display_job_attribute          ,display_job_attributes, disja) jmp$_display_job_attribute xref
command (display_job_attribute_default  ,display_job_attribute_defaults, disjad) jmp$_display_job_attribute_def xref
command (display_job_data               ,disjd) clp$display_job_data_command xref hidden
command (display_job_history            ,disjh) clp$display_job_history_command xref
command (display_job_limit              ,display_job_limits,  disjl) sfp$_display_job_limit xref
command (display_job_status             ,display_input_status, disis ,disjs) jmp$_display_job_status xref
command (display_keypoint_environment   ,diske) clp$display_keypoint_env xref hidden
command (display_keypoint_file          ,diskf) clp$display_keypoint_file xref hidden
command (display_link_attributes        ,display_link_attribute, disla) rhp$display_link_attributes xref
command (display_log                    ,disl) lgp$_display_log xref
command display_log_attributes          lgp$_display_log_attributes xref hidden
command (display_message                ,dism) clp$_display_message xref
command (display_multiprocessing_options,display_multiprocessing_option,  dismo) clp$display_multipro_opt_cmd xref
command (display_output_attribute       ,display_output_attributes, disoa) jmp$_display_output_attribute xref
command (display_output_history         ,disoh) clp$display_output_history_cmd xref
command (display_output_status          ,disos, display_print_status, disps) jmp$_display_output_status xref
command (display_program_attributes     ,display_program_attribute,  dispa) pmp$_display_program_attributes xref
command (display_remote_validation      ,disrv) nfp$display_remote_validation xref
command (display_scl_options            ,display_scl_option, dissclo, disso) clp$_display_scl_options xref
command (display_system_data            ,dissd) clp$display_system_data_command xref hidden
command (display_task_status            ,dists) clp$_display_task_status xref
command (display_tape_label_attributes  ,display_tape_label_attribute, distla) clp$display_tape_label_attr_cmd xref
command (display_term_conn_defaults     ,display_term_conn_default,  distcd) ifp$_display_term_conn_defaults xref
command (display_terminal_attributes    ,display_terminal_attribute,  dista) ifp$_display_terminal_attribute xref
command (display_value                  ,display_values,  disv) clp$_display_value xref
command (display_variable_list          ,disvl) clp$_display_variable_list xref
command (display_working_catalog        ,diswc) clp$_display_working_catalog xref
command (edit_file                      ,edif) esp$edit_file load
command (emit_keypoint                  ,emik) clp$issue_keypoint xref hidden
command (execute_command                ,exec) clp$_execute_command xref
command (execute_task                   ,exet) pmp$_execute_task xref
command (flush_catalog                  ,flush_catalogs, fluc) clp$_flush_catalog xref hidden
command (get_file                       ,getf) rhp$_get_file xref l=manual
command (get_line                       ,get_lines,  accept_line,  accept_lines,  accl,  getl) clp$_get_line xref
command (help                           ,h) clp$_help xref
command (include_command                ,incc) clp$_include_command xref
command (include_file                   ,incf) clp$_include_file xref
command (include_line                   ,incl) clp$_include_line xref
command (issue_string_as_keypoint       ,isssak) clp$issue_string_as_keypoint xref hidden
command login                           clp$login_command xref l=manual
command logout                          clp$logout_command xref
command (manage_memory                  ,manm)  mmp$manage_memory xref
command (print_file                     ,print_files,  prif) jmp$_print_file xref
command (process_storage                ,pros) pfp$process_storage xref hidden
command (put_line                       ,put_lines,  putl) clp$_put_line xref
command (release_keypoint_environment   ,relke) clp$release_keypoint_env xref hidden
command (release_resource               ,release_resources,  relr) clp$release_resource_command xref
command (release_spi_environment        ,relse) clp$release_spi_environment xref hidden
command (replace_file                   ,repf) rhp$_replace_file xref l=manual
command (request_magnetic_tape          ,reqmt) clp$request_tape_command xref l=manual
command (request_null                   ,reqn) clp$request_null_command xref hidden
command (request_operator_action        ,reqoa) clp$request_op_action_command xref
command (request_terminal               ,reqt) ifp$_request_terminal xref
command (reserve_keypoint_environment   ,reske) clp$reserve_keypoint_env xref hidden
command (reserve_resource               ,reserve_resources,  resr) clp$reserve_resource_command xref
command (reserve_spi_environment        ,resse) clp$reserve_spi_environment xref hidden
command (rewind_file                    ,rewind_files,  rewf) clp$rewind_command xref
command (send_operator_message          ,senom) ofp$send_operator_message_cmd xref
command (set_command_list               ,setcl) clp$_set_command_list xref hidden
command (set_cycle_damage_conditions    ,set_cycle_damage_condition) pfp$set_cycle_damage_cmd xref hidden
command (set_debug_list                 ,setdl) clp$set_debug_list_command xref
command (set_debug_ring                 ,setdr) clp$set_debug_ring_command xref
command (set_file_attributes            ,set_file_attribute,  setfa) clp$_set_file_attributes xref
command (set_job_debug_ring             ,setjdr) osp$set_job_debug_ring_cmd xref hidden
command (set_job_limit                  ,set_job_limits,  setjl) sfp$_set_job_limit xref
command (set_job_recovery_test          ,setjrt) osp$set_job_recovery_test xref hidden
command (set_link_attributes            ,set_link_attribute,  setla) rhp$_set_link_attributes xref l=manual
command (set_multiprocessing_options    ,set_multiprocessing_option,  setmo) clp$set_multipro_opt_cmd xref
command (set_program_attributes         ,set_program_attribute,  setpa) pmp$_set_program_attributes xref
command (set_sense_switch               ,set_sense_switches,  setss) jmp$_set_sense_switch xref
command (set_spy_identifier             ,setsi) clp$set_spy_identifier xref hidden
command (skip_tape_mark                 ,skip_tape_marks,  skitm) clp$skip_command xref
command (start_keypoint_collection      ,stakc) clp$start_keypoint_collection xref hidden
command (start_spi_collection           ,stasc) clp$start_spi_collection xref hidden
command (stop_keypoint_collection       ,stokc) clp$stop_keypoint_collection xref hidden
command (stop_spi_collection            ,stosc) clp$stop_spi_collection xref hidden
command (submit_detached_job            ) jmp$_submit_detached xref hidden
command (submit_job                     ,subj) jmp$_submit_job xref
command (submit_multi_record_job        ,submrj) nfp$_submit_multi_record_job xref
command system_prolog                   clp$system_prolog_command xref hidden
command (terminate_job                  ,terminate_jobs, terminate_input, teri, terj) ..
                                                 jmp$_terminate_job xref
command (terminate_output               ,terminate_outputs, tero, terminate_print, terminate_prints, terp) ..
                                                 jmp$_terminate_output xref
command (terminate_task                 ,tert) pmp$_terminate_task xref
command (test_keypoint_collection       ,teskc) clp$test_keypoint_collection xref hidden
command (update_perm_file_space_limit   ,updpfsl) pfp$_update_perm_file_space_lim xref hidden
command (wait                           ) clp$_wait xref
command (wait_for_system_idle           , waifsi) jmp$wait_system_idle_comnd xref
"
" NOTE:
"   The following command ideally belongs in the control_statements table in
"   module clm$control_statements.  It is defined in this table to allow
"   its name to be used for a subcommand of generate_command_table and
"   UTILITY/UTILITYEND.
"
command function                        clp$_function_statement xref hidden
tablend
*DECK DECK=CLM$SYSTEM_FILE_IDENTIFIERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Storage Module for IDentifiers of Special Files' ??
MODULE clm$system_file_identifiers;

{
{ PURPOSE:
{   This module provides for storage and retrieval of file_identifiers for "special files".
{   A "special file" is one that, for certain operations, is (implicitly) opened the first time it is used
{   in a task, has that instance of opened used for subsequent accesses in taht task, and is closed as part
{   of task termination.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc clc$compiling_for_test_harness
*copyc clc$standard_file_names
*IF NOT $true(osv$unix)
*copyc cle$user_already_logged_in
*ELSE
*copyc amc_standard_files
*copyc amv$nil_file_identifier
*IFEND
*copyc clt$standard_file
*copyc clt$standard_files
*copyc clt$system_file_identifiers
*IF NOT $true(osv$unix)
*copyc fst$path_handle_name
*copyc jmv$job_attributes
*copyc osc$timesharing_terminal_file
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc oss$task_shared
*IFEND
?? POP ??
*IF NOT $true(osv$unix)
*copyc clp$convert_str_to_path_handle
*copyc osp$set_status_condition
*copyc pmp$find_prog_options_and_libs
*IFEND
?? TITLE := 'IDentifiers for Special Files', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    standard_file_names: [STATIC, READ, oss$job_paged_literal] array [clt$standard_files] of
          amt$local_file_name := [clc$job_log, clc$null_file, clc$job_input, clc$standard_input,
          clc$job_output, clc$standard_output, clc$error_output, clc$listing_output, clc$echoed_commands,
          clc$job_command_response, clc$job_command_input, osc$timesharing_terminal_file, osc$display_a,
          osc$display_b, osc$null_name];
*ELSE
    standard_file_names: [STATIC, READ] array [clt$standard_files] of
          amt$local_file_name := [clc$null_file, clc$job_input, clc$standard_input,
          clc$job_output, clc$standard_output, clc$error_output,
          clc$job_command_input, osc$null_name];
*IFEND

  VAR
*IF NOT $true(osv$unix)
    clv$system_file_identifiers: [XDCL, oss$task_private] clt$system_file_identifiers :=
          [[FALSE], [FALSE], [FALSE], [FALSE]];
*ELSE
    clv$system_file_identifiers: [XDCL] clt$system_file_identifiers :=
          [[FALSE], [FALSE]];
*IFEND

  VAR
*IF NOT $true(osv$unix)
    clv$standard_files: [XDCL, #GATE, oss$task_shared] array
          [clt$standard_files] of clt$standard_file := [[osc$null_name, [0, 0, [FALSE]]],
          [osc$null_name, [0, 0, [FALSE]]], [osc$null_name, [0, 0, [FALSE]]],
          [osc$null_name, [0, 0, [FALSE]]], [osc$null_name, [0, 0, [FALSE]]],
          [osc$null_name, [0, 0, [FALSE]]], [osc$null_name, [0, 0, [FALSE]]],
          [osc$null_name, [0, 0, [FALSE]]], [osc$null_name, [0, 0, [FALSE]]],
          [osc$null_name, [0, 0, [FALSE]]], [osc$null_name, [0, 0, [FALSE]]],
          [osc$null_name, [0, 0, [FALSE]]], [osc$null_name, [0, 0, [FALSE]]],
          [osc$null_name, [0, 0, [FALSE]]], [osc$null_name, [0, 0, [FALSE]]]];
*ELSE
    clv$standard_files: [XDCL, #GATE] array
          [clt$standard_files] of clt$standard_file := [[amc_null, -1],
          [amc_stdin, amc_stdin_fid], [amc_stdin, amc_stdin_fid],
          [amc_stdout, amc_stdout_fid], [amc_stdout, amc_stdout_fid],
          [amc_stderr, amc_stderr_fid], [amc_stdin, amc_stdin_fid],
          [' ', -1]];
*IFEND

*IF NOT $true(osv$unix)
  VAR
    clv$local_catalog_handle_name: [XDCL, #GATE, oss$task_shared] fst$path_handle_name := osc$null_name;

  VAR
    clv$already_logged_in: [STATIC, oss$task_shared] boolean := FALSE;

  CONST
    osc$display_a = 'DISPLAY_A                      ',
    osc$display_b = 'DISPLAY_B                      ';

?? TITLE := 'clp$login_command_ring_3', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$login_command_ring_3
    (VAR status: ost$status);


    status.normal := TRUE;
    IF clv$already_logged_in OR (NOT jmv$job_attributes.login_command_supplied) THEN
      osp$set_status_condition (cle$user_already_logged_in, status);
    ELSE
      clv$already_logged_in := TRUE;
    IFEND;

  PROCEND clp$login_command_ring_3;
?? TITLE := 'clp$store_path_handle_names', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$store_std_path_handle_names
    (    operator_job: boolean;
         first_time: boolean;
     VAR status: ost$status);

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      file: clt$standard_files,
      path_handle_name: fst$path_handle_name,
      prog_options_and_libraries: ^pmt$prog_options_and_libraries;


    status.normal := TRUE;
    pmp$find_prog_options_and_libs (prog_options_and_libraries);

    IF first_time THEN

    /initialize_files/
      FOR file := clc$sf_job_log_file TO clc$sf_display_b_file DO
        IF ((file = clc$sf_display_a_file) OR (file = clc$sf_display_b_file)) AND NOT operator_job THEN
          CYCLE /initialize_files/;
        IFEND;
        IF file = clc$sf_command_file THEN
          CYCLE /initialize_files/;
        IFEND;
        clp$convert_str_to_path_handle (standard_file_names [file], FALSE, TRUE, FALSE, path_handle_name,
              evaluated_file_reference, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clv$standard_files [file].path_handle_name := path_handle_name;
        clv$standard_files [file].path_handle := evaluated_file_reference.path_handle_info.path_handle;
      FOREND /initialize_files/;

      ?IF clc$compiling_for_test_harness THEN

        clp$convert_str_to_path_handle (':$LOCAL', FALSE, TRUE, FALSE, path_handle_name,
              evaluated_file_reference, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clv$local_catalog_handle_name := path_handle_name;

      ?IFEND

      prog_options_and_libraries^.default_options^.debug_input :=
            clv$standard_files [clc$sf_command_file].path_handle_name;
      prog_options_and_libraries^.default_options^.debug_output :=
            clv$standard_files [clc$sf_standard_output_file].path_handle_name;
      prog_options_and_libraries^.default_options^.abort_file :=
            clv$standard_files [clc$sf_null_file].path_handle_name;

    ELSE {NOT first_time}
      file := clc$sf_command_file;
      clp$convert_str_to_path_handle (standard_file_names [file], FALSE, TRUE, FALSE, path_handle_name,
            evaluated_file_reference, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clv$standard_files [file].path_handle_name := path_handle_name;
      clv$standard_files [file].path_handle := evaluated_file_reference.path_handle_info.path_handle;

      prog_options_and_libraries^.default_options^.debug_input :=
            clv$standard_files [clc$sf_command_file].path_handle_name;
    IFEND;

  PROCEND clp$store_std_path_handle_names;
*IFEND
?? TITLE := 'clp$fetch_system_file_id', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$fetch_system_file_id
    (    file_name: amt$local_file_name;
     VAR file_id: amt$file_identifier;
     VAR file_id_defined: boolean);


*IF NOT $true(osv$unix)
    IF file_name = clc$echoed_commands THEN
      file_id_defined := clv$system_file_identifiers.echoed_commands.id_defined;
      IF file_id_defined THEN
        file_id := clv$system_file_identifiers.echoed_commands.id;
      IFEND;
    ELSEIF file_name = clc$job_command_response THEN
      file_id_defined := clv$system_file_identifiers.job_command_response.id_defined;
      IF file_id_defined THEN
        file_id := clv$system_file_identifiers.job_command_response.id;
      IFEND;
    ELSEIF file_name = clc$error_output THEN
*ELSE
    IF file_name = clc$error_output THEN
*IFEND
      file_id_defined := clv$system_file_identifiers.error_output.id_defined;
      IF file_id_defined THEN
        file_id := clv$system_file_identifiers.error_output.id;
      IFEND;
    ELSEIF file_name = clc$job_output THEN
      file_id_defined := clv$system_file_identifiers.job_output.id_defined;
      IF file_id_defined THEN
        file_id := clv$system_file_identifiers.job_output.id;
      IFEND;
    ELSE
      file_id_defined := FALSE;
    IFEND;

  PROCEND clp$fetch_system_file_id;
?? TITLE := 'clp$store_system_file_id', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$store_system_file_id
    (    file_name: amt$local_file_name;
         file_id: amt$file_identifier);


*IF NOT $true(osv$unix)
    IF file_name = clc$echoed_commands THEN
      clv$system_file_identifiers.echoed_commands.id_defined := TRUE;
      clv$system_file_identifiers.echoed_commands.id := file_id;
    ELSEIF file_name = clc$job_command_response THEN
      clv$system_file_identifiers.job_command_response.id_defined := TRUE;
      clv$system_file_identifiers.job_command_response.id := file_id;
    ELSEIF file_name = clc$error_output THEN
*ELSE
    IF file_name = clc$error_output THEN
*IFEND
      clv$system_file_identifiers.error_output.id_defined := TRUE;
      clv$system_file_identifiers.error_output.id := file_id;
    ELSEIF file_name = clc$job_output THEN
      clv$system_file_identifiers.job_output.id_defined := TRUE;
      clv$system_file_identifiers.job_output.id := file_id;
*IF $true(osv$unix)
    ELSEIF file_name = clc$null_file THEN
      clv$standard_files [clc$sf_null_file].file_id := file_id;
*IFEND
    IFEND;

  PROCEND clp$store_system_file_id;

MODEND clm$system_file_identifiers;
*DECK DECK=CLM$SYSTEM_FUNCTIONS EXPAND=TRUE
table clv$system_functions type=function section_name=oss$job_paged_literal scope=xdcl ..
      m=clm$system_functions
function $access_mode                   clp$$access_mode xref hidden
function $add                           clp$$add xref
function $application                   clp$$application xref
function $apply                         clp$$apply xref
function $array                         clp$$array xref
function $build_list                    clp$$build_list xref
function $build_result                  clp$$build_result xref
function $catalog_contents              clp$$catalog_contents xref
function $char                          clp$$char xref
function $combine                       clp$$combine xref
function $command                       clp$$command xref
function $command_of_caller             clp$$command_of_caller xref
function $command_list                  clp$$command_list xref
function $command_list_entry            clp$$command_list_entry xref
function $command_search_mode           clp$$command_search_mode xref
function $command_source                clp$$command_source xref hidden
function $connection_attributes         ifp$$connection_attributes xref
function ($condition_name               ,$condition) clp$$condition_name xref hidden
function $cpu_time                      pmp$$cpu_time xref
function $data_name                     clp$$data_name xref
function $date                          clp$$date xref
function $date_time                     clp$$date_time xref
function $date_time_string              clp$$date_time_string xref
function $day                           clp$$day xref
function $difference                    clp$$difference xref
function $element_type                  clp$$element_type xref
function $evaluate                      clp$$evaluate xref
function $family                        clp$$family xref
function $field                         clp$$field xref
function $field_list                    clp$$field_list xref
function $file                          clp$$file xref hidden
function $file_attributes               clp$$file_attributes xref
function $file_cycles                   clp$$file_cycles xref
function $first                         clp$$first xref
function $fname                         clp$$fname xref
function $format_value                  clp$$format_value xref
function $generic_type                  clp$$generic_type xref
function $if                            clp$$if xref
function $indefinite                    clp$$indefinite xref
function $infinite                      clp$$infinite xref
function $infinity                      clp$$infinity xref
function $integer                       clp$$integer xref
function $integer_string                clp$$integer_string xref
function $interaction_information       osp$$interaction_information xref
function $interaction_style             osp$$interaction_style xref hidden
function $intersection                  clp$$intersection xref
function $job                           jmp$$job xref
function ($job_default                  ,$job_defaults) jmp$$job_default xref
function $job_input                     jmp$$input xref
function $job_limit                     sfp$$job_limit xref
function $job_output                    jmp$$output xref
function $job_status                    jmp$$job_status xref
function $job_termination_status        clp$$job_termination_status xref
function $job_validation                avp$$job_validation xref
function $join                          clp$$join xref
function $justify                       clp$$justify xref
function $keyword                       clp$$keyword xref
function $last                          clp$$last xref
function $list_of                       clp$$list_of xref
function $local                         clp$$local xref
function $local_date_time               clp$$local_date_time xref
function ($lower_bound                  ,$lowerbound) clp$$lower_bound xref
function ($lower_value                  ,$lowervalue) clp$$lower_value xref
function $mainframe                     clp$$mainframe xref
function $match                         clp$$match xref
function $max                           clp$$max xref
function $max_headroom                  clp$$max_headroom xref hidden
function $max_integer                   clp$$max_integer xref
function $max_list                      clp$$max_list xref
function $max_name                      clp$$max_name xref
function $max_real                      clp$$max_real xref
function $max_value_sets                clp$$max_value_sets xref hidden
function $max_values                    clp$$max_values xref hidden
function $max_string                    clp$$max_string xref
function $max_string_size               clp$$max_string_size xref
function $min                           clp$$min xref
function $min_integer                   clp$$min_integer xref
function $min_real                      clp$$min_real xref
function $min_string_size               clp$$min_string_size xref
function $mod                           clp$$mod xref
function $name                          clp$$name xref
function $nil                           clp$$nil xref
function $not                           clp$$not xref
function $now                           clp$$now xref
function $output_status                 jmp$$output_status xref
function $parameter                     clp$$parameter xref hidden
function $parameter_list                clp$$parameter_list xref hidden
function $parameter_value               clp$$parameter_value load "special cased"
function $path                          clp$$path xref
function $path_elements                 clp$$path_elements xref
function $processor                     clp$$processor xref
function $program                       pmp$$program xref
function $program_name                  clp$$program_name xref
function $queue                         clp$$queue xref
function $quote                         clp$$quote xref
function $range                         clp$$range xref hidden
function $range_of                      clp$$range_of xref
function $range_specified               clp$$range_specified xref
function $real                          clp$$real xref
function $real_string                   clp$$real_string xref
function $record                        clp$$record xref
function $remote_validation             nfp$$remote_validation xref
function $rest                          clp$$rest xref
function $reverse                       clp$$reverse xref
function $ring                          clp$$ring xref
function $scan_any                      clp$$scan_any xref
function ($scan_not_any                 ,$scan_notany) clp$$scan_not_any xref
function $scan_string                   clp$$scan_string xref
function $scl_options                   clp$$scl_options xref
function $security_option               avp$$security_option xref
function $select                        clp$$select xref
function ($select_strings               ,$select_string) clp$$select_strings xref
function ($select_wild_card_names       ,$select_wild_card_name,$select_name,$select_names) ..
      clp$$select_wild_card_names xref
function ($select_wild_card_files       ,$select_wild_card_file,$select_file,$select_files) ..
      clp$$select_wild_card_files xref
function ($select_wild_card_program_names,$select_wild_card_program_name) ..
      clp$$select_wild_card_program_n xref
function ($select_wild_card_strings     ,$select_wild_card_string) clp$$select_wild_card_strings xref
function $set_count                     clp$$set_count xref hidden
function $size                          clp$$size xref
function $sort                          clp$$sort xref
function $sort_fields                   clp$$sort_fields xref
function $source                        clp$$source xref
function $source_of_caller              clp$$source_of_caller xref
function $specified                     clp$$specified xref
function $sp_any                        clp$$sp_any xref
function $sp_balance                    clp$$sp_balance xref
function $sp_capture                    clp$$sp_capture xref
function $sp_count                      clp$$sp_count xref
function $sp_defer                      clp$$sp_defer xref
function $sp_fail                       clp$$sp_fail xref
function $sp_fence                      clp$$sp_fence xref
function $sp_left                       clp$$sp_left xref
function $sp_index                      clp$$sp_index xref
function $sp_not_any                    clp$$sp_not_any xref
function $sp_null                       clp$$sp_null xref
function $sp_or                         clp$$sp_or xref
function $sp_repeat                     clp$$sp_repeat xref
function $sp_right                      clp$$sp_right xref
function $sp_stop                       clp$$sp_stop xref
function $sp_string                     clp$$sp_string xref
function $sp_succeed                    clp$$sp_succeed xref
function $sp_test                       clp$$sp_test xref
function $sp_upto                       clp$$sp_upto xref
function ($sp_wild_card                 ,$sp_wc) clp$$sp_wild_card xref
function $statistic_code                clp$$statistic_code xref
function $statistic_code_string         clp$$statistic_code_string xref
function $status                        clp$$status xref
function $status_code                   clp$$status_code xref
function $status_code_name              clp$$status_code_name xref
function $status_code_string            clp$$status_code_string xref
function $status_message                clp$$status_message xref
function $status_severity               clp$$status_severity xref
function $string                        clp$$string xref
function $strlen                        clp$$strlen xref hidden
function $strrep                        clp$$strrep xref hidden
function $sublist                       clp$$sublist xref
function $subset                        clp$$subset xref
function ($substring                    ,$substr) clp$$substring xref
function $sum                           clp$$sum xref
function $system                        clp$$system xref
function $tape_label_attributes         clp$$tape_label_attributes xref
function $task_complete                 clp$$task_complete xref hidden
function $task_status                   clp$$task_status xref
function $term_conn_defaults            ifp$$term_conn_defaults xref
function $terminal_attributes           ifp$$terminal_attributes xref
function $terminal_model                ifp$$terminal_model xref
function $time                          clp$$time xref
function $time_zone                     clp$$time_zone xref
function ($time_zone_identifier         ,$time_zone_id) clp$$time_zone_identifier xref
function $translate                     clp$$translate xref
function $trim                          clp$$trim xref
function $true                          clp$$true xref hidden
function $type                          clp$$type xref
function $union                         clp$$union xref
function $unique                        clp$$unique xref
function $universal_date_time           clp$$universal_date_time xref
function $unseen_mail_action            clp$$unseen_mail_action xref
function $unspecified_value             clp$$unspecified_value xref
function $up                            clp$$up xref
function ($upper_bound                  ,$upperbound) clp$$upper_bound xref
function ($upper_value                  ,$uppervalue) clp$$upper_value xref
function $user                          clp$$user xref
function $utility                       clp$$utility xref
function $validation_level              avp$$validation_level xref
function $value                         clp$$value load "special cased" hidden
function $value_count                   clp$$value_count xref hidden
function $value_kind                    clp$$value_kind xref hidden
function $variable                      clp$$variable xref
function $vname                         clp$$vname load "special cased"
function $vsn_list                      clp$$vsn_list xref
function ($wild_card_files              ,$wild_card_file,$wcf) clp$$wild_card_files xref
function ($working_catalog              ,$catalog,$wc) clp$$working_catalog xref
tablend
*DECK DECK=CLM$SYSTEM_FUNCTIONS_V0 EXPAND=TRUE
table clv$system_functions_v0 type=function section_name=oss$job_paged_literal scope=xdcl ..
      m=clm$system_functions_v0 version=0
function $clock                         clp$$clock xref hidden
function $condition_code                clp$$condition_code xref hidden
function $default_family                clp$$default_family xref hidden
function $job_counts                    jmp$$job_counts xref hidden
function $job_template_name             clp$$job_template_name xref hidden
function $message_level                 clp$$message_level xref
function $natural_language              clp$$natural_language xref
function $namve_active                  nap$$namve_active xref hidden
function $namve_configuration_activated nap$$namve_config_activated xref hidden
function $ord                           clp$$ord xref
function $previous_status               clp$$previous_status xref
function $scl_test_harness_active       clp$$scl_test_harness_active xref hidden
function $severity                      clp$$severity xref hidden
function $task_name                     clp$$task_name xref
tablend
*DECK DECK=CLM$SYSTEM_LOGGING_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : System Logging control Commands' ??
MODULE clm$system_logging_commands;

{
{ PURPOSE:
{   This module contains the processors for the commands that control whether
{   commands from user jobs are recorded in the system log.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc clp$set_secure_logging_active
*copyc clp$set_system_logging_active

?? TITLE := 'clp$activate_system_logging', EJECT ??

  PROCEDURE [XDCL,#GATE] clp$activate_system_logging
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT activate_sys_log_pdt (
{   STATUS)

?? PUSH (LISTEXT := ON) ??

    VAR
      activate_sys_log_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^activate_sys_log_pdt_names, ^activate_sys_log_pdt_params];

    VAR
      activate_sys_log_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      activate_sys_log_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
            clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    clp$scan_parameter_list (parameter_list, activate_sys_log_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$set_system_logging_active (TRUE, status);

  PROCEND clp$activate_system_logging;
?? TITLE := 'clp$deactivate_system_logging', EJECT ??

  PROCEDURE [XDCL,#GATE] clp$deactivate_system_logging
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT deactivate_sys_log_pdt (
{   STATUS)

?? PUSH (LISTEXT := ON) ??

    VAR
      deactivate_sys_log_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^deactivate_sys_log_pdt_names, ^deactivate_sys_log_pdt_params];

    VAR
      deactivate_sys_log_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      deactivate_sys_log_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
            clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    clp$scan_parameter_list (parameter_list, deactivate_sys_log_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$set_system_logging_active (FALSE, status);

  PROCEND clp$deactivate_system_logging;
?? TITLE := 'clp$change_secure_logging', EJECT ??

  PROCEDURE [XDCL] clp$change_secure_logging
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PDT change_secure_log_pdt (
{     secure_logging, sl: boolean = false
{     STATUS)

?? PUSH (LISTEXT := ON) ??

    VAR
      change_secure_log_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^change_secure_log_pdt_names, ^change_secure_log_pdt_params];

    VAR
      change_secure_log_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['SECURE_LOGGING', 1], ['SL', 1], ['STATUS', 2]];

    VAR
      change_secure_log_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ SECURE_LOGGING SL }
      [[clc$optional_with_default, ^change_secure_log_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$boolean_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      change_secure_log_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';

?? POP ??

    VAR
      value: clt$value;

    clp$scan_parameter_list (parameter_list, change_secure_log_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_value ('SECURE_LOGGING', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    clp$set_secure_logging_active (value.bool.value, status);

  PROCEND clp$change_secure_logging;

MODEND clm$system_logging_commands;
*DECK DECK=CLM$SYSTEM_PROLOG_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'System_Prolog_Command_Module' ??
MODULE clm$system_prolog_command;

{
{ Purpose:
{    This module contains the system prolog contents to be
{    executed as a command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$compiling_for_test_harness
*copyc cle$ecc_miscellaneous
*copyc clt$parameter_list
*copyc fst$path
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
?? POP ??
*copyc clp$add_file_to_command_list
*copyc clp$convert_cyc_ref_to_cyc_sel
*copyc clp$convert_str_to_path_handle
*copyc clp$create_environment_variable
*copyc clp$establish_sys_command_lib
*copyc clp$trimmed_string_size
*copyc fsp$convert_fs_structure_to_pf
*copyc jmp$system_job
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pfp$attach
*copyc pmp$change_debug_library_list
*copyc pmp$change_job_library_list


  TYPE
    prolog_files = (cyf$run_time_library, flf$library, cbf$4dd_library, dbf$library, mlf$library, smf$library,
          lsf$library,
          aaf$4dd_library, aaf$44d_library, bcf$library, paf$library, osf$system_library, tuf$library,
          tuf$terminal_definitions, ftf$library, adf$library, c2f$library, c2f$libc, c2f$libm,
          c2f$run_time_library, c2f$libmalloc, vcf$library, vcf$libc, vcf$libm, fdf$library,
          xwf$xterm_library),

    debug_list_prolog_files = (debug_bound_product, unused_debug_library);

  VAR
    local_catalog: [STATIC, READ, oss$job_paged_literal] string (7) := ':$LOCAL',
    system_command_library: [STATIC, READ, oss$job_paged_literal] string (36)  :=
          ':$SYSTEM.$SYSTEM.OSF$COMMAND_LIBRARY',
    local_library_list: [STATIC, READ, oss$job_paged_literal] array [prolog_files] of
          ost$name := ['CYF$RUN_TIME_LIBRARY', 'FLF$LIBRARY         ', 'CBF$4DD_LIBRARY     ',
          'DBF$LIBRARY         ', 'MLF$LIBRARY         ', 'SMF$LIBRARY         ', 'LSF$LIBRARY         ',
          'AAF$4DD_LIBRARY     ',
          'AAF$44D_LIBRARY     ', 'BCF$LIBRARY         ', 'PAF$LIBRARY         ', 'OSF$SYSTEM_LIBRARY  ',
          'TUF$LIBRARY         ', 'TUF$TERMINAL_DEFINITIONS', 'FTF$LIBRARY     ', 'ADF$LIBRARY         ',
          'C2F$LIBRARY         ', 'C2F$LIBC            ', 'C2F$LIBM            ', 'C2F$RUN_TIME_LIBRARY',
          'C2F$LIBMALLOC       ', 'VCF$LIBRARY         ', 'VCF$LIBC            ', 'VCF$LIBM            ',
          'FDF$LIBRARY         ', 'XWF$XTERM_LIBRARY   '],
    library_list: [STATIC, READ, oss$job_paged_literal] array [prolog_files] of string (46) :=
          [':$SYSTEM.$SYSTEM.CYBIL.CYF$RUN_TIME_LIBRARY   ', ':$SYSTEM.$SYSTEM.FORTRAN.FLF$LIBRARY          ',
          ':$SYSTEM.$SYSTEM.COBOL.CBF$4DD_LIBRARY        ', ':$SYSTEM.$SYSTEM.DEBUG.DBF$LIBRARY            ',
          ':$SYSTEM.$SYSTEM.COMMON.MLF$LIBRARY           ', ':$SYSTEM.$SYSTEM.SORT.SMF$LIBRARY             ',
          ':$SYSTEM.$SYSTEM.LANGUAGE_SERVICES.LSF$LIBRARY',
          ':$SYSTEM.$SYSTEM.AAM.AAF$4DD_LIBRARY          ', ':$SYSTEM.$SYSTEM.AAM.AAF$44D_LIBRARY          ',
          ':$SYSTEM.$SYSTEM.BASIC.BCF$LIBRARY            ', ':$SYSTEM.$SYSTEM.PASCAL.PAF$LIBRARY           ',
          ':$SYSTEM.$SYSTEM.OSF$SYSTEM_LIBRARY           ', ':$SYSTEM.$SYSTEM.TDU.BOUND_PRODUCT            ',
          ':$SYSTEM.$SYSTEM.TDU.TERMINAL_DEFINITIONS     ', ':$SYSTEM.$SYSTEM.FORTRAN_VERSION_2.FTF$LIBRARY',
          ':$SYSTEM.$SYSTEM.ADA.ADF$LIBRARY              ', ':$SYSTEM.$SYSTEM.C.VCF$LIBRARY                ',
          ':$SYSTEM.$SYSTEM.CV2.C2F$LIBC                 ', ':$SYSTEM.$SYSTEM.CV2.C2F$LIBM                 ',
          ':$SYSTEM.$SYSTEM.CV2.C2F$RUN_TIME_LIBRARY     ', ':$SYSTEM.$SYSTEM.CV2.C2F$LIBMALLOC            ',
          ':$SYSTEM.$SYSTEM.C.VCF$LIBRARY                ', ':$SYSTEM.$SYSTEM.C.LIBC                       ',
          ':$SYSTEM.$SYSTEM.C.LIBM                       ', ':$SYSTEM.$SYSTEM.FDF$LIBRARY                  ',
          ':$SYSTEM.$SYSTEM.X11R4.BIN.XTERM              '],
    debug_library_list: [STATIC, READ, oss$job_paged_literal] array [debug_list_prolog_files] of
          string (36) := [':$SYSTEM.$SYSTEM.DEBUG.BOUND_PRODUCT', ''];

?? TITLE := 'clp$system_prolog_command', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$system_prolog_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{The functions performed by this command are now invoked automatically
{by clp$system_prolog_phase_1 and clp$system_prolog_phase_2, which are
{called by clp$job_boot and clp$interpret_commands.

    VAR
      executing_within_system_job: boolean;


    status.normal := TRUE;
    executing_within_system_job := jmp$system_job ();

    IF executing_within_system_job THEN
      clp$system_prolog_phase_1 (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$system_prolog_phase_2 (status);
    IFEND;

  PROCEND clp$system_prolog_command;
?? TITLE := 'clp$system_prolog_phase_1', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$system_prolog_phase_1
    (VAR status: ost$status);

{ TYPE
{   file = file

    VAR
      type_specification: [STATIC, READ, cls$declaration_section] record
        header: clt$type_specification_header,
      recend := [[1, 0, clc$file_type]];

{ TYPEND

    VAR
      file_var_init_value_p: ^clt$data_value,
      ignore_status: ost$status,
      index: prolog_files;


    ?IF NOT clc$compiling_for_test_harness THEN

      PUSH file_var_init_value_p;
      file_var_init_value_p^.kind := clc$file;

    /process_system_file_list/
      FOR index := LOWERVALUE (prolog_files) TO UPPERVALUE (prolog_files) DO
        file_var_init_value_p^.file_value := ^library_list [index];
        clp$create_environment_variable (local_library_list [index], clc$job_scope, clc$read_write,
              clc$immediate_evaluation, #SEQ (type_specification), file_var_init_value_p, status);
        IF NOT status.normal THEN
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
          CYCLE /process_system_file_list/;
        IFEND;
      FOREND /process_system_file_list/;
    ?IFEND;

  PROCEND clp$system_prolog_phase_1;
?? TITLE := 'clp$system_prolog_phase_2', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$system_prolog_phase_2
    (VAR status: ost$status);

    VAR
      add_libraries: ^pmt$object_library_list,
      caller_id: ost$caller_identifier,
      command_list_file: clt$command_list_entry_file,
      delete_libraries: ^pmt$object_library_list,
      executing_within_system_job: boolean,
      ignore_status: ost$status,
      usage_selections: pft$usage_selections,
      share_selections: pft$share_selections,
      evaluated_file_reference: fst$evaluated_file_reference,
      cycle_selector: clt$cycle_selector,
      path_handle_name: fst$path_handle_name,
      pf_path: ^pft$path,
      local_library: fst$path;


    executing_within_system_job := jmp$system_job ();

    ?IF NOT clc$compiling_for_test_harness THEN
      #CALLER_ID (caller_id);

      PUSH add_libraries: [1 .. 1];
      clp$convert_str_to_path_handle (library_list [aaf$4dd_library], FALSE, TRUE, TRUE, path_handle_name,
            evaluated_file_reference, status);
      IF NOT status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
      IFEND;
      add_libraries^ [1] := path_handle_name;
      delete_libraries := NIL;
      pmp$change_job_library_list (delete_libraries, add_libraries, status);
      IF NOT status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
      IFEND;

      IF NOT executing_within_system_job THEN
        clp$convert_str_to_path_handle (debug_library_list [debug_bound_product], FALSE, FALSE, TRUE,
              path_handle_name, evaluated_file_reference, status);
        IF NOT status.normal THEN
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
        IFEND;
        add_libraries^ [1] := path_handle_name;
        delete_libraries := NIL;
        pmp$change_debug_library_list (delete_libraries, add_libraries, status);
        IF NOT status.normal THEN
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
        IFEND;

        command_list_file.kind := clc$command_list_entry_$system;
        command_list_file.path := ^system_command_library;
        clp$establish_sys_command_lib (command_list_file.path, status);
        IF NOT status.normal THEN
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
        IFEND;
      IFEND;
    ?IFEND;

    IF NOT executing_within_system_job THEN
      command_list_file.kind := clc$command_list_entry_path;
      command_list_file.path := ^local_catalog;
      clp$add_file_to_command_list (command_list_file, FALSE, status);
      IF NOT status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
      IFEND;
    IFEND;

  PROCEND clp$system_prolog_phase_2;

MODEND clm$system_prolog_command;
*DECK DECK=CLM$SYSTEM_TASK_MAINTENANCE EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Command Language : Command Processors for System Task Commands' ??
MODULE clm$system_task_maintenance;

{ PURPOSE:
{   This module contains the command processors for the commands that define, delete, activate and
{   deactivate system tasks.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc osp$activate_system_task
*copyc osp$deactivate_system_task
*copyc osp$define_system_task
*copyc osp$delete_system_task
*copyc osp$set_status_abnormal
?? OLDTITLE, NEWTITLE := '[XDCL, #GATE] clp$activate_system_task', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$activate_system_task (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{   PROCEDURE (osm$actst) activate_system_task, activate_system_tasks, actst (
{     task_name, task_names, tn: list of name = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 31, 14, 4, 44, 512],
    clc$command, 4, 2, 1, 0, 0, 0, 2, 'OSM$ACTST'], [
    ['STATUS                         ',clc$nominal_entry, 2],
    ['TASK_NAME                      ',clc$nominal_entry, 1],
    ['TASK_NAMES                     ',clc$alias_entry, 1],
    ['TN                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 21, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$task_name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      node: ^clt$data_value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    node := pvt [p$task_name].value;
    WHILE node <> NIL DO
      osp$activate_system_task (node^.element_value^.name_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      node := node^.link;
    WHILEND;

  PROCEND clp$activate_system_task;
?? OLDTITLE, NEWTITLE := '[XDCL, #GATE] clp$deactivate_system_task', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$deactivate_system_task (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{   PROCEDURE (osm$deast) deactivate_system_task, deactivate_system_tasks, deast (
{     task_name, task_names, tn: list of name = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 31, 14, 4, 51, 678],
    clc$command, 4, 2, 1, 0, 0, 0, 2, 'OSM$DEAST'], [
    ['STATUS                         ',clc$nominal_entry, 2],
    ['TASK_NAME                      ',clc$nominal_entry, 1],
    ['TASK_NAMES                     ',clc$alias_entry, 1],
    ['TN                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 21, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$task_name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      node: ^clt$data_value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    node := pvt [p$task_name].value;
    WHILE node <> NIL DO
      osp$deactivate_system_task (node^.element_value^.name_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      node := node^.link;
    WHILEND;

  PROCEND clp$deactivate_system_task;
?? OLDTITLE, NEWTITLE := '[XDCL, #GATE] clp$define_system_task', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$define_system_task (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{   PROCEDURE (osm$defst) define_system_task, defst (
{     name, n: name = $required
{     starting_procedure, sp: program_name = $optional
{     automatic_restart, ar: boolean = true
{     deactivate_task_option, dto:
{       key
{         (terminate, t)
{         (voluntary, v)
{         (prohibited, p)
{       keyend = terminate
{     idle_task_option, ito:
{       key
{         (terminate, t)
{         (voluntary, v)
{         (ignore, i)
{       keyend = terminate
{     restart_after_idle, rai: boolean = true
{     spy_identifier, si: integer 0..63 = 0
{     parameters, parameter, p: string = $optional
{     files, file, f: list of file = $optional
{     libraries, library, l:
{       list of any of
{         key
{           osf$task_services_library
{         keyend
{         file
{       anyend = $optional
{     modules, module, m: list of program_name = $optional
{     load_map, lm: file = $optional
{     load_map_options, load_map_option, lmo:
{       any of
{         key
{           all
{           none
{         keyend
{         list of key
{           (segment, s)
{           (block, b)
{           (entry_point, ep)
{           (cross_reference, cr)
{         keyend
{       anyend = none
{     preset_value, pv:
{       key
{         (zero, z)
{         (floating_point_indefinite, fpi)
{         (infinity, i)
{         (alternate_ones, ao)
{        keyend = $optional
{     termination_error_level, tel:
{       key
{         (warning, w)
{         (error, e)
{         (fatal, f)
{       keyend = warning
{     stack_size, ss: integer 1 .. osc$max_segment_length = $optional
{     debug_input, di: file = $optional
{     debug_output, do: file = $optional
{     abort_file, af: file = $optional
{     debug_mode, dm: boolean = false
{     execution_ring, er: integer 3 .. 15 = 11
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 48] of clt$pdt_parameter_name,
      parameters: array [1 .. 22] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (9),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (9),
      recend,
      type6: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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,
          recend,
        recend,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type12: record
        header: clt$type_specification_header,
      recend,
      type13: 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 .. 2] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 8] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (4),
      recend,
      type14: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
      recend,
      type15: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type17: record
        header: clt$type_specification_header,
      recend,
      type18: record
        header: clt$type_specification_header,
      recend,
      type19: record
        header: clt$type_specification_header,
      recend,
      type20: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type21: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (2),
      recend,
      type22: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 2, 9, 34, 16, 334],
    clc$command, 48, 22, 1, 0, 0, 0, 22, 'OSM$DEFST'], [
    ['ABORT_FILE                     ',clc$nominal_entry, 19],
    ['AF                             ',clc$abbreviation_entry, 19],
    ['AR                             ',clc$abbreviation_entry, 3],
    ['AUTOMATIC_RESTART              ',clc$nominal_entry, 3],
    ['DEACTIVATE_TASK_OPTION         ',clc$nominal_entry, 4],
    ['DEBUG_INPUT                    ',clc$nominal_entry, 17],
    ['DEBUG_MODE                     ',clc$nominal_entry, 20],
    ['DEBUG_OUTPUT                   ',clc$nominal_entry, 18],
    ['DI                             ',clc$abbreviation_entry, 17],
    ['DM                             ',clc$abbreviation_entry, 20],
    ['DO                             ',clc$abbreviation_entry, 18],
    ['DTO                            ',clc$abbreviation_entry, 4],
    ['ER                             ',clc$abbreviation_entry, 21],
    ['EXECUTION_RING                 ',clc$nominal_entry, 21],
    ['F                              ',clc$abbreviation_entry, 9],
    ['FILE                           ',clc$alias_entry, 9],
    ['FILES                          ',clc$nominal_entry, 9],
    ['IDLE_TASK_OPTION               ',clc$nominal_entry, 5],
    ['ITO                            ',clc$abbreviation_entry, 5],
    ['L                              ',clc$abbreviation_entry, 10],
    ['LIBRARIES                      ',clc$nominal_entry, 10],
    ['LIBRARY                        ',clc$alias_entry, 10],
    ['LM                             ',clc$abbreviation_entry, 12],
    ['LMO                            ',clc$abbreviation_entry, 13],
    ['LOAD_MAP                       ',clc$nominal_entry, 12],
    ['LOAD_MAP_OPTION                ',clc$alias_entry, 13],
    ['LOAD_MAP_OPTIONS               ',clc$nominal_entry, 13],
    ['M                              ',clc$abbreviation_entry, 11],
    ['MODULE                         ',clc$alias_entry, 11],
    ['MODULES                        ',clc$nominal_entry, 11],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['P                              ',clc$abbreviation_entry, 8],
    ['PARAMETER                      ',clc$alias_entry, 8],
    ['PARAMETERS                     ',clc$nominal_entry, 8],
    ['PRESET_VALUE                   ',clc$nominal_entry, 14],
    ['PV                             ',clc$abbreviation_entry, 14],
    ['RAI                            ',clc$abbreviation_entry, 6],
    ['RESTART_AFTER_IDLE             ',clc$nominal_entry, 6],
    ['SI                             ',clc$abbreviation_entry, 7],
    ['SP                             ',clc$abbreviation_entry, 2],
    ['SPY_IDENTIFIER                 ',clc$nominal_entry, 7],
    ['SS                             ',clc$abbreviation_entry, 16],
    ['STACK_SIZE                     ',clc$nominal_entry, 16],
    ['STARTING_PROCEDURE             ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 22],
    ['TEL                            ',clc$abbreviation_entry, 15],
    ['TERMINATION_ERROR_LEVEL        ',clc$nominal_entry, 15]],
    [
{ PARAMETER 1
    [32, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [45, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 9],
{ PARAMETER 5
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 9],
{ PARAMETER 6
    [39, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 7
    [42, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 8
    [35, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 9
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$optional_parameter,
  0, 0],
{ PARAMETER 10
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 83, clc$optional_parameter,
  0, 0],
{ PARAMETER 11
    [30, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$optional_parameter,
  0, 0],
{ PARAMETER 12
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 13
    [27, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 420,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 14
    [36, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_parameter, 0, 0],
{ PARAMETER 15
    [48, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 16
    [44, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 17
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 18
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 19
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 20
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 21
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 22
    [46, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$program_name_type]],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [6], [
    ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['PROHIBITED                     ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['V                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['VOLUNTARY                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'terminate'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [6], [
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['IGNORE                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['V                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['VOLUNTARY                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'terminate'],
{ PARAMETER 6
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 7
    [[1, 0, clc$integer_type], [0, 63, 10],
    '0'],
{ PARAMETER 8
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 9
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 10
    [[1, 0, clc$list_type], [67, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['OSF$TASK_SERVICES_LIBRARY      ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      3, [[1, 0, clc$file_type]]
      ]
    ],
{ PARAMETER 11
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$program_name_type]]
    ],
{ PARAMETER 12
    [[1, 0, clc$file_type]],
{ PARAMETER 13
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    319, [[1, 0, clc$list_type], [303, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [8], [
        ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['BLOCK                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['CR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['CROSS_REFERENCE                ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['SEGMENT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ]
      ]
    ,
    'none'],
{ PARAMETER 14
    [[1, 0, clc$keyword_type], [8], [
    ['ALTERNATE_ONES                 ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['AO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['FLOATING_POINT_INDEFINITE      ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['FPI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['INFINITY                       ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['Z                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ZERO                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 15
    [[1, 0, clc$keyword_type], [6], [
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['ERROR                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FATAL                          ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['WARNING                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'warning'],
{ PARAMETER 16
    [[1, 0, clc$integer_type], [1, osc$max_segment_length, 10]],
{ PARAMETER 17
    [[1, 0, clc$file_type]],
{ PARAMETER 18
    [[1, 0, clc$file_type]],
{ PARAMETER 19
    [[1, 0, clc$file_type]],
{ PARAMETER 20
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 21
    [[1, 0, clc$integer_type], [3, 15, 10],
    '11'],
{ PARAMETER 22
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$starting_procedure = 2,
      p$automatic_restart = 3,
      p$deactivate_task_option = 4,
      p$idle_task_option = 5,
      p$restart_after_idle = 6,
      p$spy_identifier = 7,
      p$parameters = 8,
      p$files = 9,
      p$libraries = 10,
      p$modules = 11,
      p$load_map = 12,
      p$load_map_options = 13,
      p$preset_value = 14,
      p$termination_error_level = 15,
      p$stack_size = 16,
      p$debug_input = 17,
      p$debug_output = 18,
      p$abort_file = 19,
      p$debug_mode = 20,
      p$execution_ring = 21,
      p$status = 22;

    VAR
      pvt: array [1 .. 22] of clt$parameter_value;

    CONST
      terminate = 'TERMINATE',
      voluntary = 'VOLUNTARY';

    VAR
      automatic_restart: boolean,
      deactivate_task_option: ost$termination_type,
      execution_ring: ost$valid_ring,
      i: clt$list_size,
      idle_task_option: ost$termination_type,
      libraries: ^llt$object_library_list,
      library_count: clt$list_size,
      module_count: clt$list_size,
      modules: ^pmt$module_list,
      node: ^clt$data_value,
      object_file_count: clt$list_size,
      object_files: ^llt$object_file_list,
      parameter_string: ^clt$parameter_list_contents,
      parameters: ^clt$parameter_list,
      program_attributes: ^llt$program_attributes,
      program_description: ^llt$program_description,
      restart_after_idle: boolean,
      spy_identifier: pmt$spy_identifier,
      task_name: ost$name;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    object_file_count := clp$count_list_elements (pvt [p$files].value);
    library_count := clp$count_list_elements (pvt [p$libraries].value);
    module_count := clp$count_list_elements (pvt [p$modules].value);
    PUSH program_description: [[REP (#SIZE (llt$program_attributes) + (object_file_count + library_count) *
          #SIZE (clt$path_name) + module_count * #SIZE (pmt$program_name)) OF cell]];
    RESET program_description;
    NEXT program_attributes IN program_description;
    program_attributes^.contents := $pmt$prog_description_contents [];

    task_name := pvt [p$name].value^.program_name_value;

    IF pvt [p$starting_procedure].specified THEN
      program_attributes^.contents := program_attributes^.contents +
            $pmt$prog_description_contents [pmc$starting_proc_specified];
      program_attributes^.starting_procedure := pvt [p$starting_procedure].value^.program_name_value;
    IFEND;

    automatic_restart := pvt [p$automatic_restart].value^.boolean_value.value;

    IF pvt [p$deactivate_task_option].value^.keyword_value = terminate THEN
      deactivate_task_option := osc$tt_terminate;
    ELSEIF pvt [p$deactivate_task_option].value^.keyword_value = voluntary THEN
      deactivate_task_option := osc$tt_voluntary;
    ELSE { pvt [p$deactivate_task_option].value^.keyword_value = 'PROHIBITED' }
      deactivate_task_option := osc$tt_ignore_or_prohibited;
    IFEND;

    IF pvt [p$idle_task_option].value^.keyword_value = terminate THEN
      idle_task_option := osc$tt_terminate;
    ELSEIF pvt [p$idle_task_option].value^.keyword_value = voluntary THEN
      idle_task_option := osc$tt_voluntary;
    ELSE { pvt [p$idle_task_option].value^.keyword_value = 'IGNORE' }
      idle_task_option := osc$tt_ignore_or_prohibited;
    IFEND;

    restart_after_idle := pvt [p$restart_after_idle].value^.boolean_value.value;

    spy_identifier := pvt [p$spy_identifier].value^.integer_value.value;

    IF pvt [p$parameters].specified THEN
      PUSH parameter_string: [#SIZE (pvt [p$parameters].value^.string_value^)];
      parameter_string^.size := #SIZE (pvt [p$parameters].value^.string_value^);
      parameter_string^.text := pvt [p$parameters].value^.string_value^
    ELSE
      PUSH parameter_string: [0];
      parameter_string^.size := 0;
      parameter_string^.text := '';
    IFEND;
    parameters := #SEQ (parameter_string^);

    IF object_file_count > 0 THEN
      program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
            [pmc$object_file_list_specified];
      program_attributes^.number_of_object_files := object_file_count;
      NEXT object_files: [1 .. object_file_count] IN program_description;
      node := pvt [p$files].value;
      FOR i := 1 TO object_file_count DO
        object_files^ [i] := node^.element_value^.file_value^;
        node := node^.link;
      FOREND;
    IFEND;

    IF module_count > 0 THEN
      program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
            [pmc$module_list_specified];
      program_attributes^.number_of_modules := module_count;
      NEXT modules: [1 .. module_count] IN program_description;
      node := pvt [p$modules].value;
      FOR i := 1 TO module_count DO
        modules^ [i] := node^.element_value^.program_name_value;
        node := node^.link;
      FOREND;
    IFEND;

    IF library_count > 0 THEN
      program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
            [pmc$library_list_specified];
      program_attributes^.number_of_libraries := library_count;
      NEXT libraries: [1 .. library_count] IN program_description;
      node := pvt [p$libraries].value;
      FOR i := 1 TO library_count DO
        IF node^.element_value^.kind = clc$keyword THEN
          libraries^ [i] := node^.element_value^.keyword_value;
        ELSE
          libraries^ [i] := node^.element_value^.file_value^;
        IFEND;
        node := node^.link;
      FOREND;
    IFEND;

    IF pvt [p$load_map].specified THEN
      program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
            [pmc$load_map_file_specified];
      program_attributes^.load_map_file := pvt [p$load_map].value^.file_value^;
    IFEND;

    program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
          [pmc$load_map_options_specified];
    program_attributes^.load_map_options := $pmt$load_map_options [];
    IF pvt [p$load_map_options].value^.kind = clc$keyword THEN
      IF pvt [p$load_map_options].value^.keyword_value = 'ALL' THEN
        program_attributes^.load_map_options := -$pmt$load_map_options [pmc$no_load_map];
      ELSE {NONE}
        program_attributes^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
      IFEND;
    ELSE {clc$list of clc$keyword}
      node := pvt [p$load_map_options].value;
      WHILE node <> NIL DO
        IF node^.element_value^.keyword_value = 'SEGMENT' THEN
          program_attributes^.load_map_options := program_attributes^.load_map_options +
                $pmt$load_map_options [pmc$segment_map];
        ELSEIF node^.element_value^.keyword_value = 'BLOCK' THEN
          program_attributes^.load_map_options := program_attributes^.load_map_options +
                $pmt$load_map_options [pmc$block_map];
        ELSEIF node^.element_value^.keyword_value = 'ENTRY_POINT' THEN
          program_attributes^.load_map_options := program_attributes^.load_map_options +
                $pmt$load_map_options [pmc$entry_point_map];
        ELSE {CROSS_REFERENCE}
          program_attributes^.load_map_options := program_attributes^.load_map_options +
                $pmt$load_map_options [pmc$entry_point_xref];
        IFEND;
        node := node^.link;
      WHILEND;
    IFEND;

    IF pvt [p$preset_value].specified THEN
      program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
            [pmc$preset_specified];
      IF pvt [p$preset_value].value^.keyword_value = 'FLOATING_POINT_INDEFINITE' THEN
        program_attributes^.preset := pmc$initialize_to_indefinite;
      ELSEIF pvt [p$preset_value].value^.keyword_value = 'INFINITY' THEN
        program_attributes^.preset := pmc$initialize_to_infinity;
      ELSEIF pvt [p$preset_value].value^.keyword_value = 'ALTERNATE_ONES' THEN
        program_attributes^.preset := pmc$initialize_to_alt_ones;
      ELSEIF pvt [p$preset_value].value^.keyword_value = 'ZERO' THEN
        program_attributes^.preset := pmc$initialize_to_zero;
      IFEND;
    IFEND;

    program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
          [pmc$term_error_level_specified];
    IF pvt [p$termination_error_level].value^.keyword_value = 'WARNING' THEN
      program_attributes^.termination_error_level := pmc$warning_load_errors;
    ELSEIF pvt [p$termination_error_level].value^.keyword_value = 'ERROR' THEN
      program_attributes^.termination_error_level := pmc$error_load_errors;
    ELSEIF pvt [p$termination_error_level].value^.keyword_value = 'FATAL' THEN
      program_attributes^.termination_error_level := pmc$fatal_load_errors;
    IFEND;

    IF pvt [p$stack_size].specified THEN
      program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
            [pmc$max_stack_size_specified];
      program_attributes^.maximum_stack_size := pvt [p$stack_size].value^.integer_value.value;
    IFEND;

    IF pvt [p$debug_input].specified THEN
      program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
            [pmc$debug_input_specified];
      program_attributes^.debug_input := pvt [p$debug_input].value^.file_value^;
    IFEND;

    IF pvt [p$debug_output].specified THEN
      program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
            [pmc$debug_output_specified];
      program_attributes^.debug_output := pvt [p$debug_output].value^.file_value^;
    IFEND;

    IF pvt [p$abort_file].specified THEN
      program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
            [pmc$abort_file_specified];
      program_attributes^.abort_file := pvt [p$abort_file].value^.file_value^;
    IFEND;

    program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
          [pmc$debug_mode_specified];
    program_attributes^.debug_mode := pvt [p$debug_mode].value^.boolean_value.value;

    execution_ring := pvt [p$execution_ring].value^.integer_value.value;

    osp$define_system_task (task_name, automatic_restart, deactivate_task_option, idle_task_option,
          restart_after_idle, spy_identifier, execution_ring, program_description, parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND clp$define_system_task;
?? OLDTITLE, NEWTITLE := '[XDCL, #GATE] clp$delete_system_task', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$delete_system_task (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{   PROCEDURE (osm$delst) delete_system_task, delst (
{     name, n: name = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 31, 14, 5, 18, 653],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$DELST'], [
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$delete_system_task (pvt [p$name].value^.name_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND clp$delete_system_task;
?? OLDTITLE ??
MODEND clm$system_task_maintenance;
*DECK DECK=CLM$SYS_MESSAGES$US_ENGLISH EXPAND=TRUE
CREATE_MESSAGE_MODULE clm$sys_messages$us_english

"
"--- The following messages are used for line mode parameter prompting.
"

CREATE_PARAMETER_ASSIST_MESSAGE clc$all_command_params_correct
All parameters for command +P have been given.
+NPress next/return to continue:
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$confirm_new_param_version
Should the new value be used (YES or no)?
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$confirm_param_default_value
Is "+P2" the value you want for parameter +P1 (YES or no)?
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$confirm_parameter_name
Is +P the parameter you meant (yes, no, or next/return to ignore the parameter)?
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$correct_command_params_msg
Please enter corrections for parameter(s) of command +P:
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$correct_function_params_msg
Please enter corrections for parameter(s) of function +P:
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$correct_parameters_prompt
Please enter corrections for parameters:
**

CREATE_PARAMETER_PROMPT_MESSAGE clc$default_parameter_prompt
+P?
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$enter_command_params_msg
Please enter parameters for command +P:
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$enter_function_params_msg
Please enter parameters for function +P:
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$no_command_params_msg
There are no parameters to supply for command +P.
+NPress next/return to continue:
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$no_function_params_msg
There are no parameters to supply for function +P.
+NPress next/return to continue:
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$prompt_for_advanced_param
Do you wish to be prompted for additional parameters (yes or NO)?
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$prompt_for_parameter_name
Please enter the name of the parameter you meant or
+Nnext/return to ignore the parameter:
**

"
"--- The following messages are used for input trace echoing.
"
"    The first two characters of each message identify its purpose.
"    IB indicates 'Input Begin'.
"    IE indicates 'Input End'.
"
"    In all of these messages the parameter order is fixed to ease generalizing
"    their production.
"    The first parameter is an identifying name.
"    The second parameter is a file reference (used in messages for procedures
"    and include_file only).
"    The third parameter is a status code name (used in end and when/whenend
"    messages only).
"

CREATE_PARAMETER_ASSIST_MESSAGE clc$echo_command_proc_begin
IB $$$$$$$$$$ BEGIN command procedure +P1 on +F2
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$echo_command_proc_end
IE $$$$$$$$$$+X3END command procedure +P1 (status=+P3) on +F2
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$echo_function_proc_begin
IB $$$$$$$$$$ BEGIN function procedure +P1 on +F2
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$echo_function_proc_end
IE $$$$$$$$$$+X3END function procedure +P1 (status=+P3) on +F2
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$echo_include_$command_begin
IB $$$$$$$$$$ BEGIN include $command (utility=+P1)
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$echo_include_$command_end
IE $$$$$$$$$$+X3END include $command (utility=+P1, status=+P3)
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$echo_include_file_begin
IB $$$$$$$$$$ BEGIN include file +F2 (utility=+P1)
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$echo_include_file_end
IE $$$$$$$$$$+X3END include file +F2 (utility=+P1, status=+P3)
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$echo_include_line_begin
IB $$$$$$$$$$ BEGIN include line (utility=+P1)
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$echo_include_line_end
IE $$$$$$$$$$+X3END include line (utility=+P1, status=+P3)
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$echo_task_begin
IB $$$$$$$$$$ BEGIN task/taskend +P1
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$echo_task_end
IE $$$$$$$$$$+X3END task/taskend +P1 (status=+P3)
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$echo_condition_begin
IB $$$$$$$$$$ BEGIN when/whenend for +P1 with status=+P3
**

CREATE_PARAMETER_ASSIST_MESSAGE clc$echo_condition_end
IE $$$$$$$$$$+X3END when/whenend for +P1 (status=+P3)
**

END_MESSAGE_MODULE
*DECK DECK=CLM$TAPE_LABEL_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE clm$tape_label_commands;

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amd$operation_declarations
*copyc ame$device_class_validation
*copyc ame$lfn_program_actions
*copyc ame$tape_program_actions
*copyc amt$local_file_name
*copyc amt$term_option
*copyc cld$value
*copyc cle$ecc_parameter_list
*copyc clt$display_control
*copyc clt$work_area
*copyc fme$file_management_errors
*copyc fst$ansi_eof1_label
*copyc fst$ansi_vol1_label
*copyc fst$attachment_option
*copyc fst$tape_attachment_choices
*copyc fst$tape_attachment_information
*copyc fst$tape_label_block_descriptor
*copyc fst$tape_label_sequence_header
*copyc ofe$error_codes
*copyc oss$job_paged_literal
*copyc ost$date
*copyc ost$name
*copyc ost$status
*copyc ost$string
*copyc rme$creblv_errors
*copyc rmt$device_class
?? POP ??

*copyc amv$nil_file_identifier
*copyc avp$removable_media_admin
*copyc bap$fetch_tape_label_attributes
*copyc bap$store_tape_label_attributes
*copyc bap$store_tape_attachment
*copyc clp$close_display
*copyc clp$convert_data_to_string
*copyc clp$convert_date_time_to_string
*copyc clp$convert_string_to_date_time
*copyc clp$convert_string_to_file
*copyc clp$evaluate_parameters
*copyc clp$get_work_area
*copyc clp$make_boolean_value
*copyc clp$make_date_time_value
*copyc clp$make_integer_value
*copyc clp$make_keyword_value
*copyc clp$make_list_value
*copyc clp$make_name_value
*copyc clp$make_record_value
*copyc clp$make_string_value
*copyc clp$make_unspecified_value
*copyc clp$open_display
*copyc clp$put_data_representation
*copyc clp$trimmed_string_size
*copyc clv$nil_display_control
*copyc clv$user_identification
*copyc clv$value_descriptors
*copyc fmv$tape_attachment_information
*copyc fsp$evaluate_file_reference
*copyc fsp$default_tape_label_attrib
*copyc fsp$get_tape_label_attributes
*copyc fsp$locate_tape_label
*copyc fsp$path_element
*copyc fsp$set_evaluated_file_abnormal
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$change_legible_date_format
*copyc pmp$compute_date_time
*copyc pmp$get_compact_date_time
*copyc rmp$change_tape_debug_mode_23d
*copyc rmp$validate_ansi_string
*copyc rmp$validate_specified_rmg

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    max_tape_attachments = fsc$tape_block_count;

  TYPE
    current_tape_attachments = set of fsc$tape_block_type .. max_tape_attachments;

  CONST
    max_block_types_size = 16,
    max_character_sets_size = 13,
    max_file_set_position_size = 24,
    max_record_types_size = 23;

  VAR
    block_types: [STATIC, READ, oss$job_paged_literal] array [amt$block_type] of
          string (max_block_types_size) := ['SYSTEM_SPECIFIED', 'USER_SPECIFIED'],

    character_sets: [STATIC, READ, oss$job_paged_literal] array [amt$internal_code] of
          string (max_character_sets_size)
          := ['A6', 'A8', 'ASCII', 'D64', 'EBCDIC', 'BCD', 'D63',
          'FTAM1 ia5', 'FTAM1 visible', 'FTAM1 graphic', 'FTAM1 general',
          'FTAM2 ia5', 'FTAM2 visible', 'FTAM2 graphic', 'FTAM2 general'],

    file_set_position: [STATIC, READ, oss$job_paged_literal] array [fst$tape_file_set_pos_choices] of
          string (max_file_set_position_size)
          := ['BEGINNING_OF_SET', 'CURRENT_FILE', 'END_OF_SET',
          'FILE_IDENTIFIER_POSITION', 'FILE_SEQUENCE_POSITION', 'NEXT_FILE'],

    record_types: [STATIC, READ, oss$job_paged_literal] array [amt$record_type] of
          string (max_record_types_size)
          := ['VARIABLE', 'UNDEFINED', 'ANSI_FIXED', 'ANSI_SPANNED',
          'ANSI_VARIABLE', 'TRAILING_CHAR_DELIMITED'];

  CONST
    max_displayable_attributes = max_tape_attachments - 1; {removes fsc$tape_null_attachment_option}

  VAR
    tape_attachment_names: [STATIC, READ, oss$job_paged_literal] array [1 .. max_displayable_attributes] OF
      record
        text: ost$name,
        ordinal: fst$tape_attachment_choices,
      recend := [

      ['BLOCK_COUNT                    ', fsc$tape_block_count],
      ['BLOCK_TYPE                     ', fsc$tape_block_type],
      ['BUFFER_OFFSET                  ', fsc$tape_buffer_offset],
      ['CHARACTER_CONVERSION           ', fsc$tape_character_conversion],
      ['CHARACTER_SET                  ', fsc$tape_character_set],
      ['CREATION_DATE                  ', fsc$tape_creation_date],
      ['EXPIRATION_DATE                ', fsc$tape_expiration_date],
      ['FILE_ACCESSIBILITY             ', fsc$tape_file_accessibility],
      ['FILE_IDENTIFIER                ', fsc$tape_file_identifier],
      ['FILE_SECTION_NUMBER            ', fsc$tape_file_section_number],
      ['FILE_SEQUENCE_NUMBER           ', fsc$tape_file_sequence_number],
      ['FILE_SET_IDENTIFIER            ', fsc$tape_file_set_identifier],
      ['FILE_SET_POSITION              ', fsc$tape_file_set_position],
      ['GENERATION_NUMBER              ', fsc$tape_generation_number],
      ['GENERATION_VERSION_NUMBER      ', fsc$tape_generation_version_num],
      ['HEADER_LABELS                  ', fsc$tape_header_labels],
      ['IMPLEMENTATION_IDENTIFIER      ', fsc$tape_implementation_id],
      ['LABEL_STANDARD_VERSION         ', fsc$tape_label_standard_version],
      ['MAXIMUM_BLOCK_LENGTH           ', fsc$tape_max_block_length],
      ['MAXIMUM_RECORD_LENGTH          ', fsc$tape_max_record_length],
      ['OWNER_IDENTIFIER               ', fsc$tape_owner_identification],
      ['PADDING_CHARACTER              ', fsc$tape_padding_character],
      ['RECORD_TYPE                    ', fsc$tape_record_type],
      ['REMOVABLE_MEDIA_GROUP          ', fsc$tape_removable_media_group],
      ['REWRITE_LABELS                 ', fsc$tape_rewrite_labels],
      ['TRAILER_LABELS                 ', fsc$tape_trailer_labels],
      ['VOLUME_ACCESSIBILITY           ', fsc$tape_volume_accessibility]];

?? TITLE := 'PROCEDURE clp$_change_tape_debug_mode', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$_change_tape_debug_mode (
        parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE change_tape_debug_mode (
{   debug_mode, dm: boolean = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 7, 5, 10, 56, 0, 107],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['DEBUG_MODE                     ',clc$nominal_entry, 1],
    ['DM                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$debug_mode = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$debug_mode].specified THEN
      rmp$change_tape_debug_mode_23d (pvt [p$debug_mode].value^.boolean_value.value);
    IFEND;

  PROCEND clp$_change_tape_debug_mode;

?? TITLE := 'PROCEDURE clp$display_tape_label_attr_cmd', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$display_tape_label_attr_cmd (
        parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE display_tape_label_attributes, display_tape_label_attribute, distla (
{   file, f: any of
{       key
{         (system_default_values, system_default_value, sdv)
{       keyend
{       file
{     anyend = $required
{   display_options, display_option, do: any of
{       key
{         all
{       keyend
{       list of key
{         (block_count, bc)
{         (block_type, bt)
{         (buffer_offset, bo)
{         (character_conversion, cc)
{         (character_set, cs)
{         (creation_date, cd)
{         (expiration_date, ed)
{         (file_identifier, fi)
{         (file_sequence_number, fsn)
{         (file_set_identifier, fsi)
{         (file_set_position, fsp)
{         (generation_number, gn)
{         (generation_version_number, gvn)
{         (header_labels, hl)
{         (maximum_block_length, maxbl)
{         (maximum_record_length, maxrl)
{         (padding_character, pc)
{         (record_type, rt)
{         (rewrite_labels, rl)
{         (trailer_labels, tl)
{       advanced_key
{         (file_accessibility, fa, file_accessibility_code, fac)
{         (file_section_number, fsen)
{         (implementation_identifier, ii)
{         (label_standard_version, lsv)
{         (owner_identifier, oi)
{         (removable_media_group, rmg)
{         (volume_accessibility, va)
{       hidden_key
{         (current_file, cf)
{         (next_file, nf)
{         (source, s)
{       keyend
{     anyend = osd$distla_display_options, all
{   output, o: file = $output
{   source, s: (BY_NAME) key
{       (explicit_specification, es)
{       (last_accessed, la)
{       (next_position, np)
{     keyend = next_position
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: 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 .. 62] of clt$keyword_specification,
          recend,
        recend,
        default_name: string (26),
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (13),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 4, 5, 17, 3, 53, 708],
    clc$command, 10, 5, 1, 0, 0, 0, 5, ''], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['S                              ',clc$abbreviation_entry, 4],
    ['SOURCE                         ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 141,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 2381,
  clc$optional_default_parameter, 26, 3],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 13],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SDV                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['SYSTEM_DEFAULT_VALUE           ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['SYSTEM_DEFAULT_VALUES          ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[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]]
      ],
    2317, [[1, 0, clc$list_type], [2301, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [62], [
        ['BC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['BLOCK_COUNT                    ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['BLOCK_TYPE                     ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['BO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['BT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['BUFFER_OFFSET                  ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['CC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['CD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['CF                             ', clc$abbreviation_entry, clc$hidden_entry, 28],
        ['CHARACTER_CONVERSION           ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['CHARACTER_SET                  ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['CREATION_DATE                  ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['CS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['CURRENT_FILE                   ', clc$nominal_entry, clc$hidden_entry, 28],
        ['ED                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
        ['EXPIRATION_DATE                ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['FA                             ', clc$alias_entry, clc$advanced_usage_entry, 21],
        ['FAC                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 21],
        ['FI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
        ['FILE_ACCESSIBILITY             ', clc$nominal_entry, clc$advanced_usage_entry, 21],
        ['FILE_ACCESSIBILITY_CODE        ', clc$alias_entry, clc$advanced_usage_entry, 21],
        ['FILE_IDENTIFIER                ', clc$nominal_entry, clc$normal_usage_entry, 8],
        ['FILE_SECTION_NUMBER            ', clc$nominal_entry, clc$advanced_usage_entry, 22],
        ['FILE_SEQUENCE_NUMBER           ', clc$nominal_entry, clc$normal_usage_entry, 9],
        ['FILE_SET_IDENTIFIER            ', clc$nominal_entry, clc$normal_usage_entry, 10],
        ['FILE_SET_POSITION              ', clc$nominal_entry, clc$normal_usage_entry, 11],
        ['FSEN                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 22],
        ['FSI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
        ['FSN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
        ['FSP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
        ['GENERATION_NUMBER              ', clc$nominal_entry, clc$normal_usage_entry, 12],
        ['GENERATION_VERSION_NUMBER      ', clc$nominal_entry, clc$normal_usage_entry, 13],
        ['GN                             ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
        ['GVN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
        ['HEADER_LABELS                  ', clc$nominal_entry, clc$normal_usage_entry, 14],
        ['HL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
        ['II                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 23],
        ['IMPLEMENTATION_IDENTIFIER      ', clc$nominal_entry, clc$advanced_usage_entry, 23],
        ['LABEL_STANDARD_VERSION         ', clc$nominal_entry, clc$advanced_usage_entry, 24],
        ['LSV                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 24],
        ['MAXBL                          ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
        ['MAXIMUM_BLOCK_LENGTH           ', clc$nominal_entry, clc$normal_usage_entry, 15],
        ['MAXIMUM_RECORD_LENGTH          ', clc$nominal_entry, clc$normal_usage_entry, 16],
        ['MAXRL                          ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
        ['NEXT_FILE                      ', clc$nominal_entry, clc$hidden_entry, 29],
        ['NF                             ', clc$abbreviation_entry, clc$hidden_entry, 29],
        ['OI                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 25],
        ['OWNER_IDENTIFIER               ', clc$nominal_entry, clc$advanced_usage_entry, 25],
        ['PADDING_CHARACTER              ', clc$nominal_entry, clc$normal_usage_entry, 17],
        ['PC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
        ['RECORD_TYPE                    ', clc$nominal_entry, clc$normal_usage_entry, 18],
        ['REMOVABLE_MEDIA_GROUP          ', clc$nominal_entry, clc$advanced_usage_entry, 26],
        ['REWRITE_LABELS                 ', clc$nominal_entry, clc$normal_usage_entry, 19],
        ['RL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
        ['RMG                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 26],
        ['RT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
        ['S                              ', clc$abbreviation_entry, clc$hidden_entry, 30],
        ['SOURCE                         ', clc$nominal_entry, clc$hidden_entry, 30],
        ['TL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 20],
        ['TRAILER_LABELS                 ', clc$nominal_entry, clc$normal_usage_entry, 20],
        ['VA                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 27],
        ['VOLUME_ACCESSIBILITY           ', clc$nominal_entry, clc$advanced_usage_entry, 27]]
        ]
      ]
    ,
    'OSD$DISTLA_DISPLAY_OPTIONS',
    'all'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [6], [
    ['ES                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['EXPLICIT_SPECIFICATION         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['LA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['LAST_ACCESSED                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['NEXT_POSITION                  ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['NP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3]]
    ,
    'next_position'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$display_options = 2,
      p$output = 3,
      p$source = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

?? NEWTITLE := 'PROCEDURE abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;

?? TITLE := 'PROCEDURE put_subtitle', EJECT ??
{ The following XREFs are required by clp$put_path_subtitle and should be
{ copyc'd in that deck but are not.

*copyc clp$build_path_subtitle
*copyc clp$horizontal_tab_display
*copyc clp$get_path_name
*copyc clp$put_partial_display

*copyc clp$put_path_subtitle
*copyc clv$display_variables

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

      clv$subtitles_built := FALSE;
      clp$put_path_subtitle (output_file, 'FILE', status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND put_subtitle;

{ The following XREFs are required by clp$new_page_procedure and should be
{ copyc'd in that deck but are not.

*copyc clp$build_standard_title
*copyc clp$convert_integer_to_string
*copyc clp$new_display_line
*copyc clp$put_display
*copyc clp$reset_for_next_display_page

*copy clp$new_page_procedure
?? OLDTITLE, EJECT ??

 {  Begin main procedure  }

    VAR
      attributes: array [1 .. max_tape_attachments] of fst$attachment_option,
      attributes_requested: current_tape_attachments,
      current_file_selected: boolean,
      current_option: ^clt$data_value,
      data_representation: ^clt$data_representation,
      display_control: clt$display_control,
      local_status: ost$status,
      next_file_selected: boolean,
      number_of_attributes_requested: ost$non_negative_integers,
      output_file: clt$file,
      result: ^clt$data_value,
      returned_attributes: fst$tla_returned_attributes,
      source: fst$tape_attribute_source,
      source_selected: boolean,
      tape_attachment_choice: fst$tape_attachment_choices,
      work_area: ^^clt$work_area;

    status.normal := TRUE;
    local_status.normal := TRUE;

    current_file_selected := FALSE;
    next_file_selected := FALSE;
    source_selected:= FALSE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    attributes_requested := $current_tape_attachments [];

    current_option := pvt [p$display_options].value;

    IF current_option^.kind = clc$keyword THEN { ALL selected }
      enforce_security (number_of_attributes_requested, attributes_requested);
    ELSE
      number_of_attributes_requested := 0;
      WHILE current_option <> NIL DO
        IF (current_option^.element_value^.keyword_value = 'CURRENT_FILE') THEN
          current_file_selected := TRUE;
        ELSEIF (current_option^.element_value^.keyword_value = 'NEXT_FILE') THEN
          next_file_selected := TRUE;
        ELSEIF (current_option^.element_value^.keyword_value = 'SOURCE') THEN
          source_selected := TRUE;
        ELSE
          get_tape_attachment_choice (current_option^.element_value^.keyword_value, tape_attachment_choice);
          IF NOT (tape_attachment_choice IN attributes_requested) THEN
            attributes_requested := attributes_requested +
                  $current_tape_attachments [tape_attachment_choice];
            number_of_attributes_requested := number_of_attributes_requested + 1;
          IFEND;
        IFEND;
        current_option := current_option^.link;
      WHILEND;

      IF (source_selected OR current_file_selected OR next_file_selected) AND
            (attributes_requested = $current_tape_attachments []) THEN
        enforce_security (number_of_attributes_requested, attributes_requested);
      IFEND;
    IFEND;

    IF number_of_attributes_requested = 0 THEN
      RETURN;
    IFEND;

    FOR tape_attachment_choice := 1 TO max_tape_attachments DO
      IF tape_attachment_choice IN attributes_requested THEN
        attributes [tape_attachment_choice].selector := fsc$tape_attachment;
        attributes [tape_attachment_choice].tape_attachment.selector := tape_attachment_choice;
      ELSE
        attributes [tape_attachment_choice].selector := fsc$null_attachment_option;
      IFEND;
    FOREND;

    IF fsc$tape_header_labels IN attributes_requested THEN
      PUSH attributes [fsc$tape_header_labels].tape_attachment.tape_header_labels:
            [[REP 1 OF fst$tape_label_sequence_header, REP (fsc$max_tape_labels *
            (#SIZE (fst$tape_label_block_descriptor) + fsc$max_tape_label_length)) OF cell]];
    IFEND;
    IF fsc$tape_trailer_labels IN attributes_requested THEN
      PUSH attributes [fsc$tape_trailer_labels].tape_attachment.tape_trailer_labels:
            [[REP 1 OF fst$tape_label_sequence_header, REP (fsc$max_tape_labels *
            (#SIZE (fst$tape_label_block_descriptor) + fsc$max_tape_label_length)) OF cell]];
    IFEND;

    IF pvt [p$file].value^.kind = clc$keyword THEN { system_default_values }
      fsp$default_tape_label_attrib (fsc$tla_system_default, attributes, returned_attributes, status);
    ELSE
      IF (pvt [p$source].value^.keyword_value = 'LAST_ACCESSED') OR current_file_selected THEN
        source := fsc$tla_last_ansi_file_accessed;
      ELSEIF (pvt [p$source].value^.keyword_value = 'NEXT_POSITION') OR next_file_selected THEN
        source := fsc$tla_next_position;
      ELSE
        source := fsc$tla_explicit_specification;
      IFEND;
      fsp$get_tape_label_attributes (pvt [p$file].value^.file_value^, source, attributes,
            returned_attributes, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_work_area (#RING (^work_area), work_area, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_record_value (number_of_attributes_requested, work_area^, result);

    build_display_record (attributes, attributes_requested, returned_attributes, work_area^, result,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_control := clv$nil_display_control;
    #spoil (display_control);
    osp$establish_block_exit_hndlr (^abort_handler);

    clp$convert_string_to_file (pvt [p$output].value^.file_value^, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /form_display/
    BEGIN
      clp$open_display (output_file, ^clp$new_page_procedure, display_control, status);
      IF NOT status.normal THEN
        EXIT /form_display/;
      IFEND;
      clv$titles_built := FALSE;
      clv$subtitles_built := FALSE;
      clv$command_name := 'display_tape_label_attributes';

      IF display_control.page_width < clc$narrow_page_width THEN
        clv$page_width := clc$narrow_page_width;
      ELSEIF display_control.page_width > clc$wide_page_width THEN
        clv$page_width := clc$wide_page_width;
      ELSE
        clv$page_width := display_control.page_width;
      IFEND;

      clp$convert_data_to_string (result, clc$labeled_elem_representation, clv$page_width, work_area^,
            data_representation, status);
      IF NOT status.normal THEN
        EXIT /form_display/;
      IFEND;

      clp$put_data_representation (display_control, data_representation, status);
      IF NOT status.normal THEN
        EXIT /form_display/;
      IFEND;
    END /form_display/;

    IF display_control.file_id <> amv$nil_file_identifier THEN
      clp$close_display (display_control, local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND clp$display_tape_label_attr_cmd;

?? TITLE := 'PROCEDURE clp$change_tape_label_attr_cmd', EJECT ??
  PROCEDURE [XDCL, #GATE] clp$change_tape_label_attr_cmd (
        parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE (osm$chatla) change_tape_label_attribute, change_tape_label_attributes, chatla (
{   file, f: file = $required
{   block_type, bt: (BY_NAME) key
{       $unspecified
{       (system_specified, ss)
{       (user_specified, us)
{     keyend = $optional
{   character_conversion, cc: (BY_NAME) any of
{       key
{         $unspecified
{       keyend
{       boolean
{     anyend = $optional
{   character_set, ic, internal_code, cs: (BY_NAME) key
{       $unspecified
{       (ascii, a)
{       (ebcdic, e)
{     keyend = $optional
{   creation_date, cd: (BY_NAME) any of
{       key
{         $unspecified
{       keyend
{       date
{     anyend = $optional
{   expiration_date, ed: (BY_NAME) any of
{       key
{         $unspecified
{         (expired, e)
{       keyend
{       date
{       time_increment
{     anyend = $optional
{   file_accessibility, fac, file_accessibility_code, fa: (BY_NAME, ADVANCED, SECURE) any of
{       key
{         $unspecified, none
{       keyend
{       string 1
{       name 1..1
{     anyend = $optional
{   file_identifier, fi: (BY_NAME) any of
{       key
{         $unspecified
{       keyend
{       string 1..17
{       name 1..17
{     anyend = $optional
{   file_sequence_number, fsn: (BY_NAME, HIDDEN) integer 1..9999 = $optional
{   file_set_identifier, fsi: (BY_NAME) any of
{       key
{         $unspecified
{       keyend
{       string 1..6
{       name 1..6
{     anyend = $optional
{   file_set_position, fsp: (BY_NAME) any of
{       key
{         $unspecified
{         (beginning_of_set, bos)
{         (current_file, cf)
{         (end_of_set, eos)
{         (next_file, nf)
{       keyend
{       record
{         method: key
{           (file_identifier_position, fip)
{         keyend
{         file_identifier: any of
{           string 1..17
{           name 1..17
{         anyend = $optional
{         generation_number: integer 1..9999 = $optional
{       recend
{       record
{         method: key
{           (file_sequence_position, fsp)
{         keyend
{         file_sequence_number: integer 1..9999 = $optional
{       recend
{     anyend = $optional
{   generation_number, gn: (BY_NAME) any of
{       key
{         $unspecified
{       keyend
{       integer 1..9999
{     anyend = $optional
{   generation_version_number, gvn: (BY_NAME) any of
{       key
{         $unspecified
{       keyend
{       integer 0..99
{     anyend = $optional
{   maximum_block_length, maxbl: (BY_NAME) any of
{       key
{         $unspecified
{       keyend
{       integer 1..2147483615
{     anyend = $optional
{   maximum_record_length, maxrl: (BY_NAME) any of
{       key
{         $unspecified
{       keyend
{       integer 0..4398046511103
{     anyend = $optional
{   owner_identifier, oi: (BY_NAME, ADVANCED, SECURE) any of
{       key
{         $unspecified, none
{       keyend
{       string 1..14
{       name 1..14
{     anyend = $optional
{   padding_character, pc: (BY_NAME) any of
{       key
{         $unspecified
{       keyend
{       string 1
{       name 1..1
{     anyend = $optional
{   record_type, rt: (BY_NAME) key
{       $unspecified
{       (ansi_fixed, f, fixed, af)
{       (ansi_spanned, s, as)
{       (ansi_variable, d, av)
{       (undefined, u)
{       (variable, v)
{     keyend = $optional
{   removable_media_group, rmg: (BY_NAME, ADVANCED, SECURE) any of
{       key
{         $unspecified
{       keyend
{       name 1..13
{     anyend = $optional
{   rewrite_labels, rl: (BY_NAME) any of
{       key
{         $unspecified
{       keyend
{       boolean
{     anyend = $optional
{   volume_accessibility, va: (BY_NAME, ADVANCED, SECURE) any of
{       key
{         $unspecified, none
{       keyend
{       string 1
{       name 1..1
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 47] of clt$pdt_parameter_name,
      parameters: array [1 .. 22] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
      recend,
      type3: 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,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
      recend,
      type5: 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$date_time_type_qualifier,
        recend,
      recend,
      type6: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$date_time_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
        recend,
      recend,
      type7: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type8: 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$string_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type10: 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$string_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type11: 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 .. 9] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 2] of clt$keyword_specification,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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$string_type_qualifier,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 2] of clt$keyword_specification,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
      recend,
      type12: 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$integer_type_qualifier,
        recend,
      recend,
      type13: 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$integer_type_qualifier,
        recend,
      recend,
      type14: 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$integer_type_qualifier,
        recend,
      recend,
      type15: 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$integer_type_qualifier,
        recend,
      recend,
      type16: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type17: 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$string_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type18: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 15] of clt$keyword_specification,
      recend,
      type19: 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$name_type_qualifier,
        recend,
      recend,
      type20: 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,
        recend,
      recend,
      type21: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type22: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 10, 30, 9, 43, 47, 221],
    clc$command, 47, 22, 1, 4, 1, 0, 22, 'OSM$CHATLA'], [
    ['BLOCK_TYPE                     ',clc$nominal_entry, 2],
    ['BT                             ',clc$abbreviation_entry, 2],
    ['CC                             ',clc$abbreviation_entry, 3],
    ['CD                             ',clc$abbreviation_entry, 5],
    ['CHARACTER_CONVERSION           ',clc$nominal_entry, 3],
    ['CHARACTER_SET                  ',clc$nominal_entry, 4],
    ['CREATION_DATE                  ',clc$nominal_entry, 5],
    ['CS                             ',clc$abbreviation_entry, 4],
    ['ED                             ',clc$abbreviation_entry, 6],
    ['EXPIRATION_DATE                ',clc$nominal_entry, 6],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FA                             ',clc$abbreviation_entry, 7],
    ['FAC                            ',clc$alias_entry, 7],
    ['FI                             ',clc$abbreviation_entry, 8],
    ['FILE                           ',clc$nominal_entry, 1],
    ['FILE_ACCESSIBILITY             ',clc$nominal_entry, 7],
    ['FILE_ACCESSIBILITY_CODE        ',clc$alias_entry, 7],
    ['FILE_IDENTIFIER                ',clc$nominal_entry, 8],
    ['FILE_SEQUENCE_NUMBER           ',clc$nominal_entry, 9],
    ['FILE_SET_IDENTIFIER            ',clc$nominal_entry, 10],
    ['FILE_SET_POSITION              ',clc$nominal_entry, 11],
    ['FSI                            ',clc$abbreviation_entry, 10],
    ['FSN                            ',clc$abbreviation_entry, 9],
    ['FSP                            ',clc$abbreviation_entry, 11],
    ['GENERATION_NUMBER              ',clc$nominal_entry, 12],
    ['GENERATION_VERSION_NUMBER      ',clc$nominal_entry, 13],
    ['GN                             ',clc$abbreviation_entry, 12],
    ['GVN                            ',clc$abbreviation_entry, 13],
    ['IC                             ',clc$alias_entry, 4],
    ['INTERNAL_CODE                  ',clc$alias_entry, 4],
    ['MAXBL                          ',clc$abbreviation_entry, 14],
    ['MAXIMUM_BLOCK_LENGTH           ',clc$nominal_entry, 14],
    ['MAXIMUM_RECORD_LENGTH          ',clc$nominal_entry, 15],
    ['MAXRL                          ',clc$abbreviation_entry, 15],
    ['OI                             ',clc$abbreviation_entry, 16],
    ['OWNER_IDENTIFIER               ',clc$nominal_entry, 16],
    ['PADDING_CHARACTER              ',clc$nominal_entry, 17],
    ['PC                             ',clc$abbreviation_entry, 17],
    ['RECORD_TYPE                    ',clc$nominal_entry, 18],
    ['REMOVABLE_MEDIA_GROUP          ',clc$nominal_entry, 19],
    ['REWRITE_LABELS                 ',clc$nominal_entry, 20],
    ['RL                             ',clc$abbreviation_entry, 20],
    ['RMG                            ',clc$abbreviation_entry, 19],
    ['RT                             ',clc$abbreviation_entry, 18],
    ['STATUS                         ',clc$nominal_entry, 22],
    ['VA                             ',clc$abbreviation_entry, 21],
    ['VOLUME_ACCESSIBILITY           ',clc$nominal_entry, 21]],
    [
{ PARAMETER 1
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 67, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 150,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [16, clc$advanced_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81, clc$optional_parameter,
  0, 0],
{ PARAMETER 9
    [19, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 10
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81, clc$optional_parameter,
  0, 0],
{ PARAMETER 11
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 793,
  clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84, clc$optional_parameter,
  0, 0],
{ PARAMETER 13
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84, clc$optional_parameter,
  0, 0],
{ PARAMETER 14
    [32, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84, clc$optional_parameter,
  0, 0],
{ PARAMETER 15
    [33, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84, clc$optional_parameter,
  0, 0],
{ PARAMETER 16
    [36, clc$advanced_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [37, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81, clc$optional_parameter,
  0, 0],
{ PARAMETER 18
    [39, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 562,
  clc$optional_parameter, 0, 0],
{ PARAMETER 19
    [40, clc$advanced_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 20
    [41, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 67, clc$optional_parameter,
  0, 0],
{ PARAMETER 21
    [47, clc$advanced_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_parameter, 0, 0],
{ PARAMETER 22
    [45, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [5], [
    ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['SS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SYSTEM_SPECIFIED               ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['US                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['USER_SPECIFIED                 ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [5], [
    ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['ASCII                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['EBCDIC                         ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$date_time_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date], $clt$date_time_tenses [clc$past,
  clc$present, clc$future]]]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$date_time_type, clc$keyword_type, clc$time_increment_type],
    FALSE, 3],
    118, [[1, 0, clc$keyword_type], [3], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['EXPIRED                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date], $clt$date_time_tenses [clc$past,
  clc$present, clc$future]]],
    3, [[1, 0, clc$time_increment_type]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type, clc$string_type],
    FALSE, 3],
    81, [[1, 0, clc$keyword_type], [2], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    8, [[1, 0, clc$string_type], [1, 1, FALSE]],
    5, [[1, 0, clc$name_type], [1, 1]]
    ],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type, clc$string_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [1, 17, FALSE]],
    5, [[1, 0, clc$name_type], [1, 17]]
    ],
{ PARAMETER 9
    [[1, 0, clc$integer_type], [1, 9999, 10]],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type, clc$string_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [1, 6, FALSE]],
    5, [[1, 0, clc$name_type], [1, 6]]
    ],
{ PARAMETER 11
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$record_type],
    FALSE, 3],
    340, [[1, 0, clc$keyword_type], [9], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['BEGINNING_OF_SET               ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['BOS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['CF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['CURRENT_FILE                   ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['END_OF_SET                     ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['EOS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['NEXT_FILE                      ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['NF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5]]
      ],
    249, [[1, 0, clc$record_type], [3],
      ['METHOD                         ', clc$required_field, 81], [[1, 0, clc$keyword_type], [2], [
        ['FILE_IDENTIFIER_POSITION       ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['FIP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1]]
        ],
      ['FILE_IDENTIFIER                ', clc$optional_field, 33], [[1, 0, clc$union_type], [[
        clc$name_type, clc$string_type],
        TRUE, 2],
        8, [[1, 0, clc$string_type], [1, 17, FALSE]],
        5, [[1, 0, clc$name_type], [1, 17]]
        ],
      ['GENERATION_NUMBER              ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1, 9999, 10]]
      ],
    180, [[1, 0, clc$record_type], [2],
      ['METHOD                         ', clc$required_field, 81], [[1, 0, clc$keyword_type], [2], [
        ['FILE_SEQUENCE_POSITION         ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['FSP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1]]
        ],
      ['FILE_SEQUENCE_NUMBER           ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1, 9999, 10]]
      ]
    ],
{ PARAMETER 12
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, 9999, 10]]
    ],
{ PARAMETER 13
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, 99, 10]]
    ],
{ PARAMETER 14
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, 2147483615, 10]]
    ],
{ PARAMETER 15
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, 4398046511103, 10]]
    ],
{ PARAMETER 16
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type, clc$string_type],
    FALSE, 3],
    81, [[1, 0, clc$keyword_type], [2], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    8, [[1, 0, clc$string_type], [1, 14, FALSE]],
    5, [[1, 0, clc$name_type], [1, 14]]
    ],
{ PARAMETER 17
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type, clc$string_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [1, 1, FALSE]],
    5, [[1, 0, clc$name_type], [1, 1]]
    ],
{ PARAMETER 18
    [[1, 0, clc$keyword_type], [15], [
    ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['AF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['ANSI_FIXED                     ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['ANSI_SPANNED                   ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['ANSI_VARIABLE                  ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['AS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['AV                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['D                              ', clc$alias_entry, clc$normal_usage_entry, 4],
    ['F                              ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['FIXED                          ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['S                              ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['UNDEFINED                      ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['V                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['VARIABLE                       ', clc$nominal_entry, clc$normal_usage_entry, 6]]
    ],
{ PARAMETER 19
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, 13]]
    ],
{ PARAMETER 20
    [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 21
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type, clc$string_type],
    FALSE, 3],
    81, [[1, 0, clc$keyword_type], [2], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    8, [[1, 0, clc$string_type], [1, 1, FALSE]],
    5, [[1, 0, clc$name_type], [1, 1]]
    ],
{ PARAMETER 22
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$block_type = 2,
      p$character_conversion = 3,
      p$character_set = 4,
      p$creation_date = 5,
      p$expiration_date = 6,
      p$file_accessibility = 7,
      p$file_identifier = 8,
      p$file_sequence_number = 9,
      p$file_set_identifier = 10,
      p$file_set_position = 11,
      p$generation_number = 12,
      p$generation_version_number = 13,
      p$maximum_block_length = 14,
      p$maximum_record_length = 15,
      p$owner_identifier = 16,
      p$padding_character = 17,
      p$record_type = 18,
      p$removable_media_group = 19,
      p$rewrite_labels = 20,
      p$volume_accessibility = 21,
      p$status = 22;

    VAR
      pvt: array [1 .. 22] of clt$parameter_value;

    VAR
      attachment_option_keys: [STATIC, READ, oss$job_paged_literal] array
            [p$block_type .. p$volume_accessibility] of fst$tape_attachment_choices :=
        [fsc$tape_block_type,
         fsc$tape_character_conversion,
         fsc$tape_character_set,
         fsc$tape_creation_date,
         fsc$tape_expiration_date,
         fsc$tape_file_accessibility,
         fsc$tape_file_identifier,
         fsc$tape_file_sequence_number,
         fsc$tape_file_set_identifier,
         fsc$tape_file_set_position,
         fsc$tape_generation_number,
         fsc$tape_generation_version_num,
         fsc$tape_max_block_length,
         fsc$tape_max_record_length,
         fsc$tape_owner_identification,
         fsc$tape_padding_character,
         fsc$tape_record_type,
         fsc$tape_removable_media_group,
         fsc$tape_rewrite_labels,
         fsc$tape_volume_accessibility];

?? NEWTITLE := 'validate_tape_attachments', EJECT ??
    PROCEDURE validate_tape_attachments
      (VAR status: ost$status);

      VAR
        file_set_position: [STATIC, READ, oss$job_paged_literal] array
              [fsc$tape_beginning_of_set .. fsc$tape_next_file] of ost$name :=
          ['BEGINNING_OF_SET',
           'CURRENT_FILE',
           'END_OF_SET',
           'FILE_IDENTIFIER_POSITION',
           'FILE_SEQUENCE_POSITION',
           'NEXT_FILE'];

      VAR
        authorized_access: fst$file_access_options,
        local_status: ost$status,
        message_status: ost$status,
        temp_attachments: fst$tape_attachment_information;

      status.normal := TRUE;

      bap$fetch_tape_label_attributes (evaluated_file_reference, temp_attachments, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      {  Merge old and new tape attachment values into temp_attachments  }

      bap$store_tape_attachment (attachment_options, fsc$tape_label_attr_command, ^temp_attachments,  status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      bap$store_tape_attachment (undo_options, fsc$tape_label_attr_default, ^temp_attachments,  status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT temp_attachments.rewrite_labels THEN
        IF specified [fsc$tape_file_identifier] AND specified [fsc$tape_file_set_position] AND
              (attachment_options [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.position
              = fsc$tape_file_identifier_pos) AND (fsc$fsp_file_identifier IN supplied_file_set_pos_fields)
              AND (attachment_options [fsc$tape_file_identifier].tape_attachment.tape_file_identifier <>
              attachment_options [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.
              file_identifier) THEN
          attachment_options [fsc$tape_file_identifier].tape_attachment.selector :=
                fsc$tape_null_attachment_option;
          fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_identifier_ignored,
                fmc$change_tape_label_attr_cmd, '', message_status);
          osp$generate_message (message_status, local_status);
        IFEND;
        IF specified [fsc$tape_generation_number] AND specified [fsc$tape_file_set_position] AND
              (attachment_options [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.position
              = fsc$tape_file_identifier_pos) AND (fsc$fsp_generation_number IN supplied_file_set_pos_fields)
              AND (attachment_options [fsc$tape_generation_number].tape_attachment.tape_generation_number <>
              attachment_options [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.
              generation_number) THEN
          attachment_options [fsc$tape_generation_number].tape_attachment.selector :=
                fsc$tape_null_attachment_option;
          fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$generation_number_ignored,
                fmc$change_tape_label_attr_cmd, '', message_status);
          osp$generate_message (message_status, local_status);
        IFEND;
      IFEND;

      IF temp_attachments.file_set_position.position <> fsc$tape_file_sequence_pos THEN
        IF specified [fsc$tape_file_sequence_number] THEN
          attachment_options [fsc$tape_file_sequence_number].tape_attachment.selector :=
                fsc$tape_null_attachment_option;
          fsp$set_evaluated_file_abnormal (evaluated_file_reference,
                ame$file_seq_number_ignored, fmc$change_tape_label_attr_cmd, '', message_status);
          osp$generate_message (message_status, local_status);
        IFEND;
      IFEND;

      IF specified [fsc$tape_owner_identification] AND (specified [fsc$tape_removable_media_group] OR
            (temp_attachments.removable_media_group_source <> fsc$tape_label_attr_default)) THEN
        osp$set_status_condition (rme$ambiguous_specifications, status);
        RETURN;
      IFEND;

      IF specified [fsc$tape_removable_media_group] THEN
        IF temp_attachments.owner_identifier_source = fsc$tape_label_attr_default THEN
          rmp$validate_specified_rmg (evaluated_file_reference,
                attachment_options [fsc$tape_removable_media_group].tape_attachment.
                tape_removable_media_group, authorized_access, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          osp$set_status_condition (rme$ambiguous_specifications, status);
          RETURN;
        IFEND;
      IFEND;

      IF specified [fsc$tape_block_type] OR specified [fsc$tape_record_type] OR
            (undo_options [fsc$tape_block_type].tape_attachment.selector = fsc$tape_block_type) OR
            (undo_options [fsc$tape_record_type].tape_attachment.selector = fsc$tape_record_type) THEN
        IF temp_attachments.block_type = amc$system_specified THEN
          IF temp_attachments.record_type = amc$ansi_fixed THEN
            fsp$set_evaluated_file_abnormal (evaluated_file_reference,
                 ame$unsupported_tape_bt_rt, fmc$change_tape_label_attr_cmd,
                'Block type SYSTEM_SPECIFIED (SS), record type FIXED (F)', status);
            RETURN;
          ELSEIF temp_attachments.record_type = amc$ansi_variable THEN
            fsp$set_evaluated_file_abnormal (evaluated_file_reference,
                 ame$unsupported_tape_bt_rt, fmc$change_tape_label_attr_cmd,
                 'Block type SYSTEM_SPECIFIED (SS), record type ANSI_VARIABLE (D)', status);
            RETURN;
          ELSEIF temp_attachments.record_type = amc$ansi_spanned THEN
            fsp$set_evaluated_file_abnormal (evaluated_file_reference,
                 ame$unsupported_tape_bt_rt, fmc$change_tape_label_attr_cmd,
                 'Block type SYSTEM_SPECIFIED (SS), record type ANSI_SPANNED (S)', status);
            RETURN;
          IFEND;
        IFEND;
      IFEND;

    PROCEND validate_tape_attachments;
?? OLDTITLE, EJECT ??

 {  Begin main procedure  }

    VAR
      attachment_options: array [1 .. max_tape_attachments] of fst$attachment_option,
      current_date: ost$date_time,
      date_string: ost$string,
      evaluated_file_reference: fst$evaluated_file_reference,
      expiration_date: clt$date_time,
      index: 0 .. max_tape_attachments,
      local_status: ost$status,
      message_status: ost$status,
      returned_attributes: fst$tla_returned_attributes,
      specified: array [1 .. max_tape_attachments] of boolean,
      supplied_file_set_pos_fields: fst$supplied_file_set_positions,
      tape_attachment_specified: boolean,
      undo_option_specified: boolean,
      undo_options: array [1 .. max_tape_attachments] of fst$attachment_option;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR index := 1 TO max_tape_attachments DO
      attachment_options [index].selector := fsc$tape_attachment;
      attachment_options [index].tape_attachment.selector := fsc$tape_null_attachment_option;
      specified [index] := FALSE;
    FOREND;

    FOR index := 1 TO max_tape_attachments DO
      undo_options [index].selector := fsc$tape_attachment;
      undo_options [index].tape_attachment.selector := fsc$tape_null_attachment_option;
    FOREND;

    fsp$evaluate_file_reference (pvt [p$file].value^.file_value^, FALSE {command_file_reference_allowed},
          evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    supplied_file_set_pos_fields := $fst$supplied_file_set_positions [];

    FOR index := p$block_type TO p$volume_accessibility DO
      IF pvt [index].specified THEN
        IF (pvt [index].value^.kind = clc$keyword) AND
              (pvt [index].value^.keyword_value = '$UNSPECIFIED') THEN
          undo_options [attachment_option_keys [index]].tape_attachment.selector :=
                attachment_option_keys [index];
        ELSE
          specified [attachment_option_keys [index]] := TRUE;
          attachment_options [attachment_option_keys [index]].tape_attachment.selector :=
                attachment_option_keys [index];
          CASE index OF
          = p$block_type =
            IF pvt [p$block_type].value^.keyword_value = 'SYSTEM_SPECIFIED' THEN
              attachment_options [fsc$tape_block_type].tape_attachment.tape_block_type :=
                    amc$system_specified;
            ELSE
              attachment_options [fsc$tape_block_type].tape_attachment.tape_block_type :=
                    amc$user_specified;
            IFEND;
          = p$character_conversion =
            attachment_options [fsc$tape_character_conversion].tape_attachment.tape_character_conversion :=
                  pvt [p$character_conversion].value^.boolean_value.value;
          = p$character_set =
            IF pvt [p$character_set].value^.keyword_value = 'ASCII' THEN
              attachment_options [fsc$tape_character_set].tape_attachment.tape_character_set := amc$ascii;
            ELSE
              attachment_options [fsc$tape_character_set].tape_attachment.tape_character_set := amc$ebcdic;
            IFEND;
          = p$creation_date =
            clp$convert_date_time_to_string (pvt [p$creation_date].value^.date_time_value,
                  'Y4J3', date_string, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            attachment_options [fsc$tape_creation_date].tape_attachment.tape_creation_date :=
                  date_string.value (1, 7);
          = p$expiration_date =
            IF pvt [p$expiration_date].value^.kind = clc$keyword THEN { EXPIRED }
              attachment_options [fsc$tape_expiration_date].tape_attachment.tape_expiration_date := '  00000';
            ELSEIF pvt [p$expiration_date].value^.kind = clc$date_time THEN
              clp$convert_date_time_to_string (pvt [p$expiration_date].value^.date_time_value,
                    'Y4J3', date_string, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              attachment_options [fsc$tape_expiration_date].tape_attachment.tape_expiration_date :=
                    date_string.value (1, 7);
            ELSE { time_increment }
              pmp$get_compact_date_time (current_date, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              pmp$compute_date_time (current_date, pvt [p$expiration_date].value^.time_increment_value^,
                    expiration_date.value, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              expiration_date.date_specified := TRUE;
              clp$convert_date_time_to_string (expiration_date, 'Y4J3', date_string, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              attachment_options [fsc$tape_expiration_date].tape_attachment.tape_expiration_date :=
                    date_string.value (1, 7);
            IFEND;
          = p$file_accessibility =
            IF pvt [index].value^.kind = clc$keyword THEN { NONE }
              attachment_options [fsc$tape_file_accessibility].tape_attachment.tape_file_accessibility := ' ';
            ELSEIF pvt [index].value^.kind = clc$name THEN
              rmp$validate_ansi_string (pvt [index].value^.name_value,
                    attachment_options [fsc$tape_file_accessibility].tape_attachment.tape_file_accessibility,
                    status);
            ELSE { string }
              rmp$validate_ansi_string (pvt [index].value^.string_value^,
                    attachment_options [fsc$tape_file_accessibility].tape_attachment.tape_file_accessibility,
                    status);
            IFEND;
            IF NOT status.normal THEN
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    ' for FILE_ACCESSIBILITY parameter', status);
              RETURN;
            IFEND;
          = p$file_identifier =
            IF pvt [index].value^.kind = clc$name THEN
              rmp$validate_ansi_string (pvt [index].value^.name_value,
                    attachment_options [fsc$tape_file_identifier].tape_attachment.tape_file_identifier,
                    status);
            ELSE { string }
              rmp$validate_ansi_string (pvt [index].value^.string_value^,
                    attachment_options [fsc$tape_file_identifier].tape_attachment.tape_file_identifier,
                    status);
            IFEND;
            IF NOT status.normal THEN
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    ' for FILE_IDENTIFIER parameter', status);
              RETURN;
            IFEND;
          = p$file_sequence_number =
            attachment_options [fsc$tape_file_sequence_number].tape_attachment.tape_file_sequence_number :=
                  pvt [index].value^.integer_value.value;
          = p$file_set_identifier =
            IF pvt [index].value^.kind = clc$name THEN
              rmp$validate_ansi_string (pvt [index].value^.name_value,
                    attachment_options [fsc$tape_file_set_identifier].tape_attachment.
                    tape_file_set_identifier, status);
            ELSE { string }
              rmp$validate_ansi_string (pvt [index].value^.string_value^,
                    attachment_options [fsc$tape_file_set_identifier].tape_attachment.
                    tape_file_set_identifier, status);
            IFEND;
            IF NOT status.normal THEN
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    ' for FILE_SET_IDENTIFIER parameter', status);
              RETURN;
            IFEND;
          = p$file_set_position =
            IF pvt [index].value^.kind = clc$keyword THEN
              IF pvt [index].value^.keyword_value = 'BEGINNING_OF_SET' THEN
                attachment_options [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.
                     position := fsc$tape_beginning_of_set;
              ELSEIF pvt [index].value^.keyword_value = 'CURRENT_FILE' THEN
                attachment_options [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.
                     position := fsc$tape_current_file;
              ELSEIF pvt [index].value^.keyword_value = 'END_OF_SET' THEN
                attachment_options [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.
                     position := fsc$tape_end_of_set;
              ELSE { NEXT_FILE }
                attachment_options [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.
                     position := fsc$tape_next_file;
              IFEND;
            ELSE { clc$record }
              IF pvt [index].value^.field_values^ [1].value^.keyword_value = 'FILE_IDENTIFIER_POSITION' THEN
                attachment_options [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.
                      position := fsc$tape_file_identifier_pos;
                IF pvt [index].value^.field_values^ [2].value <> NIL THEN
                  IF pvt [index].value^.field_values^ [2].value^.kind = clc$name THEN
                    rmp$validate_ansi_string (pvt [index].value^.field_values^ [2].value^.name_value,
                          attachment_options [fsc$tape_file_set_position].tape_attachment.
                          tape_file_set_position.file_identifier, status);
                    supplied_file_set_pos_fields := supplied_file_set_pos_fields +
                          $fst$supplied_file_set_positions [fsc$fsp_file_identifier];
                  ELSE { string }
                    rmp$validate_ansi_string (pvt [index].value^.field_values^ [2].value^.string_value^,
                          attachment_options [fsc$tape_file_set_position].tape_attachment.
                          tape_file_set_position.file_identifier, status);
                    supplied_file_set_pos_fields := supplied_file_set_pos_fields +
                          $fst$supplied_file_set_positions [fsc$fsp_file_identifier];
                  IFEND;
                  IF NOT status.normal THEN
                    osp$append_status_parameter (osc$status_parameter_delimiter,
                          ' for FILE_IDENTIFIER field of FILE_SET_POSITION parameter', status);
                    RETURN;
                  IFEND;
                IFEND;
                IF pvt [index].value^.field_values^ [3].value <> NIL THEN
                  attachment_options [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.
                        generation_number := pvt [index].value^.field_values^ [3].value^.integer_value.value;
                  supplied_file_set_pos_fields := supplied_file_set_pos_fields +
                        $fst$supplied_file_set_positions [fsc$fsp_generation_number];
                IFEND;
              ELSE { FILE_SEQUENCE_POSITION }
                attachment_options [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.
                      position := fsc$tape_file_sequence_pos;
                IF pvt [index].value^.field_values^ [2].value <> NIL THEN
                  attachment_options [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.
                        file_sequence_number := pvt [index].value^.field_values^ [2].value^.integer_value.
                        value;
                  supplied_file_set_pos_fields := supplied_file_set_pos_fields +
                        $fst$supplied_file_set_positions [fsc$fsp_file_sequence_number];
                  IF specified [fsc$tape_file_sequence_number] THEN
                    fsp$set_evaluated_file_abnormal (evaluated_file_reference,
                          ame$redundant_file_seq_number, fmc$change_tape_label_attr_cmd, '', message_status);
                    osp$generate_message (message_status, local_status);
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          = p$generation_number =
            attachment_options [fsc$tape_generation_number].tape_attachment.tape_generation_number :=
                 pvt [index].value^.integer_value.value;
          = p$generation_version_number =
            attachment_options [fsc$tape_generation_version_num].tape_attachment.tape_generation_version_num
                  := pvt [index].value^.integer_value.value;
          = p$maximum_block_length =
            attachment_options [fsc$tape_max_block_length].tape_attachment.tape_max_block_length :=
                  pvt [index].value^.integer_value.value;
          = p$maximum_record_length =
            attachment_options [fsc$tape_max_record_length].tape_attachment.tape_max_record_length :=
                 pvt [index].value^.integer_value.value;
          = p$owner_identifier =
            IF pvt [index].value^.kind = clc$keyword THEN { NONE }
              attachment_options [fsc$tape_owner_identification].tape_attachment.tape_owner_identification :=
                    ' ';
            ELSEIF pvt [index].value^.kind = clc$name THEN
              rmp$validate_ansi_string (pvt [index].value^.name_value,
                    attachment_options [fsc$tape_owner_identification].tape_attachment.
                    tape_owner_identification, status);
            ELSE { string }
              rmp$validate_ansi_string (pvt [index].value^.string_value^,
                    attachment_options [fsc$tape_owner_identification].tape_attachment.
                    tape_owner_identification, status);
            IFEND;
            IF NOT status.normal THEN
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    ' for OWNER_IDENTIFIER parameter', status);
              RETURN;
            IFEND;
          = p$padding_character =
            IF pvt [index].value^.kind = clc$name THEN
              attachment_options [fsc$tape_padding_character].tape_attachment.tape_padding_character :=
                    pvt [index].value^.name_value (1);
            ELSE
              attachment_options [fsc$tape_padding_character].tape_attachment.tape_padding_character :=
                    pvt [index].value^.string_value^ (1);
            IFEND;
          = p$record_type =
            IF pvt [index].value^.keyword_value = 'ANSI_FIXED' THEN
              attachment_options [fsc$tape_record_type].tape_attachment.tape_record_type :=
                    amc$ansi_fixed;
            ELSEIF pvt [index].value^.keyword_value = 'ANSI_SPANNED' THEN
              attachment_options [fsc$tape_record_type].tape_attachment.tape_record_type :=
                    amc$ansi_spanned;
            ELSEIF pvt [index].value^.keyword_value = 'ANSI_VARIABLE' THEN
              attachment_options [fsc$tape_record_type].tape_attachment.tape_record_type :=
                    amc$ansi_variable;
            ELSEIF pvt [index].value^.keyword_value = 'UNDEFINED' THEN
              attachment_options [fsc$tape_record_type].tape_attachment.tape_record_type :=
                    amc$undefined;
            ELSEIF pvt [index].value^.keyword_value = 'VARIABLE' THEN
              attachment_options [fsc$tape_record_type].tape_attachment.tape_record_type :=
                    amc$variable;
            IFEND;
          = p$removable_media_group =
            attachment_options [fsc$tape_removable_media_group].tape_attachment.tape_removable_media_group :=
                  pvt [index].value^.name_value;
          = p$rewrite_labels =
            attachment_options [fsc$tape_rewrite_labels].tape_attachment.tape_rewrite_labels :=
                  pvt [p$rewrite_labels].value^.boolean_value.value;
          = p$volume_accessibility =
            IF pvt [index].value^.kind = clc$keyword THEN { NONE }
              attachment_options [fsc$tape_volume_accessibility].tape_attachment.tape_volume_accessibility :=
                    ' ';
            ELSEIF pvt [index].value^.kind = clc$name THEN
              rmp$validate_ansi_string (pvt [index].value^.name_value,
                    attachment_options [fsc$tape_volume_accessibility].tape_attachment.
                    tape_volume_accessibility, status);
            ELSE { string }
              rmp$validate_ansi_string (pvt [index].value^.string_value^,
                    attachment_options [fsc$tape_volume_accessibility].tape_attachment.
                    tape_volume_accessibility, status);
            IFEND;
            IF NOT status.normal THEN
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    ' for VOLUME_ACCESSIBILITY parameter', status);
              RETURN;
            IFEND;

          ELSE
          CASEND;
        IFEND;
      IFEND;
    FOREND;

    tape_attachment_specified := FALSE;
  /search_specified/
    FOR index := 1 TO max_tape_attachments DO
      IF specified [index] THEN
        tape_attachment_specified := TRUE;
        EXIT /search_specified/;
      IFEND;
    FOREND /search_specified/;

    undo_option_specified := FALSE;
  /search_undo/
    FOR index := 1 TO max_tape_attachments DO
      IF undo_options [index].tape_attachment.selector <> fsc$tape_null_attachment_option THEN
        undo_option_specified := TRUE;
        fsp$default_tape_label_attrib (fsc$tla_system_default, undo_options, returned_attributes, status);
        EXIT /search_undo/;
      IFEND;
    FOREND /search_undo/;

    fsp$evaluate_file_reference (pvt [p$file].value^.file_value^, FALSE {command_file_reference_allowed},
          evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    validate_tape_attachments (status);

    IF status.normal THEN
      IF tape_attachment_specified THEN
        bap$store_tape_label_attributes (evaluated_file_reference, attachment_options,
            supplied_file_set_pos_fields, fsc$tape_label_attr_command, status);
      IFEND;
      IF status.normal AND undo_option_specified THEN
        bap$store_tape_label_attributes (evaluated_file_reference, undo_options,
            supplied_file_set_pos_fields, fsc$tape_label_attr_default, status);
      IFEND;
    IFEND;

    IF NOT status.normal THEN
      IF status.condition = ame$improper_device_class THEN
        fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_device_class,
              fmc$change_tape_label_attr_cmd, 'MASS_STORAGE/NULL/TERMINAL', status);
      ELSEIF status.condition = ame$file_not_known THEN
        fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_not_known,
              fmc$change_tape_label_attr_cmd, 'CHANGE_TAPE_LABEL_ATTRIBUTES', status);
      ELSEIF status.condition = ame$file_attachment_required THEN
        fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_attachment_required,
              fmc$change_tape_label_attr_cmd, 'CHANGE_TAPE_LABEL_ATTRIBUTES', status);
      ELSEIF status.condition = fme$no_cycle_description THEN
        fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_not_known,
              fmc$change_tape_label_attr_cmd, 'CHANGE_TAPE_LABEL_ATTRIBUTES', status);
      IFEND;
    IFEND;

  PROCEND clp$change_tape_label_attr_cmd;

?? TITLE := 'PROCEDURE clp$$tape_label_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$$tape_label_attributes
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$tape_label_attributes) $tape_label_attributes (
{   file: any of
{       key
{         (system_default_values, system_default_value, sdv)
{       keyend
{       file
{     anyend = $required
{   source: key
{       (explicit_specification, es)
{       (last_accessed, la)
{       (next_position, np)
{     keyend = next_position
{   attributes: list rest of key
{       all
{       (block_count, bc)
{       (block_type, bt)
{       (buffer_offset, bo)
{       (character_conversion, cc)
{       (character_set, cs)
{       (creation_date, cd)
{       (expiration_date, ed)
{       (file_identifier, fi)
{       (file_sequence_number, fsn)
{       (file_set_identifier, fsi)
{       (file_set_position, fsp)
{       (generation_number, gn)
{       (generation_version_number, gvn)
{       (header_labels, hl)
{       (maximum_block_length, maxbl)
{       (maximum_record_length, maxrl)
{       (padding_character, pc)
{       (record_type, rt)
{       (rewrite_labels, rl)
{       (trailer_labels, tl)
{     advanced_key
{       (file_accessibility, fa)
{       (file_section_number, fsen)
{       (implementation_identifier, ii)
{       (label_standard_version, lsv)
{       (owner_identifier, oi)
{       (removable_media_group, rmg)
{       (volume_accessibility, va)
{     keyend = all
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (13),
      recend,
      type3: 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 .. 55] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
    recend := [
    [1,
    [91, 4, 5, 17, 2, 48, 347],
    clc$function, 3, 3, 1, 0, 0, 0, 0, ''], [
    ['ATTRIBUTES                     ',clc$nominal_entry, 3],
    ['FILE                           ',clc$nominal_entry, 1],
    ['SOURCE                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, 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, 141,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, 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, 229,
  clc$optional_default_parameter, 0, 13],
{ PARAMETER 3
    [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, 2058,
  clc$optional_default_parameter, 0, 3]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SDV                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['SYSTEM_DEFAULT_VALUE           ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['SYSTEM_DEFAULT_VALUES          ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [6], [
    ['ES                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['EXPLICIT_SPECIFICATION         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['LA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['LAST_ACCESSED                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['NEXT_POSITION                  ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['NP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3]]
    ,
    'next_position'],
{ PARAMETER 3
    [[1, 0, clc$list_type], [2042, 1, clc$max_list_size, 0, FALSE, TRUE],
      [[1, 0, clc$keyword_type], [55], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['BC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['BLOCK_COUNT                    ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['BLOCK_TYPE                     ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['BO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['BT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['BUFFER_OFFSET                  ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['CC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['CD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['CHARACTER_CONVERSION           ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['CHARACTER_SET                  ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['CREATION_DATE                  ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['CS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['ED                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
      ['EXPIRATION_DATE                ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['FA                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 22],
      ['FI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
      ['FILE_ACCESSIBILITY             ', clc$nominal_entry, clc$advanced_usage_entry, 22],
      ['FILE_IDENTIFIER                ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['FILE_SECTION_NUMBER            ', clc$nominal_entry, clc$advanced_usage_entry, 23],
      ['FILE_SEQUENCE_NUMBER           ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['FILE_SET_IDENTIFIER            ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['FILE_SET_POSITION              ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['FSEN                           ', clc$abbreviation_entry, clc$advanced_usage_entry, 23],
      ['FSI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
      ['FSN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
      ['FSP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
      ['GENERATION_NUMBER              ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['GENERATION_VERSION_NUMBER      ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['GN                             ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
      ['GVN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
      ['HEADER_LABELS                  ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['HL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
      ['II                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 24],
      ['IMPLEMENTATION_IDENTIFIER      ', clc$nominal_entry, clc$advanced_usage_entry, 24],
      ['LABEL_STANDARD_VERSION         ', clc$nominal_entry, clc$advanced_usage_entry, 25],
      ['LSV                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 25],
      ['MAXBL                          ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
      ['MAXIMUM_BLOCK_LENGTH           ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['MAXIMUM_RECORD_LENGTH          ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['MAXRL                          ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
      ['OI                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 26],
      ['OWNER_IDENTIFIER               ', clc$nominal_entry, clc$advanced_usage_entry, 26],
      ['PADDING_CHARACTER              ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['PC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
      ['RECORD_TYPE                    ', clc$nominal_entry, clc$normal_usage_entry, 19],
      ['REMOVABLE_MEDIA_GROUP          ', clc$nominal_entry, clc$advanced_usage_entry, 27],
      ['REWRITE_LABELS                 ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['RL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 20],
      ['RMG                            ', clc$abbreviation_entry, clc$advanced_usage_entry, 27],
      ['RT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
      ['TL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 21],
      ['TRAILER_LABELS                 ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['VA                             ', clc$abbreviation_entry, clc$advanced_usage_entry, 28],
      ['VOLUME_ACCESSIBILITY           ', clc$nominal_entry, clc$advanced_usage_entry, 28]]
      ]
    ,
    'all']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$source = 2,
      p$attributes = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      attributes_requested: current_tape_attachments,
      attributes: array [1 .. max_tape_attachments] of fst$attachment_option,
      current_option: ^clt$data_value,
      number_of_attributes_requested: ost$non_negative_integers,
      result_node: ^^clt$data_value,
      returned_attributes: fst$tla_returned_attributes,
      source: fst$tape_attribute_source,
      tape_attachment_choice: fst$tape_attachment_choices;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    attributes_requested :=  $current_tape_attachments [];
    number_of_attributes_requested := 0;
    current_option := pvt [p$attributes].value;

  /determine_attributes_requested/
    WHILE current_option <> NIL DO
      IF current_option^.element_value^.keyword_value = 'ALL' THEN
        enforce_security (number_of_attributes_requested, attributes_requested);
        EXIT /determine_attributes_requested/;
      ELSE
        get_tape_attachment_choice (current_option^.element_value^.keyword_value, tape_attachment_choice);
        IF NOT (tape_attachment_choice IN attributes_requested) THEN
          attributes_requested := attributes_requested + $current_tape_attachments [tape_attachment_choice];
          number_of_attributes_requested := number_of_attributes_requested + 1;
        IFEND;
      IFEND;
      current_option := current_option^.link;
    WHILEND /determine_attributes_requested/;

    FOR tape_attachment_choice := 1 TO max_tape_attachments DO
      IF tape_attachment_choice IN attributes_requested THEN
        attributes [tape_attachment_choice].selector := fsc$tape_attachment;
        attributes [tape_attachment_choice].tape_attachment.selector := tape_attachment_choice;
      ELSE
        attributes [tape_attachment_choice].selector := fsc$null_attachment_option;
      IFEND;
    FOREND;

    IF pvt [p$file].value^.kind = clc$keyword THEN { system_default_values }
      fsp$default_tape_label_attrib (fsc$tla_system_default, attributes, returned_attributes, status);
    ELSE
      IF pvt [p$source].value^.keyword_value = 'LAST_ACCESSED' THEN
        source := fsc$tla_last_ansi_file_accessed;
      ELSEIF pvt [p$source].value^.keyword_value = 'EXPLICIT_SPECIFICATION' THEN
        source := fsc$tla_explicit_specification;
      ELSE
        source := fsc$tla_next_position;
      IFEND;
      IF fsc$tape_header_labels IN attributes_requested THEN
        PUSH attributes [fsc$tape_header_labels].tape_attachment.tape_header_labels:
              [[REP 1 OF fst$tape_label_sequence_header, REP (fsc$max_tape_labels *
              (#SIZE (fst$tape_label_block_descriptor) + fsc$max_tape_label_length)) OF cell]];
      IFEND;
      IF fsc$tape_trailer_labels IN attributes_requested THEN
        PUSH attributes [fsc$tape_trailer_labels].tape_attachment.tape_header_labels:
              [[REP 1 OF fst$tape_label_sequence_header, REP (fsc$max_tape_labels *
              (#SIZE (fst$tape_label_block_descriptor) + fsc$max_tape_label_length)) OF cell]];
      IFEND;
      fsp$get_tape_label_attributes (pvt [p$file].value^.file_value^, source, attributes,
            returned_attributes, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_record_value (number_of_attributes_requested, work_area, result);

    build_display_record (attributes, attributes_requested, returned_attributes, work_area, result, status);

  PROCEND clp$$tape_label_attributes;

?? TITLE := 'PROCEDURE build_display_record', EJECT ??

  PROCEDURE build_display_record
    (   attributes: fst$attachment_options;
        attributes_requested: current_tape_attachments;
        returned_attributes: fst$tla_returned_attributes;
    VAR work_area: ^clt$work_area;
    VAR result: ^clt$data_value;
    VAR status: ost$status);

?? NEWTITLE := 'convert_labels', EJECT ??
    PROCEDURE [INLINE] convert_labels
      (    label_sequence: ^SEQ ( * );
       VAR result: ^clt$data_value);

     VAR
       block_number: fst$tape_label_count,
       label_identifier: fst$tape_label_identifier,
       label_locator: fst$tape_label_locator,
       label_string: ^string (* <= fsc$max_tape_label_length),
       local_sequence: ^SEQ ( * ),
       result_p: ^^clt$data_value,
       sequence_header: ^fst$tape_label_sequence_header;

      result_p := ^result;
      result := NIL;
      local_sequence := label_sequence;

      NEXT sequence_header IN local_sequence;
      label_identifier.location_method := fsc$tape_label_locate_by_index;
      FOR block_number := 1 TO sequence_header^.label_count DO
        label_identifier.label_index := block_number;
        fsp$locate_tape_label (local_sequence, label_identifier, label_locator);
        IF label_locator.label_found AND (label_locator.label_block_descriptor^.label_block_type =
              fsc$normal_tape_label_block) THEN
          clp$make_list_value (work_area, result_p^);
          NEXT label_string: [label_locator.label_block_descriptor^.normal_label_transfer_length] IN
                label_locator.label_block;
          clp$make_string_value (label_string^, work_area, result_p^^.element_value);
          result_p := ^result_p^^.link;
        IFEND;
      FOREND;

      IF result = NIL THEN
        clp$make_list_value (work_area, result);
      IFEND;

    PROCEND convert_labels;
?? OLDTITLE, EJECT ??

    VAR
      character_string: string (1),
      current_field_number: ost$positive_integers,
      date: clt$date_time,
      fsp_value_pp: ^^clt$data_value,
      tape_option: 1 .. max_displayable_attributes;

    status.normal := TRUE;
    current_field_number := 1;

    FOR tape_option := 1 TO max_displayable_attributes DO
      IF tape_attachment_names [tape_option].ordinal IN attributes_requested THEN
        result^.field_values^[current_field_number].name := tape_attachment_names [tape_option].text;
        IF NOT (tape_attachment_names [tape_option].ordinal IN returned_attributes) THEN
          clp$make_unspecified_value (work_area, result^.field_values^[current_field_number].value);
        ELSE
          CASE tape_attachment_names [tape_option].ordinal OF
          = fsc$tape_block_count =
            clp$make_integer_value (attributes [fsc$tape_block_count].tape_attachment.tape_block_count,
                  10, FALSE, work_area, result^.field_values^[current_field_number].value);

          = fsc$tape_block_type =
            clp$make_keyword_value (block_types [attributes [fsc$tape_block_type].tape_attachment.
                  tape_block_type], work_area, result^.field_values^ [current_field_number].value);

          = fsc$tape_buffer_offset =
            clp$make_integer_value (attributes [fsc$tape_buffer_offset].tape_attachment.tape_buffer_offset,
                  10, FALSE, work_area, result^.field_values^[current_field_number].value);

          = fsc$tape_character_conversion =
            clp$make_boolean_value (attributes [fsc$tape_character_conversion].tape_attachment.
                  tape_character_conversion, clc$yes_no_boolean, work_area,
                  result^.field_values^[current_field_number].value);

          = fsc$tape_character_set =
            clp$make_keyword_value (character_sets [attributes [fsc$tape_character_set].tape_attachment.
                  tape_character_set], work_area, result^.field_values^[current_field_number].value);

          = fsc$tape_creation_date =
            clp$convert_string_to_date_time (attributes [fsc$tape_creation_date].tape_attachment.
                  tape_creation_date, 'Y4J3', date, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            clp$make_date_time_value (date, work_area, result^.field_values^[current_field_number].value);

          = fsc$tape_expiration_date =
            IF attributes [fsc$tape_expiration_date].tape_attachment.tape_expiration_date = '  00000' THEN
              clp$make_keyword_value ('EXPIRED', work_area,
                    result^.field_values^[current_field_number].value);
            ELSE
              clp$convert_string_to_date_time (attributes [fsc$tape_expiration_date].tape_attachment.
                    tape_expiration_date, 'Y4J3', date, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              clp$make_date_time_value (date, work_area, result^.field_values^[current_field_number].value);
            IFEND;

          = fsc$tape_file_accessibility =
            clp$make_string_value (attributes [fsc$tape_file_accessibility].tape_attachment.
                  tape_file_accessibility, work_area, result^.field_values^ [current_field_number].value);

          = fsc$tape_file_identifier =
            clp$make_string_value (attributes [fsc$tape_file_identifier].tape_attachment.tape_file_identifier,
                  work_area, result^.field_values^ [current_field_number].value);

          = fsc$tape_file_section_number =
            clp$make_integer_value (attributes [fsc$tape_file_section_number].tape_attachment.
                  tape_file_section_number, 10, FALSE, work_area,
                  result^.field_values^[current_field_number].value);

          = fsc$tape_file_sequence_number =
            clp$make_integer_value (attributes [fsc$tape_file_sequence_number].tape_attachment.
                  tape_file_sequence_number, 10, FALSE, work_area,
                  result^.field_values^[current_field_number].value);

          = fsc$tape_file_set_identifier =
            clp$make_string_value (attributes [fsc$tape_file_set_identifier].tape_attachment.
                  tape_file_set_identifier, work_area, result^.field_values
                  ^[current_field_number].value);

          = fsc$tape_file_set_position =
            fsp_value_pp := ^result^.field_values^ [current_field_number].value;
            IF attributes [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.position =
                  fsc$tape_file_identifier_pos THEN
              clp$make_record_value (3, work_area, fsp_value_pp^);
              fsp_value_pp^^.field_values^[1].name := 'METHOD';
              clp$make_keyword_value (file_set_position [attributes [fsc$tape_file_set_position].
                    tape_attachment.tape_file_set_position.position], work_area,
                    fsp_value_pp^^.field_values^[1].value);
              fsp_value_pp^^.field_values^[2].name := 'FILE_IDENTIFIER';
              clp$make_string_value (attributes [fsc$tape_file_set_position].tape_attachment.
                    tape_file_set_position.file_identifier, work_area, fsp_value_pp^^.
                    field_values^[2].value);
              fsp_value_pp^^.field_values^[3].name := 'GENERATION_NUMBER';
              clp$make_integer_value (attributes [fsc$tape_file_set_position].tape_attachment.
                    tape_file_set_position.generation_number, 10, FALSE, work_area,
                    fsp_value_pp^^.field_values^[3].value);

            ELSEIF attributes [fsc$tape_file_set_position].tape_attachment.tape_file_set_position.position =
                  fsc$tape_file_sequence_pos THEN
              clp$make_record_value (2, work_area, fsp_value_pp^);
              fsp_value_pp^^.field_values^[1].name := 'METHOD';
              clp$make_keyword_value (file_set_position [attributes [fsc$tape_file_set_position].
                    tape_attachment.tape_file_set_position.position], work_area,
                    fsp_value_pp^^.field_values^[1].value);
              fsp_value_pp^^.field_values^[2].name := 'FILE_SEQUENCE_NUMBER';
              clp$make_integer_value (attributes [fsc$tape_file_set_position].tape_attachment.
                    tape_file_set_position.file_sequence_number, 10, FALSE, work_area,
                    fsp_value_pp^^.field_values^[2].value);

            ELSE
              clp$make_keyword_value (file_set_position [attributes [fsc$tape_file_set_position].
                    tape_attachment.tape_file_set_position.position], work_area, fsp_value_pp^);
            IFEND;

          = fsc$tape_generation_number =
            clp$make_integer_value (attributes [fsc$tape_generation_number].tape_attachment.
                  tape_generation_number, 10, FALSE, work_area,
                  result^.field_values^[current_field_number].value);

          = fsc$tape_generation_version_num =
            clp$make_integer_value (attributes [fsc$tape_generation_version_num].tape_attachment.
                  tape_generation_version_num, 10, FALSE, work_area,
                  result^.field_values^[current_field_number].value);

          = fsc$tape_header_labels =
            convert_labels (attributes [fsc$tape_header_labels].tape_attachment.tape_header_labels,
                  result^.field_values^[current_field_number].value);

          = fsc$tape_implementation_id =
            clp$make_string_value (attributes [fsc$tape_implementation_id].tape_attachment.
                  tape_implementation_id, work_area, result^.field_values^[current_field_number].value);

          = fsc$tape_label_standard_version =
            clp$make_integer_value (attributes [fsc$tape_label_standard_version].tape_attachment.
                  tape_label_standard_version, 10, FALSE, work_area,
                  result^.field_values^[current_field_number].value);

          = fsc$tape_max_block_length =
            clp$make_integer_value (attributes [fsc$tape_max_block_length].tape_attachment.
                  tape_max_block_length, 10, FALSE, work_area,
                  result^.field_values^[current_field_number].value);

          = fsc$tape_max_record_length =
            clp$make_integer_value (attributes [fsc$tape_max_record_length].tape_attachment.
                  tape_max_record_length, 10, FALSE, work_area,
                  result^.field_values^[current_field_number].value);

          = fsc$tape_owner_identification =
            clp$make_string_value (attributes [fsc$tape_owner_identification].tape_attachment.
                  tape_owner_identification, work_area, result^.field_values^[current_field_number].value);

          = fsc$tape_padding_character =
            character_string := attributes [fsc$tape_padding_character].tape_attachment.
                  tape_padding_character;
            clp$make_string_value (character_string, work_area,
                  result^.field_values^ [current_field_number].value);

          = fsc$tape_record_type =
            clp$make_keyword_value (record_types [attributes [fsc$tape_record_type].tape_attachment.
                  tape_record_type], work_area, result^.field_values^[current_field_number].value);

          = fsc$tape_removable_media_group =
            clp$make_name_value (attributes [fsc$tape_removable_media_group].tape_attachment.
                  tape_removable_media_group, work_area, result^.field_values^[current_field_number].value);

          = fsc$tape_rewrite_labels =
            clp$make_boolean_value (attributes [fsc$tape_rewrite_labels].tape_attachment.tape_rewrite_labels,
                  clc$yes_no_boolean, work_area, result^.field_values^[current_field_number].value);

          = fsc$tape_trailer_labels =
            convert_labels (attributes [fsc$tape_trailer_labels].tape_attachment.tape_header_labels,
                  result^.field_values^[current_field_number].value);

          = fsc$tape_volume_accessibility =
            clp$make_string_value (attributes [fsc$tape_volume_accessibility].tape_attachment.
                  tape_volume_accessibility, work_area, result^.field_values^[current_field_number].value);

          ELSE
            ;
          CASEND;
        IFEND;
        current_field_number := current_field_number + 1;
      IFEND;
    FOREND;

  PROCEND build_display_record;

?? TITLE := 'PROCEDURE enforce_security', EJECT ??
  PROCEDURE enforce_security
    (VAR number_of_attributes_requested: ost$non_negative_integers;
     VAR attributes_requested: current_tape_attachments);

    IF avp$removable_media_admin () THEN
      number_of_attributes_requested := max_displayable_attributes;
      attributes_requested := -$current_tape_attachments [fsc$tape_null_attachment_option];
    ELSE
      number_of_attributes_requested := max_displayable_attributes - 4;
      attributes_requested := -$current_tape_attachments [fsc$tape_null_attachment_option,
            fsc$tape_file_accessibility, fsc$tape_owner_identification, fsc$tape_removable_media_group,
            fsc$tape_volume_accessibility];
    IFEND;

  PROCEND enforce_security;

?? TITLE := 'PROCEDURE get_tape_attachment_choice', EJECT ??

  PROCEDURE get_tape_attachment_choice (
        text: ost$name;
    VAR tape_attachment_choice: fst$tape_attachment_choices);

    VAR
      i: 1 .. max_displayable_attributes;

    FOR i := 1 TO max_displayable_attributes DO
      IF (tape_attachment_names [i].text = text) THEN
        tape_attachment_choice := tape_attachment_names [i].ordinal;
        RETURN;
      IFEND;
    FOREND;

  PROCEND get_tape_attachment_choice;
?? OLDTITLE ??
MODEND clm$tape_label_commands;
*DECK DECK=CLM$TAPE_SCAN_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE clm$tape_scan_commands;

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$max_integer
*copyc cld$value
*copyc clt$display_control
*copyc ofe$error_codes
*copyc ost$status
*copyc ost$string
?? POP ??

*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc iop$change_tape_scan_freq_23d
*copyc iop$fetch_tape_scan_frequency
*copyc osp$establish_condition_handler

  PROCEDURE [XDCL, #GATE] clp$_change_tape_scan_freq_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE change_tape_scan_frequency (
{   scan_frequency: integer 1..clc$max_integer = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 12, 5, 18, 23, 0, 540],
    clc$command, 2, 2, 1, 0, 0, 0, 2, ''], [
    ['SCAN_FREQUENCY                 ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [1, clc$max_integer, 10]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$scan_frequency = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    iop$change_tape_scan_freq_23d (pvt [p$scan_frequency].value^.integer_value.value, status);

  PROCEND clp$_change_tape_scan_freq_cmd;

  PROCEDURE [XDCL, #GATE] clp$_display_tape_scan_freq_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_tape_scan_frequency, distsf (
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 11, 26, 16, 48, 5, 297],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

*copyc clp$abort_handler
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_file
*copyc clp$get_parameter
*copyc clp$get_path_description
*copyc clp$get_path_name
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$new_page_procedure
*copyc clp$open_display
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$put_partial_display
*copyc clp$put_path_subtitle
*copyc clp$reset_for_next_display_page
*copyc clp$trimmed_string_size
*copyc clv$display_variables
*copyc clv$value_descriptors

?? EJECT ??

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

      clv$subtitles_built := TRUE;

    PROCEND put_subtitle;

?? EJECT ??

    PROCEDURE put_attribute
      (    header: string ( * );
           value: string ( * ));

      VAR
        ignore_status: ost$status,
        start_option: amt$term_option,
        edited_header: string (tab_over);

      CONST
        max_attribute_name_size = 22,
        tab_over = max_attribute_name_size + 3;

      start_option := amc$start;
      edited_header := header;
      edited_header (tab_over - 1) := ':';

      clp$put_partial_display (display_control, edited_header, clc$no_trim, start_option, status);
      IF NOT status.normal THEN
        clp$close_display (display_control, ignore_status);
        EXIT clp$_display_tape_scan_freq_cmd;
      IFEND;
      clp$put_partial_display (display_control, value, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        clp$close_display (display_control, ignore_status);
        EXIT clp$_display_tape_scan_freq_cmd;
      IFEND;
    PROCEND put_attribute;
?? EJECT ??

    PROCEDURE clean_up;

      VAR
        ignore_status: ost$status;

      IF output_open THEN
        clp$close_display (display_control, ignore_status);
        output_open := FALSE;
      IFEND;

    PROCEND clean_up;

    {  Begin main procedure  }

    VAR
      value: clt$value,
      display_control: clt$display_control,
      output_file: clt$file,
      output_open: boolean,
      scan_frequency: integer,
      scan_frequency_string: ost$string;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_string_to_file (pvt [p$output].value^.file_value^, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_open := FALSE;
    osp$establish_condition_handler (^clp$abort_handler, FALSE);

    clp$open_display (output_file, ^clp$new_page_procedure, display_control, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    output_open := TRUE;
    clv$titles_built := FALSE;
    clv$subtitles_built := FALSE;
    clv$command_name := 'display_tape_scan_frequency';

    IF display_control.page_width < clc$narrow_page_width THEN
      clv$page_width := clc$narrow_page_width;
    ELSEIF display_control.page_width > clc$wide_page_width THEN
      clv$page_width := clc$wide_page_width;
    ELSE
      clv$page_width := display_control.page_width;
    IFEND;

    iop$fetch_tape_scan_frequency (scan_frequency, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$convert_integer_to_string (scan_frequency, {radix} 10, {include_radix} FALSE, scan_frequency_string,
          status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    IF status.normal THEN
      IF scan_frequency > 1 THEN
        scan_frequency_string.value (scan_frequency_string.size + 1, 8) := ' seconds';
        scan_frequency_string.size := scan_frequency_string.size + 8;
      ELSE
        scan_frequency_string.value (scan_frequency_string.size + 1, 7) := ' second';
        scan_frequency_string.size := scan_frequency_string.size + 7;
      IFEND;
      put_attribute ('Tape Scan Frequency', scan_frequency_string.
            value (1, scan_frequency_string.size));
    IFEND;

    clp$close_display (display_control, status);
    IF status.normal THEN
      output_open := FALSE;
    IFEND;

  PROCEND clp$_display_tape_scan_freq_cmd;
MODEND clm$tape_scan_commands;
*DECK DECK=CLM$TAPE_VALIDATION_COMMANDS EXPAND=TRUE

*copyc osd$default_pragmats

MODULE clm$tape_validation_commands;

*copyc bap$fetch_tape_validation
*copyc bap$get_tape_security_state
*copyc bap$put_tape_security_state
*copyc bap$store_tape_validation
*copyc cld$value
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_parameter_list
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc clt$display_control
*copyc clt$path_display_chunks
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal
*copyc oss$job_paged_literal
*copyc ost$status
?? EJECT ??

  PROCEDURE [XDCL, #GATE] clp$display_tape_validate_cmd (
        parameter_list: clt$parameter_list;
    VAR status: ost$status);


{  PROCEDURE display_tape_validation, distv (
{    output, o: FILE = $output
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 9, 20, 8, 37, 45, 231],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;



*copyc clp$get_path_name
*copyc clp$put_path_subtitle
*copyc clp$reset_for_next_display_page
*copyc clp$new_display_line
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$put_partial_display
*copyc clp$horizontal_tab_display
*copyc clp$get_path_description
*copyc clp$get_parameter
*copyc clp$open_display
*copyc clp$close_display
*copyc clp$put_partial_display
*copyc clp$put_display
*copyc clv$display_variables
*copyc clv$value_descriptors
*copyc clp$abort_handler
*copyc clp$new_page_procedure
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_file

    CONST
      max_tape_validation_size = 4;

    VAR
      tape_validation_string: [STATIC, READ, oss$job_paged_literal]
       array [bat$tape_validation_state] of record
        size: 1 .. max_tape_validation_size,
        value: string (max_tape_validation_size),
      recend := [[4, 'none'],[2, 'on'], [3, 'off']];

?? EJECT ??

    PROCEDURE put_subtitle (VAR display_control: clt$display_control;
      VAR status: ost$status);

      clv$subtitles_built := TRUE;

    PROCEND put_subtitle;

?? EJECT ??

    PROCEDURE put_attribute (header: string ( * );
          value: string ( * ));

      VAR
        ignore_status: ost$status,
        start_option: amt$term_option,
        edited_header: string (tab_over);

      CONST
        max_attribute_name_size = 22,
        tab_over = max_attribute_name_size + 3;

      status.normal := TRUE;
      start_option := amc$start;
      edited_header := header;
      edited_header (tab_over - 1) := ':';

      clp$put_partial_display (display_control, edited_header, clc$no_trim, start_option, status);
      IF NOT status.normal THEN
        clp$close_display (display_control, ignore_status);
        EXIT clp$display_tape_validate_cmd;
      IFEND;
      clp$put_partial_display (display_control, value, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        clp$close_display (display_control, ignore_status);
        EXIT clp$display_tape_validate_cmd;
      IFEND;
    PROCEND put_attribute;
?? EJECT ??

    PROCEDURE clean_up;

      VAR
        ignore_status: ost$status;

      IF output_open THEN
        clp$close_display (display_control, ignore_status);
        output_open := FALSE;
      IFEND;

    PROCEND clean_up;

 {  Begin main procedure  }

    VAR
      value: clt$value,
      display_control: clt$display_control,
      enforce_tape_security: bat$tape_validation_state,
      output_file: clt$file,
      output_open: boolean,
      tape_validation: bat$tape_validation_state;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #seq (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_string_to_file (pvt [p$output].value^.file_value^, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_open := FALSE;
    osp$establish_condition_handler (^clp$abort_handler, false);

    clp$open_display (output_file, ^clp$new_page_procedure, display_control, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    output_open := TRUE;
    clv$titles_built := FALSE;
    clv$subtitles_built := FALSE;
    clv$command_name := 'display_tape_validation';

    IF display_control.page_width < clc$narrow_page_width THEN
      clv$page_width := clc$narrow_page_width;
    ELSEIF display_control.page_width > clc$wide_page_width THEN
      clv$page_width := clc$wide_page_width;
    ELSE
      clv$page_width := display_control.page_width;
    IFEND;

    bap$fetch_tape_validation( tape_validation, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    put_attribute ('Validate_Tape_Access', tape_validation_string [tape_validation].value
        (1, tape_validation_string [tape_validation].size));

    bap$get_tape_security_state(enforce_tape_security, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    put_attribute ('Enforce_Tape_Security', tape_validation_string [enforce_tape_security].value
        (1, tape_validation_string [enforce_tape_security].size));
    clp$close_display (display_control, status);
    IF status.normal THEN
      output_open := FALSE;
    IFEND;

  PROCEND clp$display_tape_validate_cmd;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] clp$change_tape_validation_cmd (
        parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE change_tape_validation, chatv (
{   validate_tape_access, vta: boolean = $optional
{   enforce_tape_security, ets: (BY_NAME) boolean = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 2, 1, 0, 0, 17, 638],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['ENFORCE_TAPE_SECURITY          ',clc$nominal_entry, 2],
    ['ETS                            ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['VALIDATE_TAPE_ACCESS           ',clc$nominal_entry, 1],
    ['VTA                            ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type]],
{ PARAMETER 2
    [[1, 0, clc$boolean_type]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$validate_tape_access = 1,
      p$enforce_tape_security = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      enforce_tape_security: bat$tape_validation_state,
      value: clt$value,
      tape_validation: bat$tape_validation_state;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$validate_tape_access].specified OR pvt [p$enforce_tape_security].specified THEN
      IF pvt [p$validate_tape_access].specified THEN
        IF pvt [p$validate_tape_access].value^.boolean_value.value THEN
          tape_validation := bac$tape_validation_on;
        ELSE
          tape_validation := bac$tape_validation_off;
        IFEND;
        bap$store_tape_validation (tape_validation, status);
      IFEND;

      IF pvt [p$enforce_tape_security].specified THEN
        IF pvt [p$enforce_tape_security].value^.boolean_value.value THEN
          enforce_tape_security := bac$tape_validation_on;
        ELSE
          enforce_tape_security := bac$tape_validation_off;
        IFEND;
        bap$put_tape_security_state (enforce_tape_security, status);
      IFEND;
    ELSE
     osp$set_status_abnormal ('CL', cle$required_parameter_omitted,
            'ENFORCE_TAPE_SECURITY or VALIDATE_TAPE_ACCESS', status);
    IFEND;
  PROCEND clp$change_tape_validation_cmd;

MODEND clm$tape_validation_commands;
*DECK DECK=CLM$TERMINATE_TAPE_ASSIGNMENT EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE SCL Interpreter : Terminate Tape Assignment Command' ??
MODULE clm$terminate_tape_assignment;

{  PURPOSE:
{    This module contains the processor for the TERMINATE_TAPE_ASSIGNMENT command.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_file_reference
*copyc jmt$name
*copyc jmt$system_supplied_name
*copyc rmc$condition_code_limits
?? POP ??

*copyc clp$evaluate_parameters
*copyc iop$terminate_tape_assignment
*copyc jmp$validate_name
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
*copyc osv$lower_to_upper
*copyc rmp$validate_ansi_string

?? OLDTITLE ??
?? NEWTITLE := 'clp$terminate_tape_assignment', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$terminate_tape_assignment
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (clm$terta) terminate_tape_assignment, terta (
{   external_vsn, evsn, ev: any of
{       string 1..6
{       name 1..6
{     anyend = $required
{   message, m : string 0 .. 80 = $optional
{   job_name, jn : name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 6, 15, 19, 33, 5, 547],
    clc$command, 8, 4, 1, 0, 0, 0, 4, 'CLM$TERTA'], [
    ['EV                             ',clc$abbreviation_entry, 1],
    ['EVSN                           ',clc$alias_entry, 1],
    ['EXTERNAL_VSN                   ',clc$nominal_entry, 1],
    ['JN                             ',clc$abbreviation_entry, 3],
    ['JOB_NAME                       ',clc$nominal_entry, 3],
    ['M                              ',clc$abbreviation_entry, 2],
    ['MESSAGE                        ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [1, 6, FALSE]],
    5, [[1, 0, clc$name_type], [1, 6]]
    ],
{ PARAMETER 2
    [[1, 0, clc$string_type], [0, 80, FALSE]],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$external_vsn = 1,
      p$message = 2,
      p$job_name = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      candidate_name: jmt$name,
      element_name: ost$name,
      external_vsn: rmt$external_vsn,
      job_name: jmt$system_supplied_name,
      message_size: integer,
      message: string (osc$max_string_size),
      verified_job_name: jmt$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$external_vsn].value^.kind = clc$string THEN
      external_vsn := pvt [p$external_vsn].value^.string_value^;
    ELSEIF pvt [p$external_vsn].value^.kind = clc$name THEN
      external_vsn := pvt [p$external_vsn].value^.name_value;
    IFEND;
    rmp$validate_ansi_string (external_vsn, external_vsn, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (rmc$resource_management_id, cle$improper_vsn_value, external_vsn, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'EXTERNAL_VSN', status);
      RETURN;
    IFEND;

    IF pvt [p$message].specified THEN
      message := pvt [p$message].value^.string_value^;
    ELSE
      message := 'the specified tape could not be located';
    IFEND;

    IF pvt [p$job_name].specified THEN
      candidate_name.kind := jmc$system_supplied_name;
      candidate_name.system_supplied_name := pvt [p$job_name].value^.name_value;
      jmp$validate_name (candidate_name, verified_job_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      job_name := verified_job_name.system_supplied_name;
    ELSE
      job_name := jmc$blank_system_supplied_name;
    IFEND;

    iop$terminate_tape_assignment (external_vsn, message, job_name, status);

  PROCEND clp$terminate_tape_assignment;

MODEND clm$terminate_tape_assignment;
*DECK DECK=CLM$TEST_HARNESS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'SCL and FS Test harnesses' ??
MODULE clm$test_harness;
*copyc clh$test_harness
*copyc clc$compiling_for_test_harness
*copyc fsc$compiling_for_test_harness

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
*copyc ost$heap
?? POP ??
*copyc amp$#copy_file
*copyc amp$#get_segment_pointer
*copyc amp$#open
*copyc amp$change_file_attributes
*copyc amp$close
*copyc amp$open
*copyc amp$put_next
*copyc avp$get_set_name
*copyc clp$interpret_commands
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$scan_command_file
*copyc fsv$test_harness_cmnds
*copyc fsv$test_harness_fnctns
*copyc jmp$get_attribute_defaults
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_from_condition
*copyc pfp$define_master_catalog
*copyc pfp$overhaul_set
*copyc pmp$continue_to_cause
*copyc pmp$get_user_identification
*copyc rmp$request_terminal


  PROCEDURE [XREF] display
    (    display_line: string ( * <= 256));


  PROCEDURE [XREF] display_status
    (    status: ost$status);


  PROCEDURE [XREF] set_current_user_id;


  PROCEDURE [XREF] setup_job_pointers;


  PROCEDURE [XREF] setup_job_table_entry
    (    job_id: integer);



  VAR
    logging_out: [XREF] pmt$condition_name;

  ?IF clc$compiling_for_test_harness THEN

    VAR
      exiting: [XREF] pmt$condition_name;

    ?IF fsc$compiling_for_test_harness THEN

      VAR
        global_system_administrator: [XREF] boolean,
        global_family_administrator: [XREF] boolean,
        last_real_file_name: [XREF] amt$local_file_name;

    ?IFEND
  ?IFEND
?? TITLE := 'Stubbed variables', EJECT ??

  VAR
    osv$task_private_heap: [XDCL] ^ost$heap,
    osv$task_shared_heap: [XDCL] ^ost$heap;

  ?IF fsc$compiling_for_test_harness THEN

    VAR
      osv$mainframe_pageable_heap: [XDCL] ^ost$heap,
      osv$job_pageable_heap: [XDCL] ^ost$heap;

    ?IF NOT clc$compiling_for_test_harness THEN

      VAR
        userbam_utility_name: [XDCL] ost$name := 'USERBAM                        ';

    ?IFEND
  ?IFEND

?? TITLE := 'SCL test harness', EJECT ??
{                         **********************
{                         ** SCL TEST HARNESS **
{                         **********************

  ?IF clc$compiling_for_test_harness THEN

    PROCEDURE [XDCL] clp$test_harness
      (    ignore_parameter_list: clt$parameter_list;
       VAR status: ost$status);

?? NEWTITLE := 'abort_handler', EJECT ??

      PROCEDURE abort_handler
        (    condition: pmt$condition;
             condition_descriptor: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);

        VAR
          exit_status: ^ost$status;

        IF (condition.selector = pmc$user_defined_condition) AND
              ((condition.user_condition_name = exiting) OR (condition.user_condition_name = logging_out))
              THEN
          exit_status := condition_descriptor;
          status := exit_status^;
          EXIT clp$test_harness;
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      PROCEND abort_handler;
?? OLDTITLE, EJECT ??
      ?IF fsc$compiling_for_test_harness THEN

        VAR
          terminal_null_attribute: array [1 .. 1] of ift$connection_attribute,
          command_file: amt$local_file_name,
          charge_id: pft$charge_id,
          default_attribute_results: ^jmt$default_attribute_results,
          user_id: ost$user_identification,
          local_status: ost$status,
          set_name: stt$set_name;

      ?IFEND

      osp$establish_condition_handler (^abort_handler, FALSE);

      create_heap ('OSV$TASK_PRIVATE_HEAP          ', osv$task_private_heap, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      create_heap ('OSV$TASK_SHARED_HEAP           ', osv$task_shared_heap, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      setup_job_table_entry (1);

      ?IF fsc$compiling_for_test_harness THEN
        create_heap ('OSV$MAINFRAME_PAGEABLE_HEAP    ', osv$mainframe_pageable_heap, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        create_heap ('OSV$JOB_PAGEABLE_HEAP          ', osv$job_pageable_heap, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        setup_job_pointers;
        global_system_administrator := TRUE;
        global_family_administrator := FALSE;

        bring_in_command_library ('OSF$COMMAND_LIBRARY            ', 'OSF$COMMAND_LIBRARY            ');

        set_current_user_id;
        pmp$get_user_identification (user_id, status);
        avp$get_set_name (user_id.family, set_name, status);

        pfp$overhaul_set (set_name, $pft$set_overhaul_choices [], status);

        charge_id.account := '  ';
        charge_id.project := ' ';
        PUSH default_attribute_results: [1 .. 1];
        default_attribute_results^ [1].key := jmc$login_family;
        jmp$get_attribute_defaults (jmc$interactive_connected, default_attribute_results, status);
        pfp$define_master_catalog (set_name, default_attribute_results^ [1].login_family,
              user_id.user, charge_id, status);
        pfp$define_master_catalog (set_name, '$SYSTEM                        ',
              '$SYSTEM                        ', charge_id, status);

        global_system_administrator := FALSE;
        global_family_administrator := FALSE;

        terminal_null_attribute [1].key := ifc$null_connection_attribute;

        display (' requesting terminal: input, output, command');
        rmp$request_terminal ('INPUT                          ', NIL, terminal_null_attribute, status);
        display_status (status);

        rmp$request_terminal ('OUTPUT                         ', NIL, terminal_null_attribute, status);
        display_status (status);

        rmp$request_terminal ('COMMAND                        ', NIL, terminal_null_attribute, status);
        display_status (status);

        display (' interpret commands');
      ?IFEND

      clp$interpret_commands;

      osp$disestablish_cond_handler;

    PROCEND clp$test_harness;
  ?IFEND
?? TITLE := 'FS test harness', EJECT ??
{                         **********************
{                         ** FS TEST HARNESS. **
{                         **********************

  ?IF fsc$compiling_for_test_harness AND (NOT clc$compiling_for_test_harness) THEN

    PROCEDURE [XDCL] fsp$test_harness
      (    ignore_parameter_list: clt$parameter_list;
       VAR status: ost$status);

?? NEWTITLE := 'stub_abort_handler', EJECT ??

      PROCEDURE stub_abort_handler
        (    condition: pmt$condition;
             condition_information: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);

        VAR
          condition_status,
          construction_status: ost$status;

        handler_status.normal := TRUE;

{ DISPLAY THE REASON FOR THE CONDITION

        display (' Condition occurred in stub_abort_handlers');
        osp$set_status_from_condition (amc$access_method_id, condition, save_area, condition_status,
              construction_status);
        IF construction_status.normal THEN
          display_status (condition_status);
        ELSE
          display_status (construction_status);
        IFEND;
        CASE condition.selector OF

        = pmc$user_defined_condition =
          IF condition.user_condition_name = logging_out THEN
            EXIT fsp$test_harness;
          IFEND;

        = ifc$interactive_condition =
          display (' interactive condition');
          display (' Continue to cause - execute standard procedure');
          status.normal := TRUE;

        ELSE
        CASEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      PROCEND stub_abort_handler;
?? OLDTITLE, EJECT ??

      VAR
        command_file: amt$local_file_name,
        local_status: ost$status;

      display (' Welcome to user bam');
      osp$establish_condition_handler (^stub_abort_handler, FALSE);

      create_heap ('OSV$TASK_PRIVATE_HEAP          ', osv$task_private_heap, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      create_heap ('OSV$TASK_SHARED_HEAP           ', osv$task_shared_heap, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      create_heap ('OSV$MAINFRAME_PAGEABLE_HEAP    ', osv$mainframe_pageable_heap, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      create_heap ('OSV$JOB_PAGEABLE_HEAP          ', osv$job_pageable_heap, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      set_current_user_id;
      setup_job_pointers;
      setup_job_table_entry (1);

      clp$push_utility (userbam_utility_name, clc$global_command_search, fsv$test_harness_cmnds,
            fsv$test_harness_fnctns, status);
      IF status.normal THEN
        command_file := '$COMMAND';
        clp$scan_command_file (command_file, userbam_utility_name, 'UB', status);
        clp$pop_utility (local_status);
      IFEND;

      osp$disestablish_cond_handler;

    PROCEND fsp$test_harness;
  ?IFEND
?? TITLE := 'create_heap', EJECT ??

  PROCEDURE create_heap
    (    heap_file_name: amt$local_file_name;
     VAR heap_pointer: ^ost$heap;
     VAR status: ost$status);

    VAR
      file_identifier: amt$file_identifier,
      segment_pointer: amt$segment_pointer;

    amp$#open (heap_file_name, amc$segment, NIL, file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$#get_segment_pointer (file_identifier, amc$cell_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    heap_pointer := segment_pointer.cell_pointer;
    RESET heap_pointer^;

  PROCEND create_heap;
?? TITLE := 'bring_in_command_library', EJECT ??

  ?IF clc$compiling_for_test_harness AND fsc$compiling_for_test_harness THEN

    PROCEDURE bring_in_command_library
      (    real_lfn: amt$local_file_name;
           userbam_lfn: amt$local_file_name);

      VAR
        status: ost$status,
        p_change_attributes: ^amt$file_attributes,
        wsa: ^cell,
        wsa_string: string (50),
        fid: amt$file_identifier,
        wsl: amt$working_storage_length,
        ba: amt$file_byte_address;

      display (' bringing in command library ');
      display (userbam_lfn);

{ first create the userbam file and put enough data in it so that
{ eoi is believable by command language.

      amp$open (userbam_lfn, amc$record, NIL, fid, status);
      IF NOT status.normal THEN
        display_status (status);
      IFEND;
      wsa_string := 'Garys kludge';
      wsa := ^wsa_string;
      amp$put_next (fid, wsa, 50, ba, status);
      amp$put_next (fid, wsa, 50, ba, status);
      amp$put_next (fid, wsa, 50, ba, status);
      amp$put_next (fid, wsa, 50, ba, status);
      amp$close (fid, status);

{ copy the data into the file

      display (' amp$#copy_file');
      amp$#copy_file (real_lfn, last_real_file_name, status);
      display_status (status);

{ chafa to make them believable as a command library

      PUSH p_change_attributes: [1 .. 2];
      p_change_attributes^ [1].key := amc$file_structure;
      p_change_attributes^ [1].file_structure := 'LIBRARY';
      p_change_attributes^ [2].key := amc$file_contents;
      p_change_attributes^ [2].file_contents := 'OBJECT';

      display (' chafa file ');
      amp$change_file_attributes (userbam_lfn, p_change_attributes, status);
      display_status (status);

    PROCEND bring_in_command_library;

  ?IFEND

MODEND clm$test_harness;
*DECK DECK=CLM$TEST_HARNESS_COMMON_SUPPORT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'SCL and FS common test_harness support' ??
MODULE clm$test_harness_common_support;

{
{ PURPOSE:
{ This module contains common support code for the SCL and FS test harnesses.
{ It must be compiled to match the users changed type declarations.
{ The common support includes:
{   1. simulated multiple task and jobs,
{   2. various display routines.
{

*copyc clc$compiling_for_test_harness
*copyc fsc$compiling_for_test_harness

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc amt$ring_attributes
*copyc avc$validation_field_names
*copyc avt$conditional_capabilities
*copyc avt$security_option
*copyc avt$valid_security_options
*copyc clc$exiting_condition
*copyc clt$command_line_index
*copyc clt$connected_file
*copyc clt$expression
*copyc clt$line_layout
*copyc clt$prompt_string
*copyc clt$working_catalog
*copyc cyt$string_size
*copyc fst$detachment_options
*copyc fst$path
*copyc fst$path_size
*copyc ift$connection_attributes
*copyc ift$network_identifier
*copyc jmc$system_family
*copyc jmt$job_attributes
*copyc jmt$job_control_block
*copyc lgt$log_read_activity
*copyc osd$wait
*copyc ose$undefined_condition
*copyc oss$job_fixed
*copyc oss$job_paged_literal
*copyc oss$mainframe_paged_literal
*copyc oss$mainframe_wired
*copyc ost$caller_identifier
*copyc ost$date
*copyc ost$date_time
*copyc ost$page_size
*copyc ost$signature_lock
*copyc ost$time
*copyc pmd$local_queues
*copyc pme$execution_exceptions
*copyc pmt$entry_point_reference
*copyc pmt$program_description
*copyc pmt$program_parameters
*copyc pmt$task_status
*copyc rmt$device_class
*copyc syt$perf_keypoints_enabled
?? POP ??
*copyc amp$return
*copyc bap$task_termination_cleanup
*copyc clp$erase_child_task
*copyc clp$put_job_command_response
*copyc clp$record_child_task
*copyc fsp$close_file
*copyc ifp$fetch_term_conn_attributes
*copyc ifp$store_term_conn_attributes
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pmp$cause_condition
*copyc pmp$continue_to_cause
*copyc pmp$load
*copyc pmp$log
*copyc pmp$receive_queue_message
*copyc pmp$remove_entry_point
*copyc pmp$task_debug_mode_on
?? EJECT ??

  ?IF fsc$compiling_for_test_harness THEN

    VAR
      fmv$initial_cdu_pointer: [XREF] ^fmt$cycle_description_unit;

    VAR
      fmv$initial_cdu: [XREF] fmt$cycle_description_unit;

    VAR
      fmv$initial_cdu_entries: [XREF] array [1 .. fmc$number_of_init_cycle_descs] of fmt$cycle_description;

    VAR
      fmv$initial_global_file_entries: [XREF] array [1 .. fmc$number_of_init_cycle_descs] of
            bat$global_file_information;

    VAR
      fmv$initial_pdu_pointer: [XREF] ^fmt$path_description_unit;

    VAR
      fmv$initial_pdu: [XREF] fmt$path_description_unit;

    VAR
      fmv$initial_pdu_entries: [XREF] array [1 .. fmc$number_of_init_path_descs] of
            fmt$path_description_entry;

    VAR
      pfv$number_of_alarm_sets: [XREF] ost$non_negative_integers;

    VAR
      pfv$p_attached_pf_table: [XREF] pft$p_attached_pf_table;

    VAR
      pfv$p_newest_queued_catalog: [XREF] pft$p_queued_catalog;

    VAR
      pfv$p_queued_catalog_table: [XREF] pft$p_queued_catalog_table;

*copyc bav$auxilliary_request_table
*copyc bav$task_file_table
*copyc bav$tft_entry_assignment
?? PUSH (LISTEXT := ON) ??
*copyc bat$global_file_information
*copyc fmc$number_of_init_cycle_descs
*copyc fmc$number_of_init_path_descs
*copyc fmt$cycle_description
*copyc fmt$cycle_description_unit
*copyc fmt$path_description_entry
*copyc fmt$path_description_unit
*copyc pfd$attached_pf_table
*copyc pfd$catalog
*copyc pfd$catalog_alarm_table
*copyc pfd$queued_catalog_table
?? POP ??
  ?IFEND

  ?IF clc$compiling_for_test_harness THEN
*copyc clv$command_logging_activated
*copyc clv$current_task_block
*copyc clv$environment_object_location
*copyc clv$message_cache
*copyc clv$named_task_group_list
*copyc clv$processing_phase
*copyc clv$system_file_identifiers
*copyc clv$task_command_library_list
*copyc clv$task_list
*copyc clv$task_name
*copyc clv$work_areas
  ?IFEND
?? TITLE := 'Stubbed variables', EJECT ??

  VAR
    avv$security_options: [XDCL, #GATE, oss$mainframe_wired] array [avt$valid_security_options] of
          avt$security_option := [[FALSE, FALSE], [FALSE, FALSE], [FALSE, FALSE]];

  VAR
    avv$cond_capability_names: [XDCL, READ, oss$job_paged_literal] array [avt$conditional_capability] of
          ost$name := [avc$accounting_administration, avc$configuration_admin, avc$family_administration,
          avc$removable_media_admin, avc$removable_media_operation, avc$system_administration,
          avc$system_displays, avc$system_operation];

  VAR
    clv$log_secure_parameters: [XDCL, #GATE] boolean := TRUE;

  VAR
    jmv$jcb: [XDCL] jmt$job_control_block;

  VAR
    jmv$job_attributes: [XDCL, READ, oss$job_paged_literal] jmt$job_attributes := [
         { comment_banner } 'SYSTEM_ERROR - See Site Info',
         { copy_count } 1,
         { device } 'AUTOMATIC',
         { earliest_run_time } [FALSE],
         { earliest_print_time } [FALSE],
         { external_characteristics } 'NORMAL',
         { forms_code } 'NORMAL',
         { implicit_routing_text} [0, ''],
         { job_controller } [jmc$system_user, jmc$system_family],
         { job_initiation_time } [0, 1, 1, 0, 0, 0, 0],
         { job_input_device } [0, ''],
         { job_qualifier_list } [REP jmc$maximum_job_qualifiers OF osc$null_name],
         { job_size } 0,
         { job_submission_time } *,
         { latest_run_time } [FALSE],
         { latest_print_time } [FALSE],
         { login_command_supplied } FALSE,
         { originating_application_name } 'OSA$JOB_BEGIN',
         { originating_ssn } jmc$full_system_supplied_name,
         { output_class } 'NORMAL',
         { output_deferred_by_user } FALSE,
         { output_destination } '',
         { output_destination_family } jmc$system_family,
         { output_destination_usage } 'SYSTEM_ERROR',
         { output_disposition_key } jmc$normal_output_disposition,
         { output_disposition_path } '',
         { output_priority } 'LOW',
         { processor_user_prolog_and_epilog } TRUE,
         { purge_delay } [FALSE],
         { remote_host_directive } [0, ''],
         { routing_banner } 'SYSTEM_ERROR - See Site Info',
         { source_logical_id } '',
         { site_information } 'The job has aborted as part of initiation.  The job attributes have not ' CAT
                              'been initialized.  The Job Log in the standard output file contains the ' CAT
                              'status of the initiation failure.  To print this file change the OUTPUT_' CAT
                              'DESTINATION_USAGE.',
         { station } 'AUTOMATIC',
         { station_operator } jmc$system_user,
         { system_job_parameters } [0, ''],
         { system_routing_text } [0, ''],
         { user_information } 'A system error occured during job initiation.  See Site_Information ' CAT
                              'for additional information.',
         { vertical_print_density } jmc$vertical_print_density_none,
         { vfu_load_procedure } osc$null_name];

  VAR
    syv$perf_keypoints_enabled: [XDCL] syt$perf_keypoints_enabled :=
          [FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE];

  VAR
    osv$page_size: [XDCL] ost$page_size := 01000(16);

  VAR
    jmv$executing_within_system_job: [XDCL, oss$job_fixed] boolean := FALSE;

  VAR
    lgv$log_names: [XDCL, READ, oss$mainframe_paged_literal] array [pmt$logs] of
          ost$name := ['$JOB_ACCOUNTING_LOG', '$JOB_STATISTIC_LOG', '$ACCOUNT_LOG', '$ENGINEERING_LOG',
          '$HISTORY_LOG', '$SECURITY_LOG', '$STATISTIC_LOG', '$SYSTEM_LOG', '$JOB_LOG'];

  VAR
    rmv$valid_vsn_characters: [XDCL, READ, oss$job_paged_literal] set of char :=
          ['A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R',
           'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
           'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', '0', '1',
           '2', '3', '4', '5', '6', '7', '8', '9', ' ', '!', '"', '%', '&', '''', '(', ')', '*', '+',
           ',', '-', '.', '/', ':', ';', '<', '=', '>', '?', '_', '$', '#', '@'];
  CONST
    max_jobs = 5,
    max_tasks = 5;

  TYPE
    pmt$program = ^procedure (    parameters: pmt$program_parameters;
                              VAR status: ost$status);

  TYPE
    job_table_entry = record
      case active: boolean of
      = FALSE =
        ,
      = TRUE =
        system_job: boolean,
        current_task: pmt$task_id,
        tasks: array [1 .. max_tasks] of task_table_entry,
        ?IF clc$compiling_for_test_harness THEN
          { CL job tables
          command_logging_activated: boolean,
          processing_phase: clt$processing_phase,
          task_list: clt$task_list,
        ?IFEND
        ?IF fsc$compiling_for_test_harness THEN
          { FM job tables
          initial_cdu_pointer: ^fmt$cycle_description_unit,
          initial_cdu: fmt$cycle_description_unit,
          initial_cdu_entries: array [1 .. fmc$number_of_init_cycle_descs] of fmt$cycle_description,
          initial_global_file_entries: array [1 .. fmc$number_of_init_cycle_descs] of
                bat$global_file_information,
          initial_pdu_pointer: ^fmt$path_description_unit,
          initial_pdu: fmt$path_description_unit,
          initial_pdu_entries: array [1 .. fmc$number_of_init_path_descs] of fmt$path_description_entry,
          { PF job tables }
          p_attached_pf_table: pft$p_attached_pf_table,
          p_newest_queued_catalog: pft$p_queued_catalog,
          p_queued_catalog_table: pft$p_queued_catalog_table,
        ?IFEND
      casend,
    recend;

  TYPE
    task_table_entry = record
      case active: boolean of
      = FALSE =
        ,
      = TRUE =
        parent_task: pmt$task_id { 0 if none } ,
        first_child_task: pmt$task_id { 0 if none } ,
        next_sibling_task: pmt$task_id { 0 if none } ,
        previous_sibling_task: pmt$task_id { 0 if none } ,
        ?IF fsc$compiling_for_test_harness THEN
          { BA task tables
          p_task_file_table: ^bat$task_file_table,
          p_tft_entry_assignment: ^bat$tft_entry_assignment,
          p_auxilliary_request_table: ^bat$auxilliary_request_table,
        ?IFEND
        ?IF clc$compiling_for_test_harness THEN
          { CL task tables
          environment_object_location: clt$environment_object_location,
          current_task_block: ^clt$block,
          message_cache: clt$message_cache,
          named_task_group_list: ^^clt$named_task,
          system_file_identifiers: clt$system_file_identifiers,
          task_library_list: ^clt$command_library_list_entry,
          task_name: ost$name,
          work_areas: clt$work_areas,
        ?IFEND
      casend,
    recend;

  VAR
    max_number_of_jobs: [XDCL] integer := max_jobs,
    current_job: [STATIC] 1 .. max_jobs := 1,
    jobs: [STATIC] array [1 .. max_jobs] of job_table_entry := [REP max_jobs of [FALSE]];

  VAR
    max_number_of_tasks: [XDCL] pmt$task_id := max_tasks;

  VAR
    logging_out: [XDCL] pmt$condition_name := 'JMC$LOGOUT                     ';

  VAR
    exiting: [XDCL] pmt$condition_name := 'PMC$EXIT                       ';

  CONST
    ignore_command_file = osc$null_name;

  ?IF clc$compiling_for_test_harness THEN

    VAR
      initialized_task_list: clt$task_list := [NIL, [0], NIL],
      initialized_message_cache: clt$message_cache := [0, * ],
      initialized_system_file_ids: clt$system_file_identifiers := [[FALSE], [FALSE], [FALSE], [FALSE]];

  ?IFEND

  ?IF fsc$compiling_for_test_harness THEN

    VAR
      initialized_cdu: fmt$cycle_description_unit := [NIL, NIL, 0, 0, NIL, NIL],
      initialized_pdu: fmt$path_description_unit := [NIL, 0, 0, NIL, NIL];

  ?IFEND
?? TITLE := 'clp$send_exiting_signal', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$send_exiting_signal
    (    target_task_id: pmt$task_id;
         targets_child_task_id: pmt$task_id;
         exit_control_block: ^clt$block;
     VAR status: ost$status);


    IF exit_control_block <> NIL THEN
      pmp$cause_condition (clc$exiting_condition, exit_control_block, status);
    IFEND;

  PROCEND clp$send_exiting_signal;
?? TITLE := 'fsp$detach_file', EJECT ??

  PROCEDURE [XDCL] fsp$detach_file
    (    file: fst$file_reference;
         detachment_options: ^fst$detachment_options;
     VAR status: ost$status);


    status.normal := TRUE;
    amp$return (file, status);

  PROCEND fsp$detach_file;
?? TITLE := 'ifp$get_network_identifier', EJECT ??

{
{ NOTE:
{   This stub can be removed once feature NV05445 has been integrated.
{

  PROCEDURE [XDCL, #GATE] ifp$get_network_identifier
    (VAR network_identifier: ift$network_identifier;
     VAR status: ost$status);


    status.normal := TRUE;
    network_identifier := ifc$ni_nam_ve_cdcnet;

  PROCEND ifp$get_network_identifier;
?? TITLE := 'jmp$logout', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$logout
    (VAR status: ost$status);

    VAR
      exit_status: ost$status,
      ignore_status: ost$status;

    display ('*** STUBBED JMP$LOGOUT ***');

    exit_status := status;
    pmp$cause_condition (logging_out, ^exit_status, ignore_status);

  PROCEND jmp$logout;
?? TITLE := 'mmp$reverify_access', EJECT ??

  FUNCTION [XDCL] mmp$reverify_access
    (    pva: ^^cell): boolean;


    mmp$reverify_access := TRUE;

  FUNCEND mmp$reverify_access;
?? TITLE := 'osp$get_job_template_name', EJECT ??

  PROCEDURE [XDCL] osp$get_job_template_name
    (VAR job_template_name: ost$name);


    job_template_name := 'SCL_TEST_HARNESS';

  PROCEND osp$get_job_template_name;
?? TITLE := 'osp$system_error', EJECT ??

  PROCEDURE [XDCL] osp$system_error
    (    error_message: string ( * );
         status: ^ost$status);


    display ('osp$system_error');
    display (error_message);
    IF status <> NIL THEN
      display_status (status^);
    IFEND;

  PROCEND osp$system_error;
?? TITLE := 'pmp$get_task_id', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_task_id
    (VAR task_id: pmt$task_id;
     VAR status: ost$status);

    status.normal := TRUE;
    task_id := jobs [current_job].current_task;

  PROCEND pmp$get_task_id;
?? TITLE := 'pmp$execute', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$execute
    (    program_description: pmt$program_description;
         program_parameters: pmt$program_parameters;
         wait: ost$wait;
     VAR task_id: pmt$task_id;
     VAR task_status: pmt$task_status;
     VAR status: ost$status);

    VAR
      caller: ost$caller_identifier;

    status.normal := TRUE;
    task_status.complete := FALSE;
    task_id := LOWERVALUE (pmt$task_id);
    #CALLER_ID (caller);

    display ('*** STUBBED PMP$EXECUTE ***');

    execute_task (caller.ring, program_description, program_parameters, ignore_command_file, wait, FALSE,
          task_id, task_status, status);

  PROCEND pmp$execute;
?? TITLE := 'pmp$execute_within_task', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$execute_within_task
    (    program_description: pmt$program_description;
         program_parameters: pmt$program_parameters;
     VAR status: ost$status);

    VAR
      caller: ost$caller_identifier,
      task_id: pmt$task_id,
      task_status: pmt$task_status;

    status.normal := TRUE;
    task_status.complete := FALSE;
    task_id := LOWERVALUE (pmt$task_id);
    #CALLER_ID (caller);

    display ('*** STUBBED PMP$EXECUTE_WITHIN_TASK ***');
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    execute_task (caller.ring, program_description, program_parameters, ignore_command_file, osc$wait, FALSE,
          task_id, task_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Execute within a task will not return because of it's "Outward Call". Simulate this.

    pmp$exit (task_status.status);

  PROCEND pmp$execute_within_task;
?? TITLE := 'pmp$execute_with_less_privilege', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$execute_with_less_privilege
    (    target_ring: ost$valid_ring;
         program_description: pmt$program_description;
         program_parameters: pmt$program_parameters;
         wait: ost$wait;
         cl_task: boolean;
     VAR task_id: pmt$task_id;
     VAR task_status: pmt$task_status;
     VAR status: ost$status);

    CONST
      no_command_file = osc$null_name;

    VAR
      caller: ost$caller_identifier;

    status.normal := TRUE;
    task_id := LOWERVALUE (pmt$task_id);
    task_status.complete := FALSE;
    #CALLER_ID (caller);

    display ('*** STUBBED PMP$EXECUTE_WITH_LESS_PRIVILEGE ***');

    execute_task (target_ring, program_description, program_parameters, no_command_file, wait, cl_task,
          task_id, task_status, status);

  PROCEND pmp$execute_with_less_privilege;
?? TITLE := 'pmp$execute_with_command_file', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$execute_with_command_file
    (    target_ring: ost$valid_ring;
         program_description: pmt$program_description;
         program_parameters: pmt$program_parameters;
         command_file: amt$local_file_name;
         wait: ost$wait;
         cl_task: boolean;
     VAR task_id: pmt$task_id;
     VAR task_status: pmt$task_status;
     VAR status: ost$status);

    VAR
      caller: ost$caller_identifier;

    status.normal := TRUE;
    task_id := LOWERVALUE (pmt$task_id);
    task_status.complete := FALSE;
    #CALLER_ID (caller);

    display ('*** STUBBED PMP$EXECUTE_WITH_COMMAND_FILE ***');

    execute_task (target_ring, program_description, program_parameters, command_file, wait, cl_task, task_id,
          task_status, status);

  PROCEND pmp$execute_with_command_file;
?? TITLE := 'pmp$await_task_termination', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$await_task_termination
    (    task_id: pmt$task_id;
     VAR status: ost$status);

    osp$set_status_abnormal ('PM', ose$undefined_condition,
          'pmp$await_task_termination not supported in "test harness"', status);

  PROCEND pmp$await_task_termination;
?? TITLE := 'osp$await_activity_completion', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$await_activity_completion
    (    wait_list: ost$wait_list;
     VAR ready_index: integer;
     VAR status: ost$status);

    osp$set_status_abnormal ('PM', ose$undefined_condition,
          'osp$await_activity_completion not supported in "test harness"', status);

  PROCEND osp$await_activity_completion;
?? TITLE := 'pmp$receive_from_queue', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$receive_from_queue
    (    qid: pmt$queue_connection;
         wait: ost$wait;
     VAR message: pmt$message;
     VAR status: ost$status);

    VAR
      receive_complete: boolean;

    status.normal := TRUE;

    CASE wait OF
    = osc$wait =
      ;
    = osc$nowait =
      osp$set_status_abnormal ('PM', ose$undefined_condition,
            'osc$wait option of pmm$receive_from_queue not supported in "test harness"', status);
      RETURN;
    ELSE
      osp$set_status_abnormal ('PM', pme$invalid_wait_parameter, '', status);
      RETURN;
    CASEND;

    receive_complete := FALSE;
    REPEAT
      pmp$receive_queue_message (qid, wait, message, receive_complete, status);
    UNTIL receive_complete OR NOT status.normal;

  PROCEND pmp$receive_from_queue;
?? TITLE := 'pmp$exit', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$exit
    (    status: ost$status);

    VAR
      exit_status: ost$status,
      ignore_status: ost$status;

    display ('*** STUBBED PMP$EXIT ***');

    exit_status := status;
    pmp$cause_condition (exiting, ^exit_status, ignore_status);

  PROCEND pmp$exit;
?? TITLE := 'pmp$abort', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$abort
    (    status: ost$status);

    VAR
      exit_status: ost$status,
      ignore_status: ost$status;

    display ('*** STUBBED PMP$ABORT ***');

    exit_status := status;
    pmp$cause_condition (exiting, ^exit_status, ignore_status);

  PROCEND pmp$abort;
?? TITLE := 'pmp$cause_task_condition', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$cause_task_condition
    (    condition_name: pmt$condition_name;
         condition_descriptor: ^pmt$condition_information;
         notify_scl: boolean;
         notify_debug: boolean;
         propagate_to_parent: boolean;
         call_default_handler: boolean;
     VAR status: ost$status);


    pmp$cause_condition (condition_name, condition_descriptor, status);

  PROCEND pmp$cause_task_condition;
?? TITLE := 'setup_job_table_entry', EJECT ??

  PROCEDURE [XDCL] setup_job_table_entry
    (    job_id: integer);

    VAR
      i: 2 .. max_tasks,
      job: ^job_table_entry;

    job := ^jobs [job_id];

    job^.active := TRUE;
    job^.system_job := FALSE;
    job^.current_task := 1;

    ?IF clc$compiling_for_test_harness THEN
      job^.command_logging_activated := FALSE;
      job^.processing_phase := clc$job_begin_phase;
      job^.task_list := initialized_task_list;
    ?IFEND

    ?IF fsc$compiling_for_test_harness THEN
      job^.initial_cdu_pointer := NIL;
      job^.initial_cdu := initialized_cdu;
      job^.initial_pdu_pointer := NIL;
      job^.initial_pdu := initialized_pdu;

      job^.p_attached_pf_table := NIL;
      job^.p_newest_queued_catalog := NIL;
      job^.p_queued_catalog_table := NIL;
    ?IFEND

    setup_task_table_entry (job_id, 1, 0);
    FOR i := 2 TO max_tasks DO
      job^.tasks [i].active := FALSE;
    FOREND;

  PROCEND setup_job_table_entry;
?? TITLE := 'setup_task_table_entry', EJECT ??

  PROCEDURE setup_task_table_entry
    (    job_id: integer;
         task_id: pmt$task_id;
         parent_task_id: pmt$task_id);

    VAR
      first_child_task: ^task_table_entry,
      object_ordinal: clt$environment_object_ordinal,
      parent_task: ^task_table_entry,
      ring: ost$valid_ring,
      task: ^task_table_entry;


    task := ^jobs [job_id].tasks [task_id];

    task^.active := TRUE;
    task^.parent_task := parent_task_id;
    task^.first_child_task := 0;
    IF parent_task_id > 0 THEN
      parent_task := ^jobs [job_id].tasks [parent_task_id];
      task^.next_sibling_task := parent_task^.first_child_task;
      IF parent_task^.first_child_task > 0 THEN
        first_child_task := ^jobs [job_id].tasks [parent_task^.first_child_task];
        first_child_task^.previous_sibling_task := task_id;
      IFEND;
      parent_task^.first_child_task := task_id;
    ELSE
      task^.next_sibling_task := 0;
    IFEND;
    task^.previous_sibling_task := 0;

    ?IF fsc$compiling_for_test_harness THEN
      task^.p_task_file_table := NIL;
      task^.p_tft_entry_assignment := NIL;
      task^.p_auxilliary_request_table := NIL;
    ?IFEND

    ?IF clc$compiling_for_test_harness THEN
      FOR object_ordinal := LOWERVALUE (clt$environment_object_ordinal) TO
            UPPERVALUE (clt$environment_object_ordinal) DO
        task^.environment_object_location [object_ordinal].object := NIL;
      FOREND;
      task^.current_task_block := NIL;
      task^.message_cache := initialized_message_cache;
      task^.named_task_group_list := NIL;
      task^.system_file_identifiers := initialized_system_file_ids;
      task^.task_library_list := NIL;
      task^.task_name := osc$null_name;
      FOR ring := LOWERBOUND (task^.work_areas) TO UPPERBOUND (task^.work_areas) DO
        task^.work_areas [ring].pointer := NIL;
      FOREND;
    ?IFEND

  PROCEND setup_task_table_entry;
?? TITLE := 'setup_new_job', EJECT ??

  PROCEDURE setup_new_job
    (VAR new_job_id: integer);

    VAR
      i: 2 .. max_jobs;

    FOR i := 2 TO max_jobs DO
      IF NOT jobs [i].active THEN
        new_job_id := i;
        setup_job_table_entry (new_job_id);
        RETURN;
      IFEND;
    FOREND;

{ Indicate that no "slot" is available for a new job.

    new_job_id := 0;

  PROCEND setup_new_job;
?? TITLE := 'setup_child_task', EJECT ??

  PROCEDURE setup_child_task
    (VAR child_task_id: pmt$task_id);

    VAR
      i: 2 .. max_tasks;

    FOR i := 2 TO max_tasks DO
      IF NOT jobs [current_job].tasks [i].active THEN
        child_task_id := i;
        setup_task_table_entry (current_job, child_task_id, jobs [current_job].current_task);
        RETURN;
      IFEND;
    FOREND;

{ Indicate that no "slot" is available for a new child task.

    child_task_id := 0;

  PROCEND setup_child_task;
?? TITLE := 'save_current_job', EJECT ??

  PROCEDURE save_current_job;

    VAR
      job: ^job_table_entry;

    job := ^jobs [current_job];

    save_current_task;

    ?IF clc$compiling_for_test_harness THEN
      job^.command_logging_activated := clv$command_logging_activated;
      job^.processing_phase := clv$processing_phase;
      job^.task_list := clv$task_list;
    ?IFEND

    ?IF fsc$compiling_for_test_harness THEN
      job^.initial_cdu_pointer := fmv$initial_cdu_pointer;
      job^.initial_cdu := fmv$initial_cdu;
      job^.initial_cdu_entries := fmv$initial_cdu_entries;
      job^.initial_global_file_entries := fmv$initial_global_file_entries;
      job^.initial_pdu_pointer := fmv$initial_pdu_pointer;
      job^.initial_pdu := fmv$initial_pdu;
      job^.initial_pdu_entries := fmv$initial_pdu_entries;

      job^.p_attached_pf_table := pfv$p_attached_pf_table;
      job^.p_newest_queued_catalog := pfv$p_newest_queued_catalog;
      job^.p_queued_catalog_table := pfv$p_queued_catalog_table;
    ?IFEND

  PROCEND save_current_job;
?? TITLE := 'restore_job', EJECT ??

  PROCEDURE restore_job
    (    job_id: integer);

    VAR
      job: ^job_table_entry;

    current_job := job_id;

    job := ^jobs [current_job];

    ?IF clc$compiling_for_test_harness THEN
      clv$command_logging_activated := job^.command_logging_activated;
      clv$processing_phase := job^.processing_phase;
      clv$task_list := job^.task_list;
    ?IFEND

    ?IF fsc$compiling_for_test_harness THEN
      fmv$initial_cdu_pointer := job^.initial_cdu_pointer;
      fmv$initial_cdu := job^.initial_cdu;
      fmv$initial_cdu_entries := job^.initial_cdu_entries;
      fmv$initial_global_file_entries := job^.initial_global_file_entries;
      fmv$initial_pdu_pointer := job^.initial_pdu_pointer;
      fmv$initial_pdu := job^.initial_pdu;
      fmv$initial_pdu_entries := job^.initial_pdu_entries;

      pfv$p_attached_pf_table := job^.p_attached_pf_table;
      pfv$p_newest_queued_catalog := job^.p_newest_queued_catalog;
      pfv$p_queued_catalog_table := job^.p_queued_catalog_table;
    ?IFEND

    restore_current_task;

  PROCEND restore_job;
?? TITLE := 'switch_jobs', EJECT ??

  PROCEDURE [XDCL] switch_jobs
    (    next_job_id: integer;
     VAR next_job_active: boolean);

    next_job_active := jobs [next_job_id].active;
    IF next_job_active THEN
      save_current_job;
      restore_job (next_job_id);
    IFEND;

  PROCEND switch_jobs;
?? TITLE := 'save_current_task', EJECT ??

  PROCEDURE save_current_task;

    VAR
      task: ^task_table_entry;

    task := ^jobs [current_job].tasks [jobs [current_job].current_task];

    ?IF fsc$compiling_for_test_harness THEN
      task^.p_task_file_table := bav$task_file_table;
      task^.p_tft_entry_assignment := bav$tft_entry_assignment;
      task^.p_auxilliary_request_table := bav$auxilliary_request_table;
    ?IFEND

    ?IF clc$compiling_for_test_harness THEN
      task^.environment_object_location := clv$environment_object_location;
      task^.current_task_block := clv$current_task_block;
      task^.message_cache := clv$message_cache;
      task^.named_task_group_list := clv$named_task_group_list;
      task^.system_file_identifiers := clv$system_file_identifiers;
      task^.task_library_list := clv$task_command_library_list;
      task^.task_name := clv$task_name;
      task^.work_areas := clv$work_areas;
    ?IFEND

  PROCEND save_current_task;
?? TITLE := 'restore_current_task', EJECT ??

  PROCEDURE restore_current_task;

    VAR
      command_library_list: ^clt$command_library_list_entry,
      found_in_parent_task: boolean,
      ignore_status: ost$status,
      parent_task_library_list: ^clt$command_library_list_entry,
      task: ^task_table_entry;

    task := ^jobs [current_job].tasks [jobs [current_job].current_task];

    ?IF fsc$compiling_for_test_harness THEN
      bav$task_file_table := task^.p_task_file_table;
      bav$tft_entry_assignment := task^.p_tft_entry_assignment;
      bav$auxilliary_request_table := task^.p_auxilliary_request_table;
    ?IFEND

    ?IF clc$compiling_for_test_harness THEN
      clv$environment_object_location := task^.environment_object_location;
      clv$current_task_block := task^.current_task_block;
      clv$message_cache := task^.message_cache;
      clv$named_task_group_list := task^.named_task_group_list;
      clv$system_file_identifiers := task^.system_file_identifiers;

      command_library_list := clv$task_command_library_list;
      WHILE command_library_list <> NIL DO
        parent_task_library_list := task^.task_library_list;
        found_in_parent_task := FALSE;

      /find_in_parent_task/
        WHILE parent_task_library_list <> NIL DO
          IF command_library_list^.local_file_name = parent_task_library_list^.
                local_file_name THEN
            found_in_parent_task := TRUE;
            EXIT /find_in_parent_task/;
          IFEND;
          parent_task_library_list := parent_task_library_list^.next_entry;
        WHILEND /find_in_parent_task/;
        IF NOT found_in_parent_task THEN
          fsp$close_file (command_library_list^.file_id, ignore_status);
        IFEND;
        command_library_list := command_library_list^.next_entry;
      WHILEND;

      clv$task_command_library_list := task^.task_library_list;
      clv$task_name := task^.task_name;
      clv$work_areas := task^.work_areas;
    ?IFEND

  PROCEND restore_current_task;
?? TITLE := 'switch_tasks', EJECT ??

  PROCEDURE [XDCL] switch_tasks
    (    next_task_id: pmt$task_id;
     VAR next_task_active: boolean);

    next_task_active := jobs [current_job].tasks [next_task_id].active;
    IF next_task_active THEN
      save_current_task;
      jobs [current_job].current_task := next_task_id;
      restore_current_task;
    IFEND;

  PROCEND switch_tasks;
?? TITLE := 'set_job_terminated', EJECT ??

  PROCEDURE [XDCL] set_job_terminated
    (    job_id: integer);

    IF job_id = 0 THEN
      jobs [current_job].active := FALSE;
    ELSE
      jobs [job_id].active := FALSE;
    IFEND;

  PROCEND set_job_terminated;
?? TITLE := 'set_task_terminated', EJECT ??

  PROCEDURE [XDCL] set_task_terminated
    (    task_id: pmt$task_id);

    VAR
      parent_id: pmt$task_id,
      next_sibling_id: pmt$task_id,
      previous_sibling_id: pmt$task_id,
      task_number: pmt$task_id;

    IF task_id = 0 THEN
      task_number := jobs [current_job].current_task;
    ELSEIF NOT jobs [current_job].tasks [task_id].active THEN
      RETURN;
    ELSE
      task_number := task_id;
    IFEND;

    parent_id := jobs [current_job].tasks [task_number].parent_task;
    next_sibling_id := jobs [current_job].tasks [task_number].next_sibling_task;
    previous_sibling_id := jobs [current_job].tasks [task_number].previous_sibling_task;

    IF next_sibling_id > 0 THEN
      jobs [current_job].tasks [next_sibling_id].previous_sibling_task := previous_sibling_id;
    IFEND;

    IF previous_sibling_id > 0 THEN
      jobs [current_job].tasks [previous_sibling_id].next_sibling_task := next_sibling_id;
    ELSE
      jobs [current_job].tasks [parent_id].first_child_task := next_sibling_id;
    IFEND;

    jobs [current_job].tasks [task_number].active := FALSE;

  PROCEND set_task_terminated;
?? TITLE := 'execute_task', EJECT ??

  PROCEDURE execute_task
    (    target_ring: ost$valid_ring;
         program_description: pmt$program_description;
         parameters: pmt$program_parameters;
         command_file: amt$local_file_name;
         wait: ost$wait;
         ignore_cl_task: boolean;
     VAR task_id: pmt$task_id;
     VAR task_status: pmt$task_status;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      current_task: pmt$task_id,
      ignore_task_active: boolean,
      loaded_program: pmt$program,
      loaded_program_name: pmt$program_name,
      local_status: ost$status;

    status.normal := TRUE;
    task_id := LOWERVALUE (pmt$task_id);
    task_status.complete := FALSE;
    #CALLER_ID (caller_id);

    CASE wait OF
    = osc$wait =
      ;
    = osc$nowait =
      clp$put_job_command_response (
            ' **** WARNING ****  Asynchronous task will actually run synchronously (in "test harness").',
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      osp$set_status_abnormal ('PM', pme$invalid_wait_parameter, '', status);
      RETURN;
    CASEND;

    current_task := jobs [current_job].current_task;

    setup_child_task (task_id);
    IF task_id = 0 THEN
      osp$set_status_abnormal ('PM', ose$undefined_condition, 'No available task slots in this job.', status);
      RETURN;
    IFEND;

    load_program (program_description, loaded_program, loaded_program_name, status);
    IF NOT status.normal THEN
      set_task_terminated (task_id);
      RETURN;
    IFEND;

    ?IF clc$compiling_for_test_harness THEN
      clp$record_child_task (caller_id.ring, task_id, wait = osc$wait, command_file, status);
      IF NOT status.normal THEN
        IF (NOT pmp$task_debug_mode_on ()) AND (loaded_program_name <> 'CLP$TASK_TASKEND') AND
              (loaded_program_name <> 'CLP$ASYNCHRONOUS_COMMAND') THEN
          pmp$remove_entry_point (loaded_program_name, local_status);
        IFEND;
        set_task_terminated (task_id);
        RETURN;
      IFEND;
    ?IFEND

    switch_tasks (task_id, ignore_task_active);

    call_program (loaded_program, parameters, task_status.status);
    task_status.complete := TRUE;

    IF (NOT pmp$task_debug_mode_on ()) AND (loaded_program_name <> 'CLP$TASK_TASKEND') AND
          (loaded_program_name <> 'CLP$ASYNCHRONOUS_COMMAND') THEN
      pmp$remove_entry_point (loaded_program_name, status);
    IFEND;

    set_task_terminated (task_id);
    jobs [current_job].current_task := current_task;
    restore_current_task;

    ?IF clc$compiling_for_test_harness THEN
      clp$erase_child_task (task_id, local_status);
      IF (NOT local_status.normal) AND status.normal THEN
        status := local_status;
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ?IFEND

  PROCEND execute_task;
?? TITLE := 'load_program', EJECT ??

  PROCEDURE load_program
    (    program_description: pmt$program_description;
     VAR loaded_program: pmt$program;
     VAR loaded_program_name: pmt$program_name;
     VAR status: ost$status);

    VAR
      loaded_address: pmt$loaded_address,
      program_attributes_ptr: ^pmt$program_attributes,
      program_description_ptr: ^pmt$program_description;

    status.normal := TRUE;
    program_description_ptr := ^program_description;
    RESET program_description_ptr;
    NEXT program_attributes_ptr IN program_description_ptr;

    IF (program_attributes_ptr = NIL) OR (NOT (pmc$starting_proc_specified IN
          program_attributes_ptr^.contents)) THEN
      osp$set_status_abnormal ('PM', ose$undefined_condition,
            'Program description does not contain starting procedure.', status);
      RETURN;
    IFEND;

    pmp$load (program_attributes_ptr^.starting_procedure, pmc$procedure_address, loaded_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, loaded_program);
    loaded_program_name := program_attributes_ptr^.starting_procedure;

  PROCEND load_program;
?? TITLE := 'call_program', EJECT ??

  PROCEDURE call_program
    (    loaded_program: pmt$program;
         program_parameters: pmt$program_parameters;
     VAR status: ost$status);

    VAR
      callers_save_area: ^ost$stack_frame_save_area;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information,
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        exit_status: ^ost$status;


      CASE condition.selector OF

      = pmc$system_conditions =

{ same checks as invoke_sub_command (in clm$process_commands)
{ for an abort on the attempt to call the "program"

        IF ($pmt$system_conditions [pmc$instruction_specification, pmc$address_specification,
              pmc$access_violation, pmc$environment_specification, pmc$invalid_segment_ring_0,
              pmc$out_call_in_return] * condition.system_conditions) <> $pmt$system_conditions [] THEN
          IF save_area^.minimum_save_area.a2_previous_save_area = callers_save_area THEN
            osp$set_status_abnormal ('PM', ose$undefined_condition,
                  'Unable to call starting procedure of task.', status);
            EXIT call_program;
          IFEND;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = exiting THEN
          exit_status := condition_descriptor;
          status := exit_status^;
          EXIT call_program;
        IFEND;

      = pmc$block_exit_processing =
        task_termination_cleanup;
        RETURN;

      ELSE
        ;
      CASEND;

      osp$set_status_from_condition ('CL', condition, save_area, status, handler_status);
      IF handler_status.normal THEN
        EXIT call_program;
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    callers_save_area := #PREVIOUS_SAVE_AREA ();
    osp$establish_condition_handler (^abort_handler, TRUE);

    loaded_program^ (program_parameters, status);

    task_termination_cleanup;

    osp$disestablish_cond_handler;

  PROCEND call_program;
?? TITLE := 'task_termination_cleanup', EJECT ??

  PROCEDURE task_termination_cleanup;

    ?IF fsc$compiling_for_test_harness THEN
      bap$task_termination_cleanup;
    ?IFEND

  PROCEND task_termination_cleanup;
?? TITLE := 'display', EJECT ??

  PROCEDURE [XDCL] display
    (    display_line: string ( * <= 256));

    VAR
      length: integer,
      working_string: string (256),
      status: ost$status;

    STRINGREP (working_string, length, ' ', display_line);
    pmp$log (working_string (1, length), status);

{   IF NOT clc$compiling_for_test_harness THEN
{   clp$put_job_command_response (working_string (1,length), status);
{   IFEND

  PROCEND display;
?? TITLE := 'display_integer', EJECT ??

  PROCEDURE [XDCL] display_integer
    (    descriptor: string ( * <= 128);
         number: integer);

    VAR
      working_string: string (255),
      descriptor_length: integer,
      number_length: integer,
      total_length: integer;

    working_string := descriptor;
    descriptor_length := STRLENGTH (descriptor);
    STRINGREP (working_string ((descriptor_length + 2), * ), number_length, number);
    total_length := number_length + descriptor_length + 2;
    display (working_string (1, total_length));

  PROCEND display_integer;
?? TITLE := 'display_job_information', EJECT ??

  PROCEDURE [XDCL] display_job_information
    (    display_current_job: boolean;
         display_current_task: boolean);

    IF display_current_job THEN
      display_integer (' ***************** current job  ', current_job);
    IFEND;
    IF display_current_task THEN
      display_integer (' ------------  current task ', jobs [current_job].current_task);
    IFEND;

  PROCEND display_job_information;
?? TITLE := 'display_status', EJECT ??

  PROCEDURE [XDCL] display_status
    (    status: ost$status);

    VAR
      request_status: ost$status,
      message: ost$status_message,
      p_message: ^ost$status_message,
      p_line_count: ^ost$status_message_line_count,
      p_message_line: ^string ( * ),
      line_count: ost$status_message_line_count,
      p_line_size: ^ost$status_message_line_size;

    request_status.normal := TRUE;
    IF status.normal THEN
      display (' STATUS NORMAL ');
      RETURN;
    ELSE
      display (' STATUS abnormal');
      display_integer (' condition ', status.condition);
      display (status.text.value (1, status.text.size));
      RETURN;
    IFEND;
    p_message := ^message;
    RESET p_message;
    osp$format_message (status, osc$full_message_level, osc$max_string_size, p_message^, request_status);
    IF NOT request_status.normal THEN
      display (' unable to display status ');
      RETURN;
    IFEND;
    RESET p_message;
    NEXT p_line_count IN p_message;
    IF p_line_count^ > 0 THEN
      FOR line_count := 1 TO (p_line_count^) DO
        NEXT p_line_size IN p_message;
        NEXT p_message_line: [p_line_size^] IN p_message;
        display (p_message_line^);
      FOREND;
    IFEND;

  PROCEND display_status;
?? TITLE := 'display_to_log', EJECT ??

  PROCEDURE [XDCL] display_to_log
    (    display_line: string ( * <= 256));

    VAR
      length: integer,
      working_string: string (256),
      status: ost$status;

    STRINGREP (working_string, length, ' ', display_line);
    pmp$log (working_string (1, length), status);

  PROCEND display_to_log;
?? TITLE := 'display_integer_to_log', EJECT ??

  PROCEDURE [XDCL] display_integer_to_log
    (    descriptor: string ( * <= 128);
         number: integer);

    VAR
      working_string: string (255),
      descriptor_length: integer,
      number_length: integer,
      total_length: integer;

    working_string := descriptor;
    descriptor_length := STRLENGTH (descriptor);
    STRINGREP (working_string ((descriptor_length + 2), * ), number_length, number);
    total_length := number_length + descriptor_length + 2;
    display_to_log (working_string (1, total_length));

  PROCEND display_integer_to_log;
?? TITLE := 'display_status_to_log', EJECT ??

  PROCEDURE [XDCL] display_status_to_log
    (    status: ost$status);


    VAR
      request_status: ost$status,
      message: ost$status_message,
      p_message: ^ost$status_message,
      p_line_count: ^ost$status_message_line_count,
      p_message_line: ^string ( * ),
      line_count: ost$status_message_line_count,
      p_line_size: ^ost$status_message_line_size;

    request_status.normal := TRUE;
    IF status.normal THEN
      display_to_log (' STATUS NORMAL ');
      RETURN;
    ELSE
      display_to_log (' STATUS abnormal');
      display_integer_to_log (' condition ', status.condition);
      display_to_log (status.text.value (1, status.text.size));
      RETURN;
    IFEND;
    p_message := ^message;
    RESET p_message;
    osp$format_message (status, osc$full_message_level, osc$max_string_size, p_message^, request_status);
    IF NOT request_status.normal THEN
      display_to_log (' unable to display_to_log status ');
      RETURN;
    IFEND;
    RESET p_message;
    NEXT p_line_count IN p_message;
    IF p_line_count^ > 0 THEN
      FOR line_count := 1 TO (p_line_count^) DO
        NEXT p_line_size IN p_message;
        NEXT p_message_line: [p_line_size^] IN p_message;
        display_to_log (p_message_line^);
      FOREND;
    IFEND;

  PROCEND display_status_to_log;
?? TITLE := 'iip$direct_fetch_trm_conn_atts', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$direct_fetch_trm_conn_atts
    (    file_identifier: amt$file_identifier;
     VAR terminal_attributes: ift$get_connection_attributes;
     VAR status: ost$status);


    ifp$fetch_term_conn_attributes (file_identifier, terminal_attributes, status);

  PROCEND iip$direct_fetch_trm_conn_atts;
?? TITLE := 'iip$direct_store_trm_conn_atts', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$direct_store_trm_conn_atts
    (    file_identifier: amt$file_identifier;
         terminal_attributes: ift$connection_attributes;
     VAR status: ost$status);


    ifp$store_term_conn_attributes (file_identifier, terminal_attributes, status);

  PROCEND iip$direct_store_trm_conn_atts;

MODEND clm$test_harness_common_support;

*DECK DECK=CLM$TEST_HARNESS_SCL_SUPPORT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'SCL test harness support' ??
MODULE clm$test_harness_scl_support;

{
{ This module contains support code for the SCL test harness
{ in the following groups:
{   1. variables,
{   2. interfaces,
{   3. command processors.
{

*copyc clc$compiling_for_test_harness
*copyc fsc$compiling_for_test_harness

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc avt$account_name
*copyc avt$conditional_capabilities
*copyc avt$project_name
*copyc avt$validation_record
*copyc bat$process_pt_work_list
*copyc bat$process_pt_results
*copyc cld$value
*copyc clt$command_table
*copyc clt$connected_file
*copyc clt$name
*copyc clt$parameter_substitutions
*copyc clt$parameter_value_table
*copyc clt$unbundled_pdt
*copyc clt$work_area
*copyc clv$user_identification
*copyc fmt$cycle_description
*copyc fmt$path_handle
*copyc fmt$cycle_description
*copyc fst$evaluated_file_reference
*copyc fst$file_reference
*copyc jmt$application_attributes
*copyc jmt$application_index
*copyc jmt$application_name
*copyc jmt$job_class
*copyc jmt$service_accumulator
*copyc osd$code_base_pointer
*copyc osd$virtual_address
*copyc oss$job_pageable
*copyc oss$job_paged_literal
*copyc oss$mainframe_pageable
*copyc oss$task_shared
*copyc ost$deadstart_phase
*copyc ost$name
*copyc ost$name_reference
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc ost$user_identification
*copyc pmt$stack_segment
*copyc rmt$device_class
?? POP ??
*copyc bap$process_pt_request
*copyc pmp$load
*copyc pmp$log_ascii
*copyc pmp$test_condition_handler
?? TITLE := 'Stubbed variables', EJECT ??

  VAR
    avv$logged_in: [STATIC, oss$job_pageable] boolean := FALSE;

  VAR
    avv$active_sou_capabilities: [XDCL, oss$task_shared] avt$conditional_capabilities
      := -$avt$conditional_capabilities[];

  VAR
    amv$nil_file_identifier: [XDCL, READ, oss$job_paged_literal] amt$file_identifier :=
          [0, 1];
  VAR
    clv$command_statistics_enabled: [XDCL, oss$mainframe_pageable] boolean := FALSE;

  VAR
    clv$operator_commands: [XDCL, READ, oss$job_paged_literal] ^clt$command_table := NIL;

  VAR
    clv$secure_logging_activated: [XDCL, oss$mainframe_pageable] boolean := FALSE;

  VAR
    clv$system_logging_activated: [XDCL, oss$mainframe_pageable] boolean := FALSE;

  VAR
    jmv$job_history_active: [XDCL, oss$mainframe_pageable] boolean := FALSE;

  VAR
    mmv$max_segment_length: [XDCL] integer := 150000000;

  VAR
    pmv$unseen_mail_pending: [XDCL, oss$task_shared] boolean := FALSE;

?? TITLE := 'Stubbed interfaces', EJECT ??

  FUNCTION [XDCL] avp$already_logged_in: boolean;

    avp$already_logged_in := avv$logged_in;

  FUNCEND avp$already_logged_in;
?? SKIP := 3 ??

  PROCEDURE [XDCL] avp$begin_job_account
    (    family_name: ost$family_name;
         user_name: ost$user_name;
         account_name: avt$account_name;
         project_name: avt$project_name;
         user_supplied_job_name: ost$name;
         job_class: jmt$job_class;
     VAR status: ost$status);

    status.normal := TRUE;

  PROCEND avp$begin_job_account;
?? SKIP := 3 ??

  PROCEDURE [XDCL] avp$activate_family_admin
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

     status.normal := TRUE;

  PROCEND avp$activate_family_admin;
?? SKIP := 3 ??

  PROCEDURE [XDCL] avp$activate_system_admin
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    status.normal := TRUE;

  PROCEND avp$activate_system_admin;
?? SKIP := 3 ??

  PROCEDURE [XDCL] avp$deactivate_family_admin
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

     status.normal := TRUE;

   PROCEND avp$deactivate_family_admin;
?? SKIP := 3 ??

  PROCEDURE [XDCL] avp$deactivate_system_admin
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

     status.normal := TRUE;

   PROCEND avp$deactivate_system_admin;
?? SKIP := 3 ??

  PROCEDURE [XDCL] avp$end_job_account
    (VAR status: ost$status);

    status.normal := TRUE;

  PROCEND avp$end_job_account;
?? SKIP := 3 ??

  FUNCTION [XDCL] avp$get_account_project_specif: boolean;

    avp$get_account_project_specif := FALSE;

  FUNCEND avp$get_account_project_specif;
?? SKIP := 3 ??

  PROCEDURE [XDCL] avp$initialize_constrain
    (VAR status: ost$status);

    status.normal := TRUE;

  PROCEND avp$initialize_constrain;
?? SKIP := 3 ??

  PROCEDURE [XDCL] avp$mark_login_as_complete
    (VAR status: ost$status);

    status.normal := TRUE;
    avv$logged_in := TRUE;

  PROCEND avp$mark_login_as_complete;
?? SKIP := 3 ??

  PROCEDURE [XDCL] avp$set_account_project
    (    account: avt$account_name;
         project: avt$project_name;
     VAR status: ost$status);

    status.normal := TRUE;

  PROCEND avp$set_account_project;
?? SKIP := 3 ??
  ?IF NOT fsc$compiling_for_test_harness THEN

    PROCEDURE [XDCL] bap$close_obsolete_target_files
      (    connected_files: ^clt$connected_files);

    PROCEND bap$close_obsolete_target_files;

  PROCEDURE [XDCL] bap$set_private_read (file: fst$file_reference,
        private_read: boolean;
    VAR status: ost$status);

  PROCEND bap$set_private_read;
  ?IFEND
?? SKIP := 3 ??

  PROCEDURE [XDCL] fmp$evaluate_path
    (    file: fst$file_reference;
         process_pt_work_list: bat$process_pt_work_list;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

      status.normal := TRUE;
      evaluated_file_reference.path_handle_info.path_handle_present := FALSE;

  PROCEND fmp$evaluate_path;
?? SKIP := 3 ??

  PROCEDURE [XDCL] fmp$file_is_local
    (    local_file_name: amt$local_file_name;
     VAR file_is_local: boolean);

    file_is_local := TRUE;

  PROCEND fmp$file_is_local;
?? SKIP := 3 ??

  PROCEDURE [XDCL] fmp$process_pt_request (
        process_pt_work_list: bat$process_pt_work_list;
        local_file_name: amt$local_file_name;
    VAR evaluated_file_reference: fst$evaluated_file_reference;
    VAR cycle_description: ^fmt$cycle_description;
    VAR process_pt_results: bat$process_pt_results;
    VAR status: ost$status);

     status.normal := TRUE;
     bap$process_pt_request (process_pt_work_list, local_file_name,
           evaluated_file_reference, process_pt_results, status);

  PROCEND fmp$process_pt_request;

?? PUSH (LISTEXT := ON) ??
  ?IF NOT fsc$compiling_for_test_harness THEN
?? SKIP := 3 ??

  PROCEDURE [XDCL] fmp$request_null_device
    (    null_device_use: rmt$device_class;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR status: ost$status);

      status.normal := TRUE;

    PROCEND fmp$request_null_device;
  ?IFEND
?? SKIP := 3 ??

  PROCEDURE [XDCL] nfp$verify_family
   (    family_name: ost$family_name;
    VAR family_is_local: boolean;
    VAR status: ost$status);


    status.normal := TRUE;
    family_is_local := family_name <> 'REMOTE';

  PROCEND nfp$verify_family;
?? SKIP := 3 ??

  PROCEDURE [XDCL] avp$get_capability
    (    field_name: ost$name;
         record_level: avt$validation_record;
     VAR capability: boolean;
     VAR status: ost$status);


    status.normal := TRUE;
    capability := TRUE;

  PROCEND avp$get_capability;
?? SKIP := 3 ??

  PROCEDURE [XDCL] osp$initialize_virtual_system
    (    deadstart_phase: ost$deadstart_phase);

  PROCEND osp$initialize_virtual_system;
?? SKIP := 3 ??

  PROCEDURE [XDCL] osp$run_virtual_system
    (    system_restart: boolean;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND osp$run_virtual_system;
?? SKIP := 3 ??

  PROCEDURE [XDCL] pmp$dispose_interactive_cond
    (    interactive_condition: ift$interactive_condition);

    VAR
      condition: pmt$condition,
      ignore_status: ost$status,
      save_area: ^ost$stack_frame_save_area;

    condition.selector := ifc$interactive_condition;
    condition.interactive_condition := interactive_condition;
    save_area := #PREVIOUS_SAVE_AREA ();
    pmp$test_condition_handler (condition, save_area, ignore_status);

  PROCEND pmp$dispose_interactive_cond;
?? SKIP := 3 ??

  PROCEDURE [XDCL] pmp$load_from_library
    (    name: pmt$program_name;
         ring: ost$ring;
         global_key: ost$key_lock_value;
         kind: pmt$loaded_address_kind;
         library: ^SEQ ( * );
         library_name: amt$local_file_name;
     VAR address: pmt$loaded_address;
     VAR status: ost$status);

    pmp$load (name, kind, address, status);

  PROCEND pmp$load_from_library;
?? SKIP := 3 ??

  PROCEDURE [XDCL] pmp$outward_call (callee: ^ost$external_code_base_pointer;
    ring: ost$ring;
    parameter_list: ^cell;
    preceding_sfsa: ^ost$stack_frame_save_area;
    VAR stack_segment: ^pmt$stack_segment);

  PROCEND pmp$outward_call;
?? SKIP := 3 ??

  PROCEDURE [XDCL] rap$establish_variables
    (VAR status: ost$status);

    status.normal := TRUE;

  PROCEND rap$establish_variables;
?? SKIP := 3 ??

  PROCEDURE [XDCL] syp$store_system_constant
    (    name: string ( * );
         index: integer;
         value: integer;
     VAR status: ost$status);

    status.normal := TRUE;

  PROCEND syp$store_system_constant;
?? SKIP := 3 ??

  PROCEDURE [XDCL] jmp$disable_user_breaks;

  PROCEND jmp$disable_user_breaks;
?? SKIP := 3 ??

  PROCEDURE [XDCL] jmp$enable_exit_processing;

  PROCEND jmp$enable_exit_processing;
?? SKIP := 3 ??

  PROCEDURE [XDCL] jmp$enable_terminal_io;

  PROCEND jmp$enable_terminal_io;
?? SKIP := 3 ??

  PROCEDURE [XDCL] jmp$enable_user_breaks;

  PROCEND jmp$enable_user_breaks;
?? SKIP := 3 ??
  PROCEDURE [XDCL] jmp$end_application_scheduling
    (VAR status: ost$status);

    status.normal := TRUE;

  PROCEND jmp$end_application_scheduling;
?? SKIP := 3 ??
  PROCEDURE [XDCL] jmp$get_job_class_prolog
    (VAR job_class_prolog: fst$file_reference;
     VAR status: ost$status);

    status.normal := TRUE;
    job_class_prolog := '';

  PROCEND jmp$get_job_class_prolog;
?? SKIP := 3 ??

  PROCEDURE [XDCL] jmp$inhibit_exit_processing;

  PROCEND jmp$inhibit_exit_processing;
?? SKIP := 3 ??
?? NEWTITLE := '[XDCL] jmp$log_edited_login_command', EJECT ??

  PROCEDURE [XDCL] jmp$log_edited_login_command
    (VAR status: ost$status);

    CONST
      line_size_maximum = 2000;

    VAR
      ascii_logset: pmt$ascii_logset,
      line: string (line_size_maximum),
      line_size: 0 .. line_size_maximum;

?? NEWTITLE := '[INLINE] add_to_line', EJECT ??

    PROCEDURE [INLINE] add_to_line
      (    text: string ( * ));

      line (line_size + 1, STRLENGTH (text)) := text;
      line_size := line_size + STRLENGTH (text);
      WHILE (line_size > 0) AND (line (line_size) = ' ') DO
        line_size := line_size - 1;
      WHILEND;

    PROCEND add_to_line;
?? OLDTITLE ??

    status.normal := TRUE;

    line_size := 0;
    add_to_line ('LOGIN, LOGIN_USER=');
    add_to_line (clv$user_identification.user.value (1, clv$user_identification.user.size));
    add_to_line (', LOGIN_FAMILY=');
    add_to_line (clv$user_identification.family.value (1, clv$user_identification.family.size));
    add_to_line (', LOGIN_ACCOUNT=');
    add_to_line ('NONE');
    add_to_line (', LOGIN_PROJECT=');
    add_to_line ('NONE');
    add_to_line (', JOB_CLASS=SCL_TEST_HARNESS');

    ascii_logset := $pmt$ascii_logset [pmc$job_log];

    pmp$log_ascii (line (1, line_size), ascii_logset, pmc$msg_origin_command, status);

  PROCEND jmp$log_edited_login_command;
?? SKIP := 3 ??
  PROCEDURE [XDCL] jmp$read_application_record
    (    application_name: jmt$application_name;
     VAR application_index: {input, output} jmt$application_index;
     VAR application_record: jmt$application_attributes;
     VAR status: ost$status);

     status.normal := TRUE;

  PROCEND jmp$read_application_record;

?? SKIP := 3 ??
  PROCEDURE [XDCL] jmp$set_application_scheduling
    (    application_attributes: jmt$application_attributes;
         new_service_accumulator: jmt$service_accumulator;
     VAR old_service_accumulator: jmt$service_accumulator;
     VAR status: ost$status);

     status.normal := TRUE;

   PROCEND jmp$set_application_scheduling;

?? SKIP := 3 ??
  PROCEDURE [XDCL] jmp$reset_dispatching_priority;

  PROCEND jmp$reset_dispatching_priority;
?? TITLE := 'Stubbed command processors', EJECT ??

  PROCEDURE [XDCL] avp$change_password_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND avp$change_password_command;

  PROCEDURE [XDCL] avp$emit_permanent_file_stats
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND avp$emit_permanent_file_stats;

  PROCEDURE [XDCL] clp$activate_keypoints
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$activate_keypoints;

  PROCEDURE [XDCL] clp$deactivate_keypoints
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$deactivate_keypoints;

  PROCEDURE [XDCL] clp$display_job_attr_def_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$display_job_attr_def_cmnd;

  PROCEDURE [XDCL] clp$display_job_data_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$display_job_data_command;

  PROCEDURE [XDCL] clp$display_job_history_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$display_job_history_command;

  PROCEDURE [XDCL] clp$display_keypoint_env
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$display_keypoint_env;

  PROCEDURE [XDCL] clp$display_keypoint_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$display_keypoint_file;

  PROCEDURE [XDCL] clp$display_multipro_opt_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$display_multipro_opt_cmd;

  PROCEDURE [XDCL] clp$display_output_history_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$display_output_history_cmd;

  PROCEDURE [XDCL] clp$display_system_data_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$display_system_data_command;

  PROCEDURE [XDCL] clp$release_spi_environment
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$release_spi_environment;

  PROCEDURE [XDCL] clp$reserve_spi_environment
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$reserve_spi_environment;

  PROCEDURE [XDCL] clp$start_spi_collection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$start_spi_collection;

  PROCEDURE [XDCL] clp$stop_spi_collection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$stop_spi_collection;

  PROCEDURE [XDCL] mmp$manage_memory
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND mmp$manage_memory;

  PROCEDURE [XDCL] ofp$send_operator_message_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND ofp$send_operator_message_cmd;

  PROCEDURE [XDCL] pfp$change_catalog_contents_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND pfp$change_catalog_contents_cmd;

  PROCEDURE [XDCL] pfp$move_classes_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND pfp$move_classes_command;

  PROCEDURE [XDCL] pfp$process_storage
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND pfp$process_storage;

  PROCEDURE [XDCL] pfp$_update_perm_file_space_lim
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND pfp$_update_perm_file_space_lim;

  PROCEDURE [XDCL] sfp$_activate_job_statistic
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND sfp$_activate_job_statistic;

  PROCEDURE [XDCL] sfp$activate_local_stat_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND sfp$activate_local_stat_command;

  PROCEDURE [XDCL] sfp$activate_sys_stat_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND sfp$activate_sys_stat_command;

  PROCEDURE [XDCL] sfp$_change_job_limit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND sfp$_change_job_limit;

  PROCEDURE [XDCL] sfp$_deactivate_job_statistic
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND sfp$_deactivate_job_statistic;

  PROCEDURE [XDCL] sfp$deactivate_local_stat_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND sfp$deactivate_local_stat_cmd;

  PROCEDURE [XDCL] sfp$deactivate_sys_stat_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND sfp$deactivate_sys_stat_command;

  PROCEDURE [XDCL] sfp$_display_active_job_statist
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND sfp$_display_active_job_statist;

  PROCEDURE [XDCL] sfp$_display_active_system_stat
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND sfp$_display_active_system_stat;

  PROCEDURE [XDCL] sfp$_display_job_limit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND sfp$_display_job_limit;

  PROCEDURE [XDCL] sfp$_set_job_limit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND sfp$_set_job_limit;

  ?IF NOT fsc$compiling_for_test_harness THEN

    PROCEDURE [XDCL] rhp$_get_file
      (    parameter_list: clt$parameter_list;
       VAR status: ost$status);

    PROCEND rhp$_get_file;
  ?IFEND

  PROCEDURE [XDCL] clp$issue_keypoint
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$issue_keypoint;

  PROCEDURE [XDCL] clp$issue_string_as_keypoint
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$issue_string_as_keypoint;

  PROCEDURE [XDCL] clp$link_user_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$link_user_command;

  PROCEDURE [XDCL] clp$release_keypoint_env
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$release_keypoint_env;

  ?IF NOT fsc$compiling_for_test_harness THEN

    PROCEDURE [XDCL] rhp$_replace_file
      (    parameter_list: clt$parameter_list;
       VAR status: ost$status);

    PROCEND rhp$_replace_file;
  ?IFEND

  PROCEDURE [XDCL] clp$request_op_action_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$request_op_action_command;

  PROCEDURE [XDCL] clp$reserve_keypoint_env
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$reserve_keypoint_env;

  PROCEDURE [XDCL] clp$set_multipro_opt_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$set_multipro_opt_cmd;

  PROCEDURE [XDCL] clp$set_spy_identifier
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$set_spy_identifier;

  PROCEDURE [XDCL] clp$start_keypoint_collection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$start_keypoint_collection;

  PROCEDURE [XDCL] clp$stop_keypoint_collection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$stop_keypoint_collection;

  PROCEDURE [XDCL] clp$test_keypoint_collection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$test_keypoint_collection;

  PROCEDURE [XDCL] jmp$wait_system_idle_comnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND jmp$wait_system_idle_comnd;

  PROCEDURE [XDCL] nfp$_create_remote_validation
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND nfp$_create_remote_validation;

  PROCEDURE [XDCL] nfp$_delete_remote_validation
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND nfp$_delete_remote_validation;

  PROCEDURE [XDCL] nfp$_submit_multi_record_job
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND nfp$_submit_multi_record_job;

  PROCEDURE [XDCL] nfp$display_remote_validation
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND nfp$display_remote_validation;

  PROCEDURE [XDCL] nfp$manage_remote_files
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND nfp$manage_remote_files;

  PROCEDURE [XDCL] osp$deactivate_job_template
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);
  PROCEND osp$deactivate_job_template;

  PROCEDURE [XDCL] rhp$_change_link_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND rhp$_change_link_attributes;

  PROCEDURE [XDCL] rhp$_set_link_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND rhp$_set_link_attributes;

  PROCEDURE [XDCL] rhp$display_link_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND rhp$display_link_attributes;

  PROCEDURE [XDCL] clp$suspend_simulation_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEND clp$suspend_simulation_command;

?? TITLE := 'Stubbed function processors', EJECT ??
  ?IF NOT fsc$compiling_for_test_harness THEN

  PROCEDURE [XDCL] avp$$security_option
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    status.normal := TRUE;

  PROCEND avp$$security_option;

  PROCEDURE [XDCL] avp$$validation_level
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    status.normal := TRUE;

  PROCEND avp$$validation_level;

  PROCEDURE [XDCL] avp$$job_validation
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    status.normal := TRUE;

  PROCEND avp$$job_validation;
  ?IFEND

  PROCEDURE [XDCL] nfp$$remote_validation
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEND nfp$$remote_validation;

  PROCEDURE [XDCL] sfp$$job_limit
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEND sfp$$job_limit;
?? OLDTITLE ??

MODEND clm$test_harness_scl_support;

*DECK DECK=CLM$TEST_UTILITY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE System Command Language Test Utility (SCLTU)' ??
MODULE clm$test_utility;

{
{ PURPOSE:
{   This module contains a command utility used to test command language
{   supplied interfaces.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$max_integer
*copyc clc$min_integer
*copyc cle$work_area_overflow
*copyc clt$parameter_list
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*copyc clp$begin_utility
*copyc clp$build_pattern_for_wild_card
*copyc clp$change_variable
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$convert_real_to_string
*copyc clp$convert_string_to_file
*copyc clp$convert_string_to_integer
*copyc clp$convert_string_to_name
*copyc clp$convert_string_to_real
*copyc clp$edit_command_parameter_list
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$evaluate_token
*copyc clp$get_job_parameters
*copyc clp$include_file
*copyc clp$make_boolean_value
*copyc clp$make_integer_value
*copyc clp$make_list_value
*copyc clp$make_sized_string_value
*copyc clp$make_value
*copyc clp$match_string_pattern
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$sp_convert_to_string
*copyc clp$trimmed_string_size
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
*copyc osp$set_status_abnormal

?? TITLE := 'utility command and function tables, etc.', EJECT ??

  SECTION
    read_only: READ;

  CONST
    utility_name = 'SCLTU                          ',
    utility_prompt = 'SCLTU';

{ table command_table section_name=read_only
{ command (quit qui), quit
{ command (clp$convert_string_to_integer convert_string_to_integer consti), convert_string_to_integer
{ command (clp$convert_string_to_name convert_string_to_name constn), convert_string_to_name
{ command (clp$convert_string_to_real convert_string_to_real constr), convert_string_to_real
{ command (clp$edit_command_parameter_list edit_command_parameter_list edicpl), edit_command_parameter_list
{ command (clp$evaluate_token evaluate_token evat), evaluate_token
{ command (clp$get_job_parameters get_job_parameters getjp), get_job_parameters
{ command (test_string_patterns test_string_pattern tessp), test_string_patterns
{ command (display_string_pattern dissp), display_string_pattern
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    command_table: [STATIC, READ, read_only] ^clt$command_table := ^command_table_entries,

    command_table_entries: [STATIC, READ, read_only] array [1 .. 23] of clt$command_table_entry := [
          {} ['CLP$CONVERT_STRING_TO_INTEGER  ', clc$nominal_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^convert_string_to_integer],
          {} ['CLP$CONVERT_STRING_TO_NAME     ', clc$nominal_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^convert_string_to_name],
          {} ['CLP$CONVERT_STRING_TO_REAL     ', clc$nominal_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^convert_string_to_real],
          {} ['CLP$EDIT_COMMAND_PARAMETER_LIST', clc$nominal_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^edit_command_parameter_list],
          {} ['CLP$EVALUATE_TOKEN             ', clc$nominal_entry, clc$normal_usage_entry, 6,
          clc$automatically_log, clc$linked_call, ^evaluate_token],
          {} ['CLP$GET_JOB_PARAMETERS         ', clc$nominal_entry, clc$normal_usage_entry, 7,
          clc$automatically_log, clc$linked_call, ^get_job_parameters],
          {} ['CONSTI                         ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^convert_string_to_integer],
          {} ['CONSTN                         ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^convert_string_to_name],
          {} ['CONSTR                         ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^convert_string_to_real],
          {} ['CONVERT_STRING_TO_INTEGER      ', clc$alias_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^convert_string_to_integer],
          {} ['CONVERT_STRING_TO_NAME         ', clc$alias_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^convert_string_to_name],
          {} ['CONVERT_STRING_TO_REAL         ', clc$alias_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^convert_string_to_real],
          {} ['EDICPL                         ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^edit_command_parameter_list],
          {} ['EDIT_COMMAND_PARAMETER_LIST    ', clc$alias_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^edit_command_parameter_list],
          {} ['EVALUATE_TOKEN                 ', clc$alias_entry, clc$normal_usage_entry, 6,
          clc$automatically_log, clc$linked_call, ^evaluate_token],
          {} ['EVAT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
          clc$automatically_log, clc$linked_call, ^evaluate_token],
          {} ['GETJP                          ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
          clc$automatically_log, clc$linked_call, ^get_job_parameters],
          {} ['GET_JOB_PARAMETERS             ', clc$alias_entry, clc$normal_usage_entry, 7,
          clc$automatically_log, clc$linked_call, ^get_job_parameters],
          {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^quit],
          {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^quit],
          {} ['TESSP                          ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
          clc$automatically_log, clc$linked_call, ^test_string_patterns],
          {} ['TEST_STRING_PATTERN            ', clc$alias_entry, clc$normal_usage_entry, 8,
          clc$automatically_log, clc$linked_call, ^test_string_patterns],
          {} ['TEST_STRING_PATTERNS           ', clc$nominal_entry, clc$normal_usage_entry, 8,
          clc$automatically_log, clc$linked_call, ^test_string_patterns]];

?? POP ??

{ table function_table type=function section_name=read_only
{ function ($memory $mem), clp$$memory, " availability=advanced_usage
{ function ($memory_string $ms), clp$$memory_string, " availability=advanced_usage
{ function ($nil_pva $np), clp$$nil_pva, " availability=advanced_usage
{ function $match                         clp$$match xref
{ function $sp_any                        clp$$sp_any xref
{ function $sp_balance                    clp$$sp_balance xref
{ function $sp_capture                    clp$$sp_capture xref
{ function $sp_count                      clp$$sp_count xref
{ function $sp_defer                      clp$$sp_defer xref
{ function $sp_fail                       clp$$sp_fail xref
{ function $sp_fence                      clp$$sp_fence xref
{ function $sp_left                       clp$$sp_left xref
{ function $sp_index                      clp$$sp_index xref
{ function $sp_not_any                    clp$$sp_not_any xref
{ function $sp_null                       clp$$sp_null xref
{ function $sp_or                         clp$$sp_or xref
{ function $sp_repeat                     clp$$sp_repeat xref
{ function $sp_right                      clp$$sp_right xref
{ function $sp_stop                       clp$$sp_stop xref
{ function $sp_string                     clp$$sp_string xref
{ function $sp_succeed                    clp$$sp_succeed xref
{ function $sp_test                       clp$$sp_test xref
{ function $sp_upto                       clp$$sp_upto xref
{ function ($sp_wild_card                 ,$sp_wc) clp$$sp_wild_card xref
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  function_table: [STATIC, READ, read_only] ^clt$function_processor_table := ^function_table_entries,

  function_table_entries: [STATIC, READ, read_only] array [1 .. 28] of clt$function_proc_table_entry := [
  {} ['$MATCH                         ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$linked_call, ^clp$$match],
  {} ['$MEM                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
        clc$linked_call, ^clp$$memory],
  {} ['$MEMORY                        ', clc$nominal_entry, clc$normal_usage_entry, 1,
        clc$linked_call, ^clp$$memory],
  {} ['$MEMORY_STRING                 ', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$linked_call, ^clp$$memory_string],
  {} ['$MS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
        clc$linked_call, ^clp$$memory_string],
  {} ['$NIL_PVA                       ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$linked_call, ^clp$$nil_pva],
  {} ['$NP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$linked_call, ^clp$$nil_pva],
  {} ['$SP_ANY                        ', clc$nominal_entry, clc$normal_usage_entry, 5,
        clc$linked_call, ^clp$$sp_any],
  {} ['$SP_BALANCE                    ', clc$nominal_entry, clc$normal_usage_entry, 6,
        clc$linked_call, ^clp$$sp_balance],
  {} ['$SP_CAPTURE                    ', clc$nominal_entry, clc$normal_usage_entry, 7,
        clc$linked_call, ^clp$$sp_capture],
  {} ['$SP_COUNT                      ', clc$nominal_entry, clc$normal_usage_entry, 8,
        clc$linked_call, ^clp$$sp_count],
  {} ['$SP_DEFER                      ', clc$nominal_entry, clc$normal_usage_entry, 9,
        clc$linked_call, ^clp$$sp_defer],
  {} ['$SP_FAIL                       ', clc$nominal_entry, clc$normal_usage_entry, 10,
        clc$linked_call, ^clp$$sp_fail],
  {} ['$SP_FENCE                      ', clc$nominal_entry, clc$normal_usage_entry, 11,
        clc$linked_call, ^clp$$sp_fence],
  {} ['$SP_INDEX                      ', clc$nominal_entry, clc$normal_usage_entry, 13,
        clc$linked_call, ^clp$$sp_index],
  {} ['$SP_LEFT                       ', clc$nominal_entry, clc$normal_usage_entry, 12,
        clc$linked_call, ^clp$$sp_left],
  {} ['$SP_NOT_ANY                    ', clc$nominal_entry, clc$normal_usage_entry, 14,
        clc$linked_call, ^clp$$sp_not_any],
  {} ['$SP_NULL                       ', clc$nominal_entry, clc$normal_usage_entry, 15,
        clc$linked_call, ^clp$$sp_null],
  {} ['$SP_OR                         ', clc$nominal_entry, clc$normal_usage_entry, 16,
        clc$linked_call, ^clp$$sp_or],
  {} ['$SP_REPEAT                     ', clc$nominal_entry, clc$normal_usage_entry, 17,
        clc$linked_call, ^clp$$sp_repeat],
  {} ['$SP_RIGHT                      ', clc$nominal_entry, clc$normal_usage_entry, 18,
        clc$linked_call, ^clp$$sp_right],
  {} ['$SP_STOP                       ', clc$nominal_entry, clc$normal_usage_entry, 19,
        clc$linked_call, ^clp$$sp_stop],
  {} ['$SP_STRING                     ', clc$nominal_entry, clc$normal_usage_entry, 20,
        clc$linked_call, ^clp$$sp_string],
  {} ['$SP_SUCCEED                    ', clc$nominal_entry, clc$normal_usage_entry, 21,
        clc$linked_call, ^clp$$sp_succeed],
  {} ['$SP_TEST                       ', clc$nominal_entry, clc$normal_usage_entry, 22,
        clc$linked_call, ^clp$$sp_test],
  {} ['$SP_UPTO                       ', clc$nominal_entry, clc$normal_usage_entry, 23,
        clc$linked_call, ^clp$$sp_upto],
  {} ['$SP_WC                         ', clc$abbreviation_entry, clc$normal_usage_entry, 24,
        clc$linked_call, ^clp$$sp_wild_card],
  {} ['$SP_WILD_CARD                  ', clc$nominal_entry, clc$normal_usage_entry, 24,
        clc$linked_call, ^clp$$sp_wild_card]];

  PROCEDURE [XREF] clp$$match
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_any
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_balance
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_capture
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_count
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_defer
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_fail
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_fence
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_index
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_left
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_not_any
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_null
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_or
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_repeat
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_right
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_stop
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_string
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_succeed
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_test
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_upto
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] clp$$sp_wild_card
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? POP ??



  VAR
    display_control: clt$display_control,
    first_time: boolean := TRUE,
    restart_utility: boolean,
    segment_pointer: amt$segment_pointer,
    work_area: ^clt$work_area;

?? TITLE := 'scltu', EJECT ??

  PROGRAM clp$_scl_test_utility
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE scl_test_utility, scltu (
{   input, i: file = $command
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (8),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 3, 14, 23, 2, 538],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$command'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$input = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      default_ring_attributes: amt$ring_attributes,
      file_reference: ^fst$file_reference,
      utility_attributes: array [1 .. 3] of clt$utility_attribute;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
    clp$open_display_reference (pvt [p$output].value^.file_value^, NIL, fsc$legible_data,
          default_ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    work_area := segment_pointer.sequence_pointer;

    REPEAT
      restart_utility := FALSE;

      utility_attributes [1].key := clc$utility_prompt;
      utility_attributes [1].prompt.value := utility_prompt;
      utility_attributes [1].prompt.size := STRLENGTH (utility_prompt);
      utility_attributes [2].key := clc$utility_command_table;
      utility_attributes [2].command_table := command_table;
      utility_attributes [3].key := clc$utility_function_proc_table;
      utility_attributes [3].function_processor_table := function_table;
      clp$begin_utility (utility_name, utility_attributes, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF first_time THEN
        first_time := FALSE;
        file_reference := pvt [p$input].value^.file_value;
      ELSEIF file_reference^ (1, STRLENGTH (':$COMMAND.')) <> ':$COMMAND.' THEN
        PUSH file_reference: [clp$trimmed_string_size (file_reference^) + STRLENGTH ('.$ASIS')];
        file_reference^ := pvt [p$input].value^.file_value^;
        file_reference^ (STRLENGTH (file_reference^) - STRLENGTH ('.$ASIS') + 1, * ) := '.$ASIS';
      IFEND;

      clp$include_file (file_reference^, utility_prompt, utility_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$end_utility (utility_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    UNTIL NOT restart_utility;

    clp$close_display (display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$delete_scratch_segment (segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND clp$_scl_test_utility;
?? TITLE := 'quit', EJECT ??

  PROCEDURE quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE quit, qui (
{   restart, r: boolean = no
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (2),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 3, 14, 53, 55, 176],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['R                              ',clc$abbreviation_entry, 1],
    ['RESTART                        ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type],
    'no'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$restart = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    restart_utility := pvt [p$restart].value^.boolean_value.value;

    clp$end_include (utility_name, status);

  PROCEND quit;
?? TITLE := 'pva_ring', EJECT ??

  FUNCTION [INLINE] pva_ring
    (    address: 0 .. 0ffffffffffff(16)): 0 .. 0f(16);


    pva_ring := address DIV 100000000000(16);

  FUNCEND pva_ring;
?? TITLE := 'pva_segment', EJECT ??

  FUNCTION [INLINE] pva_segment
    (    address: 0 .. 0ffffffffffff(16)): 0 .. 0fff(16);


    pva_segment := (address MOD 100000000000(16)) DIV 100000000(16);

  FUNCEND pva_segment;
?? TITLE := 'pva_offset', EJECT ??

  FUNCTION [INLINE] pva_offset
    (    address: 0 .. 0ffffffffffff(16)): -80000000(16) .. 7fffffff(16);

    VAR
      offset_converter: packed record
        case 1 .. 2 of
        = 1 =
          positive_offset: 0 .. 0ffffffff(16),
        = 2 =
          signed_offset: -80000000(16) .. 7fffffff(16),
        casend,
      recend;


    offset_converter.positive_offset := address MOD 100000000(16);
    pva_offset := offset_converter.signed_offset;

  FUNCEND pva_offset;
?? TITLE := 'clp$$memory', EJECT ??

  PROCEDURE [XDCL] clp$$memory
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $memory (
{   address: integer 0..0ffffffffffff(16) = $required
{   size: integer 1..8 = 6
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
    recend := [
    [1,
    [89, 8, 3, 15, 6, 33, 401],
    clc$function, 2, 2, 1, 0, 0, 0, 0, ''], [
    ['ADDRESS                        ',clc$nominal_entry, 1],
    ['SIZE                           ',clc$nominal_entry, 2]],
    [
{ 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, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, 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, 20,
  clc$optional_default_parameter, 0, 1]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 0ffffffffffff(16), 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, 8, 10],
    '6']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$address = 1,
      p$size = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      address: 0 .. 0ffffffffffff(16),
      pointer: ^string (8),
      size: 1 .. 8,
      word: string (8);


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    address := pvt [p$address].value^.integer_value.value;
    size := pvt [p$size].value^.integer_value.value;

    clp$make_integer_value (0, 16, TRUE, work_area, result);
    pointer := #ADDRESS (#RING (^address), pva_segment (address), pva_offset (address));
    #UNCHECKED_CONVERSION (result^.integer_value.value, word);
    word (8 + 1 - size, size) := pointer^ (1, size);
    #UNCHECKED_CONVERSION (word, result^.integer_value.value);

  PROCEND clp$$memory;
?? TITLE := 'clp$$memory_string', EJECT ??

  PROCEDURE [XDCL] clp$$memory_string
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $memory_string (
{   address: integer 0..0ffffffffffff(16) = $required
{   size: integer 0..cyc$max_string_size = 1
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
    recend := [
    [1,
    [89, 8, 3, 15, 56, 18, 198],
    clc$function, 2, 2, 1, 0, 0, 0, 0, ''], [
    ['ADDRESS                        ',clc$nominal_entry, 1],
    ['SIZE                           ',clc$nominal_entry, 2]],
    [
{ 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, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, 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, 20,
  clc$optional_default_parameter, 0, 1]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 0ffffffffffff(16), 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, cyc$max_string_size, 10],
    '1']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$address = 1,
      p$size = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      address: 0 .. 0ffffffffffff(16),
      pointer: ^string (cyc$max_string_size),
      size: 0 .. cyc$max_string_size;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    address := pvt [p$address].value^.integer_value.value;
    size := pvt [p$size].value^.integer_value.value;

    clp$make_sized_string_value (size, work_area, result);
    pointer := #ADDRESS (#RING (^address), pva_segment (address), pva_offset (address));
    result^.string_value^ := pointer^ (1, size);

  PROCEND clp$$memory_string;
?? TITLE := 'clp$$nil_pva', EJECT ??

  PROCEDURE [XDCL] clp$$nil_pva
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $nil_pva (
{   address: integer 0..0ffffffffffff(16) = $required
{   )

?? 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$integer_type_qualifier,
      recend,
    recend := [
    [1,
    [89, 8, 3, 16, 13, 33, 262],
    clc$function, 1, 1, 1, 0, 0, 0, 0, ''], [
    ['ADDRESS                        ',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, 20, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 0ffffffffffff(16), 10]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$address = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_boolean_value ((pvt [p$address].value^.integer_value.value DIV 80000000(16)) = 1ffff(16),
          clc$true_false_boolean, work_area, result);

  PROCEND clp$$nil_pva;
?? TITLE := 'convert_string_to_integer', EJECT ??

  PROCEDURE convert_string_to_integer
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE convert_string_to_integer, consti (
{   string, s: string = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 3, 18, 3, 43, 393],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['S                              ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2],
    ['STRING                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$string = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      int: clt$integer,
      str: ost$string;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_string_to_integer (pvt [p$string].value^.string_value^, int, status);
    IF status.normal THEN
      clp$convert_integer_to_string (int.value, int.radix, int.radix_specified, str, status);
      IF status.normal THEN
        clp$put_display (display_control, str.value (1, str.size), clc$no_trim, status);
      IFEND;
    IFEND;

  PROCEND convert_string_to_integer;
?? TITLE := 'convert_string_to_name', EJECT ??

  PROCEDURE convert_string_to_name
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE convert_string_to_name, constn (
{   string, s: string = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 3, 18, 3, 43, 393],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['S                              ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2],
    ['STRING                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$string = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      name: clt$name;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_string_to_name (pvt [p$string].value^.string_value^, name, status);
    IF status.normal THEN
      clp$put_display (display_control, name.value (1, name.size), clc$no_trim, status);
    IFEND;

  PROCEND convert_string_to_name;
?? TITLE := 'convert_string_to_real', EJECT ??

  PROCEDURE convert_string_to_real
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE convert_string_to_real, constr (
{   string, s: string = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 3, 18, 3, 43, 393],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['S                              ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2],
    ['STRING                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$string = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      real_number: clt$real,
      str: ost$string;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_string_to_real (pvt [p$string].value^.string_value^, real_number, status);
    IF status.normal THEN
      clp$convert_real_to_string (real_number.value, real_number.number_of_digits, str, status);
      IF status.normal THEN
        clp$put_display (display_control, str.value (1, str.size), clc$no_trim, status);
      IFEND;
    IFEND;

  PROCEND convert_string_to_real;
?? TITLE := 'edit_command_parameter_list', EJECT ??

  PROCEDURE edit_command_parameter_list
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE edit_command_parameter_list, edicpl (
{   command_and_parameters, cap: string = $required
{   max_string, maxs: integer 0..clc$max_string_size = $required
{   edited_parameters, ep: (VAR) list 0..clc$max_list_size of string = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 4, 13, 39, 22, 425],
    clc$command, 7, 4, 3, 0, 0, 1, 4, ''], [
    ['CAP                            ',clc$abbreviation_entry, 1],
    ['COMMAND_AND_PARAMETERS         ',clc$nominal_entry, 1],
    ['EDITED_PARAMETERS              ',clc$nominal_entry, 3],
    ['EP                             ',clc$abbreviation_entry, 3],
    ['MAXS                           ',clc$abbreviation_entry, 2],
    ['MAX_STRING                     ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 24,
  clc$required_parameter, 0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, clc$max_string_size, 10]],
{ PARAMETER 3
    [[1, 0, clc$list_type], [8, 0, clc$max_list_size, FALSE],
      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$command_and_parameters = 1,
      p$max_string = 2,
      p$edited_parameters = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      i: clt$data_representation_count,
      node: ^clt$data_value,
      representation: ^clt$data_representation,
      result: ^clt$data_value,
      string_count: ^clt$data_representation_count,
      string_size: ^clt$string_size;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET work_area;

    clp$edit_command_parameter_list (pvt [p$command_and_parameters].value^.string_value^,
          pvt [p$max_string].value^.integer_value.value, work_area, representation, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT string_count IN representation;
    clp$make_list_value (work_area, result);
    node := result;

    FOR i := 1 TO string_count^ DO
      clp$make_value (clc$string, work_area, node^.element_value);
      NEXT string_size IN representation;
      NEXT node^.element_value^.string_value: [string_size^] IN representation;
      IF i < string_count^ THEN
        clp$make_list_value (work_area, node^.link);
        node := node^.link;
      IFEND;
    FOREND;

    clp$change_variable (pvt [p$edited_parameters].variable^, result, status);

  PROCEND edit_command_parameter_list;
?? TITLE := 'evaluate_token', EJECT ??

  PROCEDURE evaluate_token
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE evaluate_token, evat (
{   text, t: string = $required
{   evaluation_options, evaluation_option, eo: list 0..clc$max_list_size of key
{       (clc$ignore_spaces_before_token, isbt)
{       (clc$comment_is_token, cit)
{       (clc$classify_name_token, cnt)
{       (clc$cobol_name_is_token, cnit)
{       (clc$special_cybil_name_is_token, scnit)
{       (clc$international_char_is_token, icit)
{       (clc$special_char_is_token, scit)
{     keyend = ()
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        default_value: string (2),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 3, 18, 23, 9, 307],
    clc$command, 6, 3, 1, 0, 0, 0, 3, ''], [
    ['EO                             ',clc$abbreviation_entry, 2],
    ['EVALUATION_OPTION              ',clc$alias_entry, 2],
    ['EVALUATION_OPTIONS             ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 1],
    ['TEXT                           ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 541,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [525, 0, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [14], [
      ['CIT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['CLC$CLASSIFY_NAME_TOKEN        ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['CLC$COBOL_NAME_IS_TOKEN        ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['CLC$COMMENT_IS_TOKEN           ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['CLC$IGNORE_SPACES_BEFORE_TOKEN ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['CLC$INTERNATIONAL_CHAR_IS_TOKEN', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['CLC$SPECIAL_CHAR_IS_TOKEN      ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['CLC$SPECIAL_CYBIL_NAME_IS_TOKEN', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['CNIT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['CNT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['ICIT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['ISBT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['SCIT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['SCNIT                          ', clc$abbreviation_entry, clc$normal_usage_entry, 5]]
      ]
    ,
    '()'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$text = 1,
      p$evaluation_options = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

?? NEWTITLE := 'put_line', EJECT ??

    PROCEDURE [INLINE] put_line;

      clp$put_display (display_control, line (1, line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT evaluate_token;
      IFEND;

    PROCEND put_line;
?? OLDTITLE, EJECT ??

    VAR
      token_kind_strings: [STATIC, READ, read_only] array [clt$lexical_token_kind] of ost$name :=
            ['clc$unknown_token', 'clc$end_of_line_token', 'clc$space_token', 'clc$comment_token',
            'clc$semicolon_token', 'clc$colon_token', 'clc$cybil_assign_token', 'clc$left_parenthesis_token',
            'clc$right_parenthesis_token', 'clc$comma_token', 'clc$ellipsis_token', 'clc$dot_token',
            'clc$query_token', 'clc$greater_than_token', 'clc$greater_equal_token', 'clc$less_than_token',
            'clc$less_equal_token', 'clc$equal_token', 'clc$not_equal_token', 'clc$concatenate_token',
            'clc$exponentiate_token', 'clc$multiply_token', 'clc$divide_token', 'clc$add_token',
            'clc$subtract_token', 'clc$left_bracket_token', 'clc$reverse_slant_token',
            'clc$right_bracket_token', 'clc$circumflex_token', 'clc$grave_accent_token',
            'clc$left_brace_token', 'clc$vertical_bar_token', 'clc$right_brace_token', 'clc$tilde_token',
            'clc$number_sign_token', 'clc$dollar_sign_token', 'clc$commercial_at_token',
            'clc$underscore_token', 'clc$name_token', 'clc$cybil_name_token', 'clc$special_cybil_name_token',
            'clc$simple_name_token', 'clc$cobol_name_token', 'clc$string_token', 'clc$unsigned_integer_token',
            'clc$signed_integer_token', 'clc$unsigned_real_token', 'clc$signed_real_token'];

    VAR
      line: string (132),
      line_size: integer,
      page_width: amt$page_width,
      evaluation_options: clt$token_evaluation_options,
      node: ^clt$data_value,
      spaces_preceded_token: boolean,
      str: ost$string,
      str_index: ost$string_index,
      text: ^clt$string_value,
      text_index: clt$string_index,
      token: clt$lexical_token;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    evaluation_options := $clt$token_evaluation_options [];
    node := pvt [p$evaluation_options].value;
    WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
      IF node^.element_value^.keyword_value = 'CLC$IGNORE_SPACES_BEFORE_TOKEN' THEN
        evaluation_options := evaluation_options + $clt$token_evaluation_options
              [clc$ignore_spaces_before_token];
      ELSEIF node^.element_value^.keyword_value = 'CLC$COMMENT_IS_TOKEN' THEN
        evaluation_options := evaluation_options + $clt$token_evaluation_options [clc$comment_is_token];
      ELSEIF node^.element_value^.keyword_value = 'CLC$CLASSIFY_NAME_TOKEN' THEN
        evaluation_options := evaluation_options + $clt$token_evaluation_options [clc$classify_name_token];
      ELSEIF node^.element_value^.keyword_value = 'CLC$COBOL_NAME_IS_TOKEN' THEN
        evaluation_options := evaluation_options + $clt$token_evaluation_options [clc$cobol_name_is_token];
      ELSEIF node^.element_value^.keyword_value = 'CLC$SPECIAL_CYBIL_NAME_IS_TOKEN' THEN
        evaluation_options := evaluation_options + $clt$token_evaluation_options
              [clc$special_cybil_name_is_token];
      ELSEIF node^.element_value^.keyword_value = 'CLC$INTERNATIONAL_CHAR_IS_TOKEN' THEN
        evaluation_options := evaluation_options + $clt$token_evaluation_options
              [clc$international_char_is_token];
      ELSEIF node^.element_value^.keyword_value = 'CLC$SPECIAL_CHAR_IS_TOKEN' THEN
        evaluation_options := evaluation_options + $clt$token_evaluation_options [clc$special_char_is_token];
      IFEND;
      node := node^.link;
    WHILEND;

    text := pvt [p$text].value^.string_value;
    text_index := 1;
    REPEAT
      clp$evaluate_token (text^, evaluation_options, text_index, spaces_preceded_token, token, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (line, line_size, 'INDEX =', text_index);
      put_line;
      STRINGREP (line, line_size, 'SPACES_PRECEDED_TOKEN = ', spaces_preceded_token);
      put_line;
      STRINGREP (line, line_size, 'TOKEN.TEXT_INDEX =', token.text_index);
      put_line;
      STRINGREP (line, line_size, 'TOKEN.TEXT_SIZE =', token.text_size);
      put_line;
      STRINGREP (line, line_size, 'TOKEN.DESCRIPTOR = ', token.descriptor);
      put_line;
      STRINGREP (line, line_size, 'TOKEN.KIND = ', token_kind_strings [token.kind]);
      put_line;
      CASE token.kind OF

      = clc$unknown_token .. clc$string_token =
        STRINGREP (line, line_size, 'TOKEN.STR.SIZE =', token.str.size);
        put_line;
        STRINGREP (line, line_size, 'TOKEN.STR.VALUE = ..');
        put_line;
        IF display_control.page_width <= STRLENGTH (line) THEN
          page_width := display_control.page_width;
        ELSE
          page_width := STRLENGTH (line);
        IFEND;
        str_index := 1;
        REPEAT
          line_size := token.str.size - str_index + 1;
          IF line_size > page_width THEN
            line_size := page_width;
          IFEND;
          line := token.str.value (str_index, line_size);
          put_line;
          str_index := str_index + line_size;
        UNTIL str_index > token.str.size;
        STRINGREP (line, line_size, 'TOKEN.STR_COMPLETE = ', token.str_complete);
        put_line;

      = clc$unsigned_integer_token, clc$signed_integer_token =
        clp$convert_integer_to_string (token.int.value, token.int.radix, token.int.radix_specified, str,
              status);
        IF status.normal THEN
          clp$put_display (display_control, str.value (1, str.size), clc$no_trim, status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = clc$unsigned_real_token, clc$signed_real_token =
        clp$convert_real_to_string (token.rnum.value, token.rnum.number_of_digits, str, status);
        IF status.normal THEN
          clp$put_display (display_control, str.value (1, str.size), clc$no_trim, status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      CASEND;
    UNTIL text_index > STRLENGTH (text^);

  PROCEND evaluate_token;
?? TITLE := 'get_job_parameters', EJECT ??

  PROCEDURE get_job_parameters
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE get_job_parameters, getjp (
{   file, f: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 4, 13, 49, 27, 99],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    VAR
      file: clt$file,
      job_system_label: jmt$job_system_label,
      login_command_in_file: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_string_to_file (pvt [p$file].value^.file_value^, file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{--- The following call is commented out becuase clp$get_job_parameters is not #GATEd and therefore
{--- cannot be called from outside of task services.
{--- To make this testing command useful, the test utility can be run on a job template that has been
{--- modified to #GATE clp$get_job_parameters.
{
{   clp$get_job_parameters (#RING (^job_system_label), file.local_file_name, job_system_label,
{         login_command_in_file, status);
{
{--- Set a breakpoint here to in order to display the results.

    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND get_job_parameters;
?? TITLE := 'test_string_patterns', EJECT ??

  PROCEDURE test_string_patterns
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE test_string_patterns, test_string_pattern, tessp (
{   pattern, p: (wild_card_pattern) string = $required
{   subjects, subject, s: any of
{       list of string
{       list of name
{     anyend = $required
{   anchor_option, ao: (BY_NAME) boolean = yes
{   pattern_build_options, pattern_build_option, pbo: (BY_NAME) list 0..clc$max_list_size of key
{       (file_reference_pattern, frp)
{       (ignore_matched_substring, ims)
{       (match_at_left, mal)
{       (match_at_right, mar)
{     keyend = (ignore_matched_substring, match_at_right)
{   scan_option, so: (BY_NAME) key
{       (quick, q)
{       (full, f)
{     keyend = quick
{   wild_card_pattern_type, wcpt: (BY_NAME) key
{       (basic, b)
{       (extended, e)
{     keyend = extended
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 15] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        name: string (17),
        qualifier: clt$string_type_qualifier,
      recend,
      type2: 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 8] of clt$keyword_specification,
        recend,
        default_value: string (42),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (8),
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 2, 16, 14, 27, 697],
    clc$command, 15, 7, 2, 0, 0, 0, 7, ''], [
    ['ANCHOR_OPTION                  ',clc$nominal_entry, 3],
    ['AO                             ',clc$abbreviation_entry, 3],
    ['P                              ',clc$abbreviation_entry, 1],
    ['PATTERN                        ',clc$nominal_entry, 1],
    ['PATTERN_BUILD_OPTION           ',clc$alias_entry, 4],
    ['PATTERN_BUILD_OPTIONS          ',clc$nominal_entry, 4],
    ['PBO                            ',clc$abbreviation_entry, 4],
    ['S                              ',clc$abbreviation_entry, 2],
    ['SCAN_OPTION                    ',clc$nominal_entry, 5],
    ['SO                             ',clc$abbreviation_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 7],
    ['SUBJECT                        ',clc$alias_entry, 2],
    ['SUBJECTS                       ',clc$nominal_entry, 2],
    ['WCPT                           ',clc$abbreviation_entry, 6],
    ['WILD_CARD_PATTERN_TYPE         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 25, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 65, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 319,
  clc$optional_default_parameter, 0, 42],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 6
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 7
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 17, clc$string_type], 'WILD_CARD_PATTERN', [0, clc$max_string_size, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$list_type],
    FALSE, 2],
    24, [[1, 0, clc$list_type], [8, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'yes'],
{ PARAMETER 4
    [[1, 0, clc$list_type], [303, 0, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [8], [
      ['FILE_REFERENCE_PATTERN         ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['FRP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['IGNORE_MATCHED_SUBSTRING       ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['IMS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['MAL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['MAR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['MATCH_AT_LEFT                  ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['MATCH_AT_RIGHT                 ', clc$nominal_entry, clc$normal_usage_entry, 4]]
      ]
    ,
    '(ignore_matched_substring, match_at_right)'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [4], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FULL                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['Q                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['QUICK                          ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'quick'],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BASIC                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXTENDED                       ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'extended'],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$pattern = 1,
      p$subjects = 2,
      p$anchor_option = 3,
      p$pattern_build_options = 4,
      p$scan_option = 5,
      p$wild_card_pattern_type = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

    VAR
      match_info: clt$string_pattern_match_info,
      node: ^clt$data_value,
      pattern: ^clt$string_pattern,
      anchor_option: clt$string_pattern_anchor_opt,
      pattern_build_options: clt$string_pattern_build_opts,
      scan_option: clt$string_pattern_scan_option,
      subject: ^clt$string_value,
      summary: string (256),
      summary_size: integer,
      wild_card_pattern_type: clt$wild_card_pattern_type;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$anchor_option].value^.boolean_value.value THEN
      anchor_option := clc$sp_anchored;
    ELSE
      anchor_option := clc$sp_unanchored;
    IFEND;

    pattern_build_options := $clt$string_pattern_build_opts [];
    node := pvt [p$pattern_build_options].value;
    WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
      IF node^.element_value^.keyword_value = 'FILE_REFERENCE_PATTERN' THEN
        pattern_build_options := pattern_build_options + $clt$string_pattern_build_opts
              [clc$sp_file_reference_pattern];
      ELSEIF node^.element_value^.keyword_value = 'IGNORE_MATCHED_SUBSTRING' THEN
        pattern_build_options := pattern_build_options + $clt$string_pattern_build_opts
              [clc$sp_ignore_matched_substring];
      ELSEIF node^.element_value^.keyword_value = 'MATCH_AT_LEFT' THEN
        pattern_build_options := pattern_build_options + $clt$string_pattern_build_opts
              [clc$sp_match_at_left];
      ELSE {MATCH_AT_RIGHT}
        pattern_build_options := pattern_build_options + $clt$string_pattern_build_opts
              [clc$sp_match_at_right];
      IFEND;
      node := node^.link;
    WHILEND;

    IF pvt [p$scan_option].value^.keyword_value = 'FULL' THEN
      scan_option := clc$sp_full_scan;
    ELSE {QUICK}
      scan_option := clc$sp_quick_scan;
    IFEND;

    IF pvt [p$wild_card_pattern_type].value^.keyword_value = 'BASIC' THEN
      wild_card_pattern_type := clc$wc_basic_pattern;
    ELSE {EXTENDED}
      wild_card_pattern_type := clc$wc_extended_pattern;
    IFEND;

    RESET work_area;

    clp$build_pattern_for_wild_card (wild_card_pattern_type, pattern_build_options,
          pvt [p$pattern].value^.string_value^, work_area, pattern, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    node := pvt [p$subjects].value;
    WHILE node <> NIL DO
      IF node^.element_value^.kind = clc$string THEN
        subject := node^.element_value^.string_value;
      ELSE
        subject := ^node^.element_value^.name_value (1, clp$trimmed_string_size
              (node^.element_value^.name_value));
      IFEND;

      clp$match_string_pattern (subject^, pattern, anchor_option, scan_option, match_info, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF match_info.result = clc$sp_success THEN
        STRINGREP (summary, summary_size, ' Match SUCCEEDED for ''', subject^, ''' -- index:',
              match_info.index, ', size:', match_info.size);
      ELSE
        STRINGREP (summary, summary_size, ' Match FAILED    for ''', subject^, '''');
      IFEND;
      clp$put_display (display_control, summary (1, summary_size), clc$no_trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      node := node^.link;
    WHILEND;

  PROCEND test_string_patterns;
?? TITLE := 'display_string_pattern', EJECT ??

  PROCEDURE display_string_pattern
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_string_pattern, dissp (
{   string_pattern, sp: string_pattern = $required
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 1, 20, 17, 40, 22, 258],
    clc$command, 5, 3, 1, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['SP                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['STRING_PATTERN                 ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_pattern_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$string_pattern = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    ignore_condition: pmt$condition;
           ignore_condition_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      IF output_open THEN
        clp$close_display (display_control, handler_status);
        output_open := FALSE;
      IFEND;
      handler_status.normal := TRUE;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      output_open: boolean,
      string_ptr: ^clt$string_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET work_area;

    output_open := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
    clp$open_display_reference (pvt [p$output].value^.file_value^, NIL, fsc$list, default_ring_attributes,
          display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    output_open := TRUE;

    clp$sp_convert_to_string (pvt [p$string_pattern].value^.string_pattern_value, work_area, string_ptr,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, string_ptr^, clc$no_trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$close_display (display_control, status);
    output_open := FALSE;

    osp$disestablish_cond_handler;

  PROCEND display_string_pattern;

MODEND clm$test_utility;
*DECK DECK=CLM$TRANSLATE_FUNCTION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE PROC Translator' ??
MODULE clm$translate_function;

{ PURPOSE:
{    The purpose of this module is to translate the input line
{    consisting of a SCL function name and associated argument list
{    into a line consistent with the new SCL types.

?? TITLE := '  Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_function_processing
*copyc cle$ecc_scl_formatter
*copyc clt$command_line
*copyc clt$command_line_size
*copyc clt$command_line_index
*copyc clt$format_token_type
*copyc oss$job_paged_literal
*copyc ost$name
*copyc ost$string
?? POP ??
*copyc clp$append_status_parse_state
*copyc clp$initialize_parse_state
*copyc clp$scan_lexical_unit
*copyc clp$trimmed_string_size
*copyc osp$append_status_integer
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc osv$upper_to_lower

?? TITLE := 'clp$scan_unnested_sep_lex_unit', EJECT ??

{ This version of the routine has been modified for the formatter.
{ CLP$SCAN_UNNESTED_SEP_LEXICAL_UNIT updates its PARSE parameter to designate
{ the next lexical unit that is a separator (space, comment, comma, semicolon
{ or, optionally, ellipsis) not nested within parentheses.
{ This procedure requires that the UNITS field of the PARSE parameter be
{ non-NIL.

  PROCEDURE [INLINE] clp$scan_unnested_sep_lex_unit
    (    ellipsis_treatment: (clc$ignore_ellipsis, clc$ellipsis_is_separator);
     VAR parse {input, output} : clt$parse_state);

    VAR
      nesting_level: clt$string_size;


    nesting_level := $INTEGER (parse.unit.kind = clc$lex_left_parenthesis);
    REPEAT
      clp$scan_lexical_unit (clc$slu_any, parse);
      CASE parse.unit.kind OF
      = clc$lex_end_of_line =
        RETURN;
      = clc$lex_space, clc$lex_comment, clc$lex_unterminated_comment, clc$lex_semicolon, clc$lex_comma =
        IF nesting_level <= 0 THEN
          RETURN;
        IFEND;
      = clc$lex_ellipsis =
        IF (ellipsis_treatment = clc$ellipsis_is_separator) AND (nesting_level <= 0) THEN
          RETURN;
        IFEND;
      = clc$lex_left_parenthesis =
        nesting_level := nesting_level + 1;
      = clc$lex_right_parenthesis =
        IF nesting_level <= 0 THEN
          RETURN;
        IFEND;
        nesting_level := nesting_level - 1;
      ELSE
        ;
      CASEND;
    UNTIL parse.unit_index >= parse.index_limit;

  PROCEND clp$scan_unnested_sep_lex_unit;
?? TITLE := '  [XDCL] clp$translate_function', EJECT ??

  PROCEDURE [XDCL] clp$translate_function
    (    input_line_ptr: ^clt$command_line;
         output_line_ptr: ^clt$command_line;
         function_begin_index: clt$token_array_index;
     VAR function_end_index: clt$token_array_index;
         array_ptr: ^clt$format_token_array;
         max_array_index: clt$token_array_index;
     VAR output_line_size: clt$command_line_size;
     VAR name_only_translated: boolean;
     VAR name_to_flag: ost$name;
     VAR status: ost$status);

    CONST
      translate_function_count = 8;

    VAR
      argument_count: 0 .. 10,
      argument_ptrs: array [1 .. 10] of ^string ( * ),
      current_token: clt$format_token,
      function_name: ost$name,
      function_name_size: ost$name_size,
      index: clt$token_array_index,
      j: integer,
      j2: integer,
      name_index: 1 .. translate_function_count,
      argument_name: ost$name,
      not_it: boolean,
      parse: clt$parse_state,
      parse_text_remaining: clt$command_line_size,
      temp_index: clt$token_array_index,
      temp_name: ost$name,
      translate: boolean;

    VAR
      functions_to_translate: [STATIC, READ, oss$job_paged_literal] array [1 .. translate_function_count] of
            record
        name: ost$name,
        translatable: boolean,
        translated_name: ost$name,
        min_argument_count: 0 .. 10,
        max_argument_count: 0 .. 10,
        translate_name_only: boolean,
      recend := [
            {} ['$CATALOG                       ', TRUE, '$working_catalog               ', 0, 0, FALSE],
            {} ['$CLOCK                         ', TRUE, '$processor                     ', 0, 0, FALSE],
            {} ['$CONDITION_CODE                ', TRUE, '$string                        ', 1, 2, FALSE],
            {} ['$SET_COUNT                     ', TRUE, '$size                          ', 1, 1, FALSE],
            {} ['$SEVERITY                      ', TRUE, '$string                        ', 1, 1, FALSE],
            {} ['$STRLEN                        ', TRUE, '$size                          ', 1, 1, TRUE],
            {} ['$SUBSTR                        ', TRUE, '$substring                     ', 3, 5, TRUE],
            {} ['$VARIABLE                      ', TRUE, 'TO BE SET                      ', 2, 2, FALSE]];

    status.normal := TRUE;
    output_line_size := 0;
    name_to_flag := '';
    clp$initialize_parse_state (input_line_ptr, NIL, parse);
    clp$scan_lexical_unit (clc$slu_non_space, parse);
    IF parse.unit.kind <> clc$lex_name THEN
      osp$set_status_abnormal ('CL', 99999, 'not name', status);
      RETURN;
    IFEND;
    #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), function_name);

    translate := FALSE;

  /search/
    FOR name_index := 1 TO translate_function_count DO
      IF functions_to_translate [name_index].name = function_name THEN
        translate := TRUE;
        EXIT /search/;
      IFEND;
    FOREND /search/;
    IF NOT translate THEN
      RETURN;
    IFEND;

    IF NOT functions_to_translate [name_index].translatable THEN
      osp$set_status_abnormal ('CL', cle$cannot_be_translated, function_name, status);
      RETURN;
    IFEND;

    function_name_size := clp$trimmed_string_size (functions_to_translate [name_index].translated_name);
    IF function_name_size > 0 THEN
      output_line_ptr^ (1, function_name_size) := functions_to_translate [name_index].translated_name;
      output_line_size := function_name_size;
    IFEND;

    name_only_translated := functions_to_translate [name_index].translate_name_only;
    IF name_only_translated THEN
      RETURN;
    IFEND;

    get_arguments (parse, argument_count, argument_ptrs, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF argument_count < functions_to_translate [name_index].min_argument_count THEN
      osp$set_status_abnormal ('CL', cle$required_argument_omitted, function_name, status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            functions_to_translate [name_index].min_argument_count, 10, FALSE, status);
      RETURN;
    ELSEIF argument_count > functions_to_translate [name_index].max_argument_count THEN
      osp$set_status_abnormal ('CL', cle$too_many_arguments, function_name, status);
      RETURN;
    IFEND;

    IF function_name = '$CLOCK' THEN
      STRINGREP (output_line_ptr^, j, '$processor(clock)');
      output_line_size := j;

{   ELSEIF (function_name = '$CONDITION') OR (function_name = '$CONDITION_NAME') THEN
{     STRINGREP (output_line_ptr^, j, '$string($status_code_name(', argument_ptrs [1]^);
{     IF argument_count > 1 THEN
{       STRINGREP (output_line_ptr^ (j + 1, * ), j2, ',', argument_ptrs [2]^);
{       j := j + j2
{     IFEND;
{     STRINGREP (output_line_ptr^ (j + 1, *), j2, '))');
{     output_line_size := j + j2;
{     name_to_flag := function_name;
{

    ELSEIF function_name = '$CONDITION_CODE' THEN
      IF argument_count > 1 THEN
        #TRANSLATE (osv$lower_to_upper, argument_ptrs [2]^, temp_name);
        IF temp_name = 'SYMBOLIC' THEN
          STRINGREP (output_line_ptr^, j, '$status_code_string(', argument_ptrs [1]^, ')');
        ELSE { NUMERIC
          STRINGREP (output_line_ptr^, j, '$status_code(', argument_ptrs [1]^, ')');
        IFEND;
      ELSE {default is NUMERIC
        STRINGREP (output_line_ptr^, j, '$status_code(', argument_ptrs [1]^, ')');
      IFEND;
      output_line_size := j;
      name_to_flag := function_name;

{   ELSEIF (function_name = '$FILE') THEN
{     #translate (osv$lower_to_upper, argument_ptrs [2]^, temp_name);
{     IF (temp_name = 'DEVICE_CLASS') OR (temp_name = 'DC') OR (temp_name = 'FILE_CONTENTS') OR (temp_name =
{       'FC') OR (temp_name = 'FILE_ORGANIZATION') OR (temp_name = 'FO') OR (temp_name = 'FILE_PROCESSOR') OR
{         (temp_name = 'FP') OR (temp_name = 'FILE_STRUCTURE') OR (temp_name = 'FS') OR (temp_name =
{       'OPEN_POSITION') OR (temp_name = 'OP') THEN
{       STRINGREP (output_line_ptr^, j, '$string($file(', argument_ptrs [1]^, ', ', argument_ptrs [2]^, '))');
{       output_line_size := j;
{       name_to_flag := function_name;
{     ELSE
{       output_line_size := 0;
{     IFEND;
{
{   ELSEIF function_name = '$JOB' THEN
{     #translate (osv$upper_to_lower, argument_ptrs [1]^, argument_name);
{     IF (#SIZE (argument_ptrs [1]^) = 7) AND (argument_name (1, 6) = 'switch') THEN
{       {???|| string 'ON' 'OFF'
{       STRINGREP (output_line_ptr^, j, '$switch(', argument_name (7), ')');
{       output_line_size := j;
{     ELSEIF argument_name <> 'operator' THEN
{       IF argument_name = 'job_name' THEN
{         temp_name := 'name';
{       ELSEIF argument_name = 'system_job_name' THEN
{         temp_name := 'system_name';
{       ELSE
{         temp_name := argument_name;
{       IFEND;
{       STRINGREP (output_line_ptr^, j, '$string($job(', temp_name, '))');
{       output_line_size := j;
{       name_to_flag := function_name;
{     ELSE
{       output_line_size := 0;
{     IFEND;
{
{  $PARAMETER was removed from the translation table because of psr NV05926 which
{  complained that the translation didn't work if the parameter was a list or was
{  optional.
{
{   ELSEIF (function_name = '$PARAMETER') THEN
{     STRINGREP (output_line_ptr^, j, '$string($parameter_value(', argument_ptrs [1]^, '))');
{     output_line_size := j;
{
{   ELSEIF (function_name = '$PATH') THEN
{     #translate (osv$upper_to_lower, argument_ptrs [2]^, argument_name);
{     IF argument_name = 'catalog' THEN
{       STRINGREP (output_line_ptr^, j, '$string($up(', argument_ptrs [1]^, '))');
{       output_line_size := j;
{     ELSEIF argument_name = 'last' THEN
{       STRINGREP (output_line_ptr^, j, '$string($file(', argument_ptrs [1]^, ', last_path_name))');
{       output_line_size := j;
{     ELSEIF argument_name = 'count' THEN
{       osp$set_status_abnormal ('CL', cle$cannot_be_translated, '$PATH(path, COUNT)', status);
{     ELSE
{       output_line_size := 0;
{     IFEND;
{
{   ELSEIF function_name = '$PROGRAM' THEN
{     j := 0;
{     #translate (osv$upper_to_lower, argument_ptrs [1]^, argument_name);
{     IF argument_count = 1 THEN
{       IF (argument_name = 'preset_value') OR (argument_name = 'pv') OR (argument_name =
{         'termination_error_level') OR (argument_name = 'tel') THEN
{         STRINGREP (output_line_ptr^, j, '$string($program(', argument_name, '))');
{       IFEND;
{     ELSEIF argument_count > 1 THEN
{       IF (argument_name = 'load_map_option') OR (argument_name = 'lmo') THEN
{         output_line_ptr^ := '$subset($list(';
{         j := 14;
{         FOR j2 := 2 TO argument_count DO
{           #translate (osv$upper_to_lower, argument_ptrs [j2]^, temp_name);
{           output_line_ptr^ (j + 1, #SIZE (argument_ptrs [j2]^)) := temp_name;
{           j := j + #SIZE (argument_ptrs [j2]^);
{           IF j2 < argument_count THEN
{             output_line_ptr^ (j + 1, 2) := ', ';
{             j := j + 2;
{           IFEND;
{         FOREND;
{         output_line_ptr^ (j + 1, 29) := '), $program(load_map_option))';
{         j := j + 29;
{       IFEND;
{     IFEND;
{     name_to_flag := function_name;
{     output_line_size := j;

    ELSEIF function_name = '$SET_COUNT' THEN
      STRINGREP (output_line_ptr^, j, '$size($parameter_value(', argument_ptrs [1]^, '))');
      output_line_size := j;

    ELSEIF function_name = '$SEVERITY' THEN
      STRINGREP (output_line_ptr^, j, '$string($status_severity(', argument_ptrs [1]^, '))');
      output_line_size := j;
      name_to_flag := function_name;

{For compatibility reasons the following functions will not be translated at this time.

{   ELSEIF function_name = '$VALUE' THEN
{     j := 0;
{     output_line_ptr^ := '$value(';
{     j := 7;
{     IF argument_count = 4 THEN
{       #translate (osv$upper_to_lower, argument_ptrs [4]^, argument_name);
{       IF argument_name = 'low' THEN
{         output_line_ptr^ (8, 5) := '$low(';
{         j := 12;
{       ELSEIF argument_name = 'high' THEN
{         output_line_ptr^ (8, 6) := '$high(';
{         j := 13;
{       ELSE
{         osp$set_status_abnormal ('CL', cle$cannot_be_translated,
{           '$VALUE range_specification other than LOW or HIGH', status);
{         RETURN;
{       IFEND;
{     IFEND;
{     output_line_ptr^ (j + 1, #SIZE (argument_ptrs [1]^)) := argument_ptrs [1]^;
{     j := j + #SIZE (argument_ptrs [1]^);
{     IF argument_count > 1 THEN
{       STRINGREP (output_line_ptr^ (j + 1, * ), j2, '(', argument_ptrs [2]^, ')');
{       j := j + j2
{     IFEND;
{     IF argument_count > 2 THEN
{       STRINGREP (output_line_ptr^ (j + 1, * ), j2, '(', argument_ptrs [3]^, ')');
{       j := j + j2
{     IFEND;
{     IF argument_count = 4 THEN
{       output_line_ptr^ (j + 1, 1) := ')';
{       j := j + 1;
{     IFEND;
{     output_line_ptr^ (j + 1, 1) := ')';
{     output_line_size := j + 1;
{
{   ELSEIF function_name = '$VALUE_COUNT' THEN
{     j := 0;
{     IF (argument_count = 1) OR (argument_count = 2) THEN
{       STRINGREP (output_line_ptr^, j, '$size(', argument_ptrs [1]^);
{       IF argument_count = 2 THEN
{         STRINGREP (output_line_ptr^ (j + 1, * ), j2, '(', argument_ptrs [2]^, ')');
{         j := j + j2;
{       IFEND;
{       output_line_ptr^ (j + 1, 1) := ')';
{       j := j + 1;
{     IFEND;
{     output_line_size := j;
{
{   ELSEIF function_name = '$VALUE_KIND' THEN
{     j := 0;
{     output_line_ptr^ := '';
{     STRINGREP (output_line_ptr^, j, '$string($generic_type(');
{     IF argument_count = 4 THEN
{       IF argument_ptrs [4]^ = 'low' THEN
{         output_line_ptr^ (j + 1, 5) := '$low(';
{         j := j + 5;
{       ELSEIF argument_ptrs [4]^ = 'high' THEN
{         output_line_ptr^ (j + 1, 6) := '$high(';
{         j := j + 6;
{       ELSE
{         osp$set_status_abnormal ('CL', cle$cannot_be_translated,
{           '$VALUE_KIND range_specification other than LOW or HIGH', status);
{         RETURN;
{       IFEND;
{     IFEND;
{     output_line_ptr^ (j + 1, #SIZE (argument_ptrs [1]^)) := argument_ptrs [1]^;
{     j := j + #SIZE (argument_ptrs [1]^);
{     IF argument_count > 1 THEN
{       STRINGREP (output_line_ptr^ (j + 1, * ), j2, '(', argument_ptrs [2]^, ')');
{       j := j + j2
{     IFEND;
{     IF argument_count > 2 THEN
{       STRINGREP (output_line_ptr^ (j + 1, * ), j2, '(', argument_ptrs [3]^, ')');
{       j := j + j2
{     IFEND;
{     output_line_ptr^ (j + 1, 2) := '))';
{     j := j + 2;
{     IF argument_count = 4 THEN
{       output_line_ptr^ (j + 1, 1) := ')';
{       j := j + 1;
{     IFEND;
{     output_line_size := j;

    ELSEIF (function_name = '$VARIABLE') THEN
      #TRANSLATE (osv$upper_to_lower, argument_ptrs [2]^, argument_name);
      IF (argument_name = 'lower_bound') OR (argument_name = 'upper_bound') THEN
        STRINGREP (output_line_ptr^, j, '$', argument_name (1, clp$trimmed_string_size (argument_name)),
              '(', argument_ptrs [1]^, ')');
        output_line_size := j;
      ELSEIF argument_name = 'string_size' THEN
        STRINGREP (output_line_ptr^, j, '$size(', argument_ptrs [1]^, ')');
        output_line_size := j;
      ELSEIF (argument_name = 'declared') THEN
        name_to_flag := function_name;
        temp_index := function_end_index + 3;
        IF (array_ptr^ [temp_index].clt_kind = clc$lex_space) OR
              (array_ptr^ [temp_index].clt_kind = clc$lex_comment) THEN
          temp_index := temp_index + 1;
        IFEND;
        IF array_ptr^ [temp_index].clt_kind = clc$lex_equal THEN
          not_it := FALSE;
        ELSEIF array_ptr^ [temp_index].clt_kind = clc$lex_not_equal THEN
          not_it := TRUE;
        ELSE
          output_line_ptr^ := input_line_ptr^;
          output_line_size := clp$trimmed_string_size (input_line_ptr^);
          RETURN;
        IFEND;
        temp_index := temp_index + 1;
        IF (array_ptr^ [temp_index].clt_kind = clc$lex_space) OR
              (array_ptr^ [temp_index].clt_kind = clc$lex_comment) THEN
          temp_index := temp_index + 1;
        IFEND;
        IF array_ptr^ [temp_index].clt_kind <> clc$lex_string THEN
          output_line_ptr^ := input_line_ptr^;
          output_line_size := clp$trimmed_string_size (input_line_ptr^);
          RETURN;
        IFEND;
        IF array_ptr^ [temp_index].string_ptr^ = '''UNKNOWN''' THEN
          not_it := NOT not_it;
          temp_name := 'defined';
        ELSEIF array_ptr^ [temp_index].string_ptr^ = '''LOCAL''' THEN
          temp_name := 'local';
        ELSEIF array_ptr^ [temp_index].string_ptr^ = '''NONLOCAL''' THEN
          temp_name := 'nonlocal';
        ELSE
          output_line_ptr^ := input_line_ptr^;
          output_line_size := clp$trimmed_string_size (input_line_ptr^);
          RETURN;
        IFEND;
        function_end_index := temp_index;

        j2 := 0;
        IF not_it THEN
          function_name := '$variable';
          output_line_ptr^ := '$not(';
          j2 := 5;
        IFEND;
        STRINGREP (output_line_ptr^ (j2 + 1, * ), j, function_name
              (1, clp$trimmed_string_size (function_name)), '(', argument_ptrs [1]^,
              ', ', temp_name (1, clp$trimmed_string_size (temp_name)), ')');
        IF not_it THEN
          output_line_ptr^ (j2 + j + 1) := ')';
          j := j + j2 + 1;
        IFEND;
        output_line_size := j;
      ELSEIF argument_name = 'kind' THEN
        STRINGREP (output_line_ptr^, j, '$string($generic_type(', argument_ptrs [1]^, '))');
        output_line_size := j;
      ELSE
        output_line_ptr^ := input_line_ptr^;
        output_line_size := clp$trimmed_string_size (input_line_ptr^);
        RETURN;
      IFEND;
    IFEND;

  PROCEND clp$translate_function;

?? TITLE := '  get_arguments', EJECT ??

  PROCEDURE get_arguments
    (VAR {input, output} parse: clt$parse_state;
     VAR argument_count: 0 .. 10;
     VAR argument_ptrs: array [1 .. 10] of ^string ( * );
     VAR status: ost$status);

    VAR
      argument_begin_count: clt$command_line_size,
      argument_begin_index: clt$command_line_index;

    status.normal := TRUE;
    argument_count := 0;
    clp$scan_lexical_unit (clc$slu_any, parse);
    IF parse.unit.kind <> clc$lex_left_parenthesis THEN
      RETURN;
    IFEND;

    clp$scan_lexical_unit (clc$slu_non_space, parse);

    WHILE parse.unit.kind <> clc$lex_right_parenthesis DO
      argument_count := argument_count + 1;
      argument_begin_index := parse.unit_index;
      clp$scan_unnested_sep_lex_unit (clc$ignore_ellipsis, parse);
      argument_ptrs [argument_count] := ^parse.text^ (argument_begin_index,
            parse.unit_index - argument_begin_index);
      IF parse.unit_is_space THEN
        clp$scan_lexical_unit (clc$slu_non_space, parse);
      IFEND;
      IF parse.unit.kind = clc$lex_comma THEN
        clp$scan_lexical_unit (clc$slu_non_space, parse);
      IFEND;
      IF parse.unit.kind = clc$lex_end_of_line THEN
        osp$set_status_abnormal ('CL', 99999, 'no right paren', status);
        RETURN;
      IFEND;
    WHILEND;

  PROCEND get_arguments;

MODEND clm$translate_function;
*DECK DECK=CLM$TRANSLATE_PDT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Translate Old PDT to New' ??
MODULE clm$translate_pdt;

{
{ PURPOSE:
{
{   This module contains the procedures that translate a
{   clt$parameter_descriptor_table (the old style PDT for commands) and a
{   clt$argument_descriptor_table (the old style PDT (ADT) for functions) to a
{   clt$unbundled_pdt.  It additionally contains a procedure to translate a
{   clt$value_kind_specifier to a clt$type_description.
{
{   It also contains the procedure that "bundles" a translated PDT into a
{   clt$parameter_description_table (the new style PDT for both commands and
{   functions.
{
{ NOTES:
{
{ 1. Because of the nature of the (older) clt$parameter_descriptor_table, the
{    following facts somewhat simplify the translation process:
{
{    a. The "depth" of a list can not exceed 2. That is "LIST OF LIST" can be
{       expected but no "LIST OF LIST OF LIST".
{    b. Neither LISTs nor RANGEs are possible for functions.
{    c. No more than two different types can exist for a parameter.
{    d. There will be no default name for a parameter.
{
{ 2. Restrictions:
{
{    a. A parameter declared as a LIST and/or RANGE OF VAR/ARRAY OF some_kind
{       cannot be translated.  Also, VAR/ARRAY OF some_kind OR KEY xxx cannot
{       be translated.
{
{ 3. Application value specifications are translated.  However, to properly
{    evaluate such parameters requires keeping the "old" PDT in order to be
{    able to call the application value scanner at the appropriate moment.
{    This is intended to be done by the clt$check_parameters_procedure
{    supplied by clp$scan_parameter_list.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*IF $true(osv$unix)
*copyc clc$declaration_version
*IFEND
*copyc cle$bad_pdt
*copyc cle$ecc_parsing
*copyc cle$work_area_overflow
*copyc clt$argument_descriptor_table
*copyc clt$parameter_description_table
*copyc clt$parameter_descriptor_table
*copyc clt$symbolic_parameters
*copyc clt$symbolic_subrange_qualifier
*copyc clt$type_description
*copyc clt$unbundled_pdt
*copyc clt$value_kind_specifier
*copyc clt$work_area
*IF NOT $true(osv$unix)
*copyc oss$job_paged_literal
*IFEND
*copyc ost$status
?? POP ??
*copyc clp$convert_integer_to_string
*copyc clp$convert_type_desc_to_spec
*copyc clp$trimmed_string_size
*copyc clv$negative_infinity
*copyc clv$positive_infinity
*copyc i#current_sequence_position
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
?? TITLE := 'old_union_type_description', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    old_union_type_description: [STATIC, READ, oss$job_paged_literal] clt$type_description :=
          [NIL, NIL, TRUE, FALSE, $clt$type_kinds [clc$boolean_type, clc$file_type, clc$integer_type,
          clc$name_type, clc$real_type, clc$status_type, clc$string_type], clc$union_type, ^old_union_members,
          ^old_union_information],
    old_union_members: [STATIC, READ, oss$job_paged_literal] array [1 .. 7] of clt$type_description := [
*ELSE
    old_union_type_description: [STATIC, READ] clt$type_description :=
          [NIL, NIL, TRUE, FALSE, $clt$type_kinds_v2 [clc$boolean_type, clc$nos_ve_file_type,
          clc$integer_type, clc$name_type, clc$real_type, clc$status_type, clc$string_type], clc$union_type,
          ^old_union_members, ^old_union_information],
    old_union_members: [STATIC, READ] array [1 .. 7] of clt$type_description := [
*IFEND
          {BOOLEAN} [NIL, NIL, TRUE, FALSE, [clc$boolean_type], clc$boolean_type],
          {NAME} [NIL, NIL, TRUE, FALSE, [clc$name_type], clc$name_type, 1, osc$max_name_size],
*IF NOT $true(osv$unix)
          {FILE} [NIL, NIL, TRUE, FALSE, [clc$file_type], clc$file_type],
*ELSE
          {NOS_VE_FILE} [NIL, NIL, TRUE, FALSE, [clc$nos_ve_file_type], clc$nos_ve_file_type],
*IFEND
          {INTEGER} [NIL, NIL, TRUE, FALSE, [clc$integer_type], clc$integer_type, clc$min_integer,
          clc$max_integer, 10],
          {REAL} [NIL, NIL, TRUE, FALSE, [clc$real_type], clc$real_type,
*IF NOT $true(osv$unix)
          [{-$INFINITY} 3, [[0d000(16), 0], [0d000(16), 0]]], [{$INFINITY} 3, [[5000(16), 0],
          [5000(16), 0]]]],
*ELSE
*copy cli$longreal_negative_infinity
          ,
*copy cli$longreal_positive_infinity
          ],
*IFEND
          {STATUS} [NIL, NIL, TRUE, FALSE, [clc$status_type], clc$status_type],
          {STRING} [NIL, NIL, TRUE, FALSE, [clc$string_type], clc$string_type, 0, clc$max_string_size,
          FALSE]],
*IF NOT $true(osv$unix)
    old_union_information: [STATIC, READ, oss$job_paged_literal] clt$union_type_information :=
          [TRUE, clc$min_integer, clc$max_integer, 10, [{-$INFINITY} 3, [[0d000(16), 0], [0d000(16), 0]]],
          [{$INFINITY} 3, [[5000(16), 0], [5000(16), 0]]]];
*ELSE
    old_union_information: [STATIC, READ] clt$union_type_information :=
          [TRUE, clc$min_integer, clc$max_integer, 10,
*copy cli$longreal_negative_infinity
          ,
*copy cli$longreal_positive_infinity
          ];
*IFEND

?? TITLE := 'clp$type_desc_is_for_old_union', EJECT ??

  FUNCTION [XDCL] clp$type_desc_is_for_old_union
    (    type_description: ^clt$type_description): boolean;

    VAR
      i: 1 .. clc$max_union_members;


    clp$type_desc_is_for_old_union := FALSE;

    IF (type_description^.kinds <> old_union_type_description.kinds) OR
          (type_description^.member_descriptions = NIL) OR (UPPERBOUND (type_description^.
          member_descriptions^) <> UPPERBOUND (old_union_type_description.member_descriptions^)) THEN
      RETURN;
    IFEND;

    FOR i := 1 TO UPPERBOUND (type_description^.member_descriptions^) DO
      IF type_description^.member_descriptions^ [i].kind <> old_union_type_description.
            member_descriptions^ [i].kind THEN
        RETURN;
      IFEND;
    FOREND;

    clp$type_desc_is_for_old_union := TRUE;

  FUNCEND clp$type_desc_is_for_old_union;
?? TITLE := 'clp$translate_adt', EJECT ??

  PROCEDURE [XDCL] clp$translate_adt
    (    old_adt: ^clt$argument_descriptor_table;
         group_keywords: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR application_type_present: boolean;
     VAR new_pdt: clt$unbundled_pdt;
     VAR status: ost$status);

    VAR
      symbolic_qualifiers_work_area: ^clt$work_area;

?? NEWTITLE := 'initialize_header', EJECT ??

    PROCEDURE [INLINE] initialize_header;


      new_pdt.default_names := NIL;
      NEXT new_pdt.header IN work_area;

      new_pdt.header^.version := clc$declaration_version;
      new_pdt.header^.generation_date_time.year := 1987 - 1900;
      new_pdt.header^.generation_date_time.month := 9;
      new_pdt.header^.generation_date_time.day := 17;
      new_pdt.header^.generation_date_time.hour := 0;
      new_pdt.header^.generation_date_time.minute := 0;
      new_pdt.header^.generation_date_time.second := 0;
      new_pdt.header^.generation_date_time.millisecond := 0;
      new_pdt.header^.command_or_function := clc$function;
      new_pdt.header^.number_of_required_parameters := 0;
      new_pdt.header^.number_of_advanced_parameters := 0;
      new_pdt.header^.number_of_hidden_parameters := 0;
      new_pdt.header^.number_of_var_parameters := 0;
      new_pdt.header^.status_parameter_number := 0;
      new_pdt.header^.help_module_name := osc$null_name;

      IF old_adt = NIL THEN
        new_pdt.names := NIL;
        new_pdt.parameters := NIL;
        new_pdt.type_descriptions := NIL;
        new_pdt.default_values := NIL;
        new_pdt.header^.number_of_parameter_names := 0;
        new_pdt.header^.number_of_parameters := 0;
        EXIT clp$translate_adt;
      IFEND;

      new_pdt.header^.number_of_parameter_names := UPPERBOUND (old_adt^);
      new_pdt.header^.number_of_parameters := UPPERBOUND (old_adt^);

      NEXT new_pdt.names: [1 .. new_pdt.header^.number_of_parameter_names] IN work_area;
      NEXT new_pdt.parameters: [1 .. new_pdt.header^.number_of_parameters] IN work_area;
      NEXT new_pdt.type_descriptions: [1 .. new_pdt.header^.number_of_parameters] IN work_area;
      NEXT new_pdt.default_values: [1 .. new_pdt.header^.number_of_parameters] IN work_area;

    PROCEND initialize_header;
?? TITLE := 'create_parameter_names', EJECT ??

    PROCEDURE [INLINE] create_parameter_names;

      CONST
        parameter_name_prefix = 'PARAMETER_',
        parameter_name_prefix_size = 10 {STRLENGTH (parameter_name_prefix)} ;

      VAR
        i: clt$parameter_name_index,
        str: ^ost$string;


      str := NIL;
      FOR i := 1 TO new_pdt.header^.number_of_parameter_names DO
        new_pdt.names^ [i].name := parameter_name_prefix;
        IF i <= 9 THEN
          new_pdt.names^ [i].name (parameter_name_prefix_size + 1) := $CHAR ($INTEGER ('0') + i);
        ELSE
          IF str = NIL THEN
            PUSH str;
          IFEND;
          clp$convert_integer_to_string (i, 10, FALSE, str^, status);
          new_pdt.names^ [i].name (parameter_name_prefix_size + 1, * ) := str^.value (1, str^.size);
        IFEND;
        new_pdt.names^ [i].class := clc$nominal_entry;
        new_pdt.names^ [i].position := i;
        new_pdt.parameters^ [i].name_index := i;
      FOREND;

    PROCEND create_parameter_names;
?? TITLE := 'process_parameters', EJECT ??

    PROCEDURE [INLINE] process_parameters;

      VAR
        i: clt$parameter_number;


      FOR i := 1 TO new_pdt.header^.number_of_parameters DO
        new_pdt.parameters^ [i].availability := clc$normal_usage_entry;

        new_pdt.parameters^ [i].security := clc$non_secure_parameter;

        new_pdt.parameters^ [i].specification_methods := $clt$parameter_spec_methods
              [clc$specify_positionally];

        IF old_adt^ [i].value_kind_specifier.kind <> clc$variable_reference THEN
          new_pdt.parameters^ [i].passing_method := clc$pass_by_value;
        ELSE
          new_pdt.parameters^ [i].passing_method := clc$pass_by_reference;
        IFEND;

        new_pdt.parameters^ [i].evaluation_method := clc$immediate_evaluation;

        new_pdt.parameters^ [i].checking_level := clc$standard_parameter_checking;

        new_pdt.parameters^ [i].type_specification_size := 0;

        CASE old_adt^ [i].required_or_optional.selector OF

        = clc$required =
          new_pdt.header^.number_of_required_parameters := new_pdt.header^.number_of_required_parameters + 1;

          new_pdt.parameters^ [i].requirement := clc$required_parameter;
          new_pdt.parameters^ [i].default_value_size := 0;

          new_pdt.default_values^ [i] := NIL;

        = clc$optional_with_default =
          new_pdt.parameters^ [i].requirement := clc$optional_default_parameter;
          new_pdt.parameters^ [i].default_value_size := STRLENGTH (old_adt^ [i].required_or_optional.
                default^);

          new_pdt.default_values^ [i] := old_adt^ [i].required_or_optional.default;

        ELSE { clc$optional }
          new_pdt.parameters^ [i].requirement := clc$optional_parameter;
          new_pdt.parameters^ [i].default_value_size := 0;

          new_pdt.default_values^ [i] := NIL;
        CASEND;

        new_pdt.parameters^ [i].default_name_size := 0;
      FOREND;

    PROCEND process_parameters;
?? TITLE := 'translate_adt_types', EJECT ??

    PROCEDURE [INLINE] translate_adt_types;

      VAR
        i: clt$parameter_number,
        local_application_type_present: boolean,
        type_description: ^clt$type_description,
*IF NOT $true(osv$unix)
        type_kinds: clt$type_kinds;
*ELSE
        type_kinds: clt$type_kinds_v2;
*IFEND


      FOR i := 1 TO new_pdt.header^.number_of_parameters DO
        determine_type_kinds (old_adt^ [i].value_kind_specifier, type_kinds);

        type_description := ^new_pdt.type_descriptions^ [i];

        translate_type (type_kinds, TRUE, old_adt^ [i].value_kind_specifier, group_keywords, NIL,
              symbolic_qualifiers_work_area, work_area, local_application_type_present, type_description,
              status);
        IF NOT status.normal THEN
          EXIT clp$translate_adt;
        ELSEIF local_application_type_present THEN
          application_type_present := TRUE;
          new_pdt.parameters^ [i].checking_level := clc$extended_parameter_checking;
        IFEND;
      FOREND;

    PROCEND translate_adt_types;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    application_type_present := FALSE;
    symbolic_qualifiers_work_area := NIL;

    initialize_header;

    IF old_adt <> NIL THEN

      create_parameter_names;

      process_parameters;

      translate_adt_types;

      IF UPPERBOUND (old_adt^) > 9 THEN
        sort_parameter_names (new_pdt);
      IFEND;

    IFEND;

  PROCEND clp$translate_adt;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$translate_pdt', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$translate_pdt
    (    old_pdt: clt$parameter_descriptor_table;
         encode_file_values: boolean;
         group_keywords: boolean;
         report_status_procedure: ^procedure
           (    parameter_name: clt$parameter_name;
                error_status: ost$status;
            VAR status: ost$status);
         symbolic_parameters: ^clt$symbolic_parameters;
         symbolic_qualifiers_area: ^clt$work_area;
     VAR work_area {input, output} : ^clt$work_area;
     VAR application_type_present: boolean;
     VAR new_pdt: clt$unbundled_pdt;
     VAR status: ost$status);

    VAR
      symbolic_parameter: ^clt$symbolic_parameter,
      symbolic_qualifiers_work_area: ^clt$work_area;

{ The following variables are used only by translate_pdt_types and the various
{ "set type" routines it calls.  They are declared here so that those routines
{ can all be declared as INLINE.  (The "set type" routines should be nested
{ within translate_pdt_types but that would preclude it from being INLINE).

    VAR
      i: clt$parameter_number,
      list_specified: boolean,
      parameter_name: ^clt$parameter_name,
      range_specified: boolean,
      sub_list_specified: boolean,
      symbolic_qualifier_applicable: boolean,
      type_description: ^clt$type_description,
*IF NOT $true(osv$unix)
      type_kinds: clt$type_kinds,
*ELSE
      type_kinds: clt$type_kinds_v2,
*IFEND
      value_kind_specifier: ^clt$value_kind_specifier;

?? NEWTITLE := 'initialize_header', EJECT ??

    PROCEDURE [INLINE] initialize_header;


      new_pdt.default_names := NIL;
      NEXT new_pdt.header IN work_area;

      new_pdt.header^.version := clc$declaration_version;
      new_pdt.header^.generation_date_time.year := 1987 - 1900;
      new_pdt.header^.generation_date_time.month := 5;
      new_pdt.header^.generation_date_time.day := 20;
      new_pdt.header^.generation_date_time.hour := 0;
      new_pdt.header^.generation_date_time.minute := 0;
      new_pdt.header^.generation_date_time.second := 0;
      new_pdt.header^.generation_date_time.millisecond := 0;
      new_pdt.header^.command_or_function := clc$command;
      new_pdt.header^.number_of_required_parameters := 0;
      new_pdt.header^.number_of_advanced_parameters := 0;
      new_pdt.header^.number_of_hidden_parameters := 0;
      new_pdt.header^.number_of_var_parameters := 0;
      new_pdt.header^.status_parameter_number := 0;
      new_pdt.header^.help_module_name := osc$null_name;

      IF old_pdt.parameters = NIL THEN
        IF old_pdt.names <> NIL THEN
          osp$set_status_abnormal ('CL', cle$bad_pdt, '', status);
          EXIT clp$translate_pdt;
        IFEND;

        new_pdt.names := NIL;
        new_pdt.parameters := NIL;
        new_pdt.type_descriptions := NIL;
        new_pdt.default_values := NIL;
        new_pdt.header^.number_of_parameter_names := 0;
        new_pdt.header^.number_of_parameters := 0;
        EXIT clp$translate_pdt;

      ELSEIF old_pdt.names = NIL THEN
        osp$set_status_abnormal ('CL', cle$bad_pdt, '', status);
        EXIT clp$translate_pdt;
      IFEND;

      new_pdt.header^.number_of_parameter_names := UPPERBOUND (old_pdt.names^);
      new_pdt.header^.number_of_parameters := UPPERBOUND (old_pdt.parameters^);

      NEXT new_pdt.names: [1 .. new_pdt.header^.number_of_parameter_names] IN work_area;
      NEXT new_pdt.parameters: [1 .. new_pdt.header^.number_of_parameters] IN work_area;
      NEXT new_pdt.type_descriptions: [1 .. new_pdt.header^.number_of_parameters] IN work_area;
      NEXT new_pdt.default_values: [1 .. new_pdt.header^.number_of_parameters] IN work_area;

    PROCEND initialize_header;
?? TITLE := 'process_parameter_names', EJECT ??

    PROCEDURE [INLINE] process_parameter_names;

      VAR
        i: clt$parameter_name_index,
        parameter_name_count: 0 .. clc$max_parameter_names,
        parameter_number: 0 .. clc$max_parameters;


      parameter_number := 0;
      parameter_name_count := 0;
      FOR i := 1 TO new_pdt.header^.number_of_parameter_names DO
        #TRANSLATE (osv$lower_to_upper, old_pdt.names^ [i].name, new_pdt.names^ [i].name);
        IF parameter_number <> old_pdt.names^ [i].number THEN
          IF parameter_name_count > 1 THEN
            new_pdt.names^ [i - 1].class := clc$abbreviation_entry;
          IFEND;
          parameter_number := old_pdt.names^ [i].number;
          IF (parameter_number < 1) OR (parameter_number > new_pdt.header^.number_of_parameters) THEN
            osp$set_status_abnormal ('CL', cle$bad_pdt, '', status);
            EXIT clp$translate_pdt;
          IFEND;
          parameter_name_count := 0;
        IFEND;
        IF parameter_name_count = 0 THEN
          new_pdt.names^ [i].class := clc$nominal_entry;
          new_pdt.parameters^ [parameter_number].name_index := i;
        ELSE
          new_pdt.names^ [i].class := clc$alias_entry;
        IFEND;
        parameter_name_count := parameter_name_count + 1;
        new_pdt.names^ [i].position := parameter_number;
      FOREND;
      IF parameter_name_count > 1 THEN
        new_pdt.names^ [i].class := clc$abbreviation_entry;
      IFEND;

    PROCEND process_parameter_names;
?? TITLE := 'process_parameters', EJECT ??

    PROCEDURE [INLINE] process_parameters;

      VAR
        i: clt$parameter_number,
        name_index: integer;


      FOR i := 1 TO new_pdt.header^.number_of_parameters DO
        name_index := new_pdt.parameters^ [i].name_index;
        IF (name_index > new_pdt.header^.number_of_parameter_names) OR
              (new_pdt.names^ [name_index].position <> i) OR (new_pdt.names^ [name_index].class <>
              clc$nominal_entry) THEN
          osp$set_status_abnormal ('CL', cle$bad_pdt, '', status);
          EXIT clp$translate_pdt;
        IFEND;

        new_pdt.parameters^ [i].availability := clc$normal_usage_entry;

        new_pdt.parameters^ [i].security := clc$non_secure_parameter;

        new_pdt.parameters^ [i].specification_methods := $clt$parameter_spec_methods
              [clc$specify_by_name, clc$specify_positionally];

        IF old_pdt.parameters^ [i].value_kind_specifier.kind <> clc$variable_reference THEN
          new_pdt.parameters^ [i].passing_method := clc$pass_by_value;
        ELSE
          new_pdt.parameters^ [i].passing_method := clc$pass_by_reference;
          new_pdt.header^.number_of_var_parameters := new_pdt.header^.number_of_var_parameters + 1;
          IF (old_pdt.parameters^ [i].value_kind_specifier.variable_kind = clc$status_value) AND
                (new_pdt.names^ [name_index].name = 'STATUS') THEN

            new_pdt.parameters^ [i].specification_methods := $clt$parameter_spec_methods
                  [clc$specify_by_name];

            new_pdt.header^.status_parameter_number := i;
          IFEND;
        IFEND;

        new_pdt.parameters^ [i].evaluation_method := clc$immediate_evaluation;

        new_pdt.parameters^ [i].checking_level := clc$standard_parameter_checking;

        new_pdt.parameters^ [i].type_specification_size := 0;

        CASE old_pdt.parameters^ [i].required_or_optional.selector OF

        = clc$required =
          new_pdt.header^.number_of_required_parameters := new_pdt.header^.number_of_required_parameters + 1;

          new_pdt.parameters^ [i].requirement := clc$required_parameter;
          new_pdt.parameters^ [i].default_value_size := 0;

          new_pdt.default_values^ [i] := NIL;

        = clc$optional_with_default =
          new_pdt.parameters^ [i].requirement := clc$optional_default_parameter;
          new_pdt.parameters^ [i].default_value_size := STRLENGTH (old_pdt.parameters^ [i].
                required_or_optional.default^);

          new_pdt.default_values^ [i] := old_pdt.parameters^ [i].required_or_optional.default;

        ELSE { clc$optional }
          new_pdt.parameters^ [i].requirement := clc$optional_parameter;
          new_pdt.parameters^ [i].default_value_size := 0;

          new_pdt.default_values^ [i] := NIL;
        CASEND;

        new_pdt.parameters^ [i].default_name_size := 0;
      FOREND;

    PROCEND process_parameters;
?? TITLE := 'set_list_type', EJECT ??

    PROCEDURE [INLINE] set_list_type
      (    min_list_size: 1 .. clc$max_list_size;
           max_list_size: 1 .. clc$max_list_size);


      set_type (clc$list_type);
      type_description^.min_list_size := min_list_size;
      type_description^.max_list_size := max_list_size;
      type_description^.defer_expansion := FALSE;
      type_description^.list_rest := FALSE;
      NEXT type_description^.list_element_type_description IN work_area;
      type_description := type_description^.list_element_type_description;

    PROCEND set_list_type;
?? TITLE := 'set_range_type', EJECT ??

    PROCEDURE [INLINE] set_range_type;


      set_type (clc$range_type);
      NEXT type_description^.range_element_type_description IN work_area;
      type_description := type_description^.range_element_type_description;

    PROCEND set_range_type;
?? TITLE := 'set_type', EJECT ??

    PROCEDURE [INLINE] set_type
      (    kind: clt$type_kind);


      type_description^.specification := NIL;
      type_description^.name := NIL;
      type_description^.derived_from_value_kind_spec := encode_file_values;
      type_description^.advanced_keywords_present := FALSE;
      type_description^.kinds := type_kinds;
      type_description^.kind := kind;

    PROCEND set_type;
?? TITLE := 'translate_pdt_types', EJECT ??

    PROCEDURE [INLINE] translate_pdt_types;

      VAR
        local_application_type_present: boolean,
        status_to_report: ^ost$status;


      status_to_report := NIL;

    /process_parameter/
      FOR i := 1 TO new_pdt.header^.number_of_parameters DO
        parameter_name := ^new_pdt.names^ [new_pdt.parameters^ [i].name_index].name;

        IF symbolic_parameters = NIL THEN
          symbolic_parameter := NIL;
        ELSE
          symbolic_parameter := ^symbolic_parameters^ [i];
        IFEND;

        sub_list_specified := (old_pdt.parameters^ [i].max_values_per_set > 1) OR
              ((symbolic_parameter <> NIL) AND (symbolic_parameter^.max_values_per_set <> NIL));
        list_specified := sub_list_specified OR (old_pdt.parameters^ [i].max_value_sets > 1) OR
              ((symbolic_parameter <> NIL) AND (symbolic_parameter^.max_value_sets <> NIL));
        range_specified := old_pdt.parameters^ [i].value_range_allowed = clc$value_range_allowed;

        value_kind_specifier := ^old_pdt.parameters^ [i].value_kind_specifier;

        IF (list_specified OR range_specified OR (value_kind_specifier^.keyword_values <> NIL)) AND
              (value_kind_specifier^.kind = clc$variable_reference) THEN

          osp$set_status_abnormal ('CL', cle$unsupported_parameter_spec, parameter_name^, status);

          IF report_status_procedure <> NIL THEN
            IF status_to_report = NIL THEN
              PUSH status_to_report;
            IFEND;
            status_to_report^ := status;
            status.normal := TRUE;
            report_status_procedure^ (parameter_name^, status_to_report^, status);
            IF status.normal THEN
              new_pdt.names^ [new_pdt.parameters^ [i].name_index].name (osc$max_name_size) := '*';
              CYCLE /process_parameter/;
            IFEND;
          IFEND;

          EXIT clp$translate_pdt;
        IFEND;

        determine_type_kinds (value_kind_specifier^, type_kinds);

        IF range_specified THEN
*IF NOT $true(osv$unix)
          type_kinds := type_kinds + $clt$type_kinds [clc$range_type];
*ELSE
          type_kinds := type_kinds + $clt$type_kinds_v2 [clc$range_type];
*IFEND
        IFEND;

        type_description := ^new_pdt.type_descriptions^ [i];

        IF list_specified THEN
*IF NOT $true(osv$unix)
          type_kinds := type_kinds + $clt$type_kinds [clc$list_type];
*ELSE
          type_kinds := type_kinds + $clt$type_kinds_v2 [clc$list_type];
*IFEND
          set_list_type (old_pdt.parameters^ [i].min_value_sets, old_pdt.parameters^ [i].max_value_sets);
          IF symbolic_parameter <> NIL THEN
            set_symbolic_qualifier (symbolic_parameter^.min_value_sets, symbolic_parameter^.max_value_sets,
                  symbolic_qualifiers_work_area, status);
            IF NOT status.normal THEN
              EXIT clp$translate_pdt;
            IFEND;
          IFEND;

          IF sub_list_specified THEN
            set_list_type (old_pdt.parameters^ [i].min_values_per_set,
                  old_pdt.parameters^ [i].max_values_per_set);
            IF symbolic_parameter <> NIL THEN
              set_symbolic_qualifier (symbolic_parameter^.min_values_per_set,
                    symbolic_parameter^.max_values_per_set, symbolic_qualifiers_work_area, status);
              IF NOT status.normal THEN
                EXIT clp$translate_pdt;
              IFEND;
            IFEND;
          IFEND;
*IF NOT $true(osv$unix)
          type_kinds := type_kinds - $clt$type_kinds [clc$list_type];
*ELSE
          type_kinds := type_kinds - $clt$type_kinds_v2 [clc$list_type];
*IFEND
        IFEND;

        IF range_specified THEN
          set_range_type;
*IF NOT $true(osv$unix)
          type_kinds := type_kinds - $clt$type_kinds [clc$range_type];
*ELSE
          type_kinds := type_kinds - $clt$type_kinds_v2 [clc$range_type];
*IFEND
        IFEND;

        translate_type (type_kinds, encode_file_values, value_kind_specifier^, group_keywords,
              symbolic_parameter, symbolic_qualifiers_work_area, work_area, local_application_type_present,
              type_description, status);
        IF NOT status.normal THEN
          EXIT clp$translate_pdt;
        ELSEIF local_application_type_present THEN
          application_type_present := TRUE;
          new_pdt.parameters^ [i].checking_level := clc$extended_parameter_checking;
        IFEND;
      FOREND /process_parameter/;

    PROCEND translate_pdt_types;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    application_type_present := FALSE;
    symbolic_qualifiers_work_area := symbolic_qualifiers_area;

    initialize_header;

    IF old_pdt.parameters <> NIL THEN

      process_parameter_names;

      process_parameters;

      translate_pdt_types;

      sort_parameter_names (new_pdt);

    IFEND;

  PROCEND clp$translate_pdt;
?? TITLE := 'clp$translate_vks', EJECT ??

  PROCEDURE [XDCL] clp$translate_vks
    (    old_vks: clt$value_kind_specifier;
         group_keywords: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR application_type_present: boolean;
     VAR new_type_description: clt$type_description;
     VAR status: ost$status);

    VAR
      type_description: ^clt$type_description,
*IF NOT $true(osv$unix)
      type_kinds: clt$type_kinds,
*ELSE
      type_kinds: clt$type_kinds_v2,
*IFEND
      symbolic_qualifiers_work_area: ^clt$work_area;


    status.normal := TRUE;
    application_type_present := FALSE;
    symbolic_qualifiers_work_area := NIL;

    determine_type_kinds (old_vks, type_kinds);

    type_description := ^new_type_description;

    translate_type (type_kinds, TRUE, old_vks, group_keywords, NIL, symbolic_qualifiers_work_area, work_area,
          application_type_present, type_description, status);

  PROCEND clp$translate_vks;
*IFEND
?? TITLE := 'determine_type_kinds', EJECT ??

  PROCEDURE [INLINE] determine_type_kinds
    (    value_kind_specifier: clt$value_kind_specifier;
*IF NOT $true(osv$unix)
     VAR type_kinds: clt$type_kinds);
*ELSE
     VAR type_kinds: clt$type_kinds_v2);
*IFEND

    VAR
      type_kind: clt$type_kind;


*IF NOT $true(osv$unix)
    type_kinds := $clt$type_kinds [];
*ELSE
    type_kinds := $clt$type_kinds_v2 [];
*IFEND

    CASE value_kind_specifier.kind OF
    = clc$any_value =
      type_kind := clc$union_type;
*IF NOT $true(osv$unix)
      type_kinds := $clt$type_kinds [clc$boolean_type, clc$file_type, clc$integer_type, clc$name_type,
            clc$real_type, clc$status_type, clc$string_type];
*ELSE
      type_kinds := $clt$type_kinds_v2 [clc$boolean_type, clc$nos_ve_file_type, clc$integer_type,
            clc$name_type, clc$real_type, clc$status_type, clc$string_type];
*IFEND
    = clc$application_value =
      type_kind := clc$application_type;
    = clc$boolean_value =
      type_kind := clc$boolean_type;
    = clc$file_value =
*IF NOT $true(osv$unix)
      type_kind := clc$file_type;
*ELSE
      type_kind := clc$nos_ve_file_type;
*IFEND
    = clc$integer_value =
      type_kind := clc$integer_type;
    = clc$keyword_value =
      type_kind := clc$keyword_type;
    = clc$name_value =
      type_kind := clc$name_type;
    = clc$real_value =
      type_kind := clc$real_type;
    = clc$status_value =
      type_kind := clc$status_type;
    = clc$string_value =
      type_kind := clc$string_type;

    = clc$variable_reference =
      CASE value_kind_specifier.variable_kind OF
      = clc$any_value =
        type_kind := clc$union_type;
*IF NOT $true(osv$unix)
        type_kinds := $clt$type_kinds [clc$boolean_type, clc$file_type, clc$integer_type, clc$name_type,
              clc$real_type, clc$status_type, clc$string_type, clc$union_type];
*ELSE
        type_kinds := $clt$type_kinds_v2 [clc$boolean_type, clc$nos_ve_file_type, clc$integer_type,
              clc$name_type, clc$real_type, clc$status_type, clc$string_type, clc$union_type];
*IFEND
      = clc$boolean_value =
        type_kind := clc$boolean_type;
      = clc$integer_value =
        type_kind := clc$integer_type;
      = clc$real_value =
        type_kind := clc$real_type;
      = clc$status_value =
        type_kind := clc$status_type;
      = clc$string_value =
        type_kind := clc$string_type;
      CASEND;
    CASEND;

*IF NOT $true(osv$unix)
    type_kinds := type_kinds + $clt$type_kinds [type_kind];
*ELSE
    type_kinds := type_kinds + $clt$type_kinds_v2 [type_kind];
*IFEND

    IF value_kind_specifier.keyword_values <> NIL THEN
*IF NOT $true(osv$unix)
      type_kinds := type_kinds + $clt$type_kinds [clc$keyword_type];
*ELSE
      type_kinds := type_kinds + $clt$type_kinds_v2 [clc$keyword_type];
*IFEND
    IFEND;

  PROCEND determine_type_kinds;
?? TITLE := 'set_symbolic_qualifier', EJECT ??

  PROCEDURE set_symbolic_qualifier
    (    low_text: ^string ( * );
         high_text: ^string ( * );
     VAR symbolic_qualifiers_work_area { input, output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      symbolic_high_text: ^string ( * ),
      symbolic_low_text: ^string ( * ),
      symbolic_subrange_qualifier: ^clt$symbolic_subrange_qualifier;


    status.normal := TRUE;

    NEXT symbolic_subrange_qualifier IN symbolic_qualifiers_work_area;
    IF symbolic_subrange_qualifier = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;

    IF low_text = NIL THEN
      symbolic_subrange_qualifier^.low_text_size := 0;
    ELSE
      symbolic_subrange_qualifier^.low_text_size := STRLENGTH (low_text^);
      NEXT symbolic_low_text: [STRLENGTH (low_text^)] IN symbolic_qualifiers_work_area;
      IF symbolic_low_text = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
      symbolic_low_text^ := low_text^;
    IFEND;

    IF (high_text = NIL) OR (high_text = low_text) THEN
      symbolic_subrange_qualifier^.high_text_size := 0;
    ELSE
      symbolic_subrange_qualifier^.high_text_size := STRLENGTH (high_text^);
      NEXT symbolic_high_text: [STRLENGTH (high_text^)] IN symbolic_qualifiers_work_area;
      IF symbolic_high_text = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
      symbolic_high_text^ := high_text^;
    IFEND

  PROCEND set_symbolic_qualifier;
?? TITLE := 'sort_parameter_names', EJECT ??

  PROCEDURE [INLINE] sort_parameter_names
    (VAR new_pdt {input, output} : clt$unbundled_pdt);

    VAR
      current: -clc$max_parameter_names .. clc$max_parameter_names,
      gap: 1 .. clc$max_parameter_names,
      start: 1 .. clc$max_parameter_names,
      swap: clt$pdt_parameter_name;

    VAR
      i: clt$parameter_name_index;


{ Sort parameter names using shell sort technique.

    gap := UPPERBOUND (new_pdt.names^);
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := 1 TO UPPERBOUND (new_pdt.names^) - gap DO
        current := start;
        WHILE (current > 0) AND (new_pdt.names^ [current].name > new_pdt.names^ [current + gap].name) DO
          swap := new_pdt.names^ [current];
          new_pdt.names^ [current] := new_pdt.names^ [current + gap];
          new_pdt.names^ [current + gap] := swap;
          current := current - gap;
        WHILEND;
      FOREND;
    WHILEND;

{ Adjust name indexes in parameters array following sort.

    FOR i := 1 TO UPPERBOUND (new_pdt.names^) DO
      IF new_pdt.names^ [i].class = clc$nominal_entry THEN
        new_pdt.parameters^ [new_pdt.names^ [i].position].name_index := i;
      IFEND;
    FOREND;

  PROCEND sort_parameter_names;
?? TITLE := 'translate_type', EJECT ??

  PROCEDURE translate_type
*IF NOT $true(osv$unix)
    (    type_kinds: clt$type_kinds;
*ELSE
    (    type_kinds: clt$type_kinds_v2;
*IFEND
         encode_file_values: boolean;
         value_kind_specifier: clt$value_kind_specifier;
         group_keywords: boolean;
         symbolic_parameter: ^clt$symbolic_parameter;
     VAR symbolic_qualifiers_work_area {input, output} : ^clt$work_area;
     VAR work_area {input, output} : ^clt$work_area;
     VAR application_type_present: boolean;
     VAR type_description {input, output} : ^clt$type_description;
     VAR status: ost$status);

    VAR
      symbolic_qualifier_applicable: boolean;

?? NEWTITLE := 'set_application_type', EJECT ??

    PROCEDURE [INLINE] set_application_type;


      set_type (clc$application_type);
      IF value_kind_specifier.value_name <> '' THEN
        NEXT type_description^.name: [clp$trimmed_string_size (value_kind_specifier.value_name)] IN work_area;
        type_description^.name^ := value_kind_specifier.value_name;
      IFEND;
      type_description^.balance_brackets := FALSE;

      application_type_present := TRUE;

    PROCEND set_application_type;
?? TITLE := 'set_integer_type', EJECT ??

    PROCEDURE [INLINE] set_integer_type
      (    min_integer_value: integer;
           max_integer_value: integer);


      symbolic_qualifier_applicable := TRUE;
      set_type (clc$integer_type);
      type_description^.min_integer_value := min_integer_value;
      type_description^.max_integer_value := max_integer_value;
      type_description^.default_radix := 10;

    PROCEND set_integer_type;
?? TITLE := 'set_keyword_type', EJECT ??

    PROCEDURE set_keyword_type;

?? NEWTITLE := 'set_keyword_groups', EJECT ??

      PROCEDURE set_keyword_groups
        (VAR keywords {input, output} : clt$keyword_specifications);

        VAR
*IF NOT $true(osv$unix)
          underline: [STATIC, READ, oss$job_paged_literal] packed array [char] of boolean := [
*ELSE
          underline: [STATIC, READ] packed array [char] of boolean := [
*IFEND
                { } REP 95 of FALSE,
                {_} TRUE,
                { } REP 160 of FALSE];

        VAR
          abbrev: ost$name,
          abbrev_name_found: boolean,
          abbrev_size: 0 .. osc$max_name_size,
          current_name: ost$name,
          current_name_size: ost$name_size,
          first_character: char,
          first_index: 1 .. clc$max_keywords,
          group_begin: 1 .. clc$max_keywords,
          group_end: 1 .. clc$max_keywords,
          group_index: 1 .. clc$max_keywords,
          group_ordinal: clt$named_entry_ordinal,
          index: 1 .. clc$max_keywords,
          name: ost$name,
          name_index: integer,
          name_size: ost$name_size,
          number_of_keywords: 1 .. clc$max_keywords,
          scan_index: integer,
          temp_abbrev: ost$name,
          temp_size: 0 .. osc$max_name_size,
          underline_encountered: boolean,
          underline_found: boolean;


        number_of_keywords := UPPERBOUND (keywords);
        group_ordinal := 1;
        index := 1;

      /group/
        WHILE index <= number_of_keywords DO
          group_begin := index;
          first_character := keywords [group_begin].keyword (1);
          group_end := group_begin;

        /group_on_first/
          WHILE group_end <= number_of_keywords DO
            IF keywords [group_end].keyword (1) <> first_character THEN
              group_end := group_end - 1;
              EXIT /group_on_first/;
            IFEND;
            IF group_end = number_of_keywords THEN
              EXIT /group_on_first/;
            IFEND;
            group_end := group_end + 1;
          WHILEND /group_on_first/;

          IF group_end = group_begin THEN

{Only nominal entry (preset by  caller) in group

            keywords [index].ordinal := group_ordinal;
            group_ordinal := group_ordinal + 1;
            index := index + 1;
            CYCLE /group/;
          IFEND;

          group_index := index;

        /process_first_same_char/
          WHILE group_index <= group_end DO
            abbrev (1) := first_character;
            abbrev_size := 1;
            underline_encountered := FALSE;
            abbrev_name_found := FALSE;

          /group_on_abbrev/
            WHILE group_index <= group_end DO
              temp_abbrev (1) := first_character;
              temp_size := 1;
              name_index := 1;
              current_name := keywords [group_index].keyword;
              current_name_size := clp$trimmed_string_size (keywords [group_index].keyword);

            /find_abbrev/
              WHILE name_index <= current_name_size DO
                #SCAN (underline, current_name (name_index, * ), scan_index, underline_found);
                name_index := name_index + scan_index;
                IF underline_found THEN
                  IF name_index < current_name_size THEN
                    underline_encountered := TRUE;
                    temp_abbrev (temp_size + 1) := current_name (name_index);
                    temp_size := temp_size + 1;
                  ELSE
                    temp_size := 1;
                    EXIT /find_abbrev/;
                  IFEND;
                IFEND;
              WHILEND /find_abbrev/;

              IF abbrev_size = 1 THEN
                IF (temp_size > 1) THEN
                  abbrev := temp_abbrev;
                  abbrev_size := temp_size;
                ELSEIF (NOT underline_encountered) AND (NOT abbrev_name_found) THEN
                  abbrev_name_found := TRUE;
                  abbrev := current_name;
                  abbrev_size := current_name_size;
                  group_index := group_index + 1;
                  CYCLE /group_on_abbrev/;
                IFEND;
              IFEND;

              IF current_name (1, current_name_size) = abbrev (1, abbrev_size) THEN
                abbrev_name_found := TRUE;
                group_index := group_index + 1;
                CYCLE /group_on_abbrev/;
              ELSEIF temp_abbrev (1, temp_size) = abbrev (1, abbrev_size) THEN
                group_index := group_index + 1;
                CYCLE /group_on_abbrev/;
              ELSEIF (temp_size = 1) AND ((current_name_size = 1) AND (NOT underline_encountered)) THEN
                abbrev_name_found := TRUE;
                group_index := group_index + 1;
                CYCLE /group_on_abbrev/;
              ELSEIF current_name_size = (abbrev_size + 1) THEN
                IF (current_name (1, abbrev_size) = abbrev) AND (current_name (current_name_size) = 'S') THEN
                  abbrev_name_found := TRUE;
                  group_index := group_index + 1;
                  CYCLE /group_on_abbrev/;
                IFEND;
              ELSEIF abbrev_size = (current_name_size + 1) THEN
                IF (abbrev (1, current_name_size) = current_name) AND (abbrev (abbrev_size) = 'S') THEN
                  abbrev_name_found := TRUE;
                  group_index := group_index + 1;
                  CYCLE /group_on_abbrev/;
                IFEND;
              IFEND;

{no match on abbrev

              IF group_index > index THEN
                group_index := group_index - 1;
              IFEND;
              EXIT /group_on_abbrev/;
            WHILEND /group_on_abbrev/;

            IF group_index > group_end THEN
              group_index := group_end;
            IFEND;
            first_index := index;
            WHILE index <= group_index DO
              keywords [index].ordinal := group_ordinal;
              IF abbrev_name_found THEN
                IF index <> first_index THEN
                  IF (index < group_index) THEN
                    keywords [index].class := clc$alias_entry
                  ELSE
                    keywords [index].class := clc$abbreviation_entry;
                  IFEND;
                IFEND;
              ELSE
                group_ordinal := group_ordinal + 1;
              IFEND;
              index := index + 1;
            WHILEND;
            IF abbrev_name_found THEN
              group_ordinal := group_ordinal + 1;
            IFEND;
            group_index := group_index + 1;
          WHILEND /process_first_same_char/;
          index := group_end + 1;

        WHILEND /group/;

      PROCEND set_keyword_groups;
?? TITLE := 'sort_keywords', EJECT ??

      PROCEDURE [INLINE] sort_keywords
        (VAR keywords {input, output} : clt$keyword_specifications);

        VAR
          current: -clc$max_keywords .. clc$max_keywords,
          gap: 1 .. clc$max_keywords,
          start: 1 .. clc$max_keywords,
          swap: clt$keyword_specification;


{ Sort keywords using shell sort technique.

        gap := UPPERBOUND (keywords);
        WHILE gap > 1 DO
          gap := 2 * (gap DIV 4) + 1;
          FOR start := 1 TO UPPERBOUND (keywords) - gap DO
            current := start;
            WHILE (current > 0) AND (keywords [current].keyword > keywords [current + gap].keyword) DO
              swap := keywords [current];
              keywords [current] := keywords [current + gap];
              keywords [current + gap] := swap;
              current := current - gap;
            WHILEND;
          FOREND;
        WHILEND;

      PROCEND sort_keywords;
?? OLDTITLE, EJECT ??

      VAR
        i: 1 .. clc$max_keywords;


      set_type (clc$keyword_type);

      NEXT type_description^.keyword_specifications: [1 .. UPPERBOUND (value_kind_specifier.
            keyword_values^)] IN work_area;

      FOR i := 1 TO UPPERBOUND (value_kind_specifier.keyword_values^) DO
        #TRANSLATE (osv$lower_to_upper, value_kind_specifier.keyword_values^ [i],
              type_description^.keyword_specifications^ [i].keyword);
        type_description^.keyword_specifications^ [i].class := clc$nominal_entry;
        type_description^.keyword_specifications^ [i].availability := clc$normal_usage_entry;
        type_description^.keyword_specifications^ [i].ordinal := i;
      FOREND;

      IF group_keywords THEN
        set_keyword_groups (type_description^.keyword_specifications^);
      IFEND;

      sort_keywords (type_description^.keyword_specifications^);

    PROCEND set_keyword_type;
?? TITLE := 'set_name_type', EJECT ??

    PROCEDURE [INLINE] set_name_type
      (    min_name_size: ost$name_size;
           max_name_size: ost$name_size);


      symbolic_qualifier_applicable := TRUE;
      set_type (clc$name_type);
      type_description^.min_name_size := min_name_size;
      type_description^.max_name_size := max_name_size;

    PROCEND set_name_type;
?? TITLE := 'set_real_type', EJECT ??

    PROCEDURE [INLINE] set_real_type;


      set_type (clc$real_type);
*IF NOT $true(osv$unix)
      #UNCHECKED_CONVERSION (clv$negative_infinity^, type_description^.min_real_value.long_real);
      #UNCHECKED_CONVERSION (clv$positive_infinity^, type_description^.max_real_value.long_real);
*ELSE
      type_description^.min_real_value.long_real := clv$negative_infinity^;
      type_description^.max_real_value.long_real := clv$positive_infinity^;
*IFEND

    PROCEND set_real_type;
?? TITLE := 'set_specifier_type', EJECT ??

    PROCEDURE [INLINE] set_specifier_type;


      CASE value_kind_specifier.kind OF
      = clc$any_value =
        set_unqualified_union_type;
      = clc$application_value =
        set_application_type;
      = clc$variable_reference =
        IF value_kind_specifier.array_allowed = clc$array_allowed THEN
          set_type (clc$array_type);
          type_description^.array_bounds_defined := FALSE;
          NEXT type_description^.array_element_type_description IN work_area;
          type_description := type_description^.array_element_type_description;
        IFEND;

        CASE value_kind_specifier.variable_kind OF
        = clc$string_value =
          set_string_type (0, clc$max_string_size);
        = clc$real_value =
          set_real_type;
        = clc$integer_value =
          set_integer_type (clc$min_integer, clc$max_integer);
        = clc$boolean_value =
          set_type (clc$boolean_type);
        = clc$status_value =
          set_type (clc$status_type);
        = clc$any_value =
          set_unqualified_union_type;
        CASEND;

      = clc$file_value =
*IF NOT $true(osv$unix)
        set_type (clc$file_type);
*ELSE
        set_type (clc$nos_ve_file_type);
*IFEND
      = clc$name_value =
        set_name_type (value_kind_specifier.min_name_size, value_kind_specifier.max_name_size);
      = clc$string_value =
        set_string_type (value_kind_specifier.min_string_size, value_kind_specifier.max_string_size);
      = clc$integer_value =
        set_integer_type (value_kind_specifier.min_integer_value, value_kind_specifier.max_integer_value);
      = clc$real_value =
        set_real_type;
      = clc$boolean_value =
        set_type (clc$boolean_type);
      = clc$status_value =
        set_type (clc$status_type);
      CASEND;

    PROCEND set_specifier_type;
?? TITLE := 'set_string_type', EJECT ??

    PROCEDURE [INLINE] set_string_type
      (    min_string_size: clt$string_size;
           max_string_size: clt$string_size);


      symbolic_qualifier_applicable := TRUE;
      set_type (clc$string_type);
      type_description^.min_string_size := min_string_size;
      IF max_string_size >= osc$max_string_size THEN
        type_description^.max_string_size := clc$max_string_size;
      ELSE
        type_description^.max_string_size := max_string_size;
      IFEND;
      type_description^.literal := FALSE;

    PROCEND set_string_type;
?? TITLE := 'set_type', EJECT ??

    PROCEDURE [INLINE] set_type
      (    kind: clt$type_kind);


      type_description^.specification := NIL;
      type_description^.name := NIL;
      type_description^.derived_from_value_kind_spec := encode_file_values;
      type_description^.advanced_keywords_present := FALSE;
      type_description^.kinds := type_kinds;
      type_description^.kind := kind;

    PROCEND set_type;
?? TITLE := 'set_union_with_keywords_type', EJECT ??

    PROCEDURE [INLINE] set_union_with_keywords_type;

      VAR
        union_type_description: ^clt$type_description;


      set_type (clc$union_type);

      NEXT type_description^.member_descriptions: [1 .. 2] IN work_area;

      union_type_description := type_description;
      type_description := ^union_type_description^.member_descriptions^ [1];

      set_keyword_type;

      type_description := ^union_type_description^.member_descriptions^ [2];

      set_specifier_type;

      NEXT union_type_description^.union_information IN work_area;
      union_type_description^.union_information^.only_standard_types_in_union := FALSE;
      IF type_description^.kind = clc$integer_type THEN
        union_type_description^.union_information^.min_integer_value := type_description^.min_integer_value;
        union_type_description^.union_information^.max_integer_value := type_description^.max_integer_value;
      ELSE
        union_type_description^.union_information^.min_integer_value := clc$min_integer;
        union_type_description^.union_information^.max_integer_value := clc$max_integer;
      IFEND;
      union_type_description^.union_information^.default_radix := 10;
*IF NOT $true(osv$unix)
      #UNCHECKED_CONVERSION (clv$negative_infinity^, union_type_description^.union_information^.
            min_real_value.long_real);
      #UNCHECKED_CONVERSION (clv$positive_infinity^, union_type_description^.union_information^.
            max_real_value.long_real);
*ELSE
      union_type_description^.union_information^.min_real_value.long_real := clv$negative_infinity^;
      union_type_description^.union_information^.max_real_value.long_real := clv$positive_infinity^;
*IFEND

    PROCEND set_union_with_keywords_type;
?? TITLE := 'set_unqualified_union_type', EJECT ??

    PROCEDURE [INLINE] set_unqualified_union_type;

      VAR
        i: 1 .. clc$max_union_members,
        union_members: ^array [ * ] of clt$type_description;


      type_description^ := old_union_type_description;
      type_description^.derived_from_value_kind_spec := encode_file_values;
      NEXT union_members: [1 .. UPPERBOUND (old_union_members)] IN work_area;
      union_members^ := old_union_members;
      FOR i := 1 TO UPPERBOUND (old_union_members) DO
        union_members^ [i].derived_from_value_kind_spec := encode_file_values;
      FOREND;
      type_description^.member_descriptions := union_members;

      IF symbolic_parameter <> NIL THEN

{ Establish symbolic info for types NAME, INTEGER and STRING.

        set_symbolic_qualifier (NIL, NIL, symbolic_qualifiers_work_area, status);
        set_symbolic_qualifier (NIL, NIL, symbolic_qualifiers_work_area, status);
        set_symbolic_qualifier (NIL, NIL, symbolic_qualifiers_work_area, status);
      IFEND;

    PROCEND set_unqualified_union_type;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    application_type_present := FALSE;

    symbolic_qualifier_applicable := FALSE;

    IF value_kind_specifier.keyword_values <> NIL THEN
      IF (value_kind_specifier.kind = clc$unspecified_value) OR
            (value_kind_specifier.kind = clc$keyword_value) THEN
        set_keyword_type;
      ELSE
        set_union_with_keywords_type;
      IFEND;
    ELSE
      set_specifier_type;
    IFEND;

    IF symbolic_qualifier_applicable AND (symbolic_parameter <> NIL) THEN
      set_symbolic_qualifier (symbolic_parameter^.value_kind_qualifier_low,
            symbolic_parameter^.value_kind_qualifier_high, symbolic_qualifiers_work_area, status);
    IFEND;

  PROCEND translate_type;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$bundle_pdt', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$bundle_pdt
    (    unbundled_pdt: clt$unbundled_pdt;
     VAR work_area {input, output} : ^clt$work_area;
     VAR parameter_description_table: ^clt$parameter_description_table;
     VAR status: ost$status);

    VAR
      default_name: ^clt$variable_name_reference,
      default_value: ^clt$expression_text,
      final_position: integer,
      header: ^clt$pdt_header,
      i: clt$parameter_number,
      names: ^clt$pdt_parameter_names,
      parameters: ^clt$pdt_parameters,
      type_specification: ^clt$type_specification;


    status.normal := TRUE;
    parameter_description_table := NIL;

    NEXT header IN work_area;
    IF header = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;
    header^ := unbundled_pdt.header^;

    IF unbundled_pdt.header^.number_of_parameter_names > 0 THEN
      NEXT names: [1 .. header^.number_of_parameter_names] IN work_area;
      NEXT parameters: [1 .. header^.number_of_parameters] IN work_area;
      IF (names = NIL) OR (parameters = NIL) THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;
      names^ := unbundled_pdt.names^;
      parameters^ := unbundled_pdt.parameters^;

      FOR i := 1 TO header^.number_of_parameters DO
        IF unbundled_pdt.type_descriptions^ [i].specification <> NIL THEN
          NEXT type_specification: [[REP #SIZE (unbundled_pdt.type_descriptions^ [i].specification^) OF
                cell]] IN work_area;
          IF type_specification = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            RETURN;
          IFEND;
          type_specification^ := unbundled_pdt.type_descriptions^ [i].specification^;
        ELSE
          clp$convert_type_desc_to_spec (^unbundled_pdt.type_descriptions^ [i], work_area, type_specification,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        parameters^ [i].type_specification_size := #SIZE (type_specification^);

        IF (unbundled_pdt.default_names = NIL) OR (unbundled_pdt.default_names^ [i] = NIL) THEN
          parameters^ [i].default_name_size := 0;
        ELSE
          NEXT default_name: [STRLENGTH (unbundled_pdt.default_names^ [i]^)] IN work_area;
          IF default_name = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            RETURN;
          IFEND;
          default_name^ := unbundled_pdt.default_names^ [i]^;
          parameters^ [i].default_name_size := STRLENGTH (default_name^);
        IFEND;

        IF unbundled_pdt.default_values^ [i] = NIL THEN
          parameters^ [i].default_value_size := 0;
        ELSE
          NEXT default_value: [STRLENGTH (unbundled_pdt.default_values^ [i]^)] IN work_area;
          IF default_value = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            RETURN;
          IFEND;
          default_value^ := unbundled_pdt.default_values^ [i]^;
          parameters^ [i].default_value_size := STRLENGTH (default_value^);
        IFEND;
      FOREND;
    IFEND;

    final_position := i#current_sequence_position (work_area);
    RESET work_area TO header;
    NEXT parameter_description_table: [[REP final_position - i#current_sequence_position (work_area) OF
          cell]] IN work_area;
    RESET parameter_description_table;

  PROCEND clp$bundle_pdt;
?? TITLE := 'clp$convert_pdt', EJECT ??
*copyc clh$convert_pdt

  PROCEDURE [XDCL, #GATE] clp$convert_pdt
    (    old_pdt: clt$parameter_descriptor_table;
     VAR work_area {input, output} : ^clt$work_area;
     VAR new_pdt: ^clt$parameter_description_table;
     VAR status: ost$status);

    VAR
      ignore_application_type_present: boolean,
      unbundled_pdt: clt$unbundled_pdt;


    clp$translate_pdt (old_pdt, FALSE, FALSE, NIL, NIL, NIL, work_area, ignore_application_type_present,
          unbundled_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$bundle_pdt (unbundled_pdt, work_area, new_pdt, status);

  PROCEND clp$convert_pdt;
*IFEND

MODEND clm$translate_pdt;
*DECK DECK=CLM$UNSEEN_MAIL_ACTION_HANDLER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Interpreter : UNSEEN_MAIL Action Handlers' ??
MODULE clm$unseen_mail_action_handler;

{
{ PURPOSE:
{   This module contains procedures to change and to retrieve the
{   unseen_mail action for the task.
{

?? NEWTITLE := 'Global Declarations Referenced in this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$bad_unseen_mail_action
*copyc clt$environment_object_contents
*copyc clt$environment_object_size
*copyc clt$env_object_pop_reason
*copyc clt$unseen_mail_action
*copyc ost$status
?? POP ??
*copyc clp$find_unseen_mail_action
*copyc osp$set_status_condition
*copyc pmp$propagate_unseen_mail
*copyc pmv$unseen_mail_pending
?? OLDTITLE ??
?? NEWTITLE := 'clp$eo_size_unseen_mail_action', EJECT ??

  FUNCTION [XDCL] clp$eo_size_unseen_mail_action: clt$environment_object_size;


    clp$eo_size_unseen_mail_action := #SIZE (clt$unseen_mail_action);

  FUNCEND clp$eo_size_unseen_mail_action;
?? OLDTITLE ??
?? NEWTITLE := 'clp$eo_init_unseen_mail_action', EJECT ??

  PROCEDURE [XDCL] clp$eo_init_unseen_mail_action
    (    object: ^clt$environment_object_contents);

    VAR
      unseen_mail_action: ^clt$unseen_mail_action;


    unseen_mail_action := object;

    unseen_mail_action^ := clc$display_unseen_mail;

  PROCEND clp$eo_init_unseen_mail_action;
?? OLDTITLE ??
?? NEWTITLE := 'clp$eo_pop_unseen_mail_action', EJECT ??

  PROCEDURE [XDCL] clp$eo_pop_unseen_mail_action
    (    pop_reason: clt$env_object_pop_reason;
         object: ^clt$environment_object_contents;
         object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

    VAR
      popped_unseen_mail_action: ^clt$unseen_mail_action,
      pushed_unseen_mail_action: ^clt$unseen_mail_action;


    status.normal := TRUE;

    IF pushed_object = NIL THEN
      RETURN;
    IFEND;

    popped_unseen_mail_action := object;
    pushed_unseen_mail_action := pushed_object;

    IF (popped_unseen_mail_action^ = clc$post_unseen_mail) AND pmv$unseen_mail_pending AND
          (pushed_unseen_mail_action^ = clc$display_unseen_mail) THEN
      pmp$propagate_unseen_mail (status);
    IFEND;

  PROCEND clp$eo_pop_unseen_mail_action;
?? OLDTITLE ??
?? NEWTITLE := 'clp$eo_updt_unseen_mail_action', EJECT ??

  PROCEDURE [XDCL] clp$eo_updt_unseen_mail_action
    (    synchronous_with_parent: boolean;
         synchronous_with_job: boolean;
         current_object: ^clt$environment_object_contents;
         current_object_in_current_task: boolean;
     VAR status: ost$status);

    VAR
      unseen_mail_action: ^clt$unseen_mail_action;


    status.normal := TRUE;

    unseen_mail_action := current_object;

    IF synchronous_with_job AND pmv$unseen_mail_pending AND (unseen_mail_action^ = clc$display_unseen_mail)
          THEN
      pmp$propagate_unseen_mail (status);
    IFEND;

  PROCEND clp$eo_updt_unseen_mail_action;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] clp$change_unseen_mail_action', EJECT ??
*copyc clh$change_unseen_mail_action

  PROCEDURE [XDCL, #GATE] clp$change_unseen_mail_action
    (    action: clt$unseen_mail_action;
     VAR status: ost$status);

    VAR
      unseen_mail_action_ptr: ^clt$unseen_mail_action,
      old_action: clt$unseen_mail_action;


    status.normal := TRUE;
    IF (action <> clc$post_unseen_mail) AND (action <> clc$display_unseen_mail) THEN
      osp$set_status_condition (cle$bad_unseen_mail_action, status);
      RETURN;
    IFEND;

    clp$find_unseen_mail_action (unseen_mail_action_ptr);
    old_action := unseen_mail_action_ptr^;
    unseen_mail_action_ptr^ := action;
    IF (action = clc$display_unseen_mail) AND (old_action = clc$post_unseen_mail) AND
          pmv$unseen_mail_pending THEN
      pmp$propagate_unseen_mail (status);
    IFEND;

  PROCEND clp$change_unseen_mail_action;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] clp$get_unseen_mail_action', EJECT ??
*copyc clh$get_unseen_mail_action

  PROCEDURE [XDCL, #GATE] clp$get_unseen_mail_action
    (VAR action: clt$unseen_mail_action;
     VAR status: ost$status);

    VAR
      unseen_mail_action_ptr: ^clt$unseen_mail_action;


    status.normal := TRUE;
    clp$find_unseen_mail_action (unseen_mail_action_ptr);
    action := unseen_mail_action_ptr^;

  PROCEND clp$get_unseen_mail_action;
?? OLDTITLE ??

MODEND clm$unseen_mail_action_handler;
*DECK DECK=CLM$UTILITY_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Command Level Utility Commands' ??
MODULE clm$utility_commands;

{
{ PURPOSE:
{   This module contains the processors for the commands that provide the
{   "command level" utility capability.
{
{ DESIGN:
{   Process all the information needed to create a command level utility.
{   Execute the command level utility.  Change attributes of a command
{   level utility.  Return information about a utility.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_control_statement
*copyc cle$ecc_utilities
*copyc clt$block
*copyc clt$command_table_entry
*copyc clt$control_statement_info
*copyc clt$parse_state
*copyc clt$utility_attribute
*copyc clt$when_condition
*copyc ost$status
?? POP ??
*copyc clp$begin_utility
*copyc clp$change_utility_environment
*copyc clp$count_list_elements
*copyc clp$create_utility_environment
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$find_current_block
*copyc clp$get_interpreter_mode
*copyc clp$get_utility_attributes
*copyc clp$include_file
*copyc clp$make_boolean_value
*copyc clp$make_name_value
*copyc clp$make_string_value
*copyc clp$prepare_delayed_block
*copyc clp$process_delayed_block
*copyc clp$trimmed_string_size
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osv$initial_exception_context
?? EJECT ??

  CONST
    max_utility_attributes = 11;

  TYPE
    table_entry = record
      command: boolean,
      entry_info: clt$command_table_entry,
    recend;

  CONST
    utility_prompt = 'UTILITY',
    utility_prompt_length = 7;

?? TITLE := 'clp$_utility', EJECT ??

  PROCEDURE [XDCL] clp$_utility
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$utility) utility (
{   name, n: name = $required
{   enable_subcommand_logging, esl: (BY_NAME) boolean = yes
{   interactive_include_processor, iip: (BY_NAME) any of
{       key
{         none
{       keyend
{       name
{     anyend = none
{   library, libraries, l: (BY_NAME) list of file = $optional
{   line_preprocessor, lp: (BY_NAME) any of
{       key
{         none
{       keyend
{       name
{     anyend = none
{   online_manual, om: (BY_NAME) any of
{       key
{         none
{       keyend
{       name
{     anyend = none
{   prompt, p: (BY_NAME) string 0..27 = $optional
{   search_mode, sm: (BY_NAME) key
{       (global, g)
{       (restricted, r)
{       (exclusive, e)
{     keyend = global
{   tables, table, t: (BY_NAME) file = $command
{   termination_command_name, tcn: (BY_NAME) name = quit
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 23] of clt$pdt_parameter_name,
      parameters: array [1 .. 11] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (3),
      recend,
      type3: 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$name_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type5: 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$name_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type6: 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$name_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (6),
      recend,
      type9: record
        header: clt$type_specification_header,
        default_value: string (8),
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (4),
      recend,
      type11: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 4, 20, 14, 42, 58, 149],
    clc$command, 23, 11, 1, 0, 0, 0, 11, 'OSM$UTILITY'], [
    ['ENABLE_SUBCOMMAND_LOGGING      ',clc$nominal_entry, 2],
    ['ESL                            ',clc$abbreviation_entry, 2],
    ['IIP                            ',clc$abbreviation_entry, 3],
    ['INTERACTIVE_INCLUDE_PROCESSOR  ',clc$nominal_entry, 3],
    ['L                              ',clc$abbreviation_entry, 4],
    ['LIBRARIES                      ',clc$alias_entry, 4],
    ['LIBRARY                        ',clc$nominal_entry, 4],
    ['LINE_PREPROCESSOR              ',clc$nominal_entry, 5],
    ['LP                             ',clc$abbreviation_entry, 5],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['OM                             ',clc$abbreviation_entry, 6],
    ['ONLINE_MANUAL                  ',clc$nominal_entry, 6],
    ['P                              ',clc$abbreviation_entry, 7],
    ['PROMPT                         ',clc$nominal_entry, 7],
    ['SEARCH_MODE                    ',clc$nominal_entry, 8],
    ['SM                             ',clc$abbreviation_entry, 8],
    ['STATUS                         ',clc$nominal_entry, 11],
    ['T                              ',clc$abbreviation_entry, 9],
    ['TABLE                          ',clc$alias_entry, 9],
    ['TABLES                         ',clc$nominal_entry, 9],
    ['TCN                            ',clc$abbreviation_entry, 10],
    ['TERMINATION_COMMAND_NAME       ',clc$nominal_entry, 10]],
    [
{ PARAMETER 1
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$optional_parameter,
  0, 0],
{ PARAMETER 5
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 6
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 7
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 8
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 9
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 10
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 11
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$boolean_type],
    'yes'],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'none'],
{ PARAMETER 4
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'none'],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'none'],
{ PARAMETER 7
    [[1, 0, clc$string_type], [0, 27, FALSE]],
{ PARAMETER 8
    [[1, 0, clc$keyword_type], [6], [
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['EXCLUSIVE                      ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['G                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['GLOBAL                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['RESTRICTED                     ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'global'],
{ PARAMETER 9
    [[1, 0, clc$file_type],
    '$command'],
{ PARAMETER 10
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'quit'],
{ PARAMETER 11
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$enable_subcommand_logging = 2,
      p$interactive_include_processor = 3,
      p$library = 4,
      p$line_preprocessor = 5,
      p$online_manual = 6,
      p$prompt = 7,
      p$search_mode = 8,
      p$tables = 9,
      p$termination_command_name = 10,
      p$status = 11;

    VAR
      pvt: array [1 .. 11] of clt$parameter_value;


    VAR
      block: ^clt$block,
      can_be_echoed: boolean,
      command_sequence_pointer: ^SEQ ( * ),
      command_table: ^clt$command_table,
      delete_segment_status: ost$status,
      function_sequence_pointer: ^SEQ ( * ),
      function_table: ^clt$function_processor_table,
      include_processor: clt$utility_interactive_in_desc,
      index: integer,
      interpreter_mode: clt$interpreter_modes,
      library_list_ptr: ^array [1 .. * ] of fst$path,
      node: ^clt$data_value,
      online_manual: ost$name,
      pre_process: clt$utility_line_preproc_desc,
      prompt: string (clc$max_prompt_size),
      prompt_size: clt$prompt_size,
      search_mode: clt$command_search_modes,
      segment_pointer: amt$segment_pointer,
      statement_area: ^clt$collect_statement_area,
      substitution_mark: clt$substitution_mark,
      utility_command_attributes: array [1 .. 10] of clt$utility_attribute;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      IF command_sequence_pointer <> NIL THEN
        segment_pointer.sequence_pointer := command_sequence_pointer;
        mmp$delete_scratch_segment (segment_pointer, handler_status);
      IFEND;

      IF function_sequence_pointer <> NIL THEN
        segment_pointer.sequence_pointer := function_sequence_pointer;
        mmp$delete_scratch_segment (segment_pointer, handler_status);
      IFEND;

      handler_status.normal := TRUE;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      context: ^ost$ecp_exception_context;

    status.normal := TRUE;
    context := NIL;
    substitution_mark.specified := FALSE;
    command_sequence_pointer := NIL;
    #SPOIL (command_sequence_pointer);
    function_sequence_pointer := NIL;
    #SPOIL (function_sequence_pointer);

    clp$get_interpreter_mode (interpreter_mode);

    IF interpreter_mode <> clc$skip_mode THEN

      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF pvt [p$interactive_include_processor].value^.kind = clc$keyword {AND keyword = NONE} THEN
        include_processor.call_method := clc$unspecified_call;
      ELSE
        osp$set_status_abnormal ('CL', cle$not_yet_implemented, 'interactive include processor', status);
        RETURN;

{ The following code will be used when the interactive include processor is implemented.
{
{       include_processor.call_method := clc$proc_call;
{       include_processor.command_name := pvt [p$interactive_include_processor].value^.name_value;

      IFEND;

      IF pvt [p$library].specified THEN
        PUSH library_list_ptr: [1 .. clp$count_list_elements (pvt [p$library].value)];
        node := pvt [p$library].value;
        FOR index := 1 TO UPPERBOUND (library_list_ptr^) DO
          library_list_ptr^ [index] := node^.element_value^.file_value^;
          node := node^.link;
        FOREND;

      ELSE
        clp$find_current_block (block);
        block := block^.previous_block;

      /search/
        WHILE block <> NIL DO
          CASE block^.kind OF
          = clc$command_block =
            CASE block^.command_kind OF
            = clc$command_is_include_file, clc$command_is_include_line =
              ;
            ELSE
              EXIT /search/;
            CASEND;
          = clc$command_proc_block, clc$function_proc_block =
            EXIT /search/;
          ELSE
            ;
          CASEND;
          block := block^.previous_block;
        WHILEND /search/;

        IF block = NIL THEN
          osp$set_status_abnormal ('CL', cle$command_source_not_lib, '', status);
          EXIT clp$_utility;
        ELSEIF block^.source.kind = clc$library_commands THEN
          PUSH library_list_ptr: [1 .. 1];
          library_list_ptr^ [1] := block^.source.local_file_name;
        ELSEIF (block^.source.kind = clc$sub_commands) AND (block^.source.utility_info^.libraries <> NIL) THEN
          PUSH library_list_ptr: [1 .. UPPERBOUND (block^.source.utility_info^.libraries^)];
          FOR index := 1 TO UPPERBOUND (library_list_ptr^) DO
            library_list_ptr^ [index] := block^.source.utility_info^.libraries^ [index];
          FOREND;
        ELSE
          osp$set_status_abnormal ('CL', cle$command_source_not_lib, '', status);
          EXIT clp$_utility;
        IFEND;
      IFEND;

      IF pvt [p$line_preprocessor].value^.kind = clc$keyword {AND keyword = NONE} THEN
        pre_process.call_method := clc$unspecified_call;
      ELSE
        osp$set_status_abnormal ('CL', cle$not_yet_implemented, 'line preprocessor', status);
        RETURN;

{ The following code will be used when the line processor is implemented.
{
{       pre_process.call_method := clc$proc_call;
{       pre_process.command_name := pvt [p$line_preprocessor].value^.name_value;

      IFEND;

      IF pvt [p$online_manual].value^.kind = clc$keyword {AND keyword = NONE} THEN
        online_manual := osc$null_name;
      ELSE
        online_manual := pvt [p$online_manual].value^.name_value;
      IFEND;

      IF pvt [p$prompt].specified THEN
        prompt := pvt [p$prompt].value^.string_value^;
      ELSE
        prompt := pvt [p$name].value^.name_value;
      IFEND;
      prompt_size := clp$trimmed_string_size (prompt);
      IF prompt_size > clc$max_prompt_size THEN
        prompt_size := clc$max_prompt_size;
      IFEND;

      IF pvt [p$search_mode].value^.keyword_value = 'GLOBAL' THEN
        search_mode := clc$global_command_search;
      ELSEIF pvt [p$search_mode].value^.keyword_value = 'RESTRICTED' THEN
        search_mode := clc$restricted_command_search;
      ELSE {EXCLUSIVE}
        search_mode := clc$exclusive_command_search;
      IFEND;

      osp$establish_block_exit_hndlr (^abort_handler);

      build_tables (pvt [p$tables].value^.file_value^, command_sequence_pointer, function_sequence_pointer,
            command_table, function_table, status);

    IFEND; {End of skip if in skip_mode.

  /set_up_user_utility/
    BEGIN
      IF NOT status.normal THEN
        EXIT /set_up_user_utility/;
      IFEND;

      clp$prepare_delayed_block (interpreter_mode, 'UTILITY', 'UTILITYEND', utility_prompt, '',
            substitution_mark, statement_area, can_be_echoed, status);

      IF interpreter_mode <> clc$interpret_mode THEN
        RETURN;
      IFEND;

      IF NOT status.normal THEN
        EXIT /set_up_user_utility/;
      IFEND;

      utility_command_attributes [1].key := clc$utility_command_search_mode;
      utility_command_attributes [1].command_search_mode := search_mode;
      utility_command_attributes [2].key := clc$utility_command_table;
      utility_command_attributes [2].command_table := command_table;
      utility_command_attributes [3].key := clc$utility_function_proc_table;
      utility_command_attributes [3].function_processor_table := function_table;
      utility_command_attributes [4].key := clc$utility_interactive_include;
      utility_command_attributes [4].interactive_include_processor := include_processor;
      utility_command_attributes [5].key := clc$utility_libraries;
      utility_command_attributes [5].libraries := library_list_ptr;
      utility_command_attributes [6].key := clc$utility_line_preprocessor;
      utility_command_attributes [6].line_preprocessor := pre_process;
      utility_command_attributes [7].key := clc$utility_online_manual;
      utility_command_attributes [7].online_manual_name := online_manual;
      utility_command_attributes [8].key := clc$utility_prompt;
      utility_command_attributes [8].prompt.value := prompt;
      utility_command_attributes [8].prompt.size := prompt_size;
      utility_command_attributes [9].key := clc$utility_subcmnd_log_enabled;
      utility_command_attributes [9].subcommand_logging_enabled :=
            pvt [p$enable_subcommand_logging].value^.boolean_value.value;
      utility_command_attributes [10].key := clc$utility_termination_command;
      utility_command_attributes [10].termination_command :=
            pvt [p$termination_command_name].value^.name_value;

      REPEAT
        clp$create_utility_environment (pvt [p$name].value^.name_value, TRUE, FALSE,
              utility_command_attributes, status);
        IF NOT status.normal THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
    END /set_up_user_utility/;

    IF command_sequence_pointer <> NIL THEN
      segment_pointer.sequence_pointer := command_sequence_pointer;
      mmp$delete_scratch_segment (segment_pointer, delete_segment_status);
      IF (NOT delete_segment_status.normal) AND status.normal THEN
        status := delete_segment_status;
      IFEND;
      command_sequence_pointer := NIL;
      #SPOIL (command_sequence_pointer);
    IFEND;

    IF function_sequence_pointer <> NIL THEN
      segment_pointer.sequence_pointer := function_sequence_pointer;
      mmp$delete_scratch_segment (segment_pointer, delete_segment_status);
      IF (NOT delete_segment_status.normal) AND status.normal THEN
        status := delete_segment_status;
      IFEND;
      function_sequence_pointer := NIL;
      #SPOIL (function_sequence_pointer);
    IFEND;

    osp$disestablish_cond_handler;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$process_delayed_block (pvt [p$name].value^.name_value, statement_area, can_be_echoed, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (pvt [p$name].value^.name_value, status);

  PROCEND clp$_utility;
?? TITLE := 'build_tables', EJECT ??

  PROCEDURE build_tables
    (    table_file_name: fst$file_reference;
     VAR command_sequence_pointer {input, output} : ^SEQ ( * );
     VAR function_sequence_pointer {input, output} : ^SEQ ( * );
     VAR command_table {input, output} : ^clt$command_table;
     VAR function_table {input, output} : ^clt$function_processor_table;
     VAR status: ost$status);

{ table utility_command_list
{ command command command_command
{ command function function_command
{ command tablend tablend_command
{ tablend

{ The utility_command_list data is initialized later in
{ the init_utility_cmnd_list routine. Because there are
{ numerous nested procedures used to establish the
{ utility environment, the command_list cannot be
{ statically initialized. If any new commands need to
{ be added to the utility_command_list, use GENCT to
{ create the array and information needed, then use
{ the values to dynamically create the command_list.
{ See the init_utility_cmnd_list procedure.

    VAR
      command_entries: ^clt$command_table,
      command_entry_count: integer,
      command_ordinal_count: integer,
      function_entries: ^clt$function_processor_table,
      function_entry_count: integer,
      function_ordinal_count: integer,
      segment_pointer: amt$segment_pointer,
      utility_attributes: array [1 .. 4] of clt$utility_attribute,
      utility_command_list: ^clt$command_table,
      utility_command_list_entries: array [1 .. 3] of clt$command_table_entry,
      utility_name: ost$name;

?? NEWTITLE := 'command_command', EJECT ??

    PROCEDURE command_command
      (    parameter_list: clt$parameter_list;
       VAR status: ost$status);

{ PROCEDURE (osm$utility_command) command (
{   name, names, n: list of name = $required
{   processor, p: name = $optional
{   availability, a: (BY_NAME) key
{       (normal_usage, advertised, a, nu)
{       (advanced_usage, au)
{       (hidden, h)
{     keyend = normal_usage
{   automatically_log, al: (BY_NAME) boolean = yes
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
        default_value: string (12),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (3),
      recend,
    recend := [
    [1,
    [89, 4, 19, 17, 18, 53, 213],
    clc$command, 9, 4, 1, 0, 0, 0, 0, 'OSM$UTILITY_COMMAND'], [
    ['A                              ',clc$abbreviation_entry, 3],
    ['AL                             ',clc$abbreviation_entry, 4],
    ['AUTOMATICALLY_LOG              ',clc$nominal_entry, 4],
    ['AVAILABILITY                   ',clc$nominal_entry, 3],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PROCESSOR                      ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_default_parameter, 0, 12],
{ PARAMETER 4
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 3]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [8], [
    ['A                              ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['ADVANCED_USAGE                 ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['ADVERTISED                     ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['AU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['H                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['HIDDEN                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['NORMAL_USAGE                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['NU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1]]
    ,
    'normal_usage'],
{ PARAMETER 4
    [[1, 0, clc$boolean_type],
    'yes']];

?? FMT (FORMAT := ON) ??
?? POP ??

      CONST
        p$name = 1,
        p$processor = 2,
        p$availability = 3,
        p$automatically_log = 4;

      VAR
        pvt: array [1 .. 4] of clt$parameter_value;


      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF command_sequence_pointer = NIL THEN
        mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        command_sequence_pointer := segment_pointer.sequence_pointer;
        RESET command_sequence_pointer;
        NEXT command_entries: [1 .. #SIZE (command_sequence_pointer^) DIV
              #SIZE (clt$command_table_entry)] IN command_sequence_pointer;
      IFEND;

      save_entries (clc$command, pvt [p$name].value, pvt [p$processor].value, pvt [p$availability].
            value^.keyword_value, pvt [p$automatically_log].value^.boolean_value.value, status);

    PROCEND command_command;
?? TITLE := 'function_command', EJECT ??

    PROCEDURE function_command
      (    parameter_list: clt$parameter_list;
       VAR status: ost$status);

{ PROCEDURE (osm$utility_function) function (
{   name, names, n: any of
{       data_name
{       list of data_name
{     anyend = $required
{   processor, p: data_name = $optional
{   availability, a: (BY_NAME) key
{       (normal_usage, a, advertised, nu)
{       (advanced_usage, au)
{       (hidden, h)
{     keyend = normal_usage
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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,
        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,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
        default_value: string (12),
      recend,
    recend := [
    [1,
    [90, 3, 24, 14, 15, 14, 619],
    clc$command, 7, 3, 1, 0, 0, 0, 0, 'OSM$UTILITY_FUNCTION'], [
    ['A                              ',clc$abbreviation_entry, 3],
    ['AVAILABILITY                   ',clc$nominal_entry, 3],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PROCESSOR                      ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 42, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_default_parameter, 0, 12]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$data_name_type, clc$list_type],
    FALSE, 2],
    3, [[1, 0, clc$data_name_type]],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$data_name_type]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$data_name_type]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [8], [
    ['A                              ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['ADVANCED_USAGE                 ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['ADVERTISED                     ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['AU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['H                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['HIDDEN                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['NORMAL_USAGE                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['NU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1]]
    ,
    'normal_usage']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$processor = 2,
      p$availability = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


      VAR
        names: ^clt$data_value;


      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF function_sequence_pointer = NIL THEN
        mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        function_sequence_pointer := segment_pointer.sequence_pointer;
        RESET function_sequence_pointer;
        NEXT function_entries: [1 .. #SIZE (function_sequence_pointer^) DIV
              #SIZE (clt$function_proc_table_entry)] IN function_sequence_pointer;
      IFEND;

      IF pvt [p$name].value^.kind = clc$list THEN
        names := pvt [p$name].value;
      ELSE
        PUSH names;
        names^.kind := clc$list;
        names^.element_value := pvt [p$name].value;
        names^.link := NIL;
        names^.generated_via_list_rest := FALSE;
      IFEND;

      save_entries (clc$function, names, pvt [p$processor].value, pvt [p$availability].
            value^.keyword_value, FALSE {ignored} , status);

    PROCEND function_command;
?? TITLE := 'tablend_command', EJECT ??

    PROCEDURE tablend_command
      (    parameter_list: clt$parameter_list;
       VAR status: ost$status);

{ PROCEDURE (osm$utility_tablend) tablend

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 4, 19, 17, 27, 20, 914],
    clc$command, 0, 0, 0, 0, 0, 0, 0, 'OSM$UTILITY_TABLEND']];

?? FMT (FORMAT := ON) ??
?? POP ??

      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$end_include (utility_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND tablend_command;
?? TITLE := 'init_utility_cmnd_table', EJECT ??

    PROCEDURE [INLINE] init_utility_cmnd_table;


      utility_command_list := ^utility_command_list_entries;

      utility_command_list_entries [1].name := 'COMMAND                        ';
      utility_command_list_entries [1].class := clc$nominal_entry;
      utility_command_list_entries [1].availability := clc$advertised_entry;
      utility_command_list_entries [1].ordinal := 1;
      utility_command_list_entries [1].log_option := clc$automatically_log;
      utility_command_list_entries [1].call_method := clc$linked_call;
      utility_command_list_entries [1].command := ^command_command;

      utility_command_list_entries [2].name := 'FUNCTION                       ';
      utility_command_list_entries [2].class := clc$nominal_entry;
      utility_command_list_entries [2].availability := clc$advertised_entry;
      utility_command_list_entries [2].ordinal := 2;
      utility_command_list_entries [2].log_option := clc$automatically_log;
      utility_command_list_entries [2].call_method := clc$linked_call;
      utility_command_list_entries [2].command := ^function_command;

      utility_command_list_entries [3].name := 'TABLEND                        ';
      utility_command_list_entries [3].class := clc$nominal_entry;
      utility_command_list_entries [3].availability := clc$advertised_entry;
      utility_command_list_entries [3].ordinal := 3;
      utility_command_list_entries [3].log_option := clc$automatically_log;
      utility_command_list_entries [3].call_method := clc$linked_call;
      utility_command_list_entries [3].command := ^tablend_command;

    PROCEND init_utility_cmnd_table;
?? TITLE := 'save_entries', EJECT ??

    PROCEDURE save_entries
      (    command_or_function: clt$command_or_function;
           names: ^clt$data_value;
           processor_value: ^clt$data_value;
           availability_keyword: clt$keyword;
           automatically_log: boolean;
       VAR status: ost$status);

      VAR
        availability: clt$named_entry_availability,
        index: integer,
        method: clt$call_method,
        log_option: clt$command_log_option,
        node: ^clt$data_value,
        processor: ost$name;


      IF availability_keyword = 'NORMAL_USAGE' THEN
        availability := clc$normal_usage_entry;
      ELSEIF availability_keyword = 'ADVANCED_USAGE' THEN
        availability := clc$advanced_usage_entry;
      ELSE {HIDDEN}
        availability := clc$hidden_entry;
      IFEND;

      IF command_or_function = clc$command THEN
        IF automatically_log THEN
          log_option := clc$automatically_log;
        ELSE
          log_option := clc$manually_log;
        IFEND;
        IF command_entry_count < 1 THEN
          RESET command_sequence_pointer;
        IFEND;
        command_ordinal_count := command_ordinal_count + 1;
      ELSE {clc$function}
        IF function_entry_count < 1 THEN
          RESET function_sequence_pointer;
        IFEND;
        function_ordinal_count := function_ordinal_count + 1;
      IFEND;

      node := names;
      WHILE node <> NIL DO

        IF command_or_function = clc$command THEN
          FOR index := 1 TO command_entry_count DO
            IF node^.element_value^.name_value = command_entries^ [index].name THEN
              osp$set_status_abnormal ('CL', cle$duplicate_cmnd_or_fcn_name,
                    node^.element_value^.name_value, status);
              RETURN;
            IFEND;
          FOREND;
          command_entry_count := command_entry_count + 1;
          IF node = names THEN
            IF processor_value <> NIL THEN
              processor := processor_value^.name_value;
            ELSE
              processor := names^.element_value^.name_value;
            IFEND;
            command_entries^ [command_entry_count].class := clc$nominal_entry;
          ELSEIF node^.link = NIL THEN
            command_entries^ [command_entry_count].class := clc$abbreviation_entry;
          ELSE
            command_entries^ [command_entry_count].class := clc$alias_entry;
          IFEND;
          command_entries^ [command_entry_count].name := node^.element_value^.name_value;
          command_entries^ [command_entry_count].availability := availability;

{ We are assuming here that Proc_calls and Program_calls are
{ dealt with essentially the same.

          command_entries^ [command_entry_count].call_method := clc$proc_call;
          command_entries^ [command_entry_count].procedure_name := processor;
          command_entries^ [command_entry_count].ordinal := command_ordinal_count;
          command_entries^ [command_entry_count].log_option := log_option;

        ELSE {clc$function}
          FOR index := 1 TO function_entry_count DO
            IF node^.element_value^.data_name_value = function_entries^ [index].name THEN
              osp$set_status_abnormal ('CL', cle$duplicate_cmnd_or_fcn_name,
                    node^.element_value^.data_name_value, status);
              RETURN;
            IFEND;
          FOREND;
          function_entry_count := function_entry_count + 1;
          IF node = names THEN
            IF processor_value <> NIL THEN
              processor := processor_value^.data_name_value;
            ELSE
              processor := names^.element_value^.data_name_value;
            IFEND;
            function_entries^ [function_entry_count].class := clc$nominal_entry;
          ELSEIF node^.link = NIL THEN
            function_entries^ [function_entry_count].class := clc$abbreviation_entry;
          ELSE
            function_entries^ [function_entry_count].class := clc$alias_entry;
          IFEND;
          function_entries^ [function_entry_count].name := node^.element_value^.data_name_value;
          function_entries^ [function_entry_count].availability := availability;

{ We are assuming here that Proc_calls and Program_calls are
{ dealt with essentially the same.

          function_entries^ [function_entry_count].call_method := clc$proc_call;
          function_entries^ [function_entry_count].procedure_name := processor;
          function_entries^ [function_entry_count].ordinal := function_ordinal_count;
        IFEND;

        node := node^.link;
      WHILEND;

    PROCEND save_entries;
?? TITLE := 'sort_command_entries', EJECT ??

    PROCEDURE [INLINE] sort_command_entries;

      VAR
        current: integer,
        gap: integer,
        start: integer,
        swap: clt$command_table_entry;


      gap := command_entry_count;
      WHILE gap > 1 DO
        gap := 2 * (gap DIV 4) + 1;
        FOR start := 1 TO command_entry_count - gap DO
          current := start;
          WHILE (current > 0) AND (command_entries^ [current].name > command_entries^ [current + gap].name) DO
            swap := command_entries^ [current];
            command_entries^ [current] := command_entries^ [current + gap];
            command_entries^ [current + gap] := swap;
            current := current - gap;
          WHILEND;
        FOREND;
      WHILEND;

    PROCEND sort_command_entries;
?? TITLE := 'sort_function_entries', EJECT ??

    PROCEDURE [INLINE] sort_function_entries;

      VAR
        current: integer,
        gap: integer,
        start: integer,
        swap: clt$function_proc_table_entry;


      gap := function_entry_count;
      WHILE gap > 1 DO
        gap := 2 * (gap DIV 4) + 1;
        FOR start := 1 TO function_entry_count - gap DO
          current := start;
          WHILE (current > 0) AND (function_entries^ [current].name > function_entries^ [current + gap].name)
                DO
            swap := function_entries^ [current];
            function_entries^ [current] := function_entries^ [current + gap];
            function_entries^ [current + gap] := swap;
            current := current - gap;
          WHILEND;
        FOREND;
      WHILEND;

    PROCEND sort_function_entries;
?? OLDTITLE, EJECT ??

    command_entry_count := 0;
    command_ordinal_count := 0;
    function_entry_count := 0;
    function_ordinal_count := 0;
    utility_name := 'utility_utilityend';

    init_utility_cmnd_table;

    utility_attributes [1].key := clc$utility_command_search_mode;
    utility_attributes [1].command_search_mode := clc$global_command_search;
    utility_attributes [2].key := clc$utility_command_table;
    utility_attributes [2].command_table := utility_command_list;
    utility_attributes [3].key := clc$utility_prompt;
    utility_attributes [3].prompt.value := utility_prompt;
    utility_attributes [3].prompt.size := utility_prompt_length;
    utility_attributes [4].key := clc$utility_termination_command;
    utility_attributes [4].termination_command := 'tablend';

    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (table_file_name, utility_prompt, utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET command_sequence_pointer;
    RESET function_sequence_pointer;

    IF command_entry_count > 0 THEN
      NEXT command_entries: [1 .. command_entry_count] IN command_sequence_pointer;
      sort_command_entries;
    ELSE
      command_entries := NIL;
    IFEND;

    IF function_entry_count > 0 THEN
      NEXT function_entries: [1 .. function_entry_count] IN function_sequence_pointer;
      sort_function_entries;
    ELSE
      function_entries := NIL;
    IFEND;

    command_table := command_entries;
    function_table := function_entries;

  PROCEND build_tables;
?? TITLE := 'clp$utilityend_statement', EJECT ??

  PROCEDURE [XDCL] clp$utilityend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

    VAR
      current_block: ^clt$block;


    status.normal := TRUE;
    clp$find_current_block (current_block);

    IF (current_block^.kind <> clc$input_block) OR (current_block^.previous_block^.kind <>
          clc$utility_block) OR (NOT current_block^.previous_block^.command_environment.command_level) THEN
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'UTILITYEND', status);
    IFEND;

  PROCEND clp$utilityend_statement;
?? TITLE := 'clp$$utility', EJECT ??

  PROCEDURE [XDCL] clp$$utility
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$utility) $utility (
{   attribute: key
{       (name, n)
{       (online_manual, om)
{       (prompt, p)
{       (subcommand_logging_enabled, scle, sle)
{     keyend = $required
{   )

?? 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$keyword_type_qualifier,
        keyword_specs: array [1 .. 9] of clt$keyword_specification,
      recend,
    recend := [
    [1,
    [89, 4, 20, 14, 36, 49, 240],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$UTILITY'], [
    ['ATTRIBUTE                      ',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, 340,
  clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [9], [
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NAME                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['OM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['ONLINE_MANUAL                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['PROMPT                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['SCLE                           ', clc$alias_entry, clc$normal_usage_entry, 4],
    ['SLE                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['SUBCOMMAND_LOGGING_ENABLED     ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$attribute = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    VAR
      attributes: array [1 .. 1] of clt$utility_attribute,
      utility_active: boolean,
      utility_name: ost$name;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    utility_name := osc$null_name;
    utility_active := TRUE;

    IF (pvt [p$attribute].value^.keyword_value = 'NAME') THEN
      attributes [1].key := clc$utility_name;
    ELSEIF (pvt [p$attribute].value^.keyword_value = 'ONLINE_MANUAL') THEN
      attributes [1].key := clc$utility_online_manual;
    ELSEIF (pvt [p$attribute].value^.keyword_value = 'PROMPT') THEN
      attributes [1].key := clc$utility_prompt;
    ELSEIF (pvt [p$attribute].value^.keyword_value = 'SUBCOMMAND_LOGGING_ENABLED') THEN
      attributes [1].key := clc$utility_subcmnd_log_enabled;
    IFEND;

    clp$get_utility_attributes (utility_name, attributes, status);
    IF NOT status.normal THEN
      IF status.condition <> cle$unknown_utility THEN
        RETURN;
      ELSE
        utility_active := FALSE;
        status.normal := TRUE;
      IFEND;
    IFEND;

    CASE attributes [1].key OF

    = clc$utility_name =
      IF utility_active THEN
        clp$make_name_value (attributes [1].name, work_area, result);
      ELSE
        clp$make_name_value ('NONE', work_area, result);
      IFEND;

    = clc$utility_online_manual =
      IF (attributes [1].online_manual_name <> osc$null_name) AND utility_active THEN
        clp$make_name_value (attributes [1].online_manual_name, work_area, result);
      ELSE
        clp$make_name_value ('NONE', work_area, result);
      IFEND;

    = clc$utility_prompt =
      IF utility_active THEN
        clp$make_string_value (attributes [1].prompt.value (1, attributes [1].prompt.size),
              work_area, result);
      ELSE
        clp$make_string_value ('', work_area, result);
      IFEND;

    = clc$utility_subcmnd_log_enabled =
      IF utility_active THEN
        clp$make_boolean_value (attributes [1].subcommand_logging_enabled, clc$true_false_boolean, work_area,
              result);
      ELSE
        clp$make_boolean_value (TRUE, clc$true_false_boolean, work_area, result);
      IFEND;

    CASEND;

  PROCEND clp$$utility;
?? TITLE := 'clp$_change_utility_attributes', EJECT ??

  PROCEDURE [XDCL] clp$_change_utility_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$chaua) change_utility_attributes, change_utility_attribute, chaua (
{   utility, u: name = $required
{   enable_subcommand_logging, esl: (BY_NAME) boolean = $optional
{   interactive_include_processor, iip: (BY_NAME) any of
{       key
{         none
{       keyend
{       name
{     anyend = $optional
{   line_preprocessor, lp: (BY_NAME) any of
{       key
{         none
{       keyend
{       name
{     anyend = $optional
{   online_manual, om: (BY_NAME) any of
{       key
{         none
{       keyend
{       name
{     anyend = $optional
{   prompt, p: (BY_NAME) string 0..27 = $optional
{   tables, table, t: (BY_NAME) file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 16] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: 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$name_type_qualifier,
        recend,
      recend,
      type4: 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$name_type_qualifier,
        recend,
      recend,
      type5: 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$name_type_qualifier,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 1, 25, 14, 16, 6, 424],
    clc$command, 16, 8, 1, 0, 0, 0, 8, 'OSM$CHAUA'], [
    ['ENABLE_SUBCOMMAND_LOGGING      ',clc$nominal_entry, 2],
    ['ESL                            ',clc$abbreviation_entry, 2],
    ['IIP                            ',clc$abbreviation_entry, 3],
    ['INTERACTIVE_INCLUDE_PROCESSOR  ',clc$nominal_entry, 3],
    ['LINE_PREPROCESSOR              ',clc$nominal_entry, 4],
    ['LP                             ',clc$abbreviation_entry, 4],
    ['OM                             ',clc$abbreviation_entry, 5],
    ['ONLINE_MANUAL                  ',clc$nominal_entry, 5],
    ['P                              ',clc$abbreviation_entry, 6],
    ['PROMPT                         ',clc$nominal_entry, 6],
    ['STATUS                         ',clc$nominal_entry, 8],
    ['T                              ',clc$abbreviation_entry, 7],
    ['TABLE                          ',clc$alias_entry, 7],
    ['TABLES                         ',clc$nominal_entry, 7],
    ['U                              ',clc$abbreviation_entry, 1],
    ['UTILITY                        ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 5
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 7
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 8
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$boolean_type]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 6
    [[1, 0, clc$string_type], [0, 27, FALSE]],
{ PARAMETER 7
    [[1, 0, clc$file_type]],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$utility = 1,
      p$enable_subcommand_logging = 2,
      p$interactive_include_processor = 3,
      p$line_preprocessor = 4,
      p$online_manual = 5,
      p$prompt = 6,
      p$tables = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;


    VAR
      attribute_ptr: ^SEQ (REP max_utility_attributes of clt$utility_attribute),
      change_utility_name: ost$name,
      command_sequence_pointer: ^SEQ ( * ),
      command_table: ^clt$command_table,
      delete_segment_status: ost$status,
      function_sequence_pointer: ^SEQ ( * ),
      function_table: ^clt$function_processor_table,
      parameter_count: 0 .. 6,
      segment_pointer: amt$segment_pointer,
      table_file_name: ^fst$file_reference,
      utility_command_attribute: ^array [1 .. * ] of clt$utility_attribute;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      IF command_sequence_pointer <> NIL THEN
        segment_pointer.sequence_pointer := command_sequence_pointer;
        mmp$delete_scratch_segment (segment_pointer, handler_status);
      IFEND;

      IF function_sequence_pointer <> NIL THEN
        segment_pointer.sequence_pointer := function_sequence_pointer;
        mmp$delete_scratch_segment (segment_pointer, handler_status);
      IFEND;

      handler_status.normal := TRUE;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    command_sequence_pointer := NIL;
    #SPOIL (command_sequence_pointer);
    function_sequence_pointer := NIL;
    #SPOIL (function_sequence_pointer);
    parameter_count := 0;

    change_utility_name := pvt [p$utility].value^.name_value;

    PUSH attribute_ptr;
    RESET attribute_ptr;
    NEXT utility_command_attribute: [1 .. 6] IN attribute_ptr;

    IF pvt [p$enable_subcommand_logging].specified THEN
      parameter_count := parameter_count + 1;
      utility_command_attribute^ [parameter_count].key := clc$utility_subcmnd_log_enabled;
      utility_command_attribute^ [parameter_count].subcommand_logging_enabled :=
            pvt [p$enable_subcommand_logging].value^.boolean_value.value;
    IFEND;

    IF pvt [p$interactive_include_processor].specified THEN
      parameter_count := parameter_count + 1;
      utility_command_attribute^ [parameter_count].key := clc$utility_interactive_include;
      IF pvt [p$interactive_include_processor].value^.kind = clc$keyword THEN
        utility_command_attribute^ [parameter_count].interactive_include_processor.call_method :=
              clc$unspecified_call;
      ELSE
        osp$set_status_abnormal ('CL', cle$not_yet_implemented, 'interactive_include_processor', status);
        RETURN;
        utility_command_attribute^ [parameter_count].interactive_include_processor.call_method :=
              clc$proc_call;
        utility_command_attribute^ [parameter_count].interactive_include_processor.command_name :=
              pvt [p$interactive_include_processor].value^.name_value;
      IFEND;
    IFEND;

    IF pvt [p$line_preprocessor].specified THEN
      parameter_count := parameter_count + 1;
      utility_command_attribute^ [parameter_count].key := clc$utility_line_preprocessor;
      IF pvt [p$line_preprocessor].value^.kind = clc$keyword THEN
        utility_command_attribute^ [parameter_count].line_preprocessor.call_method := clc$unspecified_call;
      ELSE
        osp$set_status_abnormal ('CL', cle$not_yet_implemented, 'line_preprocessor', status);
        RETURN;
        utility_command_attribute^ [parameter_count].line_preprocessor.call_method := clc$proc_call;
        utility_command_attribute^ [parameter_count].line_preprocessor.command_name :=
              pvt [p$line_preprocessor].value^.name_value;
      IFEND;
    IFEND;

    IF pvt [p$online_manual].specified THEN
      parameter_count := parameter_count + 1;
      utility_command_attribute^ [parameter_count].key := clc$utility_online_manual;
      IF pvt [p$online_manual].value^.kind = clc$keyword THEN
        utility_command_attribute^ [parameter_count].online_manual_name := osc$null_name;
      ELSE
        utility_command_attribute^ [parameter_count].online_manual_name :=
              pvt [p$online_manual].value^.name_value;
      IFEND;
    IFEND;

    IF pvt [p$prompt].specified THEN
      parameter_count := parameter_count + 1;
      utility_command_attribute^ [parameter_count].key := clc$utility_prompt;
      utility_command_attribute^ [parameter_count].prompt.value := pvt [p$prompt].value^.string_value^;
      utility_command_attribute^ [parameter_count].prompt.size :=
            STRLENGTH (pvt [p$prompt].value^.string_value^);
    IFEND;

  /change_user_utility/
    BEGIN
      IF pvt [p$tables].specified THEN
        osp$establish_block_exit_hndlr (^abort_handler);

        build_tables (pvt [p$tables].value^.file_value^, command_sequence_pointer, function_sequence_pointer,
              command_table, function_table, status);
        IF NOT status.normal THEN
          EXIT /change_user_utility/;
        IFEND;

        IF command_sequence_pointer <> NIL THEN
          parameter_count := parameter_count + 1;
          utility_command_attribute^ [parameter_count].key := clc$utility_command_table;
          utility_command_attribute^ [parameter_count].command_table := command_table;
        IFEND;
        IF function_sequence_pointer <> NIL THEN
          parameter_count := parameter_count + 1;
          utility_command_attribute^ [parameter_count].key := clc$utility_function_proc_table;
          utility_command_attribute^ [parameter_count].function_processor_table := function_table;
        IFEND;
      IFEND;

      IF parameter_count = 0 THEN
        EXIT /change_user_utility/;
      IFEND;

      RESET attribute_ptr;
      NEXT utility_command_attribute: [1 .. parameter_count] IN attribute_ptr;

      clp$change_utility_environment (change_utility_name, TRUE, utility_command_attribute^, status);
      IF NOT status.normal THEN
        EXIT /change_user_utility/;
      IFEND;
    END /change_user_utility/;

    IF pvt [p$tables].specified THEN
      IF command_sequence_pointer <> NIL THEN
        segment_pointer.sequence_pointer := command_sequence_pointer;
        mmp$delete_scratch_segment (segment_pointer, delete_segment_status);
        IF (NOT delete_segment_status.normal) AND status.normal THEN
          status := delete_segment_status;
        IFEND;
        command_sequence_pointer := NIL;
        #SPOIL (command_sequence_pointer);
      IFEND;

      IF function_sequence_pointer <> NIL THEN
        segment_pointer.sequence_pointer := function_sequence_pointer;
        mmp$delete_scratch_segment (segment_pointer, delete_segment_status);
        IF (NOT delete_segment_status.normal) AND status.normal THEN
          status := delete_segment_status;
        IFEND;
        function_sequence_pointer := NIL;
        #SPOIL (function_sequence_pointer);
      IFEND;

      osp$disestablish_cond_handler;
    IFEND;

  PROCEND clp$_change_utility_attributes;

MODEND clm$utility_commands;
*DECK DECK=CLM$VARIABLE_ACCESS_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Variable Access Manager' ??
MODULE clm$variable_access_manager;

{
{ PURPOSE:
{   This module contains the commands that declare and remove command language variables, as well as
{   requests that read and initiate the writing of such variables.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc cle$ecc_parsing
*copyc cle$ecc_variable
*IF $true(osv$unix)
*copyc cle$not_supported
*IFEND
*copyc cle$unknown_variable
*copyc cle$work_area_overflow
*copyc clk$change_variable
*copyc clk$create_environment_variable
*copyc clk$create_procedure_variable
*copyc clk$declare_variable
*copyc clk$get_variable
*copyc clk$read_variable
*copyc clk$write_variable
*copyc clt$environment_variable_scope
*copyc clt$procedure_variable_scope
*copyc clt$variable_class
*copyc clt$variable_value_description
?? POP ??
*IF $true(osv$unix)
*copyc clp_getenv
*IFEND
*IF NOT $true(osv$unix)
*copyc clp$access_param_variable
*copyc clp$access_variable
*copyc clp$add_to_defer_list
*IFEND
*copyc clp$append_status_parse_state
*IF NOT $true(osv$unix)
*copyc clp$change_variable_value
*copyc clp$check_name_for_boolean
*copyc clp$compute_variable_name_hash
*copyc clp$convert_integer_to_string
*copyc clp$convert_int_value_to_ext
*copyc clp$convert_type_desc_to_spec
*copyc clp$convert_type_spec_to_desc
*copyc clp$convert_value_to_var_value
*copyc clp$convert_var_value_to_value
*copyc clp$copy_data_value
*copyc clp$create_var_from_conversion
*copyc clp$create_var_from_type_spec
*copyc clp$delete_from_defer_list
*copyc clp$derive_type_desc_from_value
*ELSE
*copyc clt$access_variable_requests
*copyc clt$variable_information
*IFEND
*copyc clp$evaluate_expression
*copyc clp$evaluate_function
*copyc clp$evaluate_parameters
*IF NOT $true(osv$unix)
*copyc clp$evaluate_read_data_value
*copyc clp$evaluate_unqual_union_expr
*IFEND
*copyc clp$find_current_block
*IF NOT $true(osv$unix)
*copyc clp$find_variable_access
*copyc clp$find_first_var_block
*copyc clp$find_next_var_block
*copyc clp$get_qualified_type_desc
*IFEND
*copyc clp$get_read_value_qualifiers
*IF NOT $true(osv$unix)
*copyc clp$get_write_value_qualifiers
*IFEND
*copyc clp$get_work_area
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*IF NOT $true(osv$unix)
*copyc clp$internal_delete_variable
*IFEND
*copyc clp$internal_evaluate_expr
*copyc clp$make_boolean_value
*copyc clp$make_deferred_value
*copyc clp$make_integer_value
*copyc clp$make_string_value
*copyc clp$make_unspecified_value
*copyc clp$obtain_variable_value
*IF NOT $true(osv$unix)
*copyc clp$read_qualified_data_value
*IFEND
*copyc clp$scan_lexical_unit
*copyc clp$scan_non_space_lexical_unit
*copyc clp$scan_any_lexical_unit
*IF NOT $true(osv$unix)
*copyc clp$search_parameter_names
*IFEND
*copyc clp$trimmed_string_size
*copyc clp$validate_name
*copyc clv$type_kind_names
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osv$lower_to_upper

*IF NOT $true(osv$unix)
?? TITLE := 'clp$_create_default_variable', EJECT ??

  PROCEDURE [XDCL] clp$_create_default_variable
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (osm$credv) create_default_variable, credv (
{    name, n: data_name = $required
{    default, d: string = $required
{    scope, s: (by_name) key
{      (environment, e),
{      (job, j),
{      (task, t),
{      (utility, u),
{    keyend = job
{    status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 8] of clt$keyword_specification,
          default_value: string (3),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 26, 8, 55, 37, 863], clc$command, 7, 4, 2, 0, 0, 0, 4, 'OSM$CREDV'],
            [['D                              ', clc$abbreviation_entry, 2],
            ['DEFAULT                        ', clc$nominal_entry, 2],
            ['N                              ', clc$abbreviation_entry, 1],
            ['NAME                           ', clc$nominal_entry, 1],
            ['S                              ', clc$abbreviation_entry, 3],
            ['SCOPE                          ', clc$nominal_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$required_parameter, 0, 0],

{ PARAMETER 3

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
            clc$optional_default_parameter, 0, 3],

{ PARAMETER 4

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$data_name_type]],

{ PARAMETER 2

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],

{ PARAMETER 3

      [[1, 0, clc$keyword_type], [8], [['E                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['ENVIRONMENT                    ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['J                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['JOB                            ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['T                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['TASK                           ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['UTILITY                        ', clc$nominal_entry,
            clc$normal_usage_entry, 4]], 'job'],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$name = 1,
      p$default = 2,
      p$scope = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

{  TYPE
{    string = string
{  TYPEND

?? PUSH (LISTEXT := ON) ??

    VAR
      type_specification: [STATIC, READ, cls$declaration_section] record
        header: clt$type_specification_header,
        name: string (6),
        qualifier: clt$string_type_qualifier,
      recend := [[1, 6, clc$string_type], 'STRING', [0, clc$max_string_size, FALSE]];

?? POP ??


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_default_or_file_variable (pvt [p$name].value^.data_name_value, pvt [p$scope].value^.
          keyword_value, #SEQ (type_specification), pvt [p$default].value, status);

  PROCEND clp$_create_default_variable;
?? TITLE := 'clp$_create_file_variable', EJECT ??

  PROCEDURE [XDCL] clp$_create_file_variable
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (osm$crefv) create_file_variable, crefv (
{    name, n: data_name = $required
{    file, f: file = $required
{    scope, s: (by_name) key
{      (environment, e),
{      (job, j),
{      (task, t),
{      (utility, u),
{    keyend = job
{    status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 8] of clt$keyword_specification,
          default_value: string (3),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 26, 8, 55, 56, 521], clc$command, 7, 4, 2, 0, 0, 0, 4, 'OSM$CREFV'],
            [['F                              ', clc$abbreviation_entry, 2],
            ['FILE                           ', clc$nominal_entry, 2],
            ['N                              ', clc$abbreviation_entry, 1],
            ['NAME                           ', clc$nominal_entry, 1],
            ['S                              ', clc$abbreviation_entry, 3],
            ['SCOPE                          ', clc$nominal_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 3

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
            clc$optional_default_parameter, 0, 3],

{ PARAMETER 4

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$data_name_type]],

{ PARAMETER 2

      [[1, 0, clc$file_type]],

{ PARAMETER 3

      [[1, 0, clc$keyword_type], [8], [['E                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['ENVIRONMENT                    ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['J                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['JOB                            ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['T                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['TASK                           ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['UTILITY                        ', clc$nominal_entry,
            clc$normal_usage_entry, 4]], 'job'],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$name = 1,
      p$file = 2,
      p$scope = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

{  TYPE
{    file = file
{  TYPEND

?? PUSH (LISTEXT := ON) ??

    VAR
      type_specification: [STATIC, READ, cls$declaration_section] record
        header: clt$type_specification_header,
        name: string (4),
      recend := [[1, 4, clc$file_type], 'FILE'];

?? POP ??


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_default_or_file_variable (pvt [p$name].value^.data_name_value, pvt [p$scope].value^.
          keyword_value, #SEQ (type_specification), pvt [p$file].value, status);

  PROCEND clp$_create_file_variable;
?? TITLE := 'clp$_create_variable', EJECT ??

  PROCEDURE [XDCL] clp$_create_variable
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$crev) create_variables, create_variable, crev (
{   names, name, n: any of
{       data_name
{       list of data_name
{     anyend = $required
{   kind, k: any of
{       key
{         integer, boolean, real, status, string
{       keyend
{       record
{         string_kind: key
{           string
{         keyend
{         maximum_string_size: integer 0..clc$max_string_size
{       recend
{     anyend = integer
{   dimension, d: range of integer clc$min_variable_dimension..clc$max_variable_dimension = $optional
{   value, v: any = $optional
{   scope, s: any of
{       key
{         local, xdcl, xref, job
{       keyend
{       data_name
{     anyend = local
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 12] of clt$pdt_parameter_name,
        parameters: array [1 .. 6] 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,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$list_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
        type2: 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 .. 5] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$record_type_qualifier,
            field_spec_1: clt$field_specification,
            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,
            field_spec_2: clt$field_specification,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
          default_value: string (7),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$range_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$union_type_qualifier,
        recend,
        type5: 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 .. 4] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
          default_value: string (5),
        recend,
        type6: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 16, 14, 49, 32, 581], clc$command, 12, 6, 1, 0, 0, 0, 6, 'OSM$CREV'],
            [['D                              ', clc$abbreviation_entry, 3],
            ['DIMENSION                      ', clc$nominal_entry, 3],
            ['K                              ', clc$abbreviation_entry, 2],
            ['KIND                           ', clc$nominal_entry, 2],
            ['N                              ', clc$abbreviation_entry, 1],
            ['NAME                           ', clc$alias_entry, 1],
            ['NAMES                          ', clc$nominal_entry, 1],
            ['S                              ', clc$abbreviation_entry, 5],
            ['SCOPE                          ', clc$nominal_entry, 5],
            ['STATUS                         ', clc$nominal_entry, 6],
            ['V                              ', clc$abbreviation_entry, 4],
            ['VALUE                          ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 42, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 355, clc$optional_default_parameter, 0, 7],

{ PARAMETER 3

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 27, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 12, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 178, clc$optional_default_parameter, 0, 5],

{ PARAMETER 6

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$data_name_type, clc$list_type], FALSE, 2], 3,
            [[1, 0, clc$data_name_type]], 19, [[1, 0, clc$list_type],
            [3, 1, clc$max_list_size, FALSE], [[1, 0, clc$data_name_type]]]],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$record_type], FALSE, 2], 192,
            [[1, 0, clc$keyword_type], [5], [['BOOLEAN                        ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['INTEGER                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['REAL                           ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['STATUS                         ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['STRING                         ', clc$nominal_entry,
            clc$normal_usage_entry, 5]]], 143, [[1, 0, clc$record_type], [2],
            ['STRING_KIND                    ', clc$required_field, 44],
            [[1, 0, clc$keyword_type], [1], [['STRING                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], ['MAXIMUM_STRING_SIZE            ', clc$required_field, 20],
            [[1, 0, clc$integer_type], [0, clc$max_string_size, 10]]], 'integer'],

{ PARAMETER 3

      [[1, 0, clc$range_type], [20], [[1, 0, clc$integer_type],
            [clc$min_variable_dimension, clc$max_variable_dimension, 10]]],

{ PARAMETER 4

      [[1, 0, clc$union_type], [-$clt$type_kinds [], FALSE, 0]],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$data_name_type, clc$keyword_type], FALSE, 2], 155,
            [[1, 0, clc$keyword_type], [4], [['JOB                            ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['LOCAL                          ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['XDCL                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['XREF                           ', clc$nominal_entry,
            clc$normal_usage_entry, 3]]], 3, [[1, 0, clc$data_name_type]], 'local'],

{ PARAMETER 6

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$names = 1,
      p$kind = 2,
      p$dimension = 3,
      p$value = 4,
      p$scope = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      create_array: boolean,
      ignore_var_ref: clt$variable_reference,
      index: integer,
      initial_value: ^clt$data_value,
      kind: clt$variable_kinds,
      list_value: ^clt$data_value,
      lower_bound: clt$variable_dimension,
      max_string_size: clt$string_size,
      name: ost$name,
      scope: clt$variable_scope,
      upper_bound: clt$variable_dimension,
      work_area: ^clt$work_area,
      work_area_ptr: ^^clt$work_area;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    clp$get_work_area (#RING (^work_area_ptr), work_area_ptr, status);
*ELSE
    clp$get_work_area (osc$user_ring, work_area_ptr, status);
*IFEND
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    work_area := work_area_ptr^;

    IF pvt [p$names].value^.kind = clc$list THEN
      list_value := pvt [p$names].value;
    ELSE
      PUSH list_value;
      list_value^.kind := clc$list;
      list_value^.element_value := pvt [p$names].value;
      list_value^.link := NIL;
      list_value^.generated_via_list_rest := FALSE;
    IFEND;

    IF pvt [p$kind].value^.kind = clc$keyword THEN
      max_string_size := 1;
      IF pvt [p$kind].value^.keyword_value = 'BOOLEAN' THEN
        kind := clc$boolean_value;
      ELSEIF pvt [p$kind].value^.keyword_value = 'INTEGER' THEN
        kind := clc$integer_value;
      ELSEIF pvt [p$kind].value^.keyword_value = 'REAL' THEN
        kind := clc$real_value;
      ELSEIF pvt [p$kind].value^.keyword_value = 'STATUS' THEN
        kind := clc$status_value;
      ELSE

{ Can only be STRING.

        kind := clc$string_value;
        max_string_size := clc$max_string_size;
      IFEND;
    ELSE

{ Can only be STRING with a specified string size.

      kind := clc$string_value;
      max_string_size := pvt [p$kind].value^.field_values^ [2].value^.integer_value.value;
      IF max_string_size = osc$max_string_size THEN
        max_string_size := clc$max_string_size;
      IFEND;
    IFEND;

    create_array := pvt [p$dimension].specified;
    IF NOT create_array THEN
      lower_bound := 1;
      upper_bound := 1;
    ELSE
      upper_bound := pvt [p$dimension].value^.high_value^.integer_value.value;
      IF pvt [p$dimension].value^.low_value = pvt [p$dimension].value^.high_value THEN
        lower_bound := 1;
      ELSE
        lower_bound := pvt [p$dimension].value^.low_value^.integer_value.value;
      IFEND;
      IF (lower_bound > upper_bound) THEN
        osp$set_status_abnormal ('CL', cle$improper_array_bounds, list_value^.element_value^.data_name_value,
              status);
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$scope].value^.kind = clc$keyword THEN
      IF pvt [p$scope].value^.keyword_value = 'JOB' THEN
        scope.kind := clc$job_variable;
      ELSEIF pvt [p$scope].value^.keyword_value = 'LOCAL' THEN
        scope.kind := clc$local_variable;
      ELSEIF pvt [p$scope].value^.keyword_value = 'XDCL' THEN
        scope.kind := clc$xdcl_variable;
      ELSE

{ Can only be XREF.

        scope.kind := clc$xref_variable;
      IFEND;
    ELSE

{ Can only be UTILITY with a specified utility name.

      scope.kind := clc$utility_variable;
      scope.utility_name := pvt [p$scope].value^.data_name_value;
    IFEND;

    IF pvt [p$value].specified THEN
      CASE pvt [p$value].value^.kind OF
      = clc$boolean, clc$integer, clc$real, clc$string, clc$status =
        IF NOT create_array THEN
          initial_value := pvt [p$value].value;
        ELSE
          NEXT initial_value IN work_area_ptr^;
          IF initial_value <> NIL THEN
            NEXT initial_value^.array_value: [lower_bound .. upper_bound] IN work_area_ptr^;
          IFEND;
          IF initial_value = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            RETURN;
          IFEND;

          initial_value^.kind := clc$array;
          FOR index := lower_bound TO upper_bound DO
            initial_value^.array_value^ [index] := pvt [p$value].value;
          FOREND;
        IFEND;
      ELSE
        osp$set_status_abnormal ('CL', cle$not_a_variable_kind, list_value^.element_value^.data_name_value,
              status);
        RETURN;
      CASEND;
    ELSE
      initial_value := NIL;
    IFEND;

    WHILE list_value <> NIL DO
      name := list_value^.element_value^.data_name_value;
      clp$create_var_from_conversion (name, kind, max_string_size, create_array, lower_bound, upper_bound,
            scope, initial_value, FALSE, work_area_ptr^, ignore_var_ref, status);
      IF NOT status.normal THEN
        work_area_ptr^ := work_area;
        RETURN;
      IFEND;
      list_value := list_value^.link;
    WHILEND;

    work_area_ptr^ := work_area;

  PROCEND clp$_create_variable;
?? TITLE := 'clp$_delete_variable', EJECT ??

  PROCEDURE [XDCL] clp$_delete_variable
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$delv) delete_variable, delete_variables, delv (
{   names, name, n: any of
{       data_name
{       list of data_name
{     anyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 4] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] 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,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$list_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 16, 14, 50, 26, 762], clc$command, 4, 2, 1, 0, 0, 0, 2, 'OSM$DELV'],
            [['N                              ', clc$abbreviation_entry, 1],
            ['NAME                           ', clc$alias_entry, 1],
            ['NAMES                          ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 2]], [

{ PARAMETER 1

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 42, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$data_name_type, clc$list_type], FALSE, 2], 3,
            [[1, 0, clc$data_name_type]], 19, [[1, 0, clc$list_type],
            [3, 1, clc$max_list_size, FALSE], [[1, 0, clc$data_name_type]]]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$names = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      list_value: ^clt$data_value,
      local_status: ost$status,
      name: ost$name;


    status.normal := TRUE;
    local_status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$names].value^.kind = clc$list THEN
      list_value := pvt [p$names].value;
    ELSE
      PUSH list_value;
      list_value^.kind := clc$list;
      list_value^.element_value := pvt [p$names].value;
      list_value^.link := NIL;
      list_value^.generated_via_list_rest := FALSE;
    IFEND;

    WHILE list_value <> NIL DO
      name := list_value^.element_value^.data_name_value;
      clp$internal_delete_variable (name, -$clt$internal_variable_classes [], status);
      IF NOT status.normal THEN
        IF status.condition <> cle$unknown_variable THEN
          RETURN;
        IFEND;
        IF local_status.normal THEN
          local_status := status;
        ELSE
          osp$append_status_parameter (' ', name, local_status);
        IFEND;
      IFEND;
      list_value := list_value^.link;
    WHILEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND clp$_delete_variable;
*IFEND
*IF $true(osv$unix)
?? TITLE := 'clp$$import', EJECT ??

  PROCEDURE [XDCL] clp$$import
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{   FUNCTION (osm$$import) $import (
{     variable: any of
{         string 1..31
{         name
{       anyend = $required
{     )



?? 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_v2,
        type_size_1: clt$type_specification_size,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
    recend := [
    [2,
    [91, 12, 9, 12, 20, 28, 0],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$UNIX_VARIABLE_VALUE'], [
    ['VARIABLE                       ',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, 42, clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[2, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    9, [[2, 0, clc$string_type], [1, 31, FALSE]],
    6, [[2, 0, clc$name_type], [1, osc$max_name_size]]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$variable = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      variable_length: ost_c_integer,
      variable_name: ost_c_name,
      variable_value: ost_c_fixed_string;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$variable].value^.kind = clc$string THEN
      variable_name := pvt [p$variable].value^.string_value^;
    ELSE { name }
      variable_name := pvt [p$variable].value^.name_value;
    IFEND;
    clp_getenv (variable_name, variable_value, variable_length);

    clp$make_string_value (variable_value (1, variable_length), work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

  PROCEND clp$$import;
*IFEND
*IF NOT $true(osv$unix)
?? TITLE := 'clp$$variable', EJECT ??

  PROCEDURE [XDCL] clp$$variable
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$variable) $variable (
{   variable: data_name = $required
{   attribute: key
{       defined
{       environment
{       initialized
{       local
{       nonlocal
{       read
{     hidden_key
{       declared
{       kind
{       lower_bound
{       upper_bound
{       string_size
{   keyend = $required
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 11] of clt$keyword_specification,
        recend,
      recend := [[1, [87, 11, 19, 15, 48, 41, 125], clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$VARIABLE'],
            [['ATTRIBUTE                      ', clc$nominal_entry, 2],
            ['VARIABLE                       ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [2, 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, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [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, 414, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$data_name_type]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [11], [['DECLARED                       ', clc$nominal_entry,
            clc$hidden_entry, 7], ['DEFINED                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['ENVIRONMENT                    ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['INITIALIZED                    ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['KIND                           ', clc$nominal_entry,
            clc$hidden_entry, 8], ['LOCAL                          ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['LOWER_BOUND                    ', clc$nominal_entry,
            clc$hidden_entry, 9], ['NONLOCAL                       ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['READ                           ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['STRING_SIZE                    ', clc$nominal_entry,
            clc$hidden_entry, 11], ['UPPER_BOUND                    ', clc$nominal_entry, clc$hidden_entry,
            10]]]];

?? POP ??

    CONST
      p$variable = 1,
      p$attribute = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      allowed_classes: clt$internal_variable_classes,
      associated_utility: boolean,
      block: ^clt$block,
      date_time_type_qualifier: ^clt$date_time_type_qualifier,
      hash: clt$variable_name_hash,
      hashed_name: clt$variable_name,
      inherited_allowed_classes: clt$internal_variable_classes,
      inherited_block: ^clt$block,
      i_value: ^clt$i_data_value,
      keyword: clt$keyword,
      local_block: boolean,
      local_for_declared_keyword: boolean,
      type_specification_area: ^clt$type_specification,
      type_specification_header: ^clt$type_specification_header,
      variable_name: clt$variable_name,
      variable_access_info: ^clt$variable_access_info;

?? NEWTITLE := 'find_variable', EJECT ??

    PROCEDURE [INLINE] find_variable
      (    include_xdcl_variables: boolean);


      local_block := TRUE;
      local_for_declared_keyword := TRUE;
      allowed_classes := -$clt$internal_variable_classes [clc$param_variable];
      clp$find_first_var_block (allowed_classes, inherited_allowed_classes, inherited_block, block,
            associated_utility);
      WHILE block <> NIL DO
        IF (inherited_block <> NIL) AND (block^.kind IN $clt$block_kinds
              [clc$command_proc_block, clc$function_proc_block]) AND block^.parameters.evaluated THEN
          IF include_xdcl_variables THEN
            allowed_classes := $clt$internal_variable_classes
                  [clc$env_variable, clc$lib_variable, clc$pushed_variable, clc$xdcled_variable];
          ELSE
            allowed_classes := $clt$internal_variable_classes
                  [clc$env_variable, clc$lib_variable, clc$pushed_variable];
          IFEND;
        IFEND;

        IF associated_utility AND (block = inherited_block) THEN
          IF include_xdcl_variables THEN
            allowed_classes := $clt$internal_variable_classes
                  [clc$env_variable, clc$lib_variable, clc$pushed_variable, clc$xdcled_variable];
          ELSE
            allowed_classes := $clt$internal_variable_classes
                  [clc$env_variable, clc$lib_variable, clc$pushed_variable];
          IFEND;
        IFEND;
        clp$find_variable_access (variable_name, hashed_name, hash, allowed_classes, block,
              variable_access_info);
        IF variable_access_info <> NIL THEN
          RETURN;
        IFEND;
        IF (block^.kind IN $clt$block_kinds [clc$command_proc_block, clc$function_proc_block]) AND
              block^.parameters.evaluated THEN
          IF include_xdcl_variables THEN
            allowed_classes := $clt$internal_variable_classes
                  [clc$env_variable, clc$lib_variable, clc$pushed_variable, clc$xdcled_variable];
          ELSE
            allowed_classes := $clt$internal_variable_classes
                  [clc$env_variable, clc$lib_variable, clc$pushed_variable];
          IFEND;
        IFEND;
        IF (block^.static_link = NIL) AND (block^.kind <> clc$utility_block) THEN
          local_for_declared_keyword := FALSE;
        IFEND;
        clp$find_next_var_block (allowed_classes, inherited_allowed_classes, inherited_block, block,
              associated_utility);
        local_block := FALSE;
      WHILEND;

    PROCEND find_variable;
?? TITLE := 'process_declared_keyword', EJECT ??

    PROCEDURE [INLINE] process_declared_keyword;

      find_variable ({include_xdcled_variables =} TRUE);

      IF variable_access_info = NIL THEN
        clp$make_string_value ('UNKNOWN', work_area, result);
      ELSEIF local_for_declared_keyword THEN
        clp$make_string_value ('LOCAL', work_area, result);
      ELSE
        clp$make_string_value ('NONLOCAL', work_area, result);
      IFEND;

    PROCEND process_declared_keyword;
?? TITLE := 'process_environment_keyword', EJECT ??

    PROCEDURE process_environment_keyword;

      VAR
        environment_variable: boolean;


      find_variable ({include_xdcled_variables =} FALSE);
      environment_variable := (variable_access_info <> NIL) AND
            (variable_access_info^.class IN $clt$internal_variable_classes
            [clc$env_variable, clc$lib_variable, clc$pushed_variable]);
      clp$make_boolean_value (environment_variable, clc$true_false_boolean, work_area, result);

    PROCEND process_environment_keyword;
?? TITLE := 'process_initialized_keyword', EJECT ??

    PROCEDURE process_initialized_keyword;

      VAR
        initialized_variable: boolean;


      find_variable ({include_xdcled_variables =} TRUE);
      initialized_variable := (variable_access_info <> NIL) AND (variable_access_info^.descriptor <> NIL) AND
            (variable_access_info^.descriptor^.header.value <> NIL);
      clp$make_boolean_value (initialized_variable, clc$true_false_boolean, work_area, result);

    PROCEND process_initialized_keyword;
?? TITLE := 'process_kind_keyword', EJECT ??

    PROCEDURE process_kind_keyword;


      find_variable ({include_xdcled_variables =} TRUE);
      IF (variable_access_info <> NIL) AND (variable_access_info^.descriptor <> NIL) THEN
        type_specification_area := ^variable_access_info^.descriptor^.type_specification;
        RESET type_specification_area;
        NEXT type_specification_header IN type_specification_area;
        IF type_specification_header^.kind = clc$date_time_type THEN
          NEXT date_time_type_qualifier IN type_specification_area;
          IF date_time_type_qualifier^.date_and_or_time = $clt$date_and_or_time [clc$date, clc$time] THEN
            clp$make_string_value ('DATE_TIME', work_area, result);
          ELSEIF date_time_type_qualifier^.date_and_or_time = $clt$date_and_or_time [clc$date] THEN
            clp$make_string_value ('DATE', work_area, result);
          ELSE
            clp$make_string_value ('TIME', work_area, result);
          IFEND;
        ELSE
          clp$make_string_value (clv$type_kind_names [type_specification_header^.kind]
                (1, clp$trimmed_string_size (clv$type_kind_names [type_specification_header^.kind])),
                work_area, result);
        IFEND;
      ELSE
        osp$set_status_abnormal ('CL', cle$unknown_variable, variable_name, status);
      IFEND;

    PROCEND process_kind_keyword;
?? TITLE := 'process_local_keyword', EJECT ??

    PROCEDURE process_local_keyword;

      VAR
        local_variable: boolean;


      find_variable ({include_xdcled_variables =} FALSE);

      clp$make_boolean_value ((variable_access_info <> NIL) AND local_block, clc$true_false_boolean,
            work_area, result);

    PROCEND process_local_keyword;
?? TITLE := 'process_lower_bound_keyword', EJECT ??

    PROCEDURE process_lower_bound_keyword;

      VAR
        array_type_qualifier: ^clt$array_type_qualifier,
        lower_bound: clt$array_bound;


      find_variable ({include_xdcled_variables =} TRUE);
      IF (variable_access_info <> NIL) AND (variable_access_info^.descriptor <> NIL) THEN
        type_specification_area := ^variable_access_info^.descriptor^.type_specification;
        RESET type_specification_area;
        NEXT type_specification_header IN type_specification_area;
        lower_bound := 1;
        IF type_specification_header^.kind = clc$array_type THEN
          NEXT array_type_qualifier IN type_specification_area;
          IF array_type_qualifier^.array_bounds_defined THEN
            lower_bound := array_type_qualifier^.bounds.lower;
          IFEND;
        IFEND;
        clp$make_integer_value (lower_bound, 10, FALSE, work_area, result);
      ELSE
        osp$set_status_abnormal ('CL', cle$unknown_variable, variable_name, status);
      IFEND;

    PROCEND process_lower_bound_keyword;
?? TITLE := 'process_nonlocal_keyword', EJECT ??

    PROCEDURE process_nonlocal_keyword;


      find_variable ({include_xdcled_variables =} TRUE);

      clp$make_boolean_value ((variable_access_info <> NIL) AND (NOT local_block), clc$true_false_boolean,
            work_area, result);

    PROCEND process_nonlocal_keyword;
?? TITLE := 'process_read_keyword', EJECT ??

    PROCEDURE process_read_keyword;


      find_variable ({include_xdcled_variables =} TRUE);

      clp$make_boolean_value ((variable_access_info <> NIL) AND
            (variable_access_info^.access_mode = clc$read_only), clc$true_false_boolean, work_area, result);

    PROCEND process_read_keyword;
?? TITLE := 'process_string_size_keyword', EJECT ??

    PROCEDURE process_string_size_keyword;

      VAR
        string_type_qualifier: ^clt$string_type_qualifier;


      find_variable ({include_xdcled_variables =} TRUE);
      IF (variable_access_info <> NIL) AND (variable_access_info^.descriptor <> NIL) THEN
        type_specification_area := ^variable_access_info^.descriptor^.type_specification;
        RESET type_specification_area;
        NEXT type_specification_header IN type_specification_area;
        IF type_specification_header^.kind <> clc$string_type THEN
          osp$set_status_abnormal ('CL', cle$undefined_var_attribute, keyword, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, variable_name, status);
        ELSE
          NEXT string_type_qualifier IN type_specification_area;
          clp$make_integer_value (string_type_qualifier^.max_string_size, 10, FALSE, work_area, result);
        IFEND;
      ELSE
        osp$set_status_abnormal ('CL', cle$unknown_variable, variable_name, status);
      IFEND;

    PROCEND process_string_size_keyword;
?? TITLE := 'process_upper_bound_keyword', EJECT ??

    PROCEDURE process_upper_bound_keyword;

      VAR
        array_type_qualifier: ^clt$array_type_qualifier,
        upper_bound: clt$array_bound;


      find_variable ({include_xdcled_variables =} TRUE);
      IF (variable_access_info <> NIL) AND (variable_access_info^.descriptor <> NIL) THEN
        type_specification_area := ^variable_access_info^.descriptor^.type_specification;
        RESET type_specification_area;
        NEXT type_specification_header IN type_specification_area;
        upper_bound := 1;
        IF type_specification_header^.kind = clc$array_type THEN
          NEXT array_type_qualifier IN type_specification_area;
          IF array_type_qualifier^.array_bounds_defined THEN
            upper_bound := array_type_qualifier^.bounds.upper;
          IFEND;
        IFEND;
        clp$make_integer_value (upper_bound, 10, FALSE, work_area, result);
      ELSE
        osp$set_status_abnormal ('CL', cle$unknown_variable, variable_name, status);
      IFEND;

    PROCEND process_upper_bound_keyword;
?? OLDTITLE, EJECT ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    keyword := pvt [p$attribute].value^.keyword_value;
    variable_name := pvt [p$variable].value^.data_name_value;
    clp$compute_variable_name_hash (variable_name, hashed_name, hash);
    IF keyword = 'DEFINED' THEN
      find_variable ({include_xdcled_variables =} TRUE);
      clp$make_boolean_value ((variable_access_info <> NIL), clc$true_false_boolean, work_area, result);
    ELSEIF keyword = 'ENVIRONMENT' THEN
      process_environment_keyword;
    ELSEIF keyword = 'INITIALIZED' THEN
      process_initialized_keyword;
    ELSEIF keyword = 'LOCAL' THEN
      process_local_keyword;
    ELSEIF keyword = 'NONLOCAL' THEN
      process_nonlocal_keyword;
    ELSEIF keyword = 'READ' THEN
      process_read_keyword;

{ The following keywords are being retained for compatibility.

    ELSEIF keyword = 'DECLARED' THEN
      process_declared_keyword;
    ELSEIF keyword = 'KIND' THEN
      process_kind_keyword;
    ELSEIF keyword = 'LOWER_BOUND' THEN
      process_lower_bound_keyword;
    ELSEIF keyword = 'STRING_SIZE' THEN
      process_string_size_keyword;
    ELSEIF keyword = 'UPPER_BOUND' THEN
      process_upper_bound_keyword;
    IFEND;

    IF status.normal AND (result = NIL) THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND clp$$variable;
?? TITLE := 'clp$assignment_statement', EJECT ??

  PROCEDURE [XDCL] clp$assignment_statement
    (VAR left_parse {input, output} : clt$parse_state;
     VAR right_parse {input, output} : clt$parse_state;
     VAR work_area {input,output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      access_handle: clt$variable_access_handle,
      access_variable_requests: clt$access_variable_requests,
      bool: clt$boolean,
      complete_type_description: ^clt$type_description,
      data_value: ^clt$data_value,
      left_operand_name: ost$name,
      left_variable_name: clt$variable_name,
      name_is_boolean: boolean,
      qualified_type_description_copy: clt$type_description,
      result_type_description: ^clt$type_description,
      result_type_specification: ^clt$type_specification,
      right_operand_name: ost$name,
      variable_found: boolean,
      variable_information: clt$variable_information;

    status.normal := TRUE;

{ Evaluate left operand.

    IF left_parse.unit.kind <> clc$lex_name THEN
      osp$set_status_abnormal ('CL', cle$expecting_variable_name, '', status);
      RETURN;
    IFEND;
    #TRANSLATE (osv$lower_to_upper, left_parse.text^ (left_parse.unit_index, left_parse.unit.size),
          left_operand_name);
    clp$scan_any_lexical_unit (left_parse);

    access_variable_requests := $clt$access_variable_requests
          [clc$type_spec_if_defer_method, clc$return_type_description, clc$return_value_qualifiers];
    clp$evaluate_name_for_write (left_operand_name, access_variable_requests, FALSE, left_parse, work_area,
          left_variable_name, variable_information, access_handle, complete_type_description, variable_found,
          status);
    IF NOT status.normal THEN

{ Ignore the error if it is the result of attempting to write to a read only parameter variable,
{ not through $VALUE or $PARAMETER_VALUE, and it is an unqualified reference.  Then go ahead
{ and implicitly create the variable as it would if the parameter variable did not exist.

      IF (status.condition <> cle$cannot_assign_to_a_read_var) OR (left_operand_name (1) = '$') OR
            (variable_information.class <> clc$param_variable) OR
            (left_parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_left_parenthesis, clc$lex_dot]) THEN
        RETURN;
      IFEND;
      variable_found := FALSE;
      status.normal := TRUE;
    IFEND;

    IF left_parse.unit_is_space THEN
      clp$scan_non_space_lexical_unit (left_parse);
    IFEND;
    IF left_parse.unit_index <> left_parse.index_limit THEN
      osp$set_status_abnormal ('CL', cle$expecting_end_of_expression, '', status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, left_parse, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, ' for left side of assignment statement',
            status);
      RETURN;
    IFEND;

{ Evaluate right operand.

  /evaluate_value/
    BEGIN
      IF variable_found THEN
        IF variable_information.evaluation_method = clc$deferred_evaluation THEN
          clp$make_deferred_value (right_parse.text^ (right_parse.unit_index,
                right_parse.index_limit - right_parse.unit_index), variable_information.type_specification,
                work_area, data_value);
          IF data_value = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            RETURN;
          IFEND;
          EXIT /evaluate_value/;
        ELSE
          IF variable_information.type_description = NIL THEN

{ There are qualifiers in the left operand and an 'ANY' type was found in the evaluation of the
{ type description for that left operand.

            clp$evaluate_unqual_union_expr (work_area, right_parse, result_type_description, data_value,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSE

{
{ The variable_information.type_description for the text field of a status variable
{ resides in OSS$JOB_PAGED_LITERAL. Therefore you cannot change any fields within the
{ variable_information.type_description.
{

            qualified_type_description_copy := variable_information.type_description^;
            IF variable_information.type_description^.kind = clc$string_type THEN
              qualified_type_description_copy.min_string_size := 0;
              qualified_type_description_copy.max_string_size := clc$max_string_size;
            IFEND;

            clp$internal_evaluate_expr (right_parse, ^qualified_type_description_copy, work_area,
                  result_type_description, data_value, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

          IFEND;

          IF variable_information.value_qualifiers_present AND (data_value^.kind = clc$deferred) THEN
            osp$set_status_abnormal ('CL', cle$improper_use_of_defer_var, left_operand_name, status);
            RETURN;
          IFEND;
        IFEND;
      ELSE
        clp$evaluate_unqual_union_expr (work_area, right_parse, result_type_description, data_value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF right_parse.unit_is_space THEN
        clp$scan_non_space_lexical_unit (right_parse);
      IFEND;
      IF right_parse.unit_index <> right_parse.index_limit THEN
        osp$set_status_abnormal ('CL', cle$expecting_end_of_expression, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, right_parse, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              ' for right side of assignment statement', status);
        RETURN;
      IFEND;
    END /evaluate_value/;

    IF variable_found THEN
      clp$change_variable_value (left_variable_name, data_value, variable_information.value_qualifiers,
            complete_type_description, variable_information.type_description, access_handle, TRUE, work_area,
            status);
    ELSE
      IF result_type_description = NIL THEN
        NEXT result_type_description IN work_area;
        IF result_type_description = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          RETURN;
        IFEND;
        clp$derive_type_desc_from_value (data_value, work_area, result_type_description^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      clp$convert_type_desc_to_spec (result_type_description, work_area, result_type_specification, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$create_var_from_type_spec (left_variable_name, clc$local_scope, clc$read_write,
            clc$immediate_evaluation, result_type_specification, data_value, FALSE, work_area, status);
    IFEND;

  PROCEND clp$assignment_statement;
?? TITLE := 'clp$change_variable', EJECT ??
*copyc clh$change_variable

  PROCEDURE [XDCL, #GATE] clp$change_variable
    (    reference: clt$variable_ref_expression;
         value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      replacement_value: clt$variable_value_description,
      work_area: ^clt$work_area,
      work_area_ptr: ^^clt$work_area;


    #KEYPOINT (osk$entry, 0, clk$change_variable);

    status.normal := TRUE;

  /change_variable/
    BEGIN
*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^work_area_ptr), work_area_ptr, local_status);
*ELSE
      clp$get_work_area (osc$user_ring, work_area_ptr, local_status);
*IFEND
      IF NOT local_status.normal THEN
        EXIT /change_variable/;
      IFEND;
      work_area := work_area_ptr^;

      replacement_value.kind := clc$variable_data_value;
      replacement_value.data_value := value;

      clp$update_variable (^reference, replacement_value, work_area, local_status);
      work_area_ptr^ := work_area;

    END /change_variable/;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, clk$change_variable);

  PROCEND clp$change_variable;
?? TITLE := 'clp$create_environment_variable', EJECT ??
*copyc clh$create_environment_variable

  PROCEDURE [XDCL, #GATE] clp$create_environment_variable
    (    name: clt$variable_name_reference;
         scope: clt$environment_variable_scope;
         access_mode: clt$data_access_mode;
         evaluation_method: clt$expression_eval_method;
         type_specification: ^clt$type_specification;
         initial_value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      name_is_valid: boolean,
      validated_name: ost$name,
      value: ^clt$data_value,
      work_area: ^clt$work_area,
      work_area_ptr: ^^clt$work_area;


    #KEYPOINT (osk$entry, 0, clk$create_environment_variable);

    status.normal := TRUE;

  /create_environment_var/
    BEGIN

      clp$validate_name (name, validated_name, name_is_valid);
      IF NOT name_is_valid THEN
        osp$set_status_abnormal ('CL', cle$improper_variable_name, name, local_status);
        EXIT /create_environment_var/;
      IFEND;
      IF ((scope < LOWERVALUE (clt$environment_variable_scope)) OR
            (scope > UPPERVALUE (clt$environment_variable_scope))) THEN
        osp$set_status_abnormal ('CL', cle$bad_variable_scope, name, local_status);
        EXIT /create_environment_var/;
      IFEND;
      IF ((access_mode < LOWERVALUE (clt$data_access_mode)) OR
            (access_mode > UPPERVALUE (clt$data_access_mode))) THEN
        osp$set_status_abnormal ('CL', cle$bad_variable_access_mode, name, local_status);
        EXIT /create_environment_var/;
      IFEND;
      IF ((evaluation_method < LOWERVALUE (clt$expression_eval_method)) OR
            (evaluation_method > UPPERVALUE (clt$expression_eval_method))) THEN
        osp$set_status_abnormal ('CL', cle$bad_variable_eval_method, name, local_status);
        EXIT /create_environment_var/;
      IFEND;
      IF type_specification = NIL THEN
        osp$set_status_abnormal ('CL', cle$no_type_spec_specified, name, local_status);
        EXIT /create_environment_var/;
      IFEND;

*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^work_area_ptr), work_area_ptr, local_status);
*ELSE
      clp$get_work_area (osc$user_ring, work_area_ptr, local_status);
*IFEND
      IF NOT local_status.normal THEN
        EXIT /create_environment_var/;
      IFEND;
      work_area := work_area_ptr^;

      IF (initial_value <> NIL) AND (initial_value^.kind = clc$deferred) AND
            (evaluation_method = clc$immediate_evaluation) THEN
        clp$evaluate_expression (initial_value^.deferred_value^, initial_value^.deferred_type, work_area_ptr^,
              value, local_status);
        IF NOT local_status.normal THEN
          IF local_status.condition <> cle$work_area_overflow THEN
            osp$set_status_abnormal ('CL', cle$nonevaluable_deferred_value, name, local_status);
          IFEND;
          EXIT /create_environment_var/;
        IFEND;
      ELSE
        value := initial_value;
      IFEND;

      clp$create_var_from_type_spec (validated_name, scope, access_mode, evaluation_method,
            type_specification, value, FALSE, work_area_ptr^, local_status);

      work_area_ptr^ := work_area;

    END /create_environment_var/;
    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, clk$create_environment_variable);

  PROCEND clp$create_environment_variable;
?? TITLE := 'clp$create_procedure_variable', EJECT ??
*copyc clh$create_procedure_variable

  PROCEDURE [XDCL, #GATE] clp$create_procedure_variable
    (    name: clt$variable_name_reference;
         scope: clt$procedure_variable_scope;
         access_mode: clt$data_access_mode;
         evaluation_method: clt$expression_eval_method;
         type_specification: ^clt$type_specification;
         initial_value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      name_is_valid: boolean,
      validated_name: ost$name,
      value: ^clt$data_value,
      work_area: ^clt$work_area,
      work_area_ptr: ^^clt$work_area;


    #KEYPOINT (osk$entry, 0, clk$create_procedure_variable);

    status.normal := TRUE;

  /create_procedure_var/
    BEGIN

      clp$validate_name (name, validated_name, name_is_valid);
      IF NOT name_is_valid THEN
        osp$set_status_abnormal ('CL', cle$improper_variable_name, name, local_status);
        EXIT /create_procedure_var/;
      IFEND;
      IF ((scope < LOWERVALUE (clt$procedure_variable_scope)) OR
            (scope > UPPERVALUE (clt$procedure_variable_scope))) THEN
        osp$set_status_abnormal ('CL', cle$bad_variable_scope, name, local_status);
        EXIT /create_procedure_var/;
      IFEND;
      IF ((access_mode < LOWERVALUE (clt$data_access_mode)) OR
            (access_mode > UPPERVALUE (clt$data_access_mode))) THEN
        osp$set_status_abnormal ('CL', cle$bad_variable_access_mode, name, local_status);
        EXIT /create_procedure_var/;
      IFEND;
      IF ((evaluation_method < LOWERVALUE (clt$expression_eval_method)) OR
            (evaluation_method > UPPERVALUE (clt$expression_eval_method))) THEN
        osp$set_status_abnormal ('CL', cle$bad_variable_eval_method, name, local_status);
        EXIT /create_procedure_var/;
      IFEND;
      IF type_specification = NIL THEN
        osp$set_status_abnormal ('CL', cle$no_type_spec_specified, name, local_status);
        EXIT /create_procedure_var/;
      IFEND;
      IF (scope = clc$xref_scope) AND (initial_value <> NIL) THEN
        osp$set_status_abnormal ('CL', cle$xref_var_cannot_have_value, name, local_status);
        EXIT /create_procedure_var/;
      IFEND;

*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^work_area_ptr), work_area_ptr, local_status);
*ELSE
      clp$get_work_area (osc$user_ring, work_area_ptr, local_status);
*IFEND
      IF NOT local_status.normal THEN
        EXIT /create_procedure_var/;
      IFEND;
      work_area := work_area_ptr^;

      IF (initial_value <> NIL) AND (initial_value^.kind = clc$deferred) AND
            (evaluation_method = clc$immediate_evaluation) THEN
        clp$evaluate_expression (initial_value^.deferred_value^, initial_value^.deferred_type, work_area_ptr^,
              value, local_status);
        IF NOT local_status.normal THEN
          IF local_status.condition <> cle$work_area_overflow THEN
            osp$set_status_abnormal ('CL', cle$nonevaluable_deferred_value, name, local_status);
          IFEND;
          EXIT /create_procedure_var/;
        IFEND;
      ELSE
        value := initial_value;
      IFEND;

      clp$create_var_from_type_spec (validated_name, scope, access_mode, evaluation_method,
            type_specification, value, FALSE, work_area_ptr^, local_status);

      work_area_ptr^ := work_area;

    END /create_procedure_var/;
    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, clk$create_procedure_variable);

  PROCEND clp$create_procedure_variable;
?? TITLE := 'clp$create_variable', EJECT ??
*copyc clh$create_variable

  PROCEDURE [XDCL, #GATE] clp$create_variable
    (    name: string ( * );
         kind: clt$variable_kinds;
         max_string_size: ost$string_size;
         lower_bound: clt$variable_dimension;
         upper_bound: clt$variable_dimension;
         scope: clt$variable_scope;
     VAR variable: clt$variable_reference;
     VAR status: ost$status);

    VAR
      create_array: boolean,
      local_max_string_size: clt$string_size,
      local_status: ost$status,
      name_is_valid: boolean,
      validated_name: ost$name,
      work_area: ^clt$work_area,
      work_area_ptr: ^^clt$work_area;


    #KEYPOINT (osk$entry, 0, clk$declare_variable);

    status.normal := TRUE;
    local_status.normal := TRUE;

  /create_variable/
    BEGIN

      clp$validate_name (name, validated_name, name_is_valid);
      IF NOT name_is_valid THEN
        osp$set_status_abnormal ('CL', cle$improper_variable_name, name, local_status);
        EXIT /create_variable/;
      IFEND;
      IF ((kind < LOWERVALUE (clt$variable_kinds)) OR (kind > UPPERVALUE (clt$variable_kinds))) THEN
        osp$set_status_abnormal ('CL', cle$bad_variable_kind, name, local_status);
        EXIT /create_variable/;
      IFEND;
      IF ((scope.kind < LOWERVALUE (clt$variable_scope_kind)) OR
            (scope.kind > UPPERVALUE (clt$variable_scope_kind))) THEN
        osp$set_status_abnormal ('CL', cle$bad_variable_scope, name, local_status);
        EXIT /create_variable/;
      IFEND;
      local_max_string_size := max_string_size;
      IF (kind = clc$string_value) THEN
        IF ((max_string_size < 0) OR (max_string_size > osc$max_string_size)) THEN
          osp$set_status_abnormal ('CL', cle$bad_variable_string_size, name, local_status);
          EXIT /create_variable/;
        IFEND;
        IF max_string_size = osc$max_string_size THEN
          local_max_string_size := clc$max_string_size;
        IFEND;
      IFEND;
      IF (((lower_bound < clc$min_variable_dimension) OR (lower_bound > clc$max_variable_dimension)) OR
            ((upper_bound < clc$min_variable_dimension) OR (upper_bound > clc$max_variable_dimension)) OR
            ((lower_bound > upper_bound))) THEN
        osp$set_status_abnormal ('CL', cle$improper_array_bounds, name, local_status);
        EXIT /create_variable/;
      IFEND;

*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^work_area_ptr), work_area_ptr, local_status);
*ELSE
      clp$get_work_area (osc$user_ring, work_area_ptr, local_status);
*IFEND
      IF NOT local_status.normal THEN
        EXIT /create_variable/;
      IFEND;
      work_area := work_area_ptr^;

      create_array := (lower_bound <> upper_bound) OR ((lower_bound <> 0) AND (lower_bound <> 1));
      clp$create_var_from_conversion (validated_name, kind, local_max_string_size, create_array, lower_bound,
            upper_bound, scope, NIL, TRUE, work_area_ptr^, variable, local_status);

      work_area_ptr^ := work_area;

    END /create_variable/;
    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, clk$declare_variable);

  PROCEND clp$create_variable;
*IFEND
?? TITLE := 'clp$evaluate_name_for_read', EJECT ??

  PROCEDURE [XDCL] clp$evaluate_name_for_read
    (    name: clt$variable_name;
         context_type_description: ^clt$type_description;
         access_variable_requests: clt$access_variable_requests;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR variable_name: clt$variable_name;
     VAR variable_information: clt$variable_information;
     VAR value: ^clt$data_value;
     VAR found: boolean;
     VAR last_qualifier_is_field: boolean;
     VAR status: ost$status);

    VAR
      access_handle: clt$variable_access_handle,
      access_handle_ptr: ^clt$variable_access_handle,
      block: ^clt$block,
      deferred_value: ^clt$expression_text,
      function_qualifiers_present: boolean,
      i_value: ^clt$i_data_value,
      internal_value: ^clt$internal_data_value,
      kind: clt$value_qualifier_kind,
      local_variable_requests: clt$access_variable_requests,
      parse_value_qualifiers: ^clt$value_qualifiers,
      parse_value_qualifier_index: integer,
      result: clt$function_result,
      temporary_sequence: ^SEQ ( * ),
      variable_requests: clt$access_variable_requests;

*IF NOT $true(osv$unix)
?? NEWTITLE := 'process_name', EJECT ??

    PROCEDURE process_name;

      VAR
        hash: clt$variable_name_hash,
        hashed_name: clt$variable_name;


      clp$compute_variable_name_hash (name, hashed_name, hash);
      local_variable_requests := access_variable_requests +
            $clt$access_variable_requests [clc$value_info_if_defer_value] -
            $clt$access_variable_requests [clc$return_value_qualifiers];
      clp$access_variable (name, hashed_name, hash, TRUE, local_variable_requests, work_area,
            variable_information, access_handle, status);
      IF NOT (status.normal AND variable_information.access_info_found) THEN
        EXIT clp$evaluate_name_for_read;
      IFEND;
      access_handle_ptr := ^access_handle;

      found := TRUE;

      IF NOT variable_information.parameter_passed THEN
        clp$make_unspecified_value (work_area, value);
        IF value = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          EXIT clp$evaluate_name_for_read;
        IFEND;
        RETURN;
      IFEND;

      IF variable_information.has_no_internal_value THEN
        IF (variable_information.value_qualifiers_present OR
              (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_left_parenthesis, clc$lex_dot])) AND
              (NOT (clc$possible_file_reference IN variable_requests)) THEN
          osp$set_status_abnormal ('CL', cle$cannot_read_component, name, status);
          EXIT clp$evaluate_name_for_read;
        IFEND;
        access_handle_ptr := NIL;
        RETURN;
      IFEND;

      IF variable_information.internal_value <> NIL THEN
        clp$add_to_defer_list (name, status);
        IF NOT status.normal THEN
          EXIT clp$evaluate_name_for_read;
        IFEND;
        internal_value := variable_information.internal_value;
        i_value := #PTR (internal_value^.header.value, internal_value^);
        deferred_value := #PTR (i_value^.deferred_value, internal_value^);

{
{ Clp$evaluate_expression will return an error if the result value is NIL or unspecified.
{

        clp$evaluate_expression (deferred_value^, variable_information.type_specification, work_area, value,
              status);
        clp$delete_from_defer_list;
        IF NOT status.normal THEN
          IF (status.condition <> cle$work_area_overflow) AND
                (status.condition <> cle$recursive_deferred_variable) THEN
            osp$set_status_abnormal ('CL', cle$nonevaluable_deferred_value, name, status);
          IFEND;
          EXIT clp$evaluate_name_for_read;
        IFEND;
        variable_information.internal_value := NIL;
      IFEND;

    PROCEND process_name;
?? TITLE := 'process_parameter_name', EJECT ??

    PROCEDURE process_parameter_name;


      variable_requests := access_variable_requests + $clt$access_variable_requests
            [clc$convert_nil_value_to_unspec];

      variable_name := result.parameter_name;
      local_variable_requests := access_variable_requests +
            $clt$access_variable_requests [clc$value_info_if_defer_value] -
            $clt$access_variable_requests [clc$return_value_qualifiers];
      clp$access_param_variable (variable_name, local_variable_requests, work_area, variable_information,
            access_handle, status);
      IF NOT status.normal THEN
        EXIT clp$evaluate_name_for_read;
      IFEND;
      IF variable_information.access_info_found THEN
        access_handle_ptr := ^access_handle;
      ELSE
        initialize_variable_information (variable_information);
      IFEND;

      IF NOT (variable_information.access_info_found AND variable_information.parameter_passed) OR
            variable_information.has_no_internal_value THEN
        clp$make_unspecified_value (work_area, value);
        IF value = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          EXIT clp$evaluate_name_for_read;
        IFEND;
        RETURN;
      IFEND;

      IF variable_information.internal_value <> NIL THEN
        internal_value := variable_information.internal_value;
        i_value := #PTR (internal_value^.header.value, internal_value^);
        deferred_value := #PTR (i_value^.deferred_value, internal_value^);

{
{ Clp$evaluate_expression will return an error if the result value is NIL or unspecified.
{

        clp$evaluate_expression (deferred_value^, variable_information.type_specification, work_area, value,
              status);
        IF NOT status.normal THEN
          IF status.condition <> cle$work_area_overflow THEN
            osp$set_status_abnormal ('CL', cle$nonevaluable_deferred_value, name, status);
          IFEND;
          EXIT clp$evaluate_name_for_read;
        IFEND;
        variable_information.internal_value := NIL;
      IFEND;

    PROCEND process_parameter_name;
?? TITLE := 'process_variable_reference', EJECT ??

    PROCEDURE process_variable_reference;

      VAR
        lexical_units: ^clt$lexical_units,
        nested_parse: clt$parse_state;


      clp$identify_lexical_units (result.variable, work_area, lexical_units, status);
      IF NOT status.normal THEN
        EXIT clp$evaluate_name_for_read;
      IFEND;
      clp$initialize_parse_state (result.variable, lexical_units, nested_parse);
      clp$scan_non_space_lexical_unit (nested_parse);
      CASE nested_parse.unit.kind OF
      = clc$lex_name =
        ;
      = clc$lex_long_name =
        osp$set_status_abnormal ('CL', cle$name_too_long, nested_parse.
              text^ (nested_parse.unit_index, nested_parse.unit.size), status);
        EXIT clp$evaluate_name_for_read;
      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_variable_name, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, nested_parse, status);
        EXIT clp$evaluate_name_for_read;
      CASEND;

      #TRANSLATE (osv$lower_to_upper, nested_parse.text^ (nested_parse.unit_index, nested_parse.unit.size),
            variable_name);
      clp$scan_any_lexical_unit (nested_parse);

      local_variable_requests := variable_requests - $clt$access_variable_requests
            [clc$possible_file_reference];
      clp$evaluate_name_for_read (variable_name, context_type_description, local_variable_requests,
            nested_parse, work_area, variable_name, variable_information, value, found,
            last_qualifier_is_field, status);
      IF NOT status.normal THEN
        EXIT clp$evaluate_name_for_read;
      IFEND;
      IF NOT found THEN
        osp$set_status_abnormal ('CL', cle$unknown_variable, variable_name, status);
        EXIT clp$evaluate_name_for_read;
      IFEND;
      function_qualifiers_present := variable_information.value_qualifiers_present;

      IF nested_parse.unit_is_space THEN
        clp$scan_non_space_lexical_unit (nested_parse);
      IFEND;
      IF nested_parse.unit.kind <> clc$lex_end_of_line THEN
        osp$set_status_abnormal ('CL', cle$expecting_end_of_expression, variable_name, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, nested_parse, status);
        EXIT clp$evaluate_name_for_read;
      IFEND;

      IF value = NIL THEN
        IF (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_left_parenthesis, clc$lex_dot]) THEN
          osp$set_status_abnormal ('CL', cle$cannot_read_component, name, status);
        IFEND;
        EXIT clp$evaluate_name_for_read;
      IFEND;

    PROCEND process_variable_reference;
*IFEND
?? TITLE := 'process_value', EJECT ??

    PROCEDURE process_value;


      value := result.value;
      initialize_variable_information (variable_information);

      IF value = NIL THEN
        IF (parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_left_parenthesis, clc$lex_dot]) THEN
*IF NOT $true(osv$unix)
          osp$set_status_abnormal ('CL', cle$cannot_read_component, name, status);
*ELSE
          osp$set_status_abnormal ('CL', cle$not_supported, 'Variables are', status);
*IFEND
        IFEND;
        RETURN;
      IFEND;

    PROCEND process_value;
?? OLDTITLE, EJECT ??

{
{ The type description may not be found and therefore not returned even
{ though it was requested by the caller of this routine.
{ It is known that return_value_qualifiers is only set to TRUE when this
{ routine is called by clp$read_variable.
{


    status.normal := TRUE;
    variable_information.access_info_found := FALSE;
    found := FALSE;
    variable_name := name;
    value := NIL;
    internal_value := NIL;
    function_qualifiers_present := FALSE;
    parse_value_qualifiers := NIL;
    parse_value_qualifier_index := 0;
    access_handle_ptr := NIL;
    last_qualifier_is_field := FALSE;

    clp$find_current_block (block);
*IF NOT $true(osv$unix)
    IF (block^.kind = clc$sub_parameters_block) AND (NOT block^.lookup_functions_and_variables) THEN
      RETURN;
    IFEND;
*IFEND

    IF ($clt$access_variable_requests [clc$return_internal_value, clc$value_info_if_defer_value,
          clc$return_type_specification, clc$type_spec_if_defer_method,
          clc$convert_nil_value_to_unspec] * access_variable_requests) <> $clt$access_variable_requests
          [] THEN
*IF NOT $true(osv$unix)
      osp$set_status_abnormal ('CL', cle$improper_variable_requests, name, status);
*ELSE
      osp$set_status_abnormal ('CL', cle$not_supported, 'Variables are', status);
*IFEND
      RETURN;
    IFEND;

    variable_requests := access_variable_requests;

    IF name (1) = '$' THEN
      clp$evaluate_function (FALSE, name, context_type_description, parse, work_area, result, found, status);
      IF NOT (status.normal AND found) THEN
        IF found THEN
          initialize_variable_information (variable_information);
        IFEND;
        RETURN;
      IFEND;

      CASE result.kind OF

      = clc$fr_value =
        process_value;

*IF NOT $true(osv$unix)
      = clc$fr_parameter_name =

{ Result from $PARAMETER_VALUE function.

        process_parameter_name;

      = clc$fr_variable_reference =

{ Result from $VNAME function.

        process_variable_reference;
*IFEND

      ELSE

{ Should never get here.

        osp$set_status_abnormal ('CL', cle$bad_function_result, name, status);
        RETURN;
      CASEND;

*IF NOT $true(osv$unix)
    ELSE
      process_name;
*IFEND

    IFEND;

    IF parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_left_parenthesis, clc$lex_dot] THEN
      clp$get_read_value_qualifiers (name, parse, work_area, parse_value_qualifiers, status);
      IF NOT status.normal THEN
        EXIT clp$evaluate_name_for_read;
      IFEND;
    IFEND;

{
{ The value has already been obtained at this point in the following instances
{    (we would not make the call to clp$obtain_variable_value):
{    1. It is a function result other than $PARAMETER_VALUE and there are no qualifiers.
{    2. It is an unitialized value and there are no qualifiers.
{

    IF (access_handle_ptr <> NIL) OR (parse_value_qualifiers <> NIL) THEN

      IF variable_information.type_description = NIL THEN
        variable_requests := variable_requests - $clt$access_variable_requests [clc$return_type_description];
      IFEND;

{ Access_handler_ptr is NIL for all function results except $parameter_value(known parameter).
{ Otherwise access_handler_ptr is always NOT NIL.
{
{ Value is NOT NIL for function results other than $parameter_value(known parameter) or a
{ deferred value or a newly created 'unspecified' value.  Otherwise value is always NIL.
{

      clp$obtain_variable_value (variable_name, access_handle_ptr, variable_requests, work_area,
            variable_information.type_description, parse_value_qualifiers, parse_value_qualifier_index, value,
            status);
    IFEND;

    variable_information.value_qualifiers_present := (parse_value_qualifiers <> NIL) AND
          (parse_value_qualifier_index <> 1) OR function_qualifiers_present;

    IF parse_value_qualifiers <> NIL THEN
      kind := parse_value_qualifiers^ [UPPERBOUND (parse_value_qualifiers^)].kind;
      last_qualifier_is_field := (kind = clc$field_qualifier) OR (kind = clc$unspecified_field_qualifier) OR
            (kind = clc$invalid_field_qualifier);
    IFEND;

    IF parse_value_qualifier_index <> 0 THEN
      parse := parse_value_qualifiers^ [parse_value_qualifier_index].parse^;
    IFEND;

    IF (clc$return_value_qualifiers IN access_variable_requests) AND (parse_value_qualifier_index > 1) THEN
      temporary_sequence := #SEQ (parse_value_qualifiers);
      RESET temporary_sequence;
      NEXT variable_information.value_qualifiers: [1 .. parse_value_qualifier_index - 1] IN
            temporary_sequence;
    ELSE
      variable_information.value_qualifiers := NIL;
    IFEND;

  PROCEND clp$evaluate_name_for_read;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$evaluate_name_for_write', EJECT ??

  PROCEDURE [XDCL] clp$evaluate_name_for_write
    (    name: clt$variable_name;
         access_variable_requests: clt$access_variable_requests;
         evaluating_for_var_parameter: boolean;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR variable_name: clt$variable_name;
     VAR variable_information: clt$variable_information;
     VAR access_handle: clt$variable_access_handle;
     VAR complete_type_description: ^clt$type_description;
     VAR found: boolean;
     VAR status: ost$status);

    VAR
      all_value_qualifiers: ^clt$value_qualifiers,
      function_or_parameter_qual: ^clt$value_qualifiers,
      function_or_parameter_qual_size: integer,
      i: integer,
      result: clt$function_result,
      value_qualifiers_size: integer,
      variable_requests: clt$access_variable_requests;

?? NEWTITLE := 'process_name', EJECT ??

    PROCEDURE process_name;

      VAR
        hash: clt$variable_name_hash,
        hashed_name: clt$variable_name;


      clp$compute_variable_name_hash (name, hashed_name, hash);
      variable_requests := access_variable_requests + $clt$access_variable_requests
            [clc$return_type_description, clc$return_value_qualifiers];
      clp$access_variable (name, hashed_name, hash, TRUE, variable_requests, work_area, variable_information,
            access_handle, status);
      IF NOT (status.normal AND variable_information.access_info_found) THEN
        EXIT clp$evaluate_name_for_write;
      ELSEIF NOT variable_information.parameter_passed THEN
        IF NOT evaluating_for_var_parameter THEN
          IF variable_information.access_mode = clc$read_write THEN
            osp$set_status_abnormal ('CL', cle$cannot_write_omitted_param, name, status);
          IFEND;
          EXIT clp$evaluate_name_for_write;
        IFEND;
      IFEND;

      found := TRUE;

      complete_type_description := variable_information.type_description;

      IF variable_information.value_qualifiers_present THEN
        function_or_parameter_qual := variable_information.value_qualifiers;
        clp$get_qualified_type_desc (function_or_parameter_qual, variable_information.type_description);
      IFEND;

    PROCEND process_name;
?? TITLE := 'process_parameter_name', EJECT ??

    PROCEDURE process_parameter_name;


      variable_name := result.parameter_name;
      variable_requests := access_variable_requests + $clt$access_variable_requests
            [clc$return_type_description, clc$return_value_qualifiers];
      clp$access_param_variable (variable_name, variable_requests, work_area, variable_information,
            access_handle, status);
      IF NOT status.normal THEN
        EXIT clp$evaluate_name_for_write;
      ELSEIF NOT variable_information.access_info_found THEN
        osp$set_status_abnormal ('CL', cle$unknown_parameter_name, variable_name, status);
        EXIT clp$evaluate_name_for_write;
      ELSEIF (NOT variable_information.parameter_passed) AND (NOT evaluating_for_var_parameter) AND
            (variable_information.access_mode = clc$read_write) THEN
        osp$set_status_abnormal ('CL', cle$cannot_write_omitted_param, variable_name, status);
        EXIT clp$evaluate_name_for_write;
      IFEND;

      complete_type_description := variable_information.type_description;

      IF variable_information.value_qualifiers_present THEN
        function_or_parameter_qual := variable_information.value_qualifiers;
        clp$get_qualified_type_desc (function_or_parameter_qual, variable_information.type_description);
      IFEND;

    PROCEND process_parameter_name;
?? TITLE := 'process_variable_reference', EJECT ??

    PROCEDURE process_variable_reference;

      VAR
        lexical_units: ^clt$lexical_units,
        nested_parse: clt$parse_state;


      clp$identify_lexical_units (result.variable, work_area, lexical_units, status);
      IF NOT status.normal THEN
        EXIT clp$evaluate_name_for_write;
      IFEND;
      clp$initialize_parse_state (result.variable, lexical_units, nested_parse);
      clp$scan_non_space_lexical_unit (nested_parse);
      CASE nested_parse.unit.kind OF
      = clc$lex_name =
        ;
      = clc$lex_long_name =
        osp$set_status_abnormal ('CL', cle$name_too_long, nested_parse.
              text^ (nested_parse.unit_index, nested_parse.unit.size), status);
        EXIT clp$evaluate_name_for_write;
      ELSE
        osp$set_status_abnormal ('CL', cle$expecting_variable_name, '', status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, nested_parse, status);
        EXIT clp$evaluate_name_for_write;
      CASEND;

      #TRANSLATE (osv$lower_to_upper, nested_parse.text^ (nested_parse.unit_index, nested_parse.unit.size),
            variable_name);
      clp$scan_any_lexical_unit (nested_parse);

      clp$evaluate_name_for_write (variable_name, access_variable_requests, evaluating_for_var_parameter,
            nested_parse, work_area, variable_name, variable_information, access_handle,
            complete_type_description, found, status);
      IF NOT status.normal THEN
        EXIT clp$evaluate_name_for_write;
      IFEND;
      IF NOT found THEN
        osp$set_status_abnormal ('CL', cle$unknown_variable, variable_name, status);
        EXIT clp$evaluate_name_for_write;
      IFEND;
      IF nested_parse.unit_is_space THEN
        clp$scan_non_space_lexical_unit (nested_parse);
      IFEND;
      IF nested_parse.unit.kind <> clc$lex_end_of_line THEN
        osp$set_status_abnormal ('CL', cle$expecting_end_of_expression, variable_name, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, nested_parse, status);
        EXIT clp$evaluate_name_for_write;
      IFEND;

      function_or_parameter_qual := variable_information.value_qualifiers;

    PROCEND process_variable_reference;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    found := FALSE;
    variable_name := name;
    complete_type_description := NIL;

    function_or_parameter_qual := NIL;

    IF ($clt$access_variable_requests [clc$return_internal_value, clc$value_info_if_defer_value,
          clc$return_type_specification, clc$possible_file_reference,
          clc$convert_nil_value_to_unspec] * access_variable_requests) <> $clt$access_variable_requests
          [] THEN
      ;
      osp$set_status_abnormal ('CL', cle$improper_variable_requests, name, status);
      RETURN;
    IFEND;

    IF name (1) = '$' THEN
      clp$evaluate_function (TRUE, name, NIL, parse, work_area, result, found, status);
      IF NOT (status.normal AND found) THEN
        IF found THEN
          initialize_variable_information (variable_information);
        IFEND;
        RETURN;
      IFEND;

      CASE result.kind OF

      = clc$fr_value =

{ Should never get here.

        initialize_variable_information (variable_information);
        osp$set_status_abnormal ('CL', cle$bad_function_result, name, status);
        RETURN;

      = clc$fr_parameter_name =

{ Result from $PARAMETER_VALUE or $VALUE function.

        process_parameter_name;

      = clc$fr_variable_reference =

{Result from $VNAME function.

        process_variable_reference;
      ELSE

{ Should never get here.

        osp$set_status_abnormal ('CL', cle$bad_function_result, name, status);
        RETURN;
      CASEND;
    ELSE
      process_name;
    IFEND;

    IF variable_information.access_mode <> clc$read_write THEN
      osp$set_status_abnormal ('CL', cle$cannot_assign_to_a_read_var, variable_name, status);
      RETURN;
    IFEND;

    IF parse.unit.kind IN $clt$lexical_unit_kinds [clc$lex_left_parenthesis, clc$lex_dot] THEN
      IF evaluating_for_var_parameter AND (NOT variable_information.parameter_passed) THEN
        osp$set_status_abnormal ('CL', cle$unexpected_qual_for_unspec, variable_name, status);
        clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
        RETURN;
      IFEND;
      clp$get_write_value_qualifiers (name, variable_information.type_description, parse, work_area,
            variable_information.value_qualifiers, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF variable_information.value_qualifiers <> NIL THEN
        variable_information.value_qualifiers_present := TRUE;
        IF variable_information.evaluation_method = clc$deferred_evaluation THEN
          osp$set_status_abnormal ('CL', cle$improper_use_of_defer_var, variable_name, status);
          RETURN;
        IFEND;

        IF function_or_parameter_qual <> NIL THEN
          function_or_parameter_qual_size := UPPERBOUND (function_or_parameter_qual^);
          value_qualifiers_size := UPPERBOUND (variable_information.value_qualifiers^);
          NEXT all_value_qualifiers: [1 .. function_or_parameter_qual_size + value_qualifiers_size] IN
                work_area;
          IF all_value_qualifiers = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            RETURN;
          IFEND;
          FOR i := 1 TO function_or_parameter_qual_size DO
            all_value_qualifiers^ [i] := function_or_parameter_qual^ [i];
          FOREND;
          FOR i := 1 TO value_qualifiers_size DO
            all_value_qualifiers^ [function_or_parameter_qual_size + i] :=
                  variable_information.value_qualifiers^ [i];
          FOREND;
          variable_information.value_qualifiers := all_value_qualifiers;
        IFEND;

      IFEND;
    IFEND;

  PROCEND clp$evaluate_name_for_write;
?? TITLE := 'clp$get_variable', EJECT ??
*copyc clh$get_variable

  PROCEDURE [XDCL, #GATE] clp$get_variable
    (    reference: clt$variable_ref_expression;
     VAR work_area {input, output} : ^clt$work_area;
     VAR class: clt$variable_class;
     VAR access_mode: clt$data_access_mode;
     VAR evaluation_method: clt$expression_eval_method;
     VAR type_specification: ^clt$type_specification;
     VAR value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      access_variable_requests: clt$access_variable_requests,
      local_status: ost$status,
      local_work_area: ^^clt$work_area,
      local_value: ^clt$data_value,
      name: clt$variable_name,
      original_local_work_area: ^clt$work_area,
      variable_information: clt$variable_information;


    #KEYPOINT (osk$entry, 0, clk$get_variable);

    status.normal := TRUE;
    value := NIL;

  /get_variable/
    BEGIN
      IF work_area = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', local_status);
        EXIT /get_variable/;
      IFEND;

*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^local_work_area), local_work_area, local_status);
*ELSE
      clp$get_work_area (osc$user_ring, local_work_area, local_status);
*IFEND
      IF NOT local_status.normal THEN
        EXIT /get_variable/;
      IFEND;
      original_local_work_area := local_work_area^;


      access_variable_requests := $clt$access_variable_requests [clc$return_type_description];
      get_variable_value (^reference, access_variable_requests, local_work_area^, name, variable_information,
            local_value, local_status);
      IF NOT local_status.normal THEN
        EXIT /get_variable/;
      IFEND;

      IF variable_information.type_description = NIL THEN
        osp$set_status_abnormal ('CL', cle$cannot_read_omitted_param, name, local_status);
        EXIT /get_variable/;
      IFEND;

      clp$convert_type_desc_to_spec (variable_information.type_description, work_area, type_specification,
            local_status);
      IF NOT local_status.normal THEN
        EXIT /get_variable/;
      IFEND;

      IF local_value <> NIL THEN
*IF NOT $true(osv$unix)
        IF #SEGMENT (work_area) = #SEGMENT (local_work_area^) THEN
*ELSE
        IF #LOC (work_area^) = #LOC (local_work_area^^) THEN
*IFEND
          value := local_value;
        ELSE
          clp$copy_data_value (local_value, work_area, value, local_status);
          local_work_area^ := original_local_work_area;
          IF NOT local_status.normal THEN
            EXIT /get_variable/;
          IFEND;
        IFEND;
      IFEND;

      access_mode := variable_information.access_mode;
      evaluation_method := variable_information.evaluation_method;
      CASE variable_information.class OF
      = clc$env_variable, clc$pushed_variable =
        class := clc$environment_variable;
      = clc$proc_variable, clc$xdcled_variable, clc$xrefed_variable =
        class := clc$procedure_variable;
      = clc$lib_variable =
        class := clc$library_variable;
      ELSE
        class := clc$parameter_variable;
      CASEND;

    END /get_variable/;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, clk$get_variable);

  PROCEND clp$get_variable;
?? TITLE := 'clp$get_variable_value', EJECT ??
*copyc clh$get_variable_value

  PROCEDURE [XDCL, #GATE] clp$get_variable_value
    (    reference: clt$variable_ref_expression;
     VAR value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      access_variable_requests: clt$access_variable_requests,
      ignore_variable_information: clt$variable_information,
      local_status: ost$status,
      name: clt$variable_name,
      work_area: ^^clt$work_area;


    #KEYPOINT (osk$entry, 1, clk$get_variable);

    status.normal := TRUE;
    value := NIL;

  /get_variable/
    BEGIN
*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^work_area), work_area, local_status);
*ELSE
      clp$get_work_area (osc$user_ring, work_area, local_status);
*IFEND
      IF NOT local_status.normal THEN
        EXIT /get_variable/;
      IFEND;

      access_variable_requests := $clt$access_variable_requests [];
      get_variable_value (^reference, access_variable_requests, work_area^, name, ignore_variable_information,
            value, local_status);
    END /get_variable/;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 1, clk$get_variable);

  PROCEND clp$get_variable_value;
*IFEND
?? TITLE := 'clp$produce_variable_ref_expr', EJECT ??

  PROCEDURE [XDCL] clp$produce_variable_ref_expr
    (    class: clt$internal_variable_class;
         name: clt$variable_name;
         value_qualifiers: ^clt$value_qualifiers;
     VAR work_area {input, output} : ^clt$work_area;
     VAR variable: ^clt$variable_ref_expression;
     VAR status: ost$status);

    CONST
      parameter_prefix = '$PARAMETER_VALUE(',
      parameter_prefix_size = 17 {STRLENGTH (parameter_prefix)} ,
      substring_all = 'ALL',
      substring_all_size = 3 {STRLENGTH (substring_all)} ;

    VAR
      field_size: integer,
      i: integer,
      name_size: ost$name_size,
      process_subscript: boolean,
      str: ^ost$string,
      subscript: clt$array_bound,
      variable_size: clt$expression_text_size;


    status.normal := TRUE;
    str := NIL;

    name_size := clp$trimmed_string_size (name);
    IF class = clc$param_variable THEN
      variable_size := parameter_prefix_size + name_size + 1;
    ELSE
      variable_size := name_size;
    IFEND;
    NEXT variable: [variable_size] IN work_area;
    IF variable = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;
    IF class = clc$param_variable THEN
      variable^ (1, parameter_prefix_size) := parameter_prefix;
      variable^ (parameter_prefix_size + 1, name_size) := name (1, name_size);
      variable^ (parameter_prefix_size + name_size + 1) := ')';
    ELSE
      variable^ (1, name_size) := name (1, name_size);
    IFEND;

*IF NOT $true(osv$unix)
    IF value_qualifiers = NIL THEN
*IFEND
      RETURN;
*IF NOT $true(osv$unix)
    IFEND;

    FOR i := 1 TO UPPERBOUND (value_qualifiers^) DO

      process_subscript := FALSE;
      CASE value_qualifiers^ [i].kind OF

      = clc$array_subscript_qualifier =
        subscript := value_qualifiers^ [i].array_subscript;
        process_subscript := TRUE;

      = clc$field_qualifier, clc$unspecified_field_qualifier =
        field_size := clp$trimmed_string_size (value_qualifiers^ [i].field_name);
        RESET work_area TO variable;
        NEXT variable: [variable_size + 1 + field_size] IN work_area;
        IF variable = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          RETURN;
        IFEND;
        variable^ (variable_size + 1) := '.';
        variable^ (variable_size + 2, field_size) := value_qualifiers^ [i].field_name (1, field_size);
        variable_size := STRLENGTH (variable^);

      = clc$list_subscript_qualifier =
        subscript := value_qualifiers^ [i].list_subscript;
        process_subscript := TRUE;

      = clc$substring_qualifier, clc$unspecified_substring_qual =
        IF str = NIL THEN
          PUSH str;
        IFEND;
        clp$convert_integer_to_string (value_qualifiers^ [i].index, 10, FALSE, str^, status);
        RESET work_area TO variable;
        NEXT variable: [variable_size + 1 + str^.size + 2] IN work_area;
        IF variable = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          RETURN;
        IFEND;
        variable^ (variable_size + 1) := '(';
        variable^ (variable_size + 2, str^.size) := str^.value (1, str^.size);
        variable_size := STRLENGTH (variable^);
        variable^ (variable_size - 1, 2) := ', ';
        IF (value_qualifiers^ [i].kind = clc$unspecified_substring_qual) AND
              value_qualifiers^ [i].all_specified THEN
          str^.value (1, substring_all_size) := substring_all;
          str^.size := substring_all_size;
        ELSE
          clp$convert_integer_to_string (value_qualifiers^ [i].size, 10, FALSE, str^, status);
        IFEND;
        RESET work_area TO variable;
        NEXT variable: [variable_size + str^.size + 1] IN work_area;
        IF variable = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          RETURN;
        IFEND;
        variable^ (variable_size + 1, str^.size) := str^.value (1, str^.size);
        variable_size := STRLENGTH (variable^);
        variable^ (variable_size) := ')';

      = clc$unspecified_subscript_qual =
        subscript := value_qualifiers^ [i].unspecified_subscript;
        process_subscript := TRUE;

      ELSE
        osp$set_status_abnormal ('CL', cle$bad_value_qualifier, name, status);
        RETURN;
      CASEND;

      IF process_subscript THEN
        IF str = NIL THEN
          PUSH str;
        IFEND;
        clp$convert_integer_to_string (subscript, 10, FALSE, str^, status);
        RESET work_area TO variable;
        NEXT variable: [variable_size + 1 + str^.size + 1] IN work_area;
        IF variable = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
          RETURN;
        IFEND;
        variable^ (variable_size + 1) := '(';
        variable^ (variable_size + 2, str^.size) := str^.value (1, str^.size);
        variable_size := STRLENGTH (variable^);
        variable^ (variable_size) := ')';
      IFEND;
    FOREND;
*IFEND

  PROCEND clp$produce_variable_ref_expr;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$read_variable', EJECT ??
*copyc clh$read_variable

  PROCEDURE [XDCL, #GATE] clp$read_variable
    (    reference: string ( * );
     VAR variable: clt$variable_reference;
     VAR status: ost$status);

    VAR
      access_variable_requests: clt$access_variable_requests,
      local_status: ost$status,
      max_string_size: clt$string_size,
      name: clt$variable_name,
      value: ^clt$data_value,
      variable_information: clt$variable_information,
      variable_reference: ^clt$variable_ref_expression,
      work_area: ^^clt$work_area;


    #KEYPOINT (osk$entry, 0, clk$read_variable);

    status.normal := TRUE;

  /read_variable/
    BEGIN
*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^work_area), work_area, local_status);
*ELSE
      clp$get_work_area (osc$user_ring, work_area, local_status);
*IFEND
      IF NOT local_status.normal THEN
        EXIT /read_variable/;
      IFEND;

      access_variable_requests := $clt$access_variable_requests
            [clc$return_type_description, clc$return_value_qualifiers];
      get_variable_value (^reference, access_variable_requests, work_area^, name, variable_information, value,
            local_status);
      IF NOT local_status.normal THEN
        EXIT /read_variable/;
      IFEND;

      IF variable_information.type_description = NIL THEN
        osp$set_status_abnormal ('CL', cle$cannot_read_omitted_param, name, local_status);
        EXIT /read_variable/;
      IFEND;

      IF variable_information.type_description^.kind = clc$array_type THEN
        variable.lower_bound := variable_information.type_description^.bounds.lower;
        variable.upper_bound := variable_information.type_description^.bounds.upper;
        variable_information.type_description := variable_information.type_description^.
              array_element_type_description;
      ELSE
        variable.lower_bound := 1;
        variable.upper_bound := 1;
      IFEND;
      IF variable_information.type_description^.kind = clc$string_type THEN
        max_string_size := variable_information.type_description^.max_string_size;
      ELSE
        max_string_size := 1;
      IFEND;
      clp$convert_value_to_var_value (value, max_string_size, variable.value, local_status);
      IF NOT local_status.normal THEN
        EXIT /read_variable/;
      IFEND;

      clp$produce_variable_ref_expr (variable_information.class, name, variable_information.value_qualifiers,
            work_area^, variable_reference, local_status);
      IF NOT local_status.normal THEN
        EXIT /read_variable/;
      IFEND;
      variable.reference.size := #SIZE (variable_reference^);
      variable.reference.value := variable_reference^;

    END /read_variable/;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, clk$read_variable);

  PROCEND clp$read_variable;
?? TITLE := 'clp$update_variable', EJECT ??

  PROCEDURE [XDCL] clp$update_variable
    (    reference: ^clt$variable_ref_expression;
         new_value: clt$variable_value_description;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      access_handle: clt$variable_access_handle,
      access_variable_requests: clt$access_variable_requests,
      array_variable: boolean,
      data_value: ^clt$data_value,
      ignore_variable_name: clt$variable_name,
      lexical_units: ^clt$lexical_units,
      lower_bound: clt$array_bound,
      name: clt$variable_name,
      parse: clt$parse_state,
      complete_type_description: ^clt$type_description,
      upper_bound: clt$array_bound,
      variable_found: boolean,
      variable_information: clt$variable_information;

    status.normal := TRUE;

    clp$identify_lexical_units (reference, work_area, lexical_units, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$initialize_parse_state (reference, lexical_units, parse);
    clp$scan_non_space_lexical_unit (parse);
    IF parse.unit.kind <> clc$lex_name THEN
      osp$set_status_abnormal ('CL', cle$expecting_variable_name, '', status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      RETURN;
    IFEND;
    #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
    clp$scan_any_lexical_unit (parse);

    access_variable_requests := $clt$access_variable_requests
          [clc$return_type_description, clc$return_value_qualifiers];
    clp$evaluate_name_for_write (name, access_variable_requests, FALSE, parse, work_area,
          ignore_variable_name, variable_information, access_handle, complete_type_description,
          variable_found, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT variable_found THEN
      osp$set_status_abnormal ('CL', cle$unknown_variable, name, status);
      RETURN;
    IFEND;

    IF parse.unit_is_space THEN
      clp$scan_non_space_lexical_unit (parse);
    IFEND;
    IF parse.unit.kind <> clc$lex_end_of_line THEN
      osp$set_status_abnormal ('CL', cle$expecting_end_of_expression, '', status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      RETURN;
    IFEND;

    IF new_value.kind = clc$variable_value THEN
      IF variable_information.type_description = NIL THEN

{ Variable with ANY type.

        osp$set_status_abnormal ('CL', cle$bad_variable_kind, name, status);
        RETURN;
      IFEND;
      IF variable_information.type_description^.kind = clc$array_type THEN
        lower_bound := variable_information.type_description^.bounds.lower;
        upper_bound := variable_information.type_description^.bounds.upper;
        array_variable := TRUE;
      ELSE
        lower_bound := 1;
        upper_bound := 1;
        array_variable := FALSE;
      IFEND;
      clp$convert_var_value_to_value (new_value.value, array_variable, lower_bound, upper_bound, work_area,
            data_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      data_value := new_value.data_value;
    IFEND;

    IF data_value = NIL THEN
      osp$set_status_abnormal ('CL', cle$must_specify_new_data_value, name, status);
      RETURN;
    IFEND;

    IF data_value^.kind = clc$deferred THEN
      IF variable_information.value_qualifiers_present THEN
        osp$set_status_abnormal ('CL', cle$improper_use_of_defer_value, name, status);
        RETURN;
      IFEND;
      IF variable_information.evaluation_method = clc$immediate_evaluation THEN
        clp$evaluate_expression (data_value^.deferred_value^, data_value^.deferred_type, work_area,
              data_value, status);
        IF NOT status.normal THEN
          IF status.condition <> cle$work_area_overflow THEN
            osp$set_status_abnormal ('CL', cle$nonevaluable_deferred_value, name, status);
          IFEND;
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    clp$change_variable_value (name, data_value, variable_information.value_qualifiers,
          complete_type_description, variable_information.type_description, access_handle, FALSE, work_area,
          status);

  PROCEND clp$update_variable;
?? TITLE := 'clp$write_variable', EJECT ??
*copyc clh$write_variable

  PROCEDURE [XDCL, #GATE] clp$write_variable
    (    reference: string ( * );
         value: clt$variable_value;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      replacement_value: clt$variable_value_description,
      work_area: ^clt$work_area,
      work_area_ptr: ^^clt$work_area;


    #KEYPOINT (osk$entry, 0, clk$write_variable);

    status.normal := TRUE;

  /write_variable/
    BEGIN
*IF NOT $true(osv$unix)
      clp$get_work_area (#RING (^work_area_ptr), work_area_ptr, local_status);
*ELSE
      clp$get_work_area (osc$user_ring, work_area_ptr, local_status);
*IFEND
      IF NOT local_status.normal THEN
        EXIT /write_variable/;
      IFEND;
      work_area := work_area_ptr^;

      replacement_value.kind := clc$variable_value;
      replacement_value.value := value;

      clp$update_variable (^reference, replacement_value, work_area_ptr^, local_status);
      work_area_ptr^ := work_area;

    END /write_variable/;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, clk$write_variable);

  PROCEND clp$write_variable;
?? TITLE := 'create_default_or_file_variable', EJECT ??

  PROCEDURE create_default_or_file_variable
    (    name: clt$variable_name;
         scope: clt$keyword;
         type_specification: ^clt$type_specification;
         initial_value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      var_scope: clt$variable_declaration_scope,
      work_area: ^clt$work_area,
      work_area_ptr: ^^clt$work_area;


    status.normal := TRUE;

*IF NOT $true(osv$unix)
    clp$get_work_area (#RING (^work_area_ptr), work_area_ptr, status);
*ELSE
    clp$get_work_area (osc$user_ring, work_area_ptr, status);
*IFEND
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    work_area := work_area_ptr^;

    IF scope = 'ENVIRONMENT' THEN
      var_scope := clc$environment_scope;
    ELSEIF scope = 'JOB' THEN
      var_scope := clc$job_scope;
    ELSEIF scope = 'TASK' THEN
      var_scope := clc$task_scope;
    ELSE

{ Can only be UTILITY.

      var_scope := clc$utility_scope;
    IFEND;

    clp$create_var_from_type_spec (name, var_scope, clc$read_write, clc$immediate_evaluation,
          type_specification, initial_value, FALSE, work_area_ptr^, status);
    work_area_ptr^ := work_area;

  PROCEND create_default_or_file_variable;
?? TITLE := 'get_variable_value', EJECT ??

  PROCEDURE get_variable_value
    (    reference: ^clt$variable_ref_expression;
         access_variable_requests: clt$access_variable_requests;
     VAR work_area {input, output} : ^clt$work_area;
     VAR name: clt$variable_name;
     VAR variable_information: clt$variable_information;
     VAR value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      ignore_last_qualifier_is_field: boolean,
      lexical_units: ^clt$lexical_units,
      parse: clt$parse_state,
      variable_found: boolean,
      variable_name: clt$variable_name;


    status.normal := TRUE;

    value := NIL;

    clp$identify_lexical_units (reference, work_area, lexical_units, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$initialize_parse_state (reference, lexical_units, parse);
    clp$scan_non_space_lexical_unit (parse);
    IF parse.unit.kind <> clc$lex_name THEN
      osp$set_status_abnormal ('CL', cle$expecting_variable_name, '', status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
      RETURN;
    IFEND;
    #TRANSLATE (osv$lower_to_upper, parse.text^ (parse.unit_index, parse.unit.size), name);
    clp$scan_any_lexical_unit (parse);

    clp$evaluate_name_for_read (name, NIL, access_variable_requests, parse, work_area, variable_name,
          variable_information, value, variable_found, ignore_last_qualifier_is_field, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT variable_found THEN
      osp$set_status_abnormal ('CL', cle$unknown_variable, name, status);
      RETURN;
    IFEND;

    name := variable_name;

    IF parse.unit_is_space THEN
      clp$scan_non_space_lexical_unit (parse);
    IFEND;
    IF parse.unit.kind <> clc$lex_end_of_line THEN
      osp$set_status_abnormal ('CL', cle$expecting_end_of_expression, '', status);
      clp$append_status_parse_state (osc$status_parameter_delimiter, parse, status);
    IFEND;

  PROCEND get_variable_value;
*IFEND
?? TITLE := 'initialize_variable_information', EJECT ??

  PROCEDURE [INLINE] initialize_variable_information
    (VAR variable_information: clt$variable_information);


    variable_information.access_info_found := FALSE;
    variable_information.parameter_passed := FALSE;
    variable_information.has_no_internal_value := TRUE;
    variable_information.internal_value := NIL;
    variable_information.type_specification := NIL;
    variable_information.type_description := NIL;
    variable_information.value_qualifiers_present := FALSE;
    variable_information.value_qualifiers := NIL;

  PROCEND initialize_variable_information;

MODEND clm$variable_access_manager;
*DECK DECK=CLM$VARIABLE_STORAGE_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Variable Storage Manager' ??
MODULE clm$variable_storage_manager;

{
{ PURPOSE:
{   This module contains the procedures that create, delete and write command language variables.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_parsing
*copyc cle$ecc_utilities
*IF $true(osv$unix)
*copyc cle$not_supported
*IFEND
*copyc cle$unexpected_call_to
*copyc cle$unknown_variable
*copyc cle$var_already_created
*copyc cle$work_area_overflow
*copyc clk$remove_variable
*copyc clt$access_variable_requests
*copyc clt$environment_variable_scope
*copyc clt$procedure_variable_scope
*copyc clt$variable_access_handle
*copyc clt$variable_declaration_scope
*copyc clt$variable_information
*copyc oss$task_private
*copyc oss$task_shared
?? POP ??
*IF NOT $true(osv$unix)
*copyc clp$add_variable_to_tree
*copyc clp$check_name_for_boolean
*copyc clp$compute_variable_name_hash
*copyc clp$convert_ext_value_to_int
*copyc clp$convert_int_to_var_value
*copyc clp$convert_int_value_to_ext
*copyc clp$convert_type_spec_to_desc
*copyc clp$create_default_init_value
*copyc clp$create_variable_type
*copyc clp$delete_variable_access
*copyc clp$delete_variable_from_tree
*IFEND
*copyc clp$evaluate_type_conformance
*copyc clp$evaluate_value_conformance
*copyc clp$find_current_block
*IF NOT $true(osv$unix)
*copyc clp$find_first_var_block
*copyc clp$find_next_var_block
*copyc clp$find_variable_access
*IFEND
*copyc clp$read_qualified_data_value
*copyc clp$trimmed_string_size
*copyc clp$validate_name
*IF NOT $true(osv$unix)
*copyc clp$write_qualified_data_value
*copyc osp$clear_job_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$increment_locked_variable
*copyc osp$set_job_signature_lock
*IFEND
*copyc osp$set_status_abnormal
*IF NOT $true(osv$unix)
*copyc osv$task_private_heap
*IFEND
*copyc osv$task_shared_heap
*IF NOT $true(osv$unix)
*copyc pmp$continue_to_cause
*IFEND
?? EJECT ??

*IF NOT $true(osv$unix)
  VAR
    clv$var_access_assignment_count: [XDCL, oss$task_shared] integer := 0;

  VAR
    clv$retain_unprintable_char: [XDCL, #GATE, oss$task_private] boolean := FALSE;

  VAR
    clv$call_from_colt_command: [XDCL, #GATE, oss$task_private] boolean := FALSE;

  VAR
    clv$first_header_creation: [XDCL, #GATE, oss$task_private] boolean := FALSE;

  VAR
    clv$max_variable_allocation: [XDCL, #GATE, oss$task_shared] ost$segment_length := 4000000(16);

  VAR
    clv$total_variable_allocation: [STATIC, oss$task_shared] ost$segment_length := 0;

  VAR
    clv$variable_access_lock: [STATIC, oss$task_shared] ost$signature_lock := [0];

  TYPE
    conversion_value = record
      case converted: boolean of
      = TRUE =
        max_string_size: ost$string_size,
        converted_value: clt$variable_value,
      casend
    recend;

  TYPE
    utility_name_definition = record
      case defined: boolean of
      = TRUE =
        value: ost$name,
      casend,
    recend;

  TYPE
    clt$deferred_variable_list = record
      name: ost$name,
      link: ^clt$deferred_variable_list,
    recend;

  VAR
    clv$deferred_variable_list: [STATIC, oss$task_private] ^clt$deferred_variable_list := NIL;


?? TITLE := 'check_name', EJECT ??

  PROCEDURE [INLINE] check_name
    (    name: clt$variable_name;
     VAR status: ost$status);

    VAR
      ignore_bool: clt$boolean,
      name_is_boolean: boolean;


    status.normal := TRUE;

    clp$check_name_for_boolean (name, ignore_bool, name_is_boolean);
    IF name_is_boolean THEN
      osp$set_status_abnormal ('CL', cle$special_name_use, name, status);
      RETURN;
    IFEND;
    IF name (1) = '$' THEN
      osp$set_status_abnormal ('CL', cle$improper_use_of_$, name, status);
      RETURN;
    IFEND;

  PROCEND check_name;
?? TITLE := 'clp$access_param_variable', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$access_param_variable
    (    name: clt$parameter_name;
         access_variable_requests: clt$access_variable_requests;
     VAR work_area {input, output} : ^clt$work_area;
     VAR variable_information: clt$variable_information;
     VAR variable_access_handle: clt$variable_access_handle;
     VAR status: ost$status);

    VAR
      access_info: ^clt$variable_access_info,
      block: ^clt$block,
      index: clt$parameter_name_index,
      found: boolean;


    status.normal := TRUE;
    variable_information.access_info_found := FALSE;

    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);

    access_info := NIL;
    clp$find_current_block (block);

  /find_block/
    WHILE block <> NIL DO
      CASE block^.kind OF
      = clc$command_proc_block, clc$function_proc_block =
        IF block^.parameters.evaluated THEN
          IF block^.parameters.procedure_parameters THEN
            clp$search_parameter_names (name, block^.parameters.names, index, found);
            IF found THEN
              access_info := ^block^.parameters.accesses^ [block^.parameters.names^ [index].position].info;
            IFEND;
          IFEND;
          EXIT /find_block/;
        IFEND;
      = clc$input_block =
        IF block^.inherited_input.found THEN
          block := block^.inherited_input.block;
          CYCLE /find_block/;
        IFEND;
      ELSE
        ;
      CASEND;

      IF block^.static_link <> NIL THEN
        block := block^.static_link;
      ELSE
        block := block^.previous_block;
      IFEND;

    WHILEND /find_block/;

    IF access_info <> NIL THEN
      variable_information.access_info_found := TRUE;
      copy_variable_information (access_info, access_variable_requests, work_area, variable_information,
            variable_access_handle, status);
    IFEND;

    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;

  PROCEND clp$access_param_variable;
?? TITLE := 'clp$access_variable', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$access_variable
    (    name: clt$variable_name;
         hashed_name: clt$variable_name;
         hash: clt$variable_name_hash;
         lock: boolean;
         access_variable_requests: clt$access_variable_requests;
     VAR work_area {input,output} : ^clt$work_area;
     VAR variable_information: clt$variable_information;
     VAR variable_access_handle: clt$variable_access_handle;
     VAR status: ost$status);

{ LOCK should always be set to TRUE unless the caller to this
{ procedure knows the lock has already been previously set. Currently
{ the only time this occurs is when 'pushing' a variable.

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           ignore_condition_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      IF lock THEN
        osp$clear_job_signature_lock (clv$variable_access_lock);
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      access_info: ^clt$variable_access_info,
      allowed_classes: clt$internal_variable_classes,
      associated_utility : boolean,
      block: ^clt$block,
      inherited_allowed_classes: clt$internal_variable_classes,
      inherited_block: ^clt$block;


    status.normal := TRUE;
    variable_information.access_info_found := FALSE;

    IF lock THEN
      osp$establish_block_exit_hndlr (^abort_handler);
      osp$set_job_signature_lock (clv$variable_access_lock);
    IFEND;

    access_info := NIL;
    allowed_classes := -$clt$internal_variable_classes [];
    clp$find_first_var_block (allowed_classes, inherited_allowed_classes, inherited_block, block,
          associated_utility);

  /find_block/
    WHILE block <> NIL DO
      IF (inherited_block <> NIL) AND (block^.kind IN $clt$block_kinds
            [clc$command_proc_block, clc$function_proc_block]) AND block^.parameters.evaluated THEN
        allowed_classes := $clt$internal_variable_classes [clc$env_variable, clc$lib_variable,
              clc$pushed_variable];
      IFEND;
      clp$find_variable_access (name, hashed_name, hash, allowed_classes, block, access_info);
      IF access_info <> NIL THEN
        EXIT /find_block/;
      IFEND;
      IF (block^.kind IN $clt$block_kinds [clc$command_proc_block, clc$function_proc_block]) AND
            block^.parameters.evaluated THEN
        allowed_classes := $clt$internal_variable_classes [clc$env_variable, clc$lib_variable,
              clc$pushed_variable];
      IFEND;
      IF associated_utility AND (block = inherited_block) THEN
        allowed_classes := $clt$internal_variable_classes [clc$env_variable, clc$lib_variable,
              clc$pushed_variable];
      IFEND;
      clp$find_next_var_block (allowed_classes, inherited_allowed_classes, inherited_block, block,
            associated_utility);
    WHILEND /find_block/;

    IF access_info <> NIL THEN
      variable_information.access_info_found := TRUE;
      copy_variable_information (access_info, access_variable_requests, work_area, variable_information,
            variable_access_handle, status);
    IFEND;

    IF lock THEN
      osp$clear_job_signature_lock (clv$variable_access_lock);
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND clp$access_variable;
?? NEWTITLE := 'clp$add_to_defer_list', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$add_to_defer_list
    (    name: ost$name;
     VAR status: ost$status);

    VAR
      entry: ^clt$deferred_variable_list,
      deferred_variable_list: ^clt$deferred_variable_list;


    status.normal := TRUE;

    deferred_variable_list := clv$deferred_variable_list;
    WHILE deferred_variable_list <> NIL DO
      IF name = deferred_variable_list^.name THEN
        osp$set_status_abnormal ('CL', cle$recursive_deferred_variable, name, status);
        RETURN;
      IFEND;
      deferred_variable_list := deferred_variable_list^.link;
    WHILEND;

    ALLOCATE entry IN osv$task_private_heap^;
    entry^.name := name;
    entry^.link := clv$deferred_variable_list;
    clv$deferred_variable_list := entry;

  PROCEND clp$add_to_defer_list;
?? NEWTITLE := 'clp$change_colt_ruc_value', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$change_colt_ruc_value
    (    retain_unprintable_characters: boolean;
         call_from_colt_command: boolean);

    clv$retain_unprintable_char := retain_unprintable_characters;
    clv$call_from_colt_command := call_from_colt_command;

  PROCEND clp$change_colt_ruc_value;
?? NEWTITLE := 'clp$change_hdr_creation_value', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$change_hdr_creation_value
    (    first_header_creation_value: boolean);

    clv$first_header_creation := first_header_creation_value;

  PROCEND clp$change_hdr_creation_value;
?? TITLE := 'clp$change_variable_value', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$change_variable_value
    (    name: clt$variable_name;
         data_value: ^clt$data_value;
         value_qualifiers: ^clt$value_qualifiers;
         type_description: ^clt$type_description;
         qualified_type_description: ^clt$type_description;
         variable_access_handle: clt$variable_access_handle;
         allow_padding_or_truncation: boolean;
     VAR work_area {input,output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      access_info: ^clt$variable_access_info,
      conformance_checked: boolean,
      new_total_variable_allocation: integer,
      original_value: ^clt$internal_data_value,
      original_work_area: ^clt$work_area,
      pad_or_truncate_string: boolean,
      saved_work_area: ^clt$work_area,
      string_value: ^clt$string_value,
      type_conformance: clt$type_conformance,
      value: ^clt$data_value,
      variable_descriptor: ^clt$variable_descriptor,
      variable_value: ^clt$internal_data_value;


    status.normal := TRUE;
    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);
    original_work_area := work_area;

  /change_variable/
    BEGIN
*IF NOT $true(osv$unix)
      access_info := #ADDRESS (#RING (^access_info), #SEGMENT (osv$task_shared_heap),
            variable_access_handle.access_info_offset);
*ELSE
      access_info := #ADDRESS (variable_access_handle.access_info_offset);
*IFEND
      IF (access_info^.assignment_counter <> variable_access_handle.assignment_counter) OR
            (#OFFSET (access_info^.descriptor) <> variable_access_handle.descriptor_offset) THEN
        osp$set_status_abnormal ('CL', cle$unknown_variable, name, status);
        EXIT /change_variable/;
      IFEND;

      variable_descriptor := access_info^.descriptor;
      value := data_value;
      variable_value := NIL;
      conformance_checked := FALSE;
      pad_or_truncate_string := FALSE;

      IF data_value^.kind = clc$deferred THEN
        conformance_checked := TRUE;
      ELSEIF qualified_type_description <> NIL THEN
        IF (qualified_type_description^.kind = clc$string_type) AND allow_padding_or_truncation AND
              (value^.kind = clc$string) THEN
          pad_or_truncate_string := TRUE;
        ELSE
          clp$evaluate_value_conformance (value, qualified_type_description, clc$conforms_to_type, status);
          IF NOT status.normal THEN
            EXIT /change_variable/;
          IFEND;
        IFEND;
        conformance_checked := TRUE;
      IFEND;

      saved_work_area := NIL;

      IF pad_or_truncate_string THEN
        IF STRLENGTH (value^.string_value^) > qualified_type_description^.max_string_size THEN
          value^.string_value := ^value^.string_value^ (1, qualified_type_description^.max_string_size);
        ELSEIF STRLENGTH (value^.string_value^) < qualified_type_description^.min_string_size THEN
          NEXT string_value: [qualified_type_description^.min_string_size] IN work_area;
          IF string_value = NIL THEN
            osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
            EXIT /change_variable/;
          IFEND;
          string_value^ := value^.string_value^;
          value^.string_value := string_value;
        IFEND;
      IFEND;

      IF value_qualifiers <> NIL THEN
        IF variable_descriptor^.header.value <> NIL THEN
          original_value := variable_descriptor^.header.value;
        ELSE

{ The following call is made to get an initial estimate for the size of a variable, when the first
{ assignment to that variable is actually to one of its components.

          original_value := NIL;
          clp$convert_ext_value_to_int (type_description, NIL, NIL, work_area, original_value, status);
          IF NOT status.normal THEN
            IF status.condition = cle$work_area_overflow THEN
              osp$set_status_abnormal ('CL', cle$no_space_for_variable, name, status);
            IFEND;
            EXIT /change_variable/;
          IFEND;
        IFEND;
        clp$write_qualified_data_value (name, value_qualifiers, original_value, value, conformance_checked,
              allow_padding_or_truncation, work_area, variable_value, status);
        IF NOT status.normal THEN
          IF status.condition = cle$work_area_overflow THEN
            osp$set_status_abnormal ('CL', cle$no_space_for_variable, name, status);
          IFEND;
          EXIT /change_variable/;
        IFEND;
        IF NOT conformance_checked THEN
          saved_work_area := work_area;
          clp$convert_int_value_to_ext (variable_value, variable_value^.header.value, work_area, value,
                status);
          IF NOT status.normal THEN
            EXIT /change_variable/;
          IFEND;
        IFEND;
      IFEND;

      IF NOT conformance_checked THEN
        clp$evaluate_value_conformance (value, type_description, clc$conforms_to_type, status);
        IF NOT status.normal THEN
          EXIT /change_variable/;
        IFEND;
        IF saved_work_area <> NIL THEN
          work_area := saved_work_area;
        IFEND;
      IFEND;

      IF variable_value = NIL THEN
        clp$convert_ext_value_to_int (type_description, value, NIL, work_area, variable_value, status);
        IF NOT status.normal THEN
          IF status.condition = cle$work_area_overflow THEN
            osp$set_status_abnormal ('CL', cle$no_space_for_variable, name, status);
          IFEND;
          EXIT /change_variable/;
        IFEND;
      IFEND;

      IF variable_value = variable_descriptor^.header.value THEN
        EXIT /change_variable/;
      IFEND;

      new_total_variable_allocation := clv$total_variable_allocation + #SIZE (variable_value^);
      IF variable_descriptor^.header.value <> NIL THEN
        new_total_variable_allocation := new_total_variable_allocation -
              #SIZE (variable_descriptor^.header.value^);
      IFEND;
      IF new_total_variable_allocation > clv$max_variable_allocation THEN
        osp$set_status_abnormal ('CL', cle$no_space_for_variable, name, status);
        EXIT /change_variable/;
      IFEND;

      IF variable_descriptor^.header.value <> NIL THEN
        FREE variable_descriptor^.header.value IN osv$task_shared_heap^;
      IFEND;

      ALLOCATE variable_descriptor^.header.value: [[REP #SIZE (variable_value^.allocated_space) OF cell]] IN
            osv$task_shared_heap^;
      clv$total_variable_allocation := new_total_variable_allocation;

      variable_descriptor^.header.value^ := variable_value^;
    END /change_variable/;

    work_area := original_work_area;
    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;

  PROCEND clp$change_variable_value;
?? TITLE := 'clp$create_var_from_conversion', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$create_var_from_conversion
    (    name: ost$name;
         kind: clt$variable_kinds;
         max_string_size: clt$string_size;
         create_array: boolean;
         lower_bound: clt$variable_dimension;
         upper_bound: clt$variable_dimension;
         scope: clt$variable_scope;
         initial_value: ^clt$data_value;
         return_variable: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR variable: clt$variable_reference;
     VAR status: ost$status);

    VAR
      declaration_scope: clt$variable_declaration_scope,
      return_variable_value: conversion_value,
      type_description: ^clt$type_description,
      type_specification: ^clt$type_specification,
      utility_name: utility_name_definition;


    status.normal := TRUE;

    check_name (name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$create_variable_type (kind, max_string_size, create_array, lower_bound, upper_bound, work_area,
          type_specification, type_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    return_variable_value.converted := return_variable;
    IF max_string_size <= osc$max_string_size THEN
      return_variable_value.max_string_size := max_string_size;
    ELSE
      return_variable_value.max_string_size := osc$max_string_size;
    IFEND;

    CASE scope.kind OF
    = clc$job_variable =
      declaration_scope := clc$job_scope;
      utility_name.defined := FALSE;
    = clc$utility_variable =
      declaration_scope := clc$utility_scope;
      utility_name.defined := TRUE;
      utility_name.value := scope.utility_name;
    = clc$local_variable =
      declaration_scope := clc$local_scope;
    = clc$xdcl_variable =
      declaration_scope := clc$xdcl_scope;
    = clc$xref_variable =
      declaration_scope := clc$xref_scope;
    ELSE

{ Should never get here.

      osp$set_status_abnormal ('CL', cle$bad_variable_scope, name, status);
      RETURN;
    CASEND;

    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);

    CASE declaration_scope OF
    = clc$job_scope, clc$utility_scope =
      internal_create_environment_var (name, clc$read_write, clc$immediate_evaluation, type_specification,
            declaration_scope, utility_name, type_description, initial_value, FALSE, return_variable_value,
            work_area, status);
    ELSE
      internal_create_procedure_var (name, clc$read_write, clc$immediate_evaluation, type_specification,
            declaration_scope, type_description, initial_value, return_variable_value, work_area, status);
    CASEND;

    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF return_variable THEN
      variable.reference.value := name;
      variable.reference.size := clp$trimmed_string_size (name);
      variable.lower_bound := lower_bound;
      variable.upper_bound := upper_bound;
      variable.value := return_variable_value.converted_value;
    IFEND;

  PROCEND clp$create_var_from_conversion;
?? TITLE := 'clp$create_var_from_type_spec', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$create_var_from_type_spec
    (    name: clt$variable_name;
         scope: clt$variable_declaration_scope;
         access_mode: clt$data_access_mode;
         evaluation_method: clt$expression_eval_method;
         type_specification: ^clt$type_specification;
         initial_value: ^clt$data_value;
         require_existing_var_for_push: boolean;
     VAR work_area {input,output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      return_variable_value: conversion_value,
      type_description: ^clt$type_description,
      utility_name: utility_name_definition;


    status.normal := TRUE;
    type_description := NIL;
    return_variable_value.converted := FALSE;

    check_name (name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (access_mode = clc$read_only) AND (initial_value = NIL) AND (scope <> clc$push_scope) AND
          (scope <> clc$xref_scope) THEN
      osp$set_status_abnormal ('CL', cle$read_var_requires_value, name, status);
      RETURN;
    IFEND;

    IF NOT ((scope = clc$push_scope) AND require_existing_var_for_push) THEN
      NEXT type_description IN work_area;
      IF type_description = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
        RETURN;
      IFEND;

      clp$convert_type_spec_to_desc (type_specification, work_area, type_description^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);

    CASE scope OF
    = clc$environment_scope, clc$job_scope, clc$task_scope, clc$utility_scope, clc$push_scope =
      utility_name.defined := FALSE;
      internal_create_environment_var (name, access_mode, evaluation_method, type_specification, scope,
            utility_name, type_description, initial_value, require_existing_var_for_push,
            return_variable_value, work_area, status);
    = clc$local_scope, clc$xdcl_scope, clc$xref_scope =
      internal_create_procedure_var (name, access_mode, evaluation_method, type_specification, scope,
            type_description, initial_value, return_variable_value, work_area, status);
    CASEND;

    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;

  PROCEND clp$create_var_from_type_spec;
?? TITLE := 'clp$delete_from_defer_list', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$delete_from_defer_list;

    VAR
      first_entry: ^clt$deferred_variable_list;

    first_entry := clv$deferred_variable_list;
    IF first_entry <> NIL THEN
      clv$deferred_variable_list := clv$deferred_variable_list^.link;
      FREE first_entry IN osv$task_private_heap^;
    IFEND;

  PROCEND clp$delete_from_defer_list;
?? TITLE := 'clp$delete_parameters', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$delete_parameters
    (VAR parameters: clt$parameters);

    VAR
      i: clt$parameter_number;


    IF parameters.procedure_parameters THEN
      IF parameters.values <> NIL THEN
        FREE parameters.values IN osv$task_shared_heap^;
      IFEND;

      IF parameters.accesses <> NIL THEN
        FOR i := 1 TO UPPERBOUND (parameters.accesses^) DO
          IF (parameters.accesses^ [i].info.access_mode = clc$read_write) AND parameters.accesses^ [i].
                info.parameter_passed THEN
            decrement_variable_access_count (parameters.accesses^ [i].info.descriptor);
            IF parameters.accesses^ [i].info.qualifiers <> NIL THEN
              FREE parameters.accesses^ [i].info.qualifiers IN osv$task_shared_heap^;
            IFEND;
          IFEND;
        FOREND;
      IFEND;
    IFEND;

    IF parameters.area <> NIL THEN
      FREE parameters.area IN osv$task_shared_heap^;
    IFEND;

  PROCEND clp$delete_parameters;
?? TITLE := 'clp$delete_variable', EJECT ??
*copyc clh$delete_variable

  PROCEDURE [XDCL, #GATE] clp$delete_variable
    (    name: string ( * );
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      name_is_valid: boolean,
      validated_name: ost$name;


    #KEYPOINT (osk$entry, 0, clk$remove_variable);

    status.normal := TRUE;

    clp$validate_name (name, validated_name, name_is_valid);
    IF name_is_valid THEN
      clp$internal_delete_variable (validated_name, -$clt$internal_variable_classes [], local_status);
    ELSE
      osp$set_status_abnormal ('CL', cle$improper_variable_name, name, local_status);
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, clk$remove_variable);

  PROCEND clp$delete_variable;
?? TITLE := 'clp$delete_variables', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$delete_variables
    (VAR variables: clt$variables);

    VAR
      current_variable: ^clt$variable_access,
      i: clt$variable_name_hash,
      next_variable: ^clt$variable_access,
      variable_descriptor: ^clt$variable_descriptor;


    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);

    FOR i := 0 TO clc$max_variable_hash_groups - 1 DO
      variables.hash_groups [i].root := NIL;
      variables.hash_groups [i].environment_variables_in_group := 0;
      variables.hash_groups [i].procedure_variables_in_group := 0;
    FOREND;
    current_variable := variables.thread;
    variables.thread := NIL;
    WHILE current_variable <> NIL DO
      next_variable := current_variable^.forward_thread;
      decrement_variable_access_count (current_variable^.info.descriptor);
      FREE current_variable IN osv$task_shared_heap^;
      current_variable := next_variable;
    WHILEND;

    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;

  PROCEND clp$delete_variables;
?? TITLE := 'clp$internal_delete_variable ', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$internal_delete_variable
    (    name: ost$name;
         allowed_classes: clt$internal_variable_classes;
     VAR status: ost$status);

    VAR
      hash: clt$variable_name_hash,
      hashed_name: clt$variable_name,
      variable_descriptor: ^clt$variable_descriptor;


    status.normal := TRUE;

    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);

  /delete_variable/
    BEGIN
      clp$compute_variable_name_hash (name, hashed_name, hash);
      clp$delete_variable_access (hashed_name, hash, allowed_classes, variable_descriptor);
      IF variable_descriptor = NIL THEN
        osp$set_status_abnormal ('CL', cle$unknown_variable, name, status);
        EXIT /delete_variable/;
      IFEND;
      decrement_variable_access_count (variable_descriptor);
    END /delete_variable/;

    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;

  PROCEND clp$internal_delete_variable;
*IFEND
?? TITLE := 'clp$obtain_variable_value', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$obtain_variable_value
    (    name: clt$variable_name;
         variable_access_handle: ^clt$variable_access_handle;
         access_variable_requests: clt$access_variable_requests;
     VAR work_area {input, output} : ^clt$work_area;
     VAR qualified_type_description {input, output} : ^clt$type_description;
     VAR parse_value_qualifiers {input, output} : ^clt$value_qualifiers;
     VAR parse_value_qualifiers_index: integer;
     VAR value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      access_info: ^clt$variable_access_info,
      internal_value: ^clt$internal_data_value,
      var_parameter_value_qualifiers: ^clt$value_qualifiers;

{
{ The parameter VALUE is NOT NIL in a few instances. The value
{ is either a function result or a deferred value of a variable
{ or an unspecified value.
{
{ The result value is evaluated from the parameter VALUE if it is NOT NIL.
{ Otherwise the result value is evaluated from the internal value from the
{ access info.
{


    status.normal := TRUE;
    internal_value := NIL;
    var_parameter_value_qualifiers := NIL;
    parse_value_qualifiers_index := 0;
*IF NOT $true(osv$unix)
    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);
*IFEND

  /obtain_value/
    BEGIN
      IF variable_access_handle <> NIL THEN
*IF NOT $true(osv$unix)
*IF NOT $true(osv$unix)
        access_info := #ADDRESS (#RING (^access_info), #SEGMENT (osv$task_shared_heap),
              variable_access_handle^.access_info_offset);
*ELSE
        access_info := #ADDRESS (variable_access_handle^.access_info_offset);
*IFEND
        IF (access_info^.assignment_counter <> variable_access_handle^.assignment_counter) OR
              (#OFFSET (access_info^.descriptor) <> variable_access_handle^.descriptor_offset) THEN
          osp$set_status_abnormal ('CL', cle$unknown_variable, name, status);
          EXIT /obtain_value/;
        IFEND;

        var_parameter_value_qualifiers := access_info^.qualifiers;

        IF value = NIL THEN
          internal_value := access_info^.descriptor^.header.value;
        IFEND;
*ELSE
{ I don't think we should get here for PHASE I, but if we do, just set status
{ to abnormal.
        osp$set_status_abnormal ('CL', cle$not_supported, 'Variables are',
              status);
        EXIT /obtain_value/;
*IFEND
      IFEND;

      IF (var_parameter_value_qualifiers = NIL) AND (parse_value_qualifiers = NIL) THEN
{
{ There are no value qualifiers.  Convert the internal value if necessary.
{
        IF internal_value <> NIL THEN
*IF NOT $true(osv$unix)
          clp$convert_int_value_to_ext (internal_value, internal_value^.header.value, work_area, value,
                status);
*ELSE
{ I don't think we should get here for PHASE I, but if we do, just set status
{ to abnormal.
        osp$set_status_abnormal ('CL', cle$not_supported, 'Variables are',
             status);
        EXIT /obtain_value/;
*IFEND
        IFEND;
      ELSEIF (value <> NIL) OR (internal_value <> NIL) THEN
{
{ Evaluate the value qualifiers according to the value.
{
        clp$read_qualified_data_value (name, access_variable_requests, var_parameter_value_qualifiers,
              internal_value, value, work_area, qualified_type_description, parse_value_qualifiers,
              parse_value_qualifiers_index, status);
        IF NOT status.normal THEN
          EXIT /obtain_value/;
        IFEND;
      ELSEIF NOT (clc$possible_file_reference IN access_variable_requests) THEN
{
{ There are value qualifiers but no value.  Return an error message because it is not a
{ possible file reference.
{
*IF NOT $true(osv$unix)
        osp$set_status_abnormal ('CL', cle$cannot_read_component, name, status);
*ELSE
        osp$set_status_abnormal ('CL', cle$not_supported, 'Variables are', status);
*IFEND
        EXIT /obtain_value/;
      ELSE
{
{ This is a possible file reference.  Reset the parse to the beginning.
{
        IF parse_value_qualifiers <> NIL THEN
          parse_value_qualifiers_index := 1;
        IFEND;
      IFEND;

    END /obtain_value/;

*IF NOT $true(osv$unix)
    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;
*IFEND

  PROCEND clp$obtain_variable_value;
*IF NOT $true(osv$unix)
?? TITLE := 'clp$pass_variable_parameter', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$pass_variable_parameter
    (    parameter_number: clt$parameter_number;
         access_handle: clt$variable_access_handle;
         value_qualifiers: ^clt$value_qualifiers;
         variable_name: clt$variable_name;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      i: integer,
      number_of_qualifiers: integer,
      parameter_access: ^clt$parameter_access,
      size: integer,
      variable_access_info: ^clt$variable_access_info;

?? NEWTITLE := 'get_size_of_value_qualifiers', EJECT ??

    PROCEDURE [INLINE] get_size_of_value_qualifiers
      (    value_qualifiers: ^clt$value_qualifiers;
       VAR number_of_qualifiers: integer;
       VAR size: integer);

      VAR
        i: integer;


      IF value_qualifiers = NIL THEN
        number_of_qualifiers := 0;
        size := 0;
      ELSE
        number_of_qualifiers := UPPERBOUND (value_qualifiers^);
        size := (#SIZE (clt$value_qualifier)) * number_of_qualifiers;
        FOR i := 1 TO number_of_qualifiers DO
          CASE value_qualifiers^ [i].kind OF
          = clc$field_qualifier, clc$unspecified_field_qualifier =
            IF value_qualifiers^ [i].record_kind = clc$record_record THEN
              size := size + #SIZE (value_qualifiers^ [i].field_names^);
            IFEND;
          ELSE
            ;
          CASEND;
        FOREND;
      IFEND;

    PROCEND get_size_of_value_qualifiers;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);

  /pass_variable_parameter/
    BEGIN
      clp$find_current_block (block);
      IF (block^.kind = clc$input_block) AND block^.input.prompting_input THEN
        block := block^.previous_block;
      IFEND;
      IF block^.parameters.evaluated OR (block^.kind <> clc$command_proc_block) OR
            (block^.parameters.accesses = NIL) OR (parameter_number >
            UPPERBOUND (block^.parameters.accesses^)) OR block^.parameters.accesses^ [parameter_number].info.
            parameter_passed OR (block^.parameters.accesses^ [parameter_number].info.access_mode <>
            clc$read_write) THEN
        osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$pass_variable_parameter', status);
        EXIT /pass_variable_parameter/;
      IFEND;

*IF NOT $true(osv$unix)
      variable_access_info := #ADDRESS (#RING (block), #SEGMENT (osv$task_shared_heap),
            access_handle.access_info_offset);
*ELSE
      variable_access_info := #ADDRESS (access_handle.access_info_offset);
*IFEND
      IF (variable_access_info^.assignment_counter <> access_handle.assignment_counter) OR
            (#OFFSET (variable_access_info^.descriptor) <> access_handle.descriptor_offset) THEN
        osp$set_status_abnormal ('CL', cle$unknown_variable, variable_name, status);
        EXIT /pass_variable_parameter/;
      IFEND;

      parameter_access := ^block^.parameters.accesses^ [parameter_number];
      parameter_access^.info.class := clc$param_variable;
      parameter_access^.info.parameter_passed := TRUE;
      parameter_access^.info.descriptor := variable_access_info^.descriptor;
      variable_access_info^.descriptor^.header.access_count :=
            variable_access_info^.descriptor^.header.access_count + 1;

      get_size_of_value_qualifiers (value_qualifiers, number_of_qualifiers, size);
      IF number_of_qualifiers = 0 THEN
        EXIT /pass_variable_parameter/;
      IFEND;

      ALLOCATE parameter_access^.qualifiers_area: [[REP size OF cell]] IN osv$task_shared_heap^;
      RESET parameter_access^.qualifiers_area;
      NEXT parameter_access^.info.qualifiers: [1 .. number_of_qualifiers] IN
            parameter_access^.qualifiers_area;
      FOR i := 1 TO number_of_qualifiers DO
        parameter_access^.info.qualifiers^ [i] := value_qualifiers^ [i];
        CASE value_qualifiers^ [i].kind OF
        = clc$field_qualifier, clc$unspecified_field_qualifier =
          IF value_qualifiers^ [i].record_kind = clc$record_record THEN
            NEXT parameter_access^.info.qualifiers^ [i].field_names:
                  [1 .. UPPERBOUND (value_qualifiers^ [i].field_names^)] IN parameter_access^.qualifiers_area;
            parameter_access^.info.qualifiers^ [i].field_names^ := value_qualifiers^ [i].field_names^;
          IFEND;
        ELSE
          ;
        CASEND;
      FOREND;

    END /pass_variable_parameter/;

    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;

  PROCEND clp$pass_variable_parameter;
?? TITLE := 'clp$unpass_variable_parameter', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$unpass_variable_parameter
    (    parameter_number: clt$parameter_number);

    VAR
      block: ^clt$block;


    clp$find_current_block (block);
    IF (block^.kind = clc$input_block) AND block^.input.prompting_input THEN
      block := block^.previous_block;
    IFEND;
    IF block^.parameters.evaluated OR (block^.kind <> clc$command_proc_block) OR
          (block^.parameters.accesses = NIL) OR (parameter_number >
          UPPERBOUND (block^.parameters.accesses^)) OR (NOT block^.parameters.accesses^ [parameter_number].
          info.parameter_passed) OR (block^.parameters.accesses^ [parameter_number].info.access_mode <>
          clc$read_write) THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^variable_abort_handler);
    osp$set_job_signature_lock (clv$variable_access_lock);

    block^.parameters.accesses^ [parameter_number].info.class := clc$param_variable;
    block^.parameters.accesses^ [parameter_number].info.parameter_passed := FALSE;
    decrement_variable_access_count (block^.parameters.accesses^ [parameter_number].info.descriptor);
    block^.parameters.accesses^ [parameter_number].info.qualifiers := NIL;
    block^.parameters.accesses^ [parameter_number].info.descriptor := block^.parameters.
          accesses^ [parameter_number].info.original_parameter_descriptor;
    IF block^.parameters.accesses^ [parameter_number].qualifiers_area <> NIL THEN
      FREE block^.parameters.accesses^ [parameter_number].qualifiers_area IN osv$task_shared_heap^;
    IFEND;

    osp$clear_job_signature_lock (clv$variable_access_lock);
    osp$disestablish_cond_handler;

  PROCEND clp$unpass_variable_parameter;
?? TITLE := 'complete_variable_access', EJECT ??

  PROCEDURE complete_variable_access
    (    access_mode: clt$data_access_mode;
         class: clt$internal_variable_class;
         descriptor: ^clt$variable_descriptor;
         qualifiers: ^clt$value_qualifiers;
         variable_access: ^clt$variable_access);


    variable_access^.info.access_mode := access_mode;
    variable_access^.info.class := class;
    variable_access^.info.parameter_passed := TRUE;
    variable_access^.info.descriptor := descriptor;
    variable_access^.info.qualifiers := qualifiers;
    osp$increment_locked_variable (clv$var_access_assignment_count, 0,
          variable_access^.info.assignment_counter);
    descriptor^.header.access_count := descriptor^.header.access_count + 1;

  PROCEND complete_variable_access;
?? TITLE := 'copy_variable_information', EJECT ??

  PROCEDURE copy_variable_information
    (    variable_access_info: ^clt$variable_access_info;
         access_variable_requests: clt$access_variable_requests;
     VAR work_area {input, output} : ^clt$work_area;
     VAR variable_information: clt$variable_information;
     VAR variable_access_handle: clt$variable_access_handle;
     VAR status: ost$status);

    VAR
      copy_internal_value: boolean,
      copy_type_specification: boolean,
      i_value: ^clt$i_data_value,
      internal_value: ^clt$internal_data_value,
      original_work_area: ^clt$work_area;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           ignore_condition_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      CASE condition.selector OF

      = pmc$block_exit_processing =
        work_area := original_work_area;
        #SPOIL (work_area);
        RETURN;

      = mmc$segment_access_condition =
        CASE condition.segment_access_condition.identifier OF
        = mmc$sac_read_write_beyond_msl, mmc$sac_no_append_permission =
*IF NOT $true(osv$unix)
          IF #SEGMENT (condition.segment_access_condition.segment) = #SEGMENT (work_area) THEN
*ELSE
          IF #LOC (condition.segment_access_condition.segment^) = #LOC (work_area^) THEN
*IFEND
            work_area_overflow;
          IFEND;
        ELSE
          ;
        CASEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? TITLE := 'work_area_overflow', EJECT ??

    PROCEDURE [INLINE] work_area_overflow;


      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      EXIT copy_variable_information;

    PROCEND work_area_overflow;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    original_work_area := work_area;
    #SPOIL (original_work_area);
    osp$establish_condition_handler (^abort_handler, TRUE);

    variable_access_handle.access_info_offset := #OFFSET (variable_access_info);
    variable_access_handle.descriptor_offset := #OFFSET (variable_access_info^.descriptor);
    variable_access_handle.assignment_counter := variable_access_info^.assignment_counter;

    variable_information.access_mode := variable_access_info^.access_mode;
    variable_information.class := variable_access_info^.class;
    variable_information.parameter_passed := variable_access_info^.parameter_passed;
    variable_information.evaluation_method := variable_access_info^.descriptor^.header.evaluation_method;
    variable_information.has_no_internal_value := variable_access_info^.descriptor^.header.value = NIL;
    variable_information.value_qualifiers_present := variable_access_info^.qualifiers <> NIL;

    IF NOT variable_information.has_no_internal_value THEN
      internal_value := variable_access_info^.descriptor^.header.value;
      i_value := #PTR (internal_value^.header.value, internal_value^);
    IFEND;

    IF clc$return_type_specification IN access_variable_requests THEN
      copy_type_specification := TRUE;
    ELSEIF (clc$type_spec_if_defer_method IN access_variable_requests) AND
          (variable_information.evaluation_method = clc$deferred_evaluation) THEN
      copy_type_specification := TRUE;
    ELSEIF (clc$value_info_if_defer_value IN access_variable_requests) AND
          (NOT variable_information.has_no_internal_value) AND (i_value^.kind = clc$deferred) THEN
      copy_type_specification := TRUE;
    ELSE
      copy_type_specification := FALSE;
    IFEND;

    IF copy_type_specification THEN
      NEXT variable_information.type_specification: [[REP #SIZE (variable_access_info^.descriptor^.
            type_specification) OF cell]] IN work_area;
      IF variable_information.type_specification = NIL THEN
        work_area_overflow;
      IFEND;
      variable_information.type_specification^ := variable_access_info^.descriptor^.type_specification;
    ELSE
      variable_information.type_specification := NIL;
    IFEND;

    IF variable_information.has_no_internal_value THEN
      copy_internal_value := FALSE;
    ELSEIF clc$return_internal_value IN access_variable_requests THEN
      copy_internal_value := TRUE;
    ELSEIF (clc$value_info_if_defer_value IN access_variable_requests) AND (i_value^.kind = clc$deferred) THEN
      copy_internal_value := TRUE;
    ELSE
      copy_internal_value := FALSE;
    IFEND;

    IF copy_internal_value THEN
      NEXT variable_information.internal_value: [[REP #SIZE (variable_access_info^.descriptor^.header.
            value^) OF cell]] IN work_area;
      IF variable_information.internal_value = NIL THEN
        work_area_overflow;
      IFEND;
      variable_information.internal_value^ := variable_access_info^.descriptor^.header.value^;
    ELSE
      variable_information.internal_value := NIL;
    IFEND;

    IF (clc$return_value_qualifiers IN access_variable_requests) AND
          variable_information.value_qualifiers_present THEN
      NEXT variable_information.value_qualifiers: [1 .. UPPERBOUND (variable_access_info^.qualifiers^)] IN
            work_area;
      IF variable_information.value_qualifiers = NIL THEN
        work_area_overflow;
      IFEND;
      variable_information.value_qualifiers^ := variable_access_info^.qualifiers^;
    ELSE
      variable_information.value_qualifiers := NIL;
    IFEND;

    IF clc$return_type_description IN access_variable_requests THEN
      NEXT variable_information.type_description IN work_area;
      IF variable_information.type_description = NIL THEN
        work_area_overflow;
      IFEND;
      clp$convert_type_spec_to_desc (^variable_access_info^.descriptor^.type_specification, work_area,
            variable_information.type_description^, status);
    ELSE
      variable_information.type_description := NIL;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND copy_variable_information;
?? TITLE := 'decrement_variable_access_count', EJECT ??

  PROCEDURE decrement_variable_access_count
    (VAR {input, output} variable_descriptor: ^clt$variable_descriptor);

    IF variable_descriptor <> NIL THEN
      variable_descriptor^.header.access_count := variable_descriptor^.header.access_count - 1;
      IF variable_descriptor^.header.access_count = 0 THEN
        IF variable_descriptor^.header.value <> NIL THEN
          clv$total_variable_allocation := clv$total_variable_allocation -
                #SIZE (variable_descriptor^.header.value^);
          FREE variable_descriptor^.header.value IN osv$task_shared_heap^;
        IFEND;
        FREE variable_descriptor IN osv$task_shared_heap^;
      IFEND;
    IFEND;

  PROCEND decrement_variable_access_count;
?? TITLE := 'find_first_var_creation_block', EJECT ??

  PROCEDURE find_first_var_creation_block
    (VAR allowed_classes {input, output} : clt$internal_variable_classes;
     VAR inherited_allowed_classes {input, output} : clt$internal_variable_classes;
     VAR inherited_block {input, output} : ^clt$block;
     VAR block {input, output} : ^clt$block);

    VAR
      associated_utility: boolean;


    clp$find_first_var_block (allowed_classes, inherited_allowed_classes, inherited_block, block,
          associated_utility);

    WHILE (block <> NIL) AND (inherited_block <> NIL) AND (NOT associated_utility) AND
          (block^.kind IN $clt$block_kinds [clc$command_proc_block, clc$function_proc_block]) AND
          block^.parameters.evaluated DO

      clp$find_next_var_block (allowed_classes, inherited_allowed_classes, inherited_block, block,
            associated_utility);

    WHILEND;

  PROCEND find_first_var_creation_block;
?? TITLE := 'initialize_variable_value', EJECT ??

  PROCEDURE initialize_variable_value
    (    name: clt$variable_name;
         initial_value: ^clt$data_value;
         type_description: ^clt$type_description;
     VAR work_area {input, output} : ^clt$work_area;
     VAR descriptor_header {input, output} : clt$variable_descriptor_header;
     VAR status: ost$status);

    VAR
      internal_value: ^clt$internal_data_value,
      original_work_area: ^clt$work_area,
      type_conformance: clt$type_conformance;


    status.normal := TRUE;
    original_work_area := work_area;

  /initialize_value/
    BEGIN
      IF (initial_value <> NIL) AND (initial_value^.kind <> clc$unspecified) THEN
        IF initial_value^.kind <> clc$deferred THEN
          clp$evaluate_value_conformance (initial_value, type_description, clc$conforms_to_type, status);
          IF NOT status.normal THEN
            EXIT /initialize_value/;
          IFEND;
        IFEND;
        internal_value := NIL;
        clp$convert_ext_value_to_int (type_description, initial_value, NIL, work_area, internal_value,
              status);
      ELSE
        clp$create_default_init_value (type_description, work_area, internal_value, status);
        IF status.normal AND (internal_value = NIL) THEN
          EXIT /initialize_value/;
        IFEND;
      IFEND;

      IF NOT status.normal THEN
        IF status.condition = cle$work_area_overflow THEN
          osp$set_status_abnormal ('CL', cle$no_space_for_variable, name, status);
        IFEND;
        EXIT /initialize_value/;
      ELSEIF (clv$total_variable_allocation + #SIZE (internal_value^)) > clv$max_variable_allocation THEN
        osp$set_status_abnormal ('CL', cle$no_space_for_variable, name, status);
        EXIT /initialize_value/;
      IFEND;

      ALLOCATE descriptor_header.value: [[REP #SIZE (internal_value^.allocated_space) OF cell]] IN
            osv$task_shared_heap^;
      clv$total_variable_allocation := clv$total_variable_allocation + #SIZE (internal_value^);

      descriptor_header.value^ := internal_value^;
    END /initialize_value/;

    work_area := original_work_area;

  PROCEND initialize_variable_value;
?? TITLE := 'internal_create_environment_var', EJECT ??

  PROCEDURE internal_create_environment_var
    (    name: clt$variable_name;
         access_mode: clt$data_access_mode;
         evaluation_method: clt$expression_eval_method;
         type_specification: ^clt$type_specification;
         scope: clt$environment_variable_scope;
         utility_name: utility_name_definition;
         type_description: ^clt$type_description;
         initial_value: ^clt$data_value;
         require_existing_var_for_push: boolean;
     VAR return_variable_value {input, output} : conversion_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      allowed_classes: clt$internal_variable_classes,
      declarer_block: ^clt$block,
      declarer_variable_access: ^clt$variable_access,
      descriptor: ^clt$variable_descriptor,
      descriptor_header: clt$variable_descriptor_header,
      hash: clt$variable_name_hash,
      hashed_name: clt$variable_name,
      ignore_associated_utility: boolean,
      inherited_allowed_classes: clt$internal_variable_classes,
      inherited_block: ^clt$block,
      local_access_mode: clt$data_access_mode,
      local_class: clt$internal_variable_class,
      local_type_specification: ^clt$type_specification,
      pushed_variable_information: clt$variable_information,
      type_conformance: clt$type_conformance,
      xref_block: ^clt$block,
      xref_variable_access: ^clt$variable_access;

?? NEWTITLE := 'process_push_scope', EJECT ??

    PROCEDURE process_push_scope;

      VAR
        access_variable_requests: clt$access_variable_requests,
        ignore_access_handle: clt$variable_access_handle;

?? NEWTITLE := 'initialize_push_variable_value', EJECT ??

      PROCEDURE [INLINE] initialize_push_variable_value;

        VAR
          initial_value_size: clt$internal_data_value_size;


        initial_value_size := #SIZE (pushed_variable_information.internal_value^.allocated_space);
        IF (clv$total_variable_allocation + initial_value_size) > clv$max_variable_allocation THEN
          osp$set_status_abnormal ('CL', cle$no_space_for_variable, name, status);
          EXIT internal_create_environment_var;
        IFEND;

        ALLOCATE descriptor_header.value: [[REP #SIZE (pushed_variable_information.
              internal_value^.allocated_space) OF cell]] IN osv$task_shared_heap^;
        clv$total_variable_allocation := clv$total_variable_allocation +
          #SIZE (pushed_variable_information.internal_value^);
        descriptor_header.value^ := pushed_variable_information.internal_value^;

      PROCEND initialize_push_variable_value;
?? OLDTITLE, EJECT ??



      access_variable_requests := $clt$access_variable_requests [clc$return_type_description];
      IF require_existing_var_for_push THEN
        access_variable_requests := access_variable_requests +
              $clt$access_variable_requests [clc$return_type_specification];
      IFEND;
      IF initial_value = NIL THEN
        access_variable_requests := access_variable_requests +
              $clt$access_variable_requests [clc$return_internal_value];
      IFEND;

      clp$access_variable (name, hashed_name, hash, FALSE, access_variable_requests, work_area,
            pushed_variable_information, ignore_access_handle, status);
      IF NOT status.normal THEN
        EXIT internal_create_environment_var;
      IFEND;

      IF pushed_variable_information.access_info_found THEN
        CASE pushed_variable_information.class OF
        = clc$env_variable, clc$lib_variable, clc$pushed_variable =
          ;
        ELSE
          osp$set_status_abnormal ('CL', cle$cannot_push_variable, name, status);
          EXIT internal_create_environment_var;
        CASEND;

        descriptor_header.evaluation_method := pushed_variable_information.evaluation_method;

        IF require_existing_var_for_push THEN
          local_type_specification := pushed_variable_information.type_specification;
        ELSE
          clp$evaluate_type_conformance (type_description, pushed_variable_information.type_description,
                clc$identical_types, status);
          IF NOT status.normal THEN
            EXIT internal_create_environment_var;
          IFEND;
        IFEND;

        IF (initial_value = NIL) AND (NOT pushed_variable_information.has_no_internal_value) THEN
          initialize_push_variable_value;
        IFEND;

      ELSEIF require_existing_var_for_push THEN
        osp$set_status_abnormal ('CL', cle$unknown_variable, name, status);
        EXIT internal_create_environment_var;
      IFEND;

      local_access_mode := clc$read_write;
      local_class := clc$pushed_variable;

    PROCEND process_push_scope;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    local_access_mode := access_mode;
    local_type_specification := type_specification;
    local_class := clc$env_variable;
    descriptor_header.access_count := 0;
    descriptor_header.evaluation_method := evaluation_method;
    descriptor_header.value := NIL;
    descriptor_header.library := NIL;

    clp$compute_variable_name_hash (name, hashed_name, hash);
    allowed_classes := $clt$internal_variable_classes [clc$env_variable, clc$xrefed_variable,
          clc$pushed_variable];
    find_first_var_creation_block (allowed_classes, inherited_allowed_classes, inherited_block,
          declarer_block);
    xref_block := declarer_block;

  /find_declarer_block/
    BEGIN
      WHILE declarer_block <> NIL DO
        CASE scope OF
        = clc$job_scope =
          IF (declarer_block^.kind = clc$task_block) AND (declarer_block^.task_kind = clc$job_monitor_task)
                THEN
            EXIT /find_declarer_block/;
          IFEND;
        = clc$environment_scope =
          EXIT /find_declarer_block/;
        = clc$task_scope =
          IF declarer_block^.kind = clc$task_block THEN
            EXIT /find_declarer_block/;
          IFEND;
        = clc$utility_scope =
          IF (declarer_block^.kind = clc$utility_block) AND ((NOT utility_name.defined) OR
                (declarer_block^.label = utility_name.value)) THEN
            EXIT /find_declarer_block/;
          IFEND;
        = clc$push_scope =
          process_push_scope;
          EXIT /find_declarer_block/;
        ELSE

{ Should not get here.

          osp$set_status_abnormal ('CL', cle$bad_variable_scope, name, status);
          RETURN;
        CASEND;
        clp$find_next_var_block (allowed_classes, inherited_allowed_classes, inherited_block, declarer_block,
              ignore_associated_utility);
      WHILEND;
      IF utility_name.defined THEN
        osp$set_status_abnormal ('CL', cle$unknown_utility, utility_name.value, status);
      ELSE
        osp$set_status_abnormal ('CL', cle$no_utility_active, '', status);
      IFEND;
      RETURN;
    END /find_declarer_block/;

    IF descriptor_header.value = NIL THEN

{ This is the usual path.  Process_push_scope sometimes creates the value.

      initialize_variable_value (name, initial_value, type_description, work_area, descriptor_header, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF return_variable_value.converted THEN
      clp$convert_int_to_var_value (descriptor_header.value, return_variable_value.max_string_size,
            return_variable_value.converted_value, status);
      IF NOT status.normal THEN
        IF descriptor_header.value <> NIL THEN
          clv$total_variable_allocation := clv$total_variable_allocation - #SIZE (descriptor_header.value^);
          FREE descriptor_header.value IN osv$task_shared_heap^;
        IFEND;
        RETURN;
      IFEND;
    IFEND;

    clp$add_variable_to_tree (hashed_name, hash, local_class, declarer_block^.variables,
          declarer_variable_access);

    IF declarer_variable_access = NIL THEN

{ A variable already exists by the same name in the declarer block.

      IF descriptor_header.value <> NIL THEN
        clv$total_variable_allocation := clv$total_variable_allocation - #SIZE (descriptor_header.value^);
        FREE descriptor_header.value IN osv$task_shared_heap^;
      IFEND;
      osp$set_status_abnormal ('CL', cle$var_already_created, name, status);
      RETURN;
    ELSEIF declarer_block <> xref_block THEN
      clp$add_variable_to_tree (hashed_name, hash, clc$xrefed_variable, xref_block^.variables,
            xref_variable_access);
      IF xref_variable_access = NIL THEN

{ A variable already exists by the same name in the xref block.

        clp$delete_variable_from_tree (hashed_name, hash, $clt$internal_variable_classes [local_class],
              declarer_block^.variables, descriptor);
        IF descriptor_header.value <> NIL THEN
          clv$total_variable_allocation := clv$total_variable_allocation - #SIZE (descriptor_header.value^);
          FREE descriptor_header.value IN osv$task_shared_heap^;
        IFEND;
        osp$set_status_abnormal ('CL', cle$var_already_created, name, status);
        RETURN;
      IFEND;
    IFEND;

    ALLOCATE descriptor: [[REP #SIZE (local_type_specification^) OF cell]] IN osv$task_shared_heap^;
    descriptor^.header := descriptor_header;
    descriptor^.type_specification := local_type_specification^;

    complete_variable_access (local_access_mode, local_class, descriptor, NIL, declarer_variable_access);
    IF declarer_block <> xref_block THEN
      complete_variable_access (local_access_mode, clc$xrefed_variable, descriptor, NIL,
            xref_variable_access);
    IFEND;

  PROCEND internal_create_environment_var;
?? TITLE := 'internal_create_procedure_var', EJECT ??

  PROCEDURE internal_create_procedure_var
    (    name: clt$variable_name;
         access_mode: clt$data_access_mode;
         evaluation_method: clt$expression_eval_method;
         type_specification: ^clt$type_specification;
         scope: clt$procedure_variable_scope;
         type_description: ^clt$type_description;
         initial_value: ^clt$data_value;
     VAR return_variable_value {input, output} : conversion_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      allowed_classes: clt$internal_variable_classes,
      block: ^clt$block,
      class: clt$internal_variable_class,
      declarer_type_description: clt$type_description,
      descriptor: ^clt$variable_descriptor,
      descriptor_header: clt$variable_descriptor_header,
      hash: clt$variable_name_hash,
      hashed_name: clt$variable_name,
      ignore_associated_utility: boolean,
      inherited_allowed_class: clt$internal_variable_classes,
      inherited_block: ^clt$block,
      type_conformance: clt$type_conformance,
      variable_access: ^clt$variable_access,
      variable_access_info: ^clt$variable_access_info,
      variable_block: ^clt$block;


    status.normal := TRUE;
    descriptor := NIL;

    allowed_classes := $clt$internal_variable_classes [clc$xdcled_variable, clc$env_variable,
          clc$lib_variable, clc$pushed_variable, clc$xrefed_variable];
    find_first_var_creation_block (allowed_classes, inherited_allowed_class, inherited_block, block);
    clp$compute_variable_name_hash (name, hashed_name, hash);

    IF scope = clc$xref_scope THEN
      variable_block := block;

    /find_declarer_variable/
      BEGIN

      /find_var_block/
        WHILE TRUE DO
          IF variable_block = NIL THEN
            EXIT /find_var_block/;
          IFEND;

          clp$find_variable_access (name, hashed_name, hash, allowed_classes, variable_block,
                variable_access_info);
          IF variable_access_info <> NIL THEN
            EXIT /find_declarer_variable/;
          IFEND;

          clp$find_next_var_block (allowed_classes, inherited_allowed_class, inherited_block, variable_block,
                ignore_associated_utility);

        WHILEND /find_var_block/;
        osp$set_status_abnormal ('CL', cle$unknown_variable, name, status);
        RETURN;
      END /find_declarer_variable/;

      IF (variable_access_info^.access_mode = clc$read_only) AND (access_mode = clc$read_write) THEN
        osp$set_status_abnormal ('CL', cle$bad_variable_access_mode, name, status);
        RETURN;
      IFEND;

      descriptor := variable_access_info^.descriptor;
      clp$convert_type_spec_to_desc (^descriptor^.type_specification, work_area, declarer_type_description,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$evaluate_type_conformance (type_description, ^declarer_type_description, clc$identical_types,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      descriptor_header := descriptor^.header;
      class := clc$xrefed_variable;
    ELSE
      descriptor_header.access_count := 0;
      descriptor_header.evaluation_method := evaluation_method;
      descriptor_header.value := NIL;
      descriptor_header.library := NIL;

      initialize_variable_value (name, initial_value, type_description, work_area, descriptor_header, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF scope = clc$xdcl_scope THEN
        class := clc$xdcled_variable;
      ELSE
        class := clc$proc_variable;
      IFEND;
    IFEND;

    IF return_variable_value.converted THEN
      clp$convert_int_to_var_value (descriptor_header.value, return_variable_value.max_string_size,
            return_variable_value.converted_value, status);
      IF NOT status.normal THEN
        IF (scope <> clc$xref_scope) AND (descriptor_header.value <> NIL) THEN
          clv$total_variable_allocation := clv$total_variable_allocation - #SIZE (descriptor_header.value^);
          FREE descriptor_header.value IN osv$task_shared_heap^;
        IFEND;
        RETURN;
      IFEND;
    IFEND;

    clp$add_variable_to_tree (hashed_name, hash, class, block^.variables, variable_access);

{ A variable already exists by the same name in the block.

    IF variable_access = NIL THEN
      osp$set_status_abnormal ('CL', cle$var_already_created, name, status);
      IF (scope <> clc$xref_scope) AND (descriptor_header.value <> NIL) THEN
        clv$total_variable_allocation := clv$total_variable_allocation - #SIZE (descriptor_header.value^);
        FREE descriptor_header.value IN osv$task_shared_heap^;
      IFEND;
      RETURN;
    IFEND;

    IF descriptor = NIL THEN
      ALLOCATE descriptor: [[REP #SIZE (type_specification^) OF cell]] IN osv$task_shared_heap^;
      descriptor^.header := descriptor_header;
      descriptor^.type_specification := type_specification^;
    IFEND;
    complete_variable_access (access_mode, class, descriptor, NIL, variable_access);

  PROCEND internal_create_procedure_var;
?? TITLE := 'variable_abort_handler', EJECT ??

  PROCEDURE variable_abort_handler
    (    condition: pmt$condition;
         ignore_condition_information: ^pmt$condition_information;
         ignore_save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);


    osp$clear_job_signature_lock (clv$variable_access_lock);

  PROCEND variable_abort_handler;
*IFEND

MODEND clm$variable_storage_manager;
*DECK DECK=CLM$WHEN_CONDITION_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : WHEN/WHENEND Condition Manager' ??
MODULE clm$when_condition_manager;

{
{ PURPOSE:
{   This module contains the procedures that manage WHEN condition processing information.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$compiling_for_test_harness
*copyc cle$ecc_control_statement
*copyc cle$unexpected_call_to
*copyc clt$collect_statement_area
*copyc clt$condition_processed_state
*copyc clt$established_handler_index
*copyc clt$established_handlers
*copyc clt$when_conditions
*copyc oss$task_shared
*copyc ost$caller_identifier
*copyc ost$status
?? POP ??
*copyc clp$create_procedure_variable
*copyc clp$find_current_block
*copyc clp$pop_input_stack
*copyc clp$save_collect_statement_area
*copyc clp$trimmed_string_size
*copyc osp$decrement_locked_variable
*copyc osp$fetch_locked_variable
*copyc osp$increment_locked_variable
*copyc osp$set_status_abnormal
*copyc osp$verify_system_privilege
*copyc osv$task_shared_heap
?? TITLE := 'clv$execution_fault_hndlr_count', EJECT ??

{ This variable is used to keep track of whether there are any WHEN/WHENEND
{ condition handlers established specifically for clc$wc_EXECUTION_FAULT.
{ This information is used to optimize the processing of abnormally
{ terminating commands in the absence of such a handler.  This variable must
{ always be accessed using the "locked variable" interfaces.

  VAR
    clv$execution_fault_hndlr_count: [STATIC, oss$task_shared] integer := 0;

?? TITLE := 'clp$continue', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$continue
    (    continue_when_condition_option: clt$condition_processed_state;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      target_block: ^clt$block;


    ?IF NOT clc$compiling_for_test_harness THEN
      osp$verify_system_privilege;
    ?IFEND;

    status.normal := TRUE;
    clp$find_current_block (block);
    target_block := block;

  /find_when_block/
    WHILE target_block <> NIL DO
      CASE target_block^.kind OF
      = clc$block_block, clc$command_block, clc$for_block, clc$if_block, clc$input_block, clc$loop_block,
            clc$repeat_block, clc$while_block =
        target_block := target_block^.previous_block;
      = clc$when_block =
        EXIT /find_when_block/;
      ELSE
        target_block := NIL;
        EXIT /find_when_block/;
      CASEND;
    WHILEND /find_when_block/;

    IF target_block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'CONTINUE', status);
      RETURN;
    IFEND;

    WHILE TRUE DO
      block^.interpreter_mode := clc$skip_mode;
      block^.being_exited := TRUE;
      IF block = target_block THEN
        block^.when_condition^.condition_processed_state := continue_when_condition_option;
        RETURN;
      IFEND;
      block := block^.previous_block;
    WHILEND;

  PROCEND clp$continue;
?? TITLE := 'clp$disestablish_cond_handler', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$disestablish_cond_handler
    (    any_condition: boolean;
         any_fault: boolean;
         specific_conditions: ^clt$when_conditions);

    VAR
      block: ^clt$block;


    ?IF NOT clc$compiling_for_test_harness THEN
      osp$verify_system_privilege;
    ?IFEND;

    find_block_for_handler (block);
    IF (block = NIL) OR (NOT handlers_in_block (block)) THEN
      RETURN;
    IFEND;

    disestablish_cond_handler (any_condition, any_fault, specific_conditions, block);

  PROCEND clp$disestablish_cond_handler;
?? TITLE := 'clp$establish_condition_handler', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$establish_condition_handler
    (    any_condition: boolean;
         any_fault: boolean;
         specific_conditions: ^clt$when_conditions;
         statement_area: ^clt$collect_statement_area;
         can_be_echoed: boolean;
     VAR status: ost$status);

    VAR
      block: ^clt$block,
      caller_id: ost$caller_identifier,
      i: clt$established_handler_index,
      ignore_count: integer,
      handler_statements: ^clt$established_handler_stmnts,
      new_established_handlers: ^clt$established_handlers;

?? NEWTITLE := 'eliminate_duplicate_handlers', EJECT ??

    PROCEDURE [INLINE] eliminate_duplicate_handlers
      (VAR specific_handler_count {input, output} : clt$established_handler_count;
       VAR specific_handlers {input, output} : clt$established_handlers);

      VAR
        duplicate_count: clt$established_handler_count,
        i: clt$established_handler_index,
        j: clt$established_handler_index;


      i := 1;
      WHILE i < specific_handler_count DO
        j := i + 1;
        WHILE (j <= specific_handler_count) AND (specific_handlers [i].condition =
              specific_handlers [j].condition) DO
          free_handler_statements (specific_handlers [j].statements);
          j := j + 1;
        WHILEND;
        duplicate_count := j - i - 1;
        IF duplicate_count > 0 THEN
          WHILE j <= specific_handler_count DO
            specific_handlers [j - duplicate_count] := specific_handlers [j];
            j := j + 1;
          WHILEND;
          specific_handler_count := specific_handler_count - duplicate_count;
        IFEND;
        i := i + 1;
      WHILEND;

    PROCEND eliminate_duplicate_handlers;
?? TITLE := 'sort_handlers', EJECT ??

    PROCEDURE [INLINE] sort_handlers
      (    specific_handler_count: clt$established_handler_count;
       VAR specific_handlers {input, output} : clt$established_handlers);

      VAR
        current: -clc$max_established_handlers .. clc$max_established_handlers,
        gap: clt$established_handler_index,
        start: clt$established_handler_index,
        swap: clt$established_handler;

      VAR
        duplicate_count: clt$established_handler_count,
        i: clt$established_handler_index,
        j: clt$established_handler_index;


{ Use shell sort technique to sort the specific_handlers array.

      gap := specific_handler_count;
      WHILE gap > 1 DO
        gap := 2 * (gap DIV 4) + 1;
        FOR start := 1 TO specific_handler_count - gap DO
          current := start;
          WHILE (current > 0) AND (specific_handlers [current].condition >
                specific_handlers [current + gap].condition) DO
            swap := specific_handlers [current];
            specific_handlers [current] := specific_handlers [current + gap];
            specific_handlers [current + gap] := swap;
            current := current - gap;
          WHILEND;
        FOREND;
      WHILEND;

    PROCEND sort_handlers;
?? OLDTITLE, EJECT ??

    ?IF NOT clc$compiling_for_test_harness THEN
      osp$verify_system_privilege;
    ?IFEND;

    status.normal := TRUE;
    #CALLER_ID (caller_id);

    find_block_for_handler (block);
    IF block = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'clp$establish_condition_handler', status);
      RETURN;
    IFEND;

    IF handlers_in_block (block) THEN
      disestablish_cond_handler (any_condition, any_fault, specific_conditions, block);
    IFEND;

    ALLOCATE handler_statements: [[REP #SIZE (statement_area^) OF cell]] IN osv$task_shared_heap^;
    handler_statements^.established_count := 0;
    handler_statements^.establishing_ring := caller_id.ring;
    handler_statements^.can_be_echoed := can_be_echoed;
    handler_statements^.statement_area := statement_area^;

    IF any_condition THEN
      block^.established_handler_info.any_condition_handler := handler_statements;
      handler_statements^.established_count := handler_statements^.established_count + 1;
    IFEND;

    IF any_fault THEN
      block^.established_handler_info.any_fault_handler := handler_statements;
      handler_statements^.established_count := handler_statements^.established_count + 1;
    IFEND;

    IF specific_conditions <> NIL THEN
      IF block^.established_handler_info.specific_handler_count = 0 THEN
        ALLOCATE block^.established_handler_info.specific_handlers:
              [1 .. UPPERBOUND (specific_conditions^)] IN osv$task_shared_heap^;
      ELSEIF (block^.established_handler_info.specific_handler_count + UPPERBOUND (specific_conditions^)) >
            UPPERBOUND (block^.established_handler_info.specific_handlers^) THEN
        ALLOCATE new_established_handlers: [1 .. block^.established_handler_info.
              specific_handler_count + UPPERBOUND (specific_conditions^)] IN osv$task_shared_heap^;
        FOR i := 1 TO block^.established_handler_info.specific_handler_count DO
          new_established_handlers^ [i] := block^.established_handler_info.specific_handlers^ [i];
        FOREND;
        FREE block^.established_handler_info.specific_handlers IN osv$task_shared_heap^;
        block^.established_handler_info.specific_handlers := new_established_handlers;
      IFEND;

      FOR i := 1 TO UPPERBOUND (specific_conditions^) DO
        block^.established_handler_info.specific_handler_count :=
              block^.established_handler_info.specific_handler_count + 1;
        block^.established_handler_info.specific_handlers^ [block^.established_handler_info.
              specific_handler_count].condition := specific_conditions^ [i];
        block^.established_handler_info.specific_handlers^ [block^.established_handler_info.
              specific_handler_count].statements := handler_statements;
        handler_statements^.established_count := handler_statements^.established_count + 1;
        IF specific_conditions^ [i] = clc$wc_execution_fault THEN
          osp$increment_locked_variable (clv$execution_fault_hndlr_count, 0, ignore_count);
        IFEND;
      FOREND;

      sort_handlers (block^.established_handler_info.specific_handler_count,
            block^.established_handler_info.specific_handlers^);
      eliminate_duplicate_handlers (block^.established_handler_info.specific_handler_count,
            block^.established_handler_info.specific_handlers^);
    IFEND;

  PROCEND clp$establish_condition_handler;
?? TITLE := 'clp$execution_fault_handler_est', EJECT ??

  FUNCTION [XDCL, #GATE, UNSAFE] clp$execution_fault_handler_est: boolean;

    VAR
      count: integer;


    osp$fetch_locked_variable (clv$execution_fault_hndlr_count, count);
    clp$execution_fault_handler_est := count > 0;

  FUNCEND clp$execution_fault_handler_est;
?? TITLE := 'clp$free_all_handlers', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$free_all_handlers;

    VAR
      block: ^clt$block;


    find_block_for_handler (block);
    IF (block = NIL) OR (NOT handlers_in_block (block)) THEN
      clp$find_current_block (block);
      IF (block^.kind <> clc$task_block) OR (block^.task_kind <> clc$job_monitor_task) OR
            (NOT handlers_in_block (block)) THEN
        RETURN;
      IFEND;
    IFEND;

    clp$free_all_handlers_in_block (block);

  PROCEND clp$free_all_handlers;
?? TITLE := 'clp$free_all_handlers_in_block', EJECT ??

  PROCEDURE [XDCL] clp$free_all_handlers_in_block
    (    block: ^clt$block);

    VAR
      i: clt$established_handler_index;


    IF block^.established_handler_info.any_condition_handler <> NIL THEN
      free_handler_statements (block^.established_handler_info.any_condition_handler);
    IFEND;

    IF block^.established_handler_info.any_fault_handler <> NIL THEN
      free_handler_statements (block^.established_handler_info.any_fault_handler);
    IFEND;

    IF block^.established_handler_info.specific_handlers <> NIL THEN
      FOR i := 1 TO block^.established_handler_info.specific_handler_count DO
        free_handler_statements (block^.established_handler_info.specific_handlers^ [i].statements);
      FOREND;
      FREE block^.established_handler_info.specific_handlers IN osv$task_shared_heap^;
    IFEND;

    block^.established_handler_info.specific_handler_count := 0;

  PROCEND clp$free_all_handlers_in_block;
?? TITLE := 'disestablish_cond_handler', EJECT ??

  PROCEDURE disestablish_cond_handler
    (    any_condition: boolean;
         any_fault: boolean;
         specific_conditions: ^clt$when_conditions;
         block: ^clt$block);

    VAR
      handler_found: boolean,
      handler_index: clt$established_handler_index,
      i: clt$established_handler_index,
      ignore_count: integer,
      ignore_count_error: boolean;


    IF any_condition AND (block^.established_handler_info.any_condition_handler <> NIL) THEN
      free_handler_statements (block^.established_handler_info.any_condition_handler);
    IFEND;

    IF any_fault AND (block^.established_handler_info.any_fault_handler <> NIL) THEN
      free_handler_statements (block^.established_handler_info.any_fault_handler);
    IFEND;

    IF (block^.established_handler_info.specific_handler_count > 0) AND (specific_conditions <> NIL) THEN
      FOR i := 1 TO UPPERBOUND (specific_conditions^) DO
        search_established_handlers (specific_conditions^ [i],
              block^.established_handler_info.specific_handlers,
              block^.established_handler_info.specific_handler_count, handler_index, handler_found);

        IF handler_found THEN
          free_handler_statements (block^.established_handler_info.specific_handlers^ [handler_index].
                statements);
          FOR handler_index := handler_index + 1 TO block^.established_handler_info.specific_handler_count DO
            block^.established_handler_info.specific_handlers^ [handler_index - 1] :=
                  block^.established_handler_info.specific_handlers^ [handler_index];
          FOREND;
          block^.established_handler_info.specific_handler_count :=
                block^.established_handler_info.specific_handler_count - 1;
          IF specific_conditions^ [i] = clc$wc_execution_fault THEN
            osp$decrement_locked_variable (clv$execution_fault_hndlr_count, 1, ignore_count,
                  ignore_count_error);
          IFEND;
        IFEND;
      FOREND;
    IFEND;

    IF (block^.established_handler_info.specific_handler_count = 0) AND
          (block^.established_handler_info.specific_handlers <> NIL) THEN
      FREE block^.established_handler_info.specific_handlers IN osv$task_shared_heap^;
    IFEND;

  PROCEND disestablish_cond_handler;
?? TITLE := 'find_block_for_handler', EJECT ??

  PROCEDURE [INLINE] find_block_for_handler
    (VAR block: ^clt$block);


    clp$find_current_block (block);

    WHILE block <> NIL DO
      CASE block^.kind OF

      = clc$command_proc_block, clc$function_proc_block, clc$when_block =
        RETURN;

      = clc$input_block =
        IF (block^.associated_utility <> NIL) OR ((block^.previous_block^.kind = clc$task_block) AND
              ((block^.previous_block^.task_kind = clc$task_statement_task) OR
              (block^.previous_block^.task_kind = clc$job_monitor_task))) THEN
          RETURN;
        IFEND;

      ELSE
        ;
      CASEND;

      block := block^.previous_block;
    WHILEND;

  PROCEND find_block_for_handler;
?? TITLE := 'free_handler_statements', EJECT ??

  PROCEDURE [INLINE] free_handler_statements
    (VAR handler_statements {input, output} : ^clt$established_handler_stmnts);


    handler_statements^.established_count := handler_statements^.established_count - 1;

    IF handler_statements^.established_count <= 0 THEN
      FREE handler_statements IN osv$task_shared_heap^;
    IFEND;

    handler_statements := NIL;

  PROCEND free_handler_statements;
?? TITLE := 'handlers_in_block', EJECT ??

  FUNCTION [INLINE] handlers_in_block
    (    block: ^clt$block): boolean;


    handlers_in_block := (block^.established_handler_info.any_condition_handler <> NIL) OR
          (block^.established_handler_info.any_fault_handler <> NIL) OR
          (block^.established_handler_info.specific_handler_count > 0);

  FUNCEND handlers_in_block;
?? TITLE := 'search_established_handlers', EJECT ??

  PROCEDURE [INLINE] search_established_handlers
    (    condition: clt$when_condition;
         handlers: ^clt$established_handlers;
         handler_count: clt$established_handler_count;
     VAR handler_index: clt$established_handler_index;
     VAR handler_found: boolean);

    VAR
      low_index: 1 .. clc$max_established_handlers + 1,
      temp: integer,
      high_index: 0 .. clc$max_established_handlers;


    handler_found := FALSE;

    IF (handlers <> NIL) AND (handler_count > 0) THEN
      low_index := 1;
      high_index := handler_count;
      REPEAT
        temp := low_index + high_index;
        handler_index := temp DIV 2;
        IF condition = handlers^ [handler_index].condition THEN
          handler_found := TRUE;
        ELSEIF condition > handlers^ [handler_index].condition THEN
          low_index := handler_index + 1;
        ELSE
          high_index := handler_index - 1;
        IFEND;
      UNTIL handler_found OR (low_index > high_index);
    IFEND;

  PROCEND search_established_handlers;

MODEND clm$when_condition_manager;
*DECK DECK=CLM$WILD_CARD_FILE_EXPANSION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Wild Card File Reference Expansion' ??
MODULE clm$wild_card_file_expansion;

{
{ PURPOSE:
{   This module contains request that expands a file reference containing
{   "wild cards" into a "list of file".
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$no_match_for_wild_card_file
*copyc cle$wild_card_cant_be_first
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$wc_file_expansion_option
*copyc clt$work_area
*copyc fsc$local
*copyc fst$evaluated_file_reference
*copyc fst$path_element_name
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc bap$process_pt_request
*copyc clp$build_pattern_for_wild_card
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_file_reference
*copyc clp$find_scl_options
*copyc clp$get_file_cycles
*copyc clp$get_list_of_$local_files
*copyc clp$make_file_value
*copyc clp$make_list_value
*copyc clp$make_value
*copyc clp$match_string_pattern
*copyc clp$trimmed_string_size
*copyc clv$open_position_designator
*copyc fsp$convert_fs_structure_to_pf
*copyc fsp$path_element
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_multi_item_info

?? TITLE := 'clp$wild_card_file_expansion', EJECT ??
*copyc clh$wild_card_file_expansion

  PROCEDURE [XDCL, #GATE] clp$wild_card_file_expansion
    (    evaluated_file_reference: fst$evaluated_file_reference;
         expansion_option: clt$wc_file_expansion_option;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result_list_head: ^clt$data_value;
     VAR result_list_tail: ^clt$data_value;
     VAR status: ost$status);

    CONST
      max_cycle_reference = 5,
      max_open_position = 5,
      max_cycle_ref_open_pos_suffix = 1 + max_cycle_reference + 1 + max_open_position;

    TYPE
      chars = set of char;

    VAR
      current_list_node: ^^clt$data_value,
      cycle_ref_open_pos_suffix: string (max_cycle_ref_open_pos_suffix),
      cycle_ref_open_pos_suffix_size: 0 .. max_cycle_ref_open_pos_suffix,
      first_path_element: ^fst$path_element_string,
      include_catalogs: boolean,
      include_files: boolean,
      local_status: ost$status,
      open_pos_suffix_index: 1 .. max_cycle_ref_open_pos_suffix + 1,
      open_pos_suffix_size: 0 .. 1 + max_open_position,
      original_path: ^fst$path,
      original_path_size: fst$path_size,
      path: ^fst$file_reference,
      scl_options: ^clt$scl_options,
      traversal_count: integer,
      wild_card_characters: chars;

?? NEWTITLE := 'add_path_and_open_pos_to_list', EJECT ??

    PROCEDURE add_path_and_open_pos_to_list
      (    path: fst$file_reference);


      IF (STRLENGTH (path) + open_pos_suffix_size) > fsc$max_path_size THEN
        osp$set_status_abnormal ('CL', cle$file_reference_too_long, '', status);
        EXIT clp$wild_card_file_expansion;
      IFEND;

      IF (traversal_count > 1) AND path_is_in_list (path) THEN
        RETURN;
      IFEND;

      clp$make_list_value (work_area, current_list_node^);
      IF current_list_node^ = NIL THEN
        work_area_overflow;
      IFEND;
      clp$make_value (clc$file, work_area, current_list_node^^.element_value);
      IF current_list_node^^.element_value = NIL THEN
        work_area_overflow;
      IFEND;
      NEXT current_list_node^^.element_value^.file_value: [STRLENGTH (path) + open_pos_suffix_size] IN
            work_area;
      IF current_list_node^^.element_value^.file_value = NIL THEN
        work_area_overflow;
      IFEND;

      current_list_node^^.element_value^.file_value^ := path;
      IF open_pos_suffix_size > 0 THEN
        current_list_node^^.element_value^.file_value^ (STRLENGTH (path) + 1,
              open_pos_suffix_size) := cycle_ref_open_pos_suffix
              (open_pos_suffix_index, open_pos_suffix_size);
      IFEND;

      result_list_tail := current_list_node^;
      current_list_node := ^result_list_tail^.link;

    PROCEND add_path_and_open_pos_to_list;
?? TITLE := 'add_path_and_suffix_to_list', EJECT ??

    PROCEDURE add_path_and_suffix_to_list
      (    path: fst$file_reference);


      IF (STRLENGTH (path) + cycle_ref_open_pos_suffix_size) > fsc$max_path_size THEN
        osp$set_status_abnormal ('CL', cle$file_reference_too_long, '', status);
        EXIT clp$wild_card_file_expansion;
      IFEND;

      IF (traversal_count > 1) AND path_is_in_list (path) THEN
        RETURN;
      IFEND;

      clp$make_list_value (work_area, current_list_node^);
      IF current_list_node^ = NIL THEN
        work_area_overflow;
      IFEND;
      clp$make_value (clc$file, work_area, current_list_node^^.element_value);
      IF current_list_node^^.element_value = NIL THEN
        work_area_overflow;
      IFEND;
      NEXT current_list_node^^.element_value^.file_value: [STRLENGTH (path) +
            cycle_ref_open_pos_suffix_size] IN work_area;
      IF current_list_node^^.element_value^.file_value = NIL THEN
        work_area_overflow;
      IFEND;

      current_list_node^^.element_value^.file_value^ := path;
      IF cycle_ref_open_pos_suffix_size > 0 THEN
        current_list_node^^.element_value^.file_value^ (STRLENGTH (path) + 1,
              cycle_ref_open_pos_suffix_size) := cycle_ref_open_pos_suffix;
      IFEND;

      result_list_tail := current_list_node^;
      current_list_node := ^result_list_tail^.link;

    PROCEND add_path_and_suffix_to_list;
?? TITLE := 'add_path_to_list', EJECT ??

    PROCEDURE add_path_to_list
      (    path: fst$file_reference);


      IF (traversal_count > 1) AND path_is_in_list (path) THEN
        RETURN;
      IFEND;

      clp$make_list_value (work_area, current_list_node^);
      IF current_list_node^ = NIL THEN
        work_area_overflow;
      IFEND;
      clp$make_file_value (path, work_area, current_list_node^^.element_value);
      IF current_list_node^^.element_value = NIL THEN
        work_area_overflow;
      IFEND;
      result_list_tail := current_list_node^;
      current_list_node := ^result_list_tail^.link;

    PROCEND add_path_to_list;
?? TITLE := 'contains_wild_card', EJECT ??

    FUNCTION [INLINE] contains_wild_card
      (    path_element: ^fst$path_element_string): boolean;

      VAR
        ignore_scan_index: integer,
        scan_found_char: boolean;


      #SCAN (wild_card_characters, path_element^, ignore_scan_index, scan_found_char);
      contains_wild_card := scan_found_char;

    FUNCEND contains_wild_card;
?? TITLE := 'cycle_number_exists', EJECT ??

    FUNCTION cycle_number_exists
      (    cycles: pft$p_cycle_array): boolean;

      VAR
        i: pft$array_index;


      FOR i := LOWERBOUND (cycles^) TO UPPERBOUND (cycles^) DO
        IF cycles^ [i].cycle_number = evaluated_file_reference.cycle_reference.cycle_number THEN
          cycle_number_exists := TRUE;
          RETURN;
        IFEND;
      FOREND;

      cycle_number_exists := FALSE;

    FUNCEND cycle_number_exists;
?? TITLE := 'path_is_in_list', EJECT ??

    FUNCTION [INLINE] path_is_in_list
      (    path: fst$file_reference): boolean;

      VAR
        local_node: ^clt$data_value;


      local_node := result_list_head;

      WHILE local_node <> NIL DO
        IF local_node^.element_value^.file_value^ = path THEN
          path_is_in_list := TRUE;
          RETURN;
        IFEND;
        local_node := local_node^.link;
      WHILEND;

      path_is_in_list := FALSE;

    FUNCEND path_is_in_list;
?? TITLE := 'prepare_cycle_open_pos_suffix', EJECT ??

    PROCEDURE prepare_cycle_open_pos_suffix;

      VAR
        cycle_string: ost$string;


      cycle_ref_open_pos_suffix_size := 0;
      open_pos_suffix_index := 1;
      open_pos_suffix_size := 0;

      IF evaluated_file_reference.cycle_reference.specification <> fsc$cycle_omitted THEN
        include_catalogs := FALSE;
        CASE evaluated_file_reference.cycle_reference.specification OF
        = fsc$cycle_number =
          clp$convert_integer_to_string (evaluated_file_reference.cycle_reference.cycle_number, 10, FALSE,
                cycle_string, local_status);
          cycle_ref_open_pos_suffix_size := 1 + cycle_string.size;
          cycle_ref_open_pos_suffix (1) := '.';
          cycle_ref_open_pos_suffix (2, * ) := cycle_string.value (1, cycle_string.size);
        = fsc$high_cycle =
          cycle_ref_open_pos_suffix_size := 6;
          cycle_ref_open_pos_suffix := '.$HIGH';
        = fsc$low_cycle =
          cycle_ref_open_pos_suffix_size := 5;
          cycle_ref_open_pos_suffix := '.$LOW';
        = fsc$next_cycle =
          cycle_ref_open_pos_suffix_size := 6;
          cycle_ref_open_pos_suffix := '.$NEXT';
        ELSE
          ;
        CASEND;
        open_pos_suffix_index := cycle_ref_open_pos_suffix_size + 1;
      IFEND;

      IF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
        include_catalogs := FALSE;
        open_pos_suffix_size := clv$open_position_designator
              [evaluated_file_reference.path_handle_info.path_handle.open_position.value].size;
        cycle_ref_open_pos_suffix (cycle_ref_open_pos_suffix_size + 1) := '.';
        cycle_ref_open_pos_suffix (cycle_ref_open_pos_suffix_size + 2,
              open_pos_suffix_size) := clv$open_position_designator
              [evaluated_file_reference.path_handle_info.path_handle.open_position.value].
              value (1, open_pos_suffix_size);
        open_pos_suffix_size := 1 + open_pos_suffix_size;
        cycle_ref_open_pos_suffix_size := cycle_ref_open_pos_suffix_size + open_pos_suffix_size;
      IFEND;

    PROCEND prepare_cycle_open_pos_suffix;
?? TITLE := 'process_element', EJECT ??

    PROCEDURE process_element
      (    starting_path: fst$file_reference;
           starting_element_number: fst$number_of_path_elements);

      VAR
        current_path_element: ^fst$path_element_string,
        cycles: pft$p_cycle_array,
        directory: pft$p_directory_array,
        element_number: fst$number_of_path_elements,
        i: pft$array_index,
        item_is_catalog: boolean,
        local_status: ost$status,
        match_info: clt$string_pattern_match_info,
        name_size: ost$name_size,
        path: fst$path,
        path_size: fst$path_size,
        string_pattern: ^clt$string_pattern;

?? NEWTITLE := 'get_catalog_directory', EJECT ??

      PROCEDURE get_catalog_directory
        (    catalog: fst$file_reference;
         VAR directory: pft$p_directory_array);

        VAR
          evaluated_file_reference: fst$evaluated_file_reference,
          first_path_element_is_$local: boolean,
          group: pft$group,
          info: pft$p_info,
          info_record: pft$p_info_record,
          pf_path: ^pft$path;

?? NEWTITLE := 'sort_directory', EJECT ??

        PROCEDURE sort_directory;

          VAR
            gap: integer,
            start: integer,
            current: integer,
            swap: pft$directory_array_entry;

{ Use shell sort technique.

          gap := UPPERBOUND (directory^);
          WHILE gap > 1 DO
            gap := 2 * (gap DIV 4) + 1;
            FOR start := 1 TO UPPERBOUND (directory^) - gap DO
              current := start;
              WHILE (current > 0) AND (directory^ [current].name > directory^ [current + gap].name) DO
                swap := directory^ [current];
                directory^ [current] := directory^ [current + gap];
                directory^ [current + gap] := swap;
                current := current - gap;
              WHILEND;
            FOREND;
          WHILEND;

        PROCEND sort_directory;
?? OLDTITLE, EJECT ??

        directory := NIL;

        clp$evaluate_file_reference (catalog, $clt$file_ref_parsing_options [], FALSE,
              evaluated_file_reference, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;

        first_path_element_is_$local := fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local;

        IF first_path_element_is_$local AND (evaluated_file_reference.number_of_path_elements > 1) THEN
          RETURN;
        IFEND;

        info := work_area;

        IF first_path_element_is_$local THEN
          clp$get_list_of_$local_files (work_area, local_status);

        ELSE
          PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
          fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);

          group.group_type := pfc$member;
          group.member_description.family := osc$null_name;
          group.member_description.account := osc$null_name;
          group.member_description.project := osc$null_name;
          group.member_description.user := osc$null_name;

          pfp$get_multi_item_info (pf_path^, group, $pft$catalog_info_selections [pfc$catalog_directory],
                $pft$file_info_selections [pfc$file_directory], work_area, local_status);
        IFEND;

        IF NOT local_status.normal THEN
          RETURN;
        IFEND;

        pfp$find_next_info_record (info, info_record, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
        pfp$find_directory_array (info_record, directory, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;

        IF directory <> NIL THEN
          sort_directory;
        IFEND;

      PROCEND get_catalog_directory;
?? TITLE := 'get_catalog_item_info', EJECT ??

      PROCEDURE get_catalog_item_info
        (    path: fst$file_reference;
         VAR item_is_catalog: boolean;
         VAR cycles: pft$p_cycle_array);

        VAR
          cycle_array: ^array [1 .. * ] of fst$cycle_number,
          evaluated_file_reference: fst$evaluated_file_reference,
          first_path_element_is_$local: boolean,
          group: pft$group,
          i: pft$cycle_number,
          info: pft$p_info;

?? NEWTITLE := 'sort_cycles', EJECT ??

        PROCEDURE sort_cycles;

          VAR
            gap: integer,
            start: integer,
            current: integer,
            swap: pft$cycle_array_entry;

{ Use shell sort technique.

          gap := UPPERBOUND (cycles^);
          WHILE gap > 1 DO
            gap := 2 * (gap DIV 4) + 1;
            FOR start := 1 TO UPPERBOUND (cycles^) - gap DO
              current := start;
              WHILE (current > 0) AND (cycles^ [current].cycle_number < cycles^ [current + gap].
                    cycle_number) DO
                swap := cycles^ [current];
                cycles^ [current] := cycles^ [current + gap];
                cycles^ [current + gap] := swap;
                current := current - gap;
              WHILEND;
            FOREND;
          WHILEND;

        PROCEND sort_cycles;
?? OLDTITLE, EJECT ??

        item_is_catalog := FALSE;
        cycles := NIL;

        clp$evaluate_file_reference (path, $clt$file_ref_parsing_options [], FALSE, evaluated_file_reference,
              local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;

        first_path_element_is_$local := fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local;

        IF first_path_element_is_$local AND (evaluated_file_reference.number_of_path_elements = 1) THEN
          item_is_catalog := TRUE;
          RETURN;
        IFEND;

        clp$get_file_cycles (path, work_area, cycle_array, local_status);
        IF (NOT local_status.normal) THEN
          IF local_status.condition = pfe$name_not_permanent_file THEN
            item_is_catalog := TRUE;
          IFEND;
          RETURN;
        ELSEIF (cycle_array = NIL) THEN
          RETURN;
        IFEND;

        NEXT cycles: [1 .. UPPERBOUND (cycle_array^)] IN work_area;
        IF cycles = NIL THEN
          work_area_overflow;
        IFEND;
        FOR i := 1 TO UPPERBOUND (cycle_array^) DO
          cycles^ [i].cycle_number := cycle_array^ [i];
        FOREND;

        IF cycles <> NIL THEN
          sort_cycles;
        IFEND;

      PROCEND get_catalog_item_info;
?? TITLE := 'process_path_traversal', EJECT ??

      PROCEDURE process_path_traversal
        (    path: fst$file_reference;
             element_number: fst$number_of_path_elements);

        VAR
          directory: pft$p_directory_array,
          i: pft$array_index,
          sub_path: fst$path;


        process_element (path, element_number);

        get_catalog_directory (path, directory);
        IF directory <> NIL THEN
          sub_path := path;
          sub_path (STRLENGTH (path) + 1) := '.';

          FOR i := LOWERBOUND (directory^) TO UPPERBOUND (directory^) DO
            sub_path (STRLENGTH (path) + 2, * ) := directory^ [i].name;
            process_path_traversal (sub_path (1, STRLENGTH (path) +
                  1 + clp$trimmed_string_size (directory^ [i].name)), element_number);
          FOREND;
        IFEND;

      PROCEND process_path_traversal;
?? TITLE := 'process_subordinate_paths', EJECT ??

      PROCEDURE process_subordinate_paths
        (    path: fst$file_reference);

        VAR
          cycle_string: ost$string,
          cycles: pft$p_cycle_array,
          directory: pft$p_directory_array,
          i: pft$array_index,
          item_is_catalog: boolean,
          sub_path: fst$path;


        get_catalog_item_info (path, item_is_catalog, cycles);
        sub_path := path;
        sub_path (STRLENGTH (path) + 1) := '.';

        IF item_is_catalog THEN
          IF include_catalogs THEN
            add_path_to_list (path);
          IFEND;
          get_catalog_directory (path, directory);
          IF directory <> NIL THEN
            FOR i := LOWERBOUND (directory^) TO UPPERBOUND (directory^) DO
              sub_path (STRLENGTH (path) + 2, * ) := directory^ [i].name;
              process_subordinate_paths (sub_path (1, STRLENGTH (path) +
                    1 + clp$trimmed_string_size (directory^ [i].name)));
            FOREND;
          IFEND;

        ELSEIF (cycles <> NIL) AND include_files THEN
          CASE evaluated_file_reference.cycle_reference.specification OF
          = fsc$cycle_omitted =
            FOR i := LOWERBOUND (cycles^) TO UPPERBOUND (cycles^) DO
              clp$convert_integer_to_string (cycles^ [i].cycle_number, 10, FALSE, cycle_string,
                    {ignore} status);
              sub_path (STRLENGTH (path) + 2, * ) := cycle_string.value (1, cycle_string.size);
              add_path_and_open_pos_to_list (sub_path (1, STRLENGTH (path) + 1 + cycle_string.size));
            FOREND;
          = fsc$cycle_number =
            IF cycle_number_exists (cycles) THEN
              add_path_and_suffix_to_list (path);
            IFEND;
          ELSE
            add_path_and_suffix_to_list (path);
          CASEND;
        IFEND;

      PROCEND process_subordinate_paths;
?? OLDTITLE, EJECT ??

      path := starting_path;
      path_size := STRLENGTH (starting_path);
      element_number := starting_element_number;

      WHILE element_number <= evaluated_file_reference.number_of_path_elements DO
        current_path_element := fsp$path_element (^evaluated_file_reference, element_number);

        IF current_path_element^ = '$ALL' THEN
          IF element_number = evaluated_file_reference.number_of_path_elements THEN
            traversal_count := traversal_count + 1;
            process_subordinate_paths (path (1, path_size));
            traversal_count := traversal_count - 1;
            RETURN;
          IFEND;

{ If the next path element is also $ALL, ignore the current element.
{ This has the effect of treating adjacent $ALL's as if there's only one.

          IF fsp$path_element (^evaluated_file_reference, element_number + 1) ^ <> '$ALL' THEN
            traversal_count := traversal_count + 1;
            process_path_traversal (path (1, path_size), element_number + 1);
            traversal_count := traversal_count - 1;
            RETURN;
          IFEND;

        ELSEIF contains_wild_card (current_path_element) THEN
          get_catalog_directory (path (1, path_size), directory);
          IF directory = NIL THEN
            RETURN;
          IFEND;

          clp$build_pattern_for_wild_card (scl_options^.wild_card_pattern_type,
                $clt$string_pattern_build_opts [clc$sp_match_at_right, clc$sp_ignore_matched_substring],
                current_path_element^, work_area, string_pattern, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          FOR i := LOWERBOUND (directory^) TO UPPERBOUND (directory^) DO
            IF (directory^ [i].name_type = pfc$catalog_name) OR include_files THEN
              name_size := clp$trimmed_string_size (directory^ [i].name);
              clp$match_string_pattern (directory^ [i].name (1, name_size), string_pattern, clc$sp_anchored,
                    clc$sp_quick_scan, match_info, status);
              IF status.normal THEN
                IF match_info.result = clc$sp_success THEN
                  path (path_size + 1) := '.';
                  path (path_size + 2, name_size) := directory^ [i].name (1, name_size);
                  IF element_number < evaluated_file_reference.number_of_path_elements THEN
                    process_element (path (1, path_size + 1 + name_size), element_number + 1);
                  ELSEIF directory^ [i].name_type = pfc$file_name THEN
                    IF evaluated_file_reference.cycle_reference.specification <> fsc$cycle_number THEN
                      add_path_and_suffix_to_list (path (1, path_size + 1 + name_size));
                    ELSE
                      get_catalog_item_info (path (1, path_size + 1 + name_size), item_is_catalog, cycles);
                      IF (cycles <> NIL) AND cycle_number_exists (cycles) THEN
                        add_path_and_suffix_to_list (path (1, path_size + 1 + name_size));
                      IFEND;
                    IFEND;
                  ELSEIF include_catalogs THEN
                    add_path_to_list (path (1, path_size + 1 + name_size));
                  IFEND;
                IFEND;
              ELSE
                RETURN;
              IFEND;
            IFEND;
          FOREND;
          RETURN;

        ELSE
          path (path_size + 1) := '.';
          path (path_size + 2, STRLENGTH (current_path_element^)) := current_path_element^;
          path_size := path_size + 1 + STRLENGTH (current_path_element^);

          IF element_number = evaluated_file_reference.number_of_path_elements THEN
            get_catalog_item_info (path (1, path_size), item_is_catalog, cycles);
            IF item_is_catalog AND include_catalogs THEN
              add_path_to_list (path (1, path_size));
            ELSEIF (cycles <> NIL) AND include_files AND ((evaluated_file_reference.cycle_reference.
                  specification <> fsc$cycle_number) OR cycle_number_exists (cycles)) THEN
              add_path_and_suffix_to_list (path (1, path_size));
            IFEND;
            RETURN;
          IFEND;
        IFEND;

        element_number := element_number + 1;
      WHILEND;

    PROCEND process_element;
?? TITLE := 'work_area_overflow', EJECT ??

    PROCEDURE [INLINE] work_area_overflow;


      osp$set_status_abnormal ('CL', cle$work_area_overflow, 'clp$wild_card_file_expansion', status);
      EXIT clp$wild_card_file_expansion;

    PROCEND work_area_overflow;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    result_list_head := NIL;
    result_list_tail := NIL;
    traversal_count := 0;

    clp$find_scl_options (scl_options);

    IF scl_options^.wild_card_pattern_type = clc$wc_basic_pattern THEN
      wild_card_characters := $chars ['*', '?'];
    ELSE { clc$wc_extended_pattern }
      wild_card_characters := $chars ['*', '?', '[', '-', ']', '{', '}'];
    IFEND;

    first_path_element := fsp$path_element (^evaluated_file_reference, 1);
    IF (first_path_element^ = '$ALL') OR contains_wild_card (first_path_element) THEN
      osp$set_status_abnormal ('CL', cle$wild_card_cant_be_first, '', status);
      RETURN;
    IFEND;

    CASE expansion_option OF
    = clc$wcfe_only_files =
      include_files := TRUE;
      include_catalogs := FALSE;
    = clc$wcfe_only_catalogs =
      include_files := FALSE;
      include_catalogs := TRUE;
    ELSE {clc$wcfe_files_and_catalogs}
      include_files := TRUE;
      include_catalogs := TRUE;
    CASEND;

    current_list_node := ^result_list_head;

    prepare_cycle_open_pos_suffix;

    IF include_files OR include_catalogs THEN
      PUSH path: [1 + STRLENGTH (first_path_element^)];
      path^ (1) := ':';
      path^ (2, * ) := first_path_element^;
      IF (evaluated_file_reference.number_of_path_elements = 1) AND (first_path_element^ = '$LOCAL') AND
            include_catalogs THEN
        add_path_to_list (path^ (1, clp$trimmed_string_size (path^)));
        RETURN;
      IFEND;
      process_element (path^, 2);
    IFEND;

    IF result_list_head = NIL THEN
      PUSH original_path;
      clp$convert_file_ref_to_string (evaluated_file_reference, TRUE, original_path^, original_path_size,
            {ignore} status);
      IF original_path_size > osc$max_string_size THEN
        original_path_size := osc$max_string_size;
      IFEND;
      osp$set_status_abnormal ('CL', cle$no_match_for_wild_card_file, original_path^ (1, original_path_size),
            status);
    IFEND;

  PROCEND clp$wild_card_file_expansion;

MODEND clm$wild_card_file_expansion;
*DECK DECK=CLM$WORKING_CATALOG_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Set Working Catalog Path' ??
MODULE clm$working_catalog_manager;

{
{ PURPOSE:
{   This module contains the procedure that stores the working catalog.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc clt$environment_object_contents
*copyc clt$environment_object_size
*copyc clt$env_object_pop_reason
*copyc clt$env_object_push_reason
*copyc clt$working_catalog
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??
*copyc clp$find_working_catalog
*copyc osv$task_shared_heap
?? OLDTITLE ??
?? NEWTITLE := 'clp$eo_size_working_catalog', EJECT ??

  FUNCTION [XDCL] clp$eo_size_working_catalog: clt$environment_object_size;

    TYPE
      working_catalog_env_object = ^clt$working_catalog;


    clp$eo_size_working_catalog := #SIZE (working_catalog_env_object);

  FUNCEND clp$eo_size_working_catalog;
?? OLDTITLE ??
?? NEWTITLE := 'clp$eo_init_working_catalog', EJECT ??

  PROCEDURE [XDCL] clp$eo_init_working_catalog
    (    object: ^clt$environment_object_contents);

    VAR
      working_catalog: ^^clt$working_catalog;


    working_catalog := object;

    working_catalog^ := NIL;

  PROCEND clp$eo_init_working_catalog;
?? OLDTITLE ??
?? NEWTITLE := 'clp$eo_push_working_catalog', EJECT ??

  PROCEDURE [XDCL] clp$eo_push_working_catalog
    (    push_reason: clt$env_object_push_reason;
         new_object: ^clt$environment_object_contents;
         new_object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

    VAR
      new_working_catalog: ^^clt$working_catalog,
      old_working_catalog: ^^clt$working_catalog;


    status.normal := TRUE;

    new_working_catalog := new_object;
    old_working_catalog := pushed_object;

    IF old_working_catalog^ = NIL THEN
      new_working_catalog^ := NIL;
    ELSE
      ALLOCATE new_working_catalog^ IN osv$task_shared_heap^;
      new_working_catalog^^ := old_working_catalog^^;
    IFEND;

  PROCEND clp$eo_push_working_catalog;
?? OLDTITLE ??
?? NEWTITLE := 'clp$eo_pop_working_catalog', EJECT ??

  PROCEDURE [XDCL] clp$eo_pop_working_catalog
    (    pop_reason: clt$env_object_pop_reason;
         object: ^clt$environment_object_contents;
         object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

    VAR
      working_catalog: ^^clt$working_catalog;


    status.normal := TRUE;

    working_catalog := object;

    IF working_catalog^ <> NIL THEN
      FREE working_catalog^ IN osv$task_shared_heap^;
    IFEND;

  PROCEND clp$eo_pop_working_catalog;
?? OLDTITLE ??
?? NEWTITLE := 'clp$set_working_catalog_path', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_working_catalog_path
    (    working_catalog_path_handle: amt$local_file_name;
         evaluated_file_reference: fst$evaluated_file_reference);

    VAR
      working_catalog: ^^clt$working_catalog;


    clp$find_working_catalog (working_catalog);

    IF working_catalog^ = NIL THEN
      ALLOCATE working_catalog^ IN osv$task_shared_heap^;
    IFEND;

    working_catalog^^.handle := working_catalog_path_handle;
    working_catalog^^.evaluated_file_reference := evaluated_file_reference;

  PROCEND clp$set_working_catalog_path;
?? OLDTITLE ??

MODEND clm$working_catalog_manager;
*DECK DECK=CLM$WORK_AREA_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Work Area Manager' ??
MODULE clm$work_area_manager;

{
{ PURPOSE:
{   This module manages the task local work areas used by various SCL services.
{   Each task has, potentially, one work area per ring (3..13).  If a request
{   is made from ring 2, ring 3's work area is used.  Each work area is created
{   as a segment the first time it is needed.  The segment is used as a stack
{   to permit nested usages.  The stack is controlled by a sequence pointer
{   which is the first item of data in the segment.  The pointer is initialized
{   once the segment has been created.  Users of the work area manipulate this
{   pointer DIRECTLY to keep track of how much of the area they have used.
{   When a user obtains a pointer to a work area, its "current position" must
{   be treated as the beginning of the sequence, i.e. the user must NEVER use
{   any part of the sequence "behind" that point.
{
{ NOTE:
{   The maximum segment length for a work area is set to clv$work_area_size,
{   however the sequence pointer's size component is set to the maximum
{   possible value.  This is done so that attempts to access the work area
{   beyond its maximum segment length will always be "translated" to the
{   mmc$sac_read_write_beyond_msl segment access condition.  It also eliminates
{   the need to check for NIL after doing a NEXT in the work area.
{

?? NEWTITLE := 'Global Declarations' ??
?? NEWTITLE := 'clt$saved_work_area_positions', EJECT ??
*copyc clt$saved_work_area_positions
?? TITLE := 'clt$work_areas', EJECT ??
*copyc clt$work_areas
?? OLDTITLE, EJECT ??
?? PUSH (LISTEXT := ON) ??
*IF $true(osv$unix)
*copyc cle$work_area_overflow
*IFEND
*copyc oss$task_private
*copyc oss$task_shared
*copyc ost$caller_identifier
?? POP ??
*copyc mmp$create_segment
*IF $true(osv$unix)
*copyc osp$set_status_abnormal
*IFEND
?? EJECT ??

  VAR
    clv$work_areas: [XDCL, #GATE, oss$task_private] clt$work_areas :=
*IF NOT $true(osv$unix)
          [REP osc$user_ring_2 - osc$tsrv_ring + 1 of [1, NIL]];
*ELSE
          [1, NIL]
          ;
*IFEND

  VAR
*IF NOT $true(osv$unix)
    clv$work_area_size: [XDCL, oss$task_shared] ost$segment_length := 10000000(16);
*ELSE
    clv$work_area_size: [XDCL, oss$task_shared] ost$segment_length := 100000(16);
*IFEND

?? TITLE := 'clp$get_work_area', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$get_work_area
    (    work_area_ring: ost$valid_ring;
     VAR work_area: ^^clt$work_area;
     VAR status: ost$status);

*IF NOT $true(osv$unix)

    VAR
      caller_id: ost$caller_identifier,
      segment_attributes: array [1 .. 2] of mmt$attribute_descriptor,
      segment_pointer: mmt$segment_pointer;

*ELSE

    VAR
      new_work_area: ^clt$work_area;

*IFEND


    status.normal := TRUE;
    work_area := NIL;

*IF NOT $true(osv$unix)

    #CALLER_ID (caller_id);
    IF work_area_ring > caller_id.ring THEN
      caller_id.ring := work_area_ring;
    IFEND;
    IF caller_id.ring < osc$tsrv_ring THEN
      caller_id.ring := osc$tsrv_ring;
    ELSEIF caller_id.ring > osc$user_ring_2 THEN
      caller_id.ring := osc$user_ring_2;
    IFEND;

    IF clv$work_areas [caller_id.ring].pointer = NIL THEN
      segment_attributes [1].keyword := mmc$kw_max_segment_length;
      segment_attributes [1].max_length := clv$work_area_size;
      segment_attributes [2].keyword := mmc$kw_ring_numbers;
      segment_attributes [2].r1 := caller_id.ring;
      segment_attributes [2].r2 := osc$user_ring_2;
      mmp$create_segment (^segment_attributes, mmc$sequence_pointer, caller_id.ring, segment_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET segment_pointer.seq_pointer;
      NEXT clv$work_areas [caller_id.ring].pointer IN segment_pointer.seq_pointer;
      clv$work_areas [caller_id.ring].pointer^ := segment_pointer.seq_pointer;
      clv$work_areas [caller_id.ring].breakdown^.length := UPPERVALUE (clv$work_areas [caller_id.ring].
            breakdown^.length);
    IFEND;

    work_area := clv$work_areas [caller_id.ring].pointer;

*ELSE

    IF clv$work_areas.pointer = NIL THEN
      ALLOCATE new_work_area: [[REP clv$work_area_size OF cell]];
      IF new_work_area = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, 'clp$get_work_area', status);
        RETURN;
      IFEND;
      RESET new_work_area;
      NEXT clv$work_areas.pointer IN new_work_area;
      clv$work_areas.pointer^ := new_work_area;
    IFEND;

    work_area := clv$work_areas.pointer;

*IFEND

  PROCEND clp$get_work_area;
?? TITLE := 'clp$save_work_area_positions', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$save_work_area_positions
    (VAR saved_work_area_positions: clt$saved_work_area_positions);

*IF NOT $true(osv$unix)

    VAR
      ring: osc$tsrv_ring .. osc$user_ring_2;


    FOR ring := osc$tsrv_ring TO osc$user_ring_2 DO
      IF clv$work_areas [ring].breakdown = NIL THEN
        saved_work_area_positions [ring] := 0;
      ELSE
        saved_work_area_positions [ring] := clv$work_areas [ring].breakdown^.nextt;
      IFEND;
    FOREND;

*ELSE

    IF clv$work_areas.breakdown = NIL THEN
      saved_work_area_positions := 0;
    ELSE
      saved_work_area_positions := clv$work_areas.breakdown^.nextt;
    IFEND;

*IFEND

  PROCEND clp$save_work_area_positions;
?? TITLE := 'clp$restore_work_area_positions', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$restore_work_area_positions
    (    saved_work_area_positions: clt$saved_work_area_positions;
     VAR status: ost$status);

*IF NOT $true(osv$unix)

    VAR
      ring: osc$tsrv_ring .. osc$user_ring_2;


    status.normal := TRUE;
    FOR ring := osc$tsrv_ring TO osc$user_ring_2 DO
      IF clv$work_areas [ring].breakdown <> NIL THEN
        IF saved_work_area_positions [ring] = 0 THEN
          clv$work_areas [ring].breakdown^.nextt := #SIZE (cyt$sequence_pointer);
        ELSE
          clv$work_areas [ring].breakdown^.nextt := saved_work_area_positions [ring];
        IFEND;
      IFEND;
    FOREND;

*ELSE

    status.normal := TRUE;
    IF clv$work_areas.breakdown <> NIL THEN
      IF saved_work_area_positions = 0 THEN
        clv$work_areas.breakdown^.nextt := #SIZE (cyt$sequence_pointer);
      ELSE
        clv$work_areas.breakdown^.nextt := saved_work_area_positions;
      IFEND;
    IFEND;

*IFEND

  PROCEND clp$restore_work_area_positions;
?? TITLE := 'clp$reset_work_area_positions', EJECT ??

  PROCEDURE [XDCL] clp$reset_work_area_positions
    (VAR status: ost$status);

*IF NOT $true(osv$unix)

    VAR
      ring: osc$tsrv_ring .. osc$user_ring_2;


    status.normal := TRUE;
    FOR ring := osc$tsrv_ring TO osc$user_ring_2 DO
      IF clv$work_areas [ring].breakdown <> NIL THEN
        clv$work_areas [ring].breakdown^.nextt := #SIZE (cyt$sequence_pointer);
      IFEND;
    FOREND;

*ELSE

    status.normal := TRUE;
    IF clv$work_areas.breakdown <> NIL THEN
      clv$work_areas.breakdown^.nextt := #SIZE (cyt$sequence_pointer);
    IFEND;

*IFEND

  PROCEND clp$reset_work_area_positions;

MODEND clm$work_area_manager;
*DECK DECK=CLM$WRITE_TAPE_MARK_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE SCL Interpreter : Write Tapemark Command' ??

MODULE clm$write_tape_mark_command;

{
{ PURPOSE:
{   This module contains the processor for the write_tape_mark command.
{

?? NEWTITLE := '  Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc cle$ecc_file_reference
*copyc ost$status
*copyc oss$job_paged_literal
?? POP ??

*copyc amp$get_file_attributes
*copyc amp$write_tape_mark
*copyc clp$evaluate_parameters
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc rmp$get_device_class


?? TITLE := '  [XDCL, #GATE] clp$_write_tape_mark_command', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$_write_tape_mark_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{   PROCEDURE (osm$writf) write_tape_mark_pdt (
{     file, f : file = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 5, 14, 10, 55, 36, 241],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$WRITF'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

?? NEWTITLE := '    abort_handler', EJECT ??

    PROCEDURE abort_handler (condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      IF file_open THEN
        fsp$close_file (file_id, handler_status);
        file_open := FALSE;
      IFEND;

      handler_status.normal := TRUE;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    CONST
      max_class_size = 15,
      max_open_position_size = 4;

    VAR
      class: [STATIC, READ, oss$job_paged_literal] array [rmt$device_class] of record
        size: 1 .. max_class_size,
        value: string (max_class_size),
      recend := [[14, 'CONNECTED_FILE'], [15, 'INTERSTATE_LINK'],
        [11, 'LOCAL_QUEUE'], [3, 'LOG'], [13, 'MAGNETIC_TAPE'],
        [12, 'MASS_STORAGE'], [15, 'MEMORY_RESIDENT'], [7, 'NETWORK'], [4,'NULL'],
        [8, 'PIPELINE'], [5, 'RHFAM'], [8, 'TERMINAL']],

      positioning: [STATIC, READ, oss$job_paged_literal] array [amt$open_position] of record
        size: 1 .. max_open_position_size,
        value: string (max_open_position_size),
      recend := [[4, '$ASIS'], [4, '$BOI'], [4, '$BOP'], [4, '$EOI']],

      explicit_attribute_sources: [STATIC, READ, oss$job_paged_literal] set of amt$attribute_source :=
          [amc$change_file_attributes, amc$file_reference, amc$file_command, amc$file_request,
           amc$add_to_file_description];

    VAR
      file_attributes: array [1 .. 2] of amt$get_item,
      file_attachment: array [1 .. 2] of fst$attachment_option,
      local_file: boolean,
      existing_file: boolean,
      contains_data: boolean,
      file_id: amt$file_identifier,
      file_open: boolean,
      device_assigned: boolean,
      device_class: rmt$device_class,
      open_position: amt$open_position,
      open_position_source: amt$attribute_source,
      ignore_status: ost$status,
      file_set_position_changed: boolean;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_open := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

    /write_tape_mark/
    BEGIN

      file_attributes [1].key := amc$open_position;
      file_attributes [2].key := amc$label_type;

      amp$get_file_attributes (pvt [p$file].value^.file_value^, file_attributes,
        local_file, existing_file, contains_data, status);
      IF NOT status.normal THEN
        EXIT /write_tape_mark/;
      IFEND;

      IF NOT local_file THEN
        osp$set_status_abnormal ('CL', cle$file_not_assigned_to_device, 'WRITE_TAPE_MARK', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'MAGNETIC_TAPE', status);
        EXIT /write_tape_mark/;
      IFEND;

      rmp$get_device_class (pvt [p$file].value^.file_value^, device_assigned, device_class, status);
      IF NOT status.normal THEN
        EXIT /write_tape_mark/;
      IFEND;

      IF NOT device_assigned THEN
        osp$set_status_abnormal ('CL', cle$file_not_assigned_to_device, 'WRITE_TAPE_MARK', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'MAGNETIC_TAPE', status);
        EXIT /write_tape_mark/;
      IFEND;

      IF device_class <> rmc$magnetic_tape_device THEN
        osp$set_status_abnormal ('CL', cle$improper_device_class, 'WRITE_TAPE_MARK', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, class [device_class].value, status);
        EXIT /write_tape_mark/;
      IFEND;

      IF file_attributes [2].label_type = amc$labelled THEN
        osp$set_status_abnormal ('CL', cle$improper_labelled_tape_op, 'WRITE_TAPE_MARK', status);
        EXIT /write_tape_mark/;
      IFEND;

      open_position := file_attributes [1].open_position;
      open_position_source := file_attributes [1].source;

      IF (open_position <> amc$open_no_positioning) AND
         (open_position_source IN explicit_attribute_sources) THEN
        osp$set_status_abnormal ('CL', cle$improper_open_position, positioning [open_position].value, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'WRITE_TAPE_MARK', status);
        EXIT /write_tape_mark/;
      IFEND;

      file_attachment [1].selector := fsc$create_file;
      file_attachment [1].create_file := FALSE;

      file_attachment [2].selector := fsc$open_position;
      file_attachment [2].open_position := amc$open_no_positioning;

      fsp$open_file (pvt [p$file].value^.file_value^, amc$record, ^file_attachment, NIL, NIL, NIL, NIL,
            file_id, status);
      IF NOT status.normal THEN
        EXIT /write_tape_mark/;
      IFEND;
      file_open := TRUE;

      amp$write_tape_mark (file_id, status);
      IF status.normal THEN
        fsp$close_file (file_id, status);
      ELSE
        fsp$close_file (file_id, ignore_status);
      IFEND;

      file_open := FALSE;
    END /write_tape_mark/;

    osp$disestablish_cond_handler;

  PROCEND clp$_write_tape_mark_command;

MODEND clm$write_tape_mark_command;
*DECK DECK=CLP$ABORT_HANDLER EXPAND=FALSE
?? NEWTITLE := 'clp$abort_handler', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc CYD$RUN_TIME_ERROR_CONDITION
*copyc oss$job_paged_literal
*copyc PMT$CONDITION
?? POP ??
*copyc PMP$CONTINUE_TO_CAUSE

{
{   PURPOSE:
{     This procedure is established to invoke a procedure clean_up within its
{     establisher in the event that its establisher is aborted.
{     Conditions considered to represent an abort are: system, segment access,
{     cybil run time, interactive terminate break, and block exit.
{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     ****** This condition handler is obsolete and should NOT, under  ******
{     ****** ANY circumstances be used.  Modules presently using it    ******
{     ****** should be changed to have their own specialized condition ******
{     ****** handler.  This usually just entails making a block exit   ******
{     ****** handler out of the "clean_up" procedure that this routine ******
{     ****** now calls.                                                ******
{     ***********************************************************************
{     ***********************************************************************
{

  PROCEDURE clp$abort_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    VAR
      abort: boolean;

    handler_status.normal := TRUE;
    CASE condition.selector OF
    = pmc$system_conditions, mmc$segment_access_condition =
      abort := TRUE;
    = pmc$user_defined_condition =
      abort := condition.user_condition_name = cye$run_time_condition;
    = ifc$interactive_condition =
      abort := condition.interactive_condition = ifc$terminate_break;
    = pmc$block_exit_processing =
      abort := TRUE;
    ELSE
      abort := FALSE;
    CASEND;

    IF abort THEN
      clean_up;
    IFEND;

    IF condition.selector = pmc$block_exit_processing THEN
      RETURN;
    IFEND;

    pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

  PROCEND clp$abort_handler;


  VAR
    clv$abort_conditions: [STATIC, READ, oss$job_paged_literal]
          pmt$condition := [pmc$condition_combination,
          [pmc$system_conditions, mmc$segment_access_condition,
          pmc$user_defined_condition, ifc$interactive_condition]],
    clv$established_abort_handler: pmt$established_handler;

?? OLDTITLE ??
*DECK DECK=CLP$ACCESS_COMMAND_FILE EXPAND=FALSE

  PROCEDURE [XREF] clp$access_command_file
    (    command_file: clt$command_file_kind;
*IF NOT $true(osv$unix)
         submitter_ring: ost$ring;
*IFEND
         file_reference: fst$file_reference;
     VAR file_id: amt$file_identifier;
     VAR segment: ^SEQ ( * );
     VAR opened_executable_file: boolean;
     VAR can_be_echoed: boolean;
     VAR line_layout: clt$line_layout;
*IF NOT $true(osv$unix)
     VAR file_contents: clt$file_contents;
     VAR ring_attributes: amt$ring_attributes;
     VAR file_has_fap: boolean;
*IFEND
     VAR device_class: rmt$device_class;
*IF NOT $true(osv$unix)
     VAR path_handle_name: fst$path_handle_name;
*ELSE
     VAR path_handle_name: fst$path;
*IFEND
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*IF NOT $true(osv$unix)
*copyc amt$ring_attributes
*IFEND
*copyc clt$command_file_kind
*IF NOT $true(osv$unix)
*copyc clt$file_contents
*IFEND
*copyc clt$line_layout
*copyc fst$file_reference
*copyc fst$path_handle_name
*IF NOT $true(osv$unix)
*copyc osd$virtual_address
*IFEND
*copyc ost$status
*copyc rmt$device_class
?? POP ??
*DECK DECK=CLP$ACCESS_PARAM_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] clp$access_param_variable
    (    name: clt$parameter_name;
         access_variable_requests: clt$access_variable_requests;
     VAR work_area {input, output} :^clt$work_area;
     VAR variable_information: clt$variable_information;
     VAR variable_access_handle: clt$variable_access_handle;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$access_variable_requests
*copyc clt$parameter_name
*copyc clt$variable_access_handle
*copyc clt$variable_information
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$ACCESS_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] clp$access_variable
    (    name: clt$variable_name;
         hashed_name: clt$variable_name;
         hash: clt$variable_name_hash;
         lock: boolean;
         access_variable_requests: clt$access_variable_requests;
     VAR work_area {input, output} :^clt$work_area;
     VAR variable_information: clt$variable_information;
     VAR variable_access_handle: clt$variable_access_handle;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$access_variable_requests
*copyc clt$variable_access_handle
*copyc clt$variable_information
*copyc clt$variable_name
*copyc clt$variable_name_hash
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$ADD_AUXILIARY_UTILITY_LIB EXPAND=FALSE

  PROCEDURE [XREF] clp$add_auxiliary_utility_lib
    (    utility: clt$utility_name;
         library: fst$file_reference;
         checkout_library: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$utility_name
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$ADD_FILE_TO_COMMAND_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$add_file_to_command_list
    (    entry: clt$command_list_entry_file;
         append: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_command_processing
*copyc clt$command_list_entry_file
*copyc ost$status
?? POP ??
*DECK DECK=CLP$ADD_FORMAT_MARKER EXPAND=FALSE

  PROCEDURE [XREF] clp$add_format_marker
    (    format_marker_kind: clt$format_marker_kind;
         node_value: clt$f_node_value);

?? PUSH (LISTEXT := ON) ??
*copyc clt$f_node_value
*copyc clt$format_marker_kind
?? POP ??
*DECK DECK=CLP$ADD_FORMAT_TOKEN EXPAND=FALSE

  PROCEDURE [XREF] clp$add_format_token
    (    str_ptr: ^string ( * );
         clt_kind: clt$lexical_unit_kind;
         format_type: clt$format_token_type);

?? PUSH (LISTEXT := ON) ??
*copyc clt$format_token_type
*copyc clt$lexical_unit_kind
?? POP ??
*DECK DECK=CLP$ADD_TO_DEFER_LIST EXPAND=FALSE
  PROCEDURE [XREF] clp$add_to_defer_list
    (    name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$ADD_UTILITY_TO_COMMAND_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$add_utility_to_command_list
    (    utility_block: ^clt$block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc ost$status
?? POP ??
*DECK DECK=CLP$ADD_VARIABLE_TO_TREE EXPAND=FALSE

  PROCEDURE [INLINE] clp$add_variable_to_tree
    (    hashed_name: clt$variable_name;
         hash: clt$variable_name_hash;
         class: clt$internal_variable_class;
     VAR {input, output} variables: clt$variables;
     VAR variable_access: ^clt$variable_access);

    VAR
      current_access: ^^clt$variable_access;


    variable_access := NIL;
    current_access := ^variables.hash_groups [hash].root;

  /locate_node/
    WHILE current_access^ <> NIL DO
      IF hashed_name < current_access^^.hashed_name THEN
        current_access := ^current_access^^.left_search_tree;
      ELSEIF hashed_name > current_access^^.hashed_name THEN
        current_access := ^current_access^^.right_search_tree;
      ELSE
        RETURN;
      IFEND;
    WHILEND /locate_node/;

    ALLOCATE variable_access IN osv$task_shared_heap^;

    variable_access^.left_search_tree := NIL;
    variable_access^.right_search_tree := NIL;
    variable_access^.forward_thread := variables.thread;
    IF variables.thread <> NIL THEN
      variables.thread^.backward_thread := variable_access;
    IFEND;
    variables.thread := variable_access;
    variable_access^.backward_thread := NIL;
    variable_access^.hashed_name := hashed_name;
    variable_access^.info.class := class;
    variable_access^.info.parameter_passed := TRUE;
    current_access^ := variable_access;

    CASE class OF
    = clc$env_variable, clc$lib_variable, clc$pushed_variable =
      variables.hash_groups [hash].environment_variables_in_group :=
            variables.hash_groups [hash].environment_variables_in_group + 1;
    ELSE
      variables.hash_groups [hash].procedure_variables_in_group :=
            variables.hash_groups [hash].procedure_variables_in_group + 1;
    CASEND;

  PROCEND clp$add_variable_to_tree;

?? PUSH (LISTEXT := ON) ??
*copyc clt$internal_variable_class
*copyc clt$variable_access
*copyc clt$variable_name
*copyc clt$variable_name_hash
*copyc clt$variables
*copyc osv$task_shared_heap
?? POP ??
*DECK DECK=CLP$ADVANCE_FOR_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$advance_for_block
    (    set_exit_position: boolean);

*DECK DECK=CLP$ANALYZE_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] clp$analyze_command
    (    command_text: ^clt$command_line;
     VAR prompting_requested: boolean;
     VAR escaped: boolean;
     VAR label: ost$name;
     VAR command_reference_index: clt$command_line_index;
     VAR command_reference_size: clt$command_line_size;
     VAR file: clt$file;
     VAR form: clt$command_reference_form;
     VAR name: clt$name;
     VAR utility_name: clt$utility_name;
     VAR parameter_list_index: clt$command_line_index;
     VAR separator: clt$lexical_unit_kind;
     VAR empty_command: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc clt$command_line_index
*copyc clt$command_line_size
*copyc clt$command_reference_form
*copyc clt$file
*copyc clt$lexical_unit_kind
*copyc clt$name
*copyc clt$utility_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$APPEND_CONTINUATION_LINE EXPAND=FALSE

  PROCEDURE [XREF] clp$append_continuation_line
    (    command_line_size: clt$command_line_size;
         continuation_line_size: clt$command_line_size;
     VAR command_line: ^clt$command_line);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc clt$command_line_size
?? POP ??
*DECK DECK=CLP$APPEND_EXPANDABLE_STRING EXPAND=FALSE

  PROCEDURE [INLINE] clp$append_expandable_string
    (    retain_size: clt$string_size;
         append_text: ^clt$string_value;
     VAR expandable_string {input, output} : clt$expandable_string);

?? PUSH (LISTEXT := ON) ??

    VAR
      needed_area_size: integer,
      new_area: ^SEQ ( * ),
      new_text: ^clt$string_value;


    needed_area_size := retain_size + STRLENGTH (append_text^);

    IF needed_area_size <= #SIZE (expandable_string.area^) THEN
      RESET expandable_string.area;
      NEXT expandable_string.text: [retain_size + STRLENGTH (append_text^)] IN
            expandable_string.area;
    ELSE
      ALLOCATE new_area: [[REP ((needed_area_size + clc$expansion_chunk_size -
            1) DIV clc$expansion_chunk_size) * clc$expansion_chunk_size OF
            cell]] IN osv$task_shared_heap^;
      RESET new_area;
      NEXT new_text: [retain_size + STRLENGTH (append_text^)] IN new_area;
      new_text^ (1, retain_size) := expandable_string.text^ (1, retain_size);
      FREE expandable_string.area IN osv$task_shared_heap^;
      expandable_string.area := new_area;
      expandable_string.text := new_text;
    IFEND;

    expandable_string.text^ (retain_size + 1,
          STRLENGTH (append_text^)) := append_text^;

  PROCEND clp$append_expandable_string;

*copyc clt$expandable_string
*copyc clt$string_size
*copyc clt$string_value
?? POP ??
*copyc osv$task_shared_heap
*DECK DECK=CLP$APPEND_STATUS_PARSE_STATE EXPAND=FALSE

  PROCEDURE [XREF] clp$append_status_parse_state
    (    delimiter: char;
         parse: clt$parse_state;
     VAR status {input, output} : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parse_state
*copyc ost$status
?? POP ??
*DECK DECK=CLP$APPEND_STATUS_STRING EXPAND=FALSE

  PROCEDURE [XREF] clp$append_status_string
    (    delimiter: char;
         text: string ( * );
     VAR status {input, output} : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osc$status_parameter_delimiter
*copyc ost$status
?? POP ??
*DECK DECK=CLP$APPEND_STATUS_TYPE EXPAND=FALSE

  PROCEDURE [XREF] clp$append_status_type
    (    delimiter: char;
         type_specification: ^clt$type_specification;
     VAR status {input, output} : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$type_specification
*copyc ost$status
?? POP ??
*DECK DECK=CLP$APPEND_STATUS_TYPE_DESC EXPAND=FALSE

  PROCEDURE [XREF] clp$append_status_type_desc
    (    delimiter: char;
         type_description: ^clt$type_description;
     VAR status {input, output} : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$type_description
*copyc ost$status
?? POP ??
*DECK DECK=CLP$APPEND_STATUS_VALUE_TYPE EXPAND=FALSE

  PROCEDURE [XREF] clp$append_status_value_type
    (    delimiter: char;
         value: ^clt$data_value;
     VAR status {input, output} : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc ost$status
?? POP ??
*DECK DECK=CLP$ARRAY_VALUE_COMPARE EXPAND=FALSE

  FUNCTION [XREF, UNSAFE] clp$array_value_compare
    (    left_value: ^clt$data_value;
         right_value: ^clt$data_value): clt$comparison_result;

?? PUSH (LISTEXT := ON) ??
*copyc clt$comparison_result
*copyc clt$data_value
?? POP ??
*DECK DECK=CLP$ASSIGNMENT_STATEMENT EXPAND=FALSE

  PROCEDURE [XREF] clp$assignment_statement
    (VAR variable_parse {input, output} : clt$parse_state;
     VAR expression_parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parse_state
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$BALANCE_PARENTHESES EXPAND=FALSE

  PROCEDURE [XREF] clp$balance_parentheses
    (VAR parse {input, output} : clt$parse_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parse_state
*copyc ost$status
?? POP ??
*DECK DECK=CLP$BEGIN_UTILITY EXPAND=FALSE

  PROCEDURE [XREF] clp$begin_utility
    (    name: clt$utility_name;
         attributes: clt$utility_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_utilities
*copyc clt$utility_attributes
*copyc clt$utility_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$BOOLEAN_COMPARE EXPAND=FALSE

  FUNCTION [INLINE] clp$boolean_compare
    (    left_boolean: boolean;
         right_boolean: boolean): clt$comparison_result;

?? PUSH (LISTEXT := ON) ??

    IF left_boolean = right_boolean THEN
      clp$boolean_compare := clc$equal;
    ELSEIF left_boolean > right_boolean THEN
      clp$boolean_compare := clc$left_is_greater;
    ELSE
      clp$boolean_compare := clc$right_is_greater;
    IFEND;

  FUNCEND clp$boolean_compare;

*copyc clt$comparison_result
?? POP ??
*DECK DECK=CLP$BUILD_FORMATTED_STRINGS EXPAND=FALSE
  PROCEDURE [XREF] clp$format_values
    (    format_representation: ^clt$format_representation;
         value: ^clt$data_value;
         max_string: clt$string_size;
     VAR work_area: ^clt$work_area;
     VAR data_representation: ^clt$data_representation;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_representation
*copyc clt$data_value
*copyc clt$format_representation
*copyc clt$string_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$BUILD_FORMAT_REPRESENTATION EXPAND=FALSE
  PROCEDURE [XREF] clp$build_format_representation
    (    format_string: ^clt$string_value;
     VAR work_area: ^clt$work_area;
     VAR data_representation: ^clt$data_representation;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_representation
*copyc clt$string_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$BUILD_PATH_SUBTITLE EXPAND=FALSE

  PROCEDURE [XREF] clp$build_path_subtitle
    (VAR path_name {input,output} : fst$file_reference;
         length: 1 .. fsc$max_path_size;
         width: amt$page_width;
     VAR count: 0 .. fsc$max_path_elements;
     VAR display_array: clt$path_display_chunks);

?? PUSH (LISTEXT := ON) ??
*copyc amd$page_format_declarations
*copyc clt$path_display_chunks
*copyc fsc$max_path_elements
*copyc fsc$max_path_size
*copyc fst$file_reference
?? POP ??
*DECK DECK=CLP$BUILD_PATTERN_FOR_WILD_CARD EXPAND=FALSE

  PROCEDURE [XREF] clp$build_pattern_for_wild_card
    (    wild_card_pattern_type: clt$wild_card_pattern_type;
         build_options: clt$string_pattern_build_opts;
         source: clt$string_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$string_pattern
*copyc clt$string_pattern_build_opts
*copyc clt$string_value
*copyc clt$wild_card_pattern_type
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$BUILD_STANDARD_TITLE EXPAND=FALSE

  PROCEDURE [XREF] clp$build_standard_title
    (    wide: boolean;
         command_name: string (osc$max_name_size);
     VAR wide_title: string (clc$wide_page_width);
     VAR narrow_title1: string (clc$narrow_page_width);
     VAR narrow_title2: string (clc$narrow_page_width);
     VAR display_control: clt$display_control;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clc$page_widths
*copyc clt$display_control
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$BUNDLE_PDT EXPAND=FALSE

  PROCEDURE [XREF] clp$bundle_pdt
    (    unbundled_pdt: clt$unbundled_pdt;
     VAR work_area {input, output} : ^clt$work_area;
     VAR parameter_description_table: ^clt$parameter_description_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_description_table
*copyc clt$unbundled_pdt
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CASE_SELECTION_STATEMENT EXPAND=FALSE

  PROCEDURE [XREF] clp$case_selection_statement
    (    interpreter_mode: clt$interpreter_modes;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$interpreter_modes
*copyc clt$parse_state
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CHANGE_COLT_RUC_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$change_colt_ruc_value
    (    retain_unprintable_characters: boolean,
         call_from_colt_command: boolean);
*DECK DECK=CLP$CHANGE_HDR_CREATION_VALUE EXPAND=FALSE
  PROCEDURE [XREF] clp$change_hdr_creation_value
    (    first_header_creation_value: boolean);
*DECK DECK=CLP$CHANGE_INTERNAL_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$change_internal_value
    (    change_in_place: boolean;
         old_value: ^clt$internal_data_value;
         graft_address: ^ REL (clt$internal_data_value) ^clt$i_data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR new_value {input, output} : ^clt$internal_data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$internal_data_value
*copyc clt$i_data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CHANGE_PDT EXPAND=FALSE

  PROCEDURE [XREF] clp$change_pdt
    (    parameter_description_table: ^clt$parameter_description_table;
         changes: clt$pdt_changes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_description_table
*copyc clt$pdt_changes
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CHANGE_PROMPT_STRING EXPAND=FALSE

  PROCEDURE [XREF] clp$change_prompt_string
    (    new_prompt_string: string ( * );
     VAR old_prompt_string: string (ifc$max_prompt_string_size));

?? PUSH (LISTEXT := ON) ??
*copyc ifc$terminal_constants
?? POP ??
*DECK DECK=CLP$CHANGE_SCL_OPTIONS EXPAND=FALSE

  PROCEDURE [XREF] clp$change_scl_options
    (    options: clt$scl_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$scl_options
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CHANGE_TAPE_LABEL_ATTR_CMD EXPAND=FALSE

  PROCEDURE [XREF] clp$change_tape_label_attr_cmd (
        parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc clt$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CHANGE_TYPE_SPECIFICATION EXPAND=FALSE

  PROCEDURE [XREF] clp$change_type_specification
    (    type_specification_ptr: ^clt$type_specification;
         type_changes: clt$type_changes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$type_changes
*copyc clt$type_specification
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CHANGE_UNSEEN_MAIL_ACTION EXPAND=FALSE
  PROCEDURE [XREF] clp$change_unseen_mail_action
    (    action: clt$unseen_mail_action;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$bad_unseen_mail_action
*copyc clt$unseen_mail_action
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CHANGE_UTILITY_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] clp$change_utility_attributes
    (    name: clt$utility_name;
         attributes: clt$utility_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_utilities
*copyc clt$utility_attributes
*copyc clt$utility_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CHANGE_UTILITY_ENVIRONMENT EXPAND=FALSE

  PROCEDURE [XREF] clp$change_utility_environment
    (    name: clt$utility_name;
         defined_at_command_level: boolean;
         attributes: clt$utility_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$utility_attributes
*copyc clt$utility_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CHANGE_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] clp$change_variable
    (    reference: clt$variable_ref_expression;
         value: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$unknown_variable
*copyc clt$data_value
*copyc clt$variable_ref_expression
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CHANGE_VARIABLE_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$change_variable_value
    (    name: clt$variable_name;
         data_value: ^clt$data_value;
         value_qualifiers: ^clt$value_qualifiers;
         type_description: ^clt$type_description;
         element_type_description: ^clt$type_description;
         variable_access_handle: clt$variable_access_handle;
         allow_padding_or_truncation: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$type_description
*copyc clt$value_qualifiers
*copyc clt$variable_access_handle
*copyc clt$variable_name
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CHECK_KEYWORD EXPAND=FALSE

  PROCEDURE [INLINE] clp$check_keyword
    (    candidate: clt$keyword;
         keyword_specifications: ^clt$keyword_specifications;
     VAR result_keyword: clt$keyword);

?? PUSH (LISTEXT := ON) ??

    VAR
      current_index: 0 .. clc$max_keywords,
      high_index: 0 .. clc$max_keywords,
      temp: integer,
      low_index: 1 .. clc$max_keywords + 1;


    IF keyword_specifications <> NIL THEN
      low_index := 1;
      high_index := UPPERBOUND (keyword_specifications^);

    /search/
      REPEAT
        temp := low_index + high_index;
        current_index := temp DIV 2;
        IF keyword_specifications^ [current_index].keyword = candidate THEN
          IF keyword_specifications^ [current_index].class =
                clc$nominal_entry THEN
            result_keyword := candidate;
            RETURN;
          IFEND;
          EXIT /search/;
        ELSEIF keyword_specifications^ [current_index].keyword > candidate THEN
          high_index := current_index - 1;
        ELSE
          low_index := current_index + 1;
        IFEND;
      UNTIL low_index > high_index {/search/} ;
    IFEND;

    result_keyword := osc$null_name;

  PROCEND clp$check_keyword;

*copyc clc$max_keywords
*copyc clt$keyword
*copyc clt$keyword_specifications
?? POP ??
*DECK DECK=CLP$CHECK_NAME_FOR_BOOLEAN EXPAND=FALSE

  PROCEDURE [XREF] clp$check_name_for_boolean
    (    name: ost$name;
     VAR bool: clt$boolean;
     VAR name_is_boolean: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc clt$boolean
*copyc ost$name
?? POP ??
*DECK DECK=CLP$CHECK_NAME_FOR_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] clp$check_name_for_control
    (    name: clt$name;
     VAR control_statement_descriptor: ^clt$control_statement_desc);

?? PUSH (LISTEXT := ON) ??
*copyc clt$control_statement_desc
*copyc clt$name
?? POP ??
*DECK DECK=CLP$CHECK_NAME_FOR_FUNCTION EXPAND=FALSE

  PROCEDURE [XREF] clp$check_name_for_function
    (    name: clt$name;
     VAR func: clt$function;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$function
*copyc clt$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CHECK_NAME_FOR_PATH_HANDLE EXPAND=FALSE

  PROCEDURE [INLINE] clp$check_name_for_path_handle
*IF NOT $true(osv$unix)
    (    name: fst$path_element_name;
*ELSE
    (    name: fst$file_reference;
*IFEND
     VAR path_handle: clt$path_handle);

?? PUSH (LISTEXT := ON) ??

    VAR
      i: 8 .. 31,
      j: integer,
      n: integer,
      offset_converter: fmt$path_handle_offset_nibbles;

  /check/
    BEGIN
      IF (name (1, 4) <> 'FS$$') OR (name (6) <> '_') OR (name (15) <>
            '_') THEN
        EXIT /check/;
      IFEND;

      path_handle.kind := clc$regular_path_handle;

      CASE name (5) OF
      = '_' =
        path_handle.regular_handle.open_position.specified := FALSE;
      = 'A' =
        path_handle.regular_handle.open_position.specified := TRUE;
        path_handle.regular_handle.open_position.value :=
              amc$open_no_positioning;
      = 'B' =
        path_handle.regular_handle.open_position.specified := TRUE;
        path_handle.regular_handle.open_position.value := amc$open_at_boi;
      = 'C' =
        path_handle.kind := clc$command_file_handle;
      = 'E' =
        path_handle.regular_handle.open_position.specified := TRUE;
        path_handle.regular_handle.open_position.value := amc$open_at_eoi;
      ELSE
        EXIT /check/;
      CASEND;

      CASE name (7) OF
      = '0' .. '7' =
        offset_converter.segment_offset := 0;
        offset_converter.nibble [1] := $INTEGER (name (7)) - $INTEGER ('0');
        FOR i := 8 TO 14 DO
          CASE name (i) OF
          = '0' .. '9' =
            offset_converter.nibble [i - 6] := $INTEGER (name (i)) -
                  $INTEGER ('0');
          = 'A' .. 'F' =
            offset_converter.nibble [i - 6] := $INTEGER (name (i)) -
                  $INTEGER ('A') + 10;
          ELSE
            EXIT /check/;
          CASEND;
        FOREND;
      ELSE
        EXIT /check/;
      CASEND;
      IF path_handle.kind = clc$command_file_handle THEN
        path_handle.block_handle.segment_offset :=
              offset_converter.segment_offset;
      ELSE
        path_handle.regular_handle.segment_offset :=
              offset_converter.segment_offset;
      IFEND;

      n := 0;

      IF (name (16) = '0') THEN
        EXIT /check/;
      IFEND;
    /compute_assignment_counter/
      FOR i := 16 TO 31 DO
        CASE name (i) OF
        = '0' .. '9' =
          j := $INTEGER (name (i)) - $INTEGER ('0');
        = 'A' .. 'F' =
          j := $INTEGER (name (i)) - $INTEGER ('A') + 10;
        = ' ' =
          EXIT /compute_assignment_counter/;
        ELSE
          EXIT /check/;
        CASEND;
        n := (n * 16) + j;
      FOREND /compute_assignment_counter/;
      IF n > UPPERVALUE (fmt$pde_assignment_counter) THEN
          EXIT /check/;
      IFEND;
      IF path_handle.kind = clc$command_file_handle THEN
        path_handle.block_handle.assignment_counter := n;
      ELSE
        path_handle.regular_handle.assignment_counter := n;
      IFEND;

      RETURN;
    END /check/;
    path_handle.kind := clc$not_a_path_handle;

  PROCEND clp$check_name_for_path_handle;

*copyc clt$path_handle
*copyc fmt$path_handle_offset_nibbles
*copyc fmt$pde_assignment_counter
*IF NOT $true(osv$unix)
*copyc fst$path_element_name
*ELSE
*copyc fst$file_reference
*IFEND
?? POP ??
*DECK DECK=CLP$CHECK_NAME_FOR_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] clp$check_name_for_variable
    (    name: ost$name;
     VAR name_is_variable: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CHECK_VALID_CATALOG EXPAND=FALSE

  PROCEDURE [INLINE] clp$check_valid_catalog
    (    path: pft$path;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      group: pft$group,
      info: pft$p_info,
      info_area: SEQ (pft$info_record_type, pft$info_record_body_size,
            pft$info_record_type, pft$info_record_body_size,
            pft$directory_array_entry, pft$info_record_type,
            pft$info_record_body_size, cell);

    status.normal := TRUE;

    info := ^info_area;
    RESET info;
    group.group_type := pfc$member;
    group.member_description.family := osc$null_name;
    group.member_description.account := osc$null_name;
    group.member_description.project := osc$null_name;
    group.member_description.user := osc$null_name;
    pfp$get_item_info (path, group, $pft$catalog_info_selections
          [pfc$catalog_directory], $pft$file_info_selections [], info, status);

  PROCEND clp$check_valid_catalog;

*copyc ost$status
?? POP ??
*copyc pfp$get_item_info
*DECK DECK=CLP$CLEANUP_DYNAMIC_LOAD EXPAND=FALSE














*DECK DECK=CLP$CLEAR_LOCK_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] clp$clear_lock_variable
    (    reference: clt$variable_ref_expression;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$variable_ref_expression
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CLEAR_MESSAGE_CACHE EXPAND=FALSE

  PROCEDURE [XREF] clp$clear_message_cache;

*DECK DECK=CLP$CLOSE_COMMAND_FILE EXPAND=FALSE

  PROCEDURE [INLINE] clp$close_command_file
    (    file_id: amt$file_identifier;
         executable_file: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

*IF NOT $true(osv$unix)
    IF executable_file THEN
      clp$close_executable_cmnd_file (file_id, status);
    ELSE
*ELSE
    status.normal := TRUE;

    IF file_id <> amc_stdin_fid THEN
*IFEND
      fsp$close_file (file_id, status);
    IFEND;

  PROCEND clp$close_command_file;

*IF $true(osv$unix)
*copyc amc_standard_files
*IFEND
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*IF NOT $true(osv$unix)
*copyc clp$close_executable_cmnd_file
*IFEND
*copyc fsp$close_file
*DECK DECK=CLP$CLOSE_COMMAND_LIBRARY EXPAND=FALSE

*IF $true(osv$unix)
  PROCEDURE [INLINE] clp$close_command_library
    (    local_file_name: amt$local_file_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
    status.normal := TRUE;

  PROCEND clp$close_command_library;
*ELSE
  PROCEDURE [XREF] clp$close_command_library
    (    local_file_name: amt$local_file_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*IFEND
*copyc amt$local_file_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CLOSE_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] clp$close_display
    (    display_control: clt$display_control;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CLOSE_EXECUTABLE_CMND_FILE EXPAND=FALSE

  PROCEDURE [XREF] clp$close_executable_cmnd_file
    (    file_id: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=CLP$COLLECT_COMMANDS EXPAND=FALSE

  PROCEDURE [XREF] clp$collect_commands
    (    file: fst$file_reference;
         terminator: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc cle$ecc_miscellaneous
*copyc fst$file_reference
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$COLLECT_STATEMENT EXPAND=FALSE

  PROCEDURE [XREF] clp$collect_statement
    (    save_statement: boolean;
         begin_name: ost$name;
         end_name: ost$name;
         first_line_to_write: clt$command_line;
         substitution_mark: clt$substitution_mark;
     VAR work_area {input, output} : ^clt$work_area;
     VAR statement_area: ^clt$collect_statement_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$collect_statement_area
*copyc clt$command_line
*copyc clt$substitution_mark
*copyc clt$work_area
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$COMMAND_REFERENCE_COMPARE EXPAND=FALSE

  FUNCTION [XREF, UNSAFE] clp$command_reference_compare
    (    left_command_reference: clt$command_reference;
         right_command_reference: clt$command_reference):
         clt$comparison_result;

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_reference
*copyc clt$comparison_result
?? POP ??
*DECK DECK=CLP$COMPLETE_FILE_REF_EVAL EXPAND=FALSE

  PROCEDURE [XREF] clp$complete_file_ref_eval
*IF NOT $true(osv$unix)
    (    multiple_reference_allowed: boolean;
*ELSE
    (    unix_path: boolean;
         multiple_reference_allowed: boolean;
*IFEND
         defer_expansion: boolean;
         encode_file_values: boolean;
     VAR initial_path {input, output} : ^fst$file_reference;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR result_sub_list_tail: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$parse_state
*copyc clt$work_area
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$COMPLETE_FILE_REF_PARSE EXPAND=FALSE

  PROCEDURE [XREF] clp$complete_file_ref_parse
    (VAR initial_path {input, output} : ^fst$file_reference;
     VAR parse {input, output } : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
         file_reference_parsing_options: clt$file_ref_parsing_options;
         user_identification: clt$user_identification;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR command_or_program_name: clt$name;
     VAR form: clt$command_reference_form;
     VAR parameter_name: clt$parameter_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_reference_form
*copyc clt$file_ref_parsing_options
*copyc clt$name
*copyc clt$parameter_name
*copyc clt$parse_state
*copyc clt$user_identification
*copyc clt$work_area
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$COMPLETE_FILE_REF_SCAN EXPAND=FALSE

  PROCEDURE [XREF] clp$complete_file_ref_scan
    (    evaluate: boolean;
         extra_element_expected: boolean;
         name: clt$name;
     VAR file: clt$file;
     VAR extra_element: clt$name;
     VAR parse {input, output} : clt$parse_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$file
*copyc clt$name
*copyc clt$parse_state
*copyc clt$parsed_path
*copyc ost$status
?? POP ??
*DECK DECK=CLP$COMPUTE_VARIABLE_NAME_HASH EXPAND=FALSE

  PROCEDURE [INLINE] clp$compute_variable_name_hash
    (    name: clt$variable_name;
     VAR hashed_name: clt$variable_name;
     VAR hash: clt$variable_name_hash);

?? PUSH (LISTEXT := ON) ??

    TYPE
      four_chars = 0 .. 0ffffffff(16),
      three_chars = 0 .. 0ffffff(16);

    VAR
      scratch_pad: record
        p1: four_chars,
        p2: four_chars,
        p3: four_chars,
        p4: four_chars,
        p5: four_chars,
        p6: four_chars,
        p7: four_chars,
        p8: three_chars,
      recend,
      swap: four_chars;


    #UNCHECKED_CONVERSION (name, scratch_pad);

{ Swap the first group of four characters in the name with the third group of
{ four characters to improve the distribution of names within a search tree.
{ (This operation can be undone by clp$unhash_variable_name.)

    swap := scratch_pad.p3;
    scratch_pad.p3 := scratch_pad.p1;
    scratch_pad.p1 := swap;

    hash := (scratch_pad.p1 + scratch_pad.p2 + scratch_pad.p3 +
          scratch_pad.p4 + scratch_pad.p5 + scratch_pad.p6 + scratch_pad.p7 +
          scratch_pad.p8) MOD clc$max_variable_hash_groups;

    #UNCHECKED_CONVERSION (scratch_pad, hashed_name);

  PROCEND clp$compute_variable_name_hash;

*copyc clc$max_variable_hash_groups
*copyc clt$variable_name
*copyc clt$variable_name_hash
*copyc ost$name
?? POP ??
*DECK DECK=CLP$CONSTRUCT_BLOCK_HANDLE_NAME EXPAND=FALSE

  PROCEDURE [INLINE] clp$construct_block_handle_name
    (    block_handle: clt$block_handle;
*IF NOT $true(osv$unix)
     VAR block_handle_name: fst$path_handle_name);
*ELSE
     VAR block_handle_name: fst$path);
*IFEND

?? PUSH (LISTEXT := ON) ??

    VAR
      digits: array [1 .. 16] of 0 .. 15,
      count: 0 .. 16,
      i: 1 .. 31 + 1,
      j: 1 .. 16,
      n: integer;

    block_handle_name := 'FS$$__12345678_0';

    n := block_handle.segment_offset;
    FOR i := 14 DOWNTO 7 DO
      digits [1] := n MOD 16;
      n := n DIV 16;
      IF digits [1] <= 9 THEN
        block_handle_name (i) := $CHAR ($INTEGER ('0') + digits [1]);
      ELSE
        block_handle_name (i) := $CHAR ($INTEGER ('A') + digits [1] - 10);
      IFEND;
    FOREND;

    n := block_handle.assignment_counter;
    count := 0;
    REPEAT
      count := count + 1;
      digits [count] := n MOD 16;
      n := n DIV 16;
    UNTIL n = 0;
    i := 16;
    REPEAT
      IF digits [count] <= 9 THEN
        block_handle_name (i) := $CHAR ($INTEGER ('0') + digits [count]);
      ELSE
        block_handle_name (i) := $CHAR ($INTEGER ('A') + digits [count] - 10);
      IFEND;
      i := i + 1;
      count := count - 1;
    UNTIL count = 0;

    block_handle_name (5) := 'C';

  PROCEND clp$construct_block_handle_name;

*copyc clt$block_handle
*IF NOT $true(osv$unix)
*copyc fst$path_handle_name
*ELSE
*copyc fst$path
*IFEND
?? POP ??
*DECK DECK=CLP$CONSTRUCT_PATH_HANDLE_NAME EXPAND=FALSE

  PROCEDURE [INLINE] clp$construct_path_handle_name
    (    path_handle: fmt$path_handle;
     VAR path_handle_name: fst$path_handle_name);

?? PUSH (LISTEXT := ON) ??

    VAR
      digits: array [1 .. 16] of 0 .. 15,
      count: 0 .. 16,
      i: 1 .. 31 + 1,
      j: 1 .. 16,
      n: integer,
      offset_converter: fmt$path_handle_offset_nibbles;

    path_handle_name := 'FS$$__12345678_0';

    offset_converter.segment_offset := path_handle.segment_offset;
    FOR i := 1 TO 8 DO
      IF offset_converter.nibble [i] <= 9 THEN
        path_handle_name (i + 6) := $CHAR ($INTEGER ('0') +
              offset_converter.nibble [i]);
      ELSE
        path_handle_name (i + 6) := $CHAR ($INTEGER ('A') +
              offset_converter.nibble [i] - 10);
      IFEND;
    FOREND;

    n := path_handle.assignment_counter;
    count := 0;
    REPEAT
      count := count + 1;
      digits [count] := n MOD 16;
      n := n DIV 16;
    UNTIL n = 0;
    i := 16;
    REPEAT
      IF digits [count] <= 9 THEN
        path_handle_name (i) := $CHAR ($INTEGER ('0') + digits [count]);
      ELSE
        path_handle_name (i) := $CHAR ($INTEGER ('A') + digits [count] - 10);
      IFEND;
      i := i + 1;
      count := count - 1;
    UNTIL count = 0;

    clp$put_open_pos_in_path_handle (path_handle.open_position,
          path_handle_name);

  PROCEND clp$construct_path_handle_name;

*copyc fmt$path_handle
*copyc fmt$path_handle_offset_nibbles
*copyc fst$path_handle_name
?? POP ??
*copyc clp$put_open_pos_in_path_handle
*DECK DECK=CLP$CONTINUE EXPAND=FALSE

  PROCEDURE [XREF] clp$continue
    (    continue_when_condition_option: clt$condition_processed_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$condition_processed_state
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_ARRAY_TO_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_array_to_list
    (    array_value: ^clt$data_value;
         array_type_description: ^clt$type_description;
         list_type_description: ^clt$type_description;
     VAR work_area {input, output} : ^clt$work_area;
     VAR list_value {input, output} : ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$type_description
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_CHAR_TO_GRAPHIC EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_char_to_graphic
    (    ch: char;
     VAR char_string: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$CONVERT_CLT$VALUE_TO_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_clt$value_to_value
    (    value: clt$value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR data_value: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_CONSOLE_TO_ASCII EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_console_to_ascii
    (    console_string: string ( * );
     VAR ascii_string: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_CYCLE_TO_STRING EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_cycle_to_string
    (    cycle_selector: clt$cycle_selector;
     VAR cycle_string: ost$string);

?? PUSH (LISTEXT := ON) ??
*copyc cld$path_description
*copyc ost$string
?? POP ??
*DECK DECK=CLP$CONVERT_CYC_REF_TO_CYC_SEL EXPAND=FALSE

  PROCEDURE [INLINE] clp$convert_cyc_ref_to_cyc_sel
    (    fs_cycle_reference: fst$cycle_reference;
     VAR cycle_selector: clt$cycle_selector);

?? PUSH (LISTEXT := ON) ??

    CASE fs_cycle_reference.specification OF
    = fsc$cycle_omitted =
      cycle_selector.specification := clc$cycle_omitted;
      cycle_selector.value.cycle_option := pfc$highest_cycle;
    = fsc$high_cycle =
      cycle_selector.specification := clc$cycle_specified;
      cycle_selector.value.cycle_option := pfc$highest_cycle;
    = fsc$low_cycle =
      cycle_selector.specification := clc$cycle_specified;
      cycle_selector.value.cycle_option := pfc$lowest_cycle;
    = fsc$next_cycle =
      cycle_selector.specification := clc$cycle_next_highest;
      cycle_selector.value.cycle_option := pfc$highest_cycle;
    = fsc$cycle_number =
      cycle_selector.specification := clc$cycle_specified;
      cycle_selector.value.cycle_option := pfc$specific_cycle;
      cycle_selector.value.cycle_number := fs_cycle_reference.cycle_number;
    CASEND;

  PROCEND clp$convert_cyc_ref_to_cyc_sel;

*copyc cld$path_description
*copyc fst$cycle_reference
?? POP ??
*DECK DECK=CLP$CONVERT_DATA_TO_STRING EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_data_to_string
    (    value: ^clt$data_value;
         representation_option: clt$data_representation_option;
         max_string: clt$string_size;
     VAR work_area {input, output} : ^clt$work_area;
     VAR data_representation: ^clt$data_representation;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$bad_data_rep_option
*copyc cle$bad_data_value
*copyc cle$work_area_overflow
*copyc clt$data_representation
*copyc clt$data_representation_option
*copyc clt$data_value
*copyc clt$string_size
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_DATE_TIME_TO_STRING EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_date_time_to_string
    (    date_time: clt$date_time;
         format: clt$date_time_form_string;
     VAR str: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$date_time
*copyc clt$date_time_form_string
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$CONVERT_EXT_VALUE_TO_INT EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_ext_value_to_int
    (    initializing_type_description: ^clt$type_description;
         external_value: ^clt$data_value;
         internal_component_address: ^ REL (clt$internal_data_value) ^clt$i_data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR internal_value {input, output} : ^clt$internal_data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$internal_data_value
*copyc clt$i_data_value
*copyc clt$type_description
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_FILE_REF_TO_STRING EXPAND=FALSE

*IF NOT $true(osv$unix)
  PROCEDURE [INLINE] clp$convert_file_ref_to_string
*ELSE
  PROCEDURE [XREF] clp$convert_file_ref_to_string
*IFEND
    (    evaluated_file_reference: fst$evaluated_file_reference;
         include_open_position: boolean;
     VAR str: fst$path;
     VAR size: fst$path_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)

    VAR
      cycle_ref_size: fst$path_index,
      cycle_ref_value: string (5),
      cycle_string: ost$string,
      local_status: ost$status,
      i: fst$path_index,
      open_pos_size: 4 .. 5;

    status.normal := TRUE;

    size := evaluated_file_reference.path_structure_size;
    str := evaluated_file_reference.path_structure (1, size);
    str (1) := ':';
    i := $INTEGER (evaluated_file_reference.path_structure (1)) + 2;
    WHILE i < size DO
      str (i) := '.';
      i := i + $INTEGER (evaluated_file_reference.path_structure (i)) + 1;
    WHILEND;

    IF evaluated_file_reference.cycle_reference.specification <>
          fsc$cycle_omitted THEN
      CASE evaluated_file_reference.cycle_reference.specification OF
      = fsc$cycle_number =
        clp$convert_integer_to_string (evaluated_file_reference.
              cycle_reference.cycle_number, 10, FALSE, cycle_string,
              local_status);
        cycle_ref_size := cycle_string.size;
        cycle_ref_value := cycle_string.value (1, cycle_string.size);
      = fsc$high_cycle =
        cycle_ref_size := 5;
        cycle_ref_value := '$HIGH';
      = fsc$low_cycle =
        cycle_ref_size := 4;
        cycle_ref_value := '$LOW';
      = fsc$next_cycle =
        cycle_ref_size := 5;
        cycle_ref_value := '$NEXT';
      ELSE
        cycle_ref_size := fsc$max_path_size;
      CASEND;

      IF (i + cycle_ref_size) <= fsc$max_path_size THEN
        str (i) := '.';
        str (i + 1, cycle_ref_size) := cycle_ref_value;
        size := i + cycle_ref_size;
      ELSE
        osp$set_status_abnormal ('CL', cle$file_reference_too_long, '',
              status);
        RETURN;
      IFEND;
    IFEND;

    IF include_open_position AND evaluated_file_reference.path_handle_info.
          path_handle.open_position.specified THEN
      open_pos_size := clv$open_position_designator
            [evaluated_file_reference.path_handle_info.path_handle.
            open_position.value].size;
      IF size + open_pos_size + 2 <= fsc$max_path_size THEN
        str (size + 1) := '.';
        str (size + 2, open_pos_size) := clv$open_position_designator [
              evaluated_file_reference.path_handle_info.path_handle.
              open_position.value].value (1, open_pos_size);
        size := size + open_pos_size + 1;
      IFEND;
    IFEND;

  PROCEND clp$convert_file_ref_to_string;

*copyc cle$ecc_file_reference
*IFEND
*copyc fst$evaluated_file_reference
*copyc fst$path
*IF NOT $true(osv$unix)
*copyc fst$path_index
*IFEND
*copyc fst$path_size
*copyc ost$status
*IF NOT $true(osv$unix)
*copyc ost$string
*IFEND
?? POP ??
*IF NOT $true(osv$unix)
*copyc clp$convert_integer_to_string
*copyc clv$open_position_designator
*copyc osp$set_status_abnormal
*IFEND
*DECK DECK=CLP$CONVERT_INTEGER_TO_REAL EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_integer_to_real
    (    integer_number: integer;
     VAR real_number: clt$real;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$real
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_INTEGER_TO_RJSTRING EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_integer_to_rjstring ALIAS 'clpcirs'
    (    int: integer;
         radix: 2 .. 16;
         include_radix_specifier: boolean;
         fill_character: char;
     VAR str: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_expression_result
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_INTEGER_TO_STRING EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_integer_to_string ALIAS 'clpci2s'
    (    int: integer;
         radix: 2 .. 16;
         include_radix_specifier: boolean;
     VAR str: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$CONVERT_INT_TO_VAR_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_int_to_var_value
    (    internal_value: ^clt$internal_data_value;
         max_string_size: clt$string_size;
     VAR variable_value: clt$variable_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$variable_reference
*copyc clt$internal_data_value
*copyc clt$string_size
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_INT_VALUE_TO_EXT EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_int_value_to_ext
    (    internal_value: ^clt$internal_data_value;
         initial_component: REL (clt$internal_data_value) ^clt$i_data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR external_value: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$internal_data_value
*copyc clt$i_data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_LIST_TO_ARRAY EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_list_to_array
    (    list_value: ^clt$data_value;
         list_type_description: ^clt$type_description;
         array_type_description: ^clt$type_description;
     VAR work_area {input, output} : ^clt$work_area;
     VAR array_value {input, output} : ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$type_description
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_PDT EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_pdt
    (    old_pdt: clt$parameter_descriptor_table;
     VAR work_area {input, output} : ^clt$work_area;
     VAR new_pdt: ^clt$parameter_description_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_description_table
*copyc clt$parameter_descriptor_table
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_REAL_TO_INTEGER EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_real_to_integer
    (    real_number: longreal;
     VAR integer_number: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_REAL_TO_STRING EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_real_to_string
    (    real_number: longreal;
         number_of_digits: clt$real_number_digit_count;
     VAR str: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$real_number_digit_count
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$CONVERT_STRING_TO_DATE_TIME EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_string_to_date_time
    (    str: string ( * );
         format: clt$date_time_form_string;
     VAR date_time: clt$date_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$date_time
*copyc clt$date_time_form_string
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_STRING_TO_FILE EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_string_to_file
    (    str: string ( * );
*IF NOT $true(osv$unix)
     VAR file: clt$file;
*ELSE
     VAR file: fst$path;
*IFEND
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_file_reference
*copyc cle$ecc_lexical
*IF NOT $true(osv$unix)
*copyc clt$file
*ELSE
*copyc fst$path
*IFEND
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_STRING_TO_FILE_PATH EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_string_to_file_path
    (    str: string ( * );
         use_$local_as_working_catalog: boolean;
         return_path_handle_name: boolean;
     VAR path_handle_name: fst$path_handle_name;
     VAR resolved_path: fst$resolved_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$path_handle_name
*copyc fst$resolved_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_STRING_TO_FILE_REF EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_string_to_file_ref
    (    str: string ( * );
     VAR parsed_file_reference: fst$parsed_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$parsed_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_STRING_TO_INTEGER EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_string_to_integer ALIAS 'clpcs2i'
    (    str: string ( * );
     VAR int: clt$integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc clt$integer
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_STRING_TO_NAME EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_string_to_name ALIAS 'clpcs2n'
    (    str: string ( * );
     VAR name: clt$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc clt$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_STRING_TO_REAL EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_string_to_real
    (    str: string ( * );
     VAR real_number: clt$real;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$real
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_STR_TO_PATH_HANDLE EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_str_to_path_handle
    (    str: string ( * );
         delete_allowed: boolean;
         resolve_path: boolean;
         include_open_pos_in_handle: boolean;
*IF NOT $true(osv$unix)
     VAR path_handle_name: fst$path_handle_name;
*ELSE
     VAR path_handle_name: fst$path;
*IFEND
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fsc$max_path_size
*copyc fst$evaluated_file_reference
*IF NOT $true(osv$unix)
*copyc fst$path_handle_name
*ELSE
*copyc fst$path
*IFEND
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_TO_CLT$STATUS EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_to_clt$status
    (    osv$status: ost$status;
     VAR clv$status: clt$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$variable_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_TO_OST$STATUS EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_to_ost$status
    (    clv$status: clt$status;
     VAR osv$status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$variable_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_TYPE_DESC_TO_SPEC EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_type_desc_to_spec
    (    type_description: ^clt$type_description;
     VAR work_area {input, output} : ^clt$work_area;
     VAR type_specification: ^clt$type_specification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$type_description
*copyc clt$type_specification
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_TYPE_SPEC_TO_DESC EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_type_spec_to_desc
    (    type_specification: ^clt$type_specification;
     VAR work_area {input, output} : ^clt$work_area;
     VAR type_description: clt$type_description;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$type_description
*copyc clt$type_specification
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_VALUE_TO_CLT$VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_value_to_clt$value
    (    data_value: ^clt$data_value;
         value_set_number: 1 .. clc$max_value_sets;
         value_number: 1 .. clc$max_values_per_set;
         low_or_high: clt$low_or_high;
     VAR value: clt$value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_limits
*copyc cld$value
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_VALUE_TO_STRING EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_value_to_string ALIAS 'clpcv2s'
    (    value: clt$value;
     VAR str: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$CONVERT_VALUE_TO_VAR_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_value_to_var_value
    (    data_value: ^clt$data_value;
         max_string_size: clt$string_size;
     VAR variable_value: clt$variable_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$variable_reference
*copyc clt$data_value
*copyc clt$string_size
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CONVERT_VAR_VALUE_TO_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$convert_var_value_to_value
    (    variable_value: clt$variable_value;
         array_variable: boolean;
         lower_bound: clt$variable_dimension;
         upper_bound: clt$variable_dimension;
     VAR work_area {input, output} : ^clt$work_area;
     VAR data_value: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$variable_reference
*copyc cld$value
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??

*DECK DECK=CLP$COPY_COMMAND_LIST EXPAND=FALSE
*DECK DECK=CLP$COPY_CONNECTED_FILES EXPAND=FALSE
*DECK DECK=CLP$COPY_DATA_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$copy_data_value
    (    old_value: ^clt$data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR new_value: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$COUNT_LIST_ELEMENTS EXPAND=FALSE

  FUNCTION [INLINE] clp$count_list_elements
    (    list_value: ^clt$data_value): clt$list_size;

?? PUSH (LISTEXT := ON) ??

    VAR
      node: ^clt$data_value,
      list_size: clt$list_size;


    list_size := 0;
    node := list_value;
    WHILE (node <> NIL) AND (node^.kind = clc$list) DO
      list_size := list_size + $INTEGER (node^.element_value <> NIL);
      node := node^.link;
    WHILEND;
    clp$count_list_elements := list_size;

  FUNCEND clp$count_list_elements;

*copyc clt$data_value
*copyc clt$list_size
?? POP ??
*DECK DECK=CLP$CREATE_DEFAULT_INIT_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$create_default_init_value
    (    type_description: ^clt$type_description;
     VAR work_area {input, output} : ^clt$work_area;
     VAR internal_value: ^clt$internal_data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$internal_data_value
*copyc clt$type_description
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CREATE_ENVIRONMENT_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] clp$create_environment_variable
    (    name: clt$variable_name_reference;
         scope: clt$environment_variable_scope;
         access_mode: clt$data_access_mode;
         evaluation_method: clt$expression_eval_method;
         type_specification: ^clt$type_specification;
         initial_value: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$var_already_created
*copyc clt$data_access_mode
*copyc clt$data_value
*copyc clt$environment_variable_scope
*copyc clt$expression_eval_method
*copyc clt$type_specification
*copyc clt$variable_name_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CREATE_FILE_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] clp$create_file_connection
    (    subject_file: fst$file_reference;
         target_file: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc cle$ecc_connected_file
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CREATE_PROCEDURE_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] clp$create_procedure_variable
    (    name: clt$variable_name_reference;
         scope: clt$procedure_variable_scope;
         access_mode: clt$data_access_mode;
         evaluation_method: clt$expression_eval_method;
         type_specification: ^clt$type_specification;
         initial_value: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$var_already_created
*copyc clt$data_access_mode
*copyc clt$data_value
*copyc clt$expression_eval_method
*copyc clt$procedure_variable_scope
*copyc clt$type_specification
*copyc clt$variable_name_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CREATE_UTILITY_ENVIRONMENT EXPAND=FALSE

  PROCEDURE [XREF] clp$create_utility_environment
    (    name: clt$utility_name;
         defined_at_command_level: boolean;
         called_from_push_utility: boolean;
         attributes: clt$utility_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$utility_attributes
*copyc clt$utility_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CREATE_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] clp$create_variable
    (    name: string ( * );
         kind: clt$variable_kinds;
         max_string_size: ost$string_size;
         lower_bound: clt$variable_dimension;
         upper_bound: clt$variable_dimension;
         scope: clt$variable_scope;
     VAR variable: clt$variable_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$variable_reference
*copyc cle$ecc_variable
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$CREATE_VARIABLE_TYPE EXPAND=FALSE

  PROCEDURE [XREF] clp$create_variable_type
    (    kind: clt$variable_kinds;
         max_string_size: clt$string_size;
         create_array: boolean;
         lower_bound: clt$variable_dimension;
         upper_bound: clt$variable_dimension;
     VAR work_area {input, output} : ^clt$work_area;
     VAR type_specification: ^clt$type_specification;
     VAR type_description: ^clt$type_description;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$variable_reference
*copyc clt$string_size
*copyc clt$type_description
*copyc clt$type_specification
*copyc clt$variable_kinds
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CREATE_VAR_FROM_CONVERSION EXPAND=FALSE

  PROCEDURE [XREF] clp$create_var_from_conversion
    (    name: ost$name;
         kind: clt$variable_kinds;
         max_string_size: clt$string_size;
         create_array: boolean;
         lower_bound: clt$variable_dimension;
         upper_bound: clt$variable_dimension;
         scope: clt$variable_scope;
         initial_value: ^clt$data_value;
         return_variable: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR variable: clt$variable_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$variable_reference
*copyc clt$data_value
*copyc clt$string_size
*copyc clt$variable_kinds
*copyc clt$work_area
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CREATE_VAR_FROM_TYPE_SPEC EXPAND=FALSE

  PROCEDURE [XREF] clp$create_var_from_type_spec
    (    name: clt$variable_name;
         scope: clt$variable_declaration_scope;
         access_mode: clt$data_access_mode;
         evaluation_method: clt$expression_eval_method;
         type_specification: ^clt$type_specification;
         initial_value: ^clt$data_value;
         require_existing_var_for_push: boolean;
     VAR work_area {input, output}: ^clt$work_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_access_mode
*copyc clt$data_value
*copyc clt$expression_eval_method
*copyc clt$type_specification
*copyc clt$variable_declaration_scope
*copyc clt$variable_name
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$CYCLE_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$cycle_block
    (    target_label: ost$name;
         no_more_iterations: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DATA_REPRESENTATION_TEXT EXPAND=FALSE

  FUNCTION [INLINE] clp$data_representation_text
    (    representation: ^clt$data_representation): ^clt$string_value;

?? PUSH (LISTEXT := ON) ??

    VAR
      representation_text: ^clt$string_value,
      representation_area: ^clt$data_representation,
      representation_line_count: ^clt$data_representation_count,
      representation_text_size: ^clt$string_size;


    representation_area := representation;
    RESET representation_area;
    NEXT representation_line_count IN representation_area;
    IF representation_line_count^ = 0 THEN
      RESET representation_area;
      NEXT representation_text: [0] IN representation_area;
    ELSE
      NEXT representation_text_size IN representation_area;
      NEXT representation_text: [representation_text_size^] IN
            representation_area;
    IFEND;
    clp$data_representation_text := representation_text;

  FUNCEND clp$data_representation_text;

*copyc clt$data_representation
*copyc clt$data_representation_count
*copyc clt$string_size
*copyc clt$string_value
?? POP ??
*DECK DECK=CLP$DATA_VALUE_COMPARE EXPAND=FALSE

  FUNCTION [XREF, UNSAFE] clp$data_value_compare
    (    left_value: ^clt$data_value;
         right_value: ^clt$data_value): clt$comparison_result;

?? PUSH (LISTEXT := ON) ??
*copyc clt$comparison_result
*copyc clt$data_value
?? POP ??
*DECK DECK=CLP$DATE_TIME_COMPARE EXPAND=FALSE

  FUNCTION [XREF] clp$date_time_compare
    (    left_date_time: clt$date_time;
         right_date_time: clt$date_time): clt$comparison_result;

?? PUSH (LISTEXT := ON) ??
*copyc clt$comparison_result
*copyc clt$date_time
?? POP ??

*DECK DECK=CLP$DEFAULT_UNSEEN_MAIL_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] clp$default_unseen_mail_handler
    (    ignore_condition: pmt$condition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$condition
?? POP ??
*DECK DECK=CLP$DEFINE_APPLICATION_MENU EXPAND=FALSE

  PROCEDURE [XREF] clp$define_application_menu
    (VAR work_area_ptr: ^SEQ ( * );
         menu_name: ost$status_condition_name;
         module_name: pmt$program_name;
     VAR number_of_classes: cst$max_classes;
     VAR number_of_items: cst$menu_item_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$max_classes
*copyc cst$menu_item_number
*copyc ost$status
*copyc ost$status_condition_name
*copyc pmt$program_name
?? POP ??
*DECK DECK=CLP$DEFINE_APPLIC_UNIT_ARRAY EXPAND=FALSE

  PROCEDURE [XREF] clp$define_applic_unit_array
    (    application_unit_array: ^clt$application_unit_array;
         application_unit_array_size: clt$application_unit_array_size;
         application_address: ost$pva;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc clt$application_unit_array
*copyc clt$application_unit_array_size
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DEFINE_INITIAL_APPLICATION EXPAND=FALSE

  PROCEDURE [XREF] clp$define_initial_application
    (    application: ^clt$command_line;
         logout_upon_termination: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DEFINE_MESSAGE_MODULE EXPAND=FALSE

  PROCEDURE [XREF] clp$define_message_module
    (    module_name: pmt$program_name;
         natural_language: ost$natural_language;
         online_manual_name: ost$online_manual_name;
         work_area: ^SEQ ( * );
     VAR message_module: ^ost$message_template_module;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_mt_generator
*copyc ost$message_template_module
*copyc ost$natural_language
*copyc ost$online_manual_name
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=CLP$DEFINE_SCL_PROCEDURE EXPAND=FALSE

  PROCEDURE [XREF] clp$define_scl_procedure
    (    file_id: amt$file_identifier;
         work_area: ^SEQ ( * );
     VAR procedure_name: pmt$program_name;
     VAR aliases: ^array [1 .. * ] of pmt$program_name;
     VAR command_or_function: clt$command_or_function;
     VAR availability: clt$named_entry_availability;
     VAR command_kind: llt$command_kind;
     VAR command_log_option: clt$command_log_option;
     VAR scl_procedure: ^clt$scl_procedure;
     VAR file_position: amt$file_position;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$file_position
*copyc cle$expecting_proc
*copyc clt$command_log_option
*copyc clt$command_or_function
*copyc clt$named_entry_availability
*copyc clt$scl_procedure
*copyc llt$command_kind
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=CLP$DELETE_ALL_FILE_CONNECTIONS EXPAND=FALSE

  PROCEDURE [XREF] clp$delete_all_file_connections;

*DECK DECK=CLP$DELETE_ALL_FROM_CMND_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$delete_all_from_cmnd_list
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DELETE_ALL_TARGETS EXPAND=FALSE

  PROCEDURE [XREF] clp$delete_all_targets
    (    subject_file: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_connected_file
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DELETE_CURRENT_FORMAT_TOKEN EXPAND=FALSE

  PROCEDURE [XREF] clp$delete_current_format_token;

*DECK DECK=CLP$DELETE_EXPANDABLE_STRING EXPAND=FALSE

  PROCEDURE [INLINE] clp$delete_expandable_string
    (VAR expandable_string {input,output} : clt$expandable_string);

?? PUSH (LISTEXT := ON) ??

    IF expandable_string.area <> NIL THEN
      FREE expandable_string.area IN osv$task_shared_heap^;
    IFEND;

  PROCEND clp$delete_expandable_string;

*copyc clt$expandable_string
?? POP ??
*copyc osv$task_shared_heap
*DECK DECK=CLP$DELETE_FILE_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] clp$delete_file_connection
    (    subject_file: fst$file_reference;
         target_file: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc cle$ecc_connected_file
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DELETE_FILE_FROM_CMND_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$delete_file_from_cmnd_list
    (    entry: clt$command_list_entry_file;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_command_processing
*copyc clt$command_list_entry_file
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DELETE_FROM_DEFER_LIST EXPAND=FALSE
  PROCEDURE [XREF] clp$delete_from_defer_list;

*DECK DECK=CLP$DELETE_NAMED_TASK_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] clp$delete_named_task_entry
    (    task_name: ost$name);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=CLP$DELETE_NODE_FORMAT_TOKEN EXPAND=FALSE
  PROCEDURE [XREF] clp$delete_node_format_token
    (index: clt$token_array_index);

?? PUSH (LISTEXT := ON) ??
*copyc clt$format_token_type
?? POP ??
*DECK DECK=CLP$DELETE_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] clp$delete_parameters
    (VAR parameters {input, output} : clt$parameters);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameters
?? POP ??
*DECK DECK=CLP$DELETE_UTIL_FROM_CMND_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$delete_util_from_cmnd_list
    (    block: ^clt$block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DELETE_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] clp$delete_variable
    (    name: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_variable
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DELETE_VARIABLES EXPAND=FALSE

  PROCEDURE [XREF] clp$delete_variables
    (VAR variables: clt$variables);

?? PUSH (LISTEXT := ON) ??
*copyc clt$variables
?? POP ??
*DECK DECK=CLP$DELETE_VARIABLE_ACCESS EXPAND=FALSE

  PROCEDURE [INLINE] clp$delete_variable_access
    (    hashed_name: clt$variable_name;
         hash: clt$variable_name_hash;
         allowed_classes: clt$internal_variable_classes;
     VAR variable_descriptor: ^clt$variable_descriptor);

?? PUSH (LISTEXT := ON) ??

    VAR
      associated_utility: boolean,
      block: ^clt$block,
      classes: clt$internal_variable_classes,
      inherited_allowed_classes: clt$internal_variable_classes,
      inherited_block: ^clt$block;


    variable_descriptor := NIL;
    classes := allowed_classes * (-$clt$internal_variable_classes [clc$lib_variable, clc$param_variable]);
    clp$find_first_var_block (classes, inherited_allowed_classes, inherited_block, block,
          associated_utility);

    WHILE block <> NIL DO
      IF (inherited_block <> NIL) AND (block^.kind IN $clt$block_kinds [clc$command_proc_block,
            clc$function_proc_block]) AND block^.parameters.evaluated THEN
        classes := classes * $clt$internal_variable_classes [clc$env_variable, clc$pushed_variable];
      IFEND;
      clp$delete_variable_from_tree (hashed_name, hash, classes, block^.variables, variable_descriptor);
      IF variable_descriptor <> NIL THEN
        RETURN;
      IFEND;
      IF block^.kind IN $clt$block_kinds [clc$command_proc_block, clc$function_proc_block] THEN
        classes := classes * $clt$internal_variable_classes [clc$env_variable, clc$pushed_variable];
      IFEND;
      IF associated_utility AND (block = inherited_block) THEN
        classes := classes * $clt$internal_variable_classes [clc$env_variable, clc$pushed_variable];
      IFEND;
      clp$find_next_var_block (classes, inherited_allowed_classes, inherited_block, block,
            associated_utility);
    WHILEND;

  PROCEND clp$delete_variable_access;

*copyc clt$block
*copyc clt$internal_variable_classes
*copyc clt$variable_descriptor
*copyc clt$variable_name
*copyc clt$variable_name_hash
*copyc ost$status
?? POP ??
*copyc clp$delete_variable_from_tree
*copyc clp$find_first_var_block
*copyc clp$find_next_var_block
*DECK DECK=CLP$DELETE_VARIABLE_FROM_TREE EXPAND=FALSE

  PROCEDURE [INLINE] clp$delete_variable_from_tree
    (    hashed_name: clt$variable_name;
         hash: clt$variable_name_hash;
         allowed_data_classes: clt$internal_variable_classes;
     VAR variables {input, output}: clt$variables;
     VAR variable_descriptor: ^clt$variable_descriptor);

?? PUSH (LISTEXT := ON) ??

    VAR
      access_to_be_deleted: ^clt$variable_access,
      current_access: ^^clt$variable_access,
      replacement: ^^clt$variable_access;


    variable_descriptor := NIL;
    current_access := ^variables.hash_groups [hash].root;

  /locate_variable/
    WHILE current_access^ <> NIL DO
      IF hashed_name < current_access^^.hashed_name THEN
        current_access := ^current_access^^.left_search_tree;
      ELSEIF hashed_name > current_access^^.hashed_name THEN
        current_access := ^current_access^^.right_search_tree;
      ELSE
        EXIT /locate_variable/;
      IFEND;
    WHILEND /locate_variable/;

    IF (current_access^ = NIL) OR  NOT (current_access^^.info.class IN allowed_data_classes) THEN
      RETURN;
    IFEND;

    access_to_be_deleted := current_access^;
    CASE current_access^^.info.class OF
    = clc$env_variable, clc$lib_variable, clc$pushed_variable =
      variables.hash_groups [hash].environment_variables_in_group :=
            variables.hash_groups [hash].environment_variables_in_group - 1;
    ELSE
      variables.hash_groups [hash].procedure_variables_in_group :=
            variables.hash_groups [hash].procedure_variables_in_group - 1;
    CASEND;
    variable_descriptor := current_access^^.info.descriptor;

    IF current_access^^.backward_thread <> NIL THEN
      current_access^^.backward_thread^.forward_thread := current_access^^.forward_thread;
    ELSE
      variables.thread := current_access^^.forward_thread;
    IFEND;
    IF current_access^^.forward_thread <> NIL THEN
      current_access^^.forward_thread^.backward_thread := current_access^^.backward_thread;
    IFEND;

{ Remove variable from the search tree.

    IF current_access^^.left_search_tree = NIL THEN
      current_access^ := current_access^^.right_search_tree;
    ELSEIF current_access^^.right_search_tree = NIL THEN
      current_access^ := current_access^^.left_search_tree;
    ELSE

{ Find largest member of variable's left search tree and use it to replace the deleted variable in the tree.

      replacement := ^current_access^^.left_search_tree;
      WHILE replacement^^.right_search_tree <> NIL DO
        replacement := ^replacement^^.right_search_tree;
      WHILEND;
      current_access^ := replacement^;
      replacement^ := replacement^^.left_search_tree;
      current_access^^.right_search_tree := access_to_be_deleted^.right_search_tree;
      current_access^^.left_search_tree := access_to_be_deleted^.left_search_tree;
    IFEND;

    access_to_be_deleted^.info.assignment_counter := 0;
    access_to_be_deleted^.info.descriptor := NIL;
    FREE access_to_be_deleted IN osv$task_shared_heap^;

  PROCEND clp$delete_variable_from_tree;

*copyc clt$internal_variable_classes
*copyc clt$variables
*copyc clt$variable_access
*copyc clt$variable_descriptor
*copyc clt$variable_name
*copyc clt$variable_name_hash
?? POP ??
*DECK DECK=CLP$DERIVE_TYPE_DESC_FROM_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$derive_type_desc_from_value
    (    value: ^clt$data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR type_description: clt$type_description;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$type_description
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DERIVE_TYPE_SPEC_FROM_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$derive_type_spec_from_value
    (    value: ^clt$data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR type_specification: ^clt$type_specification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$type_specification
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DETERMINE_LINE_LAYOUT EXPAND=FALSE

  PROCEDURE [XREF] clp$determine_line_layout
    (    file_reference: fst$file_reference;
*IF NOT $true(osv$unix)
         record_type: amt$record_type,
         max_record_length: amt$max_record_length;
         line_number_present: boolean;
         line_number: amt$line_number;
         statement_identifier_present: boolean;
         statement_identifier: amt$statement_identifier;
*IFEND
     VAR line_layout: clt$line_layout;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc amd$file_attributes
*copyc amt$line_number
*copyc amt$max_record_length
*copyc amt$statement_identifier
*IFEND
*copyc clt$line_layout
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DETERMINE_SELECT_RESULT_TYP EXPAND=FALSE

  PROCEDURE [XREF] clp$determine_select_result_typ
    (VAR work_area {input, output} : ^clt$work_area;
     VAR return_selected_indices: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DETERMINE_WHEN_CONDITION EXPAND=FALSE

  PROCEDURE [XREF] clp$determine_when_condition
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR when_condition: clt$when_condition_definition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$when_condition_definition
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc pmt$condition
*copyc pmt$condition_information
?? POP ??
*DECK DECK=CLP$DISCARD_ACCUMULATED_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] clp$discard_accumulated_display
    (VAR display_control {input, output} : clt$display_control;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DISESTABLISH_COND_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] clp$disestablish_cond_handler
    (    any_condition: boolean;
         any_fault: boolean;
         specific_conditions: ^clt$when_conditions);

?? PUSH (LISTEXT := ON) ??
*copyc clt$when_conditions
?? POP ??
*DECK DECK=CLP$DISPLAY_CMND_OR_FUNC_INFO EXPAND=FALSE

  PROCEDURE [XREF] clp$display_cmnd_or_func_info
    (    default_file_contents: amt$file_contents;
         help_context: clt$parameter_help_context;
         command_or_function_source: clt$command_or_function_source;
         command_or_function_name: clt$command_name;
         pdt: clt$unbundled_pdt;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_contents
*copyc clt$command_name
*copyc clt$command_or_function_source
*copyc clt$parameter_help_context
*copyc clt$unbundled_pdt
*copyc fsc$file_contents
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DISPLAY_COMMAND_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] clp$display_command_parameters
    (    local_file_name: amt$local_file_name;
         command_name: ost$name;
         pdt: clt$parameter_descriptor_table;
         default_file_contents: amt$file_contents;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_contents
*copyc amt$local_file_name
*copyc clt$parameter_descriptor_table
*copyc fsc$file_contents
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DISPLAY_FUNCTION_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] clp$display_function_parameters
    (    local_file_name: amt$local_file_name;
         function_name: ost$name;
         adt: ^clt$argument_descriptor_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc clt$argument_descriptor_table
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DISPLAY_SCL_PROC_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] clp$display_scl_proc_parameters
    (VAR display_control {input, output} : clt$display_control;
         scl_procedure: ^clt$scl_procedure;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc clt$scl_procedure
*copyc ost$status
?? POP ??
*DECK DECK=CLP$DISPLAY_TAPE_LABEL_ATTR_CMD EXPAND=FALSE

  PROCEDURE [XREF] clp$display_tape_label_attr_cmd (
        parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc clt$parameter_list
*copyc ost$status
?? POP ??

*DECK DECK=CLP$DTOD EXPAND=FALSE

  FUNCTION [XREF] clp$dtod
    (    left: longreal;
         right: longreal): longreal;

*DECK DECK=CLP$DTOI EXPAND=FALSE

  FUNCTION [XREF] clp$dtoi
    (    left: longreal;
         right: integer): longreal;

*DECK DECK=CLP$ECHO_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] clp$echo_command
    (    interpreter_mode: clt$interpreter_modes;
         command: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$interpreter_modes
*copyc ost$status
?? POP ??
*DECK DECK=CLP$ECHO_TRACE_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] clp$echo_trace_information
    (    message_name: ost$name_reference;
         identifying_name: ^ost$name_reference;
         file_reference: ^fst$file_reference;
         message_status: ^ost$status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$name_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EDIT_COMMAND_PARAMETER_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$edit_command_parameter_list
    (    command_and_parameters: clt$command_line;
         max_string: clt$string_size;
     VAR work_area {input, output} : ^clt$work_area;
     VAR edited_parameters: ^clt$data_representation;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$work_area_overflow
*copyc clt$command_line
*copyc clt$data_representation
*copyc clt$string_size
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$END_INCLUDE EXPAND=FALSE

  PROCEDURE [XREF] clp$end_include
    (    utility: clt$utility_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_utilities
*copyc clt$utility_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$END_SCAN_COMMAND_FILE EXPAND=FALSE

{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     ****** This program interface is obsolete.  Modules presently    ******
{     ****** using it should be changed to use CLP$END_INCLUDE.        ******
{     ***********************************************************************
{     ***********************************************************************
{

  PROCEDURE [XREF] clp$end_scan_command_file
    (    utility_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_utilities
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$END_UTILITY EXPAND=FALSE

  PROCEDURE [XREF] clp$end_utility
    (    name: clt$utility_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_utilities
*copyc clt$utility_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$ENTRY_POINT_REF_COMPARE EXPAND=FALSE

  FUNCTION [XREF, UNSAFE] clp$entry_point_ref_compare
    (    left_entry_point_reference: pmt$entry_point_reference;
         right_entry_point_reference: pmt$entry_point_reference):
         clt$comparison_result;

?? PUSH (LISTEXT := ON) ??
*copyc clt$comparison_result
*copyc pmt$entry_point_reference
?? POP ??
*DECK DECK=CLP$ENVIRONMENT_OBJECT_IN_BLOCK EXPAND=FALSE

  FUNCTION [XREF] clp$environment_object_in_block
    (    object_ordinal: clt$environment_object_ordinal;
         block: ^clt$block): ^clt$environment_object_contents;

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc clt$environment_object_ordinal
?? POP ??
*DECK DECK=CLP$ENVIRONMENT_OBJECT_NAME EXPAND=FALSE

  FUNCTION [XREF] clp$environment_object_name
    (    object_ordinal: clt$environment_object_ordinal):
        ^clt$environment_object;

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object
*copyc clt$environment_object_ordinal
?? POP ??
*DECK DECK=CLP$EO_INIT_COMMAND_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$eo_init_command_list
    (    object: ^clt$environment_object_contents);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
?? POP ??
*DECK DECK=CLP$EO_INIT_FILE_CONNECTIONS EXPAND=FALSE

  PROCEDURE [XREF] clp$eo_init_file_connections
    (    object: ^clt$environment_object_contents);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
?? POP ??
*DECK DECK=CLP$EO_INIT_SCL_OPTIONS EXPAND=FALSE

  PROCEDURE [XREF] clp$eo_init_scl_options
    (    object: ^clt$environment_object_contents);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
?? POP ??
*DECK DECK=CLP$EO_INIT_UNSEEN_MAIL_ACTION EXPAND=FALSE

  PROCEDURE [XREF] clp$eo_init_unseen_mail_action
    (    object: ^clt$environment_object_contents);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
?? POP ??
*DECK DECK=CLP$EO_INIT_WORKING_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] clp$eo_init_working_catalog
    (    object: ^clt$environment_object_contents);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
?? POP ??
*DECK DECK=CLP$EO_POP_COMMAND_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$eo_pop_command_list
    (    pop_reason: clt$env_object_pop_reason;
         object: ^clt$environment_object_contents;
         object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc clt$env_object_pop_reason
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EO_POP_FILE_CONNECTIONS EXPAND=FALSE

  PROCEDURE [XREF] clp$eo_pop_file_connections
    (    pop_reason: clt$env_object_pop_reason;
         object: ^clt$environment_object_contents;
         object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc clt$env_object_pop_reason
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EO_POP_UNSEEN_MAIL_ACTION EXPAND=FALSE

  PROCEDURE [XREF] clp$eo_pop_unseen_mail_action
    (    pop_reason: clt$env_object_pop_reason;
         object: ^clt$environment_object_contents;
         object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc clt$env_object_pop_reason
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EO_POP_WORKING_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] clp$eo_pop_working_catalog
    (    pop_reason: clt$env_object_pop_reason;
         object: ^clt$environment_object_contents;
         object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc clt$env_object_pop_reason
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EO_PUSH_COMMAND_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$eo_push_command_list
    (    push_reason: clt$env_object_push_reason;
         new_object: ^clt$environment_object_contents;
         new_object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc clt$env_object_push_reason
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EO_PUSH_FILE_CONNECTIONS EXPAND=FALSE

  PROCEDURE [XREF] clp$eo_push_file_connections
    (    push_reason: clt$env_object_push_reason;
         new_object: ^clt$environment_object_contents;
         new_object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc clt$env_object_push_reason
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EO_PUSH_WORKING_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] clp$eo_push_working_catalog
    (    push_reason: clt$env_object_push_reason;
         new_object: ^clt$environment_object_contents;
         new_object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc clt$env_object_push_reason
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EO_SIZE_COMMAND_LIST EXPAND=FALSE

  FUNCTION [XREF] clp$eo_size_command_list: clt$environment_object_size;

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_size
?? POP ??
*DECK DECK=CLP$EO_SIZE_FILE_CONNECTIONS EXPAND=FALSE

  FUNCTION [XREF] clp$eo_size_file_connections: clt$environment_object_size;

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_size
?? POP ??
*DECK DECK=CLP$EO_SIZE_SCL_OPTIONS EXPAND=FALSE

  FUNCTION [XREF] clp$eo_size_scl_options: clt$environment_object_size;

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_size
?? POP ??
*DECK DECK=CLP$EO_SIZE_UNSEEN_MAIL_ACTION EXPAND=FALSE

  FUNCTION [XREF] clp$eo_size_unseen_mail_action: clt$environment_object_size;

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_size
?? POP ??
*DECK DECK=CLP$EO_SIZE_WORKING_CATALOG EXPAND=FALSE

  FUNCTION [XREF] clp$eo_size_working_catalog: clt$environment_object_size;

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_size
?? POP ??
*DECK DECK=CLP$EO_UPDT_COMMAND_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$eo_updt_command_list
    (    synchronous_with_parent: boolean;
         synchronous_with_job: boolean;
         current_object: ^clt$environment_object_contents;
         current_object_in_current_task: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EO_UPDT_UNSEEN_MAIL_ACTION EXPAND=FALSE

  PROCEDURE [XREF] clp$eo_updt_unseen_mail_action
    (    synchronous_with_parent: boolean;
         synchronous_with_job: boolean;
         current_object: ^clt$environment_object_contents;
         current_object_in_current_task: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc ost$status
?? POP ??
*DECK DECK=CLP$ERASE_CHILD_TASK EXPAND=FALSE

  PROCEDURE [XREF] clp$erase_child_task
    (    child_task_id: pmt$task_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$task_id
?? POP ??
*DECK DECK=CLP$ESTABLISH_CONDITION_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] clp$establish_condition_handler
    (    any_condition: boolean;
         any_fault: boolean;
         specific_conditions: ^clt$when_conditions;
         statement_area: ^clt$collect_statement_area;
         can_be_echoed: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$collect_statement_area
*copyc clt$when_conditions
*copyc ost$status
?? POP ??
*DECK DECK=CLP$ESTABLISH_SYS_COMMAND_LIB EXPAND=FALSE

  PROCEDURE [XREF] clp$establish_sys_command_lib
    (    file: ^fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EVALUATE_BOOLEAN_EXPRESSION EXPAND=FALSE

  PROCEDURE [INLINE] clp$evaluate_boolean_expression
    (VAR work_area {input} : ^clt$work_area;
     VAR parse {input, output} : clt$parse_state;
     VAR result: clt$boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_result_type_description: ^clt$type_description,
      original_work_area: ^clt$work_area,
      type_description: clt$type_description,
      value: ^clt$data_value;


    type_description.specification := NIL;
    type_description.name := NIL;
    type_description.derived_from_value_kind_spec := FALSE;
    type_description.advanced_keywords_present := FALSE;
*IF NOT $true(osv$unix)
    type_description.kinds := $clt$type_kinds [clc$boolean_type];
*ELSE
    type_description.kinds := $clt$type_kinds_v2 [clc$boolean_type];
*IFEND
    type_description.kind := clc$boolean_type;

    original_work_area := work_area;
    clp$internal_evaluate_expr (parse, ^type_description, work_area,
          ignore_result_type_description, value, status);
    work_area := original_work_area;

    IF status.normal THEN
      IF value^.kind = clc$unspecified THEN
        osp$set_status_abnormal ('CL', cle$unspecified_value_for_req,
              'clp$evaluate_expression', status);
      ELSE
        result := value^.boolean_value;
      IFEND;
    IFEND;

  PROCEND clp$evaluate_boolean_expression;

*copyc cle$ecc_parsing
*copyc clt$boolean
*copyc clt$parse_state
*copyc clt$work_area
*copyc ost$status
?? POP ??
*copyc clp$internal_evaluate_expr
*copyc osp$set_status_abnormal
*DECK DECK=CLP$EVALUATE_COMMAND_REFERENCE EXPAND=FALSE

  PROCEDURE [XREF] clp$evaluate_command_reference
    (VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
         get_path_handle_name: boolean;
     VAR path_handle_name: fst$path_handle_name;
     VAR command_reference: clt$command_reference;
     VAR utility_command_list_entry: ^clt$command_list_entry;
     VAR parameter_name: clt$parameter_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_list
*copyc clt$command_reference
*copyc clt$parameter_name
*copyc clt$parse_state
*copyc clt$work_area
*copyc fst$path_handle_name
?? POP ??
*DECK DECK=CLP$EVALUATE_DATA_NAME_EXPR EXPAND=FALSE

  PROCEDURE [INLINE] clp$evaluate_data_name_expr
    (VAR work_area {input} : ^clt$work_area;
     VAR parse {input, output} : clt$parse_state;
     VAR result: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_result_type_description: ^clt$type_description,
      original_work_area: ^clt$work_area,
      type_description: clt$type_description,
      value: ^clt$data_value;


    type_description.specification := NIL;
    type_description.name := NIL;
    type_description.derived_from_value_kind_spec := FALSE;
    type_description.advanced_keywords_present := FALSE;
*IF NOT $true(osv$unix)
    type_description.kinds := $clt$type_kinds [clc$data_name_type];
*ELSE
    type_description.kinds := $clt$type_kinds_v2 [clc$data_name_type];
*IFEND
    type_description.kind := clc$data_name_type;

    original_work_area := work_area;
    clp$internal_evaluate_expr (parse, ^type_description, work_area,
          ignore_result_type_description, value, status);
    work_area := original_work_area;

    IF status.normal THEN
      IF value^.kind = clc$unspecified THEN
        osp$set_status_abnormal ('CL', cle$unspecified_value_for_req,
              'clp$evaluate_expression', status);
      ELSE
        result := value^.data_name_value;
      IFEND;
    IFEND;

  PROCEND clp$evaluate_data_name_expr;

*copyc cle$ecc_parsing
*copyc clt$parse_state
*copyc clt$work_area
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc clp$internal_evaluate_expr
*copyc osp$set_status_abnormal
*DECK DECK=CLP$EVALUATE_EXPRESSION EXPAND=FALSE

  PROCEDURE [XREF] clp$evaluate_expression
    (    expression: clt$expression_text;
         type_specification: ^clt$type_specification;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$expression_text
*copyc clt$type_specification
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EVALUATE_EXPRESSION_TO_STR EXPAND=FALSE

  PROCEDURE [XREF] clp$evaluate_expression_to_str
    (    expression: clt$expression_text;
     VAR result_string: clt$string_value;
     VAR type_name: clt$type_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$expression_text
*copyc clt$string_value
*copyc clt$type_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EVALUATE_FILE_REFERENCE EXPAND=FALSE

  PROCEDURE [XREF] clp$evaluate_file_reference
    (    file: fst$file_reference;
         file_reference_parsing_options: clt$file_ref_parsing_options;
         resolve_cycle_number: boolean;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$file_ref_parsing_options
*copyc fst$evaluated_file_reference
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EVALUATE_FUNCTION EXPAND=FALSE

  PROCEDURE [XREF] clp$evaluate_function
    (    evaluate_for_write: boolean;
         name: clt$function_name;
         context_type_description: ^clt$type_description;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: clt$function_result;
     VAR found: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$function_name
*copyc clt$function_result
*copyc clt$parse_state
*copyc clt$type_description
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EVALUATE_INTEGER_EXPRESSION EXPAND=FALSE

  PROCEDURE [INLINE] clp$evaluate_integer_expression
    (    min_integer_result: integer;
         max_integer_result: integer;
     VAR work_area {input} : ^clt$work_area;
     VAR parse {input, output} : clt$parse_state;
     VAR result: clt$integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_result_type_description: ^clt$type_description,
      original_work_area: ^clt$work_area,
      type_description: clt$type_description,
      value: ^clt$data_value;


    type_description.specification := NIL;
    type_description.name := NIL;
    type_description.derived_from_value_kind_spec := FALSE;
    type_description.advanced_keywords_present := FALSE;
*IF NOT $true(osv$unix)
    type_description.kinds := $clt$type_kinds [clc$integer_type];
*ELSE
    type_description.kinds := $clt$type_kinds_v2 [clc$integer_type];
*IFEND
    type_description.kind := clc$integer_type;
    type_description.min_integer_value := min_integer_result;
    type_description.max_integer_value := max_integer_result;
    type_description.default_radix := 10;

    original_work_area := work_area;
    clp$internal_evaluate_expr (parse, ^type_description, work_area,
          ignore_result_type_description, value, status);
    work_area := original_work_area;

    IF status.normal THEN
      IF value^.kind = clc$unspecified THEN
        osp$set_status_abnormal ('CL', cle$unspecified_value_for_req,
              'clp$evaluate_expression', status);
      ELSE
        result := value^.integer_value;
      IFEND;
    IFEND;

  PROCEND clp$evaluate_integer_expression;

*copyc cle$ecc_parsing
*copyc clt$integer
*copyc clt$parse_state
*copyc clt$work_area
*copyc ost$status
?? POP ??
*copyc clp$internal_evaluate_expr
*copyc osp$set_status_abnormal
*DECK DECK=CLP$EVALUATE_LIST_EXPRESSION EXPAND=FALSE

  PROCEDURE [INLINE] clp$evaluate_list_expression
    (    min_list_size: clt$list_size;
         max_list_size: clt$list_size;
         list_rest: boolean;
         element_type_description: ^clt$type_description;
     VAR work_area {input, output} : ^clt$work_area;
     VAR parse {input, output} : clt$parse_state;
     VAR result_type_description: ^clt$type_description;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      type_description: clt$type_description;


    type_description.specification := NIL;
    type_description.name := NIL;
    type_description.derived_from_value_kind_spec := FALSE;
    type_description.advanced_keywords_present := FALSE;
*IF NOT $true(osv$unix)
    type_description.kinds := $clt$type_kinds [clc$list_type];
*ELSE
    type_description.kinds := $clt$type_kinds_v2 [clc$list_type];
*IFEND
    type_description.kind := clc$list_type;
    type_description.list_element_type_description := element_type_description;
    type_description.min_list_size := min_list_size;
    type_description.max_list_size := max_list_size;
    type_description.list_rest := list_rest;

    clp$internal_evaluate_expr (parse, ^type_description, work_area,
          result_type_description, result, status);

    IF status.normal AND (result^.kind = clc$unspecified) THEN
      osp$set_status_abnormal ('CL', cle$unspecified_value_for_req,
            'clp$evaluate_expression', status);
    IFEND;

  PROCEND clp$evaluate_list_expression;

*copyc cle$ecc_parsing
*copyc clt$data_value
*copyc clt$list_size
*copyc clt$parse_state
*copyc clt$type_description
*copyc clt$work_area
*copyc ost$status
?? POP ??
*copyc clp$internal_evaluate_expr
*copyc osp$set_status_abnormal
*DECK DECK=CLP$EVALUATE_NAME EXPAND=FALSE

  PROCEDURE [INLINE] clp$evaluate_name
    (    name: clt$variable_name;
         access_variable_requests: clt$access_variable_requests;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value;
     VAR found: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_actual_name: clt$variable_name,
      ignore_last_qualifier_is_field: boolean,
      ignore_variable_information: clt$variable_information;


    clp$evaluate_name_for_read (name, NIL, access_variable_requests, parse,
          work_area, ignore_actual_name, ignore_variable_information, value,
          found, ignore_last_qualifier_is_field, status);

  PROCEND clp$evaluate_name;

*copyc clt$access_variable_requests
*copyc clt$data_value
*copyc clt$parse_state
*copyc clt$variable_information
*copyc clt$variable_name
*copyc clt$work_area
*copyc ost$status
?? POP ??
*copyc clp$evaluate_name_for_read
*DECK DECK=CLP$EVALUATE_NAME_FOR_READ EXPAND=FALSE

  PROCEDURE [XREF] clp$evaluate_name_for_read
    (    name: clt$variable_name;
         context_type_description: ^clt$type_description;
         access_variable_requests: clt$access_variable_requests;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR variable_name: clt$variable_name;
     VAR variable_information: clt$variable_information;
     VAR value: ^clt$data_value;
     VAR found: boolean;
     VAR last_qualifier_is_field: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$access_variable_requests
*copyc clt$data_value
*copyc clt$parse_state
*copyc clt$variable_information
*copyc clt$variable_name
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EVALUATE_NAME_FOR_WRITE EXPAND=FALSE

  PROCEDURE [XREF] clp$evaluate_name_for_write
    (    name: clt$variable_name;
         access_variable_requests: clt$access_variable_requests;
         evaluating_for_var_parameter: boolean;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR variable_name: clt$variable_name;
     VAR variable_information: clt$variable_information;
     VAR access_handle: clt$variable_access_handle;
     VAR complete_type_description: ^clt$type_description;
     VAR found: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$access_variable_requests
*copyc clt$parse_state
*copyc clt$type_description
*copyc clt$value_qualifiers
*copyc clt$variable_access_handle
*copyc clt$variable_information
*copyc clt$variable_name
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EVALUATE_NUMERIC_EXPRESSION EXPAND=FALSE

  PROCEDURE [INLINE] clp$evaluate_numeric_expression
    (VAR work_area {input} : ^clt$work_area;
     VAR parse {input, output} : clt$parse_state;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_result_type_description: ^clt$type_description,
      members: array [1 .. 2] of clt$type_description,
      original_work_area: ^clt$work_area,
      type_description: clt$type_description,
      union_info: clt$union_type_information;


    status.normal := TRUE;
    result := NIL;

    type_description.specification := NIL;
    type_description.name := NIL;
    type_description.derived_from_value_kind_spec := FALSE;
    type_description.advanced_keywords_present := FALSE;
*IF NOT $true(osv$unix)
    type_description.kinds := $clt$type_kinds
*ELSE
    type_description.kinds := $clt$type_kinds_v2
*IFEND
          [clc$integer_type, clc$real_type];
    type_description.kind := clc$union_type;
    type_description.member_descriptions := ^members;
    type_description.union_information := ^union_info;

    union_info.only_standard_types_in_union := TRUE;
    union_info.min_integer_value := clc$min_integer;
    union_info.max_integer_value := clc$max_integer;
    union_info.default_radix := 10;
*IF NOT $true(osv$unix)
    #UNCHECKED_CONVERSION (clv$negative_infinity^,
          union_info.min_real_value.long_real);
    #UNCHECKED_CONVERSION (clv$positive_infinity^,
          union_info.max_real_value.long_real);
*ELSE
    union_info.min_real_value.long_real := clv$negative_infinity^;
    union_info.max_real_value.long_real := clv$positive_infinity^;
*IFEND

    members [1].specification := NIL;
    members [1].name := NIL;
    members [1].derived_from_value_kind_spec := FALSE;
    members [1].advanced_keywords_present := FALSE;
*IF NOT $true(osv$unix)
    members [1].kinds := $clt$type_kinds [clc$integer_type];
*ELSE
    members [1].kinds := $clt$type_kinds_v2 [clc$integer_type];
*IFEND
    members [1].kind := clc$integer_type;
    members [1].min_integer_value := clc$min_integer;
    members [1].max_integer_value := clc$max_integer;
    members [1].default_radix := 10;

    members [2].specification := NIL;
    members [2].name := NIL;
    members [2].derived_from_value_kind_spec := FALSE;
    members [2].advanced_keywords_present := FALSE;
*IF NOT $true(osv$unix)
    members [2].kinds := $clt$type_kinds [clc$real_type];
*ELSE
    members [2].kinds := $clt$type_kinds_v2 [clc$real_type];
*IFEND
    members [2].kind := clc$real_type;
*IF NOT $true(osv$unix)
    #UNCHECKED_CONVERSION (clv$negative_infinity^,
          members [2].min_real_value.long_real);
    #UNCHECKED_CONVERSION (clv$positive_infinity^,
          members [2].max_real_value.long_real);
*ELSE
    members [2].min_real_value.long_real := clv$negative_infinity^;
    members [2].max_real_value.long_real := clv$positive_infinity^;
*IFEND

    original_work_area := work_area;
    clp$internal_evaluate_expr (parse, ^type_description, work_area,
          ignore_result_type_description, result, status);
    work_area := original_work_area;

    IF status.normal AND (result^.kind = clc$unspecified) THEN
      osp$set_status_abnormal ('CL', cle$unspecified_value_for_req,
            'clp$evaluate_expression', status);
    IFEND;

  PROCEND clp$evaluate_numeric_expression;

*copyc clc$max_integer
*copyc clc$min_integer
*copyc cle$ecc_parsing
*copyc clt$data_value
*copyc clt$parse_state
*copyc clt$work_area
*copyc ost$status
?? POP ??
*copyc clp$internal_evaluate_expr
*copyc clv$negative_infinity
*copyc clv$positive_infinity
*copyc osp$set_status_abnormal
*DECK DECK=CLP$EVALUATE_NUMERIC_LITERAL EXPAND=FALSE

  PROCEDURE [XREF] clp$evaluate_numeric_literal
    (    sign: -1 .. 1;
         default_radix: 2 .. 16;
     VAR parse {input, output} : clt$parse_state;
     VAR literal: clt$number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$number
*copyc clt$parse_state
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EVALUATE_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] clp$evaluate_parameters
    (    parameter_list: clt$parameter_list;
         parameter_description_table: ^clt$parameter_description_table;
         check_parameters_procedure: clt$check_parameters_procedure;
         parameter_value_table: ^clt$parameter_value_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$check_parameters_procedure
*copyc clt$parameter_description_table
*copyc clt$parameter_list
*copyc clt$parameter_value_table
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EVALUATE_READ_DATA_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$evaluate_read_data_value
    (    name: clt$variable_name;
         return_value_qualifiers: boolean;
         return_type_description: boolean;
         internal_value: ^clt$internal_data_value;
     VAR parse {input, output} : clt$parse_state;
     VAR value {input, output} : ^clt$data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value_qualifiers: ^clt$value_qualifiers;
     VAR type_description {input, output} : ^clt$type_description;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$internal_data_value
*copyc clt$parse_state
*copyc clt$type_description
*copyc clt$value_qualifiers
*copyc clt$variable_name
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EVALUATE_REAL_EXPRESSION EXPAND=FALSE

{ Clp$evaluate_real_expression is intended to be an INLINE procedure but
{ cannot be at present because of a CYBIL problem.

  PROCEDURE clp$evaluate_real_expression
    (    min_real_result: longreal;
         max_real_result: longreal;
     VAR work_area {input} : ^clt$work_area;
     VAR parse {input, output} : clt$parse_state;
     VAR result: clt$real;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_result_type_description: ^clt$type_description,
      original_work_area: ^clt$work_area,
      type_description: clt$type_description,
      value: ^clt$data_value;


    type_description.specification := NIL;
    type_description.name := NIL;
    type_description.derived_from_value_kind_spec := FALSE;
    type_description.advanced_keywords_present := FALSE;
    type_description.kinds := $clt$type_kinds [clc$real_type];
    type_description.kind := clc$real_type;
    #UNCHECKED_CONVERSION (min_real_result,
          type_description.min_real_value.long_real);
    #UNCHECKED_CONVERSION (max_real_result,
          type_description.max_real_value.long_real);

    original_work_area := work_area;
    clp$internal_evaluate_expr (parse, ^type_description, work_area,
          ignore_result_type_description, value, status);
    work_area := original_work_area;

    IF status.normal THEN
      IF value^.kind = clc$unspecified THEN
        osp$set_status_abnormal ('CL', cle$unspecified_value_for_req,
              'clp$evaluate_expression', status);
      ELSE
        result := value^.real_value;
      IFEND;
    IFEND;

  PROCEND clp$evaluate_real_expression;

*copyc cle$ecc_parsing
*copyc clt$parse_state
*copyc clt$real
*copyc clt$work_area
*copyc ost$status
?? POP ??
*copyc clp$internal_evaluate_expr
*copyc osp$set_status_abnormal
*DECK DECK=CLP$EVALUATE_STATUS_EXPRESSION EXPAND=FALSE

  PROCEDURE [INLINE] clp$evaluate_status_expression
    (VAR work_area {input} : ^clt$work_area;
     VAR parse {input, output} : clt$parse_state;
     VAR result: ost$status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_result_type_description: ^clt$type_description,
      original_work_area: ^clt$work_area,
      type_description: clt$type_description,
      value: ^clt$data_value;


    type_description.specification := NIL;
    type_description.name := NIL;
    type_description.derived_from_value_kind_spec := FALSE;
    type_description.advanced_keywords_present := FALSE;
*IF NOT $true(osv$unix)
    type_description.kinds := $clt$type_kinds [clc$status_type];
*ELSE
    type_description.kinds := $clt$type_kinds_v2 [clc$status_type];
*IFEND
    type_description.kind := clc$status_type;

    original_work_area := work_area;
    clp$internal_evaluate_expr (parse, ^type_description, work_area,
          ignore_result_type_description, value, status);
    work_area := original_work_area;

    IF status.normal THEN
      IF value^.kind = clc$unspecified THEN
        osp$set_status_abnormal ('CL', cle$unspecified_value_for_req,
              'clp$evaluate_expression', status);
      ELSE
        result := value^.status_value^;
      IFEND;
    IFEND;

  PROCEND clp$evaluate_status_expression;

*copyc cle$ecc_parsing
*copyc clt$parse_state
*copyc clt$work_area
*copyc ost$status
?? POP ??
*copyc clp$internal_evaluate_expr
*copyc osp$set_status_abnormal
*DECK DECK=CLP$EVALUATE_SUB_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] clp$evaluate_sub_parameters
    (    parameter_list_text: clt$parameter_list_text;
         parameter_description_table: ^clt$parameter_description_table;
     VAR work_area {input, output} : ^clt$work_area;
         parameter_value_table: ^clt$parameter_value_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_description_table
*copyc clt$parameter_list_text
*copyc clt$parameter_value_table
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EVALUATE_TOKEN EXPAND=FALSE

  PROCEDURE [XREF] clp$evaluate_token
    (    text: clt$string_value;
         evaluation_options: clt$token_evaluation_options;
     VAR index {input, output} : clt$string_index;
     VAR spaces_preceded_token: boolean;
     VAR token: clt$lexical_token;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc clt$lexical_token
*copyc clt$string_index
*copyc clt$string_value
*copyc clt$token_evaluation_options
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EVALUATE_TYPE_CONFORMANCE EXPAND=FALSE

  PROCEDURE [XREF] clp$evaluate_type_conformance
    (    candidate_type_description: ^clt$type_description;
         base_type_description: ^clt$type_description;
         minimum_type_conformance: clt$type_conformance;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$type_conformance
*copyc clt$type_description
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EVALUATE_UNQUAL_UNION_EXPR EXPAND=FALSE

  PROCEDURE [INLINE] clp$evaluate_unqual_union_expr
    (VAR work_area {input} : ^clt$work_area;
     VAR parse {input, output} : clt$parse_state;
     VAR result_type_description: ^clt$type_description;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      type_description: clt$type_description,
      union_info: clt$union_type_information;


    status.normal := TRUE;
    result := NIL;

    type_description.specification := NIL;
    type_description.name := NIL;
    type_description.derived_from_value_kind_spec := FALSE;
    type_description.advanced_keywords_present := FALSE;
*IF NOT $true(osv$unix)
    type_description.kinds := -$clt$type_kinds [];
*ELSE
    type_description.kinds := -$clt$type_kinds_v2 [];
*IFEND
    type_description.kind := clc$union_type;
    type_description.member_descriptions := NIL;
    type_description.union_information := ^union_info;

    union_info.only_standard_types_in_union := TRUE;
    union_info.min_integer_value := clc$min_integer;
    union_info.max_integer_value := clc$max_integer;
    union_info.default_radix := 10;
*IF NOT $true(osv$unix)
    #UNCHECKED_CONVERSION (clv$negative_infinity^,
          union_info.min_real_value.long_real);
    #UNCHECKED_CONVERSION (clv$positive_infinity^,
          union_info.max_real_value.long_real);
*ELSE
    union_info.min_real_value.long_real := clv$negative_infinity^;
    union_info.max_real_value.long_real := clv$positive_infinity^;
*IFEND

    clp$internal_evaluate_expr (parse, ^type_description, work_area,
          result_type_description, result, status);

    IF status.normal AND (result^.kind = clc$unspecified) THEN
      osp$set_status_abnormal ('CL', cle$unspecified_value_for_req,
            'clp$evaluate_expression', status);
    IFEND;

  PROCEND clp$evaluate_unqual_union_expr;

*copyc cle$ecc_parsing
*copyc clt$data_value
*copyc clt$parse_state
*copyc clt$type_description
*copyc clt$work_area
*copyc ost$status
?? POP ??
*copyc clp$internal_evaluate_expr
*copyc clv$negative_infinity
*copyc clv$positive_infinity
*copyc osp$set_status_abnormal
*DECK DECK=CLP$EVALUATE_UNSIGNED_DECIMAL EXPAND=FALSE

  PROCEDURE [INLINE] clp$evaluate_unsigned_decimal
    (    text: string ( * );
     VAR number: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    CONST
      max_positive_integer = '9223372036854775807',
      max_positive_integer_digits = 19;

    VAR
      digit: 0 .. 9,
      i: integer,
      non_zero_digit_found: boolean,
      number_of_digits: integer;


    status.normal := TRUE;
    number := 0;

    #SCAN (clv$non_zero_digit, text, i, non_zero_digit_found);
    IF NOT non_zero_digit_found THEN
      RETURN;
    IFEND;

    number_of_digits := STRLENGTH (text) - i + 1;
    IF (number_of_digits > max_positive_integer_digits) OR
          ((number_of_digits = max_positive_integer_digits) AND
          (text (i, number_of_digits) > max_positive_integer)) THEN
      osp$set_status_abnormal ('CL', cle$integer_literal_too_large, text,
            status);
      RETURN;
    IFEND;

    FOR i := i TO STRLENGTH (text) DO
      CASE text (i) OF
      = '0' .. '9' =
        digit := $INTEGER (text (i)) - $INTEGER ('0');
      ELSE
        osp$set_status_abnormal ('CL', cle$improper_integer, text, status);
        RETURN;
      CASEND;
      number := (number * 10) + digit;
    FOREND;

  PROCEND clp$evaluate_unsigned_decimal;

*copyc cle$ecc_lexical
*copyc ost$status
?? POP ??
*copyc clv$non_zero_digit
*copyc osp$set_status_abnormal
*DECK DECK=CLP$EVALUATE_VALUE_CONFORMANCE EXPAND=FALSE

  PROCEDURE [XREF] clp$evaluate_value_conformance
    (    value: ^clt$data_value;
         type_description: ^clt$type_description;
         minimum_type_conformance: clt$type_conformance;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$type_conformance
*copyc clt$type_description
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EVALUATE_VALUE_QUALIFIERS EXPAND=FALSE

  PROCEDURE [XREF] clp$evaluate_value_qualifiers
    (    name: clt$variable_name;
         return_value_qualifiers: boolean;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value {input, output} : ^clt$data_value;
     VAR type_specification {input, output} : ^clt$type_specification;
     VAR value_qualifiers: ^clt$value_qualifiers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$parse_state
*copyc clt$type_specification
*copyc clt$value_qualifiers
*copyc clt$variable_name
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EVALUATE_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] clp$evaluate_variable
    (    name: clt$variable_name;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value;
     VAR type_specification: ^clt$type_specification;
     VAR type_description: ^clt$type_description;
     VAR found: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$parse_state
*copyc clt$type_description
*copyc clt$type_specification
*copyc clt$variable_name
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EXECUTE_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] clp$execute_command
    (    command: clt$command_line;
         command_file: fst$file_reference;
         enable_echoing: boolean;
         task_name: clt$task_name_reference;
     VAR task_id: pmt$task_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_command_processing
*copyc clt$command_line
*copyc clt$task_name_reference
*copyc fst$file_reference
*copyc ost$status
*copyc pmt$task_id
?? POP ??
*DECK DECK=CLP$EXECUTE_JOB_EPILOG EXPAND=FALSE
  PROCEDURE [XREF] clp$execute_job_epilog;
*DECK DECK=CLP$EXECUTE_NAMED_TASK EXPAND=FALSE

  PROCEDURE [XREF] clp$execute_named_task
    (    task_name: ost$name;
         target_ring: ost$valid_ring;
         program_description: pmt$program_description;
         parameters: pmt$program_parameters;
         command_file: amt$local_file_name;
     VAR task_id: pmt$task_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
*copyc pmt$program_description
*copyc pmt$program_parameters
*copyc pmt$task_id
?? POP ??
*DECK DECK=CLP$EXECUTION_FAULT_HANDLER_EST EXPAND=FALSE

  FUNCTION [XREF, UNSAFE] clp$execution_fault_handler_est: boolean;

*DECK DECK=CLP$EXIT_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$exit_block
    (    target_block_offset: ost$segment_offset;
         exit_status: ^ost$status;
         function_result: ^clt$internal_data_value;
         terminating_utility: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$internal_data_value
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EXPRESSION_SCANNER EXPAND=FALSE

  PROCEDURE [XREF] clp$expression_scanner ALIAS 'clpexps'
    (    value_kind_specifier: clt$value_kind_specifier;
     VAR parse {input, output} : clt$parse_state;
     VAR value: clt$value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc clt$parse_state
*copyc clt$value_kind_specifier
*copyc ost$status
?? POP ??
*DECK DECK=CLP$EXTRACT_MESSAGE_MODULE EXPAND=FALSE

  PROCEDURE [XREF] clp$extract_message_module
    (    file_id: amt$file_identifier;
         module_name: pmt$program_name;
         message_module: ^ost$message_template_module;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$message_template_module
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=CLP$EXTRACT_MSG_MODULE_CONTENTS EXPAND=FALSE

  PROCEDURE [INLINE] clp$extract_msg_module_contents
    (    message_module: ^ost$message_template_module;
     VAR header: ^ost$mtm_header;
     VAR codes: ^ost$mtm_condition_codes;
     VAR names: ^ost$mtm_condition_names);

?? PUSH (LISTEXT := ON) ??

    VAR
      msg_module: ^ost$message_template_module;

    msg_module := message_module;
    RESET msg_module;

  /validate/
    BEGIN
      NEXT header IN msg_module;
      IF (header = NIL) OR (header^.number_of_codes < 0) OR
            (header^.number_of_codes > (osc$max_status_condition_code + 1)) OR
            (header^.number_of_names < 0) OR (header^.number_of_names >
            (osc$max_status_condition_code + 1)) THEN
        EXIT /validate/;
      IFEND;
      IF header^.number_of_codes > 0 THEN
        NEXT codes: [0 .. header^.number_of_codes - 1] IN msg_module;
        IF codes = NIL THEN
          EXIT /validate/;
        IFEND;
      ELSE
        codes := NIL;
      IFEND;
      NEXT names: [0 .. header^.number_of_names - 1] IN msg_module;
      IF names = NIL THEN
        EXIT /validate/;
      IFEND;
      RETURN;
    END /validate/;
    header := NIL;

  PROCEND clp$extract_msg_module_contents;

*copyc ost$message_template_module
?? POP ??
*DECK DECK=CLP$EXTRACT_SCL_PROCEDURE EXPAND=FALSE

  PROCEDURE [XREF] clp$extract_scl_procedure
    (    file_id: amt$file_identifier;
         scl_procedure: ^clt$scl_procedure;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc clt$scl_procedure
*copyc ost$status
?? POP ??
*DECK DECK=CLP$FETCH_DISPLAY_LOG_INDICES EXPAND=FALSE

  PROCEDURE [XREF] clp$fetch_display_log_indices
    (VAR indices: clt$display_log_indices);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_log_indices
?? POP ??
*DECK DECK=CLP$FETCH_NAMED_TASK_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] clp$fetch_named_task_entry
    (    task_name: ost$name;
     VAR named_task: clt$named_task);

?? PUSH (LISTEXT := ON) ??
*copyc clt$named_task
*copyc ost$name
?? POP ??
*DECK DECK=CLP$FETCH_SYSTEM_FILE_ID EXPAND=FALSE

  PROCEDURE [XREF] clp$fetch_system_file_id
    (    file_name: amt$local_file_name;
     VAR file_id: amt$file_identifier;
     VAR file_id_defined: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc clc$standard_file_names
?? POP ??
*DECK DECK=CLP$FETCH_UTILITY_DIALOG_INFO EXPAND=FALSE

  PROCEDURE [XREF] clp$fetch_utility_dialog_info
    (    utility: clt$utility_name;
     VAR dialog_info: ^clt$utility_dialog_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$utility_dialog_info
*copyc clt$utility_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$FILE_REF_IS_PRE_EVALUATED EXPAND=FALSE

  FUNCTION [INLINE] clp$file_ref_is_pre_evaluated
    (    file_reference_parsing_options: clt$file_ref_parsing_options;
         parse: clt$parse_state): boolean;

?? PUSH (LISTEXT := ON) ??

    clp$file_ref_is_pre_evaluated := ($clt$file_ref_parsing_options
          [clc$evaluating_command_ref, clc$evaluating_entry_point_ref,
          clc$multiple_reference_allowed] * file_reference_parsing_options =
          $clt$file_ref_parsing_options []) AND
          (parse.units_array^ [parse.units_array_index + 1].kind =
          clc$lex_name) AND (parse.text^ (parse.index) <> '$');

  FUNCEND clp$file_ref_is_pre_evaluated;

*copyc clt$file_ref_parsing_options
*copyc clt$parse_state
?? POP ??
*DECK DECK=CLP$FIND_BLOCK_VIA_HANDLE EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_block_via_handle
    (    handle: clt$block_handle;
     VAR block: ^clt$block;
     VAR block_in_current_task: boolean;
     VAR block_is_synchronous: boolean);

?? PUSH (LISTEXT := ON) ??

    block_is_synchronous := TRUE;
    block_in_current_task := TRUE;
    clp$find_current_block (block);
    WHILE (block <> NIL) AND (#OFFSET (block) <> handle.segment_offset) DO
      IF block^.kind = clc$task_block THEN
        block_in_current_task := FALSE;
        IF NOT block^.synchronous_with_parent THEN
          block_is_synchronous := FALSE;
        IFEND;
      IFEND;
      block := block^.previous_block;
    WHILEND;
    IF (block <> NIL) AND (block^.assignment_counter <>
          handle.assignment_counter) THEN
      block := NIL;
    IFEND;

  PROCEND clp$find_block_via_handle;

*copyc clt$block_handle
?? POP ??
*copyc clp$find_current_block

*DECK DECK=CLP$FIND_CALLER_INPUT_BLOCK EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_caller_input_block
    (    file_name: amt$local_file_name;
     VAR block: ^clt$block;
     VAR block_in_current_task: boolean);

?? PUSH (LISTEXT := ON) ??

    block_in_current_task := TRUE;
    clp$find_current_block (block);

    IF file_name = clc$proc_caller_command_input THEN
*IF NOT $true(osv$unix)
      WHILE (block <> NIL) AND (block^.kind <> clc$command_proc_block) DO
*ELSE
      WHILE (block <> NIL) DO
*IFEND
        IF block^.kind = clc$task_block THEN
          IF NOT block^.synchronous_with_parent THEN
            IF block^.command_file = osc$null_name THEN
              block := NIL;
            IFEND;
            RETURN;
          IFEND;
          block_in_current_task := FALSE;
        IFEND;
        block := block^.previous_block;
      WHILEND;
      IF block <> NIL THEN
        block := block^.previous_block;
      IFEND;
    IFEND;

    WHILE block <> NIL DO
      CASE block^.kind OF
*IF NOT $true(osv$unix)
      = clc$command_proc_block, clc$function_proc_block =
        IF block^.parameters.evaluated THEN
          RETURN;
        IFEND;
*IFEND
      = clc$input_block =
        IF NOT block^.input.prompting_input THEN
          RETURN;
        IFEND;
      = clc$task_block =
        IF NOT block^.synchronous_with_parent THEN
          IF block^.command_file = osc$null_name THEN
            block := NIL;
          IFEND;
          RETURN;
        IFEND;
        block_in_current_task := FALSE;
*IF NOT $true(osv$unix)
      = clc$when_block =
        RETURN;
*IFEND
      ELSE
        ;
      CASEND;
      block := block^.previous_block;
    WHILEND;

  PROCEND clp$find_caller_input_block;

*copyc amt$local_file_name
*copyc clc$standard_file_names
?? POP ??
*copyc clp$find_current_block

*DECK DECK=CLP$FIND_CMND_LIST_FIRST_TIME EXPAND=FALSE
*DECK DECK=CLP$FIND_CMND_OR_FUNC_IN_PROG EXPAND=FALSE

  PROCEDURE [XREF] clp$find_cmnd_or_func_in_prog
    (    command_or_function_name: ost$name;
         command_or_function: clt$command_or_function;
     VAR work_area {input, output} : ^clt$work_area;
     VAR local_file_name: amt$local_file_name;
     VAR ring_attributes: amt$ring_attributes;
     VAR search_info: clt$command_library_search_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc amt$ring_attributes
*copyc clt$command_or_function
*copyc clt$command_library_search_info
*copyc clt$work_area
*copyc ost$name
*copyc ost$status
?? POP ??

*DECK DECK=CLP$FIND_COMMAND_ENTRIES EXPAND=FALSE

  PROCEDURE [XREF] clp$find_command_entries
    (    local_file_name: amt$local_file_name;
     VAR work_area {input, output} : ^clt$work_area;
     VAR ring_attributes: amt$ring_attributes;
     VAR command_dictionary: ^llt$command_dictionary;
     VAR function_entries: ^llt$function_dictionary;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc amt$ring_attributes
*copyc clt$work_area
*copyc llt$command_dictionary
*copyc llt$function_dictionary
*copyc ost$status
?? POP ??
*DECK DECK=CLP$FIND_COMMAND_INPUT_BLOCK EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_command_input_block
    (    handle: clt$block_handle;
     VAR block: ^clt$block;
     VAR block_in_current_task: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      block_is_synchronous: boolean,
      local_block: ^clt$block;


    clp$find_block_via_handle (handle, block, block_in_current_task,
          block_is_synchronous);
    IF block = NIL THEN
      RETURN;
    ELSEIF NOT (block_is_synchronous AND (block^.kind IN
*IF NOT $true(osv$unix)
          $clt$block_kinds [clc$command_proc_block, clc$function_proc_block,
          clc$input_block, clc$when_block, clc$task_block])) THEN
*ELSE
          $clt$block_kinds [clc$input_block, clc$task_block])) THEN
*IFEND
      block := NIL;
      RETURN;
    IFEND;

    WHILE block^.inheriting_block <> NIL DO
      block := block^.inheriting_block;
    WHILEND;

    block_in_current_task := TRUE;
    clp$find_current_block (local_block);
    WHILE (local_block <> NIL) AND (local_block <> block) DO
      IF local_block^.kind = clc$task_block THEN
        block_in_current_task := FALSE;
      IFEND;
      local_block := local_block^.previous_block;
    WHILEND;

  PROCEND clp$find_command_input_block;

?? POP ??
*copyc clp$find_block_via_handle
*copyc clp$find_current_block
*DECK DECK=CLP$FIND_COMMAND_LIST EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_command_list
    (VAR command_list: ^clt$command_list;
     VAR cmnd_list_found_in_current_task: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      object: ^clt$environment_object_contents;


    clp$find_environment_object (clc$eo_command_list, object,
          cmnd_list_found_in_current_task);

    command_list := object;

  PROCEND clp$find_command_list;

*copyc clt$command_list
?? POP ??
*copyc clp$find_environment_object
*DECK DECK=CLP$FIND_COMMAND_SOURCE EXPAND=FALSE

  PROCEDURE [XREF] clp$find_command_source
    (    file_name: amt$local_file_name;
     VAR block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc clt$block
?? POP ??
*DECK DECK=CLP$FIND_CONNECTED_FILE EXPAND=FALSE

  PROCEDURE [XREF] clp$find_connected_file
    (    local_file_name: amt$local_file_name;
     VAR connected_file: ^clt$connected_file_subject);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc clt$connected_file
?? POP ??
*DECK DECK=CLP$FIND_CONNECTED_FILES EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_connected_files
    (VAR connected_files: ^clt$connected_files);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_object_in_current_task: boolean,
      object: ^clt$environment_object_contents;


    clp$find_environment_object (clc$eo_file_connections, object,
          ignore_object_in_current_task);

    connected_files := object;

  PROCEND clp$find_connected_files;

*copyc clt$connected_file
?? POP ??
*copyc clp$find_environment_object
*DECK DECK=CLP$FIND_CON_FILES_FIRST_TIME EXPAND=FALSE
*DECK DECK=CLP$FIND_CURRENT_BLOCK EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_current_block
    (VAR current_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??

    VAR
      status: ^ost$status;


    IF clv$current_task_block <> NIL THEN
      current_block := clv$current_task_block^.current_block;
    ELSE
      PUSH status;
      clp$find_task_block_first_time (current_block, status^);
      IF NOT status^.normal THEN
*IF NOT $true(osv$unix)
        osp$system_error ('Unable to get pointer to SCL Task Block', status);
*ELSE
        RETURN;
*IFEND
      IFEND;
      current_block := current_block^.current_block;
    IFEND;

  PROCEND clp$find_current_block;

*copyc clt$block
*copyc ost$status
?? POP ??
*copyc clp$find_task_block_first_time
*copyc clv$current_task_block
*IF NOT $true(osv$unix)
*copyc osp$system_error
*IFEND
*DECK DECK=CLP$FIND_CURRENT_JOB_SYNCH_TASK EXPAND=FALSE

  PROCEDURE [XREF] clp$find_current_job_synch_task
    (VAR task_id: pmt$task_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$task_id
?? POP ??
*DECK DECK=CLP$FIND_CYCLE_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$find_cycle_block
    (    target_label: ost$name;
     VAR current_block: ^clt$block;
     VAR target_block: ^clt$block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$FIND_DAY_AND_MONTH_NAMES EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_day_and_month_names
    (    language: ost$natural_language;
     VAR day_and_month_names_entry: ^clt$day_and_month_names);

    VAR
      search_language: ost$natural_language;


    IF language = 'ENGLISH' THEN
      search_language := 'US_ENGLISH';
    ELSE
      search_language := language;
    IFEND;

    day_and_month_names_entry := clv$day_and_month_names_list;
    WHILE day_and_month_names_entry <> NIL DO
      IF day_and_month_names_entry^.language = search_language THEN
{Language is already in list of known languages.}
        RETURN;
      IFEND;
      day_and_month_names_entry := day_and_month_names_entry^.next_entry;
    WHILEND;

  PROCEND clp$find_day_and_month_names;

?? PUSH (LISTEXT := ON) ??
*copyc ost$natural_language
*copyc clt$day_and_month_names
*copyc clv$day_and_month_names_list
?? POP ??
*DECK DECK=CLP$FIND_DEFAULT_SESSION_FILE EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_default_session_file
    (VAR default_session_file: ^fst$file_reference);

?? PUSH (LISTEXT := ON) ??

    IF clv$find_default_session_file = NIL THEN
      clp$find_def_ses_file_1st_time (default_session_file);
    ELSE
      default_session_file := clv$find_default_session_file;
    IFEND;

  PROCEND clp$find_default_session_file;

*copyc fst$file_reference
?? POP ??
*copyc clp$find_def_ses_file_1st_time
*copyc clv$find_default_session_file
*DECK DECK=CLP$FIND_DEF_SES_FILE_1ST_TIME EXPAND=FALSE

  PROCEDURE [XREF] clp$find_def_ses_file_1st_time
    (VAR default_session_file: ^fst$file_reference);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
?? POP ??
*DECK DECK=CLP$FIND_ENVIRONMENT_OBJECT EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_environment_object
    (    object_ordinal: clt$environment_object_ordinal;
     VAR object: ^clt$environment_object_contents;
     VAR object_in_current_task: boolean);

?? PUSH (LISTEXT := ON) ??

    IF clv$environment_object_location [object_ordinal].object = NIL THEN
      clp$find_env_object_first_time (object_ordinal, object_in_current_task,
            object);
    ELSE
      object_in_current_task := clv$environment_object_location
            [object_ordinal].object_in_current_task;
      object := clv$environment_object_location [object_ordinal].object;
    IFEND;

  PROCEND clp$find_environment_object;

*copyc clt$environment_object_contents
*copyc clt$environment_object_ordinal
?? POP ??
*copyc clp$find_env_object_first_time
*copyc clv$environment_object_location
*DECK DECK=CLP$FIND_ENV_OBJECT_FIRST_TIME EXPAND=FALSE

  PROCEDURE [XREF] clp$find_env_object_first_time
    (    object_ordinal: clt$environment_object_ordinal;
     VAR object_in_current_task: boolean;
     VAR object: ^clt$environment_object_contents);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc clt$environment_object_ordinal
?? POP ??
*DECK DECK=CLP$FIND_ESTABLISHING_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$find_establishing_block
    (    condition: clt$when_condition;
     VAR {input, output} when_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$when_conditions
?? POP ??
*DECK DECK=CLP$FIND_EXIT_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$find_exit_block
    (    target_label: ost$name;
     VAR target_block: ^clt$block;
     VAR terminating_utility: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$FIND_EXTERNAL_INPUT_BLOCK EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_external_input_block
    (VAR block: ^clt$block);

?? PUSH (LISTEXT := ON) ??

    clp$find_input_block (FALSE, block);
    WHILE block <> NIL DO
      CASE block^.kind OF
*IF NOT $true(osv$unix)
      = clc$command_proc_block, clc$function_proc_block, clc$input_block,
            clc$when_block =
*ELSE
      = clc$input_block =
*IFEND
        IF NOT block^.input.internal THEN
          RETURN;
        IFEND;
        IF block^.inherited_input.found THEN
          block := block^.inherited_input.block;
        ELSE
          block := block^.previous_block;
        IFEND;
      = clc$task_block =
        IF NOT block^.synchronous_with_parent THEN
          block := NIL;
          RETURN;
        IFEND;
        block := block^.previous_block;
      ELSE
        block := block^.previous_block;
      CASEND;
    WHILEND;

  PROCEND clp$find_external_input_block;

*copyc clt$block
?? POP ??
*copyc clp$find_input_block
*DECK DECK=CLP$FIND_FIRST_VAR_BLOCK EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_first_var_block
    (VAR allowed_classes {input, output} : clt$internal_variable_classes;
     VAR inherited_input_allowed_classes: clt$internal_variable_classes;
     VAR inherited_input_block: ^clt$block;
     VAR current_block: ^clt$block;
     VAR associated_utility: boolean);

?? PUSH (LISTEXT := ON) ??

    inherited_input_allowed_classes := allowed_classes;
    inherited_input_block := NIL;
    associated_utility := FALSE;
    clp$find_current_block (current_block);

*copy cli$find_var_block

  PROCEND clp$find_first_var_block;

*copyc clt$block
*copyc clt$internal_variable_classes
?? POP ??
*copyc clp$find_current_block
*DECK DECK=CLP$FIND_FORM EXPAND=FALSE

  PROCEDURE [XREF] clp$find_form
    (    form_name: ost$name;
     VAR p_form_module: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$FIND_HELP_MODULE EXPAND=TRUE
  PROCEDURE [XREF] clp$find_help_module (seed_name: pmt$program_name;
        natural_language: ost$natural_language;
    VAR help_module: ^ost$help_module;
    VAR online_manual_name: ost$online_manual_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$program_name
*copyc ost$natural_language
*copyc ost$help_module
*copyc ost$online_manual_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$FIND_INPUT_BLOCK EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_input_block
    (    search_only_current_task: boolean;
     VAR block: ^clt$block);

?? PUSH (LISTEXT := ON) ??

    clp$find_current_block (block);
    WHILE block <> NIL DO
      CASE block^.kind OF
*IF NOT $true(osv$unix)
      = clc$command_proc_block, clc$function_proc_block, clc$input_block,
            clc$when_block =
*ELSE
      = clc$input_block =
*IFEND
        RETURN;
      = clc$task_block =
        IF search_only_current_task OR (NOT block^.synchronous_with_parent)
              THEN
          block := NIL;
          RETURN;
        IFEND;
      ELSE
        ;
      CASEND;
      block := block^.previous_block;
    WHILEND;

  PROCEND clp$find_input_block;

*copyc clt$block
?? POP ??
*copyc clp$find_current_block
*DECK DECK=CLP$FIND_MAIL_ACTION_FIRST_TIME EXPAND=FALSE
*DECK DECK=CLP$FIND_NAMED_TASK_GROUP_LIST EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_named_task_group_list
    (VAR named_task_list: ^^clt$named_task);

?? PUSH (LISTEXT := ON) ??

    IF clv$named_task_group_list = NIL THEN
      clp$find_nt_group_list_first (named_task_list);
    ELSE
      named_task_list := clv$named_task_group_list;
    IFEND;

  PROCEND clp$find_named_task_group_list;

*copyc clt$named_task
?? POP ??
*copyc clp$find_nt_group_list_first
*copyc clv$named_task_group_list
*DECK DECK=CLP$FIND_NEXT_VAR_BLOCK EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_next_var_block
    (VAR allowed_classes {input, output} : clt$internal_variable_classes;
     VAR inherited_input_allowed_classes {input, output} :
               clt$internal_variable_classes;
     VAR inherited_input_block {input, output} : ^clt$block;
     VAR current_block {input, output} : ^clt$block;
     VAR associated_utility {output} : boolean);

?? PUSH (LISTEXT := ON) ??

    IF current_block^.static_link <> NIL THEN
      current_block := current_block^.static_link;
    ELSE
      current_block := current_block^.previous_block;
    IFEND;
    associated_utility := FALSE;

*copy cli$find_var_block

  PROCEND clp$find_next_var_block;

*copyc clt$block
*copyc clt$internal_variable_classes
?? POP ??
*DECK DECK=CLP$FIND_NT_GROUP_LIST_FIRST EXPAND=FALSE

  PROCEDURE [XREF] clp$find_nt_group_list_first
    (VAR named_task_list: ^^clt$named_task);

?? PUSH (LISTEXT := ON) ??
*copyc clt$named_task
?? POP ??
*DECK DECK=CLP$FIND_SCL_OPTIONS EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_scl_options
    (VAR scl_options: ^clt$scl_options);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_object_in_current_task: boolean,
      object: ^clt$environment_object_contents;


    clp$find_environment_object (clc$eo_scl_options, object,
          ignore_object_in_current_task);

    scl_options := object;

  PROCEND clp$find_scl_options;

*copyc clt$scl_options
?? POP ??
*copyc clp$find_environment_object
*DECK DECK=CLP$FIND_SCL_PROC_IN_LIBRARY EXPAND=FALSE

  PROCEDURE [XREF] clp$find_scl_proc_in_library
    (    object_library: ^SEQ ( * );
         object_library_name: amt$local_file_name;
         procedure_name: ost$name;
     VAR scl_procedure: ^clt$scl_procedure;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc clt$scl_procedure
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$FIND_TASK_BLOCK EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_task_block
    (VAR task_block: ^clt$block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    IF clv$current_task_block = NIL THEN
      clp$find_task_block_first_time (task_block, status);
    ELSE
      status.normal := TRUE;
      task_block := clv$current_task_block;
    IFEND;

  PROCEND clp$find_task_block;

*copyc clt$block
*copyc ost$status
?? POP ??
*copyc clp$find_task_block_first_time
*copyc clv$current_task_block
*DECK DECK=CLP$FIND_TASK_BLOCK_FIRST_TIME EXPAND=FALSE

  PROCEDURE [XREF] clp$find_task_block_first_time
    (VAR task_block: ^clt$block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc ost$status
?? POP ??
*DECK DECK=CLP$FIND_UNSEEN_MAIL_ACTION EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_unseen_mail_action
    (VAR unseen_mail_action: ^clt$unseen_mail_action);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_object_in_current_task: boolean,
      object: ^clt$environment_object_contents;


    clp$find_environment_object (clc$eo_unseen_mail_action, object,
          ignore_object_in_current_task);

    unseen_mail_action := object;

  PROCEND clp$find_unseen_mail_action;

*copyc clt$unseen_mail_action
?? POP ??
*copyc clp$find_environment_object
*DECK DECK=CLP$FIND_UTILITY_BLOCK EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_utility_block
    (    utility_name: clt$utility_name;
     VAR block: ^clt$block;
     VAR block_in_current_task: boolean);

?? PUSH (LISTEXT := ON) ??

    block_in_current_task := TRUE;
    clp$find_current_block (block);
    WHILE block <> NIL DO
      CASE block^.kind OF
      = clc$utility_block =
        IF (utility_name = osc$null_name) OR (utility_name = block^.label) THEN
          RETURN;
        IFEND;
      = clc$task_block =
        block_in_current_task := FALSE;
        IF NOT block^.synchronous_with_parent THEN
          block := NIL;
          RETURN;
        IFEND;
      ELSE
        ;
      CASEND;
      block := block^.previous_block;
    WHILEND;

  PROCEND clp$find_utility_block;

*copyc clt$block
*copyc clt$utility_name
*copyc ost$status
?? POP ??
*copyc clp$find_current_block
*copyc osv$lower_to_upper
*DECK DECK=CLP$FIND_VARIABLE_ACCESS EXPAND=FALSE

  PROCEDURE [INLINE] clp$find_variable_access
    (    name: clt$variable_name;
         hashed_name: clt$variable_name;
         hash: clt$variable_name_hash;
         allowed_data_classes: clt$internal_variable_classes;
         block: ^clt$block;
     VAR variable_access_info: ^clt$variable_access_info);

?? PUSH (LISTEXT := ON) ??

    VAR
      current_access: ^clt$variable_access,
      environment_variable_set: clt$internal_variable_classes,
      index: clt$parameter_name_index,
      found: boolean;


    variable_access_info := NIL;
    environment_variable_set := $clt$internal_variable_classes [clc$env_variable, clc$lib_variable,
          clc$pushed_variable];

    current_access := block^.variables.hash_groups [hash].root;
    IF ((allowed_data_classes * (-$clt$internal_variable_classes [clc$param_variable]))
          <> $clt$internal_variable_classes []) AND
          ((block^.variables.hash_groups [hash].procedure_variables_in_group > 0) OR
          (block^.variables.hash_groups [hash].environment_variables_in_group > 0)) THEN
      IF (block^.variables.hash_groups [hash].environment_variables_in_group = 0) AND
            (allowed_data_classes <= environment_variable_set) THEN
        RETURN;
      IFEND;

    /search_variables/
      WHILE current_access <> NIL DO
        IF hashed_name < current_access^.hashed_name THEN
          current_access := current_access^.left_search_tree;
        ELSEIF hashed_name > current_access^.hashed_name THEN
          current_access := current_access^.right_search_tree;
        ELSE
          IF current_access^.info.class IN allowed_data_classes THEN
            variable_access_info := ^current_access^.info;
            RETURN;
          ELSE
            EXIT /search_variables/;
          IFEND;
        IFEND;
      WHILEND /search_variables/;

    IFEND;

    IF (clc$param_variable IN allowed_data_classes) AND block^.parameters.evaluated AND
          block^.parameters.procedure_parameters THEN
      clp$search_parameter_names (name, block^.parameters.names, index, found);
      IF found THEN
        variable_access_info := ^block^.parameters.accesses^ [block^.parameters.names^ [index].position].info;
      IFEND;
    IFEND;

  PROCEND clp$find_variable_access;

*copyc clt$block
*copyc clt$internal_variable_classes
*copyc clt$variable_access
*copyc clt$variable_access_info
*copyc clt$variable_name
*copyc clt$variable_name_hash
?? POP ??
*copyc clp$search_parameter_names
*DECK DECK=CLP$FIND_WORKING_CATALOG EXPAND=FALSE

*IF NOT $true(osv$unix)
  PROCEDURE [INLINE] clp$find_working_catalog
    (VAR working_catalog: ^^clt$working_catalog);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_object_in_current_task: boolean,
      object: ^clt$environment_object_contents;


    clp$find_environment_object (clc$eo_working_catalog, object,
          ignore_object_in_current_task);

    working_catalog := object;

  PROCEND clp$find_working_catalog;

*copyc clt$working_catalog
?? POP ??
*copyc clp$find_environment_object
*ELSE
  PROCEDURE [XREF] clp$find_working_catalog
    (VAR working_catalog: clt$working_catalog;
     VAR status: ost$status);

*copyc clt$working_catalog
*copyc ost$status
*IFEND
*DECK DECK=CLP$FIND_WORKING_CAT_FIRST_TIME EXPAND=FALSE
*DECK DECK=CLP$FIRST_LIST_ELEMENT EXPAND=FALSE

  FUNCTION [INLINE] clp$first_list_element
    (    list_value: ^clt$data_value): ^clt$data_value;

?? PUSH (LISTEXT := ON) ??

    VAR
      first_list_node: ^clt$data_value;


    first_list_node := list_value;
    WHILE (first_list_node <> NIL) AND (first_list_node^.kind = clc$list) DO
      IF first_list_node^.element_value <> NIL THEN
        clp$first_list_element := first_list_node;
        RETURN;
      IFEND;
      first_list_node := first_list_node^.link;
    WHILEND;
    clp$first_list_element := NIL;

  FUNCEND clp$first_list_element;

*copyc clt$data_value
?? POP ??
*DECK DECK=CLP$FORMAT_PROC_HEADER EXPAND=FALSE

  PROCEDURE [XREF] clp$format_proc_header
    (    output_file_id: amt$file_identifier;
         page_width: amt$page_width;
         supplied_first_line: ^clt$command_line;
         translate: boolean;
         indent_column: amt$page_width;
     VAR proc_name: ost$name;
     VAR error_count {input, output} : 0 .. amc$file_byte_limit;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc amt$file_identifier
*copyc amt$page_width
*copyc clt$command_line
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$FORMAT_VALUE EXPAND=FALSE
  PROCEDURE [XREF] clp$format_value
    (    format_string: ^clt$string_value;
         value: ^clt$data_value;
         max_string: clt$string_size;
     VAR work_area: ^clt$work_area;
     VAR data_representation: ^clt$data_representation;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_representation
*copyc clt$data_value
*copyc clt$string_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$FREE_ALL_HANDLERS EXPAND=FALSE

  PROCEDURE [XREF] clp$free_all_handlers;

*DECK DECK=CLP$FREE_ALL_HANDLERS_IN_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$free_all_handlers_in_block
    (    block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
?? POP ??
*DECK DECK=CLP$F_ADD_NODE_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$f_add_node_value
    (    node_value: clt$f_node_value);

?? PUSH (LISTEXT := ON) ??
*copyc clt$f_node_value
?? POP ??
*DECK DECK=CLP$F_CHECK_NAME_FOR_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] clp$f_check_name_for_control
    (    name: clt$name;
     VAR control_statement_descriptor: ^clt$f_control_statement_desc);

?? PUSH (LISTEXT := ON) ??
*copyc clt$f_control_statement_desc
*copyc clt$name
?? POP ??

*DECK DECK=CLP$F_COMPLETE_FILE_OR_VAR_SCAN EXPAND=FALSE

  PROCEDURE [XREF] clp$f_complete_file_or_var_scan
    (VAR parse {input, output} : clt$parse_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parse_state
*copyc ost$status
?? POP ??
*DECK DECK=CLP$F_EVALUATE_EXPRESSION EXPAND=FALSE

  PROCEDURE [XREF] clp$f_evaluate_expression
    (    value_kind_specifier: clt$value_kind_specifier;
         control_expression: boolean;
         parameter: boolean;
     VAR parse {input, output} : clt$parse_state;
     VAR value: clt$value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc clt$parse_state
*copyc clt$value_kind_specifier
*copyc ost$status
?? POP ??
*DECK DECK=CLP$F_EXPRESSION_SCANNER EXPAND=FALSE

  PROCEDURE [XREF] clp$f_expression_scanner
    (    value_kind_specifier: clt$value_kind_specifier;
         control_expression: boolean;
     VAR parse {input, output} : clt$parse_state;
     VAR value: clt$value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc clt$parse_state
*copyc clt$value_kind_specifier
*copyc ost$status
?? POP ??
*DECK DECK=CLP$F_FIND_CURRENT_BLOCK EXPAND=FALSE

  PROCEDURE [INLINE] clp$f_find_current_block
    (VAR current_block: ^clt$f_block);

?? PUSH (LISTEXT := ON) ??

    VAR
      task_block: ^clt$f_block,
      status: ost$status;

    clp$f_find_task_block (task_block, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal ('CL', 77777,
            'Unable to get pointer to SCL Task Block', status);
      pmp$abort (status);
    IFEND;
    current_block := task_block^.current_block;

  PROCEND clp$f_find_current_block;

*copyc clt$f_block
*copyc ost$status
?? POP ??
*copyc clp$f_find_task_block
*copyc osp$set_status_abnormal
*copyc pmp$abort
*DECK DECK=CLP$F_FIND_CYCLE_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$f_find_cycle_block
    (    target_label: ost$name;
     VAR current_block: ^clt$f_block;
     VAR target_block: ^clt$f_block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$f_block
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$F_FIND_TASK_BLOCK EXPAND=FALSE

  PROCEDURE [INLINE] clp$f_find_task_block
    (VAR task_block: ^clt$f_block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    IF clv$f_current_task_block = NIL THEN
      clp$f_find_task_block_1st_time (task_block, status);
    ELSE
      status.normal := TRUE;
      task_block := clv$f_current_task_block;
    IFEND;

  PROCEND clp$f_find_task_block;

*copyc clt$f_block
*copyc ost$status
?? POP ??
*copyc clp$f_find_task_block_1st_time
*copyc clv$f_current_task_block
*DECK DECK=CLP$F_FIND_TASK_BLOCK_1ST_TIME EXPAND=FALSE

  PROCEDURE [XREF] clp$f_find_task_block_1st_time
    (VAR task_block: ^clt$f_block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$f_block
*copyc ost$status
?? POP ??
*DECK DECK=CLP$F_NOTE_UNENDED_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$f_note_unended_block
    (    block_count: integer;
     VAR current_block: ^clt$f_block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$f_block
*copyc ost$status
?? POP ??
*DECK DECK=CLP$F_OUTPUT_LINE_NUMBER EXPAND=FALSE

  FUNCTION [XREF] clp$f_output_line_number: integer;

*DECK DECK=CLP$F_POP_BLOCK_STACK EXPAND=FALSE

  PROCEDURE [XREF] clp$f_pop_block_stack
    (VAR block: ^clt$f_block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$f_block
?? POP ??
*DECK DECK=CLP$F_PROCESS_COLLECT_TEXT EXPAND=FALSE

  PROCEDURE [XREF] clp$f_process_collect_text
    (    collect_command: string ( * <= 31);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$F_PROCESS_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] clp$f_process_command
    (    interpreter_mode: clt$interpreter_modes;
         command: ^clt$command_line;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc clt$interpreter_modes
*copyc ost$status
?? POP ??
*DECK DECK=CLP$F_PROCESS_PROC_HEADER EXPAND=FALSE

  PROCEDURE [XREF] clp$f_process_proc_header
    (    input_parameters: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$F_PROCESS_TASK_OR_JOB EXPAND=FALSE

  PROCEDURE [XREF] clp$f_process_task_or_job
    (    command: string ( * <= 4);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$F_PROCESS_VAR_OR_TYPE EXPAND=TRUE

  PROCEDURE [XREF] clp$f_process_var_or_type
    (    definition: string ( * <= osc$max_name_size);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$F_PUSH_BLOCK_STACK EXPAND=FALSE

  PROCEDURE [XREF] clp$f_push_block_stack
    (    block_kind: clt$block_kind;
         block_label: ost$name;
     VAR block: ^clt$f_block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$f_block
*copyc ost$name
?? POP ??
*DECK DECK=CLP$F_SCAN_ARGUMENT_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$f_scan_argument_list
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$F_SCAN_EXPRESSION EXPAND=FALSE

  PROCEDURE [XREF] clp$f_scan_expression
    (    expression: string ( * );
         value_kind_specifier: clt$value_kind_specifier;
     VAR value: clt$value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc cle$ecc_expression
*copyc cle$ecc_expression_result
*copyc cle$ecc_file_reference
*copyc cle$ecc_function_processing
*copyc cle$ecc_lexical
*copyc cle$ecc_variable
*copyc clt$value_kind_specifier
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$F_SCAN_PARAMETER_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$f_scan_parameter_list
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CLP$F_SCAN_TOKEN EXPAND=FALSE

  PROCEDURE [XREF] clp$f_scan_token
    (    termination_option: clt$slu_termination_option;
     VAR parse: { input, output } clt$parse_state);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc clt$parse_state
*copyc clt$slu_termination_option
?? POP ??
*DECK DECK=CLP$F_SET_COMMAND_HEADER_TYPE EXPAND=FALSE

  PROCEDURE [XREF] clp$f_set_command_header_type
    (    command_type: clt$f_command_type);

?? PUSH (LISTEXT := ON) ??
*copyc clt$f_command_type
?? POP ??
*DECK DECK=CLP$F_SET_SUBSTITUTION_MARK EXPAND=FALSE

  PROCEDURE [XREF] clp$f_set_substitution_mark
    (    substitution_mark: string (1));
*DECK DECK=CLP$F_SET_TREE_MARKER EXPAND=FALSE

  PROCEDURE [XREF] clp$f_set_tree_marker
    (    node_value: clt$f_node_value;
         insert_index: integer;
         eoi_encountered: boolean);


  PROCEDURE [XREF] clp$f_get_token_index
    (VAR index: integer);


?? PUSH (LISTEXT := ON) ??
*copyc clt$f_node_value
*copyc clt$format_marker_kind
?? POP ??
*DECK DECK=CLP$GENERATE_PDT EXPAND=FALSE

  PROCEDURE [XREF] clp$generate_pdt
    (    command_or_function: clt$command_or_function;
         first_line: ^clt$command_line;
         first_line_index: clt$command_line_index;
         get_line: clt$input_procedure;
     VAR work_area {input, output} : ^clt$work_area;
     VAR last_line: ^clt$command_line;
     VAR last_line_index: clt$command_line_index;
     VAR command_or_function_name: pmt$program_name;
     VAR aliases: ^array [1 .. * ] of pmt$program_name;
     VAR availability: clt$named_entry_availability;
     VAR command_or_function_scope: clt$command_or_function_scope;
     VAR command_log_option: clt$command_log_option;
     VAR parameter_description_table: ^clt$parameter_description_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc clt$command_line_index
*copyc clt$command_log_option
*copyc clt$command_or_function
*copyc clt$command_or_function_scope
*copyc clt$input_procedure
*copyc clt$named_entry_availability
*copyc clt$parameter_description_table
*copyc clt$work_area
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=CLP$GENERATE_TYPE_SPECIFICATION EXPAND=FALSE

  PROCEDURE [XREF] clp$generate_type_specification
    (    type_name: clt$type_name;
         first_line: ^clt$command_line;
         first_line_index: clt$command_line_index;
         get_line: clt$input_procedure;
     VAR work_area {input, output} : ^clt$work_area;
     VAR last_line: ^clt$command_line;
     VAR last_line_index: clt$command_line_index;
     VAR type_specification: ^clt$type_specification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc clt$command_line_index
*copyc clt$input_procedure
*copyc clt$type_name
*copyc clt$type_specification
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_ALL_CMND_OR_FUNC_NAMES EXPAND=FALSE

  PROCEDURE [XREF] clp$get_all_cmnd_or_func_names
    (    command_or_function: clt$command_or_function;
         command_or_function_source: clt$command_or_function_source;
         command_or_function_name: clt$command_name;
     VAR work_area {input, output} : ^clt$work_area;
     VAR names: ^array [1 .. * ] of clt$command_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_name
*copyc clt$command_or_function
*copyc clt$command_or_function_source
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_ARRAY_ELEMENT_TYPE_DESC EXPAND=FALSE

  PROCEDURE [INLINE] clp$get_array_element_type_desc
    (    value: ^clt$data_value;
     VAR type_description {input, output} : ^clt$type_description);

?? PUSH (LISTEXT := ON) ??

    IF (type_description <> NIL) AND (type_description^.kind = clc$array_type)
          THEN
      type_description := type_description^.array_element_type_description;
      IF value <> NIL THEN
        clp$get_value_type_desc (value, FALSE, type_description);
      IFEND;
    ELSE
      type_description := NIL;
    IFEND;

  PROCEND clp$get_array_element_type_desc;

*copyc clt$data_value
*copyc clt$type_description
?? POP ??
*copyc clp$get_value_type_desc
*DECK DECK=CLP$GET_CMND_OR_FUNC_SOURCE_STR EXPAND=FALSE

  PROCEDURE [XREF] clp$get_cmnd_or_func_source_str
    (    command_or_function_source: clt$command_or_function_source;
     VAR source_string: fst$path;
     VAR source_string_size: fst$path_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_or_function_source
*copyc fst$path
*copyc fst$path_size
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_COLLECT_TEXT_CMND_INFO EXPAND=FALSE

  PROCEDURE [XREF] clp$get_collect_text_cmnd_info
    (VAR collect_text_command_info: clt$collect_text_command_info);

?? PUSH (LISTEXT := ON) ??
*copyc clt$collect_text_command_info
?? POP ??
*DECK DECK=CLP$GET_COMMAND_IMAGE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_command_image
    (VAR command_image: ^clt$command_line;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_COMMAND_LINE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_command_line
    (VAR parse: clt$parse_state;
     VAR end_of_input: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parse_state
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_COMMAND_NAME EXPAND=FALSE

  PROCEDURE [XREF] clp$get_command_name
      (VAR anme: clt$command_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_COMMAND_ORIGIN EXPAND=FALSE

  PROCEDURE [XREF] clp$get_command_origin
    (VAR interactive: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_COMMAND_SEARCH_MODE EXPAND=FALSE

  PROCEDURE [INLINE] clp$get_command_search_mode
    (VAR search_mode: clt$command_search_modes);

?? PUSH (LISTEXT := ON) ??

    VAR
      command_list: ^clt$command_list,
      ignore_cmnd_list_found_in_task: boolean;

    clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);
    search_mode := command_list^.search_mode;

  PROCEND clp$get_command_search_mode;

*copyc clt$command_list
*copyc clt$command_search_modes
?? POP ??
*copyc clp$find_command_list
*DECK DECK=CLP$GET_COMMAND_STATISTICS EXPAND=FALSE

  PROCEDURE [XREF] clp$get_command_statistics
    (VAR cmd_statistics: clt$command_resource_statistics;
     VAR secure_logging: boolean;
     VAR stats_enabled: boolean;
     VAR command_performance_statistics: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_resource_statistics
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_DATA_LINE EXPAND=FALSE

{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     ****** This program interface is obsolete.  Modules presently    ******
{     ****** using it should be changed to use CLP$GET_LINE_FROM_      ******
{     ****** COMMAND_FILE.                                             ******
{     ***********************************************************************
{     ***********************************************************************
{

  PROCEDURE [XREF] clp$get_data_line
    (    prompt_string: string ( * );
     VAR line: ost$string;
     VAR got_line: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$GET_DATA_RECORD EXPAND=FALSE

  PROCEDURE [XREF] clp$get_data_record
    (    local_file_name: amt$local_file_name;
         file_id: amt$file_identifier;
         record_number: amt$file_byte_address;
         line_layout: clt$line_layout;
         line_area: ^SEQ ( * );
     VAR line: ^clt$command_line;
     VAR line_identifier: clt$line_identifier;
     VAR got_line: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc clt$command_line
*copyc clt$line_identifier
*copyc clt$line_layout
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_DATE_STRING EXPAND=FALSE

  PROCEDURE [XREF] clp$get_date_string
    (VAR str: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$GET_DATE_TIME_STRING EXPAND=FALSE

  PROCEDURE [XREF] clp$get_date_time_string
    (    format: clt$date_time_form_string;
     VAR str: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$date_time_form_string
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$GET_DAY_AND_MONTH_NAMES EXPAND=TRUE

  PROCEDURE [XREF] clp$get_day_and_month_names
    (    language: ost$natural_language;
     VAR day_and_month_names_ptr: ^clt$day_and_month_names;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$natural_language
*copyc clt$day_and_month_names
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_DAY_NAME EXPAND=FALSE

  PROCEDURE [XREF] clp$get_day_name
    (    day_of_week: ost$day_of_week;
         full_form: boolean;
         natural_language: ost$natural_language;
     VAR day_name: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$day_of_week
*copyc ost$natural_language
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$GET_EXPECTED_TYPE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_expected_type
    (VAR work_area {input, output} : ^clt$work_area;
     VAR expected_type: ^clt$type_specification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$type_specification
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_FIELD_TYPE_DESC EXPAND=FALSE

  PROCEDURE [INLINE] clp$get_field_type_desc
    (    field_name: clt$field_name;
         value: ^clt$data_value;
     VAR type_description {input, output} : ^clt$type_description);

?? PUSH (LISTEXT := ON) ??

    VAR
      i: clt$field_number;


    IF (type_description <> NIL) AND (type_description^.kind = clc$record_type)
          THEN
      FOR i := 1 TO type_description^.fields_pdt^.header^.
            number_of_parameters DO
        IF type_description^.fields_pdt^.names^ [i].name = field_name THEN
          type_description := ^type_description^.fields_pdt^.
                type_descriptions^ [i];
          IF value <> NIL THEN
            clp$get_value_type_desc (value, FALSE, type_description);
          IFEND;
          RETURN;
        IFEND;
      FOREND;
    IFEND;
    type_description := NIL;

  PROCEND clp$get_field_type_desc;

*copyc clt$data_value
*copyc clt$field_name
*copyc clt$type_description
?? POP ??
*copyc clp$get_value_type_desc
*DECK DECK=CLP$GET_FILE_CYCLES EXPAND=FALSE

  PROCEDURE [XREF] clp$get_file_cycles
    (    file: fst$file_reference;
     VAR work_area {input, output}: ^clt$work_area;
     VAR cycle_array: ^array [1 .. * ] of fst$cycle_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$work_area
*copyc fst$cycle_number
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_FS_PATH_ELEMENTS EXPAND=FALSE

{
{ Clp$get_fs_path_elements assumes that the path_handle_name it receives
{ as input represents a path_handle, i.e. it can be converted to an
{ fmt$path_handle.
{

  PROCEDURE [INLINE] clp$get_fs_path_elements
    (    path_handle_name: amt$local_file_name;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      cl_path_handle: clt$path_handle,
      ignore_status: ost$status;

    status.normal := TRUE;

    clp$check_name_for_path_handle (path_handle_name, cl_path_handle);
    IF cl_path_handle.kind = clc$command_file_handle THEN
      osp$set_status_abnormal ('CL', cle$inappropriate_cmnd_file_ref, '',
            status);
      RETURN;
    IFEND;

    bap$get_path_elements (cl_path_handle.regular_handle,
          evaluated_file_reference, status);
    IF NOT status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status,
            ignore_status);
      osp$set_status_abnormal ('CL', cle$system_error, '', status);
    IFEND;

  PROCEND clp$get_fs_path_elements;

*copyc amt$local_file_name
*copyc cle$ecc_command_processing
*copyc cle$ecc_file_reference
*copyc fst$evaluated_file_reference
*copyc pmd$system_log_interface
?? POP ??
*copyc bap$get_path_elements
*copyc clp$check_name_for_path_handle
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*DECK DECK=CLP$GET_FS_PATH_STRING EXPAND=FALSE

{
{ Clp$get_fs_path_string assumes that the path_handle_name it receives
{ as input represents a path_handle, i.e. it can be converted to an
{ fmt$path_handle.
{

  PROCEDURE [INLINE] clp$get_fs_path_string
    (    path_handle_name: amt$local_file_name;
     VAR path: fst$path;
     VAR path_size: fst$path_size;
     VAR path_handle: fmt$path_handle;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      cl_path_handle: clt$path_handle,
      ignore_local_file_name: amt$local_file_name,
      ignore_name_is_path_handle: boolean,
      ignore_name_is_valid: boolean,
      ignore_status: ost$status;

    status.normal := TRUE;
    path := '';
    path_size := 0;

    clp$check_name_for_path_handle (path_handle_name, cl_path_handle);
    IF cl_path_handle.kind = clc$command_file_handle THEN
      osp$set_status_abnormal ('CL', cle$inappropriate_cmnd_file_ref, '',
            status);
      RETURN;
    IFEND;

    bap$get_path_string (cl_path_handle.regular_handle, path, path_size,
             status);
    IF NOT status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status,
            ignore_status);
      osp$set_status_abnormal ('CL', cle$system_error, '', status);
    IFEND;

  PROCEND clp$get_fs_path_string;

*copyc amt$local_file_name
*copyc cle$ecc_command_processing
*copyc cle$ecc_file_reference
*copyc fmt$path_handle
*copyc fst$path
*copyc pmd$system_log_interface
?? POP ??
*copyc bap$get_path_string
*copyc clp$check_name_for_path_handle
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal

*DECK DECK=CLP$GET_INCLUDE_ENDED EXPAND=FALSE

  PROCEDURE [XREF] clp$get_include_ended
    (    utility: clt$utility_name;
     VAR include_ended: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$utility_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_INTERPRETER_MODE EXPAND=FALSE

  PROCEDURE [INLINE] clp$get_interpreter_mode
    (VAR interpreter_mode: clt$interpreter_modes);

?? PUSH (LISTEXT := ON) ??

    VAR
      block: ^clt$block;

    clp$find_current_block (block);
    interpreter_mode := block^.interpreter_mode;

  PROCEND clp$get_interpreter_mode;

*copyc clt$block
*copyc clt$interpreter_modes
?? POP ??
*copyc clp$find_current_block
*DECK DECK=CLP$GET_JOB_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] clp$get_job_parameters
    (    submitter_ring: ost$valid_ring;
         submitted_file_reference: fst$file_reference;
     VAR job_system_label: {input, output} jmt$job_system_label;
     VAR login_command_in_file: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jmt$job_system_label
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_LINE_FROM_COMMAND_FILE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_line_from_command_file
    (    prompt_string: clt$prompt_string;
     VAR line: ^clt$command_line;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc clt$command_line
*copyc clt$prompt_string
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_LIST_ELEMENT_TYPE_DESC EXPAND=FALSE

  PROCEDURE [INLINE] clp$get_list_element_type_desc
    (    value: ^clt$data_value;
     VAR type_description {input, output} : ^clt$type_description);

?? PUSH (LISTEXT := ON) ??

    IF (type_description <> NIL) AND (type_description^.kind = clc$list_type)
          THEN
      type_description := type_description^.list_element_type_description;
      IF value <> NIL THEN
        clp$get_value_type_desc (value, FALSE, type_description);
      IFEND;
    ELSE
      type_description := NIL;
    IFEND;

  PROCEND clp$get_list_element_type_desc;

*copyc clt$data_value
*copyc clt$type_description
?? POP ??
*copyc clp$get_value_type_desc
*DECK DECK=CLP$GET_LIST_OF_$LOCAL_FILES EXPAND=FALSE

  PROCEDURE [XREF] clp$get_list_of_$local_files
    (VAR info: pft$p_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
?? POP ??
*DECK DECK=CLP$GET_LOGIN_DATA_FOR_NAM EXPAND=FALSE

  PROCEDURE [XREF] clp$get_login_data_for_nam
    (    parameter_list: clt$parameter_list;
     VAR login_user: ost$name;
     VAR login_password: ost$name;
     VAR login_family: ost$name;
     VAR login_account: ost$name;
     VAR login_project: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_LOGIN_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] clp$get_login_parameters
    (    parameter_list: clt$parameter_list;
     VAR job_system_label {input, output}: jmt$job_system_label;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc jmt$job_system_label
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_LOG_SECURE_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] clp$get_log_secure_parameters
    (VAR log_secure_parameters: boolean);

*DECK DECK=CLP$GET_MESSAGE_MODULE_INFO EXPAND=FALSE

  PROCEDURE [XREF] clp$get_message_module_info
    (    message_template_module: ^ost$message_template_module;
     VAR natural_language: ost$natural_language;
     VAR online_manual_name: ost$online_manual_name;
     VAR help_module: boolean;
     VAR message_module: boolean;
     VAR lowest_message_code: ost$status_condition_code;
     VAR highest_message_code: ost$status_condition_code;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$message_template_module
*copyc ost$natural_language
*copyc ost$online_manual_name
*copyc ost$status
*copyc ost$status_condition_code
?? POP ??
*DECK DECK=CLP$GET_MONTH_NAME EXPAND=FALSE

  PROCEDURE [XREF] clp$get_month_name
    (    month_number: 1 .. 12;
         full_form: boolean;
         natural_language: ost$natural_language;
     VAR month_name: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$natural_language
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$GET_NEXT_SCL_PROC_LINE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_next_scl_proc_line
    (VAR scl_procedure {input, output} : ^clt$scl_procedure;
     VAR line: ^clt$command_line;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc clt$scl_procedure
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_NON_STANDARD_CMND_LINE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_non_standard_cmnd_line
    (VAR parse: clt$parse_state;
     VAR end_of_input: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parse_state
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_NON_STANDARD_LINE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_non_standard_line
    (    line_kind: clt$input_line_kind;
         prompt_string: clt$prompt_string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$input_line_kind
*copyc clt$prompt_string
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_OPEN_POS_OF_PATH_HANDLE EXPAND=FALSE

  PROCEDURE [INLINE] clp$get_open_pos_of_path_handle
    (    path_handle_name: amt$local_file_name;
     VAR open_position: fst$open_position);

?? PUSH (LISTEXT := ON) ??

    CASE path_handle_name (5) OF
    = 'A' =
      open_position.specified := TRUE;
      open_position.value := amc$open_no_positioning;
    = 'B' =
      open_position.specified := TRUE;
      open_position.value := amc$open_at_boi;
    = 'E' =
      open_position.specified := TRUE;
      open_position.value := amc$open_at_eoi;
    ELSE
      open_position.specified := FALSE;
    CASEND;

  PROCEND clp$get_open_pos_of_path_handle;

*copyc amt$local_file_name
*copyc fst$open_position
?? POP ??
*DECK DECK=CLP$GET_PARAMETER EXPAND=FALSE

  PROCEDURE [XREF] clp$get_parameter
    (    parameter_name: string ( * );
     VAR value_list: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_parameter_list
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$GET_PARAMETER_LIST EXPAND=FALSE

{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     ****** This program interface is obsolete.  Modules presently    ******
{     ****** using it should be changed to use CLP$GET_PARAMETER_      ******
{     ****** LIST_TEXT.                                                ******
{     ***********************************************************************
{     ***********************************************************************
{

  PROCEDURE [XREF] clp$get_parameter_list
    (VAR parameter_list: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$GET_PARAMETER_LIST_PARSE EXPAND=FALSE

  PROCEDURE [INLINE] clp$get_parameter_list_parse
    (    parameter_list: ^clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR parse {input, output} : clt$parse_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      lexical_units: ^clt$lexical_units,
      parameter_list_area: ^clt$parameter_list,
      parameter_list_contents: ^clt$i_parameter_list_contents,
      parameter_list_text: ^clt$parameter_list_text;


    status.normal := TRUE;

    parameter_list_area := parameter_list;
    RESET parameter_list_area;
    NEXT parameter_list_contents IN parameter_list_area;

    IF parameter_list_contents = NIL THEN
      osp$set_status_abnormal ('CL', cle$bad_parameter_list, '', status);
      RETURN;
    IFEND;

    IF parameter_list_contents^.identifying_size_field =
          UPPERVALUE (parameter_list_contents^.identifying_size_field) THEN
      RETURN;
    IFEND;

    NEXT parameter_list_text: [parameter_list_contents^.
          identifying_size_field] IN parameter_list_area;
    IF parameter_list_text = NIL THEN
      osp$set_status_abnormal ('CL', cle$bad_parameter_list, '', status);
      RETURN;
    IFEND;

    clp$identify_lexical_units (parameter_list_text, work_area, lexical_units,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$initialize_parse_state (parameter_list_text, lexical_units, parse);
    clp$scan_non_space_lexical_unit (parse);

  PROCEND clp$get_parameter_list_parse;

*copyc cle$bad_parameter_list
*copyc clt$i_parameter_list_contents
*copyc clt$parameter_list
*copyc clt$parameter_list_text
*copyc clt$work_area
*copyc clt$parse_state
*copyc ost$status
?? POP ??
*copyc clp$identify_lexical_units
*copyc clp$initialize_parse_state
*copyc clp$scan_non_space_lexical_unit
*copyc osp$set_status_abnormal
*DECK DECK=CLP$GET_PARAMETER_LIST_TEXT EXPAND=FALSE

  PROCEDURE [XREF] clp$get_parameter_list_text
    (    parameter_list: ^clt$parameter_list;
     VAR parameter_list_text: ^clt$parameter_list_text;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc clt$parameter_list_text
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_PARAMETER_NUMBER EXPAND=FALSE

  PROCEDURE [XREF] clp$get_parameter_number
    (    parameter_description_table: ^clt$parameter_description_table;
         parameter_name: clt$parameter_reference;
     VAR parameter_number: clt$parameter_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_description_table
*copyc clt$parameter_number
*copyc clt$parameter_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_PATH_DESCRIPTION EXPAND=FALSE

  PROCEDURE [XREF] clp$get_path_description
    (    file: clt$file;
     VAR file_reference: clt$file_reference;
     VAR path_container: clt$path_container;
     VAR path: ^pft$path;
     VAR cycle_selector: clt$cycle_selector;
     VAR open_position: clt$open_position;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$file
*copyc clt$file_reference
*copyc cld$path_description
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=CLP$GET_PATH_NAME EXPAND=FALSE

  PROCEDURE [XREF] clp$get_path_name ALIAS 'clpgpn'
    (    local_file_name: fst$file_reference;
         format: ost$format_message_level;
     VAR file_reference: fst$path);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc fst$path
*copyc ost$format_message_level
?? POP ??
*DECK DECK=CLP$GET_PROCESSING_PHASE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_processing_phase
    (VAR processing_phase: clt$processing_phase;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$processing_phase
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_PROC_PARAMETER EXPAND=FALSE

  PROCEDURE [XREF] clp$get_proc_parameter
    (    parameter_name: string ( * );
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_PROC_PARAMETER_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$get_proc_parameter_list
    (VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_PROC_SET_COUNT EXPAND=FALSE

  PROCEDURE [XREF] clp$get_proc_set_count
    (    parameter_name: string ( * );
     VAR work_area {input, output} : ^clt$work_area;
     VAR value_set_count: 0 .. clc$max_value_sets;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_limits
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_PROC_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_proc_value
    (    parameter_name: string ( * );
         value_set_number: 1 .. clc$max_value_sets;
         value_number: 1 .. clc$max_values_per_set;
         low_or_high: clt$low_or_high;
     VAR work_area {input, output} : ^clt$work_area;
     VAR access_mode: clt$data_access_mode;
     VAR value: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_limits
*copyc clt$data_access_mode
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_PROC_VALUE_COUNT EXPAND=FALSE

  PROCEDURE [XREF] clp$get_proc_value_count
    (    parameter_name: string ( * );
         value_set_number: 1 .. clc$max_value_sets;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value_count: 0 .. clc$max_values_per_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_limits
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_PROC_VALUE_KIND EXPAND=FALSE

  PROCEDURE [XREF] clp$get_proc_value_kind
    (    parameter_name: string ( * );
         value_set_number: 1 .. clc$max_value_sets;
         value_number: 1 .. clc$max_values_per_set;
         low_or_high: clt$low_or_high;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_limits
*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_PROMPTING_REPLY EXPAND=FALSE

  PROCEDURE [XREF] clp$get_prompting_reply
    (VAR line: ^clt$command_line;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_QUALIFIED_TYPE_DESC EXPAND=FALSE

  PROCEDURE [XREF] clp$get_qualified_type_desc
    (    value_qualifiers: ^clt$value_qualifiers;
     VAR type_description {input, output} : ^clt$type_description);

*copyc clt$type_description
*copyc clt$value_qualifiers
*DECK DECK=CLP$GET_RANGE_ELEMENT_TYPE_DESC EXPAND=FALSE

  PROCEDURE [INLINE] clp$get_range_element_type_desc
    (    value: ^clt$data_value;
     VAR type_description {input, output} : ^clt$type_description);

?? PUSH (LISTEXT := ON) ??

    IF (type_description <> NIL) AND (type_description^.kind = clc$range_type)
          THEN
      type_description := type_description^.range_element_type_description;
      IF value <> NIL THEN
        clp$get_value_type_desc (value, FALSE, type_description);
      IFEND;
    ELSE
      type_description := NIL;
    IFEND;

  PROCEND clp$get_range_element_type_desc;

*copyc clt$data_value
*copyc clt$type_description
?? POP ??
*copyc clp$get_value_type_desc
*DECK DECK=CLP$GET_READ_VALUE_QUALIFIERS EXPAND=FALSE

  PROCEDURE [XREF] clp$get_read_value_qualifiers
    (    name: clt$variable_name;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value_qualifiers : ^clt$value_qualifiers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parse_state
*copyc clt$value_qualifiers
*copyc clt$variable_name
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_REASON_FOR_CALL EXPAND=FALSE

  PROCEDURE [XREF] clp$get_reason_for_call
    (VAR information_request: boolean;
     VAR display_file: fst$path;
     VAR prompting_activated: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$path
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_RETURN_FILE_VALS_AS_STR EXPAND=FALSE

  PROCEDURE [INLINE] clp$get_return_file_vals_as_str
    (VAR return_file_values_as_strings: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      block: ^clt$block;


    clp$find_current_block (block);
    IF (block^.kind = clc$input_block) AND
          (block^.input.kind = clc$file_input) AND
          block^.input.interactive_device THEN
      block := block^.previous_block;
    IFEND;

    IF (block^.kind <> clc$command_block) OR block^.pvt.built THEN
      return_file_values_as_strings := FALSE;
    ELSE
      return_file_values_as_strings := block^.return_file_values_as_strings;
    IFEND;

  PROCEND clp$get_return_file_vals_as_str;

*copyc clt$block
?? POP ??
*copyc clp$find_current_block
*DECK DECK=CLP$GET_SEGMENT_CMND_LINE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_segment_cmnd_line
    (VAR parse: clt$parse_state;
     VAR end_of_input: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parse_state
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_SEGMENT_CMND_LINE_V0 EXPAND=FALSE

  PROCEDURE [XREF] clp$get_segment_cmnd_line_v0
    (VAR parse: clt$parse_state;
     VAR end_of_input: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parse_state
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_SEGMENT_LINE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_segment_line
    (    line_kind: clt$input_line_kind;
         prompt_string: clt$prompt_string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$input_line_kind
*copyc clt$prompt_string
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_SEGMENT_LINE_V0 EXPAND=FALSE

  PROCEDURE [XREF] clp$get_segment_line_v0
    (    line_kind: clt$input_line_kind;
         prompt_string: clt$prompt_string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$input_line_kind
*copyc clt$prompt_string
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_SEMICOLON_AFTER_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] clp$get_semicolon_after_command
    (VAR semicolon_after_command: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_SET_COUNT EXPAND=FALSE

  PROCEDURE [XREF] clp$get_set_count
    (    parameter_name: string ( * );
     VAR value_set_count: 0 .. clc$max_value_sets;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_limits
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_SINGLE_DATA_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_single_data_value
    (    value_set_number: 1 .. clc$max_value_sets;
         value_number: 1 .. clc$max_values_per_set;
         low_or_high: clt$low_or_high;
     VAR data_value: ^clt$data_value;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_limits
*copyc clt$data_value
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_SINGLE_INTERNAL_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_single_internal_value
    (    internal_value: ^clt$internal_data_value;
         value_set_number: 1 .. clc$max_value_sets;
         value_number: 1 .. clc$max_values_per_set;
         low_or_high: clt$low_or_high;
     VAR internal_component {input, output} : REL (clt$internal_data_value) ^clt$i_data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_limits
*copyc clt$i_data_value
*copyc clt$internal_data_value
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_SOURCE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_source
    (VAR source: clt$source;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$source
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_STANDARD_CMND_LINE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_standard_cmnd_line
    (VAR parse: clt$parse_state;
     VAR end_of_input: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parse_state
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_STANDARD_LINE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_standard_line
    (    line_kind: clt$input_line_kind;
         prompt_string: clt$prompt_string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$input_line_kind
*copyc clt$prompt_string
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_STATEMENT_TO_FORMAT EXPAND=FALSE

  PROCEDURE [XREF] clp$get_statement_to_format
    (VAR line_ptr: ^clt$command_line;
     VAR got_line: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_SYNCHRONOUS_WITH_PARENT EXPAND=FALSE

  PROCEDURE [XREF] clp$get_synchronous_with_parent
    (VAR synchronous_with_parent: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_SYSTEM_FILE_ID EXPAND=FALSE

  PROCEDURE [XREF] clp$get_system_file_id
    (    file_name: amt$local_file_name;
     VAR file_id: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_SYSTEM_MESSAGE_MOD_PTR EXPAND=FALSE
  PROCEDURE [XREF] clp$get_system_message_mod_ptr
    (VAR message_template: ^ost$message_template_module);

?? PUSH (LISTEXT := ON) ??
*copyc ost$message_template_module
?? POP ??
*DECK DECK=CLP$GET_TASK_STATUS EXPAND=FALSE

  PROCEDURE [XREF] clp$get_task_status
    (    task_name: clt$task_name_reference;
     VAR task_status: pmt$task_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$task_name_reference
*copyc ost$status
*copyc pmt$task_status
?? POP ??
*DECK DECK=CLP$GET_TIME_STRING EXPAND=FALSE

  PROCEDURE [XREF] clp$get_time_string
    (VAR str: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$GET_TIME_ZONE_IDENTIFIER EXPAND=FALSE

  PROCEDURE [XREF] clp$get_time_zone_identifier
    (    time_zone: ost$time_zone;
         full_form: boolean;
         natural_language: ost$natural_language;
     VAR time_zone_identifier: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$natural_language
*copyc ost$status
*copyc ost$string
*copyc ost$time_zone
?? POP ??
*DECK DECK=CLP$GET_TYPE_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] clp$get_type_information
    (    type_specification: ^clt$type_specification;
     VAR work_area {input, output} : ^clt$work_area;
     VAR type_information: clt$type_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$type_information
*copyc clt$type_specification
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_ULTIMATE_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] clp$get_ultimate_connection
    (    candidate_name: amt$local_file_name;
     VAR ultimate_name: amt$local_file_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_UNSEEN_MAIL_ACTION EXPAND=FALSE
  PROCEDURE [XREF] clp$get_unseen_mail_action
    (VAR action: clt$unseen_mail_action;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$unseen_mail_action
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_USER_IDENTIFICATION EXPAND=FALSE

  PROCEDURE [XREF] clp$get_user_identification
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_UTILITY_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] clp$get_utility_attributes
    (    name: clt$utility_name;
     VAR attributes {input, output} : clt$utility_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_utilities
*copyc clt$utility_attributes
*copyc clt$utility_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_value
    (    parameter_name: string ( * );
         value_set_number: 1 .. clc$max_value_sets;
         value_number: 1 .. clc$max_values_per_set;
         low_or_high: clt$low_or_high;
     VAR value: clt$value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_limits
*copyc cld$value
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_VALUE_COUNT EXPAND=FALSE

  PROCEDURE [XREF] clp$get_value_count
    (    parameter_name: string ( * );
         value_set_number: 1 .. clc$max_value_sets;
     VAR value_count: 0 .. clc$max_values_per_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_limits
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_VALUE_TYPE_DESC EXPAND=FALSE

  PROCEDURE [XREF] clp$get_value_type_desc
    (    value: ^clt$data_value;
         check_keyword: boolean;
     VAR type_description {input, output} : ^clt$type_description);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$type_description
?? POP ??
*DECK DECK=CLP$GET_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_variable
    (    reference: clt$variable_ref_expression;
     VAR work_area {input, output} : ^clt$work_area;
     VAR class: clt$variable_class;
     VAR access_mode: clt$data_access_mode;
     VAR evaluation_method: clt$expression_eval_method;
     VAR type_specification: ^clt$type_specification;
     VAR value: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$unknown_variable
*copyc clt$data_access_mode
*copyc clt$data_value
*copyc clt$expression_eval_method
*copyc clt$type_specification
*copyc clt$variable_class
*copyc clt$variable_ref_expression
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_VARIABLE_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$get_variable_value
    (    reference: clt$variable_ref_expression;
     VAR value: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$unknown_variable
*copyc clt$data_value
*copyc clt$variable_ref_expression
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_WORKING_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] clp$get_working_catalog
    (VAR catalog_reference: clt$file_reference;
     VAR path_container: clt$path_container;
     VAR path: ^pft$path;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$path_description
*copyc clt$file_reference
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=CLP$GET_WORK_AREA EXPAND=FALSE

  PROCEDURE [XREF] clp$get_work_area
    (    work_area_ring: ost$valid_ring;
     VAR work_area: ^^clt$work_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$work_area
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=CLP$GET_WRITE_VALUE_QUALIFIERS EXPAND=FALSE

  PROCEDURE [XREF] clp$get_write_value_qualifiers
    (    name: clt$variable_name;
     VAR type_description {input, output} : ^clt$type_description;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value_qualifiers : ^clt$value_qualifiers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parse_state
*copyc clt$type_description
*copyc clt$value_qualifiers
*copyc clt$variable_name
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$HELP_SUBJECT_AVS EXPAND=FALSE

  PROCEDURE [XREF] clp$help_subject_avs
    (    avs_name: clt$application_value_name;
         avs_keyword_values: ^array [1 .. * ] of ost$name;
         avs_text: string ( * );
     VAR avs_value: clt$value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc clt$application_value
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$HORIZONTAL_TAB_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] clp$horizontal_tab_display
    (VAR display_control {input, output} : clt$display_control;
         column_number: amt$page_width;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amd$page_format_declarations
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=CLP$IDENTIFY_LEXICAL_UNIT EXPAND=FALSE

  PROCEDURE [XREF] clp$identify_lexical_unit
    (    termination_option: clt$slu_termination_option;
         text: ^clt$string_value;
     VAR index {input, output} : clt$string_index;
     VAR unit_index: clt$string_index;
     VAR unit_is_space: boolean;
     VAR unit: clt$lexical_unit);

?? PUSH (LISTEXT := ON) ??
*copyc clt$lexical_unit
*copyc clt$slu_termination_option
*copyc clt$string_index
*copyc clt$string_value
?? POP ??
*DECK DECK=CLP$IDENTIFY_LEXICAL_UNITS EXPAND=FALSE

  PROCEDURE [XREF] clp$identify_lexical_units
    (    text: ^clt$string_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR units: ^clt$lexical_units;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$lexical_units
*copyc clt$string_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$IGNORE_REST_OF_FILE EXPAND=FALSE

  PROCEDURE [XREF] clp$ignore_rest_of_file
    (    utility_name: clt$utility_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$utility_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$INCLUDE_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] clp$include_command
    (    command: clt$command_line;
         enable_echoing: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc ost$status
?? POP ??
*DECK DECK=CLP$INCLUDE_FILE EXPAND=FALSE

  PROCEDURE [XREF] clp$include_file
    (    file: fst$file_reference;
         prompt: clt$prompt;
         utility: clt$utility_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc cle$exception_condition_codes
*copyc clt$prompt
*copyc clt$utility_name
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$INCLUDE_LINE EXPAND=FALSE

  PROCEDURE [XREF] clp$include_line
    (    statement_list: clt$command_line;
         enable_echoing: boolean;
         utility: clt$utility_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$exception_condition_codes
*copyc clt$command_line
*copyc clt$utility_name
*copyc ost$status
?? POP ??

*DECK DECK=CLP$INITIALIZE_APPLICATION_INFO EXPAND=FALSE

  PROCEDURE [XREF] clp$initialize_application_info
    (    application_identifier: llt$application_identifier;
         library_privilege: ost$name;
         module_kind: llt$library_module_kind;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc llt$application_identifier
*copyc llt$library_module_kind
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$INITIALIZE_PARSE_STATE EXPAND=FALSE

  PROCEDURE [INLINE] clp$initialize_parse_state
    (    text: ^clt$string_value;
         units: ^clt$lexical_units;
     VAR parse: clt$parse_state);

?? PUSH (LISTEXT := ON) ??

    parse.text := text;
    parse.index := 1;
    parse.units_array := units;
    parse.units_array_index := 1;
    parse.index_limit := STRLENGTH (text^) + 1;
    parse.unit.kind := clc$lex_beginning_of_line;
    parse.unit.size := 0;
    parse.unit_index := 1;
    parse.unit_is_space := FALSE;
    parse.previous_unit_is_space := FALSE;
    parse.previous_non_space_unit.kind := clc$lex_beginning_of_line;
    parse.previous_non_space_unit.size := 0;
    parse.previous_non_space_unit_index := 1;

  PROCEND clp$initialize_parse_state;

*copyc clt$lexical_units
*copyc clt$parse_state
*copyc clt$string_value
?? POP ??
*DECK DECK=CLP$INITIALIZE_TEST_HARNESS EXPAND=FALSE

  PROCEDURE [XREF] clp$initialize_test_harness
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$INIT_ALL_ENVIRONMENT EXPAND=FALSE

  PROCEDURE [XREF] clp$init_all_environment
    (VAR environment_object_info: ^clt$environment_object_info);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_info
?? POP ??
*DECK DECK=CLP$INIT_INPUT_PARSE_STATE EXPAND=FALSE

  PROCEDURE [XREF] clp$init_input_parse_state
    (    lexical_units: ^clt$lexical_units;
     VAR parse: clt$parse_state);

?? PUSH (LISTEXT := ON) ??
*copyc clt$lexical_units
*copyc clt$parse_state
?? POP ??
*DECK DECK=CLP$INSERT_FORMAT_MARKER EXPAND=FALSE

  PROCEDURE [XREF] clp$insert_format_marker
    (    format_marker_kind: clt$format_marker_kind;
         offset: 0 .. 15);

?? PUSH (LISTEXT := ON) ??
*copyc clt$format_marker_kind
?? POP ??
*DECK DECK=CLP$INTEGER_COMPARE EXPAND=FALSE

  FUNCTION [INLINE] clp$integer_compare
    (    left_integer: integer;
         right_integer: integer): clt$comparison_result;

?? PUSH (LISTEXT := ON) ??

    IF left_integer < right_integer THEN
      clp$integer_compare := clc$right_is_greater;
    ELSEIF left_integer = right_integer THEN
      clp$integer_compare := clc$equal;
    ELSE
      clp$integer_compare := clc$left_is_greater;
    IFEND;

  FUNCEND clp$integer_compare;

*copyc clt$comparison_result
?? POP ??
*DECK DECK=CLP$INTERNAL_CONVERT_TO_STRING EXPAND=FALSE

  PROCEDURE [XREF] clp$internal_convert_to_string
    (    request: clt$convert_to_string_request;
     VAR work_area {input, output} : ^clt$work_area;
     VAR data_representation: ^clt$data_representation;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$convert_to_string_request
*copyc clt$data_representation
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$INTERNAL_CRE_FILE_CONNECT EXPAND=FALSE

  PROCEDURE [XREF] clp$internal_cre_file_connect
    (    subject_file: fst$path_handle_name;
         target_file: fst$path_handle_name;
         open_position: fst$open_position;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$open_position
*copyc fst$path_handle_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$INTERNAL_DELETE_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] clp$internal_delete_variable
    (    name: ost$name;
         allowed_classes: clt$internal_variable_classes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$internal_variable_classes
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$INTERNAL_DEL_ALL_TARGETS EXPAND=FALSE

  PROCEDURE [XREF] clp$internal_del_all_targets
    (    subject_file: amt$local_file_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$INTERNAL_DEL_FILE_CONNECT EXPAND=FALSE

  PROCEDURE [XREF] clp$internal_del_file_connect
    (    subject_file: amt$local_file_name;
         target_file: amt$local_file_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$INTERNAL_EVALUATE_EXPR EXPAND=FALSE

  PROCEDURE [XREF] clp$internal_evaluate_expr
    (VAR parse {input, output} : clt$parse_state;
         type_description: ^clt$type_description;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result_type_description: ^clt$type_description;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$parse_state
*copyc clt$type_description
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$INTERNAL_EVALUATE_PARAMS EXPAND=FALSE

  PROCEDURE [XREF] clp$internal_evaluate_params
    (    evaluation_context: clt$parameter_eval_context;
         pdt: clt$unbundled_pdt;
         check_parameters_procedure: clt$check_parameters_procedure;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
         pvt: ^clt$parameter_value_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$check_parameters_procedure
*copyc clt$parameter_eval_context
*copyc clt$parameter_value_table
*copyc clt$parse_state
*copyc clt$unbundled_pdt
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$INTERNAL_EVALUATE_SUB_PARAM EXPAND=FALSE

  PROCEDURE [XREF] clp$internal_evaluate_sub_param
    (VAR parse {input} : clt$parse_state;
         parameter_description_table: ^clt$parameter_description_table;
     VAR work_area {input, output} : ^clt$work_area;
         parameter_value_table: ^clt$parameter_value_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_description_table
*copyc clt$parameter_value_table
*copyc clt$parse_state
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$INTERNAL_GENERATE_OLD_PDT EXPAND=FALSE

  PROCEDURE [XREF] clp$internal_generate_old_pdt
    (    proc_or_pdt: ost$name_reference;
         get_line: clt$internal_input_procedure;
     VAR work_area {input, output} : ^clt$work_area;
     VAR parse {input, output} : clt$parse_state;
     VAR proc_name_area: SEQ ( * );
     VAR parameter_name_area: SEQ ( * );
     VAR parameter_area: SEQ ( * );
     VAR symbolic_parameter_area: SEQ ( * );
     VAR extra_info_area: SEQ ( * );
     VAR proc_names: ^clt$proc_names;
     VAR pdt: clt$parameter_descriptor_table;
     VAR symbolic_parameters: ^clt$symbolic_parameters;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$internal_input_procedure
*copyc clt$parameter_descriptor_table
*copyc clt$parse_state
*copyc clt$proc_names
*copyc clt$symbolic_parameters
*copyc clt$work_area
*copyc ost$name_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$INTERNAL_GENERATE_PDT EXPAND=FALSE

  PROCEDURE [XREF] clp$internal_generate_pdt
    (    command_or_function: clt$command_or_function;
         get_line: clt$internal_input_procedure;
         symbolic_qualifiers_area: ^clt$work_area;
     VAR work_area {input, output} : ^clt$work_area;
     VAR parse {input, output} : clt$parse_state;
     VAR command_or_function_name: pmt$program_name;
     VAR aliases: ^array [1 .. * ] of pmt$program_name;
     VAR availability: clt$named_entry_availability;
     VAR command_or_function_scope: clt$command_or_function_scope;
     VAR command_log_option: clt$command_log_option;
     VAR parameter_description_table: ^clt$parameter_description_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_log_option
*copyc clt$command_or_function
*copyc clt$command_or_function_scope
*copyc clt$internal_input_procedure
*copyc clt$named_entry_availability
*copyc clt$parameter_description_table
*copyc clt$parse_state
*copyc clt$work_area
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=CLP$INTERNAL_GEN_TYPE_SPEC EXPAND=FALSE

  PROCEDURE [XREF] clp$internal_gen_type_spec
    (    type_name: clt$type_name;
         unspecified_type_allowed: boolean;
         get_line: clt$internal_input_procedure;
         symbolic_qualifiers_area: ^clt$work_area;
     VAR work_area {input, output} : ^clt$work_area;
     VAR parse {input, output} : clt$parse_state;
     VAR type_specification: ^clt$type_specification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$internal_input_procedure
*copyc clt$parse_state
*copyc clt$type_name
*copyc clt$type_specification
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$INTERPRET_COMMANDS EXPAND=FALSE

  PROCEDURE [XREF] clp$interpret_commands;

*DECK DECK=CLP$ISOLATE_APPLICATION_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$isolate_application_value
    (    balance_brackets: boolean;
         text: clt$string_value;
         start_index: clt$string_index;
     VAR end_index: clt$string_index);

?? PUSH (LISTEXT := ON) ??

    VAR
      found_char: boolean,
      nesting_level: integer,
      scan_index: integer,
      text_index: clt$string_index;


    text_index := start_index;
    nesting_level := 0;
    found_char := TRUE;

  /scan_loop/
    WHILE found_char AND (text_index <= STRLENGTH (text)) DO
      #SCAN (clv$isolate_application_value, text (text_index, * ), scan_index,
            found_char);
      text_index := scan_index + text_index - 1;
      IF found_char THEN
        CASE text (text_index) OF
        = '"' =
          IF nesting_level <= 0 THEN
            EXIT /scan_loop/;
          IFEND;
          #SCAN (clv$comment_delimiter, text (text_index + 1, * ), scan_index,
                found_char);
          text_index := scan_index + text_index + $INTEGER (found_char);
        = '''' =
          #SCAN (clv$string_delimiter, text (text_index + 1, * ), scan_index,
                found_char);
          text_index := scan_index + text_index + $INTEGER (found_char);
        = '(' =
          nesting_level := nesting_level + 1;
          text_index := text_index + 1;
        = ')' =
          IF nesting_level <= 0 THEN
            EXIT /scan_loop/;
          IFEND;
          nesting_level := nesting_level - 1;
          text_index := text_index + 1;
        = '[', '{' =
          IF balance_brackets THEN
            nesting_level := nesting_level + 1;
          IFEND;
          text_index := text_index + 1;
        = ']', '}' =
          IF balance_brackets THEN
            IF nesting_level <= 0 THEN
              EXIT /scan_loop/;
            IFEND;
            nesting_level := nesting_level - 1;
          IFEND;
          text_index := text_index + 1;
        = $CHAR (9) {HT} , ' ', ',', ';' =
          IF nesting_level <= 0 THEN
            EXIT /scan_loop/;
          IFEND;
          text_index := text_index + 1;
        = '.' =
          IF (text_index < STRLENGTH (text)) AND (text (text_index + 1) =
                '.') THEN
            IF nesting_level <= 0 THEN
              EXIT /scan_loop/;
            IFEND;
            text_index := text_index + 2;
          ELSE
            text_index := text_index + 1;
          IFEND;
        ELSE
          text_index := text_index + 1;
        CASEND;
      IFEND;
    WHILEND /scan_loop/;
    end_index := text_index;

  PROCEND clp$isolate_application_value;

*copyc clt$string_index
*copyc clt$string_value
?? POP ??
*copyc clv$comment_delimiter
*copyc clv$isolate_application_value
*copyc clv$string_delimiter
*DECK DECK=CLP$ISOLATE_BALANCED_TEXT EXPAND=FALSE

  PROCEDURE [INLINE] clp$isolate_balanced_text
    (    text: clt$command_line;
         start_index: clt$command_line_index;
     VAR end_index: clt$command_line_index);

?? PUSH (LISTEXT := ON) ??

    VAR
      found_char: boolean,
      nesting_level: integer,
      scan_index: integer,
      text_index: clt$command_line_index;

    text_index := start_index;
    nesting_level := 0;
    found_char := TRUE;

  /scan_loop/
    WHILE found_char AND (text_index <= STRLENGTH (text)) DO
      #SCAN (clv$isolate_balanced_text, text (text_index, * ), scan_index,
            found_char);
      text_index := scan_index + text_index - 1;
      IF found_char THEN
        CASE text (text_index) OF
        = '"' =
          IF nesting_level <= 0 THEN
            EXIT /scan_loop/;
          IFEND;
          #SCAN (clv$comment_delimiter, text (text_index + 1, * ), scan_index,
                found_char);
          text_index := scan_index + text_index + $INTEGER (found_char);
        = '''' =
          #SCAN (clv$string_delimiter, text (text_index + 1, * ), scan_index,
                found_char);
          text_index := scan_index + text_index + $INTEGER (found_char);
        = '(' =
          nesting_level := nesting_level + 1;
          text_index := text_index + 1;
        = ')' =
          IF nesting_level <= 0 THEN
            EXIT /scan_loop/;
          IFEND;
          nesting_level := nesting_level - 1;
          text_index := text_index + 1;
        = $CHAR (9) {HT} , ' ', ',', ';' =
          IF nesting_level <= 0 THEN
            EXIT /scan_loop/;
          IFEND;
          text_index := text_index + 1;
        ELSE
          text_index := text_index + 1;
        CASEND;
      IFEND;
    WHILEND /scan_loop/;
    end_index := text_index;

  PROCEND clp$isolate_balanced_text;

*copyc clt$command_line
*copyc clt$command_line_index
?? POP ??
*copyc clv$comment_delimiter
*copyc clv$isolate_balanced_text
*copyc clv$string_delimiter
*DECK DECK=CLP$ISOLATE_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] clp$isolate_command
    (    text: clt$command_line;
         start_index: clt$command_line_index;
     VAR end_index: clt$command_line_index);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc clt$command_line_index
?? POP ??
*DECK DECK=CLP$ISOLATE_TEXT_VIA_SEPARATOR EXPAND=FALSE

  PROCEDURE [INLINE] clp$isolate_text_via_separator
    (    mode: clt$ibt_modes;
         text: clt$command_line;
         start_index: clt$command_line_index;
     VAR end_index: clt$command_line_index);

?? PUSH (LISTEXT := ON) ??

    VAR
      found_char: boolean,
      nesting_level: integer,
      scan_index: integer,
      text_index: clt$command_line_index;

    text_index := start_index;
    nesting_level := 0;
    found_char := TRUE;

  /scan_loop/
    WHILE found_char AND (text_index <= STRLENGTH (text)) DO
      #SCAN (clv$isolate_balanced_text, text (text_index, * ), scan_index,
            found_char);
      text_index := scan_index + text_index - 1;
      IF found_char THEN
        CASE text (text_index) OF
        = '"' =
          IF nesting_level <= 0 THEN
            EXIT /scan_loop/;
          IFEND;
          #SCAN (clv$comment_delimiter, text (text_index + 1, * ), scan_index,
                found_char);
          text_index := scan_index + text_index + $INTEGER (found_char);
        = '''' =
          #SCAN (clv$string_delimiter, text (text_index + 1, * ), scan_index,
                found_char);
          text_index := scan_index + text_index + $INTEGER (found_char);
        = '(' =
          nesting_level := nesting_level + 1;
          text_index := text_index + 1;
        = ')' =
          IF nesting_level <= 0 THEN
            EXIT /scan_loop/;
          IFEND;
          nesting_level := nesting_level - 1;
          text_index := text_index + 1;
          IF (mode = clc$ibt_stop_on_balanced) AND (nesting_level = 0) THEN
            EXIT /scan_loop/;
          IFEND;
        = $CHAR (9) {HT} , ' ', ',', ';' =
          IF nesting_level <= 0 THEN
            EXIT /scan_loop/;
          IFEND;
          text_index := text_index + 1;
        = '.' =
          IF (text_index < STRLENGTH (text)) AND (text (text_index + 1) =
                '.') THEN
            IF nesting_level <= 0 THEN
              EXIT /scan_loop/;
            IFEND;
            text_index := text_index + 2;
          ELSE
            text_index := text_index + 1;
          IFEND;
        = '=', '<', '>' =
          IF (mode = clc$ibt_stop_on_relational) AND (nesting_level <= 0) THEN
            EXIT /scan_loop/;
          IFEND;
          text_index := text_index + 1;
        ELSE
          text_index := text_index + 1;
        CASEND;
      IFEND;
    WHILEND /scan_loop/;
    end_index := text_index;

  PROCEND clp$isolate_text_via_separator;

*copyc clt$command_line
*copyc clt$command_line_index
*copyc clt$ibt_modes
?? POP ??
*copyc clv$comment_delimiter
*copyc clv$isolate_balanced_text
*copyc clv$string_delimiter
*DECK DECK=CLP$ITOD EXPAND=FALSE

  FUNCTION [XREF] clp$itod
    (    left: integer;
         right: longreal): longreal;

*DECK DECK=CLP$ITOI EXPAND=FALSE

  FUNCTION [XREF] clp$itoi
    (    left: integer;
         right: integer): integer;

*DECK DECK=CLP$I_CONVERT_STRING_TO_INTEGER EXPAND=FALSE

  PROCEDURE [XREF] clp$i_convert_string_to_integer
    (    str: string ( * );
         default_radix: 2 .. 16;
     VAR int: clt$integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$integer
*copyc ost$status
?? POP ??
*DECK DECK=CLP$JOB_BOOT EXPAND=FALSE
  PROCEDURE [XREF] clp$job_boot;
*DECK DECK=CLP$LAYOUT_DATA_LINE EXPAND=FALSE

  PROCEDURE [INLINE] clp$layout_data_line
*IF NOT $true(osv$unix)
    (    local_file_name: amt$local_file_name;
*ELSE
    (    local_file_name: fst$path;
*IFEND
         transfer_count: amt$transfer_count,
         line_layout: clt$line_layout;
         line_area: ^SEQ ( * );
     VAR line: ^clt$command_line;
     VAR line_identifier: clt$line_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      line_area_ptr: ^SEQ ( * ),
      remaining_count: amt$transfer_count,
      element_size: clt$line_element_size,
      text_ptr: ^clt$command_line,
      line_number_ptr: ^string ( * <= amc$max_line_number),
      statement_identifier_ptr: ^string ( * <= amc$max_statement_id_length),
      first_space: boolean,
      j: 1 .. clc$max_line_element_size,
      i: 1 .. 3;

    status.normal := TRUE;
    line_area_ptr := line_area;
    RESET line_area_ptr;

    remaining_count := transfer_count;
    text_ptr := NIL;
    line_number_ptr := NIL;
    statement_identifier_ptr := NIL;

  /extract_line_elements/
    FOR i := 1 TO 3 DO
      IF remaining_count <= 0 THEN
        EXIT /extract_line_elements/;
      IFEND;
      element_size := line_layout.element [i].size;
      IF remaining_count < element_size THEN
        element_size := remaining_count;
      IFEND;
      CASE line_layout.element [i].kind OF
      = clc$null_line_element =
        EXIT /extract_line_elements/;
      = clc$text_line_element =
        NEXT text_ptr: [element_size] IN line_area_ptr;
      = clc$line_number_line_element =
        NEXT line_number_ptr: [element_size] IN line_area_ptr;
      = clc$statement_id_line_element =
        NEXT statement_identifier_ptr: [element_size] IN line_area_ptr;
      CASEND;
      remaining_count := remaining_count - element_size;
    FOREND /extract_line_elements/;

    IF text_ptr = NIL THEN
      RESET line_area_ptr;
      NEXT line: [0] IN line_area_ptr;
    ELSE
      element_size := STRLENGTH (text_ptr^);
      WHILE (element_size > 0) AND (text_ptr^ (element_size) = ' ') DO
        element_size := element_size - 1;
      WHILEND;
      IF element_size > clc$max_command_line_size THEN
*IF NOT $true(osv$unix)
        osp$set_status_abnormal ('CL', cle$line_too_long, local_file_name,
              status);
*ELSE
        osp$set_status_abnormal ('CL', cle$line_too_long, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, local_file_name,
              status);
*IFEND
        RETURN;
      IFEND;
      line := ^text_ptr^ (1, element_size);
    IFEND;

    line_identifier.line_number_size := 0;
    IF line_number_ptr <> NIL THEN
      FOR j := 1 TO STRLENGTH (line_number_ptr^) DO
        CASE line_number_ptr^ (j) OF
        = '!' .. '~' =
          line_identifier.line_number_size :=
                line_identifier.line_number_size + 1;
          line_identifier.line_number (line_identifier.line_number_size) :=
                line_number_ptr^ (j);
        = ' ' =
          ;
        ELSE
          line_identifier.line_number_size :=
                line_identifier.line_number_size + 1;
          line_identifier.line_number (line_identifier.line_number_size) :=
                '?';
        CASEND;
      FOREND;
    IFEND;

    line_identifier.statement_identifier_size := 0;
    IF statement_identifier_ptr <> NIL THEN
      first_space := TRUE;
      FOR j := 1 TO STRLENGTH (statement_identifier_ptr^) DO
        CASE statement_identifier_ptr^ (j) OF
        = '!' .. '~' =
          line_identifier.statement_identifier_size :=
                line_identifier.statement_identifier_size + 1;
          line_identifier.statement_identifier
                (line_identifier.statement_identifier_size) :=
                statement_identifier_ptr^ (j);
        = ' ' =
          IF first_space THEN
            line_identifier.statement_identifier_size :=
                  line_identifier.statement_identifier_size + 1;
            line_identifier.statement_identifier
                  (line_identifier.statement_identifier_size) := '.';
            first_space := FALSE;
          IFEND;
        ELSE
          line_identifier.statement_identifier_size :=
                line_identifier.statement_identifier_size + 1;
          line_identifier.statement_identifier
                (line_identifier.statement_identifier_size) := '?';
        CASEND;
      FOREND;
    IFEND;

  PROCEND clp$layout_data_line;
*copyc amt$file_byte_address
*IF NOT $true(osv$unix)
*copyc amt$local_file_name
*ELSE
*copyc fst$path
*IFEND
*copyc amt$transfer_count
*copyc cle$ecc_command_processing
*copyc clt$command_line
*copyc clt$line_identifier
*copyc clt$line_layout
*copyc ost$status
?? POP ??
*IF $true(osv$unix)
*copyc osp$append_status_file
*IFEND
*copyc osp$set_status_abnormal
*DECK DECK=CLP$LIST_VALUE_COMPARE EXPAND=FALSE

  FUNCTION [XREF, UNSAFE] clp$list_value_compare
    (    left_value: ^clt$data_value;
         right_value: ^clt$data_value): clt$comparison_result;

?? PUSH (LISTEXT := ON) ??
*copyc clt$comparison_result
*copyc clt$data_value
?? POP ??
*DECK DECK=CLP$LOAD_FROM_LIBRARY EXPAND=FALSE

  PROCEDURE [XREF] clp$load_from_library
    (    name: pmt$program_name;
         kind: pmt$loaded_address_kind;
         local_file_name: amt$local_file_name;
     VAR loaded_address: pmt$loaded_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ost$status
*copyc pmt$loaded_address
*copyc pmt$program_name
?? POP ??
*DECK DECK=CLP$LOAD_SYSTEM_ENTRY_POINT EXPAND=FALSE

  PROCEDURE [XREF] clp$load_system_entry_point
    (    name: pmt$program_name;
         kind: pmt$loaded_address_kind;
     VAR loaded_address: pmt$loaded_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$loaded_address
*copyc pmt$program_name
?? POP ??

*DECK DECK=CLP$LOCAL_QUEUE_FAP EXPAND=FALSE

  PROCEDURE [XREF] clp$local_queue_fap
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
?? POP ??
*DECK DECK=CLP$LOGIN EXPAND=FALSE

  PROCEDURE [XREF] clp$login
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$LOGIN_COMMAND_RING_3 EXPAND=FALSE

  PROCEDURE [XREF] clp$login_command_ring_3
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$LOG_AND_OR_ECHO_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] clp$log_and_or_echo_command
    (    edited_parameter_list_text: clt$parameter_list_text;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list_text
*copyc ost$status
?? POP ??
*DECK DECK=CLP$LOG_COMMAND_LINE EXPAND=FALSE

  PROCEDURE [XREF] clp$log_command_line
    (    line: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$LOG_COMMENT EXPAND=FALSE

  PROCEDURE [XREF] clp$log_comment
    (    message: string ( * );
         log_name_selections: array [ * ] of ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$LOG_EDITED_LOGIN_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] clp$log_edited_login_command
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$LONGREAL_ADD EXPAND=FALSE
*DECK DECK=CLP$LONGREAL_CLASSIFY EXPAND=FALSE

  FUNCTION [INLINE] clp$longreal_classify
    (    real_number: longreal): clt$real_number_class;

?? PUSH (LISTEXT := ON) ??

    VAR
*IF NOT $true(osv$unix)
      breakdown: clt$longreal_breakdown,
      check: 0 .. 0f(16);
*ELSE
      breakdown: clt$longreal_breakdown;
*IFEND


    #UNCHECKED_CONVERSION (real_number, breakdown);

*IF $true(osv$unix)

    IF breakdown.exponent = 0 THEN
      clp$longreal_classify := clc$real_zero;
    ELSEIF breakdown.exponent = UPPERVALUE (breakdown.exponent) THEN
      IF (breakdown.fraction_1 = 0) AND
            (breakdown.fraction_2 = 0) THEN
        IF breakdown.sign = 0 THEN
          clp$longreal_classify := clc$real_positive_infinite;
        ELSE
          clp$longreal_classify := clc$real_negative_standard;
        IFEND;
      ELSE
        clp$longreal_classify := clc$real_indefinite;
      IFEND;
    ELSEIF breakdown.sign = 0 THEN
      clp$longreal_classify := clc$real_positive_standard;
    ELSE
      clp$longreal_classify := clc$real_negative_standard;
    IFEND;

*ELSE

    check := breakdown.first.exponent DIV 1000(16);

    CASE check OF
    = 0(16) .. 2(16), 8(16) .. 0a(16) =
      clp$longreal_classify := clc$real_zero;
    = 3(16) .. 4(16) =
      clp$longreal_classify := clc$real_positive_standard;
    = 0b(16) .. 0c(16) =
      clp$longreal_classify := clc$real_negative_standard;
    = 5(16) .. 6(16) =
      clp$longreal_classify := clc$real_positive_infinite;
    = 0d(16) .. 0e(16) =
      clp$longreal_classify := clc$real_negative_infinite;
    = 7(16), 0f(16) =
      clp$longreal_classify := clc$real_indefinite;
    CASEND;

*IFEND

  FUNCEND clp$longreal_classify;

*copyc clt$longreal_breakdown
*copyc clt$real_number_class
?? POP ??
*DECK DECK=CLP$LONGREAL_COMPARE EXPAND=FALSE

  FUNCTION [INLINE] clp$longreal_compare
    (    left_operand: longreal;
         right_operand: longreal;
         same_sign_infinities_order: clt$same_sign_infinities_order):
        clt$comparison_result;

?? PUSH (LISTEXT := ON) ??

    VAR
      comparison_result: clt$comparison_result,
      ignore_comparison_status: mlt$error,
      left_class: clt$real_number_class,
      right_class: clt$real_number_class;


    left_class := clp$longreal_classify (left_operand);
    right_class := clp$longreal_classify (right_operand);

    IF (left_class = clc$real_indefinite) OR
          (right_class = clc$real_indefinite) THEN
      comparison_result := clc$unordered;
    ELSEIF left_class > right_class THEN
      comparison_result := clc$left_is_greater;
    ELSEIF right_class > left_class THEN
      comparison_result := clc$right_is_greater;
    ELSE
      CASE left_class {and right_class} OF
      = clc$real_zero =
        comparison_result := clc$equal;
      = clc$real_positive_infinite, clc$real_negative_infinite =
        IF same_sign_infinities_order = clc$infinities_equal THEN
          comparison_result := clc$equal;
        ELSE
          comparison_result := clc$unordered;
        IFEND;
      ELSE
        mlp$compare_floating (^left_operand, mlc$double_precision,
              ^right_operand, mlc$double_precision, comparison_result,
              ignore_comparison_status);
      CASEND;
    IFEND;

    clp$longreal_compare := comparison_result;

  FUNCEND clp$longreal_compare;

*copyc clt$comparison_result
*copyc clt$real_number_classes
*copyc clt$same_sign_infinities_order
?? POP ??
*copyc clp$longreal_classify
*copyc mlp$compare_floating
*DECK DECK=CLP$LONGREAL_COMPARE_EQ EXPAND=FALSE

  FUNCTION [INLINE] clp$longreal_compare_eq
    (    left_operand: longreal;
         right_operand: longreal): boolean;

?? PUSH (LISTEXT := ON) ??

    clp$longreal_compare_eq := clp$longreal_compare
          (left_operand, right_operand, clc$infinities_equal) = clc$equal;

  FUNCEND clp$longreal_compare_eq;

?? POP ??
*copyc clp$longreal_compare
*DECK DECK=CLP$LONGREAL_COMPARE_GE EXPAND=FALSE

  FUNCTION [INLINE] clp$longreal_compare_ge
    (    left_operand: longreal;
         right_operand: longreal): boolean;

?? PUSH (LISTEXT := ON) ??

    clp$longreal_compare_ge := clp$longreal_compare
          (left_operand, right_operand, clc$infinities_equal) IN
          $clt$comparison_results [clc$left_is_greater, clc$equal];

  FUNCEND clp$longreal_compare_ge;

*copyc clt$comparison_results
?? POP ??
*copyc clp$longreal_compare
*DECK DECK=CLP$LONGREAL_COMPARE_GT EXPAND=FALSE

  FUNCTION [INLINE] clp$longreal_compare_gt
    (    left_operand: longreal;
         right_operand: longreal): boolean;

?? PUSH (LISTEXT := ON) ??

    clp$longreal_compare_gt := clp$longreal_compare
          (left_operand, right_operand, clc$infinities_equal) =
          clc$left_is_greater;

  FUNCEND clp$longreal_compare_gt;

?? POP ??
*copyc clp$longreal_compare
*DECK DECK=CLP$LONGREAL_COMPARE_LE EXPAND=FALSE

  FUNCTION [INLINE] clp$longreal_compare_le
    (    left_operand: longreal;
         right_operand: longreal): boolean;

?? PUSH (LISTEXT := ON) ??

    clp$longreal_compare_le := clp$longreal_compare
          (left_operand, right_operand, clc$infinities_equal) IN
          $clt$comparison_results [clc$right_is_greater, clc$equal];

  FUNCEND clp$longreal_compare_le;

*copyc clt$comparison_results
?? POP ??
*copyc clp$longreal_compare
*DECK DECK=CLP$LONGREAL_COMPARE_LT EXPAND=FALSE

  FUNCTION [INLINE] clp$longreal_compare_lt
    (    left_operand: longreal;
         right_operand: longreal): boolean;

?? PUSH (LISTEXT := ON) ??

    clp$longreal_compare_lt := clp$longreal_compare
          (left_operand, right_operand, clc$infinities_equal) =
          clc$right_is_greater;

  FUNCEND clp$longreal_compare_lt;

?? POP ??
*copyc clp$longreal_compare
*DECK DECK=CLP$LONGREAL_COMPARE_NE EXPAND=FALSE

  FUNCTION [INLINE] clp$longreal_compare_ne
    (    left_operand: longreal;
         right_operand: longreal): boolean;

?? PUSH (LISTEXT := ON) ??

    clp$longreal_compare_ne := clp$longreal_compare
          (left_operand, right_operand, clc$infinities_equal) IN
          $clt$comparison_results [clc$left_is_greater, clc$right_is_greater];

  FUNCEND clp$longreal_compare_ne;

*copyc clt$comparison_results
?? POP ??
*copyc clp$longreal_compare
*DECK DECK=CLP$LONGREAL_DIVIDE EXPAND=FALSE
*DECK DECK=CLP$LONGREAL_MULTIPLY EXPAND=FALSE
*DECK DECK=CLP$LONGREAL_SUBTRACT EXPAND=FALSE
*DECK DECK=CLP$MAKE_APPLICATION_CLT$VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_application_clt$value
    (    application_value_text: clt$application_value_text;
     VAR value: clt$value);

    VAR
      application_value: ^clt$application_value,
      text: ^string (*);

    clp$make_clt$value (clc$application_value, value);
    application_value := ^value.application;
    NEXT text: [#SIZE(clt$application_value)] IN application_value;
    text^ := application_value_text;

  PROCEND clp$make_application_clt$value;

?? PUSH (LISTEXT := ON) ??
*copyc clt$application_value
*copyc clt$application_value_text
*copyc cld$value
?? POP ??
*copyc clp$make_clt$value
*DECK DECK=CLP$MAKE_APPLICATION_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_application_value
    (    application_value: clt$application_value_text;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$application, work_area, value);
    IF value <> NIL THEN
      NEXT value^.application_value: [STRLENGTH (application_value)] IN
            work_area;
      IF value^.application_value <> NIL THEN
        value^.application_value^ := application_value;
        RETURN;
      IFEND;
      RESET work_area TO value;
      value := NIL;
    IFEND;

  PROCEND clp$make_application_value;

*copyc clt$application_value_text
*copyc clt$data_value
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_ARRAY_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_array_value
    (    lower_bound: clt$array_bound;
         upper_bound: clt$array_bound;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$array, work_area, value);
    IF value <> NIL THEN
      NEXT value^.array_value: [lower_bound .. upper_bound] IN work_area;
      IF value^.array_value <> NIL THEN
        RETURN;
      IFEND;
      RESET work_area TO value;
      value := NIL;
    IFEND;

  PROCEND clp$make_array_value;

*copyc clt$array_bound
*copyc clt$data_value
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_BOOLEAN_CLT$VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_boolean_clt$value
    (    bool: clt$boolean;
     VAR value: clt$value);


    clp$make_clt$value (clc$boolean_value, value);
    value.bool.value := bool.value;
    value.bool.kind := bool.kind;

  PROCEND clp$make_boolean_clt$value;

?? PUSH (LISTEXT := ON) ??
*copyc clt$boolean
*copyc cld$value
?? POP ??
*copyc clp$make_clt$value
*DECK DECK=CLP$MAKE_BOOLEAN_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_boolean_value
    (    bool: boolean;
         kind: clt$boolean_kinds;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$boolean, work_area, value);
    IF value <> NIL THEN
      value^.boolean_value.value := bool;
      value^.boolean_value.kind := kind;
    IFEND;

  PROCEND clp$make_boolean_value;

*copyc clt$boolean
*copyc clt$data_value
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_CHAR_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_char_value
    (    ch: char;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$string, work_area, value);
    IF value <> NIL THEN
      NEXT value^.string_value: [1] IN work_area;
      IF value^.string_value <> NIL THEN
        value^.string_value^ (1) := ch;
        RETURN;
      IFEND;
      RESET work_area TO value;
      value := NIL;
    IFEND;

  PROCEND clp$make_char_value;

*copyc clt$data_value
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_CLT$BOOLEAN_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_clt$boolean_value
    (    bool: clt$boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$boolean, work_area, value);
    IF value <> NIL THEN
      value^.boolean_value := bool;
    IFEND;

  PROCEND clp$make_clt$boolean_value;

*copyc clt$boolean
*copyc clt$data_value
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_CLT$INTEGER_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_clt$integer_value
    (    int: clt$integer;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$integer, work_area, value);
    IF value <> NIL THEN
      value^.integer_value := int;
    IFEND;

  PROCEND clp$make_clt$integer_value;

*copyc clt$data_value
*copyc clt$integer
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_CLT$NUMBER_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_clt$number_value
    (    number: clt$number;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    VAR
      value_kind: clt$data_kind;


    IF number.kind = clc$integer_number THEN
      value_kind := clc$integer;
    ELSE
      value_kind := clc$real;
    IFEND;
    clp$make_value (value_kind, work_area, value);
    IF value <> NIL THEN
      IF value^.kind = clc$integer THEN
        value^.integer_value := number.integer_number;
      ELSE
        value^.real_value := number.real_number;
      IFEND;
    IFEND;

  PROCEND clp$make_clt$number_value;

*copyc clt$data_value
*copyc clt$number
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_CLT$REAL_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_clt$real_value
    (    real_number: clt$real;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$real, work_area, value);
    IF value <> NIL THEN
      value^.real_value := real_number;
    IFEND;

  PROCEND clp$make_clt$real_value;

*copyc clt$data_value
*copyc clt$real
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_CLT$VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_clt$value
    (    kind: clc$unknown_value .. clc$status_value;
     VAR value: clt$value);


      IF kind = clc$unknown_value THEN
        value.descriptor := 'UNKNOWN';
      ELSEIF kind = clc$application_value THEN
        value.descriptor := 'APPLICATION';
      ELSE
        value.descriptor := clv$value_descriptors [kind];
      IFEND;
      value.kind := kind;

  PROCEND clp$make_clt$value;

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc clv$value_descriptors
*copyc clt$value_kinds
?? POP ??
*DECK DECK=CLP$MAKE_COBOL_NAME_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_cobol_name_value
    (    cobol_name: clt$cobol_name_reference;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$cobol_name, work_area, value);
    IF value <> NIL THEN
      #TRANSLATE (osv$lower_to_upper, cobol_name, value^.cobol_name_value);
    IFEND;

  PROCEND clp$make_cobol_name_value;

*copyc clt$cobol_name_reference
*copyc clt$data_value
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*copyc osv$lower_to_upper
*DECK DECK=CLP$MAKE_COMMAND_REF_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_command_ref_value
    (    command_reference: ^clt$command_reference;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$command_reference, work_area, value);
    IF value <> NIL THEN
      NEXT value^.command_reference_value IN work_area;
      IF value^.command_reference_value <> NIL THEN
        value^.command_reference_value^ := command_reference^;
        RETURN;
      IFEND;
      RESET work_area TO value;
      value := NIL;
    IFEND;

  PROCEND clp$make_command_ref_value;

*copyc clt$command_reference
*copyc clt$data_value
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_DATA_NAME_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_data_name_value
    (    data_name: ost$name_reference;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$data_name, work_area, value);
    IF value <> NIL THEN
      #TRANSLATE (osv$lower_to_upper, data_name, value^.data_name_value);
    IFEND;

  PROCEND clp$make_data_name_value;

*copyc clt$data_value
*copyc clt$work_area
*copyc ost$name_reference
?? POP ??
*copyc clp$make_value
*copyc osv$lower_to_upper
*DECK DECK=CLP$MAKE_DATE_TIME_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_date_time_value
    (    date_time: clt$date_time;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$date_time, work_area, value);
    IF value <> NIL THEN
      value^.date_time_value := date_time;
    IFEND;

  PROCEND clp$make_date_time_value;

*copyc clt$data_value
*copyc clt$date_time
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_DEFERRED_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_deferred_value
    (    deferred_value: clt$expression_text;
         deferred_type: ^clt$type_specification;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$deferred, work_area, value);
    IF value <> NIL THEN
      NEXT value^.deferred_value: [STRLENGTH (deferred_value)] IN work_area;
      IF value^.deferred_value <> NIL THEN
        value^.deferred_value^ := deferred_value;
        IF deferred_type = NIL THEN
          value^.deferred_type := NIL;
          RETURN;
        IFEND;
        NEXT value^.deferred_type: [[REP #SIZE (deferred_type^) OF cell]] IN
              work_area;
        IF value^.deferred_type <> NIL THEN
          value^.deferred_type^ := deferred_type^;
          RETURN;
        IFEND;
      IFEND;
      RESET work_area TO value;
      value := NIL;
    IFEND;

  PROCEND clp$make_deferred_value;

*copyc clt$data_value
*copyc clt$expression_text
*copyc clt$type_specification
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_ENTRY_POINT_REF_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_entry_point_ref_value
    (    entry_point: ost$name_reference;
         object_library: fst$file_reference;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$entry_point_reference, work_area, value);
    IF value <> NIL THEN
      NEXT value^.entry_point_reference_value IN work_area;
      IF value^.entry_point_reference_value <> NIL THEN
        value^.entry_point_reference_value^.entry_point := entry_point;
        value^.entry_point_reference_value^.object_library := object_library;
        RETURN;
      IFEND;
      RESET work_area TO value;
      value := NIL;
    IFEND;

  PROCEND clp$make_entry_point_ref_value;

*copyc clt$data_value
*copyc clt$work_area
*copyc fst$file_reference
*copyc ost$name_reference
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_FILE_CLT$VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_file_clt$value
    (    file_reference: fst$file_reference;
     VAR value: clt$value);


    clp$make_clt$value (clc$file_value, value);
    value.file.local_file_name := file_reference;

  PROCEND clp$make_file_clt$value;

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc fst$file_reference
?? POP ??
*copyc clp$make_clt$value
*DECK DECK=CLP$MAKE_FILE_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_file_value
    (    file: fst$file_reference;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)

    VAR
      size: fst$path_size;


    clp$make_value (clc$file, work_area, value);
*ELSE
    clp$make_a_file_value (clc$file, file, work_area, value);
*IFEND
*IF NOT $true(osv$unix)
    IF value <> NIL THEN
      size := STRLENGTH (file);
      WHILE (size > 0) AND (file (size) = ' ') DO
        size := size - 1;
      WHILEND;
      NEXT value^.file_value: [size] IN work_area;
      IF value^.file_value <> NIL THEN
        value^.file_value^ (1, size) := file (1, size);
        RETURN;
      IFEND;
      RESET work_area TO value;
      value := NIL;
    IFEND;
*IFEND

  PROCEND clp$make_file_value;

*copyc clt$data_value
*copyc clt$work_area
*copyc fst$file_reference
*IF NOT $true(osv$unix)
*copyc fst$path_size
*IFEND
?? POP ??
*IF NOT $true(osv$unix)
*copyc clp$make_value
*ELSE
*copyc clp$make_a_file_value
*IFEND
*DECK DECK=CLP$MAKE_INTEGER_CLT$VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_integer_clt$value
    (    int: clt$integer;
     VAR value: clt$value);


    clp$make_clt$value (clc$integer_value, value);
    value.int := int;

  PROCEND clp$make_integer_clt$value;

?? PUSH (LISTEXT := ON) ??
*copyc clt$integer
*copyc cld$value
?? POP ??
*copyc clp$make_clt$value
*DECK DECK=CLP$MAKE_INTEGER_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_integer_value
    (    int: integer;
         radix: 2 .. 16;
         radix_specified: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$integer, work_area, value);
    IF value <> NIL THEN
      value^.integer_value.value := int;
      value^.integer_value.radix := radix;
      value^.integer_value.radix_specified := radix_specified;
    IFEND;

  PROCEND clp$make_integer_value;

*copyc clt$data_value
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_KEYWORD_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_keyword_value
    (    keyword: clt$keyword_reference;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$keyword, work_area, value);
    IF value <> NIL THEN
      value^.keyword_value := keyword;
    IFEND;

  PROCEND clp$make_keyword_value;

*copyc clt$data_value
*copyc clt$keyword_reference
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_LIST_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_list_value
    (VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$list, work_area, value);
    IF value <> NIL THEN
      value^.element_value := NIL;
      value^.link := NIL;
      value^.generated_via_list_rest := FALSE;
    IFEND;

  PROCEND clp$make_list_value;

*copyc clt$data_value
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_LOCK_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_lock_value
    (    lock: ^clt$lock;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$lock, work_area, value);
    IF value <> NIL THEN
      NEXT value^.lock_value IN work_area;
      IF value^.lock_value <> NIL THEN
        value^.lock_value^ := lock^;
        RETURN;
      IFEND;
      RESET work_area TO value;
      value := NIL;
    IFEND;

  PROCEND clp$make_lock_value;

*copyc clt$data_value
*copyc clt$lock
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_NAME_CLT$VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_name_clt$value
    (    name: ost$name;
         name_size: ost$name_size;
     VAR value: clt$value);


    clp$make_clt$value (clc$name_value, value);
    value.name.size := name_size;
    value.name.value := name;

  PROCEND clp$make_name_clt$value;

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc ost$name
?? POP ??
*copyc clp$make_clt$value
*DECK DECK=CLP$MAKE_NAME_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_name_value
    (    name: ost$name_reference;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$name, work_area, value);
    IF value <> NIL THEN
      #TRANSLATE (osv$lower_to_upper, name, value^.name_value);
    IFEND;

  PROCEND clp$make_name_value;

*copyc clt$data_value
*copyc clt$work_area
*copyc ost$name_reference
?? POP ??
*copyc clp$make_value
*copyc osv$lower_to_upper
*DECK DECK=CLP$MAKE_NETWORK_TITLE_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_network_title_value
    (    network_title: nat$title;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$network_title, work_area, value);
    IF value <> NIL THEN
      NEXT value^.network_title_value: [STRLENGTH (network_title)] IN
            work_area;
      IF value^.network_title_value <> NIL THEN
        value^.network_title_value^ := network_title;
        RETURN;
      IFEND;
      RESET work_area TO value;
      value := NIL;
    IFEND;

  PROCEND clp$make_network_title_value;

*copyc clt$data_value
*copyc clt$work_area
*copyc nat$title
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_PROGRAM_NAME_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_program_name_value
    (    program_name: ost$name_reference;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$program_name, work_area, value);
    IF value <> NIL THEN
      value^.program_name_value := program_name;
    IFEND;

  PROCEND clp$make_program_name_value;

*copyc clt$data_value
*copyc clt$work_area
*copyc ost$name_reference
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_RANGE_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_range_value
    (VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$range, work_area, value);
    IF value <> NIL THEN
      value^.low_value := NIL;
      value^.high_value := NIL;
    IFEND;

  PROCEND clp$make_range_value;

*copyc clt$data_value
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_REAL_CLT$VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_real_clt$value
    (    real_value: clt$real;
     VAR value: clt$value);


    clp$make_clt$value (clc$real_value, value);
    value.rnum := real_value;

  PROCEND clp$make_real_clt$value;

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
?? POP ??
*copyc clp$make_clt$value
*DECK DECK=CLP$MAKE_REAL_VALUE EXPAND=FALSE

*IF NOT $true(osv$unix)
{ Clp$make_real_value is intended to be an INLINE procedure but cannot be
{ at present because of a CYBIL problem.

  PROCEDURE {INLINE} clp$make_real_value
*ELSE
  PROCEDURE [INLINE] clp$make_real_value
*IFEND
    (    real_number: longreal;
         number_of_digits: clt$real_number_digit_count;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$real, work_area, value);
    IF value <> NIL THEN
*IF NOT $true(osv$unix)
      #UNCHECKED_CONVERSION (real_number, value^.real_value.value);
*ELSE
      value^.real_value.value := real_number;
*IFEND
      value^.real_value.number_of_digits := number_of_digits;
    IFEND;

  PROCEND clp$make_real_value;

*copyc clt$data_value
*copyc clt$real_number_digit_count
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_RECORD_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_record_value
    (    number_of_fields: clt$field_number;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$record, work_area, value);
    IF value <> NIL THEN
      NEXT value^.field_values: [1 .. number_of_fields] IN work_area;
      IF value^.field_values <> NIL THEN
        RETURN;
      IFEND;
      RESET work_area TO value;
      value := NIL;
    IFEND;

  PROCEND clp$make_record_value;

*copyc clt$data_value
*copyc clt$field_number
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_SCU_LINE_ID_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_scu_line_id_value
    (    scu_line_identifier: clt$scu_line_identifier;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$scu_line_identifier, work_area, value);
    IF value <> NIL THEN
      value^.scu_line_identifier_value := scu_line_identifier;
    IFEND;

  PROCEND clp$make_scu_line_id_value;

*copyc clt$data_value
*copyc clt$scu_line_identifier
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_SIZED_STRING_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_sized_string_value
    (    size: clt$string_size;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$string, work_area, value);
    IF value <> NIL THEN
      NEXT value^.string_value: [size] IN work_area;
      IF value^.string_value <> NIL THEN
        RETURN;
      IFEND;
      RESET work_area TO value;
      value := NIL;
    IFEND;

  PROCEND clp$make_sized_string_value;

*copyc clt$data_value
*copyc clt$string_size
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_STATISTIC_CODE_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_statistic_code_value
    (    statistic_code: sft$statistic_code;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$statistic_code, work_area, value);
    IF value <> NIL THEN
      value^.statistic_code_value := statistic_code;
    IFEND;

  PROCEND clp$make_statistic_code_value;

*copyc clt$data_value
*copyc clt$work_area
*copyc sfd$type_declarations
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_STATUS_CLT$VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_status_clt$value
    (    status: ost$status;
     VAR value: clt$value);


    clp$make_clt$value (clc$status_value, value);
    value.status := status;

  PROCEND clp$make_status_clt$value;

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*copyc clp$make_clt$value
*DECK DECK=CLP$MAKE_STATUS_CODE_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_status_code_value
    (    status_code: ost$status_condition_code;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$status_code, work_area, value);
    IF value <> NIL THEN
      value^.status_code_value := status_code;
    IFEND;

  PROCEND clp$make_status_code_value;

*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status_condition_code
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_STATUS_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_status_value
    (    status_value: ost$status;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$status, work_area, value);
    IF value <> NIL THEN
      NEXT value^.status_value IN work_area;
      IF value^.status_value <> NIL THEN
        value^.status_value^ := status_value;
        RETURN;
      IFEND;
      RESET work_area TO value;
      value := NIL;
    IFEND;

  PROCEND clp$make_status_value;

*copyc clt$data_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_STRING_PATTERN_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_string_pattern_value
    (    string_pattern: clt$string_pattern;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$string_pattern, work_area, value);
    IF value <> NIL THEN
      NEXT value^.string_pattern_value: [[REP #SIZE (string_pattern) OF
            cell]] IN work_area;
      IF value^.string_pattern_value <> NIL THEN
        value^.string_pattern_value^ := string_pattern;
        RETURN;
      IFEND;
      RESET work_area TO value;
      value := NIL;
    IFEND;

  PROCEND clp$make_string_pattern_value;

*copyc clt$data_value
*copyc clt$string_pattern
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_STRING_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_string_value
    (    str: clt$string_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$string, work_area, value);
    IF value <> NIL THEN
      NEXT value^.string_value: [STRLENGTH (str)] IN work_area;
      IF value^.string_value <> NIL THEN
        value^.string_value^ := str;
        RETURN;
      IFEND;
      RESET work_area TO value;
      value := NIL;
    IFEND;

  PROCEND clp$make_string_value;

*copyc clt$data_value
*copyc clt$string_value
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_TIME_INCREMENT_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_time_increment_value
    (    time_increment: ^pmt$time_increment;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$time_increment, work_area, value);
    IF value <> NIL THEN
      NEXT value^.time_increment_value IN work_area;
      IF value^.time_increment_value <> NIL THEN
        value^.time_increment_value^ := time_increment^;
        RETURN;
      IFEND;
      RESET work_area TO value;
      value := NIL;
    IFEND;

  PROCEND clp$make_time_increment_value;

*copyc clt$data_value
*copyc clt$work_area
*copyc pmt$time_increment
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_TIME_ZONE_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_time_zone_value
    (    time_zone: ost$time_zone;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$time_zone, work_area, value);
    IF value <> NIL THEN
      value^.time_zone_value := time_zone;
    IFEND;

  PROCEND clp$make_time_zone_value;

*copyc clt$data_value
*copyc clt$work_area
*copyc ost$time_zone
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_TRIMMED_STRING_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_trimmed_string_value
    (    str: clt$string_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$string, work_area, value);
    IF value <> NIL THEN
      NEXT value^.string_value: [clp$trimmed_string_size (str)] IN work_area;
      IF value^.string_value <> NIL THEN
        value^.string_value^ := str;
        RETURN;
      IFEND;
      RESET work_area TO value;
      value := NIL;
    IFEND;

  PROCEND clp$make_trimmed_string_value;

*copyc clt$data_value
*copyc clt$string_value
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*copyc clp$trimmed_string_size
*DECK DECK=CLP$MAKE_TYPE_SPEC_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_type_spec_value
    (    type_specification: ^clt$type_specification;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$type_specification, work_area, value);
    IF value <> NIL THEN
      value^.type_specification_value := type_specification;
    IFEND;

  PROCEND clp$make_type_spec_value;

*copyc clt$data_value
*copyc clt$type_specification
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_UNSPECIFIED_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_unspecified_value
    (VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    clp$make_value (clc$unspecified, work_area, value);

  PROCEND clp$make_unspecified_value;

*copyc clt$data_value
*copyc clt$work_area
?? POP ??
*copyc clp$make_value
*DECK DECK=CLP$MAKE_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] clp$make_value
    (    kind: clt$data_kind;
     VAR work_area {input, output} : ^clt$work_area;
     VAR value: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??

    NEXT value IN work_area;
    IF value <> NIL THEN
      value^.kind := kind;
    IFEND;

  PROCEND clp$make_value;

*copyc clt$data_value
*copyc clt$data_kind
*copyc clt$type_name
*copyc clt$work_area
?? POP ??
*DECK DECK=CLP$MATCH_STRING_PATTERN EXPAND=FALSE

  PROCEDURE [XREF] clp$match_string_pattern
    (    subject: clt$string_value;
         pattern: ^clt$string_pattern;
         anchor_option: clt$string_pattern_anchor_opt;
         scan_option: clt$string_pattern_scan_option;
     VAR match_info: clt$string_pattern_match_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$string_pattern
*copyc clt$string_pattern_anchor_opt
*copyc clt$string_pattern_match_info
*copyc clt$string_pattern_scan_option
*copyc clt$string_value
*copyc ost$status
?? POP ??
*DECK DECK=CLP$NEW_DISPLAY_LINE EXPAND=FALSE

  PROCEDURE [XREF] clp$new_display_line
    (VAR display_control {input, output} : clt$display_control;
         skip_count: clt$new_display_line_skip;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=CLP$NEW_DISPLAY_PAGE EXPAND=FALSE

  PROCEDURE [XREF] clp$new_display_page
    (VAR display_control {input, output} : clt$display_control;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=CLP$NEW_PAGE_PROCEDURE EXPAND=FALSE
?? TITLE := '    clp$new_page_procedure', EJECT ??

*copyc clp$right_justify_string

  PROCEDURE clp$new_page_procedure
    (VAR display_control: clt$display_control;
         new_page_number: integer;
     VAR status: ost$status);

    CONST
      max_page_chars = 10;

    VAR
      ignore_status: ost$status,
      str: ost$string,
      page_and_number: string (max_page_chars),
      page_number_length: integer;

    clp$reset_for_next_display_page (display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF display_control.page_width < clc$narrow_page_width THEN
      clv$page_width := clc$narrow_page_width;
    ELSE
      clv$page_width := display_control.page_width;
    IFEND;
    clv$wide := clv$page_width >= clc$wide_page_width;
    clp$convert_integer_to_string (new_page_number, 10, FALSE, str,
          ignore_status);
    IF NOT clv$titles_built THEN
      clp$build_standard_title (clv$wide, clv$command_name, clv$wide_title,
            clv$narrow_title1, clv$narrow_title2, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clv$titles_built := TRUE;
    IFEND;
    page_and_number := '';
    STRINGREP (page_and_number, page_number_length, 'PAGE', new_page_number);
    IF display_control.include_format_effectors THEN
      clp$right_justify_string (page_and_number);
    IFEND;


    IF clv$wide THEN
      clv$wide_title (123, 10) := page_and_number;
      clp$put_display (display_control, clv$wide_title, clc$trim, status);
    ELSE
      clv$narrow_title1 (70, 10) := page_and_number;
      clp$put_display (display_control, clv$narrow_title1, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_display (display_control, clv$narrow_title2, clc$trim, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    put_subtitle (display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 1, status);

  PROCEND clp$new_page_procedure;
*DECK DECK=CLP$NEXT_LIST_ELEMENT EXPAND=FALSE

  FUNCTION [INLINE] clp$next_list_element
    (    current_list_node: ^clt$data_value): ^clt$data_value;

?? PUSH (LISTEXT := ON) ??

    VAR
      next_list_node: ^clt$data_value;


    next_list_node := current_list_node^.link;
    WHILE (next_list_node <> NIL) AND (next_list_node^.kind = clc$list) DO
      IF next_list_node^.element_value <> NIL THEN
        clp$next_list_element := next_list_node;
        RETURN;
      IFEND;
      next_list_node := next_list_node^.link;
    WHILEND;
    clp$next_list_element := NIL;

  FUNCEND clp$next_list_element;

*copyc clt$data_value
?? POP ??
*DECK DECK=CLP$NOTIFY_BEFORE_COMMAND_READ EXPAND=FALSE

  PROCEDURE [XREF] clp$notify_before_command_read
    (    notification_procedure: ^procedure
           (VAR status: ost$status));

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$NUMBER_COMPARE EXPAND=FALSE

  FUNCTION [XREF] clp$number_compare
    (    left_operand: clt$data_value;
         right_operand: clt$data_value): clt$comparison_result;

?? PUSH (LISTEXT := ON) ??
*copyc clt$comparison_result
*copyc clt$data_value
?? POP ??
*DECK DECK=CLP$OBTAIN_VARIABLE_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$obtain_variable_value
    (    name: clt$variable_name;
         variable_access_handle: ^clt$variable_access_handle;
         access_variable_requests: clt$access_variable_requests;
     VAR work_area {input, output} : ^clt$work_area;
     VAR qualified_type_description {input, output} : ^clt$type_description;
     VAR parse_value_qualifiers {input, output} : ^clt$value_qualifiers;
     VAR parse_value_qualifiers_index: integer;
     VAR value: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$access_variable_requests
*copyc clt$data_value
*copyc clt$type_description
*copyc clt$variable_access_handle
*copyc clt$variable_name
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$ONLY_VALIDATE_NAME EXPAND=FALSE

  PROCEDURE [INLINE] clp$only_validate_name
    (    potential_name: string ( * <= osc$max_name_size);
     VAR name_is_valid: boolean);

?? PUSH (LISTEXT := ON) ??
{ When a change is made to this routine, a corresponding change should be
{ made to clp$validate_name if necessary.

    TYPE
      char_set = set of char;

    VAR
      ignore_scan_found_char: boolean,
      non_name_chars: char_set,
      scan_index: 1 .. osc$max_name_size + 1;

    CASE potential_name (1) OF
    = '#', '$', '@', 'A' .. 'Z', 'a' .. 'z', '[', '\', ']', '^', '_', '`', '{',
          '|', '}', '~' =
      non_name_chars := -$char_set ['#', '$', '0', '1', '2', '3', '4', '5',
            '6', '7', '8', '9', '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H',
            'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U',
            'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h',
            'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u',
            'v', 'w', 'x', 'y', 'z', '[', '\', ']', '^', '_', '`', '{', '|',
            '}', '~'];
      #SCAN (non_name_chars, potential_name, scan_index,
            ignore_scan_found_char);
      name_is_valid := potential_name (scan_index, * ) = '';
    ELSE
      name_is_valid := FALSE;
    CASEND;

  PROCEND clp$only_validate_name;

*copyc ost$name
?? POP ??
*copyc osv$lower_to_upper
*DECK DECK=CLP$OPEN_COMMAND_FILE EXPAND=FALSE

{
{ The access modes are passed in by the parameter, file_access_modes.
{ Share mode and open share mode are always set to (read, execute).
{ Create file attachment option is always set to FALSE.
{

  PROCEDURE [INLINE] clp$open_command_file
    (    file_reference: fst$file_reference;
*IF NOT $true(osv$unix)
         job_mode: jmt$job_mode;
*IFEND
         access_level: amc$record .. amc$segment;
         file_access_modes: clt$command_file_access_modes;
         attribute_validation: ^fst$file_cycle_attributes;
*IF NOT $true(osv$unix)
         allowed_device_classes: fst$device_classes;
*IFEND
     VAR file_id: amt$file_identifier;
     VAR sequence: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
*IF NOT $true(osv$unix)
      file_creation_attributes: array [1 .. 1] of fst$file_cycle_attribute,
      creation_attributes: ^fst$file_cycle_attributes,
      file_attr_override: array [1 .. 2] of fst$file_cycle_attribute,
      attribute_override: ^fst$file_cycle_attributes,
*IFEND
      file_attachment: ^fst$attachment_options,
      number_of_file_access_modes: integer,
      attachment_index: integer,
*IF NOT $true(osv$unix)
      segment: amt$segment_pointer,
*IFEND
      ignore_status: ost$status;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, 0, clk$open_command_file);
*IFEND

    status.normal := TRUE;


*IF NOT $true(osv$unix)
{ The second selector for file_attr_override is determined later.

    IF access_level = amc$record THEN
      file_attr_override [1].selector := fsc$file_organization;
      file_attr_override [1].file_organization := amc$byte_addressable;
      attribute_override := ^file_attr_override;
    ELSE
      attribute_override := NIL;
    IFEND;
*IFEND

    number_of_file_access_modes := UPPERBOUND (file_access_modes);
    PUSH file_attachment: [1 .. (number_of_file_access_modes + 5)];

    FOR attachment_index := 1 TO number_of_file_access_modes DO
      IF file_access_modes [attachment_index] = $fst$file_access_options
            [] THEN
        file_attachment^ [attachment_index].selector :=
              fsc$null_attachment_option;
      ELSE
        file_attachment^ [attachment_index].selector :=
              fsc$access_and_share_modes;
        file_attachment^ [attachment_index].access_modes.selector :=
              fsc$specific_access_modes;
        file_attachment^ [attachment_index].access_modes.value :=
              file_access_modes [attachment_index];
        file_attachment^ [attachment_index].share_modes.selector :=
              fsc$specific_share_modes;
        file_attachment^ [attachment_index].share_modes.value :=
              $fst$file_access_options [fsc$read, fsc$execute];
      IFEND;
    FOREND;

    attachment_index := number_of_file_access_modes + 1;
    file_attachment^ [attachment_index].selector := fsc$create_file;
    file_attachment^ [attachment_index].create_file := FALSE;
    attachment_index := attachment_index + 1;
    file_attachment^ [attachment_index].selector := fsc$open_share_modes;
    file_attachment^ [attachment_index].open_share_modes :=
          $fst$file_access_options [fsc$read, fsc$execute];
    attachment_index := attachment_index + 1;

*IF NOT $true(osv$unix)
    IF file_reference = clv$standard_files [clc$sf_command_file].
          path_handle_name THEN
      IF job_mode = jmc$batch THEN
        file_attr_override [2].selector := fsc$ring_attributes;
        file_attr_override [2].ring_attributes.r1 := osc$tsrv_ring;
        file_attr_override [2].ring_attributes.r2 := osc$user_ring_2;
        file_attr_override [2].ring_attributes.r3 := osc$user_ring_2;
        creation_attributes := NIL;
      ELSE
        file_creation_attributes [1].selector := fsc$ring_attributes;
        file_creation_attributes [1].ring_attributes.r1 := osc$user_ring_2;
        file_creation_attributes [1].ring_attributes.r2 := osc$user_ring_2;
        file_creation_attributes [1].ring_attributes.r3 := osc$user_ring_2;
        creation_attributes := ^file_creation_attributes;
        file_attr_override [2].selector := fsc$null_attribute;
      IFEND;

      file_attachment^ [attachment_index].selector := fsc$open_position;
      file_attachment^ [attachment_index].open_position :=
            amc$open_no_positioning;
      attachment_index := attachment_index + 1;

{  Attaching COMMAND without private_read prevents coordination
{  problems when more than 1 include_file of COMMAND is active
{  at the same time.

      file_attachment^ [attachment_index].selector := fsc$private_read;
      file_attachment^ [attachment_index].private_read := FALSE;
      attachment_index := attachment_index + 1;

    ELSE
      creation_attributes := NIL;
      file_attr_override [2].selector := fsc$null_attribute;
*IFEND
      file_attachment^ [attachment_index].selector :=
            fsc$null_attachment_option;
      attachment_index := attachment_index + 1;
      file_attachment^ [attachment_index].selector := fsc$null_attachment_option;
      attachment_index := attachment_index + 1;
*IF NOT $true(osv$unix)
    IFEND;

    file_attachment^ [attachment_index].selector := fsc$allowed_device_classes;
    file_attachment^ [attachment_index].allowed_device_classes := allowed_device_classes;
*ELSE
    file_attachment^ [attachment_index].selector := fsc$null_attachment_option;
*IFEND

  /open_command_file/
    BEGIN
      fsp$open_file (file_reference, access_level, file_attachment,
*IF NOT $true(osv$unix)
            creation_attributes, NIL, attribute_validation, attribute_override,
*IFEND
            file_id, status);
      IF NOT status.normal THEN
*IF NOT $true(osv$unix)
        CASE status.condition OF
        = ame$no_permission_for_access, fse$redundant_attach_conflict,
          fse$concurrent_access_conflict, pfe$usage_not_permitted =
          osp$set_status_abnormal ('CL', cle$command_file_not_executable, '', status);
          osp$append_status_file (osc$status_parameter_delimiter, file_reference, status);
        = ame$ring_validation_error =
          osp$set_status_abnormal ('CL', cle$command_file_not_callable, '', status);
          osp$append_status_file (osc$status_parameter_delimiter, file_reference, status);
        ELSE
          ;
        CASEND;
*IFEND
        EXIT /open_command_file/;
      IFEND;

*IF NOT $true(osv$unix)
      IF access_level = amc$segment THEN
        amp$get_segment_pointer (file_id, amc$sequence_pointer, segment,
              status);
        IF NOT status.normal THEN
          fsp$close_file (file_id, ignore_status);
          EXIT /open_command_file/;
        IFEND;
        sequence := segment.sequence_pointer;
      ELSE
*IFEND
        sequence := NIL;
*IF NOT $true(osv$unix)
      IFEND;
*IFEND
    END /open_command_file/;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, 0, clk$open_command_file);
*IFEND

  PROCEND clp$open_command_file;

*copyc amt$file_identifier
*copyc fst$file_reference
*copyc clc$standard_file_names
*copyc cle$ecc_command_processing
*IF NOT $true(osv$unix)
*copyc clk$procedure_keypoints
*IFEND
*copyc clt$command_file_access_modes
*IF NOT $true(osv$unix)
*copyc fst$device_classes
*IFEND
*copyc fst$file_cycle_attributes
*IF NOT $true(osv$unix)
*copyc jmt$job_mode
*IFEND
*copyc ost$status
?? POP ??
*IF NOT $true(osv$unix)
*copyc amp$get_segment_pointer
*copyc clv$standard_files
*IFEND
*copyc fsp$close_file
*copyc fsp$open_file
*IF NOT $true(osv$unix)
*copyc osp$append_status_file
*IFEND
*copyc osp$set_status_abnormal
*DECK DECK=CLP$OPEN_COMMAND_LIBRARY EXPAND=FALSE

  PROCEDURE [XREF] clp$open_command_library
    (    caller_ring: ost$valid_ring;
         local_file_name: amt$local_file_name;
     VAR library_list_entry: ^clt$command_library_list_entry;
     VAR validated_file_name: fst$path_handle_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_list
*copyc fst$path_handle_name
*copyc ost$caller_identifier
*copyc ost$status
?? POP ??
*DECK DECK=CLP$OPEN_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] clp$open_display
    (    file: clt$file;
         new_page_procedure: clt$new_display_page_procedure;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc clt$file
*copyc ost$status
?? POP ??
*DECK DECK=CLP$OPEN_DISPLAY_FILE EXPAND=FALSE

  PROCEDURE [XREF] clp$open_display_file
    (    file: clt$file;
         new_page_procedure: clt$new_display_page_procedure;
*IF NOT $true(osv$unix)
         default_file_contents: amt$file_contents;
         default_ring_attributes: amt$ring_attributes;
*IFEND
     VAR display_control: clt$display_control;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc amd$file_contents
*copyc amt$ring_attributes
*IFEND
*copyc clt$display_control
*copyc clt$file
*IF NOT $true(osv$unix)
*copyc fsc$file_contents
*IFEND
*copyc ost$status
?? POP ??
*DECK DECK=CLP$OPEN_DISPLAY_REFERENCE EXPAND=FALSE

  PROCEDURE [XREF] clp$open_display_reference
    (    file: fst$file_reference;
         new_page_procedure: clt$new_display_page_procedure;
         default_file_contents: amt$file_contents;
*IF NOT $true(osv$unix)
         default_ring_attributes: amt$ring_attributes;
*IFEND
     VAR display_control: clt$display_control;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_contents
*IF NOT $true(osv$unix)
*copyc amt$ring_attributes
*IFEND
*copyc clt$display_control
*IF NOT $true(osv$unix)
*copyc fsc$file_contents
*IFEND
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$OPEN_EXECUTABLE_CMND_FILE EXPAND=FALSE

  PROCEDURE [XREF] clp$open_executable_cmnd_file
    (    file_reference: fst$file_reference;
         job_mode: jmt$job_mode;
         access_level: amc$record .. amc$segment;
         file_access_modes: clt$command_file_access_modes;
         attribute_validation: ^fst$file_cycle_attributes;
     VAR file_id: amt$file_identifier;
     VAR sequence: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amd$open_declarations
*copyc amt$file_identifier
*copyc clt$command_file_access_modes
*copyc fst$file_cycle_attributes
*copyc fst$file_reference
*copyc jmt$job_mode
*copyc ost$status
?? POP ??
*DECK DECK=CLP$OPERATOR_INTERVENTION EXPAND=FALSE

  PROCEDURE [XREF] clp$operator_intervention
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PARSE_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] clp$parse_command
    (VAR parse {input, output} : clt$parse_state;
     VAR prompting_requested: boolean;
     VAR escaped: boolean;
     VAR label: ost$name;
     VAR command_reference_parse: clt$parse_state;
     VAR file: clt$file;
     VAR form: clt$command_reference_form;
     VAR name: clt$name;
     VAR utility_command_list_entry: ^clt$command_list_entry;
     VAR separator: clt$lexical_unit_kind;
     VAR empty_command: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_list
*copyc clt$command_reference_form
*copyc clt$file
*copyc clt$lexical_unit_kind
*copyc clt$name
*copyc clt$parse_state
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PARSE_FILE_REFERENCE EXPAND=FALSE
*IF NOT $true(osv$unix)

  PROCEDURE [XREF] clp$parse_file_reference
    (VAR parse {input, output } : clt$parse_state;
     VAR path_parsed {output} : boolean;
     VAR evaluated_file_reference {output} : fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parse_state
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??
*IFEND
*DECK DECK=CLP$PARSE_JOB_INDEPENDENT_PATH EXPAND=FALSE

  PROCEDURE [XREF] clp$parse_job_independent_path
    (    path: fst$file_reference;
         user_identification: ost$user_identification;
         include_open_position: boolean;
     VAR parsed_path: fst$parsed_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc fst$parsed_file_reference
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=CLP$PASS_VARIABLE_PARAMETER EXPAND=FALSE

  PROCEDURE [XREF] clp$pass_variable_parameter
    (    parameter_number: clt$parameter_number;
         access_handle: clt$variable_access_handle;
         value_qualifiers: ^clt$value_qualifiers;
         variable_name: clt$variable_name;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_number
*copyc clt$value_qualifiers
*copyc clt$variable_access_handle
*copyc clt$variable_name
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PERFORM_NUMERIC_OPERATION EXPAND=FALSE

  PROCEDURE [XREF] clp$perform_numeric_operation
    (    operator: string ( * <= osc$max_name_size);
         left_operand: clt$data_value;
         right_operand: clt$data_value;
     VAR result: clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$POP_ALL_ENVIRONMENT EXPAND=FALSE

  PROCEDURE [XREF] clp$pop_all_environment
    (    pop_reason: clc$eo_pop_for_block .. clc$eo_pop_for_task;
         block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$env_object_pop_reason
?? POP ??
*DECK DECK=CLP$POP_BLOCK_STACK EXPAND=FALSE

  PROCEDURE [XREF] clp$pop_block_stack
    (VAR block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
?? POP ??
*DECK DECK=CLP$POP_COMMAND_LINE EXPAND=FALSE

  PROCEDURE [XREF] clp$pop_command_line;

*DECK DECK=CLP$POP_ENVIRONMENT EXPAND=FALSE

  PROCEDURE [XREF] clp$pop_environment
    (    object: clt$environment_object;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object
*copyc ost$status
?? POP ??
*DECK DECK=CLP$POP_INPUT EXPAND=FALSE

  PROCEDURE [XREF] clp$pop_input
    (    read_only: boolean;
         input_block_handle: clt$block_handle;
         file_id: amt$file_identifier;
         opened_executable_file: boolean;
         termination_status: ^ost$status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc clt$block_handle
*copyc clt$prompt_string
*copyc ost$status
?? POP ??
*DECK DECK=CLP$POP_INPUT_STACK EXPAND=FALSE

  PROCEDURE [XREF] clp$pop_input_stack
    (VAR block: ^clt$block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc ost$status
?? POP ??
*DECK DECK=CLP$POP_INTERACTIVE_INPUT EXPAND=FALSE

  PROCEDURE [XREF] clp$pop_interactive_input
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc ost$status
?? POP ??
*DECK DECK=CLP$POP_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] clp$pop_parameters
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$unexpected_call_to
*copyc ost$status
?? POP ??
*DECK DECK=CLP$POP_TERMINATED_BLOCKS EXPAND=FALSE

  PROCEDURE [XREF] clp$pop_terminated_blocks
    (    first_block_to_keep: ^clt$block;
     VAR status {input,output} : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc ost$status
?? POP ??
*DECK DECK=CLP$POP_UTILITY EXPAND=FALSE

{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     ****** This program interface is obsolete.  Modules presently    ******
{     ****** using it should be changed to use CLP$END_UTILITY.        ******
{     ***********************************************************************
{     ***********************************************************************
{

  PROCEDURE [XREF] clp$pop_utility
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PREPARE_DELAYED_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$prepare_delayed_block
    (    interpreter_mode: clt$interpreter_modes;
         begin_name: ost$name_reference;
         end_name: ost$name_reference;
         prompt_string: clt$prompt_string;
         first_line_to_write: clt$command_line;
         substitution_mark: clt$substitution_mark;
     VAR statement_area: ^clt$collect_statement_area;
     VAR can_be_echoed: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$collect_statement_area
*copyc clt$command_line
*copyc clt$interpreter_modes
*copyc clt$prompt_string
*copyc clt$substitution_mark
*copyc ost$name_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PREPARE_FOR_LOG_AND_OR_ECHO EXPAND=FALSE

  PROCEDURE [XREF] clp$prepare_for_log_and_or_echo
    (    command_reference_text: ^clt$command_line;
         pdt: ^clt$unbundled_pdt;
         pvt: ^clt$parameter_value_table;
     VAR work_area {input, output} : ^clt$work_area;
     VAR edited_command: ^clt$command_line);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc clt$parameter_value_table
*copyc clt$unbundled_pdt
*copyc clt$work_area
?? POP ??
*DECK DECK=CLP$PREPROCESS_COMMAND_LINE EXPAND=FALSE
  PROCEDURE [XREF] clp$preprocess_command_line
    (    line_preprocessor_descriptor: clt$utility_line_preproc_desc;
         line: ^clt$command_line;
         interactive_file: boolean;
     VAR edited_line: ^clt$command_line;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc clt$utility_line_preproc_desc
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PROCESS_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] clp$process_command
    (    block_at_start_of_command: ^clt$block;
         interpreter_mode: clt$interpreter_modes;
         command_from_job_command_file: boolean;
         command_from_execute_command: boolean;
         log_the_command: boolean;
         command_can_be_echoed: boolean;
         parse: clt$parse_state;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$interpreter_modes
*copyc clt$parse_state
*copyc clt$when_condition
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PROCESS_COMMAND_FAULT EXPAND=FALSE

  PROCEDURE [XREF] clp$process_command_fault
    (    condition_status: ost$status;
         input_block: ^clt$block;
     VAR retry_command: ^clt$command_line;
     VAR condition_processed_state: clt$condition_processed_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$command_line
*copyc clt$condition_processed_state
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PROCESS_COMMAND_FILE EXPAND=FALSE

  PROCEDURE [XREF] clp$process_command_file
    (    input_block: ^clt$block;
         handle_interactive_include: ^procedure;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PROCESS_CONTINUED_CONDITION EXPAND=FALSE

  PROCEDURE [XREF] clp$process_continued_condition
    (    when_block: ^clt$block;
         continue_when_condition_option: clt$condition_processed_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$condition_processed_state
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PROCESS_DELAYED_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$process_delayed_block
    (    utility_name: clt$utility_name;
         statement_area: ^clt$collect_statement_area;
         can_be_echoed: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$collect_statement_area
*copyc clt$utility_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PROCESS_EXECUTION_FAULT EXPAND=FALSE

  PROCEDURE [XREF] clp$process_execution_fault
    (    condition_status: ost$status;
         input_block: ^clt$block;
     VAR retry_command: ^clt$command_line;
     VAR condition_processed_state: clt$condition_processed_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$command_line
*copyc clt$condition_processed_state
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PROCESS_EXIT_CONDITION EXPAND=FALSE

  PROCEDURE [XREF] clp$process_exit_condition
    (    input_block: ^clt$block;
         exit_status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PROCESS_PROC_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] clp$process_proc_parameters
    (    command_or_function: clt$command_or_function;
         proc_data: ^clt$scl_procedure;
         header: ^clt$scl_procedure_header;
         can_be_echoed: boolean;
     VAR parameter_list_parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_or_function
*copyc clt$parse_state
*copyc clt$scl_procedure
*copyc clt$scl_procedure_header
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PROCESS_UTILITY_DEF_FILE EXPAND=FALSE

  PROCEDURE [XREF] clp$process_utility_def_file
    (    file_name: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PROCESS_WHEN_CONDITION EXPAND=FALSE
*DECK DECK=CLP$PROCESS_WHEN_COND_IN_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$process_when_cond_in_block
    (    condition_definition: clt$when_condition_definition;
         input_block: ^clt$block;
         exit_on_continue_condition: boolean;
     VAR condition_processed: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$when_condition_definition
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PROCESS_WHEN_COND_IN_TASK EXPAND=FALSE

  PROCEDURE [XREF] clp$process_when_cond_in_task
    (    condition_definition: clt$when_condition_definition;
         default_handler: ^procedure (VAR status: ost$status);
     VAR condition_processed: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$when_condition_definition
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PRODUCE_VARIABLE_REF_EXPR EXPAND=FALSE

  PROCEDURE [XREF] clp$produce_variable_ref_expr
    (    class: clt$internal_variable_class;
         name: clt$variable_name;
         value_qualifiers: ^clt$value_qualifiers;
     VAR work_area {input, output} : ^clt$work_area;
     VAR variable: ^clt$variable_ref_expression;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$internal_variable_class
*copyc clt$name
*copyc clt$value_qualifiers
*copyc clt$variable_name
*copyc clt$variable_ref_expression
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PUSH_ALL_ENVIRONMENT EXPAND=FALSE

  PROCEDURE [XREF] clp$push_all_environment
    (    child_task_block: ^clt$block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PUSH_BLOCK_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_block_block
    (    label: ost$name;
     VAR block_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc ost$name
?? POP ??
*DECK DECK=CLP$PUSH_CASE_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_case_block
    (    selection_value: ^clt$internal_data_value;
     VAR case_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$internal_data_value
?? POP ??
*DECK DECK=CLP$PUSH_CHECK_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_check_block
    (    parameter_name: clt$parameter_name;
     VAR check_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$parameter_name
?? POP ??
*DECK DECK=CLP$PUSH_COMMAND_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_command_block
    (    caller_ring: ost$valid_ring;
         command_name: clt$command_name;
         command_source: clt$command_or_function_source;
         command_logging_completed: boolean;
         command_echoing_completed: boolean;
         prompting_requested: boolean;
         command_kind: clt$command_kind;
         parameter_list_parse: clt$parse_state;
     VAR command_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$command_kind
*copyc clt$command_name
*copyc clt$command_or_function_source
*copyc clt$parse_state
*copyc osd$virtual_address
?? POP ??
*DECK DECK=CLP$PUSH_COMMAND_LINE EXPAND=FALSE

  PROCEDURE [XREF] clp$push_command_line
    (    line: ^clt$command_line;
         lexical_units: ^clt$lexical_units;
     VAR input_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$command_line
*copyc clt$lexical_units
?? POP ??
*DECK DECK=CLP$PUSH_COMMAND_PROC_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_command_proc_block
    (    caller_ring: ost$valid_ring;
         command_name: clt$command_name;
         command_source: clt$command_or_function_source;
         command_proc_logging_completed: boolean;
         command_proc_echoing_completed: boolean;
         prompting_requested: boolean;
         proc_can_be_echoed: boolean;
         file_name: fst$path_handle_name;
         file_id: amt$file_identifier;
         line_layout: clt$line_layout;
         proc_data: ^clt$input_data;
         proc_data_version: clt$declaration_version;
         device_class: rmt$device_class;
     VAR command_proc_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc clt$block
*copyc clt$command_name
*copyc clt$command_or_function_source
*copyc clt$declaration_version
*copyc clt$input_data
*copyc clt$line_layout
*copyc fst$path_handle_name
*copyc osd$virtual_address
*copyc rmt$device_class
?? POP ??
*DECK DECK=CLP$PUSH_DYNAMIC_COMMAND_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$push_dynamic_command_list
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PUSH_EDIT_PARAMETERS_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_edit_parameters_block
    (    max_string: clt$string_size;
     VAR edit_parameters_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$string_size
?? POP ??
*DECK DECK=CLP$PUSH_ENVIRONMENT EXPAND=FALSE

  PROCEDURE [XREF] clp$push_environment
    (    object: clt$environment_object;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PUSH_FOR_INCREMENTAL_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_for_incremental_block
    (    label: ost$name;
         variable: ^clt$variable_ref_expression;
         initial: clt$integer;
         limit: integer;
         increment: integer;
     VAR for_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$integer
*copyc clt$variable_ref_expression
*copyc ost$name
?? POP ??
*DECK DECK=CLP$PUSH_FOR_LIST_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_for_list_block
    (    label: ost$name;
         variable: ^clt$variable_ref_expression;
         list: ^clt$internal_data_value;
     VAR for_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$internal_data_value
*copyc clt$variable_ref_expression
*copyc ost$name
?? POP ??
*DECK DECK=CLP$PUSH_FUNCTION_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_function_block
    (    caller_ring: ost$valid_ring;
         function_name: ost$name;
         function_source: clt$command_or_function_source;
         parameter_list_parse: clt$parse_state;
         expected_result_type: ^clt$type_description;
     VAR function_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$command_or_function_source
*copyc clt$parse_state
*copyc clt$type_description
*copyc osd$virtual_address
*copyc ost$name
?? POP ??
*DECK DECK=CLP$PUSH_FUNCTION_PROC_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_function_proc_block
    (    caller_ring: ost$valid_ring;
         function_name: ost$name;
         function_source: clt$command_or_function_source;
         proc_can_be_echoed: boolean;
         file_name: fst$path_handle_name;
         file_id: amt$file_identifier;
         proc_data: ^clt$input_data;
         expected_result_type: ^clt$type_specification;
     VAR function_proc_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc clt$block
*copyc clt$command_or_function_source
*copyc clt$input_data
*copyc clt$type_specification
*copyc fst$path_handle_name
*copyc osd$virtual_address
*copyc ost$name
*copyc rmt$device_class
?? POP ??
*DECK DECK=CLP$PUSH_IF_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_if_block
    (    condition_met: boolean;
     VAR if_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
?? POP ??
*DECK DECK=CLP$PUSH_INPUT EXPAND=FALSE

  PROCEDURE [XREF] clp$push_input
    (    file: fst$file_reference;
         utility_name: clt$utility_name;
         prompt_string: clt$prompt_string;
         enable_echoing: boolean;
         read_only: boolean;
     VAR input_block_handle: clt$block_handle;
     VAR file_id: amt$file_identifier;
     VAR opened_executable_file: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc clt$block_handle
*copyc clt$prompt_string
*copyc clt$utility_name
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PUSH_INPUT_$COMMAND_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_input_$command_block
    (    inherited_input_block_offset: ost$segment_offset;
         utility_name: clt$utility_name;
         prompt_string: clt$prompt_string;
         file_id: amt$file_identifier;
         data: ^clt$input_data;
         input_can_be_echoed: boolean;
         inherited_input_in_current_task: boolean;
     VAR input_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc clt$block
*copyc clt$input_data
*copyc clt$prompt_string
*copyc clt$utility_name
*copyc osd$virtual_address
?? POP ??
*DECK DECK=CLP$PUSH_INPUT_FILE_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_input_file_block
*IF NOT $true(osv$unix)
    (    file_name: fst$path_handle_name;
*ELSE
    (    file_name: fst$path;
*IFEND
         file_id: amt$file_identifier;
         utility_name: clt$utility_name;
         prompt_string: clt$prompt_string;
         input_can_be_echoed: boolean;
         line_layout: clt$line_layout;
         device_class: rmt$device_class;
         file_has_fap: boolean;
         process_utility_end_include: boolean;
     VAR input_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc clt$block
*copyc clt$line_layout
*copyc clt$prompt_string
*copyc clt$utility_name
*IF NOT $true(osv$unix)
*copyc fst$path_handle_name
*ELSE
*copyc fst$path
*IFEND
*copyc rmt$device_class
?? POP ??
*DECK DECK=CLP$PUSH_INPUT_INTERNAL_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_input_internal_block
    (    utility_name: clt$utility_name;
         input_can_be_echoed: boolean;
         input_data: ^clt$input_data;
     VAR internal_input_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$input_data
*copyc clt$utility_name
?? POP ??
*DECK DECK=CLP$PUSH_INPUT_LINE_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_input_line_block
    (    utility_name: clt$utility_name;
         input_can_be_echoed: boolean;
         statement_list: ^clt$command_line;
         lexical_units: ^clt$lexical_units;
     VAR input_line_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$command_line
*copyc clt$lexical_units
*copyc clt$utility_name
?? POP ??
*DECK DECK=CLP$PUSH_INTERACTIVE_INPUT EXPAND=FALSE

  PROCEDURE [XREF] clp$push_interactive_input
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PUSH_LOOP_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_loop_block
    (    label: ost$name;
     VAR loop_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc ost$name
?? POP ??
*DECK DECK=CLP$PUSH_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] clp$push_parameters
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PUSH_REPEAT_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_repeat_block
    (    label: ost$name;
     VAR repeat_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc ost$name
?? POP ??
*DECK DECK=CLP$PUSH_SUB_PARAMETERS_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_sub_parameters_block
    (    lookup_functions_and_variables: boolean);

*DECK DECK=CLP$PUSH_UTILITY EXPAND=FALSE

{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     ****** This program interface is obsolete.  Modules presently    ******
{     ****** using it should be changed to use CLP$BEGIN_UTILITY.      ******
{     ***********************************************************************
{     ***********************************************************************
{

  PROCEDURE [XREF] clp$push_utility
    (    utility_name: ost$name;
         search_mode: clt$command_search_modes;
         commands: ^clt$command_table;
         functions: ^clt$function_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_utilities
*copyc clt$command_search_modes
*copyc clt$command_table
*copyc clt$function_table
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PUSH_UTILITY_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_utility_block
    (    utility_name: clt$utility_name;
     VAR utility_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$utility_name
?? POP ??
*DECK DECK=CLP$PUSH_WHEN_BLOCK EXPAND=FALSE
*DECK DECK=CLP$PUSH_WHEN_INPUT_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_when_input_block
    (    condition: clt$when_condition_definition;
         exit_on_continue_condition: boolean;
         default_handler: ^procedure (VAR status: ost$status);
         command: ^clt$command_line;
         command_name: clt$command_name;
         handler_statements: ^clt$established_handler_stmnts;
         static_link_handle: clt$block_handle;
     VAR when_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$block_handle
*copyc clt$command_line
*copyc clt$command_name
*copyc clt$established_handler_stmnts
*copyc clt$when_condition_definition
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PUSH_WHILE_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$push_while_block
    (    label: ost$name;
         condition: boolean;
         expression_parse: clt$parse_state;
     VAR while_block: ^clt$block);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc clt$parse_state
*copyc ost$name
?? POP ??
*DECK DECK=CLP$PUT_COMMAND_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] clp$put_command_parameters
    (VAR display_control {input, output} : clt$display_control;
         stand_alone_display: boolean;
         indentation: 0 .. amc$max_page_width;
         pdt: clt$parameter_descriptor_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amd$page_format_declarations
*copyc clt$display_control
*copyc clt$parameter_descriptor_table
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PUT_DATA_REPRESENTATION EXPAND=FALSE

  PROCEDURE [XREF] clp$put_data_representation
    (VAR display_control {input, output} : clt$display_control;
     VAR data_representation {input, output} : ^clt$data_representation;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_representation
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PUT_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] clp$put_display
    (VAR display_control {input, output} : clt$display_control;
         str: string ( * );
         trim_option: clt$trim_display_text_option;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PUT_ERROR_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] clp$put_error_output
    (    text: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PUT_JOB_COMMAND_RESPONSE EXPAND=FALSE

  PROCEDURE [XREF] clp$put_job_command_response
    (    text: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PUT_JOB_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] clp$put_job_output
    (    text: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PUT_OPEN_POS_IN_PATH_HANDLE EXPAND=FALSE

  PROCEDURE [INLINE] clp$put_open_pos_in_path_handle
    (    open_position: fst$open_position;
     VAR path_handle_name {input, output} : amt$local_file_name);

?? PUSH (LISTEXT := ON) ??

    IF open_position.specified THEN
      CASE open_position.value OF
      = amc$open_no_positioning =
        path_handle_name (5) := 'A';
      = amc$open_at_boi =
        path_handle_name (5) := 'B';
      = amc$open_at_eoi =
        path_handle_name (5) := 'E';
      CASEND;
    ELSE
      path_handle_name (5) := '_';
    IFEND;

  PROCEND clp$put_open_pos_in_path_handle;

*copyc amt$local_file_name
*copyc fst$open_position
?? POP ??
*DECK DECK=CLP$PUT_PARTIAL_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] clp$put_partial_display
    (VAR display_control {input, output} : clt$display_control;
         str: string ( * );
         trim_option: clt$trim_display_text_option;
         term_option: amt$term_option;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$term_option
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=CLP$PUT_PATH_REFERENCE_SUBTITLE EXPAND=FALSE
?? TITLE := 'clp$put_path_reference_subtitle', EJECT ??

  PROCEDURE clp$put_path_reference_subtitle
    (    path: fst$file_reference;
         header: string ( * );
     VAR status: ost$status);

    VAR
      header_length: ost$string_size,
      i: 1 .. fsc$max_path_elements,
      terminate_string: string (2);


    header_length := STRLENGTH (header) + 1;
    terminate_string := '..';

    IF NOT clv$subtitles_built THEN
      clv$path_display_string := path;
      clp$build_path_subtitle (clv$path_display_string,
            clp$trimmed_string_size (clv$path_display_string),
            (clv$page_width - header_length), clv$path_display_chunk_count,
            clv$path_display_chunks);
      clv$subtitles_built := TRUE;
    IFEND;

    FOR i := 1 TO clv$path_display_chunk_count DO
      IF i = 1 THEN
        clp$put_partial_display (display_control, header, clc$no_trim,
              amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        clp$horizontal_tab_display (display_control, header_length, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF i = clv$path_display_chunk_count THEN
        terminate_string := '  ';
      IFEND;
      clp$put_partial_display (display_control,
            clv$path_display_string (clv$path_display_chunks [i].position,
            clv$path_display_chunks [i].length), clc$trim, amc$continue,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_partial_display (display_control, terminate_string, clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND clp$put_path_reference_subtitle;
*DECK DECK=CLP$PUT_PATH_SUBTITLE EXPAND=FALSE
?? TITLE := 'clp$put_path_subtitle', EJECT ??

  PROCEDURE clp$put_path_subtitle
    (    file: clt$file;
         header: string ( * );
     VAR status: ost$status);


    IF NOT clv$subtitles_built THEN
      clp$get_path_name (file.local_file_name, osc$full_message_level,
            clv$path_display_string);
      clp$build_path_subtitle (clv$path_display_string,
            clp$trimmed_string_size (clv$path_display_string),
            (clv$page_width - STRLENGTH (header) - 1),
            clv$path_display_chunk_count, clv$path_display_chunks);
      clv$subtitles_built := TRUE;
    IFEND;

    clp$put_path_reference_subtitle ('', header, status);

  PROCEND clp$put_path_subtitle;
*copy clp$put_path_reference_subtitle
*DECK DECK=CLP$RANGE_VALUE_COMPARE EXPAND=FALSE

  FUNCTION [XREF, UNSAFE] clp$range_value_compare
    (    left_value: ^clt$data_value;
         right_value: ^clt$data_value): clt$comparison_result;

?? PUSH (LISTEXT := ON) ??
*copyc clt$comparison_result
*copyc clt$data_value
?? POP ??
*DECK DECK=CLP$READ_COMMAND_FILE EXPAND=FALSE

  PROCEDURE [XREF] clp$read_command_file
    (    file: fst$file_reference;
         utility: clt$utility_name;
         prompt: clt$prompt;
         enable_echoing: boolean;
         initial_command: ^clt$command_line;
         continue_after_initial_command: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc clt$prompt
*copyc clt$utility_name
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$READ_QUALIFIED_DATA_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$read_qualified_data_value
    (    name: clt$variable_name;
         access_variable_requests: clt$access_variable_requests;
         var_parameter_value_qualifiers: ^clt$value_qualifiers;
         internal_value: ^clt$internal_data_value;
     VAR data_value {input, output} : ^clt$data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR type_description {input, output} : ^clt$type_description;
     VAR parse_value_qualifiers {input, output} : ^clt$value_qualifiers;
     VAR parse_value_qualifier_index: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$access_variable_requests
*copyc clt$data_value
*copyc clt$internal_data_value
*copyc clt$type_description
*copyc clt$value_qualifiers
*copyc clt$variable_name
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$READ_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] clp$read_variable
    (    reference: string ( * );
     VAR variable: clt$variable_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$variable_reference
*copyc cle$ecc_variable
*copyc ost$status
?? POP ??
*DECK DECK=CLP$RECOGNIZE_COBOL_NAME EXPAND=FALSE

  PROCEDURE [INLINE] clp$recognize_cobol_name
    (    text: clt$string_value;
     VAR cobol_name_size: ost$name_size;
     VAR is_only_cobol_name: boolean;
     VAR is_cobol_name: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_scan_found_char: boolean,
      scan_index: integer;

    #SCAN (clv$non_cobol_name_char, text, scan_index, ignore_scan_found_char);
    IF (1 <= (scan_index - 1)) AND ((scan_index - 1) <=
          clc$max_cobol_name_size) AND (text (1) <> '-') AND
          (text (scan_index - 1) <> '-') THEN
      cobol_name_size := scan_index - 1;
      IF ('0' <= text (1)) AND (text (1) <= '9') THEN
        #SCAN (clv$letter_char, text (1, cobol_name_size), scan_index,
              is_cobol_name);
        is_only_cobol_name := is_cobol_name;
      ELSE
        is_cobol_name := TRUE;
        #SCAN (clv$non_letter_or_digit, text (1, cobol_name_size), scan_index,
              is_only_cobol_name);
      IFEND;
    ELSE
      is_cobol_name := FALSE;
      is_only_cobol_name := FALSE;
    IFEND;

  PROCEND clp$recognize_cobol_name;

*copyc clc$max_cobol_name_size
*copyc clt$string_value
*copyc ost$name
?? POP ??
*copyc clv$letter_char
*copyc clv$non_cobol_name_char
*copyc clv$non_letter_or_digit
*DECK DECK=CLP$RECOGNIZE_FORMAT_TOKENS EXPAND=FALSE

  PROCEDURE [XREF] clp$recognize_format_tokens
    (    action: boolean);

*DECK DECK=CLP$RECORD_APPLICATION_UNITS EXPAND=FALSE

  PROCEDURE [XREF] clp$record_application_units;

*DECK DECK=CLP$RECORD_CHILD_TASK EXPAND=FALSE

  PROCEDURE [XREF] clp$record_child_task
    (    caller_ring: ost$valid_ring;
         child_task_id: pmt$task_id;
         synchronous_with_parent: boolean;
         command_file: amt$local_file_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$task_id
?? POP ??
*DECK DECK=CLP$RECORD_VALUE_COMPARE EXPAND=FALSE

  FUNCTION [XREF, UNSAFE] clp$record_value_compare
    (    left_value: ^clt$data_value;
         right_value: ^clt$data_value): clt$comparison_result;

?? PUSH (LISTEXT := ON) ??
*copyc clt$comparison_result
*copyc clt$data_value
?? POP ??
*DECK DECK=CLP$RELEASE_COMMAND_LIST EXPAND=FALSE
*DECK DECK=CLP$RELEASE_CONNECTED_FILES EXPAND=FALSE
*DECK DECK=CLP$REMOVE_LAST_PATH_ELEMENT EXPAND=FALSE

  PROCEDURE [INLINE] clp$remove_last_path_element
    (VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      i: fst$path_index,
      position: fst$path_index;

    status.normal := TRUE;

{ Cannot remove "only" path element from the file reference.

    IF evaluated_file_reference.number_of_path_elements = 1 THEN
      osp$set_status_abnormal ('CL', cle$up_produced_empty_file_ref, '',
            status);
    ELSE
      i := $INTEGER (evaluated_file_reference.path_structure (1)) + 2;
      WHILE i < evaluated_file_reference.path_structure_size DO
        position := i;
        i := i + $INTEGER (evaluated_file_reference.path_structure (i)) + 1;
      WHILEND;

      evaluated_file_reference.path_structure_size := position - 1;
      evaluated_file_reference.path_structure :=
            evaluated_file_reference.path_structure (1, position - 1);
      evaluated_file_reference.number_of_path_elements :=
            evaluated_file_reference.number_of_path_elements - 1;
    IFEND;

  PROCEND clp$remove_last_path_element;

*copyc cle$ecc_file_reference
*copyc fst$evaluated_file_reference
*copyc fst$path_index
*copyc ost$status
?? POP ??
*copyc osp$set_status_abnormal
*DECK DECK=CLP$REQUEST_LOG_DEVICE EXPAND=FALSE

  PROCEDURE [XREF] clp$request_log_device
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$RESCAN_WILD_CARD_LEX_UNIT EXPAND=FALSE
{
{ CLP$RESCAN_WILD_CARD_LEX_UNIT updates its PARSE parameter to designate the
{ next lexical unit that may include "wild card" characters.  The unit kind
{ clc$lex_wild_card_name can be thought of as "compound" units comprised of one
{ or more of the "simple" units: clc$lex_name, clc$lex_long_name,
{ clc$lex_alpha_number, clc$lex_unsigned_decimal, clc$lex_query,
{ clc$lex_multiply, clc$lex_exponentiate, and clc$lex_subtract.
{ For this procedure, the current unit upon entry will be (part of) the current
{ unit upon exit, whereas CLP$SCAN_WILD_CARD_LEXICAL_UNIT always moves on to
{ the next unit.
{ This procedure requires that the UNITS_ARRAY field of the PARSE parameter be
{ non-NIL.
{

  PROCEDURE [INLINE] clp$rescan_wild_card_lex_unit
    (VAR parse {input, output} : clt$parse_state);

?? PUSH (LISTEXT := ON) ??

    VAR
      wild_card_encountered: boolean;


    IF parse.unit.kind IN $clt$lexical_unit_kinds
          [clc$lex_name, clc$lex_long_name, clc$lex_query,
          clc$lex_multiply, clc$lex_exponentiate]
          THEN
      wild_card_encountered := FALSE;

    /scan_wild_card_units/
      WHILE TRUE DO
        IF parse.unit.kind IN $clt$lexical_unit_kinds
              [clc$lex_query, clc$lex_multiply, clc$lex_exponentiate,
              clc$lex_subtract] THEN
          wild_card_encountered := TRUE;
        IFEND;

        IF parse.index >= parse.index_limit THEN
          EXIT /scan_wild_card_units/;
        ELSE
          CASE parse.units_array^ [parse.units_array_index + 1].kind OF
          = clc$lex_name, clc$lex_long_name, clc$lex_alpha_number,
                clc$lex_unsigned_decimal, clc$lex_query,
                clc$lex_multiply, clc$lex_exponentiate =
            ;
          = clc$lex_subtract =
            CASE parse.units_array^ [parse.units_array_index + 2].kind OF
            = clc$lex_name, clc$lex_long_name, clc$lex_alpha_number,
                  clc$lex_query, clc$lex_multiply, clc$lex_exponentiate =
              ;
            = clc$lex_unsigned_decimal =
              IF NOT (parse.units_array^ [parse.units_array_index + 3].kind
                    IN $clt$lexical_unit_kinds [clc$lex_name,
                    clc$lex_long_name, clc$lex_alpha_number, clc$lex_query,
                    clc$lex_multiply, clc$lex_exponentiate]) THEN
                EXIT /scan_wild_card_units/;
              IFEND;
            ELSE
              EXIT /scan_wild_card_units/;
            CASEND;
          ELSE
            EXIT /scan_wild_card_units/;
          CASEND;
        IFEND;

        parse.units_array_index := parse.units_array_index + 1;
        parse.unit.kind := parse.units_array^ [parse.units_array_index].kind;
        parse.index := parse.index + parse.units_array^
              [parse.units_array_index].size;
      WHILEND /scan_wild_card_units/;

      IF wild_card_encountered THEN
        parse.unit.kind := clc$lex_wild_card_name;
        parse.unit.size := parse.index - parse.unit_index;
      IFEND;
    IFEND;

  PROCEND clp$rescan_wild_card_lex_unit;

*copyc clt$lexical_unit_kinds
*copyc clt$parse_state
?? POP ??
*DECK DECK=CLP$RESET_FOR_NEXT_DISPLAY_PAGE EXPAND=FALSE

  PROCEDURE [XREF] clp$reset_for_next_display_page
    (VAR display_control {input, output} : clt$display_control;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=CLP$RESET_INPUT_POSITION EXPAND=FALSE

  PROCEDURE [XREF] clp$reset_input_position
    (    line_identifier: clt$line_identifier;
         line_parse: clt$parse_state);

?? PUSH (LISTEXT := ON) ??
*copyc clt$line_identifier
*copyc clt$parse_state
?? POP ??
*DECK DECK=CLP$RESET_INPUT_STATE EXPAND=FALSE

  PROCEDURE [XREF] clp$reset_input_state;
*DECK DECK=CLP$RESET_WORK_AREA_POSITIONS EXPAND=FALSE

  PROCEDURE [XREF] clp$reset_work_area_positions
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$RESTORE_WORK_AREA_POSITIONS EXPAND=FALSE

  PROCEDURE [XREF] clp$restore_work_area_positions
    (    saved_work_area_positions: clt$saved_work_area_positions;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$saved_work_area_positions
*copyc ost$status
?? POP ??
*DECK DECK=CLP$RETURN_CONNECTED_FILE EXPAND=FALSE

  PROCEDURE [XREF] clp$return_connected_file
    (    local_file_name: amt$local_file_name);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
?? POP ??
*DECK DECK=CLP$RETURN_FILE_VALS_AS_FILES EXPAND=FALSE

  PROCEDURE [XREF] clp$return_file_vals_as_files
    (VAR orig_block_value: boolean);

*DECK DECK=CLP$RETURN_FILE_VALS_AS_STRINGS EXPAND=FALSE

  PROCEDURE [XREF] clp$return_file_vals_as_strings;

*DECK DECK=CLP$REVERSE_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$reverse_list
    (VAR list: ^clt$data_value);

*copyc clt$data_value
*DECK DECK=CLP$RIGHT_JUSTIFY_STRING EXPAND=FALSE

  PROCEDURE [INLINE] clp$right_justify_string
    (VAR substring: string ( * <= 255));

?? PUSH (LISTEXT := ON) ??

    VAR
      count_index: integer,
      swap_index: integer,
      string_length: integer;

    string_length := STRLENGTH (substring);

    FOR count_index := string_length DOWNTO 1 DO {Start at right end of string}
      IF substring (count_index) <> ' ' THEN {Look for first non-blank
        {character}
        IF count_index <> string_length THEN {If there are no blanks no need to
          {right justify}
          FOR swap_index := count_index DOWNTO 1 DO
            substring (string_length) := substring (swap_index); {Move
            {character to rightmost spot}
            substring (swap_index) := ' '; {Blank out old position}
            string_length := string_length - 1;
          FOREND;
        IFEND;
        RETURN;
      IFEND;
    FOREND;

  PROCEND clp$right_justify_string;

*copy clh$right_justify_string

?? POP ??

*DECK DECK=CLP$SAVE_COLLECT_STATEMENT_AREA EXPAND=FALSE

  PROCEDURE [INLINE] clp$save_collect_statement_area
    (    collected_statements: ^clt$collect_statement_area;
     VAR statement_area: ^clt$collect_statement_area);

?? PUSH (LISTEXT := ON) ??

    ALLOCATE statement_area: [[REP #SIZE (collected_statements^) OF cell]] IN
          osv$task_shared_heap^;
    RESET statement_area;
    statement_area^ := collected_statements^;

  PROCEND clp$save_collect_statement_area;

*copyc clt$collect_statement_area
?? POP ??
*copyc osv$task_shared_heap
*DECK DECK=CLP$SAVE_EVALUATED_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] clp$save_evaluated_parameters
    (    pdt: ^clt$unbundled_pdt;
         pvt: ^clt$parameter_value_table;
         evaluated_by_scan_param_list: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status {input, output} : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_value_table
*copyc clt$unbundled_pdt
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SAVE_WORK_AREA_POSITIONS EXPAND=FALSE

  PROCEDURE [XREF] clp$save_work_area_positions
    (VAR saved_work_area_positions: clt$saved_work_area_positions);

?? PUSH (LISTEXT := ON) ??
*copyc clt$saved_work_area_positions
?? POP ??
*DECK DECK=CLP$SCAN_ANY_LEXICAL_UNIT EXPAND=FALSE

{
{ CLP$SCAN_ANY_LEXICAL_UNIT updates its PARSE parameter to designate the next
{ lexical unit of any kind.
{ This procedure requires that the UNITS_ARRAY field of the PARSE parameter be
{ non-NIL.
{

  PROCEDURE [INLINE] clp$scan_any_lexical_unit
    (VAR parse {input, output} : clt$parse_state);

?? PUSH (LISTEXT := ON) ??

    IF parse.unit_index < parse.index_limit THEN
      IF NOT parse.unit_is_space THEN
        parse.previous_non_space_unit := parse.unit;
        parse.previous_non_space_unit_index := parse.unit_index;
      IFEND;

      parse.previous_unit_is_space := parse.unit_is_space;
      parse.unit_index := parse.index;
      parse.units_array_index := parse.units_array_index + 1;
      parse.unit := parse.units_array^ [parse.units_array_index];
      parse.index := parse.index + parse.unit.size;

      parse.unit_is_space := parse.unit.kind IN
            $clt$lexical_unit_kinds [clc$lex_space, clc$lex_comment,
            clc$lex_unterminated_comment];

    ELSEIF parse.unit.kind = clc$lex_beginning_of_line THEN
      parse.units_array_index := 2;
      parse.unit.kind := clc$lex_end_of_line;
    IFEND;

  PROCEND clp$scan_any_lexical_unit;

*copyc clt$lexical_unit_kinds
*copyc clt$parse_state
?? POP ??
*DECK DECK=CLP$SCAN_ARGUMENT_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$scan_argument_list
    (    function_name: clt$name;
         argument_list: string ( * );
         adt: ^clt$argument_descriptor_table;
         avt: ^clt$argument_value_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_expression
*copyc cle$ecc_expression_result
*copyc cle$ecc_file_reference
*copyc cle$ecc_function_processing
*copyc cle$ecc_lexical
*copyc cle$ecc_variable
*copyc clt$argument_descriptor_table
*copyc clt$argument_value_table
*copyc clt$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SCAN_BALANCED_PARENTHESIS EXPAND=FALSE

  PROCEDURE [INLINE] clp$scan_balanced_parenthesis
    (    text: clt$command_line;
         start_index: clt$command_line_index;
     VAR end_index: clt$command_line_index);

?? PUSH (LISTEXT := ON) ??

    VAR
      found_char: boolean,
      nesting_level: integer,
      scan_index: integer,
      text_index: clt$command_line_index;

    text_index := start_index;
    nesting_level := 1;
    found_char := TRUE;

  /scan_loop/
    WHILE (nesting_level > 0) AND found_char AND
          (text_index <= STRLENGTH (text)) DO
      #SCAN (clv$isolate_balanced_text, text (text_index, * ), scan_index,
            found_char);
      text_index := scan_index + text_index - 1;
      IF found_char THEN
        CASE text (text_index) OF
        = '"' =
          #SCAN (clv$comment_delimiter, text (text_index + 1, * ), scan_index,
                found_char);
          text_index := scan_index + text_index + $INTEGER (found_char);
        = '''' =
          #SCAN (clv$string_delimiter, text (text_index + 1, * ), scan_index,
                found_char);
          text_index := scan_index + text_index + $INTEGER (found_char);
        = '(' =
          nesting_level := nesting_level + 1;
          text_index := text_index + 1;
        = ')' =
          nesting_level := nesting_level - 1;
          text_index := text_index + 1;
        = $CHAR (9) {HT} , ' ', ',', ';' =
          text_index := text_index + 1;
        ELSE
          text_index := text_index + 1;
        CASEND;
      IFEND;
    WHILEND /scan_loop/;
    end_index := text_index - 1;

  PROCEND clp$scan_balanced_parenthesis;

*copyc clt$command_line
*copyc clt$command_line_index
?? POP ??
*copyc clv$comment_delimiter
*copyc clv$isolate_balanced_text
*copyc clv$string_delimiter
*DECK DECK=CLP$SCAN_BAL_PAREN_LEXICAL_UNIT EXPAND=FALSE

{
{ CLP$SCAN_BAL_PAREN_LEXICAL_UNIT is called after encountering a left
{ parenthesis and updates its PARSE parameter to designate the balancing right
{ parentheses lexical unit.
{ This procedure requires that the UNITS_ARRAY field of the PARSE parameter be
{ non-NIL.
{

  PROCEDURE [INLINE] clp$scan_bal_paren_lexical_unit
    (VAR parse {input, output} : clt$parse_state);

?? PUSH (LISTEXT := ON) ??

    VAR
      nesting_level: clt$string_size;


    IF parse.unit_index < parse.index_limit THEN
      nesting_level := 1;
      REPEAT
        IF NOT parse.unit_is_space THEN
          parse.previous_non_space_unit := parse.unit;
          parse.previous_non_space_unit_index := parse.unit_index;
        IFEND;

        parse.previous_unit_is_space := parse.unit_is_space;
        parse.unit_index := parse.index;
        parse.units_array_index := parse.units_array_index + 1;
        parse.unit := parse.units_array^ [parse.units_array_index];
        parse.index := parse.index + parse.unit.size;

        parse.unit_is_space := FALSE;
        CASE parse.unit.kind OF
        = clc$lex_space, clc$lex_comment, clc$lex_unterminated_comment =
          parse.unit_is_space := TRUE;
        = clc$lex_left_parenthesis =
          nesting_level := nesting_level + 1;
        = clc$lex_right_parenthesis =
          nesting_level := nesting_level - 1;
        ELSE
          ;
        CASEND;

      UNTIL (nesting_level <= 0) OR (parse.unit_index >= parse.index_limit);
    IFEND;

  PROCEND clp$scan_bal_paren_lexical_unit;

*copyc clt$parse_state
*copyc clt$string_size
?? POP ??
*DECK DECK=CLP$SCAN_COMMAND_FILE EXPAND=FALSE

{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     ****** This program interface is obsolete.  Modules presently    ******
{     ****** using it should be changed to use CLP$INCLUDE_FILE.       ******
{     ***********************************************************************
{     ***********************************************************************
{

  PROCEDURE [XREF] clp$scan_command_file
    (    file: fst$file_reference;
         utility_name: ost$name;
         prompt_string: clt$prompt_string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc clc$standard_file_names
*copyc cle$exception_condition_codes
*copyc clt$prompt_string
*copyc fst$file_reference
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SCAN_COMMAND_LINE EXPAND=FALSE

{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     ****** This program interface is obsolete.  Modules presently    ******
{     ****** using it should be changed to use CLP$INCLUDE_LINE.       ******
{     ***********************************************************************
{     ***********************************************************************
{

  PROCEDURE [XREF] clp$scan_command_line
    (    text: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$exception_condition_codes
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SCAN_EXPRESSION EXPAND=FALSE

  PROCEDURE [XREF] clp$scan_expression ALIAS 'clpexpr'
    (    expression: string ( * );
         value_kind_specifier: clt$value_kind_specifier;
     VAR value: clt$value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc cle$ecc_expression
*copyc cle$ecc_expression_result
*copyc cle$ecc_file_reference
*copyc cle$ecc_function_processing
*copyc cle$ecc_lexical
*copyc cle$ecc_variable
*copyc clt$value_kind_specifier
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$SCAN_LEXICAL_UNIT EXPAND=FALSE

{
{ CLP$SCAN_LEXICAL_UNIT updates its PARSE parameter to designate the
{ lexical unit determined by the TERMINATION_OPTION parameter.
{ This procedure does NOT require that the UNITS_ARRAY field of the PARSE
{ parameter be non-NIL.
{

  PROCEDURE [INLINE] clp$scan_lexical_unit
    (    termination_option: clt$slu_termination_option;
     VAR parse {input, output} : clt$parse_state);

?? PUSH (LISTEXT := ON) ??


    IF parse.unit_index < parse.index_limit THEN
      IF NOT parse.unit_is_space THEN
        parse.previous_non_space_unit := parse.unit;
        parse.previous_non_space_unit_index := parse.unit_index;
      IFEND;

      IF parse.units_array <> NIL THEN
        REPEAT
          parse.previous_unit_is_space := parse.unit_is_space;
          parse.unit_index := parse.index;
          parse.units_array_index := parse.units_array_index + 1;
          parse.unit := parse.units_array^ [parse.units_array_index];
          parse.index := parse.index + parse.unit.size;

          parse.unit_is_space := parse.unit.kind IN
                $clt$lexical_unit_kinds [clc$lex_space, clc$lex_comment,
                clc$lex_unterminated_comment];

        UNTIL (termination_option = clc$slu_any) OR
              (NOT parse.unit_is_space) OR (parse.unit_index >=
              parse.index_limit);

      ELSE
        clp$identify_lexical_unit (termination_option, parse.text, parse.index,
              parse.unit_index, parse.unit_is_space, parse.unit);
        parse.previous_unit_is_space := parse.unit_index >
              (parse.previous_non_space_unit_index +
              parse.previous_non_space_unit.size);
      IFEND;

    ELSEIF parse.unit.kind = clc$lex_beginning_of_line THEN
      parse.units_array_index := 2;
      parse.unit.kind := clc$lex_end_of_line;
    IFEND;

  PROCEND clp$scan_lexical_unit;

*copyc clt$lexical_unit_kinds
*copyc clt$parse_state
*copyc clt$slu_termination_option
?? POP ??
*copyc clp$identify_lexical_unit
*DECK DECK=CLP$SCAN_NON_SPACE_LEXICAL_UNIT EXPAND=FALSE

{
{ CLP$SCAN_NON_SPACE_LEXICAL_UNIT updates its PARSE parameter to designate the
{ next lexical unit that is not normally considerred to be a space (i.e. not a
{ space or comment).
{ This procedure requires that the UNITS_ARRAY field of the PARSE parameter be
{ non-NIL.
{

  PROCEDURE [INLINE] clp$scan_non_space_lexical_unit
    (VAR parse {input, output} : clt$parse_state);

?? PUSH (LISTEXT := ON) ??

    IF parse.unit_index < parse.index_limit THEN
      IF NOT parse.unit_is_space THEN
        parse.previous_non_space_unit := parse.unit;
        parse.previous_non_space_unit_index := parse.unit_index;
      IFEND;

      REPEAT
        parse.previous_unit_is_space := parse.unit_is_space;
        parse.unit_index := parse.index;
        parse.units_array_index := parse.units_array_index + 1;
        parse.unit := parse.units_array^ [parse.units_array_index];
        parse.index := parse.index + parse.unit.size;

        parse.unit_is_space := parse.unit.kind IN
              $clt$lexical_unit_kinds [clc$lex_space, clc$lex_comment,
              clc$lex_unterminated_comment];

      UNTIL (NOT parse.unit_is_space) OR
            (parse.unit_index >= parse.index_limit);

    ELSEIF parse.unit.kind = clc$lex_beginning_of_line THEN
      parse.units_array_index := 2;
      parse.unit.kind := clc$lex_end_of_line;
    IFEND;

  PROCEND clp$scan_non_space_lexical_unit;

*copyc clt$lexical_unit_kinds
*copyc clt$parse_state
?? POP ??
*DECK DECK=CLP$SCAN_OPERAND EXPAND=FALSE

{
{ CLP$SCAN_OPERAND updates its PARSE parameter to designate the
{ next lexical unit that is a separator (space, comment, comma, semicolon or
{ ellipsis) not nested within parentheses.
{ An ellipsis may have spaces on either side of it.
{ This procedure requires that the UNITS_ARRAY field of the PARSE parameter be
{ non-NIL.
{

  PROCEDURE [INLINE] clp$scan_operand
    (    termination_option: (clc$separator, clc$ellipsis);
     VAR parse {input, output} : clt$parse_state);

?? PUSH (LISTEXT := ON) ??

    VAR
      backup_parse: clt$parse_state,
      done: boolean,
      nesting_level: clt$string_size,
      space_pending: boolean,
      spaces_significant: boolean;


    nesting_level := $INTEGER (parse.unit.kind = clc$lex_left_parenthesis);
    spaces_significant := TRUE;
    done := FALSE;
    space_pending := FALSE;

    WHILE (NOT done) AND (parse.unit_index < parse.index_limit) DO
      IF NOT parse.unit_is_space THEN
        parse.previous_non_space_unit := parse.unit;
        parse.previous_non_space_unit_index := parse.unit_index;
      IFEND;

      parse.previous_unit_is_space := parse.unit_is_space;
      parse.unit_index := parse.index;
      parse.units_array_index := parse.units_array_index + 1;
      parse.unit := parse.units_array^ [parse.units_array_index];
      parse.index := parse.index + parse.unit.size;

      parse.unit_is_space := FALSE;
      CASE parse.unit.kind OF
      = clc$lex_space, clc$lex_comment, clc$lex_unterminated_comment =
        parse.unit_is_space := TRUE;
        IF spaces_significant AND (nesting_level <= 0) AND
              (NOT space_pending) THEN
          backup_parse := parse;
          IF termination_option = clc$ellipsis THEN
            space_pending := FALSE;
          ELSE
            space_pending := TRUE;
          IFEND;
        IFEND;
      = clc$lex_ellipsis =
        IF (nesting_level <= 0) AND (termination_option = clc$ellipsis) THEN
          done := TRUE;
          backup_parse := parse;
        ELSE
          spaces_significant := FALSE;
        IFEND;
      = clc$lex_semicolon, clc$lex_comma =
        IF nesting_level <= 0 THEN
          done := TRUE;
        ELSE
          spaces_significant := TRUE;
        IFEND;
      = clc$lex_left_parenthesis =
        done := space_pending;
        nesting_level := nesting_level + 1;
        spaces_significant := TRUE;
      = clc$lex_right_parenthesis =
        IF nesting_level <= 0 THEN
          done := TRUE;
        ELSE
          nesting_level := nesting_level - 1;
          spaces_significant := TRUE;
        IFEND;
      = clc$lex_greater_than .. clc$lex_subtract =
        done := space_pending;
        spaces_significant := FALSE;
      ELSE
        done := space_pending;
        spaces_significant := TRUE;
      CASEND;

      IF (NOT done) AND (NOT parse.unit_is_space) THEN
        space_pending := FALSE
      IFEND;
    WHILEND;

    IF space_pending AND (done OR (parse.unit_index >= parse.index_limit)) THEN
      parse := backup_parse;

    ELSEIF parse.unit.kind = clc$lex_beginning_of_line THEN
      parse.units_array_index := 2;
      parse.unit.kind := clc$lex_end_of_line;
    ELSEIF done AND (parse.unit.kind = clc$lex_ellipsis) THEN
      parse := backup_parse;
    IFEND;

  PROCEND clp$scan_operand;

*copyc clt$lexical_unit_kinds
*copyc clt$parse_state
*copyc clt$string_size
?? POP ??
*DECK DECK=CLP$SCAN_PARAMETER_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$scan_parameter_list
    (    parameter_list: clt$parameter_list;
         pdt: clt$parameter_descriptor_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc cle$ecc_expression
*copyc cle$ecc_expression_result
*copyc cle$ecc_file_reference
*copyc cle$ecc_function_processing
*copyc cle$ecc_lexical
*copyc cle$ecc_parameter_list
*copyc cle$ecc_variable
*copyc clt$parameter_descriptor_table
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SCAN_PROC_DECLARATION EXPAND=FALSE

  PROCEDURE [XREF] clp$scan_proc_declaration ALIAS 'clpspd'
    (    input_type: clt$proc_input_type;
         get_line: clt$proc_input_procedure;
     VAR proc_name_area: SEQ ( * );
     VAR parameter_name_area: SEQ ( * );
     VAR parameter_area: SEQ ( * );
     VAR symbolic_parameter_area: SEQ ( * );
     VAR extra_info_area: SEQ ( * );
     VAR proc_names: ^clt$proc_names;
     VAR pdt: clt$parameter_descriptor_table;
     VAR symbolic_parameters: ^clt$symbolic_parameters;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$proc_declaration
*copyc cle$ecc_expression
*copyc cle$ecc_expression_result
*copyc cle$ecc_file_reference
*copyc cle$ecc_function_processing
*copyc cle$ecc_lexical
*copyc cle$ecc_proc_declaration
*copyc cle$ecc_variable
*copyc clt$parameter_descriptor_table
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SCAN_TOKEN EXPAND=FALSE

{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     ****** This program interface is obsolete.  Modules presently    ******
{     ****** using it should be changed to use CLP$EVALUATE_TOKEN.     ******
{     ***********************************************************************
{     ***********************************************************************
{

  PROCEDURE [XREF] clp$scan_token ALIAS 'clpstok'
    (    text: string ( * );
     VAR index {input, output} : ost$string_index;
     VAR token: clt$token;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc clt$token
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$SCAN_TO_LEXICAL_LIMIT EXPAND=FALSE

{
{ CLP$SCAN_TO_LEXICAL_LIMIT is called to advance its PARSE parameter to its
{ established limit (usually to "end of line").
{ This procedure requires that the UNITS_ARRAY field of the PARSE parameter be
{ non-NIL.
{

  PROCEDURE [INLINE] clp$scan_to_lexical_limit
    (VAR parse {input, output} : clt$parse_state);

?? PUSH (LISTEXT := ON) ??


    WHILE parse.unit_index < parse.index_limit DO
      IF NOT parse.unit_is_space THEN
        parse.previous_non_space_unit := parse.unit;
        parse.previous_non_space_unit_index := parse.unit_index;
      IFEND;

      parse.previous_unit_is_space := parse.unit_is_space;
      parse.unit_index := parse.index;
      parse.units_array_index := parse.units_array_index + 1;
      parse.unit := parse.units_array^ [parse.units_array_index];
      parse.index := parse.index + parse.unit.size;

      parse.unit_is_space := parse.unit.kind IN
            $clt$lexical_unit_kinds [clc$lex_space, clc$lex_comment,
            clc$lex_unterminated_comment];
    WHILEND;

    IF parse.unit.kind = clc$lex_beginning_of_line THEN
      parse.units_array_index := 2;
      parse.unit.kind := clc$lex_end_of_line;
    IFEND;

  PROCEND clp$scan_to_lexical_limit;

*copyc clt$lexical_unit_kinds
*copyc clt$parse_state
?? POP ??
*DECK DECK=CLP$SCAN_UNNESTED_CMND_LEX_UNIT EXPAND=FALSE

{
{ CLP$SCAN_UNNESTED_CMND_LEX_UNIT updates its PARSE parameter to designate the
{ next lexical unit that is a command separator (semicolon) not nested within
{ parentheses.
{ This procedure requires that the UNITS_ARRAY field of the PARSE parameter be
{ non-NIL.
{

  PROCEDURE [INLINE] clp$scan_unnested_cmnd_lex_unit
    (VAR parse {input, output} : clt$parse_state);

?? PUSH (LISTEXT := ON) ??

    VAR
      done: boolean,
      nesting_level: integer;


    nesting_level := 0;
    done := parse.unit.kind = clc$lex_semicolon;

    WHILE (NOT done) AND (parse.unit_index < parse.index_limit) DO
      IF NOT parse.unit_is_space THEN
        parse.previous_non_space_unit := parse.unit;
        parse.previous_non_space_unit_index := parse.unit_index;
      IFEND;

      parse.previous_unit_is_space := parse.unit_is_space;
      parse.unit_index := parse.index;
      parse.units_array_index := parse.units_array_index + 1;
      parse.unit := parse.units_array^ [parse.units_array_index];
      parse.index := parse.index + parse.unit.size;

      parse.unit_is_space := FALSE;
      CASE parse.unit.kind OF
      = clc$lex_space, clc$lex_comment, clc$lex_unterminated_comment =
        parse.unit_is_space := TRUE;
      = clc$lex_semicolon =
        done := nesting_level <= 0;
      = clc$lex_left_parenthesis =
        nesting_level := nesting_level + $INTEGER (nesting_level >= 0);
      = clc$lex_right_parenthesis =
        nesting_level := nesting_level - 1;
      ELSE
        ;
      CASEND;
    WHILEND;

    IF parse.unit.kind = clc$lex_beginning_of_line THEN
      parse.units_array_index := 2;
      parse.unit.kind := clc$lex_end_of_line;
    IFEND;

  PROCEND clp$scan_unnested_cmnd_lex_unit;

*copyc clt$parse_state
?? POP ??
*DECK DECK=CLP$SCAN_UNNESTED_REL_LEX_UNIT EXPAND=FALSE

{
{ CLP$SCAN_UNNESTED_REL_LEX_UNIT updates its PARSE parameter to designate the
{ next lexical unit that is a separator (space, comment, comma, semicolon or
{ ellipsis) or relational operator (<, <=, >, >=, = or <>) not nested within
{ parentheses.
{ This procedure requires that the UNITS_ARRAY field of the PARSE parameter be
{ non-NIL.
{

  PROCEDURE [INLINE] clp$scan_unnested_rel_lex_unit
    (VAR parse {input, output} : clt$parse_state);

?? PUSH (LISTEXT := ON) ??

    VAR
      done: boolean,
      nesting_level: clt$string_size;


    nesting_level := $INTEGER (parse.unit.kind = clc$lex_left_parenthesis);
    done := parse.unit.kind IN $clt$lexical_unit_kinds
          [clc$lex_semicolon, clc$lex_comma, clc$lex_ellipsis,
          clc$lex_greater_than, clc$lex_greater_equal, clc$lex_less_than,
          clc$lex_less_equal, clc$lex_equal, clc$lex_not_equal];

    WHILE (NOT done) AND (parse.unit_index < parse.index_limit) DO
      IF NOT parse.unit_is_space THEN
        parse.previous_non_space_unit := parse.unit;
        parse.previous_non_space_unit_index := parse.unit_index;
      IFEND;

      parse.previous_unit_is_space := parse.unit_is_space;
      parse.unit_index := parse.index;
      parse.units_array_index := parse.units_array_index + 1;
      parse.unit := parse.units_array^ [parse.units_array_index];
      parse.index := parse.index + parse.unit.size;

      parse.unit_is_space := FALSE;
      CASE parse.unit.kind OF
      = clc$lex_space, clc$lex_comment, clc$lex_unterminated_comment =
        parse.unit_is_space := TRUE;
        done := nesting_level <= 0;
      = clc$lex_semicolon, clc$lex_comma, clc$lex_ellipsis,
            clc$lex_greater_than, clc$lex_greater_equal, clc$lex_less_than,
            clc$lex_less_equal, clc$lex_equal, clc$lex_not_equal =
        done := nesting_level <= 0;
      = clc$lex_left_parenthesis =
        nesting_level := nesting_level + 1;
      = clc$lex_right_parenthesis =
        IF nesting_level <= 0 THEN
          done := TRUE;
        ELSE
          nesting_level := nesting_level - 1;
        IFEND;
      ELSE
        ;
      CASEND;
    WHILEND;

    IF parse.unit.kind = clc$lex_beginning_of_line THEN
      parse.units_array_index := 2;
      parse.unit.kind := clc$lex_end_of_line;
    IFEND;

  PROCEND clp$scan_unnested_rel_lex_unit;

*copyc clt$lexical_unit_kinds
*copyc clt$parse_state
*copyc clt$string_size
?? POP ??
*DECK DECK=CLP$SCAN_UNNESTED_SEP_LEX_UNIT EXPAND=FALSE

{
{ CLP$SCAN_UNNESTED_SEP_LEX_UNIT updates its PARSE parameter to designate the
{ next lexical unit that is a separator (space, comment, comma, semicolon or,
{ optionally, ellipsis) not nested within parentheses.
{ An ellipsis may have spaces on either side of it.
{ This procedure requires that the UNITS_ARRAY field of the PARSE parameter be
{ non-NIL.
{

  PROCEDURE [INLINE] clp$scan_unnested_sep_lex_unit
    (    ellipsis_treatment: (clc$ignore_ellipsis, clc$ellipsis_is_separator);
     VAR parse {input, output} : clt$parse_state);

?? PUSH (LISTEXT := ON) ??

    VAR
      backup_parse: clt$parse_state,
      done: boolean,
      nesting_level: clt$string_size,
      space_pending: boolean,
      spaces_significant: boolean;


    nesting_level := $INTEGER (parse.unit.kind = clc$lex_left_parenthesis);
    spaces_significant := TRUE;
    done := FALSE;
    space_pending := FALSE;

    WHILE (NOT done) AND (parse.unit_index < parse.index_limit) DO
      IF NOT parse.unit_is_space THEN
        parse.previous_non_space_unit := parse.unit;
        parse.previous_non_space_unit_index := parse.unit_index;
      IFEND;

      parse.previous_unit_is_space := parse.unit_is_space;
      parse.unit_index := parse.index;
      parse.units_array_index := parse.units_array_index + 1;
      parse.unit := parse.units_array^ [parse.units_array_index];
      parse.index := parse.index + parse.unit.size;

      parse.unit_is_space := FALSE;
      CASE parse.unit.kind OF
      = clc$lex_space, clc$lex_comment, clc$lex_unterminated_comment =
        parse.unit_is_space := TRUE;
        IF spaces_significant AND (nesting_level <= 0) AND
              (NOT space_pending) THEN
          backup_parse := parse;
          space_pending := TRUE;
        IFEND;
      = clc$lex_ellipsis =
        IF (nesting_level <= 0) AND (ellipsis_treatment =
              clc$ellipsis_is_separator) THEN
          done := TRUE;
        ELSE
          spaces_significant := FALSE;
        IFEND;
      = clc$lex_semicolon, clc$lex_comma =
        IF nesting_level <= 0 THEN
          done := TRUE;
        ELSE
          spaces_significant := TRUE;
        IFEND;
      = clc$lex_left_parenthesis =
        done := space_pending;
        nesting_level := nesting_level + 1;
        spaces_significant := TRUE;
      = clc$lex_right_parenthesis =
        IF nesting_level <= 0 THEN
          done := TRUE;
        ELSE
          nesting_level := nesting_level - 1;
          spaces_significant := TRUE;
        IFEND;
      ELSE
        done := space_pending;
        spaces_significant := TRUE;
      CASEND;

      IF (NOT done) AND (NOT parse.unit_is_space) THEN
        space_pending := FALSE
      IFEND;
    WHILEND;

    IF space_pending AND (done OR (parse.unit_index >= parse.index_limit)) THEN
      parse := backup_parse;

    ELSEIF parse.unit.kind = clc$lex_beginning_of_line THEN
      parse.units_array_index := 2;
      parse.unit.kind := clc$lex_end_of_line;
    IFEND;

  PROCEND clp$scan_unnested_sep_lex_unit;

*copyc clt$lexical_unit_kinds
*copyc clt$parse_state
*copyc clt$string_size
?? POP ??
*DECK DECK=CLP$SCAN_WILD_CARD_LEXICAL_UNIT EXPAND=FALSE
{
{ CLP$SCAN_WILD_CARD_LEXICAL_UNIT updates its PARSE parameter to designate the
{ next lexical unit that may include "wild card" characters.  The unit kind
{ clc$lex_wild_card_name can be thought of as "compound" units comprised of one
{ or more of the "simple" units: clc$lex_name, clc$lex_long_name,
{ clc$lex_alpha_number, clc$lex_unsigned_decimal, clc$lex_query,
{ clc$lex_multiply, clc$lex_exponentiate, and clc$lex_subtract.
{ This procedure should be used in place of CLP$SCAN_ANY_LEXICAL_UNIT when
{ "wild card" characters are possible.
{ This procedure requires that the UNITS_ARRAY field of the PARSE parameter be
{ non-NIL.
{

  PROCEDURE [INLINE] clp$scan_wild_card_lexical_unit
    (VAR parse {input, output} : clt$parse_state);

?? PUSH (LISTEXT := ON) ??

    VAR
      wild_card_encountered: boolean;


    IF parse.unit_index < parse.index_limit THEN
      IF NOT parse.unit_is_space THEN
        parse.previous_non_space_unit := parse.unit;
        parse.previous_non_space_unit_index := parse.unit_index;
      IFEND;

      parse.previous_unit_is_space := parse.unit_is_space;
      parse.unit_index := parse.index;
      parse.units_array_index := parse.units_array_index + 1;
      parse.unit := parse.units_array^ [parse.units_array_index];
      parse.index := parse.index + parse.unit.size;

      CASE parse.unit.kind OF

      = clc$lex_space, clc$lex_comment, clc$lex_unterminated_comment =
        parse.unit_is_space := TRUE;

      = clc$lex_name, clc$lex_long_name, clc$lex_query,
              clc$lex_multiply, clc$lex_exponentiate =
        parse.unit_is_space := FALSE;
        wild_card_encountered := FALSE;

      /scan_wild_card_units/
        WHILE TRUE DO
          IF parse.unit.kind IN $clt$lexical_unit_kinds
                [clc$lex_query, clc$lex_multiply, clc$lex_exponentiate,
                clc$lex_subtract] THEN
            wild_card_encountered := TRUE;
          IFEND;

          IF parse.index >= parse.index_limit THEN
            EXIT /scan_wild_card_units/;
          ELSE
            CASE parse.units_array^ [parse.units_array_index + 1].kind OF
            = clc$lex_name, clc$lex_long_name, clc$lex_alpha_number,
                  clc$lex_unsigned_decimal, clc$lex_query, clc$lex_multiply,
                  clc$lex_exponentiate =
              ;
            = clc$lex_subtract =
              CASE parse.units_array^ [parse.units_array_index + 2].kind OF
              = clc$lex_name, clc$lex_long_name, clc$lex_alpha_number,
                    clc$lex_query, clc$lex_multiply, clc$lex_exponentiate =
                ;
              = clc$lex_unsigned_decimal =
                IF NOT (parse.units_array^ [parse.units_array_index + 3].kind
                      IN $clt$lexical_unit_kinds [clc$lex_name,
                      clc$lex_long_name, clc$lex_alpha_number, clc$lex_query,
                      clc$lex_multiply, clc$lex_exponentiate]) THEN
                  EXIT /scan_wild_card_units/;
                IFEND;
              ELSE
                EXIT /scan_wild_card_units/;
              CASEND;
            ELSE
              EXIT /scan_wild_card_units/;
            CASEND;
          IFEND;

          parse.units_array_index := parse.units_array_index + 1;
          parse.unit.kind := parse.units_array^ [parse.units_array_index].kind;
          parse.index := parse.index + parse.
                units_array^ [parse.units_array_index].size;
        WHILEND /scan_wild_card_units/;

        IF wild_card_encountered THEN
          parse.unit.kind := clc$lex_wild_card_name;
          parse.unit.size := parse.index - parse.unit_index;
        IFEND;

      ELSE
        parse.unit_is_space := FALSE;
      CASEND;

    ELSEIF parse.unit.kind = clc$lex_beginning_of_line THEN
      parse.units_array_index := 2;
      parse.unit.kind := clc$lex_end_of_line;
    IFEND;

  PROCEND clp$scan_wild_card_lexical_unit;

*copyc clt$lexical_unit_kinds
*copyc clt$parse_state
?? POP ??
*DECK DECK=CLP$SCL_SIGNAL_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] clp$scl_signal_handler
    (    originator: ost$global_task_id;
         signal: pmt$signal);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc pmt$signal
?? POP ??
*DECK DECK=CLP$SEARCH_COMMAND_LIBRARY EXPAND=FALSE

  PROCEDURE [XREF] clp$search_command_library
    (    command_or_function_name: ost$name;
         command_or_function: clt$command_or_function;
         searching_command_list: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR local_file_name {input, output} : amt$local_file_name;
     VAR file_id: amt$file_identifier;
     VAR ring_attributes: amt$ring_attributes;
     VAR can_be_echoed: boolean;
     VAR search_info: clt$command_library_search_info;
     VAR command_or_function_found: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc amt$ring_attributes
*copyc clt$command_or_function
*copyc clt$command_library_search_info
*copyc clt$work_area
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SEARCH_COMMAND_LIST EXPAND=FALSE

  PROCEDURE [XREF] clp$search_command_list ALIAS 'clpsrc'
    (    escape_mode_search: boolean;
         command_name: ost$name;
     VAR command_proc: clt$command;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_processor
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SEARCH_COMMAND_TABLE EXPAND=FALSE

  PROCEDURE [INLINE] clp$search_command_table
    (    name: clt$command_name;
         command_table: ^clt$command_table;
     VAR entry_index: clt$command_table_index;
     VAR entry_found: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      low_index: 1 .. clc$max_command_table_size + 1,
      temp: integer,
      high_index: 0 .. clc$max_command_table_size;


    entry_found := FALSE;

    IF command_table <> NIL THEN
      low_index := 1;
      high_index := UPPERBOUND (command_table^);
      REPEAT
        temp := low_index + high_index;
        entry_index := temp DIV 2;
        IF name = command_table^ [entry_index].name THEN
          entry_found := TRUE;
        ELSEIF name > command_table^ [entry_index].name THEN
          low_index := entry_index + 1;
        ELSE
          high_index := entry_index - 1;
        IFEND;
      UNTIL entry_found OR (low_index > high_index);
    IFEND;

  PROCEND clp$search_command_table;

*copyc clt$command_name
*copyc clt$command_table
*copyc clt$command_table_index
?? POP ??
*DECK DECK=CLP$SEARCH_DICTIONARY_FOR_CODE EXPAND=FALSE

  PROCEDURE [INLINE] clp$search_dictionary_for_code
    (    library: ^SEQ ( * );
         message_module_dictionary: ^llt$message_module_dictionary;
         natural_language: ost$natural_language;
         search_by_language: boolean;
         code: ost$status_condition_code;
     VAR name: ost$status_condition_name;
     VAR severity: ost$message_module_severity;
     VAR template: ^ost$message_template;
     VAR entry_found: boolean;
     VAR saved_default: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      language: ost$natural_language,
      ignore_status: ost$status,
      index: llt$message_module_index,
      member_header: ^llt$library_member_header,
      message_module: ^ost$message_template_module;

  /search_dictionary/
    FOR index := 1 TO UPPERBOUND (message_module_dictionary^) DO
      IF NOT ((message_module_dictionary^ [index].lowest_condition_code <=
            code) AND (code <= message_module_dictionary^ [index].
            highest_condition_code)) THEN
        CYCLE /search_dictionary/;
      IFEND;
      IF search_by_language THEN
        language := message_module_dictionary^ [index].language;
        IF ((language = osc$default_natural_language) AND saved_default) OR
              ((language <> natural_language) AND
              (language <> osc$default_natural_language)) THEN
          CYCLE /search_dictionary/;
        IFEND;
      IFEND;
      member_header := #PTR (message_module_dictionary^ [index].message_header,
            library^);
      message_module := #PTR (member_header^.member, library^);
      RESET message_module;
      clp$search_module_for_code (message_module, code, language, name,
            severity, template, entry_found, ignore_status);
      IF entry_found THEN
        IF (NOT search_by_language) OR (language = natural_language) THEN
          RETURN;
        IFEND;
        saved_default := TRUE;
        entry_found := FALSE;
      IFEND;
    FOREND /search_dictionary/;

  PROCEND clp$search_dictionary_for_code;

*copyc llt$library_member_header
*copyc llt$message_module_dictionary
*copyc ost$message_module_severity
*copyc ost$message_template
*copyc ost$message_template_module
*copyc ost$natural_language
*copyc ost$status
*copyc ost$status_condition_code
*copyc ost$status_condition_name
?? POP ??
*copyc clp$search_module_for_code
*DECK DECK=CLP$SEARCH_DICTIONARY_FOR_NAME EXPAND=FALSE

  PROCEDURE [INLINE] clp$search_dictionary_for_name
    (    library: ^SEQ ( * );
         message_module_dictionary: ^llt$message_module_dictionary;
         natural_language: ost$natural_language;
         search_by_language: boolean;
         name: ost$status_condition_name;
     VAR code: ost$status_condition_code;
     VAR severity: ost$message_module_severity;
     VAR template: ^ost$message_template;
     VAR entry_found: boolean;
     VAR saved_default: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      language: ost$natural_language,
      ignore_status: ost$status,
      index: llt$message_module_index,
      member_header: ^llt$library_member_header,
      message_module: ^ost$message_template_module;

  /search_dictionary/
    FOR index := 1 TO UPPERBOUND (message_module_dictionary^) DO
      IF search_by_language THEN
        language := message_module_dictionary^ [index].language;
        IF ((language = osc$default_natural_language) AND saved_default) OR
              ((language <> natural_language) AND
              (language <> osc$default_natural_language)) THEN
          CYCLE /search_dictionary/;
        IFEND;
      IFEND;
      member_header := #PTR (message_module_dictionary^ [index].message_header,
            library^);
      message_module := #PTR (member_header^.member, library^);
      RESET message_module;
      clp$search_module_for_name (message_module, name, language, code,
            severity, template, entry_found, ignore_status);
      IF entry_found THEN
        IF (NOT search_by_language) OR (language = natural_language) THEN
          RETURN;
        IFEND;
        saved_default := TRUE;
        entry_found := FALSE;
      IFEND;
    FOREND /search_dictionary/;

  PROCEND clp$search_dictionary_for_name;

*copyc llt$library_member_header
*copyc llt$message_module_dictionary
*copyc ost$message_module_severity
*copyc ost$message_template
*copyc ost$message_template_module
*copyc ost$natural_language
*copyc ost$status
*copyc ost$status_condition_code
*copyc ost$status_condition_name
?? POP ??
*copyc clp$search_module_for_name
*DECK DECK=CLP$SEARCH_FORMAT_UTILITIES EXPAND=FALSE

  PROCEDURE [XREF] clp$search_format_utilities
    (    name: clt$name;
     VAR control_statement_descriptor: ^clt$f_control_statement_desc);

?? PUSH (LISTEXT := ON) ??
*copyc clt$f_control_statement_desc
*copyc clt$name
?? POP ??
*DECK DECK=CLP$SEARCH_FOR_HELP_MODULE EXPAND=FALSE

  PROCEDURE [XREF] clp$search_for_help_module
    (    caller_ring: ost$valid_ring;
         name: pmt$program_name;
     VAR local_file_name {input, output} : amt$local_file_name;
     VAR entry_found: boolean;
     VAR help_module: ^ost$message_template_module;
     VAR language: ost$natural_language;
     VAR online_manual: ost$online_manual_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc osd$virtual_address
*copyc ost$message_template_module
*copyc ost$natural_language
*copyc ost$online_manual_name
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=CLP$SEARCH_HELP_MODULE EXPAND=FALSE

  PROCEDURE [INLINE] clp$search_help_module
    (    name: clt$parameter_name;
         kind: ost$message_template_kind;
         names: ^ost$mtm_condition_names;
         help_module: ^ost$help_module;
     VAR template: ^ost$message_template);

?? PUSH (LISTEXT := ON) ??

    VAR
      index: ost$status_condition_code,
      temp: integer,
      lower: 0 .. osc$max_status_condition_code + 1,
      upper: -1 .. osc$max_status_condition_code + 1,
      upper_case_name: ost$name;

    IF name <> osc$null_name THEN
      #TRANSLATE (osv$lower_to_upper, name, upper_case_name);
    ELSE
      upper_case_name := name;
    IFEND;

    lower := 0;
    upper := UPPERBOUND (names^);

  /search_help_module/

    WHILE lower <= upper DO
      temp := lower + upper;
      index := temp DIV 2;
      IF names^ [index].name = upper_case_name THEN
        IF names^ [index].kind = kind THEN
          template := #PTR (names^ [index].template, help_module^);
          EXIT /search_help_module/;
        ELSEIF names^ [index].kind > kind THEN
          upper := index - 1;
        ELSE
          lower := index + 1;
        IFEND;
      ELSEIF names^ [index].name > upper_case_name THEN
        upper := index - 1;
      ELSE
        lower := index + 1;
      IFEND;
    WHILEND /search_help_module/;

  PROCEND clp$search_help_module;

*copyc clt$parameter_name
*copyc ost$help_module
*copyc ost$message_template
*copyc ost$message_template_kind
*copyc ost$mtm_condition_names
?? POP ??
*copyc osv$lower_to_upper
*DECK DECK=CLP$SEARCH_KEYWORD_SPECS EXPAND=FALSE

  PROCEDURE [INLINE] clp$search_keyword_specs
    (    keyword: clt$keyword;
         keyword_specifications: ^clt$keyword_specifications;
     VAR index: clt$keyword_index;
     VAR found: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      current_index: 0 .. clc$max_keywords,
      high_index: 0 .. clc$max_keywords,
      temp: integer,
      low_index: 1 .. clc$max_keywords + 1;


    IF keyword_specifications <> NIL THEN
      low_index := 1;
      high_index := UPPERBOUND (keyword_specifications^);
      REPEAT
        temp := low_index + high_index;
        current_index := temp DIV 2;
        IF keyword_specifications^ [current_index].keyword = keyword THEN
          index := current_index;
          found := TRUE;
          RETURN;
        ELSEIF keyword_specifications^ [current_index].keyword > keyword THEN
          high_index := current_index - 1;
        ELSE
          low_index := current_index + 1;
        IFEND;
      UNTIL low_index > high_index;
    IFEND;

    found := FALSE;

  PROCEND clp$search_keyword_specs;

*copyc clc$max_keywords
*copyc clt$keyword
*copyc clt$keyword_index
*copyc clt$keyword_specifications
?? POP ??
*DECK DECK=CLP$SEARCH_MODULE_FOR_CODE EXPAND=FALSE

  PROCEDURE [INLINE] clp$search_module_for_code
    (    message_module: ^ost$message_template_module;
         code: ost$status_condition_code;
     VAR language: ost$natural_language;
     VAR name: ost$status_condition_name;
     VAR severity: ost$message_module_severity;
     VAR template: ^ost$message_template;
     VAR entry_found: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      lower: 0 .. osc$max_status_condition_code + 1,
      upper: -1 .. osc$max_status_condition_code,
      codes: ^ost$mtm_condition_codes,
      names: ^ost$mtm_condition_names,
      header: ^ost$mtm_header,
      temp: integer,
      code_index: ost$message_template_index,
      name_index: ost$message_template_index;

  /search_module/
    BEGIN

      entry_found := FALSE;
      clp$extract_msg_module_contents (message_module, header, codes, names);
      IF (header = NIL) OR (codes = NIL) THEN
        EXIT /search_module/;
      IFEND;
      language := header^.language;
      lower := 0;
      upper := UPPERBOUND (codes^);

    /binary_search/
      WHILE (lower <= upper) DO
        temp := lower + upper;
        code_index := temp DIV 2;
        IF code = codes^ [code_index].code THEN
          entry_found := TRUE;
          IF (codes^ [code_index].name_index < 0) OR
                (codes^ [code_index].name_index >
                osc$max_status_condition_code) THEN
            EXIT /search_module/;
          IFEND;
          name_index := codes^ [code_index].name_index;
          EXIT /binary_search/;
        ELSEIF code > codes^ [code_index].code THEN
          lower := code_index + 1;
        ELSE
          upper := code_index - 1;
        IFEND;
      WHILEND /binary_search/;

      IF entry_found THEN
        name := names^ [name_index].name;
        severity := names^ [name_index].severity;
*IF NOT $true(osv$unix)
        template := #PTR (names^ [name_index].template, message_module^);
*ELSE
        template^ := names^ [name_index].template;
*IFEND
      IFEND;
      RETURN;
    END /search_module/;
    osp$set_status_abnormal ('CL', cle$bad_help_module, '', status);

  PROCEND clp$search_module_for_code;

*copyc cle$ecc_mt_generator
*copyc ost$message_module_severity
*copyc ost$message_template
*copyc ost$message_template_module
*copyc ost$mtm_condition_codes
*copyc ost$mtm_condition_names
*copyc ost$mtm_header
*copyc ost$natural_language
*copyc ost$status
*copyc ost$status_condition_code
*copyc ost$status_condition_name
?? POP ??
*copyc clp$extract_msg_module_contents
*copyc osp$set_status_abnormal
*DECK DECK=CLP$SEARCH_MODULE_FOR_NAME EXPAND=FALSE

  PROCEDURE [INLINE] clp$search_module_for_name
    (    message_module: ^ost$message_template_module;
         name: ost$status_condition_name;
     VAR language: ost$natural_language;
     VAR code: ost$status_condition_code;
     VAR severity: ost$message_module_severity;
     VAR template: ^ost$message_template;
     VAR entry_found: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      lower: 0 .. osc$max_status_condition_code + 1,
      upper: -1 .. osc$max_status_condition_code,
      codes: ^ost$mtm_condition_codes,
      names: ^ost$mtm_condition_names,
      header: ^ost$mtm_header,
      temp: integer,
      name_index: ost$message_template_index;

    entry_found := FALSE;
    clp$extract_msg_module_contents (message_module, header, codes, names);
    IF header = NIL THEN
      osp$set_status_abnormal ('CL', cle$bad_help_module, '', status);
      RETURN;
    IFEND;
    language := header^.language;
    lower := 0;
    upper := UPPERBOUND (names^);

  /binary_search/
    WHILE (lower <= upper) DO
      temp := lower + upper;
      name_index := temp DIV 2;
*IF NOT $true(osv$unix)
      IF (name = names^ [name_index].name) AND
            (names^ [name_index].kind = osc$status_message) THEN
*ELSE
      IF (name = names^ [name_index].name) THEN
*IFEND
        entry_found := TRUE;
        EXIT /binary_search/;
      ELSEIF name > names^ [name_index].name THEN
        lower := name_index + 1;
      ELSE
        upper := name_index - 1;
      IFEND;
    WHILEND /binary_search/;

    IF entry_found THEN
      code := names^ [name_index].code;
      severity := names^ [name_index].severity;
*IF NOT $true(osv$unix)
      template := #PTR (names^ [name_index].template, message_module^);
*ELSE
      template^ := names^ [name_index].template;
*IFEND
    IFEND;

  PROCEND clp$search_module_for_name;

*copyc cle$ecc_mt_generator
*copyc ost$message_module_severity
*copyc ost$message_template
*copyc ost$message_template_module
*copyc ost$mtm_condition_codes
*copyc ost$mtm_condition_names
*copyc ost$mtm_header
*copyc ost$natural_language
*copyc ost$status
*copyc ost$status_condition_code
*copyc ost$status_condition_name
?? POP ??
*copyc clp$extract_msg_module_contents
*copyc osp$set_status_abnormal
*DECK DECK=CLP$SEARCH_MSG_LIBRARY_VIA_CODE EXPAND=FALSE

  PROCEDURE [XREF] clp$search_msg_library_via_code
    (    caller_ring: ost$valid_ring;
         code: ost$status_condition_code;
         search_by_language: boolean;
         search_cache: boolean;
     VAR local_file_name {input, output} : amt$local_file_name;
     VAR name: ost$status_condition_name;
     VAR severity: ost$message_module_severity;
     VAR template: ^ost$message_template;
     VAR entry_found: boolean;
     VAR saved_default: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc osd$virtual_address
*copyc ost$message_module_severity
*copyc ost$message_template
*copyc ost$status
*copyc ost$status_condition_code
*copyc ost$status_condition_name
?? POP ??
*DECK DECK=CLP$SEARCH_MSG_LIBRARY_VIA_NAME EXPAND=FALSE

  PROCEDURE [XREF] clp$search_msg_library_via_name
    (    caller_ring: ost$valid_ring;
         name: ost$status_condition_name;
         search_by_language: boolean;
         search_cache: boolean;
     VAR local_file_name {input, output} : amt$local_file_name;
     VAR code: ost$status_condition_code;
     VAR severity: ost$message_module_severity;
     VAR template: ^ost$message_template;
     VAR entry_found: boolean;
     VAR saved_default: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc osd$virtual_address
*copyc ost$message_module_severity
*copyc ost$message_template
*copyc ost$status
*copyc ost$status_condition_code
*copyc ost$status_condition_name
?? POP ??
*DECK DECK=CLP$SEARCH_PARAMETER_NAMES EXPAND=FALSE

  PROCEDURE [INLINE] clp$search_parameter_names
    (    name: clt$parameter_name;
         names: ^clt$pdt_parameter_names;
     VAR index: clt$parameter_name_index;
     VAR found: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      low_index: 1 .. clc$max_parameter_names + 1,
      high_index: 0 .. clc$max_parameter_names,
      temp: integer,
      current_index: clt$parameter_name_index;


    found := FALSE;
    IF names <> NIL THEN
      low_index := 1;
      high_index := UPPERBOUND (names^);
      REPEAT
        temp := low_index + high_index;
        current_index := temp DIV 2;
        IF name = names^ [current_index].name THEN
          index := current_index;
          found := TRUE;
        ELSEIF name > names^ [current_index].name THEN
          low_index := current_index + 1;
        ELSE
          high_index := current_index - 1;
        IFEND;
      UNTIL found OR (low_index > high_index);
    IFEND;

  PROCEND clp$search_parameter_names;

*copyc clt$parameter_name
*copyc clt$parameter_name_index
*copyc clt$pdt_parameter_names
?? POP ??
*DECK DECK=CLP$SEND_EXITING_SIGNAL EXPAND=FALSE

  PROCEDURE [XREF] clp$send_exiting_signal
    (    target_task_id: pmt$task_id;
         targets_child_task_id: pmt$task_id;
         exit_control_block: ^clt$block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
*copyc ost$status
*copyc pmt$task_id
?? POP ??
*DECK DECK=CLP$SETUP_AND_PARSE_FILE_REF EXPAND=FALSE

  PROCEDURE [XREF] clp$setup_and_parse_file_ref
    (    file: fst$file_reference;
         file_reference_parsing_options: clt$file_ref_parsing_options;
         user_identification: clt$user_identification;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$file_ref_parsing_options
*copyc clt$user_identification
*copyc fst$evaluated_file_reference
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SETUP_PARAMETER_EVALUATION EXPAND=FALSE

  PROCEDURE [XREF] clp$setup_parameter_evaluation
    (    proc_pdt: ^clt$unbundled_pdt;
         proc_name: clt$command_name;
         reset_interpreter_mode: boolean;
     VAR parameter_list_parse: clt$parse_state;
     VAR work_area_ptr: ^^clt$work_area;
     VAR evaluation_context: clt$parameter_eval_context;
     VAR help_context: clt$parameter_help_context;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_name
*copyc clt$parameter_eval_context
*copyc clt$parameter_help_context
*copyc clt$parse_state
*copyc clt$unbundled_pdt
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SET_COMMAND_KIND EXPAND=FALSE

  PROCEDURE [XREF] clp$set_command_kind
    (    command_kind: clt$command_kind);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_kind
?? POP ??
*DECK DECK=CLP$SET_CURRENT_PROMPT_STRING EXPAND=FALSE

  PROCEDURE [XREF] clp$set_current_prompt_string
    (    prompt_string: ift$prompt_string);

?? PUSH (LISTEXT := ON) ??
*copyc ift$terminal_connection_types
?? POP ??
*DECK DECK=CLP$SET_EXIT_POSITION EXPAND=FALSE

  PROCEDURE [XREF] clp$set_exit_position;

*DECK DECK=CLP$SET_FORMAT_TYPE EXPAND=FALSE

  PROCEDURE [XREF] clp$set_format_type
    (    format_type: clt$format_token_type);

?? PUSH (LISTEXT := ON) ??
*copyc clt$format_token_type
?? POP ??
*DECK DECK=CLP$SET_HELP_MODE EXPAND=FALSE

  PROCEDURE [XREF] clp$set_help_mode
    (    help_output_file: ^fst$file_reference;
         help_output_options: clt$parameter_help_options);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_help_options
*copyc fst$file_reference
?? POP ??
*DECK DECK=CLP$SET_IF_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$set_if_block
    (    interpreter_mode: clt$interpreter_modes;
         if_condition_met: boolean;
         if_else_allowed: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc clt$interpreter_modes
?? POP ??
*DECK DECK=CLP$SET_INCLUDE_PROCESSOR_STATE EXPAND=FALSE

  PROCEDURE [XREF] clp$set_include_processor_state
    (    name: clt$utility_name;
         active: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$utility_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SET_INPUT_LINE EXPAND=FALSE

  PROCEDURE [XREF] clp$set_input_line
    (    line_kind: clt$input_line_kind;
         line_text: ^clt$command_line;
         line_identifier: clt$line_identifier;
         record_number: amt$file_byte_address;
         line_address: amt$file_byte_address);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc clt$command_line
*copyc clt$input_line_kind
*copyc clt$line_identifier
?? POP ??
*DECK DECK=CLP$SET_INPUT_LINE_FINISHED EXPAND=FALSE

  PROCEDURE [XREF] clp$set_input_line_finished;

*DECK DECK=CLP$SET_INPUT_LINE_PARSE EXPAND=FALSE

  PROCEDURE [XREF] clp$set_input_line_parse
    (    parse: clt$parse_state);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parse_state
?? POP ??
*DECK DECK=CLP$SET_INPUT_LINE_POSITION EXPAND=FALSE

  PROCEDURE [XREF] clp$set_input_line_position
    (    line_identifier: clt$line_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc clt$line_identifier
?? POP ??
*DECK DECK=CLP$SET_JOB_COMMAND_SEARCH_MODE EXPAND=FALSE

  PROCEDURE [XREF] clp$set_job_command_search_mode
    (    search_mode: clt$command_search_modes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_search_modes
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SET_LOCK_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] clp$set_lock_variable
    (    reference: clt$variable_ref_expression;
         wait: ost$wait;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$variable_ref_expression
*copyc ost$status
*copyc ost$wait
?? POP ??
*DECK DECK=CLP$SET_PREV_CMND_NAME_AND_STAT EXPAND=FALSE

  PROCEDURE [XREF] clp$set_prev_cmnd_name_and_stat
    (    command: ^clt$command_line;
         command_name: clt$command_name;
         command_status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc clt$command_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SET_PRIMARY_TASK EXPAND=FALSE

  PROCEDURE [XREF] clp$set_primary_task
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SET_PROCESSING_PHASE EXPAND=FALSE

  PROCEDURE [XREF] clp$set_processing_phase
    (    processing_phase: clt$processing_phase;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$processing_phase
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SET_PROMPTING_INPUT EXPAND=FALSE

  PROCEDURE [XREF] clp$set_prompting_input;

*DECK DECK=CLP$SET_PROMPT_STRING EXPAND=FALSE

  PROCEDURE [XREF] clp$set_prompt_string
    (    block: ^clt$block;
         prompt_string: string ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
?? POP ??
*DECK DECK=CLP$SET_REPEAT_UNTIL EXPAND=FALSE

  PROCEDURE [XREF] clp$set_repeat_until
    (    expression_parse: clt$parse_state);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parse_state
?? POP ??
*DECK DECK=CLP$SET_SECURE_LOGGING_ACTIVE EXPAND=FALSE

  PROCEDURE [XREF] clp$set_secure_logging_active
    (    activate: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SET_SYSTEM_LOGGING_ACTIVE EXPAND=FALSE

  PROCEDURE [XREF] clp$set_system_logging_active
    (    activate: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SET_TASK_STATEMENT_TASK EXPAND=FALSE

  PROCEDURE [XREF] clp$set_task_statement_task
    (    task_name: ost$name);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=CLP$SET_WHEN_CONDITION EXPAND=FALSE

  PROCEDURE [XREF] clp$set_when_condition
    (    condition: clt$when_condition);

?? PUSH (LISTEXT := ON) ??
*copyc clt$when_conditions
?? POP ??
*DECK DECK=CLP$SET_WORKING_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] clp$set_working_catalog
    (    catalog: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_file_reference
*copyc cle$ecc_lexical
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SET_WORKING_CATALOG_LFN EXPAND=FALSE

  PROCEDURE [XREF] clp$set_working_catalog_lfn
    (    catalog: clt$file);

?? PUSH (LISTEXT := ON) ??
*copyc clt$file
?? POP ??
*DECK DECK=CLP$SET_WORKING_CATALOG_PATH EXPAND=FALSE

  PROCEDURE [XREF] clp$set_working_catalog_path
    (    working_catalog_path_handle: amt$local_file_name;
         evaluated_file_reference: fst$evaluated_file_reference);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc fst$evaluated_file_reference
?? POP ??
*DECK DECK=CLP$SKIP_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] clp$skip_block;

*DECK DECK=CLP$SKIP_SPACES_AND_COMMENTS EXPAND=FALSE

  PROCEDURE [INLINE] clp$skip_spaces_and_comments
    (    text: string ( * );
         start_index: ost$string_index;
     VAR end_index: ost$string_index;
     VAR found_space_or_comment: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      found_char: boolean,
      scan_index: integer,
      text_index: ost$string_index;

    text_index := start_index;

  /scan_loop/
    WHILE text_index <= STRLENGTH (text) DO
      #SCAN (clv$non_space, text (text_index, * ), scan_index, found_char);
      text_index := scan_index + text_index - 1;
      IF found_char AND (text (text_index) = '"') THEN
        #SCAN (clv$comment_delimiter, text (text_index + 1, * ), scan_index,
              found_char);
        text_index := scan_index + text_index + $INTEGER (found_char);
      ELSEIF scan_index <= 1 THEN
        EXIT /scan_loop/;
      IFEND;
    WHILEND /scan_loop/;
    end_index := text_index;
    found_space_or_comment := text_index > start_index;

  PROCEND clp$skip_spaces_and_comments;

*copyc ost$string
?? POP ??
*copyc clv$comment_delimiter
*copyc clv$non_space
*DECK DECK=CLP$SORT_RECORD_FIELDS EXPAND=FALSE

  PROCEDURE [INLINE] clp$sort_record_fields
    (VAR field_values {input, output} : array [1 .. * ] of clt$field_value);

?? PUSH (LISTEXT := ON) ??

    VAR
      current: -clc$max_fields .. clc$max_fields,
      gap: clt$field_number,
      start: clt$field_number,
      swap: clt$field_value;


    gap := UPPERBOUND (field_values);
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := 1 TO UPPERBOUND (field_values) - gap DO
        current := start;
        WHILE (current > 0) AND (field_values [current].
              name > field_values [current + gap].name) DO
          swap := field_values [current];
          field_values [current] := field_values [current + gap];
          field_values [current + gap] := swap;
          current := current - gap;
        WHILEND;
      FOREND;
    WHILEND;

  PROCEND clp$sort_record_fields;

*copyc clt$field_number
*copyc clt$field_value
?? POP ??
*DECK DECK=CLP$SP_CONVERT_TO_STRING EXPAND=FALSE

  PROCEDURE [XREF] clp$sp_convert_to_string
    (    source_pattern: ^clt$string_pattern;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result_string: ^clt$string_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$string_pattern
*copyc clt$string_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SP_PATTERN_CONCAT_PATTERN EXPAND=FALSE

  PROCEDURE [XREF] clp$sp_pattern_concat_pattern
    (    left_pattern: ^clt$string_pattern;
         right_pattern: ^clt$string_pattern;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result_pattern: ^clt$string_pattern;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$string_pattern
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SP_PATTERN_CONCAT_STRING EXPAND=FALSE

  PROCEDURE [XREF] clp$sp_pattern_concat_string
    (    left_pattern: ^clt$string_pattern;
         right_string: ^clt$string_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result_pattern: ^clt$string_pattern;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$string_pattern
*copyc clt$string_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SP_PATTERN_OR_PATTERN EXPAND=FALSE

  PROCEDURE [XREF] clp$sp_pattern_or_pattern
    (    first_pattern: ^clt$string_pattern;
         second_pattern: ^clt$string_pattern;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result_pattern: ^clt$string_pattern;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$string_pattern
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SP_STRING_CONCAT_PATTERN EXPAND=FALSE

  PROCEDURE [XREF] clp$sp_string_concat_pattern
    (    left_string: ^clt$string_value;
         right_pattern: ^clt$string_pattern;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result_pattern: ^clt$string_pattern;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$string_pattern
*copyc clt$string_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SP_STRING_LITERAL EXPAND=FALSE

  PROCEDURE [XREF] clp$sp_string_literal
    (    string_literal: ^clt$string_value;
         case_sensitive: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR pattern: ^clt$string_pattern;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$string_pattern
*copyc clt$string_value
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$STATUS_COMPARE EXPAND=FALSE

  FUNCTION [XREF] clp$status_compare
    (    left_status: ost$status;
         right_status: ost$status): clt$comparison_result;

?? PUSH (LISTEXT := ON) ??
*copyc clt$comparison_result
*copyc ost$status
?? POP ??
*DECK DECK=CLP$STORE_DISPLAY_LOG_INDICES EXPAND=FALSE

  PROCEDURE [XREF] clp$store_display_log_indices
    (    indices: clt$display_log_indices);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_log_indices
?? POP ??
*DECK DECK=CLP$STORE_EXPANDABLE_STRING EXPAND=FALSE

  PROCEDURE [INLINE] clp$store_expandable_string
    (    text: ^clt$string_value;
         lexical_units: ^clt$lexical_units;
     VAR expandable_string {input, output} : clt$expandable_string);

?? PUSH (LISTEXT := ON) ??

    VAR
      current_area_size: integer,
      needed_area_size: integer,
      new_area: ^SEQ ( * ),
      new_text: ^clt$string_value,
      old_text: ^clt$string_value;


    IF expandable_string.area = NIL THEN
      current_area_size := 0;
    ELSE
      current_area_size := #SIZE (expandable_string.area^);
    IFEND;

    IF text <> NIL THEN
      old_text := text;
    ELSE
      old_text := expandable_string.text;
    IFEND;

    needed_area_size := #SIZE (old_text^) + 1;
    IF lexical_units <> NIL THEN
      needed_area_size := needed_area_size + #SIZE (lexical_units^);
    IFEND;

    IF (needed_area_size <= current_area_size) AND
          (expandable_string.area <> NIL) THEN
      IF text <> NIL THEN
        RESET expandable_string.area;
        NEXT expandable_string.text: [STRLENGTH (text^)] IN
              expandable_string.area;
        expandable_string.text^ := text^;
      IFEND;
    ELSE
      ALLOCATE new_area: [[REP ((needed_area_size + clc$expansion_chunk_size -
            1) DIV clc$expansion_chunk_size) * clc$expansion_chunk_size OF
            cell]] IN osv$task_shared_heap^;
      RESET new_area;
      NEXT new_text: [STRLENGTH (old_text^)] IN new_area;
      new_text^ := old_text^;
      IF expandable_string.area <> NIL THEN
        FREE expandable_string.area IN osv$task_shared_heap^;
      IFEND;
      expandable_string.area := new_area;
      expandable_string.text := new_text;
    IFEND;

    IF lexical_units = NIL THEN
      expandable_string.lexical_units := NIL;
    ELSE
      NEXT expandable_string.lexical_units:
            [1 .. UPPERBOUND (lexical_units^)] IN expandable_string.area;
      expandable_string.lexical_units^ := lexical_units^;
    IFEND;

  PROCEND clp$store_expandable_string;

*copyc clt$expandable_string
*copyc clt$lexical_units
*copyc clt$string_value
?? POP ??
*copyc osv$task_shared_heap
*DECK DECK=CLP$STORE_STD_PATH_HANDLE_NAMES EXPAND=FALSE

  PROCEDURE [XREF] clp$store_std_path_handle_names
    (    executing_within_system_job: boolean;
         first_time: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$STORE_SYSTEM_FILE_ID EXPAND=FALSE

  PROCEDURE [XREF] clp$store_system_file_id
    (    file_name: amt$local_file_name;
         file_id: amt$file_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc clc$standard_file_names
?? POP ??
*DECK DECK=CLP$STORE_UTILITY_DIALOG_INFO EXPAND=FALSE

  PROCEDURE [XREF] clp$store_utility_dialog_info
    (    utility: clt$utility_name;
         commands: ^clt$command_table;
         functions: ^clt$function_processor_table;
         create_scratch_segment: boolean;
     VAR dialog_info: ^clt$utility_dialog_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_table
*copyc clt$function_processor_table
*copyc clt$utility_dialog_info
*copyc clt$utility_name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$STRING_COMPARE EXPAND=FALSE

  FUNCTION [INLINE] clp$string_compare
    (    left_string: ^string ( * );
         right_string: ^string ( * )): clt$comparison_result;

?? PUSH (LISTEXT := ON) ??

    IF (left_string = NIL) OR (right_string = NIL) THEN
      clp$string_compare := clc$unordered;
    ELSEIF left_string^ < right_string^ THEN
      clp$string_compare := clc$right_is_greater;
    ELSEIF left_string^ = right_string^ THEN
      clp$string_compare := clc$equal;
    ELSE
      clp$string_compare := clc$left_is_greater;
    IFEND;

  FUNCEND clp$string_compare;

*copyc clt$comparison_result
?? POP ??
*DECK DECK=CLP$SUBMIT_JOB EXPAND=FALSE

  PROCEDURE [XREF] clp$submit_job
    (    local_file_name: amt$local_file_name;
         job_name: jmt$user_supplied_name;
         output_destination: ost$user_identification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc jmt$user_supplied_name
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=CLP$SUBSTITUTE_DELIMITED_TEXT EXPAND=FALSE

  PROCEDURE [XREF] clp$substitute_delimited_text
    (    old_text: clt$command_line;
         delimiter: char;
     VAR new_text: clt$command_line;
     VAR new_text_size: clt$command_line_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc clt$command_line_size
*copyc ost$status
?? POP ??


*DECK DECK=CLP$SUPPRESS_COMMAND_LOGGING EXPAND=FALSE

  PROCEDURE [XREF] clp$suppress_command_logging;

*DECK DECK=CLP$SYSTEM_PROLOG_PHASE_1 EXPAND=FALSE
PROCEDURE [XREF] clp$system_prolog_phase_1
    (VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$SYSTEM_PROLOG_PHASE_2 EXPAND=FALSE
PROCEDURE [XREF] clp$system_prolog_phase_2
    (VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$TEST_PARAMETER EXPAND=FALSE

  PROCEDURE [XREF] clp$test_parameter
    (    parameter_name: string ( * );
     VAR parameter_specified: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CLP$TEST_PROC_PARAMETER EXPAND=FALSE

  PROCEDURE [XREF] clp$test_proc_parameter
    (    parameter_name: string ( * );
     VAR parameter_specified: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$TEST_PROC_RANGE EXPAND=FALSE

  PROCEDURE [XREF] clp$test_proc_range
    (    parameter_name: string ( * );
         value_set_number: 1 .. clc$max_value_sets;
         value_number: 1 .. clc$max_values_per_set;
     VAR work_area {input, output} : ^clt$work_area;
     VAR range_specified: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_limits
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$TEST_RANGE EXPAND=FALSE

  PROCEDURE [XREF] clp$test_range
    (    parameter_name: string ( * );
         value_set_number: 1 .. clc$max_value_sets;
         value_number: 1 .. clc$max_values_per_set;
     VAR range_specified: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_limits
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CLP$TIME_INCREMENT_COMPARE EXPAND=FALSE

  FUNCTION [XREF] clp$time_increment_compare
    (    left_time_increment: pmt$time_increment;
         right_time_increment: pmt$time_increment): clt$comparison_result;

?? PUSH (LISTEXT := ON) ??
*copyc clt$comparison_result
*copyc pmt$time_increment
?? POP ??
*DECK DECK=CLP$TRANSLATE_ADT EXPAND=FALSE

  PROCEDURE [XREF] clp$translate_adt
    (    old_adt: ^clt$argument_descriptor_table;
         group_keywords: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR application_type_present: boolean;
     VAR new_pdt: clt$unbundled_pdt;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$argument_descriptor_table
*copyc clt$unbundled_pdt
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$TRANSLATE_FUNCTION EXPAND=FALSE

  PROCEDURE [XREF] clp$translate_function (input_line_ptr: ^clt$command_line;
        output_line_ptr: ^clt$command_line;
        function_begin_index: clt$token_array_index;
    VAR function_end_index : clt$token_array_index;
        array_ptr: ^clt$format_token_array;
        max_array_index: clt$token_array_index;
    VAR output_line_size: clt$command_line_size;
    VAR name_only_translated: boolean;
    VAR name_to_flag: ost$name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc clt$command_line_size
*copyc clt$format_token_type
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$TRANSLATE_PDT EXPAND=FALSE

  PROCEDURE [XREF] clp$translate_pdt
    (    old_pdt: clt$parameter_descriptor_table;
         encode_file_values: boolean;
         group_keywords: boolean;
         report_status_procedure: ^procedure
           (    parameter_name: clt$parameter_name;
                error_status: ost$status;
            VAR status: ost$status);
         symbolic_parameters: ^clt$symbolic_parameters;
         symbolic_qualifiers_area: ^clt$work_area;
     VAR work_area {input, output} : ^clt$work_area;
     VAR application_type_present: boolean;
     VAR new_pdt: clt$unbundled_pdt;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_descriptor_table
*copyc clt$parameter_name
*copyc clt$symbolic_parameters
*copyc clt$unbundled_pdt
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$TRANSLATE_VKS EXPAND=FALSE

  PROCEDURE [XREF] clp$translate_vks
    (    old_vks: clt$value_kind_specifier;
         group_keywords: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR application_type_present: boolean;
     VAR new_type_description: clt$type_description;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$type_description
*copyc clt$value_kind_specifier
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$TRIMMED_STRING_SIZE EXPAND=FALSE

  FUNCTION [INLINE] clp$trimmed_string_size
    (    str: string ( * )): integer;

?? PUSH (LISTEXT := ON) ??

    VAR
      horizontal_tab: char,
      size: ost$non_negative_integers,
      space: char;

    horizontal_tab := $CHAR (9);
    size := STRLENGTH (str);
    space := ' ';

    WHILE (size > 0) AND ((str (size) = space) OR (str (size) =
          horizontal_tab)) DO
      size := size - 1;
    WHILEND;
    clp$trimmed_string_size := size;

  FUNCEND clp$trimmed_string_size;

*copyc osd$integer_limits
?? POP ??
*DECK DECK=CLP$TURN_KEYPOINT_OFF EXPAND=FALSE

  PROCEDURE [XREF] clp$turn_keypoint_off
    (    environment: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CLP$TYPE_DESC_IS_FOR_OLD_UNION EXPAND=FALSE

  FUNCTION [XREF] clp$type_desc_is_for_old_union
    (    type_description: ^clt$type_description): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc clt$type_description
?? POP ??
*DECK DECK=CLP$UNBUNDLE_PDT EXPAND=FALSE

  PROCEDURE [XREF] clp$unbundle_pdt
    (    parameter_description_table: ^clt$parameter_description_table;
     VAR work_area {input, output} : ^clt$work_area;
     VAR unbundled_pdt: clt$unbundled_pdt;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_description_table
*copyc clt$unbundled_pdt
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$UNHASH_VARIABLE_NAME EXPAND=FALSE

  PROCEDURE [INLINE] clp$unhash_variable_name
    (    hashed_name: clt$variable_name;
     VAR name: clt$variable_name);

?? PUSH (LISTEXT := ON) ??

{ "Unswap" the first group of four characters in the name with the third group
{ of four characters which had been done to improve the distribution of names
{ within a search tree (by clp$compute_variable_name_hash).

    name (1, 4) := hashed_name (9, 4);
    name (5, 4) := hashed_name (5, 4);
    name (9, 4) := hashed_name (1, 4);
    name (13, * ) := hashed_name (13, *);

  PROCEND clp$unhash_variable_name;

*copyc clt$variable_name
?? POP ??
*DECK DECK=CLP$UNPASS_VARIABLE_PARAMETER EXPAND=FALSE

  PROCEDURE [XREF] clp$unpass_variable_parameter
    (    parameter_number: clt$parameter_number);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_number
?? POP ??
*DECK DECK=CLP$UNSPECIFIED_AV_SCANNER EXPAND=FALSE

  PROCEDURE [XREF] clp$unspecified_av_scanner
    (    value_name: clt$application_value_name;
         keyword_values: ^array [1 .. * ] of ost$name;
         text: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$application_value_scanner
?? POP ??
*DECK DECK=CLP$UPDATE_ALL_ENVIRONMENT EXPAND=FALSE

  PROCEDURE [XREF] clp$update_all_environment
    (    synchronous_with_parent: boolean;
         synchronous_with_job: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CLP$UPDATE_APPLIC_RESOURCES EXPAND=FALSE


  PROCEDURE [XREF] clp$update_applic_resources
    (    cp_time: pmt$task_cp_time;
         paging_stats: ost$paging_statistics);

?? PUSH (LISTEXT := ON) ??
*copyc ost$paging_statistics
*copyc pmt$task_cp_time
?? POP ??
*DECK DECK=CLP$UPDATE_COMMAND_LIST EXPAND=FALSE
*DECK DECK=CLP$UPDATE_CONNECTED_FILES EXPAND=FALSE
  PROCEDURE [XREF] clp$update_connected_files
    (    new_ring: ost$valid_ring );
?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
?? POP ??
*DECK DECK=CLP$UPDATE_PARSE_STATE EXPAND=FALSE

  PROCEDURE [INLINE] clp$update_parse_state
    (    source_parse: clt$parse_state;
     VAR target_parse: clt$parse_state);

?? PUSH (LISTEXT := ON) ??

    IF source_parse.text = NIL THEN
      clp$initialize_parse_state (target_parse.text, target_parse.units_array,
            target_parse);
    ELSE
      target_parse.index := source_parse.index;
      target_parse.units_array_index := source_parse.units_array_index;
      target_parse.index_limit := source_parse.index_limit;
      target_parse.unit := source_parse.unit;
      target_parse.unit_index := source_parse.unit_index;
      target_parse.unit_is_space := source_parse.unit_is_space;
      target_parse.previous_unit_is_space :=
            source_parse.previous_unit_is_space;
      target_parse.previous_non_space_unit :=
            source_parse.previous_non_space_unit;
      target_parse.previous_non_space_unit_index :=
            source_parse.previous_non_space_unit_index;
    IFEND;

  PROCEND clp$update_parse_state;

*copyc clt$parse_state
?? POP ??
*copyc clp$initialize_parse_state
*DECK DECK=CLP$UPDATE_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] clp$update_variable
    (    reference: ^clt$variable_ref_expression;
         new_value: clt$variable_value_description;
     VAR work_area {input, output}: ^clt$work_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$variable_ref_expression
*copyc clt$variable_value_description
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$VALIDATE_DATE_TIME EXPAND=FALSE


  PROCEDURE [XREF] clp$validate_date_time
    (    date_time: clt$date_time;
         str: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$date_time
*copyc ost$status
?? POP ??
*DECK DECK=CLP$VALIDATE_LOCAL_FILE_NAME EXPAND=FALSE

  PROCEDURE [INLINE] clp$validate_local_file_name
    (    potential_name: fst$file_reference;
     VAR local_file_name: amt$local_file_name;
     VAR path_handle: fmt$path_handle;
     VAR name_is_path_handle: boolean;
     VAR name_is_valid: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      cl_path_handle: clt$path_handle,
      name_size: fst$path_size;

    name_size := STRLENGTH (potential_name);
    WHILE (name_size > 1) AND (potential_name (name_size) = ' ') DO
      name_size := name_size - 1;
    WHILEND;
    name_is_path_handle := FALSE;
    IF name_size > STRLENGTH (amt$local_file_name) THEN
      name_is_valid := FALSE;
    ELSE
      clp$validate_name (potential_name (1, name_size), local_file_name,
            name_is_valid);
      IF name_is_valid THEN
        clp$check_name_for_path_handle (local_file_name, cl_path_handle);
        IF cl_path_handle.kind = clc$regular_path_handle THEN
          name_is_path_handle := TRUE;
          path_handle := cl_path_handle.regular_handle;
        IFEND;
      IFEND;
    IFEND;

  PROCEND clp$validate_local_file_name;

*copyc amt$local_file_name
*copyc fmt$path_handle
*copyc fst$file_reference
*copyc fst$path_size
?? POP ??
*copyc clp$check_name_for_path_handle
*copyc clp$validate_name
*DECK DECK=CLP$VALIDATE_NAME EXPAND=FALSE

  PROCEDURE [INLINE] clp$validate_name
    (    potential_name: string ( * <= osc$max_name_size);
     VAR validated_name: ost$name;
     VAR name_is_valid: boolean);

?? PUSH (LISTEXT := ON) ??
{ When a change is made to this routine, a corresponding change should be
{ made to clp$only_validate_name if necessary.

    TYPE
      char_set = set of char;

    VAR
      ignore_scan_found_char: boolean,
      non_name_chars: char_set,
      scan_index: 1 .. osc$max_name_size + 1;

    #TRANSLATE (osv$lower_to_upper, potential_name, validated_name);
    CASE validated_name (1) OF
    = '#', '$', '@', 'A' .. 'Z', '[', '\', ']', '^', '_', '`', '{', '|', '}',
          '~' =
      non_name_chars := -$char_set ['#', '$', '0', '1', '2', '3', '4', '5',
            '6', '7', '8', '9', '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H',
            'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U',
            'V', 'W', 'X', 'Y', 'Z', '[', '\', ']', '^', '_', '`', '{', '|',
            '}', '~'];
      #SCAN (non_name_chars, validated_name, scan_index,
            ignore_scan_found_char);
      name_is_valid := validated_name (scan_index, * ) = '';
    ELSE
      name_is_valid := FALSE;
    CASEND;

  PROCEND clp$validate_name;

*copy clh$validate_name

*copyc ost$name
?? POP ??
*copyc osv$lower_to_upper
*DECK DECK=CLP$VALIDATE_NEW_FILE_NAME EXPAND=FALSE

  PROCEDURE [XREF] clp$validate_new_file_name
    (    file_name: string ( * <= fsc$max_path_element_size);
     VAR validated_file_name: ost$name;
     VAR name_is_valid_new_file_name: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc fsc$max_path_element_size
*copyc ost$name
?? POP ??

*DECK DECK=CLP$VALIDATE_NEW_LFN EXPAND=FALSE

  PROCEDURE [XREF] clp$validate_new_lfn
    (    local_file_name: string ( * <= fsc$max_path_element_size);
     VAR validated_local_file_name: ost$name;
     VAR name_is_valid_new_lfn: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc fsc$max_path_element_size
*copyc ost$name
?? POP ??

*DECK DECK=CLP$VALIDATE_TYPE_CONFORMANCE EXPAND=FALSE

  PROCEDURE [XREF] clp$validate_type_conformance
    (    candidate_type_description: ^clt$type_description;
         base_type_description: ^clt$type_description;
     VAR type_conformance: clt$type_conformance);

?? PUSH (LISTEXT := ON) ??
*copyc clt$type_conformance
*copyc clt$type_description
?? POP ??
*DECK DECK=CLP$VALIDATE_VALUE_CONFORMANCE EXPAND=FALSE

  PROCEDURE [XREF] clp$validate_value_conformance
    (    value: ^clt$data_value;
         type_description: ^clt$type_description;
     VAR type_conformance: clt$type_conformance);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$type_conformance
*copyc clt$type_description
?? POP ??
*DECK DECK=CLP$VALIDATE_VAR_CONFORMANCE EXPAND=FALSE

  PROCEDURE [XREF] clp$validate_var_conformance
    (    subject_type_description: ^clt$type_description;
         target_type_description: ^clt$type_description;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$type_description
*copyc ost$status
?? POP ??
*DECK DECK=CLP$VALUE_TO_STRING EXPAND=FALSE

  PROCEDURE [XREF] clp$value_to_string
    (    value: clt$value;
         external_radix_spec: clt$external_radix_spec;
     VAR str: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc clt$external_radix_spec
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CLP$VERIFY_TIME_INCREMENT EXPAND=FALSE

  PROCEDURE [XREF] clp$verify_time_increment
    (    time_increment: pmt$time_increment;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$time_increment
?? POP ??
*DECK DECK=CLP$VERTICAL_TAB_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] clp$vertical_tab_display
    (VAR display_control {input, output} : clt$display_control;
         line_number: amt$page_length;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amd$page_format_declarations
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=CLP$WILD_CARD_FILE_EXPANSION EXPAND=FALSE

  PROCEDURE [XREF] clp$wild_card_file_expansion
    (    evaluated_file_reference: fst$evaluated_file_reference;
         expansion_option: clt$wc_file_expansion_option;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result_list_head: ^clt$data_value;
     VAR result_list_tail: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$no_match_for_wild_card_file
*copyc cle$wild_card_cant_be_first
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$wc_file_expansion_option
*copyc clt$work_area
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=CLP$WRITE_QUALIFIED_DATA_VALUE EXPAND=FALSE

  PROCEDURE [XREF] clp$write_qualified_data_value
    (    name: clt$variable_name;
         value_qualifiers : ^clt$value_qualifiers;
         old_value: ^clt$internal_data_value;
         replacement_value: ^clt$data_value;
         conformance_checked: boolean;
         allow_padding_or_truncation: boolean;
     VAR work_area {input, output} : ^clt$work_area;
     VAR new_value: ^clt$internal_data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$internal_data_value
*copyc clt$value_qualifiers
*copyc clt$variable_name
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=CLP$WRITE_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] clp$write_variable
    (    reference: string ( * );
         value: clt$variable_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$variable_reference
*copyc cle$ecc_variable
*copyc ost$status
?? POP ??
*DECK DECK=CLS$ADT_SECTIONS EXPAND=FALSE

  SECTION
    cls$adt: READ,
    cls$adt_names_and_defaults: READ;

*DECK DECK=CLS$DECLARATION_SECTION EXPAND=FALSE

  SECTION
    cls$declaration_section: READ;

*DECK DECK=CLS$PDT_SECTIONS EXPAND=FALSE

  SECTION
    cls$pdt: READ,
    cls$pdt_parameters: READ,
    cls$pdt_names_and_defaults: READ;

*DECK DECK=CLT$ACCESS_VARIABLE_REQUEST EXPAND=FALSE

  TYPE
    clt$access_variable_request = (clc$return_internal_value,
          clc$return_type_description, clc$return_type_specification,
          clc$return_value_qualifiers, clc$type_spec_if_defer_method,
          clc$value_info_if_defer_value, clc$possible_file_reference,
          clc$convert_nil_value_to_unspec);
*DECK DECK=CLT$ACCESS_VARIABLE_REQUESTS EXPAND=FALSE

  TYPE
    clt$access_variable_requests = set of clt$access_variable_request;

*copyc clt$access_variable_request

*DECK DECK=CLT$APPLICATION_INFO EXPAND=FALSE

  TYPE
    clt$application_info = record
      lock: ost$signature_lock,
      identifier: llt$application_identifier,
      nested_identifier: llt$application_identifier,
      library_privilege: ost$name,
      task_link_head: ^clt$block,
      previous_info: ^clt$application_info,
      application_scheduling: boolean,
      application_index: jmt$application_index,
      service_accumulator: jmt$service_accumulator,
      previous_scheduled_block: ^clt$block,
      accumulated_cp_time: pmt$task_cp_time,
      accumulated_paging_stats: ost$paging_statistics,
      unit_info: ^clt$application_unit_info,
      case module_kind: llt$library_module_kind of
      = llc$applic_command_procedure, llc$applic_command_description =
        procedure_cp_time: pmt$task_cp_time,
        procedure_paging_stats: ost$paging_statistics,
      = llc$applic_program_description =
        ,
      = llc$load_module =
        ,
      casend,
    recend;

*copyc clt$block
*copyc clt$application_unit_info
*copyc jmt$application_index
*copyc jmt$service_accumulator
*copyc llt$application_identifier
*copyc ost$name
*copyc ost$paging_statistics
*copyc ost$signature_lock
*copyc pmt$task_cp_time
*DECK DECK=CLT$APPLICATION_TYPE_QUALIFIER EXPAND=FALSE

  TYPE
    clt$application_type_qualifier = record
      balance_brackets: boolean,
    recend;

*DECK DECK=CLT$APPLICATION_UNIT_ARRAY EXPAND=FALSE

  TYPE
    clt$application_unit_array = array [1 .. * ] of integer;

*DECK DECK=CLT$APPLICATION_UNIT_ARRAY_SIZE EXPAND=FALSE

  TYPE
    clt$application_unit_array_size = 1 .. 255;

*copyc sft$counters
*DECK DECK=CLT$APPLICATION_UNIT_INFO EXPAND=FALSE

  TYPE
    clt$application_unit_info = record
      module_name: ost$name,
      identifier: llt$application_identifier,
      nested_identifier: llt$application_identifier,
      library_privilege: ost$name,
      unit_array: ^clt$application_unit_array,
      unit_array_size: clt$application_unit_array_size,
      unit_info: ^clt$application_unit_info,
    recend;

*copyc clt$application_unit_array
*copyc clt$application_unit_array_size
*copyc llt$application_identifier
*copyc ost$name
*DECK DECK=CLT$APPLICATION_VALUE EXPAND=FALSE

  TYPE
    clt$application_value = SEQ (ost$string);

  TYPE
    clt$application_value_name = ost$name;

*copyc ost$name
*copyc ost$string
*DECK DECK=CLT$APPLICATION_VALUE_AREA EXPAND=FALSE

  TYPE
    clt$application_value_text_area = SEQ (ost$string);

*copyc ost$string
*DECK DECK=CLT$APPLICATION_VALUE_NAME EXPAND=FALSE

  TYPE
    clt$application_value_text_name = ost$name;

*copyc ost$name
*DECK DECK=CLT$APPLICATION_VALUE_TEXT EXPAND=FALSE

  TYPE
    clt$application_value_text = clt$expression_text;

*copyc clt$expression_text
*DECK DECK=CLT$ARGUMENT_DESCRIPTOR_TABLE EXPAND=FALSE

  CONST
    clc$max_arguments = osc$max_string_size DIV 2;

  TYPE
    clt$argument_descriptor = record
      required_or_optional: clt$required_or_optional,
      value_kind_specifier: clt$value_kind_specifier,
    recend,
    clt$argument_descriptor_table = array [1 .. * ] of clt$argument_descriptor;

*copyc cls$adt_sections
*copyc clt$required_or_optional
*copyc clt$value_kind_specifier
*copyc ost$string
*DECK DECK=CLT$ARGUMENT_VALUE_TABLE EXPAND=FALSE

  TYPE
    clt$argument_value_table = array [1 .. * ] of clt$value;

*copyc cld$value
*DECK DECK=CLT$ARRAY_BOUND EXPAND=FALSE

  TYPE
    clt$array_bound = clc$min_array_bound .. clc$max_array_bound;

*copyc clc$max_array_bound
*copyc clc$min_array_bound
*DECK DECK=CLT$ARRAY_BOUNDS EXPAND=FALSE

  TYPE
    clt$array_bounds = record
      lower: clt$array_bound,
      upper: clt$array_bound,
    recend;

*copyc clt$array_bound
*DECK DECK=CLT$ARRAY_TYPE_QUALIFIER EXPAND=FALSE

  TYPE
    clt$array_type_qualifier = record
      element_type_specification_size: clt$type_specification_size,
      case array_bounds_defined: boolean of
      = TRUE =
        bounds: clt$array_bounds,
      = FALSE =
        ,
      casend,
      { A clt$type_specification for the element type follows the }
      { clt$array_type_qualifier. }
    recend;

*copyc clt$array_bounds
*copyc clt$type_specification
*copyc clt$type_specification_size
*DECK DECK=CLT$ASYNC_COMMAND_PARAMETERS EXPAND=FALSE

  TYPE
    clt$async_command_parameters = record
      command_can_be_echoed: boolean,
      init_from_desktop_environment: boolean,
      text_size: clt$string_size,
      units_array_size: clt$string_size,
      parse: clt$parse_state,
    recend;

*copyc clt$parse_state
*copyc clt$string_size
*DECK DECK=CLT$AV_EVALUATOR_CALL_METHOD EXPAND=FALSE

  TYPE
    clt$av_evaluator_call_method = clc$unspecified_call .. clc$proc_call;

*copyc clt$call_method
*DECK DECK=CLT$AV_EVALUATOR_NAME EXPAND=FALSE

  TYPE
    clt$av_evaluator_name = ost$name;

*copyc ost$name
*DECK DECK=CLT$BLOCK EXPAND=FALSE

  TYPE
*IF NOT $true(osv$unix)
    clt$block_kind = (clc$block_block, clc$case_block, clc$check_block,
          clc$command_block, clc$command_proc_block, clc$for_block,
          clc$function_block, clc$function_proc_block, clc$if_block,
          clc$input_block, clc$loop_block, clc$repeat_block,
          clc$sub_parameters_block, clc$task_block, clc$utility_block,
          clc$when_block, clc$while_block);
*ELSE
    clt$block_kind = (clc$command_block, clc$function_block, clc$input_block,
          clc$task_block, clc$utility_block);
*IFEND

  TYPE
    clt$block_kinds = set of clt$block_kind;

  TYPE
    clt$block = record
      access_count: ALIGNED [0 MOD 8] integer,
      assignment_counter: integer,
      previous_block: ^clt$block,
*IF NOT $true(osv$unix)
      static_link: ^clt$block,
      started_application: boolean,
      application_info: ^clt$application_info,
      caller_ring: ost$valid_ring,
      active_capabilities: avt$conditional_capabilities,
*IFEND
      interpreter_mode: clt$interpreter_modes,
*IF NOT $true(osv$unix)
      variables: clt$variables,
*IFEND
      parameters: clt$parameters,
      source: clt$command_or_function_source,
      use_command_search_mode: boolean,
      prompting_requested: boolean,
*IF NOT $true(osv$unix)
      established_handler_info: clt$established_handler_info,
*IFEND
      environment_object_info: ^clt$environment_object_info,
      line_identifier: clt$line_identifier,
      line_parse: clt$parse_state,
*IF NOT $true(osv$unix)
      input_can_be_echoed: boolean,
*IFEND
      being_exited: boolean,
      exit_position: record
        case defined: boolean of
*IF $true(osv$unix)
        = FALSE =
          ,
*IFEND
        = TRUE =
          line_identifier: clt$line_identifier,
          line_parse: clt$parse_state,
        casend,
      recend,
      inheriting_block: ^clt$block,
      label: ost$name,
      kind_name: string (14) {longest is "sub_parameters"} ,
      kind_end_name: string (18) {longest is "sub_parameters_end"} ,
      case kind: clt$block_kind of
*IF NOT $true(osv$unix)
      = clc$block_block =
        ,
      = clc$case_block =
        case_selection_value: ^clt$internal_data_value,
        case_selection_encounterred: boolean,
        case_selection_made: boolean,
        case_else_allowed: boolean,
      = clc$check_block =
        check_status: ost$status,
*IFEND
      = clc$command_block =
        command_kind: clt$command_kind,
*IF NOT $true(osv$unix)
        command_logging_completed: boolean,
        command_echoing_completed: boolean,
*IFEND
        help_output_file: ^fst$file_reference,
        help_output_options: clt$parameter_help_options,
*IF NOT $true(osv$unix)
        edited_parameters_max_size: clt$string_size,
        edited_parameters: ^clt$data_representation,
      = clc$command_proc_block, clc$function_proc_block, clc$input_block,
            clc$when_block =
*ELSE
      = clc$input_block =
*IFEND
        inherited_input: record
          case found: boolean of
          = TRUE =
            block: ^clt$block,
            in_current_task: boolean,
          casend,
        recend,
        input: record
          internal: boolean,
          prompting_input: boolean,
          line: clt$expandable_string,
          pushed_line: ^clt$pushed_line,
          case kind: (clc$line_input, clc$file_input, clc$sequence_input) of
          = clc$file_input, clc$sequence_input =
*IF NOT $true(osv$unix)
            local_file_name: fst$path_handle_name,
*ELSE
            local_file_name: fst$path,
*IFEND
            file_id: amt$file_identifier,
            line_layout: clt$line_layout,
            get_command_line: ^procedure
                   (VAR parse: clt$parse_state;
                    VAR end_of_input: boolean;
                    VAR status: ost$status),
            get_line: ^procedure (    line_kind: clt$input_line_kind;
                                      prompt_string: clt$prompt_string;
                                  VAR status: ost$status),
            data_line: clt$expandable_string,
            line_address_is_for_previous: boolean,
            line_address: amt$file_byte_address,
            record_number: amt$file_byte_address,
            data: ^clt$input_data,
            file_rereadable: boolean,
            interactive_device: boolean,
            device_class: rmt$device_class,
            base_prompt_string: ift$prompt_string,
            current_prompt_string: ift$prompt_string,
            case state: clt$input_state of
            = clc$reset_input =
              reset_line_identifier: clt$line_identifier,
              reset_line_parse: clt$parse_state,
            casend,
          casend,
        recend,
        previous_command: clt$expandable_string,
        previous_command_name: clt$command_name,
        previous_command_status: ost$status,
*IF NOT $true(osv$unix)
        proc_name: ost$name,
        command_proc_status: ^ost$status,
        command_proc_logging_completed: boolean,
        command_proc_echoing_completed: boolean,
        function_proc_result: ^clt$internal_data_value,
        expected_function_proc_type: ^clt$type_specification,
        when_condition: ^clt$when_condition_descriptor,
*IFEND
        associated_utility: ^clt$block,
        line_preprocessor_specified: boolean,
*IF NOT $true(osv$unix)
      = clc$for_block =
        for_variable: ^clt$variable_ref_expression,
        for_control: record
          case style: (clc$for_control_incremental, clc$for_control_list) of
          = clc$for_control_incremental =
            value: clt$integer,
            limit: integer,
            increment: integer,
          = clc$for_control_list =
            list: ^clt$internal_data_value,
          casend,
        recend,
*IFEND
      = clc$function_block =
        expected_function_type: ^clt$type_description,
*IF NOT $true(osv$unix)
      = clc$if_block =
        if_condition_met: boolean,
        if_else_allowed: boolean,
      = clc$loop_block =
        ,
      = clc$repeat_block, clc$while_block =
        expression_area: ^SEQ ( * ),
        expression_parse: clt$parse_state,
      = clc$sub_parameters_block =
        sub_parameters_work_area_ptr: ^^clt$work_area,
        sub_parameters_work_area: ^clt$work_area,
        lookup_functions_and_variables: boolean,
*IFEND
      = clc$task_block =
        task_id: pmt$task_id,
        task_kind: (clc$job_monitor_task, clc$task_statement_task,
              clc$other_task),
        task_link: ^clt$block,
*IF NOT $true(osv$unix)
        application_task_link: ^clt$block,
*IFEND
        parent: ^clt$block,
        current_block: ^clt$block,
*IF NOT $true(osv$unix)
        display_log_indices: clt$display_log_indices,
*IFEND
        synchronous_with_job: boolean,
        case synchronous_with_parent: boolean of
        = FALSE =
          command_file: fst$path_handle_name,
          named_task_list: ^clt$named_task,
*IF NOT $true(osv$unix)
          default_session_file: ^fst$file_reference,
*IFEND
        = TRUE =
          ,
        casend,
      = clc$utility_block =
        notify_before_command_read: ^procedure
               (VAR status: ost$status),
        command_environment: clt$utility_command_environment,
        command_search_mode: clt$command_search_modes,
        interactive_include_processor: clt$utility_interactive_in_desc,
        libraries: ^array [1 .. * ] of fst$path,
        line_preprocessor: clt$utility_line_preproc_desc,
        online_manual_name: ost$online_manual_name,
        prompt: clt$utility_prompt,
        termination_command_found: boolean,
        include_processor_active: boolean,
*IF NOT $true(osv$unix)
        active_sou_capabilities: record
          case saved: boolean of
          = TRUE =
            value: avt$conditional_capabilities,
          casend,
        recend,
*IFEND
      casend,
    recend;

*IF NOT $true(osv$unix)
*copyc amt$file_byte_address
*copyc amt$file_identifier
*IFEND
*copyc avt$conditional_capabilities
*copyc clt$application_info
*copyc clt$command_kind
*copyc clt$command_name
*copyc clt$command_or_function_source
*copyc clt$command_search_modes
*copyc clt$data_representation
*IF NOT $true(osv$unix)
*copyc clt$display_log_indices
*IFEND
*copyc clt$environment_object_info
*IF NOT $true(osv$unix)
*copyc clt$established_handler_info
*IFEND
*copyc clt$expandable_string
*copyc clt$integer
*copyc clt$internal_data_value
*copyc clt$interpreter_modes
*copyc clt$input_data
*copyc clt$input_line_kind
*copyc clt$input_state
*copyc clt$line_identifier
*copyc clt$line_layout
*copyc clt$named_task
*copyc clt$parameters
*copyc clt$parameter_help_options
*copyc clt$parameter_name
*copyc clt$parse_state
*copyc clt$prompt_string
*copyc clt$pushed_line
*copyc clt$string_size
*copyc clt$type_description
*copyc clt$type_specification
*copyc clt$utility_attribute
*copyc clt$utility_command_environment
*copyc clt$utility_interactive_in_desc
*copyc clt$utility_line_preproc_desc
*copyc clt$utility_prompt
*IF NOT $true(osv$unix)
*copyc clt$value_qualifiers
*copyc clt$variables
*copyc clt$variable_name
*copyc clt$variable_ref_expression
*copyc clt$when_condition_descriptor
*IFEND
*copyc clt$work_area
*copyc fst$file_reference
*copyc fst$path
*IF NOT $true(osv$unix)
*copyc fst$path_handle_name
*copyc ift$terminal_connection_types
*copyc osd$virtual_address
*IFEND
*copyc ost$name
*copyc ost$online_manual_name
*copyc ost$status
*IF NOT $true(osv$unix)
*copyc pmt$task_id
*IFEND
*copyc rmt$device_class

*DECK DECK=CLT$BLOCK_HANDLE EXPAND=FALSE

  TYPE
    clt$block_handle = record
      segment_offset: ost$segment_length,
      assignment_counter: fmt$pde_assignment_counter,
    recend;

*copyc fmt$pde_assignment_counter
*copyc osd$virtual_address
*DECK DECK=CLT$BOOLEAN EXPAND=FALSE

  TYPE
    clt$boolean = record
      value: boolean,
      kind: clt$boolean_kinds,
    recend;

  TYPE
    clt$boolean_kinds = (clc$true_false_boolean, clc$yes_no_boolean,
          clc$on_off_boolean);

*DECK DECK=CLT$CALL_METHOD EXPAND=FALSE

  TYPE
    clt$call_method = (clc$unspecified_call, clc$linked_call,
          clc$unlinked_call, clc$proc_call, clc$program_call);

*DECK DECK=CLT$CHARACTER_CLASS EXPAND=FALSE

  TYPE
    clt$character_class = (clc$space_character,
          clc$comment_delimiter_character, clc$string_delimiter_character,
          clc$digit_character, clc$alpha_character, clc$token_character,
          clc$digraph_token_character, clc$other_character);

*DECK DECK=CLT$CHECK_PARAMETERS_PROCEDURE EXPAND=FALSE

  TYPE
    clt$check_parameters_procedure = ^procedure
           (    parameter_value_table: ^clt$parameter_value_table;
                which_parameter: clt$which_parameter;
            VAR status: ost$status);

*copyc clt$parameter_value_table
*copyc clt$which_parameter
*copyc ost$status
*DECK DECK=CLT$COBOL_NAME EXPAND=FALSE

  TYPE
    clt$cobol_name = string (clc$max_cobol_name_size);

*copyc clc$max_cobol_name_size
*DECK DECK=CLT$COBOL_NAME_REFERENCE EXPAND=FALSE

  TYPE
    clt$cobol_name_reference = string ( * <= clc$max_cobol_name_size);

*copyc clc$max_cobol_name_size
*DECK DECK=CLT$COBOL_NAME_SIZE EXPAND=FALSE

  TYPE
    clt$cobol_name_size = 1 .. clc$max_cobol_name_size;

*copyc clc$max_cobol_name_size
*DECK DECK=CLT$COLLECT_STATEMENT_AREA EXPAND=FALSE

  TYPE
    clt$collect_statement_area = clt$input_data;

*copyc clt$input_data
*DECK DECK=CLT$COLLECT_TEXT_COMMAND_INFO EXPAND=FALSE

  TYPE
    clt$collect_text_command_info = record
      pdt: ^clt$parameter_description_table,
      number_of_parameters: clt$parameter_count,
      until_parameter_number: clt$parameter_number,
      input_parameter_number: clt$parameter_number,
      default_until_string: ^clt$string_value,
    recend;

*copyc clt$parameter_count
*copyc clt$parameter_description_table
*copyc clt$parameter_number
*copyc clt$string_value
*DECK DECK=CLT$COMMAND EXPAND=FALSE
*copyc clt$command_processor
*DECK DECK=CLT$COMMAND_CALL_METHOD EXPAND=FALSE

  TYPE
    clt$command_call_method = clc$linked_call .. clc$program_call;

*copyc clt$call_method
*DECK DECK=CLT$COMMAND_FILE_ACCESS_MODES EXPAND=FALSE

  TYPE
    clt$command_file_access_modes = array [1 .. 3] of fst$file_access_options;

*copyc fst$file_access_options

*DECK DECK=CLT$COMMAND_FILE_KIND EXPAND=FALSE

  TYPE
    clt$command_file_kind = (clc$include_file, clc$incf_segment_caller_file,
          clc$incf_record_caller_file, clc$get_file,
          clc$get_segment_caller_file, clc$get_record_caller_file,
          clc$catalog_command, clc$command_library, clc$submit_job);

*DECK DECK=CLT$COMMAND_KIND EXPAND=FALSE

  TYPE
    clt$command_kind = (clc$regular_command, clc$program_command,
          clc$command_is_include_file, clc$command_is_include_line,
          clc$command_is_execute_task, clc$login_command);

*DECK DECK=CLT$COMMAND_LIBRARY_SEARCH_INFO EXPAND=FALSE

  TYPE
    clt$command_library_search_info = record
      command_or_function_module: ^SEQ ( * ),
      command_or_function_kind: llt$command_kind,
      ordinal: clt$named_entry_ordinal,
      case module_kind: llt$library_module_kind of
      = llc$command_procedure, llc$applic_command_procedure,
            llc$program_description, llc$applic_program_description,
            llc$command_description, llc$applic_command_description =
        log_option: clt$command_log_option,
        application_identifier: llt$application_identifier,
        library_privilege: ost$name,
      = llc$function_procedure, llc$function_description =
        ,
      casend,
    recend;

*copyc clt$command_log_option
*copyc clt$named_entry_ordinal
*copyc llt$application_identifier
*copyc llt$command_kind
*copyc llt$library_module_kind
*copyc ost$name
*DECK DECK=CLT$COMMAND_LINE EXPAND=FALSE

  TYPE
    clt$command_line = string ( * <= clc$max_command_line_size);

*copyc clc$max_command_line_size
*DECK DECK=CLT$COMMAND_LINE_INDEX EXPAND=FALSE

  TYPE
    clt$command_line_index = 1 .. clc$max_command_line_size + 1;

*copyc clc$max_command_line_size
*DECK DECK=CLT$COMMAND_LINE_SIZE EXPAND=FALSE

  TYPE
    clt$command_line_size = 0 .. clc$max_command_line_size;

*copyc clc$max_command_line_size
*DECK DECK=CLT$COMMAND_LIST EXPAND=FALSE

  TYPE
    clt$command_list = record
      search_mode: clt$command_search_modes,
      entries: clt$command_list_entries,
      system_command_library_lfn: fst$path_handle_name,
      system_library_contains: clt$command_library_contains,
      number_of_utilities_added: 0 .. 7fffffff(16),
      deletion_made: boolean,
    recend;

  TYPE
    clt$command_list_entries = record
      first_entry: ^clt$command_list_entry,
      entry_after_fence: ^clt$command_list_entry,
      last_entry: ^clt$command_list_entry,
    recend;

  TYPE
    clt$command_list_entry = record
      next_entry: ^clt$command_list_entry,
      case kind: clt$command_list_entry_kind of
      = clc$catalog_commands, clc$library_commands =
        local_file_name: fst$path_handle_name,
        library_contains: clt$command_library_contains,
        unaccessible_entry: boolean,
      = clc$working_catalog_commands =
        ,
      = clc$system_commands =
        ,
      = clc$sub_commands =
        utility_name: ost$name,
        utility_info: ^clt$utility_command_environment,
      = clc$command_list_fence =
        ,
      casend,
    recend;

  TYPE
    clt$command_list_entry_kind = (clc$catalog_commands, clc$library_commands,
          clc$system_commands, clc$sub_commands, clc$working_catalog_commands,
          clc$command_list_fence);

  TYPE
    clt$command_library_list_entry = record
      next_entry: ^clt$command_library_list_entry,
      local_file_name: fst$path_handle_name,
      used_for_dynamic_load: boolean,
      file_id: amt$file_identifier,
      ring_attributes: amt$ring_attributes,
      contents: ^SEQ ( * ),
      dictionaries: llt$library_dictionary_pointers,
      can_be_echoed: boolean,
    recend;

  TYPE
    clt$command_library_contains = packed record
      commands: boolean,
      functions: boolean,
      help_modules: boolean,
      message_modules: boolean,
      panels: boolean,
    recend;

*copyc amt$file_identifier
*copyc amt$ring_attributes
*copyc clt$command_search_modes
*copyc clt$utility_command_environment
*copyc fst$path_handle_name
*copyc llt$library_dictionary_pointers
*copyc ost$name
*DECK DECK=CLT$COMMAND_LIST_ENTRY_FILE EXPAND=FALSE

  TYPE
    clt$command_list_entry_file = record
      case kind: clt$command_list_entry_fil_kind of
      = clc$command_list_entry_$system, clc$command_list_entry_fence =
        ,
      = clc$command_list_entry_path =
        path: ^fst$file_reference,
      casend,
    recend;

*copyc clt$command_list_entry_fil_kind
*copyc fst$file_reference
*DECK DECK=CLT$COMMAND_LIST_ENTRY_FIL_KIND EXPAND=FALSE

  TYPE
    clt$command_list_entry_fil_kind = (clc$command_list_entry_$system,
          clc$command_list_entry_fence, clc$command_list_entry_path);

*DECK DECK=CLT$COMMAND_LIST_INFO EXPAND=FALSE

  TYPE
    clt$command_list_info = record
      contents: ^clt$command_list,
      defined_in_current_task: boolean,
    recend;

*copyc clt$command_list
*DECK DECK=CLT$COMMAND_LOG_OPTION EXPAND=FALSE

  TYPE
    clt$command_log_option = (clc$automatically_log, clc$manually_log);

*DECK DECK=CLT$COMMAND_NAME EXPAND=FALSE

  TYPE
    clt$command_name = ost$name;

*copyc ost$name
*DECK DECK=CLT$COMMAND_OR_FUNCTION EXPAND=FALSE

  TYPE
    clt$command_or_function = (clc$command, clc$function);

*DECK DECK=CLT$COMMAND_OR_FUNCTION_SCOPE EXPAND=FALSE

  TYPE
    clt$command_or_function_scope = (clc$xdcl_command_or_function,
          clc$gate_command_or_function, clc$local_command_or_function);

*DECK DECK=CLT$COMMAND_OR_FUNCTION_SOURCE EXPAND=FALSE

  TYPE
    clt$command_or_function_source = record
      index: clt$string_index,
      size: clt$string_size,
      reference_index: clt$string_index,
      reference_size: clt$string_size,
      ordinal: clt$named_entry_ordinal,
      function_interface: clt$function_interface,
      case kind: clt$command_list_entry_kind of
      = clc$catalog_commands, clc$library_commands =
        local_file_name: fst$path_handle_name,
      = clc$system_commands =
        system_command_table: ^clt$command_table,
      = clc$sub_commands =
        utility_name: clt$utility_name,
        utility_info: ^clt$utility_command_environment,
        utility_termination_command: boolean,
        auxilliary_table: boolean,
      casend,
    recend;

*copyc clt$command_list
*copyc clt$command_table
*copyc clt$function_interface
*copyc clt$named_entry_ordinal
*copyc clt$string_index
*copyc clt$string_size
*copyc clt$utility_command_environment
*copyc clt$utility_name
*copyc fst$path_handle_name
*DECK DECK=CLT$COMMAND_PROCESSOR EXPAND=FALSE

  TYPE
    clt$command = ^procedure (    parameter_list: clt$parameter_list;
                              VAR status: ost$status);

*copyc cld$parameter_list
*copyc ost$status
*DECK DECK=CLT$COMMAND_REFERENCE EXPAND=FALSE

  TYPE
    clt$command_reference = record
      name: clt$command_name,
      case form: clt$command_reference_form of
      = clc$name_only_command_ref =
        ,
      = clc$skip_1st_entry_command_ref =
        ,
      = clc$system_command_ref =
        ,
      = clc$utility_command_ref =
        utility: clt$utility_name,
      = clc$module_or_file_command_ref =
        library_or_catalog: fst$path,
      = clc$file_cycle_command_ref =
        catalog: fst$path,
        cycle_number: fst$cycle_number,
      casend,
    recend;

*copyc clt$command_name
*copyc clt$command_reference_form
*copyc clt$utility_name
*copyc fst$cycle_number
*copyc fst$path
*DECK DECK=CLT$COMMAND_REFERENCE_FORM EXPAND=FALSE

  TYPE
    clt$command_reference_form = (clc$name_only_command_ref,
          clc$skip_1st_entry_command_ref, clc$system_command_ref,
          clc$utility_command_ref, clc$module_or_file_command_ref,
          clc$file_cycle_command_ref);

*DECK DECK=CLT$COMMAND_RESOURCE_STATISTICS EXPAND=FALSE

  TYPE
    clt$command_resource_statistics = record
      cptime: pmt$task_cp_time,
      paging_statistics: ost$paging_statistics,
    recend;

*copyc ost$paging_statistics
*copyc pmt$task_cp_time
*DECK DECK=CLT$COMMAND_SEARCH_MODES EXPAND=FALSE

  TYPE
    clt$command_search_modes = (clc$global_command_search,
          clc$restricted_command_search, clc$exclusive_command_search);

*DECK DECK=CLT$COMMAND_TABLE EXPAND=FALSE

  TYPE
    clt$command_table = array [1 .. * ] of clt$command_table_entry;

*copyc clt$command_table_entry
*DECK DECK=CLT$COMMAND_TABLE_ENTRY EXPAND=FALSE

  TYPE
    clt$command_table_entry = record
      name: clt$command_name,
      class: clt$named_entry_class,
      availability: clt$named_entry_availability,
      ordinal: clt$named_entry_ordinal,
      log_option: clt$command_log_option,
      case call_method: clt$command_call_method of
      = clc$linked_call =
        command: clt$command,
      = clc$unlinked_call, clc$proc_call, clc$program_call =
        procedure_name: pmt$program_name,
      casend,
    recend;

*copyc clt$command_call_method
*copyc clt$command_log_option
*copyc clt$command_name
*copyc clt$command_processor
*copyc clt$named_entry_availability
*copyc clt$named_entry_class
*copyc clt$named_entry_ordinal
*copyc pmt$program_name
*DECK DECK=CLT$COMMAND_TABLE_INDEX EXPAND=FALSE

  TYPE
    clt$command_table_index = 1 .. clc$max_command_table_size;

*copyc clc$max_command_table_size
*DECK DECK=CLT$COMPARISON_RESULT EXPAND=FALSE

  TYPE
    clt$comparison_result = mlt$compare;

  CONST
    clc$equal = mlc$equal,
    clc$left_is_greater = mlc$source_is_greater,
    clc$unordered = mlc$unordered,
    clc$right_is_greater = mlc$target_is_greater;

*copyc mlt$compare
*DECK DECK=CLT$COMPARISON_RESULTS EXPAND=FALSE

  TYPE
    clt$comparison_results = set of clt$comparison_result;

*copyc clt$comparison_result
*DECK DECK=CLT$CONDITION_PROCESSED_STATE EXPAND=FALSE

  TYPE
    clt$condition_processed_state = (clc$no_handler_established,
          clc$continue_next, clc$continue_retry, clc$continue_next_handler,
          clc$continue_next_user_handler);

*DECK DECK=CLT$CONNECTED_FILE EXPAND=FALSE

  TYPE

{  The connection_level field of the active connected_files tree is
{  incremented on every create_file_connection and delete_file_connection.
{  On a PUSH this value is copied to the new tree and on a POP the
{  value of the previous tree is saved and used to update the 'new' tree.
{  Thus this value always increases and represents the total number
{  of connection events that have occurred.  It is used to update the
{  subject's connection_level when a subject participates in a
{  connection event (create or delete).  This value is often referred to
{  as the 'global' connection_level.

    clt$connected_files = record
      subject_tree: ^clt$connected_file_subject,
      echo_count: integer,
      connection_level: clt$file_connection_level,
    recend;

  TYPE

{  The connection_level field represents the value of the global
{  connection_level at the time this subject last had a file connection
{  created or deleted.  When the subject file is opened, this value
{  is copied to the connection_level field in the subject's TFT entry.

    clt$connected_file_subject = record
      path_handle_name: fst$path_handle_name,
      left_link: ^clt$connected_file_subject,
      right_link: ^clt$connected_file_subject,
      connection_level: clt$file_connection_level,
      targets: ^clt$connected_file_targets,
    recend;

  TYPE
    clt$file_connection_level = integer;

  CONST
    clc$min_connected_file_targets = 3;

  CONST
    clc$max_connected_file_targets = 7fffffff(16);

  TYPE
    clt$connected_file_target_index = 1 .. clc$max_connected_file_targets;

  TYPE
    clt$connected_file_targets = array [1 .. * ] of clt$connected_file_target;

  TYPE

{  Connection_level is copied from the target's subject connection_level
{  when the connection to the target is either created or deleted.
{  When the target is opened, this value is copied to the target_connection_level
{  field in the target's TFT entry.

    clt$connected_file_target = record
      connection_active: boolean,
      path_handle_name: fst$path_handle_name,
      open_position: fst$open_position,
      connection_level: clt$file_connection_level,
      connection_ring: ost$valid_ring,
    recend;

*copyc cld$path_description
*copyc fst$open_position
*copyc fst$path_handle_name
*copyc osd$virtual_address
*DECK DECK=CLT$CONTROL_STATEMENT EXPAND=FALSE

  TYPE
    clt$control_statement = ^procedure
          (    control_statement_info: clt$control_statement_info;
           VAR parse {input, output} : clt$parse_state;
           VAR work_area {input, output} : ^clt$work_area;
           VAR cause_condition {input, output} : clt$when_condition;
           VAR status: ost$status);

*copyc clt$control_statement_info
*copyc clt$parse_state
*copyc clt$when_condition
*copyc clt$work_area
*copyc ost$status
*DECK DECK=CLT$CONTROL_STATEMENT_DESC EXPAND=FALSE

  TYPE
    clt$control_statement_desc = record
      call_in_skip_mode: boolean,
      case kind: clt$control_statement_kind of
      = clc$control_command =
        command: clt$command,
      = clc$control_statement =
        label_allowed: boolean,
        statement: clt$control_statement,
      casend,
    recend;

  TYPE
    clt$control_statement_kind = (clc$control_command, clc$control_statement);

*copyc clt$command_processor
*copyc clt$control_statement
*DECK DECK=CLT$CONTROL_STATEMENT_INFO EXPAND=FALSE

  TYPE
    clt$control_statement_info = record
      interpreter_mode: clt$interpreter_modes,
      label: ost$name,
      logging_required: boolean,
      echoing_required: boolean,
    recend;

*copyc clt$interpreter_modes
*copyc ost$name
*DECK DECK=CLT$CONVERT_TO_STRING_KIND EXPAND=FALSE

  TYPE
    clt$convert_to_string_kind = (clc$convert_data_value,
          clc$convert_type_description, clc$convert_unbundled_pdt,
          clc$convert_old_pdt, clc$convert_parameters);

*DECK DECK=CLT$CONVERT_TO_STRING_REQUEST EXPAND=FALSE

  TYPE
    clt$convert_to_string_request = record
      initial_indentation: clt$string_size,
      continuation_indentation: clt$string_size,
      max_string: clt$string_size,
      include_advanced_items: boolean,
      include_hidden_items: boolean,
      case kind: clt$convert_to_string_kind of
      = clc$convert_data_value =
        representation_option: clt$data_representation_option,
        value: ^clt$data_value,
      = clc$convert_type_description =
        multi_line_type_format: boolean,
        type_description: ^clt$type_description,
        symbolic_type_qualifiers_area: ^clt$work_area,
      = clc$convert_unbundled_pdt =
        multi_line_pdt_format: boolean,
        parameter_starts_line: boolean,
        individual_parameter: boolean,
        individual_parameter_number: clt$parameter_number,
        include_header: boolean,
        command_or_function_name: pmt$program_name,
        aliases: ^array [1 .. * ] of pmt$program_name,
        availability: clt$named_entry_availability,
        command_or_function_scope: clt$command_or_function_scope,
        pdt: ^clt$unbundled_pdt,
        pvt: ^clt$parameter_value_table,
        symbolic_pdt_qualifiers_area: ^clt$work_area,
        include_implementation_info: boolean,
      = clc$convert_old_pdt =
        multi_line_old_pdt_format: boolean,
        proc_or_pdt: ost$name,
        proc_names: ^clt$proc_names,
        old_pdt: clt$parameter_descriptor_table,
        symbolic_parameters: ^clt$symbolic_parameters,
      = clc$convert_parameters =
        initial_text: ^clt$command_line,
        include_secure_parameters: boolean,
        evaluated_pdt: ^clt$unbundled_pdt,
        evaluated_pvt: ^clt$parameter_value_table,
        parameter_substitutions: ^clt$parameter_substitutions,
      casend,
    recend;

*copyc clt$command_line
*copyc clt$command_or_function_scope
*copyc clt$convert_to_string_kind
*copyc clt$data_representation_option
*copyc clt$data_value
*copyc clt$named_entry_availability
*copyc clt$parameter_descriptor_table
*copyc clt$parameter_number
*copyc clt$parameter_substitutions
*copyc clt$parameter_value_table
*copyc clt$proc_names
*copyc clt$string_size
*copyc clt$symbolic_parameters
*copyc clt$type_description
*copyc clt$unbundled_pdt
*copyc clt$work_area
*copyc pmt$program_name
*DECK DECK=CLT$CYCLE_SELECTOR EXPAND=FALSE

  TYPE
    clt$cycle_selector = record
      specification: clt$cycle_specification,
      value: pft$cycle_selector,
    recend,
    clt$cycle_specification = (clc$cycle_omitted, clc$cycle_specified,
          clc$cycle_next_highest, clc$cycle_next_lowest);

*copyc pfd$permanent_file_definitions
*DECK DECK=CLT$DATA_ACCESS_MODE EXPAND=FALSE

  TYPE
    clt$data_access_mode = (clc$read_write, clc$read_only);

*DECK DECK=CLT$DATA_KIND EXPAND=FALSE

  TYPE
    clt$data_kind = (clc$application, clc$array, clc$boolean, clc$cobol_name,
          clc$command_reference, clc$data_name, clc$date_time, clc$deferred,
*IF NOT $true(osv$unix)
          clc$entry_point_reference, clc$file, clc$integer, clc$keyword,
*ELSE
          clc$entry_point_reference, clc$nos_ve_file, clc$integer, clc$keyword,
*IFEND
          clc$list, clc$lock, clc$name, clc$network_title, clc$program_name,
          clc$range, clc$real, clc$record, clc$scu_line_identifier,
          clc$statistic_code, clc$status, clc$status_code, clc$string,
          clc$string_pattern, clc$time_increment, clc$time_zone,
*IF NOT $true(osv$unix)
          clc$type_specification, clc$unspecified);
*ELSE
          clc$type_specification, clc$unspecified, clc$unix_file);

    CONST
      clc$file = clc$unix_file;

*IFEND

*DECK DECK=CLT$DATA_KINDS EXPAND=FALSE

  TYPE
    clt$data_kinds = set of clt$data_kind;

*copyc clt$data_kind
*DECK DECK=CLT$DATA_REPRESENTATION EXPAND=FALSE

  TYPE
    clt$data_representation = SEQ ( * );

*copyc clt$string_size
*copyc clt$string_value
*copyc clt$data_representation_count
*DECK DECK=CLT$DATA_REPRESENTATION_COUNT EXPAND=FALSE

  TYPE
    clt$data_representation_count = 0 .. 7fffffff(16);

*DECK DECK=CLT$DATA_REPRESENTATION_OPTION EXPAND=FALSE
  TYPE
    clt$data_representation_option = (clc$data_elem_representation,
          clc$data_struct_representation, clc$data_source_representation,
          clc$labeled_elem_representation, clc$compressed_labeled_elem_rep,
          clc$display_elem_representation, clc$display_srce_representation);

*DECK DECK=CLT$DATA_VALUE EXPAND=FALSE

  TYPE
    clt$data_value = record
      case kind: clt$data_kind of
      = clc$application =
        application_value: ^clt$application_value_text,
      = clc$array =
        array_value: ^array [ * ] of ^clt$data_value,
      = clc$boolean =
        boolean_value: clt$boolean,
      = clc$cobol_name =
        cobol_name_value: clt$cobol_name,
      = clc$command_reference =
        command_reference_value: ^clt$command_reference,
      = clc$data_name =
        data_name_value: ost$name,
      = clc$date_time =
        date_time_value: clt$date_time,
      = clc$deferred =
        deferred_value: ^clt$expression_text,
        deferred_type: ^clt$type_specification,
      = clc$entry_point_reference =
        entry_point_reference_value: ^pmt$entry_point_reference,
*IF NOT $true(osv$unix)
      = clc$file =
*ELSE
      = {clc$file} clc$nos_ve_file, clc$unix_file =
*IFEND
        file_value: ^fst$file_reference,
      = clc$integer =
        integer_value: clt$integer,
      = clc$keyword =
        keyword_value: clt$keyword,
      = clc$list =
        element_value: ^clt$data_value,
        link: ^clt$data_value,
        generated_via_list_rest: boolean,
      = clc$lock =
        lock_value: ^clt$lock,
      = clc$name =
        name_value: ost$name,
      = clc$network_title =
        network_title_value: ^nat$title,
      = clc$program_name =
        program_name_value: pmt$program_name,
      = clc$range =
        low_value: ^clt$data_value,
        high_value: ^clt$data_value,
      = clc$real =
        real_value: clt$real,
      = clc$record =
        field_values: ^array [1 .. * ] of clt$field_value,
      = clc$scu_line_identifier =
        scu_line_identifier_value: clt$scu_line_identifier,
      = clc$statistic_code =
        statistic_code_value: sft$statistic_code,
      = clc$status =
        status_value: ^ost$status,
      = clc$status_code =
        status_code_value: ost$status_condition_code,
      = clc$string =
        string_value: ^clt$string_value,
      = clc$string_pattern =
        string_pattern_value: ^clt$string_pattern,
      = clc$time_increment =
        time_increment_value: ^pmt$time_increment,
      = clc$time_zone =
        time_zone_value: ost$time_zone,
      = clc$type_specification =
        type_specification_value: ^clt$type_specification,
      = clc$unspecified =
        ,
      casend,
    recend;

*copyc clt$application_value_text
*copyc clt$boolean
*copyc clt$cobol_name
*copyc clt$command_reference
*copyc clt$date_time
*copyc clt$data_kind
*copyc clt$expression_text
*copyc clt$field_value
*copyc clt$integer
*copyc clt$keyword
*copyc clt$lock
*copyc clt$real
*copyc clt$scu_line_identifier
*copyc clt$string_pattern
*copyc clt$string_value
*copyc clt$type_specification
*copyc fst$file_reference
*copyc nat$title
*copyc ost$name
*copyc ost$status
*copyc ost$status_condition_code
*copyc ost$time_zone
*copyc pmt$entry_point_reference
*copyc pmt$program_name
*copyc pmt$time_increment
*copyc sfd$type_declarations
*DECK DECK=CLT$DATA_VALUE_KIND EXPAND=FALSE

  TYPE
    clt$data_value_kind = (clc$unspecified_value, clc$application_value,
          clc$deferred_value, clc$file_value, clc$name_value, clc$string_value,
          clc$real_value, clc$integer_value, clc$boolean_value,
          clc$status_value, clc$array_value, clc$cobol_name_value,
          clc$date_time_value, clc$entry_point_reference_value,
          clc$keyword_value, clc$list_value, clc$lock_value,
          clc$network_title_value, clc$range_value, clc$record_value,
          clc$scu_line_identifier_value, clc$string_pattern_value,
          clc$time_increment_value, clc$type_specification_value);

*DECK DECK=CLT$DATE_AND_OR_TIME EXPAND=FALSE

  TYPE
    clt$date_and_or_time = set of clt$date_or_time;

*copyc clt$date_or_time
*DECK DECK=CLT$DATE_OR_TIME EXPAND=FALSE

  TYPE
    clt$date_or_time = (clc$date, clc$time);

*DECK DECK=CLT$DATE_TIME EXPAND=FALSE

  TYPE
    clt$date_time = record
      value: ost$date_time,
      date_specified: boolean,
      time_specified: boolean,
    recend;

*copyc ost$date_time
*DECK DECK=CLT$DATE_TIME_FORM_STRING EXPAND=FALSE

  TYPE
    clt$date_time_form_string = string ( * <= clc$max_date_time_form_string);

*copyc clc$max_date_time_form_string
*DECK DECK=CLT$DATE_TIME_TENSE EXPAND=FALSE

  TYPE
    clt$date_time_tense = (clc$past, clc$present, clc$future);

*DECK DECK=CLT$DATE_TIME_TENSES EXPAND=FALSE

  TYPE
    clt$date_time_tenses = set of clt$date_time_tense;

*copyc clt$date_time_tense
*DECK DECK=CLT$DATE_TIME_TYPE_QUALIFIER EXPAND=FALSE

  TYPE
    clt$date_time_type_qualifier = record
      date_and_or_time: clt$date_and_or_time,
      tenses: clt$date_time_tenses,
    recend;

*copyc clt$date_and_or_time
*copyc clt$date_time_tenses
*DECK DECK=CLT$DAY_AND_MONTH_NAMES EXPAND=TRUE

  TYPE
    clt$day_and_month_names = record
      next_entry: ^clt$day_and_month_names,
      language: ost$natural_language,
      months: array [1 .. 12] of clt$name,
      months_abbrev: array [1 .. 12] of clt$name,
      days: array [1 .. 7] of clt$name,
      days_abbrev: array [1 .. 7] of clt$name,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ost$natural_language
*copyc clt$name
?? POP ??
*DECK DECK=CLT$DECLARATION_VERSION EXPAND=FALSE

  TYPE
    clt$declaration_version = 0 .. 255;

*IF NOT $true(osv$unix)
*copyc clc$declaration_version
*IFEND
*DECK DECK=CLT$DISPLAY_CONTROL EXPAND=FALSE

  CONST
    clc$same_display_line = -1,
    clc$next_display_line = 0;

  TYPE
    clt$new_display_line_skip = clc$same_display_line .. amc$file_byte_limit;

  TYPE
    clt$new_display_page_procedure = ^procedure
           (VAR display_control {input,
                 {output} : clt$display_control;
                new_page_number: integer;
            VAR status: ost$status);

  TYPE
    clt$trim_display_text_option = (clc$no_trim, clc$trim);

  TYPE
    clt$display_control = record
      page_format: amt$page_format,
      page_length: amt$page_length,
      page_width: amt$page_width,
      page_number: integer,
      line_number: integer,
      column_number: amt$page_width,
      file_id: amt$file_identifier,
      device_class: rmt$device_class,
      new_page_procedure: clt$new_display_page_procedure,
      data_in_line: boolean,
      include_format_effectors: boolean,
      new_line_started: boolean,
      new_page_proc_called: boolean,
      line: ost$string,
      put_partial_line: boolean,
    recend;

*copyc amd$page_format_declarations
*copyc amt$file_byte_address
*copyc amt$file_identifier
*copyc amt$term_option
*copyc ost$status
*copyc rmt$device_class
*DECK DECK=CLT$DISPLAY_LOG_INDICES EXPAND=FALSE

  TYPE
    clt$display_log_indices = array [clt$display_log_kind] of record
      last_log_entry: amt$file_byte_address,
      last_display_log_entry: amt$file_byte_address,
      last_log_cycle: lgt$log_cycle,
    recend;

  TYPE
    clt$display_log_kind = (clc$display_job_log, clc$display_system_log,
          clc$display_critical_window_log);

*copyc amt$file_byte_address
*copyc lgt$log_read_activity
*DECK DECK=CLT$ENTRY_POINT_REFERENCE_SIZE EXPAND=FALSE

  TYPE
    clt$entry_point_reference_size = record
      entry_point_size: ost$name_size,
      object_library_size: fst$path_size,
    recend;

*copyc fst$path_size
*copyc ost$name
*DECK DECK=CLT$ENVIRONMENT_OBJECT EXPAND=FALSE

  TYPE
    clt$environment_object = ost$name;

  { An environment object is either one of the items below
  { or an SCL environment variable.

?? FMT (FORMAT := OFF) ??

  CONST
    clc$attach_file_defaults        = 'ATTACH_FILE_DEFAULTS           ',
    clc$command_list                = 'COMMAND_LIST                   ',
    clc$file_attribute_defaults     = 'FILE_ATTRIBUTE_DEFAULTS        ',
    clc$file_connections            = 'FILE_CONNECTIONS               ',
    clc$interaction_information     = 'INTERACTION_INFORMATION        ',
    clc$link_attributes             = 'LINK_ATTRIBUTES                ',
    clc$message_level               = 'MESSAGE_LEVEL                  ',
    clc$message_receipt_action      = 'MESSAGE_RECEIPT_ACTION         ',
    clc$natural_language            = 'NATURAL_LANGUAGE               ',
    clc$program_attributes          = 'PROGRAM_ATTRIBUTES             ',
    clc$scl_options                 = 'SCL_OPTIONS                    ',
    clc$unseen_mail_action          = 'UNSEEN_MAIL_ACTION             ',
    clc$working_catalog             = 'WORKING_CATALOG                ';

  CONST
    clc$interaction_style           = clc$interaction_information;

?? FMT (FORMAT := ON) ??

*copyc ost$name
*DECK DECK=CLT$ENVIRONMENT_OBJECT_CONTENTS EXPAND=FALSE

  TYPE
    clt$environment_object_contents = cell;

*DECK DECK=CLT$ENVIRONMENT_OBJECT_INFO EXPAND=FALSE

  TYPE
    clt$environment_object_info = record
      defined: packed array [clt$environment_object_ordinal] of boolean,
      contents: array [0 .. * ] of cell,
    recend;

*copyc clt$environment_object_ordinal
*DECK DECK=CLT$ENVIRONMENT_OBJECT_LOCATION EXPAND=FALSE

  TYPE
    clt$environment_object_location = array [clt$environment_object_ordinal] of
          record
      object: ^clt$environment_object_contents,
      object_in_current_task: boolean,
    recend;

*copyc clt$environment_object_contents
*copyc clt$environment_object_ordinal
*DECK DECK=CLT$ENVIRONMENT_OBJECT_ORDINAL EXPAND=FALSE
?? FMT (FORMAT := OFF) ??

  TYPE
    clt$environment_object_ordinal = (
*IF NOT $true(osv$unix)
          clc$eo_command_list,
          clc$eo_file_connections,
          clc$eo_interaction_information,
          clc$eo_message_level,
          clc$eo_natural_language,
          clc$eo_program_attributes,
          clc$eo_scl_options,
          clc$eo_unseen_mail_action,
          clc$eo_working_catalog);
*ELSE
          clc$eo_command_list,
          clc$eo_interaction_information,
          clc$eo_message_level);
*IFEND

?? FMT (FORMAT := ON) ??
*DECK DECK=CLT$ENVIRONMENT_OBJECT_SIZE EXPAND=FALSE

  TYPE
    clt$environment_object_size = 0 .. 0ff(16);

*DECK DECK=CLT$ENVIRONMENT_VARIABLE_SCOPE EXPAND=FALSE

  TYPE
    clt$environment_variable_scope = clc$push_scope .. clc$job_scope;

*copyc clt$variable_declaration_scope
*DECK DECK=CLT$ENV_OBJECT_POP_REASON EXPAND=FALSE

  TYPE
    clt$env_object_pop_reason = (clc$eo_pop_requested, clc$eo_pop_for_block,
          clc$eo_pop_for_task, clc$eo_pop_for_cleanup);

*DECK DECK=CLT$ENV_OBJECT_PUSH_REASON EXPAND=FALSE

  TYPE
    clt$env_object_push_reason = (clc$eo_push_requested, clc$eo_push_for_task);

*DECK DECK=CLT$ESTABLISHED_HANDLER EXPAND=FALSE

  TYPE
    clt$established_handler = record
      condition: clt$when_condition,
      statements: ^clt$established_handler_stmnts,
    recend;

*copyc clt$when_condition
*copyc clt$established_handler_stmnts
*DECK DECK=CLT$ESTABLISHED_HANDLERS EXPAND=FALSE

  TYPE
    clt$established_handlers = array [1 .. * ] of clt$established_handler;

*copyc clt$established_handler
*DECK DECK=CLT$ESTABLISHED_HANDLER_COUNT EXPAND=FALSE

  TYPE
    clt$established_handler_count = 0 .. clc$max_established_handlers;

*copyc clc$max_established_handlers
*DECK DECK=CLT$ESTABLISHED_HANDLER_INDEX EXPAND=FALSE

  TYPE
    clt$established_handler_index = 1 .. clc$max_established_handlers;

*copyc clc$max_established_handlers
*DECK DECK=CLT$ESTABLISHED_HANDLER_INFO EXPAND=FALSE

  TYPE
    clt$established_handler_info = record
      any_condition_handler: ^clt$established_handler_stmnts,
      any_fault_handler: ^clt$established_handler_stmnts,
      specific_handler_count: clt$established_handler_count,
      specific_handlers: ^clt$established_handlers,
    recend;

*copyc clt$established_handler_count
*copyc clt$established_handler_stmnts
*copyc clt$established_handlers
*DECK DECK=CLT$ESTABLISHED_HANDLER_STMNTS EXPAND=FALSE

  TYPE
    clt$established_handler_stmnts = record
      established_count: integer,
      establishing_ring: ost$valid_ring,
      can_be_echoed: boolean,
      statement_area: clt$collect_statement_area,
    recend;

*copyc clt$collect_statement_area
*copyc osd$virtual_address
*DECK DECK=CLT$EXPANDABLE_STRING EXPAND=FALSE

  TYPE
    clt$expandable_string = record
      area: ^SEQ ( * ),
      text: ^clt$string_value,
      lexical_units: ^clt$lexical_units,
    recend;

  CONST
    clc$expansion_chunk_size = 256;

*copyc clt$lexical_units
*copyc clt$string_value
*DECK DECK=CLT$EXPRESSION EXPAND=FALSE

  CONST
    clc$max_expression_size = clc$max_command_line_size;

  TYPE
    clt$expression_size = 0 .. clc$max_expression_size,
    clt$expression_index = 1 .. clc$max_expression_size + 1;

  TYPE
    clt$expression = string ( * <= clc$max_expression_size);

*copyc clt$command_line
*DECK DECK=CLT$EXPRESSION_EVAL_METHOD EXPAND=FALSE

  TYPE
    clt$expression_eval_method = (clc$immediate_evaluation,
          clc$deferred_evaluation);

*DECK DECK=CLT$EXPRESSION_TEXT EXPAND=FALSE

  TYPE
    clt$expression_text = string ( * <= clc$max_expression_text_size);

*copyc clc$max_expression_text_size
*DECK DECK=CLT$EXPRESSION_TEXT_INDEX EXPAND=FALSE

  TYPE
    clt$expression_text_index = 1 .. clc$max_expression_text_size + 1;

*copyc clc$max_expression_text_size
*DECK DECK=CLT$EXPRESSION_TEXT_SIZE EXPAND=FALSE

  TYPE
    clt$expression_text_size = 0 .. clc$max_expression_text_size;

*copyc clc$max_expression_text_size
*DECK DECK=CLT$EXTERNAL_RADIX_SPEC EXPAND=FALSE

  TYPE
    clt$external_radix_spec = record
      case override_radix_in_value: boolean of
      = TRUE =
        radix: 2 .. 16,
        include_radix_specifier: boolean,
      casend,
    recend;

*DECK DECK=CLT$FIELD_INFORMATION EXPAND=FALSE

  TYPE
    clt$field_information = record
      name: clt$field_name,
      requirement: clt$field_requirement,
      type_information: clt$type_information,
    recend;

*copyc clt$field_name
*copyc clt$field_requirement
*copyc clt$type_information
*DECK DECK=CLT$FIELD_NAME EXPAND=FALSE

  TYPE
    clt$field_name = ost$name;

*copyc ost$name
*DECK DECK=CLT$FIELD_NUMBER EXPAND=FALSE

  TYPE
    clt$field_number = 1 .. clc$max_fields;

*copyc clc$max_fields
*DECK DECK=CLT$FIELD_REQUIREMENT EXPAND=FALSE

  CONST
    clc$required_field = clc$required_parameter,
    clc$optional_field = clc$optional_parameter;

  TYPE
    clt$field_requirement = clc$required_field .. clc$optional_field;

*copyc clt$parameter_requirement
*DECK DECK=CLT$FIELD_SIZE EXPAND=FALSE

  TYPE
    clt$field_size = record
      name_size: ost$name_size,
      value_size: clt$internal_data_value_size,
    recend;

*copyc clt$internal_data_value_size
*copyc ost$name
*DECK DECK=CLT$FIELD_SPECIFICATION EXPAND=FALSE

  TYPE
    clt$field_specification = record
      name: clt$field_name,
      requirement: clt$field_requirement,
      type_specification_size: clt$type_specification_size,
    recend;

*copyc clt$field_name
*copyc clt$field_requirement
*copyc clt$type_specification
*copyc clt$type_specification_size
*DECK DECK=CLT$FIELD_VALUE EXPAND=FALSE

  TYPE
    clt$field_value = record
      name: clt$field_name,
      value: ^clt$data_value,
    recend;

*copyc clt$data_value
*copyc clt$field_name
*DECK DECK=CLT$FILE EXPAND=FALSE

  TYPE
    clt$file = record
      local_file_name: amt$local_file_name,
    recend;

*copyc amt$local_file_name
*DECK DECK=CLT$FILE_CONTENTS EXPAND=FALSE

  TYPE
    clt$file_contents = record
      is_object: boolean,
      path_exists: boolean,
    recend;

*DECK DECK=CLT$FILE_REFERENCE EXPAND=FALSE

  TYPE
    clt$file_reference = record
      path_name: clt$path_name,
      path_name_size: 1 .. clc$max_path_name_size,
      validation_ring: record
        case known: boolean of
        = TRUE =
          number: ost$valid_ring,
        casend,
      recend,
    recend;

*copyc clt$path_name
*copyc osd$virtual_address
*DECK DECK=CLT$FILE_REF_PARSING_OPTION EXPAND=FALSE

  TYPE
    clt$file_ref_parsing_option = (clc$use_$local_as_working_cat,
          clc$evaluating_command_ref, clc$evaluating_entry_point_ref,
          clc$multiple_reference_allowed, clc$command_file_ref_allowed,
*IF NOT $true(osv$unix)
          clc$file_ref_evaluation_stage, clc$prevent_job_context_element);
*ELSE
          clc$file_ref_evaluation_stage, clc$prevent_job_context_element,
          clc$unix_path_syntax);
*IFEND
*DECK DECK=CLT$FILE_REF_PARSING_OPTIONS EXPAND=FALSE

  TYPE
    clt$file_ref_parsing_options = set of clt$file_ref_parsing_option;

*copyc clt$file_ref_parsing_option
*DECK DECK=CLT$FORMAT_MARKER_KIND EXPAND=FALSE

  TYPE
    clt$format_marker_kind = clc$file_or_var_begin .. clc$tree_end;

*copyc clt$format_token_type
*DECK DECK=CLT$FORMAT_TOKEN_TYPE EXPAND=FALSE

  CONST
    clc$max_array_tokens = 5000;

  TYPE
    clt$format_token_type = (clc$label, clc$unassigned, clc$parameter_name,
          clc$reserved_name, clc$node, clc$file_or_var_begin,
          clc$file_or_var_end, clc$function_begin, clc$function_end,
          clc$parameter_begin, clc$parameter_end, clc$value_set_begin,
          clc$value_set_end, clc$value_begin, clc$value_end, clc$tree_begin,
          clc$tree_end, clc$translated_function);

  TYPE
    clt$format_token = record
      string_ptr: ^string ( * ),
      clt_kind: clt$lexical_unit_kind,
      token_size: clt$string_size,
      case format_type: clt$format_token_type of
      = clc$tree_begin, clc$node, clc$tree_end =
        node_value: clt$f_node_value,
      casend,
    recend;

  TYPE
    clt$format_token_array = array [1 .. clc$max_array_tokens] of
          clt$format_token,
    clt$token_array_index = 0 .. clc$max_array_tokens;

*copyc clt$f_node_value
*copyc clt$lexical_unit_kind
*copyc clt$string_size
*DECK DECK=CLT$FUNCTION EXPAND=FALSE

  TYPE
    clt$function = ^procedure (    function_name: clt$name;
                                   argument_list: string ( * );
                               VAR value: clt$value;
                               VAR status: ost$status);

*copyc cld$value
*copyc clt$name
*copyc ost$status
*DECK DECK=CLT$FUNCTION_CALL_METHOD EXPAND=FALSE

  TYPE
    clt$function_call_method = clc$linked_call .. clc$proc_call;

*copyc clt$call_method
*DECK DECK=CLT$FUNCTION_INTERFACE EXPAND=FALSE

  TYPE
    clt$function_interface = (clc$fi_original, clc$fi_contemporary);

*DECK DECK=CLT$FUNCTION_NAME EXPAND=FALSE

  TYPE
    clt$function_name = ost$name;

*copyc ost$name
*DECK DECK=CLT$FUNCTION_PROCESSOR EXPAND=FALSE

  TYPE
    clt$function_processor = ^procedure
           (    parameter_list: clt$parameter_list;
            VAR work_area {input, output} : ^clt$work_area;
            VAR result: ^clt$data_value;
            VAR status: ost$status);

*copyc clt$data_value
*copyc clt$parameter_list
*copyc clt$work_area
*copyc ost$status
*DECK DECK=CLT$FUNCTION_PROCESSOR_TABLE EXPAND=FALSE

  TYPE
    clt$function_processor_table = array [1 .. * ] of
          clt$function_proc_table_entry;

*copyc clt$function_proc_table_entry
*DECK DECK=CLT$FUNCTION_PROC_TABLE_ENTRY EXPAND=FALSE

  TYPE
    clt$function_proc_table_entry = record
      name: clt$function_name,
      class: clt$named_entry_class,
      availability: clt$named_entry_availability,
      ordinal: clt$named_entry_ordinal,
      case call_method: clt$function_call_method of
      = clc$linked_call =
        func: clt$function_processor,
      = clc$unlinked_call, clc$proc_call =
        procedure_name: pmt$program_name,
      casend,
    recend;

*copyc clt$function_call_method
*copyc clt$function_name
*copyc clt$function_processor
*copyc clt$named_entry_availability
*copyc clt$named_entry_class
*copyc clt$named_entry_ordinal
*copyc pmt$program_name
*DECK DECK=CLT$FUNCTION_RESULT EXPAND=FALSE

  TYPE
    clt$function_result = record
      case kind: clt$function_result_kind of
      = clc$fr_value =
        value: ^clt$data_value,
      = clc$fr_parameter_name =
        parameter_name: clt$parameter_name,
      = clc$fr_variable_reference =
        variable: ^clt$variable_ref_expression,
      casend,
    recend;

*copyc clt$data_value
*copyc clt$function_result_kind
*copyc clt$parameter_name
*copyc clt$variable_ref_expression
*DECK DECK=CLT$FUNCTION_RESULT_KIND EXPAND=FALSE

  TYPE
    clt$function_result_kind = (clc$fr_value, clc$fr_parameter_name,
          clc$fr_variable_reference);

*DECK DECK=CLT$FUNCTION_TABLE EXPAND=FALSE

  TYPE
    clt$function_table = array [1 .. * ] of clt$function_table_entry;

*copyc clt$function_table_entry
*DECK DECK=CLT$FUNCTION_TABLE_ENTRY EXPAND=FALSE

  TYPE
    clt$function_table_entry = record
      name: clt$function_name,
      class: clt$named_entry_class,
      availability: clt$named_entry_availability,
      ordinal: clt$named_entry_ordinal,
      case call_method: clt$function_call_method of
      = clc$linked_call =
        func: clt$function,
      = clc$unlinked_call, clc$proc_call =
        procedure_name: pmt$program_name,
      casend,
    recend;

*copyc clt$function
*copyc clt$function_call_method
*copyc clt$function_name
*copyc clt$named_entry_availability
*copyc clt$named_entry_class
*copyc clt$named_entry_ordinal
*copyc pmt$program_name
*DECK DECK=CLT$F_BLOCK EXPAND=FALSE

  TYPE
    clt$block_kind = (clc$block_block, clc$command_block, clc$for_block,
          clc$formatter_job_block, clc$formatter_log_block,
          clc$formatter_pipe_block, clc$formatter_task_block,
          clc$formatter_utility_block, clc$if_block, clc$input_block,
          clc$loop_block, clc$proc_block, clc$repeat_block,
          clc$sub_parameters_block, clc$task_block, clc$utility_block,
          clc$var_block, clc$when_block, clc$while_block);

  TYPE
    clt$block_kinds = set of clt$block_kind;

  TYPE
    clt$f_block = bound record
      previous_block: ^clt$f_block,
      interpreter_mode: clt$interpreter_modes,
      line_index: ost$string_index,
      output_line_number: integer,
      being_exited: boolean,
      exit_position: record
        case defined: boolean of
        = TRUE =
          line_index: ost$string_index,
        casend,
      recend,
      label: ost$name,
      kind_name: string (osc$max_name_size),
      kind_end_name: string (osc$max_name_size),
      case kind: clt$block_kind of
      = clc$command_block =
        ,
      = clc$for_block =
        for_value: array [1 .. 1] of clt$integer,
        for_limit: integer,
        for_increment: integer,
      = clc$if_block =
        if_condition_met: boolean,
        if_else_allowed: boolean,
      = clc$input_block, clc$proc_block, clc$when_block =
{       when_condition: clt$when_condition,
        when_continue_with_retry: boolean,
      = clc$repeat_block, clc$while_block =
        ,
      = clc$task_block =
        task_kind: (clc$job_monitor_task, clc$task_statement_task,
              clc$other_task),
        task_link: ^clt$f_block,
        parent: ^clt$f_block,
        current_block: ^clt$f_block,
      = clc$block_block, clc$loop_block, clc$sub_parameters_block,
            clc$formatter_job_block, clc$formatter_log_block,
            clc$formatter_pipe_block, clc$formatter_task_block,
            clc$var_block, clc$formatter_utility_block, clc$utility_block =
        ,
      casend,
    recend;

*copyc amt$local_file_name
*copyc cld$variable_reference
*copyc clt$interpreter_modes
*copyc ost$name
*copyc ost$status
*copyc ost$string
*DECK DECK=CLT$F_COMMAND_TYPE EXPAND=FALSE

  TYPE
    clt$f_command_type = (clc$assignment, clc$control_statement_begin,
          clc$empty_command, clc$control_statement_end,
          clc$control_statement_switch, clc$control_statement_no_switch,
          clc$to_be_translated_command, clc$escape_command,
          clc$unknown_command, clc$utility_begin, clc$utility_end,
          clc$proc_declaration, clc$file_command, clc$collect_text_command,
          clc$labeled_command, clc$end_colt_command, clc$procend_command,
          clc$var_or_type_statement);
*DECK DECK=CLT$F_CONTROL_STATEMENT EXPAND=FALSE

  TYPE
    clt$f_control_statement = ^procedure (    label: ost$name;
                                            parameters: string ( * );
                                        VAR status: ost$status);

*copyc ost$name
*copyc ost$status
*DECK DECK=CLT$F_CONTROL_STATEMENT_DESC EXPAND=FALSE

  TYPE
    clt$f_control_statement_desc = record
      call_in_skip_mode: boolean,
      case kind: clt$f_control_statement_kind of
      = clc$control_command =
        command: clt$command,
      = clc$control_statement =
        label_allowed: boolean,
        statement: clt$f_control_statement,
      casend,
    recend;

  TYPE
    clt$f_control_statement_kind = (clc$control_command, clc$control_statement);

*copyc clt$command_processor
*copyc clt$f_control_statement
*DECK DECK=CLT$F_NODE_VALUE EXPAND=FALSE

  TYPE
    clt$f_node_value = (clc$null_node, clc$or_node, clc$and_node, clc$not_node,
          clc$rel_node, clc$cat_node, clc$add_node, clc$mul_node,
          clc$exp_node);

*DECK DECK=CLT$IBT_MODES EXPAND=FALSE

  TYPE
    clt$ibt_modes = (clc$ibt_normal, clc$ibt_stop_on_balanced,
          clc$ibt_stop_on_relational);

*DECK DECK=CLT$INITIAL_APPLICATION EXPAND=FALSE

  TYPE
    clt$initial_application = record
      case defined: boolean of
      = FALSE =
        ,
      = TRUE =
        application: ^clt$command_line,
        logout_upon_termination: boolean,
      casend,
    recend;

*copyc clt$command_line
*DECK DECK=CLT$INPUT_DATA EXPAND=FALSE

{
{ A CLT$INPUT_DATA SEQuence is used in object libraries for SCL PROCedures and
{ for the SEQuences used to hold WHEN / WHENEND blocks, asynchronous TASK /
{ TASKEND blocks, interactively entered structured statements, etc.
{
{ The clt$input_data consists of a series of lines each represented by a
{ clt$input_data_line_header followed by the actual data as indicated in the
{ header.
{
{ The text of the line (of length header.LINE_SIZE) follows the header.
{
{ If header.NUMBER_OF_LEXICAL_UNITS is non-zero, a clt$lexical_units array
{ with that many elements follows the text.
{
{ If this line was formed from the combination of a number of "continuation"
{ lines, header.SIZE_OF_COMPENENT_LINES_DATA is non-zero and indicates the
{ total omount of space occupied by those lines.  The data for these component
{ lines immediately follow the data for this line.
{

  TYPE
    clt$input_data = SEQ ( * );

*copyc clt$command_line
*copyc clt$input_data_line_header
*copyc clt$lexical_units
*DECK DECK=CLT$INPUT_DATA_LINE_HEADER EXPAND=FALSE

  TYPE
    clt$input_data_line_header = record
      line_size: clt$command_line_size,
      number_of_lexical_units: 0 .. clc$max_command_line_size +
            clc$lexical_units_size_pad,
      size_of_component_lines_data: ost$segment_length,
    recend;

*copyc clc$lexical_units_size_pad
*copyc clc$max_command_line_size
*copyc clt$command_line_size
*copyc osd$virtual_address
*DECK DECK=CLT$INPUT_LINE_KIND EXPAND=FALSE

  TYPE
    clt$input_line_kind = (clc$command_line, clc$command_continuation_line,
          clc$data_line);

*DECK DECK=CLT$INPUT_PROCEDURE EXPAND=FALSE

  TYPE
    clt$input_procedure = ^procedure (VAR line: ^clt$command_line;
                                      VAR status: ost$status);

*copyc clt$command_line
*copyc ost$status
*DECK DECK=CLT$INPUT_STATE EXPAND=FALSE

  TYPE
    clt$input_state = (clc$continue_input, clc$update_input, clc$end_of_input,
          clc$reset_input);

*DECK DECK=CLT$INTEGER EXPAND=FALSE

  TYPE
    clt$integer = record
      value: integer,
      radix: 2 .. 16,
      radix_specified: boolean,
    recend;

*DECK DECK=CLT$INTEGER_TYPE_QUALIFIER EXPAND=FALSE

  TYPE
    clt$integer_type_qualifier = record
      min_integer_value: integer,
      max_integer_value: integer,
      default_radix: 2 .. 16,
    recend;

*copyc clc$max_integer
*copyc clc$min_integer
*DECK DECK=CLT$INTERACTION_INFORMATION EXPAND=FALSE

  TYPE
    clt$interaction_information = record
      style: ost$interaction_style,
      menu_rows: cst$number_of_menu_rows,
      extend_utility_interaction: boolean,
    recend;

*copyc cst$number_of_menu_rows
*copyc ost$interaction_style

*DECK DECK=CLT$INTERNAL_COMMAND_REF_VALUE EXPAND=FALSE

  TYPE
    clt$internal_command_ref_value = record
      name_size: ost$name_size,
      form: clt$command_reference_form,
      cycle_number: fst$cycle_number,
      path_or_name_size: fst$path_size,
      { A ost$name_reference for the command name follows this record, its
      { size determined by the name_size field.
      { It may followed by a fst$file_reference for the name of the utility,
      { library or catalog, as appropriate according to the form field.
      { Its size (if present) is determined by the path_or_name_size field.
    recend;

*copyc clt$command_reference_form
*copyc fst$cycle_number
*copyc fst$path_size
*copyc ost$name
*DECK DECK=CLT$INTERNAL_DATA_VALUE EXPAND=FALSE

  TYPE
    clt$internal_data_value = record
      header: clt$internal_data_value_header,
      allocated_space: SEQ ( * ),
    recend;

*copyc clt$internal_data_value_header
*DECK DECK=CLT$INTERNAL_DATA_VALUE_HEADER EXPAND=FALSE

  TYPE
    clt$internal_data_value_header = record
      value: REL (clt$internal_data_value) ^clt$i_data_value,
      unused_space: clt$internal_data_value_size,
      minimum_allocation_increment: clt$internal_data_value_size,
    recend;

*copyc clt$i_data_value
*copyc clt$internal_data_value
*copyc clt$internal_data_value_size
*DECK DECK=CLT$INTERNAL_DATA_VALUE_SIZE EXPAND=FALSE

  TYPE
    clt$internal_data_value_size = 0 .. 7fffffff(16);

*DECK DECK=CLT$INTERNAL_FIELD_VALUE EXPAND=FALSE

  TYPE
    clt$internal_field_value = record
      name: clt$field_name,
      value: REL (clt$internal_data_value) ^clt$i_data_value,
    recend;

*copyc clt$field_name
*copyc clt$i_data_value
*copyc clt$internal_data_value
*DECK DECK=CLT$INTERNAL_INPUT_PROCEDURE EXPAND=FALSE

  TYPE
    clt$internal_input_procedure = ^procedure
          (VAR parse: clt$parse_state;
           VAR end_of_input: boolean;
           VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parse_state
*copyc ost$status
?? POP ??
*DECK DECK=CLT$INTERNAL_VARIABLE_CLASS EXPAND=FALSE

  TYPE
    clt$internal_variable_class = (clc$lib_variable, clc$env_variable,
          clc$proc_variable, clc$pushed_variable, clc$xdcled_variable,
          clc$xrefed_variable, clc$param_variable);

*DECK DECK=CLT$INTERNAL_VARIABLE_CLASSES EXPAND=FALSE

  TYPE
    clt$internal_variable_classes = SET OF clt$internal_variable_class;
*copyc clt$internal_variable_class

*DECK DECK=CLT$INTERPRETER_MODES EXPAND=FALSE

  TYPE
    clt$interpreter_modes = (clc$interpret_mode, clc$skip_mode, clc$help_mode);

*DECK DECK=CLT$I_DATA_VALUE EXPAND=FALSE

  TYPE
    clt$i_data_value = record
      case kind: clt$data_kind of
      = clc$application =
        application_value: REL (clt$internal_data_value)
              ^clt$application_value_text,
      = clc$array =
        array_value: REL (clt$internal_data_value) ^array [ * ] of
              REL (clt$internal_data_value) ^clt$i_data_value,
      = clc$boolean =
        boolean_value: clt$boolean,
      = clc$cobol_name =
        cobol_name_value: REL (clt$internal_data_value) ^clt$cobol_name,
      = clc$command_reference =
        command_reference_value: REL (clt$internal_data_value)
              ^clt$command_reference,
      = clc$data_name =
        data_name_value: REL (clt$internal_data_value) ^ost$name,
      = clc$date_time =
        date_time_value: clt$date_time,
      = clc$deferred =
        deferred_value: REL (clt$internal_data_value) ^clt$expression_text,
      = clc$entry_point_reference =
        entry_point_reference_value: REL (clt$internal_data_value)
              ^pmt$entry_point_reference,
*IF NOT $true(osv$unix)
      = clc$file =
*ELSE
      = {clc$file} clc$nos_ve_file, clc$unix_file =
*IFEND
        file_value: REL (clt$internal_data_value) ^fst$file_reference,
      = clc$integer =
        integer_value: clt$integer,
      = clc$keyword =
        keyword_value: REL (clt$internal_data_value) ^clt$keyword,
      = clc$list =
        element_value: REL (clt$internal_data_value) ^clt$i_data_value,
        link: REL (clt$internal_data_value) ^clt$i_data_value,
        generated_via_list_rest: boolean,
      = clc$lock =
        lock_value: REL (clt$internal_data_value) ^clt$lock,
      = clc$name =
        name_value: REL (clt$internal_data_value) ^ost$name,
      = clc$network_title =
        network_title_value: REL (clt$internal_data_value) ^nat$title,
      = clc$program_name =
        program_name_value: REL (clt$internal_data_value) ^pmt$program_name,
      = clc$range =
        low_value: REL (clt$internal_data_value) ^clt$i_data_value,
        high_value: REL (clt$internal_data_value) ^clt$i_data_value,
      = clc$real =
        real_value: clt$real,
      = clc$record =
        field_values: REL (clt$internal_data_value) ^array [1 .. * ] of
              clt$internal_field_value,
      = clc$scu_line_identifier =
        scu_line_identifier_value: clt$scu_line_identifier,
      = clc$statistic_code =
        statistic_code_value: sft$statistic_code,
      = clc$status =
        status_value: REL (clt$internal_data_value) ^ost$status,
      = clc$status_code =
        status_code_value: ost$status_condition_code,
      = clc$string =
        string_value: REL (clt$internal_data_value) ^clt$string_value,
      = clc$string_pattern =
        string_pattern_value: REL (clt$internal_data_value)
              ^clt$string_pattern,
      = clc$time_increment =
        time_increment_value: REL (clt$internal_data_value)
              ^pmt$time_increment,
      = clc$time_zone =
        time_zone_value: ost$time_zone,
      = clc$type_specification =
        type_specification_value: REL (clt$internal_data_value)
              ^clt$type_specification,
      = clc$unspecified =
        ,
      casend,
    recend;

*copyc clt$application_value_text
*copyc clt$boolean
*copyc clt$cobol_name
*copyc clt$command_reference
*copyc clt$data_kind
*copyc clt$date_time
*copyc clt$expression_text
*copyc clt$integer
*copyc clt$internal_data_value
*copyc clt$internal_field_value
*copyc clt$keyword
*copyc clt$lock
*copyc clt$real
*copyc clt$scu_line_identifier
*copyc clt$string_value
*copyc clt$string_pattern
*copyc clt$type_specification
*copyc fst$file_reference
*copyc nat$title
*copyc ost$name
*copyc ost$status
*copyc ost$status_condition_code
*copyc ost$time_zone
*copyc pmt$entry_point_reference
*copyc pmt$program_name
*copyc pmt$time_increment
*copyc sfd$type_declarations
*DECK DECK=CLT$I_PARAMETER_LIST_CONTENTS EXPAND=FALSE

{ The CLT$I_PARAMETER_LIST_CONTENTS type is used as the contents of the
{ CLT$PARAMETER_LIST that is passed to a command or function processor.  The
{ command or function processor will normally call CLP$EVALUATE_PARAMETERS,
{ which knows how to deal with a CLT$PARAMETER_LIST.  Processors that want the
{ text of the parameter list should call CLP$GET_PARAMETER_LIST_TEXT.
{
{ This type is used to optimize the calling of a command or function processor
{ such that no redundant lexical analysis of the parameter list is required.
{
{ The "old style" of parameter list contents consisted of a
{ CLT$PARAMETER_LIST_SIZE followed by the text of the parameter list, the
{ length of the text being determined by the CLT$PARAMETER_LIST_SIZE value.
{
{ This "new style" is distinguished from the old by always setting the
{ IDENTIFYING_SIZE_FIELD of this new style to its maximum value
{ (CLC$MAX_PARAMETER_SIZE) while making the CLT$PARAMETER_LIST sequence large
{ enough to hold just a CLT$I_PARAMETER_LIST_CONTENTS.  In the "old style",
{ this combination would have lead to a "garbled parameter list" error.
{
{ The actual data for the parameter list is stored in the appropriate block
{ for the command or function processor.

  TYPE
    clt$i_parameter_list_contents = record
      identifying_size_field: clt$parameter_list_size,
    recend;

*copyc clt$parameter_list_size
*DECK DECK=CLT$KEYWORD EXPAND=FALSE

  TYPE
    clt$keyword = ost$name;

*copyc ost$name
*DECK DECK=CLT$KEYWORD_INDEX EXPAND=FALSE

  TYPE
    clt$keyword_index = 1 .. clc$max_keywords;

*copyc clc$max_keywords
*DECK DECK=CLT$KEYWORD_REFERENCE EXPAND=FALSE

  TYPE
    clt$keyword_reference = ost$name_reference;

*copyc ost$name_reference
*DECK DECK=CLT$KEYWORD_SPECIFICATION EXPAND=FALSE

  TYPE
    clt$keyword_specification = record
      keyword: clt$keyword,
      class: clt$named_entry_class,
      availability: clt$named_entry_availability,
      ordinal: clt$named_entry_ordinal,
    recend;

*copyc clt$keyword
*copyc clt$named_entry_availability
*copyc clt$named_entry_class
*copyc clt$named_entry_ordinal
*DECK DECK=CLT$KEYWORD_SPECIFICATIONS EXPAND=FALSE

  TYPE
    clt$keyword_specifications = array [1 .. * ] of clt$keyword_specification;

*copyc clt$keyword_specification
*DECK DECK=CLT$KEYWORD_TYPE_QUALIFIER EXPAND=FALSE

  TYPE
    clt$keyword_type_qualifier = record
      number_of_keywords: 1 .. clc$max_keywords,
      { An array [1 .. number_of_keywords] of clt$keyword_specification }
      { follows the clt$keyword_type_qualifier. }
    recend;

*copyc clc$max_keywords
*copyc clt$keyword_specifications
*DECK DECK=CLT$LEXICAL_KINDS EXPAND=FALSE

  TYPE
    clt$lexical_kinds = (clc$unknown_token, clc$space_token, clc$eol_token,
          clc$dot_token, clc$semicolon_token, clc$colon_token,
          clc$lparen_token, clc$lbracket_token, clc$lbrace_token,
          clc$rparen_token, clc$rbracket_token, clc$rbrace_token,
          clc$uparrow_token, clc$rslant_token, clc$query_token,
          clc$comma_token, clc$ellipsis_token, clc$exp_token, clc$add_token,
          clc$sub_token, clc$mult_token, clc$div_token, clc$cat_token,
          clc$gt_token, clc$ge_token, clc$lt_token, clc$le_token, clc$eq_token,
          clc$ne_token, clc$string_token, clc$name_token, clc$integer_token,
          clc$real_token);

  CONST
    clc$assign_token = clc$eq_token;

*DECK DECK=CLT$LEXICAL_TOKEN EXPAND=FALSE

  TYPE
    clt$lexical_token = record
      text_index: clt$string_index,
      text_size: clt$string_size,
      descriptor: string (osc$max_name_size),
      case kind: clt$lexical_token_kind of
      = clc$unknown_token .. clc$string_token =
        str: ost$string,
        str_complete: boolean,
      = clc$unsigned_integer_token, clc$signed_integer_token =
        int: clt$integer,
      = clc$unsigned_real_token, clc$signed_real_token =
        rnum: clt$real,
      casend,
    recend;

*copyc clt$integer
*copyc clt$lexical_token_kind
*copyc clt$real
*copyc clt$string_index
*copyc clt$string_size
*copyc ost$name
*copyc ost$string
*DECK DECK=CLT$LEXICAL_TOKEN_KIND EXPAND=FALSE

  TYPE
    clt$lexical_token_kind = (clc$unknown_token, clc$end_of_line_token,
          clc$space_token, clc$comment_token, clc$semicolon_token,
          clc$colon_token, clc$cybil_assign_token, clc$left_parenthesis_token,
          clc$right_parenthesis_token, clc$comma_token, clc$ellipsis_token,
          clc$dot_token, clc$query_token, clc$greater_than_token,
          clc$greater_equal_token, clc$less_than_token, clc$less_equal_token,
          clc$equal_token, clc$not_equal_token, clc$concatenate_token,
          clc$exponentiate_token, clc$multiply_token, clc$divide_token,
          clc$add_token, clc$subtract_token, clc$left_bracket_token,
          clc$reverse_slant_token, clc$right_bracket_token,
          clc$circumflex_token, clc$grave_accent_token, clc$left_brace_token,
          clc$vertical_bar_token, clc$right_brace_token, clc$tilde_token,
          clc$number_sign_token, clc$dollar_sign_token,
          clc$commercial_at_token, clc$underscore_token, clc$name_token,
          clc$cybil_name_token, clc$special_cybil_name_token,
          clc$simple_name_token, clc$cobol_name_token, clc$string_token,
          clc$unsigned_integer_token, clc$signed_integer_token,
          clc$unsigned_real_token, clc$signed_real_token);

  CONST
    clc$assign_token = clc$equal_token;

*DECK DECK=CLT$LEXICAL_UNIT EXPAND=FALSE

  TYPE
    clt$lexical_unit = record
      size: clt$string_size,
      kind: clt$lexical_unit_kind,
    recend;

*copyc clt$lexical_unit_kind
*copyc clt$string_size
*DECK DECK=CLT$LEXICAL_UNITS EXPAND=FALSE

  TYPE
    clt$lexical_units = array [1 .. * ] of clt$lexical_unit;

*copyc clt$lexical_unit
*DECK DECK=CLT$LEXICAL_UNITS_INDEX EXPAND=FALSE

  TYPE
    clt$lexical_units_index = 1 .. clc$max_lexical_units;

*copyc clc$max_lexical_units
*DECK DECK=CLT$LEXICAL_UNIT_KIND EXPAND=FALSE

  TYPE
    clt$lexical_unit_kind = (clc$lex_unknown, clc$lex_beginning_of_line,
          clc$lex_end_of_line, clc$lex_space, clc$lex_comment,
          clc$lex_unterminated_comment, clc$lex_semicolon, clc$lex_colon,
          clc$lex_cybil_assign, clc$lex_left_parenthesis,
          clc$lex_right_parenthesis, clc$lex_comma, clc$lex_ellipsis,
          clc$lex_dot, clc$lex_query, clc$lex_greater_than,
          clc$lex_greater_equal, clc$lex_less_than, clc$lex_less_equal,
          clc$lex_equal, clc$lex_not_equal, clc$lex_concatenate,
          clc$lex_exponentiate, clc$lex_multiply, clc$lex_divide, clc$lex_add,
          clc$lex_subtract, clc$lex_name, clc$lex_long_name, clc$lex_string,
          clc$lex_unterminated_string, clc$lex_alpha_number,
          clc$lex_unsigned_decimal, clc$lex_wild_card_name);

  CONST
    clc$lex_assign = clc$lex_equal;

*DECK DECK=CLT$LEXICAL_UNIT_KINDS EXPAND=FALSE

  TYPE
    clt$lexical_unit_kinds = set of clt$lexical_unit_kind;

*copyc clt$lexical_unit_kind
*DECK DECK=CLT$LINE_IDENTIFIER EXPAND=FALSE

  TYPE
    clt$line_identifier = record
      byte_address: amt$file_byte_address,
      record_number: amt$file_byte_address,
      line_number_size: 0 .. amc$max_line_number,
      line_number: string (amc$max_line_number),
      statement_identifier_size: 0 .. amc$max_statement_id_length,
      statement_identifier: string (amc$max_statement_id_length),
    recend;

*copyc amt$file_byte_address
*copyc amt$line_number
*copyc amt$statement_identifier
*DECK DECK=CLT$LINE_LAYOUT EXPAND=FALSE

  CONST
    clc$nominal_command_line_size = osc$max_string_size +
          amc$max_statement_id_length + amc$max_line_number,
    clc$max_line_element_size = clc$max_command_line_size,
    clc$max_physical_line_size = clc$max_command_line_size +
          amc$max_statement_id_length + amc$max_line_number,
    clc$min_text_line_element_size = 1;

  TYPE
    clt$physical_line_size = clc$min_text_line_element_size ..
          clc$max_physical_line_size,
    clt$line_element_kind = (clc$null_line_element, clc$text_line_element,
          clc$statement_id_line_element, clc$line_number_line_element),
    clt$line_element_size = 0 .. clc$max_line_element_size,
    clt$line_layout = record
      physical_line_size: clt$physical_line_size,
      element: array [1 .. 3] of record
        kind: clt$line_element_kind,
        size: clt$line_element_size,
      recend,
    recend;

*copyc amt$line_number
*copyc amt$statement_identifier
*copyc clt$command_line
*copyc ost$string
*DECK DECK=CLT$LIST_SIZE EXPAND=FALSE

  TYPE
    clt$list_size = 0 .. clc$max_list_size;

*copyc clc$max_list_size
*DECK DECK=CLT$LIST_TYPE_QUALIFIER EXPAND=FALSE

  TYPE
    clt$list_type_qualifier = record
      element_type_specification_size: clt$type_specification_size,
      min_list_size: clt$list_size,
      max_list_size: clt$list_size,
      list_rest: boolean,
      { A clt$type_specification for the element type follows the }
      { clt$list_type_qualifier. }
    recend;

*copyc clt$list_size
*copyc clt$type_specification
*copyc clt$type_specification_size
*DECK DECK=CLT$LIST_TYPE_QUALIFIER_V2 EXPAND=FALSE

  TYPE
    clt$list_type_qualifier_v2 = packed record
      element_type_specification_size: ALIGNED clt$type_specification_size,
      min_list_size: ALIGNED clt$list_size,
      max_list_size: ALIGNED clt$list_size,
      reserved: 0 .. 3f(16) {6 bits - must be 0} ,
      defer_expansion: boolean,
      list_rest: boolean,
      { A clt$type_specification for the element type follows the }
      { clt$list_type_qualifier. }
    recend;

*copyc clt$list_size
*copyc clt$type_specification
*copyc clt$type_specification_size
*DECK DECK=CLT$LOCAL_QUEUE_FILE_TABLE EXPAND=FALSE

  CONST
    clc$max_local_queue_files = 6;

  TYPE
    clt$local_queue_file_entries = record
      local_file_name: amt$local_file_name,
      local_queue_id: pmt$queue_connection,
    recend,

    clt$local_queue_file_table = record
      next_available_entry: 1 .. clc$max_local_queue_files + 1,
      entries: array [1 .. clc$max_local_queue_files] of
            clt$local_queue_file_entries,
    recend;

*copyc amt$local_file_name
*copyc pmd$local_queues
*DECK DECK=CLT$LOCK EXPAND=FALSE

  TYPE
    clt$lock = record
      case state: clt$lock_state of
      = clc$lock_clear =
        ,
      = clc$lock_set, clc$lock_expired =
        set_by_job: jmt$system_supplied_name,
        set_by_task: pmt$task_id,
        expiration_date_time_rel_gmt: ost$date_time,
      casend,
    recend;

*copyc clt$lock_state
*copyc jmt$system_supplied_name
*copyc ost$date_time
*copyc pmt$task_id
*DECK DECK=CLT$LOCK_STATE EXPAND=FALSE

  TYPE
    clt$lock_state = (clc$lock_clear, clc$lock_set, clc$lock_expired);

*DECK DECK=CLT$LONGREAL EXPAND=FALSE

  TYPE
    clt$longreal = record
      case 1 .. 3 of
      = 1 =
        long_real: longreal,
      = 2 =
        first_real: real,
        second_real: real,
      = 3 =
        breakdown: clt$longreal_breakdown,
      casend,
    recend;

*copyc clt$longreal_breakdown
*DECK DECK=CLT$LONGREAL_BREAKDOWN EXPAND=FALSE

  TYPE
*IF NOT $true(osv$unix)
    clt$longreal_breakdown = record
      first: clt$real_breakdown,
      second: clt$real_breakdown,
    recend;
*ELSE
    clt$longreal_breakdown = clt$ieee_real_double;
*IFEND

*IF $true(osv$unix)
*copyc clt$ieee_real_double
*IFEND
*copyc clt$real_breakdown
*DECK DECK=CLT$LOW_OR_HIGH EXPAND=FALSE

  TYPE
    clt$low_or_high = (clc$low, clc$high);

*DECK DECK=CLT$MESSAGE_CACHE EXPAND=FALSE

  CONST
    clc$message_cache_size = 10;

  TYPE
    clt$message_cache = record
      count: 0 .. clc$message_cache_size,
      buffer: array [1 .. clc$message_cache_size] of clt$message_cache_entry,
    recend;

  TYPE
    clt$message_cache_entry = record
      code: ost$status_condition_code,
      name: ost$status_condition_name,
      severity: ost$message_module_severity,
*IF NOT $true(osv$unix)
      template: ^ost$message_template,
*ELSE
      template: string (256),
*IFEND
    recend;

*copyc ost$message_module_severity
*copyc ost$message_template
*copyc ost$status_condition_code
*copyc ost$status_condition_name
*DECK DECK=CLT$NAME EXPAND=FALSE

  TYPE
    clt$name = record
      size: ost$name_size,
      value: ost$name,
    recend;

*copyc ost$name
*DECK DECK=CLT$NAMED_ENTRY_AVAILABILITY EXPAND=FALSE

  TYPE
    clt$named_entry_availability = (clc$normal_usage_entry, clc$hidden_entry,
          clc$advanced_usage_entry);

  CONST
    clc$advertised_entry = clc$normal_usage_entry;

*DECK DECK=CLT$NAMED_ENTRY_CLASS EXPAND=FALSE

  TYPE
    clt$named_entry_class = (clc$nominal_entry, clc$alias_entry,
          clc$abbreviation_entry);

*DECK DECK=CLT$NAMED_ENTRY_ORDINAL EXPAND=FALSE

  TYPE
    clt$named_entry_ordinal = 1 .. 7fffffff(16);

*DECK DECK=CLT$NAMED_TASK EXPAND=FALSE

  TYPE
    clt$named_task = record
      link: ^clt$named_task,
      name: ost$name,
      id: pmt$task_id,
      parent_task_id: pmt$task_id,
      status: pmt$task_status,
    recend;

*copyc ost$name
*copyc pmt$task_id
*copyc pmt$task_status
*DECK DECK=CLT$NAME_FOLDING_LEVEL EXPAND=FALSE

  TYPE
    clt$name_folding_level = (clc$standard_folding, clc$full_folding);
*DECK DECK=CLT$NAME_TYPE_QUALIFIER EXPAND=FALSE

  TYPE
    clt$name_type_qualifier = record
      min_name_size: ost$name_size,
      max_name_size: ost$name_size,
    recend;

*copyc ost$name
*DECK DECK=CLT$NUMBER EXPAND=FALSE

  TYPE
    clt$number = record
      case kind: clt$number_kind of
      = clc$integer_number =
        integer_number: clt$integer,
      = clc$real_number =
        real_number: clt$real,
      casend,
    recend;

*copyc clt$integer
*copyc clt$number_kind
*copyc clt$real
*DECK DECK=CLT$NUMBER_KIND EXPAND=FALSE

  TYPE
    clt$number_kind = (clc$integer_number, clc$real_number);

*DECK DECK=CLT$NUMBER_KINDS EXPAND=FALSE

  TYPE
    clt$number_kinds = set of clt$number_kind;

*copyc clt$number_kind
*DECK DECK=CLT$NUMERIC_OPERAND_INFO EXPAND=FALSE

  TYPE
    clt$numeric_operand_info = record
      case initialized: boolean of
      = FALSE =
        ,
      = TRUE =
        sign: -1 .. 1,
        min_real_value: longreal,
        max_real_value: longreal,
        min_integer_value: integer,
        max_integer_value: integer,
        radix: record
          default: 2 .. 16,
          case established: boolean of
          = FALSE =
            ,
          = TRUE =
            value: 2 .. 16,
            specified: boolean,
          casend,
        recend,
      casend,
    recend;

*DECK DECK=CLT$PARAMETERS EXPAND=FALSE

{ The CLT$PARAMETERS type is used within appropriate CLT$BLOCK's for the
{ storage of command or function parameters.
{
{ The AREA field points to a SEQuence (allocated in OSV$TASK_SHARED_HEAP^)
{ which contains the data for the parameters noted below.
{
{ The EVALUATED field is initially FALSE and is set to TRUE once parameters
{ have been evaluated for the block.
{
{ The NAMES field points to the parameter names array.  The array is stored in
{ the AREA sequence for a procedure, but remains in the work area that was used
{ during parameter evaluation otherwise.  The NAMES field is NIL if the command
{ or function has no parameters or if evaluation was performed via
{ clp$evaluate_parameters.
{
{ The PROCEDURE_PARAMETERS field is TRUE if the block is for a command or
{ function procedure and FALSE otherwise.
{
{ The COMMAND_STATUS_SPECIFIED field is TRUE for a command procedure whose
{ standard status parameter was specified.
{
{ The elements of the ACCESSES field describe the parameters for a procedure.
{ A CLC$PASS_BY_VALUE (non-VAR) parameter is treated like a CLC$READ_ONLY
{ variable.  A CLC$PASS_BY_REFERENCE (VAR) parameter is treated like a
{ CLC$READ_WRITE variable.  The DESCRIPTORs and VALUE_QUALIFIERS for the
{ CLC$PASS_BY_VALUE (non-VAR) parameters are stored in the AREA sequence.  The
{ VALUEs for CLC$PASS_BY_VALUE (non-VAR) parameters are stored in the VALUES
{ sequence.  The DESCRIPTORs for CLC$READ_WRITE (VAR) parameters are stored
{ separately (see variable storage management).  The ACCESSES field is NIL if
{ the procedure has no parameters.
{
{ The VALUES field points to a SEQuence (allocated in OSV$TASK_SHARED_HEAP^)
{ which contains the data for the CLC$PASS_BY_VALUE (non-VAR) parameters.
{
{ The UNBUNDLED_PDT field is used (non-NIL) for a command or function.
{
{ The COMMAND_STATUS_VARIABLE field is non-NIL for a command whose
{ standard status parameter was specified.
{
{ The PARAMETER_VALUE_TABLE field is used (non-NIL) for a command that has
{ parameters and whose parameter evaluation was performed via
{ CLP$SCAN_PARAMETER_LIST.  The data it points to remains in the work area that
{ was used during parameter evaluation.


  TYPE
    clt$parameters = record
      area: ^SEQ ( * ),
      evaluated: boolean,
      names: ^clt$pdt_parameter_names,
      case procedure_parameters: boolean of
      = TRUE =
        command_status_specified: boolean,
        accesses: ^clt$parameter_accesses,
        values: ^SEQ ( * ),
      = FALSE =
        unbundled_pdt: ^clt$unbundled_pdt,
        command_status_variable: ^clt$variable_ref_expression,
        parameter_value_table: ^clt$parameter_value_table,
      casend,
    recend;

*copyc clt$parameter_accesses
*copyc clt$parameter_value_table
*copyc clt$pdt_parameter_names
*copyc clt$unbundled_pdt
*copyc clt$variable_ref_expression
*DECK DECK=CLT$PARAMETER_ACCESS EXPAND=FALSE

  TYPE
    clt$parameter_access = record
      name_index: clt$parameter_name_index,
      security: clt$parameter_security,
      specified: boolean,
      passed_variable_reference: ^clt$variable_ref_expression,
      qualifiers_area: ^SEQ ( * ),
      info: clt$variable_access_info,
    recend;

*copyc clt$parameter_name_index
*copyc clt$parameter_security
*copyc clt$variable_access_info
*copyc clt$variable_ref_expression
*DECK DECK=CLT$PARAMETER_ACCESSES EXPAND=FALSE

  TYPE
    clt$parameter_accesses = array [1 .. * ] of clt$parameter_access;

*copyc clt$parameter_access
*DECK DECK=CLT$PARAMETER_CHECKING_LEVEL EXPAND=FALSE

  TYPE
    clt$parameter_checking_level = (clc$standard_parameter_checking,
          clc$extended_parameter_checking);

*DECK DECK=CLT$PARAMETER_COUNT EXPAND=FALSE

  TYPE
    clt$parameter_count = 0 .. clc$max_parameters;

*copyc clc$max_parameters
*DECK DECK=CLT$PARAMETER_DESCRIPTION_TABLE EXPAND=FALSE

  TYPE
    clt$parameter_description_table = SEQ ( * );

  {
  { A clt$Parameter_Description_Table contains a header followed by one
  { or more of the following, depending on the header, in the order shown:
  {- an array [1 .. header.number_of_parameter_names] of clt$pdt_parameter_name
  {- an array [1 .. header.number_of_parameters] of clt$pdt_parameter
  {- a clt$type_specification, clt$variable_name (default name), and
  { clt$expression_text (default value) for each parameter, in parameter
  { position order
  {

*copyc cls$declaration_section
*copyc clt$pdt_header
*copyc clt$pdt_parameters
*copyc clt$pdt_parameter_names
*DECK DECK=CLT$PARAMETER_DESCRIPTOR_TABLE EXPAND=FALSE

  TYPE
    clt$parameter_descriptor_table = record
      names: ^array [1 .. * ] of clt$parameter_name_descriptor,
      parameters: ^array [1 .. * ] of clt$parameter_descriptor,
    recend;

  TYPE
    clt$parameter_name_descriptor = record
      name: ost$name,
      number: 1 .. clc$max_parameters,
    recend;

  TYPE
    clt$parameter_descriptor = record
      required_or_optional: clt$required_or_optional,
      min_value_sets: 1 .. clc$max_value_sets,
      max_value_sets: 1 .. clc$max_value_sets,
      min_values_per_set: 1 .. clc$max_values_per_set,
      max_values_per_set: 1 .. clc$max_values_per_set,
      value_range_allowed: (clc$value_range_not_allowed,
            clc$value_range_allowed),
      value_kind_specifier: clt$value_kind_specifier,
    recend;

*copyc cld$parameter_limits
*copyc cls$pdt_sections
*copyc clt$required_or_optional
*copyc clt$value_kind_specifier
*copyc ost$name
*DECK DECK=CLT$PARAMETER_DIALOG_MANAGER EXPAND=FALSE

  TYPE
    clt$parameter_dialog_manager = ^procedure
          (    support: clt$parameter_dialog_support;
               command_or_function_name: clt$command_name;
               online_manual_name: ost$online_manual_name;
               parameter_description_table: clt$unbundled_pdt;
           VAR cancel: boolean;
           VAR status {input, output} : ost$status);

*copyc clt$command_name
*copyc clt$parameter_dialog_support
*copyc clt$unbundled_pdt
*copyc ost$online_manual_name
*copyc ost$status
*DECK DECK=CLT$PARAMETER_DIALOG_SUPPORT EXPAND=FALSE

  TYPE
    clt$parameter_dialog_support = record
      get_brief_help: ^procedure
            (    max_message_line: ost$max_status_message_line;
             VAR message: ^ost$status_message;
             VAR status: ost$status),
      get_full_help: ^procedure
            (    max_message_line: ost$max_status_message_line;
             VAR message: ^ost$status_message;
             VAR status: ost$status),
      get_parameter_prompt: ^procedure
            (    parameter_number: clt$parameter_number;
                 max_message_line: ost$max_status_message_line;
             VAR message: ^ost$status_message;
             VAR status: ost$status),
      get_parameter_assist_prompt: ^procedure
            (    parameter_number: clt$parameter_number;
                 max_message_line: ost$max_status_message_line;
             VAR message: ^ost$status_message;
             VAR status: ost$status),
      get_parameter_help: ^procedure
            (    parameter_number: clt$parameter_number;
                 max_message_line: ost$max_status_message_line;
             VAR message: ^ost$status_message;
             VAR status: ost$status),
      get_all_parameter_specs: ^procedure
            (    include_advanced_items: boolean;
                 max_representation_line: clt$string_size;
             VAR representation: ^clt$data_representation;
             VAR status: ost$status),
      get_parameter_spec: ^procedure
            (    parameter_number: clt$parameter_number;
                 include_advanced_keywords: boolean;
                 max_representation_line: clt$string_size;
             VAR representation: ^clt$data_representation;
             VAR status: ost$status),
      get_parameter_value: ^procedure
            (    parameter_number: clt$parameter_number;
             VAR value: clt$parameter_value;
             VAR status: ost$status),
      get_parameter_value_source: ^procedure
            (    parameter_number: clt$parameter_number;
                 max_representation_line: clt$string_size;
             VAR representation: ^clt$data_representation;
             VAR status: ost$status),
      get_parameter_default: ^procedure
            (    parameter_number: clt$parameter_number;
             VAR text: ^clt$expression_text;
             VAR status: ost$status),
      evaluate_parameter: ^procedure
            (    parameter_number: clt$parameter_number;
                 text: clt$expression_text;
             VAR status: ost$status),
      restore_parameter_default: ^procedure
            (    parameter_number: clt$parameter_number;
             VAR status: ost$status),
      verify_all_parameters: ^procedure
            (VAR error_locator: clt$which_parameter;
             VAR status: ost$status),
      explain: ^procedure
            (VAR explanation_available: boolean;
             VAR status: ost$status),
      get_all_names: ^procedure
            (VAR names: ^array [1 .. * ] of clt$command_name;
             VAR status: ost$status),
      get_source: ^procedure
            (VAR source_string: fst$path;
             VAR source_string_size: fst$path_size;
             VAR status: ost$status),
      help_module: ^ost$help_module,
      change_expression_save: ^procedure
            (    save_expression_source: boolean;
             VAR status: ost$status),
      nested_dialog: ^procedure
            (    text: clt$expression_text;
                 dialog_pdt: clt$unbundled_pdt;
                 dialog_title: clt$string_value;
                 max_representation_line: clt$string_size;
             VAR representation: ^clt$data_representation;
             VAR status: ost$status),
      nested_dialog_title: ^clt$string_value,
    recend;

*copyc clt$command_name
*copyc clt$data_representation
*copyc clt$expression_text
*copyc clt$parameter_number
*copyc clt$parameter_value
*copyc clt$string_size
*copyc clt$which_parameter
*copyc fst$path
*copyc fst$path_size
*copyc ost$help_module
*copyc ost$max_status_message_line
*copyc ost$status
*copyc ost$status_message
*DECK DECK=CLT$PARAMETER_EVAL_CONTEXT EXPAND=FALSE

  TYPE
    clt$parameter_eval_context = record
      interpreter_mode: clt$interpreter_modes,
      interactive_origin: boolean,
      interaction_style: ost$interaction_style,
      prompting_requested: boolean,
      command_or_function_name: clt$command_name,
      command_or_function: clt$command_or_function,
      procedure_parameters: boolean,
      command_logging_completed: boolean,
      command_echoing_completed: boolean,
      command_or_function_source: ^clt$command_or_function_source,
    recend;

*copyc clt$command_name
*copyc clt$command_or_function
*copyc clt$command_or_function_source
*copyc clt$interpreter_modes
*copyc ost$interaction_style
*DECK DECK=CLT$PARAMETER_HELP_CONTEXT EXPAND=FALSE

  TYPE
    clt$parameter_help_context = record
      help_output_file: ^fst$file_reference,
*IF NOT $true(osv$unix)
      help_output_ring: ost$valid_ring,
*IFEND
      help_output_options: clt$parameter_help_options,
    recend;

*copyc clt$parameter_help_options
*copyc fst$file_reference
*copyc osd$virtual_address
*DECK DECK=CLT$PARAMETER_HELP_OPTION EXPAND=FALSE

  TYPE
    clt$parameter_help_option = (clc$ph_all_names, clc$ph_source,
          clc$ph_brief_help, clc$ph_full_help, clc$ph_compact_par_descriptions,
          clc$ph_parameter_descriptions, clc$ph_parameter_help,
*IF $true(osv$unix)
          clc$ph_advanced_usage, clc$ph_help_module_name, clc$ph_man);
*ELSE
          clc$ph_advanced_usage, clc$ph_help_module_name);
*IFEND
*DECK DECK=CLT$PARAMETER_HELP_OPTIONS EXPAND=FALSE

  TYPE
    clt$parameter_help_options = set of clt$parameter_help_option;

*copyc clt$parameter_help_option
*DECK DECK=CLT$PARAMETER_INDEX EXPAND=FALSE

  TYPE
    clt$parameter_index = 1 .. clc$max_parameters + 1;

*copyc clc$max_parameters
*DECK DECK=CLT$PARAMETER_LIST EXPAND=FALSE

  TYPE
    clt$parameter_list = pmt$program_parameters;

*copyc pmt$program_parameters
*DECK DECK=CLT$PARAMETER_LIST_CONTENTS EXPAND=FALSE

  TYPE
    clt$parameter_list_contents = record
      size: clt$parameter_list_text_size,
      text: clt$parameter_list_text,
    recend;

*copyc clt$parameter_list_text
*copyc clt$parameter_list_text_size
*DECK DECK=CLT$PARAMETER_LIST_SIZE EXPAND=FALSE

  TYPE
    clt$parameter_list_size = 0 .. clc$max_parameter_list_size;

*copyc clc$max_parameter_list_size
*DECK DECK=CLT$PARAMETER_LIST_TEXT EXPAND=FALSE

  TYPE
    clt$parameter_list_text = string ( * <= clc$max_parameter_list_size);

*copyc clc$max_parameter_list_size
*DECK DECK=CLT$PARAMETER_LIST_TEXT_INDEX EXPAND=FALSE

  TYPE
    clt$parameter_list_text_index = 1 .. clc$max_parameter_list_size + 1;

*copyc clc$max_parameter_list_size
*DECK DECK=CLT$PARAMETER_LIST_TEXT_SIZE EXPAND=FALSE

  TYPE
    clt$parameter_list_text_size = 0 .. clc$max_parameter_list_size;

*copyc clc$max_parameter_list_size
*DECK DECK=CLT$PARAMETER_NAME EXPAND=FALSE

  TYPE
    clt$parameter_name = ost$name;

*copyc ost$name
*DECK DECK=CLT$PARAMETER_NAME_COUNT EXPAND=FALSE

  TYPE
    clt$parameter_name_count = 0 .. clc$max_parameter_names;

*copyc clc$max_parameter_names
*DECK DECK=CLT$PARAMETER_NAME_INDEX EXPAND=FALSE

  TYPE
    clt$parameter_name_index = 1 .. clc$max_parameter_names;

*copyc clc$max_parameter_names
*DECK DECK=CLT$PARAMETER_NUMBER EXPAND=FALSE

  TYPE
    clt$parameter_number = 1 .. clc$max_parameters;

*copyc clc$max_parameters
*DECK DECK=CLT$PARAMETER_PASSING_METHOD EXPAND=FALSE

  TYPE
    clt$parameter_passing_method = (clc$pass_by_value, clc$pass_by_reference);

*DECK DECK=CLT$PARAMETER_REFERENCE EXPAND=FALSE

  TYPE
    clt$parameter_reference = string ( * <= osc$max_name_size);

*copyc ost$name
*DECK DECK=CLT$PARAMETER_REQUIREMENT EXPAND=FALSE

  TYPE
    clt$parameter_requirement = (clc$required_parameter,
          clc$optional_parameter, clc$optional_default_parameter,
          clc$confirm_default_parameter);

*DECK DECK=CLT$PARAMETER_SECURITY EXPAND=FALSE

  TYPE
    clt$parameter_security = (clc$non_secure_parameter, clc$secure_parameter);

*DECK DECK=CLT$PARAMETER_SPEC_METHOD EXPAND=FALSE

  TYPE
    clt$parameter_spec_method = (clc$specify_positionally,
          clc$specify_by_name);

*DECK DECK=CLT$PARAMETER_SPEC_METHODS EXPAND=FALSE

  TYPE
    clt$parameter_spec_methods = set of clt$parameter_spec_method;

*copyc clt$parameter_spec_method
*DECK DECK=CLT$PARAMETER_SUBSTITUTION EXPAND=FALSE

  TYPE
    clt$parameter_substitution = record
      name: clt$parameter_name,
      text: ^clt$expression_text,
    recend;

*copyc clt$expression_text
*copyc clt$parameter_name
*DECK DECK=CLT$PARAMETER_SUBSTITUTIONS EXPAND=FALSE

  TYPE
    clt$parameter_substitutions = array [1 .. * ] of
          clt$parameter_substitution;

*copyc clt$parameter_substitution
*DECK DECK=CLT$PARAMETER_VALUE EXPAND=FALSE

  TYPE
    clt$parameter_value = record
      specified: boolean,
      case passing_method: clt$parameter_passing_method of
      = clc$pass_by_value =
        value: ^clt$data_value, {NIL if omitted and no default}
      = clc$pass_by_reference =
        variable: ^clt$variable_ref_expression, {NIL if omitted and no default}
      casend,
    recend;

*copyc clt$data_value
*copyc clt$parameter_passing_method
*copyc clt$variable_ref_expression
*DECK DECK=CLT$PARAMETER_VALUE_TABLE EXPAND=FALSE

  TYPE
    clt$parameter_value_table = array [1 .. * ] of clt$parameter_value;

*copyc clt$parameter_value
*DECK DECK=CLT$PARSED_PATH EXPAND=FALSE

  TYPE
    clt$parsed_path = record
      name: clt$path_name,
      name_size: 1 .. clc$max_path_name_size,
      name_and_cycle_size: 1 .. clc$max_path_name_size,
      kind: clt$path_kind,
      number_of_elements: 1 .. clc$max_path_elements,
      first_specified_element: 1 .. clc$max_path_elements,
      element: array [1 .. clc$max_path_elements + 1] of
            0 .. clc$max_path_name_size + 1,
    recend;

*copyc cld$path_description
*copyc clt$path_kind
*copyc clt$path_name
*copyc ost$string
*DECK DECK=CLT$PARSED_VARIABLE EXPAND=FALSE

  TYPE
    clt$parsed_variable = record
      name: ost$name,
      subscript: record
        case present: boolean of
        = TRUE =
          value: clc$min_variable_dimension .. clc$max_variable_dimension,
        casend,
      recend,
      field: ost$name,
    recend;

*copyc cld$variable_reference
*copyc ost$name
*DECK DECK=CLT$PARSE_STATE EXPAND=FALSE

  TYPE
    clt$parse_state = record
      text: ^clt$string_value,
      index: clt$string_index,
      units_array: ^clt$lexical_units,
      units_array_index: clt$lexical_units_index,
      index_limit: clt$string_index,
      unit: clt$lexical_unit,
      unit_index: clt$string_index,
      unit_is_space: boolean,
      previous_unit_is_space: boolean,
      previous_non_space_unit: clt$lexical_unit,
      previous_non_space_unit_index: clt$string_index,
    recend;

*copyc clt$lexical_unit
*copyc clt$lexical_units
*copyc clt$lexical_units_index
*copyc clt$string_index
*copyc clt$string_value
*DECK DECK=CLT$PATH_DISPLAY_CHUNKS EXPAND=FALSE

  TYPE
    clt$path_display_chunks = array [1 .. fsc$max_path_elements] of record
      position: integer,
      length: integer,
    recend;

*copyc fsc$max_path_elements
*DECK DECK=CLT$PATH_HANDLE EXPAND=FALSE

  TYPE
    clt$path_handle = record
      case kind: clt$path_handle_kind of
      = clc$not_a_path_handle =
        ,
      = clc$regular_path_handle =
        regular_handle: fmt$path_handle,
      = clc$command_file_handle =
        block_handle: clt$block_handle,
      casend,
    recend;

*copyc clt$block_handle
*copyc clt$path_handle_kind
*copyc fmt$path_handle
*DECK DECK=CLT$PATH_HANDLE_KIND EXPAND=FALSE

  TYPE
    clt$path_handle_kind = (clc$not_a_path_handle, clc$regular_path_handle,
          clc$command_file_handle);

*DECK DECK=CLT$PATH_KIND EXPAND=FALSE

  TYPE
    clt$path_kind = (clc$local_catalog_path, clc$local_file_path,
          clc$permanent_file_path, clc$permanent_catalog_path,
          clc$perm_file_or_catalog_path);

*DECK DECK=CLT$PATH_NAME EXPAND=FALSE

  TYPE
    clt$path_name = string (clc$max_path_name_size);

  CONST
    clc$max_path_name_size = osc$max_string_size;

*copyc ost$string
*DECK DECK=CLT$PDT_CHANGE EXPAND=FALSE

  TYPE
    clt$pdt_change = record
      number: clt$parameter_number,
      case kind: clt$pdt_change_kind of
      = clc$pdtc_availability =
        availability: clt$named_entry_availability,
      = clc$pdtc_security =
        security: clt$parameter_security,
      = clc$pdtc_type =
        type_changes: ^clt$type_changes,
      = clc$pdtc_default_value =
        default_value: ^clt$expression_text,
      = clc$pdtc_null =
        ,
      casend,
    recend;

*copyc clt$expression_text
*copyc clt$named_entry_availability
*copyc clt$parameter_number
*copyc clt$parameter_security
*copyc clt$pdt_change_kind
*copyc clt$type_changes
*DECK DECK=CLT$PDT_CHANGES EXPAND=FALSE

  TYPE
    clt$pdt_changes = array [1 .. * ] of clt$pdt_change;

*copyc clt$pdt_change
*DECK DECK=CLT$PDT_CHANGE_KIND EXPAND=FALSE

  TYPE
    clt$pdt_change_kind = (clc$pdtc_null, clc$pdtc_availability,
          clc$pdtc_security, clc$pdtc_type, clc$pdtc_default_value);

*DECK DECK=CLT$PDT_HEADER EXPAND=FALSE

  TYPE
    clt$pdt_header = record
      version: clt$declaration_version,
      generation_date_time: ost$date_time,
      command_or_function: clt$command_or_function,
      number_of_parameter_names: clt$parameter_name_count,
      number_of_parameters: clt$parameter_count,
      number_of_required_parameters: clt$parameter_count,
      number_of_advanced_parameters: clt$parameter_count,
      number_of_hidden_parameters: clt$parameter_count,
      number_of_var_parameters: clt$parameter_count,
      status_parameter_number: 0 .. clc$max_parameters,
      help_module_name: pmt$program_name,
    recend;

*copyc clc$max_parameters
*copyc clt$command_or_function
*copyc clt$declaration_version
*copyc clt$parameter_count
*copyc clt$parameter_name_count
*copyc ost$date_time
*copyc pmt$program_name
*DECK DECK=CLT$PDT_PARAMETER EXPAND=FALSE

  TYPE
    clt$pdt_parameter = record
      name_index: clt$parameter_name_index,
      availability: clt$named_entry_availability,
      security: clt$parameter_security,
      specification_methods: clt$parameter_spec_methods,
      passing_method: clt$parameter_passing_method,
      evaluation_method: clt$expression_eval_method,
      checking_level: clt$parameter_checking_level,
      type_specification_size: clt$type_specification_size,
      requirement: clt$parameter_requirement,
      default_name_size: 0 .. osc$max_name_size,
      default_value_size: clt$expression_text_size,
    recend;

*copyc clt$expression_eval_method
*copyc clt$expression_text_size
*copyc clt$named_entry_availability
*copyc clt$parameter_checking_level
*copyc clt$parameter_name_index
*copyc clt$parameter_passing_method
*copyc clt$parameter_requirement
*copyc clt$parameter_security
*copyc clt$parameter_spec_methods
*copyc clt$type_specification_size
*copyc ost$name
*DECK DECK=CLT$PDT_PARAMETERS EXPAND=FALSE

  TYPE
    clt$pdt_parameters = array [1 .. * ] of clt$pdt_parameter;

*copyc clt$pdt_parameter
*DECK DECK=CLT$PDT_PARAMETER_NAME EXPAND=FALSE

  TYPE
    clt$pdt_parameter_name = record
      name: clt$parameter_name,
      class: clt$named_entry_class,
      position: clt$parameter_number,
    recend;

*copyc clt$named_entry_class
*copyc clt$parameter_name
*copyc clt$parameter_number
*DECK DECK=CLT$PDT_PARAMETER_NAMES EXPAND=FALSE

  TYPE
    clt$pdt_parameter_names = array [1 .. * ] of clt$pdt_parameter_name;

*copyc clt$pdt_parameter_name
*DECK DECK=CLT$PF_PATH_CONTAINER EXPAND=FALSE

  CONST
    clc$max_pf_path_elements = 2 + (osc$max_string_size DIV 2);

  TYPE
    clt$pf_path_container = SEQ (REP clc$max_pf_path_elements of pft$name);

  TYPE
    clt$pf_cycle_selector = record
      specification: clt$pf_cycle_specification,
      value: pft$cycle_selector,
    recend,
    clt$pf_cycle_specification = (clc$pf_cycle_omitted, clc$pf_cycle_specified,
          clc$pf_cycle_next_highest, clc$pf_cycle_next_lowest);

*copyc ost$string
*copyc pfd$permanent_file_definitions
*DECK DECK=CLT$PROCEDURE_VARIABLE_SCOPE EXPAND=FALSE

  TYPE
    clt$procedure_variable_scope = clc$local_scope .. clc$xref_scope;

*copyc clt$variable_declaration_scope
*DECK DECK=CLT$PROCESSING_PHASE EXPAND=FALSE
{ Common deck clt$_processing_phase. }

  TYPE
    clt$processing_phase = (clc$job_begin_phase, clc$system_prolog_phase,
          clc$class_prolog_phase, clc$account_prolog_phase,
          clc$project_prolog_phase, clc$member_prolog_phase,
          clc$user_prolog_phase, clc$command_phase, clc$user_epilog_phase,
          clc$member_epilog_phase, clc$project_epilog_phase,
          clc$account_epilog_phase, clc$class_epilog_phase,
          clc$system_epilog_phase, clc$job_end_phase);

*DECK DECK=CLT$PROC_INPUT_PROCEDURE EXPAND=FALSE

  TYPE
    clt$proc_input_procedure = ^procedure
           (VAR line: ost$string;
            VAR index: ost$string_index;
            VAR token: clt$token;
            VAR status: ost$status);

*copyc clt$token
*copyc ost$status
*copyc ost$string
*DECK DECK=CLT$PROC_INPUT_TYPE EXPAND=FALSE

  TYPE
    clt$proc_input_type = (clc$proc_input, clc$pdt_input);

*DECK DECK=CLT$PROC_NAMES EXPAND=FALSE

  TYPE
    clt$proc_names = array [1 .. * ] of ost$name;

*copyc ost$name
*DECK DECK=CLT$PROMPT EXPAND=FALSE

  TYPE
    clt$prompt = string ( * <= clc$max_prompt_size);

*copyc clc$max_prompt_size
*DECK DECK=CLT$PROMPT_SIZE EXPAND=FALSE

  TYPE
    clt$prompt_size = 0 .. clc$max_prompt_size;

*copyc clc$max_prompt_size
*DECK DECK=CLT$PROMPT_STRING EXPAND=FALSE

  TYPE
    clt$prompt_string = string ( * <= clc$max_prompt_string_size);

*copyc clc$max_prompt_string_size
*DECK DECK=CLT$PUSHED_LINE EXPAND=FALSE

  TYPE
    clt$pushed_line = record
      previous: ^clt$pushed_line,
      line: clt$expandable_string,
      parse: clt$parse_state,
    recend;

*copyc clt$expandable_string
*copyc clt$parse_state
*DECK DECK=CLT$RANGE_TYPE_QUALIFIER EXPAND=FALSE

  TYPE
    clt$range_type_qualifier = record
      element_type_specification_size: clt$type_specification_size,
      { A clt$type_specification for the element type follows the }
      { clt$range_type_qualifier. }
    recend;

*copyc clt$type_specification
*copyc clt$type_specification_size
*DECK DECK=CLT$RANGE_VALUE_SIZE EXPAND=FALSE

  TYPE
    clt$range_value_size = record
      low_value_size: clt$internal_data_value_size,
      high_value_size: clt$internal_data_value_size,
    recend;

*copyc clt$internal_data_value_size
*DECK DECK=CLT$REAL EXPAND=FALSE

  TYPE
    clt$real = record
      value: longreal,
      number_of_digits: clt$real_number_digit_count,
    recend;

*copyc clt$real_number_digit_count
*DECK DECK=CLT$REAL_BREAKDOWN EXPAND=FALSE

  TYPE
*IF NOT $true(osv$unix)
    clt$real_breakdown = record
      exponent: 0 .. 0ffff(16),
      mantissa: 0 .. 0ffffffffffff(16),
    recend;
*ELSE
    clt$real_breakdown = clt$ieee_real_single;
*IFEND

*IF $true(osv$unix)
*copyc clt$ieee_real_single
*IFEND
*DECK DECK=CLT$REAL_NUMBER_CLASS EXPAND=FALSE

  TYPE
    clt$real_number_class = (clc$real_indefinite, clc$real_negative_infinite,
          clc$real_negative_standard, clc$real_zero,
          clc$real_positive_standard, clc$real_positive_infinite);

*DECK DECK=CLT$REAL_NUMBER_CLASSES EXPAND=FALSE

  TYPE
    clt$real_number_classes = set of clt$real_number_class;

*copyc clt$real_number_class
*DECK DECK=CLT$REAL_NUMBER_DIGIT_COUNT EXPAND=FALSE

  TYPE
    clt$real_number_digit_count = 1 .. clc$max_real_number_digits;

*copyc clc$max_real_number_digits
*DECK DECK=CLT$REAL_TYPE_QUALIFIER EXPAND=FALSE

  TYPE
    clt$real_type_qualifier = record
      min_real_value: clt$longreal,
      max_real_value: clt$longreal,
    recend;

*copyc clt$longreal
*DECK DECK=CLT$RECORD_TYPE_QUALIFIER EXPAND=FALSE

  TYPE
    clt$record_type_qualifier = record
      number_of_fields: clt$field_number,
      { There are number_of_fields occurrences of a clt$field_specification }
      { followed by a clt$type_specification following the }
      { clt$record_type_qualifier. }
    recend;

*copyc clt$field_number
*copyc clt$field_specification
*copyc clt$type_specification
*DECK DECK=CLT$REQUIRED_OR_OPTIONAL EXPAND=FALSE

  TYPE
    clt$required_or_optional = record
      case selector: (clc$required, clc$optional, clc$optional_with_default) of
      = clc$required =
        ,
      = clc$optional =
        ,
      = clc$optional_with_default =
        default: ^string ( * ),
      casend,
    recend;

*DECK DECK=CLT$SAME_SIGN_INFINITIES_ORDER EXPAND=FALSE

  TYPE
    clt$same_sign_infinities_order = (clc$infinities_unordered,
          clc$infinities_equal);

*DECK DECK=CLT$SAVED_WORK_AREA_POSITIONS EXPAND=FALSE

  TYPE
*IF NOT $true(osv$unix)
    clt$saved_work_area_positions = array [osc$tsrv_ring .. osc$user_ring_2] of
*ELSE
    clt$saved_work_area_positions =
*IFEND
          0 .. 7fffffff(16);

*copyc osd$virtual_address
*DECK DECK=CLT$SCL_OPTIONS EXPAND=FALSE

  TYPE
    clt$scl_options = record
      line_style_correction_prompts: record
        case selected: boolean of
        = FALSE =
          ,
        = TRUE =
          prompting_style: osc$line_interaction .. osc$screen_interaction,
        casend,
      recend,
      screen_style_correction_prompts: record
        selected: boolean,
      recend,
      name_folding_level: clt$name_folding_level,
      wild_card_pattern_type: clt$wild_card_pattern_type,
    recend;

*copyc clt$name_folding_level
*copyc clt$wild_card_pattern_type
*copyc ost$interaction_style
*DECK DECK=CLT$SCL_PROCEDURE EXPAND=FALSE

  TYPE
    clt$scl_procedure = SEQ ( * );

*DECK DECK=CLT$SCL_PROCEDURE_HEADER EXPAND=FALSE

{ A CLT$SCL_PROCEDURE_HEADER is the first thing in a CLT$SCL_PROCEDURE
{ SEQuence is used to hold and SCL command or function procedure on an object
{ library
{
{ The COMMAND_OR_FUNCTION_NAME field of the header is the first name from the
{ declaration for the procedure.
{
{ The INITIAL_LINE_FOR_ECHOING field of the header is a relative pointer to a
{ line of text that can be used when the proc is executed for echoing in lieu
{ of echoing the declaration header.  This line immediately follows the header.
{
{ The PARAMETER_DESCRIPTION_TABLE field of the header is a relative pointer to
{ the procedure's PDT which immediately follows the initial line for echoing.
{
{ The CHECK_PARAMETER_STATEMENTS field of the header is a relative pointer to
{ an array that follows the PDT, each element of which is a relative pointer to
{ the clt$input_data for the optional CHECK / CHECEND statement for the
{ corresponding procedure parameter.
{
{ The last thing in the clt$scl_procedure is the clt$input_data for the entire
{ procedure.
{
{ The ENTIRE_PROCEDURE field of the header is a relative pointer to the
{ clt$input_data for all the lines of the procedure, which is the last thing in
{ the clt$scl_procedure.  The pointers to clt$input_data for the parameter
{ CHECK / CHECKEND statements mentioned above, and the other pointer in the
{ header actually point to subsets of the data pointed to by this field.
{
{ The PROCEDURE_DECLARATION field of the header is a relative pointer to the
{ clt$input_data for the lines that contain the procedure's declaration.
{
{ The CHECK_STATEMENT field of the header is a relative pointer to the
{ clt$input_data for the optional CHECK / CHECEND statement for the procedure
{ as a whole.
{
{ The PROCEDURE_BODY field of the header is a relative pointer to the
{ clt$input_data for the lines that comprise the body of the procedure,
{ including the PROCEND or FUNCEND statement (if present).
{
{ The header also contains the information necessary to distinguish the above
{ described format for a clt$scl_procedure from that used prior to NOS/VE
{ release 1.3.1.
{
{ The old format consisted of just the "raw" data for the procedure as a series
{ of lines.  Each line was represented by a clt$command_line_size followed by
{ the line's text of that length.
{
{ To distinguish between the old format and that described above, use is made
{ of the fact that for procedures in the old format, their declaration lines
{ could not exceed 256 (osc$max_string_size) characters in length.  However,
{ the clt$command_line_size type used for the length of each line occupies two
{ bytes and can represent lengths of up to 65535 (clc$max_command_line_size).
{ The first byte of a clt$scl_procedure_header (the IDENTIFYING_FIRST_BYTE
{ field) is always set to its maximum value, 0FF(16), a value which could not
{ occur in the old format.  The VERSION field of the header identifies the
{ version of the clt$scl_procedure format subsequent to release 1.3.1.  (This
{ allows for future changes to the format in an upward compatible fashion.)

  TYPE
    clt$scl_procedure_header = record
      identifying_first_byte: 0 .. 0ff(16),
      version: clt$declaration_version,
      command_or_function_name: clt$command_name,
      initial_line_for_echoing: REL (clt$scl_procedure) ^clt$command_line,
      parameter_description_table: REL (clt$scl_procedure)
            ^clt$parameter_description_table,
      check_parameter_statements: REL (clt$scl_procedure) ^array [1 .. * ] of
            REL (clt$scl_procedure) ^clt$input_data,
      entire_procedure: REL (clt$scl_procedure) ^clt$input_data,
      procedure_declaration: REL (clt$scl_procedure) ^clt$input_data,
      check_statement: REL (clt$scl_procedure) ^clt$input_data,
      procedure_body: REL (clt$scl_procedure) ^clt$input_data,
    recend;

*copyc clt$command_line
*copyc clt$command_name
*copyc clt$declaration_version
*copyc clt$input_data
*copyc clt$parameter_description_table
*copyc clt$scl_procedure
*DECK DECK=CLT$SCL_SIGNAL EXPAND=FALSE

  TYPE
    clt$scl_signal = record
      case 1 .. 2 of
      = 1 =
        signal: pmt$signal,
      = 2 =
        identifier: pmt$signal_id,
        contents: clt$scl_signal_contents,
      casend,
    recend;

*copyc clt$scl_signal_contents
*copyc pmt$signal
*DECK DECK=CLT$SCL_SIGNAL_CONTENTS EXPAND=FALSE

  TYPE
    clt$scl_signal_contents = record
      case kind: clt$scl_signal_kind of
      = clc$signal_exiting =
        child_task_id: pmt$task_id,
        exit_control_block: ^clt$block,
      casend,
    recend;

*copyc clt$block
*copyc clt$scl_signal_kind
*copyc pmt$task_id
*DECK DECK=CLT$SCL_SIGNAL_KIND EXPAND=FALSE

  TYPE
    clt$scl_signal_kind = (clc$signal_exiting, clc$signal_reserved);

*DECK DECK=CLT$SCU_LINE_IDENTIFIER EXPAND=FALSE

  TYPE
    clt$scu_line_identifier = record
      modification_name: clt$scu_modification_name,
      sequence_number: clt$scu_sequence_number,
    recend;

*copyc clt$scu_modification_name
*copyc clt$scu_sequence_number
*DECK DECK=CLT$SCU_MODIFICATION_NAME EXPAND=FALSE

  TYPE
    clt$scu_modification_name = string (clc$max_scu_modification_name);

*copyc clc$max_scu_modification_name
*DECK DECK=CLT$SCU_SEQUENCE_NUMBER EXPAND=FALSE

  TYPE
    clt$scu_sequence_number = 1 .. clc$max_scu_sequence_number;

*copyc clc$max_scu_sequence_number
*DECK DECK=CLT$SLU_TERMINATION_OPTION EXPAND=FALSE

{ termination options for clp$scan_lexical_unit

  TYPE
    clt$slu_termination_option = (clc$slu_any, clc$slu_non_space);

*DECK DECK=CLT$SOURCE EXPAND=FALSE

  TYPE
    clt$source = record
      case kind: clt$source_kind of
      = clc$system_source =
        ,
      = clc$utility_source =
        utility_name: clt$utility_name,
      = clc$catalog_source, clc$library_source =
        path_name: fst$path,
      casend,
    recend;

*copyc clt$source_kind
*copyc clt$utility_name
*copyc fst$path
*DECK DECK=CLT$SOURCE_KIND EXPAND=FALSE

  TYPE
    clt$source_kind = (clc$system_source, clc$utility_source,
          clc$catalog_source, clc$library_source);

*DECK DECK=CLT$STANDARD_FILE EXPAND=FALSE

  TYPE
    clt$standard_file = record
*IF NOT $true(osv$unix)
      path_handle_name: fst$path_handle_name,
      path_handle: fmt$path_handle,
*ELSE
      unix_file_name: ost_standard_file_name,
      file_id: amt$file_identifier,
*IFEND
    recend;

*IF NOT $true(osv$unix)
*copyc fst$path_handle_name
*copyc fmt$path_handle
*ELSE
*copyc amt$file_identifier
*copyc ost_standard_file_name
*IFEND
*DECK DECK=CLT$STANDARD_FILES EXPAND=FALSE

  TYPE
*IF NOT $true(osv$unix)
    clt$standard_files = (clc$sf_job_log_file, clc$sf_null_file,
          clc$sf_job_input_file, clc$sf_standard_input_file,
          clc$sf_job_output_file, clc$sf_standard_output_file,
          clc$sf_error_file, clc$sf_list_file, clc$sf_echo_file,
          clc$sf_response_file, clc$sf_command_file, clc$sf_terminal_file,
          clc$sf_display_a_file, clc$sf_display_b_file,
          clc$sf_not_a_standard_file);
*ELSE
    clt$standard_files = (clc$sf_null_file,
          clc$sf_job_input_file, clc$sf_standard_input_file,
          clc$sf_job_output_file, clc$sf_standard_output_file,
          clc$sf_error_file, clc$sf_command_file, clc$sf_not_a_standard_file);

*IFEND
*DECK DECK=CLT$STRING_INDEX EXPAND=FALSE

  TYPE
    clt$string_index = 1 .. clc$max_string_size + 1;

*copyc clc$max_string_size
*DECK DECK=CLT$STRING_PATTERN EXPAND=FALSE

  TYPE
    clt$string_pattern = SEQ ( * );

*DECK DECK=CLT$STRING_PATTERN_ANCHOR_OPT EXPAND=FALSE

  TYPE
    clt$string_pattern_anchor_opt = (clc$sp_anchored, clc$sp_unanchored);

*DECK DECK=CLT$STRING_PATTERN_BUILD_OPTION EXPAND=FALSE

  TYPE
    clt$string_pattern_build_option = 0 .. 7;

  CONST
    clc$sp_unused_build_option_0 = 0,
    clc$sp_unused_build_option_1 = 1,
    clc$sp_unused_build_option_2 = 2,
    clc$sp_unused_build_option_3 = 3,

    clc$sp_file_reference_pattern = 4,
    clc$sp_match_at_left = 5,
    clc$sp_match_at_right = 6,
    clc$sp_ignore_matched_substring = 7;

*DECK DECK=CLT$STRING_PATTERN_BUILD_OPTS EXPAND=FALSE

  TYPE
    clt$string_pattern_build_opts = set of clt$string_pattern_build_option;

*copyc clt$string_pattern_build_option
*DECK DECK=CLT$STRING_PATTERN_MATCH_INFO EXPAND=FALSE

  TYPE
    clt$string_pattern_match_info = record
      case result: clt$string_pattern_match_result of
      = clc$sp_success =
        index: clt$string_index,
        size: clt$string_size,
      = clc$sp_failure =
        ,
      casend,
    recend;

*copyc clt$string_index
*copyc clt$string_pattern_match_result
*copyc clt$string_size
*DECK DECK=CLT$STRING_PATTERN_MATCH_RESULT EXPAND=FALSE

  TYPE
    clt$string_pattern_match_result = (clc$sp_success, clc$sp_failure);

*DECK DECK=CLT$STRING_PATTERN_SCAN_OPTION EXPAND=FALSE

  TYPE
    clt$string_pattern_scan_option = (clc$sp_quick_scan, clc$sp_full_scan);

*DECK DECK=CLT$STRING_PATTERN_SIZE EXPAND=FALSE

  TYPE
    clt$string_pattern_size = 1 .. 7fffffff(16);

*DECK DECK=CLT$STRING_SIZE EXPAND=FALSE

  TYPE
    clt$string_size = 0 .. clc$max_string_size;

*copyc clc$max_string_size
*DECK DECK=CLT$STRING_TYPE_QUALIFIER EXPAND=FALSE

  TYPE
    clt$string_type_qualifier = record
      min_string_size: clt$string_size,
      max_string_size: clt$string_size,
      literal: boolean,
    recend;

*copyc clt$string_size
*DECK DECK=CLT$STRING_VALUE EXPAND=FALSE

  TYPE
    clt$string_value = string ( * <= clc$max_string_size);

*copyc clc$max_string_size
*DECK DECK=CLT$SUBSTITUTION_MARK EXPAND=FALSE

  TYPE
    clt$substitution_mark = record
      case specified: boolean of
      = TRUE =
        value: char,
      casend,
    recend;

*DECK DECK=CLT$SYMBOLIC_PARAMETER EXPAND=FALSE

  TYPE
    clt$symbolic_parameter = record
      min_value_sets: ^string ( * ),
      max_value_sets: ^string ( * ),
      min_values_per_set: ^string ( * ),
      max_values_per_set: ^string ( * ),
      value_kind_qualifier_low: ^string ( * ),
      value_kind_qualifier_high: ^string ( * ),
    recend;

*DECK DECK=CLT$SYMBOLIC_PARAMETERS EXPAND=FALSE

  TYPE
    clt$symbolic_parameters = array [1 .. * ] of clt$symbolic_parameter;

*copyc clt$symbolic_parameter
*DECK DECK=CLT$SYMBOLIC_SUBRANGE_QUALIFIER EXPAND=FALSE

{
{ The clt$symbolic_subrange_qualifier is inserted into a clt$type_specification
{ following the qualifiers for arrays, integers, lists, names and strings if
{ the include_symbolic_qualifiers was selected when the type specification was
{ generated.  This option is selected by the generate_pdt command so that CYBIL
{ constant expressions can be used within a PDT for these qualifiers.
{

  TYPE
    clt$symbolic_subrange_qualifier = record
      low_text_size: clt$expression_text_size,
      high_text_size: clt$expression_text_size,
      { Following the clt$symbolic_subrange_qualifier is a clt$expression_text
      { for the low side of the subrange, followed by a clt$expression_text
      { for the high side of the subrange.  The sizes of these strings are
      { determined by the above fields.  If high_text_size is zero the text
      { for the high side of the subrange is the same as that for the low.
    recend;

*copyc clt$expression_text
*copyc clt$expression_text_size
*DECK DECK=CLT$SYSTEM_FILE_IDENTIFIERS EXPAND=FALSE

  TYPE
    clt$system_file_identifiers = record
*IF NOT $true(osv$unix)
      echoed_commands: record
        case id_defined: boolean of
        = FALSE =
          ,
        = TRUE =
          id: amt$file_identifier,
        casend,
      recend,
*IFEND
      error_output: record
        case id_defined: boolean of
        = FALSE =
          ,
        = TRUE =
          id: amt$file_identifier,
        casend,
      recend,
*IF NOT $true(osv$unix)
      job_command_response: record
        case id_defined: boolean of
        = FALSE =
          ,
        = TRUE =
          id: amt$file_identifier,
        casend,
      recend,
*IFEND
      job_output: record
        case id_defined: boolean of
        = FALSE =
          ,
        = TRUE =
          id: amt$file_identifier,
        casend,
      recend,
    recend;

*copyc amt$file_identifier
*DECK DECK=CLT$TASK_LIST EXPAND=FALSE

  TYPE
    clt$task_list = record
      head: ^clt$block,
      lock: ost$signature_lock,
      current_job_synchronous_task: ^clt$block,
    recend;

*copyc clt$block
*copyc ost$signature_lock
*DECK DECK=CLT$TASK_NAME EXPAND=FALSE

  TYPE
    clt$task_name = ost$name;

*copyc ost$name
*DECK DECK=CLT$TASK_NAME_REFERENCE EXPAND=FALSE

  TYPE
    clt$task_name_reference = string ( * <= osc$max_name_size);

*copyc ost$name
*DECK DECK=CLT$TOKEN EXPAND=FALSE

  TYPE
    clt$token = record
      text_index: ost$string_index,
      text_size: ost$string_size,
      descriptor: string (osc$max_name_size),
      case kind: clt$lexical_kinds of
      = clc$unknown_token .. clc$string_token =
        str: ost$string,
      = clc$name_token =
        name: clt$name,
      = clc$integer_token =
        int: clt$integer,
      = clc$real_token =
        rnum: clt$real,
      casend,
    recend;

*copyc clt$integer
*copyc clt$lexical_kinds
*copyc clt$name
*copyc clt$real
*copyc ost$string
*DECK DECK=CLT$TOKEN_EVALUATION_OPTION EXPAND=FALSE

  TYPE
    clt$token_evaluation_option = (clc$ignore_spaces_before_token,
          clc$comment_is_token, clc$classify_name_token,
          clc$cobol_name_is_token, clc$special_cybil_name_is_token,
          clc$international_char_is_token, clc$special_char_is_token);

*DECK DECK=CLT$TOKEN_EVALUATION_OPTIONS EXPAND=FALSE

  TYPE
    clt$token_evaluation_options = set of clt$token_evaluation_option;

*copyc clt$token_evaluation_option
*DECK DECK=CLT$TYPE_CHANGE EXPAND=FALSE

  TYPE
    clt$type_change = record
      case kind: clt$type_change_kind of
      = clc$tc_integer_subrange =
        min_integer_value: integer,
        max_integer_value: integer,
      = clc$tc_keyword_availability =
        keyword: clt$keyword,
        availability: clt$named_entry_availability,
      = clc$tc_list_size =
        min_list_size: clt$list_size,
        max_list_size: clt$list_size,
      = clc$tc_real_subrange =
        min_real_value: longreal,
        max_real_value: longreal,
      = clc$tc_string_size =
        min_string_size: clt$string_size,
        max_string_size: clt$string_size,
      = clc$tc_null =
        ,
      casend,
    recend;

*copyc clt$keyword
*copyc clt$list_size
*copyc clt$named_entry_availability
*copyc clt$string_size
*copyc clt$type_change_kind
*DECK DECK=CLT$TYPE_CHANGES EXPAND=FALSE

  TYPE
    clt$type_changes = array [1 .. * ] of clt$type_change;

*copyc clt$type_change
*DECK DECK=CLT$TYPE_CHANGE_KIND EXPAND=FALSE

  TYPE
    clt$type_change_kind = (clc$tc_null, clc$tc_keyword_availability,
          clc$tc_integer_subrange, clc$tc_list_size, clc$tc_real_subrange,
          clc$tc_string_size);

*DECK DECK=CLT$TYPE_CONFORMANCE EXPAND=FALSE

  TYPE
    clt$type_conformance = (clc$no_conformance_to_type,
          clc$conforms_to_generic_type, clc$conforms_to_type,
          clc$identical_types);

*DECK DECK=CLT$TYPE_DESCRIPTION EXPAND=FALSE

  TYPE
    clt$type_description = record
      specification: ^clt$type_specification,
      name: ^clt$type_name_reference,
      derived_from_value_kind_spec: boolean,
      advanced_keywords_present: boolean,
*IF NOT $true(osv$unix)
      kinds: clt$type_kinds,
*ELSE
      kinds: clt$type_kinds_v2,
*IFEND
      case kind: clt$type_kind of
      = clc$application_type =
        balance_brackets: boolean,
      = clc$array_type =
        array_element_type_description: ^clt$type_description,
        case array_bounds_defined: boolean of
        = TRUE =
          bounds: clt$array_bounds,
        = FALSE =
          ,
        casend,
      = clc$boolean_type =
        ,
      = clc$cobol_name_type =
        ,
      = clc$command_reference_type =
        ,
      = clc$data_name_type =
        ,
      = clc$date_time_type =
        date_and_or_time: clt$date_and_or_time,
        tenses: clt$date_time_tenses,
      = clc$entry_point_reference_type =
        ,
*IF NOT $true(osv$unix)
      = clc$file_type =
*ELSE
      = {clc$file_type} clc$nos_ve_file_type, clc$unix_file_type =
*IFEND
        ,
      = clc$integer_type =
        min_integer_value: integer,
        max_integer_value: integer,
        default_radix: 2 .. 16,
      = clc$keyword_type =
        keyword_specifications: ^clt$keyword_specifications,
      = clc$list_type =
        list_element_type_description: ^clt$type_description,
        min_list_size: clt$list_size,
        max_list_size: clt$list_size,
        list_rest: boolean,
        defer_expansion: boolean,
      = clc$lock_type =
        ,
      = clc$name_type =
        min_name_size: ost$name_size,
        max_name_size: ost$name_size,
      = clc$network_title_type =
        ,
      = clc$program_name_type =
        ,
      = clc$range_type =
        range_element_type_description: ^clt$type_description,
      = clc$real_type =
        min_real_value: clt$longreal,
        max_real_value: clt$longreal,
      = clc$record_type =
        fields_pdt: ^clt$unbundled_pdt,
      = clc$scu_line_identifier_type =
        ,
      = clc$statistic_code_type =
        ,
      = clc$status_type =
        ,
      = clc$status_code_type =
        ,
      = clc$string_type =
        min_string_size: clt$string_size,
        max_string_size: clt$string_size,
        literal: boolean,
      = clc$string_pattern_type =
        ,
      = clc$time_increment_type =
        ,
      = clc$time_zone_type =
        ,
      = clc$type_specification_type =
        ,
      = clc$union_type =
        member_descriptions: ^array [1 .. * ] of clt$type_description,
        union_information: ^clt$union_type_information,
      casend,
    recend;

*copyc clt$array_bounds
*copyc clt$date_and_or_time
*copyc clt$date_time_tenses
*copyc clt$keyword_specifications
*copyc clt$list_size
*copyc clt$longreal
*copyc clt$string_size
*copyc clt$type_kind
*IF NOT $true(osv$unix)
*copyc clt$type_kinds
*ELSE
*copyc clt$type_kinds_v2
*IFEND
*copyc clt$type_name_reference
*copyc clt$type_specification
*copyc clt$unbundled_pdt
*copyc clt$union_type_information
*copyc ost$name
*DECK DECK=CLT$TYPE_INFORMATION EXPAND=FALSE

  TYPE
    clt$type_information = record
      case kind: clt$type_kind of
      = clc$application_type =
        balance_brackets: boolean,
      = clc$array_type =
        array_element_type_information: ^clt$type_information,
        case array_bounds_defined: boolean of
        = TRUE =
          bounds: clt$array_bounds,
        = FALSE =
          ,
        casend,
      = clc$boolean_type =
        ,
      = clc$cobol_name_type =
        ,
      = clc$command_reference_type =
        ,
      = clc$data_name_type =
        ,
      = clc$date_time_type =
        date_and_or_time: clt$date_and_or_time,
        tenses: clt$date_time_tenses,
      = clc$entry_point_reference_type =
        ,
*IF NOT $true(osv$unix)
      = clc$file_type =
*ELSE
      = {clc$file_type} clc$nos_ve_file_type, clc$unix_file_type =
*IFEND
        ,
      = clc$integer_type =
        min_integer_value: integer,
        max_integer_value: integer,
        default_radix: 2 .. 16,
      = clc$keyword_type =
        keyword_specifications: ^clt$keyword_specifications,
      = clc$list_type =
        list_element_type_information: ^clt$type_information,
        min_list_size: clt$list_size,
        max_list_size: clt$list_size,
        list_rest: boolean,
        defer_expansion: boolean,
      = clc$lock_type =
        ,
      = clc$name_type =
        min_name_size: ost$name_size,
        max_name_size: ost$name_size,
      = clc$network_title_type =
        ,
      = clc$program_name_type =
        ,
      = clc$range_type =
        range_element_type_information: ^clt$type_information,
      = clc$real_type =
        min_real_value: longreal,
        max_real_value: longreal,
      = clc$record_type =
        fields_information: ^array [1 .. * ] of clt$field_information,
      = clc$scu_line_identifier_type =
        ,
      = clc$statistic_code_type =
        ,
      = clc$status_type =
        ,
      = clc$status_code_type =
        ,
      = clc$string_type =
        min_string_size: clt$string_size,
        max_string_size: clt$string_size,
        literal: boolean,
      = clc$string_pattern_type =
        ,
      = clc$time_increment_type =
        ,
      = clc$time_zone_type =
        ,
      = clc$type_specification_type =
        ,
      = clc$union_type =
        members_information: ^array [1 .. * ] of clt$type_information,
      casend,
    recend;

*copyc clt$array_bounds
*copyc clt$date_and_or_time
*copyc clt$date_time_tenses
*copyc clt$keyword_specifications
*copyc clt$field_information
*copyc clt$list_size
*copyc clt$string_size
*copyc clt$type_kind
*copyc ost$name
*DECK DECK=CLT$TYPE_KIND EXPAND=FALSE

  TYPE
    clt$type_kind = (clc$application_type, clc$array_type, clc$boolean_type,
          clc$cobol_name_type, clc$command_reference_type, clc$data_name_type,
*IF NOT $true(osv$unix)
          clc$date_time_type, clc$entry_point_reference_type, clc$file_type,
          clc$integer_type, clc$keyword_type, clc$list_type, clc$lock_type,
          clc$name_type, clc$network_title_type, clc$program_name_type,
          clc$range_type, clc$real_type, clc$record_type,
          clc$scu_line_identifier_type, clc$statistic_code_type,
          clc$status_type, clc$status_code_type, clc$string_type,
          clc$string_pattern_type, clc$time_increment_type, clc$time_zone_type,
          clc$type_specification_type, clc$union_type);
*ELSE
          clc$date_time_type, clc$entry_point_reference_type,
          clc$nos_ve_file_type, clc$integer_type, clc$keyword_type,
          clc$list_type, clc$lock_type, clc$name_type, clc$network_title_type,
          clc$program_name_type, clc$range_type, clc$real_type,
          clc$record_type, clc$scu_line_identifier_type,
          clc$statistic_code_type, clc$status_type, clc$status_code_type,
          clc$string_type, clc$string_pattern_type, clc$time_increment_type,
          clc$time_zone_type, clc$type_specification_type, clc$union_type,
          clc$unix_file_type,
          {} clc$reserved_type_kind_30,
          {} clc$reserved_type_kind_31);

    CONST
      clc$file_type = clc$unix_file_type;

*IFEND

*DECK DECK=CLT$TYPE_KINDS EXPAND=FALSE

  TYPE
*IF NOT $true(osv$unix)
    clt$type_kinds = set of clt$type_kind;
*ELSE
    clt$type_kinds = set of clc$application_type .. clc$union_type;
*IFEND

*copyc clt$type_kind
*DECK DECK=CLT$TYPE_NAME EXPAND=FALSE

  TYPE
    clt$type_name = clt$variable_name;

*copyc clt$variable_name
*DECK DECK=CLT$TYPE_NAME_REFERENCE EXPAND=FALSE

  TYPE
    clt$type_name_reference = string ( * <= osc$max_name_size);

*copyc ost$name
*DECK DECK=CLT$TYPE_SPECIFICATION EXPAND=FALSE

  TYPE
    clt$type_specification = SEQ ( * );

  {
  { A clt$type_specification contains a clt$type_specification_header
  { followed by a qualifier for the particular type being specified.
  { For certain types the qualifier may not be present.
  {

*copyc cls$declaration_section
*copyc clt$application_type_qualifier
*copyc clt$array_type_qualifier
*copyc clt$date_time_type_qualifier
*copyc clt$integer_type_qualifier
*copyc clt$keyword_type_qualifier
*copyc clt$list_type_qualifier "for backward compatibility"
*copyc clt$list_type_qualifier_v2
*copyc clt$name_type_qualifier
*copyc clt$range_type_qualifier
*copyc clt$real_type_qualifier
*copyc clt$record_type_qualifier
*copyc clt$string_type_qualifier
*copyc clt$type_name_reference
*copyc clt$type_specification_header
*IF NOT $true(osv$unix)
*copyc clt$union_type_qualifier
*ELSE
*copyc clt$union_type_qualifier "for backward compatibility"
*copyc clt$union_type_qualifier_v2
*IFEND
*DECK DECK=CLT$TYPE_SPECIFICATION_HEADER EXPAND=FALSE

  TYPE
    clt$type_specification_header = record
      version: clt$declaration_version,
      name_size: 0 .. osc$max_name_size,
      { clt$type_name_reference follows header if name_size > 0 }
      case kind: clt$type_kind of
      = clc$application_type =
        { clt$application_type_qualifier follows header } ,
      = clc$array_type =
        { clt$array_type_qualifier follows header } ,
      = clc$boolean_type =
        ,
      = clc$cobol_name_type =
        ,
      = clc$command_reference_type =
        ,
      = clc$data_name_type =
        ,
      = clc$date_time_type =
        { clt$date_time_type_qualifier follows header } ,
      = clc$entry_point_reference_type =
        ,
*IF NOT $true(osv$unix)
      = clc$file_type =
*ELSE
      = {clc$file_type} clc$nos_ve_file_type, clc$unix_file_type =
*IFEND
        ,
      = clc$integer_type =
        { clt$integer_type_qualifier follows header } ,
      = clc$keyword_type =
        { clt$keyword_type_qualifier follows header } ,
      = clc$list_type =
*IF NOT $true(osv$unix)
        { clt$list_type_qualifier follows header } ,
*ELSE
        { clt$list_type_qualifier[_v2] follows header } ,
*IFEND
      = clc$lock_type =
        ,
      = clc$name_type =
        { clt$name_type_qualifier follows header } ,
      = clc$network_title_type =
        ,
      = clc$program_name_type =
        ,
      = clc$range_type =
        { clt$range_type_qualifier follows header } ,
      = clc$real_type =
        { clt$real_type_qualifier follows header } ,
      = clc$record_type =
        { clt$record_type_qualifier follows header } ,
      = clc$scu_line_identifier_type =
        ,
      = clc$statistic_code_type =
        ,
      = clc$status_type =
        ,
      = clc$status_code_type =
        ,
      = clc$string_type =
        { clt$string_type_qualifier follows header } ,
      = clc$string_pattern_type =
        ,
      = clc$time_increment_type =
        ,
      = clc$time_zone_type =
        ,
      = clc$type_specification_type =
        ,
      = clc$union_type =
*IF NOT $true(osv$unix)
        { clt$union_type_qualifier follows header } ,
*ELSE
        { clt$union_type_qualifier[_v2] follows header } ,
*IFEND
      casend,
    recend;

*copyc clt$declaration_version
*copyc clt$type_kind
*copyc ost$name
*DECK DECK=CLT$TYPE_SPECIFICATION_SIZE EXPAND=FALSE

  TYPE
    clt$type_specification_size = 0 .. clc$max_type_specification_size;

*copyc clc$max_type_specification_size
*DECK DECK=CLT$UNBUNDLED_PDT EXPAND=FALSE

  TYPE
    clt$unbundled_pdt = record
      header: ^clt$pdt_header,
      names: ^clt$pdt_parameter_names,
      parameters: ^clt$pdt_parameters,
      type_descriptions: ^array [1 .. * ] of clt$type_description,
      default_names: ^array [1 .. * ] of ^clt$variable_name_reference,
      default_values: ^array [1 .. * ] of ^clt$expression_text,
    recend;

*copyc clt$expression_text
*copyc clt$parameter_count
*copyc clt$pdt_header
*copyc clt$pdt_parameter_names
*copyc clt$pdt_parameters
*copyc clt$type_description
*copyc clt$variable_name_reference
*DECK DECK=CLT$UNION_MEMBER_NUMBER EXPAND=FALSE

  TYPE
    clt$union_member_number = 0 .. clc$max_union_members;

*copyc clc$max_union_members
*DECK DECK=CLT$UNION_TYPE_INFORMATION EXPAND=FALSE

  TYPE
    clt$union_type_information = record
      only_standard_types_in_union: boolean,
      { The "standard" types have non-conflicting expression forms, therefore
      { an expression for a union of them can be evaluated without the need for
      { trying each type individually.  The "standard" types are:  boolean,
      { file, integer (if default radix is 10), name, real, status, string (if
      { not literal), string_pattern, and union (consisting only of these
      { "standard" types).
      min_integer_value: integer,
      max_integer_value: integer,
      default_radix: 2 .. 16,
      min_real_value: clt$longreal,
      max_real_value: clt$longreal,
    recend;

*copyc clc$max_integer
*copyc clc$min_integer
*copyc clt$longreal
*DECK DECK=CLT$UNION_TYPE_QUALIFIER EXPAND=FALSE

  TYPE
    clt$union_type_qualifier = record
      kinds: clt$type_kinds,
      only_standard_types_in_union: boolean,
      { The "standard" types have non-conflicting expression forms, therefore
      { an expression for a union of them can be evaluated without the need for
      { trying each type individually.  The "standard" types are:  boolean,
      { file, integer (if default radix is 10), name, real, status, string (if
      { not literal), string_pattern, and union (consisting only of these
      { "standard" types).
      case number_of_members: clt$union_member_number of
      = 0 =
        { The union consists of all possible types. } ,
      = 1 .. clc$max_union_members =
        { There are number_of_members occurrences of a }
        { clt$type_specification_size followed by a clt$type_specification }
        { following the clt$union_type_qualifier. }
      casend,
    recend;

*copyc clc$max_union_members
*copyc clt$type_kinds
*copyc clt$type_specification
*copyc clt$type_specification_size
*copyc clt$union_member_number
*DECK DECK=CLT$UNSEEN_MAIL_ACTION EXPAND=FALSE
  TYPE
    clt$unseen_mail_action = (clc$post_unseen_mail, clc$display_unseen_mail);

*DECK DECK=CLT$USER_IDENTIFICATION EXPAND=FALSE

  TYPE
    clt$user_identification = record
      user: fst$path_element,
      family: fst$path_element,
    recend;

*copyc fst$path_element
*DECK DECK=CLT$UTILITY_ATTRIBUTE EXPAND=FALSE

{
{ The clt$utility_attribute data type is used to define (clp$BEGIN_utility),
{ change (clp$CHANGE_utility_attributes), and get (clp$GET_utility_attributes)
{ the attributes of a command utility.  Not all of the attributes apply to
{ all of the requests. In a comment accompanying each attribute key in the
{ following type declaration are indications of which requests that attribute
{ may be used with.  The indications are given by the words in upper case
{ letters in the above list of interface names.
{

  TYPE
    clt$utility_attribute = record
      case key: clt$utility_attribute_key of
      = clc$null_utility_attribute = {BEGIN, CHANGE, GET}
        ,
      = clc$utility_command_search_mode = {BEGIN, GET}
        command_search_mode: clt$command_search_modes,
      = clc$utility_command_table = {BEGIN, CHANGE, GET}
        command_table: ^clt$command_table,
      = clc$utility_function_table = {BEGIN, CHANGE, GET}
        function_table: ^clt$function_table,
      = clc$utility_function_proc_table = {BEGIN, CHANGE, GET}
        function_processor_table: ^clt$function_processor_table,
      = clc$utility_interactive_include = {BEGIN, CHANGE, GET}
        interactive_include_processor: clt$utility_interactive_in_desc,
      = clc$utility_libraries = {GET} {for use by the UTILITY/UTILEND command}
        libraries: ^array [1 .. * ] of fst$path,
      = clc$utility_line_preprocessor = {BEGIN, CHANGE, GET}
        line_preprocessor: clt$utility_line_preproc_desc,
      = clc$utility_name = {GET}
        name: clt$utility_name,
      = clc$utility_online_manual = {BEGIN, CHANGE, GET}
        online_manual_name: ost$online_manual_name,
      = clc$utility_prompt = {BEGIN, CHANGE, GET}
        prompt: clt$utility_prompt,
      = clc$utility_subcmnd_log_enabled = {BEGIN, CHANGE, GET}
        subcommand_logging_enabled: boolean,
      = clc$utility_termination_command = {BEGIN, GET}
        termination_command: clt$command_name,
      casend,
    recend;

*copyc clt$command_name
*copyc clt$command_search_modes
*copyc clt$command_table
*copyc clt$function_processor_table
*copyc clt$function_table
*copyc clt$utility_attribute_key
*copyc clt$utility_interactive_in_desc
*copyc clt$utility_line_preproc_desc
*copyc clt$utility_name
*copyc clt$utility_prompt
*copyc fst$path
*copyc ost$online_manual_name
*DECK DECK=CLT$UTILITY_ATTRIBUTES EXPAND=FALSE

  TYPE
    clt$utility_attributes = array [1 .. * ] of clt$utility_attribute;

*copyc clt$utility_attribute
*DECK DECK=CLT$UTILITY_ATTRIBUTE_KEY EXPAND=FALSE

  TYPE
    clt$utility_attribute_key = (clc$null_utility_attribute,
          clc$utility_command_search_mode, clc$utility_command_table,
          clc$utility_function_table, clc$utility_function_proc_table,
          clc$utility_interactive_include, clc$utility_libraries,
          clc$utility_line_preprocessor, clc$utility_name,
          clc$utility_online_manual, clc$utility_prompt,
          clc$utility_subcmnd_log_enabled, clc$utility_termination_command);

*DECK DECK=CLT$UTILITY_AUXILIARY_LIBRARIES EXPAND=FALSE

  TYPE
    clt$utility_auxiliary_libraries = array [1 .. * ] of
          clt$utility_auxiliary_library;

*copyc clt$utility_auxiliary_library
*DECK DECK=CLT$UTILITY_AUXILIARY_LIBRARY EXPAND=FALSE

  TYPE
    clt$utility_auxiliary_library = record
      name: fst$path_handle_name,
      contains: clt$command_library_contains,
    recend;

*copyc clt$command_list
*copyc fst$path_handle_name
*DECK DECK=CLT$UTILITY_COMMAND_ENVIRONMENT EXPAND=FALSE

  TYPE
    clt$utility_command_environment = record
      commands: ^clt$command_table,
      contemporary_functions: ^clt$function_processor_table,
      original_functions: ^clt$function_table,
      libraries: ^array [1 .. * ] of fst$path_handle_name,
      subcommand_logging_enabled: boolean,
      command_level: boolean,
      task_id: pmt$task_id,
      previous_search_mode: clt$command_search_modes,
      termination_command_ordinal: clt$named_entry_ordinal,
      termination_command_index: clt$command_table_index,
      auxiliary_libraries: ^clt$utility_auxiliary_libraries,
      dialog_info: clt$utility_dialog_info,
    recend;

*copyc clt$command_search_modes
*copyc clt$command_table
*copyc clt$command_table_index
*copyc clt$function_processor_table
*copyc clt$function_table
*copyc clt$named_entry_ordinal
*copyc clt$utility_auxiliary_libraries
*copyc clt$utility_dialog_info
*copyc fst$path_handle_name
*copyc pmt$task_id
*DECK DECK=CLT$UTILITY_DIALOG_INFO EXPAND=FALSE

  TYPE
    clt$utility_dialog_info = record
      commands: ^clt$command_table,
      functions: ^clt$function_processor_table,
      scratch_segment: ^ SEQ ( * ),
    recend;

*copyc clt$command_table
*copyc clt$function_processor_table
*DECK DECK=CLT$UTILITY_DIALOG_MANAGER EXPAND=FALSE

  TYPE
    clt$utility_dialog_manager = ^procedure
           (    utility: clt$utility_name;
                dialog_info: ^clt$utility_dialog_info;
            VAR status: ost$status);

*copyc clt$utility_dialog_info
*copyc clt$utility_name
*copyc ost$status
*DECK DECK=CLT$UTILITY_INTERACTIVE_INCLUDE EXPAND=FALSE

  TYPE
    clt$utility_interactive_include = ^procedure
           (    interaction_style: ost$interaction_style;
            VAR status: ost$status);

*copyc ost$interaction_style
*copyc ost$status
*DECK DECK=CLT$UTILITY_INTERACTIVE_IN_DESC EXPAND=FALSE

  TYPE
    clt$utility_interactive_in_desc = record
      case call_method: clt$call_method of
      = clc$unspecified_call =
        {this option specifies the absence of an interactive include processor}
        ,
      = clc$linked_call =
        proc: clt$utility_interactive_include,
      = clc$unlinked_call =
        procedure_name: pmt$program_name,
      = clc$proc_call, clc$program_call =
        command_name: pmt$program_name,
      casend,
    recend;

*copyc clt$call_method
*copyc clt$utility_interactive_include
*copyc pmt$program_name
*DECK DECK=CLT$UTILITY_LINE_PREPROCESSOR EXPAND=FALSE

  TYPE
    clt$utility_line_preprocessor = ^procedure
           (    command_line: ^clt$command_line;
                interactive_source: boolean;
                interpreting_commands: boolean;
            VAR edited_command_line: ^clt$command_line;
            VAR status: ost$status);

*copyc clt$command_line
*copyc ost$status
*DECK DECK=CLT$UTILITY_LINE_PREPROC_DESC EXPAND=FALSE

  TYPE
    clt$utility_line_preproc_desc = record
      case call_method: clt$call_method of
      = clc$unspecified_call =
        , {this option specifies the absence of a line preprocessor}
      = clc$linked_call =
        proc: clt$utility_line_preprocessor,
      = clc$unlinked_call =
        procedure_name: pmt$program_name,
      = clc$proc_call, clc$program_call =
        command_name: pmt$program_name,
      casend,
    recend;

*copyc clt$call_method
*copyc clt$utility_line_preprocessor
*copyc pmt$program_name
*DECK DECK=CLT$UTILITY_NAME EXPAND=FALSE

  TYPE
    clt$utility_name = ost$name;

*copyc ost$name
*DECK DECK=CLT$UTILITY_PROMPT EXPAND=FALSE

  TYPE
    clt$utility_prompt = record
      size: clt$prompt_size,
      value: string (clc$max_prompt_size),
    recend;

*copyc clc$max_prompt_size
*copyc clt$prompt_size
*DECK DECK=CLT$VALUE_KINDS EXPAND=FALSE

  TYPE
    clt$value_kinds = clt$data_value_kind;

{
{ The following clt$value_kinds are defined in terms of some of the new
{ clt$data_value_kind's.
{ This is done in order to facilitate simultaneous support of both the
{ old and new value representations.
{ Although this is certainly a "kludge", it is workable because the old
{ representation (clt$value) is strictly a subset of the new representation
{ (clt$data_value).
{

  CONST
    clc$variable_reference = clc$deferred_value,
    clc$any_value = clc$array_value,
    clc$unknown_value = clc$unspecified_value;

*copyc clt$data_value_kind
*DECK DECK=CLT$VALUE_KIND_SPECIFIER EXPAND=FALSE

  TYPE
    clt$value_kind_specifier = record
      keyword_values: ^array [1 .. * ] of ost$name,
      case kind: clt$value_kinds of
      = clc$keyword_value, clc$any_value =
        ,
      = clc$variable_reference =
        array_allowed: (clc$array_not_allowed, clc$array_allowed),
        variable_kind: clc$string_value .. clc$any_value,
      = clc$application_value =
        value_name: clt$application_value_name,
        scanner: record
          case kind: clt$av_scanner_kind of
          = clc$unspecified_av_scanner =
            ,
          = clc$linked_av_scanner =
            proc: ^clt$application_value_scanner,
          = clc$unlinked_av_scanner =
            name: pmt$program_name,
          casend,
        recend,
      = clc$file_value =
        ,
      = clc$name_value =
        min_name_size: ost$name_size,
        max_name_size: ost$name_size,
      = clc$string_value =
        min_string_size: ost$string_size,
        max_string_size: ost$string_size,
      = clc$integer_value =
        min_integer_value: integer,
        max_integer_value: integer,
      = clc$real_value, clc$boolean_value, clc$status_value =
        ,
      casend,
    recend;

*copyc clc$max_integer
*copyc clc$min_integer
*copyc cld$application_value_scanner
*copyc clt$application_value
*copyc clt$value_kinds
*copyc ost$name
*copyc ost$string
*copyc pmt$program_name
*DECK DECK=CLT$VALUE_QUALIFIER EXPAND=FALSE

  TYPE
    clt$value_qualifier = record
      parse: ^clt$parse_state,
      case kind: clt$value_qualifier_kind of
      = clc$array_subscript_qualifier =
        array_subscript: clt$array_bound,
        bounds: clt$array_bounds,
      = clc$field_qualifier, clc$unspecified_field_qualifier =
        field_name: clt$field_name,
        case record_kind: clt$value_qualifier_records of
        = clc$command_reference_record .. clc$entry_point_ref_record,
              clc$scu_line_ident_record .. clc$unknown_record =
          ,
        = clc$record_record =
          field_names: ^clt$pdt_parameter_names,
        casend,
      = clc$invalid_field_qualifier =
        invalid_field_status: ^ost$status,
      = clc$invalid_subscript_qual =
        invalid_subscript_status: ^ost$status,
        case subscript_defined: boolean of
        = TRUE =
         invalid_subscript: integer,
        casend,
      = clc$invalid_substring_qual =
        invalid_index: integer,
        invalid_separator: char,
        invalid_substring_status: ^ost$status,
        case size_defined: boolean of
        = TRUE =
         invalid_size: integer,
        casend,
      = clc$list_subscript_qualifier =
        list_subscript: clt$array_bound,
      = clc$range_qualifier =
        low_or_high: clt$low_or_high,
      = clc$substring_qualifier =
        index: clt$array_bound,
        size: clt$string_size,
        all_specified: boolean,
      = clc$unspecified_subscript_qual =
        unspecified_subscript: integer,
      = clc$unspecified_substring_qual =
        unspecified_index: integer,
        unspecified_size: integer,
        unspecified_all_found: boolean,
        unspecified_separator: char,
      casend,
    recend;

*copyc clt$array_bounds
*copyc clt$field_name
*copyc clt$low_or_high
*copyc clt$pdt_parameter_names
*copyc clt$string_index
*copyc clt$string_size
*copyc clt$value_qualifier_kind
*copyc clt$value_qualifier_records
*copyc ost$status
*DECK DECK=CLT$VALUE_QUALIFIERS EXPAND=FALSE

  TYPE
    clt$value_qualifiers = array [1 .. * ] of clt$value_qualifier;

*copyc clt$value_qualifier
*DECK DECK=CLT$VALUE_QUALIFIER_KIND EXPAND=FALSE

  TYPE
    clt$value_qualifier_kind = (clc$array_subscript_qualifier,
          clc$field_qualifier, clc$list_subscript_qualifier,
          clc$substring_qualifier, clc$unspecified_field_qualifier,
          clc$unspecified_subscript_qual, clc$unspecified_substring_qual,
          clc$range_qualifier, clc$invalid_field_qualifier,
          clc$invalid_subscript_qual, clc$invalid_substring_qual);
*DECK DECK=CLT$VALUE_QUALIFIER_RECORDS EXPAND=FALSE

  TYPE
    clt$value_qualifier_records = (clc$command_reference_record,
          clc$date_time_record, clc$entry_point_ref_record, clc$record_record,
          clc$scu_line_ident_record, clc$status_record,
          clc$time_increment_record, clc$time_zone_record, clc$unknown_record);
*DECK DECK=CLT$VARIABLES EXPAND=FALSE

  TYPE
    clt$variables = record
      hash_groups: array [clt$variable_name_hash] of clt$variable_hash_group,
      thread: ^clt$variable_access,
    recend;

*copyc clt$variable_access
*copyc clt$variable_hash_group
*copyc clt$variable_name_hash
*DECK DECK=CLT$VARIABLE_ACCESS EXPAND=FALSE

  TYPE
    clt$variable_access = record
      left_search_tree: ^clt$variable_access,
      right_search_tree: ^clt$variable_access,
      forward_thread: ^clt$variable_access,
      backward_thread: ^clt$variable_access,
      hashed_name: clt$variable_name,
      info: clt$variable_access_info,
    recend;

*copyc clt$variable_access_info
*copyc clt$variable_name
*DECK DECK=CLT$VARIABLE_ACCESS_HANDLE EXPAND=FALSE

  TYPE
    clt$variable_access_handle = record
      access_info_offset: ost$segment_offset,
      descriptor_offset: ost$segment_offset,
      assignment_counter: integer,
    recend;

*copyc osd$virtual_address
*DECK DECK=CLT$VARIABLE_ACCESS_INFO EXPAND=FALSE

  TYPE
    clt$variable_access_info = record
      access_mode: clt$data_access_mode,
      class: clt$internal_variable_class,
      parameter_passed: boolean,
      assignment_counter: integer,
      descriptor: ^clt$variable_descriptor,
      original_parameter_descriptor: ^clt$variable_descriptor,
      qualifiers: ^clt$value_qualifiers,
    recend;

*copyc clt$data_access_mode
*copyc clt$internal_variable_class
*copyc clt$value_qualifiers
*copyc clt$variable_descriptor
*DECK DECK=CLT$VARIABLE_CLASS EXPAND=FALSE

  TYPE
    clt$variable_class = (clc$library_variable, clc$environment_variable,
          clc$procedure_variable, clc$parameter_variable);

*DECK DECK=CLT$VARIABLE_DECLARATION_SCOPE EXPAND=FALSE

  TYPE
    clt$variable_declaration_scope = (clc$local_scope, clc$xdcl_scope,
          clc$xref_scope, clc$push_scope, clc$environment_scope,
          clc$utility_scope, clc$task_scope, clc$job_scope, clc$library_scope);

*DECK DECK=CLT$VARIABLE_DESCRIPTOR EXPAND=FALSE

  TYPE
    clt$variable_descriptor = record
      header: clt$variable_descriptor_header,
      type_specification: clt$type_specification,
    recend;

*copyc clt$type_specification
*copyc clt$variable_descriptor_header
*DECK DECK=CLT$VARIABLE_DESCRIPTOR_HEADER EXPAND=FALSE

  TYPE
    clt$variable_descriptor_header = record
      access_count: integer,
      evaluation_method: clt$expression_eval_method,
      value: ^clt$internal_data_value,
      library: ^clt$variable_library_descriptor,
    recend;

*copyc clt$expression_eval_method
*copyc clt$internal_data_value
*copyc clt$variable_library_descriptor
*DECK DECK=CLT$VARIABLE_HASH_GROUP EXPAND=FALSE

  TYPE
    clt$variable_hash_group = record
      environment_variables_in_group: 0 .. 7fffffff(16),
      procedure_variables_in_group: 0 .. 7fffffff(16),
      root: ^clt$variable_access,
    recend;

*copyc clt$variable_access
*DECK DECK=CLT$VARIABLE_INFORMATION EXPAND=FALSE

  TYPE
    clt$variable_information = record
      access_info_found: boolean,
      access_mode: clt$data_access_mode,
      class: clt$internal_variable_class,
      parameter_passed: boolean,
      evaluation_method: clt$expression_eval_method,
      has_no_internal_value: boolean,
      internal_value: ^clt$internal_data_value,
      type_specification: ^clt$type_specification,
      type_description: ^clt$type_description,
      value_qualifiers_present: boolean,
      value_qualifiers: ^clt$value_qualifiers,
    recend;

*copyc clt$data_access_mode
*copyc clt$expression_eval_method
*copyc clt$internal_data_value
*copyc clt$internal_variable_class
*copyc clt$type_description
*copyc clt$type_specification
*copyc clt$value_qualifiers
*DECK DECK=CLT$VARIABLE_KINDS EXPAND=FALSE

  TYPE
    clt$variable_kinds = clc$string_value .. clc$status_value;

*copyc clt$value_kinds
*DECK DECK=CLT$VARIABLE_LIBRARY_DESCRIPTOR EXPAND=FALSE

  TYPE
    clt$variable_library_descriptor = record
      name: fst$path,
      first_variable_access: ^clt$variable_access,
    recend;

*copyc clt$variable_access
*copyc fst$path
*DECK DECK=CLT$VARIABLE_NAME EXPAND=FALSE

  TYPE
    clt$variable_name = ost$name;

*copyc ost$name
*DECK DECK=CLT$VARIABLE_NAME_HASH EXPAND=FALSE

  TYPE
    clt$variable_name_hash = 0 .. clc$max_variable_hash_groups - 1;

*copyc clc$max_variable_hash_groups
*DECK DECK=CLT$VARIABLE_NAME_REFERENCE EXPAND=FALSE

  TYPE
    clt$variable_name_reference = string ( * <= osc$max_name_size);

*copyc ost$name
*DECK DECK=CLT$VARIABLE_REF_EXPRESSION EXPAND=FALSE

  TYPE
    clt$variable_ref_expression = string ( * <= clc$max_expression_text_size);

*copyc clc$max_expression_text_size
*DECK DECK=CLT$VARIABLE_VALUE_DESCRIPTION EXPAND=FALSE

  TYPE
    clt$variable_value_description = record
      case kind: (clc$variable_data_value, clc$variable_value) of
      = clc$variable_data_value =
        data_value: ^clt$data_value,
      = clc$variable_value =
        value: clt$variable_value,
      casend,
    recend;

*copyc cld$variable_reference
*copyc clt$data_value
*DECK DECK=CLT$WC_FILE_EXPANSION_OPTION EXPAND=FALSE

  TYPE
    clt$wc_file_expansion_option = (clc$wcfe_only_files,
          clc$wcfe_only_catalogs, clc$wcfe_files_and_catalogs);

*DECK DECK=CLT$WHEN_CONDITION EXPAND=FALSE

  TYPE
    clt$when_condition = ost$name;

?? FMT (FORMAT := OFF) ??

  CONST
    clc$wc_any_condition            = 'ANY_CONDITION                  ',
    clc$wc_any_fault                = 'ANY_FAULT                      ',
    clc$wc_command_fault            = 'COMMAND_FAULT                  ',
    clc$wc_disconnect               = 'DISCONNECT                     ',
    clc$wc_execution_fault          = 'EXECUTION_FAULT                ',
    clc$wc_exit                     = 'EXIT                           ',
    clc$wc_limit_fault              = 'LIMIT_FAULT                    ',
    clc$wc_pause                    = 'PAUSE                          ',
    clc$wc_reconnect                = 'RECONNECT                      ',
    clc$wc_terminate                = 'TERMINATE                      ',
    clc$wc_unseen_mail              = 'UNSEEN_MAIL                    ';

?? FMT (FORMAT := ON) ??

*copyc ost$name
*DECK DECK=CLT$WHEN_CONDITIONS EXPAND=FALSE

  TYPE
    clt$when_conditions = array [1 .. * ] of clt$when_condition;

*copyc clt$when_condition
*DECK DECK=CLT$WHEN_CONDITION_DEFINITION EXPAND=FALSE

  TYPE
    clt$when_condition_definition = record
      name: clt$when_condition,
      status: ost$status,
      limit_name: ost$name,
    recend;

*copyc clt$when_condition
*copyc ost$name
*copyc ost$status
*DECK DECK=CLT$WHEN_CONDITION_DESCRIPTOR EXPAND=FALSE

  TYPE
    clt$when_condition_descriptor = record
      name: clt$when_condition,
      status: ost$status,
      limit_name: ost$name,
      exit_on_continue_condition: boolean,
      default_handler: ^procedure (VAR status: ost$status),
      condition_processed_state: clt$condition_processed_state,
      command_name: clt$command_name,
      command: clt$command_line,
    recend;

*copyc clt$command_line
*copyc clt$command_name
*copyc clt$condition_processed_state
*copyc clt$when_condition
*copyc ost$name
*copyc ost$status
*DECK DECK=CLT$WHICH_PARAMETER EXPAND=FALSE

  TYPE
    clt$which_parameter = record
      case specific: boolean of
      = TRUE =
        number: clt$parameter_number,
      = FALSE =
        ,
      casend,
    recend;

*copyc clt$parameter_number
*DECK DECK=CLT$WILD_CARD_PATTERN_TYPE EXPAND=FALSE

  TYPE
    clt$wild_card_pattern_type = (clc$wc_basic_pattern,
          clc$wc_extended_pattern);

*DECK DECK=CLT$WORKING_CATALOG EXPAND=FALSE

  TYPE
    clt$working_catalog = record
*IF NOT $true(osv$unix)
      handle: amt$local_file_name,
*ELSE
      path: fst$path,
*IFEND
      evaluated_file_reference: fst$evaluated_file_reference,
    recend;

*IF NOT $true(osv$unix)
*copyc amt$local_file_name
*ELSE
*copyc fst$path
*IFEND
*copyc fst$evaluated_file_reference
*DECK DECK=CLT$WORK_AREA EXPAND=FALSE

  TYPE
    clt$work_area = SEQ ( * );

*DECK DECK=CLT$WORK_AREAS EXPAND=FALSE

  TYPE
*IF NOT $true(osv$unix)
    clt$work_areas = array [osc$tsrv_ring .. osc$user_ring_2] of record
*ELSE
    clt$work_areas =
    record
*IFEND
      case 1 .. 2 of
      = 1 =
        pointer: ^^clt$work_area,
      = 2 =
        breakdown: ^cyt$sequence_pointer,
      casend,
    recend;

*copyc clt$work_area
*copyc cyd$cybil_structure_definitions
*copyc osd$virtual_address
*DECK DECK=CLV$APPLICATIONS_ACTIVE EXPAND=FALSE

  VAR
    clv$applications_active: [XREF, READ] ost$non_negative_integers;

?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
?? POP ??
*DECK DECK=CLV$CHARACTER_CLASS EXPAND=FALSE

  VAR
    clv$character_class: [XREF, READ] array [char] of clt$character_class;

?? PUSH (LISTEXT := ON) ??
*copyc clt$character_class
?? POP ??
*DECK DECK=CLV$COMMAND_LIST EXPAND=FALSE
*DECK DECK=CLV$COMMAND_LOGGING_ACTIVATED EXPAND=FALSE

  VAR
    clv$command_logging_activated: [XREF] boolean;
*DECK DECK=CLV$COMMAND_STATISTICS_ENABLED EXPAND=FALSE

  VAR
    clv$command_statistics_enabled: [XREF] boolean;

*DECK DECK=CLV$COMMENT_DELIMITER EXPAND=FALSE

  VAR
    clv$comment_delimiter: [XREF, READ] packed array [char] of boolean;

*DECK DECK=CLV$CONNECTED_FILES EXPAND=FALSE
*DECK DECK=CLV$CRITICAL_LOG_PATH_HANDLE EXPAND=FALSE

  VAR
    clv$critical_log_path_handle: [XREF, oss$task_shared] fst$path_handle_name;

?? PUSH (LISTEXT := ON) ??
*copyc fst$path_handle_name
*copyc oss$task_shared
?? POP ??
*DECK DECK=CLV$CURRENT_TASK_BLOCK EXPAND=FALSE

  VAR
    clv$current_task_block: [XREF] ^clt$block;

?? PUSH (LISTEXT := ON) ??
*copyc clt$block
?? POP ??
*DECK DECK=CLV$DAY_AND_MONTH_NAMES_LIST EXPAND=FALSE

  VAR
    clv$day_and_month_names_list: [XREF, oss$task_shared] ^clt$day_and_month_names;

?? PUSH (LISTEXT := ON) ??
*copyc clt$day_and_month_names
*copyc oss$task_shared
?? POP ??
*DECK DECK=CLV$DEFAULT_SESSION_FILE EXPAND=FALSE

  VAR
    clv$default_session_file: [XREF] ^fst$file_reference;

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
?? POP ??
*DECK DECK=CLV$DISPLAY_VARIABLES EXPAND=FALSE

  VAR
    clv$command_name: string (osc$max_name_size),
    clv$date: ost$date,
    clv$narrow_title1: string (clc$narrow_page_width),
    clv$narrow_title2: string (clc$narrow_page_width),
    clv$os_version: pmt$os_name,
    clv$page_width: amt$page_width,
    clv$path_display_chunk_count: 0 .. fsc$max_path_elements,
    clv$path_display_chunks: clt$path_display_chunks,
    clv$path_display_string: fst$path,
    clv$subtitles_built: boolean,
    clv$time: ost$time,
    clv$titles_built: boolean,
    clv$wide: boolean,
    clv$wide_title: string (clc$wide_page_width);

?? PUSH (LISTEXT := ON)??
*copyc amt$page_width
*copyc clc$page_widths
*copyc cld$path_description
*copyc clt$path_display_chunks
*copyc clt$path_name
*copyc fsc$max_path_elements
*copyc fst$path
*copyc ost$date
*copyc ost$time
*copyc pmt$os_name
?? POP ??
*DECK DECK=CLV$ENGLISH_DAY_AND_MONTH_NAMES EXPAND=FALSE

VAR
  clv$english_day_and_month_names: [XREF, READ, oss$job_paged_literal] clt$day_and_month_names;

?? PUSH (LISTEXT := ON) ??
*copyc clt$day_and_month_names
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=CLV$ENVIRONMENT_OBJECT_LOCATION EXPAND=FALSE

  VAR
    clv$environment_object_location: [XREF] clt$environment_object_location;

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_location
?? POP ??
*DECK DECK=CLV$FORMATTING_IN_EFFECT EXPAND=FALSE

VAR
  clv$formatting_in_effect: [XREF] boolean;
*DECK DECK=CLV$F_CURRENT_TASK_BLOCK EXPAND=FALSE

  VAR
    clv$f_current_task_block: [XREF] ^clt$f_block;

?? PUSH (LISTEXT := ON) ??
*copyc clt$f_block
?? POP ??
*DECK DECK=CLV$IJL_ORDINAL EXPAND=FALSE

  VAR
    clv$ijl_ordinal: [XREF] jmt$ijl_ordinal;

?? PUSH (LISTEXT := OFF) ??
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=CLV$INITIAL_APPLICATION EXPAND=FALSE

  VAR
    clv$initial_application: [XREF] clt$initial_application;

?? PUSH (LISTEXT := ON) ??
*copyc clt$initial_application
?? POP ??
*DECK DECK=CLV$INTERNATIONAL_NAME_CHAR EXPAND=FALSE

  VAR
    clv$international_name_char: [XREF, READ] packed array [char] of boolean;

*DECK DECK=CLV$INTRINSIC_COMMANDS EXPAND=FALSE

  VAR
    clv$intrinsic_commands: [XREF, READ] ^clt$command_table;

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_table
?? POP ??
*DECK DECK=CLV$ISOLATE_APPLICATION_VALUE EXPAND=FALSE

  VAR
    clv$isolate_application_value: [XREF] packed array [char] of boolean;

*DECK DECK=CLV$ISOLATE_BALANCED_TEXT EXPAND=FALSE

  VAR
    clv$isolate_balanced_text: [XREF, READ] packed array [char] of boolean;

*DECK DECK=CLV$LETTER_CHAR EXPAND=FALSE

  VAR
    clv$letter_char: [XREF, READ] packed array [char] of boolean;

*DECK DECK=CLV$LOCAL_CATALOG_HANDLE_NAME EXPAND=FALSE

  VAR
    clv$local_catalog_handle_name: [XREF] fst$path_handle_name;

?? PUSH (LISTEXT := ON) ??
*copyc fst$path_handle_name
?? POP ??
*DECK DECK=CLV$LOCAL_QUEUE_FILE_TABLE EXPAND=FALSE

  VAR
    clv$local_queue_file_table: [XREF] clt$local_queue_file_table;

?? PUSH (LISTEXT := ON) ??
*copyc clt$local_queue_file_table
?? POP ??
*DECK DECK=CLV$LOG_NAME_PATH_HANDLES EXPAND=FALSE

  VAR
    clv$log_name_path_handles: [XREF, oss$task_shared] array [pmt$logs] of
          fst$path_handle_name;

?? PUSH (LISTEXT := ON) ??
*copyc fst$path_handle_name
*copyc oss$task_shared
*copyc pmd$system_log_interface
?? POP ??
*DECK DECK=CLV$LOG_SECURE_PARAMETERS EXPAND=FALSE

  VAR
    clv$log_secure_parameters: [XREF] boolean;

*DECK DECK=CLV$MAX_INTEGER_AS_REAL EXPAND=FALSE

  VAR
    clv$max_integer_as_real: [XREF] ^longreal;

*DECK DECK=CLV$MAX_REAL EXPAND=FALSE

  VAR
    clv$max_real: [XREF] ^longreal;

*DECK DECK=CLV$MAX_VARIABLE_ALLOCATION EXPAND=FALSE

  VAR
    clv$max_variable_allocation: [XREF] ost$segment_length;

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
?? POP ??
*DECK DECK=CLV$MESSAGE_CACHE EXPAND=FALSE

  VAR
    clv$message_cache: [XREF] clt$message_cache;

?? PUSH (LISTEXT := ON) ??
*copyc clt$message_cache
?? POP ??
*DECK DECK=CLV$MIN_INTEGER_AS_REAL EXPAND=FALSE

  VAR
    clv$min_integer_as_real: [XREF] ^longreal;

*DECK DECK=CLV$MIN_REAL EXPAND=FALSE

  VAR
    clv$min_real: [XREF] ^longreal;

*DECK DECK=CLV$NAMED_TASK_GROUP_LIST EXPAND=FALSE

  VAR
    clv$named_task_group_list: [XREF] ^^clt$named_task;

?? PUSH (LISTEXT := ON) ??
*copyc clt$named_task
?? POP ??
*DECK DECK=CLV$NAMED_TASK_LIST EXPAND=FALSE

  VAR
    clv$named_task_list: [XREF] ^clt$named_task;

?? PUSH (LISTEXT := ON) ??
*copyc clt$named_task
?? POP ??
*DECK DECK=CLV$NEGATIVE_INFINITY EXPAND=FALSE

  VAR
    clv$negative_infinity: [XREF] ^longreal;

*DECK DECK=CLV$NIL_BLOCK_HANDLE EXPAND=FALSE

  VAR
    clv$nil_block_handle: [XREF, READ] clt$block_handle;

?? PUSH (LISTEXT := ON) ??
*copyc clt$block_handle
?? POP ??
*DECK DECK=CLV$NIL_DISPLAY_CONTROL EXPAND=FALSE

  VAR
    clv$nil_display_control: [XREF] clt$display_control;

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
?? POP ??
*DECK DECK=CLV$NON_ALPHANUMERIC EXPAND=FALSE

  VAR
    clv$non_alphanumeric: [XREF, READ] packed array [char] of boolean;

*DECK DECK=CLV$NON_COBOL_NAME_CHAR EXPAND=FALSE

  VAR
    clv$non_cobol_name_char: [XREF, READ] packed array [char] of boolean;

*DECK DECK=CLV$NON_DECIMAL_DIGIT EXPAND=FALSE

  VAR
    clv$non_decimal_digit: [XREF, READ] packed array [char] of boolean;

*DECK DECK=CLV$NON_GRAPHIC EXPAND=FALSE

  VAR
    clv$non_graphic: [XREF] packed array [char] of boolean;

*DECK DECK=CLV$NON_HEX_DIGIT EXPAND=FALSE

  VAR
    clv$non_hex_digit: [XREF, READ] packed array [char] of boolean;

*DECK DECK=CLV$NON_LETTER_OR_DIGIT EXPAND=FALSE

  VAR
    clv$non_letter_or_digit: [XREF, READ] packed array [char] of boolean;

*DECK DECK=CLV$NON_SPACE EXPAND=FALSE

  VAR
    clv$non_space: [XREF, READ] packed array [char] of boolean;

*DECK DECK=CLV$NON_SUBSTITUTION_MARK EXPAND=FALSE

  VAR
    clv$non_substitution_mark: [XREF, READ, oss$job_paged_literal]
          packed array [char] of boolean;

?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=CLV$NON_ZERO_DIGIT EXPAND=FALSE

  VAR
    clv$non_zero_digit: [XREF] packed array [char] of boolean;

*DECK DECK=CLV$OPEN_POSITIONS EXPAND=FALSE

  VAR
    clv$open_positions: [XREF] array [amt$open_position] of string (5);

*copyc amt$open_position
*DECK DECK=CLV$OPEN_POSITION_DESIGNATOR EXPAND=FALSE

  VAR
    clv$open_position_designator: [XREF, READ] array [amt$open_position] of
          record
      size: 4 .. 5,
      value: string (5),
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$open_position
?? POP ??
*DECK DECK=CLV$OPERATOR_COMMANDS EXPAND=FALSE

  VAR
    clv$operator_commands: [XREF, READ] ^clt$command_table;

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_table
?? POP ??
*DECK DECK=CLV$POSITIVE_INFINITY EXPAND=FALSE

  VAR
    clv$positive_infinity: [XREF] ^longreal;

*DECK DECK=CLV$PROCESSING_PHASE EXPAND=FALSE

  VAR
    clv$processing_phase: [XREF] clt$processing_phase;

?? PUSH (LISTEXT := ON) ??
*copyc clt$processing_phase
?? POP ??
*DECK DECK=CLV$REAL_ONE EXPAND=FALSE

  VAR
    clv$real_one: [XREF] ^longreal;

*DECK DECK=CLV$REAL_ZERO EXPAND=FALSE

  VAR
    clv$real_zero: [XREF] ^longreal;

*DECK DECK=CLV$SCL_OPTIONS EXPAND=FALSE
*DECK DECK=CLV$SECURE_LOGGING_ACTIVATED EXPAND=FALSE

  VAR
    clv$secure_logging_activated: [XREF] boolean;

*DECK DECK=CLV$SPECIAL_NAME_CHAR EXPAND=FALSE

  VAR
    clv$special_name_char: [XREF, READ] packed array [char] of boolean;

*DECK DECK=CLV$STANDARD_FILES EXPAND=FALSE

  VAR
    clv$standard_files: [XREF] array [clt$standard_files] of clt$standard_file;

?? PUSH (LISTEXT := ON) ??
*copyc clt$standard_file
*copyc clt$standard_files
?? POP ??
*DECK DECK=CLV$STRING_DELIMITER EXPAND=FALSE

  VAR
    clv$string_delimiter: [XREF, READ] packed array [char] of boolean;

*DECK DECK=CLV$SYSTEM_ACCOUNTING_ACTIVATED EXPAND=FALSE

  VAR
    clv$system_accounting_activated: [XREF] boolean;

*DECK DECK=CLV$SYSTEM_COMMANDS EXPAND=FALSE

  VAR
    clv$system_commands: [XREF, READ] ^clt$command_table;

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_table
?? POP ??
*DECK DECK=CLV$SYSTEM_FILE_IDENTIFIERS EXPAND=FALSE

  VAR
    clv$system_file_identifiers: [XREF] clt$system_file_identifiers;

?? PUSH (LISTEXT := ON) ??
*copyc clt$system_file_identifiers
?? POP ??
*DECK DECK=CLV$SYSTEM_FUNCTIONS EXPAND=FALSE

  VAR
    clv$system_functions: [XREF, READ] ^clt$function_processor_table;

?? PUSH (LISTEXT := ON) ??
*copyc clt$function_processor_table
?? POP ??
*DECK DECK=CLV$SYSTEM_FUNCTIONS_V0 EXPAND=FALSE

  VAR
    clv$system_functions_v0: [XREF, READ] ^clt$function_table;

?? PUSH (LISTEXT := ON) ??
*copyc clt$function_table
?? POP ??
*DECK DECK=CLV$SYSTEM_LOGGING_ACTIVATED EXPAND=FALSE

  VAR
    clv$system_logging_activated: [XREF] boolean;

*DECK DECK=CLV$SYSTEM_MESSAGES_MODULE EXPAND=FALSE

  VAR
    clv$system_messages_module: [XREF] ^ost$help_module;

?? PUSH (LISTEXT := ON) ??
*copyc ost$help_module
?? POP ??
*DECK DECK=CLV$TASK_COMMAND_LIBRARY_LIST EXPAND=FALSE

  VAR
    clv$task_command_library_list: [XREF] ^clt$command_library_list_entry;

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_list
?? POP ??
*DECK DECK=CLV$TASK_LIST EXPAND=FALSE

  VAR
    clv$task_list: [XREF] clt$task_list;

?? PUSH (LISTEXT := ON) ??
*copyc clt$task_list
?? POP ??
*DECK DECK=CLV$TASK_NAME EXPAND=FALSE

  VAR
    clv$task_name: [XREF] ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=CLV$TYPE_KIND_NAMES EXPAND=FALSE

  VAR
*IF NOT $true(osv$unix)
    clv$type_kind_names: [XREF] array [clt$type_kind] of clt$type_name;
*ELSE
    clv$type_kind_names: [XREF] array [clc$application_type ..
          clc$unix_file_type] of clt$type_name;
*IFEND

?? PUSH (LISTEXT := ON) ??
*copyc clt$type_kind
*copyc clt$type_name
?? POP ??
*DECK DECK=CLV$UNIQUE_NAME EXPAND=FALSE

  VAR
    clv$unique_name: [XREF] ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=CLV$UNSEEN_MAIL_ACTION EXPAND=FALSE
*DECK DECK=CLV$USER_IDENTIFICATION EXPAND=FALSE

  VAR
    clv$user_identification: [XREF] clt$user_identification;

?? PUSH (LISTEXT := ON) ??
*copyc clt$user_identification
?? POP ??
*DECK DECK=CLV$VALUE_DESCRIPTORS EXPAND=FALSE

  VAR
    clv$value_descriptors: [XREF, READ] array
          [clc$variable_reference .. clc$status_value] of string (8);

?? PUSH (LISTEXT := ON) ??
*copyc clt$value_kinds
?? POP ??
*DECK DECK=CLV$VALUE_TYPE_KINDS EXPAND=FALSE

  VAR
    clv$value_type_kinds: [XREF] array [clt$data_kind] of clt$type_kind;

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_kind
*copyc clt$type_kind
?? POP ??
*DECK DECK=CLV$VAR_ACCESS_ASSIGNMENT_COUNT EXPAND=FALSE

  VAR
    clv$var_access_assignment_count: [XREF] integer;
*DECK DECK=CLV$WORKING_CATALOG EXPAND=FALSE
*DECK DECK=CLV$WORK_AREAS EXPAND=FALSE

  VAR
    clv$work_areas: [XREF] clt$work_areas;

?? PUSH (LISTEXT := ON) ??
*copyc clt$work_areas
?? POP ??
*DECK DECK=CMC$ACTION_MESSAGES EXPAND=FALSE
CONST
  cmc$action_messages   = 'CMM$ACTION_MESSAGES            ';
*DECK DECK=CMC$CONDITION_LIMITS EXPAND=FALSE

{ COMMON DECK CMDERRC }

  CONST
    cmc$min_ecc = (($INTEGER ('C') * 100(16)) + $INTEGER ('M')) * 1000000(16),
    cmc$max_ecc = cmc$min_ecc + 9999;

  CONST
    cmc$configuration_management_id = 'CM';
*DECK DECK=CMC$DEFAULT_CHANNEL_NAME EXPAND=FALSE

{ COMMON DECK CMDSETN }

  CONST
    cmc$default_channel_name = '$CHANNEL',
    cmc$default_controller_name = '$CONTROLLER',
    cmc$default_device_name = '$STORAGE_DEVICE';
*DECK DECK=CMC$DEFAULT_VSN EXPAND=FALSE

{ COMMON DECK CMDDVSN }

  CONST
    cmc$default_vsn = 'UNINIT';
*DECK DECK=CMC$DISPLAY_ELEMENT_CONSTANTS EXPAND=FALSE

{  This common deck defines some constant expressions used in the
{  LCU subcommand DISPLAY_MAINFRAME_CONFIGURATION (DISPLAY_ELEMENT).

  CONST
    cmc$msg_channel_element = 'CHANNEL ELEMENT: ',
    cmc$msg_mainframe = 'MAINFRAME: ',
    cmc$msg_iou_con = 'IOU: ',
    cmc$msg_channel_type = 'CHANNEL TYPE: ',
    cmc$msg_controller_con = 'CONTROLLER CONNECTIONS: ',
    cmc$msg_external_proc_con = 'EXTERNAL PROCESSOR CONNECTIONS: ',
    cmc$msg_channel_adapter_con = 'CHANNEL ADAPTER CONNECTIONS: ',
    cmc$msg_communications_con = 'COMMUNICATIONS ELEMENT CONNECTIONS: ',
    cmc$msg_controller_element = 'CONTROLLER ELEMENT: ',
    cmc$msg_channel_adapter_element = 'CHANNEL ADAPTER ELEMENT: ',
    cmc$msg_communications_element = 'COMMUNICATION ELEMENT: ',
    cmc$msg_ext_proc_element = 'EXTERNAL PROCESSOR ELEMENT: ',
    cmc$msg_msclass = 'MASS STORAGE CLASS: ',
    cmc$msg_product_id = 'PRODUCT IDENTIFICATION: ',
    cmc$msg_peripheral_driver_name = 'IOU PROGRAM NAME: ',
    cmc$msg_channel_connections = 'CHANNEL CONNECTIONS: ',
    cmc$msg_storage_device_con = 'STORAGE DEVICE CONNECTIONS: ',
    cmc$msg_storage_device_element = 'STORAGE DEVICE ELEMENT: ',
    cmc$msg_serial_number = 'SERIAL NUMBER: ',
    cmc$msg_equipment_number = 'EQUIPMENT NUMBER: ',
    cmc$msg_unit_number = 'UNIT NUMBER: ',
    cmc$msg_state_info = 'STATE: ',
    cmc$msg_host_network = 'HOST NETWORK: ',
    cmc$msg_network = 'NETWORK: ',
    cmc$msg_type = 'TYPE: ',
    cmc$msg_channel_network = 'CHANNEL NETWORK',
    cmc$msg_ethernet = 'ETHERNET',
    cmc$msg_connected_system = 'CONNECTED SYSTEM: ',
    cmc$msg_access = 'ACCESS: ',
    cmc$msg_relays_restricted = 'RELAYS RESTRICTED: ',
    cmc$msg_system_identifier = 'SYSTEM IDENTIFIER: ',
    cmc$msg_active_paths = 'ACTIVE PATHS: ',
    cmc$msg_inactive_paths = 'INACTIVE PATHS: ',
    cmc$msg_disabled_paths = 'DISABLED PATHS: ',
    cmc$msg_physical_paths = 'PHYSICAL PATHS: ',
    cmc$msg_connection_status = 'CONNECTION STATUS: ',
    cmc$msg_downline_element = 'DOWNLINE ELEMENT: ',
    cmc$msg_upline_element = 'UPLINE ELEMENT: ',
    cmc$msg_connect_status_header = 'STATUS: ',
    cmc$msg_tcpip_host_name = 'TCP/IP HOST NAME: ',
    cmc$msg_forward_search_range = 'FORWARD SEARCH RANGE: ',
    cmc$msg_application_info = 'APPLICATION INFORMATION: ',
    cmc$msg_site_info = 'SITE INFORMATION: ',
    cmc$msg_parity_status = 'PARITY PROTECTION:',

    cmc$upline_connection_column = 7,
    cmc$connection_status_column = 39,
    cmc$downline_connection_column = 48,
    cmc$spacing = 2,
    cmc$starting_element_column = 1,
    cmc$starting_subheader_column = 5,
    cmc$starting_name_column = 10,
    cmc$status_column = 62;

*DECK DECK=CMC$LOGICAL_CONF_DEV_FILE_NAME EXPAND=FALSE
*DECK DECK=CMC$LOGICAL_UNIT_CONSTANTS EXPAND=FALSE

{ COMMON DECK CMDRESC }

{    These constants determine how many entries in the logical }
{ unit table are to be reserved for system use, and which }
{ logical unit number is the lowest that can be used by the }
{ job template system. }

  CONST
    cmc$image_file_lun = 1,
    cmc$reserved_unit_count = cmc$image_file_lun,
    cmc$reserved_network_unit_count = 20,

    cmc$job_template_unit_ordinal = cmc$reserved_unit_count + 1;
*DECK DECK=CMC$LOGOICAL_UNIT_CONSTANTS EXPAND=FALSE

{ COMMON DECK CMDRESC }

{    These constants determine how many entries in the logical }
{ unit table are to be reserved for system use, and which }
{ logical unit number is the lowest that can be used by the }
{ job template system. }

  CONST
    cmc$image_file_lun = 1,
    cmc$reserved_unit_count = cmc$image_file_lun,

    cmc$job_template_unit_ordinal = cmc$reserved_unit_count + 1;
*DECK DECK=CMC$MAXIMUM_ESM_SIZE EXPAND=FALSE

{ DECK: CMC$MAXIMUM_ESM_SIZE

  CONST
      cmc$max_esm_size = 16777215;
*DECK DECK=CMC$MAX_COMMUNICATIONS_PORT EXPAND=FALSE
  CONST
    cmc$max_communications_port = 15;

*DECK DECK=CMC$MAX_PP_PER_IOU EXPAND=FALSE

  CONST
    cmc$max_pp_per_iou = 30;
*DECK DECK=CMC$MINIMUM_PAGE_SIZE EXPAND=FALSE

{ COMMON DECK CMDMPS }

{  This deck defines a constant that is used to determine the minimum }
{ page width for the display_element displays. }

  CONST
    cmc$minimum_page_size = 60;
*DECK DECK=CMC$PCU_PARAMETER_INDICES EXPAND=FALSE

 { This constant declaration part must be updated when adding or deleting
 { parameters from the following PCU subcommands:
 {   DEFINE_ELEMENT, ADD_ELEMENT_DEFINITION, REPLACE_ELEMENT_DEFINITION
 {   and CHANGE_ELEMENT_DEFINITION.

  CONST
    p$element = 1,
    p$same_as = 2,
    p$element_identification = 3,
    p$iou_program_name = 4,
    p$serial_number = 5,
    p$state = 6,
    p$central_memory_connection = 7,
    p$iou_connection = 8,
    p$peripheral_connection = 9,
    p$verify_element_identification = 10,
    p$application_information = 11,
    p$site_information = 12;
*DECK DECK=CMC$PHYSICAL_CONF_DEV_FILE_NAME EXPAND=FALSE


{ This deck contains the constant declaration for the device file names }
{ that will be used for the physical configuration. }

  CONST
    cmc$physical_configuration_file = 'CMF$PHYSICAL_CONFIGURATION_FILE';
*DECK DECK=CMD$DEFAULT_IOCT_ENTRY EXPAND=FALSE

   VAR
    cmv$default_ioct_entry: [STATIC, READ, oss$mainframe_paged_literal]
      cmt$io_completion_table_entry := [TRUE, [0, 0], [*,*],
      cmc$subsystem_io_not_active, [cmc$no_io,osc$null_name, [NIL, 'Z', FALSE, FALSE]],
      NIL, NIL, NIL, NIL, *,
      [osc$millisecond_time,'00000000'],jmc$blank_system_supplied_name];

?? PUSH (LISTEXT := ON) ??
*copyc iot$io_completion_table
*copyc oss$mainframe_paged_literal
*copyc ost$name
*copyc jmt$system_supplied_name
*copyc cmt$io_request_type
*copyc ost$global_task_id
*copyc ost$time
?? POP ??
*DECK DECK=CMD$IO_COMPLETION_TABLE EXPAND=FALSE

 VAR
    cmv$io_completion_table_p: [#GATE, XDCL, STATIC, oss$job_fixed]
      ^cmt$io_completion_table := NIL;

?? PUSH (LISTEXT := ON) ??
*copyc oss$job_fixed
*copyc iot$io_completion_table
?? POP ??
*DECK DECK=CMD$NULL_EQUIPMENT_NUMBER EXPAND=FALSE

  CONST
    cmc$null_equipment_number = 8,
    cmc$null_unit_number = 64;
*DECK DECK=CMDECC EXPAND=FALSE
?? NEWTITLE := 'CMDECC:  Configuration Management:  ''CM'' 0 .. 9999' ??
*copyc cmc$condition_limits
*copyc cme$active_driver_manager
*copyc cme$manage_170_resources
*copyc cme$access_device_files
*copyc cme$manage_interface_tables
*copyc cme$job_template_deadstart
*copyc cme$logical_configuration_mgr
*copyc cme$logical_configuration_utl
*copyc cme$physical_configuration_mgr
*copyc cme$physical_configuration_utl
*copyc cme$reserve_element
*copyc mse$request_maintenance_access
?? OLDTITLE ??
*DECK DECK=CME$ACCESS_DEVICE_FILES EXPAND=FALSE

?? FMT (FORMAT := OFF) ??

*copyc CMC$CONDITION_LIMITS

  CONST
    cmc$adf_err = cmc$min_ecc + 100,

    cme$adf_illegal_version = cmc$adf_err + 30,
        {E Device file version +P1 is not the current version of this system. }

    cme$adf_incomplete_device_file = cmc$adf_err + 40,
        {E Modifications to device file +P3 are in an incomplete state. }

    cme$adf_nil_element_pointer = cmc$adf_err + 50;
        {E A NIL sequence pointer was encountered with a +P1 in +P2. }

?? FMT (FORMAT := ON) ??
*DECK DECK=CME$ACTIVE_DRIVER_MANAGER EXPAND=FALSE
*DECK DECK=CME$JOB_TEMPLATE_DEADSTART EXPAND=FALSE

{ COMMON DECK CME$JOB_TEMPLATE_DEADSTART }

?? FMT (FORMAT := OFF) ??
*copyc CMC$CONDITION_LIMITS

  CONST
    cmc$jtd_err = cmc$min_ecc + 300,

    cme$jtd_element_size_mismatch = cmc$jtd_err + 10,
        {E Element size mismatch: +P3. }

    cme$jtd_eoi_not_returned = cmc$jtd_err + 20,
        {E Eoi not returned: +P3. }

    cme$jtd_nil_sequence_pointer = cmc$jtd_err + 30,
        {E Nil sequence pointer: +P3. }

    cme$jtd_sys_dev_lun_not_found = cmc$jtd_err + 40,
        {E System device logical unit number not found. }

    cme$jtd_ica2_requires_system_id = cmc$jtd_err + 42,
        {E The ICA-II SYSTEM IDENTIFIER must be specified.}

    cme$jtd_system_id_not_allowed = cmc$jtd_err + 43,
        {E A SYSTEM IDENTIFIER can only be specified when defining an ICA-II connection.}

    cme$jtd_invalid_element_type = cmc$jtd_err + 44,
        {E Element +P1 is of invalid type for use with command.}

    cme$jtd_nil_network_descriptor = cmc$jtd_err + 45,
        {E NIL network_descriptor_pointer in : +P1 }

    cme$jtd_invalid_state_change = cmc$jtd_err + 46,
         {E +P1.}

    cme$jtd_unsupported_unit_class = cmc$jtd_err + 47,
         {E Product id +P1 is not supported by NOS/VE. }

    cme$jtd_unable_to_access_lut = cmc$jtd_err + 48,
         {E Unable to set lock on logical unit table. }

    cme$jtd_unit_already_assigned = cmc$jtd_err + 49,
         {E +P1 is already assigned to +P2.}

    cme$jtd_unit_already_reserved = cmc$jtd_err + 50,
         {E +P1 is already reserved to +P2.}

    cme$jtd_cannot_access_element = cmc$jtd_err + 51,
         {E +P1.}

    cme$jtd_state_not_retained = cmc$jtd_err + 52;
         {W Unable to update state information, state change ..
         {  may not be retained across deadstart.

?? FMT (FORMAT := ON) ??
*DECK DECK=CME$LOGICAL_CONFIGURATION_MGR EXPAND=FALSE
*copyc cmc$condition_limits

?? FMT (FORMAT := OFF) ??

  CONST
    cmc$min_lcm_err = cmc$min_ecc + 400,

    cme$lcm_duplicate_element_names = cmc$min_lcm_err + 0,
        {E Element +P1 has already been defined.}

    cme$lcm_incompatible_lc = cmc$min_lcm_err + 5,
        {E Incompatible logical configuration file.}

    cme$lcm_empty_lc = cmc$min_lcm_err + 10,
        {E The active configuration is empty.}

    cme$lcm_elements_not_found = cmc$min_lcm_err + 15,
        {E No elements of the selector type specified found.}

    cme$lcm_nil_pointer_detected = cmc$min_lcm_err + 16,
       {E Nil pointer detected in : +P1.}

    cme$lcm_insufficient_space = cmc$min_lcm_err + 17,
       {E Insufficient space allocated for application_information ..
       { or site_information string.}

    cme$lcm_unexpected_element_type = cmc$min_lcm_err + 20,
        {E Element +P1 : Product +P2 cannot be configured.}

    cme$lcm_unsupported_channel = cmc$min_lcm_err + 25,
        {E Element +P1 is improper in the active configuration.}

    cme$lcm_ring_validation_error = cmc$min_lcm_err + 30,
        {E Permission not granted for : +P1.}

    cme$jobclass_cant_change_states = cmc$min_lcm_err + 31,
        {E User is executing in the wrong job class to change the element ..
        { state from +P1 to +P2.}

    cme$cannot_change_states = cmc$min_lcm_err + 32,
        {E User cannot change the element state from +P1 to +P2 because the ..
        { element is in its current state due to hardware problems.}

    cme$state_changed_in_interim = cmc$min_lcm_err + 33,
        {E The state of the element changed from +P1 to +P2 between the ..
        { initial validation of the element state and the actual request to ..
        { change the element state.}

    cme$change_produces_interrupt = cmc$min_lcm_err + 34,
        {E The element state change of +P1 to +P2 would produce a system ..
        { interrupt.}

    cme$lcm_empty_pa_set = cmc$min_lcm_err + 35,
        {E Empty physical address specifier set.}

    cme$lcm_unsupported_statechange = cmc$min_lcm_err + 36,
        {E The state change from +P1 to +P2 is not supported.}

    cme$lcm_model_cant_change_state = cmc$min_lcm_err + 37,
        {E The state change from +P1 to +P2 is not supported for this ..
        { processor model.}

    cme$cant_change_state_wo_deadst = cmc$min_lcm_err + 38,
        {E User cannot change the element state from +P1 to +P2 because ..
        { of the state of the element at deadstart.}

    cme$lcm_missing_pa_set_member = cmc$min_lcm_err + 40,
        {E +P1 missing in physical address specifier set.}

    cme$lcm_element_not_found = cmc$min_lcm_err + 45,
        {E Element +P1 is not in the active configuration.}

    cme$request_state_is_crnt_state = cmc$min_lcm_err + 46,
        {W The current element state is the same as the requested state.}

    cme$lcm_element_name_not_found = cmc$min_lcm_err + 50,
        {E An element name cannot be found for physical address: +P1.}

    cme$lcm_ambiguous_product_id = cmc$min_lcm_err + 51,
        {E Hardware address must be specified for multi-spindles devices.}

    cme$lcm_not_available = cmc$min_lcm_err + 55,
        {E +P1.}

    cme$lcm_system_critical_element = cmc$min_lcm_err + 56,
        {E +P1 is a system critical element.}

    cme$invalid_ms_configuration = cmc$min_lcm_err + 57,
        {E The number of mass storage devices exceeds the ..
        { allowed value for this mainframe model type.}

    cme$ms_device_not_allowed = cmc$min_lcm_err + 58,
        {E The physical configuration contains mass storage ..
        { devices not allowed on this mainframe model type.}

    cme$channel_port_required = cmc$min_lcm_err + 59,
        {E +P1 requires channel port on IOU_CONNECTIONS parameter.}

    cme$multiple_reconf_tasks = cmc$min_lcm_err + 60,
        {E +P1 is currently performing reconfiguration tasks. Please retry later on.}

    cme$invalid_upline_connection = cmc$min_lcm_err + 61,
    {E Element +P1 has an invalid upline connection to element +P2.}

    cme$invalid_downline_connection = cmc$min_lcm_err + 62,
    {E Element +P1 does not have a downline connection to element +P2.}

    cme$unsupported_connection = cmc$min_lcm_err + 63,
    {E Element +P1 does not support downline connections.}

    cme$lcu_still_active = cmc$min_lcm_err + 64,
    {E Terminate_system is not allowed while the Logical_Configuration_Utility ..
    {(LCU) is active.  ..
    {Job +P must quit LCU to allow the system to be terminated. }

    cmc$lcm_null = 0;



?? FMT (FORMAT := ON) ??
*DECK DECK=CME$LOGICAL_CONFIGURATION_UTL EXPAND=FALSE

{ COMMON DECK CME$LOGICAL_CONFIGURATION_UTL }

?? FMT (FORMAT := OFF) ??
*copyc CMC$CONDITION_LIMITS

  CONST
    cmc$min_lcu_err = cmc$min_ecc + 500,

    cme$lcu_dup_tcpip_host_defn = cmc$min_lcu_err + 1,
        {E Duplicate define_tcpip_host commands defined.}

    cme$lcu_invalid_domain_label_ch = cmc$min_lcu_err + 2,
        {E The character +P is an invalid TCP/IP domain label character.}

    cme$lcu_domain_label_too_long = cmc$min_lcu_err + 3,
        {E The TCP/IP domain label may not exceed 63 characters.}

    cme$lcu_first_domain_label_char = cmc$min_lcu_err + 4,
        {E The first character of a TCP/IP domain label may be 'a'..'z' or 'A'..'Z' but not +P.}

    cme$lcu_tcpip_host_name_length = cmc$min_lcu_err + 5,
        {E The TCP/IP host name may not exceed 255 characters.}

    cme$lcu_last_char_domain_label = cmc$min_lcu_err + 6,
        {E The last character of a TCP/IP domain label may be 'a'..'z' or 'A'..'Z' or '0'..'9' but not +P.}

    cme$lcu_last_host_name_char = cmc$min_lcu_err + 7,
        {E The last character of a TCP/IP host name may be 'a'..'z' or 'A'..'Z' or '0'..'9' but not +P.}

    cme$lcu_element_size_mismatch = cmc$min_lcu_err + 10,
        {E File inconsistency in the +P3 detected in procedure +P4. }

    cme$class_missing_on_set = cmc$min_lcu_err + 11,
        {E Set +P1 requires a volume with mass storage class +P2.}

    cme$class_missing_on_system = cmc$min_lcu_err + 12,
        {E The system requires a volume with mass storage class +P1.}

    cme$class_missing_on_sys_device = cmc$min_lcu_err + 13,
        {E The system device +P1 requires mass storage class.}

    cme$lcu_eoi_not_returned = cmc$min_lcu_err + 20,
        {E Information regarding the configuration is not available. }

    cme$lcu_illegal_output_file = cmc$min_lcu_err + 30,
        {E File +F1 must have page width of at least +P2 characters. }

    cme$lcu_illegal_state_field = cmc$min_lcu_err + 35,
        {E Parameter : +P1 is not a legal value for the state field of the  ..
        {CONFIGURATION_OPTION parameter. }

    cme$lcu_illegal_type_field = cmc$min_lcu_err + 36,
        {E Parameter : +P1 is not a legal value for the type field of the  ..
        {CONFIGURATION_OPTION parameter. }

    cme$lcu_improper_name_value = cmc$min_lcu_err + 40,
        {E Illegal value for parameter +P1. }


    cme$lcu_illegal_inimv = cmc$min_lcu_err + 41,
        {E Illegal initialization of system device +P1.}

    cme$lcu_duplicate_vsn = cmc$min_lcu_err + 42,
        {E +P1 is already used for the system device.}

    cme$lcu_illegal_addvts = cmc$min_lcu_err + 43,
        {E Illegal ADDVTS issued for system device element.}

    cme$lcu_invalid_unit_type = cmc$min_lcu_err + 44,
        {E Element, +P1, is not a valid element for this command.}

    cme$lcu_invalid_vsn = cmc$min_lcu_err + 50,
        {E VSN parameter: +P1 contains non alphanumeric characters. }

     cme$lcu_unaddressable_sector = cmc$min_lcu_err + 55,
         {E Unaddressable sector - +P1.}

    cme$lcu_nil_sequence_pointer = cmc$min_lcu_err + 60,
        {E Nil sequence pointer: +P3. }

    cme$lcu_asynchronous_attempt = cmc$min_lcu_err + 61,
        {E Asynchronous attempts not allowed for : +P1.}

    cme$lcu_invalid_element_status = cmc$min_lcu_err + 62,
        {E +P1 is NOT enabled.}

    cme$lcu_invalid_recorded_vsn = cmc$min_lcu_err + 63,
        {E Volume +P1 does not exist or not initialized.}

    cme$lcu_cannot_delete_class_a = cmc$min_lcu_err + 64,
        {E Cannot remove class A from any devices.}

    cme$lcu_invalid_sys_dev_class = cmc$min_lcu_err + 65,
        {E  Cannot remove class A or Q from the system device.}

    cme$lcu_class_has_no_members = cmc$min_lcu_err + 66,
        {F The system requires a volume with mass storage class(es) +P1.}

    cme$lcu_cannot_write_vol_label = cmc$min_lcu_err + 68,
        {E +P1+P2.}

    cme$lcu_dup_host_network_defn = cmc$min_lcu_err + 69,
        {E The DEFINE_HOST_NETWORK command can only be specified once.}

    cme$lcu_push_failed = cmc$min_lcu_err + 70,
        {E Push returned nil pointer. }

    cme$lcu_duplicate_system_id = cmc$min_lcu_err + 71,
        {E System id +P1 has already been assigned.}

    cme$lcu_no_netw_device_defn = cmc$min_lcu_err + 72,
        {E The network configuration must define a network device. }

    cme$lcu_duplicate_element = cmc$min_lcu_err + 73,
        {E The element +P1 has already been defined in the network configuration. }

    cme$lcu_sys_dev_path_not_found = cmc$min_lcu_err + 75,
        {W System/Deadstart device path of +P1, +P2, EQUIPMENT +P3, and UNIT +P4 is not ..
        { in the configuration file, +P5.}

    cme$lcu_too_many_conf_options = cmc$min_lcu_err + 76,
        {E Too many values for the CONFIGURATION_OPTIONS parameter. }

    cme$lcu_unit_density_mismatch = cmc$min_lcu_err + 77,
        {E Requested element +P1 does not support the requested density. }

    cme$lcu_illegal_tape_unit_name = cmc$min_lcu_err + 78,
        {E The requested element +P1 is not a tape unit. }

    cme$lcu_wrong_element_assigned = cmc$min_lcu_err + 79,
        {E The wrong tape element, +P1, was assigned.  The requested element name was +P2. }

    cme$lcu_no_host_network_defn = cmc$min_lcu_err + 80,
        {E Network configuration requires DEFINE_HOST_NETWORK command.}

    cme$lcu_save_flaw_warning = cmc$min_lcu_err + 82,
        {W +P1 will be flawed when available.}

    cme$lcu_illegal_parameter_value = cmc$min_lcu_err + 83,
        {E +P1 }

    cme$lcu_address_not_sw_flawed = cmc$min_lcu_err + 84,
        {W Address not software flawed - +P1.}

    cme$lcu_channel_number_too_big = cmc$min_lcu_err + 85,
        {E +P1 }

    cme$lcu_illegal_use_of_command = cmc$min_lcu_err + 87,
        {E User cannot use this command interactively. }

    cme$lcu_under_priv_nam_user = cmc$min_lcu_err + 88,
        {E User  has insufficient privilege to install the network configuration. }

    cme$lcu_vernc_error = cmc$min_lcu_err + 90,
        {E +P1 detects +P2 error(s).}

    cme$lcu_empty_input_on_vernc = cmc$min_lcu_err + 91,
        {E Input file +P1 is empty.}

    cme$lcu_device_not_active =  cmc$min_lcu_err + 93,
        {E Element +P1 does not have an active path. }

     cme$lcu_recorded_vsn_not_found = cmc$min_lcu_err + 94,
         {E Recorded vsn not found - +P1.}

     cme$lcu_cylinder_limit_exceeded = cmc$min_lcu_err + 95,
         {E Cylinder parameter too large - +P1.}

     cme$lcu_track_limit_exceeded = cmc$min_lcu_err + 96,
         {E Track parameter too large - +P1.}

     cme$lcu_sector_limit_exceeded = cmc$min_lcu_err + 97,
         {E Sector parameter too large - +P1.}

     cme$lcu_logging_not_active = cmc$min_lcu_err + 98,
         {E Logging not active - +P1.}

     cme$lcu_address_already_flawed = cmc$min_lcu_err + 99;
         {W Address already flawed - +P1.}

?? FMT (FORMAT := ON) ??




*DECK DECK=CME$MANAGE_170_RESOURCES EXPAND=FALSE

{ COMMON DECK CME$MANAGE_170_RESOURCES }

?? FMT (FORMAT := OFF) ??
*copyc CMC$CONDITION_LIMITS

  CONST
    cmc$manage_170_resources_err = cmc$min_ecc + 800,

    cme$acq_request_error = cmc$manage_170_resources_err + 20;
        {E The following resource request, +P1, received the following error: +P2. }

?? FMT (FORMAT := ON) ??
*DECK DECK=CME$MANAGE_INTERFACE_TABLES EXPAND=FALSE

{ COMMON DECK CME$MANAGE_INTERFACE_TABLES }

?? FMT (FORMAT := OFF) ??
*copyc CMC$CONDITION_LIMITS
  CONST
    cmc$mit_err = cmc$min_ecc + 200,

{ general interface_table_errors }

    cme$it_invalid_parameter = cmc$mit_err + 0,
        {E +P1. }

    cme$pointer_not_defined = cmc$mit_err + 1,
        {E The pointer +P1 is not defined.}

    cme$search_not_found = cmc$mit_err + 2,
        {E The +P1 was not found.}

    { errors for build_logical_unit_table }

    cme$it_lu_unknown_product_id = cmc$mit_err + 5,
        {E +P3 for logical +P2 in procedure +P1. }


    { errors for build_pp_interface_table }

    cme$it_pp_not_controller_type = cmc$mit_err + 20,
        {E Element +P7 on channel +P3 is not a controller. }

    cme$it_pp_ct_number_mismatch = cmc$mit_err + 25,
        {E Controller element +P7 has mismatching equipment numbers: +P4 and +P5..
        { in procedure +P1. }

    cme$it_pp_channel_name_mismatch = cmc$mit_err + 30,
        {E +P7 not found in controller connection in procedure +P1. }

    cme$it_pp_not_data_type = cmc$mit_err + 35,
        {E +P7 is not a storage device element in procedure +P1. }

    cme$it_pp_unknown_product_id = cmc$mit_err + 40,
        {E +P7 has an unknown product identifier in procedure +P1. }

    cme$it_pp_invalid_lun = cmc$mit_err + 50,
        {E Logical unit number +P6 for element +P7 is too large..
        { in procedure +P1. }

    cme$it_pp_unit_number_mismatch = cmc$mit_err + 55,
        {E Physical unit +P5 for element +P7 does not match defined units..
        { in procedure +P1. }

    cme$it_pp_invalid_channel = cmc$mit_err + 60,
        {E Unsupported channel +P3 for element +P7 was detected in..
        { procedure +P1. }


    cme$it_invalid_jsn = cmc$mit_err + 70,
        {E +P1. }

    cme$it_lun_not_in_range = cmc$mit_err + 75,
        {E +P1. }

    cme$it_nil_lut = cmc$mit_err + 80,
        {E +P1. }

    cme$it_no_cip_access = cmc$mit_err + 83,
        {E Two CIO channels configured.}

    cme$it_unusable_cip_access = cmc$mit_err + 84,
        {E One CIO channel and the second channel unused or OFF. }

    cme$it_unit_unavailable = cmc$mit_err + 85,
        {E +P1. }

    cme$it_not_cip_device = cmc$mit_err + 86,
        {E +P1. }

    cme$it_nil_lpt = cmc$mit_err + 87,
        {E +P1. }

    cme$it_not_mass_storage = cmc$mit_err + 88,
        {E +P1. }

    cme$it_unknown_unit_type = cmc$mit_err + 89,
        {E +P1. }

    cme$it_unconfigured_lun = cmc$mit_err + 90;
       {E +P1 is not configured. }

?? FMT (FORMAT := ON) ??
*DECK DECK=CME$PHYSICAL_CONFIGURATION_MGR EXPAND=FALSE

{ COMMON DECK CME$PHYSICAL_CONFIGURATION_MGR }

?? FMT (FORMAT := OFF) ??
*copyc CMC$CONDITION_LIMITS
  CONST
    cmc$min_pcm_err = cmc$min_ecc + 600,

{ general physical configuration table errors }

    cme$pc_addr_type_not_in_spaa = cmc$min_pcm_err + 0,
        {E Address type +P1 not found in SPAA. }

    cme$pc_allocate_avt_error = cmc$min_pcm_err + 2,
        {C Unable to allocate the active volume table in procedure +P1. }

    cme$pc_element_not_found = cmc$min_pcm_err + 5,
        {E Element +P2 is not in the physical configuration table. }

    cme$no_logical_pp_available = cmc$min_pcm_err + 6,
        {E Unable to assign logical pp. Internal table is full.}

    cme$pc_equip_not_configured = cmc$min_pcm_err + 10,
        {E The system device is not configured in the logical configuration. }

    cme$pc_name_not_data_element = cmc$min_pcm_err + 15,
        {E Element +P2 is not a data storage device. }

    cme$pc_nil_lct = cmc$min_pcm_err + 20,
        {E The logical configuration table was found to be empty when..
        { looking for element +P2. }

    cme$pc_nil_pct = cmc$min_pcm_err + 25,
        {E The physical configuration table was found to be empty when..
        { looking for element +P2. }

    cme$pc_not_enough_entries = cmc$min_pcm_err + 26,
        {E Not enough entries allocated for element list in ..
        {   CMP$GET_CONNECTED_ELEMENTS.}

    cme$pc_no_more_channels = cmc$min_pcm_err + 30,
        {E No more channels available in the logical configuration. }

    cme$pc_not_logically_conf = cmc$min_pcm_err + 35,
        {E Element +P2 is not logically configured. }

    cme$pc_unit_not_found = cmc$min_pcm_err + 40,
        {E Logical unit +P3 is not in the physical configuration table. }

    cme$unknown_channel_type = cmc$min_pcm_err + 41,
        {E Unable to determine channel type +P1. The channel specified is not an external ..
        { channel on the current mainframe.}

    cme$pc_unknown_controller_type = cmc$min_pcm_err + 45,
        {E Product identification +P1 is unknown to the system. }

    cme$pc_unsupported_channel = cmc$min_pcm_err + 50,
        {E Channel number +P1 is not an external channel. }


    cme$pc_nil_cm_table = cmc$min_pcm_err + 51,
        {E +P1.}


{ build physical configuration table errors }

    cme$cmd_name_too_large = cmc$min_pcm_err + 60,
        {E Recorded vsn +P1 contains more than 6 characters. }

    cme$iou_not_configured = cmc$min_pcm_err + 61,
        {E +P1 is not in the active configuration. }

    cme$invalid_iou_number = cmc$min_pcm_err + 63,
        {E Invalid iou number : +P1. }

    cme$invalid_iou_name = cmc$min_pcm_err + 64,
        {E +P1 is not a valid IOU name. }

    cme$illegal_channel_number = cmc$min_pcm_err + 65,
        {E Channel number +P1 is not in range between +P2 and +P3. }

    cme$invalid_channel_number = cmc$min_pcm_err + 66,
        {E +P1. }

    cme$invalid_channel_name = cmc$min_pcm_err + 67,
        {E +P1 is not a valid channel name. }

    cme$invalid_pp_number = cmc$min_pcm_err + 68,
        {E +P1. }

    cme$invalid_pp_name = cmc$min_pcm_err + 69,
        {E +P1 is not a valid PP name. }

    cme$illegal_unit_number = cmc$min_pcm_err + 70,
        {E Unit number +P1 is not in range for the unit type. }

    cme$invalid_name = cmc$min_pcm_err + 75,
        {E Product identification +P1 is incorrect: +P2.}

    cme$invalid_iou_program_name = cmc$min_pcm_err + 76,
        {E +P1 is not a valid peripheral driver name.}

    cme$scc_not_complete = cmc$min_pcm_err + 80,
        {E The system core commands are not complete: +P1. }

    cme$scc_tape_dev_not_specified = cmc$min_pcm_err + 82,
        {E No tape device specified . }

    cme$device_not_allowed_on_iou = cmc$min_pcm_err + 83,
        {E The selected device is not allowed on the current IOU.}

    cme$unknown_product_id = cmc$min_pcm_err + 85,
        {E Product identification +P1 is unknown to the system. }

    cme$port_not_allowed_on_iou = cmc$min_pcm_err + 86,
        {E Ports are not allowed on channels on the current IOU.}

    cme$unsupported_unit_type = cmc$min_pcm_err + 90,
        {E Product identification +P1 is an unsupported unit type. }

    cme$boot_tape_io_error = cmc$min_pcm_err + 91,
        {E +P1 }

    cme$boot_disk_io_error = cmc$min_pcm_err + 92,
        {E +P1 }

    cme$invalid_channel = cmc$min_pcm_err + 93,
        {E +P1 }

    cme$unable_to_idle  = cmc$min_pcm_err + 94,
        {E +P1.}

    cme$unable_to_resume = cmc$min_pcm_err + 95,
        {E +P1.}

    cme$ppit_not_built = cmc$min_pcm_err + 96,
        {E PP interface table not built.}

    cme$dump_requires_hardware_idle = cmc$min_pcm_err + 97,
        {E Hardware idle required for dumping PP memory. }

    cme$pp_holds_pp_queue_lock = cmc$min_pcm_err + 98,
        {E PP currently have PP queue locked. }

    cme$cm_end_case_error = cmc$min_pcm_err + 99;
        {E End case error encountered in +P1, type out of range.}

?? FMT (FORMAT := ON) ??
*DECK DECK=CME$PHYSICAL_CONFIGURATION_UTL EXPAND=FALSE

*copyc CMC$CONDITION_LIMITS
{ COMMON DECK CME$PHYSICAL_CONFIGURATION_UTL }

?? FMT (FORMAT := OFF) ??

  CONST
    cmc$pcu = cmc$min_ecc + 700,

    cme$pcu_duplicate_pen = cmc$pcu + 0,
        {E Element +P1 has a physical equipment number, +P2 that is already..
        { being used by +P3. }

    cme$pcu_duplicate_pun = cmc$pcu + 10,
        {E Physical unit number +P2 of element +P1 is already  ..
        { being used by +P3. }

    cme$pcu_duplicate_ser_num = cmc$pcu + 15,
        {E Element +P1 has a serial number +P2 that is already  }
        { being used.}

    cme$pcu_eoi_not_returned = cmc$pcu + 20,
        {E Information regarding the configuration is not available in..
        { the PHYSICAL_CONFIGURATION_UTILITY.}

    cme$pcu_invalid_inspc_call = cmc$pcu + 21,
        {E INSTALL_PHYSICAL_CONFIGURATION cannot be called after ..
        { deadstart.}

    cme$pcu_same_as_not_defined = cmc$pcu + 22,
        {E +P1 is not yet defined. }


    cme$pcu_file_error = cmc$pcu + 30,
        {E Can't detect eoi for input file in +P1 in ..
        {the PHYSICAL_CONFIGURATION_UTILITY. }

    cme$pcu_illegal_output_file = cmc$pcu + 35,
        {E File +F1 must have page width of at least +P2 characters. }

    cme$pcu_invalid_channel_number = cmc$pcu + 40,
        {E Invalid channel name: +P2 in +P1. }

    cme$pcu_improper_channel_usage = cmc$pcu + 41,
        {E +P1 cannot be connected to +P2. Channel port is ..
        {either missing or should not be used.}

    cme$pcu_invalid_element_id = cmc$pcu + 45,
        {E Element +P1 has an invalid ELEMENT_IDENTIFICATION: +P2}

    cme$pcu_invalid_parameter = cmc$pcu + 55,
        {E +P1 for element +P2. }

    cme$pcu_too_many_value_sets = cmc$pcu + 60,
        {E +P1 for element +P2. }

    cme$pcu_underprivileged_user = cmc$pcu + 65,
        {E User has insufficient privilege to install the physical configuration. }

    cme$pcu_unknown_product_id = cmc$pcu + 70,
        {I Product identification +P1 is unknown to the system. }

    cme$pcu_unknown_value = cmc$pcu + 75,
        {E +P1: +P2. }

    cme$pcu_element_not_found = cmc$pcu + 76,
        {E +P1 is not in the edited file. }

    cme$pcu_empty_file = cmc$pcu + 77,
        {E The current file is empty.}

    cme$pcu_connection_not_found = cmc$pcu + 78,
        {E +P1 does not have a connection of the type described.}

    cme$pcu_invalid_command = cmc$pcu + 79,
        {E +P1 cannot be executed within EDIPC session.}

    cme$pcu_value_out_of_range = cmc$pcu + 80,
        {E +P1 in DEFINE_ELEMENT. }

    cme$pcu_missing_parameters = cmc$pcu + 81,
        {E Missing parameter +P1 for element +P2.}

    cme$pcu_verpc_err = cmc$pcu + 82,
        {E VERIFY_PHYSICAL_CONFIGURATION detects +P2 error(s).}

    cme$pcu_inspc_err = cmc$pcu + 83,
        {E INSTALL_PHYSICAL_CONFIGURATION detects +P2 error(s).}

    cme$pcu_invalid_pf_ref = cmc$pcu + 84,
        {E User cannot reference permanent files at this time.}

    cme$pcu_element_already_defined = cmc$pcu + 85,
        {E +P1 is already defined in the edited file.}

    cme$pcu_mainframe_not_found = cmc$pcu + 86,
        {E +P1 is not defined in the configuration file.}

    cme$pcu_inconsistent_tape_subs = cmc$pcu + 87,
        {E Invalid mixture of single and dual PP ..
        {   tape subsystem: +P1 is already defined as a ..
        {   dual PP while +P2 is a single PP tape subsystem. }

    cme$invalid_mixture_of_product = cmc$pcu + 88,
        {E Invalid mixture of product identification connected to ..
        {   +P1. The following products are found : +P2, +P3 . }

    cme$pcu_invalid_use_of_retain = cmc$pcu + 89,
       {E RETAIN parameter can be specified only when using ALL on ..
       {  ELEMENTS parameter.}

    cme$pcu_invalid_connection = cmc$pcu + 90;
       {E Element : +P1 is found to have no units connected to ..
       {  to it, dangling controller definition is not allowed. }

?? FMT (FORMAT := ON) ??

*DECK DECK=CME$RESERVE_ELEMENT EXPAND=FALSE

?? FMT (FORMAT := OFF) ??
*copyc cmc$condition_limits

 CONST
   cmc$reserve_element_error = cmc$min_ecc + 900,

   cme$element_not_reservable     = cmc$reserve_element_error + 0,
    {E +P1 is not reservable. }

   cme$incorrect_element_type     = cmc$reserve_element_error + 1,
    {E Requested element type does not match element type found ..
    {in active configuration for +P1. }

   cme$privileged_job_required    = cmc$reserve_element_error + 2,
    {E Insufficient privilege to perform +P1 request. }

   cme$element_not_storage_device = cmc$reserve_element_error + 3,
    {E Element name or hardware address is not a storage device ..
    {in +P1. }

   cme$specific_pp_not_reservable = cmc$reserve_element_error + 4,
    {E A specific pp cannot be reserved at this time. }

   cme$element_already_reserved   = cmc$reserve_element_error + 6,
    {E +P1 is already reserved by: +P2.}

   cme$element_state_not_proper   = cmc$reserve_element_error + 8,
    {E +P1 is NOT in ON state.}

   cme$element_unavailable_in_170 = cmc$reserve_element_error + 10,
    {E +P1 is not available in the NOS or NOS/BE system.}

   cme$invalid_state_in_mainframe = cmc$reserve_element_error + 12,
    {E +P1 needs to be in the DOWN or OFF state in mainframe +P2.}

   cme$element_not_reserved       = cmc$reserve_element_error + 14,
    {E +P1 is not reserved to this job. }

   cme$reserve_not_permitted      = cmc$reserve_element_error + 16,
    {E Job already has +P1 reserved to it; reservation of +P2 ..
    {not permitted. }

   cme$element_downline_connected =  cmc$reserve_element_error + 18,
    {E +P1 has at least one element connected to it which is ..
    {not in the OFF state.}

   cme$cm_table_empty             =  cmc$reserve_element_error + 20,
    {E Configuration table is empty. }

   cme$active_pc_empty            =  cmc$reserve_element_error + 22,
    {E Active physical configuration table is empty. }

   cme$page_size_too_small = cmc$reserve_element_error + 23,
    {E The page size is required to be at least 4096 bytes ..
    {   in order to get contiguous memory. }

   cme$cm_element_not_found       =  cmc$reserve_element_error + 24,
    {E Element +P1 NOT found in configuration table. }

   cme$too_many_pp_program_desc   =  cmc$reserve_element_error + 26,
    {E CMP$EXECUTE_PP_PROGRAM allows no more than two program descriptions. }

   cme$reserve_request_required   =  cmc$reserve_element_error + 28,
    {E Storage device +P1 must be RESERVED or REQUESTED (dedicated or
    { maintenance) by this job for the mounting of a medium on it. }

   cme$buffer_length_too_large = cmc$reserve_element_error + 29,
    {E The requested communication buffer length exceeds the ..
    { maximum page size. }

   cme$mount_storage_medium       =  cmc$reserve_element_error + 30,
    {I Mount medium +P1 on device +P2  (mode = +P3). }

   cme$message_to_operator        =  cmc$reserve_element_error + 32,
    {I Do ASSIGN_DEVICE again with device = +P1. }

   cme$lcm_device_attached_to_job =  cmc$reserve_element_error + 34,
    {E Storage device +P1 is already attached to this job. }

   cme$lcm_device_busy            =  cmc$reserve_element_error + 36,
    {E Storage device +P1 is busy (assigned by job: +P2). }

   cme$mount_media_denied         =  cmc$reserve_element_error + 38;
    {E CMP$MOUNT_STORAGE_MEDIUM not allowed on mass storage device (+P1) ..
    {which is the object of CONCURRENT maintenance. }

?? FMT (FORMAT := ON) ??
*DECK DECK=CMH$ACQUIRE_SYSTEM_DEVICE EXPAND=TRUE

{ COMMON DECK CMHASD }

{   The purpose of the request is to acquire then system device
{ described by system core commands during either installation or
{ continuation deadstart, or described by stored information on all
{ other types of deadstart.
{
{       CMP$ACQUIRE_SYSTEM_DEVICE (STATUS)
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CMH$ACTIVATE_VOLUME EXPAND=FALSE

{ COMMON DECK CMHAVOL }

{   The purpose of this request is to allow the logical configuation utility
{ to call a ring one device management procedure to activate a volume.
{
{       CMP$ACTIVATE_VOLUME (LOGICAL_UNIT_NUMBER, STATUS)
{
{ LOGICAL_UNIT_NUMBER: (input)  This parameter specifies the logical unit
{       number of the volume to be activated.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$ADDRESS_TYPE_NOT_FOUND EXPAND=FALSE

{   The purpose of this request is to return a status for not finding a
{ particular address type.
{
{       CMP$ADDRESS_TYPE_NOT_FOUND (ADDRESS_TYPE, CONDITION, STATUS)
{
{ ADDRESS_TYPE: (input)  This parameter specifies the address type that
{       was not found.
{
{ CONDITION: (input)  This parameter specifies the status condition code.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$ADD_SSIOT_ENTRY_AVAIL_QUEUE EXPAND=FALSE
{
{     This request is used to return a job io completion table entry to
{  the job io completion table.
{
{         CMP$ADD_SSIOT_ENTRY_AVAIL_QUEUE (JOB_IO_COMPLETION_QUEUE_INDEX)
{
{  JOB_IO_COMPLETION_QUEUE_INDEX: (input/output)  This parameter specifies the
{                          index of the entry to be returned.
{
*DECK DECK=CMH$ALLOCATE_ADTT EXPAND=FALSE

{ COMMON DECK CMHALAD }

{   The purpose of this request is to allocate the active driver type
{ table in the mainframe wired heap.
{
{       CMP$ALLOCATE_ADTT (STATUS)
{
{ STATUS: (output)  This paramter specifies the request status.
{
*DECK DECK=CMH$ALLOCATE_IMAGE_FILE_ADTT EXPAND=FALSE

{ COMMON DECK CMHALID }

{   The purpose of this request is to allocate the active driver type
{ table for the image file in the mainframe wired heap.
{
{       CMP$ALLOCATE_IMAGE_FILE_ADTT (TABLE_SPACE, STATUS)
{
{ TABLE_SPACE: (input)  This parameter specifies where the adtt is to
{       be loacated.
{
{ STATUS: (output)  This paramter specifies the request status.
{
*DECK DECK=CMH$ASSIGN_UNIT EXPAND=FALSE
*DECK DECK=CMH$BEGIN_TRANSITION EXPAND=FALSE

{ COMMON DECK CMHBTRN }

{   The purpose of this request is to initiate the transition phase of
{ configuration management.  This routine calls procedures to initialize
{ the active driver type table and to set all the system pointer address
{ array fields.  It then idles the system core device driver, and
{ requests and loads all other equipment that has been specified.
{ It then notifies device management and tape management that there
{ might exist units that their areas are unaware of.
{
{       CMP$BEGIN_TRANSITION (SYS_DEV_LUN, CHANNEL_NUMBER, EQUIPMENT_NUMBER,
{         UNIT_NUMBER, PP_NUMBER, STATUS)
{
{ SYS_DEV_LUN: (input)  This parameter specifies the logical unit number
{       associated with the system device.
{
{ CHANNEL_NUMBER: (input)  This parameter specifies the physical channel
{       number used by the system device.
{
{ EQUIPMENT_NUMBER: (input)  This parameter specifies the physical
{       equipment number used by the system device.
{
{ UNIT_NUMBER: (input)  This parameter specifies the physical unit number
{       used by the system device.
{
{ PP_NUMBER: (input)  This parameter specifies the physical pp number
{       used by the system device.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$BUILD_INTERFACE_TABLES EXPAND=FALSE
*DECK DECK=CMH$BUILD_LCT EXPAND=FALSE

{ COMMON DECK CMHBLCT }

{   The purpose of this request is to build an array in mainframe paged
{ containing the entries in the logical configuration table.  The variable
{ describing this array is cmv$logical_configuraion.
{
{       CMP$BUILD_LCT (ENTRY_COUNT, ENTRIES, STATUS)
{
{ ENTRY_COUNT: (input) This parameter specifies the number of lct entries
{       to be placed in the table.
{
{ ENTRIES: (input) This parameter specifies the lct entries to be used when
{       building the lct.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CMH$BUILD_LOGICAL_CONF EXPAND=FALSE

{ COMMON DECK CMHBLC }

{
{   The purpose of this request is to build a logical configuration file.
{
{       CMP$BUILD_LOGICAL_CONF (CONNECTED_PC_FID, LC_LIST_FID,CONNECTED_LC_FID,
{         STATUS)
{
{ CONNECTED_PC_FID: (input) This parameter specifies the segment access
{       file identifier of the file containing the connected physical
{       configuration.
{
{ LC_LIST_FID: (input) This parameter specifies the segment access file
{       identifier of the file containing the logical configuration list.
{
{ CONNECTED_LC_FID: (input) This parameter specifies the segment access
{       file identifier of the file that recieves the subset of the
{       physical configuration specified by the lc_list_fid.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CMH$BUILD_PCT EXPAND=FALSE

{ COMMON DECK CMHBPCT }

{   The purpose of this request is to build an array in mainframe paged
{ containing the entries in the physical configuration table.  The variable
{ describing this array is cmv$physical_configuraion.
{
{       CMP$BUILD_PCT (ENTRY_COUNT, ENTRIES, STATUS)
{
{ ENTRY_COUNT: (input) This parameter specifies the number of pct entries
{       to be placed in the table.
{
{ ENTRIES: (input) This parameter specifies the pct entries to be used when
{       building the pct.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CMH$BUILD_REQUEST_ENTRY EXPAND=FALSE

{ COMMON DECK CMHBRE }

{   The purpose of this request is acquire for the equipment specified
{
{       CMP$BUILD_REQUEST_ENTRY (CHANNEL_NUMBER,EQUIPMENT_NUMBER,
{         UNIT_NUMBER, DRIVER_NAME, PP_NUMBER, STATUS)
{
{ CHANNEL_NUMBER: (input)  This parameter specifies the channel number of the
{       equipment being requested.
{
{ EQUIPMENT_NUMBER: (input)  This parameter specifies the equipment number of
{       the equipment being requested.
{
{ UNIT_NUMBER: (input)  This parameter specifies the unit number of the
{       equipment being requested.
{
{
{ DRIVER_NAME: (input)  This parameter specifies the name of the peripheral
{       driver to be loaded with the above equipment.
{
{ PP_NUMBER: (output) This parameter specifies the pp number acquired
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$BUILD_STATE_TABLE EXPAND=FALSE
{
{   The purpose of this request is to copy state information of all the
{   elements in the active logical configuration into a table.
{
{       CMP$BUILD_STATE_TABLE (ENTRY_COUNT, ENTRIES, STATUS)
{
{    ENTRY_COUNT : {input} This parameter specifies the number of elements
{                   to copy.
{
{    ENTRIES     : {input} This parameter specifies an array of state information
{                  entries.
{
{    STATUS      : {output} This parameter specifies the requested status.
{
*DECK DECK=CMH$BUILD_STND_INTERFACE_TABLES EXPAND=FALSE
*DECK DECK=CMH$BUILD_WIRED_QUEUE_REQUEST EXPAND=FALSE

{
{    This request is used to construct the io queue entry for a subsystem
{  io request.
{
{          CMP$BUILD_WIRED_QUEUE_REQUEST (ELEMENT_NAME, REQUEST_TYPE, COMMAND_TABLE,
{                        DATA_COMMAND_DESCRIPTORS_P, REQUEST_ID, IO_RESPONSE_P,
{                        STATUS)
{
{  ELEMENT_NAME: (input)  This parameter specifies the element name associated
{                         with the request.  For a pp request, the element name is the
{                         name of a unit associated with pp.  For a unit request, the
{                         element name is the element name of the unit.
{
{  REQUEST_TYPE: (input)  This parameter specifies the type of io request.
{
{  COMMAND_TABLE_P: (input)  This parameter is a pointer to the commands to be used
{                            to process this request.
{
{  DATA_COMMAND_DESCRIPTORS_P: (input)  This parameter is a pointer to the addresses
{                                       to be associated with the commands.
{
{  REQUEST_ID: (input)  This parameter specifies the subsystem io request
{                       identification to be associated with this
{                       io queue entry.
{
{  IO_RESPONSE_P: (input)  This parameter is a pointer to a subsystem response
{                          area to be associated with this request.
{
{  STATUS: (output)  This parameter returns the request status.
{
*DECK DECK=CMH$CHANGE_CPU_ELEMENT_STATE EXPAND=FALSE
{
{   The purpose of this request is to change the logical state of a Central
{ Processor Unit (CPU).  Configuration status and control privilege is required to
{ be able to use this request.
{
{   All CPU state changes are logged in the Engineering Log (statistic CM0200);
{ the specific state change ( e.g.  ON to OFF) and the initiator of the change are
{ recorded.
{
{   The new state of a CPU will be preserved across NOS/VE system continuation
{ deadstarts.
{
{   The state for a central processor is initially determined at each NOS/VE
{ deadstart.  NOS/VE dynamically adapts to the logical presence or absence of
{ central processors dictated by the system operator during deadstart.
{
{   Only CPU elements which are not critical to system execution may be placed in
{ the OFF or DOWN states.  An example of a request which would be rejected is
{ downing or offing the only CPU.
{
{   If the system element is being returned to the ON state from the OFF or DOWN
{ state, it will be subject to automatic, element-dependent re-instatement
{ procedures.  This includes reloading microcode in a central processor, if
{ necessary.
{
{   Placing a CPU in the DOWN or OFF state has the following impact on the NOS/VE
{ system and its users:
{
{   The central processor is hardware idled and isolated from the
{ hardware error monitoring part of the system.
{
{   A few notes on element states:
{   (See ERS A6714: Configuration Management Program Interface, sec. 10.3.2)
{   ON state:
{   The ON state implies that the system element is either fully operational or
{ operating in a degraded mode, i.e.  capable of performing a useful subset of
{ its capabilities.  The ON state further indicated that the element is
{ available for use by the system or by (concurrent) maintenance.  An element
{ whose state is changes to ON will be subjected to NOS/VE-initiated,
{ element-dependent, reinstatement procedures including:
{        - standard microcode loading
{        - confidence testing
{        - label searching
{
{   OFF state:
{   The OFF state indicates that the system element is neither available to the
{ system not to online/concurrent maintenance.  An element may be placed in the
{ OFF state to inhibit its further use.  While in this state the element is
{ logically not present and may be physically isolated from the rest of the
{ system, i.e.  the element may be switched "off-line" or hardware idled so that
{ it cannot affect the rest of the system.  The CE may place an element in the
{ OFF state to prevent other users or OCM (On-line/Concurrent Maintenance) access
{ while an element is being repaired or until replacement parts are available to
{ complete a repair action.
{
{   DOWN state:
{   The DOWN state indicates that the system element may be accessed only by a
{ maintenance job.  This is provided for online, dedicated access to elements
{ which have failed or appear to have failed to operate correctly.  An element
{ in the DOWN state may be undergoing diagnostic or repair acivities.
{
{   A few notes on valid state changes:
{   (See ERS A6714: Configuration Management Program Interface, sec. 10.4.1)
{   The following table shows who may initiate an element state change and under
{ what conditions the state change is allowed.  A 'Y' or 'N' indicates the
{ action is allowed or disallowed under any circumstance.  A numeral refers to
{ one of the rules or comments (which appear in section 10.4.1 of the refered
{ ERS) to which the state change is subject in order to be valid.
{
{    ------------+-------------|----------+----------+------------
{                |             |  SYSTEM  |    CE    |  NOS/VE
{       FROM     |     TO      | OPERATOR |          |  SYSTEM
{    ------------+-------------|----------+----------+------------
{                |             |          |          |
{       ON       |  OFF        |     1,5  |    N     |      N
{       ON       |  DOWN       |     1    |    1     |      Y,2
{       OFF      |  ON         |     3,8  |    N     |      N
{       OFF      |  DOWN       |     4    |    N     |      N
{       DOWN     |  ON         |   3,5,8  |  3,5,6,8 |      N
{       DOWN     |  OFF        |     5    |    5,7   |      N
{
{
{       CMP$CHANGE_ELEMENT_STATE (PROCESSOR_ID, STATE, STATUS)
{
{ PROCESSOR_ID: (input)  This parameter specifies the number of the CPU whose
{       state is to be changed.  The identity specifiea the logical element
{       number of the CPU as it relates to the CPU state table.
{
{ STATE: (input)  This parameter specifies the new state of the element.
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS:
{                     cme$request_state_is_crnt_state,
{                     ose$processor_not_defined,
{                     cme$lcm_ring_validation_error
{
{         IDENTIFIER:  'CM'
{
*DECK DECK=CMH$CHANGE_DFT_ENTRY EXPAND=TRUE

{ COMMON DECK CMHCDFT }

{   The purpose of this request is to change a particular device
{ file table entry.
{
{       CMP$CHANGE_DFT_ENTRY (DEVICE_FILE_TYPE, DEVICE_FILE_COUNT,
{         DEVICE_FILE_RECORD)
{
{ DEVICE_FILE_TYPE: (input)  This parameter specifies the device file
{       type of the entry to be changed.
{
{ DEVICE_FILE_COUNT: (input)  This parameter specifies the device file
{       count of the entry to be changed.
{
{ DEVICE_FILE_RECORD: (input)  This parameter specifies the new value
{       of the entry being changed.
{
*DECK DECK=CMH$CHANGE_ELEMENT_STATE EXPAND=FALSE
{
{   The purpose of this request is to change the logical state of an element.
{ Configuration status and control privilege is required to be able to use this
{ request.
{
{   All element state changes are logged in the Engineering Log (statistic
{ CM0200); the specific state change ( e.g.  ON to OFF) and the initiator of
{ the change are recorded.
{
{   The new state of a peripheral element will be preserved across NOS/VE
{ system continuation deadstarts.
{
{   The state for a central processor is initially determined at each NOS/VE
{ deadstart.  NOS/VE dynamically adapts to the logical presence or absence of
{ central processors dictated by the system operator during deadstart.  State
{ changes of a central processor made using this request are not preserved
{ across NOS/VE system continuation deadstarts; they merely control the use of
{ a processor until the next NOS/VE deadstart.
{
{   Only system elements which are not critical to system execution may be
{ placed in the OFF or DOWN states.  Examples of requests which would be
{ rejected are:  downing or offing the only CP, the system disk, or the only
{ channel/controller to the system deadstart device.
{
{   A state change is disallowed if the element is currently reserved to a job
{ or it is connected to a channel which is currently reserved to a job.  Refer
{ to the documentation of the CMP$RESERVE_ELEMENT request.  Elements which are
{ reserved by the NOS/VE system itself may or may not be permitted to change
{ state, depending upon the circumstances; refer to the documentation of the
{ CHANGE_ELEMENT_STATE subcommand of the Logical Configuration Utility.
{
{   If a peripheral element is identified in the element descriptor, this
{ request will ensure that the value of the element_type field matches the type
{ of the element identified by the peripheral_descriptor field.  Remember that
{ all reservable elements available to a non-system caller are either
{ classified as a controller or a storage device; refer to the description of
{ the DEFINE_ELEMENT subcommand of the Physical Configuration Utility for more
{ information.
{
{   If a channel has multiple ports, then all ports of the channel are affected
{ by the change of state.  For example, an I4 CIO channel may be referred to by
{ the name CCH1A, CCH1B, or CCH1; with respect to this request all forms of
{ reference have the same result.
{
{   If the system element is being returned to the ON state from the OFF or
{ DOWN state, it will be subject to automatic, element-dependent re-instatement
{ procedures.  This includes one or more of the following:
{
{   .Reloading microcode in a central processor
{
{   .Down-loading of standard microcode into a peripheral
{
{   .Searching for system labels on mass storage volumes
{
{   Placing an element in the DOWN or OFF state has the following impact on the
{ NOS/VE system and its users:
{
{   If the element is a storage device:
{
{        1.  No further access to the media is permitted except for a
{            maintenance job (and then only if the element is in the DOWN
{            state).
{
{        2.  Jobs requiring access to the media are swapped out of memory until
{            the media is re-instated.
{
{        3.  For a mass storage device no further allocation is performed on
{            the media and new files are allocated to the remaining media.
{
{   If the element is a data channel, channel-adapter, or controller, the
{ effect of the state change is configuration-dependent, but the change will
{ prevent access to one or more storage devices in the absence of an alternate
{ access to the storage devices.
{
{   If the element is a central processor, the processor is hardware-idled and
{ isolated from the hardware-error-monitoring part of the system.
{
{       CMP$CHANGE_ELEMENT_STATE (ELEMENT, STATE, STATUS)
{
{ ELEMENT: (input)  This parameter specifies the identity of the system element
{       whose state is to be changed.  The identity may be specified using
{       either the name of the element or its hardware address.
{
{       If a peripheral hardware address is specified you must initialize the
{       physical_address_specifier to indicate how many parts of the address
{       are initialized in the address path.  For example, if you are changing
{       the state of a unit, the physical_address_specifier must include a
{       channel, a channel_address and the unit_address and you must initialize
{       all three fields of the hardware address.
{
{       If use_logical_identification is FALSE in any of the fields of the
{       element descriptor and the mainframe has more than one IOU, the name of
{       the IOU must be initialized because the channel identification is
{       ambiguous in this case.  The IOU component of the peripheral descriptor
{       will be ignored on single IOU mainframes.
{
{
{ STATE: (input)  This parameter specifies the new state of the element.
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS:
{                     cme$element_unavailable_in_170,
{                     cme$lcm_element_not_found,
{                     cme$lcm_empty_pa_set,
{                     cme$lcm_missing_pa_set_member,
{                     cme$lcm_ring_validation_error,
{                     cme$privileged_job_required.
{
{         IDENTIFIER:  'CM'
{
{
*DECK DECK=CMH$CHECK_FOR_UNIQUE_ELEMENT EXPAND=FALSE
*DECK DECK=CMH$CHECK_INITIATED_IO_STATUS EXPAND=FALSE
{
{    This request is used to check for completion of subsystem io requests.
{  Upon completion of this request, the pp response associated with each
{  completed subsystem io request, is available in the response area
{  associated with the subsystem io request.
{
{      CMP$CHECK_INITIATED_IO_STATUS (IO_STATUS_P, INDEX, STATUS)
{
{  IO_STATUS_P: (input,output)  This parameter is a pointer to a list of
{                               subsystem io request ids and their associated
{                               completion status.  A NIL pointer implies an
{                               io status check will be made for all subsystem
{                               io requests known to the job.
{
{  INDEX: (output)  This parameter specifies the index of the first subsystem io
{                   request id in the list that has a completed io status.  A value
{                   of 0 implies no subsystem io request has a completed io
{                   status.  IF io_status_p was NIL, this index will be non-
{                   zero if any subsystem io request has a completed io status.
{
{  STATUS: (output)  This parameter returns the request status.
{
*DECK DECK=CMH$COMPLETE_SSIOT_RECOVERY EXPAND=FALSE
{
{     This request is used to indicate that recovery of all outstanding io
{  requests has been performed by a subsystem.
{
{          CMP$COMPLETE_SSIOT_RECOVERY (STATUS)
{
{  STATUS: (output)  This parameter returns the request status.
{
*DECK DECK=CMH$CONFIGURE_INSTALLED_SYSTEM EXPAND=FALSE

{ COMMON DECK CMHCIS }

{   The purpose of this request is to configure a system that has been
{ previously installed by running the physical configuration utility and
{ the logical configuration utility.  If the utilities have not been run
{ successfully, this procedure will abort and the system configuration
{ will remain as it currently is.
{
{       CMP$CONFIGURE_INSTALLED_SYSTEM (STATUS)
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$CONFIGURE_SYSTEM_DEVICE EXPAND=FALSE

{ COMMON DECK CMHCSD }

{   The purpose of this request is to configure the system device during
{ system core deadstart.
{
{       CMP$CONFIGURE_SYSTEM_DEVICE (STATUS)
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$CONNECT_CHANNEL_ELEMENTS EXPAND=FALSE

{ COMMON DECK CMHCCHE }

{   The purpose of this request is to configure a channel element and all
{ downline equipments that exist in the connected physical configuration.
{
{       CMP$CONNECT_CHANNEL_ELEMENTS (CONNECTED_PC_FID, CONNECTED_LC_FID,
{         ELEMENT, STATUS)
{
{ CONNECTED_PC_FID: (input)  This parameter specifies the segment access
{       file identifier that contains the connected physical configuration.
{
{ CONNECTED_LC_FID: (input)  This parameter specifies the segment access
{       file identifier that will contain the connected logical configuration.
{
{ ELEMENT: (input)  This parameter specifies the channel element that is
{       being connected.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$CONNECT_CONTROLLER_ELEMENTS EXPAND=FALSE

{ COMMON DECK CMHCCTE }

{   The purpose of this request is to configure a controller element and all
{ downline units that exist in the connected physical configuration.
{
{       CMP$CONNECT_CONTROLLER_ELEMENTS (CONNECTED_PC_FID, CONNECTED_LC_FID,
{         ELEMENT, STATUS)
{
{ CONNECTED_PC_FID: (input)  This parameter specifies the segment access
{       file identifier that contains the connected physical configuration.
{
{ CONNECTED_LC_FID: (input)  This parameter specifies the segment access
{       file identifier that will contain the connected logical configuration.
{
{ ELEMENT: (input)  This parameter specifies the controller element that is
{       being connected.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$COPY_STATE_INFO_TO_DF EXPAND=FALSE
{
{  The purpose of this request is to copy state information from a
{  BAM file to a device file.
{
{    CMP$COPY_STATE_INFO_TO_DF (STATE_INFO_FID, CREATE_NEW_FILE,
{          STATUS)
{
{   STATE_INFO_FID : {input} This parameter specifies the BAM file identifier
{                    that contains state information.
{
{   CREATE_NEW_FILE : {input} This parameter specifies whether or not a new device
{                     should be created. During an Installation Deadstart, this
{                     parameter is set to TRUE.
{
{   STATUS : {output} This parameter specifies the status of the request.
{
{
*DECK DECK=CMH$CREATE_AND_SUBMIT_IO_REQ EXPAND=FALSE
{
{    This request is used to create and queue a subsystem io request.
{
{          CMP$CREATE_AND_SUBMIT_IO_REQ (REQUEST_TYPE, ELEMENT_NAME,
{                        COMMAND_TABLE_P, DATA_COMMAND_DESCRIPTORS_P,
{                        UNIT_QUEUE_CONTROL, RECOVERY_OPTIONS,
{                        WAIT_FOR_IO_COMPLETION, IO_IDENTIFICATION,
{                        IO_RESPONSE_P, REQUEST_ID, STATUS)
{
{  REQUEST_TYPE: (input)  This parameter specifies the type of io request.
{
{  ELEMENT_NAME: (input)  This parameter specifies the element name of the element
{                         to be associated with the io request.
{
{  COMMAND_TABLE_P: (input)  This parameter is a pointer to the commands to be used
{                            to process this request.
{
{  DATA_COMMAND_DESCRIPTORS_P: (input)  This parameter is a pointer to the addresses to be
{                                        associated with the commands.
{
{  UNIT_QUEUE_CONTROL: (input)  This parameter specifies the manner in which
{                               to link this request into the unit request
{                               queue.
{
{  RECOVERY_OPTIONS: (input)  This parameter specifies the type of
{                             recovery to associate with this request.
{
{  WAIT_FOR_IO_COMPLETION:  (input)  This parameter specifies whether or not
{                                    the task wants to wait for this io request
{                                    to complete.  If the task wants to wait
{                                    for io completion, an amount of time to
{                                    wait must be specified.
{
{  IO_IDENTIFICATION: (input)  This parameter specifies a user io
{                              identification to be associated with this
{                              subsystem io request.
{
{  IO_RESPONSE_P: (input)  This parameter is a pointer to a subsystem response
{                          area to be associated with this request.
{
{  REQUEST_ID: (output)  This parameter returns the operating system identification
{                        that is associated with the subsystem io request.
{
{  STATUS: (output)  This parameter returns the request status.
{
*DECK DECK=CMH$CREATE_CM_DEVICE_FILES EXPAND=FALSE

{ COMMON DECK CMHCDF }

{   The purpose of this request is to create two device files that will
{ be used by the physical and logical configuration utilities to store
{ configuration information.  This procedure must be called after device
{ management system initialization and before device management activate
{ volume code.
{
{       CMP$CREATE_CM_DEVICE_FILES (STATUS)
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$CREATE_IO_REQUEST EXPAND=FALSE
{
{    This request is used to construct the operating system portion for a subsystem
{  io request.
{
{          CMP$CREATE_IO_REQUEST (REQUEST_TYPE, ELEMENT_NAME,
{                        COMMAND_TABLE_P, DATA_COMMAND_DESCRIPTORS_P,
{                        IO_IDENTIFICATION, IO_RESPONSE_P, REQUEST_ID, STATUS)
{
{  REQUEST_TYPE: (input)  This parameter specifies the type of io request.
{
{  ELEMENT_NAME: (input)  This parameter specifies the element name of the element that
{                         is to be associated with the io request.
{
{  COMMAND_TABLE_P: (input)  This parameter is a pointer to the commands to be used
{                            to process this request.
{
{  DATA_COMMAND_DESCRIPTORS_P: (input)  This parameter is a pointer to the addresses to be
{                                        associated with the commands.
{
{  IO_IDENTIFICATION: (input)  This parameter specifies a user io
{                              identification to be associated with this
{                              subsystem io request.
{
{  IO_RESPONSE_P: (input)  This parameter is a pointer to a subsystem response
{                          area to be associated with this request.
{
{  REQUEST_ID: (output)  This parameter returns the operating system
{                        identification that is associated with the io
{                        request.
{
{  STATUS: (output)  This parameter returns the request status.
{
*DECK DECK=CMH$CREATE_STATE_INFO_DF EXPAND=FALSE
{
{  The purpose of this request is to create a device file containing
{  state information about all element in the active logical configuration.
{
{    CMP$CREATE_STATE_INFO_DF (STATUS)
{
{  STATUS : {output} This parameter specifies the status of the request.
{
{
*DECK DECK=CMH$DEADSTART_PHASE EXPAND=FALSE
{ }
{     The purpose of this request is to return the current value }
{ of osv$deadstart_phase to a ring 11 user. }
{ }
{       FUNCTION CMP$DEADSTART_PHASE }
{ }
*DECK DECK=CMH$DESTROY_IO_COMPLETION_TABLE EXPAND=FALSE
{
{    This request is used to destroy the io completion table associated
{  with a job.  If the io completion table has any outstanding io requests,
{  the table will not be destroyed.
{
{          CMP$DESTROY_IO_COMPLETION_TABLE (STATUS)
{
{  STATUS: (output)  This parameter returns the request status.
{

*DECK DECK=CMH$DESTROY_IO_COMPLETION_TB_R1 EXPAND=FALSE

{
{    This request is used to destroy the io completion table associated
{  with a job.  If the io completion table has any outstanding
{  io requests, the table is not destroyed.
{
{          CMP$DESTROY_IO_COMPLETION_TB_R1 (STATUS)
{
{  STATUS: (output)  This parameter returns the request status.
{
*DECK DECK=CMH$DESTROY_IO_COMPLETION_TB_R2 EXPAND=FALSE
{
{    This requst is used to destroy the io completion table associated
{  with a job.  If the io completion table has any outstanding io requests,
{  the table is not destroyed.
{
{          CMP$DESTROY_IO_COMPLETION_TB_R2 (STATUS)
{
{  STATUS: (output)  This parameter returns the request status.
{
*DECK DECK=CMH$DESTROY_IO_REQUEST EXPAND=FALSE
{
{     This request is used to destroy the operating system supplied portion
{  of a subsystem io request.
{
{          CMP$DESTROY_IO_REQUEST (REQUEST_ID, STATUS)
{
{  REQUEST_ID: (input/output)  This parameter specifies the operating system
{                        identification of the io request to destroy.
{
{  STATUS: (output)  This parameter returns the request status.
{
*DECK DECK=CMH$DISPLAY_NAMED_ELEMENT EXPAND=FALSE

{ COMMON DECK CMHDNE }

{   The purpose of this request is to display a particular named
{ element from a list of elements to a specific output file.
{
{       CMP$DISPLAY_NAMED_ELEMENT (ELEMENT_NAME, IOU_NAME, DISPLAY_OPTION,
{         ELEMENT_COUNT, LC_ELEMENT, DISPLAY_CONTROL, STATUS)
{
{ ELEMENT_NAME: (input)  This parameter specifies the name of element to
{       be displayed.
{
{ IOU_NAME: (input) This parameter specifies the name of the IOU associated
{       with the element name if the element is a data channel element.
{
{ ELEMENT_COUNT: (input)  This parameter specifies the number of elements
{       in the list.
{
{ DISPLAY_OPTION: (input) This parameter specifies the type of information to
{      be displayed.
{
{ LC_ELEMENT: (input)  This parameter specifies the pointer to the
{       array that contains all the elements in the active configuration.
{
{ DISPLAY_CONTROL: (input, output)  This parameter describes the output
{       file where the information will be written.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$DISPLAY_TYPE_ELEMENTS EXPAND=FALSE

{ COMMON DECK CMHDTE }

{   The purpose of this request is to display all of a particular type of
{ element from a list of elements to a specific output file.
{
{       CMP$DISPLAY_TYPE_ELEMENTS (ELEMENT_TYPE, DISPLAY_OPTION, ELEMENT_COUNT,
{         LC_ELEMENT, DISPLAY_CONTROL, STATUS)
{
{ ELEMENT_TYPE: (input)  This parameter specifies the type of element to
{       be displayed.
{
{ DISPLAY_OPTION: (input) This parameter specifies the type of information to
{       be displayed.
{
{ ELEMENT_COUNT: (input)  This parameter specifies the number of elements
{       in the list.
{
{ LC_ELEMENT: (input)  This parameter specifies the pointer to the
{       array that contain all the elements in the active configuration.
{
{ DISPLAY_CONTROL: (input, output)  This parameter describes the output
{       file where the information will be written.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$EXECUTE_PP_PROGRAM EXPAND=FALSE
{
{     The purpose of this request is to cause a PP to begin executing a
{ program for the purpose of diagnosing mainframe or peripheral failures.
{ A communication-buffer is also provided to permit the requesting program
{ to interchange data or control information with the PP program.
{     If a system interrupt should occur during the execution of the PP
{ program, the content of the PP's memory and location and contents of the
{ the communication buffer is not recovered nor is this request automatically
{ re-issued.  The recovery and the continuation of PP execution is the
{ responsibility of the program.
{     The execution of the PP program may be terminated by using the
{ cmp$idle_pp request.  If such a request is not issued, then the PP execution
{ is terminated when the task which issues this request is terminated.  In
{ either case, any channel interlock(s) set by this PP are cleared.
{     If a multiple-PP solution is required, this interface may be used
{ to load and execute the same or a different program in each PP.
{
{         CMP$EXECUTE_PP_PROGRAM (PROGRAM_DESCRIPTION, STATUS)
{
{ PROGRAM_DESCRIPTION: (input,output) This parameter specifies the identity of
{ the
{        PP(s) to be initialized, the identity of the program to be loaded in
{        the PP(s) and the peripheral element(s), if any, to be accessed.
{        A PP-interface-table is created for each PP described by this
{        parameter.
{        Up to two PPs may be initialized by this request.  This parameter is
{        specified as an array of 1 or 2 records, each consisting of the
{        following fields:
{
{        The pp_identification field (input) specifies which PP is to be
{        executed.  The PP must previously have been reserved to the requesting
{        job using the cmp$reserve_element request.
{
{        The iou_program_name field (input) specifies the name of the program
{        whose contents is described in the pp_program_field.  This name is
{        provided for presentation in system displays.
{
{        The pp_program field (input) specifies the image of the PP program to
{        be executed in the PP.  A PP program is essentially an array of 16-bit
{        PP-memory  bytes, four per CM word.  The first 16-bit byte (address 0
{        in PP memory) contains the address minus one of the start of the PP
{        program.  The hardware 'jumps' to the contents plus one of PP address
{        0
{        to complete the deadstart process.  Addresses 72(8) and 73(8) of the
{        PP program are reserved by convention for the real-memory address
{        of the PP's PP-interface-table; this interface initializes these two
{        locations in the PP's memory prior to giving control to the PP
{        program.
{        Note that if the PP program is stored in a NOS/VE object library, a
{        pointer to the PP object module may be obtained by using the
{        pmp$open_object_library and pmp$find_module_in_library requests.
{
{        The master_pp field (input) specifies whether or not the PP is to be
{        the "boss" in a multiple-pp implementation of a peripheral device
{        PP program.  If the PP is not the master, i.e. a value of FALSE is
{        specified, bit 31 of the PP's communication-buffer word 1 is set to 1.
{
{        The element_access field (input) specifies the hardware address to
{        each
{        peripheral element to be accessed.  A NIL pointer may be used to
{        specify that no peripheral elements are to be accessed, in this
{        case only a PP-interface-table is created for the PP.
{        If a peripheral element is to be accessed, the complete path to the
{        element, i.e. IOU, channel, channel_address and/or unit_address must
{        be
{        specified.  If a storage device is in the active configuration, only
{        one
{        unit-interface-table will be created for the storage device even
{        though
{        there may be multiple paths to it.  If a storage device is not in the
{        active configuration, this request cannot determine whether two
{        hardware
{        addresses lead to the same storage device or to two different ones;
{        therefore, a unit-interface-table will be built for each hardware
{        address
{        supplied.  A unit-descriptor will be built in the pp-interface-table
{        for
{        each element identified by this field.  All elements identified must
{        have
{        either been previously reserved to the job using the
{        cmp$reserve_element
{        request or have been the object of an msp$request_maintenance_access
{        request.
{
{        The communication_buffer_length (input) field specifies the length of
{        real-memory assigned to the PP-communication-buffer assigned to the
{        PP.
{        The communication buffer is guaranteed to be contiguous in real-memory
{        and therefore is tied to the page-size of the mainframe.
{
{        The communication_buffer (input, output) specifies a pointer variable
{        which is initialized as a result of this request.  The pointer
{        variable
{        is initialized by this request to point to the communication buffer
{        assigned to the PP.  The "limit" value in the ^seq(*) is initialized
{        to the length of the communication buffer allocated.  The
{        communication
{        buffer is assigned to a unique segment which has the property that
{        real-memory assigned to the segment is never paged-out nor is it
{        released when the job is swapped.  This permits the PP to reference
{        the communication buffer at all times.  An attempt to page-fault
{        beyond
{        the length of the assigned communication buffer will cause a segment-
{        access-condition.
{
{        Each PP is provided its own communication-buffer.
{        By convention, the first word of each communication-buffer is
{        initialized as follows:
{                                       3                               6
{        0______________________________1_______________________________3
{        |000000000000000000000000000000S             RMA of PPIT       |
{        ----------------------------------------------------------------
{
{        Where:
{              S=1 if the PP was designated as a slave PP.
{              S=0 if the PP was designated as the master PP.
{
{              RMA of communication buffer is the real memory address of
{                the partner's PP-interface-table.
{
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS:
{                     cme$lcm_element_not_found,
{                     cme$lcm_empty_pa_set,
{                     cme$lcm_missing_pa_set_member,
{                     cme$lcm_not_available,
{                     cme$lcm_ring_validation_error,
{                     cme$privileged_job_required,
{                     cme$too_many_pp_program_desc,
{                     cme$buffer_length_too_large,
{                     cme$page_size_too_small.
{
{         IDENTIFIER : 'CM'
{
*DECK DECK=CMH$FIND_ELEMENT EXPAND=FALSE
*DECK DECK=CMH$GENERATE_INTERFACE_TABLES EXPAND=FALSE

{ COMMON DECK CMHGIT }

{   The purpose of this procedure is to generate the pp and unit interface
{ tables required by the reconfigured system.
{
{       CMP$GENERATE_INTERFACE_TABLES (PHYSICAL_CONF_ARRAY,
{         LOGICAL_CONF_ARRAY, STATUS)
{
{ PHYSICAL_CONF_ARRAY: (input)  This parameter specifies the physical
{       configuration to base the interface tables on.
{
{ LOGICAL_CONF_ARRAY: (input)  This parameter specifies the logical
{       configuration to base the interface tables on.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$GET_CHANNEL_DEFINITION EXPAND=FALSE
{
{
{   The purpose of this request is to provide configuration information about a
{ particular channel.
{
{       CMP$GET_CHANNEL_DEFINITION (CHANNEL_IDENTIFICATION, CHANNEL_DEFINITION,
{         STATUS)
{
{ CHANNEL_IDENTIFICATION: (input)  This parameter specifies the identity of the
{       channel whose configuration information is sought.  Either the name of
{       the channel or the physical address of the channel may be used to
{       identify it.
{
{       If the mainframe has more than one IOU the name of the IOU must be
{       initialized in the field of this parameter because channel numbers are
{       ambiguous in a multi-IOU system.  The IOU component of this parameter
{       will be ignored on single IOU mainframes.
{
{       If you do not use logical identification to identify the channel, then
{       the CONCURRENT field must be initialized to avoid ambiguity; some IOUs
{       have both concurrent (CIO) channels and non-concurrent (NIO) channels
{       with the same number.
{
{ CHANNEL_DEFINITION: (output)  This parameter specifies the configuration of
{       the channel.  If a channel name is specified in the
{       CHANNEL_IDENTIFICATION , then the CHANNEL_DEFINITION will include which
{       channel port was specified, if any; if no port was specified, then
{       cmc$unspecified_port is returned.
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS :  cme$illegal_channel_number
{                       cme$invalid_channnel
{
{         IDENTIFIER : 'CM'
{
{
*DECK DECK=CMH$GET_CONF_FILE EXPAND=TRUE
*DECK DECK=CMH$GET_CONTROLLER_TYPE EXPAND=FALSE

{ COMMON DECK CMHGCT }

{   The purpose of this request is to determine the controller type given
{ the product identification string of the controller.
{
{       CMP$GET_CONTROLLER_TYPE (PID, CONTROLLER_TYPE, STATUS)
{
{ PID: (input)  This parameter specifies the product id string to be used
{       to determine the controller type.
{
{ CONTROLLER_TYPE: (output)  This parameter specifies the controller type.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$GET_CONTROLLER_TYPE_R3 EXPAND=FALSE

{   The purpose of this request is to get the controller type associated with
{ a particular product identifier.  This request is the same as cmp$get_
{ controller_type, except that this request can run in any ring.
{
{       CMP$GET_CONTROLLER_TYPE_R3 (PID, CONTROLLER_TYPE, STATUS)
{
{ PID: (input)  This parameter specifies the product identifier.
{
{ CONTROLLER_TYPE: (output)  This parameter specifies the controller type.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$GET_CPU_ELEMENT_R1 EXPAND=FALSE
{
{   The purpose of this request is to return the processor element information
{ associated with a processor id number.
{
{       CMP$GET_CPU_ELEMENT_R1 (PROCESSOR_ID, CPU_ELEMENT, STATUS)
{
{ PROCESSOR_ID: (input)  This parameter specifies the number of the processor
{                        about which the information should be obtained.  The id
{                        specifies the logical element number of the CPU as it
{                        relates to the CPU state table.
{
{ UPDATE_CST: (input)    This parameter determines whether the CPU state table
{                        for the specified processor_id should be updated to
{                        reflect the data currently found in the MRT.  The CST
{                        information will be updated when displaying the status
{                        of the processors or when processing the front end of
{                        a operator-initiated CPU state change.  The information
{                        will NOT be updated in the back end of a CPU state
{                        change since the CST already accurately reflects the
{                        true state of the CPU as processed in the monitor mode
{                        state change procedure.
{
{ CPU_ELEMENT: (output)  This parameter specifies the cpu element information
{                        associated with the processor id number.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$GET_CPU_ELEMENT_R3 EXPAND=FALSE
{
{   The purpose of this request is to provide the interface to the Ring 1
{ procedure which obtains information about individual central processing units.
{
{       CMP$GET_CPU_ELEMENT_R3 (
{         PROCESSOR_ID,
{         CPU_ELEMENT,
{         STATUS)
{
{ PROCESSOR_ID: (input)  This parameter specifies the number of the processor
{                        about which the information should be obtained.  The id
{                        specifies the logical element number of the CPU as it
{                        relates to the CPU state table.
{
{ CPU_ELEMENT: (output)  This parameter specifies the cpu element information
{                        associated with the processor id number.
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS:
{               none
{
*DECK DECK=CMH$GET_DEVICE_FILE EXPAND=FALSE

{ COMMON DECK CMHGDF }

{   The purpose of this request is to retrieve a named device file from
{ the system device and to copy it into a segment access bam file.  If
{ the named device file does not exist on the system device, an error
{ status is returned.
{
{       CMP$GET_DEVICE_FILE (DEVICE_FILE_NAME, SEGMENT_FILE_FID, STATUS)
{
{ DEVICE_FILE_NAME: (input)  This parameter specifies the name of the device
{       file to be retrieved.
{
{ SEGMENT_FILE_FID: (input)  This parameter specifies the segment access file
{       identifier of the file to receive the data in the device file.  The
{       file is treated as a sequence.
{
{ STATUS: (output)  This parameter sepecifies the request status.
{
*DECK DECK=CMH$GET_ELEMENT_DEFINITION EXPAND=FALSE
{
{   The purpose of this request is to provide the definition of a peripheral
{ element of the mainframe's active configuration.  A peripheral element is one
{ of the following types of elements:  channel adapter, communications element,
{ controller, storage device, or external processor.
{
{   The information provided describes the element and its connectivity to
{ other elements within the active configuration.  The information is derived
{ from the active physical configuration which has been installed in the
{ mainframe on which this request is issued.
{
{   For example, if the element were a tape controller, this request would
{ describe the identification of each channel (channel name, mainframe and IOU)
{ connected to the controller plus the names of tape storage device(s)
{ connected to the controller.
{
{   To use this request it is necessary to initialize the element_type field of
{ the element descriptor to one of the values identified in the case of the
{ peripheral_descriptor; however, it is not required that you know exactly
{ which type of peripheral you are querying.  The actual element_type is
{ returned in the DEFINITION parameter.
{
{       CMP$GET_ELEMENT_DEFINITION (ELEMENT, DEFINITION, STATUS)
{
{ ELEMENT: (input)  This parameter specifies the identity of the peripheral
{       element whose definition is desired.  The identity may be specified
{       using either the name of the element or its hardware address.
{
{       If a hardware address is specified you must initialize the
{       physical_address_specifier to indicate how many parts of the address
{       are initialized in the address path.  For example, if you are querying
{       a unit, the physical_address_specifier must include a channel, a
{       channel_address and the unit_address and you must initialize all three
{       fields of the hardware address.
{
{       If a hardware address is specified and the mainframe has more than one
{       IOU, the name of the IOU must be initialized because the channel
{       identification is ambiguous in this case.  The IOU component of the
{       peripheral descriptor will be ignored on single IOU mainframes.
{
{ DEFINITION: (output)  This parameter describes the element and its connect-
{       ivity with other elements in the mainframe's active configuration.
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS:
{                     cme$lcm_element_not_found,
{                     cme$lcm_empty_pa_set,
{                     cme$lcm_missing_pa_set_member,
{                     cme$lcm_not_available,
{                     cme$lcm_ring_validation_error,
{                     cme$privileged_job_required.
{
{         IDENTIFIER : 'CM'
{
*DECK DECK=CMH$GET_ELEMENT_INFORMATION EXPAND=FALSE
{
{   The purpose of this request is to provide configuration information about a
{ peripheral element of the mainframe's active configuration.  A peripheral
{ element is one of the following types of elements:  channel adapter,
{ communications element, controller, storage device, or external processor.
{
{   For example the state of the element, its product identification, serial
{ number, etc.  can be obtained; however, not all items of information are
{ available for all peripheral elements, since some of the information is
{ device specific.
{
{   To use this request it is necessary to initialize the element_type field of
{ the element descriptor to one of the values identified in the case of the
{ peripheral_descriptor; however, it is not required that you know exactly
{ which type of peripheral you are querying.  The intent of this request is to
{ query about a peripheral without having to know anything except its name.
{
{       CMP$GET_ELEMENT_INFORMATION (ELEMENT, INFORMATION, STATUS)
{
{ ELEMENT: (input)  This parameter specifies the identity of the system element
{       for which information is desired.  The identity may be specified using
{       either the name of the element or its hardware address.
{
{       If a hardware address is specified you must initialize the
{       physical_address_specifier to indicate how many parts of the address
{       are initialized in the address path.  For example, if you are querying
{       a unit, the physical_address_specifier must include a channel, a
{       channel_address and the unit_address and you must initialize all three
{       fields of the hardware address.
{
{       If a hardware address is specified and the mainframe has more than one
{       IOU, the name of the IOU must be initialized because the channel
{       identification is ambiguous in this case.  The IOU component of the
{       peripheral descriptor will be ignored on single IOU mainframes.
{
{ INFORMATION: (output)  This parameter specifies the requested information
{       about the system element.
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS:
{                     cme$lcm_element_not_found,
{                     cme$lcm_empty_pa_set,
{                     cme$lcm_missing_pa_set_member,
{                     cme$lcm_not_available,
{                     cme$lcm_ring_validation_error,
{                     cme$privileged_job_required.
{
{         IDENTIFIER : 'CM'
{
{
{
*DECK DECK=CMH$GET_ELEMENT_NAME EXPAND=FALSE
{
{   The purpose of this request is to provide the name of an element in the
{ active configuration given an alternate form of identification.
{
{   One may refer to an element using its hardware address, its hardware
{ identification (product identification plus serial number), or a combination
{ of hardware address and hardware identification.  The latter means of
{ reference is necessary when multiple elements share the same hardware
{ identification but have unique hardware addresses.  If a product does consist
{ of multiple addressable elements and one specifies only the product
{ identification and serial number, a cme$ambiguous_product_id abnormal status
{ is returned; one must then qualify the product identification with a hardware
{ address to resolve the ambiguity.
{
{       CMP$GET_ELEMENT_NAME (PHYSICAL_IDENTIFICATION, ELEMENT, STATUS)
{
{ PHYSICAL_IDENTIFICATION: (input)  This parameter specifies a hardware
{       identification of the element whose name is desired.  If a null string
{       ('') is supplied for the product_number component of the product
{       identification then this request will assume that the product
{       identification and serial number have not been supplied and that only
{       the hardware address will be used to find the element name.  If a null
{       physical_address_specifier set is specified, then the system will
{       assume that only the product identification and serial number will be
{       used to find the element name.
{
{       If a hardware address is specified and the mainframe has more than one
{       IOU, the name of the IOU must be initialized because the channel
{       identification is ambiguous in this case.  The IOU component of the
{       peripheral descriptor will be ignored on single IOU mainframes.
{
{       If a hardware address is supplied, the physical_address_specifier
{       indicates which components of a peripheral hardware address are to be
{       used to find the element name.  The physical address may consist of:
{
{        1.  channel (the name of a channel is returned)
{
{        2.  (channel, channel_address) - the name of a channel adapter,
{            communications element, controller, external processor or storage
{            device is returned.
{
{        3.  (channel, channel_address, unit_address) - the name of a storage
{            device is returned.
{
{ ELEMENT: (output)  This parameter specifies the identity of the system
{       element for which information is desired.
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS :
{                      cme$lcm_ambiguous_product_id,
{                      cme$lcm_element_name_not_found,
{                      cme$lcm_empty_lc,
{                      cme$lcm_empty_pa_set,
{                      cme$lcm_missing_pa_set_member,
{                      cme$lcm_not_available,
{                      cme$lcm_ring_validation_error,
{                      cme$privileged_job_required.
{
{         IDENTIFIER : 'CM'
{
*DECK DECK=CMH$GET_ELEMENT_NAMES EXPAND=FALSE
{
{   The purpose of this request is to return an array of peripheral element
{ names in the active configuration which match a specific criterion.  The
{ CMP$GET_NUMBER_OF_ELEMENTS request may be used prior to calling this
{ interface to determine the dimension of the ELEMENTS array.
{
{       CMP$GET_ELEMENT_NAMES (SELECTOR, ELEMENTS, STATUS)
{
{ SELECTOR: (input)  This parameter specifies the criterion used in searching
{       the active configuration.  One of the following criteria may be chosen:
{
{          1.  Select by type of element (cmc$select_by_type)
{
{              The following types of elements are supported:
{
{              cmc$channel_adapter_element
{
{              cmc$communications_element
{
{              cmc$controller_element
{
{              cmc$external_processor_element
{
{              cmc$storage_device_element
{
{          2.  Select by product identification.
{
{              Two options are available in searching by product
{              identification.  The product_id field is composed of two
{              sub-fields:  product_number and model_number.  If model_number
{              is a null string ('') then the names of all elements matching
{              the product_number are returned; otherwise the names of all
{              elements matching the product_number AND the model_number are
{              returned.
{
{              For example, the 7155-1x has five models:  $7155_1, $7155_11,
{              $7155_12, $7155_13, $7155_14.  Let us assume there is one of
{              each of these models in the active configuration.  If
{              model_number is a null string, then the names of 5 elements are
{              returned.  If model_number is '13', then one element name is
{              returned.  In both cases the product_number is ' $7155'.
{
{          3.  Select by device class.  The following device classes are
{              supported:
{
{              rmc$magnetic_tape_device - returns the names of magnetic tape
{              controllers and storage devices
{
{              rmc$mass_storage_device - returns the names of mass storage
{              controllers and storage devices
{
{              rmc$network_device - refer to the documentation of the
{              $peripheral_element_names LCU subcommand.
{
{              rmc$rhfam_device - refer to the documentation of the
{              $peripheral_element_names LCU subcommand.
{
{          4.  Return the names of ALL peripheral elements in the active
{              configuration.
{
{ ELEMENTS:  (input, ouput) This parameter specifies the list of element names
{       that meet the specified criterion.  This parameter is a pointer to an
{       adaptable array, therefore the user of this interface must allocate
{       enough entries before making the request.
{
{ STATUS: (output)  This parameter specifies the request status.
{
{   CONDITIONS:
{
{
{   IDENTIFIER:  'CM'
{
{
*DECK DECK=CMH$GET_ELEMENT_NAME_VIA_LUN EXPAND=FALSE

{ COMMON DECK CMHGELN }

{   The purpose of this request is to return an element name that is associated
{ with the logical unit number specified from the installed logical
{ configuration.
{
{       CMP$GET_ELEMENT_NAME (LOGICAL_UNIT_NUMBER, ELEMENT_NAME, STATUS)
{
{ LOGICAL_UNIT_NUMBER: (input)  This parameter specifies the logical unit number
{       of the element that we wish to access.
{
{ ELEMENT_NAME: (output)  This parameter specifies the name associated with
{       the logical unit number above.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$GET_ELEMENT_R3 EXPAND=FALSE

{   The purpose of this request is to get the mainframe element associated
{ with an element name.  This request is the same as cmp$get_mainframe_element
{ except that this request can run in any ring.
{
{       CMP$GET_ELEMENT_R3 (ELEMENT_NAME, MAINFRAME_ELEMENT, STATUS)
{
{ ELEMENT_NAME: (input)  This parameter specifies the element name.
{
{ MAINFRAME_ELEMENT: (output)  This parameter specifies the mainframe element.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$GET_IOU_DEFINITION EXPAND=FALSE
{
{   The purpose of this request is to provide configuration information about a
{ particular IOU.
{
{       CMP$GET_IOU_DEFINITION (IOU, IOU_DEFINITION, STATUS)
{
{
{ IOU: (input)  This parameter specifies the name of the IOU whose
{       configuration information is sought.  The name of the IOU must be of
{       the form IOUn, where n is the iou number.
{
{ IOU_DEFINITION: (output)  This parameter specifies the configuration of the
{       IOU.
{
{ STATUS: (output)  This parameter specifies the request status.
{
{   CONDITIONS :  cme$invalid_iou_name
{
{   IDENTIFIER :  'CM'
{
*DECK DECK=CMH$GET_IO_COMPLETION_TBL_ENTRY EXPAND=FALSE
{
{    This request is used to retrieve the address of an io completion table
{  entry.
{
{          CMP$GET_IO_COMPLETION_TBL_ENTRY (IO_COMPLETION_QUEUE_INDEX,
{                             IO_COMPLETION_TABLE_ENTRY_P)
{
{  IO_COMPLETION_QUEUE_INDEX: (input)  This parameter specifies the index of
{                                      the entry to retrieve.
{
{  IO_COMPLETION_TABLE_ENTRY_P: (output)  This parameter returns the address
{                                         of the associated io completion table
{                                         entry.
{
*DECK DECK=CMH$GET_LOGICAL_ATTRIBUTES EXPAND=FALSE

{   The purpose of this request is to allow users running in a ring higher
{ than 3 to access dmp$get_logical_attributes.
{
{       CMP$GET_LOGICAL_ATTRIBUTES (PRODUCT_IDENTIFICATION,
{         P_LOGICAL_ATTRIBUTES, STATUS)
{
{ PRODUCT_IDENTIFICATION: (input)  This parameter specifies the product
{       identifier of the unit whose attributes you are getting.
{
{ P_LOGICAL_ATTRIBUTES: (input, output)  This parameter specifies the
{       pointer to an adaptable array of logical device attributes
{       which contain keys to indicate which attributes are desired,
{       and room for the actual attributes.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$GET_LOGICAL_PP_NUMBER EXPAND=FALSE
*DECK DECK=CMH$GET_LOGICAL_UNIT_NUMBER EXPAND=FALSE

{ COMMON DECK CMHGLUN }

{   The purpose of this request is to retrieve the logical unit number
{ associated with a given element name from the installed logical
{ configuration.
{
{       CMP$GET_LOGICAL_UNIT_NUMBER (ELEMENT_NAME, LOGICAL_UNIT_NUMBER,
{         STATUS)
{
{ ELEMENT_NAME: (input)  This parameter specifies the name of the element
{       we wish to access.
{
{ LOGICAL_UNIT_NUMBER: (output)  This parameter specifies the logical unit
{       number associated with the name above.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$GET_LOGICAL_UNIT_NUMBER_R3 EXPAND=FALSE

{   The purpose of this request is to return the logical unit number
{ associated with an element name.
{
{       CMP$GET_LOGICAL_UNIT_NUMBER_R3 (ELEMENT_NAME, LOGICAL_UNIT_NUMBER,
{         STATUS)
{
{ ELEMENT_NAME: (input)  This parameter specifies the element name.
{
{ LOGICAL_UNIT_NUMBER: (output)  This parameter specifies the logical unit
{       number.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$GET_MAINFRAME_ELEMENT EXPAND=FALSE

{ COMMON DECK CMHGME }

{   The purpose of this request is to return the mainframe element specified
{ by a logical unit number.
{
{       CMP$GET_MAINFRAME_ELEMENT (ELEMENT_NAME, IOU_NAME, MAINFRAME_ELEMENT,
{         STATUS)
{
{ ELEMENT_NAME: (input)  This parameter specifies the name of the mainframe
{       element to be returned.
{
{ IOU_NAME: (input) This parameter specifies the iou name connected to the
{       mainframe element.
{
{
{ MAINFRAME_ELEMENT: (output)  This parameter specifies the mainframe
{       element indicated by the logical unit number.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$GET_MS_LOGICAL_UNIT_NUMBERS EXPAND=FALSE

{ COMMON DECK CMHGMSU }

{   The purpose of this procedure is to return a list of logical unit numbers
{ and corresponding product identifications of all mass storage units that are
{ logically configured and accessable to NOS/VE.
{
{       CMP$GET_MS_LOGICAL_UNIT_NUMBERS (MS_LOGICAL_UNIT_LIST, LIST_COUNT, STATUS)
{
{ MS_LOGICAL_UNIT_LIST: (output)  This stucture contains the logical unit numbers
{       and associated product ids.
{
{ LIST_COUNT: (output)  This parameter specifies the number of mass storage units
{       that are logically configured and accessable to NOS/VE.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$GET_NUMBER_OF_ELEMENTS EXPAND=FALSE
{
{   The purpose of this request is to return the number of elements present in
{ the configuration which satisfy a particular criterion.  This request is
{ usually made prior to calling CMP$GET_ELEMENT_NAMES to determine the
{ dimension of the array used in that interface.  Refer to
{ CMP$GET_ELEMENT_NAMES for documentation of the selection criteria.
{
{       CMP$GET_NUMBER_OF_ELEMENTS (SELECTOR, NUMBER_OF_ELEMENTS, STATUS)
{
{ SELECTOR: (input)  This parameter specifies which criterion to use in
{       searching the active configuration.  Refer to the documentation of
{       CMP$GET_ELEMENT_NAMES.
{
{ NUMBER_OF_ELEMENTS: (output)  This parameter specifies the number of elements
{       that meet the specified criterion.
{
{ STATUS: (output)  This parameter specifies the request status.
{
{   CONDITIONS :
{
{
{   IDENTIFIER :  'CM'
{
{
*DECK DECK=CMH$GET_NUMBER_OF_IO_ENTRIES EXPAND=FALSE
{
{    This request is used to obtain the number of entries in the
{  subsystem io completion table.
{
{          CMP$GET_NUMBER_OF_IO_ENTRIES (NUMBER_OF_ENTRIES)
{
{  NUMBER_OF_ENTRIES: (output)  This parameter is used to return the number
{                               of entries in the table.
{
*DECK DECK=CMH$GET_PHYSICAL_ATTRIBUTES EXPAND=FALSE

{   The purpose of this request is to allow users running in a ring higher
{ than 3 to access dmp$get_physical_attributes.
{
{       CMP$GET_PHYSICAL_ATTRIBUTES (PRODUCT_IDENTIFICATION,
{         P_PHYSICAL_ATTRIBUTES, STATUS)
{
{ PRODUCT_IDENTIFICATION: (input)  This parameter specifies the product
{       identifier of the unit whose attributes you are getting.
{
{ P_PHYSICAL_ATTRIBUTES: (input, output)  This parameter specifies the
{       pointer to an adaptable array of physical device attributes
{       which contain keys to indicate which attributes are desired,
{       and room for the actual attributes.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$GET_PHYSICAL_CONF_TABLE EXPAND=FALSE

{ COMMON DECK CMHGPCT }

{   The pupose of this request is to return a copy of the physical configuration
{ table for the active system.
{
{       CMP$GET_PHYSICAL_CONF_TABLE (SEQUENCE, STATUS)
{
{ SEQUENCE: (input, output)  This parameter specifies the pointer to sequence
{       which will hold the physical configuration table.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$GET_PP_DEFINITION EXPAND=FALSE
{
{   The purpose of this request is to provide configuration information about a
{ particular PP.
{
{       CMP$GET_PP_DEFINITION (PP_IDENTIFICATION, PP_DEFINITION, STATUS)
{
{ PP_IDENTIFICATION: (input)  This parameter specifies the identity of the PP
{       whose configuration information is sought.  Either the name of the PP
{       or the physical address of the PP may be used to identify it.
{
{       If the mainframe has more than one IOU the name of the IOU must be
{       initialized in the field of this parameter because PP numbers are
{       ambiguous in a multi-IOU system.  The IOU component of this parameter
{       will be ignored on single IOU mainframes.
{
{       If you do not use logical identification to identify the PP, then the
{       CONCURRENT field must be initialized to avoid ambiguity; some IOUs have
{       both concurrent (CIO) PPs and non-concurrent (NIO) PPs with the same
{       number.
{
{ PP_DEFINITION: (output)  This parameter specifies the configuration of the
{       PP.
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS :   cme$invalid_pp_name
{                        cme$invalid_pp_number
{
{         IDENTIFIER : 'CM'
{
{
*DECK DECK=CMH$GET_PP_REGISTERS EXPAND=FALSE
{
{   The purpose of this request is to obtain the contents of a PP's A, K, P,
{ and Q registers.  The PP must previously been reserved to the requesting
{ job.  The accuracy of the result of this request is IOU design dependent
{ unless the PP is in a one instruction loop or is hung on a data transfer
{ between itself and Central Memory or a data channel.  Because of hardware
{ limitations described above, the use of this interface is limited to aiding
{ the determination if a PP is hung.  One would have to sample the PP's P
{ register several times to see if the value is changing; however, this is not
{ conclusive.  Refer to the CMP$IDLE_PP request if more precision is required.
{
{       CMP$GET_PP_REGISTERS (PP_IDENTIFICATION, REGISTERS, STATUS)
{
{ PP_IDENTIFICATION: (input)  This parameter specifies the identity of the PP
{       whose registers are desired.
{
{ REGISTERS: (output)  This parameter specifies the content of the PP's
{       registers.  The value of each register is stored right-justified with
{       zero fill in the corresponding component of this parameter.  If the PP
{       is in a hardware-idled state, the K register will contain the value
{       107700(8).
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS:
{                     cme$element_not_reserved,
{                     cme$lcm_not_available,
{                     cme$lcm_ring_validation_error,
{                     cme$privileged_job_required.
{
{         IDENTIFIER : 'CM'
{
{
*DECK DECK=CMH$GET_SSIOT_ENTRY_AVAIL_QUEUE EXPAND=FALSE
{
{     This request is used to get a job io completion table entry from
{  the job io completion table.
{
{         CMP$GET_SSIOT_ENTRY_AVAIL_QUEUE (JOB_IO_COMPLETION_QUEUE_INDEX)
{
{  JOB_IO_COMPLETION_QUEUE_INDEX: (output)  This parameter specifies the
{                          index of the entry reserved.
{
*DECK DECK=CMH$GET_SUBSYS_EQUIPMENT_DESC EXPAND=FALSE
{
{     This request is used to obtain the physical equipment description
{  for a unit associated with a specifed PP.
{
{          CMP$GET_SUBSYS_EQUIPMENT_DESC (PP_NUMBER, LOGICAL_UNIT,
{                  EQUIPMENT_DESCRIPTION, STATUS)
{
{  PP_NUMBER: (input)  This parameter specifies the logical PP associated
{                      with the logical unit.
{
{  LOGICAL_UNIT: (input)  This parameter specifies the logical unit number
{                         of the element whose physical equipment description
{                         will be returned.
{
{  EQUIPMENT_DESCRIPTION: (output) This parameter is used to return the physical
{                                 description of the logical unit.
{
{  STATUS: (output)  This parameter retruns the request status.
{
*DECK DECK=CMH$GET_SUBSYS_EQUIP_DESC_R1 EXPAND=FALSE
{
{     This request is used to obtain the physical equipment description
{  for a unit associated with a specifed PP.
{
{          CMP$GET_SUBSYS_EQUIP_DESC_R1 (PP_NUMBER, LOGICAL_UNIT,
{                  EQUIPMENT_DESCRIPTION, STATUS)
{
{  PP_NUMBER: (input)  This parameter specifies the logical PP associated
{                      with the logical unit.
{
{  LOGICAL_UNIT: (input)  This parameter specifies the logical unit number
{                         of the element whose physical equipment description
{                         will be returned.
{
{  EQUIPMENT_DESCRIPTION: (output) This parameter is used to return the physical
{                                 description of the logical unit.
{
{  STATUS: (output)  This parameter retruns the request status.
{
*DECK DECK=CMH$GET_SYS_DEV_REC_VSN EXPAND=FALSE

{   The purpose of this request is to externalize the system device recorded
{ vsn to users running is a ring higher than 3.
{
{       CMP$GET_SYS_DEV_REC_VSN (RECORDED_VSN, STATUS)
{
{ RECORDED_VSN: (output)  This parameter specifies the recorded vsn.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$GET_UNIT_NUMBER_VIA_VSN EXPAND=FALSE

{ COMMON DECK CMHGUNV }

{   The purpose of the request is to retrieve the logical unit number
{ associated with the given recorded vsn from a ring one device
{ management procedure.
{
{       CMP$GET_UNIT_NUMBER_VIA_VSN (RECORDED_VSN, LOGICAL_UNIT_NUMBER,
{         STATUS)
{
{ RECORDED_VSN: (input)  This parameter specifies the recorded vsn to
{       key the search for the logical unit number.
{
{ LOGICAL_UNIT_NUMBER: (output)  This parameter specifies the varable
{       to receive the logical unit number.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$GET_UNIT_TYPE EXPAND=FALSE

{ COMMON DECK CMHGUT }

{   The purpose of this request is to return the cm unit type, the io
{ unit type, and the unit class based on a product identifier.  If no
{ unit matches the product identifier, a flag is returned indicating so.
{
{       CMP$GET_UNIT_TYPE (PRODUCT_ID, CM_UNIT_TYPE, IO_UNIT_TYPE,
{         UNIT_CLASS, FOUND)
{
{ PRODUCT_ID: (input)  This parameter specifies the product identification
{       code of the unit.
{
{ CM_UNIT_TYPE: (output)  This parameter specifies the configuration
{       management unit type.
{
{ IO_UNIT_TYPE: (output)  This parameter specifies the I/O unit type.
{
{ UNIT_CLASS: (output)  This parameter specifies the classification of
{       the unit.
{
{ FOUND: (output)  This parameter specifies if the product identification
{       code was found.
{
*DECK DECK=CMH$IDLE_PP EXPAND=FALSE
{
{   The purpose of this request is to idle a PP logically or physically.
{ Logically idling the PP is referred to as a "software_idle".  Physically
{ idling a PP is referred to as a "hardware-idle".  Optionally, a dump of the
{ PP's memory may be obtained.
{
{   The system will first attempt to logically idle the PP by giving it an
{ "idle-pp" request on its "PP-queue".  The system will wait for up to two (2)
{ seconds for a response to this request.  If a response is returned or the
{ two seconds have elapsed, the PP will be hardware-idled, if requested.
{
{   If HARDWARE_IDLE_PP is FALSE and the PP has its "PP-queue" interlocked,
{ then this request will return abnormal status.  However, if HARDWARE_IDLE_PP
{ is TRUE, then the PP will be hardware-idled regardless of the state of the
{ "PP-queue" interlock.
{
{       CMP$IDLE_PP (PP_IDENTIFICATION, BREAK_INTERLOCKS, HARDWARE_IDLE_PP,
{         PP_MEMORY_AREA, ACTUAL_PP_MEMORY_SIZE, PP_REGISTERS,
{         PP_SOFTWARE_IDLED, STATUS)
{
{ PP_IDENTIFICATION: (input)  This parameter specifies the identity of the PP
{       to be initialized.  The PP must previously have been reserved to the
{       requesting job using the cmp$reserve_element request.
{
{ BREAK_INTERLOCKS: (input)  This parameter specifies whether or not software
{       interlocks obtained by the PP, which have not been cleared by the PP
{       as a result of its processing of the software-idle, are to be cleared
{       by the system.
{
{ HARDWARE_IDLE_PP: (input)  This parameter specifies whether or not to
{       terminate the execution of the PP under hardware control.  If TRUE is
{       specified, the PP will first be software-idled, the current
{       instruction will be exited and an optional dump of the PP's memory is
{       taken.  If FALSE is specified, the PP will only be software-idled, if
{       possible; otherwise the state of the PP is unaltered by this request.
{       If FALSE is specified, a dump of PP memory is precluded.
{
{ PP_MEMORY_AREA: (input)  This parameter specifies the area into which the
{       image of the PP memory will be written by this request.  A dump of PP
{       memory will be returned to this area only if TRUE was specified for
{       the HARDWARE_IDLE_PP parameter and normal status is returned by the
{       request.  Abnormal status will be returned if this parameter is
{       non-NIL and FALSE is specified for HARDWARE_IDLE_PP.  If the size of
{       the area provided is less than the size of memory in the PP, a
{       fractional dump of the PP's memory will be provided.  If the size of
{       the area provided is greater than the size of memory in the PP, a
{       complete dump of the PP's memory will be provided and the parameter
{       actual_pp_memory_size specifies the amount of valid data in the area.
{
{ ACTUAL_PP_MEMORY_SIZE: (output)  This parameter specifies the size of the
{       memory of the specified PP.
{
{ PP_REGISTERS: (output)  This parameter specifies the content of the PP's
{       registers.  Although PP register contents are always returned by a
{       normal completion of this request, the accuracy of the register
{       information is not guaranteed unless TRUE was specified for the
{       HARDWARE_IDLE_PP parameter.  The value of each register is stored
{       right-justified with zero fill in the corresponding component of this
{       parameter.  If the PP is in a hardware-idled state, the K register
{       will contain the value 107700(8).
{
{ PP_SOFTWARE_IDLED: (output)  This parameter specifies whether or not the PP
{       responded to the software-idle within the time period allotted for the
{       response.
{
{ STATUS: (output)  This parameter specifies the request
{       status.
{
{         CONDITIONS:
{                    cme$dump_requires_hardware_idle,
{                    cme$element_not_reserved,
{                    cme$lcm_ring_validation_error,
{                    cme$pp_already_idled,
{                    cme$pp_holds_pp_queue_lock,
{                    cme$privileged_job_required.
{
{   IDENTIFIER :  'CM'
{
*DECK DECK=CMH$ILLEGAL_UNIT_NUMBER EXPAND=FALSE

{   The purpose of this request is to initialize a status variable for an
{ illegal unit number.
{
{       CMP$ILLEGAL_UNIT_NUMBER (ILLEGAL_UNIT_NUMBER, CONDITION, STATUS)
{
{ ILLEGAL_UNIT_NUMBER: (input)  This parameter specifies the illegal unit
{       number.
{
{ CONDITION: (input)  This parameter specifies the status condition code.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$INITIALIZE_ADTT EXPAND=FALSE

{ COMMON DECK CMHINAD }

{   The purpose of this request is to initialize the active driver type
{ table to correspond to entries in the logical configuration.  The
{ system device driver is a special case as it must occupy the first
{ entry in its driver type table.  The rest are ordered arbitrarily.
{
{       CMP$INITIALIZE_ADTT (SYS_DEV_CHANNEL_NUMBER, SYS_DEV_EQUIPMENT_NUMBER,
{         LOGICAL_PP_NUMBER, STATUS)
{
{ SYS_DEV_CHANNEL_NUMBER: (input)  This parameter specifies the channel number
{       used to access the system device.
{
{ SYS_DEV_EQUIPMENT_NUMBER: (input)  This parameter specifies the equipment
{       number used to access the system device.
{
{ LOGICAL_PP_NUMBER: (input)  This parameter specifies the logical pp table
{       that contains pointers to the interface tables referenced when the
{       adtt in initialized.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$INITIALIZE_DFT EXPAND=TRUE
*DECK DECK=CMH$INITIALIZE_MS_VOLUME EXPAND=FALSE

{ COMMON DECK CMHIMSV }

{   The purpose of this request is to allow user access to the device
{ management routine dmp$initialize_ms_volume.
{
{       CMP$INITIALIZE_MS_VOLUME (ACCESS_CODE, OWNER_ID,
{         P_PHYSICAL_ATTRIBUTES, P_LOGICAL_ATTRIBUTES,
{         P_VOLUME_LABEL_ATTRIBUTES, LOGICAL_UNIT_SPECIFICATION,
{         ALLOWED_TO_OVERWRITE_VOLUME, STATUS)
{
{ ACCESS_CODE: (input)  This parameter specifies the access_code.
{
{ OWNER_ID: (input)  This parameter specifies the owner_id.
{
{ P_PHYSICAL_ATTRIBUTES: (input)  This parameter specifies the physical
{       attributes of the volume to be initialized.
{
{ P_LOGICAL_ATTRIBUTES: (input)  This parameter specifies the logical
{       attributes of the volume to be initialized.
{
{ P_VOLUME_LABEL_ATTRIBUTES: (input)  This parameter specifies the volume
{       label attributes of the volume to be initialized.
{
{ LOGICAL_UNIT_DESCRIPTION: (input)  This parameter specifies the logical
{       unit description of the unit.
{
{ ALLOWED_TO_OVERWRITE: (input)  This parameter specifies whether the
{       procedure should overwrite the volume.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$INITIATED_JOB_STATUS EXPAND=FALSE
{
{    This request is used to determine whether or not an initiated job is still
{  known to the system.  This request should be used by application subsystems
{  to determine if users of the application have been recovered after a failure
{  of the operating system or a failure of the application subsystem.
{
{          CMP$INITIATED_JOB_STATUS (JOB_NAME, JOB_EXECUTING)
{
{  JOB_NAME: (input)  This parameter specifies the job name of the initiated job.
{
{  JOB_EXECUTING: (output)  This parameter returns a boolean indicating whether
{                           or not the job is still executing.
{
*DECK DECK=CMH$INSTALL_CONF_FILE EXPAND=TRUE
*DECK DECK=CMH$LOCK_LUN_ENTRY EXPAND=FALSE
{ }
{     The purpose of this request is to lock a logical unit table }
{ entry for exclusive access.  This is a ring 1 interface. }
{ }
{       CMP$LOCK_LUN_ENTRY (LOGICAL_UNIT, LUN_LOCK_OBTAINED) }
{ }
{ LOGICAL_UNIT: (input)  This parameter specifies the logical unit }
{       of the entry to be locked. }
{ }
{ LUN_LOCK_OBTAINED: (output)  This parameter specifies whether the }
{       lock was obtained. }
{ }
*DECK DECK=CMH$LSP_FAILURE_DATA_DOC EXPAND=FALSE
{
{ DECK: CMH$LSP_FAILURE_DATA_DOC
{ PURPOSE:
{    The purpose of this statistic is to record the failure data captured
{    by the system when accessing a STORNET/ESM memory device.
{    The File Server's PP reports initial failure data after the request
{    retry count has been exhausted. This log-entry provides the initial
{    and final failure data for the I/O failure.
{
{ FREQUENCY: At each failure occurrence.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<ch>.<element>.<class>.<message>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where  <pp>  is the string 'PPn' where n is the PP number (in
{        decimal) of the PP which performed the i/o operation  which
{        is being reported.
{
{      where <ch> is the string 'CHn' where n is the channel number
{        number (in decimal) over which the i/o request was processed.
{
{      where  <element> is the element_name assigned to the STORNET
{        device via the PCU command DEFINE_ELEMENT.
{
{      where <class> is the string 'UF' when error is unrecovered and
{        'RF' when error is recovered.
{
{      where  <message>  is a statement describing the type of error
{        encountered. The failure message corresponds to the integer
{        in counter 8 of the statistics counter field.
{
{
{    The  counter-value portion of this statistic contains:
{
{    1.  Logical PP number (bits 58 - 63).
{        Bits 46 - 51 contain the IOU number.
{
{    2.  Channel Number (bits 58 - 63).
{        Bits 46 - 51 contain the IOU number.
{
{    3.  Always zero.
{    4.  Always zero.
{    5.  Unit-type
{           0 = ESM II
{           1 = STORNET
{    6.  Logical Operation Code (always 1)
{        1 - read
{        2 - write
{    7.  Log-entry Class
{        0 - Recovered Failure Report
{        1 - Unrecovered Failure Report
{    8.  Failure Analysis Code
{        Indicates the extent to which the subsystem and the PP were
{        able to isolate  the  failure when it was detected. The code
{        corresponds to the number preceding the failure messages.
{    9.  Request Retry Count
{        The number of times the PP retried the operation.
{   10.  First Word Address of the ESM/Stornet Buffer.
{   11.  Number of bytes to be transferred between ESM/Stornet and CM
{   12.  unused
{   13.  Last function issued on channel (bits 48 - 63).
{   14.  Residual byte count after executing block I/O instruction.
{   15.  ESM/Stornet Low Speed Port status after failure.
{
{        STATUS BIT   HEXIDECIMAL
{       (right most)  POSITION                ASSIGNMENT
{       ------------  -----------    ----------------------------
{           63          xxx1          Abort.
{           62          xxx2          Accept.
{           61          xxx4          Double bit error.
{           60          xxx8          Write operation in progress.
{           59          xx1x          Channel parity error.
{           58          xx2x          Memory address parity error (STORNET only)
{           57          xx4x          not used.
{           56          xx8x          not used.
{           55          x1xx          not used.
{           54          x2xx          Upper half of buffer memory enabled.
{           53          x4xx          High speed data transfer enabled.
{           52          x8xx          not used.
{
{ These counter values are set to -1 if not CY170 DMA Adapter channel or if
{ the failure did not occur during DMA mode I/O via the CY170 DMA Adapter.
{ (Refer to Engineering Specification No.22132530 for details.)
{   16.  CY170 DMA Adapter initial T register contents (if set prior to error).
{   17.  CY170 DMA Adapter Control Register contents.
{   18.  CY170 DMA Adapter Operational Status register contents.
{   19.  CY170 DMA Adapter Error Status register contents.
{
{        STATUS BIT   HEXIDECIMAL
{       (right most)  POSITION                ASSIGNMENT
{       ------------  -----------    ----------------------------
{           63          xxx1          KX board error.
{           62          xxx2          JY board error.
{           61          xxx4          KZ board error.
{           60          xxx8          BAS parity error.
{           59          xx1x          JY data error.
{           58          xx2x          12/16 conversion error.
{           57          xx4x          Input error.
{           56          xx8x          Overflow error.
{           55          x1xx          Clock fault.
{           54          x2xx          CMI read data parity error.
{           53          x4xx          Response code parity error.
{           52          x8xx          Invalid CM response.
{           51          1xxx          CM reject.
{           50          2xxx          Uncorrected CM error.
{           49          4xxx          not used.
{           48          8xxx          not used.
{
{   20.  CY170 DMA Adapter PP word count (Always 2).
{   21.  CY170 DMA Adapter T register contents at time of failure (if loaded).
{
{  The following failure messages correspond to the condition codes
{  defined in deck dfc$esm_driver_error_codes.
{  The <message> recorded in the engineering log entry is that shown below
{  preceded by the character string "ERR=VP730ncccc, " where 'n' is 2 if
{  device is Stornet, 3 if ESM II; and where 'cccc' is the symptom code.
{
{    1 - CHANNEL FUNCTION TIMEOUT               The channel did not go inactive
{                                               after function issued.
{    2 - IOU CHANNEL PARITY ERROR               A channel parity error was
{                                               detected by the IOU.
{    3 - ESM CHANNEL PARITY ERROR               A channel parity error was
{                                               detected by ESM/Stornet.
{    4 - ESM DOUBLE BIT PARITY ERROR            A double bit parity error was
{                                               detected by ESM/Stornet.
{    5 - ESM ADDRESS PARITY ERROR               ESM/Stornet detected parity
{                                               error on received address.
{    6 - ESM FLAG OPERATION ABORT               An unexpected abort on a four
{                                               bit flag operation occurred.
{    7 - ADAPTER UNCORRECTED CM ERROR           CY170 DMA Adapter status bit 50.
{
{    8 - ADAPTER CM REJECT                      CY170 DMA Adapter status bit 51.
{
{    9 - ADAPTER INVALID CM RESPONSE            CY170 DMA Adapter status bit 52.
{
{   10 - ADAPTER CM RESPONSE PARITY ERROR       CY170 DMA ADAPTER status bit 53.
{
{   11 - ADAPTER CMI READ PARITY ERROR          CY170 DMA ADAPTER status bit 54.
{
{   12 - ADAPTER CLOCK FAULT                    CY170 DMA ADAPTER status bit 55.
{
{   13 - ADAPTER INPUT BUFFER OVERFLOW          CY170 DMA ADAPTER status bit 56.
{
{   14 - ADAPTER INPUT DATA PARITY ERROR        CY170 DMA ADAPTER status bit 57.
{
{   15 - ADAPTER 12/16 CONVERTION ERROR         CY170 DMA ADAPTER status bit 58.
{
{   16 - ADAPTER JY DATA PARITY ERROR           CY170 DMA ADAPTER status bit 59.
{
{   17 - ADAPTER BAS (KX PP DATA) PARITY ERROR  CY170 DMA ADAPTER status bit 60.
{
{   18 - ADAPTER KZ BOARD DETECTED ERROR        CY170 DMA ADAPTER status bit 61.
{
{   19 - ADAPTER JY BOARD DETECTED ERROR        CY170 DMA ADAPTER status bit 62.
{
{   20 - ADAPTER KX BOARD DETECTED ERROR        CY170 DMA ADAPTER status bit 63.
{
{   21 - ESM ADDRESS OVERFLOW                   ESM LSP error status bits 62 & 63.
{
{   22 - CHANNEL INACTIVE ERROR                 Channel found to be inactive
{                                               when expected to be active.
{   23 - ADAPTER TRANSFER HALTED EARLY          The transfer halted early, more
{                                               detail unknown.
{   24 - LOW SPEED PORT DEADMAN TIMEOUT         The STORNET/ESM failed to fill or
{                                               empty the channel within time limit.

*DECK DECK=CMH$MONITOR_ROUTINES EXPAND=FALSE
{ }
{     The purpose of this request is to call the monitor procedure }
{ cmp$monitor_routines.  This procedure uses the input data block }
{ to decide which sub procedure is to be called, and to supply }
{ parameters to the procedure. }
{ }
{       CMP$MONITOR_ROUTINES (REQUEST_BLOCK) }
{ }
{ REQUEST_BLOCK: (input, output)  This parameter holds the information }
{       controlling which procedure is called, along with the input and }
{       output parameters }
{ }
*DECK DECK=CMH$MOUNT_STORAGE_MEDIUM EXPAND=FALSE
{
{   This request provides a scheduling and operator negotiation service to a
{ program which requires direct access to a storage device and its data
{ storage medium without the use of NOS/VE file system interfaces.
{
{   The function of this request is twofold:
{
{        1.  The "attachment" (or assignment) of a storage device to the job
{            by the operator.
{
{        2.  The mounting of a storage medium, e.g.  tape reel or mass storage
{            pack, on the indicated storage device.
{
{   The system performs no validation of the medium mounted by the operator.
{ The assumption of the system is that the medium is not identifiable to the
{ system; therefore, the onus falls upon the caller of this interface to
{ ensure that the correct medium has been mounted.
{
{   While this request is awaiting the operator to mount the medium, an
{ interactive user will be able to see in his/her job status that such an
{ operator action is outstanding and will be able to do a "user break" to
{ terminate or pause from this request.
{
{   If the system should be interrupted after the medium has been mounted, the
{ caller must repeat this request to ensure the medium is still mounted on the
{ correct storage device after the interrupt.
{
{   The request will be accepted if the element has been:
{
{        1.  Reserved to the job making this request (see
{            cmp$reserve_element).
{
{        or..
{
{        2.  The object of an msp$request_maintenance_access request by the
{            job making this request.
{
{            a.  If the storage device is scheduled for CONCURRENT maintenance
{                access and this request was issued with "no wait", then this
{                request will terminate with abnormal status if another job
{                has the storage device assigned.
{
{            b.  If the storage device is a mass storage device which is
{                requested for CONCURRENT maintenance access, then this
{                request will be rejected.
{
{            c.  If the storage device is a magnetic tape device which is
{                requested for CONCURRENT maintenance access, the storage
{                device must be in the DOWN state.
{
{            d.  If the storage device is scheduled for either CONCURRENT or
{                DEDICATED maintenance access and the requesting job already
{                has the storage device assigned, this request will be
{                rejected.
{
{
{   and ..
{
{        3.  The operator agrees to mount the indicated media.
{
{   Either a CMP$RELEASE_ELEMENT or MSP$RELEASE_MAINTENANCE_ACCESS request
{ will terminate the assignment of the storage device to the job.  However,
{ physically unloading the medium from the storage device is the province of
{ the program or the operator.
{
{       CMP$MOUNT_STORAGE_MEDIUM (STORAGE_DEVICE, MEDIUM, WRITE_ACCESS,
{         WAIT_FOR_ATTACHMENT, STATUS)
{
{ STORAGE_DEVICE: (input)  This parameter specifies the identity of the
{       storage device on which the media is to be mounted.
{
{ MEDIUM: (input)  This parameter specifies the identity of the medium which
{       is to be mounted.
{
{ WRITE_ACCESS: (input)  This parameter specifies whether the access to the
{       medium will include write access or not.  If not, the operator will be
{       asked to mount tape media without a write ring and to set the the
{       'write disable' switch, if present, on mass storage media.
{
{ WAIT_FOR_ATTACHMENT: (input)  This parameter specifies whether or not the
{       task should wait for availability of the storage device on which the
{       medium will be mounted.  If the storage device is undergoing
{       CONCURRENT maintenance access, some other job may have the storage
{       device assigned to it.  This parameter has effect only in the
{       "attachment" of the storage device to the job; once the attachment
{       process completes, the wait for the operator to mount the medium is
{       indefinite.
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS:
{                     cme$element_not_reserved,
{                     cme$lcm_device_attached_to_job,
{                     cme$lcm_device_busy,
{                     cme$lcm_element_not_found,
{                     cme$lcm_empty_pa_set,
{                     cme$lcm_missing_pa_set_member,
{                     cme$lcm_not_available,
{                     cme$lcm_ring_validation_error,
{                     cme$mount_media_denied,
{                     cme$privileged_job_required.
{
{         IDENTIFIER : 'CM'
{
{
*DECK DECK=CMH$MULTIPLE_IOU_SYSTEM EXPAND=FALSE
{
{   The purpose of this function is to determine whether or not the system on
{ which the function is executed has multiple IOUs physically configured.  The
{ value TRUE is returned if more than one IOU is physically connected to the
{ mainframe on which this function is executed; otherwise the value FALSE is
{ returned.
{
{         CMP$MULTIPLE_IOU_SYSTEM
{
*DECK DECK=CMH$PC_GET_ELEMENT EXPAND=FALSE

{ COMMON DECK CMHPCGE }

{   The purpose of this procedure is to retrieve an element specified by
{ name from the active physical configuration table.
{
{       CMP$PC_GET_ELEMENT (ELEMENT_NAME, IOU_NAME, MAINFRAME_ELEMENT, STATUS)
{
{ ELEMENT_NAME: (input)  This parameter specifies the name of the
{       element to be retrieved.
{
{ IOU_NAME : (input) This parameter specifies the name of the iou. Only
{       if the element is a channel will iou name will be used in the search.
{
{ MAINFRAME_ELEMENT: (output)  This parameter specifies the named element
{       found.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$PC_GET_LOGICAL_UNIT EXPAND=FALSE

{ COMMON DECK CMHPCLU }

{   The purpose of this request is to return the mainframe element specified
{ by a logical unit number.
{
{       CMP$PC_GET_LOGICAL_UNIT (LOGICAL_UNIT_NUMBER, MAINFRAME_ELEMENT,
{         STATUS)
{
{ LOGICAL_UNIT_NUMBER: (input)  This parameter specifies the logical unit
{       number of the mainframe element to be returned.
{
{ MAINFRAME_ELEMENT: (output)  This parameter specifies the mainframe
{       element indicated by the logical unit number.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$PC_GET_NEXT_CHANNEL EXPAND=FALSE

{ COMMON DECK CMHPCGC }

{   The purpose of this procedure is to search the installed logical
{ configuration sequencially for the nth channel element.
{
{       CMP$PC_GET_NEXT_CHANNEL (CURRENT_CHANNEL, MAINFRAME_ELEMENT,
{         STATUS)
{
{ CURRENT_CHANNEL: (input)  This parameter specifies which channel is currently
{       being used.  To the the first channel element, this value should
{       be zero.
{
{ MAINFRAME_ELEMENT: (output)  This parameter specifies the channel element
{       found.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$PC_MODIFY_LCT EXPAND=FALSE

{ COMMON DECK CMHPCML }

{   The purpose of this request is to modify the logical configuration
{ table by changing the logical unit number on an entry, specified by
{ the old logical unit number, to a new logical unit number.
{
{       CMP$PC_MODIFY_LCT (OLD_LUN, NEW_LUN, STATUS)
{
{ OLD_LUN: (input)  This parameter specifies the key by which the
{       logical configuration table is searched.
{
{ NEW_LUN: (input)  This parameter specifies the new logical unit
{       number to be used.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$PROCESS_CPU_STATE_CHANGE EXPAND=FALSE
{
{   The purpose of this request is to provide the interface to the Ring 1
{ procedure which actually requests the CPU state change from job-mode.
{
{       CMP$PROCESS_CPU_STATE_CHANGE (
{         PROCESSOR_ID,
{         CURRENT_STATE,
{         NEW_STATE,
{         STATUS)
{
{ PROCESSOR_ID: (input)  This parameter specifies the number of the CPU whose
{       state is to be changed.  The id specifies the logical element
{       number of the CPU as it relates to the CPU state table.
{
{ CURRENT_STATE: (input)  This parameter specifies the current state of the
{       element.
{
{ NEW_STATE: (input)  This parameter specifies the new state of the element.
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS:
{               cme$lcm_ring_validation_error
{
{         IDENTIFIER:  'CM'
{
*DECK DECK=CMH$PROCESS_CPU_STATE_CHANGE_R1 EXPAND=FALSE
*DECK DECK=CMH$PROCESS_EXCLUDE_LIST EXPAND=FALSE

{ COMMON DECK CMHPEL }


{   The purpose of this request is to remove elements specified by the
{ exclude list from the logical configuration list.
{
{       CMP$PROCESS_EXCLUDE_LIST (EXCLUDE_LIST, CONNECTED_LC_FID,
{         CONNECTED_LIST_FID, STATUS)
{
{ EXCLUDE_LIST: (input) This prarameter specifies the names of elements to
{       be excluded from the logical configuration.
{
{ CONNECTED_LC_FID: (input) This parameter specifies the segment access
{       file identifier that contains the logical configuration.
{
{ CONNECTED_LIST_FID: (input) This parameter specifies the segment access
{       file identifier that will contain the final list.
{
{ STATUS: (output) This paramter specifies the request status.
{
*DECK DECK=CMH$PROCESS_STATE_CHANGE EXPAND=FALSE
{
{   This is a Ring 3 interfaces to change the state of an element.
{
{      CMP$PROCESS_STATE_CHANGE (ELEMENT_DEFINITION, CURRENT_STATE. NEW_STATE,
{                    STATUS)
{
{    ELEMENT_DEFINITION : {input} This parameter describes the element whose
{                         state will be changed.
{
{    CURRENT_STATE : {input} This parameter specifies the current state of the element.
{
{    NEW_STATE : {input} This parameter specifies the new state.
{
{    STATUS : {output} This parameter specifies the status of the request.
{
*DECK DECK=CMH$QUEUE_IO_REQUEST EXPAND=FALSE
{
{    This request is used to queue a subsystem io request.
{
{          CMP$QUEUE_IO_REQUEST (REQUEST_ID, QUEUE_CONTROL, RECOVERY_OPTIONS,
{                                WAIT_FOR_IO_COMPLETION, STATUS)
{
{  REQUEST_ID: (input/output)  This parameter specifies the operating system
{                              identification that is associated with the
{                              subsystem io request.
{
{  QUEUE_CONTROL: (input)  This parameter specifies the manner in which
{                               to link this request into the request queue.
{
{  RECOVERY_OPTIONS: (input)  This parameter specifies the type of recovery
{                             to associate with this request.
{
{  WAIT_FOR_IO_COMPLETION:  (input)  This parameter specifies whether or not
{                                    the task wants to wait for this io
{                                    request to complete.  If the task wants
{                                    to wait for io completion, an amount of
{                                    time to wait must be specified.
{
{  STATUS: (output)  This parameter returns the request status.
{
*DECK DECK=CMH$QUEUE_REQUEST_R1 EXPAND=FALSE

{
{    This request is used to link a request queue entry into a queue.
{  queue.
{
{          CMP$QUEUE_REQUEST_R1 (REQUEST_ID, QUEUE_CONTROL, RECOVERY_OPTIONS,
{                                READY_TASK_UPON_IO_COMPLETION, STATUS)
{
{  REQUEST_ID: (input)  This parameter specifies the operating system identification
{                        that is associated with the io request.
{
{  QUEUE_CONTROL: (input)  This parameter specifies the manner in which
{                          to link this request into the request queue.
{
{  RECOVERY_OPTIONS: (input)  This parameter specifies the type of recovery
{                             to associate with this request.
{
{  READY_TASK_UPON_IO_COMPLETION:  (input)  This parameter specifies whether or not
{                                           to ready the task upon completion of the io
{                                           request.
{
{  STATUS: (output)  This parameter returns the request status.
{
*DECK DECK=CMH$RECOVER_SUBSYSTEM_IO_TABLE EXPAND=FALSE
{
{    This request provides job recovery processing of the subsystem io
{  completion table for a job.
{
{          PROCEDURE CMP$RECOVER_SUBSYSTEM_IO_TABLE (STATUS)
{
{ STATUS: (output)  This parameter returns the result of the request.
{

*DECK DECK=CMH$RELEASE_ELEMENT EXPAND=FALSE
{
{   The purpose of this request is to release the job's reservation of one or
{ more elements.
{
{   All element reservations may be released in one request or a sequence of
{ requests.  However, additional reservations of certain elements are not
{ allowed until previous reservations have first been released.  Refer to the
{ description of CMP$RESERVE_ELEMENT.
{
{   If a PP reservation is released, the PP is first hardware idled and then
{ any channel interlock(s) held by the PP are cleared by this request.
{
{   If a job has a PP reserved and has scheduled maintenance access to
{ peripheral elements which were being accessed through the reserved PP, the PP
{ reservation should be released before the maintenance access is released to
{ avoid potential access conflict with the system.
{
{   If a storage device was reserved and had been the object of a
{ CMP$MOUNT_STORAGE_MEDIUM request, the storage device will be "detached"
{ (unassigned) from the job; the medium will not be physically unloaded by this
{ request.
{
{   Reservations made by a non-system-caller which are not explicitly released
{ by this request are released when the task which made the reservations
{ terminates.
{
{       CMP$RELEASE_ELEMENT (ELEMENT, STATUS)
{
{ ELEMENT: (input)  This parameter specifies the identity of the element whose
{       reservation is to be released.  The identity of the system element may
{       be specified using either the name of the element or its hardware
{       address.
{
{       If a peripheral hardware address is specified you must initialize the
{       physical_address_specifier to indicate how many parts of the address
{       are initialized in the address path.  For example, if you are querying
{       a unit, the physical_address_specifier must include a channel, a
{       channel_address and the unit_address and you must initialize all three
{       fields of the hardware address.
{
{       If use_logical_identification is FALSE in any of the fields of the
{       element descriptor and the mainframe has more than one IOU, the name of
{       the IOU must be initialized because the channel and PP identification
{       is ambiguous in this case.  The IOU component of the peripheral
{       descriptor will be ignored on single IOU mainframes.
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS:
{                     cme$element_not_reserved,
{                     cme$lcm_element_not_found,
{                     cme$lcm_empty_pa_set,
{                     cme$lcm_missing_pa_set_member,
{                     cme$lcm_ring_validation_error,
{                     cme$privileged_job_required.
{
{         IDENTIFIER:  'CM'
{
{
*DECK DECK=CMH$RELEASE_UNIT EXPAND=FALSE
*DECK DECK=CMH$RESERVE_ELEMENT EXPAND=FALSE
{
{   The purpose of this request is to schedule a mainframe or peripheral
{ element for the exclusive use of the requesting job.  The only mainframe
{ elements which may be reserved are PPs and channels.
{
{   All peripheral elements and channels which must be reserved concurrently
{ must be reserved in one request.  A peripheral element is one of the
{ following types of elements:  channel adapter, communications element,
{ controller, external processor, or storage device.  All PPs which must be
{ reserved concurrently must be reserved in one request, but not necessarily
{ the same request as the one which reserved the peripheral elements and
{ channels.
{
{   This request grants special privileges to a system caller.  A system caller
{ is one whose request is made from a system segment.  A system caller is
{ exempt from the following four policies and does not affect the ability of a
{ non-system-caller to perform subsequent reservations in the same job.
{
{    1.  Once a peripheral or channel reservation is granted to a job a
{        subsequent attempt to acquire additional peripheral element or channel
{        reservations will not be allowed; existing reservations of such
{        elements must first be released.  Only elements which have not been
{        reserved by a system caller are considered in this policy.
{
{    2.  If a job has peripheral elements and or channels reserved to it, a
{        subsequent attempt to reserve PPs will be allowed if they are
{        available and if none are already reserved to that job.  Only elements
{        which have not been reserved by a system caller are considered in this
{        policy.
{
{    3.  If a job has a PP reserved to it, further reservations of PPs,
{        channels or peripheral elements to that job will not be allowed;
{        existing PP reservations must first be released.
{
{    4.  The reservations of all elements within a job are automatically
{        released when the task which made the reservation terminates.
{
{   It is recommended that programs requiring multiple schedulable resources
{ obtain those resources in the following order and release them in the inverse
{ order, i.e.  last reserved is first released:
{
{        1.  Tape storage device reservation (RESERVE_RESOURCES).
{
{        2.  File attachments (fsp$open_file, ATTACH_FILE, fsp$attach_file).
{
{        3.  Peripheral and channel element reservations (cmp$reserve_element).
{
{        4.  Maintenance access (msp$request_maintenance_access).
{
{        5.  PP reservations (cmp$reserve_element).
{
{   It is further recommended that a program which gets blocked in its attempt
{ to obtain a particular type of resource, return the resources previously
{ acquired in the inverse order in which they were acquired.  For example, if
{ an attempt to acquire peripheral hardware reservations is blocked, the
{ program should back out of its file attachments and then its tape storage
{ device reservations to avoid a deadlock with other jobs which may be in
{ competition with it for some or all of the same resources.
{
{   Element reservations are not maintained across a system interrupt.  It is
{ the responsibility of the program making the reservation to repeat the
{ reservation process, if desired, after the system recovery completes.  A job
{ may establish a job-recovery condition-handler for this purpose.
{
{
{   PP RESERVATIONS:
{
{   If a PP is requested, the PP must not be currently reserved to a job nor to
{ the NOS/VE system itself.  In a dual-state system, the satisfaction of a
{ request for a PP in IOU0 is contingent upon a successful request of the PP
{ from the NOS or NOS/BE system.  If the PP is acquired, the reservation is
{ allowed and the PP will be returned to the NOS or NOS/BE system when the
{ NOS/VE element reservation is released.
{
{   There are four ways to identify the PP which is desired:
{
{         1.  cmc$choose_any_pp - This selection will return any available
{             PP regardless of IOU.  This selection might commonly be used to
{             acquire a PP to perform a background task or to perform a Central
{             Memory test, etc.  In a system with NIO and CIO PP's, an NIO PP
{             will be selected if available, otherwise, a CIO PP will be
{             selected.  In a system with only CIO PP's, this request will
{             select an available CIO PP.  In a dual IOU system, the search
{             order is IOU1 NIO, IOU0 NIO, IOU1 CIO, IOU0 CIO.
{
{         2.  cmc$choose_pp_by_barrel - This selection will return an NIO PP
{             which is in the "driver barrel" on a CYBER 810/830 system.  On
{             any other system this selection is identical to
{             cmc$choose_any_pp.
{
{         3.  cmc$choose_pp_by_channel - This selection will return any
{             available PP which has access to the channel identified in the
{             request.  In a multiple IOU system, the IOU field of this record
{             must be initialized to uniquely identify the channel.
{
{         4.  cmc$choose_specific_pp - This selection will return only the PP
{             identified by the request.  This option is not implemented on a
{             dual-state system.  In a multiple IOU system, the IOU field of
{             this record must be initialized to uniquely identify the PP.
{
{
{   DATA CHANNEL RESERVATIONS:
{
{   If a data channel is requested, it must be an external data channel which
{ is not currently reserved to a job nor to the NOS/VE system itself.  In a
{ dual-state system, the satisfaction of a request for a channel in IOU0 is
{ contingent upon a successful request of the channel from the NOS or NOS/BE
{ system.  If the channel is acquired, the reservation is allowed and the
{ channel will be returned to the NOS or NOS/BE system when the NOS/VE element
{ reservation is released.  In a multiple-IOU system, the IOU field of the
{ record must be initialized to uniquely identify the channel being reserved.
{
{   If a channel has multiple ports, then all ports of the channel are reserved
{ as a result of requesting any one of the ports.  For example, an I4 CIO
{ channel may be referred to by the name CCH1A, CCH1B, or CCH1; with respect to
{ this request all forms of reference have the same result.
{
{   NOS/VE's policy for channel reservation depends upon whether or not a
{ peripheral which is defined in the active, physical configuration is
{ connected to the channel requested; if this is the case the channel is said
{ to be in the active configuration.
{
{   If the requested channel is not in the active configuration, this request
{ is granted subject to the previously mentioned conditions.
{
{   If the requested channel is in the active configuration, then in addition
{ to other conditions mentioned above, the channel must also be in the ON
{ state, have no elements in the ON or DOWN state connected to it and not be
{ the object of maintenance access.
{
{
{   PERIPHERAL RESERVATIONS:
{
{   For the purposes of the following discussion a peripheral element is
{ reservable by a job if one of the following is true:
{
{         1.  The element is classified as reservable only by a system process
{             and the call was made from a system segment.
{
{         2.  The element is one which is not recognized as a standard
{             peripheral to the NOS/VE operating system, per se.  Elements in
{             this class are defined to NOS/VE by specifying
{             VERIFY_ELEMENT_IDENTIFICATION=FALSE on the DEFINE_ELEMENT
{             subcommand which configures the element to NOS/VE.  Refer to the
{             documentation of the Physical Configuration Utility for the
{             explanation about how elements defined in this manner are
{             categorized as "controllers" and "storage devices" by NOS/VE.
{
{   If a peripheral element is requested it must be a reservable element and
{ must not be currently reserved to a job nor to the NOS/VE system itself.
{
{   Furthermore, if a peripheral element is requested by name or by hardware
{ address, this request will ensure that the value of the element_type field
{ matches the type of the element identified by the peripheral_descriptor
{ field.  Remember that all reservable elements available to a non-system
{ caller are either classified as a controller or a storage device; refer to
{ the description of the DEFINE_ELEMENT subcommand of the Physical
{ Configuration Utility for more information.
{
{   If a peripheral element is requested by name, the name must be defined in
{ the active configuration or the request is denied.
{
{   NOS/VE's reservation policy further depends upon whether or not the
{ peripheral is defined in the active, physical configuration.
{
{   If the requested peripheral is not in the active configuration, this
{ request is granted subject to the previously mentioned conditions.
{
{   If the requested peripheral is in the active configuration, then in
{ addition to other conditions mentioned above, the peripheral must be in the
{ ON state, be a reservable element and not be the object of maintenance
{ access.  If the peripheral is connected to another channel of this mainframe
{ or is connected to another mainframe, it is the caller's responsibility to
{ coordinate this reservation with other jobs and with other mainframes.
{
{   If your task is going to access the peripheral, you must either reserve a
{ channel to the element in this same request or, if your task is a maintenance
{ task, you may use msp$request_maintenance_access to schedule access to the
{ channel.
{
{       CMP$RESERVE_ELEMENT (ELEMENT, STATUS)
{
{ ELEMENT: (input, output)  This parameter specifies the identity of the system
{       element to be reserved to the job.  The identity may be specified using
{       either the name of the element or its hardware address.
{
{       If a peripheral hardware address is specified you must initialize the
{       physical_address_specifier to indicate how many parts of the address
{       are initialized in the address path.  For example, if you are querying
{       a unit, the physical_address_specifier must include a channel, a
{       channel_address and the unit_address and you must initialize all three
{       fields of the hardware address.
{
{       If use_logical_identification is FALSE in any of the fields of the
{       element descriptor and the mainframe has more than one IOU, the name of
{       the IOU must be initialized because the channel and PP identification
{       is ambiguous in this case.  The IOU component of the peripheral
{       descriptor will be ignored on single IOU mainframes.
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS:
{                     cme$cm_element_not_found,
{                     cme$element_already_reserved,
{                     cme$element_downline_connected,
{                     cme$element_not_reservable,
{                     cme$element_state_not_proper,
{                     cme$element_unavailable_in_170,
{                     cme$invalid_state_in_mainframe,
{                     cme$lcm_element_not_found,
{                     cme$lcm_empty_pa_set,
{                     cme$lcm_missing_pa_set_member,
{                     cme$lcm_ring_validation_error,
{                     cme$privileged_job_required,
{                     cme$reserve_not_permitted,
{                     cme$specific_pp_not_reservable.
{
{         IDENTIFIER:  'CM'
{
*DECK DECK=CMH$RESUME_PP EXPAND=FALSE
{
{   The purpose of this request is to resume the execution of a PP which had
{ previously been idled by the CMP$IDLE_PP request.
{
{   This request may be used to resume a PP which had been software-idled or
{ one which was hardware-idled.  In the latter case, the PP is resumed at a
{ specified address in the current image of the PP's memory; the first two
{ locations in the PP's memory will be destroyed to accomplish the resumption.
{
{   After the optional resumption of the PP from a hardware-idled state, the
{ PP is given a "resume pp" request on its "PP queue".  The system will wait
{ for up to two seconds for the PP to respond to this request before the
{ request terminates with an indication of whether or not the PP responded.
{ An attempt to restart the PP at a new address will be rejected if the PP is
{ not currently in a hardware-idled state.  The state of any external data
{ channel is unaffected by this request.
{
{       CMP$RESUME_PP (PP_IDENTIFICATION, HARDWARE_RESUME_PP, START_ADDRESS,
{         PP_SOFTWARE_RESUMED, STATUS)
{
{ PP_IDENTIFICATION: (input)  This parameter specifies the identity of the PP
{       to be resumed.  The PP must currently be reserved to the requesting
{       job and must be in a hardware-idled condition.
{
{ HARDWARE_RESUME_PP: (input)  This parameter specifies whether or not the PP
{       is to be restarted from a hardware-idled state at an address within
{       the current image of the PP's memory.
{
{ START_ADDRESS: (input)  This parameter specifies the PP program address at
{       which re-execution of the PP is to commence.  The start address cannot
{       be location 0 or 1 of the PP as these are destroyed by this request.
{       This parameter is ignored if the value of HARDWARE_RESUME_PP is FALSE.
{
{ PP_SOFTWARE_RESUMED: (output)  This parameter specifies whether or not the
{       PP resonded to the "PP resume" request in the allotted time.
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS:
{                     cme$element_not_reserved,
{                     cme$improper_start_address,
{                     cme$lcm_ring_validation_error,
{                     cme$pp_not_hardware_idled,
{                     cme$pp_could_not_be_restarted,
{                     cme$privileged_job_required.
{
{         IDENTIFIER : 'CM'
{
{
*DECK DECK=CMH$RETURN_DESCRIPTOR_DATA EXPAND=FALSE

{ HEADER DECK CMH$RETURN_DESCRIPTOR_DATA }

{   The purpose of this request is to return a string containing
{ the physical pp number, the channel, iou, mainframe, controller, and logical
{ unit element names, along with the vsn currently assigned with
{ the device.
{
{      CMP$RETURN_DESCRIPTOR_DATA (CHANNEL_NUMBER, IOU_NUMBER, PHYSICAL_EQUIPMENT_NUMBER
{        LOGICAL_UNIT_NUMBER, DESCRIPTOR_DATA, PP_NUMBER)
{
{ CHANNEL_NUMBER: (input) This parameter specifies the channel number of the
{      desired path.
{
{ IOU_NUMBER: (input) This parameter specifies the iou number associated with
{     the given channel number.
{
{ PHYSICAL_EQUIPMENT_NUMBER: (input) This parameter specifies the physical
{      equipment number of the desired path.
{
{ LOGICAL_UNIT_NUMBER: (input) This parameter specifies the logical unit
{      number of the desired path.
{
{ DESCRIPTOR_DATA: (output) This parameter specifies the string containing
{      the information desired.
{
{ PP_NUMBER: (output) This parameter specifies the actual physical pp number
{      of the desired path.
{
*DECK DECK=CMH$SAVE_DEVICE_FILE EXPAND=FALSE

{ COMMON DECK CMHSDF }

{   The purpose of this request is to store information from a bam segment
{ access file on a named device file on the system device.  If the device
{ file currently exists, it will write over the old data.  If the device file
{ does not exist, it will create one.
{
{       CMP$SAVE_DEVICE_FILE (DEVICE_FILE_NAME, SEGMENT_FILE_FID, STATUS)
{
{ DEVICE_FILE_NAME: (input)  This parameter specifies the name of the
{       device file to be written.
{
{ SEGMENT_FILE_FID: (input)  This parameter specifies the segment_access file
{       identifier that contains the data to be stored in the device file.
{       The file is treated as a sequence.
{
{ STATUS: (output)  This parameter sepecifies the request status.
{
*DECK DECK=CMH$SDP_FAILURE_DATA_DOC EXPAND=FALSE
{
{ DECK: CMH$SDP_FAILURE_DATA_DOC
{ PURPOSE:
{    The purpose of this statistic is to record the failure data captured
{    by the system when logging side door port status from a STORNET/ESM
{    memory device.
{
{ FREQUENCY:
{    When STORNET/ESM is initially defined and at NOS/VE top of hour
{    processing thereafter.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mainframe>.<iou>.<pp>.<ch>.<element>*<message>'
{
{      where <mainframe> is the identification of the mainframe in the
{        form $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where <iou> is the string 'IOUn' where n is 0 or 1.  This
{        identifies the IOU associated with the channel over which
{        the failure was reported.
{
{      where <pp> is the string 'PPn' or 'CPPn' where n is the PP number
{        (in decimal) of the PP which performed the I/O operation which
{        is being reported.
{
{      where <ch> is the string 'CHn' or 'CCHn' where n is the channel
{        number (in decimal) over which the I/O request was processed.
{
{      where <element> is the element_name assigned to the STORNET/ESM
{        memory device via the PCU command DEFINE_ELEMENT_DEFINITION.
{
{      where <message> is the textual representation of an analysis code.
{        The message text corresponds with the analysis code in counter 2
{        of the statistics counter field.
{
{
{    The counter-value portion of this statistic contains:
{
{     1.  Date/Time Stamp.
{
{     2.  Analysis Code.
{         Indicates completion status or the extent to which the CPU and
{         PPU were able to isolate a failure when it was detected.
{
{     3.  STORNET/ESM side door port path information.
{
{     4.  Error Log (bits 0 - 63).
{
{     5.  Error Log (bits 0 - 63).
{
{     6.  Error Log (bits 0 - 63).
{
{     7.  Error Log (bits 0 - 63).
{
{     8.  Error Log (bits 0 - 63).
{
{     9.  Error Log (bits 0 - 63).
{
{    10.  Error Log (bits 0 - 63).
{
{    11.  Error Log (bits 0 - 63).
{
{    12.  Error Log (bits 0 - 63).
{
{    13.  Error Log (bits 0 - 63).
{
{    14.  Error Log (bits 0 - 63).
{
{    15.  Error Log (bits 0 - 63).
{
{    16.  Error Log (bits 0 - 63).
{
{    17.  Error Log (bits 0 - 63).
{
{    18.  Error Log (bits 0 - 63).
{
{    19.  Error Log (bits 0 - 35).
{         Bits 36 - 63 = zero.
{
{    20.  Side Door Port Status (bits 16 - 63).
{         Bits 0 - 15 = zero.
{
{
{  The following failure messages correspond to the condition codes defined
{  in decks dfc$sdp_driver_error_codes and dfc$sdp_logging_error_codes.
{
{  The <message> recorded in the Engineering Log entry is that shown below
{  preceded by the character string "ERR=VP730ncccc, " where 'n' is 0 if
{  device is STORNET, 1 if ESM II; and where 'cccc' is the symptom code.
{
{    2 - SIDE DOOR PORT CHANNEL ACTIVE ERROR
{        The SDPD PP driver found the data channel ACTIVE when it was expected
{        to be INACTIVE.
{
{    3 - SIDE DOOR PORT NO INACTIVE TO FUNCTION
{        The data channel did not go INACTIVE after a function was issued from
{        the SDPD PP driver to the STORNET/ESM side door port.
{
{    4 - SIDE DOOR PORT LOST DATA ON INPUT
{        A data transfer from the STORNET/ESM side door port to the SDPD PP
{        driver terminated early.
{
{    5 - SIDE DOOR PORT CHANNEL PARITY ERROR
{        The SDPD PP driver detected a data channel parity error.
{
{    6 - SIDE DOOR PORT CHANNEL NOT EMPTY
{        The data channel stayed FULL after a data transfer from the SDPD PP
{        driver to the STORNET/ESM side door port.
{
{    7 - SIDE DOOR PORT CHANNEL LOCKWORD ERROR
{        The PP number in the Channel Lockword for the STORNET/ESM side door
{        port channel in the Channel Interlock Table is incorrect.
{
{    8 - RESERVED
{
{    9 - RESERVED
{
{   10 - RESERVED
{
{   11 - RESERVED
{
{   12 - RESERVED
{
{   13 - RESERVED
{
{   14 - RESERVED
{
{   15 - RESERVED
{
{   16 - RESERVED
{
{   17 - RESERVED
{
{   18 - RESERVED
{
{   19 - RESERVED
{
{   20 - SIDE DOOR PORT NO INITIALIZATION ERROR
{        No errors occurred during side door port logging initialization.
{
{   21 - SIDE DOOR PORT CHANNEL INCORRECT STATE
{        No defined STORNET/ESM side door port channel is found having a
{        channel status state of 'CMC$ON'.  Channel status state is either
{        'CMC$DOWN' or 'CMC$OFF'.
{
{   22 - SIDE DOOR PORT CHANNEL UNAVAILABLE
{        Side door port logging could not RESERVE the defined STORNET/ESM side
{        door port channel from NOS/VE.
{
{   23 - SIDE DOOR PORT PP UNAVAILABLE
{        Side door port logging could not RESERVE a PPU resource having access
{        to the defined STORNET/ESM side door port channel.
{
{   24 - SIDE DOOR PORT NO SDPD RESPONSE
{        Side door port logging did not receive a response from the SDPD driver
{        within the required 4 second interval and a timeout occurred.
{
*DECK DECK=CMH$SET_ELEMENT_STATE EXPAND=FALSE
{}
{    The purpose of this request is to change the logical state of an element.
{ The new state of the element will be preserved accross NOS/VE system
{ continuation deadstarts.
{    Only system elements which are not critical to system execution
{ may be placed in the OFF or DOWN states. Examples of requests which
{ would be rejected are: asking for both CPs, the only CP, the entire
{ IOU, MEMORY (as a system element rather than a few pages), the
{ system deadstart device or the only channel/controller to the
{ system deadstart device.
{   Changing the state of an element has no implied effect on the state
{ of any other element connected to it.
{    If the system element is being returned to the ON state from the OFF or
{ DOWN state, it will be subject to automatic, element-dependent
{ re-instatement procedures. This includes one or more of the following:
{      . Down-loading of standard controlware into a controller
{      . Searching for system labels on mass storage volumes
{      . Communicating to the system operator that the element is
{          available for use on other mainframes.
{    Only the operator may change the state of an element to or from the
{ OFF state.
{    A maintenance person or the NOS/VE system itself may change the state
{ of an element from ON to DOWN.
{    Either a maintenance person or the system operator may change the
{ the state of an element from DOWN to ON.
{}
{       CMP$CHANGE_ELEMENT_STATE (ELEMENT, STATE, STATUS)
{}
{  ELEMENT: (input) This parameter specifies the identity of the system
{         element whose state is to be changed.
{}
{  STATE: (input) This parameter specifies the new state of the element.
{}
{  STATUS: (output) This parameter specifies the request status.
{}
*DECK DECK=CMH$SET_ILLEGAL_CHANNEL_STATUS EXPAND=FALSE

{   The purpose of this request is to initialize a status variable for an
{ illegal channel status.
{
{       CMP$SET_ILLEGAL_CHANNEL_STATUS (ILLEGAL_CHANNEL_NUMBER, CONDITION,
{         STATUS)
{
{ ILLEGAL_CHANNEL_NUMBER: (input)  This parameter specifies the illegal
{       channel number.
{
{ CONDITION: (input)  This parameter specifies the status condition code.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$SET_PRODUCT_ID_STATUS EXPAND=FALSE

{   The purpose of this request is to format the status variable using the
{ text, product_id, and condition fields.
{
{       CMP$SET_PRODUCT_ID_STATUS (TEXT, PRODUCT_ID, CONDITION, STATUS)
{
{ TEXT: (input)  This parameter specifies the text field to be appended to
{       the status variable.
{
{ PRODUCT_ID: (input)  This parameter specifies the product identifier to be
{       placed in the status variable.
{
{ CONDITION: (input)  This parameter specifies the status condition code.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$SET_UNKNOWN_PRODUCT_ID EXPAND=FALSE

{   The purpose of this request is to format the status variable with a
{ product identifier.
{
{       CMP$SET_UNKNOWN_PRODUCT_ID (PRODUCT_ID, STATUS)
{
{ PRODUCT_ID: (input)  This parameter specifies the product identifier to
{       be placed in the status variable.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$SIGNAL_HANDLER EXPAND=FALSE
{
{    The purpose of this request is to indicate that a configuration
{  management signal has arrived and requires attention.
{
{        CMP$SIGNAL_HANDLER (ORIGINATOR, SIGNAL);
{
{ ORIGINATOR: (input) This indicates the task that sent the signal.
{
{ SIGNAL: (input) This is the information sent with the signal.
{
*DECK DECK=CMH$SSIOT_END_HANDLER EXPAND=FALSE
{
{    This request is to be used as the end handler for subsystem io
{  completion table end processing.
{
{          CMP$SSIOT_END_HANDLER (TERMINATION_STATUS, STATUS)
{
{  TERMINATION_STATUS: (input)  This parameter specifies the condition that
{                               caused the task to terminate.
{
{  STATUS: (output)  This parameter returns the request status.
{
*DECK DECK=CMH$SSIOT_RECOVERY_COMPLETE EXPAND=FALSE

{
{    This request is used to indicate that recovery of requests in the subsystem
{  io completion table has been performed.
{
{          CMP$SSIOT_RECOVERY_COMPLETE (STATUS)
{
{  STATUS: (output)  This parameter returns the request status.
{

*DECK DECK=CMH$SSIOT_RECOVERY_CONDITION EXPAND=FALSE

{
{    This request is used to determine if the subsystem io completion table
{  has been recovered after an operating system recovery.
{
{          CMP$SSIOT_RECOVERY_CONDITION (STATUS)
{
{  STATUS: (output)  This parameter returns the request status. If recovery
{                    action must be performed on the subsystem io completion
{                    table, a status of ioe$ssiot_recovery_required is
{                    returned.
{

*DECK DECK=CMH$SSIOT_RECOVERY_PROCESSING EXPAND=FALSE

{
{    This request will be called as part of job recovery by the operating
{  system.  The request will determine if recovery of outstanding io requests
{  is required by subsystems using the io completion table.  If recovery of
{  outstanding io requests is required, no new unit queue requests will be
{  accepted until action has been taken, by the subsystems, on the outstanding
{  io requests.
{
{          CMP$SSIOT_RECOVERY_PROCESSING (STATUS)
{
{  STATUS: (output)  This parameter returns the request status.
{
*DECK DECK=CMH$STORE_SSIOT_ENTRY_INFO EXPAND=FALSE
{
{    This request is used to store information in a subsystem io
{  completion table entry.
{
{          CMP$STORE_SSIOT_ENTRY_INFO (IO_COMPLETION_QUEUE_INDEX,
{                      ENTRY_INFORMATION_P, STATUS)
{
{  IO_COMPLETION_QUEUE_INDEX: (input)  This parameter specifies the
{                                      subsystem io completion table entry
{                                      in which information will be stored.
{
{  ENTRY_INFORMATION_P: (input)  This parameter specifies the information
{                                that is to be stored in the subsystem io
{                                completion table entry.
{
{  STATUS: (output)  This parameter returns the request status.
{
*DECK DECK=CMH$SUBSYSTEM_IO_JOB_EXIT EXPAND=FALSE
{
{    The purpose of this request is to clean up software tables associated
{  with the ability to perform subsystem io.  All the mf wired space associated
{  with the job io completion table must be returned.
{
{          CMP$SUBSYSTEM_IO_JOB_EXIT (STATUS)
{
{  STATUS: (output)  This parameter returns the request status.
{
*DECK DECK=CMH$UNLOCK_LUN_ENTRY EXPAND=FALSE
{ }
{     The purpose of this request is to unlock a logical unit }
{ table entry.  This is a ring 1 interface. }
{ }
{       CMP$UNLOCK_LUN_ENTRY (LOGICAL_UNIT, LUN_LOCK_RELEASED) }
{ }
{ LOGICAL_UNIT: (input)  This parameter specifies the logical }
{       unit of the entry to be unlocked. }
{ }
{ LUN_LOCK_RELEASED: (output)  This parameter specifies whether }
{       the unit was unlocked. }
{ }
*DECK DECK=CMH$UPDATE_INSTALLED_DFT EXPAND=TRUE

{ HEADER DECK CMHUIDF }

{   The purpose of this request is to change the status of the installed
{ device files to active, and then to change the active device files to
{ invalid.
{
{       CMP$UPDATE_INSTALLED_DFT (STATUS)
{
{ STATUS: (output)  This parameter specifies the request status.

*DECK DECK=CMH$VALIDATE_JOB EXPAND=FALSE
{
{   The purpose of this request is to check to see if a job
{   has sufficient privileges to use maintenance services and
{   configuration management interfaces.
{
{     CMP$VALIDATE_JOB (JOB_NAME, OPERATOR_JOB, MAINTENANCE_JOB,
{          SYSTEM_JOB, PRIVILEGED_JOB, STATUS)
{
{   JOB_NAME : {output} This parameter specifies the job name of the current
{              executing job.
{
{   OPERATOR_JOB : {output}  This parameter specifies whether or not the job
{                  is an operator job.
{
{   MAINTENANCE_JOB : {output} This parameter specifies whether or not the current
{                     job has maintenance job class.
{
{   SYSTEM_JOB : {output} This parameter specifies whether or not the current job is
{                system job.
{
{   PRIVILEGED_JOB : {output} This parameter specifies whether or not the job has
{                    configuration control and status.
{
{   STATUS : {output} This parameter specifies the status of the request.
{
{
*DECK DECK=CMH$VALIDATE_NETWORK_CONFIG EXPAND=FALSE
{
{    The purpose of this request is to verify that the network configuration
{ has defined the host network as well as at least one network device.
{
{       CMP$VALIDATE_NETWORK_CONFIG (NETWORK_DESCRIPTOR_LIST, STATUS)
{
{ NETWORK_DESCRIPTOR_LIST: (input)  This parameter specifies the network
{       descriptor list that defines the NAM/VE configuration.  This list will
{       be searched to determine if the host network and at least one network
{       device has been defined.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             cme$lcu_no_host_network_defn
{             cme$lcu_no_netw_device_defn
{      IDENTIFIER: 'CM'
{
*DECK DECK=CMH$VERIFY_CONNECTIONS EXPAND=FALSE

{ COMMON DECK CMHVERC }


{   The purpose of this request is to verify that the logical configuration
{ specified will generate a correct configuration.
{
{       CMP$VERIFY_CONNECTIONS (CONFIGURATION_LIST_FID, CONNECTED_LIST_FID,
{         EXCLUDE_LIST, STATUS)
{
{ CONFIGURATION_LIST_FID: (input) This parameter specifies the the segment
{       access file identifier of the file containing the logical configuration
{       list.
{
{ CONNECTED_LIST_FILE: (input) This parameter specifies the segment access
{       file identifier of the file that will contain the logical configuration
{       list after excluding elements contained in the exclude list.
{
{ EXCLUDE_LIST: (input) This parameter specifies the names of elements to be
{       excluded from the logical configuration.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CMH$VOLUME_ONLINE EXPAND=FALSE

{ COMMON DECK CMHVONL }

{   The purpose of this request is to allow user ring access the device
{ management procedure dmp$volume_online.
{
{       CMP$VOLUME_ONLINE (LOGICAL_UNIT_NUMBER, P_PHYSICAL_ATTRIBUTES, STATUS)
{
{ LOGICAL_UNIT_NUMBER: (input)  This parameter specifies the logical unit number
{       of the unit to be brought online.
{
{ P_PHYSICAL_ATTRIBUTES: (input)  This parameter specifies the physical
{       attributes of the volume.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=CMH$VSN_TOO_LARGE EXPAND=FALSE

{   The purpose of this request is to format the status variable with
{ the vsn and the size of the vsn.
{
{       CMP$VSN_TOO_LARGE (VSN, VSN_SIZE, CONDITION, STATUS)
{
{ VSN: (input)  This parameter specifies the offending vsn.
{
{ VSN_SIZE: (input)  This parameter specifies the size of the offending vsn.
{
{ CONDITION: (input)  This parameter specifies the status condition code.
{
{ STATUS: (output)  This parameter specifie the request status.
{
*DECK DECK=CMK$KEYPOINTS EXPAND=FALSE
{ COMMON DECK CMDKEY }


  CONST

    cmk$build_interface_tables = cmk$base + 1,
    {E 'cmp$build_interface_tables' }
    {X 'cmp$build_interface_tables' 'status' I20 }

    cmk$build_unit_interface_table = cmk$base + 2,
    {E 'cmp$build_unit_interface_table' 'unit cnt' I20 }
    {X 'cmp$build_unit_interface_table' 'status' I20 }

    cmk$build_pp_interface_table = cmk$base + 3,
    {E 'cmp$build_pp_interface_table' 'pp cnt' I20}
    {X 'cmp$build_pp_interface_table' 'status' I20 }

    cmk$build_pct = cmk$base + 4,
    {E 'cmp$build_pct' 'entries' I20 }
    {X 'cmp$build_pct' 'status' I20 }

    cmk$configure_system_device = cmk$base + 5,
    {E 'cmp$configure_system_device' }
    {X 'cmp$configure_system_device' 'status' I20 }

    cmk$get_element_name_via_lun = cmk$base + 6,
    {E 'cmp$get_element_name_via_lun' 'lun' I20 }
    {X 'cmp$get_element_name' 'status' I20 }
    {X 'cmp$get_element_name_via_lun' }

    cmk$get_logical_unit_number = cmk$base + 7,
    {E 'cmp$get_logical_unit_number' }
    {X 'cmp$get_logical_unit_number' 'status' I20 }
    {X 'cmp$get_logical_unit_number' 'lun' I20}

    cmk$pc_get_element = cmk$base + 8,
    {E 'cmp$pc_get_element' 'name' I20 }
    {D 'cmp$pc_get_element' 'loc' I20  }
    {X 'cmp$pc_get_element' 'status' I20 }

    cmk$pc_get_logical_unit = cmk$base + 9,
    {E 'cmp$pc_get_logical_unit' 'lun' I20 }
    {D 'cmp$pc_get_logical_unit' 'loc' I20 }
    {X 'cmp$pc_get_logical_unit' 'status' I20 }

    cmk$pc_get_next_channel = cmk$base + 10,
    {E 'cmp$pc_get_next_channel' 'channel' I20 }
    {D 'cmp$pc_get_next_channel' 'loc' I20 }
    {X 'cmp$pc_get_next_channel' 'status' I20 }

    cmk$setdct_command = cmk$base + 11,
    {E 'syp$setdct_command' }
    {D 'syp$setdct_command' 'controlr' I20 }
    {X 'syp$setdct_command' 'status' I20 }

    cmk$setdd_command = cmk$base + 12,
    {E 'syp$setdd_command' }
    {D 'syp$setdd_command' 'unit' I20 }
    {X 'syp$setdd_command' 'status' I20 }

    cmk$manage_physical_conf = cmk$base + 13,
    {E 'manage_physical_configuration' }
    {X 'manage_physical_configuration' 'status' I20 }

    cmk$set_mainframe = cmk$base + 14,
    {E 'cmp$set_mainframe_definition' }
    {X 'cmp$set_mainframe_definition' 'status' I20 }

    cmk$set_data_channel = cmk$base + 15,
    {E 'cmp$set_data_channel_definition' }
    {X 'cmp$set_data_channel_definition' 'status' I20 }

    cmk$set_controller = cmk$base + 16,
    {E 'cmp$set_controller_definition' }
    {X 'cmp$set_controller_definition' 'status' I20 }

    cmk$set_storage_device = cmk$base + 17,
    {E 'cmp$set_storage_device_defn' }
    {X 'cmp$set_storage_device_defn' 'status' I20 }

    cmk$install_physical_conf = cmk$base + 18,
    {E 'cmp$install_physical_conf' }
    {X 'cmp$install_physical_conf' 'status' I20 }

    cmk$lock_lun_entry = cmk$base + 19,
    {E 'cmp$lock_lun_entry' 'lun' I20 }
    {D 'cmp$lock_lun_entry' 'status' I20 }
    {X 'cmp$lock_lun_entry' 'locked?' I1 }

    cmk$unlock_lun_entry = cmk$base + 20,

    {E 'cmp$unlock_lun_entry' 'lun' I20 }
    {D 'cmp$unlock_lun_entry' 'status' I20 }
    {X 'cmp$unlock_lun_entry' 'freed?' I1 }

    cmk$get_conf_file = cmk$base + 21,
    {E 'cmp$get_conf_file' }
    {X 'cmp$get_conf_file' 'status' I20 }

    cmk$install_conf_file = cmk$base + 22,
    {E 'cmp$install_conf_file' 'df_type' I20 }
    {X 'cmp$install_conf_file' 'status' I20 }

    cmk$initialize_dft = cmk$base + 23,
    {E 'cmp$initialize_dft' }
    {X 'cmp$initialize_dft' 'status' I20 }

    cmk$get_logical_conf_table = cmk$base + 24,
    {E 'cmp$get_logical_conf_table' }
    {X 'cmp$get_logical_conf_table' 'status' I20 }

    cmk$get_physical_conf_table = cmk$base + 25,
    {E 'cmp$get_physical_conf_table' }
    {X 'cmp$get_physical_conf_table' 'status' I20 }

    cmk$update_installed_dft = cmk$base + 26,

    {E 'cmp$update_installed_dft' }
    {X 'cmp$update_installed_dft' 'status' I20 }

    cmk$configure_installed_system = cmk$base + 27,

  {E 'cmp$configure_installed_system' }
  {X 'cmp$configure_installed_system' 'status' I20 }

    cmk$check_initiated_io = cmk$base + 28,

    {E 'cmp$check_initiated_io'}
    {D 'cmp$check_initiated_io' 'req_id' I20}
    {X 'cmp$check_initiated_io'}

    cmk$create_and_submit_io_req = cmk$base + 29,
    {E 'cmp$create_and_submit_io_req'}
    {X 'cmp$create_and_submit_io_req'}

    cmk$create_io_request = cmk$base + 30,
    {E 'cmp$create_io_request'}
    {D 'cmp$create_io_requst' 'req_id' I20}
    {X 'cmp$create_io_request'}

    cmk$destroy_io_request = cmk$base + 31,
    {E 'cmp$destroy_io_request'}
    {D 'cmp$destroy_io_request' 'req_id' I20}
    {X 'cmp$destroy_io_request'}

    cmk$queue_io_request = cmk$base + 32,
    {E 'cmp$queue_io_request'}
    {D 'cmp$queue_io_request' 'req_id' I20}
    {X 'cmp$queue_io_request'}

    cmk$complete_ssiot_recovery = cmk$base + 33,
    {E 'cmp$complete_ssiot_recovery'}
    {X 'cmp$complete_ssiot_recovery'}

    cmk$destroy_io_completion_table = cmk$base + 34,
    {E 'cmp$destroy_io_completion_table'}
    {X 'cmp$destroy_io_completion_table'}

    cmk$recover_subsystem_io_table = cmk$base + 35,
    {E 'cmp$recover_subsystem_io_table'}
    {X 'cmp$recover_subsystem_io_table'}

    cmk$build_pp_queue_request = cmk$base + 36,
    {E 'cmp$build_pp_queue_request'}
    {X 'cmp$build_pp_queue_request'}

    cmk$build_unit_queue_request = cmk$base + 37,
    {E 'cmp$build_unit_queue_request'}
    {X 'cmp$build_unit_queue_request'}

    cmk$destroy_io_queue_req_r2 = cmk$base + 38,
    {E 'cmp$destroy_io_queue_req_r2'}
    {X 'cmp$destroy_io_queue_req_r2'}

    cmk$mfh_subsystem_io_completion = cmk$base + 39,
    {E 'cmp$mfh_subsystem_io_completion'}
    {D 'cmp$mfh_subsystem_io_completion' 'req_id' I20}
    {X 'cmp$mfh_subsystem_io_completion'}

    cmk$queue_pp_request = cmk$base + 40,
    {E 'cmp$queue_pp_request_r1'}
    {X 'cmp$queue_pp_request_r1'}

    cmk$queue_unit_request = cmk$base + 41,
    {E 'cmp$queue_unit_request_r1'}
    {X 'cmp$queue_unit_request_r1'}

    cmk$process_subsys_io_response = cmk$base + 42,
    {E 'cmp$subsys_process_pp_response'}
    {X 'cmp$subsys_process_pp_response'}

    cmk$subsystem_queue_io_request = cmk$base + 43,
    {E 'cmp$subsystem_queue_request'}
    {X 'cmp$subsystem_queue_request'}

    cmk$build_wired_queue_request = cmk$base + 44,
    {E 'cmp$build_wired_queue_request'}
    {X 'cmp$build_wired_queue_request'}

    cmk$queue_request_r1 = cmk$base + 45;
    {E 'cmp$queue_request_r1'}
    {X 'cmp$queue_request_r1'}

*copyc AMK$BASE_KEYPOINT_VALUES
*DECK DECK=CML$10395_11_FAILURE_DATA EXPAND=FALSE
{
{ CML$10395_11_FAILURE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record the failure data
{ captured by the system when accessing a 10395_11 disk controller.
{
{ FREQUENCY: At each failure occurrence.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<ch>.<cm>.<unit>*<vsn>*<class>*..
{       <message>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where  <pp>  is the string 'PPn' where n is the PP number (in
{        decimal) of the PP which performed the i/o operation  which
{        is being reported.
{
{      where  <ch>  is  the string 'CHn' where n is the channel
{        number  (in  decimal)  over  which  the  i/o  request   was
{        processed.
{
{      where  <cm>  is  the  element  name  of  the   disk   control
{        module (controller) used in the failing request.
{
{      where  <unit> is the element name of the failing disk storage
{        device used in the failing request.
{
{      where <vsn> is the recorded-vsn of the disk volume which  was
{        the object of the failing request.
{
{      where  <class>  is  the string 'UF' for unrecovered, 'RF' for
{        recovered, 'IF' for intermediate failure log-entry, and 'IM'
{        for an informative message.
{
{        The PP reports failure data and diagnostic results  as  an
{        intermediate  failure  log-entry  prior  to retrying an i/o
{        request.  This is due to  PP-memory-size  limitations.   An
{        intermediate    failure    log-entry   will   provide   the
{        first-failure data captured by the PP  during  the  initial
{        attempt  at  the  request  or  during  a subsequent request
{        retry.  This  log-entry  provides  the  initial  and  final
{        failure data for an intermediate, unsuccessful i/o request
{        retry.  At least  one  additional  request  retry  will  be
{        performed after this log-entry is made.
{
{        For  unrecovered  disk failures the counter values contain
{        the failure data corresponding  to  the  last  unsuccessful
{        retry of the i/o request.  This log-entry provides
{        the   initial   and  final  failure  data  for  the  final,
{        unsuccessful i/o request retry.
{
{        For  failures  corrected  during  sector-oriented  (media)
{        recovery, the counter values contain the first-failure data
{        captured by  the  PP.   This  log-entry  is  only  made  to
{        document successful sector-oriented recovery.
{
{      where  <message> is a statement of failure isolation based on
{        either diagnostic execution or status reported by subsystem:
{
{        ADAPTER FAILURE <code>
{        CONTROL MODULE FAILURE <code>
{        DRIVE FAILURE <code>
{          The <code> clause, a hex value which is optionally
{          appended to the messages documented above, is the
{          diagnostic code reported by the subsystem when an inline
{          diagnostic has isolated a failure to the indicated
{          subsystem element.  The diagnostic code is also reported
{          in counter-value 10.  Absence  of  the  <code> clause
{          indicates that the Adapter suspects the failure to be in
{          the indicated box; however, the failure could not be
{          isolated by diagnostics.
{
{       MEDIA FAILURE - Cccc Ttt Sss
{          The cylinder (ccc), track (tt) and sector (ss) are
{          expressed in decimal.  The location of the media failure
{          is also reported in counter-values 14, 15 and 16.
{
{       <symptom statement>
{          The symptom  statement  is  provided  for  those failures
{          which could not be isolated to a particular element.
{          The text of the possible symptom statements is
{          identical in content to the uppercase text discussed
{          under counter-value 8 below.
{
{
{    1.  Logical PP number (bits 58 - 63).
{        Bits 46 - 51 contain the IOU number.
{
{    2.  Channel Number (bits 58 - 63).
{        Bits 46 - 51 contain the IOU number.
{
{    3.  Address of Control Module
{    4.  Physical Unit Number
{    5.  Unit-type
{        3 - 834-12
{    6.  Logical Operation Code
{        1 - read
{        2 - write
{    7.  Log-entry Class
{        0 - Recovered Failure Report
{        1 - Unrecovered Failure Report
{        2 - Intermediate Failure Report
{        3 - Informative Message
{    8.  Failure Analysis
{        Indicates the extent to which the subsystem and the PP were
{        able to isolate  the  failure when it was detected.  The
{        failure data is analyzed in the order in which the following
{        symptom statements are presented in this paper.  Therefore,
{        should multiple failures occur and be implied in the failure
{        data, only one symptom statement will be provided;  the one
{        provided will be the one appearing first in the following
{        list of symptoms.
{
{    0 - INDETERMINATE        The   failure  did  not  manifest
{                             itself as one  of  the  following
{                             symptoms.    Refer  to  the  Poll
{                             Status and  Detailed  Status  for
{                             additional information.
{
{    Failures reported to be in the Adapter, Control Module,
{    Drive or Media are confirmed either by subsystem
{    diagnostics or by attempting to reload the controlware
{    for a subsystem element.
{
{    1 - PP TIMED OUT A COMMAND    A command sent to the Adapter and
{                                  or Control Module was not
{                                  responded to in the allotted time.
{
{    2 - CONTROL MODULE RESERVED   The Control Module was reserved to
{                                  another host adapter.
{
{    3 - SOFTWARE FAILURE          A software failure was detected by
{                                  the PP driver.
{
{    4 - DRIVE NOT READY           The  Control  Module  reported  a
{                                  manual   intervention   code   of
{                                  C1(16)  but  there  was  no drive
{                                  fault; the Adapter  reports  this
{                                  as  a  Poll  Status  of  440xx(8).
{                                  This failure indicates  that  the
{                                  drive  is  not  spinning.  The PP
{                                  driver automatically  spins-up  a
{                                  drive   if   this   condition  is
{                                  detected; therefore if this is an
{                                  unrecovered  failure,  the  CE or
{                                  Operator  may  have  placed   the
{                                  LOC/REM  switch of the FSD in the
{                                  LOC position.  Placing the switch
{                                  in  the LOC position prevents the
{                                  PP from spinning  up  the  drive.
{                                  The PP cannot determine the state
{                                  of    the     LOC/REM     switch.
{                                  Therefore,  if  the  switch is in
{                                  the LOC position  either  depress
{                                  the   START  button  or  set  the
{                                  LOC/REM switch to the REM  state.
{
{    5 - RELOADING CONTROL MODULE  A Control Module microcode reload
{                                  was initiated.
{
{    6 - CONTROL MODULE RELOADED   The Control Module microcode was
{                                  successfully reloaded.
{
{    7 - EXECUTING LEVEL II DIAGNOSTICS   Execution of LEVEL II
{                                  inline diagnostics was initiated.
{
{    8 - LEVEL II DIAGNOSTICS PASSED      Level II diagnostics ran
{                                  successfully.
{
{    9 - DRIVE NOT PRESENT         The  Control  Module  reported  a
{                                  manual   intervention   code   of
{                                  C3(16) indicating  there  was  no
{                                  response from the drive.
{
{    10 -MEDIA FAILURE             This  indicates that a 'bad-spot'
{                                  has  developed   on   the   media
{                                  surface or there is a less likely
{                                  possibility  that  there  was  an
{                                  intermittent   failure  when  the
{                                  sector  was  originally   written
{                                  which  was not detected until the
{                                  subsequent read.
{
{    11 -FUNCTION FAILURE CLASS 2  The  channel-error-flag  was  set
{                                  and the Adapter failed to respond
{                                  to a function attempt.
{
{    12 -FUNCTION FAILURE CLASS 3  The channel-error-flag was  not
{                                  set  and  the  Adapter  failed to
{                                  respond to a function attempt.
{
{    13 -INPUT ICI PARITY          On an input from the  Adapter  to
{                                  the PP the channel-error-flag was
{                                  set.
{
{    14 -OUTPUT ICI PARITY CLASS 1 On an output from the PP  to  the
{                                  Adapter   the  channel-error-flag
{                                  was set and the Adapter  reported
{                                  the parity error.  The IOU is the
{                                  likely cause of the  problem  but
{                                  this is not a certainty.
{
{    15 -OUTPUT ICI PARITY CLASS 2 On  an  output from the PP to the
{                                  Adapter  the   channel-error-flag
{                                  was set but the Adapter did not
{                                  report a parity error.
{
{    16 -OUTPUT ICI PARITY CLASS 3 On an output from the PP  to  the
{                                  Adapter  the  Adapter  reported a
{                                  parity     error     but      the
{                                  channel-error-flag was not set.
{
{    17 -ADAPTER RAM PARITY        The  Adapter  reported  a  parity
{                                  error in its RAM memory.
{
{    18 -ADAPTER BUFFER PARITY     A  parity  error  was detected in
{                                  the Adapter's buffer memory.
{
{    19 -ADAPTER ROM PARITY        A parity error  was  detected  in
{                                  the  Adapter's  ROM  (poll status
{                                  5014).
{
{    20 -START SWITCH NOT DEPRESSED   Spin-up of the storage device
{                                  failed because the start switch
{                                  was not depressed.
{
{    21 -ISI PARITY                On  an  input or an output between
{                                  the Control Module and the Adapter
{                                  the Adapter reported a parity
{                                  error but the Control Module did
{                                  not.
{
{    22 -OUTPUT ISI PARITY CLASS 1 On  an output from the Adapter to
{                                  the  Control  Module   both   the
{                                  Adapter  and  the  Control Module
{                                  reported a parity  error  on  the
{                                  ISI channel.
{
{    23 -OUTPUT ISI PARITY CLASS 3 On  an output from the Adapter to
{                                  the Control  Module  the  Control
{                                  Module reported a parity error on
{                                  the ISI channel and  the  Adapter
{                                  did not.
{
{    24 -SEEK ERROR                The  Control  Module  reported  a
{                                  system   intervention   code   of
{                                  21(16) indicating a seek fault or
{                                  a    sector    header     address
{                                  miscompare.
{
{    25 -UNABLE TO READ HEADER     The  Control  Module  reported  a
{                                  system   intervention   code   of
{                                  41(16)  indicating  it was unable
{                                  to read the header portion of the
{                                  sector.
{
{    26 -UNABLE TO READ DATA       The   Control   Module   reported
{                                  system   intervention   code   of
{                                  43(16)  indicating  either a Sync
{                                  Byte  detection  problem   or   a
{                                  header ECC mismatch.
{
{    27 -ISI DEADMAN TIME-OUT      The    Adapter    detected     an
{                                  expiration  of  the deadman timer
{                                  on a data transfer between itself
{                                  and the Control Module.
{
{    28 -CM SCHEDULER PARITY       The  Control  Module  reported  a
{                                  manual   intervention   code   of
{                                  64(16) indicating a R/W Scheduler
{                                  memory parity error.
{
{    29 -CM MPU PARITY             The  Control  Module  reported  a
{                                  manual   intervention   code   of
{                                  65(16)  indicating  an MPU memory
{                                  parity error.
{
{    30 -CM R/W HARDWARE FAULT     The  Control  Module  reported  a
{                                  manual   intervention   code   of
{                                  66(16).
{
{    31 -DRIVE VOLTAGE FAULT       The  Control  Module  reported  a
{                                  manual   intervention   code   of
{                                  67(16).
{
{    32 -OVER TEMPERATURE FAULT    The  Control  Module  reported  a
{                                  manual   intervention   code   of
{                                  6B(16).
{
{    33 -INVALID BOOTSTRAP ERROR   Manual Intervention Status 69(16)
{                                  was reported by the Control
{                                  Module.
{
{    34 -DRIVE WRITE PROTECTED     The  Control  Module  reported  a
{                                  manual   intervention   code   of
{                                  C2(16) indicating that the system
{                                  attempted  to  write on the drive
{                                  but  the  drive's  WRITE  PROTECT
{                                  switch was set.
{
{    35 -INCOMPLETE ICI TRANSFER   The  PP's A-register was non-zero
{                                  after   the   ICI   channel   was
{                                  inactivated    during    a   data
{                                  transfer  and  Poll  Status   was
{                                  normal.   Refer  to  the Residual
{                                  Byte Count below to see how  many
{                                  16-bit bytes were lost.
{
{    36 -LOOPBACK COMPARE ERROR    A  compare  error was detected by
{                                  the  Adapter  when  looping  data
{                                  between   the   Adapter  and  the
{                                  Control Module.
{
{    37 -LOOPBACK SELECT ACTIVE    The select active state  did  not
{                                  drop  when  a  word  sent  to the
{                                  Control Module from  the  Adapter
{                                  had a parity error.
{
{    38 -LOOPBACK ATTENTION        The attention status was not sent
{                                  by the Control Module  after  the
{                                  Adapter sent a word with a parity
{                                  error.
{
{    39 -LOOPBACK CHECK FAILURE    The  Control  Module  failed   to
{                                  report   an  ISI  channel  parity
{                                  error when  the  Adapter  sent  a
{                                  word   with  bad  parity  to  the
{                                  Control Module.
{
{    40 -CONTROL MODULE FAILURE   The failure was isolated to the
{                                 Control Module.
{
{    41 -ADAPTER FAILURE          The failure was isolated to the
{                                 7255-1 adapter.
{
{    42 -DRIVE FAILURE            The failure was isolated to the
{                                 storage device (drive).
{
{    43 -ADAPTER CONTROLWARE ERROR  An error most likely caused by
{                                 the adapter.  Some of the possible
{                                 causes are: wrong status after load
{                                 attention delay, wrong status after
{                                 sending controlware, status asking
{                                 for more data when there is none,
{                                 and status saying the read or write
{                                 command is complete when there is
{                                 more data to transfer.
{
{    44 -PP - ADAPTER DATA INTEGRITY  An interface test transferred
{                                 data between the PP and the adapter.
{                                 No error was detected, but the data
{                                 miscompared.
{
{    45 -PP - DRIVE DATA INTEGRITY  A confidence test wrote data to a
{                                 drive, then read it back.  No error
{                                 was detected, but the data miscompared.
{
{    9.  Request Retry Count      The number of times the PP driver
{                                 retried the  entire  i/o  request
{                                 from the beginning.
{
{    10. Diagnostic Code          Provides  the result of a failing
{                                 diagnostic.
{
{    11. Cylinder number of initial seek
{
{    12. Track number of initial seek
{
{    13. Sector number of initial seek
{
{    14. Cylinder number of failure - This is normally the cylinder
{        number in the disk request.  However, if the failure occurred
{        while running the confidence test, the cylinder number will be
{        815 for an 834 drive and 699 for an 836 drive (the confidence
{        test cylinder).
{
{    15. Track number of failure
{
{    16. Sector number of failure
{
{    17. Residual byte count on incomplete channel transfer
{
{
{    18. Failing Function         The   function  that  caused  the
{                                 initial  recovery  attempt.   The
{                                 value   is   extracted  from  the
{                                 initial detailed  status  if  the
{                                 Adapter provides status after the
{                                 failure.  On a function  timeout,
{                                 the  function reported is the one
{                                 which was  outstanding  when  the
{                                 Adapter hung.
{
{   First-failure Data:
{    19.       Poll Status
{                    (right justified)
{    20 .. 39. Words 1..20 of Detailed Status
{                    (right justified)
{
{   The following failure data is only provided in the
{   cases where the Log-entry Class is unrecovered or
{   intermediate.  The data represents the subsystem
{   status at the end of the intermediate or final
{   request retry.
{
{   Last-failure Data:
{    40.       Poll Status
{                    (right justified)
{    41 .. 60. Words 1..20 of Detailed Status
{                    (right justified)
{

  CONST
    cml$10395_11_failure_data = cmc$min_ecc + 4102;

*copyc cmc$condition_limits
*DECK DECK=CML$5380_100_LSP_FAILURE_DATA EXPAND=FALSE
{
{ DECK: CML$5380_100_LSP_FAILURE_DATA
*copyc cmh$lsp_failure_data_doc

  CONST
    cml$5380_100_lsp_failure_data = cmc$min_ecc + 7302;

*copyc cmc$condition_limits

*DECK DECK=CML$5380_100_SDP_FAILURE_DATA EXPAND=FALSE
{
{ DECK: CML$5380_100_SDP_FAILURE_DATA

*copyc cmh$sdp_failure_data_doc

  CONST
    cml$5380_100_sdp_failure_data = cmc$min_ecc + 7300;

*copyc cmc$condition_limits

*DECK DECK=CML$5680_11_FAILURE_DATA EXPAND=FALSE
{
{ CML$5680_11_FAILURE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record the failure data
{ captured by the system when accessing a CCC Cyber Cartridge Tape
{ Subsystem ($5680_11).
{
{ FREQUENCY: At each failure occurrence.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{     <mf>.<iou>.<pp>.<channel>.<eq>.<unit>*<vsn>*<severity>..
{       *<symptom>
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is the string 'PPn' or 'CPPn' where n is the
{       logical PP number in decimal of the PP used to process the
{       failing request.
{
{      where <channel> is the string 'CHn' or 'CCHn' where n is the
{       channel number in decimal through which the tape device was
{       accessed.
{
{      where <eq> is the element name of the $5680_11 used in the
{        failing request.
{
{      where  <unit> is the element name of the failing tape storage
{        device used in the failing request.
{
{      where <vsn> is the external-vsn of the tape volume which  was
{        the object of the failing request.
{
{      where <severity> is the string 'UF'  for  unrecovered or 'RF'
{        for recovered message.
{
{      where <symptom> is the symptom/action statement  provided  by
{        the system.
{
{    The  counter-value portion of this statistic contains:
{
{    1.  Logical PP number
{        Bits 46 thru 51 contain the IOU number of the PP.
{        Bit 57 = 0 implies that the PP is an NIO PP.
{        Bit 57 = 1 implies that the PP is an I4 concurrent (CIO) PP.
{        Bits 58 thru 63 contain the logical PP number.
{    2.  Channel Number of channel coupler
{        Bits 0 thru 15 contain the initial C170/DMA channel Error
{         Status Register (only valid if bit 57 = 1).
{        Bits 16 thru 31 contain the final C170/DMA channel Error
{         Status Register (only valid if bit 57 = 1).
{        Bits 46 thru 51 contain the IOU number of the channel.
{        Bit 57 = 0 implies that the channel is an NIO channel
{        Bit 57 = 1 implies that the channel is an I4 concurrent
{         (CIO) channel.
{        Bits 58 thru 63 contain the channel number.
{    3.  Equipment Number of the $5680_11
{    4.  Physical Unit Number
{    5.  Unit-type
{       10 - $5682_12 or $5682_14
{    6.  Logical Operation Code
{       0 - none (unsolicited response from PP)
{       1 - read
{       2 - write
{       3 - rewind
{       4 - unload
{       5 - locate_block
{       6 - write_tapemark
{       7 - erase
{       8 - forespace_record
{       9 - backspace_record
{       10 - forespace_tapemark(s)
{       11 - backspace_tapemark(s)
{       12 - get_status
{    7.  Failure Severity
{       0 - Recovered Failure
{       1 - Unrecovered Failure
{    8.  Failure Symptom Code (tells what the system thinks is wrong)
{
{       1 - INDETERMINATE - The error did not manifest into one of the
{                           following symptom codes.
{
{       2 - INPUT CHANNEL PARITY - On an input from controller to PP
{                                  the channel-error-flag was set.
{
{       3 - OUTPUT CHANNEL PARITY - On an output from the PP to the controller,
{                                   the controller reported a parity error in
{                                   detailed status but the channel-error-flag
{                                   was not set.
{
{       4 - COUPLER FAILURE - An error has been detected in the CCC.
{                             Refer to detailed status for further
{                             information.
{
{       5 - CONTROL UNIT FAILURE - An error has been detected in the
{                                  Control Unit.  Refer to sense byte
{                                  3 (ERPA code) for further information.
{
{       6 - UNIT FAILURE - The drive is offline or a unit check has
{                          occurred.  Refer to detailed status for
{                          for further information.
{
{       7 - UNIT NOT READY - The unit does not have a tape loaded or the
{                            unit has dropped ready during a motion
{                            function.
{
{       8 - FUNCTION TIMEOUT - The channel coupler is not responding
{                              to functions.
{
{       9 - TAPE MEDIUM FAILURE - This indicates a defect was present
{                                 on the tape media.
{
{      10 - IOU OUTPUT PARITY - On an output from PP to controller
{                               both the channel-error-flag and the controller's
{                               detailed status indicated a parity error had
{                               occurred.
{
{      11 - INDETERMINATE OUTPUT PARITY - On an output from PP to controller
{                                         the channel-error-flag was set but there
{                                         was no parity error reported by the
{                                         controller.
{
{      12 - UNABLE TO WRITE ID MARK - The id-mark could not be written
{                                     at load point.
{
{      13 - UNABLE TO READ ID MARK - The drive was not capable of reading the
{                                    density mark at loadpoint.
{
{      14 - HARDWARE CORRECTIONS - The reported hardware status indicated that On-The-Fly
{                                  read or write corrections were made while the tape file
{                                  was active or that hardware controlled read or write error
{                                  recovery occurred.  This symptom code indicates a count is
{                                  present in some or all of counter words 11, 12, 15, 16 and 34.
{                                  In most cases, this symptom code is the ONLY way to know
{                                  if read/write recovered errors occurred on a cartridge.
{                                  This symptom code is always logged as an *RF* message.
{                                  The status counter words (21 - 32) are zero when this
{                                  symptom code is issued.
{
{      15 - MICROCODE LOAD ERROR - An error occurred when the PP attempted to load
{                                  the CCC microcode.  Refer to General Status for
{                                  the specific error.  Possible values of general status
{                                  are (in octal):
{                                     5xxx - where xxx is adapter error code (refer to
{                                            MB468 microcode ERS.
{                                     7777 - Autoload function timeout.
{                                     7776 - Output channel error flag set.
{                                     7775 - Input channel error flag set.
{                                     7774 - CY170 CIO channel adapter error.
{                                     7773 - CIO channel function error flag set.
{                                     7772 - Status function timeout after autoload.
{                                     7771 - Incomplete transfer during autoload.
{                                     7770 - Software failure - driver does not support unit type.
{
{      16 - BLOCK ID INVALID - The controller has encountered an invalid Block-ID.  This
{                              can occur on a read, write or locate block operation.  This
{                              error can indicate a hardware failure or media failure.
{
{      17 - INCOMPLETE TRANSFER ON INPUT - The PP driver has detected an incomplete data
{                                          or status transfer during an input operation.
{                                          A non-zero value was in the PP A-register after
{                                          an input instruction terminated.
{
{      18 - INCOMPLETE TRANSFER ON OUTPUT - The PP driver has detected an incomplete data
{                                           or parameter transfer during an output operation.
{                                           A non-zero value was in the PP A-register after
{                                           an output instruction terminated.
{
{      19 - CHANNEL FLAG ERROR - During a read or write operation the master or slave PP
{                                lost synchronization with its partner.  This can occur
{                                when the channel flag was clear when it was expected to
{                                be set or set when it was expected to be clear.
{
{      20 thru 28 - SOFTWARE FAILURE - The CPU or PP has detected a logical inconsistency
{                                      in the tape subsystem.  The symptom code value
{                                      defines the exact failure.
{
{    9.   Blocks written on Unit
{    10.  Blocks read on Unit
{    11.  On The Fly read corrections count
{    12.  On The Fly write corrections count
{    13.  Absolute Block Count from Load Point
{    14.  Absolute number of Tape/File Marks from Load Point
{    15.  Hardware read error recovery count
{    16.  Hardware write error recovery count
{    17.  Last functions issued
{         Bits 48 - 63 = Last function issued
{         Bits 32 - 47 = Last non-status function issued
{         Bits 0 - 31 = Reserved (zero)
{    18.  Retry count of recovery attempts
{    19.  First failure I4 error status register
{         Bits 48 - 63 = Error status register (zero if not CIO channel)
{         Bits 0 - 47 = Reserved (zero)
{    20.  Last failure I4 error status register
{         Bits 48 - 63 = Error status register (zero if not CIO channel)
{         Bits 0 - 47 = Reserved (zero)
{
{   First-failure Data:
{    21.       Initial General and Detailed Status.  The format of the
{              counter word is as follows.
{               Bits 0 - 3 = 0.
{               Bits 4 - 15 = General Status.
{               Bits 16 - 19 = 0.
{               Bits 20 - 31 = Detailed Status.
{               Bits 32 - 63 = Last Good Block ID.
{               Refer to the MB468 Controlware ERS for the meaning
{               of the status bits.
{    22 .. 26.  Initial Extended Status (FIPS Sense Bytes)
{               Refer to the MB468 Controlware ERS for the meaning
{               of the sense byte bits.
{
{   Last-failure Data:
{    27.       Final General and Detailed Status.  The format of the
{              counter word is as follows.
{               Bits 0 - 3 = 0.
{               Bits 4 - 15 = General Status.
{               Bits 16 - 19 = 0.
{               Bits 20 - 31 = Detailed Status.
{               Bits 32 - 63 = Last Good Block ID.
{               Refer to the MB468 Controlware ERS for the meaning
{               of the status bits.
{    28 .. 32.  Final Extended Status (FIPS Sense Bytes)
{               Refer to the MB468 Controlware ERS for the meaning
{               of the sense byte bits.
{
{    33.        Density at which the unit was operating (currently always 38000)
{    34.        CU buffer underrun count (indicates high volume of CM conflicts)
{    35.        Reserved
{    36.        Reserved

  CONST
    cml$5680_11_failure_data = cmc$min_ecc + 5104;

*copyc cmc$condition_limits
*DECK DECK=CML$5698_1X_FAILURE_DATA EXPAND=FALSE
{
{ CML$5698_1X_FAILURE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record the failure data
{ captured by the system when accessing a Cyber Magnetic Tape
{ Subsystem thru an IPI channel (CMTS/IPI).
{
{ FREQUENCY: At each failure occurrence.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<channel>.<slave>.<facility>*<vsn>*<severity>..
{       *<symptom>
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is the string 'PPn' where n is the logical PP
{       number in decimal of the PP used to process the failing
{       request.
{
{      where <channel> is the string 'CHn' where n is the channel
{       number in decimal through which the tape device was
{       accessed.
{
{      where <slave> is the element name of the Equipment (slave)
{        used in the failing request.
{
{      where  <facility> is the element name of the failing tape storage
{        device (facility) used in the failing request.  If the element
{        is $NULL, the engineering log message was issued as a result
{        if an unsolicited response from the PP driver.  $NULL indicates
{        the message is applicable to the slave and there is no facility
{        applicable.
{
{      where <vsn> is the external-vsn of the tape volume which  was
{        the object of the failing request.
{
{      where <severity> is the string 'UF'  for  unrecovered,  'RF'  for
{        recovered,  'IF'  for  intermediate and 'IM' for informative
{        message.
{
{      where <symptom> is the symptom/action statement  provided  by
{        the system.
{
{    The  counter-value portion of this statistic contains:
{
{    1.  Logical PP number
{        Bits 46 thru 51 contain the IOU number of the PP.
{        Bit 57 = 1 implies that the PP is an I4 concurrent PP.
{        Bits 58 thru 63 contain the logical PP number.
{    2.  Channel Number
{        Bits 46 thru 51 contain the IOU number of the channel.
{        Bit 55 is set to 1 if I4 channel port A.
{        Bit 56 is set to 1 if I4 channel port B.
{        Bit 57 = 1 implies that the channel is an I4 concurrent
{         channel.
{        Bits 58 thru 63 contain the channel number.
{    3.  Equipment Number of the slave (Slave address)
{    4.  Physical Facility Number (Facility address)
{    5.  Unit-type
{       9 - 698-3X  (IPI)
{    6.  Logical Operation Code
{       0 - none (unsolicited response from PP)
{       1 - read
{       2 - write
{       3 - rewind
{       4 - unload
{       6 - write_tapemark
{       7 - erase
{       8 - forespace
{       9 - backspace
{       10 - forespace_tapemark(s)
{       11 - backspace_tapemark(s)
{       12 - get_status
{    7.  Failure Severity
{       0 - Recovered Failure
{       1 - Unrecovered Failure
{       2 - Intermediate Failure Report
{       3 - Informative Message
{    8.  Failure Analysis
{       This indicates the extent to which the subsystem and  the  PP
{       were  able  to isolate the failure when it was detected.  The
{       failure data is analyzed in the order in which the  following
{       symptom   statements   are   presented   in   this  document.
{       Therefore, should multiple failures occur and be  implied  in
{       the   failure  data,  only  one  symptom  statement  will  be
{       provided; the one provided will be the one appearing first in
{       the following list of symptoms.  For all error codes, counter
{       words 9 - 17 contain valid data, but may not be applicable to
{       a particular failure.
{
{       0 - INDETERMINATE           The   failure  did  not  manifest
{                                   itself as one  of  the  following
{                                   symptoms.   Refer to the Response
{                                   Packet       for       additional
{                                   information.
{
{         The following symptom statements are isolated to  the  IOU.
{       They  can  not  be  caused  by  either the slave or the cable
{       between  the  PP  and  slave.   Counter  words  1-8,  18  and
{       referenced  words  are  applicable  to  the following symptom
{       statements.  For errors that  refer  to  IPI  channel  status
{       register,  IPI  channel  error  register  or I4 IPI DMA error
{       register, refer to counter words 20, 21 or 22,  respectively.
{
{       1 - FUNCTION TIMEOUT        The  IPI  channel did not respond
{                                   to a function.  Counter  word  19
{                                   contains  the function or bits 52
{                                   and/or  53  of  the  IPI  channel
{                                   error register are set.
{
{       2 - CHANNEL EMPTY WHEN ACTIVATED  The  IPI  channel  did  not
{                                   force the channel  full  when  it
{                                   was activated.
{
{       3 - PERIOD COUNTER ERROR    This is bit 51 of the IPI channel
{                                   error register.
{
{       4 - UPPER ICI PARITY        This is bit 57 of the IPI channel
{                                   error register and indicates that
{                                   a parity error  has  occurred  on
{                                   the  most significant byte of the
{                                   channel between the IPI chip  and
{                                   the PP.
{
{       5 - LOWER ICI PARITY        This is bit 58 if the IPI channel
{                                   error register  and  indicates  a
{                                   parity  error has occurred on the
{                                   least  significant  byte  of  the
{                                   channel  between the IPI chip and
{                                   the PP.
{
{       6 - IOU ERROR               The channel error flag is set and
{                                   none  of  the  bits  in  the  IPI
{                                   channel error register or I4  IPI
{                                   DMA error register are set.
{
{       7 - INCOMPLETE I4 TRANSFER  The  PP's  A register was nonzero
{                                   after  an  output  of   parameter
{                                   words.
{
{       8 - CHANNEL NOT EMPTY       The  I4  channel did not go empty
{                                   after  the  output  of  parameter
{                                   words.
{
{       9 - CENTRAL MEMORY ERROR    This indicates that bit 50 or bit
{                                   51  of  the  I4  IPI  DMA   error
{                                   register  is  set  and  that   an
{                                   uncorrected   or   reject   error
{                                   response   was   received    from
{                                   central memory.
{
{       10 - INVALID CM RESPONSE CODE  This  is  bit 52 of the I4 IPI
{                                   DMA error register and  indicates
{                                   the  response  code  from central
{                                   memory decoded  into  an  illegal
{                                   value.
{
{       11 - CM RESPONSE CODE PARITY ERROR  This  is bit 53 of the I4
{                                   IPI  DMA   error   register   and
{                                   indicates  that the response code
{                                   from central memory had a  parity
{                                   error.
{
{       12 - CMI READ DATA PARITY ERROR  This is bit 54 if the I4 IPI
{                                   DMA error register and  indicates
{                                   that the central memory interface
{                                   logic has detected  a  read  data
{                                   parity error.
{
{       13 - JY DATA ERROR          This  is bit 59 of the I4 IPI DMA
{                                   error register and indicates that
{                                   the  JY board has detected a data
{                                   parity error.
{
{       14 - BAS PARITY ERROR       This is bit 60 of the I4 IPI  DMA
{                                   error register and indicates that
{                                   the  LX  board  has  detected   a
{                                   parity  error  on  data  received
{                                   from the barrel and slot  of  the
{                                   PP.
{
{       15 - LZ ERROR               This  is bit 61 of the I4 IPI DMA
{                                   error register and indicates that
{                                   the  LZ  board  has  detected  an
{                                   error.
{
{       16 - JY ERROR               This is bit 62 of the I4 IPI  DMA
{                                   error register and indicates that
{                                   the  JY  board  has  detected  an
{                                   error.
{
{       17 - LX ERROR               This  is bit 63 of the I4 IPI DMA
{                                   error register and indicates that
{                                   the  LX  board  has  detected  an
{                                   error.
{
{       18 - DMA TEST MODE FAILURE  Test mode was used to  pass  data
{                                   through  the  adapter.   No  bits
{                                   were set in the I4 IPI channel or
{                                   I4  IPI  DMA error registers, but
{                                   the data was incorrect.
{
{       19 - ILLEGAL OPERATION      This is bit 62 of the IPI channel
{                                   error   register   and  indicates
{                                   detection of an illegal  function
{                                   code.
{
{         The  following  symptom  statements are most likely a slave
{       problem but may be caused by the IOU, IPI channel  or  cable.
{       Counter words 1-8, 18 and referenced words are applicable for
{       the following symptom statements.  For errors that  refer  to
{       IPI channel status register, IPI channel error register or I4
{       IPI DMA error register, refer to counter words 20, 21 or  22,
{       respectively.
{
{       20 - CANNOT SELECT CONTROLLER The  SLAVE IN  line was not set
{                                   after the PP sent the select code
{                                   to the slave.
{
{       21 - BIT SIGNIFICANT RESPONSE ERROR   The   bit   significant
{                                   response which is in  bits  56-63
{                                   of   the   IPI   channel   status
{                                   register is incorrect.
{
{       22 - NO SYNC IN             During  a  bus  control  sequence
{                                   SYNC IN did not set.
{
{       23 - SYNC IN DID NOT DROP   During  a  bus  control  sequence
{                                   SYNC IN did not drop.
{
{       24 - IPI SEQUENCE ERROR     This is bit 59 of the IPI channel
{                                   error  register  and indicates an
{                                   illegal   sequence   of   control
{                                   signals  has  occurred on the IPI
{                                   interface.
{
{       25 - UPPER IPI CHANNEL PARITY This  is  bit  60  of  the  IPI
{                                   channel    error   register   and
{                                   indicates that  the  IPI  channel
{                                   has  detected  a  parity error on
{                                   bus A of the IPI interface.
{
{       26 - LOWER IPI CHANNEL PARITY This  is  bit  61  of  the  IPI
{                                   channel    error   register   and
{                                   indicates that  the  IPI  channel
{                                   has  detected  a  parity error on
{                                   bus B of the IPI interface.
{
{       27 - SLAVE IN NOT SET       During an ending status  sequence
{                                   or  a  request  transfer settings
{                                   sequence SLAVE IN did not set.
{
{       28 - SLAVE IN DID NOT DROP  During a deselect sequence  or  a
{                                   request     transfer     settings
{                                   sequence SLAVE IN did not drop.
{
{       29 - INCOMPLETE TRANSFER    Not all  words  were  transferred
{                                   when the channel was inactivated.
{                                   Status from  the  slave  did  not
{                                   indicate an error.
{
{       30 - CHANNEL STAYED ACTIVE  Following an information exchange
{                                   the slave did not drop SLAVE  IN.
{                                   The slave drops SLAVE IN when the
{                                   last word has been transferred or
{                                   if no words have been transferred
{                                   for its timeout limit of about 25
{                                   milliseconds.
{
{       31 - BUFFER COUNTER ERROR   This is bit 48 of the IPI channel
{                                   error register.
{
{       32 - SYNC COUNTER ERROR     This is bit 50 of the IPI channel
{                                   error register.
{
{       33 - LOST DATA              This is bit 56 of the IPI channel
{                                   error  register.   It   indicates
{                                   that   the  slave  ended  a  data
{                                   transfer and  the  IPI  channel's
{                                   buffer is not empty.
{
{       34 - BUS PARITY             This  is  bit 57 of ending status
{                                   received  from  the  slave.    It
{                                   indicates that the slave detected
{                                   a  parity  error   on   the   IPI
{                                   interface.    Ending   status  is
{                                   right justified in  counter  word
{                                   20.
{
{       35 - COMMAND REJECT         This is reported in bits 60-63 of
{                                   ending status received  from  the
{                                   slave.  If a value of  2, 3, 6, 8
{                                   or C (hex) is in these bits,  the
{                                   slave has  rejected  the  command
{                                   sent by the PP.  Ending status is
{                                   right  justified  in counter word
{                                   20.
{
{       36 - SYNC OUTS NOT EQUAL    This is reported in bits 60-63 of
{            SYNC INS               ending  status  received from the
{                                   slave.   If  these  bits  have  a
{                                   value  of 9, the slave's SYNC OUT
{                                   count and its SYNC IN count  were
{                                   not   equal   when  the  transfer
{                                   ended.  Ending  status  is  right
{                                   justified in counter word 20.
{
{       37 - BUS B ACKNOWLEDGE INCORRECT   During   a   bus   control
{                                   sequence bus B received from  the
{                                   slave  was  nonzero.  Bus B is in
{                                   the right-most 8 bits of the  IPI
{                                   channel status register.
{
{       38 - NO CONTROLLER INTERRUPT A  command or a  state  sequence
{                                   sent  to  the   slave  was    not
{                                   responded to within the  allotted
{                                   time.
{
{       39 - ENDING STATUS WRONG    This   is  reported  if  bit  56,
{                                   indicating  successful,  was  not
{                                   set  in  ending  status  from the
{                                   slave.  Ending  status  is  right
{                                   justified in counter word 20.
{
{       40 - SLAVE ENCODED ENDING STATUS  WRONG  This is bits 60 - 63
{                                   of  the  ending  status  received
{                                   from  the  slave.  Expecting even
{                                   octet  and  received  odd   octet
{                                   transfer  status  or  visa versa.
{                                   Ending status is right  justified
{                                   in counter word 20.
{
{         The  following  symptom statements are informative and will
{       have counter word 7 set to a value of 3.  Counter  words  1-8
{       are applicable for the following symptom statements.
{
{       50 - EXECUTING CONTROLLER DIAGNOSTICS  Execution  of  a slave
{                                   reset was initiated.
{
{       51 - CONTROLLER DIAGNOSTICS PASSED   The   slave    self-test
{                                   diagnostic  portion  of the slave
{                                   reset completed without error.
{
{       52 - ON THE FLY HARDWARE CORRECTIONS Indicates the number  of
{                                   single  and/or double track error
{                                   corrections that occurred on  the
{                                   tape  reel.   This  is  issued at
{                                   tape unload time if the value  is
{                                   greater  than zero.  Counter word
{                                   11   contains   the   number   of
{                                   hardware corrected errors.
{
{         The  following  symptom  statements  are  returned  when  a
{       diagnostic isolated an  error.   All  counter  words,  except
{       19-24, are applicable for the following symptom statements.
{
{       60 - CONTROLLER FAILURE     Slave  reset  detected a failure.
{                                   Reference the response packet for
{                                   more information.
{
{       61 - DRIVE FAILURE          Facility     disgnostics     have
{                                   detected  a  failure.   Reference
{                                   parameter  ID  26  (hex)  in  the
{                                   response    packet    for    more
{                                   information.
{
{         The  following symptom statements are most likely caused by
{       the slave.  All counter words, except 19-24,  are  applicable
{       for  the following symptom statements.  For errors that refer
{       to IPI channel status register, IPI channel error register or
{       I4  IPI  DMA error register, refer to counter words 20, 21 or
{       22, respectively.
{
{       70 - INTERNAL CONTROLLER ERROR This is reported in bits 60-63
{                                   of  ending  status  received from
{                                   the slave with a code of B (hex).
{                                   Ending  status is right-justified
{                                   in counter word 20.
{
{       71 - CONTROLLER INTERVENTION REQUIRED The slave is unable  to
{                                   execute commands and  some inter-
{                                   vention  is  required.  Reference
{                                   parameter  ID  14  (hex)  in  the
{                                   response    packet    for    more
{                                   information.
{
{       72 - CONTROLLER MACHINE EXCEPTION  A  machine  exception  was
{                                   detected   in   the   controller.
{                                   Reference parameter ID  16  (hex)
{                                   in  the  response packet for more
{                                   information.
{
{       73 - COMMAND EXCEPTION      The command  packet  received  by
{                                   the  slave  had incorrect values,
{                                   was too short, or did not contain
{                                   all      required     parameters.
{                                   Reference parameter ID  17  (hex)
{                                   of  the  response packet for more
{                                   information.
{
{       74 - MICROCODE EXECUTION ERROR The slave encountered an error
{                                   in   its   own  microcode  during
{                                   execution.   Reference  parameter
{                                   ID   13  (hex)  of  the  response
{                                   packet for more information.
{
{       75 - ALTERNATE PORT EXCEPTION The  slave  detected  an  event
{                                   from     an    alternate    port.
{                                   Reference parameter ID  15  (hex)
{                                   of  the  response packet for more
{                                   information.
{
{       76 - UNEXPECTED RESPONSE    The  response  packet  from   the
{                                   slave   was   not   the  expected
{                                   response  for  the  operation  in
{                                   progress.
{
{       77 - DRIVE RESERVED TO OTHER CONTROLLER  PORT  The  drive  is
{                                   reserved to the redundant port of
{                                   the slave.
{
{       78 - NO BLOCK ID PARAMETER RETURNED  The response packet does
{                                   not have parameter  ID  D0  (hex)
{                                   included but was expected to.
{
{       79 - UNEXPECTED CLASS 2 INTERRUPT   An   unexpected  class  2
{                                   interrupt has been detected  when
{                                   no data transfer was in progress.
{                                   This is reported in bits 56 -  63
{                                   of  the request interrupts (class
{                                   2) sequence bus B address  octet.
{                                   This status is right justified in
{                                   counter word 20.
{
{
{         The following symptom statements are most likely caused  by
{       the  drive.   All counter words, except 19-24, are applicable
{       for the following symptom statements.
{
{       80 - DRIVE NOT OPERATIONAL  The drive is not present, powered
{                                   on, or responding.
{
{       81 - DRIVE NOT READY        This usually means the drive does
{                                   not have a tape loaded and/or the
{                                   facility was not set to ready.
{
{       82 - DRIVE INTERVENTION REQUIRED The drive is powered on  and
{                                   ready   but   unable  to  execute
{                                   commands.  Reference parameter ID
{                                   24  (hex)  in the response packet
{                                   for more information.
{
{       83 - PHYSICAL INTERFACE CHECK  The  slave  detected  a  check
{                                   condition    on    the   physical
{                                   interface    to    the     drive.
{                                   Reference  parameter  ID 26 (hex)
{                                   in the response packet  for  more
{                                   information.
{
{       84 - OPERATION TIMEOUT      This  indicates  a drive internal
{                                   timeout  mechanism   detected   a
{                                   failure.   Reference parameter ID
{                                   26 (hex) in the  response  packet
{                                   for more information.
{
{       85 - DRIVE MACHINE EXCEPTION A machine exception was detected
{                                   in    the    drive.     Reference
{                                   parameter  ID  26  (hex)  in  the
{                                   response    packet    for    more
{                                   information.
{
{       86 - FATAL ERROR            The  drive  detected  an internal
{                                   machine  error   that   precludes
{                                   execution  or continuation of the
{                                   current    command.     Reference
{                                   parameter  ID  26  (hex)  in  the
{                                   response    packet    for    more
{                                   information.
{
{       87 - DRIVE CONDITIONAL SUCCESS  An  abort  command was issued
{                                   but the addressee was not able to
{                                   process it.  Reference  parameter
{                                   ID 19 (hex) or ID 29 (hex) in the
{                                   response    packet   for     more
{                                   information.
{
{       88 - POSITION LOST          The  drive  has lost its position
{                                   on the media.
{
{       89 - DRIVE RESERVED TO OTHER CONTROLLER Another slave has the
{                                   drive reserved.
{
{       90 - NO END OF EXTENT DETECTED The slave has not reported end
{                                   of extent (tape mark) when it was
{                                   expected.
{
{       91 - DATA LENGTH DIFFERENCE The addressee has not transferred
{                                   all the information  specified in
{                                   the transfer command.   Reference
{                                   parameter  ID 2A (hex)  in    the
{                                   response    packet    for    more
{                                   information.
{
{         The following symptom statements are most likely caused  by
{       the  tape  medium,  however,  there  is a possiblity that the
{       cause of the failure could be a drive failure.   All  counter
{       words, except 19-24, are applicable for the following symptom
{       statements.
{
{       100 - TAPE MEDIUM FAILURE   This indicates that a  defect  is
{                                   present  on  the  tape  medium in
{                                   which error  recovery  could  not
{                                   recover from.
{
{       101 - UNABLE TO WRITE ID BURST  This  indicates  that  the ID
{                                   burst could not be  written  from
{                                   load point.  This could be due to
{                                   a bad tape, dirty heads  or  tape
{                                   drive malfunction.
{
{       102 - UNABLE TO SET AGC     This  indicates the drive was not
{                                   capable of setting the  automatic
{                                   gain control at load point.  This
{                                   cound be due to a bad tape, dirty
{                                   heads or  tape drive malfunction.
{
{         The  following  symptom  statements  are  returned  if  the
{       failure  could  not  be  isolated.   Counter  words  1-8  are
{       applicable.
{
{       110 - MASTER-SLAVE DATA INTEGRITY Slave reset was successful,
{                                   no  write  buffer  or read buffer
{                                   errors were  detected,  but  data
{                                   read  from  the  slave buffer did
{                                   not match data previously written
{                                   during the PP/slave path test.
{
{       111 - SLAVE-FACILITY DATA INTEGRITY   All   self-tests   were
{                                   successful,  no  write  or   read
{                                   command errors were detected, but
{                                   data read to central  memory  did
{                                   not  match  the  data  previously
{                                   written  during  the   confidence
{                                   test.
{
{       120 - SOFTWARE FAILURE      The  PP  has  detected  a logical
{                                   inconsistency  not  related  to a
{                                   hardware    malfunction.      The
{                                   condition  is   further   defined
{                                   in counter word 25.
{
{       121 thru 130 - SOFTWARE FAILURE    The  CPU  has  detected  a
{                                   logical inconsistency in the tape
{                                   subsystem.  This   response  code
{                                   value defines the error.
{
{    9.   Blocks written on Unit
{    10.  Blocks read on Unit
{    11.  On The Fly single/double track corrections count
{    12.  Reserved for CDC (zero)
{    13.  Absolute Block Count from Load Point
{    14.  Absolute number of Tape/File Marks from Load Point
{    15.  User requested format parameters
{    16.  Actual Density at which the unit was functioning
{    17.  Reserved for CDC (zero)
{    18.  Retry count of recovery attempts
{    19.  Last requested function
{    20.  Status register of IPI channel
{    21.  Error register of IPI channel
{    22.  Error register of I4 IPI DMA (0 on Cyber 930)
{    23.  Operation register of I4 IPI DMA (0 on Cyber 930)
{    24.  Control register of I4 IPI DMA (0 on Cyber 930)
{    25.  Interface error code (software failure)
{    26.  Reserved for CDC (zero)
{    27.  Reserved for CDC (zero)
{    28.  Reserved for CDC (zero)
{    29.  Reserved for CDC (zero)
{    30.  Reserved for CDC (zero)
{    31 .. NN.  IPI status.  Counter word 31 is the first word of the
{               response packet.  If the first 16 bits of this word are
{               non-zero, a response packet is present.  Response
{               packet bytes are packed, 8 bytes per counter word.
{               Reference the 5698_1x Technical Reference Manual for
{               a description of the response.  The maximun value for
{               NN will be 62.

  CONST
    cml$5698_1x_failure_data = cmc$min_ecc + 5103;

*copyc cmc$condition_limits
*DECK DECK=CML$5744_LIBRARY_FAILURE_ERROR EXPAND=FALSE
{
{ CML$5744_LIBRARY_FAILURE_ERROR
{
{
{ PURPOSE:
{   The purpose of this statistic is to record the failure of the 5744 device
{   when a failure is detected by the application accessing the device.  This
{   error is returned in the status portion of the response to a device request.
{
{ FREQUENCY: At each occurrence of a 5744 device failure.
{
{ CONTENT:
{   The descriptive data portion of this statistic contains:
{     '<mf>.<workstation>.<symptom>'
{
{      where:
{        <mf> is the identification of the mainframe in the form
{          $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{          Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{          serial number of that processor, e.g. 0104.
{
{        <workstation> is the host name of the SUN workstation which controls
{          the 5744 device.  The software that controls the 5744 device runs on
{          the workstation.
{
{        <symptom> is the text describing the failure.  The value returned in
{          this field is:
{            '5744 library failure.'
{

  CONST
    cml$5744_library_failure_error = cmc$min_ecc + 9004;

*copyc cmc$condition_limits
*DECK DECK=CML$65354_1X_FAILURE_DATA EXPAND=TRUE
{
{ CML$65354_1X_FAILURE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record the failure data
{ captured by the system when accessing a 65354 MAP V subsystem.
{
{ FREQUENCY: At each failure occurrence.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<channel>.<unit>*<severity>*<symptom>
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is either the string 'PPn' or 'CPPn' and where 'n'
{        is the decimal representation of the logical PP number used
{        to process the failing request.  Note that 'CPP' is the
{        designation given to the concurrent PPs in an I4 IOU.
{
{      where <channel> is either the string 'CHn' or 'CCHnp',
{        where 'n' is the decimal representation of the channel and
{        where 'p' is the channel port (A or B) through which the
{        disk device was accessed.  Note that 'CCH' is the
{        designation given to the concurrent channels in an I4 IOU.
{
{      where  <unit> is the element name of the failing MAP V.
{
{      where  <severity>  is the string 'UF' or 'RF' for unrecovered
{        and recovered failure severity, respectively.
{
{      where <symptom> is the symptom/action statement  provided  by
{        the MAP V subsystem, MAP V PPU, or the MAP V MONITOR.
{
{    The  counter-value portion of this statistic contains:
{
{    1.  Logical PP number
{    2.  Channel Number of the MAP V io processor
{    3.  Equipment Number of MAP V
{    4.  Physical Unit Number
{    5.  Unit-type
{       1 - 65354
{    6.  Logical Operation Code
{       1 - write map request
{       2 - read map response
{       3 - write data on the channel
{       4 - read data from the channel
{       5 - write data on the CMI
{       6 - read data with the CMI
{       7 - master clear this mainframe's portion of the MAP V.
{       8 - MAP V internal error
{    7.  Failure Severity
{       0 - Recovered Failure
{       1 - Unrecovered Failure
{    8.  Failure Symptom Code (tells what the system thinks is wrong)
{            ERRORS REPORTED BY THE MAP V.
{       4 - MAP V down.
{       30 - data transmission error on channel
{       39 - system error detected by MAP V
{       57 - data transmission error on CMI
{       81 - MAP V ACP micrand parity error
{       82 - MAP V SMP micrand parity error
{
{            ERRORS REPORTED BY THE PPU.
{
{       REQUEST/RESPONSE PACKET ERRORS
{
{       1401 - REQUEST PACKET LENGTH ERROR 1(16)
{                THE MINIMUM LENGTH OF A REQUEST PACKET IS 6.
{                THE VALUE FOUND IN LENGTH FIELD OF REQUEST PACKET
{                IS LESS THAN 6.
{
{       1402 - REQUEST PACKET WILL NOT FIT IN PP BUFFER   2(16)
{                THE REQUEST IS LARGER THAN WHAT CAN BE ACCOMODATED
{                BY THE SIZE OF PPU BUFFER.
{
{       ARRAY PROCESSOR ERROR CODES
{
{       1416 - SEQUENCER BUSY    10(16)
{                SEQUENCER BUSY (STATUS BIT 0 - WORD 1)
{                IS CHECKED AFTER EACH MAP-V SEQUENCE
{                (I.E. AFTER WRITE FLAG SEQUENCE, WRITE REQUEST,
{                READ RESPONSE OR TRANSFER OF DATA).  IF STATUS
{                BIT DOES NOT CLEAR BEFORE ASSEMBLY OPTION
{                LOOP COUNT GOES TO ZERO, AN ABNORMAL
{                RESPONSE IS RETURNED.
{
{       1417 - CONTROL PROCESSOR NOT RUNNING   11(16)
{                CONTROL PROCESSOR RUNNING (STATUS BIT 1 - WORD 1)
{                IS CHECKED EACH TIME MAP-V HARDWARE STATUS WORD 1
{                IS READ.  IF BIT IS NOT ON, AN ABNORMAL
{                RESPONSE IS RETURNED.
{
{       1418 - HOST CHANNEL SEQUENCE ERROR    12(16)
{                HOST CHANNEL SEQUENCE ERROR (STATUS BIT 2 - WORD 1)
{                IS CHECKED AFTER WRITE FLAG FUNCTION SEQUENCE AS PART
{                OF A WRITE REQUEST PACKET OR A READ RESPONSE PACKET.
{                IF HOST CHANNEL SEQUENCE ERROR STATUS BIT IS ON,
{                WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
{                RESPONSE RETURNED.
{
{       1419 - CONTROL PROCESSOR SEQUENCE ERROR 13(16)
{                CONTROL PROCESSOR SEQUENCE ERROR (STATUS BIT 3 - WORD 1)
{                IS CHECKED AFTER WRITE FLAG FUNCTION SEQUENCE AS PART
{                OF A WRITE REQUEST PACKET OR A READ RESPONSE PACKET.
{                IF CONTROL PROCESSOR SEQUENCE ERROR STATUS BIT IS ON,
{                WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
{                RESPONSE IS RETURNED.
{
{       1420 - COMMAND REJECTED   14(16)
{                COMMAND REJECTED (STATUS BIT 4 - WORD 1) IS
{                CHECKED AFTER WRITE FLAG FUNCTION SEQUENCE AS PART
{                OF A WRITE REQUEST PACKET OR A READ RESPONSE PACKET.
{                IF COMMAND REJECTED STATUS BIT IS FOUND ON,
{                WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
{                RESPONSE RETURNED.
{
{       1422 - WRITEFLAG STATUS BIT NOT ON  16(16)
{
{       1423 - MAIN MEMORY PARITY ERROR   17(16)
{                MAIN MEMORY PARITY ERROR (STATUS BIT 7 - WORD 1)
{                INDICATES THAT THE MAP-V HARDWARE HAS DETECTED
{                A PARITY ERROR IN MAIN MEMORY.
{                IT IS CHECKED EACH TIME, VIA STATUS WORD 1, THAT
{                DATA IS WRITTEN INTO OR READ FROM MAIN MEMORY.
{
{                IF MAIN MEMORY PARITY ERROR STATUS REMAINS ON
{                AFTER THREE RETRYS, WHILE PROCESSING A PP UNIT
{                REQUEST, AN ABNORMAL RESPONSE RETURNED.
{
{       1424 - PUBLIC MEMORY PARITY ERROR   18(16)
{                PUBLIC MEMORY PARITY ERROR (STATUS BIT 8 - WORD 1)
{                INDICATES THAT THE MAP-V HARDWARE HAS DETECTED
{                A PARITY ERROR IN PUBLIC MEMORY.
{                IT IS CHECKED EACH TIME, VIA STATUS WORD 1, THAT
{                DATA IS WRITTEN INTO OR READ FROM PUBLIC MEMORY.
{
{                IF PUBLIC MEMORY PARITY ERROR STATUS REMAINS ON
{                AFTER THREE RETRYS,WHILE PROCESSING A PP UNIT
{                REQUEST, AN ABNORMAL RESPONSE RETURNED.
{
{       1425 - CHANNEL PARITY ERROR   19(16)
{                CHANNEL PARITY ERROR (STATUS BIT 9 - WORD 1)
{                INDICATES THAT THE MAP-V INTERFACE
{                HARDWARE IS NOT IN AGREEMENT WITH THE PARITY
{                GENERATED BY CYBER CHANNEL HARDWARE ON DATA RECEIVED.
{                IT IS CHECKED EVERY TIME STATUS WORD 1 IS READ.
{                IF FOUND ON AFTER THREE RETRIES,
{                AN ABNORMAL RESPONSE RETURNED.
{
{                A CHANNEL PARITY ERROR MAY ALSO OCCUR ON DATA
{                RECEIVED AT THE PPU.  FOR THIS CASE,
{                CHANNEL PARITY (VIA PPU INSTRUCTION) IS CHECKED
{                EVERY TIME STATUS IS READ AND DATA IS TRANSFERED.
{                IF ERROR OCCURS IN THIS CASE, ERROR CODE
{                (PARITY ERROR ON CHANNEL) IS REPORTED AFTER
{                THREE RETRIES AND AN ABNORMAL RESPONSE RETURNED.
{
{                STATUS BIT 10 -  EXPONENT OUT OF RANGE ERROR
{
{                ARE NOT REPORTED TO INTERFACE AS ERROR.
{                THIS INFORMATION IS CONTAINED IN STATUS WORDS AS
{                PART OF THE NOS/VE RESPONSE.
{
{       1434 - *APM* INVALID PRECEDING FUNCTION   22(16)
{                INVALID PRECEDING FUNCTION (STATUS BIT 2 -
{                WORD 2) IS CHECKED AFTER EVERY WRITE FLAG
{                FUNCTION.
{
{                IF INVALID PRECEDING FUNCTION BIT IS FOUND ON,
{                WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
{                RESPONSE IS RETURNED.
{
{
{       1435 - *APM* NO PERMISSION TO PROCEED   23(16)
{                PERMISSION TO PROCEED (STATUS BIT 3 - WORD 2) IS
{                CHECKED AFTER WRITE FLAG FUNCTION SEQUENCE AS
{                PART OF WRITE REQUEST PACKET OR READ RESPONSE PACKET.
{                IF PERMISSION TO PROCEED STATUS BIT IS NOT FOUND
{                ON WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
{                RESPONSE IS RETURNED.
{
{        1438 - ERROR IN LAST REQUEST PACKET  26(16)
{                ERROR IN LAST REQUEST PACKET (STATUS BIT 6 - WORD 2)
{                IS CHECKED AFTER WRITING REQUEST PACKET TO MAP-V.
{
{                IF ERROR IN LAST REQUEST PACKET BIT IS FOUND ON,
{                WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
{                RESPONSE IS RETURNED.
{
{
{       ERROR AS A RESULT OF CHANNEL RELATED PROBLEMS/ERRORS
{
{       1448 - NO RESPONSE TO FUNCTION CODE  30(16)
{                THIS ERROR CODE INDICATES THAT PP TIMED OUT
{                WAITING FOR A RESPONSE TO A FUNCTION FROM THE
{                MAP-V CHANNEL INTERFACE HARDWARE.  IF ERROR OCCURS
{                WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
{                RESPONSE IS RETURNED.
{
{       1449 - PARITY ERROR ON CHANNEL  31(16)
{                THIS ERROR CODE INDICATES THAT A PP INSTRUCTION
{                (EITHER CFM/SFM - JUMP IF PARITY ERROR CLEAR/SET)
{                DETECTED A CHANNEL PARITY ERROR.  THIS ERROR
{                INDICATES THAT THE CYBER CHANNEL HARDWARE
{                IS NOT IN AGREEMENT WITH THE PARITY GENERATED
{                BY MAP-V HARDWARE INTERFACE ON DATA RECEIVED.
{                IF ERROR PERSISTS AFTER THREE RETRYS,
{                WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
{                RESPONSE IS RETURNED.
{
{                A CHANNEL PARITY ERROR MAY ALSO OCCUR ON DATA
{                RECEIVED AT THE MAP-V INTERFACE.  FOR THIS CASE,
{                CHANNEL PARITY STATUS BIT (BIT 9) IS CHECKED
{                EVERY TIME STATUS IS READ AND DATA IS TRANSFERED.
{                IF ERROR PERSISTS AFTER THREE RETRYS,
{                WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
{                RESPONSE IS RETURNEDN *RC* FIELD, *K.OCP* IS SET
{
{       1450 - CHANNEL FAILED TO GO EMPTY  32(16)
{                THIS ERROR CODE INDICATES THAT PP TIMED OUT
{                WAITING FOR THE CHANNEL TO GO EMPTY ON OUTPUT TO
{                MAP-V CHANNEL INTERFACE HARDWARE.  IF ERROR OCCURS
{                WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
{                RESPONSE IS RETURNED.
{
{       1451 - INPUT DEADMAN TIMEOUT  33(16)
{                THIS ERROR CODE INDICATES THAT PP DETECTED AN
{                INPUT DEADMAN TERMINATE CONDITION ON THE CHANNEL
{                FROM MAP-V CHANNEL INTERFACE HARDWARE.  IF ERROR
{                OCCURS WHILE PROCESSING A PP UNIT REQUEST, AN
{                ABNORMAL RESPONSE IS RETURNED.
{
{       1452 - OUTPUT DEADMAN TIMEOUT   34(16)
{                THIS ERROR CODE INDICATES THAT PP DETECTED AN
{                OUTPUT DEADMAN TERMINATE CONDITION ON THE CHANNEL
{                FROM MAP-V CHANNEL INTERFACE HARDWARE.  IF ERROR
{                OCCURS WHILE PROCESSING A PP UNIT REQUEST, AN
{                ABNORMAL RESPONSE IS RETURNED.
{
{       1453 - CHANNEL FULL BEFORE OUTPUT  35(16)
{                THIS ERROR CODE INDICATES THAT PP DETECTED AN
{                CHANNEL FULL CONDITION WHILE PREPARING TO OUTPUT TO
{                MAP-V CHANNEL INTERFACE HARDWARE.  IF ERROR OCCURS
{                WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
{                RESPONSE IS RETURNED.
{
{       1454 - CHANNEL ACTIVE BEFORE FUNCTION   36(16)
{                THIS ERROR CODE INDICATES THAT PP DETECTED A
{                CHANNEL ACTIVE CONDITION WHILE PREPARING TO SEND
{                FUNCTION TO MAP-V CHANNEL INTERFACE HARDWARE.
{                IF ERROR OCCURS WHILE PROCESSING A PP UNIT REQUEST,
{                AN ABNORMAL RESPONSE IS RETURNED.
{
{       1455 - CHANNEL EMPTY BEFORE INPUT  37(16)
{                THIS ERROR CODE INDICATES THAT PP DETECTED A
{                CHANNEL EMPTY CONDITION WHILE PREPARING TO INPUT
{                FROM MAP-V CHANNEL INTERFACE HARDWARE.  IF ERROR
{                OCCURS WHILE PROCESSING A PP UNIT REQUEST, AN
{                ABNORMAL RESPONSE IS RETURNED.
{
{
{            COUNTERS USED IF THE PPU REPORTS THE ERROR
{    9.  Previous MAP V hardware status value
{    10. Current MAP V hardware status value
{    11. Previous MAP V software status value
{    12. Current MAP V software status value
{    13. Last function code sent to the MAP V
{    14. PPU address of code detecting the error.
{    15 - 20. Presently unused.
{
{            COUNTERS USED IF THE MAP V REPORTS THE ERROR
{    21. MAP V response status word 1
{    22. MAP V response status word 2
{    23. MAP V response status word 3
{    24 - 62.  Presently unused.
{

  CONST
    cml$65354_1x_failure_data = cmc$min_ecc + 6100;

*copyc cmc$condition_limits
*DECK DECK=CML$65850_1X_FAILURE_DATA EXPAND=FALSE
{}
{
{     DECK=CML$65850_1X_FAILURE_DATA
{
{ PURPOSE:
{    The purpose of this statistic is to record the failure data
{    captured by the system when accessing an optical disk.
{
{ FREQUENCY: At each failure occurrence.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<ch>.<controller>.<unit>*<vsn>*<class>*<message>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is either the string 'PPn' or 'CPPn' and where 'n'
{        is the decimal representation of the logical PP number used
{        to process the failing request.  Note that 'CPP' is the
{        designation given to the concurrent PPs in an I4 IOU.
{
{      where <ch> is either the string 'CHn' or 'CCHnp',
{        where 'n' is the decimal representation of the channel and
{        where 'p' is the channel port (A or B) through which the
{        disk device was accessed.  Note that 'CCH' is the
{        designation given to the concurrent channels in an I4 IOU.
{
{      where  <controller> is the element name of the controller used
{        in the failing request.
{
{      where  <unit> is the element name of the unit used
{        in the failing request.
{
{      where  <vsn> is the volume identifier of volume mounted on the
{         unit used in the failing request.
{
{      where  <class>  is the string 'UF' for unrecovered, 'RF' for
{        recovered, 'IF' for intermediate and 'IM' for informative message.
{
{      where <message> a statement of the failure provided  by
{        the optical disk controller status or by the pp status.
{        The messages are the text after the counter values in the
{        descriptions of counters 8 and 9 below.
{
{    The  counter-value portion of this statistic contains:
{
{    1.  Logical PP number
{        Bit 57 is set to 1 for an I4 concurrent PP.
{        Bits 46 thru 51 contains the iou number calculated from the 4th
{             character of the iou element name.
{    2.  Channel Number of the optical disk
{        Bit 57 is set to 1 for an I4 concurrent channel.
{        Bit 56 is set to 1 if I4 channel port A.
{        Bit 55 is set to 1 if I4 channel port b.
{        Bits 46 thru 51 contains the iou number calculated from the 4th
{             character of the iou element name.
{    3.  Equipment Number of optical disk controller
{    4.  Physical Unit Number
{    5.  Unit-type
{       1 - ODISK
{    6.  Logical Operation Code
{       1 - read label
{       2 - write label
{       3 - find label
{       4 - read file
{       5 - write file
{       6 - position
{       7 - write eop
{       8 - send function
{       9 - get scanner status
{       10 - run diagnostic
{    7.  Failure Severity
{       0 - Recovered Failure Report
{       1 - Unrecovered Failure Report
{       2 - Intermediate Failure Report
{       3 - Informative Message
{    8.  Failure Symptom Code for errors detected by the optical disk controller.
{       800(16) THRU B80(16) ERRORS REPORTED BY THE OPTICAL DISK CONTROLLER
{            Any status that can not be identified will have a text
{            message of 'UNKNOWN ERROR' if it is outside of the error status
{            range. If the status is in the range of errors but unknown the text
{            message be the header for the range of errors.
{
{
{                           GENERAL STATUS EQUATES
{
{        0001(16)  'EOI ENCOUNTERED'
{        0002(16)  'DATA READY'
{        0004(16)  'BUFFER READY'
{        0008(16)  'CONTROL MODULE RESERVED'
{        0010(16)  'COMMAND IN PROGRESS'
{        0800(16)  'DIAGNOSTIC DETECTED ERROR'
{
{                          DIAGNOSTICS DETECTED ERRORS
{
{        0801(16)  'ADDRESS ERROR'
{        0802(16)  'UNCORRECTABLE MEMORY PARITY ERROR'
{        0803(16)  'ILLEGAL INSTRUCTION'
{        0804(16)  'ZERO DIVIDE'
{        0805(16)  'TRAP OVERFLOW'
{        0806(16)  'TRAP VECTOR'
{        0807(16)  'INSTRUCTION TRACE'
{        0808(16)  'CHECK EXEMPTION'
{        0809(16)  'PRIVILEGE VIOLATION'
{        080A(16)  'BUS ERROR (ILLEGAL I/O ON PORT 7)'
{        080B(16)  'CORRECTABLE MEMORY PARITY ERROR'
{        080C(16)  'ROM MEMORY PARITY ERROR'
{        080E(16)  'FUNCTION PARITY ERROR'
{        0828(16)  'RAM MEMORY FAILURE'
{        0829(16)  'RAM MEMORY FAILURE'
{        082A(16)  'ILLEGAL DIAGNOSTIC PARAMETER'
{        082D(16)  'SELECT ACTIVE DROPPED'
{        082E(16)  'INCORRECT CONTROLWARE'
{        082F(16)  'RAM CHECKSUM ERROR'
{        0860(16)  'BUFFER MEMORY FAILURE'
{        0861(16)  'BUFFER MEMORY FAILURE'
{        0862(16)  'PORT NOT CLEAR AFTER RESET'
{        0863(16)  'WORD OUTPUT NOT = I/O PORT INPUT'
{        0864(16)  'WRITE UL=ODD   READ U BYTE, PE'
{        0865(16)  'WRITE UL=ODD   READ L BYTE, PE'
{        0866(16)  'WRITE UL=ODD   READ WORD, PE'
{        0867(16)  'WRITE U=EVEN   READ U BYTE, NO PE'
{        0868(16)  'WRITE U=EVEN   READ L BYTE, PE'
{        0869(16)  'WRITE U=EVEN   READ WORD, NO PE'
{        086A(16)  'WRITE L=EVEN   READ U BYTE, PE'
{        086B(16)  'WRITE L=EVEN   READ L BYTE, NO PE'
{        086C(16)  'WRITE L=EVEN   READ WORD, NO PE'
{        086D(16)  'WRITE UL=EVEN  READ U BYTE, NO PE'
{        086E(16)  'WRITE UL=EVEN  READ L BYTE, NO PE'
{        086F(16)  'WRITE UL=EVEN  READ WORD, NO PE'
{        0870(16)  'WRITE UL=ODD   READ U BYTE, PE'
{        0871(16)  'WRITE UL=ODD   READ L BYTE, PE'
{        0872(16)  'WRITE UL=ODD   READ WORD, PE'
{        0873(16)  'WRITE U=EVEN   READ U BYTE, NO PE'
{        0874(16)  'WRITE U=EVEN   READ L BYTE, PE'
{        0875(16)  'WRITE U=EVEN   READ WORD, NO PE'
{        0876(16)  'WRITE L=EVEN   READ U BYTE, PE'
{        0877(16)  'WRITE L=EVEN   READ L BYTE, NO PE'
{        0878(16)  'WRITE L=EVEN   READ WORD, NO PE'
{        0879(16)  'WRITE UL=EVEN  READ U BYTE, NO PE'
{        087A(16)  'WRITE UL=EVEN  READ L BYTE, NO PE'
{        087B(16)  'WRITE UL=EVEN  READ WORD, NO PE'
{        0880(16)  'LOOP ISI NOT COMPARED'
{        0881(16)  'PARITY ERROR ON LOOP ISI'
{        0882(16)  'TRANSFER NOT COMPLETE'
{        0883(16)  'BUFFER PARITY ERROR'
{        0884(16)  'BUFFER DATA MISCOMPARE'
{        0885(16)  'BAD PARITY'
{        0886(16)  'TRANSFER NOT COMPLETE'
{        0887(16)  'BUFFER PARITY ERROR'
{        0888(16)  'BUFFER DATA MISCOMPARE'
{        0889(16)  'BAD PARITY'
{        088A(16)  'ISI PARITY ERROR OCCURRED'
{        088B(16)  'TRANSFER NOT COMPLETE'
{        088C(16)  'BUFFER PARITY ERROR'
{        088D(16)  'PROC. DATA MISCOMPARE'
{        088E(16)  'BAD PARITY IN BUFFER'
{        088F(16)  'FORCED BUFFER PARITY ERROR FAILED'
{        0890(16)  'ISI PARITY ERROR'
{        0891(16)  'ISI PARITY CHECK FAILURE'
{        0892(16)  'ISI PARITY DISABLE FAILURE'
{        0893(16)  'NO INTERRUPT ON RAM PARITY ERROR'
{        0894(16)  'NO INTERRUPT ON I/O TO IC'
{        0895(16)  'NO INTERRUPT ON ODD ADDRESS'
{        0896(16)  'LOOP PROCESSOR TO BUFFER ERROR'
{        0897(16)  'LOOP BUFFER TO PROCESSOR ERROR'
{        0898(16)  'ISI DMT BIT DID NOT SET'
{        0899(16)  'NO INTERRUPT ON ILLEGAL INSTRUCTION'
{
{                        CONTROLLER/FORMATTER ERRORS
{
{        0A00(16)  'FORMATTER IRRECOVERABLE ERROR'
{        0A02(16)  'IRRECOVERABLE MEMORY PARITY ERROR'
{        0A0B(16)  'CORRECTABLE MEMORY PARITY ERROR'
{        0A10(16)  'INCORRECT ATTENTION RESPONSE'
{        0A28(16)  'RAM MEMORY FAILURE'
{        0A29(16)  'RAM MEMORY FAILURE'
{        0A2A(16)  'ILLEGAL DIAGNOSTIC PARAMETER'
{        0A2D(16)  'SELECT ACTIVE DROPPED'
{        0A2E(16)  'INCORRECT CONTROLWARE'
{        0A2F(16)  'RAM CHECKSUM ERROR'
{        0A30(16)  'PROCESSOR BUFFER WRITE ERROR (0040)'
{        0A31(16)  'PROCESSOR BUFFER READ ERROR  (0041)'
{        0A32(16)  'DMA TRANSFER TIMEOUT ERROR (0042-0043)'
{        0A33(16)  'DMA TRANSFER LENGTH ERROR  (0042-0043)'
{
{                        ISI/ICI  ERRORS
{
{        0A40(16)  'UNDEFINED ERROR FROM CRACK STATUS'
{        0A41(16)  'COMPARE ERROR ON LOOPED DATA'
{        0A42(16)  'SELECT ACTIVE NOT DROPED AFTER PARITY ERROR'
{        0A43(16)  'ATTENTION NOT RECEIVED AFTER PARITY ERROR'
{        0A44(16)  'MANUAL INTERVENTION NOT 63 AFTER PARITY ERROR'
{        0A45(16)  'ISI PARITY ERROR'
{        0A46(16)  'ISI TIMEOUT'
{        0A47(16)  'SELECT ACTIVE NOT SET'
{        0A48(16)  'DMA ISI HARDWARE TRANSFER ERROR'
{        0A49(16)  'DMA ICI HARDWARE TRANSFER ERROR'
{        0A4B(16)  'RESERVE ERROR - SELECT ACTIVE DOWN'
{        0A4C(16)  'ISI CHANNEL DEAD MAN TERMINATE'
{        0A4D(16)  'ISI CHANNEL PARITY ERROR ON FUNCTION'
{        0A4E(16)  'ICI CHANNEL PARITY ERROR ON FUNCTION'
{        0A4F(16)  'BIT SIGNIFICANT RESPONSE WRONG'
{        0A51(16)  'CONTROL MODULE FUNCTION BUFFER ERROR'
{        0A52(16)  'CONTROL MODULE DATA BUFFER ERROR'
{        0A53(16)  'DMA TRANSFER TEST FAILED'
{        0A54(16)  'FUNCTION PARAMETER LOADING ERROR'
{        0A55(16)  'MISSING ATTENTION'
{        0A56(16)  'COMMAND TIMEOUT - NO ATTENTION'
{
{                        DRIVE/UNIT ERRORS
{
{        0A58(16)  'IRRECOVERABLE DEVICE ERROR'
{        0A59(16)  'DRIVE NOT PRESENT'
{        0A5A(16)  'DRIVE NOT READY'
{        0A5B(16)  'DISPLAY UNIT ERROR'
{        0A5C(16)  'PAUSE FLAG DID NOT DROP'
{        0A60(16)  'TRANSFER TIMEOUT'
{        0A61(16)  'UNABLE TO WRITE'
{        0A62(16)  'UNABLE TO READ'
{        0A63(16)  'SYSTEM INTERVENTION SET'
{        0A64(16)  'MANUAL INTERVENTION SET'
{        0A65(16)  'DELAYED STATUS SET'
{
{                        FUNCTION FAILURES AND SOFTWARE ERRORS
{
{        0A81(16)  'ACTIVE FILE COUNTER ZERO AT DECREMENT'
{        0A82(16)  'WRITE CHUNK WITHOUT WRITE SEQUENCE'
{        0A83(16)  'READ CHUNK WITHOUT READ SEQUENCE'
{        0A84(16)  'SPIN DOWN WITH ACTIVE FILE COUNT'
{        0A85(16)  'OUTSTANDING ATTENTION AT RESERVE PATH'
{        0A86(16)  'ENCOUNTERED END OF MEDIA'
{        0A87(16)  'BEGINNING OF MEDIA DURING BACKSPACE'
{
{                        LABEL FUNCTION FAILURES AND ERRORS
{
{        0B00(16)  'NOT LABEL DATA IN BUFFER ON LABEL WRITE'
{        0B01(16)  'CARTRIDGE/UNIT WRITE PROTECT SWITCHES SET'
{        0B02(16)  'SELECT ACTIVE DROPPED'
{        0B03(16)  'HOST/FORMATTER TIMEOUT'
{        0B04(16)  'HOST/FORMATTER TRANSFER ERROR'
{        0B06(16)  'LABEL FUNCTION PARAMETERS INCORRECT'
{        0B07(16)  'CARTRIDGE NOT LABELED'
{        0B08(16)  'NO LABEL MATCH ON FIND LABEL'
{        0B0A(16)  'CARTRIDGE HAS DATA IN SYSTEM AREA'
{        0B0B(16)  'REQUEST/MOUNTED VSN MISMATCH'
{        0B0C(16)  'PARTITION LABEL MISMATCH'
{        0B0F(16)  'NO SPACE ON PARTITION/PTOC FULL'
{        0B10(16)  'UNABLE TO FIND PTOC STARTING ADDRESS'
{        0B11(16)  'HOST DID NOT SUPPLY EOF/EOS ADDRESS'
{        0B12(16)  'HOST DID NOT SUPPLY A VOLUME NAME'
{        0B13(16)  'HOST DID NOT SUPPLY PARTITION NAME'
{        0B14(16)  'NO SPACE ON LEFT ON DISK'
{        0B15(16)  'NO SPACE TO WRITE ON PARTITION/FILE'
{        0B16(16)  'PREALLOCATED FILE BIGGER THAN PARTITION'
{        0B17(16)  'NOT ENOUGH SPACE FOR PARTITION'
{
{    9.  Failure Symptom Code for errors detected by the pp
{
{       30(16) THRU 3A(16)  ERRORS REPORTED BY THE PPU.
{       ODPP Error Code can assume any of the following hexadecimal values -
{
{        30(16)  - 'NO RESPONSE TO FUNCTION'
{             Indicates that the PP timed out waiting for a response
{             to a function from the Formatter or Interface Module.
{
{        31(16)  - 'PARITY ERROR ON CHANNEL'
{             Indicates that a PP instruction (either CFM or SFM -
{             Jump if parity error clear/set) detected a channel
{             parity error.  This error indicates that the hardware
{             is not in agreement with the parity generated by the
{             hardware interface on data received.
{
{        32(16)  - 'CHANNEL FAILED TO GO EMPTY'
{             The PP timed out waiting for the channel to empty on
{             output to the hardware.
{
{        33(16)  - 'INPUT DEADMAN TIMEOUT'
{             PP detected an input deadman terminate condition on the
{             channel from the Interface Module.
{
{        34(16)  - 'OUTPUT DEADMAN TIMEOUT'
{             PP detected an output deadman terminate condition on the
{             channel from the IM interface.
{
{        35(16)  - 'CHANNEL FULL BEFORE OUTPUT'
{             PP detected a channel full condition while preparing to
{             output to the IM interface.
{
{        36(16)  - 'CHANNEL ACTIVE BEFORE FUNCTION'
{             PP detected a channel active condition while preparing
{             to send a function to the IM interface.
{
{        37(16)  - 'CHANNEL EMPTY BEFORE INPUT'
{             PP detected a channel empty condition while preparing to
{             input from the IM interface.
{
{        38(16)  - 'CHANNEL EMPTY DURING INPUT'
{             An empty channel condition was detected while inputting
{             data.  The contents of the A register was not zero when
{             the channel empty condition was detected.
{
{        39(16)  - 'EXIT FROM I/O INSTRUCTION'
{             An abnormal exit from an input instruction was detected.
{             The contents of the A register were <> 0 and the channel
{             was full and active at the time of the abnormal exit
{             from the input instruction.
{
{        3A(16)  - 'LOOPBACK DATA COMPARE ERROR'
{             The data returned on the diagnostic loopback test does not
{             match the data sent to the controller.
{
{            COUNTERS USED IF THE PPU REPORTS THE ERROR
{    10. Last function code sent to the optical disk controller
{    11. For error 39(16), number of channel words for data transfer.
{        For error 39a16), requested data pattern for loopback.
{    12. For error 39(16), residue number of channel words for data transfer.
{        For error 39a16), returned data pattern for loopback.
{    13. For error 39(16), expected number of 8-bit bytes for data transfer.
{    14. Current command table command code.
{            (used during developement).
{    15. PPU address of code detecting the error.
{            (used during developement).
{    16. A copy of the pp command being processed when the error occured.
{            (used during developement).
{    17. The index of the pp command being processed when the error occured.
{            (used during developement).
{    18-19. Currently not used.
{
{            COUNTERS USED IF THE CONTROLLER REPORTS THE ERROR
{                AND THE PP IS ABLE TO GET A HARDWARE STATUS.
{    20-25. Hardware status from controller eight bytes per counter.
{

  CONST
    cml$65850_1x_failure_data = cmc$min_ecc + 7410;

*copyc cmc$condition_limits
*DECK DECK=CML$698_1X_FAILURE_DATA EXPAND=FALSE
{
{ CML$698_1X_FAILURE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record the failure data
{ captured by the system when accessing a Cyber Magnetic Tape
{ Subsystem (CMTS).
{
{ FREQUENCY: At each failure occurrence.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<channel>.<coupler>.<unit>*<vsn>*<severity>..
{       *<symptom>
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is the string 'PPn' where n is the logical PP
{       number in decimal of the PP used to process the failing
{       request.
{
{      where <channel> is the string 'CHn' where n is the channel
{       number in decimal through which the tape device was
{       accessed.
{
{      where <adapter> is the element name of the cyber channel
{        coupler (CCC) used in the failing request.
{
{      where  <unit> is the element name of the failing tape storage
{        device used in the failing request.
{
{      where <vsn> is the external-vsn of the tape volume which  was
{        the object of the failing request.
{
{      where <severity> is the string 'UF'  for  unrecovered,  'RF'  for
{        recovered,  'IF'  for  intermediate and 'IM' for informative
{        message.
{
{      where <symptom> is the symptom/action statement  provided  by
{        the system.
{
{    The  counter-value portion of this statistic contains:
{
{    1.  Logical PP number
{        Bits 46 thru 51 contain the IOU number of the PP.
{        Bit 57 = 1 implies that the PP is an I4 concurrent PP.
{        Bits 58 thru 63 contain the logical PP number.
{    2.  Channel Number of channel coupler
{        Bits 0 thru 15 contain the initial C170/DMA channel Error
{         Status Register (only valid if bit 57 = 1).
{        Bits 16 thru 31 contain the final C170/DMA channel Error
{         Status Register (only valid if bit 57 = 1).
{        Bits 46 thru 51 contain the IOU number of the channel.
{        Bit 57 = 1 implies that the channel is an I4 concurrent
{         channel.
{        Bits 58 thru 63 contain the channel number.
{    3.  Equipment Number of channel coupler
{    4.  Physical Unit Number
{    5.  Unit-type
{       8 - 698-3X
{    6.  Logical Operation Code
{       1 - read
{       2 - write
{       3 - rewind
{       4 - unload
{       6 - write_tapemark
{       7 - data_security_erase
{       8 - forespace
{       9 - backspace
{       10 - forespace_tapemark(s)
{       11 - backspace_tapemark(s)
{       12 - get_status
{       13 - TCU_loopback
{       14 - Unit_loopback_I
{       15 - Unit_loopback_II
{       16 - master clear
{    7.  Failure Severity
{       0 - Recovered Failure
{       1 - Unrecovered Failure
{       2 - Intermediate Failure Report
{       3 - Informative Message
{    8.  Failure Symptom Code (tells what the system thinks is wrong)
{       1 - INDETERMINATE (channel or CCC or unit)
{       2 - INPUT CHANNEL PARITY - On an input from controller to PP
{           the channel-error-flag was set.
{       3 - OUTPUT CHANNEL PARITY - On an output from the PP to the
{           controller,  the controller reported a parity error in
{           detailed status but the channel-error-flag was not set.
{       4 - CONTROLLER FAILURE - (reported by channel coupler)
{       5 - UNIT FAILURE
{       6 - FUNCTION TIMEOUT - (channel coupler not responding)
{       7 - TAPE MEDIUM FAILURE
{       8 - ERASE LIMIT EXCEEDED
{      10 - IOU OUTPUT PARITY - On an output from PP to controller
{           both the channel-error-flag and the controller's
{           detailed status indicated a parity error had occurred.
{      11 - INDETERMINATE OUTPUT PARITY - On an output from PP to
{           controller the channel-error-flag was set but there
{           was no parity error reported by the controller.
{      12 - UNABLE TO WRITE ID BURST - The id-burst could not be
{           written at load point.
{      13 - UNABLE TO SET AGC - The drive was not capable of
{           setting automatic gain control.
{      14 - ON THE FLY HARDWARE CORRECTIONS - The reported hardware status
{           indicated that Single or Double Track Corrections were
{           made while the tape file was active. This Failure Symptom
{           Code indicates a valid count in the counter word labelled
{           On The Fly single/double track corrections count.
{
{    9.   Blocks written on Unit
{    10.  Blocks read on Unit
{    11.  On The Fly single/double track corrections count
{    12.  UNUSED
{    13.  Absolute Block Count from Load Point
{    14.  Absolute number of Tape/File Marks from Load Point
{    15.  User requested format parameters
{    16.  Actual Density at which the unit was functioning
{    17.  Type of Recovery performed  on  a  successful  recovery.
{         This will apply when CDC Error Recovery Standard is
{         totally implemented.  The following recovery states are
{         presently listed in the standard, but they may change when
{         the standard is finally approved.
{
{               1 - Load-point Recovery
{               2 - Read Recovery
{               3 - Write Recovery
{               4 - File Mark Write Recovery
{    18.  Retry count of recovery attempts
{    19.  Last requested function (non-status)
{
{   First-failure Data:
{    20 .. 23.  Initial General and Detailed Status (16 PP words  -
{              4 per Counter Word).   See CMTS General/Detailed
{              Status layout.
{    24 .. 28.  Initial Extended Status (CMTS Sense Bytes - 20
{              PP words, 4 per Counter Word).
{              Upper 4 bits of every PP word are zeros.
{              Reference  CDC  Pub. (CMTS MB467 ERS).
{
{   Last-failure Data:
{    29 .. 32.  Final General and Detailed Status (16 PP words -  4
{              per Counter Word).  See CMTS General/Detailed Status
{              layout.
{    33 .. 37.  Final Extended Status (CMTS Sense Bytes - 20
{              PP words, 4 per Counter Word).
{              Upper 4 bits of every PP word are zeros.
{              Reference  CDC  Pub. (CMTS MB467 ERS).
{    38 .. 46.  Historical Block Identification Window (9 CM words)
{
{              Counter-value 38:
{                     BID index : 0..0ffff(16) (Bits 0 - 15)
{                     Limit: 0..0ffff(16) (Bits 16 - 31)
{                     Reserved : 0..0ffffffff(16) (Bits 32 - 63)
{
{              Counter-value 39 thru 46:
{                ARRAY  [1  ..   window_length] OF 0..0ffff(16)
{                (bid_window_length  is 32 decimal elements)
{    47 .. 55.  Current Block Identification Window (9 CM words)
{              Same structure as Historical window above
{              (Counter-values 38 .. 46)
{    56 .. 62.  Presently unused.
{

  CONST
    cml$698_1x_failure_data = cmc$min_ecc + 5102;

*copyc cmc$condition_limits
*DECK DECK=CML$7021_3X_FAILURE_DATA EXPAND=FALSE
{
{ CML$7021_3X_FAILURE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record the failure data
{ captured by the system when accessing a 7021_3x tape subsystem.
{
{ FREQUENCY: At each failure occurrence.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<channel>.<controller>.<unit>*<vsn>*<severity>..
{       *<symptom>
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is either the string 'PPn' or the string 'CPPn'
{        and n is the decimal representation of the logical PP number
{        used to process the failing request.  Note that 'CPP' is the
{        designation given to the concurrent PPs in an I4 IOU.
{
{      where <channel> is either the string 'CHn' or the string
{        'CCHnp'; n is the decimal representation of the channel
{        number and p is the channel port (A or B) through which
{        the disk device was accessed.  Note that 'CCH' is the
{        designation given to the concurrent channels in an I4 IOU.
{
{      where <controller> is the element name of the tape controller
{        used in the failing request.
{
{      where  <unit> is the element name of the failing tape storage
{        device used in the failing request.
{
{      where <vsn> is the external-vsn of the tape volume which  was
{        the object of the failing request.
{
{      where <severity> is the string 'UF'  for  unrecovered,  'RF'  for
{        recovered,  'IF'  for  intermediate and 'IM' for informative
{        message.
{
{      where <symptom> is the symptom/action statement  provided  by
{        the system.
{
{    The  counter-value portion of this statistic contains:
{
{    1.  Logical PP number
{        Bits 46 thru 51 contain the IOU number of the PP.
{        Bit 57 = 1 implies that the PP is an I4 concurrent PP.
{        Bits 58 thru 63 contain the logical PP number.
{    2.  Channel Number of channel coupler
{        Bits 0 thru 15 contain the initial C170/DMA channel Error
{         Status Register (only valid if bit 57 = 1).
{        Bits 16 thru 31 contain the final C170/DMA channel Error
{         Status Register (only valid if bit 57 = 1).
{        Bits 46 thru 51 contain the IOU number of the channel.
{        Bit 57 = 1 implies that the channel is an I4 concurrent
{         channel.
{        Bits 58 thru 63 contain the channel number.
{    3.  Equipment Number of Controller
{    4.  Physical Unit Number
{    5.  Unit-type
{       1 - 679_2
{       2 - 679_3
{       3 - 679_4
{       4 - 679_5
{       5 - 679_6
{       6 - 679_7
{    6.  Logical Operation Code
{       1 - read
{       2 - write
{       3 - rewind
{       4 - unload
{       5 - clear_reserve
{       6 - write_tapemark
{       7 - data_security_erase
{       8 - forespace
{       9 - backspace
{       10 - forespace_tapemark(s)
{       11 - backspace_tapemark(s)
{       12 - get_status
{       13 - TCU_loopback
{       14 - unit_loopback_I
{       15 - unit_loopback_II
{       16 - master clear
{    7.  Failure Severity
{       0 - Recovered Failure
{       1 - Unrecovered Failure
{       2 - Intermediate Failure Report
{       3 - Informative Message
{    8.  Failure Symptom Code
{       1 - INDETERMINATE (channel or controller or unit)
{       2 - INPUT CHANNEL PARITY - On an input from controller to PP
{           the channel-error-flag was set.
{       3 - OUTPUT CHANNEL PARITY - On an output from the PP to the
{           controller,  the controller reported a parity error in
{           detailed status but the channel-error-flag was not set.
{       4 - CONTROLLER FAILURE - (reported by controller)
{       5 - UNIT FAILURE
{       6 - FUNCTION TIMEOUT - (controller not responding)
{       7 - TAPE MEDIUM FAILURE
{       8 - ERASE LIMIT EXCEEDED
{       9 - UNIT RESERVED (to another controller)
{      10 - IOU OUTPUT PARITY - On an output from PP to controller
{           both the channel-error-flag and the controller's
{           detailed status indicated a parity error had occurred.
{      11 - INDETERMINATE OUTPUT PARITY - On an output from PP to
{           controller the channel-error-flag was set but there
{           was no parity error reported by the controller.
{      12 - UNABLE TO WRITE ID BURST - The id-burst could not be
{           written at load point.
{      13 - UNABLE TO SET AGC - The drive was not capable of
{           setting automatic gain control.
{      14 - ON THE FLY HARDWARE CORRECTIONS - The reported hardware status
{           indicated that Single or Double Track Corrections were
{           made while the tape file was active. This Failure Symptom
{           Code indicates a valid count in the counter word labelled
{           On The Fly single/double track corrections count.
{     9.  Blocks written on Unit
{    10.  Blocks read on Unit
{    11.  On The Fly single/double track corrections count
{    12.  UNUSED
{    13.  Absolute Block Count (IRG's) from Load Point
{    14.  Absolute number of Tape/File Marks from Load Point
{    15.  User requested format parameters
{    16.  Actual Density at which the unit was functioning
{    17.  Type of Recovery performed  on  a  successful  recovery.
{         This will apply when CDC Error Recovery Standard is
{         totally implemented.  The following recovery states are
{         presently listed in the standard, but they may change when
{         the standard is finally approved.
{
{               1 - Load-point Recovery
{               2 - Read Recovery
{               3 - Write Recovery
{               4 - File Mark Write Recovery
{    18.  Retry count of recovery attempts
{    19.  Last requested function (non-status)
{
{   First-failure Data:
{    20 .. 23.  Initial General and Detailed Status (16 PP words  -
{              4 per Counter Word).   See ATS General/Detailed
{              Status layout.
{    24 .. 28.  Unused for 7021 hardware.
{
{   Last-failure Data:
{    29 .. 32.  Final General and Detailed Status (16 PP words -  4
{              per Counter Word).  See ATS General/Detailed Status
{              layout.
{    33 .. 37.  Unused for 7021 hardware.
{    38 .. 46.  Historical Block Identification Window (9 CM words)
{
{              Counter-value 38:
{                     BID index : 0..0ffff(16) (Bits 0 - 15)
{                     Limit: 0..0ffff(16) (Bits 16 - 31)
{                     Reserved : 0..0ffffffff(16) (Bits 32 - 63)
{
{              Counter-value 39 thru 46:
{                ARRAY  [1  ..  bid_window_length] OF 0..0ffff(16)
{                (bid_window_length  is 32 decimal elements)
{    47 .. 55.  Current Block Identification Window (9 CM words)
{              Same structure as Historical window above
{              (Counter-values 38 .. 46)
{    56 .. 62. Presenly unused.
{

  CONST
    cml$7021_3x_failure_data = cmc$min_ecc + 5100;

*copyc cmc$condition_limits
*DECK DECK=CML$7040_200_LSP_FAILURE_DATA EXPAND=FALSE
{
{ DECK: CML$7040_200_LSP_FAILURE_DATA
*copyc cmh$lsp_failure_data_doc

  CONST
    cml$7040_200_lsp_failure_data = cmc$min_ecc + 7303;

*copyc cmc$condition_limits
*DECK DECK=CML$7040_200_SDP_FAILURE_DATA EXPAND=FALSE
{
{ DECK: CML$7040_200_SDP_FAILURE_DATA

*copyc cmh$sdp_failure_data_doc

  CONST
    cml$7040_200_sdp_failure_data = cmc$min_ecc + 7301;

*copyc cmc$condition_limits
*DECK DECK=CML$7154_FAILURE_DATA EXPAND=FALSE
{
{ CML$7154_FAILURE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record the failure data
{ captured by the system when accessing a 7154 disk subsystem.
{
{ FREQUENCY: At occurrence of failure.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<channel>.<controller>.<unit>*<vsn>*<class>*
{       <symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is either the string 'PPn' or 'CPPn' and where 'n'
{        is the decimal representation of the logical PP number used
{        to process the failing request.  Note that 'CPP' is the
{        designation given to the concurrent PPs in an I4 IOU.
{
{      where <channel> is either the string 'CHn' or 'CCHnp',
{        where 'n' is the decimal representation of the channel and
{        where 'p' is the channel port (A or B) through which the
{        disk device was accessed.  Note that 'CCH' is the
{        designation given to the concurrent channels in an I4 IOU.
{
{      where <controller> is the element name of the disk controller
{        used in the failing request.
{
{      where  <unit> is the element name of the failing disk storage
{        device used in the failing request.
{
{      where <vsn> is the recorded-vsn of the disk volume which  was
{        the object of the failing request.
{
{      where  <class>  is  the string 'UF' for unrecovered, 'RF' for
{        recovered, 'IF' for intermediate failure log-entry, and 'IM'
{        for informative message.
{
{        The PP reports failure data and diagnostic results  as  an
{        intermediate  failure  log-entry  prior  to retrying an i/o
{        request.  This is due to  PP-memory-size  limitations.   An
{        intermediate    failure    log-entry   will   provide   the
{        first-failure data captured by the PP  during  the  initial
{        attempt  at  the  request  or  during  a subsequent request
{        retry.  This  log-entry  provides  the  initial  and  final
{        failure data for an intermediate, unsuccessful i/o request
{        retry.  At least  one  additional  request  retry  will  be
{        performed after this log-entry is made.
{
{        For  unrecovered  disk failures the counter values contain
{        the failure data corresponding  to  the  last  unsuccessful
{        retry of the i/o request.  This log-entry provides
{        the   initial   and  final  failure  data  for  the  final,
{        unsuccessful i/o request retry.
{
{        For  failures  corrected  during  sector-oriented  (media)
{        recovery, the counter values contain the first-failure data
{        captured by  the  PP.   This  log-entry  is  only  made  to
{        document successful sector-oriented recovery.
{
{      where <symptom> is the symptom/action statement  provided  by
{        the system.
{
{    The counter-value portion of this statistic contains:
{
{    1.  Logical PP number (bits 58 - 63).
{        Bits 46 - 51 contain the IOU number.
{
{    2.  Channel Number of Controller (bits 58 - 63).
{        Bits 46 - 51 contain the IOU number.
{
{    3.  Equipment Number of Controller
{    4.  Physical Unit Number
{    5.  Unit-type (identifies the kind of unit, i.e.  product id)
{        1 - 844-4x
{    6.  Logical Operation Code
{        1 - read
{        2 - write
{        4 - read_flaw_map
{        5 - disk_driver_initialization
{    7.  Log-entry Class
{        0 - Recovered Failure Report
{        1 - Unrecovered Failure Report
{        2 - Intermediate Failure Report
{        3 - Informative Message
{    8.  Failure Symptom Code (tells what the system thinks is wrong)
{        1 - INDETERMINATE (channel or controller orunit)
{        2 - INPUT CHANNEL PARITY - On an input from controller to PP
{            the channel-error-flag was set.
{        3 - OUTPUT CHANNEL PARITY - On an output from the PP to the
{            controller, the controller reported a parity error in
{            detailed status but the channel-error-flag was not set.
{        4 - CONTROLLER FAILURE - (reported by controller)
{        5 - UNIT FAILURE
{        6 - FUNCTION TIMEOUT - (controller not responding)
{        7 - UNIT RESERVED - (unit reserved to opposite access)
{            During i/o request processing the PP driver attempts
{            to connect to the target unit.  If it cannot connect
{            to the unit, this statistic is generated.  The driver
{            will terminate the i/o request as a result of the failure.
{        8 - CONTROLLER RESERVED - (to another channel)
{            During i/o request processing the PP driver attempts
{            to obtain the coupler reservation.  If not successful for
{            10 seconds, this statistic is generated.  The driver will
{            continue to try to obtain the coupler reservation until
{            successful.
{        9 - SEEK FAILURE
{        10 - ERROR IN CHECKWORD
{        11 - CONTROLLER RAM PARITY
{        12 - INCOMPLETE SECTOR TRANSFER
{        15 - UNIT NOT READY - START switch off, unit not spun up or
{            dropped ready
{        16 - UNIT OFFLINE OR NOT CABLED - 844 unit has switch on back
{            of unit in offline position or unit not cabled
{            to controller.
{        17 - UNIT READ ONLY SWITCH ON - 885 unit has write-inhibit
{            switch set
{        18 - CHAN ENABLE SWITCH OFF/UNIT NOT CABLED - 885 unit has
{            CHAN ENABLE switch off or unit is not cabled to the
{            controller.
{        19 - FLAWED TRACK - a sector with a track flaw bit set
{            has been read/written.  This may indicate that the
{            Utility Map is wrong or there is a NOS/VE software
{            problem.
{        20 - FLAWED SECTOR - a flawed sector on an 844 unit has been
{            read/written.  This may indicate that the Utility MAP is
{            wrong or there is a NOS/VE software problem.
{        21 - SECTOR ADDRESS MISCOMPARE
{        22 - CYLINDER ADDRESS MISCOMPARE
{        23 - LOST CONTROL WORD
{        24 - IOU OUTPUT PARITY - On an output from PP to controller
{            both the channel-error-flag and the controller's detailed
{            status indicated a parity error occurred.
{        25 - INDETERMINATE OUTPUT PARITY - On an output from PP to
{            controller the channel-error-flag was set but there was
{            no error reported by the controller.  This may mean there is
{            a problem in the IOU and/or the channel and/or the
{            controller.
{        26 - SOFTWARE FAILURE - The driver has detected an error
{            in the CP/PP interface.
{        27 - ADDRESS ERROR - Word 1, bit 3, is set in the detailed
{            status.
{        28 - TRACK ADDRESS MISCOMPARE - Word 1, bit 1, is set in the
{            detailed status.
{        29 - DRIVE NOT SELECTED - Word 9, bit 8, = 0, in the detailed
{            status.
{        30 - CONTROLLER - DRIVE INTERFACE ERROR -
{            - Word 18, bit 4, is set in the detailed status;
{        31 - PP - CONTROLLER DATA INTEGRITY - Data was transferred
{             between the PP and the controller, no error was detected,
{             but the data miscompared.
{        32 - PP - DRIVE DATA INTEGRITY - Data was written to disk, then
{             read from disk.  No error was detected, but the data
{             miscompared.
{        33 - WRITE BUFFER TO DISK ERROR
{        34 - PROCESSOR INSTRUCTION TIMEOUT - an internal controller
{             channel used to function the disk has timed out.
{        35 - BM REGISTER PARITY ERROR - The controller buffer memory
{             output register detected a parity error during a write
{             to disk.
{        36 - WRITE VERIFY ERROR
{        37 - MEDIA FAILURE - The confidence test passed and retries of
{             the request failed.  The sector is also software flawed
{             when this is the message.
{        38 - CONFIDENCE CYLINDER IS FLAWED - Sector or track flaw bits
{             are set in every address of every sector on the cylinder,
{             so the confidence test can not be run.
{        39 - LOADING CONTROLWARE - This is an informative message that
{             controlware is being loaded.
{    9.  Request Retry Count
{        The number of times the PP driver retried the i/o request
{        from the beginning.
{    10. Sector Retry Count
{        The number of retries that the PP driver performed on the
{        failing sector on the last attempt to retry the i/o request.
{    11. Cylinder number of initial seek
{    12. Track number of initial seek
{    13. Sector number of initial seek
{    14. Cylinder number of failure - This is normally the cylinder
{        number in the disk request.  However, if the failure occurred
{        while running the confidence test, the cylinder number will be
{        821 for an 844 drive and 842 for an 885 drive.
{    15. Track number of failure
{    16. Sector number of failure
{    17. Residual byte count on incomplete channel transfer
{    18. Failing Function
{        The function that caused the initial recovery attempt.
{        The value is extracted from the initial detailed status if
{        the controller provides status after the failure.  On a
{        function timeout, the function reported is the one which
{        was outstanding when the controller hung.
{
{   First-failure Data:
{     19.       Poll Status
{                     (right justified)
{     20 .. 39. Words 1..20 of Detailed Status
{                     (right justified)
{
{   The following failure data is only provided in the
{   cases where the Log-entry Class is unrecovered or
{   intermediate.  The data represents the subsystem
{   status at the end of the intermediate or final
{   request retry.
{
{   Last-failure Data:
{     40.       Poll Status
{                     (right justified)
{     41 .. 60. Words 1..20 of Detailed Status
{                     (right justified)
{

  CONST
    cml$7154_failure_data = cmc$min_ecc + 4100;

*copyc cmc$condition_limits

*DECK DECK=CML$7155_1X_FAILURE_DATA EXPAND=FALSE
{
{ CML$7155_1X_FAILURE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record the failure data
{ captured by the system when accessing a 7155_1x disk subsystem.
{
{ FREQUENCY: At occurrence of failure.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{   '<mf>.<iou>.<pp>.<channel>.<controller>.<unit>*<vsn>*<class>*..
{      <symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is either the string 'PPn' or 'CPPn' and where 'n'
{        is the decimal representation of the logical PP number used
{        to process the failing request.  Note that 'CPP' is the
{        designation given to the concurrent PPs in an I4 IOU.
{
{      where <channel> is either the string 'CHn' or 'CCHnp',
{        where 'n' is the decimal representation of the channel and
{        where 'p' is the channel port (A or B) through which the
{        disk device was accessed.  Note that 'CCH' is the
{        designation given to the concurrent channels in an I4 IOU.
{
{      where <controller> is the element name of the disk controller
{        used in the failing request.
{
{      where  <unit> is the element name of the failing disk storage
{        device used in the failing request.
{
{      where <vsn> is the recorded-vsn of the disk volume which  was
{        the object of the failing request.
{
{      where  <class>  is  the string 'UF' for unrecovered, 'RF' for
{        recovered, 'IF' for intermediate failure log-entry, and 'IM'
{        for informative message.
{
{        The PP reports failure data and diagnostic results  as  an
{        intermediate  failure  log-entry  prior  to retrying an i/o
{        request.  This is due to  PP-memory-size  limitations.   An
{        intermediate    failure    log-entry   will   provide   the
{        first-failure data captured by the PP  during  the  initial
{        attempt  at  the  request  or  during  a subsequent request
{        retry.  This  log-entry  provides  the  initial  and  final
{        failure data for an intermediate, unsuccessful i/o request
{        retry.  At least  one  additional  request  retry  will  be
{        performed after this log-entry is made.
{
{        For  unrecovered  disk failures the counter values contain
{        the failure data corresponding  to  the  last  unsuccessful
{        retry of the i/o request.  This log-entry provides
{        the   initial   and  final  failure  data  for  the  final,
{        unsuccessful i/o request retry.
{
{        For  failures  corrected  during  sector-oriented  (media)
{        recovery, the counter values contain the first-failure data
{        captured by  the  PP.   This  log-entry  is  only  made  to
{        document successful sector-oriented recovery.
{
{      where <symptom> is the symptom/action statement  provided  by
{        the system.
{
{    The  descriptive-data portion of this statistic contains:
{
{    1.  Logical PP number (bits 58 - 63).
{        Bit 57 = 1 implies that the PP is an I4 concurrent PP.
{        Bits 46 - 51 contain the IOU number.
{
{    2.  Channel Number of Controller (bits 58 - 63).
{        Bit 57 = 1 implies that the channel is an I4 concurrent
{        channel.
{        Bits 46 - 51 contain the IOU number.
{
{    3.  Equipment Number of Controller
{    4.  Physical Unit Number
{    5.  Unit-type (identifies the kind of unit, i.e.  product id)
{        1 - 844-4x
{        2 - 885-1x
{    6.  Logical Operation Code
{        1 - read
{        2 - write
{        4 - read_flaw_map
{        5 - disk_driver_initialization
{    7.  Log-entry Class
{        0 - Recovered Failure Report
{        1 - Unrecovered Failure Report
{        2 - Intermediate Failure Report
{        3 - Informative Message
{    8.  Failure Symptom Code
{        1 - INDETERMINATE (channel or controller or unit)
{        2 - INPUT CHANNEL PARITY - On an input from controller to
{            PP the channel-error-flag was set.
{        3 - OUTPUT CHANNEL PARITY - On an output from the PP to the
{            controller, the controller reported a parity error in
{            detailed status but the channel-error-flag was not set.
{        4 - CONTROLLER FAILURE - (reported by controller)
{        5 - UNIT FAILURE
{        6 - FUNCTION TIMEOUT - (controller not responding)
{        7 - UNIT RESERVED - (unit reserved to opposite access)
{            During i/o request processing the PP driver attempts
{            to connect to the target unit.  If it cannot connect
{            to the unit, this statistic is generated.  The driver
{            will terminate the i/o request as a result of the
{            failure.
{        8 - CONTROLLER RESERVED - (to another channel)
{            During i/o request processing the PP driver attempts
{            to obtain the coupler reservation.  If not successful for
{            10 seconds, this statistic is generated.  The driver will
{            continue to try to obtain the coupler reservation until
{            successful.
{        9 - SEEK FAILURE
{        10 - ERROR IN CHECKWORD
{        11 - CONTROLLER RAM PARITY
{        12 - INCOMPLETE SECTOR TRANSFER
{        15 - UNIT NOT READY - START switch off, unit not spun up or
{            dropped ready
{        16 - UNIT OFF LINE OR NOT CABLED - 844 unit has switch on back
{            of unit in offline position or unit not cabled
{            to controller.
{        17 - UNIT READ ONLY SWITCH ON - 885 unit has write-inhibit
{            switch set
{        18 - CHAN ENABLE SWITCH OFF OR UNIT NOT CABLED - 885 unit has
{            CHAN ENABLE switch off or unit is not cabled to the
{            controller.
{        19 - FLAWED TRACK - a sector with a track flaw bit set
{            has been read/written.  This may indicate that the
{            Utility Map is wrong or there is a NOS/VE software
{            problem.
{        20 - FLAWED SECTOR - a flawed sector on an 844 unit has been
{            read/written.  This may indicate that the Utility MAP is
{            wrong or there is a NOS/VE software problem.
{        21 - SECTOR ADDRESS MISCOMPARE
{        22 - CYLINDER ADDRESS MISCOMPARE
{        23 - LOST CONTROL WORD
{        24 - IOU OUTPUT PARITY - On an output from PP to controller
{            both the channel-error-flag and the controller's detailed
{            status indicated a parity error occurred.
{        25 - INDETERMINATE OUTPUT PARITY - On an output from PP to
{            controller the channel-error-flag was set but there was
{            no error reported by the controller.  This may mean there is
{            a problem in the IOU and/or the channel and/or the
{            controller.
{        26 - SOFTWARE FAILURE - The driver has detected an error
{            in the CP/PP interface.
{        27 - ADDRESS ERROR - Word 1, bit 3, is set in the detailed
{            status.
{        28 - TRACK ADDRESS MISCOMPARE - Word 1, bit 1, is set in the
{            detailed status.
{        29 - DRIVE NOT SELECTED - Word 9, bit 8, = 0, in the detailed
{            status.
{        30 - CONTROLLER - DRIVE INTERFACE ERROR -
{            - Word 18, bit 4, is set in the detailed status; or
{            - If the command was a seek, and word 13, bits 8 - 0
{              are nonzero. (885)
{        31 - PP - CONTROLLER DATA INTEGRITY - Data was transferred
{             between the PP and the controller, no error was detected,
{             but the data miscompared.
{        32 - PP - DRIVE DATA INTEGRITY - Data was written to disk, then
{             read from disk.  No error was detected, but the data
{             miscompared.
{        33 - WRITE BUFFER TO DISK ERROR
{        34 - PROCESSOR INSTRUCTION TIMEOUT - an internal controller
{             channel used to function the disk has timed out.
{        35 - BM REGISTER PARITY ERROR - The controller buffer memory
{             output register detected a parity error during a write
{             to disk.
{        36 - WRITE VERIFY ERROR
{        37 - MEDIA FAILURE - The confidence test passed and retries of
{             the request failed.  The sector is also software flawed
{             when this is the message.
{        38 - CONFIDENCE CYLINDER IS FLAWED - Sector or track flaw bits
{             are set in every address of every sector on the cylinder,
{             so the confidence test can not be run.
{        39 - LOADING CONTROLWARE - This is an informative message that
{             controlware is being loaded.
{    9.  Request Retry Count
{        The number of times the PP driver retried the i/o request
{        from the beginning.
{    10. Sector Retry Count
{        The number of retries that the PP driver performed on the
{        failing sector on the last attempt to retry the i/o request.
{    11. Cylinder number of initial seek
{    12. Track number of initial seek
{    13. Sector number of initial seek
{    14. Cylinder number of failure - This is normally the cylinder
{        number in the disk request.  However, if the failure occurred
{        while running the confidence test, the cylinder number will be
{        821 for an 844 drive and 842 for an 885 drive.
{    15. Track number of failure
{    16. Sector number of failure
{    17. Residual byte count on incomplete channel transfer
{    18. Failing Function
{        The function that caused the initial recovery attempt.
{        The value is extracted from the initial detailed status if
{        the controller provides status after the failure.  On a
{        function timeout, the function reported is the one which
{        was outstanding when the controller hung.
{
{   First-failure Data:
{     19.       Poll Status
{                     (right justified)
{     20 .. 39. Words 1..20 of Detailed Status
{                     (right justified)
{
{   The following failure data is only provided in the
{   cases where the Log-entry Class is unrecovered or
{   intermediate.  The data represents the subsystem
{   status at the end of the intermediate or final
{   request retry.
{
{   Last-failure Data:
{     40.       Poll Status
{                     (right justified)
{     41 .. 60. Words 1..20 of Detailed Status
{                     (right justified)
{

  CONST
    cml$7155_1x_failure_data = cmc$min_ecc + 4101;

*copyc cmc$condition_limits



*DECK DECK=CML$7165_2X_FAILURE_DATA EXPAND=TRUE
{
{ CML$7165_2x_FAILURE_DATA
{
{
{  PURPOSE:
{     The purpose of this statistic is to record the failure data
{ captured by the system when accessing a 7165 disk subsystem.
{
{  FREQUENCY: At each failure occurrence.
{
{  CONTENT:
{     The descriptive_data portion of the failure message is the
{ following:
{
{   '<mf>.<iou>.<pp>.<ch>.<sd>.<unit>*<vsn>*<class>*..
{    <message>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where <iou> is the string 'IOUn', where n is 0 or 1.  This
{        identifies  the  IOU  associated with the channel over
{        which the failure was reported.
{
{      where <pp> is either the string 'PPn' or the string 'CPPn'
{        and n is the decimal representation of the physical PP number
{        used to process the failing request.  Note that 'CPP' is the
{        designation given to the concurrent PPs in an I4 IOU.
{        This is the master PP as  only  the  master  PP performs
{        error recovery.
{
{      where <channel> is either the string 'CHn' or the string
{        'CCHn'; n is the decimal representation of the channel
{        number through which the disk device was accessed.  Note
{        that 'CCH' is the designation given to the concurrent
{        channels in an I4 IOU.
{
{      where <sd> is the element name of the 7165_2x Storage Director
{        used in the failing request.
{
{      where  <unit> is the element name of the disk storage
{        device used in the failing request.
{
{      where <vsn> is the recorded-vsn of the disk volume which  was
{        the object of the failing request.
{
{      where  <class>  is  the string 'UF' for unrecovered, 'RF' for
{        recovered, 'IF' for intermediate failure log-entry, and
{        'IM' for an informative message.
{
{        The  PP  reports failure data as an intermediate failure
{        log-entry  prior  to  retrying  an  i/o  request.   An
{        intermediate    failure    log-entry   will   provide   the
{        first-failure data captured by the PP  during  the  initial
{        attempt  at  the  request  or  during  a subsequent request
{        retry.  This  log-entry  provides  the  initial  and  final
{        failure data for an intermediate, unsuccessful i/o request
{        retry.  At least  one  additional  request  retry  will  be
{        performed after this log-entry is made.
{
{        For  unrecovered  disk failures the counter values contain
{        the failure data corresponding  to  the  last  unsuccessful
{        retry of the i/o request.  This log-entry provides
{        the   initial   and  final  failure  data  for  the  final,
{        unsuccessful i/o request retry.
{
{        For  failures  corrected  during  sector-oriented  (media)
{        recovery, the counter values contain the first-failure data
{        captured by  the  PP.   This  log-entry  is  only  made  to
{        document successful sector-oriented recovery.
{
{        The informative messages reported are SOFT SECTORING UNIT
{        and UNIT SOFT SECTORED.
{
{      where <message> is a statement of failure isolation based on
{        status reported by the 7165 subsystem.  The text of the
{        possible symptom statements are identical in content to
{        the upper case text described under counter value 8 below.
{
{    The  counter-value portion of this statistic contains:
{
{   1.  Physical PP number (bits 58 - 63).
{        Bit 57 = 1 implies that the PP is an I4 concurrent PP.
{        Bits 46 - 51 contain the IOU number.
{
{   2.  Channel Number (bits 58 - 63).
{        Bit 57 is set to 1 for an I4 concurrent channel.
{        Bits 46 - 51 contain the IOU number.
{
{   3.  Address of SD/HSC
{        Bits 60..62 contain the address of the Storage Director.
{        Bit 63 contains the address of the Head of String controller.
{
{   4.  Physical Unit Number
{
{   5.  Unit type (identifies the kind of unit, i.e.  product id)
{       5 - 895-2
{
{   6.  Logical Operation Code
{       1 - read
{       2 - write
{       4 - soft-sectoring the device
{
{   7.  Log-entry Class
{       0 - Recovered Failure Report
{       1 - Unrecovered Failure Report
{       2 - Intermediate Failure Report
{       3 - Informative Message
{
{   8.  Failure Analysis              Indicates  the  extent  to  which  the
{                                     subsystem and  the  PP  were  able  to
{                                     isolate   the   failure  when  it  was
{                                     detected.  The failure data is analyzed
{                                     to  generate  one  of  the  following
{                                     symptom codes.
{
{        1 - STORAGE DIRECTOR RETRY   General Status = 900(16)
{                                     EDS word 19 = 44A(16).  The storage
{                                     director  has  requested the CCC to
{                                     retry the command, but no sense bytes
{                                     are present.
{
{       Values 10 through 79 are only returned for errors where sense
{       bytes from the storage director are present.  Sense bytes are
{       present when general status equals A10(16).  They are also
{       present when general status equals 900(16) and EDS word 19
{       equals 402(16).  The upper hexadecimal digit of EDS byte 7
{       contains a format code and the lower hexadecimal digit of EDS
{       byte 7 contains a message code.
{
{       In general, if the format is 0, the problem is in the CCC or
{       storage director.  If the format code is 1, there is a drive
{       problem, if the code is 2 or 3 there is a storage director
{       problem, if the code is 4 or 5 there is a media problem, if
{       the code is 7 there is a Director to Device Controller (DDC)
{       interface problem, and if the code is 8 there is a Head of
{       String Controller (HSC) problem.
{
{       For messages 10 through 38 and 40 through 79 a symptom code is
{       saved in counter word 10.  The symptom code is generated by the
{       storage director and comes from sense bytes 22 and 23.  The
{       symptom code can be looked up in the hardware maintenance manual
{       to find a list of repair actions.
{
{       10 - UNDOCUMENTED FORMAT x MESSAGE
{                                     x is the format code (0-5,7,8)
{
{       The following symptom statements are most likely caused by the
{       CCC or storage director.
{
{       11 - INVALID COMMAND          EDS byte 7 = 01
{
{       12 - INVALID COMMAND ISSUED TO 7165
{                                     EDS byte 7 = 02
{
{       13 - CCW COUNT TOO SMALL      EDS byte 7 = 03
{
{       14 - INVALID DATA ARGUMENT    EDS byte 7 = 04
{
{       16 - CHAINING NOT INDICATED   EDS byte 7 = 06
{
{       17 - COMMAND MISMATCH         EDS byte 7 = 07
{
{       18 - DEFECTIVE TRACK POINTER  EDS byte 7 = 0B
{
{       The following symptom statements are most likely caused by
{       the drive.
{
{       19 - DEVICE STATUS 1 NOT EXPECTED
{                                     EDS byte 7 = 11
{
{       20 - INDEX MISSING            EDS byte 7 = 13
{
{       21 - UNRESETTABLE INTERRUPT   EDS byte 7 = 14
{
{       22 - DEVICE DOES NOT RESPOND  EDS byte 7 = 15
{
{       23 - INCOMPLETE SET SECTOR    EDS byte 7 = 16
{
{       24 - HEAD ADDRESS MISCOMPARE  EDS byte 7 = 17
{
{       25 - INVALID DEVICE STATUS 1  EDS byte 7 = 18
{
{       26 - DEVICE NOT READY         EDS byte 7 = 19
{
{       27 - TRACK ADDRESS MISCOMPARE
{                                     EDS byte 7 = 1A
{
{       28 - DRIVE MOTOR OFF          EDS byte 7 = 1C
{
{       29 - SEEK INCOMPLETE          EDS byte 7 = 1D
{
{       30 - CYLINDER ADDRESS MISCOMPARE
{                                     EDS byte 7 = 1E
{
{       31 - UNRESETTABLE OFFSET ACTIVE
{                                     EDS byte 7 = 1F
{
{       The following symptom statements are most likely caused by
{       the storage director.
{
{       32 - SELECTIVE RESET WHILE SELECTED
{                                     EDS byte 7 = 29
{
{       33 - SYNC LATCH FAILURE       EDS byte 7 = 2A
{
{       34 - MICROCODE DETECTED CHECK
{                                     EDS byte 7 = 2F
{
{       35 - CLOCK STOPPED CHECK 1 (SD)
{                                     EDS byte 7 = 38
{
{       36 - ALTERNATE STORAGE DIRECTOR FAILURE
{                                     EDS byte 7 = 3A
{
{       The following symptom statements are most likely caused by
{       media defects.
{
{       37 - ERROR UNCORRECTABLE BY ECC
{                                     EDS byte 7 = 40,41,42,43,48,49,4A,4B
{
{       38 - DATA SYNCHRONIZATION UNSUCCESSFUL
{                                     EDS byte 7 = 44,45,46,47,4C,4D,4E,4F
{
{       39 - ERROR CORRECTABLE BY ECC EDS byte 7 = 50,51,52,53,58,59,5A,5B
{
{       The following symptom statements are most likely caused by the
{       storage director or an error in the storage director to head of
{       string controller path (DDC).
{
{       41 - RCC INITIATED BY CCA     EDS byte 7 = 70
{
{       42 - RCC1 NOT SUCCESSFUL      EDS byte 7 = 71
{
{       43 - RCC1 AND RCC2 NOT SUCCESSFUL
{                                     EDS byte 7 = 72
{
{       44 - INVALID DDC TAG SEQUENCE
{                                     EDS byte 7 = 73
{
{       45 - EXTRA RCC REQUIRED       EDS byte 7 = 74
{
{       46 - INVALID DDC SELECTION    EDS byte 7 = 75
{
{       47 - MISSING END OP           EDS byte 7 = 76,77
{
{       48 - INVALID TAG              EDS byte 7 = 78,79
{
{       49 - DESELECTION              EDS byte 7 = 7A
{
{       50 - NO CONTROLLER RESPONSE   EDS byte 7 = 7B
{
{       51 - CONTROLLER NOT AVAILABLE
{                                     EDS byte 7 = 7C,7D
{
{       The following symptom statements are most likely caused by
{       the HSC.
{
{       52 - ECC HARDWARE FAILURE     EDS byte 7 = 81
{
{       53 - UNEXPECTED END OP        EDS byte 7 = 83
{
{       54 - END OP ACTIVE            EDS byte 7 = 84,85
{
{       Values from 55 to 79 can only be generated if EDS byte 7
{       contains a hex value of 0, 10, 28, 6X, or 80.
{
{       55 - COMMAND REJECT           EDS byte 0, bit 0
{
{       56 - INTERVENTION REQUIRED    EDS byte 0, bit 1
{
{       57 - BUS OUT PARITY           EDS byte 0, bit 2
{
{       58 - EQUIPMENT CHECK          EDS byte 0, bit 3
{
{       59 - DATA CHECK               EDS byte 0, bit 4
{
{       60 - OVERRUN                  EDS byte 0, bit 5
{
{       61 - PERMANENT DEVICE ERROR   EDS byte 1, bit 0
{
{       62 - END OF CYLINDER          EDS byte 1, bit 2
{
{       63 - MESSAGE TO OPERATOR      EDS byte 1, bit 3
{
{       64 - NO RECORD FOUND          EDS byte 1, bit 4
{
{       65 - FILE PROTECTED           EDS byte 1, bit 5
{
{       67 - FIRST LOGGED ERROR       EDS byte 2, bit 2
{
{       68 - ENVIRONMENTAL DATA       EDS byte 2, bit 3
{
{       69 - PATH ERROR               EDS byte 4, bit 2
{
{       70 - INVALID TRACK FORMAT     EDS byte 1, bit 1
{
{       79 - UNDOCUMENTED STORAGE DIRECTOR RESPONSE
{                                     Sense bytes are present but are not
{                                     described by codes 55 - 78.
{
{       Values from 80 to 119 are only returned for errors where general
{       status equals A00(16).  These errors are detected by the Cyber
{       Channel Coupler.  Note that the bits are numbered with bit zero
{       to the right.  Values from 80 through 97 are normally CCC or
{       storage director problems.  Values 98, 99, 101, and 103 through
{       119 are normally PP or CCC problems.  Values 100 and 102 usually
{       indicate a CCC problem.
{
{       80 - REQUEST IN NOT RECEIVED DURING COMMAND RETRY
{                                     EDS word 19, bits 11 and 4
{
{       81 - ILLEGAL WRITE            EDS word 19, bits 11 and 3
{
{       82 - CCC-STORAGE DIRECTOR INTERFACE ERROR
{                                     EDS word 19, bits 11 and bits 2/1
{
{       83 - FULL/EMPTY COUNT INCORRECT
{                                     EDS word 19, bits 11 and 0
{
{       92 - ADDRESS MISCOMPARE ON SELECT SEQUENCE
{                                     EDS word 19, bits 9 and 2
{
{       93 - NO REQUEST IN ON POLLING SEQUENCE
{                                     EDS word 19, bits 9 and 1
{
{       94 - SELECT IN RECEIVED ON SELECT SEQUENCE
{                                     EDS word 19, bits 9 and 0
{
{       95 - BUS IN PARITY ERROR      EDS word 19, bits 8 and 3
{
{       96 - READ PATH PARITY ERROR   EDS word 19, bits 8 and 2
{
{       97 - WRITE PATH PARITY ERROR  EDS word 19, bits 8 and 0
{
{       98 - INCOMPLETE DATA TRANSFER EDS word 18, bits 7 and 2
{
{       99 - CHANNEL PARITY DURING PP OUTPUT
{                                     EDS word 18, bit 6
{
{       100- COUPLER MEMORY PARITY ERROR DURING PP INPUT
{                                     EDS word 18, bit 5
{
{       101- DEADMAN TIMEOUT STATUS   EDS word 18, bit 4
{
{       102- COUPLER MEMORY PARITY ERROR
{                                     EDS word 18, bit 3 -or-
{                                     EDS word 19, bits 8 and 1
{
{       103- EXCESS DATA TRANSFERRED  EDS word 18, bit 2
{
{       104- DATA PACKING FOR CHANNEL DID NOT COME OUT EVEN
{                                     EDS word 18, bit 1
{
{       105- NORMAL END NOT SET       EDS word 18 bit 7 not set
{
{       The remaining symptom messages occur only when detailed status
{       is not present.  Values 121, 126 through 132, and 134 indicate
{       a PP or CCC problem.  Values 122 and 123 are informative.
{
{       121- FUNCTION TIMEOUT         A function issued by the PP to
{                                     the CCC was not responded to
{                                     within a timeout.  The function
{                                     is in counter word 18.
{
{       122- SOFT SECTORING UNIT
{
{       123- UNIT SOFT SECTORED
{
{       126- INTERFACE ERROR          The PP found a value in a CM
{                                     table created by the CP to be
{                                     incorrect.  The PP halts after
{                                     reporting this error.
{
{       127- KZ BOARD ERROR           The channel error flag in the IOU
{                                     is set and bit 61 of the CIO error
{                                     status register is set.
{
{       128- KX BOARD ERROR           The channel error flag in the IOU
{                                     is set and bit 63 of the CIO error
{                                     status register is set.
{
{       129- CHANNEL ERROR            The channel error flag in the IOU
{                                     is set. For the CIO channel it means
{                                     that bits 61 and 63 of the error
{                                     status register are not set.  Counter
{                                     word 40 contains the CIO error status
{                                     register.
{
{       131 - MEDIA FAILURE           The error has been isolated to media.
{                                     The error recovery algorithm successfully
{                                     wrote, read, and verified data on a
{                                     cylinder reserved for maintenance.
{                                     NOS/VE will automatically software flaw
{                                     the allocation unit containing the
{                                     failing address.
{
{       132- INCOMPLETE SECTOR TRANSFER  After a block input from the CCC
{                                     or a block output from the PP to the
{                                     CCC, the A  register was not zero.
{                                     Also,  unless  the  input  was  for
{                                     status, general status was zero.
{
{       133- CCC FAILURE              The autoload of CCC microcode failed.
{                                     The error code is in the right-most
{                                     two hex digits of general status.
{
{       134- PP-CCC DATA INTEGRITY    Data was transferred to the CCC buffer
{                                     and back to the PP memory.  No error
{                                     was reported, but the data did not compare.
{
{       135- PP-DRIVE DATA INTEGRITY  Data was transferred from PP memory to
{                                     the disk, and back to PP memory.  No
{                                     error was reported, but the data did not
{                                     compare.
{
{       136- SEEK COMMAND TIMEOUT     A  seek  command issued to the CCC did
{                                     not  complete  within a timeout of 10
{                                     seconds.
{
{       140- INDETERMINATE 895 ERROR  An error response was returned by  the
{                                     PP,  but no indication of an error was
{                                     found in the status.
{
{       141- UNCORRECTED CM ERROR     An  uncorrected  error  response was
{                                     received from CM on a request.  This
{                                     is  bit  50  of  the  error register
{                                     (counter word 40).
{
{       142- CM REJECT                A reject response was received from
{                                     CM.  This  is  bit  51 of the error
{                                     register (counter word 40).
{
{       143- INVALID CM RESPONSE      The  response  code from CM decoded
{                                     into an illegal value.  This is bit
{                                     52  of  the error register (counter
{                                     word 40).
{
{       144- CM RESPONSE CODE PARITY ERROR   The  response code from CM
{                                     had  a parity error.  This is bit
{                                     53 of the error register (counter
{                                     word 40).
{
{       145- CMI READ DATA PARITY ERROR  The CM interface logic detected
{                                     a parity error.  This is bit 54 of
{                                     the  error  register (counter word
{                                     40).
{
{       146- OVERFLOW ERROR           Data  was  received  after the DMA
{                                     channel's  input  buffer  was full.
{                                     This is bit 56 of the error register
{                                     (counter word 40).
{
{       147-JY BOARD ERROR            The  JY board has detected an error.
{                                     This is bit 62 of the error register
{                                     (counter word 40).
{
{       148- IOU FAILURE - OPERATIONAL STATUS WRONG  After using test mode
{                                     to transfer data between the PP and
{                                     CM, operational status was incorrect.
{
{       149- IOU FAILURE - TEST MODE DATA MISCOMPARE  After using test mode
{                                     to  transfer data between the PP and
{                                     CM,  no  hardware error was detected,
{                                     but the data miscompared.
{
{       150- TRANSFER IN PROGRESS DID NOT CLEAR   A data  transfer between
{                                     CM  and disk did not complete within
{                                     a  timeout.  General Status from the
{                                     CCC showed no error and no IOU error
{                                     register bits were set.  This is bit
{                                     47 of counter word 40.
{
{       151-T PRIME REGISTER NOT EMPTY  A data transfer between CM and disk
{                                     did  not  complete  within a timeout.
{                                     General Status from the CCC showed no
{                                     error  and no IOU error register bits
{                                     were  set.  This is bit 46 of counter
{                                     word 40.
{
{   9.  Request Retry Count - The number of times the PP driver retried the
{       entire i/0 request from the beginning.
{
{   10. Fault Symptom Code - This code, if present, is EDS bytes 22
{       and 23.  If the code is not present, the counter word will be
{       negative.  The code is right justified in this counter word.
{
{   11. Cylinder number of initial seek
{
{   12. Track number of initial seek
{
{   13. Sector number of initial seek
{
{   14. Cylinder number of failure - This is normally the cylinder
{       number in the disk request.  However, if the failure occurred
{       while loading CCC microcode or while running the confidence
{       test, the cylinder number will be 884.
{
{   15. Track number of failure - This is normally the track on disk
{       that was being read or written when the error was detected.
{       If the error occurred while loading CCC microcode or during
{       the interface test portion of the confidence test, the track
{       number will be set to zero.
{
{   16. Sector number of failure - This is normally the sector on disk
{       that was being read or written when the error was detected.
{       If the error occurred while loading CCC microcode or during
{       the interface test portion of the confidence test, the sector
{       number will be set to zero.
{
{   17. Residual byte count on incomplete channel transfer
{
{   18. Failing Function - On  a  function  timeout, the function
{       reported is the one which was outstanding when the CCC hung.
{
{   First-failure Data:
{   19. General Status of Last Failure
{                   (right justified)
{   20 .. 39. Words 1..20 of Detailed Status
{                   (right justified)
{   40. Error Register bits (CIO channel only)
{                   (right justified)
{
{   The following failure data is only provided in the cases where
{   the Log Entry Class is unrecovered or intermediate.  The data
{   represents the subsystem status at the end of the intermediate or
{   final request retry.
{
{
{   Last-failure Data:
{   41. General Status of Last Failure
{                   (right justified)
{   42 .. 61. Words 1..20 of Detailed Status
{                   (right justified)
{   62. Error Register bits (CIO channel only)
{                   (right justified)
{

  CONST
    cml$7165_2x_failure_data = cmc$min_ecc + 4104;

*copyc cmc$condition_limits


*DECK DECK=CML$7221_1_FAILURE_DATA EXPAND=FALSE
{
{ CML$7221_1_FAILURE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record the failure data
{ captured by the system when accessing a 7221_1 tape subsystem.
{
{ FREQUENCY: At each failure occurrence.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<channel>.<adapter>.<unit>*<vsn>*<severity>..
{       *<symptom>
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is the string 'PPn' where n is the logical PP
{       number in decimal of the PP used to process the failing
{       request.
{
{      where <channel> is the string 'CHn' where n is the channel
{       number in decimal through which the disk device was
{       accessed.
{
{      where <adapter> is the element name of the channel adapter
{        used in the failing request.
{
{      where  <unit> is the element name of the failing tape storage
{        device used in the failing request.
{
{      where <vsn> is the external-vsn of the tape volume which  was
{        the object of the failing request.
{
{      where <severity> is the string 'UF'  for  unrecovered,  'RF'  for
{        recovered,  'IF'  for  intermediate and 'IM' for informative
{        message.
{
{      where <symptom> is the symptom/action statement  provided  by
{        the system.
{
{    The  counter-value portion of this statistic contains:
{
{    1.  Logical PP number
{        Bit 57 = 1 implies that the PP is an I4 concurrent PP.
{        Bits 46 thru 51 contain the IOU number of the PP.
{    2.  Channel Number of Controller
{        Bit 57 = 1 implies that the channel is an I4 concurrent
{        channel.
{        Bits 46 thru 51 contain the IOU number of the channel.
{    3.  Equipment Number of Controller
{    4.  Physical Unit Number
{    5.  Unit-type
{       7 - 639_1
{    6.  Logical Operation Code
{       1 - read
{       2 - write
{       3 - rewind
{       4 - unload
{       6 - write_tapemark
{       7 - data_security_erase
{       8 - forespace
{       9 - backspace
{       10 - forespace_tapemark(s)
{       11 - backspace_tapemark(s)
{       12 - get_status
{       13 - TCU_loopback
{       14 - Unit_loopback_I
{       15 - Unit_loopback_II
{       16 - master clear
{    7.  Failure Severity
{       0 - Recovered Failure
{       1 - Unrecovered Failure
{       2 - Intermediate Failure Report
{       3 - Informative Message
{    8.  Failure Symptom Code (tells what the system thinks is wrong)
{       1 - INDETERMINATE (channel or adapter or unit)
{       2 - INPUT CHANNEL PARITY - On an input from controller to PP
{           the channel-error-flag was set.
{       3 - OUTPUT CHANNEL PARITY - On an output from the PP to the
{           controller,  the controller reported a parity error in
{           detailed status but the channel-error-flag was not set.
{       4 - CONTROLLER FAILURE - (reported by controller)
{       5 - UNIT FAILURE
{       6 - FUNCTION TIMEOUT - (controller not responding)
{       7 - TAPE MEDIUM FAILURE
{       8 - ERASE LIMIT EXCEEDED
{      10 - IOU OUTPUT PARITY - On an output from PP to controller
{           both the channel-error-flag and the controller's
{           detailed status indicated a parity error had occurred.
{      11 - INDETERMINATE OUTPUT PARITY - On an output from PP to
{           controller the channel-error-flag was set but there
{           was no parity error reported by the controller.
{      12 - UNABLE TO WRITE ID BURST - The id-burst could not be
{           written at load point.
{      13 - UNABLE TO SET AGC - The drive was not capable of
{           setting automatic gain control.
{      14 - ON THE FLY HARDWARE CORRECTIONS - The reported hardware status
{           indicated that Single or Double Track Corrections were
{           made while the tape file was active. This Failure Symptom
{           Code indicates a valid count in the counter word labelled
{           On The Fly single/double track corrections count.
{
{    9.  Blocks written on Unit
{    10.  Blocks read on Unit
{    11.  On The Fly single/double track corrections count
{    12.  UNUSED
{    13.  Absolute Block Count from Load Point
{    14.  Absolute number of Tape/File Marks from Load Point
{    15.  User requested format parameters
{    16.  Actual Density at which the unit was functioning
{    17.  Type of Recovery performed  on  a  successful  recovery.
{         This will apply when CDC Error Recovery Standard is
{         totally implemented.  The following recovery states are
{         presently listed in the standard, but they may change when
{         the standard is finally approved.
{
{               1 - Load-point Recovery
{               2 - Read Recovery
{               3 - Write Recovery
{               4 - File Mark Write Recovery
{    18.  Retry count of recovery attempts
{    19.  Last requested function (non-status)
{
{   First-failure Data:
{    20 .. 23.  Initial General and Detailed Status (16 PP words  -
{              4 per Counter Word).   See ISMT General/Detailed
{              Status layout.
{    24 .. 28.  Initial Extended Status (ISMT Sense Bytes 0 to 34
{              decimal,  packed with 8 bytes per counter word.
{              Only left-most 3 bytes of last word are relevant.
{              Reference  CDC  Pub. 49793200.
{
{   Last-failure Data:
{    29 .. 32.  Final General and Detailed Status (16 PP words -  4
{              per Counter Word).  See ISMT General/Detailed Status
{              layout.
{    33 .. 37.  Final  Extended Status (ISMT Sense bytes 0 to 34
{              decimal, packed  with  8  bytes  per  counter.
{              Same as 24..28 above.
{    38 .. 46.  Historical Block Identification Window (9 CM words)
{
{              Counter-value 38:
{                     BID index : 0..0ffff(16) (Bits 0 - 15)
{                     Limit: 0..0ffff(16) (Bits 16 - 31)
{                     Reserved : 0..0ffffffff(16) (Bits 32 - 63)
{
{              Counter-value 39 thru 46:
{                ARRAY  [1  ..   window_length] OF 0..0ffff(16)
{                (bid_window_length  is 32 decimal elements)
{    47 .. 55.  Current Block Identification Window (9 CM words)
{              Same structure as Historical window above
{              (Counter-values 38 .. 46)
{    56 .. 62.  Presently unused.
{

  CONST
    cml$7221_1_failure_data = cmc$min_ecc + 5101;

*copyc cmc$condition_limits
*DECK DECK=CML$7990_CHANNEL_ERROR EXPAND=FALSE

{
{ CML$7990_CHANNEL_ERROR
{
{
{ PURPOSE:
{    The purpose of this statistic is to record the channel failure data
{    captured by the application when accessing the 7990 channel.
{
{ FREQUENCY: At occurrence of failure.
{
{ CONTENT:
{    The  descriptive data portion of this statistic contains:
{
{   '<mf>.<iou>.<pp>.<channel>.<controller>.<smx>.<drd>.<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is either the string 'PPn' or 'CPPn' and where 'n'
{        is the decimal representation of the logical PP number used
{        to process the failing request.  Note that 'CPP' is the
{        designation given to the concurrent PPs in an I4 IOU.
{
{      where <channel> is either the string 'CHn' or 'CCHnp',
{        where 'n' is the decimal representation of the channel and
{        where 'p' is the channel port (A or B) through which the
{        disk device was accessed.  Note that 'CCH' is the
{        designation given to the concurrent channels in an I4 IOU.
{
{      where <controller> is the element name of the 7990 controller
{        used in the failing request.
{
{      where <smx> is the element name of the storage module
{        device used in the reporting request. x = 'A' through 'H' to
{        denote the eight possible storage modules.
{
{      where <drd> is the data recording device index ( 0 or 1).
{
{      where <symptom> is text describing the failure provided by the CCC
{        controller or the PP status.
{
{      The counter value portion of this statistic contains:
{
{    counter        description
{
{       1        Logical PP number.
{                Bits 63 thru 58 logical PP number.
{                Bit 57 is set to 1 for an I4 concurrent PP.
{                Bits 56 thru 52 reserved for CDC.
{                Bits 51 thru 46 contains IOU number.
{                Bits 45 thru 0 reserved for CDC.
{       2        Channel Number of Controller.
{                Bits 63 thru 58 channel number.
{                Bit 57 channel type
{                       0 = nonconcurrent channel  (CH)
{                       1 = concurrent channel (CCH)
{                Bit 56 port a.
{                Bit 55 port b.
{                Bits 54 thru 52 reserved for CDC.
{                Bits 51 thru 46 IOU number.
{                Bits 45 thru 32 reserved.
{                Bits 31 thru 16 Final C170/DMA channel Error Status Register.
{                Bits 15 thru 0 Initial C170/DMA channel Error status Register.
{       3        Equipment Number of the Controller.
{       4        Physical Unit Number.
{       5        Logical Operation Code
{                1 - read message
{                2 - read associated data
{                3 - write message
{                4 - write associated data
{                5 - function
{                6 - read data
{                7 - write data
{       6        Failure Severity
{                0 - Recovered Failure Report
{                1 - Unrecovered Failure Report
{                2 - Intermediate Failure Report
{                3 - Informative Message
{       7        2 - 12 bit general status words.  (right justified)
{       8 - 12   25 - 12 bit bytes of detail status of the 7990.
{
{      13   Failure Symptom Code for errors detected by the CCC controller.
{
{        CCC ERROR CODE MESSAGES (2 BYTES)
{
{        0001(8), 'CONNECT REJECTED - UNIT NOT AVAILABLE'
{        0002(8), 'CONNECT REJECTED - UNIT BUSY'
{        0003(8), 'FUNCTION REJECTED - UNIT NOT READY'
{        0006(8), 'WRITE RING MISSING'
{        0010(8), 'I/O TIME OUT ON FIPS TRANSFER'
{        0040(8), 'FIPS INTERFACE TIMEOUT ON A READ'
{        0041(8), 'FIPS INTERFACE TIMEOUT ON A WRITE'
{        0042(8), 'FIPS INTERFACE TIMEOUT ON A SENSE'
{        0043(8), 'FIPS INTERFACE TIMEOUT ON A FUNCTION'
{        0044(8), 'FIPS RESPONSE TIMEOUT WAITING FOR UNIT TO BECOME NOT BUSY'
{        0050(8), 'UNRECOGNIZABLE FUNCTION CODE'
{        0051(8), 'NO UNIT CONNECT'
{        0116(8), 'FULL/EMPTY COUNTER WAS INCORRECT'
{        0130(8), 'TIMEOUT WAITING REQUEST IN'
{        0131(8), '799X MESSAGE DEVICE UNIT CHECK'
{        0132(8), '799X MESSAGE DEVICE UNIT EXCEPTION'
{        0150(8), 'CCC CONTROLWARE DETECTED CHECKSUM ERROR ON 799X FUNCTION'
{        0151(8), '799X DETECTED A MESSAGE CHECKSUM ERROR ON TEST PATH'
{        0156(8), 'TIMEOUT ON REQUEST TO CYBER 170 DEVICE INTERFACE'
{        0157(8), 'TIMEOUT WAITING REQUEST IN AFTER WRITE FILE MARK'
{        0160(8), 'ABNORMAL STATUS FROM FIPS DEVICE INTERFACE ON TRANSFER REG'
{        0164(8), 'ABNORMAL STATUS FROM FIPS DEVICE INTERFACE ON SYSTEM RESET'
{        0165(8), 'ABNORMAL STATUS FROM FIPS DEVICE INTERFACE AFTER SENSE'
{        0170(8), 'FIPS SEQUENCE ERROR'
{        0171(8), 'FIPS INTERFACE ERROR'
{        0172(8), 'CYBER 170 DEVICE INTERFACE CHANNEL PARITY ERROR'
{        0173(8), 'CYBER 170 DEVICE INTERFACE INDICATES COUPLER PARITY ERROR'
{        0174(8), 'CYBER 170 DEVICE INTERFACE CONTROL PACKAGE PARITY ERROR'
{        0175(8), 'CYBER 170 DEVICE INTERFACE DEADMAN TIMER EXPIRED'
{        0177(8), 'CYBER 170 DEVICE INTERFACE UNDEFINED STATUS ERROR'
{
{      14   Failure Symptom Code for errors detected by the PP
{
{        If a hardware interface error occurs, the PP returns one of the
{        following hexadecimal error codes:
{
{        30 - Channel function timeout error
{        31 - Channel parity error
{        32 - Channel failed to empty after output
{        33 - Channel full before output
{        34 - Channel active before function
{        35 - Channel empty before input
{        36 - Status error following Autoload/Autodump
{        37 - Premature exit from an I/O instruction
{        38 - Adapter - DMA uncorrected CM error
{        39 - Adapter - CM reject
{        3A - Adapter - Invalid CM response
{        3B - Adapter - CM reponse code parity error
{        3C - Adapter - CMI read data parity error
{        3D - Adapter - Clock fault
{        3E - Adapter - Overflow error
{        3F - Adapter - Input error
{        40 - Adapter - 12/16 conversion error
{        41 - Adapter - JY data error
{        42 - Adapter - BAS parity error
{        43 - Adapter - KZ board error
{        44 - Adapter - JY board error
{        45 - Adapter - KX board error
{        46 - Adapter - DMA transfer halted early error
{
{        Note: Error codes 38(16) through 46(16) apply only to the C170 DMA
{              Adapter.
{
{            COUNTERS USED IF THE PPU REPORTS THE ERROR
{     15. Last function code sent to the 7990 controller (right justified)
{

  CONST
    cml$7990_channel_error = cmc$min_ecc + 9001;

*copyc cmc$condition_limits
*DECK DECK=CML$7990_CONTROLLER_LOG EXPAND=FALSE

{
{ CML$7990_CONTROLLER_LOG
{
{
{ PURPOSE:
{    The purpose of this statistic is to record the messages that are sent
{    to the application when accessing a 7990 subsystem.
{
{ FREQUENCY: At occurrence of failure within the 7990 subsystem.
{
{ CONTENT:
{    The  descriptive data portion of this statistic contains:
{
{   '<mf>.<iou>.<pp>.<channel>.<controller>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the 7990 report came.
{
{      where <pp> is either the string 'PPn' or 'CPPn' and where 'n'
{        is the decimal representation of the logical PP number used
{        to process the request.  Note that 'CPP' is the
{        designation given to the concurrent PPs in an I4 IOU.
{
{      where <channel> is either the string 'CHn' or 'CCHnp',
{        where 'n' is the decimal representation of the channel and
{        where 'p' is the channel port (A or B) through which the
{        disk device was accessed.  Note that 'CCH' is the
{        designation given to the concurrent channels in an I4 IOU.
{
{      where <controller> is the element name of the 7990 controller
{        from which the report came.
{
{      The counter value portion of this statistic contains:
{
{    counter        description
{
{       1        Logical PP number.
{                Bits 63 thru 58 logical PP number.
{                Bit 57 is set to 1 for an I4 concurrent PP.
{                Bits 56 thru 52 reserved for CDC.
{                Bits 51 thru 46 contains IOU number.
{                Bits 45 thru 0 reserved for CDC.
{       2        Channel Number of Controller.
{                Bits 63 thru 58 channel number.
{                Bit 57 channel type
{                       0 = nonconcurrent channel  (CH)
{                       1 = concurrent channel (CCH)
{                Bit 56 port A.
{                Bit 55 port B.
{                Bits 54 thru 52 reserved for CDC.
{                Bits 51 thru 46 IOU number.
{                Bits 45 thru 32 reserved.
{                Bits 31 thru 16 Final C170/DMA channel Error Status Register.
{                Bits 15 thru 0 Initial C170/DMA channel Error status Register.
{       3        Equipment Number of the Controller.
{       4 - 19   128 - 8 bit bytes of error log control unit errors.
{                Byte 0 contains the format of the message.
{                   ( The Masstor Microcode specification and error message
{                       specifications must be consulted to use these formats.)
{


  CONST
    cml$7990_controller_log = cmc$min_ecc + 9002;

*copyc cmc$condition_limits
*DECK DECK=CML$7990_USAGE_DATA EXPAND=FALSE

{
{ CML$7990_USAGE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record the information given by
{    the 7990 subsytem on usage between each mount/dismount of a vsn.
{
{ FREQUENCY: At occurrence of a dismount.
{
{ CONTENT:
{    The  descriptive data portion of this statistic contains:
{
{   '<mf>.<iou>.<pp>.<channel>.<controller>.<smx>.<drd>*<vsn>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is either the string 'PPn' or 'CPPn' and where 'n'
{        is the decimal representation of the logical PP number used
{        to process the failing request.  Note that 'CPP' is the
{        designation given to the concurrent PPs in an I4 IOU.
{
{      where <channel> is either the string 'CHn' or 'CCHnp',
{        where 'n' is the decimal representation of the channel and
{        where 'p' is the channel port (A or B) through which the
{        disk device was accessed.  Note that 'CCH' is the
{        designation given to the concurrent channels in an I4 IOU.
{
{      where <controller> is the element name of the 7990 controller
{        used in the reporting request.
{
{      where  <smx> is the element name of the storage module
{        device used in the reporting request. x = 'A' through 'H' to
{        denote the eight possible storage modules.
{
{      where <drd> is the data recording device index ( 0 or 1 ).
{
{      where <vsn> is the recorded vsn of the cartridge volume which  was
{        the object of the reporting request.
{
{
{      The counter value portion of this statistic contains:
{
{    counter        description
{
{       1        Logical PP number.
{                Bits 63 thru 58 logical PP number.
{                Bit 57 is set to 1 for an I4 concurrent PP.
{                Bits 56 thru 52 reserved for CDC.
{                Bits 51 thru 46 contains IOU number.
{                Bits 45 thru 0 reserved for CDC.
{       2        Channel Number of Controller.
{                Bits 63 thru 58 channel number.
{                Bit 57 channel type
{                       0 = nonconcurrent channel  (CH)
{                       1 = concurrent channel (CCH)
{                Bit 56 port A.
{                Bit 55 port B.
{                Bits 54 thru 52 reserved for CDC.
{                Bits 51 thru 46 IOU number.
{                Bits 45 thru 32 reserved.
{                Bits 31 thru 16 Final C170/DMA channel Error Status Register.
{                Bits 15 thru 0 Initial C170/DMA channel Error status Register.
{       3        Equipment Number of the Controller.
{       4        DRD equipment number
{       5        Vertical coordinate of cartridge.
{       6        Horizontal coordinate of cartridge.
{       7        Number of stripes read this mount.
{       8        Number of stripes written this mount.
{

  CONST
    cml$7990_usage_data = cmc$min_ecc + 9003;

*copyc cmc$condition_limits
*DECK DECK=CML$887_FAILURE_DATA EXPAND=FALSE
{
{ CML$887_FAILURE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record the failure data
{ captured by the system when accessing a 887 disk subsystem.
{
{ FREQUENCY: At each failure occurrence.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<ch>.<unit>*<vsn>*<class>*<message>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is the string 'CPPn' and n is the decimal
{        representation of the logical PP number used to process
{        the failing request.  Note that 'CPP' is the
{        designation given to the concurrent PPs in an I4 IOU.
{
{      where <channel> is the string 'CCHnp', where 'n' is the
{        decimal representation of the channel and 'p' is the
{        channel port (A or B) through which the disk device
{        was accessed.  Note that 'CCH' is the designation given
{        to the concurrent channels in an I4 IOU.
{
{      where  <unit> is the element name of the disk storage
{        device used in the failing request.
{
{      where <vsn> is the recorded-vsn of the disk volume which  was
{        the object of the failing request.
{
{      where  <class>  is  the string 'UF' for unrecovered, 'RF' for
{        recovered, 'IF' for intermediate failure log-entry, and
{        'IM' for informative message.
{
{        The PP reports failure data and diagnostic results  as  an
{        intermediate  failure  log-entry  prior  to retrying an i/o
{        request.  This is due to  PP-memory-size  limitations.   An
{        intermediate    failure    log-entry   will   provide   the
{        first-failure data captured by the PP  during  the  initial
{        attempt  at  the  request  or  during  a subsequent request
{        retry.  This  log-entry  provides  the  initial  and  final
{        failure data for an intermediate, unsuccessful i/o request
{        retry.  At least  one  additional  request  retry  will  be
{        performed after this log-entry is made.
{
{        For  unrecovered  disk failures the counter values contain
{        the failure data corresponding  to  the  last  unsuccessful
{        retry of the i/o request.  This log-entry provides
{        the   initial   and  final  failure  data  for  the  final,
{        unsuccessful i/o request retry.
{
{      where  <message> is a statement of failure isolation based on
{        either diagnostic execution or status reported by the HYDRA
{        subsystem:
{
{       <symptom statement>
{          The text of the possible symptom statements is
{          identical in content to the uppercase text discussed
{          under counter-value 8 below.
{
{    The  counter-value portion of this statistic contains:
{
{    1.  Logical PP number (bits 58 - 63).
{        Bit 57 is set to 1 implying that the PP is an I4
{        concurrent PP.
{        Bits 46 - 51 contain the IOU number.
{
{    2.  Channel Number (bits 58 - 63).
{        Bit 57 is set to 1 for an I4 concurrent channel.
{        Bit 56 is set to 1 if I4 concurrent channel port B.
{        Bit 55 is set to 1 if I4 concurrent channel port A.
{        Bits 46 - 51 contain the IOU number.
{
{    3.  Controller Address - (0 .. 7)
{    4.  Physical Unit Number - always zero
{    5.  Unit-type
{        6 - 887
{    6.  Logical Operation Code
{        1 - read
{        2 - write
{    7.  Log-entry Class
{        0 - Recovered Failure Report
{        1 - Unrecovered Failure Report
{        2 - Intermediate Failure Report
{        3 - Informative Message
{    8.  Failure Analysis
{        Indicates the extent to which the subsystem and the PP were
{        able to isolate  the  failure when it was detected.
{
{    0 - INDETERMINATE        The   failure  did  not  manifest
{                             itself as one  of  the  following
{                             symptoms.    Refer  to  the
{                             Controller Status for additional
{                             information.
{
{    1 - EXECUTING LEVEL I DIAGNOSTICS   Execution of LEVEL I
{                                  inline diagnostics was initiated.
{
{    2 - LEVEL I DIAGNOSTICS PASSED      Level I diagnostics ran
{                                  successfully.
{
{    3 - EXECUTING LEVEL II DIAGNOSTICS   Execution of LEVEL II
{                                  inline diagnostics was initiated.
{
{    4 - LEVEL II DIAGNOSTICS PASSED      Level II diagnostics ran
{                                  successfully.
{
{    5 - SPINDLE POWERED UP        The spindle was successfully
{                                  powered up.
{
{    6 - FUNCTION TIMEOUT          The I4 channel adapter failed to
{                                  respond to a function.
{
{    7 - CHANNEL DOESNT GO EMPTY   The I4 channel doesn't go
{                                  empty after the PP sends a
{                                  function or parameter word.
{
{    8 - INCOMPLETE I4 TRANSFER    The PP's A register was non-zero
{                                  after the channel was inactivated
{                                  during a data transfer.
{
{    9 - CHANNEL INITIALIZATION ERROR    The PP could not read and
{                                  verify the control or mask
{                                  registers.
{
{    10 - CANNOT SELECT THE CONTROLER     The 887 controller did not
{                                  set 'Select Active' in the
{                                  allotted time.
{
{    11 - INCORRECT CONTROLLER WAS   The wrong controller replied to
{         SELECTED                 a PP-initiated selection
{                                  sequence.
{
{    12 - PP TIMED OUT A COMMAND    The 887 controller did not
{                                  respond to a command block by
{                                  sending an attention within the
{                                  allotted time.
{
{    13 - CONTROLLER RESERVED      The 887 controller was reserved
{                                  to another host channel.
{
{    14 - SOFTWARE FAILURE         A software failure was detected by
{                                  the PP driver.
{
{    15 - DRIVE NOT READY - MIC1   The 887 controller reported  a
{                                  manual   intervention   code   of
{                                  C1(16).
{
{    16 -UNCORRECTED CM ERROR      An uncorrected error response was
{                                  received from Central Memory on a
{                                  read or write request.
{                                  Bit 50 of the I4 error status
{                                  register was set.
{
{    17 -CM REJECT                 A reject response was received
{                                  from Central Memory on a read
{                                  or write request.
{                                  Bit 51 of the I4 error status
{                                  register was set.
{
{    18 -INVALID CM RESPONSE CODE   The response code from Central
{                                  Memory decoded into an illegal
{                                  value.
{                                  Bit 52 of the I4 error status
{                                  register was set.
{
{    19 -CM RESPONSE CODE PARITY ERROR   The response code from
{                                  Central Memory had a parity
{                                  error.   Bit 53 of the I4 error
{                                  status register was set.
{
{    20 -CMI READ DATA PARITY ERROR   The I4 Central Memory Interface
{                                  (CMI) logic detected a read data
{                                  parity error.
{                                  Bit 54 of the I4 error status
{                                  register was set.
{
{    21 -INPUT BUFFER OVERFLOW     A sync-in was received after the
{                                  I4 DMA channel's input buffer had
{                                  filled.
{                                  Bit 56 of the I4 error status
{                                  register was set.
{
{    22 -JP/JY DATA PARITY ERROR   The JP/JY board detected an error.
{                                  Bit 59 of the I4 error status
{                                  Bit 59 of the I4 error status
{                                  register was set.
{
{    23 -BAS PARITY ERROR          The JN/JX board detected a parity
{                                  error on the data received from a
{                                  PP.
{                                  Bit 60 of the I4 error status
{                                  register was set.
{
{    24 -OUTPUT ISI PARITY ERROR   On  an output from the IOU to the
{                                  887 controller, the IOU reported
{                                  an ISI parity error (bit 61 of the
{                                  I4 error status register was set).
{
{    25 -JZ ERROR                  The JZ board detected an error.
{                                  Bit 61 of the I4 error status
{                                  register was set (and the 887
{                                  controller did not report an ISI
{                                  parity error).
{
{    26 - JP/JY ERROR              The JP/JY board detected an error.
{                                  Bit 62 of the I4 error status
{                                  register was set and bit 59 is
{                                  clear.  The error is either a
{                                  byte count parity, an RMA parity
{                                  error or a constant CM request
{                                  error.
{
{    27 - JN/JX ERROR              The JN/JX board detected an error.
{                                  Bit 63 of the I4 error status
{                                  register was set.
{
{    28 - INCOMPLETE DMA TRANSFER  The DMA transfer did not complete.
{                                  The PP timed out when either the
{                                  T' register was non-empty or the
{                                  Transfer-in-Progress status was
{                                  present and Select Active was set
{                                  and the the Channel Error Flag was
{                                  not set.
{
{    29 - T REGISTER BYTE COUNT NONZERO  The PP timed out when the
{                                  T register byte count was nonzero.
{
{    30 - INVALID CONTROLLER STATUS  The 887 controller has reported
{                                  one of the following:
{                                  1) 'Buffer Space Available' or
{                                  'Read Data Available' when not
{                                  appropriate.
{                                  2) Invalid Execution Status.
{                                  3) Status reported an invalid
{                                  device number or an invalid
{                                  command block number.
{
{    31 - CONTROLLER INTERFACE ERROR   1) Attention was received but
{                                  there was no outstanding command.
{                                  2) Attention was received to
{                                  transfer data when the PP was
{                                  waiting for final completion
{                                  status.
{                                  3) 'Command Complete' status was
{                                  received when there was more data
{                                  to transfer.
{
{    32 -SEEK ERROR - SI21         The 887 controller reported  a
{                                  system   intervention   code   of
{                                  21(16) indicating a seek fault or
{                                  a    sector    header     address
{                                  miscompare.
{
{    33 -UNABLE TO READ HEADER - SI41   The  887 controller reported
{                                  a system intervention   code   of
{                                  41(16)  indicating  it was unable
{                                  to read the header portion of the
{                                  sector.
{
{    34 -HEADER MISCOMPARE - SI42  The  887 controller reported  a
{                                  system   intervention   code   of
{                                  42(16)  indicating  the header
{                                  read from the disk does not match
{                                  the expected cylinder address.
{
{    35 - UNABLE TO READ DATA - SI43   The   887 controller reported
{                                  system   intervention   code   of
{                                  43(16)  indicating  either a Sync
{                                  Byte  detection  problem   or   a
{                                  header ECC mismatch.
{
{    36 - DISK NOT FORMATTED - SI82   During a Power Up Spindle
{                                  command, the 887 controller
{                                  detected that the media is not in
{                                  the format indicated by the format
{                                  select switch (System Intervention
{                                  code was 82(16).
{
{    37 - DIAGNOSTIC FAULT DETECTED    Level I or II diagnostic tests
{                                  detected a fault.
{
{    38 - COMMAND BLOCK NEGATED - SIC1   The 887 controller negated a
{                                  Command Block that it had already
{                                  recognized
{
{    39 - COMMAND BLOCK OVERWRITE - MI21   The PP has altered a
{                                  command block.
{
{    40 - ILLEGAL COMMAND BYTE - MI22   The 887 controller received a
{                                  Command Block with a Command Code
{                                  that is not defined.
{
{    41 - ILLEGAL SECONDARY SEEK ADDRESS - MI23   The 887 controller
{                                  received a Command Block with an
{                                  illegal secondary seek address.
{
{    42 - ILLEGAL PRIMARY SEEK ADDRESS - MI24   The 887 controller
{                                  received a Command Block with an
{                                  illegal primary seek address.
{
{    43 - ILLEGAL COMMAND PARAMETER - MI25   The 887 controller
{                                  received a Command Block with an
{                                  undefined command parameter.
{
{    44 - I/O ILLEGAL WRITE ERROR - MI27   The PP attempted to write
{                                  into one of the status areas in
{                                  the controller's buffer.
{
{    45 - END OF DISK REACHED - MI28   The seek address has been
{                                  incremented to its maximum value.
{
{    46 - ILLEGAL DEVICE NUMBER - MI29   The controller received a
{                                  Command Block with a nonzero
{                                  Device Number.
{
{    47 - ILLEGAL CONTROL FIELD - MI2A   The controller received a
{                                  Command Block with an invalid
{                                  Control Field.
{
{    48 - I/O ILLEGAL DISCONNECT - MI41   The controller detected
{                                  an illegal disconnect at the ISI
{                                  interface.
{
{    49 - ISI I/O PARITY ERROR - MI63   The controller received a
{                                  word across the ISI interface with
{                                  an invalid parity bit.
{
{    50 - R/W SEQUENCER RAM        The  887 controller reported  a
{         PARITY ERROR - MI64      manual   intervention   code   of
{                                  64(16) indicating a read/write
{                                  sequencer memory parity error.
{
{    51 - MPU PARITY ERROR - MI65  The 887 controller reported  a
{                                  manual   intervention   code   of
{                                  65(16)  indicating  an MPU memory
{                                  parity error.
{
{    52 - ECC FAULT - MI66         The  887 controller reported  a
{                                  manual   intervention   code   of
{                                  66(16) indicating a malfunction in
{                                  its error correction circuitry.
{
{    53 - VOLTAGE FAULT - MI67     The  887 controller reported  a
{                                  manual   intervention   code   of
{                                  67(16) indicating its DC voltage
{                                  supply is out of tolerance.
{
{    54 - WRITE TRANSFER COUNT ERROR - MI68   The PP sent more data
{                                  than the controller expected.
{
{    55 - OVER TEMPERATURE FAULT - MI6B   The 887 controller reported
{                                  a manual intervention   code   of
{                                  6B(16) indicating temperatures in
{                                  storage device are above the
{                                  desired range.
{
{    56 - NO READ/WRITE SEQUENCER RESPONSE - MI6C   The Read/Write
{                                  Sequencer failed to respond to a
{                                  request for headers and/or data
{                                  to be written or read within the
{                                  time limits.
{
{    57 - INVALID READ/WRITE SEQUENCER RESPONSE - MI6D   The 887 MPU
{                                  in unable to interpret the
{                                  response given by the Read/Write
{                                  Sequencer to a read or write
{                                  command.
{
{    58 - READ/WRITE SEQUENCER STATUS OVERWRITE - MI6E   The Read/
{                                  Write Sequencer indicated that
{                                  valid status which it was
{                                  attempting to present to the
{                                  887 MPU had been overwritten
{                                  before it was read by the MPU.
{
{    59 - HYDRA HARDWARE FAULT - MI6F   The 887 controller
{                                  reported a failure other than
{                                  those which are assigned a manual
{                                  intervention code. The failure
{                                  data is recorded in the ERROR
{                                  REGISTER IMAGE. Refer to the
{                                  contents of counter-values
{                                  36 .. 47.
{
{    60 - READ/WRITE SEQUENCER FAULT - MI70   The 887 controller
{                                  reported a failure detected by
{                                  its read/write sequencer.  A
{                                  manual intervention status of
{                                  70(16) was returned.
{
{    61 - ZEROFILL TIMEOUT - MI71   The 887 controller reported a
{                                  zerofill timeout.
{
{    62 - FUNCTION BUFFER PARITY ERROR - MI72
{                                  The 887 controller reported a
{                                  function buffer parity error.
{
{    63 - PARTIAL SECTOR ERROR - MI73    The 887 controller
{                                  ended a read/write data
{                                  transfer with a partial sector.
{
{    64 - DISK FAULT - MI81        The 887 controller reported a
{                                  manual intervention code of 81(16)
{                                  indicating the storage device
{                                  detected a fault condition. The
{                                  failure data is recorded in the
{                                  DEVICE STATUS BLOCK.  Refer to
{                                  the contents of counter-values
{                                  32 and 35.
{
{    65 - NO SECTOR PULSE - MI90   The Read/Write Sequencer is
{                                  unable to detect a sector pulse
{                                  from the disk.
{
{    66 - NO INDEX PULSE - MI91    The Read/Write Sequencer is
{                                  unable to detect the index
{                                  pulse from the disk.
{
{    67 - CYLINDER/HEAD/SECTOR WRAP ERROR - MI92   The 887 controller
{                                  detected a mismatch between a
{                                  cylinder, head or sector
{                                  address which was sent to the
{                                  disk and the value which the
{                                  disk returned for verification.
{
{    68 - NO DISK RESPONSE - MIC3   The disk does not respond to
{                                  commands from the control
{                                  portion of the 887.
{
{    69 - PAUSE TIME OUT           The controller Pause status
{                                  did not clear in the alloted
{                                  time.
{
{    70 - TRANSFER IN PROGRESS DID NOT CLEAR
{                                  The transfer-in-progress
{                                  bit in the operational
{                                  status did not clear in the
{                                  alloted time.
{
{    71 - INCOMPLETE COMMAND BLOCK TRANSFER   The channel
{                                  disconnected when the PP
{                                  was writing a command block
{                                  to the controller.
{
{    72 - INCOMPLETE STATUS TRANSFER   The channel disconnected when
{                                  the PP was reading the controller
{                                  status.
{
{    73 - SELECT ACTIVE DROPPED WHEN READING CONTROLLER STATUS
{                                  The controller dropped Select
{                                  Active when the PP was reading the
{                                  controller status.
{
{    74 - INCOMPLETE DEVICE STATUS TRANSFER   The channel
{                                  disconnected when the PP was
{                                  reading the device status.
{
{    75 - SELECT ACTIVE DROPPED WHEN READING DEVICE STATUS
{                                  The controller dropped Select
{                                  Active when the PP was reading
{                                  device status.
{
{    76 - INCOMPLETE ERROR REGISTER IMAGE TRANSFER
{                                  The channel disconnected when
{                                  the PP was reading the error
{                                  register image.
{
{    77 - SELECT ACTIVE DROPPED WHEN READING ERROR REGISTER IMAGE
{                                  The controller dropped Select
{                                  Active when the PP was reading
{                                  the error register image.
{
{    78 - INCOMPLETE ERROR LOG TRANSFER   The channel disconnected
{                                  when the PP was reading the
{                                  error log.
{
{    79 - SELECT ACTIVE DROPPED WHEN READING ERROR LOG
{                                  The controller dropped Select
{                                  Active when the PP was reading
{                                  the error log.
{
{    80 - SELECT ACTIVE DROPPED WHEN TRANSFERRING DATA
{                                  The controller dropped select
{                                  active when the PP was
{                                  transferring data.
{
{    81 - HOST I/F INTEGRITY ERROR   The NOS/VE PP writes data into
{                                  the controller's buffer, rereads
{                                  it and verifies it during the
{                                  PP's initialization sequence.
{                                  The PP detected an error when
{                                  verifying the data.
{
{    82 - DRIVE I/F INTEGRITY ERROR  After the PP verifies the host
{                                  to controller buffer data path
{                                  (see preceding symptom), the PP
{                                  writes data to a reserved
{                                  cylinder, rereads it and
{                                  verifies it during the PP's
{                                  initialization sequence.  The PP
{                                  detected an error when verifying
{                                  the data.
{
{    83 - ISI INPUT ERROR          A parity error was detected by
{                                  the I4 DMA logic on data read
{                                  from the 887 controller.
{                                  Bit 57 of the I4 error status
{                                  register was set.
{
{    84 - ISI TIMEOUT              A channel time out occurred.
{                                  The I4 channel adapter sent a
{                                  sync out and did not receive
{                                  a sync in within one second.
{                                  Bit 58 of the I4 error status
{                                  register was set.
{
{    85 - MEDIA FAILURE            This  indicates that a 'bad-spot'
{                                  has  developed   on   the   media
{                                  surface or there is a less likely
{                                  possibility  that  there  was  an
{                                  intermittent   failure  when  the
{                                  sector  was  originally   written
{                                  which  was not detected until the
{                                  subsequent read.
{
{    86 - SEEK ERROR - DS22        The 887 controller has attempted
{                                  to recover from a seek error or
{                                  header miscompare error.
{
{    87 - POWER-UP INITIALIZATION COMPLETE - DS81
{                                  The 887 controller completed a
{                                  successful initialization
{                                  operation after application
{                                  of dc power to a unit.
{
{    88 - HOST GENERATED RESET COMPLETE - DS83    The controller
{                                  has successfully completed a
{                                  Broadcast Master Reset or
{                                  Selective Reset operation.
{
{    89 - PRIORITY OVERRIDE COMPLETE - DS84    The controller has
{                                  successfully completed a
{                                  Priority Override operation.
{
{    90 - HYDRA ON LINE - DS85     The PORT Enable Switch for the
{                                  PORT sending Attention has been
{                                  moved from the offline position
{                                  to on line.
{
{    91 - SECTOR SIZE IS NOT 4096  The sector size is not 4096
{                                  bytes.
{
{    92 - HOST IDS ARE DIFFERENT   When running dual access
{                                  the host ids must be the same.
{                                  Single access will work either
{                                  way.
{
{    9.  Request Retry Count      The number of times the PP driver
{                                 retried the  entire  i/o  request
{                                 from the beginning.
{
{    10. Diagnostic Code          Provides  the result of a failing
{                                 diagnostic.
{
{    11. Cylinder number of initial seek
{
{    12. Track number of initial seek
{
{    13. Sector number of initial seek
{
{    14. Cylinder number of failure
{
{    15. Track number of failure
{
{    16. Sector number of failure
{
{    17. Residual byte count on incomplete channel transfer
{
{
{    18. Failing Function         On a function  timeout, the
{                                 function reported is the one
{                                 which was  outstanding  when  the
{                                 I4 channel adapter hung.
{
{    19. PP Status
{        bit    48          The sector size is not 4096.
{        bit    49          The controller does not have the
{                           same host id on both of its ports.
{        bit    51          Set whenever the PP is running the
{                           confidence test.
{        bit    52          Channel master clear did not work.
{        bit    53          After the PP verifies the host to
{                           controller buffer data path, the PP
{                           writes data to a reserved cylinder,
{                           rereads it and verifies it during the
{                           PP's initialization sequence.  The PP
{                           detected an error when verifying the
{                           data.
{        bit    54          The NOS/VE PP writes data into the
{                           controller's buffer, rereads it and
{                           verifies it during the PP's
{                           initialization sequence.  The PP
{                           detected an error when verifying
{                           the data.
{        bit    55          The PP could not read and verify
{                           the control or mask registers.
{        bit    56          The PP timed out waiting for Pause
{                           to clear.
{        bit    57          The PP timed out waiting for Transfer
{                           In Progress to clear.
{        bit    58          The 887 controller did not set
{                           'Select Active' in the alloted time.
{        bit    59          The wrong controller replied to a
{                           PP-initiated selection sequence.
{        bit    60          The error log is present.
{        bit    61          The error register image is present.
{        bit    62          The device status is present.
{        bit    63          The Hydra status is present.
{
{    20. PP Status
{        bit    48          The channel has been downed.
{        bit    49          The controller has been downed.
{        bit    50          not used
{        bit    51          Level I diagnostics ran successfully.
{        bit    52          Execution of LEVEL I inline diagnostics
{                           was initiated.
{        bit    53          Selective Reset was successful.
{        bit    54          Selective Reset was attempted.
{        bit    55          not used
{        bit    56          not used
{        bit    57          The 887 controller did not response to a
{                           command block by sending an attention
{                           within the allotted time.
{        bit    58          The spindle was successfully powered up.
{        bit    59          The PP issued a Power Up Spindle command.
{        bit    60          Level II diagnostics ran successfully.
{        bit    61          Execution of LEVEL II inline diagnostics
{                           was initiated.
{        bit    62          not used
{        bit    63          not used
{
{    21. PP Status
{        bit    48          The PP timed out trying to clear Select
{                           Active by clearing Select Hold.
{        bit    49          The PP timed out when the T register
{                           byte count was nonzero.
{        bit    50          The DMA transfer did not complete.
{                           The PP timed out when either the T'
{                           register was non-empty or the Transfer-
{                           in-Progress status was present and
{                           Select Active was set and the Channel
{                           Error Flag was not set.
{        bit    51          The I4 detected an error during the data
{                           transfer.
{        bit    52          The 887 controller has reported
{                           one of the following:
{                           1) 'Buffer Space Available' or
{                              'Read Data Available' when not
{                              appropriate.
{                           2) Invalid Execution Status.
{                           3) Status reported an invalid
{                              device number or an invalid
{                              command block number.
{        bit    53          The controller dropped select active when
{                           the PP was transferring data.
{        bit    54          The controller dropped Select Active when
{                           the PP was reading the error log.
{        bit    55          The channel disconnected when the PP was
{                           reading the error log.
{        bit    56          The controller dropped Select Active when
{                           the PP was reading the error register
{                           image.
{        bit    57          The channel disconnected when the PP was
{                           was reading the error register image.
{        bit    58          The controller dropped Select Active when
{                           the PP was reading device status.
{        bit    59          The channel disconnected when the PP was
{                           reading the device status.
{        bit    60          The controller dropped Select Active
{                           when the PP was reading the controller
{                           status.
{        bit    61          The channel disconnect when the PP was
{                           reading the controller status.
{        bit    62          not used
{        bit    63          The channel disconnected when the PP
{                           was writing a command block to the
{                           controller.
{
{    22. PP Status
{        bit    48          1) Attention was received but
{                              there was no outstanding command.
{                           2) Attention was received to
{                              transfer data when the PP was
{                              waiting for final completion status.
{                           3) 'Command Complete' status was
{                               received when there was more data
{                               to transfer.
{        bit    49          The 887 controller was reserved
{                           to another host channel.
{        bit    50          not used
{        bit    51          not used
{        bit    52          not used
{        bit    53          not used
{        bit    54          not used
{        bit    55          This  indicates that a 'bad-spot'
{                           has  developed   on   the   media
{                           surface or there is a less likely
{                           possibility  that  there  was  an
{                           intermittent   failure  when  the
{                           sector  was  originally   written
{                           which  was not detected until the
{                           subsequent read.
{        bit    56          not used
{        bit    57          not used
{        bit    58          The I4 channel doesn't go empty after
{                           the PP sends a function or parameter
{                           word.
{        bit    59          not used
{        bit    60          not used
{        bit    61          not used
{        bit    62          not used
{        bit    63          The PP's A register was non-zero after
{                           the channel was inactivated during a
{                           data transfer.
{
{    23. I4 Error Status Register
{                    (bits 48 .. 63)
{    24. I4 Operational Status Register
{                    (bits 48 .. 63)
{    25. I4 T Register Content
{                    (bits 16 .. 63)
{    26. I4 Control Register
{                    (bits 48 .. 63)
{    27. I4 Flag Mask Register
{                    (bits 48 .. 63)
{    28. ISI Idle Status  (bits 48 .. 63)
{        Bits 48 .. 55 of this word correspond to the reserve
{        status of the ISI bus addresses 7 .. 0, respectively.
{        Bits 56 .. 63 of this word correspond to the attention
{        status of the ISI bus addresses 7 .. 0, respectively.
{    29. Bus Unit Select Word   (bits 48 .. 63)
{        Bits 56 .. 63 (the least significant bits) of this word
{        correspond to ISI bus addresses 7 .. 0, respectively.
{        The PP selected a controller and either no controller
{        responded or the wrong controller responded.  This word
{        contains the Bit Significant Response (BSR) the PP
{        received.
{
{   First-failure Data:
{    30. Words 0..3 of 887 HYDRA Status Block (left to right)
{    31. Words 4..5 of 887 HYDRA Status Block (left justified)
{    32. Words 0..3 of 887 Device Status Block (left to right)
{

{   Last-failure Data:
{    33. Words 0..3 of 887 HYDRA Status Block (left to right)
{    34. Words 4..5 of 887 HYDRA Status Block (left justified)
{    35. Words 0..3 of 887 Device Status Block (left to right)

{
{    36 .. 47. Words 0..47 of 887 Error Register Image (left to right)
{    48 .. 59. Words 0..47 of 887 Error Log (left to right)
{
  CONST
    cml$887_failure_data = cmc$min_ecc + 4105;

*copyc cmc$condition_limits



*DECK DECK=CML$9836_1_FAILURE_DATA EXPAND=FALSE
{
{       CM4106 - 9836, 9853, 5832_1, 5832_2, 5833_1, 5833_1P, 5833_2,
{                5833_3P, 5833_4 5838_1, 5838_1P, 5838_2,
{                5838_3P, 5838_4 , 47444_1, 47444_1p, 47444_2,
{                47444_3p, 47444_4 subsystem failure data.
{
{ PURPOSE:
{    The purpose of this statistic is to record the failure data
{ captured by the system when accessing the subsystem.
{
{ FREQUENCY: At each failure occurrence.
{
{ CONTENT:
{    The descriptive data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<ch>.<cm>.<unit>*<vsn>*<class>*<message>'
{
{      Where  <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm'  is  the  model  number  of
{        Central  Processor zero (CP0), e.g.  0990, and 'ssss' is the
{        serial number of that processor, e.g.  0104.
{
{      Where <iou> is the string 'IOUn' where n  is  0  or  1.   This
{        identifies  the  IOU  associated with the channel over which
{        the failure was reported.
{
{      Where <pp> is the string 'CPPn' for an I4 or the string  'PPn'
{        for an I0.  The character n is the PP number (in decimal) of
{        the PP which performed the  i/o  operation  which  is  being
{        reported.   Note  that  CPP  is the designation given to the
{        concurrent channels in an I4 IOU.
{
{      Where <ch> is the string 'CCHnp' for an I4 or 'CHn' for an I0.
{        The character n is the decimal representation of the channel
{        and p is the I4 channel port (A or B) through which the disk
{        device was accessed.  Note that CCH is the designation given
{        to the concurrent channels in the I4 IOU.
{
{      Where <cm> is the element name  of  the  disk  control  module
{        (controller) used in the failing request.
{
{      Where <unit> is the element name of the failing  disk  storage
{        device used in the failing request.
{
{      Where  <vsn>  is the recorded-vsn of the disk volume which was
{        the object of the failing request.
{
{      Where <class> is the string 'UF'  for  unrecovered,  'RF'  for
{        recovered,  'IF'  for  intermediate and 'IM' for informative
{        message.
{
{           The PP reports failure data as  an  intermediate  failure
{        log entry prior to retrying an i/o request.  An intermediate
{        failure log  entry  will  provide  the  first  failure  data
{        captured by the PP during the initial attempt at the request
{        or during a subsequent request retry.  If a retry of an  i/o
{        request  is  successful, no additional log entries are made.
{        Results of diagnostics executed  as  part  of  the  recovery
{        algorithm  will  also be reported as an intermediate failure
{        log entry.
{
{           A  recovered  failure  log  entry will be reported if the
{        controller reports  conditional  success  to  the  PP.  This
{        means that the controller recovery algorithm enabled  by the
{        PP recovered the error without PP intervention.  The counter
{        values  for  a  recovered failure contain  the first failure
{        data captured by the PP.
{
{           For unrecovered disk failures the counter values  contain
{        the failure data when all recovery attempts have failed.
{
{      Where  <message>  is a statement of failure isolation based on
{        either  diagnostic  execution  or  status  reported  by  the
{        subsystem.  The text of  the possible symptom statements are
{        identical  in content to the upper case text described under
{        counter value 8 below.
{
{    The counter-value portion of this statistic contains:
{
{   1.  Physical PP number
{       Bits 58 - 63 contain the physical PP number.
{       Bit 57 is set to 1 for an I4 concurrent PP.
{       Bits 46 - 51 contain the IOU number.
{
{   2.  Channel number
{       Bits 58-63 contain the channel number.
{       Bit 57 is set to 1 for an I4 concurrent channel.
{       Bit 56 is set to 1 if I4 concurrent channel port B.
{       Bit 55 is set to 1 if I4 concurrent channel port A.
{       Bits 46 - 51 contain the IOU number.
{
{   3.  Controller number
{
{   4.  Physical drive number
{
{   5.  Unit type
{       7 - 9836_1 (S0 only)
{       8 - 9853_X
{       9 - 5832_1
{      10 - 5832_2
{      11 - 5833_1
{      12 - 5833_1P
{      13 - 5833_2
{      14 - 5833_3P
{      15 - 5833_4
{      16 - 5838_1
{      17 - 5838_1P
{      18 - 5838_2
{      19 - 5838_3P
{      20 - 5838_4
{      21 - 47444_1
{      22 - 47444_1P
{      23 - 47444_2
{      24 - 47444_3P
{      25 - 47444_4
{
{   6.  Logical operation code
{       1 - read
{       2 - write
{       5 - format
{
{   7.  Log entry class
{       0 - Recovered Failure Report
{       1 - Unrecovered Failure Report
{       2 - Intermediate Failure Report
{       3 - Informative Message
{     Bits 33-47 contain an isolation  code  generated  by  the  PP
{             driver when bits 48-63 equal 1.
{       0 - Media Failure
{             This  is  present  when counter word 8 has a value of
{             62.  The confidence test had to pass to get  a  media
{             failure.
{       1 - Channel failure
{             A  failure  is isolated to the channel if it occurred
{             during  the  test  mode  (I4   only)  portion  of the
{             confidence  test  or  counter word 8 has a value less
{             than 20.
{       2 - Controller failure
{             A  failure  is  isolated  to  the  controller  if  it
{             occurred   during  the PP/Controller  path  test  or
{             counter word 8 has a value of 20-49.
{       3 - Drive failure
{             This code is set if the  failure  is  isolated  to  a
{             drive  and  there  is no parity drive for the logical
{             unit or the second  drive  of  a  logical  unit  with
{             parity  failed.   A  failure that was not isolated to
{             media, the channel, or the controller  is  attributed
{             to  the  drive.   Counter  word  8 has a value of 61,
{             70-99, or 120-130 for a drive failure.
{       4 - Drive failure causing parity protection to be disabled
{             This code is set if the  failure  is  isolated  to a
{             single  drive  of  a  parity  protected logical unit.
{             Counter word 8 has a value of 61, 70-99,  or  120-130
{             for  a  drive  failure.   This   error   should   be
{             recoverable  when  the  failing  drive of the logical
{             unit with a parity drive is disabled.
{
{   8.  Failure Analysis
{       This indicates the extent to which the subsystem, the PP, and
{       the CP were able to isolate the failure when it was detected.
{       The symptom  messages  have  been  grouped  to  help  provide
{       failure  isolation.   For  an  unrecovered  failure, detailed
{       isolation, equivalent  to  that  displayed  to  the  critical
{       window,  is provided in counter word 7.  Symptom codes 53-59,
{       106, and 130-142 are only  returned  for  a  5830  subsystem.
{       Symptom codes 77, 95 and 121  are  only  returned  by the CM3
{       subsystem.  Symptom  code  19  is only returned for a 25 MB/s
{       channel. All other symptom codes could be returned for either
{       subsystem or either channel.
{
{       0 - INDETERMINATE           The   failure  did  not  manifest
{                                   itself as one  of  the  following
{                                   symptoms.   Refer to the Response
{                                   Packet       for       additional
{                                   information.
{
{         The  following  symptom statements are isolated to the IOU.
{       They can not be caused by either the controller or the  cable
{       between  the  PP  and  controller.   Counter  words  1-9  and
{       referenced words are  applicable  to  the  following  symptom
{       statements.
{
{       1 - FUNCTION TIMEOUT        The IPI channel did  not  respond
{                                   to  a  function.  Counter word 18
{                                   contains the function.
{
{       2 - CHANNEL EMPTY WHEN ACTIVATED  The  IPI  channel  did  not
{                                   force  the  channel  full when it
{                                   was activated.
{
{       3 - PERIOD COUNTER ERROR    This is bit 12 of the IPI channel
{                                   error register.
{
{       4 - PP - IPI PARITY ERROR   This is bit 5 or  6  of  the  IPI
{                                   channel    error   register   and
{                                   indicates that a parity error has
{                                   occurred on a byte of information
{                                   transferred between the IPI  chip
{                                   in the IOU and the PP.
{
{       6 - IOU ERROR               The channel error flag is set and
{                                   none  of  the  bits  in  the  IPI
{                                   channel  error register or I4 IPI
{                                   DMA error register are set.
{
{       7 - INCOMPLETE I4 TRANSFER  The PP's A register  was  nonzero
{                                   after   an  output  of  parameter
{                                   words.
{
{       8 - CHANNEL NOT EMPTY       The I4 channel did not  go  empty
{                                   after  the  output  of  parameter
{                                   words.
{
{       9 - CENTRAL MEMORY ERROR    This indicates that bit 12 or  13
{                                   of  the I4 IPI DMA error register
{                                   is set and that an uncorrected or
{                                   reject    error    response   was
{                                   received from central memory.
{
{       10 - INVALID CM RESPONSE CODE  This  is  bit 11 of the I4 IPI
{                                   DMA error register and  indicates
{                                   the  response  code  from central
{                                   memory decoded  into  an  illegal
{                                   value.
{
{       11 - CM RESPONSE CODE ERROR  This is bit 10 of the I4 IPI DMA
{                                   error   register   and  indicates
{                                   that  the  response   code   from
{                                   central memory had a parity error.
{
{       12 - CMI READ DATA PARITY ERROR  This is bit 9  of the I4 IPI
{                                   DMA error register and  indicates
{                                   that the central memory interface
{                                   logic has detected  a  read  data
{                                   parity error.
{
{       13 - Y BOARD DATA ERROR     This  is bit 4  of the I4 IPI DMA
{                                   error register and indicates that
{                                   the  Y  board has detected a data
{                                   parity error.
{
{       14 - BAS PARITY ERROR       This is bit 3  of the I4 IPI  DMA
{                                   error register and indicates that
{                                   the   X  board  has  detected   a
{                                   parity  error  on  data  received
{                                   from the barrel and slot  of  the
{                                   PP.
{
{       15 - Z BOARD ERROR          This  is bit 2  of the I4 IPI DMA
{                                   error register and indicates that
{                                   the   Z  board  has  detected  an
{                                   error.  The Z board has  the  IPI
{                                   channel chip.
{
{       16 - Y BOARD  ERROR         This is bit 1  of the I4 IPI  DMA
{                                   error register and indicates that
{                                   the   Y  board  has  detected  an
{                                   error.
{
{       17 - X BOARD ERROR          This  is bit 0  of the I4 IPI DMA
{                                   error register and indicates that
{                                   the   X  board  has  detected  an
{                                   error.
{
{       18 - DMA TEST MODE FAILURE  Test mode was used to  pass  data
{                                   through  the  adapter.   No  bits
{                                   were set in the I4 IPI channel or
{                                   I4  IPI  DMA error registers, but
{                                   the data was incorrect.
{
{
{       19 - DMA COUNT OVERFLOW     This  is  bit  15  of the IPI DMA
{                                   error register and indicates that
{                                   the IPI chip received more than 4
{                                   data requests from the Y board.
{
{         The  following  symptom  statements  are  most   likely   a
{       controller problem but may be caused by the IOU, IPI channel,
{       or  cable.   Counter  words  1-9  and  referenced  words  are
{       applicable for the following symptom statements.
{
{       20 - CAN NOT SELECT CONTROLLER  The  SLAVE  IN  line  was not
{                                   set  after the PP sent the select
{                                   code to the controller.
{
{       21 - BIT SIGNIFICANT RESPONSE   ERROR   The  bit  significant
{                                   response which  is  in  bits  0-7
{                                   of   the   IPI   channel   status
{                                   register is incorrect.
{
{       22 - NO SYNC IN             During  a  bus  control  sequence
{                                   SYNC IN did not set.
{
{       23 - SYNC IN DID NOT DROP   During  a  bus  control  sequence
{                                   SYNC IN did not drop.
{
{       24 - IPI SEQUENCE ERROR     This is bit 4  of the IPI channel
{                                   error  register  and indicates an
{                                   illegal   sequence   of   control
{                                   signals  has  occurred on the IPI
{                                   interface.
{
{       25 - IPI CHANNEL PARITY ERROR This is bit  2 or 3 of the  IPI
{                                   channel    error   register   and
{                                   indicates that  the  IPI  channel
{                                   has  detected  a  parity error on
{                                   bus A of the IPI interface.
{
{       27 - SLAVE IN NOT SET       During an ending status  sequence
{                                   or  a  request  transfer settings
{                                   sequence SLAVE IN did not set.
{
{       28 - SLAVE IN DID NOT DROP  During a deselect sequence  or  a
{                                   request     transfer     settings
{                                   sequence SLAVE IN did not drop.
{
{       29 - INCOMPLETE TRANSFER    Not all  words  were  transferred
{                                   when the channel was inactivated.
{                                   Status from the controller didn't
{                                   indicate  an error.  Refer to the
{                                   Residual Word  count  in  counter
{                                   word  17  to  see how many 16-bit
{                                   words were not transferred.
{
{       30 - CHANNEL STAYED ACTIVE  Following an information exchange
{                                   the controller did not drop SLAVE
{                                   IN.   The  controller drops SLAVE
{                                   IN when the last  word  has  been
{                                   transferred  or  if no words have
{                                   been transferred for its  timeout
{                                   limit of about 26 milliseconds.
{
{       31 - BUFFER COUNTER ERROR   This is bit 15 of the IPI channel
{                                   error register.
{
{       32 - SYNC COUNTER ERROR     This is bit 13 of the IPI channel
{                                   error register.
{
{       33 - LOST DATA              This is bit 7  of the IPI channel
{                                   error   register.   It  indicates
{                                   that the  controller ended a data
{                                   transfer  and  the  IPI channel's
{                                   buffer is not empty.
{
{       34 - BUS PARITY             This is bit 6  of  ending  status
{                                   received from the controller.  It
{                                   indicates  that  the   controller
{                                   detected a parity  error  on  the
{                                   IPI  interface.  Ending status is
{                                   right  justified  in counter word
{                                   19.
{
{       35 - COMMAND REJECT         This is reported in bits  0-3  of
{                                   ending  status  received from the
{                                   controller.   If a value of 2, 3,
{                                   6, or 8 is  in  these  bits,  the
{                                   controller   has   rejected   the
{                                   command sent by the  PP.   Ending
{                                   status   is  right  justified  in
{                                   counter word 19.
{
{       36 - SYNC OUTS NOT EQUAL SYNC INS  This is reported  in  bits
{                                   0-3  of  ending  status  received
{                                   from the  controller.   If  these
{                                   bits  have  a  value  of  9,  the
{                                   controller's SYNC OUT  count  and
{                                   its  SYNC IN count were not equal
{                                   when the transfer ended.   Ending
{                                   status   is  right  justified  in
{                                   counter word 19.
{
{       37 - BUS B ACKNOWLEDGE INCORRECT   During   a   bus   control
{                                   sequence bus B received from  the
{                                   controller was nonzero.  Bus B is
{                                   in  the  right-most 8 bits of the
{                                   IPI channel status register.
{
{       38 - NO CONTROLLER RESPONSE  A command  or  a  state sequence
{                                   sent  to  the  controller was not
{                                   responded to within the  allotted
{                                   time.
{
{       39 - ENDING STATUS WRONG    This   is   reported  if  bit  7,
{                                   indicating  successful,  was  not
{                                   set  in  ending  status  from the
{                                   controller  and  bits  in  ending
{                                   status  did not isolate to a code
{                                   of 34, 35,  36,  or  70.   Ending
{                                   status  is  right  justified  in
{                                   counter word 19.
{
{         The  following  symptom statements are informative and will
{       have counter word 7 set to a value of 3.  Counter  words  1-9
{       are applicable  for  symptom  statements  50-52.  All counter
{       words, except 17-23, are applicable for the remaining symptom
{       statements.
{
{       50 - EXECUTING CONTROLLER DIAGNOSTICS  Execution  of a  power
{                                   on  (slave)  reset  seequence was
{                                   initiated. This causes controller
{                                   diagnostics to be executed.
{
{       51 - CONTROLLER DIAGNOSTICS PASSED   The controller self-test
{                                   diagnostic  portion  of the power
{                                   on reset completed without error.
{                                   Also, during  recovery  for  this
{                                   request,   the    message     'NO
{                                   CONTROLLER  RESPONSE'   was   not
{                                   reported.
{
{       52 - CONTROLLER DIAGNOSTICS PASSED - LAST ERROR CODE IS XXXX
{                                   the  controller self-test portion
{                                   of the power on  reset  completed
{                                   without  error.   Also a previous
{                                   error   message   indicated    NO
{                                   CONTROLLER RESPONSE.   This means
{                                   that  the   controller   probably
{                                   wrote  error   status   into  its
{                                   EEPROM, displayed an  error  code
{                                   on  its 2-digit error display and
{                                   stopped  communicating  with  the
{                                   PP.
{
{       53 - CONTROLLER ALTERNATE PORT EVENT  The controller detected
{                                   an error from its alternate port.
{                                   Reference parameter ID 15 in  the
{                                   response    packet    for    more
{                                   information.
{
{       54 - DRIVE ALTERNATE PORT EVENT  The drive detected  an event
{                                   from    its     alternate   port.
{                                   Reference parameter ID 25 in  the
{                                   response    packet    for    more
{                                   information.
{
{       55 - RESTORING DRIVE        The restore of a  physical  drive
{                                   in a logical unit with parity has
{                                   been initiated.
{
{       56 - DRIVE RESTORATION COMPLETE  The restore  of  a  physical
{                                   drive  in  a  logical  unit  with
{                                   parity  has   completed   without
{                                   error.
{
{       57 - FORMATTING DRIVE       The  PP  driver  has initiated an
{                                   initial format of an HDA.
{
{       58 - FORMAT COMPLETE        The  format   of   an   HDA   has
{                                   completed successfully.
{
{       59 - PARITY PROTECTION DISABLED  An error was isolated  to  a
{                                   drive.  The logical  unit  had  a
{                                   parity  drive  and  the   failing
{                                   drive was off lined.
{
{         The  following  symptom  statements  are  returned  when  a
{       diagnostic  isolated  an  error.   All  counter words, except
{       17-23, are applicable for the following symptom statements.
{
{       61 - DRIVE FAILURE          Drive diagnostics were run and an
{                                   error   occurred.    A   response
{                                   packet  with  parameter   ID   23
{                                   contains  more  information.   If
{                                   the response packet  contains  an
{                                   error  code,  it  will  be put in
{                                   counter word 10.
{
{       62 - MEDIA FAILURE          This    indicates     that     an
{                                   uncorrectable  media  defect  has
{                                   developed on the media surface or
{                                   there    is    a    less   likely
{                                   possibility  that  there  was  an
{                                   intermittent  failure  when   the
{                                   sector   was  originally  written
{                                   which was not detected until  the
{                                   subsequent  read.  The confidence
{                                   test successfully wrote, read and
{                                   verified   data   on  a  cylinder
{                                   reserved  for  maintenance.   The
{                                   storage device is not DOWNed as a
{                                   result  of   a   media   failure.
{                                   NOS/VE     will     automatically
{                                   software  flaw  this  bad   spot.
{                                   Reference  the  section on Volume
{                                   Defect   Management   for    more
{                                   information.
{
{         The  following symptom statements are most likely caused by
{       the  controller.   However, if slave reset is successful, and
{       all retries are unsuccessful, the  PP  driver  assumes  these
{       symptom  statements  are  caused  by  the drive.  All counter
{       words, except 17-23, are applicable for the following symptom
{       statements.
{
{       70 - LRC ERROR              Data was read from disk into  the
{                                   5831  controller  buffer  without
{                                   error, then either  a  transverse
{                                   parity  error  occurred,  or  the
{                                   longitudinal    redundancy   code
{                                   generated  by  the controller for
{                                   the data sent to the host did not
{                                   match  the  one  read.   This  is
{                                   reported  when  ending status has
{                                   a  code of 0B hex.  Ending status
{                                   is  right-justified   in  counter
{                                   word 19.
{
{       71 - CONTROLLER INTERVENTION REQUIRED   The   controller   is
{                                   unable  to  execute  commands and
{                                   some  intervention  is  required.
{                                   Reference parameter ID 14 in  the
{                                   response    packet    for    more
{                                   information.
{
{       72 - CONTROLLER MACHINE EXCEPTION  A  machine  exception  was
{                                   detected   in   the   controller.
{                                   Reference parameter ID 16 in  the
{                                   response    packet    for    more
{                                   information.
{
{       73 - COMMAND EXCEPTION      The command  packet  received  by
{                                   the  controller   had   incorrect
{                                   values, was too short, or did not
{                                   contain all required  parameters.
{                                   Reference  parameter ID 17 of the
{                                   response    packet    for    more
{                                   information.
{
{       74 - MICROCODE EXECUTION ERROR  The controller encountered an
{                                   error in its own microcode during
{                                   execution.   This  is bit 3, byte
{                                   1, of parameter   ID  13  in  the
{                                   response packet.
{
{       76 - UNEXPECTED RESPONSE    Either a response packet from the
{                                   controller   indicated   transfer
{                                   notification when  there  was  no
{                                   data  to transfer or the response
{                                   packet indicated command complete
{                                   when   there  was  more  data  to
{                                   transfer.
{
{       77 - DRIVE RESERVED TO OTHER CONTROLLER  PORT  The  drive  is
{                                   reserved to the redundant port of
{                                   the CM3.   This is bit 3, byte 5,
{                                   of  parameter  ID   17   in   the
{                                   response  packet.   For  the 5831
{                                   controller it is not possible  to
{                                   tell  whether the reserve is held
{                                   by another controller or  another
{                                   port,  so  symptom 89 is returned
{                                   for both.
{
{       78 - CONTROLLER OVER TEMPERATURE  This is an early warning of
{                                   a   controller  over  temperature
{                                   condition.
{
{         The following symptom statements are most likely caused  by
{       the  drive.   All counter words, except 17-23, are applicable
{       for the following symptom statements.
{
{       80 - DRIVE NOT OPERATIONAL  The drive  is  not  present,  not
{                                   powered  on,  or  not responding.
{                                   Reference parameter ID 24  in the
{                                   response    packet    for    more
{                                   information.
{
{       81 - DRIVE NOT READY        This  usually  means the drive is
{                                   not  spinning.   The  PP   driver
{                                   automatically  attempts  to power
{                                   up the spindle if this status  is
{                                   detected.  If the start switch is
{                                   not depressed, the power up  will
{                                   be    unsuccessful   and   manual
{                                   intervention  will  be  required.
{                                   Reference parameter ID 24  in the
{                                   response    packet    for    more
{                                   information.
{
{       82 - DRIVE INTERVENTION REQUIRED The drive is powered on  and
{                                   ready   but   unable  to  execute
{                                   commands.  Reference parameter ID
{                                   24  in  the  response  packet for
{                                   more information.
{
{       85 - UNCORRECTABLE DATA CHECK The controller detected a  data
{                                   error  and  all retries have been
{                                   exhausted.  This is bit  6,  byte
{                                   2,  of  parameter  ID 26  in  the
{                                   response packet.
{
{       86 - DRIVE FATAL ERROR      The drive  detected  an  internal
{                                   machine   error   that  precludes
{                                   execution or continuation of  the
{                                   current    command.     Reference
{                                   parameter ID 26  in  the response
{                                   packet for more information.
{
{       87 - HARDWARE WRITE PROTECTED An attempt was made to write on
{                                   a write protected drive.  This is
{                                   bit 4, byte 2, of parameter ID 26
{                                   in the response packet.
{
{       89 - DRIVE RESERVED TO OTHER CONTROLLER  For a CM3 controller
{                                   this  indicates that the drive is
{                                   reserved  to  another controller.
{                                   For  a  5831 controller it is not
{                                   possible  to  tell  whether   the
{                                   reserve   is   held   by  another
{                                   controller or the other  port  of
{                                   the  controller.   For  the  5831
{                                   controller it indicates the drive
{                                   is reserved through another path.
{                                   This  is  bit  1,  byte   1,   of
{                                   parameter  ID  24 in the response
{                                   packet.
{
{       91 - DRIVE ECC ERROR        Hardware detected an ECC error in
{                                   a header.  This is returned when
{                                   command   ending   status   from
{                                   parameter  ID  26 of the response
{                                   packet has a value of XX11 hex.
{
{       92 - MISSING SYNC OCTET ON DRIVE The drive failed to find the
{                                   sync  octet  for a header or data
{                                   field.   This  is  returned  when
{                                   command    ending   status   from
{                                   parameter ID 26 of  the  response
{                                   packet has a value of XX13 hex.
{
{       93 - SECTOR NOT FOUND       The correct sector for a write or
{                                   read could not be found.  This is
{                                   returned   when   command  ending
{                                   status from parameter  ID  26  of
{                                   the response packet has  a  value
{                                   of XX19 hex.
{
{       94 - DRIVE MACHINE EXCEPTION A machine exception was detected
{                                   in    the    drive.     Reference
{                                   parameter ID 26 in  the  response
{                                   packet for more information.
{
{       95 - NO UNIT OPERATIONAL RESPONSE  After  an Abort command or
{                                   after  a slave reset sequence, an
{                                   operational   response   was  not
{                                   received for the drive.
{
{       96 - DAS HEAD SHIFT WARNING A probable head  shift  condition
{                                   has   been   detected  by the DAS
{                                   microcode  while   running  drive
{                                   diagnostics.
{
{       97 - SSD BATTERY TOO LOW FOR BACKUP The battery voltage level
{                                   in the SSD is  to low  to support
{                                   backing up  the  SSD data  to the
{                                   back-up disk.
{
{       98 - SSD BATTERY TEST FAILED The SSD battery test has failed.
{                                   The battery should be replaced.

{       99 - SSD BATTERY OLD - REPLACE The SSD battery  is more  than
{                                   three years  old  or has operated
{                                   for more than 500 back-up cycles.
{                                   Replace the battery.
{
{         The  following  symptom  statements  are  returned  if  the
{       controller recovers an error without  intervention  from  the
{       PP.   Since  recovered errors are not displayed on the System
{       Console, these codes will only be found in  counter  word  8.
{       All  counter  words,  except  17-23,  are  applicable for the
{       following symptom statements.
{
{       100 - ERROR RETRY           The   controller   completed  the
{                                   command,   but  error  retry  was
{                                   required.  Error retry  does  not
{                                   include actions associated with a
{                                   data transfer.
{
{       101 - DATA RETRY            The  controller   completed  the
{                                   command,   but   data  retry  was
{                                   required.
{
{       102 - MOTION RETRY          The  controller   completed   the
{                                   command,  but  motion  retry  was
{                                   required.
{
{       103 - DATA CORRECTION       The  controller   completed   the
{                                   command,  but data correction was
{                                   required.
{
{       104 - SOFT ERROR            The   controller   detected    an
{                                   internal  machine  error that did
{                                   not   preclude    execution    or
{                                   continuation   of   the   current
{                                   command.
{
{       106 - PARITY DRIVE CORRECTION  The logical unit has a  parity
{                                   drive,  an  error occurred  on  a
{                                   read, and the  parity  drive  was
{                                   used to return correct data.
{
{         The  following  symptom  statements  are  returned  if  the
{       failure  could  not  be  isolated.   Counter  words  1-8  are
{       applicable.
{
{       110 - PP-CONTROLLER DATA INTEGRITY    Slave     reset     was
{                                   successful,  no  write  buffer or
{                                   read buffer errors were detected,
{                                   but data read from the controller
{                                   buffer   did   not   match   data
{                                   previously   written  during  the
{                                   PP/controller path test.
{
{       111 - CM-DRIVE DATA INTEGRITY All self-tests were successful,
{                                   no  write  or read command errors
{                                   were detected, but data read from
{                                   disk  to  central  memory did not
{                                   match the data previously written
{                                   during the confidence test.
{
{         The following symptom statement  is  most likely a software
{       failure, but may be caused by a hardware  error  in  the CPU.
{       Counter words 1, 2, 7 and 8 are applicable.
{
{       120 - SOFTWARE FAILURE      The  PP  found a value in a table
{                                   created  by  the  CP  in  central
{                                   memory to be incorrect.
{
{       121 - WRONG DRIVE TYPE      The  drive  type  defined  in the
{                                   physical  configuration  does not
{                                   match the actual drive type. This
{                                   is  only  returned  for  9836 and
{                                   9853 drives.
{
{         The following symptom statement code is usually caused by a
{       bad HDA.   If  counter  word  7  indicates  unrecovered,  the
{       recommended  action  is  to  try  an  initial format.  If the
{       initial format fails, the action is to replace the HDA.   All
{       counter words, except 17-23, are applicable for the following
{       symptom code.
{
{       130 - DEFECT MANAGEMENT TASK FAILED This is usually  returned
{                                   due  to  an  error  that occurred
{                                   when    formatting    the    HDA.
{                                   Reference  parameter  ID 12 or 22
{                                   in the response packet  for  more
{                                   information.
{         The following  symptom  statements  usually  occur  when  a
{       logical unit is configured the first time and it has not been
{       formatted and clusterred.  An initialize of the logical  unit
{       will usually  correct  the  problem.   Counter  words 1-9 and
{       24-40 are applicable.
{
{       140 - XXXX CONFIGURED - FOUND YYYY  The drive type defined in
{                                   the  physical  configuration does
{                                   not match the actual drive  type.
{                                   XXXX and YYYY are product numbers
{                                   for the drives.
{
{                                   Examples are as follows.
{
{        + ---------------+----------------+------------+
{        | type defined   |  actual drive  |  comment   |
{        +----------------+----------------+------------+
{        |   any 5833     |   any 5832     |   error    |
{        |   any 5833     |   any 5838     |   error    |
{        |   any 5838     |   any 5832     |   error    |
{        |   any 5838     |   any 5833     |   error    |
{        |   any 5832     |   any 5833     |   error    |
{        |   any 5832     |   any 5838     |   error    |
{        |   5833_1       | any other 5833 |   error *  |
{        |   5833_1P      | any other 5833 |   error *  |
{        |   5833_2       | any other 5833 |   error *  |
{        |   5833_3P      | any other 5833 |   error *  |
{        |   5833_4       | any other 5833 |   error *  |
{        |   5838_1       | any other 5838 |   error *  |
{        |   5838_1P      | any other 5838 |   error *  |
{        |   5838_2       | any other 5838 |   error *  |
{        |   5838_3P      | any other 5838 |   error *  |
{        |   5838_4       | any other 5838 |   error *  |
{        |   47444_1      | any other 47444|   error *  |
{        |   47444_1P     | any other 47444|   error *  |
{        |   47444_2      | any other 47444|   error *  |
{        |   47444_3P     | any other 47444|   error *  |
{        |   47444_4      | any other 47444|   error *  |
{        |   5832_1       |    5832_2      |   error ** |
{        |   5832_2       |    5832_1      |   error ** |
{        +----------------+----------------+------------+
{
{        *  If  the drive is being initialized, the operator is asked
{           to   confirm  the  need  to  change  the  logical  unit's
{           reconfiguration.     The  drive  will  be  formatted  and
{           clustered as necessary if the operator continues.
{       **  If  the drive is being initialized, the operator is asked
{           to   confirm  the  need  to  change  the  logical  unit's
{           reconfiguration.   The switch setting for the sector size
{           is  wrong.   The  configuration switch must be 17 hex for
{           the 5832_1 unit and must be hex 16 for the 5832_2 unit.
{
{       141 - DRIVE INITIALIZATION REQUIRED The drive is not properly
{                                   formatted   or   is  not properly
{                                   clustered.  The actual drive type
{                                   could  not be determined.  If the
{                                   drive is  being  initialized,  it
{                                   will automatically  be  formatted
{                                   and clustered as necessary.
{
{       142 - CONTROLLER DOES NOT SUPPORT PARALLEL      Either    the
{                                   controller  does  not  have   the
{                                   parallel option or the controller
{                                   microcode  does  not  support the
{                                   configured unit.
{
{   9. Request  retry  count  -  The  number  of  times the PP driver
{      retried the entire i/o request.
{
{  10. Diagnostic code - If this word has  a  value  of minus one, no
{      diagnostic  code  is  present.   If  counter word 8 is 61, the
{      error code was generated by the drive as  a  result of running
{      its  self-contained diagnostic.   If counter word 8 is not 61,
{      the  error  code  is  the  most  recent  one  from the drive's
{      history  log  and may have occurred prior to the current error
{      being  reported.   Bits 40-47 contain  a two-digit hexadecimal
{      access  error  code  and  bits  56-63  contain   a   two-digit
{      hexadecimal  read/write error code.   An access error code and
{      a  read/write error code will not be present at the same time.
{      If bits 40-47 are zero, a read/write error code is present.
{
{  11. Cylinder number of initial seek
{
{  12. Track number of initial seek
{
{  13. Sector number of initial seek
{
{  14. Cylinder number of failure - This will be the cylinder  number
{      in the response packet.  If there was no response  packet  for
{      this error, it will be the one the PP was attempting to access
{      at  the  time  of  the  failure.   If the error occurred while
{      executing the path test, this  will  be  the  confidence  test
{      cylinder.
{
{  15. Track number of failure - This will be the track number in the
{      response packet.  If there was no  response  packet  for  this
{      error, it will be the one the PP was attempting to  access  at
{      the  time  of  the  failure.   If  the  error  occurred  while
{      executing the path  test  and  there  is  no  response  packet
{      present, the track number will be set to zero.
{
{  16. Sector number of failure - This will be the sector  number  in
{      the response packet.  If there was no response packet for this
{      error,  it  will be the one the PP was attempting to access at
{      the  time  of  the failure.   If  the  error  occurred   while
{      executing  the  path  test  and  there  is  no response packet
{      present, the sector number will be set to zero.
{
{  17. Residual word count on incomplete channel transfer.
{
{  18. Failing  function  -  This  is  the  last function issued.  If
{      counter word 8 indicates  a  function  timeout,  this  is  the
{      failing function.
{
{  19. Status  register of IPI channel - This register is 16 bits and
{      is right justified.
{
{  20. Error register of IPI channel - This register is 16  bits  and
{      is right justified.
{
{  21. Error register of I4 IPI DMA - This register is 16 bits and is
{      right justified.  On an S0 system bit 0 will be set to one  to
{      indicate this counter word is not used.
{
{  22. Operational  status of I4 IPI adapter - This status is 16 bits
{      and is right justified.  On an S0 system bit 0 will be set  to
{      one to indicate this counter word is not used.
{
{  23. Control  register of I4 IPI adapter - This register is 16 bits
{      and is right justified.  On an S0 system bit 0 will be set  to
{      one to indicate this counter word is not used.  The right-most
{      16 bits of this word will be 4000(16) for a 25 MB channel.
{
{  24. Controller microcode revision number - The revision number  is
{      two hex digits  and is right justified for the CM3 controller.
{      For  the  5831  controller  this contains  8  hex digits right
{      justified.   From the left there are 2 for month, 2 for day, 2
{      for the year, and 2 for the revision number.
{
{  25. Response packet first word - If the upper 16 bits of this word
{      are nonzero, a response packet is present.   These  two  bytes
{      contain  the  length,  in 8-bit bytes, of the response packet.
{      The first two bytes  are  not  included  in  the  byte  count.
{      Response  packet  bytes  are packed, 8 bytes per counter word.
{      This response packet may not be applicable  for  some  errors,
{      like  function timeout, but may still contain a valid response
{      packet.  In this case it would be  the  last  response  packet
{      received  from a controller.  It could even be for a different
{      controller than the one  the  error  is  being  reported  for.
{      Reference   the   controller   product   specification  for  a
{      description of the response.
{  .
{  .
{  .
{  NN. Response  packet  last word.  The maximum value for NN will be
{      40.
{
  CONST
    cml$9836_1_failure_data = cmc$min_ecc+4106;
*DECK DECK=CML$CHANNEL_IDENTIFICATION EXPAND=FALSE
{
{ CML$CHANNEL_IDENTIFICATION
{
{
{ PURPOSE:
{    This statistic provides the identification of a channel on the
{ mainframe being initialized.
{    Each channel identified by the IOU is reported regardless of
{ whether or not the channel is connected to a peripheral in
{ NOS/VE's active configuration.
{
{ FREQUENCY: At each system initialization, once for each channel.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<channel>*<type>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where <iou> is the name IOU0, for IOU zero, IOU1, for IOU
{        one, etc.
{
{      where <channel> is either the string 'CHn' or the string
{        'CCHn'; n is the decimal representation of the channel
{        number.  Note that 'CCH' is the designation given to the
{        concurrent channels in an I4 IOU.
{
{      where <type> is the kind of channel which is present:
{
{        CYBER 170
{        ISI
{
{    The counter-value portion of this statistic contains:
{
{    1.  Channel Number
{        Bit 57 = 1 implies that the channel is an I4 concurrent
{        channel.
{
{    2.  Channel Type
{        1. CYBER 170
{        2. ISI
{

  CONST
    cml$channel_identification = cmc$min_ecc + 5;

*copyc cmc$condition_limits
*DECK DECK=CML$CM_IDENTIFICATION EXPAND=FALSE
{
{ CML$CM_IDENTIFICATION
{
{
{ PURPOSE:
{    This statistic provides the identification of the central
{ memory on the mainframe being initialized.  This statistic is
{ emitted when the configuration is activated during each
{ system initialization.
{
{ FREQUENCY: At each system initialization.
{
{ CONTENT:
{    The descriptive-data portion of this statistic contains:
{
{    '<mf>.<element>*<product identification>*<serial number>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where <element> is the name CENTRAL_MEMORY.
{
{      where <product identification> is the model number from the
{        memory element's identification register.
{
{      where  <serial  number> is the serial number from the memory
{        element's identification register.
{
{    The counter-value portion of this statistic is unused.
{

  CONST
    cml$cm_identification = cmc$min_ecc + 3;

*copyc cmc$condition_limits
*DECK DECK=CML$CONNECTION_DISABLED EXPAND=FALSE
{
{ CML$CONNECTION_DISABLED
{
{
{ PURPOSE:
{    This statistic provides notification that a failure has been isolated
{ to either a controller or a unit and that NOS/VE has disabled the use of the
{ connection between two elements.
{
{    A disabled connection is reinstated when the state of either the upline
{ or the downline element in the connection is manually changed to ON, when the
{ UNSTEP_SYSTEM command is entered, or when NOS/VE is deadstarted.
{
{ FREQUENCY:
{    Whenever the system encounters during an I/O request a hardware failure
{    that prevents further use of the connection.
{
{ CONTENT:
{    The descriptive-data portion of this statistic contains:
{
{    '<failing_connection>,<failing_element>,<failing_path>*CONNECTION DISABLED'
{
{      where <failing_connection> is of the form:
{
{        <upline_element_name>.<downline_element_name>
{
{        where <upline_element_name> is either the name of a controller or
{        a channel.  If the latter, the string is of the form 'IOUx/CCHx'
{        or 'IOUx/CHx'.
{
{        where <downline_element_name> is the name of a controller or a unit.
{
{      where <failing_element> is the name of the element that the NOS/VE
{        driver diagnosed as the failing element.
{
{      where <failing_path> is of the form:
{
{        '<mf>.<iou>.<pp>.<channel>.[<controller>].<unit>'
{
{        where <mf> is the identification of the mainframe in the form
{          $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{          Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{          serial number of that processor, e.g. 0104.
{
{        where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{          This identifies the IOU associated with the channel over
{          which the failure was reported.
{
{        where <pp> is either the string 'PPn' or 'CPPn' and where 'n'
{          is the decimal representation of the logical PP number used
{          to process the failing request.  Note that 'CPP' is the
{          designation given to the concurrent PPs in an I4 IOU.
{
{        where <channel> is either the string 'CHn' or 'CCHnp', or 'CCHn'
{          where 'n' is the decimal representation of the channel and
{          where 'p' is the channel port (A or B) through which the
{          disk device was accessed.  Note that 'CCH' is the
{          designation given to the concurrent channels in an I4 IOU.
{
{        where <controller> is the element name of the disk controller
{          used in the failing request, if applicable.  This is an optional
{          field due to the $887_1 product that has the controller embedded
{          in the unit.
{
{        where <unit> is the element name of the failing disk storage
{          device used in the failing request.
{
{        where CONNECTION DISABLED is a string constant used to help identify
{          this statistics in the engineering log.
{
{    The counter-value portion of this statistic is not defined.
{
{

  CONST
    cml$connection_disabled = cmc$min_ecc + 202;

*copyc cmc$condition_limits
*DECK DECK=CML$CPU_FAILURE_DATA EXPAND=FALSE
{
{ CML$CPU_FAILURE_DATA
{
{
{ PURPOSE:
{    This statistic records the failure data captured by the system
{ following corrected or uncorrected CPU errors.
{
{ FREQUENCY: Each time DFT enters data into the maintenance
{            register buffers following each failure occurrence.
{
{ CONTENT:
{    The descriptive-data portion of this statistic contains:
{
{    '<mf>.<element>*<product id>*<serial number>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0) and 'ssss' is the serial
{        number of that processor.
{
{      where <element> is the name CP0 for processor zero,
{        CP1 for processor one etc.
{
{      where <product id> is the model number from the processor's
{        element identification register.
{
{      where <serial number> is the serial number from the
{        processor's element identification register.
{
{      where <symptom> is the symptom/action statement provided
{        by the system. The text of the possible symptom statements
{        is identical in content to the uppercase text described
{        under counter value 2 below.
{
{    The counter-value portion of this statistic contains:
{
{    1. Operating System (OS) action code as described in section
{       4.2 of the DFT/OS Interface Specification. (DCS # ARH6853)
{
{    2. This word contains a 12-bit DFT analysis code followed by
{       an 8-bit sequence number stored in bits 44-63 of the word.
{       The sequence number indicates the sequential order in which
{       a series of statistics occurred, and ranges from 0-255(10).
{       Dedicated Fault Tolerance (DFT) analysis code is described
{       in section 4.4 of the DFT/OS Interface Specification. The
{       failure data should be analyzed in the order in which the
{       following codes are presented. (It should also be noted
{       that if bit 12 of the 12-bit hexadecimal DFT analysis code
{       is set, the error has occurred more than one time but is
{       being reported only once; e.g. code 203 will become A03.)
{
{       201 DEADSTART ERROR LOG PROCESSOR ERROR.
{       208 FATAL CPU HALT.
{       20B FATAL CPU RECOVERY ERROR (990 PROCESSOR ONLY).
{       20D FATAL CPU UNCORRECTED ERROR
{       21A FATAL CPU HALT CLASS 2.
{       207 UNREPAIRED ERROR (990 PROCESSOR ONLY).
{       204 UNCORRECTED PROCESSOR ERROR.
{       21B RETRY CONVERTED TO UNCORRECTED.
{       219 FORCED UNCORRECTED ERROR.
{       206 REPAIRED ERROR (990 PROCESSOR ONLY).
{       203 CORRECTED PROCESSOR ERROR.
{       20C CORRECTED PROCESSOR ERROR WITH CACHE RELOAD.
{       21C RETRY EXHAUSTED.
{       205 RETRY IN PROGRESS (990 PROCESSOR ONLY).
{       21D HOURLY RETRY THRESHOLD EXHAUSTED.
{
{     The content of words 3-63 is model dependent based upon
{     the DFT error analysis code. Packets of five words, each
{     consisting of a header word followed by the contents of four
{     maintenance registers are stored sequentially. The header
{     word consists of 4 16-bit maintenance register addresses
{     stored from left to right that specify which register
{     contents are stored in the following four words. Sections
{     4.5.9 (Code 3201), 4.5.6 (Codes 3208 and 3204), 4.5.5 (Codes
{     2203 and 0205) and 4.1.17 (Codes 3207 and 2206) of the
{     DFT/OS Interface Specification define the maintenance
{     registers and the order in which their contents are stored
{     for CPU errors.
{
  CONST
    cml$cpu_failure_data = cmc$min_ecc + 1000;

*copyc cmc$condition_limits
*DECK DECK=CML$CP_IDENTIFICATION EXPAND=FALSE
{
{ CML$CP_IDENTIFICATION
{
{
{ PURPOSE:
{    This statistic provides the identification of a central
{ processor on the mainframe being initialized.  This statistic
{ is emitted when the configuration is activated during each
{ system initialization.
{
{ FREQUENCY: At each system initialization, one for each central
{ processor.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<element>*<product identification>*<serial number>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <element> is the name CP0, for processor zero, CP1 for
{        processor one, etc.
{
{      where <product identification> is the model number from the
{        processor's element identification register.
{
{      where <serial number> is the serial number from the
{        processor's element identification register.
{
{    The  counter-value portion of this statistic is unused.
{

  CONST
    cml$cp_identification = cmc$min_ecc + 2;

*copyc cmc$condition_limits
*DECK DECK=CML$DFT_CPU_FAILURE_DATA EXPAND=FALSE

  CONST
    cml$dft_cpu_failure_data = cmc$min_ecc + 1100;

*copyc cmc$condition_limits
*DECK DECK=CML$DFT_CRITICAL_FAILURE_DATA EXPAND=FALSE

  CONST
    cml$dft_critical_failure_data = cmc$min_ecc + 1108;

*copyc cmc$condition_limits
*DECK DECK=CML$DFT_CYBER_2000_ERROR EXPAND=FALSE

  CONST
    cml$dft_cyber_2000_error = cmc$min_ecc + 1120;

*copyc cmc$condition_limits
*DECK DECK=CML$DFT_HOUR_ELEMENT_COUNTERS EXPAND=FALSE

  CONST
    cml$dft_hour_element_counters = cmc$min_ecc + 1104;

*copyc cmc$condition_limits
*DECK DECK=CML$DFT_HOUR_SECDED_ID EXPAND=FALSE

  CONST
    cml$dft_hour_secded_id = cmc$min_ecc + 1105;

*copyc cmc$condition_limits
*DECK DECK=CML$DFT_IOU_FAILURE_DATA EXPAND=FALSE

  CONST
    cml$dft_iou_failure_data = cmc$min_ecc + 1102;

*copyc cmc$condition_limits
*DECK DECK=CML$DFT_MEMORY_FAILURE_DATA EXPAND=FALSE

  CONST
    cml$dft_memory_failure_data = cmc$min_ecc + 1101;

*copyc cmc$condition_limits
*DECK DECK=CML$DFT_NON_CRIT_FAILURE_DATA EXPAND=FALSE

  CONST
    cml$dft_non_crit_failure_data = cmc$min_ecc + 1109;

*copyc cmc$condition_limits
*DECK DECK=CML$DFT_PAGE_MAP_FAILURE_DATA EXPAND=FALSE

  CONST
    cml$dft_page_map_failure_data = cmc$min_ecc + 1107;

*copyc cmc$condition_limits
*DECK DECK=CML$DFT_POWER_FAILURE_DATA EXPAND=FALSE

  CONST
    cml$dft_power_failure_data = cmc$min_ecc + 1103;

*copyc cmc$condition_limits
*DECK DECK=CML$DFT_TOP_OF_HOUR EXPAND=FALSE

  CONST
    cml$dft_top_of_hour = cmc$min_ecc + 1106;

*copyc cmc$condition_limits
*DECK DECK=CML$DISK_DEVICE_USAGE_DATA EXPAND=TRUE
{
{ CML$DISK_DEVICE_USAGE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record the amount of work
{ performed by a particular disk storage device. This information is
{ used by maintenance personnel to measure the failure rate per
{ amount of service performed.
{
{ FREQUENCY: Every half-hour.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<unit>*<vsn>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where <unit> is the element name of the disk storage
{        device whose work is being recorded.
{
{      where <vsn> is the recorded-vsn of the disk volume which was
{        the object of the work performed.
{
{    The  counter-value portion of this statistic contains:
{
{    1.  Total number of MAUs read from this storage device since the
{        the system was last initialized.
{    2.  Total number of MAUs written to this storage device since
{        the system was last initialized.
{    3.  Total number of i/o requests issued for this storage device
{        since the system was last initialized.
{

  CONST
    cml$disk_device_usage_data = cmc$min_ecc + 4001;

*copyc cmc$condition_limits
*DECK DECK=CML$DISK_PATH_USAGE_DATA EXPAND=TRUE
{
{ CML$DISK_PATH_USAGE_DATA
{
{
{  PURPOSE:
{     The purpose of this statistic is to record the amount of work
{ performed by a particular channel/controller combination.  This
{ information is used by maintenance personnel to measure the failure
{ rate per amount of service performed.
{
{ FREQUENCY: Every half-hour.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{  For $7154 and $7155_1x subsystems:
{    '<mf>.<iou>.<pp>.<channel>.<controller>'
{
{  For $10395_11 and $FA7B4_d subsystems:
{    '<mf>.<iou>.<pp>.<channel>.<controller>'
{
{  For $7165_2x subsystems:
{    '<mf>.<iou>.<pp>.<channel>.<sd>'
{
{  For $887 subsystems:
{    '<mf>.<iou>.<pp>.<channel>.<controller/unit>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is either the string 'PPn' or the string 'CPPn'
{        and n is the decimal representation of the logical PP number
{        used to process the failing request.  Note that 'CPP' is the
{        designation given to the concurrent PPs in an I4 IOU.
{
{      where <channel> is the string 'CHn', 'CCHn', or 'CCHnp',
{        where 'n' is the decimal representation of the channel and
{        where 'p' is the channel port (A or B) through which the
{        disk device was accessed.  Note that 'CCH' is the
{        designation given to the concurrent channels in an I4 IOU.
{
{      where <controller> is the element name of the disk controller
{        (or control module) whose work is being reported.
{
{      where <sd> is the element name of the Storage Director
{        used in the failing request.
{
{      where  <unit> is the element name of the disk storage
{        device used in the failing request.
{
{    The  counter-value portion of this statistic contains:
{
{    1.  Total number of MAUs processed (written plus read) for this
{        disk channel/controller combination since the system was
{        last initialized.
{    2.  Total number of i/o requests processed (written plus read)
{        for this disk channel/controller combination since the
{        system was last initialized.
{

  CONST
    cml$disk_path_usage_data = cmc$min_ecc + 4000;

*copyc cmc$condition_limits
*DECK DECK=CML$DVS_USAGE_DATA EXPAND=FALSE
{
{ CML$DVS_USAGE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record usage of the
{ Diagnostic Virtual System Utility (DVS). Information recorded
{ by this statistic is used by maintenance personnel to assist
{ with location and isolation of system and mainframe faults.
{
{ FREQUENCY:
{    This statistic is emitted each time the DVS system is
{ initiated. DVS records the number of tests initiated, the
{ duration of their execution, and total number of failures that
{ have occurred. The counter-value portion of the statistic
{ records total pass and error counts for each of the tests that
{ can be executed. By convention, bit 0 (left-most bit) of a
{ counter-word indicates presence or absence of information in
{ the remainder of the word. A pass-count and error-count
{ counter-word with bit 0 set indicates that the corresponding
{ test was not initiated.
{
{ CONTENT:
{    The descriptive-data portion of this statistic contains:
{
{    '<mf>.<element>*<number_of_tests_initiated>*<execution_duration>..
{       *<number_of_tests_failed>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where <element> is the name DVS_TESTS_CP0 or DVS_TESTS_CP1.
{
{      where <number_of_tests_initiated> is a string representing
{        the decimal number of tests initiated by DVS during DVS's
{        duration of execution.
{
{      where <execution_duration> is a string representing the
{        decimal number of hours, minutes and seconds that DVS
{        was active.
{
{      where <number_of_tests_failed> is a string representing
{        the decimal number of tests of the total initiated that
{        detected errors. The counter-value portion of the
{        statistic identifies the specific tests that failed
{        and the number of errors detected.
{
{    The counter-value portion of the statistic contains:
{
{   1. RCT1 (Random Command Test 1) Total Passes Completed.
{   2. RCT1 (Random Command Test 1) Total Errors Detected.
{   3. RCT2 (Random Command Test 2) Total Passes Completed.
{   4. RCT2 (Random Command Test 2) Total Errors Detected.
{   5. FCT3 (Fixed Command Test 3) Total Passes Completed.
{   6. FCT3 (Fixed Command Test 3) Total Errors Detected.
{   7. SNGL (Single Precision Floating Point Test)
{              Total Passes Completed.
{   8. SNGL (Single Precision Floating Point Test)
{              Total Errors Detected.
{   9. DUBL (Double Precision Floating Point Test)
{              Total Passes Completed.
{  10. DUBL (Double Precision Floating Point Test)
{              Total Errors Detected.
{  11. BRCH (Floating Point Branch Test)
{              Total Passes Completed.
{  12. BRCH (Floating Point Branch Test)
{              Total Errors Detected.
{  13. FINT (Full Word Integer Test)
{              Total Passes Completed.
{  14. FINT (Full Word Integer Test)
{              Total Errors Detected.
{  15. HINT (Half Word Integer Test)
{              Total Passes Completed.
{  16. HINT (Half Word Integer Test)
{              Total Errors Detected.
{  17. FIMM (Full Word Immediate Test)
{              Total Passes Completed.
{  18. FIMM (Full Word Immediate Test)
{              Total Errors Detected.
{  19. HIMM (Half Word Immediate Test)
{              Total Passes Completed.
{  20. HIMM (Half Word Immediate Test)
{              Total Errors Detected.
{  21. NUMR (BDP Numeric Test)
{              Total Passes Completed.
{  22. NUMR (BDP Numeric Test)
{              Total Errors Detected.
{  23. BIMM (BDP Immediate Test)
{              Total Passes Completed.
{  24. BIMM (BDP Immediate Test)
{              Total Errors Detected.
{  25. RFST (Random Fast Slow Test)
{              Total Passes Completed.
{  26. RFST (Random Fast Slow Test)
{              Total Errors Detected.
{  27. DBUG (Debug Hardware Test)
{              Total Passes Completed.
{  28. DBUG (Debug Hardware Test)
{              Total Errors Detected.
{  29. TASE (Address Specification Error Test)
{              Total Passes Completed.
{  30. TASE (Address Specification Error Test)
{              Total Errors Detected.
{  31. TIVE (Instruction Specification Error Test)
{              Total Passes Completed.
{  32. TIVE (Instruction Specification Error Test)
{              Total Errors Detected.
{  33. BYTE (BDP Byte Test)
{              Total Passes Completed.
{  34. BYTE (BDP Byte Test)
{              Total Errors Detected.
{  35. EDIT (BDP Edit Test)
{              Total Passes Completed.
{  36. EDIT (BDP Edit Test)
{              Total Errors Detected.
{  37. VINT (Vector Integer Test)
{              Total Passes Completed.
{  38. VINT (Vector Integer Test)
{              Total Errors Detected.
{  39. VCMP (Vector Compare Test)
{              Total Passes Completed.
{  40. VCMP (Vector Compare Test)
{              Total Errors Detected.
{  41. VGTH (Vector Gather/Scatter Test)
{              Total Passes Completed.
{  42. VGTH (Vector Gather/Scatter Test)
{              Total Errors Detected.
{  43. VFLT (Vector Floating Point Test)
{              Total Passes Completed.
{  44. VFLT (Vector Floating Point Test)
{              Total Errors Detected.
{  45. KYPT (Keypoint Hardware Test)
{              Total Passes Completed.
{  46. KYPT (Keypoint Hardware Test)
{              Total Errors Detected.
{  47. DISK (Disk Test)
{              Total Passes Completed.
{  48. DISK (Disk Test)
{              Total Errors Detected.
{  49. TAPE (Tape Test)
{              Total Passes Completed.
{  50. TAPE (Tape Test)
{              Total Errors Detected.
{  51. CMEM (Central Memory and Disk Paging Test)
{              Total Passes Completed.
{  52. CMEM (Central Memory and Disk Paging Test)
{              Total Errors Detected.
{  53. PPCT (PP Instruction and Conflict Test)
{              Total Passes Completed.
{  54. PPCT (PP Instruction and Conflict Test)
{              Total Errors Detected.
{  55. VGSI (Vector Gather/Scatter Indexed Test)
{              Total Passes Completed.
{  56. VGSI (Vector Gather/Scatter Indexed Test)
{              Total Errors Detected.
{  57. VTRI (Vector Triad Test)
{              Total Passes Completed.
{  58. VTRI (Vector Triad Test)
{              Total Errors Detected.

  CONST
    cml$dvs_usage_data = cmc$min_ecc + 1900;

*copyc cmc$condition_limits
*DECK DECK=CML$ELEMENT_DISABLED EXPAND=FALSE
{
{ CML$ELEMENT_DISABLED
{
{ PURPOSE:
{    This statistic provides notification that an element has been disabled
{ by NOS/VE.  A disabled element remains in the ON state in the NOS/VE
{ configuration to support automatic restart of the NOS/VE system.  An element
{ is considered disabled when any of the following conditions are present:
{
{    1) The element is a channel and the driver isolated the failure to the
{       channel.
{
{    2) A controller has had all of its active downline connections disabled.
{
{    3) A controller or a unit has had all of its active upline connections
{       disabled.
{
{    A disabled element is reinstated when its state is manually changed to ON,
{ when the UNSTEP_SYSTEM command is entered, or when NOS/VE is deadstarted.
{ A redundant state change to ON is allowed if at least one of the connections
{ of the element is in a disabled condition.
{
{ FREQUENCY:
{    Whenever the system encounters one or more hardware failures that prevent
{ further use of the element.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<disabled_element>*<product identification>*<serial number>
{     *ELEMENT DISABLED'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where <disabled_element> is the element name of the element that has
{        been disabled.  If the element is a channel the element name will
{        be of the form 'IOUx/CCHx' or 'IOUx/CHx'.
{
{      where  <product  identification> is the identification of the
{        element specified in the active configuration.  If the element is
{        a channel this field will contain an empty string (i.e. ' ').
{
{      where <serial number> is the unique identity of  the  element
{        relative  to its product family as specified in the active
{        configuration (in decimal).  If the element is a channel this field
{        will contain an empty string (i.e. ' ').
{
{      where ELEMENT DISABLED is a string constant used to help identify this
{        statistic in the engineering log.
{
{    The counter-value portion of this statistic is not defined.
{
{

  CONST
    cml$element_disabled = cmc$min_ecc + 203;

*copyc cmc$condition_limits
*DECK DECK=CML$ELEMENT_STATE_CHANGE EXPAND=FALSE
{
{ CML$ELEMENT_STATE_CHANGE
{
{
{ PURPOSE:
{    This statistic provides notification of the change in the
{ state of a system hardware element.  This statistic is emitted
{ by the CHANGE_ELEMENT_STATE subcommand of the Logical
{ Configuration Utility, the cmp$change_element_state program
{ interface or as a result of the NOS/VE system automatically
{ DOWNing a failing element.
{    If a manual state change originates from a job whose class
{ is maintenance, the initiator is assumed to be a "CE".
{    If a manual state change originates from a job whose class
{ is not maintenance, the initiator is identified as an "operator".
{
{ FREQUENCY:
{    Whenever the system encounters a hardware failure which cannot
{    be tolerated and which prevents further use of the element,
{    or whenever an operator or a CE changes the state of an element
{    manually.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<element>*<product identification>*<serial number>*..
{     <message>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <element>  is  the name of the mainframe or peripheral
{        hardware element which was the object of the system action.
{
{      where  <product  identification> is the identification of the
{        element specified in the active configuration.
{
{      where <serial number> is the unique identity of  the  element
{        relative  to its product family as specified in the active
{        configuration (in decimal).
{
{      where <message> is the following:
{        'STATE CHANGED FROM <old state> TO <new state>'
{
{    The counter-value portion of this statistic contains:
{
{    1.  State Change Code
{       1 - State changed from ON to DOWN
{       2 - State changed from ON to OFF
{       3 - State changed from DOWN to ON
{       4 - State changed from DOWN to OFF
{       5 - State changed from OFF to ON
{       6 - State changed from OFF to DOWN
{    2.  Initiator Code
{       1 - Initiated by the NOS/VE system due to element failure.
{       2 - Initiated by an operator.
{       3 - Initiated by a Customer Engineer (CE).
{

  CONST
    cml$element_state_change = cmc$min_ecc + 200;

*copyc cmc$condition_limits
*DECK DECK=CML$END_DISK_USAGE_INTERVAL EXPAND=TRUE
{
{ CML$END_DISK_USAGE_INTERVAL
{
{
{  PURPOSE:
{     The purpose of this statistic is to signal the end of the
{ logging of disk path and storage device usage data. The interval
{ begins with the first CM4000 or CM4001 statistic emitted.
{
{ FREQUENCY: Every half-hour.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>*END DISK USAGE INTERVAL'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{    There are no counter-values defined for this statistic.
{

  CONST
    cml$end_disk_usage_interval = cmc$min_ecc + 4002;

*copyc cmc$condition_limits
*DECK DECK=CML$ENVIRONMENT_FAILURE_DATA EXPAND=FALSE
{
{ CML$ENVIRONMENT_FAILURE_DATA
{
{
{ PURPOSE:
{    This statistic records the failure data captured by the system
{ following detection of changing environment or power warning
{ conditions.
{
{ FREQUENCY: Each time DFT enters data into the maintenance register
{            buffers following detection of a change in environment
{            or power warning conditions.
{
{ CONTENT:
{    The descriptive-data portion of this statistic contains:
{
{    '<mf>.<element>*<product id>*<serial number>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0) and 'ssss' is the serial
{        number of that processor.
{
{      where <element> is the name CP0 or CP1, IOU0 or IOU1, or
{        CENTRAL_MEMORY.
{
{      where <product id> is the model number from the element's
{        identification register.
{
{      where <serial number> is the serial number from the
{        element's identification register.
{
{      where <symptom> is the symptom/action statement provided
{        by the system. The text of the possible symptom statements
{        is identical in content to the uppercase text described
{        under counter value 2 below.
{
{    The counter-value portion of this statistic contains:
{
{    1. Operating System (OS) action code as described in section
{       4.2 of the DFT/OS Interface Specification. (DCS # ARH6853)
{
{    2. This word contains a 12-bit DFT analysis code followed by
{       an 8-bit sequence number stored in bits 44-63 of the word.
{       The sequence number indicates the sequential order in which
{       a series of statistics occurred, and ranges from 0-255(10).
{       Dedicated Fault Tolerance (DFT) analysis code is described
{       in section 4.4 of the DFT/OS Interface Specification. The
{       failure data should be analyzed in the order in which the
{       following codes are presented. (It should also be noted
{       that if bit 12 of the 12-bit hexadecimal DFT analysis code
{       is set, the error has occurred more than one time but is
{       being reported only once.)
{
{       703 SHORT POWER WARNING
{       706 SHORT POWER WARNING CLEAR
{       702 LONG POWER WARNING
{       705 LONG POWER WARNING CLEAR
{       701 ENVIRONMENT WARNING
{       704 ENVIRONMENT WARNING CLEAR
{
{    3. Contents of maintenance register 10 (EID) for the element
{       with the warning condition present.
{
{    4. Counter-value words 4-63 are unused.
{
  CONST
    cml$environment_failure_data = cmc$min_ecc + 1003;

*copyc cmc$condition_limits
*DECK DECK=CML$FA7B4_D_FAILURE_DATA EXPAND=TRUE
{
{ CML$FA7B4_D_FAILURE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record the failure data
{ captured by the system when accessing a FA7B4_D disk controller.
{
{ FREQUENCY: At each failure occurrence.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<ch>.<cm>.<unit>*<vsn>*<class>*..
{       <message>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where  <pp>  is the string 'PPn' where n is the PP number (in
{        decimal) of the PP which performed the i/o operation  which
{        is being reported.
{
{      where  <ch>  is  the string 'CHn' where n is the channel
{        number  (in  decimal)  over  which  the  i/o  request   was
{        processed.
{
{      where  <cm>  is  the  element  name  of  the   disk   control
{        module (controller) used in the failing request.
{
{      where  <unit> is the element name of the failing disk storage
{        device used in the failing request.
{
{      where <vsn> is the recorded-vsn of the disk volume which  was
{        the object of the failing request.
{
{      where  <class>  is  the string 'UF' for unrecovered, 'RF' for
{        recovered, 'IF' for intermediate failure log-entry, and 'IM'
{        for an informative message.
{
{        The PP reports failure data and diagnostic results  as  an
{        intermediate  failure  log-entry  prior  to retrying an i/o
{        request.  This is due to  PP-memory-size  limitations.   An
{        intermediate    failure    log-entry   will   provide   the
{        first-failure data captured by the PP  during  the  initial
{        attempt  at  the  request  or  during  a subsequent request
{        retry.  This  log-entry  provides  the  initial  and  final
{        failure data for an intermediate, unsuccessful i/o request
{        retry.  At least  one  additional  request  retry  will  be
{        performed after this log-entry is made.
{
{        For  unrecovered  disk failures the counter values contain
{        the failure data corresponding  to  the  last  unsuccessful
{        retry of the i/o request.  This log-entry provides
{        the   initial   and  final  failure  data  for  the  final,
{        unsuccessful i/o request retry.
{
{        For  failures  corrected  during  sector-oriented  (media)
{        recovery, the counter values contain the first-failure data
{        captured by  the  PP.   This  log-entry  is  only  made  to
{        document successful sector-oriented recovery.
{
{      where  <message> is a statement of failure isolation based on
{        either diagnostic execution or status reported by subsystem:
{
{        ADAPTER FAILURE <code>
{        CONTROL MODULE FAILURE <code>
{        DRIVE FAILURE <code>
{          The <code> clause, a hex value which is optionally
{          appended to the messages documented above, is the
{          diagnostic code reported by the subsystem when an inline
{          diagnostic has isolated a failure to the indicated
{          subsystem element.  The diagnostic code is also reported
{          in counter-value 10.  Absence  of  the  <code> clause
{          indicates that the Adapter suspects the failure to be in
{          the indicated box; however, the failure could not be
{          isolated by diagnostics.
{
{       MEDIA FAILURE - Cccc Ttt Sss
{          The cylinder (ccc), track (tt) and sector (ss) are
{          expressed in decimal.  The location of the media failure
{          is also reported in counter-values 14, 15 and 16.
{
{       <symptom statement>
{          The symptom  statement  is  provided  for  those failures
{          which could not be isolated to a particular element.
{          The text of the possible symptom statements is
{          identical in content to the uppercase text discussed
{          under counter-value 8 below.
{
{    The  counter-value portion of this statistic contains:
{
{    1.  Logical PP number (bits 58 - 63).
{        Bits 46 - 51 contain the IOU number.
{
{    2.  Channel Number (bits 58 - 63).
{        Bits 46 - 51 contain the IOU number.
{
{    3.  Address of Control Module
{    4.  Physical Unit Number
{    5.  Unit-type
{        4 - 836-12
{    6.  Logical Operation Code
{        1 - read
{        2 - write
{    7.  Log-entry Class
{        0 - Recovered Failure Report
{        1 - Unrecovered Failure Report
{        2 - Intermediate Failure Report
{        3 - Informative Message
{    8.  Failure Analysis
{        Indicates the extent to which the subsystem and the PP were
{        able to isolate  the  failure when it was detected.  The
{        failure data is analyzed in the order in which the following
{        symptom statements are presented in this paper.  Therefore,
{        should multiple failures occur and be implied in the failure
{        data, only one symptom statement will be provided;  the one
{        provided will be the one appearing first in the following
{        list of symptoms.
{
{    0 - INDETERMINATE        The   failure  did  not  manifest
{                             itself as one  of  the  following
{                             symptoms.    Refer  to  the  Poll
{                             Status and  Detailed  Status  for
{                             additional information.
{
{    Failures reported to be in the Adapter, Control Module,
{    Drive or Media are confirmed either by subsystem
{    diagnostics or by attempting to reload the controlware
{    for a subsystem element.
{
{    1 - PP TIMED OUT A COMMAND    A command sent to the Adapter and
{                                  or Control Module was not
{                                  responded to in the allotted time.
{
{    2 - CONTROL MODULE RESERVED   The Control Module was reserved to
{                                  another host adapter.
{
{    3 - SOFTWARE FAILURE          A software failure was detected by
{                                  the PP driver.
{
{    4 - DRIVE NOT READY           The  Control  Module  reported  a
{                                  manual   intervention   code   of
{                                  C1(16)  but  there  was  no drive
{                                  fault; the Adapter  reports  this
{                                  as  a  Poll  Status  of  440xx(8).
{                                  This failure indicates  that  the
{                                  drive  is  not  spinning.  The PP
{                                  driver automatically  spins-up  a
{                                  drive   if   this   condition  is
{                                  detected; therefore if this is an
{                                  unrecovered  failure,  the  CE or
{                                  Operator  may  have  placed   the
{                                  LOC/REM  switch of the FSD in the
{                                  LOC position.  Placing the switch
{                                  in  the LOC position prevents the
{                                  PP from spinning  up  the  drive.
{                                  The PP cannot determine the state
{                                  of    the     LOC/REM     switch.
{                                  Therefore,  if  the  switch is in
{                                  the LOC position  either  depress
{                                  the   START  button  or  set  the
{                                  LOC/REM switch to the REM  state.
{
{    5 - RELOADING CONTROL MODULE  A Control Module microcode reload
{                                  was initiated.
{
{    6 - CONTROL MODULE RELOADED   The Control Module microcode was
{                                  successfully reloaded.
{
{    7 - EXECUTING LEVEL II DIAGNOSTICS   Execution of LEVEL II
{                                  inline diagnostics was initiated.
{
{    8 - LEVEL II DIAGNOSTICS PASSED      Level II diagnostics ran
{                                  successfully.
{
{    9 - DRIVE NOT PRESENT         The  Control  Module  reported  a
{                                  manual   intervention   code   of
{                                  C3(16) indicating  there  was  no
{                                  response from the drive.
{
{    10 -MEDIA FAILURE             This  indicates that a 'bad-spot'
{                                  has  developed   on   the   media
{                                  surface or there is a less likely
{                                  possibility  that  there  was  an
{                                  intermittent   failure  when  the
{                                  sector  was  originally   written
{                                  which  was not detected until the
{                                  subsequent read.
{
{    11 -FUNCTION FAILURE CLASS 2  The  channel-error-flag  was  set
{                                  and the Adapter failed to respond
{                                  to a function attempt.
{
{    12 -FUNCTION FAILURE CLASS 3  The channel-error-flag was  not
{                                  set  and  the  Adapter  failed to
{                                  respond to a function attempt.
{
{    13 -INPUT ICI PARITY          On an input from the  Adapter  to
{                                  the PP the channel-error-flag was
{                                  set.
{
{    14 -OUTPUT ICI PARITY CLASS 1 On an output from the PP  to  the
{                                  Adapter   the  channel-error-flag
{                                  was set and the Adapter  reported
{                                  the parity error.  The IOU is the
{                                  likely cause of the  problem  but
{                                  this is not a certainty.
{
{    15 -OUTPUT ICI PARITY CLASS 2 On  an  output from the PP to the
{                                  Adapter  the   channel-error-flag
{                                  was set but the Adapter did not
{                                  report a parity error.
{
{    16 -OUTPUT ICI PARITY CLASS 3 On an output from the PP  to  the
{                                  Adapter  the  Adapter  reported a
{                                  parity     error     but      the
{                                  channel-error-flag was not set.
{
{    17 -ADAPTER RAM PARITY        The  Adapter  reported  a  parity
{                                  error in its RAM memory.
{
{    18 -ADAPTER BUFFER PARITY     A  parity  error  was detected in
{                                  the Adapter's buffer memory.
{
{    19 -ADAPTER ROM PARITY        A parity error  was  detected  in
{                                  the  Adapter's  ROM  (poll status
{                                  5014).
{
{    20 -START SWITCH NOT DEPRESSED   Spin-up of the storage device
{                                  failed because the start switch
{                                  was not depressed.
{
{    21 -ISI PARITY                On  an  input or an output between
{                                  the Control Module and the Adapter
{                                  the Adapter reported a parity
{                                  error but the Control Module did
{                                  not.
{
{    22 -OUTPUT ISI PARITY CLASS 1 On  an output from the Adapter to
{                                  the  Control  Module   both   the
{                                  Adapter  and  the  Control Module
{                                  reported a parity  error  on  the
{                                  ISI channel.
{
{    23 -OUTPUT ISI PARITY CLASS 3 On  an output from the Adapter to
{                                  the Control  Module  the  Control
{                                  Module reported a parity error on
{                                  the ISI channel and  the  Adapter
{                                  did not.
{
{    24 -SEEK ERROR                The  Control  Module  reported  a
{                                  system   intervention   code   of
{                                  21(16) indicating a seek fault or
{                                  a    sector    header     address
{                                  miscompare.
{
{    25 -UNABLE TO READ HEADER     The  Control  Module  reported  a
{                                  system   intervention   code   of
{                                  41(16)  indicating  it was unable
{                                  to read the header portion of the
{                                  sector.
{
{    26 -UNABLE TO READ DATA       The   Control   Module   reported
{                                  system   intervention   code   of
{                                  43(16)  indicating  either a Sync
{                                  Byte  detection  problem   or   a
{                                  header ECC mismatch.
{
{    27 -ISI DEADMAN TIME-OUT      The    Adapter    detected     an
{                                  expiration  of  the deadman timer
{                                  on a data transfer between itself
{                                  and the Control Module.
{
{    28 -CM SCHEDULER PARITY       The  Control  Module  reported  a
{                                  manual   intervention   code   of
{                                  64(16) indicating a R/W Scheduler
{                                  memory parity error.
{
{    29 -CM MPU PARITY             The  Control  Module  reported  a
{                                  manual   intervention   code   of
{                                  65(16)  indicating  an MPU memory
{                                  parity error.
{
{    30 -CM R/W HARDWARE FAULT     The  Control  Module  reported  a
{                                  manual   intervention   code   of
{                                  66(16).
{
{    31 -DRIVE VOLTAGE FAULT       The  Control  Module  reported  a
{                                  manual   intervention   code   of
{                                  67(16).
{
{    32 -OVER TEMPERATURE FAULT    The  Control  Module  reported  a
{                                  manual   intervention   code   of
{                                  6B(16).
{
{    33 -INVALID BOOTSTRAP ERROR   Manual Intervention Status 69(16)
{                                  was reported by the Control
{                                  Module.
{
{    34 -DRIVE WRITE PROTECTED     The  Control  Module  reported  a
{                                  manual   intervention   code   of
{                                  C2(16) indicating that the system
{                                  attempted  to  write on the drive
{                                  but  the  drive's  WRITE  PROTECT
{                                  switch was set.
{
{    35 -INCOMPLETE ICI TRANSFER   The  PP's A-register was non-zero
{                                  after   the   ICI   channel   was
{                                  inactivated    during    a   data
{                                  transfer  and  Poll  Status   was
{                                  normal.   Refer  to  the Residual
{                                  Byte Count below to see how  many
{                                  16-bit bytes were lost.
{
{    36 -LOOPBACK COMPARE ERROR    A  compare  error was detected by
{                                  the  Adapter  when  looping  data
{                                  between   the   Adapter  and  the
{                                  Control Module.
{
{    37 -LOOPBACK SELECT ACTIVE    The select active state  did  not
{                                  drop  when  a  word  sent  to the
{                                  Control Module from  the  Adapter
{                                  had a parity error.
{
{    38 -LOOPBACK ATTENTION        The attention status was not sent
{                                  by the Control Module  after  the
{                                  Adapter sent a word with a parity
{                                  error.
{
{    39 -LOOPBACK CHECK FAILURE    The  Control  Module  failed   to
{                                  report   an  ISI  channel  parity
{                                  error when  the  Adapter  sent  a
{                                  word   with  bad  parity  to  the
{                                  Control Module.
{
{    40 -CONTROL MODULE FAILURE   The failure was isolated to the
{                                 Control Module.
{
{    41 -ADAPTER FAILURE          The failure was isolated to the
{                                 7255-1 adapter.
{
{    42 -DRIVE FAILURE            The failure was isolated to the
{                                 storage device (drive).
{
{    43 -ADAPTER CONTROLWARE ERROR  An error most likely caused by
{                                 the adapter.  Some of the possible
{                                 causes are: wrong status after load
{                                 attention delay, wrong status after
{                                 sending controlware, status asking
{                                 for more data when there is none,
{                                 and status saying the read or write
{                                 command is complete when there is
{                                 more data to transfer.
{
{    44 -PP - ADAPTER DATA INTEGRITY  An interface test transferred
{                                 data between the PP and the adapter.
{                                 No error was detected, but the data
{                                 miscompared.
{
{    45 -PP - DRIVE DATA INTEGRITY  A confidence test wrote data to a
{                                 drive, then read it back.  No error
{                                 was detected, but the data miscompared.
{
{    9.  Request Retry Count      The number of times the PP driver
{                                 retried the  entire  i/o  request
{                                 from the beginning.
{
{    10. Diagnostic Code          Provides  the result of a failing
{                                 diagnostic.
{
{    11. Cylinder number of initial seek
{
{    12. Track number of initial seek
{
{    13. Sector number of initial seek
{
{    14. Cylinder number of failure - This is normally the cylinder
{        number in the disk request.  However, if the failure occurred
{        while running the confidence test, the cylinder number will be
{        815 for an 834 drive and 699 for an 836 drive (the confidence
{        test cylinder).
{
{    15. Track number of failure
{
{    16. Sector number of failure
{
{    17. Residual byte count on incomplete channel transfer
{
{
{    18. Failing Function         The   function  that  caused  the
{                                 initial  recovery  attempt.   The
{                                 value   is   extracted  from  the
{                                 initial detailed  status  if  the
{                                 Adapter provides status after the
{                                 failure.  On a function  timeout,
{                                 the  function reported is the one
{                                 which was  outstanding  when  the
{                                 Adapter hung.
{
{   First-failure Data:
{    19.       Poll Status
{                    (right justified)
{    20 .. 39. Words 1..20 of Detailed Status
{                    (right justified)
{
{    The following failure data is only provided in the
{    cases where the Log-entry Class is unrecovered or
{    intermediate.  The data represents the subsystem
{    status at the end of the intermediate or final
{    request retry.
{
{   Last-failure Data:
{    40.       Poll Status
{                    (right justified)
{    41 .. 60. Words 1..20 of Detailed Status
{                    (right justified)
{

  CONST
    cml$fa7b4_d_failure_data = cmc$min_ecc + 4103;

*copyc cmc$condition_limits
*DECK DECK=CML$ICA_BOARD_NOT_SUPPORTED EXPAND=FALSE
{
{
{   CML$ICA_BOARD_VERSION_NOT_SUPPORTED
{
{   PURPOSE :
{      This log message indicates that the ICA board is not a
{   supported version for the controlware just loaded.  A ROM update
{   was not performed, and the controlware may fail (NOT predictable).
{
{   FREQUENCY :
{      Following a successful load of ICA (if message is applicable).
{
{   CONTENT :
{      The descriptive-data portion of this statistic contains :
{
{      '<mf>.<iou>.<pp>.<channel>.<element>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0),  e.g. 0990, and 'ssss' is the
{        serial number of that processor, e. g. 0104.
{
{      where <iou> is the string 'IOUn' where n is 0 or 1.  This
{        identifies the IOU associated with the channel over which
{        the statistic was reported.
{
{      where <pp> is the string 'PPn' or 'CPPn' where 'n' is the decimal
{        representation of the physical PP number used to process
{        the failing request. The C prefix is used to indicate that
{        the PP is a concurrent PP.
{
{      where <channel> is  the string 'CHn' or 'CCHn' ,
{        where 'n' is the decimal representation of the channel.
{        The C prefix is used to indicate that the channel is
{        a concurrent channel.
{
{      where <element> is the element name of the ICA.
{
{      where <symptom> is the symptom action statement provided
{        by the ICA:
{
{           'ICA Board Model Not Supported'
{
{      The counter-value portion of this statistic contains :
{
{      1.   IOU number/Logical PP number
{           Bits 46 .. 51 = IOU number
{           bit  57       = 1 if concurrent pp
{           Bits 58 .. 63 = logical PP number
{      2.   IOU number/Channel Number of Controller
{           bits 00 .. 15 = channel error status if concurrent pp
{           Bits 46 .. 51 = IOU number
{           bit  57       = 1 if concurrent pp
{           Bits 58 .. 63 = Channel Number of Controller
{      3.   ICA Board Model Number
{      4.   ROM Version on Board

    CONST
       cml$ica_board_not_supported = cmc$min_ecc + 7102;


*copyc cmc$condition_limits
*DECK DECK=CML$ICA_EEPROM_REWRITE_LIMIT EXPAND=FALSE
{
{
{   CML$ICA_EEPROM_REWRITE_LIMIT_REACHED
{
{   PURPOSE :
{      This log message indicates that the EEPROM rewrite limit
{   (10000) has been reached or exceeded.   Further EEPROM rewrites
{   run the risk of failure because of chip failure.  The EEPROM
{   (or ICA) should be replaced in a delayed maintenance action.
{
{   FREQUENCY :
{      Following a successful load of the ICA (if the message is
{   applicable).
{
{   CONTENT :
{      The descriptive-data portion of this statistic contains :
{
{      '<mf>.<iou>.<pp>.<channel>.<element>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0),  e.g. 0990, and 'ssss' is the
{        serial number of that processor, e. g. 0104.
{
{      where <iou> is the string 'IOUn' where n is 0 or 1.  This
{        identifies the IOU associated with the channel over which
{        the statistic was reported.
{
{      where <pp> is the string 'PPn' or 'CPPn' where 'n' is the decimal
{        representation of the physical PP number used to process
{        the failing request. The C prefix is used to indicate that
{        the PP is a concurrent PP.
{
{      where <channel> is  the string 'CHn' or 'CCHn' ,
{        where 'n' is the decimal representation of the channel.
{        The C prefix is used to indicate that the channel is
{        a concurrent channel.
{
{      where <element> is the element name of the ICA.
{
{      where <symptom> is the symptom action statement provided
{        by the ICA:
{
{           'EEPROM Rewrite Limit Reached'
{
{      The counter-value portion of this statistic contains :
{
{      1.   IOU number/Logical PP number
{           Bits 46 .. 51 = IOU number
{           bit  57       = 1 if concurrent pp
{           Bits 58 .. 63 = logical PP number
{      2.   IOU number/Channel Number of Controller
{           bits 00 .. 15 = channel error status if concurrent pp
{           Bits 46 .. 51 = IOU number
{           bit  57       = 1 if concurrent pp
{           Bits 58 .. 63 = Channel Number of Controller
{      3.   Rewrite Count

    CONST
       cml$ica_eeprom_rewrite_limit = cmc$min_ecc + 7104;


*copyc cmc$condition_limits
*DECK DECK=CML$ICA_FAILURE_DATA EXPAND=FALSE
{
{ CML$ICA_FAILURE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record failure data
{    captured by NOS/VE when accessing the ICA.
{
{ FREQUENCY: At occurrence of failure.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<channel>.<element>*<severity>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is the string 'PPn' or 'CPPn' where 'n' is the decimal
{        representation of the physical PP number used to process
{        the failing request. The C prefix is used to indicate that
{        the PP is a concurrent PP.
{
{      where <channel> is  the string 'CHn' or 'CCHn' ,
{        where 'n' is the decimal representation of the channel.
{        The C prefix is used to indicate that the channel is
{        a concurrent channel.
{
{      where <element> is the element name of the ICA being
{        accessed when the failure occurred.
{
{      where <severity> is the string 'UF' for unrecovered, 'RF' for
{        recovered, 'IF' for intermediate failure log-entry, and 'IM'
{        for informative messages.
{
{        The PP reports failure data and diagnostic results  as  an
{        intermediate  failure  log-entry  prior  to retrying an i/o
{        request.  This is due to the fact that retry attempts are
{        not done immediatly but alternately with other I/O queued.
{        An intermediate failure    log-entry   will   provide   the
{        first-failure data captured by the PP  during  the  initial
{        attempt  at  the  request  or  during  a subsequent request
{        retry.
{
{        For  all failures the counter values contain
{        the failure data corresponding  to  the first  unsuccessful
{        try of the i/o request.
{
{      where <symptom> is the symptom/action statement  provided  by
{        the system.
{
{
{    The absence or presence of information in a counter word is
{    determined by the same convention used by other peripheral
{    statistics.  That is if bit 0, (left-most bit) of a counter word,
{    is not set the counter contains a bonafide value. The convention
{    does not apply to detailed status, whose presence  is
{    determined by the length of the statistic.
{    Detailed status is not a function of the ICA hardware but
{    rather the ICA software. As such the length will vary
{    depending on the mode of operation. In OSI mode detailed status
{    is 2 words long and in ICA-I mode detailed status is 3 word long.
{    Again the length of the detailed status field is determained by
{    the length of the statistic. In either case the entire field is
{    valid data.
{
{    The counter-value portion of this statistic contains:
{
{    1.  IOU number/Logical PP number
{        Bits 46 .. 51 = IOU number
{        bit  57       = 1 if concurrent pp
{        Bits 58 .. 63 = logical PP number
{    2.  IOU number/Channel Number of Controller
{        bits 00 .. 15 = channel error status if concurrent pp
{        Bits 46 .. 51 = IOU number
{        bit  57       = 1 if concurrent pp
{        Bits 58 .. 63 = Channel Number of Controller
{    3.  Logical Operation Code
{        1 - write
{        2 - read
{        3 - read_detailed_status
{        4 - queue_previous_message
{        5 - channel_active_timeout
{        6 - read_diagnostic_command
{        7 - status_return
{        8 - read_general_status
{        9 - load_memory
{        10 - enter_idle_state
{        11 - enter_diagnostic_state
{        12 - set_ica_parameters
{        13 - dump_memory
{    4.  Log-entry Class
{        0 - Recovered Failure Report
{        1 - Unrecovered Failure Report
{        2 - Intermediate Failure Report
{        3 - Informative Message
{    5.  Failure Symptom Code (tells what the system thinks is wrong)
{
{        1 - STATE TRANSITION FAILURE - The requested state transition
{            was not honored by the ICA.  The counter STATE TRANSITION
{            indicates to which state transition was requested.  Valid
{            ICA states are, (0 = reset, 1 = diagnostic, 2 = idle, 3 =
{            operational).
{
{        2 - INVALID STATE TRANSITION - The ICA changed states without
{            a change being requested by the PP.  The counters CURRENT
{            STATE and PREVIOUS STATE indicate which state transition
{            occured.  Valid ICA states are, (0 = reset, 1 =
{            diagnostic, 2 = idle, 3 = operational).
{
{        3 - GENERAL STATUS BUSY TIMEOUT - The busy bit in general
{            status did not clear within 100 milliseconds after a read
{            general status function was accepted.  (This timeout is 6
{            seconds following a load memory function).  The counter
{            PREVIOUS FUNCTION contains the last function prior to the
{            busy timeout error.
{
{        4 - RESET BUSY TIMEOUT - The busy bit in general status did
{            not clear within 5 seconds after entering RESET state.
{            This would indicate a phase one on-board diagnostic
{            failure which could not be reported via general status.
{
{        5 - FUNCTION TIMEOUT - ICA did not accept a function (by
{            deactivating the channel) within 100 milliseconds.  TIMED
{            OUT FUNCTION contains the function on which the error
{            occured.
{
{        6 - FUNCTION TIMEOUT CHANNEL ERROR - ICA did not accept a
{            function within 100 milliseconds and the channel error
{            flag was set.  TIMED OUT FUNCTION contains the function
{            on which the error occured.
{
{        7 - INPUT CHANNEL PARITY - On an input from the ICA to PP the
{            channel-error-flag was set.
{
{        8 - OUTPUT CHANNEL PARITY - On an output from the PP to the
{            ICA, the ICA reported a parity error in status but the
{            channel-error-flag was not set.
{
{        9 - IOU OUTPUT PARITY - On an output from PP to ICA both the
{            channel-error-flag and the ICA's status indicated a
{            parity error occurred.
{
{        10 - INDETERMINATE OUTPUT PARITY - On an output from PP to
{             ICA the channel-error-flag was set but there was no
{             error reported by the ICA.  This may mean there is a
{             problem in the IOU and/or the channel and/or the ICA.
{
{        11 - RESET FREQUENCY THRESHOLD - The ICA reset frequency
{             threshold was reached and the ICA has been downed.
{
{        12 - READ DIAGNOSTIC COMMAND MESSAGE CONTENT ERROR - The
{            command read by the read diagnostic message command was
{            not valid.  Only the following hexidecimal values are
{            valid: 1000, 1010, 1020, 1040, and 1050.  The INCORRECT
{            DATA counter contains the data read.
{
{        13 - READ CONFIDENCE TEST MESSAGE CONTENT ERROR - The data
{            read by the read confidence test was not 0AAAA5555(16).
{            The INCORRECT DATA counter contains the data read.
{
{        14 - UNFORMATTED WRITE GENERAL STATUS CONTENT FAILURE - An
{             unformatted write was requested in diagnostic state but
{             the send data bit was not set in general status.
{
{        15 - FORMATTED WRITE GENERAL STATUS CONTENT FAILURE - A
{             formatted write was requested in diagnostic state but
{             the send data bit was not set in general status.
{
{        16 - READ GENERAL STATUS CONTENT FAILURE - A read was
{             requested in diagnostic state but the data available
{             bit was not set in general status.
{
{        17 - ECHO STATUS GENERAL STATUS CONTENT FAILURE - The status
{            returned following a diagnostic command to echo status
{            was not valid.  Two values are valid, they are 0A92A(16)
{            and 5115(16).  The INCORRECT DATA counter contains the
{            data read.
{
{        18 - CHANNEL FULL - The channel did not go empty within one
{             millisecond following a single word write to the ICA
{             during  diagnostic state.
{
{        19 - CHANNEL ACTIVE TIMEOUT FAILURE - The channel remained
{             active more than two seconds during the diagnostic
{             channel active timeout test.
{
{        20 - UNEXPECTED TRANSPARENT FUNCTION - The ICA received a
{             valid but unexpected (out of sequence) transparent
{             function code during diagnostic state.
{
{        21 - FORCED ERROR NOT DETECTED - A forced channel error was
{             not detected by diagnostics.  Either a PP overrun or a
{             input truncated error was expected but did not occur.
{
{        22 - CHANNEL INTERFACE FAILURE - ICA on-board diagnostics
{             detected an error in channel interface logic.  Error
{             could be in ICA board, the ICI channel or cable.
{
{        23 - ICA BOARD FAILURE - ICA on-board diagnostics detected
{             an error in the ICA board itself.
{
{        24 - NO ETHERNET TRANSEIVER POWER - This indicates that
{             either the ICA board has failed or the transeiver power
{             fuse has failed.  This error is detected by ICA on-board
{             diagnostics.
{
{        25 - ETHERNET TRANSEIVER FAILURE - this indicates either a
{             ETHERNET transeiver or transeiver cable failure.  This
{             error is detected by ICA on-board diagnostics.
{
{        26 - CHECKSUM ERROR - Checksum of load data unit failed.
{
{        27 - INVALID TRANSFER ADDRESS - The transfer address in the
{             load data unit is invalid.
{
{        28 - MESSAGE LENGTH VERIFICATION ERROR - The length specified
{            in the header of a message from the ICA doesnt match the
{            size of the record read.  The expected length of the
{            message is contained in counter EXPECTED LENGTH and the
{            actual length in counter ACTUAL LENGTH.  The case were a
{            message is longer than expected is indicated by an actual
{            length value of 80000000(16).
{
{        29 - GENERAL STATUS SEND DATA TIMEOUT - The send data bit in
{             general status was not set within one second of being
{             cleared.
{
{        30 - GENERAL STATUS AVAILABLE TIMEOUT - General status was
{             not available (channel full) within one millisecond of
{             the general status function being accepted. The counter
{             PREVIOUS FUNCTION contains the last function prior to
{             the general status available timeout.
{
{        31 - CHANNEL TIMEOUT - The channel has been active for two
{             seconds without any I/O activity.  The channel was
{             disconnected by the ICA hardware channel active
{             timeout.
{
{        32 - PP OVER RUN - The PP has output more than the 1514
{             maximum length set by the ICA processor in the DMA
{             registers. While writting the ICA configuration
{             this limit is 140 and while sending a loadfile
{             is 256k.
{
{        33 - INPUT TRUNCATED - The PP deactivated the channel before
{             reading the entire message whose length has been set in
{             the DMA registers.  This error is detected by the ICA
{             software.
{
{        34 - FORMATTED OUTPUT ERROR - The ICA failed while formatting
{             data on a formatted write.  This error is detected by
{             the ICA hardware and indicates that an incomplete header
{             record was transmitted by the PP during a formatted
{             write operation.
{
{        35 - ICA DMA CONFIGURATION ERROR - A ICA DMA channel was
{             incorrectly configured when it was started.
{
{        36 - ICA DMA OPERATION TIMING ERROR - The ICA software tried
{             to write to a ICA DMA register after the DMA channel had
{             started.
{
{        37 - ICA DMA COUNT ERROR - A ICA DMA channel was started with
{             a channel count of zero.
{
{        38 - ICA DMA EXTERNAL ABORT - A bus error or a hardware abort
{             was sent to the ICA DMA by the ICA hardware.
{
{        39 - ICA DMA SOFTWARE ABORT - The ICA software set the
{             software abort bits in the DMA channel control register.
{
{        40 - INVALID DATA PACKET - The data sent with the last
{             function was not of the proper size.  This error is
{             detected by the ICA software by comparing the length
{             specified in the message header with the length of the
{             message actually written.
{
{        41 - SYSTEM ADDRESS ERROR - The system address defined in the
{             configuration data packet sent to the ICA contained an
{             invalid system address (least significant bit non zero).
{
{        42 - MULTICAST ADDRESS ERROR - The multicast address defined
{             in the configuration data packet sent to the ICA
{             contained an invalid multicast address (least
{             significant bit zero).
{
{        43 - QUEUE LENGTH ERROR - The ETHERNET output queue length
{             contained in the configuration packet sent to the ICA is
{             invalid.
{
{        44 - INVALID STATISTICS TYPE - The statistic type contained
{             in the configuration packet sent to the ICA is invalid.
{
{        45 - INVALID THRESHOLDS - The single bit thresholds received
{             in the configuration packet sent to the ICA are invalid.
{
{        46 - INVALID REPORTING INTERVAL - The reporting interval
{             requested in the configuration packet sent to the ICA is
{             invalid.
{
{        47 - CHANNEL EMPTY - The channel did not go full within one
{             millisecond following the ICA's acceptance of a function
{             which was to be followed by an input operation.
{
{        48 - CHANNEL INACTIVE - The channel was inactive following a
{             write operation and no general status errors were
{             indicated.
{
{        49 - ICA RESET - The ICA was reset and phase one of the
{             on-board diagnostics completed.  General status will
{             include the reset reason.
{
{        50 - ICA NOT READY TIMEOUT - The ICA did not reach
{             operational state within twenty seconds of a reset.
{
{        51 - ICA OPERATIONAL - The ICA has entered operational state.
{
{        52 - INCOMPLETE TRANSFER - The input/output operation did not
{             complete as indicated by the PP's A register being non
{             zero.  However the channel remained active and no
{             general status or channel errors were indicated.
{
{        53 - MISMATCH HARDWARE TYPE - The ICA hardware model type does
{             not match with that defined in NAM/VE logical configuration.
{
{        54 - GENERAL STATUS REJECT - During diagnostic testing a general
{             status ws not rejected as expected.
{
{        55 - INDETERMINATE (channel or ICA or ethernet) General
{             status indicates an error but detailed status could not
{             be obtained or did not contain values which could be
{             decoded to one of the preceding errors.
{
{        56 - CHANNEL PROTOCOL NOT SUPPORTED - the version of channel
{             protocol supported by the ICA and NOS/VE are not compatible.
{             DETAILED STATUS contains the highest channel protocol supported
{             by the ICA(counter 16 bits 48 .. 55). The counter CHANNEL PROTOCOL
{             contains the highest channel protocol supported by NOS/VE.
{
{        57 - INVALID FLOW CONTROL - The flow control value indicated in
{             general status (counter 15 bits 61 - 63) is invalid. Valid
{             flow control values are (0 = normal flow control off,
{             1 = normal flow control on).
{
{        58 - MAXIMUM SIZE EXCEEDED - The message length indicated in the
{             record header is greater than the maximum size allowed.
{             Actual Length will contain the length of the record.
{
{        59 - ETHERNET ADDRESS CHECKSUM ERROR - The checksum transfered
{             with the system address is incorrect.
{
{        60 - WRITE LENGTH ERROR - The length of the record received
{             by the ICA did not match the length indicated in the
{             headers.
{
{        61 - ICA MEMORY PARITY ERROR - An ICA memory parity error was
{             detected on the Input/Output operation.
{
{        62 - ICA MEMORY ADDRESS ERROR - An ICA memory address error
{             was detected on the Input/Output operation. This error
{             could indicate an ICA software problem.
{
{    6. Request Retry Count - The number of times the PP driver
{       retried the i/o request. (0..3)
{
{    7. Timed Out Function - The function which caused a function
{       timeout. (0 .. 0ffff(16))
{
{    8. Previous Function - The function executed prior to a general
{       status busy timeout error. (0 .. 0ffff(16))
{
{    9. Incorrect Data - Data read if verification error.
{       (0 .. 0ffffffff(16))
{
{    10. State Transition - if state transition error.  Valid ICA
{        states are (0 = reset, 1 = diagnostic, 2 = idle, 3 =
{        operational).
{
{    11. Current State - If invalid state transition error.
{        Valid states are (0 = reset, 1 = diagnostic, 2 = idle, 3 =
{        operational).
{
{    12. Previous State - If invalid state transition error.
{        Valid states are (0 = reset, 1 = diagnostic, 2 = idle, 3 =
{        operational).
{
{    13. Expected Length - If error is message length
{        verification error. (0 .. 0ffffffff(16))
{
{    14. Actual Length - If error is message length
{        verification error. (0 .. 0ffffffff(16))
{
{    15.  General Status.  General status is always returned if
{        available. (0 .. 0ffff(16))
{
{    16 .. 18 Detailed Status.  Detailed status is always returned if
{        the ICA is operational and detailed status can be obtained.
{        See note above concerning the length of this feild.
{

  CONST
    cml$ica_failure_data = cmc$min_ecc + 7000;

*copyc cmc$condition_limits

*DECK DECK=CML$ICA_LAST_RESET_INFORMATION EXPAND=FALSE
{
{
{   CML$ICA_LAST_RESET_INFORMATION
{
{   PURPOSE :
{     This log message contains information on the last ICA reset.
{   If multiple resets occur before this message is delivered to the
{   PP, this message will only contain information concerning the first
{   reset.
{
{   FREQUENCY :
{      Following a successful load of the ICA.
{
{   CONTENT :
{      The descriptive-data portion of this statistic contains :
{
{      '<mf>.<iou>.<pp>.<channel>.<element>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0),  e.g. 0990, and 'ssss' is the
{        serial number of that processor, e. g. 0104.
{
{      where <iou> is the string 'IOUn' where n is 0 or 1.  This
{        identifies the IOU associated with the channel over which
{        the statistic was reported.
{
{      where <pp> is the string 'PPn' or 'CPPn' where 'n' is the decimal
{        representation of the physical PP number used to process
{        the failing request. The C prefix is used to indicate that
{        the PP is a concurrent PP.
{
{      where <channel> is  the string 'CHn' or 'CCHn' ,
{        where 'n' is the decimal representation of the channel.
{        The C prefix is used to indicate that the channel is
{        a concurrent channel.
{
{      where <element> is the element name of the ICA.
{
{      where <symptom> is the symptom action statement provided
{        by the ICA:
{
{           'Last Reset Information'
{
{      The counter-value portion of this statistic contains :
{
{      1.   IOU number/Logical PP number
{           Bits 46 .. 51 = IOU number
{           bit  57       = 1 if concurrent pp
{           Bits 58 .. 63 = logical PP number
{      2.   IOU number/Channel Number of Controller
{           bits 00 .. 15 = channel error status if concurrent pp
{           Bits 46 .. 51 = IOU number
{           bit  57       = 1 if concurrent pp
{           Bits 58 .. 63 = Channel Number of Controller
{      3.   S/W Reset Reason Code
{
{         This  code represents the software reason that resulted in a
{         reset (if applicable).  All of these errors are captured  by
{         the controlware.
{
{         ICA-1  ICA-2
{         -----  -----
{           0      0   -  Non-SW reset reason (nothing saved in first 22 counters)
{           1      1   -  Deadman Timeout
{           2      2   -  Bus Error from CPU
{           3      3   -  Address Error from CPU
{           4      4   -  Illegal Instruction Error
{           5      5   -  Zero Divide
{           6     N/A  -  Double-bit Parity Error
{           7      7   -  Unrecoverable DMA Error
{           8      8   -  Unrecoverable Ethernet Error
{           9      9   -  Reset Function
{          10     N/A  -  Byte Write
{          11     11   -  General S/W Error
{          12     12   -  Transceiver Power Failure
{          N/A    13   -  Parity Error
{
{         Note  that Reason Code 6 can be from an ethernet controller,
{         DMA  controller,  or  CPU  memory  access.    The   "address
{         accessed" field will have to be the guide here.  The program
{         counter will only be helpful on a CPU double-bit error.
{
{      4.  MC68000 Status Register
{
{         This is the 16-bit status register value at the time of  the
{         interrupt  that  resulted  in  the  reset.  This register is
{         defined in the Motorola 68000 User's Manual.
{
{      5.  MC68000 Register State
{
{         This group of counters (17 counters) contains  all  the  ICA
{         processor's  registers  at  the  time  of the interrupt that
{         resulted in the reset.  They are  listed  in  the  following
{         order :
{
{           - 32-bit Program Counter
{           - 8 32-bit Data Registers D0 - D7
{           - 8 32-bit Address Registers A0 - A7
{
{         A6  will  always  point  to  the  beginning  of the register
{         storage area of the failure management table in  memory.   It
{         is not used elsewhere in the program.
{
{      22. Address Being Accessed
{
{         This is the 32-bit address being accessed at the time of the
{         interrupt.  This value may not always be applicable in which
{         case it will be 0.
{
{      23.  Diagnostic Status Table (DST) -- Reset Code
{
{           1 - Power On
{           2 - PP Master Clear
{           3 - Deadman Timeout
{           4 - Master Clear Switch
{           5 - Reset Function from PP
{           6 - MC68010 Reset Instruction
{
{           If multiple resets occurred since this message was last
{           sent, this counter represents the first reset that occurred.
{
{      24.  DST -- # of Resets since this message was last sent.
{
{      25.  DST -- Failure Code
{
{           0100(16) - Deadman Timer doesn't time out.
{           0200(16) - The address capture registers won't load
{                      properly.
{           0300(16) - Single-bit error(s) occurred while testing
{                      D/SRAM.
{           0400(16) - Transient multibit error(s) occurred during
{                      nondestructive D/SRAM testing.
{           0500(16) - Single-bit error(s) occurred during EEPROM
{                      checksum test.  EEPROM should be rewritten
{                      be ICA software.
{           0600(16) - A channel parity error was detected on a
{                      function.
{           0700(16) - A channel parity error was detected on a PP
{                      output operation.
{           0800(16) - A channel active timeout occurred during the
{                      CHANNEL ACTIVE TIMEOUT CHECK.
{
{      26.  DST -- # of Occurrences of this failure since this message
{           was last sent.
{
{      27.  DST -- Failure Code (As Above)
{
{      28.  DST -- # of Occurrences
{
{      29. - 40.  Failure Code /# of Occurrences Pairs
{
{      Counters  25  - 40 are optional; they will only be used if
{      the diagnostics encountered any of the errors listed during
{      their processing.   The counters not used will not be sent.

    CONST
       cml$ica_last_reset_information = cmc$min_ecc + 7103;


*copyc cmc$condition_limits
*DECK DECK=CML$ICA_STATISTICS EXPAND=FALSE
{
{   CML$ICA_STATISTICS
{
{   PURPOSE :
{      This message contains the statistics maintained by the ICA
{   software.  Two levels of statistics may be reported; a symptom
{   code will indicate which type is being sent.
{
{   FREQUENCY :
{      At the interval configured by the last SET ICA PARAMETERS
{   function issued by the PP.
{
{   CONTENT :
{      The descriptive-data portion of this statistic contains :
{
{      '<mf>.<iou>.<pp>.<channel>.<element>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0),  e.g. 0990, and 'ssss' is the
{        serial number of that processor, e. g. 0104.
{
{      where <iou> is the string 'IOUn' where n is 0 or 1.  This
{        identifies the IOU associated with the channel over which
{        the statistic was reported.
{
{      where <pp> is the string 'PPn' or 'CPPn' where 'n' is the decimal
{        representation of the physical PP number used to process
{        the failing request. The C prefix is used to indicate that
{        the PP is a concurrent PP.
{
{      where <channel> is  the string 'CHn' or 'CCHn' ,
{        where 'n' is the decimal representation of the channel.
{        The C prefix is used to indicate that the channel is
{        a concurrent channel.
{
{      where <element> is the element name of the ICA.
{
{      where <symptom> is the symptom action statement provided
{        by the ICA:
{
{           'ICA Statistics'
{
{      The counter-value portion of this statistic contains :
{
{      1.   IOU number/Logical PP number
{           Bits 46 .. 51 = IOU number
{           bit  57       = 1 if concurrent pp
{           Bits 58 .. 63 = logical PP number
{      2.   IOU number/Channel Number of Controller
{           bits 00 .. 15 = channel error status if concurrent pp
{           Bits 46 .. 51 = IOU number
{           bit  57       = 1 if concurrent pp
{           Bits 58 .. 63 = Channel Number of Controller
{      3.   Symptom Code
{
{           1 - Summary Statistics Follow.
{           2 - Detail Statistics Follow.
{
{      4.   Time interval in seconds  over  which  the  statistics
{           being sent have been maintained.
{      5.   Messages  received  at  the ethernet interface with no
{           errors.
{      6.   Messages received at the ethernet  interface  with  an
{           error  and discarded.  (Sum of detailed statistics 15 - 18, 45).
{      7.   Number of messages transmitted.
{      8.   Number of messages retransmitted.
{      9.   Output messages which could not be transmitted due  to
{           excessive errors.
{      10.  # of characters received on ethernet
{      11.  # of characters transmitted on ethernet
{      12.  #  of  all  ethernet  related  errors (Sum of detailed
{           statistics 15 - 22, 45, 46).
{      13.  #  of  all  ICA  transient  errors  (Sum  of  detailed
{           statistics 43 and 44.)
{      14.  #  of all ICI interface errors (Number of times the CE
{           bit set in the general status.)
{      15.  # of CRC errors on received frames
{      16.  # of alignment errors on received frames
{      17.  # of resource errors on received frames.
{      18.  # of over runs
{      19.  # of collisions
{      20.  # of frames exceeding collision threshold
{      21.  # of transmissions aborted with no clear to send
{      22.  # of transmissions aborted with no carrier sense
{      23.  Average length of message transmitted across the ethernet
{           in bytes.
{      24.  Number of messages transmitted across ethernet with lengths
{           in the range of 0 thru 100 (inclusive).
{      25.  Number of messages transmitted across ethernet with lengths
{           in the range of 101 thru 300 (inclusive).
{      26.  Number of messages transmitted across ethernet with lengths
{           in the range of 301 thru 500 (inclusive).
{      27.  Number of messages transmitted across ethernet with lengths
{           in the range of 501 thru 700 (inclusive).
{      28.  Number of messages transmitted across ethernet with lengths
{           in the range of 701 thru 900 (inclusive).
{      29.  Number of messages transmitted across ethernet with lengths
{           in the range of 901 thru 1100 (inclusive).
{      30.  Number of messages transmitted across ethernet with lengths
{           in the range of 1101 thru 1300 (inclusive).
{      31.  Number of messages transmitted across ethernet with lengths
{           in the range greater than or equal to 1301.
{      32.  Average length of messages received from ethernet (in bytes)
{      33.  Number of messages received across ethernet with lengths
{           in the range of 0 thru 100 (inclusive).
{      34.  Number of messages received across ethernet with lengths
{           in the range of 101 thru 300 (inclusive).
{      35.  Number of messages received across ethernet with lengths
{           in the range of 301 thru 500 (inclusive).
{      36.  Number of messages received across ethernet with lengths
{           in the range of 501 thru 700 (inclusive).
{      37.  Number of messages received across ethernet with lengths
{           in the range of 701 thru 900 (inclusive).
{      38.  Number of messages received across ethernet with lengths
{           in the range of 901 thru 1100 (inclusive).
{      39.  Number of messages received across ethernet with lengths
{           in the range of 1101 thru 1300 (inclusive).
{      40.  Number of messages received across ethernet with lengths
{           in the range greater than or equal to 1301.
{      41.  single-bit SECDED parity errors
{      42.  ICA Congestion -- This counter  is  incremented  each
{           time  the  buffer  usage for messages coming from the
{           ethernet interface reaches 90%.  The counter is  only
{           incremented  once  per occurrence.  Therefore, if the
{           ICA  is  congested  during   the   entire   reporting
{           interval,  this  counter  will have a value of 1.  An
{           occurrence lasts until the  number  of  free  buffers
{           falls to 50% of the total.
{      43.  # of ethernet controller errors (recovered w/o reset)
{      44.  # of dma controller errors (recovered w/o reset)
{      45.  # of length errors on ethernet received frames.
{      46.  # of underruns on frame transmissions.
{
{** Counters 15 - 46 are only sent if this message represents a Detail
{   Statistics Packet.

    CONST
       cml$ica_statistics = cmc$min_ecc + 7105;


*copyc cmc$condition_limits
*DECK DECK=CML$ICA_THRESHOLD_REACHED EXPAND=FALSE
{
{
{   CML$ICA_THRESHOLD_REACHED
{
{   PURPOSE :
{      This log message indicates that one of the non-fatal thresholds
{   configured by the SET_ICA_PARAMETERS function has been met.
{
{   FREQUENCY :
{      At occurrence of threshold.
{
{   CONTENT :
{      The descriptive-data portion of this statistic contains :
{
{      '<mf>.<iou>.<pp>.<channel>.<element>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0),  e.g. 0990, and 'ssss' is the
{        serial number of that processor, e. g. 0104.
{
{      where <iou> is the string 'IOUn' where n is 0 or 1.  This
{        identifies the IOU associated with the channel over which
{        the statistic was reported.
{
{      where <pp> is the string 'PPn' or 'CPPn' where 'n' is the decimal
{        representation of the physical PP number used to process
{        the failing request. The C prefix is used to indicate that
{        the PP is a concurrent PP.
{
{      where <channel> is  the string 'CHn' or 'CCHn' ,
{        where 'n' is the decimal representation of the channel.
{        The C prefix is used to indicate that the channel is
{        a concurrent channel.
{
{      where <element> is the element name of the ICA.
{
{      where <symptom> is the symptom action statement provided
{        by the ICA:
{
{           'Threshold Reached'
{
{      The counter-value portion of this statistic contains :
{
{      1.   IOU number/Logical PP number
{           Bits 46 .. 51 = IOU number
{           bit  57       = 1 if concurrent pp
{           Bits 58 .. 63 = logical PP number
{      2.   IOU number/Channel Number of Controller
{           bits 00 .. 15 = channel error status if concurrent pp
{           Bits 46 .. 51 = IOU number
{           bit  57       = 1 if concurrent pp
{           Bits 58 .. 63 = Channel Number of Controller
{      3.   Symptom Code
{
{           ICA-1  ICA-2
{           -----  -----
{             1     1  - CRC Threshold -- The CRC error threshold for messages
{                        received from the ethernet has been reached.
{
{             2     2  - Retransmission Threshold -- The threshold for retrans-
{                        missions at the ethernet interface has been reached.
{                        This message indicates that the ethernet media is
{                        very busy.
{
{             3    N/A - Single-Bit Error Threshold -- The threshold for
{                        single-bit memory parity errors has been reached.
{                        This threshold indicates that a higher than normal
{                        number of single-bit errors have occurred.  The memory
{                        on the ICA board MAY be going bad.
{
{             4    N/A - Single-Bit Detection Threshold -- The single-bit
{                        memory parity error detection has been turned off because
{                        this threshold was met.  The detection will remain off
{                        until the ICA is reset.  The purpose of turning off
{                        single-bit error detection with this threshold is to
{                        prevent high numbers of parity errors from affecting
{                        the ICA performance.
{
{      4.   Threshold Value -- Number of occurrences of the event indicated
{           by the symptom code.
{
{      5.   Time Interval -- Time interval, measured by packets processed, over
{           which the threshold is determined.  For example, if the threshold
{           is defined as two CRC errors per 1000 messages processed, this
{           field would equal 1000 or less (ie. the actual number processed
{           when the threshold was met).

    CONST
       cml$ica_threshold_reached = cmc$min_ecc + 7101;


*copyc cmc$condition_limits
*DECK DECK=CML$ICA_TRANSIENT_FAILURE EXPAND=FALSE
{
{
{   CML$ICA_TRANSIENT_FAILURE
{
{   PURPOSE :
{      This statistic indicates that a transient hardware failure occurred
{   on the ICA.  A recovery action was taken by the ICA software.
{
{   FREQUENCY :
{      At occurrence of failure.
{
{   CONTENT :
{      The descriptive-data portion of this statistic contains :
{
{      '<mf>.<iou>.<pp>.<channel>.<element>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0),  e.g. 0990, and 'ssss' is the
{        serial number of that processor, e. g. 0104.
{
{      where <iou> is the string 'IOUn' where n is 0 or 1.  This
{        identifies the IOU associated with the channel over which
{        the statistic was reported.
{
{      where <pp> is the string 'PPn' or 'CPPn' where 'n' is the decimal
{        representation of the physical PP number used to process
{        the failing request. The C prefix is used to indicate that
{        the PP is a concurrent PP.
{
{      where <channel> is  the string 'CHn' or 'CCHn' ,
{        where 'n' is the decimal representation of the channel.
{        The C prefix is used to indicate that the channel is
{        a concurrent channel.
{
{      where <element> is the element name of the ICA.
{
{      where <symptom> is the symptom action statement provided
{        by the ICA:
{
{           'Transient Failure'
{
{      The counter-value portion of this statistic contains :
{
{      1.   IOU number/Logical PP number
{           Bits 46 .. 51 = IOU number
{           bit  57       = 1 if concurrent pp
{           Bits 58 .. 63 = logical PP number
{      2.   IOU number/Channel Number of Controller
{           bits 00 .. 15 = channel error status if concurrent pp
{           Bits 46 .. 51 = IOU number
{           bit  57       = 1 if concurrent pp
{           Bits 58 .. 63 = Channel Number of Controller
{      3.   Failure Type
{             1 - Ethernet Controller
{      4.   Program counter at the time of this log message generation.
{           This value is actually the program counter minus the load
{           address (currently = 10000H).  This value can be used with a
{           listing to isolate where the error was detected within the
{           program thereby making the error indication more specific.

    CONST
       cml$ica_transient_failure = cmc$min_ecc + 7100;

*copyc cmc$condition_limits
*DECK DECK=CML$ICA_USAGE_DATA EXPAND=FALSE
{
{ CML$ICA_USAGE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record usage data
{    recorded by NOS/VE when accessing the ICA.
{
{ FREQUENCY: At a minimum of thirty minute interval.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<channel>.<element>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is the string 'PPn' or 'CPPn' where 'n' is the decimal
{        representation of the physical PP number used to process
{        the failing request. The C prefix is used to indicate that
{        the PP is a concurrent PP.
{
{      where <channel> is  the string 'CHn' or 'CCHn' ,
{        where 'n' is the decimal representation of the channel.
{        The C prefix is used to indicate that the channel is
{        a concurrent channel.
{
{      where <element> is the element name of the ICA being
{        accessed when the failure occurred.
{
{      where <symptom> is the symptom/action statement  provided  by
{        the system.
{
{    The counter-value portion of this statistic contains:
{
{    1.  IOU number/Logical PP number
{        Bits 46 .. 51 = IOU number
{        bit  57       = 1 if concurrent pp
{        Bits 58 .. 63 = logical PP number
{    2.  IOU number/Channel Number of Controller
{        bits 00 .. 15 = channel error status if concurrent pp
{        Bits 46 .. 51 = IOU number
{        bit  57       = 1 if concurrent pp
{        Bits 58 .. 63 = Channel Number of Controller
{    3.  Bytes Read - The number of bytes read since the last
{        Usage Data statistic was sent. (0 .. 0ffffffff(16))
{    4.  Bytes Written - The number of bytes written since the last
{        Usage Data statistic was sent. (0 .. 0ffffffff(16))
{

  CONST
    cml$ica_usage_data = cmc$min_ecc + 7003;

*copyc cmc$condition_limits

*DECK DECK=CML$IOU_FAILURE_DATA EXPAND=FALSE
{
{ CML$IOU_FAILURE_DATA
{
{
{ PURPOSE:
{    This statistic records the failure data captured by the system
{ following corrected or uncorrected IOU errors.
{
{ FREQUENCY: Each time DFT enters data into the maintenance
{            register buffers following each failure occurrence.
{
{ CONTENT:
{
{    The descriptive-data portion of this statistic contains:
{
{    '<mf>.<element>*<product id>*<serial number>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0) and 'ssss' is the serial
{        number of that processor.
{
{      where <element> is the name IOU0, for IOU zero, IOU1 for
{        IOU1, etc.
{
{      where <product id> is the model number from the iou's
{        element identification register.
{
{      where <serial number> is the serial number from the
{        IOU's element identification register.
{
{      where <symptom> is the symptom/action statement provided
{        by the system. The text of the possible symptom statements
{        is identical in content to the uppercase text described
{        under counter value 2 below.
{
{    The counter-value portion of this statistic contains:
{
{    1. Operating System (OS) action code as described in section
{       4.2 of the DFT/OS Interface Specification. (DCS # ARH6853)
{
{    2. This word contains a 12-bit DFT analysis code followed by
{       an 8-bit sequence number stored in bits 44-63 of the word.
{       The sequence number indicates the sequential order in which
{       a series of statistics occurred, and ranges from 0-255(10).
{       Dedicated Fault Tolerance (DFT) analysis code is described
{       in section 4.4 of the DFT/OS Interface Specification. The
{       failure data should be analyzed in the order in which the
{       following codes are presented. (It should also be noted
{       that if bit 12 of the 12-bit hexadecimal DFT analysis code
{       is set, the error has occurred more than one time but is
{       being reported only once; e.g. code 003 will become 803.)
{
{       001 DEADSTART ERROR LOG IOU ERROR.
{       006 FATAL IOU ERROR (NIO; NOT PP HALT).
{       008 FATAL IOU ERROR (CIO; NOT PP HALT).
{       004 UNCORRECTED IOU ERROR (NIO PP HALT).
{       009 UNCORRECTED IOU ERROR (CIO PP HALT).
{       003 CORRECTED IOU ERROR (I4 ONLY).
{       007 IOU CHANNEL ERROR (NIO PP).
{       00B IOU CHANNEL ERROR (CIO PP).
{       005 12/16 IOU CONVERSION ERROR (NIO PP).
{       00A 12/16 IOU CONVERSION ERROR (CIO PP).
{
{     The content of words 3-63 is model dependent based upon
{     the DFT error analysis code. Packets of 5 words, each
{     consisting of a header word followed by the contents of 4
{     maintenance registers are stored sequentially. The header
{     word consists of 4 16-bit maintenance register addresses
{     stored from left to right that specify which register
{     contents are stored in the following four words. Sections
{     4.5.7 (code 3001), 4.5.2 (Codes 3007,3006,3004,2005), and
{     4.5.1 (Code 2003) of the DFT/OS Interface Specification
{     defines the maintenance registers and the order in which
{     their contents are stored for IOU errors.
{
  CONST
    cml$iou_failure_data = cmc$min_ecc + 1002;

*copyc cmc$condition_limits
*DECK DECK=CML$IOU_IDENTIFICATION EXPAND=FALSE
{
{ CML$IOU_IDENTIFICATION
{
{
{ PURPOSE:
{    This statistic provides the identification of an IOU on the
{ mainframe being initialized.  This statistic is emitted when the
{ configuration is activated during each system initialization.
{
{ FREQUENCY: At each system initialization, once for each IOU.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<element>*<product identification>*<serial number>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where <element> is the name IOU0, for IOU zero, IOU1, for IOU
{        one, etc.
{
{      where <product identification> is the model number from the
{        IOU's identification register.
{
{      where  <serial  number> is the serial number from the
{        IOU's identification register.
{
{    The counter-value portion of this statistic is unused.
{

  CONST
    cml$iou_identification = cmc$min_ecc + 4;

*copyc cmc$condition_limits
*DECK DECK=CML$IVB_FAILURE_DATA EXPAND=FALSE
{
{ CML$IVB_FAILURE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record failure data
{    captured by NOS/VE when accessing the IVB.
{
{ FREQUENCY: At occurrence of failure.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<channel>.<element>*<severity>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is the string 'PPn' or 'CPPn' where 'n' is the decimal
{        representation of the physical PP number used to process
{        the failing request. The C prefix is used to indicate that
{        the PP is an I4 concurrent PP.
{
{      where <channel> is  the string 'CHn' or 'CCHn' ,
{        where 'n' is the decimal representation of the channel.
{        The C prefix is used to indicate that the channel is
{        an I4 concurrent channel.
{
{      where <element> is the element name of the IVB being
{        accessed when the failure occurred.
{
{      where <severity> is the string 'UF' for unrecovered, 'RF' for
{        recovered, 'IF' for intermediate failure log-entry, and 'IM'
{        for informative messages.
{
{        The PP reports failure data and diagnostic results  as  an
{        intermediate  failure  log-entry  prior  to retrying an i/o
{        request.  This is due to the fact that retry attempts are
{        not done immediatly but alternately with other I/O queued.
{        An intermediate failure    log-entry   will   provide   the
{        first-failure data captured by the PP  during  the  initial
{        attempt  at  the  request  or  during  a subsequent request
{        retry.
{
{        For  all failures the counter values contain
{        the failure data corresponding  to  the first  unsuccessful
{        try of the i/o request.
{
{      where <symptom> is the symptom/action statement  provided  by
{        the system.
{
{
{    The absence or presence of information in a counter word is
{    determined by the same convention used by other peripheral
{    statistics.  That is if bit 0, (left-most bit) of a counter word,
{    is not set the counter contains a bonafide value.
{
{    The counter-value portion of this statistic contains:
{
{    1.  IOU number/Logical PP number
{        Bits 46 .. 51 = IOU number
{        bit  57       = 1 if concurrent pp
{        Bits 58 .. 63 = logical PP number
{    2.  IOU number/Channel Number of Controller
{        bits 00 .. 15 = channel error status if concurrent pp
{        Bits 46 .. 51 = IOU number
{        bit  55       = 1 if I4 concurrent channel port A
{        bit  56       = 1 if I4 concurrent channel port B
{        bit  57       = 1 if concurrent pp
{        Bits 58 .. 63 = Channel Number of Controller
{    3.  Reserved for future use
{    4.  Log-entry Class
{        0 - Recovered Failure Report
{        1 - Unrecovered Failure Report
{        2 - Intermediate Failure Report
{        3 - Informative Message
{    5.  Failure Symptom Code (tells what the system thinks is wrong)
{
{         1  - FUNCTION   TIMEOUT  ERROR:  This  error  indicates  that  a
{              function timeout has occured.
{
{         2  - CHANNEL EMPTY: This error indicates that  the  IPI  channel
{              did not force the channel full when it was activated.
{
{         3  - PERIOD COUNTER PARITY: This is bit 51 of  the  IPI  channel
{              error register.
{
{         4  - UPPER  ICI  PARITY: This is bit 57 of the IPI channel error
{              register and indicates that a parity error has occurred  on
{              the  most  significant  byte of the channel between the IPI
{              chip and the PP.
{
{         5  - LOWER ICI PARITY: This is bit 58 of the IPI  channel  error
{              register  and  indicates a parity error has occurred on the
{              least significant byte of the channel between the IPI  chip
{              and the PP.
{
{         6  - IOU ERROR: This error indicates that the channel error flag
{              is set and none of  the  bits  in  the  IPI  channel  error
{              register or I4 IPI DMA error register are set.
{
{         7  - INCOMPLETE  TRANSFER:  This  error  indicates that the PP's
{              word count was nonzero after an I/O operation.
{
{         8  - CHANNEL NOT EMPTY: This error indicates  that  the  the  I4
{              channel  did  not  go  empty  after the output of parameter
{              words.
{
{         9  - CENTRAL MEMORY ERROR: This indicates that bit 50 or bit  51
{              of  the  I4  IPI  DMA  error  register  is  set and that an
{              uncorrected or reject  error  response  was  received  from
{              central memory.
{
{         10 - INVALID  CM RESPONSE CODE: This is bit 52 of the I4 IPI DMA
{              error register and indicates the response code from central
{              memory decoded into an illegal value.
{
{         11 - CM RESPONSE CODE PARITY ERROR: This is bit 53 of the I4 IPI
{              DMA error register and indicates  that  the  response  code
{              from central memory had a parity error.
{
{         12 - CMI  READ  DATA  PARITY ERROR: This is bit 54 of the I4 IPI
{              DMA error register and indicates that  the  central  memory
{              interface logic has detected a read data parity error.
{
{         13 - JY  DATA  ERROR:  This  is  bit  59 of the I4 IPI DMA error
{              register and indicates that the JY  board  has  detected  a
{              data parity error.
{
{         14 - BAS  PARITY  ERROR:  This is bit 60 of the I4 IPI DMA error
{              register and indicates that the LX  board  has  detected  a
{              parity error on data received from the barrel and  slot  of
{              the PP.
{
{         15 - LZ  ERROR:  This is bit 61 of the I4 IPI DMA error register
{              and indicates that the LZ board has detected an error.
{
{         16 - JY ERROR: This is bit 62 of the I4 IPI DMA  error  register
{              and indicates that the JY board has detected an error.
{
{         17 - LX  ERROR:  This is bit 63 of the I4 IPI DMA error register
{              and indicates that the LX board has detected an error.
{
{         20 - CANT SELECT: This error indicates that The  SLAVE  IN  line
{              was not set after the PP sent the select code to the IVB.
{
{         21 - BIT  SIGNIFICANT  RESPONSE ERROR: This error indicates that
{              the bit significant response which is in bits 56-63 of  the
{              IPI channel status register is incorrect.
{
{         22 - NO SYNC IN: This error indicates that During a bus  control
{              sequence SYNC IN did not set.
{
{         23 - SYNC  IN  DID  NOT DROP: This error indicates that During a
{              bus control sequence SYNC IN did not drop.
{
{         24 - IPI SEQUENCE ERROR: This is bit 59 of the IPI channel error
{              register  and  indicates  an  illegal  sequence  of control
{              signals has occurred on the IPI interface.
{
{         25 - UPPER IPI CHANNEL PARITY: This is bit 60 of the IPI channel
{              error  register  and  indicates  that  the  IPI channel has
{              detected a parity error on bus A of the IPI interface.
{
{         26 - LOWER IPI CHANNEL PARITY: This is bit 61 of the IPI channel
{              error  register  and  indicates  that  the  IPI channel has
{              detected a parity error on bus B of the IPI interface.
{
{         27 - SLAVE IN NOT SET:  This  error  indicates  that  during  an
{              ending  status  sequence  or  a  request  transfer settings
{              sequence SLAVE IN did not set.
{
{         28 - SLAVE IN DID NOT DROP: This error indicates that  During  a
{              deselect  sequence  or a command transfer sequence SLAVE IN
{              did not drop.
{
{         29 - CHANNEL ERROR: This error indicates that the channel  error
{              flag was set after reading the IPI or DMA registers.
{
{         30 - CHANNEL STAYED ACTIVE: This error indicates that  following
{              an information exchange the IVB did not drop SLAVE IN.  The
{              IVB drops SLAVE IN when the last word has been  transferred
{              or  if no words have been transferred for its timeout limit
{              of about 26 milliseconds.
{
{         31 - BUFFER COUNTER PARITY: This is bit 48 of  the  IPI  channel
{              error register.
{
{         32 - SYNC  COUNTER  PARITY:  This  is  bit 50 of the IPI channel
{              error register.
{
{         33 - LOST DATA:  This  is  bit  56  of  the  IPI  channel  error
{              register.   It indicates that the IVB ended a data transfer
{              and the IPI channel's buffer is not empty.
{
{         34 - BUS PARITY: This is bit 58 of ending status  received  from
{              the IVB.  It indicates that the IVB detected a parity error
{              on the IPI interface.
{
{         35 - COMMAND REJECT: This is reported in bits  60-63  of  ending
{              status  received from the IVB.  If a value of 2, 3, 6, or 8
{              is in these bits, the IVB has rejected the command sent  by
{              the PP.
{
{         36 - SYNC  OUT NOT EQ SYNC IN: This is reported in bits 60-63 of
{              ending status received from the IVB.  If these bits have  a
{              value  of 9, the IVB's SYNC OUT count and its SYNC IN count
{              were not equal when the transfer ended.
{
{         37 - BUS B ACK INCORRECT: This error indicates that during a bus
{              control sequence bus B received from the IVB was nonzero.
{
{         39 - ENDING STATUS WRONG: This error  is  reported  if  bit  56,
{              indicating  successful,  was  not set in ending status from
{              the IVB.
{
{         40 - IVB AVAILABLE: This error indicates  that  the  IVB  has
{              gone from not ready to ready.
{
{         41 - IVB  RESET:  This  error  indicates the IVB has switched to
{              reset state and  will  be  unavailable  for  an  indefinate
{              period of time.
{
{         42 - RESET FREQUENCY THRESHOLD: The IVB reset frequency threshold
{              was reached and the IVB has been downed.
{
{         100 - FORCED ERROR DID NOT OCCUR: This error indicates that  the
{               PP  forced  an  error during diagnostics but the error did
{               not occur.
{
{         200 - INVALID IPI READ RESPONSE: This error  indicates  that  an
{               invalid   read   response   was  received  from  the  IVB.
{
{         201 - INVALID IPI PARAMETER LENGTH: This error indicates that  a
{               parameter  was  received from the IVB for which the length
{               field was invalid.
{
{         202 - SEQUENCE  NUMBER  ERROR:  This  error  indicates  that   a
{               response  was  received  from  the  IVB which contained an
{               invalid sequence number.
{
{         203 - STATUS  MISMATCH:  This  error  indicates  that  the  host
{               indicated to the IVB that  an  operation  failed  but  the
{               status   returned   from  the  IVB  indicated  successful
{               completion.
{
{         205 - INVALID IPI RESPONSE OPCODE: This error indicates that  an
{               invalid operation  code was received with an IVB response.
{
{         206 - Invalid IPI response length: This error indicates that the
{               length  field  of  an IPI response was invalid.
{
{         207 - INVALID READ RESPONSE PARAMETER: This error indicates that
{               an  invalid  parameter  was received with an IPI response.
{
{         221 - INVALID DIAGNOSTIC RESPONSE: This error indicates that  an
{               invalid  diagnostic  response  was read.
{
{         229 - MAX CCPDU SIZE EXCEEDED: This error indicates that a ccpdu
{               was   received   which  exceeded  the  maximum  pdu  size.
{
{         230 - BUFFER REQUIRMENTS EXCEEDED: This error indicates that the
{               PP  does  not  support the maximum ccpdu size supported by
{               the IVB.
{
{         300 - RMA NOT ON WORD BOUNDARY: This error  indicates  a  system
{               error has occured.  A real memory address which must start
{               on a word boundary does not.
{
{         301 - CCPDU HEADER ERROR: This error  indicates  a  system error
{               has occured. A CCPDU header is not the correct size.
{
{         302 - INVALID UNIT REQUEST: This error  indicates  that  the  PP
{               received   an  unsupported  unit  request  from  the  CPU.
{
{         303 - WRITE REQUEST LENGTH ERROR: This error  indicates  that  a
{               write  request  received  from  the  CPU  was  of  invalid
{               length.
{
{         320 - IVB PROTOCOL NEGOTIATION FAILED: This error indicates that
{               the PP does not support the IPI or CC protocol proposed by
{               the IVB.
{
{         321 - INVALID  PP  COMMAND:  This  error  indicates  that the PP
{               received an unsupported command from the  CPU.
{
{         322 - UNEXPECTED CPU ACK: This error indicates that the CPU sent
{               an unexpected syncronization response to the PP.
{
{         323 - UNABLE TO CLEAR CHANNEL LOCK: This error indicates that  a
{               system  error  has  occured.   The  channel lock cannot be
{               cleared by the PP.
{
{         324 - INVALID BUFFER POOL DESCRIPTOR: This error indicates  that
{               a system error has occured. The buffer pool descriptors
{               are corrupted.
{
{         325 - MAXIMUM CCPDU SIZE REQUESTED ON SUSPEND LINK:  This error
{               indicates  that the maximum ccpdu size specified in the
{               suspend link request exceeds the maximum size supported.
{
{         350 - INDETERMINATE: This error indicates that an error has been
{               reported which can not be decoded to one of the preceding
{               errors.
{
{    6. Request Retry Count - The number of times the PP driver
{       retried the i/o request. (0..3)
{
{    7. Last Function - The last function sent from the PP to IVB.
{       (0 .. 0ffff(16))
{
{    8. Last -1 Function - The last -1 function sent from the PP to IVB.
{       (0 .. 0ffff(16))
{
{    9. Last -2 Function - The last -2 function sent from the PP to IVB.
{       (0 .. 0ffff(16))
{
{    10. Last -3 Function - The last -3 function sent from the PP to IVB.
{        (0 .. 0ffff(16))
{
{    11. Last -4 Function - The last -4 function sent from the PP to IVB.
{        (0 .. 0ffff(16))
{
{    12. Last -5 Function - The last -5 function sent from the PP to IVB.
{        (0 .. 0ffff(16))
{
{    13. Last -6 Function - The last -6 function sent from the PP to IVB.
{        (0 .. 0ffff(16))
{
{    14. Last -7 Function - The last -7 function sent from the PP to IVB.
{        (0 .. 0ffff(16))
{
{    15. Master Status - Last master status sent to the IVB.
{        (0 .. 0ffff(16))
{
{    16. Slave Status - Last slave status sent to the PP.
{        (0 .. 0ffff(16))
{
{    17. Operation Code - Operation code of the response in error
{        or the PP/UNIT command in error.
{        (0 .. 0ffff(16))
{
{    18. Parameter Id - Parameter identifier in error.
{        (0 .. 0ffff(16))
{
{    19. Expected Sequence Number - The  sequence number expected
{        with the failing response.
{        (0 .. 0ffff(16))
{
{    20. Actual Sequence Number - The  sequence number received
{        with the failing response.
{        (0 .. 0ffff(16))
{
{    21. Supported Protocol - Defines the IPI and CC protocol supported
{        by the host.  (0 .. 0ffff(16) defined as IICC) were II  indicates the
{        IPI protocol and CC indicates the Channel Connection protocol.
{        ie the value 0203(16) would define a IPI protocal of 2 and a
{        Channel Connection protocal of 3.
{
{    22. IVB Proposed Pprotocol - Defines the IPI and CC protocol supported
{        by the IVB.  (0 .. 0ffff(16) defined as IICC) were II  indicates the
{        IPI protocol and CC indicates the Channel Connection protocol.
{        ie the value 0203(16) would define a IPI protocal of 2 and a
{        Channel Connection protocal of 3.
{
{    23. REQUIRED BUFFERS - Number of buffers required by the PP to read
{        the maximum sized ccpdu.
{
{    24. MAXIMUM BUFFERS - Maximum number of buffers the PP is designed
{        to aquire for one ccpdu.
{
{    25. Length - This could be the length of a response or ccpdu
{        depending on error type.
{
{    26. IPI Status register - (0 .. 0FFFF(16)).
{
{    27. IPI Error register - (0 .. 0FFFF(16)).
{
{    28. DMA Error register - (0 .. 0FFFF(16)).
{
{    29. DMA Status register - (0 .. 0FFFF(16)).
{
{    30. DMA Control register - (0 .. 0FFFF(16)).
{
{    31. Expected Length - If error is incomplete transfer this counter
{        defines the expected length of the transfer. (0 .. 0FFFF(16).
{
{    32. Actual Length - If error is incomplete transfer this counter
{        defines the actual length of the transfer. (0 .. 0FFFF(16).
{
{    33. MAXIMUM CCPDU LENGTH - This counter indicates the maximum ccdpu
{        size supported by the IVB. This counter is included only with
{        the device available message.
{
{    34 - 38. RESERVED FOR PP - These words are reserved for debugging
{             purposes and should not be reported by HPA.

  CONST
    cml$ivb_failure_data = cmc$min_ecc + 7004;

*copyc cmc$condition_limits

*DECK DECK=CML$IVB_USAGE_DATA EXPAND=FALSE
{
{ CML$IVB_USAGE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record usage data
{    recorded by NOS/VE when accessing the IVB.
{
{ FREQUENCY: At a minimum of thirty minute interval.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<channel>.<element>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is the string 'PPn' or 'CPPn' where 'n' is the decimal
{        representation of the physical PP number used to process
{        the failing request. The C prefix is used to indicate that
{        the PP is a concurrent PP.
{
{      where <channel> is  the string 'CHn' or 'CCHn' ,
{        where 'n' is the decimal representation of the channel.
{        The C prefix is used to indicate that the channel is
{        a concurrent channel.
{
{      where <element> is the element name of the IVB being
{        accessed.
{
{      where <symptom> is the symptom/action statement  provided  by
{        the system.
{
{    The counter-value portion of this statistic contains:
{
{    1.  IOU number/Logical PP number
{        Bits 46 .. 51 = IOU number
{        bit  57       = 1 if I4 concurrent pp
{        Bits 58 .. 63 = physical PP number
{    2.  IOU number/Channel Number of Controller
{        bits 46 .. 51 = IOU number
{        bit  55       = 1 if I4 concurrent channel port A
{        bit  56       = 1 if I4 concurrent channel port B
{        bit  57       = 1 if concurrent pp
{        Bits 58 .. 63 = Channel Number of Controller
{    3.  Bytes Read - The number of bytes read since the last
{        Usage Data statistic was sent. (0 .. 0ffffffff(16))
{    4.  Bytes Written - The number of bytes written since the last
{        Usage Data statistic was sent. (0 .. 0ffffffff(16))
{

  CONST
    cml$ivb_usage_data = cmc$min_ecc + 7005;

*copyc cmc$condition_limits

*DECK DECK=CML$JOB_RECOVERY_FAILURE EXPAND=FALSE

  CONST
    cml$job_recovery_failure = cmc$min_ecc + 1113;

*copyc cmc$condition_limits
*DECK DECK=CML$JOB_RECOVERY_TOTALS EXPAND=FALSE

  CONST
    cml$job_recovery_totals = cmc$min_ecc + 1112;

*copyc cmc$condition_limits
*DECK DECK=CML$MAINFRAME_IDENTIFICATION EXPAND=TRUE
{
{ CML$MAINFRAME_IDENTIFICATION
{
{
{ PURPOSE:
{    This statistic provides the identification of the mainframe
{ for which a system initialization has occurred.  This statistic
{ is emitted when the configuration is activated during each
{ system initialization.
{
{ FREQUENCY: At each system initialization.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{    The  counter-value portion of this statistic is unused.
{

  CONST
    cml$mainframe_identification = cmc$min_ecc + 1;

*copyc cmc$condition_limits

*DECK DECK=CML$MDI_FAILURE_DATA EXPAND=FALSE
{
{ CML$MDI_FAILURE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record failure data
{    captured by NOS/VE when accessing the MDI.
{
{ FREQUENCY: At occurrence of failure.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<channel>.<element>*<severity>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is the string 'PPn' or 'CPPn' where 'n' is the decimal
{        representation of the physical PP number used to process
{        the failing request. The C prefix is used to indicate that
{        the PP is a concurrent PP.
{
{      where <channel> is  the string 'CHn' or 'CCHn' ,
{        where 'n' is the decimal representation of the channel.
{        The C prefix is used to indicate that the channel is
{        a concurrent channel.
{
{      where <element> is the element name of the MDI being
{        accessed when the failure occurred.
{
{      where <severity> is the string 'UF' for unrecovered, 'RF' for
{        recovered, 'IF' for intermediate failure log-entry, and 'IM'
{        for informative messages.
{
{        The PP reports failure data and diagnostic results  as  an
{        intermediate  failure  log-entry  prior  to retrying an i/o
{        request.  This is due to the fact that retry attempts are
{        not done immediatly but alternately with other I/O queued.
{        An intermediate failure    log-entry   will   provide   the
{        first-failure data captured by the PP  during  the  initial
{        attempt  at  the  request  or  during  a subsequent request
{        retry.
{
{        For  all failures the counter values contain
{        the failure data corresponding  to  the first  unsuccessful
{        try of the i/o request.
{
{      where <symptom> is the symptom/action statement  provided  by
{        the system.
{
{
{    The absence or presence of information in a counter word is
{    determined by the same convention used by other peripheral
{    statistics.  That is if bit 0, (left-most bit) of a counter word,
{    is not set the counter contains a bonafide value. The convention
{    does not apply to detailed status, whose presence  is
{    determined by the length of the statistic.
{
{    The counter-value portion of this statistic contains:
{
{    1.  IOU number/Logical PP number
{        Bits 46 .. 51 = IOU number
{        bit  57       = 1 if concurrent pp
{        Bits 58 .. 63 = logical PP number
{    2.  IOU number/Channel Number of Controller
{        bits 00 .. 15 = channel error status if concurrent pp
{        Bits 46 .. 51 = IOU number
{        bit  57       = 1 if concurrent pp
{        Bits 58 .. 63 = Channel Number of Controller
{    3.  Logical Operation Code
{        1 - write
{        2 - read
{        3 - read_detailed_status
{        4 - read_diagnostic_command
{        5 - read_general_status
{        6 - inline_write
{    4.  Log-entry Class
{        0 - Recovered Failure Report
{        1 - Unrecovered Failure Report
{        2 - Intermediate Failure Report
{        3 - Informative Message
{    5.  Failure Symptom Code (tells what the system thinks is wrong)
{
{        1 - INVALID STATE TRANSITION - The MDI has switched to an
{            invalid state. The counter CURRENT STATE contains the
{            current MDI state. The counter PREVIOUS STATE contains
{            the previous MDI state.
{
{        2 - GENERAL STATUS BUSY TIMEOUT - The busy bit in general
{            status did not clear within 100 milliseconds after a read
{            general status function was accepted. The counter
{            PREVIOUS FUNCTION contains the last function prior to the
{            busy timeout error.
{
{        3 - FUNCTION TIMEOUT - MDI did not accept a function (by
{            deactivating the channel) within 100 milliseconds.  TIMED
{            OUT FUNCTION contains the function on which the error
{            occured.
{
{        4 - FUNCTION TIMEOUT CHANNEL ERROR - MDI did not accept a
{            function within 100 milliseconds and the channel error
{            flag was set.  TIMED OUT FUNCTION contains the function
{            on which the error occured.
{
{        5 - INPUT CHANNEL PARITY - On an input from the MDI to PP the
{            channel-error-flag was set.
{
{        6 - OUTPUT CHANNEL PARITY - On an output from the PP to the
{            MDI, the MDI reported a parity error in status but the
{            channel-error-flag was not set.
{
{        7 - IOU OUTPUT PARITY - On an output from PP to MDI both the
{            channel-error-flag and the MDI's status indicated a
{            parity error occurred.
{
{        8 - INDETERMINATE OUTPUT PARITY - On an output from PP to
{            MDI the channel-error-flag was set but there was no
{            error reported by the MDI.  This may mean there is a
{            problem in the IOU and/or the channel and/or the MDI.
{
{        9 - CHANNEL FULL - The channel did not go empty within one
{            millisecond following a write to the MDI.
{
{        10 - MESSAGE LENGTH VERIFICATION ERROR - The length specified
{            in the header of a message from the MDI doesnt match the
{            size of the record read.  The expected length of the
{            message is contained in counter EXPECTED LENGTH and the
{            actual length in counter ACTUAL LENGTH.  The case were a
{            message is longer than expected is indicated by an actual
{            length value of 80000000(16).
{
{        11 - GENERAL STATUS SEND DATA TIMEOUT - The send data bit in
{             general status was not set within one second of being
{             cleared.
{
{        12 - GENERAL STATUS AVAILABLE TIMEOUT - General status was
{             not available (channel full) within one millisecond of
{             the general status function being accepted. The counter
{             PREVIOUS FUNCTION contains the last function prior to
{             the general status available timeout. The counter
{             PREVIOUS STATE contains the last known state of the MCI.
{
{        13 - CHANNEL EMPTY - The channel did not go full within one
{             millisecond following the MDI's acceptance of a function
{             which was to be followed by an input operation.
{
{        14 - CHANNEL INACTIVE - The channel was inactive following a
{             write operation and no general status errors were
{             indicated.
{
{        15 - MDI RESET - The MDI has switched to reset state.
{
{        16 - MDI AVAILABLE - The MDI has entered loading or
{             operational state.
{
{        17 - INCOMPLETE TRANSFER - The input/output operation did not
{             complete as indicated by the PP's A register being non
{             zero.  However the channel remained active and no
{             general status or channel errors were indicated.
{
{        18 - INDETERMINATE (channel or MDI or ethernet) General
{             status indicates an error but detailed status could not
{             be obtained or did not contain values which could be
{             decoded to one of the preceding errors.
{
{        19 - GENERAL STATUS DATA AVAILABLE TIMEOUT - The data
{             available bit in general status was not set within one
{             second of recieving a Diagnostic Command to read.
{             The counter DIAGNOSTIC COMMAND contains the last
{             read diagnostic command.
{
{        20 - MESSAGE CONTENT ERROR - An invalid command was read
{             during diagnostic mode. The counter DIAGNOSTIC
{             COMMAND contains the last read diagnostic command.
{
{        21 - GENERAL STATUS CONTENT FAILURE - During diagnostic
{             state the contents of the general status was not as
{             expected. Only two error values are allowed in
{             diagnostic mode, these are 6012(8) and 4011(8).
{             Counter DIAGNOSTIC COMMAND contains the diagnostic
{             command last read.
{
{             NOTE:  If the MCI is connected to a CIO channel this
{             error could indicate that the MCI does not include
{             required FCO#48716.
{
{        22 - MASTER CLEAR FAILURE - After issuing a MASTER CLEAR
{             function the MDI failed to transition out of LOADING
{             or OPERATIONAL state.
{
{        23 - RESET FREQUENCY THRESHOLD - The MDI reset frequency
{             threshold was reached and the MDI has been downed.
{
{        24 - Reserved.
{
{        25 - ITB ERROR - The ITB error comes from a slave device and
{             indicates that it has detected an error condition.
{
{        26 - ITB PARITY ERROR - The ITB parity error signal indicates
{             that a parity error was detected on read data.
{
{        27 - CHANNEL TIMEOUT - The channel has been active for eight
{             seconds without any I/O activity.  The channel was
{             disconnected by the MCI hardware channel active
{             timeout.
{
{        28 - INPUT TRUNCATED - The PP deactivated the channel before
{             reading the entire message whose length has been set in
{             the DMA registers.
{
{        29 - PP OVERRUN - The PP has output more than the
{             maximum length set by the MCI processor in the DMA
{             registers.
{
{        30 - CHANNEL PROTOCOL NOT SUPPORTED - the version of channel
{             protocol supported by the MDI and NOS/VE are not compatible.
{             DETAILED STATUS contains the highest channel protocol supported
{             by the MDI(counter 16 bits 48 .. 55). The counter CHANNEL PROTOCOL
{             contains the highest channel protocol supported by NOS/VE.
{
{        31 - Reserved.
{
{        32 - INVALID MESSAGE TYPE - The message type value indicated in
{             general status (counter 14 bits 58 - 60) is invalid. Valid
{             message type values are (0 = channelnet message, 1 = channel
{             connection message, 5 = inline diagnostic message).
{
{        33 - MAXIMUM RECORD SIZE EXCEEDED - The record size indicated in
{             the record header exceeds the maximum allowed for this
{             device. The counter ACTUAL LENGTH contains the length of
{             the record.
{
{        34 - MCI DETECTED LENGTH ERROR - The MCI detected a length error
{             after a write operation.
{
{    6. Request Retry Count - The number of times the PP driver
{       retried the i/o request. (0..3)
{
{    7. Timed Out Function - The function which caused a function
{       timeout. (0 .. 07777(8))
{
{    8. Previous Function - The function executed prior to a general
{       status busy timeout error. (0 .. 07777(8))
{
{    9. Current State - If invalid state transition error.
{       Valid states are (0 = reset, 1 = diagnostic,
{       4 = loading, 10(8) = operational).
{
{    10. Previous State - If invalid state transition error or
{        general status available timeout.
{        Valid states are (0 = reset, 1 = diagnostic,
{        4 = loading, 10(8) = operational).
{
{    11. Expected Length - If error is message length
{        verification error. (0 .. 0ffffffff(16))
{
{    12. Actual Length - If error is message length
{        verification error. (0 .. 0ffffffff(16))
{
{    13. Diagnostic Command - Contains the command read if error is
{        Message Content Error, General Status Data Available Timeout,
{        Genreral Status Content Failure. (0 .. 0fff(16)).
{
{    14. General Status - General status is always returned if
{        available. (0 .. 07777(8))
{
{    15. Channel Protocol - If error is channel protocol not supported
{        (0 .. 0ff(16)).
{
{    16 .. 19 Detailed Status.  Detailed status is always returned if
{        the MDI is operational and detailed status can be obtained.
{

  CONST
    cml$mdi_failure_data = cmc$min_ecc + 7001;

*copyc cmc$condition_limits

*DECK DECK=CML$MDI_USAGE_DATA EXPAND=FALSE
{
{ CML$MDI_USAGE_DATA
{
{ PURPOSE:
{    The purpose of this statistic is to record usage data
{    recorded by NOS/VE when accessing the MDI.
{
{ FREQUENCY: At a minimum of thirty minute interval.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<channel>.<element>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the failure was reported.
{
{      where <pp> is the string 'PPn' or 'CPPn' where 'n' is the decimal
{        representation of the physical PP number used to process
{        the failing request. The C prefix is used to indicate that
{        the PP is a concurrent PP.
{
{      where <channel> is  the string 'CHn' or 'CCHn' ,
{        where 'n' is the decimal representation of the channel.
{        The C prefix is used to indicate that the channel is
{        a concurrent channel.
{
{      where <element> is the element name of the MDI being
{        accessed when the failure occurred.
{
{      where <symptom> is the symptom/action statement  provided  by
{        the system.
{
{    The counter-value portion of this statistic contains:
{
{    1.  IOU number/Logical PP number
{        Bits 46 .. 51 = IOU number
{        bit  57       = 1 if concurrent pp
{        Bits 58 .. 63 = logical PP number
{    2.  IOU number/Channel Number of Controller
{        bits 00 .. 15 = channel error status if concurrent pp
{        Bits 46 .. 51 = IOU number
{        bit  57       = 1 if concurrent pp
{        Bits 58 .. 63 = Channel Number of Controller
{    3.  Bytes Read - The number of bytes read since the last
{        Usage Data statistic was sent. (0 .. 0ffffffff(16))
{    4.  Bytes Written - The number of bytes written since the last
{        Usage Data statistic was sent. (0 .. 0ffffffff(16))
{

  CONST
    cml$mdi_usage_data = cmc$min_ecc + 7002;

*copyc cmc$condition_limits

*DECK DECK=CML$MEMORY_FAILURE_DATA EXPAND=FALSE
{
{ CML$MEMORY_FAILURE_DATA
{
{
{ PURPOSE:
{    This statistic records the failure data captured by the system
{ following corrected or uncorrected central memory errors.
{
{ FREQUENCY: Each time DFT enters data into the maintenance
{            register buffers following each failure occurrence.
{
{ CONTENT:
{    The descriptive-data portion of this statistic contains:
{
{    '<mf>.<element>*<product id>*<serial number>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0) and 'ssss' is the serial number
{        of that processor.
{
{      where <element> is the name CENTRAL_MEMORY.
{
{      where <product id> is the model number from the memory
{        element's identification register.
{
{      where <serial number> is the serial number from the
{        memory element's identification register.
{
{      where <symptom> is the symptom/action statement provided
{        by the system. The text of the possible symptom statements
{        is identical in content to the uppercase text described
{        under counter value 2 below.
{
{    The counter-value portion of this statistic contains:
{
{    1. Operating System (OS) action code as described in section
{       4.2 of the DFT/OS Interface Specification.(DCS # ARH6853)
{
{    2. This word contains a 12-bit DFT analysis code followed by
{       an 8-bit sequence number stored in bits 44-63 of the word.
{       The sequence number indicates the sequential order in which
{       a series of statistics occurred, and ranges from 0-255(10).
{       Dedicated Fault Tolerance (DFT) analysis code is described
{       in section 4.4 of the DFT/OS Interface Specification. The
{       failure data should be analyzed in the order in which the
{       following codes are presented. (It should also be noted
{       that if bit 12 of the 12-bit hexadecimal DFT analysis code
{       is set, the error has occurred more than one time but is
{       being reported only once; e.g. code 103 will become 903.)
{
{       101 DEADSTART ERROR LOG MEMORY ERROR.
{       105 MULTIPLE ODD BIT MEMORY ERROR.
{       104 UNCORRECTED MEMORY ERROR.
{       103 CORRECTED MEMORY ERROR.
{       108 UNCORRECTED MEMORY BOARD LEVEL ERROR.
{       109 UNCORRECTED CENTRAL MEMORY INTERFACE ERROR.
{
{     The content of words 3-63 is model dependent based upon
{     the DFT error analysis code. Packets of 5 words, each
{     consisting of a header word followed by the contents of 4
{     maintenance registers are stored sequentially. The header
{     word consists of 4 16-bit maintenance register addresses
{     stored from left to right that specify which register
{     contents are stored in the following four words. Sections
{     4.5.8 (Code 3101), 4.5.4 (Code 3104) and 4.5.3 (Code 2103)
{     of the DFT/OS Interface  Specification define the mainte-
{     nance registers and the order in which their contents are
{     stored for central memory errors. (No maintenance register
{     contents are stored for code 3105).
{
   CONST
     cml$memory_failure_data = cmc$min_ecc + 1001;

*copyc cmc$condition_limits
*DECK DECK=CML$MS_MEDIA_FLAW_CHANGE EXPAND=FALSE
{
{ CML$MS_MEDIA_FLAW_CHANGE
{
{
{ PURPOSE:
{    This statistic provides notification of the change in the
{ state of a mass storage media flaw.  This statistic is emitted
{ either by an automatic flawing of media by NOS/VE itself or by
{ a manual change performed by the LCU subcommands DEFINE_MS_FLAW
{ and REMOVE_MS_FLAW.
{    If a manual change originates from a job whose class
{ is maintenance, the initiator is assumed to be a "CE".
{    If a manual change originates from a job whose class
{ is not maintenance, the initiator is identified as an "operator".
{
{ FREQUENCY:
{    Whenever the system encounters a media failure which cannot
{    be tolerated and which prevents further use of a sector
{    or whenever an operator or a CE manually flaws mass storage
{    media.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<element>*<vsn>*<message>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <element>  is  the name of the mass storage element
{        whose media state is affected.
{
{      where <vsn> is the recorded-vsn which identifies the media
{        mounted on the specified element.
{
{      where <message> is one of the following:
{        'MEDIA FLAW DEFINED (Ccccc Ttt Sss) .. (Ccccc Ttt Sss)'
{        'MEDIA FLAW REMOVED (Ccccc Ttt Sss) .. (Ccccc Ttt Sss)'
{
{    The counter-value portion of this statistic contains:
{
{    1.  Flawing Operation Code
{       1 - Flaw Defined.
{       2 - Flaw Removed.
{    2.  Initiator Code
{       1 - Initiated by the NOS/VE system due to media failure.
{       2 - Initiated by an operator.
{       3 - Initiated by a Customer Engineer (CE).
{    3.  Starting Cylinder
{    4.  Starting Track
{    5.  Starting Sector
{    6.  Ending Cylinder
{    7.  Ending Track
{    8.  Ending Sector



  CONST
    cml$ms_media_flaw_change = cmc$min_ecc + 201;

*copyc cmc$condition_limits

*DECK DECK=CML$MS_VOLUME_INITIALIZATION EXPAND=FALSE
{
{ CML$MS_VOLUME_INITIALIZATION
{
{
{ PURPOSE:
{    This statistic provides the identification of a peripheral
{ storage device which has been initialized.  This statistic is
{ emitted by the INITIALIZE_MS_VOLUME subcommand of the Logical
{ Configuration Utility or when the system disk is initialized
{ during a system installation.
{
{ FREQUENCY: Whenever a disk volume is initialized.
{
{ CONTENT:
{    The descriptive-data portion of this statistic contains:
{
{    '<mf>.<element>*<vsn>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where <element> is the name of the element specified in the
{        active configuration.
{
{      where <vsn> is the site-supplied name for the mass storage
{        volume (HDA).
{
{    The counter-value portion of this statistic contains:
{
{    1. Physical unit number of the storage device on which the
{       volume is currently mounted.  The physical unit number
{       is used to differentiate among storage devices which
{       share the same cabinet.

  CONST
    cml$ms_volume_initialization = cmc$min_ecc + 100;

*copyc cmc$condition_limits
*DECK DECK=CML$OPTICAL_DISK_USAGE_DATA EXPAND=FALSE
{
{  DECK=CML$OPTICAL_DISK_DEVICE_USAGE_DATA
{
{
{ PURPOSE:
{    The purpose of this statistic is to record the amount of work
{     performed by a particular disk storage device. This information is
{     used by maintenance personnel to measure the failure rate per
{     amount of service performed.
{
{ FREQUENCY:
{    This statistic is emitted every hour or each time a volume
{    is dismounted by the system.  If no i/o was performed to the
{    volume, this statistic is still emitted to record the fact that
{    the volume had been mounted; in this case the counter-values
{    are zeroed.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<controller>.<unit>*<vsn>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where <controller> is the element name of the optical storage
{        controller involved in the work being recorded.
{
{      where <unit> is the element name of the optical storage
{        device whose work is being recorded.
{
{      where <vsn> is the recorded-vsn of the volume which was
{        the object of the work performed.
{
{    The  counter-value portion of this statistic contains:
{
{    1.  Type of usage log entry.
{        0 - Volume dismount entry.
{        1 - Interval entry.
{        3 - Interval entry.  Last unit for the controller.
{    2.  Total number of sectors read from this storage device since the
{        the volume was mounted or since the last usage logging.
{    3.  Total number of sectors written to this storage device since
{        the volume was mounted or since the last usage logging.
{    4.  Total number of i/o requests issued for this storage device
{        the volume was mounted or since the last usage logging.
{    5.  Number of bytes per sector.
{

  CONST
    cml$optical_disk_usage_data = cmc$min_ecc + 7400;

*copyc cmc$condition_limits
*DECK DECK=CML$PAGE_MAP_FAILURE_DATA EXPAND=FALSE
{
{ CML$PAGE_MAP_FAILURE_DATA
{
{
{ PURPOSE:
{    This statistic records the failure data captured by the system
{ following corrected or uncorrected page map errors.
{
{ FREQUENCY: Each time DFT enters data into the maintenance
{            register buffers following each failure occurrence.
{
{ CONTENT:
{    The descriptive-data portion of this statistic contains:
{
{    '<mf>.<element>*<product id>*<serial number>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0) and 'ssss' is the serial number
{        of that processor.
{
{      where <element> is the name PAGE_MAP.
{
{      where <product id> is the model number from the memory
{        element's identification register.
{
{      where <serial number> is the serial number from the
{        memory element's identification register.
{
{      where <symptom> is the symptom/action statement provided
{        by the system. The text of the possible symptom statements
{        is identical in content to the uppercase text described
{        under counter value 2 below.
{
{    The counter-value portion of this statistic contains:
{
{    1. Operating System (OS) action code as described in section
{       4.2 of the DFT/OS Interface Specification.(DCS # ARH6853)
{
{    2. This word contains a 12-bit DFT analysis code followed by
{       an 8-bit sequence number stored in bits 44-63 of the word.
{       The sequence number indicates the sequential order in which
{       a series of statistics occurred, and ranges from 0-255(10).
{       Dedicated Fault Tolerance (DFT) analysis code is described
{       in section 4.4 of the DFT/OS Interface Specification. The
{       failure data should be analyzed in the order in which the
{       following codes are presented. (It should also be noted
{       that if bit 12 of the 12-bit hexadecimal DFT analysis code
{       is set, the error has occurred more than one time but is
{       being reported only once; e.g. code 301 will become B01.)
{
{       301 CORRECTED PAGE MAP ERROR.
{       302 UNCORRECTED PAGE MAP ERROR.
{
{     The content of words 3-63 is model dependent based upon
{     the DFT error analysis code. Packets of 5 words, each
{     consisting of a header word followed by the contents of 4
{     maintenance registers are stored sequentially. The header
{     word consists of 4 16-bit maintenance register addresses
{     stored from left to right that specify which register
{     contents are stored in the following four words.  Sections
{     4.5.10 (code 301), 4.5.11 (code 302) of the DFT/OS Interface
{     Specification define the maintenance registers and the order
{     in which their contents are stored for page map errors.
{
   CONST
     cml$page_map_failure_data = cmc$min_ecc + 1007;

*copyc cmc$condition_limits
*DECK DECK=CML$PERIPHERAL_IDENTIFICATION EXPAND=FALSE
{
{ CML$PERIPHERAL_IDENTIFICATION
{
{
{ PURPOSE:
{    This statistic provides the identification of a peripheral in
{ NOS/VE's active configuration.
{    Refer to the Physical Configuration Utility's DEFINE_ELEMENT
{ subcommand for a complete list of peripheral hardware products
{ for which this statistic would be emitted.
{
{ FREQUENCY: At each system initialization, once for each peripheral
{    in the active configuration.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<element>*<product identification>*<serial number>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where <element> is the name of the element specified in the
{        active configuration.
{
{      where  <product  identification> is the identification of the
{        element specified in the active configuration.
{
{      where <serial number> is the unique identity of  the  element
{        relative  to its product family as specified in the active
{        configuration (in decimal).
{
{    The counter-value portion of this statistic contains:
{
{    1. Peripheral Element Type:
{      1 - Channel adapter (has only downline connections)
{      2 - Controller (has upline and downline connections)
{      3 - Storage Device (has only upline connections)
{    2. Element State
{      1 - ON
{      2 - DOWN
{      3 - OFF
{    3. Physical unit number of the storage device. The
{       physical unit number is used to differentiate
{       among storage devices which share the same cabinet.
{       Note, this counter value is valid only if the
{       peripheral element is a storage device.

  CONST
    cml$peripheral_identification = cmc$min_ecc + 6;

*copyc cmc$condition_limits
*DECK DECK=CML$PM_IDENTIFICATION EXPAND=FALSE
{
{ CML$PM_IDENTIFICATION
{
{
{ PURPOSE:
{    This statistic provides the identification of the page
{ map on the mainframe being initialized.  This statistic is
{ emitted when the configuration is activated during each
{ system initialization.
{
{ FREQUENCY: At each system initialization.
{
{ CONTENT:
{    The descriptive-data portion of this statistic contains:
{
{    '<mf>.<element>*<product identification>*<serial number>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where <element> is the name PAGE_MAP.
{
{      where <product identification> is the model number from the
{        memory element's identification register.
{
{      where  <serial  number> is the serial number from the memory
{        element's identification register.
{
{    The counter-value portion of this statistic is unused.
{

  CONST
    cml$pm_identification = cmc$min_ecc + 7;

*copyc cmc$condition_limits
*DECK DECK=CML$PP_HUNG EXPAND=FALSE

  CONST
    cml$pp_hung = cmc$min_ecc + 1010;

*copyc cmc$condition_limits

*DECK DECK=CML$PP_TIMED_OUT EXPAND=FALSE
{
{ CML$PP_TIMED_OUT
{
{
{ PURPOSE:
{    This statistic records a message denoting that monitor
{ has detected that a PP has timed out.
{
{ FREQUENCY: Once when each PP that is involved with
{            CPU/PP handshaking times out.
{
{ CONTENT:
{    The descriptive-data portion of this statistic contains:
{
{    '<mf>*<message><time and date>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where <message> is the action statement provided by the
{        system. Following is the text of the possible message
{        statements.
{
{      VEOS6000- xxxxx TIMED OUT   -  Monitor has detected that
{                                     PP xxxxx is no longer
{                                     responding to the CPU/PP
{                                     handshaking protocol.
{                                     The possible values for
{                                     xxxxx are:
{                                             SCI
{                                             DFT
{                                             DFT-S
{                                     If the PP is DFT, the
{                                     system may continue to run
{                                     for an indefinite period
{                                     of time.
{
{      where <time and date> is the time and date at which the
{      time out occurred, in the form:
{
{           at hh:mm:ss.sss on mm/dd/yy.
{
{      The counter-value portion of this statistic is unused.
{
  CONST
    cml$pp_timed_out = cmc$min_ecc + 52;

*copyc cmc$condition_limits

*DECK DECK=CML$RHFAM_FAILURE_DATA EXPAND=FALSE

{ CML$RHFAM_FAILURE_DATA
{
{ PURPOSE:  This statistic provides the information that is available
{    when the NAD PP driver encounters an abnormality, while
{    functioning the NAD.
{
{ FREQUENCY:  Each time the PP encounters an error a message is emitted.
{    If the error is retryable, then an intermediate failure condition
{    is logged.  Otherwise an unrecorvered failure is logged.
{
{ CONTENT:
{    Descriptive Data:
{
{    '<mf>.<iou>.<pp>.<channel>.<element>*<severity>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        central processor zero and 'ssss' is the serial number of
{        that processor.
{
{      where <iou> specifies the string 'IOUn' where n identifies
{        the resident IOU of the channel (either 0 or 1).
{
{      where <pp> specifies the string 'PPn' where n is the decimal
{        representation of the logical PP used to access the channel.
{
{      where <channel> specifies the string 'CHn' where n is the decimal
{        representation of the physical channel used to access the NAD.
{
{      where <element> is the element name, specified in the PCU,
{        used to logically identify the NAD.
{
{      where <severity> specifies a string of two characters which
{        defines the severity of the error.
{
{        IF      Intermediate failure.
{        UF      Unrecovered failure.
{
{      where <symptom> specifies a string that briefly describes the
{        failure encountered by the PP.
{
{        0)  FUNCTION TIMEOUT
{        1)  CHANNEL ACTIVATE FAILED
{        2)  CHANNEL HUNG EMPTY
{        3)  PRIME FLAG TIMEOUT
{        4)  FLAG FUNCTION TIMEOUT
{        5)  ABNORMAL NAD RESPONSE
{        6)  NAD HARDWARE ABNORMAL
{        7)  INPUT TERMINATED EARLY
{        8)  OUTPUT TERMINATED EARLY
{        9)  CHANNEL PARITY ERROR
{       10)  UNIVERSAL COMMAND TIMEOUT
{       11)  NAD MEMORY ERROR
{       12)  CONCURRENT_CHANNEL_ERROR
{
{    Counters:
{
{      1 - Logical PP number.
{          Bit 57 = 1 implies that the PP is an I4 concurrent PP.
{          Bits 46 thru 51 contain the IOU number of the PP.
{
{      2 - Channel number of the channel that is physically connected
{            to the NAD.  Since only one NAD exists per channel
{            the channel number uniquely defines the NAD.
{          Bit 57 = 1 implies that the channel is an I4 concurrent
{          channel.
{          Bits 46 thru 51 contain the IOU number of the channel.
{
{      3 - Equipment number. (not used)
{
{      4 - Unit number. (not used)
{
{      5 - Unit type value.
{          1  = $380-170.
{
{      6 - Logical Operation Code.
{
{          0  = load the local NAD micro-code.
{          1  = dump the local NAD memory image.
{          2  = obtain the status of the connections
{               established through the local NAD.
{          3  = obtain statistics from the local NAD.
{          4  = send data across the network.
{          5  = receive data from the network.
{          6  = request the establishment of a connection
{               through the local NAD.
{          7  = accept an incoming connect request.
{          8  = reject an incoming connect request.
{          9  = obtain an incoming connect request.
{         10  = dump the remote NAD memory image.
{         11  = load the remote NAD micro-code.
{         12  = obtain statistics from the remote NAD.
{         13  = obtain the status of the corresponding
{               connection.
{         14  = terminate the connection in the local NAD.
{         15  = send a control message.
{         16  = receive a control message.
{
{      7 - Failure severity. (2 specifies a intermediate
{          failure and 1 specifies an unrecovered
{          failure.
{
{      8 - Symptom code.  A number which corresponds
{          to a symptom code defined in the descriptive
{          data section (e.g. a "0" is a FUNCTION
{          TIMEOUT).
{
{      9 - Retry count.  This parameter specifies the
{          current retry iteration being logged.  This
{          is used to correlate a sequence of messages.
{
{     10 - Connection number.  (A value of zero is used
{          for non-path related functions).
{
{     11 - The last controlware function issued.
{          If the function flag is clear then
{          this field contains the last
{          universal command subfunction issued.
{
{     12 - The last hardware function issued.
{
{     13 - Controlware status at time of failure.
{          A value of 0FFFF(16) means the status was not
{          available.
{
{     14 - Hardware status at time of failure.
{          A value of 0FFFF(16) means the status was not
{          available.
{
{          See the 380-170 NAD Hardware reference manual for
{          further documentation of the NAD functions and status
{          values.
{
{     15 - Transfer count.  This counter contains the number of
{          bytes that were transferred across the channel before
{          the error was encountered.  This counter is typically
{          only meaningful for abnormal I/O conditions.  However,
{          it can also provide trace information.

  CONST
      cml$rhfam_failure_data = cmc$min_ecc + 7200;

*copyc cmc$condition_limits

*DECK DECK=CML$RHFAM_NETWORK_FAILURE EXPAND=FALSE

{ CML$RHFAM_NETWORK_FAILURE
{
{ PURPOSE:  The purpose of this statistic is to provide the internal
{    network failure data at the time the local host observes a
{    network failure.
{
{ FREQUENCY:  Each time an unexpected network failure occurs, this
{    statistic will be emitted.  NOTE - some prevalidation is done
{    to prevent duplication of messages when a normal occurrance
{    has not changed (e.g. a host is not running).
{
{ CONTENT:
{    Descriptive data
{
{    '<mf>.<iou>.<pp>.<channel>.<element>*<severity>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        central processor zero and 'ssss' is the serial number of
{        that processor.
{
{      where <iou> specifies the string 'IOUn' where n identifies
{        the resident IOU of the channel (either 0 or 1).
{
{      where <pp> specifies the the string 'PPn' where n is the decimal
{        representation of the logical PP used to access the channel.
{
{      where <channel> specifies the string 'CHn' where n is the decimal
{        representation of the physical channel used to access the NAD.
{
{      where <element> is the element name, specified in the PCU,
{        used to logically identify the local NAD.
{
{      where <severity> is the string 'IM' which specifies that
{        the message is only informative.
{
{      where <symptom> specifies a string identifying the symptom that
{        the access method observed.
{
{        0)  CONNECTION FAILURE
{
{    COUNTER:
{
{      1 - Logical PP number.
{          Bit 57 = 1 implies that the PP is an I4 concurrent PP.
{          Bits 46 thru 51 contain the IOU number of the PP.
{
{      2 - Channel number is the number of the channel physically
{          connected to the NAD.  Since only one NAD exists per
{          channel, the channel number uniquely defines the NAD.
{          Bit 57 = 1 implies that the channel is an I4 concurrent
{          channel.
{          Bits 46 thru 51 contain the IOU number of the channel.
{
{      3 - Equipment number. (not used)
{
{      4 - Unit number. (not used)
{
{      5 - Unit type value.
{          1  = $380-170.
{
{      6 - Logical Operation Code (not used).
{
{      7 - Failure severity. (3 specifies informative
{          message).
{
{      8 - Symptom code.  A number which corresponds
{          to a symptom code defined in the descriptive
{          data section (i.e. a "0" is a CONNECTION
{          FAILURE).
{
{      9 - Retry count.  (not used)
{
{     10 - Connection number.
{
{     11 - Network Break Reason Code.  Specifies the reason code for
{          an unanticipated connection failure.
{          NOTE - these codes are equivalent to the network
{          break reason codes defined in the 170 NAD HRM.
{
{   The following counters are used to define the physical path
{   between the local NAD and the remote host.
{
{     12 - Local TCU mask.  Specifies the local NAD TCU mask where
{          bit zero is the mask bit for TCU zero, etc.  Each non-zero
{          bit means that the corresponding TCU was selected for use
{          by the corresponding path.
{
{     13 - Remote TCU mask.  Specifies the remote NAD TCU mask where
{          bit zero is the mask bit for TCU zero, etc.  Each non-zero
{          bit means that the corresponding TCU was selected for use
{          by the corresponding path.
{
{     14 - Remote NAD Address.  Specifies the address
{          of the remote NAD.
{
{     15 - Logical Network.  Specifies the network identifier
{          of the location of the network containing
{          the destination NAD.  A value of zero means that the remote
{          NAD is the destination NAD.
{
{     16 - Logical NAD.  Specifies the logical address of the
{          destination NAD within the specified logical network.  This
{          counter is not meaningful if the logical network value is
{          zero.
{
{   The following counters are used to isolate the failure along the
{   path to a specific NAD.
{
{     17 - Failing Network.  Specifies the network identifier
{          of the location of the network where the failing
{          NAD resides.  A value of zero means that the error
{          occurred within the local area network.
{
{     18 - Failing NAD.  Specifies the physical address of the
{          NAD that failed.
{
{     19 - Hop count.  Specifies the number of NADs between the local
{          NAD and the failing NAD.  A value of zero means the
{          failure occurred in the local NAD.
{
{     20 - Remote path number.  Specifies the path number
{          that was assigned to the connection in the
{          remote NAD.  If zero, the remote path ID could not
{          be obtained.

  CONST
    cml$rhfam_network_failure = cmc$min_ecc + 7201;

*copyc cmc$condition_limits
*DECK DECK=CML$RHFAM_USAGE_DATA EXPAND=FALSE

{ CML$RHFAM_USAGE_DATA
{
{ PURPOSE:  This statistic provides the performance information that
{    is required for SQC analysis.
{
{ FREQUENCY:  This statistic is emitted once every hour while the
{    RHFAM/VE system task is running.  The initial timer is set
{    when the RHFAM/VE system task is initiated.  The following
{    are exceptions to the hourly logging:
{
{    1)  The statistics are logged at the time a NAD is
{        removed from access method service.
{
{    2)  The statistics are not logged again until an attempt has been
{        made to restart the NAD.
{
{ CONTENT:
{    Descriptive Data:
{
{    '<mf>.<iou>.<pp>.<channel>.<element>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        central processor zero and 'ssss' is the serial number of
{        that processor.
{
{      where <iou> specifies the string 'IOUn' where n identifies
{        the resident IOU of the channel (either 0 or 1).
{
{      where <pp> specifies the the string 'PPn' where n is the decimal
{        representation of the logical PP used to access the channel.
{
{      where <channel> specifies the string 'CHn' where n is the decimal
{        representation of the physical channel used to access the NAD.
{
{      where <element> is the element name, specified in the PCU,
{        used to logically identify the NAD.
{
{    Counters:
{
{      1 - Channel Number.
{          Bit 57 = 1 implies that the channel is an I4 concurrent
{          channel.
{          Bits 46 thru 51 contain the IOU number of the channel.
{
{      2 - Bytes sent.
{
{      3 - Bytes received.
{
{      4 - Controlware reloads.
{
{      5 - Connections established.

  CONST
      cml$rhfam_usage_data = cmc$min_ecc + 7202;

*copyc cmc$condition_limits

*DECK DECK=CML$SYSTEM_CONTINUATION EXPAND=FALSE
{
{ CML$SYSTEM_CONTINUATION
{
{
{ PURPOSE:
{    This statistic records a message denoting that a system
{ continuation command has been processed.
{
{ FREQUENCY: Each time a system RESUME, or UNSTEP
{            command is initiated.
{
{ CONTENT:
{    The descriptive-data portion of this statistic contains:
{
{    '<mf>*<message>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where <message> is the action statement provided by the
{        system. Following is the text of the possible message
{        statements.
{
{      SYSTEM RESUME -       NOS/VE operation has resumed
{                            following a system IDLE. The
{                            Operating System is assumed to
{                            be intact in central memory and
{                            all jobs are resumed from their
{                            disk images.
{
{      SYSTEM UNSTEP -       NOS/VE operation is continued
{                            without deadstart following
{                            a system STEP. This assumes
{                            that the contents of memory
{                            remains intact. (i.e. No main-
{                            tenance action was performed
{                            that could affect the contents
{                            of memory.)
{
{      The counter-value portion of this statistic is unused.
{
  CONST
    cml$system_continuation = cmc$min_ecc + 51;

*copyc cmc$condition_limits

*DECK DECK=CML$SYSTEM_DEADSTART_STATUS EXPAND=FALSE

  CONST
    cml$system_deadstart_status = cmc$min_ecc + 1110;

*copyc cmc$condition_limits
*DECK DECK=CML$SYSTEM_ERROR EXPAND=FALSE

  CONST
    cml$system_error = cmc$min_ecc + 1111;

*copyc cmc$condition_limits
*DECK DECK=CML$SYSTEM_INFORMATIVE_MESSAGE EXPAND=FALSE
{
{ CML$SYSTEM_INFORMATIVE_MESSAGE
{
{
{ PURPOSE:
{    This statistic records a informative message in the
{ engineering log.
{
{ FREQUENCY: Unknown.  This statistic is used to write any desired
{            message to the log.
{
{ CONTENT:
{    The descriptive-data portion of this statistic contains:
{
{    '<mf>*<message>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where <message> consists of a descriptive message.
{
{    The counter-value portion of this statistic is unused.
{
  CONST
    cml$system_informative_message = cmc$min_ecc + 1800;

*copyc cmc$condition_limits

*DECK DECK=CML$SYSTEM_INITIALIZATION EXPAND=FALSE
{
{ CML$SYSTEM_INITIALIZATION
{
{
{ PURPOSE:
{    The system initialization statistic is emitted when the NOS/VE
{ system is deadstarted.
{    The statistic identifies the elements used to initialize the
{ system and the type of initialization performed.
{
{ FREQUENCY: At each system initialization.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<channel>.<controller>.<unit>*<vsn>*<message>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the initialization occurred.
{
{      where <pp> is either the string 'PPn' or 'CPPn' and where 'n'
{        is the decimal representation of the logical PP number used
{        to process the initialization.  Note that 'CPP' is the
{        designation given to the concurrent PPs in an I4 IOU.
{
{      where <channel> is either the string 'CHn', 'CCHn', or 'CCHnp',
{        where 'n' is the decimal representation of the channel and
{        where 'p' is the channel port (A or B) through which the
{        disk device was accessed.  Note that 'CCH' is the
{        designation given to the concurrent channels in an I4 IOU.
{
{      where <controller> is the element name of the disk controller
{        used to access the system disk device.
{
{      where  <unit>  is the element name of the system disk storage
{        device.
{
{      where <vsn> is the recorded-vsn of the  system  disk  storage
{        device.
{
{      where   <message>   indicates   the  type  of  initialization
{        performed:
{
{
{          TAPE INSTALLATION DEADSART
{          DISK CONTINUATION DEADSTART
{          TAPE CONTINUATION DEADSTART
{
{    The  counter-value portion of this statistic contains:
{
{      1. Type of initialization
{        0 - tape installation deadstart
{        1 - disk continuation deadstart
{        2 - tape continuation deadstart
{

  CONST
    cml$system_initialization = cmc$min_ecc + 0;

*copyc cmc$condition_limits
*DECK DECK=CML$SYSTEM_TERMINATION EXPAND=FALSE
{
{ CML$SYSTEM_TERMINATION
{
{
{ PURPOSE:
{    This statistic records a message denoting that a system
{ termination command has been processed.
{
{ FREQUENCY: Each time a system IDLE, STEP, or TERMINATE
{            command is initiated.
{
{ CONTENT:
{    The descriptive-data portion of this statistic contains:
{
{    '<mf>*<message>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where <message> is the action statement provided by the
{        system. Following is the text of the possible message
{        statements.
{
{      SYSTEM IDLE -         NOS/VE has been idled such that all its
{                            jobs in the system will be recoverable
{                            from mass storage. (All information
{                            necessary to support a system restart
{                            has been recorded on mass storage
{                            from the contents of central memory.)
{                            If the system has been running in dual
{                            state mode, the 170 state operating system
{                            will continue to run. NOS/VE operation can
{                            be resumed via a RESUME command.
{
{
{      SYSTEM STEP -         NOS/VE has been stopped such
{                            that it may be restarted from
{                            the contents of memory via an
{                            UNSTEP command, without the need
{                            for a deadstart. If the the system
{                            has been running in dual state mode,
{                            the 170 state operating system will
{                            continue to run.
{
{
{      SYSTEM TERMINATE  -   NOS/VE has been terminated and all of its
{                            jobs in the system will be recoverable
{                            from mass storage. If the system has
{                            been running in dual state mode, NOS/VE
{                            operation is terminated but the 170 state
{                            operating system continues to run. (No
{                            restart of NOS/VE via a RESUME command
{                            will be possible)
{
{
{      The counter-value portion of this statistic is unused.
{
  CONST
    cml$system_termination = cmc$min_ecc + 50;

*copyc cmc$condition_limits

*DECK DECK=CML$TAPE_SUBSYSTEM_USAGE_DATA EXPAND=FALSE
{
{ CML$TAPE_SUBSYSTEM_USAGE_DATA
{
{
{   PURPOSE:
{      The purpose of this statistic is to record the amount of
{ work performed by a tape storage device for a particular job. The
{ information is used by maintenance personnel to measure the
{ failure rate per amount of service performed.  The evsn/rvsn
{ of the tape medium is included in this statistic to aid in the
{ isolation of failure.  It is difficult to diagnose whether a tape
{ reel or a tape device is at fault.  If the evsn/rvsn can be
{ implicated in failures on other tape devices, then the
{ installation can discontinue use of the tape reel. An installation
{ may also use this statistic to track the "wear and tear" of a tape
{ reel.
{
{ FREQUENCY:
{    This statistic is emitted each time a tape reel which had been
{ assigned to a job is dismounted by the system.  If no i/o was
{ performed to the tape reel, this statistic is still emitted to
{ record the fact that the tape had been mounted.
{    This statistic is emitted once for each detach of a tape
{ storage device used by the job. This permits the collection of
{ usage data for tape transports/devices.
{
{ CONTENT:
{    The  descriptive-data portion of this statistic contains:
{
{    '<mf>.<iou>.<pp>.<channel>.<element>.<unit>,<evsn>,<rvsn>,<file>
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0), e.g. 0990, and 'ssss' is the
{        serial number of that processor, e.g. 0104.
{
{      where  <iou>  is  the  string  'IOUn' where n is 0 or 1.
{        This identifies the IOU associated with the channel over
{        which the usage occurred.
{
{      where <pp> is the string 'PPn' where n is the decimal
{        representation of the logical PP number used to access the
{        tape subsystem.
{
{      where <channel> is the string 'CHn' where n is the channel
{      number (in decimal) through which the tape device was
{      accessed.
{
{      where <element> is the element name of either a 7021_3x
{        controller, a 7221_1 adapter or a 698_xx CCC whose work
{        is being reported.
{
{      where  <unit> is the element name of the tape storage device
{        whose work is being reported.
{
{      where <evsn> is the external-vsn of the tape volume which was
{        the object of the work performed.
{
{      where <rvsn> is the recorded-vsn of the tape volume which was
{        the object of the work performed.
{
{      where <file> is the the last name (identifier) in the file path.
{
{
{    The  counter-value portion of this statistic contains:
{
{    1.  Tape unit density selection in effect during the last read
{        or write operation on the tape medium.
{           1 - NRZI ( 800 CPI)
{           2 - PE   (1600 CPI)
{           3 - GCR  (6250 CPI)
{           4 - Cartridge Tape (38000 CPI)
{    2.  Total number of tape blocks written to the tape medium by
{        the job using this physical path.  This count includes
{        blocks which were written during failure recovery.
{    3.  Total number of tape blocks read from the tape medium by
{        the job using this physical path.  This count includes
{        blocks which were read during failure recovery and any
{        forespaces/backspaces executed on the unit. This counter
{        indicates total read type usage.
{    4.  Total number of i/o requests made by the job for this
{        path to the tape storage device. The i/o requests are for
{        any request sent to the PP (motion functions, write, read, etc.).
{    5.  Blocks skipped is the total number of forespaces/backspaces
{        (does not include recovery) that were executed from the time
{        the tape was assigned until the tape was unloaded. The subsystem
{        uses forspaces/backspaces to search for a tapemark instead of
{        using the hardware function.
{    6.  Blocks written for accounting (does not include recovery).
{        A tapemark written is counted as 1 block.
{    7.  Blocks read for accounting (does not include recovery).
{        A tapemark read is counted as 1 block. This count does not
{        include any forespace/backspace operation as they are included
{        with the skip count in counter 5 above.
{    8.  Number of bytes written (does not include recovery).
{    9.  Number of bytes read. (does not include recovery or any forespace,
{        backspace operations as they are included with the skip count).
{        The byte counts for both write/read are derived using the max block
{        size for each instance of open.  Each close causes the bytes counts
{        to be incremented by a value derived from the block count for that
{        instance of open times the max block size for that instance of open.
{   10.  Number of wallclock seconds that the tape was mounted.


  CONST
    cml$tape_subsystem_usage_data = cmc$min_ecc +5000;

*copyc cmc$condition_limits
*DECK DECK=CML$TAPE_USAGE_DATA EXPAND=FALSE

{   PURPOSE:
{     The purpose of this statistic is to record in the engineering log
{     the usage statistics captured by the system when accessing any
{     tape subsystem.

{   FREQUENCY:
{     At every tape reel unload.

    CONST
      cml$tape_usage_data = cmc$min_ecc + 1999;

*copyc cmc$condition_limits
*DECK DECK=CML$TOP_OF_HOUR EXPAND=FALSE
{
{ CML$TOP_OF_HOUR
{
{
{ PURPOSE:
{    This statistic records that a new hour has just begun.
{ This statistic will cause HPA/VE to update its usage counters.
{
{ FREQUENCY: At the beginning of each hour, immediately following
{            the top of hour statistics (CM1004) and CM1005).
{
{ CONTENT:
{    The descriptive-data portion of this statistic contains:
{
{    '<mf>*<message>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0) and 'ssss' is the serial number
{        of that processor.
{
{      where <message> consists of the text message 'TOP OF HOUR'.
{
{    The counter-value portion of this statistic is unused.
{
  CONST
    cml$top_of_hour = cmc$min_ecc + 1006;

*copyc cmc$condition_limits
*DECK DECK=CML$TOP_OF_HOUR_COUNTERS EXPAND=FALSE
{
{ CML$TOP_OF_HOUR_COUNTERS
{
{
{ PURPOSE:
{    This statistic records the failure data stored in the Main-
{ frame Element Counters Buffer.
{
{ FREQUENCY: At the beginning of each hour.
{
{ CONTENT:
{    The descriptive-data portion of this statistic contains:
{
{    '<mf>*<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0) and 'ssss' is the serial number
{        of that processor.
{
{      where <symptom> is the symptom/action statement provided
{        by the system. The text of the possible symptom statement
{        is identical in content to the uppercase text described
{        under counter value 2 below.
{
{    The counter-value portion of this statistic contains:
{
{    1. Operating System (OS) action code as described in section
{       4.2 of the DFT/OS Interface Specification. (DCS # ARH6853)
{
{    2. This word contains a 12-bit DFT analysis code followed by
{       an 8-bit sequence number stored in bits 43-63 of the word.
{       The sequence number indicates the sequential order in which
{       a series of statistics occurred, and ranges from 0-255(10).
{       Dedicated Fault Tolerance (DFT) analysis code is described
{       in section 4.4 of the DFT/OS Interface Specification.
{
{         707 TOP OF HOUR MAINFRAME ELEMENT COUNTERS BUFFER.
{
{    3. The content of words 3-63 contain the Mainframe
{       Element Counters. Detailed descriptions
{       of the Mainframe Element Counters are located
{       in section 3.1.4 of the DFT/OS Interface Specification.
{
{    The Mainframe Element Counters Buffer has a one word entry
{    for each element in the mainframe including the system
{    console or service processor. Each entry consists of an
{    element type code field and three counters which are maintained
{    by DFT.  Bits 0-15 of each entry contain the CTI element code
{    for that element - right justified (0=IOU, 1=memory,
{    2=processor, 3=page map). It should also be noted that if
{    multiple CPU's or IOU's exist, they will always appear in
{    ascending order within this buffer. (i.e. CPU1 will always
{    follow CPU0, IOU1 will follow IOU0 etc.)
{
  CONST
    cml$top_of_hour_counters = cmc$min_ecc + 1004;

*copyc cmc$condition_limits
*DECK DECK=CML$TOP_OF_HOUR_SECDED_ID EXPAND=FALSE
{
{ CML$TOP_OF_HOUR_SECDED_ID
{
{
{ PURPOSE:
{    This statistic records the failure data stored in the
{ SECDED ID Table.
{
{ FREQUENCY: At the beginning of each hour.
{
{ CONTENT:
{    The descriptive-data portion of this statistic contains:
{
{    '<mf>.<element>*<product id>*<serial number> *<symptom>'
{
{      where <mf> is the identification of the mainframe in the form
{        $SYSTEM_mmmm_ssss.  Where 'mmmm' is the model number of
{        Central Processor zero (CP0) and 'ssss' is the serial number
{        number of that processor.
{
{      where <element> is the name CENTRAL_MEMORY.
{
{      where <product id> is the model number from the memory
{        element's identification register.
{
{      where <serial number> is the serial number from the
{        memory element's identification register.
{
{      where <symptom> is the symptom/action statement provided
{        by the system. The text of the possible symptom statement
{        is identical in content to the uppercase text described
{        under counter value 2 below.
{
{    The counter-value portion of this statistic contains:
{
{    1. Operating System (OS) action code as described in section
{       4.2 of the DFT/OS Interface Specification. (DCS # ARH6853)
{
{    2. This word contains a 12-bit DFT analysis code followed by
{       an 8-bit sequence number stored in bits 44-63 of the word.
{       The sequence number indicates the sequential order in which
{       a series of statistics occurred, and ranges from 0-255(10).
{       Dedicated Fault Tolerance (DFT) analysis code is described
{       in section 4.4 of the DFT/OS Interface Specification.
{
{         708 TOP OF HOUR SECDED ID TABLE.
{
{    3. Memory Option Installed Maintenance Register.
{
{    4. Memory Element ID Register.
{
{    5. The content of words 5-14 contain the SECDED ID Table. A
{       detailed description of the SECDED ID Table is located
{       in section 3.1.5 of the DFT/OS Interface Specification.
{
{    The SECDED ID Table is used by DFT to record central memory
{    single bit errors. There are ten entries in this table and
{    each entry represents one unique error. Counter-value word
{    3 contains the Memory Option Installed Maintenance Register.
{    The copy of the SECDED ID Table is stored beginning at
{    counter-value word 4.
{
  CONST
    cml$top_of_hour_secded_id = cmc$min_ecc + 1005;

*copyc cmc$condition_limits
*DECK DECK=CMM$ACCESS_DEVICE_FILES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE CM : Access Device Files' ??
MODULE cmm$access_device_files;

{ PURPOSE:

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cme$logical_configuration_mgr
*copyc cme$access_device_files
*copyc cmc$default_vsn
*copyc cmt$device_file_header
*copyc cmk$keypoints
*copyc gft$system_file_identifier
*copyc osd$integer_limits
?? POP ??
*copyc amp$get_next
*copyc amp$put_next
*copyc cmp$change_new_df_entry
*copyc cmp$manage_device_file_lock
*copyc dmp$attach_device_file
*copyc dmp$close_file
*copyc dmp$detach_device_file
*copyc dmp$open_file
*copyc i#move
*copyc mmp$write_modified_pages
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc cmv$new_device_file
*copyc cmv$physical_configuration
  VAR
    cmv$use_installed_configuration : [XREF] boolean;
*copyc dmv$system_device_information
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  CONST
    c$current_version_number = 'SECOND VERSION NUMBER 2        ';
?? OLDTITLE ??
?? NEWTITLE := 'attach_device_file', EJECT ??

  PROCEDURE attach_device_file
    (    device_file_name: ost$name;
         recorded_vsn: rmt$recorded_vsn;
     VAR segment_pointer: mmt$segment_pointer;
     VAR system_file_id: gft$system_file_identifier;
     VAR status: ost$status);

    status.normal := TRUE;

    dmp$attach_device_file (recorded_vsn, device_file_name, system_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    segment_pointer.kind := mmc$sequence_pointer;
    dmp$open_file (system_file_id, osc$tsrv_ring, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_random,
          segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND attach_device_file;
?? OLDTITLE ??
?? NEWTITLE := 'close_device_file', EJECT ??

  PROCEDURE close_device_file
    (    segment_p: mmt$segment_pointer;
         system_file_id: gft$system_file_identifier;
     VAR status: ost$status);

    VAR
      file_modified: boolean,
      fmd_modified: boolean;

    status.normal := TRUE;
    dmp$close_file (#LOC (segment_p.seq_pointer^), status);
    IF status.normal THEN
      dmp$detach_device_file (system_file_id, file_modified, fmd_modified, status);
    IFEND;

  PROCEND close_device_file;
?? OLDTITLE ??
?? NEWTITLE := 'copy_bam_file_to_df', EJECT ??

  PROCEDURE copy_bam_file_to_df
    (    bam_fid: amt$file_identifier;
         file_status: cmt$device_file_status;
         file_version: ost$name;
     VAR seq_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      bam_el: string (osc$max_string_size),
      byte_address: amt$file_byte_address,
      cell_p: ^cell,
      df_header_p: ^cmt$device_file_header_v2,
      file_position: amt$file_position,
      ignore_status: ost$status,
      line_count: integer,
      size_line_p: ^ost$non_negative_integers,
      text_el_p: ^string ( * ),
      transfer_count: amt$transfer_count;

    status.normal := TRUE;

   /main_program/
    BEGIN
      RESET seq_p;
      NEXT df_header_p IN seq_p;
      df_header_p^.being_updated := cmc$being_updated;
      mmp$write_modified_pages (df_header_p, #SIZE (cmt$device_file_header_v2), osc$wait, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      df_header_p^.version := file_version;
      df_header_p^.status := file_status;

      { Move the information to the device file.

      line_count := 0;

     /read_loop/
      WHILE TRUE DO
        amp$get_next (bam_fid, ^bam_el, #SIZE (bam_el), transfer_count, byte_address, file_position, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        IF file_position = amc$eoi THEN
          EXIT /read_loop/;
        IFEND;
        NEXT size_line_p IN seq_p;
        size_line_p^ := transfer_count;
        NEXT text_el_p: [transfer_count] IN seq_p;
        cell_p := ^bam_el;
        i#move (cell_p, text_el_p, transfer_count);
        line_count := line_count + 1;
      WHILEND /read_loop/;

      df_header_p^.length := line_count;
      df_header_p^.changed := TRUE;
      mmp$write_modified_pages (df_header_p, line_count + #SIZE (cmt$device_file_header_v2), osc$wait,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
    END /main_program/;

    { Set the being_updated flag to false and write pages to disk.

    df_header_p^.being_updated := cmc$valid_data_in_file;
    mmp$write_modified_pages (df_header_p, #SIZE (cmt$device_file_header_v2), osc$wait, ignore_status);

  PROCEND copy_bam_file_to_df;
?? OLDTITLE ??
?? NEWTITLE := 'copy_df_to_bam_file', EJECT ??

  PROCEDURE copy_df_to_bam_file
    (    bam_fid: amt$file_identifier;
     VAR seq_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      df_header_p: ^cmt$device_file_header_v2,
      ignore_file_byte_address : amt$file_byte_address,
      loop_index: integer,
      size_line_p: ^ost$non_negative_integers,
      text_el_p: ^string ( * );

    status.normal := TRUE;
    RESET seq_p;
    NEXT df_header_p IN seq_p;
    IF df_header_p^.being_updated <> cmc$valid_data_in_file THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$adf_incomplete_device_file,
            cmv$new_device_file.name, status);
      RETURN;
    IFEND;

    IF df_header_p^.version <> c$current_version_number THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$adf_illegal_version,
            df_header_p^.version, status);
      RETURN;
    IFEND;

    { Move the information from the device file.

    FOR loop_index := 1 TO df_header_p^.length DO
      NEXT size_line_p IN seq_p;
      NEXT text_el_p: [size_line_p^] IN seq_p;
      IF text_el_p <> NIL THEN
        amp$put_next (bam_fid, text_el_p, size_line_p^, ignore_file_byte_address, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND copy_df_to_bam_file;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$copy_active_configuration', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$copy_active_configuration
    (VAR configuration_p: ^ARRAY [1 .. *] OF cmt$element_definition;
     VAR status: ost$status);

    VAR
      index: integer;

    status.normal := TRUE;
    FOR index := 1 TO UPPERBOUND (cmv$physical_configuration^) DO
      configuration_p^ [index] := cmv$physical_configuration^ [index];
    FOREND;

  PROCEND cmp$copy_active_configuration;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_conf_file', EJECT ??

{ PURPOSE:
{   This procedure retrieves either the logical or physical configuration stored on a device file.  The data
{   is stored on a BAM file with segment access in the form of a sequence.  The device file is either active
{   or installed.

  PROCEDURE [XDCL, #GATE] cmp$get_conf_file
    (    bam_fid: amt$file_identifier;
     VAR status: ost$status);

    VAR
      df_header_p: ^cmt$device_file_header_v2,
      close_status: ost$status,
      segment_pointer: mmt$segment_pointer,
      sfid: gft$system_file_identifier;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, cmk$get_conf_file);

    attach_device_file (cmv$new_device_file.name, cmv$new_device_file.recorded_vsn, segment_pointer, sfid,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

   /file_open/
    BEGIN
      RESET segment_pointer.seq_pointer;
      NEXT df_header_p IN segment_pointer.seq_pointer;
      IF df_header_p = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$adf_nil_element_pointer, 'DEVICE FILE',
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'CMP$GET_CONF_FILE', status);
        EXIT /file_open/;
      IFEND;

      IF df_header_p^.being_updated <> cmc$valid_data_in_file THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$adf_incomplete_device_file,
              cmv$new_device_file.name, status);
        EXIT /file_open/;
      IFEND;
      copy_df_to_bam_file (bam_fid, segment_pointer.seq_pointer, status);
    END /file_open/;

    close_device_file (segment_pointer, sfid, close_status);
    IF status.normal THEN
      status := close_status;
    IFEND;
    IF NOT status.normal AND NOT cmv$use_installed_configuration THEN
      status.normal := TRUE;
    IFEND;
    #KEYPOINT (osk$exit, 0, cmk$get_conf_file);

  PROCEND cmp$get_conf_file;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_number_of_element', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_number_of_element
    (VAR element_count: integer;
     VAR status: ost$status);

    status.normal := TRUE;
    IF cmv$physical_configuration = NIL THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_empty_lc, ' ', status);
      RETURN;
    IFEND;

    element_count := UPPERBOUND (cmv$physical_configuration^);

  PROCEND cmp$get_number_of_element;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$initialize_dft', EJECT ??

{ PURPOSE:
{   This procedure initializes the device file table.  This procedure will attach each device file, validate
{   the status of the file, and set the corresponding entry in the device file table.

  PROCEDURE [XDCL] cmp$initialize_dft
    (VAR status: ost$status);

    VAR
      device_file_record: cmt$device_file_record,
      df_header_p: ^cmt$device_file_header_v2,
      ignore_status: ost$status,
      recorded_vsn: rmt$recorded_vsn,
      segment_pointer: mmt$segment_pointer,
      system_file_id: gft$system_file_identifier;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, cmk$initialize_dft);

   /main_program/
    BEGIN
      device_file_record := cmv$new_device_file;
      recorded_vsn := cmv$new_device_file.recorded_vsn;
      IF recorded_vsn = cmc$default_vsn THEN
        recorded_vsn := dmv$system_device_recorded_vsn;
        device_file_record.recorded_vsn := recorded_vsn;
      IFEND;
      attach_device_file (device_file_record.name, recorded_vsn, segment_pointer, system_file_id, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      RESET segment_pointer.seq_pointer;
      NEXT df_header_p IN segment_pointer.seq_pointer;
      IF df_header_p = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$adf_nil_element_pointer, 'DEVICE FILE',
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'CMP$INITIALIZE_DFT', status);
        close_device_file (segment_pointer, system_file_id, ignore_status);
        EXIT /main_program/;
      IFEND;

      device_file_record.version := df_header_p^.version;
      device_file_record.status := df_header_p^.status;
      device_file_record.relative_time := df_header_p^.relative_time;
      close_device_file (segment_pointer, system_file_id, status);
      cmp$change_new_df_entry (device_file_record);
    END /main_program/;

    #KEYPOINT (osk$exit, 0, cmk$initialize_dft);

  PROCEND cmp$initialize_dft;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$install_conf_file', EJECT ??

{ PURPOSE:
{   This procedure installs the bam file provided as a device file and marks the device file as installed,
{   both on the device file and in the device file table.

  PROCEDURE [XDCL, #GATE] cmp$install_conf_file
    (    bam_fid: amt$file_identifier;
     VAR status: ost$status);

    VAR
      close_status: ost$status,
      device_file_record: cmt$device_file_record,
      df_header_p: ^cmt$device_file_header_v2,
      segment_pointer: mmt$segment_pointer,
      system_file_id: gft$system_file_identifier;

    status.normal := TRUE;

    { Set global lock to prevent concurrent update of the device file.

    cmp$manage_device_file_lock ({set_lock = }TRUE, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

   /lock_set/
    BEGIN
      attach_device_file (cmv$new_device_file.name, cmv$new_device_file.recorded_vsn, segment_pointer,
            system_file_id, status);
      IF NOT status.normal THEN
        EXIT /lock_set/;
      IFEND;

     /file_open/
      BEGIN

        { Update headers.

        RESET segment_pointer.seq_pointer;
        NEXT df_header_p IN segment_pointer.seq_pointer;
        IF df_header_p = NIL THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$adf_nil_element_pointer,
                'DEVICE FILE', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'CMP$INSTALL_CONF_FILE', status);
          EXIT /file_open/;
        IFEND;

        copy_bam_file_to_df (bam_fid, cmc$dfs_active, c$current_version_number, segment_pointer.seq_pointer,
              status);
        IF NOT status.normal THEN
          EXIT /file_open/;
        IFEND;

        device_file_record := cmv$new_device_file;
        device_file_record.status := cmc$dfs_active;
        device_file_record.version := c$current_version_number;
        cmp$change_new_df_entry (device_file_record);
      END /file_open/;

      close_device_file (segment_pointer, system_file_id, close_status);
      IF status.normal THEN
        status := close_status;
      IFEND;
    END /lock_set/;
    cmp$manage_device_file_lock ({set_lock = }FALSE, close_status);
    IF status.normal THEN
      status := close_status;
    IFEND;

    #KEYPOINT (osk$entry, 0, cmk$install_conf_file);

  PROCEND cmp$install_conf_file;
?? OLDTITLE ??
MODEND cmm$access_device_files;
*DECK DECK=CMM$ACQUIRE_SYSTEM_DEVICE EXPAND=TRUE
*DECK DECK=CMM$ACTION_MESSAGES EXPAND=TRUE
~"  CREATE_MESSAGE_MODULE CMM$ACTION_MESSAGES$US_ENGLISH
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CHANNEL_DISABLED

              NOS/VE Reconfiguration Message

 Status           : NOS/VE disabled an element, a mass storage channel.
 Disabled Element : ~P1

 Please inform the Customer Engineer.
 Use the DISPLAY_ACTIVE_VOLUMES command to determine if any volumes are
   unavailable as a result of this action.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTROLLER_DISABLED

             NOS/VE Reconfiguration Message

 Status             : NOS/VE disabled an element, a mass storage controller.
 Disabled Element   : ~P1
 Element Identifier : ~P2
 Serial Number      : ~P3

 Please inform the Customer Engineer.
 Use the DISPLAY_ACTIVE_VOLUMES command to determine if any volumes are
   unavailable as a result of this action.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=UNIT_DISABLED

             NOS/VE Reconfiguration Message

 Status             : NOS/VE disabled an element, a mass storage unit.
 Disabled Element   : ~P1
 Element Identifier : ~P2
 Serial Number      : ~P3
 Volume             : ~P4

 Please inform the Customer Engineer.
 Use the DISPLAY_ACTIVE_VOLUMES command to determine which mass
   storage classes are affected by this action.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=RECONFIGURE_CHANNEL

             NOS/VE Reconfiguration Message

 Status           : NOS/VE disabled an element, a mass storage channel.
 Disabled Element : ~P1
 Enabled Path(s)  : ~P2
                    ~P3
                    ~P4
                    ~P5

 ~P6
 Please inform the Customer Engineer.
 Use the DISPLAY_ACTIVE_VOLUMES command to determine if any volumes are
   unavailable as a result of the reconfiguration.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=RECONFIGURE_CONTROLLER

             NOS/VE Reconfiguration Message

 Status           : NOS/VE disabled an element, a mass storage controller.
 Disabled Element : ~P1
 Enabled Path(s)  : ~P2
                    ~P3
                    ~P4
                    ~P5

 ~P6
 Please inform the Customer Engineer.
 Use the DISPLAY_ACTIVE_VOLUMES command to determine if any volumes are
   unavailable as a result of the reconfiguration.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=RECONFIGURE_UNIT

             NOS/VE Reconfiguration Message

 Status              : NOS/VE disabled a connection between a mass storage
                       controller and a unit
 Disabled Connection : ~P1
 Disabled Path       : ~P2
 Enabled Path        : ~P3

 ~P4
 Please inform the Customer Engineer.
 Use the DISPLAY_ACTIVE_VOLUMES command to determine if any volumes are
   unavailable as a result of the reconfiguration.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTROLLER_OVERTEMP

             NOS/VE Element Status Message

 Status              : A mass storage controller has encountered an
                       OVER TEMPERATURE condition.
 Controller Element  : ~P1

 Please inform the Customer Engineer.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=DAS_DRIVE_HEAD_SHIFT_WARNING

             NOS/VE Element Status Message

 Status               : A probable head shift condition has been
                        detected on a DAS disk drive. Action should
                        be taken to correct this condition as soon
                        as possible.
 Element              : ~P1
 Element Identifier   : ~P2
 Recorded VSN         : ~P3
 Physical Unit Number : ~P4

 Please inform the Customer Engineer.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=SSD_BATTERY_ALERT

             NOS/VE Element Status Message

 Status               : A problem has been detected with an SSD
                        back-up battery pack. Action should be
                        taken to correct this condition as soon
                        as possible.
 Element              : ~P1
 Element Identifier   : ~P2
 Recorded VSN         : ~P3
 Physical Unit Number : ~P4
 Battery Condition    : ~P5
 Please inform the Customer Engineer.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PARITY_PROTECTION_DISABLED

             NOS/VE Element Status Message

 Status               : Parity Protection for an element is disabled.
                        One physical unit in a parity device is not
                        operational.
 Element              : ~P1
 Element Identifier   : ~P2
 Recorded VSN         : ~P3
 Physical Unit Number : ~P4

 Please inform the Customer Engineer.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
*DECK DECK=CMM$CONFIGURATION_INTERFACE_13D EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'Configuration interface (13D)' ??
MODULE cmm$configuration_interface_13d;

?? PUSH (LISTEXT := ON) ??
*copyc cme$logical_configuration_mgr
*copyc cme$physical_configuration_mgr
*copyc cmt$element_descriptor
*copyc cmt$physical_identification
*copyc oss$mainframe_pageable
*copyc oss$mainframe_paged_literal
?? POP ??
*copyc clp$convert_integer_to_string
*copyc cmp$convert_channel_number
*copyc cmp$convert_iou_name
*copyc cmp$convert_iou_number
*copyc cmp$get_logical_pp_index
*copyc cmp$get_logical_unit_number
*copyc cmp$pc_get_element
*copyc cmp$pc_get_logical_unit
*copyc cmp$retrieve_logical_pp_index
*copyc cmp$search_active_volume_table
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc cmv$physical_configuration
*copyc cmv$state_info_table
*copyc dsp$retrieve_channel_type
*copyc dsp$retrieve_iou_information
*copyc iov$tusl_p
*copyc osp$append_status_integer
*copyc osp$set_status_abnormal

  VAR
    v$cip_driver_name: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [cmt$controller_type] OF
          ARRAY [boolean] OF dst$driver_name :=
          { NIO driver, CIO driver }
          [['DSK7154', 'DSK7154'], ['DSK55A ', 'DSK55C7'], ['DSK55A ', 'DSK55C7'], ['D895   ', 'D895CIO'],
           ['DSKI   ', 'E9P9853'], ['       ', 'HYD    '], ['E5P5831', 'E9P5831'], ['TAPE   ', 'TAPE   '],
           ['TAPE   ', 'TAPE   '], ['ISD    ', '       '], ['ISD    ', '       '], ['TAPB   ', '       '],
           ['E2X5680', 'E2X5680'], ['TAPE   ', '       '], ['TAPE   ', 'TAPE   '], ['TAPC   ', 'TAPD   '],
           ['VM5B   ', 'VM5B   '], ['E1C2629', '       '], ['E1C380 ', 'E1A380 '], ['E1C2620', 'E1A2620'],
           ['E1C2620', 'E1A2620'], ['E1C5380', 'E1A5380'], ['E5P4000', 'E9P4000'], ['       ', '       ']],

    v$iou_program_name: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [cmt$controller_type] OF
          ARRAY [boolean] OF dst$driver_name :=
          { NIO driver, CIO driver }
          [['DSKE   ', 'DSKE   '], ['E1C7155', 'E1A7155'], ['E1C7155', 'E1A7155'], ['E2C7165', 'E9A7165'],
           ['E5P9836', 'E9P9853'], ['       ', 'E9S887 '], ['E5P5831', 'E9P5831'], ['E1C7021', 'E1A7021'],
           ['E1C7021', 'E1A7021'], ['E1I7255', '       '], ['E1I7255', '       '], ['E5I9639', '       '],
           ['E2C5680', 'E2A5680'], ['E1C7021', '       '], ['E1C7021', 'E1A7021'], ['E5P5698', 'E9P5698'],
           ['E1C6535', 'E1A6535'], ['E1C2629', '       '], ['E1C380 ', 'E1A380 '], ['E1C2620', 'E1A2620'],
           ['E1C2620', 'E1A2620'], ['E1C5380', 'E1A5380'], ['E5P4000', 'E9P4000'], ['       ', '       ']];

  VAR
    cmv$post_deadstart: [XDCL, #GATE, oss$mainframe_pageable] boolean := FALSE,

{ 20 physical pps in octal   : 0..7, 10, 11, 20..27, 30, 31.
{                    decimal : 0..7,  8,  9, 16..23, 24, 25.

    cmv$valid_pp_names: { Array must be sorted }
          [STATIC, READ, oss$mainframe_paged_literal] array [1 .. 40] of cmt$element_name :=
          ['CPP0                           ', 'CPP1                           ',
          'CPP16                          ', 'CPP17                          ',
          'CPP18                          ', 'CPP19                          ',
          'CPP2                           ', 'CPP20                          ',
          'CPP21                          ', 'CPP22                          ',
          'CPP23                          ', 'CPP24                          ',
          'CPP25                          ', 'CPP3                           ',
          'CPP4                           ', 'CPP5                           ',
          'CPP6                           ', 'CPP7                           ',
          'CPP8                           ', 'CPP9                           ',
          'PP0                            ', 'PP1                            ',
          'PP16                           ', 'PP17                           ',
          'PP18                           ', 'PP19                           ',
          'PP2                            ', 'PP20                           ',
          'PP21                           ', 'PP22                           ',
          'PP23                           ', 'PP24                           ',
          'PP25                           ', 'PP3                            ',
          'PP4                            ', 'PP5                            ',
          'PP6                            ', 'PP7                            ',
          'PP8                            ', 'PP9                            '],

{ Array of channel names must be sorted

    cmv$default_channel_names: [STATIC, READ, oss$mainframe_paged_literal] array [1 .. 96] of
          cmt$element_name := ['CCH0                      ', 'CCH0A                     ',
          'CCH0B                     ', 'CCH1                      ', 'CCH10                     ',
          'CCH11                     ', 'CCH12                     ', 'CCH13                     ',
          'CCH14                     ', 'CCH15                     ', 'CCH16                     ',
          'CCH16A                    ', 'CCH16B                    ', 'CCH17                     ',
          'CCH17A                    ', 'CCH17B                    ', 'CCH18                     ',
          'CCH18A                    ', 'CCH18B                    ', 'CCH19                     ',
          'CCH19A                    ', 'CCH19B                    ', 'CCH1A                     ',
          'CCH1B                     ', 'CCH2                      ', 'CCH20                     ',
          'CCH20A                    ', 'CCH20B                    ', 'CCH21             ',
          'CCH21A            ', 'CCH21B            ', 'CCH22             ', 'CCH22A            ',
          'CCH22B            ', 'CCH23             ', 'CCH23A            ', 'CCH23B            ',
          'CCH24             ', 'CCH24A            ', 'CCH24B            ', 'CCH25             ',
          'CCH25A            ', 'CCH25B            ', 'CCH26             ', 'CCH27             ',
          'CCH2A             ', 'CCH2B             ', 'CCH3              ', 'CCH3A             ',
          'CCH3B             ', 'CCH4              ', 'CCH4A             ', 'CCH4B             ',
          'CCH5              ', 'CCH5A             ', 'CCH5B             ', 'CCH6              ',
          'CCH6A             ', 'CCH6B             ', 'CCH7              ', 'CCH7A             ',
          'CCH7B             ', 'CCH8              ', 'CCH8A             ', 'CCH8B             ',
          'CCH9              ', 'CCH9A             ', 'CCH9B             ', 'CH0               ',
          'CH1               ', 'CH10              ', 'CH11              ', 'CH12              ',
          'CH13              ', 'CH14              ', 'CH15              ', 'CH16              ',
          'CH17              ', 'CH18              ', 'CH19              ', 'CH2               ',
          'CH20              ', 'CH21              ', 'CH22              ', 'CH23              ',
          'CH24              ', 'CH25              ', 'CH26              ', 'CH27              ',
          'CH3               ', 'CH4               ', 'CH5               ', 'CH6               ',
          'CH7               ', 'CH8               ', 'CH9               '];


?? TITLE := '  cmp$valid_channel_name', EJECT ??

  FUNCTION [XDCL, #GATE] cmp$valid_channel_name
    (    channel_name: cmt$element_name): boolean;

    VAR
      temp: integer,
      found: boolean,
      index: integer,
      high: integer,
      low: integer,
      middle: integer;

    found := FALSE;
    low := LOWERBOUND (cmv$default_channel_names);
    high := UPPERBOUND (cmv$default_channel_names);
    WHILE (low <= high) AND NOT found DO
      temp := low + high;
      middle := temp DIV 2;
      IF cmv$default_channel_names [middle] = channel_name THEN
        found := TRUE;
      ELSEIF channel_name < cmv$default_channel_names [middle] THEN
        high := middle - 1;
      ELSEIF channel_name > cmv$default_channel_names [middle] THEN
        low := middle + 1;
      IFEND;
    WHILEND;
    cmp$valid_channel_name := found;
  FUNCEND cmp$valid_channel_name;


?? TITLE := '  valid_pp_name', EJECT ??

  FUNCTION valid_pp_name
    (    pp_name: cmt$element_name): boolean;

    VAR
      temp: integer,
      found: boolean,
      index: integer,
      high: integer,
      low: integer,
      middle: integer;

    found := FALSE;
    low := LOWERBOUND (cmv$valid_pp_names);
    high := UPPERBOUND (cmv$valid_pp_names);
    WHILE (low <= high) AND NOT found DO
      temp := low + high;
      middle := temp DIV 2;
      IF cmv$valid_pp_names [middle] = pp_name THEN
        found := TRUE;
      ELSEIF pp_name < cmv$valid_pp_names [middle] THEN
        high := middle - 1;
      ELSEIF pp_name > cmv$valid_pp_names [middle] THEN
        low := middle + 1;
      IFEND;
    WHILEND;
    valid_pp_name := found;
  FUNCEND valid_pp_name;

?? TITLE := '  cmp$convert_channel_ordinal', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$convert_channel_ordinal
    (    channel_ordinal: cmt$channel_ordinal;
     VAR channel_name: cmt$element_name;
     VAR channel_number: ost$physical_channel_number;
     VAR concurrent: boolean;
     VAR channel_port: cmt$channel_port;
     VAR status: ost$status);

    VAR
      port: string (1),
      str: ost$string;

{ PURPOSE : This procedure convert the internal CM type channel ordinal
{   Into the equivalent channel name, channel number.

    status.normal := TRUE;
    concurrent := TRUE;
    port := ' ';
    channel_port := cmc$unspecified_port;
    CASE channel_ordinal OF
    = cmc$channel0 .. cmc$channel27 =
      concurrent := FALSE;
      channel_number := $INTEGER (channel_ordinal);
    = cmc$cio_channel0_porta .. cmc$cio_channel9_portb =
      channel_number := ($INTEGER (channel_ordinal) - $INTEGER (cmc$cio_channel0_porta)) DIV 2;
      IF ($INTEGER (channel_ordinal) - $INTEGER (cmc$cio_channel0_porta)) MOD 2 = 1 THEN
        port := 'B';
      ELSE
        port := 'A';
      IFEND;
    = cmc$cio_channel16_porta .. cmc$cio_channel25_portb =
      channel_number := ($INTEGER (channel_ordinal) - 16) DIV 2;
      IF ($INTEGER (channel_ordinal) - 16) MOD 2 = 1 THEN
        port := 'B';
      ELSE
        port := 'A';
      IFEND;

    = cmc$cio_channel0 .. cmc$cio_channel27 =
      channel_number := $INTEGER (channel_ordinal) - $INTEGER (cmc$cio_channel0);
    ELSE
      osp$set_status_abnormal (cmc$configuration_management_id, cme$cm_end_case_error,
            'CMP$CONVERT_CHANNEL_ORDINAL', status);
    CASEND;

    clp$convert_integer_to_string (channel_number, 10, FALSE, str, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF concurrent THEN
      channel_name := 'CCH';
      channel_name (4, str.size) := str.value;
      IF port <> ' ' THEN
        channel_name (str.size + 4, 1) := port;
        IF port = 'A' THEN
          channel_port := cmc$port_a;
        ELSE
          channel_port := cmc$port_b;
        IFEND;
      IFEND;
    ELSE
      channel_name := 'CH';
      channel_name (3, str.size) := str.value;
    IFEND;

  PROCEND cmp$convert_channel_ordinal;

?? TITLE := '   cmp$determine_active_path', EJECT ??

{ PURPOSE:
{   This procedure determines if a given channel, controller and mass storage
{   unit are currently active. This is determined by checking for a non-zero
{   UIT RMA in the unit descriptor entry of the PP interface table.
{   This interface expects all three elements to be of the correct type and
{   that they are members of a valid path.


  PROCEDURE [XDCL, #GATE] cmp$determine_active_path
    (    channel_element: cmt$element_definition;
         controller_element: cmt$element_definition;
         unit_element: cmt$element_definition;
     VAR active: boolean;
     VAR status: ost$status);

    VAR
      controller_number: cmt$physical_equipment_number,
      logical_pp_index: iot$pp_number,
      logical_unit: iot$logical_unit,
      ppit_p: ^iot$pp_interface_table;

    status.normal := TRUE;
    active := FALSE;

    cmp$get_logical_pp_index (channel_element, logical_pp_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    ppit_p := cmv$logical_pp_table_p^ [logical_pp_index].pp_info.pp_interface_table_p;

    controller_number := controller_element.controller.physical_equipment_number;

    cmp$get_logical_unit_number (unit_element.element_name, logical_unit, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    active := (ppit_p^.unit_descriptors [logical_unit].unit_interface_table <> NIL) AND
          (ppit_p^.unit_descriptors [logical_unit].physical_path.controller_number = controller_number) AND
          (ppit_p^.unit_descriptors [logical_unit].unit_interface_table_rma <> 0);

  PROCEND cmp$determine_active_path;

?? TITLE := '  cmp$format_error_message', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$format_error_message
    (    element_descriptor: cmt$element_descriptor;
         physical_id: cmt$physical_identification;
         specified_physical_id: boolean;
         condition: integer;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      str: ost$string,
      text: string (255),
      concurrent: boolean,
      channel_name: cmt$element_name,
      channel_port: cmt$channel_port,
      channel_number: ost$physical_channel_number,
      index: integer;

{ PURPOSE: This procedure format the error message to include the
{   physical path of the form IOU # CH # EQ # UN #.


    text := '           ';

    IF specified_physical_id THEN
      IF physical_id.product_identification.product_number <> '      ' THEN
        text (1, 6) := physical_id.product_identification.product_number;
        text (7, 1) := physical_id.product_identification.underscore;
        text (8, 3) := physical_id.product_identification.model_number;
        text (12, 6) := physical_id.serial_number;

        osp$set_status_abnormal (cmc$configuration_management_id, condition, text (1, 18), status);

      ELSE
        text (1, 5) := physical_id.hardware_address.iou (1, 5);
        IF (cmc$channel IN physical_id.hardware_address.physical_address_specifier) AND
              (cmc$channel_address IN physical_id.hardware_address.physical_address_specifier) AND
              (cmc$unit_address IN physical_id.hardware_address.physical_address_specifier) THEN
          cmp$convert_channel_ordinal (physical_id.hardware_address.channel.ordinal, channel_name,
                channel_number, concurrent, channel_port, local_status);
          text (6, 6) := channel_name (1, 6);
          index := 12;
          clp$convert_integer_to_string (physical_id.hardware_address.channel_address, 10, FALSE, str,
                local_status);
          text (index, 3) := ' EQ';
          text (index + 3, str.size) := str.value (1, str.size);
          index := index + str.size + 4;
          clp$convert_integer_to_string (physical_id.hardware_address.unit_address, 10, FALSE, str,
                local_status);
          text (index, 3) := ' UN';
          text (index + 3, str.size) := str.value (1, str.size);
          index := index + str.size + 3;

        ELSEIF (cmc$channel IN physical_id.hardware_address.physical_address_specifier) AND
              (cmc$channel_address IN physical_id.hardware_address.physical_address_specifier) THEN
          cmp$convert_channel_ordinal (physical_id.hardware_address.channel.ordinal, channel_name,
                channel_number, concurrent, channel_port, local_status);
          text (6, 6) := channel_name (1, 6);
          index := 12;
          clp$convert_integer_to_string (physical_id.hardware_address.channel_address, 10, FALSE, str,
                local_status);
          text (index, 3) := ' EQ';
          text (index + 3, str.size) := str.value (1, str.size);
          index := index + str.size + 3;

        ELSEIF (cmc$channel IN physical_id.hardware_address.physical_address_specifier) THEN
          cmp$convert_channel_ordinal (physical_id.hardware_address.channel.ordinal, channel_name,
                channel_number, concurrent, channel_port, local_status);
          text (6, 6) := channel_name (1, 6);
          index := 12;

        ELSE
        IFEND;

        osp$set_status_abnormal (cmc$configuration_management_id, condition, text (1, index), status);

      IFEND;

    ELSE

      CASE element_descriptor.element_type OF

      = cmc$data_channel_element =
        text (1, 5) := element_descriptor.channel_descriptor.iou (1, 5);
        IF element_descriptor.channel_descriptor.use_logical_identification THEN
          text (6, * ) := element_descriptor.channel_descriptor.name;
        ELSE
          cmp$convert_channel_ordinal (element_descriptor.channel_descriptor.channel_ordinal, channel_name,
                channel_number, concurrent, channel_port, local_status);
          text (6, * ) := channel_name;
        IFEND;
        index := 37;

      = cmc$controller_element, cmc$storage_device_element, cmc$external_processor_element,
            cmc$channel_adapter_element, cmc$communications_element =

        CASE element_descriptor.peripheral_descriptor.use_logical_identification OF

        = TRUE =
          text (1, * ) := element_descriptor.peripheral_descriptor.element_name;
          index := 31;
        = FALSE =
          text (1, 5) := element_descriptor.peripheral_descriptor.hardware_address.iou (1, 5);
          IF (cmc$channel IN element_descriptor.peripheral_descriptor.hardware_address.
                physical_address_specifier) AND (cmc$channel_address IN
                element_descriptor.peripheral_descriptor.hardware_address.physical_address_specifier) AND
                (cmc$unit_address IN element_descriptor.peripheral_descriptor.hardware_address.
                physical_address_specifier) THEN
            cmp$convert_channel_ordinal (element_descriptor.peripheral_descriptor.hardware_address.channel.
                  ordinal, channel_name, channel_number, concurrent, channel_port, local_status);
            text (6, 6) := channel_name (1, 6);
            index := 12;
            clp$convert_integer_to_string (element_descriptor.peripheral_descriptor.hardware_address.
                  channel_address, 10, FALSE, str, local_status);
            text (index, 3) := ' EQ';
            text (index + 3, str.size) := str.value (1, str.size);
            index := index + str.size + 4;
            clp$convert_integer_to_string (element_descriptor.peripheral_descriptor.hardware_address.
                  unit_address, 10, FALSE, str, local_status);
            text (index, 3) := ' UN';
            text (index + 3, str.size) := str.value (1, str.size);
            index := index + str.size + 3;

          ELSEIF (cmc$channel IN element_descriptor.peripheral_descriptor.hardware_address.
                physical_address_specifier) AND (cmc$channel_address IN
                element_descriptor.peripheral_descriptor.hardware_address.physical_address_specifier) THEN
            cmp$convert_channel_ordinal (element_descriptor.peripheral_descriptor.hardware_address.channel.
                  ordinal, channel_name, channel_number, concurrent, channel_port, local_status);
            text (6, 6) := channel_name (1, 6);
            index := 12;
            clp$convert_integer_to_string (element_descriptor.peripheral_descriptor.hardware_address.
                  channel_address, 10, FALSE, str, local_status);
            text (index, 3) := ' EQ';
            text (index + 3, str.size) := str.value (1, str.size);
            index := index + str.size + 3;

          ELSEIF (cmc$channel IN element_descriptor.peripheral_descriptor.hardware_address.
                physical_address_specifier) THEN
            cmp$convert_channel_ordinal (element_descriptor.peripheral_descriptor.hardware_address.channel.
                  ordinal, channel_name, channel_number, concurrent, channel_port, local_status);
            text (6, 6) := channel_name (1, 6);
            index := 12;

          ELSE
          IFEND;

        CASEND;

      ELSE
      CASEND;

      osp$set_status_abnormal (cmc$configuration_management_id, condition, text (1, index), status);

    IFEND;

  PROCEND cmp$format_error_message;

?? TITLE := '   cmp$get_channel_def', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_channel_def
    (    channel_identification: cmt$channel_descriptor;
     VAR channel_definition: cmt$data_channel_definition;
     VAR status: ost$status);

    VAR
      found: boolean,
      ch_name: cmt$element_name,
      ch_number: ost$physical_channel_number,
      ch_ordinal: cmt$channel_ordinal,
      ch_port: cmt$channel_port,
      concurrent: boolean,
      element_descriptor: cmt$element_descriptor,
      error_string: string (80),
      exact_match: boolean,
      i: integer,
      iou_definition: cmt$iou_definition,
      iou_information_table: dst$iou_information_table,
      iou_name: cmt$element_name,
      iou_number: dst$iou_number,
      number: integer,
      number_of_ious: dst$number_of_ious,
      number_string: string (4),
      physical_id: cmt$physical_identification,
      string_index: 0 .. 31,
      string_length: integer,
      val: integer,
      valid: boolean;

    status.normal := TRUE;
    iou_name := 'IOU0';

    dsp$retrieve_iou_information (number_of_ious, iou_information_table);
    IF number_of_ious > 1 THEN
      iou_name := channel_identification.iou;
    IFEND;

    cmp$retrieve_iou_definition (iou_name, iou_definition, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$convert_iou_name (iou_name, iou_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF channel_identification.use_logical_identification THEN

      { Determine physical channel number from channel name.

      IF NOT cmp$valid_channel_name (channel_identification.name) THEN
        error_string := iou_name;
        error_string (7, * ) := channel_identification.name;
        osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_channel_name, error_string,
              status);
        RETURN;
      IFEND;

      i := 1;
      number_string := ' ';
      string_index := 0;
      WHILE (channel_identification.name (i) <> ' ') AND (i <= osc$max_name_size) DO
        IF (channel_identification.name (i) >= '0') AND (channel_identification.name (i) <= '9') THEN
          string_index := string_index + 1;
          number_string (string_index) := channel_identification.name (i);
        IFEND;
        i := i + 1;
      WHILEND;
      IF number_string = ' ' THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_channel_name,
              channel_identification.name, status);
        RETURN;
      IFEND;

      number := 0;
      val := 1;
      FOR i := string_index DOWNTO 1 DO
        IF number_string (i) <> ' ' THEN
          number := (number + (($INTEGER (number_string (i)) - $INTEGER ('0')) * val));
          val := val * 10;
        IFEND;
      FOREND;
      IF (number >= 0) AND (number <= 27) THEN
        ch_number := number;
      ELSE
        osp$set_status_abnormal (cmc$configuration_management_id, cme$illegal_channel_number,
              number_string, status);
        osp$append_status_integer (osc$status_parameter_delimiter, 0, 10, TRUE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, 27, 10, TRUE, status);
        RETURN;
      IFEND;

      concurrent := channel_identification.name (1, 2) = 'CC';
      ch_port := cmc$unspecified_port;
      IF concurrent THEN
        IF (channel_identification.name (5) = 'A') OR (channel_identification.name (6) = 'A') THEN
          ch_port := cmc$port_a;
        ELSEIF (channel_identification.name (5) = 'B') OR (channel_identification.name (6) = 'B') THEN
          ch_port := cmc$port_b;
        IFEND;
      IFEND;

      cmp$convert_channel_number (ch_number, concurrent, ch_port, ch_ordinal, ch_name, valid);
      IF NOT valid THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$illegal_channel_number,
              number_string, status);
        osp$append_status_integer (osc$status_parameter_delimiter, 0, 10, TRUE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, 27, 10, TRUE, status);
        RETURN;
      IFEND;
    ELSE

      ch_number := channel_identification.number;
      ch_ordinal := channel_identification.channel_ordinal;
      concurrent := channel_identification.concurrent;
      CASE ch_ordinal OF
      = cmc$cio_channel0_porta .. cmc$cio_channel9_portb =
        IF ($INTEGER (ch_ordinal) - $INTEGER (cmc$cio_channel0_porta)) MOD 2 = 1 THEN
          ch_port := cmc$port_b;
        ELSE
          ch_port := cmc$port_a;
        IFEND;
      = cmc$cio_channel16_porta .. cmc$cio_channel25_portb =
        IF ($INTEGER (ch_ordinal) - 16) MOD 2 = 1 THEN
          ch_port := cmc$port_b;
        ELSE
          ch_port := cmc$port_a;
        IFEND;
      ELSE
        ch_port := cmc$unspecified_port;
      CASEND;
      number_string := ' ';
      STRINGREP (number_string, string_length, ch_number);
    IFEND;

    found := FALSE;

    IF cmv$post_deadstart AND (cmv$physical_configuration <> NIL) THEN

     /pc_loop/
      FOR i := LOWERBOUND (cmv$physical_configuration^) TO UPPERBOUND (cmv$physical_configuration^) DO
        IF cmv$physical_configuration^ [i].element_type = cmc$data_channel_element THEN
          exact_match := (ch_port = cmv$physical_configuration^ [i].data_channel.port) AND
                (ch_number = cmv$physical_configuration^ [i].data_channel.number) AND
                (concurrent = cmv$physical_configuration^ [i].data_channel.concurrent) AND
                (iou_name = cmv$physical_configuration^ [i].data_channel.iou);
          IF exact_match THEN
            found := TRUE;
            EXIT /pc_loop/;
          ELSE
            IF (ch_number = cmv$physical_configuration^ [i].data_channel.number) AND
                  (concurrent = cmv$physical_configuration^ [i].data_channel.concurrent) AND
                  (iou_name = cmv$physical_configuration^ [i].data_channel.iou) THEN
              found := TRUE;
              channel_definition := cmv$physical_configuration^ [i].data_channel;
            IFEND;
          IFEND;
        IFEND;
      FOREND /pc_loop/;
    IFEND;

    { If no exact match is found then the CIO channel no port will be returned.

    IF found THEN
      IF exact_match THEN
        channel_definition := cmv$physical_configuration^ [i].data_channel;
      ELSE
        channel_definition.port := cmc$unspecified_port;
        cmp$convert_channel_number (channel_definition.number, concurrent, cmc$unspecified_port,
              channel_definition.ordinal, ch_name, valid);
      IFEND;
      RETURN;
    IFEND;

    { The channel was not found in the physical configuration table.

    channel_definition.number := ch_number;
    channel_definition.concurrent := concurrent;
    channel_definition.port := ch_port;
    channel_definition.ordinal := ch_ordinal;

    cmp$convert_channel_number (ch_number, concurrent, ch_port, ch_ordinal, ch_name, valid);
    IF NOT valid THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$illegal_channel_number,
            number_string, status);
      osp$append_status_integer (osc$status_parameter_delimiter, 0, 10, TRUE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, 27, 10, TRUE, status);
      RETURN;
    IFEND;

    FOR i := LOWERVALUE (ost$physical_pp_number) TO UPPERVALUE (ost$physical_pp_number) DO
      channel_definition.pps_capable_of_access [i] := FALSE;
    FOREND;
    CASE iou_definition.kind OF
    = dsc$imn_i0_5x_model =
      IF channel_definition.number <= 5 THEN
        FOR i := 0 TO 4 DO
          channel_definition.pps_capable_of_access [i] := TRUE;
        FOREND;
      ELSE
        FOR i := 20(8) TO 24(8) DO
          channel_definition.pps_capable_of_access [i] := TRUE;
        FOREND;
      IFEND;

    = dsc$imn_i4_40_model =
      IF channel_definition.concurrent THEN
        IF channel_definition.number <= 4 THEN
          FOR i := 0 TO 4 DO
            channel_definition.pps_capable_of_access [i] := TRUE;
          FOREND;
        ELSE
          FOR i := 5 TO 9 DO
            channel_definition.pps_capable_of_access [i] := TRUE;
          FOREND;
        IFEND;
      ELSE
        FOR i := LOWERVALUE (ost$physical_pp_number) TO UPPERVALUE (ost$physical_pp_number) DO
          channel_definition.pps_capable_of_access [i] := TRUE;
        FOREND;
      IFEND;

    = dsc$imn_i4_44_model, dsc$imn_i4_46_model =
      IF (channel_definition.number >= 2) AND (channel_definition.number <= 4) THEN
        FOR i := 0 TO 4 DO
          channel_definition.pps_capable_of_access [i] := TRUE;
        FOREND;
      ELSEIF (channel_definition.number >= 5) AND (channel_definition.number <= 11(8)) THEN
        FOR i := 5 TO 11(8) DO
          channel_definition.pps_capable_of_access [i] := TRUE;
        FOREND;
      ELSEIF (channel_definition.number >= 12(8)) AND (channel_definition.number <= 17(8)) THEN
        FOR i := LOWERVALUE (ost$physical_pp_number) TO UPPERVALUE (ost$physical_pp_number) DO
          channel_definition.pps_capable_of_access [i] := TRUE;
        FOREND;
      ELSEIF (channel_definition.number >= 20(8)) AND (channel_definition.number <= 24(8)) THEN
        FOR i := 20(8) TO 24(8) DO
          channel_definition.pps_capable_of_access [i] := TRUE;
        FOREND;
      ELSEIF (channel_definition.number >= 25(8)) AND (channel_definition.number <= 31(8)) THEN
        FOR i := 25(8) TO 31(8) DO
          channel_definition.pps_capable_of_access [i] := TRUE;
        FOREND;
      ELSEIF (iou_definition.kind = dsc$imn_i4_46_model) AND
            ((channel_definition.number = 32(8)) OR (channel_definition.number = 33(8))) THEN
        FOR i := 0 TO 11(8) DO
          channel_definition.pps_capable_of_access [i] := TRUE;
        FOREND;
      IFEND;

    = dsc$imn_i4_42_model =
      IF channel_definition.concurrent THEN
        IF (channel_definition.number > 3) THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$illegal_channel_number,
                number_string, status);
          osp$append_status_integer (osc$status_parameter_delimiter, 0, 10, TRUE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, 3, 10, TRUE, status);
          RETURN;
        IFEND;
        FOR i := 0 TO 4 DO
          channel_definition.pps_capable_of_access [i] := TRUE;
        FOREND;
      ELSE
        IF (channel_definition.number > 24(8)) THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$illegal_channel_number,
                number_string, status);
          osp$append_status_integer (osc$status_parameter_delimiter, 0, 10, TRUE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, 20, 10, TRUE, status);
          RETURN;
        IFEND;
        FOR i := 0 TO 11(8) DO
          channel_definition.pps_capable_of_access [i] := TRUE;
        FOREND;
        FOR i := 20(8) TO 24(8) DO
         channel_definition.pps_capable_of_access [i] := TRUE;
        FOREND;
      IFEND;

    ELSE { I1, I2 model }
      FOR i := LOWERVALUE (ost$physical_pp_number) TO UPPERVALUE (ost$physical_pp_number) DO
        channel_definition.pps_capable_of_access [i] := TRUE;
      FOREND;
    CASEND;

    channel_definition.iou := iou_name;
    FOR i := LOWERVALUE (cmt$physical_equipment_number) TO UPPERVALUE (cmt$physical_equipment_number) DO
      channel_definition.connection.equipment [i].configured := FALSE;
    FOREND;
    cmp$get_channel_type (iou_number, channel_definition.number, channel_definition.concurrent,
          channel_definition.kind, status);
    IF NOT status.normal THEN
      error_string := iou_name;
      error_string (7, * ) := ch_name;
      osp$set_status_abnormal (cmc$configuration_management_id, cme$unknown_channel_type,
            error_string, status);
      RETURN;
    IFEND;

    channel_definition.direct_memory_access := ((channel_definition.concurrent OR
          (iou_definition.kind = dsc$imn_i0_5x_model)) AND (channel_definition.kind = cmc$170_channel)) OR
          (channel_definition.kind = cmc$ipi_channel) OR
          ((channel_definition.kind = cmc$ici_channel) AND
          (iou_definition.kind = dsc$imn_i0_5x_model)) OR (channel_definition.kind = cmc$isi_channel);

    { Return abnormal status indicating that the channel is not in the active configuration.

    IF cmv$post_deadstart AND status.normal THEN
      element_descriptor.element_type := cmc$data_channel_element;
      element_descriptor.channel_descriptor := channel_identification;
      cmp$format_error_message (element_descriptor, physical_id, FALSE, cme$lcm_element_not_found, status);
    IFEND;

  PROCEND cmp$get_channel_def;

?? TITLE := '    cmp$get_channel_type ', EJECT ??

  PROCEDURE [XDCL] cmp$get_channel_type
    (    iou_number: dst$iou_number;
         channel_number: ost$physical_channel_number;
         concurrent: boolean;
     VAR channel_type: cmt$channel_type;
     VAR status: ost$status);

    VAR
      channel: dst$iou_resource,
      channel_type_found: boolean;

    status.normal := TRUE;
    channel_type := cmc$170_channel;
    channel.iou_number := iou_number;
    IF NOT concurrent THEN
      channel.channel_protocol := dsc$cpt_nio;
    ELSE
      channel.channel_protocol := dsc$cpt_cio;
    IFEND;
    channel.number := channel_number;

    dsp$retrieve_channel_type (channel, channel_type, channel_type_found);
    IF NOT channel_type_found THEN
      status.normal := FALSE;
    IFEND;

  PROCEND cmp$get_channel_type;
?? TITLE := '   cmp$get_driver_by_controller', EJECT ??

{ PURPOSE:
{   This procedure retrieves the driver name given the controller type.

  PROCEDURE [XDCL, #GATE] cmp$get_driver_by_controller
    (    controller: cmt$controller_type;
         concurrent: boolean;
         iou: dst$iou_number;
     VAR driver_name: dst$driver_name;
     VAR alternate_driver_name: dst$driver_name);

    VAR
      index: dst$number_of_ious,
      iou_information_table: dst$iou_information_table,
      number_of_ious: dst$number_of_ious;

    driver_name := ' ';
    alternate_driver_name := ' ';

    driver_name := v$iou_program_name [controller] [concurrent];

    CASE controller OF
    = cmc$mt7021_3x, cmc$mt7021_4x, cmc$mt698_xx =
      IF concurrent THEN
        alternate_driver_name := 'E2A7021';
      ELSE
        alternate_driver_name := 'E2C7021';
      IFEND;
    = cmc$mt7221_1 =
      IF NOT concurrent THEN
        alternate_driver_name := 'E2C7021';
      IFEND;
    = cmc$lcn380_170 =
      IF NOT concurrent THEN
        alternate_driver_name := 'E1I380';
      IFEND;
    ELSE
    CASEND;

  PROCEND cmp$get_driver_by_controller;
?? TITLE := '   cmp$get_driver_info', EJECT ??

{ PURPOSE:
{   This procedure returns the CIP driver name, given the IOU program name used at PCU and the channel
{   type (CIO or NIO). It also tells whether or not the current driver is a Dual PP.

  PROCEDURE [XDCL, #GATE] cmp$get_driver_info
    (    iou_program_name: pmt$program_name;
         concurrent: boolean;
     VAR cip_driver_name: dst$driver_name;
     VAR dual_pp: boolean;
     VAR status: ost$status);

    VAR
      controller: cmt$controller_type,
      temp_iou_program_name: pmt$program_name;

    status.normal := TRUE;

    { The following programs are carefully handled to insure that the case where one controller is being
    { accessed from both NIO and CIO channels is being properly handled.  In this situation the
    { iou_program_name will reflect whichever access was declared first, so an explicit NIO/CIO check is
    { required to determine the correct cip_driver_name and PP requirements.

    IF (iou_program_name = 'E9A7165') OR (iou_program_name = 'E2C7165') THEN
      IF concurrent THEN
        temp_iou_program_name := 'E9A7165';
      ELSE
        temp_iou_program_name := 'E2C7165';
      IFEND;
    ELSEIF (iou_program_name = 'E1C7155') OR (iou_program_name = 'E1A7155') THEN
      IF concurrent THEN
        temp_iou_program_name := 'E1A7155';
      ELSE
        temp_iou_program_name := 'E1C7155';
      IFEND;
    ELSE
      temp_iou_program_name := iou_program_name;
    IFEND;

    FOR controller := LOWERVALUE (cmt$controller_type) TO UPPERVALUE (cmt$controller_type) DO
      IF temp_iou_program_name = v$iou_program_name [controller] [concurrent] THEN
        cip_driver_name := v$cip_driver_name [controller] [concurrent];
        dual_pp := (temp_iou_program_name (2) = '2');
        RETURN;
      IFEND;
    FOREND;

    IF (temp_iou_program_name = 'E2A7021') OR (temp_iou_program_name = 'E2C7021') THEN
      cip_driver_name := 'TAPE';
      dual_pp := TRUE;
      RETURN;
    ELSEIF (temp_iou_program_name = 'E9Q5698') OR (temp_iou_program_name = 'E1I380') THEN
      cip_driver_name := temp_iou_program_name;
      dual_pp := FALSE;
      RETURN;
    IFEND;

    osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_iou_program_name, iou_program_name,
          status);

  PROCEND cmp$get_driver_info;
?? TITLE := '  cmp$get_driver_state', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_driver_state
    (    channel_name: cmt$element_name;
         iou_name: cmt$element_name;
     VAR driver_present: boolean;
     VAR status: ost$status);

    VAR
      channel: dst$iou_resource,
      channel_definition: cmt$data_channel_definition,
      channel_identification: cmt$channel_descriptor,
      index: iot$pp_number;

    status.normal := TRUE;
    driver_present := FALSE;

    channel_identification.iou := iou_name;
    channel_identification.name := channel_name;
    channel_identification.use_logical_identification := TRUE;
    cmp$get_channel_def (channel_identification, channel_definition, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    channel.number := channel_definition.number;

    cmp$convert_iou_name (iou_name, channel.iou_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF channel_definition.concurrent THEN
      channel.channel_protocol := dsc$cpt_cio;
    ELSE
      channel.channel_protocol := dsc$cpt_nio;
    IFEND;

    FOR index := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
      IF cmv$logical_pp_table_p^ [index].flags.configured AND
            (cmv$logical_pp_table_p^ [index].flags.entry_reserved_by_nosve OR
            cmv$logical_pp_table_p^ [index].flags.entry_reserved_by_other) AND
            (cmv$logical_pp_table_p^ [index].pp_info.channel = channel) THEN
        driver_present := TRUE;
        RETURN;
      IFEND;
    FOREND;

  PROCEND cmp$get_driver_state;

?? TITLE := '    cmp$get_element_state', EJECT ??

{
{  PURPOSE : Return the current state associated with the given
{      element name.
{

  PROCEDURE [XDCL, #GATE] cmp$get_element_state
    (    element_name: cmt$element_name;
         iou_name: cmt$element_name;
     VAR state: cmt$element_state;
     VAR status: ost$status);

    VAR
      found: boolean,
      index: integer,
      text: string (80);

    status.normal := TRUE;
    found := FALSE;

  /main_program/
    BEGIN
      IF cmv$state_info_table = NIL THEN
        IF NOT cmv$post_deadstart THEN

{ Default state to ON because state table is not built during
{ Boot or System Core time.

          state := cmc$on;
        ELSE
          osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_nil_cm_table,
                'Nil state info table', status);
        IFEND;
        EXIT /main_program/;
      IFEND;
      IF cmp$valid_channel_name (element_name) THEN
        text (1, 5) := iou_name;
        text (7, *) := element_name;
      ELSE
        text := element_name;
      IFEND;
    /loop/
      FOR index := 1 TO UPPERBOUND (cmv$state_info_table^) DO
        IF (cmv$state_info_table^ [index].element_type = cmc$data_channel_element) THEN

          found := (element_name = cmv$state_info_table^ [index].element_name) AND
                (iou_name = cmv$state_info_table^ [index].iou);
        ELSE
          found := (element_name = cmv$state_info_table^ [index].element_name);
        IFEND;
        IF found THEN
          state := cmv$state_info_table^ [index].status.state;
          EXIT /loop/;
        IFEND;
      FOREND /loop/;
      IF NOT found THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_element_not_found, text,
              status);
      IFEND;
    END /main_program/;

  PROCEND cmp$get_element_state;

?? TITLE := '   cmp$get_pp_def', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_pp_def
    (    pp_identification: cmt$pp_descriptor;
     VAR pp_definition: cmt$pp_definition;
     VAR status: ost$status);

    VAR
      ch_number: ost$physical_channel_number,
      iou_definition: cmt$iou_definition,
      iou_information_table: dst$iou_information_table,
      iou_name: cmt$element_name,
      number_of_ious: dst$number_of_ious,
      pp_number: ost$physical_pp_number;

    status.normal := TRUE;
    iou_name := 'IOU0';
    dsp$retrieve_iou_information (number_of_ious, iou_information_table);
    IF number_of_ious > 1 THEN
      iou_name := pp_identification.iou;
    IFEND;
    cmp$retrieve_iou_definition (iou_name, iou_definition, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR ch_number := LOWERVALUE (ost$physical_channel_number) TO UPPERVALUE (ost$physical_channel_number) DO
      pp_definition.accessible_channels [ch_number] := FALSE;
    FOREND;

    IF pp_identification.use_logical_identification THEN
      IF NOT valid_pp_name (pp_identification.pp_name) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_pp_name,
              pp_identification.pp_name, status);
        RETURN;
      IFEND;
      pp_definition.concurrent := (pp_identification.pp_name (1, 3) = 'CPP');
      IF pp_definition.concurrent THEN
        IF pp_identification.pp_name (5) <> ' ' THEN
          pp_number := (($INTEGER (pp_identification.pp_name (4)) - $INTEGER ('0')) * 10) +
                ($INTEGER (pp_identification.pp_name (5)) - $INTEGER ('0'));
        ELSE
          pp_number := $INTEGER (pp_identification.pp_name (4)) - $INTEGER ('0');
        IFEND;
      ELSE
        IF pp_identification.pp_name (4) <> ' ' THEN
          pp_number := (($INTEGER (pp_identification.pp_name (3)) - $INTEGER ('0')) * 10) +
                ($INTEGER (pp_identification.pp_name (4)) - $INTEGER ('0'));
        ELSE
          pp_number := $INTEGER (pp_identification.pp_name (3)) - $INTEGER ('0');
        IFEND;
      IFEND;
      pp_definition.number := pp_number;
    ELSE
      pp_definition.concurrent := pp_identification.concurrent;
      pp_definition.number := pp_identification.pp_number;
    IFEND;

    IF (pp_definition.number > 25) OR ((pp_definition.number > 9) AND (pp_definition.number < 16)) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_pp_number,
            'PP number must be in range 0..9 or 16..25.', status);
      RETURN;
    IFEND;

    pp_definition.direct_memory_access := FALSE;
    pp_definition.iou := iou_name;

    CASE iou_definition.kind OF
    = dsc$imn_i0_5x_model =
      pp_definition.size := 16384;
      pp_definition.direct_memory_access := TRUE;
      IF pp_definition.number <= 4 THEN
        FOR ch_number := 0 TO 5 DO
          pp_definition.accessible_channels [ch_number] := TRUE;
        FOREND;
      ELSE
        FOR ch_number := 21(8) TO 26(8) DO
          pp_definition.accessible_channels [ch_number] := TRUE;
        FOREND;
      IFEND;

    = dsc$imn_i4_40_model =
      IF pp_definition.concurrent THEN
        pp_definition.size := 8192;
        pp_definition.direct_memory_access := TRUE;
        IF pp_definition.number <= 4 THEN
          FOR ch_number := 0 TO 4 DO
            pp_definition.accessible_channels [ch_number] := TRUE;
          FOREND;
        ELSE
          FOR ch_number := 5 TO 11(8) DO
            pp_definition.accessible_channels [ch_number] := TRUE;
          FOREND;
        IFEND;
      ELSE
        pp_definition.size := 4096;
        FOR ch_number := LOWERVALUE (ost$physical_channel_number)
              TO UPPERVALUE (ost$physical_channel_number) DO
          pp_definition.accessible_channels [ch_number] := TRUE;
        FOREND;
      IFEND;

    = dsc$imn_i4_44_model, dsc$imn_i4_46_model =
      pp_definition.size := 8192;
      pp_definition.direct_memory_access := TRUE;
      FOR ch_number := LOWERVALUE (ost$physical_channel_number)
            TO UPPERVALUE (ost$physical_channel_number) DO
        pp_definition.accessible_channels [ch_number] := TRUE;
      FOREND;

    = dsc$imn_i4_42_model =
      IF pp_definition.concurrent THEN
        pp_definition.size := 8192;
        pp_definition.direct_memory_access := TRUE;
        FOR ch_number := 0 TO 4 DO
          pp_definition.accessible_channels [ch_number] := TRUE;
        FOREND;
      ELSE
        pp_definition.size := 4096;
        FOR ch_number := LOWERVALUE (ost$physical_channel_number) TO 24(8) DO
          pp_definition.accessible_channels [ch_number] := TRUE;
        FOREND;
      IFEND;

    ELSE  { dsc$imn_i1_10_model .. dsc$imn_i2_20_model
      pp_definition.size := 4096;
      FOR ch_number := LOWERVALUE (ost$physical_channel_number)
            TO UPPERVALUE (ost$physical_channel_number) DO
        pp_definition.accessible_channels [ch_number] := TRUE;
      FOREND;
    CASEND;

  PROCEND cmp$get_pp_def;

?? TITLE := '  cmp$retrieve_iou_definition', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$retrieve_iou_definition
    (    iou_name: cmt$element_name;
     VAR iou_definition: cmt$iou_definition;
     VAR status: ost$status);

    VAR
      iou_information_table: dst$iou_information_table,
      iou_index: dst$number_of_ious,
      iou_number: dst$iou_number,
      number_of_ious: dst$number_of_ious;

    status.normal := TRUE;
    cmp$convert_iou_name (iou_name, iou_number, status);
    IF NOT status.normal THEN
      RETURN;
    ELSE
      dsp$retrieve_iou_information (number_of_ious, iou_information_table);

      FOR iou_index := 1 TO number_of_ious DO
        IF iou_information_table [iou_index].physical_iou_number = iou_number THEN
          iou_definition.kind := iou_information_table [iou_index].model_type;
          RETURN;
        IFEND;
      FOREND;
      osp$set_status_abnormal (cmc$configuration_management_id, cme$iou_not_configured, iou_name, status);
    IFEND;
  PROCEND cmp$retrieve_iou_definition;

?? TITLE := '  cmp$return_descriptor_data', EJECT ??

*copy cmh$return_descriptor_data

  PROCEDURE [XDCL, #GATE] cmp$return_descriptor_data
    (    channel: cmt$physical_channel;
         iou_number: dst$iou_number;
         physical_equipment_number: cmt$physical_equipment_number;
         logical_unit_number: iot$logical_unit;
     VAR descriptor_data: ost$string;
     VAR pp_number: 0 .. 0ff(16));

?? NEWTITLE := '  append_string_data', EJECT ??

    PROCEDURE [INLINE] append_string_data
      (    string_data: string ( * <= 31));

      descriptor_data.value (index, * ) := string_data;

      WHILE (descriptor_data.value (index, 1) <> ' ') DO
        index := index + 1;
      WHILEND;

    PROCEND append_string_data;
?? OLDTITLE ??

    CONST
      null_name = '$NULL';

    VAR
      channel_type: dst$channel_protocol_type,
      channel_ordinal: cmt$channel_ordinal,
      pp_string: string (10),
      search_key: dmt$avt_search_key,
      recorded_vsn: rmt$recorded_vsn,
      avt_entry_not_found: boolean,
      all_elements_found: boolean,
      build_pp_string: boolean,
      length,
      index: integer,
      vsn: rmt$recorded_vsn,
      status: ost$status,
      channel_element,
      controller_element,
      logical_unit_element: ^cmt$element_definition,
      logical_pp_index: iot$pp_number,
      mainframe_name,
      channel_name,
      controller_name,
      iou_name: cmt$element_name,
      logical_unit_name: cmt$element_name,
      ct_port: cmt$controller_port_number,
      un_port: cmt$data_storage_port_number,
      valid: boolean;

    all_elements_found := FALSE;
    controller_name := osc$null_name;
    PUSH logical_unit_element;
    PUSH controller_element;
    PUSH channel_element;
    vsn := ' ';
    descriptor_data.value := ' ';
    descriptor_data.size := 0;

    cmp$convert_iou_number (iou_number, iou_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$retrieve_logical_pp_index (channel, iou_number, cmv$logical_pp_table_p, logical_pp_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$pc_get_logical_unit (logical_unit_number, logical_unit_element, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    logical_unit_name := logical_unit_element^.element_name;

    /logical_unit_port_loop/
      FOR un_port := LOWERVALUE (un_port) TO UPPERVALUE (un_port) DO
        IF logical_unit_element^.storage_device.connection.port [un_port].configured THEN
          controller_name := logical_unit_element^.storage_device.connection.port [un_port].element_name;

          cmp$pc_get_element (controller_name, iou_name, controller_element, status);
          IF NOT status.normal THEN
            CYCLE /logical_unit_port_loop/;
          IFEND;
          IF controller_element^.element_type = cmc$controller_element THEN
            IF controller_element^.controller.physical_equipment_number = physical_equipment_number THEN

            /controller_port_loop/
              FOR ct_port := LOWERVALUE (ct_port) TO UPPERVALUE (ct_port) DO
                IF controller_element^.controller.connection.port [ct_port].configured THEN
                  channel_name := controller_element^.controller.connection.port [ct_port].element_name;
                  cmp$pc_get_element (channel_name, iou_name, channel_element, status);
                  IF NOT status.normal THEN
                    CYCLE /controller_port_loop/;
                  IFEND;
                  IF (channel_element^.data_channel.number = channel.number) AND
                        (channel_element^.data_channel.port = channel.port) AND
                        (channel_element^.data_channel.concurrent = channel.concurrent) THEN
                    mainframe_name := channel_element^.data_channel.mainframe_ownership;
                    all_elements_found := TRUE;
                    EXIT /logical_unit_port_loop/;
                  IFEND;
                IFEND;
              FOREND /controller_port_loop/;
            IFEND;
          ELSE { controller_element is in fact a Channel }
            controller_name := osc$null_name;
            channel_name := controller_element^.element_name;
            mainframe_name := controller_element^.data_channel.mainframe_ownership;
            all_elements_found := TRUE;
            IF (controller_element^.data_channel.number = channel.number) AND
                  (controller_element^.data_channel.port = channel.port) AND
                  (controller_element^.data_channel.concurrent = channel.concurrent) THEN
              EXIT /logical_unit_port_loop/;
            ELSE
              CYCLE /logical_unit_port_loop/;
            IFEND;
          IFEND;
        IFEND;
      FOREND /logical_unit_port_loop/;
      IF all_elements_found THEN
        IF (cmv$logical_unit_table^ [logical_unit_number].unit_interface_table^.unit_type >=
              ioc$lowest_disk_unit) AND (cmv$logical_unit_table^ [logical_unit_number].
              unit_interface_table^.unit_type <= ioc$highest_disk_unit) THEN  { element is a disk
          search_key.value := dmc$search_avt_by_lun;
          search_key.logical_unit_number := logical_unit_number;

          cmp$search_active_volume_table (search_key, recorded_vsn, avt_entry_not_found);
          IF NOT avt_entry_not_found THEN
            vsn := recorded_vsn;
          IFEND;
        ELSE {element is a tape
         /search_tusl_for_evsn/
          FOR index := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
            IF (iov$tusl_p^ [index].element_name = logical_unit_name) AND
                  (iov$tusl_p^ [index].assignment_state <> ioc$not_assigned) THEN
              vsn := iov$tusl_p^ [index].evsn;
              EXIT /search_tusl_for_evsn/;
            IFEND;
          FOREND /search_tusl_for_evsn/;
        IFEND;
      ELSE
        logical_unit_name := null_name;
        cmp$convert_channel_number (channel.number, channel.concurrent, channel.port, channel_ordinal,
              channel_name, valid);
        cmp$pc_get_element (channel_name, iou_name, channel_element, status);
        IF status.normal THEN
          mainframe_name := channel_element^.data_channel.mainframe_ownership;
          IF channel_element^.data_channel.connection.equipment [physical_equipment_number].configured THEN
            controller_name := channel_element^.data_channel.connection.equipment [physical_equipment_number].
                  element_name;
          ELSE
            controller_name := null_name;
          IFEND;
        ELSE
          mainframe_name := null_name;
        IFEND;
      IFEND;
      index := 1;
      append_string_data (mainframe_name);
      append_string_data ('.');
      append_string_data (iou_name);
      build_pp_string := TRUE;
      IF channel.concurrent THEN
        channel_type := dsc$cpt_cio;
      ELSE
        channel_type := dsc$cpt_nio;
      IFEND;
      IF cmv$logical_pp_table_p^ [logical_pp_index].flags.resources_acquired THEN
        pp_number := cmv$logical_pp_table_p^ [logical_pp_index].pp_info.physical_pp.number;
      ELSE
        build_pp_string := FALSE;
      IFEND;

      IF build_pp_string THEN
        pp_string := '   ';
        STRINGREP (pp_string, length, pp_number);
        IF NOT channel.concurrent THEN
          append_string_data ('.PP ');
        ELSE
          append_string_data ('.CPP ');
        IFEND;
        append_string_data (pp_string (2, * ));
      ELSE
        append_string_data ('. ');
      IFEND;
      append_string_data ('. ');
      append_string_data (channel_name);
      IF controller_name <> osc$null_name THEN
        append_string_data ('. ');
        append_string_data (controller_name);
      IFEND;
      append_string_data ('. ');
      append_string_data (logical_unit_name);
      append_string_data ('* ');
      append_string_data (vsn);
      descriptor_data.size := index - 1;

  PROCEND cmp$return_descriptor_data;

MODEND cmm$configuration_interface_13d;
*DECK DECK=CMM$CONFIGURE_IN_JOB_TEMPLATE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE CM : Job Template Configuration' ??
MODULE cmm$configure_in_job_template;

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH(LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc clt$file
*copyc cmc$logical_unit_constants
*copyc cme$job_template_deadstart
*copyc cme$logical_configuration_mgr
*copyc cme$logical_configuration_utl
*copyc cme$manage_interface_tables
*copyc cme$physical_configuration_utl
*copyc cmt$element_definition
*copyc cmt$mass_storage_volume
*copyc cmt$physical_configuration
*copyc dmt$error_condition_codes
*copyc dmt$initialize_status_info
*copyc dst$iou_number
*copyc mme$condition_codes
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc rmc$mass_storage_class
*copyc std$active_set_table
*copyc ste$error_condition_codes
?? POP ??
*copyc amp$close
*copyc amp$fetch_access_information
*copyc amp$file
*copyc amp$get_next
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$put_next
*copyc amp$return
*copyc amp$rewind
*copyc amp$set_segment_eoi
*copyc amp$set_segment_position
*copyc clp$begin_utility
*copyc clp$convert_integer_to_string
*copyc clp$convert_to_clt$status
*copyc clp$create_variable
*copyc clp$end_utility
*copyc clp$end_scan_command_file
*copyc clp$evaluate_parameters
*copyc clp$include_line
*copyc clp$put_job_output
*copyc clp$read_variable
*copyc clp$scan_command_line
*copyc clp$trimmed_string_size
*copyc clp$write_variable
*copyc cmp$acquire_all_peripherals_r1
*copyc cmp$assign_logical_unit_numbers
*copyc cmp$build_pct
*copyc cmp$build_state_table
*copyc cmp$close_utility_files
*copyc cmp$convert_channel_number
*copyc cmp$convert_iou_number
*copyc cmp$define_element
*copyc cmp$define_working_mainframe
*copyc cmp$edit_pc
*copyc cmp$find_state_element
*copyc cmp$get_channel_definition
*copyc cmp$get_conf_file
*copyc cmp$get_controller_type
*copyc cmp$get_element_state
*copyc cmp$get_element_state_via_lun
*copyc cmp$get_mass_storage_info
*copyc cmp$get_ms_status_via_lun
*copyc cmp$get_system_device_path
*copyc cmp$get_unit_type
*copyc cmp$install_conf_file
*copyc cmp$install_phys_configuration
*copyc cmp$known_controller_id
*copyc cmp$open_utility_files
*copyc cmp$pc_get_logical_unit
*copyc cmp$process_state_change
*copyc cmp$prompt_for_answer
*copyc cmp$return_configuration_limits
*copyc cmp$set_default_mainframe_name
*copyc cmp$valid_channel_name
*copyc cmp$verify_active_path
*copyc cmp$verify_phys_configuration
*copyc dmp$get_volumes_active
*copyc dsp$retrieve_iou_information
*copyc jmp$system_job
*copyc ofp$receive_operator_response
*copyc ofp$send_operator_message
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$generate_error_message
*copyc osp$get_status_condition_name
*copyc osp$set_status_abnormal
*copyc pfp$define
*copyc pfp$define_catalog
*copyc pfp$log_error
*copyc pfp$purge
*copyc pmp$generate_unique_name
*copyc pmp$get_binary_processor_id
*copyc pmp$get_job_mode
*copyc pmp$get_mainframe_id
*copyc pmp$get_unique_name
*copyc pmp$log_ascii
*copyc stp$get_active_set_list
*copyc stp$get_volumes_in_set
*copyc stp$get_volumes_set_name
*copyc stp$is_volume_in_set
*copyc stp$r2_remove_inactive_member
*copyc stp$remove_inactive_members
*copyc stp$remove_member_vol_from_set
*copyc stp$search_ast_by_set
*copyc stp$verify_all_volumes_active
*copyc syp$display_deadstart_message
*copyc syp$process_deadstart_status
*copyc syp$trace_deadstart_message
?? EJECT ??
*copyc cmv$new_logical_unit_table
*copyc cmv$post_deadstart
*copyc cmv$system_device_data
*copyc dmv$active_volume_table
*copyc dmv$system_device_information
*copyc osv$deadstart_phase
*copyc osv$recover_system_set_phase
*copyc stv$system_set_name
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

{ table pcu_command_list t=c s=local sn=oss$job_paged_literal
{ command (define_working_mainframe       ,defwm) cmp$define_working_mainframe  cm=local
{ command (define_element                 ,defe)  cmp$define_element cm=local
{ command (verify_physical_configuration  ,verpc) cmp$verify_phys_configuration  cm=local
{ command (install_physical_configuration ,inspc) cmp$install_phys_configuration cm=local
{ command (edit_physical_configuration    ,edipc) cmp$edit_pc cm=local
{ command (quit                           ,qui)   quit cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??
VAR
  pcu_command_list: [STATIC, READ, oss$job_paged_literal] ^clt$command_table := ^pcu_command_list_entries,
  pcu_command_list_entries: [STATIC, READ, oss$job_paged_literal] array [1 .. 12] of
      clt$command_table_entry := [
  {} ['DEFE                           ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^cmp$define_element],
  {} ['DEFINE_ELEMENT                 ', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^cmp$define_element],
  {} ['DEFINE_WORKING_MAINFRAME       ', clc$nominal_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^cmp$define_working_mainframe],
  {} ['DEFWM                          ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^cmp$define_working_mainframe],
  {} ['EDIPC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^cmp$edit_pc],
  {} ['EDIT_PHYSICAL_CONFIGURATION    ', clc$nominal_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^cmp$edit_pc],
  {} ['INSPC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^cmp$install_phys_configuration],
  {} ['INSTALL_PHYSICAL_CONFIGURATION ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^cmp$install_phys_configuration],
  {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^quit],
  {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^quit],
  {} ['VERIFY_PHYSICAL_CONFIGURATION  ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^cmp$verify_phys_configuration],
  {} ['VERPC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^cmp$verify_phys_configuration]];
?? POP ??

  VAR
    cmv$create_state_info_df: [XDCL, oss$task_private] boolean := FALSE,
    cmv$installed_mainframe: [XREF] cmt$element_name,
    cmv$use_installed_configuration: [XREF] boolean,
    osv$configuration_prolog_name: [XREF] ost$string,
    osv$verify_missing_volumes: [XREF] boolean,

    v$low_cycle: [READ, oss$job_paged_literal] pft$cycle_selector := [pfc$lowest_cycle],
    v$pf_cycle: [READ, oss$job_paged_literal] pft$cycle_selector := [pfc$highest_cycle];

?? OLDTITLE ??
?? NEWTITLE := 'get_volume_ms_class', EJECT ??

{ PURPOSE:
{   This procedure locates the specifed recorded vsn in the active volume table
{   and returns the the mass storage class information if the volume is active.
{   If the volume does not exist or is unavailable an empty set will be returned.
{
  PROCEDURE get_volume_ms_class
    (    recorded_vsn: rmt$recorded_vsn;
     VAR volume_ms_class: dmt$class);

    VAR
      avt_index: integer,
      element_status: iot$unit_status,
      state: cmt$element_state;

    volume_ms_class := $dmt$class [];

  /avt_loop/
    FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND (dmv$p_active_volume_table^) DO
      IF dmv$p_active_volume_table^ [avt_index].entry_available THEN
        CYCLE /avt_loop/;
      IFEND;

      IF dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn <> recorded_vsn THEN
        CYCLE /avt_loop/;
      IFEND;

      IF NOT dmv$p_active_volume_table^ [avt_index].mass_storage.allocation_allowed THEN
        EXIT /avt_loop/;
      IFEND;

      cmp$get_element_state_via_lun (dmv$p_active_volume_table^ [avt_index].logical_unit_number, state);
      IF state <> cmc$on THEN
        EXIT /avt_loop/;
      IFEND;

      cmp$get_ms_status_via_lun (dmv$p_active_volume_table^ [avt_index].logical_unit_number,
            element_status);
      IF element_status.disabled THEN
        EXIT /avt_loop/;
      IFEND;

      volume_ms_class := dmv$p_active_volume_table^ [avt_index].mass_storage.class;
      EXIT /avt_loop/;
    FOREND /avt_loop/;
  PROCEND get_volume_ms_class;

?? OLDTITLE ??
?? NEWTITLE := 'initialize_cm_variables', EJECT ??

{ PURPOSE:
{   This procedure creates and initializes a certain number of SCL variables that will be referenced by the
{   SYSTEM_DEADSTART_PROLOG.

  PROCEDURE initialize_cm_variables;

    CONST
      c$warning_message = 'WARNING -- The following error was found while creating variables:';

    TYPE
      t$variable_data = RECORD
        CASE boolean OF
        = TRUE =
          size: ost$string_size,
          value: ost$name,
        = FALSE =
          data: ARRAY [1 .. (2 + osc$max_name_size)] OF cell,
        CASEND,
      RECEND;

    VAR
      local_status: ost$status,
      phase_scope: clt$variable_scope,
      variable_data: t$variable_data,
      variable_value: clt$variable_reference;

    phase_scope.kind := clc$job_variable;

    clp$create_variable ('OSV$CONFIGURATION_PROLOG_NAME', clc$string_value, osc$max_name_size, 1, 1,
          phase_scope, variable_value, local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (c$warning_message, FALSE, local_status);
    IFEND;
    variable_data.size := osv$configuration_prolog_name.size;
    variable_data.value := osv$configuration_prolog_name.value;
    variable_value.value.string_value := ^variable_data.data;
    clp$write_variable ('OSV$CONFIGURATION_PROLOG_NAME', variable_value.value, local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (c$warning_message, FALSE, local_status);
    IFEND;

    clp$create_variable ('OSV$SITE_CONFIGURATION_FILE', clc$string_value, osc$max_name_size, 1, 1,
          phase_scope, variable_value, local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (c$warning_message, FALSE, local_status);
    IFEND;
    variable_data.size := 18;
    variable_data.value := 'SITE_CONFIGURATION';
    variable_value.value.string_value := ^variable_data.data;
    clp$write_variable ('OSV$SITE_CONFIGURATION_FILE', variable_value.value, local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (c$warning_message, FALSE, local_status);
    IFEND;

    clp$create_variable ('CMV$CONFIGURATION_ACTIVATED', clc$boolean_value, osc$max_name_size, 1, 1,
          phase_scope, variable_value, local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (c$warning_message, FALSE, local_status);
    IFEND;

    clp$create_variable ('CMV$FORCE_INTERVENTION', clc$boolean_value, 0, 1, 1, phase_scope, variable_value,
          local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (c$warning_message, FALSE, local_status);
    IFEND;

    clp$create_variable ('CMV$NETWORK_ACTIVATED', clc$boolean_value, 0, 1, 1, phase_scope, variable_value,
          local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (c$warning_message, FALSE, local_status);
    IFEND;

    clp$create_variable ('CMV$PCU_STATUS', clc$status_value, 0, 1, 1, phase_scope, variable_value,
          local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (c$warning_message, FALSE, local_status);
    IFEND;

    clp$create_variable ('CMV$DEVICE_FILE_COPY_STATUS', clc$status_value, 0, 1, 1, phase_scope,
          variable_value, local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (c$warning_message, FALSE, local_status);
    IFEND;

  PROCEND initialize_cm_variables;
?? OLDTITLE ??
?? NEWTITLE := 'prepare_configuration_file', EJECT ??

{ PURPOSE:
{   This procedure builds a text file containing the DEFINE_ELEMENT commands for the system/deadstart
{   devices. This file is used by the SYSTEM_DEADSTART_PROLOG if an unconfigured deadstart tape is used.

  PROCEDURE prepare_configuration_file
    (    file_identifier: amt$file_identifier);

    VAR
      byte_address: amt$file_byte_address,
      cm_unit_type: cmt$unit_type,
      count: 1 .. 2,
      device: cmt$system_device_types,
      found: boolean,
      index: 1 .. 4,
      integer_string: ost$string,
      io_unit_type: iot$unit_type,
      iou_name: cmt$element_name,
      line: string (osc$max_string_size),
      local_status: ost$status,
      mainframe_id: pmt$mainframe_id,
      unit_class: cmt$unit_class;

    { Prepare the file with information from the system device data variable.

    pmp$get_mainframe_id (mainframe_id, local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (' ', FALSE, local_status);
      RETURN;
    IFEND;

    line := ' ';
    line (1, 25) := 'DEFINE_WORKING_MAINFRAME ';
    line (26, *) := mainframe_id;
    amp$put_next (file_identifier, ^line, #SIZE (line), byte_address, local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (' ', FALSE, local_status);
      RETURN;
    IFEND;

    cmp$get_unit_type (cmv$system_device_data [cmc$sdt_disk_device].unit_id, cm_unit_type, io_unit_type,
          unit_class, found);
    IF NOT found THEN
      RETURN;
    IFEND;

    device := cmc$sdt_disk_device;
    IF cmv$system_device_data [cmc$sdt_tape_device].specified THEN
      count := 2;
    ELSE
      count := 1;
    IFEND;

    FOR index := 1 TO count DO
      line := ' ';
      line (1, 14) := 'DEFINE_ELEMENT';
      line (15, 3) := ' E=';
      line (18, 21) := cmv$system_device_data [device].unit_name;
      line (39, 4) := ' EI=';
      line (43, 6) := cmv$system_device_data [device].unit_id.product_number;
      line (49, 1) := cmv$system_device_data [device].unit_id.underscore;
      line (50, 3) := cmv$system_device_data [device].unit_id.model_number;
      line (53, 4) := ' SN=';
      clp$convert_integer_to_string (index, 10, FALSE, integer_string, local_status);
      line (57, 1) := integer_string.value;
      line (58, 8) := ' S=ON ..';
      amp$put_next (file_identifier, ^line, #SIZE (line), byte_address, local_status);
      IF NOT local_status.normal THEN
        syp$process_deadstart_status (' ', FALSE, local_status);
        RETURN;
      IFEND;

      line := ' ';
      IF (cm_unit_type = cmc$mshydra) AND (device = cmc$sdt_disk_device) THEN
        line (1, 6) := ' IC=((';
        line (7, 6) := cmv$system_device_data [device].channel_name;
        line (13, 1) := ' ';
        clp$convert_integer_to_string (cmv$system_device_data [device].unit_number, 10, FALSE,
              integer_string, local_status);
        line (14, 3) := integer_string.value (1, 3);
        line (17, 1) := ' ';
        line (18, 31) := mainframe_id;
        line (49, 1) := ' ';
        cmp$convert_iou_number (cmv$system_device_data [device].iou_number, iou_name, local_status);
        line (50, 5) := iou_name (1, 5);
        line (55, 3) := ')) ';
      ELSE
        line (1, 6) := ' PC=((';
        line (7, 21) := cmv$system_device_data [device].equipment_name;
        line (28, 1) := ' ';
        clp$convert_integer_to_string (cmv$system_device_data [device].unit_number, 10, FALSE,
              integer_string, local_status);
        line (29, 3) := integer_string.value (1, 3);
        line (32, 3) := ')) ';
      IFEND;
      amp$put_next (file_identifier, ^line, #SIZE (line), byte_address, local_status);
      IF NOT local_status.normal THEN
        syp$process_deadstart_status (' ', FALSE, local_status);
        RETURN;
      IFEND;
      device := cmc$sdt_tape_device;
    FOREND;

    device := cmc$sdt_disk_device;
    FOR index := 3 TO 4 DO

      { If ISD or 895 or HYDRA disk device, need to build channel adapter, head of string controller etc.

      line := ' ';
      IF (cm_unit_type <> cmc$mshydra) OR (device <> cmc$sdt_disk_device) THEN
        line (1, 14) := 'DEFINE_ELEMENT';
        line (15, 3) := ' E=';
        line (18, 21) := cmv$system_device_data [device].equipment_name;
        line (39, 4) := ' EI=';
        line (43, 6) := cmv$system_device_data [device].equipment_id.product_number;
        line (49, 1) := cmv$system_device_data [device].equipment_id.underscore;
        line (50, 3) := cmv$system_device_data [device].equipment_id.model_number;
        line (53, 4) := ' SN=';
        clp$convert_integer_to_string (index, 10, FALSE, integer_string, local_status);
        line (57, 1) := integer_string.value;
        line (58, 8) := ' S=ON ..';
        amp$put_next (file_identifier, ^line, #SIZE (line), byte_address, local_status);
        IF NOT local_status.normal THEN
          syp$process_deadstart_status (' ', FALSE, local_status);
          RETURN;
        IFEND;

        line := ' ';
        line (1, 6) := ' IC=((';
        line (7, 6) := cmv$system_device_data [device].channel_name;
        line (13, 1) := ' ';
        clp$convert_integer_to_string (cmv$system_device_data [device].equipment_number, 10, FALSE,
              integer_string, local_status);
        line (14, 3) := integer_string.value (1, 3);
        line (17, 1) := ' ';
        line (18, 31) := mainframe_id;
        line (49, 1) := ' ';
        cmp$convert_iou_number (cmv$system_device_data [device].iou_number, iou_name, local_status);
        line (50, 5) := iou_name (1, 5);
        line (55, 3) := ')) ';
        amp$put_next (file_identifier, ^line, #SIZE (line), byte_address, local_status);
        IF NOT local_status.normal THEN
          syp$process_deadstart_status (' ', FALSE, local_status);
          RETURN;
        IFEND;
      IFEND;
      device := cmc$sdt_tape_device;
    FOREND;

  PROCEND prepare_configuration_file;
?? OLDTITLE ??
?? NEWTITLE := 'press_next', EJECT ??

{ PURPOSE:
{   This procedure issues a message and waits for CARRIAGE RETURN to be entered.

  PROCEDURE press_next;

    VAR
      byte_address: amt$file_byte_address,
      file_position: amt$file_position,
      input_fid: amt$file_identifier,
      line: string (80),
      status: ost$status,
      transfer_count: amt$transfer_count;

    clp$put_job_output (' Press RETURN/NEXT when ready to continue', status);
    amp$open (clc$job_input, amc$record, NIL, input_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    amp$get_next (input_fid, ^line, #SIZE (line), transfer_count, byte_address, file_position, status);

  PROCEND press_next;
?? OLDTITLE ??
?? NEWTITLE := 'quit', EJECT ??

{ PURPOSE:
{   Dummy procedure to quit physical_configuration_utility.

  PROCEDURE quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE quit_pcu_pdt (
{    )

?? PUSH (LISTEXT := ON) ??
    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [88, 5, 13, 14, 30, 41, 383], clc$command, 0, 0, 0, 0, 0, 0, 0, 'QUIT_PCU_PDT']];
?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$end_scan_command_file ('PHYSICAL_CONFIGURATION_UTILITY ', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cmp$close_utility_files;

  PROCEND quit;
?? OLDTITLE ??
?? NEWTITLE := 'update_connectivity', EJECT ??

{ PURPOSE:
{   This procedure updates all the connections in the file: connected_lc_fid.  The file contains all of the
{   configuration information belonging to mainframe.  The file: state_info_fid is passed to allow retrieval
{   of state information about the deadstart and/or system device path(s).

  PROCEDURE update_connectivity
    (    connected_lc_fid: amt$file_identifier;
         state_info_fid: amt$file_identifier;
         mainframe: cmt$element_name;
     VAR status: ost$status);

    CONST
      c$max_ms_devices_allowed = 2;

    VAR
      channel_element_p: ^cmt$element_definition,
      channel_name: cmt$element_name,
      channel_port: cmt$channel_port,
      channel_type: cmt$channel_kind,
      char_to_check: char,
      configuration_limits: cmt$configuration_limits,
      controller_type: cmt$controller_type,
      cm_unit_type: cmt$unit_type,
      done_checking: boolean,
      dspn: cmt$data_storage_port_number,
      eoi_addr: ARRAY [1 .. 1] OF amt$access_info,
      element_p: ^cmt$element_definition,
      found: boolean,
      io_unit_type: iot$unit_type,
      iou_information_table: dst$iou_information_table,
      iou_name: cmt$element_name,
      last_channel_port: cmt$channel_port,
      lc_element_p: ^cmt$element_definition,
      lc_count: integer,
      lc_index: integer,
      lc_seg: amt$segment_pointer,
      local_status: ost$status,
      non_9836_count: integer,
      number_of_ious: dst$number_of_ious,
      number_of_spindles: integer,
      number_of_units_defined: integer,
      pid : string (10),
      pen: cmt$physical_equipment_number,
      processor_element_id: ost$processor_element_id,
      product_found: boolean,
      product_number: cmt$product_number,
      pun: cmt$physical_unit_number,
      starting_channel_name: cmt$element_name,
      string_index: 0 .. osc$max_name_size,
      unit_class: cmt$unit_class,
      unit_element_p: ^cmt$element_definition;

    status.normal := TRUE;
    number_of_spindles := 0;
    non_9836_count := 0;

    eoi_addr [1].key := amc$eoi_byte_address;
    amp$fetch_access_information (connected_lc_fid, eoi_addr, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT eoi_addr [1].item_returned THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_empty_lc, ' ', status);
      RETURN;
    IFEND;
    IF (eoi_addr [1].eoi_byte_address MOD #SIZE (cmt$element_definition)) <> 0 THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_incompatible_lc, ' ', status);
      RETURN;
    IFEND;
    lc_count := eoi_addr [1].eoi_byte_address DIV #SIZE (cmt$element_definition);

    { Get the segment pointer.

    amp$get_segment_pointer (connected_lc_fid, amc$sequence_pointer, lc_seg, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET lc_seg.sequence_pointer;

    dsp$retrieve_iou_information (number_of_ious, iou_information_table);

   /search_element_loop/
    FOR lc_index := 1 TO lc_count DO
      NEXT lc_element_p IN lc_seg.sequence_pointer;
      IF lc_element_p = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_empty_lc, ' ', status);
        RETURN;
      IFEND;

      CASE lc_element_p^.element_type OF
      = cmc$data_channel_element =
        IF ((lc_element_p^.data_channel.number >= 12) AND (lc_element_p^.data_channel.number <= 15)) OR
              (lc_element_p^.data_channel.concurrent AND (lc_element_p^.data_channel.number > 25)) THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_unsupported_channel,
                lc_element_p^.element_name, status);
          RETURN;
        IFEND;
        product_number := ' ';

       /channel_forloop/
        FOR pen := LOWERVALUE (cmt$physical_equipment_number) TO UPPERVALUE (cmt$physical_equipment_number) DO
          IF NOT lc_element_p^.data_channel.connection.equipment [pen].configured THEN
            CYCLE /channel_forloop/;
          IFEND;
          cmp$find_element (lc_element_p^.data_channel.connection.equipment [pen].element_name,
                {not used} iou_name, osc$null_name, connected_lc_fid, element_p, local_status);
          IF NOT local_status.normal THEN
            lc_element_p^.data_channel.connection.equipment [pen].configured := FALSE;
            CYCLE /channel_forloop/;
          IFEND;

          IF product_number = ' ' THEN
            product_number := element_p^.product_id.product_number;
          ELSE
            IF product_number <> element_p^.product_id.product_number THEN
              osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_mixture_of_product,
                    lc_element_p^.element_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, product_number, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    element_p^.product_id.product_number, status);
              RETURN;
            IFEND;
          IFEND;

          IF NOT lc_element_p^.data_channel.concurrent THEN
            CYCLE /channel_forloop/;
          IFEND;

          { Make sure that the concurrent channel is properly defined with or without port depending on the
          { product.

          IF lc_element_p^.data_channel.port = cmc$unspecified_port THEN
            channel_type := cmc$cio_channel_no_port;
          ELSE
            channel_type := cmc$cio_channel_2_port;
          IFEND;

          IF element_p^.element_type = cmc$controller_element THEN

           /find_unit/
            FOR pun := LOWERVALUE (cmt$physical_unit_number) TO UPPERVALUE (cmt$physical_unit_number) DO
              IF NOT element_p^.controller.connection.unit [pun].configured THEN
                CYCLE /find_unit/;
              IFEND;
              cmp$find_element (element_p^.controller.connection.unit [pun].element_name,
                    {not used} iou_name, osc$null_name, connected_lc_fid, unit_element_p, local_status);
              IF NOT local_status.normal THEN
                CYCLE /find_unit/;
              IFEND;
              cmp$return_configuration_limits (unit_element_p^.product_id.product_number,
                    configuration_limits, product_found);
              IF NOT product_found THEN
                CYCLE /find_unit/;
              IFEND;
              IF mainframe = cmv$installed_mainframe THEN
                IF NOT (channel_type IN configuration_limits.allowed_channels) THEN
                  osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_improper_channel_usage,
                        unit_element_p^.element_name, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, lc_element_p^.element_name,
                        status);
                  RETURN;
                IFEND;
              IFEND;
              IF NOT (iou_information_table [1].model_type IN configuration_limits.allowed_ious) THEN
                osp$set_status_abnormal (cmc$configuration_management_id, cme$device_not_allowed_on_iou, '',
                      status);
                RETURN;
              IFEND;

              { Special case: Because $698_3x tape units can be connected to both 5698 and 698 tape
              { controller, check to make sure that the correct channel is used.

              IF mainframe = cmv$installed_mainframe THEN
                IF ((element_p^.product_id.product_number = '  $698') AND
                      (channel_type = cmc$cio_channel_2_port)) OR
                      ((element_p^.product_id.product_number = ' $5698') AND
                      (channel_type = cmc$cio_channel_no_port)) THEN
                  osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_improper_channel_usage,
                        unit_element_p^.element_name, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, lc_element_p^.element_name,
                        status);
                  RETURN;
                IFEND;
              IFEND;
              EXIT /find_unit/; { Only need to check first unit on the channel.
            FOREND /find_unit/;

          ELSEIF element_p^.element_type = cmc$storage_device_element THEN
            cmp$return_configuration_limits (element_p^.product_id.product_number, configuration_limits,
                  product_found);
            IF product_found THEN
              IF mainframe = cmv$installed_mainframe THEN
                IF NOT (channel_type IN configuration_limits.allowed_channels) THEN
                  osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_improper_channel_usage,
                        element_p^.element_name, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, lc_element_p^.element_name,
                        status);
                  RETURN;
                IFEND;
              IFEND;
              IF NOT (iou_information_table [1].model_type IN configuration_limits.allowed_ious) THEN
                osp$set_status_abnormal (cmc$configuration_management_id, cme$device_not_allowed_on_iou, '',
                      status);
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        FOREND /channel_forloop/;

        IF NOT lc_element_p^.data_channel.concurrent THEN
          CYCLE /search_element_loop/;
        IFEND;

        { See if there is any other CIO channel with or without port and validate subsystem configured on
        { these channels.

        channel_name := lc_element_p^.element_name;
        IF lc_element_p^.data_channel.port = cmc$unspecified_port THEN
          char_to_check := ' ';
          channel_port := cmc$port_a;
          last_channel_port := cmc$port_b;
        ELSEIF lc_element_p^.data_channel.port = cmc$port_a THEN
          char_to_check := 'A';
          channel_port := cmc$unspecified_port;
          last_channel_port := cmc$port_b;
        ELSE
          char_to_check := 'B';
          channel_port := cmc$unspecified_port;
          last_channel_port := cmc$port_a;
        IFEND;
        done_checking := FALSE;
        starting_channel_name := channel_name;

        WHILE NOT done_checking DO
          string_index := 1;
          WHILE (string_index <= osc$max_name_size) AND (channel_name (string_index, 1) <> char_to_check) DO
            string_index := string_index + 1;
          WHILEND;
          IF channel_port = cmc$port_a THEN
            channel_name (string_index, 1) := 'A';
          ELSEIF channel_port = cmc$port_b THEN
            channel_name (string_index, 1) := 'B';
          ELSE
            channel_name (string_index, 1) := ' ';
          IFEND;
          cmp$find_element (channel_name, lc_element_p^.data_channel.iou,
                lc_element_p^.data_channel.mainframe_ownership, connected_lc_fid, channel_element_p,
                local_status);
          IF local_status.normal THEN
            FOR pen := LOWERVALUE (cmt$physical_equipment_number) TO
                  UPPERVALUE (cmt$physical_equipment_number) DO
              IF channel_element_p^.data_channel.connection.equipment [pen].configured THEN
                cmp$find_element (channel_element_p^.data_channel.connection.equipment [pen].element_name,
                      {not used} iou_name, osc$null_name, connected_lc_fid, element_p, local_status);
                IF local_status.normal AND (product_number <> element_p^.product_id.product_number) THEN
                  osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_mixture_of_product,
                        lc_element_p^.element_name, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, product_number, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        element_p^.product_id.product_number, status);
                  RETURN;
                IFEND;
              IFEND;
            FOREND;
          IFEND;
          done_checking := (channel_port = last_channel_port);
          channel_name := starting_channel_name;
          channel_port := last_channel_port;
        WHILEND;

      = cmc$controller_element =
        number_of_units_defined := 0;

        { Upline connections of controller can have multiple mainframe references.  Check the down_line
        { connections.

        FOR pun := LOWERVALUE (cmt$physical_unit_number) TO UPPERVALUE (cmt$physical_unit_number) DO
          IF lc_element_p^.controller.connection.unit [pun].configured THEN
            number_of_units_defined := number_of_units_defined + 1;
            cmp$find_element (lc_element_p^.controller.connection.unit [pun].element_name,
                  {not used} iou_name, osc$null_name, connected_lc_fid, element_p, local_status);
            IF NOT local_status.normal THEN
              lc_element_p^.controller.connection.unit [pun].configured := FALSE;
            IFEND;
          IFEND;
        FOREND;
        IF number_of_units_defined = 0 THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_connection,
                lc_element_p^.element_name, status);
          RETURN;
        IFEND;

      = cmc$storage_device_element =
        product_number := ' ';

        { Updates the upline connection of these storage device only to show connections to controller or
        { channel of the current mainframe.

       /storage_device_forloop/
        FOR dspn := LOWERVALUE (cmt$data_storage_port_number) TO UPPERVALUE (cmt$data_storage_port_number) DO
          IF NOT lc_element_p^.storage_device.connection.port [dspn].configured THEN
            CYCLE /storage_device_forloop/;
          IFEND;
          IF lc_element_p^.storage_device.connection.port [dspn].upline_connection_type =
                cmc$data_channel_element THEN
            iou_name := lc_element_p^.storage_device.connection.port [dspn].iou;
          IFEND;
          cmp$find_element (lc_element_p^.storage_device.connection.port [dspn].element_name, iou_name,
                mainframe, connected_lc_fid, element_p, local_status);
          IF NOT local_status.normal THEN
            lc_element_p^.storage_device.connection.port [dspn].configured := FALSE;
            CYCLE /storage_device_forloop/;
          IFEND;

          { Validates the proper type of controller is being used for this storage device element_p.

          cmp$return_configuration_limits (lc_element_p^.product_id.product_number, configuration_limits,
                product_found);
          IF NOT product_found OR (element_p^.element_type <> cmc$controller_element) THEN
            CYCLE /storage_device_forloop/;
          IFEND;

          cmp$get_controller_type (element_p^.product_id, controller_type, local_status);
          IF local_status.normal AND NOT (controller_type IN configuration_limits.allowed_controllers) THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_mixture_of_product,
                  lc_element_p^.element_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  lc_element_p^.product_id.product_number, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  element_p^.product_id.product_number, status);
            RETURN;
          IFEND;
          IF NOT (iou_information_table [1].model_type IN configuration_limits.allowed_ious) THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$device_not_allowed_on_iou, '',
                  status);
            RETURN;
          IFEND;

          { Validates that all products connected to the storage device are the same.

          IF product_number = ' ' THEN
            product_number := element_p^.product_id.product_number;
          ELSE
            IF (product_number <> element_p^.product_id.product_number) AND
                  NOT ((product_number = ' $7154') OR (product_number = ' $7155')) AND
                  NOT ((element_p^.product_id.product_number = ' $7154') OR
                  (element_p^.product_id.product_number = ' $7155')) THEN
              osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_mixture_of_product,
                    lc_element_p^.element_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, product_number, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    element_p^.product_id.product_number, status);
              RETURN;
            IFEND;
          IFEND;
        FOREND /storage_device_forloop/;

        cmp$get_unit_type (lc_element_p^.product_id, cm_unit_type, io_unit_type, unit_class, found);
        IF found AND (unit_class = cmc$mass_storage_unit) THEN
          number_of_spindles := number_of_spindles + 1;
          IF lc_element_p^.product_id.product_number <> ' $9836' THEN
            non_9836_count := non_9836_count + 1;
          IFEND;
        IFEND;

      = cmc$channel_adapter_element, cmc$external_processor_element, cmc$communications_element =

        { These element type could have multiple mainframes on the upline connections, do nothing.

      ELSE
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_unexpected_element_type,
              lc_element_p^.element_name, status);
        pid (1, 6) := lc_element_p^.product_id.product_number;
        pid (7, 1) := lc_element_p^.product_id.underscore;
        pid (8, 3) := lc_element_p^.product_id.model_number;
        osp$append_status_parameter (osc$status_parameter_delimiter, pid, status);
      CASEND;
    FOREND /search_element_loop/;

    IF mainframe <> cmv$installed_mainframe THEN
      RETURN;
    IFEND;

    { Check for presence of system device and Deadstart device.

    validate_system_device_path (connected_lc_fid, state_info_fid, cmc$sdt_disk_device, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF cmv$system_device_data [cmc$sdt_tape_device].specified THEN
      validate_system_device_path (connected_lc_fid, state_info_fid, cmc$sdt_tape_device, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    pmp$get_binary_processor_id (processor_element_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF ((processor_element_id.model_number = osc$cyber_180_model_930a) OR
          (processor_element_id.model_number = osc$cyber_180_model_930b) OR
          (processor_element_id.model_number = osc$cyber_180_model_930c) OR
          (processor_element_id.model_number = osc$cyber_180_model_932a) OR
          (processor_element_id.model_number = osc$cyber_180_model_932b)) THEN
      IF (number_of_spindles > c$max_ms_devices_allowed) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_ms_configuration, ' ', status);
      ELSEIF (non_9836_count <> 0) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$ms_device_not_allowed, ' ', status);
      IFEND;
    IFEND;

  PROCEND update_connectivity;
?? OLDTITLE ??
?? NEWTITLE := 'validate_foreign_devices', EJECT ??

{ PURPOSE:
{   This procedure makes a pass through the configuration file and reclassifies all foreign devices
{   accordingly as Controller or Storage Device.

  PROCEDURE validate_foreign_devices
    (    connected_lc_fid: amt$file_identifier;
         state_info_fid: amt$file_identifier;
     VAR status: ost$status);

    VAR
      element_ok: boolean,
      eoi_addr: ARRAY [1 .. 1] OF amt$access_info,
      lc_count: integer,
      lc_element_p: ^cmt$element_definition,
      lc_index: integer,
      lc_seg: amt$segment_pointer,
      pun: cmt$physical_unit_number,
      state_element_p: ^cmt$state_information,
      state_segment_pointer: amt$segment_pointer,
      temp_element: cmt$element_definition;

    status.normal := TRUE;
    element_ok := TRUE;

    eoi_addr [1].key := amc$eoi_byte_address;
    amp$fetch_access_information (connected_lc_fid, eoi_addr, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (eoi_addr [1].eoi_byte_address MOD #SIZE (cmt$element_definition)) <> 0 THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_incompatible_lc, ' ', status);
      RETURN;
    IFEND;
    lc_count := eoi_addr [1].eoi_byte_address DIV #SIZE (cmt$element_definition);

    amp$get_segment_pointer (connected_lc_fid, amc$sequence_pointer, lc_seg, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    amp$get_segment_pointer (state_info_fid, amc$sequence_pointer, state_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET lc_seg.sequence_pointer;
    RESET state_segment_pointer.sequence_pointer;

    FOR lc_index := 1 TO lc_count DO
      NEXT lc_element_p IN lc_seg.sequence_pointer;
      IF lc_element_p = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_empty_lc, ' ', status);
        RETURN;
      IFEND;
      NEXT state_element_p IN state_segment_pointer.sequence_pointer;
      IF state_element_p = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_empty_lc, ' ', status);
        RETURN;
      IFEND;

      IF (lc_element_p^.element_type = cmc$controller_element) AND
            NOT cmp$known_controller_id (lc_element_p^.product_id) THEN
        element_ok := FALSE;

       /check_connection/
        FOR pun := LOWERVALUE (cmt$physical_unit_number) TO UPPERVALUE (cmt$physical_unit_number) DO
          IF lc_element_p^.controller.connection.unit [pun].configured THEN
            element_ok := TRUE;
            EXIT /check_connection/;
          IFEND;
        FOREND /check_connection/;

        IF NOT element_ok THEN
          temp_element.element_type := cmc$storage_device_element;
          temp_element.element_name := lc_element_p^.element_name;
          temp_element.serial_number := lc_element_p^.serial_number;
          temp_element.product_id := lc_element_p^.product_id;
          temp_element.storage_device.physical_unit_number :=
                lc_element_p^.controller.physical_equipment_number;
          temp_element.storage_device.connection.port := lc_element_p^.controller.connection.port;
          lc_element_p^ := temp_element;
          state_element_p^.element_type := cmc$storage_device_element;
        IFEND;
      IFEND;
    FOREND;

  PROCEND validate_foreign_devices;
?? OLDTITLE ??
?? NEWTITLE := 'validate_system_device_path', EJECT ??

{ PURPOSE:
{   This procedure validates the presence and the correct logical state of the system/deastart device in the
{   configuration file.

  PROCEDURE validate_system_device_path
    (    connected_list_fid: amt$file_identifier;
         state_info_fid: amt$file_identifier;
         device: cmt$system_device_types;
     VAR status: ost$status);

    VAR
      channel: cmt$physical_channel,
      channel_element_p: ^cmt$element_definition,
      channel_name: cmt$element_name,
      channel_ordinal: cmt$channel_ordinal,
      equipment_number: cmt$physical_equipment_number,
      equipment_name: cmt$element_name,
      element_p: ^cmt$element_definition,
      iou_name: cmt$element_name,
      state_element_p: ^cmt$state_information,
      text: string (255),
      unit_element_p: ^cmt$element_definition,
      unit_name: cmt$element_name,
      unit_number: cmt$physical_unit_number,
      valid: boolean;

    status.normal := TRUE;
    channel_name := ' ';
    equipment_name := ' ';
    unit_name := ' ';
    text := ' ';

    cmp$get_system_device_path (device, iou_name, channel, equipment_number, unit_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cmp$convert_channel_number (channel.number, channel.concurrent, channel.port, channel_ordinal,
          channel_name, valid);
    IF NOT valid THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_channel_number,
            'Bad channel number encountered in validate_system_device_path', status);
      RETURN;
    IFEND;

   /determine_if_error/
    BEGIN
      cmp$find_element (channel_name, iou_name, cmv$installed_mainframe, connected_list_fid,
            channel_element_p, status);
      IF NOT status.normal OR (channel_element_p = NIL) THEN
        text (1, 49) := 'Unable to find system/deadstart device channel : ';
        text (50, *) := channel_name;
        EXIT /determine_if_error/;
      IFEND;

      IF channel_element_p^.data_channel.connection.equipment [equipment_number].configured THEN
        equipment_name :=
              channel_element_p^.data_channel.connection.equipment [equipment_number].element_name;
        cmp$find_element (equipment_name, {not used} iou_name, cmv$installed_mainframe, connected_list_fid,
              element_p, status);
        IF NOT status.normal OR (element_p = NIL) THEN
          text (1, 52) := 'Unable to find system/deadstart device controller: ';
          text (53, *) := equipment_name;
          EXIT /determine_if_error/;
        IFEND;
      ELSEIF channel_element_p^.data_channel.connection.equipment [unit_number].configured THEN
        unit_name := channel_element_p^.data_channel.connection.equipment [unit_number].element_name;
        cmp$find_element (unit_name, {not used} iou_name, cmv$installed_mainframe, connected_list_fid,
              element_p, status);
        IF NOT status.normal OR (element_p = NIL) THEN
          text (1, 42) := 'Unable to find system/deadstart device: ';
          text (43, *) := unit_name;
          EXIT /determine_if_error/;
        IFEND;
      ELSE
        text (1, 39) := 'Unable to find element connected to: ';
        text (40, *) := channel_name;
        EXIT /determine_if_error/;
      IFEND;

      IF element_p^.element_type = cmc$controller_element THEN
        IF NOT element_p^.controller.connection.unit [unit_number].configured THEN
          text (1, 54) := 'Unable to find system/deadstart device connected to : ';
          text (55, *) := equipment_name;
          EXIT /determine_if_error/;
        IFEND;
        unit_name := element_p^.controller.connection.unit [unit_number].element_name;
        cmp$find_element (unit_name, {not used} iou_name, cmv$installed_mainframe, connected_list_fid,
              unit_element_p, status);
        IF NOT status.normal OR (unit_element_p = NIL) THEN
          text (1, 41) := 'Unable to find system/deadstart device : ';
          text (42, *) := unit_name;
          EXIT /determine_if_error/;
        IFEND;
      ELSEIF element_p^.element_type = cmc$storage_device_element THEN
        IF unit_name = osc$null_name THEN
          unit_name := equipment_name;
        IFEND;
        IF element_p^.storage_device.physical_unit_number <> unit_number THEN
          text (1, 41) := 'Unable to find system/deadstart device : ';
          text (42, *) := unit_name;
          EXIT /determine_if_error/;
        IFEND;
      IFEND;

      IF equipment_name <> osc$null_name THEN
        cmp$find_state_element (equipment_name, {not used} iou_name, state_info_fid, state_element_p, status);
        IF NOT status.normal OR (state_element_p = NIL) THEN
          text := 'Unable to determine state of system device equipment.';
          EXIT /determine_if_error/;
        IFEND;
        IF state_element_p^.status.state <> cmc$on THEN
          text := 'System/deadstart controller is not in the ON state.';
          EXIT /determine_if_error/;
        IFEND;
      IFEND;

      cmp$find_state_element (unit_name, {not used} iou_name, state_info_fid, state_element_p, status);
      IF NOT status.normal OR (state_element_p = NIL) THEN
        text := 'Unable to determine state of system device unit.';
        EXIT /determine_if_error/;
      IFEND;
      IF state_element_p^.status.state <> cmc$on THEN
        text := 'System/deadstart device is not in the ON state.';
        EXIT /determine_if_error/;
      IFEND;
      RETURN;
    END /determine_if_error/;

    osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_sys_dev_path_not_found, iou_name,
          status);
    osp$append_status_parameter (osc$status_parameter_delimiter, channel_name, status);
    osp$append_status_integer (osc$status_parameter_delimiter, equipment_number, 10, TRUE, status);
    osp$append_status_integer (osc$status_parameter_delimiter, unit_number, 10, TRUE, status);
    osp$append_status_parameter (osc$status_parameter_delimiter, text, status);

  PROCEND validate_system_device_path;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$acquire_all_peripherals ',EJECT ??

{ PURPOSE:
{   This procedure determines how many IOU resources to be acquired, builds the I/O interface tables and
{   activates the full configuration.

  PROCEDURE [XDCL] cmp$acquire_all_peripherals
    (VAR status: ost$status);

    VAR
      intervention_array: ARRAY [1 .. 1] OF clt$boolean,
      intervention_variable: clt$variable_reference,
      iou_name: cmt$element_name,
      line: string (80),
      set_operator_intervention: boolean,
      state: cmt$element_state;

    status.normal := TRUE;

    cmp$acquire_all_peripherals_r1 (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Check the state of the System/Deadstart device channel.  If it is not ON then allow operator
    { intervention in LCU to turn it back ON.

    set_operator_intervention := FALSE;
    line := ' ';

    IF cmv$system_device_data [cmc$sdt_tape_device].specified THEN
      cmp$convert_iou_number (cmv$system_device_data [cmc$sdt_tape_device].iou_number, iou_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      cmp$get_element_state (cmv$system_device_data [cmc$sdt_tape_device].channel_name, iou_name, state,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF state <> cmc$on THEN
        line (1, 28) := ' Deadstart device channel : ';
        line (29, 5) := iou_name (1, 5);
        line (35, 5) := cmv$system_device_data [cmc$sdt_tape_device].channel_name;
        line (41, *) := 'is not in the ON state.';
        syp$display_deadstart_message (line);
        syp$display_deadstart_message (' If this is the only channel to the deadstart device, you must use');
        syp$display_deadstart_message (' the LCU command CHANGE_ELEMENT_STATE to turn it ON.');
        set_operator_intervention := TRUE;
        press_next;
      IFEND;
    IFEND;

    cmp$convert_iou_number (cmv$system_device_data [cmc$sdt_disk_device].iou_number, iou_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cmp$get_element_state (cmv$system_device_data [cmc$sdt_disk_device].channel_name, iou_name, state,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF state <> cmc$on THEN
      line := ' ';
      line (1, 25) := ' System device channel : ';
      line (27, 5) := iou_name (1, 5);
      line (34, 6) := cmv$system_device_data [cmc$sdt_disk_device].channel_name;
      line (42, *) := 'is not in the ON state.';
      syp$display_deadstart_message (line);
      syp$display_deadstart_message (' You may use the LCU command CHANGE_ELEMENT_STATE to turn it ON,');
      syp$display_deadstart_message (' if you have dual access.');
      set_operator_intervention := TRUE;
      press_next;
    IFEND;

    IF set_operator_intervention THEN
      intervention_array [1].value := TRUE;
      intervention_array [1].kind := clc$true_false_boolean;
      clp$read_variable ('CMV$FORCE_INTERVENTION', intervention_variable, status);
      intervention_variable.value.boolean_value := ^intervention_array;
      clp$write_variable ('CMV$FORCE_INTERVENTION', intervention_variable.value, status);
    IFEND;

  PROCEND cmp$acquire_all_peripherals;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$build_active_conf', EJECT ??

{ PURPOSE:
{   This procedure builds two files containing information for all peripherals belonging to the current
{   mainframe. It will discard all other mainframes' equipments.

  PROCEDURE [XDCL] cmp$build_active_conf
    (    connected_pc_fid: amt$file_identifier;
         connected_active_fid: amt$file_identifier;
         state_info_fid: amt$file_identifier;
         active_state_info_fid: amt$file_identifier;
         mainframe: cmt$element_name;
     VAR status: ost$status);

    TYPE
      t$tape_subsystem = RECORD
        dual_pp_present: boolean,
        dual_pp_name: cmt$element_name,
        single_pp_present: boolean,
        single_pp_name: cmt$element_name,
      RECEND;

    VAR
      active_state_element_p: ^cmt$state_information,
      active_state_info_seg: amt$segment_pointer,
      commpn: cmt$communications_port_number,
      connected_list_element_p: ^cmt$element_definition,
      connected_list_seg: amt$segment_pointer,
      connected_pc_count: integer,
      connected_pc_element_p: ^cmt$element_definition,
      connected_pc_index: integer,
      connected_pc_seg: amt$segment_pointer,
      controller_type: cmt$controller_type,
      cpn: cmt$controller_port_number,
      element_p: ^cmt$element_definition,
      eoi_addr: ARRAY [1 .. 1] OF amt$access_info,
      iou_name: cmt$element_name,
      lc_list_element_p: ^cmt$state_information,
      local_status: ost$status,
      mainframe_found: boolean,
      sd_port: cmt$data_storage_port_number,
      state_info_seg: amt$segment_pointer,
      tape_subsystem: t$tape_subsystem;

    status.normal := TRUE;
    mainframe_found := FALSE;
    tape_subsystem.dual_pp_present := FALSE;
    tape_subsystem.single_pp_present := FALSE;

    eoi_addr [1].key := amc$eoi_byte_address;
    amp$fetch_access_information (connected_pc_fid, eoi_addr, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT eoi_addr [1].item_returned THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_empty_lc, ' ', status);
      RETURN;
    IFEND;

    IF (eoi_addr [1].eoi_byte_address MOD #SIZE (cmt$element_definition)) <> 0 THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_incompatible_lc, ' ', status);
      RETURN;
    IFEND;
    connected_pc_count := eoi_addr [1].eoi_byte_address DIV #SIZE (cmt$element_definition);

    amp$get_segment_pointer (connected_pc_fid, amc$sequence_pointer, connected_pc_seg, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (connected_active_fid, amc$sequence_pointer, connected_list_seg, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (state_info_fid, amc$sequence_pointer, state_info_seg, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (active_state_info_fid, amc$sequence_pointer, active_state_info_seg, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET state_info_seg.sequence_pointer;
    RESET active_state_info_seg.sequence_pointer;
    RESET connected_list_seg.sequence_pointer;
    RESET connected_pc_seg.sequence_pointer;

   /connected_pc_loop/
    FOR connected_pc_index := 1 TO connected_pc_count DO
      NEXT connected_pc_element_p IN connected_pc_seg.sequence_pointer;
      IF connected_pc_element_p = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_empty_lc, ' ', status);
        RETURN;
      IFEND;
      NEXT lc_list_element_p IN state_info_seg.sequence_pointer;
      IF lc_list_element_p = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_empty_lc, ' ', status);
        RETURN;
      IFEND;

      IF lc_list_element_p^.element_type <> cmc$data_channel_element THEN
        IF lc_list_element_p^.application_info_size <> 0 THEN
          NEXT lc_list_element_p^.application_info_p: [lc_list_element_p^.application_info_size] IN
                state_info_seg.sequence_pointer;
          IF lc_list_element_p^.application_info_p = NIL THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_empty_lc, ' ', status);
            RETURN;
          IFEND;
        IFEND;

        IF lc_list_element_p^.site_info_size <> 0 THEN
          NEXT lc_list_element_p^.site_info_p: [lc_list_element_p^.site_info_size] IN
                state_info_seg.sequence_pointer;
          IF lc_list_element_p^.site_info_p = NIL THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_empty_lc, ' ', status);
            RETURN;
          IFEND;
        IFEND;
      IFEND;

      amp$set_segment_eoi (connected_active_fid, connected_list_seg, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$set_segment_eoi (active_state_info_fid, active_state_info_seg, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

     /find_element_match/
      BEGIN
        CASE connected_pc_element_p^.element_type OF
        = cmc$data_channel_element =
          IF connected_pc_element_p^.data_channel.mainframe_ownership = mainframe THEN
            IF NOT mainframe_found THEN
              mainframe_found := TRUE;
            IFEND;
            EXIT /find_element_match/;
          IFEND;

        = cmc$controller_element =
          FOR cpn := LOWERVALUE (cmt$controller_port_number) TO UPPERVALUE (cmt$controller_port_number) DO
            IF connected_pc_element_p^.controller.connection.port [cpn].configured AND (mainframe =
                  connected_pc_element_p^.controller.connection.port [cpn].mainframe_ownership) THEN
              cmp$get_controller_type (connected_pc_element_p^.product_id, controller_type, local_status);
              IF (controller_type = cmc$mt698_xx) OR (controller_type = cmc$mt7221_1) OR
                    (controller_type = cmc$mt7021_3x) THEN
                IF NOT tape_subsystem.dual_pp_present AND
                      (connected_pc_element_p^.controller.peripheral_driver_name(1, 2) = 'E2') THEN
                  tape_subsystem.dual_pp_present := TRUE;
                  tape_subsystem.dual_pp_name := connected_pc_element_p^.element_name;
                IFEND;
                IF NOT tape_subsystem.single_pp_present AND
                      (connected_pc_element_p^.controller.peripheral_driver_name(1, 2) = 'E1') THEN
                  tape_subsystem.single_pp_present := TRUE;
                  tape_subsystem.single_pp_name := connected_pc_element_p^.element_name;
                IFEND;
              IFEND;
              EXIT /find_element_match/;
            IFEND;
          FOREND;

        = cmc$channel_adapter_element =
          IF connected_pc_element_p^.channel_adapter.connection.channel.configured AND
                (connected_pc_element_p^.channel_adapter.connection.channel.upline_connection_type =
                cmc$data_channel_element) AND (mainframe =
                connected_pc_element_p^.channel_adapter.connection.channel.mainframe_ownership) THEN
            EXIT /find_element_match/;
          IFEND;

        = cmc$communications_element =
          FOR commpn := LOWERVALUE (cmt$communications_port_number) TO
                UPPERVALUE (cmt$communications_port_number) DO
            IF connected_pc_element_p^.communications_element.connection.port [commpn].configured THEN
              IF connected_pc_element_p^.communications_element.connection.port [commpn].mainframe_ownership =
                    mainframe THEN
                EXIT /find_element_match/;
              IFEND;
            IFEND;
          FOREND;

        = cmc$external_processor_element =
          FOR cpn := LOWERVALUE(cmt$controller_port_number) TO UPPERVALUE (cmt$controller_port_number) DO
            IF connected_pc_element_p^.external_processor.connection.io_port [cpn].configured THEN
              IF connected_pc_element_p^.external_processor.connection.io_port [cpn].mainframe_ownership =
                    mainframe THEN
                EXIT /find_element_match/;
              IFEND;
            IFEND;
          FOREND;

        = cmc$storage_device_element =
          FOR sd_port := LOWERVALUE (cmt$data_storage_port_number) TO
                UPPERVALUE (cmt$data_storage_port_number) DO
            IF connected_pc_element_p^.storage_device.connection.port [sd_port].configured THEN
              IF connected_pc_element_p^.storage_device.connection.port [sd_port].upline_connection_type =
                    cmc$data_channel_element THEN
                IF connected_pc_element_p^.storage_device.connection.port [sd_port].mainframe_ownership =
                      mainframe THEN
                  EXIT /find_element_match/;
                IFEND;
              ELSEIF connected_pc_element_p^.storage_device.connection.port [sd_port].upline_connection_type =
                    cmc$controller_element THEN
                cmp$find_element (
                      connected_pc_element_p^.storage_device.connection.port [sd_port].element_name, iou_name,
                      mainframe, connected_pc_fid, element_p, local_status);
                IF local_status.normal THEN
                  FOR cpn := LOWERVALUE (cmt$controller_port_number) TO
                        UPPERVALUE (cmt$controller_port_number) DO
                    IF element_p^.controller.connection.port [cpn].configured AND
                          (mainframe = element_p^.controller.connection.port [cpn].mainframe_ownership) THEN
                      EXIT /find_element_match/;
                    IFEND;
                  FOREND;
                ELSE
                  osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_connection_not_found,
                                           connected_pc_element_p^.element_name, status);
                  RETURN;
                IFEND;
              IFEND;
            IFEND;
          FOREND;
        ELSE
        CASEND;

        CYCLE /connected_pc_loop/;

      END /find_element_match/;

      { Found a match, now move the element over. }

      IF tape_subsystem.dual_pp_present AND tape_subsystem.single_pp_present THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_inconsistent_tape_subs,
              tape_subsystem.dual_pp_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, tape_subsystem.single_pp_name, status);
        RETURN;
      IFEND;

      NEXT connected_list_element_p IN connected_list_seg.sequence_pointer;
      IF connected_list_element_p = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_empty_lc, ' ', status);
        RETURN;
      IFEND;

      connected_list_element_p^ := connected_pc_element_p^;
      amp$set_segment_eoi (connected_active_fid, connected_list_seg, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$set_segment_position (connected_active_fid, connected_list_seg, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      NEXT active_state_element_p IN active_state_info_seg.sequence_pointer;
      active_state_element_p^.element_name := lc_list_element_p^.element_name;
      active_state_element_p^.status := lc_list_element_p^.status;
      active_state_element_p^.element_type := lc_list_element_p^.element_type;
      IF active_state_element_p^.element_type = cmc$data_channel_element THEN
        active_state_element_p^.iou := lc_list_element_p^.iou;
      ELSE
        active_state_element_p^.product_id := lc_list_element_p^.product_id;
        active_state_element_p^.application_info_size := lc_list_element_p^.application_info_size;
        active_state_element_p^.site_info_size := lc_list_element_p^.site_info_size;
        IF lc_list_element_p^.application_info_size <> 0 THEN
          NEXT active_state_element_p^.application_info_p: [lc_list_element_p^.application_info_size] IN
                active_state_info_seg.sequence_pointer;
          active_state_element_p^.application_info_p^ := lc_list_element_p^.application_info_p^;
        ELSE
          active_state_element_p^.application_info_p := NIL;
        IFEND;

        IF lc_list_element_p^.site_info_size <> 0 THEN
          NEXT active_state_element_p^.site_info_p: [lc_list_element_p^.site_info_size] IN
                active_state_info_seg.sequence_pointer;
          active_state_element_p^.site_info_p^ := lc_list_element_p^.site_info_p^;
        ELSE
          active_state_element_p^.site_info_p := NIL;
        IFEND;
      IFEND;

      amp$set_segment_eoi (active_state_info_fid, active_state_info_seg, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      amp$set_segment_position (active_state_info_fid, active_state_info_seg, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND /connected_pc_loop/;

    IF NOT mainframe_found THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_mainframe_not_found, mainframe,
            status);
      RETURN;
    IFEND;

    update_connectivity (connected_active_fid, active_state_info_fid, mainframe, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Validate all elements not known to NOS/VE and reclassify them accordingly as storage device or
    { controller.

    validate_foreign_devices (connected_active_fid, active_state_info_fid, status);

  PROCEND cmp$build_active_conf;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$build_conf_tables', EJECT ??

{ PURPOSE:
{   This procedure builds the various mainframe pageable structures and assigns logical units to all
{   applicable elements.
{ NOTE:
{   The information used to build those tables are from two files created via INSPC.

  PROCEDURE [XDCL] cmp$build_conf_tables
    (VAR physical_conf_fid: amt$file_identifier;
     VAR state_info_fid: amt$file_identifier;
     VAR status: ost$status);

    VAR
      channel: cmt$physical_channel,
      eoi_addr: ARRAY [1 .. 1] OF amt$access_info,
      equipment_number: cmt$physical_equipment_number,
      iou_name: cmt$element_name,
      lc_index: integer,
      logical_element_index: integer,
      logical_conf_seg: amt$segment_pointer,
      physical_element_count: integer,
      physical_element_index: integer,
      physical_conf_array_p: cmt$physical_configuration,
      physical_conf_seg: amt$segment_pointer,
      physical_conf_element_p: ^cmt$element_definition,
      state_info_element_p: ^cmt$state_information,
      state_element_array_p: ^ARRAY [ * ] OF cmt$state_information,
      system_device_lun: iot$logical_unit,
      unit_number: cmt$physical_unit_number;

    status.normal := TRUE;
    eoi_addr [1].key := amc$eoi_byte_address;
    amp$fetch_access_information (physical_conf_fid, eoi_addr, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT eoi_addr [1].item_returned THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$jtd_eoi_not_returned,
            'eoi not returned"cmp$configure_peripheral"physical_conf_fid', status);
      RETURN;
    IFEND;
    physical_element_count := eoi_addr [1].eoi_byte_address DIV #SIZE (cmt$element_definition);
    PUSH physical_conf_array_p: [1 .. physical_element_count];
    IF physical_conf_array_p = NIL THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$jtd_nil_sequence_pointer,
            'physical_conf_array_p in cmp$build_conf_tables, cmm$configure_in_job_template', status);
      RETURN;
    IFEND;

    amp$fetch_access_information (state_info_fid, eoi_addr, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT eoi_addr [1].item_returned THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$jtd_eoi_not_returned,
            'eoi not returned"cmp$configure_peripheral"state_info_fid', status);
      RETURN;
    IFEND;
    PUSH state_element_array_p: [1 .. physical_element_count];
    IF state_element_array_p = NIL THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$jtd_nil_sequence_pointer,
            'state_element_array_p in cmp$build_conf_tables, cmm$configure_in_job_template', status);
      RETURN;
    IFEND;

    amp$get_segment_pointer (physical_conf_fid, amc$sequence_pointer, physical_conf_seg, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    amp$get_segment_pointer (state_info_fid, amc$sequence_pointer, logical_conf_seg, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET logical_conf_seg.sequence_pointer;
    RESET physical_conf_seg.sequence_pointer;

    lc_index := 1;
    FOR logical_element_index := 1 TO physical_element_count DO
      NEXT physical_conf_element_p IN physical_conf_seg.sequence_pointer;
      IF physical_conf_element_p = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$jtd_nil_sequence_pointer,
              'physical_conf_element_p in cmp$build_conf_tables, cmm$configure_in_job_template', status);
        RETURN;
      IFEND;
      NEXT state_info_element_p IN logical_conf_seg.sequence_pointer;
      IF state_info_element_p = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$jtd_nil_sequence_pointer,
              'state_info_element_p in cmp$build_conf_tables, cmm$configure_in_job_template', status);
        RETURN;
      IFEND;

      IF state_info_element_p^.element_name = physical_conf_element_p^.element_name THEN
        state_element_array_p^ [lc_index].element_name := state_info_element_p^.element_name;
        state_element_array_p^ [lc_index].status := state_info_element_p^.status;
        state_element_array_p^ [lc_index].element_type := state_info_element_p^.element_type;
        IF state_element_array_p^ [lc_index].element_type = cmc$data_channel_element THEN
          state_element_array_p^ [lc_index].iou := state_info_element_p^.iou;
        ELSE
          state_element_array_p^ [lc_index].product_id := state_info_element_p^.product_id;
          state_element_array_p^ [lc_index].application_info_size :=
                state_info_element_p^.application_info_size;
          state_element_array_p^ [lc_index].site_info_size := state_info_element_p^.site_info_size;
          IF state_info_element_p^.application_info_size <> 0 THEN
            NEXT state_info_element_p^.application_info_p: [state_info_element_p^.application_info_size] IN
                  logical_conf_seg.sequence_pointer;
            PUSH state_element_array_p^ [lc_index].application_info_p:
                  [STRLENGTH (state_info_element_p^.application_info_p^)];
            state_element_array_p^ [lc_index].application_info_p^ :=
                  state_info_element_p^.application_info_p^;
          ELSE
            state_element_array_p^ [lc_index].application_info_p := NIL;
          IFEND;
          IF state_info_element_p^.site_info_size <> 0 THEN
            NEXT state_info_element_p^.site_info_p: [state_info_element_p^.site_info_size] IN
                  logical_conf_seg.sequence_pointer;
            PUSH state_element_array_p^ [lc_index].site_info_p:
                  [STRLENGTH (state_info_element_p^.site_info_p^)];
            state_element_array_p^ [lc_index].site_info_p^ := state_info_element_p^.site_info_p^;
          ELSE
            state_element_array_p^ [lc_index].site_info_p := NIL;
          IFEND;
          state_element_array_p^ [lc_index].logical_unit := 0;
        IFEND;
        lc_index :=  lc_index + 1;
      IFEND;
    FOREND;

    RESET physical_conf_seg.sequence_pointer;

    FOR physical_element_index := 1 TO physical_element_count DO
      NEXT physical_conf_element_p IN physical_conf_seg.sequence_pointer;
      IF physical_conf_element_p = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$jtd_nil_sequence_pointer,
              'physical_conf_element_p in cmp$build_conf_tables, cmm$configure_in_job_template', status);
        RETURN;
      IFEND;
      physical_conf_array_p^ [physical_element_index] := physical_conf_element_p^;
    FOREND;

    cmp$get_system_device_path (cmc$sdt_disk_device, iou_name, channel, equipment_number, unit_number,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    system_device_lun := cmc$job_template_unit_ordinal;
    syp$trace_deadstart_message ('building cm tables');
    cmp$build_pct (physical_element_count, physical_conf_array_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$build_state_table (UPPERBOUND (state_element_array_p^), state_element_array_p^,
          {use_mrt_state=} TRUE, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$assign_logical_unit_numbers (iou_name, equipment_number, unit_number, system_device_lun, status);

  PROCEND cmp$build_conf_tables;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$check_for_unique_element', EJECT ??

{ PURPOSE:
{   This procedure searches a segment access file constructed as a sequence of to see if the named element
{   is unique.  A mainframe parameter must be specified, it is only used when the element refers to a
{   channel element.

  PROCEDURE [XDCL, #GATE] cmp$check_for_unique_element
    (    name: cmt$element_name;
         mainframe: cmt$element_name;
         input_fid: amt$file_identifier;
     VAR status: ost$status);

    VAR
      element_p: ^cmt$element_definition,
      eoi_addr: ARRAY [1 .. 1] OF amt$access_info,
      loop_count: integer,
      loop_index: integer,
      seg: amt$segment_pointer;

    status.normal := TRUE;
    eoi_addr [1].key := amc$eoi_byte_address;
    amp$fetch_access_information (input_fid, eoi_addr, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT eoi_addr [1].item_returned THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_incompatible_lc, ' ', status);
      RETURN;
    IFEND;
    loop_count := eoi_addr [1].eoi_byte_address DIV #SIZE (cmt$element_definition);

    amp$get_segment_pointer (input_fid, amc$sequence_pointer, seg, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET seg.sequence_pointer;

    FOR loop_index := 1 TO loop_count DO
      NEXT element_p IN seg.sequence_pointer;
      IF element_p^.element_name = name THEN
        IF element_p^.element_type = cmc$data_channel_element THEN
          IF mainframe = element_p^.data_channel.mainframe_ownership THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_duplicate_element_names, name,
                  status);
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_duplicate_element_names, name,
                status);
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND cmp$check_for_unique_element;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$check_init_status', EJECT ??

{ PURPOSE:
{   This procedure checks the status from INITIALIZE_MS_VOLUMES and performs the dialog with the operator to
{   allow him/her to back out of the INIMV process.

  PROCEDURE [XDCL, #GATE] cmp$check_init_status
    (    status: ost$status;
         initialize_status_info: dmt$initialize_status_info;
         element: cmt$element_name;
     VAR continue_initialization: boolean);

    VAR
      ignore_status: ost$status,
      line: string (80);

    IF (osv$deadstart_phase = osc$installation_deadstart) AND NOT cmv$post_deadstart THEN
      continue_initialization := TRUE;
      RETURN;
    IFEND;

    IF status.normal THEN
      RETURN;
    IFEND;

    IF status.condition = dme$vol_label_date_not_expired THEN
      clp$put_job_output (' INITIALIZE_MS_VOLUME detected a recorded volume serial number: ', ignore_status);
      line := ' ';
      line (3, 7) := initialize_status_info.recorded_vsn;
      line (11, 12) := 'for element ';
      line (24, *) := element;
      clp$put_job_output (line, ignore_status);
      clp$put_job_output (' Files on this volume will be lost if you initialize it.', ignore_status);
    ELSE
      clp$put_job_output (' INITIALIZE_MS_VOLUME detected the following error :', ignore_status);
      osp$generate_error_message (status, ignore_status);
    IFEND;
    cmp$prompt_for_answer (' Enter YES to allow initialize to continue, NO to stop.',
          continue_initialization);

  PROCEND cmp$check_init_status;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$configure_peripheral', EJECT ??

{ PURPOSE:
{   This procedure is used at configuration transition time to set up SCL variables for the
{   SYSTEM_DEADSTART_PROLOG procedure and to invoke the SYSTEM_DEADSTART_PROLOG procedure.  The latter in
{   turns will invoke PCU and LCU to allow more peripheral subsystem to be configured and activated.

  PROCEDURE [XDCL] cmp$configure_peripheral
    (VAR status: ost$status);

    CONST
      c$physical_config_file_name = 'PHYSICAL_CONFIG                ';

    VAR
      cm_status: clt$variable_reference,
      file_attributes_p: ^amt$file_attributes,
      ignore_status: ost$status,
      pc_fid: amt$file_identifier,
      status_array: ARRAY [1 .. 1] OF clt$status;

    status.normal := TRUE;
    initialize_cm_variables;

    PUSH file_attributes_p: [1 .. 2];
    file_attributes_p^ [1].key := amc$access_mode;
    file_attributes_p^ [1].access_mode :=
          $pft$usage_selections [pfc$read, pfc$modify, pfc$execute, pfc$shorten, pfc$append];
    file_attributes_p^ [2].key := amc$ring_attributes;
    file_attributes_p^ [2].ring_attributes.r1 := osc$user_ring;
    file_attributes_p^ [2].ring_attributes.r2 := osc$user_ring;
    file_attributes_p^ [2].ring_attributes.r3 := osc$user_ring;
    IF osv$deadstart_phase = osc$installation_deadstart THEN
      amp$open ('CMF$DEFAULT_CONFIGURATION      ', amc$record, file_attributes_p, pc_fid, status);
      prepare_configuration_file (pc_fid);

    ELSEIF cmv$use_installed_configuration THEN
      amp$return (c$physical_config_file_name, ignore_status);
      amp$open (c$physical_config_file_name, amc$record, file_attributes_p, pc_fid, status);
      IF NOT status.normal THEN
        syp$process_deadstart_status (' ', FALSE, status);
        RETURN;
      IFEND;

      { Copy device file to BAM file.

      cmp$get_conf_file (pc_fid, status);
      IF NOT status.normal THEN
        clp$convert_to_clt$status (status, status_array [1]);
        cm_status.value.kind := clc$status_value;
        cm_status.value.status_value := ^status_array;
        clp$write_variable ('CMV$DEVICE_FILE_COPY_STATUS', cm_status.value, status);
        IF NOT status.normal THEN
          syp$process_deadstart_status (' ', FALSE, status);
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    amp$close (pc_fid, ignore_status);

    clp$include_line ('$LOCAL.OSF$DS_LIBRARY.CMP$SYSTEM_DEADSTART_PROLOG', TRUE, osc$null_name, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status (' ', FALSE, status);
      RETURN;
    IFEND;

  PROCEND cmp$configure_peripheral;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$find_element', EJECT ??

{ PURPOSE:
{   This procedure searches a segment access file that is in the form of a sequence for a particular element.
{   A mainframe parameter must be specified, it is only used when the element refers to a channel element.

  PROCEDURE [XDCL, #GATE] cmp$find_element
    (    element_name: cmt$element_name;
         iou_name: cmt$element_name;
         mainframe_owner: cmt$element_name;
         fid: amt$file_identifier;
     VAR element_p: ^cmt$element_definition;
     VAR status: ost$status);

    VAR
      eoi_addr: ARRAY [1 .. 1] OF amt$access_info,
      loop_count: integer,
      loop_index: integer,
      seg: amt$segment_pointer;

    status.normal := TRUE;
    element_p := NIL;

    eoi_addr [1].key := amc$eoi_byte_address;
    amp$fetch_access_information (fid, eoi_addr, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT eoi_addr [1].item_returned THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_incompatible_lc, ' ', status);
      RETURN;
    IFEND;
    loop_count := eoi_addr [1].eoi_byte_address DIV #SIZE (cmt$element_definition);

    amp$get_segment_pointer (fid, amc$sequence_pointer, seg, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET seg.sequence_pointer;

    FOR loop_index := 1 TO loop_count DO
      NEXT element_p IN seg.sequence_pointer;
      IF element_p = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_element_not_found, element_name,
              status);
        RETURN;
      IFEND;
      IF element_p^.element_name = element_name THEN
        CASE element_p^.element_type OF
        = cmc$storage_device_element, cmc$controller_element, cmc$channel_adapter_element,
                cmc$external_processor_element, cmc$communications_element =
          RETURN;
        = cmc$data_channel_element =
          IF (element_p^.data_channel.mainframe_ownership = mainframe_owner) AND
                (element_p^.data_channel.iou = iou_name) THEN
            RETURN;
          IFEND;
        ELSE
        CASEND;
      IFEND;
    FOREND;

    osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_element_not_found, element_name,
          status);

  PROCEND cmp$find_element;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_volumes_active', EJECT ??

{ PURPOSE:
{   This procedure activates all ON Volumes in the configuration.  All Volumes in the ON state will be
{   redundantly activated if LCU is exited:
{     1. During a continuation deadstart
{     2. During an installation deadstart with Recover_system_set
{     3. After Deadstart is completed.

  PROCEDURE [XDCL, #GATE] cmp$get_volumes_active
    (VAR status: ost$status);

    VAR
      active_path: boolean,
      condition_name: ost$status_condition_name,
      continue: boolean,
      element_p: ^cmt$element_definition,
      element_descriptor: cmt$element_descriptor,
      down_element: boolean,
      iou_name: cmt$element_name,
      job_mode: jmt$job_mode,
      local_status: ost$status,
      lun: iot$logical_unit,
      message: string (60),
      operator_message: string (256),
      operator_message_length: integer,
      operator_response: ost$string,
      state: cmt$element_state,
      unit_index: integer,
      yes_replied: boolean;

    status.normal := TRUE;
    iou_name := 'IOU0';
    message := ' ';

    IF NOT ((osv$deadstart_phase <> osc$installation_deadstart) OR
          ((osv$deadstart_phase = osc$installation_deadstart) AND cmv$post_deadstart) OR
          (osv$recover_system_set_phase = osc$reinitialize_system_device)) THEN
      RETURN;
    IFEND;

   /forloop/
    FOR lun := cmc$job_template_unit_ordinal TO UPPERVALUE (iot$logical_unit) DO
      cmp$pc_get_logical_unit (lun, element_p, local_status);
      IF NOT local_status.normal THEN
        EXIT /forloop/;
      IFEND;

     /unit_loop/
      FOR unit_index := 1 TO UPPERBOUND (cmv$product_id_ptr^) DO
        IF (cmv$product_id_ptr^ [unit_index].cm_unit_type < cmc$ms844_4x) OR
              (cmv$product_id_ptr^ [unit_index].product_id <> element_p^.product_id) THEN
          CYCLE /unit_loop/;
        IFEND;
        cmp$get_element_state (element_p^.element_name, {not used} iou_name, state, local_status);
        IF state <> cmc$on THEN
          CYCLE /unit_loop/;
        IFEND;
        cmp$verify_active_path (element_p^, active_path);
        IF NOT active_path THEN
          CYCLE /unit_loop/;
        IFEND;

        down_element := FALSE;
        continue := TRUE;
        REPEAT
          dmp$get_volume_active (lun, element_p^.product_id, local_status);
          IF NOT local_status.normal THEN
            IF (local_status.condition <> dme$volume_already_active) AND
                  (local_status.condition <> ste$vol_not_found) AND
                  (local_status.condition <> dme$volume_already_online) THEN
              pfp$log_error (local_status, $pmt$ascii_logset [pmc$job_log, pmc$system_log],
                    pmc$msg_origin_system, TRUE);
              pmp$get_job_mode (job_mode, status);
              IF jmp$system_job() OR (job_mode <> jmc$batch) THEN
                clp$put_job_output (
                      ' WARNING -- The following error was detected while activating volume mounted on',
                      status);
                message (2, *) := element_p^.element_name;
                clp$put_job_output (message, status);
                osp$generate_error_message (local_status, status);
                cmp$prompt_for_answer (' Do you want to retry activating that volume?', continue);
              ELSE
                osp$get_status_condition_name (local_status.condition, condition_name, status);
                STRINGREP (operator_message, operator_message_length,
                      ' WARNING -- The error ', condition_name (1, clp$trimmed_string_size(condition_name)),
                      ' was detected while activating volume ',
                      element_p^.element_name (1, clp$trimmed_string_size(element_p^.element_name)),
                      '.  Do you want to retry activating this volume? (Reply with yes or no)');
                ofp$send_operator_message (operator_message (1, operator_message_length),
                      ofc$system_operator, {acknowledgement_allowed = } TRUE, status);
                ofp$receive_operator_response (ofc$system_operator, osc$wait, operator_response, status);
                continue := (operator_response.value(1) = 'Y') OR (operator_response.value(1) = 'y');
              IFEND;
              IF continue THEN

                { Turn DOWN then ON the element to clear anything set by DM or IO.  STATUS is ignored if
                { cannot turn element back to ON.

                element_descriptor.element_type := element_p^.element_type;
                element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
                element_descriptor.peripheral_descriptor.element_name := element_p^.element_name;
                cmp$process_state_change ({tape_element=} FALSE, {clear_lock_behind=} TRUE,
                      {system_call=} TRUE, element_descriptor, {system_critical} FALSE, state,
                      {new_state=} cmc$down, status);
                IF status.normal THEN
                  cmp$process_state_change ({tape_element=} FALSE, {clear_lock_behind=} TRUE,
                        {system_call=} TRUE, element_descriptor, {system_critical} FALSE, cmc$down,
                        {new_state=} cmc$on, status);
                IFEND;
              ELSE
                down_element := TRUE;
              IFEND;
            ELSE
              local_status.normal := TRUE;
            IFEND;
          IFEND;
          status.normal := TRUE;
        UNTIL (continue = FALSE) OR local_status.normal;

        IF down_element THEN

          { Attempt to automatically DOWN the volume.

          element_descriptor.element_type := element_p^.element_type;
          element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
          element_descriptor.peripheral_descriptor.element_name := element_p^.element_name;
          cmp$process_state_change ({tape_element=} FALSE, {clear_lock_behind=} TRUE, {system_call=} TRUE,
                element_descriptor, {system critical} FALSE, state, {new_state=} cmc$down, local_status);
          IF NOT local_status.normal THEN
            clp$put_job_output (' WARNING -- The following error was detected when trying to DOWN', status);
            clp$put_job_output (message, status);
            osp$generate_error_message (local_status, status);
          IFEND;
        IFEND;
        EXIT /unit_loop/;
      FOREND /unit_loop/;
    FOREND /forloop/;

    { Now verify that all volumes are active.

    IF NOT cmv$post_deadstart THEN
      stp$verify_all_volumes_active (stv$system_set_name, local_status);
      IF NOT local_status.normal THEN
        syp$display_deadstart_message ('WARNING -- Not all volumes are active ');
        osp$generate_error_message (local_status, status);
        pmp$log_ascii ('NOT ALL MASS STORAGE VOLUMES ARE ACTIVE',
              $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system, local_status);
        IF osv$verify_missing_volumes THEN
          cmp$prompt_for_answer (' Do you want to delete the missing volumes from the set?', yes_replied);
          IF yes_replied THEN
            stp$remove_inactive_members (stv$system_set_name, status);
            IF NOT status.normal THEN
              syp$process_deadstart_status (' ', FALSE, status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND cmp$get_volumes_active;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$install_system_conf', EJECT ??

{ PURPOSE:
{   This procedure writes the physical configuration text file to the device file.

  PROCEDURE [XDCL] cmp$install_system_conf
    (    input_fid: amt$file_identifier;
     VAR status : ost$status);

    VAR
      local_status: ost$status;

    status.normal := TRUE;
    amp$rewind (input_fid, osc$nowait, local_status);

    cmp$install_conf_file (input_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND cmp$install_system_conf;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$post_deadstart', EJECT ??
  FUNCTION [XDCL, #GATE] cmp$post_deadstart: boolean;

    cmp$post_deadstart := cmv$post_deadstart;

  FUNCEND cmp$post_deadstart;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$save_mf_configuration', EJECT ??

{ PURPOSE:
{   This procedure saves a copy of the physical configuration file on file $SYSTEM.MAINFRAME.CONFIGURATION.
{   This is mainly for sites to rebuild their configuration file after a deadstart.
{ NOTE:
{   On a Continuation deadstart, this routine must be called after the point of committment, i.e when PF can
{   be referenced.

  PROCEDURE [XDCL] cmp$save_mf_configuration
    (VAR status: ost$status);

    VAR
      c_path: ARRAY [1 .. 3] OF pft$name,
      file_attrs_p: ^amt$file_attributes,
      fid: amt$file_identifier,
      local_file: amt$local_file_name,
      local_status: ost$status,
      open_file_attr_p: amt$file_access_selections,
      path: ARRAY [1 .. 4] OF pft$name,
      unique_name: ost$unique_name;

    status.normal := TRUE;

   /main_program/
    BEGIN
      pmp$generate_unique_name (unique_name, local_status);
      local_file := unique_name.value;
      path [1] := osc$null_name;
      path [2] := osc$null_name;
      path [3] := 'MAINFRAME';
      path [4] := 'CONFIGURATION';

      PUSH file_attrs_p: [1 .. 1];
      file_attrs_p^ [1].key := amc$ring_attributes;
      file_attrs_p^ [1].ring_attributes.r1 := osc$tsrv_ring;
      file_attrs_p^ [1].ring_attributes.r2 := osc$user_ring_2;
      file_attrs_p^ [1].ring_attributes.r3 := osc$user_ring_2;
      amp$file (local_file, file_attrs_p^, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      c_path [1] := osc$null_name;
      c_path [2] := osc$null_name;
      c_path [3] := 'MAINFRAME';
      pfp$define_catalog (c_path, status);
      IF NOT status.normal AND (status.condition <> pfe$name_already_subcatalog) THEN
        EXIT /main_program/;
      IFEND;

      IF osv$deadstart_phase <> osc$installation_deadstart THEN
        pfp$purge (path, v$low_cycle, osc$null_name, local_status);
      IFEND;
      pfp$define (local_file, path, v$pf_cycle, osc$null_name, pfc$maximum_retention, pfc$log, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      PUSH open_file_attr_p: [1 .. 4];
      open_file_attr_p^ [1].key := amc$ring_attributes;
      open_file_attr_p^ [1].ring_attributes.r1 := osc$tsrv_ring;
      open_file_attr_p^ [1].ring_attributes.r2 := osc$user_ring;
      open_file_attr_p^ [1].ring_attributes.r3 := osc$user_ring;
      open_file_attr_p^ [2].key := amc$access_mode;
      open_file_attr_p^ [2].access_mode := $pft$usage_selections [pfc$read,pfc$append,pfc$shorten,pfc$modify];
      open_file_attr_p^ [3].key := amc$open_position;
      open_file_attr_p^ [3].open_position := amc$open_at_boi;
      open_file_attr_p^ [4].key := amc$return_option;
      open_file_attr_p^ [4].return_option := amc$return_at_close;
      amp$open (local_file, amc$record, open_file_attr_p, fid, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      cmp$get_conf_file (fid, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    END /main_program/;
    amp$rewind (fid, osc$nowait, local_status);
    amp$close (fid, local_status);
    amp$return (local_file , local_status);

  PROCEND cmp$save_mf_configuration;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$update_pcu_state_info', EJECT ??

{ PURPOSE:
{   This procedure updates the state information on a device file.
{ DESIGN:
{   1. Get the physical configuration file from the device file.
{   2. Run that file through PCU EDIT_PHYSICAL_CONFIGURATION
{   3. Use CHANGE_ELEMENT_DEFINTION E=xxx S=new_sate
{   4. QUIT Write_physical_configuration=TRUE
{   5. Rewrite the updated file to the device files.

  PROCEDURE [XDCL] cmp$update_pcu_state_info
    (    element_name: cmt$element_name;
         state: cmt$element_state;
     VAR status: ost$status);

    CONST
      utility_name = 'PHYSICAL_CONFIGURATION_UTILITY ';

    VAR
      edit_string: string (256),
      file_attr_p: ^amt$file_attributes,
      file_name: amt$local_file_name,
      ignore_status: ost$status,
      pc_fid: amt$file_identifier,
      pcu_utl_attr_p: ^clt$utility_attributes;

    status.normal := TRUE;

   /main_program/
    BEGIN
      pmp$get_unique_name (file_name, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      PUSH file_attr_p: [1 .. 2];
      file_attr_p^ [1].key := amc$access_mode;
      file_attr_p^ [1].access_mode := $pft$usage_selections [pfc$read, pfc$execute,pfc$shorten, pfc$append];
      file_attr_p^ [2].key := amc$ring_attributes;
      file_attr_p^ [2].ring_attributes.r1 := osc$user_ring;
      file_attr_p^ [2].ring_attributes.r2 := osc$user_ring;
      file_attr_p^ [2].ring_attributes.r3 := osc$user_ring;
      amp$open (file_name, amc$record, file_attr_p, pc_fid, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      cmp$get_conf_file (pc_fid, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      amp$rewind (pc_fid, osc$nowait, ignore_status);
      amp$close (pc_fid, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      PUSH pcu_utl_attr_p: [1 .. 4];
      pcu_utl_attr_p^ [1].key := clc$utility_command_search_mode;
      pcu_utl_attr_p^ [1].command_search_mode := clc$global_command_search;
      pcu_utl_attr_p^ [2].key := clc$utility_command_table;
      pcu_utl_attr_p^ [2].command_table := pcu_command_list;
      pcu_utl_attr_p^ [3].key := clc$utility_prompt;
      pcu_utl_attr_p^ [3].prompt.value := 'PCU';
      pcu_utl_attr_p^ [3].prompt.size := 3;
      pcu_utl_attr_p^ [4].key := clc$utility_termination_command;
      pcu_utl_attr_p^ [4].termination_command := 'QUIT';
      clp$begin_utility (utility_name, pcu_utl_attr_p^, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      cmp$open_utility_files (status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      cmp$set_default_mainframe_name (status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      edit_string := '    ';
      edit_string(2, 8) := 'EDIPC I=';
      edit_string(11, 31) := file_name;
      edit_string (43, 3) := 'O= ';
      edit_string (47, 31) := file_name;
      edit_string (80,1) := ';';
      edit_string (83, 9) := 'CHAED E= ';
      edit_string (93, 31) := element_name;
      edit_string (126, 6) := 'STATE=';
      CASE state OF
      = cmc$on =
        edit_string (133, 4) := 'ON';
      = cmc$off =
        edit_string (133, 4) := 'OFF';
      = cmc$down =
        edit_string (133, 4) := 'DOWN';
      CASEND;
      edit_string (138, 1) := ';';
      edit_string (142, 20) := 'QUIT WPC=TRUE;';
      clp$scan_command_line (edit_string, ignore_status);
      IF NOT ignore_status.normal THEN
        status := ignore_status;
      IFEND;
      clp$end_utility (utility_name, ignore_status);

      cmp$close_utility_files;

      IF status.normal THEN
        amp$open (file_name, amc$record, file_attr_p, pc_fid, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        cmp$install_system_conf (pc_fid, status);
      IFEND;
    END /main_program/;
    IF NOT status.normal THEN
      osp$generate_error_message (status, ignore_status);
    IFEND;
    amp$close (pc_fid, ignore_status);
    amp$return (file_name, ignore_status);

  PROCEND cmp$update_pcu_state_info;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$validate_cip_path ', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$validate_cip_path
    (    logical_unit: iot$logical_unit;
     VAR continue_initialization: boolean);

    VAR
      local_status: ost$status,
      msi: cmt$mass_storage_information;

    continue_initialization := TRUE;
    cmp$get_mass_storage_info (logical_unit, msi, local_status);
    IF NOT local_status.normal AND (local_status.condition = cme$it_unusable_cip_access) THEN
      clp$put_job_output ('  WARNING - NOS/VE can not determine if CIP resides on a device', local_status);
      clp$put_job_output ('  which is only accessable to NOS/VE via a CIO channel.  The', local_status);
      clp$put_job_output ('  INITIALIZE_MS_VOLUME command will destroy CIP if allowed to continue.',
            local_status);
      cmp$prompt_for_answer (' Enter Yes to allow initialize to continue, No to stop.',
            continue_initialization);
    IFEND;

  PROCEND cmp$validate_cip_path;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$validate_ms_class', EJECT ??

{ PURPOSE:
{   This procedure validates the mass storage classes assigned to the active
{   volumes.  The following rules are enforced:
{     o Class C and P is required on the system set.
{     o Class J and K are required on every set.
{     o Class L is required on every non-system set.
{     o Class N is required on at least one device.
{     o Class Q is required on the system device.
{     o Every class is required on at least one device.
{
  PROCEDURE [XDCL, #GATE] cmp$validate_ms_class
    (VAR status: ost$status);

    VAR
      class_member: 'A' .. 'Z',
      master_volume: stt$volume_info,
      set_count: stt$number_of_sets,
      set_index: integer,
      set_list_p: ^stt$set_list,
      set_ms_class: dmt$class,
      str: string (52),
      str_len: 0 .. 255,
      system_ms_class: dmt$class,
      system_set: boolean,
      set_list_size: stt$number_of_sets,
      volume_list_size: stt$number_of_members,
      volume_count: stt$number_of_members,
      volume_index: integer,
      volume_list_p: ^stt$volume_list,
      volume_ms_class: dmt$class;

    status.normal := TRUE;
    system_ms_class := $dmt$class [];

    set_count := 10;
    REPEAT
      set_list_size := set_count;
      PUSH set_list_p: [1 .. set_list_size];
      stp$get_active_set_list (set_list_p^, set_count);
    UNTIL set_count <= set_list_size;

  /set_loop/
    FOR set_index := LOWERBOUND (set_list_p^) TO set_count DO
      system_set := (set_index = LOWERBOUND (set_list_p^));

      volume_count := 10;
      REPEAT
        volume_list_size := volume_count;
        PUSH volume_list_p: [1 .. volume_list_size];
        stp$get_volumes_in_set (set_list_p^ [set_index], master_volume, volume_list_p^, volume_count,
              status);
      UNTIL volume_count <= volume_list_size;

      get_volume_ms_class (master_volume.recorded_vsn, volume_ms_class);
      set_ms_class := volume_ms_class;

      IF NOT (rmc$msc_system_critical_files IN set_ms_class) AND system_set THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$class_missing_on_sys_device,
              master_volume.recorded_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, rmc$msc_system_critical_files, status);
        RETURN;
      IFEND;

    /volume_loop/
      FOR volume_index := LOWERBOUND (volume_list_p^) TO volume_count DO
        get_volume_ms_class (volume_list_p^ [volume_index].recorded_vsn, volume_ms_class);
        set_ms_class := set_ms_class + volume_ms_class;
      FOREND /volume_loop/;

      system_ms_class := system_ms_class + set_ms_class;

      IF NOT (rmc$msc_system_swap_files IN set_ms_class) AND system_set THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$class_missing_on_set,
              set_list_p^ [set_index], status);
        osp$append_status_parameter (osc$status_parameter_delimiter, rmc$msc_system_swap_files, status);
        RETURN;
      IFEND;

      IF NOT (rmc$msc_system_catalogs IN set_ms_class) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$class_missing_on_set,
              set_list_p^ [set_index], status);
        osp$append_status_parameter (osc$status_parameter_delimiter, rmc$msc_system_catalogs, status);
        RETURN;
      IFEND;

      IF NOT (rmc$msc_system_permanent_files IN set_ms_class) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$class_missing_on_set,
              set_list_p^ [set_index], status);
        osp$append_status_parameter (osc$status_parameter_delimiter, rmc$msc_system_permanent_files,
              status);
        RETURN;
      IFEND;

      IF NOT (rmc$msc_product_files IN set_ms_class) AND system_set THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$class_missing_on_set,
              set_list_p^ [set_index], status);
        osp$append_status_parameter (osc$status_parameter_delimiter, rmc$msc_product_files, status);
        RETURN;
      IFEND;

      IF NOT (rmc$msc_user_permanent_files IN set_ms_class) and (NOT system_set) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$class_missing_on_set,
              set_list_p^ [set_index], status);
        osp$append_status_parameter (osc$status_parameter_delimiter, rmc$msc_user_permanent_files, status);
        RETURN;
      IFEND;

      IF NOT (rmc$msc_user_catalogs IN set_ms_class) AND (NOT system_set) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$class_missing_on_set,
              set_list_p^ [set_index], status);
        osp$append_status_parameter (osc$status_parameter_delimiter, rmc$msc_user_catalogs, status);
        RETURN;
      IFEND;
    FOREND /set_loop/;

    IF NOT (rmc$msc_user_temporary_files IN system_ms_class) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$class_missing_on_system,
            rmc$msc_user_temporary_files, status);
      RETURN;
    IFEND;

    str := ' ';
    str_len := 0;
    FOR class_member := 'A' TO 'Z' DO
      IF NOT (class_member IN system_ms_class) THEN
        str (str_len + 1) := ' ';
        str (str_len + 2) := class_member;
        str_len := str_len + 2;
      IFEND;
    FOREND;

    IF str_len <> 0 THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_class_has_no_members,
            str (1, str_len), status);
      RETURN;
    IFEND;

  PROCEND cmp$validate_ms_class;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$validate_set_membership', EJECT ??

{ PURPOSE:
{   This procedure checks for SET membership of the volume being initialized via INITIALIZE_MS_VOLUME.
{   If the volume is currently a member of the set, then prompt for operator intervention. If the operator
{   enters yes to the prompt, then remove the volume from the set.

  PROCEDURE [XDCL, #GATE] cmp$validate_set_membership
    (    recorded_vsn: rmt$recorded_vsn;
         new_set_name: stt$set_name;
     VAR allow_to_continue: boolean;
     VAR status: ost$status);

    VAR
      found_ast_entry: stt$active_set_entry,
      found_ast_index: stt$ast_index,
      local_status: ost$status,
      master_info: stt$volume_info,
      master_vsn: rmt$recorded_vsn,
      member_count: stt$number_of_members,
      member_list_p: ^stt$volume_list,
      message: string (80),
      set_key_found: boolean,
      set_name: stt$set_name,
      volume_info: stt$volume_info;

    status.normal := TRUE;
    allow_to_continue := TRUE;
    IF (osv$deadstart_phase = osc$installation_deadstart) AND NOT cmv$post_deadstart THEN
      RETURN;
    IFEND;

    stp$get_volumes_set_name (recorded_vsn, set_name, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    PUSH member_list_p: [1 .. 1];
    stp$get_volumes_in_set (set_name, master_info, member_list_p^, member_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    master_vsn := master_info.recorded_vsn;
    stp$is_volume_in_set (recorded_vsn, set_name, volume_info, local_status);
    IF NOT local_status.normal THEN

      { Volume is not a member of the Set, OK to continue initialization.

      RETURN;
    IFEND;

    message := ' ';
    message := ' Volume         is currently a member of set ';
    message (9, 6):= recorded_vsn;
    message (46, *) := set_name;
    clp$put_job_output (message, local_status);
    cmp$prompt_for_answer (' Enter Yes to remove the volume from the set and continue, No to stop.',
          allow_to_continue);
    IF allow_to_continue THEN
      stp$remove_member_vol_from_set (set_name, recorded_vsn, master_vsn, status);
      IF NOT status.normal AND ((status.condition = ste$member_not_active) OR
            (status.condition = ste$vol_not_in_set)) THEN
        stp$search_ast_by_set (set_name, found_ast_entry, found_ast_index, set_key_found);
        IF set_key_found THEN
          stp$r2_remove_inactive_member (found_ast_index, recorded_vsn, master_vsn, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;
      message := ' ';
      message := ' Volume          has been removed from set   ';
      message (9, 6):= recorded_vsn;
      message (46, *) := set_name;
      clp$put_job_output (message, local_status);
      IF new_set_name = 'INIMV ATTEMPTED' THEN
        clp$put_job_output (' and the initialization of the device continues.', local_status);
      ELSE
        message := ' ';
        message := ' Volume          added to set ';
        message (9, 6):= recorded_vsn;
        IF new_set_name = 'UNSPECIFIED' THEN
          message (31, *) := stv$system_set_name;
        ELSE
          message (31, *) := new_set_name;
        IFEND;
        clp$put_job_output (message, local_status);
      IFEND;
    IFEND;

  PROCEND cmp$validate_set_membership;
?? OLDTITLE ??
MODEND cmm$configure_in_job_template;
*DECK DECK=CMM$CONFIG_STATUS_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
MODULE cmm$config_status_interfaces;
?? TITLE := ' CONFIGURATION MANAGEMENT: Configuration status', EJECT ??

{ PURPOSE:
{   This module contains interfaces that retrieve configuration
{   information.

?? PUSH (LISTEXT := ON) ??
*copyc cme$logical_configuration_mgr
*copyc cmt$element_definition
*copyc cmt$element_descriptor
*copyc cmt$element_information
*copyc cmt$element_selector
*copyc cmt$job_ownership
*copyc cmt$physical_channel
*copyc dmt$active_volume_table_index
*copyc iot$logical_unit
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc ost$status
*copyc rmt$device_class
?? POP ??
*copyc avp$configuration_administrator
*copyc avp$removable_media_operator
*copyc avp$system_displays
*copyc avp$system_operator
*copyc cmp$convert_channel_ordinal
*copyc cmp$convert_iou_name
*copyc cmp$format_error_message
*copyc cmp$get_channel_def
*copyc cmp$get_controller_type
*copyc cmp$get_element_state
*copyc cmp$get_logical_pp_index
*copyc cmp$get_logical_unit_number
*copyc cmp$get_ms_class_on_volume_r1
*copyc cmp$get_physical_attributes
*copyc cmp$get_unit_type
*copyc cmp$get_pp_def
*copyc cmp$pc_get_element
*copyc cmp$retrieve_iou_definition
*copyc cmp$search_active_volume_table
*copyc cmp$search_peripheral_table
*copyc dmp$calculate_device_capacity
*copyc dmp$calculate_remaining_space
*copyc dmp$volume_is_active
*copyc dmp$volume_is_online
*copyc dsp$retrieve_iou_information
*copyc osp$set_status_abnormal
*copyc pmp$get_mainframe_id
*copyc stp$get_volumes_set_name
*copyc cmv$physical_configuration
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc cmv$peripheral_element_table
*copyc cmv$state_info_table
*copyc iov$tusl_p
*copyc stv$system_set_name

?? OLDTITLE ??
?? NEWTITLE := '   cmp$get_channel_definition', EJECT ??
*copyc cmh$get_channel_definition

  PROCEDURE [XDCL, #GATE] cmp$get_channel_definition
    (    channel_identification: cmt$channel_descriptor;
     VAR channel_definition: cmt$data_channel_definition;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      channel_def: cmt$data_channel_definition,
      channel_id: cmt$channel_descriptor;

    #CALLER_ID (caller_id);
    IF NOT (avp$configuration_administrator () OR avp$removable_media_operator () OR avp$system_displays ()
           OR (caller_id.ring <= 6)) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_ring_validation_error,
            'CMP$GET_CHANNEL_DEFINITION', status);
      RETURN;
    IFEND;
    channel_id := channel_identification;
    cmp$get_channel_def (channel_id, channel_def, status);
    channel_definition := channel_def;

  PROCEND cmp$get_channel_definition;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$get_element_activity', EJECT ??

{ PURPOSE:
{   This procedure returns maintenance activity of element.

  PROCEDURE cmp$get_element_activity
    (    logical_unit: iot$logical_unit;
         element_descriptor: cmt$element_descriptor;
     VAR reservable_resource: boolean;
     VAR assigned_job: cmt$job_ownership;
     VAR reserved_job: cmt$job_ownership;
     VAR status: ost$status);

    VAR
      element_reservation: cmt$element_reservation,
      peripheral_index: integer;

    status.normal := TRUE;
    reservable_resource := FALSE;
    IF element_descriptor.element_type = cmc$storage_device_element THEN
      IF cmv$logical_unit_table^ [logical_unit].status.assignable_device THEN
        reservable_resource := TRUE;
      IFEND;
    IFEND;

    cmp$search_peripheral_table (element_descriptor, element_reservation, FALSE, peripheral_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF cmv$peripheral_element_table.pointer^ [peripheral_index].reservable_element <> cmc$not_reservable THEN
      reservable_resource := TRUE;
    IFEND;

    IF reservable_resource THEN
      assigned_job.active := FALSE;
      reserved_job.active := FALSE;

      IF element_descriptor.element_type = cmc$storage_device_element THEN
        IF cmv$logical_unit_table^ [logical_unit].status.assignable_device THEN
          IF cmv$logical_unit_table^ [logical_unit].status.assigned THEN
            assigned_job.active := TRUE;
            assigned_job.job_identification := cmv$logical_unit_table^ [logical_unit].status.assigned_jsn;
          IFEND;
        IFEND;
      IFEND;

      IF cmv$peripheral_element_table.pointer^ [peripheral_index].reservable_element <>
            cmc$not_reservable THEN
        IF cmv$peripheral_element_table.pointer^ [peripheral_index].entry_interlock THEN
          IF cmv$peripheral_element_table.pointer^ [peripheral_index].reserved_status THEN
            reserved_job.active := TRUE;
            reserved_job.job_identification := cmv$peripheral_element_table.pointer^ [peripheral_index].
                  reserved_job;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND cmp$get_element_activity;
?? OLDTITLE ??
?? NEWTITLE := '  cmp$get_element_density_access', EJECT ??

{ PURPOSE:
{   This procedure returns density information of tape element.

  PROCEDURE cmp$get_element_density_access
    (    logical_unit: iot$logical_unit;
     VAR densities: cmt$densities;
     VAR write_inhibited: boolean;
     VAR status: ost$status);

    VAR
      unit_type: iot$unit_type;

    status.normal := TRUE;
    unit_type := cmv$logical_unit_table^ [logical_unit].unit_interface_table^.unit_type;
    IF (unit_type = ioc$dt_mt679_2) OR (unit_type = ioc$dt_mt679_3) OR (unit_type = ioc$dt_mt679_4) THEN
      densities := $cmt$densities [rmc$800, rmc$1600];
    ELSEIF unit_type = ioc$dt_mt5682_1x THEN
      densities := $cmt$densities [rmc$38000];
    ELSE
      densities := $cmt$densities [rmc$1600, rmc$6250];
    IFEND;

    IF $cmt$element_access [cmc$write] <= cmv$logical_unit_table^ [logical_unit].element_access THEN
      write_inhibited := FALSE;
    ELSE
      write_inhibited := TRUE;
    IFEND;

  PROCEND cmp$get_element_density_access;

?? OLDTITLE ??
?? TITLE := '      cmp$get_element_definition ', EJECT ??

*copyc cmh$get_element_definition

  PROCEDURE [XDCL, #GATE] cmp$get_element_definition
    (    element: cmt$element_descriptor;
     VAR definition: cmt$element_definition;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      channel_definition: cmt$data_channel_definition,
      element_count: integer,
      element_descriptor: cmt$element_descriptor,
      exact_match: boolean,
      found: boolean,
      i: integer,
      lc_index: integer,
      local_status: ost$status,
      physical_id: cmt$physical_identification;

    #CALLER_ID (caller_id);
    IF NOT (avp$configuration_administrator () OR avp$removable_media_operator () OR avp$system_displays ()
          OR (caller_id.ring <= 6)) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_ring_validation_error,
            'CMP$GET_ELEMENT_DEFINITION', status);
      RETURN;
    IFEND;


    status.normal := TRUE;
    found := FALSE;
    exact_match := FALSE;

  /main_program/
    BEGIN

      CASE element.element_type OF
      = cmc$controller_element, cmc$storage_device_element, cmc$external_processor_element,
            cmc$channel_adapter_element, cmc$communications_element =
        IF NOT element.peripheral_descriptor.use_logical_identification THEN

{ set up element descriptor for search

          physical_id.product_identification.product_number := '      ';
          physical_id.serial_number := '      ';

          physical_id.hardware_address.physical_address_specifier :=
                element.peripheral_descriptor.hardware_address.physical_address_specifier;
          IF cmp$multiple_iou_system () THEN
            physical_id.hardware_address.iou := element.peripheral_descriptor.hardware_address.iou;
          ELSE
            physical_id.hardware_address.iou := 'IOU0';
          IFEND;
          physical_id.hardware_address.channel := element.peripheral_descriptor.hardware_address.channel;
          physical_id.hardware_address.channel.iou := element.peripheral_descriptor.hardware_address.channel.
                iou;
          physical_id.hardware_address.channel_address := element.peripheral_descriptor.hardware_address.
                channel_address;
          physical_id.hardware_address.unit_address := element.peripheral_descriptor.hardware_address.
                unit_address;
          physical_id.product_identification.product_number := '     ';
          physical_id.product_identification.underscore := ' ';
          physical_id.product_identification.model_number := '   ';
          physical_id.serial_number := '   ';
          cmp$get_element_name (physical_id, element_descriptor, status);

          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;

      = cmc$data_channel_element =

{
{ If the channel is not in the configuration then an error will be returned here.
{

        cmp$get_channel_definition (element.channel_descriptor, channel_definition, status);
        IF NOT status.normal THEN
          IF status.condition = cme$lcm_element_not_found THEN

{ This is a normal condition since a different channel port may exist.

            status.normal := TRUE;
          ELSE
            EXIT /main_program/;
          IFEND;
        IFEND;
      ELSE
      CASEND;

    /for_loop/
      FOR lc_index := LOWERBOUND (cmv$physical_configuration^) TO UPPERBOUND (cmv$physical_configuration^) DO

        CASE element.element_type OF
        = cmc$data_channel_element =

{ Match IOU name if there is more than 1 IOU present.

          IF cmp$multiple_iou_system () THEN
            IF (cmv$physical_configuration^ [lc_index].element_type = cmc$data_channel_element) AND
                  (cmv$physical_configuration^ [lc_index].data_channel.iou <> element.channel_descriptor.iou)
                  THEN
              CYCLE /for_loop/;
            IFEND;
          IFEND;
          IF (cmv$physical_configuration^ [lc_index].element_type = cmc$data_channel_element) THEN
            exact_match := (cmv$physical_configuration^ [lc_index].data_channel.number =
                  channel_definition.number) AND (cmv$physical_configuration^ [lc_index].data_channel.
                  concurrent = channel_definition.concurrent) AND
                  (channel_definition.port = cmv$physical_configuration^ [lc_index].data_channel.port);
            IF exact_match THEN
              definition := cmv$physical_configuration^ [lc_index];
              found := TRUE;
              EXIT /for_loop/;
            ELSE
              IF (cmv$physical_configuration^ [lc_index].data_channel.number = channel_definition.number) AND
                    (cmv$physical_configuration^ [lc_index].data_channel.concurrent =
                    channel_definition.concurrent) THEN
                definition := cmv$physical_configuration^ [lc_index];
                found := TRUE;
              IFEND;
            IFEND;
          IFEND;

        = cmc$controller_element, cmc$storage_device_element, cmc$external_processor_element,
              cmc$channel_adapter_element, cmc$communications_element =

          IF element.peripheral_descriptor.use_logical_identification THEN
            IF (cmv$physical_configuration^ [lc_index].element_name =
                  element.peripheral_descriptor.element_name) THEN
              found := TRUE;
              EXIT /for_loop/;
            IFEND;

          ELSE
            IF (cmv$physical_configuration^ [lc_index].element_name =
                  element_descriptor.peripheral_descriptor.element_name) THEN
              found := TRUE;
              EXIT /for_loop/;
            IFEND;

          IFEND;

        ELSE { CASE statement }

{ error not implemented

        CASEND;
      FOREND /for_loop/;

      IF NOT found THEN
        cmp$format_error_message (element, physical_id, FALSE, cme$lcm_element_not_found, status);
        EXIT /main_program/;

      ELSE
        IF element.element_type = cmc$data_channel_element THEN
          IF (NOT exact_match) THEN

{ Strip the port value in the channel name.

            IF definition.data_channel.port <> cmc$unspecified_port THEN
              definition.data_channel.port := cmc$unspecified_port;
              i := osc$max_name_size;
              WHILE (i >= 1) AND (definition.element_name (i, 1) = ' ') DO
                IF (definition.element_name (i, 1) = 'A') OR (definition.element_name (i, 1) = 'B') THEN
                  definition.element_name (i, 1) := ' ';
                IFEND;
                i := i - 1;
              WHILEND;
            IFEND;
          IFEND;
        ELSE
          definition := cmv$physical_configuration^ [lc_index];
        IFEND;
      IFEND;
    END /main_program/;

  PROCEND cmp$get_element_definition;

?? OLDTITLE ??
?? TITLE := '      cmp$get_element_information ', EJECT ??

*copyc cmh$get_element_information

  PROCEDURE [XDCL, #GATE] cmp$get_element_information
    (    element: cmt$element_descriptor;
     VAR information: cmt$element_information;
     VAR status: ost$status);

    PROCEDURE retrieve_device_class
      (    product: cmt$product_identification;
           element_type: cmt$element_type;
       VAR device_class: rmt$device_class;
       VAR found_device_class: boolean);

      VAR
        cm_unit_type: cmt$unit_type,
        found: boolean,
        io_unit_type: iot$unit_type,
        unit_class: cmt$unit_class;

      found_device_class := TRUE;
      IF (element_type <> cmc$data_channel_element) AND (element_type <> cmc$controller_element) THEN
        cmp$get_unit_type (product_id, cm_unit_type, io_unit_type, unit_class, found);
        IF found THEN
          IF unit_class = cmc$magnetic_tape_unit THEN
            device_class := rmc$magnetic_tape_device;
          ELSEIF unit_class = cmc$mass_storage_unit THEN
            device_class := rmc$mass_storage_device;
          ELSE
            found_device_class := FALSE;
          IFEND;
        ELSE { Not found, foreign or network devices }
          IF element_type = cmc$storage_device_element THEN
            device_class := rmc$mass_storage_device;
          ELSEIF element_type = cmc$communications_element THEN
            IF unit_class = cmc$rhfam_unit THEN
              device_class := rmc$rhfam_device;
            ELSEIF unit_class = cmc$network_unit THEN
              device_class := rmc$network_device;
            IFEND;
          ELSEIF (element_type = cmc$channel_adapter_element) AND (unit_class = cmc$network_unit) THEN
            device_class := rmc$network_device;
          ELSE
            found_device_class := FALSE;
          IFEND;
        IFEND;
      ELSE
        found_device_class := FALSE;
      IFEND;
    PROCEND retrieve_device_class;

    VAR
      assigned_job: cmt$job_ownership,
      avt_entry_not_found: boolean,
      caller_id: ost$caller_identifier,
      channel_definition: cmt$data_channel_definition,
      densities: cmt$densities,
      element_count: integer,
      element_descriptor: cmt$element_descriptor,
      element_name: cmt$element_name,
      element_type: cmt$element_type,
      entry_type: rmt$device_class,
      ext_vsn: rmt$external_vsn,
      ext_vsn_found: boolean,
      found: boolean,
      index: integer,
      iou_name: cmt$element_name,
      item_returned: boolean,
      lc_index: integer,
      local_status: ost$status,
      logical_unit: iot$logical_unit,
      physical_attributes_p: ^dmt$physical_device_attributes,
      physical_id: cmt$physical_identification,
      product_id: cmt$product_identification,
      rec_vsn: rmt$recorded_vsn,
      rec_vsn_found: boolean,
      reservable_resource: boolean,
      reserved_job: cmt$job_ownership,
      search_key: dmt$avt_search_key,
      serial_number: cmt$serial_number,
      system_critical: boolean,
      write_inhibited: boolean;

    #CALLER_ID (caller_id);
    IF NOT (avp$configuration_administrator () OR avp$removable_media_operator () OR avp$system_displays ()
          OR (caller_id.ring <= 6)) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_ring_validation_error,
            'CMP$GET_ELEMENT_INFORMATION', status);
      RETURN;
    IFEND;
    status.normal := TRUE;
    iou_name := 'IOU0';
    ext_vsn_found := FALSE;
    avt_entry_not_found := TRUE;
    found := FALSE;

  /main_program/

    BEGIN

      FOR index := LOWERBOUND (information) TO UPPERBOUND (information) DO
        information [index].item_returned := FALSE;
      FOREND;

      element_descriptor.element_type := element.element_type;
      CASE element.element_type OF
      = cmc$controller_element, cmc$storage_device_element, cmc$external_processor_element,
            cmc$channel_adapter_element, cmc$communications_element =

        IF NOT element.peripheral_descriptor.use_logical_identification THEN

{ set up element descriptor for search

          physical_id.hardware_address.physical_address_specifier :=
                element.peripheral_descriptor.hardware_address.physical_address_specifier;
          IF cmp$multiple_iou_system () THEN
            physical_id.hardware_address.iou := element.peripheral_descriptor.hardware_address.iou;
          ELSE
            physical_id.hardware_address.iou := 'IOU0';
          IFEND;
          physical_id.hardware_address.channel := element.peripheral_descriptor.hardware_address.channel;
          physical_id.hardware_address.channel_address := element.peripheral_descriptor.hardware_address.
                channel_address;
          physical_id.hardware_address.unit_address := element.peripheral_descriptor.hardware_address.
                unit_address;
          physical_id.product_identification.product_number := '     ';
          physical_id.product_identification.underscore := ' ';
          physical_id.product_identification.model_number := '   ';
          physical_id.serial_number := '   ';
          cmp$get_element_name (physical_id, element_descriptor, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        ELSE
          element_descriptor.peripheral_descriptor.element_name := element.peripheral_descriptor.element_name;
        IFEND;

      = cmc$data_channel_element =
        cmp$get_channel_definition (element.channel_descriptor, channel_definition, status);
        IF NOT status.normal THEN
          IF status.condition = cme$lcm_element_not_found THEN
            status.normal := TRUE;
          ELSE
            EXIT /main_program/;
          IFEND;
        IFEND;
        IF cmp$multiple_iou_system () THEN
          iou_name := element.channel_descriptor.iou;
        IFEND;
      ELSE
      CASEND;

    /for_loop/
      FOR lc_index := LOWERBOUND (cmv$physical_configuration^) TO UPPERBOUND (cmv$physical_configuration^) DO

        CASE element.element_type OF
        = cmc$data_channel_element =
          IF cmp$multiple_iou_system () THEN
            IF (cmv$physical_configuration^ [lc_index].element_type = cmc$data_channel_element) AND
                  (cmv$physical_configuration^ [lc_index].data_channel.iou <> element.channel_descriptor.iou)
                  THEN
              CYCLE /for_loop/;
            IFEND;
          IFEND;
          IF (cmv$physical_configuration^ [lc_index].data_channel.number = channel_definition.number) AND
                (cmv$physical_configuration^ [lc_index].data_channel.concurrent =
                channel_definition.concurrent) THEN
            found := TRUE;
            EXIT /for_loop/;
          IFEND;

        = cmc$controller_element, cmc$storage_device_element, cmc$external_processor_element,
              cmc$channel_adapter_element, cmc$communications_element =

          IF element.peripheral_descriptor.use_logical_identification THEN
            IF (cmv$physical_configuration^ [lc_index].element_name =
                  element.peripheral_descriptor.element_name) THEN

              found := TRUE;
              EXIT /for_loop/;
            IFEND;

          ELSE
            IF (cmv$physical_configuration^ [lc_index].element_name =
                  element_descriptor.peripheral_descriptor.element_name) THEN
              found := TRUE;
              EXIT /for_loop/;
            IFEND;

          IFEND;

        ELSE { CASE statement }

{ error not implemented

        CASEND;

      FOREND /for_loop/;

      IF NOT found THEN
        cmp$format_error_message (element, physical_id, FALSE, cme$lcm_element_not_found, status);
        EXIT /main_program/;
      ELSE
        element_name := cmv$physical_configuration^ [lc_index].element_name;
        element_type := cmv$physical_configuration^ [lc_index].element_type;
        serial_number := cmv$physical_configuration^ [lc_index].serial_number;
        product_id := cmv$physical_configuration^ [lc_index].product_id;
      IFEND;

      CASE element_type OF
      = cmc$storage_device_element =

        cmp$get_logical_unit_number (element_name, logical_unit, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        retrieve_device_class (product_id, element_type, entry_type, item_returned);
        IF item_returned AND (entry_type = rmc$magnetic_tape_device) THEN

        /search_tusl_for_evsn/
          FOR index := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
            IF iov$tusl_p^ [index].element_name = element_name THEN
              IF iov$tusl_p^ [index].assignment_state <> ioc$not_assigned THEN
                ext_vsn := iov$tusl_p^ [index].evsn;
                ext_vsn_found := TRUE;
              IFEND;

              IF iov$tusl_p^ [index].unit_ready THEN
                rec_vsn := iov$tusl_p^ [index].rvsn;
                rec_vsn_found := TRUE;
              IFEND;
              EXIT /search_tusl_for_evsn/;
            IFEND;
          FOREND /search_tusl_for_evsn/;
        ELSE
          search_key.value := dmc$search_avt_by_lun;
          search_key.logical_unit_number := logical_unit;
          cmp$search_active_volume_table (search_key, rec_vsn, avt_entry_not_found);
          rec_vsn_found := NOT avt_entry_not_found;
        IFEND;

      ELSE
        ;
      CASEND;


      FOR index := LOWERBOUND (information) TO UPPERBOUND (information) DO

        CASE information [index].selector OF
        = cmc$application_information =
          IF information [index].application_information = NIL THEN
            osp$set_status_abnormal (cmc$configuration_management_id,
               cme$lcm_nil_pointer_detected, 'CMP$GET_ELEMENT_INFORMATION', status);
            EXIT /main_program/;
          IFEND;
          IF (cmv$state_info_table^ [lc_index].application_info_p <> NIL) THEN
            IF (STRLENGTH(information [index].application_information^) <
                STRLENGTH(cmv$state_info_table^ [lc_index].application_info_p^)) THEN
              osp$set_status_abnormal (cmc$configuration_management_id,
                   cme$lcm_insufficient_space, ' ', status);
              EXIT /main_program/;
            IFEND;
            information [index].application_information^ := cmv$state_info_table^
                     [lc_index].application_info_p^;
            information [index].item_returned := TRUE;
          IFEND;
        = cmc$application_string_size =
          IF (cmv$state_info_table^ [lc_index].application_info_p <> NIL) THEN
            information [index].application_info_string_size :=
                  cmv$state_info_table^ [lc_index].application_info_size;
            information [index].item_returned := TRUE;
          IFEND;
        = cmc$dau_size =
          PUSH physical_attributes_p: [1 .. 2];
          physical_attributes_p^ [1].keyword := dmc$bytes_per_mau;
          physical_attributes_p^ [2].keyword := dmc$maus_per_dau;
          cmp$get_physical_attributes (product_id, physical_attributes_p, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
          information [index].item_returned := TRUE;
          information [index].dau_size := (physical_attributes_p^ [1].
                bytes_per_mau * physical_attributes_p^ [2].maus_per_dau);

        = cmc$device_class =
          IF NOT avt_entry_not_found THEN
            information [index].item_returned := TRUE;
            information [index].device_class := entry_type;
          ELSE
            retrieve_device_class (product_id, element_type, information [index].
                  device_class, information [index].item_returned);
          IFEND;

        = cmc$element_status =
          cmp$get_element_state (element_name, iou_name, information [index].element_status.state, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
          information [index].item_returned := TRUE;
          IF information [index].element_status.state <> cmc$on THEN
            information [index].element_status.repair_action_required := FALSE;
          IFEND;

        = cmc$external_vsn =
          IF ext_vsn_found THEN
            information [index].item_returned := TRUE;
            information [index].external_vsn := ext_vsn;
          IFEND;

        = cmc$maintenance_activity =
          ;

        = cmc$mass_storage_capacity =
          dmp$calculate_device_capacity (product_id, information [index].total_capacity, local_status);
          information [index].item_returned := local_status.normal;

        = cmc$mass_storage_available =
          dmp$calculate_remaining_space (logical_unit, information [index].available_capacity,
                       local_status);
          information [index].item_returned := local_status.normal;
        = cmc$product_identification =
          IF found AND NOT (element_type = cmc$data_channel_element) THEN
            information [index].item_returned := TRUE;
            information [index].product_identification := product_id;
          IFEND;

        = cmc$recorded_vsn =
          IF rec_vsn_found THEN
            information [index].item_returned := TRUE;
            information [index].recorded_vsn := rec_vsn;
          IFEND;

        = cmc$serial_number =
          IF found AND NOT (element_type = cmc$data_channel_element) THEN
            information [index].item_returned := TRUE;
            information [index].serial_number := serial_number;
          IFEND;

        = cmc$site_information =
          IF information [index].site_information = NIL THEN
            osp$set_status_abnormal (cmc$configuration_management_id,
                  cme$lcm_nil_pointer_detected, 'CMP$GET_ELEMENT_INFORMATION', status);
            EXIT /main_program/;
          IFEND;
          IF (cmv$state_info_table^ [lc_index].site_info_p <> NIL) THEN
            IF (STRLENGTH(information [index].site_information^) <
                  STRLENGTH(cmv$state_info_table^ [lc_index].site_info_p^)) THEN
              osp$set_status_abnormal (cmc$configuration_management_id,
                    cme$lcm_insufficient_space, ' ', status);
             EXIT /main_program/;
            IFEND;
            information [index].site_information^ := cmv$state_info_table^
                    [lc_index].site_info_p^;
            information [index].item_returned := TRUE;
          IFEND;
        = cmc$site_info_string_size =
          IF (cmv$state_info_table^ [lc_index].site_info_p <> NIL) THEN
            information [index].site_info_string_size :=
                   cmv$state_info_table^ [lc_index].site_info_size;
            information [index].item_returned := TRUE;
          IFEND;

        = cmc$system_critical_element =
          information [index].system_critical_element := FALSE;

          cmp$system_critical (cmv$physical_configuration^ [lc_index], system_critical, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
          information [index].item_returned := TRUE;
          information [index].system_critical_element := system_critical;

        = cmc$element_capability =
          information [index].item_returned := TRUE;
          information [index].element_capability.element_type := element_type;
          retrieve_device_class (product_id, element_type, information [index].element_capability.
                device_class, information [index].item_returned);
          IF (information [index].element_capability.device_class = rmc$magnetic_tape_device) AND
                (information [index].item_returned) THEN
            cmp$get_element_density_access (logical_unit, densities, write_inhibited, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            information [index].element_capability.densities := densities;
            information [index].element_capability.write_inhibited := write_inhibited;
          IFEND;

        = cmc$volume_online =
          dmp$volume_is_online (logical_unit, information [index].online);
          information [index].item_returned := (logical_unit <> 0);

        = cmc$volume_active =
          dmp$volume_is_active (logical_unit, information [index].active);
          information [index].item_returned := (logical_unit <> 0);

        = cmc$system_activity =
          information [index].item_returned := TRUE;
          cmp$get_element_activity (logical_unit, element_descriptor, reservable_resource, assigned_job,
                reserved_job, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
          information [index].system_activity.reservable_resource := reservable_resource;
          IF reservable_resource THEN
            information [index].system_activity.job_assignment.active := assigned_job.active;
            IF assigned_job.active THEN
              information [index].system_activity.job_assignment.job_identification :=
                    assigned_job.job_identification;
            IFEND;
            information [index].system_activity.job_reservation.active := reserved_job.active;
            IF reserved_job.active THEN
              information [index].system_activity.job_reservation.job_identification :=
                    reserved_job.job_identification;
            IFEND;
          IFEND;

        ELSE
          ; { ERROR, undefined selector }
        CASEND;

      FOREND;

    END /main_program/;

  PROCEND cmp$get_element_information;

?? OLDTITLE ??
?? TITLE := '      cmp$get_element_name', EJECT ??

*copyc cmh$get_element_name

  PROCEDURE [XDCL, #GATE] cmp$get_element_name
    (    physical_identification: cmt$physical_identification;
     VAR element: cmt$element_descriptor;
     VAR status: ost$status);

    VAR
      address_specified: array [cmt$physical_address_parts] of boolean,
      caller_id: ost$caller_identifier,
      channel: cmt$physical_channel,
      channel_address: cmt$physical_equipment_number,
      channel_name: cmt$element_name,
      channel_number: cmt$channel_identification,
      definition: cmt$element_definition,
      element_count: integer,
      element_def: ^cmt$element_definition,
      element_descriptor: cmt$element_descriptor,
      empty_set: [STATIC, READ, oss$job_paged_literal] cmt$physical_address_specifier := [],
      found: boolean,
      i: integer,
      iou_name: cmt$element_name,
      lc_index: integer,
      local_status: ost$status,
      pa_index: cmt$physical_address_parts,
      pen: cmt$physical_equipment_number,
      physical_descriptor: cmt$element_descriptor,
      product_id: cmt$product_identification,
      serial_number: cmt$serial_number,
      unit_address: cmt$physical_unit_number;

    #CALLER_ID (caller_id);
    IF NOT (avp$configuration_administrator () OR avp$removable_media_operator () OR avp$system_displays ()
          OR (caller_id.ring <= 6)) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_ring_validation_error,
            'CMP$GET_ELEMENT_NAME', status);
      RETURN;
    IFEND;
    found := FALSE;
    status.normal := TRUE;
    iou_name := 'IOU0';

  /main_program/
    BEGIN

      IF (physical_identification.product_identification.product_number = '  $885') OR
            (physical_identification.product_identification.product_number = '  $895') THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_ambiguous_product_id, ' ', status);
        EXIT /main_program/;
      IFEND;

      IF (physical_identification.product_identification.product_number <> '      ') AND
            (physical_identification.serial_number <> '      ') THEN
        product_id := physical_identification.product_identification;
        serial_number := physical_identification.serial_number;

      /for_loop/
        FOR lc_index := LOWERBOUND (cmv$physical_configuration^)
              TO UPPERBOUND (cmv$physical_configuration^) DO

          IF (cmv$physical_configuration^ [lc_index].product_id = product_id) AND
                (cmv$physical_configuration^ [lc_index].serial_number = serial_number) AND
                (cmv$physical_configuration^ [lc_index].element_type <> cmc$data_channel_element) THEN
            found := TRUE;
            element.element_type := cmv$physical_configuration^ [lc_index].element_type;
            CASE element.element_type OF
            = cmc$controller_element, cmc$storage_device_element, cmc$external_processor_element,
                  cmc$channel_adapter_element, cmc$communications_element =

              element.peripheral_descriptor.use_logical_identification := TRUE;
              element.peripheral_descriptor.element_name := cmv$physical_configuration^ [lc_index].
                    element_name;
            ELSE
            CASEND;

            EXIT /for_loop/;

          IFEND;

        FOREND /for_loop/;

      ELSE

{ match physical  channel number, channel address
{ and unit address

        IF physical_identification.hardware_address.physical_address_specifier = empty_set THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_empty_pa_set, ' ', status);
          EXIT /main_program/;
        IFEND;
        FOR pa_index := LOWERVALUE (cmt$physical_address_parts) TO UPPERVALUE (cmt$physical_address_parts) DO
          address_specified [pa_index] := pa_index IN physical_identification.hardware_address.
                physical_address_specifier;
          IF address_specified [pa_index] THEN
            CASE pa_index OF
            = cmc$iou =
              IF cmp$multiple_iou_system () THEN
                iou_name := physical_identification.hardware_address.iou;
              IFEND;
            = cmc$channel =
              channel_number.ordinal := physical_identification.hardware_address.channel.ordinal;
              IF cmp$multiple_iou_system () THEN
                channel_number.iou := physical_identification.hardware_address.channel.iou;
              ELSE
                channel_number.iou := iou_name;
              IFEND;
              cmp$convert_channel_ordinal (channel_number.ordinal, channel_name, channel.number,
                    channel.concurrent, channel.port, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
            = cmc$channel_address =
              channel_address := physical_identification.hardware_address.channel_address;
            = cmc$unit_address =
              unit_address := physical_identification.hardware_address.unit_address;
            CASEND;
          IFEND;
        FOREND;

        IF cmp$multiple_iou_system () THEN
          IF NOT address_specified [cmc$iou] THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_missing_pa_set_member, 'IOU',
                  status);
            EXIT /main_program/;
          IFEND;
        IFEND;

        IF address_specified [cmc$channel_address] THEN
          IF NOT address_specified [cmc$channel] THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_missing_pa_set_member,
                  'Channel ID', status);
            EXIT /main_program/;
          IFEND;
        IFEND;
        IF address_specified [cmc$unit_address] THEN
          IF (NOT address_specified [cmc$channel]) OR (NOT address_specified [cmc$channel_address]) THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_missing_pa_set_member,
                  'Channel ID and Address', status);
            EXIT /main_program/;
          IFEND;
        IFEND;

      /for_loop2/
        FOR lc_index := LOWERBOUND (cmv$physical_configuration^)
              TO UPPERBOUND (cmv$physical_configuration^) DO
          IF address_specified [cmc$channel] AND address_specified [cmc$channel_address] AND
                address_specified [cmc$unit_address] THEN
            IF (cmv$physical_configuration^ [lc_index].element_type = cmc$data_channel_element) AND
                  (cmv$physical_configuration^ [lc_index].data_channel.iou = iou_name) AND
                  (cmv$physical_configuration^ [lc_index].data_channel.ordinal = channel_number.ordinal) THEN
              FOR pen := LOWERVALUE (cmt$physical_equipment_number)
                    TO UPPERVALUE (cmt$physical_equipment_number) DO
                IF (cmv$physical_configuration^ [lc_index].data_channel.connection.equipment [pen].
                      configured) THEN
                  cmp$pc_get_element (cmv$physical_configuration^ [lc_index].data_channel.connection.
                        equipment [pen].element_name, iou_name, element_def, status);
                  IF NOT status.normal THEN
                    EXIT /for_loop2/;
                  IFEND;

                  IF element_def^.element_type = cmc$controller_element THEN
                    IF pen = channel_address THEN
                      IF element_def^.controller.connection.unit [unit_address].configured THEN
                        found := TRUE;
                        element.element_type := cmc$storage_device_element;
                        element.peripheral_descriptor.use_logical_identification := TRUE;
                        element.peripheral_descriptor.element_name :=
                              element_def^.controller.connection.unit [unit_address].element_name;
                        EXIT /for_loop2/;

                      IFEND;
                    IFEND;
                  ELSEIF element_def^.element_type = cmc$storage_device_element THEN
                    IF pen = unit_address THEN
                      found := TRUE;
                      element.element_type := element_def^.element_type;
                      element.peripheral_descriptor.use_logical_identification := TRUE;
                      element.peripheral_descriptor.element_name := element_def^.element_name;
                      EXIT /for_loop2/;
                    IFEND;
                  IFEND;
                IFEND;
              FOREND;
            IFEND;
          ELSEIF address_specified [cmc$channel] AND address_specified [cmc$channel_address] AND
                NOT address_specified [cmc$unit_address] THEN
            IF (cmv$physical_configuration^ [lc_index].element_type = cmc$data_channel_element) AND
                  (cmv$physical_configuration^ [lc_index].data_channel.ordinal = channel_number.ordinal) AND
                  (cmv$physical_configuration^ [lc_index].data_channel.iou = iou_name) AND
                  (cmv$physical_configuration^ [lc_index].data_channel.connection.equipment [channel_address].
                  configured) THEN
              found := TRUE;

              physical_descriptor.element_type := cmc$channel_adapter_element;
              physical_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
              physical_descriptor.peripheral_descriptor.element_name :=
                    cmv$physical_configuration^ [lc_index].data_channel.connection.
                    equipment [channel_address].element_name;
              cmp$get_element_definition (physical_descriptor, definition, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;

              element.element_type := definition.element_type;
              element.peripheral_descriptor.use_logical_identification := TRUE;
              element.peripheral_descriptor.element_name := cmv$physical_configuration^ [lc_index].
                    data_channel.connection.equipment [channel_address].element_name;
              EXIT /for_loop2/;

            IFEND;

          ELSEIF address_specified [cmc$channel] AND NOT address_specified [cmc$channel_address] AND
                NOT address_specified [cmc$unit_address] THEN
            IF (cmv$physical_configuration^ [lc_index].element_type = cmc$data_channel_element) AND
                  (cmv$physical_configuration^ [lc_index].data_channel.iou = iou_name) AND
                  (cmv$physical_configuration^ [lc_index].data_channel.number = channel.number) AND
                  (cmv$physical_configuration^ [lc_index].data_channel.concurrent = channel.concurrent) THEN
              found := TRUE;
              element.element_type := cmc$data_channel_element;
              element.channel_descriptor.use_logical_identification := TRUE;
              element.channel_descriptor.name := cmv$physical_configuration^ [lc_index].element_name;
              IF (cmv$physical_configuration^ [lc_index].data_channel.port = channel.port) THEN
                EXIT /for_loop2/;
              ELSE

{
{ Allow a channel name with no port to be returned if the request specifies no port.
{ Else an exact match is needed.
{

                IF (channel.port <> cmc$unspecified_port) THEN
                  found := FALSE;
                  CYCLE /for_loop2/;
                ELSE

{ Strip Port value from Channel name.

                  i := osc$max_name_size;
                  WHILE (i >= 1) AND (element.channel_descriptor.name (i, 1) = ' ') DO
                    IF (element.channel_descriptor.name (i, 1) = 'A') OR
                          (element.channel_descriptor.name (i, 1) = 'B') THEN
                      element.channel_descriptor.name (i, 1) := ' ';
                    IFEND;
                    i := i - 1;
                  WHILEND;
                IFEND;
              IFEND;
            IFEND;

          ELSEIF address_specified [cmc$iou] THEN
            IF NOT address_specified [cmc$channel_address] AND NOT address_specified [cmc$channel] AND
                  NOT address_specified [cmc$unit_address] THEN
              found := TRUE;
              element.element_type := cmc$iou_element;
              element.name := iou_name;
              EXIT /for_loop2/;
            IFEND;

          IFEND;
        FOREND /for_loop2/;
      IFEND;
      IF NOT found THEN
        cmp$format_error_message (element_descriptor, physical_identification, TRUE,
              cme$lcm_element_name_not_found, status);
        EXIT /main_program/;
      IFEND;

    END /main_program/;

  PROCEND cmp$get_element_name;

?? OLDTITLE ??
?? NEWTITLE := '  cmp$get_ms_class_on_volume', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_ms_class_on_volume
    (    recorded_vsn: rmt$recorded_vsn;
     VAR volume_found: boolean;
     VAR ms_class_info: cmt$ms_class_info);

    cmp$get_ms_class_on_volume_r1 (recorded_vsn, volume_found, ms_class_info);

  PROCEND cmp$get_ms_class_on_volume;

?? OLDTITLE ??
?? TITLE := '  cmp$get_number_of_elements', EJECT ??

*copyc cmh$get_number_of_elements

  PROCEDURE [XDCL, #GATE] cmp$get_number_of_elements
    (    selector: cmt$element_selector;
     VAR number_of_elements: integer;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      class: rmt$device_class,
      unit_type: cmt$unit_type,
      found: boolean,
      io_unit_type: iot$unit_type,
      unit_class: cmt$unit_class,
      index: integer;

    #CALLER_ID (caller_id);
    IF NOT (avp$configuration_administrator () OR avp$removable_media_operator () OR avp$system_displays ()
          OR (caller_id.ring <= 6)) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_ring_validation_error,
            'CMP$GET_NUMBER_OF_ELEMENTS', status);
      RETURN;
    IFEND;
    status.normal := TRUE;
    number_of_elements := 0;

  /main_program/
    BEGIN
      FOR index := LOWERBOUND (cmv$physical_configuration^) TO UPPERBOUND (cmv$physical_configuration^) DO
        CASE selector.key OF
        = cmc$select_by_type =

          IF cmv$physical_configuration^ [index].element_type = selector.element_type THEN
            number_of_elements := number_of_elements + 1;
          IFEND;
        = cmc$select_by_product =
          IF selector.product_id.model_number = '   ' THEN
            IF cmv$physical_configuration^ [index].product_id.product_number =
                  selector.product_id.product_number THEN
              number_of_elements := number_of_elements + 1;
            IFEND;
          ELSE

            IF cmv$physical_configuration^ [index].product_id = selector.product_id THEN
              number_of_elements := number_of_elements + 1;
            IFEND;
          IFEND;
        = cmc$select_by_device_class =

          IF (cmv$physical_configuration^ [index].element_type <> cmc$data_channel_element) AND
                (cmv$physical_configuration^ [index].element_type <> cmc$controller_element) THEN

            cmp$get_unit_type (cmv$physical_configuration^ [index].product_id, unit_type, io_unit_type,
                  unit_class, found);

            CASE unit_class OF
            = cmc$magnetic_tape_unit =
              class := rmc$magnetic_tape_device;
            = cmc$mass_storage_unit =
              class := rmc$mass_storage_device;
            = cmc$network_unit =
              class := rmc$network_device;
            = cmc$rhfam_unit =
              class := rmc$rhfam_device;
            ELSE
              class := rmc$null_device;
            CASEND;
            IF (NOT found) AND (cmv$physical_configuration^ [index].element_type =
                  cmc$storage_device_element) THEN
              class := rmc$mass_storage_device;
            IFEND;
            IF class = selector.device_class THEN
              number_of_elements := number_of_elements + 1;
            IFEND;
          IFEND;
        = cmc$select_all =

          IF (cmv$physical_configuration^ [index].element_type <> cmc$data_channel_element) THEN
            number_of_elements := number_of_elements + 1;
          IFEND;


        ELSE
          ;
        CASEND;

      FOREND;
      IF number_of_elements = 0 THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_elements_not_found, ' ', status);
        EXIT /main_program/;
      IFEND;
    END /main_program/;
  PROCEND cmp$get_number_of_elements;

?? OLDTITLE ??
?? TITLE := '   cmp$get_element_names', EJECT ??

*copyc cmh$get_element_names

  PROCEDURE [XDCL, #GATE] cmp$get_element_names
    (    selector: cmt$element_selector;
         elements: ^array [ * ] of cmt$element_name;
     VAR status: ost$status);


    VAR
      caller_id: ost$caller_identifier,
      class: rmt$device_class,
      unit_type: cmt$unit_type,
      found: boolean,
      io_unit_type: iot$unit_type,
      unit_class: cmt$unit_class,
      number_of_elements,
      index: integer;

    #CALLER_ID (caller_id);
    IF NOT (avp$configuration_administrator () OR avp$removable_media_operator () OR avp$system_displays ()
          OR (caller_id.ring <= 6)) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_ring_validation_error,
            'CMP$GET_ELEMENT_NAMES', status);
      RETURN;
    IFEND;
    status.normal := TRUE;

  /main_program/
    BEGIN
      IF elements = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_nil_pointer_detected,
              'CMP$GET_ELEMENT_NAMES', status);
        EXIT /main_program/;
      IFEND;
      FOR index := LOWERBOUND (elements^) TO UPPERBOUND (elements^) DO
        elements^ [index] := osc$null_name;
      FOREND;


      number_of_elements := 0;
      FOR index := LOWERBOUND (cmv$physical_configuration^) TO UPPERBOUND (cmv$physical_configuration^) DO
        CASE selector.key OF
        = cmc$select_by_type =

          IF cmv$physical_configuration^ [index].element_type = selector.element_type THEN
            number_of_elements := number_of_elements + 1;
            elements^ [number_of_elements] := cmv$physical_configuration^ [index].element_name;
          IFEND;
        = cmc$select_by_product =
          IF selector.product_id.model_number = '   ' THEN
            IF cmv$physical_configuration^ [index].product_id.product_number =
                  selector.product_id.product_number THEN
              number_of_elements := number_of_elements + 1;
              elements^ [number_of_elements] := cmv$physical_configuration^ [index].element_name;
            IFEND;
          ELSE

            IF cmv$physical_configuration^ [index].product_id = selector.product_id THEN
              number_of_elements := number_of_elements + 1;
              elements^ [number_of_elements] := cmv$physical_configuration^ [index].element_name;
            IFEND;
          IFEND;
        = cmc$select_by_device_class =

          IF (cmv$physical_configuration^ [index].element_type <> cmc$data_channel_element) AND
                (cmv$physical_configuration^ [index].element_type <> cmc$controller_element) THEN

            cmp$get_unit_type (cmv$physical_configuration^ [index].product_id, unit_type, io_unit_type,
                  unit_class, found);

            CASE unit_class OF
            = cmc$magnetic_tape_unit =
              class := rmc$magnetic_tape_device;
            = cmc$mass_storage_unit =
              class := rmc$mass_storage_device;
            = cmc$network_unit =
              class := rmc$network_device;
            = cmc$rhfam_unit =
              class := rmc$rhfam_device;
            ELSE
              class := rmc$null_device;
            CASEND;
            IF (NOT found) AND (cmv$physical_configuration^ [index].element_type =
                  cmc$storage_device_element) THEN
              class := rmc$mass_storage_device;
            IFEND;
            IF class = selector.device_class THEN
              number_of_elements := number_of_elements + 1;
              elements^ [number_of_elements] := cmv$physical_configuration^ [index].element_name;
            IFEND;
          IFEND;
        = cmc$select_all =

          IF (cmv$physical_configuration^ [index].element_type <> cmc$data_channel_element) THEN
            number_of_elements := number_of_elements + 1;
            elements^ [number_of_elements] := cmv$physical_configuration^ [index].element_name;
          IFEND;


        ELSE
          ;
        CASEND;
        IF number_of_elements >= UPPERBOUND (elements^) THEN
          EXIT /main_program/;
        IFEND;
      FOREND;
    END /main_program/;

  PROCEND cmp$get_element_names;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$get_iou_definition ', EJECT ??

*copyc cmh$get_iou_definition

  PROCEDURE [XDCL, #GATE] cmp$get_iou_definition
    (    iou_name: cmt$element_name;
     VAR iou_definition: cmt$iou_definition;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      iou_def: cmt$iou_definition;

    #CALLER_ID (caller_id);
    IF NOT (avp$configuration_administrator () OR avp$removable_media_operator () OR avp$system_displays ()
          OR (caller_id.ring <= 6)) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_ring_validation_error,
            'CMP$GET_IOU_DEFINITION', status);
      RETURN;
    IFEND;
    status.normal := TRUE;
    cmp$retrieve_iou_definition (iou_name, iou_def, status);
    IF status.normal THEN
      iou_definition := iou_def;
    IFEND;
  PROCEND cmp$get_iou_definition;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$get_pp_definition', EJECT ??

*copyc cmh$get_pp_definition

  PROCEDURE [XDCL, #GATE] cmp$get_pp_definition
    (    pp_identification: cmt$pp_descriptor;
     VAR pp_definition: cmt$pp_definition;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      pp_id: cmt$pp_descriptor,
      pp_def: cmt$pp_definition;

    #CALLER_ID (caller_id);
    IF NOT (avp$configuration_administrator () OR avp$removable_media_operator () OR avp$system_displays ()
          OR (caller_id.ring <= 6)) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_ring_validation_error,
            'CMP$GET_PP_DEFINITION', status);
      RETURN;
    IFEND;
    status.normal := TRUE;
    pp_id := pp_identification;
    cmp$get_pp_def (pp_id, pp_def, status);
    IF status.normal THEN
      pp_definition := pp_def;
    IFEND;

  PROCEND cmp$get_pp_definition;

?? OLDTITLE ??
?? NEWTITLE := '  cmp$multiple_iou_system', EJECT ??
*copyc cmh$multiple_iou_system

  FUNCTION [XDCL, #GATE, UNSAFE] cmp$multiple_iou_system: boolean;

    VAR
      caller_id: ost$caller_identifier,
      iou_information_table: dst$iou_information_table,
      number_of_ious: dst$number_of_ious;

    #CALLER_ID (caller_id);
    IF NOT (avp$configuration_administrator () OR avp$removable_media_operator () OR avp$system_displays ()
          OR (caller_id.ring <= 6)) THEN
      RETURN;
    IFEND;
    dsp$retrieve_iou_information (number_of_ious, iou_information_table);
    cmp$multiple_iou_system := number_of_ious > 1;

  FUNCEND cmp$multiple_iou_system;

?? OLDTITLE ??
?? NEWTITLE := '      cmp$system_critical', EJECT ??

{ PURPOSE:
{   This procedure determines whether or not an element is system critical.

  PROCEDURE [XDCL] cmp$system_critical
    (    element: cmt$element_definition;
     VAR system_critical: boolean;
     VAR status: ost$status);

    VAR
      avt_entry_not_found: boolean,
      ch_port: integer,
      ch_state: cmt$element_state,
      channel_element: ^cmt$element_definition,
      channels_on: integer,
      cio_channel_name: cmt$element_name,
      controller_type: cmt$controller_type,
      dual_access: boolean,
      eq_element: ^cmt$element_definition,
      eq_index: integer,
      ignore_status: ost$status,
      iou_name: cmt$element_name,
      logical_pp: iot$pp_number,
      logical_unit: iot$logical_unit,
      mainframe_id: pmt$mainframe_id,
      ms_class_info: cmt$ms_class_info,
      non_dual_access_controller: boolean,
      other_channel: ^cmt$element_definition,
      other_equipment: ^cmt$element_definition,
      other_logical_pp: iot$pp_number,
      port: integer,
      rec_vsn: rmt$recorded_vsn,
      search_key: dmt$avt_search_key,
      set_name: stt$set_name,
      state: cmt$element_state,
      system_device: boolean,
      unit_element: ^cmt$element_definition,
      unit_index: integer,
      volume_found: boolean;

    system_critical := FALSE;
    system_device := FALSE;
    dual_access := FALSE;
    status.normal := TRUE;

    pmp$get_mainframe_id (mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE element.element_type OF
    = cmc$data_channel_element =
      cmp$pc_get_element (element.element_name, element.data_channel.iou, channel_element, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      cmp$get_logical_pp_index (channel_element^, logical_pp, ignore_status);
      IF NOT ignore_status.normal THEN
        {
        { Element defined, but no PP Table entry.  i.e. forgein equipment defined but cmp$execute_pp_program
        { has not been executed yet.  Ignore status and return NOT system critical.
        {
        RETURN;
      IFEND;

    /equipment_loop_0/
      FOR eq_index := LOWERVALUE (cmt$physical_equipment_number)
            TO UPPERVALUE (cmt$physical_equipment_number) DO
        IF element.data_channel.connection.equipment [eq_index].configured THEN
          cmp$pc_get_element (element.data_channel.connection.equipment [eq_index].element_name, iou_name,
                eq_element, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF eq_element^.element_type = cmc$storage_device_element THEN { Hydra }
            cmp$get_logical_unit_number (eq_element^.element_name, logical_unit, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF logical_unit <> 0 THEN

              search_key.value := dmc$search_avt_by_lun;
              search_key.logical_unit_number := logical_unit;
              cmp$search_active_volume_table (search_key, rec_vsn, avt_entry_not_found);

              IF NOT avt_entry_not_found THEN
                stp$get_volumes_set_name (rec_vsn, set_name, ignore_status);
                cmp$get_ms_class_on_volume (rec_vsn, volume_found, ms_class_info);
                IF volume_found THEN
                  system_device := (ms_class_info['J'] AND (set_name = stv$system_set_name))
                      OR ms_class_info['Q'];
                  IF system_device THEN
                    EXIT /equipment_loop_0/;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          ELSEIF eq_element^.element_type = cmc$controller_element THEN

          /unit_loop_0/
            FOR unit_index := LOWERVALUE (cmt$physical_unit_number)
                  TO UPPERVALUE (cmt$physical_unit_number) DO
              IF eq_element^.controller.connection.unit [unit_index].configured THEN
                cmp$pc_get_element (eq_element^.controller.connection.unit [unit_index].element_name,
                      iou_name, unit_element, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                cmp$get_logical_unit_number (unit_element^.element_name, logical_unit, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                IF (logical_unit <> 0) AND
                      (cmv$logical_pp_table_p^ [logical_pp].pp_info.pp_interface_table_p^.
                      unit_descriptors [logical_unit].unit_interface_table_rma <> 0) THEN

                  search_key.value := dmc$search_avt_by_lun;
                  search_key.logical_unit_number := logical_unit;
                  cmp$search_active_volume_table (search_key, rec_vsn, avt_entry_not_found);
                  IF NOT avt_entry_not_found THEN
                    stp$get_volumes_set_name (rec_vsn, set_name, ignore_status);
                    cmp$get_ms_class_on_volume (rec_vsn, volume_found, ms_class_info);
                    IF volume_found THEN
                      system_device := (ms_class_info['J'] AND (set_name = stv$system_set_name))
                          OR ms_class_info['Q'];
                      IF system_device THEN
                        EXIT /equipment_loop_0/;
                      IFEND;
                    IFEND;
                  IFEND;
                IFEND;
              IFEND;
            FOREND /unit_loop_0/;
          ELSE
            RETURN;
          IFEND;
        IFEND;
      FOREND /equipment_loop_0/;

{ IF NOT system_device THEN check another port of the channel

      IF NOT system_device THEN
        cio_channel_name := ' ';
        IF (element.element_name (5) = 'A') OR (element.element_name (5) = 'B') THEN
          cio_channel_name := element.element_name;
          IF (element.element_name (5) = 'A') THEN
            cio_channel_name (5) := 'B';
          ELSE
            cio_channel_name (5) := 'A';
          IFEND;

          cmp$pc_get_element (cio_channel_name, element.data_channel.iou, channel_element, ignore_status);

          IF ignore_status.normal THEN
            cmp$get_element_state (cio_channel_name, channel_element^.data_channel.iou, ch_state,
                  ignore_status);
            IF ch_state = cmc$on THEN

            /equipment_loop_1/
              FOR eq_index := LOWERVALUE (cmt$physical_equipment_number)
                    TO UPPERVALUE (cmt$physical_equipment_number) DO
                IF channel_element^.data_channel.connection.equipment [eq_index].configured THEN
                  cmp$pc_get_element (channel_element^.data_channel.connection.equipment [eq_index].
                        element_name, iou_name, eq_element, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;

                  IF eq_element^.element_type = cmc$storage_device_element THEN { Hydra }
                    cmp$get_logical_unit_number (eq_element^.element_name, logical_unit, status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;

                    IF logical_unit <> 0 THEN
                      search_key.value := dmc$search_avt_by_lun;
                      search_key.logical_unit_number := logical_unit;
                      cmp$search_active_volume_table (search_key, rec_vsn, avt_entry_not_found);
                      IF NOT avt_entry_not_found THEN
                        stp$get_volumes_set_name (rec_vsn, set_name, ignore_status);
                        cmp$get_ms_class_on_volume (rec_vsn, volume_found, ms_class_info);
                        IF volume_found THEN
                          system_device := (ms_class_info['J'] AND (set_name = stv$system_set_name))
                              OR ms_class_info['Q'];
                          IF system_device THEN
                            EXIT /equipment_loop_1/;
                          IFEND;
                        IFEND;
                      IFEND;
                    IFEND;
                  ELSEIF eq_element^.element_type = cmc$controller_element THEN

                  /unit_loop_1/
                    FOR unit_index := LOWERVALUE (cmt$physical_unit_number)
                          TO UPPERVALUE (cmt$physical_unit_number) DO
                      IF eq_element^.controller.connection.unit [unit_index].configured THEN
                        cmp$pc_get_element (eq_element^.controller.connection.unit [unit_index].element_name,
                              iou_name, unit_element, status);
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;

                        cmp$get_logical_unit_number (unit_element^.element_name, logical_unit, status);
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;

                        IF logical_unit <> 0 THEN

                          search_key.value := dmc$search_avt_by_lun;
                          search_key.logical_unit_number := logical_unit;
                          cmp$search_active_volume_table (search_key, rec_vsn, avt_entry_not_found);

                          IF NOT avt_entry_not_found THEN
                            stp$get_volumes_set_name (rec_vsn, set_name, ignore_status);
                            cmp$get_ms_class_on_volume (rec_vsn, volume_found, ms_class_info);
                            IF volume_found THEN
                              system_device := (ms_class_info['J'] AND (set_name = stv$system_set_name))
                                  OR ms_class_info['Q'];
                              IF system_device THEN
                                EXIT /equipment_loop_1/;
                              IFEND;
                            IFEND;
                          IFEND;
                        IFEND;
                      IFEND;
                    FOREND /unit_loop_1/;
                  ELSE
                    RETURN;
                  IFEND;
                IFEND;
              FOREND /equipment_loop_1/;
            IFEND; { CHANNEL is ON }
          IFEND; { Normal status from cmp$pc_get_element }
        IFEND;
      IFEND;

      IF system_device THEN

        logical_pp := 0; { IF PPIT not built at deadstart. }
        cmp$get_logical_pp_index (channel_element^, logical_pp, ignore_status);

        IF eq_element^.element_type = cmc$storage_device_element THEN { Hydra }

        /port_loop_1/
          FOR port := LOWERVALUE (cmt$data_storage_port_number)
                TO UPPERVALUE (cmt$data_storage_port_number) DO
            IF eq_element^.storage_device.connection.port [port].configured THEN
              IF ((eq_element^.storage_device.connection.port [port].element_name <>
                    channel_element^.element_name) OR (eq_element^.storage_device.connection.port [port].
                    iou <> channel_element^.data_channel.iou)) AND
                    (eq_element^.storage_device.connection.port [port].mainframe_ownership =
                    channel_element^.data_channel.mainframe_ownership) THEN
                cmp$get_element_state (eq_element^.storage_device.connection.port [port].element_name,
                      eq_element^.storage_device.connection.port [port].iou, state, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                IF state = cmc$on THEN
                  cmp$pc_get_element (eq_element^.storage_device.connection.port [port].element_name,
                        eq_element^.storage_device.connection.port [port].iou, other_channel, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;

                  cmp$get_logical_pp_index (other_channel^, other_logical_pp, ignore_status);
                  IF ignore_status.normal THEN { PPIT build at deadstart. }
                    IF logical_pp <> other_logical_pp THEN { CCH#A and CCH#B have the same PPIT. }
                      dual_access := TRUE;
                      EXIT /port_loop_1/;
                    IFEND;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          FOREND /port_loop_1/;
        ELSEIF eq_element^.element_type = cmc$controller_element THEN

        /port_loop_2/
          FOR port := LOWERVALUE (cmt$data_storage_port_number)
                TO UPPERVALUE (cmt$data_storage_port_number) DO
            IF (unit_element^.storage_device.connection.port [port].configured) THEN
              IF unit_element^.storage_device.connection.port [port].element_name <>
                    eq_element^.element_name THEN

{ Dual controllers to system device.

                cmp$get_element_state (unit_element^.storage_device.connection.port [port].element_name,
                      iou_name, state, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                IF state = cmc$on THEN

{ Check the state of all channels connected to this equipment

                  cmp$pc_get_element (unit_element^.storage_device.connection.port [port].element_name,
                        iou_name, other_equipment, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;

                  FOR ch_port := LOWERVALUE (cmt$controller_port_number)
                        TO UPPERVALUE (cmt$controller_port_number) DO
                    IF other_equipment^.controller.connection.port [ch_port].configured THEN
                      IF ((other_equipment^.controller.connection.port [ch_port].element_name <>
                            channel_element^.element_name) OR (other_equipment^.controller.connection.
                            port [ch_port].iou <> channel_element^.data_channel.iou)) AND
                            (eq_element^.controller.connection.port [ch_port].mainframe_ownership =
                            channel_element^.data_channel.mainframe_ownership) THEN
                        cmp$get_element_state (other_equipment^.controller.connection.port [ch_port].
                              element_name, other_equipment^.controller.connection.port [ch_port].iou,
                              ch_state, status);
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;

                        IF ch_state = cmc$on THEN
                          cmp$pc_get_element (other_equipment^.controller.connection.port [ch_port].
                                element_name, other_equipment^.controller.connection.port [ch_port].iou,
                                other_channel, status);
                          IF NOT status.normal THEN
                            RETURN;
                          IFEND;

                          cmp$get_logical_pp_index (other_channel^, other_logical_pp, ignore_status);
                          IF ignore_status.normal THEN { PPIT build at deadstart. }
                            IF other_logical_pp <> logical_pp THEN { CCH#A and CCH#B have same PPIT. }
                              dual_access := TRUE;
                              EXIT /port_loop_2/;
                            IFEND;
                          IFEND;
                        IFEND;
                      IFEND;
                    IFEND;
                  FOREND;
                IFEND;
              IFEND;
            IFEND;
          FOREND /port_loop_2/;

{ Not dual controller access, so check if dual channel access
{ unless type of controller is non dual access.

          IF NOT dual_access THEN

            cmp$get_controller_type (eq_element^.product_id, controller_type, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            non_dual_access_controller := (controller_type = cmc$ms7155_1) OR
                  (controller_type = cmc$ms7155_1x) OR (controller_type = cmc$mscm3_ct) OR
                  (controller_type = cmc$ms7154_x) OR (controller_type = cmc$ms7255_1_1) OR
                  (controller_type = cmc$ms7255_1_2);

            IF NOT non_dual_access_controller THEN

            /port_loop_3/
              FOR port := LOWERVALUE (cmt$controller_port_number)
                    TO UPPERVALUE (cmt$controller_port_number) DO
                IF (eq_element^.controller.connection.port [port].configured) AND
                      (eq_element^.controller.connection.port [port].mainframe_ownership = mainframe_id) THEN
                  IF (eq_element^.controller.connection.port [port].element_name <>
                        channel_element^.element_name) OR (eq_element^.controller.connection.port [port].
                        iou <> channel_element^.data_channel.iou) THEN
                    cmp$get_element_state (eq_element^.controller.connection.port [port].element_name,
                          eq_element^.controller.connection.port [port].iou, state, status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;

                    IF state = cmc$on THEN
                      cmp$pc_get_element (eq_element^.controller.connection.port [port].element_name,
                            eq_element^.controller.connection.port [port].iou, other_channel, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                      cmp$get_logical_pp_index (other_channel^, other_logical_pp, ignore_status);
                      IF ignore_status.normal THEN { PPIT build at deadstart. }
                        IF other_logical_pp <> logical_pp THEN { CCH#A and CCH#B have same PPIT. }
                          dual_access := TRUE;
                          EXIT /port_loop_3/;
                        IFEND;
                      IFEND;
                    IFEND;
                  IFEND;
                IFEND;
              FOREND /port_loop_3/;
            IFEND;
          IFEND;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      system_critical := (system_device) AND (NOT dual_access);

    = cmc$controller_element =

    /unit_loop_2/
      FOR unit_index := LOWERVALUE (cmt$physical_unit_number) TO UPPERVALUE (cmt$physical_unit_number) DO
        IF element.controller.connection.unit [unit_index].configured THEN
          cmp$pc_get_element (element.controller.connection.unit [unit_index].element_name, iou_name,
                unit_element, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          cmp$get_logical_unit_number (unit_element^.element_name, logical_unit, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF logical_unit <> 0 THEN

            search_key.value := dmc$search_avt_by_lun;
            search_key.logical_unit_number := logical_unit;
            cmp$search_active_volume_table (search_key, rec_vsn, avt_entry_not_found);

            IF NOT avt_entry_not_found THEN
              stp$get_volumes_set_name (rec_vsn, set_name, ignore_status);
              cmp$get_ms_class_on_volume (rec_vsn, volume_found, ms_class_info);
              IF volume_found THEN
                system_device := (ms_class_info['J'] AND (set_name = stv$system_set_name))
                    OR ms_class_info['Q'];
                IF system_device THEN
                  EXIT /unit_loop_2/;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND /unit_loop_2/;

      IF system_device THEN

      /port_loop_4/
        FOR port := LOWERVALUE (cmt$data_storage_port_number) TO UPPERVALUE (cmt$data_storage_port_number) DO
          IF (unit_element^.storage_device.connection.port [port].configured) THEN
            IF unit_element^.storage_device.connection.port [port].element_name <> element.element_name THEN
              cmp$get_element_state (unit_element^.storage_device.connection.port [port].element_name,
                    iou_name, state, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              IF state = cmc$on THEN

{ Check the state of all channels connected to this equipment

                cmp$pc_get_element (unit_element^.storage_device.connection.port [port].element_name,
                      iou_name, other_equipment, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                FOR ch_port := LOWERVALUE (cmt$controller_port_number)
                      TO UPPERVALUE (cmt$controller_port_number) DO
                  IF other_equipment^.controller.connection.port [ch_port].configured THEN

{ Do not care if other_equipment.channel = element.channel

                    cmp$get_element_state (other_equipment^.controller.connection.port [ch_port].element_name,
                          other_equipment^.controller.connection.port [ch_port].iou, ch_state, status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;

                    IF ch_state = cmc$on THEN
                      cmp$pc_get_element (other_equipment^.controller.connection.port [ch_port].element_name,
                            other_equipment^.controller.connection.port [ch_port].iou, other_channel, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                      cmp$get_logical_pp_index (other_channel^, other_logical_pp, ignore_status);
                      IF ignore_status.normal THEN { PPIT build at deadstart. }

{ CCH#A and CCH#B have same PPIT does not count in this case.

                        dual_access := TRUE;
                        EXIT /port_loop_4/;
                      IFEND;
                    IFEND;
                  IFEND;
                FOREND;
              IFEND;
            IFEND;
          IFEND;
        FOREND /port_loop_4/;

{ Not dual controller access, so check if dual channel access ?
{ No, if element is controller, dual channel access does not count.

      IFEND;

      system_critical := (system_device) AND (NOT dual_access);

    = cmc$storage_device_element =

      cmp$get_logical_unit_number (element.element_name, logical_unit, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF logical_unit <> 0 THEN

        search_key.value := dmc$search_avt_by_lun;
        search_key.logical_unit_number := logical_unit;
        cmp$search_active_volume_table (search_key, rec_vsn, avt_entry_not_found);

        IF NOT avt_entry_not_found THEN
          stp$get_volumes_set_name (rec_vsn, set_name, ignore_status);
          cmp$get_ms_class_on_volume (rec_vsn, volume_found, ms_class_info);
          IF volume_found THEN
            system_device := (ms_class_info['J'] AND (set_name = stv$system_set_name))
                OR ms_class_info['Q'];
          IFEND;
        IFEND;
      IFEND;
      system_critical := system_device;
    ELSE
      ;
    CASEND;

  PROCEND cmp$system_critical;

?? OLDTITLE ??
MODEND cmm$config_status_interfaces

*DECK DECK=CMM$CONNECTION_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'Connection Management Interfaces' ??
MODULE cmm$connection_manager;
{
{ PURPOSE: This module contains interfaces that maintain and display information
{          about connections between elements in a configuration.  The connection
{          information is stored in the physical_descriptor field of the
{          peripheral_element_table which resides in the mainframe_wired segment.
{
{ DESIGN:  A connection status may be in one of three states:
{            cmc$active - both the upline and downline elements are in the ON state.
{            cmc$inactive - either one or both of the upline and downline elements are
{                           in the OFF or DOWN state.
{            cmc$disabled - both the upline and downline element are in the ON state
{                           but an automatic reconfiguration has disabled the connection
{                           and reconfigured to a redundant path.


?? PUSH (LISTEXT := ON) ??
*copyc cme$logical_configuration_mgr
*copyc cmt$connection
*copyc cmt$element_descriptor
*copyc cmt$element_reservation
*copyc cmt$upline_connection
*copyc cmv$peripheral_element_table
*copyc cmv$physical_configuration
*copyc ost$status
?? POP ??
*copyc cmp$get_element_definition
*copyc cmp$get_mainframe_element
*copyc cmp$search_peripheral_table
*copyc pmp$get_mainframe_id
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal

?? TITLE := '  cmp$get_connection_list', EJECT ??

{
{ PURPOSE:
{   This procedure will return an array that contains connection information for
{   every connection in every path that contains the specified element.  For example,
{   if a channel is specified the array would contain all channel/controller connections
{   and all controller /unit connections accessible by the channel.  The connection
{   information includes the upline element name, the downline element name and the
{   connection status.  The connection count will return the number of connections
{   found.  If the array supplied was not large enough to hold all connections found
{   this value can be used to allocate an array of the proper size before calling this
{   procedure again.
{

  PROCEDURE [XDCL, #GATE] cmp$get_connection_list
    (    element_definition: cmt$element_definition;
     VAR connection_count: integer;
     VAR connection_list: ^array [1 .. * ] of cmt$connection;
     VAR status: ost$status);

    VAR
      controller_definition: cmt$element_definition,
      dummy_reservation: cmt$element_reservation,
      element_descriptor: cmt$element_descriptor,
      i: integer,
      iou_channel: cmt$element_name,
      j: integer,
      mainframe_id: pmt$mainframe_id,
      pet_index: integer,
      pet_index_2: integer,
      upline_connection: cmt$upline_connection;

    connection_count := 0;
    status.normal := TRUE;

    pmp$get_mainframe_id (mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE element_definition.element_type OF
    = cmc$data_channel_element =
      {
      { Find the channel in the peripheral_element table.
      {
      element_descriptor.element_type := element_definition.element_type;
      element_descriptor.channel_descriptor.iou := element_definition.data_channel.iou;
      element_descriptor.channel_descriptor.use_logical_identification := TRUE;
      element_descriptor.channel_descriptor.name := element_definition.element_name;
      cmp$search_peripheral_table (element_descriptor, dummy_reservation, FALSE, pet_index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      iou_channel := element_definition.data_channel.iou;
      iou_channel (5) := '/';
      iou_channel (6, * ) := element_definition.element_name;

      FOR i := 1 TO UPPERBOUND (cmv$peripheral_element_table.pointer^ [pet_index].physical_descriptor.
            channel_connection^) DO
        connection_count := connection_count + 1;
        IF connection_count <= UPPERBOUND (connection_list^) THEN
          connection_list^ [connection_count].upline_element := iou_channel;
          connection_list^ [connection_count].downline_element := cmv$peripheral_element_table.
                pointer^ [pet_index].physical_descriptor.channel_connection^ [i].downline_element;
          connection_list^ [connection_count].status := cmv$peripheral_element_table.pointer^ [pet_index].
                physical_descriptor.channel_connection^ [i].status;
        IFEND;

        cmp$get_mainframe_element (cmv$peripheral_element_table.pointer^ [pet_index].physical_descriptor.
              channel_connection^ [i].downline_element, element_definition.data_channel.iou,
              controller_definition, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        CASE controller_definition.element_type OF
        = cmc$controller_element, cmc$channel_adapter_element =
          element_descriptor.element_type := controller_definition.element_type;
          element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
          element_descriptor.peripheral_descriptor.element_name := controller_definition.element_name;

          cmp$search_peripheral_table (element_descriptor, dummy_reservation, FALSE, pet_index_2, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          FOR j := 1 TO UPPERBOUND (cmv$peripheral_element_table.pointer^ [pet_index_2].physical_descriptor.
                equipment_connection^) DO
            connection_count := connection_count + 1;
            IF connection_count <= UPPERBOUND (connection_list^) THEN
              connection_list^ [connection_count].upline_element :=
                    element_descriptor.peripheral_descriptor.element_name;
              connection_list^ [connection_count].downline_element := cmv$peripheral_element_table.
                    pointer^ [pet_index_2].physical_descriptor.equipment_connection^ [j].downline_element;
              connection_list^ [connection_count].status := cmv$peripheral_element_table.
                    pointer^ [pet_index_2].physical_descriptor.equipment_connection^ [j].status;
            IFEND;
          FOREND;
        ELSE
        CASEND;
      FOREND;

    = cmc$communications_element =

    /equipment_loop_1/
      FOR i := LOWERVALUE (cmt$communications_port_number) TO UPPERVALUE (cmt$communications_port_number) DO
        IF NOT element_definition.communications_element.connection.port [i].configured THEN
          CYCLE /equipment_loop_1/;
        IFEND;

        upline_connection := element_definition.communications_element.connection.port [i];
        IF upline_connection.upline_connection_type <> cmc$data_channel_element THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_upline_connection,
                element_definition.element_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, upline_connection.element_name,
                status);
          RETURN;
        IFEND;

        IF upline_connection.mainframe_ownership <> mainframe_id THEN
          CYCLE /equipment_loop_1/
        IFEND;

        element_descriptor.element_type := upline_connection.upline_connection_type;
        element_descriptor.channel_descriptor.name := upline_connection.element_name;
        element_descriptor.channel_descriptor.iou := upline_connection.iou;
        element_descriptor.channel_descriptor.use_logical_identification := TRUE;

        connection_count := connection_count + 1;
        IF connection_count <= UPPERBOUND (connection_list^) THEN
          iou_channel := upline_connection.iou;
          iou_channel (5) := '/';
          iou_channel (6, * ) := upline_connection.element_name;

          connection_list^ [connection_count].upline_element := iou_channel;
          connection_list^ [connection_count].downline_element := element_definition.element_name;
          cmp$get_connection_status (element_descriptor, element_definition.element_name,
                connection_list^ [connection_count].status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND /equipment_loop_1/;

    = cmc$external_processor_element =

    /external_processor_loop_1/
      FOR i := LOWERVALUE (cmt$physical_equipment_number) TO UPPERVALUE (cmt$physical_equipment_number) DO
        IF element_definition.external_processor.connection.io_port [i].configured THEN
          upline_connection := element_definition.external_processor.connection.io_port [i];
          IF upline_connection.upline_connection_type <> cmc$data_channel_element THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_upline_connection,
                  element_definition.element_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, upline_connection.element_name,
                  status);
            RETURN;
          IFEND;

          IF upline_connection.mainframe_ownership <> mainframe_id THEN
            CYCLE /external_processor_loop_1/;
          IFEND;

          element_descriptor.element_type := upline_connection.upline_connection_type;
          element_descriptor.channel_descriptor.name := upline_connection.element_name;
          element_descriptor.channel_descriptor.iou := upline_connection.iou;
          element_descriptor.channel_descriptor.use_logical_identification := TRUE;

          connection_count := connection_count + 1;
          IF connection_count <= UPPERBOUND (connection_list^) THEN
            iou_channel := upline_connection.iou;
            iou_channel (5) := '/';
            iou_channel (6, * ) := upline_connection.element_name;

            connection_list^ [connection_count].upline_element := iou_channel;
            connection_list^ [connection_count].downline_element := element_definition.element_name;
            cmp$get_connection_status (element_descriptor, element_definition.element_name,
                  connection_list^ [connection_count].status, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      FOREND /external_processor_loop_1/;

    = cmc$controller_element =

    /controller_loop_1/
      FOR i := LOWERVALUE (cmt$controller_port_number) TO UPPERVALUE (cmt$controller_port_number) DO
        IF element_definition.controller.connection.port [i].configured THEN
          upline_connection := element_definition.controller.connection.port [i];
          IF upline_connection.upline_connection_type <> cmc$data_channel_element THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_upline_connection,
                  element_definition.element_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, upline_connection.element_name,
                  status);
            RETURN;
          IFEND;

          IF upline_connection.mainframe_ownership <> mainframe_id THEN
            CYCLE /controller_loop_1/;
          IFEND;

          element_descriptor.element_type := upline_connection.upline_connection_type;
          element_descriptor.channel_descriptor.name := upline_connection.element_name;
          element_descriptor.channel_descriptor.iou := upline_connection.iou;
          element_descriptor.channel_descriptor.use_logical_identification := TRUE;

          connection_count := connection_count + 1;
          IF connection_count <= UPPERBOUND (connection_list^) THEN
            iou_channel := upline_connection.iou;
            iou_channel (5) := '/';
            iou_channel (6, * ) := upline_connection.element_name;

            connection_list^ [connection_count].upline_element := iou_channel;
            connection_list^ [connection_count].downline_element := element_definition.element_name;
            cmp$get_connection_status (element_descriptor, element_definition.element_name,
                  connection_list^ [connection_count].status, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      FOREND /controller_loop_1/;

      element_descriptor.element_type := element_definition.element_type;
      element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
      element_descriptor.peripheral_descriptor.element_name := element_definition.element_name;
      cmp$search_peripheral_table (element_descriptor, dummy_reservation, FALSE, pet_index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      FOR i := 1 TO UPPERBOUND (cmv$peripheral_element_table.pointer^ [pet_index].physical_descriptor.
            equipment_connection^) DO
        connection_count := connection_count + 1;
        IF connection_count <= UPPERBOUND (connection_list^) THEN
          connection_list^ [connection_count].upline_element := element_definition.element_name;
          connection_list^ [connection_count].downline_element := cmv$peripheral_element_table.
                pointer^ [pet_index].physical_descriptor.equipment_connection^ [i].downline_element;
          connection_list^ [connection_count].status := cmv$peripheral_element_table.pointer^ [pet_index].
                physical_descriptor.equipment_connection^ [i].status;
        IFEND;
      FOREND;

    = cmc$channel_adapter_element =
      IF element_definition.channel_adapter.connection.channel.configured THEN
        upline_connection := element_definition.channel_adapter.connection.channel;
        IF upline_connection.upline_connection_type <> cmc$data_channel_element THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_upline_connection,
                element_definition.element_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, upline_connection.element_name,
                status);
          RETURN;
        IFEND;

        element_descriptor.element_type := upline_connection.upline_connection_type;
        element_descriptor.channel_descriptor.name := upline_connection.element_name;
        element_descriptor.channel_descriptor.iou := upline_connection.iou;
        element_descriptor.channel_descriptor.use_logical_identification := TRUE;

        connection_count := connection_count + 1;
        IF connection_count <= UPPERBOUND (connection_list^) THEN
          iou_channel := upline_connection.iou;
          iou_channel (5) := '/';
          iou_channel (6, * ) := upline_connection.element_name;

          connection_list^ [connection_count].upline_element := iou_channel;
          connection_list^ [connection_count].downline_element := element_definition.element_name;
          cmp$get_connection_status (element_descriptor, element_definition.element_name,
                connection_list^ [connection_count].status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;

      element_descriptor.element_type := element_definition.element_type;
      element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
      element_descriptor.peripheral_descriptor.element_name := element_definition.element_name;
      cmp$search_peripheral_table (element_descriptor, dummy_reservation, FALSE, pet_index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      FOR i := 1 TO UPPERBOUND (cmv$peripheral_element_table.pointer^ [pet_index].physical_descriptor.
            equipment_connection^) DO
        connection_count := connection_count + 1;
        IF connection_count <= UPPERBOUND (connection_list^) THEN
          connection_list^ [connection_count].upline_element := element_definition.element_name;
          connection_list^ [connection_count].downline_element := cmv$peripheral_element_table.
                pointer^ [pet_index].physical_descriptor.equipment_connection^ [i].downline_element;
          connection_list^ [connection_count].status := cmv$peripheral_element_table.pointer^ [pet_index].
                physical_descriptor.equipment_connection^ [i].status;
        IFEND;
      FOREND;

    = cmc$storage_device_element =
      IF element_definition.product_id.product_number = '  $887' THEN
        cmp$get_hydra_connection_list (element_definition, connection_count, connection_list, status);
        RETURN;
      IFEND;

    /unit_loop/
      FOR i := LOWERVALUE (cmt$data_storage_port_number) TO UPPERVALUE (cmt$data_storage_port_number) DO
        IF NOT element_definition.storage_device.connection.port [i].configured THEN
          CYCLE /unit_loop/;
        IFEND;
        upline_connection := element_definition.storage_device.connection.port [i];

        element_descriptor.element_type := upline_connection.upline_connection_type;
        element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
        element_descriptor.peripheral_descriptor.element_name := upline_connection.element_name;

        cmp$get_element_definition (element_descriptor, controller_definition, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        CASE upline_connection.upline_connection_type OF
        = cmc$controller_element =

        /controller_loop_2/
          FOR j := LOWERVALUE (cmt$controller_port_number) TO UPPERVALUE (cmt$controller_port_number) DO
            IF NOT controller_definition.controller.connection.port [j].configured THEN
              CYCLE /controller_loop_2/;
            IFEND;

            upline_connection := controller_definition.controller.connection.port [j];
            IF upline_connection.upline_connection_type <> cmc$data_channel_element THEN
              osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_upline_connection,
                    controller_definition.element_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, upline_connection.element_name,
                    status);
              RETURN;
            IFEND;

            IF upline_connection.mainframe_ownership <> mainframe_id THEN
              CYCLE /controller_loop_2/;
            IFEND;

            element_descriptor.element_type := upline_connection.upline_connection_type;
            element_descriptor.channel_descriptor.name := upline_connection.element_name;
            element_descriptor.channel_descriptor.iou := upline_connection.iou;
            element_descriptor.channel_descriptor.use_logical_identification := TRUE;

            connection_count := connection_count + 1;
            IF connection_count <= UPPERBOUND (connection_list^) THEN
              iou_channel := upline_connection.iou;
              iou_channel (5) := '/';
              iou_channel (6, * ) := upline_connection.element_name;

              connection_list^ [connection_count].upline_element := iou_channel;
              connection_list^ [connection_count].downline_element := controller_definition.element_name;
              cmp$get_connection_status (element_descriptor, controller_definition.element_name,
                    connection_list^ [connection_count].status, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          FOREND /controller_loop_2/;

        = cmc$channel_adapter_element =
          upline_connection := controller_definition.channel_adapter.connection.channel;
          IF upline_connection.upline_connection_type <> cmc$data_channel_element THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_upline_connection,
                  controller_definition.element_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, upline_connection.element_name,
                  status);
            RETURN;
          IFEND;

          element_descriptor.element_type := upline_connection.upline_connection_type;
          element_descriptor.channel_descriptor.name := upline_connection.element_name;
          element_descriptor.channel_descriptor.iou := upline_connection.iou;
          element_descriptor.channel_descriptor.use_logical_identification := TRUE;

          connection_count := connection_count + 1;
          IF connection_count <= UPPERBOUND (connection_list^) THEN
            iou_channel := upline_connection.iou;
            iou_channel (5) := '/';
            iou_channel (6, * ) := upline_connection.element_name;

            connection_list^ [connection_count].upline_element := iou_channel;
            connection_list^ [connection_count].downline_element := controller_definition.element_name;
            cmp$get_connection_status (element_descriptor, controller_definition.element_name,
                  connection_list^ [connection_count].status, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

        ELSE
          osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_upline_connection,
                element_definition.element_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, upline_connection.element_name,
                status);
        CASEND;

        element_descriptor.element_type := controller_definition.element_type;
        element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
        element_descriptor.peripheral_descriptor.element_name := controller_definition.element_name;

        connection_count := connection_count + 1;
        IF connection_count <= UPPERBOUND (connection_list^) THEN
          connection_list^ [connection_count].upline_element := controller_definition.element_name;
          connection_list^ [connection_count].downline_element := element_definition.element_name;
          cmp$get_connection_status (element_descriptor, element_definition.element_name,
                connection_list^ [connection_count].status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND /unit_loop/;

    ELSE
    CASEND;

  PROCEND cmp$get_connection_list;

?? TITLE := '  cmp$get_connection_status', EJECT ??
{
{ PURPOSE:
{   This procedure will return the current status for the connection which includes
{   the specified upline element and downline element.
{

  PROCEDURE [XDCL, #GATE] cmp$get_connection_status
    (    upline_element_descriptor: cmt$element_descriptor;
         downline_element_name: cmt$element_name;
     VAR connection_status: cmt$connection_status;
     VAR status: ost$status);

    VAR
      dummy_reservation: cmt$element_reservation,
      element_name: cmt$element_name,
      i: integer,
      pet_index: integer;

    status.normal := TRUE;

    cmp$search_peripheral_table (upline_element_descriptor, dummy_reservation, FALSE, pet_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE upline_element_descriptor.element_type OF
    = cmc$data_channel_element =
      FOR i := 1 TO UPPERBOUND (cmv$peripheral_element_table.pointer^ [pet_index].physical_descriptor.
            channel_connection^) DO
        IF cmv$peripheral_element_table.pointer^ [pet_index].physical_descriptor.channel_connection^ [i].
              downline_element = downline_element_name THEN
          connection_status := cmv$peripheral_element_table.pointer^ [pet_index].physical_descriptor.
                channel_connection^ [i].status;
          RETURN;
        IFEND;
      FOREND;

      IF upline_element_descriptor.channel_descriptor.use_logical_identification THEN
        element_name := upline_element_descriptor.channel_descriptor.name;
      ELSE
        element_name := osc$null_name;
      IFEND;
      osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_downline_connection,
            element_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, downline_element_name, status);
      RETURN;

    = cmc$controller_element, cmc$channel_adapter_element =
      FOR i := 1 TO UPPERBOUND (cmv$peripheral_element_table.pointer^ [pet_index].physical_descriptor.
            equipment_connection^) DO
        IF cmv$peripheral_element_table.pointer^ [pet_index].physical_descriptor.equipment_connection^ [i].
              downline_element = downline_element_name THEN
          connection_status := cmv$peripheral_element_table.pointer^ [pet_index].physical_descriptor.
                equipment_connection^ [i].status;
          RETURN;
        IFEND;
      FOREND;

      IF upline_element_descriptor.peripheral_descriptor.use_logical_identification THEN
        element_name := upline_element_descriptor.peripheral_descriptor.element_name;
      ELSE
        element_name := osc$null_name;
      IFEND;
      osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_downline_connection,
            element_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, downline_element_name, status);
      RETURN;

    = cmc$communications_element, cmc$external_processor_element, cmc$storage_device_element =
      IF upline_element_descriptor.peripheral_descriptor.use_logical_identification THEN
        element_name := upline_element_descriptor.peripheral_descriptor.element_name;
      ELSE
        element_name := osc$null_name;
      IFEND;
      osp$set_status_abnormal (cmc$configuration_management_id, cme$unsupported_connection,
            element_name, status);
      RETURN;
    ELSE
    CASEND;

  PROCEND cmp$get_connection_status;

?? TITLE := '  cmp$get_hydra_connection_list', EJECT ??
{
{ PURPOSE:
{   This procedure will return an array that contains connection information for
{   every connection in every path that contains the specified HYDRA mass storage
{   element.  The connection information includes the upline element name, the
{   downline element name and the connection status.  The connection count will
{   return the number of connections found.  If the array supplied was not large
{   enough to hold all connections found this value can be used to allocate an
{   array of the proper size before calling this procedure again.
{

  PROCEDURE cmp$get_hydra_connection_list
    (    element_definition: cmt$element_definition;
     VAR connection_count: integer;
     VAR connection_list: ^array [1 .. * ] of cmt$connection;
     VAR status: ost$status);

    VAR
      element_descriptor: cmt$element_descriptor,
      i: integer,
      iou_channel: cmt$element_name,
      upline_connection: cmt$upline_connection;

    connection_count := 0;
    status.normal := TRUE;

    FOR i := LOWERVALUE (cmt$data_storage_port_number) TO UPPERVALUE (cmt$data_storage_port_number) DO
      IF element_definition.storage_device.connection.port [i].configured THEN
        upline_connection := element_definition.storage_device.connection.port [i];

        IF upline_connection.upline_connection_type <> cmc$data_channel_element THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_upline_connection,
                element_definition.element_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, upline_connection.element_name,
                status);
          RETURN;
        IFEND;

        element_descriptor.element_type := upline_connection.upline_connection_type;
        element_descriptor.channel_descriptor.name := upline_connection.element_name;
        element_descriptor.channel_descriptor.iou := upline_connection.iou;
        element_descriptor.channel_descriptor.use_logical_identification := TRUE;

        connection_count := connection_count + 1;
        IF connection_count <= UPPERBOUND (connection_list^) THEN
          iou_channel := upline_connection.iou;
          iou_channel (5) := '/';
          iou_channel (6, * ) := upline_connection.element_name;

          connection_list^ [connection_count].upline_element := iou_channel;
          connection_list^ [connection_count].downline_element := element_definition.element_name;
          cmp$get_connection_status (element_descriptor, element_definition.element_name,
                connection_list^ [connection_count].status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    FOREND;
  PROCEND cmp$get_hydra_connection_list;

?? TITLE := '  cmp$locate_disabled_connection', EJECT ??

{
{ PURPOSE:
{   This procedure will search all downline and upline connections of the
{   specified element for a disabled connection.  If a connection_status
{    of CMC$DISABLED is found the parameter disabled_connection_exists will
{    be set to TRUE, otherwise it will be set to FALSE.

  PROCEDURE [XDCL, #GATE] cmp$locate_disabled_connection
    (    element_definition: cmt$element_definition;
     VAR disabled_connection_exists: boolean;
     VAR status: ost$status);

    VAR
      connection_status: cmt$connection_status,
      dummy_reservation: cmt$element_reservation,
      element_descriptor: cmt$element_descriptor,
      i: integer,
      j: integer,
      mainframe_id: pmt$mainframe_id,
      pet_entry_p: ^cmt$peripheral_element_entry,
      pet_index: integer,
      upline_connection: cmt$upline_connection;

    status.normal := TRUE;
    disabled_connection_exists := FALSE;

    pmp$get_mainframe_id (mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE element_definition.element_type OF
    = cmc$data_channel_element =
      {
      { Find the channel in the peripheral_element table.
      {
      element_descriptor.element_type := element_definition.element_type;
      element_descriptor.channel_descriptor.iou := element_definition.data_channel.iou;
      element_descriptor.channel_descriptor.use_logical_identification := TRUE;
      element_descriptor.channel_descriptor.name := element_definition.element_name;
      cmp$search_peripheral_table (element_descriptor, dummy_reservation, FALSE, pet_index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      pet_entry_p := ^cmv$peripheral_element_table.pointer^ [pet_index];

      FOR i := 1 TO UPPERBOUND (pet_entry_p^.physical_descriptor.channel_connection^) DO
        IF pet_entry_p^.physical_descriptor.channel_connection^ [i].status = cmc$disabled THEN
          disabled_connection_exists := TRUE;
          RETURN;
        IFEND;
      FOREND;

    = cmc$communications_element =

    /equipment_loop_1/
      FOR i := LOWERVALUE (cmt$communications_port_number) TO UPPERVALUE (cmt$communications_port_number) DO
        IF NOT element_definition.communications_element.connection.port [i].configured THEN
          CYCLE /equipment_loop_1/;
        IFEND;

        upline_connection := element_definition.communications_element.connection.port [i];
        IF upline_connection.upline_connection_type <> cmc$data_channel_element THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_upline_connection,
                element_definition.element_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, upline_connection.element_name,
                status);
          RETURN;
        IFEND;

        IF upline_connection.mainframe_ownership <> mainframe_id THEN
          CYCLE /equipment_loop_1/
        IFEND;

        element_descriptor.element_type := upline_connection.upline_connection_type;
        element_descriptor.channel_descriptor.name := upline_connection.element_name;
        element_descriptor.channel_descriptor.iou := upline_connection.iou;
        element_descriptor.channel_descriptor.use_logical_identification := TRUE;

        cmp$get_connection_status (element_descriptor, element_definition.element_name, connection_status,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF connection_status = cmc$disabled THEN
          disabled_connection_exists := TRUE;
        IFEND;

      FOREND /equipment_loop_1/;

    = cmc$external_processor_element =
    /ext_proc_loop/
      FOR i := LOWERVALUE (cmt$physical_equipment_number) TO UPPERVALUE (cmt$physical_equipment_number) DO
        IF NOT element_definition.external_processor.connection.io_port [i].configured THEN
          CYCLE /ext_proc_loop/;
        IFEND;

        upline_connection := element_definition.external_processor.connection.io_port [i];
        IF upline_connection.upline_connection_type <> cmc$data_channel_element THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_upline_connection,
                element_definition.element_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, upline_connection.element_name,
                status);
          RETURN;
        IFEND;

        element_descriptor.element_type := upline_connection.upline_connection_type;
        element_descriptor.channel_descriptor.name := upline_connection.element_name;
        element_descriptor.channel_descriptor.iou := upline_connection.iou;
        element_descriptor.channel_descriptor.use_logical_identification := TRUE;

        cmp$get_connection_status (element_descriptor, element_definition.element_name, connection_status,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF connection_status = cmc$disabled THEN
          disabled_connection_exists := TRUE;
        IFEND;
      FOREND;

    = cmc$controller_element =
      element_descriptor.element_type := element_definition.element_type;
      element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
      element_descriptor.peripheral_descriptor.element_name := element_definition.element_name;
      cmp$search_peripheral_table (element_descriptor, dummy_reservation, FALSE, pet_index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      pet_entry_p := ^cmv$peripheral_element_table.pointer^ [pet_index];

      FOR i := 1 TO UPPERBOUND (pet_entry_p^.physical_descriptor.equipment_connection^) DO
        IF pet_entry_p^.physical_descriptor.equipment_connection^ [i].status = cmc$disabled THEN
          disabled_connection_exists := TRUE;
          RETURN;
        IFEND;
      FOREND;

    = cmc$channel_adapter_element =
      IF element_definition.channel_adapter.connection.channel.configured THEN
        upline_connection := element_definition.channel_adapter.connection.channel;
        IF upline_connection.upline_connection_type <> cmc$data_channel_element THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_upline_connection,
                element_definition.element_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, upline_connection.element_name,
                status);
          RETURN;
        IFEND;

        element_descriptor.element_type := upline_connection.upline_connection_type;
        element_descriptor.channel_descriptor.name := upline_connection.element_name;
        element_descriptor.channel_descriptor.iou := upline_connection.iou;
        element_descriptor.channel_descriptor.use_logical_identification := TRUE;

        cmp$get_connection_status (element_descriptor, element_definition.element_name, connection_status,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF connection_status = cmc$disabled THEN
          disabled_connection_exists := TRUE;
        IFEND;
      IFEND;

      element_descriptor.element_type := element_definition.element_type;
      element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
      element_descriptor.peripheral_descriptor.element_name := element_definition.element_name;

      cmp$search_peripheral_table (element_descriptor, dummy_reservation, FALSE, pet_index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      pet_entry_p := ^cmv$peripheral_element_table.pointer^ [pet_index];

      FOR i := 1 TO UPPERBOUND (pet_entry_p^.physical_descriptor.equipment_connection^) DO
        IF pet_entry_p^.physical_descriptor.equipment_connection^ [i].status = cmc$disabled THEN
          disabled_connection_exists := TRUE;
          RETURN;
        IFEND;
      FOREND;

    = cmc$storage_device_element =

    /unit_loop/
      FOR i := LOWERVALUE (cmt$data_storage_port_number) TO UPPERVALUE (cmt$data_storage_port_number) DO
        IF NOT element_definition.storage_device.connection.port [i].configured THEN
          CYCLE /unit_loop/;
        IFEND;

        upline_connection := element_definition.storage_device.connection.port [i];

        element_descriptor.element_type := upline_connection.upline_connection_type;
        CASE upline_connection.upline_connection_type OF
        = cmc$data_channel_element =
          element_descriptor.channel_descriptor.iou := upline_connection.iou;
          element_descriptor.channel_descriptor.use_logical_identification := TRUE;
          element_descriptor.channel_descriptor.name := upline_connection.element_name;

        = cmc$controller_element, cmc$channel_adapter_element =
          element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
          element_descriptor.peripheral_descriptor.element_name := upline_connection.element_name;
        ELSE
        CASEND;

        cmp$get_connection_status (element_descriptor, element_definition.element_name, connection_status,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF connection_status = cmc$disabled THEN
          disabled_connection_exists := TRUE;
        IFEND;

      FOREND /unit_loop/;

    ELSE
    CASEND;

  PROCEND cmp$locate_disabled_connection;

MODEND cmm$connection_manager;
*DECK DECK=CMM$DISPLAY_ACTIVE_VOLUMES EXPAND=TRUE
PROCEDURE display_active_volumes, disav (
  output, o: file = $output
  relevant_classes, rc: any of
      key
        all
        (site_reserved_classes, src)
        (system_defined_classes, sdc)
      keyend
      list of name 1..1
    anyend = osd$disav_relevant_classes, system_defined_classes
  sets, set, s: any of
      key
        all
      keyend
      list of name
    anyend = all
  volumes, volume, v: any of
      key
        all
        (available_volumes, available_volume, av)
        (unavailable_volumes, unavailable_volume, uv)
      keyend
      list of name 1..6
    anyend = all
  status)

  LOGICAL_CONFIGURATION_UTILITY
    VAR
      classes: list of list of any
      displayed_classes : list of name 1 = ()
      copf_status: status
      ignore_status: status
      line: string 110
      local_rvsn: string 6 = '      '
      out: file = $unique($local)
      relevant_line_displayed: boolean = false
    VAREND

    IF $generic_type(relevant_classes) = key THEN
      IF relevant_classes = all THEN
        class_string = 'abcdefghijklmnopqrstuvwxyz'
      ELSEIF relevant_classes = site_reserved_classes THEN
        class_string = 'uvwxyz'
      ELSEIF relevant_classes = system_defined_classes THEN
        class_string = 'cjklmnpq'
      IFEND
      "Construct list of class names to avoid parameter alias substitution"
      FOR index = $size(class_string) TO 1 BY -1 DO
        displayed_classes = $add($name($substring(class_string, index)), displayed_classes)
      FOREND
    ELSE
      displayed_classes = relevant_classes
    IFEND

" $ADD addes an element to the front of a list - first reverse the list"
    temp_classes = $reverse(displayed_classes)
    classes = $list_of($mass_storage_class_members(temp_classes(1)))
    FOR i = 2 TO $size(displayed_classes) DO
      classes = $add($mass_storage_class_members(temp_classes(i)) classes)
    FOREND

    IF $generic_type(sets) = key THEN
      active_sets = $active_sets
    ELSE
      active_sets = sets
    IFEND

    FOR EACH set IN $sort(active_sets) DO
      displaying_by_set = true
      VAR
        active_volumes: list of any = ()
      VAREND
      IF $generic_type(volumes) = key "ALL" THEN
        IF volumes = all THEN
          active_volumes = $active_set_members(set)
          criterion = 'active '
        ELSEIF volumes = available_volumes THEN
          active_volumes = $select($active_set_members(set), x.volume_available)
          criterion = 'available '
        ELSE "volumes=unavailable_volumes"
          active_volumes = $select($active_set_members(set), (NOT x.volume_available))
          criterion = 'unavailable '
        IFEND
      ELSE
        FOR EACH volume IN volumes DO
          active_volumes = $join($select($active_set_members(set) x.recorded_vsn=volume), active_volumes)
        FOREND
        criterion = 'active '
        displaying_by_set = false
      IFEND

      displayed_volumes = $intersection(active_volumes, $active_set_members(set))
      IF $nil(displayed_volumes) THEN
        IF displaying_by_set THEN
COLLECT_TEXT output=out.$eoi sm='?'

 SET: ?$string(set)? has no ?criterion?volumes.

**
          relevant_line_displayed = true
        IFEND
      ELSE
        IF displaying_by_set THEN
COLLECT_TEXT output=out.$eoi sm='?'

 SET: ?$string(set)? has ?$size(displayed_volumes)? ?criterion?volume(s).

   VSN    Element Name                     Type         Relevant Classes

**
        ELSE
COLLECT_TEXT output=out.$eoi sm='?'

  SET: ?$string(set)? has the following ?criterion?volume(s).

   VSN    Element Name                     Type         Relevant Classes

**
        IFEND
        FOR EACH vsn IN $sort(displayed_volumes, x1.recorded_vsn<=x2.recorded_vsn) DO
          local_rvsn = $string(vsn.recorded_vsn)
          line = '   ' // local_rvsn // ' ' // vsn.element_name
          line = line(1, 42) // $element(vsn.element_name element_identification)
          j = 56
          FOR k =1 TO $size(displayed_classes) DO
            IF NOT $nil($select(classes(k) x.recorded_vsn=vsn.recorded_vsn)) THEN
              line = line(1, j)//displayed_classes(k)
              relevant_line_displayed = true
            IFEND
            j = j+2
          FOREND
          put_line $trim(line, ' ', trailing) o=out.$eoi
        FOREND
      IFEND
      delete_variable (active_volumes, criterion, displayed_volumes, local_rvsn) status=ignore_status
    FOREND
    IF relevant_line_displayed THEN
      copy_file i=out o=output status=copf_status
    IFEND
    delete_file out status=ignore_status
    EXIT procedure WHEN ((NOT relevant_line_displayed) OR (NOT copf_status.normal)) with $status(false, ..
          'US', 999, ..
          ' No volumes match the criteria defined by the RELEVANT_CLASSES, SETS, and VOLUMES parameters.')
  QUIT


PROCEND display_active_volumes
*DECK DECK=CMM$JOB_TEMPLATE_DEADSTART EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE CM : Job Template Deadstart', ??
MODULE cmm$job_template_deadstart;

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc clt$command_table
*copyc clt$function_processor_table
*copyc cmc$logical_conf_dev_file_name
*copyc cmc$logical_unit_constants
*copyc cme$access_device_files
*copyc cme$job_template_deadstart
*copyc cme$logical_configuration_mgr
*copyc cme$logical_configuration_utl
*copyc cmc$physical_conf_dev_file_name
*copyc cme$physical_configuration_mgr
*copyc cme$reserve_element
*copyc cmk$keypoints
*copyc cml$ms_volume_initialization
*copyc cmt$cpu_element_definition
*copyc cmt$element_capability
*copyc cmt$element_information
*copyc dmt$active_volume_table_index
*copyc dmt$error_condition_codes
*copyc dst$log_ms_volume_init
*copyc nat$network_descriptor
*copyc ofe$error_codes
*copyc oss$job_paged_literal
*copyc oss$mainframe_paged_literal
*copyc oss$task_private
*copyc oss$task_shared
*copyc ost$caller_identifier
*copyc rmd$volume_declarations
*copyc rmt$device_class
*copyc stt$number_of_members
*copyc stt$volume_info
*copyc stt$volume_list
?? POP ??
*copyc amp$close
*copyc amp$open
*copyc amp$put_next
*copyc amp$return
*copyc avp$configuration_administrator
*copyc avp$removable_media_operator
*copyc avp$system_displays
*copyc avp$system_operator
*copyc clp$trimmed_string_size
*copyc cmp$get_controller_type
*copyc cmp$get_cpu_element_r1
*copyc cmp$get_element_name_via_lun
*copyc cmp$get_element_definition
*copyc cmp$get_iou_definition
*copyc cmp$get_logical_unit_number
*copyc cmp$get_logical_unit_state
*copyc cmp$get_mainframe_element
*copyc cmp$get_unit_type
*copyc cmp$lock_set_by_task
*copyc cmp$manage_lcu_lock
*copyc cmp$pc_get_element
*copyc cmp$pc_get_logical_unit
*copyc cmp$process_cpu_state_change_r1
*copyc dmp$process_das_restore
*copyc cmp$search_peripheral_table
*copyc dmp$change_volume_attributes
*copyc dmp$activate_volume
*copyc dmp$add_class_to_volume
*copyc dmp$add_to_sorted_dfl
*copyc dmp$get_logical_attributes
*copyc dmp$get_logical_unit_number
*copyc dmp$get_physical_attributes
*copyc dmp$get_volume_attributes
*copyc dmp$initialize_ms_volume
*copyc dmp$process_force_format
*copyc dmp$volume_online
*copyc dsp$log_system_message
*copyc fsp$copy_file
*copyc osp$append_status_parameter
*copyc i#call_monitor
*copyc osp$append_status_parameter
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$get_mainframe_id
*copyc pmp$get_unique_name
*copyc stp$get_active_volume_list
?? EJECT ??
*copyc tmt$rb_update_job_task_enviro
*copyc cmv$controller_data
*copyc cmv$logical_unit_table
*copyc cmv$peripheral_element_table
*copyc cmv$physical_configuration
*copyc cmv$state_info_table
*copyc dmv$active_volume_table
*copyc dmv$system_device_information
*copyc mtv$cst0
*copyc osv$deadstart_phase
*copyc osv$cpus_logically_on
*copyc osv$cpus_physically_configured
*copyc osv$task_private_heap
*copyc syv$mandatory_dualstate
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  TYPE
    cmt$mass_storage_volume = RECORD
      recorded_vsn: rmt$recorded_vsn,
      class: dmt$class,
      lun: iot$logical_unit,
      on_and_enabled: boolean,
      changed: boolean,
      write_status: ost$status,
    RECEND;

  VAR
    cmv$error_count: [XDCL, #GATE, oss$task_private] integer := 0,
    cmv$lcu_command_list: [XDCL, #GATE] ^clt$command_table := NIL,
    cmv$lcu_function_list: [XDCL, #GATE] ^clt$function_processor_table := NIL,
    cmv$network_descriptor_p: [XDCL, #GATE, oss$task_private] ^nat$network_descriptor := NIL,
    cmv$semantic_error_file_name: amt$local_file_name,
    cmv$semantic_fid: amt$file_identifier,
    cmv$syntax_error_file_name: amt$local_file_name,
    cmv$syntax_fid: amt$file_identifier;

?? NOCOMPILE ??
  VAR
    debug_control: clt$display_control,
    debug_status: ost$status;
?? COMPILE ??

?? TITLE := 'cmp$hide_commands', EJECT ??

{ PURPOSE:
{   This procedure is used to hide commands that the user would not be able to use because of the user's
{   authority.
{ NOTES:
{   Any form of the command name may be passed to this routine and all forms of that command will be hidden.

    PROCEDURE [XDCL, #GATE] cmp$hide_commands
      (lcu_command_list: ^clt$command_table;
       lcu_function_list: ^clt$function_processor_table);

?? NEWTITLE := 'change_command_availability', EJECT ??

{ PURPOSE:
{   This procedure changes the availability entry for the specified command.
{ NOTES:
{   Any form of the command name may be passed to this routine and all forms of that command will be hidden.

      PROCEDURE change_command_availability
        (    command_name: string ( * <= osc$max_name_size);
             availability: clt$named_entry_availability;
         VAR command_table: ^clt$command_table);

        VAR
          command_ordinal: clt$named_entry_ordinal,
          index: integer;

      /find_command_ordinal/
        BEGIN
          FOR index := LOWERBOUND (command_table^) TO UPPERBOUND (command_table^) DO
            IF command_table^ [index].name = command_name THEN
              command_ordinal := command_table^ [index].ordinal;
              EXIT /find_command_ordinal/;
            IFEND;
          FOREND;
          RETURN;
        END /find_command_ordinal/;

        FOR index := LOWERBOUND (command_table^) TO UPPERBOUND (command_table^) DO
          IF command_table^ [index].ordinal = command_ordinal THEN
            command_table^ [index].availability := availability;
          IFEND;
        FOREND;

      PROCEND change_command_availability;


?? OLDTITLE, EJECT ??

      VAR
        i: integer,
        configuration_administrator: boolean,
        removable_media_operation: boolean,
        system_displays: boolean,
        system_operation: boolean;


      IF cmv$lcu_command_list = NIL THEN
        ALLOCATE cmv$lcu_command_list: [LOWERBOUND (lcu_command_list^) ..
              UPPERBOUND (lcu_command_list^)] IN osv$task_private_heap^;
        FOR i := LOWERBOUND (lcu_command_list^) TO UPPERBOUND (lcu_command_list^) DO
          cmv$lcu_command_list^ [i] := lcu_command_list^ [i];
        FOREND;
      IFEND;
      IF cmv$lcu_function_list = NIL THEN
        ALLOCATE cmv$lcu_function_list: [LOWERBOUND (lcu_function_list^) ..
              UPPERBOUND (lcu_function_list^)] IN osv$task_private_heap^;
        FOR i := LOWERBOUND (lcu_function_list^) TO UPPERBOUND (lcu_function_list^) DO
          cmv$lcu_function_list^ [i] := lcu_function_list^ [i];
        FOREND;
      IFEND;

      configuration_administrator := avp$configuration_administrator ();
      removable_media_operation := avp$removable_media_operator ();
      system_displays := avp$system_displays ();
      system_operation := avp$system_operator ();

{ Hide the commands that the user would not be able to use anyway.

      IF configuration_administrator THEN
        RETURN; {All commands are available to configuration administration user}
      IFEND;

      IF system_displays OR removable_media_operation OR
              system_operation THEN
        change_command_availability ('ADD_VOLUME_TO_SET', clc$hidden_entry, cmv$lcu_command_list);
        change_command_availability ('CHANGE_MS_CLASS', clc$hidden_entry, cmv$lcu_command_list);
        change_command_availability ('CHANGE_MS_VOLUME', clc$hidden_entry, cmv$lcu_command_list);
        change_command_availability ('CREATE_SET', clc$hidden_entry, cmv$lcu_command_list);
        change_command_availability ('DEFINE_MS_FLAW', clc$hidden_entry, cmv$lcu_command_list);
        change_command_availability ('INITIALIZE_MS_VOLUME', clc$hidden_entry, cmv$lcu_command_list);
        change_command_availability ('INSTALL_NETWORK_CONFIGURATION', clc$hidden_entry,
             cmv$lcu_command_list);
        change_command_availability ('REMOVE_MS_FLAW', clc$hidden_entry, cmv$lcu_command_list);

        IF NOT (removable_media_operation OR system_operation) THEN
          change_command_availability ('CHANGE_ELEMENT_STATE', clc$hidden_entry, cmv$lcu_command_list);
        IFEND;
        RETURN;
      IFEND;

 { If control gets here user is not validated for any SOU capability.

      change_command_availability ('ADD_VOLUME_TO_SET', clc$hidden_entry, cmv$lcu_command_list);
      change_command_availability ('CHANGE_ELEMENT_STATE', clc$hidden_entry, cmv$lcu_command_list);
      change_command_availability ('CHANGE_MS_CLASS', clc$hidden_entry, cmv$lcu_command_list);
      change_command_availability ('CHANGE_MS_VOLUME', clc$hidden_entry, cmv$lcu_command_list);
      change_command_availability ('CREATE_SET', clc$hidden_entry, cmv$lcu_command_list);
      change_command_availability ('DEFINE_MS_FLAW', clc$hidden_entry, cmv$lcu_command_list);
      change_command_availability ('DISPLAY_MAINFRAME_CONFIGURATION', clc$hidden_entry, cmv$lcu_command_list);
      change_command_availability ('DISPLAY_MS_CLASS', clc$hidden_entry, cmv$lcu_command_list);
      change_command_availability ('DISPLAY_MS_FLAW', clc$hidden_entry, cmv$lcu_command_list);
      change_command_availability ('DISPLAY_MS_VOLUME', clc$hidden_entry, cmv$lcu_command_list);
      change_command_availability ('DISPLAY_NETWORK_CONFIGURATION', clc$hidden_entry, cmv$lcu_command_list);
      change_command_availability ('DISPLAY_PROCESSOR_STATE', clc$hidden_entry, cmv$lcu_command_list);
      change_command_availability ('INITIALIZE_MS_VOLUME', clc$hidden_entry, cmv$lcu_command_list);
      change_command_availability ('INSTALL_NETWORK_CONFIGURATION', clc$hidden_entry, cmv$lcu_command_list);
      change_command_availability ('REMOVE_MS_FLAW', clc$hidden_entry, cmv$lcu_command_list);

      IF cmv$lcu_function_list <> NIL THEN
        FREE cmv$lcu_function_list IN osv$task_private_heap^;
        cmv$lcu_function_list := NIL;
      IFEND;

    PROCEND cmp$hide_commands;

?? TITLE := '   cmp$free_command_list', EJECT ??

{ PURPOSE:
{   This procedure frees command list space upon exiting LCU.

   PROCEDURE [XDCL, #GATE] cmp$free_command_list;
     IF cmv$lcu_command_list <> NIL THEN
       FREE cmv$lcu_command_list IN osv$task_private_heap^;
     IFEND;
     IF cmv$lcu_function_list <> NIL THEN
       FREE cmv$lcu_function_list IN osv$task_private_heap^;
     IFEND;
  PROCEND cmp$free_command_list;


?? TITLE := '   cmp$manage_lock_r3', EJECT ??

{ PURPOSE :
{   Ring 3 routine to set and clear lock for serialization of
{   LCU subcommands.

  PROCEDURE [XDCL, #GATE]  cmp$manage_lock_r3
    (    lock_type: cmt$lcu_lock_type;
         clear_lock: boolean;
         job_name: jmt$system_supplied_name;
     VAR status: ost$status);

    IF NOT (avp$configuration_administrator () OR avp$removable_media_operator ()
              OR avp$system_operator ()) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_ring_validation_error,
            'CMP$MANAGE_LOCK_R3', status);
      RETURN;
    IFEND;
    cmp$manage_lcu_lock (lock_type, clear_lock, job_name, status);

  PROCEND cmp$manage_lock_r3;

?? TITLE := '   cmp$lock_set_by_current_task', EJECT ??

  FUNCTION [XDCL, #GATE, UNSAFE] cmp$lock_set_by_current_task (
      lock_type: cmt$lcu_lock_type): BOOLEAN;

     cmp$lock_set_by_current_task := cmp$lock_set_by_task (lock_type);

  FUNCEND cmp$lock_set_by_current_task;

?? TITLE := '   cmp$determine_tape_element', EJECT ??

{ PURPOSE:
{   This procedure determines whether or not the given element
{   descriptor is a tape element.

  PROCEDURE [XDCL, #GATE] cmp$determine_tape_element
    (    element: cmt$element_descriptor;
     VAR tape_element: boolean);

    VAR
      element_p: ^cmt$element_definition,
      controller_type: cmt$controller_type,
      definition: cmt$element_definition,
      dummy_iou: cmt$element_name,
      found: boolean,
      io_unit_type: iot$unit_type,
      pen: cmt$physical_equipment_number,
      pun: cmt$physical_unit_number,
      status: ost$status,
      unit_class: cmt$unit_class,
      unit_type: cmt$unit_type;

    tape_element := FALSE;
    cmp$get_element_definition (element, definition, status);
    CASE definition.element_type OF
    = cmc$data_channel_element =
      FOR pen := LOWERVALUE (cmt$physical_equipment_number) TO UPPERVALUE
                    (cmt$physical_equipment_number) DO
        IF definition.data_channel.connection.equipment [pen].configured THEN
          cmp$pc_get_element (definition.data_channel.connection.equipment [pen].element_name,
                   dummy_iou, element_p, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          cmp$get_controller_type (element_p^.product_id, controller_type, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          tape_element := (controller_type = cmc$mt7021_3x) OR (controller_type =
                cmc$mt7021_4x) OR (controller_type = cmc$mt7221_1) OR (controller_type
                = cmc$mt7221_2_s0) OR (controller_type = cmc$mt698_xx);
          RETURN;
        IFEND;
      FOREND;
    = cmc$controller_element =
      cmp$get_controller_type (definition.product_id, controller_type, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      tape_element := (controller_type = cmc$mt7021_3x) OR (controller_type =
             cmc$mt7021_4x) OR (controller_type = cmc$mt7221_1) OR (controller_type
             = cmc$mt7221_2_s0) OR (controller_type = cmc$mt698_xx) OR (controller_type =
             cmc$mt5680_xx);
    = cmc$storage_device_element =
      cmp$get_unit_type (definition.product_id, unit_type, io_unit_type, unit_class, found);
      tape_element := unit_class = cmc$magnetic_tape_unit;
    ELSE
      ;
    CASEND;
  PROCEND cmp$determine_tape_element;

?? TITLE := '    cmp$open_scratch_err_file',EJECT ??

   PROCEDURE [XDCL, #GATE] cmp$open_scratch_err_file (
       VAR status: ost$status);

     pmp$get_unique_name (cmv$syntax_error_file_name, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

     amp$open (cmv$syntax_error_file_name, amc$record, NIL,
          cmv$syntax_fid, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;
     pmp$get_unique_name (cmv$semantic_error_file_name, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;
     amp$open (cmv$semantic_error_file_name, amc$record, NIL,
          cmv$semantic_fid, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

  PROCEND cmp$open_scratch_err_file;

?? TITLE := '    cmp$echo_command ',EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$echo_command (
         command_line: ost$string;
     VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address;

      amp$put_next (cmv$syntax_fid, #LOC (command_line.value), command_line.size,
            byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

   PROCEND cmp$echo_command;

?? TITLE := '    cmp$echo_errors', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$echo_errors
    (    syntax_error: boolean;
         status_echoed: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      length: integer,
      line_count: ost$status_message_line_count,
      local_status: ost$status,
      output_str: string (255),
      p_line_count: ^ost$status_message_line_count,
      p_line_size: ^ost$status_message_line_size,
      p_message: ^ost$status_message,
      p_message_line: ^string ( * ),
      str: ost$string;

      cmv$error_count := cmv$error_count + 1;
      PUSH p_message;
      osp$format_message (status_echoed, osc$full_message_level, osc$max_string_size,
            p_message^, local_status);
      IF NOT local_status.normal THEN
        RETURN;
      IFEND;
      RESET p_message;
      NEXT p_line_count IN p_message;
      FOR line_count := 1 TO p_line_count^ DO
        NEXT p_line_size IN p_message;
        NEXT p_message_line: [p_line_size^] IN p_message;
        IF syntax_error THEN

          amp$put_next (cmv$syntax_fid, #LOC (p_message_line^), #SIZE(p_message_line^),
            byte_address, local_status);
        ELSE
          amp$put_next (cmv$semantic_fid, #LOC (p_message_line^), #SIZE(p_message_line^),
            byte_address, local_status);

        IFEND;
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;

      FOREND;

  PROCEND cmp$echo_errors;

?? TITLE := '    cmp$generate_error_listing',EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$generate_error_listing
    (    error_file_name: amt$local_file_name;
     VAR status: ost$status);

    VAR
      creation_attr: array [1 .. 1] of fst$file_cycle_attribute,
      local_status: ost$status,
      temp_error_file: string (osc$max_name_size + 5);

    status.normal := TRUE;
    amp$close (cmv$syntax_fid, local_status);
    amp$close (cmv$semantic_fid, local_status);
    creation_attr [1].selector := fsc$ring_attributes;
    creation_attr [1].ring_attributes.r1 := osc$user_ring;
    creation_attr [1].ring_attributes.r2 := osc$user_ring;
    creation_attr [1].ring_attributes.r3 := osc$user_ring;
    fsp$copy_file (cmv$syntax_error_file_name, error_file_name, NIL, ^creation_attr,
             ^creation_attr,  status);
    IF NOT status.normal THEN
      IF status.condition = fse$empty_input_file THEN
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;
    temp_error_file := error_file_name;
    temp_error_file (clp$trimmed_string_size (error_file_name)+1, *) := '.$EOI';
    fsp$copy_file (cmv$semantic_error_file_name, temp_error_file, NIL, ^creation_attr,
        ^creation_attr, status);
    IF NOT status.normal THEN
      IF status.condition = fse$empty_input_file THEN
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

  PROCEND cmp$generate_error_listing;

?? TITLE := '    cmp$clean_up_error_count',EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$clean_up_error_count;

      VAR
        local_status: ost$status;

      amp$close (cmv$syntax_fid, local_status);
      amp$close (cmv$semantic_fid, local_status);
      amp$return (cmv$syntax_error_file_name, local_status);
      amp$return (cmv$semantic_error_file_name, local_status);

      cmv$error_count := 0;

  PROCEND cmp$clean_up_error_count;

?? TITLE := '    cmp$clean_up_network_list', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$clean_up_network_list
    (VAR status: ost$status);

    VAR
      next_pointer: ^nat$network_descriptor,
      pointer: ^nat$network_descriptor;

    status.normal := TRUE;
    IF cmv$network_descriptor_p = NIL THEN
      RETURN;
    IFEND;
    pointer := cmv$network_descriptor_p;

{ Go thru the list and free all pointers allocated in task private heap }

    WHILE pointer <> NIL DO
      next_pointer := pointer^.next_descriptor;

      FREE pointer IN osv$task_private_heap^;
      pointer := next_pointer;
    WHILEND;
    cmv$network_descriptor_p := NIL;
  PROCEND cmp$clean_up_network_list;

?? TITLE := '    cmp$form_network_list', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$form_network_list
    (VAR network_descriptor: ^nat$network_descriptor;
     VAR status: ost$status);

      VAR
        cpn: cmt$communications_port_number,
        current_p: ^nat$network_descriptor,
        element_descriptor: cmt$element_descriptor,
        element_reservation: cmt$element_reservation,
        element_type: cmt$element_type,
        iou_definition: cmt$iou_definition,
        iou_name: cmt$element_name,
        mainframe_id: pmt$mainframe_id,
        pc_index_1: integer,
        pc_index_2: integer,
        peripheral_index: integer,
        previous_p: ^^nat$network_descriptor,
        temp_pointer: ^nat$network_descriptor;

  { At this time there is no user heap in ring 11.  Therefore this procedure must be in ring 3 in order to
  { keep a head of list global.  After a call to INSTALL_NETWORK_CONFIGURATION the list must be cleared.

      ALLOCATE temp_pointer IN osv$task_private_heap^;

  /main_program/
    BEGIN
      IF network_descriptor <> NIL THEN
        temp_pointer^ := network_descriptor^;
        IF network_descriptor^.kind = nac$network_device THEN

{ Verify element names in network_descriptor if they are in peripheral table.

          iou_name := 'IOU0';
          cmp$get_element_type (network_descriptor^.access.element, iou_name, element_type, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          iou_name := 'IOU0';
          cmp$get_iou_definition (iou_name, iou_definition, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          element_descriptor.element_type := element_type;
          IF element_type = cmc$data_channel_element THEN
            element_descriptor.channel_descriptor.iou := iou_name;
            element_descriptor.channel_descriptor.name := network_descriptor^.access.element;
          ELSE
            element_descriptor.peripheral_descriptor.element_name := network_descriptor^.access.element;
          IFEND;
          cmp$search_peripheral_table (element_descriptor, element_reservation, FALSE, peripheral_index,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Should return abnormal status if channel and channel_address NOT found.

          CASE element_type OF

          = cmc$channel_adapter_element =
            IF (cmv$peripheral_element_table.
                pointer ^[peripheral_index].product_id.product_number = ' $2629') AND
                (cmv$peripheral_element_table.
                     pointer ^[peripheral_index].product_id.model_number = '2   ') THEN
              IF temp_pointer^.system_identifier <> 0 THEN
                temp_pointer^.device_type := nac$ica_2;
                temp_pointer^.driver_name := 'ICAD';
              ELSE
                osp$set_status_condition (cme$jtd_ica2_requires_system_id, status);
                EXIT /main_program/;
              IFEND;
            ELSE
              osp$set_status_abnormal (cmc$configuration_management_id,
                   cme$jtd_invalid_element_type, network_descriptor^.access.element, status);
              EXIT /main_program/;
            IFEND;

            /loop_ica/
            FOR pc_index_1 := 1 TO UPPERBOUND (cmv$physical_configuration^) DO
              IF (cmv$physical_configuration^ [pc_index_1].element_type = cmc$channel_adapter_element)
                 AND (cmv$physical_configuration^ [pc_index_1].element_name =
                          element_descriptor.peripheral_descriptor.element_name) THEN
                IF cmv$physical_configuration^ [pc_index_1].
                    channel_adapter.connection.channel.configured THEN
                  FOR pc_index_2 := 1 TO UPPERBOUND (cmv$physical_configuration^) DO
                    IF (cmv$physical_configuration^ [pc_index_2].element_type = cmc$data_channel_element) AND
                       (cmv$physical_configuration^ [pc_index_1].channel_adapter.connection.
                          channel.iou = cmv$physical_configuration^ [pc_index_2].data_channel.iou) AND
                        (cmv$physical_configuration^ [pc_index_1].channel_adapter.connection.
                          channel.element_name = cmv$physical_configuration^ [pc_index_2].element_name) THEN
                      temp_pointer^.access.channel := cmv$physical_configuration^ [pc_index_2].
                           data_channel.ordinal;
                      temp_pointer^.access.channel_address :=
                        cmv$physical_configuration^ [pc_index_1].channel_adapter.physical_equipment_number;
                      EXIT /loop_ica/;
                    IFEND;
                  FOREND;
                IFEND;
              IFEND;
            FOREND /loop_ica/;

          = cmc$communications_element =
            IF (cmv$peripheral_element_table.
                      pointer ^[peripheral_index].product_id.product_number = ' $2620') OR
                (cmv$peripheral_element_table.
                   pointer ^[peripheral_index].product_id.product_number = ' $2621') THEN
              temp_pointer^.device_type := nac$di;
              temp_pointer^.driver_name := 'NETW';
            ELSEIF (cmv$peripheral_element_table.
                      pointer ^[peripheral_index].product_id.product_number = ' $4000') THEN
              temp_pointer^.device_type := nac$expresslink;
              IF iou_definition.kind = dsc$imn_i0_5x_model THEN
                temp_pointer^.driver_name := 'IVB0';
              ELSE
                temp_pointer^.driver_name := 'IVB4';
              IFEND;
            ELSE
              osp$set_status_abnormal (cmc$configuration_management_id,
                   cme$jtd_invalid_element_type, network_descriptor^.access.element, status);
              EXIT /main_program/;
            IFEND;
            IF temp_pointer^.system_identifier <> 0 THEN
              osp$set_status_condition (cme$jtd_system_id_not_allowed, status);
              EXIT /main_program/;
            IFEND;

            pmp$get_mainframe_id (mainframe_id, status);
            /loop_communications/
            FOR pc_index_1 := 1 TO UPPERBOUND (cmv$physical_configuration^) DO
              IF (cmv$physical_configuration^ [pc_index_1].element_type = cmc$communications_element)
                 AND (cmv$physical_configuration^ [pc_index_1].element_name =
                          element_descriptor.peripheral_descriptor.element_name) THEN
                FOR cpn := LOWERVALUE (cpn) TO UPPERVALUE (cpn) DO
                  IF (cmv$physical_configuration^ [pc_index_1].
                      communications_element.connection.port [cpn].configured) AND
                     (cmv$physical_configuration^ [pc_index_1].
                      communications_element.connection.port [cpn].mainframe_ownership = mainframe_id) THEN
                    FOR pc_index_2 := 1 TO UPPERBOUND (cmv$physical_configuration^) DO
                      IF (cmv$physical_configuration^ [pc_index_2].
                          element_type = cmc$data_channel_element) AND
                         (cmv$physical_configuration^ [pc_index_1].communications_element.connection.port
                            [cpn].iou = cmv$physical_configuration^ [pc_index_2].data_channel.iou) AND
                          (cmv$physical_configuration^ [pc_index_1].communications_element.connection.port
                            [cpn].element_name = cmv$physical_configuration^ [pc_index_2].element_name) THEN
                        temp_pointer^.access.channel := cmv$physical_configuration^ [pc_index_2].
                              data_channel.ordinal;
                        temp_pointer^.access.channel_address := cmv$physical_configuration^
                          [pc_index_1].communications_element.physical_equipment_number;
                        EXIT /loop_communications/;
                      IFEND;
                    FOREND;
                  IFEND;
                FOREND;
              IFEND;
            FOREND /loop_communications/;
          ELSE
            osp$set_status_abnormal (cmc$configuration_management_id,
                  cme$jtd_invalid_element_type, network_descriptor^.access.element, status);
            EXIT /main_program/;
          CASEND;
        ELSEIF network_descriptor^.kind = nac$define_tcpip_host THEN
          ALLOCATE temp_pointer^.tcpip.host_name: [#SIZE (network_descriptor^.tcpip.host_name^)] IN
                osv$task_private_heap^;
          temp_pointer^.tcpip.host_name^ := network_descriptor^.tcpip.host_name^;

        IFEND;

        temp_pointer^.next_descriptor := cmv$network_descriptor_p;
        cmv$network_descriptor_p := temp_pointer;
      ELSE
        osp$set_status_abnormal (cmc$configuration_management_id, cme$jtd_nil_network_descriptor,
          'cmp$form_network_list', status);
      IFEND;
    END /main_program/;

  PROCEND cmp$form_network_list;

?? TITLE := '    cmp$process_cpu_state_change', EJECT ??

*copyc cmh$process_cpu_state_change
  PROCEDURE [XDCL, #GATE] cmp$process_cpu_state_change
    (    processor_id: ost$processor_id;
         current_state: cmt$element_state;
         new_state: cmt$element_state;
     VAR status: ost$status);

    VAR
      caller_identifier: ost$caller_identifier,
      cst_p: ^ost$cpu_state_table,
      state_translation_table: [STATIC, READ, oss$job_paged_literal] array [cmt$element_state] of string (4)
            := ['  ON', ' OFF', 'DOWN'];

    #caller_id (caller_identifier);
    status.normal := TRUE;
    IF  NOT (avp$configuration_administrator () OR avp$system_operator ()
             OR (caller_identifier.ring <= 6)) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration or system_operation'
          , status);
      RETURN;
    IFEND;

    cst_p := ^mtv$cst0 [processor_id];
    IF cst_p^.processor_state <> current_state THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$state_changed_in_interim,
            state_translation_table [current_state], status);
      osp$append_status_parameter (osc$status_parameter_delimiter, state_translation_table
            [cst_p^.processor_state], status);
      RETURN;
    IFEND;

    IF cst_p^.processor_state = cmc$off THEN

{ A state change from OFF to any other state is not supported, and such a state change is detected in the
{ caller to this procedure.  This code is present to prevent a malicious user from performing a state change
{ using this procedure as an entry point.

      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_model_cant_change_state,
            state_translation_table [current_state], status);
      osp$append_status_parameter (osc$status_parameter_delimiter, state_translation_table [new_state],
            status);
      RETURN;
    IFEND;

    IF (new_state <> cmc$on) AND ((osv$cpus_logically_on < 2) OR ((cst_p^.dual_state_jps <> 0) AND
          syv$mandatory_dualstate)) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$change_produces_interrupt,
            state_translation_table [current_state], status);
      osp$append_status_parameter (osc$status_parameter_delimiter, state_translation_table
            [new_state], status);
      RETURN;
    IFEND;

    cmp$process_cpu_state_change_r1 (processor_id, new_state, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND cmp$process_cpu_state_change;

?? TITLE := '    cmp$enable_production_r3', EJECT ??
{
{ PURPOSE:
{   This procedure makes a monitor call to enable production on a reinstated CPU.  Until this command is
{   entered, the CPU will not be used by any existing job, including those jobs which may have explicitly
{   requested the use of the reinstated CPU previous to its deconfiguration/reconfiguration.
{
  PROCEDURE [XDCL, #GATE] cmp$enable_production_r3
    (VAR status: ost$status);

    VAR
      caller_identifier: ost$caller_identifier,
      request_block: tmt$rb_update_job_task_enviro;

    status.normal := TRUE;
    #caller_id (caller_identifier);
    IF NOT (avp$configuration_administrator () OR avp$system_operator ()
             OR (caller_identifier.ring <= 6)) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration or system_operation',
            status);
      RETURN;
    IFEND;

{ Set up and make the monitor call which enables production on the reinstated CPU.

    request_block.reqcode := syc$rc_update_job_task_enviro;
    request_block.status.normal := TRUE;
    request_block.subcode := tmc$ujte_update_cpu_selections;
    i#call_monitor (#LOC (request_block), #SIZE (request_block));

  PROCEND cmp$enable_production_r3;
?? TITLE := '    FUNCTION cmp$cpus_physically_configured', EJECT ??
{
{ PURPOSE:
{   This function provides a ring 3 interface to access the ring 1 variable OSV$CPUS_PHYSICALLY_CONFIGURED.
{
  FUNCTION [XDCL, #GATE] cmp$cpus_physically_configured: ost$processor_id;

    cmp$cpus_physically_configured := osv$cpus_physically_configured;

  FUNCEND cmp$cpus_physically_configured;
?? TITLE := '      cmp$get_unit_number_via_vsn', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_unit_number_via_vsn
    (    recorded_vsn: rmt$recorded_vsn;
     VAR logical_unit_number: iot$logical_unit;
     VAR status: ost$status);


    dmp$get_logical_unit_number (recorded_vsn, logical_unit_number, status);

  PROCEND cmp$get_unit_number_via_vsn;

?? TITLE := '      cmp$activate_volume', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$activate_volume
    (    logical_unit_number: iot$logical_unit;
     VAR status: ost$status);

    VAR
      lun: iot$logical_unit;

    IF (NOT avp$configuration_administrator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      RETURN;
    IFEND;
    lun := logical_unit_number;
    status.normal := TRUE;
    dmp$activate_volume (lun, status);
    IF status.normal THEN
      dmp$add_to_sorted_dfl (lun, status);
    IFEND;

  PROCEND cmp$activate_volume;

?? TITLE := '      cmp$process_force_format', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$process_force_format
    (    product_id: cmt$product_identification;
         element: cmt$element_name;
         logical_unit_number: iot$logical_unit;
         force_format: boolean;
     VAR status: ost$status);

    VAR
      found: boolean,
      io_unit_type: iot$unit_type,
      unit_class: cmt$unit_class,
      unit_type: cmt$unit_type;

{ Valdate user for 'configuration_administrator' capability.
    IF (NOT avp$configuration_administrator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      RETURN;
    IFEND;

{ Validate that the unit type is valid for this command and call processor.
    cmp$get_unit_type (product_id, unit_type, io_unit_type, unit_class, found);
    IF (unit_type = cmc$ms5833_1p) OR (unit_type = cmc$ms5833_3p) OR
          (unit_type = cmc$ms5838_1p) OR (unit_type = cmc$ms5838_3p) OR
          (unit_type = cmc$ms47444_1p) OR (unit_type = cmc$ms47444_3p) THEN
      dmp$process_force_format (logical_unit_number, force_format, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND
    ELSE
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_invalid_unit_type, element, status);
      RETURN;
    IFEND;

  PROCEND cmp$process_force_format;

?? TITLE := '      cmp$process_das_restore', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$process_das_restore
    (    product_id: cmt$product_identification;
         element: cmt$element_name;
         logical_unit_number: iot$logical_unit;
     VAR status: ost$status);

    VAR
      found: boolean,
      io_unit_type: iot$unit_type,
      unit_class: cmt$unit_class,
      unit_type: cmt$unit_type;

{ Valdate user for 'configuration_administrator' capability.
    IF (NOT avp$configuration_administrator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      RETURN;
    IFEND;

{ Validate that the unit type is valid for this command and call processor.
    cmp$get_unit_type (product_id, unit_type, io_unit_type, unit_class, found);
    IF (unit_type = cmc$ms5833_1p) OR (unit_type = cmc$ms5833_3p) OR
          (unit_type = cmc$ms5838_1p) OR (unit_type = cmc$ms5838_3p) OR
          (unit_type = cmc$ms47444_1p) OR (unit_type = cmc$ms47444_3p) THEN
      dmp$process_das_restore (logical_unit_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND
    ELSE
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_invalid_unit_type, element, status);
      RETURN;
    IFEND;

  PROCEND cmp$process_das_restore;

?? TITLE := '      cmp$initialize_ms_volume', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$initialize_ms_volume
    (    access_code: ost$name;
         product_id: cmt$product_identification;
         owner_id: ost$user_identification;
         p_physical_attributes: ^dmt$physical_device_attributes;
         p_logical_attributes: ^dmt$logical_device_attributes;
         p_volume_label_attributes: ^dmt$volume_label_attributes;
         logical_unit_number: iot$logical_unit;
         allowed_to_overwrite_volume: boolean;
         retain_device_flaws: boolean;
     VAR initialize_status_info: dmt$initialize_status_info;
     VAR status: ost$status);

    VAR
      element_def: ^cmt$element_definition,
      found: boolean,
      io_unit_type: iot$unit_type,
      log_data_ptr: ^SEQ (*),
      logging_data: dst$log_ms_volume_init,
      unit_class: cmt$unit_class,
      unit_type: cmt$unit_type;

    IF (NOT avp$configuration_administrator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      RETURN;
    IFEND;

    cmp$get_unit_type (product_id, unit_type, io_unit_type, unit_class, found);
    IF (unit_class = cmc$mass_storage_unit) AND (io_unit_type <> ioc$dt_foreign_device) THEN

      dmp$initialize_ms_volume (access_code, owner_id, unit_type, p_physical_attributes,
            p_logical_attributes, p_volume_label_attributes,
            logical_unit_number, allowed_to_overwrite_volume,
            retain_device_flaws, initialize_status_info, status);

      IF status.normal THEN

        cmp$get_element_name_via_lun (logical_unit_number,
            logging_data.element_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        logging_data.recorded_vsn := p_volume_label_attributes^ [3].recorded_vsn;
        cmp$pc_get_logical_unit (logical_unit_number,
            element_def, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF element_def^.element_type = cmc$storage_device_element THEN
          logging_data.physical_unit_number := element_def^.storage_device.physical_unit_number;
        IFEND;
        log_data_ptr := #SEQ (logging_data);
        dsp$log_system_message (cml$ms_volume_initialization, log_data_ptr, status);
      IFEND;
    ELSE
      osp$set_status_abnormal (cmc$configuration_management_id,
          cme$jtd_unsupported_unit_class, product_id.product_number, status);
    IFEND;

  PROCEND cmp$initialize_ms_volume;

?? TITLE := '      cmp$volume_online', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$volume_online
    (    logical_unit_number: iot$logical_unit;
         p_physical_attributes: ^dmt$physical_device_attributes;
     VAR status: ost$status);

    VAR
      lun: iot$logical_unit,
      local_status: ost$status;

    IF (NOT avp$configuration_administrator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      RETURN;
    IFEND;
    lun := logical_unit_number;
    status.normal := TRUE;
    dmp$volume_online (lun, p_physical_attributes, status);

  PROCEND cmp$volume_online;
?? TITLE := '      cmp$change_volume_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$change_volume_attributes (logical_unit_number: iot$logical_unit;
        p_volume_attributes: ^dmt$volume_attributes;
    VAR status: ost$status);

    IF (NOT avp$configuration_administrator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      RETURN;
    IFEND;
    dmp$change_volume_attributes (logical_unit_number, p_volume_attributes, status);

  PROCEND cmp$change_volume_attributes;
?? TITLE := '      cmp$get_volume_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_volume_attributes (logical_unit_number: iot$logical_unit;
    VAR volume_attribute_info: dmt$volume_attribute_info;
    VAR status: ost$status);

   VAR
     lun: iot$logical_unit,
     volume_attr_info: dmt$volume_attribute_info;

    status.normal := TRUE;
    lun := logical_unit_number;
    dmp$get_volume_attributes (lun, volume_attr_info, status);
    IF status.normal THEN
      volume_attribute_info := volume_attr_info;
    IFEND;

  PROCEND cmp$get_volume_attributes;

?? TITLE := '      cmp$get_logical_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_logical_attributes
    (    product_identification: cmt$product_identification;
     VAR p_logical_attributes: ^dmt$logical_device_attributes;
     VAR status: ost$status);

    VAR
      pid: cmt$product_identification;

    status.normal := TRUE;
    pid := product_identification;
    dmp$get_logical_attributes (pid, p_logical_attributes, status);

  PROCEND cmp$get_logical_attributes;

?? TITLE := '      cmp$get_physical_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_physical_attributes
    (    product_identification: cmt$product_identification;
     VAR p_physical_attributes: ^dmt$physical_device_attributes;
     VAR status: ost$status);

    VAR
      pid: cmt$product_identification;

    status.normal := TRUE;
    pid := product_identification;
    dmp$get_physical_attributes (pid, p_physical_attributes, status);

  PROCEND cmp$get_physical_attributes;

?? TITLE := '      cmp$get_controller_type_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_controller_type_r3
    (    pid: cmt$product_identification;
     VAR controller_type: cmt$controller_type;
     VAR status: ost$status);

    VAR
      ct: cmt$controller_type,
      product_id: cmt$product_identification;

    status.normal := TRUE;
    product_id := pid;
    cmp$get_controller_type (product_id, ct, status);
    IF status.normal THEN
      controller_type := ct;
    IFEND;
  PROCEND cmp$get_controller_type_r3;

?? TITLE := '      cmp$get_element_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_element_r3
    (    element_name: cmt$element_name;
         iou_name: cmt$element_name;
     VAR mainframe_element: ^cmt$element_definition;
     VAR status: ost$status);

    cmp$get_mainframe_element (element_name, iou_name, mainframe_element^, status);

  PROCEND cmp$get_element_r3;

?? TITLE := '      cmp$get_cpu_element_r3', EJECT ??

*copyc cmh$get_cpu_element_r3
  PROCEDURE [XDCL, #GATE] cmp$get_cpu_element_r3
    (    processor_id: ost$processor_id;
     VAR cpu_element: ^cmt$cpu_element_definition;
     VAR status: ost$status);

    cmp$get_cpu_element_r1 (processor_id, {update_cst =} TRUE, cpu_element^, status);

  PROCEND cmp$get_cpu_element_r3;

?? TITLE := '      cmp$get_element_type', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_element_type
    (    element_name: cmt$element_name;
         iou_name: cmt$element_name;
     VAR element_type: cmt$element_type;
     VAR status: ost$status);

    VAR
      element: cmt$element_name,
      iou: cmt$element_name,
      mainframe_element: cmt$element_definition;

    status.normal := TRUE;
    element := element_name;
    iou := iou_name;
    cmp$get_mainframe_element (element, iou, mainframe_element, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    element_type := mainframe_element.element_type;

  PROCEND cmp$get_element_type;

?? TITLE := '      cmp$get_logical_unit_number_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_logical_unit_number_r3
    (    element_name: cmt$element_name;
     VAR logical_unit_number: iot$logical_unit;
     VAR status: ost$status);

    VAR
      element: cmt$element_name,
      lun: iot$logical_unit;

    status.normal := TRUE;
    element := element_name;
    cmp$get_logical_unit_number (element, lun, status);
    IF status.normal THEN
      logical_unit_number := lun;
    IFEND;
  PROCEND cmp$get_logical_unit_number_r3;

?? TITLE := '      cmp$get_sys_dev_rec_vsn', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_sys_dev_rec_vsn
    (VAR recorded_vsn: rmt$recorded_vsn;
     VAR status: ost$status);

    status.normal := TRUE;

    recorded_vsn := dmv$system_device_recorded_vsn;

  PROCEND cmp$get_sys_dev_rec_vsn;

?? TITLE := '      FUNCTION cmp$deadstart_phase', EJECT ??

  FUNCTION [XDCL, #GATE] cmp$deadstart_phase: ost$deadstart_phase;

    cmp$deadstart_phase := osv$deadstart_phase;

  FUNCEND cmp$deadstart_phase;

?? TITLE := '      cmp$known_controller_id', EJECT ??

  FUNCTION [XDCL, #GATE] cmp$known_controller_id
    (    product_id: cmt$product_identification): boolean;

    VAR
      index: integer;

    cmp$known_controller_id := FALSE;

  /forloop/
    FOR index := 1 TO UPPERBOUND (cmv$controller_data_ptr^) DO

      IF product_id = cmv$controller_data_ptr^ [index].product_id THEN
        cmp$known_controller_id := TRUE;
        EXIT /forloop/;
      IFEND;

    FOREND /forloop/;

  FUNCEND cmp$known_controller_id;

?? TITLE := '      cmp$known_product_id', EJECT ??

  FUNCTION [XDCL, #GATE] cmp$known_product_id
    (    product_id: cmt$product_identification): boolean;

    VAR
      index: integer;

    cmp$known_product_id := FALSE;

  /forloop/
    FOR index := 1 TO UPPERBOUND (cmv$product_id_ptr^) DO

      IF product_id = cmv$product_id_ptr^ [index].product_id THEN
        cmp$known_product_id := TRUE;
        EXIT /forloop/;
      IFEND;

    FOREND /forloop/;

  FUNCEND cmp$known_product_id;

?? EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$add_class_to_element
    (    avt_index: dmt$active_volume_table_index;
         class: dmt$class;
     VAR status: ost$status);

    VAR
      add_class: dmt$class,
      index: dmt$active_volume_table_index;

    IF (NOT avp$configuration_administrator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      RETURN;
    IFEND;
    status.normal := TRUE;
    index := avt_index;
    add_class := class;
    dmp$add_class_to_volume (index, add_class, status);

  PROCEND cmp$add_class_to_element;


?? EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$obtain_max_volume_index
    (VAR max_volume_index: integer);

    max_volume_index := UPPERBOUND (dmv$p_active_volume_table^);

  PROCEND cmp$obtain_max_volume_index;

?? EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_ms_volumes
    (VAR max_ms_volumes: integer);

    VAR
      index: integer;

      max_ms_volumes := 0;
      FOR index := LOWERBOUND (dmv$p_active_volume_table ^) TO
                     UPPERBOUND (dmv$p_active_volume_table ^) DO
        IF NOT dmv$p_active_volume_table ^[index].entry_available THEN
          max_ms_volumes := max_ms_volumes + 1;
        IFEND;
      FOREND

  PROCEND cmp$get_ms_volumes;

?? EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_ms_volume_info
    (VAR ms_volumes: ^array [ * ] of cmt$mass_storage_volume);

    VAR
      index: integer,
      ms_index: integer;

      ms_index := 0;
      FOR index := LOWERBOUND (dmv$p_active_volume_table ^) TO
                     UPPERBOUND (dmv$p_active_volume_table ^) DO
        IF NOT dmv$p_active_volume_table ^[index].entry_available THEN
          ms_index := ms_index + 1;
          ms_volumes ^[ms_index].recorded_vsn :=
                dmv$p_active_volume_table ^[index].mass_storage.recorded_vsn;
          ms_volumes ^[ms_index].class :=
                dmv$p_active_volume_table ^[index].mass_storage.class;
          ms_volumes ^[ms_index].lun :=
                dmv$p_active_volume_table ^[index].logical_unit_number;
        IFEND;
      FOREND

  PROCEND cmp$get_ms_volume_info;

?? EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$obtain_volumes
    (VAR volume_list: ^stt$volume_list;
     VAR number_of_members: integer);

    VAR
      status: ost$status;

    stp$get_active_volume_list (volume_list^, number_of_members,
      status);

  PROCEND cmp$obtain_volumes;

?? EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_parity_status_info
    (    element_name: cmt$element_name;
     VAR parity_status: iot$unit_status;
     VAR status: ost$status);

    VAR
      lun: iot$logical_unit;

    cmp$get_logical_unit_number (element_name, lun, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    parity_status := cmv$logical_unit_table ^[lun].unit_interface_table ^.unit_status;

  PROCEND cmp$get_parity_status_info;

?? EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_ms_status_via_lun
    (    lun: iot$logical_unit;
     VAR element_status: iot$unit_status);

    element_status.disabled := cmv$logical_unit_table ^[lun].unit_interface_table ^.unit_status.disabled;

  PROCEND cmp$get_ms_status_via_lun;

?? TITLE := '      cmp$get_element_state_via_lun ',EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_element_state_via_lun
    (    logical_unit_number: iot$logical_unit;
     VAR state: cmt$element_state);

    VAR
      lun: iot$logical_unit,
      element_state: cmt$element_state;

    lun := logical_unit_number;
    cmp$get_logical_unit_state (lun, cmv$logical_unit_table, element_state);
    state := element_state;

  PROCEND cmp$get_element_state_via_lun;

?? OLDTITLE, OLDTITLE, OLDTITLE, OLDTITLE ??

MODEND cmm$job_template_deadstart;
*DECK DECK=CMM$LCU_FUNCTIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Configuration Management: LCU Functions' ??
MODULE cmm$lcu_functions;

{ PURPOSE:
{   This module contains all the Logical Configuration Utility functions.
{
{ DESIGN:
{   Throughout this module, the STATUS variable is set to normal and the function will usually return a null
{ string if an abnormal status is encountered internally.

?? NEWTITLE := 'Global Declarations Referenced By This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$name
*copyc clt$parameter_list
*copyc clt$parameter_value
*copyc clt$work_area
*copyc cmc$condition_limits
*copyc cme$physical_configuration_mgr
*copyc cmt$element_definition
*copyc cmt$element_selector
*copyc cmt$mass_storage_volume
*copyc iot$unit_interface_table
*copyc jmt$system_supplied_name
?? POP ??
*copyc avp$configuration_administrator
*copyc avp$removable_media_operator
*copyc avp$system_displays
*copyc avp$system_operator
*copyc clp$convert_string_to_integer
*copyc clp$evaluate_parameters
*copyc cmp$count_con_access_job
*copyc cmp$dedicated_maint_active
*copyc cmp$get_channel_definition
*copyc cmp$get_element_definition
*copyc cmp$get_element_information
*copyc cmp$get_element_name_via_lun
*copyc cmp$get_logical_unit_number
*copyc cmp$get_ms_class_on_volume
*copyc cmp$get_parity_status_info
*copyc cmp$get_reservation_info
*copyc cmp$get_unit_number_via_vsn
*copyc cmp$get_unit_type
*copyc cmp$pc_get_element
*copyc cmp$pc_get_logical_unit
*copyc cmp$get_ms_volumes
*copyc cmp$get_ms_volume_info
*copyc cmp$return_lun_info
*copyc cmp$search_peripheral_table
*copyc dmv$active_volume_table
*copyc osp$get_family_names_by_set
*copyc osp$set_status_abnormal
*copyc oss$job_paged_literal
*copyc osv$task_private_heap
*copyc stp$get_active_set_list
*copyc stp$get_volumes_set_name
*copyc stp$get_volumes_in_set
*copyc stv$system_set_name

?? OLDTITLE ??
?? NEWTITLE := 'LCU Functions' ??
?? OLDTITLE ??
?? NEWTITLE := '   $ACTIVE_SETS', EJECT ??

{ PURPOSE:
{   This function provides a list of the names of all the active mass
{   storage sets on the requesting mainframe. The name of the system set
{   is included.

  PROCEDURE [XDCL, #GATE] cmp$$active_sets
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (cmm$$active_sets) $active_sets (
{ )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 4, 18, 15, 15, 9, 282],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'CMM$$ACTIVE_SETS']];

?? FMT (FORMAT := ON) ??
?? POP ??

  VAR
    actual_number_of_sets: stt$number_of_sets,
    index: integer,
    p_active_set_list: ^stt$set_list,
    value: ^clt$data_value;

    status.normal := TRUE;
    NEXT result IN work_area;
    result^.kind := clc$list;
    result^.element_value := NIL;
    result^.link := NIL;
    result^.generated_via_list_rest := FALSE;
    IF NOT (avp$configuration_administrator () OR avp$removable_media_operator () OR
             avp$system_displays ()) THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    actual_number_of_sets := 10;
    REPEAT
      PUSH p_active_set_list: [1 .. actual_number_of_sets];
      stp$get_active_set_list (p_active_set_list^, actual_number_of_sets);
    UNTIL (actual_number_of_sets <= UPPERBOUND (p_active_set_list^));

    IF actual_number_of_sets = 0 THEN
      RETURN;
    IFEND;

    value := result;
    FOR index := LOWERBOUND (p_active_set_list^) TO actual_number_of_sets DO
      NEXT value^.element_value IN work_area;
      value^.element_value^.kind := clc$name;
      value^.element_value^.name_value := p_active_set_list^ [index];
      value^.generated_via_list_rest := FALSE;
      IF index < actual_number_of_sets THEN
        NEXT value^.link IN work_area;
        value^.link^.kind := clc$list;
        value^.link^.element_value := NIL;
        value^.link^.link := NIL;
        value^.link^.generated_via_list_rest := FALSE;
        value := value^.link;
      ELSE
        value^.link := NIL;
      IFEND;
    FOREND;

  PROCEND cmp$$active_sets;

?? OLDTITLE ??
?? NEWTITLE := '  $ACTIVE_SET_FAMILIES', EJECT ??

{ PURPOSE:
{   This function provides a list of names of families assigned to the
{   set. If the set is not defined, an empty list is returned.

  PROCEDURE [XDCL, #GATE] cmp$$active_set_families
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);


{   FUNCTION (cmm$$active_set_families) $active_set_families (
{     set: name = $required
{  )

?? 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$name_type_qualifier,
      recend,
    recend := [
    [1,
    [89, 4, 19, 9, 33, 53, 876],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'CMM$$ACTIVE_SET_FAMILIES'], [
    ['SET                            ',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, 5, clc$required_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$set = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      active_family_list: ^array [1 .. * ] of ost$name,
      ignore_status: ost$status,
      index: pmt$family_name_count,
      number_of_families: pmt$family_name_count,
      set_name: stt$set_name,
      value: ^clt$data_value;

    status.normal := TRUE;

    NEXT result IN work_area;
    result^.kind := clc$list;
    result^.element_value := NIL;
    result^.link := NIL;
    result^.generated_via_list_rest := FALSE;
    IF NOT (avp$configuration_administrator () OR avp$removable_media_operator ()
            OR avp$system_displays ()) THEN
      RETURN;
    IFEND;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    set_name := pvt [p$set].value^.name_value;
    number_of_families := 10;
    REPEAT
      PUSH active_family_list: [1 .. number_of_families];
      osp$get_family_names_by_set (set_name, active_family_list^, number_of_families, ignore_status);
      IF NOT ignore_status.normal THEN
        RETURN;
      IFEND;
    UNTIL number_of_families <= UPPERBOUND (active_family_list^);
    IF number_of_families = 0 THEN
      RETURN;
    IFEND;
    value := result;
    FOR index := 1 TO number_of_families DO
      NEXT value^.element_value IN work_area;
      value^.element_value^.kind := clc$name;
      value^.element_value^.name_value := active_family_list^ [index];
      value^.generated_via_list_rest := FALSE;
      IF index < number_of_families THEN
        NEXT value^.link IN work_area;
        value^.link^.kind := clc$list;
        value^.link^.element_value := NIL;
        value^.link^.link := NIL;
        value^.link^.generated_via_list_rest := FALSE;
        value := value^.link;
      ELSE
        value^.link := NIL;
      IFEND;
    FOREND;

  PROCEND cmp$$active_set_families;

?? OLDTITLE ??
?? NEWTITLE := '   $ACTIVE_SET_MEMBERS', EJECT ??

{ PURPOSE:
{   This function returns a record for each mass storage volume that is
{   a member of the specified set. If the set is not defined, an empty
{   list is returned.
{ NOTE:
{   The record returned is of the following SCL type:
{   "member_volume" record
{     element_name    : name
{     recorded_vsn    : name 1 .. 6
{     volume_available: boolean
{  recend

  PROCEDURE [XDCL, #GATE] cmp$$active_set_members
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);


{ FUNCTION (cmm$$active_set_members) $active_set_members (
{   set: name = $required
{ )

?? 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$name_type_qualifier,
      recend,
    recend := [
    [1,
    [89, 4, 18, 14, 23, 26, 448],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'CMM$$ACTIVE_SET_MEMBERS'], [
    ['SET                            ',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, 5, clc$required_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$set = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      actual_number_of_members: stt$number_of_members,
      element_name: cmt$element_name,
      local_status: ost$status,
      index: integer,
      lun: iot$logical_unit,
      master_vol: stt$volume_info,
      p_member_vol_list: ^stt$volume_list,
      set_name: stt$set_name,
      value: ^clt$data_value;

    status.normal := TRUE;
    NEXT result IN work_area;
    result^.kind := clc$list;
    result^.element_value := NIL;
    result^.link := NIL;
    result^.generated_via_list_rest := FALSE;
    IF NOT (avp$configuration_administrator () OR avp$removable_media_operator ()
              OR avp$system_displays ()) THEN
      RETURN;
    IFEND;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

 { Preset function result to empty list.

    set_name :=  pvt [p$set].value^.name_value;
    actual_number_of_members := 10;
    REPEAT
      PUSH p_member_vol_list: [1 .. actual_number_of_members];
      stp$get_volumes_in_set (set_name, master_vol, p_member_vol_list^,
          actual_number_of_members, local_status);
      IF NOT local_status.normal THEN
        RETURN;
      IFEND;
    UNTIL actual_number_of_members <= UPPERBOUND (p_member_vol_list^);

 { Retrieve info for master volume and make it the first entry in the list

    cmp$get_unit_number_via_vsn (master_vol.recorded_vsn, lun, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    cmp$get_element_name_via_lun (lun, element_name, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    value := result;
    NEXT value^.element_value IN work_area;
    value^.element_value^.kind := clc$record;
    NEXT value^.element_value^.field_values: [1 .. 3] IN work_area;
    value^.element_value^.field_values^ [1].name := 'ELEMENT_NAME';
    NEXT value^.element_value^.field_values^ [1].value IN work_area;
    value^.element_value^.field_values^ [1].value^.kind := clc$name;
    value^.element_value^.field_values^ [1].value^.name_value := element_name;
    value^.element_value^.field_values^ [2].name := 'RECORDED_VSN';
    NEXT value^.element_value^.field_values^ [2].value IN work_area;
    value^.element_value^.field_values^ [2].value^.kind := clc$name;
    value^.element_value^.field_values^ [2].value^.name_value := master_vol.recorded_vsn;
    value^.element_value^.field_values^ [3].name := 'VOLUME_AVAILABLE';
    NEXT value^.element_value^.field_values^ [3].value IN work_area;
    value^.element_value^.field_values^ [3].value^.kind := clc$boolean;
    value^.element_value^.field_values^ [3].value^.boolean_value.kind := clc$true_false_boolean;
    value^.element_value^.field_values^ [3].value^.boolean_value.value :=
          volume_available(master_vol.recorded_vsn);
    value^.generated_via_list_rest := FALSE;
    value^.link := NIL;
    IF actual_number_of_members = 0 THEN
      RETURN;
    IFEND;

    /get_elements_loop/
    FOR index := LOWERBOUND (p_member_vol_list^) TO actual_number_of_members DO

      cmp$get_unit_number_via_vsn (p_member_vol_list^ [index].recorded_vsn, lun, local_status);
      IF NOT local_status.normal THEN
        IF local_status.condition = dme$recorded_vsn_not_in_lun THEN
          local_status.normal := TRUE;
          CYCLE /get_elements_loop/;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      cmp$get_element_name_via_lun (lun, element_name, local_status);
      IF NOT local_status.normal THEN
        RETURN;
      IFEND;

      NEXT value^.link IN work_area;
      value := value^.link;
      value^.kind := clc$list;
      value^.link := NIL;
      NEXT value^.element_value IN work_area;
      value^.element_value^.kind := clc$record;
      NEXT value^.element_value^.field_values: [1 .. 3] IN work_area;
      value^.element_value^.field_values^ [1].name := 'ELEMENT_NAME';
      NEXT value^.element_value^.field_values^ [1].value IN work_area;
      value^.element_value^.field_values^ [1].value^.kind := clc$name;
      value^.element_value^.field_values^ [1].value^.name_value := element_name;
      value^.element_value^.field_values^ [2].name := 'RECORDED_VSN';
      NEXT value^.element_value^.field_values^ [2].value IN work_area;
      value^.element_value^.field_values^ [2].value^.kind := clc$name;
      value^.element_value^.field_values^ [2].value^.name_value := p_member_vol_list^ [index].recorded_vsn;
      value^.element_value^.field_values^ [3].name := 'VOLUME_AVAILABLE';
      NEXT value^.element_value^.field_values^ [3].value IN work_area;
      value^.element_value^.field_values^ [3].value^.kind := clc$boolean;
      value^.element_value^.field_values^ [3].value^.boolean_value.kind := clc$true_false_boolean;
      value^.element_value^.field_values^ [3].value^.boolean_value.value :=
            volume_available(p_member_vol_list^ [index].recorded_vsn);
      value^.generated_via_list_rest := FALSE;
    FOREND /get_elements_loop/;

  PROCEND cmp$$active_set_members;

?? OLDTITLE ??
?? NEWTITLE := '  $CHANNEL_PORT', EJECT ??

{ PURPOSE:
{   This function returns the port value of a CIO channel.

  PROCEDURE [XDCL, #GATE] cmp$$channel_port
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (cmm$$channel_port) $channel_port, $cp (
{   channel: name = $required
{   downline_element: name = $required
{   iou: name = IOU0
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          default_value: string (4),
        recend,
      recend := [[1, [88, 11, 2, 12, 34, 56, 789], clc$function, 3, 3, 2, 0, 0, 0, 0, 'CMM$$CHANNEL_PORT'],
            [['CHANNEL                        ', clc$nominal_entry, 1],
            ['DOWNLINE_ELEMENT               ', clc$nominal_entry, 2],
            ['IOU                            ', clc$nominal_entry, 3]], [

{ CHANNEL

      [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, 5, clc$required_parameter, 0, 0],

{ DOWNLINE_ELEMENT

      [2, 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, 5, clc$required_parameter, 0, 0],

{ IOU

      [3, 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, 5, clc$optional_default_parameter, 0,
            4]],

{ CHANNEL

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ DOWNLINE_ELEMENT

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ IOU

      [[1, 0, clc$name_type], [1, osc$max_name_size], 'IOU0']];

?? POP ??

    CONST
      p$channel = 1,
      p$downline_element = 2,
      p$iou = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      channel_descriptor: cmt$channel_descriptor,
      channel_definition: cmt$data_channel_definition,
      data_port: cmt$data_storage_port_number,
      element: ^cmt$element_definition,
      element_name: cmt$element_name,
      ignore_status: ost$status,
      iou_name: cmt$element_name,
      port: cmt$controller_port_number,
      upline_channel: cmt$data_channel_definition;

    status.normal := TRUE;

{ Preset empty string so SOMETHING will be returned no matter what else goes wrong...

    NEXT result IN work_area;
    result^.kind := clc$string;
    NEXT result^.string_value: [0] IN work_area;

  /main_program/
    BEGIN
      IF NOT (avp$configuration_administrator () OR avp$removable_media_operator ()
           OR avp$system_displays ()) THEN
        EXIT /main_program/;
      IFEND;
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      channel_descriptor.use_logical_identification := TRUE;
      channel_descriptor.name := pvt [p$channel].value^.name_value;
      channel_descriptor.iou := iou_name;
      element_name := pvt [p$downline_element].value^.name_value;
      iou_name := pvt [p$iou].value^.name_value;
      cmp$get_channel_definition (channel_descriptor, channel_definition, ignore_status);
      IF NOT ignore_status.normal THEN
        IF ignore_status.condition <> cme$lcm_element_not_found THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF NOT channel_definition.concurrent THEN

{ Non concurrent channels have no port.

        EXIT /main_program/;
      IFEND;
      cmp$pc_get_element (element_name, iou_name, element, ignore_status);
      IF NOT ignore_status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF element^.element_type = cmc$controller_element THEN

      /upline_connection_loop1/
        FOR port := LOWERVALUE (cmt$controller_port_number) TO UPPERVALUE (cmt$controller_port_number) DO
          IF element^.controller.connection.port [port].configured THEN
            channel_descriptor.use_logical_identification := TRUE;
            channel_descriptor.iou := element^.controller.connection.port [port].iou;
            channel_descriptor.name := element^.controller.connection.port [port].element_name;
            cmp$get_channel_definition (channel_descriptor, upline_channel, ignore_status);
            IF NOT ignore_status.normal THEN
              EXIT /main_program/;
            IFEND;
            IF (upline_channel.number = channel_definition.number) AND
                  (element^.controller.connection.port [port].iou = iou_name) THEN
              IF upline_channel.port = cmc$port_a THEN
                result^.string_value^ (1, 1) := 'A';
              ELSE { upline_channel.port = cmc$port_b
                result^.string_value^ (1, 1) := 'B';
              IFEND;
              EXIT /upline_connection_loop1/;
            IFEND;
          IFEND;
        FOREND /upline_connection_loop1/;

      ELSEIF element^.element_type = cmc$storage_device_element THEN

      /upline_connection_loop2/
        FOR data_port := LOWERVALUE (cmt$data_storage_port_number)
              TO UPPERVALUE (cmt$data_storage_port_number) DO
          IF (element^.storage_device.connection.port [data_port].configured) AND
                (element^.storage_device.connection.port [data_port].upline_connection_type =
                cmc$data_channel_element) THEN
            channel_descriptor.use_logical_identification := TRUE;
            channel_descriptor.iou := element^.storage_device.connection.port [data_port].iou;
            channel_descriptor.name := element^.storage_device.connection.port [data_port].element_name;
            cmp$get_channel_definition (channel_descriptor, upline_channel, ignore_status);
            IF NOT ignore_status.normal THEN
              EXIT /main_program/;
            IFEND;
            IF (upline_channel.number = channel_definition.number) AND
                  (element^.storage_device.connection.port [port].iou = iou_name) THEN
              IF upline_channel.port = cmc$port_a THEN
                result^.string_value^ (1, 1) := 'A';
              ELSE { upline_channel.port = cmc$port_b THEN
                result^.string_value^ (1, 1) := 'B';
              IFEND;
              EXIT /upline_connection_loop2/;
            IFEND;
          IFEND;
        FOREND /upline_connection_loop2/;
      IFEND;
    END /main_program/;

  PROCEND cmp$$channel_port;

?? OLDTITLE ??
?? NEWTITLE := '  $ELEMENT', EJECT ??

{ PURPOSE:
{   This function returns a specified attribute of a given element.

  PROCEDURE [XDCL, #GATE] cmp$$element
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{    FUNCTION (cmm$$element) $element (
{      element: name = $required
{      attribute: key
{          (application_information, ai)
{          (assigned_job_identification, aji)
{          (assigned_to_job, atj)
{          (concurrent_maintenance_count, cmc)
{          (dedicated_maintenance_active, dma)
{          (densities_in_operation, dio)
{          (device_allocation_unit_size, daus)
{          (device_class, dc)
{          (element_capability, ec)
{          (element_exists, ee)
{          (element_identification, ei)
{          (element_state, es)
{          (element_type, et)
{          (external_vsn, evsn, ev)
{          (iou_program_name, ioupn, ipn)
{          (mass_storage_available, msa)
{          (mass_storage_capacity, msc)
{          (mass_storage_set_name, mssn)
{          (mass_storage_volume_active, msva)
{          (mass_storage_volume_classes, msvc)
{          (mass_storage_volume_online, msvo)
{          (off_line_drive_number, oldn)
{          (parity_protection_enabled, ppe)
{          (recorded_vsn, rvsn, rv)
{          (repair_action_required, rar)
{          (repair_attempted, ra)
{          (reservable_element, re)
{          (reserved_to_job, rtj)
{          (reserving_job_identification, rji)
{          (restoring_drive, rd)
{          (serial_number, sn)
{          (site_information, si)
{          (system_critical_element, sce)
{        keyend = $required
{      iou: name = IOU0
{      )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 69] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (4),
      recend,
    recend := [
    [1,
    [94, 12, 21, 14, 50, 42, 497],
    clc$function, 3, 3, 2, 0, 0, 0, 0, 'CMM$$ELEMENT'], [
    ['ATTRIBUTE                      ',clc$nominal_entry, 2],
    ['ELEMENT                        ',clc$nominal_entry, 1],
    ['IOU                            ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, 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, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [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, 2560, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [3, 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, 5, clc$optional_default_parameter, 0, 4]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [69], [
    ['AI                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['AJI                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['APPLICATION_INFORMATION        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['ASSIGNED_JOB_IDENTIFICATION    ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['ASSIGNED_TO_JOB                ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['ATJ                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['CMC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
    ['CONCURRENT_MAINTENANCE_COUNT   ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['DAUS                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
    ['DC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
    ['DEDICATED_MAINTENANCE_ACTIVE   ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
    ['DENSITIES_IN_OPERATION         ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
    ['DEVICE_ALLOCATION_UNIT_SIZE    ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
    ['DEVICE_CLASS                   ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
    ['DIO                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
    ['DMA                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
    ['EC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
    ['EE                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
    ['EI                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 11],
    ['ELEMENT_CAPABILITY             ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
    ['ELEMENT_EXISTS                 ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
    ['ELEMENT_IDENTIFICATION         ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
    ['ELEMENT_STATE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
    ['ELEMENT_TYPE                   ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
    ['ES                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 12],
    ['ET                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 13],
    ['EV                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 14],
    ['EVSN                           ', clc$alias_entry,
  clc$normal_usage_entry, 14],
    ['EXTERNAL_VSN                   ', clc$nominal_entry,
  clc$normal_usage_entry, 14],
    ['IOUPN                          ', clc$alias_entry,
  clc$normal_usage_entry, 15],
    ['IOU_PROGRAM_NAME               ', clc$nominal_entry,
  clc$normal_usage_entry, 15],
    ['IPN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 15],
    ['MASS_STORAGE_AVAILABLE         ', clc$nominal_entry,
  clc$normal_usage_entry, 16],
    ['MASS_STORAGE_CAPACITY          ', clc$nominal_entry,
  clc$normal_usage_entry, 17],
    ['MASS_STORAGE_SET_NAME          ', clc$nominal_entry,
  clc$normal_usage_entry, 18],
    ['MASS_STORAGE_VOLUME_ACTIVE     ', clc$nominal_entry,
  clc$normal_usage_entry, 19],
    ['MASS_STORAGE_VOLUME_CLASSES    ', clc$nominal_entry,
  clc$normal_usage_entry, 20],
    ['MASS_STORAGE_VOLUME_ONLINE     ', clc$nominal_entry,
  clc$normal_usage_entry, 21],
    ['MSA                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 16],
    ['MSC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 17],
    ['MSSN                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 18],
    ['MSVA                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 19],
    ['MSVC                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 20],
    ['MSVO                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 21],
    ['OFF_LINE_DRIVE_NUMBER          ', clc$nominal_entry,
  clc$normal_usage_entry, 22],
    ['OLDN                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 22],
    ['PARITY_PROTECTION_ENABLED      ', clc$nominal_entry,
  clc$normal_usage_entry, 23],
    ['PPE                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 23],
    ['RA                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 26],
    ['RAR                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 25],
    ['RD                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 30],
    ['RE                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 27],
    ['RECORDED_VSN                   ', clc$nominal_entry,
  clc$normal_usage_entry, 24],
    ['REPAIR_ACTION_REQUIRED         ', clc$nominal_entry,
  clc$normal_usage_entry, 25],
    ['REPAIR_ATTEMPTED               ', clc$nominal_entry,
  clc$normal_usage_entry, 26],
    ['RESERVABLE_ELEMENT             ', clc$nominal_entry,
  clc$normal_usage_entry, 27],
    ['RESERVED_TO_JOB                ', clc$nominal_entry,
  clc$normal_usage_entry, 28],
    ['RESERVING_JOB_IDENTIFICATION   ', clc$nominal_entry,
  clc$normal_usage_entry, 29],
    ['RESTORING_DRIVE                ', clc$nominal_entry,
  clc$normal_usage_entry, 30],
    ['RJI                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 29],
    ['RTJ                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 28],
    ['RV                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 24],
    ['RVSN                           ', clc$alias_entry,
  clc$normal_usage_entry, 24],
    ['SCE                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 33],
    ['SERIAL_NUMBER                  ', clc$nominal_entry,
  clc$normal_usage_entry, 31],
    ['SI                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 32],
    ['SITE_INFORMATION               ', clc$nominal_entry,
  clc$normal_usage_entry, 32],
    ['SN                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 31],
    ['SYSTEM_CRITICAL_ELEMENT        ', clc$nominal_entry,
  clc$normal_usage_entry, 33]]
    ],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'IOU0']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element = 1,
      p$attribute = 2,
      p$iou = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    CONST
      init_offln_drv_num = 0ff(16),    {NOSVE initialization value for 'off_line_drive_number'.}
      no_drives_offline = 0fe(16);     {Value set by driver to indicate no drives offline.}

    VAR
      assigned_jsn: jmt$system_supplied_name,
      assigned_to_job: boolean,
      attribute: clt$keyword,
      call_program_interface: boolean,
      cm_unit_type: cmt$unit_type,
      element: ^cmt$element_definition,
      element_def: ^cmt$element_definition,
      element_descriptor: cmt$element_descriptor,
      element_exists: boolean,
      element_info: array [1 .. 1] of cmt$element_info_item,
      element_name: cmt$element_name,
      element_reservation: cmt$element_reservation,
      found: boolean,
      ignore: ost$status,
      io_unit_type: iot$unit_type,
      iou_name: cmt$element_name,
      jc: integer,
      list_count: integer,
      logical_unit_number: iot$logical_unit,
      ms_class: cmt$ms_class_members,
      ms_class_info: cmt$ms_class_info,
      name_list_index: integer,
      not_in_configuration: boolean,
      parity_status: iot$unit_status,
      port: cmt$data_storage_port_number,
      read_only: boolean,
      reservable_element: boolean,
      reserved_to_job: boolean,
      reserving_job: jmt$system_supplied_name,
      set_index: rmt$density,
      set_name: stt$set_name,
      string_p: ^string ( * ),
      table_index: integer,
      unit_class: cmt$unit_class,
      value: ^clt$data_value;

    status.normal := TRUE;

  /main_program/
    BEGIN
      {
      { Preset empty string so SOMETHING will be returned no matter what else goes wrong...
      {
      NEXT result IN work_area;
      result^.kind := clc$string;
      NEXT result^.string_value: [0] IN work_area;
      IF NOT (avp$configuration_administrator () OR avp$removable_media_operator ()
            OR avp$system_displays ()) THEN
        EXIT /main_program/;
      IFEND;

      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      attribute := pvt [p$attribute].value^.keyword_value;
      element_name := pvt [p$element].value^.name_value;
      iou_name := pvt [p$iou].value^.name_value;

      cmp$pc_get_element (element_name, iou_name, element_def, ignore);
      element_exists := ignore.normal;
      not_in_configuration := NOT element_exists;

      cmp$get_logical_unit_number (element_name, logical_unit_number, ignore);

      IF attribute = 'ELEMENT_EXISTS' THEN
        result^.kind := clc$boolean;
        result^.boolean_value.kind := clc$true_false_boolean;
        result^.boolean_value.value := element_exists;
        EXIT /main_program/;
      ELSEIF not_in_configuration THEN
        EXIT /main_program/;
      IFEND;

      element_descriptor.element_type := element_def^.element_type;

{ Set up element descriptor for CMP$GET_ELEMENT_INFORMATION.  Note that this will only be called for
{ certain values of ATTRIBUTE.

      CASE element_def^.element_type OF
      = cmc$channel_adapter_element, cmc$communications_element, cmc$controller_element,
            cmc$storage_device_element, cmc$external_processor_element =
        element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
        element_descriptor.peripheral_descriptor.element_name := element_name;
      = cmc$data_channel_element =
        element_descriptor.channel_descriptor.use_logical_identification := TRUE;
        element_descriptor.channel_descriptor.iou := iou_name;
        element_descriptor.channel_descriptor.name := element_name;
      ELSE
        EXIT /main_program/;
      CASEND;

      call_program_interface := TRUE;

      IF attribute = 'APPLICATION_INFORMATION' THEN
        element_info [1].selector := cmc$application_string_size;
      ELSEIF attribute = 'DENSITIES_IN_OPERATION' THEN
        element_info [1].selector := cmc$element_capability;
      ELSEIF attribute = 'DEVICE_ALLOCATION_UNIT_SIZE' THEN
        element_info [1].selector := cmc$dau_size;
      ELSEIF attribute = 'DEVICE_CLASS' THEN
        element_info [1].selector := cmc$device_class;
      ELSEIF attribute = 'ELEMENT_CAPABILITY' THEN
        element_info [1].selector := cmc$element_capability;
      ELSEIF attribute = 'ELEMENT_IDENTIFICATION' THEN
        element_info [1].selector := cmc$product_identification;
      ELSEIF attribute = 'ELEMENT_STATE' THEN
        element_info [1].selector := cmc$element_status;
      ELSEIF attribute = 'EXTERNAL_VSN' THEN
        element_info [1].selector := cmc$external_vsn;
      ELSEIF attribute = 'MASS_STORAGE_AVAILABLE' THEN
        element_info [1].selector := cmc$mass_storage_available;
      ELSEIF attribute = 'MASS_STORAGE_CAPACITY' THEN
        element_info [1].selector := cmc$mass_storage_capacity;
      ELSEIF attribute = 'MASS_STORAGE_SET_NAME' THEN
        element_info [1].selector := cmc$recorded_vsn;
      ELSEIF attribute = 'MASS_STORAGE_VOLUME_ACTIVE' THEN
        element_info [1].selector := cmc$volume_active;
      ELSEIF attribute = 'MASS_STORAGE_VOLUME_CLASSES' THEN
        element_info [1].selector := cmc$recorded_vsn;
      ELSEIF attribute = 'MASS_STORAGE_VOLUME_ONLINE' THEN
        element_info [1].selector := cmc$volume_online;
      ELSEIF attribute = 'RECORDED_VSN' THEN
        element_info [1].selector := cmc$recorded_vsn;
      ELSEIF attribute = 'REPAIR_ATTEMPTED' THEN
        element_info [1].selector := cmc$element_status;
      ELSEIF attribute = 'SERIAL_NUMBER' THEN
        element_info [1].selector := cmc$serial_number;
      ELSEIF attribute = 'SITE_INFORMATION' THEN
        element_info [1].selector := cmc$site_info_string_size;
      ELSEIF attribute = 'SYSTEM_CRITICAL_ELEMENT' THEN
        element_info [1].selector := cmc$system_critical_element;
      ELSE
        call_program_interface := FALSE;
      IFEND;

      IF call_program_interface THEN
        cmp$get_element_information (element_descriptor, element_info, ignore);
        IF NOT ignore.normal THEN
          EXIT /main_program/;
        IFEND;
        IF NOT element_info [1].item_returned THEN
          IF element_info [1].selector <> cmc$device_class THEN
            EXIT /main_program/;
          IFEND;
        IFEND;
      IFEND;

{ The following code is logically a 'CASE attribute OF' construct...

      IF attribute = 'APPLICATION_INFORMATION' THEN
        IF element_info [1].application_info_string_size > 0 THEN
          NEXT string_p: [element_info [1].application_info_string_size] in work_area;
          element_info [1].selector := cmc$application_information;
          element_info [1].application_information := string_p;
          cmp$get_element_information (element_descriptor, element_info, ignore);
          IF NOT ignore.normal THEN
            EXIT /main_program/;
          IFEND;
          result^.string_value := element_info [1].application_information;
        IFEND;
      ELSEIF attribute = 'ASSIGNED_JOB_IDENTIFICATION' THEN
        IF logical_unit_number <> 0 THEN
          cmp$return_lun_info (logical_unit_number, assigned_to_job, assigned_jsn);
          result^.kind := clc$name;
          IF assigned_to_job THEN
            result^.name_value := assigned_jsn;
          ELSE
            result^.name_value := ' ';
          IFEND;
        IFEND;

      ELSEIF attribute = 'ASSIGNED_TO_JOB' THEN
        IF logical_unit_number <> 0 THEN
          cmp$return_lun_info (logical_unit_number, assigned_to_job, assigned_jsn);
          result^.kind := clc$boolean;
          result^.boolean_value.kind := clc$true_false_boolean;
          result^.boolean_value.value := assigned_to_job;
        IFEND;

      ELSEIF attribute = 'CONCURRENT_MAINTENANCE_COUNT' THEN
        cmp$search_peripheral_table (element_descriptor, element_reservation, not_in_configuration,
              table_index, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        result^.kind := clc$integer;
        result^.integer_value.radix := 10;
        result^.integer_value.radix_specified := FALSE;
        cmp$count_con_access_job (table_index, result^.integer_value.value, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

      ELSEIF attribute = 'DEDICATED_MAINTENANCE_ACTIVE' THEN
        cmp$search_peripheral_table (element_descriptor, element_reservation, not_in_configuration,
              table_index, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        result^.kind := clc$boolean;
        result^.boolean_value.kind := clc$true_false_boolean;
        result^.boolean_value.value := cmp$dedicated_maint_active (table_index);

      ELSEIF attribute = 'DENSITIES_IN_OPERATION' THEN
        list_count := 0;
        IF element_info [1].element_capability.element_type = cmc$storage_device_element THEN
          IF element_info [1].element_capability.device_class = rmc$magnetic_tape_device THEN
            FOR set_index := LOWERVALUE (rmt$density) TO UPPERVALUE (rmt$density) DO
              IF set_index IN element_info [1].element_capability.densities THEN
                list_count := list_count + 1;
              IFEND;
            FOREND;
          ELSE
            EXIT /main_program/;
          IFEND;
        IFEND;
        IF list_count > 0 THEN
          result^.kind := clc$array;
          NEXT result^.array_value: [1 .. list_count] IN work_area;
          name_list_index := 1;
          FOR set_index := LOWERVALUE (rmt$density) TO UPPERVALUE (rmt$density) DO
            IF set_index IN element_info [1].element_capability.densities THEN
              NEXT result^.array_value^ [name_list_index] IN work_area;
              result^.array_value^ [name_list_index]^.kind := clc$name;
              CASE set_index OF
              = rmc$800 =
                result^.array_value^ [name_list_index]^.name_value := 'MT9$800';
              = rmc$1600 =
                result^.array_value^ [name_list_index]^.name_value := 'MT9$1600';
              = rmc$6250 =
                result^.array_value^ [name_list_index]^.name_value := 'MT9$6250';
              = rmc$38000 =
                result^.array_value^ [name_list_index]^.name_value := 'MT18$38000';
              ELSE
                result^.array_value^ [name_list_index]^.name_value := ' ';
              CASEND;
              name_list_index := name_list_index + 1;
            IFEND;
          FOREND;
        IFEND;

      ELSEIF attribute = 'DEVICE_ALLOCATION_UNIT_SIZE' THEN
        result^.kind := clc$integer;
        result^.integer_value.radix := 10;
        result^.integer_value.radix_specified := FALSE;
        result^.integer_value.value := element_info [1].dau_size;

      ELSEIF attribute = 'DEVICE_CLASS' THEN
        result^.kind := clc$keyword;
        CASE element_info [1].device_class OF
        = rmc$magnetic_tape_device =
          result^.keyword_value := 'MAGNETIC_TAPE';
        = rmc$mass_storage_device =
          result^.keyword_value := 'MASS_STORAGE';
        = rmc$network_device =
          result^.keyword_value := 'NETWORK_DEVICE';
        = rmc$rhfam_device =
          result^.keyword_value := 'RHFAM_DEVICE';
        ELSE
          result^.keyword_value := ' ';
        CASEND;
        IF NOT element_info [1].item_returned THEN
          IF element_def^.element_type = cmc$storage_device_element THEN
            cmp$get_unit_type (element_def^.product_id, cm_unit_type, io_unit_type, unit_class, found);
            IF cm_unit_type = cmc$foreign_unit THEN
              NEXT result^.string_value: [12] IN work_area;
              result^.string_value^ := 'MASS_STORAGE';
            IFEND;
          IFEND;
        IFEND;

      ELSEIF attribute = 'ELEMENT_CAPABILITY' THEN
        read_only := FALSE;
        IF element_info [1].element_capability.element_type = cmc$storage_device_element THEN
          IF element_info [1].element_capability.device_class = rmc$magnetic_tape_device THEN
            read_only := element_info [1].element_capability.write_inhibited;
          IFEND;
        ELSE
          EXIT /main_program/;
        IFEND;
        result^.kind := clc$array;
        IF read_only THEN
          NEXT result^.array_value: [1 .. 1] IN work_area;
          NEXT result^.array_value^ [1] IN work_area;
          result^.array_value^ [1]^.kind := clc$name;
          result^.array_value^ [1]^.name_value := 'READ';
        ELSE
          NEXT result^.array_value: [1 .. 2] IN work_area;
          NEXT result^.array_value^ [1] IN work_area;
          result^.array_value^ [1]^.kind := clc$name;
          result^.array_value^ [1]^.name_value := 'READ';
          NEXT result^.array_value^ [2] IN work_area;
          result^.array_value^ [2]^.kind := clc$name;
          result^.array_value^ [2]^.name_value := 'WRITE';
        IFEND;

      ELSEIF attribute = 'ELEMENT_IDENTIFICATION' THEN
        result^.kind := clc$name;
        result^.name_value (1, 6) := element_info [1].product_identification.product_number;
        result^.name_value (7, 1) := element_info [1].product_identification.underscore;
        result^.name_value (8, * ) := element_info [1].product_identification.model_number;

      ELSEIF attribute = 'ELEMENT_STATE' THEN
        result^.kind := clc$keyword;
        CASE element_info [1].element_status.state OF
        = cmc$down =
          result^.keyword_value := 'DOWN';
        = cmc$off =
          result^.keyword_value := 'OFF';
        = cmc$on =
          result^.keyword_value := 'ON';
        ELSE
          result^.keyword_value := ' ';
        CASEND;

      ELSEIF attribute = 'ELEMENT_TYPE' THEN
        result^.kind := clc$keyword;
        CASE element_def^.element_type OF
        = cmc$central_memory_element =
          result^.keyword_value := 'CENTRAL_MEMORY';
        = cmc$central_processor_element =
          result^.keyword_value := 'CENTRAL_PROCESSOR';
        = cmc$channel_adapter_element =
          result^.keyword_value := 'CHANNEL_ADAPTER';
        = cmc$communications_element =
          result^.keyword_value := 'COMMUNICATIONS_ELEMENT';
        = cmc$controller_element =
          result^.keyword_value := 'CONTROLLER';
        = cmc$data_channel_element =
          result^.keyword_value := 'DATA_CHANNEL';
        = cmc$external_processor_element =
          result^.keyword_value := 'EXTERNAL_PROCESSOR';
        = cmc$iou_element =
          result^.keyword_value := 'IOU';
        = cmc$mainframe_element =
          result^.keyword_value := 'MAINFRAME';
        = cmc$pp_element =
          result^.keyword_value := 'PP';
        = cmc$storage_device_element =
          result^.keyword_value := 'STORAGE_DEVICE';
        ELSE
          result^.keyword_value := ' ';
        CASEND;

      ELSEIF attribute = 'EXTERNAL_VSN' THEN
        result^.kind := clc$string;
        NEXT result^.string_value: [6] IN work_area;
        result^.string_value^ := element_info [1].external_vsn;

      ELSEIF attribute = 'IOU_PROGRAM_NAME' THEN
        result^.kind := clc$name;
        CASE element_def^.element_type OF
        = cmc$channel_adapter_element =
          result^.name_value := element_def^.channel_adapter.peripheral_driver_name;
        = cmc$communications_element =
          result^.name_value := element_def^.communications_element.peripheral_driver_name;
        = cmc$controller_element =
          result^.name_value := element_def^.controller.peripheral_driver_name;
        = cmc$storage_device_element =
          IF element_def^.product_id.product_number = '  $887' THEN
            result^.name_value := 'E9S887';
          ELSE

          /find_controller_loop/
            FOR port := LOWERVALUE (cmt$data_storage_port_number)
                  TO UPPERVALUE (cmt$data_storage_port_number) DO
              IF element_def^.storage_device.connection.port [port].configured THEN
                cmp$pc_get_element (element_def^.storage_device.connection.port [port].element_name, iou_name,
                      element, ignore);
                IF ignore.normal THEN
                  IF element^.element_type = cmc$controller_element THEN
                    result^.name_value := element^.controller.peripheral_driver_name;
                    EXIT /find_controller_loop/;
                  IFEND;
                IFEND;
              IFEND;
            FOREND /find_controller_loop/;
          IFEND;
        ELSE
          result^.name_value := ' ';
        CASEND;

      ELSEIF attribute = 'MASS_STORAGE_AVAILABLE' THEN
        result^.kind := clc$integer;
        result^.integer_value.radix := 10;
        result^.integer_value.radix_specified := FALSE;
        IF element_info [1].item_returned THEN
          result^.integer_value.value := element_info [1].available_capacity;
        ELSE
          result^.integer_value.value := 0;
        IFEND;

      ELSEIF attribute = 'MASS_STORAGE_CAPACITY' THEN
        result^.kind := clc$integer;
        result^.integer_value.radix := 10;
        result^.integer_value.radix_specified := FALSE;
        IF element_info [1].item_returned THEN
          result^.integer_value.value := element_info [1].total_capacity;
        ELSE
          result^.integer_value.value := 0;
        IFEND;

      ELSEIF attribute = 'MASS_STORAGE_SET_NAME' THEN
        result^.kind := clc$name;
        IF logical_unit_number <> 0 THEN
          IF element_def^.element_type = cmc$storage_device_element THEN
            IF element_info [1].recorded_vsn <> ' ' THEN
              stp$get_volumes_set_name (element_info [1].recorded_vsn, set_name, ignore);
              IF ignore.normal THEN
                result^.name_value := set_name;
              IFEND;
            IFEND;
          IFEND;
        ELSE
          result^.name_value := ' ';
        IFEND;

      ELSEIF attribute = 'MASS_STORAGE_VOLUME_ACTIVE' THEN
        result^.kind := clc$boolean;
        result^.boolean_value.kind := clc$true_false_boolean;
        IF element_info [1].item_returned THEN
          result^.boolean_value.value := element_info [1].active;
        ELSE
          result^.boolean_value.value := FALSE;
        IFEND;

      ELSEIF attribute = 'MASS_STORAGE_VOLUME_CLASSES' THEN
        result^.kind := clc$list;
        result^.element_value := NIL;
        result^.link := NIL;
        result^.generated_via_list_rest := FALSE;

        IF logical_unit_number <> 0 THEN
          IF element_def^.element_type = cmc$storage_device_element THEN
            IF element_info [1].recorded_vsn <> ' ' THEN
              cmp$get_ms_class_on_volume (element_info [1].recorded_vsn, found, ms_class_info);
              IF NOT found THEN
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        value := NIL;
      /build_list/
        FOR ms_class := LOWERBOUND (ms_class_info) TO UPPERBOUND(ms_class_info) DO
          IF NOT ms_class_info[ms_class] THEN
            CYCLE /build_list/;
          IFEND;

          IF value = NIL THEN
            value := result;
          ELSE
            NEXT value^.link IN work_area;
            value^.link^.kind := clc$list;
            value^.link^.generated_via_list_rest := FALSE;
            value := value^.link;
            value^.link := NIL;
          IFEND;

          NEXT value^.element_value IN work_area;
          value^.element_value^.kind := clc$string;
          NEXT value^.element_value^.string_value: [1] IN work_area;
          value^.element_value^.string_value^(1) := ms_class;
          value^.generated_via_list_rest := FALSE;
        FOREND /build_list/;

      ELSEIF attribute = 'MASS_STORAGE_VOLUME_ONLINE' THEN
        result^.kind := clc$boolean;
        result^.boolean_value.kind := clc$true_false_boolean;
        IF element_info [1].item_returned THEN
          result^.boolean_value.value := element_info [1].online;
        ELSE
          result^.boolean_value.value := FALSE;
        IFEND;

      ELSEIF attribute = 'OFF_LINE_DRIVE_NUMBER' THEN
        IF (element_def^.product_id.product_number = ' $5833') OR
              (element_def^.product_id.product_number = ' $5838') OR
              (element_def^.product_id.product_number = '$47444') THEN
          IF (element_def^.product_id.model_number = '1P ') OR
                (element_def^.product_id.model_number = '3P ') THEN
            cmp$get_parity_status_info (element_name, parity_status, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            IF (parity_status.off_line_drive_number = init_offln_drv_num) OR
                  (parity_status.off_line_drive_number = no_drives_offline) THEN
              EXIT /main_program/;
            ELSE
              result^.kind := clc$integer;
              result^.integer_value.radix := 10;
              result^.integer_value.radix_specified := FALSE;
              result^.integer_value.value := parity_status.off_line_drive_number;
            IFEND;
          IFEND;
        IFEND;

        ELSEIF attribute = 'PARITY_PROTECTION_ENABLED' THEN
          IF (element_def^.product_id.product_number = ' $5833') OR
                (element_def^.product_id.product_number = ' $5838') OR
                (element_def^.product_id.product_number = '$47444') THEN
            IF (element_def^.product_id.model_number = '1P ') OR
                  (element_def^.product_id.model_number = '3P ') THEN
              cmp$get_parity_status_info (element_name, parity_status, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              IF parity_status.off_line_drive_number <> init_offln_drv_num THEN
                result^.kind := clc$boolean;
                result^.boolean_value.kind := clc$true_false_boolean;
                result^.boolean_value.value := parity_status.parity_protection_enabled;
              IFEND;
            IFEND;
          IFEND;

      ELSEIF attribute = 'RECORDED_VSN' THEN
        result^.kind := clc$name;
        result^.name_value := element_info [1].recorded_vsn;

      ELSEIF attribute = 'REPAIR_ACTION_REQUIRED' THEN
        result^.kind := clc$boolean;
        result^.boolean_value.kind := clc$true_false_boolean;
        result^.boolean_value.value := FALSE;

      ELSEIF attribute = 'REPAIR_ATTEMPTED' THEN
        result^.kind := clc$boolean;
        result^.boolean_value.kind := clc$true_false_boolean;
        IF (element_info [1].element_status.state = cmc$down) OR
              (element_info [1].element_status.state = cmc$off) THEN
          result^.boolean_value.value := element_info [1].element_status.repair_attempted;
        ELSE
          result^.boolean_value.value := FALSE;
        IFEND;

      ELSEIF attribute = 'RESERVABLE_ELEMENT' THEN
        cmp$search_peripheral_table (element_descriptor, element_reservation, not_in_configuration,
              table_index, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        cmp$get_reservation_info (table_index, reservable_element, reserved_to_job, reserving_job);
        result^.kind := clc$boolean;
        result^.boolean_value.kind := clc$true_false_boolean;
        result^.boolean_value.value := reservable_element;

      ELSEIF attribute = 'RESERVED_TO_JOB' THEN
        cmp$search_peripheral_table (element_descriptor, element_reservation, not_in_configuration,
              table_index, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        cmp$get_reservation_info (table_index, reservable_element, reserved_to_job, reserving_job);
        result^.kind := clc$boolean;
        result^.boolean_value.kind := clc$true_false_boolean;
        result^.boolean_value.value := reserved_to_job;

      ELSEIF attribute = 'RESERVING_JOB_IDENTIFICATION' THEN
        cmp$search_peripheral_table (element_descriptor, element_reservation, not_in_configuration,
              table_index, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        cmp$get_reservation_info (table_index, reservable_element, reserved_to_job, reserving_job);
        result^.kind := clc$name;
        IF reserved_to_job THEN
          result^.name_value := reserving_job;
        ELSE
          result^.name_value := ' ';
        IFEND;

      ELSEIF attribute = 'RESTORING_DRIVE' THEN
        IF (element_def^.product_id.product_number = ' $5833') OR
              (element_def^.product_id.product_number = ' $5838') OR
              (element_def^.product_id.product_number = '$47444') THEN
          IF (element_def^.product_id.model_number = '1P ') OR
                (element_def^.product_id.model_number = '3P ') THEN
            cmp$get_parity_status_info (element_name, parity_status, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            IF parity_status.off_line_drive_number <> init_offln_drv_num THEN
              result^.kind := clc$boolean;
              result^.boolean_value.kind := clc$true_false_boolean;
              result^.boolean_value.value := parity_status.restoring_drive;
            IFEND;
          IFEND;
        IFEND;

      ELSEIF attribute = 'SERIAL_NUMBER' THEN
        result^.kind := clc$integer;
        result^.integer_value.radix := 10;
        result^.integer_value.radix_specified := FALSE;
        clp$convert_string_to_integer (element_info [1].serial_number (1, 6), result^.integer_value, status);

      ELSEIF attribute = 'SITE_INFORMATION' THEN
        IF element_info [1].site_info_string_size > 0 THEN
          NEXT string_p: [element_info [1].site_info_string_size] in work_area;
          element_info [1].selector := cmc$site_information;
          element_info [1].site_information := string_p;
          cmp$get_element_information (element_descriptor, element_info, ignore);
          IF NOT ignore.normal THEN
            EXIT /main_program/;
          IFEND;
          result^.string_value := element_info [1].site_information;
        IFEND;
      ELSEIF attribute = 'SYSTEM_CRITICAL_ELEMENT' THEN
        result^.kind := clc$boolean;
        result^.boolean_value.kind := clc$true_false_boolean;
        result^.boolean_value.value := element_info [1].system_critical_element;

      IFEND;

    END /main_program/;

  PROCEND cmp$$element;

?? OLDTITLE ??
?? NEWTITLE := '  $MASS_STORAGE_CLASS_MEMBERS', EJECT ??

{ PURPOSE:
{   This functions returns a record for each member of the mass storage class
{
{ NOTE:
{   The record returned is of the following SCL type:
{   "member_volume" record
{     element_name: name
{     recorded_vsn: name 1 .. 6
{     volume_available: boolean
{  recend
{

  PROCEDURE [XDCL, #GATE] cmp$$mass_storage_class_members
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);


{   FUNCTION (cmm$$mass_storage_class_members) $mass_storage_class_members (
{     class: name 1 = $required
{  )

?? 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$name_type_qualifier,
      recend,
    recend := [
    [1,
    [89, 4, 19, 9, 41, 44, 381],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'CMM$$MASS_STORAGE_CLASS_MEMBERS'], [
    ['CLASS                          ',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, 5, clc$required_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, 1]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$class = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      class: dmt$class,
      element_name: cmt$element_name,
      ignore_status: ost$status,
      index: integer,
      lun: iot$logical_unit,
      max_ms_volumes: integer,
      ms_volumes: ^array [ * ] of cmt$mass_storage_volume,
      value: ^clt$data_value;

    status.normal := TRUE;
    {
    { Preset function result to empty list.
    {
    NEXT result IN work_area;
    result^.kind := clc$list;
    result^.element_value := NIL;
    result^.link := NIL;
    result^.generated_via_list_rest := FALSE;
    class := $dmt$class [];

    IF NOT (avp$configuration_administrator () OR avp$removable_media_operator ()
          OR avp$system_displays ()) THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    class := class + $dmt$class [pvt [p$class].value^.name_value];
    cmp$get_ms_volumes (max_ms_volumes);
    PUSH ms_volumes: [1 .. max_ms_volumes];
    cmp$get_ms_volume_info (ms_volumes);
    value := NIL;
    FOR index := 1 TO max_ms_volumes DO
      IF class <= ms_volumes^ [index].class THEN
        IF value = NIL THEN
          value := result;
        ELSE
          NEXT value^.link IN work_area;
          value^.link^.kind := clc$list;
          value^.link^.generated_via_list_rest := FALSE;
          value := value^.link;
          value^.link := NIL;
        IFEND;

        cmp$get_unit_number_via_vsn (ms_volumes^ [index].recorded_vsn, lun, ignore_status);
        IF NOT ignore_status.normal THEN
          RETURN;
        IFEND;

        cmp$get_element_name_via_lun (lun, element_name, ignore_status);
        IF NOT ignore_status.normal THEN
          RETURN;
        IFEND;

        NEXT value^.element_value IN work_area;
        value^.element_value^.kind := clc$record;
        NEXT value^.element_value^.field_values: [1 .. 3] IN work_area;
        value^.element_value^.field_values^ [1].name := 'ELEMENT_NAME';
        NEXT value^.element_value^.field_values^ [1].value IN work_area;
        value^.element_value^.field_values^ [1].value^.kind := clc$name;
        value^.element_value^.field_values^ [1].value^.name_value := element_name;
        value^.element_value^.field_values^ [2].name := 'RECORDED_VSN';
        NEXT value^.element_value^.field_values^ [2].value IN work_area;
        value^.element_value^.field_values^ [2].value^.kind := clc$name;
        value^.element_value^.field_values^ [2].value^.name_value := ms_volumes^ [index].recorded_vsn;
        value^.element_value^.field_values^ [3].name := 'VOLUME_AVAILABLE';
        NEXT value^.element_value^.field_values^ [3].value IN work_area;
        value^.element_value^.field_values^ [3].value^.kind := clc$boolean;
        value^.element_value^.field_values^ [3].value^.boolean_value.kind := clc$true_false_boolean;
        value^.element_value^.field_values^ [3].value^.boolean_value.value :=
              volume_available(ms_volumes^ [index].recorded_vsn);
        value^.generated_via_list_rest := FALSE;
      IFEND;
    FOREND;

  PROCEND cmp$$mass_storage_class_members;

?? OLDTITLE ??
?? NEWTITLE := '  $PHYSICAL_ADDRESS', EJECT ??

{ PURPOSE:
{   This function returns the physical address of an element, given its upline element and the element itself.

  PROCEDURE [XDCL, #GATE] cmp$$physical_address
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (cmm$$physical_address) $physical_address (
{   upline_element: name = $required
{   downline_element: name = $required
{   iou: name = IOU0
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          default_value: string (4),
        recend,
      recend := [[1, [88, 11, 2, 12, 34, 56, 789], clc$function, 3, 3, 2, 0, 0, 0, 0,
            'CMM$$PHYSICAL_ADDRESS'], [['DOWNLINE_ELEMENT               ', clc$nominal_entry, 2],
            ['IOU                            ', clc$nominal_entry, 3],
            ['UPLINE_ELEMENT                 ', clc$nominal_entry, 1]], [

{ UPLINE_ELEMENT

      [3, 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, 5, clc$required_parameter, 0, 0],

{ DOWNLINE_ELEMENT

      [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, 5, clc$required_parameter, 0, 0],

{ IOU

      [2, 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, 5, clc$optional_default_parameter, 0,
            4]],

{ UPLINE_ELEMENT

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ DOWNLINE_ELEMENT

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ IOU

      [[1, 0, clc$name_type], [1, osc$max_name_size], 'IOU0']];

?? POP ??

    CONST
      p$upline_element = 1,
      p$downline_element = 2,
      p$iou = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      downline_element: cmt$element_name,
      element: ^cmt$element_definition,
      iou_name: cmt$element_name,
      pen: cmt$physical_equipment_number,
      pun: cmt$physical_unit_number,
      upline_element: cmt$element_name;

    status.normal := TRUE;

  /main_program/
    BEGIN

{ Preset result = -1 so SOMETHING will be returned no matter what else goes wrong...

      NEXT result IN work_area;
      result^.kind := clc$integer;
      result^.integer_value.radix := 10;
      result^.integer_value.radix_specified := FALSE;
      result^.integer_value.value := -1;

      IF NOT (avp$configuration_administrator () OR avp$removable_media_operator ()
              OR avp$system_displays ()) THEN
        EXIT /main_program/;
      IFEND;
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      downline_element := pvt [p$downline_element].value^.name_value;
      iou_name := pvt [p$iou].value^.name_value;
      upline_element := pvt [p$upline_element].value^.name_value;

      cmp$pc_get_element (upline_element, iou_name, element, status);
      IF NOT status.normal THEN
        status.normal := TRUE;
        EXIT /main_program/;
      IFEND;

      CASE element^.element_type OF
      = cmc$controller_element =
        FOR pun := LOWERVALUE (cmt$physical_unit_number) TO UPPERVALUE (cmt$physical_unit_number) DO
          IF element^.controller.connection.unit [pun].configured THEN
            IF element^.controller.connection.unit [pun].element_name = downline_element THEN
              result^.integer_value.value := pun;
              EXIT /main_program/;
            IFEND;
          IFEND;
        FOREND;

      = cmc$data_channel_element =
        FOR pen := LOWERVALUE (cmt$physical_equipment_number) TO UPPERVALUE (cmt$physical_equipment_number) DO
          IF element^.data_channel.connection.equipment [pen].configured THEN
            IF element^.data_channel.connection.equipment [pen].element_name = downline_element THEN
              result^.integer_value.value := pen;
              EXIT /main_program/;
            IFEND;
          IFEND;
        FOREND;

      ELSE
        ;
      CASEND;

    END /main_program/;
  PROCEND cmp$$physical_address;

?? OLDTITLE ??
?? NEWTITLE := '  $STORAGE_DEVICE_NAME ', EJECT ??

{ PURPOSE:
{   This function returns the element name of a storage device element given its recorded vsn.

  PROCEDURE [XDCL, #GATE] cmp$$storage_device_name
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{  FUNCTION (cmm$$storage_device) $storage_device (
{    recorded_vsn: name 1..6 = $required
{    )

?? 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$name_type_qualifier,
      recend,
    recend := [
    [1,
    [89, 8, 25, 9, 37, 51, 266],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'CMM$$STORAGE_DEVICE'], [
    ['RECORDED_VSN                   ',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, 5, clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, 6]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$recorded_vsn = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      element: ^cmt$element_definition,
      ignore: ost$status,
      lun: iot$logical_unit,
      recorded_vsn: rmt$recorded_vsn;

    status.normal := TRUE;

  /main_program/
    BEGIN

{ Preset empty string so SOMETHING will be returned no matter what else goes wrong...

      NEXT result IN work_area;
      result^.kind := clc$string;
      NEXT result^.string_value: [0] IN work_area;

      IF NOT (avp$configuration_administrator () OR avp$removable_media_operator ()
              OR avp$system_displays ()) THEN
        EXIT /main_program/;
      IFEND;
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      recorded_vsn := pvt [p$recorded_vsn].value^.name_value;
      cmp$get_unit_number_via_vsn (recorded_vsn, lun, ignore);
      IF NOT ignore.normal THEN
        EXIT /main_program/;
      IFEND;
      cmp$pc_get_logical_unit (lun, element, ignore);
      IF NOT ignore.normal THEN
        EXIT /main_program/;
      IFEND;

      result^.kind := clc$name;
      result^.name_value := ' ';
      result^.name_value := element^.element_name;

    END /main_program/;

  PROCEND cmp$$storage_device_name;

?? OLDTITLE ??
?? NEWTITLE := '   $SYSTEM_SET_NAME', EJECT ??

{ PURPOSE:
{   This function provides the name of the system set.

  PROCEDURE [XDCL, #GATE] cmp$$system_set_name
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);


{  FUNCTION (cmm$$system_set_name) $system_set_name (
{ )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 4, 19, 12, 33, 10, 583],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'CMM$$SYSTEM_SET_NAME']];

?? FMT (FORMAT := ON) ??
?? POP ??

    status.normal := TRUE;
    NEXT result IN work_area;
    result^.kind := clc$name;
    result^.name_value := osc$null_name;
    IF NOT (avp$configuration_administrator () OR avp$removable_media_operator ()
         OR avp$system_displays ()) THEN
      RETURN;
    IFEND;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    result^.name_value := stv$system_set_name;
  PROCEND cmp$$system_set_name;

?? TITLE := 'volume_available', EJECT ??

  FUNCTION volume_available
    (    recorded_vsn: rmt$recorded_vsn): boolean;

    VAR
      avt_index: integer;

    volume_available := FALSE;

  /avt_loop/
    FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND (dmv$p_active_volume_table^) DO
      IF dmv$p_active_volume_table^ [avt_index].entry_available THEN
        CYCLE /avt_loop/;
      IFEND;

      IF dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn <> recorded_vsn THEN
        CYCLE /avt_loop/;
      IFEND;

      volume_available := (NOT dmv$p_active_volume_table^ [avt_index].mass_storage.volume_unavailable);
      RETURN;
    FOREND /avt_loop/;

  FUNCEND volume_available;

?? OLDTITLE, OLDTITLE ??
MODEND cmm$lcu_functions;
*DECK DECK=CMM$LCU_MF_SUBCMDS EXPAND=TRUE
" Text file which is replaced by the site's LCU configuration prolog when
" a deadstart catalog is created.
*DECK DECK=CMM$LOGICAL_CONFIGURATION_MGR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'Logical Configuration Manager' ??
MODULE cmm$logical_configuration_mgr;
*copyc avp$configuration_administrator
*copyc avp$system_operator
*copyc avp$removable_media_operator
*copyc amp$close
*copyc amp$fetch_access_information
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$set_segment_eoi
*copyc amp$set_segment_position
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$put_partial_display
*copyc cmp$convert_channel_type
*copyc cmp$deadstart_phase
*copyc cmp$determine_active_path
*copyc cmp$determine_tape_element
*copyc cmp$format_error_message
*copyc cmp$get_connection_list
*copyc cmp$get_connection_status
*copyc cmp$get_driver_state
*copyc cmp$get_element_information
*copyc cmp$get_element_state
*copyc cmp$get_element_type
*copyc cmp$get_ms_class_on_volume
*copyc cmp$get_parity_status_info
*copyc cmp$get_physical_attributes
*copyc cmh$multiple_iou_system
*copyc cmp$multiple_iou_system
*copyc cmp$post_deadstart
*copyc cmp$process_state_change
*copyc cmp$support_redundant_access
*copyc cmp$valid_channel_name
*copyc jmp$get_job_attributes
*copyc jmp$system_job
*copyc pmp$get_mainframe_id
?? PUSH (LISTEXT := ON) ??
*copyc cmc$display_element_constants
*copyc cmc$minimum_page_size
*copyc cme$logical_configuration_mgr
*copyc cmp$get_cpu_element_r3
*copyc cmp$process_cpu_state_change
*copyc cmp$search_peripheral_table
*copyc cmt$connection
*copyc cmt$cpu_element_definition
*copyc cmt$display_option
*copyc cmt$element_capability
*copyc cmt$element_definition
*copyc cmt$element_descriptor
*copyc cmt$element_information
*copyc cmt$element_state
*copyc cmt$lcu_display_option_key
*copyc cmt$physical_address_parts
*copyc cmt$physical_address_specifier
*copyc cmt$physical_identification
*copyc cmt$state_change_request
*copyc cmt$unit_class
*copyc cmt$unit_type
*copyc cmv$physical_configuration
*copyc cmv$peripheral_element_table
*copyc dme$tape_errors
*copyc iot$logical_unit
*copyc iot$unit_type
*copyc ofe$error_codes
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc ost$processor_id
*copyc pmp$get_unique_name
*copyc pmt$mainframe_id
*copyc rmd$volume_declarations
*copyc rmt$device_class
?? POP ??

?? TITLE := '    [XDCL, #GATE] cmp$change_cpu_element_state', EJECT ??
*copyc cmh$change_cpu_element_state

  PROCEDURE [XDCL, #GATE] cmp$change_cpu_element_state
    (    processor_id: ost$processor_id;
         state: cmt$element_state;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      cpu_element_p: ^cmt$cpu_element_definition,
      current_state: cmt$element_state,
      state_translation_table: [STATIC, READ, oss$job_paged_literal] ARRAY [cmt$element_state] OF
            string (4) := ['  ON', ' OFF', 'DOWN'];


    #caller_id (caller_id);
    status.normal := TRUE;

    IF NOT (avp$configuration_administrator () OR avp$system_operator () OR
                  (caller_id.ring <= 6)) THEN
       osp$set_status_abnormal ('OF', ofe$sou_not_active,
               'configuration_administration or system_operation', status);
       RETURN;
    IFEND;

    PUSH cpu_element_p;
    cmp$get_cpu_element_r3 (processor_id, cpu_element_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    current_state := cpu_element_p^.processor_state;

    IF current_state = state THEN
{ Issue WARNING or INFORMATIVE message }
      osp$set_status_abnormal (cmc$configuration_management_id, cme$request_state_is_crnt_state, '', status);
      RETURN;
    IFEND;

{ Current supported state changes for CPUs are:
{     ON --> DOWN
{   DOWN -->   ON
{ State changes which are NOT supported are:
{     ON -->  OFF
{    OFF -->   ON
{    OFF --> DOWN
{   DOWN -->  OFF

    IF (state = cmc$off) OR (current_state = cmc$off) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_unsupported_statechange,
              state_translation_table [current_state], status);
      osp$append_status_parameter (osc$status_parameter_delimiter, state_translation_table [state], status);
      RETURN;
    IFEND;

    cmp$process_cpu_state_change (processor_id, current_state, state, status);

  PROCEND cmp$change_cpu_element_state;

?? TITLE := '    [XDCL, #GATE] cmp$change_element_state', EJECT ??

*copyc CMH$CHANGE_ELEMENT_STATE

  PROCEDURE [XDCL, #GATE] cmp$change_element_state
    (    element: cmt$element_descriptor;
         state: cmt$element_state;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      current_state: cmt$element_state,
      definition: cmt$element_definition,
      element_info: array [1 .. 1] of cmt$element_info_item,
      element_name: cmt$element_name,
      index: integer,
      iou_name: cmt$element_name,
      job_name: jmt$system_supplied_name,
      physical_id: cmt$physical_identification,
      privileged_job: boolean,
      tape_element: boolean,
      tape_status: ost$status,
      valid_request: boolean;

    #caller_id (caller_id);
    status.normal := TRUE;
    iou_name := 'IOU0';

    /main_program/
      BEGIN
        privileged_job := caller_id.ring <= 6;

        IF NOT privileged_job THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_ring_validation_error,
               'CMP$CHANGE_ELEMENT_STATE', status);
          EXIT /main_program/;
        IFEND;
        cmp$determine_tape_element (element, tape_element);
        IF tape_element THEN
          IF NOT (avp$system_operator () OR avp$configuration_administrator () OR
                  avp$removable_media_operator () OR privileged_job) THEN
            osp$set_status_abnormal ('OF', ofe$sou_not_active,
               'configuration_administration, removable_media_operation ' CAT
               'or system_operation', status);
            EXIT /main_program/;
          IFEND;
        ELSE
          IF NOT (avp$configuration_administrator () OR avp$system_operator () OR
                  privileged_job) THEN
            osp$set_status_abnormal ('OF', ofe$sou_not_active,
               'configuration_administration or system_operation', status);
            EXIT /main_program/;
          IFEND;
        IFEND;
        CASE element.element_type OF
        = cmc$data_channel_element =
          element_name := element.channel_descriptor.name;

  { Set up iou name if there is more than one IOU present

          IF cmp$multiple_iou_system () THEN
            iou_name := element.channel_descriptor.iou;
          IFEND;
        = cmc$controller_element, cmc$channel_adapter_element, cmc$external_processor_element,
            cmc$storage_device_element, cmc$communications_element =
          element_name := element.peripheral_descriptor.element_name;
        ELSE
          ;
        CASEND;

        element_info [1].selector := cmc$system_critical_element;
        cmp$get_element_information (element, element_info, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        IF element_info [1].item_returned THEN
          IF element_info [1].system_critical_element THEN
            IF element.element_type = cmc$storage_device_element THEN
              osp$set_status_abnormal (cmc$configuration_management_id,
                cme$lcm_system_critical_element, element_name, status);
              EXIT /main_program/;
            IFEND;
          IFEND;
        IFEND;

        cmp$get_element_state (element_name, iou_name, current_state, status);
        IF NOT status.normal THEN
          cmp$format_error_message (element, physical_id, FALSE, cme$lcm_element_not_found, status);
          EXIT /main_program/;
        IFEND;

        IF state = current_state THEN
          { Issue WARNING or INFORMATIVE message }
          EXIT /main_program/;
        IFEND;

        cmp$process_state_change (tape_element, {clear_lock_behind=} TRUE,
             {system_caller=} FALSE, element, element_info [1].system_critical_element,
             current_state, state, status);

      END /main_program/;

  PROCEND cmp$change_element_state;

?? TITLE := '    cmp$open_scratch_sa_file', EJECT ??

  PROCEDURE cmp$open_scratch_sa_file (VAR file_id: amt$file_identifier;
    VAR status: ost$status);

    VAR
      contains_data: boolean,
      existing_file: boolean,
      get_attr: array [1 .. 1] of amt$get_item,
      lfn: amt$local_file_name,
      local_file: boolean;

    status.normal := TRUE;

  /main_program/
    BEGIN

      get_attr [1].key := amc$null_attribute;

      REPEAT
        pmp$get_unique_name (lfn, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        amp$get_file_attributes (lfn, get_attr, local_file, existing_file,
              contains_data, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      UNTIL NOT local_file;

      amp$open (lfn, amc$segment, NIL, file_id, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    END /main_program/;

  PROCEND cmp$open_scratch_sa_file;

?? TITLE := '    cmp$copy_sequence_files', EJECT ??

  PROCEDURE cmp$copy_sequence_files (file_id: amt$file_identifier;
    VAR sequence: ^SEQ ( * );
    VAR status: ost$status);

    VAR
      eoi_addr: array [1 .. 1] of amt$access_info,
      from_cell: ^cell,
      index: integer,
      len: integer,
      seg: amt$segment_pointer,
      to_cell: ^cell;

    status.normal := TRUE;

  /main_program/
    BEGIN

      eoi_addr [1].key := amc$eoi_byte_address;

      amp$fetch_access_information (file_id, eoi_addr, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      len := eoi_addr [1].eoi_byte_address;

      amp$get_segment_pointer (file_id, amc$sequence_pointer, seg, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      RESET seg.sequence_pointer;
      RESET sequence;

      FOR index := 1 TO len DO

        NEXT from_cell IN seg.sequence_pointer;

        IF from_cell = NIL THEN
          osp$set_status_abnormal (cmc$configuration_management_id,
                cme$lcm_empty_lc, ' ', status);
        IFEND;

        NEXT to_cell IN sequence;

        IF to_cell = NIL THEN
          osp$set_status_abnormal (cmc$configuration_management_id,
                cme$lcm_empty_lc, ' ', status);
        IFEND;

        to_cell^ := from_cell^;

      FOREND;

    END /main_program/;

  PROCEND cmp$copy_sequence_files;

?? TITLE := '    [XDCL, #GATE] cmp$display_type_elements', EJECT ??

*copy CMH$DISPLAY_TYPE_ELEMENTS

  PROCEDURE [XDCL, #GATE] cmp$display_type_elements
    (    element_type: cmt$element_type;
         display_option: cmt$display_option;
         element_count: integer;
         lc_element: ^array [1 .. *] of cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      cmv$element_type_map: [STATIC, READ, oss$job_paged_literal] array
        [cmt$element_type] of ost$name := [
        { cmc$central_memory_element } '$CENTRAL_MEMORY',
        { cmc$central_processor_element } '$CENTRAL_PROCESSOR',
        { cmc$controller_element } '$CONTROLLER',
        { cmc$data_channel_element } '$CHANNEL',
        { cmc$channel_adapter_element } '$CHANNEL_ADAPTER',
        { cmc$iou_element } '$IOU',
        { cmc$mainframe_element } '$MAINFRAME',
        { cmc$pem_element } '$PEM',
        { cmc$pp_element } '$PP',
        { cmc$storage_device_element } '$STORAGE_DEVICE',
        { cmc$external_processor_element } '$EXTERNAL_PROCESSOR',
        { cmc$communications_element } '$COMMUNICATIONS_ELEMENTS'];

    VAR
      found_element: boolean,
      i: integer,
      mainframe_element: ^cmt$element_definition,
      mainframe_id: pmt$mainframe_id;

    status.normal := TRUE;

  /main_program/
    BEGIN
      pmp$get_mainframe_id (mainframe_id, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      found_element := FALSE;
      FOR i := 1 TO element_count DO
        IF lc_element^[i].element_type = element_type THEN
          found_element := TRUE;
          mainframe_element := ^lc_element^ [i];
          CASE element_type OF
          = cmc$data_channel_element =
            cmp$display_channel_element (mainframe_element, display_option, mainframe_id, element_count,
                  lc_element, display_control, status);
          = cmc$controller_element =
            cmp$display_controller_element (mainframe_element, display_option, mainframe_id, element_count,
                  lc_element, display_control, status);
          = cmc$channel_adapter_element =
            cmp$display_ca_element (mainframe_element, display_option, mainframe_id, element_count,
                  lc_element, display_control, status);
          = cmc$communications_element =
            cmp$display_comm_element (mainframe_element, display_option, mainframe_id, element_count,
                  lc_element, display_control, status);
          = cmc$storage_device_element =
            cmp$display_storage_dev_element (mainframe_element, display_option, mainframe_id, element_count,
                  lc_element, display_control, status);
          = cmc$external_processor_element =
            cmp$display_external_proc (mainframe_element, display_option, mainframe_id, element_count,
                  lc_element, display_control, status);
          ELSE
            ;
          CASEND;
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;
      FOREND;

      IF NOT found_element THEN
        osp$set_status_abnormal (cmc$configuration_management_id,
          cme$lcm_element_not_found, cmv$element_type_map [element_type], status);
      IFEND;

    END /main_program/;

  PROCEND cmp$display_type_elements;

?? TITLE := '    [XDCL, #GATE] cmp$display_named_element', EJECT ??

*copy CMH$DISPLAY_NAMED_ELEMENT

  PROCEDURE [XDCL, #GATE] cmp$display_named_element
    (    element_name: cmt$element_name;
         iou_name: cmt$element_name;
         display_option: cmt$display_option;
         element_count: integer;
         lc_element: ^array [1 .. *] of cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      index: integer,
      mainframe_element: ^cmt$element_definition,
      mainframe_id: pmt$mainframe_id,
      text: string (64);

    status.normal := TRUE;
    text := '   ';
  /main_program/
    BEGIN
      pmp$get_mainframe_id (mainframe_id, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    /forloop/
      FOR index := 1 TO element_count DO
        IF lc_element^[index].element_name = element_name THEN
          mainframe_element := ^lc_element^[index];
          CASE mainframe_element^.element_type OF
          = cmc$data_channel_element =
            IF (mainframe_element^.data_channel.iou = iou_name) THEN
              cmp$display_channel_element (mainframe_element, display_option, mainframe_id, element_count,
                  lc_element, display_control, status);
            ELSE
              CYCLE /forloop/;
            IFEND;
          = cmc$controller_element =
            cmp$display_controller_element (mainframe_element, display_option, mainframe_id, element_count,
                  lc_element, display_control, status);
          = cmc$channel_adapter_element =
            cmp$display_ca_element (mainframe_element, display_option, mainframe_id, element_count,
                  lc_element, display_control, status);
          = cmc$communications_element =
            cmp$display_comm_element (mainframe_element, display_option, mainframe_id, element_count,
                  lc_element, display_control, status);
          = cmc$storage_device_element =
            cmp$display_storage_dev_element (mainframe_element, display_option, mainframe_id, element_count,
                  lc_element, display_control, status);
          = cmc$external_processor_element =
            cmp$display_external_proc (mainframe_element, display_option, mainframe_id, element_count,
                  lc_element, display_control, status);
          ELSE
            ;
          CASEND;
          EXIT /main_program/;
        IFEND;
      FOREND /forloop/;
      IF cmp$valid_channel_name (element_name) THEN
        text (1, 5) := iou_name (1, 5);
        text (6, *) := element_name;
      ELSE
        text (1, *) := element_name;
      IFEND;
      osp$set_status_abnormal (cmc$configuration_management_id,
            cme$lcm_element_not_found, text, status);

    END /main_program/;

  PROCEND cmp$display_named_element;

?? TITLE := '    cmp$display_ca_element', EJECT ??

  PROCEDURE cmp$display_ca_element
    (    mainframe_element: ^cmt$element_definition;
         display_option: cmt$display_option;
         mainframe_id: pmt$mainframe_id;
         element_count: integer;
         lc_element: ^array [1 .. *] of cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      i: integer,
      iou_name: cmt$element_name,
      number: integer,
      number_string: string (10),
      product_id: string (10),
      upline_element: ^cmt$element_definition;

    status.normal := TRUE;
    iou_name := 'IOU0';

  /main_program/

    BEGIN
      put_header (cmc$msg_channel_adapter_element, mainframe_element^.element_name, display_control, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$element_id_kw] <= display_option) THEN
        product_id (1, 6) := mainframe_element^.product_id.product_number;
        product_id (7, 1) := mainframe_element^.product_id.underscore;
        product_id (8, 3) := mainframe_element^.product_id.model_number;
        put_subheader (cmc$msg_product_id, product_id, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$serial_number_kw] <= display_option) THEN
        put_subheader (cmc$msg_serial_number, mainframe_element^.serial_number, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$ioupn_kw] <= display_option) THEN
        put_subheader (cmc$msg_peripheral_driver_name, mainframe_element^.channel_adapter.
              peripheral_driver_name, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$state_kw] <= display_option) THEN
        cmp$display_element_state (mainframe_element^.element_name,iou_name, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$physical_connection_kw] <= display_option) THEN
        number := mainframe_element^.channel_adapter.physical_equipment_number;
        clp$convert_integer_to_rjstring (number, 10, TRUE, ' ', number_string, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        put_subheader (cmc$msg_equipment_number, number_string, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        clp$horizontal_tab_display (display_control, cmc$starting_subheader_column, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        clp$put_partial_display (display_control, cmc$msg_channel_connections, clc$no_trim, amc$continue,
              status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        cmp$display_ca_upline_conn (mainframe_element^.channel_adapter.connection.channel, display_control,
              status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;
      IF ($cmt$display_option [cmc$all_kw] <= display_option) OR
           ($cmt$display_option [cmc$application_info_kw] <= display_option) THEN
        display_application_info (mainframe_element^, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;
      IF ($cmt$display_option [cmc$all_kw] <= display_option) OR
           ($cmt$display_option [cmc$site_info_kw] <= display_option) THEN
        display_site_info (mainframe_element^, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;
      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$connection_status_kw] <= display_option) THEN
        display_conn_status (mainframe_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$active_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_active_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_ca_paths (cmc$active_paths, mainframe_element, mainframe_id, element_count, lc_element,
              display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$inactive_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_inactive_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_ca_paths (cmc$inactive_paths, mainframe_element, mainframe_id, element_count, lc_element,
              display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$disabled_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_disabled_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_ca_paths (cmc$disabled_paths, mainframe_element, mainframe_id, element_count, lc_element,
              display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$physical_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_physical_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_ca_paths (cmc$physical_paths, mainframe_element, mainframe_id, element_count, lc_element,
              display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

    END /main_program/;

  PROCEND cmp$display_ca_element;

?? TITLE := '    cmp$display_channel_element', EJECT ??

  PROCEDURE cmp$display_channel_element
    (    mainframe_element: ^cmt$element_definition;
         display_option: cmt$display_option;
         mainframe_id: pmt$mainframe_id;
         element_count: integer;
         lc_element: ^array [1 .. *] of cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      channel_type: string (11),
      element_type: cmt$element_type,
      i: integer,
      unused_iou: cmt$element_name;

    status.normal := TRUE;

  /main_program/
    BEGIN

      put_header (cmc$msg_channel_element, mainframe_element^.element_name, display_control, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      cmp$convert_channel_type (mainframe_element^.data_channel.kind, channel_type);
      put_subheader (cmc$msg_channel_type, channel_type, display_control, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$state_kw] <= display_option) THEN
        cmp$display_element_state (mainframe_element^.element_name, mainframe_element^.data_channel.iou,
             display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$physical_connection_kw] <= display_option) THEN
        put_subheader (cmc$msg_mainframe, mainframe_element^.data_channel.mainframe_ownership,
              display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        put_subheader (cmc$msg_iou_con, mainframe_element^.data_channel.iou, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        clp$horizontal_tab_display (display_control, cmc$starting_subheader_column, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        /down_line_loop/
        FOR i := LOWERBOUND (mainframe_element^.data_channel.connection.equipment)
            TO UPPERBOUND (mainframe_element^.data_channel.connection.equipment) DO
          IF mainframe_element^.data_channel.connection.equipment [i].configured THEN
            cmp$get_element_type (mainframe_element^.data_channel.
              connection.equipment [i].element_name, unused_iou, element_type, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            EXIT /down_line_loop/;
          IFEND;
        FOREND /down_line_loop/;

        CASE element_type OF
        = cmc$controller_element =
          clp$put_partial_display (display_control, cmc$msg_controller_con, clc$no_trim, amc$continue,
                status);
        = cmc$channel_adapter_element =
          clp$put_partial_display (display_control, cmc$msg_channel_adapter_con, clc$no_trim, amc$continue,
                status);
        = cmc$storage_device_element =
          clp$put_partial_display (display_control, cmc$msg_storage_device_con, clc$no_trim, amc$continue,
                status);
        = cmc$communications_element =
          clp$put_partial_display (display_control, cmc$msg_communications_con, clc$no_trim, amc$continue,
                status);
        = cmc$external_processor_element =
          clp$put_partial_display (display_control, cmc$msg_external_proc_con, clc$no_trim, amc$continue,
                status);
        CASEND;
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        cmp$display_element_connection (mainframe_element^.data_channel.connection.equipment,
              display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$connection_status_kw] <= display_option) THEN
        display_conn_status (mainframe_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$active_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_active_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_channel_paths (cmc$active_paths, mainframe_element, mainframe_id, element_count, lc_element,
              display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$inactive_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_inactive_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_channel_paths (cmc$inactive_paths, mainframe_element, mainframe_id, element_count, lc_element,
              display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$disabled_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_disabled_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_channel_paths (cmc$disabled_paths, mainframe_element, mainframe_id, element_count, lc_element,
              display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF $cmt$display_option[cmc$physical_paths_kw] <= display_option THEN
        put_subheader (cmc$msg_physical_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_channel_paths (cmc$physical_paths, mainframe_element, mainframe_id, element_count, lc_element,
              display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

    END /main_program/;

  PROCEND cmp$display_channel_element;

?? TITLE := '    cmp$display_comm_element', EJECT ??

  PROCEDURE cmp$display_comm_element
    (    mainframe_element: ^cmt$element_definition;
         display_option: cmt$display_option;
         mainframe_id: pmt$mainframe_id;
         element_count: integer;
         lc_element: ^array [1 .. *] of cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      iou_name: cmt$element_name,
      number: integer,
      number_string: string (10),
      product_id: string (10);

    status.normal := TRUE;
    iou_name := 'IOU0';
  /main_program/
    BEGIN

      put_header (cmc$msg_communications_element, mainframe_element^.element_name, display_control, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$element_id_kw] <= display_option) THEN
        product_id (1, 6) := mainframe_element^.product_id.product_number;
        product_id (7, 1) := mainframe_element^.product_id.underscore;
        product_id (8, 3) := mainframe_element^.product_id.model_number;
        put_subheader (cmc$msg_product_id, product_id, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$serial_number_kw] <= display_option) THEN
        put_subheader (cmc$msg_serial_number, mainframe_element^.serial_number, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$ioupn_kw] <= display_option) THEN
        put_subheader (cmc$msg_peripheral_driver_name, mainframe_element^.communications_element.
              peripheral_driver_name, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$state_kw] <= display_option) THEN
        cmp$display_element_state (mainframe_element^.element_name,iou_name, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$physical_connection_kw] <= display_option) THEN
        number := mainframe_element^.communications_element.physical_equipment_number;
        clp$convert_integer_to_rjstring (number, 10, TRUE, ' ', number_string, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        put_subheader (cmc$msg_equipment_number, number_string, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        cmp$display_upline_connection (mainframe_element^.communications_element.connection.port,
              display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;
      IF ($cmt$display_option [cmc$all_kw] <= display_option) OR
           ($cmt$display_option [cmc$application_info_kw] <= display_option) THEN
        display_application_info (mainframe_element^, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;
      IF ($cmt$display_option [cmc$all_kw] <= display_option) OR
           ($cmt$display_option [cmc$site_info_kw] <= display_option) THEN
        display_site_info (mainframe_element^, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$connection_status_kw] <= display_option) THEN
        display_conn_status (mainframe_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$active_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_active_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_comm_paths (cmc$active_paths, mainframe_element, mainframe_id, element_count, lc_element,
              display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$inactive_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_inactive_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_comm_paths (cmc$inactive_paths, mainframe_element, mainframe_id, element_count, lc_element,
              display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$disabled_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_disabled_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_comm_paths (cmc$disabled_paths, mainframe_element, mainframe_id, element_count, lc_element,
              display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF $cmt$display_option[cmc$physical_paths_kw] <= display_option THEN
        put_subheader (cmc$msg_physical_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_comm_paths (cmc$physical_paths, mainframe_element, mainframe_id, element_count, lc_element,
              display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

    END /main_program/;

  PROCEND cmp$display_comm_element;

?? TITLE := '    cmp$display_controller_element', EJECT ??

  PROCEDURE cmp$display_controller_element
    (    mainframe_element: ^cmt$element_definition;
         display_option: cmt$display_option;
         mainframe_id: pmt$mainframe_id;
         element_count: integer;
         lc_element: ^array [1 .. *] of cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      iou_name: cmt$element_name,
      number: integer,
      number_string: string (10),
      product_id: string (10);

    status.normal := TRUE;
    iou_name := 'IOU0';

  /main_program/
    BEGIN

      put_header (cmc$msg_controller_element, mainframe_element^.element_name, display_control, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$element_id_kw] <= display_option) THEN
        product_id (1, 6) := mainframe_element^.product_id.product_number;
        product_id (7, 1) := mainframe_element^.product_id.underscore;
        product_id (8, 3) := mainframe_element^.product_id.model_number;
        put_subheader (cmc$msg_product_id, product_id, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$serial_number_kw] <= display_option) THEN
        put_subheader (cmc$msg_serial_number, mainframe_element^.serial_number, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$ioupn_kw] <= display_option) THEN
        put_subheader (cmc$msg_peripheral_driver_name, mainframe_element^.controller.peripheral_driver_name,
              display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$state_kw] <= display_option) THEN
        cmp$display_element_state (mainframe_element^.element_name, iou_name, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$physical_connection_kw] <= display_option) THEN
        number := mainframe_element^.controller.physical_equipment_number;
        clp$convert_integer_to_rjstring (number, 10, TRUE, ' ', number_string,
              status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        put_subheader (cmc$msg_equipment_number, number_string, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        cmp$display_upline_connection (mainframe_element^.controller.connection.port, display_control,
              status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        clp$horizontal_tab_display (display_control, cmc$starting_subheader_column, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        clp$put_partial_display (display_control, cmc$msg_storage_device_con, clc$no_trim, amc$continue,
              status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        cmp$display_element_connection (mainframe_element^.controller.connection.unit, display_control,
              status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;
      IF ($cmt$display_option [cmc$all_kw] <= display_option) OR
           ($cmt$display_option [cmc$application_info_kw] <= display_option) THEN
        display_application_info (mainframe_element^, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;
      IF ($cmt$display_option [cmc$all_kw] <= display_option) OR
           ($cmt$display_option [cmc$site_info_kw] <= display_option) THEN
        display_site_info (mainframe_element^, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$connection_status_kw] <= display_option) THEN
        display_conn_status (mainframe_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$active_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_active_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_controller_paths (cmc$active_paths, mainframe_element, mainframe_id, element_count,
              lc_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$inactive_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_inactive_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_controller_paths (cmc$inactive_paths, mainframe_element, mainframe_id, element_count,
              lc_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$disabled_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_disabled_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_controller_paths (cmc$disabled_paths, mainframe_element, mainframe_id, element_count,
              lc_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF $cmt$display_option[cmc$physical_paths_kw] <= display_option THEN
        put_subheader (cmc$msg_physical_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_controller_paths (cmc$physical_paths, mainframe_element, mainframe_id, element_count,
              lc_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

    END /main_program/;

  PROCEND cmp$display_controller_element;

?? TITLE := '    cmp$display_external_proc', EJECT ??

  PROCEDURE cmp$display_external_proc
    (    mainframe_element: ^cmt$element_definition;
         display_option: cmt$display_option;
         mainframe_id: pmt$mainframe_id;
         element_count: integer;
         lc_element: ^array [1 .. *] of cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      iou_name: cmt$element_name,
      number: integer,
      number_string: string (10),
      product_id: string (10);

    status.normal := TRUE;
    iou_name := 'IOU0';

  /main_program/
    BEGIN

      put_header (cmc$msg_ext_proc_element, mainframe_element^.element_name, display_control, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$element_id_kw] <= display_option) THEN
        product_id (1, 6) := mainframe_element^.product_id.product_number;
        product_id (7, 1) := mainframe_element^.product_id.underscore;
        product_id (8, 3) := mainframe_element^.product_id.model_number;
        put_subheader (cmc$msg_product_id, product_id, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$serial_number_kw] <= display_option) THEN
        put_subheader (cmc$msg_serial_number, mainframe_element^.serial_number, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$ioupn_kw] <= display_option) THEN
        put_subheader (cmc$msg_peripheral_driver_name, mainframe_element^.external_processor.
              peripheral_driver_name, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$state_kw] <= display_option) THEN
        cmp$display_element_state (mainframe_element^.element_name, iou_name, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$physical_connection_kw] <= display_option) THEN
        number := mainframe_element^.external_processor.physical_equipment_number;
        clp$convert_integer_to_rjstring (number, 10, TRUE, ' ', number_string, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        put_subheader (cmc$msg_equipment_number, number_string, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        cmp$display_upline_connection (mainframe_element^.external_processor.connection.io_port,
              display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;
      IF ($cmt$display_option [cmc$all_kw] <= display_option) OR
           ($cmt$display_option [cmc$application_info_kw] <= display_option) THEN
        display_application_info (mainframe_element^, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;
      IF ($cmt$display_option [cmc$all_kw] <= display_option) OR
           ($cmt$display_option [cmc$site_info_kw] <= display_option) THEN
        display_site_info (mainframe_element^, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$connection_status_kw] <= display_option) THEN
        display_conn_status (mainframe_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$active_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_active_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_external_proc_paths (cmc$active_paths, mainframe_element, mainframe_id, element_count,
              lc_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$inactive_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_inactive_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_external_proc_paths (cmc$inactive_paths, mainframe_element, mainframe_id, element_count,
              lc_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$disabled_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_disabled_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_external_proc_paths (cmc$disabled_paths, mainframe_element, mainframe_id, element_count,
              lc_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF $cmt$display_option[cmc$physical_paths_kw] <= display_option THEN
        put_subheader (cmc$msg_physical_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_external_proc_paths (cmc$physical_paths, mainframe_element, mainframe_id, element_count,
              lc_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

    END /main_program/;

  PROCEND cmp$display_external_proc;

?? TITLE := '    cmp$display_storage_dev_element', EJECT ??

  PROCEDURE cmp$display_storage_dev_element
    (    mainframe_element: ^cmt$element_definition;
         display_option: cmt$display_option;
         mainframe_id: pmt$mainframe_id;
         element_count: integer;
         lc_element: ^array [1 .. *] of cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      element_descriptor: cmt$element_descriptor,
      element_info: array [1 .. 1] of cmt$element_info_item,
      iou_name: cmt$element_name,
      j: 1 .. 26,
      ms_class: cmt$ms_class_members,
      ms_class_info: cmt$ms_class_info,
      ms_class_str: string(1),
      number: integer,
      number_string: string (10),
      product_id: string (10),
      recorded_vsn: rmt$recorded_vsn,
      volume_found: boolean;

    status.normal := TRUE;
    iou_name := 'IOU0';

  /main_program/
    BEGIN
      put_header (cmc$msg_storage_device_element, mainframe_element^.element_name, display_control, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$element_id_kw] <= display_option) THEN
        product_id (1, 6) := mainframe_element^.product_id.product_number;
        product_id (7, 1) := mainframe_element^.product_id.underscore;
        product_id (8, 3) := mainframe_element^.product_id.model_number;
        put_subheader (cmc$msg_product_id, product_id, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$serial_number_kw] <= display_option) THEN
        put_subheader (cmc$msg_serial_number, mainframe_element^.serial_number, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$state_kw] <= display_option) THEN
        cmp$display_element_state (mainframe_element^.element_name, iou_name, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$parity_status_kw] <= display_option) THEN
        IF (mainframe_element^.product_id.product_number = ' $5833') OR
              (mainframe_element^.product_id.product_number = ' $5838') OR
              (mainframe_element^.product_id.product_number = '$47444') THEN
          IF (mainframe_element^.product_id.model_number = '1P ') OR
                (mainframe_element^.product_id.model_number = '3P ') THEN
            cmp$display_parity_status (mainframe_element^.element_name, display_control, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$ms_class_kw] <= display_option) THEN
        element_info[1].selector := cmc$recorded_vsn;
        element_descriptor.element_type := cmc$storage_device_element;
        element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
        element_descriptor.peripheral_descriptor.element_name := mainframe_element^.element_name;
        cmp$get_element_information (element_descriptor, element_info, status);
        IF status.normal THEN
          IF element_info[1].item_returned THEN
            clp$horizontal_tab_display (display_control,cmc$starting_subheader_column, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            clp$put_partial_display (display_control, cmc$msg_msclass, clc$no_trim, amc$continue, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            cmp$get_ms_class_on_volume (element_info[1].recorded_vsn, volume_found, ms_class_info);
            IF volume_found THEN
              FOR ms_class := LOWERBOUND(ms_class_info) TO UPPERBOUND(ms_class_info) DO
                IF ms_class_info[ms_class] THEN
                  ms_class_str(1) := ms_class;
                  cmp$display_name(ms_class_str(1), display_control, status);
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;
                IFEND;
              FOREND;
            IFEND;
            clp$put_partial_display(display_control, ' ', clc$trim, amc$terminate, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
          IFEND;
        ELSEIF NOT status.normal THEN
          status.normal := TRUE; { Go on to display other information }
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$physical_connection_kw] <= display_option) THEN
        number := mainframe_element^.storage_device.physical_unit_number;
        clp$convert_integer_to_rjstring (number, 10, TRUE, ' ', number_string, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        put_subheader (cmc$msg_unit_number, number_string, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        cmp$display_upline_connection (mainframe_element^.storage_device.connection.port, display_control,
              status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;
      IF ($cmt$display_option [cmc$all_kw] <= display_option) OR
           ($cmt$display_option [cmc$application_info_kw] <= display_option) THEN
        display_application_info (mainframe_element^, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;
      IF ($cmt$display_option [cmc$all_kw] <= display_option) OR
           ($cmt$display_option [cmc$site_info_kw] <= display_option) THEN
        display_site_info (mainframe_element^, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$connection_status_kw] <= display_option) THEN
        display_conn_status (mainframe_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$active_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_active_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_storage_device_paths (cmc$active_paths, mainframe_element, mainframe_id, element_count,
              lc_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$inactive_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_inactive_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_storage_device_paths (cmc$inactive_paths, mainframe_element, mainframe_id, element_count,
              lc_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
         ($cmt$display_option[cmc$disabled_paths_kw] <= display_option) THEN
        put_subheader (cmc$msg_disabled_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_storage_device_paths (cmc$disabled_paths, mainframe_element, mainframe_id, element_count,
              lc_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF $cmt$display_option[cmc$physical_paths_kw] <= display_option THEN
        put_subheader (cmc$msg_physical_paths, ' ', display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        display_storage_device_paths (cmc$physical_paths, mainframe_element, mainframe_id, element_count,
              lc_element, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

    END /main_program/;

  PROCEND cmp$display_storage_dev_element;

?? TITLE := '    cmp$display_element_state', EJECT ??

  PROCEDURE cmp$display_element_state
    (    element_name: cmt$element_name;
         iou_name: cmt$element_name;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      index: integer,
      state: cmt$element_state,
      state_info_array: [STATIC, READ, oss$job_paged_literal] array [cmt$element_state] of
         string (4) := ['ON', 'OFF', 'DOWN'];

    status.normal := TRUE;
    /main_program/
      BEGIN
       cmp$get_element_state (element_name, iou_name, state, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;
       put_subheader (cmc$msg_state_info, state_info_array [state], display_control, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;
      END /main_program/;

  PROCEND cmp$display_element_state;

?? TITLE := '    cmp$display_parity_status', EJECT ??

  PROCEDURE cmp$display_parity_status
    (    element_name: cmt$element_name;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    CONST
      init_offln_drv_num = 0ff(16);    {NOSVE initialization value for 'off_line_drive_number'.}

    VAR
      off_msg1: [STATIC] string(35) :=' OFF (PHYSICAL UNIT xx IS OFF-LINE)',
      off_msg2: [STATIC] string(36) :=' OFF (PHYSICAL UNIT xx IS RESTORING)',
      parity_status: iot$unit_status,
      parity_status_info: string(39);

    status.normal := TRUE;
    cmp$get_parity_status_info (element_name, parity_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF parity_status.off_line_drive_number = init_offln_drv_num THEN
      parity_status_info := ' UNKNOWN                               ';
    ELSEIF parity_status.parity_protection_enabled THEN
      parity_status_info := ' ON                                    ';
    ELSE
      IF parity_status.restoring_drive THEN
        parity_status_info := off_msg2;
      ELSE
        parity_status_info := off_msg1;
      IFEND;
      cmp$ascii_decimal (^parity_status_info (21, *), 2, parity_status.
            off_line_drive_number);
    IFEND;
    put_subheader (cmc$msg_parity_status, parity_status_info, display_control, status);
  PROCEND cmp$display_parity_status;

?? TITLE := 'cmp$ascii_decimal', EJECT ??

  PROCEDURE cmp$ascii_decimal (msg: ^string ( * );
        number_of_characters: 1 .. 4;
        word: 0 .. 0ffff(16));

    VAR
      i: integer,
      k: integer,
      divisor: [STATIC] array [1 .. 4] of integer := [1, 10, 100, 1000];


    k := 1;
    FOR i := number_of_characters DOWNTO 1 DO
      msg^ (i) := CHR (((word DIV divisor [k]) MOD 10) + ORD ('0'));
      k := k + 1;
    FOREND;
  PROCEND cmp$ascii_decimal;

?? TITLE := '    cmp$display_upline_connection', EJECT ??

  PROCEDURE cmp$display_upline_connection
    (    upline_connection: array [ * ] of cmt$upline_connection;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      i: integer,
      mainframe_id: pmt$mainframe_id,
      path_name: string (80),
      subtitle_displayed: boolean;

    status.normal := TRUE;
    subtitle_displayed := FALSE;
  /main_program/
    BEGIN
      pmp$get_mainframe_id (mainframe_id, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
    /loop/
      FOR i := LOWERBOUND (upline_connection) TO UPPERBOUND (upline_connection) DO
        IF upline_connection [i].configured THEN
          IF NOT subtitle_displayed THEN
            clp$horizontal_tab_display (display_control, cmc$starting_subheader_column, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            IF upline_connection [i].upline_connection_type = cmc$data_channel_element THEN
              clp$put_partial_display (display_control, cmc$msg_channel_connections, clc$no_trim,
                    amc$continue, status);
            ELSE
              clp$put_partial_display (display_control, cmc$msg_controller_con, clc$no_trim, amc$continue,
                    status);
            IFEND;
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            subtitle_displayed := TRUE;
          IFEND;
          path_name := '  ';
          IF upline_connection [i].upline_connection_type = cmc$data_channel_element THEN
            path_name (1, 4) := upline_connection [i].iou;
            path_name (5, 1) := '/';
            path_name (6, *) := upline_connection [i].element_name;
          ELSE
            path_name (1, *) := upline_connection [i].element_name;
          IFEND;
          IF (upline_connection [i].upline_connection_type = cmc$data_channel_element) AND
             (upline_connection [i].mainframe_ownership <> mainframe_id) THEN
            CYCLE /loop/;
          IFEND;
          cmp$display_name (path_name, display_control, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;
      FOREND /loop/;

      clp$new_display_line (display_control, 0, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    END /main_program/;

  PROCEND cmp$display_upline_connection;

?? TITLE := '    cmp$display_ca_upline_conn', EJECT ??

  PROCEDURE cmp$display_ca_upline_conn
    (    upline_connection: cmt$upline_connection;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      path_name: string (80);

    status.normal := TRUE;

  /main_program/

    BEGIN

      IF upline_connection.configured THEN
        path_name := '  ';
        path_name (1, 4) := upline_connection.iou;
        path_name (5, 1) := '/';
        path_name (6, *) := upline_connection.element_name;
        cmp$display_name (path_name, display_control, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      clp$new_display_line (display_control, 0, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    END /main_program/;

  PROCEND cmp$display_ca_upline_conn;

?? TITLE := '    cmp$display_element_connection', EJECT ??

  PROCEDURE cmp$display_element_connection
    (    element_connection: array [ * ] of cmt$element_connection;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      i: integer;

    status.normal := TRUE;

  /main_program/
    BEGIN

      FOR i := LOWERBOUND (element_connection) TO UPPERBOUND
            (element_connection) DO
        IF element_connection [i].configured THEN
          cmp$display_name (element_connection [i].element_name, display_control, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;
      FOREND;

      clp$new_display_line (display_control, 0, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    END /main_program/;

  PROCEND cmp$display_element_connection;

?? TITLE := '    cmp$display_name', EJECT ??

  PROCEDURE cmp$display_name
    (    message: string ( * );
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      column_number: amt$page_width,
      i: integer,
      message_length: integer;

    status.normal := TRUE;

  /main_program/
    BEGIN

      message_length := STRLENGTH (message);

    /forloop/
      FOR i := 1 TO message_length DO
        IF message (i, 1) = ' ' THEN
          message_length := i - 1;
          EXIT /forloop/;
        IFEND;
      FOREND /forloop/;

      IF display_control.page_width < display_control.column_number +
            cmc$spacing + message_length THEN
        clp$new_display_line (display_control, 0, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        column_number := cmc$starting_name_column;
      ELSE
        column_number := display_control.column_number + cmc$spacing;
      IFEND;

      clp$horizontal_tab_display (display_control, column_number, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$put_partial_display (display_control, message, clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    END /main_program/;
  PROCEND cmp$display_name;

?? TITLE := '    determine_active_path', EJECT ??

  PROCEDURE determine_active_path
    (    channel_p: ^cmt$element_definition;
         downline_1_p: ^cmt$element_definition;
         downline_2_p: ^cmt$element_definition;
     VAR active: boolean;
     VAR disabled: boolean;
     VAR status: ost$status);

    VAR
      connection_status: cmt$connection_status,
      element_descriptor: cmt$element_descriptor;

    status.normal := TRUE;
    active := FALSE;
    disabled := FALSE;

    IF channel_p = NIL THEN
      RETURN;
    IFEND;

    IF channel_p^.element_type <> cmc$data_channel_element THEN
      RETURN;
    IFEND;

    cmp$get_driver_state (channel_p^.element_name, channel_p^.data_channel.iou, active, status);
    IF (NOT status.normal) OR (NOT active) THEN
      RETURN;
    IFEND;
    active := FALSE;

    IF downline_1_p = NIL THEN
      RETURN;
    IFEND;

    element_descriptor.element_type := channel_p^.element_type;
    element_descriptor.channel_descriptor.iou := channel_p^.data_channel.iou;
    element_descriptor.channel_descriptor.use_logical_identification := TRUE;
    element_descriptor.channel_descriptor.name := channel_p^.element_name;

    cmp$get_connection_status (element_descriptor, downline_1_p^.element_name, connection_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE connection_status OF
    = cmc$active =
      active := TRUE;
    = cmc$inactive =

    = cmc$disabled =
      disabled := TRUE;
    CASEND;

    IF NOT active THEN
      RETURN;
    IFEND;

    IF downline_2_p <> NIL THEN
      element_descriptor.element_type := downline_1_p^.element_type;
      element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
      element_descriptor.peripheral_descriptor.element_name := downline_1_p^.element_name;

      cmp$get_connection_status (element_descriptor, downline_2_p^.element_name, connection_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE connection_status OF
      = cmc$active =
        active := TRUE;
      = cmc$inactive =
        active := FALSE;
      = cmc$disabled =
        active := FALSE;
        disabled := TRUE;
      CASEND;

      IF NOT active THEN
        RETURN;
      IFEND;

      IF cmp$support_redundant_access (downline_1_p^.element_type, downline_1_p^.product_id) THEN
        cmp$determine_active_path (channel_p^, downline_1_p^, downline_2_p^, active, status);
        IF (NOT status.normal) OR (NOT active) THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

  PROCEND determine_active_path;

?? TITLE := '    display_application_info', EJECT ??

  PROCEDURE display_application_info
    (    element: cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      element_descriptor: cmt$element_descriptor,
      element_info: array [1 .. 1] of cmt$element_info_item,
      ignore: ost$status,
      string_p: ^string ( * );

    status.normal := TRUE;
    element_descriptor.element_type := element.element_type;
    element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
    element_descriptor.peripheral_descriptor.element_name := element.element_name;
    element_info [1].selector := cmc$application_string_size;
    cmp$get_element_information (element_descriptor, element_info, ignore);
    IF NOT ignore.normal THEN
      RETURN;
    IFEND;
    IF element_info [1].item_returned THEN
      IF element_info [1].application_info_string_size > 0 THEN
        PUSH string_p: [element_info [1].application_info_string_size];
        element_info [1].selector := cmc$application_information;
        element_info [1].application_information := string_p;
        cmp$get_element_information (element_descriptor, element_info, ignore);
        IF NOT ignore.normal THEN
          RETURN;
        IFEND;
        IF element_info [1].item_returned THEN
          put_subheader (cmc$msg_application_info, element_info [1].application_information^,
               display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND display_application_info;

?? TITLE := '    display_site_info', EJECT ??

  PROCEDURE display_site_info
    (    element: cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      element_descriptor: cmt$element_descriptor,
      element_info: array [1 .. 1] of cmt$element_info_item,
      ignore: ost$status,
      string_p: ^string ( * );

    status.normal := TRUE;
    element_descriptor.element_type := element.element_type;
    element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
    element_descriptor.peripheral_descriptor.element_name := element.element_name;
    element_info [1].selector := cmc$site_info_string_size;
    cmp$get_element_information (element_descriptor, element_info, ignore);
    IF NOT ignore.normal THEN
      RETURN;
    IFEND;
    IF element_info [1].item_returned THEN
      IF element_info [1].site_info_string_size > 0 THEN
        PUSH string_p: [element_info [1].site_info_string_size];
        element_info [1].selector := cmc$site_information;
        element_info [1].site_information := string_p;
        cmp$get_element_information (element_descriptor, element_info, ignore);
        IF NOT ignore.normal THEN
          RETURN;
        IFEND;
        IF element_info [1].item_returned THEN
          put_subheader (cmc$msg_site_info, element_info [1].site_information^, display_control
                     ,status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND display_site_info;
?? TITLE := '    display_ca_paths', EJECT ??

  PROCEDURE display_ca_paths
    (    path_option: cmt$path_types;
         mainframe_element: ^cmt$element_definition;
         mainframe_id: pmt$mainframe_id;
         element_count: integer;
         lc_element: ^array [1 .. *] of cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      downline_element: ^cmt$element_definition,
      downline_element_found: boolean,
      i: integer,
      path_found: boolean,
      upline_element: ^cmt$element_definition;

    status.normal := TRUE;
    path_found := FALSE;

    IF (mainframe_element^.channel_adapter.connection.channel.configured) AND
            (mainframe_element^.channel_adapter.connection.channel.mainframe_ownership = mainframe_id) THEN
      find_named_element (mainframe_element^.channel_adapter.connection.channel.element_name,
              mainframe_id, mainframe_element^.channel_adapter.connection.channel.iou, element_count,
              lc_element, upline_element, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      downline_element_found := FALSE;
      FOR i := LOWERBOUND (mainframe_element^.channel_adapter.connection.equipment) TO
              UPPERBOUND (mainframe_element^.channel_adapter.connection.equipment) DO
        IF mainframe_element^.channel_adapter.connection.equipment [i].configured THEN
          find_named_element (mainframe_element^.channel_adapter.connection.equipment [i].
                element_name, mainframe_id, upline_element^.data_channel.iou, element_count,
                lc_element, downline_element, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          downline_element_found := TRUE;
          display_path_status (path_option, upline_element, mainframe_element, downline_element,
                path_found, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND;
      IF NOT downline_element_found THEN
        display_path_status (path_option, upline_element, mainframe_element, NIL, path_found,
               display_control, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    IF NOT path_found THEN
      put_subheader ('  NONE', ' ', display_control, status);
    IFEND;

  PROCEND display_ca_paths;

?? TITLE := '    display_channel_paths', EJECT ??

  PROCEDURE display_channel_paths
    (    path_option: cmt$path_types;
         mainframe_element: ^cmt$element_definition;
         mainframe_id: pmt$mainframe_id;
         element_count: integer;
         lc_element: ^array [1 .. *] of cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      downline_element_1: ^cmt$element_definition,
      downline_element_2: ^cmt$element_definition,
      i: integer,
      j: integer,
      path_found: boolean;

    status.normal := TRUE;
    path_found := FALSE;

    FOR i := LOWERBOUND (mainframe_element^.data_channel.connection.equipment) TO
          UPPERBOUND (mainframe_element^.data_channel.connection.equipment) DO
      IF mainframe_element^.data_channel.connection.equipment [i].configured THEN
        find_named_element (mainframe_element^.data_channel.connection.equipment [i].element_name,
              mainframe_id, mainframe_element^.data_channel.iou, element_count, lc_element,
              downline_element_1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        CASE downline_element_1^.element_type OF
        = cmc$controller_element =
          FOR j := LOWERBOUND (downline_element_1^.controller.connection.unit) TO
                UPPERBOUND (downline_element_1^.controller.connection.unit) DO
            IF downline_element_1^.controller.connection.unit [j].configured THEN
              find_named_element (downline_element_1^.controller.connection.unit [j].element_name,
                    mainframe_id, mainframe_element^.data_channel.iou, element_count, lc_element,
                    downline_element_2, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              display_path_status (path_option, mainframe_element, downline_element_1, downline_element_2,
                    path_found, display_control, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          FOREND;
        = cmc$channel_adapter_element =
          FOR j := LOWERBOUND (downline_element_1^.channel_adapter.connection.equipment) TO
                UPPERBOUND (downline_element_1^.channel_adapter.connection.equipment) DO
            IF downline_element_1^.channel_adapter.connection.equipment [j].configured THEN
              find_named_element (downline_element_1^.channel_adapter.connection.equipment [j].
                    element_name, mainframe_id, mainframe_element^.data_channel.iou, element_count,
                    lc_element, downline_element_2, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              display_path_status (path_option, mainframe_element, downline_element_1, downline_element_2,
                    path_found, display_control, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          FOREND;
        ELSE
          display_path_status (path_option, mainframe_element, downline_element_1, NIL, path_found,
                display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        CASEND;
      IFEND;
    FOREND;

    IF NOT path_found THEN
      put_subheader ('  NONE', ' ', display_control, status);
    IFEND;

  PROCEND display_channel_paths;

?? TITLE := '    display_comm_paths', EJECT ??

  PROCEDURE display_comm_paths
    (    path_option: cmt$path_types;
         mainframe_element: ^cmt$element_definition;
         mainframe_id: pmt$mainframe_id;
         element_count: integer;
         lc_element: ^array [1 .. *] of cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      i: integer,
      path_found: boolean,
      upline_element: ^cmt$element_definition;

    status.normal := TRUE;
    path_found := FALSE;

    FOR i := LOWERBOUND (mainframe_element^.communications_element.connection.port) TO
          UPPERBOUND (mainframe_element^.communications_element.connection.port) DO
      IF (mainframe_element^.communications_element.connection.port [i].configured) AND
            (mainframe_element^.communications_element.connection.port [i].mainframe_ownership =
            mainframe_id) THEN
        find_named_element (mainframe_element^.communications_element.connection.port [i].element_name,
              mainframe_id, mainframe_element^.communications_element.connection.port [i].iou,
              element_count, lc_element, upline_element, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        display_path_status (path_option, upline_element, mainframe_element, NIL, path_found, display_control,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    IF NOT path_found THEN
      put_subheader ('  NONE', ' ', display_control, status);
    IFEND;

  PROCEND display_comm_paths;

?? TITLE := '    display_conn_status', EJECT ??

  PROCEDURE display_conn_status
    (    mainframe_element: ^cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      connection: cmt$connection,
      connection_count: integer,
      connection_list: ^array [1 .. * ] of cmt$connection,
      i: integer;

    status.normal := TRUE;

    put_subheader (cmc$msg_connection_status, ' ', display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, cmc$upline_connection_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, cmc$msg_upline_element, clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, cmc$connection_status_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, cmc$msg_connect_status_header, clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, cmc$downline_connection_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, cmc$msg_downline_element, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    connection_count := 16;
    REPEAT
      PUSH connection_list: [1 .. connection_count];
      cmp$get_connection_list (mainframe_element^, connection_count, connection_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    UNTIL connection_count <= UPPERBOUND (connection_list^);

    FOR i := 1 TO connection_count DO
      connection := connection_list^ [i];

      clp$horizontal_tab_display (display_control, cmc$upline_connection_column, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, connection.upline_element, clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$horizontal_tab_display (display_control, cmc$connection_status_column, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE connection.status OF
      = cmc$active =
        clp$put_partial_display (display_control, 'ACTIVE', clc$trim, amc$continue, status);
      = cmc$inactive =
        clp$put_partial_display (display_control, 'INACTIVE', clc$trim, amc$continue, status);
      = cmc$disabled =
        clp$put_partial_display (display_control, 'DISABLED', clc$trim, amc$continue, status);
      CASEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$horizontal_tab_display (display_control, cmc$downline_connection_column, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, connection.downline_element, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND display_conn_status;

?? TITLE := '    display_controller_paths', EJECT ??

  PROCEDURE display_controller_paths
    (    path_option: cmt$path_types;
         mainframe_element: ^cmt$element_definition;
         mainframe_id: pmt$mainframe_id;
         element_count: integer;
         lc_element: ^array [1 .. *] of cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      downline_element: ^cmt$element_definition,
      i: integer,
      j: integer,
      path_found: boolean,
      upline_element: ^cmt$element_definition;

    status.normal := TRUE;
    path_found := FALSE;

    FOR i := LOWERBOUND (mainframe_element^.controller.connection.port) TO
          UPPERBOUND (mainframe_element^.controller.connection.port) DO
      IF (mainframe_element^.controller.connection.port [i].configured) AND
            (mainframe_element^.controller.connection.port [i].mainframe_ownership = mainframe_id) THEN
        find_named_element (mainframe_element^.controller.connection.port [i].element_name,
              mainframe_id, mainframe_element^.controller.connection.port [i].iou, element_count,
              lc_element, upline_element, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        FOR j := LOWERBOUND (mainframe_element^.controller.connection.unit) TO
              UPPERBOUND (mainframe_element^.controller.connection.unit) DO
          IF mainframe_element^.controller.connection.unit [j].configured THEN
            find_named_element (mainframe_element^.controller.connection.unit [j].element_name,
                  mainframe_id, upline_element^.data_channel.iou, element_count, lc_element,
                  downline_element, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            display_path_status (path_option, upline_element, mainframe_element, downline_element, path_found,
                  display_control, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        FOREND;
      IFEND;
    FOREND;

    IF NOT path_found THEN
      put_subheader ('  NONE', ' ', display_control, status);
    IFEND;

  PROCEND display_controller_paths;

?? TITLE := '    display_external_proc_paths', EJECT ??

  PROCEDURE display_external_proc_paths
    (    path_option: cmt$path_types;
         mainframe_element: ^cmt$element_definition;
         mainframe_id: pmt$mainframe_id;
         element_count: integer;
         lc_element: ^array [1 .. *] of cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      i: integer,
      path_found: boolean,
      upline_element: ^cmt$element_definition;

    status.normal := TRUE;
    path_found := FALSE;

    FOR i := LOWERBOUND (mainframe_element^.external_processor.connection.io_port) TO
          UPPERBOUND (mainframe_element^.external_processor.connection.io_port) DO
      IF (mainframe_element^.external_processor.connection.io_port [i].configured) AND
            (mainframe_element^.external_processor.connection.io_port [i].mainframe_ownership =
            mainframe_id) THEN
        find_named_element (mainframe_element^.external_processor.connection.io_port [i].element_name,
              mainframe_id, mainframe_element^.external_processor.connection.io_port [i].iou,
              element_count, lc_element, upline_element, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        display_path_status (path_option, upline_element, mainframe_element, NIL, path_found, display_control,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    IF NOT path_found THEN
      put_subheader ('  NONE', ' ', display_control, status);
    IFEND;

  PROCEND display_external_proc_paths;

?? TITLE := '    display_path_status', EJECT ??

  PROCEDURE display_path_status
    (    path_option: cmt$path_types;
         channel_element: ^cmt$element_definition;
         downline_element_1: ^cmt$element_definition;
         downline_element_2: ^cmt$element_definition;
     VAR path_found: boolean;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      active_path: boolean,
      address_string: ost$string,
      disabled_path: boolean;

    status.normal := TRUE;

    determine_active_path (channel_element, downline_element_1, downline_element_2, active_path,
          disabled_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE path_option OF
    = cmc$active_paths =
      IF NOT active_path THEN
        RETURN;
      IFEND;
    = cmc$inactive_paths =
      IF active_path OR disabled_path THEN
        RETURN;
      IFEND;
    = cmc$disabled_paths =
      IF NOT disabled_path THEN
        RETURN;
      IFEND;
    ELSE
    CASEND;

    path_found := TRUE;

    clp$horizontal_tab_display (display_control, cmc$starting_subheader_column + 2, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, channel_element^.data_channel.iou, clc$trim, amc$continue,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '.', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, channel_element^.element_name, clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '.', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, downline_element_1^.element_name, clc$trim, amc$continue,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF downline_element_2 <> NIL THEN
      clp$put_partial_display (display_control, '.', clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, downline_element_2^.element_name, clc$trim, amc$continue,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    clp$horizontal_tab_display (display_control, cmc$status_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, channel_element^.data_channel.iou, clc$trim, amc$continue,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '.', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, channel_element^.element_name, clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE downline_element_1^.element_type OF

    = cmc$channel_adapter_element =
      clp$put_partial_display (display_control, '.C', clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$convert_integer_to_string (downline_element_1^.channel_adapter.physical_equipment_number, 10, FALSE,
            address_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_partial_display (display_control, address_string.value, clc$trim, amc$terminate, status);

    = cmc$communications_element =
      clp$put_partial_display (display_control, '.C', clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$convert_integer_to_string (downline_element_1^.communications_element.physical_equipment_number,
            10, FALSE, address_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_partial_display (display_control, address_string.value, clc$trim, amc$terminate, status);

    = cmc$controller_element =
      clp$put_partial_display (display_control, '.C', clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$convert_integer_to_string (downline_element_1^.controller.physical_equipment_number, 10, FALSE,
            address_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_partial_display (display_control, address_string.value, clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_partial_display (display_control, '.U', clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$convert_integer_to_string (downline_element_2^.storage_device.physical_unit_number, 10, FALSE,
            address_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_partial_display (display_control, address_string.value, clc$trim, amc$terminate, status);

    = cmc$storage_device_element =
      clp$put_partial_display (display_control, '.U', clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$convert_integer_to_string (downline_element_1^.storage_device.physical_unit_number, 10, FALSE,
            address_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_partial_display (display_control, address_string.value, clc$trim, amc$terminate, status);

    = cmc$external_processor_element =
      clp$put_partial_display (display_control, '.C', clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$convert_integer_to_string (downline_element_1^.external_processor.physical_equipment_number,
            10, FALSE, address_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_partial_display (display_control, address_string.value, clc$trim, amc$terminate, status);
    CASEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_path_status;

?? TITLE := '    display_storage_device_paths', EJECT ??

  PROCEDURE display_storage_device_paths
    (    path_option: cmt$path_types;
         mainframe_element: ^cmt$element_definition;
         mainframe_id: pmt$mainframe_id;
         element_count: integer;
         lc_element: ^array [1 .. *] of cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      i: integer,
      j: integer,
      path_found: boolean,
      upline_element_1: ^cmt$element_definition,
      upline_element_2: ^cmt$element_definition;

    status.normal := TRUE;
    path_found := FALSE;

    FOR i := LOWERBOUND (mainframe_element^.storage_device.connection.port) TO
          UPPERBOUND (mainframe_element^.storage_device.connection.port) DO
      IF mainframe_element^.storage_device.connection.port [i].configured THEN
        CASE mainframe_element^.storage_device.connection.port [i].upline_connection_type OF
        = cmc$data_channel_element =
          IF mainframe_element^.storage_device.connection.port [i].mainframe_ownership = mainframe_id THEN
            find_named_element (mainframe_element^.storage_device.connection.port [i].element_name,
                  mainframe_id, mainframe_element^.storage_device.connection.port [i].iou, element_count,
                  lc_element, upline_element_1, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            display_path_status (path_option, upline_element_1, mainframe_element, NIL, path_found,
                  display_control, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        = cmc$controller_element =
          find_named_element (mainframe_element^.storage_device.connection.port [i].element_name,
                mainframe_id, mainframe_element^.storage_device.connection.port [i].iou, element_count,
                lc_element, upline_element_1, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          FOR j := LOWERBOUND (upline_element_1^.controller.connection.port) TO
                UPPERBOUND (upline_element_1^.controller.connection.port) DO
            IF (upline_element_1^.controller.connection.port [j].configured) AND
                  (upline_element_1^.controller.connection.port [j].mainframe_ownership = mainframe_id) THEN
              find_named_element (upline_element_1^.controller.connection.port [j].element_name,
                    mainframe_id, upline_element_1^.controller.connection.port [j].iou, element_count,
                    lc_element, upline_element_2, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              display_path_status (path_option, upline_element_2, upline_element_1, mainframe_element,
                    path_found, display_control, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          FOREND;
        CASEND;
      IFEND;
    FOREND;

    IF NOT path_found THEN
      put_subheader ('  NONE', ' ', display_control, status);
    IFEND;

  PROCEND display_storage_device_paths;

?? TITLE := '    find_named_element', EJECT ??

  PROCEDURE find_named_element
    (    name: cmt$element_name;
         mainframe_id: pmt$mainframe_id;
         iou: cmt$element_name;
         element_count: integer;
         lc_element: ^array [1 .. *] of cmt$element_definition;
     VAR element: ^cmt$element_definition;
     VAR status: ost$status);

    VAR
      i: integer;

    status.normal := TRUE;

    FOR i := 1 TO element_count DO
      IF lc_element^ [i].element_type = cmc$data_channel_element THEN
        IF (lc_element^ [i].element_name = name) AND (lc_element^ [i].data_channel.iou = iou) AND
              (lc_element^ [i].data_channel.mainframe_ownership = mainframe_id) THEN
          element := ^lc_element^ [i];
          RETURN;
        IFEND;
      ELSE
        IF lc_element^ [i].element_name = name THEN
          element := ^lc_element^ [i];
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_element_not_found, name, status);

  PROCEND find_named_element;

?? TITLE := '    put_header', EJECT ??

  PROCEDURE put_header
    (    descriptor: string ( * );
         value: string ( * );
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    status.normal := TRUE;

    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, cmc$starting_element_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, descriptor, clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, value, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND put_header;

?? TITLE := '    put_subheader', EJECT ??

  PROCEDURE put_subheader
    (    descriptor: string ( * );
         value: string ( * );
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    status.normal := TRUE;

    clp$horizontal_tab_display (display_control, cmc$starting_subheader_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, descriptor, clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, value, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND put_subheader;

MODEND cmm$logical_configuration_mgr;
*DECK DECK=CMM$LOGICAL_CONFIGURATION_UTIL EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Configuration Management: Logical Configuration Utility' ??
MODULE cmm$logical_configuration_util;

{ PURPOSE:
{   This module provides operator status and control interfaces to the Logical Configuration structures of
{ NOS/VE.  These include interfaces used during during, as well as after, deadstart.  Included are commands
{ relating to mass storage devices, tape label initialization, and network configuration, as well as more
{ general configuration status and control.

?? NEWTITLE := 'Global Declarations Referenced By This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc clc$standard_file_names
*copyc cld$parameter_limits
*copyc cle$ecc_file_reference
*copyc cle$ecc_parsing
*copyc clt$function_proc_table_entry
*copyc clt$function_processor_table
*copyc clt$parameter_value_table
*copyc clt$path_display_chunks
*copyc clt$string_value
*copyc clt$work_area
*copyc cmc$logical_unit_constants
*copyc cme$logical_configuration_mgr
*copyc cme$logical_configuration_utl
*copyc cme$reserve_element
*copyc cmk$keypoints
*copyc cmt$configuration_state
*copyc cmt$cpu_element_definition
*copyc cmt$element_definition
*copyc cmt$element_name
*copyc cmt$element_state
*copyc cmt$lcu_display_option_key
*copyc cmt$mass_storage_volume
*copyc cmt$unit_class
*copyc cmt$unit_type
*copyc dmc$k_multiplier
*copyc dmt$allocation_size
*copyc dmt$error_condition_codes
*copyc dmt$flaw_dau_definition
*copyc dmt$flaw_duplication
*copyc dmt$log_flaw_init_data
*copyc dmt$transfer_size
*copyc dmt$volume_attribute_info
*copyc dmt$volume_attributes
*copyc jmc$system_family
*copyc nac$network_catalog
*copyc nac$sk_max_host_name_size
*copyc nat$channel_descriptor
*copyc nat$display_option
*copyc nat$network_descriptor
*copyc ofe$error_codes
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc ost$caller_identifier
*copyc ost$cpu_down_state_reason
*copyc ost$name
*copyc ost$processor_id
*copyc ost$processor_id_set
*copyc rmc$condition_code_limits
*copyc rmd$volume_declarations
*copyc rmt$density
*copyc stt$number_of_members
*copyc stt$volume_info
*copyc stt$volume_list
?? POP ??

*copyc amp$copy_file
*copyc amp$get_file_attributes
*copyc amp$get_next
*copyc amp$put_partial
*copyc amp$return
*copyc avp$configuration_administrator
*copyc avp$get_capability
*copyc avp$removable_media_operator
*copyc avp$system_displays
*copyc avp$system_operator
*copyc clp$begin_utility
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_string_to_file
*copyc clp$convert_value_to_string
*copyc clp$count_list_elements
*copyc clp$end_scan_command_file
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$new_display_line
*copyc clp$open_display
*copyc clp$open_display_file
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_job_output
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$scan_command_file
*copyc clp$scan_command_line
*copyc clp$trimmed_string_size
*copyc cmp$activate_volume
*copyc cmp$add_class_to_element
*copyc cmp$change_cpu_element_state
*copyc cmp$determine_tape_element
*copyc cmp$change_volume_attributes
*copyc cmp$change_volume_attributes
*copyc cmp$check_init_status
*copyc cmp$clean_up_error_count
*copyc cmp$clean_up_network_list
*copyc cmp$copy_active_configuration
*copyc cmp$cpus_physically_configured
*copyc cmp$deadstart_phase
*copyc cmp$display_named_element
*copyc cmp$display_type_elements
*copyc cmp$echo_command
*copyc cmp$echo_errors
*copyc cmp$enable_production_r3
*copyc cmp$form_network_list
*copyc cmp$free_command_list
*copyc cmp$generate_error_listing
*copyc cmp$get_cpu_element_r3
*copyc cmp$get_element_r3
*copyc cmp$get_element_state
*copyc cmp$get_element_state_via_lun
*copyc cmp$get_element_information
*copyc cmp$get_logical_attributes
*copyc cmp$get_logical_unit_number_r3
*copyc cmp$get_ms_class_on_volume
*copyc cmp$get_ms_status_via_lun
*copyc cmp$get_ms_volume_info
*copyc cmp$get_ms_volumes
*copyc cmp$get_number_of_element
*copyc cmp$get_physical_attributes
*copyc cmp$get_sys_dev_rec_vsn
*copyc cmp$get_unit_number_via_vsn
*copyc cmp$get_volume_attributes
*copyc cmp$get_volumes_active
*copyc cmp$get_volume_attributes
*copyc cmp$hide_commands
*copyc cmp$initialize_ms_volume
*copyc cmp$lock_set_by_current_task
*copyc cmp$manage_lock_r3
*copyc cmp$obtain_max_volume_index
*copyc cmp$obtain_volumes
*copyc cmp$open_scratch_err_file
*copyc cmp$post_deadstart
*copyc cmp$process_das_restore
*copyc cmp$process_state_change
*copyc cmp$process_force_format
*copyc cmp$process_outstanding_sc_req
*copyc cmp$valid_channel_name
*copyc cmp$validate_cip_path
*copyc cmp$validate_ms_class
*copyc cmp$validate_set_membership
*copyc cmp$volume_online
*copyc cmv$error_count
*copyc cmv$network_descriptor_p
*copyc dmp$define_remove_ms_flaw
*copyc dmp$identify_flawed_daus
*copyc fsp$close_file
*copyc fsp$open_file
*copyc ifp$invoke_pause_utility
*copyc jmp$system_job
*copyc nap$display_network_config
*copyc nap$get_file_cycle_count
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$unpack_status_identifier
*copyc osv$lower_to_upper
*copyc pfp$define
*copyc pfp$define_catalog
*copyc pfp$overhaul_set
*copyc pfp$purge
*copyc pmp$continue_to_cause
*copyc pmp$get_job_names
*copyc pmp$get_unique_name
*copyc pmp$zero_out_table
*copyc stp$add_member_vol_to_set
*copyc stp$create_set
*copyc cmv$lcu_command_list
*copyc cmv$lcu_function_list
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared By This Module', EJECT ??

  VAR
    cmv$get_attr: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 1] of amt$get_item := [[ * , amc$null_attribute]];

  VAR
    cmv$utility_name: [STATIC, READ, oss$job_paged_literal] ost$name := 'LOGICAL_CONFIGURATION_UTILITY';

?? OLDTITLE ??

?? NEWTITLE := 'LOGICAL_CONFIGURATION_UTILITY', EJECT ??

  PROCEDURE [XDCL, #GATE] logical_configuration_utility
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (cmm$lcu) logical_configuration_utility, lcu (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 11, 2, 12, 34, 56, 789], clc$command, 1, 1, 0, 0, 0, 0, 1, 'CMM$LCU'],
            [['STATUS                         ', clc$nominal_entry, 1]], [

{ STATUS

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ STATUS

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

{ table lcu_command_list type=command section_name=oss$job_paged_literal ..
{                s=local
{ command (add_volume_to_set               ,addvts) add_volume_to_set      ..
{           cm=local
{ command (change_element_state            ,chaes) change_element_state    ..
{             cm=local
{ command (change_ms_class                 ,change_ms_classes,chamc,       ..
{      chamsc)    change_ms_class cm=local
{ command (change_ms_volume                ,chamv,chamsv) change_ms_volume ..
{                cm=local
{ command (create_set                      ,cres) create_set cm=local
{ command (define_host_network             ,defhn) cmp$define_host_network ..
{                cm=local     availability=hidden
{ command (define_ms_flaw                  ,defmf,defmsf) define_ms_flaw   ..
{           cm=local
{ command (define_network_connection       ,defnc)              ..
{   cmp$define_network_connection cm=local                           ..
{   availability=hidden
{ command (define_tcpip_host               ,defth) cmp$define_tcpip_host   ..
{         cm=local availability=hidden
{ command (display_element_status          ,dises) display_element_status  ..
{         cm=local
{ command (display_mainframe_configuration ,dismc)              ..
{   cmp$display_mf_configuration cm=local
{ command (display_ms_class                ,display_ms_classes,dismsc)     ..
{         display_ms_class cm=local
{ command (display_ms_flaws                ,display_ms_flaw,dismsf)        ..
{         display_ms_flaw cm=local
{ command (display_ms_volume               ,dismv,dismsv)              ..
{   display_ms_volume cm=local
{ command (display_network_configuration   ,disnc)              ..
{   cmp$display_netw_configuration cm=local
{ command (display_processor_state         ,disps) display_processor_state ..
{                cm=local
{ command (enable_production               ,enap) enable_production        ..
{         cm=local
{ command (format_reinstated_parity_unit   ,forrpu)       ..
{   format_reinstated_parity_unit cm=local
{ command (initialize_ms_volume            ,inimv,inimsv)              ..
{   initialize_ms_volume cm=local
{ command (initiate_das_restore            ,inidr)    initiate_das_restore ..
{      cm=local
{ command (install_network_configuration   ,insnc)              ..
{   install_network_configuration cm=local
{ command (quit                            ,qui) quit cm=local
{ command (remove_ms_flaw                  ,remmf,remmsf) remove_ms_flaw   ..
{           cm=local
{ command (verify_network_configuration    ,vernc)              ..
{   verify_network_configuration cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  lcu_command_list: [STATIC, READ, oss$job_paged_literal]
      ^clt$command_table := ^lcu_command_list_entries,

  lcu_command_list_entries: [STATIC, READ, oss$job_paged_literal] array
      [1 .. 57] of clt$command_table_entry := [
  {} ['ADDVTS                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^add_volume_to_set],
  {} ['ADD_VOLUME_TO_SET              ', clc$nominal_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^add_volume_to_set],
  {} ['CHAES                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^change_element_state],
  {} ['CHAMC                          ', clc$alias_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^change_ms_class],
  {} ['CHAMSC                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^change_ms_class],
  {} ['CHAMSV                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^change_ms_volume],
  {} ['CHAMV                          ', clc$alias_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^change_ms_volume],
  {} ['CHANGE_ELEMENT_STATE           ', clc$nominal_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^change_element_state],
  {} ['CHANGE_MS_CLASS                ', clc$nominal_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^change_ms_class],
  {} ['CHANGE_MS_CLASSES              ', clc$alias_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^change_ms_class],
  {} ['CHANGE_MS_VOLUME               ', clc$nominal_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^change_ms_volume],
  {} ['CREATE_SET                     ', clc$nominal_entry,
        clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
        ^create_set],
  {} ['CRES                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
        ^create_set],
  {} ['DEFHN                          ', clc$abbreviation_entry,
        clc$hidden_entry, 6, clc$automatically_log, clc$linked_call,
        ^cmp$define_host_network],
  {} ['DEFINE_HOST_NETWORK            ', clc$nominal_entry,
        clc$hidden_entry, 6, clc$automatically_log, clc$linked_call,
        ^cmp$define_host_network],
  {} ['DEFINE_MS_FLAW                 ', clc$nominal_entry,
        clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
        ^define_ms_flaw],
  {} ['DEFINE_NETWORK_CONNECTION      ', clc$nominal_entry,
        clc$hidden_entry, 8, clc$automatically_log, clc$linked_call,
        ^cmp$define_network_connection],
  {} ['DEFINE_TCPIP_HOST              ', clc$nominal_entry,
        clc$hidden_entry, 9, clc$automatically_log, clc$linked_call,
        ^cmp$define_tcpip_host],
  {} ['DEFMF                          ', clc$alias_entry,
        clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
        ^define_ms_flaw],
  {} ['DEFMSF                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
        ^define_ms_flaw],
  {} ['DEFNC                          ', clc$abbreviation_entry,
        clc$hidden_entry, 8, clc$automatically_log, clc$linked_call,
        ^cmp$define_network_connection],
  {} ['DEFTH                          ', clc$abbreviation_entry,
        clc$hidden_entry, 9, clc$automatically_log, clc$linked_call,
        ^cmp$define_tcpip_host],
  {} ['DISES                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 10, clc$automatically_log, clc$linked_call,
        ^display_element_status],
  {} ['DISMC                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 11, clc$automatically_log, clc$linked_call,
        ^cmp$display_mf_configuration],
  {} ['DISMSC                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 12, clc$automatically_log, clc$linked_call,
        ^display_ms_class],
  {} ['DISMSF                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 13, clc$automatically_log, clc$linked_call,
        ^display_ms_flaw],
  {} ['DISMSV                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 14, clc$automatically_log, clc$linked_call,
        ^display_ms_volume],
  {} ['DISMV                          ', clc$alias_entry,
        clc$normal_usage_entry, 14, clc$automatically_log, clc$linked_call,
        ^display_ms_volume],
  {} ['DISNC                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 15, clc$automatically_log, clc$linked_call,
        ^cmp$display_netw_configuration],
  {} ['DISPLAY_ELEMENT_STATUS         ', clc$nominal_entry,
        clc$normal_usage_entry, 10, clc$automatically_log, clc$linked_call,
        ^display_element_status],
  {} ['DISPLAY_MAINFRAME_CONFIGURATION', clc$nominal_entry,
        clc$normal_usage_entry, 11, clc$automatically_log, clc$linked_call,
        ^cmp$display_mf_configuration],
  {} ['DISPLAY_MS_CLASS               ', clc$nominal_entry,
        clc$normal_usage_entry, 12, clc$automatically_log, clc$linked_call,
        ^display_ms_class],
  {} ['DISPLAY_MS_CLASSES             ', clc$alias_entry,
        clc$normal_usage_entry, 12, clc$automatically_log, clc$linked_call,
        ^display_ms_class],
  {} ['DISPLAY_MS_FLAW                ', clc$alias_entry,
        clc$normal_usage_entry, 13, clc$automatically_log, clc$linked_call,
        ^display_ms_flaw],
  {} ['DISPLAY_MS_FLAWS               ', clc$nominal_entry,
        clc$normal_usage_entry, 13, clc$automatically_log, clc$linked_call,
        ^display_ms_flaw],
  {} ['DISPLAY_MS_VOLUME              ', clc$nominal_entry,
        clc$normal_usage_entry, 14, clc$automatically_log, clc$linked_call,
        ^display_ms_volume],
  {} ['DISPLAY_NETWORK_CONFIGURATION  ', clc$nominal_entry,
        clc$normal_usage_entry, 15, clc$automatically_log, clc$linked_call,
        ^cmp$display_netw_configuration],
  {} ['DISPLAY_PROCESSOR_STATE        ', clc$nominal_entry,
        clc$normal_usage_entry, 16, clc$automatically_log, clc$linked_call,
        ^display_processor_state],
  {} ['DISPS                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 16, clc$automatically_log, clc$linked_call,
        ^display_processor_state],
  {} ['ENABLE_PRODUCTION              ', clc$nominal_entry,
        clc$normal_usage_entry, 17, clc$automatically_log, clc$linked_call,
        ^enable_production],
  {} ['ENAP                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 17, clc$automatically_log, clc$linked_call,
        ^enable_production],
  {} ['FORMAT_REINSTATED_PARITY_UNIT  ', clc$nominal_entry,
        clc$normal_usage_entry, 18, clc$automatically_log, clc$linked_call,
        ^format_reinstated_parity_unit],
  {} ['FORRPU                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 18, clc$automatically_log, clc$linked_call,
        ^format_reinstated_parity_unit],
  {} ['INIDR                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 20, clc$automatically_log, clc$linked_call,
        ^initiate_das_restore],
  {} ['INIMSV                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 19, clc$automatically_log, clc$linked_call,
        ^initialize_ms_volume],
  {} ['INIMV                          ', clc$alias_entry,
        clc$normal_usage_entry, 19, clc$automatically_log, clc$linked_call,
        ^initialize_ms_volume],
  {} ['INITIALIZE_MS_VOLUME           ', clc$nominal_entry,
        clc$normal_usage_entry, 19, clc$automatically_log, clc$linked_call,
        ^initialize_ms_volume],
  {} ['INITIATE_DAS_RESTORE           ', clc$nominal_entry,
        clc$normal_usage_entry, 20, clc$automatically_log, clc$linked_call,
        ^initiate_das_restore],
  {} ['INSNC                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 21, clc$automatically_log, clc$linked_call,
        ^install_network_configuration],
  {} ['INSTALL_NETWORK_CONFIGURATION  ', clc$nominal_entry,
        clc$normal_usage_entry, 21, clc$automatically_log, clc$linked_call,
        ^install_network_configuration],
  {} ['QUI                            ', clc$abbreviation_entry,
        clc$normal_usage_entry, 22, clc$automatically_log, clc$linked_call,
        ^quit],
  {} ['QUIT                           ', clc$nominal_entry,
        clc$normal_usage_entry, 22, clc$automatically_log, clc$linked_call,
        ^quit],
  {} ['REMMF                          ', clc$alias_entry,
        clc$normal_usage_entry, 23, clc$automatically_log, clc$linked_call,
        ^remove_ms_flaw],
  {} ['REMMSF                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 23, clc$automatically_log, clc$linked_call,
        ^remove_ms_flaw],
  {} ['REMOVE_MS_FLAW                 ', clc$nominal_entry,
        clc$normal_usage_entry, 23, clc$automatically_log, clc$linked_call,
        ^remove_ms_flaw],
  {} ['VERIFY_NETWORK_CONFIGURATION   ', clc$nominal_entry,
        clc$normal_usage_entry, 24, clc$automatically_log, clc$linked_call,
        ^verify_network_configuration],
  {} ['VERNC                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 24, clc$automatically_log, clc$linked_call,
        ^verify_network_configuration]];

?? POP ??

{ table lcu_function_list type=function section_name=oss$job_paged_literal scope=local
{ function $active_sets                   cmp$$active_sets xref
{ function $active_set_families           cmp$$active_set_families xref
{ function $active_set_members            cmp$$active_set_members xref
{ function $mass_storage_class_members    cmp$$mass_storage_class_members xref
{ function ($channel_port                 $cp) cmp$$channel_port xref
{ function $element                       cmp$$element xref
{ function ($physical_address             $pa) cmp$$physical_address xref
{ function $storage_device_name          cmp$$storage_device_name xref
{ function $system_set_name              cmp$$system_set_name xref
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  lcu_function_list: [STATIC, READ, oss$job_paged_literal] ^clt$function_processor_table :=
      ^lcu_function_list_entries,

  lcu_function_list_entries: [STATIC, READ, oss$job_paged_literal] array [1 .. 11] of
      clt$function_proc_table_entry := [
  {} ['$ACTIVE_SETS                   ', clc$nominal_entry, clc$normal_usage_entry, 1,
        clc$linked_call, ^cmp$$active_sets],
  {} ['$ACTIVE_SET_FAMILIES           ', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$linked_call, ^cmp$$active_set_families],
  {} ['$ACTIVE_SET_MEMBERS            ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$linked_call, ^cmp$$active_set_members],
  {} ['$CHANNEL_PORT                  ', clc$nominal_entry, clc$normal_usage_entry, 5,
        clc$linked_call, ^cmp$$channel_port],
  {} ['$CP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
        clc$linked_call, ^cmp$$channel_port],
  {} ['$ELEMENT                       ', clc$nominal_entry, clc$normal_usage_entry, 6,
        clc$linked_call, ^cmp$$element],
  {} ['$MASS_STORAGE_CLASS_MEMBERS    ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$linked_call, ^cmp$$mass_storage_class_members],
  {} ['$PA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
        clc$linked_call, ^cmp$$physical_address],
  {} ['$PHYSICAL_ADDRESS              ', clc$nominal_entry, clc$normal_usage_entry, 7,
        clc$linked_call, ^cmp$$physical_address],
  {} ['$STORAGE_DEVICE_NAME           ', clc$nominal_entry, clc$normal_usage_entry, 8,
        clc$linked_call, ^cmp$$storage_device_name],
  {} ['$SYSTEM_SET_NAME               ', clc$nominal_entry, clc$normal_usage_entry, 9,
        clc$linked_call, ^cmp$$system_set_name]];

  PROCEDURE [XREF] cmp$$active_sets
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] cmp$$active_set_families
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] cmp$$active_set_members
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] cmp$$channel_port
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] cmp$$element
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] cmp$$mass_storage_class_members
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] cmp$$physical_address
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] cmp$$storage_device_name
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] cmp$$system_set_name
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? POP ??

?? NEWTITLE := '   abort_handler', EJECT ??

   PROCEDURE abort_handler
     (    condition: pmt$condition;
          p_condition_info: ^pmt$condition_information;
          p_stack: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

     VAR
       system_supplied_name: jmt$system_supplied_name;

     CASE condition.selector OF

     = pmc$block_exit_processing =
       IF cmp$lock_set_by_current_task (cmc$configuration_administrator) THEN
         cmp$manage_lock_r3 (cmc$configuration_administrator, TRUE,
                  system_supplied_name, status);
       IFEND;

       IF cmp$lock_set_by_current_task (cmc$removable_media_operation)  THEN
         cmp$manage_lock_r3 (cmc$removable_media_operation, TRUE,
                system_supplied_name, status);
       IFEND;
     ELSE
       pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
     CASEND;

   PROCEND abort_handler;

?? OLDTITLE ??

    VAR
      utility_attributes_p: ^clt$utility_attributes;

    status.normal := TRUE;
  /main_program/
    BEGIN
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      osp$establish_block_exit_hndlr (^abort_handler);
      cmp$hide_commands (lcu_command_list, lcu_function_list);

      PUSH utility_attributes_p: [1 .. 5];
      utility_attributes_p^ [1].key := clc$utility_command_search_mode;
      utility_attributes_p^ [1].command_search_mode := clc$global_command_search;
      utility_attributes_p^ [2].key := clc$utility_command_table;
      utility_attributes_p^ [2].command_table := cmv$lcu_command_list;
      utility_attributes_p^ [3].key := clc$utility_function_proc_table;
      utility_attributes_p^ [3].function_processor_table := cmv$lcu_function_list;
      utility_attributes_p^ [4].key := clc$utility_prompt;
      utility_attributes_p^ [4].prompt.value := 'LCU';
      utility_attributes_p^ [4].prompt.size := 3;
      utility_attributes_p^ [5].key := clc$utility_termination_command;
      utility_attributes_p^ [5].termination_command := 'QUIT';

      clp$begin_utility (cmv$utility_name, utility_attributes_p^, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$scan_command_file (clc$current_command_input, cmv$utility_name, 'LCU', status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$end_utility (cmv$utility_name, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    END /main_program/;

  PROCEND logical_configuration_utility;

?? OLDTITLE ??
?? NEWTITLE := 'LCU', EJECT ??

  PROCEDURE [XDCL, #GATE] lcu
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    logical_configuration_utility (parameter_list, status);

  PROCEND lcu;

?? OLDTITLE ??
?? NEWTITLE := 'LCU Subcommands' ??
?? NEWTITLE := '  ADD_VOLUME_TO_SET', EJECT ??

  PROCEDURE add_volume_to_set
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (cmm$lcu_addvts) add_volume_to_set, addvts (
{     recorded_vsn, member_vsn, memvsn, mv, rv: name 1..6 = $required
{     set_name, sn: name
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 25, 9, 10, 23, 89],
    clc$command, 8, 3, 1, 0, 0, 0, 3, 'CMM$LCU_ADDVTS'], [
    ['MEMBER_VSN                     ',clc$alias_entry, 1],
    ['MEMVSN                         ',clc$alias_entry, 1],
    ['MV                             ',clc$alias_entry, 1],
    ['RECORDED_VSN                   ',clc$nominal_entry, 1],
    ['RV                             ',clc$abbreviation_entry, 1],
    ['SET_NAME                       ',clc$nominal_entry, 2],
    ['SN                             ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, 6]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$recorded_vsn = 1,
      p$set_name = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    CONST
      command_name = 'ADD_VOLUME_TO_SET';

    VAR
      allow_to_continue: boolean,
      logical_unit_number: iot$logical_unit,
      message: string (60),
      recorded_vsn: rmt$recorded_vsn,
      set_name: stt$set_name,
      system_device_vsn: rmt$recorded_vsn,
      system_supplied_name: jmt$system_supplied_name,
      user_supplied_name: jmt$user_supplied_name;

    status.normal := TRUE;

  /main_program/
    BEGIN
      IF (NOT avp$configuration_administrator ()) THEN
        osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
        EXIT /main_program/;
      IFEND;
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF NOT cmp$lock_set_by_current_task (cmc$configuration_administrator) THEN
        pmp$get_job_names (user_supplied_name, system_supplied_name, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        cmp$manage_lock_r3 (cmc$configuration_administrator, FALSE,
               system_supplied_name, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;
      recorded_vsn := pvt [p$recorded_vsn].value^.name_value;
      IF pvt [p$set_name].specified THEN
        set_name := pvt [p$set_name].value^.name_value;
      ELSE
        set_name := 'UNSPECIFIED';
      IFEND;
      cmp$get_unit_number_via_vsn (recorded_vsn, logical_unit_number, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_recorded_vsn_not_found,
              command_name, status);
        EXIT /main_program/;
      IFEND;

      cmp$get_sys_dev_rec_vsn (system_device_vsn, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF logical_unit_number = 2 THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_illegal_addvts, ' ', status);
        EXIT /main_program/;
      IFEND;

      IF recorded_vsn = system_device_vsn THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_duplicate_vsn, recorded_vsn,
              status);
        EXIT /main_program/;
      IFEND;

      cmp$validate_set_membership (pvt [p$recorded_vsn].value^.name_value (1, 6), set_name,
            allow_to_continue, status);
      IF (NOT status.normal) OR (NOT allow_to_continue) THEN
        EXIT /main_program/;
      IFEND;

      stp$add_member_vol_to_set (set_name, recorded_vsn, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      message := ' ACTIVATING ';
      message (13, *) := recorded_vsn;
      clp$put_job_output (message, status);
      cmp$activate_volume (logical_unit_number, status);
      IF NOT status.normal THEN
        IF status.condition = dme$volume_already_active THEN
          status.normal := TRUE;
        ELSE
          EXIT /main_program/;
        IFEND;
      IFEND;

    END /main_program/;

  PROCEND add_volume_to_set;

?? OLDTITLE ??
?? NEWTITLE := '  CHANGE_ELEMENT_STATE', EJECT ??

{ PURPOSE:
{   This procedure is the command processor for the CHANGE_ELEMENT_STATE command.

  PROCEDURE change_element_state
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (cmm$lcu_chaes) change_element_state, chaes (
{    element, e: name = $required
{    state, s: key
{        down, off, on
{      keyend = $required
{    iou, i: name = IOU0
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 29, 13, 48, 49, 964],
    clc$command, 7, 4, 2, 0, 0, 0, 4, 'CMM$LCU_CHAES'], [
    ['E                              ',clc$abbreviation_entry, 1],
    ['ELEMENT                        ',clc$nominal_entry, 1],
    ['I                              ',clc$abbreviation_entry, 3],
    ['IOU                            ',clc$nominal_entry, 3],
    ['S                              ',clc$abbreviation_entry, 2],
    ['STATE                          ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 118, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [3], [
    ['DOWN                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['OFF                            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['ON                             ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'IOU0'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element = 1,
      p$state = 2,
      p$iou = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    CONST
      command_name = 'CHANGE_ELEMENT_STATE';

    VAR
      element: cmt$element_descriptor,
      element_definition: ^cmt$element_definition,
      element_info: array [1 .. 2] of cmt$element_info_item,
      element_state: [STATIC, READ, oss$job_paged_literal] array [cmt$element_state] of ost$name :=
        ['ON', 'OFF', 'DOWN'],
      index_state: cmt$element_state,
      iou_name: cmt$element_name,
      initial_processor_value: 0 .. 255,
      processor_index: ost$processor_id,
      processor_name: cmt$element_name,
      state: cmt$element_state,
      tape_element: boolean;

    status.normal := TRUE;

  /main_program/
    BEGIN
      IF NOT (avp$system_operator () OR avp$configuration_administrator () OR
                 avp$removable_media_operator ()) THEN
        osp$set_status_abnormal ('OF', ofe$sou_not_active,
               'configuration_administration, removable_media_operation ' CAT
               'or system_operation', status);
        EXIT /main_program/;
      IFEND;
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      iou_name := pvt [p$iou].value^.name_value;

    /translate_to_cmt$element_state/
      FOR index_state := LOWERVALUE (cmt$element_state) TO UPPERVALUE (cmt$element_state) DO
        IF pvt [p$state].value^.keyword_value = element_state [index_state] THEN
          state := index_state;
          EXIT /translate_to_cmt$element_state/;
        IFEND;
      FOREND /translate_to_cmt$element_state/;

      IF (pvt [p$element].value^.name_value (1, 2) = 'CP') AND
            (clp$trimmed_string_size (pvt [p$element].value^.name_value) = 3) THEN
        processor_name := pvt [p$element].value^.name_value;
        initial_processor_value := $INTEGER (processor_name (3)) - $INTEGER ('0');
        IF (initial_processor_value < LOWERVALUE (ost$processor_id)) OR
              (initial_processor_value > UPPERVALUE (ost$processor_id)) THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_element_not_found, processor_name,
                status);
          RETURN;
        IFEND;

        processor_index := initial_processor_value;
        cmp$change_cpu_element_state (processor_index, state, status);
        RETURN;
      IFEND;

      PUSH element_definition;

      cmp$get_element_r3 (pvt [p$element].value^.name_value, iou_name, element_definition, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      element.element_type := element_definition^.element_type;

      CASE element.element_type OF
      = cmc$data_channel_element =
        element.channel_descriptor.iou := iou_name;
        element.channel_descriptor.use_logical_identification := TRUE;
        element.channel_descriptor.name := pvt [p$element].value^.name_value;

      = cmc$channel_adapter_element, cmc$communications_element, cmc$controller_element,
            cmc$external_processor_element, cmc$storage_device_element =
        element.peripheral_descriptor.use_logical_identification := TRUE;
        element.peripheral_descriptor.element_name := pvt [p$element].value^.name_value;

      = cmc$central_processor_element =
        element.name := pvt [p$element].value^.name_value;
      ELSE
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_not_available,
              'Invalid state change request for given element type', status);
        EXIT /main_program/;
      CASEND;
      cmp$determine_tape_element (element, tape_element);
      IF tape_element THEN
        IF NOT (avp$system_operator () OR avp$configuration_administrator () OR
                   avp$removable_media_operator ()) THEN
          osp$set_status_abnormal ('OF', ofe$sou_not_active,
               'configuration_administration, removable_media_operation ' CAT
               'or system_operation', status);
          EXIT /main_program/;
        IFEND;
      ELSE
        IF NOT (avp$configuration_administrator () OR avp$system_operator ()) THEN
          osp$set_status_abnormal ('OF', ofe$sou_not_active,
               'configuration_administration or system_operation', status);
          EXIT /main_program/;
        IFEND;
      IFEND;

      element_info [1].selector := cmc$system_critical_element;
      element_info [2].selector := cmc$element_status;
      cmp$get_element_information (element, element_info, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF element_info [1].item_returned THEN
        IF element_info [1].system_critical_element THEN
          IF element.element_type = cmc$storage_device_element THEN
            IF state <> cmc$on THEN
              osp$set_status_abnormal (cmc$configuration_management_id,
                  cme$lcm_system_critical_element, pvt [p$element].value^.name_value, status);
              EXIT /main_program/;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      cmp$process_state_change (tape_element, {clear_lock_behind=} FALSE,
             {system_caller=} FALSE, element, element_info [1].system_critical_element,
             element_info [2].element_status.state, state, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    END /main_program/;

  PROCEND change_element_state;

?? OLDTITLE ??
?? NEWTITLE := '  CHANGE_MS_CLASS', EJECT ??

  PROCEDURE change_ms_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{    PROCEDURE (cmm$lcu_chamc) change_ms_class, change_ms_classes, chamc, cha..
{ msc (
{      recorded_vsn, recorded_vsns, rvsn, rv: any of
{          key
{            all
{          keyend
{          list of name 1..6
{        anyend = $required
{      delete_class, delete_classes, dc: any of
{          key
{            all
{          keyend
{          list of name 1..1
{        anyend = $optional
{      add_class, add_classes, ac: any of
{          key
{            all
{          keyend
{          list of name 1..1
{        anyend = $optional
{      status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type3: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 29, 13, 50, 13, 482],
    clc$command, 11, 4, 1, 0, 0, 0, 4, 'CMM$LCU_CHAMC'], [
    ['AC                             ',clc$abbreviation_entry, 3],
    ['ADD_CLASS                      ',clc$nominal_entry, 3],
    ['ADD_CLASSES                    ',clc$alias_entry, 3],
    ['DC                             ',clc$abbreviation_entry, 2],
    ['DELETE_CLASS                   ',clc$nominal_entry, 2],
    ['DELETE_CLASSES                 ',clc$alias_entry, 2],
    ['RECORDED_VSN                   ',clc$nominal_entry, 1],
    ['RECORDED_VSNS                  ',clc$alias_entry, 1],
    ['RV                             ',clc$abbreviation_entry, 1],
    ['RVSN                           ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, 6]]
      ]
    ],
{ PARAMETER 2
    [[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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, 1]]
      ]
    ],
{ PARAMETER 3
    [[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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, 1]]
      ]
    ],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$recorded_vsn = 1,
      p$delete_class = 2,
      p$add_class = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    TYPE
      recorded_vsn_list = record
        recorded_vsn: rmt$recorded_vsn,
        valid: boolean,
      recend;

    CONST
      command_name = 'CHANGE_MS_CLASS';

    VAR
      add_class: dmt$class,
      class: char,
      delete_class: dmt$class,
      element_status: iot$unit_status,
      ignore_status: ost$status,
      i: integer,
      j: integer,
      max_ms_volumes: integer,
      ms_volumes: ^array [ * ] of cmt$mass_storage_volume,
      rvsn_count: clt$list_size,
      rvsn_list: ^array [ * ] of recorded_vsn_list,
      scan_p: ^clt$data_value,
      state: cmt$element_state,
      system_device_rec_vsn: rmt$recorded_vsn,
      system_supplied_name: jmt$system_supplied_name,
      user_supplied_name: jmt$user_supplied_name;

    status.normal := TRUE;

  /main_program/
    BEGIN

      IF (NOT avp$configuration_administrator ()) THEN
        osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
        EXIT /main_program/;
      IFEND;
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF NOT cmp$lock_set_by_current_task (cmc$configuration_administrator) THEN
        pmp$get_job_names (user_supplied_name, system_supplied_name, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        cmp$manage_lock_r3 (cmc$configuration_administrator, FALSE,
             system_supplied_name, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;
      IF pvt [p$recorded_vsn].value^.kind <> clc$keyword THEN
        rvsn_count := clp$count_list_elements (pvt [p$recorded_vsn].value);
        scan_p := pvt [p$recorded_vsn].value;
        PUSH rvsn_list: [1 .. rvsn_count];
        FOR i := 1 TO rvsn_count DO
          rvsn_list^ [i].recorded_vsn := scan_p^.element_value^.name_value;
          rvsn_list^ [i].valid := FALSE;
          scan_p := scan_p^.link;
        FOREND;
      IFEND;

{ Obtain the class membership of each volume in the configuration which is ON and ENABLED.

      cmp$get_ms_volumes (max_ms_volumes);
      PUSH ms_volumes: [1 .. max_ms_volumes];
      cmp$get_ms_volume_info (ms_volumes);

      FOR i := 1 TO max_ms_volumes DO

{ Check if any of the volumes identified by RECORDED_VSN parameter is not ON.

        cmp$get_element_state_via_lun (ms_volumes^ [i].lun, state);
        IF state <> cmc$on THEN
          IF pvt [p$recorded_vsn].value^.kind = clc$keyword THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$element_state_not_proper,
                  ms_volumes^ [i].recorded_vsn, status);
            EXIT /main_program/;
          ELSE
            FOR j := 1 TO rvsn_count DO
              IF rvsn_list^ [j].recorded_vsn = ms_volumes^ [i].recorded_vsn THEN
                osp$set_status_abnormal (cmc$configuration_management_id, cme$element_state_not_proper,
                      ms_volumes^ [i].recorded_vsn, status);
                EXIT /main_program/;
              IFEND;
            FOREND;
          IFEND;
        IFEND;

{ Check if any of the volumes identified by RECORDED_VSN parameter is disabled.

        cmp$get_ms_status_via_lun (ms_volumes^ [i].lun, element_status);
        IF element_status.disabled THEN
          IF pvt [p$recorded_vsn].value^.kind = clc$keyword THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_invalid_element_status,
                  ms_volumes^ [i].recorded_vsn, status);
            EXIT /main_program/;
          ELSE
            FOR j := 1 TO rvsn_count DO
              IF rvsn_list^ [j].recorded_vsn = ms_volumes^ [i].recorded_vsn THEN
                osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_invalid_element_status,
                      ms_volumes^ [i].recorded_vsn, status);
                EXIT /main_program/;
              IFEND;
            FOREND;
          IFEND;
        IFEND;

        ms_volumes^ [i].on_and_enabled := (state = cmc$on) AND (NOT element_status.disabled);

        IF pvt [p$recorded_vsn].value^.kind = clc$keyword THEN
          IF ms_volumes^ [i].on_and_enabled THEN
            ms_volumes^ [i].changed := TRUE;
          IFEND;
        ELSE
          ms_volumes^ [i].changed := FALSE;

        /volume_loop_0/
          FOR j := 1 TO rvsn_count DO
            IF rvsn_list^ [j].recorded_vsn = ms_volumes^ [i].recorded_vsn THEN
              rvsn_list^ [j].valid := TRUE;
              IF ms_volumes^ [i].on_and_enabled THEN
                ms_volumes^ [i].changed := TRUE;
              IFEND;
              EXIT /volume_loop_0/;
            IFEND;
          FOREND /volume_loop_0/;
        IFEND;

      FOREND;

{ Check if a volume identified by RECORDED_VSN parameter invalid or not initialized.

      IF pvt [p$recorded_vsn].value^.kind <> clc$keyword THEN
        FOR j := 1 TO rvsn_count DO
          IF NOT rvsn_list^ [j].valid THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_invalid_recorded_vsn,
                  rvsn_list^ [j].recorded_vsn, status);
            EXIT /main_program/;
          IFEND;
        FOREND;
      IFEND;

      add_class := $dmt$class [];
      IF pvt [p$add_class].specified THEN
        IF pvt [p$add_class].value^.kind = clc$keyword THEN
          add_class := -add_class;
        ELSE
          scan_p := pvt [p$add_class].value;
          WHILE scan_p <> NIL DO
            add_class := add_class + $dmt$class [scan_p^.element_value^.name_value];
            scan_p := scan_p^.link;
          WHILEND;
        IFEND;
      IFEND;

      delete_class := $dmt$class [];
      IF pvt [p$delete_class].specified THEN
        IF pvt [p$delete_class].value^.kind = clc$keyword THEN
          delete_class := -$dmt$class ['A'];
        ELSE
          scan_p := pvt [p$delete_class].value;
          WHILE scan_p <> NIL DO
            delete_class := delete_class + $dmt$class [scan_p^.element_value^.name_value];
            scan_p := scan_p^.link;
          WHILEND;
        IFEND;
      IFEND;

      FOR i := 1 TO max_ms_volumes DO
        IF ms_volumes^ [i].on_and_enabled THEN
          IF ms_volumes^ [i].changed THEN

{ DELETE_CLASSES must be processed before ADD_CLASSES is processed.

            ms_volumes^ [i].class := ms_volumes^ [i].class - delete_class;
            ms_volumes^ [i].class := ms_volumes^ [i].class + add_class;
          IFEND;
        IFEND
      FOREND;

{ Verify that every volume belongs to class A.

      FOR i := 1 TO max_ms_volumes DO
        IF ms_volumes^ [i].on_and_enabled THEN
          IF NOT ('A' IN ms_volumes^ [i].class) THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_cannot_delete_class_a, ' ',
                  status);
            EXIT /main_program/;
          IFEND;
        IFEND;
      FOREND;

{ Verify that the system device belongs to class A or Q.

      cmp$get_sys_dev_rec_vsn (system_device_rec_vsn, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    /volume_loop_1/
      FOR i := 1 TO max_ms_volumes DO
        IF ms_volumes^ [i].recorded_vsn = system_device_rec_vsn THEN
          IF NOT ($dmt$class ['A', 'Q'] <= ms_volumes^ [i].class) THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_invalid_sys_dev_class,
                  ms_volumes^ [i].recorded_vsn, status);
            EXIT /main_program/;
          IFEND;
          EXIT /volume_loop_1/;
        IFEND;
      FOREND /volume_loop_1/;

{ Write the new membership to AVT and the volume table.

      FOR i := 1 TO max_ms_volumes DO
        IF ms_volumes^ [i].on_and_enabled THEN
          IF ms_volumes^ [i].changed THEN
            cmp$add_class_to_element (i, ms_volumes^ [i].class, ms_volumes^ [i].write_status);
          IFEND;
        IFEND;
      FOREND;

{ Issue error message if an error occurs when writing the volume label.

    /volume_loop_3/
      FOR i := 1 TO max_ms_volumes DO
        IF ms_volumes^ [i].on_and_enabled THEN
          IF ms_volumes^ [i].changed THEN
            IF NOT ms_volumes^ [i].write_status.normal THEN
              osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_cannot_write_vol_label,
                    'Not all volumes processed due to peripheral failure', status);
              EXIT /main_program/;
            IFEND;
          IFEND;
        IFEND;
      FOREND /volume_loop_3/;

    END /main_program/;

  PROCEND change_ms_class;

?? OLDTITLE ??
?? NEWTITLE := '  CHANGE_MS_VOLUME', EJECT ??

  PROCEDURE change_ms_volume
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (cmm$lcu_chamsv) change_ms_volume, chamv, chamsv (
{    recorded_vsn, recorded_vsns, rvsn, rv: any of
{        key
{          all
{        keyend
{        list of name 1..6
{      anyend = $required
{    allocation_size, as: key
{        $16k, $32k, $64k, $128k, $256k, $512k
{        (cylinder, c)
{      keyend = $optional
{    transfer_size, ts: key
{        $16k, $32k, $64k, $128k, $256k, $512k
{        (cylinder, c)
{      keyend = $optional
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 5, 24, 9, 27, 42, 812],
    clc$command, 9, 4, 1, 0, 0, 0, 4, 'CMM$LCU_CHAMSV'], [
    ['ALLOCATION_SIZE                ',clc$nominal_entry, 2],
    ['AS                             ',clc$abbreviation_entry, 2],
    ['RECORDED_VSN                   ',clc$nominal_entry, 1],
    ['RECORDED_VSNS                  ',clc$alias_entry, 1],
    ['RV                             ',clc$abbreviation_entry, 1],
    ['RVSN                           ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['TRANSFER_SIZE                  ',clc$nominal_entry, 3],
    ['TS                             ',clc$abbreviation_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 303, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 303, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, 6]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [8], [
    ['$128K                          ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['$16K                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['$256K                          ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
    ['$32K                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['$512K                          ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
    ['$64K                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
    ['CYLINDER                       ', clc$nominal_entry,
  clc$normal_usage_entry, 7]]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [8], [
    ['$128K                          ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['$16K                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['$256K                          ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
    ['$32K                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['$512K                          ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
    ['$64K                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
    ['CYLINDER                       ', clc$nominal_entry,
  clc$normal_usage_entry, 7]]
    ],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$recorded_vsn = 1,
      p$allocation_size = 2,
      p$transfer_size = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    TYPE
      recorded_vsn_list = record
        recorded_vsn: rmt$recorded_vsn,
        valid: boolean,
      recend;

    CONST
      command_name = 'CHANGE_MS_VOLUME';

    VAR
      allocation_size: dmt$allocation_size,
      element_status: iot$unit_status,
      ignore_status: ost$status,
      i: integer,
      index: integer,
      j: integer,
      max_ms_volumes: integer,
      ms_volumes: ^array [ * ] of cmt$mass_storage_volume,
      rvsn_list: ^array [ * ] of recorded_vsn_list,
      scan_p: ^clt$data_value,
      state: cmt$element_state,
      system_supplied_name: jmt$system_supplied_name,
      transfer_size: dmt$transfer_size,
      user_supplied_name: jmt$user_supplied_name,
      volume_attributes_p: ^dmt$volume_attributes,
      volume_count: 0 .. 7fffffff(16);

    status.normal := TRUE;

  /main_program/
    BEGIN

      IF (NOT avp$configuration_administrator ()) THEN
        osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
        EXIT /main_program/;
      IFEND;
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      IF NOT cmp$lock_set_by_current_task (cmc$configuration_administrator) THEN
        pmp$get_job_names (user_supplied_name, system_supplied_name, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        cmp$manage_lock_r3 (cmc$configuration_administrator, FALSE,
             system_supplied_name, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF pvt [p$recorded_vsn].value^.kind <> clc$keyword THEN
        volume_count := clp$count_list_elements (pvt [p$recorded_vsn].value);
        PUSH rvsn_list: [1 .. volume_count];
        scan_p := pvt [p$recorded_vsn].value;
        FOR i := 1 TO volume_count DO
          rvsn_list^ [i].recorded_vsn := scan_p^.element_value^.name_value;
          rvsn_list^ [i].valid := FALSE;
          scan_p := scan_p^.link;
        FOREND;
      IFEND;

      cmp$get_ms_volumes (max_ms_volumes);
      PUSH ms_volumes: [1 .. max_ms_volumes];
      cmp$get_ms_volume_info (ms_volumes);

      FOR i := 1 TO max_ms_volumes DO

{ Check if any of the volumes identified by RECORDED_VSN parameter is not ON.

        cmp$get_element_state_via_lun (ms_volumes^ [i].lun, state);
        IF state <> cmc$on THEN
          IF pvt [p$recorded_vsn].value^.kind = clc$keyword THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$element_state_not_proper,
                  ms_volumes^ [i].recorded_vsn, status);
            EXIT /main_program/;
          ELSE
            FOR j := 1 TO volume_count DO
              IF rvsn_list^ [j].recorded_vsn = ms_volumes^ [i].recorded_vsn THEN
                osp$set_status_abnormal (cmc$configuration_management_id, cme$element_state_not_proper,
                      ms_volumes^ [i].recorded_vsn, status);
                EXIT /main_program/;
              IFEND;
            FOREND;
          IFEND;
        IFEND;

{ Check if any of the volumes identified by RECORDED_VSN parameter is disabled.

        cmp$get_ms_status_via_lun (ms_volumes^ [i].lun, element_status);
        IF element_status.disabled THEN
          IF pvt [p$recorded_vsn].value^.kind = clc$keyword THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_invalid_element_status,
                  ms_volumes^ [i].recorded_vsn, status);
            EXIT /main_program/;
          ELSE
            FOR j := 1 TO volume_count DO
              IF rvsn_list^ [j].recorded_vsn = ms_volumes^ [i].recorded_vsn THEN
                osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_invalid_element_status,
                      ms_volumes^ [i].recorded_vsn, status);
                EXIT /main_program/;
              IFEND;
            FOREND;
          IFEND;
        IFEND;

        ms_volumes^ [i].on_and_enabled := (state = cmc$on) AND (NOT element_status.disabled);

        IF pvt [p$recorded_vsn].value^.kind = clc$keyword THEN
          IF ms_volumes^ [i].on_and_enabled THEN
            ms_volumes^ [i].changed := TRUE;
          IFEND;
        ELSE
          ms_volumes^ [i].changed := FALSE;

        /volume_loop_0/
          FOR j := 1 TO volume_count DO
            IF rvsn_list^ [j].recorded_vsn = ms_volumes^ [i].recorded_vsn THEN
              rvsn_list^ [j].valid := TRUE;
              IF ms_volumes^ [i].on_and_enabled THEN
                ms_volumes^ [i].changed := TRUE;
              IFEND;
              EXIT /volume_loop_0/;
            IFEND;
          FOREND /volume_loop_0/;
        IFEND;

      FOREND;

{ Check if a volume identified by RECORDED_VSN parameter invalid or not initialized.

      IF pvt [p$recorded_vsn].value^.kind <> clc$keyword THEN
        FOR j := 1 TO volume_count DO
          IF NOT rvsn_list^ [j].valid THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_invalid_recorded_vsn,
                  rvsn_list^ [j].recorded_vsn, status);
            EXIT /main_program/;
          IFEND;
        FOREND;
      IFEND;

      IF pvt [p$allocation_size].specified THEN
        IF pvt [p$allocation_size].value^.keyword_value = 'CYLINDER' THEN
          allocation_size := dmc$max_bytes_per_allocation;
        ELSEIF pvt [p$allocation_size].value^.keyword_value = '$16K' THEN
          allocation_size := 16 * dmc$k_multiplier;
        ELSEIF pvt [p$allocation_size].value^.keyword_value = '$32K' THEN
          allocation_size := 32 * dmc$k_multiplier;
        ELSEIF pvt [p$allocation_size].value^.keyword_value = '$64K' THEN
          allocation_size := 64 * dmc$k_multiplier;
        ELSEIF pvt [p$allocation_size].value^.keyword_value = '$128K' THEN
          allocation_size := 128 * dmc$k_multiplier;
        ELSEIF pvt [p$allocation_size].value^.keyword_value = '$256K' THEN
          allocation_size := 256 * dmc$k_multiplier;
        ELSEIF pvt [p$allocation_size].value^.keyword_value = '$512K' THEN
          allocation_size := 512 * dmc$k_multiplier;
        IFEND;
      ELSE
        allocation_size := dmc$unspecified_allocation_size;
      IFEND;

      IF pvt [p$transfer_size].specified THEN
        IF pvt [p$transfer_size].value^.keyword_value = 'CYLINDER' THEN
          transfer_size := dmc$max_transfer_size;
        ELSEIF pvt [p$transfer_size].value^.keyword_value = '$16K' THEN
          transfer_size := 16 * dmc$k_multiplier;
        ELSEIF pvt [p$transfer_size].value^.keyword_value = '$32K' THEN
          transfer_size := 32 * dmc$k_multiplier;
        ELSEIF pvt [p$transfer_size].value^.keyword_value = '$64K' THEN
          transfer_size := 64 * dmc$k_multiplier;
        ELSEIF pvt [p$transfer_size].value^.keyword_value = '$128K' THEN
          transfer_size := 128 * dmc$k_multiplier;
        ELSEIF pvt [p$transfer_size].value^.keyword_value = '$256K' THEN
          transfer_size := 256 * dmc$k_multiplier;
        ELSEIF pvt [p$transfer_size].value^.keyword_value = '$512K' THEN
          transfer_size := 512 * dmc$k_multiplier;
        IFEND;
      ELSE
        transfer_size := dmc$unspecified_transfer_size;
      IFEND;

      PUSH volume_attributes_p: [1 .. 2];

      volume_attributes_p^ [1].keyword := dmc$vol_default_allocation_size;
      volume_attributes_p^ [1].default_allocation_size := allocation_size;
      volume_attributes_p^ [2].keyword := dmc$vol_default_transfer_size;
      volume_attributes_p^ [2].default_transfer_size := transfer_size;

      FOR index := 1 TO max_ms_volumes DO
        IF ms_volumes^ [index].on_and_enabled THEN
          IF ms_volumes^ [index].changed THEN
            cmp$change_volume_attributes (ms_volumes^ [index].lun, volume_attributes_p,
                  ms_volumes^ [index].write_status);
          IFEND;
        IFEND;
      FOREND;

{ Issue error message if an error occurs when writing.

    /volume_loop_3/
      FOR i := 1 TO max_ms_volumes DO
        IF ms_volumes^ [i].on_and_enabled THEN
          IF ms_volumes^ [i].changed THEN
            IF NOT ms_volumes^ [i].write_status.normal THEN
              IF ms_volumes^ [i].write_status.condition = dme$avt_entry_not_found THEN
                osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_recorded_vsn_not_found,
                      ms_volumes^ [i].recorded_vsn, status);
              ELSE
                osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_cannot_write_vol_label,
                      ms_volumes^ [i].recorded_vsn, status);
                osp$append_status_parameter (':', 'Not processed due to peripheral failure', status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND /volume_loop_3/;

    END /main_program/;

  PROCEND change_ms_volume;

?? OLDTITLE ??
?? NEWTITLE := '  CREATE_SET', EJECT ??

  PROCEDURE create_set
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (cmm$lcu_cres) create_set, cres (
{   set_name, sn: name = $required
{   master_vsn, mvsn, mv: name 1..6 = $required
{   recover_set, rs: boolean = FALSE
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 8] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
          default_value: string (5),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 11, 2, 12, 34, 56, 789], clc$command, 8, 4, 2, 0, 0, 0, 4, 'CMM$LCU_CRES'],
            [['MASTER_VSN                     ', clc$nominal_entry, 2],
            ['MV                             ', clc$abbreviation_entry, 2],
            ['MVSN                           ', clc$alias_entry, 2],
            ['RECOVER_SET                    ', clc$nominal_entry, 3],
            ['RS                             ', clc$abbreviation_entry, 3],
            ['SET_NAME                       ', clc$nominal_entry, 1],
            ['SN                             ', clc$abbreviation_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 4]], [

{ SET_NAME, SN

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ MASTER_VSN, MVSN, MV

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ RECOVER_SET, RS

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 5],

{ STATUS

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ SET_NAME, SN

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ MASTER_VSN, MVSN, MV

      [[1, 0, clc$name_type], [1, 6]],

{ RECOVER_SET, RS

      [[1, 0, clc$boolean_type], 'FALSE'],

{ STATUS

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$set_name = 1,
      p$master_vsn = 2,
      p$recover_set = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      logical_unit: iot$logical_unit,
      master_vsn: rmt$recorded_vsn,
      owner: ost$user_identification,
      recover_set: boolean,
      set_name: stt$set_name,
      system_supplied_name: jmt$system_supplied_name,
      user_supplied_name: jmt$user_supplied_name;

    status.normal := TRUE;


    IF (NOT avp$configuration_administrator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      RETURN;
    IFEND;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT cmp$lock_set_by_current_task (cmc$configuration_administrator) THEN
      pmp$get_job_names (user_supplied_name, system_supplied_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      cmp$manage_lock_r3 (cmc$configuration_administrator, FALSE,
             system_supplied_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    master_vsn := pvt [p$master_vsn].value^.name_value;
    owner.family := jmc$system_family;
    owner.user := jmc$system_user;
    recover_set := pvt [p$recover_set].value^.boolean_value.value;
    set_name := pvt [p$set_name].value^.name_value;

    stp$create_set (set_name, master_vsn, owner, stc$allow_access, recover_set, status);
    IF status.normal THEN
      cmp$get_unit_number_via_vsn (master_vsn, logical_unit, status);
      IF status.normal THEN
        cmp$activate_volume (logical_unit, status);
      IFEND;
      IF NOT status.normal THEN
        IF status.condition = dme$volume_already_active THEN
          status.normal := TRUE;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      pfp$overhaul_set (set_name, $pft$set_overhaul_choices [], status);
    IFEND;

  PROCEND create_set;

?? OLDTITLE ??
?? NEWTITLE := '  DEFINE_MS_FLAW', EJECT ??

  PROCEDURE define_ms_flaw
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (cmm$lcu_defmsf) define_ms_flaw, defmf, defmsf (
{    recorded_vsn, rvsn, rv: name 1..6 = $required
{    cylinder, c: integer 0..281474976710655 = $required
{    track, t: integer 0..281474976710655 = $optional
{    sector, s: integer 0..281474976710655 = $optional
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 29, 13, 51, 24, 407],
    clc$command, 10, 5, 2, 0, 0, 0, 5, 'CMM$LCU_DEFMSF'], [
    ['C                              ',clc$abbreviation_entry, 2],
    ['CYLINDER                       ',clc$nominal_entry, 2],
    ['RECORDED_VSN                   ',clc$nominal_entry, 1],
    ['RV                             ',clc$abbreviation_entry, 1],
    ['RVSN                           ',clc$alias_entry, 1],
    ['S                              ',clc$abbreviation_entry, 4],
    ['SECTOR                         ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['T                              ',clc$abbreviation_entry, 3],
    ['TRACK                          ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, 6]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, 281474976710655, 10]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, 281474976710655, 10]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [0, 281474976710655, 10]],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$recorded_vsn = 1,
      p$cylinder = 2,
      p$track = 3,
      p$sector = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    CONST
      command_name = 'DEFINE_MS_FLAW';

    VAR
      physical_flaw_address_p: ^dmt$physical_flaw_address,
      recorded_vsn: rmt$recorded_vsn,
      system_supplied_name: jmt$system_supplied_name,
      user_supplied_name: jmt$user_supplied_name;

    status.normal := TRUE;


    IF (NOT avp$configuration_administrator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      RETURN;
    IFEND;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT cmp$lock_set_by_current_task (cmc$configuration_administrator) THEN
      pmp$get_job_names (user_supplied_name, system_supplied_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      cmp$manage_lock_r3 (cmc$configuration_administrator, FALSE,
           system_supplied_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    PUSH physical_flaw_address_p;

    recorded_vsn := pvt [p$recorded_vsn].value^.name_value;
    physical_flaw_address_p^.cylinder := pvt [p$cylinder].value^.integer_value.value;
    IF pvt [p$track].specified THEN
      physical_flaw_address_p^.track := pvt [p$track].value^.integer_value.value;
    IFEND;
    IF pvt [p$sector].specified THEN
      physical_flaw_address_p^.sector := pvt [p$sector].value^.integer_value.value;
    IFEND;

    dmp$define_remove_ms_flaw (recorded_vsn, physical_flaw_address_p, pvt [p$track].specified,
          pvt [p$sector].specified, dmc$oc_flaw_define, dmc$ic_operator_initiated, status);
    IF NOT status.normal THEN
      CASE status.condition OF
      = dme$avt_entry_not_found, dme$recorded_vsn_not_in_lun =
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_recorded_vsn_not_found,
              command_name, status);

      = dme$cylinder_limit_exceeded =
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_cylinder_limit_exceeded,
              command_name, status);

      = dme$track_limit_exceeded =
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_track_limit_exceeded, command_name,
              status);

      = dme$flawing_deferred =
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_save_flaw_warning, recorded_vsn,
              status);

      = dme$sector_limit_exceeded =
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_sector_limit_exceeded, command_name,
              status);

      = dme$logging_unavailable =
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_logging_not_active, command_name,
              status);

      = dme$address_already_flawed =
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_address_already_flawed,
              command_name, status);

      = dme$unaddressable_sector =
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_unaddressable_sector, command_name,
              status);
      ELSE
        ;
      CASEND;
    IFEND;
  PROCEND define_ms_flaw;

?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_MAINFRAME_CONFIGURATION', EJECT ??

*block

  PROCEDURE [XDCL, #GATE] cmp$display_mf_configuration
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (cmm$lcu_dismc) cmp$display_mf_configuration, dismc (
{     elements, element, e: any of
{           key
{             all
{           keyend
{           list of key
{             $channel
{             ($channel_adapter, $ca)
{             ($communications_element, $ce)
{             $controller
{             ($external_processor, $ep)
{             ($storage_device, $sd)
{           keyend
{           list of name
{         anyend = ALL
{     display_options, display_option, do: any of
{           key
{             all
{           keyend
{           list of key
{             (active_paths, ap)
{             (application_information, ai)
{             (connection_status, cs)
{             (disabled_paths, dp)
{             (element_identification, ei)
{             (inactive_paths, ip)
{             (iou_program_name, ioupn, ipn)
{             (ms_class, msc, mc)
{             (parity_status, ps)
{             (physical_connections, pc)
{             (physical_paths, pp)
{             (serial_number, sn)
{             (site_information, si)
{             (state, s)
{           keyend
{         anyend = all
{     iou, i: name = IOU0
{     output, o: file = $OUTPUT
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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 .. 10] of clt$keyword_specification,
          recend,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier_v2,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: 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 .. 30] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [96, 8, 1, 8, 19, 2, 354],
    clc$command, 11, 5, 0, 0, 0, 0, 5, 'CMM$LCU_DISMC'], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['E                              ',clc$abbreviation_entry, 1],
    ['ELEMENT                        ',clc$alias_entry, 1],
    ['ELEMENTS                       ',clc$nominal_entry, 1],
    ['I                              ',clc$abbreviation_entry, 3],
    ['IOU                            ',clc$nominal_entry, 3],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OUTPUT                         ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 482, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 1197, clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    393, [[1, 0, clc$list_type], [377, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [10], [
        ['$CA                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['$CE                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['$CHANNEL                       ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['$CHANNEL_ADAPTER               ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['$COMMUNICATIONS_ELEMENT        ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['$CONTROLLER                    ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['$EP                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['$EXTERNAL_PROCESSOR            ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['$SD                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['$STORAGE_DEVICE                ', clc$nominal_entry,
  clc$normal_usage_entry, 6]]
        ]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'ALL'],
{ PARAMETER 2
    [[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]]
      ],
    1133, [[1, 0, clc$list_type], [1117, 1, clc$max_list_size, 0, FALSE, FALSE]
  ,
        [[1, 0, clc$keyword_type], [30], [
        ['ACTIVE_PATHS                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['AI                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['AP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['APPLICATION_INFORMATION        ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['CONNECTION_STATUS              ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['CS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['DISABLED_PATHS                 ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['DP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['EI                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['ELEMENT_IDENTIFICATION         ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['INACTIVE_PATHS                 ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
        ['IOUPN                          ', clc$alias_entry,
  clc$normal_usage_entry, 7],
        ['IOU_PROGRAM_NAME               ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
        ['IP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['IPN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
        ['MC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
        ['MSC                            ', clc$alias_entry,
  clc$normal_usage_entry, 8],
        ['MS_CLASS                       ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
        ['PARITY_STATUS                  ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
        ['PC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
        ['PHYSICAL_CONNECTIONS           ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
        ['PHYSICAL_PATHS                 ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
        ['PP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 11],
        ['PS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
        ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 14],
        ['SERIAL_NUMBER                  ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
        ['SI                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 13],
        ['SITE_INFORMATION               ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
        ['SN                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 12],
        ['STATE                          ', clc$nominal_entry,
  clc$normal_usage_entry, 14]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'IOU0'],
{ PARAMETER 4
    [[1, 0, clc$file_type],
    '$OUTPUT'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$elements = 1,
      p$display_options = 2,
      p$iou = 3,
      p$output = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

*copyc clv$display_variables
*copyc cmc$minimum_page_size

    CONST
      command_name = 'DISPLAY_MAINFRAME_CONFIGURATION';

    VAR
      caller_id: ost$caller_identifier,
      display_control: clt$display_control,
      display_option: cmt$display_option,
      element_count: integer,
      element_option_key: cmt$lcu_display_option_key,
      file: clt$file,
      header: string (50),
      i: integer,
      ignore_status: ost$status,
      iou_name: cmt$element_name,
      lc_element: ^array [1 .. * ] of cmt$element_definition,
      keyword: clt$keyword,
      output_open: boolean,
      scan_p: ^clt$data_value;

?? NEWTITLE := '    abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF output_open THEN
        clp$close_display (display_control, ignore_status);
        output_open := FALSE;
      IFEND;

    PROCEND abort_handler;

*copyc clp$new_page_procedure

?? OLDTITLE ??
?? NEWTITLE := '    print_subtitle', EJECT ??

    PROCEDURE print_subtitle
      (    header: string (50);
       VAR status: ost$status);

      clp$put_partial_display (display_control, header, clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND print_subtitle;

?? OLDTITLE ??
?? NEWTITLE := '    put_subtitle', EJECT ??

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

      print_subtitle (header, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND put_subtitle;

?? OLDTITLE, EJECT ??

    #caller_id (caller_id);
    status.normal := TRUE;
    header := 'ACTIVE PHYSICAL CONFIGURATION';
    output_open := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

  /main_program/
    BEGIN

      validate_command_usage (status);
      IF caller_id.ring > 6 THEN
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      cmp$get_number_of_element (element_count, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF element_count = 0 THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_eoi_not_returned,
              'Zero element count returned by CMP$GET_NUMBER_OF_ELEMENT', status);
        EXIT /main_program/;
      IFEND;

      PUSH lc_element: [1 .. element_count];

      cmp$copy_active_configuration (lc_element, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$convert_string_to_file (pvt [p$output].value^.file_value^, file, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$open_display (file, ^clp$new_page_procedure, display_control, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      output_open := TRUE;

      IF display_control.page_width < cmc$minimum_page_size THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_illegal_output_file,
              file.local_file_name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, cmc$minimum_page_size, 10, FALSE, status);
        EXIT /main_program/;
      IFEND;

      clv$titles_built := FALSE;
      clv$command_name := command_name;

      display_option := $cmt$display_option [];
      IF pvt [p$display_options].value^.kind = clc$keyword THEN
        IF pvt [p$display_options].value^.keyword_value = 'ALL' THEN
          display_option := display_option + $cmt$display_option [cmc$all_kw];
        IFEND;
      ELSE
        scan_p := pvt [p$display_options].value;
        WHILE scan_p <> NIL DO
          keyword := scan_p^.element_value^.keyword_value;
          IF keyword = 'ACTIVE_PATHS' THEN
            display_option := display_option + $cmt$display_option [cmc$active_paths_kw];
          ELSEIF keyword = 'APPLICATION_INFORMATION' THEN
            display_option := display_option + $cmt$display_option [cmc$application_info_kw];
          ELSEIF keyword = 'CONNECTION_STATUS' THEN
            display_option := display_option + $cmt$display_option [cmc$connection_status_kw];
          ELSEIF keyword = 'DISABLED_PATHS' THEN
            display_option := display_option + $cmt$display_option [cmc$disabled_paths_kw];
          ELSEIF keyword = 'ELEMENT_IDENTIFICATION' THEN
            display_option := display_option + $cmt$display_option [cmc$element_id_kw];
          ELSEIF keyword = 'INACTIVE_PATHS' THEN
            display_option := display_option + $cmt$display_option [cmc$inactive_paths_kw];
          ELSEIF keyword = 'IOU_PROGRAM_NAME' THEN
            display_option := display_option + $cmt$display_option [cmc$ioupn_kw];
          ELSEIF keyword = 'MS_CLASS' THEN
            display_option := display_option + $cmt$display_option [cmc$ms_class_kw];
          ELSEIF keyword = 'PARITY_STATUS' THEN
            display_option := display_option + $cmt$display_option [cmc$parity_status_kw];
          ELSEIF keyword = 'PHYSICAL_CONNECTIONS' THEN
            display_option := display_option + $cmt$display_option [cmc$physical_connection_kw];
          ELSEIF keyword = 'PHYSICAL_PATHS' THEN
            display_option := display_option + $cmt$display_option [cmc$physical_paths_kw];
          ELSEIF keyword = 'SERIAL_NUMBER' THEN
            display_option := display_option + $cmt$display_option [cmc$serial_number_kw];
          ELSEIF keyword = 'SITE_INFORMATION' THEN
            display_option := display_option + $cmt$display_option [cmc$site_info_kw];
          ELSEIF keyword = 'STATE' THEN
            display_option := display_option + $cmt$display_option [cmc$state_kw];
          ELSE
            ;
          IFEND;
          scan_p := scan_p^.link;
        WHILEND;
      IFEND;
      iou_name := pvt [p$iou].value^.name_value;
      IF pvt [p$elements].value^.kind = clc$keyword THEN
        IF pvt [p$elements].value^.keyword_value = 'ALL' THEN

{ Since some device types may not be present on all mainframes, use IGNORE_STATUS for DO=ALL.

          cmp$display_type_elements (cmc$data_channel_element, display_option, element_count, lc_element,
                  display_control, ignore_status);
          cmp$display_type_elements (cmc$channel_adapter_element, display_option, element_count, lc_element,
                  display_control, ignore_status);
          cmp$display_type_elements (cmc$communications_element, display_option, element_count, lc_element,
                  display_control, ignore_status);
          cmp$display_type_elements (cmc$controller_element, display_option, element_count, lc_element,
                  display_control, ignore_status);
          cmp$display_type_elements (cmc$storage_device_element, display_option, element_count, lc_element,
                  display_control, ignore_status);
          cmp$display_type_elements (cmc$external_processor_element, display_option, element_count,
                  lc_element, display_control, ignore_status);
        IFEND;
      ELSE
        scan_p := pvt [p$elements].value;
        WHILE scan_p <> NIL DO
          CASE scan_p^.element_value^.kind OF
          = clc$name =
            cmp$display_named_element (scan_p^.element_value^.name_value, iou_name, display_option,
                  element_count, lc_element, display_control, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
          = clc$keyword =
            keyword := scan_p^.element_value^.keyword_value;
            IF keyword = '$CHANNEL' THEN
              cmp$display_type_elements (cmc$data_channel_element, display_option, element_count, lc_element,
                    display_control, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
            ELSEIF keyword = '$CHANNEL_ADAPTER' THEN
              cmp$display_type_elements (cmc$channel_adapter_element, display_option, element_count,
                    lc_element, display_control, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
            ELSEIF keyword = '$COMMUNICATIONS_ELEMENT' THEN
              cmp$display_type_elements (cmc$communications_element, display_option, element_count,
                  lc_element, display_control, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
            ELSEIF keyword = '$CONTROLLER' THEN
              cmp$display_type_elements (cmc$controller_element, display_option, element_count, lc_element,
                    display_control, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
            ELSEIF keyword = '$EXTERNAL_PROCESSOR' THEN
              cmp$display_type_elements (cmc$external_processor_element, display_option, element_count,
                    lc_element, display_control, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
            ELSEIF keyword = '$STORAGE_DEVICE' THEN
              cmp$display_type_elements (cmc$storage_device_element, display_option, element_count,
                   lc_element, display_control, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
            ELSE
              ;
            IFEND;
          ELSE
            ;
          CASEND;
          scan_p := scan_p^.link;
        WHILEND;
      IFEND;
    END /main_program/;

    IF output_open THEN
      clp$close_display (display_control, ignore_status);
      output_open := FALSE;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND cmp$display_mf_configuration;
*blockend

?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_MS_CLASS', EJECT ??

*block

  PROCEDURE display_ms_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (cmm$lcu_dismsc) display_ms_class, display_ms_classes, dismsc (
{     recorded_vsn, recorded_vsns, rvsn, rv: any of
{         key
{           all
{         keyend
{         list of name 1..6
{       anyend = ALL
{     output, o: file = $OUTPUT
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 29, 13, 57, 36, 281],
    clc$command, 7, 3, 0, 0, 0, 0, 3, 'CMM$LCU_DISMSC'], [
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['RECORDED_VSN                   ',clc$nominal_entry, 1],
    ['RECORDED_VSNS                  ',clc$alias_entry, 1],
    ['RV                             ',clc$abbreviation_entry, 1],
    ['RVSN                           ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, 6]]
      ]
    ,
    'ALL'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$OUTPUT'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$recorded_vsn = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

*copy clv$display_variables
*copy cmc$minimum_page_size

    CONST
      command_name = 'DISPLAY_MS_CLASS';

    VAR
      display_control: clt$display_control,
      file: clt$file,
      header: string (50),
      i: 0 .. 255,
      j: 0 .. 255,
      max_volume_index: integer,
      ms_class: cmt$ms_class_members,
      ms_class_info: cmt$ms_class_info,
      number_of_vol: integer,
      output_open: boolean,
      scan_p: ^clt$data_value,
      stl: 0 .. 255,
      str: string (80),
      volume_found: boolean,
      volume_list: ^stt$volume_list,
      vsn: rmt$recorded_vsn;

?? NEWTITLE := '    abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF output_open THEN
        clp$close_display (display_control, status);
        output_open := FALSE;
      IFEND;

    PROCEND abort_handler;

*copy clp$new_page_procedure

?? OLDTITLE ??
?? NEWTITLE := '    print_subtitle', EJECT ??

    PROCEDURE print_subtitle
      (    header: string (50);
       VAR status: ost$status);

      clp$put_partial_display (display_control, header, clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND print_subtitle;

?? OLDTITLE ??
?? NEWTITLE := '    put_subtitle', EJECT ??

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

      print_subtitle (header, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND put_subtitle;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    header := ' MASS STORAGE CLASS ASSIGNMENTS';
    output_open := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

    validate_command_usage (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_string_to_file (pvt [p$output].value^.file_value^, file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$open_display (file, ^clp$new_page_procedure, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output_open := TRUE;

    IF display_control.page_width < cmc$minimum_page_size THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_illegal_output_file,
            pvt [p$output].value^.file_value^, status);
      osp$append_status_integer (osc$status_parameter_delimiter, cmc$minimum_page_size, 10, FALSE, status);
      RETURN;
    IFEND;

    clv$titles_built := FALSE;
    clv$command_name := 'display_ms_volume';

    str := ' VOLUME                         CLASS ';
    clp$put_display (display_control, str, clc$no_trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    str := ' ';
    clp$put_display (display_control, str, clc$no_trim, status);

    str := ' VSN      ';
    stl := 10;

    FOR ms_class := LOWERBOUND(ms_class_info) TO UPPERBOUND(ms_class_info) DO
      str (stl + 1) := ms_class;
      str (stl + 2) := ' ';
      stl := stl + 2;
    FOREND;
    clp$put_display (display_control, str, clc$no_trim, status);

    str := ' ';
    clp$put_display (display_control, str, clc$no_trim, status);
    clp$put_display (display_control, str, clc$no_trim, status);

    cmp$obtain_max_volume_index (max_volume_index);
    PUSH volume_list: [1 .. max_volume_index];
    cmp$obtain_volumes (volume_list, number_of_vol);

    IF pvt [p$recorded_vsn].value^.kind = clc$keyword THEN

    /volume_loop/
      FOR i := 1 TO number_of_vol DO
        cmp$get_ms_class_on_volume (volume_list^ [i].recorded_vsn, volume_found, ms_class_info);
        IF NOT volume_found THEN
          CYCLE /volume_loop/;
        IFEND;

        str := ' ';
        str (2, 6) := volume_list^ [i].recorded_vsn;
        str (8, 3) := '   ';
        stl := 10;

        FOR ms_class := LOWERBOUND(ms_class_info) TO UPPERBOUND(ms_class_info) DO
          IF ms_class_info[ms_class] THEN
            str (stl + 1) := ms_class;
          ELSE
            str (stl + 1) := ' ';
          IFEND;
          str (stl + 2) := ' ';
          stl := stl + 2;
        FOREND;
        clp$put_display (display_control, str, clc$no_trim, status);
      FOREND /volume_loop/;
    ELSE
      scan_p := pvt [p$recorded_vsn].value;

    /rvsn_loop/
      FOR i := 1 TO clp$count_list_elements (pvt [p$recorded_vsn].value) DO
        vsn := scan_p^.element_value^.name_value;

        cmp$get_ms_class_on_volume (vsn, volume_found, ms_class_info);
        IF NOT volume_found THEN
          CYCLE /rvsn_loop/;
        IFEND;

        str := ' ';
        str (2, 6) := vsn;
        str (8, 3) := '   ';
        stl := 10;

        FOR ms_class := LOWERBOUND(ms_class_info) TO UPPERBOUND(ms_class_info) DO
          IF ms_class_info[ms_class] THEN
            str (stl + 1) := ms_class;
          ELSE
            str (stl + 1) := ' ';
          IFEND;
          str (stl + 2) := ' ';
          stl := stl + 2;
        FOREND;
        clp$put_display (display_control, str, clc$no_trim, status);

        scan_p := scan_p^.link;
      FOREND /rvsn_loop/;
    IFEND;

    str := '     ';
    clp$put_display (display_control, str, clc$no_trim, status);
    str := ' Class C: System swap files.';
    clp$put_display (display_control, str, clc$no_trim, status);
    str := ' Class J: System catalogs and subcatalogs.';
    clp$put_display (display_control, str, clc$no_trim, status);
    str := ' Class K: System permanent files.';
    clp$put_display (display_control, str, clc$no_trim, status);
    str := ' Class L: User catalogs and subcatalogs.';
    clp$put_display (display_control, str, clc$no_trim, status);
    str := ' Class M: User permanent files.';
    clp$put_display (display_control, str, clc$no_trim, status);
    str := ' Class N: User temporary files.';
    clp$put_display (display_control, str, clc$no_trim, status);
    str := ' Class P: System product files.';
    clp$put_display (display_control, str, clc$no_trim, status);
    str := ' Class Q: System critical files.';
    clp$put_display (display_control, str, clc$no_trim, status);
    str := ' Class U to Z: Reserved for Site Analyst use.';
    clp$put_display (display_control, str, clc$no_trim, status);
    str := '     ';
    clp$put_display (display_control, str, clc$no_trim, status);
    str := ' All other file classes are reserved for Control Data.';
    clp$put_display (display_control, str, clc$no_trim, status);

  PROCEND display_ms_class;

*blockend

?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_MS_FLAW', EJECT ??

  PROCEDURE display_ms_flaw
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (cmm$lcu_dismsf) display_ms_flaws, display_ms_flaw,dismf, disms..
{ f (
{     recorded_vsn, recorded_vsns, rvsn, rv: any of
{         key
{           all
{         keyend
{         list of name 1..6
{       anyend = ALL
{     display_option, do: key
{         (effect, e)
{         (source, s)
{       keyend = EFFECT
{     output, o: file = $OUTPUT
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (6),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 29, 13, 59, 5, 832],
    clc$command, 9, 4, 0, 0, 0, 0, 4, 'CMM$LCU_DISMSF'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['RECORDED_VSN                   ',clc$nominal_entry, 1],
    ['RECORDED_VSNS                  ',clc$alias_entry, 1],
    ['RV                             ',clc$abbreviation_entry, 1],
    ['RVSN                           ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 6],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, 6]]
      ]
    ,
    'ALL'],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['E                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['EFFECT                         ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['SOURCE                         ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'EFFECT'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$OUTPUT'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$recorded_vsn = 1,
      p$display_option = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    CONST
      command_name = 'DISPLAY_MS_FLAW';

    VAR
      big_enough_array: boolean,
      close_status: ost$status,
      default_file_contents: amt$file_contents,
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      file: clt$file,
      flaw_dau_information_p: ^array [1 .. * ] of dmt$flaw_dau_definition,
      flaw_duplication_index: integer,
      flaw_duplication_p: ^array [1 .. * ] of dmt$flaw_duplication,
      flaw_index: integer,
      i: integer,
      max_volume_index: integer,
      number_of_vol: integer,
      scan_p: ^clt$data_value,
      str: ost$string,
      volume_count: clt$list_size,
      volume_list: ^stt$volume_list;

    status.normal := TRUE;

    validate_command_usage (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_string_to_file (pvt [p$output].value^.file_value^, file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$display_option].value^.keyword_value = 'EFFECT' THEN
      default_file_contents := fsc$list;
    ELSEIF pvt [p$display_option].value^.keyword_value = 'SOURCE' THEN
      default_file_contents := fsc$legible_data;
    ELSE
      ;
    IFEND;

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);

    clp$open_display_file (file, NIL, default_file_contents, default_ring_attributes, display_control,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /display_open/
    BEGIN
      IF pvt [p$recorded_vsn].value^.kind = clc$keyword THEN
        cmp$obtain_max_volume_index (max_volume_index);
        PUSH volume_list: [1 .. max_volume_index];
        cmp$obtain_volumes (volume_list, number_of_vol);

      /all_volume_loop/
        FOR i := 1 TO number_of_vol DO
          flaw_index := 50;
          flaw_duplication_index := flaw_index * 10;
          REPEAT
            PUSH flaw_dau_information_p: [1 .. flaw_index];
            pmp$zero_out_table (flaw_dau_information_p, #SIZE (flaw_dau_information_p^));
            PUSH flaw_duplication_p: [1 .. flaw_duplication_index];
            pmp$zero_out_table (flaw_duplication_p, #SIZE (flaw_duplication_p^));
            dmp$identify_flawed_daus (volume_list^ [i].recorded_vsn, flaw_dau_information_p,
                  flaw_duplication_p, big_enough_array, status);
            IF NOT status.normal THEN
              CASE status.condition OF
              = dme$recorded_vsn_not_in_lun, dme$avt_entry_not_found =
                osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_recorded_vsn_not_found,
                      command_name, status);
              ELSE
                ;
              CASEND;
              EXIT /display_open/;
            IFEND;
            flaw_index := flaw_index + 50;
            flaw_duplication_index := flaw_index * 10;
          UNTIL big_enough_array = TRUE;

          display_flaw_list (volume_list^ [i].recorded_vsn, flaw_dau_information_p, flaw_duplication_p,
                pvt [p$display_option].value^.keyword_value, display_control, status);
          IF NOT status.normal THEN
            EXIT /display_open/;
          IFEND;

        FOREND /all_volume_loop/;

{ If a list of volumes was selected.

      ELSE
        scan_p := pvt [p$recorded_vsn].value;

        WHILE scan_p <> NIL DO
          flaw_index := 50;
          flaw_duplication_index := flaw_index * 10;
          REPEAT
            PUSH flaw_dau_information_p: [1 .. flaw_index];
            pmp$zero_out_table (flaw_dau_information_p, #SIZE (flaw_dau_information_p^));
            PUSH flaw_duplication_p: [1 .. flaw_duplication_index];
            pmp$zero_out_table (flaw_duplication_p, #SIZE (flaw_duplication_p^));
            dmp$identify_flawed_daus (scan_p^.element_value^.name_value (1, rmc$recorded_vsn_size),
                  flaw_dau_information_p, flaw_duplication_p, big_enough_array, status);
            IF NOT status.normal THEN
              CASE status.condition OF
              = dme$recorded_vsn_not_in_lun, dme$avt_entry_not_found =
                osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_recorded_vsn_not_found,
                      command_name, status);
              ELSE
                ;
              CASEND;
              EXIT /display_open/;
            IFEND;
            flaw_index := flaw_index + 50;
            flaw_duplication_index := flaw_index * 10;
          UNTIL big_enough_array = TRUE;

          display_flaw_list (scan_p^.element_value^.name_value (1, rmc$recorded_vsn_size),
                flaw_dau_information_p, flaw_duplication_p, pvt [p$display_option].value^.keyword_value,
                display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          scan_p := scan_p^.link;
        WHILEND;
      IFEND;

    END /display_open/;

    clp$close_display (display_control, close_status);
    IF status.normal AND NOT close_status.normal THEN
      status := close_status;
    IFEND;
  PROCEND display_ms_flaw;

?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_MS_VOLUME', EJECT ??

*block

  PROCEDURE display_ms_volume
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (cmm$lcu_dismsv) display_ms_volume, dismv, dismsv (
{    recorded_vsn, recorded_vsns, rvsn, rv: any of
{        key
{          all
{        keyend
{        list of name 1..6
{      anyend = ALL
{    display_options, display_option, do: any of
{       key
{        all
{      keyend
{      list of key
{        (allocation_size, as)
{        (transfer_size, ts)
{      keyend
{    anyend = all
{    output, o: file = $OUTPUT
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 4] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 25, 9, 29, 55, 784],
    clc$command, 10, 4, 0, 0, 0, 0, 4, 'CMM$LCU_DISMSV'], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['RECORDED_VSN                   ',clc$nominal_entry, 1],
    ['RECORDED_VSNS                  ',clc$alias_entry, 1],
    ['RV                             ',clc$abbreviation_entry, 1],
    ['RVSN                           ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 235, clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, 6]]
      ]
    ,
    'ALL'],
{ PARAMETER 2
    [[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]]
      ],
    171, [[1, 0, clc$list_type], [155, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [4], [
        ['ALLOCATION_SIZE                ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['AS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['TRANSFER_SIZE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['TS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$OUTPUT'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$recorded_vsn = 1,
      p$display_options = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;


    TYPE
      recorded_vsn_list = record
        recorded_vsn: rmt$recorded_vsn,
        valid: boolean,
      recend;

    CONST
      blank_line = '                                           ',
      command_name = 'DISPLAY_MS_VOLUME';

*copy clv$display_variables
*copy cmc$minimum_page_size

    VAR
      allocation_size_specified: boolean,
      as_value: string (15),
      display_control: clt$display_control,
      display_line: string (44),
      do_value_count: 0 .. clc$max_value_sets,
      element_status: iot$unit_status,
      file: clt$file,
      header: string (46),
      i: integer,
      ignore_status: ost$status,
      index: integer,
      j: integer,
      max_ms_volumes: integer,
      ms_volumes: ^array [ * ] of cmt$mass_storage_volume,
      output_open: boolean,
      rvsn_list: ^array [ * ] of recorded_vsn_list,
      scan_p: ^clt$data_value,
      state: cmt$element_state,
      string_length: integer,
      transfer_size_specified: boolean,
      ts_value: string (13),
      volume_attribute_info: dmt$volume_attribute_info,
      volume_count: 0 .. 7fffffff(16);

?? NEWTITLE := '    abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF output_open THEN
        clp$close_display (display_control, ignore_status);
        output_open := FALSE;
      IFEND;

    PROCEND abort_handler;

*copy clp$new_page_procedure

?? OLDTITLE ??
?? NEWTITLE := '    print_subtitle', EJECT ??

    PROCEDURE print_subtitle
      (    header: string (46);
       VAR status: ost$status);

      clp$put_partial_display (display_control, header, clc$no_trim, amc$continue, status);

      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND print_subtitle;

?? OLDTITLE ??
?? NEWTITLE := '    put_subtitle', EJECT ??

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

      print_subtitle (header, status);

      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND put_subtitle;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    header := '  RVSN     ALLOCATION SIZE     TRANSFER SIZE  ';
    output_open := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

  /main_program/

    BEGIN

      validate_command_usage (status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF pvt [p$recorded_vsn].value^.kind <> clc$keyword THEN
        volume_count := clp$count_list_elements (pvt [p$recorded_vsn].value);
        scan_p := pvt [p$recorded_vsn].value;
        PUSH rvsn_list: [1 .. volume_count];
        FOR i := 1 TO volume_count DO
          rvsn_list^ [i].recorded_vsn := scan_p^.element_value^.name_value;
          rvsn_list^ [i].valid := FALSE;
          scan_p := scan_p^.link;
        FOREND;
      IFEND;

      cmp$get_ms_volumes (max_ms_volumes);
      PUSH ms_volumes: [1 .. max_ms_volumes];
      cmp$get_ms_volume_info (ms_volumes);

      FOR i := 1 TO max_ms_volumes DO

{ Check if any of the volumes identified by RECORDED_VSN parameter is not ON.

        cmp$get_element_state_via_lun (ms_volumes^ [i].lun, state);
        IF state <> cmc$on THEN
          IF pvt [p$recorded_vsn].value^.kind = clc$keyword THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$element_state_not_proper,
                  ms_volumes^ [i].recorded_vsn, status);
            EXIT /main_program/;
          ELSE
            FOR j := 1 TO volume_count DO
              IF rvsn_list^ [j].recorded_vsn = ms_volumes^ [i].recorded_vsn THEN
                osp$set_status_abnormal (cmc$configuration_management_id, cme$element_state_not_proper,
                      ms_volumes^ [i].recorded_vsn, status);
                EXIT /main_program/;
              IFEND;
            FOREND;
          IFEND;
        IFEND;

{ Check if any of the volumes identified by RECORDED_VSN parameter is disabled.

        cmp$get_ms_status_via_lun (ms_volumes^ [i].lun, element_status);
        IF element_status.disabled THEN
          IF pvt [p$recorded_vsn].value^.kind = clc$keyword THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_invalid_element_status,
                  ms_volumes^ [i].recorded_vsn, status);
            EXIT /main_program/;
          ELSE
            FOR j := 1 TO volume_count DO
              IF rvsn_list^ [j].recorded_vsn = ms_volumes^ [i].recorded_vsn THEN
                osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_invalid_element_status,
                      ms_volumes^ [i].recorded_vsn, status);
                EXIT /main_program/;
              IFEND;
            FOREND;
          IFEND;
        IFEND;

        ms_volumes^ [i].on_and_enabled := (state = cmc$on) AND (NOT element_status.disabled);

        IF pvt [p$recorded_vsn].value^.kind = clc$keyword THEN
          IF ms_volumes^ [i].on_and_enabled THEN
            ms_volumes^ [i].changed := TRUE;
          IFEND;
        ELSE
          ms_volumes^ [i].changed := FALSE;

        /volume_loop_0/
          FOR j := 1 TO volume_count DO
            IF rvsn_list^ [j].recorded_vsn = ms_volumes^ [i].recorded_vsn THEN
              rvsn_list^ [j].valid := TRUE;
              IF ms_volumes^ [i].on_and_enabled THEN
                ms_volumes^ [i].changed := TRUE;
              IFEND;
              EXIT /volume_loop_0/;
            IFEND;
          FOREND /volume_loop_0/;
        IFEND;

      FOREND;

{ Check if a volume identified by RECORDED_VSN parameter invalid or not initialized.

      IF pvt [p$recorded_vsn].value^.kind <> clc$keyword THEN
        FOR j := 1 TO volume_count DO
          IF NOT rvsn_list^ [j].valid THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_invalid_recorded_vsn,
                  rvsn_list^ [j].recorded_vsn, status);
            EXIT /main_program/;
          IFEND;
        FOREND;
      IFEND;

      clp$convert_string_to_file (pvt [p$output].value^.file_value^, file, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$open_display (file, ^clp$new_page_procedure, display_control, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      output_open := TRUE;

      IF display_control.page_width < cmc$minimum_page_size THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_illegal_output_file,
              pvt [p$output].value^.file_value^, status);
        osp$append_status_integer (osc$status_parameter_delimiter, cmc$minimum_page_size, 10, FALSE, status);
        EXIT /main_program/;
      IFEND;

      clv$titles_built := FALSE;
      clv$command_name := 'display_ms_volume';

      allocation_size_specified := FALSE;
      transfer_size_specified := FALSE;
      IF pvt [p$display_options].value^.kind = clc$keyword THEN
        IF pvt [p$display_options].value^.keyword_value = 'ALL' THEN
          allocation_size_specified := TRUE;
          transfer_size_specified := TRUE;
        IFEND;
      ELSE
        do_value_count := clp$count_list_elements (pvt [p$display_options].value);
        scan_p := pvt [p$display_options].value;
        FOR i := 1 TO do_value_count DO
          IF scan_p^.element_value^.keyword_value = 'ALLOCATION_SIZE' THEN
            allocation_size_specified := TRUE;
          ELSEIF scan_p^.element_value^.keyword_value = 'TRANSFER_SIZE' THEN
            transfer_size_specified := TRUE;
          IFEND;
          scan_p := scan_p^.link;
        FOREND;
      IFEND;
      IF display_control.page_format = amc$continuous_form THEN
        clp$put_display (display_control, header, clc$no_trim, status);
        clp$new_display_line (display_control, 1, status);
      IFEND;

    /display_loop/
      FOR index := 1 TO max_ms_volumes DO
        IF ms_volumes^ [index].on_and_enabled THEN
          IF ms_volumes^ [index].changed THEN

            cmp$get_volume_attributes (ms_volumes^ [index].lun, volume_attribute_info,
                  ms_volumes^ [index].write_status);

            IF NOT ms_volumes^ [index].write_status.normal THEN
              CYCLE /display_loop/;
            IFEND;

            display_line := blank_line;
            display_line (3, 6) := ms_volumes^ [index].recorded_vsn;

            IF allocation_size_specified AND transfer_size_specified THEN
              STRINGREP (as_value, string_length, volume_attribute_info.default_allocation_size);
              display_line (12, string_length) := as_value;
              STRINGREP (ts_value, string_length, volume_attribute_info.default_transfer_size);
              display_line (32, string_length) := ts_value;
            ELSEIF allocation_size_specified AND NOT transfer_size_specified THEN
              STRINGREP (as_value, string_length, volume_attribute_info.default_allocation_size);
              display_line (12, string_length) := as_value;
            ELSEIF transfer_size_specified AND NOT allocation_size_specified THEN
              STRINGREP (ts_value, string_length, volume_attribute_info.default_transfer_size);
              display_line (32, string_length) := ts_value;
            IFEND;
            clp$put_display (display_control, display_line, clc$no_trim, status);
          IFEND;
        IFEND;
      FOREND /display_loop/;

    /volume_loop_3/
      FOR i := 1 TO max_ms_volumes DO
        IF ms_volumes^ [i].on_and_enabled THEN
          IF ms_volumes^ [i].changed THEN
            IF NOT ms_volumes^ [i].write_status.normal THEN
              osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_recorded_vsn_not_found,
                    ms_volumes^ [index].recorded_vsn, status);
            IFEND;
          IFEND;
        IFEND;
      FOREND /volume_loop_3/;

    END /main_program/;

  PROCEND display_ms_volume;
*blockend

?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_NETWORK_CONFIGURATION', EJECT ??

*block

  PROCEDURE [XDCL, #GATE] cmp$display_netw_configuration
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{   PROCEDURE (cmm$lcu_disnc) cmp$display_netw_configuration, disnc (
{     display_options, display_option, do: key
{         (networks, network, n)
{         all
{       keyend = ALL
{     output, o: file = $output
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 22, 10, 18, 2, 561],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'CMM$LCU_DISNC'], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 1],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 1],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [4], [
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NETWORK                        ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['NETWORKS                       ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'ALL'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$display_options = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;
*copyc clv$display_variables
*copyc cmc$minimum_page_size

    CONST
      command_name = 'DISPLAY_NETWORK_CONFIGURATION';

    VAR
      caller_id: ost$caller_identifier,
      display_control: clt$display_control,
      display_option: nat$display_option,
      header: string (50),
      file: clt$file,
      i: 0 .. clc$max_value_sets,
      ignore_status: ost$status,
      output_open: boolean;

?? NEWTITLE := '    abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF output_open THEN
        clp$close_display (display_control, ignore_status);
        output_open := FALSE;
      IFEND;

    PROCEND abort_handler;

*copyc clp$new_page_procedure

?? OLDTITLE ??
?? NEWTITLE := '    print_subtitle', EJECT ??

    PROCEDURE print_subtitle
      (    header: string (50);
       VAR status: ost$status);

      clp$put_partial_display (display_control, header, clc$trim, amc$continue, status);

    PROCEND print_subtitle;

?? OLDTITLE ??
?? NEWTITLE := '    put_subtitle', EJECT ??

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

      print_subtitle (header, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND put_subtitle;

?? OLDTITLE, EJECT ??

    #caller_id (caller_id);
    status.normal := TRUE;
    output_open := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

  /main_program/
    BEGIN
      validate_command_usage (status);
      IF caller_id.ring > 6 THEN
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

{ Currently there is only one display_option, namely NETWORKS.

      display_option := nac$display_networks;

      clp$convert_string_to_file (pvt [p$output].value^.file_value^, file, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      header := ' ACTIVE NETWORK CONFIGURATION ';
      clp$open_display (file, ^clp$new_page_procedure, display_control, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      output_open := TRUE;

      IF display_control.page_width < cmc$minimum_page_size THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_illegal_output_file,
              file.local_file_name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, cmc$minimum_page_size, 10, FALSE, status);
        EXIT /main_program/;
      IFEND;

      clv$titles_built := FALSE;
      clv$command_name := command_name;

      nap$display_network_config (display_option, display_control, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    END /main_program/;

    IF output_open THEN
      clp$close_display (display_control, ignore_status);
      output_open := FALSE;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND cmp$display_netw_configuration;
*blockend

?? OLDTITLE ??
?? NEWTITLE := 'display_processor_state', EJECT ??

{ PURPOSE:
{   This procedure is the command processor for the command 'DISPLAY_PROCESSOR_STATE'.  It generates a display
{   detailing some useful information about the CPUs configured on the mainframe and sends it to the screen or
{   to an output file.

*block

  PROCEDURE display_processor_state
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (cmm$lcu_disps) display_processor_state, disps (
{   processors, processor, p: any of
{       key
{         (all, a)
{       keyend
{       list of key cp0 cp1 keyend
{     anyend = ALL
{   output, o: file = $OUTPUT
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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 .. 2] 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 .. 2] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 9, 30, 11, 11, 51, 706],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'CMM$LCU_DISPS'], [
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['P                              ',clc$abbreviation_entry, 1],
    ['PROCESSOR                      ',clc$alias_entry, 1],
    ['PROCESSORS                     ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 198,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    97, [[1, 0, clc$list_type], [81, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [2], [
        ['CP0                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['CP1                            ', clc$nominal_entry, clc$normal_usage_entry, 2]]
        ]
      ]
    ,
    'ALL'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$OUTPUT'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$processors = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    TYPE
      t$cpu_data = RECORD
        display_data: boolean,
        physically_configured: boolean,
        element_p: ^cmt$cpu_element_definition,
      RECEND,

      t$line = RECORD
        CASE boolean OF
        = TRUE =
          line: string (80),
        = FALSE =
          cpu_number: string (27),
          element_number: string (7),
          space_1: string (2),
          model_number: string (6),
          space_2: string (2),
          serial_number: string (6),
          space_3: string (2),
          state: string (5),
          space_4: string (2),
          reason_for_current_state: string (21),
        CASEND,
      RECEND;

*copyc clv$display_variables
*copyc cmc$minimum_page_size

    VAR
      cpu_data: ARRAY [0 .. 1] OF t$cpu_data,
      cpu_index: ost$processor_id,
      display_control: clt$display_control,
      header: string (50),
      list_p: ^clt$data_value,
      local_status: ost$status,
      option_p: ^clt$data_value,
      output_line: t$line,
      ring_attributes: amt$ring_attributes,
      string_1: string (1),
      string_2: string (2),
      string_4: string (4);

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      clp$close_display (display_control, local_status);

    PROCEND abort_handler;

*copyc clp$new_page_procedure

?? OLDTITLE ??
?? NEWTITLE := 'print_subtitle', EJECT ??

    PROCEDURE print_subtitle
      (    header: string (50);
       VAR status: ost$status);

      clp$put_partial_display (display_control, header, clc$trim, amc$continue, status);

    PROCEND print_subtitle;

?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle', EJECT ??

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

      print_subtitle (header, status);

    PROCEND put_subtitle;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    header := 'PROCESSOR CONFIGURATION';
    validate_command_usage (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);
    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF display_control.page_width < cmc$minimum_page_size THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_illegal_output_file,
            pvt [p$output].value^.file_value^, status);
      osp$append_status_integer (osc$status_parameter_delimiter, cmc$minimum_page_size, 10, FALSE, status);
      clp$close_display (display_control, local_status);
      RETURN;
    IFEND;

    clv$titles_built := FALSE;
    clv$command_name := 'DISPLAY_PROCESSOR_STATE';

    FOR cpu_index := LOWERBOUND (cpu_data) TO UPPERBOUND (cpu_data) DO
      cpu_data [cpu_index].display_data := FALSE;
      PUSH cpu_data [cpu_index].element_p;
      cmp$get_cpu_element_r3 (cpu_index, cpu_data [cpu_index].element_p, local_status);
      cpu_data [cpu_index].physically_configured := local_status.normal;
    FOREND;

    IF (pvt [p$processors].value^.kind = clc$keyword) AND
          (pvt [p$processors].value^.keyword_value = 'ALL') THEN
      FOR cpu_index := LOWERBOUND (cpu_data) TO UPPERBOUND (cpu_data) DO
        IF cpu_data [cpu_index].physically_configured THEN
          cpu_data [cpu_index].display_data := TRUE;
        IFEND;
      FOREND;
    ELSE
      list_p := pvt [p$processors].value;
      WHILE list_p <> NIL DO
        option_p := list_p^.element_value;
        list_p := list_p^.link;
        IF option_p^.keyword_value = 'CP0' THEN
          cpu_data [0].display_data := TRUE;
        ELSEIF option_p^.keyword_value = 'CP1' THEN
          cpu_data [1].display_data := TRUE;
        IFEND;
      WHILEND;
    IFEND;

    output_line.line := ' ';
    output_line.cpu_number := 'Central Processor Unit #';
    output_line.element_number := 'Element';
    output_line.model_number := 'Model';
    output_line.serial_number := 'Serial';
    output_line.state := 'State';
    output_line.reason_for_current_state := 'Reason for';
    clp$put_display (display_control, output_line.line, clc$trim, local_status);
    output_line.line := ' ';
    output_line.element_number := 'Number';
    output_line.model_number := 'Number';
    output_line.serial_number := 'Number';
    output_line.reason_for_current_state := 'Current State';
    clp$put_display (display_control, output_line.line, clc$trim, local_status);

    FOR cpu_index := LOWERBOUND (cpu_data) TO UPPERBOUND (cpu_data) DO
      IF cpu_data [cpu_index].display_data THEN
        clp$convert_integer_to_rjstring (cpu_index, 10, FALSE, '0', string_1, local_status);
        IF cpu_data [cpu_index].physically_configured THEN
          output_line.line := ' ';

          output_line.cpu_number := string_1;

          clp$convert_integer_to_rjstring (cpu_data [cpu_index].element_p^.element_number, 16, FALSE, '0',
                string_2, local_status);
          output_line.element_number := string_2;
          clp$convert_integer_to_rjstring (cpu_data [cpu_index].element_p^.model_number, 16, FALSE, '0',
                string_2, local_status);
          output_line.model_number := string_2;
          clp$convert_integer_to_rjstring (cpu_data [cpu_index].element_p^.serial_number, 16, FALSE, '0',
                string_4, local_status);
          output_line.serial_number := string_4;

          CASE cpu_data [cpu_index].element_p^.processor_state OF
          = cmc$on =
            output_line.state := 'ON';
          = cmc$off =
            output_line.state := 'OFF';
          ELSE {= cmc$down =}
            output_line.state := 'DOWN';
          CASEND;

          CASE cpu_data [cpu_index].element_p^.reason_for_current_state OF
          = osc$cdsr_null =
            output_line.reason_for_current_state := ' ';
          = osc$cdsr_downed_by_dft =
            output_line.reason_for_current_state := 'Downed by DFT';
          = osc$cdsr_due_threshold_exceeded =
            output_line.reason_for_current_state := 'DUE level exceeded';
          = osc$cdsr_cpu_timeout =
            output_line.reason_for_current_state := 'CPU Timeout';
          = osc$cdsr_downed_by_operator =
            output_line.reason_for_current_state := 'Downed by operator';
          ELSE {= osc$cdsr_downed_by_system =}
            output_line.reason_for_current_state := 'Downed by SYSTEM';
          CASEND;

        ELSE
          output_line.line := ' CPU n information could not be displayed.  It is not physically configured.';
          output_line.line (6) := string_1;
        IFEND;
        clp$put_display (display_control, output_line.line, clc$trim, local_status);
      IFEND;
    FOREND;

    clp$close_display (display_control, local_status);
    osp$disestablish_cond_handler;

  PROCEND display_processor_state;
*blockend
?? OLDTITLE ??
?? NEWTITLE := '  ENABLE_PRODUCTION', EJECT ??

{ PURPOSE:
{ This procedure is the command processor for the command 'ENABLE_PRODUCTION'.  It makes a call to ring 3 to
{ enable production of a processor which has just been reinstated.

*block

  PROCEDURE enable_production
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (cmm$lcu_enap) enable_production, enap (
{     status)

?? 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,
        recend,
      recend := [
      [1,
      [91, 3, 18, 15, 3, 14, 704],
      clc$command, 1, 1, 0, 0, 0, 0, 1, 'CMM$LCU_ENAP'], [
      ['STATUS                         ',clc$nominal_entry, 1]],
      [
{ PARAMETER 1
      [1, clc$normal_usage_entry, clc$non_secure_parameter,
      $clt$parameter_spec_methods[clc$specify_by_name],
      clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
    clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    status.normal := TRUE;

    IF NOT (avp$system_operator () OR avp$configuration_administrator () OR
          avp$removable_media_operator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active,
            'configuration_administration, removable_media_operation or system_operation', status);
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$enable_production_r3 (status);

  PROCEND enable_production;
*blockend
?? OLDTITLE ??
?? NEWTITLE := '  FORMAT_REINSTATED_PARITY_UNIT', EJECT ??

  PROCEDURE format_reinstated_parity_unit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE format_reinstated_parity_unit, forrpu (
{     element, e: name = $required
{     force_format_on_reinstatement, ffor: boolean = FALSE
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 4, 10, 14, 26, 58, 587],
    clc$command, 5, 3, 1, 0, 0, 0, 3, ''], [
    ['E                              ',clc$abbreviation_entry, 1],
    ['ELEMENT                        ',clc$nominal_entry, 1],
    ['FFOR                           ',clc$abbreviation_entry, 2],
    ['FORCE_FORMAT_ON_REINSTATEMENT  ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$boolean_type],
    'FALSE'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element = 1,
      p$force_format_on_reinstatement = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    CONST
      command_name = 'FORMAT_REINSTATED_PARITY_UNIT';

    VAR
      element_definition: ^cmt$element_definition,
      element: cmt$element_name,
      force_format: boolean,
      logical_unit_number: iot$logical_unit,
      product_id: cmt$product_identification,
      state: cmt$element_state,
      system_supplied_name: jmt$system_supplied_name,
      unused_iou_name: cmt$element_name,
      user_supplied_name: jmt$user_supplied_name;

  /main_program/
    BEGIN

{ Valdate user for 'configuration_administrator' capability.
    IF (NOT avp$configuration_administrator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      EXIT /main_program/;
    IFEND;

{ Validate parameters.
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      EXIT /main_program/;
    IFEND;

{ Manage LCU lock.
    IF NOT cmp$lock_set_by_current_task (cmc$configuration_administrator) THEN
      pmp$get_job_names (user_supplied_name, system_supplied_name, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      cmp$manage_lock_r3 (cmc$configuration_administrator, FALSE,
           system_supplied_name, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
    IFEND;

    element := pvt [p$element].value^.name_value;
    force_format := pvt [p$force_format_on_reinstatement].value^.boolean_value.value;

{ Get definition for element.
    PUSH element_definition;
    cmp$get_element_r3 (element, unused_iou_name, element_definition, status);
    IF NOT status.normal THEN
      EXIT /main_program/;
    IFEND;
    product_id := element_definition^.product_id;

{ Get logical unit number.
    cmp$get_logical_unit_number_r3 (element, logical_unit_number, status);
    IF NOT status.normal THEN
      EXIT /main_program/;
    IFEND;
    IF logical_unit_number = 0 THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_element_not_found, element, status);
      EXIT /main_program/;
    IFEND;

{ Insure that the element state is 'ON'.
      cmp$get_element_state_via_lun (logical_unit_number, state);
      IF state <> cmc$on THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_device_not_active, element, status);
        EXIT /main_program/;
      IFEND;


    cmp$process_force_format (product_id, element, logical_unit_number, force_format, status);
    IF NOT status.normal THEN
      EXIT /main_program/;
    IFEND

  END /main_program/;

  PROCEND format_reinstated_parity_unit;
?? OLDTITLE ??
?? NEWTITLE := '  INITIALIZE_MS_VOLUME', EJECT ??

  PROCEDURE initialize_ms_volume
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (cmm$lcu_inimsv) initialize_ms_volume, inimv, inimsv (
{   element, e: name = $required
{   recorded_vsn, rvsn, rv: name 1..6 = $required
{   retain_device_flaws, rdf: boolean = TRUE
{   allocation_size, as: key
{       $16k, $32k, $64k, $128k, $256k, $512k
{       (cylinder, c)
{     keyend = $16K
{   transfer_size, ts: key
{       $16k, $32k, $64k, $128k, $256k, $512k
{       (cylinder, c)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 12] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 29, 13, 44, 47, 979],
    clc$command, 12, 6, 2, 0, 0, 0, 6, 'CMM$LCU_INIMSV'], [
    ['ALLOCATION_SIZE                ',clc$nominal_entry, 4],
    ['AS                             ',clc$abbreviation_entry, 4],
    ['E                              ',clc$abbreviation_entry, 1],
    ['ELEMENT                        ',clc$nominal_entry, 1],
    ['RDF                            ',clc$abbreviation_entry, 3],
    ['RECORDED_VSN                   ',clc$nominal_entry, 2],
    ['RETAIN_DEVICE_FLAWS            ',clc$nominal_entry, 3],
    ['RV                             ',clc$abbreviation_entry, 2],
    ['RVSN                           ',clc$alias_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 6],
    ['TRANSFER_SIZE                  ',clc$nominal_entry, 5],
    ['TS                             ',clc$abbreviation_entry, 5]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 303, clc$optional_default_parameter, 0, 4],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 303, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, 6]],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [8], [
    ['$128K                          ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['$16K                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['$256K                          ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
    ['$32K                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['$512K                          ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
    ['$64K                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
    ['CYLINDER                       ', clc$nominal_entry,
  clc$normal_usage_entry, 7]]
    ,
    '$16K'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [8], [
    ['$128K                          ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['$16K                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['$256K                          ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
    ['$32K                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['$512K                          ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
    ['$64K                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
    ['CYLINDER                       ', clc$nominal_entry,
  clc$normal_usage_entry, 7]]
    ],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element = 1,
      p$recorded_vsn = 2,
      p$retain_device_flaws = 3,
      p$allocation_size = 4,
      p$transfer_size = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    CONST
      command_name = 'INITIALIZE_MS_VOLUME';

    VAR
      access_code: ost$name,
      allocation_size: dmt$allocation_size,
      allow_to_continue: boolean,
      continue_initialization: boolean,
      converted_parameter: clt$integer,
      cylinder_allocation_size: boolean,
      cylinder_transfer_size: boolean,
      element: cmt$element_name,
      initialize_status_info: dmt$initialize_status_info,
      logical_attributes_p: ^dmt$logical_device_attributes,
      logical_unit_number: iot$logical_unit,
      mainframe_element: ^cmt$element_definition,
      number_of_digits: integer,
      owner_id: ost$user_identification,
      physical_attributes_p: ^dmt$physical_device_attributes,
      product_id: cmt$product_identification,
      recorded_vsn: rmt$recorded_vsn,
      retain_flaws: boolean,
      set_name: stt$set_name,
      state: cmt$element_state,
      system_supplied_name: jmt$system_supplied_name,
      transfer_size: dmt$transfer_size,
      transfer_size_specified: boolean,
      unused_iou_name: cmt$element_name,
      user_supplied_name: jmt$user_supplied_name,
      volume_label_attributes_p: ^dmt$volume_label_attributes;

    status.normal := TRUE;
    cylinder_allocation_size := FALSE;
    cylinder_transfer_size := FALSE;
    transfer_size_specified := FALSE;
    set_name := 'INIMV ATTEMPTED';

  /main_program/
    BEGIN
      IF (NOT avp$configuration_administrator ()) THEN
        osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
        EXIT /main_program/;
      IFEND;
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF NOT cmp$lock_set_by_current_task (cmc$configuration_administrator) THEN
        pmp$get_job_names (user_supplied_name, system_supplied_name, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        cmp$manage_lock_r3 (cmc$configuration_administrator, FALSE,
             system_supplied_name, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;
      cylinder_allocation_size := FALSE;
      cylinder_transfer_size := FALSE;

      element := pvt [p$element].value^.name_value;
      recorded_vsn := pvt [p$recorded_vsn].value^.name_value;
      retain_flaws := pvt [p$retain_device_flaws].value^.boolean_value.value;

      IF pvt [p$allocation_size].value^.keyword_value = 'CYLINDER' THEN
        cylinder_allocation_size := TRUE;
      ELSEIF pvt [p$allocation_size].value^.keyword_value = '$16K' THEN
        allocation_size := 16 * dmc$k_multiplier;
      ELSEIF pvt [p$allocation_size].value^.keyword_value = '$32K' THEN
        allocation_size := 32 * dmc$k_multiplier;
      ELSEIF pvt [p$allocation_size].value^.keyword_value = '$64K' THEN
        allocation_size := 64 * dmc$k_multiplier;
      ELSEIF pvt [p$allocation_size].value^.keyword_value = '$128K' THEN
        allocation_size := 128 * dmc$k_multiplier;
      ELSEIF pvt [p$allocation_size].value^.keyword_value = '$256K' THEN
        allocation_size := 256 * dmc$k_multiplier;
      ELSEIF pvt [p$allocation_size].value^.keyword_value = '$512K' THEN
        allocation_size := 512 * dmc$k_multiplier;
      IFEND;

      IF pvt [p$transfer_size].specified THEN
        IF pvt [p$transfer_size].value^.keyword_value = 'CYLINDER' THEN
          cylinder_transfer_size := TRUE;
        ELSEIF pvt [p$transfer_size].value^.keyword_value = '$16K' THEN
          transfer_size := 16 * dmc$k_multiplier;
        ELSEIF pvt [p$transfer_size].value^.keyword_value = '$32K' THEN
          transfer_size := 32 * dmc$k_multiplier;
        ELSEIF pvt [p$transfer_size].value^.keyword_value = '$64K' THEN
          transfer_size := 64 * dmc$k_multiplier;
        ELSEIF pvt [p$transfer_size].value^.keyword_value = '$128K' THEN
          transfer_size := 128 * dmc$k_multiplier;
        ELSEIF pvt [p$transfer_size].value^.keyword_value = '$256K' THEN
          transfer_size := 256 * dmc$k_multiplier;
        ELSEIF pvt [p$transfer_size].value^.keyword_value = '$512K' THEN
          transfer_size := 512 * dmc$k_multiplier;
        IFEND;
      ELSE
        transfer_size := dmc$unspecified_transfer_size;
      IFEND;

      cmp$get_logical_unit_number_r3 (element, logical_unit_number, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF logical_unit_number = cmc$job_template_unit_ordinal THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_illegal_inimv, '  ', status);
        EXIT /main_program/;
      ELSEIF logical_unit_number = 0 THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_element_not_found, element, status);
        EXIT /main_program/;
      IFEND;
      cmp$get_element_state_via_lun (logical_unit_number, state);
      IF state <> cmc$on THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_device_not_active, element, status);
        EXIT /main_program/;
      IFEND;

      PUSH mainframe_element;
      cmp$get_element_r3 (element, unused_iou_name, mainframe_element, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      cmp$validate_cip_path (logical_unit_number, continue_initialization);
      IF NOT continue_initialization THEN
        EXIT /main_program/;
      IFEND;

      product_id := mainframe_element^.product_id;

      PUSH physical_attributes_p: [1 .. 7];

      physical_attributes_p^ [1].keyword := dmc$bytes_per_mau;
      physical_attributes_p^ [2].keyword := dmc$cylinders_per_device;
      physical_attributes_p^ [3].keyword := dmc$maus_per_cylinder;
      physical_attributes_p^ [4].keyword := dmc$maus_per_dau;
      physical_attributes_p^ [5].keyword := dmc$sectors_per_mau;
      physical_attributes_p^ [6].keyword := dmc$sectors_per_track;
      physical_attributes_p^ [7].keyword := dmc$flaw_map_locations;

      cmp$get_physical_attributes (product_id, physical_attributes_p, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      PUSH volume_label_attributes_p: [1 .. 3];

      volume_label_attributes_p^ [1].keyword := dmc$label_access_code;
      volume_label_attributes_p^ [1].access_code := dmc$default_vol_access_code;
      volume_label_attributes_p^ [2].keyword := dmc$label_expiration_days;
      volume_label_attributes_p^ [2].expiration_days := dmc$max_expiration_days;
      volume_label_attributes_p^ [3].keyword := dmc$label_recorded_vsn;
      volume_label_attributes_p^ [3].recorded_vsn := recorded_vsn;

      PUSH logical_attributes_p: [1 .. 6];

      logical_attributes_p^ [1].keyword := dmc$volume_dfl_entries;
      logical_attributes_p^ [2].keyword := dmc$volume_directory_entries;
      logical_attributes_p^ [3].keyword := dmc$logical_flaws;
      logical_attributes_p^ [4].keyword := dmc$volume_default_transfer_sz;
      logical_attributes_p^ [5].keyword := dmc$volume_default_alloc_sz;
      logical_attributes_p^ [6].keyword := dmc$cylinder_allocation_size;

      cmp$get_logical_attributes (product_id, logical_attributes_p, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF cylinder_allocation_size THEN
        logical_attributes_p^ [5].volume_default_allocation_size :=
              logical_attributes_p^ [6].bytes_per_cylinder;
      ELSE
        logical_attributes_p^ [5].volume_default_allocation_size := allocation_size;
      IFEND;

      IF pvt [p$transfer_size].specified THEN
        IF cylinder_transfer_size THEN
          logical_attributes_p^ [4].volume_default_transfer_size :=
                logical_attributes_p^ [6].bytes_per_cylinder;
        ELSE
          logical_attributes_p^ [4].volume_default_transfer_size := transfer_size;
        IFEND;
      IFEND;

      access_code := dmc$default_vol_access_code;
      owner_id.family := jmc$system_family;
      owner_id.user := jmc$system_user;

      cmp$initialize_ms_volume (access_code, product_id, owner_id, physical_attributes_p,
            logical_attributes_p, volume_label_attributes_p, logical_unit_number, FALSE, retain_flaws,
            initialize_status_info, status);
      IF NOT status.normal THEN
        cmp$check_init_status (status, initialize_status_info, element, continue_initialization);
        IF continue_initialization THEN
          IF status.condition = dme$vol_label_date_not_expired THEN
            cmp$validate_set_membership (recorded_vsn, set_name, allow_to_continue, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            IF NOT allow_to_continue THEN
              EXIT /main_program/;
            IFEND;
          IFEND;
          cmp$get_element_state_via_lun (logical_unit_number, state);
          IF state <> cmc$on THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_device_not_active,
                  element, status);
            EXIT /main_program/;
          IFEND;

          cmp$initialize_ms_volume (access_code, product_id, owner_id, physical_attributes_p,
                logical_attributes_p, volume_label_attributes_p, logical_unit_number, TRUE, retain_flaws,
                initialize_status_info, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        ELSE
          EXIT /main_program/;
        IFEND;
      IFEND;

      cmp$volume_online (logical_unit_number, physical_attributes_p, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    END /main_program/;
  PROCEND initialize_ms_volume;

?? OLDTITLE ??
?? NEWTITLE := '  INITIATE_DAS_RESTORE', EJECT ??

  PROCEDURE initiate_das_restore
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{     PROCEDURE initiate_das_restore, inidr (
{       element, e: name = $required
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [94, 4, 14, 10, 23, 3, 603],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['E                              ',clc$abbreviation_entry, 1],
    ['ELEMENT                        ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    CONST
      command_name = 'INITIATE_DAS_RESTORE';

    VAR
      element_definition: ^cmt$element_definition,
      element: cmt$element_name,
      logical_unit_number: iot$logical_unit,
      product_id: cmt$product_identification,
      state: cmt$element_state,
      system_supplied_name: jmt$system_supplied_name,
      unused_iou_name: cmt$element_name,
      user_supplied_name: jmt$user_supplied_name;

  /main_program/
    BEGIN

{ Valdate user for 'configuration_administrator' capability.
    IF (NOT avp$configuration_administrator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      EXIT /main_program/;
    IFEND;

{ Validate parameters.
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      EXIT /main_program/;
    IFEND;

{ Manage LCU lock.
    IF NOT cmp$lock_set_by_current_task (cmc$configuration_administrator) THEN
      pmp$get_job_names (user_supplied_name, system_supplied_name, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      cmp$manage_lock_r3 (cmc$configuration_administrator, FALSE,
           system_supplied_name, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
    IFEND;

    element := pvt [p$element].value^.name_value;

{ Get definition for element.
    PUSH element_definition;
    cmp$get_element_r3 (element, unused_iou_name, element_definition, status);
    IF NOT status.normal THEN
      EXIT /main_program/;
    IFEND;
    product_id := element_definition^.product_id;

{ Get logical unit number.
    cmp$get_logical_unit_number_r3 (element, logical_unit_number, status);
    IF NOT status.normal THEN
      EXIT /main_program/;
    IFEND;
    IF logical_unit_number = 0 THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_element_not_found, element, status);
      EXIT /main_program/;
    IFEND;

{ Insure that the element state is 'ON'.
      cmp$get_element_state_via_lun (logical_unit_number, state);
      IF state <> cmc$on THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_device_not_active, element, status);
        EXIT /main_program/;
      IFEND;

    cmp$process_das_restore (product_id, element, logical_unit_number, status);
    IF NOT status.normal THEN
      EXIT /main_program/;
    IFEND

  END /main_program/;

  PROCEND initiate_das_restore;
?? OLDTITLE ??
?? NEWTITLE := '  INSTALL_NETWORK_CONFIGURATION', EJECT ??

  PROCEDURE install_network_configuration
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (cmm$lcu_insnc) install_network_configuration, insnc (
{   input, i: file = $required
{   errors, error, e: file = $ERRORS
{   retain_high_cycles, retain_high_cycle, rhc: any of
{       key
{         all
{       keyend
{       integer 1..pfc$maximum_cycle_number
{     anyend = 2
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 9] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type3: 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$integer_type_qualifier,
          recend,
          default_value: string (1),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 11, 2, 12, 34, 56, 789], clc$command, 9, 4, 1, 0, 0, 0, 4, 'CMM$LCU_INSNC'],
            [['E                              ', clc$abbreviation_entry, 2],
            ['ERROR                          ', clc$alias_entry, 2],
            ['ERRORS                         ', clc$nominal_entry, 2],
            ['I                              ', clc$abbreviation_entry, 1],
            ['INPUT                          ', clc$nominal_entry, 1],
            ['RETAIN_HIGH_CYCLE              ', clc$alias_entry, 3],
            ['RETAIN_HIGH_CYCLES             ', clc$nominal_entry, 3],
            ['RHC                            ', clc$abbreviation_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 4]], [

{ INPUT, I

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ ERRORS, ERROR, E

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ RETAIN_HIGH_CYCLES, RETAIN_HIGH_CYCLE, RHC

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 84, clc$optional_default_parameter, 0, 1],

{ STATUS

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ INPUT, I

      [[1, 0, clc$file_type]],

{ ERRORS, ERROR, E

      [[1, 0, clc$file_type], '$ERRORS'],

{ RETAIN_HIGH_CYCLES, RETAIN_HIGH_CYCLE, RHC

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type], [1, pfc$maximum_cycle_number, 10]],
            '2'],

{ STATUS

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$input = 1,
      p$errors = 2,
      p$retain_high_cycles = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    CONST
      command_name = 'INSTALL_NETWORK_CONFIGURATION';

    VAR
      access_sel: array [1 .. 1] of fst$attachment_option,
      access_selections: [STATIC, READ, oss$job_paged_literal] array [1 .. 2] of fst$attachment_option :=
            [[fsc$open_position, amc$open_at_boi], [fsc$access_and_share_modes,
            [fsc$specific_access_modes, [fsc$read, fsc$shorten, fsc$append, fsc$modify]],
            [fsc$determine_from_access_modes]]],
      byte_address: amt$file_byte_address,
      command_line: string (256),
      config_cycles: 0 .. pfc$maximum_cycle_number,
      config_file_path: [STATIC, READ, oss$job_paged_literal] array [1 .. 4] of pft$name :=
            [nac$network_family, nac$network_master_catalog, nac$network_subcatalog, nac$configuration_file],
      contains_data: boolean,
      continuation_string: array [1 .. 50] of ost$string,
      done: boolean,
      echoed_string: ost$string,
      error_fid: amt$file_identifier,
      error_file_name: amt$local_file_name,
      error_string: ost$string,
      existing_file: boolean,
      file: clt$file,
      file_position: amt$file_position,
      get_attr: array [1 .. 1] of amt$get_item,
      highest_cycle: [STATIC, READ, oss$job_paged_literal] pft$cycle_selector := [pfc$highest_cycle],
      i: 0 .. 50,
      ignore_status: ost$status,
      input_fid: amt$file_identifier,
      input_file_name: amt$local_file_name,
      line: string (256),
      line_continues: boolean,
      local_file: boolean,
      local_status: ost$status,
      local_status_identifier: ost$status_identifier,
      lowest_cycle: [STATIC, READ, oss$job_paged_literal] pft$cycle_selector := [pfc$lowest_cycle],
      maximum_retention: [STATIC, READ, oss$job_paged_literal] pft$retention := pfc$maximum_retention,
      name: ost$name,
      network_config_file_$high: clt$file,
      network_config_high_cycle: [READ, oss$job_paged_literal] string (35) :=
            '$SYSTEM.NETWORK.CONFIGURATION.$HIGH',
      network_configuration_file: clt$file,
      new_file_fid: amt$file_identifier,
      number_of_lines: 0 .. 50,
      password: [STATIC, READ, oss$job_paged_literal] pft$password := ' ',
      pos: integer,
      retain_cycle_count: 1 .. pfc$maximum_cycle_number,
      system_network_catalog: [STATIC, READ, oss$job_paged_literal] array [1 .. 3] of pft$name :=
            [nac$network_family, nac$network_master_catalog, nac$network_subcatalog],
      size: integer,
      system_supplied_name: jmt$system_supplied_name,
      transfer_count: amt$transfer_count,
      user_supplied_name: jmt$user_supplied_name;

    status.normal := TRUE;

  /main_program/
    BEGIN
      IF (NOT avp$configuration_administrator ()) THEN
        osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
        EXIT /main_program/;
      IFEND;

      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF NOT cmp$lock_set_by_current_task (cmc$configuration_administrator) THEN
        pmp$get_job_names (user_supplied_name, system_supplied_name, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        cmp$manage_lock_r3 (cmc$configuration_administrator, FALSE,
              system_supplied_name, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF pvt [p$retain_high_cycles].value^.kind = clc$keyword THEN
        retain_cycle_count := pfc$maximum_cycle_number;
      ELSEIF pvt [p$retain_high_cycles].value^.kind = clc$integer THEN
        retain_cycle_count := pvt [p$retain_high_cycles].value^.integer_value.value;
      ELSE
        ;
      IFEND;

      clp$convert_string_to_file (pvt [p$input].value^.file_value^, file, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      input_file_name := file.local_file_name;

      get_attr [1].key := amc$null_attribute;
      amp$get_file_attributes (input_file_name, get_attr, local_file, existing_file, contains_data, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF NOT (existing_file AND contains_data) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_empty_input_on_vernc,
              pvt [p$input].value^.file_value^, status);
        EXIT /main_program/;
      IFEND;

      access_sel [1].selector := fsc$access_and_share_modes;
      access_sel [1].access_modes.selector := fsc$specific_access_modes;
      access_sel [1].access_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
      access_sel [1].share_modes.selector := fsc$required_share_modes;

      fsp$open_file (input_file_name, amc$record, ^access_sel, NIL, NIL, NIL, NIL, input_fid, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$convert_string_to_file (pvt [p$errors].value^.file_value^, file, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      error_file_name := file.local_file_name;

      cmp$open_scratch_err_file (status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      REPEAT
        line := '   ';
        command_line := ' ';
        amp$get_next (input_fid, ^line, #SIZE (line), transfer_count, byte_address, file_position, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        line_continues := FALSE;
        echoed_string.value := line;
        echoed_string.size := transfer_count;
        pos := continuation_line_pos (line, transfer_count);
        IF pos <> 0 THEN
          line_continues := TRUE;
          command_line (1, pos) := line (1, pos);
          size := pos;
          number_of_lines := 0;
          REPEAT
            line := '  ';
            amp$get_next (input_fid, ^line, #SIZE (line), transfer_count, byte_address, file_position,
                  status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            number_of_lines := number_of_lines + 1;
            continuation_string [number_of_lines].value := line;
            continuation_string [number_of_lines].size := transfer_count;
            pos := continuation_line_pos (line, transfer_count);
            IF pos <> 0 THEN
              command_line (size + 1, * ) := line (1, pos);
              size := size + pos + 1;
              done := FALSE;
            ELSE
              command_line (size + 1, * ) := line;
              done := TRUE;
              size := size + transfer_count + 1;
            IFEND;

          UNTIL (file_position = amc$eoi) OR (number_of_lines = 10) OR done OR (size > 256);

        ELSE
          command_line := line;
        IFEND;
        clp$scan_command_line (command_line, local_status);
        IF NOT local_status.normal THEN
          cmp$echo_command (echoed_string, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
          IF line_continues THEN
            FOR i := 1 TO number_of_lines DO
              cmp$echo_command (continuation_string [i], status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
            FOREND;
          IFEND;
          osp$unpack_status_identifier (local_status.condition, local_status_identifier);
          IF (local_status_identifier = cmc$configuration_management_id) AND
                (local_status.condition = cme$lcu_duplicate_system_id) THEN
            cmp$echo_errors (FALSE, local_status);
          ELSE
            cmp$echo_errors (TRUE, local_status);
          IFEND;

        IFEND;
      UNTIL file_position = amc$eoi;

      IF cmv$error_count = 0 THEN
        cmp$validate_network_config (cmv$network_descriptor_p, local_status);
        IF NOT local_status.normal THEN
          cmp$echo_errors (FALSE, local_status);
        IFEND;
      IFEND;

      IF cmv$error_count > 0 THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_vernc_error, command_name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, cmv$error_count, 10, FALSE, status);
        IF error_file_name <> clc$null_file THEN
          cmp$generate_error_listing (error_file_name, local_status);
          IF NOT local_status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;
      ELSE
        clp$convert_string_to_file (network_config_high_cycle, network_config_file_$high, ignore_status);
        clp$convert_string_to_file (network_config_high_cycle (1, (STRLENGTH (network_config_high_cycle) -
              6)), network_configuration_file, ignore_status);
        IF (input_file_name <> network_config_file_$high.local_file_name) AND
              (input_file_name <> network_configuration_file.local_file_name) THEN

{ Input file was NOT the highest cycle of $SYSTEM.NETWORK.CONFIGURATION, so a new cycle
{ will be created.

          pfp$define_catalog (system_network_catalog, status);
          IF NOT status.normal AND (status.condition <> pfe$name_already_subcatalog) THEN
            EXIT /main_program/;
          IFEND;

          pmp$get_unique_name (name, ignore_status);
          pfp$define (name, config_file_path, highest_cycle, password, maximum_retention, pfc$no_log, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

          fsp$open_file (name, amc$record, ^access_selections, NIL, NIL, NIL, NIL, new_file_fid, status);
          IF NOT status.normal THEN
            pfp$purge (config_file_path, highest_cycle, password, local_status);
            EXIT /main_program/;
          IFEND;

          amp$copy_file (input_file_name, name, status);
          fsp$close_file (new_file_fid, ignore_status);
          amp$return (name, ignore_status);
          IF NOT status.normal THEN
            pfp$purge (config_file_path, highest_cycle, password, local_status);
            EXIT /main_program/;
          IFEND;

          nap$get_file_cycle_count (config_file_path, config_cycles, local_status);
          IF NOT local_status.normal THEN
            EXIT /main_program/;
          IFEND;

          WHILE config_cycles > retain_cycle_count DO
            pfp$purge (config_file_path, lowest_cycle, password, local_status);
            IF NOT local_status.normal THEN
              EXIT /main_program/;
            IFEND;
            config_cycles := config_cycles - 1;
          WHILEND;
        IFEND;
      IFEND;

    END /main_program/;
    fsp$close_file (input_fid, ignore_status);
    cmp$clean_up_error_count;
    cmp$clean_up_network_list (ignore_status);

  PROCEND install_network_configuration;

?? OLDTITLE ??
?? NEWTITLE := '  QUIT', EJECT ??

  PROCEDURE quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (cmm$lcu_qui) quit, qui

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [88, 11, 2, 12, 34, 56, 789], clc$command, 0, 0, 0, 0, 0, 0, 0, 'CMM$LCU_QUI']];

?? POP ??

    VAR
      local_status: ost$status,
      system_supplied_name: jmt$system_supplied_name,
      user_supplied_name: jmt$user_supplied_name;

    status.normal := TRUE;
    local_status.normal := TRUE;
  /main_program/
    BEGIN
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF avp$configuration_administrator () OR avp$system_operator () THEN
        pmp$get_job_names (user_supplied_name, system_supplied_name, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        IF NOT cmp$lock_set_by_current_task (cmc$configuration_administrator) THEN
          cmp$manage_lock_r3 (cmc$configuration_administrator, FALSE,
              system_supplied_name, local_status);
        IFEND;

        IF local_status.normal THEN

{ Activate all volumes redundantly.

          cmp$get_volumes_active (local_status);

{ If a class does not have member,
{ then return abnormal status and do not allow the utility to exit.
{ This is done to ensure that operator has to correct the problem and
{ is able to stay in the utility to do so (via CHAMSC command).

          cmp$validate_ms_class (status);
          IF status.normal THEN
            cmp$manage_lock_r3 (cmc$configuration_administrator, TRUE,
                  system_supplied_name, local_status);
          ELSE
            EXIT /main_program/;
          IFEND;
        IFEND;
      IFEND;
      IF cmp$lock_set_by_current_task (cmc$removable_media_operation)  THEN
        cmp$manage_lock_r3 (cmc$removable_media_operation, TRUE,
                system_supplied_name, local_status);
      IFEND;
      IF (avp$configuration_administrator () OR avp$system_operator () OR
             avp$removable_media_operator ()) THEN
        cmp$process_outstanding_sc_req (local_status);
      IFEND;

      clp$end_scan_command_file (cmv$utility_name, local_status);
      cmp$free_command_list;
    END /main_program/;

  PROCEND quit;

?? OLDTITLE ??
?? NEWTITLE := '  REMOVE_MS_FLAW', EJECT ??

  PROCEDURE remove_ms_flaw
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (cmm$lcu_remmsf) remove_ms_flaw, remmf, remmsf (
{    recorded_vsn, rvsn, rv: name 1..6 = $required
{    cylinder, c: integer 0..281474976710655 = $required
{    track, t: integer 0..281474976710655 = $optional
{    sector, s: integer 0..281474976710655 = $optional
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 29, 14, 0, 41, 256],
    clc$command, 10, 5, 2, 0, 0, 0, 5, 'CMM$LCU_REMMSF'], [
    ['C                              ',clc$abbreviation_entry, 2],
    ['CYLINDER                       ',clc$nominal_entry, 2],
    ['RECORDED_VSN                   ',clc$nominal_entry, 1],
    ['RV                             ',clc$abbreviation_entry, 1],
    ['RVSN                           ',clc$alias_entry, 1],
    ['S                              ',clc$abbreviation_entry, 4],
    ['SECTOR                         ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['T                              ',clc$abbreviation_entry, 3],
    ['TRACK                          ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, 6]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, 281474976710655, 10]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, 281474976710655, 10]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [0, 281474976710655, 10]],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$recorded_vsn = 1,
      p$cylinder = 2,
      p$track = 3,
      p$sector = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    CONST
      command_name = 'REMOVE_MS_FLAW';

    VAR
      physical_flaw_address_p: ^dmt$physical_flaw_address,
      recorded_vsn: rmt$recorded_vsn,
      system_supplied_name: jmt$system_supplied_name,
      user_supplied_name: jmt$user_supplied_name;

    status.normal := TRUE;

    IF (NOT avp$configuration_administrator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      RETURN;
    IFEND;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT cmp$lock_set_by_current_task (cmc$configuration_administrator) THEN
      pmp$get_job_names (user_supplied_name, system_supplied_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      cmp$manage_lock_r3 (cmc$configuration_administrator, FALSE,
           system_supplied_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    PUSH physical_flaw_address_p;

    recorded_vsn := pvt [p$recorded_vsn].value^.name_value;
    physical_flaw_address_p^.cylinder := pvt [p$cylinder].value^.integer_value.value;
    IF pvt [p$track].specified THEN
      physical_flaw_address_p^.track := pvt [p$track].value^.integer_value.value;
    IFEND;
    IF pvt [p$sector].specified THEN
      physical_flaw_address_p^.sector := pvt [p$sector].value^.integer_value.value;
    IFEND;

    dmp$define_remove_ms_flaw (recorded_vsn, physical_flaw_address_p, pvt [p$track].specified,
          pvt [p$sector].specified, dmc$oc_flaw_remove, dmc$ic_operator_initiated, status);
    IF NOT status.normal THEN
      CASE status.condition OF
      = dme$avt_entry_not_found, dme$recorded_vsn_not_in_lun =
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_recorded_vsn_not_found,
              command_name, status);

      = dme$cylinder_limit_exceeded =
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_cylinder_limit_exceeded,
              command_name, status);

      = dme$track_limit_exceeded =
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_track_limit_exceeded, command_name,
              status);

      = dme$sector_limit_exceeded =
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_sector_limit_exceeded, command_name,
              status);

      = dme$logging_unavailable =
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_logging_not_active, command_name,
              status);

      = dme$address_not_sw_flawed =
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_address_not_sw_flawed, command_name,
              status);

      = dme$unaddressable_sector =
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_unaddressable_sector, command_name,
              status);
      ELSE
        ;
      CASEND;
    IFEND;
  PROCEND remove_ms_flaw;

?? OLDTITLE ??
?? NEWTITLE := '  VERIFY_NETWORK_CONFIGURATION', EJECT ??

  PROCEDURE verify_network_configuration
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (cmm$lcu_vernc) verify_network_configuration, vernc (
{   input, i: file = $required
{   errors, error, e: file = $ERRORS
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 6] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 11, 2, 12, 34, 56, 789], clc$command, 6, 3, 1, 0, 0, 0, 3, 'CMM$LCU_VERNC'],
            [['E                              ', clc$abbreviation_entry, 2],
            ['ERROR                          ', clc$alias_entry, 2],
            ['ERRORS                         ', clc$nominal_entry, 2],
            ['I                              ', clc$abbreviation_entry, 1],
            ['INPUT                          ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 3]], [

{ INPUT, I

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ ERRORS, ERROR, E

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ STATUS

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ INPUT, I

      [[1, 0, clc$file_type]],

{ ERRORS, ERROR, E

      [[1, 0, clc$file_type], '$ERRORS'],

{ STATUS

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$input = 1,
      p$errors = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    CONST
      command_name = 'VERIFY_NETWORK_CONFIGURATION';

    VAR
      access_sel: array [1 .. 1] of fst$attachment_option,
      byte_address: amt$file_byte_address,
      command_line: string (256),
      contains_data: boolean,
      continuation_string: array [1 .. 50] of ost$string,
      count: clt$list_size,
      done: boolean,
      echoed_string: ost$string,
      error_file_attr: array [1 .. 2] of amt$access_selection,
      error_file_id: amt$file_identifier,
      error_file_name: amt$local_file_name,
      error_string: ost$string,
      existing_file: boolean,
      file: clt$file,
      file_position: amt$file_position,
      get_attr: array [1 .. 1] of amt$get_item,
      i: 0 .. 50,
      ignore_status: ost$status,
      input_fid: amt$file_identifier,
      input_file_name: amt$local_file_name,
      line: string (256),
      line_continues: boolean,
      local_file: boolean,
      local_status: ost$status,
      local_status_identifier: ost$status_identifier,
      number_of_lines: 0 .. 50,
      pos: integer,
      size: integer,
      transfer_count: amt$transfer_count;

    status.normal := TRUE;

  /main_program/
    BEGIN
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$convert_string_to_file (pvt [p$input].value^.file_value^, file, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      input_file_name := file.local_file_name;

      clp$convert_string_to_file (pvt [p$errors].value^.file_value^, file, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      error_file_name := file.local_file_name;
      cmp$open_scratch_err_file (status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      get_attr [1].key := amc$ring_attributes;
      amp$get_file_attributes (input_file_name, get_attr, local_file, existing_file, contains_data, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

  /error_check/
    BEGIN
      IF NOT (existing_file AND contains_data) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_empty_input_on_vernc,
              pvt [p$input].value^.file_value^, local_status);
        cmp$echo_errors (FALSE, local_status);
        EXIT /error_check/;
      IFEND;

      access_sel [1].selector := fsc$access_and_share_modes;
      access_sel [1].access_modes.selector := fsc$specific_access_modes;
      access_sel [1].access_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
      access_sel [1].share_modes.selector := fsc$required_share_modes;

      fsp$open_file (input_file_name, amc$record, ^access_sel, NIL, NIL, NIL, NIL, input_fid, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      REPEAT
        line := '   ';
        command_line := ' ';
        amp$get_next (input_fid, ^line, #SIZE (line), transfer_count, byte_address, file_position, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        line_continues := FALSE;
        echoed_string.value := line;
        echoed_string.size := transfer_count;
        pos := continuation_line_pos (line, transfer_count);
        IF pos <> 0 THEN
          line_continues := TRUE;
          command_line (1, pos) := line (1, pos);
          size := pos;
          number_of_lines := 0;
          REPEAT
            line := '  ';
            amp$get_next (input_fid, ^line, #SIZE (line), transfer_count, byte_address, file_position,
                  status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            number_of_lines := number_of_lines + 1;
            continuation_string [number_of_lines].value := line;
            continuation_string [number_of_lines].size := transfer_count;

            pos := continuation_line_pos (line, transfer_count);
            IF pos <> 0 THEN
              command_line (size + 1, * ) := line (1, pos);
              done := FALSE;
              size := size + pos + 1;
            ELSE
              done := TRUE;
              command_line (size + 1, * ) := line;
              size := size + transfer_count + 1;
            IFEND;
          UNTIL (file_position = amc$eoi) OR (number_of_lines = 10) OR done OR (size > 256);

        ELSE
          command_line := line;
        IFEND;
        clp$scan_command_line (command_line, local_status);
        IF NOT local_status.normal THEN
          cmp$echo_command (echoed_string, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
          IF line_continues THEN
            FOR i := 1 TO number_of_lines DO
              cmp$echo_command (continuation_string [i], status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
            FOREND;
          IFEND;
          osp$unpack_status_identifier (local_status.condition, local_status_identifier);
          IF (local_status_identifier = cmc$configuration_management_id) AND
                (local_status.condition = cme$lcu_duplicate_system_id) THEN
            cmp$echo_errors (FALSE, local_status);
          ELSE
            cmp$echo_errors (TRUE, local_status);
          IFEND;

        IFEND;

      UNTIL file_position = amc$eoi;

    END /error_check/;

      IF cmv$error_count = 0 THEN
        cmp$validate_network_config (cmv$network_descriptor_p, local_status);
        IF NOT local_status.normal THEN
          cmp$echo_errors (FALSE, local_status);
        IFEND;
      IFEND;
      IF cmv$error_count > 0 THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_vernc_error, command_name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, cmv$error_count, 10, FALSE, status);
        IF error_file_name <> clc$null_file THEN
          cmp$generate_error_listing (error_file_name, local_status);
          IF NOT local_status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;
      IFEND;

    END /main_program/;

    fsp$close_file (input_fid, ignore_status);
    cmp$clean_up_error_count;
    cmp$clean_up_network_list (ignore_status);

  PROCEND verify_network_configuration;

?? OLDTITLE, OLDTITLE ??
?? NEWTITLE := 'Network Configuration Subcommands' ??
?? NEWTITLE := '  CMP$DEFINE_HOST_NETWORK', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$define_host_network
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (cmm$lcu_defhn) define_host_network, defhn (
{   network, n: integer 1..65535 = $required
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 1] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend := [[1, [88, 11, 2, 12, 34, 56, 789], clc$command, 2, 1, 1, 0, 0, 0, 0, 'CMM$LCU_DEFHN'],
            [['N                              ', clc$abbreviation_entry, 1],
            ['NETWORK                        ', clc$nominal_entry, 1]], [

{ NETWORK, N

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$required_parameter, 0, 0]],

{ NETWORK, N

      [[1, 0, clc$integer_type], [1, 65535, 10]]];

?? POP ??

    CONST
      p$network = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      network_descriptor: ^nat$network_descriptor;

    status.normal := TRUE;

  /main_program/
    BEGIN
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      check_for_dup_host_network_defn (cmv$network_descriptor_p, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      PUSH network_descriptor;
      network_descriptor^.kind := nac$host_subnet;
      network_descriptor^.network := pvt [p$network].value^.integer_value.value;

      cmp$form_network_list (network_descriptor, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    END /main_program/;

  PROCEND cmp$define_host_network;

?? OLDTITLE ??
?? NEWTITLE := '  CMP$DEFINE_NETWORK_CONNECTION', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$define_network_connection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{   PROCEDURE (cmm$lcu_defnc) define_network_connection, defnc (
{     connected_system, cs: name = $required
{     system_identifier, si: integer 4194561..5242879 = $optional
{     )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
    recend := [
    [1,
    [88, 11, 9, 8, 45, 4, 580],
    clc$command, 4, 2, 1, 0, 0, 0, 0, 'CMM$LCU_DEFNC'], [
    ['CONNECTED_SYSTEM               ',clc$nominal_entry, 1],
    ['CS                             ',clc$abbreviation_entry, 1],
    ['SI                             ',clc$abbreviation_entry, 2],
    ['SYSTEM_IDENTIFIER              ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [4194561, 5242879, 10]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$connected_system = 1,
      p$system_identifier = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    CONST
      ica_2_system_id_prefix = 080025(16);

    VAR
      network_descriptor: ^nat$network_descriptor;

    status.normal := TRUE;

  /main_program/
    BEGIN
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      PUSH network_descriptor;
      network_descriptor^.kind := nac$network_device;
      network_descriptor^.access.element := pvt [p$connected_system].value^.name_value;

      check_unique_element (cmv$network_descriptor_p, network_descriptor^.access.element, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF pvt [p$system_identifier].specified THEN
        network_descriptor^.system_identifier := pvt [p$system_identifier].value^.integer_value.value +
              (ica_2_system_id_prefix * 1000000(16));
        check_unique_system_id (cmv$network_descriptor_p, network_descriptor^.system_identifier, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      ELSE
        network_descriptor^.system_identifier := 0;
      IFEND;

      cmp$form_network_list (network_descriptor, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    END /main_program/;

  PROCEND cmp$define_network_connection;

?? OLDTITLE ??
?? NEWTITLE := '  CMP$VALIDATE_NETWORK_CONFIG', EJECT ??

*copyc cmh$validate_network_config

  PROCEDURE [XDCL, #GATE] cmp$validate_network_config
    (    network_descriptor_list: ^nat$network_descriptor;
     VAR status: ost$status);

    VAR
      device_defined: boolean,
      host_subnet_defined: boolean,
      network_descriptor: ^nat$network_descriptor;

    status.normal := TRUE;
    device_defined := FALSE;
    host_subnet_defined := FALSE;
    network_descriptor := network_descriptor_list;

    WHILE (network_descriptor <> NIL) AND ((device_defined = FALSE) OR (host_subnet_defined = FALSE)) DO
      IF network_descriptor^.kind = nac$network_device THEN
        device_defined := TRUE;
      ELSEIF network_descriptor^.kind = nac$host_subnet THEN
        host_subnet_defined := TRUE;
      IFEND;
      network_descriptor := network_descriptor^.next_descriptor;
    WHILEND;

    IF NOT host_subnet_defined THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_no_host_network_defn, '', status);
    ELSEIF NOT device_defined THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_no_netw_device_defn, '', status);
    IFEND;

  PROCEND cmp$validate_network_config;

?? OLDTITLE ??
?? NEWTITLE := '  cmp$define_tcpip_host', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$define_tcpip_host
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (cmm$lcu_defth) define_tcpip_host, defth (
{   host_name, hn: string 1 .. 255 = $required
{   forward_search_range, fsr: integer 1 .. 16 = 4
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 22, 9, 22, 57, 541],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'CMM$LCU_DEFTH'], [
    ['FORWARD_SEARCH_RANGE           ',clc$nominal_entry, 2],
    ['FSR                            ',clc$abbreviation_entry, 2],
    ['HN                             ',clc$abbreviation_entry, 1],
    ['HOST_NAME                      ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [1, 255, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, 16, 10],
    '4'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$host_name = 1,
      p$forward_search_range = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      network_descriptor: ^nat$network_descriptor;

  /main_program/
    BEGIN
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      check_for_dup_tcpip_host_defn (cmv$network_descriptor_p, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      PUSH network_descriptor;
      network_descriptor^.kind := nac$define_tcpip_host;
      PUSH network_descriptor^.tcpip.host_name: [#SIZE(pvt [p$host_name].value^.string_value^)];
      network_descriptor^.tcpip.host_name^ :=
           pvt [p$host_name].value^.string_value^(1,#SIZE(pvt [p$host_name].value^.string_value^));
      network_descriptor^.tcpip.forward_search_range :=
          pvt [p$forward_search_range].value^.integer_value.value;

      validate_tcpip_host_name (network_descriptor^.tcpip.host_name^, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      cmp$form_network_list (network_descriptor, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    END /main_program/;

  PROCEND cmp$define_tcpip_host;

?? OLDTITLE, OLDTITLE ??
?? NEWTITLE := 'Miscellaneous Procedures' ??
?? NEWTITLE := '  check_for_dup_host_network_defn', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to check that the host network id has not
{   been previously specified via a prior DEFINE_HOST_NETWORK command.

  PROCEDURE [INLINE] check_for_dup_host_network_defn
    (    network_descriptor_list: ^nat$network_descriptor;
     VAR status: ost$status);

    VAR
      network_descriptor: ^nat$network_descriptor;

    status.normal := TRUE;
    network_descriptor := network_descriptor_list;
    WHILE (network_descriptor <> NIL) AND (network_descriptor^.kind <> nac$host_subnet) DO
      network_descriptor := network_descriptor^.next_descriptor;
    WHILEND;
    IF network_descriptor <> NIL THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_dup_host_network_defn, '', status);
    IFEND;

  PROCEND check_for_dup_host_network_defn;

?? OLDTITLE ??
?? NEWTITLE := '  check_for_dup_tcpip_host_defn', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to check that the TCP/IP host has not
{   been previously defined via a prior DEFINE_TCPIP_HOST command.

  PROCEDURE [INLINE] check_for_dup_tcpip_host_defn
    (    network_descriptor_list: ^nat$network_descriptor;
     VAR status: ost$status);

    VAR
      network_descriptor: ^nat$network_descriptor;

    status.normal := TRUE;
    network_descriptor := network_descriptor_list;
    WHILE (network_descriptor <> NIL) AND (network_descriptor^.kind <> nac$define_tcpip_host) DO
      network_descriptor := network_descriptor^.next_descriptor;
    WHILEND;
    IF network_descriptor <> NIL THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_dup_tcpip_host_defn, '', status);
    IFEND;

  PROCEND check_for_dup_tcpip_host_defn;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] check_unique_element', EJECT ??

{
{ PURPOSE:
{   The purpose of this request is to check that the element name
{   specified is unique for all defined network devices.
{

  PROCEDURE [INLINE] check_unique_element
    (    network_descriptor_list: ^nat$network_descriptor;
         element_name: cmt$element_name;
     VAR status: ost$status);

    VAR
      network_descriptor: ^nat$network_descriptor;

    status.normal := TRUE;
    network_descriptor := network_descriptor_list;

  /search/
    WHILE network_descriptor <> NIL DO
      IF (network_descriptor^.kind = nac$network_device) AND
            (network_descriptor^.access.element = element_name) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_duplicate_element,
                element_name, status);
        EXIT /search/;
      IFEND;
      network_descriptor := network_descriptor^.next_descriptor;
    WHILEND /search/;

  PROCEND check_unique_element;

?? OLDTITLE ??
?? NEWTITLE := ' [INLINE] check_unique_system_id', EJECT ??

{ PURPOSE:
{  The purpose of this request is to check that the system identifier
{ specified is unique for all defined network devices.

  PROCEDURE [INLINE] check_unique_system_id
    (    network_descriptor_list: ^nat$network_descriptor;
         system_id: nat$system_identifier;
     VAR status: ost$status);

    VAR
      network_descriptor: ^nat$network_descriptor;

    status.normal := TRUE;
    network_descriptor := network_descriptor_list;

  /search/
    WHILE network_descriptor <> NIL DO
      IF (network_descriptor^.kind = nac$network_device) AND
            (network_descriptor^.system_identifier = system_id) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_duplicate_system_id, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, system_id, 16, TRUE, status);
        EXIT /search/;
      IFEND;
      network_descriptor := network_descriptor^.next_descriptor;
    WHILEND /search/;

  PROCEND check_unique_system_id;

?? OLDTITLE ??
?? NEWTITLE := '  continuation_line_pos', EJECT ??

  FUNCTION continuation_line_pos
    (    line: string ( * );
         transfer_count: amt$transfer_count): integer;

    VAR
      i: integer;

    continuation_line_pos := 0;
    i := transfer_count;

  /loop/
    WHILE i > 1 DO
      IF line (i - 1, 2) = '..' THEN
        continuation_line_pos := i - 2;
        EXIT /loop/;
      IFEND;
      i := i - 1;
    WHILEND /loop/;

  FUNCEND continuation_line_pos;

?? OLDTITLE ??
?? NEWTITLE := '  display_flaw_list', EJECT ??

{ PURPOSE:
{   This procedure will format the data from the correct array and put it into
{   the output file.

  PROCEDURE display_flaw_list
    (    vsn: rmt$recorded_vsn;
         flaw_dau_information_p: ^array [1 .. * ] of dmt$flaw_dau_definition;
         flaw_duplication_p: ^array [1 .. * ] of dmt$flaw_duplication;
         display_option: clt$keyword;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      i: integer,
      stl: integer,
      str: string (80),
      str_el_1: string (3),
      str_el_2: string (32),
      str_el_3: string (3),
      str_el_4: string (3),
      str_el_5: string (10),
      str_el_6: string (18);

{ If the DISPLAY_OPTION of EFFECT was selected.

    IF display_option = 'EFFECT' THEN
      clp$new_display_line (display_control, 2, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      str (1, * ) := ' ';
      str_el_2 := '          MEDIA FLAWS FOR VSN - ';
      STRINGREP (str, stl, str_el_2, vsn);

      clp$put_display (display_control, str, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      str (1, * ) := '    CYL  TRK SEC  THROUGH  CYL  TRK SEC  TYPE      FIRST DAU  LAST DAU';
      clp$put_display (display_control, str, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      str (1, * ) := ' ';

      IF flaw_dau_information_p^ [1].entry_initialized = FALSE THEN
        str (1, * ) := '      NO FLAWS WERE FOUND.            ';
        clp$put_display (display_control, str, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    /display_flaw/
      FOR i := LOWERBOUND (flaw_dau_information_p^) TO UPPERBOUND (flaw_dau_information_p^) DO

        IF flaw_dau_information_p^ [i].entry_initialized = FALSE THEN
          EXIT /display_flaw/;
        IFEND;

        IF flaw_dau_information_p^ [i].reserved THEN
          str_el_5 := '  RESERVED';
        ELSE
          str_el_5 := '          ';
        IFEND;

        STRINGREP (str, stl, ' ', flaw_dau_information_p^ [i].first.cylinder: 6,
              flaw_dau_information_p^ [i].first.track: 5, flaw_dau_information_p^ [i].first.sector: 4,
              flaw_dau_information_p^ [i].last.cylinder: 14, flaw_dau_information_p^ [i].last.track: 5,
              flaw_dau_information_p^ [i].last.sector: 4, str_el_5, flaw_dau_information_p^ [i].first_dau: 10,
              flaw_dau_information_p^ [i].last_dau: 10);

        clp$put_display (display_control, str, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND /display_flaw/;

{ If the DISPLAY_OPTION of SOURCE was selected.

    ELSE
      str_el_6 := 'DEFINE_MS_FLAW RV=';
      str_el_1 := ' C=';
      str_el_3 := ' T=';
      str_el_4 := ' S=';

    /display_flaw_command/
      FOR i := LOWERBOUND (flaw_duplication_p^) TO UPPERBOUND (flaw_duplication_p^) DO
        IF flaw_duplication_p^ [i].entry_initialized = FALSE THEN
          EXIT /display_flaw_command/;
        IFEND;

        str (1, * ) := ' ';

        IF flaw_duplication_p^ [i].sector_specified = TRUE THEN
          STRINGREP (str, stl, str_el_6, vsn, str_el_1, flaw_duplication_p^ [i].cylinder, str_el_3,
                flaw_duplication_p^ [i].track, str_el_4, flaw_duplication_p^ [i].sector);
        ELSEIF flaw_duplication_p^ [i].track_specified = TRUE THEN
          STRINGREP (str, stl, str_el_6, vsn, str_el_1, flaw_duplication_p^ [i].cylinder, str_el_3,
                flaw_duplication_p^ [i].track);
        ELSE
          STRINGREP (str, stl, str_el_6, vsn, str_el_1, flaw_duplication_p^ [i].cylinder);
        IFEND;

        clp$put_display (display_control, str, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      FOREND /display_flaw_command/;
    IFEND;
  PROCEND display_flaw_list;

?? OLDTITLE ??
?? NEWTITLE := '  validate_command_usage', EJECT ??

{ PURPOSE:
{   This procedure checks user capability. If user has Configuration Administration,
{   Removable Media Operation, System displays, System Operation then normal status
{   is returned , Else Status will be set to abnormal.

  PROCEDURE validate_command_usage
   (VAR status: ost$status);

   VAR
     valid: boolean;

   status.normal := TRUE;
   IF avp$configuration_administrator () THEN
     RETURN;
   IFEND;
   IF avp$system_operator () THEN
     RETURN;
   IFEND;
   IF avp$removable_media_operator () THEN
     RETURN;
   IFEND;
   IF avp$system_displays () THEN
     RETURN;
   IFEND;
   osp$set_status_abnormal ('OF', ofe$sou_not_active,
      'configuration_administration, removable_media_operation ' CAT
      'system_displays or system_operation', status);

  PROCEND validate_command_usage;

?? OLDTITLE ??
?? NEWTITLE := '  validate_string', EJECT ??

  PROCEDURE validate_string
    (VAR str: clt$string_value;
     VAR status: ost$status);

    VAR
      i: integer,
      legal_characters: [STATIC, READ, oss$job_paged_literal] set of char := ['A', 'B', 'C', 'D', 'E', 'F',
            'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y',
            'Z', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r',
            's', 't', 'u', 'v', 'w', 'x', 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', ' ',
            '!', '"', '%', '&', '''', '(', ')', '*', '+', '-', '.', '/', ':', ';', '<', '=', '>', '?', '_',
            '$', '#', '@'];

    FOR i := 1 TO STRLENGTH (str) DO
      IF NOT (str (i) IN legal_characters) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cle$name_not_a_keyword_value, str, status);
        RETURN;
      IFEND;
    FOREND;

{ Convert all characters to upper case.

    #TRANSLATE (osv$lower_to_upper, str, str);

  PROCEND validate_string;

?? OLDTITLE ??
?? NEWTITLE := 'validate_tcpip_host_name', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to parse a TCP/IP host name.
{   The domain name is a string of 255 bytes or less.  The domain name
{   is subdivided into domain labels.  The domain labels are
{   separated by periods.  Domain labels can be up to 63 bytes in
{   length.  Domain labels must begin with a letter (A..Z or a..z)
{   and may be followed with 0 to 62 more letters, digits,
{   hyphens(-), or underscores (_) with the exception of the last
{   character which must be a letter or a digit.  For example,
{   arh.cdc.q---___5 is a valid host name.

  PROCEDURE validate_tcpip_host_name
    (    host_name: string ( * );
     VAR status: ost$status);

    CONST
      nlc$tcpip_max_domain_label = 63,
      nlc$tcpip_domain_seperator = '.';

    TYPE
      nlt$tcpip_valid_characters = set of '-' .. 'z';

    VAR
      alphanumeric: [STATIC, READ] nlt$tcpip_valid_characters := ['0', '1', '2', '3', '4', '5', '6', '7', '8',
            '9', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R',
            'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k',
            'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z'],
      domain_index: 1 .. nac$sk_max_host_name_size,
      host_name_length: integer,
      string_index: 0 .. nac$sk_max_host_name_size,
      valid_letters: [STATIC, READ] nlt$tcpip_valid_characters := ['A', 'B', 'C', 'D', 'E', 'F', 'G', 'H',
            'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 'a',
            'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
            'u', 'v', 'w', 'x', 'y', 'z'],
      valid_special_characters: [STATIC, READ] nlt$tcpip_valid_characters := ['-', '_'];

    status.normal := TRUE;
    host_name_length := #SIZE (host_name);
    IF host_name_length <= nac$sk_max_host_name_size THEN
      string_index := 0;

    /parse_host_name/
      WHILE string_index < host_name_length DO
        string_index := string_index + 1;

{ The first character of the domain labels may only be alphabetic.

        IF (host_name (string_index, 1) IN valid_letters) AND (string_index < host_name_length) THEN
          domain_index := 1;

        /parse_domain_label/
          WHILE domain_index <= nlc$tcpip_max_domain_label DO
            string_index := string_index + 1;
            domain_index := domain_index + 1;
            IF domain_index <= nlc$tcpip_max_domain_label THEN
              IF (host_name (string_index, 1) IN alphanumeric) OR
                    (host_name (string_index, 1) IN valid_special_characters) THEN
                IF string_index = host_name_length THEN
                  IF NOT (host_name (string_index, 1) IN alphanumeric) THEN
                    osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_last_host_name_char,
                          host_name (string_index, 1), status);
                  IFEND;
                  EXIT /parse_host_name/;
                IFEND;
              ELSEIF host_name (string_index, 1) = nlc$tcpip_domain_seperator THEN
                IF string_index = host_name_length THEN
                  osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_last_host_name_char,
                        host_name (string_index, 1), status);
                  EXIT /parse_host_name/;
                ELSEIF NOT (host_name (string_index - 1, 1) IN alphanumeric) THEN
                  osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_last_char_domain_label,
                        host_name (string_index - 1, 1), status);
                  EXIT /parse_host_name/;
                IFEND;
                EXIT /parse_domain_label/;
              ELSE { Invalid character.
                osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_invalid_domain_label_ch,
                      host_name (string_index, 1), status);
                EXIT /parse_host_name/;
              IFEND;
            ELSEIF (string_index <= host_name_length) AND (host_name (string_index,
                  1) <> nlc$tcpip_domain_seperator) THEN
              osp$set_status_condition (cme$lcu_domain_label_too_long, status);
              EXIT /parse_host_name/;
            IFEND;
          WHILEND /parse_domain_label/;
        ELSEIF (host_name (string_index, 1) IN valid_letters) AND (string_index = host_name_length) THEN
          EXIT /parse_host_name/;
        ELSE { IF NOT valid_character(host_name (string_index,1)) THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_first_domain_label_char,
                host_name (string_index, 1), status);
          EXIT /parse_host_name/;
        IFEND;
      WHILEND /parse_host_name/;
    ELSE { IF host_name_length > nac$sk_max_host_name_size THEN
      osp$set_status_condition (cme$lcu_tcpip_host_name_length, status);
    IFEND;
  PROCEND validate_tcpip_host_name;

?? OLDTITLE ??
?? NEWTITLE := ' DISPLAY_ELEMENT_STATUS', EJECT ??

  PROCEDURE display_element_status
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{    PROCEDURE (cmm$lcu_dises) display_element_status, dises (
{      elements, element, e: any of
{          key
{            all
{          keyend
{          list of key
{            $channel, $channel_adapter, $communications_element, $controller
{              $external_processor, $storage_device
{          keyend
{          list of name
{        anyend = ALL
{      display_options, display_option, do: any of
{          key
{            all
{          keyend
{          list of key
{            (element_identification, ei)
{            (iou_program_name, ioupn, ipn)
{            (serial_number, sn)
{            (state, s)
{          keyend
{        anyend = all
{      iou, i: name = IOU0
{      output, o: file = $OUTPUT
{      status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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 .. 6] of clt$keyword_specification,
          recend,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier_v2,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: 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 .. 9] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [94, 8, 12, 0, 46, 55, 314],
    clc$command, 11, 5, 0, 0, 0, 0, 5, 'CMM$LCU_DISES'], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['E                              ',clc$abbreviation_entry, 1],
    ['ELEMENT                        ',clc$alias_entry, 1],
    ['ELEMENTS                       ',clc$nominal_entry, 1],
    ['I                              ',clc$abbreviation_entry, 3],
    ['IOU                            ',clc$nominal_entry, 3],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OUTPUT                         ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 334, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 420, clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    245, [[1, 0, clc$list_type], [229, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [6], [
        ['$CHANNEL                       ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['$CHANNEL_ADAPTER               ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['$COMMUNICATIONS_ELEMENT        ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['$CONTROLLER                    ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['$EXTERNAL_PROCESSOR            ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['$STORAGE_DEVICE                ', clc$nominal_entry,
  clc$normal_usage_entry, 6]]
        ]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'ALL'],
{ PARAMETER 2
    [[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]]
      ],
    356, [[1, 0, clc$list_type], [340, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [9], [
        ['EI                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['ELEMENT_IDENTIFICATION         ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['IOUPN                          ', clc$alias_entry,
  clc$normal_usage_entry, 2],
        ['IOU_PROGRAM_NAME               ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['IPN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['SERIAL_NUMBER                  ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['SN                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['STATE                          ', clc$nominal_entry,
  clc$normal_usage_entry, 4]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'IOU0'],
{ PARAMETER 4
    [[1, 0, clc$file_type],
    '$OUTPUT'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$elements = 1,
      p$display_options = 2,
      p$iou = 3,
      p$output = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

*copy clv$display_variables
*copy cmc$minimum_page_size

    CONST
      command_name = 'DISPLAY_ELEMENT_STATUS';

    VAR
      display_control: clt$display_control,
      display_option: cmt$display_option,
      element_count: integer,
      element_index: integer,
      element_name: cmt$element_name,
      file: clt$file,
      found_element: boolean,
      header: string (26),
      iou_name: cmt$element_name,
      keyword: clt$keyword,
      lcu_element: ^array [1 .. *] of cmt$element_definition,
      local_status: ost$status,
      output_open: boolean,
      scan_p: ^clt$data_value,
      text: string (64);

?? NEWTITLE := '    abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF output_open THEN
        clp$close_display (display_control, status);
        output_open := FALSE;
      IFEND;

    PROCEND abort_handler;

*copy clp$new_page_procedure

?? OLDTITLE ??
?? NEWTITLE := '    print_subtitle', EJECT ??

    PROCEDURE print_subtitle
      (    header: string (26);
       VAR status: ost$status);

      clp$put_partial_display (display_control, header, clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND print_subtitle;

?? OLDTITLE ??
?? NEWTITLE := '    put_subtitle', EJECT ??

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

      print_subtitle (header, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND put_subtitle;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    text := '   ';
    header := 'PERIPHERAL STATUS DISPLAY';
    found_element := FALSE;
    output_open := FALSE;
    #SPOIL(output_open);
    osp$establish_block_exit_hndlr (^abort_handler);

  /main_program/
    BEGIN
      validate_command_usage (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_string_to_file (pvt [p$output].value^.file_value^, file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$open_display (file, ^clp$new_page_procedure, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      output_open := TRUE;
      #SPOIL(output_open);

      IF display_control.page_width < cmc$minimum_page_size THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_illegal_output_file,
              pvt [p$output].value^.file_value^, status);
        osp$append_status_integer (osc$status_parameter_delimiter, cmc$minimum_page_size, 10, FALSE, status);
        EXIT /main_program/;
      IFEND;

      cmp$get_number_of_element (element_count, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF element_count = 0 THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_eoi_not_returned,
              'Zero element count returned by CMP$GET_NUMBER_OF_ELEMENT', status);
        EXIT /main_program/;
      IFEND;

      PUSH lcu_element: [1 .. element_count];

      cmp$copy_active_configuration (lcu_element, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      iou_name := pvt [p$iou].value^.name_value;

      clv$titles_built := FALSE;
      clv$command_name := command_name;

      clp$put_partial_display (display_control,
            '=============================================================================== ',
             clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      clp$put_partial_display (display_control,
            'Element             Product    Iou/Channels            State Serial Iou Program ',
             clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      clp$put_partial_display (display_control,
            'Name (19 char)      Id                                       Number Name ',
             clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      clp$put_partial_display (display_control,
            '=============================================================================== ',
             clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      display_option := $cmt$display_option [];
      IF pvt [p$display_options].value^.kind = clc$keyword THEN
        IF pvt [p$display_options].value^.keyword_value = 'ALL' THEN
          display_option := display_option + $cmt$display_option [cmc$all_kw];
        IFEND;
      ELSE
        scan_p := pvt [p$display_options].value;
        WHILE scan_p <> NIL DO
          keyword := scan_p^.element_value^.keyword_value;
          IF keyword = 'ELEMENT_IDENTIFICATION' THEN
            display_option := display_option + $cmt$display_option [cmc$element_id_kw];
          ELSEIF keyword = 'IOU_PROGRAM_NAME' THEN
            display_option := display_option + $cmt$display_option [cmc$ioupn_kw];
          ELSEIF keyword = 'SERIAL_NUMBER' THEN
            display_option := display_option + $cmt$display_option [cmc$serial_number_kw];
          ELSEIF keyword = 'STATE' THEN
            display_option := display_option + $cmt$display_option [cmc$state_kw];
          IFEND;
          scan_p := scan_p^.link;
        WHILEND;
      IFEND;

      IF pvt [p$elements].value^.kind = clc$keyword THEN
        IF pvt [p$elements].value^.keyword_value = 'ALL' THEN
          FOR element_index := 1 TO element_count DO
            display_element (display_option, element_index, iou_name,
                               lcu_element, display_control, status);
          FOREND;
        IFEND;
      ELSE
        scan_p := pvt [p$elements].value;
        WHILE scan_p <> NIL DO
          found_element := FALSE;
          CASE scan_p^.element_value^.kind OF
          = clc$name =
            element_name := scan_p^.element_value^.name_value;

            /loop/
            FOR element_index := 1 TO element_count DO
              IF lcu_element^[element_index].element_name = element_name THEN
                IF (lcu_element^ [element_index].element_type = cmc$data_channel_element) THEN
                  IF NOT (lcu_element^ [element_index].data_channel.iou = iou_name) THEN
                    CYCLE /loop/;
                  IFEND;
                IFEND;
                display_element (display_option, element_index, iou_name,
                      lcu_element, display_control, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
                found_element := TRUE;
              IFEND;
            FOREND /loop/;

            IF NOT found_element THEN
              IF cmp$valid_channel_name (element_name) THEN
                text (1, 5) := iou_name (1, 5);
                text (6, *) := element_name;
              ELSE
                text (1, *) := element_name;
              IFEND;
              osp$set_status_abnormal (cmc$configuration_management_id,
                   cme$lcm_element_not_found, text, status);
              EXIT /main_program/;
            IFEND;

          = clc$keyword =
            keyword := scan_p^.element_value^.keyword_value;

            IF keyword = '$CHANNEL' THEN
              FOR element_index := 1 TO element_count DO
                IF lcu_element^[element_index].element_type = cmc$data_channel_element THEN
                  display_element (display_option, element_index, iou_name,
                                     lcu_element, display_control, status);
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;
                  found_element := TRUE;
                IFEND;
              FOREND;

            ELSEIF keyword = '$CHANNEL_ADAPTER' THEN
              FOR element_index := 1 TO element_count DO
                IF lcu_element^[element_index].element_type = cmc$channel_adapter_element THEN
                  display_element (display_option, element_index, iou_name,
                                     lcu_element, display_control, status);
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;
                  found_element := TRUE;
                IFEND;
              FOREND;

            ELSEIF keyword = '$COMMUNICATIONS_ELEMENT' THEN
              FOR element_index := 1 TO element_count DO
                IF lcu_element^[element_index].element_type = cmc$communications_element THEN
                  display_element (display_option, element_index, iou_name,
                                     lcu_element, display_control, status);
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;
                  found_element := TRUE;
                IFEND;
              FOREND;

            ELSEIF keyword = '$CONTROLLER' THEN
              FOR element_index := 1 TO element_count DO
                IF lcu_element^[element_index].element_type = cmc$controller_element THEN
                  display_element (display_option, element_index, iou_name,
                                     lcu_element, display_control, status);
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;
                  found_element := TRUE;
                IFEND;
              FOREND;

            ELSEIF keyword = '$EXTERNAL_PROCESSOR' THEN
              FOR element_index := 1 TO element_count DO
                IF lcu_element^[element_index].element_type = cmc$external_processor_element THEN
                  display_element (display_option, element_index, iou_name,
                                     lcu_element, display_control, status);
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;
                  found_element := TRUE;
                IFEND;
              FOREND;

            ELSEIF keyword = '$STORAGE_DEVICE' THEN
              FOR element_index := 1 TO element_count DO
                IF lcu_element^[element_index].element_type = cmc$storage_device_element THEN
                  display_element (display_option, element_index, iou_name,
                                     lcu_element, display_control, status);
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;
                  found_element := TRUE;
                IFEND;
              FOREND;
            IFEND;
            IF NOT found_element THEN
              osp$set_status_abnormal (cmc$configuration_management_id,
                           cme$lcm_element_not_found, keyword, status);
              EXIT /main_program/;
            IFEND;
          ELSE
            ;
          CASEND;
        scan_p := scan_p^.link;
      WHILEND;
    IFEND;

    END /main_program/;

    IF output_open THEN
      clp$close_display (display_control, local_status);
      IF status.normal THEN
        status := local_status;
      IFEND;
      output_open := FALSE;
      #SPOIL(output_open);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND display_element_status;

?? TITLE := '    display_element', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to actually display the elements.
{   This is called from the procedure DISPLAY_ELEMENT_STATUS only.

  PROCEDURE display_element
    (    display_option: cmt$display_option;
         element_index: integer;
         iou_name: cmt$element_name;
         lcu_element: ^array [1 .. *] of cmt$element_definition;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      ch_element: cmt$element_definition,
      cm_port: cmt$communications_port_number,
      ct_port: cmt$controller_port_number,
      char1: integer,
      char2: integer,
      count: integer,
      display_line: string (80),
      element: cmt$element_definition,
      element_definition: cmt$element_definition,
      eq: cmt$physical_equipment_number,
      local_status: ost$status,
      port: cmt$data_storage_port_number,
      posc: integer,
      start: integer,
      state: cmt$element_state,
      temp_str: ost$name;

    display_line (1, *) := '  ';
    display_line (1, 19) := lcu_element^[element_index].element_name(1, 19);

    IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
       ($cmt$display_option[cmc$element_id_kw] <= display_option) THEN

      temp_str := osc$null_name;
      char2 := 0;
      FOR char1 := 1 TO 6 DO
        IF lcu_element^[element_index].product_id.product_number (char1, 1) <> ' ' THEN
          char2 := char2 + 1;
          temp_str (char2, 1) := lcu_element^[element_index].product_id.product_number (char1, 1);
        IFEND;
      FOREND;
      char2 := char2 + 1;
      temp_str (char2, 1) := lcu_element^[element_index].product_id.underscore;
      temp_str (char2 + 1, 3) := lcu_element^[element_index].product_id.model_number;

      display_line (21, 10) := temp_str (1, 10);
    IFEND;

    CASE lcu_element^[element_index].element_type OF
    = cmc$data_channel_element =
      display_line (32, 4) := lcu_element^[element_index].data_channel.iou (1, 4);
      display_line (36, 1) := '/';
      display_line (37, 6) := lcu_element^[element_index].element_name (1, 6);

    = cmc$controller_element =
      start := 1;
      posc := 0;
      /loop/
      FOR cm_port := LOWERVALUE(cmt$controller_port_number) TO
               UPPERVALUE(cmt$controller_port_number) DO
        IF start > 2 THEN
          EXIT /loop/;
        IFEND;
        IF lcu_element^[element_index].controller.connection.port[cm_port].configured THEN
          display_line (32+posc, 4) :=
                lcu_element^[element_index].controller.connection.port[cm_port].iou (1,4);
          display_line (36+posc, 1) := '/';
          display_line (37+posc, 6) :=
                lcu_element^[element_index].controller.connection.port[cm_port].element_name (1,6);
          start := start + 1;
          posc := 12;
        IFEND;
      FOREND /loop/;

    = cmc$storage_device_element =
      start := 1;
      posc := 0;
      element_definition := lcu_element^[element_index];
      /loop1/
      FOR port := LOWERVALUE(cmt$data_storage_port_number) TO
            UPPERVALUE(cmt$data_storage_port_number) DO
        IF start > 2 THEN
          EXIT /loop1/;
        IFEND;
        IF element_definition.storage_device.connection.port[port].configured THEN
          /inner_loop1/
          FOR count := 1 TO UPPERBOUND (lcu_element^) DO
            element := lcu_element^[count];
            IF element.element_name =
                    element_definition.storage_device.connection.port[port].element_name THEN
              EXIT /inner_loop1/;
            IFEND;
          FOREND /inner_loop1/;
          IF element.element_type = cmc$controller_element THEN
            /inner_loop2/
            FOR ct_port := LOWERVALUE(cmt$controller_port_number) TO
                           UPPERVALUE(cmt$controller_port_number) DO
              IF element.controller.connection.port[ct_port].configured THEN
                /inner_loop3/
                FOR count := 1 TO UPPERBOUND (lcu_element^) DO
                  ch_element := lcu_element^[count];
                  IF ch_element.element_name =
                       element.controller.connection.port[ct_port].element_name THEN
                    EXIT /inner_loop3/;
                  IFEND;
                FOREND /inner_loop3/;
                IF ch_element.element_type = cmc$data_channel_element THEN
                  display_line (32+posc, 4) := ch_element.data_channel.iou (1, 4);
                  display_line (36+posc, 1) := '/';
                  display_line (37+posc, 6) := ch_element.element_name (1, 6);
                  start := start + 1;
                  posc := 12;
                IFEND;
              IFEND;
            FOREND /inner_loop2/;
          ELSE
            display_line (32+posc, 4) := element.data_channel.iou (1, 4);
            display_line (36+posc, 1) := '/';
            display_line (37+posc, 6) := element.element_name (1, 6);
            start := start + 1;
            posc := 12;
          IFEND;
        IFEND;
      FOREND /loop1/;

    = cmc$channel_adapter_element =
      IF lcu_element^[element_index].channel_adapter.connection.channel.configured THEN
        display_line (32, 4) := lcu_element^[element_index].channel_adapter.connection.channel.iou (1, 4);
        display_line (36, 1) := '/';
        display_line (37, 6) :=
              lcu_element^[element_index].channel_adapter.connection.channel.element_name (1, 6);
      IFEND;

    = cmc$communications_element =
      start := 1;
      posc := 0;
      /loop2/
      FOR cm_port := LOWERVALUE(cmt$communications_port_number) TO
               UPPERVALUE(cmt$communications_port_number) DO
        IF start > 2 THEN
          EXIT /loop2/;
        IFEND;
        IF lcu_element^[element_index].communications_element.connection.port[cm_port].configured THEN
          display_line (32+posc, 4) :=
                lcu_element^[element_index].communications_element.connection.port[cm_port].iou (1,4);
          display_line (36+posc, 1) := '/';
          display_line (37+posc, 6) :=
                lcu_element^[element_index].communications_element.connection.
                                              port[cm_port].element_name (1,6);
          start := start + 1;
          posc := 12;
        IFEND;
      FOREND /loop2/;

    = cmc$external_processor_element =
      start := 1;
      posc := 0;
      /loop3/
      FOR eq := LOWERVALUE(cmt$physical_equipment_number) TO
               UPPERVALUE(cmt$physical_equipment_number) DO
        IF start > 2 THEN
          EXIT /loop3/;
        IFEND;
        IF lcu_element^[element_index].external_processor.connection.io_port[eq].configured THEN
          display_line (32+posc, 4) :=
                lcu_element^[element_index].external_processor.connection.io_port[eq].iou (1,4);
          display_line (36+posc, 1) := '/';
          display_line (37+posc, 6) :=
                lcu_element^[element_index].external_processor.connection.io_port[eq].element_name (1,6);
          start := start + 1;
          posc := 12;
        IFEND;
      FOREND /loop3/;
    CASEND;

    IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
       ($cmt$display_option[cmc$state_kw] <= display_option) THEN
      cmp$get_element_state (lcu_element^[element_index].element_name,
                               {unused} iou_name, state, local_status);
      CASE state OF
      = cmc$on =
        display_line (56, 4) := 'ON  ';
      = cmc$off =
        display_line (56, 4) := 'OFF ';
      = cmc$down =
        display_line (56, 4) := 'DOWN';
      CASEND;
    IFEND;

    IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
       ($cmt$display_option[cmc$serial_number_kw] <= display_option) THEN
      display_line (62, 6) := lcu_element^[element_index].serial_number;
    IFEND;

    IF ($cmt$display_option[cmc$all_kw] <= display_option) OR
       ($cmt$display_option[cmc$ioupn_kw] <= display_option) THEN
      CASE lcu_element^[element_index].element_type OF
      = cmc$channel_adapter_element =
        display_line (69,10) := lcu_element^[element_index].channel_adapter.peripheral_driver_name(1, 10);
      = cmc$communications_element =
        display_line (69,10) :=
            lcu_element^[element_index].communications_element.peripheral_driver_name(1, 10);
      = cmc$controller_element =
        display_line (69,10) := lcu_element^[element_index].controller.peripheral_driver_name(1, 10);
      = cmc$external_processor_element =
        display_line (69,10) :=
            lcu_element^[element_index].external_processor.peripheral_driver_name(1, 10);
      ELSE
        ;
      CASEND;
    IFEND;

    clp$put_partial_display (display_control, display_line, clc$trim, amc$terminate, status);

  PROCEND display_element;

?? OLDTITLE, OLDTITLE ??
MODEND cmm$logical_configuration_util;
*DECK DECK=CMM$MAINTENANCE_SERVICES_R1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE CM : Maintenance Services Ring1' ??
MODULE cmm$maintenance_services_r1;

{ PURPOSE:
{   This module contains Ring 1 procedures that call Deadstart Services interfaces to load, idle, and
{   resume PPs.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmd$null_equipment_number
*copyc cme$logical_configuration_mgr
*copyc cme$physical_configuration_mgr
*copyc cme$reserve_element
*copyc cmt$element_definition
*copyc cmt$pp_commands
*copyc cmt$pp_memory_length
*copyc cmt$pp_registers
*copyc cmt$request_block
*copyc dse$error_codes
*copyc dst$dft_pp_registers
*copyc iot$disk_request
*copyc iot$io_request
*copyc ost$hardware_subranges
?? POP ??
*copyc cmp$assign_pp_r1
*copyc cmp$convert_iou_number
*copyc cmp$get_controller_type
*copyc cmp$get_element_state
*copyc cmp$get_logical_pp_index
*copyc cmp$pc_get_element
*copyc cmp$request_resources
*copyc cmp$retrieve_logical_pp_index
*copyc dsp$get_pp_registers
*copyc dsp$idle_pp
*copyc dsp$load_pp
*copyc dsp$resume_pp
*copyc dsp$retrieve_iou_information
*copyc i#call_monitor
*copyc i#move
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osp$set_status_condition
?? EJECT ??
*copyc cmv$logical_pp_table_p
*copyc cmv$physical_configuration
*copyc osv$170_os_type
*copyc osv$external_interrupt_selector
*copyc osv$mainframe_wired_cb_heap
*copyc osv$mainframe_wired_heap
?? OLDTITLE ??
?? NEWTITLE := 'seek_redundant_controller', EJECT ??

{ PURPOSE:
{    This procedure determines whether or not the given controller element is redundant. A controller is
{    considered primary if it is the first element in the upline connection of any units connected to it,
{    otherwise, it is redundant.
{ NOTE:
{   IGNORE_STATE is a flag set to TRUE if this procedure is called as a result of manual state change. This
{   is needed because state of the element is not yet updated in memory. When using this procedure during
{   deadstart i.e during configuration activation, ignore_state must be set to FALSE.

  PROCEDURE seek_redundant_controller
     (   element: cmt$element_definition;
         ignore_state: boolean;
     VAR redundant: boolean);

    VAR
      channel_state: cmt$element_state,
      controller_type: cmt$controller_type,
      controller_element_p: ^cmt$element_definition,
      controller_state: cmt$element_state,
      found_first_controller: boolean,
      iou_name: cmt$element_name,
      local_status: ost$status,
      port: cmt$data_storage_port_number,
      pun: cmt$physical_unit_number,
      state: cmt$element_state,
      unit_element_p: ^cmt$element_definition,
      upline_port: integer;

    redundant := FALSE;
    found_first_controller := FALSE;
    IF element.element_type <> cmc$controller_element THEN
      RETURN;
    IFEND;

    cmp$get_controller_type (element.product_id, controller_type, local_status);
    IF NOT local_status.normal OR
          ((controller_type <> cmc$mscm3_ct) AND (controller_type <> cmc$mt5680_xx)) THEN
      RETURN;
    IFEND;

   /search_units/
    FOR pun := LOWERVALUE (cmt$physical_unit_number) TO UPPERVALUE (cmt$physical_unit_number) DO
      IF NOT element.controller.connection.unit [pun].configured THEN
        CYCLE /search_units/;
      IFEND;

      cmp$pc_get_element (element.controller.connection.unit [pun].element_name, iou_name, unit_element_p,
            local_status);
      IF NOT local_status.normal THEN
        CYCLE /search_units/;
      IFEND;

      IF NOT ignore_state THEN
        cmp$get_element_state (unit_element_p^.element_name, iou_name, state, local_status);
      ELSE
        state := cmc$on;
      IFEND;
      IF state <> cmc$on THEN
        CYCLE /search_units/;
      IFEND;

     /search_upline_connection/
      FOR port := LOWERVALUE (cmt$data_storage_port_number) TO UPPERVALUE (cmt$data_storage_port_number) DO
        IF NOT unit_element_p^.storage_device.connection.port [port].configured THEN
          CYCLE /search_upline_connection/;
        IFEND;

        { Look at the first ON element in the upline connection of this unit.  If this is a request done
        { during manual state change, the state of the controller will be ignored.

        IF NOT ignore_state THEN
          cmp$get_element_state (unit_element_p^.storage_device.connection.port [port].element_name,
                iou_name, controller_state, local_status);
        ELSE
          controller_state := cmc$on;
        IFEND;
        IF controller_state <> cmc$on THEN
          CYCLE /search_upline_connection/;
        IFEND;

        cmp$pc_get_element (unit_element_p^.storage_device.connection.port [port].element_name, iou_name,
              controller_element_p, local_status);
        IF NOT local_status.normal THEN
          CYCLE /search_upline_connection/;
        IFEND;
        channel_state := cmc$on;
        IF NOT ignore_state THEN

          { Make sure this controller has channel in the ON state.

         /find_first_on_channel/
          FOR upline_port := LOWERVALUE (cmt$controller_port_number) TO
                UPPERVALUE (cmt$controller_port_number) DO
            IF controller_element_p^.controller.connection.port [upline_port].configured THEN
              cmp$get_element_state (
                    controller_element_p^.controller.connection.port [upline_port].element_name,
                    controller_element_p^.controller.connection.port [upline_port].iou, channel_state,
                    local_status);
              IF NOT local_status.normal THEN
                CYCLE /find_first_on_channel/;
              IFEND;
              IF channel_state <> cmc$on THEN
                found_first_controller := TRUE;
                CYCLE /find_first_on_channel/; { go to next channel }
              ELSE
                found_first_controller := FALSE;
                EXIT /find_first_on_channel/;
              IFEND;
            IFEND;
          FOREND /find_first_on_channel/;
        IFEND;

        IF channel_state <> cmc$on THEN

          { Cannot find a useable channel from this controller.

          CYCLE /search_upline_connection/;
        IFEND;

        { If first ON controller connected to this unit matches the controller name passed in, then it is
        { not a redundant controller.

        redundant := ((controller_element_p^.element_name <> element.element_name) OR
              found_first_controller);
        EXIT /search_upline_connection/;
      FOREND /search_upline_connection/;

      { If the controller is not redundant at this point, return, else keep searching until all units are
      { scanned, for it could be the first element on the upline connection of other units.

      IF NOT redundant THEN
        RETURN;
      IFEND;
    FOREND /search_units/;

  PROCEND seek_redundant_controller;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$acquire_resources', EJECT ??

{ PURPOSE:
{   This procedure obtains resources for operations initiated by CM external interface calls.  This is the
{   routine that obtains resources for MALET, NAM/VE, RHF, etc.
{ DESIGN:
{   If the request type is a PP request, then the output parameter physical_pp contains the information on
{   which PP was obtained.  The caller must save this information in order to later release the PP.

  PROCEDURE [XDCL, #GATE] cmp$acquire_resources
    (    request_type: dst$resource_request_types;
         channel: cmt$physical_channel;
         iou_number: dst$iou_number;
         equipment_number: 0 .. cmc$null_equipment_number;
         unit_number: 0 .. cmc$null_unit_number;
         driver_pp: boolean;
         specific_pp: boolean;
         get_pp_by_channel: boolean;
     VAR physical_pp: dst$iou_resource;
     VAR status: ost$status);

    VAR
      channel_type: dst$channel_protocol_type,
      ious_in_configuration: dst$iou_information_table,
      number_of_ious: dst$number_of_ious,
      resource_request: dst$resource_request;

    status.normal := TRUE;

    IF channel.concurrent THEN
      channel_type := dsc$cpt_cio;
    ELSE
      channel_type := dsc$cpt_nio;
    IFEND;

    resource_request.channel.iou_number := iou_number;
    resource_request.channel.channel_protocol := channel_type;
    resource_request.channel.number := channel.number;

    CASE request_type OF
    = dsc$rrt_get_channel =
      cmp$request_resources (request_type, resource_request, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    = dsc$rrt_get_equipment =

      { PROGRAMMING NOTE - The only call to this procedure with request_type = dsc$rrt_get_equipment is made
      { from cmm$pcu_ring1_helper when activating the configuration (to get channel but not load pp).  If
      { external interface modules cmm$reserve_elements or msm$request_maintenance_access ever call this
      { procedure with this request_type, code will be needed to not ignore certain abnormal statuses.

      resource_request.equipment_number := ORD (equipment_number);
      resource_request.unit_number := ORD (unit_number);
      cmp$request_resources (request_type, resource_request, status);
      IF NOT status.normal THEN
        IF (status.condition = dse$resource_already_assigned) OR
           (status.condition = dse$ch_assigned_to_ve) THEN
          status.normal := TRUE;
          cmp$request_resources (dsc$rrt_get_channel, resource_request, status);
          IF NOT status.normal THEN
            IF (status.condition <> dse$resource_already_assigned) AND
               (status.condition <> dse$ch_assigned_to_ve) THEN
              RETURN;
            ELSE
              status.normal := TRUE;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

    = dsc$rrt_get_pp =
      resource_request.options := $dst$resource_request_options [];
      IF specific_pp THEN
        IF (osv$170_os_type <> osc$ot7_none) THEN
          osp$set_status_condition (cme$specific_pp_not_reservable,  status);
          RETURN;
        IFEND;
        resource_request.channel.number := 15; { dummy channel value
        resource_request.channel.channel_protocol := physical_pp.channel_protocol;
        resource_request.channel.iou_number := physical_pp.iou_number;
        resource_request.options := $dst$resource_request_options [dsc$rro_specific_pp];
        resource_request.primary_pp := physical_pp;
      ELSEIF get_pp_by_channel THEN
        ;
      ELSE {driver_pp or any_pp
        dsp$retrieve_iou_information (number_of_ious, ious_in_configuration);
        IF driver_pp THEN
          IF (number_of_ious = 1) AND ((ious_in_configuration [1].model_type = dsc$imn_i1_13_model) OR
                (ious_in_configuration [1].model_type = dsc$imn_i1_14_model)) THEN { 810 or 830 machine }
            resource_request.options := $dst$resource_request_options [dsc$rro_driver_pp];
          ELSE { same as any_pp
            resource_request.options := $dst$resource_request_options [dsc$rro_any_pp];
          IFEND;
        ELSE { any_pp
          resource_request.options := $dst$resource_request_options [dsc$rro_any_pp];
        IFEND;
        resource_request.channel.number := 15; { dummy channel value
        resource_request.channel.channel_protocol := dsc$cpt_nio;
        resource_request.channel.iou_number := ious_in_configuration [1].physical_iou_number;
      IFEND;
      cmp$request_resources (request_type, resource_request, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      physical_pp := resource_request.primary_pp;

    ELSE
    CASEND;

  PROCEND cmp$acquire_resources;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$deadstart_pp', EJECT ??

{ PURPOSE:
{   This procedure calls a Deadstart interface to load a PP program from the PP library built from the
{   deadstart tape or from the input PP Program sequence pointer parameter.

  PROCEDURE [XDCL, #GATE] cmp$deadstart_pp
    (    pp_index: iot$pp_number;
         pp_table_rma: ost$real_memory_address;
         search_from_dstape: boolean;
         pp_program_p: ^SEQ ( * );
     VAR status: ost$status);

    status.normal := TRUE;

    IF search_from_dstape THEN
      dsp$load_pp (dsc$load_pp_by_name, cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp, NIL,
            cmv$logical_pp_table_p^ [pp_index].pp_info.cip_driver_name, pp_table_rma, status);
    ELSE
      dsp$load_pp (dsc$load_pp_image, cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp, pp_program_p,
            cmv$logical_pp_table_p^ [pp_index].pp_info.cip_driver_name, pp_table_rma, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmv$logical_pp_table_p^ [pp_index].flags.pp_loaded := TRUE;

  PROCEND cmp$deadstart_pp;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$determine_redundant_channel', EJECT ??

{ PURPOSE:
{   This procedure determines whether or not the channel is a redundant channel.  It scans all upline
{   connections of controllers connected to the channel, if the channel is not the first channel on any
{   of the connection, then redundant is set to TRUE.  A channel is not redundant if it is not the first
{   ON channel on the upline connection of a controller or storage device.

  PROCEDURE [XDCL, #GATE] cmp$determine_redundant_channel
    (    channel: cmt$physical_channel,
         iou_number: dst$iou_number;
         ignore_state: boolean;
     VAR redundant: boolean;
     VAR status: ost$status);

  VAR
    channel_p: ^cmt$element_definition,
    element_p: ^cmt$element_definition,
    first_channel_state: cmt$element_state,
    found_first_channel: boolean,
    index: integer,
    iou_name: cmt$element_name,
    pen: cmt$physical_equipment_number,
    port: cmt$controller_port_number;

    status.normal := TRUE;
    redundant := FALSE;
    cmp$convert_iou_number (iou_number, iou_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Search all of the configuration to determine redundant channel. If a redundant channel is found, do not
    { stop because although the channel is defined as redundant on one controller, the other port could be
    { defined as primary.

   /search_configuration/
    FOR index := LOWERBOUND (cmv$physical_configuration^) TO UPPERBOUND (cmv$physical_configuration^) DO
      IF cmv$physical_configuration^ [index].element_type <> cmc$data_channel_element THEN
        CYCLE /search_configuration/;
      IFEND;

      IF (cmv$physical_configuration^ [index].data_channel.number <> channel.number) OR
            (cmv$physical_configuration^ [index].data_channel.concurrent <> channel.concurrent) OR
            (cmv$physical_configuration^ [index].data_channel.iou <> iou_name) THEN
        CYCLE /search_configuration/;
      IFEND;

     /search_next_controller/
      FOR pen := LOWERVALUE (cmt$physical_equipment_number) TO UPPERVALUE (cmt$physical_equipment_number) DO
        IF NOT cmv$physical_configuration^ [index].data_channel.connection.equipment [pen].configured THEN
          CYCLE /search_next_controller/;
        IFEND;

        cmp$pc_get_element (cmv$physical_configuration^ [index].data_channel.connection.
              equipment [pen].element_name, iou_name, element_p, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        seek_redundant_controller (element_p^, ignore_state, redundant);
        IF redundant THEN
          CYCLE /search_next_controller/;
        IFEND;

        found_first_channel := FALSE;
        port := LOWERVALUE (cmt$controller_port_number);
        WHILE (port <= UPPERVALUE (cmt$controller_port_number)) AND NOT found_first_channel DO
          IF element_p^.controller.connection.port [port].configured AND
               (element_p^.controller.connection.port [port].mainframe_ownership =
               cmv$physical_configuration^ [index].data_channel.mainframe_ownership) THEN
            found_first_channel := TRUE;
            cmp$pc_get_element (element_p^.controller.connection.port [port].element_name,
                  element_p^.controller.connection.port [port].iou, channel_p, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF (channel_p^.data_channel.number = cmv$physical_configuration^[index].data_channel.number) AND
                  (channel_p^.data_channel.concurrent =
                  cmv$physical_configuration^[index].data_channel.concurrent) AND
                  (channel_p^.data_channel.iou = cmv$physical_configuration^ [index].data_channel.iou) THEN
              redundant := FALSE;
              RETURN;
            IFEND;

            cmp$get_element_state (channel_p^.element_name, channel_p^.data_channel.iou, first_channel_state,
                  status);
            IF first_channel_state <> cmc$on THEN
              redundant := FALSE;
              RETURN;
            IFEND;
            redundant := TRUE;
            CYCLE /search_next_controller/;
          IFEND;
          port := port + 1;
        WHILEND;
      FOREND /search_next_controller/;
    FOREND /search_configuration/;

  PROCEND cmp$determine_redundant_channel;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$free_pp_request', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$free_pp_request
    (    pp_index: iot$pp_number);

    IF cmv$logical_pp_table_p^ [pp_index].pp_info.saved_io_request_p <> NIL THEN
      IF cmv$logical_pp_table_p^ [pp_index].pp_info.saved_io_request_p^.device_request_p <> NIL THEN
        FREE cmv$logical_pp_table_p^ [pp_index].pp_info.saved_io_request_p^.device_request_p IN
              osv$mainframe_wired_cb_heap^;
      IFEND;
      FREE cmv$logical_pp_table_p^ [pp_index].pp_info.saved_io_request_p IN osv$mainframe_wired_cb_heap^;
      cmv$logical_pp_table_p^ [pp_index].pp_info.saved_io_request_p := NIL;
    IFEND;

  PROCEND cmp$free_pp_request;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_pp_reg ', EJECT ??

{ PURPOSE:
{   This procedure calls a deadstart interface to retrieve the PP registers.

  PROCEDURE [XDCL, #GATE] cmp$get_pp_reg
    (    pp: dst$iou_resource;
     VAR pp_registers: dst$dft_pp_registers;
     VAR status: ost$status);

    dsp$get_pp_registers (pp, pp_registers, status);

  PROCEND cmp$get_pp_reg;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$hardware_idle_pp', EJECT ??

{ PURPOSE:
{   This procedure calls a deadstart interface to hardware idle a PP.

  PROCEDURE [XDCL, #GATE] cmp$hardware_idle_pp
    (    pp: dst$iou_resource;
         dump_pp: boolean;
         dump_registers_only: boolean;
         pp_memory_p: ^SEQ ( * );
     VAR actual_pp_memory_size: cmt$pp_memory_length;
     VAR pp_registers: cmt$pp_registers;
     VAR status: ost$status);

    VAR
      dump_area_p: ^SEQ ( * ),
      pp_memory_seq_p: ^SEQ ( * ),
      pp_reg_p: ^dst$dft_pp_registers,
      size: integer;

    status.normal := TRUE;
    dump_area_p := NIL;
    IF dump_pp THEN
      IF pp_memory_p = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_nil_pointer_detected,
              'CMP$HARDWARE_IDLE_PP', status);
        RETURN;
      IFEND;
      size := #SIZE (pp_memory_p^) + #SIZE (dst$dft_pp_registers);
    ELSEIF dump_registers_only THEN
      size := #SIZE (dst$dft_pp_registers);
    IFEND;

    IF dump_pp OR dump_registers_only THEN
      ALLOCATE dump_area_p: [[REP size OF cell]] IN osv$mainframe_wired_heap^;
    IFEND;

   /dump_area_allocated/
    BEGIN
      dsp$idle_pp (pp, dump_registers_only, dump_pp, dump_area_p, status);
      IF NOT status.normal THEN
        EXIT /dump_area_allocated/;
      IFEND;
      actual_pp_memory_size := 0;
      pp_registers.a_register := 0;
      pp_registers.k_register := 0;
      pp_registers.p_register := 0;
      pp_registers.q_register := 0;

      IF dump_pp OR dump_registers_only THEN
        RESET dump_area_p;
        NEXT pp_reg_p IN dump_area_p;
        pp_registers.a_register := pp_reg_p^.a_register;
        pp_registers.k_register := pp_reg_p^.k_register;
        pp_registers.p_register := pp_reg_p^.p_register;
        pp_registers.q_register := pp_reg_p^.q_register;
        IF dump_pp THEN
          NEXT pp_memory_seq_p: [[REP #SIZE (pp_memory_p^) OF cell]] IN dump_area_p;
          actual_pp_memory_size := #SIZE (pp_memory_seq_p^);
          i#move (pp_memory_seq_p, pp_memory_p, #SIZE (pp_memory_p^));
        IFEND;
      IFEND;
    END /dump_area_allocated/;

    IF dump_area_p <> NIL THEN
      FREE dump_area_p IN osv$mainframe_wired_heap^;
    IFEND;

  PROCEND cmp$hardware_idle_pp;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$hardware_resume_pp ', EJECT ??

{ PURPOSE:
{   This procedure calls a deadstart interface to hardware resume a PP.

  PROCEDURE [XDCL, #GATE] cmp$hardware_resume_pp
    (    pp: dst$iou_resource;
         start_address: 0 .. 0ffff(16);
     VAR status: ost$status);

    dsp$resume_pp (pp, start_address, status);

  PROCEND cmp$hardware_resume_pp;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$pp_queue_lock', EJECT ??

{ PURPOSE:
{   This function determines whether or not a PP currently has its pp queue locked.

  FUNCTION [XDCL, #GATE] cmp$pp_queue_lock
    (    pp_index: iot$pp_number): boolean;

    cmp$pp_queue_lock := FALSE;
    IF cmv$logical_pp_table_p^ [pp_index].flags.configured THEN
      cmp$pp_queue_lock := cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.lockword.lock;
    IFEND;

  FUNCEND cmp$pp_queue_lock;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$reacquire_resources', EJECT ??

{ PURPOSE:
{   This routine is used by CHANGE_ELEMENT_STATE to reacquire resources when state changes to DOWN or ON are
{   performed.
{ DESIGN:
{   The parameter reload_driver dictates whether to reload the driver or just reserve the resource.

  PROCEDURE [XDCL, #GATE] cmp$reacquire_resources
    (    request_type: dst$resource_request_types;
         channel: cmt$physical_channel;
         iou_number: dst$iou_number;
         equipment_number: 0 .. cmc$null_equipment_number;
         unit_number: 0 .. cmc$null_unit_number;
         driver_name: cmt$element_name;
         pp_table_rma: ost$real_memory_address;
         controller_type: cmt$controller_type;
         reload_driver: boolean;
     VAR status: ost$status);

    VAR
      channel_type: dst$channel_protocol_type,
      partner_pp_index: iot$pp_number,
      pp_index: iot$pp_number,
      resource_request: dst$resource_request;

    status.normal := TRUE;

    IF channel.concurrent THEN
      channel_type := dsc$cpt_cio;
    ELSE
      channel_type := dsc$cpt_nio;
    IFEND;

    cmp$retrieve_logical_pp_index (channel, iou_number, cmv$logical_pp_table_p, pp_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    partner_pp_index := cmv$logical_pp_table_p^ [pp_index].pp_info.logical_partner_pp_index;

    resource_request.channel.iou_number := iou_number;
    resource_request.channel.channel_protocol := channel_type;
    resource_request.channel.number := channel.number;

    IF request_type = dsc$rrt_get_equipment THEN
      resource_request.equipment_number := ORD (equipment_number);
      resource_request.unit_number := ORD (unit_number);
    IFEND;

    IF request_type <> dsc$rrt_get_pp THEN
      cmp$request_resources (request_type, resource_request, status);
      IF NOT status.normal THEN
        IF (status.condition <> dse$resource_already_assigned) AND
           (status.condition <> dse$ch_assigned_to_ve) THEN
          RETURN;
        ELSE
          status.normal := TRUE;
        IFEND;
      IFEND;
    IFEND;

    IF NOT reload_driver OR cmv$logical_pp_table_p^ [pp_index].flags.resources_acquired THEN
      RETURN;
    IFEND;

    IF partner_pp_index > 0 THEN
      resource_request.options := $dst$resource_request_options [dsc$rro_partner_pp];
    ELSEIF channel_type = dsc$cpt_nio THEN
      resource_request.options := $dst$resource_request_options [dsc$rro_driver_pp];
    ELSE
      resource_request.options := $dst$resource_request_options [];
    IFEND;
    cmp$request_resources (dsc$rrt_get_pp, resource_request, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp := resource_request.primary_pp;
    cmv$logical_pp_table_p^ [pp_index].flags.resources_acquired := TRUE;
    IF partner_pp_index > 0 THEN
      cmv$logical_pp_table_p^ [partner_pp_index].pp_info.physical_pp := resource_request.secondary_pp;
      cmv$logical_pp_table_p^ [partner_pp_index].flags.resources_acquired := TRUE;
    IFEND;

    dsp$load_pp (dsc$load_pp_by_name, resource_request.primary_pp, NIL,
          cmv$logical_pp_table_p^ [pp_index].pp_info.cip_driver_name, pp_table_rma, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cmp$assign_pp_r1 (TRUE, pp_index);

    IF partner_pp_index > 0 THEN
      dsp$load_pp (dsc$load_pp_by_name, resource_request.secondary_pp, NIL,
          cmv$logical_pp_table_p^ [pp_index].pp_info.cip_driver_name,
          cmv$logical_pp_table_p^ [pp_index].pp_info.pp_communication_buffer_p^.partner_pp, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      cmp$assign_pp_r1 (TRUE, partner_pp_index);
    IFEND;

  PROCEND cmp$reacquire_resources;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$resume_pp_r1', EJECT ??

{ PURPOSE:
{   This procedure sets up the monitor request block to soft resume a PP.

  PROCEDURE [XDCL, #GATE] cmp$resume_pp_r1
    (    channel_name: cmt$element_name;
         iou_name: cmt$element_name;
     VAR status: ost$status);

    VAR
      channel_element_p: ^cmt$element_definition,
      logical_pp_index: iot$pp_number,
      ignore_status: ^ost$status,
      request_block: cmt$request_block;

    status.normal := TRUE;

    cmp$pc_get_element (channel_name, iou_name, channel_element_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$get_logical_pp_index (channel_element_p^, logical_pp_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    request_block.request_code := syc$rc_config_mgmt_request;
    request_block.kind := cmc$rbk_resume_pp;
    request_block.resumed_pp := logical_pp_index;
    request_block.send_resume := TRUE;
    i#call_monitor (#LOC (request_block) , #SIZE (request_block));
    IF NOT request_block.status.normal THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$unable_to_resume,
            'PP did not respond to resume request.', status);

     osp$system_error ('PP did not respond' , ignore_status);
    IFEND;

  PROCEND cmp$resume_pp_r1;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$send_pp_command', EJECT ??

{ PURPOSE:
{   This procedure queues an idle pp or a resume pp request.

  PROCEDURE [XDCL, #GATE] cmp$send_pp_command
    (    pp_index: iot$pp_number;
         pp_command: cmt$pp_commands;
     VAR successful: boolean;
     VAR status: ost$status);

    VAR
      disk_request_p: ^iot$disk_request,
      dmv$external_interrupt_selector: [XREF] 0 .. 0ff(16),
      initial_pp_request: [STATIC] iot$disk_pp_request := [0, NIL, 0, 0, ioc$min_request_length, 0,
            ioc$attempt_recovery, [FALSE, 1], 1, [FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, 0], FALSE, 0, 0,
            0, 0, 0, [[0, [TRUE, FALSE, 0], 8, 0], [0, [TRUE, FALSE, 0], 8, 0], [0, [TRUE, FALSE, 0], 8, 0]]],
      io_request_p: ^iot$io_request,
      request_block: cmt$request_block;

    status.normal := TRUE;
    successful := FALSE;
    IF NOT cmv$logical_pp_table_p^ [pp_index].flags.configured THEN
      osp$set_status_condition (cme$ppit_not_built, status);
      RETURN;
    IFEND;

    ALLOCATE disk_request_p IN osv$mainframe_wired_cb_heap^;
    disk_request_p^.request_index := 0;
    disk_request_p^.link := NIL;
    disk_request_p^.request := initial_pp_request;

    IF pp_command = cmc$idle_command THEN
      disk_request_p^.request.command [1].command_code := ioc$cc_idle;
    ELSE  { pp_command = cmc$resume_command }
      disk_request_p^.request.command [1].command_code := ioc$cc_resume;
    IFEND;

    IF dmv$external_interrupt_selector = 1 THEN
      disk_request_p^.request.interrupt.value := TRUE;
      disk_request_p^.request.interrupt.port_number := osv$external_interrupt_selector;
    IFEND;
    ALLOCATE io_request_p IN osv$mainframe_wired_cb_heap^;
    io_request_p^.device_request_p := disk_request_p;
    io_request_p^.pp_request_p := ^disk_request_p^.request;

    request_block.request_code := syc$rc_config_mgmt_request;
    request_block.kind := cmc$rbk_queue_pp_request;
    request_block.queued_pp := pp_index;
    request_block.request_p := io_request_p;

    cmv$logical_pp_table_p^ [pp_index].pp_info.saved_io_request_p := io_request_p;
    i#call_monitor (#LOC (request_block), #SIZE (request_block));
    IF NOT request_block.status.normal THEN
      IF pp_command = cmc$idle_command THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$unable_to_idle,
              'PP did not respond to idle request.', status);
      ELSE  { pp_command = cmc$resume_command }
        osp$set_status_abnormal (cmc$configuration_management_id, cme$unable_to_resume,
              'PP did not respond to resume request.', status);
      IFEND;
      RETURN;
    IFEND;

    IF pp_command = cmc$idle_command THEN
      IF NOT cmv$logical_pp_table_p^ [pp_index].flags.pp_idle_resume_supported THEN
       successful := TRUE;
      ELSE
      successful := cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.idle_status;
      IFEND;
    ELSE  { pp_command = cmc$resume_command }
      successful := NOT cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.idle_status;
    IFEND;

  PROCEND cmp$send_pp_command;
?? OLDTITLE ??
MODEND cmm$maintenance_services_r1;
*DECK DECK=CMM$MANAGE_170_RESOURCES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE CM : Manage 170 Resources' ??
MODULE cmm$manage_170_resources;


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmd$null_equipment_number
*copyc cme$physical_configuration_mgr
*copyc cme$reserve_element
*copyc dse$error_codes
*copyc cmt$channel_ordinal
*copyc cmt$controller_location
*copyc cmt$controller_port_number
*copyc cmt$element_name
*copyc cmt$element_state
*copyc cmt$physical_channel
*copyc cmt$physical_equipment_number
*copyc cmt$pp_controller_loaded
*copyc cmt$request_block
*copyc oss$mainframe_paged_literal
?? POP ??
*copyc cmp$clear_channel_interlock
*copyc cmp$get_controller_type
*copyc cmp$get_logical_pp_index
*copyc cmp$pc_get_element
*copyc cmp$retrieve_logical_pp_index
*copyc dpp$put_critical_message
*copyc dsp$allocate_continuous_memory
*copyc dsp$fetch_controlware
*copyc dsp$load_pp
*copyc dsp$request_resources
*copyc i#call_monitor
*copyc i#move
*copyc i#ptr
*copyc i#real_memory_address
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$zero_out_table
?? EJECT ??
*copyc cmv$logical_pp_table_p
*copyc cmv$physical_configuration
*copyc cmv$system_device_pp
*copyc osv$mainframe_wired_cb_heap
*copyc osv$mainframe_wired_heap
*copyc osv$page_size
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    cmv$controller_location: [XDCL] cmt$controller_location :=
          [REP (ORD (UPPERVALUE (cmt$controller_type)) + 1) OF [FALSE, NIL, NIL,0, FALSE, NIL, NIL, 0]];
?? OLDTITLE ??
?? NEWTITLE := 'cmp$acquire_deadstart_resources', EJECT ??

{ PURPOSE:
{   This procedure obtains resources and loads pps during system deadstart.  This routine is used to load the
{   system device and deadstart device drivers in the boot and system core before full configuration is
{   activated.

  PROCEDURE [XDCL] cmp$acquire_deadstart_resources
    (    channel: cmt$physical_channel;
         iou_number: dst$iou_number;
         equipment_number: 0 .. cmc$null_equipment_number;
         unit_number: 0 .. cmc$null_unit_number;
     VAR status: ost$status);

    VAR
      channel_type: dst$channel_protocol_type,
      partner_pp_index: iot$pp_number,
      partner_pp_table_rma: ost$real_memory_address,
      pp_index: iot$pp_number,
      resource_request: dst$resource_request;

    status.normal := TRUE;

    IF channel.concurrent THEN
      channel_type := dsc$cpt_cio;
    ELSE
      channel_type := dsc$cpt_nio;
    IFEND;

    cmp$retrieve_logical_pp_index (channel, iou_number, cmv$logical_pp_table_p, pp_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    partner_pp_index := cmv$logical_pp_table_p^ [pp_index].pp_info.logical_partner_pp_index;
    partner_pp_table_rma := cmv$logical_pp_table_p^ [pp_index].pp_info.pp_communication_buffer_p^.partner_pp;

    resource_request.channel.iou_number := iou_number;
    resource_request.channel.channel_protocol := channel_type;
    resource_request.channel.number := channel.number;

    IF (equipment_number <> cmc$null_equipment_number) AND (unit_number <> cmc$null_unit_number) THEN
      resource_request.equipment_number := ORD (equipment_number);
      resource_request.unit_number := ORD (unit_number);
      cmp$request_resources (dsc$rrt_get_equipment, resource_request, status);
    ELSE
      cmp$request_resources (dsc$rrt_get_channel, resource_request, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF partner_pp_index > 0 THEN
      resource_request.options := $dst$resource_request_options [dsc$rro_partner_pp];
    ELSEIF channel_type = dsc$cpt_nio THEN
      resource_request.options := $dst$resource_request_options [dsc$rro_driver_pp];
    ELSE
      resource_request.options := $dst$resource_request_options [];
    IFEND;

    cmp$request_resources (dsc$rrt_get_pp, resource_request, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp := resource_request.primary_pp;
    cmv$logical_pp_table_p^ [pp_index].flags.resources_acquired := TRUE;
    cmv$system_device_pp.primary_pp := resource_request.primary_pp;
    cmv$system_device_pp.dual_pp := (partner_pp_index > 0);
    IF cmv$system_device_pp.dual_pp THEN
      cmv$logical_pp_table_p^ [partner_pp_index].pp_info.physical_pp := resource_request.secondary_pp;
      cmv$logical_pp_table_p^ [partner_pp_index].flags.resources_acquired := TRUE;
      cmv$system_device_pp.partner_pp := resource_request.secondary_pp;
    IFEND;

    dsp$load_pp (dsc$load_pp_by_name, cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp, NIL,
          cmv$logical_pp_table_p^ [pp_index].pp_info.cip_driver_name,
          cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_rma, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cmv$logical_pp_table_p^ [pp_index].flags.pp_loaded := TRUE;

    IF cmv$system_device_pp.dual_pp THEN
      dsp$load_pp (dsc$load_pp_by_name, cmv$logical_pp_table_p^ [partner_pp_index].pp_info.physical_pp, NIL,
            cmv$logical_pp_table_p^ [partner_pp_index].pp_info.cip_driver_name, partner_pp_table_rma, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      cmv$logical_pp_table_p^ [partner_pp_index].flags.pp_loaded := TRUE;
    IFEND;

  PROCEND cmp$acquire_deadstart_resources;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$assign_pp_r1', EJECT ??

{ PURPOSE:
{   This procedure sets up the monitor request block to indicate that a PP has been assigned in Monitor.

  PROCEDURE [XDCL] cmp$assign_pp_r1
    (    assigned: boolean;
         assigned_pp: iot$pp_number);

    VAR
      request_block: cmt$request_block;

    request_block.request_code := syc$rc_config_mgmt_request;
    request_block.kind := cmc$rbk_assign_pp;
    request_block.assigned := assigned;
    request_block.assigned_pp := assigned_pp;

    i#call_monitor (#LOC (request_block) , #SIZE (request_block));

  PROCEND cmp$assign_pp_r1;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$idle_pp_r1', EJECT ??

{ PURPOSE:
{   This procedure is the ring 1 interface to set up the monitor request block to soft idle a PP.

  PROCEDURE [XDCL, #GATE] cmp$idle_pp_r1
    (    channel_name: cmt$element_name;
         iou_name: cmt$element_name;
     VAR status: ost$status);

    VAR
      channel_element_p: ^cmt$element_definition,
      done: boolean,
      ignore_status: ost$status,
      line: string (80),
      message_output: boolean,
      new_time: integer,
      old_time: integer,
      pp_index: iot$pp_number,
      request_block: cmt$request_block,
      wait_time: integer;

    status.normal := TRUE;
    done := FALSE;
    line := ' ';
    message_output := FALSE;

    cmp$pc_get_element (channel_name, iou_name, channel_element_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$get_logical_pp_index (channel_element_p^, pp_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Send the IDLE on first call to MONITOR.  Wait up to 12 minutes (units in microseconds).

   /send_request/
    BEGIN
      request_block.request_code := syc$rc_config_mgmt_request;
      request_block.kind := cmc$rbk_idle_pp;
      request_block.idled_pp := pp_index;
      request_block.send_idle := TRUE;
      wait_time := 12 * 60 * 1000000;
      old_time := #FREE_RUNNING_CLOCK (0);
      REPEAT
        i#call_monitor (#LOC (request_block) , #SIZE (request_block));
        IF NOT request_block.status.normal THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$unable_to_idle,
                'PP did not respond to idle request.', status);
          EXIT /send_request/;
        IFEND;
        new_time := #FREE_RUNNING_CLOCK (0);
        done :=  (cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.idle_status) OR
              (new_time >= old_time + wait_time);
        IF NOT done AND (new_time > (old_time + 2000000)) THEN
          IF NOT message_output THEN
            line (1,26) := 'Waiting for PP to idle on ';
            line (28, 5) := channel_element_p^.data_channel.iou (1, 5);
            line (35, 5) := channel_name;
            dpp$put_critical_message (line, ignore_status);
            message_output := TRUE;
          IFEND;
        IFEND;

        { Only check PP response, the next time exchanging to MONITOR

        request_block.send_idle := FALSE;
      UNTIL done;

      IF NOT cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.idle_status THEN
        IF message_output THEN
          dpp$put_critical_message ('PP did not respond to idle request.', ignore_status);
          osp$set_status_abnormal (cmc$configuration_management_id, cme$unable_to_idle,
                'PP did not respond to idle request.', status);
        IFEND;
      ELSE
        IF message_output THEN
          dpp$put_critical_message ('PP responded to idle request.', ignore_status);
        IFEND;
      IFEND;
    END /send_request/;

    cmp$clear_channel_interlock (cmv$logical_pp_table_p^ [pp_index].pp_info.channel.iou_number,
          pp_index, ignore_status);
    IF NOT ignore_status.normal AND status.normal THEN
      status := ignore_status;
    IFEND;

  PROCEND cmp$idle_pp_r1;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$load_controller_module', EJECT ??

{ PURPOSE:
{   This procedure loads either controlware or a control module.  This procedure retrieves the necessary
{   controlware or control module from the CIP device and stores it in the mainframe wired heap.  It
{   creates the RMA list to the area in memory that contains the controller module so that the PP has access
{   to the area.

  PROCEDURE [XDCL] cmp$load_controller_module
    (    load_controller_type: (cmc$load_controlware, cmc$load_control_module);
     VAR logical_pp_table_p: ^cmt$logical_pp_table;
     VAR status : ost$status);

    TYPE
      unpacked_controller_data = PACKED RECORD
        fill: 0 .. 0f(16),
        byte: 0 .. 0ff(16),
      RECEND;

    VAR
      controller_buffer_p: ^SEQ ( * ),
      controller_length: integer,
      controller_name: string (4),
      controller_p: ^cell,
      controller_type: cmt$controller_type,
      max_rma_list_entries : integer,
      packed_controller_p: ^ARRAY [1 .. *] OF 0 .. 0ff(16),
      page_offset: ost$segment_offset,
      pp_number: iot$pp_number,
      rma: integer,
      rma_list_index: mmt$rma_list_index,
      rma_list_p: ^cmt$controller_rma_list,
      rma_list_seq_p: ^SEQ ( * ),
      rma_list_size: integer,
      rma_length : integer,
      table_index: integer,
      temp_controller_length : integer,
      temp_controller_seq_p: ^SEQ ( * ),
      unpacked_controller_length: integer,
      unpacked_controller_p: ^PACKED ARRAY [1 .. *] OF unpacked_controller_data,
      unpacked_index: integer;

    status.normal := TRUE;

    { Go through the physical configuration and figure out all the controllers that need controlware, then
    { get it from the CIP common disk area.

   /search_pct/
    FOR table_index := LOWERBOUND(cmv$physical_configuration^) TO UPPERBOUND
           (cmv$physical_configuration^) DO
      IF (cmv$physical_configuration^[table_index].element_type = cmc$controller_element)
         OR (cmv$physical_configuration^[table_index].element_type =
             cmc$channel_adapter_element) THEN
        cmp$get_controller_type (cmv$physical_configuration^[table_index].product_id,
               controller_type, status);
        IF NOT status.normal THEN
          { The controller is a foreign device.
          status.normal := TRUE;
          CYCLE /search_pct/;
        IFEND;
        IF load_controller_type = cmc$load_control_module THEN
          IF cmv$controller_location [controller_type].control_module_loaded THEN
            CYCLE /search_pct/;
          IFEND;
        ELSE
          IF cmv$controller_location [controller_type].controlware_loaded THEN
            CYCLE /search_pct/;
          IFEND;
        IFEND;

      { Find the four character controller name.

        IF load_controller_type = cmc$load_control_module THEN
          CASE controller_type OF
          = cmc$ms7255_1_1 =
            controller_name := 'H422';
          = cmc$ms7255_1_2 =
            controller_name := 'H424';
          ELSE
            CYCLE /search_pct/;
          CASEND;
        ELSE
          CASE controller_type OF
          = cmc$mt7021_3x, cmc$mt7021_4x, cmc$mt5698_xx, cmc$mscm3_ct =
            CYCLE /search_pct/;
          = cmc$ms7255_1_1, cmc$ms7255_1_2 =
            controller_name := 'A462';
          = cmc$ms7165_2x =
            controller_name := 'A464';
          = cmc$mt5680_xx =
            controller_name := 'B468';
          = cmc$mt7221_1,cmc$mt7221_2_s0 =
            controller_name := 'B465';
          = cmc$ms7155_1x, cmc$ms7155_1 =
            controller_name := 'A721';
          = cmc$ms7154_x =
            controller_name := 'A401';
          = cmc$ca2629_2 =
            controller_name := 'C418';
          = cmc$mt698_xx =
            controller_name := 'B467';
          ELSE
            CYCLE /search_pct/;
          CASEND;
        IFEND;

        { Fetch the controller module from the CIP device.  The controller module is stored on the mainframe
        { wired heap.  This area must be freed when the procedure has moved the controller module to its
        { permanent location.

        temp_controller_seq_p := NIL;
        dsp$fetch_controlware (controller_name, temp_controller_seq_p, status);
        IF NOT status.normal THEN
          IF temp_controller_seq_p <> NIL THEN
            FREE temp_controller_seq_p IN osv$mainframe_wired_heap^;
          IFEND;
          RETURN;
        IFEND;
        controller_length := #SIZE (temp_controller_seq_p^);

        { Check to see if the controller module must be packed.  Several types
        { of controller modules must be packed from eight bits of data stored in
        { twelve bit groups to a continuous stream of data.

        IF (controller_name = 'A721') OR (controller_name = 'A464') OR
              (controller_name = 'A462') OR (controller_name = 'A401') THEN
          ALLOCATE controller_buffer_p: [[REP controller_length OF cell]] IN osv$mainframe_wired_cb_heap^;
          RESET controller_buffer_p;
          pmp$zero_out_table (#LOC (controller_buffer_p^), controller_length);
          RESET temp_controller_seq_p;
          unpacked_controller_length := (controller_length * 8) DIV 12;
          NEXT unpacked_controller_p: [1 .. unpacked_controller_length] IN temp_controller_seq_p;
          NEXT packed_controller_p: [1 .. controller_length] IN controller_buffer_p;
          controller_length := 0;
          FOR unpacked_index := 1 TO unpacked_controller_length DO
            controller_length := controller_length + 1;
            packed_controller_p^ [controller_length] := unpacked_controller_p^ [unpacked_index].byte;
          FOREND;
          RESET controller_buffer_p;
          RESET temp_controller_seq_p;
          pmp$zero_out_table (#LOC (temp_controller_seq_p^), controller_length);
          i#move (controller_buffer_p, temp_controller_seq_p, controller_length);
          FREE controller_buffer_p IN osv$mainframe_wired_cb_heap^;
        IFEND;

        { Move the controller module into the permanent mainframe wired location.

        ALLOCATE controller_buffer_p: [[REP controller_length OF cell]] IN osv$mainframe_wired_cb_heap^;
        RESET controller_buffer_p;
        pmp$zero_out_table (#LOC (controller_buffer_p^), controller_length);
        RESET temp_controller_seq_p;
        i#move (temp_controller_seq_p, controller_buffer_p, controller_length);
        FREE temp_controller_seq_p IN osv$mainframe_wired_heap^;

        { Allocate space for the RMA list and find the RMAs for the list.
        { First figure out the size needed for the rma list.

        max_rma_list_entries := 1;
        controller_p := controller_buffer_p;
        page_offset := #OFFSET (controller_p) MOD osv$page_size;
        temp_controller_length := controller_length;
        WHILE temp_controller_length > 0 DO
          IF (page_offset + temp_controller_length) > osv$page_size THEN
            rma_length := (osv$page_size - page_offset);
          ELSE
            rma_length := temp_controller_length;
          IFEND;
          temp_controller_length := temp_controller_length - rma_length;
          page_offset := 0;
          controller_p := i#ptr (rma_length, controller_p);
          max_rma_list_entries := max_rma_list_entries + 1;
        WHILEND;
        rma_list_size := max_rma_list_entries * #SIZE (mmt$rma_list_entry);

        dsp$allocate_continuous_memory (osv$mainframe_wired_cb_heap, rma_list_size, rma_list_seq_p);
        RESET rma_list_seq_p;
        pmp$zero_out_table (#LOC (rma_list_seq_p^), rma_list_size);
        NEXT rma_list_p: [1 .. max_rma_list_entries] IN rma_list_seq_p;
        rma_list_index := LOWERBOUND (rma_list_p^);
        controller_p := controller_buffer_p;
        page_offset := #OFFSET (controller_p) MOD osv$page_size;
        WHILE controller_length > 0 DO
          IF rma_list_index > UPPERBOUND (rma_list_p^) THEN
            osp$system_error ('Controller rma list not big enough in cmm$manage_170_resources', NIL);
          IFEND;
          i#real_memory_address (controller_p, rma);
          rma_list_p^ [rma_list_index].rma := rma;
          IF (page_offset + controller_length) > osv$page_size THEN
            rma_list_p^ [rma_list_index].length := osv$page_size - page_offset;
          ELSE
            rma_list_p^ [rma_list_index].length := controller_length;
          IFEND;
          controller_length := controller_length - rma_list_p^ [rma_list_index].length;
          page_offset := 0;
          controller_p := i#ptr (rma_list_p^ [rma_list_index].length, controller_p);
          rma_list_index := rma_list_index + 1;
        WHILEND;
        IF load_controller_type = cmc$load_control_module THEN
          cmv$controller_location [controller_type].control_module_loaded := TRUE;
          cmv$controller_location [controller_type].control_module_location_p := controller_buffer_p;
          cmv$controller_location [controller_type].control_module_rma_list_p := rma_list_p;
          cmv$controller_location [controller_type].control_module_rma_list_size := rma_list_size;
        ELSE
          cmv$controller_location [controller_type].controlware_loaded := TRUE;
          cmv$controller_location [controller_type].controlware_location_p := controller_buffer_p;
          cmv$controller_location [controller_type].controlware_rma_list_p := rma_list_p;
          cmv$controller_location [controller_type].controlware_rma_list_size := rma_list_size;
        IFEND;
      IFEND;
    FOREND /search_pct/;

   /search_pp_table/
    FOR pp_number := LOWERBOUND (logical_pp_table_p^) TO UPPERBOUND (logical_pp_table_p^) DO

      { Check to see if the PP is configured.

      IF NOT logical_pp_table_p^ [pp_number].flags.configured THEN
        CYCLE /search_pp_table/;
      IFEND;

      { Check to see if the controller module has already been found for this PP.

      controller_type := logical_pp_table_p^ [pp_number].controller_info.controller_type;
      CASE controller_type OF
      = cmc$mt7021_3x, cmc$mt7021_4x, cmc$mscm3_ct =
        CYCLE /search_pp_table/;
      ELSE
        ;
      CASEND;
      IF load_controller_type = cmc$load_control_module THEN
        IF logical_pp_table_p^ [pp_number].controller_info.control_module_loaded THEN
          CYCLE /search_pp_table/;
        IFEND;
      ELSE
        IF logical_pp_table_p^ [pp_number].controller_info.controlware_loaded THEN
          CYCLE /search_pp_table/;
        IFEND;
      IFEND;

      { Check to see if this particular type of controller module already exists in memory.  If it is then
      { set up the area in memory that the PP observes.  The command code must be set last because it is what
      { the PP reacts on.

      IF load_controller_type = cmc$load_control_module THEN
        IF cmv$controller_location [controller_type].control_module_loaded THEN
          i#real_memory_address (#LOC (cmv$controller_location [controller_type].control_module_rma_list_p^),
                rma);
          logical_pp_table_p^ [pp_number].pp_info.pp_communication_buffer_p^.control_module_command.address :=
                rma;
          logical_pp_table_p^ [pp_number].pp_info.pp_communication_buffer_p^.control_module_command.length :=
                cmv$controller_location [controller_type].control_module_rma_list_size;
          logical_pp_table_p^ [pp_number].pp_info.pp_communication_buffer_p^.
                control_module_command.command_code := ioc$cc_load_control_module;
          logical_pp_table_p^ [pp_number].controller_info.control_module_loaded := TRUE;
          CYCLE /search_pp_table/;
        IFEND;
      ELSE
        IF cmv$controller_location [controller_type].controlware_loaded THEN
          i#real_memory_address (#LOC (cmv$controller_location [controller_type].controlware_rma_list_p^),
                rma);
          logical_pp_table_p^ [pp_number].pp_info.pp_communication_buffer_p^.controlware_command.address :=
                rma;
          logical_pp_table_p^ [pp_number].pp_info.pp_communication_buffer_p^.controlware_command.length :=
                cmv$controller_location [controller_type].controlware_rma_list_size;
          logical_pp_table_p^ [pp_number].pp_info.pp_communication_buffer_p^.
                controlware_command.command_code := ioc$cc_load_controlware;
          logical_pp_table_p^ [pp_number].controller_info.controlware_loaded := TRUE;
          CYCLE /search_pp_table/;
        IFEND;
      IFEND;

    FOREND /search_pp_table/;

  PROCEND cmp$load_controller_module;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$release_channel_resource', EJECT ??

{ PURPOSE:
{   This routine is used to release channel resources.  It is used both by CM external interface initiated
{   calls and by system calls such as Change_Element_State.

  PROCEDURE [XDCL, #GATE] cmp$release_channel_resource
    (    channel: cmt$physical_channel;
         iou_number: dst$iou_number;
     VAR status: ost$status);

    VAR
      resource_request: dst$resource_request;

    status.normal := TRUE;

    resource_request.channel.number := channel.number;
    IF channel.concurrent THEN
      resource_request.channel.channel_protocol := dsc$cpt_cio;
    ELSE
      resource_request.channel.channel_protocol := dsc$cpt_nio;
    IFEND;
    resource_request.channel.iou_number := iou_number;

    cmp$request_resources (dsc$rrt_return_channel, resource_request, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND cmp$release_channel_resource;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$release_equipment_resource', EJECT ??

{ PURPOSE:
{   This routine is used to release equipment resources.  It is used both by CM external interface initiated
{   calls and by system calls such as Change_Element_State.

  PROCEDURE [XDCL, #GATE] cmp$release_equipment_resource
    (    channel: cmt$physical_channel;
         iou_number: dst$iou_number;
         equipment_number: 0 .. cmc$null_equipment_number;
         unit_number: 0 .. cmc$null_unit_number);

    VAR
      ignore_status: ost$status,
      resource_request: dst$resource_request;

    resource_request.channel.number := channel.number;
    IF channel.concurrent THEN
      resource_request.channel.channel_protocol := dsc$cpt_cio;
    ELSE
      resource_request.channel.channel_protocol := dsc$cpt_nio;
    IFEND;
    resource_request.channel.iou_number := iou_number;
    resource_request.equipment_number := ORD (equipment_number);
    resource_request.unit_number := ORD (unit_number);

    cmp$request_resources (dsc$rrt_return_equipment, resource_request, ignore_status);

  PROCEND cmp$release_equipment_resource;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$release_pp_resource', EJECT ??

{ PURPOSE:
{   This routine is used to release a PP resource.  It is used both by CM external interface initiated calls
{   and by system calls such as Change_Element_State.

  PROCEDURE [XDCL, #GATE] cmp$release_pp_resource
    (    pp_number: dst$iou_resource;
     VAR status: ost$status);

    VAR
      resource_request: dst$resource_request;

    status.normal := TRUE;

    resource_request.channel.iou_number := pp_number.iou_number;
    resource_request.options := $dst$resource_request_options [];
    resource_request.primary_pp := pp_number;

    cmp$request_resources (dsc$rrt_return_pp, resource_request, status);

  PROCEND cmp$release_pp_resource;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$release_pp_by_channel', EJECT ??

{ PURPOSE:
{   This routine is used to a release PP resource.  It is used both by CM external interface initiated calls
{   and by system calls such as Change_Element_State.

  PROCEDURE [XDCL, #GATE] cmp$release_pp_by_channel
    (    channel: cmt$physical_channel;
         iou_number: dst$iou_number;
     VAR status: ost$status);

    VAR
      pp_index:  iot$pp_number;

    status.normal := TRUE;

    cmp$retrieve_logical_pp_index (channel, iou_number, cmv$logical_pp_table_p, pp_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$release_pp_by_index (pp_index, status);

  PROCEND cmp$release_pp_by_channel;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$release_pp_by_index', EJECT ??

{ PURPOSE:
{   This routine is used to a release PP resource.  It is used both by CM external interface initiated calls
{   and by system calls such as Change_Element_State.

  PROCEDURE [XDCL, #GATE] cmp$release_pp_by_index
    (    pp_index: iot$pp_number;
     VAR status: ost$status);

    VAR
      partner_pp_index:  iot$pp_number,
      resource_request: dst$resource_request;

    status.normal := TRUE;

    IF NOT cmv$logical_pp_table_p^ [pp_index].flags.resources_acquired THEN
      RETURN;
    IFEND;

    resource_request.channel.number := 0;
    resource_request.channel.channel_protocol :=
          cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp.channel_protocol;
    resource_request.channel.iou_number := cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp.iou_number;
    resource_request.options := $dst$resource_request_options [];
    resource_request.primary_pp := cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp;
    partner_pp_index := cmv$logical_pp_table_p^ [pp_index].pp_info.logical_partner_pp_index;
    IF (partner_pp_index > 0) AND cmv$logical_pp_table_p^ [partner_pp_index].flags.resources_acquired THEN
      resource_request.secondary_pp := cmv$logical_pp_table_p^ [partner_pp_index].pp_info.physical_pp;
      resource_request.options := $dst$resource_request_options [dsc$rro_partner_pp];
    IFEND;

    cmp$request_resources (dsc$rrt_return_pp, resource_request, status);
    IF NOT status.normal THEN
       RETURN;
    IFEND;

    IF partner_pp_index > 0 THEN
      IF (cmv$system_device_pp.primary_pp = cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp) AND
            (cmv$system_device_pp.partner_pp =
            cmv$logical_pp_table_p^ [partner_pp_index].pp_info.physical_pp) THEN
        cmv$system_device_pp.dual_pp := FALSE;
      IFEND;
    IFEND;

    cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp.iou_number := 0;
    cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp.channel_protocol := dsc$cpt_nio;
    cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp.number := 33(8);
    cmv$logical_pp_table_p^ [pp_index].flags.resources_acquired := FALSE;
    IF partner_pp_index > 0 THEN
      cmv$logical_pp_table_p^ [partner_pp_index].pp_info.physical_pp.iou_number := 0;
      cmv$logical_pp_table_p^ [partner_pp_index].pp_info.physical_pp.channel_protocol := dsc$cpt_nio;
      cmv$logical_pp_table_p^ [partner_pp_index].pp_info.physical_pp.number := 33(8);
      cmv$logical_pp_table_p^ [partner_pp_index].flags.resources_acquired := FALSE;
    IFEND;

    cmp$assign_pp_r1 (FALSE, pp_index);
    IF partner_pp_index > 0 THEN
      cmp$assign_pp_r1 (FALSE, partner_pp_index);
    IFEND;

  PROCEND cmp$release_pp_by_index;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$request_resources', EJECT ??

{ PURPOSE:
{   This procedure makes a call to deadstart routines to request hardware resources.
{ DESIGN:
{   The parameter resource_request is both INPUT and OUTPUT.

  PROCEDURE [XDCL] cmp$request_resources
    (    request_type: dst$resource_request_types;
     VAR resource_request: dst$resource_request;
     VAR status: ost$status);

    IF (request_type = dsc$rrt_get_equipment) AND
         (resource_request.channel.channel_protocol = dsc$cpt_cio) THEN
      resource_request.resource_request_type := dsc$rrt_get_channel;
    ELSEIF (request_type = dsc$rrt_return_equipment) AND
         (resource_request.channel.channel_protocol = dsc$cpt_cio) THEN
      resource_request.resource_request_type := dsc$rrt_return_channel;
    ELSE
      resource_request.resource_request_type := request_type;
    IFEND;
    dsp$request_resources (resource_request, status);

  PROCEND cmp$request_resources;
?? OLDTITLE ??
MODEND cmm$manage_170_resources;
*DECK DECK=CMM$MANAGE_CM_TABLES EXPAND=TRUE
*DECK DECK=CMM$MANAGE_CM_TABLES_R1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Manage CM Tables Ring 1' ??
MODULE cmm$manage_cm_tables_r1;

{ PURPOSE:
{   This module contains interfaces that build and update Mainframe Wired data structures for Configuration
{   Management.
{
{ DESIGN:
{   The data structures managed in this module are mainly used to allow job(s) to reserve certain elements
{   in the physical configuration or even not present in the configuration at all.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmc$logical_unit_constants
*copyc cme$logical_configuration_mgr
*copyc cme$manage_interface_tables
*copyc cme$physical_configuration_mgr
*copyc cme$reserve_element
*copyc cmt$connection
*copyc cmt$controller_type
*copyc cmt$device_information
*copyc cmt$element_descriptor
*copyc cmt$element_reservation
*copyc cmt$mass_storage_information
*copyc dmc$cti_device_type_numbers
*copyc dst$device_path
*copyc dst$iou_resource
*copyc dst$resource_request_types
*copyc iot$pp_number
*copyc jmt$system_supplied_name
*copyc mse$request_maintenance_access
*copyc ost$global_task_id
*copyc pmt$mainframe_id
?? POP ??
*copyc cmp$clear_unit_shared
*copyc cmp$convert_channel_number
*copyc cmp$convert_channel_ordinal
*copyc cmp$convert_iou_name
*copyc cmp$convert_iou_number
*copyc cmp$crack_physical_address
*copyc cmp$determine_active_connection
*copyc cmp$format_error_message
*copyc cmp$get_controller_type
*copyc cmp$get_channel_def
*copyc cmp$get_driver_state
*copyc cmp$get_element_name_via_lun
*copyc cmp$get_element_state
*copyc cmp$get_logical_pp_index
*copyc cmp$get_logical_unit_number
*copyc cmp$get_max_number_of_pp
*copyc cmp$get_unit_type
*copyc cmp$locate_element_via_adr
*copyc cmp$locate_element_via_lun
*copyc cmp$locate_element_via_name
*copyc cmp$pc_get_element
*copyc cmp$pc_get_logical_unit
*copyc cmp$request_channels
*copyc cmp$search_peripheral_table
*copyc cmp$set_unit_shared
*copyc dsp$retrieve_iou_information
*copyc i#real_memory_address
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$clear_signature_lock
*copyc osp$free_heap_pages
*copyc osp$set_locked_variable
*copyc osp$set_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$get_job_names
*copyc pmp$zero_out_table
?? EJECT ??
*copyc cmv$configuration_activated
*copyc cmv$data_channel_address
*copyc cmv$iou_table_p
*copyc cmv$logical_pp_table_lock
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_lock
*copyc cmv$logical_unit_table
*copyc cmv$max_number_of_pp
*copyc cmv$peripheral_element_table
*copyc cmv$physical_configuration
*copyc cmv$state_info_table
*copyc osv$mainframe_wired_cb_heap
*copyc pmv$mainframe_id
?? OLDTITLE ??
?? NEWTITLE := 'check_active_path', EJECT ??

  PROCEDURE check_active_path
    (    equipment_number: cmt$physical_equipment_number;
         mass_storage: cmt$mass_storage_information;
     VAR active_path: boolean);

    VAR
      channel_element_p: ^cmt$element_definition,
      channel_name: cmt$element_name,
      channel_ordinal: cmt$channel_ordinal,
      controller_element_p: ^cmt$element_definition,
      equipment: ARRAY [cmt$physical_equipment_number] OF cmt$element_connection,
      iou_name: cmt$element_name,
      local_status: ost$status,
      state: cmt$element_state,
      valid: boolean;

    active_path := FALSE;

    cmp$convert_iou_number (mass_storage.iou_number, iou_name, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    cmp$convert_channel_number (mass_storage.channel.number, mass_storage.channel.concurrent,
          mass_storage.channel.port, channel_ordinal, channel_name, valid);
    cmp$pc_get_element (channel_name, iou_name, channel_element_p, local_status);
    IF NOT local_status.normal THEN
       RETURN;
    IFEND;
    cmp$get_element_state (channel_element_p^.element_name, channel_element_p^.data_channel.iou, state,
          local_status);
    IF NOT local_status.normal OR (state <> cmc$on) THEN
      RETURN;
    IFEND;
    equipment := channel_element_p^.data_channel.connection.equipment;

    CASE mass_storage.unit_type OF
    = cmc$ms844_4x, cmc$ms885_1x, cmc$ms885_4x =
      IF equipment [equipment_number].configured THEN
        cmp$pc_get_element (equipment [equipment_number].element_name, {not used} iou_name,
              controller_element_p, local_status);
      IFEND;
    = cmc$ms895_2 =
      IF equipment [mass_storage.storage_director_address].configured THEN
        cmp$pc_get_element (equipment [mass_storage.storage_director_address].element_name,
              {not used} iou_name, controller_element_p, local_status);
      IFEND;
    = cmc$ms834_2, cmc$msfsd_2, cmc$msxmd_3, cmc$ms5832_1, cmc$ms5832_2, cmc$ms5833_1, cmc$ms5833_1p,
          cmc$ms5833_2, cmc$ms5833_3p, cmc$ms5833_4, cmc$ms5838_1, cmc$ms5838_1p, cmc$ms5838_2,
          cmc$ms5838_3p, cmc$ms5838_4, cmc$ms47444_1, cmc$ms47444_1p, cmc$ms47444_2, cmc$ms47444_3p,
          cmc$ms47444_4 =
      IF equipment [mass_storage.control_module].configured THEN
        cmp$pc_get_element (equipment [mass_storage.control_module].element_name, {not used} iou_name,
              controller_element_p, local_status);
      IFEND;
    ELSE
    CASEND;
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    active_path := TRUE;

  PROCEND check_active_path;
?? OLDTITLE ??
?? NEWTITLE := 'unmark_pp_element', EJECT ??

{ PURPOSE:
{   This procedure unmarks an element in the logical PP table.

  PROCEDURE unmark_pp_element
    (    table_index: integer;
         cleanup: boolean);

    VAR
      first_lun: iot$logical_unit,
      local_status: ost$status,
      lun_index: iot$logical_unit,
      mf_element_p: ^cmt$element_definition,
      need_to_free_commun_buffer: boolean,
      number_of_units: iot$logical_unit;

    IF cmv$logical_pp_table_p^ [table_index].flags.reservd_by_other_has_ch_present THEN
      update_ch_connection_status (table_index);
    IFEND;

    cmv$logical_pp_table_p^ [table_index].flags.entry_in_use := FALSE;
    cmv$logical_pp_table_p^ [table_index].flags.entry_reserved_by_other := FALSE;
    cmv$logical_pp_table_p^ [table_index].flags.entry_reserved_by_system_job := FALSE;
    cmv$logical_pp_table_p^ [table_index].flags.reservd_by_other_has_ch_present := FALSE;
    cmv$logical_pp_table_p^ [table_index].task_info.gtid.index := 4095;
    cmv$logical_pp_table_p^ [table_index].task_info.gtid.seqno := 255;
    cmv$logical_pp_table_p^ [table_index].task_info.reserved_job_name := '';
    cmv$logical_pp_table_p^ [table_index].pp_info.physical_pp.iou_number := 0;
    cmv$logical_pp_table_p^ [table_index].pp_info.physical_pp.number := 33(8);
    cmv$logical_pp_table_p^ [table_index].pp_info.physical_pp.channel_protocol := dsc$cpt_nio;
    need_to_free_commun_buffer :=
          (cmv$logical_pp_table_p^ [table_index].pp_info.cip_driver_name = 'NETW') OR
          (cmv$logical_pp_table_p^ [table_index].pp_info.cip_driver_name = 'ICAD') OR
          (cmv$logical_pp_table_p^ [table_index].pp_info.cip_driver_name = 'NPDR') OR
          (cmv$logical_pp_table_p^ [table_index].pp_info.cip_driver_name = 'NDI0') OR
          (cmv$logical_pp_table_p^ [table_index].pp_info.cip_driver_name = 'IVB0') OR
          (cmv$logical_pp_table_p^ [table_index].pp_info.cip_driver_name = 'IVB4') OR
          (cmv$logical_pp_table_p^ [table_index].pp_info.cip_driver_name = 'ESMD');
    cmv$logical_pp_table_p^ [table_index].pp_info.driver_name := ' ';
    cmv$logical_pp_table_p^ [table_index].pp_info.cip_driver_name := ' ';
    cmv$logical_pp_table_p^ [table_index].controller_info.controller_type := cmc$null_controller;

    IF NOT cmv$logical_pp_table_p^ [table_index].flags.configured THEN
      RETURN;
    IFEND;

    cmv$logical_pp_table_p^ [table_index].flags.configured := FALSE;
    cmv$logical_pp_table_p^ [table_index].flags.pp_loaded := FALSE;
    IF need_to_free_commun_buffer AND
          (cmv$logical_pp_table_p^ [table_index].pp_info.pp_communication_buffer_p <> NIL) THEN
      FREE cmv$logical_pp_table_p^ [table_index].pp_info.pp_communication_buffer_p IN
            osv$mainframe_wired_cb_heap^;
    IFEND;

    { Free response_buffer

    IF cmv$logical_pp_table_p^ [table_index].pp_info.pp_interface_table_p^.response_buffer <> NIL THEN
      FREE cmv$logical_pp_table_p^ [table_index].pp_info.pp_interface_table_p^.response_buffer IN
            osv$mainframe_wired_cb_heap^;
    IFEND;
    number_of_units := cmv$logical_pp_table_p^ [table_index].pp_info.pp_interface_table_p^.number_of_units;
    first_lun := cmv$logical_pp_table_p^ [table_index].pp_info.pp_interface_table_p^.first_logical_unit;
    FOR lun_index := first_lun TO (number_of_units + first_lun - 1) DO
      IF (cmv$logical_pp_table_p^ [table_index].pp_info.pp_interface_table_p^.
            unit_descriptors [lun_index].logical_unit <> 0) AND
            (cmv$logical_pp_table_p^ [table_index].pp_info.pp_interface_table_p^.
            unit_descriptors [lun_index].unit_interface_table <> NIL) THEN
        cmp$pc_get_logical_unit (lun_index, mf_element_p, local_status);
        IF NOT local_status.normal THEN  { NOT in active configuration.
          cmv$logical_unit_table^ [lun_index].configured := FALSE;
          cmv$logical_unit_table^ [lun_index].logical_unit_number := 0;
          IF cmv$logical_unit_table^ [lun_index].unit_interface_table <> NIL THEN
            FREE cmv$logical_unit_table^ [lun_index].unit_interface_table IN osv$mainframe_wired_cb_heap^;
          IFEND;
          IF cmv$logical_unit_table^ [lun_index].unit_communication_buffer_pva <> NIL THEN
            FREE cmv$logical_unit_table^ [lun_index].unit_communication_buffer_pva IN
                  osv$mainframe_wired_cb_heap^;
          IFEND;
        ELSE  { IN active configuration, then check if ICA, MDI, MTI, EXPRESSLINK or LCN. }
          IF NOT cleanup THEN
            IF (mf_element_p^.element_type = cmc$communications_element) OR
                  ((mf_element_p^.element_type = cmc$channel_adapter_element) AND
                  (mf_element_p^.product_id.product_number = ' $2629')) THEN
              cmv$logical_unit_table^ [lun_index].configured := FALSE;
              IF cmv$logical_unit_table^ [lun_index].unit_interface_table <> NIL THEN
                FREE cmv$logical_unit_table^ [lun_index].unit_interface_table IN
                      osv$mainframe_wired_cb_heap^;
              IFEND;
              IF cmv$logical_unit_table^ [lun_index].unit_communication_buffer_pva <> NIL THEN
                FREE cmv$logical_unit_table^ [lun_index].unit_communication_buffer_pva IN
                      osv$mainframe_wired_cb_heap^;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

    IF cmv$logical_pp_table_p^ [table_index].pp_info.pp_interface_table_p <> NIL THEN
      FREE cmv$logical_pp_table_p^ [table_index].pp_info.pp_interface_table_p IN
            osv$mainframe_wired_cb_heap^;
      cmp$get_max_number_of_pp (cmv$max_number_of_pp);
      IF cmv$logical_pp_table_p^ [table_index].controller_info.controlware_loaded THEN
        cmv$logical_pp_table_p^ [table_index].controller_info.controlware_loaded := FALSE;
      IFEND;
      IF cmv$logical_pp_table_p^ [table_index].controller_info.control_module_loaded THEN
        cmv$logical_pp_table_p^ [table_index].controller_info.control_module_loaded := FALSE;
      IFEND;
    IFEND;

    osp$free_heap_pages (osv$mainframe_wired_cb_heap);

  PROCEND unmark_pp_element;
?? OLDTITLE ??
?? NEWTITLE := 'update_ch_connection_status ', EJECT ??

{ PURPOSE:
{   This procedure will call the interface cmp$update_connection_status_r1 to update connection status for
{   the specified channel.

  PROCEDURE update_ch_connection_status
    (    pp_index: iot$pp_number);

    VAR
      channel_element_def_p: ^cmt$element_definition,
      channel_name: cmt$element_name,
      channel_ordinal: cmt$channel_ordinal,
      channel_valid: boolean,
      concurrent: boolean,
      iou_name: cmt$element_name,
      local_status: ost$status;

    concurrent := (cmv$logical_pp_table_p^ [pp_index].pp_info.channel.channel_protocol = dsc$cpt_cio);
    cmp$convert_channel_number (cmv$logical_pp_table_p^ [pp_index].pp_info.channel.number, concurrent,
          cmv$logical_pp_table_p^ [pp_index].pp_info.channel_port, channel_ordinal, channel_name,
          channel_valid);
    IF NOT channel_valid THEN
      RETURN;
    IFEND;

    cmp$convert_iou_number (cmv$logical_pp_table_p^ [pp_index].pp_info.channel.iou_number, iou_name,
          local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    cmp$pc_get_element (channel_name, iou_name, channel_element_def_p, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    cmp$change_connection_status_r1 (channel_element_def_p^, pmv$mainframe_id, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

  PROCEND update_ch_connection_status;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$build_element_def_table', EJECT ??

{ PURPOSE:
{   This procedure scans the CM mainframe pageable structure and builds the mainframe wired tables.

  PROCEDURE [XDCL, #GATE] cmp$build_element_def_table
    (    mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      channel_element: ^cmt$element_definition,
      cm_unit_type: cmt$unit_type,
      concurrent: boolean,
      configured_channels: integer,
      controller_element: ^cmt$element_definition,
      controller_type: cmt$controller_type,
      cpn: integer,
      dummy_iou: cmt$element_name,
      element_definition_p: ^cmt$element_definition,
      found: boolean,
      i: integer,
      index: integer,
      io_unit_type: iot$unit_type,
      iou_number: dst$iou_number,
      j: integer,
      local_status: ost$status,
      pet_entry_p: ^cmt$peripheral_element_entry,
      sdpn: integer,
      state_table_index: integer,
      total_connections: integer,
      total_paths: integer,
      unit_class: cmt$unit_class;

    VAR
      default_entry: [STATIC] cmt$peripheral_element_entry := [
        {element_name}                   osc$null_name,
        {product_id}                     ['      ', ' ', '   '],
        {serial_number}                  '      ',
        {logical_unit_number}            0,
        {element_status}                 [cmc$off, FALSE],
        {gtid}                           [4095, 255],
        {maintenance_activity}           [msc$concurrent_access, NIL],
        {physical_descriptor}            [FALSE,
          {hardware_address}               [$cmt$physical_address_specifier[ ],
            {iou}                             0,
            {channel}                         [0, cmc$unspecified_port, FALSE],
            {channel_address}                 0,
            {unit_address}                    0]],
        {entry_interlock}                FALSE,
        {state_change_request}           [FALSE],
        {reservable_element}             cmc$reservable,
        {reserved_status}                FALSE],

      valid_peripheral_element_entry: [STATIC] set of cmt$element_type :=
            [cmc$data_channel_element, cmc$channel_adapter_element, cmc$controller_element,
            cmc$external_processor_element, cmc$storage_device_element, cmc$communications_element];

    status.normal := TRUE;

    IF cmv$physical_configuration = NIL THEN
      osp$set_status_condition (cme$active_pc_empty, status);
      RETURN;
    IFEND;

    { Lock table during initialization.

    osp$set_signature_lock (cmv$peripheral_element_table.lock, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /main_program/
    BEGIN

      { Allocate table to be the size of CMV$PHYSICAL_CONFIGURATION + 20 to make room for reservation of
      { elements not in the configuration.

      ALLOCATE cmv$peripheral_element_table.pointer: [1 .. UPPERBOUND (cmv$physical_configuration^) + 20] IN
            osv$mainframe_wired_cb_heap^;

    /pc_loop/
      FOR index := LOWERBOUND (cmv$physical_configuration^) TO UPPERBOUND (cmv$physical_configuration^) DO
        pet_entry_p := ^cmv$peripheral_element_table.pointer^ [index];
        pet_entry_p^ := default_entry;
        element_definition_p := ^cmv$physical_configuration^ [index];

        IF NOT (element_definition_p^.element_type IN valid_peripheral_element_entry) THEN
          CYCLE /pc_loop/;
        IFEND;

        pet_entry_p^.element_name := element_definition_p^.element_name;
        pet_entry_p^.product_id := element_definition_p^.product_id;
        pet_entry_p^.serial_number := element_definition_p^.serial_number;
        pet_entry_p^.physical_descriptor.configured := TRUE;
        pet_entry_p^.physical_descriptor.element_type := element_definition_p^.element_type;

        { Search cmv$state_info_table to find LOGICAL_UNIT_NUMBER and ELEMENT_STATUS.

        found := FALSE;
        IF cmv$state_info_table <> NIL THEN

        /state_table_loop/
          FOR state_table_index := LOWERBOUND (cmv$state_info_table^) TO UPPERBOUND (cmv$state_info_table^) DO
            IF element_definition_p^.element_name =
                  cmv$state_info_table^ [state_table_index].element_name THEN
              IF element_definition_p^.element_type = cmc$data_channel_element THEN
                IF element_definition_p^.data_channel.iou <>
                      cmv$state_info_table^ [state_table_index].iou THEN
                  CYCLE /state_table_loop/;
                IFEND;
              IFEND;

              found := TRUE;
              pet_entry_p^.element_status := cmv$state_info_table^ [state_table_index].status;
              IF element_definition_p^.element_type <> cmc$data_channel_element THEN
                pet_entry_p^.logical_unit_number := cmv$state_info_table^ [state_table_index].logical_unit;
              IFEND;
              EXIT /state_table_loop/;
            IFEND;
          FOREND /state_table_loop/;
        IFEND;

        IF NOT found THEN
          pet_entry_p^.element_status.state := cmc$off;
          pet_entry_p^.logical_unit_number := 0;
        IFEND;

        CASE element_definition_p^.element_type OF
        = cmc$data_channel_element =
          total_connections := 0;
          FOR cpn := LOWERBOUND (element_definition_p^.data_channel.connection.equipment) TO
                UPPERBOUND (element_definition_p^.data_channel.connection.equipment) DO
            IF (element_definition_p^.data_channel.connection.equipment [cpn].configured) AND
                  (element_definition_p^.data_channel.mainframe_ownership = mainframe_id) THEN
              total_connections := total_connections + 1;
            IFEND;
          FOREND;

          ALLOCATE pet_entry_p^.physical_descriptor.channel_connection: [1 .. total_connections] IN
                osv$mainframe_wired_cb_heap^;

          cmp$convert_iou_name (element_definition_p^.data_channel.iou, iou_number, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

          { Construct the physical address.

          pet_entry_p^.physical_descriptor.channel_path.address_specifier :=
                $cmt$physical_address_specifier [cmc$iou, cmc$channel];
          pet_entry_p^.physical_descriptor.channel_path.iou := iou_number;
          pet_entry_p^.physical_descriptor.channel_path.channel_address := 0;
          pet_entry_p^.physical_descriptor.channel_path.unit_address := 0;
          pet_entry_p^.physical_descriptor.channel_path.channel.number :=
                element_definition_p^.data_channel.number;
          pet_entry_p^.physical_descriptor.channel_path.channel.port :=
                element_definition_p^.data_channel.port;
          pet_entry_p^.physical_descriptor.channel_path.channel.concurrent :=
                element_definition_p^.data_channel.concurrent;
          pet_entry_p^.physical_descriptor.mainframe_ownership :=
                element_definition_p^.data_channel.mainframe_ownership;

          { Create a connection_status entry for this channel and each connected element.

          total_connections := 0;
          FOR cpn := LOWERBOUND (element_definition_p^.data_channel.connection.equipment) TO
                UPPERBOUND (element_definition_p^.data_channel.connection.equipment) DO
            IF (element_definition_p^.data_channel.connection.equipment [cpn].configured) AND
                  (element_definition_p^.data_channel.mainframe_ownership = mainframe_id) THEN
              total_connections := total_connections + 1;
              pet_entry_p^.physical_descriptor.channel_connection^ [total_connections].status := cmc$inactive;
              pet_entry_p^.physical_descriptor.channel_connection^ [total_connections].downline_element :=
                    element_definition_p^.data_channel.connection.equipment [cpn].element_name;
            IFEND;
          FOREND;

        = cmc$controller_element =
          cmp$get_controller_type (element_definition_p^.product_id, controller_type, status);
          IF status.normal THEN
            pet_entry_p^.reservable_element := cmc$not_reservable;
          ELSE
            status.normal := TRUE;
            pet_entry_p^.reservable_element := cmc$reservable;
          IFEND;

          pet_entry_p^.physical_descriptor.microcode_identification :=
                element_definition_p^.controller.microcode_identification;
          pet_entry_p^.physical_descriptor.peripheral_driver_name :=
                element_definition_p^.controller.peripheral_driver_name;

          configured_channels := 0;
          total_connections := 0;
          FOR cpn := LOWERVALUE (cmt$controller_port_number) TO UPPERVALUE (cmt$controller_port_number) DO
            IF (element_definition_p^.controller.connection.port [cpn].configured) AND
                  (element_definition_p^.controller.connection.port [cpn].mainframe_ownership =
                  mainframe_id) THEN
              configured_channels := configured_channels + 1;
            IFEND;
          FOREND;

          FOR i := LOWERBOUND (element_definition_p^.controller.connection.unit) TO
                UPPERBOUND (element_definition_p^.controller.connection.unit) DO
            IF element_definition_p^.controller.connection.unit [i].configured THEN
              total_connections := total_connections + 1;
            IFEND;
          FOREND;

          ALLOCATE pet_entry_p^.physical_descriptor.equipment_path: [1 .. configured_channels] IN
                osv$mainframe_wired_cb_heap^;
          ALLOCATE pet_entry_p^.physical_descriptor.equipment_connection: [1 .. total_connections] IN
                osv$mainframe_wired_cb_heap^;

          configured_channels := 0;
          total_connections := 0;
          FOR cpn := LOWERVALUE (cmt$controller_port_number) TO UPPERVALUE (cmt$controller_port_number) DO
            IF (element_definition_p^.controller.connection.port [cpn].configured) AND
                  (element_definition_p^.controller.connection.port [cpn].mainframe_ownership =
                  mainframe_id) THEN
              configured_channels := configured_channels + 1;
              cmp$convert_iou_name (element_definition_p^.controller.connection.port [cpn].iou, iou_number,
                    status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;

              { Construct the physical address.

              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].address_specifier :=
                    $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address];
              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].iou := iou_number;
              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].channel_address :=
                    element_definition_p^.controller.physical_equipment_number;
              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].unit_address := 0;

              cmp$pc_get_element (element_definition_p^.controller.connection.port [cpn].element_name,
                    element_definition_p^.controller.connection.port [cpn].iou, channel_element, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;

              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].channel.number :=
                    channel_element^.data_channel.number;
              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].channel.port :=
                    channel_element^.data_channel.port;
              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].channel.concurrent :=
                    channel_element^.data_channel.concurrent;
            IFEND;
          FOREND;

          { Create a connection_status entry for each configured storage device element.

          FOR i := LOWERBOUND (element_definition_p^.controller.connection.unit) TO
                UPPERBOUND (element_definition_p^.controller.connection.unit) DO
            IF element_definition_p^.controller.connection.unit [i].configured THEN
              total_connections := total_connections + 1;
              pet_entry_p^.physical_descriptor.equipment_connection^ [total_connections].status :=
                    cmc$inactive;
              pet_entry_p^.physical_descriptor.equipment_connection^ [total_connections].downline_element :=
                    element_definition_p^.controller.connection.unit [i].element_name;
            IFEND;
          FOREND;

        = cmc$external_processor_element =
          pet_entry_p^.reservable_element := cmc$not_reservable;
          pet_entry_p^.physical_descriptor.microcode_identification :=
                element_definition_p^.controller.microcode_identification;
          pet_entry_p^.physical_descriptor.peripheral_driver_name :=
                element_definition_p^.controller.peripheral_driver_name;
          configured_channels := 0;

          FOR cpn := LOWERVALUE (cmt$physical_equipment_number) TO
                UPPERVALUE (cmt$physical_equipment_number) DO
            IF (element_definition_p^.external_processor.connection.io_port [cpn].configured) AND
                  (element_definition_p^.external_processor.connection.io_port [cpn].mainframe_ownership =
                  mainframe_id) THEN
              configured_channels := configured_channels + 1;
            IFEND;
          FOREND;

          ALLOCATE pet_entry_p^.physical_descriptor.equipment_path: [1 .. configured_channels] IN
                osv$mainframe_wired_cb_heap^;

          { An external_processor element does not support downline connections.

          cmv$peripheral_element_table.pointer^ [index].physical_descriptor.equipment_connection := NIL;

          configured_channels := 0;
          FOR cpn := LOWERVALUE (cmt$physical_equipment_number) TO
                UPPERVALUE (cmt$physical_equipment_number) DO
            IF (element_definition_p^.external_processor.connection.io_port [cpn].configured) AND
                  (element_definition_p^.external_processor.connection.io_port [cpn].mainframe_ownership =
                  mainframe_id) THEN
              configured_channels := configured_channels + 1;
              cmp$convert_iou_name (element_definition_p^.external_processor.connection.io_port [cpn].iou,
                    iou_number, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;

              { Construct the physical address.

              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].address_specifier :=
                    $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address];
              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].iou := iou_number;
              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].channel_address :=
                    element_definition_p^.external_processor.physical_equipment_number;
              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].unit_address := 0;

              cmp$pc_get_element (
                    element_definition_p^.external_processor.connection.io_port [cpn].element_name,
                    element_definition_p^.external_processor.connection.io_port [cpn].iou,
                    channel_element, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;

              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].channel.number :=
                    channel_element^.data_channel.number;
              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].channel.port :=
                    channel_element^.data_channel.port;
              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].channel.concurrent :=
                    channel_element^.data_channel.concurrent;
            IFEND;
          FOREND;

        = cmc$channel_adapter_element =

          { For S0/S0E, channel adapters (ICA) can only be reserved by the system.

          pet_entry_p^.reservable_element := cmc$reservable_only_by_system;
          pet_entry_p^.physical_descriptor.microcode_identification :=
                element_definition_p^.channel_adapter.microcode_identification;
          pet_entry_p^.physical_descriptor.peripheral_driver_name :=
                element_definition_p^.channel_adapter.peripheral_driver_name;

          total_connections := 0;
          FOR i := LOWERBOUND (element_definition_p^.channel_adapter.connection.equipment) TO
                UPPERBOUND (element_definition_p^.channel_adapter.connection.equipment) DO
            IF element_definition_p^.channel_adapter.connection.equipment [i].configured THEN
              total_connections := total_connections + 1;
            IFEND;
          FOREND;

          ALLOCATE pet_entry_p^.physical_descriptor.equipment_path: [1 .. 1] IN osv$mainframe_wired_cb_heap^;
          ALLOCATE pet_entry_p^.physical_descriptor.equipment_connection: [1 .. total_connections] IN
                osv$mainframe_wired_cb_heap^;

          IF element_definition_p^.channel_adapter.connection.channel.configured THEN
            cmp$convert_iou_name (element_definition_p^.channel_adapter.connection.channel.iou, iou_number,
                  status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            pet_entry_p^.physical_descriptor.equipment_path^ [1].address_specifier :=
                  $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address];
            pet_entry_p^.physical_descriptor.equipment_path^ [1].iou := iou_number;
            pet_entry_p^.physical_descriptor.equipment_path^ [1].channel_address :=
                  element_definition_p^.channel_adapter.physical_equipment_number;
            pet_entry_p^.physical_descriptor.equipment_path^ [1].unit_address := 0;

            cmp$pc_get_element (element_definition_p^.channel_adapter.connection.channel.element_name,
                  element_definition_p^.channel_adapter.connection.channel.iou, channel_element, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            pet_entry_p^.physical_descriptor.equipment_path^ [1].channel.number :=
                  channel_element^.data_channel.number;
            pet_entry_p^.physical_descriptor.equipment_path^ [1].channel.port :=
                  channel_element^.data_channel.port;
            pet_entry_p^.physical_descriptor.equipment_path^ [1].channel.concurrent :=
                  channel_element^.data_channel.concurrent;

            { Create a connection_status entry for this channel adapter and each configured equipment.

            total_connections := 0;
            FOR i := LOWERBOUND (element_definition_p^.channel_adapter.connection.equipment) TO
                  UPPERBOUND (element_definition_p^.channel_adapter.connection.equipment) DO
              IF element_definition_p^.channel_adapter.connection.equipment [i].configured THEN
                total_connections := total_connections + 1;
                pet_entry_p^.physical_descriptor.equipment_connection^ [total_connections].status :=
                      cmc$inactive;
                pet_entry_p^.physical_descriptor.equipment_connection^ [total_connections].downline_element :=
                      element_definition_p^.channel_adapter.connection.equipment [i].element_name;
              IFEND;
            FOREND;
          IFEND;

        = cmc$communications_element =
          pet_entry_p^.reservable_element := cmc$reservable_only_by_system;
          pet_entry_p^.physical_descriptor.microcode_identification :=
                element_definition_p^.communications_element.microcode_identification;
          pet_entry_p^.physical_descriptor.peripheral_driver_name :=
                element_definition_p^.communications_element.peripheral_driver_name;

          configured_channels := 0;
          FOR cpn := LOWERVALUE (cmt$communications_port_number) TO
                UPPERVALUE (cmt$communications_port_number) DO
            IF (element_definition_p^.communications_element.connection.port [cpn].configured) AND
                  (element_definition_p^.communications_element.connection.port [cpn].mainframe_ownership =
                  mainframe_id) THEN
              configured_channels := configured_channels + 1;
            IFEND;
          FOREND;

          ALLOCATE pet_entry_p^.physical_descriptor.equipment_path: [1 .. configured_channels] IN
                osv$mainframe_wired_cb_heap^;

          { A communications element does not support downline connections.

          cmv$peripheral_element_table.pointer^ [index].physical_descriptor.equipment_connection := NIL;

          configured_channels := 0;
          FOR cpn := LOWERVALUE (cmt$communications_port_number) TO
                UPPERVALUE (cmt$communications_port_number) DO
            IF (element_definition_p^.communications_element.connection.port [cpn].configured) AND
                  (element_definition_p^.communications_element.connection.port [cpn].mainframe_ownership =
                  mainframe_id) THEN
              configured_channels := configured_channels + 1;
              cmp$convert_iou_name (element_definition_p^.communications_element.connection.port [cpn].iou,
                    iou_number, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;

              { Construct the physical address.

              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].address_specifier :=
                    $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address];
              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].iou := iou_number;
              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].channel_address :=
                    element_definition_p^.communications_element.physical_equipment_number;
              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].unit_address := 0;

              cmp$pc_get_element (
                    element_definition_p^.communications_element.connection.port [cpn].element_name,
                    element_definition_p^.communications_element.connection.port [cpn].iou,
                    channel_element, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;

              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].channel.number :=
                    channel_element^.data_channel.number;
              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].channel.port :=
                    channel_element^.data_channel.port;
              pet_entry_p^.physical_descriptor.equipment_path^ [configured_channels].channel.concurrent :=
                    channel_element^.data_channel.concurrent;
            IFEND;
          FOREND;

        = cmc$storage_device_element =
          cmp$get_unit_type (element_definition_p^.product_id, cm_unit_type, io_unit_type, unit_class, found);
          IF found THEN
            pet_entry_p^.reservable_element := cmc$not_reservable;
          ELSE
            pet_entry_p^.reservable_element := cmc$reservable;
          IFEND;

          IF cm_unit_type = cmc$mshydra THEN
            total_paths := 0;
            FOR sdpn := LOWERVALUE (cmt$data_storage_port_number) TO
                  UPPERVALUE (cmt$data_storage_port_number) DO
              IF (element_definition_p^.storage_device.connection.port [sdpn].configured) AND
                    (element_definition_p^.storage_device.connection.port [sdpn].mainframe_ownership =
                    mainframe_id) THEN
                total_paths := total_paths + 1;
              IFEND;
            FOREND;

            ALLOCATE pet_entry_p^.physical_descriptor.unit_path: [1 .. total_paths] IN
                  osv$mainframe_wired_cb_heap^;

            total_paths := 0;
            FOR sdpn := LOWERVALUE (cmt$data_storage_port_number) TO
                  UPPERVALUE (cmt$data_storage_port_number) DO
              IF (element_definition_p^.storage_device.connection.port [sdpn].configured) AND
                    (element_definition_p^.storage_device.connection.port [sdpn].mainframe_ownership =
                    mainframe_id) THEN

                { Construct the physical address.

                total_paths := total_paths + 1;
                cmp$convert_iou_name (element_definition_p^.storage_device.connection.port [sdpn].iou,
                      iou_number, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
                pet_entry_p^.physical_descriptor.unit_path^ [total_paths].address_specifier :=
                      $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$unit_address];
                pet_entry_p^.physical_descriptor.unit_path^ [total_paths].iou := iou_number;
                pet_entry_p^.physical_descriptor.unit_path^ [total_paths].channel_address := 0;
                pet_entry_p^.physical_descriptor.unit_path^ [total_paths].unit_address :=
                      element_definition_p^.storage_device.physical_unit_number;

                cmp$pc_get_element (element_definition_p^.storage_device.connection.port [sdpn].element_name,
                      element_definition_p^.storage_device.connection.port [sdpn].iou, channel_element,
                      status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;

                pet_entry_p^.physical_descriptor.unit_path^ [total_paths].channel.number :=
                      channel_element^.data_channel.number;
                pet_entry_p^.physical_descriptor.unit_path^ [total_paths].channel.port :=
                      channel_element^.data_channel.port;
                pet_entry_p^.physical_descriptor.unit_path^ [total_paths].channel.concurrent :=
                      channel_element^.data_channel.concurrent;
              IFEND;
            FOREND;

          ELSE { storage device other than hydra }
            total_paths := 0;

          /count_paths/
            FOR sdpn := LOWERVALUE (cmt$data_storage_port_number) TO
                  UPPERVALUE (cmt$data_storage_port_number) DO
              IF NOT element_definition_p^.storage_device.connection.port [sdpn].configured THEN
                CYCLE /count_paths/;
              IFEND;

              CASE element_definition_p^.storage_device.connection.port [sdpn].upline_connection_type OF
              = cmc$controller_element =
                cmp$pc_get_element (element_definition_p^.storage_device.connection.port [sdpn].element_name,
                      dummy_iou, controller_element, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;

                FOR cpn := LOWERVALUE (cmt$controller_port_number) TO
                      UPPERVALUE (cmt$controller_port_number) DO
                  IF (controller_element^.controller.connection.port [cpn].configured) AND
                        (controller_element^.controller.connection.port [cpn].mainframe_ownership =
                        mainframe_id) THEN
                    total_paths := total_paths + 1;
                  IFEND;
                FOREND;

              = cmc$data_channel_element =
                FOR configured_channels := LOWERVALUE (cmt$data_storage_port_number) TO
                      UPPERVALUE (cmt$data_storage_port_number) DO
                  IF (element_definition_p^.storage_device.connection.port [configured_channels].
                        configured) AND (element_definition_p^.storage_device.connection.
                        port [configured_channels].mainframe_ownership = mainframe_id) THEN
                    total_paths := total_paths + 1;
                  IFEND;
                FOREND;
              ELSE
              CASEND;
            FOREND /count_paths/;

            ALLOCATE pet_entry_p^.physical_descriptor.unit_path: [1 .. total_paths] IN
                  osv$mainframe_wired_cb_heap^;

            total_paths := 0;

          /build_paths_1/
            FOR sdpn := LOWERVALUE (cmt$data_storage_port_number) TO
                  UPPERVALUE (cmt$data_storage_port_number) DO
              IF NOT element_definition_p^.storage_device.connection.port [sdpn].configured THEN
                CYCLE /build_paths_1/;
              IFEND;

              CASE element_definition_p^.storage_device.connection.port [sdpn].upline_connection_type OF
              = cmc$controller_element =
                cmp$pc_get_element (element_definition_p^.storage_device.connection.port [sdpn].element_name,
                      dummy_iou, controller_element, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;

                FOR cpn := LOWERVALUE (cmt$controller_port_number) TO
                      UPPERVALUE (cmt$controller_port_number) DO
                  IF (controller_element^.controller.connection.port [cpn].configured) AND
                        (controller_element^.controller.connection.port [cpn].mainframe_ownership =
                        mainframe_id) THEN
                    total_paths := total_paths + 1;

                    cmp$convert_iou_name (controller_element^.controller.connection.port [cpn].iou,
                          iou_number, status);
                    IF NOT status.normal THEN
                      EXIT /main_program/;
                    IFEND;

                    pet_entry_p^.physical_descriptor.unit_path^ [total_paths].address_specifier :=
                          -$cmt$physical_address_specifier [];
                    pet_entry_p^.physical_descriptor.unit_path^ [total_paths].iou := iou_number;
                    pet_entry_p^.physical_descriptor.unit_path^ [total_paths].unit_address :=
                          element_definition_p^.storage_device.physical_unit_number;
                    pet_entry_p^.physical_descriptor.unit_path^ [total_paths].channel_address :=
                          controller_element^.controller.physical_equipment_number;

                    cmp$pc_get_element (controller_element^.controller.connection.port [cpn].element_name,
                          controller_element^.controller.connection.port [cpn].iou, channel_element, status);
                    IF NOT status.normal THEN
                      EXIT /main_program/;
                    IFEND;

                    pet_entry_p^.physical_descriptor.unit_path^ [total_paths].channel.number :=
                          channel_element^.data_channel.number;
                    pet_entry_p^.physical_descriptor.unit_path^ [total_paths].channel.port :=
                          channel_element^.data_channel.port;
                    pet_entry_p^.physical_descriptor.unit_path^ [total_paths].channel.concurrent :=
                          channel_element^.data_channel.concurrent;
                  IFEND;
                FOREND;

              = cmc$data_channel_element =
                total_paths := 0;
                FOR configured_channels := LOWERVALUE (cmt$data_storage_port_number) TO
                      UPPERVALUE (cmt$data_storage_port_number) DO
                  IF (element_definition_p^.storage_device.connection.port [configured_channels].
                        configured) AND (element_definition_p^.storage_device.connection.
                        port [configured_channels].mainframe_ownership = mainframe_id) THEN
                    total_paths := total_paths + 1;

                    cmp$convert_iou_name (
                          element_definition_p^.storage_device.connection.port [configured_channels].iou,
                          iou_number, status);
                    IF NOT status.normal THEN
                      EXIT /main_program/;
                    IFEND;

                    pet_entry_p^.physical_descriptor.unit_path^ [total_paths].address_specifier :=
                          $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address];
                    pet_entry_p^.physical_descriptor.unit_path^ [total_paths].iou := iou_number;
                    pet_entry_p^.physical_descriptor.unit_path^ [total_paths].unit_address := 0;
                    pet_entry_p^.physical_descriptor.unit_path^ [total_paths].channel_address :=
                          element_definition_p^.storage_device.physical_unit_number;

                    cmp$pc_get_element (element_definition_p^.storage_device.connection.
                          port [configured_channels].element_name, element_definition_p^.storage_device.
                          connection.port [configured_channels].iou, channel_element, status);
                    IF NOT status.normal THEN
                      EXIT /main_program/;
                    IFEND;

                    pet_entry_p^.physical_descriptor.unit_path^ [total_paths].channel.number :=
                          channel_element^.data_channel.number;
                    pet_entry_p^.physical_descriptor.unit_path^ [total_paths].channel.port :=
                          channel_element^.data_channel.port;
                    pet_entry_p^.physical_descriptor.unit_path^ [total_paths].channel.concurrent :=
                          channel_element^.data_channel.concurrent;
                  IFEND;
                FOREND;
              ELSE
              CASEND;
            FOREND /build_paths_1/;
          IFEND;
        ELSE
        CASEND;
      FOREND /pc_loop/;

      FOR index := (UPPERBOUND (cmv$physical_configuration^) + 1) TO
            UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
        cmv$peripheral_element_table.pointer^ [index] := default_entry;
      FOREND;

    END /main_program/;

    osp$clear_signature_lock (cmv$peripheral_element_table.lock, local_status);
    IF status.normal THEN
      status := local_status;
    IFEND;

  PROCEND cmp$build_element_def_table;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$change_connection_status_r1 ', EJECT ??

{ PURPOSE:
{   This procedure will update the connection status for all elements connected to the specified elements.
{   The new connection status will based on the states of the elements.

  PROCEDURE [XDCL, #GATE] cmp$change_connection_status_r1
    (    primary_element: cmt$element_definition;
         mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      downline_element_state: cmt$element_state,
      dummy_reservation: cmt$element_reservation,
      driver_present: boolean,
      element_descriptor: cmt$element_descriptor,
      i: integer,
      j: integer,
      local_status: ost$status,
      pet_entry_p: ^cmt$peripheral_element_entry,
      pet_index: integer,
      primary_element_state: cmt$element_state,
      upline_connection: cmt$upline_connection,
      upline_element_p: ^cmt$element_definition,
      upline_element_state: cmt$element_state;

    status.normal := TRUE;

    IF cmv$physical_configuration = NIL THEN
      osp$set_status_condition (cme$active_pc_empty, status);
      RETURN;
    IFEND;

    osp$set_signature_lock (cmv$peripheral_element_table.lock, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /main_program/
    BEGIN
      CASE primary_element.element_type OF
      = cmc$data_channel_element =
        cmp$get_element_state (primary_element.element_name, primary_element.data_channel.iou,
              primary_element_state, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        element_descriptor.element_type := primary_element.element_type;
        element_descriptor.channel_descriptor.iou := primary_element.data_channel.iou;
        element_descriptor.channel_descriptor.use_logical_identification := TRUE;
        element_descriptor.channel_descriptor.name := primary_element.element_name;

        cmp$search_peripheral_table (element_descriptor, dummy_reservation, {not_in_configuration} FALSE,
              pet_index, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        pet_entry_p := ^cmv$peripheral_element_table.pointer^ [pet_index];

        FOR j := LOWERBOUND (pet_entry_p^.physical_descriptor.channel_connection^) TO
              UPPERBOUND (pet_entry_p^.physical_descriptor.channel_connection^) DO
          cmp$get_element_state (pet_entry_p^.physical_descriptor.channel_connection^ [j].downline_element,
                osc$null_name, downline_element_state, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

          cmp$get_driver_state (primary_element.element_name, primary_element.data_channel.iou,
                driver_present, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

          IF driver_present AND (primary_element_state = cmc$on) AND (downline_element_state = cmc$on) THEN
            pet_entry_p^.physical_descriptor.channel_connection^ [j].status := cmc$active;
          ELSE
            pet_entry_p^.physical_descriptor.channel_connection^ [j].status := cmc$inactive;
          IFEND;
        FOREND;

      = cmc$controller_element =
        cmp$get_element_state (primary_element.element_name, osc$null_name, primary_element_state, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

      /locate_upline_1/
        FOR i := LOWERBOUND (primary_element.controller.connection.port) TO
              UPPERBOUND (primary_element.controller.connection.port) DO
          upline_connection := primary_element.controller.connection.port [i];
          IF NOT upline_connection.configured THEN
            CYCLE /locate_upline_1/;
          IFEND;

          IF upline_connection.upline_connection_type <> cmc$data_channel_element THEN
            CYCLE /locate_upline_1/;
          IFEND;

          IF upline_connection.mainframe_ownership <> mainframe_id THEN
            CYCLE /locate_upline_1/;
          IFEND;

          cmp$pc_get_element (upline_connection.element_name, upline_connection.iou, upline_element_p,
                status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

          cmp$get_element_state (upline_element_p^.element_name, upline_element_p^.data_channel.iou,
                upline_element_state, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

          element_descriptor.element_type := upline_element_p^.element_type;
          element_descriptor.channel_descriptor.iou := upline_element_p^.data_channel.iou;
          element_descriptor.channel_descriptor.use_logical_identification := TRUE;
          element_descriptor.channel_descriptor.name := upline_element_p^.element_name;

          cmp$search_peripheral_table (element_descriptor, dummy_reservation, {not_in_configuration} FALSE,
                pet_index, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
          pet_entry_p := ^cmv$peripheral_element_table.pointer^ [pet_index];

          FOR j := LOWERBOUND (pet_entry_p^.physical_descriptor.channel_connection^) TO
                UPPERBOUND (pet_entry_p^.physical_descriptor.channel_connection^) DO
            IF pet_entry_p^.physical_descriptor.channel_connection^ [j].downline_element =
                  primary_element.element_name THEN
              IF (upline_element_state = cmc$on) AND (primary_element_state = cmc$on) THEN
                pet_entry_p^.physical_descriptor.channel_connection^ [j].status := cmc$active;
              ELSE
                pet_entry_p^.physical_descriptor.channel_connection^ [j].status := cmc$inactive;
              IFEND;
            IFEND;
          FOREND;
        FOREND /locate_upline_1/;

        { Change the downline connection status.

        element_descriptor.element_type := primary_element.element_type;
        element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
        element_descriptor.peripheral_descriptor.element_name := primary_element.element_name;

        cmp$search_peripheral_table (element_descriptor, dummy_reservation, {not_in_configuration} FALSE,
              pet_index, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        pet_entry_p := ^cmv$peripheral_element_table.pointer^ [pet_index];

        FOR j := LOWERBOUND (pet_entry_p^.physical_descriptor.equipment_connection^) TO
              UPPERBOUND (pet_entry_p^.physical_descriptor.equipment_connection^) DO
          cmp$get_element_state (pet_entry_p^.physical_descriptor.equipment_connection^ [j].downline_element,
                osc$null_name, downline_element_state, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

          IF (primary_element_state = cmc$on) AND (downline_element_state = cmc$on) THEN
            pet_entry_p^.physical_descriptor.equipment_connection^ [j].status := cmc$active;
          ELSE
            pet_entry_p^.physical_descriptor.equipment_connection^ [j].status := cmc$inactive;
          IFEND;
        FOREND;

      = cmc$storage_device_element =
        cmp$get_element_state (primary_element.element_name, osc$null_name, primary_element_state, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

      /locate_upline_2/
        FOR i := LOWERBOUND (primary_element.storage_device.connection.port) TO
              UPPERBOUND (primary_element.storage_device.connection.port) DO
          upline_connection := primary_element.storage_device.connection.port [i];
          IF NOT upline_connection.configured THEN
            CYCLE /locate_upline_2/;
          IFEND;

          CASE upline_connection.upline_connection_type OF
          = cmc$controller_element, cmc$channel_adapter_element =
            cmp$pc_get_element (upline_connection.element_name, osc$null_name, upline_element_p, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            cmp$get_element_state (upline_element_p^.element_name, osc$null_name, upline_element_state,
                  status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            element_descriptor.element_type := upline_element_p^.element_type;
            element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
            element_descriptor.peripheral_descriptor.element_name := upline_element_p^.element_name;

            cmp$search_peripheral_table (element_descriptor, dummy_reservation, {not_in_configuration} FALSE,
                  pet_index, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            pet_entry_p := ^cmv$peripheral_element_table.pointer^ [pet_index];

            FOR j := LOWERBOUND (pet_entry_p^.physical_descriptor.equipment_connection^) TO
                  UPPERBOUND (pet_entry_p^.physical_descriptor.equipment_connection^) DO
              IF pet_entry_p^.physical_descriptor.equipment_connection^ [j].downline_element =
                    primary_element.element_name THEN
                IF (upline_element_state = cmc$on) AND (primary_element_state = cmc$on) THEN
                  pet_entry_p^.physical_descriptor.equipment_connection^ [j].status := cmc$active;
                ELSE
                  pet_entry_p^.physical_descriptor.equipment_connection^ [j].status := cmc$inactive;
                IFEND;
              IFEND;
            FOREND;

          = cmc$data_channel_element =

            { Process the Hydra device.

            IF upline_connection.mainframe_ownership <> mainframe_id THEN
              CYCLE /locate_upline_2/;
            IFEND;

            cmp$pc_get_element (upline_connection.element_name, upline_connection.iou, upline_element_p,
                  status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            cmp$get_element_state (upline_element_p^.element_name, upline_element_p^.data_channel.iou,
                  upline_element_state, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            element_descriptor.element_type := upline_element_p^.element_type;
            element_descriptor.channel_descriptor.iou := upline_element_p^.data_channel.iou;
            element_descriptor.channel_descriptor.use_logical_identification := TRUE;
            element_descriptor.channel_descriptor.name := upline_element_p^.element_name;

            cmp$search_peripheral_table (element_descriptor, dummy_reservation, {not_in_configuration} FALSE,
                  pet_index, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            pet_entry_p := ^cmv$peripheral_element_table.pointer^ [pet_index];

            FOR j := LOWERBOUND (pet_entry_p^.physical_descriptor.channel_connection^) TO
                  UPPERBOUND (pet_entry_p^.physical_descriptor.channel_connection^) DO
              IF pet_entry_p^.physical_descriptor.channel_connection^ [j].downline_element =
                    primary_element.element_name THEN
                IF (upline_element_state = cmc$on) AND (primary_element_state = cmc$on) THEN
                  pet_entry_p^.physical_descriptor.channel_connection^ [j].status := cmc$active;
                ELSE
                  pet_entry_p^.physical_descriptor.channel_connection^ [j].status := cmc$inactive;
                IFEND;
              IFEND;
            FOREND;
          ELSE
          CASEND;
        FOREND /locate_upline_2/;

      = cmc$channel_adapter_element =
        cmp$get_element_state (primary_element.element_name, osc$null_name, primary_element_state, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        upline_connection := primary_element.channel_adapter.connection.channel;
        IF NOT upline_connection.configured THEN
          EXIT /main_program/;
        IFEND;

        IF upline_connection.upline_connection_type <> cmc$data_channel_element THEN
          EXIT /main_program/;
        IFEND;

        IF upline_connection.mainframe_ownership <> mainframe_id THEN
          EXIT /main_program/;
        IFEND;

        cmp$pc_get_element (upline_connection.element_name, upline_connection.iou, upline_element_p, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        cmp$get_element_state (upline_element_p^.element_name, upline_element_p^.data_channel.iou,
              upline_element_state, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        element_descriptor.element_type := upline_element_p^.element_type;
        element_descriptor.channel_descriptor.iou := upline_element_p^.data_channel.iou;
        element_descriptor.channel_descriptor.use_logical_identification := TRUE;
        element_descriptor.channel_descriptor.name := upline_element_p^.element_name;

        cmp$search_peripheral_table (element_descriptor, dummy_reservation, {not_in_configuration} FALSE,
              pet_index, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        pet_entry_p := ^cmv$peripheral_element_table.pointer^ [pet_index];

        FOR j := LOWERBOUND (pet_entry_p^.physical_descriptor.channel_connection^) TO
              UPPERBOUND (pet_entry_p^.physical_descriptor.channel_connection^) DO
          IF pet_entry_p^.physical_descriptor.channel_connection^ [j].downline_element =
                primary_element.element_name THEN
            IF (upline_element_state = cmc$on) AND (primary_element_state = cmc$on) THEN
              pet_entry_p^.physical_descriptor.channel_connection^ [j].status := cmc$active;
            ELSE
              pet_entry_p^.physical_descriptor.channel_connection^ [j].status := cmc$inactive;
            IFEND;
          IFEND;
        FOREND;

        { Change the downline connection status.

        element_descriptor.element_type := primary_element.element_type;
        element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
        element_descriptor.peripheral_descriptor.element_name := primary_element.element_name;

        cmp$search_peripheral_table (element_descriptor, dummy_reservation, {not_in_configuration} FALSE,
              pet_index, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        pet_entry_p := ^cmv$peripheral_element_table.pointer^ [pet_index];

        FOR j := LOWERBOUND (pet_entry_p^.physical_descriptor.equipment_connection^) TO
              UPPERBOUND (pet_entry_p^.physical_descriptor.equipment_connection^) DO
          cmp$get_element_state (pet_entry_p^.physical_descriptor.equipment_connection^ [j].downline_element,
                osc$null_name, downline_element_state, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

          IF (primary_element_state = cmc$on) AND (downline_element_state = cmc$on) THEN
            pet_entry_p^.physical_descriptor.equipment_connection^ [j].status := cmc$active;
          ELSE
            pet_entry_p^.physical_descriptor.equipment_connection^ [j].status := cmc$inactive;
          IFEND;
        FOREND;

      = cmc$communications_element =
        cmp$get_element_state (primary_element.element_name, osc$null_name, primary_element_state, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

      /locate_upline_3/
        FOR i := LOWERBOUND (primary_element.communications_element.connection.port) TO
              UPPERBOUND (primary_element.communications_element.connection.port) DO
          upline_connection := primary_element.communications_element.connection.port [i];
          IF NOT upline_connection.configured THEN
            CYCLE /locate_upline_3/;
          IFEND;

          IF upline_connection.mainframe_ownership <> mainframe_id THEN
            CYCLE /locate_upline_3/;
          IFEND;

          cmp$pc_get_element (upline_connection.element_name, upline_connection.iou, upline_element_p,
                status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

          cmp$get_element_state (upline_element_p^.element_name, upline_element_p^.data_channel.iou,
                upline_element_state, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

          element_descriptor.element_type := upline_element_p^.element_type;
          element_descriptor.channel_descriptor.iou := upline_element_p^.data_channel.iou;
          element_descriptor.channel_descriptor.use_logical_identification := TRUE;
          element_descriptor.channel_descriptor.name := upline_element_p^.element_name;

          cmp$search_peripheral_table (element_descriptor, dummy_reservation, {not_in_configuration} FALSE,
                pet_index, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
          pet_entry_p := ^cmv$peripheral_element_table.pointer^ [pet_index];

          FOR j := LOWERBOUND (pet_entry_p^.physical_descriptor.channel_connection^) TO
                UPPERBOUND (pet_entry_p^.physical_descriptor.channel_connection^) DO
            IF pet_entry_p^.physical_descriptor.channel_connection^ [j].downline_element =
                  primary_element.element_name THEN
              IF (upline_element_state = cmc$on) AND (primary_element_state = cmc$on) THEN
                pet_entry_p^.physical_descriptor.channel_connection^ [j].status := cmc$active;
              ELSE
                pet_entry_p^.physical_descriptor.channel_connection^ [j].status := cmc$inactive;
              IFEND;
            IFEND;
          FOREND;
        FOREND /locate_upline_3/;

      = cmc$external_processor_element =
        cmp$get_element_state (primary_element.element_name, osc$null_name, primary_element_state, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

      /locate_upline_4/
        FOR i := LOWERBOUND (primary_element.external_processor.connection.io_port) TO
              UPPERBOUND (primary_element.external_processor.connection.io_port) DO
          upline_connection := primary_element.external_processor.connection.io_port [i];
          IF NOT upline_connection.configured THEN
            CYCLE /locate_upline_4/;
          IFEND;

          IF upline_connection.mainframe_ownership <> mainframe_id THEN
            CYCLE /locate_upline_4/;
          IFEND;

          cmp$pc_get_element (upline_connection.element_name, upline_connection.iou, upline_element_p,
                status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

          cmp$get_element_state (upline_element_p^.element_name, upline_element_p^.data_channel.iou,
                upline_element_state, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

          element_descriptor.element_type := upline_element_p^.element_type;
          element_descriptor.channel_descriptor.iou := upline_element_p^.data_channel.iou;
          element_descriptor.channel_descriptor.use_logical_identification := TRUE;
          element_descriptor.channel_descriptor.name := upline_element_p^.element_name;

          cmp$search_peripheral_table (element_descriptor, dummy_reservation, {not_in_configuration} FALSE,
                pet_index, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
          pet_entry_p := ^cmv$peripheral_element_table.pointer^ [pet_index];

          FOR j := LOWERBOUND (pet_entry_p^.physical_descriptor.channel_connection^) TO
                UPPERBOUND (pet_entry_p^.physical_descriptor.channel_connection^) DO
            IF pet_entry_p^.physical_descriptor.channel_connection^ [j].downline_element =
                  primary_element.element_name THEN
              IF (upline_element_state = cmc$on) AND (primary_element_state = cmc$on) THEN
                pet_entry_p^.physical_descriptor.channel_connection^ [j].status := cmc$active;
              ELSE
                pet_entry_p^.physical_descriptor.channel_connection^ [j].status := cmc$inactive;
              IFEND;
            IFEND;
          FOREND;
        FOREND /locate_upline_4/;
      ELSE
      CASEND;
    END /main_program/;

    osp$clear_signature_lock (cmv$peripheral_element_table.lock, local_status);
    IF status.normal THEN
      status := local_status;
    IFEND;

  PROCEND cmp$change_connection_status_r1;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$clear_ppit',EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$clear_ppit
    (    channel_name: cmt$element_name;
         iou_name: cmt$element_name;
     VAR status: ost$status);

    VAR
      channel_element_p: ^cmt$element_definition,
      index: iot$pp_number;

    status.normal := TRUE;

    cmp$pc_get_element (channel_name, iou_name, channel_element_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$get_logical_pp_index (channel_element_p^, index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmv$logical_pp_table_p^ [index].pp_info.pp_interface_table_p^.lockword.lock := FALSE;
    cmv$logical_pp_table_p^ [index].pp_info.pp_interface_table_p^.lockword.lock_owner.cpu_lock := FALSE;
    cmv$logical_pp_table_p^ [index].pp_info.pp_interface_table_p^.lockword.lock_owner.fill := 0;
    cmv$logical_pp_table_p^ [index].pp_info.pp_interface_table_p^.lockword.lock_owner.pp_number := 0;
    cmv$logical_pp_table_p^ [index].pp_info.pp_interface_table_p^.pp_request_queue := NIL;
    cmv$logical_pp_table_p^ [index].pp_info.pp_interface_table_p^.pp_request_queue_rma := 0;

  PROCEND cmp$clear_ppit;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$count_con_access_job', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$count_con_access_job
    (    peripheral_index: integer;
     VAR count: integer;
     VAR status: ost$status);

    VAR
      con_access_job_list_p: mst$con_access_job_list;

    status.normal := TRUE;
    count := 0;

    IF cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.access =
          msc$concurrent_access THEN
      con_access_job_list_p :=
            cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.con_access_job_list;
      WHILE con_access_job_list_p <> NIL DO
        count := count + 1;
        con_access_job_list_p := con_access_job_list_p^.forward_link;
      WHILEND;
    IFEND;

  PROCEND cmp$count_con_access_job;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$dedicated_maint_active', EJECT ??

  FUNCTION [XDCL, #GATE] cmp$dedicated_maint_active
    (    table_index: integer): boolean;

    cmp$dedicated_maint_active :=
          (cmv$peripheral_element_table.pointer^ [table_index].maintenance_activity.access =
          msc$dedicated_access);

  FUNCEND cmp$dedicated_maint_active;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$find_state_change_request', EJECT ??

{ PURPOSE:
{   This procedure looks for outstanding state change request.

  PROCEDURE [XDCL, #GATE] cmp$find_state_change_request
    (VAR outstanding_request: boolean;
     VAR element: cmt$element_descriptor;
     VAR new_state: cmt$element_state;
     VAR current_state: cmt$element_state);

    VAR
      index: integer,
      local_status: ost$status;

    outstanding_request := FALSE;

    { Set lock while searching to prevent any request to be queued, or if there is request being queued, wait
    { until lock can be set to make sure we can catch the request.

    osp$set_signature_lock (cmv$peripheral_element_table.lock, osc$wait, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

   /lock_set/
    BEGIN
      FOR index := LOWERBOUND (cmv$peripheral_element_table.pointer^) TO
           UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
        IF cmv$peripheral_element_table.pointer^ [index].physical_descriptor.configured AND
              cmv$peripheral_element_table.pointer^ [index].state_change_request.pending THEN
          element.element_type :=
                cmv$peripheral_element_table.pointer^ [index].physical_descriptor.element_type;
          IF element.element_type = cmc$data_channel_element THEN
            element.channel_descriptor.use_logical_identification := TRUE;
            element.channel_descriptor.name := cmv$peripheral_element_table.pointer^ [index].element_name;
            cmp$convert_iou_number (cmv$peripheral_element_table.pointer^ [index].
                  physical_descriptor.channel_path.iou, element.channel_descriptor.iou, local_status);
          ELSE
            element.peripheral_descriptor.use_logical_identification := TRUE;
            element.peripheral_descriptor.element_name :=
                  cmv$peripheral_element_table.pointer^ [index].element_name;
          IFEND;
          new_state := cmv$peripheral_element_table.pointer^ [index].state_change_request.new_state;
          current_state := cmv$peripheral_element_table.pointer^ [index].element_status.state;
          outstanding_request := TRUE;
          EXIT /lock_set/;
        IFEND;
      FOREND;
    END /lock_set/;

    osp$clear_signature_lock (cmv$peripheral_element_table.lock, local_status);

  PROCEND cmp$find_state_change_request;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_element_entry_via_adr', EJECT ??

{ PURPOSE:
{   This procedure provides an interface to call the interface cmp$locate_element_via_adr in module
{   cmm$monitor_job_mode_interfaces which cannot be gated.

  PROCEDURE [XDCL, #GATE] cmp$get_element_entry_via_adr
    (    physical_address: cmt$physical_address;
     VAR entry_p: ^cmt$peripheral_element_entry);

    VAR
      element_p: ^cmt$peripheral_element_entry;

    entry_p := NIL;
    cmp$locate_element_via_adr (physical_address, element_p);
    IF element_p <> NIL THEN
      entry_p := element_p;
    IFEND;

  PROCEND cmp$get_element_entry_via_adr;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_element_entry_via_lun', EJECT ??

{ PURPOSE:
{   This procedure provides an interface to call the interface cmp$locate_element_via_lun in module
{   cmm$monitor_job_mode_interfaces which cannot be gated.

  PROCEDURE [XDCL, #GATE] cmp$get_element_entry_via_lun
    (    logical_unit: iot$logical_unit;
     VAR entry_p: ^cmt$peripheral_element_entry);

    VAR
      element_p: ^cmt$peripheral_element_entry;

    entry_p := NIL;
    cmp$locate_element_via_lun (logical_unit, element_p);
    IF element_p <> NIL THEN
      entry_p := element_p;
    IFEND;

  PROCEND cmp$get_element_entry_via_lun;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_element_entry_via_name', EJECT ??

{ PURPOSE:
{   This procedure provides an interface to call the interface cmp$locate_element_via_name in module
{   cmm$monitor_job_mode_interfaces which cannot be gated.  The iou_number parameter is only used when
{   the element is a data channel element.

  PROCEDURE [XDCL, #GATE] cmp$get_element_entry_via_name
    (    element_name: cmt$element_name;
         iou_number: dst$iou_number;
     VAR entry_p: ^cmt$peripheral_element_entry);

    VAR
      element_p: ^cmt$peripheral_element_entry;

    entry_p := NIL;
    cmp$locate_element_via_name (element_name, iou_number, element_p);
    IF element_p <> NIL THEN
      entry_p := element_p;
    IFEND;

  PROCEND cmp$get_element_entry_via_name;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_mass_storage_info',EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_mass_storage_info
    (    logical_unit: iot$logical_unit;
     VAR mass_storage: cmt$mass_storage_information;
     VAR status: ost$status);

    VAR
      active_path: boolean,
      cio_count: integer,
      equipment_number: cmt$physical_equipment_number,
      first_lun: iot$logical_unit,
      index: integer,
      iou_array_index: dst$number_of_ious,
      iou_information_table: dst$iou_information_table,
      iou_model_type: dst$iou_model_types,
      last_lun: iot$logical_unit,
      lun: iot$logical_unit,
      number_of_ious: dst$number_of_ious,
      physical_path: iot$physical_path;

    status.normal := TRUE;

    IF cmv$iou_table_p = NIL THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_nil_cm_table,
            'IOU Table not built', status);
      RETURN;
    IFEND;
    IF cmv$logical_unit_table = NIL THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$it_nil_lut,
            'Logical Unit Table not built.', status);
      RETURN;
    IFEND;
    IF cmv$logical_pp_table_p = NIL THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$it_nil_lpt, 'Logical PP Table not built.',
            status);
      RETURN;
    IFEND;

    IF NOT cmv$logical_unit_table^ [logical_unit].configured OR
          (cmv$logical_unit_table^ [logical_unit].unit_interface_table = NIL) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$it_unconfigured_lun, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, logical_unit, 10, TRUE, status);
      RETURN;
    IFEND;

   /search_unit_type/
    BEGIN
      FOR index := 1 TO UPPERBOUND (cmv$product_id_ptr^) DO
        IF cmv$product_id_ptr^ [index].io_unit_type =
              cmv$logical_unit_table^ [logical_unit].unit_interface_table^.unit_type THEN
          IF cmv$product_id_ptr^ [index].cm_unit_type < cmc$ms844_4x THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$it_not_mass_storage,
                  'Logical Unit is not a Mass storage.', status);
            RETURN;
          IFEND;
          mass_storage.unit_type := cmv$product_id_ptr^ [index].cm_unit_type;
          EXIT /search_unit_type/;
        IFEND;
      FOREND ;
      osp$set_status_abnormal (cmc$configuration_management_id, cme$it_unknown_unit_type,
            'Unable to determine unit type.', status);
      RETURN;
    END /search_unit_type/;

    cio_count := 0;
    dsp$retrieve_iou_information (number_of_ious, iou_information_table);

   /pp_table_loop/
    FOR index := 1 TO UPPERBOUND (cmv$logical_pp_table_p^) DO
      IF NOT cmv$logical_pp_table_p^ [index].flags.configured OR
            (cmv$logical_pp_table_p^ [index].pp_info.pp_interface_table_p = NIL) THEN
        CYCLE /pp_table_loop/;
      IFEND;
      first_lun := cmv$logical_pp_table_p^ [index].pp_info.pp_interface_table_p^.first_logical_unit;
      last_lun := cmv$logical_pp_table_p^ [index].pp_info.pp_interface_table_p^.number_of_units +
            cmv$logical_pp_table_p^ [index].pp_info.pp_interface_table_p^.first_logical_unit - 1;
      IF (logical_unit < first_lun) OR (logical_unit > last_lun) THEN
        CYCLE /pp_table_loop/;
      IFEND;

     /search_lun/
      FOR lun := first_lun TO last_lun DO
        IF (logical_unit <> lun) OR
              (cmv$logical_pp_table_p^ [index].pp_info.pp_interface_table_p^.
              unit_descriptors [logical_unit].unit_interface_table_rma = 0) THEN
          CYCLE /search_lun/;
        IFEND;
        physical_path := cmv$logical_pp_table_p^ [index].pp_info.pp_interface_table_p^.
              unit_descriptors [logical_unit].physical_path;
        mass_storage.iou_number := cmv$logical_pp_table_p^ [index].pp_info.channel.iou_number;
        mass_storage.channel.number := physical_path.channel_number;
        mass_storage.unit_number := physical_path.physical_unit_number;
        mass_storage.channel.concurrent := cmv$logical_pp_table_p^ [index].pp_info.channel_interlock_p^.
              channel_characteristics [mass_storage.channel.number].concurrent_channel;
        mass_storage.channel.port := cmc$unspecified_port;

        CASE mass_storage.unit_type OF
        = cmc$ms844_4x, cmc$ms885_1x, cmc$ms885_4x =
          equipment_number := physical_path.controller_number;
        = cmc$ms895_2 =
          IF physical_path.storage_directory_address > 1 THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$it_not_cip_device,
                  'Logical unit is potentially not a CIP device', status);
            RETURN;
          IFEND;
          mass_storage.storage_director_address := physical_path.storage_directory_address;
          IF physical_path.physical_unit_number > 1000(16) THEN
            mass_storage.head_of_string_controller := 1;
            mass_storage.unit_number := physical_path.physical_unit_number - 1000(16);
          ELSE
            mass_storage.head_of_string_controller := 0;
          IFEND;
        = cmc$ms834_2, cmc$msfsd_2 ,cmc$msfsd2_s0, cmc$msxmd_3, cmc$ms5832_1, cmc$ms5832_2, cmc$ms5833_1,
              cmc$ms5833_1p, cmc$ms5833_2, cmc$ms5833_3p, cmc$ms5833_4, cmc$ms5838_1, cmc$ms5838_1p,
              cmc$ms5838_2, cmc$ms5838_3p, cmc$ms5838_4, cmc$ms47444_1, cmc$ms47444_1p, cmc$ms47444_2,
              cmc$ms47444_3p, cmc$ms47444_4 =
          mass_storage.control_module := physical_path.controller_number;
          IF mass_storage.channel.concurrent THEN
            osp$set_status_condition (cme$it_no_cip_access, status);
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal (cmc$configuration_management_id, cme$it_not_cip_device,
                'Logical unit is potentially not a CIP device', status);
          RETURN;
        CASEND;

        { If the current channel is concurrent then:
        {    * If running on I4C or I4CE then do not search for CIP presence
        {    * If running on I4A then, keep searching for a NIO channel.

        IF mass_storage.channel.concurrent THEN
          IF NOT cmv$logical_pp_table_p^ [index].pp_info.pp_communication_buffer_p^.slave THEN
            cio_count := cio_count + 1;
          IFEND;

         /find_iou_model/
          FOR iou_array_index := LOWERBOUND (iou_information_table) TO
                UPPERBOUND (iou_information_table) DO
            IF iou_information_table [iou_array_index].physical_iou_number = mass_storage.iou_number THEN
              iou_model_type := iou_information_table [iou_array_index].model_type;
              EXIT /find_iou_model/;
            IFEND;
          FOREND /find_iou_model/;

          CASE iou_model_type OF
          = dsc$imn_i4_44_model, dsc$imn_i4_46_model =
            osp$set_status_condition (cme$it_no_cip_access, status);
            RETURN;
          = dsc$imn_i4_40_model, dsc$imn_i4_42_model =
            CYCLE /pp_table_loop/;
          ELSE
          CASEND;
        IFEND;

        IF logical_unit <> cmc$job_template_unit_ordinal THEN
          check_active_path (equipment_number, mass_storage, active_path);
          IF NOT active_path THEN
            CYCLE /pp_table_loop/;
          IFEND;
        IFEND;
        RETURN;
      FOREND /search_lun/;
    FOREND /pp_table_loop/;

    IF cio_count = 1 THEN
      osp$set_status_condition (cme$it_unusable_cip_access, status);
    ELSE
      osp$set_status_condition (cme$it_no_cip_access, status);
    IFEND;

  PROCEND cmp$get_mass_storage_info;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_next_request ', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_next_request
    (    element_name: cmt$element_name;
     VAR next_request_p: ^iot$io_request;
     VAR status: ost$status);

    VAR
      logical_unit_number: iot$logical_unit;

    cmp$get_logical_unit_number (element_name, logical_unit_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    next_request_p := cmv$logical_unit_table^ [logical_unit_number].unit_interface_table^.next_request;

  PROCEND cmp$get_next_request;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_pp_table_rma',EJECT ??

{ PURPOSE:
{   This procedure returns the Real Memory Address of the PP interface table of the give channel definition.

  PROCEDURE [XDCL, #GATE] cmp$get_pp_table_rma
    (    element: cmt$element_definition;
     VAR pp_table_rma: ost$real_memory_address;
     VAR status: ost$status);

    VAR
      pp_index: iot$pp_number;

    status.normal := TRUE;
    cmp$get_logical_pp_index (element, pp_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pp_table_rma := cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_rma;

  PROCEND cmp$get_pp_table_rma;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_reservation_info', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_reservation_info
    (    table_index: integer;
     VAR reservable_element: boolean;
     VAR reserved_to_job: boolean;
     VAR reserving_job: jmt$system_supplied_name);

    reservable_element :=
          ((cmv$peripheral_element_table.pointer^ [table_index].reservable_element = cmc$reservable) OR
          (cmv$peripheral_element_table.pointer^ [table_index].reservable_element =
          cmc$reservable_only_by_system));
    reserved_to_job := cmv$peripheral_element_table.pointer^ [table_index].entry_interlock;
    reserving_job := cmv$peripheral_element_table.pointer^ [table_index].reserved_job;

  PROCEND cmp$get_reservation_info;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$mark_element_reserved', EJECT ??

{ PURPOSE:
{   This procedure marks an element as being reserved to a job via cmp$reserve_element.

  PROCEDURE [XDCL, #GATE] cmp$mark_element_reserved
    (    element_reservation: cmt$element_reservation;
         reserved_by_system: boolean;
         job_name: jmt$system_supplied_name;
         gtid: ost$global_task_id;
         physical_pp: dst$iou_resource;
         table_index: integer;
         channel_present: boolean;
     VAR status: ost$status);

    VAR
      channel: cmt$physical_channel,
      channel_address: cmt$physical_equipment_number,
      channel_name: cmt$element_name,
      channel_number: ost$physical_channel_number,
      channel_port: cmt$channel_port,
      concurrent: boolean,
      iou_number: dst$iou_number,
      lock_status: ost$status,
      physical_id: cmt$physical_identification,
      temp_element_descriptor: cmt$element_descriptor,
      unit_address: cmt$physical_unit_number;

    status.normal := TRUE;

    cmp$crack_physical_address (element_reservation, iou_number, channel, channel_address, unit_address,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$set_signature_lock (cmv$peripheral_element_table.lock, osc$wait, lock_status);
    IF NOT lock_status.normal THEN
      RETURN;
    IFEND;

  /main_program/
    BEGIN
      IF NOT cmv$peripheral_element_table.pointer^ [table_index].entry_interlock THEN
        cmv$peripheral_element_table.pointer^ [table_index].entry_interlock := TRUE;
        cmv$peripheral_element_table.pointer^ [table_index].gtid.index := gtid.index;
        cmv$peripheral_element_table.pointer^ [table_index].gtid.seqno := gtid.seqno;
        cmv$peripheral_element_table.pointer^ [table_index].reserved_status := TRUE;
        cmv$peripheral_element_table.pointer^ [table_index].reserved_by_system := reserved_by_system;
        cmv$peripheral_element_table.pointer^ [table_index].reserved_job := job_name;
        IF NOT cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.configured THEN
          CASE element_reservation.element_type OF
          = cmc$data_channel_element =
            cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.iou :=
                  iou_number;
            IF element_reservation.channel_descriptor.use_logical_identification THEN
              cmv$peripheral_element_table.pointer^ [table_index].element_name :=
                    element_reservation.channel_descriptor.name;
            ELSE

              { Always store the element name for channel, even though reservation is by physical address.

              cmp$convert_channel_ordinal (element_reservation.channel_descriptor.channel_ordinal,
                    channel_name, channel_number, concurrent, channel_port, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              cmv$peripheral_element_table.pointer^ [table_index].element_name := channel_name;
            IFEND;
            cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
                  address_specifier := $cmt$physical_address_specifier [cmc$iou, cmc$channel];
            cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.iou :=
                  iou_number;
            cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
                  channel := channel;
          = cmc$controller_element, cmc$storage_device_element, cmc$communications_element,
                cmc$channel_adapter_element, cmc$external_processor_element =
            IF element_reservation.peripheral_descriptor.use_logical_identification THEN
              cmv$peripheral_element_table.pointer^ [table_index].element_name :=
                    element_reservation.peripheral_descriptor.element_name;
            ELSE
              IF element_reservation.element_type <> cmc$storage_device_element THEN
                cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
                      address_specifier :=
                      $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address];
              ELSE
                cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
                      address_specifier :=
                      $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address,
                      cmc$unit_address];
              IFEND;
              cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
                    iou := iou_number;
              cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
                    channel := channel;
              cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
                    channel_address := channel_address;
              cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
                    unit_address := unit_address;
            IFEND;
          CASEND;
        IFEND;
      ELSE
        temp_element_descriptor.element_type := element_reservation.element_type;
        CASE temp_element_descriptor.element_type OF
        = cmc$data_channel_element =
          temp_element_descriptor.channel_descriptor := element_reservation.channel_descriptor;
        = cmc$controller_element, cmc$external_processor_element, cmc$channel_adapter_element,
              cmc$storage_device_element, cmc$communications_element =
          temp_element_descriptor.peripheral_descriptor := element_reservation.peripheral_descriptor;
        ELSE
        CASEND;
        cmp$format_error_message (temp_element_descriptor, {not used} physical_id, FALSE,
              cme$element_already_reserved, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              cmv$peripheral_element_table.pointer^ [table_index].reserved_job, status);
      IFEND;
    END /main_program/;

    osp$clear_signature_lock (cmv$peripheral_element_table.lock, lock_status);

  PROCEND cmp$mark_element_reserved;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$mark_pp_element_reserved', EJECT ??

{ PURPOSE:
{   This procedure marks a PP element in the Logical PP Table as being reserved to a job via
{   cmp$reserve_element.



  PROCEDURE [XDCL, #GATE] cmp$mark_pp_element_reserved
    (    element_reservation: cmt$element_reservation;
         reserved_by_system: boolean;
         job_name: jmt$system_supplied_name;
         gtid: ost$global_task_id;
         physical_pp: dst$iou_resource;
         channel_present: boolean;
     VAR pp_index: iot$pp_number;
     VAR status: ost$status);

    VAR
      cmv$free_trap: [XREF] boolean,
      channel: cmt$physical_channel,
      channel_address: cmt$physical_equipment_number,
      found: boolean,
      iou_number: dst$iou_number,
      local_status: ost$status,
      unit_address: cmt$physical_unit_number;

    status.normal := TRUE;

    { Check to see if requested PP is already reserved.

    cmp$search_pp_table (physical_pp, pp_index, found, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF found THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$element_already_reserved,
            'Requested PP', status);
      IF cmv$logical_pp_table_p^ [pp_index].flags.entry_reserved_by_nosve THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'NOS/VE', status);
      ELSE
        IF cmv$logical_pp_table_p^ [pp_index].task_info.reserved_job_name = job_name THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'this job', status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter,
                cmv$logical_pp_table_p^ [pp_index].task_info.reserved_job_name, status);
        IFEND;
      IFEND;
      RETURN;
    IFEND;

    cmp$crack_physical_address (element_reservation, iou_number, channel, channel_address, unit_address,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$set_signature_lock (cmv$logical_pp_table_lock, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$zero_out_table (#LOC (cmv$logical_pp_table_p^ [pp_index]),
          #SIZE (cmv$logical_pp_table_p^ [pp_index]));
    cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p := NIL;
    cmv$logical_pp_table_p^ [pp_index].pp_info.pp_communication_buffer_p := NIL;
    cmv$logical_pp_table_p^ [pp_index].pp_info.channel_interlock_p := NIL;
    cmv$logical_pp_table_p^ [pp_index].pp_info.driver_code_p := NIL;
    cmv$logical_pp_table_p^ [pp_index].pp_info.saved_io_request_p := NIL;
    cmv$logical_pp_table_p^ [pp_index].handlers.response_handler_p := NIL;
    cmv$logical_pp_table_p^ [pp_index].handlers.one_word_response_handler_p := NIL;

    cmv$logical_pp_table_p^ [pp_index].flags.entry_in_use := TRUE;
    cmv$logical_pp_table_p^ [pp_index].flags.entry_reserved_by_other := TRUE;
    cmv$logical_pp_table_p^ [pp_index].flags.entry_reserved_by_system_job := reserved_by_system;
    cmv$logical_pp_table_p^ [pp_index].flags.reservd_by_other_has_ch_present := channel_present;
    cmv$logical_pp_table_p^ [pp_index].task_info.gtid.index := gtid.index;
    cmv$logical_pp_table_p^ [pp_index].task_info.gtid.seqno := gtid.seqno;
    cmv$logical_pp_table_p^ [pp_index].task_info.reserved_job_name := job_name;
    cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp := physical_pp;
    cmv$logical_pp_table_p^ [pp_index].flags.resources_acquired := TRUE;
    cmv$logical_pp_table_p^ [pp_index].pp_info.driver_name := ' ';
    cmv$logical_pp_table_p^ [pp_index].pp_info.cip_driver_name := ' ';
    cmv$logical_pp_table_p^ [pp_index].pp_info.channel.iou_number := iou_number;
    IF cmv$logical_pp_table_p^ [pp_index].flags.reservd_by_other_has_ch_present THEN
      IF channel.concurrent THEN
        cmv$logical_pp_table_p^ [pp_index].pp_info.channel.channel_protocol := dsc$cpt_cio;
      ELSE
        cmv$logical_pp_table_p^ [pp_index].pp_info.channel.channel_protocol := dsc$cpt_nio;
      IFEND;
      cmv$logical_pp_table_p^ [pp_index].pp_info.channel.number := channel.number;
      cmv$logical_pp_table_p^ [pp_index].pp_info.channel_port := channel.port;
      update_ch_connection_status (pp_index);
    ELSE
      cmv$logical_pp_table_p^ [pp_index].pp_info.channel.channel_protocol := dsc$cpt_nio;
      cmv$logical_pp_table_p^ [pp_index].pp_info.channel.number := 15;
      cmv$logical_pp_table_p^ [pp_index].pp_info.channel_port := cmc$unspecified_port;
    IFEND;
    cmv$logical_pp_table_p^ [pp_index].controller_info.controller_type := cmc$null_controller;
    osp$clear_signature_lock (cmv$logical_pp_table_lock, local_status);
  PROCEND cmp$mark_pp_element_reserved;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$queue_state_change', EJECT ??

{ PURPOSE:
{   This procedure queues a state change request initiated from NOS/VE.
{ This is done when multiple state change requests were occuring.

  PROCEDURE [XDCL, #GATE] cmp$queue_state_change
    (    element: cmt$element_descriptor;
         state_change_request: cmt$state_change_request;
     VAR status: ost$status);

    VAR
      element_reservation: cmt$element_reservation,
      table_index: integer;

    status.normal := TRUE;
    cmp$search_peripheral_table (element, element_reservation, {not_in_configuration=} FALSE,
         table_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$set_signature_lock (cmv$peripheral_element_table.lock, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT cmv$peripheral_element_table.pointer^ [table_index].state_change_request.pending THEN
      cmv$peripheral_element_table.pointer^ [table_index].state_change_request := state_change_request;
    IFEND;

    osp$clear_signature_lock (cmv$peripheral_element_table.lock, status);

  PROCEND cmp$queue_state_change;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$return_lun_info', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$return_lun_info
    (    logical_unit: iot$logical_unit;
     VAR assigned_to_job: boolean;
     VAR assigned_job_id: jmt$system_supplied_name);

    assigned_to_job := cmv$logical_unit_table^ [logical_unit].status.assigned;
    assigned_job_id := cmv$logical_unit_table^ [logical_unit].status.assigned_jsn;

  PROCEND cmp$return_lun_info;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$search_pp_table', EJECT ??

{ PURPOSE:
{   Search the Logical PP Table for the given physical pp value.  If the PP is not found then the index to
{   the next available slot in the table is returned.

  PROCEDURE [XDCL, #GATE] cmp$search_pp_table
    (    physical_pp: dst$iou_resource;
     VAR logical_pp_index: iot$pp_number;
     VAR found: boolean;
     VAR status: ost$status);

    VAR
      pp_index: iot$pp_number;

    status.normal := TRUE;
    found := FALSE;

    IF cmv$logical_pp_table_p = NIL THEN
      osp$set_status_condition (cme$cm_table_empty, status);
      RETURN;
    IFEND;

    FOR pp_index := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
      IF cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp = physical_pp THEN
        found := TRUE;
        logical_pp_index := pp_index;
        RETURN;
      IFEND;
    FOREND;

    FOR pp_index := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
      IF (cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp.number = 33(8)) AND
            NOT cmv$logical_pp_table_p^ [pp_index].flags.entry_in_use THEN
        logical_pp_index := pp_index;
        RETURN;
      IFEND;
    FOREND;
    osp$set_status_condition (cme$no_logical_pp_available, status);

  PROCEND cmp$search_pp_table;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$state_change_pending', EJECT ??

{ PURPOSE:
{   This functions determines whether or not a state change request
{   already queued for the given element.

  FUNCTION [XDCL, #GATE, UNSAFE] cmp$state_change_pending
    (element: cmt$element_descriptor): BOOLEAN;

    VAR
      element_reservation: cmt$element_reservation,
      index: integer,
      local_status: ost$status;

    cmp$state_change_pending := FALSE;
    cmp$search_peripheral_table (element, element_reservation, {not_in_configuration=} FALSE, index,
          local_status);
    IF local_status.normal THEN
      cmp$state_change_pending := cmv$peripheral_element_table.pointer^ [index].state_change_request.pending;
    IFEND;

  FUNCEND cmp$state_change_pending;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$store_file_server_info', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$store_file_server_info
    (    pp_index: iot$pp_number;
         next_request_p: ^iot$io_request;
         one_word_response_allowed: boolean;
         one_word_response_processor: dft$one_word_response_handler;
     VAR status: ost$status);

    VAR
      next_request_rma: integer,
      unit: iot$logical_unit;

    status.normal := TRUE;
    IF (pp_index > UPPERBOUND (cmv$logical_pp_table_p^)) OR
          (pp_index < LOWERBOUND (cmv$logical_pp_table_p^)) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_nil_cm_table,
            'Invalid pp index detected in cmp$store_file_server_info', status);
      RETURN;
    IFEND;

    IF cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p = NIL THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_nil_cm_table,
            ' NIL pp_interface_table_p detected in cmp$store_file_server_info', status);
      RETURN;
    IFEND;

    IF cmv$logical_pp_table_p^ [pp_index].controller_info.controller_type <> cmc$fs740_200 THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_nil_cm_table,
            ' One word response only allowed for file server PP.', status);
      RETURN;
    IFEND;

    FOR unit :=
          LOWERBOUND (cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.unit_descriptors) TO
          UPPERBOUND (cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.unit_descriptors) DO
      IF cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.unit_descriptors [unit].
            unit_interface_table <> NIL THEN
        cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.unit_descriptors [unit].
              unit_interface_table^.next_request := next_request_p;
        i#real_memory_address (#LOC (next_request_p^), next_request_rma);
        cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.unit_descriptors [unit].
              unit_interface_table^.next_request_rma := next_request_rma;

        cmv$logical_pp_table_p^ [pp_index].handlers.one_word_response_allowed := one_word_response_allowed;
        IF one_word_response_allowed THEN
          cmv$logical_pp_table_p^ [pp_index].handlers.one_word_response_handler_p :=
                one_word_response_processor;
        IFEND;
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_nil_cm_table,
          'NIL unit interface table detected in cmp$store_file_server_info', status);

  PROCEND cmp$store_file_server_info;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$store_one_word_response_ptr ', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$store_one_word_response_ptr
    (    pp_index: iot$pp_number;
         one_word_response_processor: dft$one_word_response_handler;
     VAR status: ost$status);

    VAR
      unit: iot$logical_unit;

    status.normal := TRUE;
    IF (pp_index > UPPERBOUND (cmv$logical_pp_table_p^)) OR
          (pp_index < LOWERBOUND (cmv$logical_pp_table_p^)) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_nil_cm_table,
            'Invalid pp index detected in cmp$store_one_word_response_ptr', status);
      RETURN;
    IFEND;

    IF cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p = NIL THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_nil_cm_table,
            ' NIL pp_interface_table_p detected in cmp$store_one_word_response_ptr', status);
      RETURN;
    IFEND;

    cmv$logical_pp_table_p^ [pp_index].handlers.one_word_response_allowed := TRUE;
    cmv$logical_pp_table_p^ [pp_index].handlers.one_word_response_handler_p := one_word_response_processor;

  PROCEND cmp$store_one_word_response_ptr;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$unmark_element_reserved', EJECT ??

{ PURPOSE:
{   This procedure unmark an element as a result of cmp$release_element

  PROCEDURE [XDCL, #GATE] cmp$unmark_element_reserved
    (    element_reservation: cmt$element_reservation;
         job_name: jmt$system_supplied_name;
         system_caller: boolean;
         table_index: integer;
     VAR status: ost$status);

    VAR
      lock_status: ost$status,
      physical_id: cmt$physical_identification,
      temp_element_descriptor: cmt$element_descriptor;

    status.normal := TRUE;

    osp$set_signature_lock (cmv$peripheral_element_table.lock, osc$wait, lock_status);
    IF NOT lock_status.normal THEN
      RETURN;
    IFEND;

  /main_program/
    BEGIN
      IF cmv$peripheral_element_table.pointer^ [table_index].entry_interlock THEN
        IF (cmv$peripheral_element_table.pointer^ [table_index].reserved_job = job_name) OR
              (system_caller AND cmv$peripheral_element_table.pointer^ [table_index].reserved_by_system) THEN
          cmv$peripheral_element_table.pointer^ [table_index].gtid.index := 4095;
          cmv$peripheral_element_table.pointer^ [table_index].gtid.seqno := 255;
          cmv$peripheral_element_table.pointer^ [table_index].entry_interlock := FALSE;
          cmv$peripheral_element_table.pointer^ [table_index].reserved_status := FALSE;
          cmv$peripheral_element_table.pointer^ [table_index].reserved_by_system := FALSE;
          cmv$peripheral_element_table.pointer^ [table_index].reserved_job := '';
          IF NOT cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.configured THEN
            cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.iou := 0;
            cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
                  channel.number := 0;
            cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
                  channel.concurrent := FALSE;
            cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
                  channel.port := cmc$unspecified_port;
            cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
                  channel_address := 7;
            cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
                  unit_address := 63;
            cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
                  address_specifier := $cmt$physical_address_specifier [];
            cmv$peripheral_element_table.pointer^ [table_index].element_name := ' ';
          IFEND;
        ELSE
          temp_element_descriptor.element_type := element_reservation.element_type;
          CASE temp_element_descriptor.element_type OF
          = cmc$data_channel_element =
            temp_element_descriptor.channel_descriptor := element_reservation.channel_descriptor;
          = cmc$controller_element, cmc$external_processor_element, cmc$channel_adapter_element,
                cmc$storage_device_element, cmc$communications_element =
            temp_element_descriptor.peripheral_descriptor := element_reservation.peripheral_descriptor;
          ELSE
          CASEND;
          cmp$format_error_message (temp_element_descriptor, {not used} physical_id, FALSE,
                cme$element_already_reserved, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                cmv$peripheral_element_table.pointer^ [table_index].reserved_job, status);
          EXIT /main_program/;
        IFEND;
      ELSE
        temp_element_descriptor.element_type := element_reservation.element_type;
        CASE temp_element_descriptor.element_type OF
        = cmc$data_channel_element =
          temp_element_descriptor.channel_descriptor := element_reservation.channel_descriptor;
        = cmc$controller_element, cmc$external_processor_element, cmc$channel_adapter_element,
              cmc$storage_device_element, cmc$communications_element =
          temp_element_descriptor.peripheral_descriptor := element_reservation.peripheral_descriptor;
        ELSE
        CASEND;
        cmp$format_error_message (temp_element_descriptor, {not used} physical_id, FALSE,
              cme$element_not_reserved, status);
        EXIT /main_program/;
      IFEND;
    END /main_program/;

    osp$clear_signature_lock (cmv$peripheral_element_table.lock, lock_status);

  PROCEND cmp$unmark_element_reserved;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$unmark_pp_element_reserved', EJECT ??

{ PURPOSE:
{   This procedure unmarks an element in the logical PP table as a result of cmp$release_element.

  PROCEDURE [XDCL, #GATE] cmp$unmark_pp_element_reserved
    (    job_name: jmt$system_supplied_name;
         system_caller: boolean;
         table_index: integer;
     VAR status: ost$status);

    VAR
      len: integer,
      local_status: ost$status,
      pp_number: string (11);

    status.normal := TRUE;

    osp$set_signature_lock (cmv$logical_pp_table_lock, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

   /pp_table_lock_set/
    BEGIN
      IF cmv$logical_pp_table_p^ [table_index].pp_info.physical_pp.channel_protocol = dsc$cpt_cio THEN
        STRINGREP (pp_number, len, 'IOU',
              cmv$logical_pp_table_p^ [table_index].pp_info.physical_pp.iou_number: 2,
              ' CPP', cmv$logical_pp_table_p^ [table_index].pp_info.physical_pp.number: 2);
      ELSE
        STRINGREP (pp_number, len, 'IOU',
              cmv$logical_pp_table_p^ [table_index].pp_info.physical_pp.iou_number: 2,
              '  PP', cmv$logical_pp_table_p^ [table_index].pp_info.physical_pp.number: 3);
      IFEND;

      IF NOT cmv$logical_pp_table_p^ [table_index].flags.entry_in_use THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$element_not_reserved,
              pp_number (1, len), status);
        EXIT /pp_table_lock_set/;
      IFEND;

      IF cmv$logical_pp_table_p^ [table_index].flags.entry_reserved_by_nosve THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$element_already_reserved,
              pp_number (1, len), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'NOS/VE', status);
        EXIT /pp_table_lock_set/;
      IFEND;

      IF (cmv$logical_pp_table_p^ [table_index].task_info.reserved_job_name <> job_name) AND
            NOT (system_caller AND
            cmv$logical_pp_table_p^ [table_index].flags.entry_reserved_by_system_job) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$element_already_reserved,
              pp_number (1, len), status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              cmv$logical_pp_table_p^ [table_index].task_info.reserved_job_name, status);
        EXIT /pp_table_lock_set/;
      IFEND;

      unmark_pp_element (table_index, FALSE);
    END /pp_table_lock_set/;

    osp$clear_signature_lock (cmv$logical_pp_table_lock, local_status);

  PROCEND cmp$unmark_pp_element_reserved;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$unmark_pp_when_cleanup', EJECT ??

{ PURPOSE:
{   This procedure cleans up all element entries reserved as a result of task termination clean up.

  PROCEDURE [XDCL, #GATE] cmp$unmark_pp_when_cleanup
    (    table_index: integer;
     VAR status: ost$status);

    VAR
      lock_status: ost$status;

    status.normal := TRUE;

    osp$set_signature_lock (cmv$logical_pp_table_lock, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    unmark_pp_element (table_index, TRUE);
    osp$clear_signature_lock (cmv$logical_pp_table_lock, lock_status);

  PROCEND cmp$unmark_pp_when_cleanup;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$unmark_when_cleanup', EJECT ??

{ PURPOSE:
{   This procedure cleans up all element entries reserved as a result of task termination clean up.

  PROCEDURE [XDCL, #GATE] cmp$unmark_when_cleanup
    (    table_index: integer;
         mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      lock_status: ost$status,
      pc_index_1: integer;

    status.normal := TRUE;

    osp$set_signature_lock (cmv$peripheral_element_table.lock, osc$wait, lock_status);
    IF NOT lock_status.normal THEN
      RETURN;
    IFEND;

  /main_program/
    BEGIN
      cmv$peripheral_element_table.pointer^ [table_index].gtid.index := 4095;
      cmv$peripheral_element_table.pointer^ [table_index].gtid.seqno := 255;
      cmv$peripheral_element_table.pointer^ [table_index].entry_interlock := FALSE;
      cmv$peripheral_element_table.pointer^ [table_index].reserved_status := FALSE;
      cmv$peripheral_element_table.pointer^ [table_index].reserved_job := '';
      IF NOT cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.configured THEN
        cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.iou := 0;
        cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
              channel.number := 0;
        cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
              channel.concurrent := FALSE;
        cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
              channel.port := cmc$unspecified_port;
        cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
              channel_address := 7;
        cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
              unit_address := 63;
        cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.hardware_address.
              address_specifier := $cmt$physical_address_specifier [];
        cmv$peripheral_element_table.pointer^ [table_index].element_name := ' ';
      IFEND;

      IF cmv$peripheral_element_table.pointer^ [table_index].maintenance_activity.access =
            msc$dedicated_access THEN
        cmv$peripheral_element_table.pointer^ [table_index].maintenance_activity.
              dedicated_accessor.job_identification := ' ';
        cmv$peripheral_element_table.pointer^ [table_index].maintenance_activity.
              dedicated_accessor.active := FALSE;
        cmv$peripheral_element_table.pointer^ [table_index].maintenance_activity.
              access := msc$concurrent_access;
        cmv$peripheral_element_table.pointer^ [table_index].maintenance_activity.con_access_job_list := NIL;

        { Check to see if the element is in the active physical configuration having multiple channels
        { connections.  If so, release all additional channels to the real state system }

       /pc_loop_1/
        FOR pc_index_1 := 1 TO UPPERBOUND (cmv$physical_configuration^) DO
          IF (cmv$physical_configuration^ [pc_index_1].element_type =
                cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.element_type) AND
                (cmv$physical_configuration^ [pc_index_1].element_name =
                cmv$peripheral_element_table.pointer^ [table_index].element_name) THEN

            { Release all channels connected to controller to the real state system }

            cmp$request_channels (dsc$rrt_return_channel, cmv$physical_configuration^ [pc_index_1],
                  mainframe_id, status);
            IF NOT status.normal THEN
              EXIT /main_program /;
            IFEND;
            EXIT /pc_loop_1/;
          IFEND;
        FOREND /pc_loop_1/;
      IFEND;
    END /main_program/;

    osp$clear_signature_lock (cmv$peripheral_element_table.lock, lock_status);
    IF NOT lock_status.normal AND status.normal THEN
      status := lock_status;
    IFEND;

  PROCEND cmp$unmark_when_cleanup;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$update_connection_states_r1 ', EJECT ??

{ PURPOSE:
{   This procedure will go through the entire physical_configuration and update the connection_status for all
{   elements based entirely on the states of the elements.
{
{ NOTE:
{   If this procedure is executed after an automatic reconfiguration has occurred any DISABLED connection will
{   be set to ACTIVE.

  PROCEDURE [XDCL, #GATE] cmp$update_connection_states_r1
    (    mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      active_connection: boolean,
      channel_element_p: ^cmt$element_definition,
      channel_name: cmt$element_name,
      check_redundant_path: boolean,
      controller_element_p: ^cmt$element_definition,
      controller_number: cmt$physical_equipment_number,
      controller_type: cmt$controller_type,
      downline_element_p: ^cmt$element_definition,
      downline_element_state: cmt$element_state,
      i: integer,
      iou_name: cmt$element_name,
      j: integer,
      local_status: ost$status,
      upline_element_state: cmt$element_state;

    status.normal := TRUE;

    IF cmv$physical_configuration = NIL THEN
      osp$set_status_condition (cme$active_pc_empty, status);
      RETURN;
    IFEND;

    osp$set_signature_lock (cmv$peripheral_element_table.lock, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /main_program/
    BEGIN
      FOR i := LOWERBOUND (cmv$physical_configuration^) TO UPPERBOUND (cmv$physical_configuration^) DO
        CASE cmv$physical_configuration^ [i].element_type OF
        = cmc$data_channel_element =
          channel_name := cmv$physical_configuration^ [i].element_name;
          iou_name := cmv$physical_configuration^ [i].data_channel.iou;

          cmp$get_element_state (channel_name, iou_name, upline_element_state, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

          FOR j := LOWERBOUND (cmv$peripheral_element_table.pointer^ [i].physical_descriptor.
                channel_connection^) TO UPPERBOUND (cmv$peripheral_element_table.pointer^ [i].
                physical_descriptor.channel_connection^) DO

            cmp$get_element_state (cmv$peripheral_element_table.pointer^ [i].physical_descriptor.
                  channel_connection^ [j].downline_element, iou_name, downline_element_state, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            IF (upline_element_state = cmc$on) AND (downline_element_state = cmc$on) THEN
              cmv$peripheral_element_table.pointer^ [i].physical_descriptor.channel_connection^ [j].status :=
                    cmc$active;
            ELSE
              cmv$peripheral_element_table.pointer^ [i].physical_descriptor.channel_connection^ [j].status :=
                    cmc$inactive;
            IFEND;
          FOREND;

        = cmc$channel_adapter_element, cmc$controller_element =
          cmp$get_element_state (cmv$physical_configuration^ [i].element_name, osc$null_name,
                upline_element_state, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

          FOR j := LOWERBOUND (cmv$peripheral_element_table.pointer^ [i].physical_descriptor.
                equipment_connection^) TO UPPERBOUND (cmv$peripheral_element_table.pointer^ [i].
                physical_descriptor.equipment_connection^) DO

            cmp$get_element_state (cmv$peripheral_element_table.pointer^ [i].physical_descriptor.
                  equipment_connection^ [j].downline_element, osc$null_name, downline_element_state, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            IF (upline_element_state = cmc$on) AND (downline_element_state = cmc$on) THEN
              cmv$peripheral_element_table.pointer^ [i].physical_descriptor.equipment_connection^ [j].
                    status := cmc$active;
            ELSE
              cmv$peripheral_element_table.pointer^ [i].physical_descriptor.equipment_connection^ [j].
                    status := cmc$inactive;
            IFEND;
          FOREND;

        = cmc$communications_element, cmc$external_processor_element, cmc$storage_device_element =

          { These elements are the last in the path and have no downline connections.

        ELSE
        CASEND;
      FOREND;
    END /main_program/;

    osp$clear_signature_lock (cmv$peripheral_element_table.lock, local_status);
    IF status.normal THEN
      status := local_status;
    IFEND;

  PROCEND cmp$update_connection_states_r1;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$update_logical_unit_table', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$update_logical_unit_table
    (    logical_unit: iot$logical_unit;
         state: cmt$element_state;
     VAR status: ost$status);

    status.normal := TRUE;

    IF cmv$logical_unit_table = NIL THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$it_nil_lut,
            'The logical unit table is inaccessable in cmp$update_logical_unit_table.', status);
      RETURN;
    IFEND;

    IF logical_unit > UPPERBOUND (cmv$logical_unit_table^) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$it_lun_not_in_range,
            'Logical_unit_number out of bounds in cmp$update_logical_unit_table.', status);
      RETURN;
    IFEND;

    osp$set_signature_lock (cmv$logical_unit_lock, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE state OF
    = cmc$on =
      cmv$logical_unit_table^ [logical_unit].element_access := $cmt$element_access [cmc$read, cmc$write];
      cmv$logical_unit_table^ [logical_unit].element_capability := $cmt$element_capabilities
            [cmc$volume_assignment, cmc$io_request_submission, cmc$concurrent_maintenance];
    = cmc$down =
      cmv$logical_unit_table^ [logical_unit].element_access := $cmt$element_access [cmc$read, cmc$write];
      cmv$logical_unit_table^ [logical_unit].element_capability :=
            $cmt$element_capabilities [cmc$concurrent_maintenance, cmc$dedicated_maintenance];
    ELSE  { = cmc$off = }
      cmv$logical_unit_table^ [logical_unit].element_access := $cmt$element_access [ ];
      cmv$logical_unit_table^ [logical_unit].element_capability := $cmt$element_capabilities [ ];
    CASEND;

    osp$clear_signature_lock (cmv$logical_unit_lock, status);

  PROCEND cmp$update_logical_unit_table;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$validate_unused_channel ', EJECT ??

{ PURPOSE:
{   This procedure validates maintenance usage on a channel that is unused by NOS/VE.
{
{ NOTE:
{   For certain devices such as ISD1/ISD2/CM3, NOS/VE only uses the first channel on a dual access
{   configuration, thus it does not know about the other access. Therefore, maintenance should be prevented
{   from using the second access as NOS/VE will not be able to honor the other channel lock entry.

  PROCEDURE [XDCL, #GATE] cmp$validate_unused_channel
    (    channel_name: cmt$element_name;
         iou_name: cmt$element_name;
     VAR maintenance_allowed: boolean;
     VAR status: ost$status);

    VAR
      active_unit: boolean,
      channel_element_p: ^cmt$element_definition,
      channel_port_number: 0..1,
      controller_entry_p: ^cmt$peripheral_element_entry,
      controller_found: boolean,
      dummy_reservation: cmt$element_reservation,
      element_descriptor: cmt$element_descriptor,
      iou_number: dst$iou_number,
      job_name : jmt$system_supplied_name,
      logical_pp_index: iot$pp_number,
      lun: iot$logical_unit,
      pen: cmt$physical_equipment_number,
      pet_index: integer,
      ppit_p: ^iot$pp_interface_table,
      user_job_name: jmt$user_supplied_name;

    status.normal := TRUE;
    controller_found := FALSE;
    maintenance_allowed := TRUE;

    cmp$convert_iou_name (iou_name, iou_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$pc_get_element (channel_name, iou_name, channel_element_p, status);
    IF NOT status.normal THEN

      { Channel is not in VE configuration.

      status.normal := TRUE;
      RETURN;
    IFEND;

    cmp$get_logical_pp_index (channel_element_p^, logical_pp_index, status);
    IF NOT status.normal THEN
      IF status.condition = cme$pc_not_logically_conf THEN
        status.normal := TRUE;
      IFEND;
      RETURN;
    IFEND;

    CASE cmv$logical_pp_table_p^ [logical_pp_index].controller_info.controller_type OF
    = cmc$ms7154_x .. cmc$ms7155_1x, cmc$ms7255_1_1, cmc$ms7255_1_2, cmc$mscm3_ct, cmc$mt5698_xx,
          cmc$ms5831_x =
       pmp$get_job_names (user_job_name, job_name, status);
    ELSE
      {
      { Other disk subsystems are OK for maintenance access.
      {
      RETURN;
    CASEND;

    IF channel_element_p^.data_channel.port = cmc$port_b THEN
      channel_port_number := 1;
    ELSE
      channel_port_number := 0;
    IFEND;

  /loop_1/
    FOR pen := LOWERVALUE (cmt$physical_equipment_number) TO UPPERVALUE (cmt$physical_equipment_number) DO
      IF NOT channel_element_p^.data_channel.connection.equipment [pen].configured THEN
        CYCLE /loop_1/;
      IFEND;

      element_descriptor.element_type := cmc$controller_element;
      element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
      element_descriptor.peripheral_descriptor.element_name :=
            channel_element_p^.data_channel.connection.equipment [pen].element_name;

      cmp$search_peripheral_table (element_descriptor, dummy_reservation, {not_in_configuration} FALSE,
            pet_index, status);
      IF NOT status.normal THEN
        CYCLE /loop_1/;
      IFEND;
      controller_entry_p := ^cmv$peripheral_element_table.pointer^[pet_index];

      msp$search_con_access_job (pet_index, job_name, controller_found, status);
      IF controller_found THEN
        EXIT /loop_1/;
      IFEND;
    FOREND /loop_1/;

    IF controller_found AND (controller_entry_p^.element_status.state = cmc$down) THEN
      maintenance_allowed := TRUE;
      RETURN;
    IFEND;

    active_unit := FALSE;
    ppit_p := cmv$logical_pp_table_p^ [logical_pp_index].pp_info.pp_interface_table_p;

  /search_for_active_unit/
    FOR lun := LOWERBOUND (ppit_p^.unit_descriptors) TO UPPERBOUND (ppit_p^.unit_descriptors) DO
      IF ppit_p^.unit_descriptors [lun].unit_interface_table = NIL THEN
        CYCLE /search_for_active_unit/;
      IFEND;

      IF ppit_p^.unit_descriptors [lun].physical_path.port <> channel_port_number THEN
        CYCLE /search_for_active_unit/;
      IFEND;

      IF ppit_p^.unit_descriptors [lun].unit_interface_table_rma <> 0 THEN
        IF controller_found THEN
          IF ppit_p^.unit_descriptors [lun].physical_path.controller_number = pen THEN
            active_unit := TRUE;
            EXIT /search_for_active_unit/;
          IFEND
        ELSE
          active_unit := TRUE;
          EXIT /search_for_active_unit/;
        IFEND;
      IFEND;
    FOREND /search_for_active_unit/;

    maintenance_allowed := active_unit;

  PROCEND cmp$validate_unused_channel;

?? OLDTITLE ??
?? NEWTITLE := 'msp$mark_element_requested', EJECT ??

{ PURPOSE:
{   This procedure updates the peripheral element table as being requested for maintenance access (CONCURRENT
{   or DEDICATED).  When an entry has been marked as dedicated access, subsequent dedicated maintenance access
{   on that entry will be denied.

  PROCEDURE [XDCL, #GATE] msp$mark_element_requested
    (    element: cmt$element_descriptor;
         access_type: mst$access_type;
         job_name: jmt$system_supplied_name;
         gtid: ost$global_task_id;
     VAR status: ost$status);

    VAR
      element_reservation: cmt$element_reservation,
      lock_status: ost$status,
      peripheral_index: integer;

    status.normal := TRUE;

    cmp$search_peripheral_table (element, element_reservation, FALSE, peripheral_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$set_signature_lock (cmv$peripheral_element_table.lock, osc$wait, lock_status);
    IF NOT lock_status.normal THEN
      RETURN;
    IFEND;

    IF access_type = msc$dedicated_access THEN
      cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.access :=
            msc$dedicated_access;
      cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.
            dedicated_accessor.active := TRUE;
      cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.
            dedicated_accessor.job_identification := job_name;
      cmv$peripheral_element_table.pointer^ [peripheral_index].gtid := gtid;
    IFEND;

    osp$clear_signature_lock (cmv$peripheral_element_table.lock, lock_status);

  PROCEND msp$mark_element_requested;
?? OLDTITLE ??
?? NEWTITLE := 'msp$search_con_access_job', EJECT ??

  PROCEDURE [XDCL, #GATE] msp$search_con_access_job
    (    peripheral_index: integer;
         job_name: jmt$system_supplied_name;
     VAR found: boolean;
     VAR status: ost$status);

    VAR
      access: mst$access_type,
      con_access_job_list_p: mst$con_access_job_list;

    status.normal := TRUE;
    found := FALSE;

    access :=cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.access;

    CASE access OF
    = msc$concurrent_access =
      con_access_job_list_p :=
            cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.con_access_job_list;
      WHILE con_access_job_list_p <> NIL DO
        IF con_access_job_list_p^.job_name = job_name THEN
          found := TRUE;
          RETURN;
        IFEND;
        con_access_job_list_p := con_access_job_list_p^.forward_link;
      WHILEND;
    = msc$dedicated_access =
      IF  cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.dedicated_accessor.
            job_identification = job_name THEN
        found := TRUE;
      IFEND;
    ELSE
    CASEND;
  PROCEND msp$search_con_access_job;
?? OLDTITLE ??
?? NEWTITLE := 'msp$unmark_element_requested', EJECT ??

{ PURPOSE:
{   This procedure unmark an element entry as a result of msp$release_maintenance_access.

  PROCEDURE [XDCL, #GATE] msp$unmark_element_requested
    (    job_name: jmt$system_supplied_name;
         gtid: ost$global_task_id;
         peripheral_index: integer;
         mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      iou_number: dst$iou_number,
      lock_status: ost$status,
      pc_index: integer,
      table_index: integer;

    status.normal := TRUE;
    osp$set_signature_lock (cmv$peripheral_element_table.lock, osc$wait, lock_status);
    IF NOT lock_status.normal THEN
      RETURN;
    IFEND;

    { Check WRONG JOB, no DEDICATED or CONCURRENT ACCESS }

  /main_program/
    BEGIN
      IF cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.access =
            msc$dedicated_access THEN
        IF cmv$peripheral_element_table.pointer^ [peripheral_index].
              maintenance_activity.dedicated_accessor.job_identification <> job_name THEN
          osp$set_status_abnormal (msc$maintenance_services_id, mse$dedicated_access_granted,
                cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                cmv$peripheral_element_table.pointer^ [peripheral_index].
                maintenance_activity.dedicated_accessor.job_identification, status);
          EXIT /main_program/;
        IFEND;

        cmv$peripheral_element_table.pointer^ [peripheral_index].
              maintenance_activity.dedicated_accessor.job_identification := ' ';
        cmv$peripheral_element_table.pointer^ [peripheral_index].
              maintenance_activity.dedicated_accessor.active := FALSE;
        cmv$peripheral_element_table.pointer^ [peripheral_index].
              maintenance_activity.access := msc$concurrent_access;
        cmv$peripheral_element_table.pointer^ [peripheral_index].
              maintenance_activity.con_access_job_list := NIL;
        cmv$peripheral_element_table.pointer^ [peripheral_index].gtid.index := 4095;
        cmv$peripheral_element_table.pointer^ [peripheral_index].gtid.seqno := 255;

        { Check to see if the element is in the active physical configuration having multiple channel
        { connections.  If so, release all additional channels to the real state system.

       /pc_loop_1/
        FOR pc_index := 1 TO UPPERBOUND (cmv$physical_configuration^) DO
          IF (cmv$physical_configuration^ [pc_index].element_type =
                cmv$peripheral_element_table.pointer^ [peripheral_index].physical_descriptor.element_type) AND
                (cmv$physical_configuration^ [pc_index].element_name =
                cmv$peripheral_element_table.pointer^ [peripheral_index].element_name) THEN

            { Release all channels connected to controller to the real state system }

            cmp$request_channels (dsc$rrt_return_channel, cmv$physical_configuration^ [pc_index],
                  mainframe_id, status);
            IF NOT status.normal THEN
              EXIT /main_program /;
            IFEND;
            EXIT /pc_loop_1/;
          IFEND;
        FOREND /pc_loop_1/;
      IFEND;
    END /main_program/;

    osp$clear_signature_lock (cmv$peripheral_element_table.lock, lock_status);

  PROCEND msp$unmark_element_requested;
?? OLDTITLE ??
MODEND cmm$manage_cm_tables_r1;
*DECK DECK=CMM$MANAGE_ELEMENT_RESERVATION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE CM : Manage Element Reservation' ??
MODULE cmm$manage_element_reservation;

{ PURPOSE:
{   This module contains interfaces that allow system reservation and access of elements.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cme$logical_configuration_mgr
*copyc cme$physical_configuration_mgr
*copyc cme$reserve_element
*copyc cmt$element_definition
*copyc cmt$element_descriptor
*copyc cmt$element_reservation
*copyc cmt$pp_memory_length
*copyc cmt$pp_program_description
*copyc cmt$pp_registers
*copyc dme$tape_errors
*copyc dmt$message_element
*copyc dst$dft_pp_registers
*copyc dst$iou_resource
*copyc fst$wait_for_attachment
*copyc iot$pp_number
*copyc mse$request_maintenance_access
*copyc ost$string
*copyc rmc$manual_tape_maintenance
*copyc rmd$volume_declarations
?? POP ??
*copyc clp$convert_integer_to_string
*copyc clp$trimmed_string_size
*copyc cmp$acquire_resources
*copyc cmp$build_pp_table_entry
*copyc cmp$clear_channel_interlock
*copyc cmp$clear_element_lock
*copyc cmp$clear_unit_shared
*copyc cmp$convert_channel_number
*copyc cmp$convert_iou_name
*copyc cmp$convert_channel_ordinal
*copyc cmp$convert_iou_number
*copyc cmp$convert_pp_number
*copyc cmp$convert_pp_ordinal
*copyc cmp$deadstart_pp
*copyc cmp$format_error_message
*copyc cmp$free_pp_request
*copyc cmp$get_channel_definition
*copyc cmp$get_element_definition
*copyc cmp$get_element_name
*copyc cmp$get_iou_definition
*copyc cmp$get_logical_unit_number
*copyc cmp$get_pp_reg
*copyc cmp$hardware_idle_pp
*copyc cmp$hardware_resume_pp
*copyc cmp$mark_element_reserved
*copyc cmp$mark_pp_element_reserved
*copyc cmp$pc_get_element
*copyc cmp$pp_queue_lock
*copyc cmp$release_channel_resource
*copyc cmp$release_pp_by_index
*copyc cmp$release_pp_resource
*copyc cmp$search_peripheral_table
*copyc cmp$search_pp_table
*copyc cmp$send_pp_command
*copyc cmp$set_element_lock
*copyc cmp$unmark_element_reserved
*copyc cmp$unmark_pp_element_reserved
*copyc cmp$unmark_pp_when_cleanup
*copyc cmp$unmark_when_cleanup
*copyc dsp$retrieve_iou_information
*copyc mmp$create_user_segment
*copyc msp$delete_con_access_gtid
*copyc msp$delete_con_access_job
*copyc msp$search_con_access_job
*copyc msp$search_element_con_accessed
*copyc ofp$format_operator_menu
*copyc osp$append_status_parameter
*copyc osp$establish_condition_handler
*copyc osp$is_caller_system_privileged
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$wait
*copyc cmt$element_name
*copyc dst$iou_number
*copyc osp$set_status_abnormal
*copyc cme$physical_configuration_mgr

*copyc pmp$get_executing_task_gtid
*copyc pmp$get_job_names
*copyc pmp$get_mainframe_id
*copyc pmp$long_term_wait
*copyc pmp$zero_out_table
*copyc rmp$assign_tape_unit
*copyc rmp$release_tape_unit
?? EJECT ??
*copyc cmv$element_reservation_lock
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc cmv$peripheral_element_table
*copyc dmv$null_sfid
*copyc msv$con_access_gtid_list

VAR
  cmv$free_trap: [XREF] boolean;














?? OLDTITLE ??
?? NEWTITLE := 'release_channel_resource', EJECT ??

  PROCEDURE release_channel_resource
    (    element_descriptor: cmt$element_descriptor;
     VAR status: ost$status);

    VAR
      channel_definition: cmt$data_channel_definition,
      channel: cmt$physical_channel,
      iou_number: dst$iou_number;

    status.normal := TRUE;

    IF element_descriptor.element_type <> cmc$data_channel_element THEN
      RETURN;
    IFEND;

    cmp$get_channel_definition (element_descriptor.channel_descriptor, channel_definition, status);
    IF NOT status.normal AND (status.condition <> cme$lcm_element_not_found) THEN
      RETURN;
    IFEND;

    channel.number := channel_definition.number;
    channel.concurrent := channel_definition.concurrent;
    channel.port := channel_definition.port;
    cmp$convert_iou_name (channel_definition.iou, iou_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$release_channel_resource (channel, iou_number, status);

  PROCEND release_channel_resource;
?? OLDTITLE ??
?? NEWTITLE := 'release_pp_element', EJECT ??

{ PURPOSE:
{   This procedure releases a physical PP and releases a slot in the Logical PP Table.

  PROCEDURE release_pp_element
    (    job_name: jmt$system_supplied_name;
         system_caller: boolean;
         mainframe_id: pmt$mainframe_id;
         number_of_ious: dst$number_of_ious;
         iou_information_table: dst$iou_information_table;
         element_reservation: cmt$element_reservation;
     VAR status: ost$status);

    VAR
      found: boolean,
      len: integer,
      local_status: ost$status,
      physical_pp: dst$iou_resource,
      pp_index: iot$pp_number,
      pp_memory_size: cmt$pp_memory_length,
      pp_number: string (13),
      pp_registers: cmt$pp_registers,
      pp_software_idled: boolean;

    status.normal := TRUE;
    cmp$convert_pp_ordinal (element_reservation.pp_reservation.acquired_pp_identification.ordinal,
          physical_pp);

    IF number_of_ious = 1 THEN
      physical_pp.iou_number := iou_information_table [1].physical_iou_number;
    ELSE
      cmp$convert_iou_name (element_reservation.pp_reservation.acquired_pp_identification.iou,
            physical_pp.iou_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    cmp$search_pp_table (physical_pp, pp_index, found, local_status);
    IF NOT found THEN
      IF physical_pp.channel_protocol = dsc$cpt_cio THEN
        STRINGREP (pp_number, len, 'IOU', physical_pp.iou_number: 2, ' CPP', physical_pp.number: 3);
      ELSE
        STRINGREP (pp_number, len, 'IOU', physical_pp.iou_number: 2, ' PP', physical_pp.number: 3);
      IFEND;
      osp$set_status_abnormal (cmc$configuration_management_id, cme$element_not_reserved,
            pp_number (1, len), status);
      RETURN;
    IFEND;

    { Free all outstanding requests on the PP queue.

    cmp$free_pp_request (pp_index);

    cmp$release_pp_by_index (pp_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Clear all channel interlocks held by PP.

    cmp$clear_channel_interlock (physical_pp.iou_number, pp_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$unmark_pp_element_reserved (job_name, system_caller, pp_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND release_pp_element;
?? OLDTITLE ??
?? NEWTITLE := 'reserve_element_handler', EJECT ??

  PROCEDURE reserve_element_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    VAR
      ignore_status: ost$status;

    handler_status.normal := TRUE;

    cmp$clear_element_lock (ignore_status);

    pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

  PROCEND reserve_element_handler;
?? OLDTITLE ??
?? NEWTITLE := 'reserve_pp_element', EJECT ??

{ PURPOSE:
{   This procedure retrieves a physical PP and reserves a slot in the Logical PP Table.

  PROCEDURE reserve_pp_element
    (    gtid: ost$global_task_id;
         job_name: jmt$system_supplied_name;
         system_caller: boolean;
         mainframe_id: pmt$mainframe_id;
         number_of_ious: dst$number_of_ious;
         iou_information_table: dst$iou_information_table;
     VAR element_reservation: cmt$element_reservation;
     VAR status: ost$status);

    VAR
      channel_name: cmt$element_name,
      channel: cmt$physical_channel,
      channel_present: boolean,
      dummy_channel: cmt$physical_channel,
      element_entry: integer,
      found: boolean,
      ignore_status: ost$status,
      iou_number: dst$iou_number,
      len: integer,
      mark_channel: boolean,
      physical_pp: dst$iou_resource,
      pp_index: iot$pp_number,
      pp_number: string (13);

    status.normal := TRUE;
    mark_channel := FALSE;
    dummy_channel.number := 15;
    dummy_channel.port := cmc$unspecified_port;
    dummy_channel.concurrent := FALSE;
    channel_present := FALSE;

    CASE element_reservation.pp_reservation.selector OF
    = cmc$choose_any_pp =

      { Procedure cmp$acquire_resources will decide in which IOU to request the PP.

      cmp$acquire_resources (dsc$rrt_get_pp, dummy_channel, 0, 0, 0, FALSE, FALSE, FALSE, physical_pp,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    = cmc$choose_pp_by_channel =
      channel_present := TRUE;

      { Only use the user passed in IOU if the system has more than 1 IOU.

      IF number_of_ious = 1 THEN
        iou_number := iou_information_table [1].physical_iou_number;
      ELSE
        cmp$convert_iou_name (element_reservation.pp_reservation.channel.iou, iou_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      cmp$convert_channel_ordinal (element_reservation.pp_reservation.channel.ordinal, channel_name,
            channel.number, channel.concurrent, channel.port, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
{ Start here


{ Find the channel entry in the peripheral element table.

          FOR element_entry := LOWERBOUND (cmv$peripheral_element_table.pointer^)
             TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
                mark_channel := FALSE;
               IF cmv$peripheral_element_table.pointer^[element_entry].element_name = channel_name THEN
                IF cmv$peripheral_element_table.pointer^[element_entry].gtid <> gtid THEN
                 mark_channel := TRUE;
           {go attempt to acquire the channel}
            cmp$acquire_resources (dsc$rrt_get_channel, channel, iou_number, 0, 0, FALSE, FALSE, FALSE,
                  physical_pp, status);

               IF status.normal AND mark_channel THEN
                 cmp$mark_element_reserved (element_reservation, FALSE, job_name,
                    gtid, physical_pp, element_entry, FALSE, status);
                    IF NOT status.normal THEN
                       RETURN;
                    IFEND;
               IFEND;
              IFEND;
            IFEND;
          FOREND;

     {go acquire the pp.

      cmp$acquire_resources (dsc$rrt_get_pp, channel, iou_number, 0, 0, FALSE, FALSE, TRUE, physical_pp,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    = cmc$choose_specific_pp =
      cmp$convert_pp_ordinal (element_reservation.pp_reservation.desired_pp.ordinal, physical_pp);

      { Only use the user passed in IOU if the system has more than 1 IOU.

      IF number_of_ious = 1 THEN
        physical_pp.iou_number := iou_information_table [1].physical_iou_number;
      ELSE
        cmp$convert_iou_name (element_reservation.pp_reservation.desired_pp.iou, physical_pp.iou_number,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      cmp$search_pp_table (physical_pp, pp_index, found, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF found THEN
        IF physical_pp.channel_protocol = dsc$cpt_cio THEN
          STRINGREP (pp_number, len, 'IOU', physical_pp.iou_number: 2, ' CPP', physical_pp.number: 3);
        ELSE
          STRINGREP (pp_number, len, 'IOU', physical_pp.iou_number: 2, ' PP', physical_pp.number: 3);
        IFEND;
        osp$set_status_abnormal (cmc$configuration_management_id, cme$element_already_reserved,
              pp_number (1, len), status);
        IF cmv$logical_pp_table_p^ [pp_index].flags.entry_reserved_by_nosve THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'NOS/VE', status);
        ELSE
          IF cmv$logical_pp_table_p^ [pp_index].task_info.reserved_job_name = job_name THEN
            osp$append_status_parameter (osc$status_parameter_delimiter, 'this job', status);
          ELSE
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  cmv$logical_pp_table_p^ [pp_index].task_info.reserved_job_name, status);
          IFEND;
        IFEND;
        RETURN;
      IFEND;
      cmp$acquire_resources (dsc$rrt_get_pp, dummy_channel, 0, 0, 0, FALSE, TRUE, FALSE, physical_pp,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    = cmc$choose_pp_by_barrel =

      { Procedure cmp$acquire_resources will decide in which IOU to request the PP.

      cmp$acquire_resources (dsc$rrt_get_pp, dummy_channel, 0, 0, 0,
            element_reservation.pp_reservation.driver_barrel, FALSE, FALSE, physical_pp, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    ELSE
    CASEND;

   /pp_acquired/
    BEGIN
      cmp$mark_pp_element_reserved (element_reservation, system_caller, job_name, gtid, physical_pp,
            channel_present, pp_index, status);
      IF NOT status.normal THEN
        EXIT /pp_acquired/;
      IFEND;

      cmp$convert_pp_number (physical_pp,
            element_reservation.pp_reservation.acquired_pp_identification.ordinal);
      cmp$convert_iou_number (physical_pp.iou_number,
            element_reservation.pp_reservation.acquired_pp_identification.iou, status);
      IF NOT status.normal THEN
        cmp$unmark_pp_element_reserved (job_name, system_caller, pp_index, ignore_status);
      IFEND;
    END /pp_acquired/;

    IF NOT status.normal THEN
      cmp$release_pp_resource (physical_pp, ignore_status);
    IFEND;

  PROCEND reserve_pp_element;
?? OLDTITLE ??
?? NEWTITLE := 'search_connected_elements', EJECT ??

  PROCEDURE search_connected_elements
    (    channel: cmt$data_channel_definition;
         channel_name: cmt$element_name;
     VAR status: ost$status);

    VAR
      channel_element_p: ^cmt$element_definition,
      channel_element_name: cmt$element_name,
      element_descriptor: cmt$element_descriptor,
      element_reservation: cmt$element_reservation,
      error_string: string (64),
      found: boolean,
      index: integer,
      local_status: ost$status,
      number_string: ost$string,
      outer_loop: 1 .. 3,
      outer_loop_index: 1 .. 3,
      peripheral_index: integer,
      string_length: integer,
      second_name: cmt$element_name,
      third_name: cmt$element_name;

    status.normal := TRUE;
    found := FALSE;
    second_name := ' ';
    third_name := ' ';

    IF channel.concurrent THEN

      { If a CIO channel is being reserved, the connections to all three possible names of the channel must
      { all be OFF.

      clp$convert_integer_to_string (channel.number, 10, FALSE, number_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF channel.port = cmc$port_a THEN
        STRINGREP (second_name, string_length, 'CCH', number_string.value (1, number_string.size));
        STRINGREP (third_name, string_length, 'CCH', number_string.value (1, number_string.size), 'B');
      ELSEIF channel.port = cmc$port_b THEN
        STRINGREP (second_name, string_length, 'CCH', number_string.value (1, number_string.size));
        STRINGREP (third_name, string_length, 'CCH', number_string.value (1, number_string.size), 'A');
      ELSE
        STRINGREP (second_name, string_length, 'CCH', number_string.value (1, number_string.size), 'A');
        STRINGREP (third_name, string_length, 'CCH', number_string.value (1, number_string.size), 'B');
      IFEND;
      outer_loop_index := 3;
    ELSE
      outer_loop_index := 1;
    IFEND;

   /outer_for_loop/
    FOR outer_loop := 1 TO outer_loop_index DO

      CASE outer_loop OF
      = 1 =
        channel_element_name := channel_name;
      = 2 =
        channel_element_name := second_name;
      = 3 =
        channel_element_name := third_name;
      ELSE
      CASEND;

      cmp$pc_get_element (channel_element_name, channel.iou, channel_element_p, local_status);
      IF NOT local_status.normal THEN
        CYCLE /outer_for_loop/;
      IFEND;

     /for_loop/
      FOR index := LOWERVALUE (cmt$physical_equipment_number) TO UPPERVALUE (cmt$physical_equipment_number) DO
        IF channel_element_p^.data_channel.connection.equipment [index].configured THEN
          element_descriptor.element_type := cmc$controller_element;
          element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
          element_descriptor.peripheral_descriptor.element_name :=
                channel_element_p^.data_channel.connection.equipment [index].element_name;

          cmp$search_peripheral_table (element_descriptor, element_reservation, FALSE, peripheral_index,
                status);
          IF NOT status.normal THEN
            EXIT /for_loop/;
          IFEND;
          IF cmv$peripheral_element_table.pointer^ [peripheral_index].element_status.state <> cmc$off THEN
            found := TRUE;
            EXIT /for_loop/;
          IFEND;
        IFEND;
      FOREND /for_loop/;

      IF found THEN
        error_string := ' ';
        error_string (1, 6) := channel.iou;
        error_string (7, * ) := channel_name;
        osp$set_status_abnormal (cmc$configuration_management_id, cme$element_downline_connected,
              error_string, status);
        EXIT /outer_for_loop/;
      IFEND;

    FOREND /outer_for_loop/;

  PROCEND search_connected_elements;
?? OLDTITLE ??
?? NEWTITLE := 'validate_pp_reserved', EJECT ??

{ PURPOSE:
{   This procedure validates the PP parameters passed through CM program interfaces, and makes sure that the
{   PP is properly reserved by the same job via CMP$RESERVE_ELEMENT.  If the test passes then the logical PP
{   which is the index to logical PP table is returned.

  PROCEDURE validate_pp_reserved
    (    system_caller: boolean;
         job_name: jmt$system_supplied_name;
         pp: dst$iou_resource;
         iou: string (5);
     VAR pp_index: iot$pp_number;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      index: iot$pp_number,
      integer_string: ost$string,
      text: string (64);

    status.normal := TRUE;

    FOR index := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
      IF cmv$logical_pp_table_p^ [index].pp_info.physical_pp = pp THEN
        IF (cmv$logical_pp_table_p^ [index].flags.entry_reserved_by_other AND
              (cmv$logical_pp_table_p^ [index].task_info.reserved_job_name = job_name)) OR
              (cmv$logical_pp_table_p^ [index].flags.entry_reserved_by_system_job AND system_caller) THEN
          pp_index := index;
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    text := ' ';
    text (1, 5) := iou;
    clp$convert_integer_to_string (pp.number, 10, FALSE, integer_string, ignore_status);
    IF pp.channel_protocol = dsc$cpt_cio THEN
      text (6, 3) := 'CPP';
      text (9, *) := integer_string.value (1, integer_string.size);
    ELSE
      text (6, 2) := 'PP';
      text (8, *) := integer_string.value (1, integer_string.size);
    IFEND;
    osp$set_status_abnormal (cmc$configuration_management_id, cme$element_not_reserved, text, status);

  PROCEND validate_pp_reserved;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$execute_pp_program', EJECT ??
*copyc cmh$execute_pp_program
  PROCEDURE [XDCL, #GATE] cmp$execute_pp_program
    (VAR program_description: ARRAY [1 .. *] OF cmt$pp_program_description;
     VAR status: ost$status);

    TYPE
      t$communication_buff = PACKED RECORD
        fill1: 0 .. 7fffffff(16),
        slave: boolean,
        partner_pp: ost$real_memory_address,
      RECEND;

    VAR
      active_elements: ARRAY [1 .. 2] OF cmt$access_elements,
      commun_buffer_p: ^t$communication_buff,
      element_descriptor: cmt$element_descriptor,
      element_index: integer,
      element_reservation: cmt$element_reservation,
      found: boolean,
      iou_name: cmt$element_name,
      iou_number: dst$iou_number,
      index: integer,
      job_name: jmt$system_supplied_name,
      job_found: boolean,
      master_pp_table_rma: ost$real_memory_address,
      physical_id: cmt$physical_identification,
      pp_entry_index_p: ^ARRAY [1 .. *] OF iot$pp_number,
      pp_number: ARRAY [1 .. 2] OF dst$iou_resource,
      rma: ost$real_memory_address,
      search_from_dstape: boolean,
      seg_attributes_p: ^ARRAY [ * ] OF mmt$user_attribute_descriptor,
      selected_pp_programs: boolean,
      slave_pp_table_rma: ost$real_memory_address,
      slave_seq_ptr: amt$segment_pointer,
      seq_ptr: amt$segment_pointer,
      system_caller: boolean,
      table_index: integer,
      user_job_name: jmt$user_supplied_name;

    status.normal := TRUE;
    system_caller := osp$is_caller_system_privileged ();
    search_from_dstape := FALSE;
    master_pp_table_rma := 0;
    slave_pp_table_rma := 0;

    IF UPPERBOUND (program_description) > 2 THEN
      osp$set_status_condition (cme$too_many_pp_program_desc, status);
      RETURN;
    IFEND;

    pmp$get_job_names (user_job_name, job_name, status);



    PUSH pp_entry_index_p: [LOWERBOUND (program_description) .. UPPERBOUND (program_description)];

   /master_slave/
    FOR index := LOWERBOUND (program_description) TO UPPERBOUND (program_description) DO
      cmp$convert_pp_ordinal (program_description [index].pp_identification.ordinal, pp_number [index]);
      cmp$convert_iou_name (program_description [index].pp_identification.iou, pp_number [index].iou_number,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      validate_pp_reserved (system_caller, job_name, pp_number [index],
            program_description [index].pp_identification.iou (1, 5), pp_entry_index_p^ [index], status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (program_description [index].pp_program = NIL) AND program_description [index].master_pp THEN
        search_from_dstape := TRUE;
      IFEND;
      IF program_description [index].communication_buffer_length > osc$max_page_size THEN
        osp$set_status_condition (cme$buffer_length_too_large, status);
        RETURN;
      IFEND;

      IF program_description [index].element_access = NIL THEN
        CYCLE /master_slave/;
      IFEND;
      PUSH active_elements [index].accessed_elements_p:
            [LOWERBOUND (program_description [index].element_access^) ..
            UPPERBOUND (program_description [index].element_access^)];
      FOR element_index := LOWERBOUND (program_description [index].element_access^) TO
            UPPERBOUND (program_description [index].element_access^) DO
        active_elements [index].accessed_elements_p^ [element_index].active := FALSE;
        active_elements [index].accessed_elements_p^ [element_index].lun := 0;

        physical_id.product_identification.product_number := ' ';
        physical_id.serial_number := ' ';
        physical_id.hardware_address := program_description [index].element_access^ [element_index];
        cmp$get_element_name (physical_id, element_descriptor, status);
        IF NOT status.normal THEN
          IF status.condition = cme$lcm_element_name_not_found THEN
            status.normal := TRUE;
          ELSE
            RETURN;
          IFEND;
        ELSE
          active_elements [index].accessed_elements_p^ [element_index].active := TRUE;
        IFEND;

        IF active_elements [index].accessed_elements_p^ [element_index].active THEN
          cmp$search_peripheral_table (element_descriptor, element_reservation, FALSE, table_index, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          active_elements [index].accessed_elements_p^ [element_index].lun :=
                cmv$peripheral_element_table.pointer^ [table_index].logical_unit_number;

        ELSE
          IF $cmt$physical_address_specifier [cmc$unit_address] <=
                physical_id.hardware_address.physical_address_specifier THEN
            element_reservation.element_type := cmc$storage_device_element;
          ELSE
            element_reservation.element_type := cmc$controller_element;
          IFEND;
          element_reservation.peripheral_descriptor.use_logical_identification := FALSE;
          element_reservation.peripheral_descriptor.hardware_address :=
                program_description [index].element_access^ [element_index];
          cmp$search_peripheral_table (element_descriptor, element_reservation, TRUE, table_index, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF (job_name <> cmv$peripheral_element_table.pointer^ [table_index].reserved_job) AND
              NOT (system_caller AND
              cmv$peripheral_element_table.pointer^ [table_index].reserved_by_system) THEN
          IF active_elements [index].accessed_elements_p^ [element_index].active THEN

            { Check if device is the object of either CONCURRENT or DEDICATED maintenance.

            CASE cmv$peripheral_element_table.pointer^ [table_index].maintenance_activity.access OF
            = msc$dedicated_access =
              IF cmv$peripheral_element_table.pointer^ [table_index].maintenance_activity.
                    dedicated_accessor.active AND
                    (cmv$peripheral_element_table.pointer^ [table_index].maintenance_activity.
                    dedicated_accessor.job_identification <> job_name) THEN
                osp$set_status_abnormal (cmc$configuration_management_id, mse$dedicated_access_granted,
                      cmv$peripheral_element_table.pointer^ [table_index].element_name, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      cmv$peripheral_element_table.pointer^ [table_index].maintenance_activity.
                      dedicated_accessor.job_identification, status);
                RETURN;
              IFEND;

            = msc$concurrent_access =
              msp$search_con_access_job (table_index, job_name, job_found, status);
              IF NOT job_found THEN
                osp$set_status_abnormal (cmc$configuration_management_id, mse$req_maint_access_required,
                      cmv$peripheral_element_table.pointer^ [table_index].element_name, status);
                RETURN;
              IFEND;
            ELSE
            CASEND;
          ELSE
            osp$set_status_abnormal (cmc$configuration_management_id, cme$element_not_reserved,
                  'Storage devices on element_access', status);
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    FOREND /master_slave/;
    seq_ptr.kind := amc$sequence_pointer;
    seq_ptr.sequence_pointer := NIL;
    slave_seq_ptr.kind := amc$sequence_pointer;
    slave_seq_ptr.sequence_pointer := NIL;

    selected_pp_programs := (program_description [1].iou_program_name <> 'ICAD') AND
          (program_description [1].iou_program_name <> 'NDI0') AND
          (program_description [1].iou_program_name <> 'NPDR') AND
          (program_description [1].iou_program_name <> 'NETW') AND
          (program_description [1].iou_program_name <> 'IVB0') AND
          (program_description [1].iou_program_name <> 'IVB4') AND
          (program_description [1].iou_program_name <> 'ESMD');

    { Build the PP table.

    IF selected_pp_programs AND (program_description [1].communication_buffer_length > 0) THEN
      PUSH seg_attributes_p: [1 .. 3];
      seg_attributes_p^ [1].keyword := mmc$ua_segment_access_control;
      seg_attributes_p^ [1].access_control.cache_bypass := TRUE;
      seg_attributes_p^ [1].access_control.execute_privilege := osc$non_executable;
      seg_attributes_p^ [1].access_control.read_privilege := osc$read_uncontrolled;
      seg_attributes_p^ [1].access_control.write_privilege := osc$write_uncontrolled;
      seg_attributes_p^ [2].keyword := mmc$ua_ring_numbers;
      seg_attributes_p^ [2].r1 := osc$sj_ring_3;
      seg_attributes_p^ [2].r2 := osc$sj_ring_3;
      seg_attributes_p^ [3].keyword := mmc$ua_wired_segment;
      seg_attributes_p^ [3].wired_segment_length := program_description [1].communication_buffer_length;
      seg_attributes_p^ [3].contiguous_real_memory := TRUE;

      mmp$create_user_segment (seg_attributes_p, amc$sequence_pointer, mmc$as_sequential, seq_ptr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      RESET seq_ptr.sequence_pointer;
      pmp$zero_out_table (#LOC (seq_ptr.sequence_pointer^),
            program_description [1].communication_buffer_length);

      IF (UPPERBOUND (program_description) = 2) AND
            (program_description [2].communication_buffer_length > 0) THEN

        { Create wired area for slave PP

        seg_attributes_p^ [3].wired_segment_length := program_description [2].communication_buffer_length;
        mmp$create_user_segment (seg_attributes_p, amc$sequence_pointer, mmc$as_sequential, slave_seq_ptr,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        RESET slave_seq_ptr.sequence_pointer;
        pmp$zero_out_table (#LOC (slave_seq_ptr.sequence_pointer^),
              program_description [2].communication_buffer_length);
      IFEND;
    IFEND;
    cmp$build_pp_table_entry (pp_entry_index_p^, active_elements, seq_ptr.sequence_pointer,
          slave_seq_ptr.sequence_pointer, program_description, master_pp_table_rma, slave_pp_table_rma,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR index := LOWERBOUND (program_description) TO UPPERBOUND (program_description) DO
      IF selected_pp_programs AND ((master_pp_table_rma <> 0) OR (slave_pp_table_rma <> 0)) AND
            (program_description [index].communication_buffer_length > 0) THEN
        IF index = 1 THEN
          RESET seq_ptr.sequence_pointer;
          program_description [index].communication_buffer := seq_ptr.sequence_pointer;
          NEXT commun_buffer_p IN seq_ptr.sequence_pointer;
          IF commun_buffer_p <> NIL THEN
            commun_buffer_p^.slave := FALSE;
            commun_buffer_p^.partner_pp := slave_pp_table_rma;
            commun_buffer_p^.fill1 := 0;
          IFEND;
        ELSE
          RESET slave_seq_ptr.sequence_pointer;
          program_description [index].communication_buffer := slave_seq_ptr.sequence_pointer;
          NEXT commun_buffer_p IN slave_seq_ptr.sequence_pointer;
          IF commun_buffer_p <> NIL THEN
            commun_buffer_p^.slave := TRUE;
            commun_buffer_p^.partner_pp := master_pp_table_rma;
            commun_buffer_p^.fill1 := 0;
          IFEND;
        IFEND;
      IFEND;

      IF (master_pp_table_rma <> 0) OR (slave_pp_table_rma <> 0) THEN
        IF index = 1 THEN
          rma := master_pp_table_rma;
        ELSE
          rma := slave_pp_table_rma;
        IFEND;
      ELSE
        rma := cmv$logical_pp_table_p^ [pp_entry_index_p^ [index]].pp_info.pp_interface_table_rma;
      IFEND;


      cmp$deadstart_pp (pp_entry_index_p^ [index], rma, search_from_dstape,
            program_description [index].pp_program, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND cmp$execute_pp_program;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_pp_registers', EJECT ??
*copyc cmh$get_pp_registers

  PROCEDURE [XDCL, #GATE] cmp$get_pp_registers
    (    pp_identification: cmt$pp_identification;
     VAR pp_registers: cmt$pp_registers;
     VAR status: ost$status);

    VAR
      found: boolean,
      job_name: jmt$system_supplied_name,
      pp_index: iot$pp_number,
      pp: dst$iou_resource,
      pp_regs: dst$dft_pp_registers,
      system_caller: boolean,
      user_job_name: jmt$user_supplied_name;

    system_caller := osp$is_caller_system_privileged ();
    status.normal := TRUE;

    cmp$convert_pp_ordinal (pp_identification.ordinal, pp);
    cmp$convert_iou_name (pp_identification.iou, pp.iou_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$get_job_names (user_job_name, job_name, status);
    validate_pp_reserved (system_caller, job_name, pp, pp_identification.iou (1, 5), pp_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$get_pp_reg (pp, pp_regs, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pp_registers.a_register := pp_regs.a_register;
    pp_registers.k_register := pp_regs.k_register;
    pp_registers.p_register := pp_regs.p_register;
    pp_registers.q_register := pp_regs.q_register;

  PROCEND cmp$get_pp_registers;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$idle_pp', EJECT ??
*copyc cmh$idle_pp

  PROCEDURE [XDCL, #GATE] cmp$idle_pp
    (    pp_identification: cmt$pp_identification;
         break_interlocks: boolean;
         hardware_idle_pp: boolean;
         pp_memory_area: ^SEQ ( * );
     VAR actual_pp_memory_size: cmt$pp_memory_length;
     VAR pp_registers: cmt$pp_registers;
     VAR pp_software_idled: boolean;
     VAR status: ost$status);

    VAR
      dump_pp: boolean,
      dump_registers_only: boolean,
      found: boolean,
      job_name: jmt$system_supplied_name,
      physical_pp: dst$iou_resource,
      pp_entry_index: iot$pp_number,
      system_caller: boolean,
      user_job_name: jmt$user_supplied_name;

    status.normal := TRUE;

    system_caller := osp$is_caller_system_privileged ();
    pp_software_idled := FALSE;

    IF (NOT hardware_idle_pp) AND (pp_memory_area <> NIL) THEN
      osp$set_status_condition (cme$dump_requires_hardware_idle, status);
      RETURN;
    IFEND;

    dump_pp := (hardware_idle_pp) AND (pp_memory_area <> NIL);
    dump_registers_only := NOT dump_pp;

    cmp$convert_pp_ordinal (pp_identification.ordinal, physical_pp);
    cmp$convert_iou_name (pp_identification.iou, physical_pp.iou_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_job_names (user_job_name, job_name, status);
    validate_pp_reserved (system_caller, job_name, physical_pp, pp_identification.iou (1, 5),
          pp_entry_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT hardware_idle_pp THEN

      { Check pp queue lockword, if set then return abnormal status because on Soft IDLE, pp has to have
      { its queue cleared.

      IF cmp$pp_queue_lock (pp_entry_index) THEN
        osp$set_status_condition (cme$pp_holds_pp_queue_lock, status);
        RETURN;
      IFEND;
    IFEND;

    { Soft IDLE the PP first.

    cmp$send_pp_command (pp_entry_index, cmc$idle_command, pp_software_idled, status);

    IF hardware_idle_pp THEN
      cmp$hardware_idle_pp (physical_pp, dump_pp, dump_registers_only, pp_memory_area,
            actual_pp_memory_size, pp_registers, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF pp_software_idled THEN
      cmp$free_pp_request (pp_entry_index);
    IFEND;

    IF break_interlocks AND status.normal THEN
      cmp$clear_channel_interlock (physical_pp.iou_number, pp_entry_index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND cmp$idle_pp;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$mount_storage_medium', EJECT ??
*copyc cmh$mount_storage_medium

  PROCEDURE [XDCL, #GATE] cmp$mount_storage_medium
    (    storage_device: cmt$peripheral_descriptor;
         medium: rmt$external_vsn;
         write_access: boolean;
         wait_for_attachment: fst$wait_for_attachment;
     VAR status: ost$status);

?? NEWTITLE := 'menu_for_tape_maintenance_mount', EJECT ??

    PROCEDURE menu_for_tape_maintenance_mount
      (VAR status: ost$status);

      CONST
        default_terminate_reason = 'the requested tape volume is not available',
        number_of_choices = 2;

      VAR
        parameter_names: ^ost$parameter_help_names,
        response: oft$number_of_choices,
        response_string: ost$string,
        string_size: ost$name_size,
        menu_parameters: array [1 .. 3] of ^ost$message_parameter,
        terminate_reason: string (osc$max_string_size);

      status.normal := TRUE;

      menu_parameters [1] := ^medium;
      IF write_access THEN
        PUSH menu_parameters [2]: [4];
        menu_parameters [2]^ := 'TRUE';
      ELSE
        PUSH menu_parameters [2]: [5];
        menu_parameters [2]^ := 'FALSE';
      IFEND;
      string_size := clp$trimmed_string_size (element_name);
      menu_parameters [3] := ^element_name (1, string_size);

      PUSH parameter_names: [1 .. number_of_choices];
      parameter_names^ [1] := 'ALLOW_MAINTENANCE';
      parameter_names^ [2] := 'TERMINATE_REQUEST';

      ofp$format_operator_menu (rmc$manual_tape_maintenance, parameter_names, ^menu_parameters,
            number_of_choices, ofc$removable_media_operator, response, response_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE response OF
      = 1 =
        ;
      = 2 =
        IF response_string.size > 0 THEN
          terminate_reason := response_string.value (1, response_string.size);
        ELSE
          terminate_reason := default_terminate_reason;
        IFEND;
        osp$set_status_abnormal (rmc$resource_management_id, dme$operator_stop, terminate_reason, status);
      ELSE
      CASEND;

    PROCEND menu_for_tape_maintenance_mount;
?? OLDTITLE ??

    VAR
      configured: boolean,
      definition: cmt$element_definition,
      element_descriptor: cmt$element_descriptor,
      element_name: cmt$element_name,
      element_reservation: cmt$element_reservation,
      iou_information_table: dst$iou_information_table,
      iou_number: dst$iou_number,
      job_found: boolean,
      job_name: jmt$system_supplied_name,
      local_status: ost$status,
      lun: iot$logical_unit,
      number_of_ious: dst$number_of_ious,
      peripheral_index: integer,
      physical_id: cmt$physical_identification,
      tape_unit_assigned: boolean,
      user_job_name: jmt$user_supplied_name;

    status.normal := TRUE;
    tape_unit_assigned := FALSE;

  /main_program/
    BEGIN
      pmp$get_job_names (user_job_name, job_name, status);

      element_descriptor.element_type := cmc$storage_device_element;
      element_descriptor.peripheral_descriptor := storage_device;

      element_reservation.element_type := cmc$storage_device_element;
      element_reservation.peripheral_descriptor := storage_device;

      IF NOT element_descriptor.peripheral_descriptor.use_logical_identification THEN
        dsp$retrieve_iou_information (number_of_ious, iou_information_table);

{ Only use the user passed in IOU if the system has more than 1 IOU.  If the
{ system has only 1 IOU, force the IOU to IOU0.

        IF number_of_ious = 1 THEN
          cmp$convert_iou_number (iou_information_table [1].physical_iou_number,
                element_descriptor.peripheral_descriptor.hardware_address.iou, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
          element_reservation.peripheral_descriptor.hardware_address.iou :=
                element_descriptor.peripheral_descriptor.hardware_address.iou;
        ELSE { validate IOU passed in is a valid name
          cmp$convert_iou_name (element_descriptor.peripheral_descriptor.hardware_address.iou, iou_number,
                status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;
      IFEND;

      configured := FALSE;
      cmp$get_element_definition (element_descriptor, definition, status);

      IF NOT status.normal THEN
        IF (status.condition = cme$lcm_element_not_found) OR
              (status.condition = cme$lcm_element_name_not_found) THEN
          status.normal := TRUE;
        ELSE
          EXIT /main_program/;
        IFEND;
      ELSE

        IF element_descriptor.element_type <> definition.element_type THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$element_not_storage_device,
                'CMP$MOUNT_STORAGE_MEDIUM', status);
          EXIT /main_program/;
        IFEND;
        configured := TRUE;

        IF NOT storage_device.use_logical_identification THEN
          element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
          element_descriptor.peripheral_descriptor.element_name := definition.element_name;
          element_reservation.peripheral_descriptor.use_logical_identification := TRUE;
          element_reservation.peripheral_descriptor.element_name := definition.element_name;
        IFEND;

      IFEND;

      IF configured THEN
        cmp$search_peripheral_table (element_descriptor, element_reservation, FALSE, peripheral_index,
              status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      ELSE
        cmp$search_peripheral_table (element_descriptor, element_reservation, TRUE, peripheral_index, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

    /validate_job_name/
      BEGIN

{ NOTE : Malet/ve will NOT use CMP$MOUNT_STORAGE_MEDIUM for MASS storage device, but
{        the feature is still IMPLEMENTED here (recommended by A. J. Lawson).

{ At present, CMP$MOUNT_STORAGE_MEDIUM is allowed on a MASS storage device reserved
{ either by CMP$RESERVE_ELEMENT or DEDICATED MSP$REQUEST_MAINTENANCE_ACCESS. If a job
{ does CMP$MOUNT_STORAGE_MEDIUM more than one on the same MASS storage device,
{ CME$LCM_DEVICE_ATTACHED_TO_JOB is NOT issued as it IS for TAPE storage device.

{ NOTE : Malet/ve will NOT use CMP$MOUNT_STORAGE_MEDIUM for MASS storage device, but
{        the feature is still IMPLEMENTED here (recommended by A. J. Lawson).

        IF cmv$peripheral_element_table.pointer^ [peripheral_index].entry_interlock THEN
          IF cmv$peripheral_element_table.pointer^ [peripheral_index].reserved_status THEN
            IF cmv$peripheral_element_table.pointer^ [peripheral_index].reserved_job <> job_name THEN
              cmp$format_error_message (element_descriptor, {not used} physical_id, FALSE,
                    cme$element_already_reserved, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    cmv$peripheral_element_table.pointer^ [peripheral_index].reserved_job, status);
              EXIT /main_program/;
            ELSE
              IF configured THEN
                cmp$get_logical_unit_number (cmv$peripheral_element_table.pointer^ [peripheral_index].
                      element_name, lun, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
                IF cmv$logical_unit_table^ [lun].status.assignable_device THEN
                  IF cmv$logical_unit_table^ [lun].status.assigned THEN
                    IF cmv$logical_unit_table^ [lun].status.assigned_jsn = job_name THEN
                      osp$set_status_abnormal (cmc$configuration_management_id,
                            cme$lcm_device_attached_to_job, cmv$peripheral_element_table.
                            pointer^ [peripheral_index].element_name, status);
                      EXIT /main_program/;
                    ELSE
                      osp$set_status_abnormal (cmc$configuration_management_id, mse$element_already_assigned,
                            cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
                      osp$append_status_parameter (osc$status_parameter_delimiter,
                            cmv$logical_unit_table^ [lun].status.assigned_jsn, status);
                      EXIT /main_program/;
                    IFEND;
                  ELSE
                    EXIT /validate_job_name/;
                  IFEND;
                IFEND;
              ELSE
                EXIT /validate_job_name/;
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        CASE cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.access OF
        = msc$dedicated_access =
          IF cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.dedicated_accessor.
                active THEN
            IF cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.
                  dedicated_accessor.job_identification <> job_name THEN
              cmp$format_error_message (element_descriptor, {not used} physical_id, FALSE,
                    mse$dedicated_access_granted, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.
                    dedicated_accessor.job_identification, status);
              EXIT /main_program/;
            ELSE

              IF configured THEN
                cmp$get_logical_unit_number (cmv$peripheral_element_table.pointer^ [peripheral_index].
                      element_name, lun, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
                IF cmv$logical_unit_table^ [lun].status.assignable_device THEN
                  IF cmv$logical_unit_table^ [lun].status.assigned THEN
                    IF cmv$logical_unit_table^ [lun].status.assigned_jsn = job_name THEN
                      osp$set_status_abnormal (cmc$configuration_management_id,
                            cme$lcm_device_attached_to_job, cmv$peripheral_element_table.
                            pointer^ [peripheral_index].element_name, status);
                      EXIT /main_program/;
                    ELSE
                      osp$set_status_abnormal (cmc$configuration_management_id, mse$element_already_assigned,
                            cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
                      osp$append_status_parameter (osc$status_parameter_delimiter,
                            cmv$logical_unit_table^ [lun].status.assigned_jsn, status);
                      EXIT /main_program/;
                    IFEND;
                  ELSE
                    EXIT /validate_job_name/;
                  IFEND;
                IFEND;
              ELSE
                EXIT /validate_job_name/;
              IFEND;
            IFEND;
          IFEND;

        = msc$concurrent_access =

          msp$search_con_access_job (peripheral_index, job_name, job_found, status);
          IF NOT job_found THEN
            cmp$format_error_message (element_descriptor, {not used} physical_id, FALSE,
                  cme$reserve_request_required, status);
            EXIT /main_program/;
          IFEND;

          IF configured THEN
            cmp$get_logical_unit_number (cmv$peripheral_element_table.pointer^ [peripheral_index].
                  element_name, lun, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

{ CMP$MOUNT_STORAGE_MEDIUM is not allowed on MASS storage device which
{ is the object of CONCURRENT MSP$REQUEST_MAINTENANCE_ACCESS.

            IF NOT cmv$logical_unit_table^ [lun].status.assignable_device THEN
              osp$set_status_abnormal (cmc$configuration_management_id, cme$mount_media_denied,
                    cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
              EXIT /main_program/;
            IFEND;

            IF cmv$logical_unit_table^ [lun].status.assignable_device THEN
              IF cmv$logical_unit_table^ [lun].status.assigned THEN
                IF cmv$logical_unit_table^ [lun].status.assigned_jsn = job_name THEN
                  osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_device_attached_to_job,
                        cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
                  EXIT /main_program/;
                ELSE
                  IF wait_for_attachment.wait = osc$nowait THEN
                    osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_device_busy,
                          cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
                    osp$append_status_parameter (osc$status_parameter_delimiter,
                          cmv$logical_unit_table^ [lun].status.assigned_jsn, status);
                    EXIT /main_program/;
                  ELSEIF wait_for_attachment.wait = osc$wait THEN

                  /wait_for_device_unattached/
                    REPEAT
                      pmp$long_term_wait (5000, 5000);
                      CYCLE /wait_for_device_unattached/;
                    UNTIL (NOT cmv$logical_unit_table^ [lun].status.assigned) AND
                          (cmv$logical_unit_table^ [lun].status.assigned_jsn = ' ');
                  IFEND;
                  ;
                IFEND;
              IFEND;
            IFEND;
          IFEND;

        CASEND;

      END /validate_job_name/;

      element_name := element_reservation.peripheral_descriptor.element_name;

      IF configured AND cmv$logical_unit_table^ [lun].status.assignable_device THEN
        rmp$assign_tape_unit (dmv$null_sfid, element_name, $cmt$element_states [cmc$down],
              {label_type} amc$unlabelled, lun, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      tape_unit_assigned := TRUE;

    /operator_menu/
      BEGIN
        menu_for_tape_maintenance_mount (status);
        IF NOT status.normal THEN
          IF ((status.condition = dme$termination_condition) OR (status.condition = dme$operator_stop)) THEN
            EXIT /operator_menu/;
          IFEND;
        IFEND;

      END /operator_menu/;

    END /main_program/;

    IF NOT status.normal AND tape_unit_assigned THEN
      rmp$release_tape_unit (dmv$null_sfid, lun, {delete_request_from_vsn_queue} FALSE, local_status);
    IFEND;

  PROCEND cmp$mount_storage_medium;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$release_element', EJECT ??
*copyc cmh$release_element

  PROCEDURE [XDCL, #GATE] cmp$release_element
    (    element: ARRAY [ * ] OF cmt$element_reservation;
     VAR status: ost$status);

    VAR
      definition: cmt$element_definition,
      element_descriptor: cmt$element_descriptor,
      element_reservation: cmt$element_reservation,
      index: integer,
      iou_information_table: dst$iou_information_table,
      iou_number: dst$iou_number,
      job_name: jmt$system_supplied_name,
      local_status: ost$status,
      lun: integer,
      mainframe_id: pmt$mainframe_id,
      number_of_ious: dst$number_of_ious,
      peripheral_index: integer,
      physical_id: cmt$physical_identification,
      system_caller: boolean,
      user_job_name: jmt$user_supplied_name;

    status.normal := TRUE;
    system_caller := osp$is_caller_system_privileged ();
    IF (cmv$peripheral_element_table.pointer = NIL) OR (cmv$logical_pp_table_p = NIL) THEN
      osp$set_status_condition (cme$cm_table_empty, status);
      RETURN;
    IFEND;

    pmp$get_job_names (user_job_name, job_name, status);
    pmp$get_mainframe_id (mainframe_id, status);
    dsp$retrieve_iou_information (number_of_ious, iou_information_table);

   /for_loop/
    FOR index := LOWERBOUND (element) TO UPPERBOUND (element) DO
      element_descriptor.element_type := element [index].element_type;
      element_reservation := element [index];

      CASE element_reservation.element_type OF
      = cmc$pp_element =
        release_pp_element (job_name, system_caller, mainframe_id, number_of_ious, iou_information_table,
              element_reservation, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = cmc$data_channel_element, cmc$channel_adapter_element, cmc$controller_element,
            cmc$storage_device_element, cmc$communications_element =

        CASE element_descriptor.element_type OF
        = cmc$data_channel_element =
          element_descriptor.channel_descriptor := element_reservation.channel_descriptor;
          IF number_of_ious = 1 THEN
            cmp$convert_iou_number (iou_information_table [1].physical_iou_number,
                  element_descriptor.channel_descriptor.iou, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            element_reservation.channel_descriptor.iou := element_descriptor.channel_descriptor.iou;
          ELSE
            cmp$convert_iou_name (element_descriptor.channel_descriptor.iou, iou_number, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

        = cmc$controller_element, cmc$storage_device_element, cmc$external_processor_element,
              cmc$channel_adapter_element, cmc$communications_element =
          element_descriptor.peripheral_descriptor := element_reservation.peripheral_descriptor;
          IF NOT element_descriptor.peripheral_descriptor.use_logical_identification THEN
            IF number_of_ious = 1 THEN
              cmp$convert_iou_number (iou_information_table [1].physical_iou_number,
                    element_descriptor.peripheral_descriptor.hardware_address.iou, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              element_reservation.peripheral_descriptor.hardware_address.iou :=
                    element_descriptor.peripheral_descriptor.hardware_address.iou;
            ELSE
              cmp$convert_iou_name (element_descriptor.peripheral_descriptor.hardware_address.iou,
                    iou_number, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        ELSE
        CASEND;

        cmp$get_element_definition (element_descriptor, definition, status);
        IF NOT status.normal THEN { not in physical configuration
          IF (status.condition <> cme$lcm_element_name_not_found) AND
                (status.condition <> cme$lcm_element_not_found) THEN
            RETURN;
          IFEND;
          cmp$search_peripheral_table (element_descriptor, element_reservation, TRUE, peripheral_index,
                status);
          IF NOT status.normal THEN
            IF status.condition = cme$cm_element_not_found THEN
              cmp$format_error_message (element_descriptor, {not used} physical_id, FALSE,
                    cme$element_not_reserved, status);
            IFEND;
            RETURN;
          IFEND;
          cmp$unmark_element_reserved (element_reservation, job_name, system_caller, peripheral_index,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          release_channel_resource (element_descriptor, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          CYCLE /for_loop/;
        IFEND;

        { The code from here on is only reached if the element is in the configuration.

        IF element_reservation.element_type <> definition.element_type THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$incorrect_element_type,
                definition.element_name, status);
          RETURN;
        IFEND;

        CASE element_reservation.element_type OF
        = cmc$data_channel_element =
          IF NOT element_reservation.channel_descriptor.use_logical_identification THEN
            element_descriptor.channel_descriptor.use_logical_identification := TRUE;
            element_descriptor.channel_descriptor.name := definition.element_name;
          IFEND;
        = cmc$controller_element, cmc$storage_device_element, cmc$external_processor_element,
              cmc$channel_adapter_element, cmc$communications_element =
          IF NOT element_reservation.peripheral_descriptor.use_logical_identification THEN
            element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
            element_descriptor.peripheral_descriptor.element_name := definition.element_name;
          IFEND;
        ELSE
        CASEND;

        cmp$search_peripheral_table (element_descriptor, element_reservation, FALSE, peripheral_index,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        cmp$unmark_element_reserved (element_reservation, job_name, system_caller, peripheral_index,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        release_channel_resource (element_descriptor, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF cmv$peripheral_element_table.pointer^ [peripheral_index].physical_descriptor.element_type =
              cmc$storage_device_element THEN
          lun := cmv$peripheral_element_table.pointer^ [peripheral_index].logical_unit_number;
          IF cmv$logical_unit_table^ [lun].status.assignable_device THEN
            rmp$release_tape_unit (dmv$null_sfid, lun, {delete_request_from_vsn_queue} FALSE, local_status);
          IFEND;
        IFEND;

      ELSE
      CASEND;
    FOREND /for_loop/;

  PROCEND cmp$release_element;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$reserve_element', EJECT ??
*copyc cmh$reserve_element

  PROCEDURE [XDCL, #GATE] cmp$reserve_element
    (VAR {input,output} element: ARRAY [ * ] OF cmt$element_reservation;
     VAR status: ost$status);

    VAR
      channel_definition: cmt$data_channel_definition,
      channel_index: integer,
      channel_name: cmt$element_name,
      channel: cmt$physical_channel,
      channel_ordinal: cmt$channel_ordinal,
      definition: cmt$element_definition,
      element_description: cmt$element_descriptor,
      element_descriptor: cmt$element_descriptor,
      element_index: integer,
      element_entry: boolean,
      element_lock: boolean,
      element_reservation: cmt$element_reservation,
      entry_index: integer,
      found: boolean,
      gtid: ost$global_task_id,
      ignore_status: ost$status,
      index: integer,
      iou_number: dst$iou_number,
      iou_definition: cmt$iou_definition,
      iou_information_table: dst$iou_information_table,
      job_name: jmt$system_supplied_name,
      len: integer,
      mainframe_id: pmt$mainframe_id,
      number_of_ious: dst$number_of_ious,
      peripheral_index: integer,
      physical_id: cmt$physical_identification,
      physical_pp: dst$iou_resource,
      pp_number: string (13),
      privileged_job: boolean,
      released_elements_p: ^ARRAY [ * ] OF cmt$element_reservation,
      release_index: integer,
      release_status: ost$status,
      system_caller: boolean,
      user_job_name: jmt$user_supplied_name,
      valid: boolean;

    status.normal := TRUE;
    element_lock := FALSE;

    system_caller := osp$is_caller_system_privileged ();

    IF (cmv$peripheral_element_table.pointer = NIL) OR (cmv$logical_pp_table_p = NIL) THEN
      osp$set_status_condition (cme$cm_table_empty, status);
      RETURN;
    IFEND;

    pmp$get_job_names (user_job_name, job_name, status);
    pmp$get_mainframe_id (mainframe_id, status);

    { Determine if caller is allowed to reserve more elements.

    IF NOT system_caller THEN

      { Serialize the acquisition of new elements.

      cmp$set_element_lock (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      element_lock := TRUE;

      FOR index := 1 TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
        IF cmv$peripheral_element_table.pointer^ [index].entry_interlock AND
              cmv$peripheral_element_table.pointer^ [index].reserved_status AND
              (cmv$peripheral_element_table.pointer^ [index].reserved_job = job_name) AND
              (NOT cmv$peripheral_element_table.pointer^ [index].reserved_by_system) THEN
          FOR element_index := LOWERBOUND (element) TO UPPERBOUND (element) DO
            IF element [element_index].element_type <> cmc$pp_element THEN
              osp$set_status_abnormal (cmc$configuration_management_id, cme$reserve_not_permitted,
                    'a CHANNEL or a PERIPHERAL ELEMENT', status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    'a CHANNEL or a PERIPHERAL ELEMENT', status);
              cmp$clear_element_lock (ignore_status);
              RETURN;
            IFEND;
          FOREND;
        IFEND;
      FOREND;

      FOR index := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
        IF NOT cmv$logical_pp_table_p^ [index].flags.entry_reserved_by_nosve AND
              cmv$logical_pp_table_p^ [index].flags.entry_in_use AND
              cmv$logical_pp_table_p^ [index].flags.entry_reserved_by_other AND
              (cmv$logical_pp_table_p^ [index].task_info.reserved_job_name = job_name) AND
              NOT cmv$logical_pp_table_p^ [index].flags.entry_reserved_by_system_job THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$reserve_not_permitted, 'a PP',
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'a PP or a CHANNEL or a PERIPHERAL ELEMENT', status);
          cmp$clear_element_lock (ignore_status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    pmp$get_executing_task_gtid (gtid);
    dsp$retrieve_iou_information (number_of_ious, iou_information_table);

   /for_loop/
    FOR index := LOWERBOUND (element) TO UPPERBOUND (element) DO
      element_descriptor.element_type := element [index].element_type;
      element_reservation := element [index];

      CASE element_reservation.element_type OF
      = cmc$pp_element =
        reserve_pp_element (gtid, job_name, system_caller, mainframe_id, number_of_ious,
              iou_information_table, element_reservation, status);
        IF NOT status.normal THEN
          EXIT /for_loop/;
        IFEND;
        element [index].pp_reservation.acquired_pp_identification :=
              element_reservation.pp_reservation.acquired_pp_identification;

      = cmc$data_channel_element, cmc$channel_adapter_element, cmc$controller_element,
            cmc$storage_device_element, cmc$communications_element =

        CASE element_descriptor.element_type OF
        = cmc$data_channel_element =
          element_descriptor.channel_descriptor := element_reservation.channel_descriptor;
          IF number_of_ious = 1 THEN
            cmp$convert_iou_number (iou_information_table [1].physical_iou_number,
                  element_descriptor.channel_descriptor.iou, status);
            IF NOT status.normal THEN
              EXIT /for_loop/;
            IFEND;
            element_reservation.channel_descriptor.iou := element_descriptor.channel_descriptor.iou;
          ELSE
            cmp$convert_iou_name (element_descriptor.channel_descriptor.iou, iou_number, status);
            IF NOT status.normal THEN
              EXIT /for_loop/;
            IFEND;
          IFEND;

        = cmc$controller_element, cmc$storage_device_element, cmc$external_processor_element,
              cmc$channel_adapter_element, cmc$communications_element =
          element_descriptor.peripheral_descriptor := element_reservation.peripheral_descriptor;
          IF NOT element_descriptor.peripheral_descriptor.use_logical_identification THEN
            IF number_of_ious = 1 THEN
              cmp$convert_iou_number (iou_information_table [1].physical_iou_number,
                    element_descriptor.peripheral_descriptor.hardware_address.iou, status);
              IF NOT status.normal THEN
                EXIT /for_loop/;
              IFEND;
              element_reservation.peripheral_descriptor.hardware_address.iou :=
                    element_descriptor.peripheral_descriptor.hardware_address.iou;
            ELSE
              cmp$convert_iou_name (element_descriptor.peripheral_descriptor.hardware_address.iou,
                    iou_number, status);
              IF NOT status.normal THEN
                EXIT /for_loop/;
              IFEND;
            IFEND;
          IFEND;
        ELSE
        CASEND;

        { Determine if the element (or physical path) is in the active physical configuration. If the
        { element is in the configuration, continue with the validation process.  If the element or path
        { is not in the configuration, one of the following will occur:
        {   - Return an error immediately if the reserve request is by logical_identification and the
        {     element requested is not a channel element.
        {   - Return an error immediately if the reserve request is from a system process
        {     (i.e. NAM/VE or RHF).
        {   - Reserve a channel element if it is not already reserved to a job or to the NOS/VE system.
        {   - Reserve a physical path without any further validation.
        {  -  If the element which is not in the active configuration is a CIO channel and one of the other
        {     possible names of the channel IS in the active configuration,  the validation will continue
        {     following the rules for an element in the configuration.

        cmp$get_element_definition (element_descriptor, definition, status);

        IF NOT status.normal THEN {not in physical configuration}
          IF (status.condition <> cme$lcm_element_not_found) AND
                (status.condition <> cme$lcm_element_name_not_found) THEN
            EXIT /for_loop/;
          IFEND;

          IF (system_caller OR ((element_reservation.element_type <> cmc$data_channel_element) AND
                (element_reservation.peripheral_descriptor.use_logical_identification))) THEN
            EXIT /for_loop/;
          IFEND;

          cmp$search_peripheral_table (element_descriptor, element_reservation, TRUE, peripheral_index,
                status);
          IF status.normal THEN
            IF (element_reservation.element_type = cmc$data_channel_element) AND
                  NOT cmv$peripheral_element_table.pointer^ [peripheral_index].entry_interlock AND
                  (cmv$peripheral_element_table.pointer^ [peripheral_index].element_name (1, 3) = 'CCH') THEN

              { To reach this point means that the requested CIO channel was not in the configuration,
              { however, one of its aliases was.  The validation must continue following the rules for
              { a channel in the configuration.

              element_descriptor.channel_descriptor.use_logical_identification := TRUE;
              element_descriptor.channel_descriptor.name :=
                    cmv$peripheral_element_table.pointer^ [peripheral_index].element_name;
            ELSE
              cmp$format_error_message (element_descriptor, {not used} physical_id, FALSE,
                    cme$element_already_reserved, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    cmv$peripheral_element_table.pointer^ [peripheral_index].reserved_job, status);
              EXIT /for_loop/;
            IFEND;

          ELSE { element is not already reserved
            IF status.condition <> cme$cm_element_not_found THEN
              EXIT /for_loop/;
            IFEND;
            IF element_reservation.element_type = cmc$data_channel_element THEN
              cmp$get_channel_definition (element_descriptor.channel_descriptor, channel_definition,
                    status);
              IF NOT status.normal AND (status.condition <> cme$lcm_element_not_found) THEN
                EXIT /for_loop/;
              IFEND;
              cmp$get_iou_definition (element_descriptor.channel_descriptor.iou, iou_definition, status);
              IF NOT status.normal THEN
                EXIT /for_loop/;
              IFEND;
              IF ((channel_definition.number >= 12) AND (channel_definition.number <= 15)) OR
                    ((channel_definition.number > 25) AND (channel_definition.concurrent)) OR
                    ((iou_definition.kind = dsc$imn_i4_44_model) AND (channel_definition.number <= 1)) THEN
                cmp$convert_channel_number (channel_definition.number, channel_definition.concurrent,
                      channel_definition.port, channel_ordinal, channel_name, valid);
                osp$set_status_abnormal (cmc$configuration_management_id, cme$element_not_reservable,
                      channel_name, status);
                EXIT /for_loop/;
              IFEND;
              cmp$convert_iou_name (channel_definition.iou, iou_number, status);
              IF NOT status.normal THEN
                EXIT /for_loop/;
              IFEND;
              channel.number := channel_definition.number;
              channel.concurrent := channel_definition.concurrent;
              channel.port := channel_definition.port;
              cmp$acquire_resources (dsc$rrt_get_channel, channel, iou_number, 0, 0, FALSE, FALSE, FALSE,
                    physical_pp, status);
              IF NOT status.normal THEN
                EXIT /for_loop/;
              IFEND;
            IFEND;
            cmp$mark_element_reserved (element_reservation, system_caller, job_name, gtid, physical_pp,
                  peripheral_index, FALSE, status);
            IF NOT status.normal THEN
              release_channel_resource (element_descriptor, release_status);
              EXIT /for_loop/;
            IFEND;
            CYCLE /for_loop/;
          IFEND;

        ELSE {element is in physical configuration
          IF element_reservation.element_type <> definition.element_type THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$incorrect_element_type,
                  definition.element_name, status);
            EXIT /for_loop/;
          IFEND;

          CASE element_reservation.element_type OF
          = cmc$data_channel_element =
            IF NOT element_reservation.channel_descriptor.use_logical_identification THEN
              element_descriptor.channel_descriptor.use_logical_identification := TRUE;
              element_descriptor.channel_descriptor.name := definition.element_name;
            IFEND;

          = cmc$controller_element, cmc$storage_device_element, cmc$external_processor_element,
                cmc$channel_adapter_element, cmc$communications_element =
            IF NOT element_reservation.peripheral_descriptor.use_logical_identification THEN
              element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
              element_descriptor.peripheral_descriptor.element_name := definition.element_name;
            IFEND;
          ELSE
          CASEND;
          cmp$search_peripheral_table (element_descriptor, element_reservation, FALSE, peripheral_index,
                status);
          IF NOT status.normal THEN
            EXIT /for_loop/;
          IFEND;
        IFEND; { in physical configuration

        { The code from here on is only reached if the element is in the configuration.
        { Check if element is already the object of either dedicated or concurrent access.

        CASE cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.access OF
        = msc$concurrent_access =
          IF cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.
                con_access_job_list <> NIL THEN
            osp$set_status_abnormal (cmc$configuration_management_id, mse$concurrent_access_granted,
                  cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.
                  con_access_job_list^.job_name, status);
            EXIT /for_loop/;
          IFEND;
        = msc$dedicated_access =
          IF cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.
                dedicated_accessor.active THEN
            osp$set_status_abnormal (cmc$configuration_management_id, mse$dedicated_access_granted,
                  cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.
                  dedicated_accessor.job_identification, status);
            EXIT /for_loop/;
          IFEND;
        ELSE
        CASEND;

        CASE element_reservation.element_type OF
        = cmc$data_channel_element =

          { Check to see if channel is already reserved.

          IF cmv$peripheral_element_table.pointer^ [peripheral_index].entry_interlock THEN
            cmp$format_error_message (element_descriptor, {not used} physical_id, FALSE,
                  cme$element_already_reserved, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  cmv$peripheral_element_table.pointer^ [peripheral_index].reserved_job, status);
            EXIT /for_loop/;
          IFEND;

          { Check to see if CHANNEL is in ON STATE.

          IF cmv$peripheral_element_table.pointer^ [peripheral_index].element_status.state <> cmc$on THEN
            cmp$format_error_message (element_descriptor, {not_used} physical_id, FALSE,
                  cme$element_state_not_proper, status);
            EXIT /for_loop/;
          IFEND;

          cmp$get_channel_definition (element_descriptor.channel_descriptor, channel_definition, status);
          IF NOT status.normal AND (status.condition <> cme$lcm_element_not_found) THEN
            EXIT /for_loop/;
          IFEND;

          { Check to see if no logically configured elements in ON STATE connected to the channel.
          { This check is not performed if the caller is from a system segment.

          IF NOT system_caller THEN
            search_connected_elements (channel_definition, element_descriptor.channel_descriptor.name,
                  status);
            IF NOT status.normal THEN
              EXIT /for_loop/;
            IFEND;
          IFEND;

          cmp$convert_iou_name (channel_definition.iou, iou_number, status);
          IF NOT status.normal THEN
            EXIT /for_loop/;
          IFEND;
          channel.number := channel_definition.number;
          channel.concurrent := channel_definition.concurrent;
          channel.port := channel_definition.port;
          cmp$acquire_resources (dsc$rrt_get_channel, channel, iou_number, 0, 0, FALSE, FALSE, FALSE,
                physical_pp, status);
          IF NOT status.normal THEN
            EXIT /for_loop/;
          IFEND;

        = cmc$controller_element, cmc$storage_device_element, cmc$external_processor_element,
              cmc$channel_adapter_element, cmc$communications_element =

          { Check to see if element is in ON state.

          IF cmv$peripheral_element_table.pointer^ [peripheral_index].element_status.state <> cmc$on THEN
            cmp$format_error_message (element_descriptor, {not used} physical_id, FALSE,
                  cme$element_state_not_proper, status);
            EXIT /for_loop/;
          IFEND;

          { Check to see if element is reservable.

          IF (cmv$peripheral_element_table.pointer^ [peripheral_index].reservable_element =
                cmc$not_reservable) OR
                ((cmv$peripheral_element_table.pointer^ [peripheral_index].reservable_element =
                cmc$reservable_only_by_system) AND (NOT system_caller)) THEN
            cmp$format_error_message (element_descriptor, {not used} physical_id, FALSE,
                  cme$element_not_reservable, status);
            EXIT /for_loop/;
          IFEND;

        ELSE
        CASEND;

        cmp$mark_element_reserved (element_reservation, system_caller, job_name, gtid, physical_pp,
              peripheral_index, FALSE, status);
        IF NOT status.normal THEN
          release_channel_resource (element_descriptor, release_status);
          EXIT /for_loop/;
        IFEND;

      ELSE
      CASEND;

    FOREND /for_loop/;

    { If status is abnormal, release any successful elements that were reserved.

    IF NOT status.normal AND (index > LOWERBOUND (element)) THEN
      PUSH released_elements_p: [LOWERBOUND (element) .. index - 1];
      FOR release_index := LOWERBOUND (element) TO index - 1 DO
        released_elements_p^ [release_index] := element [release_index];
      FOREND;
      cmp$release_element (released_elements_p^, release_status);
    IFEND;

    IF element_lock THEN
      cmp$clear_element_lock (ignore_status);
    IFEND;

  PROCEND cmp$reserve_element;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$resume_pp', EJECT ??
*copyc cmh$resume_pp

  PROCEDURE [XDCL, #GATE] cmp$resume_pp
    (    pp_identification: cmt$pp_identification;
         hardware_resume_pp: boolean;
         start_address: cmt$pp_memory_length;
     VAR pp_software_resumed: boolean;
     VAR status: ost$status);

    VAR
      found: boolean,
      job_name: jmt$system_supplied_name,
      pp_entry_index: iot$pp_number,
      physical_pp: dst$iou_resource,
      system_caller: boolean,
      user_job_name: jmt$user_supplied_name;


    system_caller := osp$is_caller_system_privileged ();
    status.normal := TRUE;
    pp_software_resumed := FALSE;

    cmp$convert_pp_ordinal (pp_identification.ordinal, physical_pp);
    cmp$convert_iou_name (pp_identification.iou, physical_pp.iou_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_job_names (user_job_name, job_name, status);
    validate_pp_reserved (system_caller, job_name, physical_pp, pp_identification.iou (1, 5),
          pp_entry_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF hardware_resume_pp THEN
      cmp$hardware_resume_pp (physical_pp, start_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    cmp$send_pp_command (pp_entry_index, cmc$resume_command, pp_software_resumed, status);


    IF pp_software_resumed THEN
      cmp$free_pp_request (pp_entry_index);
    IFEND;

  PROCEND cmp$resume_pp;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$task_termination_cleanup', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$task_termination_cleanup;

    VAR
      con_access_gtid_list: mst$con_access_gtid_list,
      configured: boolean,
      element_descriptor: cmt$element_descriptor,
      element_found: boolean,
      element_index: integer,
      gtid: ost$global_task_id,
      hardware_address: cmt$hardware_address,
      index: integer,
      job_name: jmt$system_supplied_name,
      job_name_found: boolean,
      lun: iot$logical_unit,
      mainframe_id: pmt$mainframe_id,
      physical_pp: dst$iou_resource,
      pp_id: cmt$pp_identification,
      pp_software_idle: boolean,
      pp_registers: cmt$pp_registers,
      pp_memory_size: cmt$pp_memory_length,
      status: ost$status,
      user_name: jmt$user_supplied_name;

    IF cmv$peripheral_element_table.pointer = NIL THEN
      RETURN;
    IFEND;

    IF cmv$logical_pp_table_p = NIL THEN
      RETURN;
    IFEND;

    pmp$get_job_names (user_name, job_name, status);
    pmp$get_mainframe_id (mainframe_id, status);
    pmp$get_executing_task_gtid (gtid);

   /peripheral_loop/
    FOR index := 1 TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
      IF (cmv$peripheral_element_table.pointer^ [index].gtid.index <> gtid.index) OR
            (cmv$peripheral_element_table.pointer^ [index].gtid.seqno <> gtid.seqno) THEN
        CYCLE /peripheral_loop/;
      IFEND;

      { Do not release element if the task is a system process

      IF (cmv$peripheral_element_table.pointer^ [index].reserved_by_system) THEN
        CYCLE /peripheral_loop/;
      IFEND;

      configured := cmv$peripheral_element_table.pointer^ [index].physical_descriptor.configured;
      IF configured THEN
        element_descriptor.element_type := cmv$peripheral_element_table.pointer^ [index].
              physical_descriptor.element_type;
      ELSE
        IF cmv$peripheral_element_table.pointer^ [index].physical_descriptor.hardware_address.
              address_specifier = $cmt$physical_address_specifier [cmc$iou, cmc$channel] THEN
          element_descriptor.element_type := cmc$data_channel_element;
        ELSEIF cmv$peripheral_element_table.pointer^ [index].physical_descriptor.hardware_address.
              address_specifier =
              $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address] THEN
          element_descriptor.element_type := cmc$controller_element;
        ELSEIF cmv$peripheral_element_table.pointer^ [index].physical_descriptor.hardware_address.
              address_specifier = $cmt$physical_address_specifier
              [cmc$iou, cmc$channel, cmc$channel_address, cmc$unit_address] THEN
          element_descriptor.element_type := cmc$storage_device_element;
        IFEND;
      IFEND;

      IF element_descriptor.element_type = cmc$data_channel_element THEN

        { Set up rest of the element_descriptor for the release_channel_resource.  In the case of a channel,
        { the element name is always in the peripheral_element_table, even if the channel was reserved by
        { physical address.

        element_descriptor.channel_descriptor.use_logical_identification := TRUE;
        element_descriptor.channel_descriptor.name :=
              cmv$peripheral_element_table.pointer^ [index].element_name;
        IF cmv$peripheral_element_table.pointer^ [index].physical_descriptor.configured THEN
          cmp$convert_iou_number (cmv$peripheral_element_table.pointer^ [index].physical_descriptor.
                channel_path.iou, element_descriptor.channel_descriptor.iou, status);
        ELSE
          cmp$convert_iou_number (cmv$peripheral_element_table.pointer^ [index].physical_descriptor.
                hardware_address.iou, element_descriptor.channel_descriptor.iou, status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      { Unmark the cmv$peripheral_element_table.

      cmp$unmark_when_cleanup (index, mainframe_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      release_channel_resource (element_descriptor, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF configured THEN
        IF cmv$peripheral_element_table.pointer^ [index].physical_descriptor.element_type =
              cmc$storage_device_element THEN
          lun := cmv$peripheral_element_table.pointer^ [index].logical_unit_number;
          IF cmv$logical_unit_table^ [lun].status.assignable_device THEN
            rmp$release_tape_unit (dmv$null_sfid, lun, {delete_request_from_vsn_queue} FALSE, status);
          IFEND;
        IFEND;
      IFEND;
    FOREND /peripheral_loop/;

    con_access_gtid_list := msv$con_access_gtid_list;

    WHILE con_access_gtid_list <> NIL DO
      IF con_access_gtid_list^.gtid = gtid THEN
        element_index := con_access_gtid_list^.element_index;
        con_access_gtid_list := con_access_gtid_list^.forward_link;
        msp$delete_con_access_gtid (gtid, element_index, status);
        msp$search_element_con_accessed (element_index, element_found, status);
        IF NOT element_found THEN
          msp$search_con_access_job (element_index, job_name, job_name_found, status);
          IF job_name_found THEN
            IF cmv$peripheral_element_table.pointer^ [element_index].physical_descriptor.element_type =
                  cmc$storage_device_element THEN
              IF cmv$peripheral_element_table.pointer^ [element_index].logical_unit_number <> 0 THEN
                cmp$clear_unit_shared (cmv$peripheral_element_table.pointer^ [element_index].
                      logical_unit_number, TRUE);
              IFEND;
            IFEND;
            msp$delete_con_access_job (element_index, job_name, status);
          IFEND;
        IFEND;
        IF cmv$peripheral_element_table.pointer^ [element_index].physical_descriptor.element_type =
              cmc$storage_device_element THEN
          lun := cmv$peripheral_element_table.pointer^ [element_index].logical_unit_number;
          IF cmv$logical_unit_table^ [lun].status.assignable_device THEN
            rmp$release_tape_unit (dmv$null_sfid, lun, {delete_request_from_vsn_queue} FALSE, status);
          IFEND;
        IFEND;
      ELSE
        con_access_gtid_list := con_access_gtid_list^.forward_link;
      IFEND;
    WHILEND;

   /pp_loop/
    FOR index := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
      IF (cmv$logical_pp_table_p^ [index].task_info.gtid.index <> gtid.index) OR
            (cmv$logical_pp_table_p^ [index].task_info.gtid.seqno <> gtid.seqno) THEN
        CYCLE /pp_loop/;
      IFEND;

      { Do not release PP if the task is a system process

      IF cmv$logical_pp_table_p^ [index].flags.entry_reserved_by_system_job THEN
        CYCLE /pp_loop/;
      IFEND;

      { Unmark the logical pp table.

      physical_pp := cmv$logical_pp_table_p^ [index].pp_info.physical_pp;
      cmp$convert_pp_number (physical_pp, pp_id.ordinal);
      cmp$convert_iou_number (physical_pp.iou_number, pp_id.iou, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      cmp$idle_pp (pp_id, TRUE, TRUE, NIL, pp_memory_size, pp_registers, pp_software_idle, status);
      IF NOT status.normal THEN
        status.normal := TRUE;
      IFEND;

      cmp$release_pp_by_index (index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      { Clear all channel interlocks held by PP.

      cmp$clear_channel_interlock (physical_pp.iou_number, index, status);

      cmp$unmark_pp_when_cleanup (index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND /pp_loop/;

  PROCEND cmp$task_termination_cleanup;
?? OLDTITLE ??


  PROCEDURE [XDCL, #GATE] cmp$dummy_up_pp
    (VAR element_reservation: ARRAY [1 .. *] OF cmt$element_reservation;
     VAR program_description: ARRAY [1 .. *] OF cmt$pp_program_description;
     VAR status: ost$status);

    VAR
      ignore_status : ost$status,
      i: integer,
      break_interlock: boolean,
      stop: cell,
      kill: ^cell,
      hardware_idle: boolean,
      mem_size: cmt$pp_memory_length,
      ppr: cmt$pp_registers,
      idled: boolean,
      pp_program_description: array [1 .. 1] of cmt$pp_program_description;

    status.normal := TRUE;


     pp_program_description [1].pp_identification :=
        program_description [1].pp_identification;
     pp_program_description [1].iou_program_name := 'NERD';
     pp_program_description [1].pp_program := NIL;
     pp_program_description [1].master_pp :=
        program_description [1].master_pp;
     pp_program_description [1].element_access :=
        program_description [1].element_access;
     pp_program_description [1].communication_buffer_length :=
        program_description [1].communication_buffer_length;
     pp_program_description [1].communication_buffer :=
        program_description [1].communication_buffer;


{
{  Now a request is made to load the dummy PP driver into the PP reserved
{  in the lines above.
{

    cmp$execute_pp_program (pp_program_description, status);


      IF NOT status.normal THEN
        IF cmv$free_trap THEN
          stop := kill^;
        IFEND;
      IFEND;

{ Delay 10 seconds to allow name to appear in ved pa display.

  pmp$wait (10000,10000);

  break_interlock := true;
  hardware_idle := true;

  cmp$idle_pp (pp_program_description [1].pp_identification, break_interlock,
       hardware_idle, NIL, mem_size, ppr, idled, status);

      IF NOT idled THEN
         IF cmv$free_trap THEN
           stop := kill^;
         IFEND;
      IFEND;

  cmp$release_element(element_reservation,ignore_status);

  PROCEND cmp$dummy_up_pp;

MODEND cmm$manage_element_reservation;
*DECK DECK=CMM$MANAGE_INTERFACE_TABLES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE CM : Manage Interface Tables' ??
MODULE cmm$manage_interface_tables;

{ PURPOSE:
{   This module contains the procedures to build and manage I/O interface tables.  The Physical
{   Configuration Table and the State Info Table are used to build interface tables.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmc$logical_unit_constants
*copyc cmc$max_pp_per_iou
*copyc cme$logical_configuration_mgr
*copyc cme$manage_interface_tables
*copyc cme$physical_configuration_mgr
*copyc cme$reserve_element
*copyc cmk$keypoints
*copyc cmt$access_elements
*copyc cmt$channel_ordinal
*copyc cmt$device_information
*copyc cmt$element_connection
*copyc cmt$element_descriptor
*copyc cmt$element_reservation
*copyc cmt$element_state
*copyc cmt$hardware_address
*copyc cmt$lcu_lock
*copyc cmt$lcu_lock_type
*copyc cmt$physical_address_specifier
*copyc cmt$mass_storage_information
*copyc cmt$physical_configuration
*copyc cmt$physical_identification
*copyc cmt$pp_program_description
*copyc cmt$unit_type
*copyc dft$one_word_response_handler
*copyc dmc$cti_device_type_numbers
*copyc dmt$error_condition_codes
*copyc dst$device_path
*copyc dst$number_of_ious
*copyc iot$unit_interface_table
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc mmt$attribute_keyword
*copyc mmt$rma_list
*copyc nat$channel_descriptor
*copyc nat$network_descriptor
*copyc osd$virtual_address
*copyc ose$heap_full_exceptions
*copyc oss$mainframe_pageable
*copyc ost$spaa_entry
*copyc pmt$mainframe_id
?? POP ??
*copyc clp$convert_integer_to_string
*copyc cmp$convert_channel_number
*copyc cmp$convert_channel_ordinal
*copyc cmp$convert_iou_name
*copyc cmp$convert_iou_number
*copyc cmp$format_error_message
*copyc cmp$get_channel_def
*copyc cmp$get_controller_type
*copyc cmp$get_driver_info
*copyc cmp$get_element_name_via_lun
*copyc cmp$get_element_state
*copyc cmp$get_logical_unit_number
*copyc cmp$get_response_handler
*copyc cmp$get_unit_type
*copyc cmp$load_controller_module
*copyc cmp$pc_get_element
*copyc cmp$pc_get_logical_unit
*copyc cmp$pc_get_next_channel
*copyc cmp$retrieve_iou_definition
*copyc cmp$support_redundant_channel
*copyc dsp$allocate_continuous_memory
*copyc dsp$move_pp_driver
*copyc dsp$move_pp_overlays
*copyc dsp$retrieve_iou_information
*copyc i#real_memory_address
*copyc osp$append_status_parameter
*copyc osp$clear_signature_lock
*copyc osp$set_locked_variable
*copyc osp$set_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$system_error
*copyc osp$test_signature_lock
*copyc pmp$delay
*copyc pmp$get_job_names
*copyc pmp$zero_out_table
?? EJECT ??
*copyc cmv$assignable_device
*copyc cmv$configuration_activated
*copyc cmv$default_response_handler
*copyc cmv$iou_table_p
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc cmv$max_number_of_pp
*copyc cmv$peripheral_element_table
*copyc cmv$physical_configuration
*copyc cmv$state_info_table
*copyc osv$iou_external_interrupt
*copyc osv$mainframe_wired_cb_heap
*copyc osv$spi_response_processor
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  TYPE
    t$unit_descriptor = RECORD
      configured: boolean,
      channel: cmt$physical_channel,
      controller_number: cmt$physical_equipment_number,
      storage_directory_address: 0 .. 7,
      unit_number: 0 .. 1fff(16),
    RECEND;
?? EJECT ??
  VAR
    cmv$configuration_administrator: [XDCL, #GATE, oss$mainframe_pageable] cmt$lcu_lock := [[0],
          jmc$blank_system_supplied_name],
    cmv$element_reservation_lock: [XDCL, #GATE, oss$mainframe_pageable] ost$signature_lock,
    cmv$logical_pp_table_lock: [XDCL, #GATE, oss$mainframe_pageable] ost$signature_lock,
    cmv$logical_unit_lock: [XDCL, #GATE, oss$mainframe_pageable] ost$signature_lock,
    cmv$removable_media_operation: [XDCL, #GATE, oss$mainframe_pageable] cmt$lcu_lock := [[0],
          jmc$blank_system_supplied_name];
?? OLDTITLE ??
?? NEWTITLE := 'build_logical_unit_entry',EJECT ??

{ PURPOSE:
{   This procedure builds an entry in the logical unit table.  This procedure is called after the physical
{   configuration is installed and activated.

  PROCEDURE build_logical_unit_entry
    (    logical_unit: iot$logical_unit;
         unit_type: iot$unit_type;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      rma: integer,
      template_p: ^iot$unit_commun_buffer_template,
      unit_number_string: ost$string;

    status.normal := TRUE;

    IF logical_unit > UPPERBOUND (cmv$logical_unit_table^) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$it_pp_invalid_lun,
            'BUILD_LOGICAL_UNIT_ENTRY', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'unit_number =', status);
      clp$convert_integer_to_string (logical_unit, 10, FALSE, unit_number_string, ignore_status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            unit_number_string.value (1, unit_number_string.size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'Logical unit out of range', status);
      RETURN;
    IFEND;

    cmv$logical_unit_table^ [logical_unit].configured := TRUE;
    ALLOCATE cmv$logical_unit_table^ [logical_unit].unit_interface_table IN osv$mainframe_wired_cb_heap^;
    pmp$zero_out_table (#LOC (cmv$logical_unit_table^ [logical_unit].unit_interface_table^),
          #SIZE (cmv$logical_unit_table^ [logical_unit].unit_interface_table^));
    cmv$logical_unit_table^ [logical_unit].logical_unit_number := logical_unit;
    cmv$logical_unit_table^ [logical_unit].entry_interlock := FALSE;
    cmv$logical_unit_table^ [logical_unit].unit_interface_table^.logical_unit := logical_unit;
    cmv$logical_unit_table^ [logical_unit].unit_interface_table^.unit_type := unit_type;
    cmv$logical_unit_table^ [logical_unit].unit_interface_table^.next_request := NIL;

    { Element capability and element access needs to be initialized along with unit type by searching
    { the configuration.

    ALLOCATE template_p IN osv$mainframe_wired_cb_heap^;
    cmv$logical_unit_table^ [logical_unit].unit_communication_buffer_pva :=
          ^template_p^.unit_communication_buffer;
    pmp$zero_out_table (#LOC (cmv$logical_unit_table^ [logical_unit].unit_communication_buffer_pva^),
          #SIZE (cmv$logical_unit_table^ [logical_unit].unit_communication_buffer_pva^));

    i#real_memory_address (#LOC (cmv$logical_unit_table^ [logical_unit].unit_communication_buffer_pva^), rma);
    cmv$logical_unit_table^ [logical_unit].unit_interface_table^.unit_communication_buffer_rma := rma;
    cmv$logical_unit_table^ [logical_unit].unit_interface_table^.unit_commun_buffer_length :=
          ioc$unit_commun_buffer_length * 8;
    cmv$logical_unit_table^ [logical_unit].status.assignable_device := TRUE;
    cmv$logical_unit_table^ [logical_unit].element_access := $cmt$element_access [cmc$read, cmc$write];
    cmv$logical_unit_table^ [logical_unit].element_capability := $cmt$element_capabilities
          [cmc$volume_assignment, cmc$io_request_submission, cmc$dedicated_maintenance];

  PROCEND build_logical_unit_entry;
?? OLDTITLE ??
?? NEWTITLE := 'build_pp_interface_table', EJECT ??

{ PURPOSE:
{   This procedure builds the logical pp table for the boot, system core and the Physical Configuration.

  PROCEDURE build_pp_interface_table
    (    pp_count: iot$pp_number;
         requested_unit_count: iot$logical_unit;
         allocate_entire_configuration: boolean;
         actual_logical_unit_table_p: ^cmt$logical_unit_table;
     VAR actual_logical_pp_table_p: ^cmt$logical_pp_table;
     VAR status: ost$status);

    CONST
      c$extra_logical_pp = 10,
      procedure_name = 'BUILD_PP_INTERFACE_TABLE';

    TYPE
      t$cio_channel_used = RECORD
        configured: boolean,
        pp_index: iot$pp_number,
      RECEND;

    VAR
      channel_element_p: ^cmt$element_definition,
      cio_channel_used_p: ^ARRAY [0 .. *] OF ARRAY [ost$physical_channel_number] OF t$cio_channel_used,
      cip_driver_name: dst$driver_name,
      controller_element_p: ^cmt$element_definition,
      controller_type: cmt$controller_type,
      current_channel: 0 .. 0ff(16),
      dual_pp: boolean,
      found: boolean,
      io_unit_type: iot$unit_type,
      iou_definition: cmt$iou_definition,
      iou_information_table: dst$iou_information_table,
      iou_number: dst$iou_number,
      iou_program_name: pmt$program_name,
      local_status: ost$status,
      logical_pp_table_p: ^cmt$logical_pp_table,
      logical_unit_number: iot$logical_unit,
      low_unit: iot$logical_unit,
      max_unit_count: iot$logical_unit,
      number_of_ious: dst$number_of_ious,
      physical_eq_number: cmt$physical_equipment_number,
      physical_unit_number: cmt$physical_unit_number,
      pp: iot$pp_number,
      pp_index: iot$pp_number,
      pps_needed: 0 .. 0ff(16),
      prev_commun_buffer_p: ^iot$communication_buffer,
      table_size: iot$pp_number,
      table_unit_desc_p: ^iot$unit_descriptors,
      temp_unit_des_p: ^ARRAY [ * ] OF t$unit_descriptor,
      unit_class: cmt$unit_class,
      unit_element_p: ^cmt$element_definition,
      unit_type: cmt$unit_type,
      upper_unit: iot$logical_unit;

    status.normal := TRUE;
    #keypoint (osk$entry, pp_count * osk$m, cmk$build_pp_interface_table);

  /main_program/
    BEGIN
      max_unit_count := requested_unit_count + cmc$reserved_unit_count;
      PUSH temp_unit_des_p: [(cmc$reserved_unit_count + 1) .. max_unit_count];

      { Allocate the local Logical PP Table.  For the I4/I4S allocate extra logical PPs to allow PP
      { reservation if all slots are taken by system elements being turned OFF.  This is done only on I4/I4S
      { models because the maximum number of PP of 30 per iou is reached.

      IF allocate_entire_configuration THEN
        dsp$retrieve_iou_information (number_of_ious, iou_information_table);
        IF (iou_information_table [1].model_type = dsc$imn_i4_40_model) OR
             (iou_information_table [1].model_type = dsc$imn_i4_42_model) THEN
          table_size := (number_of_ious * cmc$max_pp_per_iou) + c$extra_logical_pp;
        ELSE
          table_size := number_of_ious * cmc$max_pp_per_iou;
        IFEND;
      ELSE
        table_size := pp_count;
      IFEND;
      ALLOCATE logical_pp_table_p: [1 .. table_size] IN osv$mainframe_wired_cb_heap^;
      pmp$zero_out_table (#LOC (logical_pp_table_p^), #SIZE (logical_pp_table_p^));
      FOR pp_index := 1 TO table_size DO
        logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p := NIL;
        logical_pp_table_p^ [pp_index].pp_info.pp_communication_buffer_p := NIL;
        logical_pp_table_p^ [pp_index].pp_info.channel_interlock_p := NIL;
        logical_pp_table_p^ [pp_index].pp_info.driver_code_p := NIL;
        logical_pp_table_p^ [pp_index].pp_info.saved_io_request_p := NIL;
        logical_pp_table_p^ [pp_index].handlers.response_handler_p := NIL;
        logical_pp_table_p^ [pp_index].handlers.one_word_response_handler_p := NIL;

        logical_pp_table_p^ [pp_index].task_info.gtid.index := 4095;
        logical_pp_table_p^ [pp_index].task_info.gtid.seqno := 255;
        logical_pp_table_p^ [pp_index].task_info.reserved_job_name := ' ';
        logical_pp_table_p^ [pp_index].pp_info.physical_pp.iou_number := 0;
        logical_pp_table_p^ [pp_index].pp_info.physical_pp.number := 33(8);
        logical_pp_table_p^ [pp_index].pp_info.physical_pp.channel_protocol := dsc$cpt_nio;
        logical_pp_table_p^ [pp_index].pp_info.driver_name := ' ';
        logical_pp_table_p^ [pp_index].pp_info.cip_driver_name := ' ';
        logical_pp_table_p^ [pp_index].controller_info.controller_type := cmc$null_controller;
      FOREND;
      cmv$logical_pp_table_lock.lock_id := 0;

      { Initialize the CIO channel used table.  This table is used to save the PP index number for CIO
      { channels with multiple ports.

      PUSH cio_channel_used_p: [0 .. UPPERBOUND (cmv$iou_table_p^)];
      pmp$zero_out_table (#LOC (cio_channel_used_p^), #SIZE (cio_channel_used_p^));

      pp := 1;
      current_channel := 0;

     /build_pp_table_loop/
      WHILE TRUE DO
        low_unit := ioc$max_unit_number;
        upper_unit := 0;

        { Retrieve a channel from the Physical Configuration, exit loop if no more were found.

        cmp$pc_get_next_channel (current_channel, channel_element_p, local_status);
        IF NOT local_status.normal THEN
          EXIT /build_pp_table_loop/;
        IFEND;
        current_channel := current_channel + 1;

        cmp$retrieve_iou_definition (channel_element_p^.data_channel.iou, iou_definition, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        IF ((channel_element_p^.data_channel.number >= 12) AND
              (channel_element_p^.data_channel.number <= 15)) OR
              ((channel_element_p^.data_channel.concurrent) AND
              (channel_element_p^.data_channel.number > 25)) OR
              ((iou_definition.kind = dsc$imn_i4_44_model) AND
              (channel_element_p^.data_channel.number <= 1)) OR
              ((iou_definition.kind = dsc$imn_i4_46_model) AND
              (channel_element_p^.data_channel.number <= 1)) THEN
          pp_interface_table_error (procedure_name, pp, channel_element_p^.data_channel.number, -1, -1,
                -1, cme$it_pp_invalid_channel, channel_element_p^.element_name, 'Invalid channel', status);
          EXIT /main_program/;
        IFEND;

        FOR logical_unit_number := LOWERBOUND (temp_unit_des_p^) TO UPPERBOUND (temp_unit_des_p^) DO
          temp_unit_des_p^ [logical_unit_number].configured := FALSE;
          temp_unit_des_p^ [logical_unit_number].channel.number := channel_element_p^.data_channel.number;
          temp_unit_des_p^ [logical_unit_number].channel.port := channel_element_p^.data_channel.port;
          temp_unit_des_p^ [logical_unit_number].channel.concurrent :=
                channel_element_p^.data_channel.concurrent;
          temp_unit_des_p^ [logical_unit_number].controller_number := 0;
          temp_unit_des_p^ [logical_unit_number].storage_directory_address := 0;
          temp_unit_des_p^ [logical_unit_number].unit_number := 0;
        FOREND;

       /equipment_number_loop/
        FOR physical_eq_number := LOWERVALUE (cmt$physical_equipment_number) TO
              UPPERVALUE (cmt$physical_equipment_number) DO
          IF NOT channel_element_p^.data_channel.connection.equipment [physical_eq_number].configured THEN
            CYCLE /equipment_number_loop/;
          IFEND;

          cmp$pc_get_element (
                channel_element_p^.data_channel.connection.equipment [physical_eq_number].element_name,
                channel_element_p^.data_channel.iou, controller_element_p, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

          CASE controller_element_p^.element_type OF
          = cmc$controller_element, cmc$external_processor_element =
            cmp$get_controller_type (controller_element_p^.product_id, controller_type, local_status);
            IF NOT local_status.normal THEN   { foreign device }
              CYCLE /build_pp_table_loop/;
            IFEND;
            IF controller_element_p^.element_type = cmc$controller_element THEN
              iou_program_name := controller_element_p^.controller.peripheral_driver_name;
            ELSE  { controller_element_p^.element_type = cmc$external_processor_element }
              iou_program_name := controller_element_p^.external_processor.peripheral_driver_name;
            IFEND;

          = cmc$channel_adapter_element, cmc$communications_element =

            { Do not build table entries for these devices.

            CYCLE /build_pp_table_loop/;
          ELSE
          CASEND;

          { Get physical unit numbers.

          IF controller_element_p^.element_type = cmc$controller_element THEN

           /unit_number_loop/
            FOR physical_unit_number := LOWERVALUE (physical_unit_number) TO
                  UPPERVALUE (physical_unit_number) DO
              IF NOT controller_element_p^.controller.connection.unit [physical_unit_number].configured THEN
                CYCLE /unit_number_loop/;
              IFEND;

              cmp$pc_get_element (
                    controller_element_p^.controller.connection.unit [physical_unit_number].element_name,
                    channel_element_p^.data_channel.iou, unit_element_p, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              IF unit_element_p^.element_type <> cmc$storage_device_element THEN
                pp_interface_table_error (procedure_name, pp, channel_element_p^.data_channel.number,
                      controller_element_p^.controller.physical_equipment_number,
                      physical_unit_number, - 1, cme$it_pp_not_data_type,
                      controller_element_p^.controller.connection.unit [physical_unit_number].element_name,
                      'Expecting data_type', status);
                EXIT /main_program/;
              IFEND;

              cmp$get_unit_type (unit_element_p^.product_id, unit_type, io_unit_type, unit_class, found);
              IF NOT found AND (io_unit_type = ioc$dt_foreign_device) THEN
                CYCLE /build_pp_table_loop/;
              IFEND;
              cmp$get_logical_unit_number (unit_element_p^.element_name, logical_unit_number, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              IF logical_unit_number > max_unit_count THEN
                pp_interface_table_error (procedure_name, pp, channel_element_p^.data_channel.number,
                      controller_element_p^.controller.physical_equipment_number, physical_unit_number,
                      logical_unit_number, cme$it_pp_invalid_lun, unit_element_p^.element_name,
                      'Logical_unit_number > max_unit_count', status);
                EXIT /main_program/;
              IFEND;

              IF logical_unit_number = 0 THEN
                CYCLE /unit_number_loop/;
              IFEND;

              { Update unit range.

              IF low_unit > logical_unit_number THEN
                low_unit := logical_unit_number;
              IFEND;
              IF upper_unit < logical_unit_number THEN
                upper_unit := logical_unit_number;
              IFEND;

              { Save the physical_path.

              temp_unit_des_p^ [logical_unit_number].configured := TRUE;
              temp_unit_des_p^ [logical_unit_number].controller_number :=
                     controller_element_p^.controller.physical_equipment_number;
              IF controller_type = cmc$ms7165_2x THEN
                temp_unit_des_p^ [logical_unit_number].storage_directory_address :=
                       controller_element_p^.controller.physical_equipment_number;
              ELSE
                temp_unit_des_p^ [logical_unit_number].storage_directory_address := 0;
              IFEND;
              IF (unit_element_p^.product_id.product_number = '  $895') AND
                    (unit_element_p^.product_id.model_number = '1  ') THEN
                temp_unit_des_p^ [logical_unit_number].unit_number :=
                      unit_element_p^.storage_device.physical_unit_number + 1000(16);
              ELSE
                temp_unit_des_p^ [logical_unit_number].unit_number :=
                      unit_element_p^.storage_device.physical_unit_number;
              IFEND;
            FOREND /unit_number_loop/;

          ELSE { Element is not a controller }
            cmp$get_unit_type (controller_element_p^.product_id, unit_type, io_unit_type, unit_class, found);
            IF NOT found THEN
              CYCLE /build_pp_table_loop/;
            IFEND;
            cmp$get_logical_unit_number (
                  channel_element_p^.data_channel.connection.equipment [physical_eq_number].element_name,
                  logical_unit_number, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            IF logical_unit_number > max_unit_count THEN
              pp_interface_table_error (procedure_name, pp, channel_element_p^.data_channel.number,
                    physical_eq_number, 0, logical_unit_number, cme$it_pp_invalid_lun,
                    controller_element_p^.element_name, 'Logical_unit_number > max_unit_count', status);
              EXIT /main_program/;
            IFEND;

            IF logical_unit_number <> 0 THEN
              IF low_unit > logical_unit_number THEN
                low_unit := logical_unit_number;
              IFEND;
              IF upper_unit < logical_unit_number THEN
                upper_unit := logical_unit_number;
              IFEND;
            IFEND;

            { Save the physical_path.

            temp_unit_des_p^ [logical_unit_number].configured := TRUE;
            temp_unit_des_p^ [logical_unit_number].controller_number := physical_eq_number;
            temp_unit_des_p^ [logical_unit_number].storage_directory_address := 0;
            temp_unit_des_p^ [logical_unit_number].unit_number := 0;

            IF unit_type = cmc$mshydra THEN
              controller_type := cmc$mshydra_ct;
              iou_program_name := 'E9S887';
            IFEND;
          IFEND;  {element_type check}

        FOREND /equipment_number_loop/;

        cmp$convert_iou_name (channel_element_p^.data_channel.iou, iou_number, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        cmp$get_driver_info (iou_program_name, channel_element_p^.data_channel.concurrent, cip_driver_name,
              dual_pp, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        IF dual_pp THEN
          pps_needed := 2;
        ELSE
          pps_needed := 1;
        IFEND;

       /build_table_entry/
        FOR pp_index := 1 TO pps_needed DO
          IF upper_unit = 0 THEN
            CYCLE /build_table_entry/;
          IFEND;

          { If both ports of a channel exists then combine the information.

          IF channel_element_p^.data_channel.concurrent AND
                cio_channel_used_p^ [iou_number] [channel_element_p^.data_channel.number].configured THEN
            PUSH table_unit_desc_p: [low_unit .. upper_unit];
            pmp$zero_out_table (#LOC (table_unit_desc_p^), #SIZE (table_unit_desc_p^));
            build_unit_descriptors (low_unit, upper_unit, actual_logical_unit_table_p, channel_element_p,
                  temp_unit_des_p, controller_type, table_unit_desc_p);
            combine_table_entry (low_unit, upper_unit, table_unit_desc_p,
                  cio_channel_used_p^ [iou_number][channel_element_p^.data_channel.number].pp_index,
                  logical_pp_table_p, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            CYCLE /build_table_entry/;
          IFEND;

          logical_pp_table_p^ [pp].flags.entry_in_use := TRUE;
          logical_pp_table_p^ [pp].flags.entry_reserved_by_nosve := TRUE;
          retrieve_logical_pp_flags (cip_driver_name, pp, logical_pp_table_p);

          IF dual_pp THEN
            IF pp_index = 1 THEN
              logical_pp_table_p^ [pp].pp_info.logical_partner_pp_index := pp + 1;
            ELSE
              logical_pp_table_p^ [pp].pp_info.logical_partner_pp_index := pp - 1;
            IFEND;
          IFEND;

          logical_pp_table_p^ [pp].pp_info.channel.iou_number := iou_number;
          IF channel_element_p^.data_channel.concurrent THEN
            logical_pp_table_p^ [pp].pp_info.channel.channel_protocol := dsc$cpt_cio;
          ELSE
            logical_pp_table_p^ [pp].pp_info.channel.channel_protocol := dsc$cpt_nio;
          IFEND;
          logical_pp_table_p^ [pp].pp_info.channel.number := channel_element_p^.data_channel.number;
          logical_pp_table_p^ [pp].pp_info.channel_port := channel_element_p^.data_channel.port;

          logical_pp_table_p^ [pp].pp_info.driver_name := iou_program_name (1, 7);
          logical_pp_table_p^ [pp].pp_info.cip_driver_name := cip_driver_name;

          logical_pp_table_p^ [pp].controller_info.controller_type := controller_type;

          cmp$get_response_handler (controller_type, logical_pp_table_p^ [pp].handlers.response_handler_p);

          setup_pp_table (pp, channel_element_p^.data_channel.concurrent, TRUE, low_unit, upper_unit,
                logical_pp_table_p, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

          logical_pp_table_p^ [pp].flags.configured := TRUE;

          IF pp_index = 1 THEN
            prev_commun_buffer_p := logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p;
          ELSE
            prev_commun_buffer_p^.partner_pp := logical_pp_table_p^ [pp].pp_info.pp_interface_table_rma;
            logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.partner_pp :=
                  logical_pp_table_p^ [pp - 1].pp_info.pp_interface_table_rma;
            prev_commun_buffer_p^.slave := FALSE;
            logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.slave := TRUE;
          IFEND;

          { Initialize unit descriptors in the pp_interface_table_p.

          table_unit_desc_p := ^logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.unit_descriptors;
          build_unit_descriptors (low_unit, upper_unit, actual_logical_unit_table_p, channel_element_p,
                temp_unit_des_p, controller_type, table_unit_desc_p);

          IF channel_element_p^.data_channel.concurrent AND
                 (channel_element_p^.data_channel.port <> cmc$unspecified_port) THEN
            cio_channel_used_p^ [iou_number] [channel_element_p^.data_channel.number].configured := TRUE;
            cio_channel_used_p^ [iou_number] [channel_element_p^.data_channel.number].pp_index := pp;
          IFEND;

          pp := pp + 1;
        FOREND /build_table_entry/;

      WHILEND /build_pp_table_loop/;

    END /main_program/;
    IF status.normal THEN
      actual_logical_pp_table_p := logical_pp_table_p;
    ELSE
      IF logical_pp_table_p <> NIL THEN
        FOR pp_index := LOWERBOUND (logical_pp_table_p^) TO UPPERBOUND (logical_pp_table_p^) DO
          IF logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p <> NIL THEN
            IF logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.response_buffer <> NIL THEN
              FREE logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.response_buffer IN
                    osv$mainframe_wired_cb_heap^;
            IFEND;
            FREE logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p IN osv$mainframe_wired_cb_heap^;
          IFEND;
          IF logical_pp_table_p^ [pp_index].pp_info.pp_communication_buffer_p <> NIL THEN
            FREE logical_pp_table_p^ [pp_index].pp_info.pp_communication_buffer_p IN
                  osv$mainframe_wired_cb_heap^;
          IFEND;
        FOREND;
        FREE logical_pp_table_p IN osv$mainframe_wired_cb_heap^;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, cmk$build_pp_interface_table);

  PROCEND build_pp_interface_table;
?? OLDTITLE ??
?? NEWTITLE := 'build_unit_descriptors', EJECT ??

{ PURPOSE:
{   This procedure sets up the values of the unit descriptors in the PP interface table.

  PROCEDURE build_unit_descriptors
    (    first_unit: iot$logical_unit;
         last_unit: iot$logical_unit;
         logical_unit_table_p: ^cmt$logical_unit_table;
         channel_p: ^cmt$element_definition;
         temp_unit_des_p: ^ARRAY [ * ] OF t$unit_descriptor;
         controller_type: cmt$controller_type;
     VAR table_unit_desc_p: ^iot$unit_descriptors);

    VAR
      controller_element_p: ^cmt$element_definition,
      controller_number: cmt$physical_equipment_number,
      controller_state: cmt$element_state,
      ignore_status: ost$status,
      logical_unit_number: iot$logical_unit,
      redundant_path: boolean,
      redundant_path_useable: boolean,
      rma: integer,
      unlocked: iot$lockword;

      unlocked.lock := FALSE;
      unlocked.fill := 0;
      unlocked.lock_owner.cpu_lock := FALSE;
      unlocked.lock_owner.fill := 0;
      unlocked.lock_owner.pp_number := 0;


   /build_each_unit/
    FOR logical_unit_number := first_unit TO last_unit DO
      IF logical_unit_number < cmc$job_template_unit_ordinal THEN
        CYCLE /build_each_unit/;
      IFEND;

      table_unit_desc_p^ [logical_unit_number].physical_path.channel_number := 0;
      table_unit_desc_p^ [logical_unit_number].physical_path.storage_directory_address := 0;
      table_unit_desc_p^ [logical_unit_number].physical_path.controller_number := 0;
      table_unit_desc_p^ [logical_unit_number].physical_path.physical_unit_number := 0;
      table_unit_desc_p^ [logical_unit_number].unit_interface_table_rma := 0;
      table_unit_desc_p^ [logical_unit_number].unit_interface_table := NIL;
      table_unit_desc_p^ [logical_unit_number].logical_unit := logical_unit_number;

      IF (logical_unit_table_p^ [logical_unit_number].unit_interface_table = NIL) OR
            NOT temp_unit_des_p^ [logical_unit_number].configured THEN
        CYCLE /build_each_unit/;
      IFEND;

      i#real_memory_address (#LOC (logical_unit_table_p^ [logical_unit_number].unit_interface_table^), rma);
      controller_number := temp_unit_des_p^ [logical_unit_number].controller_number;
      controller_element_p := NIL;

      IF channel_p <> NIL THEN
        IF cmp$support_redundant_channel(controller_type) THEN
          IF (controller_type = cmc$ms7155_1) OR (controller_type = cmc$ms7155_1x) THEN
            select_7155_controller(channel_p, logical_unit_number, controller_type,
                  controller_element_p, redundant_path, ignore_status);
          ELSE
            select_controller(channel_p, logical_unit_number, controller_type, controller_element_p,
                  redundant_path, ignore_status);
          IFEND;
          IF NOT ignore_status.normal THEN
            RETURN;
          IFEND;

          IF controller_element_p <> NIL THEN
            IF redundant_path THEN
              rma := 0;
            IFEND;
            controller_number := controller_element_p^.controller.physical_equipment_number;
          ELSE
            cmp$pc_get_element (
                  channel_p^.data_channel.connection.equipment [controller_number].element_name,
                  channel_p^.data_channel.iou, controller_element_p, ignore_status);
          IFEND;
        ELSE
          cmp$pc_get_element (channel_p^.data_channel.connection.equipment [controller_number].element_name,
                channel_p^.data_channel.iou, controller_element_p, ignore_status);
        IFEND;
      IFEND;

      table_unit_desc_p^ [logical_unit_number].unit_interface_table_rma := rma;
      table_unit_desc_p^ [logical_unit_number].unit_interface_table :=
            logical_unit_table_p^ [logical_unit_number].unit_interface_table;
      table_unit_desc_p^ [logical_unit_number].unit_interface_table^.next_request := NIL;
      table_unit_desc_p^ [logical_unit_number].unit_interface_table^.unit_lockword := unlocked;
      table_unit_desc_p^ [logical_unit_number].unit_interface_table^.next_request_rma := 0;
      table_unit_desc_p^ [logical_unit_number].unit_interface_table^.queue_count := 0;
{     table_unit_desc_p^ [logical_unit_number].unit_interface_table^.unit_communication_buffer_rma := 0;
{     table_unit_desc_p^ [logical_unit_number].unit_interface_table^.unit_commun_buffer_length := 0;


      table_unit_desc_p^ [logical_unit_number].physical_path.channel_number :=
            temp_unit_des_p^ [logical_unit_number].channel.number;
      IF controller_type <> cmc$mshydra_ct THEN
        table_unit_desc_p^ [logical_unit_number].physical_path.controller_number :=
              temp_unit_des_p^ [logical_unit_number].controller_number;
        IF ((controller_type = cmc$mscm3_ct) OR (controller_type = cmc$ms5831_x)) AND
              (temp_unit_des_p^ [logical_unit_number].controller_number <> controller_number) THEN
          table_unit_desc_p^ [logical_unit_number].physical_path.controller_number :=
                controller_number;
        IFEND;
        table_unit_desc_p^ [logical_unit_number].physical_path.physical_unit_number :=
              temp_unit_des_p^ [logical_unit_number].unit_number;
      ELSE
        table_unit_desc_p^ [logical_unit_number].physical_path.controller_number :=
              temp_unit_des_p^ [logical_unit_number].controller_number;
        table_unit_desc_p^ [logical_unit_number].physical_path.physical_unit_number := 0;
      IFEND;
      IF temp_unit_des_p^ [logical_unit_number].channel.port = cmc$port_b THEN
         table_unit_desc_p^ [logical_unit_number].physical_path.port := 1;
      ELSE
         table_unit_desc_p^ [logical_unit_number].physical_path.port := 0;
      IFEND;
      table_unit_desc_p^ [logical_unit_number].physical_path.storage_directory_address :=
            temp_unit_des_p^ [logical_unit_number].storage_directory_address;
    FOREND /build_each_unit/;

  PROCEND build_unit_descriptors;
?? OLDTITLE ??
?? NEWTITLE := 'build_unit_interface_table', EJECT ??

{ PURPOSE:
{   This procedure allocates space for the logical unit table.  It also initializes the proper pointers for
{   each entry in the table.

  PROCEDURE build_unit_interface_table
    (    requested_unit_count: iot$logical_unit;
         allocate_entire_configuration: boolean;
     VAR logical_unit_table_p: ^cmt$logical_unit_table;
     VAR status: ost$status);

    CONST
      procedure_name = 'BUILD_UNIT_INTERFACE_TABLE',
      init_offln_drv_num = 0ff(16);    {NOSVE initialization value for 'off_line_drive_number'.}

    VAR
      active_path: boolean,
      found: boolean,
      index: integer,
      io_unit_type: iot$unit_type,
      iou_name: cmt$element_name,
      local_logical_unit_table_p: ^cmt$logical_unit_table,
      mainframe_element_p: ^cmt$element_definition,
      rma: integer,
      template_p: ^iot$unit_commun_buffer_template,
      total_unit_count: iot$logical_unit,
      unit_class: cmt$unit_class,
      unit_count: iot$logical_unit,
      unit_state: cmt$element_state,
      unit_type: cmt$unit_type;

    status.normal := TRUE;
    #keypoint (osk$entry, 0, cmk$build_unit_interface_table);

  /main_program/
    BEGIN
      unit_count := requested_unit_count + cmc$reserved_unit_count;
      IF allocate_entire_configuration THEN
        total_unit_count := unit_count + cmc$reserved_network_unit_count;
      ELSE
        total_unit_count := unit_count;
      IFEND;

      { Allocate the local Logical Unit Table.

      ALLOCATE local_logical_unit_table_p: [1 .. total_unit_count] IN osv$mainframe_wired_cb_heap^;
      pmp$zero_out_table (#LOC (local_logical_unit_table_p^), #SIZE (local_logical_unit_table_p^));
      FOR index := LOWERBOUND (local_logical_unit_table_p^) TO UPPERBOUND (local_logical_unit_table_p^) DO
        local_logical_unit_table_p^ [index].configured := FALSE;
        local_logical_unit_table_p^ [index].logical_unit_number := 0;
        local_logical_unit_table_p^ [index].unit_interface_table := NIL;
      FOREND;

     /initialize_loop/
      FOR index := cmc$job_template_unit_ordinal TO unit_count DO
        cmp$pc_get_logical_unit (index, mainframe_element_p, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        { Do not build a UIT associated with the ICA or with COMMUNICATIONS_ELEMENT.

        IF ((mainframe_element_p^.element_type = cmc$channel_adapter_element) AND
              (mainframe_element_p^.product_id.product_number = ' $2629')) OR
              (mainframe_element_p^.element_type = cmc$communications_element) THEN
          local_logical_unit_table_p^ [index].configured := FALSE;
          local_logical_unit_table_p^ [index].logical_unit_number := index;
          CYCLE /initialize_loop/;
        IFEND;

        cmp$get_unit_type (mainframe_element_p^.product_id, unit_type, io_unit_type, unit_class, found);
        IF NOT found AND (io_unit_type = ioc$dt_foreign_device) THEN
          local_logical_unit_table_p^ [index].configured := FALSE;
          local_logical_unit_table_p^ [index].logical_unit_number := index;
          CYCLE /initialize_loop/;
        IFEND;
        cmp$get_element_state (mainframe_element_p^.element_name, {not used} iou_name, unit_state, status);
        IF NOT status.normal THEN
          unit_state := cmc$off;
          status.normal := TRUE;
        IFEND;

        { Allocate the UIT and Initialize logical_unit_table.

        local_logical_unit_table_p^ [index].configured := TRUE;
        ALLOCATE local_logical_unit_table_p^ [index].unit_interface_table IN osv$mainframe_wired_cb_heap^;

        pmp$zero_out_table (#LOC (local_logical_unit_table_p^ [index].unit_interface_table^),
              #SIZE (local_logical_unit_table_p^ [index].unit_interface_table^));
        local_logical_unit_table_p^ [index].logical_unit_number := index;
        local_logical_unit_table_p^ [index].entry_interlock := FALSE;
        local_logical_unit_table_p^ [index].element_capability := $cmt$element_capabilities [];
        local_logical_unit_table_p^ [index].element_access := $cmt$element_access [];
        local_logical_unit_table_p^ [index].unit_interface_table^.logical_unit := index;
        local_logical_unit_table_p^ [index].unit_interface_table^.next_request := NIL;

        IF unit_state = cmc$on THEN
          cmp$verify_active_path (mainframe_element_p^, active_path);
          IF NOT active_path THEN
            unit_state := cmc$off;
          IFEND;
        IFEND;

        CASE unit_state OF
        = cmc$on =

          { In the future, need to include cmc$file_allocation and cmc$job_reservation in the element
          { capability list. This must be done based on the type of devices.

          local_logical_unit_table_p^ [index].element_capability := $cmt$element_capabilities
                [cmc$volume_assignment, cmc$io_request_submission, cmc$concurrent_maintenance];
          local_logical_unit_table_p^ [index].element_access := - $cmt$element_access [];
        = cmc$down =
          local_logical_unit_table_p^ [index].element_capability := $cmt$element_capabilities
                [cmc$dedicated_maintenance, cmc$concurrent_maintenance];
          local_logical_unit_table_p^ [index].element_access := - $cmt$element_access [];
          local_logical_unit_table_p^ [index].unit_interface_table^.unit_status.disabled := TRUE;
        ELSE  { = cmc$off = }
          local_logical_unit_table_p^ [index].element_capability := $cmt$element_capabilities [];
          local_logical_unit_table_p^ [index].element_access :=  $cmt$element_access [];
          local_logical_unit_table_p^ [index].unit_interface_table^.unit_status.disabled := TRUE;
        CASEND;

        local_logical_unit_table_p^ [index].unit_interface_table^.unit_status.
              parity_protection_enabled := FALSE;
        local_logical_unit_table_p^ [index].unit_interface_table^.unit_status.
              restoring_drive := FALSE;
        local_logical_unit_table_p^ [index].unit_interface_table^.unit_status.
              off_line_drive_number := init_offln_drv_num;

        { Determine if it is a assignable device.

        IF unit_type IN cmv$assignable_device THEN
          local_logical_unit_table_p^ [index].status.assignable_device := TRUE;
          local_logical_unit_table_p^ [index].status.assigned := FALSE;
        ELSE
          local_logical_unit_table_p^ [index].status.assignable_device := FALSE;
        IFEND;
        local_logical_unit_table_p^ [index].unit_interface_table^.unit_type := io_unit_type;

        { Allocate the unit communication buffer.

        ALLOCATE template_p IN osv$mainframe_wired_cb_heap^;
        local_logical_unit_table_p^ [index].unit_communication_buffer_pva :=
              ^template_p^.unit_communication_buffer;
        pmp$zero_out_table (#LOC (local_logical_unit_table_p^ [index].unit_communication_buffer_pva^),
              #SIZE (local_logical_unit_table_p^ [index].unit_communication_buffer_pva^));
        i#real_memory_address (#LOC (local_logical_unit_table_p^ [index].unit_communication_buffer_pva^),
              rma);
        local_logical_unit_table_p^ [index].unit_interface_table^.unit_communication_buffer_rma := rma;
        local_logical_unit_table_p^ [index].unit_interface_table^.unit_commun_buffer_length :=
              ioc$unit_commun_buffer_length * 8;
        local_logical_unit_table_p^ [index].unit_interface_table^.unit_shared := FALSE;
      FOREND /initialize_loop/;

    END /main_program/;
    IF status.normal THEN
      logical_unit_table_p := local_logical_unit_table_p;
    IFEND;
    #keypoint (osk$exit, 0, cmk$build_unit_interface_table);

  PROCEND build_unit_interface_table;
?? OLDTITLE ??
?? NEWTITLE := 'channels_equivalent', EJECT ??

  FUNCTION [INLINE] channels_equivalent
    (    channel_element_1_p: ^cmt$element_definition;
         channel_element_2_p: ^cmt$element_definition): boolean;

    channels_equivalent :=
          (channel_element_1_p^.data_channel.number = channel_element_2_p^.data_channel.number) AND
          (channel_element_1_p^.data_channel.concurrent = channel_element_2_p^.data_channel.concurrent) AND
          (channel_element_1_p^.data_channel.iou = channel_element_2_p^.data_channel.iou);

  FUNCEND channels_equivalent;
?? OLDTITLE ??
?? NEWTITLE := 'combine_table_entry', EJECT ??

{ PURPOSE:
{   This procedure recombines information from the port A and port B channel into one pp interface table.
{   The reason for doing this is because CM stores channel portA and channel portB separately, thus
{   thinking that it is two separate channels.

  PROCEDURE combine_table_entry
    (    current_first_lun: iot$logical_unit;
         current_last_lun: iot$logical_unit;
         current_unit_desc_p: ^iot$unit_descriptors,
         pp_index: iot$pp_number;
     VAR logical_pp_table_p: ^cmt$logical_pp_table;
     VAR status: ost$status);

    CONST
      procedure_name = 'COMBINE_TABLE_ENTRY';

    VAR
      first_lun: iot$logical_unit,
      last_lun: iot$logical_unit,
      lun_index: iot$logical_unit,
      pp_interface_table_p: ^iot$pp_interface_table,
      ppit_seq_p: ^SEQ ( * ),
      rma: integer,
      size: integer,
      table_unit_desc_p: ^iot$unit_descriptors,
      unit_desc_p: ^iot$unit_descriptors,
      used_first_lun: iot$logical_unit,
      used_last_lun: iot$logical_unit;

    status.normal := TRUE;

    { Take smallest first logical unit and the largest last logical unit of the 2 pp tables.

    used_first_lun := logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.first_logical_unit;
    IF used_first_lun <= current_first_lun THEN
      first_lun := used_first_lun;
    ELSE
      first_lun := current_first_lun;
    IFEND;

    used_last_lun := logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.first_logical_unit +
          logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.number_of_units - 1;
    IF used_last_lun > current_last_lun THEN
      last_lun := used_last_lun;
    ELSE
      last_lun := current_last_lun;
    IFEND;

    { Allocate and initialize new unit descriptors.

    PUSH unit_desc_p: [first_lun .. last_lun];
    FOR lun_index := first_lun TO last_lun DO
      unit_desc_p^ [lun_index].logical_unit := 0;
      unit_desc_p^ [lun_index].unit_interface_table_rma := 0;
      unit_desc_p^ [lun_index].unit_interface_table := NIL;
      unit_desc_p^ [lun_index].physical_path.channel_number := 0;
      unit_desc_p^ [lun_index].physical_path.port := 0;
      unit_desc_p^ [lun_index].physical_path.controller_number := 0;
      unit_desc_p^ [lun_index].physical_path.storage_directory_address :=0;
      unit_desc_p^ [lun_index].physical_path.physical_unit_number := 0;
    FOREND;

    { Move stuff over to the new table.

    FOR lun_index := used_first_lun TO used_last_lun DO
      unit_desc_p^ [lun_index] :=
            logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.unit_descriptors [lun_index];
    FOREND;

    FOR lun_index := current_first_lun TO current_last_lun DO
      IF unit_desc_p^ [lun_index].unit_interface_table_rma = 0 THEN
        unit_desc_p^ [lun_index] := current_unit_desc_p^ [lun_index];
      IFEND;
    FOREND;

    { Update PPIT of pp_index.

    size := #SIZE (iot$pp_interface_table: [first_lun .. last_lun]);
    dsp$allocate_continuous_memory (osv$mainframe_wired_cb_heap, size, ppit_seq_p);
    RESET ppit_seq_p;
    NEXT pp_interface_table_p: [first_lun .. last_lun] IN ppit_seq_p;

    pp_interface_table_p^.pp_number := pp_index;
    pp_interface_table_p^.first_logical_unit := first_lun;
    pp_interface_table_p^.number_of_units := last_lun - first_lun + 1;
    pp_interface_table_p^.interrupt_register_rma :=
          logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.interrupt_register_rma;
    pp_interface_table_p^.channel_interlock_rma :=
          logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.channel_interlock_rma;
    pp_interface_table_p^.communication_buffer_length :=
          logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.communication_buffer_length;
    pp_interface_table_p^.communication_buffer_rma :=
          logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.communication_buffer_rma;
    pp_interface_table_p^.response_buffer :=
          logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.response_buffer;
    pp_interface_table_p^.response_buffer_rma :=
          logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.response_buffer_rma;
    pp_interface_table_p^.pp_request_queue := NIL;
    pp_interface_table_p^.limit := logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.limit;

    table_unit_desc_p := ^pp_interface_table_p^.unit_descriptors;
    FOR lun_index := first_lun TO last_lun DO
       table_unit_desc_p^ [lun_index] := unit_desc_p^ [lun_index];
    FOREND;

    FREE logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p IN osv$mainframe_wired_cb_heap^;
    logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p := pp_interface_table_p;
    i#real_memory_address (#LOC (logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^), rma);
    logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_rma := rma;

  PROCEND combine_table_entry;
?? OLDTITLE ??
?? NEWTITLE := 'determine_redundant_path', EJECT ??

{ PURPOSE:
{   This procedure determines if a given path channel and equipment is a redundant path.
{   A redundant path is one that in which the channel is not the first ON channel.

  PROCEDURE determine_redundant_path
    (    mainframe_id: cmt$element_name;
         channel: cmt$element_definition;
         controller_p: ^cmt$element_definition;
     VAR redundant_path: boolean;
     VAR redundant_path_useable: boolean;
     VAR status: ost$status);

    VAR
      channel_state: cmt$element_state,
      controller_state: cmt$element_state,
      current_channel_state: cmt$element_state,
      first_on_channel_found: boolean,
      first_on_channel_p: ^cmt$element_definition,
      iou_name: cmt$element_name,
      iou_number: dst$iou_number,
      physical_channel: cmt$physical_channel,
      port: integer,
      redundant: boolean;

    status.normal := TRUE;
    redundant_path := FALSE;
    redundant_path_useable := FALSE;
    IF controller_p = NIL THEN
      RETURN;
    IFEND;

    cmp$get_element_state (channel.element_name, channel.data_channel.iou, current_channel_state, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cmp$get_element_state (controller_p^.element_name, iou_name, controller_state, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    first_on_channel_found := FALSE;

  /search_primary_channel/
    FOR port := LOWERVALUE (cmt$controller_port_number) TO UPPERVALUE (cmt$controller_port_number) DO
      IF controller_p^.controller.connection.port [port].configured AND
            (controller_p^.controller.connection.port [port].mainframe_ownership = mainframe_id) THEN
        cmp$get_element_state (controller_p^.controller.connection.port [port].element_name,
              controller_p^.controller.connection.port [port].iou, channel_state, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        cmp$pc_get_element (controller_p^.controller.connection.port [port].element_name,
              controller_p^.controller.connection.port [port].iou, first_on_channel_p, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF channel_state = cmc$on THEN
          first_on_channel_found := TRUE;
          EXIT /search_primary_channel/;
        IFEND;
      IFEND;
    FOREND /search_primary_channel/;

    IF first_on_channel_found THEN

      { The current channel is not the first on channel in the upline connection of this controller.  If it
      { is not redundant at all on all the other controllers then set redundant to TRUE.

      IF (channel.data_channel.number <> first_on_channel_p^.data_channel.number) OR
             (channel.data_channel.concurrent <> first_on_channel_p^.data_channel.concurrent) OR
             (channel.data_channel.iou <> first_on_channel_p^.data_channel.iou) THEN
        redundant_path := TRUE;
        redundant_path_useable := (current_channel_state = cmc$on) AND (controller_state = cmc$on);
      IFEND;
    ELSE
      redundant := (current_channel_state <> cmc$on);
    IFEND;

  PROCEND determine_redundant_path;
?? OLDTITLE ??
?? NEWTITLE := 'get_driver_name', EJECT ??

{ PURPOSE:
{   This procedure converts the IOU Program Name supplied to the driver name.  This name is determined
{   based on channel type (NIO or CIO).
{ NOTE:
{   If the driver name is not a NOS/VE driver name, then the actual driver name will be returned.

  PROCEDURE get_driver_name
    (    driver_name: string ( * );
         channel_type: dst$channel_protocol_type;
         dual_pp: boolean;
     VAR cm_driver_name: dst$driver_name);

    CONST
      table_length = 26;

    VAR
      driver_index: 1 .. table_length;

    VAR
      default_driver: [STATIC, READ] ARRAY [1 .. table_length] OF
            ARRAY [1 .. 3] OF dst$driver_name := [

            {               NIO        CIO        CIP

            { 7155_1x   } ['E1C7155', 'illegal', 'DSK55A '],
            { 7155 CIO  } ['illegal', 'E1A7155', 'DSK55C7'],
            { 7154      } ['DSKE   ', 'DSKE   ', 'DSK7154'],
            { ISD       } ['E1I7255', 'illegal', 'ISD    '],
            { HYDRA     } ['illegal', 'E9S887 ', 'HYD    '],
            { 5831 I0   } ['E5P5831', 'illegal', 'E5P5831'],
            { 5831 I4   } ['illegal', 'E9P5831', 'E9P5831'],
            { CM3 9836  } ['E5P9836', 'illegal', 'DSKI   '],
            { CM3 9853  } ['illegal', 'E9P9853', 'E9P9853'],
            { 7165      } ['E2C7165', 'illegal', 'D895   '],
            { 7165 CIO  } ['illegal', 'E9A7165', 'D895CIO'],
            { 7021      } ['E1C7021', 'E1A7021', 'TAPE   '],
            { 7221      } ['E5I9639', 'illegal', 'TAPB   '],
            { IPI tape  } ['E5P5698', 'illegal', 'TAPC   '],
            { IPI tape  } ['illegal', 'E9P5698', 'TAPD   '],
            { IPI I4-43 } ['illegal', 'E9Q5698', 'E9Q5698'],
            { 5680      } ['E2C5680', 'E2A5680', 'E2X5680'],
            { MAP V     } ['E1C6535', 'E1A6535', 'VM5B   '],
            { NETW      } ['E1C2620', 'E1A2620', 'NETW   '],
            { ICA       } ['E1I2629', 'illegal', 'ICAD   '],
            { LCN       } ['E1C380 ', 'E1A380 ', 'NPDR   '],
            { LCN S0    } ['E1I380 ', 'illegal', 'NDI0   '],
            {EXPRESSLINK} ['E5P4000', 'illegal', 'IVB0   '],
            {EXPRESSLINK} ['illegal', 'E9P4000', 'IVB4   '],
            { ESMD      } ['E1C5380', 'E1A5380', 'ESMD   '],
            { SDPD      } ['E1CSDPD', 'E1ASDPD', 'SDPD   ']];

    cm_driver_name := driver_name;

    FOR driver_index := 1 TO table_length DO
      IF driver_name = default_driver [driver_index] [3] THEN
        IF channel_type = dsc$cpt_nio THEN
          cm_driver_name := default_driver [driver_index] [1];
        ELSE { cio channel
          cm_driver_name := default_driver [driver_index] [2];
        IFEND;
        IF (driver_name = 'TAPE') AND dual_pp THEN
          cm_driver_name (2, 1) := '2';
        IFEND;
        RETURN;
      IFEND;
    FOREND;

  PROCEND get_driver_name;
?? OLDTITLE ??
?? NEWTITLE := 'pp_interface_table_error', EJECT ??

  PROCEDURE pp_interface_table_error
    (    procedure_name: string ( * );
         pp: iot$pp_number;
         channel_number: integer;
         controller_number: integer,
         unit_number: integer;
         logical_unit_number: integer;
         condition: ost$status_condition;
         element_name: string ( * );
         text: string ( * );
     VAR status: ost$status);

    VAR
      channel_string: string (14),
      controller_string: string (17),
      logical_unit_string: string (19),
      ignore_status: ost$status,
      pp_string: string (9),
      temp_string: ost$string,
      unit_string: string (20);

    osp$set_status_abnormal (cmc$configuration_management_id, condition, procedure_name, status);

    pp_string := '-----';
    IF pp >= 0 THEN
      clp$convert_integer_to_string (pp, 10, FALSE, temp_string, ignore_status);
      pp_string := temp_string.value;
    IFEND;
    osp$append_status_parameter (osc$status_parameter_delimiter, pp_string, status);

    channel_string := '-----';
    IF channel_number >= 0 THEN
      clp$convert_integer_to_string (channel_number, 10, FALSE, temp_string, ignore_status);
      channel_string := temp_string.value;
    IFEND;
    osp$append_status_parameter (osc$status_parameter_delimiter, channel_string, status);

    controller_string := '-----';
    IF controller_number >= 0 THEN
      clp$convert_integer_to_string (controller_number, 10, FALSE, temp_string, ignore_status);
      controller_string := temp_string.value;
    IFEND;
    osp$append_status_parameter (osc$status_parameter_delimiter, controller_string, status);

    unit_string := '-----';
    IF unit_number >= 0 THEN
      clp$convert_integer_to_string (unit_number, 10, FALSE, temp_string, ignore_status);
      unit_string := temp_string.value;
    IFEND;
    osp$append_status_parameter (osc$status_parameter_delimiter, unit_string, status);

    logical_unit_string := '-----';
    IF logical_unit_number >= 0 THEN
      clp$convert_integer_to_string (logical_unit_number, 10, FALSE, temp_string, ignore_status);
      logical_unit_string := temp_string.value;
    IFEND;
    osp$append_status_parameter (osc$status_parameter_delimiter, logical_unit_string, status);
    osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
    osp$append_status_parameter (osc$status_parameter_delimiter, text, status);

  PROCEND pp_interface_table_error;
?? OLDTITLE ??
?? NEWTITLE := 'retrieve_logical_pp_flags', EJECT ??

{ PURPOSE:
{   This procedure contains the code that determines some of the flag values in the Logical PP Table.
{   When drivers add support for such things as handshaking and dynamic reload, this should be the
{   only procedure that should need the driver name added to a list.

  PROCEDURE retrieve_logical_pp_flags
    (    cip_driver_name: dst$driver_name;
         pp_index: iot$pp_number;
     VAR logical_pp_table_p: ^cmt$logical_pp_table);

    IF (cip_driver_name = 'DSK55A ') OR (cip_driver_name = 'DSK55C7') OR (cip_driver_name = 'DSK7154') OR
          (cip_driver_name = 'ISD    ') OR (cip_driver_name = 'HYD    ') OR (cip_driver_name = 'E5P5831') OR
          (cip_driver_name = 'E9P5831') OR (cip_driver_name = 'DSKI   ') OR (cip_driver_name = 'E9P9853') OR
          (cip_driver_name = 'D895   ') OR (cip_driver_name = 'D895CIO') THEN
      logical_pp_table_p^ [pp_index].pp_info.pp_type := cmc$lpt_disk_pp_type;
    ELSEIF (cip_driver_name = 'TAPE   ') OR (cip_driver_name = 'TAPB   ') OR (cip_driver_name = 'TAPC   ') OR
          (cip_driver_name = 'TAPD   ') OR (cip_driver_name = 'E9Q5698') OR (cip_driver_name = 'E2X5680') THEN
      logical_pp_table_p^ [pp_index].pp_info.pp_type := cmc$lpt_tape_pp_type;
    ELSEIF (cip_driver_name = 'NETW   ') OR (cip_driver_name = 'ICAD   ') OR (cip_driver_name = 'IVB0   ') OR
          (cip_driver_name = 'IVB4   ') THEN
      logical_pp_table_p^ [pp_index].pp_info.pp_type := cmc$lpt_network_pp_type;
    ELSEIF (cip_driver_name = 'NPDR   ') OR (cip_driver_name = 'NDI0   ') THEN
      logical_pp_table_p^ [pp_index].pp_info.pp_type := cmc$lpt_nad_pp_type;
    ELSE
      logical_pp_table_p^ [pp_index].pp_info.pp_type := cmc$lpt_other_pp_type;
    IFEND;

    IF (cip_driver_name = 'DSK55A ') OR (cip_driver_name = 'DSK55C7') OR (cip_driver_name = 'DSK7154') OR
          (cip_driver_name = 'ISD    ') OR (cip_driver_name = 'HYD    ') OR (cip_driver_name = 'E5P5831') OR
          (cip_driver_name = 'E9P5831') OR (cip_driver_name = 'DSKI   ') OR (cip_driver_name = 'E9P9853') OR
          (cip_driver_name = 'D895   ') OR (cip_driver_name = 'D895CIO') OR (cip_driver_name = 'SDPD   ') THEN
      logical_pp_table_p^ [pp_index].flags.pp_idle_resume_supported := TRUE;
    IFEND;

    IF (cip_driver_name = 'DSK55A ') OR (cip_driver_name = 'DSK55C7') OR (cip_driver_name = 'DSK7154') OR
          (cip_driver_name = 'ISD    ') OR (cip_driver_name = 'HYD    ') OR (cip_driver_name = 'E5P5831') OR
          (cip_driver_name = 'E9P5831') OR (cip_driver_name = 'DSKI   ') OR (cip_driver_name = 'E9P9853') OR
          (cip_driver_name = 'D895   ') OR (cip_driver_name = 'D895CIO') OR (cip_driver_name = 'NETW   ') OR
          (cip_driver_name = 'ICAD   ') OR (cip_driver_name = 'IVB0   ') OR (cip_driver_name = 'IVB4   ') OR
          (cip_driver_name = 'NPDR   ') OR (cip_driver_name = 'NDI0   ') THEN
      logical_pp_table_p^ [pp_index].flags.pp_handshaking_supported := TRUE;
    IFEND;

    IF (cip_driver_name = 'DSK55A ') OR (cip_driver_name = 'DSK55C7') OR (cip_driver_name = 'DSK7154') OR
          (cip_driver_name = 'ISD    ') OR (cip_driver_name = 'HYD    ') OR (cip_driver_name = 'E5P5831') OR
          (cip_driver_name = 'E9P5831') OR (cip_driver_name = 'DSKI   ') OR (cip_driver_name = 'E9P9853') OR
          (cip_driver_name = 'D895   ') OR (cip_driver_name = 'D895CIO') OR (cip_driver_name = 'NETW   ') OR
          (cip_driver_name = 'ICAD   ') OR (cip_driver_name = 'IVB0   ') OR (cip_driver_name = 'IVB4   ') OR
          (cip_driver_name = 'NPDR   ') OR (cip_driver_name = 'NDI0   ') THEN
      logical_pp_table_p^ [pp_index].flags.pp_reload_supported := TRUE;
      logical_pp_table_p^ [pp_index].active_check.timeout := 30000000;
    IFEND;

  PROCEND retrieve_logical_pp_flags;

?? OLDTITLE ??
?? NEWTITLE := 'select_controller', EJECT ??
{ PURPOSE:
{     This procedure returns the appropriate 7155 controller, if any, to be
{     configured in the PP interface table for the specified channel and unit.
{ DESIGN:
{     The 7155 controller must be handled slightly different than the other
{     devices that support redundancy and/or alternate access.  These devices
{     support both alternate access and redundant access.  Also the controller
{     number is always 0.  An FMD spindle will support alternate access from
{     two controllers but does not support redundnant controllers.  The 7155
{     controller does not support dual channel access but does support
{     redundant channels.
{     This algorithm will locate the controller connected to the specified
{     channel and unit. The SELECTED_CONTROLLER_P parameter will contain a
{     pointer to this controller if an active path to the controller exists. The
{     REDUNDANT_PATH parameter will be set to TRUE if the specified channel
{     is the primary channel for the controller and will be set to FALSE
{     otherwise.

  PROCEDURE select_7155_controller
    (    channel_p: ^cmt$element_definition;
         logical_unit_number: iot$logical_unit;
         controller_type: cmt$controller_type;
     VAR selected_controller_p: ^cmt$element_definition;
     VAR redundant_path: boolean;
     VAR status: ost$status);

    VAR
      channel_element_p: ^cmt$element_definition,
      channel_found: boolean,
      channel_port: cmt$controller_port_number,
      channel_state: cmt$element_state,
      controller_element_p: ^cmt$element_definition,
      controller_state: cmt$element_state,
      local_status: ost$status,
      port: cmt$data_storage_port_number,
      primary_channel_found: boolean,
      primary_channel_p: ^cmt$element_definition,
      storage_device_element_p: ^cmt$element_definition;

    status.normal := TRUE;
    channel_found := FALSE;
    controller_element_p := NIL;
    primary_channel_found := FALSE;
    primary_channel_p := NIL;
    redundant_path := FALSE;
    selected_controller_p := NIL;

    IF channel_p = NIL THEN
      RETURN;
    IFEND;

    cmp$pc_get_logical_unit (logical_unit_number, storage_device_element_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /search_for_primary_controller/
    FOR port := LOWERVALUE (cmt$data_storage_port_number) TO UPPERVALUE (cmt$data_storage_port_number) DO
      IF NOT storage_device_element_p^.storage_device.connection.port [port].configured THEN
        CYCLE /search_for_primary_controller/;
      IFEND;

      cmp$get_element_state (storage_device_element_p^.storage_device.connection.port [port].element_name,
            {iou_name not used} osc$null_name, controller_state, local_status);
      IF NOT local_status.normal OR (controller_state <> cmc$on) THEN
        CYCLE /search_for_primary_controller/;
      IFEND;

      cmp$pc_get_element (storage_device_element_p^.storage_device.connection.port [port].element_name,
            {iou_name not used} osc$null_name, controller_element_p, local_status);
      IF NOT local_status.normal THEN
        CYCLE /search_for_primary_controller/;
      IFEND;

      primary_channel_found := FALSE;

    /search_for_primary_channel/
      FOR channel_port := LOWERVALUE (cmt$controller_port_number)
            TO UPPERVALUE (cmt$controller_port_number) DO
        IF NOT controller_element_p^.controller.connection.port [channel_port].configured THEN
          CYCLE /search_for_primary_channel/;
        IFEND;

        cmp$get_element_state (controller_element_p^.controller.connection.port [channel_port].element_name,
              controller_element_p^.controller.connection.port [channel_port].iou, channel_state,
              local_status);
        IF NOT local_status.normal OR (channel_state <> cmc$on) THEN
          CYCLE /search_for_primary_channel/;
        IFEND;

        cmp$pc_get_element (controller_element_p^.controller.connection.port [channel_port].element_name,
              controller_element_p^.controller.connection.port [channel_port].iou, channel_element_p,
              local_status);
        IF NOT local_status.normal THEN
          CYCLE /search_for_primary_channel/;
        IFEND;

        IF NOT primary_channel_found THEN
          primary_channel_p := channel_element_p;
          primary_channel_found := TRUE;
        IFEND;

        IF channels_equivalent(channel_p, channel_element_p) THEN
          channel_found := TRUE;
          EXIT /search_for_primary_controller/;
        IFEND;
      FOREND /search_for_primary_channel/;
    FOREND /search_for_primary_controller/;

    IF channel_found THEN
      selected_controller_p := controller_element_p;
      redundant_path := NOT channels_equivalent(channel_p, primary_channel_p);
    IFEND;

  PROCEND select_7155_controller;

?? OLDTITLE ??
?? NEWTITLE := 'select_controller', EJECT ??

{ PURPOSE:
{   This procedure returns the appropriate controller, if any, to be configured in the PP interface table
{   for the specified channel and unit.
{ DESIGN:
{   If the primary channel for all controllers connected to the specified unit is the same and the channel
{   specified is the primary channel, a pointer to the primary controller for the unit is returned in the
{   SELECTED_CONTROLLER_P parameter.  The primary controller of the unit is the first controller in the ON
{   state for which there is also a channel in the ON state.  The order the controllers and/or channels
{   connected to an element are checked is the order they are listed on the DEFINE_ELEMENT command.  If the
{   primary channel for all controllers connected to the specified unit are NOT the same this indicates an
{   alternate access scenario.  The controller selected will be the controller that has the specified channel
{   as its primary channel.  The order the controllers are specified on the DEFINE_ELEMENT command for each
{   unit is not significant in an alternate access scenario.  If the specified channel is not the primary
{   channel for any of the controllers connected to the unit a NIL pointer will be returned in the
{   SELECTED_CONTROLLER_P parameter

  PROCEDURE select_controller
    (    channel_p: ^cmt$element_definition;
         logical_unit_number: iot$logical_unit;
         controller_type: cmt$controller_type;
     VAR selected_controller_p: ^cmt$element_definition;
     VAR redundant_path: boolean;
     VAR status: ost$status);

    VAR
      alternate_access_controller_p: ^cmt$element_definition,
      channel_element_p: ^cmt$element_definition,
      channel_port: cmt$controller_port_number,
      channel_state: cmt$element_state,
      controller_element_p: ^cmt$element_definition,
      controller_state: cmt$element_state,
      local_status: ost$status,
      port: cmt$data_storage_port_number,
      primary_channels_equal: boolean,
      primary_channel_found: boolean,
      primary_channel_p: ^cmt$element_definition,
      primary_controller: boolean,
      primary_controller_found: boolean,
      primary_controller_p: ^cmt$element_definition,
      storage_device_element_p: ^cmt$element_definition,
      stored_primary_channel_p: ^cmt$element_definition;

    status.normal := TRUE;
    primary_channels_equal := FALSE;
    redundant_path := FALSE;
    alternate_access_controller_p := NIL;
    selected_controller_p := NIL;
    controller_element_p := NIL;
    IF channel_p = NIL THEN
      RETURN;
    IFEND;

    cmp$pc_get_logical_unit (logical_unit_number, storage_device_element_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    primary_controller_found := FALSE;
    primary_controller_p := NIL;
    primary_channel_p := NIL;

  /search_for_primary_controller/
    FOR port := LOWERVALUE (cmt$data_storage_port_number) TO UPPERVALUE (cmt$data_storage_port_number) DO
      IF NOT storage_device_element_p^.storage_device.connection.port [port].configured THEN
        CYCLE /search_for_primary_controller/;
      IFEND;

      cmp$get_element_state (storage_device_element_p^.storage_device.connection.port [port].element_name,
            {iou_name not used} osc$null_name, controller_state, local_status);
      IF NOT local_status.normal OR (controller_state <> cmc$on) THEN
        CYCLE /search_for_primary_controller/;
      IFEND;

      cmp$pc_get_element (storage_device_element_p^.storage_device.connection.port [port].element_name,
            {iou_name not used} osc$null_name, controller_element_p, local_status);
      IF NOT local_status.normal THEN
        CYCLE /search_for_primary_controller/;
      IFEND;

      primary_controller := FALSE;
      IF NOT primary_controller_found THEN
        primary_controller_p := controller_element_p;
        primary_controller_found := TRUE;
        primary_controller := TRUE;
      IFEND;

      primary_channel_found := FALSE;

    /search_for_primary_channel/
      FOR channel_port := LOWERVALUE (cmt$controller_port_number) TO
            UPPERVALUE (cmt$controller_port_number) DO
        IF NOT controller_element_p^.controller.connection.port [channel_port].configured THEN
          CYCLE /search_for_primary_channel/;
        IFEND;
        cmp$get_element_state (controller_element_p^.controller.connection.port [channel_port].element_name,
              controller_element_p^.controller.connection.port [channel_port].iou, channel_state,
              local_status);
        IF NOT local_status.normal OR (channel_state <> cmc$on) THEN
          CYCLE /search_for_primary_channel/;
        IFEND;

        cmp$pc_get_element (controller_element_p^.controller.connection.port [channel_port].element_name,
              controller_element_p^.controller.connection.port [channel_port].iou, channel_element_p,
              local_status);
        IF NOT local_status.normal THEN
          CYCLE /search_for_primary_channel/;
        IFEND;

        IF NOT primary_channel_found THEN
          primary_channel_p := channel_element_p;
          primary_channel_found := TRUE;
          EXIT /search_for_primary_channel/;
        IFEND;
      FOREND /search_for_primary_channel/;

      IF NOT primary_channel_found THEN
        IF primary_controller THEN
          primary_controller_found := FALSE;
        IFEND;
        CYCLE /search_for_primary_controller/;
      IFEND;

      { Store this controller to use if this turns out to be an alternate access connection.

      IF channels_equivalent (channel_p, primary_channel_p) THEN
        alternate_access_controller_p := controller_element_p;
      IFEND;

      IF primary_controller THEN
        stored_primary_channel_p := primary_channel_p;
        primary_channels_equal := TRUE;
        IF controller_type <> cmc$ms5831_x THEN
          EXIT /search_for_primary_controller/;
        IFEND;
      ELSEIF NOT channels_equivalent (stored_primary_channel_p, primary_channel_p) THEN
        primary_channels_equal := FALSE;
      IFEND;
    FOREND /search_for_primary_controller/;

    IF primary_channels_equal THEN
      selected_controller_p := primary_controller_p;
      redundant_path := NOT channels_equivalent (channel_p, primary_channel_p);
    ELSE
      selected_controller_p := alternate_access_controller_p;
    IFEND;

  PROCEND select_controller;
?? OLDTITLE ??
?? NEWTITLE := 'setup_pp_table ', EJECT ??

{ PURPOSE:
{   This procedure builds an entry in the logical pp table and allocates in contiguous memory various
{   structures such as the pp interface table and the pp communication buffer.

  PROCEDURE setup_pp_table
    (    pp: iot$pp_number;
         concurrent: boolean;
         allocate_commun_buffer: boolean;
         low_unit: iot$logical_unit;
         upper_unit: iot$logical_unit;
     VAR logical_pp_table_p: ^cmt$logical_pp_table;
     VAR status: ost$status);

    VAR
      iou_number: dst$iou_number,
      overlay_rma: ost$real_memory_address,
      response_buffer_p: ^iot$response_buffer_template,
      rma: integer,
      seq_p: ^SEQ ( * ),
      size: integer,
      upper_unit_bound: iot$logical_unit;

    status.normal := TRUE;

    IF upper_unit <= 0 THEN
      upper_unit_bound := 1;
    ELSE
      upper_unit_bound := upper_unit;
    IFEND;

    { Setup the PP Interface Table.

    size := #SIZE (iot$pp_interface_table: [low_unit .. upper_unit_bound]);
    dsp$allocate_continuous_memory (osv$mainframe_wired_cb_heap, size, seq_p);
    NEXT logical_pp_table_p^ [pp].pp_info.pp_interface_table_p: [low_unit .. upper_unit_bound] IN seq_p;
    i#real_memory_address (#LOC (logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^), rma);
    logical_pp_table_p^ [pp].pp_info.pp_interface_table_rma := rma;
    logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.pp_number := pp;
    logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.first_logical_unit := low_unit;
    logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.number_of_units := upper_unit - low_unit + 1;
    logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.pp_request_queue := NIL;
    i#real_memory_address (#LOC (osv$iou_external_interrupt), rma);
    logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.interrupt_register_rma := rma;

    { Setup the Channel Interlock Pointer.

    iou_number := logical_pp_table_p^ [pp].pp_info.channel.iou_number;
    IF concurrent THEN
      IF cmv$iou_table_p^ [iou_number].cio_channel_lock_p = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_nil_cm_table,
              'CIO channel lock table is NIL.', status);
        RETURN;
      IFEND;
      logical_pp_table_p^ [pp].pp_info.channel_interlock_p :=
            cmv$iou_table_p^ [iou_number].cio_channel_lock_p;
      i#real_memory_address (#LOC (cmv$iou_table_p^ [iou_number].cio_channel_lock_p^), rma);
    ELSE
      IF cmv$iou_table_p^ [iou_number].nio_channel_lock_p = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_nil_cm_table,
              'NIO channel lock table is NIL.', status);
        RETURN;
      IFEND;
      logical_pp_table_p^ [pp].pp_info.channel_interlock_p :=
            cmv$iou_table_p^ [iou_number].nio_channel_lock_p;
      i#real_memory_address (#LOC (cmv$iou_table_p^ [iou_number].nio_channel_lock_p^), rma);
    IFEND;
    logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.channel_interlock_rma := rma;

    { Allocate and initialize the PP communication buffer.

    IF allocate_commun_buffer THEN
      IF logical_pp_table_p^ [pp].controller_info.controller_type = cmc$ms5831_x THEN
        size := 2c50(16); { Special case for HPS to allow enough space to hold data while running conf. test.
                          { Based on 8192+8(sectors*tracks) which is 2bb8(16) for IBM 3.5" drives.
      ELSE
        size := #SIZE (iot$communication_buffer);
      IFEND;
      logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.communication_buffer_length := size;
      dsp$allocate_continuous_memory (osv$mainframe_wired_cb_heap, size, seq_p);
      NEXT logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p IN seq_p;
      i#real_memory_address (#LOC (logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^), rma);
      logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.communication_buffer_rma := rma;
      logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.controlware_command.command_code := 0;
      logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.
            controlware_command.flags.indirect_address := TRUE;
      logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.controlware_command.length := 0;
      logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.control_module_command.command_code := 0;
      logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.
            control_module_command.flags.indirect_address := TRUE;
      logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.control_module_command.length := 0;

      { Copy the I/O driver overlays, if any, to contiguous real memory.

      dsp$move_pp_overlays (logical_pp_table_p^ [pp].pp_info.cip_driver_name, overlay_rma, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.overlay_rma := overlay_rma;
    IFEND;

    CASE logical_pp_table_p^ [pp].pp_info.pp_type OF
    = cmc$lpt_disk_pp_type, cmc$lpt_nad_pp_type =
      dsp$move_pp_driver (logical_pp_table_p^ [pp].pp_info.cip_driver_name,
            logical_pp_table_p^ [pp].pp_info.driver_code_p);
    ELSE
    CASEND;

    { Allocate the Response Buffer.

    dsp$allocate_continuous_memory (osv$mainframe_wired_cb_heap, #SIZE (iot$response_buffer), seq_p);
    NEXT response_buffer_p IN seq_p;
    logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.response_buffer :=
          ^response_buffer_p^.response_buffer;
    logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.limit :=
          #SIZE (logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.response_buffer^);
    i#real_memory_address (#LOC (logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.response_buffer^),
          rma);
    logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.response_buffer_rma := rma;

  PROCEND setup_pp_table;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$build_interface_tables', EJECT ??

{ PURPOSE:
{   This procedure builds the pp and unit interface tables as specified by the contents of the physical
{   configuration table and the logical configuration table.

  PROCEDURE [XDCL, #GATE] cmp$build_interface_tables
    (    pp_count: iot$pp_number;
         requested_unit_count: iot$logical_unit;
         allocate_entire_configuration: boolean;
     VAR logical_unit_table_p: ^cmt$logical_unit_table;
     VAR logical_pp_table_p: ^cmt$logical_pp_table;
     VAR status: ost$status);

    status.normal := TRUE;
    #keypoint (osk$entry, 0, cmk$build_interface_tables);

  /main_program/
    BEGIN

      { Validate the parameters.

      IF (pp_count < 0) OR (pp_count > UPPERVALUE (iot$pp_number)) OR
            (requested_unit_count < LOWERVALUE (requested_unit_count)) OR
            (requested_unit_count > UPPERVALUE (requested_unit_count)) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$it_invalid_parameter,
              'Invalid pp_count and/or unit_count in cmp$build_interface_tables', status);
        EXIT /main_program/;
      IFEND;

      build_unit_interface_table (requested_unit_count, allocate_entire_configuration, logical_unit_table_p,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      build_pp_interface_table (pp_count, requested_unit_count, allocate_entire_configuration,
            logical_unit_table_p, logical_pp_table_p, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
    END /main_program/;

    #keypoint (osk$exit, 0, cmk$build_interface_tables);

  PROCEND cmp$build_interface_tables;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$build_iou_table', EJECT ??

{ PURPOSE:
{   This routine builds the iou table and initializes the appropriate channel interlock and disk usage
{   channel tables.
{ NOTE:
{   This routine is only called twice during the deadstart process, once in the Boot and once at System Core.

  PROCEDURE [XDCL] cmp$build_iou_table
    (    number_of_ious: dst$number_of_ious;
         iou_information_table: dst$iou_information_table);

    VAR
      channel_index: 0 .. ioc$max_channel_number,
      iou_array_index: dst$number_of_ious,
      iou_index: dst$iou_number,
      iou_model_type: dst$iou_model_types,
      local_iou_table_p: ^ARRAY [ * ] OF cmt$iou_table;

    ALLOCATE local_iou_table_p: [0 .. iou_information_table [number_of_ious].physical_iou_number] IN
          osv$mainframe_wired_cb_heap^;
    FOR iou_index := LOWERBOUND (local_iou_table_p^) TO UPPERBOUND (local_iou_table_p^) DO
      local_iou_table_p^ [iou_index].configured := FALSE;
      local_iou_table_p^ [iou_index].nio_channel_lock_p := NIL;
      local_iou_table_p^ [iou_index].cio_channel_lock_p := NIL;
    FOREND;

   /find_iou_info/
    FOR iou_index := LOWERBOUND (local_iou_table_p^) TO UPPERBOUND (local_iou_table_p^) DO

     /find_iou_model/
      FOR iou_array_index := 1 TO number_of_ious DO
        IF iou_information_table [iou_array_index].physical_iou_number = iou_index THEN
          local_iou_table_p^ [iou_index].configured := TRUE;
          iou_model_type := iou_information_table [iou_array_index].model_type;
          EXIT /find_iou_model/;
        IFEND;
      FOREND /find_iou_model/;
      IF NOT local_iou_table_p^ [iou_index].configured THEN
        CYCLE /find_iou_info/;
      IFEND;

      IF (iou_model_type = dsc$imn_i4_40_model) OR (iou_model_type = dsc$imn_i4_42_model) OR
            (iou_model_type = dsc$imn_i4_44_model) OR (iou_model_type = dsc$imn_i4_46_model) THEN
        ALLOCATE local_iou_table_p^ [iou_index].cio_channel_lock_p IN osv$mainframe_wired_cb_heap^;
        pmp$zero_out_table (#LOC (local_iou_table_p^ [iou_index].cio_channel_lock_p^),
              #SIZE (local_iou_table_p^ [iou_index].cio_channel_lock_p^));
        FOR channel_index := 0 TO ioc$max_channel_number DO
          local_iou_table_p^ [iou_index].cio_channel_lock_p^.
                channel_characteristics [channel_index].concurrent_channel := TRUE;
        FOREND;
      IFEND;

      IF iou_model_type <> dsc$imn_i4_44_model THEN
        ALLOCATE local_iou_table_p^ [iou_index].nio_channel_lock_p IN osv$mainframe_wired_cb_heap^;
        pmp$zero_out_table (#LOC (local_iou_table_p^ [iou_index].nio_channel_lock_p^),
              #SIZE (local_iou_table_p^ [iou_index].nio_channel_lock_p^));
        FOR channel_index := 0 TO ioc$max_channel_number DO
          local_iou_table_p^ [iou_index].nio_channel_lock_p^.
                channel_characteristics [channel_index].concurrent_channel := FALSE;
        FOREND;
      IFEND;
    FOREND /find_iou_info/;
    cmv$iou_table_p := local_iou_table_p;

  PROCEND cmp$build_iou_table;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$build_pp_table_entry',EJECT ??

{ PURPOSE:
{   This procedure builds an entry in the logical pp table.  This procedure is called after the physical
{   configuration is installed and activated.

  PROCEDURE [XDCL, #GATE] cmp$build_pp_table_entry
    (    pp_index: ARRAY [1 .. *] OF iot$pp_number;
     VAR active_elements: ARRAY [1 .. *] OF cmt$access_elements;
     VAR seq_p: ^SEQ ( * );
     VAR slave_seq_p: ^SEQ ( * );
     VAR program_description: ARRAY [1 .. *] OF cmt$pp_program_description;
     VAR master_pp_table_rma: ost$real_memory_address;
     VAR slave_pp_table_rma: ost$real_memory_address;
     VAR status: ost$status);

    CONST
      procedure_name = 'CMP$BUILD_PP_TABLE_ENTRY';

    VAR
      access_index: integer,
      allocate_commun_buffer: boolean,
      channel_name: cmt$element_name,
      cip_driver_name: dst$driver_name,
      cm_unit_type: cmt$unit_type,
      communication_buff_length: integer,
      concurrent: boolean,
      current_rma: integer,
      dual_pp: boolean,
      found: boolean,
      ica_element_p: ^cmt$element_definition,
      index: integer,
      io_unit_type: iot$unit_type,
      logical_unit_number: iot$logical_unit,
      low_unit: iot$logical_unit,
      peripheral_index: integer,
      pp: iot$pp_number,
      rma: integer,
      selected_pp_drivers: boolean,
      table_unit_desc_p: ^iot$unit_descriptors,
      temp_unit_des_p: ^ARRAY [ * ] OF t$unit_descriptor,
      unit_class: cmt$unit_class,
      unit_ordinal: iot$logical_unit,
      unit_type: iot$unit_type,
      upper_unit: iot$logical_unit;

    status.normal := TRUE;
    low_unit := 1;
    upper_unit := 0;

    { Do NOT build UIT and PPIT again if it already exists.

    FOR pp := 1 TO UPPERBOUND (program_description) DO
      IF cmv$logical_pp_table_p^ [pp_index [pp]].flags.configured THEN
        cmv$logical_pp_table_p^ [pp_index [pp]].pp_info.pp_interface_table_p^.communication_buffer_length :=
              program_description [pp].communication_buffer_length;
        RETURN;
      IFEND;
    FOREND;

    dual_pp := (UPPERBOUND (program_description) = 2);

    FOR pp := 1 TO UPPERBOUND (program_description) DO

      get_driver_name (program_description [pp].iou_program_name,
            cmv$logical_pp_table_p^ [pp_index [pp]].pp_info.channel.channel_protocol, dual_pp,
            cmv$logical_pp_table_p^ [pp_index [pp]].pp_info.driver_name);

      cip_driver_name := program_description [pp].iou_program_name (1, 7);

      cmv$logical_pp_table_p^ [pp_index [pp]].pp_info.cip_driver_name := cip_driver_name;
      retrieve_logical_pp_flags (cip_driver_name, pp_index [pp], cmv$logical_pp_table_p);

      selected_pp_drivers := ((cip_driver_name = 'ICAD') OR (cip_driver_name = 'NDI0') OR
            (cip_driver_name = 'NPDR') OR (cip_driver_name = 'ESMD') OR (cip_driver_name = 'IVB0') OR
            (cip_driver_name = 'IVB4') OR (cip_driver_name = 'NETW'));

      { Build Unit Descriptors.

      IF program_description [pp].element_access <> NIL THEN
        low_unit := ioc$max_unit_number;
        upper_unit := 0;
        FOR access_index := 1 TO UPPERBOUND (program_description [pp].element_access^) DO
          unit_ordinal := 0;

         /lun_loop/
          FOR index := cmc$job_template_unit_ordinal TO UPPERBOUND (cmv$logical_unit_table^) DO
            IF active_elements [pp].accessed_elements_p^ [access_index].lun <> 0 THEN

              IF cmv$logical_unit_table^ [index].logical_unit_number =
                    active_elements [pp].accessed_elements_p^ [access_index].lun THEN

                { Build UIT for ICA, MTI, MDI, ESM or LCN but NOT for TAPE.

                IF selected_pp_drivers THEN
                  IF upper_unit < index THEN
                    upper_unit := index;
                  IFEND;
                  IF low_unit > index THEN
                    low_unit := index;
                  IFEND;
                  IF cmv$logical_unit_table^ [index].unit_interface_table = NIL THEN
                    unit_ordinal := active_elements [pp].accessed_elements_p^ [access_index].lun;
                  IFEND;
                ELSE

                  { Build UIT for Foreign Devices.

                  IF upper_unit < active_elements [pp].accessed_elements_p^ [access_index].lun THEN
                    upper_unit := active_elements [pp].accessed_elements_p^ [access_index].lun;
                  IFEND;
                  IF low_unit > active_elements [pp].accessed_elements_p^ [access_index].lun THEN
                    low_unit := active_elements [pp].accessed_elements_p^ [access_index].lun;
                  IFEND;
                  IF cmv$logical_unit_table^ [index].unit_interface_table = NIL THEN
                    unit_ordinal := active_elements [pp].accessed_elements_p^ [access_index].lun;
                  IFEND;
                IFEND;
                EXIT /lun_loop/;
              IFEND;
            ELSE

              { Build UIT for device NOT in the active configuration.

              IF NOT cmv$logical_unit_table^ [index].configured AND
                    (cmv$logical_unit_table^ [index].unit_interface_table = NIL) AND
                    (cmv$logical_unit_table^ [index].logical_unit_number = 0) THEN
                unit_ordinal := index;
                active_elements [pp].accessed_elements_p^ [access_index].lun := index;
                IF upper_unit < index THEN
                  upper_unit := index;
                IFEND;
                IF low_unit > index THEN
                  low_unit := index;
                IFEND;
              ELSE
                IF upper_unit < active_elements [pp].accessed_elements_p^ [access_index].lun THEN
                  upper_unit := active_elements [pp].accessed_elements_p^ [access_index].lun;
                IFEND;
                IF low_unit > active_elements [pp].accessed_elements_p^ [access_index].lun THEN
                  low_unit := active_elements [pp].accessed_elements_p^ [access_index].lun;
                IFEND;
              IFEND;
              EXIT /lun_loop/;
            IFEND;
          FOREND /lun_loop/;

          { Build UIT.

          IF unit_ordinal <> 0 THEN
            IF cip_driver_name = 'ICAD' THEN
              cmp$pc_get_logical_unit (unit_ordinal, ica_element_p, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              cmp$get_unit_type (ica_element_p^.product_id, cm_unit_type, io_unit_type, unit_class, found);
              unit_type := io_unit_type;
            ELSEIF (cip_driver_name = 'NPDR') OR (cip_driver_name = 'NDI0') THEN
              unit_type := ioc$dt_lcn_1;
            ELSEIF cip_driver_name = 'NETW' THEN
              unit_type := ioc$dt_mdi_1;
            ELSEIF cip_driver_name = 'ESMD' THEN
              unit_type := ioc$dt_file_server;
            ELSEIF (cip_driver_name = 'IVB0') OR (cip_driver_name = 'IVB4') THEN
              unit_type := ioc$dt_expresslink;
            ELSE
              unit_type := ioc$dt_foreign_device;
            IFEND;
            build_logical_unit_entry (unit_ordinal, unit_type, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        FOREND;
      IFEND;

      IF (program_description [pp].element_access <> NIL) AND
            (cmc$channel IN program_description [pp].element_access^ [1].physical_address_specifier) THEN
        concurrent := (program_description [pp].element_access^ [1].channel.ordinal > cmc$channel27);
      ELSEIF cmv$logical_pp_table_p^ [pp_index [pp]].flags.reservd_by_other_has_ch_present THEN
        concurrent :=
              (cmv$logical_pp_table_p^ [pp_index [pp]].pp_info.channel.channel_protocol = dsc$cpt_cio);
      ELSE
        concurrent := (program_description[pp].pp_identification.ordinal > cmc$pp19);
      IFEND;

      { Build UNIT_DESCRIPTORS in for PPIT.

      IF program_description [pp].element_access <> NIL THEN
        PUSH temp_unit_des_p: [low_unit .. upper_unit];
        pmp$zero_out_table (#LOC (temp_unit_des_p^), #SIZE (temp_unit_des_p^));
        FOR access_index := 1 TO UPPERBOUND (program_description [pp].element_access^) DO
          logical_unit_number := active_elements [pp].accessed_elements_p^ [access_index].lun;
          IF (logical_unit_number <> 0) AND (logical_unit_number >= low_unit) AND
                (logical_unit_number <= upper_unit) THEN
            temp_unit_des_p^ [logical_unit_number].configured := TRUE;
            cmp$convert_channel_ordinal (
                  program_description [pp].element_access^ [access_index].channel.ordinal,
                  channel_name, temp_unit_des_p^ [logical_unit_number].channel.number,
                  temp_unit_des_p^ [logical_unit_number].channel.concurrent,
                  temp_unit_des_p^ [logical_unit_number].channel.port, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF selected_pp_drivers THEN
              temp_unit_des_p^ [logical_unit_number].controller_number :=
                    program_description [pp].element_access^ [access_index].channel_address;
            ELSE
              temp_unit_des_p^ [logical_unit_number].unit_number :=
                    program_description [pp].element_access^ [access_index].unit_address;
              temp_unit_des_p^ [logical_unit_number].controller_number :=
                    program_description [pp].element_access^ [access_index].channel_address;
            IFEND;
          IFEND;
        FOREND;
      IFEND;

      IF dual_pp THEN
        IF pp = 1 THEN
          cmv$logical_pp_table_p^ [pp_index [pp]].pp_info.logical_partner_pp_index := pp_index [pp] + 1;
        ELSE
          cmv$logical_pp_table_p^ [pp_index [pp]].pp_info.logical_partner_pp_index := pp_index [pp] - 1;
        IFEND;
      IFEND;

      { Get response handler pointer.

      allocate_commun_buffer := TRUE;
      IF cip_driver_name = 'ICAD' THEN
        cmp$get_response_handler (cmc$ca2629_2,
              cmv$logical_pp_table_p^ [pp_index [pp]].handlers.response_handler_p);
        cmv$logical_pp_table_p^ [pp_index [pp]].controller_info.controller_type := cmc$ca2629_2;
      ELSEIF cip_driver_name = 'SPI ' THEN
        cmv$logical_pp_table_p^ [pp_index [pp]].handlers.response_handler_p := osv$spi_response_processor;
        allocate_commun_buffer := FALSE;
      ELSEIF (cip_driver_name = 'NPDR') OR (cip_driver_name = 'NDI0') THEN
        cmp$get_response_handler (cmc$lcn380_170,
              cmv$logical_pp_table_p^ [pp_index [pp]].handlers.response_handler_p);
        cmv$logical_pp_table_p^ [pp_index [pp]].controller_info.controller_type := cmc$lcn380_170;
      ELSEIF cip_driver_name = 'ESMD' THEN
        cmp$get_response_handler (cmc$fs740_200,
              cmv$logical_pp_table_p^ [pp_index [pp]].handlers.response_handler_p);
        cmv$logical_pp_table_p^ [pp_index [pp]].controller_info.controller_type := cmc$fs740_200;
      ELSEIF (cip_driver_name = 'IVB0') OR (cip_driver_name = 'IVB4') THEN
        cmp$get_response_handler (cmc$expresslink,
              cmv$logical_pp_table_p^ [pp_index [pp]].handlers.response_handler_p);
        cmv$logical_pp_table_p^ [pp_index [pp]].controller_info.controller_type := cmc$expresslink;
      ELSEIF cip_driver_name = 'NETW' THEN

       /peripheral_loop/
        FOR peripheral_index := LOWERBOUND (cmv$peripheral_element_table.pointer^) TO
              UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
          IF cmv$peripheral_element_table.pointer^ [peripheral_index].logical_unit_number =
                active_elements [pp].accessed_elements_p^ [1].lun THEN
            IF cmv$peripheral_element_table.pointer^ [peripheral_index].product_id.product_number =
                  ' $2620' THEN
              cmp$get_response_handler (cmc$mti2620_21x,
                    cmv$logical_pp_table_p^ [pp_index [pp]].handlers.response_handler_p);
              cmv$logical_pp_table_p^ [pp_index [pp]].controller_info.controller_type := cmc$mti2620_21x;
            ELSEIF cmv$peripheral_element_table.pointer^ [peripheral_index].product_id.product_number =
                  ' $2621' THEN
              cmp$get_response_handler (cmc$mdi2621_21x,
                    cmv$logical_pp_table_p^ [pp_index [pp]].handlers.response_handler_p);
              cmv$logical_pp_table_p^ [pp_index [pp]].controller_info.controller_type := cmc$mdi2621_21x;
            IFEND;
            EXIT /peripheral_loop/;
          IFEND;
        FOREND /peripheral_loop/;

        { This code is only used for internal testing.

      ELSEIF cmv$logical_pp_table_p^ [pp_index [pp]].pp_info.pp_type = cmc$lpt_tape_pp_type THEN
        cmp$get_response_handler (cmc$mt5698_xx,
              cmv$logical_pp_table_p^ [pp_index [pp]].handlers.response_handler_p);
      ELSE

        { Foreign Subsystem, set ALLOCATE_COMMUN_BUFFER to FALSE assuming caller already allocate wired area
        { for PP communication buffer.

        allocate_commun_buffer := FALSE;
        cmv$logical_pp_table_p^ [pp_index [pp]].handlers.response_handler_p := cmv$default_response_handler;
      IFEND;

      setup_pp_table (pp_index [pp], concurrent, allocate_commun_buffer, low_unit, upper_unit,
            cmv$logical_pp_table_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF pp = 1 THEN
        master_pp_table_rma := cmv$logical_pp_table_p^ [pp_index [pp]].pp_info.pp_interface_table_rma;
      ELSE
        slave_pp_table_rma := cmv$logical_pp_table_p^ [pp_index [pp]].pp_info.pp_interface_table_rma;
      IFEND;

      IF NOT allocate_commun_buffer AND (program_description [pp].communication_buffer_length > 0) THEN
        communication_buff_length := program_description [pp].communication_buffer_length;
        IF communication_buff_length = osc$max_page_size THEN
          communication_buff_length := communication_buff_length - 1;
        IFEND;
        IF pp = 1 THEN
          i#real_memory_address (#LOC (seq_p^), current_rma);
          cmv$logical_pp_table_p^ [pp_index [pp]].pp_info.pp_communication_buffer_p := #LOC (seq_p^);
        ELSE
          i#real_memory_address (#LOC (slave_seq_p^), current_rma);
          cmv$logical_pp_table_p^ [pp_index [pp]].pp_info.pp_communication_buffer_p := #LOC (slave_seq_p^);
        IFEND;
        cmv$logical_pp_table_p^ [pp_index [pp]].pp_info.pp_interface_table_p^.communication_buffer_length
              := communication_buff_length;
        cmv$logical_pp_table_p^ [pp_index [pp]].pp_info.pp_interface_table_p^.communication_buffer_rma :=
              current_rma;
      IFEND;

      { Initialize unit descriptors in the pp_interface_table_p.

      IF program_description [pp].element_access <> NIL THEN
        table_unit_desc_p :=
              ^cmv$logical_pp_table_p^ [pp_index [pp]].pp_info.pp_interface_table_p^.unit_descriptors;
        build_unit_descriptors (low_unit, upper_unit, cmv$logical_unit_table, NIL, temp_unit_des_p,
              cmv$logical_pp_table_p^ [pp_index [pp]].controller_info.controller_type, table_unit_desc_p);
      ELSE
        cmv$logical_pp_table_p^ [pp_index [pp]].pp_info.pp_interface_table_p^.number_of_units := 0;
      IFEND;
      cmv$logical_pp_table_p^ [pp_index [pp]].flags.configured := TRUE;
    FOREND;

    cmp$get_max_number_of_pp (cmv$max_number_of_pp);

    { Load controlware for the ICA.

    FOR pp := 1 TO UPPERBOUND (program_description) DO
      IF program_description [pp].iou_program_name (1, 4) = 'ICAD' THEN
        cmp$load_controller_module (cmc$load_controlware, cmv$logical_pp_table_p, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND cmp$build_pp_table_entry;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$clear_channel_interlock', EJECT ??

{ PURPOSE:
{   This procedure clears the entry in the channel interlock table for the sepcified IOU and logical
{   PP number.

  PROCEDURE [XDCL, #GATE] cmp$clear_channel_interlock
    (    iou_number: dst$iou_number;
         logical_pp_number: iot$pp_number;
     VAR status: ost$status);

    TYPE
      t$channel_lock = RECORD
        CASE (c$cpu_lock, c$pp_lock) OF
        = c$cpu_lock =
          cpu_lock: integer,
        = c$pp_lock =
          pp_lock: iot$table_lock_entry,
        CASEND,
      RECEND;

    VAR
      actual: t$channel_lock,
      ch_p: ^integer,
      done: boolean,
      final: t$channel_lock,
      found: boolean,
      index: integer,
      initial: t$channel_lock;

    status.normal := TRUE;

    IF NOT cmv$iou_table_p^ [iou_number].configured THEN
      RETURN;
    IFEND;

    IF cmv$iou_table_p^ [iou_number].nio_channel_lock_p <> NIL THEN
      FOR index := LOWERBOUND (cmv$iou_table_p^ [iou_number].nio_channel_lock_p^.channel_table) TO
            UPPERBOUND (cmv$iou_table_p^ [iou_number].nio_channel_lock_p^.channel_table) DO
        IF cmv$iou_table_p^ [iou_number].nio_channel_lock_p^.channel_table [index].locking_pp =
               logical_pp_number THEN
          ch_p := #LOC (cmv$iou_table_p^ [iou_number].nio_channel_lock_p^.channel_table [index]);
          actual.cpu_lock := 0;
          done := FALSE;
          REPEAT
            initial.pp_lock := actual.pp_lock;
            final.pp_lock := actual.pp_lock;
            final.pp_lock.channel_locked := FALSE;
            final.pp_lock.maintenance_need_channel := FALSE;
            osp$set_locked_variable (ch_p^, initial.cpu_lock, final.cpu_lock, actual.cpu_lock, done);
          UNTIL done;
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    IF cmv$iou_table_p^ [iou_number].cio_channel_lock_p <> NIL THEN
      FOR index := LOWERBOUND (cmv$iou_table_p^ [iou_number].cio_channel_lock_p^.channel_table) TO
            UPPERBOUND (cmv$iou_table_p^ [iou_number].cio_channel_lock_p^.channel_table) DO
        IF cmv$iou_table_p^ [iou_number].cio_channel_lock_p^.channel_table [index].locking_pp =
              logical_pp_number THEN
          ch_p := #LOC (cmv$iou_table_p^ [iou_number].cio_channel_lock_p^.channel_table [index]);
          actual.cpu_lock := 0;
          done := FALSE;
          REPEAT
            initial.pp_lock := actual.pp_lock;
            final.pp_lock := actual.pp_lock;
            final.pp_lock.channel_locked := FALSE;
            final.pp_lock.maintenance_need_channel := FALSE;
            osp$set_locked_variable (ch_p^, initial.cpu_lock, final.cpu_lock, actual.cpu_lock, done);
          UNTIL done;
          RETURN;
        IFEND;
      FOREND;
    IFEND;

  PROCEND cmp$clear_channel_interlock;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$clear_element_lock', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$clear_element_lock
    (VAR status: ost$status);

    status.normal := TRUE;

    osp$clear_signature_lock (cmv$element_reservation_lock, status);

  PROCEND cmp$clear_element_lock;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$clear_unit_shared',EJECT ??

{ PURPOSE:
{   This procedure clears the unit shared bit of the given logical unit

  PROCEDURE [XDCL, #GATE] cmp$clear_unit_shared
    (    logical_unit: iot$logical_unit;
         set_lock: boolean);

    VAR
      index: integer,
      lock_obtained: boolean;

    IF cmv$logical_unit_table = NIL THEN
      RETURN;
    IFEND;

    { Check to see if the peripheral element table is built.  If it is not build then it is before
    { transition time, go ahead and clear the unit shared.

    IF cmv$peripheral_element_table.pointer = NIL THEN
      IF NOT cmv$logical_unit_table^ [logical_unit].configured THEN
        RETURN;
      IFEND;
      IF set_lock THEN
        cmp$lock_lun_entry (logical_unit, lock_obtained);
        IF NOT lock_obtained THEN
          osp$system_error (' Unable to set CMV$LOGICAL_UNIT lock', NIL);
        IFEND;
      IFEND;
      cmv$logical_unit_table^ [logical_unit].unit_interface_table^.unit_shared := FALSE;
      IF set_lock THEN
        cmp$unlock_lun_entry (logical_unit, lock_obtained);
      IFEND;
      RETURN;
    IFEND;

    IF UPPERBOUND (cmv$peripheral_element_table.pointer^) <= 0 THEN
      RETURN;
    IFEND;

    FOR index := 1 TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
      IF (cmv$peripheral_element_table.pointer^ [index].logical_unit_number = logical_unit) AND
            (cmv$peripheral_element_table.pointer^ [index].maintenance_activity.
            con_access_job_list <> NIL) AND
            (cmv$peripheral_element_table.pointer^ [index].maintenance_activity.
            con_access_job_list^.forward_link = NIL) AND
            cmv$logical_unit_table^ [logical_unit].configured THEN

        IF set_lock THEN
          cmp$lock_lun_entry (logical_unit, lock_obtained);
          IF NOT lock_obtained THEN
            osp$system_error (' Unable to set CMV$LOGICAL_UNIT lock', NIL);
          IFEND;
        IFEND;
        cmv$logical_unit_table^ [logical_unit].unit_interface_table^.unit_shared := FALSE;
        IF set_lock THEN
          cmp$unlock_lun_entry (logical_unit, lock_obtained);
        IFEND;
        RETURN;
      IFEND;
    FOREND;

  PROCEND cmp$clear_unit_shared;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$crack_physical_address ', EJECT ??

{ PURPOSE:
{   This procedure convert the physical address given the information about an element being reserved via
{   the CYBIL Program Interface type cmt$element_reservation.

  PROCEDURE [XDCL] cmp$crack_physical_address
    (    element_reservation: cmt$element_reservation;
     VAR iou: dst$iou_number;
     VAR channel: cmt$physical_channel;
     VAR channel_address: cmt$physical_equipment_number;
     VAR unit_address: cmt$physical_unit_number;
     VAR status: ost$status);

   VAR
     channel_definition: cmt$data_channel_definition,
     channel_name: cmt$element_name;

    status.normal := TRUE;
    iou := 0;
    channel.number := 0;
    channel.port := cmc$unspecified_port;
    channel.concurrent := FALSE;
    channel_address := 0;
    unit_address := 0;

    CASE element_reservation.element_type OF
    = cmc$data_channel_element =
      cmp$get_channel_def (element_reservation.channel_descriptor, channel_definition, status);
      IF NOT status.normal THEN
        IF status.condition = cme$lcm_element_not_found THEN
          status.normal := TRUE;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      cmp$convert_iou_name (channel_definition.iou, iou, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      channel.number := channel_definition.number;
      channel.concurrent := channel_definition.concurrent;
      channel.port := channel_definition.port;

    = cmc$controller_element, cmc$storage_device_element, cmc$external_processor_element,
          cmc$communications_element, cmc$channel_adapter_element =
      IF element_reservation.peripheral_descriptor.use_logical_identification THEN
        RETURN;
      IFEND;

      IF cmc$iou IN element_reservation.peripheral_descriptor.hardware_address.physical_address_specifier THEN
        cmp$convert_iou_name (element_reservation.peripheral_descriptor.hardware_address.iou, iou, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF cmc$channel IN element_reservation.peripheral_descriptor.hardware_address.
            physical_address_specifier THEN
        cmp$convert_channel_ordinal (element_reservation.peripheral_descriptor.hardware_address.
              channel.ordinal, channel_name, channel.number, channel.concurrent, channel.port, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF cmc$channel_address IN element_reservation.peripheral_descriptor.hardware_address.
            physical_address_specifier THEN
        channel_address := element_reservation.peripheral_descriptor.hardware_address.channel_address;
      IFEND;

      IF cmc$unit_address IN element_reservation.peripheral_descriptor.hardware_address.
            physical_address_specifier THEN
        unit_address := element_reservation.peripheral_descriptor.hardware_address.unit_address;
      IFEND;

    = cmc$pp_element =
      IF element_reservation.pp_reservation.selector = cmc$choose_pp_by_channel THEN
        cmp$convert_iou_name (element_reservation.pp_reservation.channel.iou, iou, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        cmp$convert_channel_ordinal (element_reservation.pp_reservation.channel.ordinal, channel_name,
              channel.number, channel.concurrent, channel.port, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    ELSE
      osp$set_status_abnormal (cmc$configuration_management_id, cme$cm_end_case_error,
            'CMP$CRACK_PHYSICAL_ADDRESS', status);
    CASEND;

  PROCEND cmp$crack_physical_address;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$dft_acquire_maintenance', EJECT ??

{ PURPOSE:
{   This procedure acquire maintenance access to an element for any DFT request that requires accessing the
{   deadstart sector.  This process is required to avoid conflict should MALET/VE be running at the same time
{   on the same element.

  PROCEDURE [XDCL] cmp$dft_acquire_maintenance
    (    device_path: dst$device_path;
     VAR device_information: cmt$device_information;
     VAR controller_name: cmt$element_name;
     VAR element_name: cmt$element_name;
     VAR unit_shared_interlock_set: boolean;
     VAR maintenance_acquired: boolean;
     VAR status: ost$status);

    VAR
      channel_name: cmt$element_name,
      channel_ordinal: cmt$channel_ordinal,
      channel_port: cmt$channel_port,
      concurrent: boolean,
      controller_definition_p: ^cmt$element_definition,
      iou_array_index: dst$number_of_ious,
      iou_number: dst$iou_number,
      iou_information_table: dst$iou_information_table,
      iou_model_type: dst$iou_model_types,
      controller_name_found: boolean,
      element_definition_p: ^cmt$element_definition,
      element_descriptor: cmt$element_descriptor,
      element_reservation: cmt$element_reservation,
      element_type: cmt$element_type,
      first_logical_unit: iot$logical_unit,
      iou_name: cmt$element_name,
      job_name: jmt$system_supplied_name,
      length: integer,
      number_of_ious: dst$number_of_ious,
      number_of_units: iot$logical_unit,
      number_string: string (6),
      peripheral_index: integer,
      port_number: cmt$data_storage_port_number,
      pp_number: iot$pp_number,
      unit_information_found: boolean,
      unit_number: iot$logical_unit,
      user_name: jmt$user_supplied_name,
      valid: boolean;

    status.normal := TRUE;
    unit_shared_interlock_set := FALSE;
    maintenance_acquired := FALSE;
    concurrent := FALSE;
    channel_port := cmc$unspecified_port;

    { If the configuration is not activated then it is not necessary to acquire maintenance.

    IF NOT cmv$configuration_activated THEN
      RETURN;
    IFEND;

    unit_information_found := FALSE;

    { Check to see if the tables are defined.

    IF cmv$logical_pp_table_p = NIL THEN
      osp$set_status_abnormal (cmc$configuration_management_id,
            cme$pointer_not_defined, 'cmv$logical_pp_table_p', status);
      RETURN;
    IFEND;
    IF cmv$peripheral_element_table.pointer = NIL THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pointer_not_defined,
            'cmv$peripheral_element_table.pointer', status);
      RETURN;
    IFEND;

    { Find the channel number and unit type.  The maintenance only needs to be acquired for 844, 885 and HPS
    { device types.

    device_information.channel_number := device_path.channel_number;
    device_information.iou_number := device_path.iou_number;
    dsp$retrieve_iou_information (number_of_ious, iou_information_table);

   /find_iou_model/
    FOR iou_array_index := LOWERBOUND (iou_information_table) TO UPPERBOUND (iou_information_table) DO
      IF iou_information_table [iou_array_index].physical_iou_number = device_information.iou_number THEN
        iou_model_type := iou_information_table [iou_array_index].model_type;
        EXIT /find_iou_model/;
      IFEND;
    FOREND /find_iou_model/;

    concurrent := (iou_model_type = dsc$imn_i4_44_model) OR (iou_model_type = dsc$imn_i4_46_model);
    CASE device_path.device_type OF
    = dmc$844_double_density =
      device_information.unit_type := ioc$dt_ms844_4x;
    = dmc$885 =
      device_information.unit_type := ioc$dt_ms885_1x;
    ELSE
      RETURN;
    CASEND;

    { Search the logical pp table for the correct unit.

   /search_pp_table/
    FOR pp_number := 1 TO UPPERBOUND (cmv$logical_pp_table_p^) DO
      IF NOT cmv$logical_pp_table_p^ [pp_number].flags.configured THEN
        CYCLE /search_pp_table/;
      IFEND;

      first_logical_unit :=
            cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p^.first_logical_unit;
      number_of_units := cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p^.number_of_units;

     /find_unit_information/
      FOR unit_number := first_logical_unit TO (first_logical_unit + number_of_units - 1) DO
        IF NOT cmv$logical_unit_table^ [unit_number].configured THEN
          CYCLE /find_unit_information/;
        IFEND;
        IF cmv$logical_unit_table^ [unit_number].logical_unit_number <> unit_number THEN
          CYCLE /find_unit_information/;
        IFEND;
        IF cmv$logical_unit_table^ [unit_number].unit_interface_table^.unit_type <>
              device_information.unit_type THEN
          CYCLE /find_unit_information/;
        IFEND;
        IF (cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p^.
              unit_descriptors [unit_number].physical_path.channel_number <> device_path.channel_number) OR
              (cmv$logical_pp_table_p^ [pp_number].pp_info.channel.iou_number <> device_path.iou_number) OR
              (concurrent <> cmv$logical_pp_table_p^ [pp_number].pp_info.channel_interlock_p^.
              channel_characteristics [device_path.channel_number].concurrent_channel) THEN
          CYCLE /find_unit_information/;
        IFEND;

        device_information.unit_number :=
              cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p^.
              unit_descriptors [unit_number].physical_path.physical_unit_number;
        device_information.equipment_number :=
              cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p^.
              unit_descriptors [unit_number].physical_path.controller_number;

        IF device_information.unit_number = device_path.unit_number THEN
          device_information.logical_unit := unit_number;
          unit_information_found := TRUE;
          EXIT /search_pp_table/;
        IFEND;

      FOREND /find_unit_information/;
    FOREND /search_pp_table/;

    IF NOT unit_information_found THEN
      IF NOT device_path.cip_path THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$search_not_found, 'unit information',
              status);
      IFEND;
      RETURN;
    IFEND;

    { Find the element name and the controller name.

    cmp$get_element_name_via_lun (device_information.logical_unit, element_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cmp$pc_get_element (element_name, {not used} iou_name, element_definition_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    controller_name_found := FALSE;

   /find_controller_name/
    FOR port_number := LOWERVALUE (cmt$data_storage_port_number) TO
          UPPERVALUE (cmt$data_storage_port_number) DO
      IF NOT element_definition_p^.storage_device.connection.port [port_number].configured THEN
        CYCLE /find_controller_name/;
      IFEND;
      cmp$pc_get_element (element_definition_p^.storage_device.connection.port [port_number].element_name,
            iou_name, controller_definition_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (controller_definition_p^.element_type = cmc$controller_element) AND
            (controller_definition_p^.controller.physical_equipment_number =
            device_information.equipment_number) THEN
        controller_name := controller_definition_p^.element_name;
        controller_name_found := TRUE;
        EXIT /find_controller_name/;
      IFEND;
    FOREND /find_controller_name/;

    IF NOT controller_name_found THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$search_not_found, 'controller name',
            status);
      RETURN;
    IFEND;

    pmp$get_job_names (user_name, job_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cmp$convert_iou_number (device_information.iou_number, iou_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

   /add_access_job/
    FOR element_type := LOWERVALUE (cmt$element_type) TO UPPERVALUE (cmt$element_type) DO
      element_descriptor.element_type := element_type;
      CASE element_descriptor.element_type OF
      = cmc$data_channel_element =
        element_descriptor.channel_descriptor.iou := iou_name;
        element_descriptor.channel_descriptor.use_logical_identification := TRUE;
        cmp$convert_channel_number (device_information.channel_number, concurrent, channel_port,
              channel_ordinal, channel_name, valid);
        IF valid THEN
          element_descriptor.channel_descriptor.name := channel_name;
        ELSE
          STRINGREP (number_string, length, device_information.channel_number);
          osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_channel_number, number_string,
                status);
          RETURN;
        IFEND;

      = cmc$controller_element =
        element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
        element_descriptor.peripheral_descriptor.element_name := controller_name;

      = cmc$storage_device_element =
        element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
        element_descriptor.peripheral_descriptor.element_name := element_name;
      ELSE
        CYCLE /add_access_job/;
      CASEND;

      cmp$search_peripheral_table (element_descriptor, element_reservation, FALSE, peripheral_index, status);
      IF NOT status.normal AND (status.condition = cme$cm_element_not_found) THEN
        status.normal := TRUE;
        CYCLE /add_access_job/;
      IFEND;
      msp$add_con_access_job (peripheral_index, job_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND /add_access_job/;

    maintenance_acquired := TRUE;

    cmp$set_unit_shared (device_information.logical_unit, unit_shared_interlock_set);

  PROCEND cmp$dft_acquire_maintenance;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$dft_release_maintenance', EJECT ??

{ PURPOSE:
{   This procedure releases the maintenance access for DFT requests requiring deadstart sector access.

  PROCEDURE [XDCL] cmp$dft_release_maintenance
    (    device_information: cmt$device_information;
         controller_name: cmt$element_name;
         element_name: cmt$element_name;
         unit_shared_interlock_set: boolean;
     VAR status: ost$status);

    VAR
      channel_name: cmt$element_name,
      channel_ordinal: cmt$channel_ordinal,
      channel_port: cmt$channel_port,
      concurrent: boolean,
      element_descriptor: cmt$element_descriptor,
      element_reservation: cmt$element_reservation,
      element_type: cmt$element_type,
      iou_name: cmt$element_name,
      job_name: jmt$system_supplied_name,
      length: integer,
      number_string: string (6),
      peripheral_index: integer,
      user_name: jmt$user_supplied_name,
      valid: boolean;

    status.normal := TRUE;
    concurrent := FALSE;
    channel_port := cmc$unspecified_port;

    { If the configuration is not activated then it is not necessary to release maintenance.

    IF NOT cmv$configuration_activated THEN
      RETURN;
    IFEND;

    cmp$clear_unit_shared (device_information.logical_unit, unit_shared_interlock_set);

    { Check to see if the tables are defined.

    IF cmv$peripheral_element_table.pointer = NIL THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pointer_not_defined,
            'cmv$peripheral_element_table.pointer', status);
      RETURN;
    IFEND;

    pmp$get_job_names (user_name, job_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$convert_iou_number (device_information.iou_number, iou_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

   /delete_access_job/
    FOR element_type := LOWERVALUE (cmt$element_type) TO UPPERVALUE (cmt$element_type) DO
      element_descriptor.element_type := element_type;
      CASE element_descriptor.element_type OF
      = cmc$data_channel_element =
        element_descriptor.channel_descriptor.iou := iou_name;
        element_descriptor.channel_descriptor.use_logical_identification := TRUE;
        cmp$convert_channel_number (device_information.channel_number, concurrent, channel_port,
              channel_ordinal, channel_name, valid);
        IF valid THEN
          element_descriptor.channel_descriptor.name := channel_name;
        ELSE
          STRINGREP (number_string, length, device_information.channel_number);
          osp$set_status_abnormal (cmc$configuration_management_id, cme$invalid_channel_number, number_string,
                status);
          RETURN;
        IFEND;

      = cmc$controller_element =
        element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
        element_descriptor.peripheral_descriptor.element_name := controller_name;
      = cmc$storage_device_element =
        element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
        element_descriptor.peripheral_descriptor.element_name := element_name;
      ELSE
        CYCLE /delete_access_job/;
      CASEND;

      cmp$search_peripheral_table (element_descriptor, element_reservation, FALSE, peripheral_index, status);
      IF NOT status.normal AND (status.condition = cme$cm_element_not_found) THEN
        status.normal := TRUE;
        CYCLE /delete_access_job/;
      IFEND;
      msp$delete_con_access_job (peripheral_index, job_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND /delete_access_job/;

  PROCEND cmp$dft_release_maintenance;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$find_primary_controller', EJECT ??

{ PURPOSE:
{   This procedure will return the primary controller for the specified logical unit.  If no controllers are
{   in the on state the first controller will be returned.

  PROCEDURE [XDCL, #GATE] cmp$find_primary_controller
    (    logical_unit_number: iot$logical_unit;
     VAR controller_element_p: ^cmt$element_definition;
     VAR status: ost$status);

    VAR
      channel_port: integer,
      channel_state: cmt$element_state,
      controller_state: cmt$element_state,
      iou_name: cmt$element_name,
      local_status: ost$status,
      port: cmt$data_storage_port_number,
      state: cmt$element_state,
      storage_device_element_p: ^cmt$element_definition;

     status.normal := TRUE;
     controller_element_p := NIL;
     cmp$pc_get_logical_unit (logical_unit_number, storage_device_element_p, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

     FOR port := LOWERVALUE (cmt$data_storage_port_number) TO UPPERVALUE (cmt$data_storage_port_number) DO
       IF storage_device_element_p^.storage_device.connection.port [port].configured THEN
         cmp$get_element_state (storage_device_element_p^.storage_device.connection.port [port].element_name,
               iou_name, controller_state, local_status);

         { Find the first ON controller connected to the storage device element or if there is only one
         { controller, it will be returned.

         IF (controller_state = cmc$on) OR (controller_element_p = NIL) THEN
           cmp$pc_get_element (
                 storage_device_element_p^.storage_device.connection.port [port].element_name,
                 iou_name, controller_element_p, local_status);
           IF local_status.normal THEN
             FOR channel_port := LOWERVALUE (cmt$controller_port_number) TO
                   UPPERVALUE (cmt$controller_port_number) DO
               IF controller_element_p^.controller.connection.port [channel_port].configured THEN
                 cmp$get_element_state (
                       controller_element_p^.controller.connection.port [channel_port].element_name,
                       controller_element_p^.controller.connection.port [channel_port].iou,
                       channel_state, local_status);
                 IF (channel_state = cmc$on) AND (controller_state = cmc$on) THEN
                   RETURN;
                 IFEND;
               IFEND;
             FOREND;
           IFEND;
         IFEND;
       IFEND;
     FOREND;

  PROCEND cmp$find_primary_controller;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$free_element_def_table', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$free_element_def_table;

    VAR
      table_index : integer;

    IF cmv$peripheral_element_table.pointer = NIL THEN
      RETURN;
    IFEND;

    FOR table_index := LOWERBOUND (cmv$peripheral_element_table.pointer^) TO
           UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
      CASE cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.element_type OF
      = cmc$controller_element, cmc$external_processor_element, cmc$channel_adapter_element,
            cmc$communications_element =
        IF cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.equipment_path <> NIL THEN
          FREE cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.equipment_path IN
                osv$mainframe_wired_cb_heap^;
        IFEND;
      = cmc$storage_device_element =
        IF cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.unit_path <> NIL THEN
          FREE cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.unit_path IN
                osv$mainframe_wired_cb_heap^;
        IFEND;
      ELSE
      CASEND;
    FOREND;
    FREE cmv$peripheral_element_table.pointer IN osv$mainframe_wired_cb_heap^;

  PROCEND cmp$free_element_def_table;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_logical_pp_index', EJECT ??

{ PURPOSE:
{   This procedure retrieves an index into the Logical PP Table using a channel element definition.

  PROCEDURE [XDCL, #GATE] cmp$get_logical_pp_index
    (    channel_element: cmt$element_definition;
     VAR logical_pp_index: iot$pp_number;
     VAR status: ost$status);

    VAR
      channel: dst$iou_resource,
      iou_number: dst$iou_number,
      pp_index: iot$pp_number;

    status.normal := TRUE;
    logical_pp_index := 0;

    cmp$convert_iou_name (channel_element.data_channel.iou, channel.iou_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF channel_element.data_channel.concurrent THEN
      channel.channel_protocol := dsc$cpt_cio;
    ELSE
      channel.channel_protocol := dsc$cpt_nio;
    IFEND;
    channel.number := channel_element.data_channel.number;

    FOR pp_index := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
      IF cmv$logical_pp_table_p^ [pp_index].flags.configured AND
            (cmv$logical_pp_table_p^ [pp_index].pp_info.channel = channel) AND
            (cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.unit_descriptors
            [cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.first_logical_unit].
            unit_interface_table <> NIL) THEN
        logical_pp_index := pp_index;
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_not_logically_conf, '', status);

  PROCEND cmp$get_logical_pp_index;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_logical_pp_number', EJECT ??

{ PURPOSE:
{   This procedure retrieves the logical pp number associated with a given element name.

  PROCEDURE [XDCL, #GATE] cmp$get_logical_pp_number
    (    element_name: cmt$element_name;
     VAR logical_pp_number: iot$pp_number;
     VAR status: ost$status);

    VAR
      logical_unit: iot$logical_unit,
      pp_index: iot$pp_number,
      ppit_p: ^iot$pp_interface_table,
      unit_desc: iot$unit_descriptor_entry;

    status.normal := TRUE;

    cmp$get_logical_unit_number (element_name, logical_unit, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

   /table_loop/
    FOR pp_index := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
      IF NOT cmv$logical_pp_table_p^ [pp_index].flags.configured THEN
        CYCLE /table_loop/;
      IFEND;

      ppit_p := cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p;

      IF (logical_unit < LOWERBOUND (ppit_p^.unit_descriptors)) OR
            (logical_unit > UPPERBOUND (ppit_p^.unit_descriptors)) THEN
        CYCLE /table_loop/;
      IFEND;

      unit_desc := ppit_p^.unit_descriptors [logical_unit];

      IF (unit_desc.unit_interface_table = NIL) OR (unit_desc.unit_interface_table^.unit_status.disabled) THEN
        CYCLE /table_loop/;
      IFEND;

      IF unit_desc.logical_unit = logical_unit THEN
        logical_pp_number := pp_index;
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_not_logically_conf, '', status);

  PROCEND cmp$get_logical_pp_number;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_logical_unit_state',EJECT ??

{ PURPOSE:
{   This routine returns the state information of a logical unit by looking at the element capabilities list
{   in the logical unit table.

  PROCEDURE [XDCL, #GATE] cmp$get_logical_unit_state
    (    lun: iot$logical_unit;
         logical_unit_table_p: ^cmt$logical_unit_table;
     VAR state: cmt$element_state);

    IF logical_unit_table_p^ [lun].element_capability >=
          $cmt$element_capabilities [cmc$io_request_submission] THEN
      state := cmc$on;
    ELSEIF logical_unit_table_p^ [lun].element_capability =
          $cmt$element_capabilities [cmc$dedicated_maintenance, cmc$concurrent_maintenance] THEN
      state := cmc$down;
    ELSEIF logical_unit_table_p^ [lun].element_capability = $cmt$element_capabilities [] THEN
      state := cmc$off;
    ELSE
      state := cmc$off;
    IFEND;

  PROCEND cmp$get_logical_unit_state;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_max_number_of_pp',EJECT ??

{ PURPOSE:
{   This procedure computes the maximum number of logical pp present.

  PROCEDURE [XDCL, #GATE] cmp$get_max_number_of_pp
    (VAR max_number_of_pp: iot$pp_number);

    VAR
      pp_index: iot$pp_number;

    max_number_of_pp := 0;
    IF cmv$logical_pp_table_p <> NIL THEN
      FOR pp_index := UPPERBOUND (cmv$logical_pp_table_p^) DOWNTO LOWERBOUND (cmv$logical_pp_table_p^) DO
        IF cmv$logical_pp_table_p^ [pp_index].flags.configured THEN
          max_number_of_pp := pp_index;
          RETURN;
        IFEND;
      FOREND;
    IFEND;

  PROCEND cmp$get_max_number_of_pp;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$lock_lun_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$lock_lun_entry
    (    logical_unit_number: iot$logical_unit;
     VAR lock_obtained: boolean);

    VAR
      delay_and_try_again: boolean,
      status: ost$status;

    delay_and_try_again := TRUE;
    lock_obtained := FALSE;

    WHILE TRUE DO
      osp$set_signature_lock (cmv$logical_unit_lock, osc$wait, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF NOT cmv$logical_unit_table^ [logical_unit_number].entry_interlock THEN
        cmv$logical_unit_table^ [logical_unit_number].entry_interlock := TRUE;
        lock_obtained := TRUE;
      IFEND;

      osp$clear_signature_lock (cmv$logical_unit_lock, status);
      IF lock_obtained THEN
        RETURN;
      IFEND;

      IF delay_and_try_again THEN
        pmp$delay (3000, status);
        delay_and_try_again := FALSE;
      ELSE
        RETURN;
      IFEND;
    WHILEND;

  PROCEND cmp$lock_lun_entry;
?? OLDTITLE ??
?? NEWTITLE := '  cmp$lcu_lock_set_by_job', EJECT ??

{ PURPOSE:
{   This procedure determines whether the LCU locks are already set.

  PROCEDURE [XDCL, #GATE] cmp$lcu_lock_set_by_job
    (VAR job_name: jmt$system_supplied_name;
     VAR lock_set: boolean);

    VAR
      config_admin_lock_status: ost$signature_lock_status,
      local_status: ost$status,
      removable_media_lock_status: ost$signature_lock_status;

    job_name := ' ';
    lock_set := FALSE;
    osp$test_signature_lock (cmv$configuration_administrator.lock, config_admin_lock_status, local_status);
    IF (config_admin_lock_status <> osc$sls_not_locked) THEN
      lock_set := TRUE;
      job_name := cmv$configuration_administrator.job_name
    ELSE
      osp$test_signature_lock (cmv$removable_media_operation.lock, removable_media_lock_status, local_status);
      IF (removable_media_lock_status <> osc$sls_not_locked) THEN
        lock_set := TRUE;
        job_name := cmv$removable_media_operation.job_name
      IFEND;
    IFEND;

  PROCEND cmp$lcu_lock_set_by_job;
?? OLDTITLE ??
?? NEWTITLE := '  cmp$lock_set_by_task', EJECT ??

{ PURPOSE:
{   This function determines whether the given lock type is already
{   set by the current task.

  FUNCTION [XDCL, #GATE, UNSAFE] cmp$lock_set_by_task
    (    lock_type: cmt$lcu_lock_type): boolean;

    VAR
      local_status: ost$status,
      lock_status: ost$signature_lock_status;

    CASE lock_type OF
    = cmc$configuration_administrator =
      osp$test_signature_lock (cmv$configuration_administrator.lock, lock_status, local_status);
    = cmc$removable_media_operation =
      osp$test_signature_lock (cmv$removable_media_operation.lock, lock_status, local_status);
    ELSE
    CASEND;
    cmp$lock_set_by_task := lock_status = osc$sls_locked_by_current_task;

  FUNCEND cmp$lock_set_by_task;
?? OLDTITLE ??
?? NEWTITLE := '  cmp$manage_lcu_lock', EJECT ??

{ PURPOSE:
{   This procedure sets and clears locks in the LCU.

  PROCEDURE [XDCL, #GATE] cmp$manage_lcu_lock
    (    lock_type: cmt$lcu_lock_type;
         clear_lock: boolean;
         job_name: jmt$system_supplied_name;
     VAR status: ost$status);

    status.normal := TRUE;
    CASE lock_type OF
    = cmc$configuration_administrator =
      IF clear_lock THEN
        osp$clear_signature_lock (cmv$configuration_administrator.lock, status);
      ELSE
        osp$set_signature_lock (cmv$configuration_administrator.lock, osc$nowait, status);
        IF status.normal THEN
          cmv$configuration_administrator.job_name := job_name;
        ELSE
          osp$set_status_abnormal (cmc$configuration_management_id, cme$multiple_reconf_tasks,
                cmv$configuration_administrator.job_name, status);
        IFEND;
      IFEND;
    ELSE
      IF clear_lock THEN
        osp$clear_signature_lock (cmv$removable_media_operation.lock, status);
      ELSE
        osp$set_signature_lock (cmv$removable_media_operation.lock, osc$nowait, status);
        IF status.normal THEN
          cmv$removable_media_operation.job_name := job_name;
        ELSE
          osp$set_status_abnormal (cmc$configuration_management_id, cme$multiple_reconf_tasks,
                cmv$removable_media_operation.job_name, status);
        IFEND;
      IFEND;
    CASEND;
  PROCEND cmp$manage_lcu_lock;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$retrieve_logical_pp_index', EJECT ??

{ PURPOSE:
{   This procedure retrieves an index into the Logical PP Table using a channel.

  PROCEDURE [XDCL, #GATE] cmp$retrieve_logical_pp_index
    (    channel: cmt$physical_channel;
         iou_number: dst$iou_number;
         logical_pp_table_p: ^cmt$logical_pp_table;
     VAR logical_pp_index: iot$pp_number;
     VAR status: ost$status);

    VAR
      channel_data: dst$iou_resource,
      channel_element_p: ^cmt$element_definition,
      iou_name: cmt$element_name,
      pp_index: iot$pp_number,
      table_index: integer;

    status.normal := TRUE;

    cmp$convert_iou_number (iou_number, iou_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    channel_data.iou_number := iou_number;
    IF channel.concurrent THEN
      channel_data.channel_protocol := dsc$cpt_cio;
    ELSE
      channel_data.channel_protocol := dsc$cpt_nio;
    IFEND;
    channel_data.number := channel.number;

    FOR table_index := LOWERBOUND (cmv$physical_configuration^) TO UPPERBOUND (cmv$physical_configuration^) DO
      IF cmv$physical_configuration^[table_index].element_type = cmc$data_channel_element THEN
        IF (channel.number = cmv$physical_configuration^ [table_index].data_channel.number) AND
              (channel.concurrent = cmv$physical_configuration^ [table_index].data_channel.concurrent) AND
              (channel.port = cmv$physical_configuration^ [table_index].data_channel.port) AND
              (iou_name = cmv$physical_configuration^ [table_index].data_channel.iou) THEN
          FOR pp_index := LOWERBOUND (logical_pp_table_p^) TO UPPERBOUND (logical_pp_table_p^) DO
            IF logical_pp_table_p^ [pp_index].flags.configured AND
                  (logical_pp_table_p^ [pp_index].pp_info.channel = channel_data) THEN
              logical_pp_index := pp_index;
              RETURN;
            IFEND;
          FOREND;
        IFEND;
      IFEND;
    FOREND;
    osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_not_logically_conf, '', status);

  PROCEND cmp$retrieve_logical_pp_index;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$search_peripheral_table', EJECT ??

{ PURPOSE:
{   Search the peripheral element table for the given element.  The index to the table is returned.

  PROCEDURE [XDCL, #GATE] cmp$search_peripheral_table
    (    element_descriptor: cmt$element_descriptor;
         element_reservation: cmt$element_reservation;
         not_in_configuration: boolean;
     VAR table_index: integer;
     VAR status: ost$status);

    VAR
      channel: cmt$physical_channel,
      channel_address: cmt$physical_equipment_number,
      channel_definition: cmt$data_channel_definition,
      found: boolean,
      index: integer,
      iou_number: dst$iou_number,
      pete_p: ^cmt$peripheral_element_entry,
      physical_id: cmt$physical_identification,
      temp_element_descriptor: cmt$element_descriptor,
      unit_address: cmt$physical_unit_number;

    status.normal := TRUE;
    found := FALSE;

    IF cmv$peripheral_element_table.pointer = NIL THEN
      osp$set_status_condition (cme$cm_table_empty,  status);
      RETURN;
    IFEND;

    IF not_in_configuration THEN

      { Determine physical address from element reservation. Use only physical address to search for a match
      { to eliminate confusion between channel ports.

      cmp$crack_physical_address (element_reservation, iou_number, channel, channel_address, unit_address,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

     /peripheral_table_loop_1/
      FOR index := LOWERBOUND (cmv$peripheral_element_table.pointer^) TO
            UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
        IF cmv$peripheral_element_table.pointer^ [index].physical_descriptor.configured THEN
          CYCLE /peripheral_table_loop_1/;
        IFEND;

        CASE element_reservation.element_type OF
        = cmc$data_channel_element =
          IF cmv$peripheral_element_table.pointer^ [index].physical_descriptor.hardware_address.
                address_specifier = $cmt$physical_address_specifier [cmc$iou, cmc$channel] THEN
            found := (cmv$peripheral_element_table.pointer^ [index].physical_descriptor.hardware_address.
                  iou = iou_number) AND
                  (cmv$peripheral_element_table.pointer^ [index].physical_descriptor.hardware_address.
                  channel.concurrent = channel.concurrent) AND
                  (cmv$peripheral_element_table.pointer^ [index].physical_descriptor.hardware_address.
                  channel.number = channel.number);
          IFEND;
        = cmc$controller_element, cmc$storage_device_element, cmc$communications_element,
              cmc$channel_adapter_element, cmc$external_processor_element =
          IF element_reservation.peripheral_descriptor.use_logical_identification THEN
            found := element_reservation.peripheral_descriptor.element_name =
                  cmv$peripheral_element_table.pointer^ [index].element_name;
          ELSE
            IF cmv$peripheral_element_table.pointer^ [index].physical_descriptor.hardware_address.
                  address_specifier = element_reservation.peripheral_descriptor.hardware_address.
                  physical_address_specifier THEN
              CASE element_reservation.element_type OF
              = cmc$controller_element, cmc$channel_adapter_element, cmc$external_processor_element,
                    cmc$communications_element =
                found := (cmv$peripheral_element_table.pointer^ [index].physical_descriptor.hardware_address.
                      channel.number = channel.number) AND
                      (cmv$peripheral_element_table.pointer^ [index].physical_descriptor.hardware_address.
                      channel.concurrent = channel.concurrent) AND
                      (cmv$peripheral_element_table.pointer^ [index].physical_descriptor.hardware_address.
                      iou = iou_number) AND
                      (cmv$peripheral_element_table.pointer^ [index].physical_descriptor.hardware_address.
                      channel_address = channel_address);
              = cmc$storage_device_element =
                found := (cmv$peripheral_element_table.pointer^ [index].physical_descriptor.hardware_address.
                      channel.number = channel.number) AND
                      (cmv$peripheral_element_table.pointer^ [index].physical_descriptor.hardware_address.
                      channel.concurrent = channel.concurrent) AND
                      (cmv$peripheral_element_table.pointer^ [index].physical_descriptor.hardware_address.
                      iou = iou_number) AND
                      (cmv$peripheral_element_table.pointer^ [index].physical_descriptor.hardware_address.
                      channel_address = channel_address) AND
                      (cmv$peripheral_element_table.pointer^ [index].physical_descriptor.hardware_address.
                      unit_address = unit_address);
              ELSE
                osp$set_status_abnormal (cmc$configuration_management_id, cme$cm_end_case_error,
                      'CMP$SEARCH_PERIPHERAL_TABLE', status);
                RETURN;
              CASEND;
            IFEND;
          IFEND;
        ELSE
          osp$set_status_abnormal (cmc$configuration_management_id, cme$cm_end_case_error,
                'CMP$SEARCH_PERIPHERAL_TABLE', status);
          RETURN;
        CASEND;
        IF found THEN
          table_index := index;
          EXIT /peripheral_table_loop_1/;
        IFEND;
      FOREND /peripheral_table_loop_1/;

      IF NOT found THEN

       /peripheral_table_loop_2/
        FOR index := LOWERBOUND (cmv$peripheral_element_table.pointer^) TO
              UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
          IF NOT cmv$peripheral_element_table.pointer^ [index].physical_descriptor.configured AND
                NOT cmv$peripheral_element_table.pointer^ [index].entry_interlock THEN
            table_index := index;
            EXIT /peripheral_table_loop_2/;
          IFEND;
        FOREND /peripheral_table_loop_2/;

        temp_element_descriptor.element_type := element_reservation.element_type;
        CASE temp_element_descriptor.element_type OF
        = cmc$data_channel_element =
          temp_element_descriptor.channel_descriptor := element_reservation.channel_descriptor;
        = cmc$controller_element, cmc$external_processor_element, cmc$channel_adapter_element,
              cmc$storage_device_element, cmc$communications_element =
          temp_element_descriptor.peripheral_descriptor := element_reservation.peripheral_descriptor;
        ELSE
        CASEND;
        cmp$format_error_message (temp_element_descriptor, {not used} physical_id, FALSE,
              cme$cm_element_not_found, status);
      IFEND;

    ELSE { in configuration }
      CASE element_descriptor.element_type OF
      = cmc$data_channel_element =
        cmp$get_channel_def (element_descriptor.channel_descriptor, channel_definition, status);
        IF NOT status.normal THEN
          IF (status.condition = cme$lcm_element_not_found) OR
                (status.condition = cme$unknown_channel_type) THEN
            status.normal := TRUE;
          ELSE
            RETURN;
          IFEND;
        IFEND;
        cmp$convert_iou_name (element_descriptor.channel_descriptor.iou, iou_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
      CASEND;

     /peripheral_table_loop_3/
      FOR index := LOWERBOUND (cmv$peripheral_element_table.pointer^) TO
            UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
        pete_p := ^cmv$peripheral_element_table.pointer^[index];
        IF pete_p^.physical_descriptor.element_type <> element_descriptor.element_type THEN
          CYCLE /peripheral_table_loop_3/;
        IFEND;

        CASE element_descriptor.element_type OF
        = cmc$data_channel_element =
          found := (iou_number = pete_p^.physical_descriptor.channel_path.iou) AND
                (channel_definition.number = pete_p^.physical_descriptor.channel_path.channel.number) AND
                (channel_definition.port = pete_p^.physical_descriptor.channel_path.channel.port) AND
                (channel_definition.concurrent = pete_p^.physical_descriptor.channel_path.channel.concurrent);
        = cmc$controller_element, cmc$external_processor_element, cmc$communications_element,
              cmc$channel_adapter_element, cmc$storage_device_element =
          found := element_descriptor.peripheral_descriptor.element_name  = pete_p^.element_name;
        ELSE
        CASEND;

        IF found THEN
          table_index := index;
          EXIT /peripheral_table_loop_3/;
        IFEND;
      FOREND /peripheral_table_loop_3/;

      IF NOT found THEN
        CASE element_descriptor.element_type OF
        = cmc$data_channel_element =
          osp$set_status_abnormal (cmc$configuration_management_id, cme$cm_element_not_found,
                element_descriptor.channel_descriptor.name, status);
        = cmc$controller_element, cmc$storage_device_element, cmc$channel_adapter_element,
              cmc$communications_element =
          osp$set_status_abnormal (cmc$configuration_management_id, cme$cm_element_not_found,
                element_descriptor.peripheral_descriptor.element_name, status);
        ELSE
        CASEND;
      IFEND;
    IFEND;

  PROCEND cmp$search_peripheral_table;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$set_element_lock', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$set_element_lock
    (VAR status: ost$status);

    status.normal := TRUE;

    osp$set_signature_lock (cmv$element_reservation_lock, osc$wait, status);

  PROCEND cmp$set_element_lock;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$set_unit_shared',EJECT ??

{ PURPOSE:
{   This procedure sets the unit shared bit of the given logical unit.

  PROCEDURE [XDCL, #GATE] cmp$set_unit_shared
    (    logical_unit: iot$logical_unit;
         set_lock: boolean);

    VAR
      lock_obtained: boolean;

    IF (cmv$logical_unit_table = NIL) OR NOT cmv$logical_unit_table^ [logical_unit].configured THEN
      RETURN;
    IFEND;

    IF set_lock THEN
      cmp$lock_lun_entry (logical_unit, lock_obtained);
      IF NOT lock_obtained THEN
        osp$system_error (' Unable to set CMV$LOGICAL_UNIT lock', NIL);
      IFEND;
    IFEND;

    cmv$logical_unit_table^ [logical_unit].unit_interface_table^.unit_shared := TRUE;
    IF set_lock THEN
      cmp$unlock_lun_entry (logical_unit, lock_obtained);
    IFEND;

  PROCEND cmp$set_unit_shared;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$unit_disabled', EJECT ??

  FUNCTION [XDCL, #GATE] cmp$unit_disabled
    (    logical_unit: iot$logical_unit): boolean;

    cmp$unit_disabled :=
          (cmv$logical_unit_table^ [logical_unit].element_capability = $cmt$element_capabilities [ ]) AND
          cmv$logical_unit_table^ [logical_unit].unit_interface_table^.unit_status.disabled;

  FUNCEND cmp$unit_disabled;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$unlock_lun_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$unlock_lun_entry
    (    logical_unit_number: iot$logical_unit;
     VAR lock_released: boolean);

    VAR
      status: ost$status;

    #keypoint (osk$entry, logical_unit_number * osk$m, cmk$unlock_lun_entry);
    lock_released := FALSE;

  /main_program/
    BEGIN

      osp$set_signature_lock (cmv$logical_unit_lock, osc$wait, status);
      IF NOT status.normal THEN
        #keypoint (osk$debug, 0, cmk$unlock_lun_entry);
        EXIT /main_program/;
      IFEND;

      IF cmv$logical_unit_table^ [logical_unit_number].entry_interlock THEN
        cmv$logical_unit_table^ [logical_unit_number].entry_interlock := FALSE;
        lock_released := TRUE;
      IFEND;

      osp$clear_signature_lock (cmv$logical_unit_lock, status);

    END /main_program/;

    #keypoint (osk$exit, ORD (lock_released) * osk$m, cmk$unlock_lun_entry);

  PROCEND cmp$unlock_lun_entry;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$verify_active_path ', EJECT ??

{ PURPOSE:
{   This procedure returns a boolean indicating whether or not there exists an active path to the mass
{   storage device, i.e at least a channel or a control module is in the on state.

  PROCEDURE [XDCL, #GATE] cmp$verify_active_path
    (    element: cmt$element_definition;
     VAR active_path: boolean);

    VAR
      element_p: ^cmt$element_definition,
      index: cmt$data_storage_port_number,
      iou_name: cmt$element_name,
      local_status: ost$status,
      port: cmt$controller_port_number,
      state: cmt$element_state;

    IF element.element_type <> cmc$storage_device_element THEN
      active_path := TRUE;
      RETURN;
    IFEND;
    active_path := FALSE;

   /verify_loop/
    FOR index := LOWERVALUE (cmt$data_storage_port_number) TO UPPERVALUE (cmt$data_storage_port_number) DO
      IF NOT element.storage_device.connection.port [index].configured THEN
        CYCLE /verify_loop/;
      IFEND;

      IF element.storage_device.connection.port [index].upline_connection_type = cmc$data_channel_element THEN
        iou_name := element.storage_device.connection.port [index].iou;
      IFEND;
      cmp$get_element_state (element.storage_device.connection.port [index].element_name, iou_name, state,
            local_status);
      IF state <> cmc$on THEN
        CYCLE /verify_loop/;
      IFEND;

      cmp$pc_get_element (element.storage_device.connection.port [index].element_name, iou_name,
            element_p, local_status);
      CASE element_p^.element_type OF
      = cmc$data_channel_element =
        active_path := TRUE;
        RETURN;
      = cmc$controller_element =
        FOR port := LOWERVALUE (cmt$controller_port_number) TO UPPERVALUE (cmt$controller_port_number) DO
          IF element_p^.controller.connection.port[port].configured THEN
            cmp$get_element_state (element_p^.controller.connection.port [port].element_name,
                  element_p^.controller.connection.port[port].iou, state, local_status);
            IF state = cmc$on THEN
              active_path := TRUE;
              RETURN;
            IFEND;
          IFEND;
        FOREND;
      ELSE
      CASEND;
    FOREND;

  PROCEND cmp$verify_active_path;
?? OLDTITLE ??
?? NEWTITLE := 'msp$add_con_access_job', EJECT ??

  PROCEDURE [XDCL, #GATE] msp$add_con_access_job
    (    peripheral_index: integer;
         job_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      lock_status: ost$status,
      node_p: mst$con_access_job_list;

    status.normal := TRUE;

    ALLOCATE node_p IN osv$mainframe_wired_cb_heap^;
    node_p^.job_name := job_name;
    node_p^.forward_link := NIL;

    osp$set_signature_lock (cmv$peripheral_element_table.lock, osc$wait, lock_status);
    IF NOT lock_status.normal THEN
      RETURN;
    IFEND;

    IF cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.con_access_job_list =
          NIL THEN
      cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.con_access_job_list :=
            node_p;
    ELSE
      node_p^.forward_link :=
            cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.con_access_job_list;
      cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.con_access_job_list :=
            node_p;
    IFEND;

    osp$clear_signature_lock (cmv$peripheral_element_table.lock, lock_status);

  PROCEND msp$add_con_access_job;
?? OLDTITLE ??
?? NEWTITLE := 'msp$delete_con_access_job', EJECT ??

  PROCEDURE [XDCL, #GATE] msp$delete_con_access_job
    (    peripheral_index: integer;
         job_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      before_deleted_node_p: mst$con_access_job_list,
      deleted_node_p: mst$con_access_job_list,
      found: boolean,
      lock_status: ost$status;

    status.normal := TRUE;
    found := FALSE;

    osp$set_signature_lock (cmv$peripheral_element_table.lock, osc$wait, lock_status);
    IF NOT lock_status.normal THEN
      RETURN;
    IFEND;

    deleted_node_p :=
          cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.con_access_job_list;
    before_deleted_node_p := NIL;

    WHILE (deleted_node_p <> NIL) AND (NOT found) DO
      IF deleted_node_p^.job_name = job_name THEN
        found := TRUE;
      ELSE
        before_deleted_node_p := deleted_node_p;
        deleted_node_p := deleted_node_p^.forward_link;
      IFEND;
    WHILEND;

    IF found THEN
      IF cmv$peripheral_element_table.pointer^ [peripheral_index].
            maintenance_activity.con_access_job_list^.forward_link = NIL THEN
        FREE cmv$peripheral_element_table.pointer^ [peripheral_index].
              maintenance_activity.con_access_job_list IN osv$mainframe_wired_cb_heap^;
      ELSEIF before_deleted_node_p = NIL THEN
        cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.con_access_job_list :=
              cmv$peripheral_element_table.pointer^ [peripheral_index].
              maintenance_activity.con_access_job_list^.forward_link;
        FREE deleted_node_p IN osv$mainframe_wired_cb_heap^;
      ELSE
        before_deleted_node_p^.forward_link := deleted_node_p^.forward_link;
        FREE deleted_node_p IN osv$mainframe_wired_cb_heap^;
      IFEND;
    IFEND;

    osp$clear_signature_lock (cmv$peripheral_element_table.lock, lock_status);

  PROCEND msp$delete_con_access_job;
?? OLDTITLE ??
MODEND cmm$manage_interface_tables;
*DECK DECK=CMM$MISCELLANEOUS_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE CM : Miscellaneous Interfaces' ??
MODULE cmm$miscellaneous_interfaces;

{ PURPOSE:
{   This module contains interfaces that return information about elements in a configuration and
{   perform state changes.

  CONST
    one_second = 1000 {milliseconds};

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cme$job_template_deadstart
*copyc cme$logical_configuration_mgr
*copyc cme$reserve_element
*copyc cml$element_state_change
*copyc cmt$connection
*copyc cmt$element_definition
*copyc cmt$element_descriptor
*copyc cmt$element_reservation
*copyc ofe$error_codes
*copyc dme$tape_errors
*copyc dmt$error_condition_codes
*copyc dst$iou_resource
*copyc dst$log_ele_state_change
*copyc ost$caller_identifier
*copyc rmt$device_class
?? POP ??
*copyc avp$configuration_administrator
*copyc avp$system_operator
*copyc avp$removable_media_operator
*copyc cmp$change_connection_status_r1
*copyc cmp$change_state_info_table
*copyc cmp$change_state_r1
*copyc cmp$clear_ppit
*copyc cmp$convert_channel_type
*copyc cmp$convert_iou_name
*copyc cmp$convert_iou_number
*copyc cmp$dedicated_maint_active
*copyc cmp$determine_redundant_channel
*copyc cmp$determine_tape_element
*copyc cmp$queue_state_change
*copyc cmp$support_redundant_channel
*copyc cmp$search_redundant_path
*copyc cmp$disable_unit
*copyc cmp$enable_unit
*copyc cmp$find_state_change_request
*copyc cmp$get_connected_elements
*copyc cmp$get_connection_status
*copyc cmp$get_controller_type
*copyc cmp$get_element_definition
*copyc cmp$get_element_name
*copyc cmp$get_element_state
*copyc cmp$get_logical_pp_index
*copyc cmp$get_logical_unit_number
*copyc cmp$get_logical_unit_state
*copyc cmp$get_pp_table_rma
*copyc cmp$get_unit_type
*copyc cmp$get_volumes_active
*copyc cmp$idle_pp_r1
*copyc cmp$lcu_lock_set_by_job
*copyc cmp$locate_disabled_connection
*copyc cmp$lock_lun_entry
*copyc cmp$lock_set_by_task
*copyc cmp$manage_lcu_lock
*copyc cmp$pc_get_element
*copyc cmp$pc_get_logical_unit
*copyc cmp$reacquire_resources
*copyc cmp$release_channel_resource
*copyc cmp$release_equipment_resource
*copyc cmp$release_pp_by_channel
*copyc cmp$resume_pp_r1
*copyc cmp$retrieve_logical_pp_index
*copyc cmp$search_peripheral_table
*copyc cmp$unlock_lun_entry
*copyc cmp$update_connection_states_r1
*copyc cmp$switch_tape_channel
*copyc cmp$update_logical_unit_table
*copyc cmp$update_pcu_state_info
*copyc cmp$zero_out_uit_rma
*copyc dmp$update_stt
*copyc dpp$put_critical_message
*copyc dsp$log_system_message
*copyc nap$change_network_device_state
*copyc osp$append_status_parameter
*copyc osp$clear_signature_lock
*copyc osp$generate_log_message
*copyc osp$generate_error_message
*copyc osp$set_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$test_signature_lock
*copyc pmp$get_mainframe_id
*copyc pmp$get_job_names
*copyc pmp$wait
?? EJECT ??
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc cmv$peripheral_element_table
*copyc cmv$physical_configuration
*copyc osv$170_os_type
*copyc osv$task_private_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    cmt$max_channels_per_storage =  0 .. cmc$max_ports_per_data_storage * cmc$max_ports_per_controller - 1,

    pps_acquired_info = RECORD
      CASE acquired: boolean OF
      = TRUE =
        iou: dst$iou_number,
        channel: cmt$physical_channel,
        pp_table_rma: ost$real_memory_address,
        driver_name: pmt$program_name,
        controller_type: cmt$controller_type,
        logical_pp: ARRAY [1 .. 2] OF iot$pp_number,
      = FALSE =
      CASEND,
    RECEND,

    pps_released_info = RECORD
      CASE released: boolean OF
      = TRUE =
        iou: dst$iou_number,
        channel: cmt$physical_channel,
        channel_name: cmt$element_name,
        logical_pp: ARRAY [1 .. 2] OF iot$pp_number,
      = FALSE =
      CASEND,
    RECEND;

?? TITLE := ' cmp$active_path',EJECT ??

 { PURPOSE : This procedure retrieve information necessary to acquire PP
 {   for active disk channels.

  PROCEDURE cmp$active_path (
        element : cmt$element_definition;
        controller_type : cmt$controller_type;
    VAR pp_acquired : ARRAY [cmt$max_channels_per_storage] OF pps_acquired_info;
    VAR status : ost$status);


      VAR
        ch : integer,
        ch_element : ^cmt$element_definition,
        channel_state : cmt$element_state,
        ch_port : integer,
        eq_element : ^cmt$element_definition,
        equipment_state : cmt$element_state,
        ignore_status : ost$status,
        ignore_unit_state : boolean,
        iou_name : cmt$element_name,
        iou_number : dst$iou_number,
        mainframe_id : pmt$mainframe_id,
        minus_one : integer,
        pen : cmt$physical_equipment_number,
        physical_channel : cmt$physical_channel,
        port : integer,
        pp : integer,
        pp_not_active: boolean,
        pp_table_rma : ost$real_memory_address,
        pun : cmt$physical_unit_number,
        redundant : boolean,
        unit_state : cmt$element_state,
        unit_element : ^cmt$element_definition;

      status.normal := TRUE;

      FOR port := LOWERVALUE (cmt$max_channels_per_storage) TO
                    UPPERVALUE (cmt$max_channels_per_storage) DO
        pp_acquired [port].acquired := FALSE;
        pp_acquired [port].pp_table_rma := 0;
        pp_acquired [port].driver_name := ' ';
        FOR pp := 1 TO 2 DO
          pp_acquired [port].logical_pp [pp] := 0;
        FOREND;
      FOREND;
      pmp$get_mainframe_id (mainframe_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE element.element_type OF
      = cmc$data_channel_element =

        cmp$convert_iou_name (element.data_channel.iou, iou_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        /pen_loop_1/
        FOR pen := LOWERVALUE (cmt$physical_equipment_number) TO
                     UPPERVALUE (cmt$physical_equipment_number) DO
          IF element.data_channel.connection.equipment [pen].configured THEN
            cmp$get_element_state (element.data_channel.connection.equipment [pen].element_name, iou_name,
                  equipment_state, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF equipment_state = cmc$on THEN
              cmp$pc_get_element (element.data_channel.connection.
                equipment [pen].element_name, iou_name, eq_element, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              IF eq_element ^.element_type = cmc$storage_device_element THEN { Hydra }

                cmp$get_pp_table_rma (element, pp_table_rma, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                determine_if_pp_not_active (element.data_channel.number, element.data_channel.port,
                      element.data_channel.concurrent, iou_number, pp_acquired [0].acquired);
                IF pp_acquired [0].acquired THEN
                  pp_acquired [0].iou := iou_number;
                  pp_acquired [0].channel.number := element.data_channel.number;
                  pp_acquired [0].channel.concurrent := element.data_channel.concurrent;
                  pp_acquired [0].channel.port := element.data_channel.port;
                  pp_acquired [0].pp_table_rma := pp_table_rma;
                  pp_acquired [0].driver_name := 'E9S887';
                  pp_acquired [0].controller_type := cmc$mshydra_ct;

                  cmp$get_logical_pp_index (element, pp_acquired [0].logical_pp [1], status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;
                IFEND;

                EXIT /pen_loop_1/;

              ELSEIF eq_element ^.element_type = cmc$controller_element THEN
                FOR pun := LOWERVALUE (cmt$physical_unit_number) TO
                             UPPERVALUE (cmt$physical_unit_number) DO
                  IF eq_element ^.controller.connection.unit [pun].configured THEN
                    cmp$get_element_state (eq_element ^.controller.
                      connection.unit [pun].element_name, iou_name, unit_state, status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;

                    IF unit_state = cmc$on THEN
                      physical_channel.number := element.data_channel.number;
                      physical_channel.concurrent := element.data_channel.concurrent;
                      physical_channel.port := element.data_channel.port;
                      IF cmp$support_redundant_channel (controller_type) THEN
                        cmp$determine_redundant_channel (physical_channel, iou_number,
                            {ignore_state=}TRUE, redundant, ignore_status);
                        IF redundant THEN
                          CYCLE /pen_loop_1/;
                        IFEND;
                      IFEND;
                      cmp$get_pp_table_rma (element, pp_table_rma, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                      determine_if_pp_not_active (element.data_channel.number, element.data_channel.port,
                            element.data_channel.concurrent, iou_number, pp_not_active);
                      IF pp_not_active THEN
                        pp_acquired [0].acquired := TRUE;
                        pp_acquired [0].iou := iou_number;
                        pp_acquired [0].channel.number := element.data_channel.number;
                        pp_acquired [0].channel.concurrent := element.data_channel.concurrent;
                        pp_acquired [0].channel.port := element.data_channel.port;
                        pp_acquired [0].pp_table_rma := pp_table_rma;
                        pp_acquired [0].controller_type := controller_type;
                        pp_acquired [0].driver_name := eq_element ^.controller.
                             peripheral_driver_name;
                        cmp$get_logical_pp_index (element, pp_acquired [0].logical_pp [1], status);
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;

                        IF cmv$logical_pp_table_p^ [pp_acquired [0].logical_pp [1]].
                              pp_info.logical_partner_pp_index > 0 THEN
                          pp_acquired [0].logical_pp [2] :=
                                cmv$logical_pp_table_p^ [pp_acquired [0].logical_pp [1]].
                                pp_info.logical_partner_pp_index;
                        IFEND
                      IFEND;
                      EXIT /pen_loop_1/;
                    IFEND;
                  IFEND;
                FOREND;
              IFEND;
            IFEND;
          IFEND;
        FOREND /pen_loop_1/;

      = cmc$controller_element =
        ignore_unit_state := (controller_type = cmc$mt5698_xx) OR (controller_type = cmc$mt5680_xx) OR
             (controller_type = cmc$mt7021_3x) OR (controller_type = cmc$mt7021_4x)
             OR (controller_type = cmc$mt7221_2_s0) OR (controller_type = cmc$mt7221_1)
             OR (controller_type = cmc$mt698_xx);
        channel_state := cmc$down;
        /channel_loop_1/
        FOR port := LOWERVALUE (cmt$controller_port_number) TO
                      UPPERVALUE (cmt$controller_port_number) DO
          IF (element.controller.connection.port [port].configured) AND
                (element.controller.connection.port [port].mainframe_ownership = mainframe_id) THEN
            cmp$get_element_state (element.controller.connection.port [port].element_name,
                  element.controller.connection.port [port].iou, channel_state, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF channel_state = cmc$on THEN
              EXIT /channel_loop_1/;
            IFEND;
          IFEND;
        FOREND /channel_loop_1/;

        unit_state := cmc$down;
        /pun_loop_1/
        FOR pun := LOWERVALUE (cmt$physical_unit_number) TO
                     UPPERVALUE (cmt$physical_unit_number) DO
          IF element.controller.connection.unit [pun].configured THEN
            cmp$get_element_state (element.controller.
              connection.unit [pun].element_name, iou_name, unit_state, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF unit_state = cmc$on THEN
              EXIT /pun_loop_1/;
            IFEND;
          IFEND;
        FOREND /pun_loop_1/;

        IF (channel_state = cmc$on) AND ((unit_state = cmc$on) OR (ignore_unit_state)) THEN

          /channel_loop_2/
          FOR port := LOWERVALUE (cmt$controller_port_number) TO
                        UPPERVALUE (cmt$controller_port_number) DO

            { Duplicate code (cmp$get_element_state) for the first ON channel.

            IF (element.controller.connection.port [port].configured) AND
                  (element.controller.connection.port [port].mainframe_ownership = mainframe_id) THEN
              cmp$get_element_state (element.controller.
                connection.port [port].element_name, element.controller.connection.port
                  [port].iou, channel_state, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              IF channel_state = cmc$on THEN
                cmp$pc_get_element (element.controller.connection.
                  port [port].element_name, element.controller.connection.port[port].iou,
                        ch_element, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                cmp$convert_iou_name (ch_element^.data_channel.iou, iou_number, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                physical_channel.number := ch_element^.data_channel.number;
                physical_channel.concurrent := ch_element^.data_channel.concurrent;
                physical_channel.port := ch_element^.data_channel.port;
                IF cmp$support_redundant_channel (controller_type) THEN
                  cmp$determine_redundant_channel (physical_channel, iou_number,
                      {ignore_state=}TRUE, redundant, ignore_status);
                  IF redundant THEN
                    CYCLE /channel_loop_2/;
                  IFEND;
                IFEND;
                cmp$get_pp_table_rma (ch_element^, pp_table_rma, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                IF port > LOWERVALUE (cmt$controller_port_number) THEN
                  FOR minus_one := LOWERVALUE (cmt$controller_port_number) TO port - 1 DO
                    IF pp_acquired [minus_one].acquired THEN
                      IF pp_acquired [minus_one].pp_table_rma = pp_table_rma THEN

                        { Do not acquire PP for CCH#(A or B) again.

                        CYCLE /channel_loop_2/; { Find the next channel.}

                      IFEND;
                    IFEND;
                  FOREND;
                IFEND;

                determine_if_pp_not_active (ch_element^.data_channel.number, ch_element^.data_channel.port,
                      ch_element^.data_channel.concurrent, iou_number, pp_acquired [port].acquired);
                IF pp_acquired [port].acquired THEN
                  pp_acquired [port].iou := iou_number;
                  pp_acquired [port].channel.number := ch_element ^.data_channel.number;
                  pp_acquired [port].channel.concurrent := ch_element ^.data_channel.concurrent;
                  pp_acquired [port].channel.port := ch_element ^.data_channel.port;
                  pp_acquired [port].pp_table_rma := pp_table_rma;
                  pp_acquired [port].controller_type := controller_type;

                  pp_acquired [port].driver_name := element.controller.
                       peripheral_driver_name;
                  cmp$get_logical_pp_index (ch_element^, pp_acquired [port].logical_pp [1], status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;

                  IF cmv$logical_pp_table_p^ [pp_acquired [port].logical_pp [1]].
                        pp_info.logical_partner_pp_index > 0 THEN
                    pp_acquired [port].logical_pp [2] :=
                          cmv$logical_pp_table_p^ [pp_acquired [port].logical_pp [1]].
                          pp_info.logical_partner_pp_index;
                  IFEND
                IFEND;
              IFEND;
            IFEND;
          FOREND /channel_loop_2/;
        IFEND;

      = cmc$storage_device_element =

        channel_state := cmc$down;
        equipment_state := cmc$down;
        ch := -1;

        /port_loop_2/
        FOR port := LOWERVALUE (cmt$data_storage_port_number) TO
                     UPPERVALUE (cmt$data_storage_port_number) DO
          IF element.storage_device.connection.port [port].configured THEN
            IF element.storage_device.connection.
                port [port].upline_connection_type = cmc$data_channel_element THEN { Hydra }
              IF element.storage_device.connection.port [port].mainframe_ownership = mainframe_id THEN
                cmp$get_element_state (element.storage_device.
                  connection.port [port].element_name, element.storage_device.connection.
                       port [port].iou, channel_state, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                IF channel_state = cmc$on THEN
                  cmp$pc_get_element (element.storage_device.connection.
                    port [port].element_name, element.storage_device.connection.port
                          [port].iou, ch_element, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;

                  cmp$get_pp_table_rma (ch_element^, pp_table_rma, ignore_status);
                  IF NOT ignore_status.normal THEN { PPIT not build at deadstart. }
                    CYCLE /port_loop_2/; { Find the next channel. }
                  IFEND;

                  IF port > LOWERVALUE (cmt$data_storage_port_number) THEN
                    FOR minus_one := LOWERVALUE (cmt$data_storage_port_number) TO port - 1 DO
                      IF pp_acquired [minus_one].acquired THEN
                        IF pp_acquired [minus_one].pp_table_rma = pp_table_rma THEN

                          { Do not acquire PP for CCH#(A or B) again.

                          CYCLE /port_loop_2/; { Find the next channel.}
                        IFEND;
                      IFEND;
                    FOREND;
                  IFEND;
                  cmp$convert_iou_name (ch_element^.data_channel.iou, iou_number, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;

                  determine_if_pp_not_active (ch_element^.data_channel.number, ch_element^.data_channel.port,
                        ch_element^.data_channel.concurrent, iou_number, pp_acquired [port].acquired);
                  IF pp_acquired [port].acquired THEN
                    pp_acquired [port].iou := iou_number;
                    pp_acquired [port].channel.number := ch_element ^.data_channel.number;
                    pp_acquired [port].channel.concurrent := ch_element ^.data_channel.concurrent;
                    pp_acquired [port].channel.port := ch_element ^.data_channel.port;
                    pp_acquired [port].pp_table_rma := pp_table_rma;
                    pp_acquired [port].driver_name := 'E9S887';
                    pp_acquired [port].controller_type := cmc$mshydra_ct;

                    cmp$get_logical_pp_index (ch_element^, pp_acquired [port].logical_pp [1], status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;
                  IFEND;
                IFEND;
              IFEND;
            ELSEIF element.storage_device.connection.
                port [port].upline_connection_type = cmc$controller_element THEN
              cmp$get_element_state (element.storage_device.
                connection.port [port].element_name, iou_name, equipment_state, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              IF equipment_state = cmc$on THEN
                cmp$pc_get_element (element.storage_device.
                  connection.port [port].element_name, iou_name, eq_element, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                /channel_loop_3/
                FOR ch_port := LOWERVALUE (cmt$controller_port_number) TO
                                 UPPERVALUE (cmt$controller_port_number) DO
                  IF (eq_element ^.controller.connection.port [ch_port].configured) AND
                         (eq_element^ .controller.connection.port [ch_port].mainframe_ownership
                          = mainframe_id) THEN
                    cmp$get_element_state (eq_element ^.controller.
                      connection.port [ch_port].element_name,
                        eq_element^.controller.connection.port [ch_port].iou, channel_state,
                           status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;
                    IF channel_state = cmc$on THEN
                      cmp$pc_get_element (eq_element ^.controller.connection.
                        port [ch_port].element_name, eq_element^.controller.connection.port
                            [ch_port].iou,ch_element, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                      cmp$convert_iou_name (ch_element^.data_channel.iou, iou_number, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;
                      physical_channel.number := ch_element^.data_channel.number;
                      physical_channel.concurrent := ch_element^.data_channel.concurrent;
                      physical_channel.port := ch_element^.data_channel.port;
                      cmp$determine_redundant_channel (physical_channel, iou_number,
                          {ignore_state=}TRUE, redundant, ignore_status);
                      IF cmp$support_redundant_channel (controller_type) THEN
                        IF redundant THEN
                          CYCLE /channel_loop_3/;
                        IFEND;
                      IFEND;
                      cmp$get_pp_table_rma (ch_element^, pp_table_rma, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                      IF ch > LOWERVALUE (cmt$max_channels_per_storage) THEN
                        FOR minus_one := LOWERVALUE (cmt$max_channels_per_storage) TO ch - 1 DO
                          IF pp_acquired [minus_one].acquired THEN
                            IF pp_acquired [minus_one].pp_table_rma = pp_table_rma THEN

                              { Do not acquire PP for CCH#(A or B) again.

                              CYCLE /channel_loop_3/; { Find the next channel.}

                            IFEND;
                          IFEND;
                        FOREND;
                      IFEND;

                      determine_if_pp_not_active (ch_element^.data_channel.number,
                            ch_element^.data_channel.port, ch_element^.data_channel.concurrent,
                            iou_number, pp_not_active);
                      IF pp_not_active THEN
                        ch := ch + 1;
                        pp_acquired [ch].acquired := TRUE;
                        pp_acquired [ch].iou := iou_number;
                        pp_acquired [ch].channel.number := ch_element ^.data_channel.number;
                        pp_acquired [ch].channel.concurrent := ch_element ^.data_channel.concurrent;
                        pp_acquired [ch].channel.port := ch_element ^.data_channel.port;
                        pp_acquired [ch].pp_table_rma := pp_table_rma;
                        pp_acquired [ch].controller_type := controller_type;
                        pp_acquired [ch].driver_name := eq_element ^.
                            controller.peripheral_driver_name;
                        cmp$get_logical_pp_index (ch_element^, pp_acquired [ch].logical_pp [1], status);
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;

                        IF cmv$logical_pp_table_p^ [pp_acquired [ch].logical_pp [1]].
                              pp_info.logical_partner_pp_index > 0 THEN
                          pp_acquired [ch].logical_pp [2] :=
                                cmv$logical_pp_table_p^ [pp_acquired [ch].logical_pp [1]].
                                pp_info.logical_partner_pp_index;
                        IFEND
                      IFEND;
                    IFEND;
                  IFEND;
                FOREND /channel_loop_3/;
              IFEND;
            IFEND;
          IFEND;
        FOREND /port_loop_2/;

      ELSE
        ;
      CASEND;

    PROCEND cmp$active_path;

?? TITLE := '  cmp$change_ext_cpu_state', EJECT ??

  PROCEDURE cmp$change_ext_cpu_state
    (    channel_definition: cmt$element_definition;
         current_state: cmt$element_state;
         new_state: cmt$element_state;
         controller_type: cmt$controller_type;
     VAR status: ost$status);

    VAR
      driver_name: pmt$program_name,
      element_def: ^cmt$element_definition,
      iou_name: cmt$element_name,
      iou_number: dst$iou_number,
      logical_unit_number: iot$logical_unit,
      lock_obtained: boolean,
      pen: cmt$physical_equipment_number,
      physical_channel: cmt$physical_channel,
      pp_table_rma: ost$real_memory_address,
      pp_not_active: boolean,
      resources_released: boolean;

    status.normal := TRUE;
    resources_released := FALSE;

  /main_program/
    BEGIN
      IF channel_definition.element_type <> cmc$data_channel_element THEN
        EXIT /main_program/;
      ELSE
        FOR pen := LOWERVALUE (cmt$physical_equipment_number)
              TO UPPERVALUE (cmt$physical_equipment_number) DO
          IF channel_definition.data_channel.connection.equipment [pen].configured THEN
            cmp$pc_get_element (channel_definition.data_channel.connection.equipment [pen].element_name,
                  iou_name, element_def, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            driver_name := element_def^.external_processor.peripheral_driver_name;
            cmp$get_logical_unit_number (element_def^.element_name, logical_unit_number, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            IF NOT resources_released THEN
              cmp$get_pp_table_rma (channel_definition, pp_table_rma, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              cmp$convert_iou_name (channel_definition.data_channel.iou, iou_number, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              physical_channel.number := channel_definition.data_channel.number;
              physical_channel.concurrent := channel_definition.data_channel.concurrent;
              physical_channel.port := channel_definition.data_channel.port;

              IF ((new_state = cmc$off) AND (current_state = cmc$on)) OR
                    ((new_state = cmc$down) AND (current_state = cmc$on)) THEN
                determine_if_pp_not_active (channel_definition.data_channel.number,
                      channel_definition.data_channel.port, channel_definition.data_channel.concurrent,
                      iou_number, pp_not_active);
                IF NOT pp_not_active THEN
                  cmp$idle_pp_r1 (channel_definition.element_name, channel_definition.data_channel.iou,
                        status);
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;

                  cmp$release_pp_by_channel (physical_channel, iou_number, status);
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;
                IFEND;
                IF new_state = cmc$off THEN
                  cmp$release_channel_resource (physical_channel, iou_number, status);
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;
                IFEND;
              ELSEIF (new_state = cmc$down) AND (current_state = cmc$off) THEN
                cmp$clear_ppit (channel_definition.element_name, channel_definition.data_channel.iou,
                      status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;

                cmp$reacquire_resources (dsc$rrt_get_channel, physical_channel, iou_number,
                      cmc$null_equipment_number, cmc$null_unit_number, driver_name, pp_table_rma,
                      controller_type, FALSE, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;

              ELSEIF (new_state = cmc$on) THEN
                IF current_state = cmc$off THEN
                  cmp$reacquire_resources (dsc$rrt_get_channel, physical_channel, iou_number,
                        cmc$null_equipment_number, cmc$null_unit_number, driver_name, pp_table_rma,
                        controller_type, TRUE, status);
                ELSEIF current_state = cmc$down THEN
                  cmp$reacquire_resources (dsc$rrt_get_pp, physical_channel, iou_number,
                        cmc$null_equipment_number, cmc$null_unit_number, driver_name, pp_table_rma,
                        controller_type, TRUE, status);
                IFEND;
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
              IFEND;
              resources_released := TRUE;
            IFEND; { NOT resources_released }
            cmp$lock_lun_entry (logical_unit_number, lock_obtained);

            IF NOT lock_obtained THEN
              osp$set_status_abnormal (cmc$configuration_management_id, cme$jtd_unable_to_access_lut,
                    'Cannot access LUT.', status);
              EXIT /main_program/;
            IFEND;

            IF new_state = cmc$on THEN
              cmp$disable_unit (logical_unit_number);
            ELSE
              cmp$enable_unit (logical_unit_number);
            IFEND;

            cmp$update_logical_unit_table (logical_unit_number, new_state, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            cmp$unlock_lun_entry (logical_unit_number, lock_obtained);
            IF NOT lock_obtained THEN
              osp$set_status_abnormal (cmc$configuration_management_id, cme$jtd_unable_to_access_lut,
                    'Cannot access LUT.', status);
              EXIT /main_program/;
            IFEND;
          IFEND;
        FOREND;
      IFEND;
    END /main_program/;

  PROCEND cmp$change_ext_cpu_state;

?? TITLE := '  cmp$check_alternate_path ', EJECT ??

  PROCEDURE cmp$check_alternate_path (element : cmt$element_definition;
          upline_element : cmt$element_definition;
          data_channel : cmt$data_channel_definition;
      VAR alternate_path_active : BOOLEAN;
      VAR alternate_access_type: cmt$element_type;
      VAR status : ost$status);

      VAR
        channel_element_p : ^cmt$element_definition,
        controller_state: cmt$element_state,
        ct_element_p : ^cmt$element_definition,
        iou_number : dst$iou_number,
        i : cmt$data_storage_port_number,
        iou_name : cmt$element_name,
        mainframe_id : pmt$mainframe_id,
        pp_not_active: boolean,
        upline_index : cmt$controller_port_number;

{  PURPOSE : This procedure figures out whether an element of type
{      cmc$storage_device_element has an alternate active path.
{

       status.normal := TRUE;
       alternate_path_active := FALSE;
       ct_element_p := NIL;
       pmp$get_mainframe_id (mainframe_id, status);
       IF NOT status.normal THEN
         RETURN;
       IFEND;
       IF element.element_type = cmc$storage_device_element THEN
         FOR i := LOWERVALUE(cmt$data_storage_port_number) TO UPPERVALUE
                     (cmt$data_storage_port_number) DO
           IF element.storage_device.connection.port [i].configured THEN
             IF element.storage_device.connection.port [i].upline_connection_type =
                          cmc$controller_element THEN
               cmp$get_element_state (element.storage_device.connection.port [i].
                      element_name, iou_name, controller_state, status);
               IF NOT status.normal THEN
                 RETURN;
               IFEND;

               IF (element.storage_device.connection.port [i].element_name <>
                      upline_element.element_name) AND (controller_state = cmc$on) THEN

                 cmp$pc_get_element (element.storage_device.connection.port [i].
                        element_name, iou_name, ct_element_p, status);
                 IF NOT status.normal THEN
                   RETURN;
                 IFEND;

    { Found another controller connected to this unit. Now get the
    { state of all element on the upline connection of the controller.

                 FOR upline_index := LOWERVALUE(cmt$controller_port_number) TO UPPERVALUE
                           (cmt$controller_port_number) DO
                   IF ct_element_p^.controller.connection.port [upline_index].configured THEN
                     IF (ct_element_p^.controller.connection.port [upline_index].
                               upline_connection_type = cmc$data_channel_element) AND
                               (ct_element_p^.controller.connection.port [upline_index].
                               mainframe_ownership = mainframe_id) THEN
                       cmp$pc_get_element (ct_element_p^.controller.connection.port [upline_index].
                             element_name, ct_element_p^.controller.connection.port [upline_index].
                                   iou, channel_element_p, status);
                       IF NOT status.normal THEN
                         RETURN;
                       IFEND;
                       cmp$convert_iou_name (ct_element_p^.controller.connection.port [upline_index].
                                   iou, iou_number, status);
                       IF NOT status.normal THEN
                         RETURN;
                       IFEND;
                       determine_if_pp_not_active (channel_element_p^.data_channel.number,
                             channel_element_p^.data_channel.port, channel_element_p^.data_channel.concurrent,
                             iou_number, pp_not_active);
                       IF NOT pp_not_active THEN
                         alternate_path_active := TRUE;
                         alternate_access_type := cmc$controller_element;
                         RETURN;
                       IFEND;
                     IFEND;
                   IFEND;
                 FOREND;
               IFEND;
             IFEND;  { Upline connection is a controller }
          IFEND; { Upline connection is configured }
        FOREND; { Loop Through upline connection of unit }

        IF (ct_element_p = NIL) AND (upline_element.element_type = cmc$controller_element) THEN
          ct_element_p := ^upline_element;
        ELSE
          RETURN;
        IFEND;

 { If control gets here, there is no dual controller acces. See if there
 { is dual channel access.

        FOR upline_index := LOWERVALUE(cmt$controller_port_number) TO UPPERVALUE
                    (cmt$controller_port_number) DO
           IF ct_element_p^.controller.connection.port [upline_index].configured THEN
             IF (ct_element_p^.controller.connection.port [upline_index].
                       upline_connection_type = cmc$data_channel_element) AND
                       (ct_element_p^.controller.connection.port [upline_index].
                       mainframe_ownership = mainframe_id) THEN
               cmp$pc_get_element (ct_element_p^.controller.connection.port [upline_index].
                     element_name, ct_element_p^.controller.connection.port [upline_index].
                           iou, channel_element_p, status);
               IF NOT status.normal THEN
                 RETURN;
               IFEND;
               IF (channel_element_p^ .data_channel.number <> data_channel.number) OR
                      (channel_element_p^ .data_channel.concurrent <> data_channel.concurrent)
                      OR (channel_element_p^ .data_channel.iou <> data_channel.iou) THEN
                 cmp$convert_iou_name (ct_element_p^.controller.connection.port [upline_index].
                           iou, iou_number, status);
                 IF NOT status.normal THEN
                   RETURN;
                 IFEND;
                 determine_if_pp_not_active (channel_element_p^.data_channel.number,
                       channel_element_p^.data_channel.port, channel_element_p^.data_channel.concurrent,
                       iou_number, pp_not_active);
                 IF NOT pp_not_active THEN
                   alternate_path_active := TRUE;
                   alternate_access_type := cmc$data_channel_element;
                   RETURN;
                 IFEND;
               IFEND;
             IFEND;
           IFEND;
         FOREND;
       IFEND; { Element is a storage device element }

  PROCEND cmp$check_alternate_path;

?? TITLE := '  cmp$change_disk_element_state', EJECT ??

  PROCEDURE cmp$change_disk_element_state (
       element_definition : cmt$element_definition;
       controller_type : cmt$controller_type;
       system_critical_element : boolean;
       logical_pp : iot$pp_number;
       channel_number : cmt$physical_channel;
       iou_number: dst$iou_number;
       new_state : cmt$element_state;
   VAR logical_unit_number : iot$logical_unit;
   VAR status : ost$status);

   VAR
     ct_element_p : ^cmt$element_definition,
     equipment_number : cmt$physical_equipment_number,
     ignore_status : ost$status,
     iou_name : cmt$element_name,
     path_active : boolean,
     pen : cmt$physical_equipment_number,
     physical_channel : cmt$physical_channel,
     port : integer,
     pp_acquired : ^ARRAY [ * ] OF pps_acquired_info,
     pp_not_active: boolean,
     pp_released : ^ARRAY [ * ] OF pps_released_info,
     pun : cmt$physical_unit_number,
     sd_element_p : ^cmt$element_definition,
     state : cmt$element_state;

{ PURPOSE : This procedure change the state of MASS storage devices.

     status.normal := TRUE;
     equipment_number := 0;
     PUSH pp_acquired: [LOWERVALUE (cmt$max_channels_per_storage) .. UPPERVALUE
             (cmt$max_channels_per_storage)];
     PUSH pp_released: [LOWERVALUE (cmt$controller_port_number) .. UPPERVALUE
             (cmt$controller_port_number)];

   /main_program/
     BEGIN
       IF element_definition.element_type = cmc$storage_device_element THEN
         cmp$get_logical_unit_number (
            element_definition.element_name, logical_unit_number, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;
         equipment_number := cmv$logical_pp_table_p^ [logical_pp].pp_info.pp_interface_table_p^.
               unit_descriptors[logical_unit_number].physical_path.controller_number;
       ELSEIF element_definition.element_type = cmc$controller_element THEN
         equipment_number := element_definition.controller.physical_equipment_number;
       IFEND;
       IF new_state = cmc$on THEN

{ Acquire and deadstart PP(s) for channel(s) if at least
{ one path to the unit has all its elements in the ON state

         cmp$active_path (element_definition, controller_type, pp_acquired^, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;

         FOR port := LOWERVALUE (cmt$max_channels_per_storage) TO
                       UPPERVALUE (cmt$max_channels_per_storage) DO
           IF pp_acquired^ [port].acquired THEN
             cmp$reacquire_resources (dsc$rrt_get_pp, pp_acquired^ [port].channel,
               pp_acquired^ [port].iou, cmc$null_equipment_number, cmc$null_unit_number,
                 pp_acquired^ [port].driver_name, pp_acquired^ [port].pp_table_rma,
                   pp_acquired^ [port].controller_type, TRUE, status);
             IF NOT status.normal THEN
               EXIT /main_program/;
             IFEND;

           IFEND;
         FOREND;
       IFEND;

{ Call monitor to propose disabling/enabling of units

       cmp$change_state_r1 (element_definition.element_name,
             element_definition.element_type, controller_type, system_critical_element,
             new_state, iou_number, logical_pp,
             channel_number, equipment_number, logical_unit_number, status);
       IF NOT status.normal THEN
         IF new_state = cmc$on THEN

 { Undo - Release above acquired PP(s)

           FOR port := LOWERVALUE (cmt$max_channels_per_storage) TO
                         UPPERVALUE (cmt$max_channels_per_storage) DO
             IF pp_acquired^ [port].acquired THEN
               cmp$release_pp_by_channel (pp_acquired^ [port].channel, pp_acquired^ [port].iou,
                     ignore_status);
             IFEND;
           FOREND;

         IFEND;
         EXIT /main_program/;
       IFEND;


       IF (new_state = cmc$off) OR (new_state = cmc$down) THEN
         IF element_definition.element_type = cmc$controller_element THEN

   { Release PP(s) for channel if no more controllers are ON

           cmp$unactive_path (element_definition, pp_released^, status);
           IF NOT status.normal THEN
             EXIT /main_program/;
           IFEND;
           FOR port := LOWERVALUE (cmt$controller_port_number) TO
                         UPPERVALUE (cmt$controller_port_number) DO
             IF pp_released^ [port].released THEN
               cmp$release_pp_by_channel (pp_released^ [port].channel, pp_released^ [port].iou, status);
               IF NOT status.normal THEN
                 EXIT /main_program/;
               IFEND;
               cmp$convert_iou_number (pp_released^ [port].iou, iou_name, status);
               IF NOT status.normal THEN
                 EXIT /main_program/;
               IFEND;
               cmp$clear_ppit (pp_released^ [port].channel_name, iou_name, status);
               IF NOT status.normal THEN
                 EXIT /main_program/;
               IFEND;
             IFEND;
           FOREND;
         ELSEIF element_definition.element_type = cmc$data_channel_element THEN

   { Release PP for channel

           determine_if_pp_not_active (element_definition.data_channel.number,
                 element_definition.data_channel.port, element_definition.data_channel.concurrent,
                 iou_number, pp_not_active);
           IF NOT pp_not_active THEN
             physical_channel.number := element_definition.data_channel.number;
             physical_channel.concurrent := element_definition.data_channel.concurrent;
             physical_channel.port := element_definition.data_channel.port;

             cmp$release_pp_by_channel (physical_channel, iou_number, status);
             IF NOT status.normal THEN
               EXIT /main_program/;
             IFEND;

             cmp$clear_ppit (element_definition.element_name, element_definition.data_channel.iou,
                  status);
           IFEND;
         IFEND;
       IFEND;
     END /main_program/;

   PROCEND cmp$change_disk_element_state;

?? TITLE := '  cmp$change_tape_unit_state ', EJECT ??

  PROCEDURE cmp$change_tape_unit_state
    (    element_definition: cmt$element_definition;
         current_state: cmt$element_state;
         new_state: cmt$element_state;
         channel: cmt$element_definition;
         equipment_number: cmt$physical_equipment_number;
         controller_type: cmt$controller_type;
         driver_name: pmt$program_name;
         system_call: boolean;
         logical_unit_number: iot$logical_unit;
         logical_unit_state: cmt$element_state;
     VAR channel_released: boolean;
     VAR status: ost$status);

  VAR
    iou_number : dst$iou_number,
    lock_obtained : boolean,
    lock_set: boolean,
    lut_state : cmt$element_state,
    physical_channel : cmt$physical_channel,
    pp_table_rma : ost$real_memory_address,
    unit_number : cmt$physical_unit_number;

{ PURPOSE: This procedure update the logical unit table and the
{   system tape table . It assumes the given element is a tape unit.

    status.normal := TRUE;
    lock_set := FALSE;
    channel_released := FALSE;
  /main_program/
    BEGIN

      cmp$convert_iou_name (channel.data_channel.iou, iou_number, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      unit_number := element_definition.storage_device.physical_unit_number;

      cmp$lock_lun_entry (logical_unit_number, lock_obtained);
      IF NOT lock_obtained THEN
        osp$set_status_condition (
           cme$jtd_unable_to_access_lut,  status);
        EXIT /main_program/;
      IFEND;
      lock_set := TRUE;

      IF (new_state = cmc$off) OR (new_state = cmc$down) THEN
        IF cmv$logical_unit_table^ [logical_unit_number].status.assigned THEN
          osp$set_status_abnormal (cmc$configuration_management_id,
                cme$jtd_unit_already_assigned, element_definition.element_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                cmv$logical_unit_table^ [logical_unit_number].status.assigned_jsn, status);
          EXIT /main_program/;
        IFEND;
      IFEND;

 { Update logical unit table and system tape table }

      physical_channel.number := channel.data_channel.number;
      physical_channel.concurrent := channel.data_channel.concurrent;
      physical_channel.port := channel.data_channel.port;
      IF (((new_state = cmc$off) OR (new_state = cmc$down)) AND (current_state=cmc$on)) OR
             ((new_state = cmc$off) AND (current_state = cmc$down)) THEN
        cmp$disable_unit (logical_unit_number);
        IF (new_state = cmc$off) AND (logical_unit_state <> cmc$off) THEN
          IF (controller_type <> cmc$mt5698_xx) AND NOT(((controller_type = cmc$mt698_xx)
             OR (controller_type = cmc$mt5680_xx)) AND
               (osv$170_os_type = osc$ot7_dual_state_nos_be)) THEN

            cmp$release_equipment_resource (physical_channel, iou_number, equipment_number, unit_number);
            IF physical_channel.concurrent THEN
              channel_released := TRUE;
            IFEND;
          IFEND;
        IFEND;

      ELSEIF (((new_state = cmc$on) OR (new_state=cmc$down)) AND (current_state = cmc$off)) THEN
        IF (controller_type <> cmc$mt5698_xx) AND NOT((controller_type = cmc$mt698_xx) AND
               (osv$170_os_type = osc$ot7_dual_state_nos_be)) AND
               (controller_type <> cmc$mt5680_xx) THEN
          cmp$reacquire_resources (dsc$rrt_get_equipment, physical_channel,
             iou_number, equipment_number, unit_number,
             driver_name, pp_table_rma, controller_type, FALSE, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;
        IF new_state = cmc$on THEN
          cmp$enable_unit (logical_unit_number);
        IFEND;
      ELSEIF (new_state = cmc$on) AND (current_state = cmc$down) THEN
        cmp$enable_unit (logical_unit_number);
      IFEND;

      cmp$update_logical_unit_table (logical_unit_number, new_state, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      REPEAT
        dmp$update_stt (logical_unit_number, logical_unit_state, new_state, status);
        IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
          pmp$wait (one_second, one_second);
        IFEND;
      UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
    END /main_program/;
    IF lock_set THEN
      cmp$unlock_lun_entry (logical_unit_number, lock_obtained);
    IFEND;

  PROCEND cmp$change_tape_unit_state;

?? TITLE := '  cmp$check_lcu_lock_set', EJECT ??

{ PURPOSE:
{   This procedure checks the LCU lock.

  PROCEDURE [XDCL, #GATE] cmp$check_lcu_lock_set (
     VAR status: ost$status);

    VAR
      lock_set: boolean,
      job_name: jmt$system_supplied_name;

    status.normal := TRUE;
    cmp$lcu_lock_set_by_job (job_name, lock_set);
    IF lock_set THEN
      osp$set_status_abnormal (cmc$configuration_management_id,
           cme$lcu_still_active, job_name, status);
    IFEND;

  PROCEND cmp$check_lcu_lock_set;

?? TITLE := '  cmp$process_outstanding_sc_req', EJECT ??

{ PURPOSE:
{   This procedure looks for outstanding state change requests
{   and processes them.

  PROCEDURE [XDCL, #GATE] cmp$process_outstanding_sc_req
    (VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      current_state: cmt$element_state,
      element: cmt$element_descriptor,
      local_status: ost$status,
      new_state: cmt$element_state,
      outstanding_request: boolean,
      system_supplied_name: jmt$system_supplied_name,
      tape_subsystem: boolean,
      user_supplied_name: jmt$user_supplied_name;

    #caller_id (caller_id);
    status.normal := TRUE;
    IF NOT (avp$configuration_administrator () OR avp$removable_media_operator () OR
              avp$system_operator () OR (caller_id.ring <= 6)) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active,
        'configuration_administration, removable_media_operation ' CAT
        'or system_operation', status);
      RETURN;
    IFEND;
    REPEAT
      cmp$find_state_change_request (outstanding_request, element, new_state, current_state);
      IF outstanding_request THEN
        cmp$determine_tape_element (element, tape_subsystem);
        pmp$get_job_names (user_supplied_name, system_supplied_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF tape_subsystem THEN
          IF NOT cmp$lock_set_by_task (cmc$removable_media_operation) THEN
            cmp$manage_lcu_lock (cmc$removable_media_operation, FALSE,
               system_supplied_name, status);
          IFEND;
        ELSE
          IF NOT cmp$lock_set_by_task (cmc$configuration_administrator) THEN
            cmp$manage_lcu_lock (cmc$configuration_administrator, FALSE,
                 system_supplied_name, status);
          IFEND;
        IFEND;
        IF status.normal THEN
          cmp$process_state_change (tape_subsystem,
              {clear_lock_behind=} FALSE, {system_call=} TRUE, element,
              FALSE, current_state, new_state, status);
          IF NOT status.normal THEN
            osp$generate_error_message (status, local_status);
            outstanding_request := FALSE;
          IFEND;
          IF tape_subsystem THEN
            cmp$manage_lcu_lock (cmc$removable_media_operation, TRUE,
               system_supplied_name, status);
          ELSE
            cmp$manage_lcu_lock (cmc$configuration_administrator, TRUE,
              system_supplied_name, status);
          IFEND;
        ELSE
          outstanding_request := FALSE;
        IFEND;
      IFEND;
    UNTIL (outstanding_request = FALSE);
  PROCEND cmp$process_outstanding_sc_req;
?? TITLE := '    cmp$process_state_change', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$process_state_change (
          tape_element: boolean;
          clear_lock_behind: boolean;
          system_caller : BOOLEAN;
          element_descriptor : cmt$element_descriptor;
          system_critical_element : boolean;
          current_element_state: cmt$element_state;
          new_element_state : cmt$element_state;
      VAR status : ost$status);

      PROCEDURE clean_up;
      VAR
        cleanup_status : ost$status,
        current_state : cmt$element_state,
        i : integer,
        iou_number : dst$iou_number,
        internal_state : cmt$element_state,
        lock_obtained: boolean,
        new_state : cmt$element_state;

        cmp$convert_iou_name (channel.data_channel.iou, iou_number, cleanup_status);
        FOR i := 1 TO number_of_units DO
          IF released_units^[i].acquired THEN
            new_state := released_units ^[i].new_state;
            current_state := released_units ^[i].current_state;
            cmp$get_logical_unit_state (released_units^[i].lun, cmv$logical_unit_table,
                internal_state);
            cmp$lock_lun_entry (released_units^[i].lun, lock_obtained);
            IF NOT lock_obtained THEN
              osp$set_status_condition (
                cme$jtd_unable_to_access_lut,  cleanup_status);
              RETURN;
            IFEND;

            IF (current_state = cmc$off) THEN
              cmp$disable_unit (released_units^[i].lun);
          IF (controller_type <> cmc$mt5698_xx) AND NOT(((controller_type = cmc$mt698_xx)
             OR (controller_type = cmc$mt5680_xx)) AND
               (osv$170_os_type = osc$ot7_dual_state_nos_be)) THEN



                cmp$release_equipment_resource (physical_channel, iou_number, released_units^[i].pen,
                      released_units^[i].pun);
              IFEND;
            ELSEIF (current_state = cmc$on) OR (current_state = cmc$down) THEN
              IF (controller_type <> cmc$mt5698_xx) AND NOT((controller_type = cmc$mt698_xx) AND
                      (osv$170_os_type = osc$ot7_dual_state_nos_be)) AND
                      (controller_type <> cmc$mt5680_xx) THEN
                cmp$reacquire_resources (dsc$rrt_get_equipment, physical_channel,
                   iou_number, released_units^[i].pen, released_units^[i].pun,
                   driver_name, pp_table_rma, controller_type, FALSE, cleanup_status);

                IF NOT cleanup_status.normal THEN
                  cmp$unlock_lun_entry (released_units^[i].lun, lock_obtained);
                  RETURN;
                IFEND;
              IFEND;
              IF (current_state = cmc$down) THEN
                cmp$disable_unit (released_units^[i].lun);
              ELSEIF (current_state = cmc$on) THEN
                cmp$enable_unit (released_units^[i].lun);
              IFEND;
            IFEND;
            IF (controller_type = cmc$mt5698_xx) OR (controller_type = cmc$mt5680_xx) THEN
              cmp$zero_out_uit_rma  (released_units^[i].lun, channel, current_state, cleanup_status);
            IFEND;
            cmp$update_logical_unit_table (released_units^[i].lun, current_state, cleanup_status);
            IF NOT cleanup_status.normal THEN
              cmp$unlock_lun_entry (released_units^[i].lun, lock_obtained);
              RETURN;
            IFEND;
            cmp$unlock_lun_entry (released_units^[i].lun, lock_obtained);
            IF NOT lock_obtained THEN
              osp$set_status_condition (
                cme$jtd_unable_to_access_lut,  cleanup_status);
              RETURN;
            IFEND;

            REPEAT
              dmp$update_stt (released_units^[i].lun, internal_state, current_state, cleanup_status);
              IF NOT cleanup_status.normal AND (cleanup_status.condition = dme$unable_to_lock_tape_table) THEN
                pmp$wait (one_second, one_second);
              IFEND;
            UNTIL cleanup_status.normal OR (cleanup_status.condition <> dme$unable_to_lock_tape_table);
            IF NOT cleanup_status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        FOREND;
        IF redundant_path_available AND acquire_redundant_pp THEN
          FOR i := 0 TO number_of_path DO
            cmp$release_pp_by_channel (redundant_channel_list^ [i].channel, redundant_channel_list^ [i].iou,
                  cleanup_status);
          FOREND;
        IFEND;
        IF pp_idled THEN
          cmp$resume_pp_r1 (channel.element_name, channel.data_channel.iou, cleanup_status);
          pp_idled := FALSE;
        IFEND;
      PROCEND clean_up;

      TYPE
        release_information = RECORD
          acquired : BOOLEAN,
          pen : cmt$physical_equipment_number,
          pun : cmt$physical_unit_number,
          lun : iot$logical_unit,
          state : cmt$element_state,
          current_state : cmt$element_state,
          new_state : cmt$element_state,
        RECEND;

      VAR
        actual_new_state : cmt$element_state,
        acquire_redundant_pp : boolean,
        alternate_access_type : cmt$element_type,
        alternate_path_active: boolean,
        caller_id : ost$caller_identifier,
        ca_lock_set: boolean,
        channel_released: boolean,
        channel_state: cmt$element_state,
        channel: cmt$element_definition,
        channel_type: string (11),
        clean_up_status : ost$status,
        cm_unit_type : cmt$unit_type,
        controller_state : cmt$element_state,
        controller_type : cmt$controller_type,
        critical_msg : string (64),
        ct_element_p : ^cmt$element_definition,
        current_state: cmt$element_state,
        disabled_connection_exists: boolean,
        driver_name: pmt$program_name,
        element: cmt$element_descriptor,
        element_definition : cmt$element_definition,
        equipment_number : cmt$physical_equipment_number,
        foreign_equipment: boolean,
        found : BOOLEAN,
        index : integer,
        ignore_status : ost$status,
        io_unit_type : iot$unit_type,
        iou_number : dst$iou_number,
        iou_name : cmt$element_name,
        logical_pp : iot$pp_number,
        log_data_ptr: ^SEQ (*),
        logging_data: dst$log_ele_state_change,
        logical_unit_state : cmt$element_state,
        logical_unit_number : iot$logical_unit,
        mainframe_id: pmt$mainframe_id,
        mass_storage_element : boolean,
        msg_size: 0 .. 0ff(16),
        need_to_idle_pp: boolean,
        name_list_p: ^array [ * ] of cmt$element_name,
        new_state: cmt$element_state,
        number_of_entries: integer,
        number_of_down_controllers : integer,
        number_of_on_controllers : integer,
        number_of_path : integer,
        number_of_units : integer,
        outstanding_request: boolean,
        pen : cmt$physical_equipment_number,
        peripheral_driver_name : pmt$program_name,
        physical_channel : cmt$physical_channel,
        physical_id: cmt$physical_identification,
        port : integer,
        pp_idled: boolean,
        pp_not_active: boolean,
        pp_table_rma : ost$real_memory_address,
        process_channel : boolean,
        process_pp : boolean,
        pun : cmt$physical_unit_number,
        released_units : ^ARRAY [1 .. *] OF release_information,
        redundant_path_pp_list : ARRAY [cmt$physical_equipment_number] OF iot$pp_number,
        redundant_channel_list : ^ARRAY [ * ] OF  cmt$physical_address,
        redundant_pp_table_rma_list :ARRAY [cmt$physical_equipment_number] OF ost$real_memory_address,
        redundant_path_available : boolean,
        redundant_path_useable : boolean,
        rmo_lock_set: boolean,
        save_status : ost$status,
        state : cmt$element_state,
        state_change_request: cmt$state_change_request,
        state_to_check : cmt$element_state,
        system_call: boolean,
        system_supplied_name: jmt$system_supplied_name,
        tape_subsystem: boolean,
        unit_class : cmt$unit_class,
        unit_element_p : ^cmt$element_definition,
        update_controller_address: boolean,
        user_supplied_name: jmt$user_supplied_name;

  { PURPOSE: This procedure performs the STATE change. Because it needs
  {   to call 113 routines, this procedure resides in Job Template 23D

    #caller_id (caller_id);
    status.normal := TRUE;

    save_status.normal := TRUE;
    new_state := new_element_state;
    current_state := current_element_state;
    tape_subsystem := tape_element;

 { If passed in physical address, convert to element name to search in peripheral table.

    IF element_descriptor.element_type <> cmc$data_channel_element THEN
      IF NOT element_descriptor.peripheral_descriptor.use_logical_identification THEN
        physical_id.hardware_address := element_descriptor.peripheral_descriptor.hardware_address;
        physical_id.product_identification.product_number := '     ';
        physical_id.product_identification.underscore := ' ';
        physical_id.product_identification.model_number := '   ';
        physical_id.serial_number := '   ';
        cmp$get_element_name (physical_id, element, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        element := element_descriptor;
      IFEND;
    ELSE
      element := element_descriptor;
    IFEND;

    system_call := system_caller;
    PUSH redundant_channel_list : [LOWERVALUE (cmt$physical_equipment_number) ..
           UPPERVALUE (cmt$physical_equipment_number)];

  /main_program/
    BEGIN
      IF NOT (avp$system_operator () OR avp$configuration_administrator () OR
             avp$removable_media_operator () OR (caller_id.ring <= 6)) THEN
        osp$set_status_abnormal ('OF', ofe$sou_not_active,
               'configuration_administration, removable_media_operation ' CAT
               'or system_operation', status);
        EXIT /main_program/;
      IFEND;

      REPEAT
        mass_storage_element := FALSE;
        foreign_equipment := FALSE;
        pp_idled := FALSE;
        redundant_path_available := FALSE;
        redundant_path_useable := FALSE;
        acquire_redundant_pp := FALSE;
        need_to_idle_pp := FALSE;
        ca_lock_set := FALSE;
        rmo_lock_set := FALSE;

        cmp$get_element_definition (element_descriptor, element_definition, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        {
        { Validate legal state change.
        {
        IF new_state = current_state THEN
          disabled_connection_exists := FALSE;
          IF new_state = cmc$on THEN
            cmp$locate_disabled_connection (element_definition, disabled_connection_exists, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
          IFEND;
          IF NOT disabled_connection_exists THEN
            osp$set_status_abnormal (cmc$configuration_management_id,
                 cme$request_state_is_crnt_state, ' ', status);
            EXIT /main_program/;
          IFEND;
        IFEND;
        {
        { Validate element type.
        {
        IF element_descriptor.element_type <> element_definition.element_type THEN
          osp$set_status_abnormal (cmc$configuration_management_id,
              cme$incorrect_element_type, element_definition.element_name, status);
          EXIT /main_program/;
        IFEND;

        cmp$retrieve_element_info (element_definition, driver_name, controller_type, status);
        IF NOT status.normal THEN
          IF status.condition = cme$pc_unknown_controller_type THEN
            foreign_equipment := TRUE;
            status.normal := TRUE;
          ELSE
            EXIT /main_program/;
          IFEND;
        IFEND;

      /acquire_release_resource/
        BEGIN

          pmp$get_job_names (user_supplied_name, system_supplied_name, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
          IF tape_subsystem THEN
            IF NOT cmp$lock_set_by_task (cmc$removable_media_operation) THEN
              cmp$manage_lcu_lock (cmc$removable_media_operation, FALSE,
                 system_supplied_name, status);
              rmo_lock_set := status.normal;
            IFEND;
          ELSE
            IF NOT cmp$lock_set_by_task (cmc$configuration_administrator) THEN
              cmp$manage_lcu_lock (cmc$configuration_administrator, FALSE,
                 system_supplied_name, status);
              ca_lock_set := status.normal;
            IFEND;
          IFEND;

 { Queue request if system call and unable to obtain lock.

          IF NOT status.normal THEN
            IF system_call THEN
              state_change_request.pending := TRUE;
              state_change_request.new_state := new_state;

 { Lock already set by another job or task, queue the request and status should be
 { normal for system caller.

              cmp$queue_state_change (element, state_change_request, status);

 { Attempt to acquire lock one more time. If successful then process the state change.
 { This is done to make sure that the request will be done if it was missed by the
 { QUIT command.

              IF tape_subsystem THEN
                IF NOT cmp$lock_set_by_task (cmc$removable_media_operation) THEN
                  cmp$manage_lcu_lock (cmc$removable_media_operation, FALSE,
                     system_supplied_name, ignore_status);
                  rmo_lock_set := ignore_status.normal;
                IFEND;
              ELSE
                IF NOT cmp$lock_set_by_task (cmc$configuration_administrator) THEN
                  cmp$manage_lcu_lock (cmc$configuration_administrator, FALSE,
                     system_supplied_name, ignore_status);
                  ca_lock_set := ignore_status.normal;
                IFEND;
              IFEND;
              IF NOT ignore_status.normal THEN
                EXIT /main_program/;
              IFEND;
            ELSE   { Manual state change case, return abnormal status to user.
              EXIT /main_program/;
            IFEND;
          IFEND;
          IF foreign_equipment THEN

   { Check if element is already reserved by any job .
   { Only update state table, foreign subsystem is responsible for scheduling IOU resources

            check_for_element_reservation (element_descriptor, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            EXIT /acquire_release_resource/;
          IFEND;

   { Figure out the state that need to be used in deciding whether or not
   { a tape unit should be processed.

          IF new_state = cmc$on THEN
            state_to_check := current_state;
          ELSE
            state_to_check := new_state;
          IFEND;
          CASE element_definition.element_type OF

          = cmc$data_channel_element =

   { Element is an ICA or a MTI/MDI/EXPRESSLINK channel. }

            channel := element_definition; { Channel is initialized for clean up purpose.
            physical_channel.number := element_definition.data_channel.number;
            physical_channel.concurrent := element_definition.data_channel.concurrent;
            physical_channel.port := element_definition.data_channel.port;
            cmp$convert_iou_name (element_definition.data_channel.iou, iou_number, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            IF (controller_type = cmc$ca2629_2) OR
                 (controller_type = cmc$mti2620_21x) OR
                 (controller_type = cmc$expresslink) OR
                 (controller_type = cmc$mdi2621_21x) THEN

              FOR pen := LOWERVALUE (cmt$physical_equipment_number) TO
                           UPPERVALUE(cmt$physical_equipment_number) DO
                IF element_definition.data_channel.connection.equipment [pen].configured THEN

  { Check states of ICA/MTI/MDI/EXPRESSLINK channel and device before call NAM/VE. }

                  cmp$get_element_state (element_definition.
                      data_channel.connection.equipment [pen].element_name, iou_name, state, status);
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;

                  IF current_state = cmc$on THEN
                    IF state = cmc$on THEN
                      nap$change_network_device_state (element_definition.data_channel.
                        connection.equipment [pen].element_name, new_state, current_state, status);
                      IF NOT status.normal THEN
                        osp$generate_log_message (
                            $pmt$ascii_logset [pmc$job_log, pmc$system_log], status, ignore_status);
                        EXIT /main_program/;
                      IFEND;
                    IFEND;
                  ELSE
                    IF state = cmc$on THEN
                      IF new_state = cmc$on THEN
                        cmp$change_state_info_table (element_definition.element_name, element_definition.
                            data_channel.iou, new_state, status);
                        IF NOT status.normal THEN
                          EXIT /main_program/;
                        IFEND;
                        nap$change_network_device_state (element_definition.data_channel.
                          connection.equipment [pen].element_name, new_state, current_state, status);
                        IF NOT status.normal THEN
                          osp$generate_log_message (
                              $pmt$ascii_logset [pmc$job_log, pmc$system_log], status, ignore_status);
                          ignore_status.normal := TRUE;
                          cmp$change_state_info_table (
                               element_definition.element_name, element_definition.data_channel.iou,
                               current_state, ignore_status);
                          EXIT /main_program/;
                        IFEND;
                      IFEND;
                    IFEND;
                  IFEND;
                  EXIT /acquire_release_resource/;
                IFEND;

      { Check to see if channel is already reserved.

                check_for_element_reservation (element_descriptor, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
                IF (controller_type = cmc$lcn380_170) OR
                   (controller_type = cmc$fs740_200) THEN

      { Need to call DFP$ interface for file server element

                  EXIT /acquire_release_resource/;
                IFEND;
              FOREND;

  { Element is a TAPE channel.

            ELSEIF (controller_type = cmc$mt7021_3x) OR (controller_type = cmc$mt7021_4x) OR
                (controller_type = cmc$mt698_xx) OR (controller_type = cmc$mt5698_xx) OR
                  (controller_type = cmc$mt7221_2_s0) OR (controller_type = cmc$mt7221_1) OR
                  (controller_type = cmc$mt5680_xx) THEN

  { Check to see if DOWN or OFF the primary channel in a redundant configuration.
  { If so attempt to get a PP for the redundant channel if it is not already active.

              IF (cmp$support_redundant_channel (controller_type)) THEN
                cmp$search_redundant_path (element_definition, iou_number,
                       physical_channel, new_state, redundant_path_available,
                       update_controller_address, number_of_path, redundant_channel_list^,
                       redundant_path_pp_list, peripheral_driver_name, redundant_pp_table_rma_list);
                IF redundant_path_available THEN
                  FOR index := 0 TO number_of_path DO
                    determine_if_pp_not_active (redundant_channel_list^ [index].channel.number,
                          redundant_channel_list^ [index].channel.port,
                          redundant_channel_list^ [index].channel.concurrent,
                          redundant_channel_list^ [index].iou, pp_not_active);
                    IF pp_not_active AND (new_state <> cmc$on) THEN
                      cmp$reacquire_resources (dsc$rrt_get_pp, redundant_channel_list^[index].channel,
                             redundant_channel_list^[index].iou, cmc$null_equipment_number,
                             cmc$null_unit_number, peripheral_driver_name,
                             redundant_pp_table_rma_list [index], controller_type, TRUE, status);
                      redundant_path_useable := status.normal;
                      IF NOT acquire_redundant_pp THEN
                        acquire_redundant_pp := status.normal;
                      IFEND;
                    ELSE
                      redundant_path_useable := TRUE;
                    IFEND;
                  FOREND;
                IFEND;
              IFEND;

              count_all_units (element_definition, number_of_units);
              IF number_of_units > 0 THEN
                PUSH released_units : [1 .. number_of_units];
                FOR pun := 1 TO number_of_units DO
                  released_units^ [pun].acquired := FALSE;
                FOREND;
              IFEND;
              number_of_units := 0;
              number_of_on_controllers := 0;
              number_of_down_controllers := 0;
              PUSH name_list_p: [1 .. 2*(UPPERVALUE(cmt$physical_equipment_number)+1)];

   { Get a list of all element names connected to the given channel

              cmp$get_connected_elements (element_definition, name_list_p, number_of_entries, status);
              IF NOT status.normal THEN
                EXIT /main_program /;
              IFEND;
            /for_loop3/
              FOR index := 1 TO number_of_entries DO
                cmp$pc_get_element (name_list_p^[index], iou_name, ct_element_p, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
                cmp$get_element_state (ct_element_p^.element_name, iou_name, controller_state,
                    ignore_status);
                IF controller_state = cmc$on THEN
                  number_of_on_controllers := number_of_on_controllers + 1;
                ELSEIF controller_state = cmc$down THEN
                  number_of_down_controllers := number_of_down_controllers + 1;
                IFEND;
                IF (controller_state <> state_to_check) THEN
                  /pun_loop/
                  FOR pun := LOWERVALUE (cmt$physical_unit_number) TO
                               UPPERVALUE (cmt$physical_unit_number) DO

  {  NOTE : LOGICAL_UNIT_STATE : denotes the internal state of a tape unit. This
  {        state reflects the state of the upline elements connected to this
  {        unit. For example, the state  of a unit may be ON but since the
  {        channel is DOWN, the internal state is also DOWN.
  {        ACTUAL_NEW_STATE : denotes the new state of a tape unit. This new state
  {        is not necessarely the new state of the element being processed, since
  {        the state of all upline elements must be considered. For example,
  {        changing the state of a CHANNEL to ON will not result in changing the
  {        internal state of the unit to ON if the controller connected to that
  {        channel is DOWN.
  {        RELEASED_UNITS : This is the variable used to stored all the units
  {        that have been processed without error. This variable is scanned to
  {        undo the operation should any errors occur.

                    IF ct_element_p^.controller.connection.unit [pun].configured THEN
                      number_of_units := number_of_units + 1;
                      cmp$get_element_state (
                        ct_element_p^.controller.connection.unit [pun].element_name, iou_name,
                            state, status);
                      IF NOT status.normal THEN
                        EXIT /main_program/;
                      IFEND;
                      cmp$pc_get_element (ct_element_p^.controller.
                        connection.unit [pun].element_name, iou_name, unit_element_p, status);
                      IF NOT status.normal THEN
                        EXIT /main_program/;
                      IFEND;

                      cmp$check_alternate_path (unit_element_p^, ct_element_p^,
                           element_definition.data_channel, alternate_path_active, alternate_access_type,
                           status);
                      IF NOT status.normal THEN
                        EXIT /main_program/;
                      IFEND;
                      IF (NOT alternate_path_active) THEN

                        cmp$get_logical_unit_number (ct_element_p^.controller.connection.unit [pun]
                              .element_name, logical_unit_number, status);
                        IF NOT status.normal THEN
                          EXIT /main_program/;
                        IFEND;

  { Process all units in the ON state.
  { Must take into account the state of the controller or unit and use it to update the
  { state of the unit in the logical unit table.

                        IF (new_state = cmc$on) THEN
                          IF controller_state = cmc$on THEN
                            actual_new_state := state; { Use state of the unit. }
                          ELSE
                            actual_new_state := controller_state;
                          IFEND;
                        ELSE
                          actual_new_state := new_state;
                        IFEND;
                        cmp$get_logical_unit_state (logical_unit_number, cmv$logical_unit_table,
                             logical_unit_state);
                        IF (state <> state_to_check) AND (state <> cmc$off) THEN
                          cmp$change_tape_unit_state (unit_element_p^, current_state, actual_new_state,
                                element_definition, ct_element_p^.controller.physical_equipment_number,
                                controller_type, driver_name, FALSE, logical_unit_number,
                                logical_unit_state, channel_released, status);
                          IF NOT status.normal THEN
                            IF number_of_units > 0 THEN
                              clean_up;
                              EXIT /main_program/;
                            IFEND;
                          IFEND;
                          released_units^[number_of_units].acquired := TRUE;
                          released_units^[number_of_units].pen := ct_element_p^.controller.
                                physical_equipment_number;
                          released_units^[number_of_units].pun := pun;
                          released_units^[number_of_units].lun := logical_unit_number;
                          released_units^[number_of_units].state := state;
                          released_units^[number_of_units].current_state := logical_unit_state;
                          released_units^[number_of_units].new_state := actual_new_state;
                        IFEND;
                        IF ((controller_type = cmc$mt5698_xx) OR (controller_type = cmc$mt5680_xx))
                              AND (NOT redundant_path_available) AND (NOT redundant_path_useable) THEN
                          cmp$zero_out_uit_rma  (logical_unit_number, element_definition,
                                 new_state, status);
                          IF NOT status.normal THEN
                            clean_up;
                            EXIT /main_program/;
                          IFEND;
                        IFEND;
                      IFEND;
                    IFEND;
                  FOREND /pun_loop/;
                IFEND;
              FOREND /for_loop3/;

              IF NOT channel_released THEN
                process_channel := (number_of_on_controllers > 0) OR (number_of_down_controllers > 0);
              ELSE
                process_channel := FALSE;
              IFEND;
              process_pp := number_of_on_controllers > 0;
              process_iou_resources (element_definition, controller_type, process_channel, process_pp,
                       current_state, new_state, driver_name, status);
              IF NOT status.normal THEN
                clean_up;
                EXIT /main_program/;
              IFEND;

              IF redundant_path_available AND redundant_path_useable THEN

  { If the current channel is redundant then turning it on will only cause a state
  { change, there is no need to switch if the primary channel is active.
  { This include 5698 and 5680 tape subsystem where there are redundant channel
  { configured on the controller.

                determine_if_pp_not_active (element_definition.data_channel.number,
                      element_definition.data_channel.port, element_definition.data_channel.concurrent,
                      iou_number, pp_not_active);
                IF NOT pp_not_active OR (new_state <> cmc$on) THEN
                  cmp$switch_tape_channel (element_definition, FALSE {ignore_controller_state},
                       number_of_path, redundant_channel_list^,
                       new_state, redundant_path_pp_list, status);
                IFEND;
              IFEND;

  { Element is a DISK channel.

            ELSEIF (controller_type = cmc$ms7154_x) OR (controller_type = cmc$ms7155_1) OR
                  (controller_type = cmc$ms7155_1x) OR
                  (controller_type = cmc$ms7165_2x) OR (controller_type = cmc$mscm3_ct) OR
                  (controller_type = cmc$mshydra_ct) OR (controller_type = cmc$ms5831_x) OR
                  (controller_type = cmc$ms7255_1_1) OR (controller_type = cmc$ms7255_1_2) THEN

              mass_storage_element := TRUE;
              cmp$get_logical_pp_index (element_definition, logical_pp, ignore_status);

              IF ignore_status.normal THEN { Not a redundant path, PPIT built at deadstart. }
                cmp$change_disk_element_state (element_definition, controller_type,
                       system_critical_element, logical_pp, physical_channel, iou_number,
                       new_state, logical_unit_number, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
              IFEND;
            ELSEIF controller_type = cmc$mp65354_11 THEN
              cmp$change_ext_cpu_state (element_definition, current_state,
                      new_state, controller_type, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
            IFEND;

          = cmc$communications_element, cmc$channel_adapter_element =

            cmp$process_netw_element_state (element_definition, element_descriptor,
                current_state, new_state, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            EXIT /acquire_release_resource/;

          = cmc$controller_element =
            check_for_element_reservation (element_descriptor, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            find_connected_channel (element_definition, channel, equipment_number, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            physical_channel.number := channel.data_channel.number;
            physical_channel.concurrent := channel.data_channel.concurrent;
            physical_channel.port := channel.data_channel.port;
            cmp$convert_iou_name(channel.data_channel.iou, iou_number, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;


            IF (controller_type = cmc$mt7021_3x) OR (controller_type=cmc$mt7021_4x) OR
               (controller_type = cmc$mt698_xx) OR (controller_type = cmc$mt5698_xx) OR
               (controller_type = cmc$mt7221_2_s0) OR (controller_type = cmc$mt7221_1) OR
               (controller_type = cmc$mt5680_xx) THEN

   { See notes on channel_element case.

   { Check to see if DOWN or OFF the primary controller in a redundant configuration.
   { If so attempt to get a PP for the redundant channel if it is not already active.

              IF (cmp$support_redundant_channel (controller_type)) THEN
                cmp$search_redundant_path (element_definition, iou_number, physical_channel,
                       new_state, redundant_path_available,
                       update_controller_address, number_of_path, redundant_channel_list^,
                       redundant_path_pp_list, peripheral_driver_name, redundant_pp_table_rma_list);
                IF redundant_path_available THEN
                  FOR index := 0 TO number_of_path DO
                    determine_if_pp_not_active (redundant_channel_list^ [index].channel.number,
                          redundant_channel_list^ [index].channel.port,
                          redundant_channel_list^ [index].channel.concurrent,
                          redundant_channel_list^ [index].iou, pp_not_active);
                    IF pp_not_active AND (new_state <> cmc$on) THEN
                      cmp$reacquire_resources (dsc$rrt_get_pp, redundant_channel_list^[index].channel,
                         redundant_channel_list^[index].iou, cmc$null_equipment_number, cmc$null_unit_number,
                         peripheral_driver_name, redundant_pp_table_rma_list [index],
                         controller_type, TRUE, status);
                      redundant_path_useable := status.normal;
                      IF NOT acquire_redundant_pp THEN
                        acquire_redundant_pp := status.normal;
                      IFEND;
                    ELSE
                      redundant_path_useable := TRUE;
                    IFEND;
                  FOREND;
                IFEND;
              IFEND;
              count_all_units (element_definition, number_of_units);

              cmp$get_element_state (channel.element_name, channel.data_channel.iou,
                      channel_state, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;

              IF number_of_units > 0 THEN
                PUSH released_units : [1 .. number_of_units];
                FOR pun := 1 TO number_of_units DO
                  released_units^[pun].acquired := FALSE;
                FOREND;
              IFEND;

              number_of_units := 0;
             /pun_loop2/
              FOR pun := LOWERVALUE (cmt$physical_unit_number) TO UPPERVALUE
                     (cmt$physical_unit_number) DO
                IF element_definition.controller.connection.unit [pun].configured THEN
                  number_of_units := number_of_units + 1;
                  cmp$get_element_state (element_definition.
                    controller.connection.unit [pun].element_name, iou_name, state, status);
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;
                  cmp$pc_get_element (element_definition.controller.connection.unit
                     [pun].element_name, iou_name, unit_element_p, status);
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;
                  cmp$check_alternate_path (unit_element_p^, element_definition,
                       channel.data_channel, alternate_path_active, alternate_access_type, status);
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;
                  cmp$get_logical_unit_number (element_definition.controller.connection.unit [pun]
                             .element_name, logical_unit_number, status);
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;

                  IF (NOT alternate_path_active) OR (alternate_access_type = cmc$data_channel_element) THEN

   { Set flag to idle PP so IPI tape subsystem knows about the new units whose UIT RMA has been un-nil.

                    determine_if_pp_not_active (channel.data_channel.number, channel.data_channel.port,
                          channel.data_channel.concurrent, iou_number, pp_not_active);
                    IF ((controller_type = cmc$mt5698_xx) OR (controller_type = cmc$mt5680_xx)) AND
                          (new_state = cmc$on) AND NOT pp_not_active THEN
                      need_to_idle_pp := TRUE;
                    IFEND;

   { Take into account the current state of the channel or unit, when changing
   { the state of the unit to ON, since the channel may be OFF/DOWN.

                    IF new_state = cmc$on THEN
                      IF channel_state = cmc$on THEN
                        actual_new_state := state; { State of unit }
                      ELSE
                        actual_new_state := channel_state;
                      IFEND;
                    ELSE
                      actual_new_state := new_state;
                    IFEND;
                    cmp$get_logical_unit_state (logical_unit_number, cmv$logical_unit_table,
                           logical_unit_state);

                    IF (state <> state_to_check) AND (state <> cmc$off) THEN
                      cmp$change_tape_unit_state (unit_element_p^, current_state, actual_new_state,
                         channel, equipment_number, controller_type, driver_name, FALSE,
                         logical_unit_number, logical_unit_state, channel_released, status);
                      IF NOT status.normal THEN
                        IF number_of_units > 0 THEN
                          clean_up;
                          EXIT /main_program/;
                        IFEND;
                      IFEND;
                      released_units^[number_of_units].acquired := TRUE;
                      released_units^[number_of_units].pen := equipment_number;
                      released_units^[number_of_units].pun := pun;
                      released_units^[number_of_units].lun := logical_unit_number;
                      released_units^[number_of_units].state := state;
                      released_units^[number_of_units].current_state := logical_unit_state;
                      released_units^[number_of_units].new_state := actual_new_state;
                    IFEND;

   { If units are OFF or DOWN and IPI tape subsytem, turning ON the controller should un-nil UIT RMA
   { only and leave unit status as disabled in the Unit Interface Table.

                    IF ((controller_type = cmc$mt5698_xx) OR (controller_type = cmc$mt5680_xx))
                          AND (NOT redundant_path_available) AND (NOT redundant_path_useable) THEN
                      cmp$zero_out_uit_rma (logical_unit_number, channel, new_state, status);
                      IF NOT status.normal THEN
                        clean_up;
                        EXIT /main_program/;
                      IFEND;
                    IFEND;
                  IFEND;
                IFEND;
              FOREND /pun_loop2/;

              process_iou_resources (element_definition, controller_type, process_channel,
                     process_pp, current_state, new_state, driver_name, status);
              IF NOT status.normal THEN
                clean_up;
                EXIT /main_program/;
              IFEND;

              IF redundant_path_available AND redundant_path_useable AND
                    (controller_type = cmc$mt5680_xx) THEN

  { If the current controller is redundant then turning it on will only cause a state
  { change, there is no need to switch if the primary controller is active.

                determine_if_pp_not_active (channel.data_channel.number, channel.data_channel.port,
                      channel.data_channel.concurrent, iou_number, pp_not_active);
                IF NOT pp_not_active OR (new_state <> cmc$on) THEN
                  cmp$switch_tape_channel (channel, TRUE {ignore_controller_state}, number_of_path,
                       redundant_channel_list^, new_state, redundant_path_pp_list, status); { STATUS ignored.
                  need_to_idle_pp := FALSE;  { Reset this flag since PP already IDLE and RESUME at this point.
                IFEND;
             IFEND;

  { Because IPI tape controllers can be configured daisy chain, needs to
  { Idle and Resume the PP to let it know about new units.

              IF need_to_idle_pp THEN
                cmp$idle_pp_r1 (channel.element_name, channel.data_channel.iou, status);
                IF NOT status.normal THEN
                  clean_up;
                  EXIT /main_program/;
                IFEND;
                pp_idled := TRUE;
              IFEND;

              IF pp_idled THEN
                cmp$resume_pp_r1 (channel.element_name, channel.data_channel.iou, status);
                IF NOT status.normal THEN
                  clean_up;
                  EXIT /main_program/;
                IFEND;
              IFEND;
  { Element is disk controller.

            ELSEIF (controller_type = cmc$ms7154_x) OR (controller_type = cmc$ms7155_1) OR
                  (controller_type = cmc$ms7155_1x) OR
                  (controller_type = cmc$ms7165_2x) OR (controller_type = cmc$mscm3_ct) OR
                  (controller_type = cmc$mshydra_ct) OR (controller_type = cmc$ms5831_x) OR
                  (controller_type = cmc$ms7255_1_1) OR (controller_type = cmc$ms7255_1_2) THEN

              mass_storage_element := TRUE;
              cmp$get_logical_pp_index (channel, logical_pp, ignore_status);

              IF ignore_status.normal THEN { PPIT built at deadstart. }
                cmp$change_disk_element_state (element_definition, controller_type,
                    system_critical_element, logical_pp, physical_channel, iou_number,
                    new_state, logical_unit_number, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
              IFEND;
            IFEND;

          = cmc$storage_device_element =
            check_for_element_reservation (element_descriptor, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            find_connected_channel (element_definition, channel, equipment_number, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            physical_channel.number := channel.data_channel.number;
            physical_channel.concurrent := channel.data_channel.concurrent;
            physical_channel.port := channel.data_channel.port;
            cmp$convert_iou_name(channel.data_channel.iou, iou_number, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            cmp$get_element_state (channel.element_name, channel.data_channel.iou,
                     channel_state, ignore_status);
            cmp$get_element_state (channel.data_channel.connection.equipment [equipment_number].
                     element_name, channel.data_channel.iou, controller_state, ignore_status);

            cmp$get_unit_type (element_definition.product_id,
              cm_unit_type, io_unit_type, unit_class, found);
            IF found THEN
              IF unit_class = cmc$magnetic_tape_unit THEN
                cmp$get_logical_unit_number (element_definition.element_name,
                         logical_unit_number, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;

                cmp$get_logical_unit_state (logical_unit_number, cmv$logical_unit_table,
                             logical_unit_state);

    { Only Return/acquire equipment and update internal logical state if both channel and
    { controller are currently ON.

                IF((channel_state = cmc$on) AND (controller_state = cmc$on)) OR
                       ((new_state <> cmc$on) AND (logical_unit_state <> cmc$off)) THEN
                  cmp$change_tape_unit_state (element_definition, current_state,
                    new_state, channel, equipment_number, controller_type, driver_name, system_call,
                       logical_unit_number, logical_unit_state, channel_released, status);
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;
                ELSEIF (current_state = cmc$off) AND ((channel_state <> cmc$on) OR
                          (controller_state <> cmc$on)) THEN

   {
   { Get the unit only if needed, i.e if the path to the unit is not already OFF/DOWN.
   {
                  IF (logical_unit_state <> cmc$on) THEN

  {
  {   Get the unit and update the stt and logical unit state to be the channel
  {   or controller state.
  {
                    IF channel_state <> cmc$on THEN
                      state := channel_state;
                    ELSEIF controller_state <> cmc$on THEN
                      state := controller_state;
                    ELSE
                      state := cmc$down;
                    IFEND;
                    cmp$change_tape_unit_state (element_definition, current_state,
                       {new state} state, channel, equipment_number, controller_type, driver_name,
                       system_call, logical_unit_number, logical_unit_state, channel_released, status);
                    IF NOT status.normal THEN
                      EXIT /main_program/;
                    IFEND;
                  IFEND;
                IFEND;
              ELSEIF unit_class = cmc$mass_storage_unit THEN
                cmp$get_logical_pp_index (channel, logical_pp, ignore_status);
                mass_storage_element := TRUE;

                cmp$change_disk_element_state (element_definition, controller_type, system_critical_element,
                      logical_pp, physical_channel, iou_number, new_state, logical_unit_number, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
              IFEND;
            IFEND;

          = cmc$external_processor_element =

            FOR pen := LOWERVALUE(cmt$physical_equipment_number) TO
                   UPPERVALUE(cmt$physical_equipment_number) DO
               IF element_definition.external_processor.connection.io_port [pen].configured THEN
                 cmp$pc_get_element (element_definition.external_processor.
                      connection.io_port [pen].element_name, element_definition.external_processor
                     .connection.io_port [pen].iou, ct_element_p, status);
                 IF NOT status.normal THEN
                   EXIT /main_program/;
                 IFEND;
                 cmp$change_ext_cpu_state (ct_element_p^, current_state,
                        new_state, controller_type, status);
                 IF NOT status.normal THEN
                   EXIT /main_program/;
                 IFEND;
               IFEND;
            FOREND;
          ELSE
             ;

          CASEND;

        END /acquire_release_resource/;

  { Update state table and state info device file. }

        IF element_definition.element_type = cmc$data_channel_element THEN
          iou_name := element_definition.data_channel.iou;
        IFEND;

        cmp$change_state_info_table (element_definition.element_name, iou_name, new_state, status);
        IF NOT status.normal THEN
          osp$set_status_condition ( cme$jtd_state_not_retained
                ,  save_status);
          status.normal := TRUE;
        IFEND;

        IF element_definition.element_type <> cmc$data_channel_element THEN
          cmp$update_pcu_state_info (element_definition.element_name, new_state, status);
          IF NOT status.normal THEN
            osp$set_status_condition ( cme$jtd_state_not_retained
                ,  save_status);
            status.normal := TRUE;
          IFEND;
        IFEND;
         {
         { IF maintenance  job then call Device Management to activate all volumes
         {
         IF (caller_id.ring <=6) AND (NOT system_call) AND (new_state = cmc$on)
                 AND mass_storage_element THEN
           cmp$get_volumes_active (ignore_status);
         IFEND;

        {
        { Call interface to update all connection status for elements
        { that are affected by this state change.
        {
        pmp$get_mainframe_id (mainframe_id, ignore_status);
        cmp$change_connection_status_r1 (element_definition, mainframe_id, save_status);

        IF element_definition.element_type = cmc$data_channel_element THEN
          critical_msg (1, 6) := element_definition.data_channel.iou;
          msg_size := 6;
          critical_msg (7, *) := element_definition.element_name;
          logging_data.element_name (1,4) := element_definition.data_channel.iou (1,4);
          logging_data.element_name (5) := '/';
          logging_data.element_name (6,*) := element_definition.element_name;
          logging_data.serial_number := 'N/A';
          cmp$convert_channel_type (element_definition.data_channel.kind, channel_type);
          logging_data.product_id.product_number := ' ';
          logging_data.product_id.product_number (1, 3) := channel_type (1, 3);
          logging_data.product_id.underscore := ' ';
          logging_data.product_id.model_number := ' ';
        ELSE
          logging_data.element_name := element_definition.element_name;
          logging_data.product_id := element_definition.product_id;
          logging_data.serial_number := element_definition.serial_number;
          msg_size := 0;
          critical_msg (1, *) := element_definition.element_name;
        IFEND;

        REPEAT
          msg_size := msg_size + 1;
        UNTIL critical_msg (msg_size, 1) = ' ';

        logging_data.old_state := current_state;
        logging_data.new_state := new_state;
        IF system_call THEN
          logging_data.initiator := 'fail';
        ELSEIF (avp$configuration_administrator () OR avp$system_operator () OR
                avp$removable_media_operator ())
             THEN
          logging_data.initiator := 'op';
        ELSEIF (caller_id.ring <= 6) THEN
          logging_data.initiator := 'ce';
        IFEND;
        log_data_ptr := #SEQ (logging_data);
        dsp$log_system_message (cml$element_state_change, log_data_ptr, status);

  { Put message to the critical window of the NOS/VE System Console. }

        critical_msg (msg_size, 19) := ' STATE CHANGED FROM';
        msg_size := msg_size + 19;

        CASE current_state OF
        = cmc$on =
          critical_msg (msg_size, 5) := ' ON  ';
        = cmc$off =
          critical_msg (msg_size, 5) := ' OFF ';
        = cmc$down =
          critical_msg (msg_size, 5) := ' DOWN';
        ELSE
        CASEND;
        msg_size := msg_size + 5;

        critical_msg (msg_size, 3) := ' TO';
        msg_size := msg_size + 3;

        CASE new_state OF
        = cmc$on =
          critical_msg (msg_size, 6) := ' ON   ';
        = cmc$off =
          critical_msg (msg_size, 6) := ' OFF  ';
        = cmc$down =
          critical_msg (msg_size, 6) := ' DOWN ';
        ELSE
        CASEND;
        msg_size := msg_size + 6;

        IF system_call THEN
          dpp$put_critical_message (critical_msg, ignore_status);
          critical_msg (1, 64) := 'Initiated by NOS/VE due to element failure.                     ';
          dpp$put_critical_message (critical_msg, ignore_status);
        ELSEIF (caller_id.ring <= 6) THEN
          dpp$put_critical_message (critical_msg, ignore_status);
          critical_msg (1, 31) := 'Initiated by job : ';
          critical_msg (32, 19) := system_supplied_name;
          critical_msg (51, 14) := '              ';
          dpp$put_critical_message (critical_msg, ignore_status);
        IFEND;

        IF NOT clear_lock_behind THEN
          outstanding_request := FALSE;
        ELSE
          IF ca_lock_set THEN
            cmp$manage_lcu_lock (cmc$configuration_administrator, TRUE,
               system_supplied_name, ignore_status);
            ca_lock_set := NOT ignore_status.normal;
          IFEND;

          IF rmo_lock_set THEN
            cmp$manage_lcu_lock (cmc$removable_media_operation, TRUE,
               system_supplied_name, ignore_status);
            rmo_lock_set := NOT ignore_status.normal;
          IFEND;

          cmp$find_state_change_request (outstanding_request, element, new_state, current_state);
          IF outstanding_request THEN
            system_call := TRUE;
            cmp$determine_tape_element (element, tape_subsystem);
          IFEND;
        IFEND;
      UNTIL (outstanding_request = FALSE);

   END /main_program/;
   IF NOT save_status.normal THEN
     status := save_status;
   IFEND;
   IF clear_lock_behind THEN
     IF ca_lock_set THEN
       cmp$manage_lcu_lock (cmc$configuration_administrator, TRUE,
               system_supplied_name, ignore_status);
     IFEND;
     IF rmo_lock_set THEN
       cmp$manage_lcu_lock (cmc$removable_media_operation, TRUE,
               system_supplied_name, ignore_status);
     IFEND;
   IFEND;

 PROCEND cmp$process_state_change;

?? TITLE := '  cmp$process_netw_element_state ', EJECT ??

  PROCEDURE cmp$process_netw_element_state (element_definition : cmt$element_definition;
         element_descriptor : cmt$element_descriptor;
         current_state : cmt$element_state;
         new_state : cmt$element_state;
     VAR status : ost$status);

     VAR
       state : cmt$element_state,
       mainframe_id: pmt$mainframe_id,
       iou_name : cmt$element_name,
       ignore_status : ost$status,
       peripheral_index : integer,
       element_reservation : cmt$element_reservation,
       comm_port : cmt$communications_port_number;

{ PURPOSE: This procedure change the state of communications and
{   channel adapter elements.

     status.normal := TRUE;
   /main_program/
     BEGIN
       pmp$get_mainframe_id (mainframe_id, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       IF element_definition.element_type = cmc$communications_element THEN
         IF (element_definition.product_id.product_number = ' $2620') OR
             (element_definition.product_id.product_number = ' $4000') OR
             (element_definition.product_id.product_number = ' $2621') THEN

           { Check states of MDI/MTI/EXPRESSLINK channel and device before call NAM/VE. }

           /communications_loop/
           FOR comm_port := LOWERVALUE (cmt$communications_port_number) TO
                              UPPERVALUE (cmt$communications_port_number) DO
             IF (element_definition.communications_element.connection.port [comm_port].configured) AND
                 (element_definition.communications_element.connection.port [comm_port].mainframe_ownership
                  = mainframe_id) THEN
               cmp$get_element_state (element_definition.
                 communications_element.connection.port [comm_port].element_name,
                 element_definition.communications_element.connection.port [comm_port].iou,
                 state, status);
               IF NOT status.normal THEN
                 EXIT /main_program/;
               IFEND;
               EXIT /communications_loop/;
             IFEND;
           FOREND /communications_loop/;

           IF current_state = cmc$on THEN
             IF state = cmc$on THEN
               nap$change_network_device_state (
                 element_definition.element_name, new_state, current_state, status);
               IF NOT status.normal THEN
                 osp$generate_log_message (
                   $pmt$ascii_logset [pmc$job_log, pmc$system_log], status, ignore_status);
                 EXIT /main_program/;
               IFEND;
             IFEND;
           ELSE
             IF state = cmc$on THEN
               IF new_state = cmc$on THEN

                 { Turn ON MDI/MTI/EXPRESSLINK for NAM/VE to reserve it. }

                 cmp$change_state_info_table (element_definition.element_name,iou_name, new_state, status);
                 IF NOT status.normal THEN
                   EXIT /main_program/;
                 IFEND;

                 nap$change_network_device_state (
                   element_definition.element_name, new_state, current_state, status);
                 IF NOT status.normal THEN
                   osp$generate_log_message (
                     $pmt$ascii_logset [pmc$job_log, pmc$system_log], status, ignore_status);
                   ignore_status.normal := TRUE;
                   cmp$change_state_info_table (
                     element_definition.element_name, iou_name, current_state, ignore_status);
                   EXIT /main_program/;
                 IFEND;
               IFEND;
             IFEND;
           IFEND;

         ELSE

           { For communication elements other than MDI/MTI/EXPRESSLINK. }
           { For File Server element, will need to call dfp$ interface

           check_for_element_reservation (element_descriptor, status);
           IF NOT status.normal THEN
             EXIT /main_program/;
           IFEND;
         IFEND;

       ELSEIF element_definition.element_type = cmc$channel_adapter_element THEN
         IF element_definition.product_id.product_number = ' $2629' THEN

           { Check states of ICA channel and ICA before call NAM/VE. }

           IF element_definition.channel_adapter.connection.channel.configured THEN
             cmp$get_element_state (element_definition.
               channel_adapter.connection.channel.element_name,
               element_definition.channel_adapter.connection.channel.iou, state,
                 status);
             IF NOT status.normal THEN
               EXIT /main_program/;
             IFEND;
           IFEND;

           IF current_state = cmc$on THEN
             IF state = cmc$on THEN
               nap$change_network_device_state (
                 element_definition.element_name, new_state, current_state, status);
               IF NOT status.normal THEN
                 osp$generate_log_message (
                   $pmt$ascii_logset [pmc$job_log, pmc$system_log], status, ignore_status);
                 EXIT /main_program/;
               IFEND;
             IFEND;
           ELSE
             IF state = cmc$on THEN
               IF new_state = cmc$on THEN
                 { Turn ON ICA for NAM/VE to reserve it. }

                 cmp$change_state_info_table (element_definition.element_name, iou_name,new_state, status);
                 IF NOT status.normal THEN
                   EXIT /main_program/;
                 IFEND;

                 nap$change_network_device_state (
                   element_definition.element_name, new_state, current_state, status);
                 IF NOT status.normal THEN
                   osp$generate_log_message (
                     $pmt$ascii_logset [pmc$job_log, pmc$system_log], status, ignore_status);
                   ignore_status.normal := TRUE;
                   cmp$change_state_info_table (
                     element_definition.element_name, iou_name, current_state, ignore_status);
                   EXIT /main_program/;
                 IFEND;
               IFEND;
             IFEND;
           IFEND;
         IFEND;
       IFEND;
    END /main_program/;

  PROCEND cmp$process_netw_element_state;

?? TITLE := ' cmp$return_desc_data_by_lun_lpn', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$return_desc_data_by_lun_lpn (
      logical_unit_number : iot$logical_unit;
      logical_pp_number : iot$pp_number;
    VAR iou_number : dst$iou_number;
    VAR descriptor_data: ost$string;
    VAR physical_pp_number: 0 .. 31);

    PROCEDURE [INLINE] append_string_data (string_data: string ( * <= 31));
      descriptor_data.value (index, * ) := string_data;
      WHILE (descriptor_data.value (index, 1) <> ' ') DO
        index := index + 1;
      WHILEND;
    PROCEND append_string_data;

    VAR
      compn : cmt$communications_port_number,
      concurrent: boolean,
      pp_string: string (10),
      length,
      index : integer,
      status : ost$status,
      mainframe_element,
      channel_element : ^cmt$element_definition,
      mainframe_id : pmt$mainframe_id,
      mainframe_name,
      iou_name,
      channel_name,
      element_name : cmt$element_name;
{
{ PURPOSE:  This routine return a string containing physical pp number,
{    channel, iou, mainframe and element name given the logical unit
{    number and the logical pp number.
{
{ NOTE: This routine is mainly called by NAM/VE, RHFAM and any of the
{    users of cmp$reserve_element, cmp$execute_pp_program.
{

    PUSH mainframe_element;
    PUSH channel_element;
    descriptor_data.value := ' ';
    descriptor_data.size := 0;
    cmp$pc_get_logical_unit (logical_unit_number, mainframe_element, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    element_name := mainframe_element ^.element_name;
    pmp$get_mainframe_id (mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE mainframe_element ^.element_type OF
    = cmc$channel_adapter_element =
      IF (mainframe_element^.channel_adapter.connection.channel.configured) AND
         (mainframe_element^.channel_adapter.connection.channel.mainframe_ownership =
               mainframe_id) THEN
        channel_name := mainframe_element ^.channel_adapter.connection.channel.element_name;
        mainframe_name := mainframe_element ^.channel_adapter.connection.channel.mainframe_ownership;
        iou_name := mainframe_element^ .channel_adapter.connection.channel.iou;
        cmp$pc_get_element (channel_name,iou_name, channel_element, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        cmp$convert_iou_name (iou_name, iou_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        physical_pp_number := cmv$logical_pp_table_p^ [logical_pp_number].pp_info.physical_pp.number;
        pp_string := '      ';
        STRINGREP (pp_string, length, physical_pp_number);
        index := 1;
        append_string_data (mainframe_name);
        append_string_data ('. ');
        append_string_data (iou_name);
        IF cmv$logical_pp_table_p^ [logical_pp_number].pp_info.physical_pp.channel_protocol = dsc$cpt_nio THEN
          append_string_data ('.PP ');
        ELSE { cio pp
          append_string_data ('.CPP ');
        IFEND;
        append_string_data (pp_string (2, * ));
        append_string_data ('. ');
        append_string_data (channel_name);
        append_string_data ('. ');
        append_string_data (element_name);
        descriptor_data.size := index - 1;
      IFEND;

    = cmc$communications_element =
      /communications_loop/
      FOR compn := LOWERVALUE (compn) TO UPPERVALUE (compn) DO
        IF (mainframe_element ^.communications_element.connection.port [compn].configured) AND
           (mainframe_element^.communications_element.connection.port[compn].mainframe_ownership =
               mainframe_id) THEN
          channel_name :=
            mainframe_element ^.communications_element.connection.port [compn].element_name;
          mainframe_name :=
            mainframe_element ^.communications_element.connection.port [compn].mainframe_ownership;
          iou_name := mainframe_element^ .communications_element.connection.port [compn].iou;
          cmp$pc_get_element (channel_name,iou_name, channel_element, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          cmp$convert_iou_name (iou_name, iou_number, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Ensure channel is the one that is currently being used by this logical PP.

          IF cmv$logical_pp_table_p^ [logical_pp_number].flags.reservd_by_other_has_ch_present THEN
            concurrent := (cmv$logical_pp_table_p^ [logical_pp_number].pp_info.channel.channel_protocol =
                  dsc$cpt_cio);
            IF NOT ((channel_element^.data_channel.number =
                  cmv$logical_pp_table_p^ [logical_pp_number].pp_info.channel.number) AND
                  (channel_element^.data_channel.concurrent = concurrent) AND
                  (iou_number =
                  cmv$logical_pp_table_p^ [logical_pp_number].pp_info.channel.iou_number)) THEN
              CYCLE /communications_loop/;
            IFEND;
          IFEND;

          physical_pp_number := cmv$logical_pp_table_p^ [logical_pp_number].pp_info.physical_pp.number;
          pp_string := '      ';
          STRINGREP (pp_string, length, physical_pp_number);
          index := 1;
          append_string_data (mainframe_name);
          append_string_data ('. ');
          append_string_data (iou_name);
          IF cmv$logical_pp_table_p^ [logical_pp_number].pp_info.physical_pp.channel_protocol =
                dsc$cpt_nio THEN
            append_string_data ('.PP ');
          ELSE { cio pp
            append_string_data ('.CPP ');
          IFEND;
          append_string_data (pp_string (2, * ));
          append_string_data ('. ');
          append_string_data (channel_name);
          append_string_data ('. ');
          append_string_data (element_name);
          descriptor_data.size := index - 1;
          EXIT /communications_loop/;
        IFEND;
      FOREND /communications_loop/;
    ELSE
      ;
    CASEND;
  PROCEND cmp$return_desc_data_by_lun_lpn;
?? TITLE := '  cmp$return_logical_pp_number ', EJECT ??

{ PURPOSE:
{   This procedure returns the logical pp number associated with a channel. It provides a ring 11 user to
{   retrieve this information by calling a ring 1 routine.

  PROCEDURE [XDCL, #GATE] cmp$return_logical_pp_number
    (    channel: cmt$element_name;
         iou: cmt$element_name;
     VAR logical_pp: iot$pp_number;
     VAR status: ost$status);

   VAR
     channel_p : ^cmt$element_definition;

   status.normal := TRUE;
   cmp$pc_get_element (channel, iou, channel_p, status);
   IF NOT status.normal THEN
     RETURN;
   IFEND;

   cmp$get_logical_pp_index (channel_p^, logical_pp, status);

  PROCEND cmp$return_logical_pp_number;
?? TITLE := ' cmp$retrieve_element_info',EJECT ??

   { PURPOSE: This procedure retrieve information about the controller
   {   and peripheral driver name of an element.

  PROCEDURE cmp$retrieve_element_info
    (    element_definition: cmt$element_definition;
     VAR driver_name: pmt$program_name;
     VAR controller_type: cmt$controller_type;
     VAR status: ost$status);

      VAR
        data_storage_index : cmt$data_storage_port_number,
        element_def: ^cmt$element_definition,
        iou_name : cmt$element_name,
        ignore_status : ost$status,
        mainframe_id : pmt$mainframe_id,
        mf_element : ^cmt$element_definition,
        pen : cmt$physical_equipment_number,
        port : cmt$controller_port_number,
        pun : cmt$physical_equipment_number,
        unit_element: ^cmt$element_definition;


        status.normal := TRUE;
        pmp$get_mainframe_id (mainframe_id, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      /main_program/
         BEGIN

      { Validate element type and get full physical path. }

        CASE element_definition.element_type OF

        = cmc$data_channel_element =

 { ignore_status is used if PPIT is not built at deadstart }

        /for_loop1/
          FOR pen := LOWERVALUE (cmt$physical_equipment_number) TO UPPERVALUE
                       (cmt$physical_equipment_number) DO
            IF (element_definition.data_channel.connection.equipment [pen].configured) THEN
              cmp$pc_get_element (element_definition.data_channel.connection.equipment
                    [pen].element_name, iou_name, mf_element, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              EXIT /for_loop1/;
            IFEND;
          FOREND /for_loop1/;

          IF mf_element^.element_type = cmc$external_processor_element THEN
            driver_name := mf_element^.external_processor.peripheral_driver_name;
          ELSEIF mf_element^.element_type = cmc$controller_element THEN
            driver_name := mf_element^.controller.peripheral_driver_name;
          ELSEIF mf_element^.element_type = cmc$storage_device_element THEN
            IF mf_element ^.product_id.product_number = '  $887' THEN
              controller_type := cmc$mshydra_ct;
              EXIT /main_program/;
            IFEND;
          ELSEIF mf_element^.element_type = cmc$communications_element THEN
            driver_name := mf_element^.communications_element.peripheral_driver_name;
          ELSEIF mf_element^.element_type = cmc$channel_adapter_element THEN
            driver_name := mf_element^.channel_adapter.peripheral_driver_name;
          IFEND;
          cmp$get_controller_type (mf_element^.product_id, controller_type, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

        = cmc$channel_adapter_element, cmc$communications_element =
              ;
        = cmc$controller_element =
          driver_name := element_definition.controller.peripheral_driver_name;
          cmp$get_controller_type (element_definition.product_id, controller_type, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

        = cmc$storage_device_element =
          FOR data_storage_index := LOWERVALUE (cmt$data_storage_port_number) TO
                UPPERVALUE (cmt$data_storage_port_number) DO
            IF element_definition.storage_device.connection.port [data_storage_index].configured THEN
              IF element_definition.storage_device.connection.port [data_storage_index].
                   upline_connection_type = cmc$data_channel_element THEN
                iou_name := element_definition.storage_device.connection.port [data_storage_index]
                       .iou;
              IFEND;
              cmp$pc_get_element (element_definition.storage_device.connection.port
                [data_storage_index].element_name, iou_name, mf_element, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;

              IF element_definition.product_id.product_number = '  $887' THEN
                driver_name := 'E9S887';
                controller_type := cmc$mshydra_ct;
                EXIT /main_program/;
              IFEND;

              driver_name := mf_element^.controller.peripheral_driver_name;
              cmp$get_controller_type (mf_element^.product_id,
                         controller_type, status);
              EXIT /main_program/;
            IFEND;
          FOREND;
        = cmc$external_processor_element =
          cmp$get_controller_type (element_definition.product_id, controller_type,
              status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
          driver_name := element_definition.external_processor.peripheral_driver_name;
        ELSE
          osp$set_status_abnormal (cmc$configuration_management_id, cme$jtd_invalid_state_change,
               'State change unsupported for this type of element.', status);
          EXIT /main_program/;

        CASEND;

      END /main_program/;


  PROCEND cmp$retrieve_element_info;
?? TITLE := 'determine_if_pp_not_active', EJECT ??

{ PURPOSE:
{   This procedure determines whether or not a PP is currently assigned to a given channel.

  PROCEDURE determine_if_pp_not_active
    (    number: ost$physical_channel_number;
         port: cmt$channel_port;
         concurrent: boolean;
         iou_number: dst$iou_number;
     VAR pp_not_active: boolean);

    VAR
      channel: cmt$physical_channel,
      local_status: ost$status,
      logical_pp_index: iot$pp_number,
      partner_pp_index: iot$pp_number;

    pp_not_active := FALSE;
    channel.number := number;
    channel.port := port;
    channel.concurrent := concurrent;
    cmp$retrieve_logical_pp_index (channel, iou_number, cmv$logical_pp_table_p, logical_pp_index,
          local_status);
    IF local_status.normal THEN
      partner_pp_index := cmv$logical_pp_table_p^ [logical_pp_index].pp_info.logical_partner_pp_index;
      IF partner_pp_index > 0 THEN
        pp_not_active := NOT cmv$logical_pp_table_p^ [logical_pp_index].flags.resources_acquired AND
              NOT cmv$logical_pp_table_p^ [partner_pp_index].flags.resources_acquired;
      ELSE
        pp_not_active := NOT cmv$logical_pp_table_p^ [logical_pp_index].flags.resources_acquired;
      IFEND;
    IFEND;

  PROCEND determine_if_pp_not_active;
?? TITLE := ' cmp$unactive_path',EJECT ??

 { PURPOSE : This procedure retrieve information necessary to release PP
 {   for active disk channels.

  PROCEDURE cmp$unactive_path (
        element_definition : cmt$element_definition;
    VAR pp_released : ARRAY [cmt$controller_port_number] OF pps_released_info;
    VAR status : ost$status);

      VAR
        channel_definition : ^cmt$element_definition,
        channel_name: cmt$element_name,
        channel_state : cmt$element_state,
        controller_type : cmt$controller_type,
        count: 0 .. 3,
        equipment_state : cmt$element_state,
        found: boolean,
        ignore_status : ost$status,
        iou_name : cmt$element_name,
        iou_number : dst$iou_number,
        logical_pp : iot$pp_number,
        loop_count : 0 .. 2,
        mainframe_id : pmt$mainframe_id,
        minus_one : integer,
        physical_channel : cmt$physical_channel,
        pp : integer,
        pen : integer,
        port : integer,
        port_used: char,
        redundant : boolean,
        string_index : 0 .. osc$max_name_size,
        temp_channel_p: ^cmt$element_definition;

      status.normal := TRUE;

      FOR port := LOWERVALUE (cmt$controller_port_number) TO
                    UPPERVALUE (cmt$controller_port_number) DO
        pp_released [port].released := FALSE;
        FOR pp := 1 TO 2 DO
          pp_released [port].logical_pp [pp] := 0;
        FOREND;
      FOREND;
      pmp$get_mainframe_id (mainframe_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      CASE element_definition.element_type OF
      = cmc$controller_element =
        cmp$get_controller_type (element_definition.product_id, controller_type, ignore_status);
        /channel_loop/
        FOR port := LOWERVALUE (cmt$controller_port_number) TO
                      UPPERVALUE (cmt$controller_port_number) DO
          IF (element_definition.controller.connection.port [port].configured) AND
                 (element_definition.controller.connection.port [port].mainframe_ownership
                  = mainframe_id) THEN
            cmp$get_element_state (element_definition.
              controller.connection.port [port].element_name,
                   element_definition.controller.connection.port [port].iou, channel_state, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF channel_state = cmc$on THEN
              cmp$pc_get_element (element_definition.controller.
                connection.port [port].element_name, element_definition.controller.
                 connection.port [port].iou, channel_definition, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              IF (channel_definition^.data_channel.concurrent) AND
                       (channel_definition^.data_channel.port <> cmc$unspecified_port) THEN
                loop_count := 2;
              ELSE
                loop_count := 1;
              IFEND;

              { Check if no controllers are ON. Take into account CIO channel with port.

              iou_name := channel_definition^.data_channel.iou;
              count := 0;
              REPEAT

                FOR pen := LOWERVALUE (cmt$physical_equipment_number) TO
                             UPPERVALUE (cmt$physical_equipment_number) DO
                  IF channel_definition ^.data_channel.connection.equipment [pen].configured THEN

                  { State of controller not updated in cmv$state_table_info yet.

                    IF channel_definition ^.data_channel.connection.
                          equipment [pen].element_name <> element_definition.element_name THEN
                      cmp$get_element_state (channel_definition ^.data_channel.
                          connection.equipment [pen].element_name, iou_name, equipment_state, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;
                      IF equipment_state = cmc$on THEN
                        CYCLE /channel_loop/;
                      IFEND;
                    IFEND;
                  IFEND;
                FOREND;

 { If a CIO channel port is configured, make sure the other channel port is not configured
 { to other controllers.

                count := count + 1;
                IF (loop_count > 1) AND (count <> loop_count) THEN
                  channel_name := channel_definition^.element_name;
                  IF channel_definition^.data_channel.port = cmc$port_a THEN
                    port_used := 'B';
                  ELSEIF channel_definition^.data_channel.port = cmc$port_b THEN
                    port_used := 'A';
                  IFEND;
                  string_index := 0;
                  found := FALSE;
                  WHILE (NOT found) AND (string_index <= osc$max_name_size) DO
                    string_index := string_index + 1;
                    found := (channel_name (string_index, 1) = 'A') OR
                                  (channel_name (string_index, 1) = 'B');
                  WHILEND;
                  channel_name (string_index, 1) := port_used;
                  cmp$pc_get_element (channel_name, iou_name, temp_channel_p, ignore_status);
                  IF NOT ignore_status.normal THEN
                    count := count + 1;
                  ELSE
                    channel_definition := temp_channel_p;
                  IFEND;
                IFEND;
              UNTIL (count = loop_count);
              cmp$convert_iou_name (channel_definition^.data_channel.iou, iou_number, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              physical_channel.number := channel_definition^.data_channel.number;
              physical_channel.concurrent := channel_definition^.data_channel.concurrent;
              physical_channel.port := channel_definition^.data_channel.port;

 { Do not count PP and Channel in the case of multiple controller daisy chained
 { to one channel.

              IF (cmp$support_redundant_channel (controller_type)) AND (controller_type
                    <> cmc$mt5680_xx) THEN
                cmp$determine_redundant_channel (physical_channel, iou_number,
                   {ignore_state=}TRUE, redundant, ignore_status);
                IF redundant THEN
                  CYCLE /channel_loop/;
                IFEND;
              IFEND;
              cmp$get_logical_pp_index (channel_definition ^, logical_pp, status);

              IF status.normal THEN
                IF port > LOWERVALUE (cmt$controller_port_number) THEN
                  FOR minus_one := LOWERVALUE (cmt$controller_port_number) TO port - 1 DO
                    IF pp_released [minus_one].released THEN

                      IF logical_pp = pp_released [minus_one].logical_pp [1] THEN

                        { Do not release PP for CCH#(A or B) again.

                        CYCLE /channel_loop/;

                      IFEND;
                    IFEND;
                  FOREND;
                IFEND;
                pp_released [port].released := TRUE;
                pp_released [port].iou := iou_number;
                pp_released [port].channel.number := channel_definition ^.data_channel.number;
                pp_released [port].channel.concurrent := channel_definition ^.data_channel.concurrent;
                pp_released [port].channel.port := channel_definition ^.data_channel.port;
                pp_released [port].channel_name := channel_definition ^.element_name;
                pp_released [port].logical_pp [1] := logical_pp;
                IF cmv$logical_pp_table_p^ [pp_released [port].logical_pp [1]].
                      pp_info.logical_partner_pp_index > 0 THEN
                  pp_released [port].logical_pp [2] :=
                        cmv$logical_pp_table_p^ [pp_released [port].logical_pp [1]].
                        pp_info.logical_partner_pp_index;
                IFEND;
              ELSE
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        FOREND /channel_loop/;

      ELSE
        ;
      CASEND;

    PROCEND cmp$unactive_path;

?? TITLE := '  check_for_element_reservation', EJECT ??

  PROCEDURE [INLINE] check_for_element_reservation
    (    element_descriptor: cmt$element_descriptor;
     VAR status: ost$status);

    VAR
      element_reservation: cmt$element_reservation,
      peripheral_index: integer;

    status.normal := TRUE;

    cmp$search_peripheral_table (element_descriptor, element_reservation, FALSE, peripheral_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (cmv$peripheral_element_table.pointer^ [peripheral_index].entry_interlock) THEN
      IF element_descriptor.element_type = cmc$data_channel_element THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$element_already_reserved,
              element_descriptor.channel_descriptor.name, status);
      ELSE
        osp$set_status_abnormal (cmc$configuration_management_id, cme$element_already_reserved,
              element_descriptor.peripheral_descriptor.element_name, status);
      IFEND;
      osp$append_status_parameter (osc$status_parameter_delimiter, cmv$peripheral_element_table.
            pointer^ [peripheral_index].reserved_job, status);
      RETURN;
    IFEND;
    IF cmp$dedicated_maint_active (peripheral_index) THEN
      IF element_descriptor.element_type = cmc$data_channel_element THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$element_already_reserved,
              element_descriptor.channel_descriptor.name, status);
      ELSE
        osp$set_status_abnormal (cmc$configuration_management_id, cme$element_already_reserved,
              element_descriptor.peripheral_descriptor.element_name, status);
      IFEND;
      osp$append_status_parameter (osc$status_parameter_delimiter, cmv$peripheral_element_table.
            pointer^ [peripheral_index].maintenance_activity.dedicated_accessor.job_identification, status);
      RETURN;
    IFEND;
  PROCEND check_for_element_reservation;

?? TITLE := '  count_all_units', EJECT ??

{ PURPOSE : This procedure goes through all the downline connections
{   of a channel or controller and counts the total number of units
{   configured.

  PROCEDURE count_all_units
    (    element_definition: cmt$element_definition;
     VAR number_of_units: integer);

    VAR
      controller_element_p: ^cmt$element_definition,
      ignore_status: ost$status,
      index: integer,
      iou_name: cmt$element_name,
      name_list_p: ^array [ * ] of cmt$element_name,
      number_of_entries: integer,
      pun: cmt$physical_unit_number;

    number_of_units := 0;
    IF element_definition.element_type = cmc$data_channel_element THEN
      PUSH name_list_p: [1 .. 2 * (UPPERVALUE (cmt$physical_equipment_number) + 1)];
      cmp$get_connected_elements (element_definition, name_list_p, number_of_entries, ignore_status);

      FOR index := 1 TO number_of_entries DO
        cmp$pc_get_element (name_list_p^ [index], iou_name, controller_element_p, ignore_status);
        IF ignore_status.normal THEN
          IF controller_element_p^.element_type = cmc$controller_element THEN
            FOR pun := LOWERVALUE (cmt$physical_unit_number) TO UPPERVALUE (cmt$physical_unit_number) DO
              IF controller_element_p^.controller.connection.unit [pun].configured THEN
                number_of_units := number_of_units + 1;
              IFEND;
            FOREND;
          ELSEIF controller_element_p^.element_type = cmc$storage_device_element THEN
            number_of_units := number_of_units + 1;
          IFEND;
        IFEND;
      FOREND;
    ELSEIF element_definition.element_type = cmc$controller_element THEN
      FOR pun := LOWERVALUE (cmt$physical_unit_number) TO UPPERVALUE (cmt$physical_unit_number) DO
        IF element_definition.controller.connection.unit [pun].configured THEN
          number_of_units := number_of_units + 1;
        IFEND;
      FOREND;
    IFEND;

  PROCEND count_all_units;

?? TITLE := '    find_connected_channel', EJECT ??

{ PURPOSE : This procedure will return the active channel and controller
{   for the specified element.  The element is assumed to be either a
{   controller or a mass storage device.  If no active path to the element
{   is found the first channel in the ON state will be returned and if no
{   connected channels are in the ON state the primary channel and primary
{   controller are returned.
{

  PROCEDURE find_connected_channel
    (    element_definition: cmt$element_definition;
     VAR channel: cmt$element_definition;
     VAR controller_equipment_number: cmt$physical_equipment_number;
     VAR status: ost$status);

    VAR
      active_channel_found: boolean,
      channel_controller_status: cmt$connection_status,
      channel_element_p: ^cmt$element_definition,
      channel_element_state: cmt$element_state,
      controller_element_p: ^cmt$element_definition,
      controller_unit_status: cmt$connection_status,
      data_storage_index: cmt$data_storage_port_number,
      element_descriptor: cmt$element_descriptor,
      mainframe_id: pmt$mainframe_id,
      port: cmt$controller_port_number,
      primary_channel_found: boolean,
      primary_controller_found: boolean,
      unused_iou: cmt$element_name;

    status.normal := TRUE;
    active_channel_found := FALSE;
    primary_channel_found := FALSE;
    primary_controller_found := FALSE;

    pmp$get_mainframe_id (mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE element_definition.element_type OF
    = cmc$controller_element =
      controller_equipment_number := element_definition.controller.physical_equipment_number;

    /channel_loop_1/
      FOR port := LOWERVALUE (cmt$controller_port_number) TO UPPERVALUE (cmt$controller_port_number) DO
        IF NOT element_definition.controller.connection.port [port].configured THEN
          CYCLE /channel_loop_1/;
        IFEND;

        IF element_definition.controller.connection.port [port].mainframe_ownership <> mainframe_id THEN
          CYCLE /channel_loop_1/;
        IFEND;

        cmp$pc_get_element (element_definition.controller.connection.port [port].element_name,
              element_definition.controller.connection.port [port].iou, channel_element_p, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF NOT primary_channel_found THEN
          primary_channel_found := TRUE;
          channel := channel_element_p^;
        IFEND;

        cmp$get_element_state (channel_element_p^.element_name, channel_element_p^.data_channel.iou,
              channel_element_state, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF NOT active_channel_found AND (channel_element_state = cmc$on) THEN
          active_channel_found := TRUE;
          channel := channel_element_p^;
        IFEND;

        element_descriptor.element_type := cmc$data_channel_element;
        element_descriptor.channel_descriptor.use_logical_identification := TRUE;
        element_descriptor.channel_descriptor.name := element_definition.controller.connection.port [port].
              element_name;
        element_descriptor.channel_descriptor.iou := element_definition.controller.connection.port [port].iou;

        cmp$get_connection_status (element_descriptor, element_definition.element_name,
              channel_controller_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF channel_controller_status = cmc$active THEN
          channel := channel_element_p^;
          RETURN;
        IFEND;

      FOREND /channel_loop_1/;

    = cmc$storage_device_element =

    /controller_loop/
      FOR data_storage_index := LOWERVALUE (cmt$data_storage_port_number)
            TO UPPERVALUE (cmt$data_storage_port_number) DO
        IF NOT element_definition.storage_device.connection.port [data_storage_index].configured THEN
          CYCLE /controller_loop/;
        IFEND;

        IF element_definition.storage_device.connection.port [data_storage_index].upline_connection_type =
              cmc$controller_element THEN

          cmp$pc_get_element (element_definition.storage_device.connection.port [data_storage_index].
                element_name, unused_iou, controller_element_p, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF NOT primary_controller_found THEN
            primary_controller_found := TRUE;
            controller_equipment_number := controller_element_p^.controller.physical_equipment_number;
          IFEND;

          element_descriptor.element_type := cmc$controller_element;
          element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
          element_descriptor.peripheral_descriptor.element_name := controller_element_p^.element_name;

          cmp$get_connection_status (element_descriptor, element_definition.element_name,
                controller_unit_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        /channel_loop_2/
          FOR port := LOWERVALUE (cmt$controller_port_number) TO UPPERVALUE (cmt$controller_port_number) DO
            IF NOT controller_element_p^.controller.connection.port [port].configured THEN
              CYCLE /channel_loop_2/;
            IFEND;

            IF controller_element_p^.controller.connection.port [port].mainframe_ownership <>
                  mainframe_id THEN
              CYCLE /channel_loop_2/;
            IFEND;

            cmp$pc_get_element (controller_element_p^.controller.connection.port [port].element_name,
                  controller_element_p^.controller.connection.port [port].iou, channel_element_p, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF NOT primary_channel_found THEN
              primary_channel_found := TRUE;
              channel := channel_element_p^;
            IFEND;

            element_descriptor.element_type := cmc$data_channel_element;
            element_descriptor.channel_descriptor.use_logical_identification := TRUE;
            element_descriptor.channel_descriptor.name := controller_element_p^.controller.connection.port
                  [port].element_name;
            element_descriptor.channel_descriptor.iou := controller_element_p^.controller.connection.port
                  [port].iou;

            cmp$get_connection_status (element_descriptor, controller_element_p^.element_name,
                  channel_controller_status, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF (NOT active_channel_found) AND (channel_controller_status = cmc$active) THEN
              active_channel_found := TRUE;
              channel := channel_element_p^;
              controller_equipment_number := controller_element_p^.controller.physical_equipment_number;
            IFEND;

            IF (channel_controller_status = cmc$active) AND (controller_unit_status = cmc$active) THEN
              channel := channel_element_p^;
              controller_equipment_number := controller_element_p^.controller.physical_equipment_number;
              RETURN;
            IFEND;
          FOREND /channel_loop_2/;

        ELSE
          {
          {Process hydra mass storage device.
          {
          controller_equipment_number := element_definition.storage_device.physical_unit_number;
          IF element_definition.storage_device.connection.port [data_storage_index].mainframe_ownership <>
                mainframe_id THEN
            CYCLE /controller_loop/;
          IFEND;

          cmp$pc_get_element (element_definition.storage_device.connection.port [data_storage_index].
                element_name, element_definition.storage_device.connection.port [data_storage_index].iou,
                channel_element_p, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF NOT primary_channel_found THEN
            primary_channel_found := TRUE;
            channel := channel_element_p^;
          IFEND;

          cmp$get_element_state (channel_element_p^.element_name, channel_element_p^.data_channel.iou,
                channel_element_state, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF NOT active_channel_found AND (channel_element_state = cmc$on) THEN
            active_channel_found := TRUE;
            channel := channel_element_p^;
          IFEND;

          element_descriptor.element_type := cmc$data_channel_element;
          element_descriptor.channel_descriptor.use_logical_identification := TRUE;
          element_descriptor.channel_descriptor.name := element_definition.storage_device.connection.
                port [data_storage_index].element_name;
          element_descriptor.channel_descriptor.iou := element_definition.storage_device.connection.
                port [data_storage_index].iou;

          cmp$get_connection_status (element_descriptor, element_definition.element_name,
                channel_controller_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF channel_controller_status <> cmc$active THEN
            CYCLE /controller_loop/;
          IFEND;

          channel := channel_element_p^;
          RETURN;
        IFEND;
      FOREND /controller_loop/;
    ELSE
    CASEND;
  PROCEND find_connected_channel;

?? TITLE := '  process_iou_resources', EJECT ??

 { PURPOSE : This procedure acquires/release channel and PP resources.

  PROCEDURE process_iou_resources (element_definition : cmt$element_definition;
         controller_type : cmt$controller_type;
         process_channel : boolean;
         process_pp : boolean;
         current_state : cmt$element_state;
         new_state : cmt$element_state;
         driver_name : pmt$program_name;
     VAR status : ost$status);

     VAR
       channel : cmt$element_definition,
       equipment_number : cmt$physical_equipment_number,
       ignore_status : ost$status,
       iou_name : cmt$element_name,
       iou_number : dst$iou_number,
       physical_channel : cmt$physical_channel,
       port : integer,
       pp_not_active: boolean,
       pp_acquired : ARRAY [cmt$max_channels_per_storage] OF pps_acquired_info,
       pp_released : ARRAY [cmt$controller_port_number] OF pps_released_info,
       pp_table_rma : ost$real_memory_address,
       redundant: boolean;

     status.normal := TRUE;
     IF element_definition.element_type = cmc$data_channel_element THEN
       cmp$convert_iou_name (element_definition.data_channel.iou, iou_number, status);
       IF NOT status.normal THEN
         RETURN;
       IFEND;
       physical_channel.number := element_definition.data_channel.number;
       physical_channel.concurrent := element_definition.data_channel.concurrent;
       physical_channel.port := element_definition.data_channel.port;

       IF new_state = cmc$on THEN

         IF current_state = cmc$off THEN
           IF process_channel THEN
             cmp$reacquire_resources (dsc$rrt_get_channel, physical_channel,
                 iou_number, cmc$null_equipment_number, cmc$null_unit_number, driver_name,
                 pp_table_rma, controller_type, FALSE, status);
             IF NOT status.normal THEN
               RETURN;
             IFEND;
           IFEND;
         IFEND;
         IF process_pp THEN
           redundant := FALSE;
           IF cmp$support_redundant_channel (controller_type) THEN
              cmp$determine_redundant_channel (physical_channel, iou_number,
                  {ignore_state=}TRUE, redundant, ignore_status);
           IFEND;
           IF NOT redundant THEN
             cmp$get_pp_table_rma (element_definition, pp_table_rma, status);
             IF NOT status.normal THEN
               RETURN;
             IFEND;
             cmp$reacquire_resources (dsc$rrt_get_pp, physical_channel,
                   iou_number, cmc$null_equipment_number, cmc$null_unit_number,
                   driver_name, pp_table_rma, controller_type, TRUE, status);
             IF NOT status.normal THEN
               RETURN;
             IFEND;
           IFEND;
         IFEND;
       ELSEIF (new_state = cmc$down) AND (current_state = cmc$off) THEN

 { Acquire the channel only.

         cmp$reacquire_resources (dsc$rrt_get_channel, physical_channel,
             iou_number, cmc$null_equipment_number, cmc$null_unit_number, driver_name,
             pp_table_rma, controller_type, FALSE, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;

       ELSE { New state is DOWN or OFF and current state is ON }

 { Soft idle the pp first. The status will be ignored since PP will
 { be hardware idled upon being released.

         determine_if_pp_not_active (element_definition.data_channel.number,
               element_definition.data_channel.port, element_definition.data_channel.concurrent,
               iou_number, pp_not_active);
         IF NOT pp_not_active THEN
           cmp$idle_pp_r1 (element_definition.element_name, element_definition.data_channel.iou, status);
           cmp$release_pp_by_channel (physical_channel, iou_number, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;
           cmp$clear_ppit (element_definition.element_name, element_definition.
                 data_channel.iou, ignore_status);
         IFEND;
         IF (new_state = cmc$off) AND process_channel THEN
           cmp$release_channel_resource (physical_channel, iou_number, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;
         IFEND;
       IFEND;

     ELSEIF element_definition.element_type = cmc$controller_element THEN
       IF new_state = cmc$on THEN
         cmp$active_path (element_definition, controller_type, pp_acquired, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;
         FOR port := LOWERVALUE (cmt$max_channels_per_storage) TO
                       UPPERVALUE (cmt$max_channels_per_storage) DO
           IF pp_acquired [port].acquired THEN
             IF current_state = cmc$off THEN
               cmp$reacquire_resources (dsc$rrt_get_channel, pp_acquired [port].channel,
                       pp_acquired [port].iou, cmc$null_equipment_number, cmc$null_unit_number,
                       driver_name, pp_table_rma, controller_type, FALSE, status);
               IF NOT status.normal THEN
                 RETURN;
               IFEND;
             IFEND;
             cmp$reacquire_resources (dsc$rrt_get_pp, pp_acquired [port].channel,
               pp_acquired [port].iou, cmc$null_equipment_number, cmc$null_unit_number,
                 pp_acquired [port].driver_name, pp_acquired [port].pp_table_rma,
                   pp_acquired [port].controller_type, TRUE, status);
             IF NOT status.normal THEN
               RETURN;
             IFEND;
           IFEND;
         FOREND;
       ELSEIF (new_state = cmc$down) AND (current_state = cmc$off) THEN

 { Acquire all Channels.

         cmp$active_path (element_definition, controller_type, pp_acquired, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;
         FOR port := LOWERVALUE (cmt$max_channels_per_storage) TO
                       UPPERVALUE (cmt$max_channels_per_storage) DO
           IF pp_acquired [port].acquired THEN
             IF (current_state = cmc$off) THEN
               cmp$reacquire_resources (dsc$rrt_get_channel, pp_acquired [port].channel,
                       pp_acquired [port].iou, cmc$null_equipment_number, cmc$null_unit_number,
                       driver_name, pp_table_rma, controller_type, FALSE, status);
               IF NOT status.normal THEN
                 RETURN;
               IFEND;
             IFEND;
           IFEND;
         FOREND;
       ELSE { New state is DOWN or OFF }
         cmp$unactive_path (element_definition, pp_released, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;
         FOR port := LOWERVALUE (cmt$controller_port_number) TO
                    UPPERVALUE (cmt$controller_port_number) DO
           IF pp_released [port].released THEN
             cmp$convert_iou_number (pp_released [port].iou, iou_name, ignore_status);
             determine_if_pp_not_active (pp_released [port].channel.number,
                   pp_released [port].channel.port, pp_released [port].channel.concurrent,
                   pp_released [port].iou, pp_not_active);
             IF NOT pp_not_active THEN
               cmp$idle_pp_r1 (pp_released [port].channel_name, iou_name, ignore_status);
               cmp$release_pp_by_channel (pp_released [port].channel, pp_released [port].iou, status);
               IF NOT status.normal THEN
                 RETURN;
               IFEND;
             IFEND;
             IF (new_state = cmc$off) THEN
               cmp$release_channel_resource (pp_released [port].channel, pp_released [port].iou, status);
               IF NOT status.normal THEN
                 RETURN;
               IFEND;
             IFEND;
             cmp$clear_ppit (pp_released [port].channel_name, iou_name, status);
             IF NOT status.normal THEN
               RETURN;
             IFEND;
           IFEND;
         FOREND;
       IFEND;
     IFEND;

  PROCEND process_iou_resources;
?? OLDTITLE , OLDTITLE ??
MODEND cmm$miscellaneous_interfaces
*DECK DECK=CMM$MONITOR_JOB_MODE_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'CM Monitor and Job Mode interfaces' ??
MODULE cmm$monitor_job_mode_interfaces;

{ PURPOSE:
{   This module contains interfaces executing both in Monitor and Job mode
{   to retrieve configuration information.
{ NOTE:
{   Care should be taken to access only Mainframe Wired data structures from this module.

?? PUSH (LISTEXT := ON) ??
*copyc cmp$support_redundant_access
*copyc mtp$error_stop
*copyc cmt$connection
*copyc cmt$element_definition
*copyc ost$hardware_subranges
?? POP ??

*copyc cmv$controller_address
*copyc cmv$data_channel_address
*copyc cmv$hydra_mass_storage_address
*copyc cmv$logical_pp_table_p
*copyc cmv$mass_storage_address
*copyc cmv$peripheral_element_table

  VAR
    cmv$debug: [XREF] 0 .. 255,
    cmv$debug_stop: [XREF] boolean;

?? TITLE := ' cmp$find_redundant_path', EJECT ??

{ PURPOSE:
{   This procedure searches for an available redundant channel given the
{   primary channel address.  It returns the driver name, the controller type,
{   and the RMA to the PPIT of the redundant channel.
{
{ NOTE:
{   A channel is redundant if it is connected to a certain group of disk and
{   tape subsystems and if it is not the first on channel in the connection.
{

  PROCEDURE [XDCL] cmp$find_redundant_path
    (    primary_path_element: cmt$physical_address;
         new_state: cmt$element_state;
     VAR redundant_path_available: boolean;
     VAR update_controller_address: boolean;
     VAR number_of_path: integer;
     VAR redundant_channel_list: array [cmt$physical_equipment_number] of cmt$physical_address;
     VAR redundant_path_pp_list: array [cmt$physical_equipment_number] of iot$pp_number;
     VAR driver_name: pmt$program_name;
     VAR pp_table_rma_list: array [cmt$physical_equipment_number] of ost$real_memory_address);


    { PURPOSE:
    {   Function to return whether or not a channel is present in a list.
    {

    FUNCTION channel_in_list
      (    channel: cmt$physical_address): boolean;

      VAR
        list_index: integer;

      channel_in_list := FALSE;
      IF number_of_path >= 0 THEN
        list_index := LOWERBOUND (redundant_channel_list);
        WHILE (list_index <= number_of_path) DO
          IF channel = redundant_channel_list [list_index] THEN
            channel_in_list := TRUE;
            RETURN;
          IFEND;
          list_index := list_index + 1;
        WHILEND;
      IFEND;
    FUNCEND channel_in_list;

    CONST
      max_number_of_entries = 15;

    VAR
      channel: cmt$physical_address,
      channel_element_p: ^cmt$peripheral_element_entry,
      connection_status: cmt$connection_status,
      controller: cmt$physical_address,
      controller_element_p: ^cmt$peripheral_element_entry,
      element_list_p: ^array [ * ] of ^cmt$peripheral_element_entry,
      i: integer,
      j: integer,
      index: integer,
      pp_available: boolean,
      primary_controller: cmt$physical_address,
      unit_element_list_p: ^array [ * ] of ^cmt$peripheral_element_entry,
      unit_element_p: ^cmt$peripheral_element_entry,
      unit_path: cmt$physical_address;

    redundant_path_available := FALSE;
    update_controller_address := FALSE;

    FOR index := LOWERVALUE (cmt$physical_equipment_number) TO UPPERVALUE (cmt$physical_equipment_number) DO
      redundant_path_pp_list [index] := 0;
    FOREND;
    number_of_path := -1;

    IF cmv$debug = 01(16) THEN
      mtp$error_stop ('Debug stop in cmp$find_redundant_path.');
    IFEND;

    IF primary_path_element.address_specifier = cmv$data_channel_address THEN
      {
      { Get list of controllers connected to the specified channel.
      {
      PUSH element_list_p: [0 .. max_number_of_entries];
      cmp$get_element_list (primary_path_element, cmc$controller_element, element_list_p);

    /controller_element_loop_1/
      FOR index := LOWERBOUND (element_list_p^) TO UPPERBOUND (element_list_p^) DO
        IF element_list_p^ [index] = NIL THEN
          CYCLE /controller_element_loop_1/;
        IFEND;

        controller_element_p := element_list_p^ [index];
        IF NOT controller_element_p^.physical_descriptor.configured THEN
          CYCLE /controller_element_loop_1/;
        IFEND;

        IF controller_element_p^.element_status.state <> cmc$on THEN
          CYCLE /controller_element_loop_1/;
        IFEND;

        IF NOT cmp$support_redundant_access (cmc$controller_element, controller_element_p^.product_id) THEN
          RETURN;
        IFEND;
        {
        {See if the controller connected to the channel has any redundant path(s).
        {Search for an available redundant channel by going to all active units and then
        {look at their upline connections.  If there is a different channel on any of
        {the controllers connected to these units, it can be a redundant channel.
        {
        controller.address_specifier := cmv$controller_address;
        controller.iou := primary_path_element.iou;
        controller.channel := primary_path_element.channel;
        controller.channel_address := controller_element_p^.physical_descriptor.equipment_path^ [1].
              channel_address;

        PUSH unit_element_list_p: [0 .. max_number_of_entries];
        cmp$get_element_list (controller, cmc$storage_device_element, unit_element_list_p);

      /unit_element_loop_1/
        FOR i := LOWERBOUND (unit_element_list_p^) TO UPPERBOUND (unit_element_list_p^) DO
          IF unit_element_list_p^ [i] = NIL THEN
            CYCLE /unit_element_loop_1/;
          IFEND;

          unit_element_p := unit_element_list_p^ [i];
          IF NOT unit_element_p^.physical_descriptor.configured THEN
            CYCLE /unit_element_loop_1/;
          IFEND;

          IF unit_element_p^.element_status.state <> cmc$on THEN
            CYCLE /unit_element_loop_1/;
          IFEND;

        /unit_path_loop_1/
          FOR j := LOWERBOUND (unit_element_p^.physical_descriptor.unit_path^)
                TO UPPERBOUND (unit_element_p^.physical_descriptor.unit_path^) DO
            unit_path := unit_element_p^.physical_descriptor.unit_path^ [j];
            IF ((unit_path.iou = controller.iou) AND (unit_path.channel = controller.channel) AND
                  (unit_path.channel_address = controller.channel_address)) THEN
              CYCLE /unit_path_loop_1/;
            IFEND;

            get_controller_physical_address (unit_path, controller);
            cmp$locate_element_via_adr (controller, controller_element_p);
            IF (controller_element_p = NIL) OR (controller_element_p^.element_status.state <> cmc$on) THEN
              CYCLE /unit_path_loop_1/;
            IFEND;
            {
            { If the connection status is not active this path should not be checked.
            {
            get_connection_status (controller_element_p, unit_element_p^.element_name, connection_status);
            IF connection_status <> cmc$active THEN
              CYCLE /unit_path_loop_1/;
            IFEND;

            get_channel_physical_address (unit_path, channel);
            cmp$locate_element_via_adr (channel, channel_element_p);
            IF (channel_element_p = NIL) OR (channel_element_p^.element_status.state <> cmc$on) THEN
              CYCLE /unit_path_loop_1/;
            IFEND;

            {
            { If the connection status is not active we shouldn't have to check this path,
            { however, if the new_state is cmc$on, the connection status will change before
            { we actually build the PP tables.
            {
            get_connection_status (channel_element_p, controller_element_p^.element_name, connection_status);
            IF (new_state <> cmc$on) AND (connection_status <> cmc$active) THEN
              CYCLE /unit_path_loop_1/;
            IFEND;

            IF channel_in_list (channel) THEN
              CYCLE /unit_path_loop_1/;
            IFEND;

            setup_redundant_path_info (channel, number_of_path, pp_available, pp_table_rma_list,
                  redundant_path_pp_list, redundant_channel_list);
            IF pp_available THEN
              update_controller_address := TRUE;
              redundant_path_available := TRUE;
              driver_name := channel_element_p^.physical_descriptor.peripheral_driver_name;
            IFEND;
          FOREND /unit_path_loop_1/;
        FOREND /unit_element_loop_1/;
      FOREND /controller_element_loop_1/;

      IF cmv$debug = 02(16) THEN
        mtp$error_stop ('Debug stop 02(16) cmp$find_redundant_path.');
      IFEND;

    ELSEIF primary_path_element.address_specifier = cmv$controller_address THEN
      {
      {Controller address
      {
      cmp$locate_element_via_adr (primary_path_element, controller_element_p);
      IF controller_element_p = NIL THEN
        RETURN;
      IFEND;

      IF NOT cmp$support_redundant_access (cmc$controller_element, controller_element_p^.product_id) THEN
        RETURN;
      IFEND;

      update_controller_address := TRUE;
      PUSH unit_element_list_p: [0 .. max_number_of_entries];
      cmp$get_element_list (primary_path_element, cmc$storage_device_element, unit_element_list_p);

    /unit_element_loop_2/
      FOR index := LOWERBOUND (unit_element_list_p^) TO UPPERBOUND (unit_element_list_p^) DO
        IF unit_element_list_p^ [index] = NIL THEN
          CYCLE /unit_element_loop_2/;
        IFEND;

        unit_element_p := unit_element_list_p^ [index];
        IF NOT unit_element_p^.physical_descriptor.configured THEN
          CYCLE /unit_element_loop_2/;
        IFEND;

        IF unit_element_p^.element_status.state <> cmc$on THEN
          CYCLE /unit_element_loop_2/;
        IFEND;

      /unit_path_loop_2/
        FOR j := LOWERBOUND (unit_element_p^.physical_descriptor.unit_path^)
              TO UPPERBOUND (unit_element_p^.physical_descriptor.unit_path^) DO
          unit_path := unit_element_p^.physical_descriptor.unit_path^ [j];

          get_controller_physical_address (unit_path, controller);
          IF controller = primary_path_element THEN
            CYCLE /unit_path_loop_2/;
          IFEND;

          cmp$locate_element_via_adr (controller, controller_element_p);
          IF (controller_element_p = NIL) OR (controller_element_p^.element_status.state <> cmc$on) THEN
            CYCLE /unit_path_loop_2/;
          IFEND;
          {
          { If the connection status is not active we shouldn't have to check this path,
          { however, if the new_state is cmc$on, the connection status will change before
          { we actually build the PP tables.
          {
          get_connection_status (controller_element_p, unit_element_p^.element_name, connection_status);
          IF (new_state <> cmc$on) AND (connection_status <> cmc$active) THEN
            CYCLE /unit_path_loop_2/;
          IFEND;

          get_channel_physical_address (unit_path, channel);
          cmp$locate_element_via_adr (channel, channel_element_p);
          IF (channel_element_p = NIL) OR (channel_element_p^.element_status.state <> cmc$on) THEN
            CYCLE /unit_path_loop_2/;
          IFEND;
          {
          { If the connection status is not active we shouldn't have to check this path,
          { however, if the new_state is cmc$on, the connection status will change before
          { we actually build the PP tables.
          {
          get_connection_status (channel_element_p, controller_element_p^.element_name, connection_status);
          IF (new_state <> cmc$on) AND (connection_status <> cmc$active) THEN
            CYCLE /unit_path_loop_2/;
          IFEND;

          IF channel_in_list (channel) THEN
            CYCLE /unit_path_loop_2/;
          IFEND;

          setup_redundant_path_info (channel, number_of_path, pp_available, pp_table_rma_list,
                redundant_path_pp_list, redundant_channel_list);
          IF pp_available THEN
            update_controller_address := TRUE;
            redundant_path_available := TRUE;
            driver_name := channel_element_p^.physical_descriptor.peripheral_driver_name;
          IFEND;
        FOREND /unit_path_loop_2/;
      FOREND /unit_element_loop_2/;

      IF cmv$debug = 02(16) THEN
        mtp$error_stop ('Debug stop 02(16) cmp$find_redundant_path.');
      IFEND;

    ELSEIF primary_path_element.address_specifier = cmv$mass_storage_address THEN
      {
      {Storage device element
      {
      cmp$locate_element_via_adr (primary_path_element, unit_element_p);
      IF unit_element_p = NIL THEN
        RETURN;
      IFEND;

    /unit_path_loop_3/
      FOR index := LOWERBOUND (unit_element_p^.physical_descriptor.unit_path^)
            TO UPPERBOUND (unit_element_p^.physical_descriptor.unit_path^) DO
        unit_path := unit_element_p^.physical_descriptor.unit_path^ [index];
        get_controller_physical_address (unit_path, controller);

        IF unit_path = primary_path_element THEN
          CYCLE /unit_path_loop_3/;
        IFEND;

        cmp$locate_element_via_adr (controller, controller_element_p);
        IF (controller_element_p = NIL) OR (controller_element_p^.element_status.state <> cmc$on) THEN
          CYCLE /unit_path_loop_3/;
        IFEND;
        {
        { If the connection status is not active we shouldn't have to check this path,
        { however, if the new_state is cmc$on, the connection status will change before
        { we actually build the PP tables.
        {
        get_connection_status (controller_element_p, unit_element_p^.element_name, connection_status);
        IF (new_state <> cmc$on) AND (connection_status <> cmc$active) THEN
          CYCLE /unit_path_loop_3/;
        IFEND;

        get_channel_physical_address (unit_path, channel);
        cmp$locate_element_via_adr (channel, channel_element_p);
        IF (channel_element_p = NIL) OR (channel_element_p^.element_status.state <> cmc$on) THEN
          CYCLE /unit_path_loop_3/;
        IFEND;

        get_connection_status (channel_element_p, controller_element_p^.element_name, connection_status);
        IF connection_status <> cmc$active THEN
          CYCLE /unit_path_loop_3/;
        IFEND;

        IF channel_in_list (channel) THEN
          CYCLE /unit_path_loop_3/;
        IFEND;

        setup_redundant_path_info (channel, number_of_path, pp_available, pp_table_rma_list,
              redundant_path_pp_list, redundant_channel_list);
        IF pp_available THEN
          update_controller_address := TRUE;
          redundant_path_available := TRUE;
          driver_name := channel_element_p^.physical_descriptor.peripheral_driver_name;
        IFEND;
      FOREND /unit_path_loop_3/;

      IF cmv$debug = 02(16) THEN
        mtp$error_stop ('Debug stop 02(16) cmp$find_redundant_path.');
      IFEND;

    ELSEIF primary_path_element.address_specifier = cmv$hydra_mass_storage_address THEN
      {
      { This should not occur.
      {
    IFEND;
  PROCEND cmp$find_redundant_path;

?? TITLE := ' cmp$get_element_list', EJECT ??

{ PURPOSE:
{   This procedure returns a list of element entries whose upline connection
{   matches the given upline physical address.

  PROCEDURE cmp$get_element_list
    (    upline_path: cmt$physical_address;
         element_type_sought: cmt$element_type;
         element_list_p: ^array [ * ] of ^cmt$peripheral_element_entry);

    VAR
      element_p: ^cmt$peripheral_element_entry,
      list_index: integer,
      path_index: integer,
      table_index: integer;

    IF element_list_p = NIL THEN
      RETURN;
    IFEND;

    FOR list_index := LOWERBOUND (element_list_p^) TO UPPERBOUND (element_list_p^) DO
      element_list_p^ [list_index] := NIL;
    FOREND;
    list_index := LOWERBOUND (element_list_p^);

  /scan_table/
    FOR table_index := LOWERBOUND (cmv$peripheral_element_table.pointer^)
          TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
      element_p := ^cmv$peripheral_element_table.pointer^ [table_index];
      IF NOT element_p^.physical_descriptor.configured THEN
        CYCLE /scan_table/;
      IFEND;

      IF element_p^.physical_descriptor.element_type <> element_type_sought THEN
        CYCLE /scan_table/;
      IFEND;

      CASE element_type_sought OF
      = cmc$storage_device_element =
        FOR path_index := LOWERBOUND (element_p^.physical_descriptor.unit_path^)
              TO UPPERBOUND (element_p^.physical_descriptor.unit_path^) DO
          IF (element_p^.physical_descriptor.unit_path^ [path_index].iou = upline_path.iou) AND
                (element_p^.physical_descriptor.unit_path^ [path_index].channel = upline_path.channel) AND
                (element_p^.physical_descriptor.unit_path^ [path_index].channel_address =
                upline_path.channel_address) THEN
            element_list_p^ [list_index] := element_p;
            IF list_index < UPPERBOUND (element_list_p^) THEN
              list_index := list_index + 1;
            IFEND;
            CYCLE /scan_table/;
          IFEND;
        FOREND;

      = cmc$controller_element =
        FOR path_index := LOWERBOUND (element_p^.physical_descriptor.equipment_path^)
              TO UPPERBOUND (element_p^.physical_descriptor.equipment_path^) DO
          IF (element_p^.physical_descriptor.equipment_path^ [path_index].iou = upline_path.iou) AND
                (element_p^.physical_descriptor.equipment_path^ [path_index].channel =
                upline_path.channel) THEN
            element_list_p^ [list_index] := element_p;
            IF list_index < UPPERBOUND (element_list_p^) THEN
              list_index := list_index + 1;
            IFEND;
            CYCLE /scan_table/;
          IFEND;
        FOREND;
      ELSE
        ;
      CASEND;
    FOREND /scan_table/;
  PROCEND cmp$get_element_list;

?? TITLE := ' get_logical_pp', EJECT ??

{ PURPOSE:
{   This procedure retrieves the logical PP number associated with a channel.

  PROCEDURE get_logical_pp
    (    channel: cmt$physical_address;
     VAR logical_pp: iot$pp_number;
     VAR found: boolean);

    VAR
      channel_resource: dst$iou_resource;

    found := FALSE;
    channel_resource.iou_number := channel.iou;
    IF channel.channel.concurrent THEN
      channel_resource.channel_protocol := dsc$cpt_cio;
    ELSE
      channel_resource.channel_protocol := dsc$cpt_nio;
    IFEND;
    channel_resource.number := channel.channel.number;

    FOR logical_pp := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
      IF cmv$logical_pp_table_p^ [logical_pp].pp_info.channel = channel_resource THEN
        found := TRUE;
        RETURN;
      IFEND;
    FOREND;

  PROCEND get_logical_pp;

?? TITLE := ' cmp$locate_element_via_adr', EJECT ??

{ PURPOSE:
{     This procedure will search the peripheral element table for the
{     specified physical address and return a pointer to the element if it is found.
{     If the element is not found a NIL pointer will be returned.
{

  PROCEDURE [XDCL] cmp$locate_element_via_adr
    (    physical_address: cmt$physical_address;
     VAR peripheral_element_p: ^cmt$peripheral_element_entry);

    VAR
      current_path: cmt$physical_address,
      i: integer,
      table_index: integer;

    peripheral_element_p := NIL;
    IF cmv$peripheral_element_table.pointer = NIL THEN
      RETURN;
    IFEND;

  /pet_loop/
    FOR table_index := LOWERBOUND (cmv$peripheral_element_table.pointer^)
          TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
      IF NOT cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.configured THEN
        CYCLE /pet_loop/;
      IFEND;

      peripheral_element_p := ^cmv$peripheral_element_table.pointer^ [table_index];

      IF physical_address.address_specifier = cmv$data_channel_address THEN
        IF peripheral_element_p^.physical_descriptor.element_type <> cmc$data_channel_element THEN
          CYCLE /pet_loop/;
        IFEND;

        IF (peripheral_element_p^.physical_descriptor.channel_path.channel = physical_address.channel) AND
              (peripheral_element_p^.physical_descriptor.channel_path.iou = physical_address.iou) THEN
          RETURN;
        IFEND;

      ELSEIF physical_address.address_specifier = cmv$controller_address THEN
        IF (peripheral_element_p^.physical_descriptor.element_type <> cmc$controller_element) AND
              (peripheral_element_p^.physical_descriptor.element_type <> cmc$external_processor_element) AND
              (peripheral_element_p^.physical_descriptor.element_type <> cmc$channel_adapter_element) AND
              (peripheral_element_p^.physical_descriptor.element_type <> cmc$communications_element) THEN
          CYCLE /pet_loop/;
        IFEND;

        FOR i := LOWERBOUND (peripheral_element_p^.physical_descriptor.equipment_path^)
              TO UPPERBOUND (peripheral_element_p^.physical_descriptor.equipment_path^) DO
          current_path := peripheral_element_p^.physical_descriptor.equipment_path^ [i];
          IF (current_path.iou = physical_address.iou) AND
                (current_path.channel = physical_address.channel) AND
                (current_path.channel_address = physical_address.channel_address) THEN
            RETURN;
          IFEND;
        FOREND;

      ELSEIF physical_address.address_specifier = cmv$mass_storage_address THEN
        IF peripheral_element_p^.physical_descriptor.element_type <> cmc$storage_device_element THEN
          CYCLE /pet_loop/;
        IFEND;

        FOR i := LOWERBOUND (peripheral_element_p^.physical_descriptor.unit_path^) TO
              UPPERBOUND (peripheral_element_p^.physical_descriptor.unit_path^) DO
          current_path := peripheral_element_p^.physical_descriptor.unit_path^ [i];
          IF (current_path.iou = physical_address.iou) AND
                (current_path.channel = physical_address.channel) AND
                (current_path.channel_address = physical_address.channel_address) AND
                (current_path.unit_address = physical_address.unit_address) THEN
            RETURN;
          IFEND;
        FOREND;

      ELSEIF physical_address.address_specifier = cmv$hydra_mass_storage_address THEN
        IF peripheral_element_p^.physical_descriptor.element_type <> cmc$storage_device_element THEN
          CYCLE /pet_loop/;
        IFEND;

        FOR i := LOWERBOUND (peripheral_element_p^.physical_descriptor.unit_path^) TO
              UPPERBOUND (peripheral_element_p^.physical_descriptor.unit_path^) DO
          current_path := peripheral_element_p^.physical_descriptor.unit_path^ [i];
          IF (current_path.iou = physical_address.iou) AND
                (current_path.channel = physical_address.channel) AND
                (current_path.unit_address = physical_address.unit_address) THEN
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    FOREND /pet_loop/;

    peripheral_element_p := NIL;
    IF cmv$debug = 07(16) THEN
      mtp$error_stop ('Debug stop 07(16) cmp$locate_element_via_adr.');
    IFEND;

  PROCEND cmp$locate_element_via_adr;

?? TITLE := ' cmp$locate_element_via_lun', EJECT ??

{ PURPOSE:
{     This procedure will search the peripheral element table for the
{     specified logical unit number and return a pointer to the element if it
{     is found.  If the element is not found a NIL pointer will be returned.
{

  PROCEDURE [XDCL] cmp$locate_element_via_lun
    (    logical_unit_number: iot$logical_unit;
     VAR element_p: ^cmt$peripheral_element_entry);

    VAR
      pet_index: integer;

    element_p := NIL;
    IF cmv$peripheral_element_table.pointer = NIL THEN
      RETURN;
    IFEND;

  /lun_loop/
    FOR pet_index := LOWERBOUND (cmv$peripheral_element_table.pointer^)
          TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
      element_p := ^cmv$peripheral_element_table.pointer^ [pet_index];
      IF NOT element_p^.physical_descriptor.configured THEN
        CYCLE /lun_loop/;
      IFEND;

      IF element_p^.physical_descriptor.element_type <> cmc$storage_device_element THEN
        CYCLE /lun_loop/;
      IFEND;

      IF element_p^.logical_unit_number = logical_unit_number THEN
        RETURN;
      IFEND;
    FOREND /lun_loop/;
    {
    {Logical unit number not found.
    {
    element_p := NIL;

  PROCEND cmp$locate_element_via_lun;

?? TITLE := ' cmp$locate_element_via_name', EJECT ??

{ PURPOSE:
{     This procedure will search the peripheral element table for the
{     specified element and return a pointer to the element if it is found.
{     If the element is not found a NIL pointer will be returned.
{     The IOU_NUMBER parameter is used only when the specified element is
{     a data channel element.

  PROCEDURE [XDCL] cmp$locate_element_via_name
    (    element_name: cmt$element_name;
         iou_number: dst$iou_number;
     VAR element_p: ^cmt$peripheral_element_entry);

    VAR
      pet_index: integer;

    element_p := NIL;
    IF cmv$peripheral_element_table.pointer = NIL THEN
      RETURN;
    IFEND;

  /pet_loop/
    FOR pet_index := LOWERBOUND (cmv$peripheral_element_table.pointer^)
          TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
      element_p := ^cmv$peripheral_element_table.pointer^ [pet_index];
      IF NOT element_p^.physical_descriptor.configured THEN
        CYCLE /pet_loop/;
      IFEND;

      IF element_p^.element_name = element_name THEN
        IF element_p^.physical_descriptor.element_type = cmc$data_channel_element THEN
          IF element_p^.physical_descriptor.channel_path.iou <> iou_number THEN
            CYCLE /pet_loop/;
          IFEND;
        IFEND;
        RETURN;
      IFEND;

    FOREND /pet_loop/;
    {
    { Element name not found.
    {
    element_p := NIL;

  PROCEND cmp$locate_element_via_name;

?? TITLE := ' cmp$select_primary_controller', EJECT ??

{ PURPOSE:
{   This procedure uses information in the peripheral element table to determine
{   the correct controller to configure (if any) and if the unit is active on the
{   specified channel.


  PROCEDURE [XDCL] cmp$select_primary_controller
    (    pp: iot$pp_number;
         logical_unit_number: iot$logical_unit;
     VAR controller_p: ^cmt$peripheral_element_entry;
     VAR channel_p: ^cmt$peripheral_element_entry;
     VAR redundant_path: boolean);

    VAR
      alternate_access_controller_p: ^cmt$peripheral_element_entry,
      channel: cmt$physical_address,
      channel_element_p: ^cmt$peripheral_element_entry,
      connection_status: cmt$connection_status,
      controller: cmt$physical_address,
      controller_element_p: ^cmt$peripheral_element_entry,
      path_index: integer,
      pp_channel: cmt$physical_address,
      primary_channels_equal: boolean,
      primary_channel_p: ^cmt$peripheral_element_entry,
      primary_controller: cmt$physical_address,
      primary_controller_found: boolean,
      primary_controller_p: ^cmt$peripheral_element_entry,
      storage_device_element_p: ^cmt$peripheral_element_entry,
      stored_primary_channel: cmt$physical_address,
      unit_path: cmt$physical_address,
      unit_p: ^cmt$peripheral_element_entry;

    alternate_access_controller_p := NIL;
    controller_p := NIL;
    channel_p := NIL;
    primary_channels_equal := FALSE;
    primary_controller_found := FALSE;
    redundant_path := FALSE;

    pp_channel.address_specifier := cmv$data_channel_address;
    pp_channel.iou := cmv$logical_pp_table_p^ [pp].pp_info.channel.iou_number;
    pp_channel.channel.number := cmv$logical_pp_table_p^ [pp].pp_info.channel.number;
    pp_channel.channel.port := cmv$logical_pp_table_p^ [pp].pp_info.channel_port;
    pp_channel.channel.concurrent :=
          (cmv$logical_pp_table_p^ [pp].pp_info.channel.channel_protocol = dsc$cpt_cio);
    pp_channel.channel_address := 0;
    pp_channel.unit_address := 0;

    IF pp_channel.channel.concurrent THEN
      IF cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.unit_descriptors [logical_unit_number].
            physical_path.port = 0 THEN
        pp_channel.channel.port := cmc$port_a;
      ELSE
        pp_channel.channel.port := cmc$port_b;
      IFEND;
    IFEND;

    cmp$locate_element_via_lun (logical_unit_number, unit_p);
    IF unit_p = NIL THEN
      RETURN;
    IFEND;

    IF unit_p^.product_id.product_number = '  $887' THEN
      RETURN;
    ELSEIF unit_p^.product_id.product_number = '  $885' THEN
      select_7155_controller(pp, unit_p, controller_p, redundant_path);
      RETURN;
    IFEND;

    path_index := LOWERBOUND (unit_p^.physical_descriptor.unit_path^);

  /find_primary_path/
    WHILE path_index <= UPPERBOUND (unit_p^.physical_descriptor.unit_path^) DO
      unit_path := unit_p^.physical_descriptor.unit_path^ [path_index];
      path_index := path_index + 1;

      get_controller_physical_address (unit_path, controller);
      cmp$locate_element_via_adr (controller, primary_controller_p);
      IF (primary_controller_p = NIL) OR (primary_controller_p^.element_status.state <> cmc$on) THEN
        CYCLE /find_primary_path/;
      IFEND;
      {
      { Check the controller/unit connection status.
      {
      get_connection_status (primary_controller_p, unit_p^.element_name, connection_status);
      IF connection_status <> cmc$active THEN
        CYCLE /find_primary_path/;
      IFEND;

      get_channel_physical_address (unit_path, channel);
      cmp$locate_element_via_adr (channel, primary_channel_p);
      IF (primary_channel_p = NIL) OR (primary_channel_p^.element_status.state <> cmc$on) THEN
        CYCLE /find_primary_path/;
      IFEND;
      {
      { Check the channel/controller connection status.
      {
      get_connection_status (primary_channel_p, primary_controller_p^.element_name, connection_status);
      IF connection_status <> cmc$active THEN
        CYCLE /find_primary_path/;
      IFEND;

      primary_controller_found := TRUE;
      primary_controller := controller;
      stored_primary_channel := channel;
      primary_channels_equal := TRUE;

      IF channel = pp_channel THEN
        alternate_access_controller_p := primary_controller_p;
      IFEND;

      EXIT /find_primary_path/;
    WHILEND /find_primary_path/;

    IF cmv$debug = 03(16) THEN
      mtp$error_stop ('Debug stop 03(16) cmp$select_primary_controller.');
    IFEND;

    IF NOT primary_controller_found THEN
      RETURN;
    IFEND;

    IF primary_controller_p^.product_id.product_number = ' $5831' THEN
      {
      { For DAS devices we must determine if it is alternate or redundant access.
      { If redundant return the primary controller.
      { If alternate return the controller with this channel configured as its
      { primary controller.
      {

    /find_secondary_path/
      WHILE path_index <= UPPERBOUND (unit_p^.physical_descriptor.unit_path^) DO
        unit_path := unit_p^.physical_descriptor.unit_path^ [path_index];
        path_index := path_index + 1;
        IF unit_path.channel_address = primary_controller.channel_address THEN
          CYCLE /find_secondary_path/;
        IFEND;

        get_controller_physical_address (unit_path, controller);
        cmp$locate_element_via_adr (controller, controller_element_p);
        IF (controller_element_p = NIL) OR (controller_element_p^.element_status.state <> cmc$on) THEN
          CYCLE /find_secondary_path/;
        IFEND;
        {
        { Check the controller/unit connection status.
        {
        get_connection_status (controller_element_p, unit_p^.element_name, connection_status);
        IF connection_status <> cmc$active THEN
          CYCLE /find_secondary_path/;
        IFEND;

        get_channel_physical_address (unit_path, channel);
        cmp$locate_element_via_adr (channel, channel_element_p);
        IF (channel_element_p = NIL) OR (channel_element_p^.element_status.state <> cmc$on) THEN
          CYCLE /find_secondary_path/;
        IFEND;
        {
        { Check the channel/controller connection status.
        {
        get_connection_status (channel_element_p, controller_element_p^.element_name, connection_status);
        IF connection_status <> cmc$active THEN
          CYCLE /find_secondary_path/;
        IFEND;

        primary_channels_equal := (channel = stored_primary_channel);
        IF channel = pp_channel THEN
          alternate_access_controller_p := controller_element_p;
        IFEND;

        EXIT /find_secondary_path/;
      WHILEND /find_secondary_path/;
    IFEND;

    IF primary_channels_equal THEN
      controller_p := primary_controller_p;
      channel_p := primary_channel_p;
      redundant_path := (pp_channel <> stored_primary_channel);
    ELSE
      controller_p := alternate_access_controller_p;
    IFEND;

    IF cmv$debug = 04(16) THEN
      mtp$error_stop ('Debug stop 04(16) cmp$select_primary_controller.');
    IFEND;

  PROCEND cmp$select_primary_controller;

?? TITLE := ' cmp$verify_active_path_exists  ', EJECT ??

{ PURPOSE:
{   This procedure will determine if an active path for the element exists.
{   For a channel, if any active downline connection exists, TRUE will be returned.
{   For a controller, if either all downline connections are inactive or all upline
{   connections are inactive FALSE will be returned.
{   For a mass storage device if any upline connection is active TRUE will be returned.
{

  PROCEDURE [XDCL] cmp$verify_active_path_exists
    (    physical_address: cmt$physical_address;
     VAR active_path_exists: boolean);

    VAR
      channel: cmt$physical_address,
      channel_element_p: ^cmt$peripheral_element_entry,
      controller: cmt$physical_address,
      controller_element_p: ^cmt$peripheral_element_entry,
      i: integer,
      j: integer,
      unit_element_p: ^cmt$peripheral_element_entry;

    IF cmv$debug = 05(16) THEN
      mtp$error_stop ('Debug stop 05(16) cmp$verify_active_path_exists.');
    IFEND;

    active_path_exists := FALSE;

    IF physical_address.address_specifier = cmv$data_channel_address THEN
      cmp$locate_element_via_adr (physical_address, channel_element_p);
      IF channel_element_p = NIL THEN
        RETURN;
      IFEND;

      FOR i := LOWERBOUND (channel_element_p^.physical_descriptor.channel_connection^)
            TO UPPERBOUND (channel_element_p^.physical_descriptor.channel_connection^) DO
        IF channel_element_p^.physical_descriptor.channel_connection^ [i].status = cmc$active THEN
          active_path_exists := TRUE;
          RETURN;
        IFEND;
      FOREND

    ELSEIF physical_address.address_specifier = cmv$controller_address THEN
      cmp$locate_element_via_adr (physical_address, controller_element_p);
      IF controller_element_p = NIL THEN
        RETURN;
      IFEND;

    /search_downline_connections/
      FOR i := LOWERBOUND (controller_element_p^.physical_descriptor.equipment_connection^)
            TO UPPERBOUND (controller_element_p^.physical_descriptor.equipment_connection^) DO
        IF controller_element_p^.physical_descriptor.equipment_connection^ [i].status = cmc$active THEN
          active_path_exists := TRUE;
          EXIT /search_downline_connections/;
        IFEND;
      FOREND /search_downline_connections/;

      IF NOT active_path_exists THEN
        RETURN;
      IFEND;
      active_path_exists := FALSE;

      FOR i := LOWERBOUND (controller_element_p^.physical_descriptor.equipment_path^)
            TO UPPERBOUND (controller_element_p^.physical_descriptor.equipment_path^) DO
        get_channel_physical_address (controller_element_p^.physical_descriptor.equipment_path^ [i], channel);
        cmp$locate_element_via_adr (channel, channel_element_p);
        IF channel_element_p = NIL THEN
          RETURN;
        IFEND;

        FOR j := LOWERBOUND (channel_element_p^.physical_descriptor.channel_connection^)
              TO UPPERBOUND (channel_element_p^.physical_descriptor.channel_connection^) DO
          IF channel_element_p^.physical_descriptor.channel_connection^ [j].downline_element =
                controller_element_p^.element_name THEN
            IF channel_element_p^.physical_descriptor.channel_connection^ [j].status = cmc$active THEN
              active_path_exists := TRUE;
              RETURN;
            IFEND;
          IFEND;
        FOREND;
      FOREND;

    ELSEIF physical_address.address_specifier = cmv$mass_storage_address THEN
      cmp$locate_element_via_adr (physical_address, unit_element_p);
      IF unit_element_p = NIL THEN
        RETURN;
      IFEND;

      FOR i := LOWERBOUND (unit_element_p^.physical_descriptor.unit_path^)
            TO UPPERBOUND (unit_element_p^.physical_descriptor.unit_path^) DO
        get_controller_physical_address (unit_element_p^.physical_descriptor.unit_path^ [i], controller);
        cmp$locate_element_via_adr (controller, controller_element_p);
        IF controller_element_p = NIL THEN
          RETURN;
        IFEND;

        FOR j := LOWERBOUND (controller_element_p^.physical_descriptor.equipment_connection^)
              TO UPPERBOUND (controller_element_p^.physical_descriptor.equipment_connection^) DO
          IF controller_element_p^.physical_descriptor.equipment_connection^ [j].downline_element =
                unit_element_p^.element_name THEN
            IF controller_element_p^.physical_descriptor.equipment_connection^ [j].status = cmc$active THEN
              active_path_exists := TRUE;
              RETURN;
            IFEND;
          IFEND;
        FOREND;
      FOREND;

    ELSEIF physical_address.address_specifier = cmv$hydra_mass_storage_address THEN
      cmp$locate_element_via_adr (physical_address, unit_element_p);
      IF unit_element_p = NIL THEN
        RETURN;
      IFEND;

      FOR i := LOWERBOUND (unit_element_p^.physical_descriptor.unit_path^)
            TO UPPERBOUND (unit_element_p^.physical_descriptor.unit_path^) DO
        get_channel_physical_address (unit_element_p^.physical_descriptor.unit_path^ [i], channel);
        cmp$locate_element_via_adr (channel, channel_element_p);
        IF channel_element_p = NIL THEN
          RETURN;
        IFEND;

        FOR j := LOWERBOUND (channel_element_p^.physical_descriptor.channel_connection^)
              TO UPPERBOUND (channel_element_p^.physical_descriptor.channel_connection^) DO
          IF channel_element_p^.physical_descriptor.channel_connection^ [j].downline_element =
                unit_element_p^.element_name THEN
            IF channel_element_p^.physical_descriptor.channel_connection^ [j].status = cmc$active THEN
              active_path_exists := TRUE;
              RETURN;
            IFEND;
          IFEND;
        FOREND;
      FOREND;
    IFEND;

    IF cmv$debug = 06(16) THEN
      mtp$error_stop ('Debug stop 06(16) cmp$verify_active_path_exists.');
    IFEND;

  PROCEND cmp$verify_active_path_exists;

?? TITLE := ' get_channel_physical_address', EJECT ??

{ PURPOSE:
{   This procedure sets up the physical address specifier and physical address
{   of the channel element given the controller address or unit address of an element.

  PROCEDURE [INLINE] get_channel_physical_address
    (    controller_physical_address: cmt$physical_address;
     VAR channel_physical_address: cmt$physical_address);

    channel_physical_address.address_specifier := cmv$data_channel_address;
    channel_physical_address.iou := controller_physical_address.iou;
    channel_physical_address.channel := controller_physical_address.channel;
    channel_physical_address.channel_address := 0;
    channel_physical_address.unit_address := 0;
  PROCEND get_channel_physical_address;

?? TITLE := ' get_connection_status', EJECT ??

{ PURPOSE:
{   This procedure returns the status of a connection between two elements.
{

  PROCEDURE get_connection_status
    (    upline_element_p: ^cmt$peripheral_element_entry;
         downline_element: cmt$element_name;
     VAR connection_status: cmt$connection_status);

    VAR
      i: integer;

    connection_status := cmc$inactive;
    IF NOT upline_element_p^.physical_descriptor.configured THEN
      RETURN;
    IFEND;

    CASE upline_element_p^.physical_descriptor.element_type OF
    = cmc$data_channel_element =
      FOR i := LOWERBOUND (upline_element_p^.physical_descriptor.channel_connection^)
            TO UPPERBOUND (upline_element_p^.physical_descriptor.channel_connection^) DO
        IF upline_element_p^.physical_descriptor.channel_connection^ [i].downline_element =
              downline_element THEN
          connection_status := upline_element_p^.physical_descriptor.channel_connection^ [i].status;
          RETURN;
        IFEND;
      FOREND;

    = cmc$controller_element, cmc$channel_adapter_element =
      FOR i := LOWERBOUND (upline_element_p^.physical_descriptor.equipment_connection^)
            TO UPPERBOUND (upline_element_p^.physical_descriptor.equipment_connection^) DO
        IF upline_element_p^.physical_descriptor.equipment_connection^ [i].downline_element =
              downline_element THEN
          connection_status := upline_element_p^.physical_descriptor.equipment_connection^ [i].status;
          RETURN;
        IFEND;
      FOREND;
    ELSE
    CASEND;

  PROCEND get_connection_status;

?? TITLE := ' get_controller_physical_address', EJECT ??

{ PURPOSE:
{   This procedure sets up the physical address specifier and physical address
{   path of the controller element given the full path of the unit.

  PROCEDURE [INLINE] get_controller_physical_address
    (    unit_physical_address: cmt$physical_address;
     VAR controller_physical_address: cmt$physical_address);

    controller_physical_address.address_specifier := cmv$controller_address;
    controller_physical_address.iou := unit_physical_address.iou;
    controller_physical_address.channel := unit_physical_address.channel;
    controller_physical_address.channel_address := unit_physical_address.channel_address;
    controller_physical_address.unit_address := 0;
  PROCEND get_controller_physical_address;

?? TITLE := ' select_7155_controller', EJECT ??

{ PURPOSE:
{     This procedure returns the appropriate 7155 controller, if any, to be
{     configured in the PP interface table for the specified channel and unit.
{ DESIGN:
{     The 7155 controller must be handled slightly different than the other
{     devices that support redundancy and/or alternate access.  These devices
{     support both alternate access and redundant access.  Also the controller
{     number is always 0.  An FMD spindle will support alternate access from
{     two controllers but does not support redundnant controllers.  The 7155
{     controller does not support dual channel access but does support
{     redundant channels.
{     This algorithm will locate the controller connected to the specified
{     channel and unit. The CONTROLLER_P parameter will contain a
{     pointer to this controller if an active path to the controller exists. The
{     REDUNDANT_PATH parameter will be set to TRUE if the specified channel
{     is the primary channel for the controller and will be set to FALSE
{     otherwise.

  PROCEDURE select_7155_controller
    (    pp: iot$pp_number;
         unit_p: ^cmt$peripheral_element_entry;
     VAR controller_p: ^cmt$peripheral_element_entry;
     VAR redundant_path: boolean);

    VAR
      channel: cmt$physical_address,
      channel_element_p: ^cmt$peripheral_element_entry,
      channel_found: boolean,
      connection_status: cmt$connection_status,
      controller: cmt$physical_address,
      controller_element_p: ^cmt$peripheral_element_entry,
      path_index: integer,
      pp_channel: cmt$physical_address,
      primary_channel: cmt$physical_address,
      primary_channel_found: boolean,
      primary_controller_p: ^cmt$peripheral_element_entry,
      storage_device_element_p: ^cmt$peripheral_element_entry,
      stored_primary_channel: cmt$physical_address,
      unit_path: cmt$physical_address;

    channel_found := FALSE;
    controller_p := NIL;
    primary_channel_found := FALSE;
    primary_controller_p := NIL;
    redundant_path := FALSE;

    pp_channel.address_specifier := cmv$data_channel_address;
    pp_channel.iou := cmv$logical_pp_table_p^ [pp].pp_info.channel.iou_number;
    pp_channel.channel.number := cmv$logical_pp_table_p^ [pp].pp_info.channel.number;
    pp_channel.channel.port := cmv$logical_pp_table_p^ [pp].pp_info.channel_port;
    pp_channel.channel.concurrent :=
          (cmv$logical_pp_table_p^ [pp].pp_info.channel.channel_protocol = dsc$cpt_cio);
    pp_channel.channel_address := 0;
    pp_channel.unit_address := 0;
    IF unit_p = NIL THEN
      RETURN;
    IFEND;

    path_index := LOWERBOUND (unit_p^.physical_descriptor.unit_path^);

  /find_primary_path/
    WHILE path_index <= UPPERBOUND (unit_p^.physical_descriptor.unit_path^) DO
      unit_path := unit_p^.physical_descriptor.unit_path^ [path_index];
      path_index := path_index + 1;

      get_controller_physical_address (unit_path, controller);
      cmp$locate_element_via_adr (controller, controller_element_p);
      IF (controller_element_p = NIL) OR (controller_element_p^.element_status.state <> cmc$on) THEN
        CYCLE /find_primary_path/;
      IFEND;
      {
      { Check the controller/unit connection status.
      {
      get_connection_status (controller_element_p, unit_p^.element_name, connection_status);
      IF connection_status <> cmc$active THEN
        CYCLE /find_primary_path/;
      IFEND;

      get_channel_physical_address (unit_path, channel);
      cmp$locate_element_via_adr (channel, channel_element_p);
      IF (channel_element_p = NIL) OR (channel_element_p^.element_status.state <> cmc$on) THEN
        CYCLE /find_primary_path/;
      IFEND;
      {
      { Check the channel/controller connection status.
      {
      get_connection_status (channel_element_p, controller_element_p^.element_name, connection_status);
      IF connection_status <> cmc$active THEN
        CYCLE /find_primary_path/;
      IFEND;

      IF NOT primary_channel_found THEN
        primary_channel_found := TRUE;
        primary_channel := channel;
        primary_controller_p := controller_element_p;
      IFEND;

      IF controller_element_p^.element_name <> primary_controller_p^.element_name THEN
        primary_channel := channel;
        primary_controller_p := controller_element_p;
      IFEND;

      IF channel = pp_channel THEN
        channel_found := TRUE;
        EXIT /find_primary_path/;
      IFEND;
    WHILEND /find_primary_path/;

    IF channel_found THEN
      controller_p := controller_element_p;
      redundant_path := (pp_channel <> primary_channel);
    IFEND;

    IF cmv$debug = 04(16) THEN
      mtp$error_stop ('Debug stop 04(16) select_7155_controller.');
    IFEND;

  PROCEND select_7155_controller;

?? TITLE := ' setup_redundant_path_info', EJECT ??

{ PURPOSE:
{   This procedure sets up information about a redundant path.

  PROCEDURE setup_redundant_path_info
    (    channel: cmt$physical_address;
     VAR number_of_path: integer;
     VAR pp_available: boolean;
     VAR pp_table_rma_list: array [cmt$physical_equipment_number] of ost$real_memory_address;
     VAR redundant_path_pp_list: array [cmt$physical_equipment_number] of iot$pp_number;
     VAR redundant_channel_list: array [cmt$physical_equipment_number] of cmt$physical_address);

    VAR
      found_pp: boolean,
      logical_pp: iot$pp_number;

    pp_available := FALSE;
    get_logical_pp (channel, logical_pp, found_pp);
    IF found_pp AND cmv$logical_pp_table_p^ [logical_pp].flags.pp_loaded THEN
      pp_available := TRUE;
      number_of_path := number_of_path + 1;
      pp_table_rma_list [number_of_path] :=
            cmv$logical_pp_table_p^ [logical_pp].pp_info.pp_interface_table_rma;
      redundant_path_pp_list [number_of_path] := logical_pp;
      redundant_channel_list [number_of_path] := channel;
    IFEND;
  PROCEND setup_redundant_path_info;

MODEND cmm$monitor_job_mode_interfaces;
*DECK DECK=CMM$MONITOR_ROUTINES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE CM : Monitor Routines' ??
MODULE cmm$monitor_routines;

{ PURPOSE:
{   This module contains the interfaces executing in the monitor environment, performing various
{   configuration management tasks such as idle/resume of a pp, reload of the system device driver
{   and changing the state of an element.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cme$physical_configuration_mgr
*copyc cmt$connection
*copyc cmt$iou_table
*copyc cmt$logical_pp_table
*copyc cmt$logical_unit_table
*copyc cmt$peripheral_element_table
*copyc cmt$request_block
*copyc cmt$system_device_pp
*copyc ioe$st_errors
*copyc iot$channel_interlock_table
*copyc iot$cio_channel_interlock_table
*copyc iot$command
*copyc iot$disk_request
*copyc ost$exchange_package
*copyc ost$monitor_stack
*copyc ost$spaa_entry
*copyc syt$smu_request_response_block
?? POP ??
*copyc cmp$find_redundant_path
*copyc cmp$locate_element_via_adr
*copyc cmp$locate_element_via_name
*copyc cmp$select_primary_controller
*copyc cmp$support_redundant_channel
*copyc cmp$verify_active_path_exists
*copyc dmp$volume_up
*copyc dpp$display_error
*copyc dsp$advance_ds_sequence_in_mtr
*copyc dsp$perform_cpu_pp_handshaking
*copyc i#real_memory_address
*copyc i#test_set_bit
*copyc iop$change_disk_channel
*copyc iop$change_disk_controller
*copyc iop$change_disk_unit
*copyc iop$check_idle_pps
*copyc iop$idle_path
*copyc iop$idle_resume
*copyc iop$process_io_completions
*copyc iop$queue_pp_request
*copyc mmp$assign_page_to_monitor
*copyc mmp$xtask_pva_to_sva
*copyc mtp$error_stop
*copyc mtp$set_status_abnormal
*copyc osp$set_locked_variable
?? EJECT ??
*copyc mtv$cst0
*copyc mtv$time_to_call_handshaking
*copyc osv$initial_monitor_xp
*copyc osv$page_size
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    cmv$data_channel_address: [XDCL, #GATE] cmt$physical_address_specifier := [cmc$iou, cmc$channel],
    cmv$controller_address: [XDCL, #GATE] cmt$physical_address_specifier :=
          [cmc$iou, cmc$channel, cmc$channel_address],
    cmv$mass_storage_address: [XDCL, #GATE] cmt$physical_address_specifier :=
          [cmc$iou, cmc$channel, cmc$channel_address, cmc$unit_address],
    cmv$hydra_mass_storage_address: [XDCL, #GATE] cmt$physical_address_specifier :=
          [cmc$iou, cmc$channel, cmc$unit_address];

  VAR
    cmv$acquire_pp_for_redundant_ch: [XDCL, #GATE] boolean := TRUE,
    cmv$debug: [XDCL, #GATE] 0..255 := 0,
    cmv$debug_stop: [XDCL, #GATE] boolean := FALSE,
    cmv$default_response_handler: [XDCL, #GATE] iot$response_processor := ^cmp$default_response_handler,
    cmv$enable_auto_reconfiguration: [XDCL, #GATE] boolean := TRUE,
    cmv$enable_head_shift_message: [XDCL, #GATE] boolean := TRUE,
    cmv$iou_table_p: [XDCL, #GATE] ^ARRAY [ * ] OF cmt$iou_table := NIL,
    cmv$logical_pp_table_p: [XDCL, #GATE] ^cmt$logical_pp_table := NIL,
    cmv$logical_unit_table: [XDCL, #GATE] ^cmt$logical_unit_table := NIL,
    cmv$max_number_of_pp: [XDCL, #GATE] iot$pp_number := 0,
    cmv$new_logical_pp_table_p: [XDCL, #GATE] ^cmt$logical_pp_table := NIL,
    cmv$new_logical_unit_table: [XDCL, #GATE] ^cmt$logical_unit_table := NIL,
    cmv$peripheral_element_table: [XDCL, #GATE] cmt$peripheral_element_table := [[0], NIL],
    cmv$system_device_pp: [XDCL, #GATE] cmt$system_device_pp := [FALSE, [0, dsc$cpt_nio, 31(8)], FALSE];
?? OLDTITLE ??
?? NEWTITLE := 'assign_stack_segment', EJECT ??

  PROCEDURE assign_stack_segment
    (    fba_p: ^cell;
     VAR rma: integer;
     VAR status: syt$monitor_status);

    VAR
      initxp_p: ^ost$exchange_package,
      stk_p: ^ost$monitor_stack;

    mmp$assign_page_to_monitor (fba_p, 1, FALSE, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF rma = 0 THEN
      i#real_memory_address (fba_p, rma);
      stk_p := fba_p;
      initxp_p := ^osv$initial_monitor_xp;
      stk_p^.xp := initxp_p^;
      stk_p^.xp.a1_current_stack_frame := ^stk_p^.stack;
      stk_p^.xp.a0_dynamic_space_pointer := ^stk_p^.csf;
      stk_p^.xp.tos_registers [1].pva.ring := #RING (^stk_p^.stack);
      stk_p^.xp.tos_registers [1].pva.seg := #SEGMENT (^stk_p^.stack);
      stk_p^.xp.tos_registers [1].pva.offset := #OFFSET (^stk_p^.stack);
    IFEND;

  PROCEND assign_stack_segment;
?? OLDTITLE ??
?? NEWTITLE := 'build_affected_pp_tables', EJECT ??

{ PURPOSE:
{   This procedure rebuilds the pp_interface table for the PP's that service the specified element.  If a
{   channel is specified only one PP is affected, however; if a controller is specified the PP for each
{   channel connected to the controller is affected.  The interface cmp$change_state is used to rebuild the
{   PP interface tables. The state of the element is not actually changed and is assumed to be ON.
{ NOTE:
{   This code is executed only during the UNSTEP_SYSTEM monitor command.

  PROCEDURE build_affected_pp_tables
    (    element_entry_p: ^cmt$peripheral_element_entry);

    VAR
      channel_address: cmt$physical_address,
      disabled_connection_found: boolean,
      driver_name: pmt$program_name,
      first_unit: iot$logical_unit,
      found: boolean,
      i: integer,
      lun_list_p: ^ARRAY [ * ] OF cmt$rb_logical_unit_address,
      monitor_status: syt$monitor_status,
      number_of_path: integer,
      pete_p: ^cmt$peripheral_element_entry,
      physical_address: cmt$physical_address,
      pp: iot$pp_number,
      pp_count: iot$pp_number,
      pp_table_rma_list: ARRAY [cmt$physical_equipment_number] OF ost$real_memory_address,
      redundant_channel_list: ARRAY [cmt$physical_equipment_number] OF cmt$physical_address,
      redundant_path_available: boolean,
      redundant_path_pp_list: ARRAY [cmt$physical_equipment_number] OF iot$pp_number,
      request_block: cmt$request_block,
      unit_count: integer,
      update_controller_address: boolean;

    dsp$perform_cpu_pp_handshaking;
    dpp$display_error(element_entry_p^.element_name);

    CASE element_entry_p^.physical_descriptor.element_type OF
    = cmc$data_channel_element =

      { Search Logical pp table to find pp servicing this channel.  Build monitor_request for this PP.
      { Call change_state.

      physical_address := element_entry_p^.physical_descriptor.channel_path;

    /search_pp_table/
      FOR pp := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
        IF NOT cmv$logical_pp_table_p^ [pp].flags.configured THEN
          CYCLE /search_pp_table/;
        IFEND;

        IF cmv$logical_pp_table_p^ [pp].pp_info.channel.iou_number <> physical_address.iou THEN
          CYCLE /search_pp_table/;
        IFEND;

        first_unit := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.first_logical_unit;
        unit_count := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.number_of_units;

        IF cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.unit_descriptors [first_unit].
              physical_path.channel_number <> physical_address.channel.number THEN
          CYCLE /search_pp_table/;
        IFEND;

        IF cmv$logical_pp_table_p^ [pp].pp_info.channel_interlock_p^.
              channel_characteristics [physical_address.channel.number].concurrent_channel <>
              physical_address.channel.concurrent THEN
          CYCLE /search_pp_table/;
        IFEND;

        found := TRUE;
        EXIT /search_pp_table/;

      FOREND /search_pp_table/;

      IF NOT found THEN
        RETURN;
      IFEND;

      request_block.status.normal := TRUE;
      request_block.kind := cmc$rbk_change_state;
      request_block.iou := physical_address.iou;
      request_block.element_name := element_entry_p^.element_name;
      request_block.new_state := cmc$on;
      request_block.update_controller_address := TRUE;
      request_block.redundant_path_available :=
            cmp$support_redundant_channel (cmv$logical_pp_table_p^ [pp].controller_info.controller_type);
      request_block.update_controller_address := TRUE;
      request_block.element_type := cmc$data_channel_element;
      request_block.channel_pp := pp;
      request_block.channel := physical_address.channel.number;

      cmp$find_redundant_path (physical_address, cmc$on, redundant_path_available, update_controller_address,
            number_of_path, redundant_channel_list, redundant_path_pp_list, driver_name, pp_table_rma_list);
      IF redundant_path_available THEN
        PUSH request_block.redundant_path_pp_list_p: [0 .. number_of_path];
        FOR i := 0 to number_of_path DO
          request_block.redundant_path_pp_list_p^ [i] := redundant_path_pp_list[i];
        FOREND;
      ELSE
        PUSH request_block.redundant_path_pp_list_p: [0 .. 0];
        request_block.redundant_path_pp_list_p^ [0] := pp;
      IFEND;

      PUSH lun_list_p: [1 .. unit_count];
      setup_lun_list (pp, physical_address, {update_controller_address} FALSE, lun_list_p, unit_count);

      PUSH request_block.logical_unit_list_p: [1 .. unit_count];
      FOR i := 1 TO unit_count DO
        request_block.logical_unit_list_p^ [i] := lun_list_p^ [i];
      FOREND;

      change_state (request_block, monitor_status);

    = cmc$controller_element =

      { Search Logical pp table to find pp(s) for all channels connected to this controller.
      { Build monitor_request for these PPs.  Call change_state.

      physical_address := element_entry_p^.physical_descriptor.equipment_path^ [1];
      request_block.status.normal := TRUE;
      request_block.kind := cmc$rbk_change_state;
      request_block.iou := physical_address.iou;
      request_block.element_name := element_entry_p^.element_name;
      request_block.new_state := cmc$on;
      request_block.redundant_path_available := TRUE;
      request_block.update_controller_address := TRUE;
      request_block.element_type := cmc$controller_element;

      pp_count := UPPERBOUND (element_entry_p^.physical_descriptor.equipment_path^);
      PUSH request_block.redundant_path_pp_list_p: [0 .. (pp_count - 1)];

    /process_channel/
      FOR i := 1 TO pp_count DO
        physical_address := element_entry_p^.physical_descriptor.equipment_path^ [i];
        channel_address := physical_address;
        channel_address.address_specifier := cmv$data_channel_address;
        channel_address.channel_address := 0;

      /search_pp_table_2/
        FOR pp := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
          IF NOT cmv$logical_pp_table_p^ [pp].flags.configured THEN
            CYCLE /search_pp_table_2/;
          IFEND;

          IF cmv$logical_pp_table_p^ [pp].pp_info.channel.iou_number <> physical_address.iou THEN
            CYCLE /search_pp_table_2/;
          IFEND;

          first_unit := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.first_logical_unit;
          unit_count := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.number_of_units;

          IF cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.unit_descriptors [first_unit].
                physical_path.channel_number <> physical_address.channel.number THEN
            CYCLE /search_pp_table_2/;
          IFEND;

          IF cmv$logical_pp_table_p^ [pp].pp_info.channel_interlock_p^.
                channel_characteristics [physical_address.channel.number].concurrent_channel <>
                physical_address.channel.concurrent THEN
            CYCLE /search_pp_table_2/;
          IFEND;

          found := TRUE;
          EXIT /search_pp_table_2/;

        FOREND /search_pp_table_2/;

        IF NOT found THEN
          RETURN;
        IFEND;

        IF i = 1 THEN
          request_block.controller_pp := pp;
          request_block.controller_channel := physical_address.channel.number;
          request_block.controller := physical_address.channel_address;
          request_block.redundant_path_pp_list_p^ [i - 1] := pp;
        ELSE
          request_block.redundant_path_pp_list_p^ [i - 1] := pp;
        IFEND;

      FOREND /process_channel/;

      PUSH lun_list_p: [1 .. unit_count];
      setup_lun_list (request_block.controller_pp, physical_address, {update_controller_address} FALSE,
            lun_list_p, unit_count);

      PUSH request_block.logical_unit_list_p: [1 .. unit_count];
      FOR i := 1 TO unit_count DO
        request_block.logical_unit_list_p^ [i] := lun_list_p^ [i];
      FOREND;

      change_state (request_block, monitor_status);
    ELSE
    CASEND;

  PROCEND build_affected_pp_tables;
?? OLDTITLE ??
?? NEWTITLE := 'change_state', EJECT ??

{ PURPOSE:
{   This procedure performs the state change of a mass storage channel, controller, or unit.

  PROCEDURE change_state
    (    request_block: cmt$request_block;
     VAR status: syt$monitor_status);

    VAR
      found: boolean,
      ignore_state: cmt$element_state,
      index_1: integer,
      index_2: integer,
      logical_pp: iot$pp_number,
      lppit_p: ^iot$pp_interface_table,
      lun: iot$logical_unit,
      lun2: iot$logical_unit,
      old_state: cmt$element_state,
      physical_channel: cmt$physical_channel,
      pp: iot$pp_number,
      ppit_p: ^iot$pp_interface_table,
      pp_list: ARRAY [0 .. 0] OF iot$pp_number,
      rma: integer;

    status.normal := TRUE;

    IF cmv$debug = 010(16) THEN
      mtp$error_stop (' Debug stop 010(16) change_state.');
    IFEND;

    update_peripheral_element_table (request_block, request_block.new_state, old_state);

    CASE request_block.element_type OF
    = cmc$data_channel_element =
      pp := request_block.channel_pp;
    = cmc$controller_element =
      pp := request_block.controller_pp;
    = cmc$storage_device_element =
      pp := request_block.unit_pp;
    ELSE
    CASEND;

    IF request_block.redundant_path_available THEN
      IF cmv$logical_pp_table_p^ [pp].flags.pp_loaded THEN
        idle_pp_in_mtr (pp, TRUE, status);
      IFEND;

      { Idle all redundant pp. Also if any PP is disabled because one of the controller on the channel is
      { being DOWN/OFF, it should be re-enabled to allow access to the units on the primary channel,
      { accessible possibly from different controllers.

      FOR index_1 := LOWERBOUND (request_block.redundant_path_pp_list_p^)
            TO UPPERBOUND (request_block.redundant_path_pp_list_p^) DO
        IF cmv$logical_pp_table_p^ [request_block.redundant_path_pp_list_p^ [index_1]].flags.disabled THEN
          cmv$logical_pp_table_p^ [request_block.redundant_path_pp_list_p^ [index_1]].flags.disabled := FALSE;
        IFEND;
        idle_pp_in_mtr (request_block.redundant_path_pp_list_p^ [index_1], TRUE, status);
      FOREND;

      pp_list [0] := pp;
      IF request_block.new_state = cmc$on THEN
        IF cmv$logical_pp_table_p^ [pp].flags.pp_loaded THEN
          change_unit_descriptors (request_block.update_controller_address,
                request_block.redundant_path_pp_list_p^, pp_list, request_block.logical_unit_list_p);
        IFEND;
      ELSE
        change_unit_descriptors (request_block.update_controller_address, pp_list,
              request_block.redundant_path_pp_list_p^, request_block.logical_unit_list_p);
      IFEND;

      { Ignore the status for the current channel. This pp could be disabled as a
      { result of a channel failure, therefore a RESUME request will return an error.

      IF cmv$logical_pp_table_p^ [pp].flags.pp_loaded THEN
        resume_pp_in_mtr (pp, TRUE, status);
      IFEND;

      FOR index_1 := LOWERBOUND (request_block.redundant_path_pp_list_p^)
            TO UPPERBOUND (request_block.redundant_path_pp_list_p^) DO
        IF cmv$logical_pp_table_p^ [request_block.redundant_path_pp_list_p^ [index_1]].flags.pp_loaded THEN
          resume_pp_in_mtr (request_block.redundant_path_pp_list_p^ [index_1], TRUE, status);
        IFEND;
      FOREND;

      RETURN;
    IFEND;

    IF cmv$debug = 011(16) THEN
      mtp$error_stop (' Debug stop 011(16) change_state.');
    IFEND;

    IF ((request_block.element_type = cmc$data_channel_element) OR
          (request_block.element_type = cmc$controller_element)) AND (request_block.new_state = cmc$on) THEN

      { Make sure all unit descriptors have valid RMA if channel is turned ON.

      ppit_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;
    /lun_loop/
      FOR lun := LOWERBOUND (ppit_p^.unit_descriptors) TO UPPERBOUND (ppit_p^.unit_descriptors) DO
        IF ppit_p^.unit_descriptors[lun].unit_interface_table = NIL THEN
          CYCLE /lun_loop/;
        IFEND;

        IF ppit_p^.unit_descriptors[lun].unit_interface_table_rma <> 0 THEN
          CYCLE /lun_loop/;
        IFEND;

        CASE request_block.element_type OF
        = cmc$data_channel_element =
          i#real_memory_address (#LOC (cmv$logical_unit_table^ [lun].unit_interface_table^), rma);
          ppit_p^.unit_descriptors [lun].unit_interface_table_rma := rma;
        = cmc$controller_element =
          IF ppit_p^.unit_descriptors [lun].physical_path.controller_number = request_block.controller THEN
            i#real_memory_address (#LOC (cmv$logical_unit_table^ [lun].unit_interface_table^), rma);
            ppit_p^.unit_descriptors [lun].unit_interface_table_rma := rma;
          IFEND;
        ELSE
        CASEND;

        { Now make sure Unit descriptors of any other redundant channel have a zero value
        { RMA for its Unit interface table, if there is no PP assigned.

      /search_lun/
        FOR logical_pp := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
          IF logical_pp = pp THEN
            CYCLE /search_lun/;
          IFEND;

          IF NOT cmv$logical_pp_table_p^ [logical_pp].flags.configured THEN
            CYCLE /search_lun/;
          IFEND;

          IF cmv$logical_pp_table_p^ [logical_pp].flags.pp_loaded THEN
            CYCLE /search_lun/;
          IFEND;

          lppit_p := cmv$logical_pp_table_p^ [logical_pp].pp_info.pp_interface_table_p;
          IF lun < LOWERBOUND(lppit_p^.unit_descriptors) THEN
            CYCLE /search_lun/;
          IFEND;

          IF lun > UPPERBOUND(lppit_p^.unit_descriptors) THEN
            CYCLE /search_lun/;
          IFEND;

        /lun_loop_2/
          FOR lun2 := LOWERBOUND(lppit_p^.unit_descriptors) TO UPPERBOUND(lppit_p^.unit_descriptors) DO
            IF lppit_p^.unit_descriptors[lun2].unit_interface_table = NIL THEN
              CYCLE /lun_loop_2/;
            IFEND;

            IF lppit_p^.unit_descriptors[lun2].unit_interface_table_rma = 0 THEN
              CYCLE /lun_loop_2/;
            IFEND;

            lppit_p^.unit_descriptors[lun2].unit_interface_table_rma := 0;
            EXIT /lun_loop_2/;
          FOREND /lun_loop_2/;
        FOREND /search_lun/;

      FOREND /lun_loop/;
    IFEND;

    IF cmv$debug = 012(16) THEN
      mtp$error_stop (' Debug stop 012(16) change_state.');
    IFEND;

    CASE request_block.element_type OF
    = cmc$data_channel_element =
      iop$change_disk_channel (request_block.new_state, request_block.channel_pp, request_block.channel,
            status);
      IF NOT status.normal THEN
        update_peripheral_element_table (request_block, old_state, ignore_state);
        RETURN;
      IFEND;

    = cmc$controller_element =
      iop$change_disk_controller (request_block.new_state, request_block.controller_pp,
            request_block.controller_channel, request_block.controller, status);
      IF NOT status.normal THEN
        update_peripheral_element_table (request_block, old_state, ignore_state);
        RETURN;
      IFEND;

    = cmc$storage_device_element =
      iop$change_disk_unit (request_block.new_state, request_block.logical_unit, status);
      IF NOT status.normal THEN
        update_peripheral_element_table (request_block, old_state, ignore_state);
        RETURN;
      IFEND;
    ELSE
    CASEND;

  PROCEND change_state;
?? OLDTITLE ??
?? NEWTITLE := 'change_unit_descriptors', EJECT ??

{ PURPOSE:
{   This procedure updates the Unit Interface Table's RMA of unit descriptors to enable or disable access to
{   these units.

  PROCEDURE change_unit_descriptors
    (    update_controller_address: boolean;
         pp_to_clear_list: ARRAY [ * ] OF iot$pp_number;
         pp_to_set_list: ARRAY [ * ] OF iot$pp_number;
         logical_unit_list_p: ^ARRAY [ * ] OF cmt$rb_logical_unit_address);

    VAR
      found: boolean,
      ignore_status: syt$monitor_status,
      logical_unit: iot$logical_unit,
      lun_index: integer,
      mass_storage_device: boolean,
      pp: iot$pp_number,
      ppit_p: ^iot$pp_interface_table,
      pp_index: integer,
      primary_channel_p: ^cmt$peripheral_element_entry,
      primary_controller_p: ^cmt$peripheral_element_entry,
      redundant_path: boolean,
      rma: integer,
      ud: iot$logical_unit;

    mass_storage_device := cmv$logical_pp_table_p^ [pp_to_set_list [0]].controller_info.controller_type <>
          cmc$mt5698_xx;
    IF logical_unit_list_p = NIL THEN
      RETURN;
    IFEND;

    IF cmv$debug = 013(16) THEN
      mtp$error_stop (' Debug stop 013(16) change_unit_descriptors.');
    IFEND;

  /lun_loop_1/
    FOR lun_index := LOWERBOUND (logical_unit_list_p^) TO UPPERBOUND (logical_unit_list_p^) DO
      logical_unit := logical_unit_list_p^ [lun_index].logical_unit;

    /pp_loop_1/
      FOR pp_index := LOWERBOUND (pp_to_clear_list) TO UPPERBOUND (pp_to_clear_list) DO
        pp := pp_to_clear_list [pp_index];
        ppit_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;

        IF logical_unit < LOWERBOUND(ppit_p^.unit_descriptors) THEN
          CYCLE /pp_loop_1/;
        IFEND;

        IF logical_unit > UPPERBOUND(ppit_p^.unit_descriptors) THEN
          CYCLE /pp_loop_1/;
        IFEND;

        IF ppit_p^.unit_descriptors [logical_unit].unit_interface_table = NIL THEN
          CYCLE /pp_loop_1/;
        IFEND;

        IF ppit_p^.unit_descriptors [logical_unit].logical_unit <> logical_unit THEN
          CYCLE /pp_loop_1/;
        IFEND;

        cmp$select_primary_controller (pp, logical_unit, primary_controller_p, primary_channel_p,
              redundant_path);
        IF primary_controller_p <> NIL THEN
          ppit_p^.unit_descriptors [logical_unit].physical_path.controller_number :=
                primary_controller_p^.physical_descriptor.equipment_path^ [1].channel_address;
          IF redundant_path THEN
            ppit_p^.unit_descriptors [logical_unit].unit_interface_table_rma := 0;
          ELSE
            reenable_unit (logical_unit);
            i#real_memory_address (#LOC (cmv$logical_unit_table^ [logical_unit].unit_interface_table^), rma);
            ppit_p^.unit_descriptors [logical_unit].unit_interface_table_rma := rma;
          IFEND;
        ELSE
          ppit_p^.unit_descriptors [logical_unit].unit_interface_table_rma := 0;
          CYCLE /pp_loop_1/;
        IFEND;

        IF primary_channel_p <> NIL THEN
          IF primary_channel_p^.physical_descriptor.channel_path.channel.port = cmc$port_b THEN
            ppit_p^.unit_descriptors [logical_unit].physical_path.port := 1;
          ELSE
            ppit_p^.unit_descriptors [logical_unit].physical_path.port := 0;
          IFEND;
        IFEND;

        IF cmv$debug = 014(16) THEN
          mtp$error_stop (' Debug stop 014(16) cmp$change_unit_descriptors.');
        IFEND;

      FOREND /pp_loop_1/;
    FOREND /lun_loop_1/;

  /lun_loop_2/
    FOR lun_index := LOWERBOUND (logical_unit_list_p^) TO UPPERBOUND (logical_unit_list_p^) DO
      logical_unit := logical_unit_list_p^ [lun_index].logical_unit;
      found := FALSE;

    /pp_loop_2/
      FOR pp_index := LOWERBOUND (pp_to_set_list) TO UPPERBOUND (pp_to_set_list) DO
        pp := pp_to_set_list [pp_index];
        ppit_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;

        IF logical_unit < LOWERBOUND(ppit_p^.unit_descriptors) THEN
          CYCLE /pp_loop_2/;
        IFEND;

        IF logical_unit > UPPERBOUND(ppit_p^.unit_descriptors) THEN
          CYCLE /pp_loop_2/;
        IFEND;

        IF ppit_p^.unit_descriptors [logical_unit].unit_interface_table = NIL THEN
          CYCLE /pp_loop_2/;
        IFEND;

        IF ppit_p^.unit_descriptors [logical_unit].logical_unit <> logical_unit THEN
          CYCLE /pp_loop_2/;
        IFEND;

        reenable_unit (logical_unit);
        i#real_memory_address (#LOC (cmv$logical_unit_table^ [logical_unit].unit_interface_table^), rma);

        cmp$select_primary_controller (pp, logical_unit, primary_controller_p, primary_channel_p,
              redundant_path);
        IF primary_controller_p <> NIL THEN
          ppit_p^.unit_descriptors [logical_unit].physical_path.controller_number :=
                primary_controller_p^.physical_descriptor.equipment_path^ [1].channel_address;
          IF redundant_path THEN
            ppit_p^.unit_descriptors [logical_unit].unit_interface_table_rma := 0;
          ELSE
            ppit_p^.unit_descriptors [logical_unit].unit_interface_table_rma := rma;
          IFEND;
        ELSE
          ppit_p^.unit_descriptors [logical_unit].unit_interface_table_rma := 0;
          CYCLE /pp_loop_2/;
        IFEND;

        IF primary_channel_p <> NIL THEN
          IF primary_channel_p^.physical_descriptor.channel_path.channel.port = cmc$port_b THEN
            ppit_p^.unit_descriptors [logical_unit].physical_path.port := 1;
          ELSE
            ppit_p^.unit_descriptors [logical_unit].physical_path.port := 0;
          IFEND;
        IFEND;

        IF cmv$debug = 015(16) THEN
          mtp$error_stop (' Debug stop 015(16) cmp$change_unit_descriptors.');
        IFEND;

        found := TRUE;
      FOREND /pp_loop_2/;

      { A logical unit in the list was not found. This means that the unit has only one path
      { and that path was disabled. The unit must be disabled. Job mode routine CMP$CHANGE_STATE_R1
      { has already verified that this is a non critical device.

      IF (NOT found) AND mass_storage_device THEN
        iop$change_disk_unit (cmc$down, logical_unit, ignore_status);
      IFEND;
    FOREND /lun_loop_2/;

  PROCEND change_unit_descriptors;
?? OLDTITLE ??
?? NEWTITLE := 'enable_unit', EJECT ??

  PROCEDURE enable_unit
    (    unit_interface_table_p: ^iot$unit_interface_table);

    IF unit_interface_table_p <> NIL THEN
      unit_interface_table_p^.unit_lockword.lock := FALSE;
      unit_interface_table_p^.unit_lockword.lock_owner.cpu_lock := FALSE;
      unit_interface_table_p^.unit_lockword.lock_owner.fill := 0;
      unit_interface_table_p^.unit_lockword.lock_owner.pp_number := 0;
      unit_interface_table_p^.unit_q_lockword.lock := FALSE;
      unit_interface_table_p^.unit_q_lockword.lock := FALSE;
      unit_interface_table_p^.unit_q_lockword.lock_owner.cpu_lock := FALSE;
      unit_interface_table_p^.unit_q_lockword.lock_owner.fill := 0;
      unit_interface_table_p^.unit_q_lockword.lock_owner.pp_number := 0;
      unit_interface_table_p^.next_request := NIL;
      unit_interface_table_p^.next_request_rma := 0;
      unit_interface_table_p^.unit_status.disabled := FALSE;
    IFEND;

  PROCEND enable_unit;
?? OLDTITLE ??
?? NEWTITLE := 'get_channel_physical_address', EJECT ??

{ PURPOSE:
{   This procedure sets up the physical address specifier and physical address
{   of the channel element given the controller address or unit address of an element.

  PROCEDURE [INLINE] get_channel_physical_address
    (    controller_physical_address: cmt$physical_address;
     VAR channel_physical_address: cmt$physical_address);

    channel_physical_address.address_specifier := cmv$data_channel_address;
    channel_physical_address.iou := controller_physical_address.iou;
    channel_physical_address.channel := controller_physical_address.channel;
    channel_physical_address.channel_address := 0;
    channel_physical_address.unit_address := 0;

  PROCEND get_channel_physical_address;
?? OLDTITLE ??
?? NEWTITLE := 'get_controller_address', EJECT ??

{ PURPOSE:
{   This procedure returns the redundant controller number given the primary path address and the logical
{   unit.

  PROCEDURE get_controller_address
    (    primary_path: cmt$physical_address;
         logical_unit: iot$logical_unit;
     VAR controller_address: cmt$physical_equipment_number);

    VAR
      channel: cmt$physical_address,
      channel_element_p: ^cmt$peripheral_element_entry,
      controller: cmt$physical_address,
      controller_element_p: ^cmt$peripheral_element_entry,
      entry: cmt$peripheral_element_entry,
      path_index: integer,
      table_index: integer;

    controller.address_specifier := cmv$controller_address;
    channel.address_specifier := cmv$data_channel_address;

  /search_unit/
    FOR table_index := LOWERBOUND (cmv$peripheral_element_table.pointer^)
          TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
      IF NOT cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.configured THEN
        CYCLE /search_unit/;
      IFEND;

      IF logical_unit = cmv$peripheral_element_table.pointer^ [table_index].logical_unit_number THEN
        entry := cmv$peripheral_element_table.pointer^ [table_index];
        EXIT /search_unit/;
      IFEND;
    FOREND /search_unit/;

    IF primary_path.address_specifier = cmv$data_channel_address THEN
      FOR path_index := LOWERBOUND (entry.physical_descriptor.unit_path^)
            TO UPPERBOUND (entry.physical_descriptor.unit_path^) DO
        IF NOT ((entry.physical_descriptor.unit_path^ [path_index].iou = primary_path.iou) AND
              (entry.physical_descriptor.unit_path^ [path_index].channel = primary_path.channel)) THEN
          controller.iou := entry.physical_descriptor.unit_path^ [path_index].iou;
          controller.channel := entry.physical_descriptor.unit_path^ [path_index].channel;
          controller.channel_address := entry.physical_descriptor.unit_path^ [path_index].channel_address;

          cmp$locate_element_via_adr (controller, controller_element_p);
          IF (controller_element_p <> NIL) AND (controller_element_p^.element_status.state = cmc$on) THEN
            channel.iou := entry.physical_descriptor.unit_path^ [path_index].iou;
            channel.channel := entry.physical_descriptor.unit_path^ [path_index].channel;

            cmp$locate_element_via_adr (channel, channel_element_p);
            IF (channel_element_p <> NIL) AND (channel_element_p^.element_status.state = cmc$on) THEN
              controller_address := controller.channel_address;
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      FOREND;
    ELSE

      { For controller and unit, look for different controller address connected to the unit and check both
      { channel/controller state.

      FOR path_index := LOWERBOUND (entry.physical_descriptor.unit_path^)
            TO UPPERBOUND (entry.physical_descriptor.unit_path^) DO
        IF NOT (entry.physical_descriptor.unit_path^ [path_index].channel_address =
              primary_path.channel_address) THEN
          controller.iou := entry.physical_descriptor.unit_path^ [path_index].iou;
          controller.channel := entry.physical_descriptor.unit_path^ [path_index].channel;
          controller.channel_address := entry.physical_descriptor.unit_path^ [path_index].channel_address;
          cmp$locate_element_via_adr (controller, controller_element_p);
          IF (controller_element_p <> NIL) AND (controller_element_p^.element_status.state = cmc$on) THEN
            channel.iou := entry.physical_descriptor.unit_path^ [path_index].iou;
            channel.channel := entry.physical_descriptor.unit_path^ [path_index].channel;
            cmp$locate_element_via_adr (channel, channel_element_p);
            IF (channel_element_p <> NIL) AND (channel_element_p^.element_status.state = cmc$on) THEN
              controller_address := controller.channel_address;
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      FOREND;
    IFEND;

  PROCEND get_controller_address;
?? OLDTITLE ??
?? NEWTITLE := 'get_controller_physical_address', EJECT ??

{ PURPOSE:
{   This procedure sets up the physical address specifier and physical address
{   path of the controller element given the full path of the unit.

  PROCEDURE [INLINE] get_controller_physical_address
    (    unit_physical_address: cmt$physical_address;
     VAR controller_physical_address: cmt$physical_address);

    controller_physical_address.address_specifier := cmv$controller_address;
    controller_physical_address.iou := unit_physical_address.iou;
    controller_physical_address.channel := unit_physical_address.channel;
    controller_physical_address.channel_address := unit_physical_address.channel_address;
    controller_physical_address.unit_address := 0;

  PROCEND get_controller_physical_address;
?? OLDTITLE ??
?? NEWTITLE := 'idle_pp_in_mtr', EJECT ??

{ PURPOSE:
{   This procedure sends a soft IDLE command to the PP, otherwise it only checks if the PP responded.

  PROCEDURE idle_pp_in_mtr
    (    logical_pp: iot$pp_number;
         send_idle: boolean;
     VAR status: syt$monitor_status);

    status.normal := TRUE;

    IF send_idle THEN
      iop$idle_path (logical_pp, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    iop$check_idle_pps;

  PROCEND idle_pp_in_mtr;
?? OLDTITLE ??
?? NEWTITLE := 'queue_pp_request', EJECT ??

{ PURPOSE:
{    This procedure queues PP request such as IDLE and RESUME.

  PROCEDURE queue_pp_request
    (    pp: iot$pp_number;
         io_request_p: ^iot$io_request;
     VAR status: syt$monitor_status);

    VAR
      count: 0 .. 0ff(16),
      disk_request_p: ^iot$disk_request,
      done: boolean,
      previously_set: boolean,
      ppit_p: ^iot$pp_interface_table,
      retry: integer,
      time: integer,
      timeout: integer;

    ppit_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;
    ppit_p^.pp_request_queue := NIL;
    ppit_p^.pp_request_queue_rma := 0;
    io_request_p^.response_processor_p := ^cmp$process_pp_response;
    disk_request_p := io_request_p^.device_request_p;

    { Interlock the pp_interface_table.

    time := #FREE_RUNNING_CLOCK (0);
    timeout := time + 2000000;
    count := 0;

    REPEAT
      i#test_set_bit (^ppit_p^, ioc$pp_interface_table_lock_bit, previously_set);
      count := count + 1;
      IF count >= 100 THEN
        time := #FREE_RUNNING_CLOCK (0);
        count := 0;
      IFEND;
    UNTIL (NOT previously_set) OR (time > timeout);

    IF previously_set THEN
      mtp$set_status_abnormal (ioc$subsystem_io_manager, ioc$pp_interlock_set, status);
      RETURN;
    IFEND;

    IF disk_request_p^.request.command [1].command_code = ioc$cc_idle THEN
      ppit_p^.idle_status := FALSE;
    ELSEIF disk_request_p^.request.command [1].command_code = ioc$cc_resume THEN
      ppit_p^.idle_status := TRUE;
    IFEND;

    ppit_p^.lock := FALSE;

    retry := 1;

  /queue_request/
    WHILE TRUE DO
      iop$queue_pp_request (ppit_p, io_request_p, status);

      IF NOT status.normal THEN
        IF status.condition = ioc$pp_interlock_set THEN
          retry := retry + 1;
          IF retry > 20 THEN
            EXIT /queue_request/;
          IFEND;
        ELSE

          EXIT /queue_request/;
        IFEND;
      ELSE
        EXIT /queue_request/;
      IFEND;
    WHILEND /queue_request/;

    time := #FREE_RUNNING_CLOCK (0);
    timeout := timeout + 1000;
    count := 0;
    done := FALSE;

    REPEAT
      iop$process_io_completions;
      IF disk_request_p^.request.command [1].command_code = ioc$cc_idle THEN
        done := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.idle_status;
      ELSEIF disk_request_p^.request.command [1].command_code = ioc$cc_resume THEN
        done := NOT cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.idle_status;
      IFEND;
      count := count + 1;
      IF count >= 100 THEN
        time := #FREE_RUNNING_CLOCK (0);
        count := 0;
      IFEND;
    UNTIL (done) OR (time >= timeout);

  PROCEND queue_pp_request;
?? OLDTITLE ??
?? NEWTITLE := 'reenable_unit', EJECT ??

  PROCEDURE reenable_unit
    (    logical_unit: iot$logical_unit);

    cmv$logical_unit_table^ [logical_unit].unit_interface_table^.unit_status.disabled := FALSE;

    { Set element capabilities.

    cmv$logical_unit_table^ [logical_unit].element_capability :=
          $cmt$element_capabilities [cmc$volume_assignment, cmc$io_request_submission,
          cmc$concurrent_maintenance];
    cmv$logical_unit_table^ [logical_unit].element_access := $cmt$element_access [cmc$read, cmc$write];
    dmp$volume_up (logical_unit);

  PROCEND reenable_unit;
?? OLDTITLE ??
?? NEWTITLE := 'resume_pp_in_mtr', EJECT ??

{ PURPOSE:
{   This procedure sends a soft resume to the PP otherwise it only checks the pp response.

  PROCEDURE resume_pp_in_mtr
    (    resumed_pp: iot$pp_number;
         send_resume: boolean;
     VAR status: syt$monitor_status);


    status.normal := TRUE;

    IF send_resume THEN
      iop$idle_resume (resumed_pp, ioc$ira_resume, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF cmv$logical_pp_table_p^ [resumed_pp].pp_info.pp_type <> cmc$lpt_disk_pp_type THEN
      iop$process_io_completions;
    IFEND;

  PROCEND resume_pp_in_mtr;
?? OLDTITLE ??
?? NEWTITLE := 'setup_lun_list', EJECT ??

{ PURPOSE:
{   This procedure sets up a list of logical_units accessible from the given primary path element.

  PROCEDURE setup_lun_list
    (    pp: iot$pp_number;
         primary_path: cmt$physical_address;
         update_controller_address: boolean;
         logical_unit_list_p: ^ARRAY [ * ] OF cmt$rb_logical_unit_address;
     VAR number_of_units: integer);

    VAR
      logical_unit: iot$logical_unit,
      storage_device: boolean,
      ppit_p: ^iot$pp_interface_table,
      lun: iot$logical_unit,
      unit_element_p: ^cmt$peripheral_element_entry;

    number_of_units := 0;
    storage_device := FALSE;
    ppit_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;

    IF ((primary_path.address_specifier = cmv$mass_storage_address) OR
          (primary_path.address_specifier = cmv$hydra_mass_storage_address)) THEN
      cmp$locate_element_via_adr (primary_path, unit_element_p);
      IF unit_element_p <> NIL THEN
        logical_unit := unit_element_p^.logical_unit_number;
        storage_device := TRUE;
      IFEND;
    IFEND;

  /loop/
    FOR lun := LOWERBOUND (ppit_p^.unit_descriptors) TO UPPERBOUND (ppit_p^.unit_descriptors) DO
      IF ppit_p^.unit_descriptors [lun].unit_interface_table = NIL THEN
        CYCLE /loop/;
      IFEND;

      IF storage_device AND (logical_unit <> lun) THEN
        CYCLE /loop/;
      IFEND;

      number_of_units := number_of_units + 1;
      logical_unit_list_p^ [number_of_units].logical_unit := lun;
      logical_unit_list_p^ [number_of_units].controller :=
            ppit_p^.unit_descriptors [lun].physical_path.controller_number;

      IF update_controller_address THEN

        { Find the controller number by taking the first ON controller other than the one connected to the
        { primary unit.

        get_controller_address (primary_path, lun, logical_unit_list_p^ [number_of_units].controller);
      IFEND;
    FOREND /loop/;
  PROCEND setup_lun_list;
?? OLDTITLE ??
?? NEWTITLE := 'update_logical_unit_state', EJECT ??

{ PURPOSE:
{   This procedure update the state in the logical unit table and also attempts to up a volume.

  PROCEDURE update_logical_unit_state
    (    logical_unit: iot$logical_unit;
         pp: iot$pp_number);

    VAR
      controller_path: cmt$physical_address,
      eq: integer,
      index: integer,
      table_index: integer;

    controller_path.address_specifier :=
          $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address];
    controller_path.iou := cmv$logical_pp_table_p^ [pp].pp_info.channel.iou_number;
    controller_path.channel.number := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
          unit_descriptors [logical_unit].physical_path.channel_number;
    controller_path.channel.concurrent := cmv$logical_pp_table_p^ [pp].pp_info.channel_interlock_p^.
          channel_characteristics [controller_path.channel.number].concurrent_channel;
    IF (controller_path.channel.concurrent AND (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
          unit_descriptors [logical_unit].unit_interface_table^.unit_type <> ioc$dt_ms895_2)) THEN
      IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.unit_descriptors [logical_unit].
            physical_path.port = 1) THEN
        controller_path.channel.port := cmc$port_b;
      ELSE
        controller_path.channel.port := cmc$port_a;
      IFEND;
    ELSE
      controller_path.channel.port := cmc$unspecified_port;
    IFEND;

    controller_path.channel_address := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
          unit_descriptors [logical_unit].physical_path.controller_number;

    FOR index := LOWERBOUND (cmv$peripheral_element_table.pointer^)
          TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
      IF cmv$peripheral_element_table.pointer^ [index].physical_descriptor.configured THEN
        IF cmv$peripheral_element_table.pointer^ [index].physical_descriptor.element_type =
              cmc$storage_device_element THEN
          IF (cmv$peripheral_element_table.pointer^ [index].logical_unit_number = logical_unit) THEN

            { Only process units in the ON state or units whose controller is ON.

            IF (cmv$peripheral_element_table.pointer^ [index].element_status.state = cmc$on) THEN

              { Check state of controller.

            /peripheral_loop/
              FOR table_index := LOWERBOUND (cmv$peripheral_element_table.pointer^)
                    TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
                IF cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.configured
                      AND (cmv$peripheral_element_table.pointer^ [table_index].
                      physical_descriptor.element_type = cmc$controller_element) THEN
                  FOR eq := LOWERBOUND (cmv$peripheral_element_table.pointer^ [table_index].
                        physical_descriptor.equipment_path^) TO UPPERBOUND (cmv$peripheral_element_table.
                        pointer^ [table_index].physical_descriptor.equipment_path^) DO
                    IF (cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.
                          equipment_path^ [eq].iou = controller_path.iou) AND
                          (cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.
                          equipment_path^ [eq].channel = controller_path.channel) AND
                          (cmv$peripheral_element_table.pointer^ [table_index].physical_descriptor.
                          equipment_path^ [eq].channel_address = controller_path.channel_address) THEN

                      IF cmv$peripheral_element_table.pointer^ [table_index].element_status.state =
                            cmc$on THEN
                        EXIT /peripheral_loop/;
                      ELSE
                        RETURN;
                      IFEND;
                    IFEND;
                  FOREND;
                IFEND;
              FOREND /peripheral_loop/;

              cmv$logical_unit_table^ [logical_unit].unit_interface_table^.unit_status.disabled := FALSE;
              cmv$logical_unit_table^ [logical_unit].element_access := $cmt$element_access
                    [cmc$read, cmc$write];
              cmv$logical_unit_table^ [logical_unit].element_capability :=
                    $cmt$element_capabilities [cmc$volume_assignment, cmc$io_request_submission,
                    cmc$concurrent_maintenance];
              dmp$volume_up (logical_unit);
            IFEND;
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND update_logical_unit_state;
?? OLDTITLE ??
?? NEWTITLE := 'update_peripheral_element_table', EJECT ??

{ PURPOSE:
{   This procedure will update the element_state and connection status information for the affected elements
{   as part of a state change.

  PROCEDURE update_peripheral_element_table
    (    request_block: cmt$request_block;
         new_state: cmt$element_state;
     VAR old_state: cmt$element_state);

    VAR
      downline_element: cmt$element_name,
      element_p: ^cmt$peripheral_element_entry,
      element2_p: ^cmt$peripheral_element_entry,
      i: integer,
      j: integer,
      new_status: cmt$connection_status,
      physical_channel: cmt$physical_channel;

    { Change the state in the peripheral_element_table.

  /peripheral_loop_1/
    FOR i := LOWERBOUND (cmv$peripheral_element_table.pointer^)
          TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
      element_p := ^cmv$peripheral_element_table.pointer^ [i];
      IF NOT element_p^.physical_descriptor.configured THEN
        CYCLE /peripheral_loop_1/;
      IFEND;

      IF element_p^.element_name <> request_block.element_name THEN
        CYCLE /peripheral_loop_1/;
      IFEND;

      IF request_block.element_type = cmc$data_channel_element THEN
        IF element_p^.physical_descriptor.channel_path.iou <> request_block.iou THEN
          CYCLE /peripheral_loop_1/;
        ELSE
          physical_channel := element_p^.physical_descriptor.channel_path.channel;
        IFEND;
      IFEND;

      old_state := element_p^.element_status.state;
      element_p^.element_status.state := new_state;
      EXIT /peripheral_loop_1/;
    FOREND /peripheral_loop_1/;

    { Change state in the peripheral_element_table of the other port on an IPI channel

    IF (request_block.element_type = cmc$data_channel_element) AND
          (physical_channel.port <> cmc$unspecified_port) THEN

    /peripheral_loop_2/
      FOR j := i + 1 TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
        element2_p := ^cmv$peripheral_element_table.pointer^ [j];
        IF NOT element2_p^.physical_descriptor.configured THEN
          CYCLE /peripheral_loop_2/;
        IFEND;

        IF element2_p^.physical_descriptor.element_type <> cmc$data_channel_element THEN
          CYCLE /peripheral_loop_2/;
        IFEND;

        IF (physical_channel.number = element2_p^.physical_descriptor.channel_path.channel.number) AND
              (physical_channel.concurrent = element2_p^.physical_descriptor.channel_path.channel.
              concurrent) AND (request_block.iou = element2_p^.physical_descriptor.channel_path.iou) THEN
          element2_p^.element_status.state := new_state;
          EXIT /peripheral_loop_2/;
        IFEND;
      FOREND /peripheral_loop_2/;
    IFEND;

    { Update connection_status in peripheral_element_table.

    IF new_state = cmc$on THEN
      new_status := cmc$active;
    ELSE
      new_status := cmc$inactive;
    IFEND;

    CASE request_block.element_type OF
    = cmc$data_channel_element =
      FOR i := LOWERBOUND (element_p^.physical_descriptor.channel_connection^)
            TO UPPERBOUND (element_p^.physical_descriptor.channel_connection^) DO
        IF new_state = cmc$on THEN
          cmp$locate_element_via_name (element_p^.physical_descriptor.channel_connection^ [i].
                downline_element, {iou_number} 0, element2_p);
          IF (element2_p <> NIL) AND (element2_p^.element_status.state = cmc$on) THEN
            element_p^.physical_descriptor.channel_connection^ [i].status := new_status;
          IFEND;
        ELSE
          element_p^.physical_descriptor.channel_connection^ [i].status := new_status;
        IFEND;
      FOREND;

    = cmc$controller_element, cmc$channel_adapter_element =
      FOR i := LOWERBOUND (element_p^.physical_descriptor.equipment_connection^)
            TO UPPERBOUND (element_p^.physical_descriptor.equipment_connection^) DO
        IF new_state = cmc$on THEN
          cmp$locate_element_via_name (element_p^.physical_descriptor.equipment_connection^ [i].
                downline_element, {iou_number} 0, element2_p);
          IF (element2_p <> NIL) AND (element2_p^.element_status.state = cmc$on) THEN
            element_p^.physical_descriptor.equipment_connection^ [i].status := new_status;
          IFEND;
        ELSE
          element_p^.physical_descriptor.equipment_connection^ [i].status := new_status;
        IFEND;
      FOREND;

      downline_element := element_p^.element_name;

    /pet_loop_1/
      FOR i := LOWERBOUND (cmv$peripheral_element_table.pointer^)
            TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
        element_p := ^cmv$peripheral_element_table.pointer^ [i];
        IF NOT element_p^.physical_descriptor.configured THEN
          CYCLE /pet_loop_1/;
        IFEND;

        IF element_p^.physical_descriptor.element_type <> cmc$data_channel_element THEN
          CYCLE /pet_loop_1/;
        IFEND;

        IF (new_state = cmc$on) AND (element_p^.element_status.state <> cmc$on) THEN
          CYCLE /pet_loop_1/;
        IFEND;

      /downline_loop_1/
        FOR j := LOWERBOUND (element_p^.physical_descriptor.channel_connection^)
              TO UPPERBOUND (element_p^.physical_descriptor.channel_connection^) DO
          IF element_p^.physical_descriptor.channel_connection^ [j].downline_element = downline_element THEN
            IF new_state = cmc$on THEN
              IF element_p^.physical_descriptor.channel_connection^ [j].status <> cmc$disabled THEN
                element_p^.physical_descriptor.channel_connection^ [j].status := new_status;
              IFEND;
            ELSE
              element_p^.physical_descriptor.channel_connection^ [j].status := new_status;
            IFEND;
            EXIT /downline_loop_1/;
          IFEND;
        FOREND /downline_loop_1/;
      FOREND /pet_loop_1/;

    = cmc$storage_device_element =
      downline_element := element_p^.element_name;

      IF element_p^.product_id.product_number <> '  $887' THEN

      /pet_loop_2/
        FOR i := LOWERBOUND (cmv$peripheral_element_table.pointer^)
              TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
          element_p := ^cmv$peripheral_element_table.pointer^ [i];
          IF NOT element_p^.physical_descriptor.configured THEN
            CYCLE /pet_loop_2/;
          IFEND;

          IF (element_p^.physical_descriptor.element_type <> cmc$controller_element) AND
                (element_p^.physical_descriptor.element_type <> cmc$channel_adapter_element) THEN
            CYCLE /pet_loop_2/;
          IFEND;

          IF (new_state = cmc$on) AND (element_p^.element_status.state <> cmc$on) THEN
            CYCLE /pet_loop_2/;
          IFEND;

        /downline_loop_2/
          FOR j := LOWERBOUND (element_p^.physical_descriptor.equipment_connection^)
                TO UPPERBOUND (element_p^.physical_descriptor.equipment_connection^) DO
            IF element_p^.physical_descriptor.equipment_connection^ [j].downline_element =
                  downline_element THEN
              element_p^.physical_descriptor.equipment_connection^ [j].status := new_status;
              EXIT /downline_loop_2/;
            IFEND;
          FOREND /downline_loop_2/;
        FOREND /pet_loop_2/;
      ELSE

      /pet_loop_3/
        FOR i := LOWERBOUND (cmv$peripheral_element_table.pointer^)
              TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
          element_p := ^cmv$peripheral_element_table.pointer^ [i];
          IF NOT element_p^.physical_descriptor.configured THEN
            CYCLE /pet_loop_3/;
          IFEND;

          IF element_p^.physical_descriptor.element_type <> cmc$data_channel_element THEN
            CYCLE /pet_loop_3/;
          IFEND;

          IF (new_state = cmc$on) AND (element_p^.element_status.state <> cmc$on) THEN
            CYCLE /pet_loop_3/;
          IFEND;

        /downline_loop_3/
          FOR j := LOWERBOUND (element_p^.physical_descriptor.channel_connection^)
                TO UPPERBOUND (element_p^.physical_descriptor.channel_connection^) DO
            IF element_p^.physical_descriptor.channel_connection^ [j].downline_element = downline_element THEN
              element_p^.physical_descriptor.channel_connection^ [j].status := new_status;
              EXIT /downline_loop_3/;
            IFEND;
          FOREND /downline_loop_3/;
        FOREND /pet_loop_3/;
      IFEND;

    = cmc$communications_element, cmc$external_processor_element =

    /pet_loop_4/
      FOR i := LOWERBOUND (cmv$peripheral_element_table.pointer^)
            TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
        element_p := ^cmv$peripheral_element_table.pointer^ [i];
        IF NOT element_p^.physical_descriptor.configured THEN
          CYCLE /pet_loop_4/;
        IFEND;

        IF element_p^.physical_descriptor.element_type <> cmc$data_channel_element THEN
          CYCLE /pet_loop_4/;
        IFEND;

        IF (new_state = cmc$on) AND (element_p^.element_status.state <> cmc$on) THEN
          CYCLE /pet_loop_4/;
        IFEND;

      /downline_loop_4/
        FOR j := LOWERBOUND (element_p^.physical_descriptor.channel_connection^)
              TO UPPERBOUND (element_p^.physical_descriptor.channel_connection^) DO
          IF element_p^.physical_descriptor.channel_connection^ [j].downline_element = downline_element THEN
            element_p^.physical_descriptor.channel_connection^ [j].status := new_status;
            EXIT /downline_loop_4/;
          IFEND;
        FOREND /downline_loop_4/;
      FOREND /pet_loop_4/;

    ELSE
    CASEND;

  PROCEND update_peripheral_element_table;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$change_connection_status', EJECT ??

{ PURPOSE:
{   This procedure modifies the status of a connection between elements.  If a channel is specified the
{   connection status for all downline connections of the specified channel are set to the new value.  If a
{   controller is specified the connection status for all downline connections of the specified controller
{   are set to the new value.  If a storage_device is specified the connection status between the specified
{   element and it's upline element is set to the new value.  Currently this interface is only called when
{   disabling connections.  The procedure UPDATE_PERIPHERAL_ELEMENT_TABLE changes the connection status of
{   elements when a state change is being processed.

  PROCEDURE [XDCL] cmp$change_connection_status
    (    physical_address: cmt$physical_address;
         new_connection_status: cmt$connection_status);

    VAR
      channel: cmt$physical_address,
      channel_element_p: ^cmt$peripheral_element_entry,
      controller: cmt$physical_address,
      controller_element_p: ^cmt$peripheral_element_entry,
      i: integer,
      unit_element_p: ^cmt$peripheral_element_entry;

    IF physical_address.address_specifier = cmv$data_channel_address THEN

      { Update all ACTIVE downline connections from the channel to the new connection status.

      cmp$locate_element_via_adr (physical_address, channel_element_p);
      IF channel_element_p = NIL THEN
        RETURN;
      IFEND;

      FOR i := LOWERBOUND (channel_element_p^.physical_descriptor.channel_connection^)
            TO UPPERBOUND (channel_element_p^.physical_descriptor.channel_connection^) DO
        IF channel_element_p^.physical_descriptor.channel_connection^ [i].status = cmc$active THEN
          channel_element_p^.physical_descriptor.channel_connection^ [i].status := new_connection_status;
        IFEND;
      FOREND;

    ELSEIF physical_address.address_specifier = cmv$controller_address THEN

      { Update all ACTIVE downline connections from the controller to the new connection status.

      cmp$locate_element_via_adr (physical_address, controller_element_p);
      IF controller_element_p = NIL THEN
        RETURN;
      IFEND;

      FOR i := LOWERBOUND (controller_element_p^.physical_descriptor.equipment_connection^)
            TO UPPERBOUND (controller_element_p^.physical_descriptor.equipment_connection^) DO
        IF controller_element_p^.physical_descriptor.equipment_connection^ [i].status = cmc$active THEN
          controller_element_p^.physical_descriptor.equipment_connection^ [i].status := new_connection_status;
        IFEND;
      FOREND;

    ELSEIF physical_address.address_specifier = cmv$mass_storage_address THEN

      { Get the unit and controller.

      cmp$locate_element_via_adr (physical_address, unit_element_p);
      IF unit_element_p = NIL THEN
        RETURN;
      IFEND;

      get_controller_physical_address (physical_address, controller);
      cmp$locate_element_via_adr (controller, controller_element_p);
      IF controller_element_p = NIL THEN
        RETURN;
      IFEND;

      IF cmv$debug = 08(16) THEN
        mtp$error_stop ('Debug stop 08(16) - cmp$change_connection_status');
      IFEND;

      { Locate the unit in the controllers downline connections and insert the new value.

      FOR i := LOWERBOUND (controller_element_p^.physical_descriptor.equipment_connection^)
            TO UPPERBOUND (controller_element_p^.physical_descriptor.equipment_connection^) DO
        IF controller_element_p^.physical_descriptor.equipment_connection^ [i].downline_element =
              unit_element_p^.element_name THEN
          controller_element_p^.physical_descriptor.equipment_connection^ [i].status := new_connection_status;
          RETURN;
        IFEND;
      FOREND;

      IF cmv$debug = 09(16) THEN
        mtp$error_stop ('Debug stop 09(16) - cmp$change_connection_status');
      IFEND;

    ELSEIF physical_address.address_specifier = cmv$hydra_mass_storage_address THEN

      { Get the unit and channel.

      cmp$locate_element_via_adr (physical_address, unit_element_p);
      IF unit_element_p = NIL THEN
        RETURN;
      IFEND;

      get_channel_physical_address (physical_address, channel);
      cmp$locate_element_via_adr (channel, channel_element_p);
      IF channel_element_p = NIL THEN
        RETURN;
      IFEND;

      { Locate the unit in the channels downline connections and insert the new value.

      FOR i := LOWERBOUND (channel_element_p^.physical_descriptor.channel_connection^)
            TO UPPERBOUND (channel_element_p^.physical_descriptor.channel_connection^) DO
        IF channel_element_p^.physical_descriptor.channel_connection^ [i].downline_element =
              unit_element_p^.element_name THEN
          channel_element_p^.physical_descriptor.channel_connection^ [i].status := new_connection_status;
          RETURN;
        IFEND;
      FOREND;
    ELSE

      { This should never occur.

    IFEND;

  PROCEND cmp$change_connection_status;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$default_response_handler', EJECT ??

{ PURPOSE:
{   This procedure is a dummy response handler procedure used for foreign pp subsystem.

  PROCEDURE [XDCL] cmp$default_response_handler
    (    pp_response_header_p: ^iot$pp_response;
         detailed_status_p: ^iot$detailed_status;
         pp_number: 1 .. ioc$pp_count;
     VAR status: syt$monitor_status);

    status.normal := TRUE;

  PROCEND cmp$default_response_handler;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$enable_all_connections', EJECT ??

{ PURPOSE:
{   This procedure will search the peripheral element table and change the connection status of all DISABLED
{   connection to ACTIVE.  For each element whose connection status is modified, the code to rebuild the
{   affected PPs PP interface table will be executed.
{ NOTE:
{   This code is executed only during the UNSTEP_SYSTEM monitor command.

  PROCEDURE [XDCL] cmp$enable_all_connections;

    VAR
      disabled_connection_found: boolean,
      display_header: boolean,
      i: integer,
      j: integer,
      pete_p: ^cmt$peripheral_element_entry,
      status: ost$status;

    display_header := TRUE;

  /search_pet/
    FOR i := LOWERBOUND (cmv$peripheral_element_table.pointer^)
          TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
      pete_p := ^cmv$peripheral_element_table.pointer^ [i];
      IF NOT pete_p^.physical_descriptor.configured THEN
        CYCLE /search_pet/;
      IFEND;

      disabled_connection_found := FALSE;
      CASE pete_p^.physical_descriptor.element_type OF
      = cmc$data_channel_element =
        FOR j := LOWERBOUND (pete_p^.physical_descriptor.channel_connection^)
              TO UPPERBOUND (pete_p^.physical_descriptor.channel_connection^) DO
          IF pete_p^.physical_descriptor.channel_connection^[j].status = cmc$disabled THEN
            pete_p^.physical_descriptor.channel_connection^[j].status := cmc$active;
            disabled_connection_found := TRUE;
          IFEND;
        FOREND;
        IF disabled_connection_found THEN
          IF display_header THEN
            display_header := FALSE;
            dpp$display_error('Enable elements:');
          IFEND;
          build_affected_pp_tables (pete_p);
        IFEND;

      = cmc$controller_element =
        FOR j := LOWERBOUND (pete_p^.physical_descriptor.equipment_connection^)
              TO UPPERBOUND (pete_p^.physical_descriptor.equipment_connection^) DO
          IF pete_p^.physical_descriptor.equipment_connection^[j].status = cmc$disabled THEN
            pete_p^.physical_descriptor.equipment_connection^[j].status := cmc$active;
            disabled_connection_found := TRUE;
          IFEND;
        FOREND;
        IF disabled_connection_found THEN
          IF display_header THEN
            display_header := FALSE;
            dpp$display_error('Enable elements:');
          IFEND;
          build_affected_pp_tables (pete_p);
        IFEND;

      ELSE
      CASEND;

    FOREND /search_pet/;

  PROCEND cmp$enable_all_connections;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$idle_system_device_driver', EJECT ??

{ PURPOSE:
{   This procedure is called to software idle the system device pp and return information about the
{   partner pp if it exists.

  PROCEDURE [XDCL] cmp$idle_system_device_driver
    (    pp: dst$iou_resource;
     VAR dual_pp: boolean;
     VAR pp_interface_table_rma: ost$real_memory_address;
     VAR partner_pp: dst$iou_resource);

    VAR
      count: 0 .. 0ff(16),
      pp_index: iot$pp_number,
      status: syt$monitor_status,
      time: integer,
      timeout: integer;

    dual_pp := FALSE;
    IF NOT cmv$system_device_pp.software_idle THEN
      RETURN;
    IFEND;

    IF (cmv$system_device_pp.primary_pp.number <> pp.number) AND
          (cmv$system_device_pp.primary_pp.iou_number <> pp.iou_number) AND
          (cmv$system_device_pp.primary_pp.channel_protocol <> pp.channel_protocol) THEN
      RETURN;
    IFEND;

    iop$idle_resume (LOWERBOUND (cmv$logical_pp_table_p^), ioc$ira_idle, status);

    time := #FREE_RUNNING_CLOCK (0);
    timeout := time + 2000000;
    count := 0;

    REPEAT
      iop$process_io_completions;
      count := count + 1;
      IF count >= 100 THEN
        time := #FREE_RUNNING_CLOCK (0);
        count := 0;
      IFEND;
    UNTIL (cmv$logical_pp_table_p^ [1].pp_info.pp_interface_table_p^.idle_status) OR (time > timeout);

    cmp$manage_channel_lock ({Set lock =} FALSE,
          cmv$logical_pp_table_p^ [1].pp_info.channel.iou_number,
          cmv$logical_pp_table_p^ [1].pp_info.pp_interface_table_p^.
          unit_descriptors [2].physical_path.channel_number, (pp.channel_protocol = dsc$cpt_cio), status);

    IF (cmv$new_logical_unit_table <> NIL) AND (cmv$new_logical_pp_table_p <> NIL) THEN

      { Change the pointer values of the old tables to the new tables.  The new tables are being built based
      { on the full configuration.

      cmv$logical_unit_table := cmv$new_logical_unit_table;
      cmv$logical_pp_table_p := cmv$new_logical_pp_table_p;
      cmv$system_device_pp.software_idle := FALSE;
      cmv$max_number_of_pp := 0;

    /find_last_pp/
      FOR pp_index := UPPERBOUND (cmv$logical_pp_table_p^) DOWNTO LOWERBOUND (cmv$logical_pp_table_p^) DO
        IF cmv$logical_pp_table_p^ [pp_index].flags.configured THEN
          cmv$max_number_of_pp := pp_index;
          EXIT /find_last_pp/;
        IFEND;
      FOREND /find_last_pp/;
      dsp$advance_ds_sequence_in_mtr (dsc$dss_system_core_idled);
    IFEND;

    dual_pp := cmv$system_device_pp.dual_pp;
    IF dual_pp THEN
      partner_pp := cmv$system_device_pp.partner_pp;
      pp_interface_table_rma := cmv$system_device_pp.ppit_rma;
    IFEND;

  PROCEND cmp$idle_system_device_driver;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$manage_channel_lock', EJECT ??

{ PURPOSE:
{   This procedure locks OR unlocks the channel.

  PROCEDURE [XDCL] cmp$manage_channel_lock
    (    set_lock: boolean;
         iou_number: dst$iou_number;
         channel_number: dst$physical_resource_number;
         concurrent: boolean;
     VAR status: syt$monitor_status);

    TYPE
      t$lock = RECORD
        CASE (c$idr_io, c$idr_compare_swap) OF
        = c$idr_io =
          io: iot$table_lock_entry,
        = c$idr_compare_swap =
          compare_swap: integer,
        CASEND,
      RECEND;

    VAR
      actual: t$lock,
      channel_lock_p: ^integer,
      channel_lock_seq_p: ^SEQ ( * ),
      final: t$lock,
      initial: t$lock,
      succeeded: boolean;

    status.normal := TRUE;

    IF cmv$iou_table_p = NIL THEN
      RETURN;
    IFEND;

    IF NOT cmv$iou_table_p^ [iou_number].configured THEN
      RETURN;
    IFEND;

    IF NOT concurrent THEN
      IF (cmv$iou_table_p^ [iou_number].nio_channel_lock_p <> NIL) THEN
        channel_lock_seq_p := #SEQ (cmv$iou_table_p^ [iou_number].
              nio_channel_lock_p^.channel_table [channel_number]);
      ELSE

        { No NIO channel lock assume we are running on I4C, remove codes if DS passes in correct NIO/CIO
        { channel.

        IF (cmv$iou_table_p^ [iou_number].cio_channel_lock_p <> NIL) THEN
          channel_lock_seq_p := #SEQ (cmv$iou_table_p^ [iou_number].
                cio_channel_lock_p^.channel_table [channel_number]);
        ELSE
          RETURN;
        IFEND;
      IFEND;
    ELSE
      IF (cmv$iou_table_p^ [iou_number].cio_channel_lock_p <> NIL) THEN
        channel_lock_seq_p := #SEQ (cmv$iou_table_p^ [iou_number].
              cio_channel_lock_p^.channel_table [channel_number]);
      ELSE
        RETURN;
      IFEND;
    IFEND;

    RESET channel_lock_seq_p;
    NEXT channel_lock_p IN channel_lock_seq_p;

    CASE set_lock OF
    = TRUE =
      REPEAT
        actual.compare_swap := 0;
        REPEAT
          initial.io := actual.io;
          final.io := actual.io;
          final.io.maintenance_need_channel := TRUE;
          osp$set_locked_variable (channel_lock_p^, initial.compare_swap, final.compare_swap,
                actual.compare_swap, succeeded);
        UNTIL succeeded;

        initial.io := final.io;
        initial.io.channel_locked := FALSE;
        final.io.channel_locked := TRUE;
        osp$set_locked_variable (channel_lock_p^, initial.compare_swap, final.compare_swap,
              actual.compare_swap, succeeded);
        IF NOT succeeded THEN
          IF (mtv$time_to_call_handshaking - #FREE_RUNNING_CLOCK (0)) < 0 THEN
            dsp$perform_cpu_pp_handshaking;

            { Ensure that the disk driver pp that has the channel locked is not waiting for it's response
            { buffer to be emptied before it can clear the channel lock.

            iop$process_io_completions;
          IFEND;
        IFEND;
      UNTIL succeeded;

    = FALSE =
      actual.compare_swap := 0;
      REPEAT
        initial.io := actual.io;
        final.io := actual.io;
        final.io.channel_locked := FALSE;
        final.io.maintenance_need_channel := FALSE;
        osp$set_locked_variable (channel_lock_p^, initial.compare_swap, final.compare_swap,
              actual.compare_swap, succeeded);
      UNTIL succeeded;

    ELSE
      mtp$error_stop (' Illegal function in cmp$manage_channel_lock');
    CASEND;

  PROCEND cmp$manage_channel_lock;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$monitor_routines', EJECT ??

{ PURPOSE:
{   This procedure process Configuration Management monitor requests.

  PROCEDURE [XDCL] cmp$monitor_routines
    (VAR request_block: cmt$request_block);

    request_block.status.normal := TRUE;

    CASE request_block.kind OF
    = cmc$rbk_assign_pp =
      cmv$logical_pp_table_p^ [request_block.assigned_pp].flags.pp_loaded := request_block.assigned;

    = cmc$rbk_change_state =
      change_state (request_block, request_block.status);

    = cmc$rbk_idle_pp =
      idle_pp_in_mtr (request_block.idled_pp, request_block.send_idle, request_block.status);

    = cmc$rbk_queue_pp_request =
      queue_pp_request (request_block.queued_pp, request_block.request_p, request_block.status);

    = cmc$rbk_request_stack_memory =
      assign_stack_segment (request_block.first_byte_address_p, request_block.rma, request_block.status);

    = cmc$rbk_resume_pp =
      resume_pp_in_mtr (request_block.resumed_pp, request_block.send_resume, request_block.status);

    ELSE
    CASEND;

  PROCEND cmp$monitor_routines;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$process_pp_response', EJECT ??

{ PURPOSE:
{   This procedure processes a PP response.

  PROCEDURE [XDCL] cmp$process_pp_response
    (    pp_response_p: ^iot$pp_response;
         detailed_status_p: ^iot$detailed_status;
         pp: 1 .. ioc$pp_count;
     VAR status: syt$monitor_status);

    VAR
      completed_request_p: ^iot$disk_request,
      count: 0 .. 0ff(16),
      previously_set: boolean,
      pp_interface_table_p: ^iot$pp_interface_table,
      time: integer,
      timeout: integer;

    status.normal := TRUE;

    IF pp_response_p^.response_code.primary_response = ioc$intermediate_response THEN
      RETURN;
    IFEND;
    completed_request_p := pp_response_p^.request^.device_request_p;

    { Set idle_status flag in pp_interface_table.

    pp_interface_table_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;

    { Interlock the pp_interface_table.

    time := #FREE_RUNNING_CLOCK (0);
    timeout := time + 2000000;
    count := 0;

    REPEAT
      i#test_set_bit (^pp_interface_table_p^, ioc$pp_interface_table_lock_bit, previously_set);
      count := count + 1;
      IF count >= 100 THEN
        time := #FREE_RUNNING_CLOCK (0);
        count := 0;
      IFEND;
    UNTIL (NOT previously_set) OR (time > timeout);
    IF previously_set THEN
      mtp$set_status_abnormal (ioc$subsystem_io_manager, ioc$pp_interlock_set, status);
      RETURN;
    IFEND;

    CASE completed_request_p^.request.command [1].command_code OF
    = ioc$cc_idle =
      pp_interface_table_p^.idle_status := TRUE;
    = ioc$cc_resume =
      pp_interface_table_p^.idle_status := FALSE;
    ELSE
    CASEND;

    pp_interface_table_p^.lock := FALSE;

  PROCEND cmp$process_pp_response;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$reenable_unit', EJECT ??

{ PURPOSE:
{   This function determines whether or not a given path should be reenabled.

  FUNCTION [XDCL, UNSAFE] cmp$reenable_unit
    (    path: cmt$physical_address): boolean;

    VAR
      channel_element_p: ^cmt$peripheral_element_entry,
      channel_address: cmt$physical_address,
      unit_element_p: ^cmt$peripheral_element_entry,
      unit_address: cmt$physical_address,
      controller_element_p: ^cmt$peripheral_element_entry,
      controller_address: cmt$physical_address,
      unit_on: boolean,
      channel_on: boolean,
      equipment_on: boolean,
      unit: integer,
      eq: integer,
      index: integer;

    cmp$reenable_unit := FALSE;
    IF cmv$peripheral_element_table.pointer = NIL THEN
      RETURN;
    IFEND;

    unit_on := FALSE;
    equipment_on := FALSE;
    channel_on := FALSE;

    IF path.address_specifier = cmv$mass_storage_address THEN
      cmp$locate_element_via_adr (path, unit_element_p);
      IF unit_element_p <> NIL THEN
        unit_on := unit_element_p^.element_status.state = cmc$on;
      IFEND;

      IF unit_on THEN
        get_controller_physical_address (path, controller_address);
        cmp$locate_element_via_adr (controller_address, controller_element_p);
        IF controller_element_p <> NIL THEN
          equipment_on := controller_element_p^.element_status.state = cmc$on;
        IFEND;
      IFEND;

      IF unit_on AND equipment_on THEN
        get_channel_physical_address (path, channel_address);
        cmp$locate_element_via_adr (channel_address, channel_element_p);
        IF channel_element_p <> NIL THEN
          channel_on := channel_element_p^.element_status.state = cmc$on;
        IFEND;
      IFEND;

      cmp$reenable_unit := channel_on AND equipment_on AND unit_on;

    ELSEIF path.address_specifier = cmv$controller_address THEN
      cmp$locate_element_via_adr (path, controller_element_p);
      IF controller_element_p <> NIL THEN
        equipment_on := controller_element_p^.element_status.state = cmc$on;
      IFEND;

      IF equipment_on THEN
        get_channel_physical_address (path, channel_address);
        cmp$locate_element_via_adr (channel_address, channel_element_p);
        IF channel_element_p <> NIL THEN
          channel_on := channel_element_p^.element_status.state = cmc$on;
        IFEND;
      IFEND;

      cmp$reenable_unit := channel_on AND equipment_on;

    ELSEIF path.address_specifier = cmv$hydra_mass_storage_address THEN
      cmp$locate_element_via_adr (path, unit_element_p);
      IF unit_element_p <> NIL THEN
        unit_on := unit_element_p^.element_status.state = cmc$on;
      IFEND;

      IF unit_on THEN
        get_channel_physical_address (path, channel_address);
        cmp$locate_element_via_adr (channel_address, channel_element_p);
        IF channel_element_p <> NIL THEN
          channel_on := channel_element_p^.element_status.state = cmc$on;
        IFEND;
      IFEND;

      cmp$reenable_unit := channel_on AND unit_on;
    IFEND;

  FUNCEND cmp$reenable_unit;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$switch_to_redundant_path', EJECT ??

{ PURPOSE:
{   This procedure will search an available redundant path given a primary path (i.e. iou/channel or
{   iou/channel/controller).  If found, an attempt will be made to change access to all units from the
{   primary path to the redundant path.  The SUCCESSFUL parameter will be set to TRUE if the request
{   succeeded.

  PROCEDURE [XDCL] cmp$switch_to_redundant_path
    (    pp: iot$pp_number;
         primary_path: cmt$physical_address;
     VAR successful: boolean);

    VAR
      driver_name: pmt$program_name,
      list_index: integer,
      logical_unit_list_p: ^ARRAY [ * ] OF cmt$rb_logical_unit_address,
      number_of_path: integer,
      number_of_units: integer,
      pp_table_rma_list: ARRAY [cmt$physical_equipment_number] OF ost$real_memory_address,
      pp_to_clear_list_p: ^ARRAY [ * ] OF iot$pp_number,
      pp_to_set_list_p: ^ARRAY [ * ] OF iot$pp_number,
      redundant_channel_list: ARRAY [cmt$physical_equipment_number] OF cmt$physical_address,
      redundant_path_available: boolean,
      redundant_path_pp_list: ARRAY [cmt$physical_equipment_number] OF iot$pp_number,
      status: syt$monitor_status,
      temp_unit_list_p: ^ARRAY [ * ] OF cmt$rb_logical_unit_address,
      update_controller_address: boolean;

    successful := FALSE;

    cmp$find_redundant_path (primary_path, cmc$down, redundant_path_available, update_controller_address,
          number_of_path, redundant_channel_list, redundant_path_pp_list, driver_name, pp_table_rma_list);
    IF cmv$debug = 016(16) THEN
      mtp$error_stop (' Debug stop 016(16) cmp$switch_to_redundant_path.');
    IFEND;
    IF NOT redundant_path_available THEN
      RETURN;
    IFEND;

    { Update handshaking value to prevent timeout.

    dsp$perform_cpu_pp_handshaking;

    { Find all logical_units accessible from the primary path element.

    PUSH temp_unit_list_p: [1 .. UPPERVALUE (cmt$physical_unit_number)];
    setup_lun_list (pp, primary_path, update_controller_address, temp_unit_list_p, number_of_units);

    PUSH logical_unit_list_p: [1 .. number_of_units];
    FOR list_index := LOWERBOUND (logical_unit_list_p^) TO number_of_units DO
      logical_unit_list_p^ [list_index] := temp_unit_list_p^ [list_index];
    FOREND;

    PUSH pp_to_clear_list_p: [0 .. 0];
    pp_to_clear_list_p^ [0] := pp;
    PUSH pp_to_set_list_p: [0 .. number_of_path];
    FOR list_index := 0 TO number_of_path DO
      pp_to_set_list_p^ [list_index] := redundant_path_pp_list [list_index];
    FOREND;

    { Idle primary pp and redundant pp if not identical.

    iop$idle_path (pp, status);
    FOR list_index := LOWERBOUND (redundant_path_pp_list) TO number_of_path DO
      IF pp <> redundant_path_pp_list [list_index] THEN
        iop$idle_path (redundant_path_pp_list [list_index], status);
      IFEND;
    FOREND;

    { Update unit descriptors.

    change_unit_descriptors (update_controller_address, pp_to_clear_list_p^, pp_to_set_list_p^,
          logical_unit_list_p);

    iop$idle_resume (pp, ioc$ira_resume, status);
    FOR list_index := LOWERBOUND (redundant_path_pp_list) TO number_of_path DO
      IF pp <> redundant_path_pp_list [list_index] THEN
        iop$idle_resume (redundant_path_pp_list [list_index], ioc$ira_resume, status);
      IFEND;
    FOREND;
    successful := TRUE;

  PROCEND cmp$switch_to_redundant_path;
?? OLDTITLE ??
MODEND cmm$monitor_routines;
*DECK DECK=CMM$NO_PP_DRIVER EXPAND=TRUE

          IDENT NERD
          CIPPU
          TITLE OSM$NO_PP_DRIVER
          COMMENT *SMD* LVL=01
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE 4
**  NAME NERD, DECK NAME IS CMM$NO_PP_DRIVER.
*
** PURPOSE: THE PURPOSE OF THIS PROGRAM IS TO DUMMY LOAD THE
*         PP AS AN INITIALIZATION OPTION. THIS DRIVER IS ABLE TO PERFORM
*         NO FUNCTIONS OTHER THAN IDLE AND RESUME.
*
** DETAILS: THE PP GETS ITS INSTRUCTION FROM THE
*           PP INTERFACE TABLE FOR IDLE AND RESUME.
*
          SPACE   4
*copyc IODMAC1 "{RECORD DEFINITION MACROS}
*copyc IODMAC2 "{LOAD/STORE MACROS}
*copyc IODMAC3 "{GENERAL MACROS}
*copyc IODMAC4 "{GENERAL MACROS}
*copyc dsi$maintenance_register_macros
*copyc dsa$hardware_table_definitions
*copyc dsi$pp_macros
*COPYC DSC$PP_MR_AND_TPM_CONSTANTS
*COPYC CTI$DFT_ANALYSIS_CODES
*COPYC CTC$EI_CONTROL_BLOCK
          EJECT


* EQUATES

 C.CHCNT  EQU    37          NUMBER OF REQUESTS TO PROCESS BEFORE
                             CLEARING CHANNEL LOCK
 RR       EQU    400000B     R-REGISTER ACTIVATION

* INTERFACE ERROR CODES.
 E501     EQU    2401B       INVALID COMMAND CODE
          SPACE  10
* SS TABLE DEFINITIONS. INFORMATION SAVED FOR EACH UNIT.

 SS       RECORD PACKED

* WORD 1

 CHAN     SUBRANGE 0,77B     CHANNEL NUMBER
 FILL1    SUBRANGE 0,77B
 SEEK     BOOLEAN            SEEK ISSUED
 CUR      BOOLEAN            CURRENT REQUEST HAS BEEN SELECTED (IF SET)
 DV       SUBRANGE 0,3       DEVICE TYPE

* WORDS 2 - 6 = PARAMETERS FOR LOAD COMMAND BLOCK FUNCTION.

 FILL2    SUBRANGE 0,7
 SMALL    BOOLEAN            512 BYTE SECTOR, IF SET
 PRIOV    BOOLEAN            PRIORITY OVERRIDE IF SET
 FILL3    SUBRANGE 0,37B
 CMOD     SUBRANGE 0,7       CONTROL MODULE NUMBER
 UNIT     SUBRANGE 0,7       UNIT NUMBER
*
 FUNC     PPWORD             FUNCTION CODE
*
 CYL      PPWORD             CYLINDER ADDRESS
*
 TRACK    SUBRANGE 0,377B    TRACK ADDRESS
 SECTOR   SUBRANGE 0,377B    SECTOR ADDRESS
*
 TLFLG    BOOLEAN            NONZERO MEANS USE TRANSFER LENGTH
 LENGTH   SUBRANGE 0,77777B  TRANSFER LENGTH

* WORD 7 - END = SAVED INFORMATION PER UNIT.

 FNC      PPWORD             FUNCTION CODE  READ = 0
                                            WRITE = 1
                                            WRITE INITIALIZE = 2
 REQ      STRUCT 4           CURRENT REQUEST (UNFORMATTED RMA)
 PVA      STRUCT 6           PVA OF CURRENT REQUEST

 LASTC    PPWORD             OFFSET OF COMMAND IN REQUEST
 QSEL     PPWORD             REQUEST SELECTION ALGORITHM
 FRST     PPWORD             = 0, IF FIRST TIME THROUGH UNCMND
 NUMCM    PPWORD             NUMBER OF COMMANDS LEFT TO PROCESS IN
                             THIS REQUEST
 LISTL    PPWORD             NUMBER OF CM WORDS IN ADDRESS-LENGTH PAIR LIST.
                             (INCLUDES THE NUMBER OF WORDS WHICH HAVENT
                             BEEN READ FROM CM.)
 TOTAL    STRUCT 4           TOTAL CM WORDS LEFT TO TRANSFER BEFORE TERMINATING
 FCOMRQ   STRUCT 4           FIRST COMPLETED REQUEST (RMA)
 CURRQ    STRUCT 4           CURRENT REQUEST (RMA)
 PRERQ    STRUCT 4           PREVIOUS REQUEST (RMA)
 NCOMRQ   PPWORD             NUMBER OF COMPLETED REQUESTS
 NCOMW    PPWORD             NUMBER OF COMPLETED WRITE REQUESTS
 CURTRK   PPWORD             CURRENT TRACK
 CURSEC   PPWORD             CURRENT SECTOR
 SWFLG    PPWORD             NONZERO IF A STREAMING REQUEST SWITCH WAS MADE
 RVCNT    PPWORD             COUNT OF RECOVERED ERRORS PER REQUEST
 RQTRY    PPWORD             REQUEST RETRY COUNT
 ADERR    PPWORD             ADAPTER ERROR
 NR       PPWORD             NOT READY RETRY COUNT
 LAD      PPWORD             LOAD ADAPTER RETRY COUNTER
 CMLD     PPWORD             CM LOAD RETRY COUNTER
 PRELD    PPWORD             PRELOAD OF CONTROL MODULE IF NONZERO
 DIAG     PPWORD             NONZERO IF RUNNING LEVEL II DIAGNOSTICS
 DIAGS    PPWORD             NONZERO IF RUNNING DIAGNOSTICS COMMAND 72
 RECOV    PPWORD             NONZERO IF IN RECOVERY


* CURRENT REQUEST.  MUST BE ALIGNED ON A WORD BOUNDARY.

          ALIGN  0,64
 RQ       STRUCT 40          REQUEST

 CMLIST   STRUCT 8           CURRENT DATA ADDRESS OR CURRENT COMMAND

* RESPONSE.

 RS       STRUCT 152         RESPONSE
          MGEN   N.CUR
 M.CUR    EQU    MASK$
          MGEN   N.SEEK
 M.SEEK   EQU    MASK$
          MASKP  SEEK
 K.SEEK   EQU    MSK
          MASKP  CUR
 K.CUR    EQU    MSK
          MGEN   N.CHAN
 M.CHAN   EQU    MASK$
          MGEN   N.DV
 M.DV     EQU    MASK$
          MASKP  SMALL
 K.SMALL  EQU    MSK
          MGEN   N.SMALL
 M.SMALL  EQU    MASK$
          MASKP  PRIOV
 K.PRIOV  EQU    MSK
          MGEN   N.UNIT
 M.UNIT   EQU    MASK$
          MASKP  UNIT
 K.UNIT   EQU    MSK
          MASKP  CMOD
 K.CMOD   EQU    MSK
          MGEN   N.CMOD
 M.CMOD   EQU    MASK$
          MGEN   N.TRACK
 M.TRACK  EQU    MASK$
          MGEN   N.SECTOR
 M.SECTOR EQU    MASK$

 SS       RECEND
          SPACE  6
* PP TABLE.

 PT       RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 PART     PPWORD             PARTNER PP NUMBER
 PIT      RMA                PP INTERFACE TABLE ADDRESS (RMA)
 PITPVA   STRUCT 24          PP INTERFACE TABLE ADDRESS (PVA)

 PT       RECEND
          SPACE  6
* PP INTERFACE TABLE
 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
          ALIGN  0,64
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER
          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)
          ALIGN  32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          SPACE  6
* PP REQUESTS.

 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS
                               0 - ATTEMPT RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
          ALIGN  0,64
 SWIT     BOOLEAN            SWITCH TO NEXT REQUEST
          ALIGN  16,64
 CYL      PPWORD             CYLINDER ADDRESS
 TRACK    PPWORD             TRACK ADDRESS
 SECTOR   PPWORD             SECTOR ADDRESS
 CMND     INTEGER            COMMAND SEQUENCE


          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$

 RQ       RECEND
          SPACE  6
* PP COMMAND.

 CM       RECORD PACKED

 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$

 CM       RECEND
          SPACE  6
* COMMAND CODES.

 C.IDLE   EQU    4           IDLE
 C.RESUME EQU    5           RESUME
          SPACE  6
* PP RESPONSE.

 RS       RECORD PACKED

* WORD 1.
          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST

* WORD 2.
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST  (NOT USED)

* WORD 3.
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST) (NOT USED)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)  (NOT USED)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS  (NOT USED)
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY  (NOT USED)
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

* WORD 4.
          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED  (NOT USED)
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE INTERFACE
                             ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
                             (NOT USED)
 CHERR    BOOLEAN            CHANNEL PARITY ERROR
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION
                             OCCURRED ON INPUT OR INADEQUATE DATA RATE ON OUTPUT
                             (NOT USED)
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT  (NOT USED)
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A
                             HARDWARE MALFUNCTION.  EX: UNIT NOT READY,
                             UNIT NOT CONNECTED.  (NOT USED)
 FTO      BOOLEAN            FUNCTION TIMEOUT
 CHERO    BOOLEAN            CHANNEL OUTPUT PARITY ERROR
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
                               1 - RECOVERED ERROR
                               2 - COMMAND HAD EXPLICIT RESPONSE FLAG SET
                               3 - BOTH CONDITIONS 1 AND 2
 K.REC    EQU    1           RECOVERED ERROR
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE  (NOT USED)
                               1 - UNIT CHANGED FROM READY TO NOT READY
                               2 - UNIT CHANGED FROM NOT READY TO READY
                               3 - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
                               4 - CONTROLLER RESERVED
                               5 - UNIT RESERVED TO ANOTHER ACCESS
                               6 - RECOVERED ABNORMAL CONDITION
          ALIGN  49,64       ALERT CONDITIONS
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

* WORD 5.
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)

 CHAN     PPWORD             CHANNEL NUMBER
 SCYL     PPWORD             STARTING CYLINDER
 STRK     PPWORD             STARTING TRACK
 SSEC     PPWORD             STARTING SECTOR

 UNIT     PPWORD             UNIT NUMBER
 RTRY     PPWORD             REQUEST RETRY COUNT
 FTRK     PPWORD             FAILING TRACK
 FSEC     PPWORD             FAILING SECTOR

 DET      PPWORD             =1, IF DETAILED STATUS PRESENT
 ID       PPWORD             ERROR IDENTIFIER
 K.CMLD   EQU    1           RELOAD OF CONTROL MODULE WAS ATTEMPTED
 K.CMLDS  EQU    2           CONTROL MODULE RELOADED SUCCESSFULLY
 K.XD     EQU    4           EXECUTING LEVEL II DIAGNOSTICS
 K.XDP    EQU    10B         LEVEL II DIAGNOSTICS PASSED
 K.PU     EQU    20B         POWERING UP SPINDLE
 K.PUC    EQU    40B         SPINDLE POWERED UP
 K.PTO    EQU    100B        PP TIMED OUT A COMMAND
 K.UDN    EQU    20000B      UNIT DOWN
 K.CMDN   EQU    40000B      CONTROL MODULE DOWN
 K.CHDN   EQU    100000B     CHANNEL DOWN
 FILL2    PPWORD
 STRY     PPWORD             SECTOR RETRY COUNT

 GENST1   PPWORD             GENERAL STATUS OF THE FIRST TIME ERROR
                               WAS ENCOUNTERED
 GENST2   PPWORD             GENERAL STATUS OF THE LAST TIME ERROR
                               WAS ENCOUNTERED
 FUNTO    PPWORD             FUNCTION CODE IF FUNCTION TIMEOUT ERROR
 ERRID    PPWORD             ERROR IDENTIFIER
 K.IST    EQU    1           INCOMPLETE SECTOR TRANSFER
 K.CRES   EQU    2           CLEAR UNIT RESERVE ON OPPOSITE ACCESS
 K.RAM    EQU    4           RAM PARITY ERROR
 K.CLOAD  EQU    10B         CONTROLWARE LOAD WAS ATTEMPTED
 K.AFT    EQU    20B         AUTOLOAD FUNCTION TIMEOUT
 K.CEMPT  EQU    40B         CHANNEL DOESNT GO EMPTY AFTER SENDING
                             PARAMETERS / DATA
 K.CINAC  EQU    100B        CHANNEL NOT INACTIVE AFTER
                             RECEIVING PARAMETERS / DATA
 K.MEDIA  EQU    200B        MEDIA FAILURE, REREAD SECTOR
 K.UNMED  EQU    400B        UNRECOVERED MEDIA ERROR
 K.RERR   EQU    1000B       READ ERROR.  STATUS BEFORE SUSPEND/TERMINATE .NE.
                             4XXXB.
 K.CF     EQU    2000B       POLL STATUS NONZERO AFTER SENDING CONTROLWARE
 K.DE     EQU    4000B       POLL STATUS NONZERO AFTER LOADING ATTENTION DELAY
 K.NR     EQU    10000B      NOT READY
 K.URS    EQU    20000B      UNIT RESERVED
 K.CRS    EQU    40000B      CONTROLLER RESERVED
 K.ADPT   EQU    100000B     ADAPTER CONTROLWARE ERROR
          ALIGN  0,64
 DETAIL   STRUCT 40          DETAILED STATUS OF THE FIRST TIME ERROR
                             WAS ENCOUNTERED
 DET2     STRUCT 40          DETAILED STATUS OF THE LAST TIME ERROR
                             WAS ENCOUNTERED.


          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$
          MASKP  INTERR
 K.INTERR EQU    MSK
          MASKP  DATOV
 K.DATOV  EQU    MSK
          MASKP  DATERR
 K.DATERR EQU    MSK
          MASKP  HDWR
 K.HDWR   EQU    MSK
          MASKP  CHERR
 K.CHERR  EQU    MSK
          MASKP  CHERO
 K.CHERO  EQU    MSK
          MASKP  NRDY
 K.NRDY   EQU    MSK
          MASKP  FTO
 K.FTO    EQU    MSK

 RS       RECEND
          SPACE  6
* RESPONSE CODES.
 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    1           INTERMEDIATE RESPONSE
 R.NRM    EQU    2           NORMAL REQUEST TERMINATION
 R.ABN    EQU    3           ABNORMAL REQUEST TERMINATION
          SPACE  10
* PP COMMUNICATION BUFFER.

 CB       RECORD PACKED

 PPBUF    PPWORD             BUFFER NUMBER BEING PROCESSED BY PP
 B.LOW    EQU    1           VALUE OF THE LOWEST BUFFER NUMBER
 B.HIGH   EQU    16D         VALUE OF THE HIGHEST BUFFER NUMBER
 PPOFF    PPWORD             OFFSET INTO PP BUFFER
 PPSTAT   PPWORD             PP GENERAL OPERATION STATUS
 S.PWAIT  EQU    6           WAITING TO START PROCESSING
 S.PCOL   EQU    7           COLLECTING DATA
 S.PSTOP  EQU    8           STOPPED COLLECTING DATA
 S.PTERM  EQU    9           TERMINATED DATA COLLECTING
          PPWORD

* SECOND WORD OF CB

 CPBUF    PPWORD             BUFFER NUMBER LAT PROCESSED BY CP
 CPSTAT   PPWORD             CP COLLECTOR STATUS REQUEST
 S.INIT   EQU    1           COMMUNICATION BUFFER IS INITIALIZED
 S.START  EQU    2           START COLLECTING
 S.STOP   EQU    3           STOP COLLECTING
 S.TERM   EQU    4           TERMINATE COLLECTING
 S.COMP   EQU    5           PROCESS COMPLETE
 SPIID    PPWORD             SPI ID NUMBER
 P0       BOOLEAN            PROCESSOR SELECT FLAG
 P1       BOOLEAN            PROCESSOR SELECT FLAG
 P2       BOOLEAN            PROCESSOR SELECT FLAG FUTURE USE
 P3       BOOLEAN            PROCESSOR SELECT FLAG FUTURE USE
 P4       BOOLEAN            PROCESSOR SELECT FLAG FUTURE USE
 P5       BOOLEAN            PROCESSOR SELECT FLAG FUTURE USE
 P6       BOOLEAN            PROCESSOR SELECT FLAG FUTURE USE
 P7       BOOLEAN            PROCESSOR SELECT FLAG FUTURE USE
 IPORT    CHARC              INTERRUPT PORT FOR INTERRUPT INSTRUCTION

* THIRD WORD OF CB

 SAMP     STRUCT 4           NUMBER OF SPI SAMPLES
 TIME     STRUCT 4           TIME BETWEEN SAMPLES

* FOURTH WORD OF CB

 BOFF1    PPWORD             OFFSET IN BUFFER
 BST1     PPWORD             STATUS OF BUFFER
 S.AVAIL  EQU    1           BUFFER IS AVAILABLE FOR PP USE
 S.INUSE  EQU    2           BUFFER IN USE BY PP
 S.DATA   EQU    3           BUFFER HAS DATA FOR CPU TO COPY
 BRMA1    RMA                RMA OF BUFFER
 BPVA1    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF2    PPWORD             OFFSET IN BUFFER
 BST2     PPWORD             STATUS OF BUFFER
 BRMA2    RMA                RMA OF BUFFER
 BPVA2    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF3    PPWORD             OFFSET IN BUFFER
 BST3     PPWORD             STATUS OF BUFFER
 BRMA3    RMA                RMA OF BUFFER
 BPVA3    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF4    PPWORD             OFFSET IN BUFFER
 BST4     PPWORD             STATUS OF BUFFER
 BRMA4    RMA                RMA OF BUFFER
 BPVA4    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF5    PPWORD             OFFSET IN BUFFER
 BST5     PPWORD             STATUS OF BUFFER
 BRMA5    RMA                RMA OF BUFFER
 BPVA5    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF6    PPWORD             OFFSET IN BUFFER
 BST6     PPWORD             STATUS OF BUFFER
 BRMA6    RMA                RMA OF BUFFER
 BPVA6    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF7    PPWORD             OFFSET IN BUFFER
 BST7     PPWORD             STATUS OF BUFFER
 BRMA7    RMA                RMA OF BUFFER
 BPVA7    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF8    PPWORD             OFFSET IN BUFFER
 BST8     PPWORD             STATUS OF BUFFER
 BRMA8    RMA                RMA OF BUFFER
 BPVA8    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF9    PPWORD             OFFSET IN BUFFER
 BST9     PPWORD             STATUS OF BUFFER
 BRMA9    RMA                RMA OF BUFFER
 BPVA9    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF10   PPWORD             OFFSET IN BUFFER
 BST10    PPWORD             STATUS OF BUFFER
 BRMA10   RMA                RMA OF BUFFER
 BPVA10   STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF11   PPWORD             OFFSET IN BUFFER
 BST11    PPWORD             STATUS OF BUFFER
 BRMA11   RMA                RMA OF BUFFER
 BPVA11   STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF12   PPWORD             OFFSET IN BUFFER
 BST12    PPWORD             STATUS OF BUFFER
 BRMA12   RMA                RMA OF BUFFER
 BPVA12   STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF13   PPWORD             OFFSET IN BUFFER
 BST13    PPWORD             STATUS OF BUFFER
 BRMA13   RMA                RMA OF BUFFER
 BPV13    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF14   PPWORD             OFFSET IN BUFFER
 BST14    PPWORD             STATUS OF BUFFER
 BRMA14   RMA                RMA OF BUFFER
 BPVA14   STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF15   PPWORD             OFFSET IN BUFFER
 BST15    PPWORD             STATUS OF BUFFER
 BRMA15   RMA                RMA OF BUFFER
 BPVA15   STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF16   PPWORD             OFFSET IN BUFFER
 BST16    PPWORD             STATUS OF BUFFER
 BRMA16   RMA                RMA OF BUFFER
 BPVA16   STRUCT 6           PVA OF BUFFER
          PPWORD

 CB       RECEND
          EJECT
          CON    INIT-1


* DIRECT CELLS

 CM.PIT   BSSZ   3           CM ADDRESS OF PP INTERFACE TABLE (REFORMATED)

 T1       BSSZ   1
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1
 CM       BSSZ   4

 CMADR    BSSZ   3           CM ADDRESS
 CHAN     BSSZ   1           CHANNEL NUMBER
 P0       BSSZ   1           P SERIES USED BY PP DRIVER CODE
 W0       EQU    P0          W SERIES USED BY THE DEADSTART CODE
 P1       BSSZ   1
 W1       EQU    P1
 P2       BSSZ   1
 W2       EQU    P2
 P3       BSSZ   1
 W3       EQU    P3
 P4       BSSZ   1
 W4       EQU    P4
 P5       BSSZ   1
 W5       EQU    P5
 P6       BSSZ   1
 W6       EQU    P6
 WC       BSSZ   1           WORD COUNT TO READ/WRITE CM WORDS
 TM       BSSZ   2           TIMER COUNT DOWN UNTIL NEXT SAMPLE
 BN       BSSZ   1           CURRENT PROCESSING BUFFER NUMBER
 BA       BSSZ   1           ADDRESS OF REFORMATTED CENTRAL BUFFER
 FNC      BSSZ   1           FUNCTION CODE (INTERNAL)
 RESPC    BSSZ   1           RESPONSE CODE
 SSUN     CON    7777B       UX VALUE OF CURRENT SS TABLE
 CHLOCK   BSSZ   1           SET NONZERO IF CHANNEL LOCK IS SET
 IDLE     BSSZ   1           NONZERO IF IDLE COMMAND RECEIVED,
                               RESUME COMMAND RESETS IT TO 0
 PPRQ     BSSZ   1           PP REQUEST FLAG
 EC       BSSZ   1           MAINTENANCE REGISTER EQUIPEMENT CODE
 EC0      BSSZ   1           EQUIPEMNT CODE FOR PROCESSOR 0
 EC1      BSSZ   1           EQUIPMENT CODE FOR PROCESSOR 1
 MD       BSSZ   1           MODEL NUMBER
 RN       BSSZ   1           REGISTER NUMBER
 IB       BSSZ   2           EICB ACCESS
 HP       BSSZ   2           HOLD R REGISTER
 LFF00    BSSZ   1
          SPACE  3
          ORG    72B

 DSRTP    CON    0           HCS REAL MEMORY WORD-ADDRESS
          CON    1
 NODEL    EQU    DSRTP       DON'T DELINK REQUEST FLAG
 INPNT    EQU    DSRTP+1     IN POINTER FOR RESPONSE BUFFER
 LIM      BSSZ   1           LIMIT OF RESPONSE BUFFER (IN 8-BIT BYTES)
 PPNO     CON    1           LOGICAL PP NUMBER
          ORG    76B
          CON    5           TEMPORARY, PP TYPE USED BY DEADSTART
 LDCMF    EQU    76B         LOAD CONTROL MODULE, IF NONZERO
 ON       CON    1           CONSTANT 1 MAINLY USED FOR SINGLE WORD TRANSFERS
          EJECT
          ORG    100B
 START    LJM    INIT
          SPACE  6
 CM.CB    BSSZ   3           CM ADDRESS OF PP COMMUNICATION BUFFER (REFORMATTED)
 CM.RS    BSSZ   3           CM ADDRESS OF RESPONSE BUFFER (REFORMATTED)
 CM.INT   BSSZ   3           CM ADDRESS OF INTERRUPT WORD
 CM.CHAN  BSSZ   3           CM ADDRESS OF CHANNEL INTERLOCK TABLE
 CM.BF1   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF2   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF3   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF4   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF5   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF6   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF7   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF8   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF9   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF10  BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF11  BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF12  BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF13  BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF14  BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF15  BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF16  BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.CBUF  BSSZ   3           CM ADDRESS OF CURRENT SPI BUFFER (REFORMATTED)
 BUFS     BSSZ   4
 MAXOFF   CON    256D        MAXIMUM NUMBER OF WORDS IN ONE SPI COLLECTION PAGE
 RDATA    BSSZ   8           CONTENTS OF P REGISTER
          BSSZ   3           REQUIRED TO BE BEFORE HBUF. DO NOT CHANGE OR MOVE.
 HBUF     BSSZ   CMXLEN      HARDWARE ELEMENT BUFFER
          SPACE  2
          EJECT
 SPI      BSS

** NAME - MAIN   THE MAIN PROCESSING LOOP
*
** PURPOSE THIS IS THE MAIN PROCESSING LOOP FO THE SPI DATA COLLECTOR.
*         IT CHECKS FOR ANY COMMANDS ON THE PP REQUEST QUEUE AND WILL
*         PROCESS THOSE REQUESTS. IF THE PP HAS NOT BEEN IDLED THEN
*         THE PP WILL COLLECT P REGISTER SAMPLES. AFTER THAT IT WILL
*         WAIT FOR 1 MS BEFORE TRYING AGAIN. THE ONLY VALID COMMANDS
*         FOR THIS PP FROM THE PP INTERFACE TABLE ARE IDLE AND RESUME.
*
** USES   MACRO PAUSE


 MAIN10   BSS
          RJM    PPREQ       CHECK FOR ANY PP REQUESTS
          ZJN    MAIN40      IF NO PP REQUESTS
          RJM    SRESP       SET UP RESPONSE BUFFER
 MAIN20   RJM    UNCMND      GET PP COMMAND AND SET UP TO PROCESS
          ZJN    MAIN35      IF NO MORE COMMANDS
          LDML   UCMDPR,FNC  GET COMMAND PROCESSOR. FNC SET BY UNCMND.
          STML   MAINA
          RJM    **          PROCESS COMMAND
 MAINA    EQU    *-1
          LDDL   RESPC       CHECK FOR ABNORMAL RESPONSE CODE
          SBN    R.ABN
          NJK    MAIN20      IF NO ERROR, LOOK FOR ANOTHER COMMAND

 MAIN35   RJM    TERMP       SEND TERMINATION RESPONSE

 MAIN40   BSS
          LDDL   IDLE
          NJK    MAIN10      IF IDLE COMMAND, ONLY PROCESS PP REQUESTS

          PAUSE  1000D       WAIT 1 MS BEFORE TRYING AGAIN
          UJK    MAIN10


* PP COMMAND PROCESSORS.

 UCMDPR   BSS
          CON    IDLEP       IDLE
          CON    RESUME      RESUME
          EJECT
** NAME-- SRESP
*
** PURPOSE-- SET UP STATUS RESPONSE BUFFER.
          SPACE  6
 SREX     LJM    **
 SRESP    EQU    *-1
          RJM    ZRESP         ZERO OUT RESPONSE BUFFER
          LDML   SS+/SS/P.PVA  PUT PVA OF REQUEST IN RESPONSE BUFFER
          STML   RS+/RS/P.PVA
          LDML   SS+/SS/P.PVA+1
          STML   RS+/RS/P.PVA+1
          LDML   SS+/SS/P.PVA+2
          STML   RS+/RS/P.PVA+2
*
          LDN    0
          STML   RS+/RS/P.XFER  CLEAR TRANSFER COUNT
          STML   RS+/RS/P.XFER+1
          UJK    SREX           RETURN
          EJECT
** NAME-- UNCMND
*
** PURPOSE-- GET NEXT COMMAND.
*
** INPUT-- NUMCM, FRST, RS+/RS/P.LASTC
*
** OUTPUT-- CMLIST, FNC, RQ+/RQ/P.CMND
*           LISTL.
*
** EXIT-- (A) = 0, IF NO MORE COMMANDS.
*         (A) .NE. 0, IF NEXT COMMAND PRESENT.
*         EXIT VIA ATERM IF COMMAND IS NOT IDLE OR RESUME
          SPACE  6
 UNCX     LJM    **
 UNCMND   EQU    *-1
          LDML   SS+/SS/P.NUMCM
          ZJN    UNCX        IF NO MORE COMMANDS, EXIT, A REGISTER = 0
          SOML   SS+/SS/P.NUMCM  DECREMENT COMMAND COUNT
          LDML   SS+/SS/P.FRST  HAS FIRST COMMAND BEEN PROCESSED
          ZJN    UNC10       IF FIRST COMMAND HASN'T BEEN PROCESSED

*         READ NEXT COMMAND FROM CM.

          AOML   SS+/SS/P.LASTC  INCREMENT OFFSET OF LAST COMMAND
          LDN    C.CM
          STDL   WC
          LOADF  SS+/SS/P.REQ  LOAD CM ADDRESS AND REFORMAT
          ADML   SS+/SS/P.LASTC  ADD OFFSET OF COMMAND
          CRML   CMD,WC       READ COMMAND FROM CM

*         IF INDIRECT ADDRESS, READ CM ADDRESS LIST.

 UNC10    BSS
          LDML   CMD+/CM/P.LEN  MAKE SURE IT IS AN EVEN NUMBER OF CM WORDS
          ADN    7
          SCN    7
          STML   CMD+/CM/P.LEN
          STML   CMLIST+/CM/P.LEN
          SHN    -3          CHANGE BYTE COUNT TO WORD COUNT
          STML   SS+/SS/P.LISTL  LENGTH OF CM ADDRESS AREA  (CM WORDS)
          LDML   CMD+/CM/P.INDIR
          SHN    /CM/L.INDIR+2
          MJN    UNC15       IF INDIRECT ADDRESS
          LDN    1
          STML   SS+/SS/P.LISTL  IF NOT INDIRECT, ONLY 1 COMMAND.
          LDML   CMD+/CM/P.RMA
          STML   CMLIST+/CM/P.RMA
          LDML   CMD+/CM/P.RMA+1
          STML   CMLIST+/CM/P.RMA+1
          UJN    UNC20

 UNC15    BSS
          RJM    GLIST       GET CM ADDRESS LIST OF DATA AREA

* IF SWITCH FLAG IS SET, EXIT.

 UNC20    BSS

*         SET UP INTERNAL FUNCTION CODE, FNC.

          LDN    0
          STDL   FNC         SET UP INTERNAL FUNCTION CODE
 UNC30    LDML   CMD+/CM/P.CODE  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          ERRNZ  /CM/L.CODE
          SBML   UCMD,FNC    COMPARE COMMAND CODE
          ZJN    UNC40       IF COMMAND FOUND
          AODL   FNC
          SBN    UCMDL
          MJN    UNC30       IF MORE COMMANDS TO CHECK
 UNC35    BSS
          LDC    E501        ERROR IN COMMAND CODE
          RJM    ATERM       ABNORMAL TERMINATION (NO RETURN)
*         (NO RETURN FROM ATERM)

 UNC40    BSS
          LDDL   FNC
          STML   SS+/SS/P.FNC  SAVE COMMAND CODE
          AOML   SS+/SS/P.FRST  SET FIRST COMMAND FLAG NONZERO
          UJK    UNCX        RETURN A REGISTER NONZERO

* PP COMMANDS.

 UCMD     BSS
          CON    C.IDLE
          CON    C.RESUME
 UCMDL    EQU    *-UCMD
          EJECT
** NAME-- GNB GET NEXT BUFFER
*
** PURPOSE
*   1) UPDATE CURRENT BUFFER STATUS CONTROL
*   2) ISSUE INTERRUPT TO CENTRAL VIA UNSOLICITED RESPONSE
*   3) GET NEXT AVAILABLE BUFFER
*   4) UPDATE ADDRESS POINTERS
*
** EXIT  (BA) = POINTER TO RMA OF NEXT CENTRAL MEMORY BUFFER
*

 GNBX    LJM    **
 GNB     EQU    *-1
         LDM    CBT+/CB/P.PPBUF LOAD CURRENT BUFFER
         SBN    /CB/B.HIGH+1 SUBTRACT HIGHEST POSSIBLE BUFFER PLUS ONE
         PJK    GNB1         IF FIRST TIME INTO GET NEXT BUFFER
         LDK    /CB/S.DATA
         STM    BUFS+1       SET BUFFER STATUS TO HAVE DATA
         LDM    CBT+/CB/P.PPOFF
         STM    BUFS         SET BUFFER OFFSET TO CURRENT OFFSET

* UPDATE CURRENT BUFFER STATUS TO HAS DATA AND SEND UNSOLICITED MESSAGE

         LOADC  CM.CB        SET CENTRAL ADDRESS OF COMMUNICATIONS BUFFER
         ADK    /CB/C.BOFF1  ADD FIRST BUFFER OFFSET
         ADD    BN           ADD IN BUFFER NUMBER (0 .. 15)
         ADD    BN           ADD IN BUFFER NUMBER
         CWML   BUFS,ON      UPDATE BUFFER STATUS

* SET UP INTERRUPT INSTRUCTION BASED ON THE INTERRUPT PORT NUMBER

         LOAD   CBT,CB,IPORT GET THE INTERRUPT PORT MASK
         NJN    GNB0         IF INTERRUPT THEN ISSUE A INTERRUPT INSTUCTION
         LDC    2400B        2400 IS PASS INSTUCTION
         UJN    GNB00
 GNB0    ADC    102600B      ADD IN THE OPCODE FOR INTERRUPT INSTUCTION
 GNB00   STML   INTPRC       STORE INTERRUPT OR PASS INSTURCTION IN RESPIN
         RJM    SNMSG        SEND UNSOLICITED RESPONSE

*  POSITION TO NEXT BUFFER

         AOD    BN           INCREMENT TO NEXT BUFFER NUMBER
         SBN    /CB/B.HIGH
         MJN    GNB2         IF NOT PAST LAST BUFFER IN POOL

* PAST END POSITION FO FIRST BUFFER

 GNB1    LDC    CM.BF1       GET ADDRESS OF FIRST REFORMATTED ADDRESS
         STD    BA           SET POINTER TO FIRST REFORMATTED BUFFER ADDRESS
         LDN    0
         STD    BN           SET BUFFER NUMBER TO 0
         STM    CBT+/CB/P.PPBUF

*  GET UNFORMATTED RMA OF NEW BUFFER

 GNB2    LDIL   BA
         STML   CM.CBUF       UPDATE CM BUFFER ADDRESS
         AOD    BA
         LDIL   BA
         STML   CM.CBUF+1     UPDATE SECOND PART OF BUFFER ADDRESS
         AOD    BA
         LDIL   BA
         STML   CM.CBUF+2     UPDATE THIRD PART OF BUFFER ADDRESS
         AOD    BA            INCREMENT POINTER TO NEXT BUFFER ADDRESS

* WAIT FOR NEXT BUFFER TO BECOME AVAILABLE

 GNB3    LOADC  CM.CB         GET ADDRESS OF COMMUNICATIONS BUFFER
         ADK    /CB/C.BOFF1   ADD OFFSET TO FIRST BUFFER CONTROL
         ADD    BN
         ADD    BN            HAVE OFFSET TO CURRENT BUFFER CONTROL
         CRML   BUFS,ON       READ CURRENT BUFFER STATUS
         LDM    BUFS+1        GET CURRENT BUFFER STATUS
         SBN    /CB/S.AVAIL
         ZJN    GNB4          IF CURRENT BUFFER STATUS IS AVIALABLE
         PAUSE  1000          WAIT FOR BUFFER STATUS
         UJN    GNB3          TRY BUFFER STATUS AGAIN

* SET BUFFER STATUS TO IN USE BY PP

 GNB4    LDK    /CB/S.INUSE
         STM    BUFS+1        SET BUFFER STATUS TO IN USE BY PP
         LDN    0             SET OFFSET TO ZERO
         STM    CBT+/CB/P.PPOFF
         STM    BUFS
         LOADC  CM.CB         LOAD COMMUNICATION BUFFER ADDRESS
         ADK    /CB/C.BOFF1   ADD IN OFFSET TO FIRST BUFFER
         ADD    BN
         ADD    BN            NOW HAVE OFFSET OF CURRENT BUFFER CONTROL
         CWML   BUFS,ON       UPDATE BUFFER STATUS

* UPDATE PP STATUS TO INDICATE NEW BUFFER IN USE

         AOM    CBT+/CB/P.PPBUF UPDATE PP BUFFER STATUS IN COMMUNICATION BUFFER
         LOADC  CM.CB
         CWML   CBT+/CB/P.PPBUF,ON        UPDATE PP STATUS TO CENTRAL
         LJM    GNBX

         EJECT
** NAME-- GLIST
*
** PURPOSE-- READ THE CM ADDRESS LIST PORTION OF A COMMAND.
*
** INPUT-- LISTL
*
** OUTPUT-- CMLIST, CMD+/CM/P.RMA
          SPACE  6
 GLIX     LJM    **
 GLIST    EQU    *-1
          LDML   SS+/SS/P.LISTL  NO OF CM WORDS IN ADDRESS-LENGTH-PAIR LIST
          ZJN    GLIX        IF NO WORDS TO READ
          LOADF  CMD+/CM/P.RMA  LOAD CM ADDRESS AND REFORMAT
          CRML   CMLIST,ON
          LDN    8
          RAML   CMD+/CM/P.RMA+1  UPDATE RMA ADDRESS FOR NEXT READ
          SHN    -16
          RAML   CMD+/CM/P.RMA
          LDML   CMLIST+/CM/P.LEN  MAKE SURE IT IS AN EVEN NUMBER OF CM WORDS
          ADN    7
          SCN    7
          STML   CMLIST+/CM/P.LEN
          UJK    GLIX
          EJECT
** NAME-- ATERM
*
** PURPOSE-- ABNORMAL TERMINATION FOR INTERFACE ERRORS.
          SPACE  6
 ATERM    CON    0
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LDK    /RS/K.INTERR
          STDL   T1          SAVE ERROR ID
          LMC    -0
          STDL   T2
          LDML   RS+/RS/P.CHERR
          LPDL   T2
          ADDL   T1          ADD ERROR FLAG
          STML   RS+/RS/P.CHERR SAVE ERROR CODE
          LDK    C.RS*8
          STML   RS+/RS/P.RESPL RESPONSE LENGTH
          LDML   RS+/RS/P.PVA
          ADML   RS+/RS/P.PVA+1
          ADML   RS+/RS/P.PVA+2
          NJN    ATERM10        IF UNRECOVERED REQUEST
          RJM    SNMSG          SEND UNSOLICITED MESSAGE
          LJM    MAIN35

 ATERM10  BSS
          LDN    R.ABN          ABNORMAL TERMINATION
          STDL   RESPC          RESPONSE CODE
          LJM    MAIN35
          EJECT
** NAME-- TERMP
*
** PURPOSE-- TERMINATE PP REQUEST.
*
** OUTPUT-- RS+/RS/P.RC = RESPONSE CODE
          SPACE  6
 TERX     LJM    **
 TERMP    EQU    *-1
          RJM    PUTRC       PUT RESPONSE CODES IN RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
          LDN    0
          STDL   PPRQ        ZERO OUT PP REQUEST FLAG
          RJM    ZRESP       ZERO OUT RESPONSE BUFFER
          UJK    TERX
          EJECT
** NAME-- PUTRC
*
** PURPOSE-- PUT RESPONSE CODES IN RESPONSE
          SPACE  6
 PUTRCX   LJM    **
 PUTRC    EQU    *-1
          LDDL   RESPC       RESPONSE CODE
          SHN    /RS/L.RCON-/RS/L.RC+/RS/N.RCON-/RS/N.RC
          ADML   RCON        RESPONSE CONDITION
          SHN    /RS/L.URC-/RS/L.RCON+/RS/N.URC-/RS/N.RCON
          ERRNZ  /RS/P.URC-/RS/P.RCON
          ERRNZ  /RS/P.RC-/RS/P.URC
          STML   RS+/RS/P.URC
          UJK    PUTRCX
          EJECT
** NAME-- RESP
*
** PURPOSE-- WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
*
** INPUT-- CM.PIT, CM.RS, LIM, /PIT/IN, /PIT/OUT, RS+/RS/P.RESPL
*
** OUTPUT-- /PIT/IN, RESPONSE BUFFER
          SPACE  6
          SPACE  6
 RESPX    LJM    **
 RESP     EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDN    0
          STML   STORS       SET FLAG TO STORE RESPONSE
          LDML   CMD+/CM/P.STOR  CHECK IF CALLER WANTS RESPONSE
          SHN    /CM/L.STOR+2
          MJN    RESP10      IF STORE RESPONSE FLAG IS SET
          LDDL   RESPC       CHECK FOR NORMAL RESPONSE
          SBN    R.NRM
          NJN    RESP10      IF NOT NORMAL RESPONSE, STORE RESPONSE
          AOML   STORS       NONZERO MEANS DO NOT STORE RESPONSE
 RESP5    UJK    RESPX

* READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RESP10   BSS
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF 'IN' POINTER
          CRDL   P1          READ 'IN' POINTER

* CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDN    0
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE
          LDDL   P4
          SBDL   P5
          MJN    RESP20      IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   P5
 RESP20   LDML   RS+/RS/P.RESPL  GET RESPONSE LENGTH
          ZJK    RESP5       IF RESPONSE LENGTH = 0
          ADDL   P4
          STDL   INPNT       IN + RESPONSE LENGTH
          SBDL   P5          CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          PJK    RESP10      IF NOT ENOUGH ROOM IN BUFFER, LOOP
          LDDL   P4
          SHN    -3
          STDL   T3          'IN' POINTER IN WORDS
          LDML   RS+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          LDDL   INPNT
          SBDL   LIM
          MJN    RESP50      IF IN + RESPONSE LENGTH .LT. LIMIT
                             ONLY 1 BLOCK WRITE
          STDL   INPNT       IN + RESPONSE LENGTH - LIMIT = NEW 'IN' POINTER
          SHN    -3
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE

* WRITE RESPONSE TO CM.

          LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   P4
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADC    RS
          STML   RESPA       RESPONSE ADDRESS FOR 2ND BLOCK WRITE
 RESP50   BSS
          LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD 'IN' OFFSET
          CWML   RS,T4       WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          ZJN    RESP70      IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          LMC    400000B
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
                             (BEGINNING OF RESPONSE BUFFER)
 RESPA    EQU    *-1

 RESP70   BSS
          LJM    RESPX
          EJECT
** NAME-- RESPIN
*
** PURPOSE-- UPDATE THE 'IN' POINTER IN THE CM RESPONSE BUFFER.
*
** INPUT-- INPNT = NEW 'IN' POINTER.
          SPACE  6
 RESNX    LJM    **
 RESPIN   EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDML   STORS       CHECK IF CALLER WANTS RESPONSE
          NJK    RESNX       IF NO RESPONSE WAS SENT

* UPDATE THE 'IN' POINTER.

          LDN    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDDL   INPNT       NEW 'IN' POINTER
          STDL   P4
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   P1          WRITE NEW 'IN' POINTER TO CM

* INTERRUPT PROCESSOR. RESP ROUTINE SETS UP THIS INSTRUCTION.

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   PPNO-3      SET LAST BYTE NONZERO
          LDN    0           CLEAR A-REGISTER FOR S0 HARDWARE PROBLEM
 INTPRC   INPN   1           THIS INSTRUCTION IS MODIFIED BY GNB
          CRDL   T1          THIS INSTRUCTION IS BECAUSE OF AN 810/830 PROBLEM
          UJK    RESNX
          EJECT
** NAME SNMSG - SEND UNSOLICITED MESSAGE.
*
** PURPOSE-- SEND AN UNSOLICITED MEAAGE TO THE CENTRAL PROCESSOR
          SPACE  6
 SNMSGX   LJM    **
 SNMSG    EQU    *-1
          LDK    C.RS*8      SET RESPONSE LENGTH FOR ERROR
          STML   RS+/RS/P.RESPL
          LDN    0           UNSOLICITED MESSAGE
          STDL   RESPC       RESPONSE CODE
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          RJM    TERMP       SEND RESPONSE TO CM
          UJK    SNMSGX
          EJECT
** NAME-- ZRESP
*
** PURPOSE-- ZERO OUT PART OF THE RESPONSE BUFFER.
*
** NOTE-- THIS ROUTINE IS ALSO CALLED FOR RECOVERED ERROR RESPONSES.
          SPACE  6
 ZREX     LJM    **
 ZRESP    EQU    *-1
          LDN    0
          STML   RCON        RESPONSE CONDITION
          STDL   NODEL       DON'T DELINK REQUEST FLAG
          STML   RS+/RS/P.HDWR  ABNORMAL STATUS
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE

          LDK    P.RS-/RS/P.FTRK
          STDL   T1
 ZER10    LDN    0
          STML   RS+/RS/P.FTRK-1,T1 ZERO OUOT PART OF RESPONSE BUFFER
          SODL   T1
          NJN    ZER10
          LDK    /RS/C.LASTC*8+8  SET RESPONSE LENGTH FOR NORMAL RESPONSE
          STML   RS+/RS/P.RESPL
          LDN    R.NRM       SET RESPONSE CODE = NORMAL
          STDL   RESPC
          SHN    16-/RS/N.RC-/RS/L.RC
          STML   RS+/RS/P.RC  PUT REPONSE CODE IN RESPONSE
          UJK    ZREX
          EJECT
** NAME-- SPLOCK
*
** PURPOSE-- SETS THE PP REQUEST QUEUE LOCK IN THE
*            PP INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SPLX     LJM    **
 SPLOCK   EQU    *-1
          LDC    7777B
          STDL   SSUN        INVALIDATE SS TABLE
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    LOCKW       SET THE LOCKWORD
          NJK    SPLX        IF LOCK COULD NOT BE SET
          RJM    SCLOCK      SET CHANNEL LOCK
          UJK    SPLX
          EJECT


          EJECT
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
*
** EXIT-- (A) = 0, IF LOCK WAS SUCCESSFULLY SET.
*         (A) .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SCL40    LDN    0           SET LOCK SUCCESSFUL
 SCLX     LJM    **
 SCLOCK   EQU    *-1
          LDDL   CHLOCK
          NJN    SCL40       IF CHANNEL LOCK IS NOT SET

 SCL10    BSS
          LDK    C.CHCNT
          STML   CHLCNT      NUMBER OF REQUESTS TO PROCESS BEFORE
                             GIVING UP CHANNEL
          LDN    6           SET TIMEOUT DELAY TO 5 SECONDS ON S1
          STDL   P1
          STDL   P2
 SCL20    BSS
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCKW       SET LOCKWORD
          NJN    SCL30       IF LOCK WAS NOT SET
          AODL   CHLOCK      SET FLAG IF LOCK WAS SET
          UJK    SCL40       EXIT, LOCK WAS SET

 SCL30    BSS
          SODL   P1
          NJK    SCL20
          SODL   P2
          NJK    SCL20
          LDN    1           TIMEOUT ON TRYING TO GET CHANNEL LOCK
          UJK    SCLX        EXIT A REGISTER NONZERO





** NAME-- LOCKW SET CENTRAL LOCK WORD
*
** PURPOSE-- TO SET CENTRAL LOCK WORD

 LOCKX    LJM    **
 LOCKW    EQU    *-1

* SET LOCK BIT.

          LDC    100000B     SET UNIT LOCK BIT
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          SET LOCK BIT IN UNIT LOCKWORD

* CHECK IF LOCK WAS OBTAINED.

          LDDL   T1
          ADDL   T4
          ZJN    LOCK20      IF LOCK COULD BE SET
          LDDL   T4
          SBDL   PPNO        CHECK IF LOCK ALREADY SET
          NJN    LOCK10      IF LOCK COULD NOT BE SET, EXIT A .NE. 0
          LDDL   T1
          ADC    -100000B
 LOCK10   UJK    LOCKX       EXIT WITH LOCK VALUE

* SET PP NUMBER IN LOCKWORD.

 LOCK20   BSS
          LDDL   PPNO
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    RR
          RDSL   T1          SET PP NUMBER IN LOCKWORD

* CHECK IF LOCK WAS CORRECT BEFORE LAST RDSL OPERATION.

          LDDL   T1
          ADC    -100000B
          NJN    LOCK40
          LDDL   T4
          ZJK    LOCK10      IF NO ERROR, EXIT

 LOCK30   UJN    *           ERROR IN LOCKWORD

* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

 LOCK40   BSS
          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          NJN    LOCK30
          AODL   LFF00
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          UJK    LOCK20
          EJECT
** NAME-- CCLOCK
*
** PURPOSE-- CLEARS CHANNEL LOCK.
*
          SPACE  6
 CCLX     LJM    **
 CCLOCK   EQU    *-1
          LDDL   CHLOCK
          ZJK    CCLX        IF CHANNEL LOCK WAS NOT SET
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CHAN        CHANNEL NUMBER = OFFSET IN TABLE
          STDL   T5
          RJM    CLOCK       CLEAR CHANNEL LOCKWORD
          LDN    0
          STDL   CHLOCK      CLEAR CHANNEL LOCK FLAG
          UJK    CCLX
          EJECT
** NAME-- CPLOCK
*
** PURPOSE-- CLEARS THE PP QUEUE LOCK IN THE PP INTERFACE TABLE.
*
          SPACE  6
 CPLX     LJM    **
 CPLOCK   EQU    *-1
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWROD
          UJK    CPLX
          EJECT
** NAME - CLOCK
*
** PURPOSE - CLEAR A CENTRAL LOCK
*
** EXIT CONDITIONS - (A) = 0 IF LOCK IS CLEARED
*                    (A) .NE. 0 IF LOCK NOT CLEARED

 CLKX     LJM    **
 CLOCK    EQU    *-1

* MAKE SURE THIS PP IS THE ONE WHO HAS THE LOCK SET.

 CLK10    BSS
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          CRDL   T1          READ UNIT LOCK
          LDDL   T4          CHECK PP NUMBER
          SBDL   PPNO
          ZJN    CLK30       IF THIS PP HAS THE LOCK SET

* CHECK IF LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          NJN    CLK20       ERROR, THIS PP DOES NOT HAVE THE UNIT RESERVED
          AODL   LFF00
          UJK    CLK10

 CLK20    BSS
          UJK    CLKX        EXIT, A REGISTER = 0, IF LOCK WAS CLEARED
                             EXIT, A REGISTER .NE. 0, IF LOCK COULD NOT
                               BE CLEARED

* CLEAR UNIT LOCKWORD IN UNIT INTERFACE TABLE.

 CLK30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK
          LMC    RR
          RDCL   T1          CLEAR LOCK

* CHECK IF LOCK WAS CORRECT BEFORE THE CLEAR OPERATION.

          LDDL   T1
          ADC    -100000B
          NJN    CLK50
          LDDL   PPNO
          SBDL   T4
          ZJK    CLK20       IF LOCK WAS OK
 CLK40    BSS
          UJN    *           LOCK WAS MESSED UP

* CHECK IF LOCKWORD = FFFF FFFF XXXX XXXX(16).

 CLK50    BSS
          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          NJK    CLK40
          AODL   LFF00
          UJK    CLK30
          EJECT
** NAME-- FORMA
*
** PURPOSE-- FORMAT A CM REAL MEMORY ADDRESS.
*
** CALLING SEQUENCE-- LDC    ADDRESS
*                     RJM    FORMA
*
** INPUT-- - A REGISTER- IS THE ADDRESS OF A 2-WORD CM BYTE ADDRESS.
*
** OUTPUT-- -CMADR- IS THE ADDRESS OF THE RESULTING 3-WORD REFORMATED
*                CM ADDRESS.  THE FORMAT CAN BE USED BY THE LOADC MACRO.
*           -ADDRESS-, WORD 0, BITS 0-13 AND
*                      WORD 1, BITS 3-15, ARE REFORMATTED TO-
*           -CMADR-,   WORD 0, BITS 0-9,
*                      WORD 1, BITS 0-11,
*                      WORD 2, BITS 0-5.
*
          SPACE  6
 FORX     LJM    **
 FORMA    EQU    *-1
          STDL   T1
          LDML   1,T1
          LPN    7
          NJN    *           RMA ADDRESS ERROR, PERMANENT HALT
          LDIL   T1
          LPN    37B
          SHN    16
          LMML   1,T1
          SHN    9
          STD    CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   T1
          SHN    -5
          STD    CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMC    RR
          UJK    FORX
          EJECT
** NAME-- PAUS
*
** PURPOSE-- DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*            MICROSECONDS.
*
** INPUT-- A REGISTER (BITS 00-06) SPECIFIES NUMBER OF MICROSECONDS
*          TO BE DELAYED.
*
** NOTE-- THIS CODE IS MODIFIED BY THE INITIALIZATION ROUTINE.
*         THE INSTRUCTION ARE DEPENDANT ON THE TYPE OF MAINFRAME
*         THE CODE IS EXECUTED ON.
*
** CODE SEQUENCE FOR THE DIFFERENT MACHINES.
*         FOR THE S0
*         ENTRY
*         WAIT    (101700)
*         PASS
*         EXIT
*
*         FOR THE S1
*         ENTRY
* LOOP    SUBTRACT 1
*         GO TO LOOP IF NOT ZERO
*         EXIT
*
*         FOR OTHER MACHINES
*         ENTRY
* LOOP    SUBTRACT 1
*         PASS
*         PASS
*         GO TO LOOP IF NOT ZERO
*         EXIT
*

          SPACE  6
 PAUSX    LJM    **
 PAUS     EQU    *-1
*         THE FOLLOWING INSTRUCTION BECOMES A WAIT ON AN S0.
*         A WAIT IS AN 101700 INSTRUCTION
 PAUS10   SBN    1           EACH ITERATION OF THIS SBN-(PASS-PASS)-NJN LOOP
*         THE FOLLOWING INSTRUCTION BECOMES A PASS ON ANY NON S1 MACHINES.
 PAUS20   NJN    PAUS10      UTILIZES 1 MICROSECOND
*         THE FOLLOWING INSTRUCTION BECOMES A PASS ON ANY I2 OR I4 MACHINES
 PAUS30   UJK    PAUSX       EXIT FOR S0 AND S1 MACHINES
          NJN    PAUS10      UTILIZES 1 MICROSECOND ON AN I2 OR I4
          UJK    PAUSX       EXIT FOR S2, S3, AND THETA MACHINES
          EJECT
*copyc dsa$hardware_table_definitions
*copyc dsi$find_cip_module
*copyc dsi$get_hardware_element
*copyc dsi$maintenance_register_access
*copyc dsi$pack_unpack_registers
*copyc dsi$pp_utility_subroutines
          EJECT
** NAME-- PPREQ
*
** PURPOSE-- CHECK FOR ANY PP REQUESTS ON THE PP QUEUE.
*
** EXIT-- (A) = 0, IF NO PP REQUESTS.
*         (A) .NE. 0, IF A PP REQUEST WAS FOUND
          SPACE  6
 PPRQX    LJM    **
 PPREQ    EQU    *-1
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.PPQ  CM ADDRESS OF PP REQUEST QUEUE POINTER
          CRDL   P1          READ PP QUEUE POINTER
          LDDL   P3          RMA OF NEXT QUEUED PP REQUEST
          ADDL   P4
          ZJN    PPRQX       IF NO PP REQUESTS

* SET PP QUEUE LOCKWORD.

          RJM    SPLOCK      SET PP QUEUE LOCKWORD
          ZJN    PPRQ20      IF LOCK WAS SET

 PPRQ15   BSS
          LDN    0
          UJK    PPRQX       EXIT, A REGISTER = 0

* GET THE RMA OF THE FIRST PP REQUEST IN THE CHAIN.

 PPRQ20   BSS
          LDN    2
          STDL   WC
          LOADC  CM.PIT
          ADN    /PIT/C.PPQPVA
          CRML   T1,WC       READ PVA AND RMA OF FIRST REQUEST IN CHAIN

* PUT PVA AND RMA OF REQUEST IN SS TABLE.

          LDDL   T2          PUT PVA OF REQUEST IN SS TABLE
          STML   SS+/SS/P.PVA
          LDDL   T3
          STML   SS+/SS/P.PVA+1
          LDDL   T4
          STML   SS+/SS/P.PVA+2
          LDDL   T7          PUT RMA OF REQUEST IN SS TABLE
          STML   SS+/SS/P.REQ
          LDDL   T8
          STML   SS+/SS/P.REQ+1
          LDN    0
          STML   SS+/SS/P.FRST  SET FLAG WHEN REQUEST IS READ

* READ THE PP REQUEST.

          LDN    C.RQ
          STDL   P1
          LOADF  T7          CM ADDRESS OF FIRST PP REQUEST
          CRML   RQ,P1       READ PP REQUEST

* DELINK THE FIRST PP REQUEST FROM THE CHAIN.

 PPRQ30   BSS
          LOADC  CM.PIT
          ADN    /PIT/C.PPQPVA  CM ADDRESS OF PP QUEUE POINTER
          CWML   RQ,WC       WRITE PVA AND RMA POINTERS OF NEXT REQUEST
          RJM    CPLOCK      CLEAR PP QUEUE LOCKWORD
          LDML   RQ+/RQ/P.LEN  DETERMINE NUMBER OF COMMANDS
          SHN    -3
          SBN    /RQ/C.CMND
          STML   SS+/SS/P.NUMCM  NUMBER OF COMMANDS

          AODL   PPRQ        SET PP REQUEST FLAG
          UJK    PPRQX       EXIT, A REGISTER NONZERO
          EJECT
** NAME-- IDLEP
*
** PURPOSE-- PROCESS IDLE COMMAND.
          SPACE  6
 IDLX     LJM    **
 IDLEP    EQU    *-1
          AODL   IDLE        SET IDLE FLAG
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          UJK    IDLX
          EJECT
** NAME-- RESUME
*
** PURPOSE-- PROCESS RESUME COMMAND.
          SPACE  6
 RESX     LJM    **
 RESUME   EQU    *-1
          LDN    0
          STDL   IDLE        CLEAR IDLE FLAG
          UJK    RESX



 IPIT     EQU    *           PP INTERFACE TABLE
 CBT      EQU    IPIT+P.PIT
          ORG    CBT+P.CB
 STORS    BSSZ   1           STORE RESPONSE FLAG (USED BY RESPIN)
                               = 0, IF A RESPONSE IS SENT TO CM
                               = NONZERO, IF NO RESPONSE WAS SENT TO CM
 RCON     BSSZ   1           ADDITIONAL RESPONSE CONDITION
 CHLCNT   BSSZ   1           NUMBER OF REQUESTS TO PROCESS BEFORE
                             CLEARING CHANNEL LOCK
 SS       BSSZ   P.SS        INFORMATION SAVED IN UNIT COMMUNICATION BUFFER
 RQ       EQU    SS+/SS/P.RQ  REQUEST
 CMD      EQU    RQ+/RQ/P.CMND  CURRENT COMMAND
 CMLIST   EQU    SS+/SS/P.CMLIST  INDIRECT RMA LIST
 RS       EQU    SS+/SS/P.RS  RESPONSE BUFFER
          BSSZ   3           MUST FOLLOW RS, FOR ZEROING OUT RS

          EJECT
** NAME-- INIT
*
** PURPOSE-- INITIALIZE THE DRIVER AFTER DEADSTART.
*
** INPUT-- DSRTP = CM BYTE-ADDRESS OF THE PP INTERFACE TABLE.
          SPACE  6
 INIT     BSS
          RJM    PIB         PREPARE INTERFACE BLOCK
          RJM    PHT         PREPARE HARDWARE TABLES
          LDN    PROCID
          RJM    FHE         FIND PROCESSOR IN MRT
          MJN    *           HANG HERE, CANT FIND PROCESSOR CODE
          LDM    HBUF+CPRPC
          STD    EC0         SAVE EQUIPMENT CONNECT CODE
          LDM    HBUF+CPRE+EM
          SHN    -8
          STD    MD          SAVE MAINFRAME MODEL NUMBER
          SBN    5
          ZJN    INIT10      IF MODEL IS S0 THEN
          LDC    PPRG
          UJN    INIT11      PROCESS NON S0 MODEL NUMBER
 INIT10   LDC    S0PPRG
 INIT11   STD    RN          SAVE P REGISTER NUMBER
          LDC    PROCID1
          RJM    FHE         FIND HARDWARE ELEMENT FOR PROCESSOR 1
          MJN    INIT15      PROCESSOR 1 DOES NOT EXIST
          LDM    HBUF+CPRPC
          STD    EC1         SAVE CONNECT CODE FOR PROCESSOR 1

 INIT15   REFAD  DSRTP,CM.PIT   REFORMAT ADDRESS OF PP INTERFACE TABLE
                               AND SAVE.


* REFORMAT ADDRESS OF COMMUNICATION BUFFER.
* INITIALIZE CM.CB.

          LOADC  CM.PIT      ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.CBUF  OFFSET OF PP COMMUNICATION BUFFER ADDRESS
          CRDL   P1          READ ADDRESS OF PP COMMUNICATION BUFFER
          REFAD  P3,CM.CB    REFORMAT CM ADDRESS OF PP COMMUNICATION BUFFER

* READ COMMUNICATION BUFFER AND PROCESS WHEN BUFFER IS INITIALIZED.

 INIT20   LDN    C.CB
          STD    WC          SAVE WORD COUNT FOR COMMUNICATION BUFFER
          LOADC  CM.CB       ADDRESS OF COMMUNICATION BUFFER
          CRML   CBT,WC      READ COMMUNICATION BUFFER
          LDML   CBT+/CB/P.CPSTAT GET CP STATUS OF COMMUNICATION BUFFER
          SBN    /CB/S.INIT
*         ZJN    INIT30      IF COMMUNICATION BUFFER INITIALIZED
          PAUSE  1000
*         UJN    INIT20

* NOTE, DO NOT USE BUFFERS BEFORE THIS POINT, UNLESS THE PP IS
* HALTED AFTERWARD.

 INIT30   LDK    P.RS        ZERO OUT FULL RESPONSE BUFFER
          STDL   T1
 INIT98   BSS
          LDN    0
          STML   RS-1,T1     ZERO OUT RESPONSE BUFFER
          SODL   T1
          NJN    INIT98

          RJM    ZRESP       ZERO OUT RESPONSE BUFFER

* READ PP_INTERFACE_TABLE.

          LDN    C.PIT
          STDL   WC
          LOADC  CM.PIT      LOAD CM ADDRESS OF PP INTERFACE TABLE
          CRML   IPIT,WC     READ PP INTERFACE TABLE
          LDML   IPIT+/PIT/P.PPNO  GET PP NUMBER
          STDL   PPNO

* REFORMAT ADDRESS OF RESPONSE BUFFER.
* INITIALIZE CM.RS, LIM.

 INIT80   BSS
          REFAD  IPIT+/PIT/P.RSBUF,CM.RS  REFORMAT CM ADDRESS OF RESPONSE
                             BUFFER
          LDML   IPIT+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STDL   LIM

* REFORMAT ADDRESS OF INTERRUPT WORD.

          REFAD  IPIT+/PIT/P.INT,CM.INT  REFORMAT CM ADDRESS OF
                             INTERRUPT WORD

* REFORMAT ADDRESS OF CHANNEL TABLE.

          REFAD  IPIT+/PIT/P.CHAN,CM.CHAN  REFORMAT CM ADDRESS OF
                             CHANNEL TABLE

* REFORMAT ADDRESS OF CM BUFFERS
* INITIALIZE CM.BF1 TO CM.BF16

          REFAD  CBT+/CB/P.BRMA1,CM.BF1
          REFAD  CBT+/CB/P.BRMA2,CM.BF2
          REFAD  CBT+/CB/P.BRMA3,CM.BF3
          REFAD  CBT+/CB/P.BRMA4,CM.BF4
          REFAD  CBT+/CB/P.BRMA5,CM.BF5
          REFAD  CBT+/CB/P.BRMA6,CM.BF6
          REFAD  CBT+/CB/P.BRMA7,CM.BF7
          REFAD  CBT+/CB/P.BRMA8,CM.BF8
          REFAD  CBT+/CB/P.BRMA9,CM.BF9
          REFAD  CBT+/CB/P.BRMA10,CM.BF10
          REFAD  CBT+/CB/P.BRMA11,CM.BF11
          REFAD  CBT+/CB/P.BRMA12,CM.BF12
          REFAD  CBT+/CB/P.BRMA13,CM.BF13
          REFAD  CBT+/CB/P.BRMA14,CM.BF14
          REFAD  CBT+/CB/P.BRMA15,CM.BF15
          REFAD  CBT+/CB/P.BRMA16,CM.BF16

* ZERO OUT CONNECT CODES FOR PROCESSORS NOT SELECTED

          LOAD   CBT,CB,P0   LOAD PROCESSOR ZERO SELECT FLAG
          NJN    INIT83      IF PROCESSOR IS SELECTED
          STD    EC0         DESELECT PROCESSOR ZERO
 INIT83   LOAD   CBT,CB,P1   LOAD PROCESSOR ONE SELECT FLAG
          NJN    INIT85      IF PROCESSOR IS SELECTED
          STD    EC1         DESELECT PROCESSOR ONE

* STORE THE NAME SPI IN WORDS 100 AND 101

 INIT85   LDC    2R_NE
          STML   START
          LDC    2R_RD
          STML   START+1

* COPY OVER THE INITIAL TIMMER VALUE AND SET UP THE SPI IDENTIFIER
* FOR THE PROPER MAINFRAME.

          LDML   CBT+/CB/P.TIME
          STDL   TM
          LDML   CBT+/CB/P.TIME+1
          STDL   TM+1
          LDD    MD          GET THE MACHINE IDENTIFIER
          SBN    5           SUBTRACT THE S0 IDENTIFIER
          NJN    INIT90      IF NOT S0 TYPE MAINFRAME
          STML   CBT+/CB/P.SPIID ON S0 ONLY USE SPI ID OF ZERO

*  INITIALIZE PP STATUS OF COMMUNICATION BUFFER

 INIT90   LDN    /CB/B.HIGH+1 SET THE PP BUFFER NUMBER FOR START OF PROGRAM
          STM    CBT+/CB/P.PPBUF
          LDN    /CB/S.PWAIT SET THE STATUS TO IN USE
          STM    CBT+/CB/P.PPSTAT
          LDN    0           SET THE BUFFER OFFSET TO START OF BUFFER
          STM    CBT+/CB/P.PPOFF
          RJM    GNB         GET THE FIRST BUFFER


* THIS PART OF THE CODE INITIALIZES THE PAUSE DELAY LOOP FOR THE
* MACHINE THE CODE IS EXECUTED ON. THE INSTRUCTION MODIFICATION IS
* BASED ON THE MACHINE MODEL NUMBER OBTAINED ABOVE.

          LDD    MD          GET THE MACHINE MODEL NUMBER
          SBN    1
          ZJK    INIT94      IF THE SYSTEM IS ANY TYPE OF S1
          SBN    5-1
          ZJK    INIT92      IF THE SYSTEM IS AN S0

* SET UP PAUSE INSTRUCTIONS FOR I2 AND I4

          LDN    0           OP CODE FOR PASS INSTRUCTION
          STM    PAUS20      REPLACE NON ZERO JUMP WITH PASS INSTRUCTION
          STM    PAUS30      REPLACE EXIT JUMP WITH PASS INSTUCTION
          UJK    INIT94

* SET UP PAUSE INSTUCTIONS FOR S0

 INIT92   STM    PAUS20      REPLACE NON ZERO JUMP WITH PASS INSTRUCTION
          LDC    101700B     LOAD OP CODE FOR HOLD INSTRUCTION
          STML   PAUS10      REPLACE SUBTRACT WITH HOLD INSTRUCTION
 INIT94   LJM    SPI
          EJECT
 SAVAX    LJM    **
 SAVAD    EQU    *-1
          STML   2,T2
          LDDL   CMADR
          STI    T2
          LDDL   CMADR+1
          STML   1,T2
          UJK    SAVAX
 CONCH2   BSS
 TDC+40B  HERE
 T40B+DC  HERE
 TDC      HERE
          CON    0
          END    NERD
/EOR
*DECK DECK=CMM$PCU_EDITOR_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Physical Configuration Utility Subcommands processor.' ??
MODULE cmm$pcu_editor_commands;

{ PURPOSE:
{    This module contains the command processor interfaces for the
{    Physical Configuration Editor commands.
{ NOTE:
{    When adding new parameters to any of the PCU subcommands or
{    PCU editor commands, also add the P$XXXXXXX constant to
{    the constant declaration deck CMC$PCU_PARAMETER_INDICES.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmc$pcu_parameter_indices
*copyc cme$logical_configuration_utl
*copyc cme$physical_configuration_utl
*copyc cmt$element_definition
*copyc cmt$lcu_display_option_key
*copyc cmt$pcu_command_descriptor
*copyc cld$parameter_limits
*copyc clt$parameter_value_table
*copyc ost$name
?? POP ??
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_file
*copyc clp$count_list_elements
*copyc clp$close_display
*copyc clp$evaluate_parameters
*copyc clp$end_scan_command_file
*copyc clp$open_display
*copyc clp$reset_for_next_display_page
*copyc clp$put_partial_display
*copyc clp$push_utility
*copyc clp$pop_utility
*copyc clp$new_display_line
*copyc clp$build_standard_title
*copyc clp$put_job_output
*copyc clp$put_display
*copyc clp$get_command_origin
*copyc clp$scan_command_file
*copyc cmp$change_connection_ref_r3
*copyc cmp$change_definition
*copyc cmp$change_definition_name
*copyc cmp$check_reserved_names
*copyc cmp$clean_up_list
*copyc cmp$close_in_out_files
*copyc cmp$close_utility_files
*copyc cmp$crack_parameters
*copyc cmp$deadstart_phase
*copyc cmp$delete_all_elements
*copyc cmp$delete_definition
*copyc cmp$determine_element_type
*copyc cmp$display_elements_def
*copyc cmp$prompt_for_answer
*copyc cmp$search_edited_file
*copyc cmp$set_in_editor
*copyc cmp$set_exec_in_editor
*copyc cmp$open_utility_files
*copyc cmp$replace_definition
*copyc cmp$save_output
*copyc cmp$update_output_file
*copyc cmp$update_descriptor
*copyc fsp$open_file
*copyc fsp$close_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$append_status_parameter
*copyc osp$append_status_integer
*copyc cmv$command_descriptor_p
*copyc cmv$reserved_names_list
*copyc osv$lower_to_upper
?? OLDTITLE ??
?? NEWTITLE := '   cmp$add_element_def ', EJECT ??

{ PURPOSE :
{    This procedure is the command processor for the PCU editor command
{    ADD_ELEMENT_DEFINITION.

  PROCEDURE [XDCL] cmp$add_element_def
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);



{      PROCEDURE (cmm$edipc_added) add_element_definition, added (
{        element, e: name = $required
{        same_as, sa: name = $optional
{        element_identification, ei: any of
{            key
{          $834_12, $836_xxx, $844_4x, $885_1x, $887_1, $895_2, $9836_1, $9853_x,
{          $5832_1, $5832_2, $5833_1, $5833_1p, $5833_2, $5833_3p, $5833_4,
{          $5838_1, $5838_1p, $5838_2, $5838_3p, $5838_4,
{          $47444_1, $47444_1p, $47444_2, $47444_3p, $47444_4,
{          $7155_1,$7155_1x, $7165_2x, $10395_11, $fa7b4_d, $fa7b5_a, $5831_x,
{          $5680_11, $5682_1x, $5698_1x, $639_1, $679_x, $698_1x, $698_2x,
{          $698_3x, $7021_3x, $7221_1, $7221_11, $9639_1, $65354_1x, $4000_xx,
{          $2620_xxx, $2621_xxx, $2629_x, $380_170, $5380_100, $7040_200
{            keyend
{            name 1..10
{          anyend = $optional
{        iou_program_name, ioupn, ipn: name = $optional
{        serial_number, sn: integer 1..999999 = $optional
{        state, s: key
{            down, off, on
{          keyend = on
{        central_memory_connection, central_memory_connections, cmc: list 1..CLC$MAX_VALUE_SETS of record
{            port: integer 0..3
{            mainframe: name = $optional
{          recend = $optional
{        iou_connection, iou_connections, ic: list 1..CLC$MAX_VALUE_SETS of record
{            channel: name
{            equipment: integer 0..7 = $optional
{            mainframe: name = $optional
{            iou: name = $optional
{          recend = $optional
{        peripheral_connection, peripheral_connections, pc: list 1..CLC$MAX_VALUE_SETS of record
{            peripheral_element: name
{            physical_address: integer 0..0ffff(16) = $optional
{          recend = $optional
{        verify_element_identification, vei: boolean = true
{        application_information, ai: string = $optional
{        site_information, si: string = $optional
{        status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 29] of clt$pdt_parameter_name,
      parameters: array [1 .. 13] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: 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 .. 52] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
        default_value: string (2),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type13: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [94, 3, 16, 10, 58, 17, 516],
    clc$command, 29, 13, 1, 0, 0, 0, 13, 'CMM$EDIPC_ADDED'], [
    ['AI                             ',clc$abbreviation_entry, 11],
    ['APPLICATION_INFORMATION        ',clc$nominal_entry, 11],
    ['CENTRAL_MEMORY_CONNECTION      ',clc$nominal_entry, 7],
    ['CENTRAL_MEMORY_CONNECTIONS     ',clc$alias_entry, 7],
    ['CMC                            ',clc$abbreviation_entry, 7],
    ['E                              ',clc$abbreviation_entry, 1],
    ['EI                             ',clc$abbreviation_entry, 3],
    ['ELEMENT                        ',clc$nominal_entry, 1],
    ['ELEMENT_IDENTIFICATION         ',clc$nominal_entry, 3],
    ['IC                             ',clc$abbreviation_entry, 8],
    ['IOUPN                          ',clc$alias_entry, 4],
    ['IOU_CONNECTION                 ',clc$nominal_entry, 8],
    ['IOU_CONNECTIONS                ',clc$alias_entry, 8],
    ['IOU_PROGRAM_NAME               ',clc$nominal_entry, 4],
    ['IPN                            ',clc$abbreviation_entry, 4],
    ['PC                             ',clc$abbreviation_entry, 9],
    ['PERIPHERAL_CONNECTION          ',clc$nominal_entry, 9],
    ['PERIPHERAL_CONNECTIONS         ',clc$alias_entry, 9],
    ['S                              ',clc$abbreviation_entry, 6],
    ['SA                             ',clc$abbreviation_entry, 2],
    ['SAME_AS                        ',clc$nominal_entry, 2],
    ['SERIAL_NUMBER                  ',clc$nominal_entry, 5],
    ['SI                             ',clc$abbreviation_entry, 12],
    ['SITE_INFORMATION               ',clc$nominal_entry, 12],
    ['SN                             ',clc$abbreviation_entry, 5],
    ['STATE                          ',clc$nominal_entry, 6],
    ['STATUS                         ',clc$nominal_entry, 13],
    ['VEI                            ',clc$abbreviation_entry, 10],
    ['VERIFY_ELEMENT_IDENTIFICATION  ',clc$nominal_entry, 10]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1956,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 7
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 120,
  clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 202,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 120,
  clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 11
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 12
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 13
    [27, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    1931, [[1, 0, clc$keyword_type], [52], [
      ['$10395_11                      ', clc$nominal_entry, clc$normal_usage_entry, 29],
      ['$2620_XXX                      ', clc$nominal_entry, clc$normal_usage_entry, 47],
      ['$2621_XXX                      ', clc$nominal_entry, clc$normal_usage_entry, 48],
      ['$2629_X                        ', clc$nominal_entry, clc$normal_usage_entry, 49],
      ['$380_170                       ', clc$nominal_entry, clc$normal_usage_entry, 50],
      ['$4000_XX                       ', clc$nominal_entry, clc$normal_usage_entry, 46],
      ['$47444_1                       ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['$47444_1P                      ', clc$nominal_entry, clc$normal_usage_entry, 22],
      ['$47444_2                       ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['$47444_3P                      ', clc$nominal_entry, clc$normal_usage_entry, 24],
      ['$47444_4                       ', clc$nominal_entry, clc$normal_usage_entry, 25],
      ['$5380_100                      ', clc$nominal_entry, clc$normal_usage_entry, 51],
      ['$5680_11                       ', clc$nominal_entry, clc$normal_usage_entry, 33],
      ['$5682_1X                       ', clc$nominal_entry, clc$normal_usage_entry, 34],
      ['$5698_1X                       ', clc$nominal_entry, clc$normal_usage_entry, 35],
      ['$5831_X                        ', clc$nominal_entry, clc$normal_usage_entry, 32],
      ['$5832_1                        ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['$5832_2                        ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['$5833_1                        ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['$5833_1P                       ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['$5833_2                        ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['$5833_3P                       ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['$5833_4                        ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['$5838_1                        ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['$5838_1P                       ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['$5838_2                        ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['$5838_3P                       ', clc$nominal_entry, clc$normal_usage_entry, 19],
      ['$5838_4                        ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['$639_1                         ', clc$nominal_entry, clc$normal_usage_entry, 36],
      ['$65354_1X                      ', clc$nominal_entry, clc$normal_usage_entry, 45],
      ['$679_X                         ', clc$nominal_entry, clc$normal_usage_entry, 37],
      ['$698_1X                        ', clc$nominal_entry, clc$normal_usage_entry, 38],
      ['$698_2X                        ', clc$nominal_entry, clc$normal_usage_entry, 39],
      ['$698_3X                        ', clc$nominal_entry, clc$normal_usage_entry, 40],
      ['$7021_3X                       ', clc$nominal_entry, clc$normal_usage_entry, 41],
      ['$7040_200                      ', clc$nominal_entry, clc$normal_usage_entry, 52],
      ['$7155_1                        ', clc$nominal_entry, clc$normal_usage_entry, 26],
      ['$7155_1X                       ', clc$nominal_entry, clc$normal_usage_entry, 27],
      ['$7165_2X                       ', clc$nominal_entry, clc$normal_usage_entry, 28],
      ['$7221_1                        ', clc$nominal_entry, clc$normal_usage_entry, 42],
      ['$7221_11                       ', clc$nominal_entry, clc$normal_usage_entry, 43],
      ['$834_12                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['$836_XXX                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['$844_4X                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['$885_1X                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['$887_1                         ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['$895_2                         ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['$9639_1                        ', clc$nominal_entry, clc$normal_usage_entry, 44],
      ['$9836_1                        ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['$9853_X                        ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['$FA7B4_D                       ', clc$nominal_entry, clc$normal_usage_entry, 30],
      ['$FA7B5_A                       ', clc$nominal_entry, clc$normal_usage_entry, 31]]
      ],
    5, [[1, 0, clc$name_type], [1, 10]]
    ],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [1, 999999, 10]],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [3], [
    ['DOWN                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['OFF                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['ON                             ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ,
    'on'],
{ PARAMETER 7
    [[1, 0, clc$list_type], [104, 1, CLC$MAX_VALUE_SETS, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [2],
      ['PORT                           ', clc$required_field, 20], [[1, 0, clc$integer_type], [0, 3, 10]],
      ['MAINFRAME                      ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]]
      ]
    ],
{ PARAMETER 8
    [[1, 0, clc$list_type], [186, 1, CLC$MAX_VALUE_SETS, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [4],
      ['CHANNEL                        ', clc$required_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['EQUIPMENT                      ', clc$optional_field, 20], [[1, 0, clc$integer_type], [0, 7, 10]],
      ['MAINFRAME                      ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['IOU                            ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]]
      ]
    ],
{ PARAMETER 9
    [[1, 0, clc$list_type], [104, 1, CLC$MAX_VALUE_SETS, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [2],
      ['PERIPHERAL_ELEMENT             ', clc$required_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['PHYSICAL_ADDRESS               ', clc$optional_field, 20], [[1, 0, clc$integer_type], [0, 0ffff(16),
  10]]
      ]
    ],
{ PARAMETER 10
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 11
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 12
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 13
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element = 1,
      p$same_as = 2,
      p$element_identification = 3,
      p$iou_program_name = 4,
      p$serial_number = 5,
      p$state = 6,
      p$central_memory_connection = 7,
      p$iou_connection = 8,
      p$peripheral_connection = 9,
      p$verify_element_identification = 10,
      p$application_information = 11,
      p$site_information = 12,
      p$status = 13;

    VAR
      pvt: array [1 .. 13] of clt$parameter_value;

    CONST
      command_name = 'ADD_ELEMENT_DEFINITION';


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    cmp$crack_parameters (^pvt, command_name, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

  PROCEND cmp$add_element_def;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$change_connect_reference', EJECT ??

{ PURPOSE :
{      This procedure is the command processor for the PCU editor command
{      CHANGE_CONNECTION_REFERENCE.

  PROCEDURE [XDCL] cmp$change_connect_reference
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (cmm$edipc_chacr) change_connection_reference, chacr (
{   old_channel_name, ocn: record
{       channel: name
{       mainframe: name = $optional
{       iou: name = $optional
{     recend = $optional
{   new_channel_name, ncn: record
{       channel: name
{       mainframe: name = $optional
{       iou: name = $optional
{     recend = $optional
{   old_mainframe_name, omn: record
{       mainframe: name
{       iou: name = $optional
{     recend = $optional
{   new_mainframe_name, nmn: record
{       mainframe: name
{       iou: name = $optional
{     recend = $optional
{   old_peripheral_name, opn: name = $optional
{   new_peripheral_name, npn: name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 10, 13, 13, 49, 615],
    clc$command, 13, 7, 0, 0, 0, 0, 7, 'CMM$EDIPC_CHACR'], [
    ['NCN                            ',clc$abbreviation_entry, 2],
    ['NEW_CHANNEL_NAME               ',clc$nominal_entry, 2],
    ['NEW_MAINFRAME_NAME             ',clc$nominal_entry, 4],
    ['NEW_PERIPHERAL_NAME            ',clc$nominal_entry, 6],
    ['NMN                            ',clc$abbreviation_entry, 4],
    ['NPN                            ',clc$abbreviation_entry, 6],
    ['OCN                            ',clc$abbreviation_entry, 1],
    ['OLD_CHANNEL_NAME               ',clc$nominal_entry, 1],
    ['OLD_MAINFRAME_NAME             ',clc$nominal_entry, 3],
    ['OLD_PERIPHERAL_NAME            ',clc$nominal_entry, 5],
    ['OMN                            ',clc$abbreviation_entry, 3],
    ['OPN                            ',clc$abbreviation_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 7]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 130,
  clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 130,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 89, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 89, clc$optional_parameter,
  0, 0],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 6
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 7
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$record_type], [3],
    ['CHANNEL                        ', clc$required_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['MAINFRAME                      ', clc$optional_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['IOU                            ', clc$optional_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ]
    ],
{ PARAMETER 2
    [[1, 0, clc$record_type], [3],
    ['CHANNEL                        ', clc$required_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['MAINFRAME                      ', clc$optional_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['IOU                            ', clc$optional_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ]
    ],
{ PARAMETER 3
    [[1, 0, clc$record_type], [2],
    ['MAINFRAME                      ', clc$required_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['IOU                            ', clc$optional_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ]
    ],
{ PARAMETER 4
    [[1, 0, clc$record_type], [2],
    ['MAINFRAME                      ', clc$required_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['IOU                            ', clc$optional_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ]
    ],
{ PARAMETER 5
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 6
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$old_channel_name = 1,
      p$new_channel_name = 2,
      p$old_mainframe_name = 3,
      p$new_mainframe_name = 4,
      p$old_peripheral_name = 5,
      p$new_peripheral_name = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

    VAR
      new_channel_list: ^clt$data_value,
      new_mainframe_list: ^clt$data_value,
      new_peripheral: cmt$element_name,
      old_channel_list: ^clt$data_value,
      old_mainframe_list: ^clt$data_value,
      old_peripheral: cmt$element_name;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    IF pvt [p$old_channel_name].specified AND (NOT pvt [p$new_channel_name].specified) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_missing_parameters,
            'NEW_CHANNEL_NAME', status);
      RETURN;
    IFEND;
    IF (NOT pvt [p$old_channel_name].specified) AND pvt [p$new_channel_name].specified THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_missing_parameters,
            'OLD_CHANNEL_NAME', status);
      RETURN;
    IFEND;
    IF pvt [p$old_mainframe_name].specified AND (NOT pvt [p$new_mainframe_name].specified) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_missing_parameters,
            'NEW_MAINFRAME_NAME', status);
      RETURN;
    IFEND;
    IF (NOT pvt [p$old_mainframe_name].specified) AND pvt [p$new_mainframe_name].specified THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_missing_parameters,
            'OLD_MAINFRAME_NAME', status);
      RETURN;
    IFEND;
    IF pvt [p$old_peripheral_name].specified AND (NOT pvt [p$new_peripheral_name].specified) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_missing_parameters,
            'NEW_PERIPHERAL_NAME', status);
      RETURN;
    IFEND;
    IF (NOT pvt [p$old_peripheral_name].specified) AND pvt [p$new_peripheral_name].specified THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_missing_parameters,
            'OLD_PERIPHERAL_NAME', status);
      RETURN;
    IFEND;
    new_channel_list := NIL;
    new_mainframe_list := NIL;
    old_channel_list := NIL;
    old_mainframe_list := NIL;
    new_peripheral := osc$null_name;
    old_peripheral := osc$null_name;
    IF (pvt [p$old_channel_name].specified AND pvt [p$new_channel_name].specified) THEN
      old_channel_list := pvt [p$old_channel_name].value;
      new_channel_list := pvt [p$new_channel_name].value;
    IFEND;
    IF (pvt [p$old_mainframe_name].specified AND pvt [p$new_mainframe_name].specified) THEN
      old_mainframe_list := pvt [p$old_mainframe_name].value;
      new_mainframe_list := pvt [p$new_mainframe_name].value;
    IFEND;
    IF (pvt [p$old_peripheral_name].specified AND pvt [p$new_peripheral_name].specified) THEN
      old_peripheral := pvt [p$old_peripheral_name].value^.name_value;
      new_peripheral := pvt [p$new_peripheral_name].value^.name_value;
    IFEND;
    cmp$change_connection_ref_r3 (old_channel_list, new_channel_list, old_mainframe_list, new_mainframe_list,
          old_peripheral, new_peripheral, status);
  PROCEND cmp$change_connect_reference;


?? OLDTITLE ??
?? NEWTITLE := '   cmp$change_element_def', EJECT ??

{ PURPOSE :
{     This procedure is the command processor for the PCU editor command
{     CHANGE_ELEMENT_DEFINITION.

  PROCEDURE [XDCL] cmp$change_element_def
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{     PROCEDURE (cmm$edipc_chaed) change_element_definition, chaed (
{       element, e: name = $required
{       same_as, sa: name = $optional
{       element_identification, ei: any of
{          key
{      $834_12, $836_xxx, $844_4x, $885_1x, $887_1, $895_2, $9836_1, $9853_x,
{      $5832_1, $5832_2, $5833_1, $5833_1p, $5833_2, $5833_3p, $5833_4,
{      $5838_1, $5838_1p, $5838_2, $5838_3p, $5838_4,
{      $47444_1, $47444_1p, $47444_2, $47444_3p, $47444_4,
{      $7155_1, $7155_1x, $7165_2x, $10395_11, $fa7b4_d, $fa7b5_a, $5831_x,
{      $5680_11, $5682_1x, $5698_1x, $639_1, $679_x, $698_1x, $698_2x,
{      $698_3x, $7021_3x, $7221_1, $7221_11, $9639_1, $65354_1x, $4000_xx,
{      $2620_xxx, $2621_xxx, $2629_x, $380_170, $5380_100, $7040_200
{          keyend
{          name 1..10
{        anyend = $optional
{       iou_program_name, ioupn, ipn: name = $optional
{       serial_number, sn: integer 1..999999 = $optional
{       state, s: key
{           down, off, on
{         keyend = $optional
{       central_memory_connection, central_memory_connections, cmc: list 1..CLC$MAX_VALUE_SETS of record
{           port: integer 0..3
{           mainframe: name = $optional
{         recend = $optional
{       iou_connection, iou_connections, ic: list 1..CLC$MAX_VALUE_SETS of record
{           channel: name
{           equipment: integer 0..7 = $optional
{           mainframe: name = $optional
{           iou: name = $optional
{         recend = $optional
{       peripheral_connection, peripheral_connections, pc: list 1..CLC$MAX_VALUE_SETS of record
{           peripheral_element: name
{           physical_address: integer 0..0ffff(16) = $optional
{         recend = $optional
{       verify_element_identification, vei: boolean = $optional
{       application_information, ai: string = $optional
{       site_information, si: string = $optional
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 29] of clt$pdt_parameter_name,
      parameters: array [1 .. 13] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: 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 .. 52] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type13: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [94, 3, 16, 11, 7, 38, 752],
    clc$command, 29, 13, 1, 0, 0, 0, 13, 'CMM$EDIPC_CHAED'], [
    ['AI                             ',clc$abbreviation_entry, 11],
    ['APPLICATION_INFORMATION        ',clc$nominal_entry, 11],
    ['CENTRAL_MEMORY_CONNECTION      ',clc$nominal_entry, 7],
    ['CENTRAL_MEMORY_CONNECTIONS     ',clc$alias_entry, 7],
    ['CMC                            ',clc$abbreviation_entry, 7],
    ['E                              ',clc$abbreviation_entry, 1],
    ['EI                             ',clc$abbreviation_entry, 3],
    ['ELEMENT                        ',clc$nominal_entry, 1],
    ['ELEMENT_IDENTIFICATION         ',clc$nominal_entry, 3],
    ['IC                             ',clc$abbreviation_entry, 8],
    ['IOUPN                          ',clc$alias_entry, 4],
    ['IOU_CONNECTION                 ',clc$nominal_entry, 8],
    ['IOU_CONNECTIONS                ',clc$alias_entry, 8],
    ['IOU_PROGRAM_NAME               ',clc$nominal_entry, 4],
    ['IPN                            ',clc$abbreviation_entry, 4],
    ['PC                             ',clc$abbreviation_entry, 9],
    ['PERIPHERAL_CONNECTION          ',clc$nominal_entry, 9],
    ['PERIPHERAL_CONNECTIONS         ',clc$alias_entry, 9],
    ['S                              ',clc$abbreviation_entry, 6],
    ['SA                             ',clc$abbreviation_entry, 2],
    ['SAME_AS                        ',clc$nominal_entry, 2],
    ['SERIAL_NUMBER                  ',clc$nominal_entry, 5],
    ['SI                             ',clc$abbreviation_entry, 12],
    ['SITE_INFORMATION               ',clc$nominal_entry, 12],
    ['SN                             ',clc$abbreviation_entry, 5],
    ['STATE                          ',clc$nominal_entry, 6],
    ['STATUS                         ',clc$nominal_entry, 13],
    ['VEI                            ',clc$abbreviation_entry, 10],
    ['VERIFY_ELEMENT_IDENTIFICATION  ',clc$nominal_entry, 10]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1956,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 120,
  clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 202,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 120,
  clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 11
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 12
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 13
    [27, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    1931, [[1, 0, clc$keyword_type], [52], [
      ['$10395_11                      ', clc$nominal_entry, clc$normal_usage_entry, 29],
      ['$2620_XXX                      ', clc$nominal_entry, clc$normal_usage_entry, 47],
      ['$2621_XXX                      ', clc$nominal_entry, clc$normal_usage_entry, 48],
      ['$2629_X                        ', clc$nominal_entry, clc$normal_usage_entry, 49],
      ['$380_170                       ', clc$nominal_entry, clc$normal_usage_entry, 50],
      ['$4000_XX                       ', clc$nominal_entry, clc$normal_usage_entry, 46],
      ['$47444_1                       ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['$47444_1P                      ', clc$nominal_entry, clc$normal_usage_entry, 22],
      ['$47444_2                       ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['$47444_3P                      ', clc$nominal_entry, clc$normal_usage_entry, 24],
      ['$47444_4                       ', clc$nominal_entry, clc$normal_usage_entry, 25],
      ['$5380_100                      ', clc$nominal_entry, clc$normal_usage_entry, 51],
      ['$5680_11                       ', clc$nominal_entry, clc$normal_usage_entry, 33],
      ['$5682_1X                       ', clc$nominal_entry, clc$normal_usage_entry, 34],
      ['$5698_1X                       ', clc$nominal_entry, clc$normal_usage_entry, 35],
      ['$5831_X                        ', clc$nominal_entry, clc$normal_usage_entry, 32],
      ['$5832_1                        ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['$5832_2                        ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['$5833_1                        ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['$5833_1P                       ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['$5833_2                        ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['$5833_3P                       ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['$5833_4                        ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['$5838_1                        ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['$5838_1P                       ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['$5838_2                        ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['$5838_3P                       ', clc$nominal_entry, clc$normal_usage_entry, 19],
      ['$5838_4                        ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['$639_1                         ', clc$nominal_entry, clc$normal_usage_entry, 36],
      ['$65354_1X                      ', clc$nominal_entry, clc$normal_usage_entry, 45],
      ['$679_X                         ', clc$nominal_entry, clc$normal_usage_entry, 37],
      ['$698_1X                        ', clc$nominal_entry, clc$normal_usage_entry, 38],
      ['$698_2X                        ', clc$nominal_entry, clc$normal_usage_entry, 39],
      ['$698_3X                        ', clc$nominal_entry, clc$normal_usage_entry, 40],
      ['$7021_3X                       ', clc$nominal_entry, clc$normal_usage_entry, 41],
      ['$7040_200                      ', clc$nominal_entry, clc$normal_usage_entry, 52],
      ['$7155_1                        ', clc$nominal_entry, clc$normal_usage_entry, 26],
      ['$7155_1X                       ', clc$nominal_entry, clc$normal_usage_entry, 27],
      ['$7165_2X                       ', clc$nominal_entry, clc$normal_usage_entry, 28],
      ['$7221_1                        ', clc$nominal_entry, clc$normal_usage_entry, 42],
      ['$7221_11                       ', clc$nominal_entry, clc$normal_usage_entry, 43],
      ['$834_12                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['$836_XXX                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['$844_4X                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['$885_1X                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['$887_1                         ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['$895_2                         ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['$9639_1                        ', clc$nominal_entry, clc$normal_usage_entry, 44],
      ['$9836_1                        ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['$9853_X                        ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['$FA7B4_D                       ', clc$nominal_entry, clc$normal_usage_entry, 30],
      ['$FA7B5_A                       ', clc$nominal_entry, clc$normal_usage_entry, 31]]
      ],
    5, [[1, 0, clc$name_type], [1, 10]]
    ],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [1, 999999, 10]],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [3], [
    ['DOWN                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['OFF                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['ON                             ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 7
    [[1, 0, clc$list_type], [104, 1, CLC$MAX_VALUE_SETS, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [2],
      ['PORT                           ', clc$required_field, 20], [[1, 0, clc$integer_type], [0, 3, 10]],
      ['MAINFRAME                      ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]]
      ]
    ],
{ PARAMETER 8
    [[1, 0, clc$list_type], [186, 1, CLC$MAX_VALUE_SETS, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [4],
      ['CHANNEL                        ', clc$required_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['EQUIPMENT                      ', clc$optional_field, 20], [[1, 0, clc$integer_type], [0, 7, 10]],
      ['MAINFRAME                      ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['IOU                            ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]]
      ]
    ],
{ PARAMETER 9
    [[1, 0, clc$list_type], [104, 1, CLC$MAX_VALUE_SETS, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [2],
      ['PERIPHERAL_ELEMENT             ', clc$required_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['PHYSICAL_ADDRESS               ', clc$optional_field, 20], [[1, 0, clc$integer_type], [0, 0ffff(16),
  10]]
      ]
    ],
{ PARAMETER 10
    [[1, 0, clc$boolean_type]],
{ PARAMETER 11
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 12
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 13
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element = 1,
      p$same_as = 2,
      p$element_identification = 3,
      p$iou_program_name = 4,
      p$serial_number = 5,
      p$state = 6,
      p$central_memory_connection = 7,
      p$iou_connection = 8,
      p$peripheral_connection = 9,
      p$verify_element_identification = 10,
      p$application_information = 11,
      p$site_information = 12,
      p$status = 13;

    VAR
      pvt: array [1 .. 13] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    cmp$change_definition (^pvt, status);

  PROCEND cmp$change_element_def;


?? OLDTITLE ??
?? NEWTITLE := '   cmp$change_element_name', EJECT ??

{ PURPOSE :
{    This procedure is the command processor for the PCU editor command
{    CHANGE_ELEMENT_NAME.

  PROCEDURE [XDCL] cmp$change_element_name
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (cmm$edipc_chaen) change_element_name, chaen (
{   element, e: name = $required
{   new_element_name, nen: name = $required
{   change_references, change_reference, cr: boolean = true
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 10, 13, 14, 49, 27],
    clc$command, 8, 4, 2, 0, 0, 0, 4, 'CMM$EDIPC_CHAEN'], [
    ['CHANGE_REFERENCE               ',clc$alias_entry, 3],
    ['CHANGE_REFERENCES              ',clc$nominal_entry, 3],
    ['CR                             ',clc$abbreviation_entry, 3],
    ['E                              ',clc$abbreviation_entry, 1],
    ['ELEMENT                        ',clc$nominal_entry, 1],
    ['NEN                            ',clc$abbreviation_entry, 2],
    ['NEW_ELEMENT_NAME               ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element = 1,
      p$new_element_name = 2,
      p$change_references = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;


    VAR
      change_references: boolean,
      element_name: cmt$element_name,
      new_element_name: cmt$element_name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    element_name := pvt [p$element].value^.name_value;
    new_element_name := pvt [p$new_element_name].value^.name_value;
    change_references := pvt [p$change_references].value^.boolean_value.value;
    cmp$change_definition_name (element_name, new_element_name, change_references, status);

  PROCEND cmp$change_element_name;



?? OLDTITLE ??
?? NEWTITLE := '   cmp$delete_element_def', EJECT ??

{ PURPOSE :
{    This procedure is the command processor for the PCU editor command
{    DELETE_ELEMENT_DEFINITION.

  PROCEDURE [XDCL] cmp$delete_element_def
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (cmm$edipc_deled) delete_element_definition, deled (
{   element, elements, e: any of
{       list of name
{       key
{         all
{       keyend
{     anyend = $required
{   retain, r: list of name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 10, 13, 15, 15, 276],
    clc$command, 6, 3, 1, 0, 0, 0, 3, 'CMM$EDIPC_DELED'], [
    ['E                              ',clc$abbreviation_entry, 1],
    ['ELEMENT                        ',clc$nominal_entry, 1],
    ['ELEMENTS                       ',clc$alias_entry, 1],
    ['R                              ',clc$abbreviation_entry, 2],
    ['RETAIN                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element = 1,
      p$retain = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      continue: boolean,
      current_list_entry: ^clt$data_value,
      delete_element_list_p: ^array [ * ] of ost$name,
      exclude_list_p: ^array [ * ] of ost$name,
      interactive: boolean,
      list_index: integer,
      number_of_entries: integer;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    delete_element_list_p := NIL;
    exclude_list_p := NIL;
    number_of_entries := clp$count_list_elements (pvt [p$element].value);
    IF number_of_entries > 0 THEN
      PUSH delete_element_list_p: [1 .. number_of_entries];
      current_list_entry := pvt [p$element].value;
      FOR list_index := 1 TO clp$count_list_elements (pvt [p$element].value) DO
        delete_element_list_p^ [list_index] := current_list_entry^.element_value^.name_value;
        current_list_entry := current_list_entry^.link;
      FOREND;
    IFEND;
    IF pvt [p$retain].specified THEN
      number_of_entries := clp$count_list_elements (pvt [p$retain].value);
      IF number_of_entries > 0 THEN
        PUSH exclude_list_p: [1 .. number_of_entries];
        current_list_entry := pvt [p$retain].value;
        FOR list_index := 1 TO number_of_entries DO
          exclude_list_p^ [list_index] := current_list_entry^.element_value^.name_value;
          current_list_entry := current_list_entry^.link;
        FOREND;
      IFEND;
    IFEND;
    IF delete_element_list_p <> NIL THEN

    /delete_element_loop/
      FOR list_index := LOWERBOUND (delete_element_list_p^) TO UPPERBOUND (delete_element_list_p^) DO
        IF delete_element_list_p^ [list_index] <> 'ALL' THEN

{ Error if specified RETAIN.

          IF pvt [p$retain].specified THEN
            osp$set_status_condition ( cme$pcu_invalid_use_of_retain,
                  status);
            RETURN; {----->
          IFEND;
          cmp$delete_definition (delete_element_list_p^ [list_index], status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        ELSE
          clp$get_command_origin (interactive, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          IF interactive THEN
            cmp$prompt_for_answer (' Do you really want to delete all elements?', continue);
            IF NOT continue THEN
              RETURN; {----->
            IFEND;
          IFEND;
          cmp$delete_all_elements (exclude_list_p, status);
          EXIT /delete_element_loop/; {----->
        IFEND;
      FOREND /delete_element_loop/;
    IFEND;
  PROCEND cmp$delete_element_def;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$display_mf_connections', EJECT ??

{ PURPOSE :
{     This procedure is the command processor for the PCU editor command
{     DISPLAY_CONNECTED_ELEMENTS

  PROCEDURE [XDCL] cmp$display_mf_connections
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (cmm$edipc_disce) display_connected_elements, display_connected_element, disce (
{   element, e: any of
{       key
{         channel, iou, mainframe
{       keyend
{       name
{     anyend = mainframe
{   channel, c: name = $optional
{   iou: name = IOU0
{   mainframe, m: name = $name($mainframe(identifier))
{   type, t: key
{       (logically_accessible, la)
{       (physically_accessible, pa)
{     keyend = logically_accessible
{   display_options, display_option, do: list of key
{       all
{       (element_identification, ei)
{       (iou_program_name, ipn)
{       (name, n)
{       (serial_number, sn)
{       (state, s)
{       (verify_element_identification, vei)
{     keyend = all
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 15] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        default_value: string (9),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (29),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (20),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 13] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type7: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 10, 13, 15, 43, 908],
    clc$command, 15, 8, 0, 0, 0, 0, 8, 'CMM$EDIPC_DISCE'], [
    ['C                              ',clc$abbreviation_entry, 2],
    ['CHANNEL                        ',clc$nominal_entry, 2],
    ['DISPLAY_OPTION                 ',clc$alias_entry, 6],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 6],
    ['DO                             ',clc$abbreviation_entry, 6],
    ['E                              ',clc$abbreviation_entry, 1],
    ['ELEMENT                        ',clc$nominal_entry, 1],
    ['IOU                            ',clc$nominal_entry, 3],
    ['M                              ',clc$abbreviation_entry, 4],
    ['MAINFRAME                      ',clc$nominal_entry, 4],
    ['O                              ',clc$abbreviation_entry, 7],
    ['OUTPUT                         ',clc$nominal_entry, 7],
    ['STATUS                         ',clc$nominal_entry, 8],
    ['T                              ',clc$abbreviation_entry, 5],
    ['TYPE                           ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 143,
  clc$optional_default_parameter, 0, 9],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 29],
{ PARAMETER 5
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 20],
{ PARAMETER 6
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 504,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 7
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 8
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['CHANNEL                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['IOU                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['MAINFRAME                      ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'mainframe'],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'IOU0'],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    '$name($mainframe(identifier))'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [4], [
    ['LA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['LOGICALLY_ACCESSIBLE           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['PA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['PHYSICALLY_ACCESSIBLE          ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'logically_accessible'],
{ PARAMETER 6
    [[1, 0, clc$list_type], [488, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [13], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['EI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['ELEMENT_IDENTIFICATION         ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['IOU_PROGRAM_NAME               ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['IPN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['NAME                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['SERIAL_NUMBER                  ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['SN                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['STATE                          ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['VEI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['VERIFY_ELEMENT_IDENTIFICATION  ', clc$nominal_entry, clc$normal_usage_entry, 7]]
      ]
    ,
    'all'],
{ PARAMETER 7
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element = 1,
      p$channel = 2,
      p$iou = 3,
      p$mainframe = 4,
      p$type = 5,
      p$display_options = 6,
      p$output = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

*copyc clv$display_variables
*copyc cmc$minimum_page_size

    VAR
      access_type: ost$name,
      channel: cmt$element_name,
      current_list_entry: ^clt$data_value,
      element_option_value: ost$name,
      element_type: cmt$element_type,
      display_control: clt$display_control,
      display_options_array: ^array [ * ] of ost$name,
      file: clt$file,
      header: string (50),
      i: integer,
      ignore_status: ost$status,
      iou: cmt$element_name,
      mainframe: cmt$element_name,
      number_of_entries: integer,
      output_open: boolean;


?? NEWTITLE := '     abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF output_open THEN
        clp$close_display (display_control, ignore_status);
        output_open := FALSE;
      IFEND;

    PROCEND abort_handler;
*copy clp$new_page_procedure

?? NEWTITLE := '     print_subtitle', EJECT ??

    PROCEDURE print_subtitle
      (    header: string (50);
       VAR status: ost$status);


      clp$put_partial_display (display_control, header, clc$trim, amc$continue, status);

      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

    PROCEND print_subtitle;

?? NEWTITLE := '     put_subtitle', EJECT ??

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

      print_subtitle (header, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

    PROCEND put_subtitle;

?? OLDTITLE, OLDTITLE, OLDTITLE, EJECT ??

  /main_program/
    BEGIN
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      output_open := FALSE;
      osp$establish_block_exit_hndlr (^abort_handler);
      clp$convert_string_to_file (pvt [p$output].value^.file_value^, file, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      header := '  ';
      clp$open_display (file, ^clp$new_page_procedure, display_control, status);
      IF NOT status.normal THEN
        EXIT /main_program/; {----->
      IFEND;
      output_open := TRUE;

      IF display_control.page_width < cmc$minimum_page_size THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_illegal_output_file,
              file.local_file_name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, cmc$minimum_page_size, 10, FALSE, status);
        EXIT /main_program/; {----->
      IFEND;

      clv$titles_built := FALSE;
      clv$command_name := 'display_connected_elements';
      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        EXIT /main_program/; {----->
      IFEND;
      clp$put_partial_display (display_control,
            'Element                          Product   State Serial Driver  VEI   ', clc$trim, amc$terminate,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/; {----->
      IFEND;
      clp$put_partial_display (display_control,
            'Name                             Id              Number Name          ', clc$trim, amc$terminate,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/; {----->
      IFEND;

      clp$put_partial_display (display_control,
            '===================================================================== ', clc$trim, amc$terminate,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/; {----->
      IFEND;
      number_of_entries := clp$count_list_elements (pvt [p$display_options].value);
      IF number_of_entries > 0 THEN
        PUSH display_options_array: [1 .. number_of_entries];
        current_list_entry := pvt [p$display_options].value;
        FOR i := 1 TO clp$count_list_elements (pvt [p$display_options].value) DO
          display_options_array^ [i] := current_list_entry^.element_value^.name_value;
          current_list_entry := current_list_entry^.link;
        FOREND;
      IFEND;
      element_option_value := pvt [p$element].value^.name_value;
      IF pvt [p$channel].specified THEN
        channel := pvt [p$channel].value^.name_value;
      ELSE
        IF (element_option_value = 'CHANNEL') THEN
          osp$set_status_abnormal (cmc$configuration_management_id, 0,
                'Need channel name if element is channel.', status);
          EXIT /main_program/; {----->
        IFEND;
      IFEND;
      iou := pvt [p$iou].value^.name_value;
      mainframe := pvt [p$mainframe].value^.name_value;
      access_type := pvt [p$type].value^.name_value;
      cmp$display_mf_elements (element_option_value, display_options_array, channel, iou, mainframe,
            access_type, display_control, status);
      IF NOT status.normal THEN
        EXIT /main_program/; {----->
      IFEND;
    END /main_program/;

    IF output_open THEN
      clp$close_display (display_control, ignore_status);
      output_open := FALSE;
    IFEND;

    osp$disestablish_cond_handler;
  PROCEND cmp$display_mf_connections;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$display_mf_elements', EJECT ??

{ PURPOSE:
{    This procedure displays all elements connected to a particular
{    mainframe, iou or channel in the physical configuration file
{    processed by the PCU editor.

  PROCEDURE cmp$display_mf_elements
    (    element_option_value: cmt$element_name;
         display_option_array: ^array [ * ] of ost$name;
         channel: cmt$element_name;
         iou: cmt$element_name;
         mainframe: cmt$element_name;
         access_type: ost$name;
     VAR display_control: clt$display_control;
     VAR status: ost$status);


    VAR
      current_p: ^cmt$pcu_command_descriptor,
      found_element: cmt$pcu_command_descriptor,
      product_id: cmt$product_identification,
      byte_address: amt$file_byte_address,
      i,
      j: integer,
      element_type,
      current_element_type: cmt$element_type,
      line: string (80),
      display,
      first_time,
      display_all,
      found: boolean;

    status.normal := TRUE;
    found := FALSE;
    line := '   ';
    first_time := TRUE;
    display := FALSE;

  /main_program/
    BEGIN


      IF cmv$command_descriptor_p = NIL THEN
        osp$set_status_condition ( cme$pcu_empty_file,  status);
        EXIT /main_program/; {----->
      IFEND;

      IF (access_type = 'PHYSICALLY_ACCESSIBLE') OR (access_type = 'PA') THEN
        display_all := TRUE;
      ELSE
        display_all := FALSE;
      IFEND;
      current_p := cmv$command_descriptor_p;
      WHILE current_p <> NIL DO
        found := FALSE;
        CASE current_p^.connection OF
        = cmc$central_memory_connection = { Entry with IOU and/or Central Memory connections }
          IF current_p^.channel_list <> NIL THEN
            i := 1;
            WHILE (NOT found) AND (i <= UPPERBOUND (current_p^.channel_list^)) DO
              IF (element_option_value = 'CHANNEL') OR (element_option_value = 'C') THEN
                found := ((current_p^.channel_list^ [i].mainframe = mainframe) AND
                      (current_p^.channel_list^ [i].iou = iou) AND
                      (current_p^.channel_list^ [i].channel = channel));
              ELSEIF (element_option_value = 'IOU') THEN
                found := ((current_p^.channel_list^ [i].mainframe = mainframe) AND
                      (current_p^.channel_list^ [i].iou = iou));
              ELSEIF (element_option_value = 'MAINFRAME') OR (element_option_value = 'M') THEN
                found := ((current_p^.channel_list^ [i].mainframe = mainframe));
              ELSE
                found := (current_p^.element_name = element_option_value);

              IFEND;

              IF NOT display_all THEN
                IF found THEN
                  found := (current_p^.state = 'ON') OR (current_p^.state = 'DOWN') OR
                        (current_p^.state = osc$null_name);
                IFEND;
              IFEND;
              i := i + 1;
            WHILEND;
          IFEND;

        = cmc$iou_connection =
          IF current_p^.iou_list <> NIL THEN
            i := 1;
            WHILE (NOT found) AND (i <= UPPERBOUND (current_p^.iou_list^)) DO
              IF (element_option_value = 'CHANNEL') OR (element_option_value = 'C') THEN
                found := ((current_p^.iou_list^ [i].mainframe = mainframe) AND
                      (current_p^.iou_list^ [i].iou = iou) AND (current_p^.iou_list^ [i].channel = channel));
              ELSEIF (element_option_value = 'IOU') THEN
                found := ((current_p^.iou_list^ [i].mainframe = mainframe) AND
                      (current_p^.iou_list^ [i].iou = iou));
              ELSEIF (element_option_value = 'MAINFRAME') OR (element_option_value = 'M') THEN
                found := ((current_p^.iou_list^ [i].mainframe = mainframe));
              ELSE
                found := (current_p^.element_name = element_option_value);

              IFEND;

              IF NOT display_all THEN
                IF found THEN
                  found := (current_p^.state = 'ON') OR (current_p^.state = 'DOWN') OR
                        (current_p^.state = osc$null_name);
                IFEND;
              IFEND;
              i := i + 1;
            WHILEND;
          IFEND;
        = cmc$peripheral_connection =
          IF current_p^.pc_list <> NIL THEN
            i := 1;
            found := FALSE;

{ Element option value is not a mainframe name

            IF (element_option_value <> 'CHANNEL') AND (element_option_value <> 'C') AND
                  (element_option_value <> 'IOU') AND (element_option_value <> 'MAINFRAME') AND
                  (element_option_value <> 'M') THEN

              WHILE NOT found AND (i <= UPPERBOUND (current_p^.pc_list^)) DO
                found := (current_p^.pc_list^ [i].peripheral = element_option_value);
                IF NOT found THEN

{ element name sought is not in the connection

                  IF (current_p^.element_name = element_option_value) THEN
                    cmp$search_edited_file (current_p^.pc_list^ [i].peripheral, 0, product_id, found,
                          found_element);
                    IF NOT display_all THEN
                      IF found THEN
                        found := found_element.state <> 'OFF';
                      IFEND;
                    IFEND;
                    IF found THEN
                      display := TRUE;
                      cmp$display_name (found_element, display_option_array, display_control, status);
                      IF NOT status.normal THEN
                        EXIT /main_program/; {----->
                      IFEND;
                      found := FALSE; { So we don't display the name }
                    IFEND;
                  IFEND;
                IFEND;
                i := i + 1;

                IF NOT display_all THEN
                  IF found THEN
                    found := (current_p^.state = 'ON') OR (current_p^.state = 'DOWN') OR
                          (current_p^.state = osc$null_name);
                  IFEND;
                IFEND;
              WHILEND;
            ELSE
              i := 1;
              WHILE (NOT found) AND (i <= UPPERBOUND (current_p^.pc_list^)) DO
                cmp$search_edited_file (current_p^.pc_list^ [i].peripheral, 0, product_id, found,
                      found_element);
                CASE found_element.connection OF
                = cmc$iou_connection =
                  IF found_element.iou_list <> NIL THEN
                    j := 1;
                    found := FALSE;
                    WHILE (NOT found) AND (j <= UPPERBOUND (found_element.iou_list^)) DO
                      CASE found_element.connection OF
                      = cmc$iou_connection =
                        IF (element_option_value = 'CHANNEL') OR (element_option_value = 'C') THEN
                          found := ((found_element.iou_list^ [j].mainframe = mainframe) AND
                                (found_element.iou_list^ [j].iou = iou) AND
                                (found_element.iou_list^ [j].channel = channel));
                        ELSEIF (element_option_value = 'IOU') THEN
                          found := ((found_element.iou_list^ [j].mainframe = mainframe) AND
                                (found_element.iou_list^ [j].iou = iou));
                        ELSEIF (element_option_value = 'MAINFRAME') OR (element_option_value = 'M') THEN
                          found := ((found_element.iou_list^ [j].mainframe = mainframe));
                        ELSE
                          found := (found_element.element_name = element_option_value);

                        IFEND;
                      ELSE
                        ;
                      CASEND;
                      IF NOT display_all THEN
                        IF found THEN
                          found := (found_element.state = 'ON') OR (found_element.state = 'DOWN') OR
                                (found_element.state = osc$null_name);
                        IFEND;
                      IFEND;
                      j := j + 1;
                    WHILEND;
                  IFEND;
                ELSE
                  ;
                CASEND;

                i := i + 1;
              WHILEND;

            IFEND;
          IFEND;
        ELSE
          ;
        CASEND;
        IF found THEN
          display := TRUE;
          cmp$display_name (current_p^, display_option_array, display_control, status);
          IF NOT status.normal THEN
            EXIT /main_program/; {----->
          IFEND;
        IFEND;

        current_p := current_p^.next_descriptor;

      WHILEND;

      IF NOT display THEN
        line (1, 15) := 'Connections to';
        IF (element_option_value = 'C') OR (element_option_value = 'CHANNEL') THEN
          line (17, 5) := iou;
          line (24, * ) := channel;
        ELSEIF (element_option_value = 'IOU') THEN
          line (17, * ) := iou;
        ELSEIF (element_option_value = 'M') OR (element_option_value = 'MAINFRAME') THEN
          line (17, * ) := mainframe;
        ELSE
          line (17, * ) := element_option_value;
        IFEND;
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_element_not_found, line, status);
      IFEND;

    END /main_program/;

  PROCEND cmp$display_mf_elements;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$display_name', EJECT ??

{ PURPOSE:
{    This procedure display the command descriptor in the
{    edited physical configuration file.

  PROCEDURE cmp$display_name
    (    current_p: cmt$pcu_command_descriptor;
         display_option_array: ^array [ * ] of ost$name;
     VAR display_control: clt$display_control;
     VAR status: ost$status);


    VAR
      connection_line,
      line: string (80),
      str: ost$string,
      pos,
      j,
      i: integer,
      display_all: boolean,
      byte_address: amt$file_byte_address;

    status.normal := TRUE;
    display_all := FALSE;
    line := '  ';
    pos := 2;

  /search_option/
    FOR i := 1 TO UPPERBOUND (display_option_array^) DO
      IF (display_option_array^ [i] = 'ALL') THEN
        display_all := TRUE;
        EXIT /search_option/; {----->
      IFEND;
    FOREND /search_option/;
    IF NOT display_all THEN
      FOR i := 1 TO UPPERBOUND (display_option_array^) DO
        IF (display_option_array^ [i] = 'NAME') OR (display_option_array^ [i] = 'N') THEN

          line (pos, 31) := current_p.element_name;
          pos := pos + 32;

        ELSEIF (display_option_array^ [i] = 'ELEMENT_IDENTIFICATION') OR (display_option_array^ [i] =
              'EI') THEN
          line (pos, 10) := current_p.pid;
          pos := pos + 11;
        ELSEIF (display_option_array^ [i] = 'STATE') OR (display_option_array^ [i] = 'S') THEN
          line (pos, 4) := current_p.state;
          pos := pos + 5;
        ELSEIF (display_option_array^ [i] = 'SERIAL_NUMBER') OR (display_option_array^ [i] = 'SN') THEN
          clp$convert_integer_to_string (current_p.sn, 10, FALSE, str, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          line (pos, 6) := str.value;
          pos := pos + 7;
        ELSEIF (display_option_array^ [i] = 'IOU_PROGRAM_NAME') OR (display_option_array^ [i] = 'IPN') THEN
          line (pos, 7) := current_p.ioupn;
          pos := pos + 8;
        ELSEIF (display_option_array^ [i] = 'VERIFY_ELEMENT_IDENTIFICATION') OR (display_option_array^ [i] =
              'VEI') THEN
          IF current_p.verify THEN
            line (pos, 5) := 'TRUE ';
          ELSE
            line (pos, 5) := 'FALSE';
          IFEND;
          pos := pos + 6;
        IFEND;


      FOREND;

      clp$put_partial_display (display_control, line, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    ELSE

      line (pos, 31) := current_p.element_name;
      pos := pos + 32;
      line (pos, 10) := current_p.pid;
      pos := pos + 11;
      line (pos, 4) := current_p.state;
      pos := pos + 5;
      clp$convert_integer_to_string (current_p.sn, 10, FALSE, str, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      line (pos, 6) := str.value;
      pos := pos + 7;
      line (pos, 7) := current_p.ioupn;
      pos := pos + 8;
      IF current_p.verify THEN
        line (pos, 5) := 'TRUE ';
      ELSE
        line (pos, 5) := 'FALSE';
        pos := pos + 6;
      IFEND;

      clp$put_partial_display (display_control, line, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    IFEND;

  PROCEND cmp$display_name;


?? OLDTITLE ??
?? NEWTITLE := '   cmp$display_element_def', EJECT ??

{ PURPOSE :
{    This procedure is the command processor for the PCU editor command
{    DISPLAY_ELEMENT_DEFINITION.

  PROCEDURE [XDCL] cmp$display_element_def
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (cmm$edipc_dised) display_element_definition, dised (
{   elements, element, e: list of any of
{       key
{         all, $channel_adapter, $communications_element, $controller, $external_processor, $storage_device
{       keyend
{       name
{     anyend = all
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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 .. 6] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 10, 13, 16, 11, 92],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'CMM$EDIPC_DISED'], [
    ['E                              ',clc$abbreviation_entry, 1],
    ['ELEMENT                        ',clc$alias_entry, 1],
    ['ELEMENTS                       ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 270,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [254, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      229, [[1, 0, clc$keyword_type], [6], [
        ['$CHANNEL_ADAPTER               ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['$COMMUNICATIONS_ELEMENT        ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['$CONTROLLER                    ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['$EXTERNAL_PROCESSOR            ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['$STORAGE_DEVICE                ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$elements = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      cmv$key_display_options: [STATIC, READ, oss$job_paged_literal] array [cmt$lcu_display_option_key] of
            ost$name := [cmc$lcu_all_inclusive_keyword, cmc$lcu_channel_keyword, cmc$lcu_controller_keyword,
            cmc$lcu_storage_device_keyword, cmc$lcu_channel_adapter_kw, cmc$lcu_external_processor_kw,
            cmc$lcu_communications_keyword];

    VAR
      current_list_entry: ^clt$data_value,
      display_option_key: cmt$lcu_display_option_key,
      file_id: amt$file_identifier,
      file: clt$file,
      list_index: integer,
      local_status: ost$status,
      name: ost$name,
      number_of_entries: integer;

  /main_program/
    BEGIN
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      clp$convert_string_to_file (pvt [p$output].value^.file_value^, file, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      fsp$open_file (file.local_file_name, amc$record, NIL, NIL, NIL, NIL, NIL, file_id, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      current_list_entry := pvt [p$elements].value;
      number_of_entries := clp$count_list_elements (pvt [p$element].value);
      IF number_of_entries > 0 THEN

      /process_element_list/
        FOR list_index := 1 TO number_of_entries DO
          name := current_list_entry^.element_value^.name_value;
          FOR display_option_key := LOWERVALUE (display_option_key) TO UPPERVALUE (display_option_key) DO
            IF name = cmv$key_display_options [display_option_key] THEN
              cmp$display_elements_def (display_option_key, FALSE, name, file_id, status);
              IF NOT status.normal THEN
                EXIT /main_program/; {----->
              IFEND;
              current_list_entry := current_list_entry^.link;
              CYCLE /process_element_list/; {----->
            IFEND;
          FOREND;
          cmp$display_elements_def (display_option_key, TRUE, name, file_id, status);
          IF NOT status.normal THEN
            EXIT /main_program/; {----->
          IFEND;
          current_list_entry := current_list_entry^.link;
        FOREND /process_element_list/;
      IFEND;
    END /main_program/;
    fsp$close_file (file_id, local_status);

  PROCEND cmp$display_element_def;



?? OLDTITLE ??
?? NEWTITLE := '   cmp$quit_edit', EJECT ??

{ PURPOSE :
{    This procedure is the command processor for the PCU editor command
{    QUIT.

  PROCEDURE [XDCL] cmp$quit_edit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);



{ PROCEDURE (cmm$edipc_quit) quit, qui (
{   write_physical_configuration, wpc: boolean = true
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 10, 13, 16, 41, 910],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'CMM$EDIPC_QUIT'], [
    ['STATUS                         ',clc$nominal_entry, 2],
    ['WPC                            ',clc$abbreviation_entry, 1],
    ['WRITE_PHYSICAL_CONFIGURATION   ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$write_physical_configuration = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      update_pc: boolean;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    update_pc := pvt [p$write_physical_configuration].value^.boolean_value.value;
    IF update_pc THEN
      cmp$update_output_file (status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    ELSE
      cmp$clean_up_list;
    IFEND;

    cmp$close_in_out_files;

    clp$end_scan_command_file ('PHYSICAL_CONFIGURATION_EDITOR  ', status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    cmp$set_exec_in_editor (FALSE);
    cmp$set_in_editor (FALSE);

  PROCEND cmp$quit_edit;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$replace_element_def', EJECT ??

{ PURPOSE :
{    This procedure is the command processor for the PCU editor command
{    REPLACE_ELEMENT_DEFINITION.

  PROCEDURE [XDCL] cmp$replace_element_def
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{     PROCEDURE (cmm$edipc_reped) replace_element_definition, reped (
{       element, e: name = $required
{       same_as, sa: name = $optional
{       element_identification, ei: any of
{          key
{      $834_12, $836_xxx, $844_4x, $885_1x, $887_1, $895_2, $9836_1, $9853_x,
{      $5832_1, $5832_2, $5833_1, $5833_1p, $5833_2, $5833_3p, $5833_4,
{      $5838_1, $5838_1p, $5838_2, $5838_3p, $5838_4,
{      $47444_1, $47444_1p, $47444_2, $47444_3p, $47444_4,
{      $7155_1, $7155_1x, $7165_2x, $10395_11, $fa7b4_d, $fa7b5_a, $5831_x,
{      $5680_11, $5682_1x, $5698_1x, $639_1, $679_x, $698_1x, $698_2x,
{      $698_3x, $7021_3x, $7221_1, $7221_11, $9639_1, $65354_1x, $4000_xx,
{      $2620_xxx, $2621_xxx, $2629_x, $380_170, $5380_100, $7040_200
{          keyend
{          name 1..10
{         anyend = $optional
{       iou_program_name, ioupn, ipn: name = $optional
{       serial_number, sn: integer 1..999999 = $optional
{       state, s: key
{           down, off, on
{         keyend = on
{       central_memory_connection, central_memory_connections, cmc: list 1..CLC$MAX_VALUE_SETS of record
{           port: integer 0..3
{           mainframe: name = $optional
{         recend = $optional
{       iou_connection, iou_connections, ic: list 1..CLC$MAX_VALUE_SETS of record
{           channel: name
{           equipment: integer 0..7 = $optional
{           mainframe: name = $optional
{           iou: name = $optional
{         recend = $optional
{       peripheral_connection, peripheral_connections, pc: list 1..CLC$MAX_VALUE_SETS of record
{           peripheral_element: name
{           physical_address: integer 0..0ffff(16) = $optional
{         recend = $optional
{       verify_element_identification, vei: boolean = true
{       application_information, ai: string = $optional
{       site_information, si: string = $optional
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 29] of clt$pdt_parameter_name,
      parameters: array [1 .. 13] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: 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 .. 52] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
        default_value: string (2),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type13: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [94, 3, 16, 11, 13, 55, 263],
    clc$command, 29, 13, 1, 0, 0, 0, 13, 'CMM$EDIPC_REPED'], [
    ['AI                             ',clc$abbreviation_entry, 11],
    ['APPLICATION_INFORMATION        ',clc$nominal_entry, 11],
    ['CENTRAL_MEMORY_CONNECTION      ',clc$nominal_entry, 7],
    ['CENTRAL_MEMORY_CONNECTIONS     ',clc$alias_entry, 7],
    ['CMC                            ',clc$abbreviation_entry, 7],
    ['E                              ',clc$abbreviation_entry, 1],
    ['EI                             ',clc$abbreviation_entry, 3],
    ['ELEMENT                        ',clc$nominal_entry, 1],
    ['ELEMENT_IDENTIFICATION         ',clc$nominal_entry, 3],
    ['IC                             ',clc$abbreviation_entry, 8],
    ['IOUPN                          ',clc$alias_entry, 4],
    ['IOU_CONNECTION                 ',clc$nominal_entry, 8],
    ['IOU_CONNECTIONS                ',clc$alias_entry, 8],
    ['IOU_PROGRAM_NAME               ',clc$nominal_entry, 4],
    ['IPN                            ',clc$abbreviation_entry, 4],
    ['PC                             ',clc$abbreviation_entry, 9],
    ['PERIPHERAL_CONNECTION          ',clc$nominal_entry, 9],
    ['PERIPHERAL_CONNECTIONS         ',clc$alias_entry, 9],
    ['S                              ',clc$abbreviation_entry, 6],
    ['SA                             ',clc$abbreviation_entry, 2],
    ['SAME_AS                        ',clc$nominal_entry, 2],
    ['SERIAL_NUMBER                  ',clc$nominal_entry, 5],
    ['SI                             ',clc$abbreviation_entry, 12],
    ['SITE_INFORMATION               ',clc$nominal_entry, 12],
    ['SN                             ',clc$abbreviation_entry, 5],
    ['STATE                          ',clc$nominal_entry, 6],
    ['STATUS                         ',clc$nominal_entry, 13],
    ['VEI                            ',clc$abbreviation_entry, 10],
    ['VERIFY_ELEMENT_IDENTIFICATION  ',clc$nominal_entry, 10]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1956,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 7
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 120,
  clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 202,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 120,
  clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 11
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 12
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 13
    [27, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    1931, [[1, 0, clc$keyword_type], [52], [
      ['$10395_11                      ', clc$nominal_entry, clc$normal_usage_entry, 29],
      ['$2620_XXX                      ', clc$nominal_entry, clc$normal_usage_entry, 47],
      ['$2621_XXX                      ', clc$nominal_entry, clc$normal_usage_entry, 48],
      ['$2629_X                        ', clc$nominal_entry, clc$normal_usage_entry, 49],
      ['$380_170                       ', clc$nominal_entry, clc$normal_usage_entry, 50],
      ['$4000_XX                       ', clc$nominal_entry, clc$normal_usage_entry, 46],
      ['$47444_1                       ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['$47444_1P                      ', clc$nominal_entry, clc$normal_usage_entry, 22],
      ['$47444_2                       ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['$47444_3P                      ', clc$nominal_entry, clc$normal_usage_entry, 24],
      ['$47444_4                       ', clc$nominal_entry, clc$normal_usage_entry, 25],
      ['$5380_100                      ', clc$nominal_entry, clc$normal_usage_entry, 51],
      ['$5680_11                       ', clc$nominal_entry, clc$normal_usage_entry, 33],
      ['$5682_1X                       ', clc$nominal_entry, clc$normal_usage_entry, 34],
      ['$5698_1X                       ', clc$nominal_entry, clc$normal_usage_entry, 35],
      ['$5831_X                        ', clc$nominal_entry, clc$normal_usage_entry, 32],
      ['$5832_1                        ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['$5832_2                        ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['$5833_1                        ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['$5833_1P                       ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['$5833_2                        ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['$5833_3P                       ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['$5833_4                        ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['$5838_1                        ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['$5838_1P                       ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['$5838_2                        ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['$5838_3P                       ', clc$nominal_entry, clc$normal_usage_entry, 19],
      ['$5838_4                        ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['$639_1                         ', clc$nominal_entry, clc$normal_usage_entry, 36],
      ['$65354_1X                      ', clc$nominal_entry, clc$normal_usage_entry, 45],
      ['$679_X                         ', clc$nominal_entry, clc$normal_usage_entry, 37],
      ['$698_1X                        ', clc$nominal_entry, clc$normal_usage_entry, 38],
      ['$698_2X                        ', clc$nominal_entry, clc$normal_usage_entry, 39],
      ['$698_3X                        ', clc$nominal_entry, clc$normal_usage_entry, 40],
      ['$7021_3X                       ', clc$nominal_entry, clc$normal_usage_entry, 41],
      ['$7040_200                      ', clc$nominal_entry, clc$normal_usage_entry, 52],
      ['$7155_1                        ', clc$nominal_entry, clc$normal_usage_entry, 26],
      ['$7155_1X                       ', clc$nominal_entry, clc$normal_usage_entry, 27],
      ['$7165_2X                       ', clc$nominal_entry, clc$normal_usage_entry, 28],
      ['$7221_1                        ', clc$nominal_entry, clc$normal_usage_entry, 42],
      ['$7221_11                       ', clc$nominal_entry, clc$normal_usage_entry, 43],
      ['$834_12                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['$836_XXX                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['$844_4X                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['$885_1X                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['$887_1                         ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['$895_2                         ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['$9639_1                        ', clc$nominal_entry, clc$normal_usage_entry, 44],
      ['$9836_1                        ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['$9853_X                        ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['$FA7B4_D                       ', clc$nominal_entry, clc$normal_usage_entry, 30],
      ['$FA7B5_A                       ', clc$nominal_entry, clc$normal_usage_entry, 31]]
      ],
    5, [[1, 0, clc$name_type], [1, 10]]
    ],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [1, 999999, 10]],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [3], [
    ['DOWN                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['OFF                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['ON                             ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ,
    'on'],
{ PARAMETER 7
    [[1, 0, clc$list_type], [104, 1, CLC$MAX_VALUE_SETS, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [2],
      ['PORT                           ', clc$required_field, 20], [[1, 0, clc$integer_type], [0, 3, 10]],
      ['MAINFRAME                      ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]]
      ]
    ],
{ PARAMETER 8
    [[1, 0, clc$list_type], [186, 1, CLC$MAX_VALUE_SETS, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [4],
      ['CHANNEL                        ', clc$required_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['EQUIPMENT                      ', clc$optional_field, 20], [[1, 0, clc$integer_type], [0, 7, 10]],
      ['MAINFRAME                      ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['IOU                            ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]]
      ]
    ],
{ PARAMETER 9
    [[1, 0, clc$list_type], [104, 1, CLC$MAX_VALUE_SETS, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [2],
      ['PERIPHERAL_ELEMENT             ', clc$required_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['PHYSICAL_ADDRESS               ', clc$optional_field, 20], [[1, 0, clc$integer_type], [0, 0ffff(16),
  10]]
      ]
    ],
{ PARAMETER 10
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 11
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 12
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 13
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element = 1,
      p$same_as = 2,
      p$element_identification = 3,
      p$iou_program_name = 4,
      p$serial_number = 5,
      p$state = 6,
      p$central_memory_connection = 7,
      p$iou_connection = 8,
      p$peripheral_connection = 9,
      p$verify_element_identification = 10,
      p$application_information = 11,
      p$site_information = 12,
      p$status = 13;

    VAR
      pvt: array [1 .. 13] of clt$parameter_value;

    CONST
      command_name = 'REPLACE_ELEMENT_DEFINITION';


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    cmp$crack_parameters (^pvt, command_name, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

  PROCEND cmp$replace_element_def;


?? OLDTITLE ??

MODEND cmm$pcu_editor_commands;
*DECK DECK=CMM$PCU_EDITOR_FUNCTIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Physical Configuration Utility Functions processor.' ??
MODULE cmm$pcu_editor_functions;

{ PURPOSE:
{    This module contains the function processor interfaces for the
{    Physical Configuration Editor.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$parameter_list
*copyc clt$work_area
*copyc cmt$element_name
*copyc cmt$pcu_command_descriptor
?? POP ??
*copyc clp$evaluate_parameters
*copyc cmp$search_edited_file
*copyc cmv$command_descriptor_p
?? OLDTITLE ??
?? NEWTITLE := '   cmp$$element_definition', EJECT ??

{ PURPOSE:
{    This procedure is the function processor for the Physical
{    Configuration Editor function $ELEMENT_DEFINITION.

  PROCEDURE [XDCL] cmp$$element_definition
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);



{ FUNCTION (cmm$$edipc_ed) $element_definition, $ed (
{   element: any of
{       key
{         all
{       keyend
{       name
{     anyend = all
{   channel: name = $optional
{   mainframe: any of
{       key
{         all
{       keyend
{       name
{     anyend = $name($mainframe(identifier))
{   iou: name = $optional
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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$name_type_qualifier,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: 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$name_type_qualifier,
        recend,
        default_value: string (29),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
    recend := [
    [1,
    [88, 11, 10, 13, 18, 29, 148],
    clc$function, 4, 4, 0, 0, 0, 0, 0, 'CMM$$EDIPC_ED'], [
    ['CHANNEL                        ',clc$nominal_entry, 2],
    ['ELEMENT                        ',clc$nominal_entry, 1],
    ['IOU                            ',clc$nominal_entry, 4],
    ['MAINFRAME                      ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, 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, 69,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [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, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [4, 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, 69,
  clc$optional_default_parameter, 0, 29],
{ PARAMETER 4
    [3, 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, 5, clc$optional_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    '$name($mainframe(identifier))'],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element = 1,
      p$channel = 2,
      p$mainframe = 3,
      p$iou = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      channel: cmt$element_name,
      element_name: cmt$element_name,
      iou_name: cmt$element_name,
      mainframe_name: cmt$element_name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Initialize function value to be a list.

    NEXT result IN work_area;
    result^.kind := clc$list;
    result^.element_value := NIL;
    result^.link := NIL;
    element_name := pvt [p$element].value^.name_value;
    IF pvt [p$channel].specified THEN
      channel := pvt [p$channel].value^.name_value;
    ELSE
      channel := osc$null_name;
    IFEND;
    mainframe_name := pvt [p$mainframe].value^.name_value;
    iou_name := 'IOU0';
    IF pvt [p$iou].specified THEN
      iou_name := pvt [p$iou].value^.name_value;

{ Check if ALL is specified on mainframe parameter and channel and IOU are also specified
{ If so, return empty list because this is an invalid request.

      IF (channel <> osc$null_name) AND (mainframe_name = 'ALL') THEN
        RETURN;
      IFEND;
    IFEND;
    setup_function_value (element_name, channel, mainframe_name, iou_name, work_area, result);

  PROCEND cmp$$element_definition;

?? OLDTITLE ??
?? NEWTITLE := '   build_result', EJECT ??

{ PURPOSE:
{   This procedures builds the value of the function $element_definition.

  PROCEDURE build_result
    (    command: cmt$pcu_command_descriptor;
     VAR work_area: ^clt$work_area;
     VAR value: ^clt$data_value);


    VAR
      i: integer,
      list_value: ^clt$data_value;


{ build element in the list of type record. Unitialized field will be of
{ type clc$unspecified.

    NEXT value^.element_value IN work_area;
    value^.element_value^.kind := clc$record;
    NEXT value^.element_value^.field_values: [1 .. 11] IN work_area;
    value^.element_value^.field_values^ [1].name := 'ELEMENT';
    NEXT value^.element_value^.field_values^ [1].value IN work_area;
    value^.element_value^.field_values^ [1].value^.kind := clc$name;
    value^.element_value^.field_values^ [1].value^.name_value := command.element_name;

    value^.element_value^.field_values^ [2].name := 'APPLICATION_INFORMATION';
    NEXT value^.element_value^.field_values^ [2].value IN work_area;
    value^.element_value^.field_values^ [2].value^.kind := clc$unspecified;
    IF command.application_info_p <> NIL THEN
      value^.element_value^.field_values^ [2].value^.kind := clc$string;
      NEXT value^.element_value^.field_values^ [2].value^.string_value:
          [STRLENGTH(command.application_info_p^)] IN work_area;
      value^.element_value^.field_values^ [2].value^.string_value^ := command.application_info_p^;
    IFEND;
    value^.element_value^.field_values^ [3].name := 'CENTRAL_MEMORY_CONNECTIONS';
    NEXT value^.element_value^.field_values^ [3].value IN work_area;
    value^.element_value^.field_values^ [3].value^.kind := clc$unspecified;

    value^.element_value^.field_values^ [4].name := 'ELEMENT_IDENTIFICATION';
    NEXT value^.element_value^.field_values^ [4].value IN work_area;
    IF command.pid <> osc$null_name THEN
      value^.element_value^.field_values^ [4].value^.kind := clc$name;
      value^.element_value^.field_values^ [4].value^.name_value := command.pid;
    ELSE
      value^.element_value^.field_values^ [4].value^.kind := clc$unspecified;
    IFEND;

    value^.element_value^.field_values^ [5].name := 'IOU_CONNECTIONS';
    NEXT value^.element_value^.field_values^ [5].value IN work_area;
    value^.element_value^.field_values^ [5].value^.kind := clc$unspecified;

    value^.element_value^.field_values^ [6].name := 'IOU_PROGRAM_NAME';
    NEXT value^.element_value^.field_values^ [6].value IN work_area;
    IF command.ioupn <> osc$null_name THEN
      value^.element_value^.field_values^ [6].value^.kind := clc$name;
      value^.element_value^.field_values^ [6].value^.name_value := command.ioupn;
    ELSE
      value^.element_value^.field_values^ [6].value^.kind := clc$unspecified;
    IFEND;

    value^.element_value^.field_values^ [7].name := 'PERIPHERAL_CONNECTIONS';
    NEXT value^.element_value^.field_values^ [7].value IN work_area;
    value^.element_value^.field_values^ [7].value^.kind := clc$unspecified;

    CASE command.connection OF
    = cmc$central_memory_connection =
      IF command.cmc_list <> NIL THEN
        list_value := value^.element_value^.field_values^ [3].value;

{ Construct a list of record.
{ Fields of record are:
{    PORT and MAINFRAME.

        FOR i := LOWERBOUND (command.cmc_list^) TO UPPERBOUND (command.cmc_list^) DO
          list_value^.kind := clc$list;
          NEXT list_value^.element_value IN work_area;
          list_value^.element_value^.kind := clc$record;
          NEXT list_value^.element_value^.field_values: [1 .. 2] IN work_area;
          list_value^.element_value^.field_values^ [1].name := 'PORT';
          NEXT list_value^.element_value^.field_values^ [1].value IN work_area;
          list_value^.element_value^.field_values^ [1].value^.kind := clc$integer;
          list_value^.element_value^.field_values^ [1].value^.integer_value.value :=
                command.cmc_list^ [i].port;
          list_value^.element_value^.field_values^ [1].value^.integer_value.radix := 10;
          list_value^.element_value^.field_values^ [1].value^.integer_value.radix_specified := FALSE;
          list_value^.element_value^.field_values^ [2].name := 'MAINFRAME';
          NEXT list_value^.element_value^.field_values^ [2].value IN work_area;
          list_value^.element_value^.field_values^ [2].value^.kind := clc$name;
          list_value^.element_value^.field_values^ [2].value^.name_value := command.cmc_list^ [i].mainframe;
          list_value^.generated_via_list_rest := FALSE;
          IF i < UPPERBOUND (command.cmc_list^) THEN
            NEXT list_value^.link IN work_area;
            list_value := list_value^.link;
          ELSE
            list_value^.link := NIL;
          IFEND;
        FOREND;
      IFEND;
      IF command.channel_list <> NIL THEN
        list_value := value^.element_value^.field_values^ [5].value;

{ Construct a list of record.
{ Fields of record are:
{   CHANNEL, EQUIPMENT, MAINFRAME and IOU.
{ Note: External processor elements are defined with IOU_CONNECTIONS and
{ optional CENTRAL_MEMORY_CONNECTIONS.

        FOR i := LOWERBOUND (command.channel_list^) TO UPPERBOUND (command.channel_list^) DO
          list_value^.kind := clc$list;
          NEXT list_value^.element_value IN work_area;
          list_value^.element_value^.kind := clc$record;
          NEXT list_value^.element_value^.field_values: [1 .. 4] IN work_area;
          list_value^.element_value^.field_values^ [1].name := 'CHANNEL';
          NEXT list_value^.element_value^.field_values^ [1].value IN work_area;
          list_value^.element_value^.field_values^ [1].value^.kind := clc$name;
          list_value^.element_value^.field_values^ [1].value^.name_value := command.channel_list^ [i].channel;
          list_value^.element_value^.field_values^ [2].name := 'EQUIPMENT';
          NEXT list_value^.element_value^.field_values^ [2].value IN work_area;
          list_value^.element_value^.field_values^ [2].value^.kind := clc$integer;
          list_value^.element_value^.field_values^ [2].value^.integer_value.value := command.
                channel_list^ [i].equipment;
          list_value^.element_value^.field_values^ [2].value^.integer_value.radix := 10;
          list_value^.element_value^.field_values^ [2].value^.integer_value.radix_specified := FALSE;
          list_value^.element_value^.field_values^ [3].name := 'MAINFRAME';
          NEXT list_value^.element_value^.field_values^ [3].value IN work_area;
          list_value^.element_value^.field_values^ [3].value^.kind := clc$name;
          list_value^.element_value^.field_values^ [3].value^.name_value :=
                command.channel_list^ [i].mainframe;
          list_value^.element_value^.field_values^ [4].name := 'IOU';
          NEXT list_value^.element_value^.field_values^ [4].value IN work_area;
          list_value^.element_value^.field_values^ [4].value^.kind := clc$name;
          list_value^.element_value^.field_values^ [4].value^.name_value := command.channel_list^ [i].iou;
          list_value^.generated_via_list_rest := FALSE;
          IF i < UPPERBOUND (command.channel_list^) THEN
            NEXT list_value^.link IN work_area;
            list_value := list_value^.link;
          ELSE
            list_value^.link := NIL;
          IFEND;
        FOREND;
      IFEND;

    = cmc$iou_connection =
      IF command.iou_list <> NIL THEN
        list_value := value^.element_value^.field_values^ [5].value;

{ Construct a list of record.
{ Fields of record are:
{   CHANNEL, EQUIPMENT, MAINFRAME and IOU.


        FOR i := LOWERBOUND (command.iou_list^) TO UPPERBOUND (command.iou_list^) DO
          list_value^.kind := clc$list;
          NEXT list_value^.element_value IN work_area;
          list_value^.element_value^.kind := clc$record;
          NEXT list_value^.element_value^.field_values: [1 .. 4] IN work_area;
          list_value^.element_value^.field_values^ [1].name := 'CHANNEL';
          NEXT list_value^.element_value^.field_values^ [1].value IN work_area;
          list_value^.element_value^.field_values^ [1].value^.kind := clc$name;
          list_value^.element_value^.field_values^ [1].value^.name_value := command.iou_list^ [i].channel;
          list_value^.element_value^.field_values^ [2].name := 'EQUIPMENT';
          NEXT list_value^.element_value^.field_values^ [2].value IN work_area;
          list_value^.element_value^.field_values^ [2].value^.kind := clc$integer;
          list_value^.element_value^.field_values^ [2].value^.integer_value.value :=
                command.iou_list^ [i].equipment;
          list_value^.element_value^.field_values^ [2].value^.integer_value.radix := 10;
          list_value^.element_value^.field_values^ [2].value^.integer_value.radix_specified := FALSE;
          list_value^.element_value^.field_values^ [3].name := 'MAINFRAME';
          NEXT list_value^.element_value^.field_values^ [3].value IN work_area;
          list_value^.element_value^.field_values^ [3].value^.kind := clc$name;
          list_value^.element_value^.field_values^ [3].value^.name_value := command.iou_list^ [i].mainframe;
          list_value^.element_value^.field_values^ [4].name := 'IOU';
          NEXT list_value^.element_value^.field_values^ [4].value IN work_area;
          list_value^.element_value^.field_values^ [4].value^.kind := clc$name;
          list_value^.element_value^.field_values^ [4].value^.name_value := command.iou_list^ [i].iou;
          list_value^.generated_via_list_rest := FALSE;
          IF i < UPPERBOUND (command.iou_list^) THEN
            NEXT list_value^.link IN work_area;
            list_value := list_value^.link;
          ELSE
            list_value^.link := NIL;
          IFEND;
        FOREND;
      IFEND;

    = cmc$peripheral_connection =
      IF command.pc_list <> NIL THEN
        list_value := value^.element_value^.field_values^ [7].value;

{ Construct a list of record.
{ Fields of record are:
{    PERIPHERAL, and PHYSICAL_ADDRESS

        FOR i := LOWERBOUND (command.pc_list^) TO UPPERBOUND (command.pc_list^) DO
          list_value^.kind := clc$list;
          NEXT list_value^.element_value IN work_area;
          list_value^.element_value^.kind := clc$record;
          NEXT list_value^.element_value^.field_values: [1 .. 2] IN work_area;
          list_value^.element_value^.field_values^ [1].name := 'PERIPHERAL_ELEMENT';
          NEXT list_value^.element_value^.field_values^ [1].value IN work_area;
          list_value^.element_value^.field_values^ [1].value^.kind := clc$name;
          list_value^.element_value^.field_values^ [1].value^.name_value := command.pc_list^ [i].peripheral;
          list_value^.element_value^.field_values^ [2].name := 'PHYSICAL_ADDRESS';
          NEXT list_value^.element_value^.field_values^ [2].value IN work_area;
          list_value^.element_value^.field_values^ [2].value^.kind := clc$integer;
          list_value^.element_value^.field_values^ [2].value^.integer_value.value :=
                command.pc_list^ [i].address;
          list_value^.element_value^.field_values^ [2].value^.integer_value.radix := 10;
          list_value^.element_value^.field_values^ [2].value^.integer_value.radix_specified := FALSE;
          list_value^.generated_via_list_rest := FALSE;
          IF i < UPPERBOUND (command.pc_list^) THEN
            NEXT list_value^.link IN work_area;
            list_value := list_value^.link;
          ELSE
            list_value^.link := NIL;
          IFEND;
        FOREND;
      IFEND;
    ELSE
      ;
    CASEND;
    value^.element_value^.field_values^ [8].name := 'SERIAL_NUMBER';
    NEXT value^.element_value^.field_values^ [8].value IN work_area;
    IF command.sn <> 0 THEN
      value^.element_value^.field_values^ [8].value^.kind := clc$integer;
      value^.element_value^.field_values^ [8].value^.integer_value.value := command.sn;
      value^.element_value^.field_values^ [8].value^.integer_value.radix := 10;
      value^.element_value^.field_values^ [8].value^.integer_value.radix_specified := FALSE;
    ELSE
      value^.element_value^.field_values^ [8].value^.kind := clc$unspecified;
    IFEND;

    value^.element_value^.field_values^ [9].name := 'SITE_INFORMATION';
    NEXT value^.element_value^.field_values^ [9].value IN work_area;
    value^.element_value^.field_values^ [9].value^.kind := clc$unspecified;
    IF command.site_info_p <> NIL THEN
      value^.element_value^.field_values^ [9].value^.kind := clc$string;
      NEXT value^.element_value^.field_values^ [9].value^.string_value: [STRLENGTH(command.site_info_p^)]
                   IN work_area;
      value^.element_value^.field_values^ [9].value^.string_value^ := command.site_info_p^;
    IFEND;

    value^.element_value^.field_values^ [10].name := 'STATE';
    NEXT value^.element_value^.field_values^ [10].value IN work_area;
    IF command.state <> osc$null_name THEN
      value^.element_value^.field_values^ [10].value^.kind := clc$keyword;
      value^.element_value^.field_values^ [10].value^.keyword_value := command.state;
    ELSE
      value^.element_value^.field_values^ [10].value^.kind := clc$unspecified;
    IFEND;

    value^.element_value^.field_values^ [11].name := 'VERIFY_ELEMENT_IDENTIFICATION';
    NEXT value^.element_value^.field_values^ [11].value IN work_area;
    value^.element_value^.field_values^ [11].value^.kind := clc$boolean;
    value^.element_value^.field_values^ [11].value^.boolean_value.value := command.verify;
    value^.element_value^.field_values^ [11].value^.boolean_value.kind := clc$true_false_boolean;

    value^.generated_via_list_rest := FALSE;
  PROCEND build_result;

?? OLDTITLE ??
?? NEWTITLE := '   setup_function_value ', EJECT ??

{ PURPOSE:
{   This procedure searches for the definition in the edited file
{   and sets up the result of the function.

  PROCEDURE setup_function_value
    (    element_name: cmt$element_name;
         channel: cmt$element_name;
         mainframe_name: cmt$element_name;
         iou_name: cmt$element_name;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value);

    VAR
      current_p: ^cmt$pcu_command_descriptor,
      find_all_element: boolean,
      found: boolean,
      found_element: cmt$pcu_command_descriptor,
      j: integer,
      list_index: integer,
      match: boolean,
      product_id: cmt$product_identification,
      status: ost$status,
      value: ^clt$data_value;


    IF cmv$command_descriptor_p = NIL THEN
      RETURN;
    IFEND;
    find_all_element := element_name = 'ALL';
    current_p := cmv$command_descriptor_p;
    value := NIL;
    WHILE current_p <> NIL DO
      IF mainframe_name <> 'ALL' THEN
        found := FALSE;
        CASE current_p^.connection OF
        = cmc$central_memory_connection =
          IF current_p^.channel_list <> NIL THEN
            list_index := 1;
            WHILE (NOT found) AND (list_index <= UPPERBOUND (current_p^.channel_list^)) DO
              IF find_all_element THEN
                IF channel <> osc$null_name THEN
                  found := ((current_p^.channel_list^ [list_index].mainframe = mainframe_name) AND
                        (current_p^.channel_list^ [list_index].iou = iou_name) AND
                        (current_p^.channel_list^ [list_index].channel = channel));
                ELSE
                  found := ((current_p^.channel_list^ [list_index].mainframe = mainframe_name) AND
                        (current_p^.channel_list^ [list_index].iou = iou_name));
                IFEND;
              ELSE
                found := current_p^.element_name = element_name;
              IFEND;
              list_index := list_index + 1;
            WHILEND;
          IFEND;

        = cmc$iou_connection =
          IF current_p^.iou_list <> NIL THEN
            list_index := 1;
            WHILE (NOT found) AND (list_index <= UPPERBOUND (current_p^.iou_list^)) DO
              IF find_all_element THEN
                IF (channel <> osc$null_name) THEN
                  found := ((current_p^.iou_list^ [list_index].mainframe = mainframe_name) AND
                        (current_p^.iou_list^ [list_index].iou = iou_name) AND
                        (current_p^.iou_list^ [list_index].channel = channel));
                ELSE
                  found := ((current_p^.iou_list^ [list_index].mainframe = mainframe_name) AND
                        (current_p^.iou_list^ [list_index].iou = iou_name));
                IFEND;
              ELSE
                found := current_p^.element_name = element_name;
              IFEND;
              list_index := list_index + 1;
            WHILEND;
          IFEND;

        = cmc$peripheral_connection =
          IF NOT find_all_element THEN
            found := current_p^.element_name = element_name;
          ELSE
            IF current_p^.pc_list <> NIL THEN
              list_index := 1;
              WHILE (NOT found) AND (list_index <= UPPERBOUND (current_p^.pc_list^)) DO
                cmp$search_edited_file (current_p^.pc_list^ [list_index].peripheral, 0, product_id,
                     found, found_element);
                IF found THEN
                  CASE found_element.connection OF
                  = cmc$iou_connection =
                    IF found_element.iou_list <> NIL THEN
                      j := 1;
                      match := FALSE;
                      WHILE (NOT match) AND (j <= UPPERBOUND (found_element.iou_list^)) DO
                        CASE found_element.connection OF
                        = cmc$iou_connection =
                          IF (channel <> osc$null_name) THEN
                            match := ((found_element.iou_list^ [j].mainframe = mainframe_name) AND
                                (found_element.iou_list^ [j].iou = iou_name) AND
                                (found_element.iou_list^ [j].channel = channel));
                          ELSE
                            match := ((found_element.iou_list^ [j].mainframe = mainframe_name) AND
                                (found_element.iou_list^ [j].iou = iou_name));
                          IFEND;
                        ELSE
                          ;
                        CASEND;
                        j := j + 1;
                      WHILEND;
                      found := match;
                    IFEND;
                  ELSE
                    ;
                  CASEND;
                IFEND;
                list_index := list_index + 1;
              WHILEND;
            IFEND;
          IFEND;
        CASEND;
      ELSE
        found := TRUE;
      IFEND;
      IF found THEN
        IF value <> NIL THEN
          NEXT value^.link IN work_area;
          value := value^.link;
          value^.kind := clc$list;
        ELSE
          value := result;
        IFEND;
        value^.link := NIL;
        build_result (current_p^, work_area, value);
        IF NOT find_all_element THEN
          RETURN
        IFEND;
      IFEND;
      current_p := current_p^.next_descriptor;
    WHILEND;

  PROCEND setup_function_value;

?? OLDTITLE ??

MODEND cmm$pcu_editor_functions;

*DECK DECK=CMM$PCU_RING1_HELPER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE CM : PCU Ring1 Helper' ??
MODULE cmm$pcu_ring1_helper;

{ PURPOSE:
{   This module contains the ring 1 procedures that help the PCU procedures that run at job_template_23d.
{   These procedures are used to build the full configuration tables.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmc$logical_unit_constants
*copyc cme$logical_configuration_mgr
*copyc cme$physical_configuration_mgr
*copyc cmt$channel_descriptor
*copyc cmt$deadstart_signal
*copyc cmt$physical_channel
*copyc cmt$physical_equipment_number
*copyc cmt$physical_unit_number
*copyc dse$resource_errors
*copyc oss$mainframe_paged_literal
*copyc pmt$signal
?? POP ??
*copyc cmp$acquire_resources
*copyc cmp$build_element_def_table
*copyc cmp$build_interface_tables
*copyc cmp$convert_channel_number
*copyc cmp$convert_iou_name
*copyc cmp$convert_iou_number
*copyc cmp$determine_redundant_channel
*copyc cmp$free_element_def_table
*copyc cmp$get_channel_def
*copyc cmp$get_controller_type
*copyc cmp$get_driver_by_controller
*copyc cmp$get_element_state
*copyc cmp$get_max_number_of_pp
*copyc cmp$get_unit_type
*copyc cmp$idle_pp_r1
*copyc cmp$load_controller_module
*copyc cmp$pc_get_element
*copyc cmp$pc_get_logical_unit
*copyc cmp$pc_get_next_channel
*copyc cmp$release_channel_resource
*copyc cmp$release_equipment_resource
*copyc cmp$release_pp_by_channel
*copyc cmp$release_pp_resource
*copyc cmp$request_resources
*copyc cmp$retrieve_logical_pp_index
*copyc cmp$set_illegal_channel_status
*copyc cmp$update_connection_states_r1
*copyc dmp$allocate_avt
*copyc dsp$load_pp
*copyc iop$allocate_usage_counters
*copyc iop$tape_initialization
*copyc osp$set_status_abnormal
*copyc pmp$get_mainframe_id
*copyc pmp$zero_out_table
*copyc syp$process_deadstart_status
*copyc syp$trace_deadstart_message
?? EJECT ??
*copyc cmv$acquire_pp_for_redundant_ch
*copyc cmv$configuration_activated
*copyc cmv$controller_location
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc cmv$max_number_of_pp
*copyc cmv$new_logical_pp_table_p
*copyc cmv$new_logical_unit_table
*copyc cmv$physical_configuration
*copyc cmv$post_deadstart
*copyc cmv$save_pct_p
*copyc cmv$save_state_table_p
*copyc cmv$state_info_table
*copyc cmv$system_device_data
*copyc cmv$system_device_pp
*copyc osv$170_os_type
*copyc osv$mainframe_pageable_heap
*copyc osv$mainframe_wired_cb_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    t$resources_assigned = RECORD
      assigned: boolean,
      channel: cmt$physical_channel,
      iou_number: dst$iou_number,
      equipment: 0 .. cmc$null_equipment_number,
      unit: 0 .. cmc$null_unit_number,
      driver_name: cmt$element_name,
      pp_resources_needed: boolean,
    RECEND;

  VAR
    cmv$deadstart_signals: [XDCL, #GATE] ^cmt$deadstart_signal := NIL,
    cmv$signal_handler_active: [XDCL, #GATE] boolean := FALSE,
    v$first_time: boolean := TRUE,
    v$save_lpt_p: ^cmt$logical_pp_table := NIL,
    v$save_lut_p: ^cmt$logical_unit_table := NIL;

?? OLDTITLE ??
?? NEWTITLE := 'acquire_all_resources', EJECT ??

{ PURPOSE:
{   This procedure acquires all the needed IOU resources. This is achieved by going through the structure
{   previously built by determine_resources.

  PROCEDURE acquire_all_resources
    (VAR resources_assigned_p: ^ARRAY [ * ] OF t$resources_assigned;
     VAR status: ost$status);

    VAR
      dummy_pp: dst$iou_resource,
      index: integer,
      pp_number: iot$pp_number,
      tape_channel: cmt$physical_channel,
      tape_channel_name: cmt$element_name,
      tape_element_p: ^cmt$element_definition,
      tape_iou: dst$iou_number,
      tape_iou_name: cmt$element_name;

    status.normal := TRUE;

    { Clear the table which tells which PP has controlware or control module loaded.  This is done so that
    { the new logical pp table will be created with new RMA lists.

    FOR pp_number := LOWERBOUND (cmv$new_logical_pp_table_p^) TO UPPERBOUND (cmv$new_logical_pp_table_p^) DO
      cmv$new_logical_pp_table_p^ [pp_number].controller_info.controlware_loaded := FALSE;
      cmv$new_logical_pp_table_p^ [pp_number].controller_info.control_module_loaded := FALSE;
    FOREND;

    { Load the controlware from the CIP device to memory.

    cmp$load_controller_module (cmc$load_controlware, cmv$new_logical_pp_table_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Load the control module from the CIP device to memory.

    cmp$load_controller_module (cmc$load_control_module, cmv$new_logical_pp_table_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF resources_assigned_p = NIL THEN
      RETURN;
    IFEND;

    { Idle the tape driver so it can be acquired again.

    IF v$first_time THEN
      IF cmv$system_device_data [cmc$sdt_tape_device].specified THEN
        tape_channel_name := cmv$system_device_data [cmc$sdt_tape_device].channel_name;
        tape_iou := cmv$system_device_data [cmc$sdt_tape_device].iou_number;
        cmp$convert_iou_number (tape_iou, tape_iou_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        cmp$pc_get_element (tape_channel_name, tape_iou_name, tape_element_p, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        tape_channel.number := tape_element_p^.data_channel.number;
        tape_channel.concurrent := tape_element_p^.data_channel.concurrent;
        tape_channel.port := tape_element_p^.data_channel.port;

        cmp$idle_pp_r1 (tape_element_p^.element_name, tape_iou_name, status);

        cmp$release_pp_by_channel (tape_channel, tape_iou, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF (cmv$system_device_data [cmc$sdt_tape_device].unit_id.product_number = '  $639') OR
              ((cmv$system_device_data [cmc$sdt_tape_device].equipment_id.product_number = '  $698') AND
              (osv$170_os_type = osc$ot7_dual_state_nos_be)) OR
              (cmv$system_device_data [cmc$sdt_tape_device].equipment_id.product_number = ' $5698') THEN
          cmp$release_channel_resource (tape_channel, tape_iou, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          cmp$release_equipment_resource (tape_channel, tape_iou,
                cmv$system_device_data [cmc$sdt_tape_device].equipment_number,
                cmv$system_device_data [cmc$sdt_tape_device].unit_number);
        IFEND;
        v$first_time := FALSE;
      IFEND;
    IFEND;

    FOR index := LOWERBOUND (resources_assigned_p^) TO UPPERBOUND (resources_assigned_p^) DO
      IF resources_assigned_p^ [index].driver_name <> ' ' THEN
        IF resources_assigned_p^ [index].pp_resources_needed THEN
          obtain_pp_resource (resources_assigned_p^ [index], status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          resources_assigned_p^ [index].assigned := TRUE;
        ELSE

          { Attempt to get only the channel/equipment but no PP.

          IF (resources_assigned_p^ [index].equipment = cmc$null_equipment_number) OR
                (resources_assigned_p^ [index].unit = cmc$null_unit_number) THEN
            cmp$acquire_resources (dsc$rrt_get_channel, resources_assigned_p^ [index].channel,
                  resources_assigned_p^ [index].iou_number, cmc$null_equipment_number,
                  cmc$null_unit_number, FALSE, FALSE, FALSE, dummy_pp, status);
          ELSE
            cmp$acquire_resources (dsc$rrt_get_equipment, resources_assigned_p^ [index].channel,
                  resources_assigned_p^ [index].iou_number,
                  resources_assigned_p^ [index].equipment, resources_assigned_p^ [index].unit, FALSE,
                  FALSE, FALSE, dummy_pp, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          resources_assigned_p^ [index].assigned := TRUE;
        IFEND;
      IFEND;
    FOREND;

  PROCEND acquire_all_resources;
?? OLDTITLE ??
?? NEWTITLE := 'begin_conf_transition', EJECT ??

{ PURPOSE:
{   This procedure starts the transition from System/Deadstart devices to the full configuration. This
{   involves IDLE and RELOAD of the system device driver and loading of all drivers.

  PROCEDURE begin_conf_transition
    (    system_device_lun: iot$logical_unit;
     VAR resources_assigned_p: ^ARRAY [ * ] OF t$resources_assigned;
     VAR status: ost$status);

    VAR
      allocate_ok: boolean,
      cm_unit_type: cmt$unit_type,
      controller_configured: boolean,
      controller_type: cmt$controller_type,
      data_storage_port: cmt$data_storage_port_number,
      disk_unit_count: integer,
      element_name: cmt$element_name,
      io_unit_type: iot$unit_type,
      iou_name: cmt$element_name,
      iou_number: dst$iou_number,
      local_status: ost$status,
      partner_pp_index: iot$pp_number,
      pp_index: iot$pp_number,
      storage_device_found: boolean,
      sys_dev_channel_p: ^cmt$element_definition,
      sys_dev_element_p: ^cmt$element_definition,
      sys_eq_element_p: ^cmt$element_definition,
      system_device_iou: cmt$element_name,
      system_device_channel: cmt$physical_channel,
      system_device_equipment: cmt$physical_equipment_number,
      system_device_unit: cmt$physical_unit_number,
      unit_class: cmt$unit_class,
      unit_index: iot$logical_unit;

    status.normal := TRUE;

    cmp$pc_get_logical_unit (system_device_lun, sys_dev_element_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$get_system_device_path (cmc$sdt_disk_device, system_device_iou, system_device_channel,
          system_device_equipment, system_device_unit, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    controller_configured := FALSE;

   /loop/
    FOR data_storage_port := LOWERVALUE (cmt$data_storage_port_number) TO
          UPPERVALUE (cmt$data_storage_port_number) DO
      IF NOT sys_dev_element_p^.storage_device.connection.port [data_storage_port].configured THEN
        CYCLE /loop/;
      IFEND;
      element_name := sys_dev_element_p^.storage_device.connection.port [data_storage_port].element_name;
      IF sys_dev_element_p^.storage_device.connection.port [data_storage_port].upline_connection_type =
            cmc$data_channel_element THEN
        iou_name := sys_dev_element_p^.storage_device.connection.port [data_storage_port].iou;
      ELSE
        iou_name := osc$null_name;
      IFEND;
      cmp$pc_get_element (element_name, iou_name, sys_eq_element_p, local_status);
      IF NOT local_status.normal THEN
        CYCLE /loop/;
      IFEND;
      controller_configured := TRUE;
      EXIT /loop/;
    FOREND /loop/;
    IF NOT controller_configured THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_equip_not_configured,
            'Equipment specified not configured in begin_conf_transition', status);
      RETURN;
    IFEND;

    cmp$get_unit_type (sys_dev_element_p^.product_id, cm_unit_type, io_unit_type, unit_class,
          storage_device_found);
    IF NOT storage_device_found THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$unknown_product_id,
            sys_dev_element_p^.product_id.product_number, status);
      RETURN;
    IFEND;
    IF cm_unit_type <> cmc$mshydra THEN
      cmp$get_controller_type (sys_eq_element_p^.product_id, controller_type, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      controller_type := cmc$mshydra_ct;
    IFEND;

    cmp$convert_iou_name (system_device_iou, iou_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$retrieve_logical_pp_index (system_device_channel, iou_number, cmv$new_logical_pp_table_p,
          pp_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Do not obtain pp, only the reload driver.

    partner_pp_index := cmv$new_logical_pp_table_p^ [pp_index].pp_info.logical_partner_pp_index;
    cmv$new_logical_pp_table_p^ [pp_index].pp_info.physical_pp := cmv$system_device_pp.primary_pp;
    cmv$new_logical_pp_table_p^ [pp_index].flags.resources_acquired := TRUE;
    IF partner_pp_index > 0 THEN
      cmv$new_logical_pp_table_p^ [partner_pp_index].pp_info.physical_pp := cmv$system_device_pp.partner_pp;
      cmv$new_logical_pp_table_p^ [partner_pp_index].flags.resources_acquired := TRUE;
      cmv$system_device_pp.ppit_rma :=
            cmv$new_logical_pp_table_p^ [pp_index].pp_info.pp_communication_buffer_p^.partner_pp;
    IFEND;

    { One request will load both master and slave pp if dual pp exists.

    dsp$load_pp (dsc$load_pp_by_name, cmv$new_logical_pp_table_p^ [pp_index].pp_info.physical_pp, NIL,
          cmv$new_logical_pp_table_p^ [pp_index].pp_info.cip_driver_name,
          cmv$new_logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_rma, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cmv$new_logical_pp_table_p^ [pp_index].flags.pp_loaded := TRUE;
    IF partner_pp_index > 0 THEN
      cmv$new_logical_pp_table_p^ [partner_pp_index].flags.pp_loaded := TRUE;
    IFEND;

    load_all_other_drivers (system_device_channel, iou_number, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status (' ', TRUE, status);
      RETURN;
    IFEND;

    disk_unit_count := 0;
    FOR unit_index := cmc$job_template_unit_ordinal TO UPPERBOUND (cmv$logical_unit_table^) DO
      IF cmv$logical_unit_table^ [unit_index].configured AND
            (cmv$logical_unit_table^ [unit_index].unit_interface_table^.unit_type >= ioc$lowest_disk_unit) AND
            (cmv$logical_unit_table^ [unit_index].unit_interface_table^.unit_type <=
            ioc$highest_disk_unit) THEN
        disk_unit_count := disk_unit_count + 1;
      IFEND;
    FOREND;

    dmp$allocate_avt (disk_unit_count, allocate_ok);
    IF NOT allocate_ok THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_allocate_avt_error,
            'DMP$ALLOCATE_AVT', status);
      RETURN;
    IFEND;

    iop$allocate_usage_counters (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { FREE resources_assigned_p if no errors occurred

    IF resources_assigned_p <> NIL THEN
      FREE resources_assigned_p IN osv$mainframe_pageable_heap^;
    IFEND;

  PROCEND begin_conf_transition;
?? OLDTITLE ??
?? NEWTITLE := 'determine_resources', EJECT ??

{ PURPOSE:
{   This procedures determines all of the IOU resources needed to acquire.
{ DESIGN:
{   Allocate a table with the number of entries equal to the number of entries in the configuration table.
{   This structure will contain one entry per Equipment/Channel to be acquired.  The same structure will be
{   saved so clean up can be performed should an error occured during resources acquisition.

  PROCEDURE determine_resources
    (VAR resources_assigned_p: ^ARRAY [ * ] OF t$resources_assigned;
     VAR status: ost$status);

    VAR
      ch_element_p: ^cmt$element_definition,
      ch_iou_number: dst$iou_number,
      channel_state: cmt$element_state,
      cm_unit_type: cmt$unit_type,
      controller_type: cmt$controller_type,
      count: integer,
      current_channel: integer,
      current_ch_is_system_device_ch: boolean,
      driver_name: string (4),
      equip_element_p: ^cmt$element_definition,
      equip_state: cmt$element_state,
      found: boolean,
      get_full_path: boolean,
      index_count: integer,
      io_unit_type: iot$unit_type,
      local_status: ost$status,
      number_of_controller_on: integer,
      number_of_units_configured: integer,
      pen: cmt$physical_equipment_number,
      pp_resources_needed: boolean,
      pun: cmt$physical_unit_number,
      system_device_channel: cmt$physical_channel,
      system_device_iou: cmt$element_name,
      system_device_equipment: cmt$physical_equipment_number,
      system_device_unit: cmt$physical_unit_number,
      table_setup: boolean,
      temp_table_p: ^ARRAY [ * ] OF t$resources_assigned,
      total_resources: integer,
      unit_class: cmt$unit_class,
      unit_element_p: ^cmt$element_definition,
      unit_state: cmt$element_state;

    status.normal := TRUE;

    current_channel := 0;
    get_full_path := FALSE;
    total_resources := 0;

    count := UPPERBOUND (cmv$physical_configuration^);
    PUSH temp_table_p: [1 .. count];
    FOR index_count := 1 TO count DO
      temp_table_p^ [index_count].driver_name := ' ';
      temp_table_p^ [index_count].assigned := FALSE;
      temp_table_p^ [index_count].pp_resources_needed := FALSE;
    FOREND;

    cmp$get_system_device_path (cmc$sdt_disk_device, system_device_iou, system_device_channel,
          system_device_equipment, system_device_unit, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /loop_thru_channels/
    WHILE total_resources <= count DO
      cmp$pc_get_next_channel (current_channel, ch_element_p, local_status);
      IF NOT local_status.normal THEN
        EXIT /loop_thru_channels/;
      IFEND;
      current_channel := current_channel + 1;

      cmp$get_element_state (ch_element_p^.element_name, ch_element_p^.data_channel.iou, channel_state,
            status);
      IF channel_state = cmc$off THEN
        CYCLE /loop_thru_channels/;
      IFEND;

      cmp$convert_iou_name (ch_element_p^.data_channel.iou, ch_iou_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      current_ch_is_system_device_ch := FALSE;
      get_full_path := FALSE;
      number_of_controller_on := 0;
      table_setup := FALSE;

    /loop_thru_controllers/
      FOR pen := LOWERVALUE (cmt$physical_equipment_number) TO UPPERVALUE (cmt$physical_equipment_number) DO
        IF NOT ch_element_p^.data_channel.connection.equipment [pen].configured THEN
          CYCLE /loop_thru_controllers/;
        IFEND;

        cmp$pc_get_element (ch_element_p^.data_channel.connection.equipment [pen].element_name, osc$null_name,
              equip_element_p, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        { For S0, not get channel associated with ICA. }

        IF ((equip_element_p^.element_type = cmc$channel_adapter_element) AND
              (equip_element_p^.product_id.product_number = ' $2629')) OR
              (equip_element_p^.element_type = cmc$communications_element) THEN
          EXIT /loop_thru_controllers/;
        IFEND;

        cmp$get_element_state (equip_element_p^.element_name, osc$null_name, equip_state, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF equip_state = cmc$off THEN
          CYCLE /loop_thru_controllers/;
        IFEND;

        CASE equip_element_p^.element_type OF
        = cmc$controller_element =
          cmp$get_controller_type (equip_element_p^.product_id, controller_type, local_status);
          IF NOT local_status.normal THEN
            EXIT /loop_thru_controllers/;
          IFEND;

          get_full_path := (controller_type = cmc$ms7165_2x) OR
                ((controller_type = cmc$mt698_xx) AND (osv$170_os_type = osc$ot7_dual_state_nos_be)) OR
                (controller_type = cmc$mscm3_ct) OR (controller_type = cmc$mshydra_ct) OR
                (controller_type = cmc$ms7255_1_1) OR (controller_type = cmc$ms7255_1_2) OR
                (controller_type = cmc$ms5831_x) OR (controller_type = cmc$mt7221_1) OR
                (controller_type = cmc$mt5698_xx) OR (controller_type = cmc$mt5680_xx) OR
                (controller_type = cmc$mt7221_2_s0);

          current_ch_is_system_device_ch :=
                (ch_element_p^.data_channel.number = system_device_channel.number) AND
                (ch_element_p^.data_channel.concurrent = system_device_channel.concurrent) AND
                (ch_element_p^.data_channel.port = system_device_channel.port) AND
                (ch_element_p^.data_channel.iou = system_device_iou);

          IF get_full_path AND current_ch_is_system_device_ch THEN
            EXIT /loop_thru_controllers/;
          IFEND;

          IF equip_state = cmc$on THEN
            number_of_controller_on := number_of_controller_on + 1;
          IFEND;

          { If the current controller is DOWN, need to go to the next controller on the channel and check
          { its state.

          IF get_full_path THEN
            IF (number_of_controller_on <> 0) OR (pen = UPPERVALUE (cmt$physical_equipment_number)) THEN
              total_resources := total_resources + 1;
              pp_resources_needed := (number_of_controller_on <> 0);
              setup_resources_table (total_resources, equip_element_p^.controller.peripheral_driver_name,
                    ch_iou_number, ch_element_p^.data_channel, cmc$null_equipment_number,
                    cmc$null_unit_number, pp_resources_needed, temp_table_p);
              table_setup := TRUE;
              EXIT /loop_thru_controllers/;
            ELSE
              CYCLE /loop_thru_controllers/;
            IFEND;
          IFEND;

          number_of_units_configured := 0;

        /loop_thru_units/
          FOR pun := LOWERVALUE (cmt$physical_unit_number) TO UPPERVALUE (cmt$physical_unit_number) DO
            IF NOT equip_element_p^.controller.connection.unit [pun].configured THEN
              CYCLE /loop_thru_units/;
            IFEND;

            IF ((current_ch_is_system_device_ch) AND (system_device_equipment = pen) AND
                  (system_device_unit = pun)) THEN
              CYCLE /loop_thru_units/;
            IFEND;

            cmp$pc_get_element (equip_element_p^.controller.connection.unit [pun].element_name,
                  {iou not used} osc$null_name, unit_element_p, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            cmp$get_element_state (unit_element_p^.element_name, osc$null_name, unit_state, status);
            IF (unit_state = cmc$on) OR (unit_state = cmc$down) THEN
              number_of_units_configured := number_of_units_configured + 1;
              total_resources := total_resources + 1;
              pp_resources_needed := (channel_state = cmc$on) AND (equip_state = cmc$on);
              setup_resources_table (total_resources, equip_element_p^.controller.peripheral_driver_name,
                    ch_iou_number, ch_element_p^.data_channel, pen, pun, pp_resources_needed, temp_table_p);
            IFEND;
          FOREND /loop_thru_units/;

          IF number_of_units_configured = 0 THEN
            total_resources := total_resources + 1;
            pp_resources_needed := (channel_state = cmc$on) AND (equip_state = cmc$on);
            setup_resources_table (total_resources, equip_element_p^.controller.peripheral_driver_name,
                  ch_iou_number, ch_element_p^.data_channel, cmc$null_equipment_number, cmc$null_unit_number,
                  pp_resources_needed, temp_table_p);
            EXIT /loop_thru_controllers/;
          IFEND;

        = cmc$external_processor_element =
          total_resources := total_resources + 1;
          pp_resources_needed := (channel_state = cmc$on) AND (equip_state = cmc$on);
          setup_resources_table (total_resources, equip_element_p^.external_processor.peripheral_driver_name,
                ch_iou_number, ch_element_p^.data_channel, cmc$null_equipment_number, cmc$null_unit_number,
                pp_resources_needed, temp_table_p);
          EXIT /loop_thru_controllers/;

        = cmc$storage_device_element =
          IF NOT ((ch_element_p^.data_channel.number = system_device_channel.number) AND
                (ch_element_p^.data_channel.concurrent = system_device_channel.concurrent) AND
                (ch_element_p^.data_channel.port = system_device_channel.port) AND
                (ch_element_p^.data_channel.iou = system_device_iou)) THEN

            cmp$get_unit_type (equip_element_p^.product_id, cm_unit_type, io_unit_type, unit_class, found);
            IF found THEN
              IF cm_unit_type = cmc$mshydra THEN
                total_resources := total_resources + 1;
                IF equip_state = cmc$down THEN
                  number_of_units_configured := 0;
                  FOR index_count := pen TO UPPERVALUE (cmt$physical_equipment_number) DO
                    IF ch_element_p^.data_channel.connection.equipment [index_count].configured THEN
                      cmp$get_element_state (ch_element_p^.data_channel.connection.equipment [index_count].
                            element_name, osc$null_name, unit_state, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;
                      IF unit_state = cmc$on THEN
                        number_of_units_configured := number_of_units_configured + 1;
                      IFEND;
                    IFEND;
                  FOREND;
                IFEND;
                pp_resources_needed := (channel_state = cmc$on) AND
                      ((equip_state = cmc$on) OR (number_of_units_configured > 0));
                setup_resources_table (total_resources, 'E9S887                         ', ch_iou_number,
                      ch_element_p^.data_channel, cmc$null_equipment_number, cmc$null_unit_number,
                      pp_resources_needed, temp_table_p);
                EXIT /loop_thru_controllers/;
              IFEND;
            ELSEIF io_unit_type = ioc$dt_foreign_device THEN
              EXIT /loop_thru_controllers/;
            IFEND;
          ELSE
            EXIT /loop_thru_controllers/;
          IFEND;
        ELSE
          ; { Do nothing for other type of elements }
        CASEND;
      FOREND /loop_thru_controllers/;

      IF get_full_path AND (NOT table_setup) AND (NOT current_ch_is_system_device_ch) THEN
        IF (number_of_controller_on <> 0) OR (pen = UPPERVALUE (cmt$physical_equipment_number)) THEN
          total_resources := total_resources + 1;
          pp_resources_needed := (number_of_controller_on <> 0);
          setup_resources_table (total_resources, equip_element_p^.controller.peripheral_driver_name,
                ch_iou_number, ch_element_p^.data_channel, cmc$null_equipment_number, cmc$null_unit_number,
                pp_resources_needed, temp_table_p);
        IFEND;
      IFEND;
    WHILEND /loop_thru_channels/;

    { Now sort table with disk subsystems first, then dual pp tape subsystems, then single PP subsystems,
    { then other subsystems.

    IF total_resources <= 0 THEN
      RETURN;
    IFEND;
    count := 0;

    ALLOCATE resources_assigned_p: [1 .. total_resources] IN osv$mainframe_pageable_heap^;
    pmp$zero_out_table (#LOC (resources_assigned_p^), #SIZE (resources_assigned_p^));

    { Process disk subsystems.

    FOR index_count := LOWERBOUND (resources_assigned_p^) TO UPPERBOUND (resources_assigned_p^) DO
      IF (temp_table_p^ [index_count].driver_name = 'DSKE') OR
            (temp_table_p^ [index_count].driver_name = 'E1C7155') OR
            (temp_table_p^ [index_count].driver_name = 'E1A7155') OR
            (temp_table_p^ [index_count].driver_name = 'E1I7255') OR
            (temp_table_p^ [index_count].driver_name = 'E5P5831') OR
            (temp_table_p^ [index_count].driver_name = 'E9P5831') OR
            (temp_table_p^ [index_count].driver_name = 'E9S887 ') OR
            (temp_table_p^ [index_count].driver_name = 'E9P9853') OR
            (temp_table_p^ [index_count].driver_name = 'E5P9836') OR
            (temp_table_p^ [index_count].driver_name = 'E2C7165') OR
            (temp_table_p^ [index_count].driver_name = 'E9A7165') THEN
        count := count + 1;
        resources_assigned_p^ [count] := temp_table_p^ [index_count];
        temp_table_p^ [index_count].assigned := TRUE;
        resources_assigned_p^ [count].assigned := FALSE;
      IFEND;
    FOREND;

    { Process dual PP tape subsystems followed by single PP tape subsystems.

    FOR index_count := LOWERBOUND (resources_assigned_p^) TO UPPERBOUND (resources_assigned_p^) DO
      IF (temp_table_p^ [index_count].driver_name = 'E2C7021') OR
            (temp_table_p^ [index_count].driver_name = 'E2A7021') OR
            (temp_table_p^ [index_count].driver_name = 'E1A7021') OR
            (temp_table_p^ [index_count].driver_name = 'E5P5698') OR
            (temp_table_p^ [index_count].driver_name = 'E2A5680') OR
            (temp_table_p^ [index_count].driver_name = 'E2C5680') OR
            (temp_table_p^ [index_count].driver_name = 'E9P5698') OR
            (temp_table_p^ [index_count].driver_name = 'E1C7021') OR
            (temp_table_p^ [index_count].driver_name = 'E5I9639') THEN
        count := count + 1;
        resources_assigned_p^ [count] := temp_table_p^ [index_count];
        temp_table_p^ [index_count].assigned := TRUE;
        resources_assigned_p^ [count].assigned := FALSE;
      IFEND;
    FOREND;

   { Process other subsystems.

    FOR index_count := LOWERBOUND (resources_assigned_p^) TO UPPERBOUND (resources_assigned_p^) DO
      IF (NOT temp_table_p^ [index_count].assigned) AND
            (temp_table_p^ [index_count].driver_name <> ' ') THEN
        count := count + 1;
        resources_assigned_p^ [count] := temp_table_p^ [index_count];
        temp_table_p^ [index_count].assigned := TRUE;
        resources_assigned_p^ [count].assigned := FALSE;
      IFEND;
    FOREND;

  PROCEND determine_resources;
?? OLDTITLE ??
?? NEWTITLE := 'free_tables', EJECT ??

{ PURPOSE:
{   This procedure frees the logical PP table and the logical unit table.

  PROCEDURE free_tables
    (VAR logical_pp_table_p: ^cmt$logical_pp_table;
     VAR logical_unit_table_p: ^cmt$logical_unit_table);

    VAR
      index: integer,
      pp_index: iot$pp_number;

    IF logical_pp_table_p <> NIL THEN
      FOR pp_index := LOWERBOUND (logical_pp_table_p^) TO UPPERBOUND (logical_pp_table_p^) DO
        IF logical_pp_table_p^ [pp_index].flags.configured THEN
          IF logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p <> NIL THEN
            FREE logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.response_buffer IN
                  osv$mainframe_wired_cb_heap^;
            FREE logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p IN osv$mainframe_wired_cb_heap^;
          IFEND;
          IF logical_pp_table_p^ [pp_index].pp_info.pp_communication_buffer_p <> NIL THEN
            FREE logical_pp_table_p^ [pp_index].pp_info.pp_communication_buffer_p IN
                  osv$mainframe_wired_cb_heap^;
          IFEND;
        IFEND;
      FOREND;
      FREE logical_pp_table_p IN osv$mainframe_wired_cb_heap^;
    IFEND;

    IF logical_unit_table_p <> NIL THEN
      FOR index := (cmc$job_template_unit_ordinal + 1) TO UPPERBOUND (logical_unit_table_p^) DO
        IF logical_unit_table_p^ [index].configured THEN
          IF logical_unit_table_p^ [index].unit_communication_buffer_pva <> NIL THEN
            FREE logical_unit_table_p^ [index].unit_communication_buffer_pva IN osv$mainframe_wired_cb_heap^;
          IFEND;
          IF logical_unit_table_p^ [index].unit_interface_table <> NIL THEN
            FREE logical_unit_table_p^ [index].unit_interface_table IN osv$mainframe_wired_cb_heap^;
          IFEND;
        IFEND;
      FOREND;
      FREE logical_unit_table_p IN osv$mainframe_wired_cb_heap^;
    IFEND;

  PROCEND free_tables;
?? OLDTITLE ??
?? NEWTITLE := 'generate_interface_tables', EJECT ??

{ PURPOSE:
{   This procedure scans the physical configuration table to determine the number of logical units and
{   logical pp entries required.  It then builds the Interface Tables to contain all PPs and Units
{   needed for the fully configured system.

  PROCEDURE generate_interface_tables
    (VAR status: ost$status);

    VAR
      cm_unit_type: cmt$unit_type,
      controller_type: cmt$controller_type,
      element_p: ^cmt$element_definition,
      found: boolean,
      io_unit_type: iot$unit_type,
      pc_index: integer,
      pen: cmt$physical_equipment_number,
      pp_count: iot$pp_number,
      two_pps_needed: boolean,
      unit_class: cmt$unit_class,
      unit_count: iot$logical_unit;

    status.normal := TRUE;

    pp_count := 0;
    unit_count := 0;

   /scan_table/
    FOR pc_index := 1 TO UPPERBOUND (cmv$physical_configuration^) DO
      CASE cmv$physical_configuration^ [pc_index].element_type OF
      = cmc$channel_adapter_element, cmc$communications_element, cmc$external_processor_element,
            cmc$storage_device_element =
        unit_count := unit_count + 1;

      = cmc$data_channel_element =
        IF ((cmv$physical_configuration^ [pc_index].data_channel.number >= 12) AND
              (cmv$physical_configuration^ [pc_index].data_channel.number <= 15)) OR
              ((cmv$physical_configuration^ [pc_index].data_channel.number > 25) AND
              cmv$physical_configuration^ [pc_index].data_channel.concurrent) THEN
          cmp$set_illegal_channel_status (cmv$physical_configuration^ [pc_index].data_channel.number,
                cme$pc_unsupported_channel, status);
          RETURN;
        IFEND;

        two_pps_needed := FALSE;
        FOR pen := LOWERVALUE (cmt$physical_equipment_number) TO UPPERVALUE (cmt$physical_equipment_number) DO
          IF cmv$physical_configuration^ [pc_index].data_channel.connection.equipment [pen].configured THEN
            cmp$pc_get_element (
                  cmv$physical_configuration^ [pc_index].data_channel.connection.equipment [pen].element_name,
                  osc$null_name, element_p, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            CASE element_p^.element_type OF
            = cmc$channel_adapter_element =
              IF element_p^.product_id.product_number = ' $2629' THEN
                CYCLE /scan_table/;
              IFEND;
            = cmc$communications_element =
              CYCLE /scan_table/;
            = cmc$controller_element =
              cmp$get_controller_type (element_p^.product_id, controller_type, status);
              IF NOT status.normal THEN
                status.normal := TRUE;
                CYCLE /scan_table/; { foreign device }
              IFEND;
              IF (element_p^.controller.peripheral_driver_name (2, 1) = '2') AND
                    (controller_type <> cmc$mt7221_2_s0) THEN
                two_pps_needed := TRUE;
              IFEND;
            = cmc$storage_device_element =
              cmp$get_unit_type (element_p^.product_id, cm_unit_type, io_unit_type, unit_class, found);
              IF NOT found THEN
                CYCLE /scan_table/;
              IFEND;
            ELSE
            CASEND;
          IFEND;
        FOREND;
        pp_count := pp_count + 1;
        IF two_pps_needed THEN
          pp_count := pp_count + 1;
        IFEND;

      ELSE
      CASEND;
    FOREND /scan_table/;

    cmp$build_interface_tables (pp_count, unit_count, TRUE, cmv$new_logical_unit_table,
          cmv$new_logical_pp_table_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND generate_interface_tables;
?? OLDTITLE ??
?? NEWTITLE := 'load_all_other_drivers', EJECT ??

{ PURPOSE:
{   Search the logical PP table and load drivers for all channels which have been assigned.  This routine is
{   called during PCU activating the configuration.
{ DESIGN:
{   The system device driver is not loaded since it is still loaded from the deadstart process.

  PROCEDURE load_all_other_drivers
    (    system_device_channel: cmt$physical_channel;
     VAR system_device_iou: dst$iou_number;
     VAR status: ost$status);

    VAR
      partner_pp_index: iot$pp_number,
      pp_index: iot$pp_number,
      system_device_ch_type: dst$channel_protocol_type;

    status.normal := TRUE;

    IF system_device_channel.concurrent THEN
      system_device_ch_type := dsc$cpt_cio;
    ELSE
      system_device_ch_type := dsc$cpt_nio;
    IFEND;

   /table_loop/
    FOR pp_index := LOWERBOUND (cmv$new_logical_pp_table_p^) TO UPPERBOUND (cmv$new_logical_pp_table_p^) DO
      IF NOT cmv$new_logical_pp_table_p^ [pp_index].flags.configured OR
            NOT cmv$new_logical_pp_table_p^ [pp_index].flags.resources_acquired OR
            cmv$new_logical_pp_table_p^ [pp_index].flags.pp_loaded OR
            (cmv$new_logical_pp_table_p^ [pp_index].pp_info.driver_name = ' ') THEN
        CYCLE /table_loop/;
      IFEND;

      IF (system_device_channel.number = cmv$new_logical_pp_table_p^ [pp_index].pp_info.channel.number) AND
            (system_device_ch_type =
            cmv$new_logical_pp_table_p^ [pp_index].pp_info.channel.channel_protocol) AND
            (system_device_iou = cmv$new_logical_pp_table_p^ [pp_index].pp_info.channel.iou_number) THEN
        CYCLE /table_loop/;
      IFEND;

      dsp$load_pp (dsc$load_pp_by_name, cmv$new_logical_pp_table_p^ [pp_index].pp_info.physical_pp,
            NIL, cmv$new_logical_pp_table_p^ [pp_index].pp_info.cip_driver_name,
            cmv$new_logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_rma, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      cmv$new_logical_pp_table_p^ [pp_index].flags.pp_loaded := TRUE;

      partner_pp_index := cmv$new_logical_pp_table_p^ [pp_index].pp_info.logical_partner_pp_index;
      IF partner_pp_index > 0 THEN
        dsp$load_pp (dsc$load_pp_by_name, cmv$new_logical_pp_table_p^ [partner_pp_index].pp_info.physical_pp,
              NIL, cmv$new_logical_pp_table_p^ [pp_index].pp_info.cip_driver_name,
              cmv$new_logical_pp_table_p^ [pp_index].pp_info.pp_communication_buffer_p^.partner_pp, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        cmv$new_logical_pp_table_p^ [partner_pp_index].flags.pp_loaded := TRUE;
      IFEND;
    FOREND /table_loop/;

  PROCEND load_all_other_drivers;
?? OLDTITLE ??
?? NEWTITLE := 'modify_interface_pointer', EJECT ??

{ PURPOSE:
{   This procedure modifies the unit interface table RMA of the system device to reference the RMA used
{   at System core time.

  PROCEDURE modify_interface_pointer
    (VAR status: ost$status);

    VAR
      first_lun: iot$logical_unit,
      last_lun: iot$logical_unit,
      pp: iot$pp_number;

    IF (cmv$logical_pp_table_p = NIL) OR (cmv$logical_unit_table = NIL) OR
          (cmv$new_logical_pp_table_p = NIL) OR (cmv$new_logical_unit_table = NIL) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_nil_cm_table, 'NIL CM table', status);
      RETURN;
    IFEND;

    { Modify new tables to use the system device unit interface table.

    FREE cmv$new_logical_unit_table^ [cmc$job_template_unit_ordinal].unit_interface_table IN
          osv$mainframe_wired_cb_heap^;
    FREE cmv$new_logical_unit_table^ [cmc$job_template_unit_ordinal].unit_communication_buffer_pva IN
          osv$mainframe_wired_cb_heap^;
    cmv$new_logical_unit_table^ [cmc$job_template_unit_ordinal].unit_interface_table :=
          v$save_lut_p^ [cmc$job_template_unit_ordinal].unit_interface_table;
    cmv$new_logical_unit_table^ [cmc$job_template_unit_ordinal].unit_communication_buffer_pva :=
          v$save_lut_p^ [cmc$job_template_unit_ordinal].unit_communication_buffer_pva;

    FOR pp := LOWERBOUND (cmv$new_logical_pp_table_p^) TO UPPERBOUND (cmv$new_logical_pp_table_p^) DO
      IF cmv$new_logical_pp_table_p^ [pp].flags.configured THEN
        first_lun := cmv$new_logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.first_logical_unit;
        last_lun := cmv$new_logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.number_of_units +
              first_lun;

        IF (cmc$job_template_unit_ordinal >= first_lun) AND (cmc$job_template_unit_ordinal <= last_lun) THEN

          { Change unit interface table pointers.

          cmv$new_logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                unit_descriptors [cmc$job_template_unit_ordinal].unit_interface_table :=
                v$save_lpt_p^ [1].pp_info.pp_interface_table_p^.
                unit_descriptors [cmc$job_template_unit_ordinal].unit_interface_table;

          IF (cmv$new_logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                unit_descriptors [cmc$job_template_unit_ordinal].unit_interface_table_rma <> 0) THEN
            cmv$new_logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                  unit_descriptors [cmc$job_template_unit_ordinal].unit_interface_table_rma :=
                  v$save_lpt_p^ [1].pp_info.pp_interface_table_p^.
                  unit_descriptors [cmc$job_template_unit_ordinal].unit_interface_table_rma;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND modify_interface_pointer;
?? OLDTITLE ??
?? NEWTITLE := 'obtain_pp_resource', EJECT ??

{ PURPOSE:
{   Obtain a PP which can access the given channel number and also the correct channel and/or equipment.
{   This routine is called during PCU activating the configuration.
{ DESIGN:
{   The drivers are not loaded here to make clean up easier in the case where all resources cannot be obtained
{   for some reason, i.e. the resources are not available to NOS/VE in dual state.

  PROCEDURE obtain_pp_resource
    (    resource_assigned: t$resources_assigned;
     VAR status: ost$status);

    VAR
      channel_name: cmt$element_name,
      channel_ordinal: cmt$channel_ordinal,
      channel_state: cmt$element_state,
      channel_type: dst$channel_protocol_type,
      iou_name: cmt$element_name,
      partner_pp_index: iot$pp_number,
      pp_index: iot$pp_number,
      pp_needed: boolean,
      redundant: boolean,
      resource_request: dst$resource_request,
      system_device_channel: cmt$physical_channel,
      system_device_equipment: cmt$physical_equipment_number,
      system_device_iou: cmt$element_name,
      system_device_unit: cmt$physical_unit_number,
      valid_channel: boolean;

    status.normal := TRUE;

    IF resource_assigned.channel.concurrent THEN
      channel_type := dsc$cpt_cio;
    ELSE
      channel_type := dsc$cpt_nio;
    IFEND;

    cmp$retrieve_logical_pp_index (resource_assigned.channel, resource_assigned.iou_number,
          cmv$new_logical_pp_table_p, pp_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pp_needed := NOT cmv$new_logical_pp_table_p^ [pp_index].flags.resources_acquired;

    partner_pp_index := cmv$new_logical_pp_table_p^ [pp_index].pp_info.logical_partner_pp_index;

    cmp$convert_iou_number (resource_assigned.iou_number, iou_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$get_system_device_path (cmc$sdt_disk_device, system_device_iou, system_device_channel,
          system_device_equipment, system_device_unit, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pp_needed THEN
      pp_needed := NOT ((resource_assigned.channel.number = system_device_channel.number) AND
            (resource_assigned.channel.concurrent = system_device_channel.concurrent) AND
            (iou_name = system_device_iou));
    IFEND;

    { For redundant tape channels, the pp_needed will be set to FALSE to prevent obtaining a PP until the
    { channel is actually used.

    IF pp_needed AND (cmv$new_logical_pp_table_p^ [pp_index].pp_info.pp_type = cmc$lpt_tape_pp_type) THEN
      IF (cmv$new_logical_pp_table_p^ [pp_index].pp_info.cip_driver_name = 'TAPC') OR
            (cmv$new_logical_pp_table_p^ [pp_index].pp_info.cip_driver_name = 'TAPD') OR
            (cmv$new_logical_pp_table_p^ [pp_index].pp_info.cip_driver_name = 'E9Q5698') OR
            (cmv$new_logical_pp_table_p^ [pp_index].pp_info.cip_driver_name = 'E2X5680') THEN
        cmp$determine_redundant_channel (resource_assigned.channel, resource_assigned.iou_number,
              {ignore_state=}FALSE, redundant, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        pp_needed := NOT redundant;
      IFEND;
    IFEND;

    { IF auto reconfiguration is disabled then the allocation of PP's to redundant disk channels will
    { be prevented in the same way as the tape channels.

    IF NOT cmv$acquire_pp_for_redundant_ch AND pp_needed AND
          (cmv$new_logical_pp_table_p^ [pp_index].pp_info.pp_type = cmc$lpt_disk_pp_type) THEN
      IF (cmv$new_logical_pp_table_p^ [pp_index].pp_info.cip_driver_name = 'ISD') OR
            (cmv$new_logical_pp_table_p^ [pp_index].pp_info.cip_driver_name = 'DSK7154') OR
            (cmv$new_logical_pp_table_p^ [pp_index].pp_info.cip_driver_name = 'DSKI') OR
            (cmv$new_logical_pp_table_p^ [pp_index].pp_info.cip_driver_name = 'E9P9853') OR
            (cmv$new_logical_pp_table_p^ [pp_index].pp_info.cip_driver_name = 'DSK55A') OR
            (cmv$new_logical_pp_table_p^ [pp_index].pp_info.cip_driver_name = 'DSK55C7') OR
            (cmv$new_logical_pp_table_p^ [pp_index].pp_info.cip_driver_name = 'E5P5831') OR
            (cmv$new_logical_pp_table_p^ [pp_index].pp_info.cip_driver_name = 'E9P5831') then
        cmp$determine_redundant_channel (resource_assigned.channel, resource_assigned.iou_number,
              {ignore_state=}FALSE, redundant, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        pp_needed := NOT redundant;
      IFEND;
    IFEND;

    resource_request.channel.iou_number := resource_assigned.iou_number;
    resource_request.channel.channel_protocol := channel_type;
    resource_request.channel.number := resource_assigned.channel.number;

    IF ((resource_assigned.unit = cmc$null_unit_number) AND
          (resource_assigned.equipment = cmc$null_equipment_number)) THEN
      cmp$request_resources (dsc$rrt_get_channel, resource_request, status);
      IF NOT status.normal AND ((status.condition <> dse$resource_already_assigned) AND
            (status.condition <> dse$ch_assigned_to_ve)) THEN
        RETURN;
      IFEND;
    ELSE
      resource_request.equipment_number := ORD (resource_assigned.equipment);
      resource_request.unit_number := ORD (resource_assigned.unit);
      cmp$request_resources (dsc$rrt_get_equipment, resource_request, status);
      IF NOT status.normal AND ((status.condition <> dse$resource_already_assigned) AND
            (status.condition <> dse$ch_assigned_to_ve)) THEN
        RETURN;
      IFEND;
      cmp$request_resources (dsc$rrt_get_channel, resource_request, status);
      IF NOT status.normal AND ((status.condition <> dse$resource_already_assigned) AND
            (status.condition <> dse$ch_assigned_to_ve)) THEN
        RETURN;
      IFEND;
    IFEND;

    cmp$convert_channel_number (resource_assigned.channel.number, resource_assigned.channel.concurrent,
          resource_assigned.channel.port, channel_ordinal, channel_name, valid_channel);

    cmp$get_element_state (channel_name, iou_name, channel_state, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pp_needed AND (channel_state = cmc$on) THEN
      IF partner_pp_index > 0 THEN
        resource_request.options := $dst$resource_request_options [dsc$rro_partner_pp];
      ELSEIF channel_type = dsc$cpt_nio THEN
        resource_request.options := $dst$resource_request_options [dsc$rro_driver_pp];
      ELSE
        resource_request.options := $dst$resource_request_options [];
      IFEND;
      cmp$request_resources (dsc$rrt_get_pp, resource_request, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      cmv$new_logical_pp_table_p^ [pp_index].pp_info.physical_pp := resource_request.primary_pp;
      cmv$new_logical_pp_table_p^ [pp_index].flags.resources_acquired := TRUE;
      IF partner_pp_index > 0 THEN
        cmv$new_logical_pp_table_p^ [partner_pp_index].pp_info.physical_pp := resource_request.secondary_pp;
        cmv$new_logical_pp_table_p^ [partner_pp_index].flags.resources_acquired := TRUE;
      IFEND;
    IFEND;

  PROCEND obtain_pp_resource;
?? OLDTITLE ??
?? NEWTITLE := 'release_all_resources', EJECT ??

{ PURPOSE:
{   This procedure releases all the resources acquired. This routine is called if an error such as
{   channel/equipment not available occurs during configuration activation.

  PROCEDURE release_all_resources
    (VAR resources_assigned_p: ^ARRAY [ * ] OF t$resources_assigned);

    VAR
      channel_type: dst$channel_protocol_type,
      controller_type: cmt$controller_type,
      dual_access: boolean,
      index: integer,
      local_status: ost$status,
      other_channel: cmt$physical_channel,
      other_channel_iou: dst$iou_number,
      other_eq: cmt$physical_equipment_number,
      pp_index: iot$pp_number,
      system_device_channel: cmt$physical_channel,
      system_device_equipment: cmt$physical_equipment_number,
      system_device_iou: cmt$element_name,
      system_device_iou_number: dst$iou_number,
      system_device_unit: cmt$physical_unit_number,
      table_index: integer;

    IF resources_assigned_p = NIL THEN
      RETURN;
    IFEND;

    cmp$get_system_device_path (cmc$sdt_disk_device, system_device_iou, system_device_channel,
          system_device_equipment, system_device_unit, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    verify_dual_access (system_device_iou, system_device_channel, system_device_equipment,
          system_device_unit, dual_access, other_channel, other_channel_iou, other_eq, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    cmp$convert_iou_name (system_device_iou, system_device_iou_number, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

   /return_channels/
    FOR index := LOWERBOUND (resources_assigned_p^) TO UPPERBOUND (resources_assigned_p^) DO
      IF NOT resources_assigned_p^ [index].assigned THEN
        CYCLE /return_channels/;
      IFEND;

      IF resources_assigned_p^ [index].equipment = cmc$null_equipment_number THEN
        IF (resources_assigned_p^ [index].channel.number = system_device_channel.number) AND
              (resources_assigned_p^ [index].channel.concurrent = system_device_channel.concurrent) AND
              (resources_assigned_p^ [index].iou_number = system_device_iou_number) THEN
          CYCLE /return_channels/;
        IFEND;

        cmp$release_channel_resource (resources_assigned_p^ [index].channel,
              resources_assigned_p^ [index].iou_number, local_status);
      ELSE

        { Do not release system_device equipment.

        IF (resources_assigned_p^ [index].channel = system_device_channel) AND
              (resources_assigned_p^ [index].iou_number = system_device_iou_number) AND
              (resources_assigned_p^ [index].equipment = system_device_equipment) AND
              (resources_assigned_p^ [index].unit = system_device_unit) THEN
          CYCLE /return_channels/;
        IFEND;

        { Do not release alternate path to system device.

        IF dual_access AND (resources_assigned_p^ [index].channel = other_channel) AND
              (resources_assigned_p^ [index].iou_number = other_channel_iou) AND
              (resources_assigned_p^ [index].equipment = other_eq) AND
              (resources_assigned_p^ [index].unit = system_device_unit) THEN
          CYCLE /return_channels/;
        IFEND;

        cmp$release_equipment_resource (resources_assigned_p^ [index].channel,
              resources_assigned_p^ [index].iou_number, resources_assigned_p^ [index].equipment,
              resources_assigned_p^ [index].unit);
      IFEND;
    FOREND /return_channels/;
    FREE resources_assigned_p IN osv$mainframe_pageable_heap^;

    { Now return all PPs.

    IF system_device_channel.concurrent THEN
      channel_type := dsc$cpt_cio;
    ELSE
      channel_type := dsc$cpt_nio;
    IFEND;

   /table_loop/
    FOR pp_index := LOWERBOUND (cmv$new_logical_pp_table_p^) TO UPPERBOUND (cmv$new_logical_pp_table_p^) DO
      IF NOT cmv$new_logical_pp_table_p^ [pp_index].flags.configured OR
            NOT cmv$new_logical_pp_table_p^ [pp_index].flags.resources_acquired THEN
        CYCLE /table_loop/;
      IFEND;
      IF (system_device_channel.number = cmv$new_logical_pp_table_p^ [pp_index].pp_info.channel.number) AND
            (channel_type = cmv$new_logical_pp_table_p^ [pp_index].pp_info.channel.channel_protocol) AND
            (system_device_iou_number =
                  cmv$new_logical_pp_table_p^ [pp_index].pp_info.channel.iou_number) THEN
        CYCLE /table_loop/;
      IFEND;
      cmp$release_pp_resource (cmv$new_logical_pp_table_p^ [pp_index].pp_info.physical_pp, local_status);
    FOREND /table_loop/;

    { Free all allocated tables.

    IF cmv$physical_configuration <> NIL THEN
      FREE cmv$physical_configuration IN osv$mainframe_pageable_heap^;
    IFEND;

    IF cmv$state_info_table <> NIL THEN
      FOR table_index := LOWERBOUND (cmv$state_info_table^) TO UPPERBOUND (cmv$state_info_table^) DO
        IF cmv$state_info_table^ [table_index].element_type <> cmc$data_channel_element THEN
          IF cmv$state_info_table^ [table_index].application_info_p <> NIL THEN
            FREE cmv$state_info_table^ [table_index].application_info_p IN osv$mainframe_pageable_heap^;
          IFEND;
          IF cmv$state_info_table^ [table_index].site_info_p <> NIL THEN
            FREE cmv$state_info_table^ [table_index].site_info_p IN osv$mainframe_pageable_heap^;
          IFEND;
        IFEND;
      FOREND;
      FREE cmv$state_info_table IN osv$mainframe_pageable_heap^;
    IFEND;

    cmv$physical_configuration := cmv$save_pct_p;
    cmv$state_info_table := cmv$save_state_table_p;

    free_tables (cmv$new_logical_pp_table_p, cmv$new_logical_unit_table);

  { FOR controller_type := LOWERVALUE (cmt$controller_type) TO UPPERVALUE (cmt$controller_type) DO
  {   IF cmv$controller_location [controller_type].controlware_loaded THEN
  {     FREE cmv$controller_location [controller_type].controlware_rma_list_p IN osv$mainframe_wired_cb_heap^;
  {     FREE cmv$controller_location [controller_type].controlware_location_p IN osv$mainframe_wired_cb_heap^;
  {     cmv$controller_location [controller_type].controlware_loaded := FALSE;
  {   IFEND;
  {   IF cmv$controller_location [controller_type].control_module_loaded THEN
  {     FREE cmv$controller_location [controller_type].control_module_rma_list_p IN
  {           osv$mainframe_wired_cb_heap^;
  {     FREE cmv$controller_location [controller_type].control_module_location_p IN
  {           osv$mainframe_wired_cb_heap^;
  {     cmv$controller_location [controller_type].control_module_loaded := FALSE;
  {   IFEND;
  { FOREND;
  { cmp$free_element_def_table;

  PROCEND release_all_resources;
?? OLDTITLE ??
?? NEWTITLE := 'setup_resources_table', EJECT ??

{ PURPOSE:
{   This procedure builds the resources table to be used for acquiring and releasing channel/equipment/unit.

  PROCEDURE setup_resources_table
    (    table_index: integer;
         driver_name: cmt$element_name;
         ch_iou_number: dst$iou_number;
         channel: cmt$data_channel_definition;
         equipment: 0 .. cmc$null_equipment_number;
         unit: 0 .. cmc$null_unit_number;
         pp_resources_needed: boolean;
     VAR resources_table_p: ^ARRAY [ * ] OF t$resources_assigned);

    IF resources_table_p = NIL THEN
      RETURN;
    IFEND;

    IF table_index > UPPERBOUND (resources_table_p^) THEN
      RETURN;
    IFEND;

    resources_table_p^ [table_index].driver_name := driver_name;
    resources_table_p^ [table_index].channel.concurrent := channel.concurrent;
    resources_table_p^ [table_index].channel.number := channel.number;
    resources_table_p^ [table_index].channel.port := channel.port;
    resources_table_p^ [table_index].iou_number := ch_iou_number;
    resources_table_p^ [table_index].equipment := equipment;
    resources_table_p^ [table_index].unit := unit;
    resources_table_p^ [table_index].pp_resources_needed := pp_resources_needed;

  PROCEND setup_resources_table;
?? OLDTITLE ??
?? NEWTITLE := 'verify_dual_access', EJECT ??

{ PURPOSE:
{   This procedure determines if the system device is dual access.  If so, then during release_all_resources,
{   do not return the system device.

  PROCEDURE verify_dual_access
    (    system_device_iou: cmt$element_name;
         system_device_channel: cmt$physical_channel;
         system_device_equipment: cmt$physical_equipment_number;
         system_device_unit: cmt$physical_unit_number;
     VAR dual_access: boolean;
     VAR other_channel: cmt$physical_channel;
     VAR other_channel_iou: dst$iou_number;
     VAR other_eq: cmt$physical_equipment_number;
     VAR status: ost$status);

    VAR
      ch_element_p: ^cmt$element_definition,
      ch_port: cmt$controller_port_number,
      ct_element_p: ^cmt$element_definition,
      element_p: ^cmt$element_definition,
      index: integer,
      iou_name: cmt$element_name,
      port: cmt$data_storage_port_number,
      system_device_name: cmt$element_name,
      system_device_controller: cmt$element_name;

    { This procedure check to see if there is more than one path to the system disk. If so then it returns
    { the physical address of the path, channel number and equipment number.

    status.normal := TRUE;
    dual_access := FALSE;

  /loop_thru_pc/
    FOR index := LOWERBOUND (cmv$physical_configuration^) TO UPPERBOUND (cmv$physical_configuration^) DO
      IF cmv$physical_configuration^ [index].element_type <> cmc$data_channel_element THEN
        CYCLE /loop_thru_pc/;
      IFEND;

      IF (cmv$physical_configuration^ [index].data_channel.number = system_device_channel.number) AND
            (cmv$physical_configuration^ [index].data_channel.port = system_device_channel.port) AND
            (cmv$physical_configuration^ [index].data_channel.concurrent =
            system_device_channel.concurrent) AND
            (cmv$physical_configuration^ [index].data_channel.iou = system_device_iou) THEN

        IF cmv$physical_configuration^ [index].data_channel.connection.equipment [system_device_equipment].
              configured THEN
          cmp$pc_get_element (cmv$physical_configuration^ [index].
                data_channel.connection.equipment [system_device_equipment].element_name,
                {iou not used} osc$null_name, element_p, status);
          IF status.normal THEN

            { Find the system disk name.

            IF element_p^.element_type = cmc$controller_element THEN
              IF element_p^.controller.connection.unit [system_device_unit].configured THEN
                system_device_controller := element_p^.element_name;
                system_device_name := element_p^.controller.connection.unit [system_device_unit].element_name;
                EXIT /loop_thru_pc/;
              IFEND;
            ELSE
              system_device_name := element_p^.element_name;
            IFEND;
          IFEND;
        ELSEIF cmv$physical_configuration^ [index].data_channel.connection.equipment [system_device_unit].
              configured THEN
          system_device_name := cmv$physical_configuration^ [index].
                data_channel.connection.equipment [system_device_unit].element_name;
          EXIT /loop_thru_pc/;
        IFEND;
      IFEND;
    FOREND /loop_thru_pc/;

    cmp$pc_get_element (system_device_name, {iou not used} osc$null_name, element_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /loop_thru_ports/
    FOR port := LOWERVALUE (cmt$data_storage_port_number) TO UPPERVALUE (cmt$data_storage_port_number) DO
      IF NOT element_p^.storage_device.connection.port [port].configured THEN
        CYCLE /loop_thru_ports/;
      IFEND;

      IF element_p^.storage_device.connection.port [port].upline_connection_type =
            cmc$data_channel_element THEN
        iou_name := element_p^.storage_device.connection.port [port].iou;
      ELSE
        iou_name := osc$null_name;
      IFEND;

      cmp$pc_get_element (element_p^.storage_device.connection.port [port].element_name, iou_name,
            ct_element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF ct_element_p^.element_type = cmc$controller_element THEN
        IF ct_element_p^.element_name <> system_device_controller THEN

          { Could be dual access.

          other_eq := ct_element_p^.controller.physical_equipment_number;
          FOR ch_port := LOWERVALUE (cmt$controller_port_number)
                TO UPPERVALUE (cmt$controller_port_number) DO
            IF ct_element_p^.controller.connection.port [ch_port].configured THEN
              cmp$pc_get_element (ct_element_p^.controller.connection.port [ch_port].element_name,
                    ct_element_p^.controller.connection.port [ch_port].iou, ch_element_p, status);
              IF status.normal THEN
                IF NOT (ch_element_p^.data_channel.number = system_device_channel.number) AND
                      (ch_element_p^.data_channel.concurrent = system_device_channel.concurrent) AND
                      (ch_element_p^.data_channel.port = system_device_channel.port) AND
                      (ch_element_p^.data_channel.iou = system_device_iou) THEN
                  dual_access := TRUE;
                  other_channel.number := ch_element_p^.data_channel.number;
                  other_channel.port := ch_element_p^.data_channel.port;
                  other_channel.concurrent := ch_element_p^.data_channel.concurrent;
                  cmp$convert_iou_name (ch_element_p^.data_channel.iou, other_channel_iou, status);
                  RETURN;
                IFEND;
              IFEND;
            IFEND;
          FOREND;
        IFEND;
      ELSEIF ct_element_p^.element_type = cmc$data_channel_element THEN

        IF NOT (ct_element_p^.data_channel.number = system_device_channel.number) AND
              (ct_element_p^.data_channel.concurrent = system_device_channel.concurrent) AND
              (ct_element_p^.data_channel.port = system_device_channel.port) AND
              (ct_element_p^.data_channel.iou = system_device_iou) THEN
          dual_access := TRUE;
          other_channel.number := ct_element_p^.data_channel.number;
          other_channel.concurrent := ct_element_p^.data_channel.concurrent;
          other_channel.number := ct_element_p^.data_channel.number;
          cmp$convert_iou_name (ct_element_p^.data_channel.iou, other_channel_iou, status);
          RETURN;
        IFEND;
      IFEND;
    FOREND /loop_thru_ports/;

  PROCEND verify_dual_access;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$acquire_all_peripherals_r1', EJECT ??

{ PURPOSE:
{   This procedure determines how many IOU resources to acquire, builds the I/O interface tables and
{   activates the full configuration.

  PROCEDURE [XDCL, #GATE] cmp$acquire_all_peripherals_r1
    (VAR status: ost$status);

    VAR
      mainframe_id: pmt$mainframe_id,
      resources_assigned_p: ^ARRAY [ * ] OF t$resources_assigned,
      system_device_lun: iot$logical_unit;

    status.normal := TRUE;
    resources_assigned_p := NIL;

    system_device_lun := cmc$job_template_unit_ordinal;

    syp$trace_deadstart_message ('activating the configuration');

    determine_resources (resources_assigned_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Build the pp interface tables and request the other resources needed.

   /release_resources_on_error/
    BEGIN
      v$save_lut_p := cmv$logical_unit_table;
      v$save_lpt_p := cmv$logical_pp_table_p;

      generate_interface_tables (status);
      IF NOT status.normal THEN
        EXIT /release_resources_on_error/;
      IFEND;

      acquire_all_resources (resources_assigned_p, status);
      IF NOT status.normal THEN
        EXIT /release_resources_on_error/;
      IFEND;

      pmp$get_mainframe_id (mainframe_id, status);
      cmp$build_element_def_table (mainframe_id, status);
      IF NOT status.normal THEN
        EXIT /release_resources_on_error/;
      IFEND;

      iop$tape_initialization (cmv$new_logical_unit_table, status);
      IF NOT status.normal THEN
        EXIT /release_resources_on_error/;
      IFEND;

      modify_interface_pointer (status);
      IF NOT status.normal THEN
        EXIT /release_resources_on_error/;
      IFEND;

      begin_conf_transition (system_device_lun, resources_assigned_p, status);
      IF NOT status.normal THEN
        EXIT /release_resources_on_error/;
      IFEND;
    END /release_resources_on_error/;

    IF NOT status.normal THEN
      release_all_resources (resources_assigned_p);
      cmv$logical_unit_table := v$save_lut_p;
      cmv$logical_pp_table_p := v$save_lpt_p;
      cmp$get_max_number_of_pp (cmv$max_number_of_pp);
      RETURN;
    IFEND;

    { Release the original tables.

    free_tables (v$save_lpt_p, v$save_lut_p);

    cmp$update_connection_states_r1 (mainframe_id, status);

  PROCEND cmp$acquire_all_peripherals_r1;
?? OLDTITLE ??
?? NEWTITLE :='cmp$activate_signal_handler', EJECT ??

{ PURPOSE:
{   This procedure simply sets the variable cmv$signal_handler_active to TRUE.  When this variable is set to
{   FALSE all CM signals are queued for future processing.  When TRUE, CM signals are processed immediatly.

  PROCEDURE [XDCL, #GATE] cmp$activate_signal_handler;

    cmv$signal_handler_active := TRUE;

  PROCEND cmp$activate_signal_handler;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$free_deadstart_signals', EJECT ??

{ PURPOSE:
{   This procedure frees the space used by the linked list pointed to by the variable cmv$deadstart_signals.

  PROCEDURE [XDCL, #GATE] cmp$free_deadstart_signals;

    VAR
      deadstart_signal_p: ^cmt$deadstart_signal,
      next_deadstart_signal_p: ^cmt$deadstart_signal;

    IF cmv$deadstart_signals = NIL THEN
      RETURN;
    IFEND;

    deadstart_signal_p := cmv$deadstart_signals;
    WHILE deadstart_signal_p <> NIL DO
      next_deadstart_signal_p := deadstart_signal_p^.next_signal;

      FREE deadstart_signal_p IN osv$mainframe_pageable_heap^;
      deadstart_signal_p := next_deadstart_signal_p;
    WHILEND;

  PROCEND cmp$free_deadstart_signals;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_system_device_path', EJECT ??

{ PURPOSE:
{   This procedure returns the physical path of the system device.
{ DESIGN:
{   The system device path is determined from cmv$system_device_data.

  PROCEDURE [XDCL, #GATE] cmp$get_system_device_path
    (    device: cmt$system_device_types;
     VAR iou: cmt$element_name;
     VAR channel: cmt$physical_channel;
     VAR equipment_number: cmt$physical_equipment_number;
     VAR unit_number: cmt$physical_unit_number;
     VAR status: ost$status);

    VAR
      channel_descriptor: cmt$channel_descriptor,
      channel_definition: cmt$data_channel_definition,
      cm_unit_type: cmt$unit_type,
      found: boolean,
      io_unit_type: iot$unit_type,
      unit_class: cmt$unit_class;

    status.normal := TRUE;

    cmp$convert_iou_number (cmv$system_device_data [device].iou_number, iou, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    channel_descriptor.iou := iou;
    channel_descriptor.use_logical_identification := TRUE;
    channel_descriptor.name := cmv$system_device_data [device].channel_name;
    cmp$get_channel_def (channel_descriptor, channel_definition, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    channel.number := channel_definition.number;
    channel.concurrent := channel_definition.concurrent;
    channel.port := channel_definition.port;

    cmp$get_unit_type (cmv$system_device_data [device].unit_id, cm_unit_type, io_unit_type, unit_class,
          found);

    IF found AND (cm_unit_type = cmc$mshydra) THEN
      equipment_number := cmv$system_device_data [device].unit_number;
    ELSE
      equipment_number := cmv$system_device_data [device].equipment_number;
    IFEND;
    unit_number := cmv$system_device_data [device].unit_number;

  PROCEND cmp$get_system_device_path;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$queue_deadstart_signal', EJECT ??

{ PURPOSE:
{   This procedure will add the specified signal to a linked list of "deadstart" signals.  These signals are
{   actually executed by the routine cmp$process_deadstart_signals.  They are released by the procedure
{   cmp$free_deadstart_signals.

  PROCEDURE [XDCL, #GATE] cmp$queue_deadstart_signal
    (    originator: ost$global_task_id;
         signal: pmt$signal);

    VAR
      deadstart_signal_p: ^cmt$deadstart_signal,
      temp_deadstart_signal_p: ^cmt$deadstart_signal;

    ALLOCATE deadstart_signal_p IN osv$mainframe_pageable_heap^;
    deadstart_signal_p^.originator := originator;
    deadstart_signal_p^.signal := signal;
    deadstart_signal_p^.next_signal := NIL;

    IF cmv$deadstart_signals = NIL THEN
      cmv$deadstart_signals := deadstart_signal_p;
      RETURN;
    IFEND;

    temp_deadstart_signal_p := cmv$deadstart_signals;
    WHILE temp_deadstart_signal_p^.next_signal <> NIL DO
      temp_deadstart_signal_p := temp_deadstart_signal_p^.next_signal;
    WHILEND;

    temp_deadstart_signal_p^.next_signal := deadstart_signal_p;

  PROCEND cmp$queue_deadstart_signal;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$set_active_flag', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$set_active_flag
    (    configuration_state: boolean);

    cmv$configuration_activated := configuration_state;

  PROCEND cmp$set_active_flag;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$set_post_ds_flag', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$set_post_ds_flag;

    VAR
     iov$post_deadstart: [XREF] boolean,
     mmv$post_deadstart: [XREF] boolean;

    cmv$post_deadstart := TRUE;
    mmv$post_deadstart := TRUE;
    iov$post_deadstart := TRUE;

  PROCEND cmp$set_post_ds_flag;
?? OLDTITLE ??
MODEND cmm$pcu_ring1_helper;
*DECK DECK=CMM$PHYSICAL_CONFIGURATION_MGR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE CM : Physical Configuration manager' ??
MODULE cmm$physical_configuration_mgr;

{ PURPOSE:

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cme$logical_configuration_mgr
*copyc cme$physical_configuration_mgr
*copyc cmc$default_vsn
*copyc cmc$logical_conf_dev_file_name
*copyc cmc$logical_unit_constants
*copyc cmc$physical_conf_dev_file_name
*copyc cmk$keypoints
*copyc cmt$controller_type
*copyc cmt$device_file_table
*copyc cmt$element_definition
*copyc cmt$element_name
*copyc cmt$physical_configuration
*copyc cmt$sci_dft_pp
*copyc cmt$state_information
*copyc cmt$unit_type
*copyc oss$mainframe_paged_literal
*copyc ost$signature_lock
?? POP ??
*copyc clp$convert_integer_to_string
*copyc cmp$convert_iou_name
*copyc cmp$get_channel_def
*copyc cmp$set_product_id_status
*copyc cmp$valid_channel_name
*copyc dmp$search_active_volume_table
*copyc dsp$read_channel_states
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc cmv$controller_data
*copyc cmv$system_device_pp
*copyc dmv$active_volume_table
*copyc osv$mainframe_pageable_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    cmv$assignable_device: [XDCL, READ, #GATE, oss$mainframe_paged_literal] SET OF cmt$unit_type :=
          [cmc$mt679_5, cmc$mt679_6, cmc$mt679_7, cmc$mt679_2, cmc$mt679_3, cmc$mt679_4, cmc$mt677_2,
           cmc$mt677_3, cmc$mt677_4, cmc$mt667_2, cmc$mt667_2, cmc$mt667_3, cmc$mt667_4, cmc$mt669_2,
           cmc$mt669_3, cmc$mt669_4, cmc$mt698_3x, cmc$mt639_s0, cmc$mt639_1, cmc$mt5682_1x],
    cmv$configuration_activated : [XDCL, #GATE] boolean := FALSE,
    cmv$new_device_file: [XDCL, #GATE] cmt$device_file_record :=
          [cmc$physical_configuration_file, cmc$dfs_unknown, cmc$default_vsn, *, *],
    cmv$physical_configuration: [XDCL, #GATE] cmt$physical_configuration := NIL,
    cmv$save_pct_p: [XDCL] cmt$physical_configuration := NIL,
    cmv$save_state_table_p: [XDCL] ^ARRAY [1 .. *] OF cmt$state_information := NIL,
    cmv$sci_dft_pp: [XDCL, #GATE] cmt$sci_dft_pp :=
          [[0, dsc$cpt_nio, 0], FALSE, [0, dsc$cpt_nio, 0], FALSE, [0, dsc$cpt_nio, 0]],
    cmv$state_change_lock: [XDCL] ost$signature_lock,
    cmv$state_info_table: [XDCL, #GATE] ^ARRAY [1 .. *] OF cmt$state_information := NIL;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$build_pct', EJECT ??
*copy cmh$build_pct

  PROCEDURE [XDCL, #GATE] cmp$build_pct
    (    entry_count: integer;
         entries: ARRAY [1 .. * ] OF cmt$element_definition;
     VAR status: ost$status);

    VAR
      index: integer;

    status.normal := TRUE;
    #keypoint (osk$entry, entry_count * osk$m, cmk$build_pct);

   /main_program/
    BEGIN
      cmv$save_pct_p := cmv$physical_configuration;
      ALLOCATE cmv$physical_configuration: [1 .. entry_count] IN osv$mainframe_pageable_heap^;
      IF cmv$physical_configuration = NIL THEN
        EXIT /main_program/;
      IFEND;

      FOR index := 1 TO entry_count DO
        cmv$physical_configuration^ [index] := entries [index];
      FOREND;
    END /main_program/;

    #keypoint (osk$exit, 0, cmk$build_pct);

  PROCEND cmp$build_pct;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$build_state_table', EJECT ??

{ PURPOSE:
{   This procedure builds a copy of the state information.

  PROCEDURE [XDCL, #GATE] cmp$build_state_table
    (    entry_count: integer;
         entries: ARRAY [ * ] OF cmt$state_information;
         use_mrt_state : boolean;
     VAR status: ost$status);

    VAR
      channel_definition: cmt$data_channel_definition,
      channel_identification: cmt$channel_descriptor,
      channel_protocol: dst$channel_protocol_type,
      channel_state_list: dst$entire_channel_state_list,
      iou_number: dst$iou_number,
      state_index: integer;

    status.normal := TRUE;

    cmv$save_state_table_p := cmv$state_info_table;

    IF use_mrt_state THEN
      dsp$read_channel_states (channel_state_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    ALLOCATE cmv$state_info_table: [1 .. entry_count] IN osv$mainframe_pageable_heap^;

    FOR state_index := 1 TO entry_count DO
      cmv$state_info_table^ [state_index].element_name := entries [state_index].element_name;
      cmv$state_info_table^ [state_index].status := entries [state_index].status;
      cmv$state_info_table^ [state_index].element_type := entries [state_index].element_type;
      IF cmv$state_info_table^ [state_index].element_type = cmc$data_channel_element THEN
        cmv$state_info_table^ [state_index].iou := entries [state_index].iou;
        cmp$convert_iou_name (cmv$state_info_table^[state_index].iou, iou_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        channel_identification.iou := cmv$state_info_table^ [state_index].iou;
        channel_identification.use_logical_identification := TRUE;
        channel_identification.name := cmv$state_info_table^ [state_index].element_name;
        cmp$get_channel_def (channel_identification, channel_definition, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF channel_definition.concurrent THEN
          channel_protocol := dsc$cpt_cio;
        ELSE
          channel_protocol := dsc$cpt_nio;
        IFEND;
        IF use_mrt_state THEN
          cmv$state_info_table^ [state_index].status.state :=
                channel_state_list [iou_number] [channel_protocol] [channel_definition.number];
        IFEND;
      ELSE
        cmv$state_info_table^ [state_index].product_id := entries [state_index].product_id;
        cmv$state_info_table^ [state_index].logical_unit := entries [state_index].logical_unit;
        cmv$state_info_table^ [state_index].application_info_size :=
              entries [state_index].application_info_size;
        cmv$state_info_table^ [state_index].site_info_size := entries [state_index].site_info_size;
        IF entries [state_index].application_info_p <> NIL THEN
          ALLOCATE cmv$state_info_table^ [state_index].application_info_p:
                [STRLENGTH(entries [state_index].application_info_p^)] IN osv$mainframe_pageable_heap^;
          cmv$state_info_table^ [state_index].application_info_p^ :=
                entries [state_index].application_info_p^;
        ELSE
          cmv$state_info_table^ [state_index].application_info_p := NIL;
        IFEND;
        IF entries [state_index].site_info_p <> NIL THEN
          ALLOCATE cmv$state_info_table^ [state_index].site_info_p:
                [STRLENGTH(entries [state_index].site_info_p^)] IN osv$mainframe_pageable_heap^;
          cmv$state_info_table^ [state_index].site_info_p^ := entries [state_index].site_info_p^;
        ELSE
          cmv$state_info_table^ [state_index].site_info_p := NIL;
        IFEND;
      IFEND;
    FOREND;

  PROCEND cmp$build_state_table;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$check_dual_pp_system_disk ', EJECT ??

{ PURPOSE:
{   This procedure returns whether or not the system disk PP has a partner pp.

  PROCEDURE [XDCL] cmp$check_dual_pp_system_disk
    (    pp: dst$iou_resource;
     VAR dual_pp: boolean;
     VAR partner_pp: dst$iou_resource);

    dual_pp := FALSE;

    IF (cmv$system_device_pp.primary_pp = pp) AND cmv$system_device_pp.dual_pp THEN
      dual_pp := TRUE;
      partner_pp := cmv$system_device_pp.partner_pp;
    IFEND;

  PROCEND cmp$check_dual_pp_system_disk;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_controller_type', EJECT ??

{ PURPOSE:
{   This procedure returns the internal controller type based on the product id.

  PROCEDURE [XDCL, #GATE] cmp$get_controller_type
    (    pid: cmt$product_identification;
     VAR controller_type: cmt$controller_type;
     VAR status: ost$status);

    VAR
      index: integer;

    status.normal := TRUE;

    FOR index := 1 TO UPPERBOUND (cmv$controller_data_ptr^) DO
      IF cmv$controller_data_ptr^ [index].product_id = pid THEN
        controller_type := cmv$controller_data_ptr^ [index].controller_type;
        RETURN;
      IFEND;
    FOREND;

    cmp$set_product_id_status (' ', pid, cme$pc_unknown_controller_type, status);

  PROCEND cmp$get_controller_type;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_element_name_via_lun ', EJECT ??
*copy cmh$get_element_name_via_lun

  PROCEDURE [XDCL, #GATE] cmp$get_element_name_via_lun
    (    logical_unit_number: iot$logical_unit;
     VAR element_name: cmt$element_name;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      mainframe_element_p: ^cmt$element_definition,
      temp_string: ost$string;

    status.normal := TRUE;
    #keypoint (osk$entry, 0, cmk$get_element_name_via_lun );

  /main_program/
    BEGIN
      cmp$pc_get_logical_unit (logical_unit_number, mainframe_element_p, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF mainframe_element_p <> NIL THEN
        element_name := mainframe_element_p^.element_name;
      ELSE
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_unit_not_found, '', status);
        clp$convert_integer_to_string (logical_unit_number, 10, FALSE, temp_string, ignore_status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              temp_string.value (1, temp_string.size), status);
      IFEND;
    END /main_program/;

    #keypoint (osk$exit, 0, cmk$get_element_name_via_lun );

  PROCEND cmp$get_element_name_via_lun;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_logical_unit_number', EJECT ??
*copy cmh$get_logical_unit_number

  PROCEDURE [XDCL, #GATE] cmp$get_logical_unit_number
    (    element_name: cmt$element_name;
     VAR logical_unit_number: iot$logical_unit;
     VAR status: ost$status);

    VAR
      index: integer,
      mainframe_element_p: ^cmt$element_definition,
      unused_iou_name: cmt$element_name;

    status.normal := TRUE;
    #keypoint (osk$entry, 0, cmk$get_logical_unit_number);
    logical_unit_number := 0;

   /main_program/
    BEGIN
      cmp$pc_get_element (element_name, unused_iou_name, mainframe_element_p, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      { Find a logical unit for element other than channel and controllers, since they do not get assigned
      { a logical unit.

      IF (mainframe_element_p^.element_type <> cmc$data_channel_element) AND
          (mainframe_element_p^.element_type <> cmc$controller_element) THEN
        IF cmv$state_info_table = NIL THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_nil_lct, element_name, status);
          EXIT /main_program/;
        IFEND;

        FOR index := LOWERBOUND (cmv$state_info_table^) TO UPPERBOUND (cmv$state_info_table^) DO
          IF element_name = cmv$state_info_table^ [index].element_name THEN
            logical_unit_number := cmv$state_info_table^ [index].logical_unit;
            EXIT /main_program/;
          IFEND;
        FOREND;

        osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_not_logically_conf, element_name,
              status);
      ELSE
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_name_not_data_element,
              element_name, status);
      IFEND;
    END /main_program/;

    #keypoint (osk$exit, logical_unit_number * osk$m, cmk$get_logical_unit_number);

  PROCEND cmp$get_logical_unit_number;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$pc_get_element', EJECT ??
*copy cmh$pc_get_element

  PROCEDURE [XDCL, #GATE] cmp$pc_get_element
    (    element_name: cmt$element_name;
         iou_name: cmt$element_name;
     VAR mainframe_element_p: ^cmt$element_definition;
     VAR status: ost$status);

    VAR
      index: integer,
      text: string (64);

    status.normal := TRUE;
    #keypoint (osk$entry, 0, cmk$pc_get_element);

  /main_program/
    BEGIN
      IF cmv$physical_configuration = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_nil_pct, 'NIL PCT', status);
        EXIT /main_program/;
      IFEND;

      FOR index := 1 TO UPPERBOUND (cmv$physical_configuration^) DO
        #keypoint (osk$debug, index * osk$m, cmk$pc_get_element);
        mainframe_element_p := ^cmv$physical_configuration^ [index];

        IF mainframe_element_p^.element_name = element_name THEN
          IF mainframe_element_p^.element_type = cmc$data_channel_element THEN
            IF iou_name = mainframe_element_p^.data_channel.iou THEN
              EXIT /main_program/;
            IFEND;
          ELSE
            EXIT /main_program/;
          IFEND;
        IFEND;
      FOREND;
      text := ' ';
      IF cmp$valid_channel_name(element_name) THEN
        text (1, 5) := iou_name (1, 5);
        text (6, *) := element_name;
      ELSE
        text (1, *) := element_name;
      IFEND;
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_element_not_found, text, status);
    END /main_program/;

    #keypoint (osk$exit, 0, cmk$pc_get_element);

  PROCEND cmp$pc_get_element;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$pc_get_logical_unit', EJECT ??
*copy cmh$pc_get_logical_unit

  PROCEDURE [XDCL, #GATE] cmp$pc_get_logical_unit
    (    logical_unit_number: iot$logical_unit;
     VAR mainframe_element_p: ^cmt$element_definition;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      index: integer,
      temp_string: ost$string,
      unused_iou_name: cmt$element_name;

    status.normal := TRUE;
    #keypoint (osk$entry, 0, cmk$pc_get_logical_unit);

   /main_program/
    BEGIN
      FOR index := 1 TO UPPERBOUND (cmv$state_info_table^) DO
        #keypoint (osk$debug, index * osk$m, cmk$pc_get_logical_unit);
        IF (cmv$state_info_table^ [index].element_type <> cmc$data_channel_element) AND
              (cmv$state_info_table^ [index].logical_unit = logical_unit_number) THEN
          cmp$pc_get_element (cmv$state_info_table^ [index].element_name, unused_iou_name,
                mainframe_element_p, status);
          EXIT /main_program/;
        IFEND;
      FOREND;
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_unit_not_found, '', status);
      clp$convert_integer_to_string (logical_unit_number, 10, FALSE, temp_string, ignore_status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            temp_string.value (1, temp_string.size), status);
    END /main_program/;

    #keypoint (osk$exit, 0, cmk$pc_get_logical_unit);

  PROCEND cmp$pc_get_logical_unit;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$pc_get_next_channel', EJECT ??
*copy cmh$pc_get_next_channel

  PROCEDURE [XDCL, #GATE] cmp$pc_get_next_channel
    (    current_channel: integer;
     VAR mainframe_element_p: ^cmt$element_definition;
     VAR status: ost$status);

    VAR
      index: integer,
      channel_count: integer;

    status.normal := TRUE;
    #keypoint (osk$entry, 0, cmk$pc_get_next_channel);

   /main_program/
    BEGIN
      IF cmv$physical_configuration = NIL THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_nil_lct, 'NIL PCT', status);
        EXIT /main_program/;
      IFEND;

      channel_count := current_channel;

      FOR index := 1 TO UPPERBOUND (cmv$physical_configuration^) DO
        #keypoint (osk$debug, index * osk$m, cmk$pc_get_next_channel);
        mainframe_element_p := ^cmv$physical_configuration^ [index];
        IF mainframe_element_p^.element_type = cmc$data_channel_element THEN
          channel_count := channel_count - 1;
          IF channel_count < 0 THEN
            EXIT /main_program/;
          IFEND;
        IFEND;
      FOREND;
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_nil_lct, '', status);
    END /main_program/;

    #keypoint (osk$exit, 0, cmk$pc_get_next_channel);

  PROCEND cmp$pc_get_next_channel;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$search_active_volume_table', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$search_active_volume_table
    (    search_key: dmt$avt_search_key;
     VAR recorded_vsn: rmt$recorded_vsn;
     VAR avt_entry_not_found: boolean);

    VAR
      avt_index: dmt$active_volume_table_index;

    dmp$search_active_volume_table (search_key, avt_index, avt_entry_not_found);
    IF avt_entry_not_found THEN
      RETURN;
    IFEND;

    recorded_vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;

  PROCEND cmp$search_active_volume_table;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$update_dft_sci_location', EJECT ??

{ PURPOSE:
{   To initialize and update the values of SCI, DFT and secondary DFT pp number.

  PROCEDURE [XDCL] cmp$update_dft_sci_location
    (    dft_sci_location: cmt$sci_dft_pp);

    cmv$sci_dft_pp := dft_sci_location;

  PROCEND cmp$update_dft_sci_location;
?? OLDTITLE ??
MODEND cmm$physical_configuration_mgr;
*DECK DECK=CMM$PHYSICAL_CONFIG_MGR_R1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE CM : Physical Configuration manager' ??
MODULE cmm$physical_config_mgr_r1;

{ PURPOSE:
{   This module contains procedures to manage the physical configuration, configure the system and/or
{   deadstart device.
{
{ DESIGN:
{   Because of the size of the data structure, the physical configuration table is being kept in mainframe
{   pageable.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmc$default_channel_name
*copyc cmc$logical_conf_dev_file_name
*copyc cmc$logical_unit_constants
*copyc cmc$physical_conf_dev_file_name
*copyc cme$access_device_files
*copyc cme$logical_configuration_mgr
*copyc cme$physical_configuration_mgr
*copyc cmk$keypoints
*copyc cmt$controller_type
*copyc cmt$cpu_element_definition
*copyc cmt$device_file_header
*copyc cmt$element_definition
*copyc cmt$element_name
*copyc cmt$ms_class_info
*copyc cmt$ms_logical_unit_list
*copyc cmt$request_block
*copyc cmt$state_information
*copyc cmt$unit_type
*copyc dmt$error_condition_codes
*copyc dst$rb_system_deadstart_status
*copyc dst$mainframe_type
*copyc oss$mainframe_paged_literal
*copyc ost$cpu_state_table
*copyc rmd$volume_declarations
?? POP ??
*copyc cmp$acquire_deadstart_resources
*copyc cmp$build_interface_tables
*copyc cmp$build_iou_table
*copyc cmp$build_pct
*copyc cmp$build_state_table
*copyc cmp$convert_iou_name
*copyc cmp$convert_iou_number
*copyc cmp$find_redundant_path
*copyc cmp$get_channel_def
*copyc cmp$get_controller_type
*copyc cmp$get_driver_by_controller
*copyc cmp$get_element_state
*copyc cmp$get_logical_pp_index
*copyc cmp$get_logical_unit_number
*copyc cmp$get_pp_table_rma
*copyc cmp$get_unit_type
*copyc cmp$load_controller_module
*copyc cmp$pc_get_element
*copyc cmp$pc_get_logical_unit
*copyc cmp$reacquire_resources
*copyc cmp$release_pp_by_index
*copyc cmp$search_active_volume_table
*copyc cmp$set_illegal_channel_status
*copyc cmp$support_redundant_channel
*copyc cmp$valid_channel_name
*copyc dmp$create_device_file
*copyc dmp$detach_device_file
*copyc dsp$change_channel_states
*copyc dsp$get_cpu_attributes
*copyc dsp$retrieve_iou_information
*copyc i#call_monitor
*copyc i#real_memory_address
*copyc iop$tape_initialization
*copyc osp$append_status_parameter
*copyc osp$append_status_integer
*copyc osp$clear_signature_lock
*copyc osp$set_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
?? EJECT ??
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc cmv$max_number_of_pp
*copyc cmv$new_device_file
*copyc cmv$peripheral_element_table
*copyc cmv$physical_configuration
*copyc cmv$state_info_table
*copyc cmv$system_device_data
*copyc cmv$system_device_pp
*copyc dmv$active_volume_table
*copyc dmv$system_device_information
*copyc dsv$mainframe_type
*copyc mtv$cst0
*copyc mtv$scb
*copyc osv$170_os_type
*copyc osv$cpus_physically_configured
*copyc osv$mainframe_wired_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    cmv$device_file_lock: [XDCL] ost$signature_lock,
    mtv$cy2000_sp_recovery: [XREF] boolean;

?? OLDTITLE ??
?? NEWTITLE := 'build_logical_unit_list', EJECT ??

{ PURPOSE:
{   This procedure sets up a list of all logical units whose UIT RMA is not zero.

  PROCEDURE build_logical_unit_list
    (    primary_element: cmt$element_definition;
         ignore_controller_state: boolean;
         update_controller_address: boolean;
         new_state: cmt$element_state;
         logical_pp: iot$pp_number;
         logical_unit_list_p: ^ARRAY [ * ] OF cmt$rb_logical_unit_address;
     VAR logical_unit_count: integer);

    VAR
      ctport: cmt$controller_port_number,
      channel_p: ^cmt$element_definition,
      controller_p: ^cmt$element_definition,
      controller_state: cmt$element_state,
      element_lun: iot$logical_unit,
      iou_name: cmt$element_name,
      local_status: ost$status,
      logical_unit: iot$logical_unit,
      lun_index: integer,
      port: cmt$data_storage_port_number,
      ppit_p: ^iot$pp_interface_table,
      status: ost$status,
      unit_element_p: ^cmt$element_definition,
      ud: iot$logical_unit;

    logical_unit_count := 0;
    ppit_p := cmv$logical_pp_table_p^ [logical_pp].pp_info.pp_interface_table_p;

    IF primary_element.element_type = cmc$storage_device_element THEN
      cmp$get_logical_unit_number(primary_element.element_name, element_lun, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    CASE new_state OF
    = cmc$off, cmc$down =

    /loop_thru_logical_units_1/
      FOR ud := LOWERBOUND (ppit_p^.unit_descriptors) TO UPPERBOUND (ppit_p^.unit_descriptors) DO
        IF ppit_p^.unit_descriptors [ud].unit_interface_table_rma = 0 THEN
          CYCLE /loop_thru_logical_units_1/;
        IFEND;

        IF (primary_element.element_type = cmc$storage_device_element) AND (ud <> element_lun) THEN
          CYCLE /loop_thru_logical_units_1/;
        IFEND;

        IF update_controller_address AND (primary_element.element_type = cmc$controller_element) THEN

          { Only update logical units accessible from the controller being DOWN/OFF.

          IF ppit_p^.unit_descriptors [ud].physical_path.controller_number <>
                primary_element.controller.physical_equipment_number THEN
            CYCLE /loop_thru_logical_units_1/;
          IFEND;
        IFEND;

        logical_unit := ppit_p^.unit_descriptors [ud].logical_unit;
        logical_unit_count := logical_unit_count + 1;
        IF logical_unit_list_p <> NIL THEN
          logical_unit_list_p^ [logical_unit_count].logical_unit := logical_unit;
          logical_unit_list_p^ [logical_unit_count].controller  :=
                ppit_p^.unit_descriptors [ud].physical_path.controller_number;
        IFEND;

        IF update_controller_address THEN
          cmp$pc_get_logical_unit (logical_unit, unit_element_p, local_status);
          IF NOT local_status.normal THEN
            RETURN;
          IFEND;

        /loop_thru_upline_connections/
          FOR port := LOWERVALUE (cmt$data_storage_port_number) TO
                UPPERVALUE (cmt$data_storage_port_number) DO
            IF NOT unit_element_p^.storage_device.connection.port [port].configured THEN
              CYCLE /loop_thru_upline_connections/;
            IFEND;

            cmp$pc_get_element (unit_element_p^.storage_device.connection.port [port].element_name,
                  iou_name, controller_p, status);
            IF NOT local_status.normal THEN
              CYCLE /loop_thru_upline_connections/;
            IFEND;

            CASE primary_element.element_type OF
            = cmc$data_channel_element =
              IF NOT ignore_controller_state THEN
                cmp$get_element_state (unit_element_p^.storage_device.connection.port [port].element_name,
                      iou_name, controller_state, local_status);
                IF controller_state <> cmc$on THEN
                  CYCLE /loop_thru_upline_connections/;
                IFEND;
              IFEND;

              IF controller_p^.controller.physical_equipment_number =
                    ppit_p^.unit_descriptors [ud].physical_path.controller_number THEN
                FOR ctport := LOWERVALUE (cmt$controller_port_number) TO
                      UPPERVALUE (cmt$controller_port_number) DO
                  IF (controller_p^.controller.connection.port [ctport].configured) AND
                        (controller_p^.controller.connection.port [ctport].mainframe_ownership =
                        primary_element.data_channel.mainframe_ownership) THEN
                    cmp$pc_get_element (controller_p^.controller.connection.port [ctport].element_name,
                          controller_p^.controller.connection.port [ctport].iou, channel_p, status);
                    IF status.normal THEN
                      IF (channel_p^.data_channel.number <> primary_element.data_channel.number) OR
                            (channel_p^.data_channel.concurrent <> primary_element.data_channel.
                            concurrent) OR (channel_p^.data_channel.iou <> primary_element.data_channel.iou)
                            THEN
                        IF logical_unit_list_p <> NIL THEN
                          logical_unit_list_p^ [logical_unit_count].controller :=
                                controller_p^.controller.physical_equipment_number;
                        IFEND;
                      IFEND;
                    IFEND;
                  IFEND;
                FOREND;
              IFEND;

            = cmc$controller_element =

              { Take the controller number of the redundant controller connected to this unit.

              IF controller_p^.element_name <> primary_element.element_name THEN
                IF logical_unit_list_p <> NIL THEN
                  IF update_controller_address THEN
                    logical_unit_list_p^ [logical_unit_count].controller :=
                          controller_p^.controller.physical_equipment_number;
                  IFEND;
                IFEND;
              IFEND;
            ELSE
            CASEND;
          FOREND /loop_thru_upline_connections/;
        IFEND;
      FOREND /loop_thru_logical_units_1/;

    ELSE  { = cmc$on = }

      { count all lun whose first channel connections is the current channel passed in the procedure.

    /loop_thru_logical_units_2/
      FOR ud := LOWERBOUND (ppit_p^.unit_descriptors) TO UPPERBOUND (ppit_p^.unit_descriptors) DO
        IF ppit_p^.unit_descriptors [ud].unit_interface_table = NIL THEN
          CYCLE /loop_thru_logical_units_2/;
        IFEND;

        IF (primary_element.element_type = cmc$storage_device_element) AND (ud <> element_lun) THEN
          CYCLE /loop_thru_logical_units_2/;
        IFEND;

        logical_unit := ppit_p^.unit_descriptors [ud].logical_unit;

        cmp$pc_get_logical_unit (logical_unit, unit_element_p, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;

      /loop_thru_upline_connections_2/
        FOR port := LOWERVALUE (cmt$data_storage_port_number) TO
              UPPERVALUE (cmt$data_storage_port_number) DO
          IF NOT unit_element_p^.storage_device.connection.port [port].configured THEN
            CYCLE /loop_thru_upline_connections_2/;
          IFEND;

          cmp$pc_get_element (unit_element_p^.storage_device.connection.port [port].element_name, iou_name,
                controller_p, status);
          IF NOT local_status.normal THEN
            CYCLE /loop_thru_upline_connections_2/;
          IFEND;

          CASE primary_element.element_type OF
          = cmc$data_channel_element =
            IF NOT ignore_controller_state THEN
              cmp$get_element_state (unit_element_p^.storage_device.connection.port [port].element_name,
                    iou_name, controller_state, local_status);
              IF controller_state <> cmc$on THEN
                CYCLE /loop_thru_upline_connections_2/;
              IFEND;
            IFEND;

            IF controller_p^.controller.physical_equipment_number =
                  ppit_p^.unit_descriptors [ud].physical_path.controller_number THEN
              FOR ctport := LOWERVALUE (cmt$controller_port_number) TO
                    UPPERVALUE (cmt$controller_port_number) DO
                IF (controller_p^.controller.connection.port [ctport].configured) AND
                      (controller_p^.controller.connection.port [ctport].mainframe_ownership =
                      primary_element.data_channel.mainframe_ownership) THEN
                  cmp$pc_get_element (controller_p^.controller.connection.port [ctport].element_name,
                        controller_p^.controller.connection.port [ctport].iou, channel_p, status);
                  IF status.normal THEN
                    IF (channel_p^.data_channel.number = primary_element.data_channel.number) OR
                          (channel_p^.data_channel.concurrent = primary_element.data_channel.concurrent) OR
                          (channel_p^.data_channel.iou = primary_element.data_channel.iou) THEN
                      logical_unit_count := logical_unit_count + 1;
                      IF logical_unit_list_p <> NIL THEN
                        logical_unit_list_p^ [logical_unit_count].logical_unit := logical_unit;
                        IF update_controller_address THEN
                          logical_unit_list_p^ [logical_unit_count].controller :=
                                controller_p^.controller.physical_equipment_number;
                        IFEND;
                      IFEND;
                    IFEND;
                  IFEND;
                IFEND;
              FOREND;
            IFEND;

          = cmc$controller_element =

            { Take the controller number of the primary controller connected to this unit.

            IF controller_p^.element_name = primary_element.element_name THEN
              logical_unit_count := logical_unit_count + 1;
              IF logical_unit_list_p <> NIL THEN
                logical_unit_list_p^ [logical_unit_count].logical_unit := logical_unit;
                IF update_controller_address THEN
                  logical_unit_list_p^ [logical_unit_count].controller :=
                        controller_p^.controller.physical_equipment_number;
                IFEND;
              IFEND;
            IFEND;

          = cmc$storage_device_element =
            logical_unit_count := logical_unit_count + 1;
            IF logical_unit_list_p <> NIL THEN
              logical_unit_list_p^ [logical_unit_count].logical_unit := logical_unit;
              IF update_controller_address THEN
                logical_unit_list_p^ [logical_unit_count].controller :=
                      controller_p^.controller.physical_equipment_number;
              IFEND;
            IFEND;
          ELSE
          CASEND;
        FOREND /loop_thru_upline_connections_2/;
      FOREND /loop_thru_logical_units_2/;
    CASEND;

  PROCEND build_logical_unit_list;
?? OLDTITLE ??
?? NEWTITLE := 'configure_ds_device', EJECT ??

{ PURPOSE:
{   Configure the deadstart tape device by taking information from the boot menu.

  PROCEDURE configure_ds_device
    (VAR status: ost$status);

    VAR
      channel_definition: cmt$data_channel_definition,
      channel_descriptor: cmt$channel_descriptor,
      i : integer;

    status.normal := TRUE;

   { Initialize channel entry }

    cmv$physical_configuration^ [4].element_name :=
          cmv$system_device_data [cmc$sdt_tape_device].channel_name;
    cmv$physical_configuration^ [4].element_type := cmc$data_channel_element;
    cmv$physical_configuration^ [4].product_id.product_number := ' ';
    cmv$physical_configuration^ [4].product_id.underscore := ' ';
    cmv$physical_configuration^ [4].product_id.model_number := ' ';
    cmp$convert_iou_number (cmv$system_device_data [cmc$sdt_tape_device].iou_number,
          channel_descriptor.iou, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    channel_descriptor.use_logical_identification := TRUE;
    channel_descriptor.name := cmv$system_device_data [cmc$sdt_tape_device].channel_name;
    cmp$get_channel_def (channel_descriptor, channel_definition, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to determine Channel characteristics in configure_ds_device', ^status);
    IFEND;
    cmv$physical_configuration^ [4].data_channel := channel_definition;
    cmv$physical_configuration^ [4].data_channel.mainframe_ownership := '  ';

    FOR i := 0 TO UPPERVALUE (cmt$physical_equipment_number) DO
      cmv$physical_configuration^ [4].data_channel.connection.equipment [i].configured := FALSE;
    FOREND;

    cmv$physical_configuration^ [4].data_channel.connection.equipment
          [cmv$system_device_data [cmc$sdt_tape_device].equipment_number].configured := TRUE;
    cmv$physical_configuration^ [4].data_channel.connection.equipment
          [cmv$system_device_data [cmc$sdt_tape_device].equipment_number].element_name :=
          cmv$system_device_data [cmc$sdt_tape_device].equipment_name;

    IF ((cmv$physical_configuration^ [4].data_channel.number >= 12) AND
          (cmv$physical_configuration^ [4].data_channel.number <= 15)) OR
          (cmv$physical_configuration^ [4].data_channel.concurrent AND
          (cmv$physical_configuration^ [4].data_channel.number > 25)) THEN
      cmp$set_illegal_channel_status (cmv$physical_configuration^ [4].data_channel.number,
            cme$pc_unsupported_channel, status);
      RETURN;
    IFEND;

    { Initialize controller entry }

    cmv$physical_configuration^ [5].element_name :=
          cmv$system_device_data [cmc$sdt_tape_device].equipment_name;
    cmv$physical_configuration^ [5].element_type := cmc$controller_element;
    cmv$physical_configuration^ [5].product_id :=
          cmv$system_device_data [cmc$sdt_tape_device].equipment_id;
    cmv$physical_configuration^ [5].controller.physical_equipment_number :=
          cmv$system_device_data [cmc$sdt_tape_device].equipment_number;
    cmv$physical_configuration^ [5].controller.connection.port [0].configured := TRUE;
    cmv$physical_configuration^ [5].controller.connection.port [0].element_name :=
          cmv$system_device_data [cmc$sdt_tape_device].channel_name;
    cmv$physical_configuration^ [5].controller.connection.port [0].upline_connection_type :=
          cmc$data_channel_element;
    cmv$physical_configuration^ [5].controller.connection.port [0].mainframe_ownership := ' ';
    cmv$physical_configuration^ [5].controller.connection.port [0].iou :=
          cmv$physical_configuration^ [4].data_channel.iou;

    FOR i := 1 TO UPPERVALUE (cmt$controller_port_number) DO
      cmv$physical_configuration^ [5].controller.connection.port [i].configured := FALSE;
    FOREND;

    FOR i := 0 TO UPPERVALUE (cmt$physical_unit_number) DO
      cmv$physical_configuration^ [5].controller.connection.unit [i].configured := FALSE;
    FOREND;

    cmv$physical_configuration^ [5].controller.connection.unit
          [cmv$system_device_data [cmc$sdt_tape_device].unit_number].configured := TRUE;
    cmv$physical_configuration^ [5].controller.connection.unit
          [cmv$system_device_data [cmc$sdt_tape_device].unit_number].element_name :=
          cmv$system_device_data [cmc$sdt_tape_device].unit_name;

    {  Initialize data device entry }

    cmv$physical_configuration^ [6].element_name := cmv$system_device_data [cmc$sdt_tape_device].unit_name;
    cmv$physical_configuration^ [6].product_id := cmv$system_device_data [cmc$sdt_tape_device].unit_id;
    cmv$physical_configuration^ [6].element_type := cmc$storage_device_element;
    cmv$physical_configuration^ [6].storage_device.physical_unit_number :=
          cmv$system_device_data [cmc$sdt_tape_device].unit_number;
    cmv$physical_configuration^ [6].storage_device.connection.port [0].configured := TRUE;
    cmv$physical_configuration^ [6].storage_device.connection.port [0].element_name :=
          cmv$system_device_data [cmc$sdt_tape_device].equipment_name;
    cmv$physical_configuration^ [6].storage_device.connection.port [0].upline_connection_type :=
          cmc$controller_element;
    FOR i := 1 TO UPPERVALUE (cmt$data_storage_port_number) DO
      cmv$physical_configuration^ [6].storage_device.connection.port [i].configured := FALSE;
    FOREND;

  PROCEND configure_ds_device;
?? OLDTITLE ??
?? NEWTITLE := 'validate_all_units ', EJECT ??

{ PURPOSE :
{   This procedure validate all units against the list of redundant pp. If a unit can not
{   be found in the unit descriptors of the redundant pps then it has to be non system critical

  PROCEDURE validate_all_units
    (    logical_unit_list_p: ^ARRAY [ * ] OF cmt$rb_logical_unit_address;
         pp_list: ARRAY [cmt$physical_equipment_number] OF iot$pp_number;
         number_of_path: integer;
     VAR found_critical_device: boolean);

    VAR
      entry_not_found: boolean,
      found: boolean,
      lun_index: integer,
      ms_class_info: cmt$ms_class_info,
      pp_index: cmt$physical_equipment_number,
      ppit_p: ^iot$pp_interface_table,
      recorded_vsn: rmt$recorded_vsn,
      search_key: dmt$avt_search_key,
      ud: iot$logical_unit,
      volume_found: boolean;

    found_critical_device := FALSE;
    FOR lun_index := LOWERBOUND (logical_unit_list_p^) TO UPPERBOUND (logical_unit_list_p^) DO
      found := FALSE;
      pp_index := LOWERBOUND (pp_list);
      WHILE (NOT found) AND (pp_index <= number_of_path) DO

        ppit_p := cmv$logical_pp_table_p^ [pp_list[pp_index]].pp_info.pp_interface_table_p;

       /match_lun/
        FOR ud := LOWERBOUND (ppit_p^.unit_descriptors) TO UPPERBOUND (ppit_p^.unit_descriptors) DO
          IF (logical_unit_list_p^ [lun_index].logical_unit = ppit_p^.unit_descriptors [ud].logical_unit) AND
                (ppit_p^.unit_descriptors [ud].unit_interface_table <> NIL) THEN
            found := TRUE;
            EXIT /match_lun/;
          IFEND;
        FOREND /match_lun/;
        pp_index := pp_index + 1;
      WHILEND;

      IF NOT found THEN

        { There is a dangling units in the path with no redundant access.
        { Check if this is a critical device.

        search_key.value := dmc$search_avt_by_lun;
        search_key.logical_unit_number := logical_unit_list_p^ [lun_index].logical_unit;
        cmp$search_active_volume_table (search_key, recorded_vsn, entry_not_found);
        IF NOT entry_not_found THEN
          cmp$get_ms_class_on_volume_r1 (recorded_vsn, volume_found, ms_class_info);
          IF volume_found THEN
            IF ms_class_info['J'] AND ms_class_info['Q'] THEN
              found_critical_device := TRUE;
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND validate_all_units;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$assign_logical_unit_numbers', EJECT ??

{ PURPOSE:
{   This procedure assign logical unit number to all storage device, channel adapter, communications and
{   external processor elements.

  PROCEDURE [XDCL, #GATE] cmp$assign_logical_unit_numbers
    (    channel_iou: cmt$element_name;
         equipment_number: cmt$physical_equipment_number;
         unit_number: cmt$physical_unit_number;
         system_device_lun: iot$logical_unit;
     VAR status: ost$status);

    VAR
      assigned_lun: integer,
      cm_unit_type: cmt$unit_type,
      cont_name: cmt$element_name,
      found: boolean,
      found2: boolean,
      io_unit_type: iot$unit_type,
      io_unit_type2: iot$unit_type,
      pc_index: integer,
      pc_index2: integer,
      state_count: integer,
      state_index: integer,
      unit_class: cmt$unit_class,
      unit_class2: cmt$unit_class,
      unit_name: cmt$element_name,
      unit_type: cmt$unit_type;

    status.normal := TRUE;

    IF (cmv$physical_configuration = NIL) OR (cmv$state_info_table = NIL) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_nil_cm_table,
            'Try to assign logical units when CM tables are not yet built.', status);
      RETURN;
    IFEND;

   /outer_loop/
    BEGIN

     /loop1/
      FOR pc_index := LOWERBOUND(cmv$physical_configuration^) TO UPPERBOUND (cmv$physical_configuration^) DO
        IF cmv$physical_configuration^ [pc_index].element_type = cmc$data_channel_element THEN
          IF (cmv$physical_configuration^ [pc_index].element_name =
                cmv$system_device_data [cmc$sdt_disk_device].channel_name) AND
                (cmv$physical_configuration^ [pc_index].data_channel.iou = channel_iou) THEN

            cont_name := cmv$physical_configuration^ [pc_index].data_channel.
                  connection.equipment [equipment_number].element_name;

           /loop2/
            FOR pc_index2 := LOWERBOUND(cmv$physical_configuration^) TO
                  UPPERBOUND (cmv$physical_configuration^) DO
              IF cmv$physical_configuration^ [pc_index2].element_name = cont_name THEN
                unit_name := cmv$physical_configuration^ [pc_index2].controller.
                      connection.unit [unit_number].element_name;
                cmp$get_unit_type (cmv$physical_configuration^ [pc_index2].product_id, cm_unit_type,
                      io_unit_type2, unit_class2, found2);
                IF found2 THEN
                  IF cm_unit_type = cmc$mshydra THEN
                    unit_name := cont_name;
                  IFEND;
                IFEND;
                EXIT /outer_loop/;
              IFEND;
            FOREND /loop2/;
          IFEND;
        IFEND;
      FOREND /loop1/;

      osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_unit_not_found, ' ', status);
      osp$append_status_integer (osc$status_parameter_delimiter , system_device_lun, 10, FALSE, status);
      RETURN;
    END /outer_loop/;

    state_count := UPPERBOUND (cmv$state_info_table^);

    { Assign system device lun.

    FOR state_index := 1 TO state_count DO
      IF cmv$state_info_table^ [state_index].element_type <> cmc$data_channel_element THEN
        IF cmv$state_info_table^ [state_index].element_name = unit_name THEN
          cmv$state_info_table^ [state_index].logical_unit := system_device_lun;
        ELSE
          cmv$state_info_table^ [state_index].logical_unit := 0;
        IFEND;
      IFEND;
    FOREND;

    { Assign other luns.

    assigned_lun := system_device_lun + 1;

    FOR state_index := 1 TO state_count DO
      IF (cmv$physical_configuration^ [state_index].element_type <> cmc$data_channel_element) AND
            (cmv$physical_configuration^ [state_index].element_type <> cmc$controller_element) THEN
        cmp$get_unit_type (cmv$state_info_table^ [state_index].product_id, unit_type, io_unit_type,
              unit_class, found);
        IF (found OR (unit_type = cmc$foreign_unit) OR (unit_class = cmc$network_unit) OR
              (unit_class = cmc$rhfam_unit)) AND
              (cmv$state_info_table^ [state_index].logical_unit = 0) THEN
          cmv$state_info_table^ [state_index].logical_unit := assigned_lun;
          assigned_lun := assigned_lun + 1;
        IFEND;
      IFEND;
    FOREND;

  PROCEND cmp$assign_logical_unit_numbers;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$change_state_info_table', EJECT ??

{ PURPOSE:
{   This procedure updates the state value in the state info table based on the element name passed in.

  PROCEDURE [XDCL, #GATE] cmp$change_state_info_table
    (    element_name: cmt$element_name;
         iou_name: cmt$element_name;
         state: cmt$element_state;
     VAR status: ost$status);

    VAR
      channel: cmt$physical_channel,
      channel_state_list_p: ^ARRAY [ * ] OF dst$channel_state,
      channel_identification: cmt$channel_descriptor,
      channel_definition: cmt$data_channel_definition,
      cio_channel_name: cmt$element_name,
      found: boolean,
      index: integer,
      index_2: integer,
      ignore_status: ost$status,
      iou_number: dst$iou_number,
      lock_set: boolean,
      state_table_index: integer,
      text: string (80),
      update_mrt: boolean;

    status.normal := TRUE;
    found := FALSE;
    lock_set := FALSE;
    update_mrt := FALSE;
    channel.concurrent := FALSE;

   /main_program/
    BEGIN
      found := FALSE;

     /table_search_block/
      BEGIN

       /peripheral_loop_1/
        FOR index := 1 TO UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
          IF element_name <> cmv$peripheral_element_table.pointer^ [index].element_name THEN
            CYCLE /peripheral_loop_1/;
          IFEND;

          IF cmv$peripheral_element_table.pointer^ [index].physical_descriptor.element_type =
                cmc$data_channel_element THEN
            cmp$convert_iou_name (iou_name, iou_number, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            IF iou_number <>
                  cmv$peripheral_element_table.pointer^ [index].physical_descriptor.channel_path.iou THEN
              CYCLE /peripheral_loop_1/;
            IFEND;
          IFEND;

          osp$set_signature_lock (cmv$peripheral_element_table.lock, osc$wait, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
          lock_set := TRUE;
          cmv$peripheral_element_table.pointer^ [index].element_status.state := state;
          cmv$peripheral_element_table.pointer^ [index].state_change_request.pending := FALSE;

         /loop/
          FOR state_table_index := 1 TO UPPERBOUND (cmv$state_info_table^) DO
            IF element_name = cmv$state_info_table^ [state_table_index].element_name THEN
              IF (cmv$state_info_table^ [state_table_index].element_type = cmc$data_channel_element) AND
                    (iou_name <> cmv$state_info_table^ [state_table_index].iou) THEN
                CYCLE /loop/;
              IFEND;
              found := TRUE;
              IF cmv$state_info_table^ [state_table_index].element_type = cmc$data_channel_element THEN
                update_mrt := TRUE;
                channel :=
                      cmv$peripheral_element_table.pointer^ [index].physical_descriptor.channel_path.channel;
              IFEND;
              cmv$state_info_table^ [state_table_index].status.state := state;
              EXIT /loop/;
            IFEND;
          FOREND /loop/;
          IF NOT found THEN
            IF cmp$valid_channel_name(element_name) THEN
              text (1, 5) := iou_name (1, 5);
              text (6, *) := element_name;
            ELSE
              text (1, *) := element_name;
            IFEND;
            osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_element_not_found, text,
                  status);
            EXIT /main_program/;
          IFEND;
          EXIT /table_search_block/;
        FOREND /peripheral_loop_1/;

        { If control reaches here, the element name is not in the peripheral element table.

        IF cmp$valid_channel_name(element_name) THEN
          text (1, 5) := iou_name (1, 5);
          text (6, *) := element_name;
        ELSE
          text (1, *) := element_name;
        IFEND;
        osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_element_not_found, text, status);
        EXIT /main_program/;
      END /table_search_block/;

      { If the channel is concurrent and has a port value then make sure the other channel port on the same
      { IOU also has the same state.

      IF update_mrt AND channel.concurrent AND (channel.port <> cmc$unspecified_port) THEN

       /peripheral_loop_2/
        FOR index_2 := LOWERBOUND (cmv$peripheral_element_table.pointer^) TO
              UPPERBOUND (cmv$peripheral_element_table.pointer^) DO
          IF (cmv$peripheral_element_table.pointer^ [index_2].
                physical_descriptor.element_type = cmc$data_channel_element) AND
                (cmv$peripheral_element_table.pointer^ [index_2].
                physical_descriptor.channel_path.channel.number = channel.number) AND
                (cmv$peripheral_element_table.pointer^ [index_2].
                physical_descriptor.channel_path.channel.concurrent = channel.concurrent) AND
                (cmv$peripheral_element_table.pointer^ [index_2].
                physical_descriptor.channel_path.iou = iou_number) THEN
            cmv$peripheral_element_table.pointer^ [index_2].element_status.state := state;
            cmv$state_info_table^ [index_2].status.state := state;
          IFEND;
        FOREND /peripheral_loop_2/;
      IFEND;

      { Call deadstart to update the MRT if the element is a channel.

      IF update_mrt THEN

        { Try to clear the lock so Deadstart can set the lock during accessing the deadstart sector for
        { updating the MRT.

        IF lock_set THEN
          osp$clear_signature_lock (cmv$peripheral_element_table.lock, ignore_status);
          lock_set := FALSE;
        IFEND;

        channel_identification.iou := iou_name;
        channel_identification.use_logical_identification := TRUE;
        channel_identification.name := element_name;
        cmp$get_channel_def (channel_identification, channel_definition, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        PUSH channel_state_list_p : [1 .. 1];
        channel_state_list_p^ [1].channel.iou_number := iou_number;
        IF channel_definition.concurrent THEN
          channel_state_list_p^ [1].channel.channel_protocol := dsc$cpt_cio;
        ELSE
          channel_state_list_p^ [1].channel.channel_protocol := dsc$cpt_nio;
        IFEND;
        channel_state_list_p^ [1].channel.number := channel_definition.number;
        channel_state_list_p^ [1].element_state := state;
        dsp$change_channel_states (channel_state_list_p^, status);
      IFEND;

    END /main_program/;

    IF lock_set THEN
      osp$clear_signature_lock (cmv$peripheral_element_table.lock, ignore_status);
      IF status.normal THEN
        status := ignore_status;
      IFEND;
    IFEND;

  PROCEND cmp$change_state_info_table;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$change_state_r1', EJECT ??

{ PURPOSE:
{   This procedure sets up the monitor request block to change the state of an element in Monitor.

  PROCEDURE [XDCL, #GATE] cmp$change_state_r1
    (    element_name: cmt$element_name;
         element_type: cmt$element_type;
         controller_type: cmt$controller_type;
         system_critical_element: boolean;
         new_state: cmt$element_state;
         iou: dst$iou_number,
         pp: iot$pp_number;
         channel: cmt$physical_channel;
         controller: cmt$physical_equipment_number;
         logical_unit: iot$logical_unit;
     VAR status: ost$status);

    VAR
      channel_data: cmt$element_definition,
      count: integer,
      current_channel_state: cmt$element_state,
      driver_name: pmt$program_name,
      dummy_pp_number: dst$iou_resource,
      element_p: ^cmt$element_definition,
      found_critical_device: boolean,
      iou_name: cmt$element_name,
      logical_pp_index: iot$pp_number,
      loop_index: integer,
      number_of_path: integer,
      physical_channel: cmt$physical_channel,
      pp_table_rma_list: ARRAY [cmt$physical_equipment_number] OF ost$real_memory_address,
      primary_controller_p: ^cmt$peripheral_element_entry,
      redundant: boolean,
      redundant_channel_list: ARRAY [cmt$physical_equipment_number] OF cmt$physical_address,
      redundant_controller: ARRAY [cmt$physical_equipment_number] OF cmt$physical_equipment_number,
      redundant_path_available: boolean,
      redundant_path_pp_list: ARRAY [cmt$physical_equipment_number] OF iot$pp_number,
      request_block: cmt$request_block,
      text: string (80);

    status.normal := TRUE;

  /main_program/
    BEGIN
      redundant_path_available := FALSE;
      request_block.request_code := syc$rc_config_mgmt_request;
      request_block.kind := cmc$rbk_change_state;
      request_block.element_name := element_name;
      request_block.new_state := new_state;
      request_block.iou := iou;
      request_block.redundant_path_available := FALSE;
      request_block.update_controller_address := FALSE;
      request_block.logical_unit_list_p := NIL;
      request_block.redundant_path_pp_list_p := NIL;
      request_block.element_type := element_type;

      cmp$convert_iou_number (iou, iou_name, status);
      cmp$pc_get_element (element_name, iou_name, element_p, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF element_type = cmc$data_channel_element THEN
        text (1, 6) := iou_name;
        text (7, *) := element_name;
        cmp$get_element_state (element_name, iou_name, current_channel_state, status);
        IF (new_state <> cmc$on) AND (current_channel_state <> cmc$on) THEN
          EXIT /main_program/;
        IFEND;
      ELSE
        text := element_name;
      IFEND;

      IF cmp$support_redundant_channel (controller_type) THEN
        count := 0;
        cmp$search_redundant_path (element_p^, iou, channel, new_state, redundant_path_available,
              request_block.update_controller_address, number_of_path, redundant_channel_list,
              redundant_path_pp_list, driver_name, pp_table_rma_list);
        IF redundant_path_available THEN
          request_block.redundant_path_available := TRUE;
          ALLOCATE request_block.redundant_path_pp_list_p: [0 .. number_of_path] IN osv$mainframe_wired_heap^;
          FOR loop_index := LOWERVALUE (cmt$physical_equipment_number) TO number_of_path DO
            request_block.redundant_path_pp_list_p^ [loop_index] := redundant_path_pp_list [loop_index];
          FOREND;

          { Determine all logical units that need to be changed.

          build_logical_unit_list (element_p^, FALSE {ignore_controller_state},
                request_block.update_controller_address, new_state, pp, request_block.logical_unit_list_p,
                count);
          IF count <> 0 THEN
            ALLOCATE request_block.logical_unit_list_p: [1 .. count] IN osv$mainframe_wired_heap^;
            build_logical_unit_list (element_p^, FALSE {ignore_controller_state},
                  request_block.update_controller_address, new_state, pp, request_block.logical_unit_list_p,
                  count);

            IF new_state <> cmc$on THEN

              { Make sure all units on the current channel have redundant access.
              { If not, they have to be non critical devices.

              validate_all_units (request_block.logical_unit_list_p, redundant_path_pp_list, number_of_path,
                    found_critical_device);
              IF found_critical_device THEN
                osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_system_critical_element,
                      text, status);
                EXIT /main_program/;
              IFEND;
            IFEND;
          IFEND;

          FOR loop_index := LOWERVALUE (cmt$physical_equipment_number) TO number_of_path DO

            { If there is not a PP in the channel(s) and if the new state is not ON then acquire the PP
            { all redundant path(s).  If the new state is ON, and the redundant channel(s) is inactive
            { then there is no need to acquire PP.

            channel_data.element_type := cmc$data_channel_element;
            cmp$convert_iou_number (redundant_channel_list [loop_index].iou, channel_data.data_channel.iou,
                  status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            channel_data.data_channel.number := redundant_channel_list [loop_index].channel.number;
            channel_data.data_channel.port := redundant_channel_list [loop_index].channel.port;
            channel_data.data_channel.concurrent := redundant_channel_list [loop_index].channel.concurrent;
            cmp$get_logical_pp_index (channel_data, logical_pp_index, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            IF NOT cmv$logical_pp_table_p^ [logical_pp_index].flags.resources_acquired AND
                  (new_state <> cmc$on) THEN
              physical_channel.number := redundant_channel_list [loop_index].channel.number;
              physical_channel.port := redundant_channel_list [loop_index].channel.port;
              physical_channel.concurrent := redundant_channel_list [loop_index].channel.concurrent;

              cmp$reacquire_resources (dsc$rrt_get_pp, physical_channel,
                    redundant_channel_list [loop_index].iou, cmc$null_equipment_number,
                    cmc$null_unit_number, driver_name, pp_table_rma_list [loop_index], controller_type,
                    TRUE, status);
              IF NOT status.normal THEN

                { If system critical element, return error because we cannot get a pp
                { or load the driver on the redundant channel.

                IF system_critical_element THEN
                  osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_system_critical_element,
                        text, status);
                  EXIT /main_program/;
                IFEND;
              IFEND;
            IFEND;
          FOREND;
        ELSE

          { Return error if system critical element and there is not redundant channel available.

          IF system_critical_element AND (new_state <> cmc$on) THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_system_critical_element, text,
                  status);
            EXIT /main_program/;
          IFEND;
        IFEND;
      IFEND;

      CASE element_type OF
      = cmc$data_channel_element =
        request_block.channel_pp := pp;
        request_block.channel := channel.number;
      = cmc$controller_element =
        request_block.controller_pp := pp;
        request_block.controller_channel := channel.number;
        request_block.controller := controller;
      = cmc$storage_device_element =
        request_block.unit_pp := pp;
        request_block.unit_channel := channel.number;
        request_block.unit_controller := controller;
        request_block.logical_unit := logical_unit;
      ELSE
        EXIT /main_program/;
      CASEND;

      i#call_monitor (#LOC (request_block) , #SIZE (request_block));
      IF NOT request_block.status.normal THEN
        status.normal := FALSE;
        status.condition := request_block.status.condition;
      IFEND;
    END /main_program/;

    IF request_block.logical_unit_list_p <> NIL THEN
      FREE request_block.logical_unit_list_p IN osv$mainframe_wired_heap^;
    IFEND;
    IF request_block.redundant_path_pp_list_p <> NIL THEN
      FREE request_block.redundant_path_pp_list_p IN osv$mainframe_wired_heap^;
    IFEND;

  PROCEND cmp$change_state_r1;

?? OLDTITLE ??
?? NEWTITLE := 'cmp$configure_system_device', EJECT ??
*copy cmh$configure_system_device

  PROCEDURE [XDCL, #GATE] cmp$configure_system_device
    (VAR status: ost$status);

    VAR
      acquire_by_channel: boolean,
      acquire_tape_by_channel: boolean,
      channel_descriptor: cmt$channel_descriptor,
      channel_definition: cmt$data_channel_definition,
      channel: cmt$physical_channel,
      cm_unit_type: cmt$unit_type,
      controller_type: cmt$controller_type,
      disk_controller_type: cmt$controller_type,
      dual_pp: boolean,
      equipment_number: 0 .. cmc$max_equipment_per_channel,
      found: boolean,
      i: integer,
      ignore_alternate: dst$driver_name,
      io_unit_type: iot$unit_type,
      iou: dst$iou_number,
      iou_information_table: dst$iou_information_table,
      iou_number: dst$iou_number,
      iou_program_name: dst$driver_name,
      local_status: ost$status,
      need_to_load_controlware: boolean,
      number_of_ious: dst$number_of_ious,
      pc_entries: ARRAY [1 .. 6] OF cmt$element_definition,
      pp_count: iot$pp_number,
      state_entries: ARRAY [1 .. 6] OF cmt$state_information,
      unit_class: cmt$unit_class,
      unit_count: 0 .. 2,
      unit_number: 0 .. cmc$max_units_per_controller;

    status.normal := TRUE;
    #keypoint (osk$entry, 0, cmk$configure_system_device);

  /main_program/
    BEGIN

      { Initialize channel entry.

      pc_entries [1].element_name := cmv$system_device_data [cmc$sdt_disk_device].channel_name;
      pc_entries [1].product_id.product_number := ' ';
      pc_entries [1].product_id.underscore := ' ';
      pc_entries [1].product_id.model_number := ' ';
      pc_entries [1].element_type := cmc$data_channel_element;
      cmp$convert_iou_number (cmv$system_device_data [cmc$sdt_disk_device].iou_number, channel_descriptor.iou,
            status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      channel_descriptor.use_logical_identification := TRUE;
      channel_descriptor.name := cmv$system_device_data [cmc$sdt_disk_device].channel_name;
      cmp$get_channel_def (channel_descriptor, channel_definition, status);
      IF NOT status.normal THEN
        osp$system_error ('Unable to determine Channel characteristics in cmp$configure_system_device',
              ^status);
      IFEND;
      pc_entries [1].data_channel := channel_definition;
      pc_entries [1].data_channel.mainframe_ownership := ' ';
      cmp$get_unit_type (cmv$system_device_data [cmc$sdt_disk_device].unit_id, cm_unit_type, io_unit_type,
            unit_class, found);
      IF NOT found THEN
        osp$system_error ('Unknown Unit type', ^status);
      IFEND;
      IF cm_unit_type = cmc$ms895_2 THEN
        pp_count := 2;
      ELSE
        pp_count := 1;
      IFEND;

      FOR i := 0 TO UPPERVALUE (cmt$physical_equipment_number) DO
        pc_entries [1].data_channel.connection.equipment [i].configured := FALSE;
      FOREND;

      IF cm_unit_type = cmc$mshydra THEN
        pc_entries [1].data_channel.connection.equipment
              [cmv$system_device_data [cmc$sdt_disk_device].unit_number].configured := TRUE;
        pc_entries [1].data_channel.connection.equipment
              [cmv$system_device_data [cmc$sdt_disk_device].unit_number].element_name :=
              cmv$system_device_data [cmc$sdt_disk_device].unit_name;
      ELSE
        pc_entries [1].data_channel.connection.equipment
              [cmv$system_device_data [cmc$sdt_disk_device].equipment_number].configured := TRUE;
        pc_entries [1].data_channel.connection.equipment
              [cmv$system_device_data [cmc$sdt_disk_device].equipment_number].element_name :=
              cmv$system_device_data [cmc$sdt_disk_device].equipment_name;
      IFEND;
      IF ((pc_entries [1].data_channel.number >= 12) AND (pc_entries [1].data_channel.number <= 15)) OR
            ((pc_entries [1].data_channel.number > 25) AND pc_entries [1].data_channel.concurrent) THEN
        cmp$set_illegal_channel_status (pc_entries [1].data_channel.number, cme$pc_unsupported_channel,
              status);
        EXIT /main_program/;
      IFEND;

      unit_count := 1;
      CASE cm_unit_type OF
      = cmc$ms844_4x .. cmc$ms885_4x =
        acquire_by_channel := FALSE;
      ELSE
        acquire_by_channel := TRUE;
      CASEND;

      { Initialize controller entry.

      IF cm_unit_type <> cmc$mshydra THEN
        pc_entries [2].element_name := cmv$system_device_data [cmc$sdt_disk_device].equipment_name;
        pc_entries [2].product_id := cmv$system_device_data [cmc$sdt_disk_device].equipment_id;
        pc_entries [2].element_type := cmc$controller_element;
        pc_entries [2].controller.physical_equipment_number :=
              cmv$system_device_data [cmc$sdt_disk_device].equipment_number;
        pc_entries [2].controller.connection.port [0].configured := TRUE;
        pc_entries [2].controller.connection.port [0].element_name :=
              cmv$system_device_data [cmc$sdt_disk_device].channel_name;
        pc_entries [2].controller.connection.port [0].upline_connection_type := cmc$data_channel_element;
        pc_entries [2].controller.connection.port [0].mainframe_ownership := '  ';
        pc_entries [2].controller.connection.port [0].iou := pc_entries [1].data_channel.iou;

        FOR i := 1 TO UPPERVALUE (cmt$controller_port_number) DO
          pc_entries [2].controller.connection.port [i].configured := FALSE;
        FOREND;

        FOR i := 0 TO UPPERVALUE (cmt$physical_unit_number) DO
          pc_entries [2].controller.connection.unit [i].configured := FALSE;
        FOREND;

        pc_entries [2].controller.connection.unit
              [cmv$system_device_data [cmc$sdt_disk_device].unit_number].configured := TRUE;
        pc_entries [2].controller.connection.unit
              [cmv$system_device_data [cmc$sdt_disk_device].unit_number].element_name :=
              cmv$system_device_data [cmc$sdt_disk_device].unit_name;
      IFEND;

      { Initialize the storage device entry.

      pc_entries [3].element_name := cmv$system_device_data [cmc$sdt_disk_device].unit_name;
      pc_entries [3].product_id := cmv$system_device_data [cmc$sdt_disk_device].unit_id;
      pc_entries [3].element_type := cmc$storage_device_element;
      pc_entries [3].storage_device.physical_unit_number :=
            cmv$system_device_data [cmc$sdt_disk_device].unit_number;
      pc_entries [3].storage_device.connection.port [0].configured := TRUE;

      IF cm_unit_type = cmc$mshydra THEN
        pc_entries [3].storage_device.connection.port [0].element_name :=
              cmv$system_device_data [cmc$sdt_disk_device].channel_name;
        pc_entries [3].storage_device.connection.port [0].upline_connection_type := cmc$data_channel_element;
        pc_entries [3].storage_device.connection.port [0].mainframe_ownership := '  ';
        pc_entries [3].storage_device.connection.port [0].iou := pc_entries [1].data_channel.iou;
      ELSE
        pc_entries [3].storage_device.connection.port [0].element_name :=
              cmv$system_device_data [cmc$sdt_disk_device].equipment_name;
        pc_entries [3].storage_device.connection.port [0].upline_connection_type := cmc$controller_element;
      IFEND;

      FOR i := 1 TO UPPERVALUE (cmt$data_storage_port_number) DO
        pc_entries [3].storage_device.connection.port [i].configured := FALSE;
      FOREND;

      IF cmv$system_device_data [cmc$sdt_tape_device].specified THEN
        cmp$build_pct (6, pc_entries, status);
      ELSE
        cmp$build_pct (3, pc_entries, status);
      IFEND;
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      cmp$get_unit_type (cmv$system_device_data [cmc$sdt_disk_device].unit_id, cm_unit_type, io_unit_type,
            unit_class, found);
      IF cm_unit_type <> cmc$mshydra THEN
        cmp$get_controller_type (cmv$system_device_data [cmc$sdt_disk_device].equipment_id,
              disk_controller_type, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        cmp$convert_iou_name (cmv$physical_configuration^ [1].data_channel.iou, iou, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        cmp$get_driver_by_controller (disk_controller_type,
              cmv$physical_configuration^ [1].data_channel.concurrent, iou, iou_program_name,
              ignore_alternate);
        cmv$physical_configuration^ [2].controller.peripheral_driver_name := iou_program_name;
      ELSE
        disk_controller_type := cmc$mshydra_ct;
      IFEND;

      FOR i := 1 TO 6 DO
        state_entries [i].application_info_size := 0;
        state_entries [i].application_info_p := NIL;
        state_entries [i].site_info_size := 0;
        state_entries [i].site_info_p := NIL;
      FOREND;

      state_entries [1].element_name := cmv$system_device_data [cmc$sdt_disk_device].channel_name;
      state_entries [1].element_type := cmc$data_channel_element;
      state_entries [1].status.state := cmc$on;
      state_entries [1].iou := pc_entries [1].data_channel.iou;
      IF cm_unit_type <> cmc$mshydra THEN
        state_entries [2].element_name := cmv$system_device_data [cmc$sdt_disk_device].equipment_name;
        state_entries [2].element_type := cmc$controller_element;
        state_entries [2].status.state := cmc$on;
        state_entries [2].product_id := cmv$system_device_data [cmc$sdt_disk_device].equipment_id;
        state_entries [2].logical_unit := 0;
      ELSE
        state_entries [2].element_name := ' ';
      IFEND;
      state_entries [3].element_name := cmv$system_device_data [cmc$sdt_disk_device].unit_name;
      state_entries [3].element_type := cmc$storage_device_element;
      state_entries [3].status.state := cmc$on;
      state_entries [3].product_id := cmv$system_device_data [cmc$sdt_disk_device].unit_id;
      state_entries [3].logical_unit := cmc$job_template_unit_ordinal;

      { Set up the IOU table based on the number of IOUs, and also allocate the appropriate number
      { of channel lock

      dsp$retrieve_iou_information (number_of_ious, iou_information_table);
      cmp$build_iou_table (number_of_ious, iou_information_table);

      IF cmv$system_device_data [cmc$sdt_tape_device].specified THEN
        configure_ds_device (status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        state_entries [4].element_type := cmc$data_channel_element;
        state_entries [4].element_name := cmv$system_device_data [cmc$sdt_tape_device].channel_name;
        state_entries [4].status.state := cmc$on;
        state_entries [4].iou := 'IOU0';
        state_entries [5].element_name := cmv$system_device_data [cmc$sdt_tape_device].equipment_name;
        state_entries [5].element_type := cmc$controller_element;
        state_entries [5].status.state := cmc$on;
        state_entries [5].product_id := cmv$system_device_data [cmc$sdt_tape_device].equipment_id;
        state_entries [5].logical_unit := 0;
        state_entries [6].element_name := cmv$system_device_data [cmc$sdt_tape_device].unit_name;
        state_entries [6].element_type := cmc$storage_device_element;
        state_entries [6].status.state := cmc$on;
        state_entries [6].product_id := cmv$system_device_data [cmc$sdt_tape_device].unit_id;
        state_entries [6].logical_unit := cmc$job_template_unit_ordinal + 1;
        cmp$build_state_table (6, state_entries, {use_mrt_state=} FALSE, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        cmp$get_controller_type (cmv$system_device_data [cmc$sdt_tape_device].equipment_id,
              controller_type, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        acquire_tape_by_channel := (controller_type = cmc$mt5698_xx) OR
          (((controller_type = cmc$mt698_xx) OR (controller_type = cmc$mt5680_xx)) AND
            (osv$170_os_type = osc$ot7_dual_state_nos_be)) OR
             (controller_type = cmc$mt7221_1);

        cmp$convert_iou_name (cmv$physical_configuration^ [4].data_channel.iou, iou, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        cmp$get_driver_by_controller (controller_type,
              cmv$physical_configuration^ [4].data_channel.concurrent, iou, iou_program_name,
              ignore_alternate);
        cmv$physical_configuration^ [5].controller.peripheral_driver_name := iou_program_name;

        cmp$get_unit_type (cmv$system_device_data [cmc$sdt_tape_device].unit_id, cm_unit_type, io_unit_type,
              unit_class, found);
        need_to_load_controlware := (cm_unit_type = cmc$mt639_1) OR (cm_unit_type = cmc$mt639_s0) OR
              (cm_unit_type = cmc$mt698_3x) OR (cm_unit_type = cmc$mt5682_1x);
        IF controller_type = cmc$mt5680_xx THEN
          pp_count := pp_count + 2;
        ELSE
          pp_count := pp_count + 1;
        IFEND;
        unit_count := 2;
      ELSE
        cmp$build_state_table (3, state_entries, {use_mrt_state=} FALSE, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      cmp$build_interface_tables (pp_count, unit_count, FALSE, cmv$logical_unit_table,
            cmv$logical_pp_table_p, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      cmv$max_number_of_pp := pp_count;

      IF cmv$system_device_data [cmc$sdt_tape_device].specified THEN
        channel.number := cmv$physical_configuration^ [4].data_channel.number;
        channel.concurrent := cmv$physical_configuration^ [4].data_channel.concurrent;
        channel.port := cmv$physical_configuration^ [4].data_channel.port;
        iou_number := cmv$system_device_data [cmc$sdt_tape_device].iou_number;
        IF acquire_tape_by_channel THEN
          unit_number := cmc$null_unit_number;
          equipment_number := cmc$null_equipment_number;
        ELSE
          unit_number := cmv$physical_configuration^ [6].storage_device.physical_unit_number;
          equipment_number := cmv$physical_configuration^ [5].controller.physical_equipment_number;
        IFEND;

        IF need_to_load_controlware THEN
          cmp$load_controller_module (cmc$load_controlware, cmv$logical_pp_table_p, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;

        cmp$acquire_deadstart_resources (channel, iou_number, equipment_number, unit_number, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        iop$tape_initialization (cmv$logical_unit_table, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      channel.number := pc_entries [1].data_channel.number;
      channel.port := pc_entries [1].data_channel.port;
      channel.concurrent := pc_entries [1].data_channel.concurrent;
      iou_number := cmv$system_device_data [cmc$sdt_disk_device].iou_number;

      IF acquire_by_channel THEN
        unit_number := cmc$null_unit_number;
        equipment_number := cmc$null_equipment_number;
      ELSE
        unit_number := pc_entries [3].storage_device.physical_unit_number;
        equipment_number := pc_entries [2].controller.physical_equipment_number;
      IFEND;

      { Load the controlware from the CIP device to memory.

      cmp$load_controller_module (cmc$load_controlware, cmv$logical_pp_table_p, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      { Load the control module from the CIP device to memory.

      IF (disk_controller_type = cmc$ms7255_1_1) OR (disk_controller_type = cmc$ms7255_1_2) THEN
        cmp$load_controller_module (cmc$load_control_module, cmv$logical_pp_table_p, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
      IFEND;

      cmp$acquire_deadstart_resources (channel,iou_number, equipment_number, unit_number, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      cmv$system_device_pp.software_idle := TRUE;

    END /main_program/;

    #keypoint (osk$exit, 0, cmk$configure_system_device);

  PROCEND cmp$configure_system_device;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$create_cm_device_files', EJECT ??
*copy cmh$create_cm_device_files

  PROCEDURE [XDCL] cmp$create_cm_device_files
    (VAR status: ost$status);

    VAR
      file_modified: boolean,
      fmd_modified: boolean,
      lc_max_size: integer,
      system_file_id: dmt$system_file_id,
      p_file_attributes: ARRAY [1 .. 1] OF dmt$new_device_file_attribute;

    status.normal := TRUE;

    p_file_attributes [1].keyword := dmc$clear_space;
    p_file_attributes [1].required := FALSE;

    lc_max_size := 8 * 64 * #SIZE (cmt$element_definition) + #SIZE (cmt$device_file_header);
    dmp$create_device_file (cmc$physical_configuration_file, dmv$system_device_recorded_vsn,
          ^p_file_attributes, lc_max_size, system_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$detach_device_file (system_file_id, file_modified, fmd_modified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmv$new_device_file.recorded_vsn := dmv$system_device_recorded_vsn;
    cmv$new_device_file.version := 'ORIGINAL VERSION NUMBER 1';
    cmv$new_device_file.relative_time := cmc$rt_new;

  PROCEND cmp$create_cm_device_files;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$disable_unit', EJECT ??

{ PURPOSE:
{   This procedure sets the disable bit to true in the unit interface table of the corresponding logical unit.
{   This interface is intended to be used when DOWNing or OFFing elements other than mass storages (i.e, tape,
{   etc .. )

  PROCEDURE [XDCL, #GATE] cmp$disable_unit
    (    logical_unit_number: iot$logical_unit);

    IF cmv$logical_unit_table^ [logical_unit_number].unit_interface_table <> NIL THEN
      IF NOT cmv$logical_unit_table^ [logical_unit_number].unit_interface_table^.unit_lockword.lock AND
            NOT cmv$logical_unit_table^ [logical_unit_number].unit_interface_table^.unit_q_lockword.lock
            THEN
        cmv$logical_unit_table^ [logical_unit_number].unit_interface_table^.unit_status.disabled := TRUE;
      IFEND;
    IFEND;

  PROCEND cmp$disable_unit;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$enable_unit', EJECT ??

{ PURPOSE:
{   This procedure sets the disable bit to FALSE in the unit interface table of the corresponding logical
{   unit. This interface is intended to be used when ONing non mass storage devices such as tape units.

  PROCEDURE [XDCL, #GATE] cmp$enable_unit
    (    logical_unit_number: iot$logical_unit);

    IF cmv$logical_unit_table^ [logical_unit_number].unit_interface_table <> NIL THEN
      cmv$logical_unit_table^ [logical_unit_number].unit_interface_table^.unit_lockword.lock := FALSE;
      cmv$logical_unit_table^ [logical_unit_number].unit_interface_table^.unit_lockword.lock_owner.cpu_lock :=
           FALSE;
     cmv$logical_unit_table^ [logical_unit_number].unit_interface_table^.unit_lockword.lock_owner.fill := 0;
     cmv$logical_unit_table^ [logical_unit_number].unit_interface_table^.unit_lockword.lock_owner.pp_number :=
           0;
     cmv$logical_unit_table^ [logical_unit_number].unit_interface_table^.unit_q_lockword.lock := FALSE;
     cmv$logical_unit_table^ [logical_unit_number].unit_interface_table^.unit_q_lockword.lock := FALSE;
     cmv$logical_unit_table^ [logical_unit_number].unit_interface_table^.unit_q_lockword.lock_owner.cpu_lock
           := FALSE;
     cmv$logical_unit_table^ [logical_unit_number].unit_interface_table^.unit_q_lockword.lock_owner.fill := 0;
     cmv$logical_unit_table^ [logical_unit_number].unit_interface_table^.unit_q_lockword.lock_owner.pp_number
           := 0;
     cmv$logical_unit_table^ [logical_unit_number].unit_interface_table^.next_request := NIL;
     cmv$logical_unit_table^ [logical_unit_number].unit_interface_table^.next_request_rma := 0;
     cmv$logical_unit_table^ [logical_unit_number].unit_interface_table^.unit_status.disabled := FALSE;
   IFEND;

  PROCEND cmp$enable_unit;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_connected_elements', EJECT ??

{ PURPOSE:
{   This procedure returns a list of element name connected to a channel.  The list of names must be
{   allocated by caller.

  PROCEDURE [XDCL, #GATE] cmp$get_connected_elements
    (    element: cmt$element_definition;
         element_name_list_p: {input, output} ^ARRAY [ * ] OF cmt$element_name;
      VAR number_of_entries: integer;
      VAR status: ost$status);

?? NEWTITLE := 'element_not_in_list', EJECT ??
    FUNCTION element_not_in_list
      (VAR element_name: cmt$element_name): boolean;

      VAR
        list_index: integer;

      element_not_in_list := TRUE;
      IF number_of_entries > 0 THEN

       /search_loop/
        FOR list_index := LOWERBOUND (element_name_list_p^) TO number_of_entries DO
          IF element_name_list_p^ [list_index] = element_name THEN
            element_not_in_list := FALSE;
            EXIT /search_loop/;
          IFEND;
        FOREND /search_loop/;
      IFEND;

    FUNCEND element_not_in_list;
?? OLDTITLE ??

    VAR
      pen: cmt$physical_equipment_number,
      table_index: integer;

    status.normal := TRUE;
    number_of_entries := 0;

    IF (element_name_list_p = NIL) OR (element.element_type <> cmc$data_channel_element) THEN
      RETURN;
    IFEND;

    IF cmv$physical_configuration = NIL THEN
      RETURN;
    IFEND;

   /loop/
    FOR table_index := LOWERBOUND (cmv$physical_configuration^) TO UPPERBOUND (cmv$physical_configuration^) DO
      IF (cmv$physical_configuration^ [table_index].element_type <> cmc$data_channel_element) THEN
        CYCLE /loop/;
      IFEND;

      IF (cmv$physical_configuration^ [table_index].data_channel.number <> element.data_channel.number) OR
            (cmv$physical_configuration^ [table_index].data_channel.concurrent <>
            element.data_channel.concurrent) OR
            (cmv$physical_configuration^ [table_index].data_channel.iou <> element.data_channel.iou) THEN
        CYCLE /loop/;
      IFEND;

      FOR pen := LOWERVALUE (cmt$physical_equipment_number) TO UPPERVALUE (cmt$physical_equipment_number) DO
        IF cmv$physical_configuration^ [table_index].data_channel.connection.equipment [pen].configured THEN
          IF number_of_entries < UPPERBOUND (element_name_list_p^) THEN

            { See if the element name already exists in the list before counting it.

            IF element_not_in_list (cmv$physical_configuration^ [table_index].
                  data_channel.connection.equipment [pen].element_name) THEN
              number_of_entries := number_of_entries + 1;
              element_name_list_p^ [number_of_entries] := cmv$physical_configuration^ [table_index].
                    data_channel.connection.equipment [pen].element_name;
            IFEND;
          ELSE

            { Users has not allocated enough entries in array element_name_list_p Return error.

            osp$set_status_abnormal (cmc$configuration_management_id, cme$pc_not_enough_entries, ' ', status);
            RETURN;
          IFEND;
        IFEND;
      FOREND;

      IF NOT element.data_channel.concurrent THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND cmp$get_connected_elements;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_cpu_element_r1', EJECT ??
*copyc cmh$get_cpu_element_r1

  PROCEDURE [XDCL, #GATE] cmp$get_cpu_element_r1
    (    processor_id: ost$processor_id;
         update_cst: boolean;
     VAR cpu_element: cmt$cpu_element_definition;
     VAR status: ost$status);


    VAR
      cpu_attributes: dst$cpu_attributes,
      element: ost$cpu_state_table,
      length: integer,
      str: string (3);

    status.normal := TRUE;

    IF processor_id > (osv$cpus_physically_configured - 1) THEN
      str (3) := $CHAR ($INTEGER ('0') + processor_id);
      str (1, 2) := 'CP';
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_element_not_found, str, status);
      RETURN;
    IFEND;

    IF update_cst THEN

      { Get the current CPU attributes from the MRT and update the CPU state table.

      dsp$get_cpu_attributes (cpu_attributes);

      IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
        IF ((cpu_attributes.cpu [processor_id].state = cmc$on) AND
             (mtv$cst0 [processor_id].processor_state = cmc$down)) THEN
          mtv$cst0 [processor_id].next_processor_state := cmc$on;
          mtv$cst0 [processor_id].previous_processor_state := cmc$down;
          mtv$cst0 [processor_id].log_cpu_state_change := TRUE;
          mtv$cy2000_sp_recovery := TRUE;
        ELSE
          mtv$cst0 [processor_id].processor_state :=
                cpu_attributes.cpu [processor_id].state;
        IFEND;
      ELSE
        mtv$cst0 [processor_id].processor_state := cpu_attributes.cpu [processor_id].state;
      IFEND;

      IF cpu_attributes.cpu [processor_id].state = cmc$down THEN
        IF cpu_attributes.cpu [processor_id].down_reason = dsc$pdr_down_by_operator THEN
          mtv$cst0 [processor_id].reason_for_current_state := osc$cdsr_downed_by_operator;
        ELSEIF (cpu_attributes.cpu [processor_id].down_reason = dsc$pdr_down_by_system) AND
              (mtv$cst0 [processor_id].reason_for_current_state = osc$cdsr_downed_by_dft) THEN

          { Don't change the CST!  It is the only place that we retain the fact that the CPU was downed by
          { DFT; the MRT can't "remember" this reason for all CYBER models.

        ELSE
          mtv$cst0 [processor_id].reason_for_current_state := osc$cdsr_downed_by_system;
        IFEND;
      ELSE {processor not down}
        mtv$cst0 [processor_id].reason_for_current_state := osc$cdsr_null;
      IFEND;
    IFEND;

    cpu_element.element_number := mtv$cst0 [processor_id].element_id.element_number;
    cpu_element.model_number := mtv$cst0 [processor_id].element_id.model_number;
    cpu_element.serial_number := mtv$cst0 [processor_id].element_id.serial_number;
    cpu_element.processor_state := mtv$cst0 [processor_id].processor_state;
    cpu_element.reason_for_current_state := mtv$cst0 [processor_id].reason_for_current_state;


  PROCEND cmp$get_cpu_element_r1;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_mainframe_element', EJECT ??
*copy cmh$get_mainframe_element

  PROCEDURE [XDCL, #GATE] cmp$get_mainframe_element
    (    element_name: cmt$element_name;
         iou_name: cmt$element_name;
     VAR mainframe_element: cmt$element_definition;
     VAR status: ost$status);

    VAR
      element_p: ^cmt$element_definition;

    status.normal := TRUE;
    cmp$pc_get_element (element_name, iou_name, element_p, status);
    IF status.normal THEN
      mainframe_element := element_p^;
    IFEND;

  PROCEND cmp$get_mainframe_element;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_ms_class_on_volume_r1', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_ms_class_on_volume_r1
    (    recorded_vsn: rmt$recorded_vsn;
     VAR volume_found: boolean;
     VAR ms_class_info: cmt$ms_class_info);

    VAR
      i: integer,
      ms_class: cmt$ms_class_members;

    volume_found := FALSE;

  /search_avt/
    FOR i := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND (dmv$p_active_volume_table^) DO
      IF recorded_vsn <> dmv$p_active_volume_table^ [i].mass_storage.recorded_vsn THEN
        CYCLE /search_avt/;
      IFEND;

      IF dmv$p_active_volume_table^ [i].entry_available THEN
        RETURN;
      IFEND;

      volume_found := TRUE;
      EXIT /search_avt/;
    FOREND /search_avt/;

    IF NOT volume_found THEN
      RETURN;
    IFEND;

    FOR ms_class := lowerbound(ms_class_info) TO UPPERBOUND(ms_class_info) DO
      IF (ms_class IN dmv$p_active_volume_table^ [i].mass_storage.class) AND
            (NOT dmv$p_active_volume_table^ [i].mass_storage.volume_unavailable) THEN
        ms_class_info[ms_class] := TRUE;
      ELSE
        ms_class_info[ms_class] := FALSE;
      IFEND;
    FOREND;

  PROCEND cmp$get_ms_class_on_volume_r1;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_ms_logical_unit_numbers', EJECT ??
*copy cmh$get_ms_logical_unit_numbers

  PROCEDURE [XDCL] cmp$get_ms_logical_unit_numbers
    (VAR ms_logical_unit_list: cmt$ms_logical_unit_list;
     VAR list_count: iot$logical_unit;
     VAR status: ost$status);

    VAR
      cm_unit_type: cmt$unit_type,
      io_unit_type: iot$unit_type,
      found: boolean,
      unit_class: cmt$unit_class,
      lun: iot$logical_unit,
      element_p: ^cmt$element_definition,
      local_status: ost$status,
      high_list: integer;

    status.normal := TRUE;
    high_list := UPPERBOUND (ms_logical_unit_list);
    list_count := 0;

    FOR lun := cmc$job_template_unit_ordinal TO UPPERVALUE (lun) DO
      cmp$pc_get_logical_unit (lun, element_p, local_status);
      IF NOT local_status.normal THEN
        RETURN;
      IFEND;

      cmp$get_unit_type (element_p^.product_id, cm_unit_type, io_unit_type, unit_class, found);
      IF found AND (unit_class = cmc$mass_storage_unit) THEN
        list_count := list_count + 1;
        IF list_count <= high_list THEN
          ms_logical_unit_list [list_count].lun := lun;
          ms_logical_unit_list [list_count].pid := element_p^.product_id;
        IFEND;
      IFEND;
    FOREND;

  PROCEND cmp$get_ms_logical_unit_numbers;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$manage_device_file_lock ' , EJECT ??

{ PURPOSE:
{   This procedure Set/Clear device file lock to prevent deadlock situation where two tasks are trying to
{   update the physical configuration device file at the same time.

  PROCEDURE [XDCL, #GATE] cmp$manage_device_file_lock
    (    set_lock: boolean;
     VAR status: ost$status);

    status.normal := TRUE;
    IF set_lock THEN
      osp$set_signature_lock (cmv$device_file_lock, osc$wait, status);
    ELSE
      osp$clear_signature_lock (cmv$device_file_lock, status);
    IFEND;

  PROCEND cmp$manage_device_file_lock;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$process_cpu_state_change_r1', EJECT ??

{ PURPOSE:
{   This procedure processes the "front end" of a CPU state change.  It sets up flags which are processed in
{   monitor mode (MTP$MONITOR_PROCESSOR_STATUS) to drive the CPU to the desired state.  The "back end" is
{   done after monitor mode sets a system flag in the $SYSTEM job's $JOBMONITOR task to finalize the CPU
{   state change processing in job mode (SYP$MFH_CPU_CONFIG_CHANGE), where the DFT request is made to change
{   the processor's state.

  PROCEDURE [XDCL, #GATE] cmp$process_cpu_state_change_r1
    (    processor_id: ost$processor_id;
         new_state: cmt$element_state;
     VAR status: ost$status);

    VAR
      cpu_attributes: dst$cpu_attributes,
      cst_p: ^ost$cpu_state_table,
      rb: dst$rb_system_deadstart_status;

    status.normal := TRUE;
    cst_p := ^mtv$cst0 [processor_id];

    cst_p^.previous_processor_state := cst_p^.processor_state;
    IF cst_p^.processor_state = cmc$on THEN

      { The CPU can be placed in the new state by the operator.

      cst_p^.pre_processed_for_reconfig := osc$ppfr_processing_in_progress;
      cst_p^.reason_for_current_state := osc$cdsr_downed_by_operator;
      cst_p^.next_processor_state := new_state;

    ELSEIF new_state = cmc$on THEN

      dsp$get_cpu_attributes (cpu_attributes);
      IF cpu_attributes.cpu [processor_id].vectors_not_available THEN
        mtv$scb.vector_simulation_control.vector_divide_degraded :=
              mtv$scb.vector_simulation_control.vector_divide_degraded + $ost$processor_id_set [processor_id];
      ELSE
        mtv$scb.vector_simulation_control.vector_divide_degraded :=
              mtv$scb.vector_simulation_control.vector_divide_degraded - $ost$processor_id_set [processor_id];
      IFEND;

      { The processor is DOWN, and the CPU can be placed in the new state by the operator.
      { (The processor_state of OFF is caught in caller of this procedure.)

      IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
        IF ((cpu_attributes.cpu [processor_id].state = cmc$on) AND
              (cst_p^.processor_state = cmc$down)) THEN
          cst_p^.next_processor_state := cmc$on;
          cst_p^.previous_processor_state := cmc$down;
          cst_p^.log_cpu_state_change := TRUE;
          mtv$cy2000_sp_recovery := TRUE;
        ELSE
          cst_p^.processor_state :=
            cpu_attributes.cpu [processor_id].state;
        IFEND;
      ELSE
        mtv$cst0 [processor_id].processor_state := cpu_attributes.cpu [processor_id].state;
      IFEND;

      cst_p^.cpu_alive_flag := #FREE_RUNNING_CLOCK (0);
      cst_p^.next_processor_state := new_state;

      { Restore the values for the 'cache purged' and/or 'page map purged' times for the deconfigured CPU.
      { The following lines are necessary to enable this CPU to purge its cache and/or page maps.

      cst_p^.time_last_cache_purge := 0;
      cst_p^.time_last_map_request := 0;

      rb.reqcode := syc$rc_system_deadstart_status;
      rb.action := dsc$rb_sds_clear_bct_flag;
      rb.bct_flags := dsc$rb_sds_bct_both_cpu_error;
      i#call_monitor (#LOC (rb), #SIZE (rb));
    IFEND;

  PROCEND cmp$process_cpu_state_change_r1;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$search_redundant_path ', EJECT ??

{ PURPOSE:
{   This procedures searches for an available redundant channel given the primary channel definition. It
{   returns the driver name, the controller type and the RMA to the PPIT of the redundant channel.
{ NOTE:
{   A channel is redundant if it is connected to a certain group of disk and tape subsystems and if it is
{   not the first on channel in the connection.

  PROCEDURE [XDCL, #GATE] cmp$search_redundant_path
    (    primary_path_element: cmt$element_definition;
         iou: dst$iou_number;
         channel: cmt$physical_channel;
         new_state: cmt$element_state;
     VAR redundant_path_available: boolean;
     VAR update_controller_address: boolean;
     VAR number_of_path: integer;
     VAR redundant_channel_list: array [cmt$physical_equipment_number] of cmt$physical_address;
     VAR redundant_path_pp_list: array [cmt$physical_equipment_number] of iot$pp_number;
     VAR driver_name: pmt$program_name;
     VAR pp_table_rma_list: array [cmt$physical_equipment_number] of ost$real_memory_address);

    VAR
      local_status: ost$status,
      lun: iot$logical_unit,
      physical_address: cmt$physical_address,
      pp: iot$pp_number,
      pp_found: boolean,
      ppit_p: ^iot$pp_interface_table,
      unit_desc: iot$unit_descriptor_entry;

    IF primary_path_element.element_type = cmc$data_channel_element THEN
      physical_address.address_specifier := $cmt$physical_address_specifier [cmc$iou, cmc$channel];
      physical_address.iou := iou;
      physical_address.channel.number := primary_path_element.data_channel.number;
      physical_address.channel.port := primary_path_element.data_channel.port;
      physical_address.channel.concurrent := primary_path_element.data_channel.concurrent;
    ELSEIF primary_path_element.element_type = cmc$controller_element THEN
      physical_address.address_specifier :=
            $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address];
      physical_address.iou := iou;
      physical_address.channel := channel;
      physical_address.channel_address := primary_path_element.controller.physical_equipment_number;
    ELSEIF primary_path_element.element_type = cmc$storage_device_element THEN
      cmp$get_logical_unit_number(primary_path_element.element_name, lun, local_status);
      IF NOT local_status.normal THEN
        redundant_path_available := FALSE;
        RETURN;
      IFEND;

      pp_found := FALSE;
    /pp_loop/
      FOR pp := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
        IF NOT cmv$logical_pp_table_p^ [pp].flags.configured THEN
          CYCLE /pp_loop/;
        IFEND;

        ppit_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;

        IF (lun < LOWERBOUND (ppit_p^.unit_descriptors)) OR (lun > UPPERBOUND (ppit_p^.unit_descriptors)) THEN
          CYCLE /pp_loop/;
        IFEND;

        unit_desc := ppit_p^.unit_descriptors [lun];

        IF unit_desc.unit_interface_table = NIL THEN
          CYCLE /pp_loop/;
        IFEND;

        IF unit_desc.logical_unit = lun THEN
          pp_found := TRUE;
          EXIT /pp_loop/;
        IFEND;
      FOREND /pp_loop/;

      IF NOT pp_found THEN
        redundant_path_available := FALSE;
        RETURN;
      IFEND;

      physical_address.address_specifier :=
            $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address, cmc$unit_address];
      physical_address.iou := iou;
      physical_address.channel := channel;
      physical_address.channel_address := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
            unit_descriptors [lun].physical_path.controller_number;
      physical_address.unit_address := primary_path_element.storage_device.physical_unit_number;
    ELSE
      redundant_path_available := FALSE;
      RETURN;
    IFEND;

    cmp$find_redundant_path (physical_address, new_state, redundant_path_available, update_controller_address,
          number_of_path, redundant_channel_list, redundant_path_pp_list, driver_name, pp_table_rma_list);

  PROCEND cmp$search_redundant_path;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$switch_tape_channel', EJECT ??

{ PURPOSE:
{   This procedure switch access to the redundant tape channel by going through the redundant pp's unit
{   descriptors and un-Nil the RMA to the UIT.

  PROCEDURE [XDCL, #GATE] cmp$switch_tape_channel
    (    primary_channel: cmt$element_definition;
         ignore_controller_state: boolean;
         number_of_redundant_path: integer;
         redundant_channel_list: ARRAY [cmt$physical_equipment_number] OF cmt$physical_address;
         new_state: cmt$element_state;
         redundant_pp_list: ARRAY [cmt$physical_equipment_number] OF iot$pp_number;
     VAR status: ost$status);

    VAR
      channel_data: cmt$element_definition,
      count: integer,
      index: integer,
      iou_number: dst$iou_number,
      logical_pp_index: iot$pp_number,
      primary_pp: iot$pp_number,
      request_block: cmt$request_block;

    status.normal := TRUE;
    cmp$get_logical_pp_index (primary_channel, primary_pp, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cmp$convert_iou_name (primary_channel.data_channel.iou, iou_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    request_block.request_code := syc$rc_config_mgmt_request;
    request_block.kind := cmc$rbk_change_state;
    request_block.element_name := primary_channel.element_name;
    request_block.new_state := new_state;
    request_block.iou := iou_number;
    request_block.element_type := cmc$data_channel_element;
    request_block.channel := primary_channel.data_channel.number;
    request_block.channel_pp := primary_pp;
    request_block.update_controller_address := FALSE;
    request_block.redundant_path_available := TRUE;
    request_block.redundant_path_pp_list_p := NIL;
    request_block.logical_unit_list_p := NIL;

    ALLOCATE request_block.redundant_path_pp_list_p: [0 .. number_of_redundant_path] IN
          osv$mainframe_wired_heap^;
    FOR index := LOWERVALUE (cmt$physical_equipment_number) TO number_of_redundant_path DO
      request_block.redundant_path_pp_list_p^ [index] := redundant_pp_list [index];
    FOREND;

    build_logical_unit_list (primary_channel, ignore_controller_state, FALSE, new_state, primary_pp,
          request_block.logical_unit_list_p, count);
    IF count <> 0 THEN
      ALLOCATE request_block.logical_unit_list_p: [1 .. count] IN osv$mainframe_wired_heap^;
      build_logical_unit_list (primary_channel, ignore_controller_state, FALSE, new_state, primary_pp,
            request_block.logical_unit_list_p, count);
    IFEND;

    i#call_monitor (#LOC (request_block), #SIZE (request_block));
    IF request_block.logical_unit_list_p <> NIL THEN
      FREE request_block.logical_unit_list_p IN osv$mainframe_wired_heap^;
    IFEND;
    IF request_block.redundant_path_pp_list_p <> NIL THEN
      FREE request_block.redundant_path_pp_list_p IN osv$mainframe_wired_heap^;
    IFEND;

    { See if PP on redundant channel(s) need to be returned.

    IF new_state = cmc$on THEN
      FOR index := LOWERVALUE (cmt$physical_equipment_number) TO number_of_redundant_path DO
        build_logical_unit_list (primary_channel, FALSE, FALSE, cmc$down, redundant_pp_list [index], NIL,
              count);
        channel_data.element_type := cmc$data_channel_element;
        cmp$convert_iou_number (redundant_channel_list [index].iou, channel_data.data_channel.iou, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        channel_data.data_channel.number := redundant_channel_list [index].channel.number;
        channel_data.data_channel.port := redundant_channel_list [index].channel.port;
        channel_data.data_channel.concurrent := redundant_channel_list [index].channel.concurrent;
        cmp$get_logical_pp_index (channel_data, logical_pp_index, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF cmv$logical_pp_table_p^ [logical_pp_index].flags.resources_acquired AND (count = 0) THEN
          cmp$release_pp_by_index (logical_pp_index, status);
        IFEND;
      FOREND;
    IFEND;

  PROCEND cmp$switch_tape_channel;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$zero_out_uit_rma', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$zero_out_uit_rma
    (    logical_unit: iot$logical_unit;
         channel: cmt$element_definition;
         new_state: cmt$element_state;
     VAR status: ost$status);

    VAR
      logical_pp: iot$pp_number,
      rma: integer;

    status.normal := TRUE;
    cmp$get_logical_pp_index (channel, logical_pp, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF new_state = cmc$on THEN
      i#real_memory_address (#LOC (cmv$logical_unit_table^ [logical_unit].unit_interface_table^), rma);
      cmv$logical_pp_table_p^ [logical_pp].pp_info.pp_interface_table_p^.
            unit_descriptors [logical_unit].unit_interface_table_rma := rma;
    ELSE
      cmv$logical_pp_table_p^ [logical_pp].pp_info.pp_interface_table_p^.
            unit_descriptors [logical_unit].unit_interface_table_rma := 0;
    IFEND;

  PROCEND cmp$zero_out_uit_rma;
?? OLDTITLE ??
MODEND cmm$physical_config_mgr_r1;
*DECK DECK=CMM$PHYS_CONFIGURATION_UTL_23D EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Physical Configuration Utility Ring 3.', EJECT ??
MODULE cmm$phys_configuration_utl_23d;

{ PURPOSE:
{    This module contains interfaces that manage various task private data
{    structures in the Physical Configuration Utility.

?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc cmc$pcu_parameter_indices
*copyc cme$logical_configuration_mgr
*copyc cme$logical_configuration_utl
*copyc cme$physical_configuration_utl
*copyc cmt$element_definition
*copyc cmt$lcu_display_option_key
*copyc cmt$pcu_command_descriptor
*copyc cmt$state_information
*copyc clt$data_value
*copyc clt$parameter_value_table
*copyc oss$task_private
?? POP ??
*copyc amp$close
*copyc amp$change_file_attributes
*copyc amp$get_segment_pointer
*copyc amp$get_file_attributes
*copyc amp$fetch_access_information
*copyc amp$get_file_attributes
*copyc amp$open
*copyc amp$put_next
*copyc amp$return
*copyc amp$rewind
*copyc amp$set_segment_eoi
*copyc clp$count_list_elements
*copyc clp$convert_string_to_file
*copyc clp$convert_data_to_string
*copyc clp$convert_integer_to_string
*copyc clp$get_work_area
*copyc clp$put_partial_display
*copyc clp$read_variable
*copyc clp$scan_command_file
*copyc clp$write_variable
*copyc cmp$acquire_all_peripherals
*copyc cmp$build_active_conf
*copyc cmp$build_conf_tables
*copyc cmp$check_reserved_names
*copyc cmp$check_for_unique_element
*copyc cmp$clean_up_error_count
*copyc cmp$convert_iou_name
*copyc cmp$echo_errors
*copyc cmp$find_element
*copyc cmp$known_controller_id
*copyc cmp$known_product_id
*copyc cmp$generate_error_listing
*copyc cmp$get_unit_type
*copyc cmp$get_channel_definition
*copyc cmp$get_controller_type
*copyc cmp$get_driver_by_controller
*copyc cmp$install_system_conf
*copyc cmp$open_scratch_err_file
*copyc cmp$set_active_flag
*copyc cmp$valid_channel_name
*copyc fsp$close_file
*copyc fsp$copy_file
*copyc fsp$open_file
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc pmp$generate_unique_name
*copyc pmp$get_mainframe_id
*copyc cmv$configuration_activated
*copyc cmv$reserved_names_list
*copyc osv$task_private_heap
*copyc osv$lower_to_upper
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations declared by This Module.', EJECT ??

  VAR
    cmv$pcu_error_count: [XDCL, #GATE] integer,
    cmv$cmd_value_name: amt$local_file_name,
    cmv$cmd_value_fid: amt$file_identifier,
    cmv$state_value_fid: amt$file_identifier,
    cmv$state_value_name: amt$local_file_name,
    cmv$output_fid: amt$file_identifier,
    cmv$in_editor: [XDCL, #GATE] boolean := FALSE,
    cmv$input_fid: amt$file_identifier,
    cmv$installed_mainframe: [XDCL, #GATE] cmt$element_name,
    cmv$mainframe_name: cmt$element_name;

  VAR
    cmv$executing_within_editor: [XDCL, #GATE] boolean := FALSE;

  VAR
    cmv$command_descriptor_p: [XDCL, #GATE, oss$task_private] ^cmt$pcu_command_descriptor := NIL;

  VAR
    cmv$end_list_p: [XDCL] ^cmt$pcu_command_descriptor := NIL;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$add_definition ', EJECT ??

{ PURPOSE:
{    This procedure adds a command line to the current
{    edited configuration file

  PROCEDURE [XDCL, #GATE] cmp$add_definition
    (    definition: cmt$pcu_command_descriptor;
     VAR status: ost$status);

    VAR
      current_p: ^cmt$pcu_command_descriptor,
      i: integer;

    status.normal := TRUE;
    ALLOCATE current_p IN osv$task_private_heap^;
    initialize_descriptor (current_p^);
    current_p^ := definition;

    IF cmv$command_descriptor_p = NIL THEN

      cmv$command_descriptor_p := current_p;
      cmv$end_list_p := current_p;
    ELSE
      cmv$end_list_p^.next_descriptor := current_p;
      cmv$end_list_p := current_p;
    IFEND;

  PROCEND cmp$add_definition;


?? OLDTITLE ??
?? NEWTITLE := '   cmp$build_descriptor', EJECT ??

{ PURPOSE:
{    This procedure builds a single linked list of
{    commands from the input file.
{    Each node will contain one command line, a
{    head of list and an end of list pointer will be kept
{    global thru out the editing session

  PROCEDURE [XDCL, #GATE] cmp$build_descriptor
    (    definition: cmt$pcu_command_descriptor;
     VAR status: ost$status);

    VAR
      i: integer,
      temp_p: ^cmt$pcu_command_descriptor;

    status.normal := TRUE;

    ALLOCATE temp_p IN osv$task_private_heap^;
    temp_p^ := definition;
    temp_p^.next_descriptor := NIL;

    IF cmv$command_descriptor_p = NIL THEN
      cmv$command_descriptor_p := temp_p;
      cmv$end_list_p := cmv$command_descriptor_p;
    ELSE
      cmv$end_list_p^.next_descriptor := temp_p;
      cmv$end_list_p := temp_p;
    IFEND;
  PROCEND cmp$build_descriptor;


?? OLDTITLE ??
?? NEWTITLE := '   cmp$change_connection_ref_r3', EJECT ??

{ PURPOSE:
{    This procedure updates the connection references of the DEFINE_ELEMENT
{    subcommands in the edited physical configuration file.

  PROCEDURE [XDCL, #GATE] cmp$change_connection_ref_r3
    (    old_channel_list: ^clt$data_value;
         new_channel_list: ^clt$data_value;
         old_mainframe_list: ^clt$data_value;
         new_mainframe_list: ^clt$data_value;
         old_peripheral: cmt$element_name;
         new_peripheral: cmt$element_name;
     VAR status: ost$status);

    VAR
      channel_len: integer,
      current_p: ^cmt$pcu_command_descriptor,
      field_index: integer,
      index: integer,
      iou_len: integer,
      len: integer,
      mainframe_len: integer,
      message: string (256),
      npn: cmt$element_name,
      ncn_channel: cmt$element_name,
      ncn_mainframe: cmt$element_name,
      ncn_iou: cmt$element_name,
      nmn_mainframe: cmt$element_name,
      nmn_iou: cmt$element_name,
      ocn_channel: cmt$element_name,
      ocn_mainframe: cmt$element_name,
      ocn_iou: cmt$element_name,
      old_channel_found: boolean,
      old_mainframe_found: boolean,
      old_peripheral_found: boolean,
      omn_mainframe: cmt$element_name,
      omn_iou: cmt$element_name,
      opn: cmt$element_name,
      peripheral_len: integer;

    status.normal := TRUE;
    ocn_mainframe := cmv$installed_mainframe;
    ncn_mainframe := cmv$installed_mainframe;
    ocn_iou := 'IOU0';
    ncn_iou := 'IOU0';
    omn_mainframe := cmv$installed_mainframe;
    nmn_mainframe := cmv$installed_mainframe;
    omn_iou := 'IOU0';
    nmn_iou := 'IOU0';
    old_channel_found := FALSE;
    old_mainframe_found := FALSE;
    old_peripheral_found := FALSE;
    IF (old_channel_list <> NIL) AND (new_channel_list <> NIL) THEN
      FOR field_index := LOWERBOUND (old_channel_list^.field_values^)
            TO UPPERBOUND (old_channel_list^.field_values^) DO
        IF old_channel_list^.field_values^ [field_index].name = 'CHANNEL' THEN
          IF old_channel_list^.field_values^ [field_index].value <> NIL THEN
            ocn_channel := old_channel_list^.field_values^ [field_index].value^.name_value;
            IF NOT cmp$valid_channel_name (ocn_channel) THEN
              osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_channel_number,
                    'CHANGE_CONNECTION_REFERENCE', status);
              osp$append_status_parameter (osc$status_parameter_delimiter, ocn_channel, status);
              RETURN;
            IFEND;
          IFEND;
        ELSEIF old_channel_list^.field_values^ [field_index].name = 'MAINFRAME' THEN
          IF old_channel_list^.field_values^ [field_index].value <> NIL THEN
            ocn_mainframe := old_channel_list^.field_values^ [field_index].value^.name_value;
          IFEND;
        ELSEIF old_channel_list^.field_values^ [field_index].name = 'IOU' THEN
          IF old_channel_list^.field_values^ [field_index].value <> NIL THEN
            ocn_iou := old_channel_list^.field_values^ [field_index].value^.name_value;
          IFEND;
        IFEND;
      FOREND;
      FOR field_index := LOWERBOUND (new_channel_list^.field_values^)
            TO UPPERBOUND (new_channel_list^.field_values^) DO
        IF new_channel_list^.field_values^ [field_index].name = 'CHANNEL' THEN
          IF new_channel_list^.field_values^ [field_index].value <> NIL THEN
            ncn_channel := new_channel_list^.field_values^ [field_index].value^.name_value;
            IF NOT cmp$valid_channel_name (ncn_channel) THEN
              osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_channel_number,
                    'CHANGE_CONNECTION_REFERENCE', status);
              osp$append_status_parameter (osc$status_parameter_delimiter, ncn_channel, status);
              RETURN;
            IFEND;
          IFEND;
        ELSEIF new_channel_list^.field_values^ [field_index].name = 'MAINFRAME' THEN
          IF new_channel_list^.field_values^ [field_index].value <> NIL THEN
            ncn_mainframe := new_channel_list^.field_values^ [field_index].value^.name_value;
          IFEND;
        ELSEIF new_channel_list^.field_values^ [field_index].name = 'IOU' THEN
          IF new_channel_list^.field_values^ [field_index].value <> NIL THEN
            ncn_iou := new_channel_list^.field_values^ [field_index].value^.name_value;
          IFEND;
        IFEND;
      FOREND;
      IF cmv$command_descriptor_p <> NIL THEN
        current_p := cmv$command_descriptor_p;

      /channel_loop/
        WHILE current_p <> NIL DO
          IF current_p^.iou_list <> NIL THEN
            FOR index := LOWERBOUND (current_p^.iou_list^) TO UPPERBOUND (current_p^.iou_list^) DO
              IF (ocn_channel = current_p^.iou_list^ [index].channel) AND
                    (ocn_mainframe = current_p^.iou_list^ [index].mainframe) AND
                    (ocn_iou = current_p^.iou_list^ [index].iou) THEN
                old_channel_found := TRUE;
                EXIT /channel_loop/;
              IFEND;
            FOREND;
          ELSEIF current_p^.channel_list <> NIL THEN
            FOR index := LOWERBOUND (current_p^.channel_list^) TO UPPERBOUND (current_p^.channel_list^) DO
              IF (ocn_channel = current_p^.channel_list^ [index].channel) AND
                    (ocn_mainframe = current_p^.channel_list^ [index].mainframe) AND
                    (ocn_iou = current_p^.channel_list^ [index].iou) THEN
                old_channel_found := TRUE;
                EXIT /channel_loop/;
              IFEND;
            FOREND;
          IFEND;
          current_p := current_p^.next_descriptor;
        WHILEND /channel_loop/;
      IFEND;
      IF NOT old_channel_found THEN
        message := ' ';
        channel_len := find_name_length (ocn_channel) + 1;
        mainframe_len := find_name_length (ocn_mainframe) + 1;
        iou_len := find_name_length (ocn_iou);
        STRINGREP (message, len, 'Channel (', ocn_channel (1, channel_len), ocn_mainframe (1, mainframe_len),
              ocn_iou (1, iou_len), ')');
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_element_not_found, message, status);
        RETURN;
      IFEND;
    IFEND;

    IF (old_mainframe_list <> NIL) AND (new_mainframe_list <> NIL) THEN
      FOR field_index := LOWERBOUND (old_mainframe_list^.field_values^)
            TO UPPERBOUND (old_mainframe_list^.field_values^) DO
        IF old_mainframe_list^.field_values^ [field_index].name = 'MAINFRAME' THEN
          IF old_mainframe_list^.field_values^ [field_index].value <> NIL THEN
            omn_mainframe := old_mainframe_list^.field_values^ [field_index].value^.name_value;
          IFEND;
        ELSEIF old_mainframe_list^.field_values^ [field_index].name = 'IOU' THEN
          IF old_mainframe_list^.field_values^ [field_index].value <> NIL THEN
            omn_iou := old_mainframe_list^.field_values^ [field_index].value^.name_value;
          IFEND;
        IFEND;
      FOREND;
      FOR field_index := LOWERBOUND (new_mainframe_list^.field_values^)
            TO UPPERBOUND (new_mainframe_list^.field_values^) DO
        IF new_mainframe_list^.field_values^ [field_index].name = 'MAINFRAME' THEN
          IF new_mainframe_list^.field_values^ [field_index].value <> NIL THEN
            nmn_mainframe := new_mainframe_list^.field_values^ [field_index].value^.name_value;
          IFEND;
        ELSEIF new_mainframe_list^.field_values^ [field_index].name = 'IOU' THEN
          IF new_mainframe_list^.field_values^ [field_index].value <> NIL THEN
            nmn_iou := new_mainframe_list^.field_values^ [field_index].value^.name_value;
          IFEND;
        IFEND;
      FOREND;
      IF cmv$command_descriptor_p <> NIL THEN
        current_p := cmv$command_descriptor_p;

      /mainframe_loop/
        WHILE current_p <> NIL DO
          IF current_p^.iou_list <> NIL THEN
            FOR index := LOWERBOUND (current_p^.iou_list^) TO UPPERBOUND (current_p^.iou_list^) DO
              IF (omn_mainframe = current_p^.iou_list^ [index].mainframe) AND
                    (omn_iou = current_p^.iou_list^ [index].iou) THEN
                old_mainframe_found := TRUE;
                EXIT /mainframe_loop/;
              IFEND;
            FOREND;
          ELSEIF current_p^.channel_list <> NIL THEN
            FOR index := LOWERBOUND (current_p^.channel_list^) TO UPPERBOUND (current_p^.channel_list^) DO
              IF (omn_mainframe = current_p^.channel_list^ [index].mainframe) AND
                    (omn_iou = current_p^.channel_list^ [index].iou) THEN
                old_mainframe_found := TRUE;
                EXIT /mainframe_loop/;
              IFEND;
            FOREND;

          IFEND;
          current_p := current_p^.next_descriptor;
        WHILEND /mainframe_loop/;
      IFEND;

      IF NOT old_mainframe_found THEN
        message := ' ';
        mainframe_len := find_name_length (omn_mainframe) + 1;
        iou_len := find_name_length (omn_iou);
        STRINGREP (message, len, 'Mainframe (', omn_mainframe (1, mainframe_len), omn_iou (1, iou_len), ')');
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_element_not_found, message, status);
        RETURN;
      IFEND;
    IFEND;
    IF (old_peripheral <> osc$null_name) AND (new_peripheral <> osc$null_name) THEN
      IF cmv$command_descriptor_p <> NIL THEN
        current_p := cmv$command_descriptor_p;
        WHILE current_p <> NIL DO
          IF current_p^.pc_list <> NIL THEN
            FOR index := LOWERBOUND (current_p^.pc_list^) TO UPPERBOUND (current_p^.pc_list^) DO
              IF (old_peripheral = current_p^.pc_list^[index].peripheral) THEN
                old_peripheral_found := TRUE;
                current_p^.pc_list^[index].peripheral := new_peripheral;
              IFEND;
            FOREND;
          IFEND;
          current_p := current_p^.next_descriptor;
        WHILEND;
      IFEND;

      IF NOT old_peripheral_found THEN
        message := ' ';
        peripheral_len := find_name_length (opn);
        STRINGREP (message, len, 'Old peripheral (',
              opn(1,peripheral_len), ')');
        osp$set_status_abnormal (cmc$configuration_management_id,
                cme$pcu_element_not_found, message, status);
        RETURN;
      IFEND;
    IFEND;

    IF old_channel_found THEN
      IF cmv$command_descriptor_p <> NIL THEN
        current_p := cmv$command_descriptor_p;
        WHILE current_p <> NIL DO
          IF current_p^.iou_list <> NIL THEN
            FOR index := LOWERBOUND (current_p^.iou_list^) TO UPPERBOUND (current_p^.iou_list^) DO
              IF (ocn_channel = current_p^.iou_list^[index].channel) AND
                     (ocn_mainframe = current_p^.iou_list^[index].mainframe) AND
                     (ocn_iou = current_p^.iou_list^[index].iou) THEN
                current_p^.iou_list^[index].channel := ncn_channel;
                current_p^.iou_list^[index].mainframe := ncn_mainframe;
                current_p^.iou_list^[index].iou := ncn_iou;
              IFEND;
            FOREND;
          ELSEIF current_p^.channel_list <> NIL THEN
            FOR index := LOWERBOUND (current_p^.channel_list^) TO UPPERBOUND (current_p^.channel_list^) DO
              IF (ocn_channel = current_p^.channel_list^[index].channel) AND
                     (ocn_mainframe = current_p^.channel_list^[index].mainframe) AND
                     (ocn_iou = current_p^.channel_list^[index].iou) THEN
                current_p^.channel_list^[index].channel := ncn_channel;
                current_p^.channel_list^[index].mainframe := ncn_mainframe;
                current_p^.channel_list^[index].iou := ncn_iou;
              IFEND;
            FOREND;
          IFEND;
          current_p := current_p^.next_descriptor;
        WHILEND;
      IFEND;
    IFEND;

    IF old_mainframe_found THEN
      IF cmv$command_descriptor_p <> NIL THEN
        current_p := cmv$command_descriptor_p;
        WHILE current_p <> NIL DO
          IF current_p^.iou_list <> NIL THEN
            FOR index := LOWERBOUND (current_p^.iou_list^) TO UPPERBOUND (current_p^.iou_list^) DO
              IF (omn_mainframe = current_p^.iou_list^[index].mainframe) AND
                     (omn_iou = current_p^.iou_list^[index].iou) THEN
                current_p^.iou_list^[index].mainframe := nmn_mainframe;
                current_p^.iou_list^[index].iou := nmn_iou;
              IFEND;
            FOREND;
          ELSEIF current_p^.channel_list <> NIL THEN
            FOR index := LOWERBOUND (current_p^.channel_list^) TO UPPERBOUND (current_p^.channel_list^) DO
              IF (omn_mainframe = current_p^.channel_list^[index].mainframe) AND
                     (omn_iou = current_p^.channel_list^[index].iou) THEN
                current_p^.channel_list^[index].mainframe := nmn_mainframe;
                current_p^.channel_list^[index].iou := nmn_iou;
              IFEND;
            FOREND;
          IFEND;
          current_p := current_p^.next_descriptor;
        WHILEND;
      IFEND;
    IFEND;

  PROCEND cmp$change_connection_ref_r3;

?? OLDTITLE ??
?? NEWTITLE := '   cpm$change_definition', EJECT ??

{ PURPOSE:
{    This procedure searches for an element name in a
{    configuration file and change its definition


  PROCEDURE [XDCL, #GATE] cmp$change_definition
    (    pvt: ^clt$parameter_value_table;
     VAR status: ost$status);

    CONST
      command_name = 'CHANGE_ELEMENT_DEFINITION      ';

    VAR
      connection_specified: boolean,
      current_p: ^cmt$pcu_command_descriptor,
      element: cmt$element_definition,
      found: boolean,
      found_command: cmt$pcu_command_descriptor,
      new_descriptor: cmt$pcu_command_descriptor,
      nil_pointer: boolean,
      previous_p: ^cmt$pcu_command_descriptor,
      same_as: boolean,
      same_element: cmt$pcu_command_descriptor;

    status.normal := TRUE;
    initialize_descriptor (new_descriptor);

    new_descriptor.element_name := pvt^ [p$element].value^.name_value;
    element.element_name := new_descriptor.element_name;

    cmp$search_edited_file (new_descriptor.element_name, 0, element.product_id, found, found_command);
    IF NOT found THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_element_not_found,
            new_descriptor.element_name, status);
      RETURN;
    IFEND;

    cmp$determine_element_type (found_command.pid, element, status);
    IF element.element_type = cmc$external_processor_element THEN
      new_descriptor.connection := cmc$central_memory_connection;
    ELSE
      new_descriptor.connection := cmc$iou_connection;
    IFEND;

    new_descriptor.verify := found_command.verify;

    same_as := pvt^ [p$same_as].specified;
    IF same_as THEN
      cmp$search_edited_file (pvt^ [p$same_as].value^.name_value, 0, element.product_id, found, same_element);
      IF NOT found THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_same_as_not_defined,
              pvt^ [p$same_as].value^.name_value, status);
        RETURN; {----->
      ELSE
        new_descriptor.pid := same_element.pid;
        new_descriptor.state := same_element.state;
        new_descriptor.sn := same_element.sn;
      IFEND;
    IFEND;

    IF pvt^ [p$verify_element_identification].specified THEN
      new_descriptor.verify := pvt^ [p$verify_element_identification].value^.boolean_value.value;
    IFEND;

    IF pvt^ [p$element_identification].specified THEN
      new_descriptor.pid := pvt^ [p$element_identification].value^.name_value;
      cmp$get_product_id (new_descriptor.pid, element, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      IF same_as THEN
        new_descriptor.pid := same_element.pid;
      IFEND;
    IFEND;

    IF pvt^ [p$serial_number].specified THEN
      new_descriptor.sn := pvt^ [p$serial_number].value^.integer_value.value;
    IFEND;

    IF pvt^ [p$iou_program_name].specified THEN
      new_descriptor.ioupn := pvt^ [p$iou_program_name].value^.name_value;
    IFEND;

    IF pvt^ [p$state].specified THEN
      new_descriptor.state := pvt^ [p$state].value^.name_value;
    IFEND;

    IF pvt^ [p$application_information].specified THEN
      ALLOCATE new_descriptor.application_info_p:
            [STRLENGTH(pvt^[p$application_information].value^.string_value^)] IN osv$task_private_heap^;
      new_descriptor.application_info_p^ := pvt^ [p$application_information].value^.string_value^;
    IFEND;

    IF pvt^ [p$site_information].specified THEN
      ALLOCATE new_descriptor.site_info_p:
            [STRLENGTH(pvt^[p$site_information].value^.string_value^)] IN osv$task_private_heap^;
      new_descriptor.site_info_p^ := pvt^ [p$site_information].value^.string_value^;
    IFEND;

    cmp$crack_connection (pvt, command_name, connection_specified, new_descriptor, status);
    IF NOT status.normal THEN
      IF connection_specified THEN
        cmp$free_descriptor (new_descriptor);
      IFEND;
      RETURN;
    IFEND;

    IF cmv$command_descriptor_p <> NIL THEN
      current_p := cmv$command_descriptor_p;
      previous_p := current_p;
      found := FALSE;

    /link_list_loop/
      WHILE current_p <> NIL DO
        found := current_p^.element_name = element.element_name;
        IF found THEN
          EXIT /link_list_loop/;
        ELSE
          previous_p := current_p;
          current_p := current_p^.next_descriptor;
        IFEND;
      WHILEND /link_list_loop/;
    ELSE
      osp$set_status_condition ( cme$pcu_empty_file,  status);
      RETURN;
    IFEND;

    IF NOT found THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_element_not_found,
            element.element_name, status);
    ELSE
      IF current_p^.connection <> new_descriptor.connection THEN
        IF connection_specified THEN
          CASE current_p^.connection OF
          = cmc$central_memory_connection =
            nil_pointer := (current_p^.cmc_list = NIL) AND (current_p^.channel_list = NIL);
          = cmc$iou_connection =
            nil_pointer := current_p^.iou_list = NIL;
          = cmc$peripheral_connection =
            nil_pointer := current_p^.pc_list = NIL;
          CASEND;
          IF NOT nil_pointer THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_connection_not_found,
                  element.element_name, status);
            cmp$free_descriptor (new_descriptor);
            RETURN;
          IFEND;
        IFEND;
      IFEND;

      IF new_descriptor.same_as <> osc$null_name THEN
        current_p^.same_as := new_descriptor.same_as;
        current_p^.sn := 0;
        current_p^.ioupn := osc$null_name;
        current_p^.state := osc$null_name;
        current_p^.pid := osc$null_name;
      IFEND;

      IF new_descriptor.sn <> 0 THEN
        current_p^.sn := new_descriptor.sn;
      IFEND;

      IF new_descriptor.pid <> osc$null_name THEN
        current_p^.pid := new_descriptor.pid;
      IFEND;

      IF new_descriptor.state <> osc$null_name THEN
        current_p^.state := new_descriptor.state;
      IFEND;

      IF new_descriptor.ioupn <> osc$null_name THEN
        current_p^.ioupn := new_descriptor.ioupn;
      IFEND;

      current_p^.verify := new_descriptor.verify;
      IF new_descriptor.application_info_p <> NIL THEN
        IF current_p^.application_info_p = NIL THEN
          current_p^.application_info_p := new_descriptor.application_info_p;
        ELSE
          FREE current_p^.application_info_p IN osv$task_private_heap^;
          current_p^.application_info_p := new_descriptor.application_info_p;
        IFEND;
      IFEND;

      IF new_descriptor.site_info_p <> NIL THEN
        IF current_p^.site_info_p = NIL THEN
          current_p^.site_info_p := new_descriptor.site_info_p;
        ELSE
          FREE current_p^.site_info_p IN osv$task_private_heap^;
          current_p^.site_info_p := new_descriptor.site_info_p;
        IFEND;
      IFEND;
      IF connection_specified THEN
        current_p^.connection := new_descriptor.connection;
        CASE new_descriptor.connection OF
        = cmc$central_memory_connection =
          IF new_descriptor.cmc_list <> NIL THEN
            IF current_p^.cmc_list <> NIL THEN
              FREE current_p^.cmc_list IN osv$task_private_heap^;
            IFEND;
            current_p^.cmc_list := new_descriptor.cmc_list;
          IFEND;
          IF new_descriptor.channel_list <> NIL THEN
            IF current_p^.channel_list <> NIL THEN
              FREE current_p^.channel_list IN osv$task_private_heap^;
            IFEND;
            current_p^.channel_list := new_descriptor.channel_list;
          IFEND;
        = cmc$iou_connection =
          IF current_p^.iou_list <> NIL THEN
            FREE current_p^.iou_list IN osv$task_private_heap^;
          IFEND;
          current_p^.iou_list := new_descriptor.iou_list;
        = cmc$peripheral_connection =
          IF current_p^.pc_list <> NIL THEN
            FREE current_p^.pc_list IN osv$task_private_heap^;
          IFEND;
          current_p^.pc_list := new_descriptor.pc_list;
        CASEND;
      IFEND;
    IFEND;

  PROCEND cmp$change_definition;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$change_definition_name ', EJECT ??

{ This procedure change the Element name in a
{ physical configuration file


  PROCEDURE [XDCL, #GATE] cmp$change_definition_name
    (    element_name: cmt$element_name;
         new_element_name: cmt$element_name;
         change_references: boolean;
     VAR status: ost$status);

    VAR
      current_p: ^cmt$pcu_command_descriptor,
      found: boolean,
      index: integer,
      i: integer,
      made_change: boolean;

    status.normal := TRUE;
    made_change := FALSE;

  /main_program/

    BEGIN
      cmp$check_reserved_names (new_element_name, cmv$reserved_names_list, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF cmv$command_descriptor_p <> NIL THEN
        current_p := cmv$command_descriptor_p;
        WHILE current_p <> NIL DO
          IF current_p^.element_name = new_element_name THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_element_already_defined,
                  new_element_name, status);
            EXIT /main_program/;
          IFEND;
          current_p := current_p^.next_descriptor;
        WHILEND;
      IFEND;

      IF cmv$command_descriptor_p <> NIL THEN
        current_p := cmv$command_descriptor_p;

      /search_line/
        WHILE current_p <> NIL DO
          IF current_p^.element_name = element_name THEN
            made_change := TRUE;
            current_p^.element_name := new_element_name;
          IFEND;
          IF change_references THEN
            IF current_p^.same_as = element_name THEN
              current_p^.same_as := new_element_name;
            IFEND;
            CASE current_p^.connection OF
            = cmc$peripheral_connection =
              IF current_p^.pc_list <> NIL THEN

{ Scan every token of Peripheral connection list and change

                FOR index := LOWERBOUND (current_p^.pc_List^) TO UPPERBOUND (current_p^.pc_list^) DO
                  IF current_p^.pc_list^ [index].peripheral = element_name THEN
                    current_p^.pc_list^ [index].peripheral := new_element_name;
                  IFEND;
                FOREND;
              IFEND;
            ELSE
              ;
            CASEND;

          ELSE
            IF made_change THEN
              EXIT /search_line/;
            IFEND;
          IFEND;
          current_p := current_p^.next_descriptor;
        WHILEND /search_line/;

      IFEND;

      IF (NOT made_change) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_element_not_found, element_name,
              status);
      IFEND;

    END /main_program/;

  PROCEND cmp$change_definition_name;


?? OLDTITLE ??
?? NEWTITLE := '   cmp$check_for_unique_ser_num', EJECT ??

{ PURPOSE:
{   This procedure checks for serial number uniqueness within
{   the physical configuration file.

  PROCEDURE cmp$check_for_unique_ser_num
    (    serial_num: ost$string;
         product_id: cmt$product_identification;
         input_fid: amt$file_identifier;
     VAR status: ost$status);

    VAR
      check_count: integer,
      eoi_addr: array [1 .. 1] of amt$access_info,
      element: ^cmt$element_definition,
      find_count: integer,
      loop_count: integer,
      loop_index: integer,
      ptr1: amt$segment_pointer;

    status.normal := TRUE;
    IF (product_id.product_number = '  $885') OR
           (product_id.product_number = ' $5682') THEN
      check_count := 2;
    ELSEIF (product_id.product_number = '  $895') THEN
      check_count := 4;
    ELSE
      check_count := 0;
    IFEND;
    eoi_addr [1].key := amc$eoi_byte_address;
    amp$get_segment_pointer (input_fid, amc$sequence_pointer, ptr1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET ptr1.sequence_pointer;
    amp$fetch_access_information (input_fid, eoi_addr, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    find_count := 0;
    IF eoi_addr [1].item_returned THEN
      loop_count := eoi_addr [1].eoi_byte_address DIV #SIZE (cmt$element_definition);
      FOR loop_index := 1 TO loop_count DO
        NEXT element IN ptr1.sequence_pointer;
        IF (element^.serial_number = serial_num.value) AND (element^.product_id = product_id) THEN
          find_count := find_count + 1;
          IF find_count > check_count THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_duplicate_ser_num,
                  element^.element_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, serial_num.value, status);
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    ELSE
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_file_error,
            'cmp$check_for_unique_ser_num', status);
    IFEND;

  PROCEND cmp$check_for_unique_ser_num;


?? OLDTITLE ??
?? NEWTITLE := '   cmp$clean_up_list', EJECT ??

{ PURPOSE:
{    This procedure goes through the linked list built by EDIPC
{    and frees up all pointer allocated in task private.

  PROCEDURE [XDCL, #GATE] cmp$clean_up_list;

    VAR
      current_p,
      next_p: ^cmt$pcu_command_descriptor;

    IF cmv$command_descriptor_p <> NIL THEN

      current_p := cmv$command_descriptor_p;
      WHILE current_p <> NIL DO
        next_p := current_p^.next_descriptor;
        IF current_p <> cmv$command_descriptor_p THEN
          CASE current_p^.connection OF
          = cmc$central_memory_connection =
            IF current_p^.cmc_list <> NIL THEN
              FREE current_p^.cmc_list IN osv$task_private_heap^;
            IFEND;
            IF current_p^.channel_list <> NIL THEN
              FREE current_p^.channel_list IN osv$task_private_heap^;
            IFEND;
          = cmc$iou_connection =
            IF current_p^.iou_list <> NIL THEN
              FREE current_p^.iou_list IN osv$task_private_heap^;
            IFEND;
          = cmc$peripheral_connection =
            IF current_p^.pc_list <> NIL THEN
              FREE current_p^.pc_list IN osv$task_private_heap^;
            IFEND;
          ELSE
            ;
          CASEND;
          IF current_p^.application_info_p <> NIL THEN
            FREE current_p^.application_info_p IN osv$task_private_heap^;
          IFEND;
          IF current_p^.site_info_p <> NIL THEN
            FREE current_p^.site_info_p IN osv$task_private_heap^;
          IFEND;
          FREE current_p IN osv$task_private_heap^;
        IFEND;
        current_p := next_p;
      WHILEND;
      cmv$command_descriptor_p := NIL;
      cmv$end_list_p := NIL;
    IFEND;

  PROCEND cmp$clean_up_list;



?? OLDTITLE ??
?? NEWTITLE := '   cmp$close_in_out_files ', EJECT ??

{ PURPOSE:
{    This procedure closes the input and output file of the
{    PCU editor.

  PROCEDURE [XDCL, #GATE] cmp$close_in_out_files;

    VAR
      status: ost$status;

    fsp$close_file (cmv$output_fid, status);
    fsp$close_file (cmv$input_fid, status);

  PROCEND cmp$close_in_out_files;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$close_utility_files', EJECT ??

{ PURPOSE:
{    This procedures closes the global files used in the Physical
{    Configuration Utility to store definition of peripheral elements
{    and their state information.

  PROCEDURE [XDCL, #GATE] cmp$close_utility_files;

    VAR
      local_status: ost$status;

    amp$close (cmv$cmd_value_fid, local_status);
    amp$close (cmv$state_value_fid, local_status);
    amp$return (cmv$cmd_value_name, local_status);
    amp$return (cmv$state_value_name, local_status);

  PROCEND cmp$close_utility_files;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$compile_phys_configuration', EJECT ??

{ PURPOSE:
{   This procedure scans the physical configuration file and processes commands in the file. It can be called
{   by INSTALL_PHYSICAL_CONFIGURATION or VERIFY_PHYSICAL_CONFIGURATION.
{ NOTE:
{   Because it needs to access ring 3 data structures, the parameter value table is passed to this routine.
{   Therefore, any changes to the parameters of the above commands will result in changes to the variables
{   p$xxxxx used in this routine.

  PROCEDURE [XDCL, #GATE] cmp$compile_phys_configuration
    (    verify_only: boolean;
         pvt_p: ^clt$parameter_value_table;
     VAR status: ost$status);

    VAR
      cm_bool_p: ^ARRAY [1 .. * ] OF clt$boolean,
      cm_var: clt$variable_reference,
      contains_data: boolean,
      error_file: clt$file,
      existing_file: boolean,
      file_attributes: ARRAY [1 .. 1] OF amt$file_item,
      get_attr: ARRAY [1 .. 1] OF amt$get_item,
      input_file: clt$file,
      input_file_id: amt$file_identifier,
      interactive_input: boolean,
      local_file: boolean,
      local_status: ost$status,
      mainframe_name: cmt$element_name,
      mainframe_pct_name: amt$local_file_name,
      pc_fid: amt$file_identifier,
      p$mainframe: integer,
      p$input: integer,
      p$errors: integer,
      state_fid: amt$file_identifier,
      state_file_name: amt$local_file_name,
      syntax_error_found: boolean,
      unique_name: ost$unique_name;

    status.normal := TRUE;

    IF verify_only THEN
      p$mainframe := 1;
      p$input := 2;
      p$errors := 3;
      mainframe_name := pvt_p^ [p$mainframe].value^.name_value;
    ELSE
      p$input := 1;
      p$errors := 2;
      mainframe_name := cmv$installed_mainframe;
    IFEND;

    get_attr [1].key := amc$null_attribute;
    file_attributes [1].key := amc$access_mode;
    file_attributes [1].access_mode :=
          $pft$usage_selections [pfc$shorten, pfc$append, pfc$modify, pfc$read];
    syntax_error_found := FALSE;

    clp$convert_string_to_file (pvt_p^ [p$input].value^.file_value^, input_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    interactive_input := (input_file.local_file_name = '$COMMAND') OR
          (input_file.local_file_name = 'COMMAND');

    IF NOT interactive_input THEN
      get_attr [1].key := amc$file_processor;
      amp$get_file_attributes (pvt_p^ [p$input].value^.file_value^, get_attr, local_file, existing_file,
            contains_data, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF NOT contains_data OR NOT existing_file THEN
        osp$set_status_condition (cme$pcu_empty_file, status);
        RETURN;
      IFEND;
    IFEND;

    clp$convert_string_to_file (pvt_p^ [p$errors].value^.file_value^, error_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$open_scratch_err_file (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

   /cleanup_needed/
    BEGIN
      IF NOT interactive_input THEN
        cmv$pcu_error_count := 0;
        clp$scan_command_file (input_file.local_file_name, 'PHYSICAL_CONFIGURATION_UTILITY ', 'PCU', status);
        IF cmv$pcu_error_count > 0 THEN
          syntax_error_found := TRUE;
          IF error_file.local_file_name <> clc$null_file THEN
            cmp$generate_error_listing (error_file.local_file_name, local_status);
            IF verify_only THEN
              osp$set_status_condition (cme$pcu_verpc_err, status);
            ELSE
              osp$set_status_condition (cme$pcu_inspc_err, status);
            IFEND;
            osp$append_status_integer (osc$status_parameter_delimiter, cmv$pcu_error_count, 10, FALSE,
                  status);
          IFEND;
          EXIT /cleanup_needed/;
        ELSEIF NOT status.normal THEN
          EXIT /cleanup_needed/;
        IFEND;
      IFEND;

      REPEAT
        pmp$generate_unique_name (unique_name, status);
        IF NOT status.normal THEN
          EXIT /cleanup_needed/;
        IFEND;
        mainframe_pct_name := unique_name.value;
        amp$get_file_attributes (mainframe_pct_name, get_attr, local_file, existing_file, contains_data,
              status);
        IF NOT status.normal THEN
          EXIT /cleanup_needed/;
        IFEND;
      UNTIL NOT local_file;

      REPEAT
        pmp$generate_unique_name (unique_name, status);
        IF NOT status.normal THEN
          EXIT /cleanup_needed/;
        IFEND;
        state_file_name := unique_name.value;
        amp$get_file_attributes (state_file_name, get_attr, local_file, existing_file, contains_data, status);
        IF NOT status.normal THEN
          EXIT /cleanup_needed/;
        IFEND;
      UNTIL NOT local_file;

     /files_opened/
      BEGIN
        amp$open (mainframe_pct_name, amc$segment, ^file_attributes, pc_fid, status);
        IF NOT status.normal THEN
          EXIT /files_opened/;
        IFEND;
        amp$open (state_file_name, amc$segment, ^file_attributes, state_fid, status);
        IF NOT status.normal THEN
          EXIT /files_opened/;
        IFEND;

        update_downward_connections (cmv$cmd_value_fid, pc_fid, status);
        IF NOT status.normal AND (status.condition = cme$lcu_sys_dev_path_not_found) AND
              (mainframe_name <> cmv$installed_mainframe) THEN
          status.normal := TRUE;
          EXIT /files_opened/;
        IFEND;
        IF NOT status.normal AND ((status.condition = cme$pcu_duplicate_pun) OR
                                  (status.condition = cme$pcu_duplicate_pen)) THEN
          EXIT /files_opened/;
        IFEND;

        cmp$build_active_conf (pc_fid, cmv$cmd_value_fid, cmv$state_value_fid, state_fid, mainframe_name,
              status);
        IF NOT status.normal AND (status.condition = cme$lcu_sys_dev_path_not_found) AND
              (mainframe_name <> cmv$installed_mainframe) THEN
          status.normal := TRUE;
          EXIT /files_opened/;
        IFEND;
      END /files_opened/;
      amp$close (pc_fid, local_status);
      amp$return (mainframe_pct_name, local_status);
      IF NOT status.normal THEN
        EXIT /cleanup_needed/;
      IFEND;

      IF NOT verify_only AND NOT cmv$configuration_activated THEN

        { Build the physical configuration tables and proceed to activate the configuration.

        cmp$build_conf_tables (cmv$cmd_value_fid, state_fid, status);
        IF NOT status.normal THEN
          EXIT /cleanup_needed/;
        IFEND;

        cmp$acquire_all_peripherals (status);
        IF NOT status.normal THEN
          EXIT /cleanup_needed/;
        IFEND;

        cmp$set_active_flag (TRUE);
        PUSH cm_bool_p: [1 .. 1];
        cm_bool_p^ [1].value := TRUE;
        cm_bool_p^ [1].kind := clc$true_false_boolean;
        clp$read_variable ('CMV$CONFIGURATION_ACTIVATED', cm_var, local_status);
        cm_var.value.boolean_value := cm_bool_p;
        clp$write_variable ('CMV$CONFIGURATION_ACTIVATED', cm_var.value, local_status);

        amp$open (input_file.local_file_name, amc$record, ^file_attributes, input_file_id, status);
        IF NOT status.normal THEN
          EXIT /cleanup_needed/;
        IFEND;
        cmp$install_system_conf (input_file_id, status);
        IF NOT status.normal THEN
          EXIT /cleanup_needed/;
        IFEND;
      IFEND;
    END /cleanup_needed/;

    IF NOT status.normal AND NOT syntax_error_found THEN
      IF error_file.local_file_name <> '$NULL' THEN
        cmp$echo_errors (FALSE, status);
        cmp$generate_error_listing (error_file.local_file_name, local_status);
        IF verify_only THEN
          osp$set_status_condition (cme$pcu_verpc_err, status);
        ELSE
          osp$set_status_condition (cme$pcu_inspc_err, status);
        IFEND;
        osp$append_status_integer (osc$status_parameter_delimiter, 1, 10, FALSE, status);
      IFEND;
    IFEND;

    IF NOT cmv$executing_within_editor THEN
      cmp$clean_up_list;
      cmp$clean_up_error_count;
      cmp$close_utility_files;
      amp$close (input_file_id, local_status);
      amp$close (state_fid, local_status);
      amp$return (state_file_name, local_status);
      cmp$open_utility_files (local_status);
      cmv$pcu_error_count := 0;
    IFEND;

  PROCEND cmp$compile_phys_configuration;
?? OLDTITLE ??
?? NEWTITLE := '   cmp$crack_connection', EJECT ??

{ PURPOSE:
{    This procedure processes the connections parameter of the PCU subcommands.

  PROCEDURE [XDCL, #GATE] cmp$crack_connection
    (    parameter_value_table: ^clt$parameter_value_table;
         command_name: string ( * <= osc$max_name_size);
     VAR connection_specified: boolean;
     VAR command: cmt$pcu_command_descriptor;
     VAR status: ost$status);


    VAR
      channel_name: cmt$element_name,
      current_list_entry: ^clt$data_value,
      equipment_number: cmt$physical_equipment_number,
      element_definition: cmt$element_definition,
      field_index: integer,
      iou_name: cmt$element_name,
      iou_number: dst$iou_number,
      list_index: integer,
      mainframe_name: cmt$element_name,
      number_of_entries: integer,
      peripheral_element: cmt$element_name,
      physical_address: cmt$physical_unit_number,
      port: 0 .. 3,
      specified_address: boolean;

    status.normal := TRUE;
    connection_specified := FALSE;

    IF parameter_value_table^ [p$peripheral_connection].specified THEN
      connection_specified := TRUE;
      command.connection := cmc$peripheral_connection;
      current_list_entry := parameter_value_table^ [p$peripheral_connection].value;
      number_of_entries := clp$count_list_elements (parameter_value_table^ [p$peripheral_connection].value);
      IF number_of_entries > 0 THEN
        ALLOCATE command.pc_list: [1 .. number_of_entries] IN osv$task_private_heap^;
      IFEND;
      list_index := 0;
      physical_address := 0;
      specified_address := FALSE;
      WHILE current_list_entry <> NIL DO
        FOR field_index := LOWERBOUND (current_list_entry^.element_value^.field_values^)
              TO UPPERBOUND (current_list_entry^.element_value^.field_values^) DO
          IF (current_list_entry^.element_value^.field_values^ [field_index].name = 'PERIPHERAL_ELEMENT') THEN
            IF (current_list_entry^.element_value^.field_values^ [field_index].value <> NIL) THEN
              cmp$check_reserved_names (current_list_entry^.element_value^.field_values^ [field_index].value^.
                    name_value, cmv$reserved_names_list, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              peripheral_element := current_list_entry^.element_value^.field_values^ [field_index].value^.
                    name_value;
            ELSE
              osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_missing_parameters,
                  'PERIPHERAL_ELEMENT', status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                        parameter_value_table^ [p$element].value^.name_value, status);
              RETURN;
            IFEND;
          ELSEIF (current_list_entry^.element_value^.field_values^ [field_index].name =
                'PHYSICAL_ADDRESS') THEN
            IF (current_list_entry^.element_value^.field_values^ [field_index].value <> NIL) THEN
              IF NOT specified_address THEN
                specified_address := TRUE;
                physical_address := current_list_entry^.element_value^.field_values^ [field_index].value^.
                      integer_value.value;
              ELSE
                IF physical_address <> current_list_entry^.element_value^.field_values^ [field_index].value^.
                      integer_value.value THEN
                  osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
                        'Physical address mismatch on PERIPHERAL CONNECTIONS', status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        parameter_value_table^ [p$element].value^.name_value, status);
                  RETURN;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        FOREND;
        list_index := list_index + 1;
        command.pc_list^ [list_index].address := physical_address;
        command.pc_list^ [list_index].peripheral := peripheral_element;
        current_list_entry := current_list_entry^.link;
      WHILEND;

    ELSE

{ If IOU_CONNECTION is specified, must also check CENTRAL_MEMORY_CONNECTION
{ in case element is an external processor.

      IF parameter_value_table^ [p$iou_connection].specified THEN
        connection_specified := TRUE;
        IF command.connection <> cmc$central_memory_connection THEN
          command.connection := cmc$iou_connection;
        IFEND;
        current_list_entry := parameter_value_table^ [p$iou_connection].value;
        number_of_entries := clp$count_list_elements (parameter_value_table^ [p$iou_connection].value);
        IF number_of_entries > 0 THEN
          IF command.connection = cmc$iou_connection THEN
            ALLOCATE command.iou_list: [1 .. number_of_entries] IN osv$task_private_heap^;
          ELSE
            ALLOCATE command.channel_list: [1 .. number_of_entries] IN osv$task_private_heap^;
          IFEND;
        IFEND;
        list_index := 0;
        specified_address := FALSE;
        equipment_number := 0;
        WHILE current_list_entry <> NIL DO
          iou_name := 'IOU0';
          channel_name := osc$null_name;

{ If the command DEFINE_ELEMENT is processed then take the mainframe name from the
{ last DEFINE_WORKING_MAINFRAME command. For other PCU Editor commands, take the
{ mainframe name from the current mainframe id unless specified in the IOU connection.

          IF command_name = 'DEFINE_ELEMENT' THEN
            mainframe_name := cmv$mainframe_name;
          ELSE
            mainframe_name := cmv$installed_mainframe;
          IFEND;
          FOR field_index := LOWERBOUND (current_list_entry^.element_value^.field_values^)
                TO UPPERBOUND (current_list_entry^.element_value^.field_values^) DO
            IF (current_list_entry^.element_value^.field_values^ [field_index].name = 'CHANNEL') THEN
              IF (current_list_entry^.element_value^.field_values^ [field_index].value <> NIL) THEN
                channel_name := current_list_entry^.element_value^.field_values^ [field_index].value^.
                      name_value;
                IF NOT cmp$valid_channel_name (channel_name) THEN
                  osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_channel_number,
                        command_name, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, channel_name, status);
                  RETURN;
                IFEND;
              IFEND;
            ELSEIF (current_list_entry^.element_value^.field_values^ [field_index].name =
                  'EQUIPMENT') THEN
              IF (current_list_entry^.element_value^.field_values^ [field_index].value <> NIL) THEN
                IF NOT specified_address THEN
                  specified_address := TRUE;
                  equipment_number := current_list_entry^.element_value^.field_values^ [field_index].value^.
                      integer_value.value;
                ELSE
                  IF equipment_number <> current_list_entry^.element_value^.field_values^ [field_index]
                      .value^.integer_value.value THEN
                    osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
                         'Physical address mismatch on IOU CONNECTIONS', status);
                    osp$append_status_parameter (osc$status_parameter_delimiter,
                         parameter_value_table^ [p$element].value^.name_value, status);
                    RETURN;
                  IFEND;
                IFEND;
              IFEND;
            ELSEIF (current_list_entry^.element_value^.field_values^ [field_index].name = 'MAINFRAME') THEN
              IF (current_list_entry^.element_value^.field_values^ [field_index].value <> NIL) THEN
                mainframe_name := current_list_entry^.element_value^.field_values^ [field_index].value^.
                      name_value;
                cmp$validate_mainframe_name (mainframe_name, status);
                IF NOT status.normal THEN
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        parameter_value_table^ [p$element].value^.name_value, status);
                  RETURN;
                IFEND;
              IFEND;
            ELSEIF (current_list_entry^.element_value^.field_values^ [field_index].name = 'IOU') THEN
              IF (current_list_entry^.element_value^.field_values^ [field_index].value <> NIL) THEN
                iou_name := current_list_entry^.element_value^.field_values^ [field_index].value^.name_value;
                cmp$convert_iou_name (iou_name, iou_number, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              IFEND;
            IFEND;
          FOREND;
          list_index := list_index + 1;
          IF command.connection = cmc$central_memory_connection THEN
            command.channel_list^ [list_index].iou := iou_name;
            command.channel_list^ [list_index].channel := channel_name;
            command.channel_list^ [list_index].equipment := equipment_number;
            command.channel_list^ [list_index].mainframe := mainframe_name;
          ELSEIF command.connection = cmc$iou_connection THEN
            command.iou_list^ [list_index].mainframe := mainframe_name;
            command.iou_list^ [list_index].channel := channel_name;
            command.iou_list^ [list_index].iou := iou_name;
            command.iou_list^ [list_index].equipment := equipment_number;
          IFEND;
          current_list_entry := current_list_entry^.link;
        WHILEND;
      IFEND;

      IF parameter_value_table^ [p$central_memory_connection].specified THEN
        connection_specified := TRUE;
        command.connection := cmc$central_memory_connection;
        current_list_entry := parameter_value_table^ [p$central_memory_connection].value;
        number_of_entries := clp$count_list_elements (parameter_value_table^ [p$central_memory_connection].
              value);
        IF number_of_entries > 0 THEN
          ALLOCATE command.cmc_list: [1 .. number_of_entries] IN osv$task_private_heap^;
        IFEND;
        list_index := 0;
        port := 0;
        WHILE current_list_entry <> NIL DO
          IF command_name = 'DEFINE_ELEMENT' THEN
            mainframe_name := cmv$mainframe_name;
          ELSE
            mainframe_name := cmv$installed_mainframe;
          IFEND;
          FOR field_index := LOWERBOUND (current_list_entry^.element_value^.field_values^)
                TO UPPERBOUND (current_list_entry^.element_value^.field_values^) DO
            IF (current_list_entry^.element_value^.field_values^ [field_index].name = 'PORT') THEN
              IF (current_list_entry^.element_value^.field_values^ [field_index].value <> NIL) THEN
                port := current_list_entry^.element_value^.field_values^ [field_index].value^.integer_value.
                      value;
              IFEND;
            ELSEIF (current_list_entry^.element_value^.field_values^ [field_index].name = 'MAINFRAME') THEN
              IF (current_list_entry^.element_value^.field_values^ [field_index].value <> NIL) THEN
                mainframe_name := current_list_entry^.element_value^.field_values^ [field_index].value^.
                      name_value;
              IFEND;
            IFEND;
          FOREND;
          list_index := list_index + 1;
          command.cmc_list^ [list_index].port := port;
          command.cmc_list^ [list_index].mainframe := mainframe_name;
          current_list_entry := current_list_entry^.link;
        WHILEND;
      IFEND;
    IFEND;

  PROCEND cmp$crack_connection;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$crack_parameters', EJECT ??

{ PURPOSE :
{    This procedure crack the parameters of the PCU subcommands
{    that have common parameter passing requirements.
{    Following commands will use this routine:
{      DEFINE_ELEMENT
{      ADD_ELEMENT_DEFINITION
{      REPLACE_ELEMENT_DEFINITION

  PROCEDURE [XDCL, #GATE] cmp$crack_parameters
    (    parameter_value_table: ^clt$parameter_value_table;
         command_name: string ( * <= osc$max_name_size);
     VAR status: ost$status);

    VAR
      command: cmt$pcu_command_descriptor,
      connection_specified: boolean,
      dummy: cmt$pcu_command_descriptor,
      element: cmt$element_definition,
      found: boolean,
      product_index: 1..7,
      same_as: boolean,
      same_as_name: ost$name,
      same_as_element: cmt$pcu_command_descriptor,
      save_abnormal_status: boolean,
      saved_status: ost$status,
      standard_product: boolean;

    status.normal := TRUE;
    saved_status.normal := TRUE;
    save_abnormal_status := (command_name = 'DEFINE_ELEMENT                 ');

    initialize_descriptor (command);

    cmp$check_reserved_names (parameter_value_table^ [p$element].value^.name_value, cmv$reserved_names_list,
          status);
    IF NOT status.normal THEN
      IF save_abnormal_status THEN
        IF saved_status.normal THEN
          saved_status := status;
        IFEND;
      ELSE
        RETURN;
      IFEND;
    IFEND;
    {
    { Reject request if element is already defined.
    {
    cmp$search_edited_file (parameter_value_table^ [p$element].value^.name_value, 0, element.product_id,
          found, dummy);
    IF found AND (command_name <> 'REPLACE_ELEMENT_DEFINITION') THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_element_already_defined,
            parameter_value_table^ [p$element].value^.name_value, status);
      RETURN;
    IFEND;

    element.element_name := parameter_value_table^ [p$element].value^.name_value;
    command.element_name := parameter_value_table^ [p$element].value^.name_value;

    same_as := parameter_value_table^ [p$same_as].specified;
    IF same_as THEN
      same_as_name := parameter_value_table^ [p$same_as].value^.name_value;
      cmp$search_edited_file (same_as_name, 0, element.product_id, found, same_as_element);
      IF found THEN
        command.pid := same_as_element.pid;
        command.ioupn := same_as_element.ioupn;
        command.sn := same_as_element.sn;
        command.state := same_as_element.state;
        IF NOT parameter_value_table^ [p$element_identification].specified THEN

{ Set the product id value to what it is in the edited file only if the element id is
{ not specified.

          /find_product_number/
          FOR product_index := 1 to 7 DO
            IF command.pid(product_index) = '_' THEN
              EXIT /find_product_number/;
            IFEND;
          FOREND /find_product_number/;
          element.product_id.product_number := '      ';
          element.product_id.product_number (6+2-product_index, product_index-1) :=
                command.pid(1, product_index-1);
          element.product_id.underscore := '_';
          element.product_id.model_number := '   ';
          element.product_id.model_number := command.pid(product_index+1, 3)
        IFEND;
      ELSE
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_same_as_not_defined, same_as_name,
              status);
        IF save_abnormal_status THEN
          IF saved_status.normal THEN
            saved_status := status;
          IFEND;
        ELSE
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    command.verify := parameter_value_table^ [p$verify_element_identification].value^.boolean_value.value;
    standard_product := command.verify;

    IF parameter_value_table^ [p$element_identification].specified THEN
      command.pid := parameter_value_table^ [p$element_identification].value^.name_value;
      cmp$get_product_id (command.pid, element, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      IF NOT same_as THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_missing_parameters,
              'ELEMENT_IDENTIFICATION', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, element.element_name, status);
        IF save_abnormal_status THEN
          saved_status := status;
        ELSE
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    IF standard_product THEN
      IF NOT cmp$known_controller_id (element.product_id) AND NOT cmp$known_product_id
            (element.product_id) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_unknown_product_id,
              command.pid, status);
        RETURN;
      IFEND;

      cmp$determine_element_type (command.pid, element, status);
      IF NOT status.normal THEN
        IF save_abnormal_status THEN
          IF saved_status.normal THEN
            saved_status := status;
          IFEND;
        ELSE
          RETURN;
        IFEND;
      IFEND;
    ELSE
      IF cmp$known_controller_id (element.product_id) OR cmp$known_product_id (element.product_id) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
              'Invalid usage of VERIFY_ELEMENT_IDENTIFICATION parameter', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, element.element_name, status);
        RETURN;
      IFEND;
    IFEND;

    IF parameter_value_table^ [p$serial_number].specified THEN
      command.sn := parameter_value_table^ [p$serial_number].value^.integer_value.value;
    ELSE
      IF NOT same_as THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_missing_parameters, 'SERIAL_NUMBER',
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, element.element_name, status);
        IF save_abnormal_status THEN
          IF saved_status.normal THEN
            saved_status := status;
          IFEND;
        ELSE
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    IF parameter_value_table^ [p$state].specified THEN
      command.state := parameter_value_table^ [p$state].value^.name_value;
    ELSE
      IF NOT same_as THEN
        command.state := 'ON';
      IFEND;
    IFEND;

    IF parameter_value_table^ [p$iou_program_name].specified AND standard_product AND
          (element.element_type = cmc$storage_device_element) THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
            'IOU program name cannot be specified on a storage device', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, element.element_name, status);
      IF save_abnormal_status THEN
        IF saved_status.normal THEN
          saved_status := status;
        IFEND;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    IF parameter_value_table^ [p$iou_program_name].specified THEN
      command.ioupn := parameter_value_table^ [p$iou_program_name].value^.name_value;
    ELSE
      command.ioupn := osc$null_name;
    IFEND;

    IF parameter_value_table^ [p$central_memory_connection].specified THEN
      command.connection := cmc$central_memory_connection;
    ELSEIF parameter_value_table^ [p$peripheral_connection].specified THEN
      command.connection := cmc$peripheral_connection;
    ELSE
      command.connection := cmc$iou_connection;
    IFEND;

    cmp$crack_connection (parameter_value_table, command_name, connection_specified, command, status);
    IF NOT connection_specified THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_missing_parameters, 'CONNECTIONS',
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, element.element_name, status);
    IFEND;

    IF NOT status.normal THEN
      cmp$free_descriptor (command);
      RETURN;
    IFEND;

    IF parameter_value_table^ [p$application_information].specified THEN
      ALLOCATE command.application_info_p: [STRLENGTH (parameter_value_table^ [p$application_information].
            value^.string_value^)] IN osv$task_private_heap^;
      command.application_info_p^ := parameter_value_table^ [p$application_information].value^.string_value^;
    IFEND;

    IF parameter_value_table^ [p$site_information].specified THEN
      ALLOCATE command.site_info_p: [STRLENGTH (parameter_value_table^ [p$site_information].value^.
            string_value^)] IN osv$task_private_heap^;
      command.site_info_p^ := parameter_value_table^ [p$site_information].value^.string_value^;
    IFEND;

    IF command_name = 'ADD_ELEMENT_DEFINITION' THEN
      cmp$add_definition (command, status);
    ELSEIF command_name = 'REPLACE_ELEMENT_DEFINITION' THEN
      cmp$replace_definition (command.element_name, command, status);
    ELSEIF command_name = 'DEFINE_ELEMENT' THEN
      cmp$build_descriptor (command, status);
      IF (NOT saved_status.normal) AND status.normal THEN
        status := saved_status;
      IFEND;
    IFEND;

  PROCEND cmp$crack_parameters;
?? OLDTITLE ??
?? NEWTITLE := '   cmp$delete_all_elements', EJECT ??

{ PURPOSE:
{    This procedure goes thru the list of names defined
{  in the physical configuration file and matchs each of them with
{  the names in the exclude names list. If a match is not found then it deletes
{  the name.


  PROCEDURE [XDCL, #GATE] cmp$delete_all_elements
    (    exclude_names_list_p: ^array [ * ] of cmt$element_name;
     VAR status: ost$status);

    VAR
      current_p: ^cmt$pcu_command_descriptor,
      found: boolean,
      list_index: integer;

    status.normal := TRUE;
    IF cmv$command_descriptor_p <> NIL THEN
      current_p := cmv$command_descriptor_p;
      WHILE current_p <> NIL DO
        found := FALSE;
        IF exclude_names_list_p <> NIL THEN

        /match_name/
          FOR list_index := LOWERBOUND (exclude_names_list_p^) TO UPPERBOUND (exclude_names_list_p^) DO
            IF exclude_names_list_p^ [list_index] = current_p^.element_name THEN
              found := TRUE;
              EXIT /match_name/;
            IFEND;
          FOREND /match_name/;
        IFEND;
        IF NOT found THEN
          cmp$delete_definition (current_p^.element_name, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        current_p := current_p^.next_descriptor;
      WHILEND;
    ELSE
      osp$set_status_condition ( cme$pcu_empty_file,  status);
    IFEND;

  PROCEND cmp$delete_all_elements;

?? OLDTITLE ??
?? NEWTITLE := '   cpm$delete_definition', EJECT ??

{ PURPOSE:
{    This procedure search for an element name in a
{    configuration file and delete its definition


  PROCEDURE [XDCL, #GATE] cmp$delete_definition
    (    element_name: cmt$element_name;
     VAR status: ost$status);

    VAR
      current_p: ^cmt$pcu_command_descriptor,
      found: boolean,
      previous_p: ^cmt$pcu_command_descriptor;

    status.normal := TRUE;

  /main_program/
    BEGIN
      IF cmv$command_descriptor_p <> NIL THEN
        current_p := cmv$command_descriptor_p;
        previous_p := current_p;
        found := FALSE;

      /link_list_loop/
        WHILE current_p <> NIL DO
          found := current_p^.element_name = element_name;
          IF found THEN
            IF current_p = cmv$command_descriptor_p THEN
              cmv$command_descriptor_p := current_p^.next_descriptor;
              IF current_p = cmv$end_list_p THEN
                cmv$end_list_p := current_p^.next_descriptor;
              IFEND;
            ELSE
              previous_p^.next_descriptor := current_p^.next_descriptor;
              IF current_p = cmv$end_list_p THEN
                cmv$end_list_p := previous_p;
              IFEND;
            IFEND;
            EXIT /link_list_loop/;
          ELSE
            previous_p := current_p;
            current_p := current_p^.next_descriptor;
          IFEND;

        WHILEND /link_list_loop/;
      ELSE
        osp$set_status_condition ( cme$pcu_empty_file,  status);
        EXIT /main_program/;
      IFEND;

      IF found THEN
        cmp$free_descriptor (current_p^);
        FREE current_p IN osv$task_private_heap^;
      ELSE
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_element_not_found, element_name,
              status);
      IFEND;

    END /main_program/;

  PROCEND cmp$delete_definition;


?? OLDTITLE ??
?? NEWTITLE := '   cmp$determine_element_type', EJECT ??

{ PURPOSE:
{   This procedure figures out the element type given the product id string,
{   then stores the product id into a CYBIL type cmt$product_identification.

  PROCEDURE [XDCL, #GATE] cmp$determine_element_type
    (    product_id_string: ost$name;
     VAR element_definition: cmt$element_definition;
     VAR status: ost$status);

    VAR
      local_product_id: ost$name;

    status.normal := TRUE;

    local_product_id := product_id_string;
    cmp$get_product_id(local_product_id, element_definition, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cmp$known_controller_id (element_definition.product_id) THEN
      IF element_definition.product_id.product_number = '$65354' THEN
        element_definition.element_type := cmc$external_processor_element;
      ELSEIF element_definition.product_id.product_number = ' $2629' THEN
        element_definition.element_type := cmc$channel_adapter_element;
      ELSEIF (element_definition.product_id.product_number = '  $380') OR
            (element_definition.product_id.product_number = ' $2620') OR
            (element_definition.product_id.product_number = ' $5380') OR
            (element_definition.product_id.product_number = ' $4000') OR
            (element_definition.product_id.product_number = ' $7040') OR
            (element_definition.product_id.product_number = ' $2621') THEN
        element_definition.element_type := cmc$communications_element;
      ELSE
        element_definition.element_type := cmc$controller_element;
      IFEND;
    ELSE
      IF cmp$known_product_id (element_definition.product_id) THEN
        element_definition.element_type := cmc$storage_device_element;
      IFEND;
    IFEND;

  PROCEND cmp$determine_element_type;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$display_descriptor', EJECT ??

{ PURPOSE:
{    This procedure displays the DEFINE_ELEMENT command
{    from the input file to EDIT_PHYSICAL_CONFIGURATION.

  PROCEDURE cmp$display_descriptor
    (    current_p: ^cmt$pcu_command_descriptor;
         fid: amt$file_identifier;
     VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      in_line: string (osc$max_string_size),
      index: integer,
      i: 0 .. osc$max_string_size,
      line: string (osc$max_string_size),
      option: clt$data_representation_option,
      representation: ^clt$data_representation,
      string_count: ^clt$data_representation_count,
      string_ptr: ^clt$string_value,
      string_size: ^clt$string_size,
      str: ost$string,
      value: clt$data_value,
      work_area: ^^clt$work_area;

    line := '    ';
    line (2, 19) := 'DEFINE_ELEMENT E = ';
    line (21, 31) := current_p^.element_name;
    trim_blank (line, i);
    IF current_p^.same_as <> osc$null_name THEN
      line (i, 10) := 'SAME_AS = ';
      line (i + 11, 31) := current_p^.same_as;
      trim_blank (line, i);
    IFEND;
    line (i, 2) := '..';
    i := i + 2;
    amp$put_next (fid, ^line, i, byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    line := '   ';

    IF current_p^.pid <> osc$null_name THEN
      line (5, 25) := 'ELEMENT_IDENTIFICATION = ';
      line (30, 10) := current_p^.pid;
      trim_blank (line, i);
    IFEND;


    IF current_p^.state <> osc$null_name THEN
      line (i, 8) := 'STATE = ';
      line (i + 8, 5) := current_p^.state;
      trim_blank (line, i);
    IFEND;
    IF current_p^.sn <> 0 THEN
      line (i, 16) := 'SERIAL_NUMBER = ';
      clp$convert_integer_to_string (current_p^.sn, 10, FALSE, str, status);
      line (i + 16, str.size) := str.value (1, str.size);
      trim_blank (line, i);
    IFEND;
    line (i, 2) := '..';
    i := i + 2;
    amp$put_next (fid, ^line, i, byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    line := '  ';
    IF current_p^.ioupn <> osc$null_name THEN
      line (5, 19) := 'IOU_PROGRAM_NAME = ';
      line (24, 31) := current_p^.ioupn;
      trim_blank (line, i);
      line (i, 2) := '..';
      i := i + 2;
      amp$put_next (fid, ^line, i, byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      line := '   ';
    IFEND;

    CASE current_p^.connection OF
    = cmc$central_memory_connection =
      IF current_p^.cmc_list <> NIL THEN
        line (5, 28) := 'CENTRAL_MEMORY_CONNECTION = ';
        line (34, 4) := '( ..';
        amp$put_next (fid, ^line, i, byte_address, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        FOR index := LOWERBOUND (current_p^.cmc_list^) TO UPPERBOUND (current_p^.cmc_list^) DO
          line := '   ';
          line (10, 2) := ' (';
          clp$convert_integer_to_string (current_p^.cmc_list^ [index].port, 10, FALSE, str, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          line (13, * ) := str.value;
          trim_blank (line, i);
          line (i, * ) := current_p^.cmc_list^ [index].mainframe;
          trim_blank (line, i);
          IF index = UPPERBOUND (current_p^.cmc_list^) THEN
            line (i, 5) := ')) ..';
          ELSE
            line (i, 5) := ')  ..';
          IFEND;
          i := i + 5;
          amp$put_next (fid, ^line, i, byte_address, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
      IFEND;
      line := '    ';
      IF current_p^.channel_list <> NIL THEN
        line (5, 17) := 'IOU_CONNECTION = ';
        line (22, 4) := '( ..';
        amp$put_next (fid, ^line, 30, byte_address, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        FOR index := LOWERBOUND (current_p^.channel_list^) TO UPPERBOUND (current_p^.channel_list^) DO
          line := '   ';
          line (10, 2) := '( ';
          line (13, * ) := current_p^.channel_list^ [index].channel;
          trim_blank (line, i);
          clp$convert_integer_to_string (current_p^.channel_list^ [index].equipment, 10, FALSE, str, status);
          line (i, * ) := str.value;
          trim_blank (line, i);
          IF current_p^.channel_list^ [index].mainframe <> osc$null_name THEN
            line (i, * ) := current_p^.channel_list^ [index].mainframe;
            trim_blank (line, i);
          IFEND;
          IF current_p^.channel_list^ [index].iou <> osc$null_name THEN
            line (i, * ) := current_p^.channel_list^ [index].iou;
            trim_blank (line, i);
          IFEND;
          IF index = UPPERBOUND (current_p^.channel_list^) THEN
            line (i, 5) := ')) ..';
          ELSE
            line (i, 5) := ')  ..';
          IFEND;
          i := i + 5;
          amp$put_next (fid, ^line, i, byte_address, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;

      IFEND;


    = cmc$iou_connection =
      IF current_p^.iou_list <> NIL THEN
        line (5, 17) := 'IOU_CONNECTION = ';
        line (22, 4) := '( ..';
        amp$put_next (fid, ^line, 30, byte_address, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        FOR index := LOWERBOUND (current_p^.iou_list^) TO UPPERBOUND (current_p^.iou_list^) DO
          line := '   ';
          line (10, 2) := '( ';
          line (13, * ) := current_p^.iou_list^ [index].channel;
          trim_blank (line, i);
          clp$convert_integer_to_string (current_p^.iou_list^ [index].equipment, 10, FALSE, str, status);
          line (i, * ) := str.value;
          trim_blank (line, i);
          IF current_p^.iou_list^ [index].mainframe <> osc$null_name THEN
            line (i, * ) := current_p^.iou_list^ [index].mainframe;
            trim_blank (line, i);
          IFEND;
          IF current_p^.iou_list^ [index].iou <> osc$null_name THEN
            line (i, * ) := current_p^.iou_list^ [index].iou;
            trim_blank (line, i);
          IFEND;
          IF index = UPPERBOUND (current_p^.iou_list^) THEN
            line (i, 5) := ')) ..';
          ELSE
            line (i, 5) := ')  ..';
          IFEND;
          i := i + 5;
          amp$put_next (fid, ^line, i, byte_address, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
      IFEND;

    = cmc$peripheral_connection =
      IF current_p^.pc_list <> NIL THEN
        line (5, 24) := 'PERIPHERAL_CONNECTION = ';
        line (29, 4) := '( ..';
        amp$put_next (fid, ^line, 34, byte_address, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        FOR index := LOWERBOUND (current_p^.pc_list^) TO UPPERBOUND (current_p^.pc_list^) DO
          line := '  ';
          line (10, 2) := ' (';
          line (13, * ) := current_p^.pc_list^ [index].peripheral;
          trim_blank (line, i);
          clp$convert_integer_to_string (current_p^.pc_list^ [index].address, 10, FALSE, str, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          line (i, * ) := str.value;
          trim_blank (line, i);
          IF index = UPPERBOUND (current_p^.pc_list^) THEN
            line (i, 5) := ')) ..';
          ELSE
            line (i, 5) := ')  ..';
          IFEND;
          i := i + 5;
          amp$put_next (fid, ^line, i, byte_address, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    CASEND;

    line := '    ';
    line (5, 32) := 'VERIFY_ELEMENT_IDENTIFICATION = ';
    IF current_p^.verify THEN
      IF (current_p^.application_info_p <> NIL) OR (current_p^.site_info_p <> NIL) THEN
        line (37, 8) := 'TRUE ..';
      ELSE
        line (37, 5) := 'TRUE ';
      IFEND;
    ELSE
      IF (current_p^.application_info_p <> NIL) OR (current_p^.site_info_p <> NIL) THEN
        line (37, 8) := 'FALSE ..';
      ELSE
        line (37, 5) := 'FALSE';
      IFEND;
    IFEND;
    amp$put_next (fid, ^line, 45, byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    line := '  ';
    IF (current_p^.application_info_p <> NIL) OR (current_p^.site_info_p <> NIL) THEN
      clp$get_work_area (#RING (^work_area), work_area, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    IF current_p^.application_info_p <> NIL THEN
      line (5, 28) := 'APPLICATION_INFORMATION = ..';
      amp$put_next (fid, ^line, 33, byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      value.kind := clc$string;
      value.string_value := current_p^.application_info_p;
      clp$convert_data_to_string (^value, clc$data_source_representation, 65, work_area^,
            representation, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      NEXT string_count IN representation;
      FOR i := 1 TO string_count^ DO
        line := ' ';
        NEXT string_size IN representation;
        NEXT string_ptr: [string_size^] IN representation;
        line (11, string_size^) := string_ptr^;
        IF (i = string_count^) AND (current_p^.site_info_p <> NIL) THEN
          line (string_size^+11, 3) := ' ..';
        IFEND;
        #TRANSLATE(osv$lower_to_upper, line, line);
        amp$put_next (fid, ^line, string_size^+14, byte_address, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
      RESET work_area^ TO representation;
    IFEND;
    IF current_p^.site_info_p <> NIL THEN
      line := '   ';
      line (5, 21) := 'SITE_INFORMATION = ..';
      amp$put_next (fid, ^line, 26, byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      value.kind := clc$string;
      value.string_value := current_p^.site_info_p;
      clp$convert_data_to_string (^value, clc$data_source_representation, 65, work_area^,
            representation, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      NEXT string_count IN representation;
      FOR i := 1 TO string_count^ DO
        line := '  ';
        NEXT string_size IN representation;
        NEXT string_ptr: [string_size^] IN representation;
        line (11, string_size^) := string_ptr^;
        #TRANSLATE(osv$lower_to_upper, line, line);
        amp$put_next (fid, ^line, string_size^+11, byte_address, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
      RESET work_area^ TO representation;
    IFEND;
    line := '  ';
    amp$put_next (fid, ^line, 2, byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND cmp$display_descriptor;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$display_elements_def', EJECT ??

{ PURPOSE:
{    This procedures display the command definition of an
{    element name.

  PROCEDURE [XDCL, #GATE] cmp$display_elements_def
    (    display_option: cmt$lcu_display_option_key;
         display_by_name: boolean;
         name: cmt$element_name;
         file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      current_p: ^cmt$pcu_command_descriptor,
      display_once: boolean,
      element: cmt$element_definition,
      found: boolean,
      index: ost$string_index,
      same_as_p: ^cmt$pcu_command_descriptor;

    status.normal := TRUE;
    display_once := FALSE;
    found := FALSE;

  /main_program/
    BEGIN

      IF cmv$command_descriptor_p <> NIL THEN
        current_p := cmv$command_descriptor_p;
        IF NOT display_by_name THEN
          CASE display_option OF
          = cmc$lcu_do_all =
            WHILE current_p <> NIL DO
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              cmp$display_descriptor (current_p, file_id, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              display_once := TRUE;
              current_p := current_p^.next_descriptor;
            WHILEND;

          = cmc$lcu_do_channel =
            ;
          = cmc$lcu_do_controller =
            WHILE current_p <> NIL DO
              IF current_p^.pid <> osc$null_name THEN
                cmp$determine_element_type (current_p^.pid, element, status);
              ELSE
                same_as_p := cmv$command_descriptor_p;

              /same_as_loop_1/
                WHILE same_as_p <> NIL DO
                  IF same_as_p^.element_name = current_p^.same_as THEN
                    cmp$determine_element_type (same_as_p^.pid, element, status);
                    EXIT /same_as_loop_1/;
                  ELSE
                    same_as_p := same_as_p^.next_descriptor;
                  IFEND;
                WHILEND /same_as_loop_1/;
              IFEND;
              IF NOT status.normal THEN
                status.normal := TRUE;
                IF current_p^.connection = cmc$iou_connection THEN
                  IF current_p^.iou_list <> NIL THEN
                    element.element_type := cmc$controller_element;
                  IFEND;
                IFEND;
              IFEND;
              IF element.element_type = cmc$controller_element THEN
                cmp$display_descriptor (current_p, file_id, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
                display_once := TRUE;
              IFEND;
              current_p := current_p^.next_descriptor;
            WHILEND;

          = cmc$lcu_do_channel_adapter =
            WHILE current_p <> NIL DO
              IF current_p^.pid <> osc$null_name THEN
                cmp$determine_element_type (current_p^.pid, element, status);
              ELSE
                same_as_p := cmv$command_descriptor_p;

              /same_as_loop_ca/
                WHILE same_as_p <> NIL DO
                  IF same_as_p^.element_name = current_p^.same_as THEN
                    cmp$determine_element_type (same_as_p^.pid, element, status);
                    EXIT /same_as_loop_ca/;
                  ELSE
                    same_as_p := same_as_p^.next_descriptor;
                  IFEND;
                WHILEND /same_as_loop_ca/;
              IFEND;
              IF NOT status.normal THEN
                status.normal := TRUE;
                IF current_p^.connection = cmc$iou_connection THEN
                  IF current_p^.iou_list <> NIL THEN
                    element.element_type := cmc$channel_adapter_element;
                  IFEND;
                IFEND;
              IFEND;
              IF element.element_type = cmc$channel_adapter_element THEN
                cmp$display_descriptor (current_p, file_id, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
                display_once := TRUE;
              IFEND;
              current_p := current_p^.next_descriptor;
            WHILEND;

          = cmc$lcu_do_communications =
            WHILE current_p <> NIL DO
              IF current_p^.pid <> osc$null_name THEN
                cmp$determine_element_type (current_p^.pid, element, status);
              ELSE
                same_as_p := cmv$command_descriptor_p;

              /same_as_loop_comm/
                WHILE same_as_p <> NIL DO
                  IF same_as_p^.element_name = current_p^.same_as THEN
                    cmp$determine_element_type (same_as_p^.pid, element, status);
                    EXIT /same_as_loop_comm/;
                  ELSE
                    same_as_p := same_as_p^.next_descriptor;
                  IFEND;
                WHILEND /same_as_loop_comm/;
              IFEND;
              IF NOT status.normal THEN
                status.normal := TRUE;
                IF current_p^.connection = cmc$iou_connection THEN
                  IF current_p^.iou_list <> NIL THEN
                    element.element_type := cmc$communications_element;
                  IFEND;
                IFEND;
              IFEND;
              IF element.element_type = cmc$communications_element THEN
                cmp$display_descriptor (current_p, file_id, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
                display_once := TRUE;
              IFEND;
              current_p := current_p^.next_descriptor;
            WHILEND;

          = cmc$lcu_do_storage_device =
            WHILE current_p <> NIL DO
              IF current_p^.pid <> osc$null_name THEN
                cmp$determine_element_type (current_p^.pid, element, status);
              ELSE
                same_as_p := cmv$command_descriptor_p;

              /same_as_loop_2/
                WHILE same_as_p <> NIL DO
                  IF same_as_p^.element_name = current_p^.same_as THEN
                    cmp$determine_element_type (same_as_p^.pid, element, status);
                    EXIT /same_as_loop_2/;
                  ELSE
                    same_as_p := same_as_p^.next_descriptor;
                  IFEND;
                WHILEND /same_as_loop_2/;
              IFEND;
              IF NOT status.normal THEN
                status.normal := TRUE;
                IF current_p^.connection = cmc$peripheral_connection THEN
                  element.element_type := cmc$storage_device_element;
                IFEND;
              IFEND;
              IF element.element_type = cmc$storage_device_element THEN
                cmp$display_descriptor (current_p, file_id, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
                display_once := TRUE;
              IFEND;
              current_p := current_p^.next_descriptor;
            WHILEND;

          = cmc$lcu_do_external_processor =
            WHILE current_p <> NIL DO
              IF current_p^.pid <> osc$null_name THEN
                cmp$determine_element_type (current_p^.pid, element, status);
              ELSE
                same_as_p := cmv$command_descriptor_p;

              /same_as_loop_3/
                WHILE same_as_p <> NIL DO
                  IF same_as_p^.element_name = current_p^.same_as THEN
                    cmp$determine_element_type (same_as_p^.pid, element, status);
                    EXIT /same_as_loop_3/;
                  ELSE
                    same_as_p := same_as_p^.next_descriptor;
                  IFEND;
                WHILEND /same_as_loop_3/;
              IFEND;
              IF NOT status.normal THEN
                status.normal := TRUE;
                IF current_p^.connection = cmc$central_memory_connection THEN
                  element.element_type := cmc$external_processor_element;
                IFEND;
              IFEND;
              IF element.element_type = cmc$external_processor_element THEN
                cmp$display_descriptor (current_p, file_id, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
                display_once := TRUE;
              IFEND;
              current_p := current_p^.next_descriptor;
            WHILEND;

          CASEND;
        ELSE

{ display by name

        /loop/
          WHILE current_p <> NIL DO
            IF current_p^.element_name = name THEN
              found := TRUE;
              cmp$display_descriptor (current_p, file_id, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              display_once := TRUE;
              EXIT /loop/;
            IFEND;
            current_p := current_p^.next_descriptor;
          WHILEND /loop/;
          IF NOT found THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_element_not_found, name,
                  status);
            EXIT /main_program/;
          IFEND;
        IFEND;
        IF NOT display_once THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_element_not_found,
                ' Element type specified ', status);
          EXIT /main_program/;
        IFEND;

      ELSE
        osp$set_status_condition ( cme$pcu_empty_file,  status);
      IFEND;

    END /main_program/;

  PROCEND cmp$display_elements_def;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$find_state_element', EJECT ??

{ PURPOSE:
{     This procedure returns the state information of an element.
{     This is primarely used in case one specify same_as on
{     DEFINE_ELEMENT.

  PROCEDURE [XDCL, #GATE] cmp$find_state_element
    (    element_name: cmt$element_name;
         iou_name: cmt$element_name;
         fid: amt$file_identifier;
     VAR element: ^cmt$state_information;
     VAR status: ost$status);

    VAR
      eoi_addr: array [1 .. 1] of amt$access_info,
      found: boolean,
      loop_count,
      loop_index: integer,
      seg: amt$segment_pointer;

    status.normal := TRUE;

  /main_program/
    BEGIN

      eoi_addr [1].key := amc$eoi_byte_address;
      amp$get_segment_pointer (fid, amc$sequence_pointer, seg, status);

      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      amp$fetch_access_information (fid, eoi_addr, status);

      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF NOT eoi_addr [1].item_returned THEN
        osp$set_status_condition ( cme$lcm_incompatible_lc,  status);
        EXIT /main_program/;
      IFEND;

      loop_count := eoi_addr [1].eoi_byte_address DIV #SIZE (cmt$state_information);
      RESET seg.sequence_pointer;
      found := FALSE;
      FOR loop_index := 1 TO loop_count DO
        NEXT element IN seg.sequence_pointer;
        IF element^.element_name = element_name THEN
          IF element^.element_type = cmc$data_channel_element THEN
            found := iou_name = element^.iou;
          ELSE
            found := TRUE;
          IFEND;
          IF found THEN
            EXIT /main_program/;
          IFEND;
        IFEND;
        IF element^.element_type <> cmc$data_channel_element THEN
          IF element^.application_info_size <> 0 THEN
            NEXT element^.application_info_p: [element^.application_info_size]
                  IN seg.sequence_pointer;
          IFEND;
          IF element^.site_info_size <> 0 THEN
            NEXT element^.site_info_p: [element^.site_info_size]
                  IN seg.sequence_pointer;
          IFEND;
        IFEND;
      FOREND;

      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_element_not_found, element_name,
            status);

    END /main_program/;

  PROCEND cmp$find_state_element;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$free_descriptor', EJECT ??

{ PURPOSE:
{     This procedure frees a command descriptor connection list
{     pointer, allocated in Task private.

  PROCEDURE cmp$free_descriptor
    (VAR command: cmt$pcu_command_descriptor);

    IF command.application_info_p <> NIL THEN
      FREE command.application_info_p IN osv$task_private_heap^;
    IFEND;
    IF command.site_info_p <> NIL THEN
      FREE command.site_info_p IN osv$task_private_heap^;
    IFEND;
    CASE command.connection OF
    = cmc$central_memory_connection =
      IF command.cmc_list <> NIL THEN
        FREE command.cmc_list IN osv$task_private_heap^;
      IFEND;
      IF command.channel_list <> NIL THEN
        FREE command.channel_list IN osv$task_private_heap^;
      IFEND;
    = cmc$iou_connection =
      IF command.iou_list <> NIL THEN
        FREE command.iou_list IN osv$task_private_heap^;
      IFEND;
    = cmc$peripheral_connection =
      IF command.pc_list <> NIL THEN
        FREE command.pc_list IN osv$task_private_heap^;
      IFEND;
    ELSE
      ;
    CASEND;

  PROCEND cmp$free_descriptor;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$get_product_id', EJECT ??

{ PURPOSE:
{   This procedure converts the product id into
{   the CYBIL type cmt$product_identification.

  PROCEDURE cmp$get_product_id
    (VAR product_id: ost$name;
     VAR element: cmt$element_definition;
     VAR status: ost$status);

    VAR
      del: integer;

    status.normal := TRUE;

    IF product_id (1, 1) <> '$' THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_element_id,
            element.element_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            ' the ELEMENT_IDENTIFICATION must begin with a ''$''', status);
      RETURN;
    IFEND;

  /loop1/
    FOR del := 2 TO 8 DO
      IF product_id (del, 1) = '_' THEN
        EXIT /loop1/;
      IFEND;
    FOREND /loop1/;

    IF del = 8 THEN
      {
      { An underscore was not found in the specified element_identification.
      {
      IF product_id = '  $887' THEN
        element.product_id.product_number := '     ';
        element.product_id.product_number := product_id (1, 6);
        element.product_id.underscore := '_';
        element.product_id.model_number := '1   ';
      ELSE
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_element_id,
              element.element_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              ' an underscore ''_'', must separate the product number and the model number.', status);
      IFEND;
      RETURN;
    IFEND;

    element.product_id.product_number := '     ';
    element.product_id.product_number ((8 - del), (del - 1)) := product_id (1, del - 1);
    element.product_id.underscore := '_';

    IF (product_id (del + 1, 3) = 'xxx') OR (product_id (del + 1, 3) = 'XXX') THEN
      IF (element.product_id.product_number = ' $2620') OR (element.product_id.product_number = ' $2621') THEN
        product_id (del + 1, 3) := '210';
      ELSEIF (element.product_id.product_number = '  $836') THEN
        product_id (del + 1, 3) := '110';
      IFEND;
    ELSEIF (product_id (del + 2, 1) = 'x') OR (product_id (del + 2, 1) = 'X') THEN
      IF (element.product_id.product_number = '  $698') OR (element.product_id.product_number = ' $5698') OR
            (element.product_id.product_number = '$65354') THEN
        product_id (del + 2, 1) := '0';
      ELSEIF (element.product_id.product_number = ' $7155') OR
            (element.product_id.product_number = ' $7165') OR
            (element.product_id.product_number = ' $7021') OR
            (element.product_id.product_number = '  $844') OR
            (element.product_id.product_number = '  $885') THEN
        product_id (del + 2, 1) := '1';
      ELSEIF (element.product_id.product_number = ' $5682') THEN
        product_id (del + 2, 1) := '2';
      IFEND;
    ELSEIF (product_id (del + 1, 1) = 'x') OR (product_id (del + 1, 1) = 'X') THEN
      IF (element.product_id.product_number = ' $9853') OR (element.product_id.product_number = ' $2629') THEN
        product_id (del + 1, 1) := '1';
      ELSEIF (element.product_id.product_number = '  $679') THEN
        product_id (del + 1, 1) := '7';
      IFEND;
    IFEND;

    element.product_id.model_number := product_id (del + 1, 3);

  PROCEND cmp$get_product_id;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$get_serial_number', EJECT ??

{ PURPOSE:
{    This procedure converts the serial number
{    and saves it in the definition of the element.

  PROCEDURE cmp$get_serial_number
    (    serial_number: clt$integer;
     VAR element: cmt$element_definition;
     VAR status: ost$status);

    VAR
      str: ost$string;

    status.normal := TRUE;

    clp$convert_integer_to_string (serial_number.value, 10, FALSE, str, status);
    IF status.normal THEN
      IF str.size > STRLENGTH (element.serial_number) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_value_out_of_range,
              'SERIAL_NUMBER is too large', status);
      ELSE
        cmp$check_for_unique_ser_num (str, element.product_id, cmv$cmd_value_fid, status);
        IF status.normal THEN
          element.serial_number := str.value;
        IFEND;
      IFEND;
    IFEND;

  PROCEND cmp$get_serial_number;


?? OLDTITLE ??
?? NEWTITLE := '   cmp$increment_pcu_error_count', EJECT ??

{ PURPOSE:
{    This procedure increments the count of errors encountered
{    while processing the PCU define_element subcommands.

  PROCEDURE [XDCL, #GATE] cmp$increment_pcu_error_count;

    cmv$pcu_error_count := cmv$pcu_error_count + 1;

  PROCEND cmp$increment_pcu_error_count;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$open_utility_files', EJECT ??

{ PURPOSE:
{   This procedure opens the global files used to store definition
{   of peripheral elements and their state information.

  PROCEDURE [XDCL, #GATE] cmp$open_utility_files
    (VAR status: ost$status);

    VAR
      local_file,
      existing_file,
      contains_data: boolean,
      local_status: ost$status,
      output_file,
      input_file: amt$local_file_name,
      input_fid,
      output_fid: amt$file_identifier,
      byte_address: amt$file_byte_address,
      unique_name: ost$unique_name,
      get_attr: array [1 .. 1] of amt$get_item,
      file_attr: array [1 .. 1] of amt$access_selection;

    status.normal := TRUE;

  /main_program/
    BEGIN

      file_attr [1].key := amc$access_mode;
      file_attr [1].access_mode := $pft$usage_selections [pfc$shorten, pfc$read, pfc$modify, pfc$append,
            pfc$execute];


      get_attr [1].key := amc$null_attribute;
      REPEAT

        pmp$generate_unique_name (unique_name, status);

        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        amp$get_file_attributes (unique_name.value, get_attr, local_file, existing_file, contains_data,
              status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

      UNTIL NOT local_file;

      cmv$cmd_value_name := unique_name.value;
      amp$open (cmv$cmd_value_name, amc$segment, ^file_attr, cmv$cmd_value_fid, status);

      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      REPEAT

        pmp$generate_unique_name (unique_name, status);

        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        amp$get_file_attributes (unique_name.value, get_attr, local_file, existing_file, contains_data,
              status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

      UNTIL NOT local_file;

      cmv$state_value_name := unique_name.value;

      amp$open (cmv$state_value_name, amc$segment, ^file_attr, cmv$state_value_fid, status);

      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    END /main_program/;


  PROCEND cmp$open_utility_files;


?? OLDTITLE ??
?? NEWTITLE := '   cmp$process_define_element', EJECT ??

{ PURPOSE:
{     This procedure processes the parameter list of the PCU
{     subcommands DEFINE_ELEMENT and builds the data structures
{     needed to verify and/or activate the configuration.
{ NOTE:
{     This routine is called only when subcommands are being
{     processed via INSTALL_PHYSICAL_CONFIGURATION or
{     VERIFY_PHYSICAL_CONFIGURATION command.

  PROCEDURE [XDCL, #GATE] cmp$process_define_element
    (    parameter_value_table: ^clt$parameter_value_table;
     VAR status: ost$status);

    CONST
      command_name = 'DEFINE_ELEMENT';

    VAR
      map_state: [STATIC, READ, oss$job_paged_literal] array [cmt$element_state] of string (4) := ['ON  ',
            'OFF ', 'DOWN'];

    TYPE
      channel_definition = packed record
        configured: boolean,
        descriptor: cmt$element_definition,
      recend;

    VAR
      alternate_driver_name: dst$driver_name,
      channel_def: cmt$data_channel_definition,
      channel_descriptor: cmt$channel_descriptor,
      channel_element_p: ^array [ * ] of channel_definition,
      channel_name: cmt$element_name,
      connection_number: integer,
      connection_specified: boolean,
      comm_port_number: cmt$communications_port_number,
      ct_port_number: cmt$controller_port_number,
      controller_type: cmt$controller_type,
      current_list_entry: ^clt$data_value,
      definition_p: ^cmt$element_definition,
      driver_name: dst$driver_name,
      element_is_a_unit: boolean,
      equipment_number: cmt$physical_equipment_number,
      element: cmt$element_definition,
      element_name: cmt$element_name,
      field_index: integer,
      found: boolean,
      i: integer,
      io_unit_type: iot$unit_type,
      iou_name: cmt$element_name,
      iou_number: dst$iou_number,
      local_status: ost$status,
      list_index: integer,
      mainframe_name: cmt$element_name,
      p_unit_number: cmt$physical_unit_number,
      pen: cmt$physical_equipment_number,
      peripheral_element: cmt$element_name,
      physical_address: cmt$physical_unit_number,
      port: 0 .. 3,
      port_number: cmt$controller_port_number,
      pp_module_name: pmt$program_name,
      same_as: boolean,
      same_element_p: ^cmt$element_definition,
      same_state_element_p: ^cmt$state_information,
      segment_pointer: amt$segment_pointer,
      specified_address: boolean,
      standard_product: boolean,
      state: cmt$element_state,
      state_element_p: ^cmt$state_information,
      state_index: cmt$element_state,
      state_value: ost$name,
      state_segment_pointer: amt$segment_pointer,
      unit_type: cmt$unit_type,
      unit_class: cmt$unit_class,
      valid_ipn: boolean;

    status.normal := TRUE;
    channel_element_p := NIL;
    element_name := parameter_value_table^ [p$element].value^.name_value;

    cmp$check_reserved_names (element_name, cmv$reserved_names_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$check_for_unique_element (element_name, osc$null_name, cmv$cmd_value_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    same_as := parameter_value_table^ [p$same_as].specified;
    IF same_as THEN
      cmp$find_element (parameter_value_table^ [p$same_as].value^.name_value, {unused} iou_name,
            osc$null_name, cmv$cmd_value_fid, same_element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      element := same_element_p^;
      cmp$find_state_element (parameter_value_table^ [p$same_as].value^.name_value, {unused} iou_name,
            cmv$state_value_fid, same_state_element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    element.element_name := element_name;
    standard_product := parameter_value_table^ [p$verify_element_identification].value^.boolean_value.value;

    IF NOT parameter_value_table^ [p$element_identification].specified THEN
      IF NOT same_as THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_missing_parameters,
              'ELEMENT_IDENTIFICATION', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
        RETURN;
      IFEND;
    ELSE
      cmp$get_product_id (parameter_value_table^ [p$element_identification].value^.name_value, element,
            status);
      IF NOT status.normal THEN
        IF NOT standard_product THEN
          RETURN;
        ELSE
          status.normal := TRUE;
        IFEND;
      IFEND;
    IFEND;

{ Determine the need to check for unique serial number
{ based on product_id and also  determine element type.

    IF standard_product THEN
      IF NOT cmp$known_controller_id (element.product_id) AND NOT cmp$known_product_id
            (element.product_id) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_unknown_product_id,
              parameter_value_table^ [p$element_identification].value^.name_value, status);
        RETURN;
      IFEND;
      IF cmp$known_controller_id (element.product_id) THEN
        cmp$get_controller_type (element.product_id, controller_type, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        CASE controller_type OF
        = cmc$ms7154_x .. cmc$mscm3_ct, cmc$mt7021_3x, cmc$mt698_xx, cmc$mt5698_xx, cmc$mt7021_4x,
              cmc$ms5831_x, cmc$mt5680_xx, cmc$mt7221_1, cmc$mt7221_2_s0, cmc$ms7255_1_1, cmc$ms7255_1_2 =
          element.element_type := cmc$controller_element;
        = cmc$mp65354_11 =
          element.element_type := cmc$external_processor_element;
        = cmc$ca2629_2 =
          element.element_type := cmc$channel_adapter_element;
        = cmc$lcn380_170, cmc$mti2620_21x, cmc$mdi2621_21x, cmc$fs740_200, cmc$expresslink =
          element.element_type := cmc$communications_element;
        ELSE
        CASEND;
      ELSE
        IF cmp$known_product_id (element.product_id) THEN
          element.element_type := cmc$storage_device_element;
        IFEND;
      IFEND;
    ELSE
      IF cmp$known_controller_id (element.product_id) OR cmp$known_product_id (element.product_id) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
              'Invalid usage of VERIFY_ELEMENT_IDENTIFICATION parameter', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
        RETURN;
      IFEND;
      element.element_type := cmc$storage_device_element;
    IFEND;

    IF NOT parameter_value_table^ [p$serial_number].specified THEN
      IF NOT same_as THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_missing_parameters, 'SERIAL_NUMBER',
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
        RETURN;
      IFEND;
    ELSE
      cmp$get_serial_number (parameter_value_table^ [p$serial_number].value^.integer_value, element, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Initialize all connections field.

    CASE element.element_type OF
    = cmc$storage_device_element =
      FOR port_number := LOWERVALUE (cmt$controller_port_number) TO UPPERVALUE (cmt$controller_port_number) DO
        element.storage_device.connection.port [port_number].configured := FALSE;
      FOREND;
    = cmc$controller_element =
      FOR ct_port_number := LOWERVALUE (ct_port_number) TO UPPERVALUE (ct_port_number) DO
        element.controller.connection.port [ct_port_number].configured := FALSE;
      FOREND;
      FOR p_unit_number := LOWERVALUE (p_unit_number) TO UPPERVALUE (p_unit_number) DO
        element.controller.connection.unit [p_unit_number].configured := FALSE;
      FOREND;
    = cmc$external_processor_element =
      FOR pen := LOWERVALUE (cmt$physical_equipment_number) TO UPPERVALUE (cmt$physical_equipment_number) DO
        element.external_processor.connection.io_port [pen].configured := FALSE;
      FOREND;

    = cmc$channel_adapter_element =

{ Channel adapters only have 1 upline connection

      element.channel_adapter.connection.channel.configured := FALSE;
      FOR pen := LOWERVALUE (cmt$physical_equipment_number) TO UPPERVALUE (cmt$physical_equipment_number) DO
        element.channel_adapter.connection.equipment [pen].configured := FALSE;
      FOREND;
    = cmc$communications_element =
      FOR comm_port_number := LOWERVALUE (comm_port_number) TO UPPERVALUE (comm_port_number) DO
        element.communications_element.connection.port [comm_port_number].configured := FALSE;
      FOREND;
    ELSE
    CASEND;

{ Process PERIPHERAL_CONNECTIONS list.

    connection_specified := FALSE;
    connection_number := 0;
    specified_address := FALSE;
    IF parameter_value_table^ [p$peripheral_connection].specified THEN
      element_is_a_unit := TRUE;
      connection_specified := TRUE;
      current_list_entry := parameter_value_table^ [p$peripheral_connection].value;
      IF element.element_type <> cmc$storage_device_element THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
              'Invalid peripheral connection', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
        RETURN;
      IFEND;
      element.storage_device.physical_unit_number := 0;
      physical_address := 0;
      WHILE current_list_entry <> NIL DO
        FOR field_index := LOWERBOUND (current_list_entry^.element_value^.field_values^)
              TO UPPERBOUND (current_list_entry^.element_value^.field_values^) DO

          IF (current_list_entry^.element_value^.field_values^ [field_index].name = 'PERIPHERAL_ELEMENT') THEN
            IF (current_list_entry^.element_value^.field_values^ [field_index].value <> NIL) THEN
              cmp$check_reserved_names (current_list_entry^.element_value^.field_values^ [field_index].value^.
                    name_value, cmv$reserved_names_list, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              peripheral_element := current_list_entry^.element_value^.field_values^ [field_index].value^.
                    name_value;
            IFEND;
          ELSEIF (current_list_entry^.element_value^.field_values^ [field_index].name =
                'PHYSICAL_ADDRESS') THEN
            IF (current_list_entry^.element_value^.field_values^ [field_index].value <> NIL) THEN
              IF NOT specified_address THEN
                specified_address := TRUE;
                physical_address := current_list_entry^.element_value^.field_values^ [field_index].value^.
                      integer_value.value;
              ELSE
                IF physical_address <> current_list_entry^.element_value^.field_values^ [field_index].value^.
                      integer_value.value THEN
                  osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
                        'Physical address mismatch on PERIPHERAL CONNECTIONS', status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        parameter_value_table^ [p$element].value^.name_value, status);
                  RETURN;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        FOREND;
        element.storage_device.connection.port [connection_number].configured := TRUE;
        element.storage_device.connection.port [connection_number].element_name := peripheral_element;
        element.storage_device.physical_unit_number := physical_address;
        cmp$get_unit_type (element.product_id, unit_type, io_unit_type, unit_class, found);
        IF (unit_type = cmc$msfsd2_s0) OR (unit_type = cmc$msxmd_3) THEN
          IF clp$count_list_elements (parameter_value_table^ [p$peripheral_connection].value) > 2 THEN
            osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
                  'Too many peripheral connections specified', status);
            osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
            RETURN;
          IFEND;
        IFEND;
        cmp$validate_address_range (unit_type, physical_address, status);
        IF NOT status.normal THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
          RETURN;
        IFEND;
        IF unit_type = cmc$mshydra THEN
          element.storage_device.connection.port [connection_number].upline_connection_type :=
                cmc$data_channel_element;
        ELSE
          element.storage_device.connection.port [connection_number].upline_connection_type :=
                cmc$controller_element;
        IFEND;
        connection_number := connection_number + 1;
        current_list_entry := current_list_entry^.link;
        IF (current_list_entry <> NIL) AND (connection_number > UPPERVALUE (cmt$data_storage_port_number))
              THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
                'Too many values given on PERIPHERAL_CONNECTIONS', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
          RETURN;
        IFEND;
      WHILEND;
    IFEND;

{ Process IOU_CONNECTIONS List.

    IF parameter_value_table^ [p$iou_connection].specified THEN
      connection_specified := TRUE;
      connection_number := 0;
      IF NOT standard_product THEN
        element.element_type := cmc$controller_element;
        FOR ct_port_number := LOWERVALUE (ct_port_number) TO UPPERVALUE (ct_port_number) DO
          element.controller.connection.port [ct_port_number].configured := FALSE;
        FOREND;
        FOR p_unit_number := LOWERVALUE (p_unit_number) TO UPPERVALUE (p_unit_number) DO
          element.controller.connection.unit [p_unit_number].configured := FALSE;
        FOREND;
      IFEND;
      IF clp$count_list_elements (parameter_value_table^ [p$iou_connection].value) > 0 THEN
        PUSH channel_element_p: [1 .. clp$count_list_elements
              (parameter_value_table^ [p$iou_connection].value)];

        current_list_entry := parameter_value_table^ [p$iou_connection].value;
        list_index := 0;
        specified_address := FALSE;
        equipment_number := 0;
        WHILE current_list_entry <> NIL DO
          mainframe_name := cmv$mainframe_name;
          iou_name := 'IOU0';
          list_index := list_index + 1;
          FOR pen := LOWERVALUE (cmt$physical_equipment_number)
                TO UPPERVALUE (cmt$physical_equipment_number) DO
            channel_element_p^ [list_index].descriptor.data_channel.connection.equipment [pen].configured :=
                  FALSE;
          FOREND;
          FOR field_index := LOWERBOUND (current_list_entry^.element_value^.field_values^)
                TO UPPERBOUND (current_list_entry^.element_value^.field_values^) DO

            IF (current_list_entry^.element_value^.field_values^ [field_index].name = 'CHANNEL') THEN
              IF (current_list_entry^.element_value^.field_values^ [field_index].value <> NIL) THEN
                channel_name := current_list_entry^.element_value^.field_values^ [field_index].value^.
                      name_value;
                IF NOT cmp$valid_channel_name (channel_name) THEN
                  osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_channel_number,
                        command_name, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, channel_name, status);
                  RETURN;
                IFEND;
              IFEND;
            ELSEIF (current_list_entry^.element_value^.field_values^ [field_index].name =
                  'EQUIPMENT') THEN
              IF (current_list_entry^.element_value^.field_values^ [field_index].value <> NIL) THEN
                IF NOT specified_address THEN
                  equipment_number := current_list_entry^.element_value^.field_values^ [field_index].value^.
                      integer_value.value;
                  specified_address := TRUE;
                ELSE
                  IF equipment_number <> current_list_entry^.element_value^.field_values^ [field_index]
                       .value^.integer_value.value THEN
                    osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
                         'Physical address mismatch on IOU CONNECTIONS', status);
                    osp$append_status_parameter (osc$status_parameter_delimiter,
                         parameter_value_table^ [p$element].value^.name_value, status);
                    RETURN;
                  IFEND;
                IFEND;
              IFEND;
            ELSEIF (current_list_entry^.element_value^.field_values^ [field_index].name = 'MAINFRAME') THEN
              IF (current_list_entry^.element_value^.field_values^ [field_index].value <> NIL) THEN
                mainframe_name := current_list_entry^.element_value^.field_values^ [field_index].value^.
                      name_value;
                cmp$validate_mainframe_name (mainframe_name, status);
                IF NOT status.normal THEN
                  osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
                  RETURN;
                IFEND;
              IFEND;
            ELSEIF (current_list_entry^.element_value^.field_values^ [field_index].name = 'IOU') THEN
              IF (current_list_entry^.element_value^.field_values^ [field_index].value <> NIL) THEN
                iou_name := current_list_entry^.element_value^.field_values^ [field_index].value^.name_value;
                cmp$convert_iou_name (iou_name, iou_number, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              IFEND;
            IFEND;
          FOREND;
          CASE element.element_type OF
          = cmc$controller_element =
            element.controller.connection.port [connection_number].configured := TRUE;
            element.controller.connection.port [connection_number].element_name := channel_name;
            element.controller.connection.port [connection_number].upline_connection_type :=
                  cmc$data_channel_element;
            element.controller.connection.port [connection_number].mainframe_ownership := mainframe_name;
            element.controller.connection.port [connection_number].iou := iou_name;
            element.controller.physical_equipment_number := equipment_number;
          = cmc$external_processor_element =
            element.external_processor.connection.io_port [connection_number].configured := TRUE;
            element.external_processor.connection.io_port [connection_number].element_name := channel_name;
            element.external_processor.connection.io_port [connection_number].upline_connection_type :=
                  cmc$data_channel_element;
            element.external_processor.connection.io_port [connection_number].mainframe_ownership :=
                  mainframe_name;
            element.external_processor.connection.io_port [connection_number].iou := iou_name;
            element.external_processor.connection.central_memory.memory_port := cmc$memory_port_0;
            element.external_processor.connection.central_memory.element_name := mainframe_name;
            element.external_processor.physical_equipment_number := equipment_number;
          = cmc$channel_adapter_element =
            element.channel_adapter.connection.channel.configured := TRUE;
            element.channel_adapter.connection.channel.element_name := channel_name;
            element.channel_adapter.connection.channel.upline_connection_type := cmc$data_channel_element;
            element.channel_adapter.connection.channel.mainframe_ownership := mainframe_name;
            element.channel_adapter.connection.channel.iou := iou_name;
            element.channel_adapter.physical_equipment_number := equipment_number;
          = cmc$communications_element =
            element.communications_element.connection.port [connection_number].configured := TRUE;
            element.communications_element.connection.port [connection_number].element_name := channel_name;
            element.communications_element.connection.port [connection_number].upline_connection_type :=
                  cmc$data_channel_element;
            element.communications_element.connection.port [connection_number].iou := iou_name;
            element.communications_element.connection.port [connection_number].mainframe_ownership :=
                  mainframe_name;
            element.communications_element.physical_equipment_number := equipment_number;
          = cmc$storage_device_element =
            cmp$get_unit_type (element.product_id, unit_type, io_unit_type, unit_class, found);
            IF (unit_type = cmc$mshydra) THEN
              element.storage_device.connection.port [connection_number].configured := TRUE;
              element.storage_device.connection.port [connection_number].element_name := channel_name;
              cmp$validate_address_range (unit_type, equipment_number, status);
              IF NOT status.normal THEN
                osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
                RETURN;
              IFEND;
              element.storage_device.connection.port [connection_number].configured := TRUE;
              element.storage_device.connection.port [connection_number].upline_connection_type :=
                    cmc$data_channel_element;
              element.storage_device.connection.port [connection_number].mainframe_ownership :=
                    mainframe_name;
              element.storage_device.connection.port [connection_number].iou := iou_name;
              element.storage_device.physical_unit_number := equipment_number;
            ELSE
              osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
                    'Iou connection not applicable to storage device', status);
              osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
              RETURN;
            IFEND;

          ELSE { Error. }
            osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
                  'Iou connection not applicable to storage device', status);
            osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
            RETURN;
          CASEND;

          channel_element_p^ [list_index].descriptor.element_type := cmc$data_channel_element;
          IF cmp$valid_channel_name (channel_name) THEN
            channel_element_p^ [list_index].descriptor.element_name := channel_name;
            channel_element_p^ [list_index].descriptor.product_id.product_number := '      ';
            channel_element_p^ [list_index].descriptor.product_id.underscore := ' ';
            channel_element_p^ [list_index].descriptor.product_id.model_number := '   ';
            channel_element_p^ [list_index].descriptor.serial_number := '      ';
            channel_element_p^ [list_index].descriptor.data_channel.iou := iou_name;
            channel_element_p^ [list_index].descriptor.data_channel.connection.equipment [equipment_number].
                  configured := TRUE;
            channel_element_p^ [list_index].descriptor.data_channel.connection.equipment [equipment_number].
                  element_name := element_name;
          ELSE
            osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_channel_number,
                  'DEFINE_ELEMENT', status);
            osp$append_status_parameter (osc$status_parameter_delimiter, channel_name, status);
            RETURN;
          IFEND;
          channel_descriptor.iou := channel_element_p^ [list_index].descriptor.data_channel.iou;
          channel_descriptor.use_logical_identification := TRUE;
          channel_descriptor.name := channel_element_p^ [list_index].descriptor.element_name;
          cmp$get_channel_definition (channel_descriptor, channel_def, status);
          IF NOT status.normal THEN
            IF (status.condition = cme$lcm_element_not_found) OR
                  (status.condition = cme$unknown_channel_type) THEN
              status.normal := TRUE;
            ELSE
              RETURN;
            IFEND;
          IFEND;
          channel_element_p^ [list_index].descriptor.data_channel.concurrent := channel_def.concurrent;
          channel_element_p^ [list_index].descriptor.data_channel.direct_memory_access :=
                channel_def.direct_memory_access;
          channel_element_p^ [list_index].descriptor.data_channel.kind := channel_def.kind;
          channel_element_p^ [list_index].descriptor.data_channel.number := channel_def.number;
          channel_element_p^ [list_index].descriptor.data_channel.port := channel_def.port;
          channel_element_p^ [list_index].descriptor.data_channel.mainframe_ownership := mainframe_name;
          channel_element_p^ [list_index].descriptor.data_channel.pps_capable_of_access :=
                channel_def.pps_capable_of_access;
          channel_element_p^ [list_index].descriptor.data_channel.ordinal := channel_def.ordinal;
          connection_number := connection_number + 1;
          current_list_entry := current_list_entry^.link;

{ If there is more entry in the list to process, make sure we have not
{ exceeded the maximum allowable number of upline connections.

          IF current_list_entry <> NIL THEN
            CASE element.element_type OF
            = cmc$controller_element =
              IF (connection_number > UPPERVALUE (cmt$controller_port_number)) THEN
                osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
                      'Too many values given on IOU_CONNECTIONS', status);
              IFEND;
            = cmc$external_processor_element =
              IF (connection_number > UPPERVALUE (cmt$physical_equipment_number)) THEN
                osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
                      'Too many values given on IOU_CONNECTIONS', status);
              IFEND;
            = cmc$channel_adapter_element =
              IF (connection_number > 1) THEN
                osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
                      'Too many values given on IOU_CONNECTIONS', status);
              IFEND;
            = cmc$communications_element =
              IF (connection_number > UPPERVALUE (cmt$communications_port_number)) THEN
                osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
                      'Too many values given on IOU_CONNECTIONS', status);
              IFEND;
            = cmc$storage_device_element =
              IF (connection_number > UPPERVALUE (cmt$data_storage_port_number)) THEN
                osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
                      'Too many values given on IOU_CONNECTIONS', status);
              IFEND;
            ELSE
            CASEND;
            IF NOT status.normal THEN
              osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
              RETURN;
            IFEND;
          IFEND;
        WHILEND;
      IFEND;
    IFEND;

{ Process CENTRAL_MEMORY_CONNECTION.

    IF parameter_value_table^ [p$central_memory_connection].specified THEN
      IF element.element_type <> cmc$external_processor_element THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
              'Central memory connection applicable' CAT ' to external processor element only', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
        RETURN;
      IFEND;
      connection_specified := TRUE;
      current_list_entry := parameter_value_table^ [p$central_memory_connection].value;
      mainframe_name := cmv$mainframe_name;
      port := 0;
      WHILE current_list_entry <> NIL DO
        FOR field_index := LOWERBOUND (current_list_entry^.element_value^.field_values^)
              TO UPPERBOUND (current_list_entry^.element_value^.field_values^) DO
          IF (current_list_entry^.element_value^.field_values^ [field_index].name = 'PORT') THEN
            IF (current_list_entry^.element_value^.field_values^ [field_index].value <> NIL) THEN
              port := current_list_entry^.element_value^.field_values^ [field_index].value^.integer_value.
                    value;
            IFEND;
          ELSEIF (current_list_entry^.element_value^.field_values^ [field_index].name = 'MAINFRAME') THEN
            IF (current_list_entry^.element_value^.field_values^ [field_index].value <> NIL) THEN
              mainframe_name := current_list_entry^.element_value^.field_values^ [field_index].value^.
                    name_value;
            IFEND;
          IFEND;
        FOREND;
        element.external_processor.connection.central_memory.upline_connection_type :=
              cmc$central_memory_element;
        element.external_processor.connection.central_memory.element_name := mainframe_name;
        IF port = 0 THEN
          element.external_processor.connection.central_memory.memory_port := cmc$memory_port_0;
        ELSEIF port = 1 THEN
          element.external_processor.connection.central_memory.memory_port := cmc$memory_port_1;
        ELSEIF port = 2 THEN
          element.external_processor.connection.central_memory.memory_port := cmc$memory_port_2;
        ELSEIF port = 3 THEN
          element.external_processor.connection.central_memory.memory_port := cmc$memory_port_3;
        ELSE
          osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
                'PORT value out of range' CAT ' on CENTRAL_MEMORY_CONNECTION', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
          RETURN;
        IFEND;
        current_list_entry := current_list_entry^.link;
        IF current_list_entry <> NIL THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
                'Too many values given on CENTRAL_MEMORY_CONNECTIONS', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
          RETURN;
        IFEND;
      WHILEND;
    IFEND;
    IF NOT connection_specified THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_missing_parameters, 'Connections',
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
      RETURN;
    IFEND;
    IF same_as THEN
      state := same_state_element_p^.status.state;
    ELSE
      state_value := parameter_value_table^ [p$state].value^.name_value;

    /state_loop/
      FOR state_index := LOWERVALUE (cmt$element_state) TO UPPERVALUE (cmt$element_state) DO
        IF state_value = map_state [state_index] THEN
          state := state_index;
          EXIT /state_loop/;
        IFEND;
      FOREND /state_loop/;
    IFEND;

{ Find the channel belonging to the current mainframe that is being
{ verified or installed and use the concurrent field to validate IOU
{ PROGRAM NAME.

    IF channel_element_p <> NIL THEN

    /search_channel/
      FOR i := LOWERBOUND (channel_element_p^) TO UPPERBOUND (channel_element_p^) DO
        IF (channel_element_p^ [i].descriptor.data_channel.mainframe_ownership = cmv$mainframe_name) THEN
          channel_def := channel_element_p^ [i].descriptor.data_channel;
          EXIT /search_channel/;
        IFEND;
      FOREND /search_channel/;
    IFEND;

{ Get and validate IOU_PROGRAM_NAME parameter

    valid_ipn := TRUE;
    IF parameter_value_table^ [p$iou_program_name].specified THEN
      IF (element.element_type = cmc$storage_device_element) AND (unit_type <> cmc$mshydra) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
              'IOU_PROGRAM_NAME cannot be specified' CAT ' on a storage device', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
        RETURN;
      IFEND;
      pp_module_name := parameter_value_table^ [p$iou_program_name].value^.name_value;
      IF standard_product THEN
        cmp$convert_iou_name (channel_def.iou, iou_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        cmp$get_driver_by_controller (controller_type, channel_def.concurrent, iou_number, driver_name,
              alternate_driver_name);
        IF (pp_module_name <> driver_name) AND (pp_module_name <> alternate_driver_name) THEN
          valid_ipn := FALSE;
        IFEND;
      IFEND;
    ELSE
      IF same_as THEN
        CASE same_element_p^.element_type OF
        = cmc$controller_element =
          pp_module_name := same_element_p^.controller.peripheral_driver_name;
        = cmc$external_processor_element =
          pp_module_name := same_element_p^.external_processor.peripheral_driver_name;
        = cmc$channel_adapter_element =
          pp_module_name := same_element_p^.channel_adapter.peripheral_driver_name;
        = cmc$communications_element =
          pp_module_name := same_element_p^.communications_element.peripheral_driver_name;
        ELSE
          ;
        CASEND;
        IF standard_product AND (same_element_p^.element_type <> cmc$storage_device_element) THEN
          cmp$convert_iou_name (channel_def.iou, iou_number, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          cmp$get_driver_by_controller (controller_type, channel_def.concurrent, iou_number, driver_name,
                alternate_driver_name);
          IF (pp_module_name <> driver_name) AND (pp_module_name <> alternate_driver_name) THEN
            valid_ipn := FALSE;
          IFEND;
        IFEND

      ELSE

{ Get the default driver name based on product and channel types.

        IF standard_product THEN
          IF (element.element_type <> cmc$storage_device_element) THEN
            cmp$convert_iou_name (channel_def.iou, iou_number, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            cmp$get_driver_by_controller (controller_type, channel_def.concurrent, iou_number, driver_name,
                  alternate_driver_name);
            pp_module_name := driver_name;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF NOT valid_ipn THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
            'Invalid IOU_PROGRAM_NAME specified', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
      RETURN;
    IFEND;

    CASE element.element_type OF
    = cmc$controller_element =
      element.controller.peripheral_driver_name := pp_module_name;
    = cmc$external_processor_element =
      element.external_processor.peripheral_driver_name := pp_module_name;

    = cmc$channel_adapter_element =
      element.channel_adapter.peripheral_driver_name := pp_module_name;

    = cmc$communications_element =
      element.communications_element.peripheral_driver_name := pp_module_name;

    ELSE
      ;
    CASEND;

    {
    {Initialize unused/non-initialized fields.
    {
    CASE element.element_type OF
    = cmc$controller_element =
      element.controller.microcode_identification.number := '    ';
      element.controller.microcode_identification.dollar := ' ';
      element.controller.microcode_identification.type_identifier := ' ';
      element.controller.microcode_identification.series_code := ' ';
      element.controller.response_handler_name := osc$null_name;

    = cmc$communications_element =
      element.communications_element.microcode_identification.number := '    ';
      element.communications_element.microcode_identification.dollar := ' ';
      element.communications_element.microcode_identification.type_identifier := ' ';
      element.communications_element.microcode_identification.series_code := ' ';

    ELSE
    CASEND;


{ Put definition of element as well as state information into the segment
{ access files

    IF channel_element_p <> NIL THEN
      FOR i := LOWERBOUND (channel_element_p^) TO UPPERBOUND (channel_element_p^) DO
        cmp$find_element (channel_element_p^ [i].descriptor.element_name,
              channel_element_p^ [i].descriptor.data_channel.iou,
              channel_element_p^ [i].descriptor.data_channel.mainframe_ownership, cmv$cmd_value_fid,
              same_element_p, local_status);
        IF NOT local_status.normal THEN

{ This channel is not present in the file.

          channel_element_p^ [i].configured := TRUE;
        ELSE
          channel_element_p^ [i].configured := FALSE;
        IFEND;
      FOREND;
    IFEND;

    IF channel_element_p <> NIL THEN
      FOR i := LOWERBOUND (channel_element_p^) TO UPPERBOUND (channel_element_p^) DO
        IF channel_element_p^ [i].configured THEN
          amp$get_segment_pointer (cmv$cmd_value_fid, amc$sequence_pointer, segment_pointer, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          NEXT definition_p IN segment_pointer.sequence_pointer;

          amp$get_segment_pointer (cmv$state_value_fid, amc$sequence_pointer, state_segment_pointer, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          NEXT state_element_p IN state_segment_pointer.sequence_pointer;

          definition_p^ := channel_element_p^ [i].descriptor;
          state_element_p^.status.state := cmc$on;
          state_element_p^.element_name := channel_element_p^ [i].descriptor.element_name;
          state_element_p^.element_type := cmc$data_channel_element;
          state_element_p^.iou := channel_element_p^ [i].descriptor.data_channel.iou;
          amp$set_segment_eoi (cmv$cmd_value_fid, segment_pointer, local_status);
          amp$set_segment_eoi (cmv$state_value_fid, state_segment_pointer, local_status);
        IFEND;
      FOREND;
    IFEND;

    amp$get_segment_pointer (cmv$cmd_value_fid, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT definition_p IN segment_pointer.sequence_pointer;

    amp$get_segment_pointer (cmv$state_value_fid, amc$sequence_pointer, state_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT state_element_p IN state_segment_pointer.sequence_pointer;

    definition_p^ := element;
    IF NOT same_as THEN
      state_element_p^.status.state := state;
      state_element_p^.element_name := element.element_name;
      state_element_p^.element_type := element.element_type;
      state_element_p^.logical_unit := 0;
      state_element_p^.product_id := element.product_id;
      IF element.element_type <> cmc$data_channel_element THEN
        IF parameter_value_table^ [p$application_information].specified THEN
          NEXT state_element_p^.application_info_p:
             [STRLENGTH(parameter_value_table^[p$application_information].value^.
                string_value^)] IN state_segment_pointer.sequence_pointer;
          state_element_p^.application_info_p^ := parameter_value_table^ [p$application_information].
              value^.string_value^;
          state_element_p^.application_info_size := STRLENGTH(parameter_value_table^
              [p$application_information].value^.string_value^);
        ELSE
          state_element_p^.application_info_p := NIL;
          state_element_p^.application_info_size := 0;
        IFEND;
        IF parameter_value_table^ [p$site_information].specified THEN
          NEXT state_element_p^.site_info_p:
             [STRLENGTH(parameter_value_table^[p$site_information].value^.
                string_value^)] IN state_segment_pointer.sequence_pointer;
          state_element_p^.site_info_p^ := parameter_value_table^ [p$site_information].
              value^.string_value^;
          state_element_p^.site_info_size := STRLENGTH(parameter_value_table^
              [p$site_information].value^.string_value^);
        ELSE
          state_element_p^.site_info_p := NIL;
          state_element_p^.site_info_size := 0;
        IFEND;
      IFEND;
    ELSE
      state_element_p^ := same_state_element_p^;
      state_element_p^.element_name := element_name;
    IFEND;
    amp$set_segment_eoi (cmv$cmd_value_fid, segment_pointer, local_status);
    amp$set_segment_eoi (cmv$state_value_fid, state_segment_pointer, local_status);

  PROCEND cmp$process_define_element;


?? OLDTITLE ??
?? NEWTITLE := '   cpm$replace_definition', EJECT ??

{ PURPOSE:
{    This procedure searches for an element name in a
{    configuration file and replace its definition


  PROCEDURE [XDCL, #GATE] cmp$replace_definition
    (    element_name: cmt$element_name;
         new_descriptor: cmt$pcu_command_descriptor;
     VAR status: ost$status);

    VAR
      current_p: ^cmt$pcu_command_descriptor,
      found: boolean,
      save_p: ^cmt$pcu_command_descriptor;


    status.normal := TRUE;

  /main_program/
    BEGIN
      IF cmv$command_descriptor_p <> NIL THEN
        current_p := cmv$command_descriptor_p;
        found := FALSE;

      /link_list_loop/
        WHILE current_p <> NIL DO
          found := current_p^.element_name = element_name;
          IF found THEN
            save_p := current_p^.next_descriptor;
            cmp$free_descriptor (current_p^);
            current_p^ := new_descriptor;
            current_p^.next_descriptor := save_p;
            EXIT /link_list_loop/;
          ELSE
            current_p := current_p^.next_descriptor;
          IFEND;

        WHILEND /link_list_loop/;
      ELSE
        osp$set_status_condition ( cme$pcu_empty_file,  status);
        EXIT /main_program/;
      IFEND;

      IF NOT found THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_element_not_found, element_name,
              status);
      IFEND;

    END /main_program/;


  PROCEND cmp$replace_definition;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$search_edited_file', EJECT ??

{  PURPOSE:
{    This procedure search a token in the physical configuration
{    file. Two types of token are searched :
{     * Integer ( Serial number of an element )
{     * Name  ( Name of an element )
{    If found is TRUE then the element name or the serial number
{    is already being used.


  PROCEDURE [XDCL, #GATE] cmp$search_edited_file
    (    element_name: cmt$element_name;
         serial_number: integer;
         product_id: cmt$product_identification;
     VAR found: boolean;
     VAR descriptor: cmt$pcu_command_descriptor);

    VAR
      j,
      i: integer,
      pid: ost$name,
      found_count,
      check_count: integer,
      current_p: ^cmt$pcu_command_descriptor;

    found := FALSE;
    IF product_id.product_number = '  $885' THEN
      check_count := 2;
    ELSEIF product_id.product_number = ' $895' THEN
      check_count := 4;
    ELSE
      check_count := 0;
    IFEND;
    found_count := 0;
    pid := osc$null_name;
    j := 0;
    FOR i := 1 TO 6 DO
      IF product_id.product_number (i, 1) <> ' ' THEN
        j := j + 1;
        pid (j, 1) := product_id.product_number (i, 1);
      IFEND;
    FOREND;
    j := j + 1;
    pid (j, 1) := product_id.underscore;
    pid (j + 1, 3) := product_id.model_number;
    IF cmv$command_descriptor_p <> NIL THEN
      current_p := cmv$command_descriptor_p;

    /search/
      WHILE current_p <> NIL DO
        IF serial_number <> 0 THEN
          IF (serial_number = current_p^.sn) AND (pid = current_p^.pid) THEN
            found_count := found_count + 1;
            IF found_count > check_count THEN
              found := TRUE;
            IFEND;

          IFEND;
        ELSE
          IF current_p^.element_name = element_name THEN
            found := TRUE;
          IFEND;
        IFEND;

        IF found THEN
          descriptor := current_p^;
          EXIT /search/; {----->
        ELSE
          current_p := current_p^.next_descriptor;
        IFEND;

      WHILEND /search/;
    IFEND;
  PROCEND cmp$search_edited_file;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$save_output', EJECT ??

{ PURPOSE:
{     This procedure opens the output file specified on
{     EDIPC command.

  PROCEDURE [XDCL, #GATE] cmp$save_output
    (    output_file: amt$local_file_name;
         input_file: boolean;
     VAR status: ost$status);


    VAR
      attribute_override: array [1 .. 1] of fst$file_cycle_attribute,
      attribute_validation: array [1 .. 2] of fst$file_cycle_attribute,
      def_creation_attributes: array [1 .. 2] of fst$file_cycle_attribute,
      file_attachment: array [1 .. 3] of fst$attachment_option,
      mandate_creation_attributes: array [1 .. 2] of fst$file_cycle_attribute;

    file_attachment [1].selector := fsc$access_and_share_modes;
    file_attachment [2].selector := fsc$open_share_modes;
    file_attachment [3].selector := fsc$create_file;

    file_attachment [1].access_modes.selector := fsc$specific_access_modes;
    file_attachment [1].share_modes.selector := fsc$specific_share_modes;
    file_attachment [1].access_modes.value := $fst$file_access_options
          [fsc$read, fsc$execute, fsc$shorten, fsc$append];
    file_attachment [1].share_modes.value := $fst$file_access_options [];
    IF input_file THEN
      file_attachment [2].open_share_modes := $fst$file_access_options [fsc$read, fsc$execute];
    ELSE
      file_attachment [2].open_share_modes := $fst$file_access_options
            [fsc$read, fsc$execute, fsc$shorten, fsc$append];
    IFEND;
    file_attachment [3].create_file := TRUE;
    def_creation_attributes [1].selector := fsc$record_type;
    def_creation_attributes [1].record_type := amc$variable;
    def_creation_attributes [2].selector := fsc$file_contents_and_processor;
    def_creation_attributes [2].file_contents := amc$legible;
    def_creation_attributes [2].file_processor := osc$null_name;
    attribute_validation [1].selector := fsc$file_contents_and_processor;
    attribute_validation [1].file_contents := amc$unknown_contents;
    attribute_validation [1].file_processor := amc$unknown_processor;
    attribute_validation [2].selector := fsc$file_contents_and_processor;
    attribute_validation [2].file_contents := amc$legible;
    attribute_validation [2].file_processor := osc$null_name;

    mandate_creation_attributes [1].selector := fsc$record_type;
    mandate_creation_attributes [1].record_type := amc$variable;
    mandate_creation_attributes [2].selector := fsc$ring_attributes;
    mandate_creation_attributes [2].ring_attributes.r1 := osc$user_ring;
    mandate_creation_attributes [2].ring_attributes.r2 := osc$user_ring;
    mandate_creation_attributes [2].ring_attributes.r3 := osc$user_ring;
    attribute_override [1].selector := fsc$ring_attributes;
    attribute_override [1].ring_attributes.r1 := osc$user_ring;
    attribute_override [1].ring_attributes.r2 := osc$user_ring;
    attribute_override [1].ring_attributes.r3 := osc$user_ring;
    IF NOT input_file THEN
      fsp$open_file (output_file, amc$record, ^file_attachment, ^def_creation_attributes,
            ^mandate_creation_attributes, ^attribute_validation, ^attribute_override, cmv$output_fid, status);
    ELSE
      fsp$open_file (output_file, amc$record, ^file_attachment, ^def_creation_attributes,
            ^mandate_creation_attributes, ^attribute_validation, ^attribute_override, cmv$input_fid, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND cmp$save_output;


?? OLDTITLE ??
?? NEWTITLE := '   cmp$set_exec_within_editor', EJECT ??

{ PURPOSE:
{    This procedure sets a flag to indicate that the user is in
{    the PCU editor.

  PROCEDURE [XDCL, #GATE] cmp$set_exec_in_editor
    (    active: boolean);

    cmv$executing_within_editor := active;

  PROCEND cmp$set_exec_in_editor;

?? OLDTITLE ??
?? NEWTITLE := '  cmp$set_in_editor ', EJECT ??

{ PURPOSE:
{    Set the value of CMV$IN_EDITOR to indicate that  user
{    is currently in the PCU editor.

  PROCEDURE [XDCL, #GATE] cmp$set_in_editor
    (    in_editor: boolean);

    cmv$in_editor := in_editor;
  PROCEND cmp$set_in_editor;


?? OLDTITLE ??
?? NEWTITLE := '   cmp$set_default_mainframe_name', EJECT ??

{ PURPOSE:
{   This procedure assigns the default value of the mainframe name.

  PROCEDURE [XDCL, #GATE] cmp$set_default_mainframe_name
    (VAR status: ost$status);

    VAR
      index: integer,
      str: ost$string;

    VAR
      mainframe_id: pmt$mainframe_id;

    pmp$get_mainframe_id (mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cmv$mainframe_name := mainframe_id;
    cmv$installed_mainframe := cmv$mainframe_name;

  PROCEND cmp$set_default_mainframe_name;


?? OLDTITLE ??
?? NEWTITLE := '   cmp$setup_mainframe_name', EJECT ??

{ PURPOSE:
{    This procedure sets up the value of the mainframe name
{    as defined by the PCU subcommand DEFINE_WORKING_MAINFRAME.

  PROCEDURE [XDCL, #GATE] cmp$setup_mainframe_name
    (    mainframe_name: cmt$element_name);

    cmv$mainframe_name := mainframe_name;

  PROCEND cmp$setup_mainframe_name;
?? OLDTITLE ??
?? NEWTITLE := 'update_downward_connections', EJECT ??

{ PURPOSE:
{   This procedure scans the file produced by INSTALL_PHYSICAL_CONFIGURATION or VERIFY_PHYSICAL_CONFIGURATION,
{   then updates all the downline connections of all elements. It also validates duplicate physical addresses
{   of elements in the configuration file.

  PROCEDURE update_downward_connections
    (    input_fid: amt$file_identifier;
         output_fid: amt$file_identifier;
     VAR status: ost$status);

    VAR
      cm_unit_type: cmt$unit_type,
      comm_port_number: cmt$communications_port_number,
      ct_port_number: cmt$controller_port_number,
      element: ^cmt$element_definition,
      eoi_addr: array [1 .. 1] of amt$access_info,
      found: boolean,
      inn: amt$segment_pointer,
      in_el: ^cmt$element_definition,
      iou_name: cmt$element_name,
      io_unit_type: iot$unit_type,
      loop_count: integer,
      loop_index: integer,
      mf_name: cmt$element_name,
      out: amt$segment_pointer,
      out_el: ^cmt$element_definition,
      pen: cmt$physical_equipment_number,
      sd_port_number: cmt$data_storage_port_number,
      unit_class: cmt$unit_class;

    status.normal := TRUE;

  /main_program/
    BEGIN

      eoi_addr [1].key := amc$eoi_byte_address;

      amp$get_segment_pointer (input_fid, amc$sequence_pointer, inn, status);

      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      amp$get_segment_pointer (output_fid, amc$sequence_pointer, out, status);

      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      amp$fetch_access_information (input_fid, eoi_addr, status);

      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF NOT eoi_addr [1].item_returned THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_file_error,
              'update_downward_connections', status);
        EXIT /main_program/;
      IFEND;

      RESET inn.sequence_pointer;
      RESET out.sequence_pointer;
      loop_count := eoi_addr [1].eoi_byte_address DIV #SIZE (cmt$element_definition);
      FOR loop_index := 1 TO loop_count DO
        NEXT in_el IN inn.sequence_pointer;
        NEXT out_el IN out.sequence_pointer;
        out_el^ := in_el^;
      FOREND;

      amp$set_segment_eoi (output_fid, out, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      RESET out.sequence_pointer;
      FOR loop_index := 1 TO loop_count DO
        NEXT out_el IN out.sequence_pointer;
        CASE out_el^.element_type OF
        = cmc$storage_device_element =

          FOR sd_port_number := LOWERVALUE (sd_port_number) TO UPPERVALUE (sd_port_number) DO
            IF out_el^.storage_device.connection.port [sd_port_number].configured THEN
              cmp$get_unit_type (out_el^.product_id, cm_unit_type, io_unit_type, unit_class, found);
              IF (cm_unit_type = cmc$mshydra) OR (out_el^.storage_device.connection.port [sd_port_number].
                    upline_connection_type = cmc$data_channel_element) THEN
                mf_name := out_el^.storage_device.connection.port [sd_port_number].mainframe_ownership;
                iou_name := out_el^.storage_device.connection.port [sd_port_number].iou;
              ELSE
                mf_name := osc$null_name;
              IFEND;

              cmp$find_element (out_el^.storage_device.connection.port [sd_port_number].element_name,
                    iou_name, mf_name, output_fid, element, status);

              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;

              IF element^.element_type = cmc$controller_element THEN
                IF (element^.controller.connection.unit [out_el^.storage_device.physical_unit_number].
                      configured) AND (element^.controller.connection.
                      unit [out_el^.storage_device.physical_unit_number].element_name <>
                      out_el^.element_name) THEN

                  osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_duplicate_pun,
                        out_el^.element_name, status);
                  osp$append_status_integer (osc$status_parameter_delimiter,
                        out_el^.storage_device.physical_unit_number, 10, TRUE, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        element^.controller.connection.unit [out_el^.storage_device.physical_unit_number].
                        element_name, status);

                  EXIT /main_program/;
                IFEND;
                element^.controller.connection.unit [out_el^.storage_device.physical_unit_number].
                      configured := TRUE;
                element^.controller.connection.unit [out_el^.storage_device.physical_unit_number].
                      element_name := out_el^.element_name;
              ELSEIF element^.element_type = cmc$data_channel_element THEN
                IF (element^.data_channel.connection.equipment [out_el^.storage_device.physical_unit_number].
                      configured) AND (element^.data_channel.connection.
                      equipment [out_el^.storage_device.physical_unit_number].element_name <>
                      out_el^.element_name) THEN

                  osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_duplicate_pun,
                        out_el^.element_name, status);
                  osp$append_status_integer (osc$status_parameter_delimiter,
                        out_el^.storage_device.physical_unit_number, 10, TRUE, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        element^.data_channel.connection.equipment [out_el^.storage_device.
                        physical_unit_number].element_name, status);

                  EXIT /main_program/;
                IFEND;
                element^.data_channel.connection.equipment [out_el^.storage_device.physical_unit_number].
                      configured := TRUE;
                element^.data_channel.connection.equipment [out_el^.storage_device.physical_unit_number].
                      element_name := out_el^.element_name;
              IFEND;

            IFEND;

          FOREND;

        = cmc$controller_element =

{ Need to update connection in case of Channel adapter being
{ the upline connection type

          FOR ct_port_number := LOWERVALUE (ct_port_number) TO UPPERVALUE (ct_port_number) DO
            IF out_el^.controller.connection.port [ct_port_number].configured THEN

              cmp$find_element (out_el^.controller.connection.port [ct_port_number].element_name,
                    out_el^.controller.connection.port [ct_port_number].iou,
                    out_el^.controller.connection.port [ct_port_number].mainframe_ownership, output_fid,
                    element, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;

              IF element^.element_type = cmc$data_channel_element THEN
                IF (element^.data_channel.connection.equipment [out_el^.controller.physical_equipment_number].
                      configured) AND (element^.data_channel.connection.
                      equipment [out_el^.controller.physical_equipment_number].element_name <>
                      out_el^.element_name) THEN


                  osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_duplicate_pen,
                        out_el^.element_name, status);
                  osp$append_status_integer (osc$status_parameter_delimiter,
                        out_el^.controller.physical_equipment_number, 10, TRUE, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        element^.data_channel.connection.equipment [out_el^.controller.
                        physical_equipment_number].element_name, status);

                  EXIT /main_program/;
                IFEND;
              IFEND;

              element^.data_channel.connection.equipment [out_el^.controller.physical_equipment_number].
                    configured := TRUE;
              element^.data_channel.connection.equipment [out_el^.controller.physical_equipment_number].
                    element_name := out_el^.element_name;
            IFEND;
          FOREND;

        = cmc$channel_adapter_element =
          IF out_el^.channel_adapter.connection.channel.configured THEN
            cmp$find_element (out_el^.channel_adapter.connection.channel.element_name,
                  out_el^.channel_adapter.connection.channel.iou,
                  out_el^.channel_adapter.connection.channel.mainframe_ownership, output_fid, element,
                  status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            IF element^.element_type = cmc$data_channel_element THEN
              IF (element^.data_channel.connection.equipment [out_el^.channel_adapter.
                    physical_equipment_number].configured) AND (element^.data_channel.connection.
                    equipment [out_el^.channel_adapter.physical_equipment_number].element_name <>
                    out_el^.element_name) THEN
                osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_duplicate_pen,
                      out_el^.element_name, status);
                osp$append_status_integer (osc$status_parameter_delimiter,
                      out_el^.channel_adapter.physical_equipment_number, 10, TRUE, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      element^.data_channel.connection.equipment [out_el^.channel_adapter.
                      physical_equipment_number].element_name, status);
                EXIT /main_program/;
              IFEND;
            IFEND;

            element^.data_channel.connection.equipment [out_el^.channel_adapter.physical_equipment_number].
                  configured := TRUE;
            element^.data_channel.connection.equipment [out_el^.channel_adapter.physical_equipment_number].
                  element_name := out_el^.element_name;
          IFEND;

        = cmc$communications_element =

          FOR comm_port_number := LOWERVALUE (comm_port_number) TO UPPERVALUE (comm_port_number) DO
            IF out_el^.communications_element.connection.port [comm_port_number].configured THEN
              cmp$find_element (out_el^.communications_element.connection.port [comm_port_number].
                    element_name, out_el^.communications_element.connection.port [comm_port_number].iou,
                    out_el^.communications_element.connection.port [comm_port_number].mainframe_ownership,
                    output_fid, element, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;

              IF element^.element_type = cmc$data_channel_element THEN
                IF (element^.data_channel.connection.equipment [out_el^.communications_element.
                      physical_equipment_number].configured) AND (element^.data_channel.connection.
                      equipment [out_el^.communications_element.physical_equipment_number].element_name <>
                      out_el^.element_name) THEN
                  osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_duplicate_pen,
                        out_el^.element_name, status);
                  osp$append_status_integer (osc$status_parameter_delimiter,
                        out_el^.communications_element.physical_equipment_number, 10, TRUE, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        element^.data_channel.connection.equipment [out_el^.communications_element.
                        physical_equipment_number].element_name, status);
                  EXIT /main_program/;
                IFEND;
              IFEND;
              element^.data_channel.connection.equipment [out_el^.communications_element.
                    physical_equipment_number].configured := TRUE;
              element^.data_channel.connection.equipment [out_el^.communications_element.
                    physical_equipment_number].element_name := out_el^.element_name;
            IFEND;
          FOREND;

        = cmc$external_processor_element =
          FOR ct_port_number := LOWERVALUE (ct_port_number) TO UPPERVALUE (ct_port_number) DO
            IF out_el^.external_processor.connection.io_port [ct_port_number].configured THEN

              cmp$find_element (out_el^.external_processor.connection.io_port [ct_port_number].element_name,
                    out_el^.external_processor.connection.io_port [ct_port_number].iou,
                    out_el^.external_processor.connection.io_port [ct_port_number].mainframe_ownership,
                    output_fid, element, status);

              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;

              IF (element^.data_channel.connection.equipment [out_el^.external_processor.
                    physical_equipment_number].configured) AND (element^.data_channel.connection.
                    equipment [out_el^.external_processor.physical_equipment_number].element_name <>
                    out_el^.element_name) THEN
                osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_duplicate_pen,
                      out_el^.element_name, status);
                osp$append_status_integer (osc$status_parameter_delimiter,
                      out_el^.external_processor.physical_equipment_number, 10, TRUE, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      element^.data_channel.connection.equipment [out_el^.external_processor.
                      physical_equipment_number].element_name, status);

                EXIT /main_program/;
              IFEND;

              element^.data_channel.connection.equipment [out_el^.external_processor.
                    physical_equipment_number].configured := TRUE;
              element^.data_channel.connection.equipment [out_el^.external_processor.
                    physical_equipment_number].element_name := out_el^.element_name;
            IFEND;

          FOREND;

        ELSE

        CASEND;
      FOREND;

    END /main_program/;

  PROCEND update_downward_connections;
?? OLDTITLE ??
?? NEWTITLE := '   cmp$update_descriptor', EJECT ??

{ PURPOSE:
{    This procedure scans the single linked list of PCU command descriptors
{    produced by EDIT_PHYSICAL_CONFIGURATION, and updates values of command
{    descriptors that use SAME_AS parameter.

  PROCEDURE [XDCL, #GATE] cmp$update_descriptor;

    VAR
      current_p: ^cmt$pcu_command_descriptor,
      temp_p: ^cmt$pcu_command_descriptor;

    IF cmv$command_descriptor_p <> NIL THEN
      current_p := cmv$command_descriptor_p;
      WHILE current_p <> NIL DO
        IF (current_p^.same_as <> osc$null_name) THEN
          temp_p := cmv$command_descriptor_p;

        /loop/
          WHILE temp_p <> NIL DO
            IF temp_p^.element_name = current_p^.same_as THEN
              current_p^.same_as := osc$null_name;
              IF current_p^.sn = 0 THEN
                current_p^.sn := temp_p^.sn;
              IFEND;
              IF current_p^.pid = osc$null_name THEN
                current_p^.pid := temp_p^.pid;
              IFEND;
              current_p^.verify := temp_p^.verify;
              IF current_p^.state = osc$null_name THEN
                current_p^.state := temp_p^.state;
              IFEND;
              IF current_p^.application_info_p = NIL THEN
                current_p^.application_info_p := temp_p^.application_info_p;
              ELSE
                IF temp_p^.application_info_p <> NIL THEN
                  FREE current_p^.application_info_p IN osv$task_private_heap^;
                  current_p^.application_info_p := temp_p^.application_info_p;
                IFEND;
              IFEND;
              IF current_p^.site_info_p = NIL THEN
                current_p^.site_info_p := temp_p^.site_info_p;
              ELSE
                IF temp_p^.site_info_p <> NIL THEN
                  FREE current_p^.site_info_p IN osv$task_private_heap^;
                  current_p^.site_info_p := temp_p^.site_info_p;
                IFEND;
              IFEND;
              EXIT /loop/;
            IFEND;
            temp_p := temp_p^.next_descriptor;
          WHILEND /loop/;
        IFEND;
        current_p := current_p^.next_descriptor;
      WHILEND;
    IFEND;
  PROCEND cmp$update_descriptor;


?? OLDTITLE ??
?? NEWTITLE := '   cmp$update_output_file', EJECT ??

{ PURPOSE:
{    This procedure update the contents of the output file
{    on the EDIT_PHYSICAL_CONFIGURATION command.

  PROCEDURE [XDCL, #GATE] cmp$update_output_file
    (VAR status: ost$status);

    cmp$update_pc (cmv$output_fid, status);

  PROCEND cmp$update_output_file;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$update_pc', EJECT ??

{ PURPOSE:
{     This procedure updates the physical configuration
{   file specified on the output parameter of EDIPC.
{   This procedure will be invoked if QUIT WPC=TRUE


  PROCEDURE [XDCL] cmp$update_pc
    (    output_fid: amt$file_identifier;
     VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      current_p: ^cmt$pcu_command_descriptor,
      index: integer,
      line: string (2),
      local_status: ost$status,
      next_p: ^cmt$pcu_command_descriptor;

    amp$rewind (output_fid, osc$wait, local_status);

    IF cmv$command_descriptor_p <> NIL THEN
      current_p := cmv$command_descriptor_p;
      WHILE current_p <> NIL DO
        cmp$display_descriptor (current_p, output_fid, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        current_p := current_p^.next_descriptor;

      WHILEND;
    ELSE
      line := '  ';
      amp$put_next (output_fid, ^line, 2, byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    cmp$clean_up_list;

    fsp$close_file (output_fid, status);


  PROCEND cmp$update_pc;


?? OLDTITLE ??
?? NEWTITLE := '   cmp$validate_address_range', EJECT ??

{ PURPOSE:
{    This procedure validates the range of physical unit number based
{    on the device type.

  PROCEDURE cmp$validate_address_range
    (    unit_type: cmt$unit_type;
         physical_address: integer;
     VAR status: ost$status);

    VAR
      error_string: string (40),
      str: ost$string;

    status.normal := TRUE;
    clp$convert_integer_to_string (physical_address, 10, TRUE, str, status);
    error_string := '   ';
    error_string (1, 18) := ' Physical address ';
    error_string (19, str.size) := str.value (1, str.size);
    error_string (19 + str.size + 1, * ) := 'is out of range';

    CASE unit_type OF
    = cmc$mt639_1 =
      IF (physical_address <> 0) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter, error_string,
              status);
        RETURN;
      IFEND;

    = cmc$mt639_s0 =
      IF (physical_address < 0) OR (physical_address > 1) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter, error_string,
              status);
        RETURN;
      IFEND;

    = cmc$mt679_5 .. cmc$mt698_3x, cmc$ms844_4x, cmc$mshydra, cmc$ms5832_2,
            cmc$ms5833_1p .. cmc$ms5833_4, cmc$ms5838_1p .. cmc$ms5838_4,
            cmc$ms47444_1p .. cmc$ms47444_4 =
      IF (physical_address < 0) OR (physical_address > 7) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter, error_string,
              status);
        RETURN;
      IFEND;

    = cmc$mt5682_1x =
      IF (physical_address < 0) OR (physical_address > 15) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter, error_string,
              status);
        RETURN;
      IFEND;

    = cmc$ms885_1x .. cmc$ms885_4x =
      IF (physical_address < 32) OR (physical_address > 47) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter, error_string,
              status);
        RETURN;
      IFEND;
    = cmc$msfsd2_s0 =

      IF (physical_address < 0) OR (physical_address > 7) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter, error_string,
              status);
        RETURN;
      IFEND;

    = cmc$ms834_2, cmc$msfsd_2 =
      IF (physical_address < 0) OR (physical_address > 4) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter, error_string,
              status);
        RETURN;
      IFEND;
    = cmc$ms895_2, cmc$ms5832_1, cmc$ms5833_1, cmc$ms5838_1, cmc$ms47444_1 =
      IF (physical_address < 0) OR (physical_address > 31) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter, error_string,
              status);
        RETURN;
      IFEND;
    ELSE

{ may be a foreign product

      IF (physical_address < 0) OR (physical_address > 63) THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter, error_string,
              status);
        RETURN;
      IFEND;
    CASEND;


  PROCEND cmp$validate_address_range;


?? OLDTITLE ??
?? NEWTITLE := '   cmp$validate_mainframe_name', EJECT ??

{ PURPOSE:
{   This procedure validates the name of the mainframe used in PCU subcommands.

  PROCEDURE [XDCL, #GATE] cmp$validate_mainframe_name
    (    mainframe_name: cmt$element_name;
     VAR status: ost$status);

    VAR
      i: 1 .. 31,
      found: boolean;

    VAR
      alpha_numeric: [STATIC, READ, oss$job_paged_literal] set of char := ['0', '1', '2', '3', '4', '5', '6',
            '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P',
            'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'];

    status.normal := TRUE;
    IF mainframe_name (1, 8) = '$SYSTEM_' THEN
      FOR i := 1 TO 4 DO
        IF NOT (mainframe_name (8 + i, 1) IN alpha_numeric) THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
                'Invalid mainframe_name specified', status);
          RETURN;
        IFEND;
      FOREND;
    ELSE

{ Error

      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter,
            'Invalid mainframe_name specified', status);
      RETURN;
    IFEND;

  PROCEND cmp$validate_mainframe_name;

?? OLDTITLE ??
?? NEWTITLE := '   initialize_descriptor', EJECT ??

{ PURPOSE:
{   Initialize all fields of a descriptor that will be used
{   in the linked list created by the PCU editor.

  PROCEDURE initialize_descriptor
    (VAR descriptor: cmt$pcu_command_descriptor);

    descriptor.same_as := osc$null_name;
    descriptor.sn := 0;
    descriptor.pid := osc$null_name;
    descriptor.state := osc$null_name;
    descriptor.ioupn := osc$null_name;
    descriptor.next_descriptor := NIL;
    descriptor.pc_list := NIL;
    descriptor.iou_list := NIL;
    descriptor.cmc_list := NIL;
    descriptor.channel_list := NIL;
    descriptor.application_info_p := NIL;
    descriptor.site_info_p := NIL;
  PROCEND initialize_descriptor;

?? OLDTITLE ??
?? NEWTITLE := '   Function find_name_length', EJECT ??

{ PURPOSE:
{   Returns the length of a name.


  FUNCTION [INLINE] find_name_length
    (    element_name: cmt$element_name): integer;

    VAR
      i: integer;

    i := 0;
    REPEAT
      i := i + 1;
    UNTIL (element_name (i) = ' ') OR (i = 31);
    find_name_length := i - 1;

  FUNCEND find_name_length;


?? OLDTITLE ??
?? NEWTITLE := '   trim_blank', EJECT ??

{ PURPOSE:
{   This procedure trims all blanks in a string. The number of
{   non blanks characters is returned.

  PROCEDURE [INLINE] trim_blank
    (    line: string (osc$max_string_size);
     VAR length: 0 .. osc$max_string_size);

    VAR
      i: 0 .. osc$max_string_size;

    i := osc$max_string_size;
    WHILE (i >= 1) AND (line (i, 1) = ' ') DO
      i := i - 1;
    WHILEND;
    length := i + 2;

  PROCEND trim_blank;

?? OLDTITLE ??

MODEND cmm$phys_configuration_utl_23d;
*DECK DECK=CMM$PHYS_CONFIGURATION_UTL_2DD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Physical Configuration Utility command processor' ??
MODULE cmm$phys_configuration_utl_2dd;

{ PURPOSE :
{   This module contains command processor interfaces for the NOS/VE
{   Physical Configuration Utility.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$lfn_program_actions
*copyc clc$standard_file_names
*copyc cld$parameter_limits
*copyc clt$function_processor_table
*copyc clt$work_area
*copyc cme$physical_configuration_utl
*copyc cmt$element_definition
?? POP ??
*copyc amp$get_file_attributes
*copyc clp$begin_utility
*copyc clp$end_scan_command_file
*copyc clp$evaluate_parameters
*copyc clp$end_utility
*copyc clp$convert_string_to_file
*copyc clp$get_command_origin
*copyc clp$get_path_description
*copyc clp$get_parameter_list_text
*copyc clp$put_job_output
*copyc clp$scan_command_file
*copyc cmp$compile_phys_configuration
*copyc cmp$clean_up_list
*copyc cmp$clean_up_error_count
*copyc cmp$close_in_out_files
*copyc cmp$close_utility_files
*copyc cmp$crack_parameters
*copyc cmp$deadstart_phase
*copyc cmp$echo_command
*copyc cmp$echo_errors
*copyc cmp$increment_pcu_error_count
*copyc cmp$generate_error_listing
*copyc cmp$open_scratch_err_file
*copyc cmp$open_utility_files
*copyc cmp$post_deadstart
*copyc cmp$process_define_element
*copyc cmp$setup_mainframe_name
*copyc cmp$set_default_mainframe_name
*copyc cmp$set_exec_in_editor
*copyc cmp$set_in_editor
*copyc cmp$save_output
*copyc cmp$valid_channel_name
*copyc cmp$validate_mainframe_name
*copyc cmp$update_descriptor
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
*copyc cmv$in_editor
*copyc cmv$executing_within_editor
*copyc cmv$pcu_error_count
*copyc osv$lower_to_upper
*copyc oss$job_paged_literal
?? EJECT ??

  CONST
    utility_name = 'PHYSICAL_CONFIGURATION_UTILITY ';


{ table pcu_command_list t=c s=local sn=oss$job_paged_literal
{ command (define_working_mainframe       ,defwm) cmp$define_working_mainframe cm=local a=hidden l=manual
{ command (define_element                 ,defe) cmp$define_element cm=local a=hidden l=manual
{ command (quit                           ,qui) cmp$quit cm=local
{ command (verify_physical_configuration  ,verpc) cmp$verify_phys_configuration cm=local
{ command (install_physical_configuration ,inspc) cmp$install_phys_configuration cm=local
{ command (edit_physical_configuration    ,edipc) cmp$edit_pc cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    pcu_command_list: [STATIC, READ, oss$job_paged_literal] ^clt$command_table := ^pcu_command_list_entries,

    pcu_command_list_entries: [STATIC, READ, oss$job_paged_literal] array [1 .. 12] of
          clt$command_table_entry := [
          {} ['DEFE                           ', clc$abbreviation_entry, clc$hidden_entry, 2,
          clc$manually_log, clc$linked_call, ^cmp$define_element],
          {} ['DEFINE_ELEMENT                 ', clc$nominal_entry, clc$hidden_entry, 2, clc$manually_log,
          clc$linked_call, ^cmp$define_element],
          {} ['DEFINE_WORKING_MAINFRAME       ', clc$nominal_entry, clc$hidden_entry, 1, clc$manually_log,
          clc$linked_call, ^cmp$define_working_mainframe],
          {} ['DEFWM                          ', clc$abbreviation_entry, clc$hidden_entry, 1,
          clc$manually_log, clc$linked_call, ^cmp$define_working_mainframe],
          {} ['EDIPC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
          clc$automatically_log, clc$linked_call, ^cmp$edit_pc],
          {} ['EDIT_PHYSICAL_CONFIGURATION    ', clc$nominal_entry, clc$normal_usage_entry, 6,
          clc$automatically_log, clc$linked_call, ^cmp$edit_pc],
          {} ['INSPC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^cmp$install_phys_configuration],
          {} ['INSTALL_PHYSICAL_CONFIGURATION ', clc$nominal_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^cmp$install_phys_configuration],
          {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^cmp$quit],
          {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^cmp$quit],
          {} ['VERIFY_PHYSICAL_CONFIGURATION  ', clc$nominal_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^cmp$verify_phys_configuration],
          {} ['VERPC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^cmp$verify_phys_configuration]];

?? POP ??

?? OLDTITLE ??
?? NEWTITLE := '   cmp$check_reserved_names', EJECT ??

{ PURPOSE :
{    This procedure validates the element names against a list of
{    reserved keywords.

  PROCEDURE [XDCL] cmp$check_reserved_names
    (    element_name: cmt$element_name;
         reserved_names_list: ^array [ * ] of ost$name;
     VAR status: ost$status);

    VAR
      temp_string: cmt$element_name,
      text: string (60),
      c_index: cmt$channel_ordinal,
      index: integer;

    status.normal := TRUE;
    #TRANSLATE (osv$lower_to_upper, element_name, temp_string);

  /for_loop/
    FOR index := 1 TO UPPERBOUND (reserved_names_list^) DO
      IF temp_string = reserved_names_list^ [index] THEN
        text (1, * ) := 'Element name is a reserved name';
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter, text, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, temp_string, status);
        EXIT /for_loop/;
      IFEND;
    FOREND /for_loop/;
    IF status.normal THEN
      IF cmp$valid_channel_name (temp_string) THEN
        text (1, * ) := 'Element name is a reserved name';
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_parameter, text, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, temp_string, status);
      IFEND;
    IFEND;
  PROCEND cmp$check_reserved_names;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$define_element', EJECT ??

{ PURPOSE :
{    This procedure is the command processor for the PCU subcommand
{    DEFINE_ELEMENT.

  PROCEDURE [XDCL] cmp$define_element
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{    PROCEDURE (cmm$pcu_defe) define_element, defe (
{      element, e: name = $required
{      same_as, sa: name = $optional
{      element_identification, ei: any of
{        key
{          $834_12, $836_xxx, $844_4x, $885_1x, $887_1, $895_2, $9836_1, $9853_x,
{          $5832_1, $5832_2, $5833_1, $5833_1p, $5833_2, $5833_3p, $5833_4,
{          $5838_1, $5838_1p, $5838_2, $5838_3p, $5838_4,
{          $47444_1, $47444_1p, $47444_2, $47444_3p, $47444_4,
{          $7155_1, $7155_1x, $7165_2x, $10395_11, $fa7b4_d, $fa7b5_a, $5831_x,
{          $5680_11, $5682_1x, $5698_1x, $639_1, $679_x, $698_1x, $698_2x,
{          $698_3x, $7021_3x, $7221_1, $7221_11, $9639_1, $65354_1x, $4000_xx,
{          $2620_xxx, $2621_xxx, $2629_x, $380_170, $5380_100, $7040_200
{        keyend
{        name 1..10
{      anyend = $optional
{      iou_program_name, ioupn, ipn: name = $optional
{      serial_number, sn: integer 1..999999 = $optional
{      state, s: key
{          down, off, on
{        keyend = on
{      central_memory_connection, central_memory_connections, cmc: list 1..CLC$MAX_VALUE_SETS of record
{          port: integer 0..3
{          mainframe: name = $optional
{        recend = $optional
{      iou_connection, iou_connections, ic: list 1..CLC$MAX_VALUE_SETS of record
{          channel: name
{          equipment: integer 0..7 = $optional
{          mainframe: name = $optional
{          iou: name = $optional
{        recend = $optional
{      peripheral_connection, peripheral_connections, pc: list 1..CLC$MAX_VALUE_SETS of record
{          peripheral_element: name
{          physical_address: integer 0..0ffff(16) = $optional
{        recend = $optional
{      verify_element_identification, vei: boolean = true
{      application_information, ai: string = $optional
{      site_information, si: string = $optional
{      )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 28] of clt$pdt_parameter_name,
      parameters: array [1 .. 12] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: 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 .. 52] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
        default_value: string (2),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
    recend := [
    [1,
    [94, 3, 16, 11, 28, 3, 110],
    clc$command, 28, 12, 1, 0, 0, 0, 0, 'CMM$PCU_DEFE'], [
    ['AI                             ',clc$abbreviation_entry, 11],
    ['APPLICATION_INFORMATION        ',clc$nominal_entry, 11],
    ['CENTRAL_MEMORY_CONNECTION      ',clc$nominal_entry, 7],
    ['CENTRAL_MEMORY_CONNECTIONS     ',clc$alias_entry, 7],
    ['CMC                            ',clc$abbreviation_entry, 7],
    ['E                              ',clc$abbreviation_entry, 1],
    ['EI                             ',clc$abbreviation_entry, 3],
    ['ELEMENT                        ',clc$nominal_entry, 1],
    ['ELEMENT_IDENTIFICATION         ',clc$nominal_entry, 3],
    ['IC                             ',clc$abbreviation_entry, 8],
    ['IOUPN                          ',clc$alias_entry, 4],
    ['IOU_CONNECTION                 ',clc$nominal_entry, 8],
    ['IOU_CONNECTIONS                ',clc$alias_entry, 8],
    ['IOU_PROGRAM_NAME               ',clc$nominal_entry, 4],
    ['IPN                            ',clc$abbreviation_entry, 4],
    ['PC                             ',clc$abbreviation_entry, 9],
    ['PERIPHERAL_CONNECTION          ',clc$nominal_entry, 9],
    ['PERIPHERAL_CONNECTIONS         ',clc$alias_entry, 9],
    ['S                              ',clc$abbreviation_entry, 6],
    ['SA                             ',clc$abbreviation_entry, 2],
    ['SAME_AS                        ',clc$nominal_entry, 2],
    ['SERIAL_NUMBER                  ',clc$nominal_entry, 5],
    ['SI                             ',clc$abbreviation_entry, 12],
    ['SITE_INFORMATION               ',clc$nominal_entry, 12],
    ['SN                             ',clc$abbreviation_entry, 5],
    ['STATE                          ',clc$nominal_entry, 6],
    ['VEI                            ',clc$abbreviation_entry, 10],
    ['VERIFY_ELEMENT_IDENTIFICATION  ',clc$nominal_entry, 10]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1956,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 7
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 120,
  clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 202,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 120,
  clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [28, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 11
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 12
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    1931, [[1, 0, clc$keyword_type], [52], [
      ['$10395_11                      ', clc$nominal_entry, clc$normal_usage_entry, 29],
      ['$2620_XXX                      ', clc$nominal_entry, clc$normal_usage_entry, 47],
      ['$2621_XXX                      ', clc$nominal_entry, clc$normal_usage_entry, 48],
      ['$2629_X                        ', clc$nominal_entry, clc$normal_usage_entry, 49],
      ['$380_170                       ', clc$nominal_entry, clc$normal_usage_entry, 50],
      ['$4000_XX                       ', clc$nominal_entry, clc$normal_usage_entry, 46],
      ['$47444_1                       ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['$47444_1P                      ', clc$nominal_entry, clc$normal_usage_entry, 22],
      ['$47444_2                       ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['$47444_3P                      ', clc$nominal_entry, clc$normal_usage_entry, 24],
      ['$47444_4                       ', clc$nominal_entry, clc$normal_usage_entry, 25],
      ['$5380_100                      ', clc$nominal_entry, clc$normal_usage_entry, 51],
      ['$5680_11                       ', clc$nominal_entry, clc$normal_usage_entry, 33],
      ['$5682_1X                       ', clc$nominal_entry, clc$normal_usage_entry, 34],
      ['$5698_1X                       ', clc$nominal_entry, clc$normal_usage_entry, 35],
      ['$5831_X                        ', clc$nominal_entry, clc$normal_usage_entry, 32],
      ['$5832_1                        ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['$5832_2                        ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['$5833_1                        ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['$5833_1P                       ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['$5833_2                        ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['$5833_3P                       ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['$5833_4                        ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['$5838_1                        ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['$5838_1P                       ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['$5838_2                        ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['$5838_3P                       ', clc$nominal_entry, clc$normal_usage_entry, 19],
      ['$5838_4                        ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['$639_1                         ', clc$nominal_entry, clc$normal_usage_entry, 36],
      ['$65354_1X                      ', clc$nominal_entry, clc$normal_usage_entry, 45],
      ['$679_X                         ', clc$nominal_entry, clc$normal_usage_entry, 37],
      ['$698_1X                        ', clc$nominal_entry, clc$normal_usage_entry, 38],
      ['$698_2X                        ', clc$nominal_entry, clc$normal_usage_entry, 39],
      ['$698_3X                        ', clc$nominal_entry, clc$normal_usage_entry, 40],
      ['$7021_3X                       ', clc$nominal_entry, clc$normal_usage_entry, 41],
      ['$7040_200                      ', clc$nominal_entry, clc$normal_usage_entry, 52],
      ['$7155_1                        ', clc$nominal_entry, clc$normal_usage_entry, 26],
      ['$7155_1X                       ', clc$nominal_entry, clc$normal_usage_entry, 27],
      ['$7165_2X                       ', clc$nominal_entry, clc$normal_usage_entry, 28],
      ['$7221_1                        ', clc$nominal_entry, clc$normal_usage_entry, 42],
      ['$7221_11                       ', clc$nominal_entry, clc$normal_usage_entry, 43],
      ['$834_12                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['$836_XXX                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['$844_4X                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['$885_1X                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['$887_1                         ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['$895_2                         ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['$9639_1                        ', clc$nominal_entry, clc$normal_usage_entry, 44],
      ['$9836_1                        ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['$9853_X                        ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['$FA7B4_D                       ', clc$nominal_entry, clc$normal_usage_entry, 30],
      ['$FA7B5_A                       ', clc$nominal_entry, clc$normal_usage_entry, 31]]
      ],
    5, [[1, 0, clc$name_type], [1, 10]]
    ],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [1, 999999, 10]],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [3], [
    ['DOWN                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['OFF                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['ON                             ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ,
    'on'],
{ PARAMETER 7
    [[1, 0, clc$list_type], [104, 1, CLC$MAX_VALUE_SETS, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [2],
      ['PORT                           ', clc$required_field, 20], [[1, 0, clc$integer_type], [0, 3, 10]],
      ['MAINFRAME                      ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]]
      ]
    ],
{ PARAMETER 8
    [[1, 0, clc$list_type], [186, 1, CLC$MAX_VALUE_SETS, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [4],
      ['CHANNEL                        ', clc$required_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['EQUIPMENT                      ', clc$optional_field, 20], [[1, 0, clc$integer_type], [0, 7, 10]],
      ['MAINFRAME                      ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['IOU                            ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]]
      ]
    ],
{ PARAMETER 9
    [[1, 0, clc$list_type], [104, 1, CLC$MAX_VALUE_SETS, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [2],
      ['PERIPHERAL_ELEMENT             ', clc$required_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['PHYSICAL_ADDRESS               ', clc$optional_field, 20], [[1, 0, clc$integer_type], [0, 0ffff(16),
  10]]
      ]
    ],
{ PARAMETER 10
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 11
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 12
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element = 1,
      p$same_as = 2,
      p$element_identification = 3,
      p$iou_program_name = 4,
      p$serial_number = 5,
      p$state = 6,
      p$central_memory_connection = 7,
      p$iou_connection = 8,
      p$peripheral_connection = 9,
      p$verify_element_identification = 10,
      p$application_information = 11,
      p$site_information = 12;

    VAR
      pvt: array [1 .. 12] of clt$parameter_value;

    CONST
      command_name = 'DEFINE_ELEMENT';

    VAR
      error_string: ost$string,
      interactive: boolean,
      ignore_status: ost$status,
      param_string: string (osc$max_string_size),
      param_list_text: ^clt$parameter_list_text;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF cmv$executing_within_editor THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_command, command_name,
              status);
      RETURN;
    IFEND;
    IF cmv$in_editor THEN
      cmp$crack_parameters (^pvt, command_name, status);
    ELSE
      cmp$process_define_element (^pvt, status);
    IFEND;
    IF NOT status.normal THEN
      clp$get_command_origin (interactive, ignore_status);
      IF NOT interactive THEN
        error_string.value := ' ';
        clp$get_parameter_list_text (^parameter_list, param_list_text, ignore_status);
        #TRANSLATE (osv$lower_to_upper, param_list_text^, param_string);
        error_string.value (1, 15) := command_name;
        IF ((17+STRLENGTH (param_string)) <= osc$max_string_size) THEN
          error_string.value (17, STRLENGTH(param_string)) := param_string (1, STRLENGTH(param_string));
          error_string.size := 17 + STRLENGTH (param_string);
        ELSE
          error_string.value (17, 240) := param_string (1, 240);
          error_string.size := osc$max_string_size;
        IFEND;
        cmp$increment_pcu_error_count;
        cmp$echo_command (error_string, ignore_status);
        cmp$echo_errors (TRUE, status);
        status.normal := TRUE;
      IFEND;
    IFEND;

  PROCEND cmp$define_element;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$define_working_mainframe', EJECT ??

{ PURPOSE :
{     This procedure is the command processor for the PCU subcommand
{     DEFINE_WORKING_MAINFRAME

  PROCEDURE [XDCL] cmp$define_working_mainframe
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (cmm$pcu_defwm) define_working_mainframe, defwm (
{   name, n: name = $required
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 1] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
    recend := [
    [1,
    [88, 11, 10, 13, 19, 46, 806],
    clc$command, 2, 1, 1, 0, 0, 0, 0, 'CMM$PCU_DEFWM'], [
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    CONST
      command = 'DEFINE_WORKING_MAINFRAME';

    VAR
      error_string: ost$string,
      interactive: boolean,
      ignore_status: ost$status,
      mainframe_name: ost$name,
      param_string: string (osc$max_string_size),
      param_list_text: ^clt$parameter_list_text;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF cmv$executing_within_editor THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_command, command, status);
      RETURN;
    IFEND;
    mainframe_name := pvt [p$name].value^.name_value;
    cmp$validate_mainframe_name (mainframe_name, status);
    IF status.normal THEN
      cmp$setup_mainframe_name (mainframe_name);
      RETURN;
    IFEND;
    clp$get_command_origin (interactive, ignore_status);
    IF NOT interactive AND NOT status.normal THEN
      error_string.value := '   ';
      clp$get_parameter_list_text (^parameter_list, param_list_text, ignore_status);
      #TRANSLATE (osv$lower_to_upper, param_list_text^, param_string);
      error_string.value (1, 25) := command;
      error_string.value (26, * ) := param_string;
      error_string.size := 26 + STRLENGTH (param_list_text^);
      cmp$increment_pcu_error_count;
      cmp$echo_command (error_string, ignore_status);
      cmp$echo_errors (TRUE, status);
      status.normal := TRUE;
    IFEND;

  PROCEND cmp$define_working_mainframe;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$edit_pc', EJECT ??

{ PURPOSE :
{     This procedure is the command processor for the PCU command
{     EDIT_PHYSICAL_CONFIGURATION. It will start up a subutility.

  PROCEDURE [XDCL] cmp$edit_pc
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (cmm$pcu_edipc) edit_physical_configuration, edipc (
{   input, i: file = $local.physical_configuration
{   output, o: file = $local.physical_configuration
{   errors, error, e: file = $errors
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (29),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (29),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 10, 13, 20, 10, 205],
    clc$command, 8, 4, 0, 0, 0, 0, 4, 'CMM$PCU_EDIPC'], [
    ['E                              ',clc$abbreviation_entry, 3],
    ['ERROR                          ',clc$alias_entry, 3],
    ['ERRORS                         ',clc$nominal_entry, 3],
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 29],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 29],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$local.physical_configuration'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$local.physical_configuration'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$errors'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$input = 1,
      p$output = 2,
      p$errors = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    CONST
      command = 'EDIT_PHYSICAL_CONFIGURATION';


{ table edit_pcu_command_list t=c sn=oss$job_paged_literal s=local
{ command (add_element_definition         ,added) p=cmp$add_element_def cm=xref
{ command (change_connection_reference    ,change_connection_references,chacr)     ..
{   p=cmp$change_connect_reference cm=xref
{ command (change_element_definition      ,chaed) p=cmp$change_element_def      cm=xref
{ command (change_element_name            ,chaen) p=cmp$change_element_name      cm=xref
{ command (display_element_definition     ,dised) p=cmp$display_element_def      cm=xref
{ command (display_connected_elements     ,disce)     p=cmp$display_mf_connections cm=xref
{ command (delete_element_definition      ,delete_element_definitions, deled)     p=cmp$delete_element_def ..
{    cm=xref
{ command (replace_element_definition     ,reped) p=cmp$replace_element_def     cm=xref
{ command (quit                           ,qui) p=cmp$quit_edit cm=xref
{ tablend

?? PUSH (LISTEXT := ON) ??

    VAR
      edit_pcu_command_list: [STATIC, READ, oss$job_paged_literal] ^clt$command_table :=
            ^edit_pcu_command_list_entries,

      edit_pcu_command_list_entries: [STATIC, READ, oss$job_paged_literal] array [1 .. 20] of
            clt$command_table_entry := [
            {} ['ADDED                          ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^cmp$add_element_def],
            {} ['ADD_ELEMENT_DEFINITION         ', clc$nominal_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^cmp$add_element_def],
            {} ['CHACR                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^cmp$change_connect_reference],
            {} ['CHAED                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^cmp$change_element_def],
            {} ['CHAEN                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^cmp$change_element_name],
            {} ['CHANGE_CONNECTION_REFERENCE    ', clc$nominal_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^cmp$change_connect_reference],
            {} ['CHANGE_CONNECTION_REFERENCES   ', clc$alias_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^cmp$change_connect_reference],
            {} ['CHANGE_ELEMENT_DEFINITION      ', clc$nominal_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^cmp$change_element_def],
            {} ['CHANGE_ELEMENT_NAME            ', clc$nominal_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^cmp$change_element_name],
            {} ['DELED                          ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^cmp$delete_element_def],
            {} ['DELETE_ELEMENT_DEFINITION      ', clc$nominal_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^cmp$delete_element_def],
            {} ['DELETE_ELEMENT_DEFINITIONS     ', clc$alias_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^cmp$delete_element_def],
            {} ['DISCE                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^cmp$display_mf_connections],
            {} ['DISED                          ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^cmp$display_element_def],
            {} ['DISPLAY_CONNECTED_ELEMENTS     ', clc$nominal_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^cmp$display_mf_connections],
            {} ['DISPLAY_ELEMENT_DEFINITION     ', clc$nominal_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^cmp$display_element_def],
            {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
            clc$automatically_log, clc$linked_call, ^cmp$quit_edit],
            {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 9,
            clc$automatically_log, clc$linked_call, ^cmp$quit_edit],
            {} ['REPED                          ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
            clc$automatically_log, clc$linked_call, ^cmp$replace_element_def],
            {} ['REPLACE_ELEMENT_DEFINITION     ', clc$nominal_entry, clc$normal_usage_entry, 8,
            clc$automatically_log, clc$linked_call, ^cmp$replace_element_def]];

    PROCEDURE [XREF] cmp$add_element_def
      (    parameter_list: clt$parameter_list;
       VAR status: ost$status);

    PROCEDURE [XREF] cmp$change_connect_reference
      (    parameter_list: clt$parameter_list;
       VAR status: ost$status);

    PROCEDURE [XREF] cmp$change_element_def
      (    parameter_list: clt$parameter_list;
       VAR status: ost$status);

    PROCEDURE [XREF] cmp$change_element_name
      (    parameter_list: clt$parameter_list;
       VAR status: ost$status);

    PROCEDURE [XREF] cmp$delete_element_def
      (    parameter_list: clt$parameter_list;
       VAR status: ost$status);

    PROCEDURE [XREF] cmp$display_element_def
      (    parameter_list: clt$parameter_list;
       VAR status: ost$status);

    PROCEDURE [XREF] cmp$display_mf_connections
      (    parameter_list: clt$parameter_list;
       VAR status: ost$status);

    PROCEDURE [XREF] cmp$quit_edit
      (    parameter_list: clt$parameter_list;
       VAR status: ost$status);

    PROCEDURE [XREF] cmp$replace_element_def
      (    parameter_list: clt$parameter_list;
       VAR status: ost$status);

?? POP ??


{ table edit_pcu_function_list t=f sn=oss$job_paged_literal s=local
{ function ($element_definition            ,$ed) p=cmp$$element_definition cm=xref
{ tablend

?? PUSH (LISTEXT := ON) ??

    VAR
      edit_pcu_function_list: [STATIC, READ, oss$job_paged_literal] ^clt$function_processor_table :=
            ^edit_pcu_function_list_entries,

      edit_pcu_function_list_entries: [STATIC, READ, oss$job_paged_literal] array [1 .. 2] of
            clt$function_proc_table_entry := [
            {} ['$ED                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
            clc$linked_call, ^cmp$$element_definition],
            {} ['$ELEMENT_DEFINITION            ', clc$nominal_entry, clc$normal_usage_entry, 1,
            clc$linked_call, ^cmp$$element_definition]];

    PROCEDURE [XREF] cmp$$element_definition
      (    parameter_list: clt$parameter_list;
       VAR work_area {input, output} : ^clt$work_area;
       VAR result: ^clt$data_value;
       VAR status: ost$status);

?? POP ??


    VAR
      contains_data: boolean,
      edit_pcu_name: ost$name,
      error_file: clt$file,
      file_exists: boolean,
      file_previously_opened: boolean,
      file_attribute: array [1 .. 1] of amt$file_item,
      input_file: clt$file,
      input_open: boolean,
      local_status: ost$status,
      output_file: clt$file,
      output_open: boolean,
      pcu_utl_attr_p: ^clt$utility_attributes,
      set_in_editor: boolean,
      set_executing_in_editor: boolean,
      utility_attributes_p: ^clt$utility_attributes;

?? NEWTITLE := '     abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF input_open OR output_open THEN
        cmp$close_in_out_files;
        input_open := FALSE;
        output_open := FALSE;
      IFEND;
      handler_status.normal := TRUE;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

  /main_program/
    BEGIN

      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF cmv$executing_within_editor THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$pcu_invalid_command, command, status);
        RETURN;
      IFEND;
      set_in_editor := FALSE;
      set_executing_in_editor := FALSE;
      output_open := FALSE;
      input_open := FALSE;
      clp$convert_string_to_file (pvt [p$input].value^.file_value^, input_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$convert_string_to_file (pvt [p$output].value^.file_value^, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$convert_string_to_file (pvt [p$errors].value^.file_value^, error_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      osp$establish_block_exit_hndlr (^abort_handler);
      edit_pcu_name := 'PHYSICAL_CONFIGURATION_UTILITY';
      PUSH pcu_utl_attr_p: [1 .. 4];
      pcu_utl_attr_p^ [1].key := clc$utility_command_search_mode;
      pcu_utl_attr_p^ [1].command_search_mode := clc$global_command_search;
      pcu_utl_attr_p^ [2].key := clc$utility_command_table;
      pcu_utl_attr_p^ [2].command_table := pcu_command_list;
      pcu_utl_attr_p^ [3].key := clc$utility_prompt;
      pcu_utl_attr_p^ [3].prompt.value := 'PCU';
      pcu_utl_attr_p^ [3].prompt.size := 3;
      pcu_utl_attr_p^ [4].key := clc$utility_termination_command;
      pcu_utl_attr_p^ [4].termination_command := 'QUIT';

      clp$begin_utility (edit_pcu_name, pcu_utl_attr_p^, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      cmp$set_in_editor (TRUE);
      set_in_editor := TRUE;
      cmp$open_scratch_err_file (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$scan_command_file (input_file.local_file_name, edit_pcu_name, 'PCU', local_status);
      IF cmv$pcu_error_count > 0 THEN
        IF error_file.local_file_name <> clc$null_file THEN
          cmp$generate_error_listing (error_file.local_file_name, local_status);
          clp$put_job_output ('-- WARNING -- Error(s) were encountered while processing input file.',
                local_status);
        IFEND;
      ELSEIF (NOT local_status.normal) AND (local_status.condition <> ame$file_not_known) THEN
        clp$put_job_output ('-- WARNING -- Error(s) were encountered while processing input file.', status);
        osp$generate_error_message (local_status, status);
      IFEND;
      cmp$clean_up_error_count;
      cmp$set_exec_in_editor (TRUE);
      set_executing_in_editor := TRUE;
      cmp$update_descriptor;
      clp$end_utility (edit_pcu_name, local_status);
      cmp$save_output (output_file.local_file_name, FALSE, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      output_open := TRUE;
      IF input_file.local_file_name <> output_file.local_file_name THEN
        cmp$save_output (input_file.local_file_name, TRUE, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        input_open := TRUE;
      IFEND;
      edit_pcu_name := 'PHYSICAL_CONFIGURATION_EDITOR';
      PUSH utility_attributes_p: [1 .. 5];
      utility_attributes_p^ [1].key := clc$utility_command_search_mode;
      utility_attributes_p^ [1].command_search_mode := clc$global_command_search;
      utility_attributes_p^ [2].key := clc$utility_command_table;
      utility_attributes_p^ [2].command_table := edit_pcu_command_list;
      utility_attributes_p^ [3].key := clc$utility_function_proc_table;
      utility_attributes_p^ [3].function_processor_table := edit_pcu_function_list;
      utility_attributes_p^ [4].key := clc$utility_prompt;
      utility_attributes_p^ [4].prompt.value := 'PCE';
      utility_attributes_p^ [4].prompt.size := 3;
      utility_attributes_p^ [5].key := clc$utility_termination_command;
      utility_attributes_p^ [5].termination_command := 'QUIT';

      clp$begin_utility (edit_pcu_name, utility_attributes_p^, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      clp$scan_command_file (clc$current_command_input, edit_pcu_name, 'PCE', status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$end_utility (edit_pcu_name, local_status);
    END /main_program/;
    IF NOT status.normal THEN
      cmp$close_utility_files;
      cmp$open_utility_files (local_status);
      IF input_open OR output_open THEN
        cmp$close_in_out_files;
      IFEND;
      IF set_executing_in_editor THEN
        cmp$clean_up_list;
        cmp$set_exec_in_editor (FALSE);
      IFEND;
      IF set_in_editor THEN
        cmp$set_in_editor (FALSE);
      IFEND;
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND cmp$edit_pc;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$install_phys_configuration', EJECT ??

{ PURPOSE :
{    This procedure is the command processor of the PCU subcommand
{    INSTALL_PHYSICAL_CONFIGURATION.

  PROCEDURE [XDCL] cmp$install_phys_configuration
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (cmm$pcu_inspc) install_physical_configuration, inspc (
{   input, i: file = $local.physical_configuration
{   errors, error, e: file = $errors
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (29),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 10, 13, 20, 31, 115],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'CMM$PCU_INSPC'], [
    ['E                              ',clc$abbreviation_entry, 2],
    ['ERROR                          ',clc$alias_entry, 2],
    ['ERRORS                         ',clc$nominal_entry, 2],
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 29],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$local.physical_configuration'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$errors'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$input = 1,
      p$errors = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cmp$compile_phys_configuration ({VERIFY=} FALSE, ^pvt, status);

  PROCEND cmp$install_phys_configuration;

?? OLDTITLE ??
?? NEWTITLE := '   physical_configuration_utility', EJECT ??

{ PURPOSE :
{    This procedure starts up the physical_configuration_utility.

  PROCEDURE [XDCL, #GATE] physical_configuration_utility
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);



{ PROCEDURE (cmm$pcu) physical_configuration_utility, pcu (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [88, 11, 10, 13, 20, 54, 683],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'CMM$PCU'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    CONST
      utility_name = 'PHYSICAL_CONFIGURATION_UTILITY ';

    VAR
      local_status: ost$status,
      pcu_utl_attr_p: ^clt$utility_attributes;

  /main_program/
    BEGIN
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      PUSH pcu_utl_attr_p: [1 .. 4];
      pcu_utl_attr_p^ [1].key := clc$utility_command_search_mode;
      pcu_utl_attr_p^ [1].command_search_mode := clc$global_command_search;
      pcu_utl_attr_p^ [2].key := clc$utility_command_table;
      pcu_utl_attr_p^ [2].command_table := pcu_command_list;
      pcu_utl_attr_p^ [3].key := clc$utility_prompt;
      pcu_utl_attr_p^ [3].prompt.value := 'PCU';
      pcu_utl_attr_p^ [3].prompt.size := 3;
      pcu_utl_attr_p^ [4].key := clc$utility_termination_command;
      pcu_utl_attr_p^ [4].termination_command := 'QUIT';

      clp$begin_utility (utility_name, pcu_utl_attr_p^, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      cmp$open_utility_files (status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      cmp$set_default_mainframe_name (status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$scan_command_file (clc$current_command_input, utility_name, 'PCU', status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$end_utility (utility_name, local_status);

    END /main_program/;

  PROCEND physical_configuration_utility;

?? OLDTITLE ??
?? NEWTITLE := '   pcu ', EJECT ??

{ PURPOSE :
{    This procedure is the command processor of the alias PCU

  PROCEDURE [XDCL, #GATE] pcu
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    physical_configuration_utility (parameter_list, status);

  PROCEND pcu;


?? OLDTITLE ??
?? NEWTITLE := '   cmp$quit', EJECT ??

{ PURPOSE :
{    This procedure ends the physical_configuration_utility.

  PROCEDURE cmp$quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{   PROCEDURE (cmm$pcu_quit) quit, qui (
{       )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [88, 11, 10, 13, 22, 50, 357],
    clc$command, 0, 0, 0, 0, 0, 0, 0, 'CMM$PCU_QUIT']];

?? FMT (FORMAT := ON) ??
?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$end_scan_command_file (utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cmp$close_utility_files;

  PROCEND cmp$quit;

?? OLDTITLE ??
?? NEWTITLE := '   cmp$verify_phys_configuration', EJECT ??

{ PURPOSE:
{    This procedure is the command processor for the PCU command
{    VERIFY_PHYSICAL_CONFIGURATION.

  PROCEDURE [XDCL] cmp$verify_phys_configuration
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (cmm$pcu_verpc) verify_physical_configuration, verpc (
{   mainframe, m: name = $name($mainframe(identifier))
{   input, i: file = $local.physical_configuration
{   errors, error, e: file = $errors
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (29),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (29),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 10, 13, 21, 24, 501],
    clc$command, 8, 4, 0, 0, 0, 0, 4, 'CMM$PCU_VERPC'], [
    ['E                              ',clc$abbreviation_entry, 3],
    ['ERROR                          ',clc$alias_entry, 3],
    ['ERRORS                         ',clc$nominal_entry, 3],
    ['I                              ',clc$abbreviation_entry, 2],
    ['INPUT                          ',clc$nominal_entry, 2],
    ['M                              ',clc$abbreviation_entry, 1],
    ['MAINFRAME                      ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 29],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 29],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    '$name($mainframe(identifier))'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$local.physical_configuration'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$errors'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$mainframe = 1,
      p$input = 2,
      p$errors = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cmp$compile_phys_configuration ({VERIFY=} TRUE, ^pvt, status);

  PROCEND cmp$verify_phys_configuration;

?? OLDTITLE ??
?? OLDTITLE ??

MODEND cmm$phys_configuration_utl_2dd;

*DECK DECK=CMM$SIGNAL_HANDLER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' Configuration Management Signal Handler' ??
MODULE cmm$signal_handler;

{
{  PURPOSE:
{    This module contains the code to interpet and take the approriate action
{    when a configuration management signal is encountered.


?? PUSH (LISTEXT := ON) ??
*copyc clp$convert_integer_to_string
*copyc clp$trimmed_string_size
*copyc cmc$action_messages
*copyc cme$logical_configuration_mgr
*copyc cml$connection_disabled
*copyc cml$element_disabled
*copyc cmt$signal_contents
*copyc oss$task_shared
*copyc osv$task_shared_heap
*copyc ost$global_task_id
*copyc pmt$signal
*copyc cmp$activate_signal_handler
*copyc cmp$convert_channel_number
*copyc cmp$convert_iou_number
*copyc cmp$determine_tape_element
*copyc cmp$free_deadstart_signals
*copyc cmp$get_element_entry_via_adr
*copyc cmp$get_element_entry_via_lun
*copyc cmp$get_element_entry_via_name
*copyc cmp$get_element_information
*copyc cmp$get_element_r3
*copyc cmp$process_state_change
*copyc cmp$queue_deadstart_signal
*copyc cmp$return_logical_pp_number
*copyc cmp$search_active_volume_table
*copyc iot$disk_statistics
*copyc ofp$clear_operator_message
*copyc ofp$format_operator_message
*copyc ofp$receive_operator_response
*copyc ofp$send_formatted_operator_msg
*copyc osp$get_parameter_prompt
*copyc osp$system_error
*copyc pmp$execute
*copyc pmp$get_mainframe_id
*copyc pmp$log
*copyc pmp$long_term_wait
*copyc sfp$emit_statistic

?? POP ??
?? TITLE := ' XREF procedures', EJECT ??
*copyc cmv$controller_address
*copyc cmv$data_channel_address
*copyc cmv$deadstart_signals
*copyc cmv$hydra_mass_storage_address
*copyc cmv$logical_pp_table_p
*copyc cmv$mass_storage_address
*copyc cmv$peripheral_element_table
*copyc cmv$signal_handler_active
*copyc tmv$system_job_monitor_gtid


  TYPE
    cmt$signal_handler_parameters = record
      originator: ost$global_task_id,
      signal: pmt$signal,
    recend;

  VAR
    default_program_attributes: [STATIC, READ] pmt$program_attributes := [[pmc$starting_proc_specified],
          'CMP$PROCESS_SIGNAL', 0, 0, 1, osc$null_name, [pmc$no_load_map], pmc$error_load_errors,
          pmc$initialize_to_zero, osc$max_segment_length, osc$null_name, osc$null_name, osc$null_name, FALSE];

  VAR
    cmv$handler_task_status_p: [oss$task_shared] ^pmt$task_status := NIL;

?? TITLE := '  build_connection_label', EJECT ??
  {
  { PURPOSE:
  {   This procedure extracts information from the upline and
  {   downline peripheral_element_entry to build a string describing
  {   the connection between the two elements.  The connection label
  {   consists of the element_names of the two elements separated by
  {   a period (i.e. ".").  When the upline element is a channel the
  {   iou name is included as part of the channel element name.

  PROCEDURE build_connection_label
    (    upline_element_entry_p: ^cmt$peripheral_element_entry;
         downline_element_entry_p: ^cmt$peripheral_element_entry;
         iou_name: ost$name;
     VAR connection_label: ost$string);

    VAR
      i: integer,
      str_size: integer;

    i := 1;
    IF upline_element_entry_p^.physical_descriptor.element_type = cmc$data_channel_element THEN
      connection_label.value (i, 4) := iou_name (1, 4);
      i := i + 4;
      connection_label.value (i) := '/';
      i := i + 1;
    IFEND;

    str_size := clp$trimmed_string_size (upline_element_entry_p^.element_name);
    connection_label.value (i, str_size) := upline_element_entry_p^.element_name (1, str_size);
    i := i + str_size;

    connection_label.value (i) := '.';
    i := i + 1;

    str_size := clp$trimmed_string_size (downline_element_entry_p^.element_name);
    connection_label.value (i, str_size) := downline_element_entry_p^.element_name (1, str_size);
    i := i + str_size;

    connection_label.size := i - 1;

  PROCEND build_connection_label;

?? TITLE := '  build_path', EJECT ??
  {
  { PURPOSE:
  {   This procedure builds a string that represents the path
  {   of the specified physical_address. The path consists of the element names
  {   of all elements in the path seperated by periods (i.e. "."). The iou/channel
  {   element always begins the path and controller and/or mass_storage elements
  {   will be appended if the are contained in the physical_address.
  {

  PROCEDURE build_path
    (    physical_address: cmt$physical_address;
     VAR path: ost$string);

    VAR
      address: cmt$physical_address,
      element_entry_p: ^cmt$peripheral_element_entry,
      i: integer,
      iou_name: ost$name,
      local_status: ost$status,
      str_size: integer;

    i := 1;

    address := physical_address;
    address.address_specifier := cmv$data_channel_address;
    address.channel_address := 0;
    address.unit_address := 0;

    {
    { Initialize path with correct IOU name.
    {
    CASE address.iou OF
    = 0 =
      path.value (i, 5) := 'IOU0/';
      i := i + 5;
    = 1 =
      path.value (i, 5) := 'IOU1/';
      i := i + 5;
    ELSE
    CASEND;
    {
    { Get channel element name and append to path.
    {
    cmp$get_element_entry_via_adr (address, element_entry_p);
    IF element_entry_p = NIL THEN
      local_status.normal := FALSE;
      osp$system_error ('cmp$get_element_entry_via_adr unable to locate element.', ^local_status);
    IFEND;

    str_size := clp$trimmed_string_size (element_entry_p^.element_name);
    path.value (i, str_size) := element_entry_p^.element_name (1, str_size);
    i := i + str_size;
    {
    { If the address contains a channel address, get element name and append to path.
    {
    IF cmc$channel_address IN physical_address.address_specifier THEN
      address.address_specifier := cmv$controller_address;
      address.channel_address := physical_address.channel_address;

      cmp$get_element_entry_via_adr (address, element_entry_p);
      IF element_entry_p = NIL THEN
        local_status.normal := FALSE;
        osp$system_error ('cmp$get_element_entry_via_adr unable to locate element.', ^local_status);
      IFEND;

      path.value (i) := '.';
      i := i + 1;

      str_size := clp$trimmed_string_size (element_entry_p^.element_name);
      path.value (i, str_size) := element_entry_p^.element_name (1, str_size);
      i := i + str_size;

    IFEND;
    {
    { If the address contains a unit address, get element name and append to path.
    {
    IF cmc$unit_address IN physical_address.address_specifier THEN
      address.address_specifier := cmv$mass_storage_address;
      address.unit_address := physical_address.unit_address;

      cmp$get_element_entry_via_adr (address, element_entry_p);
      IF element_entry_p = NIL THEN
        local_status.normal := FALSE;
        osp$system_error ('cmp$get_element_entry_via_adr unable to locate element.', ^local_status);
      IFEND;

      path.value (i) := '.';
      i := i + 1;

      str_size := clp$trimmed_string_size (element_entry_p^.element_name);
      path.value (i, str_size) := element_entry_p^.element_name (1, str_size);
      i := i + str_size;
    IFEND;

    path.size := i - 1;

  PROCEND build_path;

?? TITLE := '  cmp$process_deadstart_signals', EJECT ??
  {
  { PURPOSE:
  {   This procedure will execute the CM signal handler for every signal
  {   queued during deadstart.  The normal signal handling procedure is
  {   activated and the queued signals are freed.
  {

  PROCEDURE [XDCL, #GATE] cmp$process_deadstart_signals;

    VAR
      p_next_deadstart_signal: ^cmt$deadstart_signal,
      p_deadstart_signal: ^cmt$deadstart_signal;

      cmp$activate_signal_handler;

      IF cmv$deadstart_signals = NIL THEN
        RETURN;
      IFEND;

      p_deadstart_signal := cmv$deadstart_signals;
      WHILE p_deadstart_signal <> NIL DO
        p_next_deadstart_signal := p_deadstart_signal^.next_signal;
        cmp$signal_handler (p_deadstart_signal^.originator, p_deadstart_signal^.signal);
        p_deadstart_signal := p_next_deadstart_signal;
      WHILEND;

      cmp$free_deadstart_signals;

  PROCEND cmp$process_deadstart_signals;

?? TITLE := '  cmp$process_signal', EJECT ??
{
{ PURPOSE:
{   This procedure is called by the configuration management signal handler
{   via a call to pmp$execute. An asynchronous task is started in the system
{   job to perform the action required to process the signal.
{

  PROCEDURE [XDCL, #GATE] cmp$process_signal
    (    program_parameters: pmt$program_parameters;
     VAR status: ost$status);

    VAR
      p_parameters: ^SEQ ( * ),
      p_signal_handler_parameters: ^cmt$signal_handler_parameters,
      signal_contents: cmt$signal_contents;

    p_parameters := ^program_parameters;
    RESET p_parameters;
    NEXT p_signal_handler_parameters IN p_parameters;

    #UNCHECKED_CONVERSION (p_signal_handler_parameters^.signal.contents, signal_contents);

    CASE signal_contents.signal_type OF
    = cmc$reconfiguration_signal =
      process_reconfig_signal (signal_contents, status);
    = cmc$das_head_shift_signal =
      process_das_head_shift_signal (signal_contents, status);
    = cmc$ssd_battery_alert_signal =
      process_ssd_battery_signal (signal_contents, status);
    = cmc$down_element_signal =
      process_down_element_signal (signal_contents, status);
    = cmc$disable_element_signal =
      process_disable_signal (signal_contents, status);
    = cmc$controller_overtemp_signal =
      process_overtemp_signal (signal_contents, status);
    = cmc$parity_disabled_signal =
      process_parity_disabled_signal (signal_contents, status);
    ELSE
    CASEND;

  PROCEND cmp$process_signal;

?? TITLE := '  cmp$signal_handler', EJECT ??
{
{ PURPOSE:
{   This procedure is the configuration management signal handler.
{   In stuations where the system is ready to support tasks it will
{   spin off an asynchronous task to service the signal.  This is to
{   prevent the system to wait for the signal to be processed.
{   If a configurtion management signal is encountered before deadstart is
{   complete the signal handler will place the signal on a linked list
{   and process the signals when the system can support asynchronous tasks
{   and operator messages.
{

  PROCEDURE [XDCL, #GATE] cmp$signal_handler
    (    originator: ost$global_task_id;
         signal: pmt$signal);

    VAR
      local_status: ost$status,
      p_parameters: ^SEQ ( * ),
      p_program_attributes: ^pmt$program_attributes,
      p_program_description: ^pmt$program_description,
      p_signal_handler_parameters: ^cmt$signal_handler_parameters,
      signal_contents: cmt$signal_contents,
      task_id: pmt$task_id;

    IF cmv$signal_handler_active THEN
      {
      { Initiate asynchronous task to execute the procedure cmp$process_signal.
      {
      IF cmv$handler_task_status_p = NIL THEN
        ALLOCATE cmv$handler_task_status_p IN osv$task_shared_heap^;
      IFEND;

      PUSH p_program_description: [[REP #SIZE (pmt$program_attributes) OF cell]];
      RESET p_program_description;
      NEXT p_program_attributes IN p_program_description;
      p_program_attributes^ := default_program_attributes;

      PUSH p_parameters: [[REP #SIZE (cmt$signal_handler_parameters) OF cell]];
      RESET p_parameters;
      NEXT p_signal_handler_parameters IN p_parameters;
      p_signal_handler_parameters^.originator := originator;
      p_signal_handler_parameters^.signal := signal;

      pmp$execute (p_program_description^, p_parameters^, osc$nowait, task_id, cmv$handler_task_status_p^,
            local_status);
    ELSE
      {
      { Execute the process signal interface synchronously.
      {
      cmp$queue_deadstart_signal(originator, signal);
    IFEND;
  PROCEND cmp$signal_handler;

?? TITLE := 'display_disable_menu', EJECT ??
{
{ PURPOSE:
{   This procedure will build the parameter list for the disable_element
{   message module and pass the parameter list to the ]mit_operator_message
{   procedure.
{

  PROCEDURE display_disable_menu
    (    element_definition: cmt$element_definition;
         element_entry_p: ^cmt$peripheral_element_entry;
     VAR status: ost$status);

    VAR
      not_found: boolean,
      parameters: ^ost$message_parameters,
      product_id_str: ost$name,
      recorded_vsn: rmt$recorded_vsn,
      search_key: dmt$avt_search_key,
      size: ost$string_size,
      temp_str: ost$string;

    temp_str.value := ' ';

    CASE element_definition.element_type OF
    = cmc$data_channel_element =
      CASE element_entry_p^.physical_descriptor.channel_path.iou OF
      = 0 =
        temp_str.value (1, 5) := 'IOU0/';
      = 1 =
        temp_str.value (1, 5) := 'IOU1/';
      ELSE
      CASEND;

      temp_str.value(6,*) := element_entry_p^.element_name;
      set_string_length (temp_str);

      PUSH parameters: [1 .. 1];
      parameters^ [1] := ^temp_str.value (1, temp_str.size);

      emit_operator_message (cmc$action_messages, 'CHANNEL_DISABLED               ', parameters,
            {acknowledgment_allowed} TRUE, status);

    = cmc$controller_element =
      size := STRLENGTH (element_entry_p^.product_id.product_number);
      temp_str.value (1, size) := element_entry_p^.product_id.product_number;
      temp_str.size := size;

      size := STRLENGTH (element_entry_p^.product_id.underscore);
      temp_str.value (temp_str.size + 1, size) := element_entry_p^.product_id.underscore;
      temp_str.size := temp_str.size + size;

      size := STRLENGTH (element_entry_p^.product_id.model_number);
      temp_str.value (temp_str.size + 1, size) := element_entry_p^.product_id.model_number;
      temp_str.size := temp_str.size + size;

      set_string_length (temp_str);

      PUSH parameters: [1 .. 3];
      parameters^ [1] := ^element_definition.element_name;
      parameters^ [2] := ^temp_str.value (1, temp_str.size);
      parameters^ [3] := ^element_definition.serial_number;

      emit_operator_message (cmc$action_messages, 'CONTROLLER_DISABLED            ', parameters,
            {acknowledgment_allowed} TRUE, status);

    = cmc$storage_device_element =
      search_key.value := dmc$search_avt_by_lun;
      search_key.logical_unit_number := element_entry_p^.logical_unit_number;
      cmp$search_active_volume_table (search_key, recorded_vsn, not_found);
      IF not_found THEN
        recorded_vsn := '      ';
      IFEND;

      size := STRLENGTH (element_entry_p^.product_id.product_number);
      temp_str.value (1, size) := element_entry_p^.product_id.product_number;
      temp_str.size := size;

      size := STRLENGTH (element_entry_p^.product_id.underscore);
      temp_str.value (temp_str.size + 1, size) := element_entry_p^.product_id.underscore;
      temp_str.size := temp_str.size + size;

      size := STRLENGTH (element_entry_p^.product_id.model_number);
      temp_str.value (temp_str.size + 1, size) := element_entry_p^.product_id.model_number;
      temp_str.size := temp_str.size + size;

      set_string_length (temp_str);

      PUSH parameters: [1 .. 4];
      parameters^ [1] := ^element_definition.element_name;
      parameters^ [2] := ^temp_str.value (1, temp_str.size);
      parameters^ [3] := ^element_definition.serial_number;
      parameters^ [4] := ^recorded_vsn;

      emit_operator_message (cmc$action_messages, 'UNIT_DISABLED                  ', parameters,
            {acknowledgment_allowed} TRUE, status);
    ELSE
    CASEND;

    IF NOT status.normal THEN
      osp$system_error ('emit_operator_message_failed.', ^status);
    IFEND;

  PROCEND display_disable_menu;

?? TITLE := 'emit_disable_connection_stat', EJECT ??

  {
  { PURPOSE:
  {   This procedure will construct the descriptive data portion for  a
  {   cml$connection_disabled statistic and send the statistic to the
  {   engineering log.
  {

  PROCEDURE emit_disable_connection_stat
    (    upline_element_entry_p: ^cmt$peripheral_element_entry;
         downline_element_entry_p: ^cmt$peripheral_element_entry;
         connection_label: ost$string;
         failing_element_name: cmt$element_name;
     VAR status: ost$status);

    VAR
      channel_name: cmt$element_name,
      channel_ordinal: cmt$channel_ordinal,
      index: 0 .. 256,
      iou_name: cmt$element_name,
      logical_pp: iot$pp_number,
      mainframe_id: pmt$mainframe_id,
      pp_string: string (10),
      size: integer,
      str: ost$string,
      temp_str: ost$string,
      unit_address: cmt$physical_address,
      valid_channel_name: boolean;

    status.normal := TRUE;
    index := 1;

    temp_str := connection_label;
    str.value (index, temp_str.size) := temp_str.value (1, temp_str.size);
    index := index + temp_str.size;

    str.value (index) := ',';
    index := index + 1;

    temp_str.value := ' ';
    temp_str.value := failing_element_name;
    set_string_length (temp_str);
    str.value (index, temp_str.size) := temp_str.value (1, temp_str.size);
    index := index + temp_str.size;

    str.value (index) := ',';
    index := index + 1;

    pmp$get_mainframe_id (mainframe_id, status);
    temp_str.value := mainframe_id;
    set_string_length (temp_str);
    str.value (index, temp_str.size) := temp_str.value (1, temp_str.size);
    index := index + temp_str.size;

    str.value (index) := '.';
    index := index + 1;

    unit_address := downline_element_entry_p^.physical_descriptor.unit_path^ [1];
    cmp$convert_iou_number (unit_address.iou, iou_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cmp$convert_channel_number (unit_address.channel.number, unit_address.channel.concurrent,
          unit_address.channel.port, channel_ordinal, channel_name, valid_channel_name);
    cmp$return_logical_pp_number (channel_name, iou_name, logical_pp, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    temp_str.value := iou_name;
    set_string_length (temp_str);
    str.value (index, temp_str.size) := temp_str.value (1, temp_str.size);
    index := index + temp_str.size;

    str.value (index) := '.';
    index := index + 1;

    STRINGREP (pp_string, size, logical_pp);
    IF unit_address.channel.concurrent THEN
      temp_str.value := 'CPP ';
      temp_str.value (4, * ) := pp_string (2, * );
    ELSE
      temp_str.value := 'PP ';
      temp_str.value (3, * ) := pp_string (2, * );
    IFEND;
    set_string_length (temp_str);
    str.value (index, temp_str.size) := temp_str.value (1, temp_str.size);
    index := index + temp_str.size;

    str.value (index) := '.';
    index := index + 1;

    temp_str.value := channel_name;
    set_string_length (temp_str);
    str.value (index, temp_str.size) := temp_str.value (1, temp_str.size);
    index := index + temp_str.size;

    str.value (index) := '.';
    index := index + 1;

    IF unit_address.address_specifier <> cmv$hydra_mass_storage_address THEN
      temp_str.value := upline_element_entry_p^.element_name;
      set_string_length (temp_str);
      str.value (index, temp_str.size) := temp_str.value (1, temp_str.size);
      index := index + temp_str.size;

      str.value (index) := '.';
      index := index + 1;
    IFEND;

    temp_str.value := downline_element_entry_p^.element_name;
    set_string_length (temp_str);
    str.value (index, temp_str.size) := temp_str.value (1, temp_str.size);
    index := index + temp_str.size;

    str.value(index, 20) := '*CONNECTION DISABLED';
    index := index + 20;

    str.size := index - 1;

    {pmp$log ('Emit connection disabled statistic.', status);
    {pmp$log (str.value (1, str.size), status);

    sfp$emit_statistic (cml$connection_disabled, str.value (1, str.size), NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND emit_disable_connection_stat;

?? TITLE := 'emit_disable_element_statistic', EJECT ??

  {
  { PURPOSE:
  {   This procedure will construct the descriptive data portion for a
  {   cml$element_disabled statistic and send the statistic to the
  {   engineering log.
  {

  PROCEDURE emit_disable_element_statistic
    (    element_entry_p: ^cmt$peripheral_element_entry;
     VAR status: ost$status);

    VAR
      temp_str: ost$string,
      index: 0 .. 256,
      mainframe_id: pmt$mainframe_id,
      size: 0 .. 256,
      str: ost$string;

    status.normal := TRUE;
    index := 1;

    pmp$get_mainframe_id (mainframe_id, status);
    str.value := mainframe_id;
    temp_str.value := mainframe_id;

    set_string_length (temp_str);
    str.value (index, temp_str.size) := temp_str.value (1, temp_str.size);
    index := index + temp_str.size;

    str.value (index) := '.';
    index := index + 1;

    IF element_entry_p^.physical_descriptor.element_type = cmc$data_channel_element THEN
      CASE element_entry_p^.physical_descriptor.channel_path.iou OF
      = 0 =
        temp_str.value (1, 5) := 'IOU0/';
      = 1 =
        temp_str.value (1, 5) := 'IOU1/';
      ELSE
      CASEND;
      temp_str.value(6,*) := element_entry_p^.element_name;
    ELSE
      temp_str.value := element_entry_p^.element_name;
    IFEND;
    set_string_length (temp_str);
    str.value (index, temp_str.size) := temp_str.value (1, temp_str.size);
    index := index + temp_str.size;

    str.value (index) := '*';
    index := index + 1;

    IF element_entry_p^.physical_descriptor.element_type <> cmc$data_channel_element THEN
      temp_str.value := ' ';
      size := STRLENGTH (element_entry_p^.product_id.product_number);
      temp_str.value (1, size) := element_entry_p^.product_id.product_number;
      temp_str.size := size;

      size := STRLENGTH (element_entry_p^.product_id.underscore);
      temp_str.value (temp_str.size + 1, size) := element_entry_p^.product_id.underscore;
      temp_str.size := temp_str.size + size;

      size := STRLENGTH (element_entry_p^.product_id.model_number);
      temp_str.value (temp_str.size + 1, size) := element_entry_p^.product_id.model_number;
      temp_str.size := temp_str.size + size;

      set_string_length (temp_str);

      str.value (index, temp_str.size) := temp_str.value (1, temp_str.size);
      index := index + temp_str.size;
    IFEND;

    str.value (index) := '*';
    index := index + 1;

    IF element_entry_p^.physical_descriptor.element_type <> cmc$data_channel_element THEN
      temp_str.value := element_entry_p^.serial_number;
      set_string_length (temp_str);
      str.value (index, temp_str.size) := temp_str.value (1, temp_str.size);
      index := index + temp_str.size;
    IFEND;

    str.value(index, 17) := '*ELEMENT DISABLED';
    index := index + 17;

    str.size := index - 1;

    {pmp$log ('Emit element disabled statistic.', status);
    {pmp$log (str.value (1, str.size), status);

    sfp$emit_statistic (cml$element_disabled, str.value (1, str.size), NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND emit_disable_element_statistic;

?? TITLE := 'emit_operator_message', EJECT ??

  {
  { PURPOSE:
  {   This procedure will format and send an operator message defined
  {   in the cmm$action_messages help module.  If the acknowledgment_allowed
  {   parameter is set to TRUE it will wait in ofp$receive_operator_response
  {   until the operator_action_message is acknowledged via the
  {   ACKNOWLEDGE_OPERATOR_MESSAGE command. If the interface is called prior
  {   to system commit the formatted message will be written directly to the
  {   system console.
  {

  PROCEDURE emit_operator_message
    (    seed_name: pmt$program_name;
         message_name: clt$parameter_name;
         message_parameters: ^ost$message_parameters;
         acknowledgement_allowed: boolean;
     VAR status: ost$status);

    VAR
      formatted_message: oft$formatted_operator_message,
      line_count: oft$number_of_displayable_lines,
      local_status: ost$status,
      message: ost$status_message,
      operator_response: ost$string;

    status.normal := TRUE;

    osp$get_parameter_prompt (seed_name, message_name, message_parameters, {max_message_line} 80, message,
          status);
    IF status.normal THEN
      ofp$format_operator_message (message, 1, formatted_message, line_count);
      IF line_count = 0 THEN
        RETURN;
      IFEND;

      ofp$send_formatted_operator_msg (formatted_message, ofc$system_operator, acknowledgement_allowed,
            status);
      WHILE NOT status.normal AND (status.condition = ofe$max_job_operator_messages) DO
        pmp$long_term_wait (1000, 1000);
        ofp$send_formatted_operator_msg (formatted_message, ofc$system_operator, acknowledgement_allowed,
              status);
      WHILEND;
      IF status.normal THEN
        ofp$receive_operator_response (ofc$system_operator, osc$wait, operator_response, status);
        IF status.normal THEN
          ofp$clear_operator_message (ofc$system_operator, local_status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND emit_operator_message;
?? TITLE := 'find_active_path', EJECT ??
  {
  { PURPOSE:
  {   This procedure will search the unit descriptors in the logical_pp_table
  {   to locate an active entry for logical_unit specified.  If an active entry is
  {   found the physical_address of the active path is returned.
  {

  PROCEDURE find_active_path
    (    logical_unit_number: iot$logical_unit;
     VAR active_path: cmt$physical_address;
     VAR found: boolean);

    VAR
      logical_unit: iot$logical_unit,
      pp: iot$pp_number,
      ppit_p: ^iot$pp_interface_table,
      unit_desc: iot$unit_descriptor_entry;

    found := FALSE;

  /search_logical_pp_table/
    FOR pp := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
      IF NOT cmv$logical_pp_table_p^ [pp].flags.configured THEN
        CYCLE /search_logical_pp_table/;
      IFEND;

      ppit_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;

      IF (logical_unit_number < LOWERBOUND (ppit_p^.unit_descriptors)) OR
            (logical_unit_number > UPPERBOUND (ppit_p^.unit_descriptors)) THEN
        CYCLE /search_logical_pp_table/;
      IFEND;

      unit_desc := ppit_p^.unit_descriptors [logical_unit_number];
      IF unit_desc.unit_interface_table = NIL THEN
        CYCLE /search_logical_pp_table/;
      IFEND;

      IF unit_desc.unit_interface_table_rma = 0 THEN
        CYCLE /search_logical_pp_table/;
      IFEND;

      IF unit_desc.unit_interface_table^.unit_status.disabled THEN
        CYCLE /search_logical_pp_table/;
      IFEND;

      IF unit_desc.logical_unit = logical_unit_number THEN
        found := TRUE;
        active_path.address_specifier := cmv$mass_storage_address;
        active_path.iou := cmv$logical_pp_table_p^ [pp].pp_info.channel.iou_number;
        active_path.channel.number := unit_desc.physical_path.channel_number;
        active_path.channel.concurrent := cmv$logical_pp_table_p^ [pp].pp_info.channel_interlock_p^.
              channel_characteristics [active_path.channel.number].concurrent_channel;
        active_path.channel.port := cmc$unspecified_port;
        IF active_path.channel.concurrent THEN
          IF (cmv$logical_pp_table_p^ [pp].controller_info.controller_type = cmc$mshydra_ct) OR
                (cmv$logical_pp_table_p^ [pp].controller_info.controller_type = cmc$ms5831_x) OR
                (cmv$logical_pp_table_p^ [pp].controller_info.controller_type = cmc$mscm3_ct) THEN
            CASE unit_desc.physical_path.port OF
            = 0 =
              active_path.channel.port := cmc$port_a;
            = 1 =
              active_path.channel.port := cmc$port_b;
            ELSE
            CASEND;
          IFEND;
        IFEND;
        active_path.channel_address := unit_desc.physical_path.controller_number;
        active_path.unit_address := unit_desc.physical_path.physical_unit_number;
        RETURN;
      IFEND;
    FOREND /search_logical_pp_table/;

  PROCEND find_active_path;

?? TITLE := 'find_enabled_paths', EJECT ??
{
{ PURPOSE:
{   This procedure will determine which units have been reconfigured
{   away from and return a list of the active path(s) that now service those
{   units.  The physical_address input to this procedure can contain either a
{   channel address or a controller address.  All units serviced by the
{   specified element are checked to determine the current active path.  For a
{   channel, all downline connections from the channel are disabled and therefore
{   all disabled downline controllers are searched for units that have been
{   assigned a new active path. For a controller only the controller specified
{   will be searched. If the disabled path is found prior to the active path in
{   the list of unit addresses in the unit's peripheral_element_table_entry we
{   will assume this element has just been reconfigured.  The controller portion
{   of the new active path for each unit is saved and returned to the caller, with
{   duplicate entries removed.
{

  PROCEDURE find_enabled_paths
    (    downline_address: cmt$physical_address;
         channel_element_entry_p: ^cmt$peripheral_element_entry;
     VAR enabled_path_p: ^array [ * ] of cmt$physical_address;
     VAR enabled_path_count: integer);

    VAR
      controller_address: cmt$physical_address,
      controller_element_entry_p: ^cmt$peripheral_element_entry,
      disabled_address: cmt$physical_address,
      disabled_address_found: boolean,
      enabled_address: cmt$physical_address,
      enabled_path_index: integer,
      found: boolean,
      i: integer,
      j: integer,
      k: integer,
      unit_address: cmt$physical_address,
      unit_element_entry_p: ^cmt$peripheral_element_entry;

    enabled_path_count := 0;
    disabled_address := downline_address;
    disabled_address.address_specifier := cmv$controller_address;

  /controller_loop/
    FOR i := LOWERBOUND (channel_element_entry_p^.physical_descriptor.channel_connection^)
          TO UPPERBOUND (channel_element_entry_p^.physical_descriptor.channel_connection^) DO
      IF downline_address.address_specifier = cmv$data_channel_address THEN
        IF channel_element_entry_p^.physical_descriptor.channel_connection^ [i].status <> cmc$disabled THEN
          CYCLE /controller_loop/;
        IFEND;
      IFEND;

      cmp$get_element_entry_via_name (channel_element_entry_p^.physical_descriptor.channel_connection^ [i].
            downline_element, {iou_number} 0, controller_element_entry_p);
      IF controller_element_entry_p = NIL THEN
        CYCLE /controller_loop/;
      IFEND;

      disabled_address.channel_address := controller_element_entry_p^.physical_descriptor.equipment_path^ [1].
            channel_address;

      {
      { If the downline element specified was a controller element we will only
      { look at units connected to that controller.  If the downline element
      { was a channel all disabled controllers will be searched.
      {
      IF (downline_address.address_specifier = cmv$controller_address) AND
            (disabled_address <> downline_address) THEN
        CYCLE /controller_loop/;
      IFEND;

    /unit_loop/
      FOR j := LOWERBOUND (controller_element_entry_p^.physical_descriptor.equipment_connection^)
            TO UPPERBOUND (controller_element_entry_p^.physical_descriptor.equipment_connection^) DO
        IF downline_address.address_specifier = cmv$data_channel_address THEN
          {
          { Only look at active connections of controllers when the input element is a channel.
          {
          IF controller_element_entry_p^.physical_descriptor.equipment_connection^ [j].status <>
                cmc$active THEN
            CYCLE /unit_loop/;
          IFEND;
        ELSEIF downline_address.address_specifier = cmv$controller_address THEN
          {
          { Only look at disabled connections of controllers when the input element is a controller.
          {
          IF controller_element_entry_p^.physical_descriptor.equipment_connection^ [j].status <>
                cmc$disabled THEN
            CYCLE /unit_loop/;
          IFEND;
        ELSE
          RETURN;
        IFEND;

        cmp$get_element_entry_via_name (controller_element_entry_p^.physical_descriptor.
              equipment_connection^ [j].downline_element, {iou_number} 0, unit_element_entry_p);
        IF unit_element_entry_p = NIL THEN
          RETURN;
        IFEND;

        find_active_path (unit_element_entry_p^.logical_unit_number, enabled_address, found);
        IF NOT found THEN
          CYCLE /unit_loop/;
        IFEND;

        disabled_address_found := FALSE;

      /path_loop/
        FOR k := LOWERBOUND (unit_element_entry_p^.physical_descriptor.unit_path^)
              TO UPPERBOUND (unit_element_entry_p^.physical_descriptor.unit_path^) DO
          unit_address := unit_element_entry_p^.physical_descriptor.unit_path^ [k];
          controller_address := unit_address;
          controller_address.address_specifier := cmv$controller_address;
          controller_address.unit_address := 0;

          IF controller_address = disabled_address THEN
            disabled_address_found := TRUE;
          IFEND;

          IF unit_address = enabled_address THEN
            IF disabled_address_found THEN
              FOR enabled_path_index := LOWERBOUND (enabled_path_p^) TO enabled_path_count DO
                IF enabled_path_p^ [enabled_path_index] = controller_address THEN
                  CYCLE /unit_loop/;
                IFEND;
              FOREND;
              enabled_path_count := enabled_path_count + 1;
              enabled_path_p^ [enabled_path_count] := controller_address;
            IFEND;
          IFEND;
        FOREND /path_loop/;
      FOREND /unit_loop/;
    FOREND /controller_loop/;
  PROCEND find_enabled_paths;

?? TITLE := 'process_das_head_shift_signal', EJECT ??
  {
  { PURPOSE:
  {   This procedure extracts the information from a signal and
  {   calls several CM interfaces to obtain the element_definition for
  {   the disabled element. The routine to format and display the
  {   information is then called.  A engineering log statistic is
  {   constructed and sent to the engineering log.
  {

  PROCEDURE process_das_head_shift_signal
    (    signal_contents: cmt$signal_contents;
     VAR status: ost$status);

    VAR
      element_definition_p: ^cmt$element_definition,
      element_entry_p: ^cmt$peripheral_element_entry,
      element_name: cmt$element_name,
      iou_name: cmt$element_name,
      local_status: ost$status;

    VAR
      not_found: boolean,
      parameters: ^ost$message_parameters,
      product_id_str: ost$name,
      recorded_vsn: rmt$recorded_vsn,
      search_key: dmt$avt_search_key,
      size: ost$string_size,
      temp_str: ost$string;

    cmp$get_element_entry_via_lun (signal_contents.hd_shift_logical_unit, element_entry_p);
    IF element_entry_p = NIL THEN
      local_status.normal := FALSE;
      osp$system_error ('cmp$get_element_entry_via_lun unable to locate element.', ^local_status);
    IFEND;

    element_name := element_entry_p^.element_name;

      temp_str.value := ' ';

      size := STRLENGTH (element_entry_p^.product_id.product_number);
      temp_str.value (1, size) := element_entry_p^.product_id.product_number;
      temp_str.size := size;

      size := STRLENGTH (element_entry_p^.product_id.underscore);
      temp_str.value (temp_str.size + 1, size) := element_entry_p^.product_id.underscore;
      temp_str.size := temp_str.size + size;

      size := STRLENGTH (element_entry_p^.product_id.model_number);
      temp_str.value (temp_str.size + 1, size) := element_entry_p^.product_id.model_number;
      temp_str.size := temp_str.size + size;

      set_string_length (temp_str);
      product_id_str := temp_str.value (1, temp_str.size);

      temp_str.value := ' ';

      search_key.value := dmc$search_avt_by_lun;
      search_key.logical_unit_number := element_entry_p^.logical_unit_number;
      cmp$search_active_volume_table (search_key, recorded_vsn, not_found);
      IF not_found THEN
        recorded_vsn := '      ';
      IFEND;

      clp$convert_integer_to_string(signal_contents.hd_shift_physical_unit, {radix} 16, TRUE,
            temp_str, status);

      PUSH parameters: [1 .. 4];
      parameters^ [1] := ^element_name;
      parameters^ [2] := ^product_id_str;
      parameters^ [3] := ^recorded_vsn;
      parameters^ [4] := ^temp_str.value (1, temp_str.size);

      emit_operator_message (cmc$action_messages, 'DAS_DRIVE_HEAD_SHIFT_WARNING   ', parameters,
            {acknowledgment_allowed} TRUE, status);

    IF NOT status.normal THEN
      osp$system_error ('emit_operator_message_failed.', ^status);
    IFEND;

  PROCEND process_das_head_shift_signal;

?? TITLE := 'process_disable_signal', EJECT ??
  {
  { PURPOSE:
  {   This procedure extracts the information from a signal and
  {   calls several CM interfaces to obtain the element_definition for
  {   the disabled element. The routine to format and display the
  {   information is then called.  A engineering log statistic is
  {   constructed and sent to the engineering log.
  {

  PROCEDURE process_disable_signal
    (    signal_contents: cmt$signal_contents;
     VAR status: ost$status);

    VAR
      element_definition_p: ^cmt$element_definition,
      element_entry_p: ^cmt$peripheral_element_entry,
      iou_name: cmt$element_name,
      local_status: ost$status;


    cmp$get_element_entry_via_adr (signal_contents.disable_element_address, element_entry_p);
    IF element_entry_p = NIL THEN
      local_status.normal := FALSE;
      osp$system_error ('cmp$get_element_entry_via_adr unable to locate element.', ^local_status);
    IFEND;

    cmp$convert_iou_number (signal_contents.disable_element_address.iou, iou_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH element_definition_p;
    cmp$get_element_r3 (element_entry_p^.element_name, iou_name, element_definition_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_disable_menu (element_definition_p^, element_entry_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    emit_disable_element_statistic (element_entry_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND process_disable_signal;

?? TITLE := 'process_down_element_signal', EJECT ??
  {
  { PURPOSE:
  {   This procedure extracts the information from a signal and
  {   calls several CM interfaces to obtain the element_definition for
  {   the downed element. The interface to perform the actual state change
  {   is called.
  {

  PROCEDURE process_down_element_signal
    (    signal_contents: cmt$signal_contents;
     VAR status: ost$status);

    VAR
      element_definition_p: ^cmt$element_definition,
      element_descriptor: cmt$element_descriptor,
      element_entry_p: ^cmt$peripheral_element_entry,
      element_info: array [1 .. 2] of cmt$element_info_item,
      iou_name: cmt$element_name,
      local_status: ost$status,
      tape_element: boolean;

    cmp$get_element_entry_via_adr (signal_contents.down_element_address, element_entry_p);
    IF element_entry_p = NIL THEN
      local_status.normal := FALSE;
      osp$system_error ('cmp$get_element_entry_via_adr unable to locate element.', ^local_status);
    IFEND;

    cmp$convert_iou_number (signal_contents.down_element_address.iou, iou_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH element_definition_p;
    cmp$get_element_r3 (element_entry_p^.element_name, iou_name, element_definition_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    element_descriptor.element_type := element_definition_p^.element_type;

    CASE element_descriptor.element_type OF
    = cmc$data_channel_element =
      element_descriptor.channel_descriptor.iou := iou_name;
      element_descriptor.channel_descriptor.use_logical_identification := TRUE;
      element_descriptor.channel_descriptor.name := element_entry_p^.element_name;

    = cmc$channel_adapter_element, cmc$communications_element, cmc$controller_element,
          cmc$external_processor_element, cmc$storage_device_element =
      element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
      element_descriptor.peripheral_descriptor.element_name := element_entry_p^.element_name;

    = cmc$central_processor_element =
      element_descriptor.name := element_entry_p^.element_name;
    ELSE
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_not_available,
            'Invalid state change request for given element type', status);
      RETURN;
    CASEND;

    cmp$determine_tape_element (element_descriptor, tape_element);

    element_info [1].selector := cmc$system_critical_element;
    element_info [2].selector := cmc$element_status;
    cmp$get_element_information (element_descriptor, element_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$process_state_change (tape_element, {clear_lock_behind} FALSE, {system_call} TRUE, element_descriptor,
          element_info [1].system_critical_element, element_info [2].element_status.state, cmc$down, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND process_down_element_signal;

?? TITLE := 'process_overtemp_signal', EJECT ??
  {
  { PURPOSE:
  {   This procedure extracts the information from a signal and
  {   calls several CM interfaces to obtain the element_definition for
  {   the disabled element. The routine to format and display the
  {   information is then called.  A engineering log statistic is
  {   constructed and sent to the engineering log.
  {

  PROCEDURE process_overtemp_signal
    (    signal_contents: cmt$signal_contents;
     VAR status: ost$status);

    VAR
      element_definition_p: ^cmt$element_definition,
      element_entry_p: ^cmt$peripheral_element_entry,
      element_name: cmt$element_name,
      iou_name: cmt$element_name,
      local_status: ost$status;
    VAR
      not_found: boolean,
      parameters: ^ost$message_parameters,
      product_id_str: ost$name,
      recorded_vsn: rmt$recorded_vsn,
      search_key: dmt$avt_search_key,
      size: ost$string_size,
      temp_str: ost$string;


    cmp$get_element_entry_via_adr (signal_contents.overtemp_element_address, element_entry_p);
    IF element_entry_p = NIL THEN
      local_status.normal := FALSE;
      osp$system_error ('cmp$get_element_entry_via_adr unable to locate element.', ^local_status);
    IFEND;

    cmp$convert_iou_number (signal_contents.disable_element_address.iou, iou_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH element_definition_p;
    cmp$get_element_r3 (element_entry_p^.element_name, iou_name, element_definition_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
      element_name := element_entry_p^.element_name;
      PUSH parameters: [1 .. 1];
      parameters^ [1] := ^element_name;

      emit_operator_message (cmc$action_messages, 'CONTROLLER_OVERTEMP            ', parameters,
            {acknowledgment_allowed} TRUE, status);

    IF NOT status.normal THEN
      osp$system_error ('emit_operator_message_failed.', ^status);
    IFEND;

  PROCEND process_overtemp_signal;

?? TITLE := 'process_parity_disabled_signal', EJECT ??
  {
  { PURPOSE:
  {   This procedure extracts the information from a signal and
  {   calls several CM interfaces to obtain the element_definition for
  {   the disabled element. The routine to format and display the
  {   information is then called.  A engineering log statistic is
  {   constructed and sent to the engineering log.
  {

  PROCEDURE process_parity_disabled_signal
    (    signal_contents: cmt$signal_contents;
     VAR status: ost$status);

    VAR
      element_definition_p: ^cmt$element_definition,
      element_entry_p: ^cmt$peripheral_element_entry,
      element_name: cmt$element_name,
      iou_name: cmt$element_name,
      local_status: ost$status;

    VAR
      not_found: boolean,
      parameters: ^ost$message_parameters,
      product_id_str: ost$name,
      recorded_vsn: rmt$recorded_vsn,
      search_key: dmt$avt_search_key,
      size: ost$string_size,
      temp_str: ost$string;

    cmp$get_element_entry_via_lun (signal_contents.parity_logical_unit, element_entry_p);
    IF element_entry_p = NIL THEN
      local_status.normal := FALSE;
      osp$system_error ('cmp$get_element_entry_via_lun unable to locate element.', ^local_status);
    IFEND;

    element_name := element_entry_p^.element_name;

      temp_str.value := ' ';

      size := STRLENGTH (element_entry_p^.product_id.product_number);
      temp_str.value (1, size) := element_entry_p^.product_id.product_number;
      temp_str.size := size;

      size := STRLENGTH (element_entry_p^.product_id.underscore);
      temp_str.value (temp_str.size + 1, size) := element_entry_p^.product_id.underscore;
      temp_str.size := temp_str.size + size;

      size := STRLENGTH (element_entry_p^.product_id.model_number);
      temp_str.value (temp_str.size + 1, size) := element_entry_p^.product_id.model_number;
      temp_str.size := temp_str.size + size;

      set_string_length (temp_str);
      product_id_str := temp_str.value (1, temp_str.size);

      temp_str.value := ' ';

      search_key.value := dmc$search_avt_by_lun;
      search_key.logical_unit_number := element_entry_p^.logical_unit_number;
      cmp$search_active_volume_table (search_key, recorded_vsn, not_found);
      IF not_found THEN
        recorded_vsn := '      ';
      IFEND;

      clp$convert_integer_to_string(signal_contents.parity_physical_unit, {radix} 16, TRUE,
            temp_str, status);

      PUSH parameters: [1 .. 4];
      parameters^ [1] := ^element_name;
      parameters^ [2] := ^product_id_str;
      parameters^ [3] := ^recorded_vsn;
      parameters^ [4] := ^temp_str.value (1, temp_str.size);

      emit_operator_message (cmc$action_messages, 'PARITY_PROTECTION_DISABLED     ', parameters,
            {acknowledgment_allowed} TRUE, status);

    IF NOT status.normal THEN
      osp$system_error ('emit_operator_message_failed.', ^status);
    IFEND;

  PROCEND process_parity_disabled_signal;

?? TITLE := 'process_reconfig_signal', EJECT ??
  {
  { PURPOSE:
  {   This procedure extracts the information from a signal and
  {   calls several CM interfaces to obtain the element_definition for
  {   the reconfigured element. Information describing which connection
  {   and/or path has been disabled and which paths have been enabled
  {   is generated and placed in a parameter list.  The routine to format
  {   and display the information is then called.  A engineering statistic
  {   is generated and sent to the engineering log.
  {

  PROCEDURE process_reconfig_signal
    (    signal_contents: cmt$signal_contents;
     VAR status: ost$status);

    VAR
      channel_element_entry_p: ^cmt$peripheral_element_entry,
      connection_label: ost$string,
      controller_element_entry_p: ^cmt$peripheral_element_entry,
      disabled_path: ost$string,
      downline_element_address: cmt$physical_address,
      downline_element_entry_p: ^cmt$peripheral_element_entry,
      enabled_address: cmt$physical_address,
      enabled_path: ost$string,
      enabled_path_adr_list_p: ^array [ * ] of cmt$physical_address,
      enabled_path_count: integer,
      enabled_path_str_list_p: ^array [ * ] of ost$string,
      element_definition_p: ^cmt$element_definition,
      element_descriptor: cmt$element_descriptor,
      element_entry: cmt$peripheral_element_entry,
      found: boolean,
      i: integer,
      iou_name: cmt$element_name,
      local_status: ost$status,
      lun_count: integer,
      parameters: ^ost$message_parameters,
      performance_impact: string(50),
      upline_element_address: cmt$physical_address,
      upline_element_entry_p: ^cmt$peripheral_element_entry;

    performance_impact := ' ';
    downline_element_address := signal_contents.reconfig_element_address;
    cmp$get_element_entry_via_adr (downline_element_address, downline_element_entry_p);
    IF downline_element_entry_p = NIL THEN
      local_status.normal := FALSE;
      osp$system_error ('cmp$get_element_entry_via_adr unable to locate element.', ^local_status);
    IFEND;

    cmp$convert_iou_number (signal_contents.reconfig_element_address.iou, iou_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE downline_element_entry_p^.physical_descriptor.element_type OF
    = cmc$data_channel_element =
      build_path (downline_element_address, disabled_path);

      enabled_path_count := 4;
      REPEAT
        PUSH enabled_path_adr_list_p: [1 .. enabled_path_count];
        find_enabled_paths (downline_element_address, downline_element_entry_p, enabled_path_adr_list_p,
              enabled_path_count);
      UNTIL enabled_path_count <= UPPERBOUND (enabled_path_adr_list_p^);

      PUSH parameters: [1 .. 6];
      parameters^ [1] := ^disabled_path.value (1, disabled_path.size);

      PUSH enabled_path_str_list_p: [1 .. enabled_path_count];

      FOR i := 1 TO 4 DO
        IF i <= enabled_path_count THEN
          build_path (enabled_path_adr_list_p^ [i], enabled_path_str_list_p^ [i]);
          parameters^ [i + 1] := ^enabled_path_str_list_p^[i].value (1, enabled_path_str_list_p^[i].size);
        ELSE
          parameters^ [i + 1] := NIL;
        IFEND;
      FOREND;

      parameters^ [6] := NIL;  {performance imapct }

      emit_operator_message (cmc$action_messages, 'RECONFIGURE_CHANNEL            ', parameters,
            {acknowledgment_allowed} TRUE, status);

      emit_disable_element_statistic (downline_element_entry_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    = cmc$controller_element =
      upline_element_address := downline_element_address;
      upline_element_address.address_specifier := cmv$data_channel_address;
      upline_element_address.channel_address := 0;

      cmp$get_element_entry_via_adr (upline_element_address, upline_element_entry_p);
      IF upline_element_entry_p = NIL THEN
        local_status.normal := FALSE;
        osp$system_error ('cmp$get_element_entry_via_adr unable to locate element.', ^local_status);
      IFEND;

      build_path (downline_element_address, disabled_path);

      enabled_path_count := 4;
      REPEAT
        PUSH enabled_path_adr_list_p: [1 .. enabled_path_count];
        find_enabled_paths (downline_element_address, upline_element_entry_p, enabled_path_adr_list_p,
              enabled_path_count);
      UNTIL enabled_path_count <= UPPERBOUND (enabled_path_adr_list_p^);

      PUSH parameters: [1 .. 6];
      parameters^ [1] := ^disabled_path.value (1, disabled_path.size);

      PUSH enabled_path_str_list_p: [1 .. enabled_path_count];

      FOR i := 1 TO 4 DO
        IF i <= enabled_path_count THEN
          build_path (enabled_path_adr_list_p^ [i], enabled_path_str_list_p^ [i]);
          parameters^ [i + 1] := ^enabled_path_str_list_p^[i].value (1, enabled_path_str_list_p^[i].size);
        ELSE
          parameters^ [i + 1] := NIL;
        IFEND;
      FOREND;

      parameters^ [6] := NIL;  {performance imapct }

      emit_operator_message (cmc$action_messages, 'RECONFIGURE_CONTROLLER         ', parameters,
            {acknowledgment_allowed} TRUE, status);

      emit_disable_element_statistic (downline_element_entry_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    = cmc$storage_device_element =
      upline_element_address := downline_element_address;
      upline_element_address.address_specifier := cmv$controller_address;
      upline_element_address.unit_address := 0;

      cmp$get_element_entry_via_adr (upline_element_address, upline_element_entry_p);
      IF upline_element_entry_p = NIL THEN
        local_status.normal := FALSE;
        osp$system_error ('cmp$get_element_entry_via_adr unable to locate element.', ^local_status);
      IFEND;

      build_connection_label (upline_element_entry_p, downline_element_entry_p, iou_name, connection_label);
      build_path (downline_element_address, disabled_path);

      find_active_path (downline_element_entry_p^.logical_unit_number, enabled_address, found);
      IF found THEN
        build_path (enabled_address, enabled_path);
      ELSE
        enabled_path.value := ' ';
        enabled_path.size := 1;
      IFEND;

      PUSH parameters: [1 .. 4];
      parameters^ [1] := ^connection_label.value (1, connection_label.size);
      parameters^ [2] := ^disabled_path.value (1, disabled_path.size);
      parameters^ [3] := ^enabled_path.value (1, enabled_path.size);
      parameters^ [4] := NIL;  {performance imapct }

      emit_operator_message (cmc$action_messages, 'RECONFIGURE_UNIT               ', parameters,
            {acknowledgment_allowed} TRUE, status);

      IF signal_contents.failing_element_address = downline_element_address THEN
        emit_disable_connection_stat (upline_element_entry_p, downline_element_entry_p, connection_label,
              downline_element_entry_p^.element_name, status);
      ELSE
        emit_disable_connection_stat (upline_element_entry_p, downline_element_entry_p, connection_label,
              upline_element_entry_p^.element_name, status);
      IFEND;

    ELSE
    CASEND;

  PROCEND process_reconfig_signal;

?? TITLE := 'process_ssd_battery_signal', EJECT ??
  {
  { PURPOSE:
  {   This procedure extracts the information from a signal and
  {   calls several CM interfaces to obtain the element_definition for
  {   the disabled element. The routine to format and display the
  {   information is then called.  A engineering log statistic is
  {   constructed and sent to the engineering log.
  {

  PROCEDURE process_ssd_battery_signal
    (    signal_contents: cmt$signal_contents;
     VAR status: ost$status);

    VAR
      element_definition_p: ^cmt$element_definition,
      element_entry_p: ^cmt$peripheral_element_entry,
      element_name: cmt$element_name,
      iou_name: cmt$element_name,
      local_status: ost$status;

    VAR
      battery_condition: 0 .. 0ffff(16),
      battery_condition_str: string(31),
      not_found: boolean,
      parameters: ^ost$message_parameters,
      product_id_str: ost$name,
      recorded_vsn: rmt$recorded_vsn,
      search_key: dmt$avt_search_key,
      size: ost$string_size,
      temp_str: ost$string;

    cmp$get_element_entry_via_lun (signal_contents.hd_shift_logical_unit, element_entry_p);
    IF element_entry_p = NIL THEN
      local_status.normal := FALSE;
      osp$system_error ('cmp$get_element_entry_via_lun unable to locate element.', ^local_status);
    IFEND;

    element_name := element_entry_p^.element_name;

      temp_str.value := ' ';

      size := STRLENGTH (element_entry_p^.product_id.product_number);
      temp_str.value (1, size) := element_entry_p^.product_id.product_number;
      temp_str.size := size;

      size := STRLENGTH (element_entry_p^.product_id.underscore);
      temp_str.value (temp_str.size + 1, size) := element_entry_p^.product_id.underscore;
      temp_str.size := temp_str.size + size;

      size := STRLENGTH (element_entry_p^.product_id.model_number);
      temp_str.value (temp_str.size + 1, size) := element_entry_p^.product_id.model_number;
      temp_str.size := temp_str.size + size;

      set_string_length (temp_str);
      product_id_str := temp_str.value (1, temp_str.size);

      temp_str.value := ' ';

      search_key.value := dmc$search_avt_by_lun;
      search_key.logical_unit_number := element_entry_p^.logical_unit_number;
      cmp$search_active_volume_table (search_key, recorded_vsn, not_found);
      IF not_found THEN
        recorded_vsn := '      ';
      IFEND;

      clp$convert_integer_to_string(signal_contents.hd_shift_physical_unit, {radix} 16, TRUE,
            temp_str, status);

      battery_condition := signal_contents.battery_alert_condition;
      IF battery_condition = ioc$9836_1_ssd_battery_to_low THEN
        battery_condition_str := 'SSD BATTERY TOO LOW FOR BACKUP ';
      ELSEIF battery_condition = ioc$9836_1_ssd_battery_test THEN
        battery_condition_str := 'SSD BATTERY TEST FAILED        ';
      ELSEIF battery_condition = ioc$9836_1_ssd_battery_old THEN
        battery_condition_str := 'SSD BATTERY OLD - REPLACE      ';
      IFEND;

      PUSH parameters: [1 .. 5];
      parameters^ [1] := ^element_name;
      parameters^ [2] := ^product_id_str;
      parameters^ [3] := ^recorded_vsn;
      parameters^ [4] := ^temp_str.value (1, temp_str.size);
      parameters^ [5] := ^battery_condition_str;

      emit_operator_message (cmc$action_messages, 'SSD_BATTERY_ALERT              ', parameters,
            {acknowledgment_allowed} TRUE, status);

    IF NOT status.normal THEN
      osp$system_error ('emit_operator_message_failed.', ^status);
    IFEND;

  PROCEND process_ssd_battery_signal;
?? TITLE := 'set_string_length', EJECT ??

{ PURPOSE:
{   This procedure finds the length of a string that is passed in as a parameter.  It also removes
{   any spaces that are at the beginning and at the end of the string.

  PROCEDURE set_string_length
    (VAR string_data: ost$string);

    VAR
      begin_index: ost$string_size,
      end_index: ost$string_size,
      temp_string: string (osc$max_string_size);

    { If the string is all blank set the string length to one and return.

    IF string_data.value = ' ' THEN
      string_data.size := 1;
      RETURN;
    IFEND;

    { Find the first non-blank character in the string.

    begin_index := 1;
    WHILE (begin_index <= osc$max_string_size) AND (string_data.value (begin_index) = ' ') DO
      begin_index := begin_index + 1;
    WHILEND;

    { Find the last non-blank character in the string.

    end_index := osc$max_string_size;
    WHILE (end_index > begin_index) AND (string_data.value (end_index) = ' ') DO
      end_index := end_index - 1;
    WHILEND;

    { Move the data in the string so the first non-blank character is the first character in the string and
    { determine the size of the string from the first non-blank character to the last non-blank character.

    temp_string := string_data.value;
    string_data.value := temp_string (begin_index, (end_index - begin_index) + 1);
    string_data.size := (end_index - begin_index) + 1;

  PROCEND set_string_length;

MODEND cmm$signal_handler;

*DECK DECK=CMM$SYSDP_HELP_TEXT EXPAND=TRUE
~"  CREATE_MESSAGE_MODULE SYSDP_MESSAGES$US_ENGLISH
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONFIGURATION_ACTIVATED

  All mass storage set members have been activated.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONFIGURATION_INSTALLED

  The physical configuration has been installed.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUATION_DS

  This is a continuation deadstart.
  YOU CANNOT REFERENCE PERMANENT FILES.
  YOU MAY ONLY USE SUBCOMMANDS OF THIS UTILITY.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ENTERING_LCU_BANNER

  ENTERING THE LOGICAL CONFIGURATION UTILITY ...
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ENTERING_PCU_BANNER

  ENTERING THE PHYSICAL CONFIGURATION UTILITY ...
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ENTERING_PCU_ON_ERROR

  Use these subcommands to correct and install the physical configuration:

    EDIT_PHYSICAL_CONFIGURATION
      CHANGE_ELEMENT_DEFINITION
    QUIT
    INSTALL_PHYSICAL_CONFIGURATION
    QUIT

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=EXECUTING_PROLOG

  Executing ~P1 from prolog ~P2.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=INSTALLED_CONFIG_OK

  The most recently installed configuration has been copied to
  the file $local.physical_configuration for you.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=INTERVENTION_DUE_TO_ERROR

  You have just completed an operator intervention to correct a problem with
  the configuration.  Because of the original problem, you may have to perform
  additional reconfiguration.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=INTERVENTION_REQUESTED

  You have requested a pause for operator intervention.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=MISSING_DS_FILE_CONFIG

  You selected to use the configuration from the deadstart file rather than
  the installed configuration.  However, either the deadstart file did not
  contain the file $LOCAL.PHYSICAL_CONFIG or it was empty.  You have the
  following choices:

    1. Redeadstart specifying USE_INSTALLED_CONFIGURATION TRUE.
    2. Redeadstart with a different deadstart file that does contain the
       desired physical configuration.
    3. Continue with this deadstart and manually define the physical
       configuration.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=MISSING_INSTALLED_CONFIG

  The installed physical configuration on the system device is damaged.
  You must either manually define the physical configuration or you must
  redeadstart from a deadstart tape containing the desired physical
  configuration.  To do the latter you must specify the following
  System Core command:

       USE_INSTALLED_CONFIGURATION false.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=NETWORK_COMMANDS_INSTALLED

  The file ~P1 has been installed from
  prolog ~P2.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROLOG_FILE_MISSING

  File ~P1 is empty or was not created by prolog ~P2.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROLOG_LIBRARY_MISSING

  The library $LOCAL.PROLOG_LIBRARY is missing or empty. Therefore,
  configuration prolog procedure ~P1 specified
  by the USE_CONFIGURATION_PROLOG System Core command cannot be executed.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROLOG_PROCEDURE_MISSING

  Configuration prolog procedure ~P1 specified
  by the USE_CONFIGURATION_PROLOG System Core command is not
  defined in library $LOCAL.PROLOG_LIBRARY.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROLOG_SELECTION_INFO

  USE_CONFIGURATION_PROLOG selection:  ~P1
  Configuration prolog to be executed: ~P2
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=REPORT_ERROR

  The following error was detected:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=REPORT_LCU_ERROR

  The following error was reported by the Locical Configuration Utility;
  you must correct this problem now:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=REPORT_MENU_FAULT

  The following error was reported in an attempt to display the
  menu for operator intervention.  Operator intervention is suppressed.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=REPORT_PROLOG_ERROR

  The following error was detected within prolog ~P.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=REPORT_PROLOG_SUPPRESSED

  Execution of the $LOCAL.LCU_MAINFRAME_SUBCOMMANDS suppressed
  due to a system set recovery.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=REPORT_WHEN_FAULT

  The following error was detected in command: ~P1;
  attempting to continue execution:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=UNCONFIGURED_DEADSTART_BANNER

  The file $local.physical_configuration has been created for you.
  This file contains the DEFINE_ELEMENT subcommands for the system
  disk subsystem and the tape subsystem used for this deadstart.

  The element names and serial numbers of these peripherals have been
  invented by NOS/VE; please correct this information now.  The
  following commands are used to correct and install the physical
  configuration:

    EDIT_PHYSICAL_CONFIGURATION
       ADD_ELEMENT_DEFINITION    (for each new peripheral)
       CHANGE_ELEMENT_DEFINITION (to correct serial number)
       CHANGE_ELEMENT_NAME       (to correct element name)
    QUIT
    INSTALL_PHYSICAL_CONFIGURATION
    QUIT

~"**
~"END_MESSAGE_MODULE CREATE_MODULE=YES
~"  CREATE_MESSAGE_MODULE CONTINUATION_DS_MENU$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE

  NOS/VE RECONFIGURATION MENU - ~P2 -

  You have the following choices for reconfiguration:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=INSTALL_CONFIGURATION
    ~P1 - Intervene before installing the physical configuration.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ACTIVATE_VOLUMES
    ~P1 - Intervene before activating existing mass storage set members.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CHANGE_LOGICAL_CONFIGURATION
    ~P1 - Intervene after activating existing mass storage set members.

~"**
~"CREATE_FULL_HELP_MESSAGE
  This phase of deadstart determines the physical and logical
  configurations of the system.

  During this deadstart, you may perform reconfiguration tasks at as many
  as three different steps in the system configuration process.  As each
  step is completed, the corresponding menu selection is removed from
  subsequent menus.

  If you choose to enter GO, the system will automatically install the
  physical configuration and activate mass storage volumes.  You will
  be asked to intervene in this process only if an error is detected.

  If an error is detected, you are informed of the error and asked to
  correct it.  After correcting the error, you are asked if you want
  intervention in any of the remaining steps.

  For help about an individual selection, enter 'n?', where n is the number
  of the selection.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=INSTALL_CONFIGURATION

  If you choose this selection, you may edit the physical configuration
  prior to its installation.  Editing the physical configuration is
  necessary if you:

        - Have recabled peripherals
        - Added or removed peripherals
        - Must change the state (ON, OFF, or DOWN) of a peripheral element
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ACTIVATE_VOLUMES

  Choosing this selection allows you to make changes to your logical
  configuration prior to NOS/VE's activation of mass storage volumes.
  The system device's volume is already active.

  Once a volume is activated, it cannot be initialized until the next
  continuation deadstart; therefore, if you need to initialize an existing
  mass storage set member, you must do so now.

  If you are initializing a volume because an uncorrectable media defect
  prevented the recovery of the volume's files, use the LCU subcommand
  DEFINE_MS_FLAW to define the flaw prior to initializing the volume.

  Because the CHANGE_MS_CLASS and ADD_VOLUME_TO_SET LCU subcommands require
  an active volume, you may only use these subcommands for those volumes
  that you initialize during this intervention.  If the volume does not need
  initialization and you want to use CHAMSC or ADDVTS, select intervention
  after activation of existing set members (the choice following this one in
  the menu).
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CHANGE_LOGICAL_CONFIGURATION

  Choosing this selection allows you to make changes to your logical
  configuration after NOS/VE's activation of mass storage volumes.

  The only restriction during this intervention is that you cannot
  initialize an active volume.  You may, however, initialize a volume
  that is not yet a member of a set or one that is mounted on a mass
  storage device that you turn ON during this intervention.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROMPT
  Enter selection, GO, or ? for HELP.
~"**
~"END_MESSAGE_MODULE CREATE_MODULE=YES
~"  CREATE_MESSAGE_MODULE INSTALLATION_DS_MENU$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE

  NOS/VE RECONFIGURATION MENU - SYSTEM SET INITIALIZATION -

  You have the following choices for reconfiguration:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=INSTALL_CONFIGURATION
    ~P1 - Intervene to change the physical configuration.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ACTIVATE_VOLUMES
    ~P1 - Intervene to change the logical configuration.

~"**
~"CREATE_FULL_HELP_MESSAGE

  During an initialization of the system set, you may perform reconfiguration
  tasks at two different steps in the system configuration process.  As each
  step is completed, the corresponding menu selection is removed from
  subsequent menus.

  If there is a configuration prolog selected and you select intervention,
  the intervention occurs after the applicable commands in the prolog are
  executed.

  If you choose to enter GO, the system will automatically install the
  physical configuration contained on your deadstart file.  Those volumes
  prepared by your configuration prolog are automatically available to you.
  You are asked to intervene in this process if either the deadstart file
  is unconfigured or an error is detected.

  If the deadstart file is unconfigured, you are given the choice to specify
  the configuration or to proceed with a default configuration consisting of
  the system disk and tape peripherals.

  If an error is detected, you are informed of the error and asked to correct
  it.  After correcting the error, you are asked if you want to intervene in
  any remaining configuration steps.

  For help about an individual selection, enter 'n?', where n is the number
  of the selection.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=INSTALL_CONFIGURATION

  If you choose this selection, you may edit the physical configuration
  prior to its installation.  Editing the physical configuration is
  necessary if:

     - The configuration in the deadstart file is out of date.
     - You must change the state (ON, OFF, or DOWN) of a peripheral element.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ACTIVATE_VOLUMES

  Choosing this selection allows you to make changes to your logical
  configuration beyond those made by your configuration prolog.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROMPT
  Enter selection, GO, or ? for HELP.
~"**
~"END_MESSAGE_MODULE CREATE_MODULE=YES
~"  CREATE_MESSAGE_MODULE PCU_SIMULATION_MENU$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE

  You are simulating the operator interaction during deadstart.

  You have had the opportunity to install the physical configuration but
  an error was detected.

  You have the following choices; for HELP enter '1?' or '2?'.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=INSTALL_CONFIGURATION
    ~P1 - Continue to attempt to install the physical configuration.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ACTIVATE_VOLUMES
    ~P1 - Proceed with the deadstart simulation without installing
          the physical configuration.

~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=INSTALL_CONFIGURATION

  If you choose this selection, you may continue to correct the problem
  that prevents the verification of the physical configuration contained
  in file $LOCAL.PHYSICAL_CONFIGURATION.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ACTIVATE_VOLUMES

  If you choose this selection, the simulation of deadstart proceeds
  to execution of the Logical Configuration Utility.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROMPT
  Enter selection or ? for HELP.
~"**
~"END_MESSAGE_MODULE CREATE_MODULE=YES
~"  CREATE_MESSAGE_MODULE UNCONFIGURED_DS_MENU$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE

  The deadstart file is unconfigured.

  You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=INSTALL_DEFAULT
    ~P1 - Install the default physical configuration.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=DEFINE_CONFIGURATION
    ~P1 - Enter the PHYSICAL_CONFIGURATION_UTILITY (PCU) to define and
         install your physical configuration.

~"**
~"CREATE_FULL_HELP_MESSAGE

  The file $LOCAL.PHYSICAL_CONFIG was either missing from the deadstart file
  or it was empty.  This indicates that the deadstart file is an unconfigured
  one.  If this is unexpected, you may want to redeadstart with the correct
  deadstart file; otherwise, choose one of the following selections and
  continue with this deadstart.

  For help about an individual selection, enter 'n?', where n is the number
  of the selection.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=INSTALL_DEFAULT

  Choosing this selection causes NOS/VE to install the physical configuration
  used to deadstart the system.  If your actual physical configuration is
  larger than this, you must:

    - Complete this deadstart.
    - Create a new deadstart file containing your actual physical
      configuration.
    _ Perform a continuation deadstart specifying the value FALSE for the
      USE_INSTALLED_CONFIGURATION (USEIC) System Core command.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=DEFINE_CONFIGURATION

  If you choose this selection, you will need to use subcommands of the
  PHYSICAL_CONFIGURATION_UTILITY (PCU) to define and install your physical
  configuration.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROMPT
  Enter selection or ? for HELP.
~"**
~"END_MESSAGE_MODULE CREATE_MODULE=YES
*DECK DECK=CMM$TABLES_RING1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Configuration Management : Ring 1 Tables' ??
MODULE cmm$tables_ring1;

{ PURPOSE:
{   This module contains variable declarations of various static tables used by configuration management to
{   determine the validity of peripheral product identifications.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmc$default_vsn
*copyc cmt$configuration_limits
*copyc cmt$controller_id
*copyc cmt$device_id
*copyc cmt$response_handler
*copyc cmt$system_device_data
*copyc oss$mainframe_paged_literal
*copyc ost$spaa_entry
?? POP ??
*copyc cmv$new_device_file
*copyc dfv$process_multiword_response
*copyc iov$process_disk_response
*copyc iov$process_subsystem_response
*copyc iov$tape_process_pp_response
*copyc nav$network_response_processor
*copyc rfv$response_processor
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    c$configuration_limits = 17;

  VAR

    { WARNING - If the use of constants CMC$CIO_CHANNEL_NO_PORT or CMC$CIO_CHANNEL_2_PORT are ever extended
    { to other equipments, the prompt message 'Select port', in procedure CHECK_FOR_CONCURRENT_CHANNEL will
    { also have to be extended to include the new equipment(s).

    cmv$configuration_limits: [XDCL, READ, oss$mainframe_paged_literal] ARRAY [1 .. c$configuration_limits] OF
          cmt$configuration_limits := [
          ['  $844', [cmc$ms7154_x, cmc$ms7155_1, cmc$ms7155_1x], [cmc$nio_channel, cmc$cio_channel_no_port],
              [dsc$imn_i1_10_model, dsc$imn_i1_11_model, dsc$imn_i1_12_model, dsc$imn_i1_13_model,
               dsc$imn_i1_14_model, dsc$imn_i2_20_model, dsc$imn_i4_40_model, dsc$imn_i4_42_model,
               dsc$imn_i4_44_model, dsc$imn_i4_46_model],
               0, 0, 0, 7],
          ['  $885', [cmc$ms7155_1, cmc$ms7155_1x], [cmc$nio_channel, cmc$cio_channel_no_port],
              [dsc$imn_i1_10_model, dsc$imn_i1_11_model, dsc$imn_i1_12_model, dsc$imn_i1_13_model,
               dsc$imn_i1_14_model, dsc$imn_i2_20_model, dsc$imn_i4_40_model, dsc$imn_i4_42_model,
               dsc$imn_i4_44_model, dsc$imn_i4_46_model],
               0, 0, 32, 47],
          ['  $895', [cmc$ms7165_2x], [cmc$nio_channel, cmc$cio_channel_no_port],
              [dsc$imn_i2_20_model, dsc$imn_i4_40_model, dsc$imn_i4_42_model, dsc$imn_i4_44_model,
               dsc$imn_i4_46_model],
               0, 1, 0, 31],
          ['  $834', [cmc$ms7255_1_1], [cmc$nio_channel],
              [dsc$imn_i1_10_model, dsc$imn_i1_11_model, dsc$imn_i1_12_model, dsc$imn_i1_13_model,
               dsc$imn_i1_14_model],
               0, 7, 0, 3],
          ['  $836', [cmc$ms7255_1_2], [cmc$nio_channel],
              [dsc$imn_i1_10_model, dsc$imn_i1_11_model, dsc$imn_i1_12_model, dsc$imn_i1_13_model,
               dsc$imn_i1_14_model],
               0, 7, 0, 3],
          ['  $887', [cmc$mshydra_ct], [cmc$cio_channel_2_port],
              [dsc$imn_i4_40_model, dsc$imn_i4_42_model, dsc$imn_i4_44_model, dsc$imn_i4_46_model],
               0, 0, 0, 7],
          [' $9836', [cmc$mscm3_ct], [cmc$nio_channel],
              [dsc$imn_i0_5x_model],
              0, 7, 0, 7],
          ['  $679', [cmc$mt7021_3x], [cmc$nio_channel, cmc$cio_channel_no_port],
              [dsc$imn_i1_10_model, dsc$imn_i1_11_model, dsc$imn_i1_12_model, dsc$imn_i1_13_model,
               dsc$imn_i1_14_model, dsc$imn_i2_20_model, dsc$imn_i4_40_model, dsc$imn_i4_42_model,
               dsc$imn_i4_44_model, dsc$imn_i4_46_model],
               0, 7, 0, 7],
          ['  $639', [cmc$mt7221_1], [cmc$nio_channel],
              [dsc$imn_i1_10_model, dsc$imn_i1_11_model, dsc$imn_i1_12_model, dsc$imn_i1_13_model,
               dsc$imn_i1_14_model],
               0, 0, 0, 0],
          [' $9639', [cmc$mt7221_2_s0], [cmc$nio_channel],
              [dsc$imn_i0_5x_model],
               0, 0, 0, 1],
          ['  $698', [cmc$mt698_xx, cmc$mt5698_xx], [cmc$nio_channel, cmc$cio_channel_2_port,
               cmc$cio_channel_no_port],
              [dsc$imn_i1_10_model, dsc$imn_i1_11_model, dsc$imn_i1_12_model, dsc$imn_i1_13_model,
               dsc$imn_i1_14_model, dsc$imn_i2_20_model, dsc$imn_i4_40_model, dsc$imn_i4_42_model,
               dsc$imn_i4_44_model, dsc$imn_i4_46_model, dsc$imn_i0_5x_model],
               0, 7, 0, 7],
          [' $5682', [cmc$mt5680_xx], [cmc$nio_channel, cmc$cio_channel_no_port],
              [dsc$imn_i2_20_model, dsc$imn_i4_40_model, dsc$imn_i4_42_model, dsc$imn_i4_44_model,
               dsc$imn_i4_46_model, dsc$imn_i1_13_model],
               0, 0, 0, 15],
          [' $9853', [cmc$mscm3_ct], [cmc$cio_channel_2_port, cmc$nio_channel],
              [dsc$imn_i4_40_model, dsc$imn_i4_42_model, dsc$imn_i4_44_model, dsc$imn_i4_46_model,
               dsc$imn_i0_5x_model],
               0, 7, 0, 7],
          [' $5832', [cmc$ms5831_x], [cmc$cio_channel_2_port, cmc$nio_channel],
              [dsc$imn_i4_40_model, dsc$imn_i4_42_model, dsc$imn_i4_44_model, dsc$imn_i4_46_model,
               dsc$imn_i0_5x_model],
               0, 7, 0, 31],
          [' $5833', [cmc$ms5831_x], [cmc$cio_channel_2_port, cmc$nio_channel],
              [dsc$imn_i4_40_model, dsc$imn_i4_42_model, dsc$imn_i4_44_model, dsc$imn_i4_46_model,
               dsc$imn_i0_5x_model],
               0, 7, 0, 31],
          [' $5838', [cmc$ms5831_x], [cmc$cio_channel_2_port, cmc$nio_channel],
              [dsc$imn_i4_40_model, dsc$imn_i4_42_model, dsc$imn_i4_44_model, dsc$imn_i4_46_model,
               dsc$imn_i0_5x_model],
               0, 7, 0, 31],
          ['$47444', [cmc$ms5831_x], [cmc$cio_channel_2_port, cmc$nio_channel],
              [dsc$imn_i4_40_model, dsc$imn_i4_42_model, dsc$imn_i4_44_model, dsc$imn_i4_46_model,
               dsc$imn_i0_5x_model],
               0, 7, 0, 31]],

    cmv$controller_data: [READ, oss$mainframe_paged_literal] ARRAY [1 .. 46] OF cmt$controller_id := [
      { } [['  $698', '_', '10 '], cmc$mt698_xx, osc$spid_698_xx_driver],
      { } [['  $698', '_', '11 '], cmc$mt698_xx, osc$spid_698_xx_driver],
      { } [['  $698', '_', '12 '], cmc$mt698_xx, osc$spid_698_xx_driver],
      { } [['  $698', '_', '20 '], cmc$mt698_xx, osc$spid_698_xx_driver],
      { } [['  $698', '_', '21 '], cmc$mt698_xx, osc$spid_698_xx_driver],
      { } [['  $698', '_', '22 '], cmc$mt698_xx, osc$spid_698_xx_driver],
      { } [[' $5680', '_', '11 '], cmc$mt5680_xx, osc$spid_5680_xx_driver],
      { } [[' $5698', '_', '10 '], cmc$mt5698_xx, osc$spid_5698_xx_driver],
      { } [[' $5698', '_', '11 '], cmc$mt5698_xx, osc$spid_5698_xx_driver],
      { } [[' $5698', '_', '12 '], cmc$mt5698_xx, osc$spid_5698_xx_driver],
      { } [[' $7154', '_', '1  '], cmc$ms7154_x, osc$spid_7154_driver],
      { } [[' $7154', '_', '2  '], cmc$ms7154_x, osc$spid_7154_driver],
      { } [[' $7154', '_', '3  '], cmc$ms7154_x, osc$spid_7154_driver],
      { } [[' $7154', '_', '4  '], cmc$ms7154_x, osc$spid_7154_driver],
      { } [[' $7155', '_', '1  '], cmc$ms7155_1, osc$spid_7155_1_driver],
      { } [[' $7155', '_', '11 '], cmc$ms7155_1x, osc$spid_7155_1x_driver],
      { } [[' $7155', '_', '12 '], cmc$ms7155_1x, osc$spid_7155_1x_driver],
      { } [[' $7155', '_', '13 '], cmc$ms7155_1x, osc$spid_7155_1x_driver],
      { } [[' $7155', '_', '14 '], cmc$ms7155_1x, osc$spid_7155_1x_driver],
      { } [[' $7021', '_', '31 '], cmc$mt7021_3x, osc$spid_7021_3x_driver],
      { } [[' $7021', '_', '32 '], cmc$mt7021_3x, osc$spid_7021_3x_driver],
      { } [[' $7221', '_', '1  '], cmc$mt7221_1, osc$spid_7021_3x_driver],
      { } [[' $7221', '_', '11 '], cmc$mt7221_2_s0, osc$spid_ismt_s0_driver_13],
      { } [[' $7021', '_', '41'], cmc$mt7021_4x, osc$spid_7021_4x_driver],
      { } [[' $7021', '_', '42'], cmc$mt7021_4x, osc$spid_7021_4x_driver],
      { } [[' $4000', '_', '01 '], cmc$expresslink, osc$spid_expresslink_driver],
      { } [[' $7040', '_', '200'], cmc$fs740_200, osc$spid_fs_driver],
      { } [[' $5380', '_', '100'], cmc$fs740_200, osc$spid_fs_driver],
      { } [['  $380', '_', '170'], cmc$lcn380_170, osc$spid_lcn_driver],
      { } [[' $2620', '_', '210'], cmc$mti2620_21x, osc$spid_mti_driver],
      { } [[' $2620', '_', '211'], cmc$mti2620_21x, osc$spid_mti_driver],
      { } [[' $2621', '_', '210'], cmc$mdi2621_21x, osc$spid_mdi_driver],
      { } [[' $2621', '_', '211'], cmc$mdi2621_21x, osc$spid_mdi_driver],
      { } [[' $2629', '_', '2  '], cmc$ca2629_2, osc$spid_ica_driver],
      { } [[' $7165', '_', '21 '], cmc$ms7165_2x, osc$spid_unused_driver_11],
      { } [[' $7165', '_', '22 '], cmc$ms7165_2x, osc$spid_unused_driver_11],
      { } [[' $7195', '_', '1  '], cmc$mshydra_ct, osc$spid_unused_driver_12],
      { } [['$10395', '_', '11 '], cmc$ms7255_1_1, osc$spid_unused_driver_10],
      { } [['$10395', '_', '1  '], cmc$ms7255_1_1, osc$spid_unused_driver_10],
      { } [['$10479', '_', '1  '], cmc$ms7255_1_2, osc$spid_unused_driver_10],
      { } [['$FA7B4', '_', 'D  '], cmc$ms7255_1_2, osc$spid_unused_driver_10],
      { } [['$FA7B5', '_', 'A  '], cmc$mscm3_ct, osc$spid_cm3_driver_14],
      { } [[' $5831', '_', 'X  '], cmc$ms5831_x, osc$spid_hps_driver],
      { } [['$65354', '_', '10 '], cmc$mp65354_11, osc$spid_map_driver],
      { } [['$65354', '_', '11 '], cmc$mp65354_11, osc$spid_map_driver],
      { } [['$65354', '_', '12 '], cmc$mp65354_11, osc$spid_map_driver]],

    cmv$controller_data_ptr: [XDCL, READ, #GATE, oss$mainframe_paged_literal] ^ARRAY [1 .. * ] OF
          cmt$controller_id := ^cmv$controller_data,

    cmv$nil_response_handler: [STATIC, READ, oss$mainframe_paged_literal] cmt$response_handler := NIL,

    cmv$product_id_ptr: [XDCL, READ, #GATE, oss$mainframe_paged_literal] ^ARRAY [1 .. *] OF
          cmt$device_id := ^cmv$product_id_string,

    cmv$product_id_string: [READ, oss$mainframe_paged_literal] ARRAY [1 .. 50] OF cmt$device_id := [
      { } [['  $679', '_', '5  '], cmc$mt679_5, ioc$dt_mt679_5, cmc$magnetic_tape_unit],
      { } [['  $679', '_', '6  '], cmc$mt679_6, ioc$dt_mt679_6, cmc$magnetic_tape_unit],
      { } [['  $679', '_', '7  '], cmc$mt679_7, ioc$dt_mt679_7, cmc$magnetic_tape_unit],
      { } [['  $679', '_', '2  '], cmc$mt679_2, ioc$dt_mt679_2, cmc$magnetic_tape_unit],
      { } [['  $679', '_', '3  '], cmc$mt679_3, ioc$dt_mt679_3, cmc$magnetic_tape_unit],
      { } [['  $679', '_', '4  '], cmc$mt679_4, ioc$dt_mt679_4, cmc$magnetic_tape_unit],
      { } [['  $639', '_', '1  '], cmc$mt639_1, ioc$dt_mt639_1, cmc$magnetic_tape_unit],
      { } [['  $698', '_', '30 '], cmc$mt698_3x, ioc$dt_mt698_3x, cmc$magnetic_tape_unit],
      { } [['  $698', '_', '31 '], cmc$mt698_3x, ioc$dt_mt698_3x, cmc$magnetic_tape_unit],
      { } [[' $5682', '_', '12 '], cmc$mt5682_1x, ioc$dt_mt5682_1x, cmc$magnetic_tape_unit],
      { } [[' $5682', '_', '14 '], cmc$mt5682_1x, ioc$dt_mt5682_1x, cmc$magnetic_tape_unit],
      { } [[' $9639', '_', '1  '], cmc$mt639_s0, ioc$dt_mt639_1, cmc$magnetic_tape_unit],
      { } [['  $887', '_', '1  '], cmc$mshydra, ioc$dt_mshydra, cmc$mass_storage_unit],
      { } [['  $895', '_', '2  '], cmc$ms895_2, ioc$dt_ms895_2, cmc$mass_storage_unit],
      { } [['  $895', '_', '2  '], cmc$ms895_2, ioc$dt_ms895_2, cmc$mass_storage_unit],
      { } [['  $844', '_', '41 '], cmc$ms844_4x, ioc$dt_ms844_4x, cmc$mass_storage_unit],
      { } [['  $844', '_', '44 '], cmc$ms844_4x, ioc$dt_ms844_4x, cmc$mass_storage_unit],
      { } [['  $885', '_', '11 '], cmc$ms885_1x, ioc$dt_ms885_1x, cmc$mass_storage_unit],
      { } [['  $885', '_', '12 '], cmc$ms885_1x, ioc$dt_ms885_1x, cmc$mass_storage_unit],
      { } [['  $885', '_', '42 '], cmc$ms885_4x, ioc$dt_ms885_42, cmc$mass_storage_unit],
      { } [['  $834', '_', '2  '], cmc$ms834_2, ioc$dt_ms834_2, cmc$mass_storage_unit],
      { } [['  $834', '_', '12 '], cmc$ms834_2, ioc$dt_ms834_2, cmc$mass_storage_unit],
      { } [['  $836', '_', '110'], cmc$msfsd_2, ioc$dt_msfsd_2, cmc$mass_storage_unit],
      { } [['  $836', '_', '221'], cmc$msfsd_2, ioc$dt_msfsd_2, cmc$mass_storage_unit],
      { } [['  $836', '_', '441'], cmc$msfsd_2, ioc$dt_msfsd_2, cmc$mass_storage_unit],
      { } [[' $9836', '_', '1  '], cmc$msfsd2_s0, ioc$dt_ms9836_1, cmc$mass_storage_unit],
      { } [[' $9853', '_', 'X  '], cmc$msxmd_3, ioc$dt_msxmd_3, cmc$mass_storage_unit],
      { } [[' $9853', '_', '1  '], cmc$msxmd_3, ioc$dt_msxmd_3, cmc$mass_storage_unit],
      { } [[' $9853', '_', '2  '], cmc$msxmd_3, ioc$dt_msxmd_3, cmc$mass_storage_unit],
      { } [[' $9853', '_', '3  '], cmc$msxmd_3, ioc$dt_msxmd_3, cmc$mass_storage_unit],
      { } [[' $9853', '_', '4  '], cmc$msxmd_3, ioc$dt_msxmd_3, cmc$mass_storage_unit],
      { } [[' $5832', '_', '1  '], cmc$ms5832_1, ioc$dt_ms5832_1, cmc$mass_storage_unit],
      { } [[' $5832', '_', '2  '], cmc$ms5832_2, ioc$dt_ms5832_2, cmc$mass_storage_unit],
      { } [[' $5833', '_', '1  '], cmc$ms5833_1, ioc$dt_ms5833_1, cmc$mass_storage_unit],
      { } [[' $5833', '_', '1P '], cmc$ms5833_1p, ioc$dt_ms5833_1p, cmc$mass_storage_unit],
      { } [[' $5833', '_', '2  '], cmc$ms5833_2, ioc$dt_ms5833_2, cmc$mass_storage_unit],
      { } [[' $5833', '_', '3P '], cmc$ms5833_3p, ioc$dt_ms5833_3p, cmc$mass_storage_unit],
      { } [[' $5833', '_', '4  '], cmc$ms5833_4, ioc$dt_ms5833_4, cmc$mass_storage_unit],
      { } [[' $5838', '_', '1  '], cmc$ms5838_1, ioc$dt_ms5838_1, cmc$mass_storage_unit],
      { } [[' $5838', '_', '1P '], cmc$ms5838_1p, ioc$dt_ms5838_1p, cmc$mass_storage_unit],
      { } [[' $5838', '_', '2  '], cmc$ms5838_2, ioc$dt_ms5838_2, cmc$mass_storage_unit],
      { } [[' $5838', '_', '3P '], cmc$ms5838_3p, ioc$dt_ms5838_3p, cmc$mass_storage_unit],
      { } [[' $5838', '_', '4  '], cmc$ms5838_4, ioc$dt_ms5838_4, cmc$mass_storage_unit],
      { } [['$47444', '_', '1  '], cmc$ms47444_1, ioc$dt_ms47444_1, cmc$mass_storage_unit],
      { } [['$47444', '_', '1P '], cmc$ms47444_1p, ioc$dt_ms47444_1p, cmc$mass_storage_unit],
      { } [['$47444', '_', '2  '], cmc$ms47444_2, ioc$dt_ms47444_2, cmc$mass_storage_unit],
      { } [['$47444', '_', '3P '], cmc$ms47444_3p, ioc$dt_ms47444_3p, cmc$mass_storage_unit],
      { } [['$47444', '_', '4  '], cmc$ms47444_4, ioc$dt_ms47444_4, cmc$mass_storage_unit],
      { } [['$MAPNO', '_', 'CMI'], cmc$map_1, ioc$dt_map_1, cmc$map_unit],
      { } [['$65354', '_', '11 '], cmc$map_cmi_1, ioc$dt_map_cmi_1, cmc$map_unit]],

    cmv$response_handler_map: [XDCL] ARRAY [cmt$controller_type] OF ^cmt$response_handler := [
      { cmc$ms7154_x        } ^iov$process_disk_response,
      { cmc$ms7155_1        } ^iov$process_disk_response,
      { cmc$ms7155_1x       } ^iov$process_disk_response,
      { cmc$ms7165_2x       } ^iov$process_disk_response,
      { cmc$mscm3_ct        } ^iov$process_disk_response,
      { cmc$mshydra_ct      } ^iov$process_disk_response,
      { cmc$ms5831_x        } ^iov$process_disk_response,
      { cmc$mt7021_3x       } ^iov$tape_process_pp_response,
      { cmc$mt7021_4x       } ^iov$tape_process_pp_response,
      { cmc$ms7255_1_1      } ^iov$process_disk_response,
      { cmc$ms7255_1_2      } ^iov$process_disk_response,
      { cmc$mt7221_2_s0     } ^iov$tape_process_pp_response,
      { cmc$mt5680_xx       } ^iov$tape_process_pp_response,
      { cmc$mt7221_1        } ^iov$tape_process_pp_response,
      { cmc$mt698_xx        } ^iov$tape_process_pp_response,
      { cmc$mt5698_xx       } ^iov$tape_process_pp_response,
      { cmc$mp65354_11      } ^iov$process_subsystem_response,
      { cmc$ca2629_2        } ^nav$network_response_processor,
      { cmc$lcn380_170      } ^rfv$response_processor,
      { cmc$mti2620_21x     } ^nav$network_response_processor,
      { cmc$mdi2621_21x     } ^nav$network_response_processor,
      { cmc$fs740_200       } ^dfv$process_multiword_response,
      { cmc$expresslink     } ^nav$network_response_processor,
      { cmc$null_controller } NIL],

    cmv$system_device_data: [XDCL, #GATE] cmt$system_device_data;

?? OLDTITLE ??
?? NEWTITLE := 'cmp$change_new_df_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$change_new_df_entry
    (    device_file_record: cmt$device_file_record);

    cmv$new_device_file := device_file_record;

  PROCEND cmp$change_new_df_entry;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$get_response_handler', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$get_response_handler ALIAS 'cmxgrh'
    (    controller_type: cmt$controller_type;
     VAR response_handler: cmt$response_handler);

    response_handler := cmv$response_handler_map [controller_type]^;

  PROCEND cmp$get_response_handler;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$return_configuration_limits', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$return_configuration_limits
    (    product_number: string (6);
     VAR configuration_limits: cmt$configuration_limits;
     VAR product_found: boolean);

    VAR
      index: 1 .. c$configuration_limits;

    product_found := FALSE;

    FOR index := LOWERBOUND (cmv$configuration_limits) TO UPPERBOUND (cmv$configuration_limits) DO
      IF cmv$configuration_limits [index].product_number = product_number THEN
        configuration_limits := cmv$configuration_limits [index];
        product_found := TRUE;
        RETURN;
      IFEND;
    FOREND;

  PROCEND cmp$return_configuration_limits;
MODEND cmm$tables_ring1;
*DECK DECK=CMM$TASK_SHARED_VARIABLES EXPAND=TRUE

MODULE cmm$task_shared_variables;
?? TITLE := 'MODULE cmm$task_shared_variables' ??

?? PUSH (LISTEXT := ON) ??
*copyc mst$con_access_gtid_list
?? POP ??

VAR

  msv$con_access_gtid_list :  [XDCL] mst$con_access_gtid_list := NIL;

MODEND cmm$task_shared_variables;
*DECK DECK=CMM$VCMB_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE CM : Boot Screen Interfaces' ??
MODULE cmm$vcmb_interfaces;

{ PURPOSE:
{   This module contains the code that displays and references the BOOT screen menus.  It also contains
{   the code that configures and deconfigures the system and the deadstart device.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmc$logical_unit_constants
*copyc cme$physical_configuration_mgr
*copyc cmt$physical_channel
*copyc dpt$console_row_size
?? POP ??
*copyc clp$convert_integer_to_string
*copyc cmp$acquire_deadstart_resources
*copyc cmp$build_interface_tables
*copyc cmp$build_iou_table
*copyc cmp$build_pct
*copyc cmp$build_state_table
*copyc cmp$convert_channel_number
*copyc cmp$convert_iou_name
*copyc cmp$convert_iou_number
*copyc cmp$free_element_def_table
*copyc cmp$get_controller_type
*copyc cmp$get_driver_by_controller
*copyc cmp$get_logical_pp_index
*copyc cmp$get_logical_unit_number
*copyc cmp$get_unit_type
*copyc cmp$idle_pp_r1
*copyc cmp$load_controller_module
*copyc cmp$release_channel_resource
*copyc cmp$release_equipment_resource
*copyc cmp$release_pp_by_index
*copyc cmp$return_configuration_limits
*copyc cmp$set_illegal_channel_status
*copyc dmp$get_physical_attributes
*copyc dpp$clear_window
*copyc dpp$close_window
*copyc dpp$get_next_line
*copyc dpp$open_window
*copyc dpp$put_critical_message
*copyc dpp$put_next_line
*copyc dpp$set_title
*copyc dsp$access_vcu_cda_data
*copyc dsp$get_entry_from_ssr
*copyc dsp$retrieve_iou_information
*copyc dsp$retrieve_mf_element_entry
*copyc dsp$save_boot_data_pointer
*copyc dsp$store_entry_in_ssr
*copyc iop$free_boot_tape_tables
*copyc iop$free_tape_tables
*copyc iop$initialize_tape_ud
*copyc iop$rewind_tape
*copyc iop$tape_initialization
*copyc iop$tape_request_status
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osp$unpack_status_condition
*copyc pmp$delay
*copyc pmp$zero_out_table
*copyc syp$ascii_to_binary
*copyc syp$get_token
?? EJECT ??
*copyc cmv$controller_location
*copyc cmv$iou_table_p
*copyc cmv$state_info_table
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc cmv$max_number_of_pp
*copyc cmv$physical_configuration
*copyc cmv$system_device_data
*copyc dpv$system_core_display
*copyc dsv$dcfile_identifier
*copyc dsv$sub_mainframe_type
*copyc osv$deadstart_device_lun
*copyc osv$mainframe_pageable_heap
*copyc osv$mainframe_wired_cb_heap
*copyc osv$system_device_cylinder_size
*copyc osv$170_os_type
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??
  CONST
    c$max_error_message_count = 7,

    c$ml_os_location_line = 1,
    c$ml_operator_intervention_line = 2,
    c$ml_dcfile_name_line = 3,
    c$ml_unused_4_line = 4,
    c$ml_device_title_line = 5,
    c$ml_unused_6_line = 6,
    c$ml_iou_line = 7,
    c$ml_channel_line = 8,
    c$ml_controller_line = 9,
    c$ml_storage_device_line = 10,
    c$ml_equipment_line = 11,
    c$ml_unit_line = 12,
    c$ml_unused_13_line = 13,
    c$ml_first_message_line = 14,
    c$ml_second_message_line = 15,
    c$ml_third_message_line = 16,
    c$ml_fourth_message_line = 17,
    c$ml_fifth_message_line = 18,
    c$ml_sixth_message_line = 19,
    c$ml_last_message_line = 20,

    c$other_controller_line = 12,
    c$other_storage_device_line = 13,
    c$disk_controller_line = 5,
    c$disk_storage_device_line = 9;

  TYPE
    t$device_supported = (c$supported_device, c$unsupported_device),
    t$menu_template = ARRAY [1 .. c$ml_last_message_line] OF string (dpc$console_row_size),
    t$token = RECORD
      data: ost$string,
      convert_ascii_to_binary: boolean,
      number: integer,
    RECEND;
?? EJECT ??
  VAR
    v$bucket_used: dst$vcu_bucket_types,
    v$channel: ARRAY [cmt$system_device_types] OF cmt$physical_channel,
    v$deadstart_device: cmt$system_device_types,
    v$error_message: ARRAY [1 .. c$max_error_message_count] OF string (dpc$console_row_size),
    v$error_message_count: 0 .. c$max_error_message_count := 0,
    v$first_time_menu_called: boolean := TRUE,
    v$iou_information_table: dst$iou_information_table,
    v$menu_output: t$menu_template,
    v$menu_window_id: dpt$window_id := 0,
    v$number_of_ious: dst$number_of_ious,
    v$operator_intervention: boolean := FALSE,
    v$special_930_model: boolean := FALSE;
?? EJECT ??
  VAR
    v$main_menu_template: t$menu_template := [
      '   1. OS Location ..........................                                 ',
      '   2. Deadstart pause for operator input ...                                 ',
      '   3. DCFILE name ..........................                                 ',
      '                                                                             ',
      '   Deadstart Device                      System Device                       ',
      '                                                                             ',
      '   4. IOU ................... x          9. IOU ................... x        ',
      '   5. Channel ............... x         10. Channel ............... x        ',
      '   6. Controller and ........ x         11. Controller and ........ x        ',
      '        Storage Device ...... x               Storage Device ...... x        ',
      '   7. Equipment Number ...... x         12. Equipment Number ...... x        ',
      '   8. Unit Number ........... x         13. Unit Number ........... x        ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             '],

    v$disk_controller_template: t$menu_template := [
      '   1. $7155_x  / $844_4x     14. $5831_x  / $5833_3P                         ',
      '   2. $7155_x  / $885_1x     15. $5831_x  / $5833_4                          ',
      '   3. $7165_2x / $895_2      16. $5831_x  / $5838_1                          ',
      '   4. $10395_1 / $834_12     17. $5831_x  / $5838_1P   Current Controller    ',
      '   5. $FA7B4_D / $836_xxx    18. $5831_x  / $5838_2    is: x                 ',
      '   6. $887_1                 19. $5831_x  / $5838_3P                         ',
      '   7. $FA7B5_A / $9836_1     20. $5831_x  / $5838_4                          ',
      '   8. $FA7B5_A / $9853_x     21. $5831_x  / $47444_1   Current Storage Device',
      '   9. $5831_x  / $5832_1     22. $5831_x  / $47444_1P  is: x                 ',
      '  10. $5831_x  / $5832_2     23. $5831_x  / $47444_2                         ',
      '  11. $5831_x  / $5833_1     24. $5831_x  / $47444_3P                        ',
      '  12. $5831_x  / $5833_1P    25. $5831_x  / $47444_4                         ',
      '  13. $5831_x  / $5833_2                                                     ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             '],

    v$tape_controller_template: t$menu_template := [
      '   1. $7021_3x /  $679_x                                                     ',
      '   2. $7221_1  /  $639_1                                                     ',
      '   3. $7221_11 /  $9639_1                                                    ',
      '   4. $698_xx  /  $698_3x                                                    ',
      '   5. $5698_xx /  $698_3x                                                    ',
      '   6. $5680_11 /  $5682_1x                                                   ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '   Current Controller is ....... x                                           ',
      '   Current Storage Device is ... x                                           ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             '];
?? EJECT ??
  VAR
    v$unsupported_disk_template: t$menu_template := [
      '   1. $7154_x  /  $844_4x                                                    ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '   Current Controller is ....... x                                           ',
      '   Current Storage Device is ... x                                           ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             '],

    v$unsupported_tape_template: t$menu_template := [
      '   There are no unsupported tape controllers and                             ',
      '   storage devices.  Press NEXT to retain current                            ',
      '   values.                                                                   ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '   Current Controller is ....... x                                           ',
      '   Current Storage Device is ... x                                           ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             ',
      '                                                                             '];
?? TITLE := 'access_menu_display', EJECT ??

{ PURPOSE:
{   This procedure displays the main boot screen menu and waits for a response.

  PROCEDURE access_menu_display
    (    buckets: dst$vcu_bucket_data);

    VAR
      device: cmt$system_device_types,
      ignore_status: ost$status,
      menu_number: 1 .. 13,
      token: t$token;

    token.convert_ascii_to_binary := TRUE;

   /menu_loop/
    WHILE TRUE DO
      v$menu_output := v$main_menu_template;
      CASE v$bucket_used OF
      = dsc$vcu_bt_disk_bucket =
        v$menu_output [c$ml_os_location_line] (46, 15) := 'Alternate Disk ';
      = dsc$vcu_bt_cr_bucket =
        v$menu_output [c$ml_os_location_line] (46, 15) := 'Default Disk   ';
      ELSE {= dsc$vcu_bt_tape_bucket =}
        v$menu_output [c$ml_os_location_line] (46, 15) := 'Tape           ';
      CASEND;
      IF v$operator_intervention THEN
        v$menu_output [c$ml_operator_intervention_line] (46, 6) := 'True  ';
      ELSE
        v$menu_output [c$ml_operator_intervention_line] (46, 6) := 'False ';
      IFEND;
      v$menu_output [c$ml_dcfile_name_line] (46, 5) := dsv$dcfile_identifier;

      { Display the information on the left side of the console.

      display_device_information (7, 31, v$deadstart_device);
      IF v$bucket_used = dsc$vcu_bt_tape_bucket THEN

        { Display the information on the right side of the console.

        display_device_information (45, 69, cmc$sdt_disk_device);
      ELSE

        { Deadstart and system device are the same, erase the right side.

        v$menu_output [c$ml_device_title_line] := '   Deadstart and System Device ';
        v$menu_output [c$ml_iou_line] (41, *) := ' ';
        v$menu_output [c$ml_channel_line] (41, *) := ' ';
        v$menu_output [c$ml_controller_line] (41, *) := ' ';
        v$menu_output [c$ml_storage_device_line] (41, *) := ' ';
        v$menu_output [c$ml_equipment_line] (41, *) := ' ';
        v$menu_output [c$ml_unit_line] (41, *) := ' ';
      IFEND;
      dpp$set_title (v$menu_window_id, 'Deadstart and System Device Configuration Selections', ignore_status);
      display_menu;

      read_input ('Enter a menu number to change a value or',
            'Press NEXT to accept parameters and continue the deadstart process', token);
      IF token.data.size <= 0 THEN
        EXIT /menu_loop/;
      IFEND;

      IF (token.number < 1) OR (token.number > 13) THEN
        display_error;
        CYCLE /menu_loop/;
      IFEND;

      IF (v$bucket_used <> dsc$vcu_bt_tape_bucket) AND (token.number > 8) THEN
        display_error;
        CYCLE /menu_loop/;
      IFEND;

      menu_number := token.number;
      IF (v$bucket_used = dsc$vcu_bt_tape_bucket) AND ((menu_number >= 4) AND (menu_number <= 8)) THEN
        device := cmc$sdt_tape_device;
      ELSE
        device := cmc$sdt_disk_device;
      IFEND;

      CASE menu_number OF
      = 1 =
        enter_new_os_location (buckets);
      = 2 =
        enter_operator_pause;
      = 3 =
        enter_dcfile_identifier;
      = 4, 9 =
        enter_iou (device);
      = 5, 10 =
        enter_channel (device);
      = 6, 11 =
        enter_controller_storage_device (device);
      = 7, 12 =
        enter_equipment_number (device);
      ELSE {= 8, 13 =}
        enter_unit_number (device);
      CASEND;
    WHILEND /menu_loop/;

  PROCEND access_menu_display;
?? TITLE := 'add_equipment_details', EJECT ??

{ PURPOSE:
{   This procedure adds the controller or storage device specific information to the menu.

  PROCEDURE add_equipment_details
    (    product_id: cmt$product_identification;
         menu_line: 1 .. c$ml_last_message_line;
         position: dpt$console_row_size);

    VAR
      entry_length: 0 .. 6,
      ignore_status: ost$status,
      index: 0 .. 6;

    entry_length := 1;
   /equipment_loop/
    FOR index := 1 TO 6 DO
      IF product_id.product_number (index) <> ' ' THEN
        entry_length := 6 - (index - 1);
        EXIT /equipment_loop/;
      IFEND;
    FOREND /equipment_loop/;
    v$menu_output [menu_line] (position, entry_length) := product_id.product_number (index, entry_length);
    v$menu_output [menu_line] (position+entry_length, 1) := product_id.underscore;
    v$menu_output [menu_line] (position+entry_length+1, 3) := product_id.model_number;

  PROCEND add_equipment_details;
?? TITLE := 'add_error_message', EJECT ??

{ PURPOSE:
{   This procedure adds an error message to the list of error messages to be displayed on the console.
{ DESIGN:
{   Since the console line is only 80 characters long, the procedure makes sure that the message is totally
{   displayed by breaking up the message into strings of 80 characters or less and displaying each string.

  PROCEDURE add_error_message
    (    text: string ( * ));

    VAR
      error_message_size: integer,
      message_length: dpt$console_row_size,
      text_index: integer;

    text_index := 1;
    error_message_size := #SIZE (text);
    WHILE (error_message_size > 0) AND (v$error_message_count < c$max_error_message_count) DO
      v$error_message_count := v$error_message_count + 1;
      IF error_message_size > dpc$console_row_size THEN
        message_length := dpc$console_row_size;
      ELSE
        message_length := error_message_size;
      IFEND;
      v$error_message [v$error_message_count] := text (text_index, message_length);
      text_index := text_index + message_length;
      error_message_size := error_message_size - message_length;
    WHILEND;

  PROCEND add_error_message;
?? TITLE := 'attempt_validation', EJECT ??

{ PURPOSE:
{   This procedure attempts to validate the deadstart and system device.

  PROCEDURE attempt_validation
    (VAR buckets: dst$vcu_bucket_data;
     VAR status: ost$status);

    VAR
      device: cmt$system_device_types,
      ignore_status: ost$status,
      ssr_entry: dst$ssr_entry,
      valid_configuration: boolean,
      vcu_cda_seq_p: ^SEQ ( * ),
      vcu_version: dst$vcu_cda_version;

    status.normal := TRUE;

    { Validate the desired configuration.

    validate_configuration (valid_configuration);
    IF NOT valid_configuration THEN
      status.normal := FALSE;
      RETURN;
    IFEND;

    IF v$deadstart_device = cmc$sdt_tape_device THEN
      dpp$put_next_line (dpv$system_core_display, 'Validating deadstart device', ignore_status);
      validate_device (cmc$sdt_tape_device, status);
      IF NOT status.normal THEN
        cmp$write_os_status ('Error found while validating deadstart device.', status);
        RETURN;
      IFEND;
      dpp$put_next_line (dpv$system_core_display, 'Validating system device', ignore_status);
      validate_device (cmc$sdt_disk_device, status);
      IF NOT status.normal THEN
        cmp$write_os_status ('Error found while validating system device.', status);
        RETURN;
      IFEND;
    ELSE
      dpp$put_next_line (dpv$system_core_display, 'Validating deadstart and system device', ignore_status);
      validate_device (cmc$sdt_disk_device, status);
      IF NOT status.normal THEN
        cmp$write_os_status ('Error found while validating deadstart and system device.', status);
        RETURN;
      IFEND;
    IFEND;

    { Write the bucket information back to VCU.

    buckets [v$bucket_used][v$deadstart_device].dcfile_identifier := dsv$dcfile_identifier;

    FOR device := v$deadstart_device DOWNTO cmc$sdt_disk_device DO
      buckets [v$bucket_used][device].backward_compatibility := FALSE;
      buckets [v$bucket_used][device].specified := TRUE;
      buckets [v$bucket_used][device].iou_number := cmv$system_device_data [device].iou_number;
      buckets [v$bucket_used][device].channel := v$channel [device];
      buckets [v$bucket_used][device].equipment_id := cmv$system_device_data [device].equipment_id;
      buckets [v$bucket_used][device].equipment_number := cmv$system_device_data [device].equipment_number;
      buckets [v$bucket_used][device].unit_id := cmv$system_device_data [device].unit_id;
      buckets [v$bucket_used][device].unit_number := cmv$system_device_data [device].unit_number;
    FOREND;

    vcu_cda_seq_p := #SEQ (buckets);
    dsp$access_vcu_cda_data (dsc$vcu_write_access, dsc$vcu_bucket_data, vcu_cda_seq_p, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to write bucket data to CDA.', ^status);
    IFEND;

    { Write the bucket type used back to VCU.

    vcu_cda_seq_p := #SEQ (v$bucket_used);
    dsp$access_vcu_cda_data (dsc$vcu_write_access, dsc$vcu_bucket_used, vcu_cda_seq_p, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to write bucket used data to CDA.', ^status);
    IFEND;

    { Write the version back to VCU.

    vcu_version := dsc$vcu_post_153_system;
    vcu_cda_seq_p := #SEQ (vcu_version);
    dsp$access_vcu_cda_data (dsc$vcu_write_access, dsc$vcu_version, vcu_cda_seq_p, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to write version data to CDA.', ^status);
    IFEND;

    { Store the operator intervention flag in the SSR.

    ssr_entry.whole_slot := $INTEGER(v$operator_intervention);
    dsp$store_entry_in_ssr (dsc$ssr_operator_intervention, dsc$ssr_whole_slot, ssr_entry);

  PROCEND attempt_validation;
?? TITLE := 'check_for_concurrent_channel', EJECT ??

{ PURPOSE:
{   Determine if the channel is concurrent.

  PROCEDURE check_for_concurrent_channel
    (    must_be_cio_channel: boolean;
     VAR concurrent: boolean;
     VAR port: cmt$channel_port);

    VAR
      token: t$token;

    port := cmc$unspecified_port;
    token.convert_ascii_to_binary := FALSE;

   /cio_loop/
    WHILE TRUE DO
      IF NOT must_be_cio_channel THEN
        read_input ('Is this a concurrent channel: Y)es, N)o', ' ', token);
        IF token.data.size = 0 THEN
          CYCLE /cio_loop/;
        IFEND;
      IFEND;

      IF must_be_cio_channel OR (token.data.value (1) = 'Y') THEN
        concurrent := TRUE;
        WHILE TRUE DO
          read_input ('Select port: Enter A or B if 5831, 887, 9853 or 5698/698_3x;',
                      '             otherwise press NEXT.', token);
          IF token.data.size = 0 THEN
            EXIT /cio_loop/;
          IFEND;

          IF (token.data.value (1) = 'A') THEN
            port := cmc$port_a;
            EXIT /cio_loop/;
          ELSEIF (token.data.value (1) = 'B') THEN
            port := cmc$port_b;
            EXIT /cio_loop/;
          IFEND;
          display_error;
        WHILEND;

      ELSEIF (token.data.value (1) = 'N') THEN
        concurrent := FALSE;
        EXIT /cio_loop/;
      IFEND;
      display_error;
    WHILEND /cio_loop/;

  PROCEND check_for_concurrent_channel;
?? TITLE := 'check_tape_status', EJECT ??

{ PURPOSE:
{   This procedure checks the status of the tape IO.

  PROCEDURE check_tape_status
    (    io_id: iot$io_id;
     VAR status: ost$status);

    VAR
      dummy_sfid: dmt$system_file_id,
      io_status: iot$tape_io_status;

    status.normal := TRUE;

    REPEAT
      iop$tape_request_status (dummy_sfid, io_id, {wait=} FALSE, io_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF NOT io_status.io_complete THEN
        pmp$delay (100, status);
      IFEND;
    UNTIL io_status.io_complete;

    IF NOT io_status.unit_ready THEN
      osp$set_status_abnormal (cmc$configuration_management_id,
            cme$boot_tape_io_error, 'Tape unit is not ready.', status);
    ELSEIF NOT io_status.normal_completion THEN
      CASE io_status.completion_code OF
      = ioc$system_software_failure =
        osp$set_status_abnormal (cmc$configuration_management_id,
              cme$boot_tape_io_error, 'IO error, software failure.', status);
      = ioc$controller_failure =
        osp$set_status_abnormal (cmc$configuration_management_id,
              cme$boot_tape_io_error, 'IO error, controller failure.',status);
      = ioc$unit_failure =
        osp$set_status_abnormal (cmc$configuration_management_id,
              cme$boot_tape_io_error, 'IO error, unit failure.', status);
      = ioc$function_timeout =
        osp$set_status_abnormal (cmc$configuration_management_id,
              cme$boot_tape_io_error, 'IO error, function timeout detected.', status);
      = ioc$input_channel_parity =
        osp$set_status_abnormal (cmc$configuration_management_id,
              cme$boot_tape_io_error, 'IO error, input channel parity.', status);
      = ioc$output_channel_parity =
        osp$set_status_abnormal (cmc$configuration_management_id,
              cme$boot_tape_io_error, 'IO error, output channel parity.', status);
      ELSE

        { Ignored for now.

      CASEND;
    IFEND;

  PROCEND check_tape_status;
?? TITLE := 'display_controller_menu', EJECT ??

{ PURPOSE:
{   This procedure displays the menu containing the controller and storage device options.

  PROCEDURE display_controller_menu
    (    device_supported: t$device_supported;
         device: cmt$system_device_types);

    VAR
      ignore_status: ost$status;

    IF device = cmc$sdt_tape_device THEN
      IF device_supported = c$supported_device THEN
        v$menu_output := v$tape_controller_template;
        dpp$set_title (v$menu_window_id, 'Tape Controller/Storage Device Selections', ignore_status);
      ELSE
        v$menu_output := v$unsupported_tape_template;
        dpp$set_title (v$menu_window_id, 'Unsupported Tape Controller/Storage Device Selections',
              ignore_status);
      IFEND;
    ELSE { device = cmc$sdt_disk_device
      IF device_supported = c$supported_device THEN
        v$menu_output := v$disk_controller_template;
        dpp$set_title (v$menu_window_id, 'Disk Controller/Storage Device Selections', ignore_status);
      ELSE
        v$menu_output := v$unsupported_disk_template;
        dpp$set_title (v$menu_window_id, 'Unsupported Disk Controller/Storage Device Selections',
              ignore_status);
      IFEND;
    IFEND;
    IF (device = cmc$sdt_disk_device) AND (device_supported = c$supported_device) THEN
      { Display the current controller information.
      add_equipment_details (cmv$system_device_data [device].equipment_id, c$disk_controller_line, 60);

      { Display the current storage device information.
      add_equipment_details (cmv$system_device_data [device].unit_id, c$disk_storage_device_line, 60);
    ELSE
      { Display the current controller information.
      add_equipment_details (cmv$system_device_data [device].equipment_id, c$other_controller_line, 34);

      { Display the current storage device information.
      add_equipment_details (cmv$system_device_data [device].unit_id, c$other_storage_device_line, 34);
    IFEND;
    display_menu;

  PROCEND display_controller_menu;
?? TITLE := 'display_device_information', EJECT ??

{ PURPOSE:
{   This procedure adds the individual device information to the menu.

  PROCEDURE display_device_information
    (    word_position: 0 .. 0ff(16);
         position: 0 .. 0ff(16);
         device: cmt$system_device_types);

    VAR
      channel_ordinal: cmt$channel_ordinal,
      ignore_status: ost$status,
      temp_string: ost$string;

    { Display the iou number information.

    clp$convert_integer_to_string (cmv$system_device_data [device].iou_number, 10, TRUE,
          temp_string, ignore_status);
    v$menu_output [c$ml_iou_line] (position, temp_string.size) := temp_string.value (1, temp_string.size);

    { Display the channel information.

    IF NOT v$channel [device].concurrent THEN
      v$menu_output [c$ml_channel_line] (word_position, 19) := 'Channel ...........';
    ELSE
      v$menu_output [c$ml_channel_line] (word_position, 19) := 'Concurrent Channel ';
    IFEND;
    v$menu_output [c$ml_channel_line] (position, 6) := cmv$system_device_data [device].channel_name (1, 6);

    { Display the controller information.

    add_equipment_details (cmv$system_device_data [device].equipment_id, c$ml_controller_line, position);

    { Display the storage device information}

    add_equipment_details (cmv$system_device_data [device].unit_id, c$ml_storage_device_line, position);

    { Display the equipment number information.

    clp$convert_integer_to_string (cmv$system_device_data [device].equipment_number, 10, TRUE,
          temp_string, ignore_status);
    v$menu_output [c$ml_equipment_line] (position, temp_string.size) :=
          temp_string.value (1, temp_string.size);

    { Display the unit number information.

    clp$convert_integer_to_string (cmv$system_device_data [device].unit_number, 10, TRUE, temp_string,
          ignore_status);
    v$menu_output [c$ml_unit_line] (position, temp_string.size) := temp_string.value (1, temp_string.size);

  PROCEND display_device_information;
?? TITLE := 'display_error', EJECT ??

{ PURPOSE:
{   This procedure displays an unvalid option entered message and forces the menu to be repainted.

  PROCEDURE display_error;

    add_error_message ('*** Invalid option entered, Enter valid option');
    display_menu;

  PROCEND display_error;
?? TITLE := 'display_menu', EJECT ??

{ PURPOSE:
{   This procedure displays the appropriate boot screen menu on the system console.

  PROCEDURE display_menu;

    VAR
      ignore_status: ost$status,
      index: 1 .. c$ml_last_message_line;

    FOR index := c$ml_first_message_line TO c$ml_last_message_line DO
      v$menu_output [index] := ' ';
    FOREND;

    IF v$error_message_count <> 0 THEN
      FOR index := c$ml_first_message_line TO (c$ml_first_message_line+v$error_message_count-1) DO
        v$menu_output [index] := v$error_message [index-(c$ml_first_message_line-1)];
      FOREND;
      v$error_message_count := 0;
    IFEND;

    FOR index := 1 TO c$ml_last_message_line DO
      dpp$put_next_line (v$menu_window_id, v$menu_output [index], ignore_status);
    FOREND;
    dpp$clear_window (v$menu_window_id, ignore_status);

  PROCEND display_menu;
?? TITLE := 'enter_channel', EJECT ??

{ PURPOSE:
{   This procedure allows the operator to change the channel number.

  PROCEDURE enter_channel
    (    device: cmt$system_device_types);

    VAR
      channel_ordinal: cmt$channel_ordinal,
      concurrent: boolean,
      must_be_cio_channel: boolean,
      port: cmt$channel_port,
      possible_cio_channel_0_thru_3: boolean,
      possible_cio_channel_0_thru_9: boolean,
      possible_cio_channel_any_ch: boolean,
      possible_i4ce_nio_channel: boolean,
      token: t$token,
      valid_channel: boolean;

    concurrent := FALSE;
    port := cmc$unspecified_port;
    must_be_cio_channel := FALSE;
    possible_cio_channel_0_thru_3 := FALSE;
    possible_cio_channel_0_thru_9 := FALSE;
    possible_cio_channel_any_ch := FALSE;
    possible_i4ce_nio_channel := FALSE;
    token.convert_ascii_to_binary := TRUE;

    { Determine if it is possible to have a CIO channel.

    CASE v$iou_information_table [1].model_type OF
    = dsc$imn_i4_40_model =
      IF (v$number_of_ious = 1) OR (v$iou_information_table [2].model_type = dsc$imn_i4_40_model) THEN
        possible_cio_channel_0_thru_9 := TRUE;
      ELSE  { I4/I4C combination }
        possible_cio_channel_any_ch := TRUE;
      IFEND;
    = dsc$imn_i4_42_model =
      IF v$number_of_ious = 1 THEN
        possible_cio_channel_0_thru_3 := TRUE;
      ELSE  { I4S/I4C combination }
        possible_cio_channel_any_ch := TRUE;
      IFEND;
    = dsc$imn_i4_44_model =
      must_be_cio_channel := TRUE;
    = dsc$imn_i4_46_model =
      possible_i4ce_nio_channel := TRUE;
    ELSE
    CASEND;

   /channel_loop/
    WHILE TRUE DO
      read_input ('Enter the Channel number (0 through 11(10), 16(10) through 27(10))', ' ', token);
      IF token.data.size <= 0 THEN
        EXIT /channel_loop/;
      IFEND;

      IF possible_i4ce_nio_channel THEN
        must_be_cio_channel := (token.number < 32(8));
      IFEND;

      IF (possible_cio_channel_0_thru_9 AND (token.number >= 0) AND (token.number <= 9)) OR
            (possible_cio_channel_0_thru_3 AND (token.number >= 0) AND (token.number <= 3)) OR
            must_be_cio_channel OR possible_cio_channel_any_ch THEN
        check_for_concurrent_channel (must_be_cio_channel, concurrent, port);
      IFEND;

      IF ((token.number >= 0) AND (token.number <= 11)) OR
            ((token.number >= 16) AND (token.number <= 27)) THEN
        v$channel [device].number := token.number;
        v$channel [device].port := port;
        v$channel [device].concurrent := concurrent;
        cmp$convert_channel_number (token.number, concurrent, port, channel_ordinal,
              cmv$system_device_data [device].channel_name, valid_channel);
        IF valid_channel THEN
          EXIT /channel_loop/;
        IFEND;
      IFEND;
      display_error;
    WHILEND /channel_loop/;

  PROCEND enter_channel;
?? TITLE := 'enter_controller_storage_device', EJECT ??

{ PURPOSE:
{   This procedure allows the operator to change the controller and the storage device.

  PROCEDURE enter_controller_storage_device
    (    device: cmt$system_device_types);

    VAR
      controller_found: boolean,
      local_status: ost$status,
      old_system_device_data: cmt$system_device_data_entry,
      token: t$token;

    { Limit the disk device to 9836 if v$special_930_model = TRUE.

    IF v$special_930_model AND (device = cmc$sdt_disk_device) THEN
      cmv$system_device_data [device].equipment_id.product_number := '$FA7B5';
      cmv$system_device_data [device].equipment_id.underscore := '_';
      cmv$system_device_data [device].equipment_id.model_number := 'A  ';
      cmv$system_device_data [device].unit_id.product_number := ' $9836';
      cmv$system_device_data [device].unit_id.underscore := '_';
      cmv$system_device_data [device].unit_id.model_number := '1  ';
      add_error_message ('Mainframe model has a fixed value for disk CONTROLLER/STORAGE DEVICE.');
      RETURN;
    IFEND;

    controller_found := FALSE;
    display_controller_menu (c$supported_device, device);
    old_system_device_data := cmv$system_device_data [device];
    token.convert_ascii_to_binary := FALSE;

   /controller_loop/
    WHILE TRUE DO
      cmv$system_device_data [device] := old_system_device_data;
      read_input ('Enter menu number to change the Controller and Storage Device or',
            'Press NEXT to accept current Controller and Storage Device', token);
      IF token.data.size <= 0 THEN
        EXIT /controller_loop/;
      IFEND;

      IF token.data.value (1, token.data.size) = 'OTHER' THEN
        enter_unsupported_controller (device, controller_found);
      ELSE
        syp$ascii_to_binary (token.data.value (1, token.data.size), 10, token.number, local_status);
        IF local_status.normal THEN
          IF device = cmc$sdt_tape_device THEN
            get_tape_controller (token, controller_found);
          ELSE
            get_disk_controller (token, controller_found);
          IFEND;
        IFEND;
      IFEND;
      IF controller_found THEN
        EXIT /controller_loop/;
      IFEND;
      display_error;
    WHILEND /controller_loop/;

  PROCEND enter_controller_storage_device;
?? TITLE := 'enter_dcfile_identifier', EJECT ??

{ PURPOSE:
{   This procedure allows the operator to change the dcfile identifier.

  PROCEDURE enter_dcfile_identifier;

    VAR
      token: t$token;

    token.convert_ascii_to_binary := FALSE;

   /enter_dcfile/
    WHILE TRUE DO
      read_input ('Enter the DCFILE name (DCFxx)', ' ', token);
      IF token.data.size <= 0 THEN
        EXIT /enter_dcfile/;
      IFEND;

      IF (token.data.size = 5) AND (token.data.value (1, 3) = 'DCF') THEN
        dsv$dcfile_identifier := token.data.value (1, 5);
        EXIT /enter_dcfile/;
      IFEND;
      display_error;
    WHILEND /enter_dcfile/;

  PROCEND enter_dcfile_identifier;
?? TITLE := 'enter_equipment_number', EJECT ??

{ PURPOSE:
{   This procedure allows the operator to change the equipment number.

  PROCEDURE enter_equipment_number
    (    device: cmt$system_device_types);

    VAR
      configuration_limits: cmt$configuration_limits,
      product_found: boolean,
      text: string (dpc$console_row_size),
      text_length: integer,
      token: t$token;

    cmp$return_configuration_limits (cmv$system_device_data [device].unit_id.product_number,
          configuration_limits, product_found);
    IF configuration_limits.minimum_equipment_number = configuration_limits.maximum_equipment_number THEN
      add_error_message ('Current device type has a fixed value for EQUIPMENT.');
      cmv$system_device_data [device].equipment_number := configuration_limits.minimum_equipment_number;
      RETURN;
    IFEND;

    text := ' ';
    STRINGREP (text, text_length, 'Enter equipment number in the range ',
          configuration_limits.minimum_equipment_number, ' -', configuration_limits.maximum_equipment_number);
    token.convert_ascii_to_binary := TRUE;

  /enter_equipment/
    WHILE TRUE DO
      read_input (text, ' ', token);
      IF token.data.size <= 0 THEN
        EXIT /enter_equipment/;
      IFEND;

      IF (token.number >= configuration_limits.minimum_equipment_number) AND
            (token.number <= configuration_limits.maximum_equipment_number) THEN
        cmv$system_device_data [device].equipment_number := token.number;
        EXIT /enter_equipment/;
      IFEND;
      display_error;
    WHILEND /enter_equipment/;

  PROCEND enter_equipment_number;
?? TITLE := 'enter_iou', EJECT ??

{ PURPOSE:
{   This procedure allows the operator to enter the iou number of the deadstart or system device.
{ DESIGN:
{   If the system has more than 1 IOU, the operator is asked to enter an IOU in the allowed range.
{   If the system only has 1 IOU, the IOU is automatically set to zero.

  PROCEDURE enter_iou
    (    device: cmt$system_device_types);

    VAR
      iou_index: dst$number_of_ious,
      text: string (dpc$console_row_size),
      text_length: integer,
      token: t$token;

    IF v$number_of_ious = 1 THEN
      cmv$system_device_data [device].iou_number := v$iou_information_table [1].physical_iou_number;
      add_error_message ('IOU field has fixed value - only 1 IOU in configuration.');
      RETURN;
    IFEND;

    text := ' ';
    STRINGREP (text, text_length, 'Enter IOU number in the range ', 0, ' -', v$number_of_ious - 1);
    token.convert_ascii_to_binary := TRUE;

  /enter_iou_number/
    WHILE TRUE DO
      read_input (text, ' ', token);
      IF token.data.size <= 0 THEN
        EXIT /enter_iou_number/;
      IFEND;

      FOR iou_index := 1 to v$number_of_ious DO
        IF v$iou_information_table [iou_index].physical_iou_number = token.number THEN
          cmv$system_device_data [device].iou_number := token.number;
          EXIT /enter_iou_number/;
        IFEND;
      FOREND;
      display_error;
    WHILEND /enter_iou_number/;

  PROCEND enter_iou;
?? TITLE := 'enter_new_os_location', EJECT ??

{ PURPOSE:
{   This procedure allows the operator to change the deadstart device location.

  PROCEDURE enter_new_os_location
    (    buckets: dst$vcu_bucket_data);

    VAR
      ignore_force_menus: boolean,
      token: t$token;

    token.convert_ascii_to_binary := FALSE;

   /new_os_loop/
    WHILE TRUE DO
      read_input ('Enter OS location: D)efault disk, A)lternate disk, T)ape', ' ', token);
      IF token.data.size <= 0 THEN
        EXIT /new_os_loop/;
      IFEND;

      IF (token.data.value (1) = 'D') THEN
        v$bucket_used := dsc$vcu_bt_cr_bucket;
        v$deadstart_device := cmc$sdt_disk_device;
        EXIT /new_os_loop/;

      ELSEIF (token.data.value (1) = 'A') THEN
        v$bucket_used := dsc$vcu_bt_disk_bucket;
        v$deadstart_device := cmc$sdt_disk_device;
        EXIT /new_os_loop/;

      ELSEIF (token.data.value (1) = 'T') THEN
        v$bucket_used := dsc$vcu_bt_tape_bucket;
        v$deadstart_device := cmc$sdt_tape_device;
        EXIT /new_os_loop/;
      IFEND;

      display_error;
    WHILEND /new_os_loop/;

    retrieve_bucket_information (buckets, ignore_force_menus);

  PROCEND enter_new_os_location;
?? TITLE := 'enter_operator_pause', EJECT ??

{ PURPOSE:
{   This procedure allows the operator to change the operator intervention flag.

  PROCEDURE enter_operator_pause;

    VAR
      token: t$token;

    token.convert_ascii_to_binary := FALSE;

   /pause_loop/
    WHILE TRUE DO
      read_input ('Should deadstart pause for operator input: T)rue, F)alse', ' ', token);
      IF token.data.size <= 0 THEN
        EXIT /pause_loop/;
      IFEND;

      IF (token.data.value (1) = 'T') OR (token.data.value (1) = 'F') THEN
        v$operator_intervention := (token.data.value (1) = 'T');
        EXIT /pause_loop/;
      IFEND;

      display_error;
    WHILEND /pause_loop/;

  PROCEND enter_operator_pause;
?? TITLE := 'enter_unit_number', EJECT ??

{ PURPOSE:
{   This procedure allows the operator to change the unit number.

  PROCEDURE enter_unit_number
    (    device: cmt$system_device_types);

    VAR
      configuration_limits: cmt$configuration_limits,
      product_found: boolean,
      text: string (dpc$console_row_size),
      text_length: integer,
      token: t$token;

    cmp$return_configuration_limits (cmv$system_device_data [device].unit_id.product_number,
          configuration_limits, product_found);
    IF configuration_limits.minimum_unit_number = configuration_limits.maximum_unit_number THEN
      add_error_message ('Current device type has a fixed value for UNIT.');
      cmv$system_device_data [device].unit_number := configuration_limits.minimum_unit_number;
      RETURN;
    IFEND;

    text := ' ';
    IF (device = cmc$sdt_disk_device) AND ((cmv$system_device_data [device].unit_id.product_number = ' $5832')
          OR (cmv$system_device_data [device].unit_id.product_number = ' $5833') OR
          (cmv$system_device_data [device].unit_id.product_number = ' $5838') OR
          (cmv$system_device_data [device].unit_id.product_number = '$47444')) THEN
      IF NOT (cmv$system_device_data [device].unit_id.model_number = '1  ') THEN
        STRINGREP (text, text_length, 'Enter unit number in the range ', configuration_limits.
           minimum_unit_number,' -', 7);
      ELSE
        STRINGREP (text, text_length, 'Enter unit number in the range ', configuration_limits.
           minimum_unit_number,' -', configuration_limits.maximum_unit_number);
      IFEND;
    ELSE
      STRINGREP (text, text_length, 'Enter unit number in the range ', configuration_limits.
          minimum_unit_number,' -', configuration_limits.maximum_unit_number);
    IFEND;
    token.convert_ascii_to_binary := TRUE;

  /enter_unit/
    WHILE TRUE DO
      read_input (text, ' ', token);
      IF token.data.size <= 0 THEN
        EXIT / enter_unit/;
      IFEND;

      IF (token.number >= configuration_limits.minimum_unit_number) AND
            (token.number <= configuration_limits.maximum_unit_number) THEN
        cmv$system_device_data [device].unit_number := token.number;
        EXIT /enter_unit/;
      IFEND;
      display_error;
    WHILEND /enter_unit/;

  PROCEND enter_unit_number;
?? TITLE := 'enter_unsupported_controller', EJECT ??

{ PURPOSE:
{   This procedure allows the user to access unsupported, but still used products.  It allows the operator
{   to change the controller and storage device.

  PROCEDURE enter_unsupported_controller
    (    device: cmt$system_device_types;
     VAR controller_found: boolean);

    VAR
      token: t$token;

    controller_found := FALSE;
    display_controller_menu (c$unsupported_device, device);
    token.convert_ascii_to_binary := TRUE;

   /unsupported_loop/
    WHILE TRUE DO
      read_input ('Enter menu number to change the Controller and Storage Device or',
            'Press NEXT to accept current Controller and Storage Device', token);
      IF token.data.size <= 0 THEN
        controller_found := TRUE;
        EXIT /unsupported_loop/;
      IFEND;

      IF device = cmc$sdt_tape_device THEN
        { No unsupported tape devices.
      ELSE
        get_unsupported_disk (token, controller_found);
      IFEND;
      IF controller_found THEN
        EXIT /unsupported_loop/;
      IFEND;
      display_error;
    WHILEND /unsupported_loop/;

  PROCEND enter_unsupported_controller;
?? TITLE := 'get_disk_controller', EJECT ??

{ PURPOSE:
{   This procedure retrieves the specific disk controller.

  PROCEDURE get_disk_controller
    (    token: t$token;
     VAR controller_found: boolean);

    controller_found := FALSE;
    IF (token.number = 1) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $7155';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := '1  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := '  $844';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '44 ';
      controller_found := TRUE;
    ELSEIF (token.number = 2) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $7155';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := '1  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := '  $885';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '12 ';
      controller_found := TRUE;
    ELSEIF (token.number = 3) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $7165';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := '21 ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := '  $895';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '2  ';
      controller_found := TRUE;
    ELSEIF (token.number = 4) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := '$10395';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := '11 ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := '  $834';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '12 ';
      controller_found := TRUE;
    ELSEIF (token.number = 5) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := '$FA7B4';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'D  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := '  $836';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '110';
      controller_found := TRUE;
    ELSEIF (token.number = 6) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' ';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := ' ';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := ' ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := '  $887';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '1  ';
      controller_found := TRUE;
    ELSEIF (token.number = 7) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := '$FA7B5';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'A  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := ' $9836';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '1  ';
      controller_found := TRUE;
    ELSEIF (token.number = 8) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := '$FA7B5';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'A  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := ' $9853';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '1  ';
      controller_found := TRUE;
    ELSEIF (token.number = 9) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $5831';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'X  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := ' $5832';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '1  ';
      controller_found := TRUE;
    ELSEIF (token.number = 10) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $5831';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'X  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := ' $5832';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '2  ';
      controller_found := TRUE;
    ELSEIF (token.number = 11) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $5831';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'X  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := ' $5833';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '1  ';
      controller_found := TRUE;
    ELSEIF (token.number = 12) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $5831';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'X  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := ' $5833';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '1P ';
      controller_found := TRUE;
    ELSEIF (token.number = 13) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $5831';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'X  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := ' $5833';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '2  ';
      controller_found := TRUE;
    ELSEIF (token.number = 14) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $5831';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'X  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := ' $5833';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '3P ';
      controller_found := TRUE;
    ELSEIF (token.number = 15) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $5831';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'X  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := ' $5833';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '4  ';
      controller_found := TRUE;
    ELSEIF (token.number = 16) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $5831';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'X  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := ' $5838';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '1  ';
      controller_found := TRUE;
    ELSEIF (token.number = 17) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $5831';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'X  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := ' $5838';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '1P ';
      controller_found := TRUE;
    ELSEIF (token.number = 18) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $5831';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'X  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := ' $5838';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '2  ';
      controller_found := TRUE;
    ELSEIF (token.number = 19) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $5831';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'X  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := ' $5838';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '3P ';
      controller_found := TRUE;
    ELSEIF (token.number = 20) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $5831';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'X  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := ' $5838';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '4  ';
      controller_found := TRUE;
    ELSEIF (token.number = 21) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $5831';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'X  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := '$47444';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '1  ';
      controller_found := TRUE;
    ELSEIF (token.number = 22) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $5831';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'X  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := '$47444';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '1P ';
      controller_found := TRUE;
    ELSEIF (token.number = 23) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $5831';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'X  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := '$47444';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '2  ';
      controller_found := TRUE;
    ELSEIF (token.number = 24) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $5831';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'X  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := '$47444';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '3P ';
      controller_found := TRUE;
    ELSEIF (token.number = 25) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $5831';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'X  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := '$47444';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '4  ';
      controller_found := TRUE;
    IFEND;

  PROCEND get_disk_controller;
?? TITLE := 'get_tape_controller', EJECT ??

{ PURPOSE:
{   This procedure retrieves the specific tape controller.

  PROCEDURE get_tape_controller
    (    token: t$token;
     VAR controller_found: boolean);

    controller_found := FALSE;
    IF (token.number = 1) THEN
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.product_number := ' $7021';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.model_number := '32 ';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.product_number := '  $679';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.model_number := '7  ';
      controller_found := TRUE;
    ELSEIF (token.number = 2) THEN
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.product_number := ' $7221';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.model_number := '1  ';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.product_number := '  $639';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.model_number := '1  ';
      controller_found := TRUE;
    ELSEIF (token.number = 3) THEN
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.product_number := ' $7221';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.model_number := '11 ';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.product_number := ' $9639';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.model_number := '1  ';
      controller_found := TRUE;
    ELSEIF (token.number = 4) THEN
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.product_number := '  $698';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.model_number := '10 ';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.product_number := '  $698';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.model_number := '30 ';
      controller_found := TRUE;
    ELSEIF (token.number = 5) THEN
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.product_number := ' $5698';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.model_number := '10 ';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.product_number := '  $698';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.model_number := '30 ';
      controller_found := TRUE;
    ELSEIF (token.number = 6) THEN
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.product_number := ' $5680';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.model_number := '11 ';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.product_number := ' $5682';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.model_number := '12 ';
      controller_found := TRUE;
    IFEND;

  PROCEND get_tape_controller;
?? TITLE := 'get_unsupported_disk', EJECT ??

{ PURPOSE:
{   This procedure retrieves the specific unsupported disk controller.

  PROCEDURE get_unsupported_disk
    (    token: t$token;
     VAR controller_found: boolean);

    controller_found := FALSE;
    IF (token.number = 1) THEN
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $7154';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := '1  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := '  $844';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '44 ';
      controller_found := TRUE;
    IFEND;

  PROCEND get_unsupported_disk;
?? TITLE := 'read_input', EJECT ??

{ PURPOSE:
{   This procedure waits for the operator to enter the input at the boot screens.  It returns
{   the string that the operator entered and converts the input value to a binary number if desired.

  PROCEDURE read_input
    (    instructions_line_1: string ( * );
         instructions_line_2: string ( * );
     VAR token: { input, output } t$token);

    VAR
      console_input: string (dpc$console_row_size),
      ignore_status: ost$status,
      line_received: boolean,
      status: ost$status,
      token_index: 0 .. 255;

   /read_loop/
    WHILE TRUE DO
      dpp$put_next_line (dpv$system_core_display, instructions_line_1, ignore_status);
      IF instructions_line_2 <> ' ' THEN
        dpp$put_next_line (dpv$system_core_display, instructions_line_2, ignore_status);
      IFEND;
      dpp$get_next_line (dpv$system_core_display, osc$wait, console_input, line_received);
      dpp$put_next_line (dpv$system_core_display, console_input, ignore_status);
      token_index := 1;
      syp$get_token (console_input, TRUE {upper_case}, token_index, token.data, status);
      IF NOT status.normal THEN
        display_error;
        CYCLE /read_loop/;
      IFEND;

      IF token.convert_ascii_to_binary THEN
        syp$ascii_to_binary (token.data.value (1, token.data.size), 10, token.number, status);
        IF NOT status.normal THEN
          display_error;
          CYCLE /read_loop/;
        IFEND;
      ELSE
        token.number := 0;
      IFEND;

      EXIT /read_loop/;
    WHILEND /read_loop/;

  PROCEND read_input;
?? TITLE := 'retrieve_bucket_information', EJECT ??

{ PURPOSE:
{   This procedure retrieves information from the buckets in VCU depending upon what type
{   of deadstart device is used.

  PROCEDURE retrieve_bucket_information
    (    buckets: dst$vcu_bucket_data;
     VAR force_menus: boolean);

    VAR
      channel_ordinal: cmt$channel_ordinal,
      device: cmt$system_device_types,
      valid_channel: boolean;

    IF buckets [v$bucket_used][v$deadstart_device].dcfile_identifier = ' ' THEN
      dsv$dcfile_identifier := 'DCF00';
      add_error_message ('DCFILE name is undefined, enter correct value.');
      force_menus := TRUE;
    ELSE
      dsv$dcfile_identifier := buckets [v$bucket_used][v$deadstart_device].dcfile_identifier;
    IFEND;

    cmv$system_device_data [cmc$sdt_disk_device].specified := TRUE;
    cmv$system_device_data [cmc$sdt_tape_device].specified := (v$bucket_used = dsc$vcu_bt_tape_bucket);

    FOR device := v$deadstart_device DOWNTO cmc$sdt_disk_device DO
      IF buckets [v$bucket_used][device].specified THEN
        cmv$system_device_data [device].specified := TRUE;
        cmv$system_device_data [device].iou_number := buckets [v$bucket_used][device].iou_number;
        v$channel [device] := buckets [v$bucket_used][device].channel;
        cmp$convert_channel_number (v$channel [device].number, v$channel [device].concurrent,
              v$channel [device].port, channel_ordinal, cmv$system_device_data [device].channel_name,
              valid_channel);
        cmv$system_device_data [device].equipment_id := buckets [v$bucket_used][device].equipment_id;
        cmv$system_device_data [device].equipment_number := buckets [v$bucket_used][device].equipment_number;
        cmv$system_device_data [device].unit_id := buckets [v$bucket_used][device].unit_id;
        cmv$system_device_data [device].unit_number := buckets [v$bucket_used][device].unit_number;
      IFEND;
    FOREND;

  PROCEND retrieve_bucket_information;
?? TITLE := 'setup_default_configuration', EJECT ??

{ PURPOSE:
{   This procedure sets up the default configuration.

  PROCEDURE setup_default_configuration;

    IF v$iou_information_table [1].model_type = dsc$imn_i0_5x_model THEN
      cmv$system_device_data [cmc$sdt_disk_device].specified := FALSE;
      cmv$system_device_data [cmc$sdt_disk_device].iou_number := 0;
      cmv$system_device_data [cmc$sdt_disk_device].channel_name := 'CH1';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_name := '$SYSTEM_CONTROLLER';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := '$FA7B5';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := 'A  ';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_number := 0;
      cmv$system_device_data [cmc$sdt_disk_device].unit_name := '$SYSTEM_DEVICE';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := ' $9836';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '1  ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_number := 0;
      v$channel [cmc$sdt_disk_device].number := 1;
      v$channel [cmc$sdt_disk_device].port := cmc$unspecified_port;
      v$channel [cmc$sdt_disk_device].concurrent := FALSE;

      cmv$system_device_data [cmc$sdt_tape_device].specified := FALSE;
      cmv$system_device_data [cmc$sdt_tape_device].iou_number := 0;
      cmv$system_device_data [cmc$sdt_tape_device].channel_name := 'CH4';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_name := '$DEADSTART_CONTROLLER';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.product_number := ' $7221';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.model_number := '11 ';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_number := 0;
      cmv$system_device_data [cmc$sdt_tape_device].unit_name := '$DEADSTART_DEVICE';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.product_number := ' $9639';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.model_number := '1  ';
      cmv$system_device_data [cmc$sdt_tape_device].unit_number := 0;
      v$channel [cmc$sdt_tape_device].number := 4;
      v$channel [cmc$sdt_tape_device].port := cmc$unspecified_port;
      v$channel [cmc$sdt_tape_device].concurrent := FALSE;

    ELSE
      cmv$system_device_data [cmc$sdt_disk_device].specified := FALSE;
      cmv$system_device_data [cmc$sdt_disk_device].iou_number := 0;
      cmv$system_device_data [cmc$sdt_disk_device].channel_name := 'CH2';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_name := '$SYSTEM_CONTROLLER';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.product_number := ' $7155';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_id.model_number := '12 ';
      cmv$system_device_data [cmc$sdt_disk_device].equipment_number := 0;
      cmv$system_device_data [cmc$sdt_disk_device].unit_name := '$SYSTEM_DEVICE';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number := '  $885';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_disk_device].unit_id.model_number := '12 ';
      cmv$system_device_data [cmc$sdt_disk_device].unit_number := 32;
      v$channel [cmc$sdt_disk_device].number := 2;
      v$channel [cmc$sdt_disk_device].port := cmc$unspecified_port;
      v$channel [cmc$sdt_disk_device].concurrent := FALSE;

      cmv$system_device_data [cmc$sdt_tape_device].specified := FALSE;
      cmv$system_device_data [cmc$sdt_tape_device].iou_number := 0;
      cmv$system_device_data [cmc$sdt_tape_device].channel_name := 'CH26';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_name := '$DEADSTART_CONTROLLER';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.product_number := ' $7021';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_id.model_number := '32 ';
      cmv$system_device_data [cmc$sdt_tape_device].equipment_number := 0;
      cmv$system_device_data [cmc$sdt_tape_device].unit_name := '$DEADSTART_DEVICE';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.product_number := '  $679';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.underscore := '_';
      cmv$system_device_data [cmc$sdt_tape_device].unit_id.model_number := '7  ';
      cmv$system_device_data [cmc$sdt_tape_device].unit_number := 0;
      v$channel [cmc$sdt_tape_device].number := 26;
      v$channel [cmc$sdt_tape_device].port := cmc$unspecified_port;
      v$channel [cmc$sdt_tape_device].concurrent := FALSE;
    IFEND;
    dsp$save_boot_data_pointer (dsc$system_device_data, #SEQ (cmv$system_device_data));

  PROCEND setup_default_configuration;
?? TITLE := 'validate_configuration', EJECT ??

{ PURPOSE:
{   This procedure validates that the parameters entered for the deadstart and/or system device are proper.

  PROCEDURE validate_configuration
    (VAR valid_configuration: boolean);

    VAR
      channel_type: cmt$channel_kind,
      configuration_limits: cmt$configuration_limits,
      device: cmt$system_device_types,
      equipment_product: string (6),
      iou_index: dst$number_of_ious,
      iou_model: dst$iou_model_types,
      product_found: boolean,
      text: string (80),
      text_size: 0 .. 0ff(16),
      unit_product: string (6),
      valid_iou: boolean;

    valid_configuration := FALSE;

    IF v$deadstart_device = cmc$sdt_tape_device THEN
      IF (cmv$system_device_data [cmc$sdt_tape_device].channel_name =
            cmv$system_device_data [cmc$sdt_disk_device].channel_name) AND
            (cmv$system_device_data [cmc$sdt_tape_device].iou_number =
            cmv$system_device_data [cmc$sdt_disk_device].iou_number) THEN
        add_error_message ('Deadstart device channel / System device channel must be different.');
        RETURN;
      IFEND;
    IFEND;

    FOR device := v$deadstart_device DOWNTO cmc$sdt_disk_device DO
      IF v$deadstart_device = cmc$sdt_disk_device THEN
        text := 'Deadstart/System device ';
        text_size := 25;
      ELSEIF device = cmc$sdt_tape_device THEN
        text := 'Deadstart device ';
        text_size := 18;
      ELSE
        text := 'System device ';
        text_size := 15;
      IFEND;
      valid_iou := FALSE;

    /validate_iou/
      FOR iou_index := 1 to v$number_of_ious DO
        IF cmv$system_device_data [device].iou_number =
              v$iou_information_table [iou_index].physical_iou_number THEN
          valid_iou := TRUE;
          iou_model := v$iou_information_table [iou_index].model_type;
          EXIT /validate_iou/;
        IFEND;
      FOREND /validate_iou/;
      IF NOT valid_iou THEN
        text (text_size, *) := 'IOU number is not in the configuration.';
        add_error_message (text);
        RETURN;
      IFEND;

      unit_product := cmv$system_device_data [device].unit_id.product_number;
      equipment_product := cmv$system_device_data [device].equipment_id.product_number;

      IF (device = cmc$sdt_disk_device) AND v$special_930_model AND (unit_product <> ' $9836') THEN
        add_error_message ('Mainframe model does not support disk controller/storage device selected.');
        RETURN;
      IFEND;

      cmp$return_configuration_limits (unit_product, configuration_limits, product_found);
      IF NOT product_found THEN
        text (text_size, *) := 'product not found in known product list.';
        add_error_message (text);
        RETURN;
      IFEND;
      IF NOT (iou_model IN configuration_limits.allowed_ious) THEN
        text (text_size, *) := 'selected is not supported on current IOU model.';
        add_error_message (text);
        RETURN;
      IFEND;

      IF NOT v$channel [device].concurrent THEN
        channel_type := cmc$nio_channel;
      ELSE
        IF v$channel [device].port = cmc$unspecified_port THEN
          channel_type := cmc$cio_channel_no_port;
        ELSE
          channel_type := cmc$cio_channel_2_port;
        IFEND;
      IFEND;

      IF (channel_type = cmc$cio_channel_2_port) AND (equipment_product = '  $698') THEN
        text (text_size, *) := 'selected does not support channel with port.';
        add_error_message (text);
        RETURN;
      IFEND;
      IF NOT (channel_type IN configuration_limits.allowed_channels) THEN
        text (text_size, *) := 'selected does not support channel type selected.';
        add_error_message (text);
        RETURN;
      IFEND;

      CASE iou_model OF
      = dsc$imn_i1_10_model, dsc$imn_i1_11_model, dsc$imn_i1_12_model, dsc$imn_i1_13_model,
            dsc$imn_i1_14_model, dsc$imn_i2_20_model, dsc$imn_i0_5x_model =
        IF v$channel [device].concurrent THEN
          text (text_size, *) := 'channel selected is not supported on current IOU.';
          add_error_message (text);
          RETURN;
        IFEND;

      = dsc$imn_i4_40_model =
        IF v$channel [device].concurrent AND (v$channel [device].number > 11(8)) THEN
          text (text_size, *) := 'channel selected is not supported on current IOU.';
          add_error_message (text);
          RETURN;
        IFEND;

      = dsc$imn_i4_42_model =
        IF (v$channel [device].concurrent AND (v$channel [device].number > 3)) OR
              (NOT v$channel [device].concurrent AND (v$channel [device].number > 24(8))) THEN
          text (text_size, *) := 'channel selected is not supported on current IOU.';
          add_error_message (text);
          RETURN;
        IFEND;

      = dsc$imn_i4_44_model =
        IF NOT v$channel [device].concurrent OR (v$channel [device].number = 0) OR
              (v$channel [device].number = 1(8)) OR (v$channel [device].number = 12(8)) OR
              (v$channel [device].number = 13(8)) OR (v$channel [device].number = 32(8)) OR
              (v$channel [device].number = 33(8)) THEN
          text (text_size, *) := 'channel selected is not supported on current IOU.';
          add_error_message (text);
          RETURN;
        IFEND;

      = dsc$imn_i4_46_model =
        IF (v$channel [device].concurrent AND ((v$channel [device].number = 32(8)) OR
              (v$channel [device].number = 33(8)))) OR (v$channel [device].number = 0) OR
              (v$channel [device].number = 1(8)) OR (v$channel [device].number = 12(8)) OR
              (v$channel [device].number = 13(8)) THEN
          text (text_size, *) := 'channel selected is not supported on current IOU.';
          add_error_message (text);
          RETURN;
        IFEND;
      ELSE
      CASEND;

      IF (cmv$system_device_data [device].equipment_number < configuration_limits.minimum_equipment_number) OR
            (cmv$system_device_data [device].equipment_number >
            configuration_limits.maximum_equipment_number) THEN
        text (text_size, *) := 'EQUIPMENT number not in allowed range.';
        add_error_message (text);
        RETURN;
      IFEND;

      IF (cmv$system_device_data [device].unit_number < configuration_limits.minimum_unit_number) OR
            (cmv$system_device_data [device].unit_number > configuration_limits.maximum_unit_number) THEN
        text (text_size, *) := 'UNIT number not in allowed range.';
        add_error_message (text);
        RETURN;
      IFEND;

      IF (unit_product = ' $5832') OR (unit_product = ' $5833') OR (unit_product = ' $5838') OR
            (unit_product = '$47444') THEN
        IF cmv$system_device_data [device].unit_id.model_number = '1  ' THEN
          IF (cmv$system_device_data [device].unit_number < configuration_limits.minimum_unit_number) OR
              (cmv$system_device_data [device].unit_number > configuration_limits.maximum_unit_number) THEN
            text (text_size, *) := 'UNIT number not in allowed range.';
            add_error_message (text);
            RETURN;
          IFEND;
        ELSE
          IF (cmv$system_device_data [device].unit_number < configuration_limits.minimum_unit_number) OR
              (cmv$system_device_data [device].unit_number > 7) THEN
            text (text_size, *) := 'UNIT number not in allowed range.';
            add_error_message (text);
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

    valid_configuration := TRUE;

  PROCEND validate_configuration;
?? TITLE := 'validate_device', EJECT ??

{ PURPOSE:
{   This procedure determines if it is possible to configure and access the tape or disk device.

  PROCEDURE validate_device
    (    device: cmt$system_device_types;
     VAR status: ost$status);

    VAR
      dummy_sfid: dmt$system_file_id,
      ignore_status: ost$status,
      io_id: iot$io_id,
      tape_init_record: dmt$tape_initialization_record;

    status.normal := TRUE;

   /validate_the_device/
    BEGIN

      cmp$configure_deadstart_device (device, status);
      IF NOT status.normal THEN
        EXIT /validate_the_device/;
      IFEND;

      IF device = cmc$sdt_tape_device THEN
        cmp$get_logical_unit_number (cmv$system_device_data [device].unit_name, osv$deadstart_device_lun,
              status);
        IF NOT status.normal THEN
          EXIT /validate_the_device/;
        IFEND;
        tape_init_record.logical_unit_number := osv$deadstart_device_lun;
        tape_init_record.density := rmc$1600;
        iop$initialize_tape_ud (tape_init_record, {multiple_requests_possible} FALSE, status);
        IF NOT status.normal THEN
          EXIT /validate_the_device/;
        IFEND;
        iop$rewind_tape (dummy_sfid, io_id, status);
        IF NOT status.normal THEN
          EXIT /validate_the_device/;
        IFEND;
        check_tape_status (io_id, status);
        IF NOT status.normal THEN
          EXIT /validate_the_device/;
        IFEND;
      IFEND;
    END /validate_the_device/;

    cmp$de_configure_ds_device (ignore_status);

  PROCEND validate_device;
?? TITLE := 'cmp$configure_deadstart_device', EJECT ??

{ PURPOSE:
{   This procedure configures a device.

  PROCEDURE [XDCL] cmp$configure_deadstart_device
    (    device: cmt$system_device_types;
     VAR status: ost$status);

    VAR
      channel: cmt$physical_channel,
      channel_name: cmt$element_name,
      cm_controller_type: cmt$controller_type,
      equipment_number: 0 .. cmc$max_equipment_per_channel,
      found: boolean,
      index: integer,
      ignore_alternate: dst$driver_name,
      io_unit_type: iot$unit_type,
      iou: dst$iou_number,
      iou_program_name: dst$driver_name,
      physical_attributes_p: ^dmt$physical_device_attributes,
      pc_entries: ARRAY [1 .. 3] OF cmt$element_definition,
      pp_count: iot$pp_number,
      state_table_entries: ARRAY [1 .. 3] OF cmt$state_information,
      unit_class: cmt$unit_class,
      unit_number: 0 .. cmc$max_units_per_controller,
      unit_type: cmt$unit_type;

    status.normal := TRUE;

    { Retrieve the channel information for the physical configuration table.

    pc_entries [1].element_name := cmv$system_device_data [device].channel_name;
    pc_entries [1].product_id.product_number := ' ';
    pc_entries [1].product_id.underscore := ' ';
    pc_entries [1].product_id.model_number := ' ';
    pc_entries [1].element_type := cmc$data_channel_element;

    cmp$get_unit_type (cmv$system_device_data [device].unit_id, unit_type, io_unit_type, unit_class, found);
    IF found THEN
      pc_entries [1].data_channel.kind := cmc$170_channel;
      IF (unit_type = cmc$ms895_2) OR (unit_type = cmc$mt5682_1x) THEN
        pp_count := 2;
      ELSE
        pp_count := 1;
      IFEND;
    ELSE
      osp$system_error ('Unable to get unit type of desired system device.', NIL);
    IFEND;

    cmp$convert_iou_number (cmv$system_device_data [device].iou_number, pc_entries [1].data_channel.iou,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$convert_channel_number (v$channel [device].number, v$channel [device].concurrent,
          v$channel [device].port, pc_entries [1].data_channel.ordinal, channel_name, found);
    pc_entries [1].data_channel.number := v$channel [device].number;
    pc_entries [1].data_channel.port := v$channel [device].port;
    pc_entries [1].data_channel.concurrent := v$channel [device].concurrent;
    pc_entries [1].data_channel.mainframe_ownership := ' ';

    IF ((pc_entries [1].data_channel.number >= 0) AND (pc_entries [1].data_channel.number <= 11)) OR
          ((pc_entries [1].data_channel.number >= 16) AND (pc_entries [1].data_channel.number <= 27)) THEN
      FOR index := 0 TO UPPERVALUE (cmt$physical_equipment_number) DO
        pc_entries [1].data_channel.connection.equipment [index].configured := FALSE;
      FOREND;
      IF unit_type = cmc$mshydra THEN
        pc_entries [1].data_channel.connection.equipment
              [cmv$system_device_data [device].unit_number].configured := TRUE;
        pc_entries [1].data_channel.connection.equipment
              [cmv$system_device_data [device].unit_number].element_name :=
              cmv$system_device_data [device].unit_name;
      ELSE
        pc_entries [1].data_channel.connection.equipment
              [cmv$system_device_data [device].equipment_number].configured := TRUE;
        pc_entries [1].data_channel.connection.equipment
              [cmv$system_device_data [device].equipment_number].element_name :=
              cmv$system_device_data [device].equipment_name;
      IFEND;
    ELSE
      cmp$set_illegal_channel_status (v$channel [device].number, cme$pc_unsupported_channel, status);
      RETURN;
    IFEND;

    { Retrieve the controller information for the physical configuration table.  HYDRAs do not have
    { controller information.

    IF unit_type <> cmc$mshydra THEN
      pc_entries [2].element_name := cmv$system_device_data [device].equipment_name;
      pc_entries [2].product_id := cmv$system_device_data [device].equipment_id;
      pc_entries [2].element_type := cmc$controller_element;
      cmp$get_controller_type (pc_entries [2].product_id, cm_controller_type, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      cmp$get_driver_by_controller (cm_controller_type, pc_entries [1].data_channel.concurrent,
            cmv$system_device_data [device].iou_number, iou_program_name, ignore_alternate);
      pc_entries [2].controller.peripheral_driver_name := iou_program_name;
      pc_entries [2].controller.physical_equipment_number :=
            cmv$system_device_data [device].equipment_number;
      pc_entries [2].controller.connection.port [0].configured := TRUE;
      pc_entries [2].controller.connection.port [0].element_name :=
            cmv$system_device_data [device].channel_name;
      pc_entries [2].controller.connection.port [0].upline_connection_type := cmc$data_channel_element;
      pc_entries [2].controller.connection.port [0].mainframe_ownership := '  ';
      cmp$convert_iou_number (cmv$system_device_data [device].iou_number,
            pc_entries [2].controller.connection.port [0].iou, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      FOR index := 1 TO UPPERVALUE (cmt$controller_port_number) DO
        pc_entries [2].controller.connection.port [index].configured := FALSE;
      FOREND;
      FOR index := 0 TO UPPERVALUE (cmt$physical_unit_number) DO
        pc_entries [2].controller.connection.unit [index].configured := FALSE;
      FOREND;
      pc_entries [2].controller.connection.unit
            [cmv$system_device_data [device].unit_number].configured := TRUE;
      pc_entries [2].controller.connection.unit [cmv$system_device_data [device].unit_number].element_name :=
            cmv$system_device_data [device].unit_name;
    IFEND;

    { Retrieve the storage device information for the physical configuration table.

    pc_entries [3].element_name := cmv$system_device_data [device].unit_name;
    pc_entries [3].product_id := cmv$system_device_data [device].unit_id;
    pc_entries [3].element_type := cmc$storage_device_element;
    pc_entries [3].storage_device.physical_unit_number := cmv$system_device_data [device].unit_number;
    pc_entries [3].storage_device.connection.port [0].configured := TRUE;
    IF unit_type = cmc$mshydra THEN
      pc_entries [3].storage_device.connection.port [0].element_name :=
            cmv$system_device_data [device].channel_name;
      pc_entries [3].storage_device.connection.port [0].upline_connection_type := cmc$data_channel_element;
      pc_entries [3].storage_device.connection.port [0].mainframe_ownership := '  ';
      cmp$convert_iou_number (cmv$system_device_data [device].iou_number,
            pc_entries [3].storage_device.connection.port [0].iou, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      pc_entries [3].storage_device.connection.port [0].element_name :=
            cmv$system_device_data [device].equipment_name;
      pc_entries [3].storage_device.connection.port [0].upline_connection_type := cmc$controller_element;
    IFEND;
    FOR index := 1 TO UPPERVALUE (cmt$data_storage_port_number) DO
      pc_entries [3].storage_device.connection.port [index].configured := FALSE;
    FOREND;

    { Build the physical configuration table (cmv$physical_configuration).

    cmp$build_pct (3, pc_entries, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Build the state information table.

    state_table_entries [1].element_name := cmv$system_device_data [device].channel_name;
    state_table_entries [1].status.state := cmc$on;
    state_table_entries [1].element_type := cmc$data_channel_element;
    cmp$convert_iou_number (cmv$system_device_data [device].iou_number, state_table_entries [1].iou, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    state_table_entries [2].application_info_p := NIL;
    state_table_entries [2].site_info_p := NIL;
    state_table_entries [2].application_info_size := 0;
    state_table_entries [2].site_info_size := 0;
    IF unit_type <> cmc$mshydra THEN
      state_table_entries [2].element_name := cmv$system_device_data [device].equipment_name;
      state_table_entries [2].status.state := cmc$on;
      state_table_entries [2].element_type := cmc$controller_element;
      state_table_entries [2].product_id := cmv$system_device_data [device].equipment_id;
      state_table_entries [2].logical_unit := 0;
    ELSE
      state_table_entries [2].element_name := ' ';
    IFEND;
    state_table_entries [3].element_name := cmv$system_device_data [device].unit_name;
    state_table_entries [3].status.state := cmc$on;
    state_table_entries [3].element_type := cmc$storage_device_element;
    state_table_entries [3].product_id := cmv$system_device_data [device].unit_id;
    state_table_entries [3].logical_unit := cmc$job_template_unit_ordinal;
    state_table_entries [3].application_info_p := NIL;
    state_table_entries [3].site_info_p := NIL;
    state_table_entries [3].application_info_size := 0;
    state_table_entries [3].site_info_size := 0;
    cmp$build_state_table (3, state_table_entries, {use_mrt_state=} FALSE, status);

    { Retrieve the PP (driver) used to drive the equipment.

    { Build the PP and unit interface tables.

    IF cmv$iou_table_p = NIL THEN
      cmp$build_iou_table (v$number_of_ious, v$iou_information_table);
    IFEND;

    cmp$build_interface_tables (pp_count, 1, FALSE, cmv$logical_unit_table, cmv$logical_pp_table_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cmv$max_number_of_pp := pp_count;

    { Load the controlware from the CIP device to memory.

    cmp$load_controller_module (cmc$load_controlware, cmv$logical_pp_table_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Load the control module from the CIP device to memory.

    IF (unit_type = cmc$ms834_2) OR (unit_type=cmc$msfsd_2) THEN
      cmp$load_controller_module (cmc$load_control_module, cmv$logical_pp_table_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    { Retrieve the PP (driver) to drive the equipment.

    CASE cmv$logical_pp_table_p^ [1].controller_info.controller_type OF
    = cmc$ms7165_2x, cmc$mscm3_ct, cmc$mshydra_ct, cmc$ms7255_1_1, cmc$ms7255_1_2, cmc$mt7221_2_s0,
          cmc$ms5831_x, cmc$mt7221_1, cmc$mt5698_xx =
      unit_number := cmc$null_unit_number;
      equipment_number := cmc$null_equipment_number;
    ELSE
      IF (cmv$logical_pp_table_p^ [1].controller_info.controller_type = cmc$mt698_xx) AND
            (osv$170_os_type = osc$ot7_dual_state_nos_be) THEN
        unit_number := cmc$null_unit_number;
        equipment_number := cmc$null_equipment_number;
      ELSE
        unit_number := pc_entries [3].storage_device.physical_unit_number;
        equipment_number := pc_entries [2].controller.physical_equipment_number;
      IFEND;
    CASEND;

    cmp$convert_iou_name (pc_entries [1].data_channel.iou, iou, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    channel.number := pc_entries [1].data_channel.number;
    channel.port := pc_entries [1].data_channel.port;
    channel.concurrent := pc_entries [1].data_channel.concurrent;

    cmp$acquire_deadstart_resources (channel, iou, equipment_number, unit_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF unit_class = cmc$magnetic_tape_unit THEN
      iop$tape_initialization (cmv$logical_unit_table, status);
    ELSE
      PUSH physical_attributes_p: [1 .. 2];
      physical_attributes_p^ [1].keyword := dmc$bytes_per_mau;
      physical_attributes_p^ [2].keyword := dmc$maus_per_cylinder;
      dmp$get_physical_attributes (cmv$system_device_data [cmc$sdt_disk_device].unit_id,
            physical_attributes_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      osv$system_device_cylinder_size := physical_attributes_p^ [1].bytes_per_mau *
            physical_attributes_p^ [2].maus_per_cylinder;
    IFEND;

  PROCEND cmp$configure_deadstart_device;
?? TITLE := 'cmp$de_configure_ds_device', EJECT ??

{ PURPOSE:
{   This procedure frees all of the structures that were used to configure the devices.

  PROCEDURE [XDCL] cmp$de_configure_ds_device
    (VAR status: ost$status);

    VAR
      channel: cmt$physical_channel,
      controller_type: cmt$controller_type,
      ignore_status: ost$status,
      iou: dst$iou_number,
      logical_pp_index: iot$pp_number,
      pp_index: iot$pp_number;

    status.normal := TRUE;

    IF cmv$physical_configuration <> NIL THEN

      { Return the system device to the Real state.

      cmp$convert_iou_name (cmv$physical_configuration^ [1].data_channel.iou, iou, status);
      IF NOT status.normal THEN
        cmp$write_os_status (' ', status);
      IFEND;
      channel.number := cmv$physical_configuration^ [1].data_channel.number;
      channel.port := cmv$physical_configuration^ [1].data_channel.port;
      channel.concurrent := cmv$physical_configuration^ [1].data_channel.concurrent;
      cmp$get_logical_pp_index (cmv$physical_configuration^ [1], logical_pp_index, status);

      IF cmv$logical_pp_table_p^ [logical_pp_index].flags.resources_acquired THEN
        cmp$idle_pp_r1 (cmv$physical_configuration^ [1].element_name,
              cmv$physical_configuration^ [1].data_channel.iou, status);
        IF NOT status.normal THEN
          cmp$write_os_status (' ', status);
        IFEND;
        cmp$release_pp_by_index (logical_pp_index, status);
        IF NOT status.normal THEN
          cmp$write_os_status (' ', status);
        IFEND;
      IFEND;

      { Return the equipments.

      IF (cmv$physical_configuration^ [2].product_id.product_number = ' $7221') OR
            (cmv$physical_configuration^ [2].product_id.product_number = '$10395') OR
            (cmv$physical_configuration^ [2].product_id.product_number = ' $5698') OR
           ((cmv$physical_configuration^ [2].product_id.product_number = ' $5680') AND
            (osv$170_os_type = osc$ot7_dual_state_nos_be)) OR
            (cmv$physical_configuration^ [2].product_id.product_number = ' $5831') OR
            (cmv$physical_configuration^ [2].product_id.product_number = '$FA7B4') OR
            (cmv$physical_configuration^ [2].product_id.product_number = '$FA7B5') OR
            (cmv$physical_configuration^ [2].product_id.product_number = ' $7165') OR
            ((cmv$physical_configuration^ [2].product_id.product_number = '  $698') AND
            (osv$170_os_type = osc$ot7_dual_state_nos_be)) OR
            (cmv$physical_configuration^ [3].product_id.product_number = '  $887') THEN
        cmp$release_channel_resource (channel, iou, ignore_status);
      ELSE
        cmp$release_equipment_resource (channel, iou,
              cmv$physical_configuration^ [2].controller.physical_equipment_number,
              cmv$physical_configuration^ [3].storage_device.physical_unit_number);
      IFEND;

      { Free space in the heaps.

      FREE cmv$physical_configuration IN osv$mainframe_pageable_heap^;
    IFEND;

    IF cmv$state_info_table <> NIL THEN
      FREE cmv$state_info_table IN osv$mainframe_pageable_heap^;
    IFEND;

    { Free the tape structures.

    iop$free_boot_tape_tables;
    iop$free_tape_tables;

    { Free the iou table.

    IF cmv$iou_table_p <> NIL THEN
      FOR iou := LOWERBOUND (cmv$iou_table_p^) TO UPPERBOUND (cmv$iou_table_p^) DO
        IF cmv$iou_table_p^ [iou].configured THEN
          IF cmv$iou_table_p^ [iou].nio_channel_lock_p <> NIL THEN
            FREE cmv$iou_table_p^ [iou].nio_channel_lock_p IN osv$mainframe_wired_cb_heap^;
          IFEND;
          IF cmv$iou_table_p^ [iou].cio_channel_lock_p <> NIL THEN
            FREE cmv$iou_table_p^ [iou].cio_channel_lock_p IN osv$mainframe_wired_cb_heap^;
          IFEND;
        IFEND;
      FOREND;
      FREE cmv$iou_table_p IN osv$mainframe_wired_cb_heap^;
    IFEND;

    { Free the logical PP table.

    IF cmv$logical_pp_table_p <> NIL THEN
      FOR pp_index := 1 TO cmv$max_number_of_pp DO
        IF cmv$logical_pp_table_p^ [pp_index].flags.configured THEN
          cmv$logical_pp_table_p^ [pp_index].flags.configured := FALSE;
          IF cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p <> NIL THEN
            IF cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.response_buffer <> NIL THEN
              FREE cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p^.response_buffer IN
                    osv$mainframe_wired_cb_heap^;
            IFEND;
            FREE cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p IN
                  osv$mainframe_wired_cb_heap^;
          IFEND;
          IF cmv$logical_pp_table_p^ [pp_index].pp_info.pp_communication_buffer_p <> NIL THEN
            FREE cmv$logical_pp_table_p^ [pp_index].pp_info.pp_communication_buffer_p IN
                  osv$mainframe_wired_cb_heap^;
          IFEND;
        IFEND;
        cmv$logical_pp_table_p^ [pp_index].controller_info.controlware_loaded := FALSE;
        cmv$logical_pp_table_p^ [pp_index].controller_info.control_module_loaded := FALSE;
      FOREND;

      FOR controller_type := LOWERVALUE (cmt$controller_type) TO UPPERVALUE (cmt$controller_type) DO
        IF cmv$controller_location [controller_type].controlware_loaded THEN
          FREE cmv$controller_location [controller_type].controlware_location_p IN
                osv$mainframe_wired_cb_heap^;
          FREE cmv$controller_location [controller_type].controlware_rma_list_p IN
                osv$mainframe_wired_cb_heap^;
          cmv$controller_location [controller_type].controlware_loaded := FALSE;
          cmv$controller_location [controller_type].controlware_location_p := NIL;
          cmv$controller_location [controller_type].controlware_rma_list_p := NIL;
        IFEND;
        IF cmv$controller_location [controller_type].control_module_loaded THEN
          FREE cmv$controller_location [controller_type].control_module_location_p IN
                osv$mainframe_wired_cb_heap^;
          FREE cmv$controller_location [controller_type].control_module_rma_list_p IN
                osv$mainframe_wired_cb_heap^;
          cmv$controller_location [controller_type].control_module_loaded := FALSE;
          cmv$controller_location [controller_type].control_module_location_p := NIL;
          cmv$controller_location [controller_type].control_module_rma_list_p := NIL;
        IFEND;
      FOREND;
      FREE cmv$logical_pp_table_p IN osv$mainframe_wired_cb_heap^;
    IFEND;

    { Free the logical unit table.  System device is the second entry in the table, entry 1 is not used.

    IF cmv$logical_unit_table <> NIL THEN
      IF cmv$logical_unit_table^ [2].configured THEN
        IF cmv$logical_unit_table^ [2].unit_interface_table <> NIL THEN
          FREE cmv$logical_unit_table^ [2].unit_interface_table IN osv$mainframe_wired_cb_heap^;
        IFEND;
      IFEND;
      IF cmv$logical_unit_table^ [2].unit_communication_buffer_pva <> NIL THEN
        FREE cmv$logical_unit_table^ [2].unit_communication_buffer_pva IN osv$mainframe_wired_cb_heap^;
      IFEND;
      FREE cmv$logical_unit_table IN osv$mainframe_wired_cb_heap^;
    IFEND;

    cmp$free_element_def_table;

    cmv$max_number_of_pp := 0;

  PROCEND cmp$de_configure_ds_device;
?? TITLE := 'cmp$vcmb_menu_manager', EJECT ??

{ PURPOSE:
{   This procedure controls the displaying of the boot screens.

  PROCEDURE [XDCL] cmp$vcmb_menu_manager;

    VAR
      bucket_data_seq_p: ^SEQ ( * ),
      buckets: dst$vcu_bucket_data,
      device: cmt$system_device_types,
      element_entry: dst$mf_element_table_entry,
      force_menus: boolean,
      ignore_status: ost$status,
      password_data: dst$vcu_password_data,
      password_data_seq_p: ^SEQ ( * ),
      ssr_entry: dst$ssr_entry,
      status: ost$status,
      vcu_cda_seq_p: ^SEQ ( * ),
      vcu_version: dst$vcu_cda_version;

    { Get number of ious and iou information table.

    dsp$retrieve_iou_information (v$number_of_ious, v$iou_information_table);

    { Check for special model of 930 which limits system device to be a 9836 disk.

    dsp$retrieve_mf_element_entry (0, dsc$dftb_eid_cpu0_element, element_entry, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to obtain processor model type from MRT', ^status);
    IFEND;
    v$special_930_model := ((element_entry.model_number = osc$cyber_180_model_930a) OR
          (element_entry.model_number = osc$cyber_180_model_930b) OR
          (element_entry.model_number = osc$cyber_180_model_930c) OR
          (element_entry.model_number = osc$cyber_180_model_932a) OR
          (element_entry.model_number = osc$cyber_180_model_932b));

    setup_default_configuration;

    force_menus := FALSE;
    pmp$zero_out_table (^buckets, #SIZE (buckets));
    dsv$dcfile_identifier := 'DCF00';

    { Retrieve the version of VCU.  If the procedure returns bad status then most likely the CIP was
    { installed prior to this deadstart and VCU has not been created.  In this case, force the displaying
    { of the menus.

    vcu_cda_seq_p := #SEQ (vcu_version);
    dsp$access_vcu_cda_data (dsc$vcu_read_access, dsc$vcu_version, vcu_cda_seq_p, status);
    IF NOT status.normal OR (vcu_version <= dsc$vcu_131_or_earlier_system) THEN
      force_menus := TRUE;
      v$bucket_used := dsc$vcu_bt_tape_bucket;
      v$deadstart_device := cmc$sdt_tape_device;
      cmv$system_device_data [cmc$sdt_tape_device].specified := TRUE;
      cmv$system_device_data [cmc$sdt_disk_device].specified := TRUE;
      buckets [v$bucket_used][cmc$sdt_tape_device].specified := FALSE;
      buckets [v$bucket_used][cmc$sdt_disk_device].specified := FALSE;
      buckets [dsc$vcu_bt_disk_bucket][cmc$sdt_disk_device].dcfile_identifier := ' ';
      buckets [dsc$vcu_bt_cr_bucket][cmc$sdt_disk_device].dcfile_identifier := ' ';
      buckets [dsc$vcu_bt_tape_bucket][cmc$sdt_tape_device].dcfile_identifier := ' ';
      add_error_message ('DCFILE name is new to menu, enter correct value.');
      add_error_message ('Deadstart device unknown, tape device assumed.');

    ELSE

      { Retrieve the last bucket type used from VCU.

      IF vcu_version <= dsc$vcu_142_or_earlier_system THEN
        force_menus := TRUE;
        v$bucket_used := dsc$vcu_bt_tape_bucket;
        add_error_message ('Deadstart device unknown, tape device assumed.');
      ELSE
        vcu_cda_seq_p := #SEQ (v$bucket_used);
        dsp$access_vcu_cda_data (dsc$vcu_read_access, dsc$vcu_bucket_used, vcu_cda_seq_p, status);
        IF NOT status.normal THEN
          osp$system_error ('Unable to read bucket used data from CDA.', ^status);
        IFEND;
      IFEND;

      IF v$bucket_used = dsc$vcu_bt_tape_bucket THEN
        v$deadstart_device := cmc$sdt_tape_device;
      ELSE
        v$deadstart_device := cmc$sdt_disk_device;
      IFEND;

      { Retrieve the buckets from VCU.

      vcu_cda_seq_p := #SEQ (buckets);
      dsp$access_vcu_cda_data (dsc$vcu_read_access, dsc$vcu_bucket_data, vcu_cda_seq_p, status);
      IF NOT status.normal THEN
        osp$system_error ('Unable to read bucket data from CDA.', ^status);
      IFEND;
      IF vcu_version <= dsc$vcu_142_or_earlier_system THEN
        buckets [dsc$vcu_bt_disk_bucket][cmc$sdt_disk_device].dcfile_identifier := ' ';
        buckets [dsc$vcu_bt_cr_bucket][cmc$sdt_disk_device].dcfile_identifier := ' ';
        buckets [dsc$vcu_bt_tape_bucket][cmc$sdt_tape_device].dcfile_identifier := ' ';
      IFEND;
      retrieve_bucket_information (buckets, force_menus);

      { Force the initialization of the interval and password if an earlier system had been deadstarted.
      { On China mainframes, do not continue with the deadstart.  Force the initialization of the CIP
      { otherwise, the security can be breached by loading an old boot and then loading the new boot
      { and entering one's own password and interval.

      IF vcu_version <= dsc$vcu_153_or_earlier_system THEN
        IF dsv$sub_mainframe_type = dsc$smt_china_mainframe THEN
          osp$system_error ('Earlier boot use detected, unable to proceed.', ^status);
        IFEND;
        password_data.password_initialized := FALSE;
        password_data.interval_initialized := FALSE;
        password_data.interval_expired := FALSE;
        password_data_seq_p := #SEQ (password_data);
        dsp$access_vcu_cda_data (dsc$vcu_write_access, dsc$vcu_password_data, password_data_seq_p, status);
        IF NOT status.normal THEN
          osp$system_error ('Unable to write password data to CDA.', ^status);
        IFEND;
      IFEND;
    IFEND;

    { Get the operator intervention flag from the SSR.

    dsp$get_entry_from_ssr (dsc$ssr_operator_intervention, ssr_entry);
    v$operator_intervention := (ssr_entry.whole_slot = 1);
    force_menus := force_menus OR v$operator_intervention;

    { Attempt validation if it is not necessary to force the menus.

    IF NOT force_menus AND v$first_time_menu_called AND
          buckets [v$bucket_used][v$deadstart_device].specified THEN
      v$first_time_menu_called := FALSE;
      attempt_validation (buckets, status);
      IF status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    dpp$open_window (dpc$wc_sharing, dpc$wk_table, 'Deadstart and Storage Device Configuration Selections',
          v$menu_window_id, ignore_status);

    v$first_time_menu_called := FALSE;
    IF NOT buckets [v$bucket_used][v$deadstart_device].specified THEN
      add_error_message ('** NOTE:  The system device path has not yet been defined.');
    IFEND;

    REPEAT
      access_menu_display (buckets);
      attempt_validation (buckets, status);
    UNTIL status.normal;
    dpp$close_window (v$menu_window_id, ignore_status);

  PROCEND cmp$vcmb_menu_manager;
?? TITLE := 'cmp$write_os_status', EJECT ??

{ PURPOSE:
{   This procedure displays a status message to the console.
{ DESIGN:
{   Since the console line is only 80 characters long, the procedure makes sure that the message is totally
{   displayed by breaking up the message into strings of 80 characters or less and displaying each string.

  PROCEDURE [XDCL] cmp$write_os_status
    (    text: string ( * );
         status: ost$status);

    VAR
      identifier: ost$status_identifier,
      ignore_status: ost$status,
      integer_string: ost$string,
      message: string (dpc$console_row_size),
      message_length: dpt$console_row_size,
      number: ost$status_condition_number,
      status_index: integer,
      status_message: ost$string,
      status_size: integer;

    add_error_message (text);
    IF status.text.size <= 0 THEN
      RETURN;
    IFEND;

    status_message.value := 'ERROR: ';
    status_message.size := 8;
    osp$unpack_status_condition (status.condition, identifier, number);
    status_message.value (status_message.size, #SIZE (identifier)) := identifier;
    status_message.size := status_message.size + #SIZE (identifier) + 1;
    clp$convert_integer_to_string (number, 10, FALSE, integer_string, ignore_status);
    status_message.value (status_message.size, integer_string.size) := integer_string.value;
    status_message.size := status_message.size + integer_string.size;
    status_message.value (status_message.size + 1, *) := status.text.value;
    status_message.size := status_message.size + status.text.size;

    status_size := status_message.size;
    status_index := 1;
    WHILE status_size > 0 DO
      IF status_size > dpc$console_row_size THEN
        message_length := dpc$console_row_size;
      ELSE
        message_length := status_size;
      IFEND;
      message := status_message.value (status_index, message_length);
      add_error_message (message);
      dpp$put_next_line (dpv$system_core_display, message, ignore_status);
      dpp$put_critical_message (message, ignore_status);
      status_index := status_index + message_length;
      status_size := status_size - message_length;
    WHILEND;

  PROCEND cmp$write_os_status;
MODEND cmm$vcmb_interfaces;
*DECK DECK=CMM$VED_DISPLAY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Configuration Management : VED PA Display' ??
MODULE cmm$ved_display;

{ PURPOSE:
{   This Module allows the use of the VED display command to display PP assignment in NOS/VE.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$put_display
*copyc dpp$put_next_line
*copyc dpp$clear_window
*copyc ofp$open_display
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
?? EJECT ??
*copyc cmv$logical_pp_table_p
*copyc cmv$sci_dft_pp
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    t$display_line = RECORD
      CASE boolean OF
      = TRUE =
        line: string (80),
      = FALSE =
        iou: string (3),
        space_1: string (2),
        pp: string (5),
        space_2: string (2),
        state: string (5),
        space_3: string (2),
        ssn: string (31),
        space_4: string (2),
        iou_program: string (11),
        space_5: string (2),
        line_end: t$end_of_display_line,
      CASEND,
    RECEND,

    t$end_of_display_line = RECORD
      CASE boolean OF
      = TRUE =
        data: string (15),
      = FALSE =
        channel: string (6),
        space_6: string (1),
        message: string (8),
      CASEND,
    RECEND;
?? OLDTITLE ??
?? NEWTITLE := 'put_display_line ', EJECT ??

{ PURPOSE:
{   This procedure builds a line containing the PP information and places the line on the display.

  PROCEDURE put_display_line
     (   pp_index: iot$pp_number;
         window_id: dpt$window_id;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      active_unit: boolean,
      channel_size: 0 .. 0ff(16),
      display_line: t$display_line,
      ignore_status: ost$status,
      index: iot$logical_unit,
      integer_string: ost$string,
      ppit_p: ^iot$pp_interface_table;

    display_line.line := ' ';
    clp$convert_integer_to_string (cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp.iou_number,
          8, FALSE, integer_string, ignore_status);
    display_line.iou := integer_string.value (1, integer_string.size);

    clp$convert_integer_to_string (cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp.number,
          8, FALSE, integer_string, ignore_status);
    IF cmv$logical_pp_table_p^ [pp_index].pp_info.physical_pp.channel_protocol = dsc$cpt_cio THEN
      display_line.pp := 'CPP';
      display_line.pp (4, 2) := integer_string.value (1, integer_string.size);
    ELSE
      display_line.pp := 'PP';
      display_line.pp (3, 2) := integer_string.value (1, integer_string.size);
    IFEND;

    display_line.state := 'ON';
    IF cmv$logical_pp_table_p^ [pp_index].flags.entry_reserved_by_nosve THEN
      display_line.ssn := '$SYSTEM';
    ELSEIF cmv$logical_pp_table_p^ [pp_index].flags.entry_reserved_by_other THEN
      display_line.ssn := cmv$logical_pp_table_p^ [pp_index].task_info.reserved_job_name;
    ELSE
      display_line.ssn := ' ';
    IFEND;
    display_line.iou_program := cmv$logical_pp_table_p^ [pp_index].pp_info.driver_name;

    IF cmv$logical_pp_table_p^ [pp_index].flags.entry_reserved_by_nosve OR
          cmv$logical_pp_table_p^ [pp_index].flags.reservd_by_other_has_ch_present THEN
      channel_size := 1;
      IF cmv$logical_pp_table_p^ [pp_index].pp_info.channel.channel_protocol = dsc$cpt_cio THEN
        display_line.line_end.channel (channel_size, 3) := 'CCH';
        channel_size := channel_size + 3;
      ELSE
        display_line.line_end.channel (channel_size, 2) := 'CH';
        channel_size := channel_size + 2;
      IFEND;
      clp$convert_integer_to_string (cmv$logical_pp_table_p^ [pp_index].pp_info.channel.number,
            8, FALSE, integer_string, ignore_status);
      display_line.line_end.channel (channel_size, integer_string.size) :=
            integer_string.value (1, integer_string.size);
      channel_size := channel_size + integer_string.size;

      IF NOT cmv$logical_pp_table_p^ [pp_index].flags.pp_hung AND
            ((cmv$logical_pp_table_p^ [pp_index].pp_info.pp_type = cmc$lpt_disk_pp_type) OR
            (cmv$logical_pp_table_p^ [pp_index].pp_info.pp_type = cmc$lpt_tape_pp_type)) THEN
        active_unit := FALSE;
        ppit_p := cmv$logical_pp_table_p^ [pp_index].pp_info.pp_interface_table_p;

       /search_for_active_unit/
        FOR index := LOWERBOUND (ppit_p^.unit_descriptors) TO UPPERBOUND (ppit_p^.unit_descriptors) DO
          IF ppit_p^.unit_descriptors [index].unit_interface_table_rma <> 0 THEN
            active_unit := TRUE;
            EXIT /search_for_active_unit/;
          IFEND;
        FOREND /search_for_active_unit/;
        IF NOT active_unit THEN
          display_line.line_end.message := 'Inactive';
        IFEND;
      IFEND;
    IFEND;

    IF cmv$logical_pp_table_p^ [pp_index].flags.pp_hung THEN
      display_line.line_end.message := 'PP Hung';
    IFEND;

    IF window_id = 0 THEN
      clp$put_display (display_control, display_line.line, clc$trim, status);
    ELSE
      dpp$put_next_line (window_id, display_line.line, status);
    IFEND;

  PROCEND put_display_line;
?? OLDTITLE ??
?? NEWTITLE := 'put_standard_pp_line ', EJECT ??

{ PURPOSE:
{   This procedure builds a line containing the PP information for DFT and SCI and places the line on
{   the display.

  PROCEDURE put_standard_pp_line
     (   pp: dst$iou_resource;
         driver_name: dst$driver_name;
         window_id: dpt$window_id;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    CONST
      c$job_name = '$SYSTEM';

    VAR
      display_line: t$display_line,
      ignore_status: ost$status,
      integer_string: ost$string;

    display_line.line := ' ';
    clp$convert_integer_to_string (pp.iou_number, 8, FALSE, integer_string, ignore_status);
    display_line.iou := integer_string.value (1, integer_string.size);

    clp$convert_integer_to_string (pp.number, 8, FALSE, integer_string, ignore_status);
    IF pp.channel_protocol = dsc$cpt_cio THEN
      display_line.pp := 'CPP';
      display_line.pp (4, 2) := integer_string.value (1, integer_string.size);
    ELSE
      display_line.pp := 'PP';
      display_line.pp (3, 2) := integer_string.value (1, integer_string.size);
    IFEND;

    display_line.state := 'ON';
    display_line.ssn := c$job_name;
    display_line.iou_program := driver_name;

    IF window_id = 0 THEN
      clp$put_display (display_control, display_line.line, clc$trim, status);
    ELSE
      dpp$put_next_line (window_id, display_line.line, status);
    IFEND;

  PROCEND put_standard_pp_line;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$ved_display_pp', EJECT ??

{ PURPOSE:
{   This procedure displays NOS/VE PP assignment to the System Console.

  PROCEDURE [XDCL, #GATE] cmp$ved_display_pp
    (    window_id: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure provides clean-up processing when a task abort occurs.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF window_id = 0 THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    CONST
      c$dft_driver_name = 'DFT    ',
      c$dfts_driver_name = 'DFT-S  ',
      c$sci_driver_name = 'SCI    ';

    VAR
      display_control: clt$display_control,
      display_line: t$display_line,
      ignore_status: ost$status,
      index: iot$pp_number,
      title: t$display_line;

    status.normal := TRUE;

    IF window_id = 0 THEN
      osp$establish_block_exit_hndlr (^abort_handler);
    IFEND;

    IF initial_call THEN
      title.line := ' ';
      title.iou := 'IOU';
      title.pp := 'PP(8)';
      title.state := 'State';
      title.ssn := 'SSN';
      title.iou_program := 'IOU Program';
      title.line_end.data := 'Channel(8)';
      ofp$open_display (file_name, window_id, dpc$wc_sharing, dpc$wk_table, title.line, display_control,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  /display_opened/
    BEGIN
      IF window_id = 0 THEN
        display_line.line := ' ';
        clp$put_display (display_control, display_line.line, clc$trim, status);
      ELSE
        dpp$clear_window (window_id, status);
      IFEND;
      IF NOT status.normal THEN
        EXIT /display_opened/;
      IFEND;

      { Display the SCI PP information.

      put_standard_pp_line (cmv$sci_dft_pp.sci_pp, c$sci_driver_name, window_id, display_control, status);
      IF NOT status.normal THEN
        EXIT /display_opened/;
      IFEND;

      { Display the DFT PP information, if such information exists.

      IF cmv$sci_dft_pp.primary_dft_available THEN
        put_standard_pp_line (cmv$sci_dft_pp.primary_dft_pp, c$dft_driver_name, window_id, display_control,
              status);
        IF NOT status.normal THEN
          EXIT /display_opened/;
        IFEND;
      IFEND;

      { Display the secondary DFT PP information, if such information exists.

      IF cmv$sci_dft_pp.secondary_dft_available THEN
        put_standard_pp_line (cmv$sci_dft_pp.secondary_dft_pp, c$dfts_driver_name, window_id, display_control,
              status);
        IF NOT status.normal THEN
          EXIT /display_opened/;
        IFEND;
      IFEND;

      { Display the other PP information.  Search Logical PP Table for the information.

      FOR index := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
        IF cmv$logical_pp_table_p^ [index].flags.configured AND
              cmv$logical_pp_table_p^ [index].flags.resources_acquired THEN
          put_display_line (index, window_id, display_control, status);
          IF NOT status.normal THEN
            EXIT /display_opened/;
          IFEND;
        IFEND;
      FOREND;

    END /display_opened/;

    IF window_id = 0 THEN
      clp$close_display (display_control, ignore_status);
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND cmp$ved_display_pp;
MODEND cmm$ved_display;
*DECK DECK=CMM$VED_DISPLAY_CONF EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Configuration Management : VED DS Display' ??
MODULE cmm$ved_display_conf;

{ PURPOSE:
{   This module resides in OSF$JOB_TEMPLATE_223 and allows the use of the VED display command to display
{   configuration status.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH(LISTEXT := ON) ??
*copyc cld$value
*copyc cme$physical_configuration_mgr
*copyc cmt$device_status_display
*copyc clt$display_control
*copyc jmt$system_supplied_name
*copyc ost$status
*copyc pmp$get_mainframe_id
*copyc ost$string
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc cmp$count_con_access_job
*copyc cmp$get_element_state
*copyc clp$new_display_line
*copyc cmp$pc_get_element
*copyc clp$put_display
*copyc cmp$search_active_volume_table
*copyc cmp$search_peripheral_table
*copyc dpp$put_next_line
*copyc dpp$clear_window
*copyc ofp$open_display
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc cmv$peripheral_element_table
*copyc cmv$physical_configuration
*copyc cmv$logical_unit_table
*copyc cmv$state_info_table
*copyc cmv$pp_element_table
*copyc iov$tusl_p
*copyc osv$task_private_heap
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc oss$task_private
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    cmv$device_status :[XDCL, #GATE] ^array [1 .. *] of cmt$device_status_display := NIL;

?? OLDTITLE ??
?? NEWTITLE := 'cmp$ved_display_configuration',EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$ved_display_configuration
    (    wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure provides clean-up processing when a task abort or a task exit occurs.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF cmv$device_status <> NIL THEN
        FREE cmv$device_status IN osv$task_private_heap^;
      IFEND;
      IF wid = 0 THEN
        clp$close_display (display_control, ignore);
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      display_control : clt$display_control,
      display_line: string (80),
      element_desc : cmt$element_descriptor,
      element_res : cmt$element_reservation,
      table_index,
      jc : integer,
      i : integer,
      index : integer,
      str : ost$string,
      iou_name : cmt$element_name,
      ignore : ost$status,
      state : cmt$element_state,
      lun : iot$logical_unit,
      search_key : dmt$avt_search_key,
      entry_type : rmt$device_class,
      external_vsn : rmt$external_vsn,
      recorded_vsn : rmt$recorded_vsn,
      avt_entry_not_found : boolean,
      current_mainframe : pmt$mainframe_id,
      title: [READ, oss$job_paged_literal] string (80) :=
            'Name(14 chars) Product State UN(8) Iou/Channels          VSN    QC    MAC LUN FF';

    VAR
      default_state_names : [STATIC,READ,oss$job_paged_literal] array
          [cmt$element_state] of string(4) := ['ON  ','OFF ','DOWN'];

    status.normal := TRUE;

    pmp$get_mainframe_id (current_mainframe, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    find_all_device_info (current_mainframe, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF wid=0 THEN
      osp$establish_block_exit_hndlr (^abort_handler);
    IFEND;
    IF initial_call THEN
      ofp$open_display (file_name, wid, dpc$wc_sharing, dpc$wk_table, title, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  /display_open/
    BEGIN
      IF wid=0 THEN
        display_line (1,*) := '   ';
        clp$put_display (display_control, display_line, clc$trim, status);
      ELSE
        dpp$clear_window (wid, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    /display_element/
      FOR index := LOWERBOUND(cmv$device_status^) TO
           UPPERBOUND(cmv$device_status^) DO
        display_line (1, *) := '   ';
        display_line (1, 14) := cmv$device_status^[index].element_name;
        IF cmv$device_status^[index].element_name (15, 1) <> ' ' THEN
          display_line (15, 2) := '..';
        IFEND;
        form_product_string (cmv$device_status^[index].product_number,
                    str);
        display_line (17, 6) := str.value (1, 6);
        cmp$get_element_state (cmv$device_status^[index].element_name,
            {unused} iou_name, state, ignore);
        display_line (24, 4) := default_state_names [state];

        clp$convert_integer_to_string (cmv$device_status^[index].physical_address, 8,
            FALSE, str, ignore);
        display_line (30, 3) := str.value (1, str.size);
        display_line (34, 4) := cmv$device_status^[index].channels [1].iou;
        display_line (38, 1) := '/';
        display_line (39, 6) := cmv$device_status^[index].channels [1].name;
        IF cmv$device_status^[index].channels [2].name <> ' ' THEN
          display_line (46, 4) := cmv$device_status^[index].channels [2].iou;
          display_line (50, 1) := '/';
          display_line (51, 6) := cmv$device_status^[index].channels [2].name;
        IFEND;
      /loop/
        FOR i := LOWERBOUND(cmv$state_info_table^) TO UPPERBOUND(cmv$state_info_table^) DO
          IF (cmv$state_info_table^[i].element_name = cmv$device_status^[index].element_name) AND
             (cmv$state_info_table^[i].element_type <> cmc$data_channel_element) THEN
            lun := cmv$state_info_table^[i].logical_unit;
            EXIT /loop/;
          IFEND;
        FOREND /loop/;
        IF lun <> 0 THEN
          clp$convert_integer_to_string (lun, 10, FALSE, str, ignore);
          display_line (75, 4) := str.value (1, str.size);
          IF cmv$logical_unit_table^ [lun].configured AND
               (cmv$logical_unit_table^ [lun].unit_interface_table^.unit_type <= ioc$highest_tape_unit) THEN
           /search_tusl_for_evsn/
            FOR i := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
              IF (cmv$device_status^ [index].element_name = iov$tusl_p^ [i].element_name) AND
                    (iov$tusl_p^ [i].assignment_state <> ioc$not_assigned) THEN
                display_line (58, 6) := iov$tusl_p^ [i].evsn;
                EXIT /search_tusl_for_evsn/;
              IFEND;
            FOREND /search_tusl_for_evsn/;
          ELSE
            search_key.value := dmc$search_avt_by_lun;
            search_key.logical_unit_number := lun;
            cmp$search_active_volume_table (search_key, recorded_vsn, avt_entry_not_found);
            IF NOT avt_entry_not_found THEN
              display_line (58, 6) :=  recorded_vsn;
              IF cmv$logical_unit_table^[lun].configured THEN
                clp$convert_integer_to_string (cmv$logical_unit_table^[lun].
                 unit_interface_table^.queue_count, 10, FALSE, str, ignore);
                display_line (65, 5) := str.value (1, str.size);
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        IF lun <> 0   THEN
          IF cmv$device_status^ [index].element_type = cmc$storage_device_element THEN
            IF (cmv$logical_unit_table ^[lun].unit_interface_table <> NIL) THEN
              CASE cmv$logical_unit_table ^[lun].unit_interface_table^.unit_type OF
              = ioc$dt_ms5833_1p, ioc$dt_ms5833_3p, ioc$dt_ms5838_1p,
                ioc$dt_ms5838_3p, ioc$dt_ms47444_1p, ioc$dt_ms47444_3p =
                IF cmv$logical_unit_table ^[lun].unit_interface_table^.unit_status.force_format THEN
                  display_line (79, 1) := 'T';
                ELSE
                  display_line (79, 1) := 'F';
                IFEND;
              ELSE
                ;
              CASEND;
            IFEND;
          IFEND;
        IFEND;

        element_desc.element_type := cmv$device_status^[index].element_type;
        element_desc.peripheral_descriptor.use_logical_identification := TRUE;
        element_desc.peripheral_descriptor.element_name := cmv$device_status^
                     [index].element_name;
        cmp$search_peripheral_table (element_desc, element_res, FALSE,
          table_index, ignore);
        IF ignore.normal THEN
          CASE cmv$peripheral_element_table.pointer^[table_index].
                    maintenance_activity.access OF
          = msc$concurrent_access =
            cmp$count_con_access_job (table_index, jc, ignore);
            clp$convert_integer_to_string (jc, 10, FALSE, str, ignore);
            display_line (71, 4) := str.value (1, str.size);
          = msc$dedicated_access =
            display_line (71, 1) := 'D';
          ELSE
            ;
          CASEND;
        IFEND;
        IF display_line <> '   ' THEN
          IF wid = 0 THEN
            clp$put_display (display_control, display_line, clc$trim, status);
          ELSE
            dpp$put_next_line (wid, display_line, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      FOREND /display_element/;

    END /display_open/;

    IF cmv$device_status <> NIL THEN
      FREE cmv$device_status IN osv$task_private_heap^;
    IFEND;

    IF wid = 0 THEN
      clp$close_display (display_control, status);
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND cmp$ved_display_configuration;
?? OLDTITLE ??
?? NEWTITLE := 'find_all_device_info', EJECT ??

{ PURPOSE:
{   This procedure scans the active physical configuration to build an array of device information to be
{   displayed on the system console.

  PROCEDURE find_all_device_info
    (     current_mainframe: pmt$mainframe_id;
      VAR status : ost$status);

      VAR
        ignore : ost$status,
        element_definition : cmt$element_definition,
        ch_element,
        element : ^cmt$element_definition,
        count,
        table_index,
        i,
        j,
        start : integer,
        iou_name : cmt$element_name,
        eq : cmt$physical_equipment_number,
        cm_port : cmt$communications_port_number,
        ct_port : cmt$controller_port_number,
        port : cmt$data_storage_port_number;

        count := 0;
        FOR i := 1 TO UPPERBOUND(cmv$physical_configuration^) DO
          IF (cmv$physical_configuration^[i].element_type <> cmc$data_channel_element) THEN
            count := count + 1;
          IFEND;
        FOREND;
  {
  { Value of COUNT should never be zero.
  {
        IF cmv$device_status <> NIL THEN
          FREE cmv$device_status IN osv$task_private_heap^;
        IFEND;

        ALLOCATE cmv$device_status : [1 .. count] IN osv$task_private_heap^;
        FOR i := 1 TO count DO
          FOR j := 1 TO 2 DO
            cmv$device_status^[i].channels [j].iou := '    ';
            cmv$device_status^[i].channels [j].name := '      ';
          FOREND;
        FOREND;
        table_index := 0;
        FOR i := 1 TO UPPERBOUND(cmv$physical_configuration^) DO

          IF (cmv$physical_configuration^[i].element_type <> cmc$data_channel_element) THEN
            table_index := table_index + 1;
            start := 1;
            element_definition := cmv$physical_configuration^[i];
            cmv$device_status^[table_index].element_name := element_definition.element_name;
            cmv$device_status^[table_index].element_type := element_definition.element_type;
            cmv$device_status^[table_index].product_number := element_definition.
                 product_id.product_number;
            CASE element_definition.element_type OF

            = cmc$storage_device_element =
              cmv$device_status^[table_index].physical_address :=
                 element_definition.storage_device.physical_unit_number;
              /loop/
              FOR port := LOWERVALUE(cmt$data_storage_port_number) TO
                    UPPERVALUE(cmt$data_storage_port_number) DO
                IF start > 2 THEN
                  EXIT /loop/;
                IFEND;
                IF element_definition.storage_device.connection.port[port].configured THEN
                  IF element_definition.storage_device.connection.port [port].
                        upline_connection_type = cmc$data_channel_element THEN
                    iou_name := element_definition.storage_device.connection.port [port].iou;
                  IFEND;
                  cmp$pc_get_element (element_definition.storage_device.connection.port[port].
                     element_name, iou_name, element, ignore);
                  IF NOT ignore.normal THEN
                    CYCLE /loop/;
                  IFEND;
                  IF element^.element_type = cmc$controller_element THEN
                   /inner_loop/
                    FOR ct_port := LOWERVALUE(cmt$controller_port_number) TO
                           UPPERVALUE(cmt$controller_port_number) DO
                      IF (element^.controller.connection.port[ct_port].configured)
                           AND (element^.controller.connection.port [ct_port].
                             mainframe_ownership = current_mainframe) THEN
                        cmp$pc_get_element (element^.controller.connection.port[ct_port].element_name,
                           element^.controller.connection.port[ct_port].iou,
                                  ch_element, ignore);
                        IF NOT ignore.normal THEN
                          CYCLE /inner_loop/;
                        IFEND;
                        IF ch_element^.element_type = cmc$data_channel_element THEN
                          cmv$device_status^ [table_index].channels [start].name := element^.
                                controller.connection.port [ct_port].element_name (1, 6);
                          cmv$device_status^ [table_index].channels [start].iou := element^.
                                controller.connection.port [ct_port].iou (1, 4);
                          start := start + 1;
                        IFEND;
                      IFEND;
                    FOREND /inner_loop/;

                  ELSE
                    IF element^.data_channel.mainframe_ownership = current_mainframe THEN
                      cmv$device_status^ [table_index].channels [start].name := element^.element_name (1, 6);
                      cmv$device_status^ [table_index].channels [start].iou := element^.
                            data_channel.iou (1, 4);
                      start := start + 1;
                    IFEND;
                  IFEND;
                IFEND;
              FOREND /loop/;

            = cmc$communications_element =
              cmv$device_status^[table_index].physical_address :=
                 element_definition.communications_element.physical_equipment_number;

              /loop1/
              FOR cm_port := LOWERVALUE(cmt$communications_port_number) TO
                       UPPERVALUE(cmt$communications_port_number) DO

                IF (start > 2) THEN
                  EXIT /loop1/;
                IFEND;
                IF (element_definition.communications_element.connection.port [cm_port].
                    configured) AND (element_definition.communications_element.
                    connection.port [cm_port].mainframe_ownership = current_mainframe) THEN
                  cmp$pc_get_element (element_definition.communications_element.
                      connection.port [cm_port].element_name,
                     element_definition.communications_element.connection.port [cm_port]
                       .iou, ch_element, ignore);
                  IF NOT status.normal THEN
                    CYCLE /loop1/;
                  IFEND;
                  IF ch_element^.element_type = cmc$data_channel_element THEN
                    cmv$device_status^ [table_index].channels [start].name := element_definition.
                         communications_element.connection.port [cm_port].element_name (1, 6);
                    cmv$device_status^ [table_index].channels [start].iou := element_definition.
                         communications_element.connection.port [cm_port].iou (1, 4);
                    start := start + 1;
                  IFEND;
                IFEND;
              FOREND /loop1/;

            = cmc$channel_adapter_element =
              cmv$device_status^ [table_index].physical_address :=
                  element_definition.channel_adapter.physical_equipment_number;
              IF element_definition.channel_adapter.connection.channel.configured THEN
                cmv$device_status^ [table_index].channels [1].name := element_definition.channel_adapter.
                     connection.channel.element_name (1, 6);
                cmv$device_status^[table_index].channels[1].iou := element_definition.channel_adapter.
                     connection.channel.iou (1, 4);
              IFEND;

            = cmc$external_processor_element =
              cmv$device_status^ [table_index].physical_address :=
                  element_definition.external_processor.physical_equipment_number;

               /loop2/
              FOR eq := LOWERVALUE(cmt$physical_equipment_number) TO UPPERVALUE(cmt$physical_equipment_number)
                     DO
                IF start > 2 THEN
                  EXIT /loop2/;
                IFEND;
                IF element_definition.external_processor.connection.io_port[eq].configured THEN

                  cmp$pc_get_element (element_definition.external_processor.
                      connection.io_port [eq].element_name,
                    element_definition.external_processor.connection.io_port [eq].iou,
                       ch_element, ignore);
                  IF NOT ignore.normal THEN
                    CYCLE /loop2/;
                  IFEND;
                  cmv$device_status^ [table_index].channels [start].name := element_definition.
                         external_processor.connection.io_port[eq].element_name (1, 6);
                  cmv$device_status^ [table_index].channels [start].iou := element_definition.
                         external_processor.connection.io_port [eq].iou (1, 4);
                  start := start + 1;
                IFEND;
              FOREND /loop2/;

            = cmc$controller_element =
              cmv$device_status^ [table_index].physical_address :=
                  element_definition.controller.physical_equipment_number;

              /loop3/
              FOR cm_port := LOWERVALUE(cmt$controller_port_number) TO
                       UPPERVALUE(cmt$controller_port_number) DO
                IF (start > 2) THEN
                  EXIT /loop3/;
                IFEND;
                IF element_definition.controller.connection.port[cm_port].configured THEN
                  cmv$device_status^ [table_index].channels [start].name := element_definition.controller.
                     connection.port[cm_port].element_name (1, 6);
                  cmv$device_status^ [table_index].channels[start].iou := element_definition.controller.
                     connection.port[cm_port].iou (1, 4);
                  start := start + 1;
                IFEND;
              FOREND /loop3/;

            ELSE
               ;
            CASEND;

          IFEND;

        FOREND;

    PROCEND find_all_device_info;
?? OLDTITLE ??
?? NEWTITLE := 'form_product_string',EJECT ??

  PROCEDURE form_product_string
    (    product_number: string (6);
     VAR pid_string: ost$string);

    VAR
      i: 0 .. 0ff(16),
      j: 0 .. 0ff(16);

    pid_string.value := ' ';
    pid_string.size := 0;
    i := 1;
    j := 1;
    WHILE (i <= 6 ) DO
      IF (product_number (i, 1) <> ' ') AND (product_number (i, 1) <> '$') THEN
        pid_string.value (j, 1) := product_number (i, 1);
        j := j + 1;
      IFEND;
      i := i + 1;
    WHILEND;
    pid_string.size := j;

  PROCEND form_product_string;
?? OLDTITLE ??
MODEND cmm$ved_display_conf;
*DECK DECK=CMP$$ELEMENT_DEFINITION EXPAND=FALSE

  PROCEDURE [XREF] cmp$$element_definition
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);
*DECK DECK=CMP$ACQUIRE_ALL_PERIPHERALS EXPAND=FALSE

  PROCEDURE [XREF] cmp$acquire_all_peripherals
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$ACQUIRE_ALL_PERIPHERALS_R1 EXPAND=FALSE

  PROCEDURE [XREF] cmp$acquire_all_peripherals_r1
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$ACQUIRE_ALL_RESOURCES EXPAND=FALSE
*DECK DECK=CMP$ACQUIRE_DEADSTART_RESOURCES EXPAND=FALSE

  PROCEDURE [XREF] cmp$acquire_deadstart_resources
    (    channel: cmt$physical_channel;
         iou_number: dst$iou_number;
         equipment_number: 0 .. cmc$null_equipment_number;
         unit_number: 0 .. cmc$null_unit_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmd$null_equipment_number
*copyc cmt$channel_type
*copyc cmt$element_name
*copyc cmt$logical_pp_table
*copyc cmt$physical_channel
*copyc cmt$physical_equipment_number
*copyc cmt$physical_unit_number
*copyc dst$iou_number
*copyc ost$hardware_subranges
*copyc ost$status
?? POP ??
*DECK DECK=CMP$ACQUIRE_RESOURCES EXPAND=FALSE

  PROCEDURE [XREF] cmp$acquire_resources
    (    request_type: dst$resource_request_types;
         number: cmt$physical_channel;
         iou_number: dst$iou_number;
         equipment_number: 0 .. cmc$null_equipment_number;
         unit_number: 0 .. cmc$null_unit_number;
         driver_pp: boolean;
         specific_pp: boolean;
         get_pp_by_channel: boolean;
     VAR physical_pp: dst$iou_resource;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmd$null_equipment_number
*copyc cmt$physical_channel
*copyc dst$iou_resource
*copyc dst$resource_request
*copyc ost$status
?? POP ??
*DECK DECK=CMP$ACQUIRE_SYSTEM_DEVICE EXPAND=FALSE

{ COMMON DECK CMXASD }

  PROCEDURE [XREF] cmp$acquire_system_device (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$ACTION_OPERATOR EXPAND=FALSE

  PROCEDURE [XREF] cmp$action_operator (
      request: ost$status;
    VAR reply: ost$string;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=CMP$ACTIVATE_CONFIGURATION EXPAND=TRUE
PROCEDURE (HIDDEN) cmp$activate_configuration (
  deadstart_phase, dp: key
      installation, reinstallation, continuation
    keyend = $optional
  operator_intervention_required, oir: boolean = $required
  prolog_procedure_name, ppn: name = $required
  operator_intervention_occurred, oio: (VAR) boolean = $required
  status)

"$FORMAT=OFF
VAR
   ignore_status: status
   intervene: boolean=operator_intervention_required
   local_status: status
   prolog_status: status
   utility_status: status
VAREND

"$FORMAT=ON

  IF prolog_procedure_name <> none THEN
    IF deadstart_phase = installation THEN
      LOGICAL_CONFIGURATION_UTILITY status=utility_status
        cmp$execute_prolog_commands ..
              prolog_procedure_name=prolog_procedure_name ..
              prolog_file=lcu_mainframe_subcommands status=prolog_status
      QUIT
      IF NOT prolog_status.normal THEN
        rap$display_message message_module=sysdp_messages ..
              message_name=report_prolog_error ..
              message_parameters=$string(prolog_procedure_name) to=$output
        display_value prolog_status o=$output
        intervene = true
      IFEND
      IF NOT utility_status.normal THEN
        rap$display_message message_module=sysdp_messages ..
              message_name=report_lcu_error ..
              message_parameters=$string(prolog_procedure_name) to=$output
        display_value utility_status o=$output
        intervene = true
      IFEND
    ELSEIF deadstart_phase = reinstallation THEN
      rap$display_message message_module=sysdp_messages ..
            message_name=report_prolog_suppressed to=$output
    IFEND
  IFEND

  IF intervene THEN
    cmp$perform_lcu_intervention deadstart_phase=deadstart_phase ..
          status=ignore_status
  ELSEIF deadstart_phase <> installation THEN
    LOGICAL_CONFIGURATION_UTILITY status=local_status
    QUIT
    IF local_status.normal THEN
      rap$display_message message_module=sysdp_messages ..
            message_name= configuration_activated to=$output
    ELSE
      intervene = true
      rap$display_message message_module=sysdp_messages ..
            message_name=report_lcu_error to=$output
      display_value local_status o=$output
      cmp$perform_lcu_intervention deadstart_phase=deadstart_phase ..
            status=ignore_status
    IFEND
  IFEND

  operator_intervention_occurred = intervene

PROCEND cmp$activate_configuration
*DECK DECK=CMP$ACTIVATE_SIGNAL_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] cmp$activate_signal_handler;
*DECK DECK=CMP$ACTIVATE_VOLUME EXPAND=FALSE

{ COMMON DECK CMXAVOL }

  PROCEDURE [XREF] cmp$activate_volume (logical_unit_number:
    iot$logical_unit;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$ADDRESS_TYPE_NOT_FOUND EXPAND=FALSE

{ COMMON DECK CMXATNF }

?? PUSH (LISTEXT := ON) ??
*copyc CLP$CONVERT_INTEGER_TO_STRING
*copyc OSP$SET_STATUS_ABNORMAL
*copyc CMC$CONDITION_LIMITS
?? POP ??

  PROCEDURE [inline] cmp$address_type_not_found (address_type: 0 .. 0ffff(16);
        condition: ost$status_condition;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      str: ost$string,
      local_status: ost$status;

    clp$convert_integer_to_string (address_type, 16, TRUE, str, local_status);

    osp$set_status_abnormal (cmc$configuration_management_id, condition, str.
          value (1, str.size), status);

  PROCEND cmp$address_type_not_found;

?? POP ??
*DECK DECK=CMP$ADD_CLASS_TO_ELEMENT EXPAND=FALSE

   PROCEDURE [XREF] cmp$add_class_to_element (
         avt_index: dmt$active_volume_table_index;
         class: dmt$class;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc dmt$class
*copyc ost$status
?? POP ??
*DECK DECK=CMP$ADD_DEFINITION EXPAND=FALSE

  PROCEDURE [XREF] cmp$add_definition (definition : cmt$pcu_command_descriptor;
           VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pcu_command_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=CMP$ADD_ELEMENT_DEF EXPAND=FALSE

   PROCEDURE [XREF] cmp$add_element_def (parameter_list :
         clt$parameter_list;
       VAR status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CMP$ADD_SSIOT_ENTRY_AVAIL_QUEUE EXPAND=FALSE

      PROCEDURE [XREF] cmp$add_ssiot_entry_avail_queue (
                  VAR job_completion_queue_index: cmt$io_completion_queue_index);

??PUSH (LISTEXT := ON)??
*copyc cmt$io_completion_queue_index
??POP??
*DECK DECK=CMP$ALLOCATE_ADTT EXPAND=FALSE

{ COMMON DECK CMXALAD }

  PROCEDURE [XREF] cmp$allocate_adtt (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$ALLOCATE_IMAGE_FILE_ADTT EXPAND=FALSE

{ COMMON DECK CMXALID }

  PROCEDURE [XREF] cmp$allocate_image_file_adtt (table_space: ^ost$heap;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc OST$HEAP
?? POP ??
*DECK DECK=CMP$ASK_FOR_INTERVENTION EXPAND=TRUE
PROCEDURE (HIDDEN) cmp$ask_for_intervention (
  deadstart_phase, dp: key
      installation, reinstallation, continuation
    keyend = $required
  menu_items: list of name = $required
  prolog_procedure_name, ppn: name = $required
  usecp_selection: string = $required
  intervention_step: (VAR) name = $required
  status)

"$FORMAT=OFF
VAR
   local_status: status
   menu_selection: string
VAREND

"$FORMAT=ON

  IF deadstart_phase = installation THEN
    rap$display_message message_module=sysdp_messages ..
          message_name=prolog_selection_info message_parameters=(..
          usecp_selection $string(prolog_procedure_name)) to=$output
    rap$prompt_via_menu menu_module= installation_ds_menu ..
          menu_selections=menu_items prompting_options=allow_go ..
          selection_chosen=menu_selection status=local_status
  ELSEIF deadstart_phase = reinstallation THEN
    rap$display_message message_module=sysdp_messages ..
          message_name=prolog_selection_info message_parameters=(..
          usecp_selection $string(prolog_procedure_name)) to=$output
    rap$prompt_via_menu menu_module= continuation_ds_menu ..
          menu_selections=menu_items prompting_options=allow_go ..
          menu_parameters= 'SYSTEM SET RECOVERY' ..
          selection_chosen=menu_selection status=local_status
  ELSE "Continuation deadstart"
    rap$prompt_via_menu menu_module= continuation_ds_menu ..
          menu_selections=menu_items prompting_options=(allow_go, ..
          clear_screen) menu_parameters= 'CONTINUATION DEADSTART' ..
          selection_chosen=menu_selection status=local_status
  IFEND

  IF local_status.normal THEN
    cmp$display_menu_selection menu_selection=menu_selection ..
        menu_items=menu_items output=$job_log
    IF menu_selection <> '+GO' THEN
      intervention_step = $name(menu_selection)
    ELSE
      intervention_step = none
    IFEND
  ELSE
    rap$display_message message_module=sysdp_messages ..
          message_name=report_menu_fault to=$output
    display_value local_status
    intervention_step = none
  IFEND

PROCEND cmp$ask_for_intervention
*DECK DECK=CMP$ASSIGN_LOGICAL_UNIT_NUMBERS EXPAND=FALSE

    PROCEDURE [XREF] cmp$assign_logical_unit_numbers (channel_iou :
        cmt$element_name;
          equipment_number: cmt$physical_equipment_number;
          unit_number: cmt$physical_unit_number;
          system_device_lun: iot$logical_unit;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$physical_equipment_number
*copyc cmt$physical_unit_number
*copyc iot$logical_unit
*copyc ost$status
?? POP ??
*DECK DECK=CMP$ASSIGN_PP_R1 EXPAND=FALSE

  PROCEDURE [XREF] cmp$assign_pp_r1
    (    assigned: boolean;
         assigned_pp: iot$pp_number);

?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
?? POP ??
*DECK DECK=CMP$ASSIGN_UNIT EXPAND=FALSE
*DECK DECK=CMP$BEGIN_CONF_TRANSITION EXPAND=FALSE
*DECK DECK=CMP$BEGIN_TRANSITION EXPAND=FALSE


  PROCEDURE [XREF] cmp$begin_transition (sys_dev_lun: iot$logical_unit;
        channel_number: cmt$channel_ordinal;
        equipment_number: cmt$physical_equipment_number;
        unit_number: cmt$physical_unit_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
*copyc CMT$CHANNEL_TYPE
*copyc CMT$CHANNEL_ORDINAL
*copyc CMT$CONTROLLER_PORT_NUMBER
*copyc CMT$PHYSICAL_EQUIPMENT_NUMBER
*copyc CMT$PHYSICAL_UNIT_NUMBER
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$BUILD_ACTIVE_CONF EXPAND=FALSE

  PROCEDURE [XREF] cmp$build_active_conf
    (    connected_pc_fid: amt$file_identifier;
         connected_active_fid: amt$file_identifier;
         state_info_fid: amt$file_identifier;
         active_state_info_fid: amt$file_identifier;
         mainframe: cmt$element_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$BUILD_CONF_TABLES EXPAND=TRUE

  PROCEDURE [XREF] cmp$build_conf_tables
    (VAR physical_file_id: amt$file_identifier;
     VAR state_file_id: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=CMP$BUILD_DESCRIPTOR EXPAND=FALSE

  PROCEDURE [XREF] cmp$build_descriptor
    (    definition: cmt$pcu_command_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pcu_command_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=CMP$BUILD_ELEMENT_DEF_TABLE EXPAND=FALSE

  PROCEDURE [XREF] cmp$build_element_def_table
    (    mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$mainframe_id
*copyc ost$status
?? POP ??
*DECK DECK=CMP$BUILD_INTERFACE_TABLES EXPAND=FALSE

  PROCEDURE [XREF] cmp$build_interface_tables
    (    pp_count: iot$pp_number;
         requested_unit_count: iot$logical_unit;
         allocate_entire_configuration: boolean;
     VAR logical_unit_table_p: ^cmt$logical_unit_table;
     VAR logical_pp_table_p: ^cmt$logical_pp_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$logical_pp_table
*copyc cmt$logical_unit_table
*copyc ost$status
?? POP ??
*DECK DECK=CMP$BUILD_IOU_TABLE EXPAND=FALSE

  PROCEDURE [XREF] cmp$build_iou_table
    (    number_of_ious: dst$number_of_ious;
         iou_information_table: dst$iou_information_table);

?? PUSH(LISTEXT := ON) ??
*copyc dst$iou_information_table
*copyc dst$number_of_ious
?? POP ??
*DECK DECK=CMP$BUILD_LOGICAL_CONF EXPAND=FALSE

{ COMMON DECK CMXBLC }

  PROCEDURE [XREF] cmp$build_logical_conf (connected_pc_fid: amt$file_identifier;
        connected_lc_fid: amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$BUILD_NAMVE_INT_TABLES EXPAND=FALSE
*DECK DECK=CMP$BUILD_PCT EXPAND=FALSE

{ COMMON DECK CMXBPCT }

  PROCEDURE [XREF] cmp$build_pct (entry_count: integer;
        entries: array [1 .. * ] OF cmt$element_definition;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc CMT$ELEMENT_DEFINITION
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$BUILD_PP_TABLE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] cmp$build_pp_table_entry
    (    pp_index: ARRAY [1 .. *] OF iot$pp_number;
     VAR active_elements: ARRAY [1 .. *] OF cmt$access_elements;
     VAR seq_p: ^SEQ ( * );
     VAR slave_seq_p: ^SEQ ( * );
     VAR program_description: ARRAY [1 .. *] OF cmt$pp_program_description;
     VAR master_pp_table_rma: ost$real_memory_address;
     VAR slave_pp_table_rma: ost$real_memory_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$access_elements
*copyc cmt$pp_program_description
*copyc iot$pp_number
*copyc ost$hardware_subranges
*copyc ost$status
?? POP ??
*DECK DECK=CMP$BUILD_STATE_TABLE EXPAND=FALSE

  PROCEDURE [XREF] cmp$build_state_table (entry_count: integer;
          entries : array [ * ] of cmt$state_information;
          use_mrt_state : boolean;
      VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$state_information
*copyc ost$status
?? POP ??
*DECK DECK=CMP$BUILD_STND_INTERFACE_TABLES EXPAND=FALSE
*DECK DECK=CMP$BUILD_WIRED_QUEUE_REQUEST EXPAND=FALSE

      PROCEDURE [XREF] cmp$build_wired_queue_request (
             element_name: cmt$element_name;
             request_type: cmt$io_request_type;
             command_table_p: ^cmt$io_command_table;
             data_command_descriptors_p: ^cmt$data_command_descriptors;
             request_id: cmt$subsystem_io_request_id;
             io_response_p: ^cmt$os_subsystem_io_response;
         VAR status: ost$status);

??PUSH (LISTEXT:=ON)??
*copyc cmt$element_name
*copyc cmt$io_request_type
*copyc cmt$io_command_table
*copyc cmt$data_command_descriptors
*copyc cmt$subsystem_io_request_id
*copyc cmt$os_subsystem_response
*copyc ost$status
??POP??
*DECK DECK=CMP$CHANGE_CONNECTION_REF_R3 EXPAND=FALSE

  PROCEDURE [XREF] cmp$change_connection_ref_r3
    (    old_channel_list: ^clt$data_value;
         new_channel_list: ^clt$data_value;
         old_mainframe_list: ^clt$data_value;
         new_mainframe_list: ^clt$data_value;
         old_peripheral: cmt$element_name;
         new_peripheral: cmt$element_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc cmt$element_name
*copyc ost$status
?? POP ??


*DECK DECK=CMP$CHANGE_CONNECTION_STATUS EXPAND=FALSE
  PROCEDURE [XREF] cmp$change_connection_status
    (    physical_address: cmt$physical_address;
         new_connection_status: cmt$connection_status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$connection
*copyc cmt$physical_address
?? POP ??
*DECK DECK=CMP$CHANGE_CONNECTION_STATUS_R1 EXPAND=FALSE
  PROCEDURE [XREF] cmp$change_connection_status_r1
    (    primary_element: cmt$element_definition;
         mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_definition
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=CMP$CHANGE_CONNECT_REFERENCE EXPAND=FALSE

   PROCEDURE [XREF] cmp$change_connect_reference (parameter_list :
         clt$parameter_list;
       VAR status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CHANGE_CPU_ELEMENT_STATE EXPAND=FALSE

  PROCEDURE [XREF] cmp$change_cpu_element_state
    (    processor_id: ost$processor_id;
         state: cmt$element_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_state
*copyc ost$processor_id
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CHANGE_DEFINITION EXPAND=FALSE

  PROCEDURE [XREF]  cmp$change_definition (
         parameter_value_table: ^clt$parameter_value_table;
     VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_value_table
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CHANGE_DEFINITION_NAME EXPAND=FALSE

   PROCEDURE [XREF] cmp$change_definition_name (
            element_name : cmt$element_name;
          new_element_name : cmt$element_name;
          change_all : boolean;
       VAR status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc ost$status
*copyc cmt$element_name
?? POP ??
*DECK DECK=CMP$CHANGE_DFT_ENTRY EXPAND=TRUE

{ COMMON DECK CMXCDFT }

  PROCEDURE [XREF] cmp$change_dft_entry (device_file_type:
    cmt$device_file_type;
        device_file_count: 1 .. cmc$device_file_count;
        device_file_record: cmt$device_file_record);

?? PUSH (LISTEXT := ON) ??
*copyc CMT$DEVICE_FILE_TABLE
?? POP ??
*DECK DECK=CMP$CHANGE_ELEMENT_DEF EXPAND=FALSE

    PROCEDURE [xref] cmp$change_element_def (parameter_list :
        clt$parameter_list;
        VAR status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CHANGE_ELEMENT_STATE EXPAND=FALSE

 PROCEDURE [XREF] cmp$change_element_state (element: cmt$element_descriptor;
        state: cmt$element_state;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_descriptor
*copyc cmt$element_state
*copyc ost$status
?? POP ??

*DECK DECK=CMP$CHANGE_NEW_DF_ENTRY EXPAND=FALSE

   PROCEDURE [XREF] cmp$change_new_df_entry (device_file_record :
               cmt$device_file_record);
?? PUSH(LISTEXT := ON) ??
*copyc cmt$device_file_table
?? POP ??
*DECK DECK=CMP$CHANGE_STATE_INFO_TABLE EXPAND=FALSE

  PROCEDURE [XREF] cmp$change_state_info_table (element_name :
                cmt$element_name;
           iou_name : cmt$element_name;
           state : cmt$element_state;
       VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_state
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CHANGE_STATE_R1 EXPAND=FALSE

  PROCEDURE [XREF] cmp$change_state_r1
    (    element_name: cmt$element_name;
         element_type: cmt$element_type;
         controller_type: cmt$controller_type;
         system_critical_element: boolean;
         new_state: cmt$element_state;
         iou: dst$iou_number;
         pp: iot$pp_number;
         channel: cmt$physical_channel;
         controller: cmt$physical_equipment_number;
         logical_unit: iot$logical_unit;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$controller_type
*copyc cmt$element_name
*copyc cmt$element_state
*copyc cmt$element_type
*copyc cmt$physical_channel
*copyc cmt$physical_equipment_number
*copyc iot$logical_unit
*copyc iot$pp_interface_table
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CHANGE_VOLUME_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] cmp$change_volume_attributes (logical_unit_number: iot$logical_unit;
        p_volume_attributes: ^dmt$volume_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$volume_attributes
*copyc iot$logical_unit
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CHANNELS_EQUIVALENT EXPAND=TRUE
  FUNCTION [INLINE] cmp$channels_equivalent
    (    channel_element_1_p: ^cmt$element_definition;
         channel_element_2_p: ^cmt$element_definition): boolean;

?? PUSH (LISTEXT := ON) ??

    cmp$channels_equivalent :=
          (channel_element_1_p^.data_channel.number = channel_element_2_p^.data_channel.number) AND
          (channel_element_1_p^.data_channel.concurrent = channel_element_2_p^.data_channel.concurrent) AND
          (channel_element_1_p^.data_channel.iou = channel_element_2_p^.data_channel.iou);
  FUNCEND cmp$channels_equivalent;

*copyc cmt$element_definition
?? POP ??
*DECK DECK=CMP$CHECK_DUAL_PP_SYSTEM_DISK EXPAND=FALSE

  PROCEDURE [XREF] cmp$check_dual_pp_system_disk (pp : dst$iou_resource;
     VAR dual_pp : boolean;
     VAR partner_pp : dst$iou_resource);

?? PUSH (LISTEXT := ON) ??
*copyc dst$iou_resource
?? POP ??
*DECK DECK=CMP$CHECK_FOREIGN_IO EXPAND=FALSE


 PROCEDURE [XREF] cmp$check_foreign_io (system_job_name:
  jmt$system_supplied_name;
  user_job_name: jmt$user_supplied_name;
    VAR match: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
?? POP ??
*DECK DECK=CMP$CHECK_FOR_UNIQUE_ELEMENT EXPAND=FALSE

  PROCEDURE [XREF] cmp$check_for_unique_element
    (    name: cmt$element_name;
         mainframe: cmt$element_name;
         input_fid: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CHECK_INITIATED_IO_STATUS EXPAND=FALSE

     PROCEDURE [XREF] cmp$check_initiated_io_status (
                 io_status_p: ^cmt$subsystem_io_status;
             VAR index: integer;
             VAR status: ost$status);

??PUSH (LISTEXT :=ON)??
*copyc cmt$subsystem_io_status
*copyc ost$status
??POP??
*DECK DECK=CMP$CHECK_INIT_STATUS EXPAND=FALSE

  PROCEDURE [XREF] cmp$check_init_status
    (    status: ost$status;
         initialize_status_info: dmt$initialize_status_info;
         element: cmt$element_name;
     VAR continue_initialization: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc dmt$initialize_status_info
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CHECK_IO_STATUS EXPAND=FALSE


PROCEDURE [XREF] cmp$check_io_status (
   request_id: cmt$subsystem_io_request_id;
   VAR status: ost$status);

*copyc ost$status
*copyc cmt$subsystem_io_request_id

*DECK DECK=CMP$CHECK_LCU_LOCK_SET EXPAND=FALSE

  PROCEDURE [XREF] cmp$check_lcu_lock_set (
     VAR status: ost$status);

*copyc ost$status
*DECK DECK=CMP$CHECK_RESERVED_NAMES EXPAND=FALSE

  PROCEDURE [XREF] cmp$check_reserved_names (
         element_name : cmt$element_name;
         reserved_names_list : ^ARRAY [ * ] of ost$name;
    VAR status : ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CLASS_IN_VOLUME EXPAND=FALSE
*DECK DECK=CMP$CLASS_VOLUME EXPAND=FALSE
*DECK DECK=CMP$CLEAN_UP_ERROR_COUNT EXPAND=FALSE

  PROCEDURE [XREF] cmp$clean_up_error_count;

*DECK DECK=CMP$CLEAN_UP_LIST EXPAND=FALSE

   PROCEDURE [XREF] cmp$clean_up_list;

*DECK DECK=CMP$CLEAN_UP_NETWORK_LIST EXPAND=FALSE

  PROCEDURE [XREF] cmp$clean_up_network_list (VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CLEAR_CHANNEL_INTERLOCK EXPAND=FALSE

  PROCEDURE [XREF] cmp$clear_channel_interlock
    (    iou_number: dst$iou_number;
         logical_pp_number: iot$pp_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$iou_number
*copyc iot$pp_number
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CLEAR_ELEMENT_LOCK EXPAND=FALSE




  PROCEDURE [XREF] cmp$clear_element_lock  (
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
  ?? POP ??
*DECK DECK=CMP$CLEAR_IOCT_SERIAL_LOCK EXPAND=FALSE


PROCEDURE [XREF] cmp$clear_ioct_serial_lock (
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
?? POP ??
*DECK DECK=CMP$CLEAR_LCU_TASKID EXPAND=FALSE
*DECK DECK=CMP$CLEAR_LCU_TASKID_R1 EXPAND=FALSE
*DECK DECK=CMP$CLEAR_PPIT EXPAND=FALSE

  PROCEDURE [XREF] cmp$clear_ppit (channel_name : cmt$element_name;
            iou_name : cmt$element_name;
        VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CLEAR_UNIT_SHARED EXPAND=FALSE

    PROCEDURE [XREF] cmp$clear_unit_shared (logical_unit: iot$logical_unit;
          set_lock: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
?? POP ??
*DECK DECK=CMP$CLOSE_IN_OUT_FILES EXPAND=FALSE


   PROCEDURE [XREF] cmp$close_in_out_files;
*DECK DECK=CMP$CLOSE_UTILITY_FILES EXPAND=FALSE
   PROCEDURE [XREF] cmp$close_utility_files;
*DECK DECK=CMP$COMPILE_PHYS_CONFIGURATION EXPAND=FALSE

  PROCEDURE [XREF] cmp$compile_phys_configuration (
       verify_only: boolean;
       parameter_value_table: ^clt$parameter_value_table;
   VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_value_table
*copyc ost$status
?? POP ??
*DECK DECK=CMP$COMPLETE_SSIOT_RECOVERY EXPAND=FALSE

          PROCEDURE [XREF] cmp$complete_ssiot_recovery (
                           VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=CMP$CONFIGURE_DEADSTART_DEVICE EXPAND=FALSE

  PROCEDURE [XREF] cmp$configure_deadstart_device
    (    device: cmt$system_device_types;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$system_device_types
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CONFIGURE_DEVICES_IN_JT EXPAND=FALSE
*DECK DECK=CMP$CONFIGURE_INSTALLED_SYSTEM EXPAND=FALSE

{ COMMON DECK CMXCIS }

  PROCEDURE [XREF] cmp$configure_installed_system (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$CONFIGURE_PERIPHERAL EXPAND=FALSE

  PROCEDURE [XREF] cmp$configure_peripheral
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CONFIGURE_SYSTEM_DEVICE EXPAND=FALSE

{ COMMON DECK CMXCSD }

  PROCEDURE [XREF] cmp$configure_system_device (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$CONNECT_CHANNEL_ELEMENTS EXPAND=FALSE

  { COMMON DECK CMXCCHE }

  PROCEDURE [XREF] cmp$connect_channel_elements (connected_pc_fid:
    amt$file_identifier;
        connected_lc_fid: amt$file_identifier;
        element: ^cmt$element_definition;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc CMT$ELEMENT_DEFINITION
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$CONNECT_CONTROLLER_ELEMENTS EXPAND=FALSE

{ COMMON DECK CMXCCTE }

  PROCEDURE [XREF] cmp$connect_controller_elements (connected_pc_fid:
    amt$file_identifier;
        connected_lc_fid: amt$file_identifier;
        element: ^cmt$mainframe_element;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc CMT$MAINFRAME_ELEMENT
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$CONVERT_CHANNEL_NUMBER EXPAND=FALSE

  PROCEDURE [INLINE] cmp$convert_channel_number
    (    channel_number: ost$physical_channel_number;
         concurrent: boolean;
         port: cmt$channel_port;
     VAR channel_ordinal: cmt$channel_ordinal;
     VAR channel_name: cmt$element_name;
     VAR valid: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      divisor: 1 .. 1000,
      i: 0 .. 4,
      j: 0 .. 0f(16),
      number_of_chars : 0 .. 4,
      number_string: string (4),
      ordinal_number: integer,
      port_char : string (1),
      start: integer;

    { PURPOSE : This inline routine converts a physical channel number into
    {    its equivalent channel ordinal and the externalized channel name.
    { DESIGN : This routine can be called from a Monitor or Job mode module.
    { NOTE : cmt$channel_ordinal is a CM type that will be deleted. Avoid
    {    using this type.


    IF (channel_number < 0) OR (channel_number > 33(8)) THEN
      valid := FALSE;
      RETURN;
    ELSE
      valid := TRUE;
      number_string := ' ';
      port_char := ' ';
      divisor := 1;
      #SPOIL(divisor);
      IF channel_number <= 9 THEN
        number_of_chars := 1;
      ELSEIF (channel_number >= 10) AND (channel_number <= 99) THEN
        number_of_chars := 2;
      ELSE
        number_of_chars := 3;
      IFEND;
      FOR i := number_of_chars DOWNTO 1 DO
        number_string (i, 1) := $CHAR (((channel_number DIV divisor) MOD
              10) + $INTEGER ('0'));
        divisor := divisor * 10;
        #SPOIL(divisor);
      FOREND;
      IF concurrent THEN
        channel_name := 'CCH';
        start := 4;
        CASE port OF
        = cmc$port_a =
          port_char := 'A';
        = cmc$port_b =
          port_char := 'B';
        ELSE
        CASEND;
      ELSE
        channel_name := 'CH';
        start := 3;
      IFEND;
      j := 0;
      #SPOIL(j);
      FOR i := 1 TO 4 DO
        IF number_string (i, 1) <> ' ' THEN
          channel_name (start + j, 2) := number_string (i, 1);
          j := j + 1;
          #SPOIL(j);
        IFEND;
      FOREND;
      IF port_char <> ' ' THEN
        j := 1;
        #SPOIL(j);
        WHILE (channel_name (j, 1) <> ' ') DO
          j := j + 1;
          #SPOIL(j);
        WHILEND;
        channel_name (j, 1) := port_char;
      IFEND;

      {  Determine channel ordinal.

      IF concurrent THEN
        IF port = cmc$unspecified_port THEN
          ordinal_number := $INTEGER (cmc$cio_channel0);
        ELSE  { port A or port B channel }
          IF channel_number <= 9 THEN
            ordinal_number := $INTEGER (cmc$cio_channel0_porta);
          ELSE

            { Set up this number because of the gap between Cio channel 9 and
            { Cio channel 16.

            ordinal_number := 16;
          IFEND;
        IFEND;

      /cio_channel_loop/
        FOR channel_ordinal := cmc$cio_channel0_porta TO
              UPPERVALUE (cmt$channel_ordinal) DO
          IF port = cmc$unspecified_port THEN
            IF (channel_number = ($INTEGER (channel_ordinal) - ordinal_number)) THEN
              EXIT /cio_channel_loop/;
            IFEND;
          ELSE
            IF (channel_number = ($INTEGER (channel_ordinal) - ordinal_number) DIV 2) THEN
              IF port = cmc$port_b THEN
                IF ((($INTEGER (channel_ordinal) - ordinal_number) MOD 2) <>
                    1) THEN
                  CYCLE /cio_channel_loop/;
                IFEND;
              IFEND;
              EXIT /cio_channel_loop/;
            IFEND;
          IFEND;
        FOREND /cio_channel_loop/;
      ELSE
      /nio_channel_loop/
        FOR channel_ordinal := LOWERVALUE (cmt$channel_ordinal)
              TO cmc$channel27 DO
          IF channel_number = $INTEGER (channel_ordinal) THEN
            EXIT /nio_channel_loop/;
          IFEND;
        FOREND /nio_channel_loop/;
      IFEND;
    IFEND;

  PROCEND cmp$convert_channel_number;

?? POP ??
?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$channel_ordinal
*copyc cmt$channel_port
*copyc ost$physical_channel_number
?? POP ??
*DECK DECK=CMP$CONVERT_CHANNEL_ORDINAL EXPAND=TRUE

  PROCEDURE [XREF] cmp$convert_channel_ordinal (channel_ordinal :
                cmt$channel_ordinal;
       VAR channel_name : cmt$element_name;
       VAR channel_number : ost$physical_channel_number;
       VAR concurrent : boolean;
       VAR channel_port : cmt$channel_port;
       VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$channel_ordinal
*copyc cmt$channel_port
*copyc ost$physical_channel_number
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CONVERT_CHANNEL_TYPE EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc cmt$channel_type
?? POP ??

  PROCEDURE [INLINE] cmp$convert_channel_type
    (    channel_type: cmt$channel_type;
     VAR string_representation: string (11));

?? PUSH (LISTEXT := ON) ??

     string_representation :=  ' ';
     CASE channel_type OF
     = cmc$170_channel =
       string_representation (1, 11) := '170_CHANNEL';
     = cmc$ici_channel =
       string_representation (1, 11) := 'ICI_CHANNEL';
     = cmc$isi_channel =
       string_representation (1, 11) := 'ISI_CHANNEL';
     = cmc$ipi_channel =
       string_representation (1, 11) := 'IPI_CHANNEL';
     CASEND;
  PROCEND cmp$convert_channel_type;
?? POP ??
*DECK DECK=CMP$CONVERT_CONFIG_PROLOG EXPAND=TRUE
PROCEDURE (HIDDEN) cmp$convert_config_prolog (
  prolog_file, pf: file = $required
  new_prolog_library, npl: file = $required
  old_prolog_library, opl: file = $optional
  status)

"$FORMAT=OFF
VAR
ignore_status:status
new_library: file =new_prolog_library
VAREND

"$FORMAT=ON

COLLECT_TEXT $local.create_prolog_file until='end_crepf'
*copy cmp$create_prolog
end_crepf

  delete_variable cmd$crep_input status=ignore_status
  create_default_variable name=cmd$crep_input default='$command_of_caller'

  delete_variable cmd$crep_output status=ignore_status
  create_default_variable name=cmd$crep_output default=$string(new_library)

  IF $specified(old_prolog_library) THEN
    CREATE_OBJECT_LIBRARY
      add_module old_prolog_library status=ignore_status
      combine_module new_library status=ignore_status
      generate_library new_library status=ignore_status
    QUIT
  IFEND

  include_file prolog_file

  delete_variable cmd$crep_input status=ignore_status
  delete_variable cmd$crep_output status=ignore_status

PROCEND cmp$convert_config_prolog
*DECK DECK=CMP$CONVERT_IOU_NAME EXPAND=FALSE

   PROCEDURE [INLINE] cmp$convert_iou_name (iou_name : cmt$element_name;
      VAR iou_number : dst$iou_number;
      VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??

  { This procedure converts an iou name of the form IOUx (where
  { x is an integer value between 0 and 1) into the equivalent
  { iou number. Iou name must be in Upper case.

      status.normal := TRUE;
      IF iou_name = 'IOU0                           ' THEN
        iou_number := 0;
      ELSEIF iou_name = 'IOU1                           ' THEN
        iou_number := 1;
      ELSE
        osp$set_status_abnormal (cmc$configuration_management_id,
             cme$invalid_iou_name, iou_name, status);
      IFEND;

   PROCEND cmp$convert_iou_name;

*copyc cmt$element_name
*copyc dst$iou_number
*copyc osp$set_status_abnormal
*copyc cme$physical_configuration_mgr
?? POP ??

*DECK DECK=CMP$CONVERT_IOU_NUMBER EXPAND=FALSE

  PROCEDURE [INLINE] cmp$convert_iou_number
    (    iou_number: dst$iou_number;
     VAR iou_name: cmt$element_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      str: ost$string;

    {
    { This procedure converts an IOU number into an IOU name of
    { the form IOUx where x is an integer value between 0 and 1.
    { For future releases, x could be bigger than one.
    {
    status.normal := TRUE;
    IF (iou_number >= 0) AND (iou_number <= UPPERVALUE (dst$iou_number)) THEN
      iou_name := 'IOU';
      iou_name (4, 1) := $CHAR (iou_number + $INTEGER ('0'));
    ELSE
      clp$convert_integer_to_string (iou_number, {radix} 10,
            {include radix specifier} FALSE, str, status);
      osp$set_status_abnormal (cmc$configuration_management_id,
            cme$invalid_iou_number, str.value, status);
    IFEND;
  PROCEND cmp$convert_iou_number;

*copyc dst$iou_number
*copyc cmt$element_name
*copyc cme$physical_configuration_mgr
*copyc osp$set_status_abnormal
*copyc clp$convert_integer_to_string
?? POP ??

*DECK DECK=CMP$CONVERT_PP_NUMBER EXPAND=TRUE

   PROCEDURE [INLINE] cmp$convert_pp_number (pp_number : dst$iou_resource;
      VAR pp_ordinal : cmt$pp_ordinal);
  {
  {  PURPOSE : Convert a pp number into its equivalent
  {     pp ordinal type. Note, when deleting the type
  {     cmt$pp_ordinal, this procedure will be changed or
  {     potentially deleted.
  {

      IF pp_number.channel_protocol = dsc$cpt_cio THEN
        IF pp_number.number <= 9 THEN
          FOR pp_ordinal := cmc$cio_pp0 TO cmc$cio_pp9 DO
            IF (pp_number.number = ($INTEGER (pp_ordinal) - $INTEGER(cmc$cio_pp0))) THEN
              RETURN;
            IFEND;
          FOREND;
        ELSE
          FOR pp_ordinal := cmc$cio_pp16 TO UPPERVALUE(cmt$pp_ordinal) DO
            IF (pp_number.number = ($INTEGER (pp_ordinal) - $INTEGER(cmc$cio_pp0)) + 6) THEN
              RETURN;
            IFEND;
          FOREND;
        IFEND;
      ELSE
        IF pp_number.number > 9 THEN
          FOR pp_ordinal := cmc$pp10 TO cmc$pp19 DO
            IF ($INTEGER (pp_ordinal) = (pp_number.number - 6)) THEN
              RETURN;
            IFEND;
          FOREND;
        ELSE
          FOR pp_ordinal := cmc$pp0 TO cmc$pp9 DO
            IF ($INTEGER (pp_ordinal) = pp_number.number) THEN
              RETURN;
            IFEND;
          FOREND;
        IFEND;
      IFEND;
    PROCEND cmp$convert_pp_number;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pp_ordinal
*copyc dst$iou_resource
?? POP ??
*DECK DECK=CMP$CONVERT_PP_ORDINAL EXPAND=FALSE

  PROCEDURE [INLINE] cmp$convert_pp_ordinal (pp_ordinal : cmt$pp_ordinal;
      VAR pp : dst$iou_resource);
  {
  {  PURPOSE : Given a pp ordinal (cmt$pp_ordinal) convert to
  {     a physical pp number of the type dst$iou_resource.
  {

      CASE pp_ordinal OF
      = cmc$pp0 .. cmc$pp9 =
        pp.channel_protocol := dsc$cpt_nio;
        pp.number := ORD (pp_ordinal);
      = cmc$pp10 .. cmc$pp19 =
        pp.channel_protocol := dsc$cpt_nio;
        pp.number := ORD (pp_ordinal) + 6;
      = cmc$cio_pp0 .. cmc$cio_pp9 =
        pp.channel_protocol := dsc$cpt_cio;
        pp.number := ORD (pp_ordinal) - 20;
      = cmc$cio_pp16 .. cmc$cio_pp25 =
        pp.channel_protocol := dsc$cpt_cio;
        pp.number := ORD (pp_ordinal) - 14;
      CASEND;

  PROCEND cmp$convert_pp_ordinal;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pp_ordinal
*copyc dst$iou_resource
?? POP ??
*DECK DECK=CMP$COPY_ACTIVE_CONFIGURATION EXPAND=FALSE

  PROCEDURE [XREF] cmp$copy_active_configuration
    (VAR configuration_p: ^ARRAY [1 .. *] OF cmt$element_definition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_definition
*copyc ost$status
?? POP ??
*DECK DECK=CMP$COPY_STATE_INFO_TO_DF EXPAND=FALSE

  PROCEDURE [XREF] cmp$copy_state_info_to_df (state_info_fid : amt$file_identifier;
           create_new_file : boolean;
       VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=CMP$COUNT_CON_ACCESS_JOB EXPAND=FALSE

  PROCEDURE [XREF] cmp$count_con_access_job (index : integer;
       VAR count : integer;
       VAR status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CPUS_PHYSICALLY_CONFIGURED EXPAND=FALSE

  FUNCTION [XREF] cmp$cpus_physically_configured: ost$processor_id;

?? PUSH (LISTEXT := ON) ??
*copyc ost$processor_id
?? POP ??
*DECK DECK=CMP$CRACK_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] cmp$crack_connection (
        parameter_value_table : ^clt$parameter_value_table;
        command_name : string ( * <= osc$max_name_size);
    VAR connection_specified : boolean;
    VAR command : cmt$pcu_command_descriptor;
    VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_value_table
*copyc cmt$pcu_command_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CRACK_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] cmp$crack_parameters
    (    parameter_value_table: ^clt$parameter_value_table;
         command_name: string ( * <= osc$max_name_size);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_value_table
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CRACK_PHYSICAL_ADDRESS EXPAND=FALSE

  PROCEDURE [XREF] cmp$crack_physical_address
    (    element_reservation: cmt$element_reservation;
     VAR iou: dst$iou_number;
     VAR channel: cmt$physical_channel;
     VAR channel_address: cmt$physical_equipment_number;
     VAR unit_address: cmt$physical_unit_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_reservation
*copyc cmt$physical_channel
*copyc cmt$physical_equipment_number
*copyc cmt$physical_unit_number
*copyc dst$iou_number
*copyc ost$status
?? POP ??
*DECK DECK=CMP$CREATE_AND_SUBMIT_IO_REQ EXPAND=FALSE

      PROCEDURE [XREF] cmp$create_and_submit_io_req (
             request_type: cmt$io_request_type;
             element_name: cmt$element_name;
             command_table_p: ^cmt$io_command_table;
             data_command_descriptors_p: ^cmt$data_command_descriptors;
             unit_queue_control: cmt$unit_queuing_options;
             recovery_options: iot$request_recovery;
             wait_for_io_completion: cmt$wait_for_io_completion;
             io_identification: cmt$user_io_identification;
             io_response_p: ^cmt$os_subsystem_io_response;
         VAR request_id: cmt$subsystem_io_request_id;
         VAR status: ost$status);

??PUSH (LISTEXT:=ON)??
*copyc cmt$io_request_type
*copyc cmt$element_name
*copyc cmt$io_command_table
*copyc cmt$data_command_descriptors
*copyc cmt$unit_queuing_options
*copyc cmt$io_request_type
*copyc cmt$user_io_identification
*copyc iot$request_recovery
*copyc cmt$os_subsystem_response
*copyc cmt$subsystem_io_request_id
*copyc ost$status
??POP??
*DECK DECK=CMP$CREATE_CM_DEVICE_FILES EXPAND=FALSE

{ COMMON DECK CMXCDF }

  PROCEDURE [XREF] cmp$create_cm_device_files (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$CREATE_IO_REQUEST EXPAND=FALSE

      PROCEDURE [XREF] cmp$create_io_request (
             request_type: cmt$io_request_type;
             element_name: cmt$element_name;
             command_table_p: ^cmt$io_command_table;
             data_command_descriptors_p: ^cmt$data_command_descriptors;
             io_identification: cmt$user_io_identification;
             io_response_p: ^cmt$os_subsystem_io_response;
         VAR request_id: cmt$subsystem_io_request_id;
         VAR status: ost$status);

??PUSH (LISTEXT:=ON)??
*copyc cmt$io_request_type
*copyc cmt$element_name
*copyc cmt$io_command_table
*copyc cmt$data_command_descriptors
*copyc cmt$user_io_identification
*copyc cmt$os_subsystem_response
*copyc cmt$subsystem_io_request_id
*copyc ost$status
??POP??
*DECK DECK=CMP$CREATE_PROLOG EXPAND=TRUE
PROCEDURE (HIDDEN) cmp$create_prolog (
  prolog_name, pn: name = $name($mainframe(identifier))
  file, f: key
      (lcu_mainframe_subcommands, lms)
      (lcu_network_subcommands, lns)
      (pcu_subcommands, ps)
    keyend = $required
  until, u: string = '**'
  input, i: file = cmd$crep_input, $command
  output, o: file = cmd$crep_output,
    $system.site_os_maintenance.deadstart_commands.prolog_library
  output_format, of: key
      (command_library, cl)
      (source_library, sl)
    keyend = cmd$crep_output_format, command_library
  deck_prefix, dp: name 1..12 = cmd$crep_deck_prefix, none
  modification_name: name = cmd$crep_modification, $name($job(user))
  status)

"$format=off
var
   converted_prolog : file =$local.temp_prolog_file
   ignore_status :status
   key: name
   status: status
   work_file:file
varend

"$format=on

  IF prolog_name = none THEN
    EXIT_PROC WITH $status(false, 'US', 001, ..
          ' The name NONE is an unacceptable name for a prolog.')
  IFEND

  PUSH command_list
  create_command_list_entry $local status=ignore_status
  PUSH file_connections

COLLECT_TEXT converted_prolog sm='~' until='end of proc'
PROCEDURE ~prolog_name~ (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
end_prolog_file

PROCEND ~prolog_name~
end of proc

  delete_file $local.lcu_mainframe_subcommands status=ignore_status
  delete_file $local.lcu_network_subcommands status=ignore_status
  delete_file $local.pcu_subcommands status=ignore_status

  IF (output_format = command_library) OR (output_format = cl) THEN
    CREATE_OBJECT_LIBRARY
      delete_file_connection $errors $local.output status=ignore_status
      add_module m=prolog_name l=output status=status
      IF status.normal THEN
        generate_library format=scl_proc library=$local.cmf$crep_temp
        $local.cmf$crep_temp
      IFEND
    QUIT
  ELSE "source_library"
    deck = $name($string(deck_prefix)//$string(prolog_name))
    SOURCE_CODE_UTILITY
      use_library output status=status
      IF status.normal THEN
        IF $deck(deck) THEN
          extract_deck deck source=$local.cmf$crep_temp status=status
          IF status.normal THEN
            include_command '$local.cmf$crep_temp' status=ignore_status
          IFEND
        IFEND
      IFEND
    QUIT
  IFEND

  key = $name($string(file))
"$format=off
  IF $file($local//key, size) = 0 THEN
    work_file = $local//key
  ELSE
COLLECT_TEXT $output sm='?'
  FIle ?file? ignored - already defined in prolog ?prolog_name?.
**
    work_file = $null
  IFEND
"$format=on

  include_line ..
        'collect_text input=input output=work_file until='//$quote(until)

  EDIT_FILE converted_prolog p=$null o=$null
    create_variable status k=status
    locate_text 'COLLECT_TEXT $local.pcu_subcommands' status=status
    IF status.normal THEN
      read_file $local.pcu_subcommands p=after status=ignore_status
    IFEND

    locate_text 'COLLECT_TEXT $local.lcu_mainframe_subcommands' status=status
    IF status.normal THEN
      read_file $local.lcu_mainframe_subcommands p=after status=ignore_status
    IFEND

    locate_text 'COLLECT_TEXT $local.lcu_network_subcommands' status=status
    IF status.normal THEN
      read_file $local.lcu_network_subcommands p=after status=ignore_status
    IFEND
  QUIT

  IF (output_format = command_library) OR (output_format = cl) THEN
    CREATE_OBJECT_LIBRARY
      combine_module l=output status=ignore_status
      combine_module library=converted_prolog
      generate_library library=output
    QUIT
  ELSE "source_library"
    SOURCE_CODE_UTILITY
      IF $file(output, opened) THEN
        use_library output
      ELSE
        create_library result=output
      IFEND

      IF NOT $modification(modification_name) THEN
        create_modification modification_name status=ignore_status
      IFEND
      IF NOT $deck(deck) THEN
        create_deck deck=deck modification=modification_name
      IFEND
      EDIT_DECK deck=deck modification=modification_name p=$null o=$null
        delete_lines l=all status=ignore_status
        read_file file=converted_prolog p=b
      END
    QUIT
  IFEND

  delete_file converted_prolog status=ignore_status
  delete_file $local.lcu_mainframe_subcommands status=ignore_status
  delete_file $local.lcu_network_subcommands status=ignore_status
  delete_file $local.pcu_subcommands status=ignore_status
  delete_file $local.cmf$crep_temp status=ignore_status

PROCEND cmp$create_prolog
*DECK DECK=CMP$CREATE_STATE_INFO_DF EXPAND=FALSE

  PROCEDURE [XREF] cmp$create_state_info_df (VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DEADSTART_PHASE EXPAND=FALSE

{ COMMON DECK CMXDSPH }

  FUNCTION [XREF] cmp$deadstart_phase: ost$deadstart_phase;

?? PUSH (LISTEXT := ON) ??
*copyc OST$DEADSTART_PHASE
?? POP ??
*DECK DECK=CMP$DEADSTART_PP EXPAND=FALSE

  PROCEDURE [XREF] cmp$deadstart_pp
    (    pp_index: iot$pp_number;
         pp_table_rma: ost$real_memory_address;
         search_from_dstape: boolean;
         pp_program_p: ^SEQ(*);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
*copyc ost$hardware_subranges
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DEDICATED_MAINT_ACTIVE EXPAND=FALSE

  FUNCTION [XREF] cmp$dedicated_maint_active (table_index : integer) : BOOLEAN;
*DECK DECK=CMP$DEFAULT_RESPONSE_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] cmp$default_response_handler (pp_response_header_p:
        ^iot$pp_response;
        detailed_status_p: ^iot$detailed_status;
        pp_number: 1 .. ioc$pp_count;
    VAR status: syt$monitor_status);


?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
*copyc iot$pp_response
*copyc syt$monitor_request_code
?? POP ??
*DECK DECK=CMP$DEFINE_CHANNEL_NETWORK EXPAND=FALSE

  PROCEDURE [XREF] cmp$define_channel_network ( parameter_list : clt$parameter_list;
      VAR status : ost$status );

?? PUSH(LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DEFINE_ELEMENT EXPAND=FALSE

   PROCEDURE [XREF] cmp$define_element (
            parameter_list : clt$parameter_list;
       VAR  status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DEFINE_HOST_NETWORK EXPAND=FALSE

  PROCEDURE [XREF] cmp$define_host_network
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DEFINE_NETWORK_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] cmp$define_network_access ( parameter_list : clt$parameter_list;
      VAR status : ost$status );

?? PUSH(LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DEFINE_NETWORK_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] cmp$define_network_connection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DEFINE_TCPIP_HOST EXPAND=FALSE

  PROCEDURE [XREF] cmp$define_tcpip_host
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DEFINE_WORKING_MAINFRAME EXPAND=FALSE

   PROCEDURE [XREF] cmp$define_working_mainframe (
           parameter_list : clt$parameter_list;
       VAR status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DELETE_ALL_ELEMENTS EXPAND=FALSE

  PROCEDURE [XREF] cmp$delete_all_elements (exclude_element_list_p :
          ^array [ * ] of cmt$element_name;
      VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
?? POP ??
*DECK DECK=CMP$DELETE_DEFINITION EXPAND=FALSE

   PROCEDURE [XREF] cmp$delete_definition (element_name :
                cmt$element_name;
          VAR status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DESTROY_IO_COMPLETION_TABLE EXPAND=FALSE

 PROCEDURE [XREF] cmp$destroy_io_completion_table (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DESTROY_IO_COMPLETION_TB_R1 EXPAND=FALSE


 PROCEDURE [XREF] cmp$destroy_io_completion_tb_r1 (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DESTROY_IO_COMPLETION_TB_R2 EXPAND=FALSE

      PROCEDURE [XREF] cmp$destroy_io_completion_tb_r2 (VAR status: ost$status);

?? PUSH (LISTEXT:=ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DESTROY_IO_REQUEST EXPAND=FALSE

      PROCEDURE [XREF] cmp$destroy_io_request (
              VAR request_id: cmt$subsystem_io_request_id;
              VAR status: ost$status);

??PUSH (LISTEXT:= ON)??
*copyc cmt$subsystem_io_request_id
*copyc ost$status
??POP??
*DECK DECK=CMP$DETERMINE_ACTIVE_CONNECTION EXPAND=FALSE
*DECK DECK=CMP$DETERMINE_ACTIVE_PATH EXPAND=FALSE
  PROCEDURE [XREF] cmp$determine_active_path
    (    channel_element: cmt$element_definition;
         controller_element: cmt$element_definition;
         unit_element: cmt$element_definition;
     VAR active: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_definition
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DETERMINE_ELEMENT_TYPE EXPAND=FALSE


  PROCEDURE [XREF] cmp$determine_element_type
    (    product_id_string: ost$name;
     VAR element_definition: cmt$element_definition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_definition
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DETERMINE_REDUNDANT_CHANNEL EXPAND=FALSE

  PROCEDURE [XREF] cmp$determine_redundant_channel
    (    channel: cmt$physical_channel;
         iou_number: dst$iou_number;
         ignore_state: boolean;
     VAR redundant: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$physical_channel
*copyc dst$iou_number
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DETERMINE_RESOURCES EXPAND=FALSE
*DECK DECK=CMP$DETERMINE_RESOURCE_REQUESTS EXPAND=FALSE

  PROCEDURE [XREF] cmp$determine_resource_requests (sys_dev_channel_number:
    cmt$channel_ordinal,
        sys_dev_equipment_number: cmt$physical_equipment_number;
        sys_dev_unit_number: cmt$physical_unit_number;
    VAR status: ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc cmt$channel_ordinal
*copyc cmt$physical_equipment_number
*copyc cmt$physical_unit_number
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DETERMINE_TAPE_ELEMENT EXPAND=FALSE

  PROCEDURE [XREF] cmp$determine_tape_element
    (    element: cmt$element_descriptor;
     VAR tape_element: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_descriptor
?? POP ??
*DECK DECK=CMP$DE_CONFIGURE_DS_DEVICE EXPAND=FALSE

  PROCEDURE [XREF] cmp$de_configure_ds_device
    (VAR status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DFT_ACQUIRE_MAINTENANCE EXPAND=FALSE

  PROCEDURE [XREF] cmp$dft_acquire_maintenance
    (    device_path: dst$device_path;
     VAR device_information: cmt$device_information;
     VAR controller_name: cmt$element_name;
     VAR element_name: cmt$element_name;
     VAR unit_shared_interlock_set: boolean;
     VAR maintenance_acquired: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$device_information
*copyc cmt$element_name
*copyc dst$device_path
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DFT_RELEASE_MAINTENANCE EXPAND=FALSE

  PROCEDURE [XREF] cmp$dft_release_maintenance
    (    device_information: cmt$device_information;
         controller_name: cmt$element_name;
         element_name: cmt$element_name;
         unit_shared_interlock_set: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$device_information
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DISABLE_UNIT EXPAND=FALSE

  PROCEDURE [XREF] cmp$disable_unit (logical_unit_number : iot$logical_unit);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
?? POP ??
*DECK DECK=CMP$DISPLAY_ELEMENTS_DEF EXPAND=FALSE

   PROCEDURE [XREF] cmp$display_elements_def (
            display_option : cmt$lcu_display_option_key;
            display_by_name : BOOLEAN;
            name : cmt$element_name;
            file_id : amt$file_identifier;
         VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cmt$element_name
*copyc cmt$lcu_display_option_key
*copyc amt$file_identifier
?? POP ??
*DECK DECK=CMP$DISPLAY_MENU_SELECTION EXPAND=TRUE
PROCEDURE (HIDDEN) cmp$display_menu_selection (
  menu_selection, ms: string = $required
  menu_items, mi: list of name = $required
  output, o: file = $output
  status)

"$FORMAT=OFF
VAR
   i:integer
   selection_name: name
VAREND

"$FORMAT=ON

  IF menu_selection = '+GO' THEN
    put_line ' **************************' o=output.$eoi
    put_line ' ****** Operator entered GO' o=output.$eoi
    put_line ' **************************' o=output.$eoi
  ELSE
    selection_name=$name(menu_selection)
    array=$array(menu_items)
    FOR i= 1 TO $size(menu_items) DO
      IF selection_name = array(i) THEN
        put_line ' ***************************************' o=output.$eoi
        put_line ' ****** Operator chose menu selection: '//i o=output.$eoi
        put_line ' ***************************************' o=output.$eoi
        EXIT_PROC
      IFEND
    FOREND
  IFEND

PROCEND cmp$display_menu_selection
*DECK DECK=CMP$DISPLAY_MF_CONFIGURATION EXPAND=FALSE
  PROCEDURE [XREF] cmp$display_mf_configuration
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc ost$status
?? POP ??

*DECK DECK=CMP$DISPLAY_NAMED_ELEMENT EXPAND=FALSE

{ COMMON DECK CMXDNE }

  PROCEDURE [XREF] cmp$display_named_element (element_name: cmt$element_name;
        iou_name : cmt$element_name;
        display_option : cmt$display_option;
        element_count: integer;
        lc_element : ^array [1 .. * ] of cmt$element_definition;
    VAR display_control: clt$display_control;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_definition
*copyc cmt$display_option
*copyc CMT$ELEMENT_NAME
*copyc CLT$DISPLAY_CONTROL
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$DISPLAY_NETW_CONFIGURATION EXPAND=FALSE
  PROCEDURE [XREF] cmp$display_netw_configuration
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CMP$DISPLAY_TYPE_ELEMENTS EXPAND=FALSE


  PROCEDURE [XREF] cmp$display_type_elements (element_type: cmt$element_type;
        display_option : cmt$display_option;
        element_count: integer;
        lc_element : ^array [1 .. * ] of cmt$element_definition;
    VAR display_control: clt$display_control;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$display_option
*copyc cmt$element_definition
*copyc CMT$ELEMENT_TYPE
*copyc CLT$DISPLAY_CONTROL
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$DOWN_FOREIGN_IO EXPAND=FALSE



PROCEDURE [XREF] cmp$down_foreign_io (
   request_id: cmt$subsystem_io_request_id;
   VAR status: ost$status);

*copyc ost$status
*copyc cmt$subsystem_io_request_id

*DECK DECK=CMP$DUMMY_UP_PP EXPAND=FALSE

 PROCEDURE [XREF] cmp$dummy_up_pp
  (VAR element_reservation: ARRAY [1 .. *] OF cmt$element_reservation;
   VAR program_description:
    {input, output} array [1 .. * ] OF cmt$pp_program_description;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pp_program_description
*copyc ost$status
?? POP ??
*DECK DECK=CMP$ECHO_COMMAND EXPAND=FALSE


   PROCEDURE [XREF] cmp$echo_command (
            command_line : ost$string;
        VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$string
*copyc ost$status
?? POP ??
*DECK DECK=CMP$ECHO_ERRORS EXPAND=FALSE

   PROCEDURE [XREF] cmp$echo_errors (
            syntax_error : boolean;
            status_echoed : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$EDIT_PC EXPAND=FALSE

  PROCEDURE [XREF] cmp$edit_pc (parameter_list : clt$parameter_list;
     VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc ost$status
?? POP ??

*DECK DECK=CMP$ENABLE_ALL_CONNECTIONS EXPAND=TRUE
  PROCEDURE [XREF] cmp$enable_all_connections;
*DECK DECK=CMP$ENABLE_FOREIGN_IO EXPAND=FALSE


PROCEDURE [XREF] cmp$enable_foreign_io (
   VAR status: ost$status);

*copyc ost$status

*DECK DECK=CMP$ENABLE_PRODUCTION_R3 EXPAND=FALSE

  PROCEDURE [XREF] cmp$enable_production_r3
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$ENABLE_UNIT EXPAND=FALSE

    PROCEDURE [XREF] cmp$enable_unit (logical_unit_number : iot$logical_unit);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
?? POP ??

*DECK DECK=CMP$EXECUTE_PP_PROGRAM EXPAND=FALSE
 PROCEDURE [XREF] cmp$execute_pp_program (VAR program_description:
    {input, output} array [1 .. * ] OF cmt$pp_program_description;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pp_program_description
*copyc ost$status
?? POP ??
*DECK DECK=CMP$EXECUTE_PROLOG_COMMANDS EXPAND=TRUE
PROCEDURE cmp$execute_prolog_commands (
  prolog_file, pf: name = $required
  prolog_procedure_name, ppn: name = $name($mainframe(identifier))
  continue_on_error, coe: boolean = true
  status)

  VAR
    ignore_status :status
    local_status :status
  VAREND
"$FORMAT=ON

" Execute the prolog to create the temporary files containing commands
  include_command $string(prolog_procedure_name) status=ignore_status

COLLECT_TEXT $local.prolog_procedure
PROCEDURE prolog_procedure (status)
"$FORMAT=OFF
 VAR
   key: name
   subcommand_status :status
 VAREND
"$FORMAT=ON
**
  IF continue_on_error THEN
COLLECT_TEXT $local.prolog_procedure.$eoi
  WHEN any_fault interrupt DO
    rap$display_message message_module=sysdp_messages ..
          message_name=report_when_fault message_parameters= ..
          osv$command_name to=$output
    display_value osv$status o=$output
    IF subcommand_status.normal THEN
      subcommand_status = osv$status
    IFEND
" Force the operator to acknowledge the error with a carriage return
    rap$press_next
    CONTINUE
  WHENEND

**
  IFEND
  copy_file $local//prolog_file $local.prolog_procedure.$eoi ..
        status=local_status

COLLECT_TEXT $local.prolog_procedure.$eoi
  EXIT_PROC with subcommand_status

PROCEND prolog_procedure
**

  IF local_status.normal THEN
    rap$display_message message_module=sysdp_messages ..
          message_name= executing_prolog message_parameters=($string(..
          prolog_file) $string(prolog_procedure_name)) to=$output
    include_line '$local.prolog_procedure' status=local_status
  ELSE
    rap$display_message message_module=sysdp_messages ..
          message_name= prolog_file_missing message_parameters=($string(..
          prolog_file) $string(prolog_procedure_name)) to=$output
" ignore the status if prolog does not exist "
    local_status.normal = TRUE
  IFEND

  delete_file $local.prolog_procedure status=ignore_status

  EXIT_PROC WITH local_status

PROCEND cmp$execute_prolog_commands
*DECK DECK=CMP$FIND_ELEMENT EXPAND=FALSE

  PROCEDURE [XREF] cmp$find_element
    (    element_name: cmt$element_name;
         iou_name: cmt$element_name;
         mainframe_owner: cmt$element_name;
         fid: amt$file_identifier;
     VAR element_p: ^cmt$element_definition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc cmt$element_definition
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$FIND_PRIMARY_CONTROLLER EXPAND=FALSE

  PROCEDURE [XREF] cmp$find_primary_controller (
         logical_unit_number: iot$logical_unit;
     VAR controller_element_p: ^cmt$element_definition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_definition
*copyc iot$logical_unit
*copyc ost$status
?? POP ??
*DECK DECK=CMP$FIND_REDUNDANT_PATH EXPAND=FALSE

  PROCEDURE [XREF] cmp$find_redundant_path
    (    primary_element: cmt$physical_address;
         new_state: cmt$element_state;
     VAR redundant_path_available: boolean;
     VAR update_controller_address: boolean;
     VAR number_of_path: integer;
     VAR redundant_channel_list: ARRAY [cmt$physical_equipment_number] OF cmt$physical_address;
     VAR redundant_path_pp_list: ARRAY [cmt$physical_equipment_number] OF iot$pp_number;
     VAR driver_name: pmt$program_name;
     VAR pp_table_rma_list: ARRAY [cmt$physical_equipment_number] OF ost$real_memory_address);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_state
*copyc cmt$physical_address
*copyc iot$pp_number
*copyc ost$hardware_subranges
*copyc pmt$program_name
?? POP ??
*DECK DECK=CMP$FIND_STATE_CHANGE_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] cmp$find_state_change_request
    (VAR outstanding_request: boolean;
     VAR element: cmt$element_descriptor;
     VAR new_state: cmt$element_state;
     VAR current_state: cmt$element_state);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_descriptor
*copyc cmt$element_state
?? POP ??
*DECK DECK=CMP$FIND_STATE_ELEMENT EXPAND=FALSE
  PROCEDURE [XREF] cmp$find_state_element (element_name : cmt$element_name;
           iou_name : cmt$element_name;
           fid : amt$file_identifier;
       VAR element : ^cmt$state_information;
       VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$state_information
*copyc ost$status
*copyc cmt$element_name
*copyc amt$file_identifier
?? POP ??
*DECK DECK=CMP$FORMAT_ERROR_MESSAGE EXPAND=TRUE


  PROCEDURE [XREF] cmp$format_error_message (element_descriptor : cmt$element_descriptor;
        physical_id : cmt$physical_identification;
        specified_physical_id : boolean;
        condition : integer;
    VAR status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc ost$status
*copyc cmt$element_descriptor
*copyc cmt$physical_identification
*copyc clp$convert_integer_to_string
?? POP ??

*DECK DECK=CMP$FORM_NETWORK_LIST EXPAND=FALSE

  PROCEDURE [XREF] cmp$form_network_list (VAR network_descriptor :
      ^nat$network_descriptor;
    VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=CMP$FREE_COMMAND_LIST EXPAND=FALSE

  PROCEDURE [XREF] cmp$free_command_list;
*DECK DECK=CMP$FREE_DEADSTART_SIGNALS EXPAND=FALSE
  PROCEDURE [XREF] cmp$free_deadstart_signals;
*DECK DECK=CMP$FREE_DESCRIPTOR EXPAND=FALSE

  PROCEDURE [XREF] cmp$free_descriptor
    (VAR command: cmt$pcu_command_descriptor);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pcu_command_descriptor
?? POP ??
*DECK DECK=CMP$FREE_ELEMENT_DEF_TABLE EXPAND=FALSE

  PROCEDURE [XREF] cmp$free_element_def_table;
*DECK DECK=CMP$FREE_PP_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] cmp$free_pp_request
    (    pp_index: iot$pp_number);

?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
?? POP ??
*DECK DECK=CMP$GENERATE_ERROR_LISTING EXPAND=FALSE

   PROCEDURE [XREF] cmp$generate_error_listing (
              error_file_name : amt$local_file_name;
        VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GENERATE_INTERFACE_TABLES EXPAND=FALSE
*DECK DECK=CMP$GENERATE_NAMVE_INT_TABLES EXPAND=FALSE
*DECK DECK=CMP$GET_CHANNEL_DEF EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_channel_def
    (    channel_identification: cmt$channel_descriptor;
     VAR channel_definition: cmt$data_channel_definition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$channel_descriptor
*copyc cmt$data_channel_definition
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_CHANNEL_DEFINITION EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_channel_definition (
          channel_identification : cmt$channel_descriptor;
      VAR channel_definition : cmt$data_channel_definition;
      VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$channel_descriptor
*copyc cmt$data_channel_definition
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_CONF_FILE EXPAND=TRUE

  PROCEDURE [XREF] cmp$get_conf_file
    (    bam_fid: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_CONNECTED_ELEMENTS EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_connected_elements
    (      element: cmt$element_definition;
          {input,output} element_name_list_p: ^array [ * ] of cmt$element_name;
      VAR number_of_entries: integer;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_definition
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_CONNECTION_COUNT EXPAND=FALSE
*DECK DECK=CMP$GET_CONNECTION_INFO EXPAND=FALSE
*DECK DECK=CMP$GET_CONNECTION_LIST EXPAND=FALSE
  PROCEDURE [XREF] cmp$get_connection_list
    (    element_definition: cmt$element_definition;
     VAR connection_count: integer;
     VAR connection_list: ^array [1 .. * ] of cmt$connection;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$connection
*copyc cmt$element_definition
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_CONNECTION_STATUS EXPAND=FALSE
  PROCEDURE [XREF] cmp$get_connection_status
    (    upline_element_descriptor: cmt$element_descriptor;
         downline_element_name: cmt$element_name;
     VAR connection_status: cmt$connection_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$connection
*copyc cmt$element_descriptor
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_CONTROLLER_TYPE EXPAND=FALSE

{ COMMON DECK CMXGCT }

  PROCEDURE [XREF] cmp$get_controller_type (pid: cmt$product_identification;
    VAR controller_type: cmt$controller_type;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc CMT$PRODUCT_IDENTIFICATION
*copyc CMT$CONTROLLER_TYPE
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$GET_CONTROLLER_TYPE_R3 EXPAND=FALSE

{ COMMON DECK CMXGCT3 }

  PROCEDURE [XREF] cmp$get_controller_type_r3 (pid: cmt$product_identification;
    VAR controller_type: cmt$controller_type;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc CMT$PRODUCT_IDENTIFICATION
*copyc CMT$CONTROLLER_TYPE
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$GET_CPU_ELEMENT_R1 EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_cpu_element_r1
    (    processor_id: ost$processor_id;
         update_cst: boolean;
     VAR cpu_element: cmt$cpu_element_definition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$cpu_element_definition
*copyc ost$processor_id
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_CPU_ELEMENT_R3 EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_cpu_element_r3
    (    processor_id: ost$processor_id;
     VAR cpu_element: ^cmt$cpu_element_definition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$cpu_element_definition
*copyc ost$processor_id
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_DEVICE_FILE EXPAND=FALSE

{ COMMON DECK CMXGDF }

  PROCEDURE [XREF] cmp$get_device_file (device_file_name: ost$name;
        segment_file_fid: amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$NAME
*copyc AMT$FILE_IDENTIFIER
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$GET_DRIVER_BY_CONTROLLER EXPAND=TRUE

  PROCEDURE [XREF] cmp$get_driver_by_controller
    (    controller: cmt$controller_type;
         concurrent: boolean;
         iou: dst$iou_number;
     VAR driver_name: dst$driver_name;
     VAR alternate_driver_name: dst$driver_name);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$controller_type
*copyc dst$driver_name
*copyc dst$iou_number
?? POP ??
*DECK DECK=CMP$GET_DRIVER_INFO EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_driver_info
    (    iou_program_name: pmt$program_name;
         concurrent_channel: boolean;
     VAR cip_driver_name: dst$driver_name;
     VAR dual_pp: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$driver_name
*copyc pmt$program_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_DRIVER_STATE EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_driver_state
    (    channel_name: cmt$element_name;
         iou_name: cmt$element_name;
     VAR driver_present: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_ELEMENT_DEFINITION EXPAND=FALSE


 PROCEDURE [XREF] cmp$get_element_definition (element: cmt$element_descriptor;
    VAR definition: cmt$element_definition;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cme$logical_configuration_mgr
*copyc cme$reserve_element
*copyc cmt$element_descriptor
*copyc cmt$element_definition
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_ELEMENT_ENTRY EXPAND=FALSE
*DECK DECK=CMP$GET_ELEMENT_ENTRY_R1 EXPAND=FALSE
*DECK DECK=CMP$GET_ELEMENT_ENTRY_VIA_ADR EXPAND=FALSE
  PROCEDURE [XREF] cmp$get_element_entry_via_adr
    (    physical_address: cmt$physical_address;
     VAR entry_p: ^cmt$peripheral_element_entry);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$peripheral_element_entry
*copyc cmt$physical_address
?? POP ??
*DECK DECK=CMP$GET_ELEMENT_ENTRY_VIA_LUN EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_element_entry_via_lun
    (    logical_unit: iot$logical_unit;
     VAR entry_p: ^cmt$peripheral_element_entry);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$peripheral_element_entry
*copyc iot$logical_unit
?? POP ??
*DECK DECK=CMP$GET_ELEMENT_ENTRY_VIA_NAME EXPAND=FALSE
  PROCEDURE [XREF] cmp$get_element_entry_via_name
    (    element_name: cmt$element_name;
         iou_number: dst$iou_number;
     VAR entry_p: ^cmt$peripheral_element_entry);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$peripheral_element_entry
*copyc dst$iou_number
?? POP ??
*DECK DECK=CMP$GET_ELEMENT_INFORMATION EXPAND=FALSE
 PROCEDURE [XREF] cmp$get_element_information (element: cmt$element_descriptor;
    VAR information: cmt$element_information;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cme$logical_configuration_mgr
*copyc cme$reserve_element
*copyc cmt$element_descriptor
*copyc cmt$element_information
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_ELEMENT_NAME EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_element_name (physical_identification :
                cmt$physical_identification;
            VAR element : cmt$element_descriptor;
            VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cme$logical_configuration_mgr
*copyc cme$reserve_element
*copyc cmt$element_descriptor
*copyc cmt$physical_identification
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_ELEMENT_NAMES EXPAND=FALSE


  PROCEDURE [XREF] cmp$get_element_names (
       selector : cmt$element_selector;
       elements : ^array [ * ] of cmt$element_name;
   VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_selector
*copyc ost$status
*copyc cmt$element_name
?? POP ??







*DECK DECK=CMP$GET_ELEMENT_NAME_VIA_LUN EXPAND=FALSE


  PROCEDURE [XREF] cmp$get_element_name_via_lun (logical_unit_number: iot$logical_unit;
    VAR element_name: cmt$element_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
*copyc CMT$ELEMENT_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$GET_ELEMENT_R11 EXPAND=FALSE
*DECK DECK=CMP$GET_ELEMENT_R3 EXPAND=FALSE

{ COMMON DECK CMXGER3 }

  PROCEDURE [XREF] cmp$get_element_r3 (element_name: cmt$element_name;
        iou_name : cmt$element_name;
    VAR mainframe_element: ^cmt$element_definition;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc CMT$ELEMENT_NAME
*copyc cmt$element_definition
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$GET_ELEMENT_STATE EXPAND=TRUE

  PROCEDURE [XREF] cmp$get_element_state (element_name : cmt$element_name;
           iou_name : cmt$element_name;
       VAR state : cmt$element_state;
       VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$element_state
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_ELEMENT_STATE_VIA_LUN EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_element_state_via_lun (logical_unit_number:
        iot$logical_unit;
        VAR state : cmt$element_state);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_state
*copyc iot$logical_unit
?? POP ??
*DECK DECK=CMP$GET_ELEMENT_TYPE EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_element_type (
        element_name : cmt$element_name;
        iou_name : cmt$element_name;
    VAR element_type : cmt$element_type;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$element_type
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_ELEMENT_VIA_LUN EXPAND=FALSE
  PROCEDURE [XREF] cmp$get_element_via_lun
    (    logical_unit_number: iot$logical_unit;
     VAR element_p: ^cmt$peripheral_element_entry);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$peripheral_element_entry
*copyc iot$logical_unit
?? POP ??
*DECK DECK=CMP$GET_ELEMENT_VIA_NAME EXPAND=FALSE
  PROCEDURE [XREF] cmp$get_element_via_name
    (    element_name: cmt$element_name;
         iou_number: dst$iou_number;
     VAR element_p: ^cmt$peripheral_element_entry);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$peripheral_element_entry
*copyc dst$iou_number
?? POP ??
*DECK DECK=CMP$GET_IOU_DEFINITION EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_iou_definition (
          iou_name : cmt$element_name;
      VAR iou_definition : cmt$iou_definition;
      VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$iou_definition
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_IO_COMPLETION_TBL_ENTRY EXPAND=FALSE

  PROCEDURE [INLINE] cmp$get_io_completion_tbl_entry (io_completion_queue_index:
    cmt$io_completion_queue_index;
    VAR io_completion_table_entry_p: ^cmt$io_completion_table_entry);

*copyc cmh$get_io_completion_tbl_entry

??PUSH (LISTEXT:= ON) ??
    VAR
      io_completion_table_p: ^cmt$io_completion_table;

    io_completion_table_entry_p := NIL;

    io_completion_table_p := cmv$io_completion_table_p;

    io_completion_table_entry_p := ^io_completion_table_p^.entries [io_completion_queue_index];

  PROCEND cmp$get_io_completion_tbl_entry;

*copyc cmv$io_completion_table
*copyc cmt$io_completion_queue_index
*copyc iot$io_completion_table
??POP??
*DECK DECK=CMP$GET_LOGICAL_ATTRIBUTES EXPAND=FALSE

{ COMMON DECK CMXGLAT }

  PROCEDURE [XREF] cmp$get_logical_attributes (product_identification:
    cmt$product_identification;
    VAR p_logical_attributes: ^dmt$logical_device_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc CMT$PRODUCT_IDENTIFICATION
*copyc dmt$logical_device_attributes
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$GET_LOGICAL_PP_INDEX EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_logical_pp_index
    (    channel_element: cmt$element_definition;
     VAR logical_pp_index: iot$pp_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_definition
*copyc iot$pp_number
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_LOGICAL_PP_NUMBER EXPAND=FALSE

      PROCEDURE [XREF] cmp$get_logical_pp_number (
                 element_name: cmt$element_name;
             VAR logical_pp_number: iot$pp_number;
             VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc iot$pp_number
*copyc ost$status
?? POP ??

*DECK DECK=CMP$GET_LOGICAL_PP_TABLE_INDEX EXPAND=TRUE

  PROCEDURE [XREF] cmp$get_logical_pp_table_index
    (    element_name: cmt$element_name;
     VAR logical_pp_table_index: integer;
     VAR status: ost$status);
*DECK DECK=CMP$GET_LOGICAL_UNIT_NUMBER EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_logical_unit_number
    (    element_name: cmt$element_name;
     VAR logical_unit_number: iot$logical_unit;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc iot$logical_unit
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_LOGICAL_UNIT_NUMBER_R3 EXPAND=FALSE

{ COMMON DECK CMXGLU3 }


  PROCEDURE [XREF] cmp$get_logical_unit_number_r3 (element_name: cmt$element_name;
    VAR logical_unit_number: iot$logical_unit;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc CMT$ELEMENT_NAME
*copyc IOT$LOGICAL_UNIT
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$GET_LOGICAL_UNIT_STATE EXPAND=FALSE

    PROCEDURE [XREF] cmp$get_logical_unit_state (
           logical_unit : iot$logical_unit;
           table_p : ^cmt$logical_unit_table;
       VAR state : cmt$element_state);

?? PUSH(LISTEXT := ON) ??
*copyc cmt$logical_unit_table
*copyc cmt$element_state
*copyc iot$logical_unit
?? POP ??
*DECK DECK=CMP$GET_MAINFRAME_ELEMENT EXPAND=FALSE

{ COMMON DECK CMXGME }

  PROCEDURE [XREF] cmp$get_mainframe_element (element_name: cmt$element_name;
        iou_name : cmt$element_name;
    VAR mainframe_element: cmt$element_definition;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc CMT$ELEMENT_NAME
*copyc cmt$element_definition
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$GET_MASS_STORAGE_INFO EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_mass_storage_info
    (    logical_unit: iot$logical_unit;
     VAR mass_storage: cmt$mass_storage_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$mass_storage_information
*copyc iot$logical_unit
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_MAX_NUMBER_OF_PP EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_max_number_of_pp
    (VAR max_number_of_pp: iot$pp_number);

?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
?? POP ??
*DECK DECK=CMP$GET_MS_CLASS_ON_VOLUME EXPAND=FALSE
  PROCEDURE [XREF] cmp$get_ms_class_on_volume
    (    recorded_vsn: rmt$recorded_vsn;
     VAR volume_found: boolean;
     VAR ms_class_info: cmt$ms_class_info);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$ms_class_info
*copyc rmd$volume_declarations
?? POP ??
*DECK DECK=CMP$GET_MS_CLASS_ON_VOLUME_R1 EXPAND=FALSE
  PROCEDURE [XREF] cmp$get_ms_class_on_volume_r1
    (    recorded_vsn: rmt$recorded_vsn;
     VAR volume_found: boolean;
     VAR ms_class_info: cmt$ms_class_info);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$ms_class_info
*copyc rmd$volume_declarations
?? POP ??
*DECK DECK=CMP$GET_MS_LOGICAL_UNIT_NUMBERS EXPAND=FALSE

{ COMMON DECK CMXGMSU }

  PROCEDURE [XREF] cmp$get_ms_logical_unit_numbers (VAR ms_logical_unit_list:
cmt$ms_logical_unit_list;
    VAR list_count: iot$logical_unit;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
*copyc CMT$PRODUCT_IDENTIFICATION
*copyc CMT$MS_LOGICAL_UNIT_LIST
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$GET_MS_STATUS_VIA_LUN EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_ms_status_via_lun (
        lun : iot$logical_unit;
    VAR element_status : iot$unit_status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc iot$unit_interface_table
?? POP ??
*DECK DECK=CMP$GET_MS_VOLUMES EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_ms_volumes (
    VAR max_ms_volumes : INTEGER);
*DECK DECK=CMP$GET_MS_VOLUME_INFO EXPAND=FALSE
  PROCEDURE [XREF] cmp$get_ms_volume_info
    (VAR ms_volumes: ^array [ * ] of cmt$mass_storage_volume);

*copyc cmt$mass_storage_volume
*DECK DECK=CMP$GET_NEW_LOGICAL_PP_INDEX EXPAND=FALSE
*DECK DECK=CMP$GET_NEXT_REQUEST EXPAND=TRUE

  PROCEDURE [XREF] cmp$get_next_request
    (    element_name: cmt$element_name;
     VAR next_request_p: ^iot$io_request;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc iot$io_request
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_NUMBER_OF_ELEMENT EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_number_of_element
    (VAR element_count: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_NUMBER_OF_ELEMENTS EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_number_of_elements (
       selector : cmt$element_selector;
   VAR number_of_elements : integer;
   VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_selector
*copyc ost$status
?? POP ??

*DECK DECK=CMP$GET_NUMBER_OF_IO_ENTRIES EXPAND=FALSE

      PROCEDURE [INLINE] cmp$get_number_of_io_entries (
                 VAR number_of_entries: cmt$io_completion_queue_index);

*copyc cmh$get_number_of_io_entries

??PUSH (LISTEXT := ON)??
*copyc cmv$io_completion_table

         number_of_entries := 0;

         IF cmv$io_completion_table_p <> NIL THEN
           number_of_entries := UPPERBOUND (cmv$io_completion_table_p^.entries);
         IFEND;

      PROCEND cmp$get_number_of_io_entries;

*copyc cmt$io_completion_queue_index
??POP??
*DECK DECK=CMP$GET_PARITY_STATUS_INFO EXPAND=FALSE
  PROCEDURE [XREF] cmp$get_parity_status_info
    (    element_name: cmt$element_name;
     VAR parity_status: iot$unit_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc iot$unit_interface_table
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_PHYSICAL_ATTRIBUTES EXPAND=FALSE

{ COMMON DECK CMXGPAT }

  PROCEDURE [XREF] cmp$get_physical_attributes (product_identification:
    cmt$product_identification;
    VAR p_physical_attributes: ^dmt$physical_device_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc CMT$PRODUCT_IDENTIFICATION
*copyc dmt$physical_device_attributes
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$GET_PP_DEF EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_pp_def
    (    pp_identification: cmt$pp_descriptor;
     VAR pp_definition: cmt$pp_definition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pp_descriptor
*copyc cmt$pp_definition
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_PP_DEFINITION EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_pp_definition (
           pp_identification : cmt$pp_descriptor;
      VAR  pp_definition : cmt$pp_definition;
      VAR  status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pp_descriptor
*copyc cmt$pp_definition
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_PP_REG EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_pp_reg (pp: dst$iou_resource;
    VAR pp_registers: dst$dft_pp_registers;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$dft_pp_registers
*copyc dst$iou_resource
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_PP_REGISTERS EXPAND=FALSE
 PROCEDURE [XREF] cmp$get_pp_registers (pp_identification:
  cmt$pp_identification;
    VAR pp_registers: cmt$pp_registers;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pp_identification
*copyc cmt$pp_registers
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_PP_TABLE_DESCRIPTOR EXPAND=TRUE
*DECK DECK=CMP$GET_PP_TABLE_RMA EXPAND=FALSE

   PROCEDURE [XREF] cmp$get_pp_table_rma (element :
              cmt$element_definition;
        VAR pp_table_rma : ost$real_memory_address;
        VAR status : ost$status);

?? PUSH(LISTEXT := ON)??
*copyc cmt$element_definition
*copyc ost$hardware_subranges
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_RESERVATION_INFO EXPAND=FALSE
  PROCEDURE [XREF] cmp$get_reservation_info (table_index : integer;
      VAR reservable_element : boolean;
      VAR reserved_to_job : boolean;
      VAR reserving_job : jmt$system_supplied_name);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
?? POP ??
*DECK DECK=CMP$GET_RESPONSE_HANDLER EXPAND=TRUE

{ COMMON DECK CMXGRH }

  PROCEDURE [XREF] cmp$get_response_handler (controller_type:
    cmt$controller_type;
    VAR response_handler: cmt$response_handler);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_NAME
*copyc CMT$RESPONSE_HANDLER
?? POP ??
*DECK DECK=CMP$GET_SSIOT_ENTRY_AVAIL_QUEUE EXPAND=FALSE

      PROCEDURE [XREF] cmp$get_ssiot_entry_avail_queue (
          VAR job_completion_queue_index: cmt$io_completion_queue_index);

??PUSH (LISTEXT := ON)??
*copyc cmt$io_completion_queue_index
??POP??
*DECK DECK=CMP$GET_STATE_INFORMATION EXPAND=FALSE
*DECK DECK=CMP$GET_SUBSYS_EQUIPMENT_DESC EXPAND=FALSE

      PROCEDURE [XREF] cmp$get_subsys_equipment_desc (
                      pp_number: iot$pp_number;
                      logical_unit: iot$logical_unit;
                  VAR equipment_description: cmt$subsystem_equip_description;
                  VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
*copyc iot$logical_unit
*copyc cmt$subsystem_equip_description
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_SUBSYS_EQUIP_DESC_R1 EXPAND=FALSE

      PROCEDURE [XREF] cmp$get_subsys_equip_desc_r1 (
                      pp_number: iot$pp_number;
                      logical_unit: iot$logical_unit;
                  VAR equipment_description: cmt$subsystem_equip_description;
                  VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
*copyc iot$logical_unit
*copyc cmt$subsystem_equip_description
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_SYSTEM_DEVICE_PATH EXPAND=TRUE

  PROCEDURE [XREF] cmp$get_system_device_path
    (    device: cmt$system_device_types;
     VAR iou: cmt$element_name;
     VAR channel: cmt$physical_channel;
     VAR equipment_number: cmt$physical_equipment_number;
     VAR unit_number: cmt$physical_unit_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$physical_channel
*copyc cmt$physical_equipment_number
*copyc cmt$physical_unit_number
*copyc cmt$system_device_types
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_SYS_DEV_REC_VSN EXPAND=FALSE

{ COMMON DECK CMXGVSN }

  PROCEDURE [XREF] cmp$get_sys_dev_rec_vsn (VAR recorded_vsn:
    rmt$recorded_vsn;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$GET_UNIT_NUMBER_VIA_VSN EXPAND=FALSE

{ COMMON DECK CMXGUNV }

  PROCEDURE [XREF] cmp$get_unit_number_via_vsn (recorded_vsn: rmt$recorded_vsn;
    VAR logical_unit_number: iot$logical_unit;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc IOT$LOGICAL_UNIT
*copyc OST$STATUS
*copyc dmt$error_condition_codes
?? POP ??
*DECK DECK=CMP$GET_UNIT_TYPE EXPAND=FALSE

  PROCEDURE [INLINE] cmp$get_unit_type
    (    product_id: cmt$product_identification;
     VAR cm_unit_type: cmt$unit_type;
     VAR io_unit_type: iot$unit_type;
     VAR unit_class: cmt$unit_class;
     VAR found: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      index: integer;

    { This INLINE procedure can only be called from ring 3 and
    { below.  It returns the internal CM and IO unit type along
    { with the class of unit. FOUND is set to false if the product
    { id is unknown to NOS/VE.

    found := FALSE;

    FOR index := 1 TO UPPERBOUND (cmv$product_id_ptr^) DO
      IF product_id = cmv$product_id_ptr^ [index].product_id THEN
        found := TRUE;
        cm_unit_type := cmv$product_id_ptr^ [index].cm_unit_type;
        io_unit_type := cmv$product_id_ptr^ [index].io_unit_type;
        unit_class := cmv$product_id_ptr^ [index].unit_class;
        RETURN;
      IFEND;
    FOREND;

    IF (product_id.product_number = ' $2620') OR (product_id.product_number = ' $2621') THEN
      unit_class := cmc$network_unit;
      io_unit_type := ioc$dt_mdi_1;
    ELSEIF product_id.product_number = ' $4000' THEN
      unit_class := cmc$network_unit;
      io_unit_type := ioc$dt_expresslink;
    ELSEIF product_id.product_number = ' $2629' THEN
      unit_class := cmc$network_unit;
      io_unit_type := ioc$dt_ica_2;
    ELSEIF (product_id.product_number = ' $7040') OR (product_id.product_number = ' $5380') THEN
      unit_class := cmc$network_unit;
      io_unit_type := ioc$dt_file_server;
    ELSEIF product_id.product_number = '  $380' THEN
      unit_class := cmc$rhfam_unit;
      io_unit_type := ioc$dt_lcn_1;
    ELSEIF product_id.product_number = '$65354' THEN
      found := TRUE;
      cm_unit_type := cmc$map_1;
      unit_class := cmc$map_unit;
      IF product_id.model_number = '10 ' THEN
        io_unit_type := ioc$dt_map_1;
      ELSE
        io_unit_type := ioc$dt_map_cmi_1;
      IFEND;
    ELSE
      cm_unit_type := cmc$foreign_unit;
      io_unit_type := ioc$dt_foreign_device;
    IFEND;

  PROCEND cmp$get_unit_type;

*copyc iot$unit_type
*copyc cmt$unit_type
*copyc cmv$product_id_string
?? POP ??
*DECK DECK=CMP$GET_VOLUMES_ACTIVE EXPAND=FALSE

  PROCEDURE [XREF] cmp$get_volumes_active
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$GET_VOLUME_ATTRIBUTES EXPAND=FALSE
  PROCEDURE [XREF] cmp$get_volume_attributes (logical_unit_number: iot$logical_unit;
    VAR volume_attribute_info: dmt$volume_attribute_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON)??
*copyc dmt$volume_attribute_info
*copyc iot$logical_unit
*copyc ost$status
?? POP ??
*DECK DECK=CMP$HARDWARE_IDLE_PP EXPAND=FALSE

   PROCEDURE [XREF] cmp$hardware_idle_pp (
             pp : dst$iou_resource;
             dump_pp : boolean;
             dump_registers_only : boolean;
             pp_memory : ^SEQ ( * );
         VAR actual_pp_memory_size : cmt$pp_memory_length;
         VAR pp_registers : cmt$pp_registers;
         VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$iou_resource
*copyc ost$status
*copyc cmt$pp_registers
*copyc cmt$pp_memory_length
?? POP ??
*DECK DECK=CMP$HARDWARE_RESUME_PP EXPAND=FALSE

   PROCEDURE [XREF] cmp$hardware_resume_pp (pp : dst$iou_resource;
            start_address : 0 .. 0ffff(16);
        VAR status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc dst$iou_resource
*copyc ost$status
?? POP ??
*DECK DECK=CMP$HIDE_COMMANDS EXPAND=FALSE

  PROCEDURE [XREF] cmp$hide_commands
    (lcu_command_list: ^clt$command_table;
     lcu_function_list: ^clt$function_processor_table);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_table
*copyc clt$function_processor_table
?? POP ??
*DECK DECK=CMP$IDLE_PP EXPAND=FALSE

 PROCEDURE [XREF] cmp$idle_pp (pp_identification: cmt$pp_identification;
        break_interlocks : boolean;
        hardware_idle_pp : boolean;
        pp_memory_area: ^SEQ ( * );
    VAR actual_pp_memory_size : cmt$pp_memory_length;
    VAR pp_registers : cmt$pp_registers;
    VAR pp_software_idled : boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pp_identification
*copyc cmt$pp_memory_length
*copyc cmt$pp_registers
*copyc ost$status
?? POP ??
*DECK DECK=CMP$IDLE_PP_R1 EXPAND=FALSE

  PROCEDURE [XREF] cmp$idle_pp_r1 (
        channel_name : cmt$element_name;
        iou_name : cmt$element_name;
    VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$IDLE_SYSTEM_DEVICE_DRIVER EXPAND=FALSE

  PROCEDURE [XREF] cmp$idle_system_device_driver (master_pp : dst$iou_resource;
    VAR dual_pp : boolean;
    VAR pp_interface_table_rma : ost$real_memory_address;
    VAR partner_pp : dst$iou_resource);

?? PUSH (LISTEXT := ON) ??
*copyc dst$iou_resource
*copyc ost$hardware_subranges
?? POP ??

*DECK DECK=CMP$ILLEGAL_UNIT_NUMBER EXPAND=FALSE

{ COMMON DECK CMXIUN }

?? PUSH (LISTEXT := ON) ??
*copyc OSP$SET_STATUS_ABNORMAL
*copyc CLP$CONVERT_INTEGER_TO_STRING
*copyc cme$physical_configuration_mgr
?? POP ??

  PROCEDURE [inline] cmp$illegal_unit_number (illegal_unit_number: integer;
        condition: ost$status_condition;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??

    VAR
      str: ost$string,
      local_status: ost$status;

    clp$convert_integer_to_string (illegal_unit_number, 10, TRUE, str,
          local_status);

    osp$set_status_abnormal (cmc$configuration_management_id, condition, str.
          value (1, str.size), status);

  PROCEND cmp$illegal_unit_number;

?? POP ??
*DECK DECK=CMP$INCREMENT_PCU_ERROR_COUNT EXPAND=FALSE

  PROCEDURE [XREF] cmp$increment_pcu_error_count;
*DECK DECK=CMP$INITIALIZE_ADTT EXPAND=FALSE

  PROCEDURE [XREF] cmp$initialize_adtt
    (    sys_dev_channel_number: cmt$channel_ordinal;
         sys_dev_equipment_number: cmt$physical_equipment_number;
         logical_pp_table_p: ^cmt$logical_pp_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$channel_ordinal
*copyc cmp$logical_pp_table
*copyc cmt$physical_equipment_number
*copyc ost$status
?? POP ??
*DECK DECK=CMP$INITIALIZE_DFT EXPAND=TRUE

  PROCEDURE [XREF] cmp$initialize_dft
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$INITIALIZE_MS_VOLUME EXPAND=FALSE
{
{ cmp$initialize_ms_volume
{

  PROCEDURE [XREF] cmp$initialize_ms_volume (access_code: ost$name;
        product_id: cmt$product_identification,
        owner_id: ost$user_identification;
        p_physical_attributes: ^dmt$physical_device_attributes;
        p_logical_attributes: ^dmt$logical_device_attributes;
        p_volume_label_attributes: ^dmt$volume_label_attributes;
        logical_unit_number: iot$logical_unit;
        allowed_to_overwrite_volume: boolean;
        retain_device_flaws: boolean;
    VAR initialize_status_info: dmt$initialize_status_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc cmt$product_identification
*copyc ost$user_identification
*copyc dmt$logical_device_attributes
*copyc dmt$physical_device_attributes
*copyc dmt$volume_label_attributes
*copyc iot$logical_unit
*copyc OST$STATUS
*copyc DMT$INITIALIZE_STATUS_INFO
?? POP ??
*DECK DECK=CMP$INITIALIZE_STATUS EXPAND=TRUE
*DECK DECK=CMP$INITIALIZE_TAPE_VOLUME EXPAND=FALSE

  PROCEDURE [XREF] cmp$initialize_tape_volume
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CMP$INITIATED_JOB_STATUS EXPAND=FALSE

      PROCEDURE [XREF] cmp$initiated_job_status (job_name: jmt$name;
                                  VAR job_executing: boolean);

?? PUSH (LISTEXT := ON)??
*copyc jmt$name
?? POP ??
*DECK DECK=CMP$INSTALL_CONFIGURATION EXPAND=TRUE
PROCEDURE (HIDDEN) cmp$install_configuration (
  deadstart_phase, dp: key
      installation, reinstallation, continuation
    keyend = $required
  operator_intervention_required, oir: boolean = $required
  prolog_procedure_name, ppn: name = $required
  operator_intervention_occurred, oio: (VAR) boolean = $required
  status)

"$FORMAT=OFF
VAR
   cmv$configuration_activated: (xref) boolean
   cmv$device_file_copy_status: (xref) status
   configuration_missing: boolean
   ignore_status: status
   intervene: boolean=operator_intervention_required
   local_status: status
   menu_selection: string
   message_name: name
VAREND

"$FORMAT=ON

  message_name = none
  configuration_missing = false
  IF ($file($local.physical_config, opened)) AND ..
        ($file($local.physical_config, size) > 0) THEN
    change_file_attribute $local.physical_config ra=(11, 11, 11) ..
          status=ignore_status
    copy_file $local.physical_config $local.physical_configuration ..
          status=local_status
    IF deadstart_phase = continuation THEN
      IF NOT cmv$device_file_copy_status.normal THEN
        message_name = missing_installed_config
        configuration_missing = true
        intervene = true
      ELSEIF intervene AND local_status.normal THEN
        rap$display_message message_module=sysdp_messages ..
              message_name= installed_config_ok to=$output
      ELSEIF NOT local_status.normal THEN
        configuration_missing = true
        intervene = true
      IFEND
    ELSEIF NOT local_status.normal THEN
      configuration_missing = true
    IFEND
  ELSE
    configuration_missing = true
    IF deadstart_phase = continuation THEN
      intervene = true
      IF cmv$device_file_copy_status.normal THEN
        message_name = missing_ds_file_config
      ELSE
        message_name = missing_installed_config
      IFEND
    IFEND
  IFEND

  IF message_name <> none THEN
    rap$display_message message_module=sysdp_messages ..
          message_name= message_name to=$output
    rap$press_next
  IFEND

  IF configuration_missing THEN
    change_file_attribute $local.cmf$default_configuration ra=(11, 11, 11) ..
          status=ignore_status
    copy_file $local.cmf$default_configuration ..
          $local.physical_configuration status=ignore_status
    IF deadstart_phase <> continuation THEN
      rap$prompt_via_menu menu_module= unconfigured_ds_menu menu_selections=..
             (install_default, define_configuration) ..
            selection_chosen=menu_selection status=local_status
      IF local_status.normal THEN
        IF $name(menu_selection) = install_default THEN
          intervene = false
        ELSE
          intervene = true
          rap$display_message message_module=sysdp_messages ..
                message_name= unconfigured_deadstart_banner to=$output
          rap$press_next
        IFEND
      ELSE
        rap$display_message message_module=sysdp_messages ..
              message_name=report_menu_fault to=$output
        display_value local_status
        intervene = true
        rap$display_message message_module=sysdp_messages ..
              message_name= unconfigured_deadstart_banner to=$output
        rap$press_next
      IFEND
    ELSE
      intervene = true
      rap$display_message message_module=sysdp_messages ..
            message_name= unconfigured_deadstart_banner to=$output
      rap$press_next
    IFEND
  IFEND

  delete_file $local.physical_config status=ignore_status

  change_file_attribute $local.physical_configuration ra=(11, 11, 11) ..
        status=ignore_status

  IF intervene THEN
    rap$display_message message_module=sysdp_messages ..
          message_name=entering_pcu_banner to=$output
    IF deadstart_phase = continuation THEN
      rap$display_message message_module=sysdp_messages ..
            message_name=continuation_ds to=$output
    IFEND
  IFEND

  IF deadstart_phase <> continuation THEN
    IF prolog_procedure_name <> none THEN
      PHYSICAL_CONFIGURATION_UTILITY
        cmp$execute_prolog_commands ..
              prolog_procedure_name=prolog_procedure_name ..
              prolog_file=pcu_subcommands ..
              continue_on_error=false status=local_status
      QUIT
      IF NOT local_status.normal THEN
        rap$display_message message_module=sysdp_messages ..
              message_name=report_prolog_error ..
              message_parameters=$string(prolog_procedure_name) to=$output
        display_value local_status o=$output
        IF intervene = false THEN
          rap$display_message message_module=sysdp_messages ..
                message_name=entering_pcu_banner to=$output
          intervene = true
        IFEND
      IFEND
    IFEND
  IFEND

pcu: ..
  WHILE NOT cmv$configuration_activated DO
    IF intervene THEN
      PHYSICAL_CONFIGURATION_UTILITY status=local_status
        include_file command prompt='PCU'
      "$QUIT
      IF local_status.normal AND (NOT cmv$configuration_activated) THEN
        PHYSICAL_CONFIGURATION_UTILITY status=ignore_status
          IF $variable(cmv$deadstart_simulation, defined) THEN
            verify_physical_configuration mainframe=cmv$simulation_mf_name ..
                  status=local_status
          ELSE
            install_physical_configuration status=local_status
          IFEND
        QUIT
      IFEND
    ELSE
      PHYSICAL_CONFIGURATION_UTILITY status=ignore_status
        IF $variable(cmv$deadstart_simulation, defined) THEN
          verify_physical_configuration mainframe=cmv$simulation_mf_name ..
                status=local_status
        ELSE
          install_physical_configuration status=local_status
        IFEND
      QUIT
    IFEND

    IF local_status.normal AND $variable(cmv$deadstart_simulation, defined) ..
          THEN
      cmv$configuration_activated = true
    ELSEIF NOT local_status.normal THEN
      rap$display_message message_module=sysdp_messages ..
            message_name=report_error to=$output
      display_value local_status o=$output
      IF $variable(cmv$deadstart_simulation, defined) THEN
        rap$prompt_via_menu menu_module= pcu_simulation_menu menu_selections..
              =(install_configuration activate_volumes) ..
              selection_chosen=menu_selection status=local_status
        IF local_status.normal THEN
          IF $name(menu_selection) = activate_volumes THEN
            cmv$configuration_activated = true
          IFEND
        IFEND
      ELSE
        IF intervene = false THEN
          rap$display_message message_module=sysdp_messages ..
                message_name=entering_pcu_banner to=$output
          intervene = true
        IFEND
      IFEND
    IFEND
  WHILEND pcu

  rap$display_message message_module=sysdp_messages ..
        message_name= configuration_installed to=$output

  operator_intervention_occurred = intervene

PROCEND cmp$install_configuration
*DECK DECK=CMP$INSTALL_CONF_FILE EXPAND=TRUE

  PROCEDURE [XREF] cmp$install_conf_file
    (    bam_fid: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=CMP$INSTALL_NETWORK_COMMANDS EXPAND=TRUE
PROCEDURE (HIDDEN) cmp$install_network_commands (
  prolog_procedure_name, ppn: name = $required
  status)

"$FORMAT=OFF
VAR
  ignore_status: status
  local_status: status
  network_file: file = $system.network.configuration
VAREND

"$FORMAT=ON

  IF prolog_procedure_name <> none THEN
    include_line $string(prolog_procedure_name)//' status=local_status'
    IF NOT local_status.normal THEN
      rap$display_message message_module=sysdp_messages ..
            message_name=report_prolog_error ..
            message_parameters=$string(prolog_procedure_name) to=$output
      display_value local_status o=$output
    IFEND
    IF $file($local.lcu_network_subcommands opened) THEN
      IF $variable(cmv$deadstart_simulation, defined) THEN
        rap$display_message message_module=sysdp_messages ..
              message_name= network_commands_installed message_parameters=(..
              $string(network_file) $string(prolog_procedure_name)) to=$output
      ELSE
        create_catalog $system.network status=ignore_status
        copy_file $local.lcu_network_subcommands network_file.$next ..
              status=local_status
        IF local_status.normal THEN
          rap$display_message message_module=sysdp_messages ..
                message_name= network_commands_installed message_parameters=..
                ($string(network_file) $string(prolog_procedure_name)) ..
                to=$output
        ELSE
          rap$display_message message_module=sysdp_messages ..
                message_name= prolog_file_missing message_parameters=(..
                $string(prolog_file) $string(prolog_procedure_name)) ..
                to=$output
        IFEND
      IFEND
    ELSE
      rap$display_message message_module=sysdp_messages ..
            message_name= prolog_file_missing message_parameters=($string(..
            prolog_file) $string(prolog_procedure_name)) to=$output
    IFEND
  IFEND


PROCEND cmp$install_network_commands
*DECK DECK=CMP$INSTALL_PHYS_CONFIGURATION EXPAND=FALSE

   PROCEDURE [XREF] cmp$install_phys_configuration (
            parameter_list : clt$parameter_list;
       VAR  status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CMP$INSTALL_SYSTEM_CONF EXPAND=FALSE

  PROCEDURE [XREF] cmp$install_system_conf
    (    input_fid: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT:=ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=CMP$KNOWN_CONTROLLER_ID EXPAND=TRUE

{ COMMON DECK CMXKCI }

  FUNCTION [XREF] cmp$known_controller_id (product_id:
    cmt$product_identification): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc CMT$PRODUCT_IDENTIFICATION
?? POP ??
*DECK DECK=CMP$KNOWN_PRODUCT_ID EXPAND=TRUE

{ COMMON DECK CMXKPI }

  FUNCTION [XREF] cmp$known_product_id (product_id:
    cmt$product_identification): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc CMT$PRODUCT_IDENTIFICATION
?? POP ??
*DECK DECK=CMP$LCU_LOCK_SET_BY_JOB EXPAND=FALSE

  PROCEDURE [XREF] cmp$lcu_lock_set_by_job
    (VAR job_name: jmt$system_supplied_name;
     VAR lock_set: boolean);

*copyc jmt$system_supplied_name
*DECK DECK=CMP$LOAD_ALL_DRIVER EXPAND=FALSE
*DECK DECK=CMP$LOAD_CONTROLLER_MODULE EXPAND=FALSE

  PROCEDURE [XREF] cmp$load_controller_module
    (    load_controller_type: (cmc$load_controlware, cmc$load_control_module);
     VAR logical_pp_table_p: ^cmt$logical_pp_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$logical_pp_table
*copyc ost$status
?? POP ??
*DECK DECK=CMP$LOCATE_DISABLED_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] cmp$locate_disabled_connection
    (    element_definition: cmt$element_definition;
     VAR disabled_connection_exists: boolean;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_definition
*copyc ost$status
?? POP ??

*DECK DECK=CMP$LOCATE_ELEMENT_VIA_ADR EXPAND=FALSE
  PROCEDURE [XREF] cmp$locate_element_via_adr
    (    physical_address: cmt$physical_address;
     VAR peripheral_element_p: ^cmt$peripheral_element_entry);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$peripheral_element_entry
*copyc cmt$physical_address
?? POP ??
*DECK DECK=CMP$LOCATE_ELEMENT_VIA_LUN EXPAND=FALSE

  PROCEDURE [XREF] cmp$locate_element_via_lun
    (    logical_unit_number: iot$logical_unit;
     VAR element_p: ^cmt$peripheral_element_entry);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$peripheral_element_entry
*copyc iot$logical_unit
?? POP ??
*DECK DECK=CMP$LOCATE_ELEMENT_VIA_NAME EXPAND=FALSE
  PROCEDURE [XREF] cmp$locate_element_via_name
    (    element_name: cmt$element_name;
         iou_number: dst$iou_number;
     VAR element_p: ^cmt$peripheral_element_entry);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$peripheral_element_entry
*copyc dst$iou_resource
?? POP ??
*DECK DECK=CMP$LOCK_LUN_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] cmp$lock_lun_entry ALIAS 'cmxllun' (logical_unit:
    iot$logical_unit;
    VAR lun_lock_obtained: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
*copyc CMV$LOGICAL_UNIT_LOCK
  ?? POP ??
*DECK DECK=CMP$LOCK_SET_BY_CURRENT_TASK EXPAND=FALSE

  FUNCTION [XREF, UNSAFE] cmp$lock_set_by_current_task
     (lock_type: cmt$lcu_lock_type): BOOLEAN;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$lcu_lock_type
?? POP ??
*DECK DECK=CMP$LOCK_SET_BY_TASK EXPAND=FALSE

  FUNCTION [XREF, UNSAFE] cmp$lock_set_by_task
     (lock_type: cmt$lcu_lock_type): BOOLEAN;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$lcu_lock_type
?? POP ??
*DECK DECK=CMP$MANAGE_CHANNEL_LOCK EXPAND=FALSE

  PROCEDURE [XREF] cmp$manage_channel_lock
    (    set_lock : boolean;
         iou_number: dst$iou_number;
         channel_number: dst$physical_resource_number;
         concurrent : boolean;
     VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$iou_number
*copyc dst$physical_resource_number
*copyc syt$monitor_status
?? POP ??

*DECK DECK=CMP$MANAGE_DEVICE_FILE_LOCK EXPAND=FALSE

  PROCEDURE [XREF] cmp$manage_device_file_lock (set_lock : boolean;
      VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$MANAGE_LCU_LOCK EXPAND=FALSE

  PROCEDURE [XREF] cmp$manage_lcu_lock
    (    lock_type: cmt$lcu_lock_type;
         clear_lock: boolean;
         job_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$lcu_lock_type
*copyc jmt$system_supplied_name
*copyc ost$wait
*copyc ost$status
?? POP ??
*DECK DECK=CMP$MANAGE_LOCK_R3 EXPAND=FALSE

  PROCEDURE [XREF] cmp$manage_lock_r3
    (    lock_type: cmt$lcu_lock_type;
         clear_lock: boolean;
         job_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$lcu_lock_type
*copyc jmt$system_supplied_name
*copyc ost$wait
*copyc ost$status
?? POP ??
*DECK DECK=CMP$MARK_ELEMENT_RESERVED EXPAND=FALSE

  PROCEDURE [XREF] cmp$mark_element_reserved
    (    element_reservation: cmt$element_reservation;
         reserved_by_system: boolean;
         job_name: jmt$system_supplied_name;
         gtid: ost$global_task_id;
         physical_pp: dst$iou_resource;
         table_index: integer;
         channel_present: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_reservation
*copyc dst$iou_resource
*copyc jmt$system_supplied_name
*copyc ost$global_task_id
*copyc ost$status
?? POP ??
*DECK DECK=CMP$MARK_PP_ELEMENT_RESERVED EXPAND=FALSE

  PROCEDURE [XREF] cmp$mark_pp_element_reserved
    (    element_reservation: cmt$element_reservation;
         reserved_by_system: boolean;
         job_name: jmt$system_supplied_name;
         gtid: ost$global_task_id;
         physical_pp: dst$iou_resource;
         channel_present: boolean;
     VAR pp_index: iot$pp_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_reservation
*copyc dst$iou_resource
*copyc iot$pp_number
*copyc jmt$system_supplied_name
*copyc ost$global_task_id
*copyc ost$status
?? POP ??
*DECK DECK=CMP$MODIFY_INTERFACE_POINTER EXPAND=FALSE
*DECK DECK=CMP$MONITOR_ROUTINES EXPAND=FALSE
*DECK DECK=CMP$MOUNT_STORAGE_MEDIUM EXPAND=FALSE
 PROCEDURE [XREF] cmp$mount_storage_medium (
        storage_device: cmt$peripheral_descriptor;
        medium: rmt$external_vsn;
        write_access: boolean;
        wait_for_attachment: fst$wait_for_attachment;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$peripheral_descriptor
*copyc rmd$volume_declarations
*copyc fst$wait_for_attachment
*copyc ost$status
?? POP ??
*DECK DECK=CMP$MULTIPLE_IOU_SYSTEM EXPAND=FALSE
  FUNCTION [XREF, UNSAFE] cmp$multiple_iou_system: boolean;
*DECK DECK=CMP$OBTAIN_MAX_VOLUME_INDEX EXPAND=FALSE

  PROCEDURE [XREF] cmp$obtain_max_volume_index (
    VAR max_volume_index: integer);
*DECK DECK=CMP$OBTAIN_PP_RESOURCE EXPAND=FALSE
*DECK DECK=CMP$OBTAIN_VOLUMES EXPAND=FALSE

  PROCEDURE [XREF] cmp$obtain_volumes (
    VAR volume_list: ^stt$volume_list;
    VAR number_of_members: integer);

?? PUSH (LISTEXT := ON) ??
*copyc stt$volume_info
*copyc stt$volume_list
?? POP ??
*DECK DECK=CMP$OPEN_SCRATCH_ERR_FILE EXPAND=FALSE

   PROCEDURE [XREF] cmp$open_scratch_err_file (
       VAR status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$OPEN_UTILITY_FILES EXPAND=FALSE

   PROCEDURE [XREF] cmp$open_utility_files (VAR status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$PC_GET_ELEMENT EXPAND=FALSE

{ COMMON DECK CMXPCGE }

  PROCEDURE [XREF] cmp$pc_get_element (element_name: cmt$element_name;
        iou_name : cmt$element_name;
    VAR mainframe_element: ^cmt$element_definition;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc CMT$ELEMENT_NAME
*copyc cmt$element_definition
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$PC_GET_LOGICAL_PP_INDEX EXPAND=FALSE
*DECK DECK=CMP$PC_GET_LOGICAL_UNIT EXPAND=FALSE

{ COMMON DECK CMXPCLU }

  PROCEDURE [XREF] cmp$pc_get_logical_unit (logical_unit_number: iot$logical_unit;
    VAR mainframe_element: ^cmt$element_definition;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
*copyc cmt$element_definition
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$PC_GET_NEXT_CHANNEL EXPAND=FALSE

{ COMMON DECK CMXPCGC }

  PROCEDURE [XREF] cmp$pc_get_next_channel (current_channel: integer;
    VAR mainframe_element: ^cmt$element_definition;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_definition
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$PC_MODIFY_LCT EXPAND=FALSE

{ COMMON DECK CMXPCML }

  PROCEDURE [XREF] cmp$pc_modify_lct (old_lun: iot$logical_unit;
        new_lun: iot$logical_unit;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$PERFORM_LCU_INTERVENTION EXPAND=TRUE
PROCEDURE (HIDDEN) cmp$perform_lcu_intervention (
  deadstart_phase, dp: key
      installation, reinstallation, continuation
    keyend = $optional
  status)

"$FORMAT=OFF
VAR
  local_status: status
VAREND

"$FORMAT=ON

  rap$display_message message_module=sysdp_messages ..
        message_name=entering_lcu_banner to=$output
  IF deadstart_phase = continuation THEN
    rap$display_message message_module=sysdp_messages ..
          message_name=continuation_ds to=$output
  IFEND

  LOGICAL_CONFIGURATION_UTILITY status=local_status
    include_file command prompt='LCU'
  "$QUIT

lcu: ..
  WHILE NOT local_status.normal DO
    rap$display_message message_module=sysdp_messages ..
          message_name=report_lcu_error to=$output
    display_value local_status o=$output
    rap$display_message message_module=sysdp_messages ..
          message_name=entering_lcu_banner to=$output

    LOGICAL_CONFIGURATION_UTILITY status=local_status
      include_file command prompt='LCU'
    "$QUIT
  WHILEND lcu

PROCEND cmp$perform_lcu_intervention
*DECK DECK=CMP$POST_DEADSTART EXPAND=FALSE

  FUNCTION [XREF] cmp$post_deadstart : boolean;
*DECK DECK=CMP$PP_QUEUE_LOCK EXPAND=FALSE

  FUNCTION [XREF] cmp$pp_queue_lock
    (    pp_index: iot$pp_number): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
?? POP ??
*DECK DECK=CMP$PROCESS_ALL_VOLUMES EXPAND=FALSE

  PROCEDURE [XREF] cmp$process_all_volumes (
    option: (delete, add);
    class: dmt$class;
    master_vol: stt$volume_info;
    number_of_members: stt$number_of_members;
    volume_list: ^stt$volume_list);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$class
*copyc stt$volume_info
*copyc stt$number_of_members
*copyc stt$volume_list
?? POP ??
*DECK DECK=CMP$PROCESS_CPU_STATE_CHANGE EXPAND=FALSE

  PROCEDURE [XREF] cmp$process_cpu_state_change
    (    processor_id: ost$processor_id;
         current_state: cmt$element_state;
         new_state : cmt$element_state;
     VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_state
*copyc ost$processor_id
*copyc ost$status
?? POP ??
*DECK DECK=CMP$PROCESS_CPU_STATE_CHANGE_R1 EXPAND=FALSE

  PROCEDURE [XREF] cmp$process_cpu_state_change_r1
    (    processor_id: ost$processor_id;
         new_state: cmt$element_state;
     VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_state
*copyc ost$processor_id
*copyc ost$status
?? POP ??
*DECK DECK=CMP$PROCESS_DAS_RESTORE EXPAND=FALSE
{
{ cmp$process_das_restore
{

  PROCEDURE [XREF] cmp$process_das_restore
    (    product_id: cmt$product_identification;
         element: cmt$element_name;
         logical_unit_number: iot$logical_unit;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc cmt$product_identification
*copyc cmt$element_name
*copyc iot$logical_unit
?? POP ??
*DECK DECK=CMP$PROCESS_DEADSTART_SIGNALS EXPAND=FALSE

  PROCEDURE [XREF] cmp$process_deadstart_signals;
*DECK DECK=CMP$PROCESS_DEFINE_ELEMENT EXPAND=FALSE

  PROCEDURE [XREF] cmp$process_define_element
    (    parameter_value_table: ^clt$parameter_value_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_value_table
*copyc ost$status
?? POP ??
*DECK DECK=CMP$PROCESS_FORCE_FORMAT EXPAND=FALSE
{
{ cmp$process_force_format
{

  PROCEDURE [XREF] cmp$process_force_format
    (    product_id: cmt$product_identification;
         element: cmt$element_name;
         logical_unit_number: iot$logical_unit;
         force_format: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc cmt$product_identification
*copyc cmt$element_name
*copyc iot$logical_unit
?? POP ??
*DECK DECK=CMP$PROCESS_OUTSTANDING_SC_REQ EXPAND=FALSE

  PROCEDURE [XREF] cmp$process_outstanding_sc_req
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$PROCESS_STATE_CHANGE EXPAND=FALSE

  PROCEDURE [XREF] cmp$process_state_change (
          tape_element: boolean;
          clear_lock_behind: boolean;
          system_call : BOOLEAN;
          element_descriptor : cmt$element_descriptor;
          system_critical_element : boolean;
          current_state: cmt$element_state;
          new_state : cmt$element_state;
      VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_descriptor
*copyc cmt$element_state
*copyc ost$status
*copyc ost$wait
?? POP ??
*DECK DECK=CMP$PROMPT_FOR_ANSWER EXPAND=FALSE

  PROCEDURE [INLINE] cmp$prompt_for_answer
    (    prompt: string ( * );
     VAR continue: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      byte_address: amt$file_byte_address,
      file_position: amt$file_position,
      input_fid: amt$file_identifier,
      line: string (80),
      reply: string (80),
      status: ost$status,
      transfer_count: amt$transfer_count;

    continue := FALSE;
    clp$put_job_output (prompt, status);
    clp$put_job_output (' Enter yes or no: ', status);
    amp$open (clc$job_input, amc$record, NIL, input_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    WHILE TRUE DO
      line := ' ';
      amp$get_next (input_fid, ^line, #SIZE (line), transfer_count, byte_address, file_position, status);
      #TRANSLATE (osv$lower_to_upper, line, reply);
      IF (reply  (1, 3) = 'YES') OR (reply (1) = 'Y') THEN
        continue := TRUE;
        amp$close (input_fid, status);
        RETURN;
      ELSEIF (reply (1, 2) = 'NO') OR (reply (1) = 'N') THEN
        amp$close (input_fid, status);
        RETURN;
      ELSE
        clp$put_job_output ('--ERROR-- You must enter YES or NO. Please try again.', status);
      IFEND;
    WHILEND;

  PROCEND cmp$prompt_for_answer;

*copyc amp$close
*copyc amp$open
*copyc amp$get_next
*copyc clp$put_job_output
*copyc osv$lower_to_upper
?? POP ??
*DECK DECK=CMP$QUEUE_DEADSTART_SIGNAL EXPAND=FALSE
  PROCEDURE [XREF] cmp$queue_deadstart_signal
    (    originator: ost$global_task_id;
         signal: pmt$signal);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc pmt$signal
?? POP ??

*DECK DECK=CMP$QUEUE_IO_REQUEST EXPAND=FALSE

      PROCEDURE [XREF] cmp$queue_io_request (
               VAR request_id: cmt$subsystem_io_request_id;
                   queue_control: cmt$unit_queuing_options;
                   recovery_options: iot$request_recovery;
                   wait_for_io_completion: cmt$wait_for_io_completion;
               VAR status: ost$status);

??PUSH(LISTEXT:=ON)??
*copyc cmt$subsystem_io_request_id
*copyc cmt$unit_queuing_options
*copyc iot$request_recovery
*copyc cmt$io_request_type
*copyc ost$status
??POP??
*DECK DECK=CMP$QUEUE_REQUEST_R1 EXPAND=FALSE

     PROCEDURE [XREF] cmp$queue_request_r1 (
                request_id: cmt$subsystem_io_request_id;
                queue_control: cmt$unit_queuing_options;
                recovery_options: iot$request_recovery;
                ready_task_upon_io_completion: boolean;
            VAR status: ost$status);

??PUSH (LISTEXT:=ON)??
*copyc cmt$subsystem_io_request_id
*copyc cmt$unit_queuing_options
*copyc iot$request_recovery
*copyc ost$status
??POP??
*DECK DECK=CMP$QUEUE_STATE_CHANGE EXPAND=FALSE

  PROCEDURE [XREF] cmp$queue_state_change
    (    element: cmt$element_descriptor;
         state_change_request: cmt$state_change_request;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_descriptor
*copyc cmt$state_change_request
*copyc ost$status
?? POP ??
*DECK DECK=CMP$QUIT_EDIT EXPAND=FALSE

  PROCEDURE [XREF] cmp$quit_edit (parameter_list : clt$parameter_list;
     VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CMP$REACQUIRE_RESOURCES EXPAND=FALSE

   PROCEDURE [XREF] cmp$reacquire_resources (request_type :
      dst$resource_request_types;
         channel_number : cmt$physical_channel;
         channel_iou_number : dst$iou_number;
         equipment_number : 0 .. cmc$null_equipment_number;
         unit_number : 0 .. cmc$null_unit_number;
         driver_name : cmt$element_name;
         pp_table_rma : ost$real_memory_address;
         controller_type : cmt$controller_type;
         reload_driver : boolean;
     VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$hardware_subranges
*copyc cmt$element_name
*copyc cmt$controller_type
*copyc cmd$null_equipment_number
*copyc dst$resource_request
*copyc cmt$physical_channel
*copyc ost$status
?? POP ??
*DECK DECK=CMP$REBUILD_INTERFACE_TABLES EXPAND=FALSE
   PROCEDURE [XREF] cmp$rebuild_interface_tables (
             table_space : ^ost$heap;
         VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$heap
*copyc ost$status
?? POP ??
*DECK DECK=CMP$RECOVER_SUBSYSTEM_IO_TABLE EXPAND=FALSE

      PROCEDURE [XREF] cmp$recover_subsystem_io_table (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=CMP$REENABLE_UNIT EXPAND=FALSE

  FUNCTION [XREF, UNSAFE] cmp$reenable_unit
    (    path: cmt$physical_address): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$physical_address
?? POP ??

*DECK DECK=CMP$RELEASE_ALL_RESOURCES EXPAND=FALSE
*DECK DECK=CMP$RELEASE_CHANNEL_RESOURCE EXPAND=FALSE

  PROCEDURE [XREF] cmp$release_channel_resource
    (    channel: cmt$physical_channel;
         iou_number: dst$iou_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$physical_channel
*copyc dst$iou_number
*copyc ost$status
?? POP ??
*DECK DECK=CMP$RELEASE_ELEMENT EXPAND=FALSE


 PROCEDURE [XREF] cmp$release_element (element:
        array [ * ] of cmt$element_reservation;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_reservation
*copyc ost$status
?? POP ??
*DECK DECK=CMP$RELEASE_EQUIPMENT_RESOURCE EXPAND=FALSE

  PROCEDURE [XREF] cmp$release_equipment_resource
    (    channel: cmt$physical_channel;
         iou_number: dst$iou_number;
         equipment_number: 0 .. cmc$null_equipment_number;
         unit_number: 0 .. cmc$null_unit_number);

?? PUSH (LISTEXT := ON) ??
*copyc cmd$null_equipment_number
*copyc cmt$physical_channel
*copyc dst$iou_number
?? POP ??
*DECK DECK=CMP$RELEASE_PP_BY_CHANNEL EXPAND=FALSE

  PROCEDURE [XREF] cmp$release_pp_by_channel
    (    channel: cmt$physical_channel;
         iou_number: dst$iou_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$physical_channel
*copyc dst$iou_number
*copyc ost$status
?? POP ??
*DECK DECK=CMP$RELEASE_PP_BY_INDEX EXPAND=FALSE

  PROCEDURE [XREF] cmp$release_pp_by_index
    (    pp_index: iot$pp_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
*copyc ost$status
?? POP ??
*DECK DECK=CMP$RELEASE_PP_RESOURCE EXPAND=FALSE

  PROCEDURE [XREF] cmp$release_pp_resource
    (    pp_number: dst$iou_resource;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$iou_resource
*copyc ost$status
?? POP ??
*DECK DECK=CMP$RELEASE_RESOURCE EXPAND=FALSE
*DECK DECK=CMP$RELEASE_UNIT EXPAND=FALSE
*DECK DECK=CMP$REPLACE_DEFINITION EXPAND=FALSE

  PROCEDURE [XREF] cmp$replace_definition (
          element_name: cmt$element_name;
          new_descriptor: cmt$pcu_command_descriptor;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$pcu_command_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=CMP$REPLACE_ELEMENT_DEF EXPAND=FALSE

    PROCEDURE [xref] cmp$replace_element_def (parameter_list :
        clt$parameter_list;
        VAR status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CMP$REQUEST_CHANNELS EXPAND=FALSE

  PROCEDURE [INLINE] cmp$request_channels
    (    request_type: dst$resource_request_types;
         element_definition: cmt$element_definition;
         mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    { PURPOSE:
    {   This inline procedure looks at all the upline connections of certain
    {   types of element and releases or acquires all channels connected to
    {   the element only if the channel state is OFF.
    { NOTE:
    {   This routine can only be called from ring 3 or below.

    VAR
      element_descriptor: cmt$element_descriptor,
      element_reservation: cmt$element_reservation,
      channel_definition: cmt$data_channel_definition,
      channel_index: integer,
      channel: cmt$physical_channel,
      iou_number: dst$iou_number,
      dummy_physical_pp: dst$iou_resource,
      peripheral_index: integer;

    status.normal := TRUE;
    IF (request_type <> dsc$rrt_get_channel) AND (request_type <> dsc$rrt_return_channel) THEN
      RETURN;
    IFEND;

    element_descriptor.element_type := cmc$data_channel_element;
    element_descriptor.channel_descriptor.use_logical_identification := TRUE;
    CASE element_definition.element_type OF
    = cmc$controller_element =

      { Release all channels connected to controller to the real state system.

      FOR channel_index := LOWERVALUE (cmt$controller_port_number)
            TO UPPERVALUE (cmt$controller_port_number) DO
        IF element_definition.controller.connection.port [channel_index].configured AND
              (element_definition.controller.connection.port [channel_index].upline_connection_type =
              cmc$data_channel_element) THEN
          IF element_definition.controller.connection.port [channel_index].mainframe_ownership =
                mainframe_id THEN
            element_descriptor.channel_descriptor.name :=
                  element_definition.controller.connection.port [channel_index].element_name;
            element_descriptor.channel_descriptor.iou :=
                  element_definition.controller.connection.port [channel_index].iou;
            cmp$search_peripheral_table (element_descriptor, element_reservation, FALSE,
                  peripheral_index, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF cmv$peripheral_element_table.pointer^ [peripheral_index].element_status.state = cmc$off THEN
              cmp$get_channel_def (element_descriptor.channel_descriptor, channel_definition, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              channel.number := channel_definition.number;
              channel.concurrent := channel_definition.concurrent;
              channel.port := channel_definition.port;
              cmp$convert_iou_name (channel_definition.iou, iou_number, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              IF request_type = dsc$rrt_return_channel THEN
                cmp$release_channel_resource (channel, iou_number, status);
              ELSEIF request_type = dsc$rrt_get_channel THEN
                cmp$acquire_resources (request_type, channel, iou_number, 0, 0, FALSE, FALSE,
                      FALSE, dummy_physical_pp, status);
              IFEND;
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND;

    = cmc$communications_element =
      FOR channel_index := LOWERVALUE (cmt$communications_port_number)
            TO UPPERVALUE (cmt$communications_port_number) DO
        IF element_definition.communications_element.connection.port [channel_index].configured AND
              (element_definition.communications_element.connection.port [channel_index].
              upline_connection_type = cmc$data_channel_element) THEN
          IF element_definition.communications_element.connection.port [channel_index].mainframe_ownership =
                mainframe_id THEN
            element_descriptor.channel_descriptor.name :=
                  element_definition.communications_element.connection.port [channel_index].element_name;
            element_descriptor.channel_descriptor.iou :=
                  element_definition.communications_element.connection.port [channel_index].iou;
            cmp$search_peripheral_table (element_descriptor, element_reservation, FALSE, peripheral_index,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF cmv$peripheral_element_table.pointer^ [peripheral_index].element_status.state = cmc$off THEN
              cmp$get_channel_def (element_descriptor.channel_descriptor, channel_definition, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              channel.number := channel_definition.number;
              channel.concurrent := channel_definition.concurrent;
              channel.port := channel_definition.port;
              cmp$convert_iou_name (channel_definition.iou, iou_number, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              IF request_type = dsc$rrt_return_channel THEN
                cmp$release_channel_resource (channel, iou_number, status);
              ELSEIF request_type = dsc$rrt_get_channel THEN
                cmp$acquire_resources (request_type, channel, iou_number, 0, 0, FALSE, FALSE, FALSE,
                      dummy_physical_pp, status);
              IFEND;
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND;

    = cmc$storage_device_element =
      FOR channel_index := LOWERVALUE (cmt$data_storage_port_number) TO
            UPPERVALUE (cmt$data_storage_port_number) DO
        IF element_definition.storage_device.connection.port [channel_index].configured AND
              (element_definition.storage_device.connection.port [channel_index].upline_connection_type =
              cmc$data_channel_element) THEN
          IF element_definition.storage_device.connection.port [channel_index].mainframe_ownership =
                mainframe_id THEN
            element_descriptor.channel_descriptor.name :=
                  element_definition.storage_device.connection.port [channel_index].element_name;
            element_descriptor.channel_descriptor.iou :=
                  element_definition.storage_device.connection.port [channel_index].iou;
            cmp$search_peripheral_table (element_descriptor, element_reservation, FALSE,
                  peripheral_index, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF cmv$peripheral_element_table.pointer^ [peripheral_index].element_status.state = cmc$off THEN
              cmp$get_channel_def (element_descriptor.channel_descriptor, channel_definition, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              channel.number := channel_definition.number;
              channel.concurrent := channel_definition.concurrent;
              channel.port := channel_definition.port;
              cmp$convert_iou_name (channel_definition.iou, iou_number, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              IF request_type = dsc$rrt_return_channel THEN
                cmp$release_channel_resource (channel, iou_number, status);
              ELSEIF request_type = dsc$rrt_get_channel THEN
                cmp$acquire_resources (request_type, channel, iou_number, 0, 0, FALSE, FALSE, FALSE,
                      dummy_physical_pp, status);
              IFEND;
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND;

    ELSE
    CASEND;

  PROCEND cmp$request_channels;

*copyc cmp$acquire_resources
*copyc cmp$convert_iou_name
*copyc cmp$get_channel_def
*copyc cmp$release_channel_resource
*copyc cmt$element_definition
*copyc ost$status
?? POP ??
*DECK DECK=CMP$REQUEST_RESOURCES EXPAND=FALSE

  PROCEDURE [XREF] cmp$request_resources
    (    request_type: dst$resource_request_types;
     VAR resource_request: dst$resource_request;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$resource_request
*copyc ost$status
?? POP ??
*DECK DECK=CMP$RESERVE_ELEMENT EXPAND=FALSE

 PROCEDURE [XREF] cmp$reserve_element (
    VAR {input,output} element : array [ * ] of cmt$element_reservation;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_reservation
*copyc ost$status
?? POP ??
*DECK DECK=CMP$RESUME_PP EXPAND=FALSE
 PROCEDURE [XREF] cmp$resume_pp (pp_identification: cmt$pp_identification;
        hardware_resume_pp : boolean;
        start_address: cmt$pp_memory_length;
    VAR pp_software_resumed : boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pp_identification
*copyc cmt$pp_memory_length
*copyc ost$status
?? POP ??
*DECK DECK=CMP$RESUME_PP_R1 EXPAND=FALSE

  PROCEDURE [XREF] cmp$resume_pp_r1 (
       channel_name: cmt$element_name;
       iou_name: cmt$element_name;
   VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$RETRIEVE_IOU_DEFINITION EXPAND=FALSE

  PROCEDURE [XREF] cmp$retrieve_iou_definition
    (    iou_name: cmt$element_name;
     VAR iou_definition: cmt$iou_definition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$iou_definition
*copyc ost$status
?? POP ??
*DECK DECK=CMP$RETRIEVE_LOGICAL_PP_INDEX EXPAND=FALSE

  PROCEDURE [XREF] cmp$retrieve_logical_pp_index
    (    channel: cmt$physical_channel;
         iou_number: dst$iou_number;
         logical_pp_table_p: ^cmt$logical_pp_table;
     VAR logical_pp_index: iot$pp_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$logical_pp_table
*copyc ost$status
*copyc cmt$physical_channel
?? POP ??
*DECK DECK=CMP$RETURN_CONFIGURATION_LIMITS EXPAND=FALSE

  PROCEDURE [XREF] cmp$return_configuration_limits (
        product: string(6);
    VAR configuration_limits: cmt$configuration_limits;
    VAR product_found: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$configuration_limits
?? POP ??
*DECK DECK=CMP$RETURN_DESCRIPTOR_DATA EXPAND=FALSE
{ XREF DECK CMP$RETURN_DESCRIPTOR_DATA }

  PROCEDURE [XREF] cmp$return_descriptor_data (channel:
    cmt$physical_channel;
        iou_number : dst$iou_number;
        physical_equipment_number: cmt$physical_equipment_number;
        logical_unit_number: iot$logical_unit;
    VAR descriptor_data: ost$string;
    VAR pp_number: 0 .. 0ff(16));

?? PUSH (LISTEXT := ON) ??
*copyc dst$iou_number
*copyc cmt$physical_channel
*copyc cmt$channel_type
*copyc cmt$physical_equipment_number
*copyc iot$logical_unit
*copyc ost$string
?? POP ??
*DECK DECK=CMP$RETURN_DESC_DATA_BY_LUN_LPN EXPAND=FALSE

  PROCEDURE [XREF] cmp$return_desc_data_by_lun_lpn (
      logical_unit_number: iot$logical_unit;
      logical_pp_number: iot$pp_number;
    VAR iou_number : dst$iou_number;
    VAR descriptor_data: ost$string;
    VAR physical_pp_number: 0 .. 31);

?? PUSH (LISTEXT := ON) ??
*copyc dst$iou_number
*copyc iot$logical_unit
*copyc iot$pp_number
*copyc ost$string
?? POP ??

*DECK DECK=CMP$RETURN_LOGICAL_PP_NUMBER EXPAND=FALSE

  PROCEDURE [XREF] cmp$return_logical_pp_number
    (    channel: cmt$element_name;
         iou: cmt$element_name;
     VAR logical_pp: iot$pp_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc iot$pp_number
*copyc ost$status
?? POP ??
*DECK DECK=CMP$RETURN_LUN_INFO EXPAND=FALSE


  PROCEDURE [XREF] cmp$return_lun_info (logical_unit : iot$logical_unit;
      VAR assigned_to_job : boolean;
      VAR assigned_job_id : jmt$system_supplied_name);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc jmt$system_supplied_name
?? POP ??
*DECK DECK=CMP$SAVE_DEVICE_FILE EXPAND=FALSE

{ COMMON DECK CMXSDF }

  PROCEDURE [XREF] cmp$save_device_file (device_file_name: ost$name;
        segment_file_fid: amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc OST$NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$SAVE_MF_CONFIGURATION EXPAND=FALSE

  PROCEDURE [XREF] cmp$save_mf_configuration
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$SAVE_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] cmp$save_output (output_file :
        amt$local_file_name;
        input_file : boolean;
      VAR status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc ost$status
*copyc amt$local_file_name
?? POP ??
*DECK DECK=CMP$SEARCH_ACTIVE_VOLUME_TABLE EXPAND=FALSE

  PROCEDURE [XREF] cmp$search_active_volume_table (
         search_key : dmt$avt_search_key;
     VAR recorded_vsn : rmt$recorded_vsn;
     VAR avt_entry_not_found : boolean);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc dmt$avt_search_key
?? POP ??
*DECK DECK=CMP$SEARCH_EDITED_FILE EXPAND=FALSE

  PROCEDURE [XREF] cmp$search_edited_file (element_name : cmt$element_name;
          serial_number : integer;
          product_id : cmt$product_identification;
      VAR found : boolean;
      VAR descriptor : cmt$pcu_command_descriptor);

?? PUSH(LISTEXT := ON) ??
*copyc cmt$product_identification
*copyc cmt$element_name
*copyc cmt$pcu_command_descriptor
?? POP ??
*DECK DECK=CMP$SEARCH_PERIPHERAL_TABLE EXPAND=FALSE

      { Common deck cmp$search_peripheral_table }

   PROCEDURE [XREF] cmp$search_peripheral_table (
            element_descriptor : cmt$element_descriptor;
            element_reservation : cmt$element_reservation;
            not_in_configuration : BOOLEAN;
        VAR table_index : integer;
        VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_descriptor
*copyc cmt$element_reservation
*copyc ost$status
?? POP ??
*DECK DECK=CMP$SEARCH_PP_TABLE EXPAND=FALSE

  PROCEDURE [XREF] cmp$search_pp_table
    (    physical_pp_number: dst$iou_resource;
     VAR logical_pp_index: iot$pp_number;
     VAR found: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$iou_resource
*copyc iot$pp_number
*copyc ost$status
?? POP ??
*DECK DECK=CMP$SEARCH_REDUNDANT_PATH EXPAND=FALSE

  PROCEDURE [XREF] cmp$search_redundant_path
    (    primary_element: cmt$element_definition;
         iou: dst$iou_number;
         channel: cmt$physical_channel;
         new_state: cmt$element_state;
     VAR redundant_path_available: boolean;
     VAR update_controller_address: boolean;
     VAR number_of_path: integer;
     VAR redundant_channel_list: array [cmt$physical_equipment_number] of cmt$physical_address;
     VAR redundant_path_pp_list: array [cmt$physical_equipment_number] of iot$pp_number;
     VAR driver_name: pmt$program_name;
     VAR pp_table_rma_list: array [cmt$physical_equipment_number] of ost$real_memory_address);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_definition
*copyc cmt$element_state
*copyc cmt$physical_address
*copyc iot$pp_number
*copyc ost$hardware_subranges
*copyc pmt$program_name
?? POP ??
*DECK DECK=CMP$SELECT_PRIMARY_CONTROLLER EXPAND=FALSE

  PROCEDURE [XREF] cmp$select_primary_controller
    (    pp: iot$pp_number;
         logical_unit_number: iot$logical_unit;
     VAR controller_p: ^cmt$peripheral_element_entry;
     VAR channel_p: ^cmt$peripheral_element_entry;
     VAR redundant_path: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$peripheral_element_entry
*copyc iot$logical_unit
*copyc iot$pp_number
?? POP ??
*DECK DECK=CMP$SEND_PP_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] cmp$send_pp_command
    (    pp_index: iot$pp_number;
         pp_command: cmt$pp_commands;
     VAR successful: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pp_commands
*copyc iot$pp_number
*copyc ost$status
?? POP ??
*DECK DECK=CMP$SETUP_MAINFRAME_NAME EXPAND=FALSE

  PROCEDURE [XREF] cmp$setup_mainframe_name (
      mainframe: cmt$element_name);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
?? POP ??
*DECK DECK=CMP$SET_ACTIVE_FLAG EXPAND=FALSE

  PROCEDURE [XREF] cmp$set_active_flag
    (    configuration_state: boolean);
*DECK DECK=CMP$SET_DEFAULT_MAINFRAME_NAME EXPAND=FALSE
   PROCEDURE [XREF] cmp$set_default_mainframe_name (
            VAR status : ost$status);
?? PUSH(LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$SET_ELEMENT_LOCK EXPAND=FALSE




  PROCEDURE [XREF] cmp$set_element_lock (
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
  ?? POP ??
*DECK DECK=CMP$SET_ELEMENT_STATE EXPAND=FALSE

 PROCEDURE [XREF] cmp$set_element_state (element: cmt$element_name;
        state: cmt$element_state;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$element_state
*copyc ost$status
?? POP ??

*DECK DECK=CMP$SET_EXEC_IN_EDITOR EXPAND=FALSE

   PROCEDURE [XREF] cmp$set_exec_in_editor (active : boolean);
*DECK DECK=CMP$SET_ILLEGAL_CHANNEL_STATUS EXPAND=FALSE

{ COMMON DECK CMXSICS }

?? PUSH (LISTEXT := ON) ??
*copyc CLP$CONVERT_INTEGER_TO_STRING
*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc CMT$CHANNEL_ORDINAL
*copyc CMT$CHANNEL_TYPE
*copyc CMC$CONDITION_LIMITS
?? POP ??

  PROCEDURE [inline] cmp$set_illegal_channel_status (illegal_channel_number:
    integer;
        condition: ost$status_condition;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      str: ost$string,
      local_status: ost$status;

    clp$convert_integer_to_string (illegal_channel_number, 10, TRUE, str,
          local_status);
    osp$set_status_abnormal (cmc$configuration_management_id, condition, str.
          value (1, str.size), status);

    clp$convert_integer_to_string (ORD (LOWERVALUE (cmt$channel_ordinal)), 10,
          TRUE, str, local_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, str.value (1,
          str.size), status);

    clp$convert_integer_to_string (ORD (UPPERVALUE (cmt$channel_ordinal)), 10,
          TRUE, str, local_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, str.value (1,
          str.size), status);

  PROCEND cmp$set_illegal_channel_status;

?? POP ??
*DECK DECK=CMP$SET_IN_EDITOR EXPAND=FALSE

  PROCEDURE [XREF] cmp$set_in_editor (
         in_editor: boolean);
*DECK DECK=CMP$SET_IOCT_SERIAL_LOCK EXPAND=FALSE


PROCEDURE [XREF] cmp$set_ioct_serial_lock (
   VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
?? POP ??
*DECK DECK=CMP$SET_LCU_TASKID EXPAND=FALSE
*DECK DECK=CMP$SET_LCU_TASKID_R1 EXPAND=FALSE
*DECK DECK=CMP$SET_POST_DS_FLAG EXPAND=FALSE

  PROCEDURE [XREF] cmp$set_post_ds_flag;
*DECK DECK=CMP$SET_PRODUCT_ID_STATUS EXPAND=FALSE

{ COMMON DECK CMXSPIS }

?? PUSH (LISTEXT := ON) ??
*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc CMT$PRODUCT_IDENTIFICATION
*copyc cme$physical_configuration_mgr
?? POP ??

  PROCEDURE [inline] cmp$set_product_id_status (text: string ( * <= 64);
        product_id: cmt$product_identification;
        condition: ost$status_condition;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??

    VAR
      pid: string (10);

    pid := product_id.product_number;
    pid (7, 1) := product_id.underscore;
    pid (8, 3) := product_id.model_number;

    osp$set_status_abnormal (cmc$configuration_management_id, condition, pid,
          status);

    osp$append_status_parameter (osc$status_parameter_delimiter, text, status);

  PROCEND cmp$set_product_id_status;

?? POP ??
*DECK DECK=CMP$SET_SPAA_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] cmp$set_spaa_entry (controller_type :
         cmt$controller_type;
      VAR spaa : array [ * ] of ost$spaa_entry;
          adtt : array [ * ] of ^ost$active_driver_type_table;
      VAR address_type : 0 .. 0ffff(16);
      VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc CMT$CONTROLLER_TYPE
*copyc OST$SPAA_ENTRY
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$SET_STATUS_ABNORMAL EXPAND=TRUE
*DECK DECK=CMP$SET_UNIT_SHARED EXPAND=FALSE

    PROCEDURE [XREF] cmp$set_unit_shared (logical_unit: iot$logical_unit;
          set_lock: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
?? POP ??
*DECK DECK=CMP$SET_UNKNOWN_PRODUCT_ID EXPAND=FALSE

{ COMMON DECK CMXSUPI }

?? PUSH (LISTEXT := ON) ??
*copyc OSP$SET_STATUS_ABNORMAL
*copyc CMT$PRODUCT_IDENTIFICATION
*copyc cme$physical_configuration_mgr
?? POP ??

  PROCEDURE [inline] cmp$set_unknown_product_id (product_id:
    cmt$product_identification;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??

    VAR
      pid: string (9);

    pid := product_id.product_number;
    pid (6, 1) := product_id.underscore;
    pid (6, 3) := product_id.model_number;

    osp$set_status_abnormal (cmc$configuration_management_id,
          cme$unknown_product_id, pid, status);

  PROCEND cmp$set_unknown_product_id;

?? POP ??
*DECK DECK=CMP$SIGNAL_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] cmp$signal_handler (
        originator: ost$global_task_id;
        signal: pmt$signal);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc pmt$signal
?? POP ??
*DECK DECK=CMP$SSIOT_END_HANDLER EXPAND=FALSE

     PROCEDURE [XREF] cmp$ssiot_end_handler (termination_status: ost$status;
                     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=CMP$SSIOT_RECOVERY_COMPLETE EXPAND=FALSE


      PROCEDURE [XREF] cmp$ssiot_recovery_complete (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=CMP$SSIOT_RECOVERY_CONDITION EXPAND=FALSE


      PROCEDURE [XREF] cmp$ssiot_recovery_condition (
                  VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=CMP$SSIOT_TERMINATION EXPAND=FALSE


PROCEDURE [XREF] cmp$ssiot_termination (
          VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$SSIOT_TERMINATION_CLEANUP EXPAND=FALSE

PROCEDURE [XREF] cmp$ssiot_termination_cleanup (
          VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$STATE_CHANGE_PENDING EXPAND=FALSE

  FUNCTION [XREF, UNSAFE] cmp$state_change_pending
     (element_descriptor: cmt$element_descriptor): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_descriptor
?? POP ??
*DECK DECK=CMP$STORE_FILE_SERVER_INFO EXPAND=TRUE

  PROCEDURE [XREF] cmp$store_file_server_info
    (    pp_index: iot$pp_number;
         next_request_p: ^iot$io_request;
         one_word_response_allowed: boolean;
         one_response_processor: dft$one_word_response_handler;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$one_word_response_handler
*copyc iot$io_request
*copyc iot$pp_number
*copyc ost$status
?? POP ??
*DECK DECK=CMP$STORE_ONE_WORD_RESPONSE_PTR EXPAND=FALSE

  PROCEDURE [XREF] cmp$store_one_word_response_ptr
    (    pp_index: iot$pp_number;
         one_word_response_processor: dft$one_word_response_handler;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$one_word_response_handler
*copyc iot$pp_number
*copyc ost$status
?? POP ??

*DECK DECK=CMP$STORE_SSIOT_ENTRY_INFO EXPAND=FALSE

 PROCEDURE [XREF] cmp$store_ssiot_entry_info (io_completion_queue_index:
  cmt$io_completion_queue_index;
        entry_information_p: ^cmt$ssiot_entry_information;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$io_completion_queue_index
*copyc iot$io_completion_table
?? POP ??
*DECK DECK=CMP$SUBSYSTEM_IO_JOB_EXIT EXPAND=FALSE

          PROCEDURE [XREF] cmp$subsystem_io_job_exit (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$SUPPORT_REDUNDANT_ACCESS EXPAND=TRUE
  FUNCTION cmp$support_redundant_access
    (    element_type: cmt$element_type;
         product_id: cmt$product_identification): boolean;

?? PUSH (LISTEXT := ON) ??

    CASE element_type OF
    = cmc$controller_element =
      cmp$support_redundant_access :=
            (product_id.product_number = ' $5680') OR (product_id.product_number = ' $5698') OR
            (product_id.product_number = ' $7154') OR (product_id.product_number = ' $7155') OR
            (product_id.product_number = '$FA7B4') OR (product_id.product_number = '$FA7B5') OR
            (product_id.product_number = ' $5831');
    = cmc$storage_device_element =
      cmp$support_redundant_access :=
            (product_id.product_number = ' $9853') OR (product_id.product_number = ' $9836') OR
            (product_id.product_number = ' $5832') OR (product_id.product_number = ' $5833') OR
            (product_id.product_number = ' $5838') OR (product_id.product_number = ' $47444');
    ELSE
      cmp$support_redundant_access := FALSE;
    CASEND;

  FUNCEND cmp$support_redundant_access;

*copyc cmt$element_type
*copyc cmt$product_identification
?? POP ??

*DECK DECK=CMP$SUPPORT_REDUNDANT_CHANNEL EXPAND=TRUE

  FUNCTION [INLINE] cmp$support_redundant_channel
    (    controller_type: cmt$controller_type): boolean;

?? PUSH (LISTEXT := ON) ??

    cmp$support_redundant_channel :=
          (controller_type = cmc$ms7155_1) OR (controller_type = cmc$mt5698_xx) OR
          (controller_type = cmc$ms7155_1x) OR (controller_type = cmc$mscm3_ct) OR
          (controller_type = cmc$ms7154_x) OR (controller_type = cmc$ms7255_1_1) OR
          (controller_type = cmc$ms5831_x) OR (controller_type = cmc$ms7255_1_2) OR
          (controller_type = cmc$mt5680_xx);

  FUNCEND cmp$support_redundant_channel;

*copyc cmt$controller_type
?? POP ??

*DECK DECK=CMP$SWITCH_TAPE_CHANNEL EXPAND=FALSE

  PROCEDURE [XREF] cmp$switch_tape_channel
    (    primary_channel: cmt$element_definition;
         ignore_controller_state: boolean;
         number_of_redundant_path: integer;
         redundant_channel_list: array [cmt$physical_equipment_number] of cmt$physical_address;
         new_state: cmt$element_state;
         redundant_pp_list: array [cmt$physical_equipment_number] of iot$pp_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_definition
*copyc cmt$element_state
*copyc cmt$physical_address
*copyc iot$pp_number
*copyc ost$status
?? POP ??
*DECK DECK=CMP$SWITCH_TO_REDUNDANT_PATH EXPAND=FALSE

  PROCEDURE [XREF] cmp$switch_to_redundant_path
    (    pp: iot$pp_number;
         primary_path: cmt$physical_address;
     VAR successful: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$physical_address
*copyc iot$pp_number
?? POP ??
*DECK DECK=CMP$SYSTEM_CRITICAL EXPAND=FALSE

  PROCEDURE [XREF] cmp$system_critical (
        element : cmt$element_definition;
    VAR system_critical : BOOLEAN;
    VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_definition
*copyc ost$status
?? POP ??
*DECK DECK=CMP$SYSTEM_DEADSTART_PROLOG EXPAND=TRUE
PROCEDURE (HIDDEN) cmp$system_deadstart_prolog

  TASK ring=11

"$FORMAT=OFF
TYPE
  deadstart_tasks: list 0..$max_list of name
TYPEND

VAR
  continuation_tasks: deadstart_tasks = ..
        (install_configuration activate_volumes change_logical_configuration)
  deadstart_phase: key installation, reinstallation, continuation ..
     keyend
  force_intervention: boolean
  ignore_status: status
  intervention_occurred: boolean
  installation_tasks: deadstart_tasks = ..
   (install_configuration activate_volumes install_network_commands)
  intervention_step : name
  menu_items: deadstart_tasks
  menu_selection: string
  menu_options: deadstart_tasks = ..
      (install_configuration activate_volumes change_logical_configuration)
  cmv$force_intervention: (xref) boolean
  osv$configuration_prolog_name: (xref) string 0 .. $max_name
  osv$deadstart_phase: (xref) string 0 .. $max_name
  osv$operator_intervention: (xref) boolean
  osv$reinitialize_system_device: (xref) boolean
  prolog_name: name
  reinstallation_tasks: deadstart_tasks = ..
     (install_configuration activate_volumes change_logical_configuration)
  status: status
  tasks: deadstart_tasks
  usecp_selection: string 31
VAREND
"$FORMAT=ON

    IF NOT $variable(cmv$deadstart_simulation, defined) THEN
      WHEN any_fault interrupt DO
        rap$display_message message_module=sysdp_messages ..
              message_name=report_when_fault ..
              message_parameters= osv$command_name to=$output
        display_value osv$status o=$output
        CONTINUE
      WHENEND
    IFEND

    PUSH file_connections
    create_file_connection $errors $job_log status=ignore_status
    create_file_connection $output $job_log status=ignore_status
    create_file_connection $response $job_log status=ignore_status

    PUSH command_list
    create_command_list_entry $local.prolog_library status=ignore_status
    create_command_list_entry $local.osf$ds_library status=ignore_status

    IF osv$deadstart_phase = 'INSTALL' THEN
      IF osv$reinitialize_system_device THEN
        deadstart_phase = reinstallation
        tasks = continuation_tasks
      ELSE
        deadstart_phase = installation
        tasks = installation_tasks
      IFEND
    ELSE
      deadstart_phase = continuation
      tasks = continuation_tasks
    IFEND

    IF deadstart_phase <> continuation THEN
      IF osv$configuration_prolog_name = '' THEN
        prolog_name = $name($mainframe(identifier))
        usecp_selection = 'NONE'
      ELSE
        prolog_name = $name(osv$configuration_prolog_name)
        usecp_selection = osv$configuration_prolog_name
      IFEND

      IF $file($local.prolog_library, opened) THEN
        display_command_information $local.prolog_library//prolog_name ..
              output=$null status=status
        IF (NOT status.normal) AND (osv$configuration_prolog_name <> '') THEN
          rap$display_message message_module=sysdp_messages ..
                message_name=prolog_procedure_missing ..
                message_parameters= osv$configuration_prolog_name to=$output
          prolog_name = none
        ELSEIF (NOT status.normal) THEN
          prolog_name = none
        IFEND
      ELSEIF osv$configuration_prolog_name <> '' THEN
        rap$display_message message_module=sysdp_messages ..
              message_name=prolog_library_missing ..
              message_parameters= osv$configuration_prolog_name to=$output
        prolog_name = none
      ELSE
        prolog_name = none
      IFEND
    ELSE
      prolog_name = none
      usecp_selection = 'NONE'
    IFEND

    IF osv$operator_intervention THEN
      rap$display_message message_module=sysdp_messages ..
            message_name=intervention_requested to=$output
      menu_items = $intersection(menu_options tasks) "
      cmp$ask_for_intervention deadstart_phase=deadstart_phase ..
            menu_items=menu_items prolog_procedure_name=prolog_name ..
            usecp_selection=usecp_selection ..
            intervention_step=intervention_step status=status
      IF NOT status.normal THEN
        rap$display_message message_module=sysdp_messages ..
              message_name=report_menu_fault to=$output
        display_value status
        intervention_step = none
      IFEND
    ELSE
      intervention_step = none
    IFEND

    REPEAT
      intervention_occurred = false
      force_intervention = (intervention_step = $first(tasks))

      IF $first(tasks) = install_configuration THEN
        cmp$install_configuration deadstart_phase= deadstart_phase ..
              operator_intervention_required= force_intervention ..
              prolog_procedure_name= prolog_name ..
              operator_intervention_occurred= intervention_occurred ..
              status=status
      IFEND

      force_intervention = force_intervention OR cmv$force_intervention
      IF $first(tasks) = activate_volumes THEN
        cmp$activate_configuration deadstart_phase= deadstart_phase ..
              operator_intervention_required=force_intervention ..
              prolog_procedure_name=prolog_name ..
              operator_intervention_occurred= intervention_occurred ..
              status=status
      IFEND

      IF $first(tasks) = change_logical_configuration THEN
        IF force_intervention THEN
          cmp$perform_lcu_intervention deadstart_phase=deadstart_phase ..
                status=status
        IFEND
      IFEND

      IF $first(tasks) = install_network_commands THEN
        cmp$install_network_commands prolog_procedure_name=prolog_name ..
              status=status
        IF NOT status.normal THEN
          rap$display_message message_module=sysdp_messages ..
                message_name=report_error
          display_value status o=$output
          status = $status(true)
        IFEND
      IFEND

      IF status.normal THEN
        tasks = $rest(tasks)
        IF force_intervention OR intervention_occurred THEN
          menu_items = $intersection(menu_options tasks)
          IF NOT $nil(menu_items) THEN
            IF force_intervention THEN
              message_name = intervention_requested
            ELSE
              message_name = intervention_due_to_error
            IFEND
            rap$display_message message_module=sysdp_messages ..
                  message_name=message_name to=$output
            cmp$ask_for_intervention deadstart_phase=deadstart_phase ..
                  menu_items=menu_items prolog_procedure_name=prolog_name ..
                  usecp_selection=usecp_selection ..
                  intervention_step=intervention_step status=status
            IF NOT status.normal THEN
              rap$display_message message_module=sysdp_messages ..
                    message_name=report_menu_fault to=$output
              display_value status
              intervention_step = none
            IFEND
          IFEND
        IFEND
      ELSE
        rap$display_message message_module=sysdp_messages ..
              message_name=report_error to=$output
        display_value status
        intervention_step = $first(tasks)
      IFEND

    UNTIL $nil(tasks)


    delete_file $local.cmf$default_configuration status=ignore_status
    delete_file $local.lcu_mainframe_subcommands status=ignore_status
    delete_file $local.lcu_network_subcommands status=ignore_status
    delete_file $local.pcu_subcommands status=ignore_status
    delete_file $local.physical_config status=ignore_status
    delete_file $local.physical_configuration status=ignore_status
  TASKEND

PROCEND cmp$system_deadstart_prolog
*DECK DECK=CMP$TASK_TERMINATION_CLEANUP EXPAND=FALSE

  PROCEDURE [XREF] cmp$task_termination_cleanup;
*DECK DECK=CMP$TEST_AND_CLEAR_IOCT_LOCK EXPAND=FALSE

PROCEDURE [XREF] cmp$test_and_clear_ioct_lock (
             VAR status: ost$status);

*copyc ost$status
*DECK DECK=CMP$UNIT_DISABLED EXPAND=FALSE

   FUNCTION [XREF] cmp$unit_disabled (logical_unit :
        iot$logical_unit) : boolean;

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
?? POP ??
*DECK DECK=CMP$UNLOCK_LUN_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] cmp$unlock_lun_entry ALIAS 'cmxulun' (logical_unit:
    iot$logical_unit;
    VAR lun_lock_released: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
*copyc CMV$LOGICAL_UNIT_LOCK
  ?? POP ??
*DECK DECK=CMP$UNLOCK_THE_RMA_LIST EXPAND=FALSE




PROCEDURE [XREF] cmp$unlock_the_rma_list (
   queue_index: cmt$io_completion_queue_index;
   VAR status: ost$status);


?? PUSH (LISTEXT :=ON) ??
*copyc iot$io_completion_table
*copyc ost$status
?? POP ??
*DECK DECK=CMP$UNLOCK_WIRED_RMA_LIST EXPAND=FALSE


  PROCEDURE [XREF] cmp$unlock_wired_rma_list (
   VAR request_block: iot$monitor_request_block);

?? PUSH (LISTEXT := ON) ??
*copyc syt$monitor_status
*copyc iot$wired_unit_queue_request
*copyc mmt$io_type
*copyc iot$monitor_request_block
*copyc i#real_memory_address
?? POP ??
*DECK DECK=CMP$UNMARK_ELEMENT_RESERVED EXPAND=FALSE

  PROCEDURE [XREF] cmp$unmark_element_reserved
    (    element_reservation: cmt$element_reservation;
         job_name: jmt$system_supplied_name;
         system_caller: boolean;
         table_index: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_reservation
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$UNMARK_PP_ELEMENT_RESERVED EXPAND=FALSE

  PROCEDURE [XREF] cmp$unmark_pp_element_reserved
    (    job_name: jmt$system_supplied_name;
         system_caller: boolean;
         table_index: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$UNMARK_PP_WHEN_CLEANUP EXPAND=FALSE

  PROCEDURE [XREF] cmp$unmark_pp_when_cleanup
    (    table_index: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$UNMARK_WHEN_CLEANUP EXPAND=FALSE

  PROCEDURE [XREF] cmp$unmark_when_cleanup
    (    table_index: integer;
         mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$mainframe_id
*copyc ost$status
?? POP ??
*DECK DECK=CMP$UPDATE_CONNECTION_STATES EXPAND=FALSE
*DECK DECK=CMP$UPDATE_CONNECTION_STATES_R1 EXPAND=FALSE

  PROCEDURE [XREF] cmp$update_connection_states_r1
    (    mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=CMP$UPDATE_DESCRIPTOR EXPAND=FALSE

    PROCEDURE [XREF] cmp$update_descriptor;
*DECK DECK=CMP$UPDATE_DFT_SCI_LOCATION EXPAND=FALSE

  PROCEDURE [XREF] cmp$update_dft_sci_location
    (    dft_sci_location: cmt$sci_dft_pp);

?? PUSH(LISTEXT := ON) ??
*copyc cmt$sci_dft_pp
?? POP ??
*DECK DECK=CMP$UPDATE_ERROR_COUNT EXPAND=FALSE



PROCEDURE [XREF] cmp$update_error_count (
   VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
?? POP ??
*DECK DECK=CMP$UPDATE_INSTALLED_DFT EXPAND=TRUE

{ COMMON DECK CMXUIDF }

  PROCEDURE [XREF] cmp$update_installed_dft (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=CMP$UPDATE_LOGICAL_UNIT_TABLE EXPAND=FALSE

  PROCEDURE [XREF] cmp$update_logical_unit_table (logical_unit :
                iot$logical_unit;
           state : cmt$element_state;
       VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc cmt$element_state
*copyc ost$status
?? POP ??
*DECK DECK=CMP$UPDATE_MRT EXPAND=FALSE
*DECK DECK=CMP$UPDATE_OUTPUT_FILE EXPAND=FALSE

  PROCEDURE [XREF] cmp$update_output_file (VAR status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=CMP$UPDATE_PC EXPAND=FALSE

  PROCEDURE [XREF] cmp$update_pc (output_fid : amt$file_identifier;
         VAR status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=CMP$UPDATE_PCU_STATE_INFO EXPAND=FALSE

  PROCEDURE [XREF] cmp$update_pcu_state_info
    (    element_name: cmt$element_name;
         state: cmt$element_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$element_state
*copyc ost$status
?? POP ??
*DECK DECK=CMP$UPDATE_PP_TABLE EXPAND=FALSE
*DECK DECK=CMP$UPDATE_UNIT_DESCRIPTORS EXPAND=FALSE
*DECK DECK=CMP$VALIDATE_CIP_PATH EXPAND=FALSE

  PROCEDURE [XREF] cmp$validate_cip_path
    (    logical_unit: iot$logical_unit;
     VAR continue_initialization: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
?? POP ??
*DECK DECK=CMP$VALIDATE_MAINFRAME_NAME EXPAND=FALSE

  PROCEDURE [XREF] cmp$validate_mainframe_name
    (    mainframe_name: cmt$element_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$VALIDATE_MS_CLASS EXPAND=FALSE

  PROCEDURE [XREF] cmp$validate_ms_class
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$VALIDATE_NETWORK_CONFIG EXPAND=FALSE

  PROCEDURE [XREF] cmp$validate_network_config
    (    network_descriptor_list: ^nat$network_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_descriptor
*copyc ost$status
?? POP ??

*DECK DECK=CMP$VALIDATE_SET_MEMBERSHIP EXPAND=FALSE

  PROCEDURE [XREF] cmp$validate_set_membership
    (    recorded_vsn: rmt$recorded_vsn;
         new_set_name: stt$set_name;
     VAR allow_to_continue: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$recorded_vsn
*copyc std$set_name
?? POP ??
*DECK DECK=CMP$VALIDATE_UNUSED_CHANNEL EXPAND=FALSE

  PROCEDURE [XREF] cmp$validate_unused_channel (channel : cmt$element_name;
         iou_name : cmt$element_name;
     VAR maintenance_allowed : boolean;
     VAR status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$VALID_CHANNEL_NAME EXPAND=FALSE

  FUNCTION [XREF] cmp$valid_channel_name (channel_name : cmt$element_name) : BOOLEAN;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
?? POP ??
*DECK DECK=CMP$VCMB_MENU_MANAGER EXPAND=FALSE

  PROCEDURE [XREF] cmp$vcmb_menu_manager;
*DECK DECK=CMP$VED_DISPLAY_CONFIGURATION EXPAND=FALSE

  PROCEDURE [XREF] cmp$ved_display_configuration
    (    window_id: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$VED_DISPLAY_PP EXPAND=FALSE

  PROCEDURE [XREF] cmp$ved_display_pp
    (    window_id: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=CMP$VERIFY_ACTIVE_PATH EXPAND=FALSE


  PROCEDURE [XREF] cmp$verify_active_path (element : cmt$element_definition;
     VAR active_path : boolean);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_definition
?? POP ??
*DECK DECK=CMP$VERIFY_ACTIVE_PATH_EXISTS EXPAND=FALSE
  PROCEDURE [XREF] cmp$verify_active_path_exists
    (    physical_address: cmt$physical_address;
     VAR active_path_exists: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$physical_address
?? POP ??

*DECK DECK=CMP$VERIFY_PHYS_CONFIGURATION EXPAND=FALSE

   PROCEDURE [XREF] cmp$verify_phys_configuration (
            parameter_list : clt$parameter_list;
       VAR  status : ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=CMP$VOLUME_ONLINE EXPAND=FALSE

{ COMMON DECK CMXVONL }

  PROCEDURE [XREF] cmp$volume_online (logical_unit_number: iot$logical_unit;
        p_physical_attributes: ^dmt$physical_device_attributes;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
*copyc dmt$physical_device_attributes
*copyc OST$STATUS
  ?? POP ??
*DECK DECK=CMP$VSN_TOO_LARGE EXPAND=FALSE

{ COMMON DECK CMXVTL }

?? PUSH (LISTEXT := ON) ??
*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc CMC$CONDITION_LIMITS
*copyc CLP$CONVERT_INTEGER_TO_STRING
?? POP ??

  PROCEDURE [inline] cmp$vsn_too_large (vsn: string ( * <= 31);
        vsn_size: integer;
        condition: ost$status_condition;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      str: ost$string,
      local_status: ost$status;

    osp$set_status_abnormal (cmc$configuration_management_id, condition, vsn,
          status);

    clp$convert_integer_to_string (vsn_size, 10, FALSE, str, local_status);

    osp$append_status_parameter (osc$status_parameter_delimiter, str.value (1,
          str.size), status);

  PROCEND cmp$vsn_too_large;

?? POP ??
*DECK DECK=CMP$WRITE_OS_STATUS EXPAND=TRUE

  PROCEDURE [XREF] cmp$write_os_status
    (    text: string ( * );
         status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CMP$ZERO_OUT_UIT_RMA EXPAND=FALSE

  PROCEDURE [XREF] cmp$zero_out_uit_rma (
        logical_unit_number: iot$logical_unit;
        channel: cmt$element_definition;
        new_state: cmt$element_state;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_definition
*copyc cmt$element_state
*copyc ost$status
?? POP ??
*DECK DECK=CMT$ACCESS_ELEMENTS EXPAND=FALSE

  TYPE
    cmt$access_elements = RECORD
      accessed_elements_p: ^ARRAY [ * ] OF cmt$peripherals,
    RECEND,

    cmt$peripherals = RECORD
      active: boolean,
      lun: iot$logical_unit,
    RECEND;

*copyc iot$logical_unit
*DECK DECK=CMT$CENTRAL_MEMORY_DEFINITION EXPAND=FALSE
 TYPE
    cmt$central_memory_definition = record
      mainframe_ownership: cmt$element_name,
      connection: cmt$cm_connectivity,
    recend;

*copyc cmt$cm_connectivity
*copyc cmt$element_name
*DECK DECK=CMT$CENTRAL_MEMORY_PORT_NUMBER EXPAND=FALSE
type
    cmt$central_memory_port_number = (cmc$memory_port_0,
      cmc$memory_port_1, cmc$memory_port_2, cmc$memory_port_3);
*DECK DECK=CMT$CHANNEL_ADAPTER_CONNECTION EXPAND=FALSE
 TYPE
    cmt$channel_adapter_connection = record
      channel: cmt$upline_connection,
      equipment: array [cmt$physical_equipment_number] of
        cmt$element_connection,
    recend;

*copyc cmt$element_connection
*copyc cmt$physical_equipment_number
*copyc cmt$upline_connection
*DECK DECK=CMT$CHANNEL_ADAPTER_DEFINITION EXPAND=FALSE
 TYPE
    cmt$channel_adapter_definition = record
      microcode_identification: cmt$equipment_identification,
      peripheral_driver_name: pmt$program_name,
      physical_equipment_number : cmt$physical_equipment_number,
      response_handler_name: pmt$program_name,
      connection: cmt$channel_adapter_connection,
    recend;

?? PUSH(LISTEXT := ON) ??
*copyc cmt$channel_adapter_connection
*copyc cmt$equipment_identification
*copyc pmt$program_name
*copyc cmt$physical_equipment_number
?? POP ??
*DECK DECK=CMT$CHANNEL_DESCRIPTOR EXPAND=FALSE
 TYPE
    cmt$channel_descriptor = record
      iou: cmt$element_name,
      case use_logical_identification: boolean of
      = TRUE =
        name: cmt$element_name,
      = FALSE =
        channel_ordinal: cmt$channel_ordinal,
        concurrent : boolean, { True implies capable of asynchronous transfer. }
        number : ost$physical_channel_number,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$channel_ordinal
*copyc ost$physical_channel_number
?? POP ??
*DECK DECK=CMT$CHANNEL_IDENTIFICATION EXPAND=FALSE

  TYPE
    cmt$channel_identification = RECORD
      ordinal : cmt$channel_ordinal,
      iou: cmt$element_name,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$channel_ordinal
*copyc cmt$element_name
?? POP ??
*DECK DECK=CMT$CHANNEL_ORDINAL EXPAND=FALSE
  TYPE
    cmt$channel_ordinal = (cmc$channel0, cmc$channel1, cmc$channel2,
          cmc$channel3, cmc$channel4, cmc$channel5, cmc$channel6, cmc$channel7,
          cmc$channel8, cmc$channel9, cmc$channel10, cmc$channel11,
          cmc$real_time_clock_channel12, cmc$special_services_channel13,
          cmc$unconfigured_channel14, cmc$maintenance_channel15, cmc$channel16,
          cmc$channel17, cmc$channel18, cmc$channel19, cmc$channel20,
          cmc$channel21, cmc$channel22, cmc$channel23, cmc$channel24,
          cmc$channel25, cmc$channel26, cmc$channel27,

{ Ordinal value 28 .. 67

    cmc$cio_channel0_porta, cmc$cio_channel0_portb, cmc$cio_channel1_porta,
          cmc$cio_channel1_portb, cmc$cio_channel2_porta,
          cmc$cio_channel2_portb, cmc$cio_channel3_porta,
          cmc$cio_channel3_portb, cmc$cio_channel4_porta,
          cmc$cio_channel4_portb, cmc$cio_channel5_porta,
          cmc$cio_channel5_portb, cmc$cio_channel6_porta,
          cmc$cio_channel6_portb, cmc$cio_channel7_porta,
          cmc$cio_channel7_portb, cmc$cio_channel8_porta,
          cmc$cio_channel8_portb, cmc$cio_channel9_porta,
          cmc$cio_channel9_portb, cmc$cio_channel16_porta,
          cmc$cio_channel16_portb, cmc$cio_channel17_porta,
          cmc$cio_channel17_portb, cmc$cio_channel18_porta,
          cmc$cio_channel18_portb, cmc$cio_channel19_porta,
          cmc$cio_channel19_portb, cmc$cio_channel20_porta,
          cmc$cio_channel20_portb, cmc$cio_channel21_porta,
          cmc$cio_channel21_portb, cmc$cio_channel22_porta,
          cmc$cio_channel22_portb, cmc$cio_channel23_porta,
          cmc$cio_channel23_portb, cmc$cio_channel24_porta,
          cmc$cio_channel24_portb, cmc$cio_channel25_porta,
          cmc$cio_channel25_portb,

{ Ordinal value 68 ..95

    cmc$cio_channel0, cmc$cio_channel1, cmc$cio_channel2, cmc$cio_channel3,
          cmc$cio_channel4, cmc$cio_channel5, cmc$cio_channel6,
          cmc$cio_channel7, cmc$cio_channel8, cmc$cio_channel9,
          cmc$inter_pp_comm_cio_channel10, cmc$inter_pp_comm_cio_channel11,
          cmc$rtc_cio_channel12, cmc$special_serv_cio_channel13,
          cmc$unconfigured_cio_channel14, cmc$maintenance_cio_channel15,
          cmc$cio_channel16, cmc$cio_channel17, cmc$cio_channel18,
          cmc$cio_channel_19, cmc$cio_channel20, cmc$cio_channel21,
          cmc$cio_channel22, cmc$cio_channel23, cmc$cio_channel24,
          cmc$cio_channel25, cmc$cio_channel26, cmc$cio_channel27);

*DECK DECK=CMT$CHANNEL_PORT EXPAND=FALSE

  TYPE
    cmt$channel_port = (cmc$unspecified_port, cmc$port_a, cmc$port_b);

*DECK DECK=CMT$CHANNEL_TYPE EXPAND=FALSE

  CONST
    cmc$170_channel = 0,
    cmc$ici_channel = 1,
    cmc$isi_channel = 2,
    cmc$ipi_channel = 3,
    cmc$max_channel_type = 255,
    cmc$max_channel_per_iou = 28;

  TYPE
    cmt$channel_kind = (cmc$nio_channel, cmc$cio_channel_2_port,
          cmc$cio_channel_no_port),
    cmt$channel_type = 0 .. cmc$max_channel_type;

*DECK DECK=CMT$CM_CONNECTIVITY EXPAND=FALSE
 TYPE
    cmt$cm_connectivity = record
      port: array [cmt$central_memory_port_number] of cmt$element_connection,
    recend;

*copyc cmt$central_memory_port_number
*copyc cmt$element_connection
*DECK DECK=CMT$COMMUNICATIONS_CONNECTIVITY EXPAND=FALSE
  TYPE
    cmt$communications_connectivity = record
      port: array [cmt$communications_port_number] of cmt$upline_connection,
    recend;

*copyc cmt$communications_port_number
*copyc cmt$upline_connection
*DECK DECK=CMT$COMMUNICATIONS_DEFINITION EXPAND=FALSE
  TYPE
    cmt$communications_definition = record
      microcode_identification: cmt$equipment_identification,
      peripheral_driver_name: pmt$program_name,
      physical_equipment_number: cmt$physical_equipment_number,
      protocol: cmt$controller_protocol,
      connection: cmt$communications_connectivity,
    recend;

*copyc cmt$communications_connectivity
*copyc cmt$controller_protocol
*copyc cmt$equipment_identification
*copyc cmt$physical_equipment_number
*copyc pmt$program_name
*DECK DECK=CMT$COMMUNICATIONS_PORT_NUMBER EXPAND=FALSE
  TYPE
    cmt$communications_port_number = 0 .. cmc$max_communications_port;

*copyc cmc$max_communications_port
*DECK DECK=CMT$CONFIGURATION_LIMITS EXPAND=FALSE

  TYPE
    cmt$configuration_limits = record
      product_number: string (6),
      allowed_controllers: SET of cmt$controller_type,
      allowed_channels: SET of cmt$channel_kind,
      allowed_ious: SET of dst$iou_model_types,
      minimum_equipment_number: cmt$physical_equipment_number,
      maximum_equipment_number: cmt$physical_equipment_number,
      minimum_unit_number: cmt$physical_unit_number,
      maximum_unit_number: cmt$physical_unit_number,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$channel_type
*copyc cmt$controller_type
*copyc cmt$physical_equipment_number
*copyc cmt$physical_unit_number
*copyc dst$iou_model_types
?? POP ??
*DECK DECK=CMT$CONFIGURATION_STATE EXPAND=FALSE

{ COMMON DECK CMDCFOP }

  TYPE
    cmt$configuration_state = (cmc$co_s_active, cmc$co_s_installed),
    cmt$configuration_type = (cmc$co_t_physical, cmc$co_t_logical);
*DECK DECK=CMT$CONNECTION EXPAND=FALSE

  TYPE
    cmt$connection_status = (cmc$active, cmc$inactive, cmc$disabled);

{ DISABLED is not used in NOS/VE 1.4.1

  TYPE
    cmt$connection = record
      upline_element: cmt$element_name,
      downline_element: cmt$element_name,
      status: cmt$connection_status,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
?? POP ??
*DECK DECK=CMT$CONTROLLER_CONNECTIVITY EXPAND=FALSE
 TYPE
    cmt$controller_connectivity = record
      port: array [cmt$controller_port_number] of cmt$upline_connection,
      unit: array [cmt$physical_unit_number] of cmt$element_connection,
      pem: cmt$element_connection,
    recend;

*copyc cmt$controller_port_number
*copyc cmt$element_connection
*copyc cmt$physical_unit_number
*copyc cmt$upline_connection
*DECK DECK=CMT$CONTROLLER_DEFINITION EXPAND=FALSE
 TYPE
    cmt$controller_definition = record
      microcode_identification: cmt$equipment_identification,
      peripheral_driver_name: pmt$program_name,
      response_handler_name: pmt$program_name,
      physical_equipment_number: cmt$physical_equipment_number,
      protocol: cmt$controller_protocol,
      connection: cmt$controller_connectivity,
    recend;

*copyc cmt$controller_connectivity
*copyc cmt$controller_protocol
*copyc cmt$equipment_identification
*copyc cmt$physical_equipment_number
*copyc cmt$physical_unit_number
*copyc pmt$program_name
*DECK DECK=CMT$CONTROLLER_ID EXPAND=FALSE


  TYPE
    cmt$controller_id = record
      product_id: cmt$product_identification,
      controller_type: cmt$controller_type,
      driver_type: 0 .. 1f(16),
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc CMT$PRODUCT_IDENTIFICATION
*copyc CMT$CONTROLLER_TYPE
?? POP ??
*DECK DECK=CMT$CONTROLLER_LOCATION EXPAND=FALSE

  { This type declaration contains information about
  { whether the controlware or the control module has
  { been written into memory and its location in memory.

  TYPE
    cmt$controller_location = ARRAY [cmt$controller_type] OF cmt$controller_location_type,

    cmt$controller_location_type = RECORD
      controlware_loaded: boolean,
      controlware_location_p: ^SEQ ( * ),
      controlware_rma_list_p: ^cmt$controller_rma_list,
      controlware_rma_list_size : integer,
      control_module_loaded: boolean,
      control_module_location_p: ^SEQ ( * ),
      control_module_rma_list_p: ^cmt$controller_rma_list,
      control_module_rma_list_size : integer,
    RECEND,

    cmt$controller_rma_list = ARRAY [ * ] OF mmt$rma_list_entry;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$controller_type
*copyc mmt$rma_list
?? POP ??
*DECK DECK=CMT$CONTROLLER_PORT_NUMBER EXPAND=FALSE

  CONST
    cmc$max_ports_per_controller = 4;

  TYPE
    cmt$controller_port_number = 0 .. cmc$max_ports_per_controller - 1;

*DECK DECK=CMT$CONTROLLER_PROTOCOL EXPAND=FALSE
 TYPE
    cmt$controller_protocol = record
      control: cmt$control_protocol,
      data: cmt$data_protocol,
    recend;

*copyc cmt$control_protocol
*copyc cmt$data_protocol
*DECK DECK=CMT$CONTROLLER_TYPE EXPAND=FALSE

  TYPE
    cmt$controller_type = (cmc$ms7154_x, cmc$ms7155_1, cmc$ms7155_1x,
          cmc$ms7165_2x, cmc$mscm3_ct, cmc$mshydra_ct, cmc$ms5831_x,
          cmc$mt7021_3x, cmc$mt7021_4x, cmc$ms7255_1_1, cmc$ms7255_1_2,
          cmc$mt7221_2_s0, cmc$mt5680_xx, cmc$mt7221_1, cmc$mt698_xx,
          cmc$mt5698_xx, cmc$mp65354_11, cmc$ca2629_2, cmc$lcn380_170,
          cmc$mti2620_21x, cmc$mdi2621_21x, cmc$fs740_200, cmc$expresslink,
          cmc$null_controller);
*DECK DECK=CMT$CONTROL_PROTOCOL EXPAND=FALSE
 TYPE
    cmt$control_protocol = record
        kind: cmt$control_protocol_kind,
        function_size: cmt$function_size,
      recend;

*copyc cmt$control_protocol_kind
*copyc cmt$function_size
*DECK DECK=CMT$CONTROL_PROTOCOL_KIND EXPAND=FALSE
 TYPE
    cmt$control_protocol_kind = (cmc$cyber_170_protocol, fips_60_protocol,
      isi_protocol, ipi_protocol);
*DECK DECK=CMT$CPU_ELEMENT_DEFINITION EXPAND=FALSE

{ TYPE declaration: CMT$CPU_ELEMENT_DEFINITION

  TYPE
    cmt$cpu_element_definition = RECORD
      element_number: ost$processor_element_number,
      model_number: ost$processor_model_number,
      serial_number: ost$processor_serial_number,
      processor_state: cmt$element_state,
      reason_for_current_state: ost$cpu_down_state_reason,
    RECEND;

*copyc cmt$element_state
*copyc ost$cpu_down_state_reason
*copyc ost$processor_element_number
*copyc ost$processor_model_number
*copyc ost$processor_serial_number
*DECK DECK=CMT$CP_CONNECTIVITY EXPAND=FALSE
 TYPE
    cmt$cp_connectivity = record
      mainframe: cmt$element_connection,
      central_memory: cmt$element_connection,
      pem: cmt$element_connection,
    recend;

*copyc cmt$element_connection
*DECK DECK=CMT$CP_DEFINITION EXPAND=FALSE
 TYPE
    cmt$cp_definition = record
      mainframe_ownership: cmt$element_name,
      connection: cmt$cp_connectivity,
    recend;

*copyc cmt$cp_connectivity
*copyc cmt$element_name
*DECK DECK=CMT$DATA_CHANNEL_CONNECTIVITY EXPAND=FALSE
  TYPE
    cmt$data_channel_connectivity = record

{ Define the elements immediately connected to the channels.

      equipment: array [cmt$physical_equipment_number] of
            cmt$element_connection,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$physical_equipment_number
*copyc cmt$element_connection
?? POP ??
*DECK DECK=CMT$DATA_CHANNEL_DEFINITION EXPAND=FALSE
 TYPE
    cmt$data_channel_definition = record
      concurrent : boolean, { True implies capable of asynchronous transfer. }
      connection: cmt$data_channel_connectivity,
      direct_memory_access: boolean, { True implies capable of DMA transfer. }
      iou : cmt$element_name,
      kind : cmt$channel_type,
      number : ost$physical_channel_number,
      port : cmt$channel_port,
      pps_capable_of_access : cmt$pp_vector,
      ordinal: cmt$channel_ordinal,
      mainframe_ownership : cmt$element_name,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$data_channel_connectivity
*copyc cmt$element_name
*copyc cmt$channel_type
*copyc ost$physical_channel_number
*copyc cmt$channel_port
*copyc cmt$channel_ordinal
*copyc cmt$pp_vector
?? POP ??
*DECK DECK=CMT$DATA_COMMAND_DESCRIPTORS EXPAND=FALSE
 TYPE
    cmt$command_index = 0 .. cmc$max_command_index,
    cmt$data_descriptor_length = 0 .. mmc$max_rma_list_length * 0FFFF(16),
    cmt$data_command_descriptor = record
      command_index: cmt$command_index,
      move_data_to_wired_area: boolean,
      move_data_from_wired_area: boolean,
      lock_data_pages: boolean,
      io_direction: cmt$io_direction,
      length: cmt$data_descriptor_length,
      address: ^cell,
    recend,
    cmt$data_command_descriptors = array [1 .. * ] of
      cmt$data_command_descriptor;

  CONST
    cmc$max_command_index = 0ff(16);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$rma_list
*copyc cmt$io_request_type
?? POP ??
*DECK DECK=CMT$DATA_PROTOCOL EXPAND=FALSE
 TYPE
    cmt$data_protocol = (cmc$single_bit_data_path, cmc$eight_bit_data_path,
      cmc$twelve_bit_data_path, cmc$sixteen_bit_data_path);
*DECK DECK=CMT$DATA_STORAGE_CLASS EXPAND=FALSE

  TYPE
    cmt$data_storage_class = (cmc$mass_storage_device, cmc$tape_device);
*DECK DECK=CMT$DATA_STORAGE_PORT_NUMBER EXPAND=FALSE
 CONST
    cmc$max_ports_per_data_storage = 4;

  TYPE
    cmt$data_storage_port_number = 0 .. cmc$max_ports_per_data_storage - 1;
*DECK DECK=CMT$DEADSTART_DEVICE_INFO EXPAND=FALSE
*DECK DECK=CMT$DEADSTART_LCU_TASKID EXPAND=FALSE
*DECK DECK=CMT$DEADSTART_SIGNAL EXPAND=FALSE
  TYPE
    cmt$deadstart_signal = record
      originator: ost$global_task_id,
      signal: pmt$signal,
      next_signal: ^cmt$deadstart_signal,
    recend;

*copyc ost$global_task_id
*copyc pmt$signal
*DECK DECK=CMT$DEVICE_FILE_HEADER EXPAND=FALSE


  TYPE
    cmt$device_file_header = record
      length: integer,
      being_updated: ost$name,
      version: ost$name,
      changed : boolean,
    recend,

    cmt$device_file_header_v2 = record
      length: integer,
      changed : boolean,
      being_updated: ost$name,
      version: ost$name,
      status: cmt$device_file_status,
      relative_time: cmt$relative_time,
      activate_date: ost$date,
      activate_time: ost$time,
    recend,

    cmt$state_info_df_header = record
      length: integer,
      being_updated: ost$name,
      version: ost$name,
      relative_time: cmt$relative_time,
      last_update: ost$date,
      last_update_time: ost$time,
    recend;

  CONST
    cmc$being_updated = 'DEVICE FILE BEING UPDATED NOW!!',
    cmc$valid_data_in_file = 'DEVICE FILE CONTAINS VALID DATA';

?? PUSH (LISTEXT := ON) ??
*copyc OST$NAME
*copyc CMT$DEVICE_FILE_TABLE
*copyc OST$DATE
*copyc OST$TIME
?? POP ??
*DECK DECK=CMT$DEVICE_FILE_TABLE EXPAND=FALSE
  TYPE
    cmt$device_file_status = (cmc$dfs_unknown, cmc$dfs_invalid,
      cmc$dfs_installed, cmc$dfs_active),
    cmt$relative_time = (cmc$rt_unknown, cmc$rt_old, cmc$rt_new),

    cmt$device_file_record = record
      name: ost$name,
      status: cmt$device_file_status,
      recorded_vsn: rmt$recorded_vsn,
      relative_time: cmt$relative_time,
      version: ost$name,
    recend,

    cmt$state_info_device_file = record
      name: ost$name,
      recorded_vsn: rmt$recorded_vsn,
      relative_time : cmt$relative_time,
      version: ost$name,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc OST$NAME
*copyc CMT$ELEMENT_STATE
*copyc CMT$ELEMENT_NAME
*copyc RMD$VOLUME_DECLARATIONS
?? POP ??
*DECK DECK=CMT$DEVICE_ID EXPAND=FALSE

{ COMMON DECK CMDDID }

  TYPE
    cmt$device_id = record
      product_id: cmt$product_identification,
      cm_unit_type: cmt$unit_type,
      io_unit_type: iot$unit_type,
      unit_class: cmt$unit_class
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc CMT$PRODUCT_IDENTIFICATION
*copyc CMT$UNIT_TYPE
*copyc CMT$UNIT_CLASS
*copyc IOT$DEVICE_TABLE
?? POP ??
*DECK DECK=CMT$DEVICE_INFORMATION EXPAND=TRUE

   TYPE
     cmt$device_information = RECORD
       iou_number : dst$iou_number,
       channel_number : 0 .. 0ff(16),
       equipment_number : 0 .. 7,
       unit_number : 0 .. 63,
       unit_type : iot$unit_type,
       logical_unit : iot$logical_unit,
     RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc dst$iou_number
*copyc iot$unit_type
*copyc iot$logical_unit
?? POP ??
*DECK DECK=CMT$DEVICE_STATUS_DISPLAY EXPAND=FALSE

  TYPE
    cmt$device_status_display = RECORD
      element_name : cmt$element_name,
      element_type : cmt$element_type,
      product_number : string (6),
      physical_address : integer,
      channels : array {iou} [1 .. 2] of channel_info,
    RECEND;

  TYPE
    channel_info = RECORD
      iou : string (4),
      name : string (6),
    RECEND;
?? PUSH(LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$element_type
*copyc iot$logical_unit
?? POP ??
*DECK DECK=CMT$DIAGNOSTIC_PATH EXPAND=FALSE
 TYPE
    cmt$diagnostic_path = record
        case use_logical_identification: boolean of
        = TRUE =
          iou: cmt$element_name,
          channel: cmt$element_name,
          controller: cmt$element_name,
          storage_device: cmt$element_name,
        = FALSE =
          physical_identification: cmt$physical_identification,
        casend,
    recend;

*copyc cmt$element_name
*copyc cmt$physical_identification

*DECK DECK=CMT$DISPLAY_OPTION EXPAND=FALSE

  TYPE
     cmt$display_option = set of cmt$display_option_key;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$display_option_key
?? POP ??
*DECK DECK=CMT$DISPLAY_OPTION_KEY EXPAND=FALSE

  TYPE
    cmt$display_option_key = (cmc$active_paths_kw, cmc$application_info_kw, cmc$connection_status_kw,
          cmc$disabled_paths_kw, cmc$element_id_kw, cmc$inactive_paths_kw, cmc$ioupn_kw,
          cmc$ms_class_kw, cmc$physical_connection_kw, cmc$physical_paths_kw,
          cmc$serial_number_kw, cmc$site_info_kw, cmc$state_kw, cmc$parity_status_kw, cmc$all_kw),

    cmt$path_types = (cmc$active_paths, cmc$inactive_paths, cmc$disabled_paths,
          cmc$physical_paths);

*DECK DECK=CMT$DOWNLINE_CONNECTION EXPAND=FALSE
  TYPE
    cmt$downline_connection = record
      downline_element: cmt$element_name,
      status: cmt$connection_status,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$connection
*copyc cmt$element_name
?? POP ??
*DECK DECK=CMT$ELEMENT_ACCESS EXPAND=FALSE

   TYPE
     cmt$device_access = (cmc$read, cmc$write),

     cmt$element_access = set of cmt$device_access;
*DECK DECK=CMT$ELEMENT_CAPABILITIES EXPAND=FALSE

  TYPE
    cmt$device_capability = (cmc$job_reservation,
         cmc$volume_assignment, cmc$file_allocation, cmc$io_request_submission,
         cmc$concurrent_maintenance, cmc$dedicated_maintenance),

    cmt$element_capabilities = set of cmt$device_capability;
*DECK DECK=CMT$ELEMENT_CAPABILITY EXPAND=FALSE
  TYPE
    cmt$element_capability = record
      case element_type: cmt$element_type of
      = cmc$storage_device_element =
        case device_class: rmt$device_class of
        = rmc$mass_storage_device, rmc$terminal_device, rmc$null_device =
          ,
        = rmc$magnetic_tape_device =
          densities: cmt$densities,
          write_inhibited: boolean,
        casend,
      = cmc$central_memory_element, cmc$controller_element,
            cmc$data_channel_element, cmc$channel_adapter_element,
            cmc$iou_element, cmc$mainframe_element, cmc$pem_element,
            cmc$pp_element, cmc$external_processor_element,
            cmc$communications_element =
        ,
      casend,
    recend;

  TYPE
    cmt$densities = set of rmt$density;

*copyc cmt$element_type
*copyc rmt$density
*copyc rmt$device_class
*DECK DECK=CMT$ELEMENT_CONNECTION EXPAND=FALSE

  TYPE
    cmt$element_connection = record
      case configured: boolean of
      = TRUE =
        element_name: cmt$element_name,
      = FALSE =
        ,
      casend,
    recend;


*copyc CMT$ELEMENT_NAME

*DECK DECK=CMT$ELEMENT_DEFINITION EXPAND=FALSE
 TYPE

    cmt$element_definition = record
      element_name: cmt$element_name,
      product_id: cmt$product_identification,
      serial_number: cmt$serial_number,
      case element_type: cmt$element_type of
      = cmc$central_memory_element =
        central_memory: cmt$central_memory_definition,
      = cmc$central_processor_element =
        central_processor: cmt$cp_definition,
      = cmc$data_channel_element =
        data_channel: cmt$data_channel_definition,
      = cmc$channel_adapter_element =
        channel_adapter: cmt$channel_adapter_definition,
      = cmc$communications_element =
        communications_element: cmt$communications_definition,
      = cmc$controller_element =
        controller: cmt$controller_definition,
      = cmc$external_processor_element =
        external_processor: cmt$external_cpu_definition,
      = cmc$iou_element =
        iou: cmt$iou_definition,
      = cmc$mainframe_element =
        mainframe: cmt$mainframe_definition,
      = cmc$pem_element =
        pem: cmt$pem_definition,
      = cmc$pp_element =
        pp: cmt$pp_definition,
      = cmc$storage_device_element =
        storage_device: cmt$storage_device_definition,
      casend,
    recend;

*copyc cmt$central_memory_definition
*copyc cmt$channel_adapter_definition
*copyc cmt$communications_definition
*copyc cmt$controller_definition
*copyc cmt$cp_definition
*copyc cmt$data_channel_definition
*copyc cmt$element_name
*copyc cmt$element_type
*copyc cmt$external_cpu_definition
*copyc cmt$iou_definition
*copyc cmt$mainframe_definition
*copyc cmt$pem_definition
*copyc cmt$pp_definition
*copyc cmt$product_identification
*copyc cmt$serial_number
*copyc cmt$storage_device_definition
*copyc pmt$program_name
*DECK DECK=CMT$ELEMENT_DESCRIPTOR EXPAND=FALSE
  TYPE
    cmt$element_descriptor = record
      case element_type: cmt$element_type of
      = cmc$mainframe_element, cmc$central_processor_element,
            cmc$central_memory_element, cmc$iou_element, cmc$pem_element =
        name: cmt$element_name,
      = cmc$channel_adapter_element, cmc$communications_element,
            cmc$controller_element, cmc$external_processor_element,
            cmc$storage_device_element =
        peripheral_descriptor: cmt$peripheral_descriptor,
      = cmc$data_channel_element =
        channel_descriptor: cmt$channel_descriptor,
      = cmc$pp_element =
        pp: cmt$pp_descriptor,
      casend,
    recend;

*copyc cmt$channel_descriptor
*copyc cmt$peripheral_descriptor
*copyc cmt$element_name
*copyc cmt$element_type
*copyc cmt$pp_descriptor
*DECK DECK=CMT$ELEMENT_INFORMATION EXPAND=FALSE
 TYPE
    cmt$element_information = array [1 .. * ] of cmt$element_info_item;

*copyc cmt$element_info_item
*DECK DECK=CMT$ELEMENT_INFO_ITEM EXPAND=FALSE
 TYPE
    cmt$element_info_item = record
      item_returned {output} : boolean,
      case selector {input} : cmt$element_info_items of {output}
      = cmc$application_information =
        application_information: ^string ( * ),
      = cmc$application_string_size =
        application_info_string_size: integer,
      = cmc$dau_size =
        dau_size: integer,
      = cmc$device_class =
        device_class: rmt$device_class,
      = cmc$element_capability =
        element_capability: cmt$element_capability,
      = cmc$element_status =
        element_status: cmt$element_status,
      = cmc$external_vsn =
        external_vsn: rmt$external_vsn,
      = cmc$mass_storage_available =
        available_capacity : integer,
      = cmc$mass_storage_capacity =
        total_capacity: integer,
      = cmc$maintenance_activity =
        maintenance_activity: cmt$maintenance_activity,
      = cmc$product_identification =
        product_identification: cmt$product_identification,
      = cmc$recorded_vsn =
        recorded_vsn: rmt$recorded_vsn,
      = cmc$serial_number =
        serial_number: cmt$serial_number,
      = cmc$site_information =
        site_information: ^string ( * ),
      = cmc$site_info_string_size =
        site_info_string_size: integer,
      = cmc$system_activity =
        system_activity: cmt$system_activity,
      = cmc$system_critical_element =
        system_critical_element: boolean,
      = cmc$volume_active =
        active: boolean,
      = cmc$volume_online =
        online: boolean,
      casend,
    recend;

*copyc cmt$element_info_items
*copyc cmt$element_capability
*copyc cmt$element_status
*copyc cmt$maintenance_activity
*copyc cmt$product_identification
*copyc cmt$serial_number
*copyc cmt$system_activity
*copyc rmd$volume_declarations
*copyc rmt$device_class
*DECK DECK=CMT$ELEMENT_INFO_ITEMS EXPAND=FALSE
 CONST

    cmc$dau_size = 5,
    cmc$device_class = 10,
    cmc$element_capability = 15,
    cmc$element_status = 20,
    cmc$external_vsn = 25,
    cmc$maintenance_activity = 30,
    cmc$product_identification = 35,
    cmc$recorded_vsn = 40,
    cmc$serial_number = 45,
    cmc$system_activity = 50,
    cmc$system_critical_element = 55,
    cmc$application_information = 60,
    cmc$application_string_size = 65,
    cmc$site_information = 70,
    cmc$site_info_string_size = 75,
    cmc$mass_storage_capacity = 80,
    cmc$mass_storage_available = 85,
    cmc$volume_active = 90,
    cmc$volume_online = 95,
    cmc$max_element_info_item = 511;

  TYPE
    cmt$element_info_items = 1 .. cmc$max_element_info_item;
*DECK DECK=CMT$ELEMENT_NAME EXPAND=FALSE

  TYPE
    cmt$element_name = ost$name;

*copyc OST$NAME
*DECK DECK=CMT$ELEMENT_RESERVATION EXPAND=FALSE
  TYPE
    cmt$element_reservation = record
      case element_type: cmt$element_type of
      = cmc$central_processor_element =
        name: cmt$element_name,
      = cmc$data_channel_element =
        channel_descriptor: cmt$channel_descriptor,
      = cmc$channel_adapter_element, cmc$communications_element,
            cmc$controller_element, cmc$external_processor_element,
            cmc$storage_device_element =
        peripheral_descriptor: cmt$peripheral_descriptor,
      = cmc$pp_element =
        pp_reservation: {input, output} cmt$pp_reservation,
{   Reservations of the following elements are not supported:}
      = cmc$mainframe_element, cmc$central_memory_element, cmc$iou_element,
            cmc$pem_element =
        ,
      casend,
    recend;

*copyc cmt$channel_descriptor
*copyc cmt$peripheral_descriptor
*copyc cmt$element_name
*copyc cmt$element_type
*copyc cmt$pp_reservation
*DECK DECK=CMT$ELEMENT_SELECTOR EXPAND=FALSE


  TYPE
     cmt$selector = (cmc$select_by_type, cmc$select_by_product,
         cmc$select_by_device_class, cmc$select_all),

     cmt$element_selector = RECORD
       CASE key : cmt$selector OF
       = cmc$select_by_type =
         element_type : cmt$element_type,
       = cmc$select_by_product =
         product_id : cmt$product_identification,
       = cmc$select_by_device_class =
         device_class : rmt$device_class,
       = cmc$select_all =
           ,
       CASEND,
     RECEND;

?? PUSH(LISTEXT := ON) ??
*copyc cmt$element_type
*copyc cmt$product_identification
*copyc rmt$device_class
?? POP ??

*DECK DECK=CMT$ELEMENT_STATE EXPAND=FALSE

  TYPE
    cmt$element_state = (cmc$on, cmc$off, cmc$down);

*DECK DECK=CMT$ELEMENT_STATES EXPAND=FALSE

  TYPE
    cmt$element_states = set of cmt$element_state;

*copyc cmt$element_state

*DECK DECK=CMT$ELEMENT_STATUS EXPAND=FALSE
 TYPE
    cmt$element_status = record
      case state: cmt$element_state of
      = cmc$on =
        ,
      = cmc$down, cmc$off =
        case repair_action_required: boolean of
        = TRUE =
          repair_attempted: boolean,
        = FALSE =
          ,
        casend,
      casend,
    recend;

*copyc cmt$element_state
*DECK DECK=CMT$ELEMENT_TYPE EXPAND=FALSE

  TYPE
    cmt$element_type = (cmc$central_memory_element,
          cmc$central_processor_element, cmc$controller_element,
          cmc$data_channel_element, cmc$channel_adapter_element,
          cmc$iou_element, cmc$mainframe_element, cmc$pem_element,
          cmc$pp_element, cmc$storage_device_element,
          cmc$external_processor_element, cmc$communications_element);

*DECK DECK=CMT$EQUIPMENT_IDENTIFICATION EXPAND=FALSE

  TYPE
    cmt$equipment_identification = record
      number: cmt$equipment_number,
      dollar: string (1), {Must be set to dollar sign}
      type_identifier: cmt$equipment_type_id,
      series_code: cmt$equipment_series_code,
    recend,

    cmt$equipment_number = string (5), {Two alpha followed by 3 numeric char}

    cmt$equipment_type_id = string (1), {One alpha char}

    cmt$equipment_series_code = string (2) {Two numeric char} ;
*DECK DECK=CMT$ESM_DEFINITION EXPAND=FALSE

{  DECK: CMT$ESM_DEFINITION

    TYPE
      cmt$esm_definition = record
        element_name: cmt$element_name,
        product_id: cmt$product_identification,
        serial_number: cmt$serial_number,
        peripheral_driver_name: pmt$program_name,
        low_speed_port: array [1 .. cmc$max_low_speed_port_number] OF cmt$upline_connection,
        side_door_port: array [1 .. cmc$max_side_door_port_number] OF cmt$upline_connection,
        memory_size: cmt$esm_memory_size,
        maintenance_buffer_location: cmt$esm_maintenance_buffer_loc,
      recend;

    TYPE
      cmt$esm_maintenance_buffer_loc = record
        first_word_address: 0 .. cmc$max_esm_size,
        length: integer,
      recend;

    TYPE
      cmt$esm_memory_size = 0 .. cmc$max_esm_size;

    CONST
      cmc$max_low_speed_port_number = 12,
      cmc$max_side_door_port_number = 2;

*copyc cmc$maximum_esm_size
*copyc cmt$element_name
*copyc cmt$product_identification
*copyc cmt$serial_number
*copyc cmt$upline_connection
*copyc pmt$program_name

*DECK DECK=CMT$EXTERNAL_CPU_CONNECTIVITY EXPAND=FALSE
 TYPE
    cmt$external_cpu_connectivity = record
      central_memory: cmt$upline_connection,
{   a MAP_V (65354_x) has 7 ports, maximum}
      io_port: array [cmt$physical_equipment_number] of cmt$upline_connection,
    recend;

*copyc cmt$physical_equipment_number
*copyc cmt$upline_connection
*DECK DECK=CMT$EXTERNAL_CPU_DEFINITION EXPAND=FALSE
 TYPE
    cmt$external_cpu_definition = record
      microcode_identification: cmt$equipment_identification,
      peripheral_driver_name: pmt$program_name,
      response_handler_name: pmt$program_name,
      physical_equipment_number: cmt$physical_equipment_number,
      connection: cmt$external_cpu_connectivity,
    recend;

*copyc cmt$equipment_identification
*copyc cmt$external_cpu_connectivity
*copyc cmt$physical_equipment_number
*copyc pmt$program_name
*DECK DECK=CMT$FOREIGN_EQUIPMENT_ERROR_LOG EXPAND=FALSE
      TYPE
        cmt$foreign_equipment_error_log = RECORD
               pp_response: iot$pp_response,
               channel: iot$channel_number,
               equipment: cmt$physical_equipment_number,
               logical_unit: iot$logical_unit,
               symptom_code: 0 .. 0ffff(16),
               unit_type: iot$unit_type,
               logical_operation: integer,
               controller_type: iot$controller_number,
               display_message: boolean,
               physical_unit: iot$physical_unit_number,
               failure_severity: 0 .. 0ff(16),
               detailed_status: iot$detailed_status,
                                          RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_response
*copyc iot$channel_number
*copyc cmt$physical_equipment_number
*copyc iot$logical_unit
*copyc iot$unit_type
*copyc iot$pp_interface_table
?? POP ??
*DECK DECK=CMT$FUNCTION_SIZE EXPAND=FALSE
 TYPE
    cmt$function_size = (cmc$eight_bit_function, cmc$twelve_bit_function,
      cmc$sixteen_bit_function);
*DECK DECK=CMT$HARDWARE_ADDRESS EXPAND=FALSE
 TYPE
    cmt$hardware_address = record
      physical_address_specifier: cmt$physical_address_specifier,
      iou: cmt$element_name, {IOU0 is assumed if not specified}
      channel: cmt$channel_identification,
      channel_address: cmt$physical_equipment_number,
      unit_address: cmt$physical_unit_number,
    recend;

*copyc cmt$element_name
*copyc cmt$channel_identification
*copyc cmt$physical_descriptors
*copyc cmt$physical_address_specifier
*copyc cmt$physical_equipment_number
*copyc cmt$physical_unit_number
*DECK DECK=CMT$HARDWARE_ELEMENT_ID EXPAND=FALSE


  CONST
{}
{ Element numbers:
{}
    cmc$processor_element_number = 0,
    cmc$memory_element_number = 1,
    cmc$iou_element_number = 2,
    cmc$ecs_coupler_element_number = 3,
    cmc$cem_element_number = 4,
{}
{ Model_numbers:
{}
    cmc$i2_model = 20(16),
    cmc$i2_cost_reduced = 21(16),
    cmc$s1_model = 10(16),
    cmc$p2_model = 20(16),
    cmc$p2_cost_reduced_model = 21(16),
    cmc$p3_model = 30(16),
    cmc$p4_model = 40(16),
    cmc$m2_model = 20(16),
    cmc$m2_cost_reduced_model = 21(16),
    cmc$m3_model = 30(16),
    cmc$m4_model = 40(16),
    cmc$ecs_coupler_model = 20(16),
    cmc$cem_model = 20(16),
{}
    cmc$max_element_number = 0ff(16),
    cmc$max_model_number = 0ff(16),
    cmc$max_serial_number = 0ffff(16);

  TYPE
    cmt$hardware_element_id = record
      element_number: cmt$hardware_element_number,
      model_number: cmt$hardware_model_number,
      serial_number: cmt$hardware_serial_number,
    recend,

    cmt$hardware_element_number = 0 .. cmc$max_element_number,
    cmt$hardware_model_number = 0 .. cmc$max_model_number,
    cmt$hardware_serial_number = 0 .. cmc$max_serial_number;
*DECK DECK=CMT$IOU_CONNECTIVITY EXPAND=FALSE

 TYPE
    cmt$iou_connectivity = record
      central_memory: cmt$upline_connection,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$upline_connection
?? POP ??
*DECK DECK=CMT$IOU_DEFINITION EXPAND=FALSE
 TYPE
    cmt$iou_definition = record
      kind : dst$iou_model_types,
      connection: cmt$iou_connectivity,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc dst$iou_model_types
*copyc cmt$iou_connectivity
?? POP ??
*DECK DECK=CMT$IOU_RESOURCE EXPAND=TRUE
*DECK DECK=CMT$IOU_TABLE EXPAND=FALSE

  TYPE
    cmt$iou_table = RECORD
      configured  : boolean,
      nio_channel_lock_p : ^iot$channel_interlock_table,
      cio_channel_lock_p : ^iot$channel_interlock_table,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc iot$channel_interlock_table
?? POP ??
*DECK DECK=CMT$IO_COMMANDS EXPAND=FALSE

{}
{ Command codes 00 .. 1f are allowed only in requests in ppu queue.
{}

  CONST
    cmc$cc_acknowledge = ioc$cc_acknowledge,
    cmc$cc_stop_unit = ioc$cc_stop_unit,
    cmc$cc_select_unit = ioc$cc_select_unit,
    cmc$cc_select_controller = ioc$cc_select_controller,
    cmc$cc_idle = ioc$cc_idle,
    cmc$cc_resume = ioc$cc_resume,
    cmc$cc_execute_overlay = ioc$cc_execute_overlay,
    cmc$cc_start_ready_scan = ioc$cc_start_ready_scan,
    cmc$cc_stop_ready_scan = ioc$cc_stop_ready_scan,
    cmc$cc_select_pp_address = ioc$cc_select_pp_address,
    cmc$cc_copy_pp_memory = ioc$cc_copy_pp_memory,
    cmc$cc_load_controlware = ioc$cc_load_controlware,
    cmc$cc_load_control_module = ioc$cc_load_control_module,
    cmc$cc_enable_unit = ioc$cc_enable_unit,
    cmc$cc_disable_unit = ioc$cc_disable_unit,
    cmc$cc_master_clear_channel = ioc$cc_master_clear_channel,
    cmc$cc_master_clear_controller = ioc$cc_master_clear_controller,
{}
{ Command codes 20 .. 3f identify device_dependent (physical) commands.
{}
    cmc$cc_function = ioc$cc_function,
    cmc$cc_output_8_bit_parameters = ioc$cc_output_8_bit_parameters,
    cmc$cc_output_6_bit_parameters = ioc$cc_output_6_bit_parameters,
    cmc$cc_output_8_bit_data = ioc$cc_output_8_bit_data,
    cmc$cc_output_6_bit_data = ioc$cc_output_6_bit_data,
    cmc$cc_input_8_bit_data = ioc$cc_input_8_bit_data,
    cmc$cc_input_6_bit_data = ioc$cc_input_6_bit_data,
{}
{ Command codes 40 .. df identify logical commands.
{}
    cmc$cc_read_bytes = ioc$cc_read_bytes,
    cmc$cc_read_record = ioc$cc_read_record,
    cmc$cc_read_6_bit_record = ioc$cc_read_6_bit_record,
    cmc$cc_write_bytes = ioc$cc_write_bytes,
    cmc$cc_write_record = ioc$cc_write_record,
    cmc$cc_write_6_bit_record = ioc$cc_write_6_bit_record,
    cmc$cc_read_status = ioc$cc_read_status,
    cmc$cc_store_transfer_count = ioc$cc_store_transfer_count,
    cmc$cc_compare_swap = ioc$cc_compare_swap,
    cmc$cc_pool_read = ioc$cc_pool_read,
    cmc$cc_write_initialize = ioc$cc_write_initialize,
    cmc$cc_read_flaws = ioc$cc_read_flaws,
    cmc$cc_write_verify = ioc$cc_write_verify,
    cmc$cc_rewind = ioc$cc_rewind,
    cmc$cc_unload = ioc$cc_unload,
    cmc$cc_forward_space_record = ioc$cc_forward_space_record,
    cmc$cc_backspace_record = ioc$cc_backspace_record,
    cmc$cc_forward_space_filemark = ioc$cc_forward_space_filemark,
    cmc$cc_backspace_filemark = ioc$cc_backspace_filemark,
    cmc$write_filemark = ioc$cc_write_filemark,
    cmc$cc_security_erase = ioc$cc_security_erase,
    cmc$cc_select_density = ioc$cc_select_density,
{}
{ Command codes 0E0 .. 0EF identify pp dependent commands.
{}
    cmc$first_pp_dependent_cc = 0E0(16),
    cmc$last_pp_dependent_cc = 0EF(16),
{}
{ Command codes F0 .. FF identify unit dependent commands.
{}
    cmc$first_unit_dependent_cc = 0F0(16),
    cmc$last_unit_dependent_cc = 0FF(16);

  TYPE
    cmt$command = iot$command,
    cmt$command_code = iot$command_code,
    cmt$flags = iot$flags,
    cmt$command_length = iot$command_length;

?? PUSH (LISTEXT := ON) ??
*copyc iot$command
?? POP ??
*DECK DECK=CMT$IO_COMMAND_TABLE EXPAND=FALSE
 TYPE
    cmt$io_command = record
      flags: cmt$flags,
      case command_code: cmt$command_code of
      = cmc$cc_acknowledge .. cmc$cc_resume, cmc$cc_start_ready_scan,
        cmc$cc_select_pp_address, cmc$cc_rewind .. cmc$cc_security_erase,
          cmc$cc_function, cmc$cc_select_density =
        length: iot$command_length,
        value: 0 .. 0ffffffff(16),
      = cmc$cc_execute_overlay, cmc$cc_copy_pp_memory, cmc$cc_load_controlware,
        cmc$cc_output_8_bit_parameters .. cmc$cc_input_6_bit_data =
        ,
      casend,
    recend,
    cmt$io_command_table = array [1 .. * ] of cmt$io_command;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$io_commands
?? POP ??
*DECK DECK=CMT$IO_COMPLETION_QUEUE_INDEX EXPAND=FALSE
 TYPE
    cmt$io_completion_queue_index = 0 .. cmc$max_subsystem_io_requests;

  CONST
    cmc$max_subsystem_io_requests = 25;
*DECK DECK=CMT$IO_REQUEST_TYPE EXPAND=FALSE
 TYPE
    cmt$io_direction = (cmc$read_into_memory, cmc$write_from_memory,
      cmc$no_memory_reference, cmc$read_write_memory, cmc$dummy_5_memory,
      cmc$dummy_6_memory, cmc$dummy_7_memory, cmc$dummy_8_memory),
    cmt$io_requests = (cmc$pp_io, cmc$unit_io, cmc$no_io, cmc$dummy4_io,
      cmc$dummy5_io, cmc$dummy6_io, cmc$dummy7_io, cmc$dummy8_io);

  TYPE
    cmt$io_request_type = cmt$io_requests,
    cmt$io_request = record
      kind: cmt$io_requests,
      element_name: cmt$element_name,
      wait_for_io_completion: cmt$wait_for_io_completion,
    recend,
    cmt$wait_for_io_completion = record
      io_complete_response_p: ^cmt$subsys_io_response_area,
      io_complete_flag: char,
      CASE wait_for_io_completion: boolean OF
        = TRUE =
            requested_wait_time: 0 .. 0ffffffffffff(16),
            expected_wait_time: 0 .. 0ffffffffffff(16),
        = FALSE =
            destroy_io_req_upon_completion: boolean,
      CASEND,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$subsys_io_response_area
?? POP ??
*DECK DECK=CMT$JOB_OWNERSHIP EXPAND=FALSE
 TYPE
    cmt$job_ownership = record
      case active: boolean of
      = TRUE =
        job_identification: jmt$system_supplied_name,
      = FALSE =
        ,
      casend,
    recend;

*copyc jmt$system_supplied_name
*DECK DECK=CMT$LCU_DISPLAY_OPTION_KEY EXPAND=FALSE

{ COMMON DECK CMDALL }

  CONST
    cmc$lcu_all_inclusive_keyword = 'ALL',
    cmc$lcu_channel_keyword = '$CHANNEL',
    cmc$lcu_controller_keyword = '$CONTROLLER',
    cmc$lcu_channel_adapter_kw = '$CHANNEL_ADAPTER',
    cmc$lcu_external_processor_kw = '$EXTERNAL_PROCESSOR',
    cmc$lcu_storage_device_keyword = '$STORAGE_DEVICE',
    cmc$lcu_communications_keyword = '$COMMUNICATIONS_ELEMENT';

  TYPE
    cmt$lcu_display_option_key = (cmc$lcu_do_all, cmc$lcu_do_channel,
      cmc$lcu_do_controller, cmc$lcu_do_storage_device,
      cmc$lcu_do_channel_adapter, cmc$lcu_do_external_processor,
      cmc$lcu_do_communications);
*DECK DECK=CMT$LCU_LOCK EXPAND=FALSE

  TYPE
    cmt$lcu_lock = record
      lock: ost$signature_lock,
      job_name: jmt$system_supplied_name,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
*copyc jmt$system_supplied_name
?? POP ??
*DECK DECK=CMT$LCU_LOCK_TYPE EXPAND=FALSE

  TYPE
    cmt$lcu_lock_type = (cmc$configuration_administrator, cmc$removable_media_operation);
*DECK DECK=CMT$LOGICAL_PP_TABLE EXPAND=FALSE

  TYPE
    cmt$logical_pp_table = ARRAY [1 .. *] OF cmt$logical_pp_table_entry,

    cmt$logical_pp_table_entry = RECORD
      flags: cmt$logical_pp_flags,
      pp_info: cmt$logical_pp_info,
      controller_info: cmt$logical_pp_controller,
      task_info: cmt$logical_pp_task_info,
      handlers: cmt$logical_pp_handlers,
      active_check: cmt$logical_pp_active_check,
    RECEND,

    cmt$logical_pp_active_check = RECORD
      timestamp: integer,
      timeout: integer,
    RECEND,

    cmt$logical_pp_controller = RECORD
      controlware_loaded: boolean,
      control_module_loaded: boolean,
      controller_type: cmt$controller_type,
    RECEND,

    cmt$logical_pp_flags = RECORD
      configured: boolean,
      resources_acquired: boolean,
      pp_loaded: boolean,
      disabled: boolean,
      entry_in_use: boolean,
      entry_reserved_by_nosve: boolean,
      entry_reserved_by_other: boolean,
      entry_reserved_by_system_job: boolean,
      reservd_by_other_has_ch_present: boolean,
      pp_hung: boolean,
      pp_idle_resume_supported: boolean,
      pp_handshaking_supported: boolean,
      pp_reload_supported: boolean,
    RECEND,

    cmt$logical_pp_handlers = RECORD
      response_handler_p: cmt$response_handler,
      one_word_response_allowed: boolean,
      one_word_response_handler_p: dft$one_word_response_handler,
    RECEND,

    cmt$logical_pp_info = RECORD
      physical_pp: dst$iou_resource,
      logical_partner_pp_index: iot$pp_number,
      pp_type: cmt$logical_pp_type,
      pp_interface_table_rma: ost$real_memory_address,
      pp_interface_table_p: ^iot$pp_interface_table,
      pp_communication_buffer_p: ^iot$communication_buffer,
      channel: dst$iou_resource,
      channel_port: cmt$channel_port,
      channel_interlock_p: ^iot$channel_interlock_table,
      driver_code_p: ^SEQ ( * ),
      driver_name: dst$driver_name,
      cip_driver_name: dst$driver_name,
      saved_io_request_p: ^iot$io_request,
    RECEND,

    cmt$logical_pp_task_info = RECORD
      gtid: ost$global_task_id,
      reserved_job_name: jmt$system_supplied_name,
    RECEND,

    cmt$logical_pp_type = (cmc$lpt_null_pp_type, cmc$lpt_other_pp_type, cmc$lpt_disk_pp_type,
          cmc$lpt_tape_pp_type, cmc$lpt_network_pp_type, cmc$lpt_nad_pp_type);

*copyc cmt$channel_port
*copyc cmt$controller_type
*copyc cmt$response_handler
*copyc dft$one_word_response_handler
*copyc dst$driver_name
*copyc dst$iou_resource
*copyc iot$channel_interlock_table
*copyc iot$io_request
*copyc iot$pp_interface_table
*copyc iot$pp_number
*copyc jmt$system_supplied_name
*copyc ost$global_task_id
*copyc ost$hardware_subranges
*DECK DECK=CMT$LOGICAL_UNIT_ATTRIBUTES EXPAND=FALSE
  {
  { common deck cmdlun
  {

  TYPE
    cmt$logical_unit_attributes = array [1 .. * ] of
      cmt$logical_unit_attribute,
    cmt$logical_unit_attribute = record
      case keyword: cmt$lun_attribute_keywords of
      = cmc$device_type =
        device_type: cmt$product_identification,
      = cmc$recorded_vsn =
        recorded_vsn: rmt$recorded_vsn,
      = cmc$sen =
        sen: rmt$sen,
      casend,
    recend,
    cmt$lun_attribute_keywords = (cmc$device_type, cmc$recorded_vsn, cmc$sen);

*copyc RMD$TYPE_DECLARATIONS
*copyc RMD$VOLUME_DECLARATIONS
*copyc CMT$PRODUCT_IDENTIFICATION
*DECK DECK=CMT$LOGICAL_UNIT_TABLE EXPAND=FALSE


  TYPE
    cmt$logical_unit_table = array [1 .. * ] of cmt$logical_unit,

    cmt$logical_unit = record
      configured: boolean, {True implies this entry is initialized.}
      logical_unit_number: iot$logical_unit,
      entry_interlock: boolean,
      unit_interface_table: ^iot$unit_interface_table,
      element_capability : cmt$element_capabilities,
      status: cmt$logical_unit_status,
      unit_communication_buffer_pva: ^iot$unit_communication_buffer,
      element_access : cmt$element_access

    recend,

    cmt$logical_unit_status = record
      case assignable_device: boolean of {Indicates sole use by a job or not.}
      = TRUE =
        assigned: boolean,
        assigned_jsn: jmt$system_supplied_name,
      = FALSE =
        ,
      casend,
    recend;

*copyc IOT$LOGICAL_UNIT
*copyc CMT$ELEMENT_CAPABILITIES
*copyc CMT$ELEMENT_ACCESS
*copyc IOT$UNIT_INTERFACE_TABLE
*copyc jmt$system_supplied_name
*DECK DECK=CMT$MAINFRAME_DEFINITION EXPAND=FALSE
 TYPE
    cmt$mainframe_definition = record
      case kind: cmt$mainframe_type of
      = cmc$cyber_180_mainframe =
        c180_connection: cmt$radial_interface,
      = cmc$cyber_170_mainframe =
        ,
      = cmc$cyber_200_mainframe =
        ,
      = cmc$non_cdc_mainframe =
        ,
      casend,
    recend,
    cmt$mainframe_type = (cmc$cyber_180_mainframe, cmc$cyber_170_mainframe,
      cmc$cyber_200_mainframe, cmc$non_cdc_mainframe);

*copyc cmt$radial_interface
*DECK DECK=CMT$MAINFRAME_ELEMENT EXPAND=FALSE

{  deleted by modification MXN_119, new deck name is CMT$ELEMENT_DEFINITION. }
*DECK DECK=CMT$MAINTENANCE_ACTIVITY EXPAND=FALSE
 TYPE
    cmt$maintenance_activity = record
      case access: mst$access_type of
      = msc$dedicated_access =
        dedicated_accessor: cmt$job_ownership,
      = msc$concurrent_access =
        concurrent_access_count : integer,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$job_ownership
*copyc mst$access_type
?? POP ??
*DECK DECK=CMT$MAINTENANCE_ACTIVITY_COUNT EXPAND=FALSE

 TYPE
    cmt$maintenance_activity_count = record
      case access: mst$access_type of
      = msc$dedicated_access =
        dedicated_accessor: cmt$job_ownership,
      = msc$concurrent_access =
        con_access_job_list : mst$con_access_job_list,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$job_ownership
*copyc mst$access_type
*copyc mst$con_access_job_list
?? POP ??
*DECK DECK=CMT$MASS_STORAGE_INFORMATION EXPAND=FALSE

   TYPE
     cmt$mass_storage_information = PACKED RECORD
       iou_number : dst$iou_number,
       channel : cmt$physical_channel,
       unit_number : 0 .. 3f(16),
       CASE unit_type : cmt$unit_type OF
       = cmc$ms844_4x , cmc$ms885_1x, cmc$ms885_4x =
              ,
       = cmc$ms895_2 =
         storage_director_address : 0 .. 7,
         head_of_string_controller : 0 .. 1,
       = cmc$ms834_2, cmc$msfsd_2, cmc$msfsd2_s0, cmc$msxmd_3 =
         control_module : 0 .. 7,
       CASEND,
     RECEND;

?? PUSH(LISTEXT := ON) ??
*copyc cmt$physical_channel
*copyc cmt$unit_type
*copyc dst$iou_number
?? POP ??
*DECK DECK=CMT$MASS_STORAGE_VOLUME EXPAND=FALSE

TYPE
  cmt$mass_storage_volume = RECORD
    recorded_vsn : rmt$recorded_vsn,
    class : dmt$class,
    lun : iot$logical_unit,
    on_and_enabled : BOOLEAN,
    changed : BOOLEAN,
    write_status : ost$status,
  RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$class
*copyc iot$logical_unit
*copyc ost$status
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=CMT$MS_CLASS EXPAND=FALSE
  TYPE
    cmt$ms_class = set of cmt$ms_class_members;

*copyc cmt$ms_class_members
*DECK DECK=CMT$MS_CLASS_INFO EXPAND=FALSE
  TYPE
    cmt$ms_class_info = array [cmt$ms_class_members] of boolean;

*copyc cmt$ms_class_members
*DECK DECK=CMT$MS_CLASS_MEMBERS EXPAND=FALSE
  TYPE
    cmt$ms_class_members = 'A' .. 'Z';
*DECK DECK=CMT$MS_LOGICAL_UNIT_LIST EXPAND=FALSE

{ COMMON DECK CMDMSLU }

  TYPE
    cmt$ms_logical_unit_list = array [1 .. * ] of record
      lun: iot$logical_unit,
      pid: cmt$product_identification,
    recend;

*copyc IOT$LOGICAL_UNIT
*copyc CMT$PRODUCT_IDENTIFICATION
*DECK DECK=CMT$OS_SUBSYSTEM_RESPONSE EXPAND=FALSE
 TYPE
    cmt$collected_pp_response = record
      pp_number: ALIGNED [0 MOD 8] iot$pp_number,
      response_status: cmt$subsys_io_response_status,
      detailed_status: iot$detailed_status,
      time_request_received_by_mtr: ost$date_time,
      time_request_queued: ost$date_time,
      time_response_received_by_mtr: ost$date_time,
      time_response_sent_to_job: ost$date_time,
      pp_response: ALIGNED [0 MOD 8] iot$pp_response,
    recend;

  TYPE
    cmt$os_subsystem_response = record
      pp_number: iot$pp_number,
      pp_response: iot$pp_response,
    recend,
    cmt$os_subsystem_io_response = record
      io_status: ALIGNED [0 MOD 8] cmt$subsystem_io_comp_status,
      pp_response: cmt$os_subsystem_response,
      detailed_status: iot$detailed_status,
    recend;

  TYPE
    cmt$subsystem_io_comp_status = ost$compare_swap_lock,
    cmt$subsys_io_response_status = (cmc$subsys_io_resp_not_avail,
      cmc$subsys_io_resp_available, cmc$subsys_io_resp_completed,
      cmc$subsys_io_response_d4, cmc$subsys_io_response_d5,
      cmc$subsys_io_response_d6, cmc$subsys_io_response_d7,
      cmc$subsys_io_response_d8);

?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
*copyc iot$pp_response
*copyc ost$signature_lock
*copyc ost$date_time
?? POP ??
*DECK DECK=CMT$PCU_COMMAND_DESCRIPTOR EXPAND=FALSE

   CONST
     cmc$central_memory_connection = 0,
     cmc$iou_connection = 1,
     cmc$peripheral_connection = 2;

   TYPE
     cmt$pcu_command_descriptor = RECORD
        element_name : cmt$element_name,
        same_as : cmt$element_name,
        pid : ost$name,
        ioupn : ost$name,
        sn : integer,
        state : ost$name,
        verify : boolean,
        application_info_p: ^string ( * ),
        site_info_p: ^string ( * ),
        next_descriptor : ^cmt$pcu_command_descriptor,
        CASE connection : cmt$connection_value OF
        = cmc$central_memory_connection =
          cmc_list : ^array [ * ] of cmt$cm_connection,
          channel_list : ^array [ * ] of cmt$iou_connection,
        = cmc$iou_connection =
          iou_list : ^array [ * ] of cmt$iou_connection,
        = cmc$peripheral_connection =
          pc_list : ^array [ * ] of cmt$p_connection,
        CASEND,
     RECEND;

  TYPE
    cmt$cm_connection = RECORD
       port : 0 .. 3,
       mainframe : cmt$element_name,
    RECEND,

    cmt$iou_connection = RECORD
      channel : cmt$element_name,
      equipment : 0 .. 7,
      mainframe : cmt$element_name,
      iou : cmt$element_name,
    RECEND,

    cmt$p_connection = RECORD
      peripheral : cmt$element_name,
      address : 0 .. 0ffff(16),
    RECEND,

    cmt$connection_value = cmc$central_memory_connection .. cmc$peripheral_connection;

?? PUSH(LISTEXT := ON) ??
*copyc ost$string
*copyc cmt$element_name
*copyc ost$name
?? POP ??
*DECK DECK=CMT$PEM_CONNECTIVITY EXPAND=FALSE
 TYPE
    cmt$pem_connectivity = record
      central_processor: cmt$element_connection,
      iou: cmt$element_connection,
      sensor_channel: array [cmt$sensor_channel_number] of cmt$sensor_channel,
    recend;

*copyc cmt$element_connection
*copyc cmt$sensor_channel
*copyc cmt$sensor_channel_number
*DECK DECK=CMT$PEM_DEFINITION EXPAND=FALSE
 TYPE
    cmt$pem_definition = record
      connection: cmt$pem_connectivity,
    recend;

*copyc cmt$pem_connectivity
*DECK DECK=CMT$PERIPHERAL_DESCRIPTOR EXPAND=FALSE
 TYPE
    cmt$peripheral_descriptor = record
      case use_logical_identification: boolean of
      = TRUE =
        element_name: cmt$element_name,
      = FALSE =
        hardware_address: cmt$hardware_address,
      casend,
    recend;

*copyc cmt$element_name
*copyc cmt$hardware_address

*DECK DECK=CMT$PERIPHERAL_ELEMENT_ENTRY EXPAND=FALSE

{ Common deck CMT$PERIPHERAL_ELEMENT_ENTRY.

  TYPE
    cmt$peripheral_element_entry = packed record { 206 bytes }
      element_name: cmt$element_name, { 31 bytes }
      product_id: cmt$product_identification, { 10 bytes }
      serial_number: cmt$serial_number, { 6 bytes }
      logical_unit_number: iot$logical_unit, { 2 bytes }
      element_status: cmt$element_status, { 3 bytes }
      gtid: ost$global_task_id, { 3 bytes }
      maintenance_activity: cmt$maintenance_activity_count, { 7 bytes }
      physical_descriptor: cmt$physical_descriptor, { 138 bytes }
      entry_interlock: boolean, { 1 bit }
      state_change_request: cmt$state_change_request,
      case reservable_element: cmt$reservable_status of
      = cmc$reservable, cmc$reservable_only_by_system =
        case reserved_status: boolean of { 1 bit }

{ Actually, 1 byte needed for entry_interlock,
{ reservable_element and reserved_status

        = TRUE =
          reserved_job: jmt$system_supplied_name, { 5 bytes }
          reserved_by_system: boolean,
        = FALSE =
          ,
        casend,
      = cmc$not_reservable =
        ,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$element_status
*copyc cmt$maintenance_activity_count
*copyc cmt$physical_descriptor
*copyc cmt$product_identification
*copyc cmt$reservable_status
*copyc cmt$serial_number
*copyc cmt$state_change_request
*copyc iot$logical_unit
*copyc jmt$system_supplied_name
*copyc ost$global_task_id
?? POP ??
*DECK DECK=CMT$PERIPHERAL_ELEMENT_TABLE EXPAND=FALSE

   { Common deck CMT$PERIPHERAL_ELEMENT_TABLE }

  TYPE
    cmt$peripheral_element_table = RECORD
      lock : ost$signature_lock,
      pointer : ^ARRAY [1 .. *] OF cmt$peripheral_element_entry,
    RECEND;

?? PUSH(LISTEXT := ON) ??
*copyc cmt$peripheral_element_entry
*copyc ost$signature_lock
?? POP ??

*DECK DECK=CMT$PHYSICAL_ADDRESS EXPAND=FALSE
  TYPE
    cmt$physical_address = PACKED RECORD
      address_specifier : cmt$physical_address_specifier,
      iou : dst$iou_number,
      channel : cmt$physical_channel,
      channel_address : cmt$physical_equipment_number,
      unit_address : cmt$physical_unit_number,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$physical_address_specifier
*copyc cmt$physical_channel
*copyc cmt$physical_equipment_number
*copyc cmt$physical_unit_number
*copyc dst$iou_number
?? POP ??
*DECK DECK=CMT$PHYSICAL_ADDRESS_PARTS EXPAND=FALSE
 TYPE
    cmt$physical_address_parts = (cmc$iou, cmc$channel, cmc$channel_address,
      cmc$unit_address);
*DECK DECK=CMT$PHYSICAL_ADDRESS_SPECIFIER EXPAND=FALSE
  TYPE
    cmt$physical_address_specifier = set of cmt$physical_address_parts;

*copyc cmt$physical_address_parts
*DECK DECK=CMT$PHYSICAL_CHANNEL EXPAND=FALSE
  TYPE
    cmt$physical_channel = RECORD
      number : ost$physical_channel_number,
      port : cmt$channel_port,
      concurrent : BOOLEAN,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc ost$physical_channel_number
*copyc cmt$channel_port
?? POP ??
*DECK DECK=CMT$PHYSICAL_CONFIGURATION EXPAND=FALSE

{ COMMON DECK CMDPC }

  TYPE
    cmt$physical_configuration = ^array [1 .. * ] of cmt$element_definition;

?? PUSH (LISTEXT := ON) ??
*copyc CMT$ELEMENT_DEFINITION
?? POP ??
*DECK DECK=CMT$PHYSICAL_DESCRIPTOR EXPAND=FALSE
  TYPE
    cmt$physical_descriptor = packed record
      case configured: boolean of { 1 bit }
      = TRUE =
        case element_type: cmt$element_type of
        = cmc$data_channel_element =
          mainframe_ownership: cmt$element_name, { 31 bytes }
          channel_path: cmt$physical_address,
          channel_connection: ^array [ * ] of cmt$downline_connection,
        = cmc$controller_element, cmc$channel_adapter_element,
                cmc$communications_element, cmc$external_processor_element =
          microcode_identification: cmt$equipment_identification, { 9 bytes }
          peripheral_driver_name: pmt$program_name, { 31 bytes }
          equipment_path: ^array [ * ] of cmt$physical_address,
          equipment_connection: ^array [ * ] of cmt$downline_connection,
        = cmc$storage_device_element =
          unit_path: ^array [ * ] of cmt$physical_address,
        casend,
      = FALSE =
        hardware_address: cmt$physical_address,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$downline_connection
*copyc cmt$element_name
*copyc cmt$element_type
*copyc cmt$equipment_identification
*copyc cmt$hardware_address
*copyc cmt$physical_address
*copyc pmt$program_name
?? POP ??
*DECK DECK=CMT$PHYSICAL_DESCRIPTORS EXPAND=FALSE
 TYPE
    cmt$physical_descriptors = (cmc$product_oriented_id,
      cmc$hardware_address_id);
*DECK DECK=CMT$PHYSICAL_EQUIPMENT_NUMBER EXPAND=FALSE
 CONST
    cmc$max_equipment_per_channel = 8;

  TYPE
    cmt$physical_equipment_number = 0 .. cmc$max_equipment_per_channel - 1;
*DECK DECK=CMT$PHYSICAL_IDENTIFICATION EXPAND=FALSE
 TYPE
    cmt$physical_identification = record
        product_identification: cmt$product_identification,
        serial_number: cmt$serial_number,
        hardware_address: cmt$hardware_address,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$hardware_address
*copyc cmt$product_identification
*copyc cmt$serial_number
?? POP ??
*DECK DECK=CMT$PHYSICAL_UNIT_NUMBER EXPAND=FALSE


  CONST
    cmc$max_units_per_controller = 64;

  TYPE
    cmt$physical_unit_number = 0 .. cmc$max_units_per_controller - 1;

*DECK DECK=CMT$PP_CLASS EXPAND=FALSE

{ COMMON DECK CMDPPCL }

  TYPE
    cmt$pp_class = (cmc$pp_class1, cmc$pp_class2),

    cmt$pp_class_set = set of cmt$pp_class;
*DECK DECK=CMT$PP_COMMANDS EXPAND=FALSE

   TYPE
     cmt$pp_commands = (cmc$idle_command , cmc$resume_command);
*DECK DECK=CMT$PP_CONNECTIVITY EXPAND=FALSE
 TYPE
   cmt$pp_connectivity = array [ost$physical_channel_number] of boolean;

?? PUSH (LISTEXT := ON) ??
*copyc ost$physical_channel_number
?? POP ??
*DECK DECK=CMT$PP_CONTROLLER_LOADED EXPAND=FALSE
*DECK DECK=CMT$PP_DEFINITION EXPAND=FALSE
 TYPE
    cmt$pp_definition = record
      accessible_channels : cmt$pp_connectivity,
      concurrent : boolean, { True implies capable of asynchronous transfer. }
      direct_memory_access : boolean, { True implies capable of DMA transfer. }
      iou : cmt$element_name,
      number : ost$physical_pp_number,
      size : cmt$pp_memory_length,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pp_connectivity
*copyc cmt$element_name
*copyc ost$physical_pp_number
*copyc cmt$pp_memory_length
?? POP ??
*DECK DECK=CMT$PP_DESCRIPTOR EXPAND=FALSE
 TYPE
    cmt$pp_descriptor = record
      iou: cmt$element_name,
      case use_logical_identification: boolean of
      = TRUE =
        pp_name: cmt$element_name,
      = FALSE =
        concurrent : boolean, { True implies capable of asynchronous transfer. }
        pp_number : ost$physical_pp_number,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc ost$physical_pp_number
?? POP ??

*DECK DECK=CMT$PP_ELEMENT_ENTRY EXPAND=FALSE
*DECK DECK=CMT$PP_ELEMENT_TABLE EXPAND=FALSE
*DECK DECK=CMT$PP_IDENTIFICATION EXPAND=FALSE
 TYPE
    cmt$pp_identification = record
      ordinal: cmt$pp_ordinal,
      iou: cmt$element_name,
    recend;

*copyc cmt$element_name
*copyc cmt$pp_ordinal

*DECK DECK=CMT$PP_MEMORY_LENGTH EXPAND=FALSE
 CONST
    cmc$max_pp_size = 65536;

  TYPE
    cmt$pp_memory_length = 0 .. cmc$max_pp_size;
*DECK DECK=CMT$PP_NUMBER EXPAND=FALSE
*DECK DECK=CMT$PP_ORDINAL EXPAND=FALSE
 TYPE
    cmt$pp_ordinal = (cmc$pp0, cmc$pp1, cmc$pp2, cmc$pp3, cmc$pp4,
      cmc$pp5, cmc$pp6, cmc$pp7, cmc$pp8, cmc$pp9, cmc$pp10, cmc$pp11,
      cmc$pp12, cmc$pp13, cmc$pp14, cmc$pp15, cmc$pp16, cmc$pp17,
      cmc$pp18, cmc$pp19, cmc$cio_pp0, cmc$cio_pp1, cmc$cio_pp2,
      cmc$cio_pp3, cmc$cio_pp4, cmc$cio_pp5, cmc$cio_pp6,
      cmc$cio_pp7, cmc$cio_pp8, cmc$cio_pp9, cmc$cio_pp16, cmc$cio_pp17,
      cmc$cio_pp18, cmc$cio_pp19, cmc$cio_pp20, cmc$cio_pp21, cmc$cio_pp22,
      cmc$cio_pp23, cmc$cio_pp24, cmc$cio_pp25);
*DECK DECK=CMT$PP_PROGRAM_DESCRIPTION EXPAND=FALSE
 TYPE
    cmt$pp_program_description = record
      pp_identification: {input} cmt$pp_identification,
      iou_program_name : pmt$program_name,
      pp_program: {input} ^SEQ ( * ),
      master_pp: {input} boolean,
      element_access: {input} ^array [1 .. * ] of cmt$hardware_address,
      communication_buffer_length: {input} 0 .. osc$max_page_size,
      communication_buffer: {input, output} ^SEQ ( * ),
    recend;

?? PUSH(LISTEXT := ON) ??
*copyc cmt$hardware_address
*copyc cmt$pp_identification
*copyc ost$page_size
*copyc pmt$processor_attributes
*copyc pmt$program_name
?? POP ??
*DECK DECK=CMT$PP_REGISTERS EXPAND=FALSE
 TYPE
    cmt$pp_registers = record
      a_register: integer,
      k_register: integer,
      p_register: integer,
      q_register: integer,
    recend;
*DECK DECK=CMT$PP_RESERVATION EXPAND=FALSE
 TYPE
    cmt$pp_reservation = record
{     The acquired_pp_identification is initialized by cmp$reserve_element
{     regardless of the value of the selector field.

      acquired_pp_identification {output} : cmt$pp_identification,
      case selector {input} : cmt$pp_reservation_choices of
      = cmc$choose_any_pp =
        ,
      = cmc$choose_pp_by_barrel =
        driver_barrel : boolean,
      = cmc$choose_pp_by_channel =
{      select a PP which has access to the specified channel.}
        channel: cmt$channel_identification,
      = cmc$choose_specific_pp =
        desired_pp: cmt$pp_identification,
      casend,
    recend;

*copyc cmt$channel_identification
*copyc cmt$channel_ordinal
*copyc cmt$pp_identification
*copyc cmt$pp_reservation_choices
*DECK DECK=CMT$PP_RESERVATION_CHOICES EXPAND=FALSE
 TYPE
    cmt$pp_reservation_choices = (cmc$choose_any_pp, cmc$choose_pp_by_channel,
      cmc$choose_pp_by_barrel, cmc$choose_specific_pp);
*DECK DECK=CMT$PP_TABLE_DESCRIPTOR EXPAND=FALSE
*DECK DECK=CMT$PP_TYPE EXPAND=FALSE
*DECK DECK=CMT$PP_VECTOR EXPAND=FALSE

  TYPE
    cmt$pp_vector = array [ost$physical_pp_number] of boolean;

?? PUSH (LISTEXT := ON) ??
*copyc ost$physical_pp_number
?? POP ??
*DECK DECK=CMT$PROCESSOR_NAME EXPAND=FALSE

  TYPE
    cmt$processor_name = string(3);

*DECK DECK=CMT$PRODUCT_IDENTIFICATION EXPAND=FALSE

  TYPE
    cmt$product_identification = record
      product_number: cmt$product_number,
      underscore: string (1), {Must be a '_' character }
      model_number: cmt$model_number,
    recend,

    cmt$product_number = string (6), {One to 5 numeric char, rjbf.}

    cmt$model_number = string (3) {One to 3 numeric char, ljbf.} ;
*DECK DECK=CMT$RADIAL_IF_PORT_NUMBER EXPAND=FALSE
 TYPE
    cmt$radial_if_port_number = (cmc$iou_radial_if_port_0,
      cmc$optional_radial_if_port_1, cmc$optional_radial_if_port_2,
      cmc$optional_radial_if_port_3, cmc$optional_radial_if_port_4,
      cmc$optional_radial_if_port_5, cmc$optional_radial_if_port_6);
*DECK DECK=CMT$RADIAL_INTERFACE EXPAND=FALSE
 TYPE
    cmt$radial_interface = record
      { An S1 has only four radial interface ports.}
      { On an S3, the M3 and P3 are on the same radial_interface port.}
      port: array [cmt$radial_if_port_number] of cmt$element_connection,
    recend;

*copyc cmt$element_connection
*copyc cmt$radial_if_port_number
*DECK DECK=CMT$REQUEST_BLOCK EXPAND=FALSE

  TYPE
    cmt$request_block = RECORD
      request_code: syt$monitor_request_code,
      status: syt$monitor_status,
      CASE kind: cmt$rb_request_block_kind OF
      = cmc$rbk_assign_pp =
        assigned_pp: iot$pp_number,
        assigned: boolean,
      = cmc$rbk_change_state =
        iou: dst$iou_number,
        element_name: cmt$element_name,
        new_state: cmt$element_state,
        update_controller_address: boolean,
        redundant_path_available: boolean,
        redundant_path_pp_list_p: ^ARRAY [ * ] OF iot$pp_number,
        logical_unit_list_p: ^ARRAY [ * ] OF cmt$rb_logical_unit_address,
        CASE element_type: cmt$element_type OF
        = cmc$data_channel_element =
          channel_pp: iot$pp_number,
          channel: ost$physical_channel_number,
        = cmc$controller_element =
          controller_pp: iot$pp_number,
          controller_channel: ost$physical_channel_number,
          controller: cmt$physical_equipment_number,
        = cmc$storage_device_element =
          unit_pp: iot$pp_number,
          unit_channel: ost$physical_channel_number,
          unit_controller: cmt$physical_equipment_number,
          logical_unit: iot$logical_unit,
        CASEND,
      = cmc$rbk_idle_pp =
        idled_pp: iot$pp_number,
        send_idle: boolean,
      = cmc$rbk_queue_pp_request =
        queued_pp: iot$pp_number,
        request_p: ^iot$io_request,
      = cmc$rbk_request_stack_memory =
        first_byte_address_p: ^cell,
        rma: integer,
      = cmc$rbk_resume_pp =
        resumed_pp: iot$pp_number,
        send_resume: boolean,
      CASEND,
    RECEND,

    cmt$rb_logical_unit_address = RECORD
      logical_unit: iot$logical_unit,
      controller: cmt$physical_equipment_number,
    RECEND,

    cmt$rb_request_block_kind = (cmc$rbk_assign_pp, cmc$rbk_change_state, cmc$rbk_idle_pp,
          cmc$rbk_queue_pp_request, cmc$rbk_request_stack_memory, cmc$rbk_resume_pp);

*copyc cmt$element_name
*copyc cmt$element_state
*copyc cmt$element_type
*copyc cmt$physical_equipment_number
*copyc dst$iou_number
*copyc iot$io_request
*copyc iot$logical_unit
*copyc iot$pp_number
*copyc ost$physical_channel_number
*copyc syc$monitor_request_codes
*copyc syt$monitor_status
*DECK DECK=CMT$RESERVABLE_STATUS EXPAND=FALSE

   { Common deck CMT$RESERVABLE_STATUS }

  TYPE
    cmt$reservable_status = (cmc$not_reservable, cmc$reservable,
            cmc$reservable_only_by_system);
*DECK DECK=CMT$RESOURCES_ASSIGNED EXPAND=FALSE
*DECK DECK=CMT$RESPONSE_HANDLER EXPAND=FALSE

{ COMMON DECK CMDRESP }

  TYPE
    cmt$response_handler = ^procedure (pp_response_p: ^iot$pp_response;
      detailed_status_p: ^iot$detailed_status;
      pp_number: 1 .. ioc$pp_count;
      VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$PP_RESPONSE
*copyc IOT$PP_INTERFACE_TABLE
*copyc syt$monitor_status
?? POP ??
*DECK DECK=CMT$SCAN_VARIABLE EXPAND=FALSE
      TYPE
        cmt$scan_character_set = SET of CHAR,
        cmt$scan_variable = cmt$scan_character_set;
*DECK DECK=CMT$SCI_DFT_PP EXPAND=FALSE

  TYPE
    cmt$sci_dft_pp = RECORD
      sci_pp: dst$iou_resource,
      primary_dft_available: boolean,
      primary_dft_pp: dst$iou_resource,
      secondary_dft_available: boolean,
      secondary_dft_pp: dst$iou_resource,
    RECEND;

*copyc dst$iou_resource
*DECK DECK=CMT$SENSOR_CHANNEL EXPAND=FALSE
 TYPE
    { Sensor channel connections are limited to another CEM, to a controller, }
    { or to a peripheral unit.}

    cmt$sensor_channel = array [cmt$sensor_connection_number] of
      cmt$element_connection;

*copyc cmt$element_connection
*copyc cmt$sensor_connection_number
*DECK DECK=CMT$SENSOR_CHANNEL_NUMBER EXPAND=FALSE
 CONST
    cmc$max_sensors_per_pem = 4;

  TYPE
    cmt$sensor_channel_number = 0 .. cmc$max_sensors_per_pem - 1;
*DECK DECK=CMT$SENSOR_CONNECTION_NUMBER EXPAND=FALSE
 CONST
    cmc$max_devices_per_sensor = 16;

  TYPE
    cmt$sensor_connection_number = 0 .. cmc$max_devices_per_sensor - 1;
*DECK DECK=CMT$SERIAL_NUMBER EXPAND=FALSE

  TYPE
    cmt$serial_number = string (6) {May be alphanumeric, hex or decimal.} ;
*DECK DECK=CMT$SIGNAL_CONTENTS EXPAND=FALSE

{ NOTE:
{   The size of this record must be maintained at 32 bytes.
{

  TYPE
    cmt$signal_contents = record
      case signal_type: cmt$signal_type of                     { 1 byte}
      = cmc$reconfiguration_signal =
        reconfig_element_address: cmt$physical_address,        { 6 bytes}
        failing_element_address: cmt$physical_address,         { 6 bytes}
        fill1: string(19),                                     {19 bytes}
      = cmc$down_element_signal =
        down_element_address: cmt$physical_address,            { 6 bytes}
        fill2: string(25),                                     {25 bytes}
      = cmc$disable_element_signal =
        disable_element_address: cmt$physical_address,         { 6 bytes}
        fill3: string(25),                                     {25 bytes}
      = cmc$controller_overtemp_signal =
        overtemp_element_address: cmt$physical_address,        { 6 bytes}
        fill4: string(25),                                     {25 bytes}
      = cmc$parity_disabled_signal =
        parity_logical_unit: iot$logical_unit,                 { 2 bytes}
        parity_physical_unit: cmt$physical_unit_number,        { 1 byte}
        fill5: string(28),                                     {28 bytes}
      = cmc$das_head_shift_signal =
        hd_shift_logical_unit: iot$logical_unit,               { 2 bytes}
        hd_shift_physical_unit: cmt$physical_unit_number,      { 1 byte}
        fill6: string(28),                                     {28 bytes}
      = cmc$ssd_battery_alert_signal =
        battery_alert_logical_unit: iot$logical_unit,          { 2 bytes}
        battery_alert_physical_unit: cmt$physical_unit_number, { 1 byte}
        battery_alert_condition: 0 .. 0ffff(16),               { 2 bytes}
        fill7: string(26),                                     {26 bytes}
      casend,
    recend;

  TYPE
    cmt$signal_type= (
          cmc$reconfiguration_signal, cmc$down_element_signal,
          cmc$disable_element_signal, cmc$controller_overtemp_signal,
          cmc$parity_disabled_signal, cmc$das_head_shift_signal,
          cmc$ssd_battery_alert_signal, cmc$available_signal_type_7,
          cmc$available_signal_type_8, cmc$available_signal_type_9,
          cmc$available_signal_type_10, cmc$available_signal_type_11,
          cmc$available_signal_type_12, cmc$available_signal_type_13,
          cmc$available_signal_type_14, cmc$available_signal_type_15,
          cmc$available_signal_type_16);


*copyc cmt$physical_address
*copyc cmt$physical_unit_number
*copyc iot$logical_unit
*DECK DECK=CMT$STATE_CHANGE_REQUEST EXPAND=FALSE
  TYPE
    cmt$state_change_request = RECORD
    CASE pending: boolean OF
    = TRUE =
      new_state: cmt$element_state,
    = FALSE =
       ,
    CASEND,
  RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_state
?? POP ??
*DECK DECK=CMT$STATE_ELEMENT_LIST EXPAND=FALSE
*DECK DECK=CMT$STATE_INFORMATION EXPAND=FALSE


  TYPE
    cmt$state_information = RECORD
      element_name : cmt$element_name,
      status : cmt$element_status,
      CASE element_type : cmt$element_type OF
      = cmc$data_channel_element =
        iou : cmt$element_name,
      = cmc$controller_element, cmc$channel_adapter_element, cmc$storage_device_element
            , cmc$external_processor_element, cmc$communications_element =
        product_id : cmt$product_identification,
        logical_unit : iot$logical_unit,
        application_info_size: integer,
        application_info_p: ^string ( * ),
        site_info_size: integer,
        site_info_p: ^string ( * ),
      CASEND,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$element_status
*copyc cmt$element_type
*copyc cmt$product_identification
*copyc iot$logical_unit
?? POP ??

*DECK DECK=CMT$STORAGE_DEVICE_CONNECTIVITY EXPAND=FALSE
 TYPE
    cmt$storage_device_connectivity = record
      port: array [cmt$data_storage_port_number] of cmt$upline_connection,
      pem: cmt$element_connection,
    recend;

*copyc cmt$data_storage_port_number
*copyc cmt$element_connection
*copyc cmt$upline_connection
*DECK DECK=CMT$STORAGE_DEVICE_DEFINITION EXPAND=FALSE
 TYPE
    cmt$storage_device_definition = record
      physical_unit_number: cmt$physical_unit_number,
      connection: cmt$storage_device_connectivity,
    recend;

*copyc cmt$physical_unit_number
*copyc cmt$storage_device_connectivity
*DECK DECK=CMT$SUBSYSTEM_COMMAND_HEAP EXPAND=FALSE

 TYPE
    cmt$subsystem_command_heap = record
      rma_list: ALIGNED [0 MOD 16384] array [1 .. *] of mmt$rma_list_entry,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc mmt$rma_list
?? POP ??
*DECK DECK=CMT$SUBSYSTEM_EQUIP_DESCRIPTION EXPAND=FALSE
  TYPE
    cmt$subsystem_equip_description = record
           pp_number: iot$pp_number,
           physical_unit: iot$physical_unit_number,
           physical_channel: iot$channel_number,
           equipment: cmt$physical_equipment_number,
           unit_type: iot$unit_type,
           controller_type: cmt$controller_type,
           logical_unit: iot$logical_unit,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$controller_type
*copyc cmt$physical_equipment_number
*copyc iot$channel_number
*copyc iot$pp_number
*copyc iot$logical_unit
*copyc iot$unit_type
?? POP ??
*DECK DECK=CMT$SUBSYSTEM_IO_REQUEST_ID EXPAND=FALSE
 TYPE
    cmt$subsystem_io_request_id = record
      system_supplied: cmt$io_completion_queue_index,
      user_supplied: cmt$user_io_identification,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$io_completion_queue_index
*copyc cmt$user_io_identification
?? POP ??
*DECK DECK=CMT$SUBSYSTEM_IO_STATUS EXPAND=FALSE
 TYPE
    cmt$subsystem_io_completion_sta = (cmc$subsystem_io_started,
      cmc$subsystem_io_completing, cmc$subsystem_io_complete,
      cmc$subsystem_io_not_active, cmc$subsystem_io_term_by_rec,
      cmc$subsystem_dummy_status_6, cmc$subsystem_dummy_status_7,
      cmc$subsystem_cleanup_req);

  TYPE
    cmt$subsystem_io_completion = record
      request_identification: cmt$subsystem_io_request_id,
      completion_status: cmt$subsystem_io_completion_sta,
    recend,
    cmt$subsystem_io_status = array [1 .. * ] of cmt$subsystem_io_completion;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$subsystem_io_request_id
?? POP ??
*DECK DECK=CMT$SUBSYS_IO_RESPONSE_AREA EXPAND=FALSE
      TYPE
        cmt$subsys_io_response_area = string(*<=256);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$scan_variable
?? POP ??
*DECK DECK=CMT$SYSTEM_ACTIVITY EXPAND=FALSE
 TYPE
    cmt$system_activity = record
      case reservable_resource: boolean of
      = TRUE =
        job_assignment: cmt$job_ownership,
        job_reservation: cmt$job_ownership,
      = FALSE =
      casend,
    recend;

*copyc cmt$job_ownership
*DECK DECK=CMT$SYSTEM_DEVICE_DATA EXPAND=FALSE

  TYPE
    cmt$system_device_data = ARRAY [cmt$system_device_types] OF cmt$system_device_data_entry,

    cmt$system_device_data_entry = RECORD
      specified: boolean,
      iou_number: dst$iou_number,
      channel_name: cmt$element_name,
      equipment_name: cmt$element_name,
      equipment_id: cmt$product_identification,
      equipment_number: 0 .. 0ffff(16),
      unit_name: cmt$element_name,
      unit_id: cmt$product_identification,
      unit_number: 0 .. 0ffff(16),
    RECEND;

*copyc cmt$element_name
*copyc cmt$product_identification
*copyc cmt$system_device_types
*copyc dst$iou_number
*DECK DECK=CMT$SYSTEM_DEVICE_PP EXPAND=FALSE

  TYPE
    cmt$system_device_pp = RECORD
      software_idle: boolean,
      primary_pp: dst$iou_resource,
      CASE dual_pp: boolean OF
      = TRUE =
        partner_pp: dst$iou_resource,
        ppit_rma: ost$real_memory_address,
      = FALSE =
      CASEND,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc dst$iou_resource
*copyc ost$hardware_subranges
?? POP ??
*DECK DECK=CMT$SYSTEM_DEVICE_TYPES EXPAND=FALSE

  TYPE
    cmt$system_device_types = (cmc$sdt_disk_device, cmc$sdt_tape_device);
*DECK DECK=CMT$UNIT_CLASS EXPAND=FALSE

{ COMMON DECK CMDUNCL }

  TYPE
    cmt$unit_class = (cmc$mass_storage_unit, cmc$magnetic_tape_unit,
      cmc$network_unit, cmc$rhfam_unit, cmc$map_unit);

*DECK DECK=CMT$UNIT_QUEUING_OPTIONS EXPAND=FALSE
 TYPE
    cmt$unit_queuing_options = (cmc$one_entry_per_queue,
      cmc$first_in_first_out_queue, cmc$first_in_last_out_queue,
      cmc$queue_option_4, cmc$queue_option_5, cmc$queue_option_6,
      cmc$queue_option_7, cmc$queue_option_8);
*DECK DECK=CMT$UNIT_TYPE EXPAND=FALSE


  TYPE
    cmt$unit_type = (cmc$foreign_unit,cmc$mt679_5, cmc$mt679_6, cmc$mt679_7, cmc$mt679_2,
      cmc$mt679_3, cmc$mt679_4, cmc$mt677_2, cmc$mt677_3, cmc$mt677_4, cmc$mt667_2,
      cmc$mt667_3, cmc$mt667_4, cmc$mt669_2, cmc$mt669_3, cmc$mt669_4, cmc$mt698_3x,
      cmc$mt639_s0, cmc$mt639_1, cmc$mt5682_1x, cmc$map_1, cmc$map_cmi_1, cmc$ms844_4x, cmc$ms885_1x,
      cmc$ms885_4x,cmc$msfsd2_s0, cmc$ms834_2, cmc$msfsd_2, cmc$mshydra, cmc$ms895_2, cmc$msxmd_3,
      cmc$ms5832_1, cmc$ms5832_2, cmc$ms5833_1, cmc$ms5833_1p, cmc$ms5833_2, cmc$ms5833_3p, cmc$ms5833_4,
      cmc$ms5838_1, cmc$ms5838_1p, cmc$ms5838_2, cmc$ms5838_3p, cmc$ms5838_4,
      cmc$ms47444_1, cmc$ms47444_1p, cmc$ms47444_2, cmc$ms47444_3p, cmc$ms47444_4);
*DECK DECK=CMT$UPLINE_CONNECTION EXPAND=FALSE

  TYPE
    cmt$upline_connection = record
      case configured: boolean of
      = TRUE =
        { The following table identifies the meaning of "element_name"
        { for each upline element type.

        { Type of upline element:               Element_name identifies:
        {---------------------------------------------------------------
        {cmc$central_memory_element             owning mainframe name
        {cmc$channel_adapter_element            channel adapter element name
        {cmc$communications_element             communications element name
        {cmc$controller_element                 controller element name
        {cmc$data_channel_element               channel

        element_name: cmt$element_name,

        case upline_connection_type: cmt$element_type of
        = cmc$central_memory_element =
          memory_port: cmt$central_memory_port_number,
        = cmc$data_channel_element =
          mainframe_ownership: cmt$element_name,
          iou: cmt$element_name,
        = cmc$channel_adapter_element, cmc$communications_element,
              cmc$controller_element =
          ,
        casend,
      = FALSE =
        ,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$central_memory_port_number
*copyc cmt$element_name
*copyc cmt$element_type
?? POP ??

*DECK DECK=CMT$USAGE_SELECTIONS EXPAND=FALSE


  TYPE
    { Usage sanctions may be used to prevent certain kinds of logical or
    {physical}
    { operations on a logical unit.}
    {}
    { Inhibit_logical_mount prevents label-searching of the medium mounted on}
    { the unit. This allows the operator to 'idle' a unit. By itself, this}
    { sanction does not prevent physical i/o operations, other than}
    { label-searching. Thus, when all jobs previously using the medium have}
    { stopped doing so, the medium is in a state where it may be logically}
    { dismounted.}
    {}
    { Inhibit_read_request and/or inhibit_write_request may be used to prevent}
    { physical i/o requests submitted on behalf of a program. These sanctions}
    { do not prevent low-level NOSVE physical i/o requests performed for such}
    { reasons as label-searching or volume-initialization. Both the read and}
    { write sanctions would be set if a unit which had been logically mounted}
    { incurred a ready/not-ready state change. These sanctions would prevent}
    { program access to the unit until NOSVE is certain that the correct}
    { volume is mounted. A use of this feature which is appropriate to a tape}
    { unit is to make it a read-only unit. A site could also designate}
    { certain units to be a read-only source of permanent files.}
    {}
    cmt$usage_sanctions = set of cmt$device_usage_sanctions,

    cmt$device_usage_sanctions = (cmc$inhibit_logical_mount,
      cmc$inhibit_read_request, cmc$inhibit_write_request);
*DECK DECK=CMT$USER_IO_IDENTIFICATION EXPAND=FALSE
 TYPE
    cmt$user_io_identification = integer;
*DECK DECK=CMV$ACQUIRE_PP_FOR_REDUNDANT_CH EXPAND=FALSE
  VAR
    cmv$acquire_pp_for_redundant_ch: [XREF] boolean;
*DECK DECK=CMV$ALTERNATE_IOU_PROGRAM_NAME EXPAND=FALSE
*DECK DECK=CMV$ASSIGNABLE_DEVICE EXPAND=FALSE

{ COMMON DECK CMXADEV }

  VAR
    cmv$assignable_device: [XREF] set of cmt$unit_type;

?? PUSH (LISTEXT := ON) ??
*copyc CMT$UNIT_TYPE
?? POP ??
*DECK DECK=CMV$COMMAND_DESCRIPTOR_P EXPAND=FALSE
  VAR
    cmv$command_descriptor_p: [XREF] ^cmt$pcu_command_descriptor;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pcu_command_descriptor
?? POP ??
*DECK DECK=CMV$CONFIGURATION_ACTIVATED EXPAND=FALSE

   VAR
     cmv$configuration_activated: [XREF] boolean;
*DECK DECK=CMV$CONFIGURATION_ADMINISTRATOR EXPAND=FALSE

  VAR
    cmv$configuration_administrator: [XREF] cmt$lcu_lock;

?? PUSH (LISTEXT :+ ON) ??
*copyc cmt$lcu_lock
?? POP ??

*DECK DECK=CMV$CONTROLLER_ADDRESS EXPAND=FALSE
  VAR
    cmv$controller_address: [XREF] cmt$physical_address_specifier;

*copyc cmt$physical_address_specifier
*DECK DECK=CMV$CONTROLLER_DATA EXPAND=FALSE

{ COMMON DECK CMXCNTD }

  VAR
    cmv$controller_data_ptr: [XREF] ^array [1 .. * ] of cmt$controller_id;

?? PUSH (LISTEXT := ON) ??
*copyc CMT$CONTROLLER_ID
?? POP ??
*DECK DECK=CMV$CONTROLLER_LOCATION EXPAND=FALSE

  VAR
    cmv$controller_location: [XREF] cmt$controller_location;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$controller_location
?? POP ??
*DECK DECK=CMV$DATA_CHANNEL_ADDRESS EXPAND=FALSE
  VAR
    cmv$data_channel_address: [XREF] cmt$physical_address_specifier;

*copyc cmt$physical_address_specifier
*DECK DECK=CMV$DEADSTART_LCU_TASKID EXPAND=FALSE
*DECK DECK=CMV$DEADSTART_SIGNALS EXPAND=FALSE
  VAR
    cmv$deadstart_signals: [XREF] ^cmt$deadstart_signal;

*copyc cmt$deadstart_signal
*DECK DECK=CMV$DEFAULT_IOCT_ENTRY EXPAND=FALSE


      VAR
        iov$default_ioct_entry: [XREF, oss$job_paged_literal] iot$io_completion_table_entry;

??PUSH (LISTEXT := ON) ??
*copyc iot$io_completion_table
*copyc oss$job_paged_literal
??POP??
*DECK DECK=CMV$DEFAULT_PP_NAMES EXPAND=FALSE

    VAR
      cmv$default_pp_names : [XREF] array [cmt$pp_ordinal] OF
            cmt$element_name;

?? PUSH(LISTEXT := ON) ??
*copyc cmt$pp_ordinal
*copyc cmt$element_name
?? POP ??
*DECK DECK=CMV$DEFAULT_RESPONSE_HANDLER EXPAND=FALSE

  VAR
    cmv$default_response_handler: [XREF] iot$response_processor;

?? PUSH (LISTEXT := ON) ??
*copyc iot$io_request
?? POP ??
*DECK DECK=CMV$DFS_CONVERSION EXPAND=FALSE

{ COMMON DECK CMXDFSC }

  VAR
    cmv$dfs_conversion: [XREF] array [cmt$device_file_status] of string (9);

?? PUSH (LISTEXT := ON) ??
*copyc CMT$DEVICE_FILE_TABLE
?? POP ??
*DECK DECK=CMV$DFT_CONVERSION EXPAND=FALSE

{ COMMON DECK CMXDFTC }

  VAR
    cmv$dft_conversion: [XREF] array [cmt$device_file_type] of string (8);

?? PUSH (LISTEXT := ON) ??
*copyc CMT$DEVICE_FILE_TABLE
?? POP ??
*DECK DECK=CMV$DRIVER_NAME EXPAND=FALSE

{ COMMON DECK CMXDRMA }

  VAR
    cmv$driver_rma: [XREF] integer;

*DECK DECK=CMV$DRIVER_RMA EXPAND=FALSE

{ COMMON DECK CMXDRMA }

  VAR
    cmv$driver_rma: [XREF] integer;

*DECK DECK=CMV$ELEMENT_RESERVATION_LOCK EXPAND=FALSE





  VAR
    cmv$element_reservation_lock:  [XREF, oss$mainframe_pageable] ost$signature_lock;

?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_pageable
*copyc ost$signature_lock
?? POP ??
*DECK DECK=CMV$ENABLE_AUTO_RECONFIGURATION EXPAND=FALSE
  VAR
    cmv$enable_auto_reconfiguration: [XREF] boolean;
*DECK DECK=CMV$ENABLE_HEAD_SHIFT_MESSAGE EXPAND=TRUE
  VAR
    cmv$enable_head_shift_message: [XREF] boolean;
*DECK DECK=CMV$ERROR_COUNT EXPAND=FALSE
  VAR
    cmv$error_count : [XREF] integer;
*DECK DECK=CMV$EXECUTING_WITHIN_EDITOR EXPAND=FALSE

   VAR
     cmv$executing_within_editor : [XREF] boolean;
*DECK DECK=CMV$HYDRA_MASS_STORAGE_ADDRESS EXPAND=FALSE
  VAR
    cmv$hydra_mass_storage_address: [XREF] cmt$physical_address_specifier;

*copyc cmt$physical_address_specifier
*DECK DECK=CMV$INSTALLED_MAINFRAME EXPAND=FALSE

  VAR
    cmv$installed_mainframe : [XREF] cmt$element_name;

?? PUSH(LISTEXT :=ON) ??
*copyc cmt$element_name
?? POP ??
*DECK DECK=CMV$IN_EDITOR EXPAND=FALSE

  VAR
    cmv$in_editor: [XREF] boolean;
*DECK DECK=CMV$IOU_PROGRAM_NAME EXPAND=FALSE
*DECK DECK=CMV$IOU_TABLE_P EXPAND=FALSE

  VAR
    cmv$iou_table_p : [XREF] ^ARRAY [ * ] OF cmt$iou_table;

?? PUSH(LISTEXT := ON) ??
*copyc cmt$iou_table
?? POP ??
*DECK DECK=CMV$IO_COMPLETION_TABLE EXPAND=FALSE


      VAR
        cmv$io_completion_table_p: [XREF] ^cmt$io_completion_table;

??PUSH (LISTEXT := ON)??
*copyc iot$io_completion_table
??POP??

*DECK DECK=CMV$LCU_COMMAND_LIST EXPAND=FALSE

  VAR
    cmv$lcu_command_list: [XREF] ^clt$command_table;

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_table
?? POP ??
*DECK DECK=CMV$LCU_FUNCTION_LIST EXPAND=FALSE

  VAR
    cmv$lcu_function_list: [XREF] ^clt$function_processor_table;

?? PUSH (LISTEXT := ON) ??
*copyc clt$function_processor_table
?? POP ??
*DECK DECK=CMV$LOGICAL_PP_TABLE EXPAND=FALSE
*DECK DECK=CMV$LOGICAL_PP_TABLE_LOCK EXPAND=FALSE

  VAR
    cmv$logical_pp_table_lock: [XREF, oss$mainframe_pageable] ost$signature_lock;

?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_pageable
*copyc ost$signature_lock
?? POP ??

*DECK DECK=CMV$LOGICAL_PP_TABLE_P EXPAND=FALSE

  VAR
    cmv$logical_pp_table_p: [XREF] ^cmt$logical_pp_table;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$logical_pp_table
?? POP ??
*DECK DECK=CMV$LOGICAL_UNIT_LOCK EXPAND=FALSE

  VAR
    cmv$logical_unit_lock: [XREF, oss$mainframe_pageable] ost$signature_lock;

?? PUSH (LISTEXT := ON) ??
*copyc OSS$MAINFRAME_PAGEABLE
*copyc ost$signature_lock
?? POP ??

*DECK DECK=CMV$LOGICAL_UNIT_TABLE EXPAND=FALSE

{ COMMON DECK CMXLUT }

  VAR
    cmv$logical_unit_table: [XREF] ^cmt$logical_unit_table;

?? PUSH (LISTEXT := ON) ??
*copyc CMT$LOGICAL_UNIT_TABLE
?? POP ??
*DECK DECK=CMV$MASS_STORAGE_ADDRESS EXPAND=FALSE
  VAR
    cmv$mass_storage_address: [XREF] cmt$physical_address_specifier;

*copyc cmt$physical_address_specifier
*DECK DECK=CMV$MAX_NUMBER_OF_PP EXPAND=FALSE

  VAR
    cmv$max_number_of_pp: [XREF] iot$pp_number;

?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
?? POP ??
*DECK DECK=CMV$NAMVE_LOGICAL_PP_TABLE EXPAND=FALSE
{ deck deleted by mxn_99 }
*DECK DECK=CMV$NAMVE_LOGICAL_UNIT_TABLE EXPAND=FALSE
{   deck deleted by mxn_99 }
*DECK DECK=CMV$NETWORK_DESCRIPTOR_P EXPAND=FALSE

  VAR
    cmv$network_descriptor_p : [XREF] ^nat$network_descriptor;

?? PUSH (LISTEXT := ON) ??
*copyc NAT$NETWORK_DESCRIPTOR
?? POP ??
*DECK DECK=CMV$NEW_DEVICE_FILE EXPAND=FALSE

   VAR
     cmv$new_device_file :[XREF] cmt$device_file_record;

?? PUSH(LISTEXT := ON) ??
*copyc cmt$device_file_table
?? POP ??
*DECK DECK=CMV$NEW_LOGICAL_PP_TABLE EXPAND=FALSE
*DECK DECK=CMV$NEW_LOGICAL_PP_TABLE_P EXPAND=FALSE

  VAR
    cmv$new_logical_pp_table_p: [XREF] ^cmt$logical_pp_table;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$logical_pp_table
?? POP ??
*DECK DECK=CMV$NEW_LOGICAL_UNIT_TABLE EXPAND=FALSE

{ COMMON DECK CMXNLUT }

  VAR
    cmv$new_logical_unit_table: [XREF] ^cmt$logical_unit_table;

?? PUSH (LISTEXT := ON) ??
*copyc CMT$LOGICAL_UNIT_TABLE
?? POP ??
*DECK DECK=CMV$NEW_PP_ELEMENT_TABLE EXPAND=FALSE
*DECK DECK=CMV$PCU_ERROR_COUNT EXPAND=FALSE

  VAR
    cmv$pcu_error_count: [XREF] integer;

*DECK DECK=CMV$PERIPHERAL_ELEMENT_TABLE EXPAND=FALSE

  VAR
    cmv$peripheral_element_table: [XREF] cmt$peripheral_element_table;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$peripheral_element_table
?? POP ??
*DECK DECK=CMV$PHYSICAL_CONFIGURATION EXPAND=FALSE

{ COMMON DECK CMXPCT }

  VAR
    cmv$physical_configuration: [XREF] cmt$physical_configuration;

?? PUSH (LISTEXT := ON) ??
*copyc CMT$PHYSICAL_CONFIGURATION
?? POP ??
*DECK DECK=CMV$POST_DEADSTART EXPAND=FALSE

  VAR
    cmv$post_deadstart: [XREF] boolean;
*DECK DECK=CMV$PP_CONTROLLER_LOADED EXPAND=FALSE
*DECK DECK=CMV$PP_CONVERSION EXPAND=FALSE
{ XREF DECK CMV$PP_CONVERSION }

{  This variable allows the user to convert a physical pp number
{  into an equivalent pp number of type cmt$pp_ordinal.

  VAR
    cmv$pp_conversion: [XREF] array [0 .. 29] of
      cmt$pp_ordinal;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pp_ordinal
?? POP ??
*DECK DECK=CMV$PP_ELEMENT_TABLE EXPAND=FALSE
*DECK DECK=CMV$PP_MAP EXPAND=FALSE
*DECK DECK=CMV$PRODUCT_ID_STRING EXPAND=FALSE

{ COMMON DECK CMXPIDS }

  VAR
    cmv$product_id_ptr: [XREF] ^array [1 .. * ] of cmt$device_id;

?? PUSH (LISTEXT := ON) ??
*copyc CMT$DEVICE_ID
?? POP ??
*DECK DECK=CMV$REMOVABLE_MEDIA_OPERATION EXPAND=FALSE

  VAR
    cmv$removable_media_operation: [XREF] cmt$lcu_lock;

?? PUSH (LISTEXT :+ ON) ??
*copyc cmt$lcu_lock
?? POP ??
*DECK DECK=CMV$RESERVED_NAMES_LIST EXPAND=FALSE

  TYPE
    cmt$reserved_names_list = array [1 .. *] of ost$name;

  VAR
    cmv$reserved_names_list: [STATIC, READ,oss$job_paged_literal] ^cmt$reserved_names_list :=
        ^reserved_names_list,
    reserved_names_list : [STATIC, READ, oss$job_paged_literal] array [1 .. 10] of ost$name := [
      '$CENTRAL_MEMORY', '$CENTRAL_PROCESSOR', '$CHANNEL', '$CHANNEL_ADAPTER', '$CONTROLLER',
      '$STORAGE_DEVICE', '$INPUT_OUTPUT_UNIT', '$MAINFRAME',
      '$PERIPHERAL_PROCESSOR', 'ALL'];

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=CMV$SAVE_CONTROLLER_LOADED EXPAND=TRUE
*DECK DECK=CMV$SAVE_LPPT EXPAND=FALSE
*DECK DECK=CMV$SAVE_LUT EXPAND=FALSE
*DECK DECK=CMV$SAVE_PCT_P EXPAND=FALSE

  VAR
    cmv$save_pct_p: [XREF] cmt$physical_configuration;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$physical_configuration
?? POP ??
*DECK DECK=CMV$SAVE_STATE_TABLE_P EXPAND=FALSE

  VAR
    cmv$save_state_table_p: [XREF] ^ARRAY [1 .. *] OF cmt$state_information;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$state_information
?? POP ??
*DECK DECK=CMV$SCI_DFT_PP EXPAND=FALSE

  VAR
    cmv$sci_dft_pp : [XREF] cmt$sci_dft_pp;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$sci_dft_pp
?? POP ??
*DECK DECK=CMV$SIGNAL_HANDLER_ACTIVE EXPAND=FALSE

  VAR
    cmv$signal_handler_active: [XREF] boolean;
*DECK DECK=CMV$STATE_INFO_DF_TABLE EXPAND=FALSE
*DECK DECK=CMV$STATE_INFO_TABLE EXPAND=FALSE

  VAR
    cmv$state_info_table : [XREF]  ^array [1 ..  * ] of cmt$state_information;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$state_information
?? POP ??
*DECK DECK=CMV$SUBSYS_IO_RESPONSES EXPAND=FALSE

      VAR
        cmv$subsys_io_responses_p: [XREF, oss$job_fixed] ^cmt$subsys_io_response_area;
?? PUSH (LISTEXT := ON) ??
*copyc cmt$subsys_io_response_area
*copyc oss$job_fixed
?? POP ??
*DECK DECK=CMV$SUBSYS_IO_SCAN_CHARACTER EXPAND=FALSE

     VAR
       cmv$subsys_io_scan_character: [XREF, STATIC, READ, oss$mainframe_wired_literal] char;
?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_wired_literal
?? POP ??
*DECK DECK=CMV$SUBSYS_IO_SCAN_VARIABLE EXPAND=FALSE

      VAR
        cmv$subsys_io_scan_variable: [XREF, oss$job_fixed] cmt$scan_variable;
?? PUSH (LISTEXT := ON) ??
*copyc oss$job_fixed
*copyc cmt$scan_variable
?? POP ??
*DECK DECK=CMV$SYSTEM_DEVICE_DATA EXPAND=FALSE

  VAR
    cmv$system_device_data: [XREF] cmt$system_device_data;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$system_device_data
?? POP ??
*DECK DECK=CMV$SYSTEM_DEVICE_PP EXPAND=FALSE

  VAR
    cmv$system_device_pp: [XREF] cmt$system_device_pp;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$system_device_pp
?? POP ??
*DECK DECK=COMMCVS EXPAND=FALSE
          CTEXT  COMMCVS - VIRTUAL SYSTEM INTERFACE MACROS.
COMMCVS   SPACE  4
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
COMMCVS   SPACE  4
***       COMMCVS - VIRTUAL SYSTEM INTERFACE MACROS.
*         D. A. HENSELER. 79/04/25.
COMMCVS   SPACE  4
***       COMMCVS CONTAINS MACROS THAT INTERFACE TO THE NOS/VE
*         SIDE OF A DUAL STATE CYBER 180 SYSTEM FROM THE CYBER 170 SIDE.
*         COMMON DECK COMSCVS CONTAINS THE SYMBOL EQUIVALENCES REQUIRED
*         BY THESE MACROS.
CALLVS    SPACE  4
***       CALLVS - CALL VIRTUAL STATE.
*
*         CALLVS XJ,XK,FUNC,CONST
*
*         ENTRY  XJ = FIRST X REGISTER DESIGNATOR (OPTIONAL).
*                XK = SECOND X REGISTER DESIGNATOR (OPTIONAL).
*                FUNC = 15 BIT FUNCTION CODE (REQUIRED).
*                CONST = 30 BIT CONSTANT (OPTIONAL).
*
*         EXIT   CALLVS (017B) INSTRUCTION EXECUTED.
          SPACE  2
          PURGMAC CALLVS
          SPACE  2
CALLVS    MACRO  P1,P2,P3,P4
          LOCAL  XJ,XK,FUNC,CONST,FN
A         IF     REG,P1
XJ        SET    -1
          ECHO   ,R=(X0,X1,X2,X3,X4,X5,X6,X7),V=(0,1,2,3,4,5,6,7)
B         IFC    EQ,$P1$R$
          STOPDUP
XJ        SET    V
B         ENDIF
          ENDD
C         IFEQ   XJ,-1
          ERR    P1 MUST BE AN X REGISTER.
XJ        SET    0
C         ENDIF
D         IF     REG,P2
XK        SET    -1
          ECHO   ,R=(X0,X1,X2,X3,X4,X5,X6,X7),V=(0,1,2,3,4,5,6,7)
B         IFC    EQ,$P2$R$
          STOPDUP
XK        SET    V
B         ENDIF
          ENDD
C         IFEQ   XK,-1
          ERR    P2 MUST BE AN X REGISTER.
XK        SET    0
C         ENDIF
FUNC      SET    P3
FN        MICRO  1,,*P3*
CONST     MICRO  1,,*P4*
D         ELSE
XK        SET    0
FUNC      SET    P2
FN        MICRO  1,,*P2*
CONST     MICRO  1,,*P3*
D         ENDIF
A         ELSE
XJ        SET    0
XK        SET    0
FUNC      SET    P1
FN        MICRO  1,,*P1*
CONST     MICRO  1,,*P2*
A         ENDIF
          IFC    EQ,$"FN"$$
          ERR    FUNCTION PARAMETER MUST BE SPECIFIED.
          ENDIF
C170      IF     -DEF,MLIC170
+         VFD    9/017B,3/XJ,3/XK,15/FUNC,30/"CONST"
C170      ELSE
          RJ     PRT
C170      ENDIF
CALLVS    ENDM
          SPACE  2
          ENDX
*DECK DECK=COMMMLI EXPAND=FALSE
          CTEXT  COMMMLI - MEMORY LINK INTERFACE MACROS.
COMMMLI   SPACE  4
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
COMMMLI   SPACE  4
***       COMMMLI - MEMORY LINK INTERFACE MACROS.
*         D. A. HENSELER. 79/04/25.
COMMMLI   SPACE  4
***       COMMMLI CONTAINS MACROS THAT INTERFACE TO THE NOS/VE
*         MEMORY LINK INTERFACE.
*         COMMON DECK COMSMLI CONTAINS THE SYMBOL EQUIVALENCES REQUIRED
*         BY THESE MACROS.COMMON DECK COMCMLI CONTAINS THE ROUTINE MLI=.
          SPACE  3
***       TRANSFR - TRANSFER PARAMETER BLOCK WORD TO ADDRESS SPECIFIED
*                   IN OTHER WORD. (A.J.GEERSEN JUNE 84)
          SPACE  1
          PURGMAC TRANSFR
          SPACE  1
TRANSFR   MACRO  P1,P2
          SA1    =XMLIPAR+P1
          SA2    =XMLIPAR+P2
          BX6    X1
          SA6    X2
          ENDM
ADDSPL    SPACE  4
***       ADDSPL - ADD SENDER TO PERMIT LIST.
*
*         ADDSPL ANAME,SNAME,STATUS
*
*         ENTRY  ANAME = ADDRESS OF APPLICATION NAME DOING THE ADDSPL
*                        REQUEST.
*                SNAME = ADDRESS OF NAME OF THE APPLICATION BEING ADDED
*                        TO THE PERMIT LIST.
*                STATUS = ADDRESS OF STATUS RETURN WORD.
*
*         EXIT   SENDER ADDED TO PERMIT LIST IF POSSIBLE.
*                STATUS PARAMETER CONTAINS A STATUS CODE.
*
*         CALLS  MLI=
*
*         USES   X - 1, 6.
*                B - NONE.
*                A - 1, 6.
          SPACE  2
          PURGMAC ADDSPL
          SPACE  2
ADDSPL    MACRO  ANAME,SNAME,STATUS
          PPARMM ANAME,MLPAN
          PPARMM SNAME,MLPSN
          PPARMD STATUS,MLPST
          PPARMD MLFAD,MLPFN
          RJ     =XMLI=
          TRANSFR MLPSV,MLPST
ADDSPL    ENDM
CONFIRM   SPACE  4
***       CONFIRM - CONFIRM A MESSAGE CAN BE SENT TO AN APPLICATION.
*
*         CONFIRM ANAME,DNAME,STATUS
*
*         ENTRY  ANAME = ADDRESS OF APPLICATION NAME DOING THE CONFIRM
*                        REQUEST.
*                DNAME = ADDRESS OF THE APPLICATION NAME TO BE CHECKED
*                        FOR SEND PERMISSION.
*                STATUS = ADDRESS OF THE STATUS RETURN WORD.
*
*         EXIT   STATUS RETURN INDICATES WHETHER OR NOT THE SEND WILL
*                BE ALLOWED.
*
*         CALLS  MLI=
*
*         USES   X - 1, 6.
*                B - NONE.
*                A - 1, 6.
          SPACE  2
          PURGMAC CONFIRM
          SPACE  2
CONFIRM   MACRO  ANAME,DNAME,STATUS
          PPARMM ANAME,MLPAN
          PPARMM DNAME,MLPSN
          PPARMD STATUS,MLPST
          PPARMD MLFCO,MLPFN
          RJ     =XMLI=
          TRANSFR MLPSV,MLPST
CONFIRM   ENDM
DELSPL    SPACE  4
***       DELSPL - DELETE SENDER FROM PERMIT LIST.
*
*         DELSPL ANAME,SNAME,STATUS
*
*         ENTRY  ANAME = ADDRESS OF APPLICATION NAME DOING THE
*                        DELSPL REQUEST.
*                SNAME = ADDRESS OF APPLICATION NAME TO BE DELETED FROM
*                        THE PERMIT LIST.
*                STATUS = ADDRESS OF STATUS RETURN WORD.
*
*         EXIT   SENDER DELETED FROM PERMIT LIST IF POSSIBLE.
*                STATUS PARAMETER CONTAINS A STATUS CODE.
*
*         CALLS  MLI=
*
*         USES   X - 1, 6.
*                B - NONE.
*                A - 1, 6.
          SPACE  2
          PURGMAC DELSPL
          SPACE  2
DELSPL    MACRO  ANAME,SNAME,STATUS
          PPARMM ANAME,MLPAN
          PPARMM SNAME,MLPSN
          PPARMD STATUS,MLPST
          PPARMD MLFDE,MLPFN
          RJ     =XMLI=
          TRANSFR MLPSV,MLPST
DELSPL    ENDM
FETCHRL   SPACE  4
***       FETCHRL - FETCH RECEIVE LIST FOR SPECIFIC/ALL SENDER(S).
*
*         FETCHRL ANAME,SNAME,FWA,COUNT,STATUS
*
*         ENTRY  ANAME = ADDRESS OF THE APPLICATION NAME PERFORMING THE
*                        FETCHRL REQUEST.
*                SNAME = ADDR. OF APPLICATION NAME FOR WHICH TO RETURN
*                        INFORMATION (IF ZERO RETURN FOR ALL SENDERS).
*                COUNT = ADDRESS OF A WORD IN WHICH TO RETURN THE COUNT
*                        OF RECEIVE LIST ITEMS RETURNED.
*                FWA = ADDRESS OF THE AREA TO RECEIVE THE INFORMATION.
*                STATUS = ADDRESS OF THE STATUS RETURN WORD.
*
*         EXIT   RECEIVE LIST RETURNED IF POSSIBLE.
*                STATUS PARAMETER CONTAINS A STATUS CODE.
*
*         CALLS  MLI=
*
*         USES   X - 1, 6.
*                B - NONE.
*                A - 1, 6.
          SPACE  2
          PURGMAC FETCHRL
          SPACE  2
FETCHRL   MACRO  ANAME,SNAME,FWA,COUNT,STATUS
          PPARMM ANAME,MLPAN
          PPARMM SNAME,MLPSN
          PPARMD COUNT,MLPCN
          PPARMD FWA,MLPFA
          PPARMD STATUS,MLPST
          PPARMD MLFFE,MLPFN
          SA1    =XMLIPAR+MLPCN
          SA1    X1
          BX6    X1
          SA6    =XMLIPAR+MLPV1
          RJ     =XMLI=
          TRANSFR MLPSV,MLPST
          TRANSFR MLPV1,MLPCN
FETCHRL   ENDM
PPARMD    SPACE  4
***       PPARMD - PROCESS PARAMETER FOR MLI MACROS (DIRECT)
*
*         PPARMD P,OFFSET
*
*         ENTRY  P = NAME OF PARAMETER.
*                IF P IS OMITTED, ZERO IS ASSUMED.
*                OFFSET = OFFSET WITHIN MLIPAR IN WHICH TO STORE VALUE.
*
*         EXIT   VALUE STORED AT =XMLIPAR + OFFSET.
*                (USED WHEN P IS THE ACTUAL VALUE TO BE USED.)
*
*         USES   X - 6.
*                B - NONE.
*                A - 6.
          SPACE  2
          PURGMAC PPARMD
          SPACE  2
PPARMD    MACRO  P,OFFSET
A         IFC    EQ,$P$$
          MX6    0
A         ELSE
          R=     X6,P
A         ENDIF
          SA6    =XMLIPAR+OFFSET
PPARMD    ENDM
PPARMM    SPACE  4
***       PPARMM - PROCESS PARAMETER FOR MLI MACROS (FROM MEMORY)
*
*         PPARMM P,OFFSET
*
*         ENTRY  P = NAME OF PARAMETER.
*                IF P IS OMITTED, ZERO IS ASSUMED.
*                OFFSET = OFFSET WITHIN MLIPAR IN WHICH TO STORE VALUE.
*
*         EXIT   VALUE CONTIANED IN MEMORY ADDRESS P IS MOVED TO
*                =XMLIPAR + OFFSET. (USED WHEN P IS THE ADDRESS OF THE
*                DESIRED VALUE).
*
*         USES   X - 1, 6.
*                B - NONE.
*                A - 1, 6.
          SPACE  2
          PURGMAC PPARMM
          SPACE  2
PPARMM    MACRO  P,OFFSET
A         IFC    EQ,$P$$
          MX6    0
A         ELSE
          SA1    P
          BX6    X1
A         ENDIF
          SA6    =XMLIPAR+OFFSET
PPARMM    ENDM
RECEIVE   SPACE  4
***       RECEIVE - RECEIVE SPECIFIC QUEUED MESSAGE.
*
*    RECEIVE ANAME,ARBINFO,SIGNAL,FWA,MSGLEN,BUFLEN,RINDEX,SENDER,STATUS
*
*         ENTRY  ANAME = ADDRESS OF THE APPLICATION NAME PERFORMING
*                        THE REQUEST.
*                ARBINFO = ADDRESS TO RECEIVE THE ARBITRARY INFO FIELD
*                          OF THE MESSAGE.
*                SIGNAL = ADDRESS OF MLT$SIGNAL_RECORD,OR NIL (377777B).
*                FWA = ADDRESS OF THE FIRST WORD OF THE BUFFER TO
*                      RECEIVE THE MESSAGE.
*                MSGLEN = ADDRESS OF A WORD TO RECEIVE THE LENGTH OF THE
*                         MESSAGE WHICH WAS TRANSFERRED.
*                BUFLEN = ADDRESS OF THE LENGTH OF THE MESSAGE BUFFER.
*                RINDEX = ADDRESS OF RECEIVE INDEX OF DESIRED MESSAGE.
*                SENDER = ADDRESS OF A WORD TO RECEIVE THE APPLICATION
*                         NAME OF THE SENDER OF THE MESSAGE.
*                STATUS = ADDRESS OF THE STATUS RETURN WORD.
*
*         EXIT   MESSAGE MOVED TO BUFFER IF POSSIBLE.
*                STATUS PARAMETER CONTAINS A STATUS CODE.
*
*         CALLS  MLI=
*
*         USES   X - 1, 6.
*                B - NONE.
*                A - 1, 6.
          SPACE  2
          PURGMAC RECEIVE
          SPACE  2
RECEIVE   MACRO  ANAME,ARBINFO,SIGNAL,FWA,MSGLEN,BUFLEN,RINDEX,SENDER,ST
,ATUS
          LOCAL  NOSIG
          PPARMM ANAME,MLPAN
          PPARMM RINDEX,MLPRI
          PPARMD FWA,MLPFA
          PPARMM BUFLEN,MLPBL
A         IFC    EQ,$SIGNAL$$
          SX6    377777B
A         ELSE
          R=     X6,SIGNAL
A         ENDIF
          SA6    =XMLIPAR+MLPSG
          SX1    377777B
          BX1    X1-X6
          ZR     X1,NOSIG
          SA1    SIGNAL
          BX6    X1
          SA6    =XMLIPAR+MLPSV
NOSIG     BSS    0
          PPARMD MSGLEN,MLPLN
          PPARMD ARBINFO,MLPAR
          PPARMD SENDER,MLPSN
          PPARMD STATUS,MLPST
          PPARMD MLFRE,MLPFN
          SA1    =XMLIPAR+MLPLN
          SA1    X1
          BX6    X1
          SA6    =XMLIPAR+MLPV1
          SA1    =XMLIPAR+MLPAR
          SA1    X1
          BX6    X1
          SA6    =XMLIPAR+MLPV2
          SA1    =XMLIPAR+MLPSN
          SA1    X1
          BX6    X1
          SA6    =XMLIPAR+MLPV3
          RJ     =XMLI=
          TRANSFR MLPSV,MLPST
          TRANSFR MLPV1,MLPLN
          TRANSFR MLPV2,MLPAR
          TRANSFR MLPV3,MLPSN
RECEIVE   ENDM
SEND      SPACE  4
***       SEND - SEND TO MESSAGE TO ANOTHER MLI APPLICATION.
*
*         SEND   ANAME,ARBINFO,SIGNAL,FWA,BUFLEN,DNAME,STATUS
*
*         ENTRY  ANAME = ADDRESS OF APPLICATION NAME PERFORMING THE SEND
*                        REQUEST.
*                ARBINFO = ADDRESS OF THE ARBITRARY INFO TO BE PASSED
*                          WITH THE MESSAGE.
*                SIGNAL = ADDRESS OF MLT$SIGNAL_RECORD OR NIL (377777B).
*                FWA = ADDRESS OF THE FIRST WORD OF THE MESSAGE TEXT.
*                BUFLEN = ADDRESS OF THE LENGTH OF THE MESSAGE BUFFER.
*                DNAME = ADDRESS OF APPLICATION NAME TO WHICH THE
*                        MESSAGE IS TO BE SENT.
*                STATUS = ADDRESS OF THE STATUS RETURN WORD.
*
*         EXIT   MESSAGE SENT IF POSSIBLE.
*                STATUS PARAMETER CONTAINS A STATUS CODE.
*
*         CALLS  MLI=
*
*         USES   X - 1, 6.
*                B - NONE.
*                A - 1, 6.
          SPACE  2
          PURGMAC SEND
          SPACE  2
SEND      MACRO  ANAME,ARBINFO,SIGNAL,FWA,BUFLEN,DNAME,STATUS
          LOCAL  NOSIG
          PPARMM ANAME,MLPAN
          PPARMM DNAME,MLPSN
          PPARMM ARBINFO,MLPAR
          PPARMD FWA,MLPFA
          PPARMM BUFLEN,MLPBL
A         IFC    EQ,$SIGNAL$$
          SX6    377777B
A         ELSE
          R=     X6,SIGNAL
A         ENDIF
          SA6    =XMLIPAR+MLPSG
          SX1    377777B
          BX1    X1-X6
          ZR     X1,NOSIG
          SA1    SIGNAL
          BX6    X1
          SA6    =XMLIPAR+MLPSV
NOSIG     BSS    0
          PPARMD STATUS,MLPST
          PPARMD MLFSE,MLPFN
          RJ     =XMLI=
          TRANSFR MLPSV,MLPST
SEND      ENDM
SIGNOFF   SPACE  4
***       SIGNOFF - SIGN OFF FROM MEMORY LINK INTERFACE.
*
*         SIGNOFF ANAME,STATUS
*
*         ENTRY  ANAME = ADDRESS OF APPLICATION NAME BEING SIGNED OFF.
*                STATUS = ADDRESS OF STATUS RETURN WORD.
*
*         EXIT   APPLICATION SIGNED OFF IF POSSIBLE.
*                STATUS PARAMETER CONTAINS A STATUS CODE.
*
*         CALLS  MLI=
*
*         USES   X - 1, 6.
*                B - NONE.
*                A - 1, 6.
          SPACE  2
          PURGMAC SIGNOFF
          SPACE  2
SIGNOFF   MACRO  ANAME,STATUS
          PPARMM ANAME,MLPAN
          PPARMD STATUS,MLPST
          PPARMD MLFOF,MLPFN
          RJ     =XMLI=
          TRANSFR MLPSV,MLPST
SIGNOFF   ENDM
SIGNON    SPACE  4
***       SIGNON - SIGN ON TO MEMORY LINK INTERFACE.
*
*         SIGNON ANAME,MAXMSG,UNIQUE,STATUS
*
*         ENTRY  ANAME = ADDRESS OF APPLICATION NAME BEING SIGNED ON.
*                MAXMSG = ADDRESS OF THE MAXIMUM NUMBER OF MESSAGES
*                         THAT CAN BE QUEUED FOR THIS APPLICATION.
*                UNIQUE = ADDRESS OF A WORD WHERE A UNIQUE APPLICATION
*                         NAME WILL BE RETURNED.
*                STATUS = ADDRESS OF STATUS RETURN WORD.
*
*         EXIT   APPLICATION SIGNED ON IF POSSIBLE.
*                STATUS PARAMETER CONTAINS A STATUS CODE.
*
*         CALLS  MLI=
          SPACE  2
          PURGMAC SIGNON
          SPACE  2
SIGNON    MACRO  ANAME,MAXMSG,UNIQUE,STATUS
          PPARMM ANAME,MLPAN
          PPARMM MAXMSG,MLPMM
          PPARMD UNIQUE,MLPSN
          PPARMD STATUS,MLPST
          PPARMD MLFON,MLPFN
          SA1    =XMLIPAR+MLPSN
          SA1    X1
          BX6    X1
          SA6    =XMLIPAR+MLPV1
          RJ     =XMLI=
          TRANSFR MLPSV,MLPST
          TRANSFR MLPV1,MLPSN
SIGNON    ENDM
          SPACE  2
          ENDX
*DECK DECK=COMPAMC EXPAND=FALSE
          EJECT
          TITLE  COMPAMC - CONSTANTS FOR MONITOR ASSIST.
***       COMPAMC - CONSTANTS FOR MONITOR ASSIST.
*
*         PROVIDES CODES FOR SMA JOBS AND OTHER CONSTANTS FOR
*         SMU/SMA COMPATABILITY.


**        JOB TABLE CODES.

 DST      EQU    1           DEADSTART SYSTEM
 TRM      EQU    2           TERMINATE DUAL STATE OPERATION
 DVP      EQU    3           DEADSTART VIRTUAL PROCESSOR
 SVP      EQU    4           SWITCH VIRTUAL PROCESSOR
*DECK DECK=COMPIOU EXPAND=FALSE
          CTEXT  COMPIOU - IOU INSTRUCTION DEFINITIONS.                  R123_OS        1
          BASE   O                                                       R123_OS        2
 COMPIOU  SPACE  4,10                                                    R123_OS        3
***       COMPIOU - IOU INSTRUCTION DEFINITIONS.                         R123_OS        4
*         B. R. HANSON       79/08/03.                                   R123_OS        5
          SPACE  4,10                                                    R123_OS        6
***              COMPIOU DEFINES THOSE INSTRUCTIONS THAT EITHER ARE      R123_OS        7
*         UNIQUE TO THE C174-2XX IOU OR NEED SPECIAL SUPPORT TO BE       R123_OS        8
*         USED FROM THE A170 NOS OPERATING SYSTEM.  TO USE THE           R123_OS        9
*         SIXTEEN BIT INSTRUCTIONS LIKE *LDDL* THE COMMON DECK           R123_OS       10
*         *COMPMCH* IS NEEDED TO DEFINE THE ROUTINE *MLI* - MAKE         R123_OS       11
*         LONG INSTRUCTIONS.                                             R123_OS       12
          SPACE  4                                                       R123_OS       13
**        BIT16 - ENTER FOLLOWING INSTRUCTION INTO TABLE OF              R123_OS       14
*                16 BIT INSTRUCTIONS.                                    R123_OS       15
*                                                                        R123_OS       16
          PURGMAC BIT16                                                  R123_OS       17
                                                                         R123_OS       18
 BIT16    MACRO  ADDR                                                    R123_OS       19
          LOCAL  X                                                       R123_OS       20
          QUAL                                                           R123_OS       21
 X        EQU    ADDR *                                                  R123_OS       22
          QUAL   *                                                       R123_OS       23
 A170     RMT                                                            R123_OS       24
          CON    X                                                       R123_OS       25
 A170     RMT                                                            R123_OS       26
          ENDM                                                           R123_OS       27
          SPACE  4                                                       R123_OS       28
**        D16A - DEFINE SINGLE OPERAND 16 BIT INSTRUCIIONS.              R123_OS       29
*                                                                        R123_OS       30
                                                                         R123_OS       31
          PURGMAC D16A                                                   R123_OS       32
                                                                         R123_OS       33
 D16A     MACRO  LIST                                                    R123_OS       34
          IRP    LIST                                                    R123_OS       35
          PURGMAC ;AL                                                    R123_OS       36
 ;AL      MACRO  A                                                       R123_OS       37
          LIST   A                                                       R123_OS       38
          BIT16  *-1                                                     R123_OS       39
 ;AL      ENDM                                                           R123_OS       40
          IRP                                                            R123_OS       41
          ENDM                                                           R123_OS       42
          SPACE  4                                                       R123_OS       43
**        D16AB - DEFINE DOUBLE OPERAND 16 BIT INSTRUCTIONS.             R123_OS       44
*                                                                        R123_OS       45
                                                                         R123_OS       46
          PURGMAC D16AB                                                  R123_OS       47
                                                                         R123_OS       48
 D16AB    MACRO  LIST                                                    R123_OS       49
          IRP    LIST                                                    R123_OS       50
          PURGMAC ;AL                                                    R123_OS       51
 ;AL      MACRO  A,B                                                     R123_OS       52
          LIST   A,B                                                     R123_OS       53
          BIT16  *-2                                                     R123_OS       54
 ;AL      ENDM                                                           R123_OS       55
          IRP                                                            R123_OS       56
          ENDM                                                           R123_OS       57
          SPACE  4                                                       R123_OS       58
**        DEFINE SINGLE OPERAND 16 BIT INSTRUCTIONS.                     R123_OS       59
                                                                         R123_OS       60
                                                                         R123_OS       61
          D16A   (LDD,STD,LDI,STI,ADD,SBD,ADI,SBI,LMD,LMI)               R123_OS       62
          D16A   (RAD,AOD,SOD,RAI,CRD,CWD)                               R123_OS       63
          SPACE  4                                                       R123_OS       64
**        DEFINE DOUBLE OPERAND 16 BIT INSTRUCTIONS.                     R123_OS       65
                                                                         R123_OS       66
          D16AB  (LDM,STM,ADM,SBM,RAM,AOM,SOM,LMM,CRM,CWM)               R123_OS       67
          SPACE  4                                                       R123_OS       68
          PURGMAC D16A,D16AB                                             R123_OS       69
          SPACE  4                                                       R123_OS       70
**        LPDL - LOGICAL PRODUCT DIRECT.                                 R123_OS       71
*                                                                        R123_OS       72
                                                                         R123_OS       73
                                                                         R123_OS       74
 LPDL.    PPOP   4,2200                                                  R123_OS       75
                                                                         R123_OS       76
          PURGMAC LPDL                                                   R123_OS       77
 LPDL     MACRO  D                                                       R123_OS       78
          BIT16                                                          R123_OS       79
          LPDL.  D                                                       R123_OS       80
          ENDM                                                           R123_OS       81
          SPACE  4                                                       R123_OS       82
**        LPIL - LOGICAL PRODUCT INDIRECT.                               R123_OS       83
*                                                                        R123_OS       84
                                                                         R123_OS       85
                                                                         R123_OS       86
 LPIL.    PPOP   4,2300                                                  R123_OS       87
                                                                         R123_OS       88
          PURGMAC LPIL                                                   R123_OS       89
 LPIL     MACRO  A                                                       R123_OS       90
          BIT16                                                          R123_OS       91
          LPIL.  A                                                       R123_OS       92
          ENDM                                                           R123_OS       93
          SPACE  4                                                       R123_OS       94
**        LPML - LOGICAL PRODUCT LONG.                                   R123_OS       95
*                                                                        R123_OS       96
                                                                         R123_OS       97
                                                                         R123_OS       98
 LPML.    PPOP   5,2400                                                  R123_OS       99
                                                                         R123_OS      100
          PURGMAC LPML                                                   R123_OS      101
 LPML     MACRO  A,B                                                     R123_OS      102
          LPML.  A,B                                                     R123_OS      103
          BIT16  *-2                                                     R123_OS      104
          ENDM                                                           R123_OS      105
          SPACE  4                                                       R123_OS      106
**        RDSL - CENTRAL READ AND SET LOCK.                              R123_OS      107
*                                                                        R123_OS      108
                                                                         R123_OS      109
 RDSL.    PPOP   4,000                                                   R123_OS      110
                                                                         R123_OS      111
                                                                         R123_OS      112
          PURGMAC RDSL                                                   R123_OS      113
 RDSL     MACRO  A                                                       R123_OS      114
          BIT16                                                          R123_OS      115
          RDSL.  A                                                       R123_OS      116
          ENDM                                                           R123_OS      117
          SPACE  4                                                       R123_OS      118
**        RDCL - CENTRAL READ AND CLEAR LOCK.                            R123_OS      119
*                                                                        R123_OS      120
                                                                         R123_OS      121
                                                                         R123_OS      122
 RDCL.    PPOP   4,0100                                                  R123_OS      123
                                                                         R123_OS      124
          PURGMAC RDCL                                                   R123_OS      125
 RDCL     MACRO  A                                                       R123_OS      126
          BIT16                                                          R123_OS      127
          RDCL.  A                                                       R123_OS      128
          ENDM                                                           R123_OS      129
          SPACE  4                                                       R123_OS      130
**        FSJM - JUMP TO M IF CHANNEL C FLAG SET.                        R123_OS      131
*                                                                        R123_OS      132
                                                                         R123_OS      133
                                                                         R123_OS      134
          PURGMAC FSJM                                                   R123_OS      135
 FSJM     MACRO  M,C                                                     R123_OS      136
          BIT16                                                          R123_OS      137
          AJM    M,C                                                     R123_OS      138
          ENDM                                                           R123_OS      139
          SPACE  4                                                       R123_OS      140
**        FCJM - JUMP TO M IF CHANNEL C FLAG CLEAR.                      R123_OS      141
*                                                                        R123_OS      142
                                                                         R123_OS      143
                                                                         R123_OS      144
          PURGMAC FCJM                                                   R123_OS      145
 FCJM     MACRO  M,C                                                     R123_OS      146
          BIT16                                                          R123_OS      147
          IJM    M,C                                                     R123_OS      148
          ENDM                                                           R123_OS      149
          SPACE  4                                                       R123_OS      150
**        IAPM - INPUT WORDS TO M FROM CHANNEL C PACKED.                 R123_OS      151
*                                                                        R123_OS      152
                                                                         R123_OS      153
                                                                         R123_OS      154
          PURGMAC IAPM                                                   R123_OS      155
 IAPM     MACRO  M,C                                                     R123_OS      156
          BIT16                                                          R123_OS      157
          IAM    M,C                                                     R123_OS      158
          ENDM                                                           R123_OS      159
          SPACE  4                                                       R123_OS      160
**        OAPM - OUTPUT WORDS FROM M TO CHANNEL C PACKED.                R123_OS      161
*                                                                        R123_OS      162
                                                                         R123_OS      163
                                                                         R123_OS      164
          PURGMAC OAPM                                                   R123_OS      165
 OAPM     MACRO  M,C                                                     R123_OS      166
          BIT16                                                          R123_OS      167
          OAM    M,C                                                     R123_OS      168
          ENDM                                                           R123_OS      169
          SPACE  4                                                       R123_OS      170
**        INPN - INTERRUPT PROCESSOR.                                    R123_OS      171
*                                                                        R123_OS      172
                                                                         R123_OS      173
                                                                         R123_OS      174
 INPN.    PPOP   4,2600                                                  R123_OS      175
                                                                         R123_OS      176
          PURGMAC INPN                                                   R123_OS      177
 INPN     MACRO  D                                                       R123_OS      178
          BIT16                                                          R123_OS      179
          INPN.  D                                                       R123_OS      180
          ENDM                                                           R123_OS      181
          SPACE  4                                                       R123_OS      182
**        LIST16 - CREATE TABLE OF 16 BIT INSTRUCTION ADDRESSES.         R123_OS      183
*                                                                        R123_OS      184
                                                                         R123_OS      185
                                                                         R123_OS      186
          PURGMAC LIST16                                                 R123_OS      187
 LIST16   MACRO                                                          R123_OS      188
 A170     HERE                                                           R123_OS      189
          CON    0                                                       R123_OS      190
          ENDM                                                           R123_OS      191
          SPACE  4                                                       R123_OS      192
          BASE   *                                                       R123_OS      193
          ENDX                                                           R123_OS      194
*DECK DECK=COMPMDD EXPAND=FALSE
          CTEXT  COMPMDD - MONITOR DISPLAY DRIVER.                       R152_OS        1
          IF     -DEF,QUAL$,1                                            R152_OS        2
          QUAL   COMPMDD                                                 R152_OS        3
          CODE   A                                                       R152_OS        4
          BASE   M                                                       R152_OS        5
 COMPMDD  SPACE  4,10                                                    R152_OS        6
***       MDD - MONITOR DISPLAY DRIVER.                                  R152_OS        7
*         B. R. HANSON-      81/09/10.                                   R152_OS        8
          SPACE  4,10                                                    R152_OS        9
***              MDD PROVIDES THE OPERATOR/ANALYST ACCESS TO THE         R152_OS       10
*         MAINTENANCE CHANNEL.                                           R152_OS       11
*                                                                        R152_OS       12
                                                                         R152_OS       13
***       MAINTENANCE REGISTER COMMANDS.                                 R152_OS       14
*                                                                        R152_OS       15
*         DR     DISPLAY MAINTENANCE REGISTERS EITHER AS A LIST OR ONE   R152_OS       16
*                AT A TIME.                                              R152_OS       17
*                SYNTAX = DR [I / M / P]                                 R152_OS       18
*                         DR [I / M / P]  RN                             R152_OS       19
*                                                                        R152_OS       20
*         ER     CHANGE VALUE OF A MAINTENANCE REGISTER.                 R152_OS       21
*                SYNTAX = ER [I / M / P] RN=REGISTER  RV=VALUE           R152_OS       22
*                                                                        R152_OS       23
*         DP     DISPLAY A, P, K, OR Q REGISTERS FOR EACH IOU IN THE MAC R152_OS       24
*                SYNTAX = DP [A / P / K / Q]                             R152_OS       25
*                                                                        R152_OS       26
*         UCR    DISPLAY EXPLANATION OF USER CONDITION REGISTER BITS.    R152_OS       27
*                SYNTAX = UCR  RV=UCR_VALUE                              R152_OS       28
*                                                                        R152_OS       29
*         MCR    DISPLAY EXPLANATION OF MONITOR CONDITION REGISTER BITS. R152_OS       30
*                SYNTAX = MCR  RV=MCR_VALUE                              R152_OS       31
*                                                                        R152_OS       32
*         IP     IDLE PP VIA THE MAINTENANCE CHANNEL.                    R152_OS       33
*                SYNTAX = IP  PP=PP_NUMBER                               R152_OS       34
*                                                                        R152_OS       35
*         RP     START PP EXECUTING AT A SPECIFIED ADDRESS.              R152_OS       36
*                SYNTAX = RP  PP=PP_NUMBER  AD=ADDRESS                   R152_OS       37
*                                                                        R152_OS       38
*         HP     HALT PROCESSOR (CPU).                                   R152_OS       39
*         SP     START PROCESSOR (CPU).                                  R152_OS       40
*                                                                        R152_OS       41
*         CI     UNCONDITIONALLY CLEAR THE MAINTENANCE INTERLOCK.  THIS  R152_OS       42
*                PROVIDES A WAY USE THE MAINTENANCE CHANNEL IF SOME OTHE R152_OS       43
*                PP PROGRAM HANGS WITH IT INTERLOCKED.                   R152_OS       44
*                                                                        R152_OS       45
*         CE     CLEAR ERRORS ON SPECIFIC PORT I, M, OR P.               R152_OS       46
*                SYNTAX = CE [I / M / P]                                 R152_OS       47
                                                                         R152_OS       48
***       CENTRAL MEMORY COMMANDS.                                       R152_OS       49
*                                                                        R152_OS       50
*         DC     DISPLAY CENTRAL MEMORY IN C170 FORMAT.                  R152_OS       51
*                SYNTAX = DC  AD=OCTAL_ADDRESS  WC=WORD_COUNT            R152_OS       52
*                                                                        R152_OS       53
*         DB     DISPLAY MEMORY IN C180 BYTE FORMAT.                     R152_OS       54
*                SYNTAX = DB  AD=HEX_ADDRESS  WC=WORD_COUNT              R152_OS       55
*                                                                        R152_OS       56
*         DH     DISPLAY MEMORY IN C180 WORD FORMAT.                     R152_OS       57
*                SYNTAX = DH  AD=HEX_WORD_ADDRESS  WC=WORD_COUNT         R152_OS       58
*                                                                        R152_OS       59
*         EC     CHANGE CONTENT OF C170 WORD.                            R152_OS       60
*                SYNTAX = EC  AD=OCTAL_WORD_ADDRESS  WV=OCTAL_VALUE      R152_OS       61
*                                                                        R152_OS       62
*         EB     CHANGE CONTENT OF C180 BYTE OR BYTES IN MEMORY.         R152_OS       63
*                SYNTAX = EB  AD=OCTAL_BYTE_ADDRESS  BYTE1  BYTE2  .. BY R152_OS       64
*                                                                        R152_OS       65
*         +      REPEAT LAST CM DISPLAY COMMAND AFTER INCREMENTING THE   R152_OS       66
*                ADDRESS.  THE DEFAULT INCREMENT IS BASED ON THE WORD_CO R152_OS       67
*                FROM THE PREVIOUS CM DISPLAY COMMAND.                   R152_OS       68
*                SYNTAX = +                                              R152_OS       69
*                         +  ADDRESS_INCREMENT                           R152_OS       70
*                                                                        R152_OS       71
*         -      REPEAT LAST CM DISPLAY COMMAND AFTER DECREMENTING THE   R152_OS       72
*                ADDRESS.  THE DEFAULT DECREMENT IS BASED ON THE WORD_CO R152_OS       73
*                FROM THE PREVIOUS CM DISPLAY COMMAND.                   R152_OS       74
*                SYNTAX = -                                              R152_OS       75
*                         -  ADDRESS_DECREMENT                           R152_OS       76
                                                                         R152_OS       77
***       MISC COMMANDS.                                                 R152_OS       78
*                                                                        R152_OS       79
*         SR     SET MDD DISPLAY REFRESH FLAG.                           R152_OS       80
*                SYNTAX = SR  [ON / OFF]                                 R152_OS       81
*                                                                        R152_OS       82
          EJECT                                                          R152_OS       83
**        MDD - MAINTENANCE DISPLAY DRIVER.                              R152_OS       84
*                                                                        R152_OS       85
*         CALLS  CMD, GTS, RDS.                                          R152_OS       86
                                                                         R152_OS       87
                                                                         R152_OS       88
 MDD      SUBR               ENTRY/EXIT                                  R152_OS       89
          RJM    GTS         CHECK SUMMARY STATUS                        R152_OS       90
          SHN    21-3                                                    R152_OS       91
          MJN    MDD1        IF INPUT AVAILABLE                          R152_OS       92
          RJM    RPT         CHECK FOR DISPLAY REPEAT                    R152_OS       93
          LDN    0                                                       R152_OS       94
          RJM    CPS         CHECK PORT STATUS                           R152_OS       95
          UJN    MDDX        RETURN                                      R152_OS       96
                                                                         R152_OS       97
 MDD1     RJM    RDS         READ STRING                                 R152_OS       98
          LDC    0                                                       R152_OS       99
 CMDP     EQU    *-1         COMMAND PROCESSOR POINTER                   R152_OS      100
          NJN    MDD2        IF OPTIONAL PROCESSOR                       R152_OS      101
          LDC    CMD         USE *CMD*                                   R152_OS      102
 MDD2     STD    T2          SET COMMAND PROCESSOR                       R152_OS      103
          LJM    0,T2        PROCESS COMMAND                             R152_OS      104
          SPACE  4,10                                                    R152_OS      105
**        SPECIAL ASCII CHARACTER CONSTANTS.                             R152_OS      106
*                                                                        R152_OS      107
                                                                         R152_OS      108
                                                                         R152_OS      109
 CR       EQU    15                                                      R152_OS      110
 LF       EQU    12                                                      R152_OS      111
 BS       EQU    10                                                      R152_OS      112
 FF       EQU    14B         SCREEN CLEAR                                R152_OS      113
 ESC      EQU    33                                                      R152_OS      114
 TOF      EQU    31                                                      R152_OS      115
 CMD      EJECT                                                          R152_OS      116
**        CMD - PROCESS COMMAND.                                         R152_OS      117
*                                                                        R152_OS      118
*         ENTRY  (NC) = ADDRESS OF NEXT CHARACTER IN LINE.               R152_OS      119
*                                                                        R152_OS      120
*         EXIT   COMMAND PROCESSED.                                      R152_OS      121
*                                                                        R152_OS      122
*         USES   T1, T2, VAL1 - VAL1+1.                                  R152_OS      123
*                                                                        R152_OS      124
*         CALLS  ASN, CLS, WTC.                                          R152_OS      125
                                                                         R152_OS      126
                                                                         R152_OS      127
 CMD      BSS    0           ENTRY                                       R152_OS      128
          RJM    CFI         CHECK FOR INCREMENT                         R152_OS      129
          ZJN    CMD2        IF INCREMENT                                R152_OS      130
          RJM    ASN         ASSEMBLE NAME                               R152_OS      131
          LDN    4                                                       R152_OS      132
          STD    T2          SET TABLE ENTRY SIZE                        R152_OS      133
          LDC    CMDS                                                    R152_OS      134
          RJM    SFN         SEARCH FOR NAME                             R152_OS      135
          ZJN    CMDE        IF ILLEGAL COMMAND                          R152_OS      136
          STM    CMDA        SET COMMAND ADDRESS                         R152_OS      137
          RJM    PRM         DECODE PARAMETER LIST                       R152_OS      138
          UJN    CMD3        PROCESS COMMAND                             R152_OS      139
                                                                         R152_OS      140
 CMD2     LDM    RDIS        REPEAT DISPLAY                              R152_OS      141
          ZJN    CMDE        IF NOT VALID                                R152_OS      142
          STM    CMDA                                                    R152_OS      143
          LDN    0                                                       R152_OS      144
 CMD3     STDL   T2                                                      R152_OS      145
          LDM    RFLG                                                    R152_OS      146
          ZJN    CMD4        IF NO REFRESH                               R152_OS      147
          RJM    CLS         CLEAR THE SCREEN                            R152_OS      148
 CMD4     LDDL   T2                                                      R152_OS      149
          LJM    0           PROCESS THE COMMAND                         R152_OS      150
 CMDA     EQU    *-1                                                     R152_OS      151
                                                                         R152_OS      152
 CMDE     LDC    =C/ *ILL*/                                              R152_OS      153
 CMDF     RJM    WTC                                                     R152_OS      154
          RJM    EOL                                                     R152_OS      155
                                                                         R152_OS      156
 CMDX     LDN    0                                                       R152_OS      157
                                                                         R152_OS      158
 CMDR     STM    RDIS        SET REPEAT DISPLAY ADDRESS                  R152_OS      159
          SHN    -14                                                     R152_OS      160
          STM    VAL4        SET ADDRESS DECODE                          R152_OS      161
          LJM    MDDX        RETURN                                      R152_OS      162
                                                                         R152_OS      163
 ERR      EQU    CMDX                                                    R152_OS      164
 CPS      SPACE  4,10                                                    R152_OS      165
**        CPS - CHECK PORT STATUS.                                       R152_OS      166
*                                                                        R152_OS      167
*         ENTRY  (A) <> 0, IMMEDIATE CHECK.                              R152_OS      168
*                                                                        R152_OS      169
*         EXIT   *RJM* TO (CPSA) IF PORT REQUESTED.                      R152_OS      170
*                                                                        R152_OS      171
*         CALLS  CPR.                                                    R152_OS      172
                                                                         R152_OS      173
                                                                         R152_OS      174
 CPS2     CON    0           NULL *RJM* ENTRY                            R152_OS      175
                                                                         R152_OS      176
 CPS      SUBR               ENTRY/EXIT                                  R152_OS      177
          NJN    CPS1        IF UNCONDITIONAL CHECK                      R152_OS      178
          SOM    CPSB                                                    R152_OS      179
          NJN    CPSX        IF NOT TIME TO CHECK STATUS                 R152_OS      180
          LDC    200                                                     R152_OS      181
          STM    CPSB                                                    R152_OS      182
 CPS1     RJM    CPR         CHECK IF PORT REQUESTED                     R152_OS      183
          ZJN    CPSX        IF PORT NOT WANTED BY SOMEONE ELSE          R152_OS      184
          RJM    HPR         IGNORE PORT REQUESTED                       R152_OS      185
          LJM    CMDX        RETURN                                      R152_OS      186
                                                                         R152_OS      187
 CPSB     CON    200                                                     R152_OS      188
 RDS      SPACE  4,10                                                    R152_OS      189
**        RDS - READ STRING.                                             R152_OS      190
*                                                                        R152_OS      191
*         EXIT   (NC) - FWA OF STRING.                                   R152_OS      192
*                (SZ) - LWA OF STRING.                                   R152_OS      193
*                TO CMDX, IF *ESC* CHARACTER TYPED.                      R152_OS      194
*                                                                        R152_OS      195
*         CALLS  NCH, OUT, WTC.                                          R152_OS      196
                                                                         R152_OS      197
                                                                         R152_OS      198
 RDS      SUBR               ENTRY/EXIT                                  R152_OS      199
                                                                         R152_OS      200
 RDS0     LDC    BUF                                                     R152_OS      201
          STD    NC                                                      R152_OS      202
          STD    SZ                                                      R152_OS      203
 RDS1     RJM    NCH         READ THE NEXT CHARACTER                     R152_OS      204
          STI    SZ                                                      R152_OS      205
          SBN    40                                                      R152_OS      206
          MJN    RDS2        IF CONTROL CHARACTER                        R152_OS      207
          AOD    SZ                                                      R152_OS      208
          SBD    NC                                                      R152_OS      209
          ADC    -72D                                                    R152_OS      210
          MJN    RDS1        IF LINE NOT TOO LONG                        R152_OS      211
          LDC    =C/ *OVL*/+10000                                        R152_OS      212
          UJN    RDS5        WRITE STRING AND RESTART LINE               R152_OS      213
                                                                         R152_OS      214
 RDS2     ADN    40-CR                                                   R152_OS      215
          ZJN    RDS3        IF (CR)                                     R152_OS      216
          SBN    ESC-CR                                                  R152_OS      217
          ZJN    RDS4        IF ESCAPE                                   R152_OS      218
          ADN    ESC-BS                                                  R152_OS      219
          NJN    RDS1        IF NOT BACKSPACE                            R152_OS      220
          SOD    SZ          DECREMENT CHARACTER COUNT                   R152_OS      221
          SBD    NC                                                      R152_OS      222
          MJN    RDS0        IF BEYOND LEFT MARGIN                       R152_OS      223
          UJN    RDS1        GET NEXT CHARACTER                          R152_OS      224
                                                                         R152_OS      225
 RDS3     STI    SZ          TERMINATE LINE WITH ZERO CHARACTER          R152_OS      226
          LDN    LF          ISSUE LINE FEED                             R152_OS      227
          RJM    OUT                                                     R152_OS      228
          LJM    RDSX        RETURN                                      R152_OS      229
                                                                         R152_OS      230
 RDS4     LDC    =C/ *ESC*/+10000                                        R152_OS      231
 RDS5     RJM    WTC         WRITE STRING                                R152_OS      232
          LJM    CMDX        IGNORE INPUT                                R152_OS      233
 RPT      SPACE  4,10                                                    R152_OS      234
**        RPT - REPEAT DISPLAY COMMAND.                                  R152_OS      235
*                                                                        R152_OS      236
*         ENTRY  (RFLG) = REPEAT FLAG.                                   R152_OS      237
*                (RDLY) = REMAINING TIME UNTIL REPEAT.                   R152_OS      238
*                (RDIS) = COMMAND ADDRESS.                               R152_OS      239
*                                                                        R152_OS      240
*         USES   T2.                                                     R152_OS      241
*                                                                        R152_OS      242
*         CALLS  OUT.                                                    R152_OS      243
                                                                         R152_OS      244
                                                                         R152_OS      245
 RPT      SUBR               ENTRY/EXIT                                  R152_OS      246
          LDM    RFLG                                                    R152_OS      247
          ZJN    RPTX        IF REPEAT NOT SET                           R152_OS      248
          SOML   RDLY                                                    R152_OS      249
          NJN    RPTX        IF NOT TIME YET                             R152_OS      250
          LDC    70000                                                   R152_OS      251
          STML   RDLY        RESET DELAY                                 R152_OS      252
          LDM    RDIS                                                    R152_OS      253
          ZJN    RPTX        IF NO REPEAT ADDRESS                        R152_OS      254
          STD    T2                                                      R152_OS      255
          LDN    TOF         TOP OF FORM                                 R152_OS      256
          RJM    OUT         RESET SCREEN                                R152_OS      257
          LJM    0,T2        REPEAT DISPLAY                              R152_OS      258
                                                                         R152_OS      259
 RFLG     CON    0           REPEAT FLAG                                 R152_OS      260
 RDLY     CON    7000        REPEAT DELAY                                R152_OS      261
 RDIS     CON    0           REPEAT DISPLAY PROCESSOR                    R152_OS      262
 VAL1     CON    0,0         VALUE 1 SAVE AREA                           R152_OS      263
 VAL2     CON    10          VALUE 2 SAVE AREA                           R152_OS      264
 VAL3     CON    0,0         INCREMENT VALUE                             R152_OS      265
 VAL4     CON    0           LAST NUMBER DECODE TYPE                     R152_OS      266
 CMDS     EJECT                                                          R152_OS      267
**        COMMANDS AVAILABLE UNDER *MDD* BY DEFAULT.                     R152_OS      268
*                                                                        R152_OS      269
                                                                         R152_OS      270
                                                                         R152_OS      271
 DR       CMND   MRP,MRNT,DRL                                            R152_OS      272
 ER       CMND   MRW,MRNT,DRL                                            R152_OS      273
 CE       CMND   CER,MRNT,DRL                                            R152_OS      274
 DRL      BSS    0                                                       R152_OS      275
          PRM    MRPA                                                    R152_OS      276
 M        PRMV   MRPC                                                    R152_OS      277
 I        PRMV   MRPB                                                    R152_OS      278
 P        PRMV   MRPD                                                    R152_OS      279
 RN       PRM    MRPE,1                                                  R152_OS      280
 RV       PRM    MRBF,10                                                 R152_OS      281
          PRME                                                           R152_OS      282
                                                                         R152_OS      283
 RF       CMND   RFP,MRNT                                                R152_OS      284
 AD       PRM    RFPA,1                                                  R152_OS      285
 WC       PRM    RFPB,1                                                  R152_OS      286
          PRME                                                           R152_OS      287
                                                                         R152_OS      288
 DC       CMND   DCM,OWNT,CMPL                                           R152_OS      289
 DH       CMND   DHX,HPNT,CMPL                                           R152_OS      290
 DB       CMND   DHB,HPNT,CMPL                                           R152_OS      291
 CMPL     BSS    0                                                       R152_OS      292
 AD       PRM    VAL1,2                                                  R152_OS      293
 WC       PRM    VAL2,1                                                  R152_OS      294
          PRME                                                           R152_OS      295
                                                                         R152_OS      296
 EB       CMND   EBT,HPNT                                                R152_OS      297
 EBTP     BSS    0                                                       R152_OS      298
 AD       PRM    VAL1,2                                                  R152_OS      299
          PRME                                                           R152_OS      300
                                                                         R152_OS      301
 EC       CMND   ECM,OWNT                                                R152_OS      302
 AD       PRM    VAL1,2                                                  R152_OS      303
 WV       PRM    MRBF,5                                                  R152_OS      304
          PRME                                                           R152_OS      305
                                                                         R152_OS      306
 DP       CMND   DPP,OWNT                                                R152_OS      307
          PRM    DPPB                                                    R152_OS      308
 P        PRMV   0                                                       R152_OS      309
 Q        PRMV   1                                                       R152_OS      310
 K        PRMV   2                                                       R152_OS      311
 A        PRMV   3                                                       R152_OS      312
          PRME                                                           R152_OS      313
                                                                         R152_OS      314
 CI       CMND   CCI         CLEAR MAINTENANCE CHANNEL INTERLOCK         R152_OS      315
 IP       CMND   IPP,OWNT,PPCL  IDLE PP                                  R152_OS      316
 RP       CMND   RPP,OWNT,PPCL  RUN PP AT SPECIFIED ADDRESS              R152_OS      317
 PPCL     BSS    0                                                       R152_OS      318
 PP       PRM    PP,1                                                    R152_OS      319
 AD       PRM    RPPA,1                                                  R152_OS      320
          PRME                                                           R152_OS      321
                                                                         R152_OS      322
 HP       CMND   HLT                                                     R152_OS      323
 SP       CMND   RUN                                                     R152_OS      324
 SR       CMND   CMDX,OWNT                                               R152_OS      325
          PRM    RFLG                                                    R152_OS      326
 ON       PRMV   1                                                       R152_OS      327
 OF       PRMV   0                                                       R152_OS      328
          PRME                                                           R152_OS      329
                                                                         R152_OS      330
                                                                         R152_OS      331
 MC       CMND   MCR,HWNT,MCCL                                           R152_OS      332
 UC       CMND   UCR,HWNT,MCCL                                           R152_OS      333
 MCCL     BSS    0                                                       R152_OS      334
 RV       PRM    PP,1                                                    R152_OS      335
          PRME                                                           R152_OS      336
                                                                         R152_OS      337
 DM       CMND   DMMP,HWNT                                               R152_OS      338
                                                                         R152_OS      339
 PV       PRM    BA,3                                                    R152_OS      340
 WC       PRM    VAL2,1                                                  R152_OS      341
          PRM    BA+3,2                                                  R152_OS      342
 MP       PRMV   MPSV                                                    R152_OS      343
 JP       PRMV   JPSV                                                    R152_OS      344
 XP       PRMV   XPSV                                                    R152_OS      345
 PT       PRM    PTAV,2                                                  R152_OS      346
 BO       PRM    BA+1,2                                                  R152_OS      347
 PS       PRM    PSMV,1                                                  R152_OS      348
 PL       PRM    PTLV,1                                                  R152_OS      349
          PRME                                                           R152_OS      350
 CMDS     BSS    0                                                       R152_OS      351
 CMDS     HERE                                                           R152_OS      352
          CON    0,CMDE      ERROR PROCESSOR                             R152_OS      353
          PURGMAC CMND                                                   R152_OS      354
                                                                         R152_OS      355
 RFP      SPACE  4,10                                                    R152_OS      356
                                                                         R152_OS      357
                                                                         R152_OS      358
          EJECT                                                          R152_OS      359
 CCI      SPACE  4,10                                                    R152_OS      360
**        CCI - CLEAR CHANNEL INTERLOCK.                                 R152_OS      361
*                                                                        R152_OS      362
                                                                         R152_OS      363
                                                                         R152_OS      364
 CCI      CCF    *,MR      CLEAR MAINTENANCE CHANNEL FLAG                R152_OS      365
          PRINT  (CLEARED.)                                              R152_OS      366
          LJM    CMDX        RETURN                                      R152_OS      367
 CER      SPACE  4,10                                                    R152_OS      368
**        CER - CLEAR ERROR IN REGISTERS.                                R152_OS      369
*                                                                        R152_OS      370
                                                                         R152_OS      371
                                                                         R152_OS      372
 CER      BSS    0                                                       R152_OS      373
          LDM    MRPA                                                    R152_OS      374
          RJM    SMO         SETUP MAINTENANCE OPERATION                 R152_OS      375
          FUNCMR ,MRCE                                                   R152_OS      376
          LJM    CMDX        RETURN                                      R152_OS      377
 DCM      SPACE  4,10                                                    R152_OS      378
**        DCM - DISPLAY CENTRAL MEMORY.                                  R152_OS      379
*                                                                        R152_OS      380
                                                                         R152_OS      381
                                                                         R152_OS      382
 DCM      BSS    0                                                       R152_OS      383
 DCM0     LDN    2           SET OCTAL/DISPLAY DUMP                      R152_OS      384
          RJM    DMB         DISPLAY MEMORY BLOCK                        R152_OS      385
          LDC    DCM0+OCWD   REFRESH ADDRESS                             R152_OS      386
          LJM    CMDR        RETURN                                      R152_OS      387
 DHB      SPACE  4,10                                                    R152_OS      388
**        DHB - DISPLAY 64 BIT MEMORY FROM A BYTE ADDRESS                R152_OS      389
*                                                                        R152_OS      390
                                                                         R152_OS      391
                                                                         R152_OS      392
 DHB      LPN    1S1                                                     R152_OS      393
          ZJN    DHB0        IF ADDRESS NOT ENTERED                      R152_OS      394
          LDC    VAL1                                                    R152_OS      395
          RJM    TBA         TRANSLATE BYTE ADDRESS                      R152_OS      396
 DHB0     LDN    0           SET HEX BYTE DISPLAY                        R152_OS      397
          RJM    DMB         DISPLAY MEMORY BLOCK                        R152_OS      398
          LDC    DHB0+HXBT   REFRESH ADDRESS                             R152_OS      399
          LJM    CMDR        RETURN                                      R152_OS      400
 DHX      SPACE  4,10                                                    R152_OS      401
**        DHX - DISPLAY 64 BIT MEMORY IN HEX.                            R152_OS      402
*                                                                        R152_OS      403
                                                                         R152_OS      404
                                                                         R152_OS      405
 DHX      LDN    1           SET HEX WORD DISPLAY                        R152_OS      406
          RJM    DMB         DISPLAY MEMORY BLOCK                        R152_OS      407
          LDC    DHX+HXWD    REFRESH ADDRESS                             R152_OS      408
          LJM    CMDR        RETURN                                      R152_OS      409
 DV       SPACE  4,10                                                    R152_OS      410
**        DMM - DISPLAY PVA COMMAND                                      R152_OS      411
*                                                                        R152_OS      412
                                                                         R152_OS      413
                                                                         R152_OS      414
 DMMP     BSS    0           DISPLAY VIRTUAL MEMORY                      R152_OS      415
          SHN    21-6                                                    R152_OS      416
          PJN    DMM1        IF PAGE SIZE MASK NOT CHANGED               R152_OS      417
          RJM    DPS         DEFINE PAGE SIZE                            R152_OS      418
 DMM1     LDM    VAL3                                                    R152_OS      419
          SHN    21-13                                                   R152_OS      420
          PJN    DMM2        IF INCREMENT                                R152_OS      421
          LMN    0#1F                                                    R152_OS      422
 DMM2     SHN    21-6                                                    R152_OS      423
          STDL   T1                                                      R152_OS      424
          SHN    14-21                                                   R152_OS      425
          LPC    10000                                                   R152_OS      426
          ADM    VAL3+1                                                  R152_OS      427
          SHN    3                                                       R152_OS      428
          RADL   BA+2                                                    R152_OS      429
          SHN    -20                                                     R152_OS      430
          ADDL   T1                                                      R152_OS      431
          RADL   BA+1                                                    R152_OS      432
          LDN    0           CLEAR INCREMENT                             R152_OS      433
          STM    VAL3                                                    R152_OS      434
          STM    VAL3+1                                                  R152_OS      435
          LDD    BA+3        MAKE SYSTEM VIRTUAL ADDRESS                 R152_OS      436
          RJM    MSA         BASED ON JPS                                R152_OS      437
          NJN    DMM2.5      IF SEGMENT EXISTS                           R152_OS      438
          PRINT  (SEGMENT MISSING)                                       R152_OS      439
          LJM    CMDX        EXIT WITH NO REFRESH                        R152_OS      440
                                                                         R152_OS      441
 DMM2.5   RJM    SPT         SEARCH PAGE TABLE                           R152_OS      442
          STD    T3                                                      R152_OS      443
          SRD    T1                                                      R152_OS      444
          LDD    T2                                                      R152_OS      445
          SHN    6                                                       R152_OS      446
          ADD    T3                                                      R152_OS      447
          STM    VAL1+1                                                  R152_OS      448
          LPC    770000                                                  R152_OS      449
          ADD    T1                                                      R152_OS      450
          SHN    6                                                       R152_OS      451
          STM    VAL1                                                    R152_OS      452
          LDM    VAL2                                                    R152_OS      453
          STD    PP                                                      R152_OS      454
          LDD    BA                                                      R152_OS      455
          STM    NBUF                                                    R152_OS      456
          LDC    =C* SEGMENT *                                           R152_OS      457
          RJM    WTC                                                     R152_OS      458
          LDC    3+HPDT                                                  R152_OS      459
          RJM    PRN                                                     R152_OS      460
          RJM    EOL         PRINT END OF LINE                           R152_OS      461
 DMM3     LDDL   CM+1                                                    R152_OS      462
          STML   NBUF                                                    R152_OS      463
          LDDL   CM+2                                                    R152_OS      464
          SCN    7           ROUND BYTE ADDRESS DOWN                     R152_OS      465
          STML   NBUF+1                                                  R152_OS      466
          LDC    HMDT+8D                                                 R152_OS      467
          RJM    PRN                                                     R152_OS      468
          RJM    SPT         SEARCH PAGE TABLE                           R152_OS      469
          ZJN    DMM5        IF PAGE MISSING                             R152_OS      470
          CRML   NBUF,ON                                                 R152_OS      471
          LDC    16D+HBDT                                                R152_OS      472
          RJM    PRN                                                     R152_OS      473
          RJM    DAT                                                     R152_OS      474
          RJM    EOL                                                     R152_OS      475
          LDN    10                                                      R152_OS      476
          RAML   CM+2                                                    R152_OS      477
          SHN    -20                                                     R152_OS      478
          RAML   CM+1                                                    R152_OS      479
          SOD    PP                                                      R152_OS      480
          NJN    DMM3        IF MORE TO DISPLAY                          R152_OS      481
 DMM4     LDC    DMM1+HXBT   REENTRY ADDRESS                             R152_OS      482
          LJM    CMDR        RETURN                                      R152_OS      483
                                                                         R152_OS      484
 DMM5     PRINT  (PAGE MISSING)                                          R152_OS      485
          UJN    DMM4        EXIT                                        R152_OS      486
 XPSV     CON    0,0                                                     R152_OS      487
 DPP      SPACE  4,10                                                    R152_OS      488
**        DPP - DISPLAY PP REGISTERS.                                    R152_OS      489
*                                                                        R152_OS      490
                                                                         R152_OS      491
                                                                         R152_OS      492
 DPP      LDM    ELIO                                                    R152_OS      493
          STD    EC          SET PORT CODE                               R152_OS      494
          READMR MRBF,,DEMR                                              R152_OS      495
 DPP0     LDC    0                                                       R152_OS      496
 DPPB     EQU    *-1                                                     R152_OS      497
          STM    MRBF+6                                                  R152_OS      498
          LDN    0                                                       R152_OS      499
          STD    PP          START WITH PP 0                             R152_OS      500
 DPP1     LDD    PP                                                      R152_OS      501
          LMN    40                                                      R152_OS      502
          STM    MRBF+4                                                  R152_OS      503
          LOCKMR SET                                                     R152_OS      504
          WRITMR MRBF,,DEMR                                              R152_OS      505
          LDC    ISTR                                                    R152_OS      506
          RJM    RMR         READ IOU STATUS REGISTER                    R152_OS      507
          LOCKMR CLEAR                                                   R152_OS      508
          LDM    NBUF+4      EXTRACT ADDRESS FROM REGISTER               R152_OS      509
          SHN    10                                                      R152_OS      510
          LMM    NBUF+5                                                  R152_OS      511
          SHN    10                                                      R152_OS      512
          LMM    NBUF+6                                                  R152_OS      513
          SHN    14                                                      R152_OS      514
          STM    NBUF        SAVE UPPER 12 BITS                          R152_OS      515
          SHN    14                                                      R152_OS      516
          STM    NBUF+1      SAVE LOWER 6 BITS                           R152_OS      517
          LDC    6+OMDT      DISPLAY 6-DIGIT OCTAL NUMBER                R152_OS      518
          RJM    PRN                                                     R152_OS      519
          AOD    PP          ADVANCE PP NUMBER                           R152_OS      520
          LPN    17                                                      R152_OS      521
          SBN    12                                                      R152_OS      522
          NJN    DPP2        IF MORE PP-S TO DUMP ON THIS LINE           R152_OS      523
          RJM    EOL         WRITE AN END OF LINE                        R152_OS      524
          LDN    20-12                                                   R152_OS      525
          RAD    PP                                                      R152_OS      526
          SBN    40                                                      R152_OS      527
          MJN    DPP2        IF ANOTHER BANK OF PP-S TO DISPLAY          R152_OS      528
          LDN    0                                                       R152_OS      529
          STM    MRBF+6                                                  R152_OS      530
          WRITMR MRBF,,DEMR                                              R152_OS      531
          LDC    DPP0        SET REFRESH ADDRESS                         R152_OS      532
          LJM    CMDR        RETURN                                      R152_OS      533
                                                                         R152_OS      534
 DPP2     LJM    DPP1        PRINT NEXT PP REGISTER VALUE                R152_OS      535
 EBT      SPACE  4,10                                                    R152_OS      536
**        EBT - ENTER HEX BYTE MEMORY.                                   R152_OS      537
*                                                                        R152_OS      538
                                                                         R152_OS      539
                                                                         R152_OS      540
 EBT      LPN    1S1                                                     R152_OS      541
          NJN    EBT0        IF ADDRESS SPECIFIED                        R152_OS      542
          LJM    CMDE        SET ERROR                                   R152_OS      543
                                                                         R152_OS      544
 EBT0     LDC    0#FF00                                                  R152_OS      545
          STML   EBTA+1                                                  R152_OS      546
          LDM    VAL1+1                                                  R152_OS      547
          LPN    7                                                       R152_OS      548
          STD    T6                                                      R152_OS      549
          LDC    VAL1                                                    R152_OS      550
          RJM    TBA         TRANSLATE BYTE ADDRESS                      R152_OS      551
 EBT1     LDC    1+MRNT                                                  R152_OS      552
          RJM    DNV                                                     R152_OS      553
          NJN    EBT2        IF ANOTHER BYTE TO WRITE                    R152_OS      554
          LDD    ST          LOAD STATUS WORD                            R152_OS      555
          SCN    10          CLEAR BIT                                   R152_OS      556
          ADN    10          SET CENTRAL MEMORY WRITE BIT                R152_OS      557
          STD    ST                                                      R152_OS      558
          LJM    CMDX        RETURN                                      R152_OS      559
                                                                         R152_OS      560
 EBT2     LDD    CM+1                                                    R152_OS      561
          LMC    1S17                                                    R152_OS      562
          CRML   NBUF,ON     READ WORD TO BE PATCHED                     R152_OS      563
          LDD    T6                                                      R152_OS      564
          SHN    -1                                                      R152_OS      565
          STD    T2                                                      R152_OS      566
          LDD    T6                                                      R152_OS      567
          LPN    1                                                       R152_OS      568
          STD    T1                                                      R152_OS      569
          NJN    EBT3        IF ODD BYTE                                 R152_OS      570
          LDM    ABUF                                                    R152_OS      571
          SHN    8D                                                      R152_OS      572
          STML   ABUF                                                    R152_OS      573
 EBT3     LDML   NBUF,T2     CHANGE DESIRED BYTE                         R152_OS      574
          LPML   EBTA,T1                                                 R152_OS      575
          LMML   ABUF                                                    R152_OS      576
          STML   NBUF,T2                                                 R152_OS      577
          LDD    CM+1                                                    R152_OS      578
          LMC    1S17                                                    R152_OS      579
          CWML   NBUF,ON     REWRITE WORD                                R152_OS      580
          AOD    T6                                                      R152_OS      581
          SBN    8D                                                      R152_OS      582
          MJN    EBT4        IF NOT AT WORD BOUNDARY                     R152_OS      583
          STD    T6                                                      R152_OS      584
          AOD    CM+1                                                    R152_OS      585
 EBT4     LJM    EBT1        GET NEXT PARCEL                             R152_OS      586
                                                                         R152_OS      587
 EBTA     BSS    0           BYTE MASKS                                  R152_OS      588
          LOC    0                                                       R152_OS      589
          CON    0#FF                                                    R152_OS      590
          CON    -0#FF                                                   R152_OS      591
          LOC    *O                                                      R152_OS      592
 ECM      SPACE  4,10                                                    R152_OS      593
**        ECM - ENTER CENTRAL MEMORY.                                    R152_OS      594
*                                                                        R152_OS      595
                                                                         R152_OS      596
                                                                         R152_OS      597
 ECM      LPN    1S2                                                     R152_OS      598
          RJM    SMP         SET MEMORY PARAMETERS                       R152_OS      599
          RJM    LCA         LOAD CM ADDRESS                             R152_OS      600
          CWM    MRBF,ON                                                 R152_OS      601
          LDD    ST        LOAD STATUS WORD                              R152_OS      602
          SCN    10                                                      R152_OS      603
          ADN    10          SET CENTRAL MEMORY WRITE BIT                R152_OS      604
          STD    ST                                                      R152_OS      605
          LJM    CMDX        RETURN                                      R152_OS      606
                                                                         R152_OS      607
 ECM1     LJM    CMDE        RETURN ERROR                                R152_OS      608
 MCR      SPACE  4,10                                                    R152_OS      609
**        MCR - DISPLAY DECODED MCR BITS.                                R152_OS      610
**        UCR - DISPLAY DECODED UCR BITS.                                R152_OS      611
*                                                                        R152_OS      612
                                                                         R152_OS      613
                                                                         R152_OS      614
 MCR      LDC    MCRB        MCR BIT LIST                                R152_OS      615
          UJN    UCR1        DECODE MCR BITS                             R152_OS      616
                                                                         R152_OS      617
 UCR      LDC    UCRB+10000  UCR BIT LIST                                R152_OS      618
 UCR1     STD    T7                                                      R152_OS      619
          SHN    -14                                                     R152_OS      620
          ADC    PMCR                                                    R152_OS      621
          STD    RN                                                      R152_OS      622
          LDD    CM+2                                                    R152_OS      623
          LPN    1S1                                                     R152_OS      624
          NJN    UCR2        IF PARAMETER 1 SPECIFIED                    R152_OS      625
          LDM    ELPR                                                    R152_OS      626
          STD    EC                                                      R152_OS      627
          LDD    RN                                                      R152_OS      628
          RJM    RMR         READ MCR/UCR                                R152_OS      629
          LDM    NBUF+6                                                  R152_OS      630
          SHN    10                                                      R152_OS      631
          ADM    NBUF+7                                                  R152_OS      632
          STD    PP          SAVE MCR/UCR VALUE                          R152_OS      633
 UCR2     LDD    T7                                                      R152_OS      634
          RJM    TBR         TRANSLATE BIT REGISTER                      R152_OS      635
          LJM    CMDX        COMPLETE COMMAND                            R152_OS      636
                                                                         R152_OS      637
 UCRB     CON    =C*UCR = *                                              R152_OS      638
          LOC    0                                                       R152_OS      639
          CON    =C*PRIV FAULT*                                          R152_OS      640
          CON    =C*UNIMP INST*                                          R152_OS      641
          CON    =C*FREE FLAG*                                           R152_OS      642
          CON    =C*PIT*                                                 R152_OS      643
          CON    =C*I-RING POP*                                          R152_OS      644
          CON    =C*CRIT F FLG*                                          R152_OS      645
          CON    =C*KEYPT*                                               R152_OS      646
          CON    =C*DIVIDE FLT*                                          R152_OS      647
          CON    =C*DEBUG*                                               R152_OS      648
          CON    =C*A-OVL*                                               R152_OS      649
          CON    =C*E-OVL*                                               R152_OS      650
          CON    =C*E-UND*                                               R152_OS      651
          CON    =C*FP LOSS*                                             R152_OS      652
          CON    =C*FP INDEF*                                            R152_OS      653
          CON    =C*ARITH LOSS*                                          R152_OS      654
          CON    =C*BAD BDP*                                             R152_OS      655
          LOC    *O                                                      R152_OS      656
                                                                         R152_OS      657
 MCRB     CON    =C*MCR =*                                               R152_OS      658
          LOC    0                                                       R152_OS      659
          CON    =C*DUE*                                                 R152_OS      660
          CON    0                                                       R152_OS      661
          CON    =C*SHRT WARN*                                           R152_OS      662
          CON    =C*I-SPEC*                                              R152_OS      663
          CON    =C*A-SPEC*                                              R152_OS      664
          CON    =C*170 XJ*                                              R152_OS      665
          CON    =C*ACCESS FLT*                                          R152_OS      666
          CON    =C*E-SPEC*                                              R152_OS      667
          CON    =C*EXT INT*                                             R152_OS      668
          CON    =C*PAGE FAULT*                                          R152_OS      669
          CON    =C*180 XJ*                                              R152_OS      670
          CON    =C*SIT*                                                 R152_OS      671
          CON    =C*INV SEG/RN0*                                         R152_OS      672
          CON    =C*CALL/RTN FLT*                                        R152_OS      673
          CON    =C*SOFT ERROR*                                          R152_OS      674
          CON    =C*TRAP EXCPT*                                          R152_OS      675
          LOC    *O                                                      R152_OS      676
 HLT      SPACE  4,10                                                    R152_OS      677
**        HLT - HALT PROCESSOR.                                          R152_OS      678
*                                                                        R152_OS      679
                                                                         R152_OS      680
                                                                         R152_OS      681
 HLT      FUNCMR ELPR,MRHP                                               R152_OS      682
          LJM    CMDX                                                    R152_OS      683
 IPP      SPACE  4,10                                                    R152_OS      684
**        IPP - IDLE PP.                                                 R152_OS      685
*                                                                        R152_OS      686
                                                                         R152_OS      687
                                                                         R152_OS      688
 IPP      LDN    4                                                       R152_OS      689
          RJM    PPF         IDLE PP                                     R152_OS      690
          LJM    CMDX        RETURN                                      R152_OS      691
 MRP      SPACE  4,10                                                    R152_OS      692
**        MRP - MAINTENANCE REGISTER DISPLAY PROCESSOR.                  R152_OS      693
*                                                                        R152_OS      694
*                                                                        R152_OS      695
                                                                         R152_OS      696
                                                                         R152_OS      697
 MRP      LDM    MRPA        FETCH PROCESSOR ADDRESS                     R152_OS      698
          RJM    SMO         SETUP MR OPERATION                          R152_OS      699
          LPN    1S2                                                     R152_OS      700
          ZJN    MRP1        IF REGISTER NOT SPECIFIED                   R152_OS      701
          LDC    MRPE                                                    R152_OS      702
          STM    MRPA                                                    R152_OS      703
 MRP1     LDM    MRPA        GET REGISTER LIST                           R152_OS      704
          RJM    DMR         READ AND DISPLAY REGISTERS                  R152_OS      705
          LDC    MRPD                                                    R152_OS      706
          SBM    MRPA                                                    R152_OS      707
          NJN    MRP5                                                    R152_OS      708
          LDM    CPUT2                                                   R152_OS      709
          SBN    1                                                       R152_OS      710
          ZJN    MRP3                                                    R152_OS      711
          SBN    1                                                       R152_OS      712
          ZJN    MRP4                                                    R152_OS      713
          LDC    MRPH                                                    R152_OS      714
          UJN    MRP4.5                                                  R152_OS      715
 MRP3     LDC    MRPF                                                    R152_OS      716
          UJN    MRP4.5                                                  R152_OS      717
 MRP4     LDC    MRPG                                                    R152_OS      718
          RJM    DMR                                                     R152_OS      719
          LDC    MRPF                                                    R152_OS      720
 MRP4.5   RJM    DMR                                                     R152_OS      721
 MRP5     LDC    MRP1        REPEAT ADDRESS                              R152_OS      722
          LJM    CMDR        RETURN                                      R152_OS      723
 MRPA     SPACE  4,10                                                    R152_OS      724
**        MAINTENANCE REGISTER TABLES.                                   R152_OS      725
*                                                                        R152_OS      726
                                                                         R152_OS      727
                                                                         R152_OS      728
 MRPA     CON    MRPB        REGISTER LIST ADD  RESS                     R152_OS      729
                                                                         R152_OS      730
          CON    ELIO        IOU PORT CODE ADDRESS                       R152_OS      731
 MRPB     BSS    0           IOU MAINTENANCE REGISTERS                   R152_OS      732
 00       MR     (SS)                                                    R152_OS      733
 12       MR     (OI)                                                    R152_OS      734
 18       MR     (MASK REGISTER)                                         R152_OS      735
 21       MR     (OS BOUNDS)                                             R152_OS      736
 30       MR     (EC)                                                    R152_OS      737
 40       MR     (STATUS)                                                R152_OS      738
 80       MR     (FS1)                                                   R152_OS      739
 81       MR     (FS2)                                                   R152_OS      740
 A0       MR     (TM)                                                    R152_OS      741
          CON    7777                                                    R152_OS      742
                                                                         R152_OS      743
          CON    ELCM        MEMORY PORT CODE ADDRESS                    R152_OS      744
 MRPC     BSS    0           MEMORY MAINTENANCE REGISTERS                R152_OS      745
 00       MR     (SS)                                                    R152_OS      746
 12       MR     (OI)                                                    R152_OS      747
 20       MR     (EC)                                                    R152_OS      748
 21       MR     (MEM BOUNDS)                                            R152_OS      749
 A0       MR     (CEL)                                                   R152_OS      750
 A4       MR     (UEL1)                                                  R152_OS      751
 A8       MR     (UEL2)                                                  R152_OS      752
          CON    7777                                                    R152_OS      753
                                                                         R152_OS      754
          CON    ELPR        PROCESSOR PORT CODE ADDRESS                 R152_OS      755
 MRPD     BSS    0           PROCESSOR MAINTENANCE REGISTERS             R152_OS      756
 00       MR     (SS)                                                    R152_OS      757
 30       MR     (DEC)                                                   R152_OS      758
 31       MR     (S)                                                     R152_OS      759
 40       MR     (P)                                                     R152_OS      760
 41       MR     (MPS)                                                   R152_OS      761
 42       MR     (MCR)                                                   R152_OS      762
 43       MR     (UCR)                                                   R152_OS      763
 48       MR     (PTA)                                                   R152_OS      764
 51       MR     (MDW)                                                   R152_OS      765
 61       MR     (JPS)                                                   R152_OS      766
 62       MR     (SIT)                                                   R152_OS      767
 80       MR     (PFS)                                                   R152_OS      768
          CON    7777                                                    R152_OS      769
                                                                         R152_OS      770
          CON    ELPR        PORT CODE FOR REGISTER DISPLAY              R152_OS      771
 MRPE     BSS    0           SINGLE REGISTER DISPLAY                     R152_OS      772
 00       MR     ( )                                                     R152_OS      773
          CON    7777        END OF TABLE                                R152_OS      774
                                                                         R152_OS      775
 MRPF     BSS    0                                                       R152_OS      776
 93       MR     (MCEL)                                                  R152_OS      777
          CON    7777                                                    R152_OS      778
                                                                         R152_OS      779
 MRPG     BSS    0                                                       R152_OS      780
 81       MR     (PFS1)                                                  R152_OS      781
 92       MR     (CCEL)                                                  R152_OS      782
          CON    7777                                                    R152_OS      783
                                                                         R152_OS      784
 MRPH     BSS    0                                                       R152_OS      785
 81       MR     (PFS1)                                                  R152_OS      786
 82       MR     (PFS2)                                                  R152_OS      787
 83       MR     (PFS3)                                                  R152_OS      788
 84       MR     (PFS4)                                                  R152_OS      789
 85       MR     (PFS5)                                                  R152_OS      790
 86       MR     (PFS6)                                                  R152_OS      791
 87       MR     (PFS7)                                                  R152_OS      792
 88       MR     (PFS8)                                                  R152_OS      793
 89       MR     (PFS9)                                                  R152_OS      794
          CON    7777                                                    R152_OS      795
                                                                         R152_OS      796
 MRW      SPACE  4,10                                                    R152_OS      797
**        MRW - WRITE MAINTENANCE REGISTER.                              R152_OS      798
*                                                                        R152_OS      799
*                                                                        R152_OS      800
                                                                         R152_OS      801
                                                                         R152_OS      802
 MRW      LDM    MRPA                                                    R152_OS      803
          RJM    SMO         SETUP MAINTENANCE REGISTER OPERATION        R152_OS      804
          LPN    1S2+1S3                                                 R152_OS      805
          LMN    1S2+1S3                                                 R152_OS      806
          NJN    MRW1        IF NOT ENOUGH PARAMETERS                    R152_OS      807
          WRITMR MRBF                                                    R152_OS      808
          LDD    ST          LOAD STATUS WORD                            R152_OS      809
          SCN    4           CLEAR BIT                                   R152_OS      810
          ADN    4           SET MAINT. REGISTER WRITE BIT               R152_OS      811
          STD    ST                                                      R152_OS      812
          LDC    MRPE                                                    R152_OS      813
          STM    MRPA                                                    R152_OS      814
          RJM    DMR         DISPLAY REGISTER                            R152_OS      815
          LJM    CMDX        RETURN                                      R152_OS      816
                                                                         R152_OS      817
 MRW1     LJM    CMDE        PROCESS ERROR                               R152_OS      818
 RPP      SPACE  4,10                                                    R152_OS      819
**        RPP - RUN PP AT ADDRESS.                                       R152_OS      820
*                                                                        R152_OS      821
                                                                         R152_OS      822
                                                                         R152_OS      823
 RPP      LPN    1S2                                                     R152_OS      824
          ZJN    MRW1        IF NO ADDRESS GIVEN                         R152_OS      825
          LDN    20                                                      R152_OS      826
          ACN    0+40        ACTIVATE CHANNEL 0                          R152_OS      827
          RJM    PPF         DEADSTART PP                                R152_OS      828
          LDC    0                                                       R152_OS      829
 RPPA     EQU    *-1         ADDRESS FROM COMMAND                        R152_OS      830
          SBN    1                                                       R152_OS      831
          OAN    0           OUTPUT TO CHANNEL 0                         R152_OS      832
          DCN    0+40                                                    R152_OS      833
          LJM    CMDX        RETURN                                      R152_OS      834
 RUN      SPACE  4,10                                                    R152_OS      835
**        RUN - START PROCESSOR EXECUTING.                               R152_OS      836
*                                                                        R152_OS      837
                                                                         R152_OS      838
                                                                         R152_OS      839
 RUN      FUNCMR ELPR,MRSP                                               R152_OS      840
          LJM    CMDX        RETURN                                      R152_OS      841
 RFP      SPACE  4,10                                                    R152_OS      842
**        RFP - DISPLAY REGISTER FILE                                    R152_OS      843
*                                                                        R152_OS      844
                                                                         R152_OS      845
 RFP      BSS    0                                                       R152_OS      846
          LDM    ELPR        GET PROCESSOR CODE                          R152_OS      847
          STD    EC                                                      R152_OS      848
          LDN    0                                                       R152_OS      849
          STD    RN                                                      R152_OS      850
          READMR NBUF        READ STATUS SUMMARY REGISTER                R152_OS      851
          LDM    NBUF+7                                                  R152_OS      852
          SHN    21-3                                                    R152_OS      853
          MJN    RFP1        IF PROCESSOR IS HALTED                      R152_OS      854
          LDM    CPUT2                                                   R152_OS      855
          SBN    3                                                       R152_OS      856
          PJN    RFP2        IF AN S3 THEN ERROR                         R152_OS      857
          UJN    RFP4                                                    R152_OS      858
                                                                         R152_OS      859
 RFP1     LDM    CPUT2                                                   R152_OS      860
          SBN    3                                                       R152_OS      861
          ZJN    RFP3        IF AN S3 THEN GO AHEAD                      R152_OS      862
 RFP2     LDC    =C*PROCESSOR IN WRONG MODE*                             R152_OS      863
          LJM    CMDF                                                    R152_OS      864
                                                                         R152_OS      865
                                                                         R152_OS      866
 RFP3     FUNCMR ELPR,MRMC   MASTER CLEAR PROCESSOR                      R152_OS      867
 RFP4     LDM    RFPB                                                    R152_OS      868
          STD    T5                                                      R152_OS      869
          LDM    CPUT2       GET CPU TYPE                                R152_OS      870
          STD    T1                                                      R152_OS      871
          LDM    ELPR                                                    R152_OS      872
          SCN    17B                                                     R152_OS      873
          ADM    RFPC-1,T1                                               R152_OS      874
          STD    EC                                                      R152_OS      875
          LDM    RFPA        GET FIRST ADDRESS TO READ                   R152_OS      876
          STD    RN                                                      R152_OS      877
          STD    T6                                                      R152_OS      878
 RFP5     LDD    RN                                                      R152_OS      879
          STM    NBUF                                                    R152_OS      880
          LDN    MRDT+2      PRINT TWO DIGIT ADDRESS                     R152_OS      881
          RJM    PRN                                                     R152_OS      882
          LDC    MRRD        READ CODE                                   R152_OS      883
          ADD    EC                                                      R152_OS      884
          RJM    AMR                                                     R152_OS      885
          IAM    NBUF,MR     READ REGISTER                               R152_OS      886
          LDN    10          MUST READ A BLOCK OF 400(8) BYTES           R152_OS      887
          STD    W1                                                      R152_OS      888
 RFP6     LDN    37                                                      R152_OS      889
          IAM    BUF,MR      SKIP UNWANTED DATA                          R152_OS      890
          SOD    W1                                                      R152_OS      891
          NJN    RFP6        IF NOT DONE SKIPPING DATA                   R152_OS      892
          RJM    CMI         CLEAR MAINT. CHANNEL                        R152_OS      893
          LDN    MRDT+20                                                 R152_OS      894
          RJM    PRN         PRINT REGISTER VALUE                        R152_OS      895
          RJM    EOL                                                     R152_OS      896
          AOD    T6                                                      R152_OS      897
          STD    RN                                                      R152_OS      898
          SOD    T5          DECREMENT COUNT                             R152_OS      899
          NJN    RFP5        IF NOT DONE YET                             R152_OS      900
          LDC    RFP+MRNT                                                R152_OS      901
          LJM    CMDR                                                    R152_OS      902
                                                                         R152_OS      903
 RFPA     DATA   0           STARTING REGISTER NUMBER                    R152_OS      904
                                                                         R152_OS      905
 RFPB     DATA   12          REGISTER COUNT                              R152_OS      906
                                                                         R152_OS      907
 RFPC     DATA   1           CODE FOR AN S1                              R152_OS      908
          DATA   5           CODE FOR AN S2                              R152_OS      909
          DATA   7           CODE FOR AN S3                              R152_OS      910
                                                                         R152_OS      911
                                                                         R152_OS      912
                                                                         R152_OS      913
                                                                         R152_OS      914
          EJECT                                                          R152_OS      915
 ASN      SPACE  4,10                                                    R152_OS      916
**        ASN - ASSEMBLE NAME.                                           R152_OS      917
*                                                                        R152_OS      918
*         ENTRY  (NC) - NEXT CHARACTER IN LINE.                          R152_OS      919
*                                                                        R152_OS      920
*         EXIT   (A) - LENGTH OF NAME ASSEMBLED.                         R152_OS      921
*                (NC) = POSITIONED AFTER NAME.                           R152_OS      922
*                                                                        R152_OS      923
*         USES   T2, T3, T4.                                             R152_OS      924
*                                                                        R152_OS      925
*         CALLS  CLC, SKP.                                               R152_OS      926
                                                                         R152_OS      927
                                                                         R152_OS      928
 ASN      SUBR               ENTRY/EXIT                                  R152_OS      929
          RJM    SKP         SKIP DELIMITERS                             R152_OS      930
          ZJN    ASNX        RETURN IF EOLN                              R152_OS      931
          LDC    ASNA                                                    R152_OS      932
          STD    T3          ADDRESS TO ASSEMBLE NAME                    R152_OS      933
 ASN1     RJM    GAC         GET ALPHABETIC CHARACTER                    R152_OS      934
          MJN    ASNX        IF NOT ALPHABETIC                           R152_OS      935
          SHN    6                                                       R152_OS      936
          STI    T3          STORE IN BUFFER                             R152_OS      937
          RJM    GAC         GET ALPHABETIC CHARACTER                    R152_OS      938
          MJN    ASNX        IF NOT ALPHABETIC                           R152_OS      939
          RAI    T3                                                      R152_OS      940
          AOD    T3          INCREMENT BUFFER POINTER                    R152_OS      941
 ASN2     RJM    GAC                                                     R152_OS      942
          MJN    ASNX                                                    R152_OS      943
          UJN    ASN2                                                    R152_OS      944
                                                                         R152_OS      945
 ASNA     BSS    1                                                       R152_OS      946
 CFI      SPACE  4,10                                                    R152_OS      947
**        CFI - CHECK FOR INCREMENT.                                     R152_OS      948
*                                                                        R152_OS      949
*         ENTRY  (NC) = NEXT CHARACTER.                                  R152_OS      950
*                                                                        R152_OS      951
*         EXIT   (A) = 0, IF INCREMENT COMMAND                           R152_OS      952
*                (VAL3 - VAL3+1) = INCREMENT VALUE.                      R152_OS      953
*                                                                        R152_OS      954
*         CALLS  DNV.                                                    R152_OS      955
                                                                         R152_OS      956
                                                                         R152_OS      957
 CFI      SUBR               ENTRY/EXIT                                  R152_OS      958
          LDN    0           PRESET INCREMENT                            R152_OS      959
          STM    VAL3                                                    R152_OS      960
          STM    VAL3+1                                                  R152_OS      961
          LDI    NC          CHECK NEXT CHARACTER                        R152_OS      962
          SBN    1R++40                                                  R152_OS      963
          STD    RN                                                      R152_OS      964
          ZJN    CFI1        IF PLUS                                     R152_OS      965
          SBN    1R--1R+                                                 R152_OS      966
          NJN    CFIX        IF NOT MINUS                                R152_OS      967
 CFI1     AOD    NC          ADVANCE CHARACTER COUNT                     R152_OS      968
          LDM    VAL4        PREVIOUS DECODE TYPE                        R152_OS      969
          LPN    7                                                       R152_OS      970
          SHN    14                                                      R152_OS      971
          LMN    2                                                       R152_OS      972
          RJM    DNV         DECODE UP TO 24 BITS                        R152_OS      973
          ZJN    CFI1.5      IF NO VALUE SPECIFIED                       R152_OS      974
          LDM    VAL4                                                    R152_OS      975
          LPN    40                                                      R152_OS      976
          ZJN    CFI2        IF WORD ADDRESS                             R152_OS      977
          LDM    ABUF-1                                                  R152_OS      978
          SHN    21-2                                                    R152_OS      979
          STM    ABUF-1                                                  R152_OS      980
          SHN    2-21                                                    R152_OS      981
          SHN    14                                                      R152_OS      982
          LMM    ABUF                                                    R152_OS      983
          SHN    -3                                                      R152_OS      984
          STM    ABUF                                                    R152_OS      985
          UJN    CFI2                                                    R152_OS      986
                                                                         R152_OS      987
 CFI1.5   LDM    VAL2        USE DISPLAY COUNT                           R152_OS      988
          STM    ABUF                                                    R152_OS      989
 CFI2     LDD    RN          INCREMENT/DECREMENT FLAG                    R152_OS      990
          ZJN    CFI3        IF INCREMENT                                R152_OS      991
          LCN    0                                                       R152_OS      992
          LMM    ABUF-1      COMPLEMENT UPPER PART                       R152_OS      993
          STD    T1                                                      R152_OS      994
          LDC    7777                                                    R152_OS      995
          LMM    ABUF                                                    R152_OS      996
          ADN    1           FORM TWOS COMPLEMENT                        R152_OS      997
          STM    ABUF                                                    R152_OS      998
          SHN    -14                                                     R152_OS      999
          ADD    T1                                                      R152_OS     1000
          STM    ABUF-1                                                  R152_OS     1001
 CFI3     LDM    ABUF        SET INCREMENT VALUE                         R152_OS     1002
          STM    VAL3+1                                                  R152_OS     1003
          LDM    ABUF-1                                                  R152_OS     1004
          STM    VAL3                                                    R152_OS     1005
          LDN    0                                                       R152_OS     1006
          LJM    CFIX        RETURN                                      R152_OS     1007
 CLS      SPACE  4,10                                                    R152_OS     1008
**        CLS - CLEAR SCREEN OF CRT.                                     R152_OS     1009
*                                                                        R152_OS     1010
*         EXIT   SCREEN CLEARED AND READY FOR DISPLAY.                   R152_OS     1011
*                                                                        R152_OS     1012
*         USES   T1.                                                     R152_OS     1013
*                                                                        R152_OS     1014
*         CALLS  OUT.                                                    R152_OS     1015
                                                                         R152_OS     1016
                                                                         R152_OS     1017
 CLS      SUBR               ENTRY/EXIT                                  R152_OS     1018
          LDN    30B                                                     R152_OS     1019
          RJM    OUT         CLEAR SCREEN                                R152_OS     1020
          LDN    FF                                                      R152_OS     1021
          RJM    OUT                                                     R152_OS     1022
          LDC    200D                                                    R152_OS     1023
          STD    T0                                                      R152_OS     1024
          RJM    CTE                                                     R152_OS     1025
          PJN    *-2                                                     R152_OS     1026
          UJN    CLSX        RETURN                                      R152_OS     1027
 DAT      SPACE  4,10                                                    R152_OS     1028
**        DAT - DISPLAY ASCII TEXT.                                      R152_OS     1029
*                                                                        R152_OS     1030
*         ENTRY  (NBUF - NBUF+3) = CHARACTERS.                           R152_OS     1031
*                                                                        R152_OS     1032
*         USES   T2.                                                     R152_OS     1033
*                                                                        R152_OS     1034
*         CALLS  PAC.                                                    R152_OS     1035
                                                                         R152_OS     1036
                                                                         R152_OS     1037
 DAT      SUBR               ENTRY/EXIT                                  R152_OS     1038
          LDN    0                                                       R152_OS     1039
          STD    T2                                                      R152_OS     1040
 DAT1     LDML   NBUF,T2                                                 R152_OS     1041
          SHN    -8D                                                     R152_OS     1042
          RJM    PAC         PRINT UPPER CHARACTER                       R152_OS     1043
          LDM    NBUF,T2                                                 R152_OS     1044
          RJM    PAC         PRINT LOWER CHARACTER                       R152_OS     1045
          AOD    T2                                                      R152_OS     1046
          LMN    4                                                       R152_OS     1047
          NJN    DAT1        IF MORE TO DISPLAY                          R152_OS     1048
          UJN    DATX        RETURN                                      R152_OS     1049
 DDT      SPACE  4,10                                                    R152_OS     1050
**        DDT - DISPLAY DISPLAY-CODE TEXT.                               R152_OS     1051
*                                                                        R152_OS     1052
*         ENTRY  (NBUF - NBUF+4) = DISPLAY CODE TEXT.                    R152_OS     1053
*                                                                        R152_OS     1054
*         USES   T2.                                                     R152_OS     1055
*                                                                        R152_OS     1056
*         CALLS  PDC.                                                    R152_OS     1057
                                                                         R152_OS     1058
                                                                         R152_OS     1059
 DDT      SUBR               ENTRY/EXIT                                  R152_OS     1060
          LDN    1R +40                                                  R152_OS     1061
          RJM    OUT                                                     R152_OS     1062
          LDN    0                                                       R152_OS     1063
          STD    T2                                                      R152_OS     1064
 DDT1     LDM    NBUF,T2                                                 R152_OS     1065
          SHN    -6                                                      R152_OS     1066
          RJM    PDC         PRINT UPPER CHARACTER                       R152_OS     1067
          LDM    NBUF,T2                                                 R152_OS     1068
          LPN    77                                                      R152_OS     1069
          RJM    PDC         PRINT LOWER CHARACTER                       R152_OS     1070
          AOD    T2                                                      R152_OS     1071
          LMN    5                                                       R152_OS     1072
          NJN    DDT1        IF MORE TO DISPLAY                          R152_OS     1073
          UJN    DDTX        RETURN                                      R152_OS     1074
 DMB      SPACE  4,10                                                    R152_OS     1075
**        DMB - DISPLAY MEMORY BLOCK IN DESIRED FORM.                    R152_OS     1076
*                                                                        R152_OS     1077
*         ENTRY  (A) = MEMORY DISPLAY FORMAT.                            R152_OS     1078
*                      0 = HEX BYTE/ASCII.                               R152_OS     1079
*                      1 = HEX WORD/ASCII.                               R152_OS     1080
*                      2 = OCTAL/DISPLAY.                                R152_OS     1081
*                (VAL1 - VAL1+1) = STARTING ADDRESS.                     R152_OS     1082
*                (VAL2) = WORD COUNT.                                    R152_OS     1083
*                                                                        R152_OS     1084
*         USES   PP, T1.                                                 R152_OS     1085
*                                                                        R152_OS     1086
*         CALLS  DAT, DDT, EOL, LCA, PRN, SMP.                           R152_OS     1087
                                                                         R152_OS     1088
                                                                         R152_OS     1089
 DMB      SUBR               ENTRY/EXIT                                  R152_OS     1090
          STD    T1                                                      R152_OS     1091
          LDM    DMBB,T1     SET ROUTINE ADDRESS                         R152_OS     1092
          STM    DMBA                                                    R152_OS     1093
          RJM    SMP         SET MEMORY PARAMETERS                       R152_OS     1094
 DMB1     SOD    PP                                                      R152_OS     1095
          MJN    DMBX        IF MEMORY DISPLAYED                         R152_OS     1096
          LDD    CM          SET ADDRESS                                 R152_OS     1097
          STM    NBUF                                                    R152_OS     1098
          LDD    CM+1                                                    R152_OS     1099
          STM    NBUF+1                                                  R152_OS     1100
          LJM    DMB2        PROCESS MEMORY WORD                         R152_OS     1101
 DMBA     EQU    *-1                                                     R152_OS     1102
                                                                         R152_OS     1103
 DMBB     BSS    0                                                       R152_OS     1104
          LOC    0                                                       R152_OS     1105
          CON    DMB2        HEX BYTE/ASCII                              R152_OS     1106
          CON    DMB3        HEX WORD/ASCII                              R152_OS     1107
          CON    DMB5        OCTAL/DISPLAY                               R152_OS     1108
          LOC    *O                                                      R152_OS     1109
                                                                         R152_OS     1110
 DMB2     LDD    CM+1        CHANGE TO BYTE ADDRESS                      R152_OS     1111
          SHN    3                                                       R152_OS     1112
          STM    NBUF+1                                                  R152_OS     1113
          LPC    170000                                                  R152_OS     1114
          SHN    3                                                       R152_OS     1115
          LMD    CM                                                      R152_OS     1116
          SHN    3                                                       R152_OS     1117
          STM    NBUF                                                    R152_OS     1118
          LDN    HBDT/10000                                              R152_OS     1119
          UJN    DMB4        PROCESS LIKE HEX WORD DISPLAY               R152_OS     1120
                                                                         R152_OS     1121
 DMB3     LDN    HMDT/10000                                              R152_OS     1122
 DMB4     ADC    2000                                                    R152_OS     1123
          STM    DMBC        SET DISPLAY TYPE                            R152_OS     1124
          LDC    HPDT+6                                                  R152_OS     1125
          RJM    PRN         DISPLAY ADDRESS                             R152_OS     1126
          RJM    LCA         LOAD ADDRESS                                R152_OS     1127
          CRML   NBUF,ON     READ MEMORY WORD                            R152_OS     1128
 DMBC     LDC    HMDT+16D    HEX WORD MEMORY DUMP                        R152_OS     1129
*         LDC    HBDT+16D    HEX BYTE MEMORY DUMP                        R152_OS     1130
          RJM    PRN         DISPLAY CONTENTS OF ADDRESS                 R152_OS     1131
          RJM    DAT         DISPLAY ASCII TEXT                          R152_OS     1132
          UJN    DMB6        COMPLETE LINE AND INCREMENT ADDRESS         R152_OS     1133
                                                                         R152_OS     1134
 DMB5     LDC    OMDT+10                                                 R152_OS     1135
          RJM    PRN         DISPLAY ADDRESS IN OCTAL                    R152_OS     1136
          RJM    LCA         LOAD ADDRESS                                R152_OS     1137
          CRM    NBUF,ON                                                 R152_OS     1138
          LDC    OMDT+20D                                                R152_OS     1139
          RJM    PRN         DISPLAY CONTENTS OF ADDRESS                 R152_OS     1140
          RJM    DDT         DISPLAY TEXT                                R152_OS     1141
 DMB6     RJM    EOL         END LINE                                    R152_OS     1142
          AOD    CM+1                                                    R152_OS     1143
          SHN    -14                                                     R152_OS     1144
          RAD    CM                                                      R152_OS     1145
          LJM    DMB1        CHECK FOR MORE TOO DISPLAY                  R152_OS     1146
 DMR      SPACE  4,10                                                    R152_OS     1147
**        DMR - DUMP MAINTENANCE REGISTER.                               R152_OS     1148
*                                                                        R152_OS     1149
*         ENTRY  (A) - LIST OF REGISTERS TO DISPLAY.                     R152_OS     1150
*                (PC) - PORT CODE OF REGISTERS TO DISPLAY.               R152_OS     1151
*                                                                        R152_OS     1152
*         EXIT   REGISTERS DISPLAYED.                                    R152_OS     1153
*                                                                        R152_OS     1154
*         USES   T5.                                                     R152_OS     1155
*                                                                        R152_OS     1156
*         CALLS  EOL, PRN, RMR, WTC.                                     R152_OS     1157
                                                                         R152_OS     1158
                                                                         R152_OS     1159
 DMR      SUBR               ENTRY/EXIT                                  R152_OS     1160
          STD    T5                                                      R152_OS     1161
          RJM    SMO         SETUP MAINTENANCE REGISTER OPERATION        R152_OS     1162
 DMR1     LDI    T5                                                      R152_OS     1163
          STM    NBUF        SAVE REGISTER NUMBER                        R152_OS     1164
          ADC    -400                                                    R152_OS     1165
          PJN    DMRX        IF END OF LIST                              R152_OS     1166
          LDN    MRDT+2                                                  R152_OS     1167
          RJM    PRN         PRINT 2 HEX DIGIT REGISTER NUMBER           R152_OS     1168
          LDM    NBUF                                                    R152_OS     1169
          RJM    RMR                                                     R152_OS     1170
          LDN    MRDT+20                                                 R152_OS     1171
          RJM    PRN         DISPLAY 20 DIGIT REGISTER                   R152_OS     1172
          AOD    T5                                                      R152_OS     1173
          LDI    T5                                                      R152_OS     1174
          RJM    WTC                                                     R152_OS     1175
          RJM    EOL                                                     R152_OS     1176
          AOD    T5                                                      R152_OS     1177
          LJM    DMR1                                                    R152_OS     1178
 DPS      SPACE  4,10                                                    R152_OS     1179
**        DPS - DEFINE PAGE SIZE.                                        R152_OS     1180
*                                                                        R152_OS     1181
*         ENTRY  (PSMV) = CONTENTS OF PAGE SIZE MASK REGISTER.           R152_OS     1182
*                                                                        R152_OS     1183
*         EXIT   (PSMV) = PAGE SIZE MASK.                                R152_OS     1184
*                (SPTA) = SHIFT INSTRUCTION TO EXTRACT PAGE NUMBER.      R152_OS     1185
                                                                         R152_OS     1186
                                                                         R152_OS     1187
 DPS      SUBR               ENTRY/EXIT                                  R152_OS     1188
          LDC    SHNI+100                                                R152_OS     1189
          STM    SPTA        SET SHIFT INTO PAGE TABLE SEARCH            R152_OS     1190
          LDM    PSMV                                                    R152_OS     1191
          LMC    0#7F                                                    R152_OS     1192
          STD    T2                                                      R152_OS     1193
          STM    PSMV        SET PAGE SIZE MASK                          R152_OS     1194
 DPS1     SOM    SPTA        ADD TO SHIFT COUNT                          R152_OS     1195
          LDD    T2                                                      R152_OS     1196
          SHN    21-0        REMOVE LOWEST BIT                           R152_OS     1197
          STD    T2                                                      R152_OS     1198
          NJN    DPS1        IF MORE BITS PRESENT                        R152_OS     1199
          UJN    DPSX        RETURN                                      R152_OS     1200
 LBA      SPACE  4,10                                                    R152_OS     1201
**        LBA - LOAD BYTE ADDRESS.                                       R152_OS     1202
*                                                                        R152_OS     1203
*         ENTRY  (A) = POINTER TO BYTE ADDRESS.                          R152_OS     1204
*                                                                        R152_OS     1205
*         EXIT   (W4 - W5) = R-REGISTER VALUE.                           R152_OS     1206
*                (A) = CM ADDRESS.                                       R152_OS     1207
*                (W6) = OFFSET FROM R-REGISTER.                          R152_OS     1208
                                                                         R152_OS     1209
                                                                         R152_OS     1210
 LBA      SUBR               ENTRY/EXIT                                  R152_OS     1211
          STD    W6                                                      R152_OS     1212
          LDI    W6                                                      R152_OS     1213
          SHN    7                                                       R152_OS     1214
          STD    W5          SET UPPER PART OF R-REGISTER                R152_OS     1215
          SHN    6                                                       R152_OS     1216
          STD    W4          R-REGISTER BITS 12-18                       R152_OS     1217
          LRD    W4                                                      R152_OS     1218
          LDML   1,W6                                                    R152_OS     1219
          SHN    -3                                                      R152_OS     1220
          STDL   W6          SET OFFSET                                  R152_OS     1221
          LMC    RR                                                      R152_OS     1222
          UJN    LBAX        RETURN                                      R152_OS     1223
 PVC      SPACE  4,10                                                    R152_OS     1224
**        PVC - PRESET VIRTUAL ADDRESS CONSTANTS.                        R152_OS     1225
*                                                                        R152_OS     1226
*         ENTRY  NONE.                                                   R152_OS     1227
*                                                                        R152_OS     1228
*         EXIT   (PTAV - PTAV+1) = PAGE TABLE ADDRESS.                   R152_OS     1229
*                (JPSV - JPSV+1) = JPS VALUE.                            R152_OS     1230
*                (MPSV - MPSV+1) = MPS VALUE.                            R152_OS     1231
*                (PSMV) = PAGE SIZE MASK.                                R152_OS     1232
*                (PTLV) = PAGE TABLE LENGTH MASK.                        R152_OS     1233
*                                                                        R152_OS     1234
*         CALLS  DPS.                                                    R152_OS     1235
*                                                                        R152_OS     1236
*         MACROS READMR.                                                 R152_OS     1237
                                                                         R152_OS     1238
                                                                         R152_OS     1239
 PVC      SUBR               ENTRY/EXIT                                  R152_OS     1240
          LDN    PVCAL                                                   R152_OS     1241
          STD    T5                                                      R152_OS     1242
 PVC1     LDM    PVCA+1,T5                                               R152_OS     1243
          STD    T4          SET DATA ADDRESS                            R152_OS     1244
          LDM    PVCA,T5     GET REGISTER NUMBER                         R152_OS     1245
          STD    RN                                                      R152_OS     1246
          READMR RDATA,ELPR                                              R152_OS     1247
          LDM    RDATA+4     FORM 32 BIT VALUE                           R152_OS     1248
          SHN    10                                                      R152_OS     1249
          LMM    RDATA+5                                                 R152_OS     1250
          STIL   T4                                                      R152_OS     1251
          LDM    RDATA+6                                                 R152_OS     1252
          SHN    10                                                      R152_OS     1253
          LMM    RDATA+7                                                 R152_OS     1254
          STML   1,T4                                                    R152_OS     1255
          LCN    2                                                       R152_OS     1256
          RAD    T5                                                      R152_OS     1257
          PJN    PVC1        IF MORE REGISTERS TO READ                   R152_OS     1258
          RJM    DPS         DEFINE PAGE SIZE                            R152_OS     1259
          LJM    PVCX        RETURN                                      R152_OS     1260
                                                                         R152_OS     1261
 PVCA     BSS    0           TABLE OF REGISTERS                          R152_OS     1262
          LOC    0                                                       R152_OS     1263
          CON    PPTA,PTAV                                               R152_OS     1264
          CON    PJPS,JPSV                                               R152_OS     1265
          CON    PMPS,MPSV                                               R152_OS     1266
          CON    PPSM,PSMV-1                                             R152_OS     1267
 PVCAL    CON    PPTL,PTLV-1                                             R152_OS     1268
          LOC    *O                                                      R152_OS     1269
                                                                         R152_OS     1270
 PTAV     CON    0,0         PAGE TABLE ADDRESS                          R152_OS     1271
 JPSV     CON    0,0         JOB PROCESS STATE POINTER                   R152_OS     1272
 PSMV     CON    0           PAGE SIZE MASK                              R152_OS     1273
 PTLV     CON    0           PAGE TABLE LENGTH VALUE                     R152_OS     1274
 MSA      SPACE  4,10                                                    R152_OS     1275
**        MSA - MAKE SYSTEM VIRTUAL ADDRESS.                             R152_OS     1276
*                                                                        R152_OS     1277
*         ENTRY  (A) - ADDRESS OF EXCHANGE PACKAGE ADDRESS.              R152_OS     1278
*                (BA - BA+2) = PROCESS VIRTUAL ADDRESS.                  R152_OS     1279
*                                                                        R152_OS     1280
*         EXIT   (CM - CM+2) = SYSTEM VIRTUAL ADDRESS.                   R152_OS     1281
*                                                                        R152_OS     1282
*         CALLS  LBA.                                                    R152_OS     1283
                                                                         R152_OS     1284
                                                                         R152_OS     1285
 MSA1     LDN    0           FLAG INVALID/MISSING SEGMENT                R152_OS     1286
                                                                         R152_OS     1287
 MSA      SUBR               ENTRY/EXIT                                  R152_OS     1288
          RJM    LBA         LOAD BYTE ADDRESS                           R152_OS     1289
          ADN    16D         SEGMENT TABLE LENGTH                        R152_OS     1290
          CRDL   T1                                                      R152_OS     1291
          ADN    34D-16D     SEGMENT TABLE ADDRESS                       R152_OS     1292
          CRDL   T2                                                      R152_OS     1293
          ADN    1                                                       R152_OS     1294
          CRDL   T3                                                      R152_OS     1295
          LDDL   T1                                                      R152_OS     1296
          SBD    BA                                                      R152_OS     1297
          MJN    MSA1        IF NOT A VALID SEGMENT                      R152_OS     1298
          LDN    T2                                                      R152_OS     1299
          RJM    LBA         LOAD ADDRESS OF SEGMENT TABLE               R152_OS     1300
          ADD    BA                                                      R152_OS     1301
          CRDL   W0          FETCH ASID                                  R152_OS     1302
          LDDL   W1                                                      R152_OS     1303
          ZJN    MSA1        IF NOT A VALID ASID                         R152_OS     1304
          STDL   CM                                                      R152_OS     1305
          LDDL   BA+1        COPY REMAINDER OF PVA                       R152_OS     1306
          STDL   CM+1                                                    R152_OS     1307
          LDDL   BA+2                                                    R152_OS     1308
          STDL   CM+2                                                    R152_OS     1309
          LDN    1                                                       R152_OS     1310
          UJN    MSAX        RETURN                                      R152_OS     1311
 SPT      SPACE  4,10                                                    R152_OS     1312
**        SPT - SEARCH PAGE TABLE.                                       R152_OS     1313
*                                                                        R152_OS     1314
*         ENTRY  (CM - CM+2) = SYSTEM VIRTUAL ADDRESS.                   R152_OS     1315
*                                                                        R152_OS     1316
*         EXIT   (A) = ADDRESS OF WORD.                                  R152_OS     1317
*                                                                        R152_OS     1318
*         CALLS  LBA.                                                    R152_OS     1319
                                                                         R152_OS     1320
                                                                         R152_OS     1321
 SPT      SUBR               ENTRY/EXIT                                  R152_OS     1322
          LDDL   CM+1                                                    R152_OS     1323
          SHN    20-11                                                   R152_OS     1324
          SCN    77          EXTRACT PAGE NUMBER                         R152_OS     1325
          STDL   T3                                                      R152_OS     1326
          LDDL   CM+2                                                    R152_OS     1327
          SHN    -11                                                     R152_OS     1328
          RADL   T3                                                      R152_OS     1329
 SPTA     SHN    -0                                                      R152_OS     1330
          LMDL   CM          EXCLUSIVE OR WITH ASID                      R152_OS     1331
          SHN    1                                                       R152_OS     1332
          STDL   T2          PAGE TABLE INDEX                            R152_OS     1333
          LDDL   T3                                                      R152_OS     1334
          LPML   PSMV                                                    R152_OS     1335
          STD    T5          BYTE NUMBER/2**9                            R152_OS     1336
          LDDL   T3                                                      R152_OS     1337
          SBD    T5          PAGE NUMBER                                 R152_OS     1338
          STDL   T4                                                      R152_OS     1339
          LDC    PTAV                                                    R152_OS     1340
          RJM    LBA         SET ADDRESS OF PAGE TABLE                   R152_OS     1341
          LDM    PTLV                                                    R152_OS     1342
          SHN    11                                                      R152_OS     1343
          LMC    777                                                     R152_OS     1344
          STDL   T3          SET PAGE TABLE LENGTH MASK                  R152_OS     1345
          LDN    32D                                                     R152_OS     1346
          STD    T1          SET SEARCH LIMIT                            R152_OS     1347
 SPT1     LDDL   T2          PAGE TABLE INDEX                            R152_OS     1348
          LPDL   T3          PAGE TABLE LENGTH MASK                      R152_OS     1349
          ADDL   W6          PAGE TABLE OFFSET FROM R                    R152_OS     1350
          LMC    RR                                                      R152_OS     1351
          CRDL   W0          PAGE TABLE ENTRY                            R152_OS     1352
          LDDL   W0                                                      R152_OS     1353
          SHN    21-17                                                   R152_OS     1354
          PJN    SPT2        IF INVALID PAGE                             R152_OS     1355
          SHN    2                                                       R152_OS     1356
          SCN    0#F                                                     R152_OS     1357
          STDL   W0          EXTRACT ASID                                R152_OS     1358
          LDDL   W1                                                      R152_OS     1359
          SHN    4-20                                                    R152_OS     1360
          RADL   W0          COMPLETE ASID                               R152_OS     1361
          LMDL   CM                                                      R152_OS     1362
          NJN    SPT2        IF NOT CORRECT ASID                         R152_OS     1363
          LDDL   W1          EXTRACT PAGE NUMBER                         R152_OS     1364
          LPN    77                                                      R152_OS     1365
          SHN    20-6                                                    R152_OS     1366
          STDL   W1                                                      R152_OS     1367
          LDDL   W2                                                      R152_OS     1368
          SHN    -6                                                      R152_OS     1369
          RADL   W1                                                      R152_OS     1370
          LMDL   T4                                                      R152_OS     1371
          ZJN    SPT3        IF PAGE FOUND                               R152_OS     1372
 SPT2     AODL   T2          INCREMENT PAGE TABLE INDEX                  R152_OS     1373
          SOD    T1          DECREMENT SEARCH COUNT                      R152_OS     1374
          NJN    SPT1        IF MORE TO SEARCH                           R152_OS     1375
          LJM    SPTX        RETURN                                      R152_OS     1376
                                                                         R152_OS     1377
 SPT3     LDDL   W3          CREATE RMA                                  R152_OS     1378
          STD    T2                                                      R152_OS     1379
          SHN    -14                                                     R152_OS     1380
          STD    T1                                                      R152_OS     1381
          LDD    CM+2                                                    R152_OS     1382
          LPC    770                                                     R152_OS     1383
          SHN    11                                                      R152_OS     1384
          LMD    T5          INCLUDE UPPER BITS OF BYTE NUMBER           R152_OS     1385
          SHN    6                                                       R152_OS     1386
          LMC    RR                                                      R152_OS     1387
          LRD    T1                                                      R152_OS     1388
          LJM    SPTX        RETURN                                      R152_OS     1389
          SPACE  4,10                                                    R152_OS     1390
 DNV      SPACE  4,10                                                    R152_OS     1391
**        DNV - DECODE NUMERIC VALUE.                                    R152_OS     1392
*                                                                        R152_OS     1393
*         ENTRY  (A) - NUMBER LENGTH + 10000*NUMBER TYPE.                R152_OS     1394
*                (NC) - NEXT CHARACTER IN LINE.                          R152_OS     1395
*                                                                        R152_OS     1396
*         EXIT   NUMBER IN ABUF.                                         R152_OS     1397
*                                                                        R152_OS     1398
*         USES   T2, T3, T4, T5, FC.                                     R152_OS     1399
*                                                                        R152_OS     1400
*         CALLS  CLB, SKP, TND.                                          R152_OS     1401
*                                                                        R152_OS     1402
*         MACROS PRINT.                                                  R152_OS     1403
                                                                         R152_OS     1404
                                                                         R152_OS     1405
 DNV      SUBR               ENTRY/EXIT                                  R152_OS     1406
          STD    T5          SAVE NUMBER LENGTH (MAX)                    R152_OS     1407
          SHN    -14                                                     R152_OS     1408
          LPN    7                                                       R152_OS     1409
          STD    T2          SET DECODE TYPE                             R152_OS     1410
          LDM    DNVC,T2     SET DIGIT MASK                              R152_OS     1411
          STM    DNVA                                                    R152_OS     1412
          LDM    DNVD,T2     SET UNPACKING ROUTINE                       R152_OS     1413
          STM    DNVB                                                    R152_OS     1414
          RJM    CLB         CLEAR BUFFER                                R152_OS     1415
          RJM    SKP         SKIP DELIMITERS                             R152_OS     1416
          ZJN    DNVX        IF END OF LINE                              R152_OS     1417
          LDD    NC                                                      R152_OS     1418
          STD    FC                                                      R152_OS     1419
 DNV1     RJM    TND         TRANSLATE NUMERIC DIGIT                     R152_OS     1420
          MJN    DNV3        IF NOT NUMBER                               R152_OS     1421
          STI    NC          SAVE DIGIT RETURNED                         R152_OS     1422
 DNVA     SCN    7           CHECK IF OUT OF RANGE                       R152_OS     1423
          NJN    DNV2        IF NUMBER TOO LARGE                         R152_OS     1424
          AOD    NC          ADVANCE CHARACTER POSITION                  R152_OS     1425
          UJN    DNV1        PROCESS NEXT CHARACTER                      R152_OS     1426
                                                                         R152_OS     1427
 DNV2     LJM    CMDE        RETURN ERROR                                R152_OS     1428
                                                                         R152_OS     1429
 DNV3     LDD    NC                                                      R152_OS     1430
          SBN    1                                                       R152_OS     1431
          STD    T4                                                      R152_OS     1432
          LDC    ABUF                                                    R152_OS     1433
          STD    T3                                                      R152_OS     1434
          SBD    T5                                                      R152_OS     1435
          STD    T5                                                      R152_OS     1436
          LDN    0                                                       R152_OS     1437
          STD    T2                                                      R152_OS     1438
 DNV4     LDI    T4          GET NEXT DIGIT                              R152_OS     1439
          LJM    **,T2                                                   R152_OS     1440
 DNVB     EQU    *-1                                                     R152_OS     1441
                                                                         R152_OS     1442
 DNV5     STD    T2          SAVE BYTE POSITION                          R152_OS     1443
          NJN    DNV6        IF CURRENT WORD NOT COMPLETED               R152_OS     1444
          SOD    T3          DECREMENT BUFFER POSITION                   R152_OS     1445
          SBD    T5                                                      R152_OS     1446
          MJN    DNV2        IF NUMBER TOO LARGE                         R152_OS     1447
 DNV6     SOD    T4                                                      R152_OS     1448
          SBD    FC                                                      R152_OS     1449
          PJN    DNV4        IF MORE DIGITS TO ASSEMBLE                  R152_OS     1450
          LDIL   T5                                                      R152_OS     1451
          NJN    DNV2        IF NUMBER OVERFLOW                          R152_OS     1452
          LDN    1                                                       R152_OS     1453
          LJM    DNVX        RETURN                                      R152_OS     1454
                                                                         R152_OS     1455
**        MRNT - MAINTENANCE REGISTER NUMBER TYPE.                       R152_OS     1456
                                                                         R152_OS     1457
 DNV7     SHN    22-4                                                    R152_OS     1458
          SHN    4                                                       R152_OS     1459
          RAI    T3                                                      R152_OS     1460
          AOD    T2                                                      R152_OS     1461
          LPN    1                                                       R152_OS     1462
          LJM    DNV5                                                    R152_OS     1463
                                                                         R152_OS     1464
**        OWNT - OCTAL WORD NUMBER TYPE.                                 R152_OS     1465
                                                                         R152_OS     1466
 DNV8     SHN    22-3                                                    R152_OS     1467
          SHN    22-3                                                    R152_OS     1468
          SHN    22-3                                                    R152_OS     1469
          SHN    11                                                      R152_OS     1470
          RAI    T3                                                      R152_OS     1471
 DNV9     AOD    T2                                                      R152_OS     1472
          LPN    3                                                       R152_OS     1473
          LJM    DNV5        CONTINUE                                    R152_OS     1474
                                                                         R152_OS     1475
**        HWNT - HEX WORD NUMBER TYPE.                                   R152_OS     1476
                                                                         R152_OS     1477
 DNV10    SHN    22-4                                                    R152_OS     1478
          SHN    22-4                                                    R152_OS     1479
          SHN    22-4                                                    R152_OS     1480
          SHN    14                                                      R152_OS     1481
          RAIL   T3                                                      R152_OS     1482
          UJN    DNV9        CONTINUE                                    R152_OS     1483
                                                                         R152_OS     1484
*         HEX PP WORD NUMBER TYPE.                                       R152_OS     1485
                                                                         R152_OS     1486
 DNV11    SHN    22-4                                                    R152_OS     1487
          SHN    22-4                                                    R152_OS     1488
          SHN    10                                                      R152_OS     1489
          RAI    T3                                                      R152_OS     1490
          AOD    T2                                                      R152_OS     1491
          SBN    3                                                       R152_OS     1492
          ZJN    DNV9        IF START NEXT WORD                          R152_OS     1493
          LJM    DNV6        CONTINUE                                    R152_OS     1494
                                                                         R152_OS     1495
                                                                         R152_OS     1496
 TBLI     SET    0                                                       R152_OS     1497
                                                                         R152_OS     1498
 MRNT     INDEX  DNV7,SCNI+17  MAINTENANCE REGISTER NUMBER TYPE          R152_OS     1499
 OWNT     INDEX  DNV8,SCNI+7   OCTAL WORD NUMBER TYPE                    R152_OS     1500
 HWNT     INDEX  DNV10,SCNI+17 HEX WORD NUMBER TYPE                      R152_OS     1501
 HPNT     INDEX  DNV11,SCNI+17 HEX PP WORD NUMBER TYPE                   R152_OS     1502
                                                                         R152_OS     1503
 DNVC     BSS    0           TABLE OF *SCN*-S                            R152_OS     1504
 TBLB     HERE                                                           R152_OS     1505
                                                                         R152_OS     1506
                                                                         R152_OS     1507
 DNVD     BSS    0           TABLE OF PROCESSOR ADDRESSES                R152_OS     1508
 TBLA     HERE                                                           R152_OS     1509
                                                                         R152_OS     1510
 OCWD     EQU    OWNT                                                    R152_OS     1511
 HXWD     EQU    HPNT                                                    R152_OS     1512
 HXBT     EQU    HPNT+400000                                             R152_OS     1513
 GAC      SPACE  4,10                                                    R152_OS     1514
**        GAC - GET ALPHABETIC CHARACTER.                                R152_OS     1515
*                                                                        R152_OS     1516
*         ENTRY  (NC) = ADDRESS OF THE NEXT CHARACTER.                   R152_OS     1517
*                                                                        R152_OS     1518
*         EXIT   (A) = CHARACTER (IF ALPHABETIC).                        R152_OS     1519
*                (A) = -1 (IF NOT).                                      R152_OS     1520
*                (NC) = INCREMENTED IF ALPHABETIC CHARACTER.             R152_OS     1521
*                                                                        R152_OS     1522
*         CALLS  CLC.                                                    R152_OS     1523
                                                                         R152_OS     1524
                                                                         R152_OS     1525
 GAC1     LCN    1           NOT ALPHABETIC CHARACTER                    R152_OS     1526
                                                                         R152_OS     1527
 GAC      SUBR               ENTRY/EXIT                                  R152_OS     1528
          RJM    CLC         CLASSIFY NEXT CHARACTER                     R152_OS     1529
          SBN    ALSY                                                    R152_OS     1530
          NJN    GAC1        IF NOT ALPHABETIC CHARACTER                 R152_OS     1531
          AOD    NC                                                      R152_OS     1532
          LDD    CH          GET ALPHABETIC UPPER CASE CHARACTER         R152_OS     1533
          SBN    40                                                      R152_OS     1534
          UJN    GACX        RETURN                                      R152_OS     1535
 PPF      SPACE  4,10                                                    R152_OS     1536
**        PPF - FUNCTION MCH TO DO SOMETHING TO PP.                      R152_OS     1537
*                                                                        R152_OS     1538
*         ENTRY  (A) = FUNCTION FOR PP.                                  R152_OS     1539
*                                                                        R152_OS     1540
*         EXIT   PP IN IDLE/LOAD/DUMP MODE.                              R152_OS     1541
*                                                                        R152_OS     1542
*         CALLS  DNV.                                                    R152_OS     1543
*                                                                        R152_OS     1544
*         MACROS WRITMR.                                                 R152_OS     1545
                                                                         R152_OS     1546
                                                                         R152_OS     1547
 PPF      SUBR               ENTRY/EXIT                                  R152_OS     1548
          STM    PPFA+6                                                  R152_OS     1549
          SHN    -14                                                     R152_OS     1550
          NJN    PPF1        IF PP NUMBER NOT NEEDED                     R152_OS     1551
          LDD    PP                                                      R152_OS     1552
          LMN    40                                                      R152_OS     1553
          STM    PPFA+4                                                  R152_OS     1554
 PPF1     READMR MRBF,ELIO,DEMR  SAVE REGISTER                           R152_OS     1555
          WRITMR PPFA,ELIO                                               R152_OS     1556
          WRITMR MRBF,ELIO                                               R152_OS     1557
          LJM    PPFX        RETURN                                      R152_OS     1558
                                                                         R152_OS     1559
 PPFA     BSSZ   4                                                       R152_OS     1560
          CON    40          AUTO BIT                                    R152_OS     1561
          CON    0                                                       R152_OS     1562
          CON    34          LOAD/DUMP/IDLE                              R152_OS     1563
          CON    40          ENABLE LOAD/DUMP/IDLE                       R152_OS     1564
 PRN      SPACE  4,10                                                    R152_OS     1565
**        PRN - PRINT NUMBER.                                            R152_OS     1566
*                                                                        R152_OS     1567
*         ENTRY  (A) - NUMBER OF DIGITS TO PRINT.                        R152_OS     1568
*                (PRNA) - ROUTINE TO UNPACK DIGITS.                      R152_OS     1569
*                                                                        R152_OS     1570
*         EXIT   NUMBER WRITTEN TO DISPLAY.                              R152_OS     1571
*                                                                        R152_OS     1572
*         USES   CH, T2, T3, T4.                                         R152_OS     1573
*                                                                        R152_OS     1574
*         CALLS  OUT, WND.                                               R152_OS     1575
                                                                         R152_OS     1576
                                                                         R152_OS     1577
 PRN      SUBR               ENTRY/EXIT                                  R152_OS     1578
          STD    T4          SET NUMBER OF DIGITS TO OUTPUT              R152_OS     1579
          SHN    -14                                                     R152_OS     1580
          STD    T2                                                      R152_OS     1581
          LDM    PRNB,T2     GET UNPACKING ROUTINE                       R152_OS     1582
          STM    PRNA        SET JUMP ADDRESS                            R152_OS     1583
          LDN    0           SET STARTING DIGIT FOR UNPACK               R152_OS     1584
          STD    T2                                                      R152_OS     1585
          LDC    NBUF        SET BUFFER POSITION                         R152_OS     1586
          STD    T3                                                      R152_OS     1587
 PRN1     LDIL   T3          READ BUFFER VALUE                           R152_OS     1588
          LJM    PRN4,T2     UNPACK DIGITS                               R152_OS     1589
 PRNA     EQU    *-1                                                     R152_OS     1590
                                                                         R152_OS     1591
 PRN2     STD    T2          SET NEXT DIGIT POSITION                     R152_OS     1592
          NJN    PRN3        IF NO ADVANCE OF POINTER                    R152_OS     1593
          AOD    T3                                                      R152_OS     1594
 PRN3     LDD    CH          GET CHARACTER TO OUTPUT                     R152_OS     1595
          RJM    WND         OUTPUT TO CC545                             R152_OS     1596
          SOD    T4          DECREMENT CHARACTER COUNT                   R152_OS     1597
          NJN    PRN1        IF MORE DIGITS TO PRINT                     R152_OS     1598
          LDN    1R +40                                                  R152_OS     1599
          RJM    OUT                                                     R152_OS     1600
          UJN    PRNX        RETURN                                      R152_OS     1601
                                                                         R152_OS     1602
**        MAINTENANCE REGISTER DIGITS.                                   R152_OS     1603
                                                                         R152_OS     1604
 PRN4     SHN    -4          GET UPPER DIGIT                             R152_OS     1605
          STD    CH          SAVE VALUE                                  R152_OS     1606
          LDD    T2                                                      R152_OS     1607
          LMN    1                                                       R152_OS     1608
          UJN    PRN2        CONTINUE PRINT                              R152_OS     1609
                                                                         R152_OS     1610
**        OCTAL MEMORY DIGIT.                                            R152_OS     1611
                                                                         R152_OS     1612
 PRN5     SHN    -3          GET UPPER DIGIT                             R152_OS     1613
          SHN    -3          GET UPPER MIDDLE DIGIT                      R152_OS     1614
          SHN    -3          GET LOWER MIDDLE DIGIT                      R152_OS     1615
          LPN    7                                                       R152_OS     1616
 PRN6     STD    CH          SAVE VALUE                                  R152_OS     1617
          AOD    T2                                                      R152_OS     1618
          LPN    3                                                       R152_OS     1619
          LJM    PRN2        CONTINUE PRINT                              R152_OS     1620
                                                                         R152_OS     1621
**        HEX MEMORY DIGIT.                                              R152_OS     1622
                                                                         R152_OS     1623
 PRN7     SHN    -4          GET UPPER DIGIT                             R152_OS     1624
          SHN    -4          GET UPPER MIDDLE DIGIT                      R152_OS     1625
          SHN    -4          GET LOWER MIDDLE DIGIT                      R152_OS     1626
          UJN    PRN6        SAVE VALUE AND ADVANCE POSITION             R152_OS     1627
                                                                         R152_OS     1628
 PRN8     SHN    -4                                                      R152_OS     1629
          SHN    -4                                                      R152_OS     1630
          LPN    17                                                      R152_OS     1631
          STD    CH                                                      R152_OS     1632
          AOD    T2                                                      R152_OS     1633
          SBN    3                                                       R152_OS     1634
          ZJN    PRN10                                                   R152_OS     1635
 PRN9     LDD    T2                                                      R152_OS     1636
 PRN10    LJM    PRN2        CONTINUE PRINT                              R152_OS     1637
                                                                         R152_OS     1638
 PRN11    SHN    -4                                                      R152_OS     1639
          SHN    -4                                                      R152_OS     1640
          SHN    -4                                                      R152_OS     1641
          STD    CH                                                      R152_OS     1642
          AOD    T2                                                      R152_OS     1643
          LPN    3                                                       R152_OS     1644
          STD    T2                                                      R152_OS     1645
          LPN    1                                                       R152_OS     1646
          ZJN    PRN9        CONTINUE PRINT                              R152_OS     1647
          LDN    1R +40                                                  R152_OS     1648
          RJM    OUT                                                     R152_OS     1649
          UJN    PRN9        CONTINUE PRINT                              R152_OS     1650
                                                                         R152_OS     1651
                                                                         R152_OS     1652
 TBLI     SET    0                                                       R152_OS     1653
                                                                         R152_OS     1654
 MRDT     INDEX  PRN4        MAINTENANCE REGISTER DISPLAY TYPE           R152_OS     1655
 OMDT     INDEX  PRN5        OCTAL MEMORY DISPLAY TYPE                   R152_OS     1656
 HMDT     INDEX  PRN7        HEX MEMORY DISPLAY TYPE                     R152_OS     1657
 HPDT     INDEX  PRN8        HEX PP DISPLAY TYPE                         R152_OS     1658
 HBDT     INDEX  PRN11       HEX BYTE DISPLAY TYPE                       R152_OS     1659
                                                                         R152_OS     1660
 PRNB     BSS    0           INDEXED TABLE                               R152_OS     1661
 TBLA     HERE                                                           R152_OS     1662
 PRM      SPACE  4,10                                                    R152_OS     1663
**        PRM - DECODE PARAMETER LIST.                                   R152_OS     1664
*                                                                        R152_OS     1665
*         ENTRY  (T7) = POINTER TO COMMAND ENTRY.                        R152_OS     1666
*                KEYBOARD LINE IN *BUF*.                                 R152_OS     1667
*                                                                        R152_OS     1668
*         EXIT   (PARAMETER LIST DECODED.                                R152_OS     1669
*                                                                        R152_OS     1670
*        USES  T1-7, CM - CM+3, NC                                       R152_OS     1671
                                                                         R152_OS     1672
                                                                         R152_OS     1673
 PRM      SUBR               ENTRY/EXIT                                  R152_OS     1674
          LDM    2,T7                                                    R152_OS     1675
          ZJN    PRMX        IF NO PARAMETER SYNTAX                      R152_OS     1676
          STD    CM                                                      R152_OS     1677
          STD    CM+1                                                    R152_OS     1678
          LDM    3,T7                                                    R152_OS     1679
          STD    CM+3                                                    R152_OS     1680
          LDN    1                                                       R152_OS     1681
          STD    CM+2                                                    R152_OS     1682
 PRM0     LDD    CM+2        SET PARAMETER NUMBER                        R152_OS     1683
          SHN    14                                                      R152_OS     1684
          LMI    CM+1                                                    R152_OS     1685
          STIL   CM+1                                                    R152_OS     1686
          SHN    -13                                                     R152_OS     1687
          LPN    1                                                       R152_OS     1688
          ADN    2                                                       R152_OS     1689
          RAD    CM+1                                                    R152_OS     1690
          AOD    CM+2        INCREMENT PARAMETER NUMBER                  R152_OS     1691
          LDI    CM+1                                                    R152_OS     1692
          NJN    PRM0        ADVANCE THROUGH LIST                        R152_OS     1693
          STD    CM+2                                                    R152_OS     1694
          LDM    1,CM        PARAMETER NAME LIST                         R152_OS     1695
          STD    CM+1                                                    R152_OS     1696
          LJM    PRM11       ENTER LOOP                                  R152_OS     1697
                                                                         R152_OS     1698
 PRM1     RJM    SKP         CLASSIFY CHARACTER                          R152_OS     1699
          SBN    ALSY                                                    R152_OS     1700
          ZJN    PRM3        IF SYMBOL                                   R152_OS     1701
          ADN    ALSY-NBSY                                               R152_OS     1702
          ZJN    PRM2.6      IF ERROR                                    R152_OS     1703
 PRM2     LJM    CMDE        PROCESS ERROR                               R152_OS     1704
                                                                         R152_OS     1705
 PRM2.5   LDD    T5                                                      R152_OS     1706
          STD    NC                                                      R152_OS     1707
 PRM2.6   LDD    CM          SET CURRENT PARAMETER                       R152_OS     1708
          STD    T6                                                      R152_OS     1709
          LDM    1,T6                                                    R152_OS     1710
          STD    T7          SET CURRENT PARAMETER POINTER               R152_OS     1711
          LDI    T6                                                      R152_OS     1712
          SHN    21-13                                                   R152_OS     1713
          MJN    PRM2        IF PARAMETER MUST BE EQUIVALENCED           R152_OS     1714
          LJM    PRM6        IF NUMBER                                   R152_OS     1715
                                                                         R152_OS     1716
 PRM3     LDD    NC                                                      R152_OS     1717
          STD    T5                                                      R152_OS     1718
          RJM    ASN         ASSEMBLE NAME                               R152_OS     1719
          ZJN    PRM2.5      IF ERROR                                    R152_OS     1720
          LDN    3                                                       R152_OS     1721
          STD    T2          SET TABLE ENTRY SIZE                        R152_OS     1722
          LDD    CM+1                                                    R152_OS     1723
          RJM    SFN         SEARCH FOR NAME                             R152_OS     1724
          ZJN    PRM2.5      IF ERROR                                    R152_OS     1725
          STD    T6          SET NEW PARAMETER POINTER                   R152_OS     1726
          LDI    T6                                                      R152_OS     1727
          SHN    21-13                                                   R152_OS     1728
          PJN    PRM4        IF MULTIPLE EQUIVALENCES                    R152_OS     1729
          LDM    2,T6                                                    R152_OS     1730
          STD    T1                                                      R152_OS     1731
          LDM    2,T7                                                    R152_OS     1732
          STI    T1                                                      R152_OS     1733
 PRM4     RJM    SKP         SKIP SPACES                                 R152_OS     1734
          SBN    EQSY                                                    R152_OS     1735
          ZJN    PRM5        IF *=*                                      R152_OS     1736
          UJN    PRM10       NO VALUE TO BE SET                          R152_OS     1737
                                                                         R152_OS     1738
 PRM5     AOD    NC          INCREMENT PAST *=*                          R152_OS     1739
 PRM6     LDI    T6                                                      R152_OS     1740
          LPN    17                                                      R152_OS     1741
          NJN    PRM8        IF CAN BE EQUIVALENCED                      R152_OS     1742
 PRM7     LJM    CMDE        PROCESS ERROR                               R152_OS     1743
                                                                         R152_OS     1744
 PRM8     STD    T1                                                      R152_OS     1745
          LDD    CM+3                                                    R152_OS     1746
          SHN    14                                                      R152_OS     1747
          LMD    T1                                                      R152_OS     1748
          RJM    DNV         DECODE NUMBER                               R152_OS     1749
          LDI    T6                                                      R152_OS     1750
          LPN    17                                                      R152_OS     1751
          STD    T1          SET WORD LENGTH                             R152_OS     1752
          LDC    ABUF                                                    R152_OS     1753
          SBD    T1                                                      R152_OS     1754
          STD    T3                                                      R152_OS     1755
          LDM    2,T7        SET VARIABLE ADDRESS                        R152_OS     1756
          STD    T4                                                      R152_OS     1757
 PRM9     AOD    T3                                                      R152_OS     1758
          LDIL   T3                                                      R152_OS     1759
          STIL   T4                                                      R152_OS     1760
          AOD    T4                                                      R152_OS     1761
          SOD    T1                                                      R152_OS     1762
          NJN    PRM9        IF NOT DONE COPYING                         R152_OS     1763
 PRM10    LDIL   T6          CLEAR NOT REFERENCED BIT                    R152_OS     1764
          STI    T6                                                      R152_OS     1765
          SHN    -14                                                     R152_OS     1766
          ZJN    PRM7        IF ALREADY USED                             R152_OS     1767
          LMC    SHNI                                                    R152_OS     1768
          STM    PRMA                                                    R152_OS     1769
          LDN    1                                                       R152_OS     1770
 PRMA     SHN    0                                                       R152_OS     1771
          RADL   CM+2        SET USED BIT FOR PARAMETER                  R152_OS     1772
          LDI    CM                                                      R152_OS     1773
          SHN    -13                                                     R152_OS     1774
          LPN    1                                                       R152_OS     1775
          ADN    2                                                       R152_OS     1776
          RAD    CM                                                      R152_OS     1777
 PRM11    LDI    CM                                                      R152_OS     1778
          ZJN    PRM13       IF END OF PARAMETER LIST                    R152_OS     1779
          RJM    SKP                                                     R152_OS     1780
          ZJN    PRM13       IF END OF LIST                              R152_OS     1781
          LDD    T3                                                      R152_OS     1782
          ZJN    PRM12.5     IF ONE OR NO COMMAS                         R152_OS     1783
          SOD    T3                                                      R152_OS     1784
 PRM12    ZJN    PRM12.5                                                 R152_OS     1785
          SOD    T3                                                      R152_OS     1786
          LDI    CM                                                      R152_OS     1787
          SHN    -13                                                     R152_OS     1788
          LPN    1                                                       R152_OS     1789
          ADN    2                                                       R152_OS     1790
          RAD    CM                                                      R152_OS     1791
          LDD    T3                                                      R152_OS     1792
          UJN    PRM12       CHECK FOR MORE COMMAS                       R152_OS     1793
                                                                         R152_OS     1794
 PRM12.5  LJM    PRM1        GO BACK FOR NEXT PARAMETER                  R152_OS     1795
                                                                         R152_OS     1796
 PRM13    LDD    CM+2        GET PARAMETER COUNT                         R152_OS     1797
          LJM    PRMX        RETURN                                      R152_OS     1798
 SKP      SPACE  4,10                                                    R152_OS     1799
**        SKP - SKIP SEPARATORS.                                         R152_OS     1800
*                                                                        R152_OS     1801
*         EXIT   (A) = 0, IF END OF LINE.                                R152_OS     1802
*                    = 1, IF NUMBER OR ALPHABETIC.                       R152_OS     1803
*                (NC) = NEXT CHARACTER POSITION.                         R152_OS     1804
*                                                                        R152_OS     1805
*         CALLS  CLC.                                                    R152_OS     1806
                                                                         R152_OS     1807
                                                                         R152_OS     1808
 SKP2     SBN    1R,-1R                                                  R152_OS     1809
          NJN    SKP3         IF NOT COMMA                               R152_OS     1810
          AOD    NC                                                      R152_OS     1811
          AOD    T3                                                      R152_OS     1812
          UJN    SKP1                                                    R152_OS     1813
                                                                         R152_OS     1814
 SKP3     RJM    CLC         CLASSIFY CHARACTER                          R152_OS     1815
                                                                         R152_OS     1816
 SKP      SUBR               ENTRY/EXIT                                  R152_OS     1817
          LDN    0                                                       R152_OS     1818
          STD    T3                                                      R152_OS     1819
 SKP1     LDI    NC                                                      R152_OS     1820
          ZJN    SKPX        IF END OF LINE                              R152_OS     1821
          SBN    1R +40                                                  R152_OS     1822
          NJN    SKP2        IF NOT SPACE                                R152_OS     1823
          AOD    NC                                                      R152_OS     1824
          UJN    SKP1        CHECK NEXT CHARACTER                        R152_OS     1825
 TBR      SPACE  4,10                                                    R152_OS     1826
**        TBR - TRANSLATE BIT REGISTER.                                  R152_OS     1827
*                                                                        R152_OS     1828
*         ENTRY  (A) = BIT TEXT DEFINITION TABLE.                        R152_OS     1829
*                (PP) = REGISTER CONTENTS.                               R152_OS     1830
*                                                                        R152_OS     1831
*         EXIT   BIT DEFINITIONS PRINTED.                                R152_OS     1832
                                                                         R152_OS     1833
                                                                         R152_OS     1834
 TBR2     RJM    EOL         COMPLETE LINE                               R152_OS     1835
                                                                         R152_OS     1836
 TBR      SUBR               ENTRY/EXIT                                  R152_OS     1837
          STD    RN          SET TABLE ADDRESS                           R152_OS     1838
          LDDL   PP                                                      R152_OS     1839
          ZJN    TBRX        IF NO BITS DEFINED                          R152_OS     1840
          LDI    RN                                                      R152_OS     1841
          RJM    WTC         WRITE STRING                                R152_OS     1842
 TBR1     AOD    RN          POSITION IN TABLE                           R152_OS     1843
          LDDL   PP          CHECK NEXT BIT                              R152_OS     1844
          ZJN    TBR2        RETURN                                      R152_OS     1845
          SHN    1                                                       R152_OS     1846
          STDL   PP                                                      R152_OS     1847
          SHN    21-20                                                   R152_OS     1848
          PJN    TBR1        IF BIT NOT SET                              R152_OS     1849
          LDI    RN                                                      R152_OS     1850
          ZJN    TBR1        IF NO MESSAGE                               R152_OS     1851
          RJM    WTC         WRITE STRING                                R152_OS     1852
          LDN    1R,+40                                                  R152_OS     1853
          RJM    OUT                                                     R152_OS     1854
          UJN    TBR1        CHECK NEXT BIT                              R152_OS     1855
 TND      SPACE  4,10                                                    R152_OS     1856
**        TND - TRANSLATE NUMERIC DIGIT.                                 R152_OS     1857
*                                                                        R152_OS     1858
*         ENTRY  (NC) = ADDRESS OF NEXT CHARACTER IN LINE.               R152_OS     1859
*                                                                        R152_OS     1860
*         EXIT   (A) = VALUE OF NUMBER (IF PRESENT).                     R152_OS     1861
*                    = -1 (IF NOT PRESENT).                              R152_OS     1862
*                                                                        R152_OS     1863
*         USES   CH.                                                     R152_OS     1864
*                                                                        R152_OS     1865
*         CALLS  CLC.                                                    R152_OS     1866
                                                                         R152_OS     1867
                                                                         R152_OS     1868
 TND2     LCN    1           IF NOT A NUMBER                             R152_OS     1869
                                                                         R152_OS     1870
 TND      SUBR               ENTRY/EXIT                                  R152_OS     1871
          RJM    CLC         CLASSIFY CHARACTER                          R152_OS     1872
          SBN    NBSY                                                    R152_OS     1873
          ZJN    TND1        IF NUMBER                                   R152_OS     1874
          SBN    ALSY-NBSY                                               R152_OS     1875
          NJN    TND2        IF NOT ALPHABETIC                           R152_OS     1876
          LCN    1RA-10D+40                                              R152_OS     1877
 TND1     RAD    CH          CONVERT TO NUMBER                           R152_OS     1878
          UJN    TNDX        RETURN                                      R152_OS     1879
 WTC      SPACE  4,10                                                    R152_OS     1880
**        WTC - WRITE CODED STRING.                                      R152_OS     1881
*                                                                        R152_OS     1882
*         ENTRY (A) - ADDRESS OF STRING TO OUTPUT.                       R152_OS     1883
*                                                                        R152_OS     1884
*         T2, T3, T4.                                                    R152_OS     1885
*                                                                        R152_OS     1886
*         CALLS  EOL, OUT.                                               R152_OS     1887
                                                                         R152_OS     1888
                                                                         R152_OS     1889
 WTC2     LDD    T4                                                      R152_OS     1890
          ZJN    WTCX        IF NO EOLN TO BE PRINTED                    R152_OS     1891
          RJM    EOL                                                     R152_OS     1892
                                                                         R152_OS     1893
 WTC      SUBR               ENTRY/EXIT                                  R152_OS     1894
          STD    T3                                                      R152_OS     1895
          SHN    -14                                                     R152_OS     1896
          STD    T4                                                      R152_OS     1897
          LDN    0                                                       R152_OS     1898
          STD    T2                                                      R152_OS     1899
 WTC1     LDI    T3                                                      R152_OS     1900
          ZJN    WTC2        IF END OF LINE                              R152_OS     1901
          SHN    -6                                                      R152_OS     1902
          ADN    40          CONVERT TO REAL ASCII                       R152_OS     1903
          RJM    OUT                                                     R152_OS     1904
          LDI    T3                                                      R152_OS     1905
          LPN    77                                                      R152_OS     1906
          ADN    40          CONVERT TO REAL ASCII                       R152_OS     1907
          RJM    OUT                                                     R152_OS     1908
          AOD    T3                                                      R152_OS     1909
          UJN    WTC1        PROCESS NEXT TWO BYTES                      R152_OS     1910
          EJECT                                                          R152_OS     1911
 CLB      SPACE  4,10                                                    R152_OS     1912
**        CLB - CLEAR BUFFER.                                            R152_OS     1913
*                                                                        R152_OS     1914
*         ENTRY  NONE.                                                   R152_OS     1915
*                                                                        R152_OS     1916
*         EXIT   BUFFER CLEARED.                                         R152_OS     1917
*                                                                        R152_OS     1918
*         USES   T2.                                                     R152_OS     1919
                                                                         R152_OS     1920
                                                                         R152_OS     1921
 CLB      SUBR               ENTRY/EXIT                                  R152_OS     1922
          LDN    17                                                      R152_OS     1923
          STD    T2                                                      R152_OS     1924
 CLB1     LDN    0                                                       R152_OS     1925
          STM    NBUF,T2     CLEAR BUFFER ENTRY                          R152_OS     1926
          SOD    T2                                                      R152_OS     1927
          PJN    CLB1        IF MORE BUFFER TO CLEAR                     R152_OS     1928
          UJN    CLBX        RETURN                                      R152_OS     1929
 CLC      SPACE  4,10                                                    R152_OS     1930
**        CLC - CLASSIFY CHARACTER.                                      R152_OS     1931
*                                                                        R152_OS     1932
*         ENTRY  (NC) = ADDRESS OF NEXT CHARACTER IN LINE.               R152_OS     1933
*                                                                        R152_OS     1934
*         EXIT   (A) = CHARACTER TYPE.                                   R152_OS     1935
*                  0 = END OF LINE.                                      R152_OS     1936
*                  1 = CONTROL.                                          R152_OS     1937
*                  2 = EQUALS SIGN.                                      R152_OS     1938
*                  3 = NUMERIC.                                          R152_OS     1939
*                  4 = ALPHABETIC.                                       R152_OS     1940
*                (CH) = UPPERCASE CHARACTER, IF ALPHABETIC.              R152_OS     1941
*                    = BINARY VALUE, IF NUMERIC.                         R152_OS     1942
*                                                                        R152_OS     1943
*         USES   CH, T1.                                                 R152_OS     1944
                                                                         R152_OS     1945
                                                                         R152_OS     1946
 CLC1     AOD    T1          ALPHABETIC                                  R152_OS     1947
 CLC2     AOD    T1          NUMERIC                                     R152_OS     1948
 CLC3     AOD    T1          SEPERATOR                                   R152_OS     1949
 CLC4     AOD    T1          CONTROL CHARACTOR                           R152_OS     1950
                                                                         R152_OS     1951
 CLC      SUBR               ENTRY/EXIT                                  R152_OS     1952
          LDN    0                                                       R152_OS     1953
          STD    T1          ASSUME (CR)                                 R152_OS     1954
          LDI    NC          GET THE NEXT CHARACTER                      R152_OS     1955
          ZJN    CLCX        IF END OF LINE                              R152_OS     1956
          SBN    1R0-+40                                                 R152_OS     1957
          STD    CH          SAVE NUMERIC VALUE                          R152_OS     1958
          MJN    CLC4        IF BAD CHARACTER                            R152_OS     1959
          SBN    10D                                                     R152_OS     1960
          MJN    CLC2        IF NUMBER                                   R152_OS     1961
          SBN    1R=-1R9-1                                               R152_OS     1962
          ZJN    CLC3        IF *=*                                      R152_OS     1963
          SBN    1RA-1R=                                                 R152_OS     1964
          MJN    CLC3        IF SEPERATOR                                R152_OS     1965
          LDI    NC          CONVERT TO UPPER CASE                       R152_OS     1966
          LPC    137                                                     R152_OS     1967
          STD    CH                                                      R152_OS     1968
          LPN    37                                                      R152_OS     1969
          SBN    1                                                       R152_OS     1970
          MJN    CLC3        IF SEPERATOR                                R152_OS     1971
          SBN    1R[-1RA                                                 R152_OS     1972
          MJN    CLC1        IF ALPHABETIC                               R152_OS     1973
          UJN    CLC3        SEPERATOR                                   R152_OS     1974
                                                                         R152_OS     1975
 CRSY     EQU    0           END OF LINE SYMBOL                          R152_OS     1976
 CCSY     EQU    1           CONTROL CHARACTER SYMBOL                    R152_OS     1977
 EQSY     EQU    2           SEPARATER SYMBOL                            R152_OS     1978
 NBSY     EQU    3           NUMBER SYMBOL                               R152_OS     1979
 ALSY     EQU    4           ALPHABETIC SYMBOL                           R152_OS     1980
 EOL      SPACE  4,10                                                    R152_OS     1981
**        EOL - WRITE END OF LINE.                                       R152_OS     1982
*                                                                        R152_OS     1983
*         EXIT   TO *MDD1* IF INPUT PENDING.                             R152_OS     1984
*                                                                        R152_OS     1985
*         CALLS  OUT.                                                    R152_OS     1986
                                                                         R152_OS     1987
 EOL      SUBR               ENTRY/EXIT                                  R152_OS     1988
          LDN    CR                                                      R152_OS     1989
          RJM    OUT                                                     R152_OS     1990
          LDN    LF                                                      R152_OS     1991
          RJM    OUT                                                     R152_OS     1992
          LDN    1                                                       R152_OS     1993
          RJM    CPS         CHECK PORT STATUS                           R152_OS     1994
          LDM    SSMX        CHECK FOR INPUT                             R152_OS     1995
          SHN    21-3                                                    R152_OS     1996
          PJN    EOLX        IF NO INPUT                                 R152_OS     1997
          LJM    MDD1        PROCESS INPUT LINE                          R152_OS     1998
 LCA      SPACE  4,10                                                    R152_OS     1999
**        LCA - LOAD CM ADDRESS.                                         R152_OS     2000
*                                                                        R152_OS     2001
*         ENTRY  (CM,CM+1) = CM ADDRESS.                                 R152_OS     2002
*                                                                        R152_OS     2003
*         EXIT   (R-REGISTER) (A) = CM ADDRESS.                          R152_OS     2004
                                                                         R152_OS     2005
                                                                         R152_OS     2006
 LCA      SUBR               ENTRY/EXIT                                  R152_OS     2007
          LDD    CM                                                      R152_OS     2008
          SHN    6                                                       R152_OS     2009
          STD    T2                                                      R152_OS     2010
          LPC    770000                                                  R152_OS     2011
          SHN    6                                                       R152_OS     2012
          STD    T1                                                      R152_OS     2013
          LRD    T1                                                      R152_OS     2014
          LDD    CM+1                                                    R152_OS     2015
          LMC    400000                                                  R152_OS     2016
          UJN    LCAX        RETURN                                      R152_OS     2017
 NCH      SPACE  4,10                                                    R152_OS     2018
**        NCH - GET THE NEXT CHARACTER.                                  R152_OS     2019
*                                                                        R152_OS     2020
*         ENTRY  NONE                                                    R152_OS     2021
*                                                                        R152_OS     2022
*         EXIT   (CH) - NEXT CHARACTER.                                  R152_OS     2023
*                (A)- NEXT CHARACTER.                                    R152_OS     2024
*                                                                        R152_OS     2025
*         CALLS  CSS, OUT.                                               R152_OS     2026
                                                                         R152_OS     2027
                                                                         R152_OS     2028
 NCH2     LPC    177         TRIM ANY PARITY                             R152_OS     2029
          STD    CH                                                      R152_OS     2030
          RJM    OUT         ECHO TO TERMINAL                            R152_OS     2031
                                                                         R152_OS     2032
 NCH      SUBR               ENTRY/EXIT                                  R152_OS     2033
                                                                         R152_OS     2034
 NCH1     RJM    RCT         READ CHARACTER FROM TERMINAL                R152_OS     2035
          NJN    NCH2        IF VALID CHARACTER READ                     R152_OS     2036
          LDC    1000                                                    R152_OS     2037
          SBN    1                                                       R152_OS     2038
          NJN    *-1                                                     R152_OS     2039
*         LDN    0                                                       R152_OS     2040
          RJM    CPS         CHECK PORT STATUS                           R152_OS     2041
          UJN    NCH1        TRY AGAIN                                   R152_OS     2042
 OUT      SPACE  4,10                                                    R152_OS     2043
**        OUT - OUTPUT CHARACTERS.                                       R152_OS     2044
*                                                                        R152_OS     2045
*         ENTRY  (A) = CHARACTER TO OUTPUT.                              R152_OS     2046
*                                                                        R152_OS     2047
*         USES   T1.                                                     R152_OS     2048
*                                                                        R152_OS     2049
*         CALLS  CSS.                                                    R152_OS     2050
                                                                         R152_OS     2051
                                                                         R152_OS     2052
 OUT      SUBR               ENTRY/EXIT                                  R152_OS     2053
          RJM    WCT         WRITE CHARACTER TO TERMINAL                 R152_OS     2054
          UJN    OUTX        RETURN                                      R152_OS     2055
 PAC      SPACE  4,10                                                    R152_OS     2056
**        PAC - PRINT ASCII CHARACTER.                                   R152_OS     2057
*                                                                        R152_OS     2058
*         ENTRY  (A) = CHARACTER.                                        R152_OS     2059
*                                                                        R152_OS     2060
*         EXIT   CHARACTER PRINTED.                                      R152_OS     2061
*                                                                        R152_OS     2062
*         CALLS  OUT.                                                    R152_OS     2063
                                                                         R152_OS     2064
                                                                         R152_OS     2065
 PAC      SUBR               ENTRY/EXIT                                  R152_OS     2066
          LPC    0#7F                                                    R152_OS     2067
          SBN    40                                                      R152_OS     2068
          PJN    PAC1        IF PRINTABLE CHARACTER                      R152_OS     2069
          LDN    1R                                                      R152_OS     2070
 PAC1     ADN    40                                                      R152_OS     2071
          RJM    OUT         PRINT                                       R152_OS     2072
          UJN    PACX        RETURN                                      R152_OS     2073
 PDC      SPACE  4,10                                                    R152_OS     2074
**        PDC - PRINT DISPLAYCODE CHARACTER.                             R152_OS     2075
*                                                                        R152_OS     2076
*         ENTRY  (A) = DISPLAY CODE CHARACTER.                           R152_OS     2077
*                                                                        R152_OS     2078
*         EXIT   CHARACTER CONVERTED TO ASCII AND PRINTED.               R152_OS     2079
*                                                                        R152_OS     2080
*         CALLS  OUT.                                                    R152_OS     2081
                                                                         R152_OS     2082
                                                                         R152_OS     2083
 PDC      SUBR               ENTRY/EXIT                                  R152_OS     2084
          ZJN    PDC2        IF COLON                                    R152_OS     2085
          SBN    33                                                      R152_OS     2086
          PJN    PDC1        IF NOT ALPHABETIC                           R152_OS     2087
          ADC    1RA-1+33+40                                             R152_OS     2088
          UJN    PDC3        PRINT IT                                    R152_OS     2089
                                                                         R152_OS     2090
 PDC1     SBN    10D                                                     R152_OS     2091
          PJN    PDC2        IF NOT NUMERIC                              R152_OS     2092
          ADN    1R0+10D+40                                              R152_OS     2093
          UJN    PDC3        PRINT IT                                    R152_OS     2094
                                                                         R152_OS     2095
 PDC2     LDN    1R +40                                                  R152_OS     2096
 PDC3     RJM    OUT         OUTPUT ASCII CHARACTER                      R152_OS     2097
          UJN    PDCX        RETURN                                      R152_OS     2098
 RMR      SPACE  4,10                                                    R152_OS     2099
**        RMR - READ MAINTENANCE REGISTER.                               R152_OS     2100
*                                                                        R152_OS     2101
*         ENTRY  (A) - REGISTER TO READ.                                 R152_OS     2102
*                (PC) - CONNECT CODE.                                    R152_OS     2103
*                                                                        R152_OS     2104
*         EXIT   (NBUF,NBUF+8) = REGISTER VALUE.                         R152_OS     2105
*                                                                        R152_OS     2106
*         USES   RN.                                                     R152_OS     2107
*                                                                        R152_OS     2108
*         MACROS READMR.                                                 R152_OS     2109
                                                                         R152_OS     2110
                                                                         R152_OS     2111
 RMR      SUBR               ENTRY/EXIT                                  R152_OS     2112
          STD    RN          SET REGISTER NUMBER                         R152_OS     2113
          READMR NBUF                                                    R152_OS     2114
          UJN    RMRX        RETURN                                      R152_OS     2115
 SFN      SPACE  4,10                                                    R152_OS     2116
**        SFN - SEARCH FOR NAME.                                         R152_OS     2117
*                                                                        R152_OS     2118
*         ENTRY  (A) = TABLE ADDRESS.                                    R152_OS     2119
*                (T2) = ENTRY SIZE.                                      R152_OS     2120
*                                                                        R152_OS     2121
*         EXIT   (A) = MATCHING ENTRY IN TABLE.                          R152_OS     2122
*                                                                        R152_OS     2123
*         USES   T7.                                                     R152_OS     2124
                                                                         R152_OS     2125
                                                                         R152_OS     2126
 SFN      SUBR               ENTRY/EXIT                                  R152_OS     2127
          SBD    T2                                                      R152_OS     2128
          STD    T7                                                      R152_OS     2129
 SFN1     LDD    T2                                                      R152_OS     2130
          RAD    T7                                                      R152_OS     2131
          LDI    T7          GET NEXT COMMAND                            R152_OS     2132
          ZJN    SFNX        IF NO MATCH                                 R152_OS     2133
          LMM    ASNA        COMPARE TO CHARACTERS FROM LINE             R152_OS     2134
          NJN    SFN1        IF NO MATCH                                 R152_OS     2135
 SFN2     LDM    1,T7        GET TABLE PARAMETER                         R152_OS     2136
          UJN    SFNX        RETURN                                      R152_OS     2137
 SMO      SPACE  4,10                                                    R152_OS     2138
**        SMO - SETUP MAINTENANCE REGISTER OPERATION.                    R152_OS     2139
*                                                                        R152_OS     2140
*         ENTRY  (A) = ADDRESS OF MR TABLE.                              R152_OS     2141
*                                                                        R152_OS     2142
*         EXIT   (EC) = CONNECT CODE.                                    R152_OS     2143
*                (RN) = REGISTER NUMBER.                                 R152_OS     2144
                                                                         R152_OS     2145
                                                                         R152_OS     2146
 SMO      SUBR               ENTRY/EXIT                                  R152_OS     2147
          STD    T2                                                      R152_OS     2148
          LDM    -1,T2                                                   R152_OS     2149
          STM    MRPE-1                                                  R152_OS     2150
          STD    T2                                                      R152_OS     2151
          LDI    T2                                                      R152_OS     2152
          STD    EC                                                      R152_OS     2153
          LDM    MRPE        FETCH REGISTER NUMBER                       R152_OS     2154
          STD    RN                                                      R152_OS     2155
          LDDL   CM+2                                                    R152_OS     2156
          UJN    SMOX        RETURN                                      R152_OS     2157
 SMP      SPACE  4,10                                                    R152_OS     2158
**        SMP - SET MEMORY PARAMETERS.                                   R152_OS     2159
*                                                                        R152_OS     2160
*         ENTRY  (VAL1 - VAL1+1) = MEMORY ADDRESS.                       R152_OS     2161
*                (VAL3 - VAL3+1) = INCREMENT VALUE.                      R152_OS     2162
*                (VAL2) = WORD COUNT.                                    R152_OS     2163
*                                                                        R152_OS     2164
*         EXIT   (CM - CM+1) = MEMORY ADDRESS.                           R152_OS     2165
*                (PP) = WORD COUNT.                                      R152_OS     2166
*                (A) = MEMORY ADDRESS RELATIVE TO R.                     R152_OS     2167
*                                                                        R152_OS     2168
*         CALLS  LCA.                                                    R152_OS     2169
                                                                         R152_OS     2170
                                                                         R152_OS     2171
 SMP      SUBR               ENTRY/EXIT                                  R152_OS     2172
          LDM    VAL3+1      INCREMENT MEMORY ADDRESS                    R152_OS     2173
          RAM    VAL1+1                                                  R152_OS     2174
          STD    CM+1                                                    R152_OS     2175
          SHN    -14                                                     R152_OS     2176
          ADM    VAL3                                                    R152_OS     2177
          RAM    VAL1                                                    R152_OS     2178
          STD    CM                                                      R152_OS     2179
          LDN    0                                                       R152_OS     2180
          STM    VAL3        CLEAR INCREMENT                             R152_OS     2181
          STM    VAL3+1                                                  R152_OS     2182
          LDM    VAL2                                                    R152_OS     2183
          STD    PP                                                      R152_OS     2184
          RJM    LCA         LOAD CM ADDRESS                             R152_OS     2185
          UJN    SMPX        RETURN                                      R152_OS     2186
 TBA      SPACE  4,10                                                    R152_OS     2187
**        TBA - TRANSLATE BYTE ADDRESS.                                  R152_OS     2188
*                                                                        R152_OS     2189
*         ENTRY  (A) = PTR TO ADDRESS IN TWO WORDS.                      R152_OS     2190
*                                                                        R152_OS     2191
*         EXIT   (VAL1 - VAL1+1) = WORD ADDRESS.                         R152_OS     2192
*                (CM - CM+1) = WORD ADDRESS.                             R152_OS     2193
*                (RN) = WORD COUNT.                                      R152_OS     2194
*                (A) = MEMORY ADDRESS RELATIVE TO R.                     R152_OS     2195
*                                                                        R152_OS     2196
*         CALLS  SMP.                                                    R152_OS     2197
*                                                                        R152_OS     2198
*         USES   T1.                                                     R152_OS     2199
                                                                         R152_OS     2200
                                                                         R152_OS     2201
 TBA      SUBR               ENTRY/EXIT                                  R152_OS     2202
          STD    T1                                                      R152_OS     2203
          LDI    T1                                                      R152_OS     2204
          SHN    22-3                                                    R152_OS     2205
          STM    VAL1                                                    R152_OS     2206
          SHN    -3                                                      R152_OS     2207
          LPC    170000                                                  R152_OS     2208
          LMM    1,T1                                                    R152_OS     2209
          SHN    -3                                                      R152_OS     2210
          STM    VAL1+1                                                  R152_OS     2211
          RJM    SMP         SET MEMORY PARAMETERS                       R152_OS     2212
          UJN    TBAX        RETURN                                      R152_OS     2213
 WND      SPACE  4,10                                                    R152_OS     2214
**        WND - WRITE NUMERIC DATA.                                      R152_OS     2215
*                                                                        R152_OS     2216
*         ENTRY  (A) - DATA TO PRINT.                                    R152_OS     2217
*                                                                        R152_OS     2218
*         CALLS  OUT.                                                    R152_OS     2219
                                                                         R152_OS     2220
                                                                         R152_OS     2221
 WND      SUBR               ENTRY/EXIT                                  R152_OS     2222
          LPN    17          EXTRACT HEX DIGIT                           R152_OS     2223
          SBN    10D                                                     R152_OS     2224
          MJN    WND1        IF DECIMAL DIGIT                            R152_OS     2225
          ADN    1RA-1R0-10D                                             R152_OS     2226
 WND1     ADN    1R0+40+10D  FORM ASCII DIGIT                            R152_OS     2227
          RJM    OUT                                                     R152_OS     2228
          UJN    WNDX        RETURN                                      R152_OS     2229
          EJECT                                                          R152_OS     2230
**        BUFFERS.                                                       R152_OS     2231
                                                                         R152_OS     2232
 NBUF     BSS    10                                                      R152_OS     2233
 ABUF     BSS    1                                                       R152_OS     2234
 MRBF     BSS    10                                                      R152_OS     2235
          SPACE  4,10                                                    R152_OS     2236
          CODE   *                                                       R152_OS     2237
          BASE   *                                                       R152_OS     2238
 QUAL$    IF     -DEF,QUAL$                                              R152_OS     2239
          QUAL   *                                                       R152_OS     2240
 MDD      EQU    /COMPMDD/MDD                                            R152_OS     2241
 CLS      EQU    /COMPMDD/CLS                                            R152_OS     2242
 CMDP     EQU    /COMPMDD/CMDP                                           R152_OS     2243
 EOL      EQU    /COMPMDD/EOL                                            R152_OS     2244
 WTC      EQU    /COMPMDD/WTC                                            R152_OS     2245
 DMB      EQU    /COMPMDD/DMB                                            R152_OS     2246
 DMR      EQU    /COMPMDD/DMR                                            R152_OS     2247
 MRPA     EQU    /COMPMDD/MRPA                                           R152_OS     2248
 PVC      EQU    /COMPMDD/PVC                                            R152_OS     2249
 CMDR     EQU    /COMPMDD/CMDR                                           R152_OS     2250
 CMDX     EQU    /COMPMDD/CMDX                                           R152_OS     2251
 VAL1     EQU    /COMPMDD/VAL1                                           R152_OS     2252
 VAL2     EQU    /COMPMDD/VAL2                                           R152_OS     2253
 VAL3     EQU    /COMPMDD/VAL3                                           R152_OS     2254
 QUAL$    ENDIF                                                          R152_OS     2255
          ENDX                                                           R152_OS     2256
                                                                         R152_OS     2257
*DECK DECK=COMPMDM EXPAND=FALSE
          CTEXT  COMPMDM - MAINTENANCE DISPLAY MACROS.                   R152_OS        1
 COMPMDM  SPACE  4,10                                                    R152_OS        2
***       COMPMDM - MAINTENANCE DISPLAY MACROS.                          R152_OS        3
*         B. R. HANSON.      81/09/10.                                   R152_OS        4
          SPACE  4,10                                                    R152_OS        5
***              COMPMDM DEFINES SEVERAL MACROS WHICH ARE USED IN TO     R152_OS        6
*         INTERFACE WITH THE MAINTENANCE DRIVER COMMON DECK              R152_OS        7
*         *COMPMDD*.                                                     R152_OS        8
 CMND     SPACE  4,10                                                    R152_OS        9
**        CMND - DEFINE COMMAND.                                         R152_OS       10
*                                                                        R152_OS       11
* XX      CMND   ADDR,(SYNTAX)                                           R152_OS       12
*                                                                        R152_OS       13
*         XX - TWO CHARACTER COMMAND.                                    R152_OS       14
*         ADDR - COMMAND PROCESSING ROUTINE.                             R152_OS       15
                                                                         R152_OS       16
                                                                         R152_OS       17
          MACRO  CMND,XX,ADDR,DTYP,PADR,SYNTX                            R152_OS       18
          LOCAL  PADDR                                                   R152_OS       19
          IFC    EQ,$PADR$$                                              R152_OS       20
 PADDR    EQU    *                                                       R152_OS       21
          ENDIF                                                          R152_OS       22
 CMDS     RMT                                                            R152_OS       23
          CON    2R_XX                                                   R152_OS       24
          CON    ADDR                                                    R152_OS       25
          IFC    EQ,$DTYP$$                                              R152_OS       26
          CON    0,0                                                     R152_OS       27
          ELSE                                                           R152_OS       28
          CON    PADR PADDR                                              R152_OS       29
          CON    DTYP/10000                                              R152_OS       30
          ENDIF                                                          R152_OS       31
          RMT                                                            R152_OS       32
 HELP     RMT                                                            R152_OS       33
          IFC    EQ,$SYNTX$$                                             R152_OS       34
          CON    0                                                       R152_OS       35
          ELSE   1                                                       R152_OS       36
          CON    =C*SYNTX*                                               R152_OS       37
          RMT                                                            R152_OS       38
          ENDM                                                           R152_OS       39
 INDEX    SPACE  4,10                                                    R152_OS       40
**        INDEX - FORM INDEXED TABLES OF DATA.                           R152_OS       41
*                                                                        R152_OS       42
* ORD     INDEX  V1,V2                                                   R152_OS       43
*                                                                        R152_OS       44
*         ORD = ORDINAL * 10000.                                         R152_OS       45
*         V1  = VALUE TO PLACE IN TABLE *TBLA*.                          R152_OS       46
*         V2  = VALUE TO PLACE IN TABLE *TBLB*.                          R152_OS       47
                                                                         R152_OS       48
                                                                         R152_OS       49
          PURGMAC INDEX                                                  R152_OS       50
          MACRO  INDEX,ORD,V1,V2                                         R152_OS       51
 ORD      EQU    TBLI*10000                                              R152_OS       52
 TBLI     SET    TBLI+1                                                  R152_OS       53
          IFC    NE,$V1$$,3                                              R152_OS       54
 TBLA     RMT                                                            R152_OS       55
          CON    V1                                                      R152_OS       56
          RMT                                                            R152_OS       57
          IFC    NE,$V2$$,3                                              R152_OS       58
 TBLB     RMT                                                            R152_OS       59
          CON    V2                                                      R152_OS       60
          RMT                                                            R152_OS       61
          ENDM                                                           R152_OS       62
 PRM      SPACE  4,10                                                    R152_OS       63
**        PRM - DEFINE PARAMETER LIST FOR COMMAND.                       R152_OS       64
*                                                                        R152_OS       65
* VAR     PRM    ADDR,WC                                                 R152_OS       66
*                                                                        R152_OS       67
*         VAR - PARAMETER NAME.                                          R152_OS       68
*         ADDR- ADDRESS TO STORE VALUE.                                  R152_OS       69
*         WC  - SIZE OF VALUE IN PP WORDS.                               R152_OS       70
*                                                                        R152_OS       71
*         IF *VAR* IS OMMITTED THEN THIS PARAMETER HAS A                 R152_OS       72
*         LIST OF SEVERAL NAMES WHICH MAY BE USED.  IN THIS              R152_OS       73
*         CASE, *ADDR* IS THE ADDRESS TO STORE THE ADDRESS               R152_OS       74
*         GIVEN IN THE SELECTED ALTERNATIVE.  IF *WC* IS                 R152_OS       75
*         OMMITTED, THE PARAMETER MUST BE ONE OF THE ALTERNATIVES        R152_OS       76
*         AND MAY NOT HAVE AN EQUIVALENCED VALUE.  IF *VAR*              R152_OS       77
*         IS OMMITTED, A LIST OF *PRMV* MACROS MUST FOLLOW WHICH         R152_OS       78
*         DEFINE THE ALTERNATE NAMES FOR THIS PARAMETER.                 R152_OS       79
                                                                         R152_OS       80
                                                                         R152_OS       81
          MACRO  PRM,VAR,ADDR,WC                                         R152_OS       82
          LOCAL  HDR                                                     R152_OS       83
          QUAL                                                           R152_OS       84
 PRMC     SET    PRMC+1                                                  R152_OS       85
 PRMV     DECMIC PRMC,4                                                  R152_OS       86
          QUAL   *                                                       R152_OS       87
 HDR      SET    WC 0                                                    R152_OS       88
          IFC    EQ,$VAR$$                                               R152_OS       89
 P"PRMV"  CON    HDR+4000,V"PRMV",ADDR                                   R152_OS       90
          ELSE                                                           R152_OS       91
 P"PRMV"  CON    HDR,V"PRMV"                                             R152_OS       92
 VAR      PRMV   ADDR                                                    R152_OS       93
          ENDIF                                                          R152_OS       94
          ENDM                                                           R152_OS       95
                                                                         R152_OS       96
 PRMC     SET    0                                                       R152_OS       97
 PRMV     SPACE  4,10                                                    R152_OS       98
**        PRMV - PARAMETER NAME DESCRIPTOR.                              R152_OS       99
*                                                                        R152_OS      100
* VAR     PRMV   ADDR                                                    R152_OS      101
*                                                                        R152_OS      102
*         THIS MACRO IS USED TO LIST OPTIONAL NAMES FOR A GIVEN          R152_OS      103
*         PARAMETER.                                                     R152_OS      104
*                                                                        R152_OS      105
*         VAR  - PARAMETER NAME.                                         R152_OS      106
*         ADDR - ADDRESS TO STORE THE VALUE OR VALUE ITSELF.             R152_OS      107
                                                                         R152_OS      108
                                                                         R152_OS      109
          MACRO  PRMV,VAR,ADDR                                           R152_OS      110
          LOCAL  PRML                                                    R152_OS      111
 PRML     DECMIC PRMC,4                                                  R152_OS      112
 PRMV     RMT                                                            R152_OS      113
          IF     -DEF,V"PRML",1                                          R152_OS      114
 V"PRML"  BSS    0                                                       R152_OS      115
          CON    2R_VAR                                                  R152_OS      116
          CON    P"PRML"                                                 R152_OS      117
          CON    ADDR                                                    R152_OS      118
          RMT                                                            R152_OS      119
          ENDM                                                           R152_OS      120
 PRME     SPACE  4,10                                                    R152_OS      121
**        PRME - END PARAMETER LIST.                                     R152_OS      122
*                                                                        R152_OS      123
*         PRME                                                           R152_OS      124
                                                                         R152_OS      125
                                                                         R152_OS      126
 PRME     MACRO                                                          R152_OS      127
          CON    0                                                       R152_OS      128
 PRMV     HERE                                                           R152_OS      129
          CON    0                                                       R152_OS      130
          ENDM                                                           R152_OS      131
 PRINT    SPACE  4,10                                                    R152_OS      132
**        PRINT - PRINT LINE.                                            R152_OS      133
*                                                                        R152_OS      134
                                                                         R152_OS      135
                                                                         R152_OS      136
 PRINT    MACRO  M                                                       R152_OS      137
          CODE   A                                                       R152_OS      138
          LDC    =C*M*+10000                                             R152_OS      139
          RJM    WTC                                                     R152_OS      140
          CODE   *                                                       R152_OS      141
          ENDM                                                           R152_OS      142
 MR       SPACE  4,10                                                    R152_OS      143
**        MR - DESCRIBE MAINTENANCE REGISTER.                            R152_OS      144
*                                                                        R152_OS      145
*                                                                        R152_OS      146
                                                                         R152_OS      147
                                                                         R152_OS      148
          MACRO  MR,HV,STR                                               R152_OS      149
          CON    0#;A                                                    R152_OS      150
          CON    =C*STR*                                                 R152_OS      151
          ENDM                                                           R152_OS      152
          ENDX                                                           R152_OS      153
*DECK DECK=COMPTMA EXPAND=FALSE
          CTEXT  COMPTMA - TWO-PORT MULTIPLEXOR ACCESS.
          SPACE  4
QUAL$     IF     -DEF,QUAL$
          QUAL   COMPTMA
QUAL$     ENDIF
          BASE   M
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4
***       COMPTMA - TWO-PORT MULTIPLEXOR ACCESS.
*         B. R. HANSON
          SPACE  4
***              COMPTMA DEFINES ROUTINES TO TALK WITH A TERMINAL
*         ON THE TWO PORT MULTIPLEXOR.  THESE ROUTINES OBSERVE THE
*         PROTOCOL FOR ACCESSING A PORT ON THE MULTIPLEXOR AND FOR
*         TALKING WITH THAT PORT.  THIS PROTOCOL PROVIDES FOR SHARING
*         THE PORT AND THE MULTIPLEXOR BETWEEN PP PROGRAMS AND
*         OPERATING SYSTEMS.
*
*         THE PROTOCOL FOR ACCESSING A TERMINAL ON THE TWO PORT MUX
*         IS AS FOLLOWS.
*
*         THE IOU TEST-MODE REGISTER (A0) CONTAINS SIX BITS RESERVED
*         FOR SOFTWARE USE - BITS 58-63.  THEY ARE DEFINED AS
*                58 - NOT USED.
*                59 - NOT USED.
*                60 - PORT 1 REQUESTED.
*                61 - PORT 0 REQUESTED.
*                62 - PORT 1 RESERVED.
*                63 - PORT 0 RESERVED.
*
*         WHEN A PP PROGRAM WANTS TO USE A PORT ON THE TWO PORT MUX,
*         IT MUST SET THE *RESERVED* BIT IN THE TEST-MODE REGISTER.  IF
*         THAT BIT IS ALREADY SET, IT MAY SET THE *REQUESTED* BIT IN
*         THE REGISTER AND WAIT FOR THE OTHER PP TO RELEASE THE PORT
*         BY CLEARING THE *RESERVED* BIT.
*
*         THE SHARING OF THE TWO-PORT MULTIPLEXOR BETWEEN TWO PP-S
*         TALKING TO SEPERATE PORTS ON THE MULTIPLEXOR IS THROUGH
*         THE CHANNEL 15 AND 17 FLAGS.  SINCE THE *SCF* INSTRUCTION
*         FOR CHANNEL 15 DOES NOT GUARANTEE EXCLUSIVE ACCESS TO THE
*         CHANNEL, THE CHANNEL FLAG FOR CHANNEL 17 MUST BE USED TO
*         ENSURE THIS CONDITION.  THE SEQUENCE OF ACCESS TO CHANNEL
*         15 SHOULD BE -
*
*         SCF 17             INTERLOCK CHANNEL 17
*         SCF 15             INTERLOCK CHANNEL 15
*         CCF 17             CLEAR INTERLOCK ON 17
*         SELECT PORT
*         STATUS PORT
*         PERFORM IO OPERATION
*         DESELECT PORT
*         CCF 15             CLEAR INTERLOCK ON 15
*
*         THE FUNCTIONS PROVIDED BY THIS COMMON DECK ARE -
*           *STM* - SELECT TERMINAL ON MULTIPLEXOR.  GAINS ACCESS TO
*                A SPECIFIC PORT ON THE MULTIPLEXOR.
*           *CPR* - CHECK FOR PORT REQUEST.  CHECKS THE TEST-MODE REG
*                FOR REQUESTS FOR ACCESS TO THE PORT BEING USED.
*           *RCT* - READ CHARACTER FROM TERMINAL.  DOES THE OPERATIONS
*                NEEDED TO READ A CHARACTER FROM THE TERMINAL ON THE
*                PORT BEING USED.
*           *WCT* - WRITE CHARACTER TO TERMINAL.  DOES THE OPERATIONS
*                NEEDED TO WRITE A CHARACTER TO THE TERMINAL CONNECTED
*                TO THE PORT BEING USED.
*           *GTS* - GET TERMINAL STATUS.  GETS JUST THE STATUS INFO
*                FOR THE PORT BEING USED.
          SPACE  4,10
          PURGMAC DCN*
 DCN*     PPOP   4,7500      DEFINE *DCN**
          SPACE  4
**        GLOBAL DATA FOR ALL ROUTINES.
*


 RBUF     BSSZ   10          MAINTENANCE REGISTER BUFFER
 SFMX     CON    0           PORT SELECT FUNCTION
 SSMX     CON    0           LAST TERMINAL STATUS
 CPA      SPACE  4
**        CPA - CLEAR PORT ACCESS.
*
*         ENTRY  TWO-PORT MUX IS RESERVED BY THIS PP.
*
*         EXIT   TWO-PORT MUX IS DESELECTED AND CHANNEL IS RELEASED.


 CPA      SUBR               ENTRY/EXIT
          FNC    MXDM,MX     DESELECT MULTIPLEXOR
          AJM    *,MX        WAIT FOR FUNCTION COMPLETE
          CCF    *,MX        RELEASE CHANNEL INTERLOCK
          UJN    CPAX        RETURN
 CPR      SPACE  4,10
**        CPR - CHECK FOR PORT REQUEST.
*
*         ENTRY  PORT RESERVED BY THIS PP.
*
*         EXIT   (A) = 0, IF NO REQUEST FOR THIS PORT
*
*         CALLS  RSB.


 CPR      SUBR               ENTRY/EXIT
          RJM    RSB         READ STATUS BITS
          SHN    -2          IGNORE PORT RESERVED BIT
          UJN    CPRX        RETURN
 DLY      SPACE  4,10
**        DLY - DELAY FOR .05 OF A SECOND.
*
*         ENTRY  NONE.
*
*         EXIT   0.05 SECONDS LATER.
*
*         USES   A.


 DLY      SUBR               ENTRY/EXIT
          LDC    100000
 DLY1     SBN    1
          PJN    DLY1        IF DELAY NOT EXPIRED
          UJN    DLYX        RETURN
 GTS      SPACE  4,10
**        GTS - GET TERMINAL STATUS.
*
*         ENTRY  NONE.
*
*         EXIT   (A) = STATUS OF TERMINAL.
*
*         CALLS  CPA, SPA.


 GTS      SUBR               ENTRY/EXIT
          RJM    SPA         SET PORT ACCESS
          RJM    CPA         CLEAR PORT ACCESS
          UJN    GTSX        RETURN
 RCT      SPACE  4,10
**        RCT - READ CHARACTER FROM TERMINAL.
*
*         ENTRY  PORT RESERVED BY THIS PP.
*
*         EXIT   (A) = CHARACTER DESIRED.
*                (A) = 0, IF NO CHARACTER PRESENT.
*
*         CALLS  CPA, SPA, WCT.


 RCT1     FNC    MXRD,MX     READ CHARACTER FUNCTION
          AJM    *,MX        WAIT FOR FUNCTION COMPLETE
          ACN    MX
          IAN    MX
          DCN*   MX
          RJM    CPA         CLEAR PORT ACCESS

 RCT      SUBR               ENTRY/EXIT
          RJM    SPA         START PORT ACCESS
          SHN    21-3
          MJN    RCT1        IF CHARACTER PRESENT
          RJM    CPA         CLEAR PORT ACCESS
          LDN    0
          UJN    RCTX        RETURN WITH NO CHARACTER
 RSB      SPACE  4,10
**        RSB - READ STATUS BITS.
*
*         ENTRY  (RSBA) = SET BASED ON PORT BEING USED.
*
*         EXIT   (A) = 1/REQUESTED, 1/0, 1/RESERVED.
*
*         USES   (RBUF - RBUF+7).
*
*         MACROS READMR.


 RSB      SUBR               ENTRY/EXIT
          READMR RBUF,ELIO,ITMR
          LDM    RBUF+7      FETCH BITS 59-63
 RSBA     SHN    0           (IF PORT 0 BEING USED)
*         SHN    -1          (IF PORT 1 BEING USED)
          LPN    5
          UJN    RSBX        RETURN
 RTM      SPACE  4,10
**        RTM - RELEASE TERMINAL ON MULTIPLEXOR.
*
*         ENTRY  THIS TERMINAL HAS ACCESS TO THE TERMINAL.
*
*         EXIT   THE FLAGS IN THE TEST MODE REGISTER RESET.
*
*         USES   SFMX.
*
*         CALLS  RSB, USB.
*
*         MACROS LOCKMR.


 RTM      SUBR               ENTRY/EXIT
          LOCKMR SET
          RJM    RSB         READ STATUS BITS
          LDC    5S12+0
          RJM    USB         CLEAR STATUS BITS
          LOCKMR CLEAR
          LDN    0
          STM    SFMX        CLEAR ACCESS CODE
          UJN    RTMX        RETURN
 SPA      SPACE  4,10
**        SPA - START PORT ACCESS.
*
*         ENTRY  PORT RESERVED BY PP.
*                (SFMX) = FUNCTION CODE TO SELECT PORT.
*
*         EXIT   PORT ACCESS OBTAINED.


 SPA      SUBR               ENTRY/EXIT

 SPA1     LDM    SFMX        FETCH PORT SELECT FUNCTION
          ZJN    SPAX        IF NO PORT DEFINED
          SCF    SPA3,MR     GET ACCESS TO MAINTENANCE CHANNEL
          SCF    SPA2,MX     GET ACCESS TO TWO-PORT MULTIPLEXOR
          CCF    *,MR
          FAN    MX          SELECT PORT
          AJM    *,MX        WAIT FOR FUNCTION COMPLETE
          FNC    MXSS,MX     FETCH PORT STATUS
          AJM    *,MX        WAIT FOR FUNCTION COMPLETE
          ACN    MX
          IAN    MX
          DCN*   MX
          STM    SSMX        SAVE TERMINAL STATUS
          UJN    SPAX        RETURN

 SPA2     CCF    *,MR        CLEAR MAINTENANCE CHANNEL INTERLOCK
 SPA3     LDN    7           BRIEF DELAY
          SBN    1
          PJN    *-1         IF DELAY NOT COMPLETE
          UJN    SPA1        TRY TO RESERVE PORT AGAIN
 STM      SPACE  4,10
**        STM - SELECT TERMINAL ON MULTIPLEXOR.
*
*         ENTRY  (A) = TERMINAL TO OBTAIN ACCESS TO.
*
*         EXIT   (A) = 0, IF ACCESS FAILED.
*
*         CALLS  DLY, RSB, USB.
*
*         USES   RSBA, SFMX, T2, USBA.
*
*         MACROS LOCKMR.


 STM      SUBR               ENTRY/EXIT
          ADC    MXPT        FORM PORT SELECT FUNCTION
          STM    SFMX
          LMC    SHNI&MXPT   FORM SHIFT INSTRUCTION
          STM    USBA
          LMN    77          COMPLEMENT SHIFT COUNT
          STM    RSBA
          LDN    0
          STD    T2

 STM1     LOCKMR SET
          RJM    RSB         READ STATUS BITS
          ZJN    STM4        IF PORT IS FREE
          LDC    4S12+4
          RJM    USB         SET PORT REQUESTED BIT
          LOCKMR CLEAR
          RJM    DLY         DELAY 0.05 SECONDS
          SOD    T2
          NJN    STM1        IF TIMEOUT NOT EXPIRED
          STM    SFMX        CLEAR PORT SELECT FUNCTION
 STM3     LJM    STMX        RETURN

 STM4     LDC    5S12+1
          RJM    USB         SET PORT RESERVED, PORT NOT REQUESTED
          LOCKMR CLEAR
          RJM    SPA         SET PORT ACCESS
          FNC    MXSM+2S1+1,MX  CONFIGURE PORT
          AJM    *,MX        WAIT FOR FUNCTION COMPLETE
          FNC    MXMC,MX     MASTER CLEAR PORT
          LDN    0
          SBN    10
          MJN    *-1         DELAY FOR A WHILE
          RJM    CPA         CLEAR PORT ACCESS
          LDN    1
          UJN    STM3        RETURN
 USB      SPACE  4,10
**        USB - UPDATE STATUS BITS.
*
*         ENTRY  (A) = 3/MASK, 9/0, 3/VALUE
*                (RBUF - RBUF+7) = CURRENT TESTMODE REGISTER CONTENTS.
*
*         EXIT   TESTMODE REGISTER REWRITTEN.
*
*         USES   T1.
*
*         MACROS WRITMR.


 USB      SUBR               ENTRY/EXIT
 USBA     SHN    0           (IF PORT 0)
*         SHN    1           (IF PORT 1)
          STD    T1
          SHN    -14
          ADC    SCNI        FORM MASK
          STM    USBB
          LDM    RBUF+7
 USBB     SCN    0
          LMD    T1
          STM    RBUF+7
          WRITMR RBUF,ELIO,ITMR
          UJN    USBX        RETURN
 WCT      SPACE  4,10
**        WCT - WRITE CHARACTER TO TERMINAL.
*
*         ENTRY  (A) = ASCII CHARACTER VALUE.
*
*         EXIT   (A) = ENTRY VALUE.
*
*         CALLS  CPA, DLY, SPA.
*
*         USES   T1.


 WCT1     FNC    MXWT,MX     FUNCTION TO WRITE
          LDD    T1
          AJM    *,MX        WAIT FOR FUNCTION COMPLETE
          ACN    MX
          OAN    MX          OUTPUT CHARACTER
          DCN*   MX+40       DISCONNECT CHANNEL
          RJM    CPA         CLEAR PORT ACCESS

 WCT      SUBR               ENTRY/EXIT
          STD    T1
 WCT2     RJM    SPA         START PORT ACCESS
          SHN    21-4
          MJN    WCT1        IF BUFFER NOT FULL
          RJM    CPA         CLEAR PORT ACCESS
          RJM    DLY         DELAY FOR 0.05 SECONDS
          UJN    WCT2        TRY TO OUTPUT AGAIN
          SPACE  4
          BASE   *
          PURGMAC DCN*
 QUAL$    IF     -DEF,QUAL$
          QUAL   *
 CPR      EQU    /COMPTMA/CPR
 GTS      EQU    /COMPTMA/GTS
 RCT      EQU    /COMPTMA/RCT
 RTM      EQU    /COMPTMA/RTM
 SSMX     EQU    /COMPTMA/SSMX
 STM      EQU    /COMPTMA/STM
 WCT      EQU    /COMPTMA/WCT
 QUAL$    ENDIF
          ENDX
*DECK DECK=COMPTVA EXPAND=FALSE
          CTEXT  COMPTVA - TRANSLATE VIRTUAL ADDRESS.
 DPS      SPACE  4,10
**        DPS - DEFINE PAGE SIZE.
*
*         ENTRY  (PSMV) = CONTENTS OF PAGE SIZE MASK REGISTER.
*
*         EXIT   (PSMV) = PAGE SIZE MASK.
*                (SPTA) = SHIFT INSTRUCTION TO EXTRACT PAGE NUMBER.


 DPS      SUBR               ENTRY/EXIT
          LDC    SHNI+100
          STM    SPTA        SET SHIFT INTO PAGE TABLE SEARCH
          LDM    PSMV
          LMC    0#7F
          STD    T2
          STM    PSMV        SET PAGE SIZE MASK
 DPS1     SOM    SPTA        ADD TO SHIFT COUNT
          LDD    T2
          SHN    21-0        REMOVE LOWEST BIT
          STD    T2
          NJN    DPS1        IF MORE BITS PRESENT
          UJN    DPSX        RETURN
 LBA      SPACE  4,10
**        LBA - LOAD BYTE ADDRESS.
*
*         ENTRY  (A) = POINTER TO BYTE ADDRESS.
*
*         EXIT   (W4 - W5) = R-REGISTER VALUE.
*                (A) = CM ADDRESS.
*                (W6) = OFFSET FROM R-REGISTER.


 LBA      SUBR               ENTRY/EXIT
          STD    W6
          LDI    W6
          SHN    7
          STD    W5          SET UPPER PART OF R-REGISTER
          SHN    6
          STD    W4          R-REGISTER BITS 12-18
          LRD    W4
          LDML   1,W6
          SHN    -3
          STDL   W6          SET OFFSET
          LMC    RR
          UJN    LBAX        RETURN
 PVC      SPACE  4,10
**        PVC - PRESET VIRTUAL ADDRESS CONSTANTS.
*
*         ENTRY  NONE.
*
*         EXIT   (PTAV - PTAV+1) = PAGE TABLE ADDRESS.
*                (JPSV - JPSV+1) = JPS VALUE.
*                (MPSV - MPSV+1) = MPS VALUE.
*                (PSMV) = PAGE SIZE MASK.
*                (PTLV) = PAGE TABLE LENGTH MASK.
*
*         CALLS  DPS.
*
*         MACROS READMR.


 PVC      SUBR               ENTRY/EXIT
          LDN    PVCAL
          STD    T5
 PVC1     LDM    PVCA+1,T5
          STD    T4          SET DATA ADDRESS
          LDM    PVCA,T5     GET REGISTER NUMBER
          STD    RN
          READMR RDATA,ELPR
          LDM    RDATA+4
          SHN    10
          LMM    RDATA+5
          STIL   T4
          LDM    RDATA+6
          SHN    10
          LMM    RDATA+7
          STML   1,T4
          LCN    2
          RAD    T5
          PJN    PVC1        IF MORE REGISTERS TO READ
          RJM    DPS         DEFINE PAGE SIZE
          LJM    PVCX        RETURN

 PVCA     BSS    0           TABLE OF REGISTERS
          LOC    0
          CON    PPTA,PTAV
          CON    PJPS,JPSV
          CON    PMPS,MPSV
          CON    PPSM,PSMV-1
 PVCAL    CON    PPTL,PTLV-1
          LOC    *O

 PTAV     CON    0,0         PAGE TABLE ADDRESS
 JPSV     CON    0,0         JOB PROCESS STATE POINTER
 MPSV     CON    0,0         MONITOR PROCESS STATE POINTER
 PSMV     CON    0           PAGE SIZE MASK
 PTLV     CON    0           PAGE TABLE LENGTH VALUE
 MSA      SPACE  4,10
**        MSA - MAKE SYSTEM VIRTUAL ADDRESS.
*
*         ENTRY  (A) - ADDRESS OF EXCHANGE PACKAGE ADDRESS.
*                (BA - BA+2) = PROCESS VIRTUAL ADDRESS.
*
*         EXIT   (CM - CM+2) = SYSTEM VIRTUAL ADDRESS.
*
*         CALLS  LBA.


 MSA1     LDN    0           FLAG INVALID/MISSING SEGMENT

 MSA      SUBR               ENTRY/EXIT
          RJM    LBA         LOAD BYTE ADDRESS
          ADN    16D         SEGMENT TABLE LENGTH
          CRDL   T1
          ADN    34D-16D     SEGMENT TABLE ADDRESS
          CRDL   T2
          ADN    1
          CRDL   T3
          LDDL   T1
          SBD    BA
          MJN    MSA1        IF NOT A VALID SEGMENT
          LDN    T2
          RJM    LBA         LOAD ADDRESS OF SEGMENT TABLE
          ADD    BA
          CRDL   W0          FETCH ASID
          LDDL   W1
          ZJN    MSA1        IF NOT A VALID ASID
          STDL   CM
          LDDL   BA+1        COPY REMAINDER OF PVA
          STDL   CM+1
          LDDL   BA+2
          STDL   CM+2
          LDN    1
          UJN    MSAX        RETURN
 SPT      SPACE  4,10
**        SPT - SEARCH PAGE TABLE.
*
*         ENTRY  (CM - CM+2) = SYSTEM VIRTUAL ADDRESS.
*
*         EXIT   (A) = ADDRESS OF WORD.
*
*         CALLS  LBA.


 SPT      SUBR               ENTRY/EXIT
          LDDL   CM+1
          SHN    20-11
          SCN    77          EXTRACT PAGE NUMBER
          STDL   T3
          LDDL   CM+2
          SHN    -11
          RADL   T3
 SPTA     SHN    -0
          LMDL   CM          EXCLUSIVE OR WITH ASID
          SHN    1
          STDL   T2          PAGE TABLE INDEX
          LDDL   T3
          LPML   PSMV
          STD    T5          BYTE NUMBER/2**9
          LDDL   T3
          SBD    T5          PAGE NUMBER
          STDL   T4
          LDC    PTAV
          RJM    LBA         SET ADDRESS OF PAGE TABLE
          LDM    PTLV
          SHN    11
          LMC    777
          STDL   T3          SET PAGE TABLE LENGTH MASK
          LDN    32D
          STD    T1          SET SEARCH LIMIT
 SPT1     LDDL   T2          PAGE TABLE INDEX
          LPDL   T3          PAGE TABLE LENGTH MASK
          ADDL   W6          PAGE TABLE OFFSET FROM R
          LMC    RR
          CRDL   W0          PAGE TABLE ENTRY
          LDDL   W0
          SHN    21-17
          PJN    SPT2        IF INVALID PAGE
          SHN    2
          SCN    0#F
          STDL   W0          EXTRACT ASID
          LDDL   W1
          SHN    4-20
          RADL   W0          COMPLETE ASID
          LMDL   CM
          NJN    SPT2        IF NOT CORRECT ASID
          LDDL   W1          EXTRACT PAGE NUMBER
          LPN    77
          SHN    20-6
          STDL   W1
          LDDL   W2
          SHN    -6
          RADL   W1
          LMDL   T4
          ZJN    SPT3        IF PAGE FOUND
 SPT2     AODL   T2          INCREMENT PAGE TABLE INDEX
          SOD    T1          DECREMENT SEARCH COUNT
          NJN    SPT1        IF MORE TO SEARCH
          LJM    SPTX        RETURN

 SPT3     LDDL   W3          CREATE RMA
          STD    T2
          SHN    -14
          STD    T1
          LDD    CM+2
          LPC    770
          SHN    11
          LMD    T5          INCLUDE UPPER BITS OF BYTE NUMBER
          SHN    6
          LMC    RR
          LRD    T1
          LJM    SPTX        RETURN
          SPACE  4,10
          ENDX
*DECK DECK=COMSCVS EXPAND=FALSE
          CTEXT  COMSCVS - CALLVS MACRO SYMBOL EQUIVALENCES.
COMSCVS   SPACE  4
          BASE   D
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
COMSCVS   SPACE  4
***       COMSCVS - CALLVS MACRO SYMBOL EQUIVALENCES.
*         D. A. HENSELER. 79/04/25.
COMSCVS   SPACE  4
***       COMSCVS CONTAINS DEFINITIONS FOR ALL CALLVS SYMBOLS.


*         CVS**** - CALLVS FUNCTION CODES.


 CVSDSCB  EQU    1           SET DSCB ADDRESS
 CVSSCPU  EQU    2           INITIATE DEADSTART OF DUAL STATE
 CVSRVT   EQU    3           REVERT TO STANDALONE
 CVSMLIP  EQU    1000B       PRIVILAGED MEMORY LINK
 CVSCPCM  EQU    1001B       MEMORY CPCM REQUEST
 CVSCPVA  EQU    1002B       SET PVA FOR MEMORY COPY
 CVSFPVA  EQU    1003B       GET PVA FOR MEMORY COPY
 CVSMLIU  EQU    2000B       UNPRIVILAGED MEMORY LINK
 CVSKDIS  EQU    2001B
 CVSSMLI  EQU    2003B       STATUS MEMORY LINK
 CVSIHF   EQU    2777B       INJECT HARDWARE FAULT

          BASE   *
          ENDX
*DECK DECK=COMSMLI EXPAND=FALSE
          CTEXT  COMSMLI - MEMORY LINK INTERFACE SYMBOL EQUIVALENCES.
COMSMLI   SPACE  4
          BASE   D
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
COMSMLI   SPACE  4
***       COMSMLI - MEMORY LINK INTERFACE SYMBOL EQUIVALENCES.
*         D. A. HENSELER. 79/04/25.
COMSMLI   SPACE  4
***       COMSMLI CONTAINS DEFINITIONS FOR ALL MEMORY LINK INTERFACE SYMBOLS.
*
*         MLP**** SYMBOLS ARE OFFSETS INTO THE MLI PARAMETER BLOCK MLIPAR.
*         MLF**** SYMBOLS ARE MLI FUNCTION CODES.
*         MLS**** SYMBOLS ARE MLI STATUS RETURN CODE EQUIVALENCES.
*         MLE**** SYMBOLS ARE MISC. MLI SYMBOLS
          SPACE  2
*         MLP**** -  MEMORY LINK PARAMETER POSITIONS WITHIN MLIPAR BLOCK.
          SPACE  2
MLPAN     EQU    0           APPLICATION NAME.
MLPSN     EQU    1           SENDER APPLICATION NAME.
MLPST     EQU    2           STATUS RETURN ADDRESS.
MLPFN     EQU    3           MLI FUNCTION NUMBER.
MLPCN     EQU    4           COUNT OF MESSAGES FOR FETCHRL.
MLPMM     EQU    4           MAX MESSAGES.
MLPRI     EQU    4           RECEIVE INDEX.
MLPFA     EQU    5           FIRST WORD ADDRESS OF BUFFER.
MLPJS     EQU    5           JSN FOR SIGNON/SIGNOFF.
MLPBL     EQU    6           MESSAGE BUFFER LENGTH.
MLPSG     EQU    7           VALUE OF SIGNAL FLAG.
MLPAR     EQU    8           ARBITRARY INFORMATION.
MLPLN     EQU    9           MESSAGE LENGTH RETURNED.
MLPSV     EQU    10          RETURNED STATUS VALUE
MLPV1     EQU    11          RETURNED VALUE 1
MLPV2     EQU    12          RETURNED VALUE 2
MLPV3     EQU    13          RETURNED VALUE 3
          SPACE  2
*         MLF**** -  MEMORY LINK FUNCTION NUMBERS.
*         THESE VALUES MAY BE CHANGED TO CONFORM TO PASCAL-X
*         CONVENTIONS AT A LATER TIME.
          SPACE  2
MLFON     EQU    0           SIGNON.
MLFOF     EQU    1           SIGNOFF.
MLFAD     EQU    2           ADDSPL.
MLFDE     EQU    3           DELSPL.
MLFSE     EQU    4           SEND.
MLFRE     EQU    5           RECEIVE.
MLFFE     EQU    6           FETCHRL.
MLFCO     EQU    7           CONFIRM.
MLFKI     EQU    8           KILL 170 JOB.
MLFKA     EQU    9           KILL ALL 170 JOBS.
MLFSW     EQU    10          SWAPOUT 170 UCP. (NOS/BE)
          SPACE  2
*         MLFS*** - MEMORY LINK SUB-FUNCTION CODES.
          SPACE  2
MLFSIN    EQU    0           INITIAL CALL TO NTH.
MLFSPL    EQU    1           POLLING CALL TO NTH.
          SPACE  2
*         MLS**** - MLI STATUS RETURN CODES.
          SPACE  2
MLSSB     EQU    0           STATUS BASE VALUE.
MLSAE     EQU    MLSSB+27D   C170 ADDRESS ERROR.
MLSAF     EQU    MLSSB+23D   ANT FULL.
MLSBA     EQU    MLSSB+18D   POOL BUFFER NOT AVAILABLE.
MLSBI     EQU    MLSSB+5D    BUSY INTERLOCK.
MLSCI     EQU    MLSSB+9D    C170 TO C170 ILLEGAL.
MLSDI     EQU    MLSSB+6D    DUPLICATE PERMITS IGNORED.
MLSIE     EQU    MLSSB+25D   MLI INTERNAL ERROR
MLSIF     EQU    MLSSB+26D   ILLEGAL FUNCTION.
MLSII     EQU    MLSSB+14D   RECEIVE LIST INDEX INVALID.
MLSML     EQU    MLSSB+22D   MAX MESSAGES TOO LARGE.
MLSMQ     EQU    MLSSB+13D   MESSAGES FROM SENDER QUEUED.
MLSMT     EQU    MLSSB+15D   MESSAGE TRUNCATED.
MLSND     EQU    MLSSB+28D   NOS/VE IS NOT UP.
MLSOK     EQU    MLSSB+0D    OK.
MLSPF     EQU    MLSSB+7D    PERMIT LIST FULL.
MLSPN     EQU    MLSSB+11D   PRIOR MESSAGE NOT RECEIVED.
MLSQL     EQU    MLSSB+20D   QUEUED MESSAGES LOST.
MLSRF     EQU    MLSSB+12D   RECEIVE LIST FULL.
MLSRN     EQU    MLSSB+3D    RECEIVER NOT SIGNED ON.
MLSRS     EQU    MLSSB+1D    RECEIVER NAME SYNTAX ERROR.
MLSSA     EQU    MLSSB+21D   MAX SIGNONS THIS APPLICATION.
MLSSC     EQU    MLSSB+16D   SIGNAL TO C170 IGNORED.
MLSSF     EQU    MLSSB+19D   SIGNAL FAILED, IGNORED.
MLSSM     EQU    MLSSB+4D    SYSTEM NAME NO MATCH
MLSSN     EQU    MLSSB+8D    SENDER NOT SIGNED ON.
MLSSP     EQU    MLSSB+10D   SENDER NOT PERMITTED.
MLSSS     EQU    MLSSB+2D    SENDER NAME SYNTAX ERROR.
MLSST     EQU    MLSSB+24D   MAX SIGNONS THIS TASK.
MLSTL     EQU    MLSSB+17D   MESSAGE TOO LONG.
          SPACE  2
*         MLE**** - MLI MISC. SYMBOLS.
          SPACE  2
MLEMXR    EQU    10          MAXIMUM NUMBER OF INTERLOCK RETRYS.
MLEITM    EQU    0           ISSUE TRACE MESSAGES DEFAULT.
MLETDF    EQU    3           TRACE MESSAGES DAYFILE NUMBER.
MLEPBS    EQU    14          MLI PARAMETER BLOCK SIZE.
          SPACE  2
          BASE   *
          ENDX
*DECK DECK=COMSSCB EXPAND=FALSE
          EJECT                                                          R152_OS        1
          TITLE  COMSSCB - SMU COMMUNICATIONS BLOCK DEFINITIONS.         R152_OS        2
***       COMSSCB - SUM COMMUNICATIONS BLOCK DEFINITIONS.                R152_OS        3
*                                                                        R152_OS        4
*         PROVIDE THE CONSTANTS FOR USE OF THE SMU COMMUNICATIONS        R152_OS        5
*         BLOCK FOR USE BY NOS/VE PPS.                                   R152_OS        6
                                                                         R152_OS        7
                                                                         R152_OS        8
**        PP ADDRESS ARRAY DESCRIPTOR NUMBER.                            R152_OS        9
*                                                                        R152_OS       10
                                                                         R152_OS       11
                                                                         R152_OS       12
 SCPPD    EQU    128D        SMU COMMUNICATIONS BUFFER                   R152_OS       13
 ABPPD    EQU    131D        ASCII BUFFER                                R152_OS       14
          SPACE  4,10                                                    R152_OS       15
**        SYSTEM CONSOLE LINE DEFINITION.                                R152_OS       16
*                                                                        R152_OS       17
                                                                         R152_OS       18
                                                                         R152_OS       19
 CLLEN    EQU    80D/8D      CONSOLE LINE LENGTH IN WORDS                R152_OS       20
          SPACE  4,10                                                    R152_OS       21
**        DEFINITIONS OF WORDS IN THE SCB.                               R152_OS       22
*                                                                        R152_OS       23
                                                                         R152_OS       24
                                                                         R152_OS       25
 SCHST    EQU    0           HARDWARE STATUS WORD                        R152_OS       26
 SCNOS    EQU    1           NOS STATUS WORD                             R152_OS       27
 SCNVE    EQU    2           NOS/VE STATUS WORD                          R152_OS       28
 SCNSF    EQU    3           NOS SERVICE FLAG                            R152_OS       29
 SCSSF    EQU    4           SMU SERVICE FLAG                            R152_OS       30
 SCCMS    EQU    5           CRITICAL MESSAGE TIME STAMP                 R152_OS       31
 SCJPS    EQU    6           RMA OF FAILING JPS                          R152_OS       32
 SCMSG    EQU    7           TERMINATION MESSAGE                         R152_OS       33
 SCCEM    EQU    SCMSG+CLLEN CRITICAL ERROR MESSAGE                      R152_OS       34
 SCREQ    EQU    SCCEM+CLLEN SMU REQUEST BLOCK                           R152_OS       35
          SPACE  4,10                                                    R152_OS       36
**        DEFINITIONS OF THE ASCII BUFFER.                               R152_OS       37
*                                                                        R152_OS       38
                                                                         R152_OS       39
                                                                         R152_OS       40
 ABHDR    EQU    1           HEADER IS IN WORD 1                         R152_OS       41
 ABINP    EQU    2           INPUT BUFFER STARTS AT WORD 2               R152_OS       42
 ABOUT    EQU    ABINP+CLLEN OUTPUT BUFFER START                         R152_OS       43
          SPACE  4,10                                                    R152_OS       44
**        DEFINITIONS OF THE SMU META-STATES.                            R152_OS       45
*                                                                        R152_OS       46
                                                                         R152_OS       47
                                                                         R152_OS       48
 SSWDS    EQU    1           WAIT FOR DEADSTART                          R152_OS       49
 SSRUN    EQU    2           NORMAL OPERATING MODE                       R152_OS       50
 SSWIF    EQU    3           WRITE IMAGE FILE                            R152_OS       51
 SSRVT    EQU    4           REVERT TO STAND ALONE                       R152_OS       52
 SSIDL    EQU    5           SMU IDLE                                    R152_OS       53
*DECK DECK=COMSSSD EXPAND=FALSE
          CTEXT  COMSSSD - SUBSYSTEM DEFINITIONS.
          SPACE  4,10
          BASE   M
*COMMENT  COMSSSD - SUBSYSTEM DEFINITIONS.
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4,10
***       COMSSSD - SUBSYSTEM DEFINITIONS.
*
*         R. M. DANISCH.     81/01/26.
          SPACE  4,10
**        SUBSYSTEM IDENTIFICATION NUMBERS.

 DSSI     EQU    7777        DEADSTART SEQUENCING IDENTIFIER

 MXSI     EQU    7776        HIGHEST SCP SUBSYSTEM IDENTIFIER

 IFSI     EQU    7776        IAF
 RFSI     EQU    7775        RHF
 I1SI     EQU    7774        RESERVED FOR INSTALLATION
 I2SI     EQU    7773        RESERVED FOR INSTALLATION
 TRSI     EQU    7772        TAF
 MPSI     EQU    7771        MAP III
 NMSI     EQU    7770        NAM
 NVSI     EQU    7767        NVE
 CDSI     EQU    7766        CDCS
 MCSI     EQU    7765        MCS
 RDSI     EQU    7764        RDF
 MFSI     EQU    7763        MSS

 MNSI     EQU    7763        LOWEST SCP SUBSYSTEM IDENTIFIER

 RBSI     EQU    7762        RBF
 BISI     EQU    7761        BATCHIO
 MTSI     EQU    7760        MAGNET
 STSI     EQU    7757        STIMULATOR
 MSSI     EQU    7756        MSM
 SMSI     EQU    7755        SMF
 SSSI     EQU    7753        SSF

 LSSI     EQU    7752        LOWEST SUBSYSTEM IDENTIFICATION NUMBER - 1

 ORSI     EQU    3           ALLOW OPERATOR ROLLOUT (FOR *SSJ=* JOBS)
 QCSI     EQU    2           INHIBIT ROLLOUT (USER CALL TO *QAC*)
 IRSI     EQU    1           INHIBIT ROLLOUT (USED BY *SSJ=* JOBS)
 UJSI     EQU    0           NON-SUBSYSTEM JOB (DEFAULT FOR USER JOBS)

 MAXS     EQU    14          MAXIMUM NUMBER OF SCP SUBSYSTEMS
 NBSS     EQU    MXSI-MNSI+1 NUMBER OF SCP SUBSYSTEMS
          ERRNG  MAXS-NBSS   IF TOO MANY SUBSYSTEMS FOR *SSCW* WORD
          SPACE  4,10
 .A       SET    MXSI-LSSI+4
 SSCTL    EQU    .A/5        LENGTH OF SSCT
          SPACE  4,10
          BASE   *
          ENDX
*DECK DECK=COMSVED EXPAND=FALSE
          CTEXT  COMSVED - VIRTUAL ENVIRONMENT DEFINITIONS.
          BASE   M
 COMSVED  SPACE  4,10
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4,10
***       COMSVED - VIRTUAL ENVIRONMENT DEFINITIONS.
*         K. H. BOSSARD.     82/03/03.
          SPACE  4,10
***              COMSVED CONTAINS *VER* INTERFACE EQUIVALENCES.
          SPACE  4,10
**        *VER* - VIRTUAL ENVIRONMENT REQUEST FUNCTION CODES.


 BEGIN    BSSN
 RSCM     BSSN   1           RESERVE CM
 RSPP     BSSN   1           RESERVE PP(S)
 RSCH     BSSN   1           RESERVE CHANNEL(S)
 RSEQ     BSSN   1           RESERVE EQUIPMENT(S)
 RNCM     BSSN   1           RETURN CM
 RNPP     BSSN   1           RETURN PP(S)
 RNCH     BSSN   1           RETURN CHANNEL(S)
 RNEQ     BSSN   1           RETURN EQUIPMENT(S)
 STCM     BSSN   1           STATUS CM
 STPP     BSSN   1           STATUS PP-S
 STCH     BSSN   1           STATUS CHANNELS
 STEQ     BSSN   1           STATUS EQUIPMENTS
 STMR     BSSN   1           STATUS AVAILABLE RESOURCES
 END      BSSN
          SPACE  4,10
**        DUAL STATE ERROR STATUS CODES.


 ESCH     EQU    10          CHANNEL NOT AVAILABLE/NOT ASSIGNED
 ESEQ     EQU    20          EQUIPMENT NOT AVAILABLE/NOT ASSIGNED
 ESUN     EQU    30          UNIT NOT AVAILABLE/NOT ASSIGNED
 ESCM     EQU    40          CM NOT AVAILABLE/NOT ASSIGNED
 ESPP     EQU    50          PP NOT AVAILABLE/NOT ASSSIGNED
 ESNE     EQU    60          CHANNEL/EQUIPMENT/UNIT NOT IN EST
 ESAA     EQU    70          EQUIPMENT/UNIT ALREADY ASSIGNED TO NOS/VE
 ESDC     EQU    100         DO NOT DOWNLINE LOAD CONTROLWARE
 ESIL     EQU    700         INSUFFICIENT LENGTH IN RESPONSE BUFFER
 ESIR     EQU    1000        ILLEGAL REQUEST
 ESNR     EQU    2000        DUAL STATE NOT ENABLED
          SPACE  4,10
**        DUAL STATE ASSEMBLY CONSTANTS.


 MINP     EQU    4           MINIMUM NUMBER OF POOL PP-S NEEDED BY NOS

          BASE   *
          ENDX
*DECK DECK=CSC$MAX_ATTRIBUTE EXPAND=FALSE

CONST
  csc$max_attribute = 63;

*copyc csc$workspace_constants
*DECK DECK=CSC$MAX_CHARACTER_POSITION EXPAND=FALSE

  CONST
    csc$max_character_position = 65535;

*DECK DECK=CSC$MAX_CLASSES EXPAND=FALSE
  CONST
    csc$max_classes = 16;
*DECK DECK=CSC$MAX_CONTROL EXPAND=FALSE

CONST
  csc$max_control = 511;

*copyc csc$workspace_constants
*DECK DECK=CSC$MAX_FIELD_NUMBER EXPAND=FALSE

  CONST
    csc$max_field_number = 65535;

*DECK DECK=CSC$MAX_GRAPHIC_ID EXPAND=FALSE

  CONST
    csc$max_graphic_id = 65535;

*DECK DECK=CSC$MAX_IMPLEMENTED_ATTRIBUTES EXPAND=FALSE

CONST
  csc$max_implemented_attributes = 30;

*copyc csc$workspace_constants
*DECK DECK=CSC$MAX_ITEMS_PER_CLASS EXPAND=FALSE
  CONST
    csc$max_items_per_class = 20;
*DECK DECK=CSC$MAX_LINE_NUMBER EXPAND=FALSE

  CONST
    csc$max_line_number = 256;

*DECK DECK=CSC$MAX_MENU_ITEMS EXPAND=FALSE
*copyc csc$max_classes
*copyc csc$max_items_per_class
  CONST
    csc$max_menu_items = csc$max_classes*csc$max_items_per_class;
*DECK DECK=CSC$MAX_MOUSE_EVENT EXPAND=FALSE

  CONST
    csc$max_mouse_event = 65535;

*DECK DECK=CSC$MAX_NAME EXPAND=FALSE

  CONST
    csc$max_name = 31;


*DECK DECK=CSC$MAX_SCREEN_DIMENSIONS EXPAND=FALSE

  CONST
    csc$max_screen_dimensions = 4;
*DECK DECK=CSC$MAX_STRING EXPAND=FALSE

  CONST
    csc$max_string = 256;

*DECK DECK=CSC$MAX_TAB_POSITION EXPAND=FALSE

  CONST
    csc$max_tab_position = 256;

*DECK DECK=CSC$MAX_TAB_STOPS EXPAND=FALSE

  CONST
    csc$max_tab_stops = 256;

*DECK DECK=CSC$MAX_TERMINAL_MODEL_NAME EXPAND=FALSE

  CONST
    csc$max_terminal_model_name = 25;

*DECK DECK=CSC$MAX_TIMEOUT EXPAND=FALSE

  CONST
    csc$max_timeout = 86401;

*DECK DECK=CSC$MAX_VISIBLE_CHAR_POSITION EXPAND=FALSE

  CONST
    csc$max_visible_char_position = 256;

*DECK DECK=CSC$MAX_X_POSITION EXPAND=FALSE

  CONST
    csc$max_x_position = 256;

*DECK DECK=CSC$MAX_Y_POSITION EXPAND=FALSE

  CONST
    csc$max_y_position = 256;

*DECK DECK=CSC$NUMBER_OF_MENU_ROWS EXPAND=FALSE
  CONST
    csc$number_of_menu_rows = 2;
*DECK DECK=CSC$WORKSPACE_CONSTANTS EXPAND=FALSE

CONST
  csc$ws_protect = 0,
  csc$ws_hide = 1,
  csc$ws_inverse = 2,
  csc$ws_alternate_intensity = 3,
  csc$ws_blink = 4,
  csc$ws_underline = 5,
  csc$ws_normal = 6,
  csc$ws_italic = 7,
  csc$ws_title =  8,
  csc$ws_input = 9,
  csc$ws_error = 10,
  csc$ws_message = 11,
  csc$foreground_black = 12,
  csc$foreground_white = 13,
  csc$foreground_red = 14,
  csc$foreground_green = 15,
  csc$foreground_blue = 16,
  csc$foreground_yellow = 17,
  csc$foreground_cyan = 18,
  csc$foreground_magenta = 19,
  csc$background_black = 20,
  csc$background_white = 21,
  csc$background_red = 22,
  csc$background_green = 23,
  csc$background_blue = 24,
  csc$background_yellow= 25,
  csc$background_cyan = 26,
  csc$background_magenta = 27,
  csc$fine_line = 28,
  csc$medium_line = 29,
  csc$bold_line = 30,
  csc$display_right_to_left = 31,
  csc$user_attribute_1 = 32,
  csc$user_attribute_2 = 33,
  csc$user_attribute_3 = 34,
  csc$user_attribute_4 = 35,
  csc$user_attribute_5 = 36,
  csc$user_attribute_6 = 37,
  csc$user_attribute_7 = 38,
  csc$user_attribute_8 = 39,
  csc$user_attribute_9 = 40,
  csc$user_attribute_10 = 41,

  csc$wc_next = 13,
  csc$wc_shift_next = 113,
  csc$wc_help = 272,
  csc$wc_shift_help = 372,
  csc$function_1 = 257,
  csc$shift_function_1 = 357,
  csc$function_2 = 258,
  csc$shift_function_2 = 358,
  csc$function_3 = 259,
  csc$shift_function_3 = 359,
  csc$function_4 = 260,
  csc$shift_function_4 = 360,
  csc$function_5 = 261,
  csc$shift_function_5 = 361,
  csc$function_6 = 262,
  csc$shift_function_6 = 362,
  csc$function_7 = 263,
  csc$shift_function_7 =363,
  csc$function_8 = 264,
  csc$shift_function_8 = 364,
  csc$function_9 = 265,
  csc$shift_function_9 = 365,
  csc$function_10 = 256,
  csc$shift_function_10 = 356,

  csc$wc_stop = 1,
  csc$wc_shift_stop = 101,
  csc$wc_back = 2,
  csc$wc_shift_back = 102,
  csc$wc_up = 3,
  csc$wc_shift_up = 103,
  csc$wc_down = 4,
  csc$wc_shift_down = 104,
  csc$wc_forward = 5,
  csc$wc_shift_forward = 105,
  csc$wc_backward = 6,
  csc$wc_shift_backward = 106,
  csc$wc_edit = 7,
  csc$wc_shift_edit = 107,
  csc$wc_data = 8,
  csc$wc_shift_data = 108,
  csc$wc_undo = 9,
  csc$wc_shift_undo =109,
  csc$wc_locate = 10,
  csc$wc_insert_line = 110,
  csc$wc_delete_line = 11,
  csc$wc_home = 111,
  csc$wc_clear = 12,
  csc$wc_timeout = 112,



  csc$function_11 = 14,
  csc$shift_function_11 = 114,
  csc$function_12 = 15,
  csc$shift_function_12 = 115,
  csc$function_13 = 16,
  csc$shift_function_13 = 116,
  csc$function_14 = 17,
  csc$shift_function_14 = 117,
  csc$function_15 = 18,
  csc$shift_function_15 = 118,
  csc$function_16 = 19,
  csc$shift_function_16 = 119;


*DECK DECK=CSE$CONDITION_CODES EXPAND=FALSE

{ cse$condition_codes

  CONST
    csc$character_screen_id = 'CS',
    csc$min_ecc = 289155317760;

  CONST
    cse$unknown_field_number = csc$min_ecc + 3010,
    {E Field not defined in current page.

    cse$unknown_line_number = csc$min_ecc + 3020,
    {E Line number out of range.

    cse$unknown_character_position = csc$min_ecc + 3030,
    {E Character position out of range.

    cse$field_off_screen = csc$min_ecc + 3040,
    {E Field not displayed on screen.

    cse$line_length_exceeded = csc$min_ecc + 3050,
    {E Line too long.

    cse$no_fields_available = csc$min_ecc + 3060,
    {E No fields available.

    cse$no_current_page = csc$min_ecc + 3070,
    {E No current page.

    cse$no_current_field = csc$min_ecc + 3080,
    {E No current field selected.

    cse$null_line_range = csc$min_ecc + 3090,
    {E First line of range greater than last line.

    cse$offset_out_of_range = csc$min_ecc + 3100,
    {E Offset > line range.

    cse$no_text_available = csc$min_ecc + 3110,
    {E Insufficient space in change container to store any changes.

    cse$unimpled_capability_level = csc$min_ecc + 3120,
    {E Only line and screen modes for now.

    cse$redundant_screen_level = csc$min_ecc + 3130,
    {E Set screen capability redundant.

    cse$alloc_returns_nil = csc$min_ecc + 3140,
    {F Cannot allocate screen image.

    cse$invalid_parameter = csc$min_ecc + 3150,
    {E Parameter out of expected or acceptable range.

    cse$illegal_command = csc$min_ecc + 3160,
    {E Command illegal for present capability level.

    cse$no_app_params = csc$min_ecc + 3170,
    {E No application parameters found.

    cse$unresolvable_field_pick = csc$min_ecc + 3180,
    {E Pick device cannot resolve your selection.

    cse$unknown_input_received = csc$min_ecc + 3190,
    {E Unknown input received from terminal.

    cse$corrupted_terminal_table = csc$min_ecc + 3200,
    {F The terminal table is corrupted or not properly loaded.

    cse$undefined_terminal_model = csc$min_ecc + 3210,
    {E The specified terminal model TDU is undefined.

    cse$page_stack_full = csc$min_ecc + 3220,
    {E No space to push page.

    cse$page_stack_empty = csc$min_ecc + 3230,
    {E No page available to pop.

    cse$incompatible_terminal = csc$min_ecc + 3240,
    {E Old terminal definitions must be recompiled - consult site analyst for
    {any other changes.

    cse$tab_stops_exceeded = csc$min_ecc + 3250,
    {E Number of available tab stops for this terminal exceeded.

    cse$field_beyond_page_boundary = csc$min_ecc + 3260,
    {E Field extends beyond page boundary.

    cse$visible_field_gt_data = csc$min_ecc + 3270,
    {E Visible portion of field larger than data portion.

    cse$unknown_msg_field_number = csc$min_ecc + 3280,
    {E Message field not defined in current page.

    cse$start_field_unknown = csc$min_ecc + 3290,
    {E Starting field not defined in current page.

    cse$end_field_unknown = csc$min_ecc + 3300,
    {E Ending field not defined in current page.

    cse$configuration_cannot_shift = csc$min_ecc + 3310,
    {E Field configuration doesn't allow shift.

    cse$start_line_unknown = csc$min_ecc + 3320,
    {E Starting line number out of range.

    cse$end_line_unknown = csc$min_ecc + 3330,
    {E Ending line number out of range.

    cse$start_character_unknown = csc$min_ecc + 3340,
    {E Starting character out of range.

    cse$end_character_unknown = csc$min_ecc + 3350,
    {E Ending character out of range.

    cse$not_hv_line = csc$min_ecc + 3360,
    {E Coordinates do not define a horizontal or vertical line.

    cse$input_buffer_overflow = csc$min_ecc + 3370,
    {E Input buffer filled by too many typed characters before carriage-return.

    cse$no_graphics_available = csc$min_ecc + 3380,
    {E No graphics available.

    cse$coord_not_equal_intersect = csc$min_ecc + 3390,
    {E Array of coordinates does not have same bound as array of intersections.

    cse$no_menu_setup = csc$min_ecc + 3400,
    {E Set_menu must be called before menu item numbers can be used.

    cse$too_many_menu_items = csc$min_ecc + 3410,
    {E The maximum number of menu items is 320

    cse$too_many_classes = csc$min_ecc + 3420,
    {E The maximum number of classes is 20.

    cse$invalid_item_number = csc$min_ecc + 3430,
    {E Item number not in current menu list.

    cse$too_many_menu_rows = csc$min_ecc + 3440,
    {E The number of menu rows must be 0, 1, or 2.

    cse$unknown_graphic_id = csc$min_ecc + 3450,
    {E Graphic not defined in current page.

    cse$not_screen_mode = csc$min_ecc + 3460,
    {E Cannot define workspace without screen interaction style.

    cse$redundant_workspace = csc$min_ecc + 3470,
    {E Redundant attempt to open workspace.

    cse$workspace_not_open = csc$min_ecc + 3480,
    {E Attempt to use workspace that has not been opened.

    cse$no_workspace_allowed = csc$min_ecc + 3490,
    {E Cannot mix workspace operations with Screen Manager operations.

    cse$unknown_x_position = csc$min_ecc + 3500,
    {E Unknown X position parameter in workspace operation.

    cse$unknown_y_position = csc$min_ecc + 3510,
    {E Unknown Y position parameter in workspace operation.

    cse$press_next_to_continue = csc$min_ecc + 3520,
    {I Press +P when ready to continue /

    cse$no_terminal_resources = csc$min_ecc + 3530,
    {F Terminal has no resources defined.

    cse$invalid_terminal_resources = csc$min_ecc + 3540;
    {F Terminal resources not terminated with correct delimiter.
*DECK DECK=CSH$ACCEPT_INPUT EXPAND=FALSE
{
{   The purpose of this request is to update the screen with any output
{ operations not yet physically output from the interfaces csp$draw_lines,
{ csp$change_workspace_attributes, csp$change_workspace_text,
{ csp$set_workspace_cursor, csp$clear_workspace_area, or csp$open_workspace.
{ Then input is requested and the device driver will calculate the net
{ effect of minor keystrokes such as overtyping, cursor motion, and
{ insertion or deletion of characters.  This request completes when the
{ input stream contains a keystrokes significant enough to be processed
{ by the application.  Future calls to CSP$ACCEPT_INPUT will continue
{ scanning the input record until it is exhausted, then another screen
{ update and device read will be performed.
{
{       CSP$ACCEPT_INPUT (CONTROL, X_POSITION, Y_POSITION, STATUS)
{
{ CONTROL: (output) This describes the significant keystroke which
{       caused scanning of the input to pause for application
{       processing.
{
{ X_POSITION: (output) This describes one of the cursor coordinates
{       at which the CONTROL event was encountered.
{
{ Y_POSITION: (output) This is the other coordinate.
{
{ STATUS: (output) This parameter receives any error conditions.
{
{       condition identifiers:  cse$workspace_not_open
{                               cse$corrupted_terminal_table
*DECK DECK=CSH$CHANGE_MENU_ITEM_STRINGS EXPAND=FALSE
{
{ The purpose of this request is to discard the old menu strings, and
{ allocate/save new news, for a selected subset of the menu list items.
{ The user identifies the item(s) by their key identities, rather than
{ by their positions within the menu list.  The user may use a NIL
{ string pointer to specify that no string is to be saved.
{
{       CSP$CHANGE_MENU_ITEM_STRINGS (NEW_MENU_ITEM_STRINGS, MENU_LIST, STATUS)
{
{ NEW_MENU_ITEM_STRINGS: (input) This lists the keys, and corresponding new
{       menu strings and labels, for one or more menu items.
{
{ MENU_LIST: (input)  This is a pointer to the menu list as most recently
{       used by CSP$SET_STANDARD_MENU.  The content of the menu list will
{       be updated.
{
{ STATUS: (output) This receives any error codes.
{
{       condition_identifiers:  none at release 1.4.1
*DECK DECK=CSH$CHANGE_PARTIAL_SCREEN EXPAND=FALSE
{
{   The purpose of this request is to put the terminal into screen mode
{ using only the top "n" rows of the screen if the task is not already in
{ screen mode, or to share an existing instance of Screen Manager.  It is
{ thus equivalent to calling either CSP$CHANGE_INTERACTION_STYLE or
{ CSP$PUSH_PAGE/CSP$POP_PAGE depending on the previous interaction style.
{ This request is also used at termination to get back to line mode or to
{ restore an previous screen.  This request is intended to be used for
{ dialogue boxes which might be implemented as different modules of Cybil
{ from the underlying application.  When the terminal definition indicates
{ feasibility, the screen will not be blanked out like happens with calls
{ to the normal CSP$CHANGE_INTERACTION_STYLE.
{
{       CSP$CHANGE_PARTIAL_SCREEN (FILE_ID, STYLE, ROWS, OLD_STYLE,
{             RESERVE_LINES, STATUS)
{
{ FILE_ID: (input) An opened terminal file that can be used by Screen
{       Manager.
{
{ STYLE: (input) This is the desired mode (screen or line).
{
{ ROWS: (input) This is the number of rows to be used.
{
{ OLD_STYLE: (input/output) This is an output parameter when STYLE is screen,
{       or an input parameter when STYLE is line.  Thus, the user should
{       preserve this value as returned when screen mode is requested, and
{       pass this value back in when returning to line mode.
{
{ RESERVE_LINES: (output) When changing to screen mode, this will return
{       to the caller the difference between actual screen size and
{       requested screen size.  This number of unused rows should be used
{       in any subsequent call to CSP$DISPLAY_MENU, in order to keep the
{       "tombstones" up in the partial screen area instead of at bottom.
{
{ STATUS: (output) This parameter receives any error conditions.
{
{       condition identifiers:  cse$workspace_not_open
{                               cse$corrupted_terminal_table

*DECK DECK=CSH$CHANGE_WORKSPACE_ATTRIBUTES EXPAND=FALSE
{
{   The purpose of this request is to change the visual attributes for
{ a rectangular area of the screen.  If the area already contains some
{ mixture of text and graphics, restrictions will be automatically
{ applied to assure that text positions do not receive any of the
{ graphic boldness attributes, and that graphic positions do not lose
{ the protection attribute.
{
{       CSP$CHANGE_WORKSPACE_ATTRIBUTES (X_POSITION, Y_POSITION,
{             WIDTH, HEIGHT, ATTRIBUTE, STATUS)
{
{ X_POSITION: (input)  This specifies one of the coordinates for the
{       upper left corner of the area to be affected.
{
{ Y_POSITION: (input)  This is the other coordinate for the upper left
{       corner of the area.
{
{ WIDTH: (input)  This specifies the horizontal size of the area.
{
{ HEIGHT: (input)  This specifies the vertical size of the area.
{
{ ATTRIBUTE: (input)  This specifies the attributes to be applied.
{
{ STATUS: (output)  This receives any condition codes.
{
{       condition_identifiers:  cse$workspace_not_open
{                               cse$unknown_x_position
{                               cse$unknown_y_position
*DECK DECK=CSH$CHANGE_WORKSPACE_TEXT EXPAND=FALSE
{
{   The purpose of this request is to display a string of text on one row
{ of the screen.  This request also applies a set of visual attributes at
{ all changed screen positions.  Restrictions will be automatically
{ applied to assure that text positions do not receive any of the
{ graphic boldness attributes.  This request is allowed to convert old
{ graphics into text.
{
{       CSP$CHANGE_WORKSPACE_TEXT (X_POSITION, Y_POSITION,
{             TEXT, ATTRIBUTE, STATUS)
{
{ X_POSITION: (input)  This specifies one of the coordinates for the
{       upper left corner of the area to be affected.
{
{ Y_POSITION: (input)  This is the other coordinate for the upper left
{       corner of the area.
{
{ TEXT: (input)  This is an adaptable string containing the text to be
{       displayed.  The length of this string determines the width of
{       the altered area on the screen.
{
{ ATTRIBUTE: (input)  This specifies the attributes to be applied.
{
{ STATUS: (output)  This receives any condition codes.
{
{       condition_identifiers:  cse$workspace_not_open
{                               cse$unknown_x_position
{                               cse$unknown_y_position
*DECK DECK=CSH$CLEAR_WORKSPACE_AREA EXPAND=FALSE
{
{   The purpose of this request is to blank out a rectangular area
{ of the screen.  This request also applies a set of visual attributes at
{ all changed screen positions.  Restrictions will be automatically
{ applied to assure that text positions do not receive any of the
{ graphic boldness attributes.  This request is allowed to convert old
{ graphics into text.
{
{       CSP$CLEAR_WORKSPACE_AREA (X_POSITION, Y_POSITION, WIDTH, HEIGHT,
{             ATTRIBUTE, STATUS)
{
{ X_POSITION: (input)  This specifies one of the coordinates for the
{       upper left corner of the area to be affected.
{
{ Y_POSITION: (input)  This is the other coordinate for the upper left
{       corner of the area.
{
{ WIDTH: (input)  This is the horizontal size of the rectangle.
{
{ HEIGHT: (input)  This is the vertical size of the rectangle.
{
{ ATTRIBUTE: (input)  This specifies the attributes to be applied.
{
{ STATUS: (output)  This receives any condition codes.
{
{       condition_identifiers:  cse$workspace_not_open
{                               cse$unknown_x_position
{                               cse$unknown_y_position
*DECK DECK=CSH$CLOSE_WORKSTATION EXPAND=FALSE
{
{   The purpose of this request is to blank the screen and release any
{ allocated memory or other resources that are unique to the workspace.
{ The resources freed by this request are those which were allocated
{ by CSP$OPEN_WORKSPACE.  Note that there are additional resources
{ controlled by CSP$CHANGE_INTERACTION_STYLE, and that it is suggested
{ that applications use that interface to drop to line mode before
{ terminating; however, a task-end handler will do that automatically.
{
{       CSP$CLOSE_WORKSTATION (STATUS)
{
{ STATUS: (output)  This receives any condition codes.
{
{       condition_identifiers:  cse$workspace_not_open
*DECK DECK=CSH$DISPLAY_WORKSPACE EXPAND=FALSE
{
{   The purpose of this request is to force any queued output operations
{ to be painted on the screen, without requesting input.  Because the
{ screen repaint optimizer can consume significant CPU overhead, most
{ applications should not use this interface, as the CSP$ACCEPT_INPUT
{ interface will perform all necessary output, deferred as long as possible
{ to minimize overhead.  CSP$DISPLAY_WORKSPACE is suitable to use in an
{ application that specifically intends to "animate" the screen or which
{ expects to incur a lengthy response time delay for application processing
{ and needs to issue an interim progress message.
{
{       CSP$DISPLAY_WORKSPACE (STATUS)
{
{ STATUS: (output)  This receives any condition codes.
{
{       condition_identifiers:  cse$workspace_not_open
*DECK DECK=CSH$DRAW_LINES EXPAND=FALSE
{
{   The purpose of this request is to draw one or more connected lines on the
{ screen.  Each line segment must be horizontal or vertical.  Corner shapes
{ will be automatically use at each intersection within this diagram, and
{ additional comparisons will be performed to determine whether any position
{ within this diagram will intersect with graphics already drawn from earlier
{ calls to CSP$DRAW_LINES.  Any intersections detected by these comparisons
{ will be drawn with "tee" or "cross" shapes as needed.  The ATTRIBUTE
{ parameter can be used to indicate which boldness is preferred, or FINE
{ boldness will be defaulted.  The "protection" attribute is applied
{ whether or not it is requested in the ATTRIBUTE parameter. The ATTRIBUTE
{ parameter can be used to request other highlighting, such as colors.
{
{       CSP$DRAW_LINES (xy_coordinates, attribute, status)
{
{ XY_COORDINATES: (input)  This is an array of records with adaptable
{       dimension.  Each record describes one coordinate of the diagram.
{       The first line segment is drawn between the first two coordinates,
{       the second line segment is drawn between the second and third
{       coordinates, etc., for "N-1" segments.
{
{ ATTRIBUTE: (input)  This specifies the visual highlighting to be used.
{
{ STATUS: (output)  This receives any error codes.
{
{       condition identifiers:  cse$workspace_not_open
{                               cse$not_hv_line
{                               cse$unknown_x_position
{                               cse$unknown_y_position
*DECK DECK=CSH$GET_CHANGED_TEXT EXPAND=FALSE
{
{   The purpose of this request to read strings of text modified by the
{ keyboard.  Typically, this would be called by the application, in a loop
{ until all changes are exhausted, just after CSP$ACCEPT_INPUT.  When the
{ CSP$ACCEPT_INPUT procedure looks for the next keystroke that is significant
{ enough to report to the application, it marks which area of the screen were
{ affected by insignificant keystrokes such as overtyping of text and insertion
{ or deletion of characters.  The CSP$GET_CHANGED_TEXT procedure searches for
{ the first area (from top of screen) that is marked as changed, and returns
{ that text, unmarks it, and attempts to process as many other changes as can
{ fit into the application's "change container".  If the application neglects
{ to exhaust all changes between two calls to CSP$ACCEPT_INPUT, the change
{ markers will endure and can be utilized in a future call to
{ CSP$GET_CHANGED_TEXT.  The largest possible individual change description
{ would be for one complete screen row; the application should use a change
{ container large enough to contain one descriptor plus one screen-width,
{ since inability to store at least one change descriptor would cause
{ error code CSE$NO_TEXT_AVAILABLE.  Larger change containers are suggested
{ to minimize CALL/RETURN overhead.
{
{       CSP$GET_CHANGED_TEXT (P_CHANGE_CONTAINER, P_CHANGED_TEXT,
{             MORE_CHANGES, STATUS);
{
{ P_CHANGE_CONTAINER: (input)  This is a pointer to sequence which describes
{       a memory area owned by the application, into which changed text can
{       be encoded.
{
{ P_CHANGED_TEXT: (output)  Upon completion, this is a pointer to a sequence
{       within the memory area described by P_CHANGE_CONTAINER.  The
{       P_CHANGED_TEXT pointer describes how much of the memory area was
{       actually used, until all changes were exhausted or until the next
{       change would not have had enough room.  The memory area contains
{       a variable number of pairs, where each pair consists of a
{       descriptor and of an adaptable string.  The descriptor is of type
{       CST$TEXT_CHANGE_DESCRIPTION.
{
{ MORE_CHANGES: (output)  This boolean indicates whether or not the request
{       ran out of memory capacity before exhausting all changes.
{
{ STATUS: (output)  This receives any error codes.
{
{       condition identifiers:  cse$workspace_not_open
{                               cse$no_text_available
*DECK DECK=CSH$GET_MENU_ITEM_STRING EXPAND=FALSE
{
{ The purpose of this request is to read one menu string, addressed by
{ position in the menu list.  A pointer is returned, which if not NIL,
{ will point to Screen Manager's copy of the text.  A NIL value means
{ that the user had not previously provided any string at all.
{
{       CSP$GET_MENU_ITEM_STRING (MENU_ITEM_NUMBER, MENU_STRING, STATUS)
{
{ MENU_ITEM_NUMBER: (input)  This identifies the menu item whose string is
{       to be read and copied back to the caller.
{
{ MENU_STRING: (output)  This will receive the text of the menu string.
{
{ STATUS: (output) This receives any error codes.
{
{       condition_identifiers:  none at release 1.4.1
*DECK DECK=CSH$GET_MENU_STRINGS EXPAND=FALSE
{
{ The purpose of this request is to read the entire set of menu strings.
{ Pointers are returned for every menu item.  NIL values indicate menu items
{ which do not have any menu string.  Non-NIL pointers will point to the
{ copy of the text allocated by Screen Manager.
{
{       CSP$GET_MENU_STRINGS (MENU_STRINGS, STATUS)
{
{ MENU_STRINGS: (input)  This array points to the memory areas into which
{       each menu string will be copied.
{
{ STATUS: (output) This receives any error codes.
{
{       condition_identifiers:  none at release 1.4.1
*DECK DECK=CSH$GET_WORKSPACE_TEXT EXPAND=FALSE
{
{   The purpose of this request is to read a string from one row of the
{ workspace.  This request returns both unchanged and changed text from
{ the specified coordinates, whereas CSP$GET_CHANGED_TEXT returns only
{ changed text and performs a search to determine the coordinates.  The
{ CSP$GET_WORKSPACE_TEXT request returns as many characters as can fit
{ into the TEXT parameter, but if it runs past the edge of a screen
{ row before filling that parameter, it blank fills the extra room.
{
{       CSP$GET_WORKSPACE_TEXT (X_POSITION, Y_POSITION, TEXT, STATUS)
{
{ X_POSITION: (input)  This is the horizontal component of the first
{       coordinate from which text shall be read.
{
{ Y_POSITION: (input)  This is the vertical coordinate.
{
{ TEXT: (output)  This is the string into which text is returned.  This
{       is an adaptable string, and its capacity is the number of
{       characters requested.
{
{ STATUS: (output)  This receives any error codes.
{
{       condition identifiers:  cse$workspace_not_open
{                               cse$unknown_x_position
{                               cse$unknown_y_position
*DECK DECK=CSH$OPEN_WORKSTATION EXPAND=FALSE
{
{   The purpose of this request is to allocate the memory for the workspace
{ image, to allocate other resources, and to blank the screen.  It must
{ have been preceeded by a call to CSP$CHANGE_INTERACTION_STYLE to start
{ the screen-mode device driver.  This request implies that the application
{ will use only the workspace-oriented entry points, and cannot be used
{ if any of the field-oriented entry points have been called.
{
{       CSP$OPEN_WORKSTATION (WIDTH, HEIGHT, ATTRIBUTE, STATUS)
{
{ WIDTH: (input)  This indicates the number of columns in the workspace.
{
{ HEIGHT: (input)  This indicates the number of rows in the workspace.
{
{ ATTRIBUTE: (input)  This indicates the visual highlighting attributes
{       to be initially used.
{
{ STATUS: (output)  This receives any error codes.
{
{       condition identifiers:  cse$not_screen_mode
{                               cse$redundant_workspace
{                               cse$no_workspace_allowed
{                               cse$unknown_x_position
{                               cse$unknown_y_position
*DECK DECK=CSH$SET_MENU_STRINGS EXPAND=FALSE
{
{ The purpose of this request is to ask Screen Manager to free any memory
{ previously used to store menu strings, and to allocate space and save
{ copies of the text, for a new set of menu strings.  The user may leave
{ any pointers as NIL, in which case Screen Manager will allocate no space
{ and will use the NIL value in its internal structures.
{
{       CSP$SET_MENU_STRINGS (MENU_STRINGS, STATUS)
{
{ MENU_STRINGS: (input)  This array points to the memory areas from which
{       each menu string will be copied.
{
{ STATUS: (output) This receives any error codes.
{
{       condition_identifiers:  none at release 1.4.1
*DECK DECK=CSH$SET_WORKSPACE_CURSOR EXPAND=FALSE
{
{   This request is used to indicate where the cursor should be positioned
{ when the next CSP$DISPLAY_WORKSPACE or CSP$ACCEPT_INPUT paints the screen.
{
{       CSP$SET_WORKSPACE_CURSOR (X_POSITION, Y_POSITION, STATUS);
{
{ X_POSITION: (input)  This is the horizontal coordinate.
{
{ Y_POSITION: (input)  This is the vertical coordinate.
{
{ STATUS: (output)  This receives any error codes.
{
{       condition identifiers:  cse$workspace_not_open
{                               cse$unknown_x_position
{                               cse$unknown_y_position
*DECK DECK=CSK$TERMINAL_MANAGER_KEYPOINTS EXPAND=FALSE
{ COMMON DECK CSK$TERMINAL_MANAGER_KEYPOINTS DEFINES KEYPOINTS FOR
{ TERMINAL MANAGER PROCEDURES.

  CONST

    csk$get_event = csk$base + 1,
    {E 'csp$get_event' }
    {X 'csp$get_event' }

    csk$update_device = csk$base + 2,
    {E 'csp$update_device' }
    {X 'csp$update_device' }

    csk$get_input = csk$base + 3,
    {E 'get_input' }
    {X 'get_input' }

    csk$output_text = csk$base + 4;
    {E 'output_text' }
    {X 'output_text' }
*DECK DECK=CSM$ADM_31 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR LEAR SIEGLER ADM31 TERMINAL                 "

"   The position of DIP Switch Location C11 SW6 determines whether the       "
"   underline function or the blanking (hidden) function is enabled.  This   "
"   TDU assumes that the underline function has been enabled.  Comments are  "
"   used to indicate changes to be made if the blanking function is to be    "
"   enabled.                                                                 "

"   VARIABLES                                                                "

    clear_home          = (esc '*')
    normal_attr         = (esc 'G0')
    start_alternate     = ()
    start_blink         = (esc 'G2')
"   Uncomment this line if DIP Switch Location C11 SW6 is ON. (hidden)"
"   start_hidden        = (esc 'G1') "
    start_inverse       = (esc 'G4')
"   Uncomment this line if DIP Switch Location C11 SW6 is OFF. (underline)"
    start_underline     = (esc 'G1')
    start_protect       = (esc '&')
    stop_protect        = (esc '''')
    no_end_block_1      = (esc '.100') " No <cr> after FUNCTION/<char> "
    default_end_block_1 = (esc '.10D') " Send <cr> after FUNCTION/<char> "
    no_auto_page        = (esc 'w')

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'ADM_31'
    communications      type  = asynch
    application_string name='driver_procedure' out='tup$bootstrap_adm31_driver'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (32)  type = binary_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (esc '=')
    cursor_pos_second        out   = ()
    cursor_pos_third         out   = ()

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (rs)
    cursor_up                inout = (vt)
    cursor_down              inout = (lf)
    cursor_left              inout = (bs)
    cursor_right             inout = (ff)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = wrap_same_next
    move_past_bottom         type  = wrap_same_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next
    char_past_left           type  = wrap_adjacent_next
    char_past_last_position  type  = scroll_next

"   TERMINAL ATTRIBUTES                                                       "
    automatic_tabbing        value = FALSE
    clears_when_change_size  value = FALSE
    function_key_leaves_mark value = 1
" Change                                                               "
"   Uncomment this line if DIP Switch Location C11 SW6 is ON. (hidden) "
"   has_hidden               value = TRUE                              "
"   Uncomment this line if DIP Switch Location C11 SW6 is OFF. (underline)"
    has_hidden               value = FALSE
    has_protect              value = FALSE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    programmable_tab_stops   number = 0
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = FALSE
    tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80

"   SCREEN AND LINE MODE TRANSITION                                            "

    screen_init   out = (no_auto_page no_end_block_1 clear_home stop_protect)
    line_init     out = (default_end_block_1 clear_home stop_protect)

"   TERMINAL CAPABILITIES                                                     "
    delete_char         inout = (esc 'W')        label='CHAR DELETE'
    delete_line_bol     inout = (esc 'R')        label='LINE DELETE'
    erase_end_of_line   inout = (esc 'T')        label='LINE ERASE'
    erase_page_home     inout = (clear_home)
    insert_char         inout = (esc 'Q')        label='CHAR INSERT'
    insert_line_bol     inout = (esc 'E')        label='LINE INSERT'
    tab_backward        inout = (esc 'I')
    tab_forward         inout = (ht)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    bell_nak            out = (bel)
    output_begin        out = ()
    output_end          out = ()

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (soh '1')             label='f1'
    f2        in = (soh '2')             label='f2'
    f3        in = (soh '3')             label='f3'
    f4        in = (soh '4')             label='f4'
    f5        in = (soh '5')             label='f5'
    f6        in = (soh '6')             label='f6'
    f7        in = (soh '7')             label='f7'
    f8        in = (soh '8')             label='f8'
    f9        in = (soh 'q')             label='fq'
    f10       in = (soh 'w')             label='fw'
    f11       in = (soh 'e')             label='fe'
    f12       in = (soh 'r')             label='fr'
    f13       in = (soh 't')             label='ft'
    f14       in = (soh 'y')             label='fy'
    f15       in = (soh 'u')             label='fu'
    f16       in = (soh 'i')             label='fi'
    f1_s      in = (soh '!')             label='f!'
    f2_s      in = (soh '"')             label='f"'
    f3_s      in = (soh '#')             label='f#'
    f4_s      in = (soh '$')             label='f$'
    f5_s      in = (soh '%')             label='f%'
    f6_s      in = (soh '&')             label='f&'
    f7_s      in = (soh '''')            label='f'''
    f8_s      in = (soh '(')             label='f('
    f9_s      in = (soh 'Q')             label='fQ'
    f10_s     in = (soh 'W')             label='fW'
    f11_s     in = (soh 'E')             label='fE'
    f12_s     in = (soh 'R')             label='fR'
    f13_s     in = (soh 'T')             label='fT'
    f14_s     in = (soh 'Y')             label='fY'
    f15_s     in = (soh 'U')             label='fU'
    f16_s     in = (soh 'I')             label='fI'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13                    label='RETURN'
    next_s    in = ()
    back      in = ()
    back_s    in = ()
    help      in = ()
    help_s    in = ()
    stop      in = ()
    stop_s    in = ()
    down      in = ()
    down_s    in = ()
    up        in = ()
    up_s      in = ()
    fwd       in = ()
    fwd_s     in = ()
    bkw       in = ()
    bkw_s     in = ()
    edit      in = ()
    edit_s    in = ()
    data      in = ()
    data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                "
    alt_begin           out = ()
    alt_end             out = (normal_attr)
"   Uncomment this line if DIP Switch Location C11 SW6 is ON. (hidden)"
"   hidden_begin        out = (start_hidden)                           "
    hidden_begin        out = ()
    hidden_end          out = (normal_attr)
    inverse_begin       out = (start_inverse)
    inverse_end         out = (normal_attr)
    protect_begin       out = ()
    protect_end         out = ()
"   Uncomment this line if DIP Switch Location C11 SW6 is OFF. (underline)"
    underline_begin     out = (start_underline)
    underline_end       out = (normal_attr)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_inverse)
    error_end           out = (normal_attr)
"   Uncomment this line if DIP Switch Location C11 SW6 is ON. (hidden)"
"   input_text_begin    out = (start_inverse)                          "
"   Uncomment this line if DIP Switch Location C11 SW6 is OFF. (underline)"
    input_text_begin    out = ()
    input_text_end      out = ()
    italic_begin        out = (start_inverse)
    italic_end          out = (normal_attr)
    message_begin       out = ()
    message_end         out = ()
    output_text_begin   out = ()
    output_text_end     out = ()


"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = ()
    ld_fine_end              out = ()
    ld_fine_horizontal       out = ('-')
    ld_fine_vertical         out = ('|')
    ld_fine_upper_left       out = ('*')
    ld_fine_upper_right      out = ('*')
    ld_fine_lower_left       out = ('*')
    ld_fine_lower_right      out = ('*')
    ld_fine_up_t             out = ('T')
    ld_fine_down_t           out = ('_')
    ld_fine_left_t           out = ('|')
    ld_fine_right_t          out = ('|')
    ld_fine_cross            out = ('+')
    ld_medium_begin          out = ()
    ld_medium_end            out = ()
    ld_medium_horizontal     out = ('-')
    ld_medium_vertical       out = ('|')
    ld_medium_upper_left     out = ('*')
    ld_medium_upper_right    out = ('*')
    ld_medium_lower_left     out = ('*')
    ld_medium_lower_right    out = ('*')
    ld_medium_up_t           out = ('T')
    ld_medium_down_t         out = ('_')
    ld_medium_left_t         out = ('|')
    ld_medium_right_t        out = ('|')
    ld_medium_cross          out = ('+')
    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (normal_attr)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')

"   END OF TERMINAL DEFINITION FILE FOR LEAR SIEGLER ADM31 TERMINAL           "
*DECK DECK=CSM$ADM_31_PROTECTED EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR LEAR SIEGLER ADM31 TERMINAL WITH PROTECTION  "

"   The position of DIP Switch Location C11 SW6 determines whether the       "
"   underline function or the blanking (hidden) function is enabled.  This   "
"   TDU assumes that the underline function has been enabled.  Comments are  "
"   used to indicate changes to be made if the blanking function is to be    "
"   enabled.                                                                 "

"   VARIABLES                                                                "

    clear_home          = (esc '*')
    normal_attr         = (esc 'G0')
    start_alternate     = ()
    start_blink         = (esc 'G2')
"   Uncomment this line if DIP Switch Location C11 SW6 is ON. (hidden)"
"   start_hidden        = (esc 'G1')
    start_inverse       = (esc 'G4')
"   Uncomment this line if DIP Switch Location C11 SW6 is OFF. (underline)"
    start_underline     = (esc 'G1')
    start_protect       = (esc '&')
    stop_protect        = (esc '''')
    no_end_block_1      = (esc '.100') " No <cr> after FUNCTION/<char> "
    default_end_block_1 = (esc '.10D') " Send <cr> after FUNCTION/<char> "
    no_auto_page        = (esc 'w')

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'ADM_31_PROTECTED'
    communications      type  = asynch
    application_string name='driver_procedure' out='tup$bootstrap_adm31_driver'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (32)  type = binary_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (esc '=')
    cursor_pos_second        out   = ()
    cursor_pos_third         out   = ()

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (rs)
    cursor_up                inout = (vt)
    cursor_down              inout = (lf)
    cursor_left              inout = (bs)
    cursor_right             inout = (ff)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = wrap_same_next
    move_past_bottom         type  = wrap_same_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next
    char_past_left           type  = wrap_adjacent_next
    char_past_last_position  type  = scroll_next

"   TERMINAL ATTRIBUTES                                                       "
    automatic_tabbing        value = FALSE
    clears_when_change_size  value = FALSE
    function_key_leaves_mark value = 1
" Change                                                               "
"   Uncomment this line if DIP Switch Location C11 SW6 is ON. (hidden) "
"   has_hidden               value = TRUE                              "
"   Uncomment this line if DIP Switch Location C11 SW6 is OFF. (underline)"
    has_hidden               value = FALSE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    programmable_tab_stops   number = 0
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = FALSE
    tabs_to_unprotected      value = TRUE

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80

"   SCREEN AND LINE MODE TRANSITION                                            "

    screen_init         out = (no_auto_page)
    screen_init         out = (no_end_block_1 clear_home stop_protect)
    line_init           out = (default_end_block_1 clear_home stop_protect)

"   TERMINAL CAPABILITIES                                                     "
    delete_char         inout = (esc 'W')        label='CHAR DELETE'
    delete_line_bol     inout = (esc 'R')        label='LINE DELETE'
    erase_end_of_line   inout = (esc 'T')        label='LINE ERASE'
    erase_page_home     inout = (clear_home)
    insert_char         inout = (esc 'Q')        label='CHAR INSERT'
    insert_line_bol     inout = (esc 'E')        label='LINE INSERT'
    tab_backward        inout = (esc 'I')
    tab_forward         inout = (ht)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    bell_nak            out = (bel)
    output_begin        out = (stop_protect)
    output_end          out = (start_protect)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (soh '1')             label='f1'
    f2        in = (soh '2')             label='f2'
    f3        in = (soh '3')             label='f3'
    f4        in = (soh '4')             label='f4'
    f5        in = (soh '5')             label='f5'
    f6        in = (soh '6')             label='f6'
    f7        in = (soh '7')             label='f7'
    f8        in = (soh '8')             label='f8'
    f9        in = (soh 'q')             label='fq'
    f10       in = (soh 'w')             label='fw'
    f11       in = (soh 'e')             label='fe'
    f12       in = (soh 'r')             label='fr'
    f13       in = (soh 't')             label='ft'
    f14       in = (soh 'y')             label='fy'
    f15       in = (soh 'u')             label='fu'
    f16       in = (soh 'i')             label='fi'
    f1_s      in = (soh '!')             label='f!'
    f2_s      in = (soh '"')             label='f"'
    f3_s      in = (soh '#')             label='f#'
    f4_s      in = (soh '$')             label='f$'
    f5_s      in = (soh '%')             label='f%'
    f6_s      in = (soh '&')             label='f&'
    f7_s      in = (soh '''')            label='f'''
    f8_s      in = (soh '(')             label='f('
    f9_s      in = (soh 'Q')             label='fQ'
    f10_s     in = (soh 'W')             label='fW'
    f11_s     in = (soh 'E')             label='fE'
    f12_s     in = (soh 'R')             label='fR'
    f13_s     in = (soh 'T')             label='fT'
    f14_s     in = (soh 'Y')             label='fY'
    f15_s     in = (soh 'U')             label='fU'
    f16_s     in = (soh 'I')             label='fI'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13                    label='RETURN'
    next_s    in = ()
    back      in = ()
    back_s    in = ()
    help      in = ()
    help_s    in = ()
    stop      in = ()
    stop_s    in = ()
    down      in = ()
    down_s    in = ()
    up        in = ()
    up_s      in = ()
    fwd       in = ()
    fwd_s     in = ()
    bkw       in = ()
    bkw_s     in = ()
    edit      in = ()
    edit_s    in = ()
    data      in = ()
    data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                "
    alt_begin           out = ()
    alt_end             out = (normal_attr)
"   Uncomment this line if DIP Switch Location C11 SW6 is ON. (hidden)"
"   hidden_begin        out = (start_hidden)                           "
    hidden_begin        out = ()
    hidden_end          out = (normal_attr)
    inverse_begin       out = (start_inverse)
    inverse_end         out = (normal_attr)
    protect_begin       out = (esc ')')
    protect_end         out = (esc '(')
"   Uncomment this line if DIP Switch Location C11 SW6 is OFF. (underline)"
    underline_begin     out = (start_underline)
    underline_end       out = (normal_attr)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_inverse)
    error_end           out = (normal_attr)
"   Uncomment this line if DIP Switch Location C11 SW6 is ON. (hidden)"
"   input_text_begin    out = (start_inverse)                          "
"   Uncomment this line if DIP Switch Location C11 SW6 is OFF. (underline)"
    input_text_begin    out = ()
    input_text_end      out = ()
    italic_begin        out = (start_inverse)
    italic_end          out = (normal_attr)
    message_begin       out = ()
    message_end         out = ()
    output_text_begin   out = ()
    output_text_end     out = ()


"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = ()
    ld_fine_end              out = ()
    ld_fine_horizontal       out = ('-')
    ld_fine_vertical         out = ('|')
    ld_fine_upper_left       out = ('*')
    ld_fine_upper_right      out = ('*')
    ld_fine_lower_left       out = ('*')
    ld_fine_lower_right      out = ('*')
    ld_fine_up_t             out = ('T')
    ld_fine_down_t           out = ('_')
    ld_fine_left_t           out = ('|')
    ld_fine_right_t          out = ('|')
    ld_fine_cross            out = ('+')
    ld_medium_begin          out = ()
    ld_medium_end            out = ()
    ld_medium_horizontal     out = ('-')
    ld_medium_vertical       out = ('|')
    ld_medium_upper_left     out = ('*')
    ld_medium_upper_right    out = ('*')
    ld_medium_lower_left     out = ('*')
    ld_medium_lower_right    out = ('*')
    ld_medium_up_t           out = ('T')
    ld_medium_down_t         out = ('_')
    ld_medium_left_t         out = ('|')
    ld_medium_right_t        out = ('|')
    ld_medium_cross          out = ('+')
    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (normal_attr)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')

"   END OF TERMINAL DEFINITION FILE FOR LEAR SIEGLER ADM31 TERMINAL           "
*DECK DECK=CSM$CDC721 EXPAND=TRUE


"   TERMINAL DEFINITION FILE FOR CDC VIKING 721 TERMINAL                      "

" Automatic tabbing is available as a user or site option.  To enable it,     "
" change the automatic_tabbing firective from FALSE to TRUE, and look at the  "
" set_screen_mode and set_line_mode directives for comment-disabled references"
" to the variables enable_autotab and disable_autotab -- enable these         "
" references by blanking over the comment quotes.                             "

"   VARIABLES                                                                 "
clear_all_tabs      = (rs dc2 'Y')
disable_autotab     = (rs '#')
disable_blink       = (eot)
disable_auto_cr     = (rs '''')
disable_protect     = (rs dc2 'L')
disable_touchpanel  = (rs dc2 'Q')
disable_old_attr    = (rs '-')
enable_auto_cr      = (rs '&')
enable_autotab      = (rs '"')
enable_clear        = (rs '$')
enable_cr_delim     = (rs enq)
enable_blink        = (etx)
enable_protect      = (rs dc2 'K')
enable_typeamatic   = (rs dc2 'i')
enable_touchpanel   = (rs dc2 'R')
end_print           = (rs 7f(16))
large_cyber_mode    = (rs dc2 'B')
page_mode           = (syn)
pop_fn_keys         = (rs dc2 71(16) cr)
push_fn_keys        = (rs dc2 70(16) cr)
scroll_mode         = (dc2)
shift_numeric_pad   = (rs dc2 6B(16))
start_inverse       = (rs 'D')
start_underline     = (ack)
stop_inverse        = (rs 'E')
stop_underline      = (nak)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'CDC721'
communications      type  = asynch
application_string  name='insert_delete_scrolling' out='true'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (32)   type = cdc721_cursor
cursor_pos_column_first  value = TRUE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         in    = (1e(16) 4d(16) 1f(16))  label = 'TOUCH'
cursor_pos_begin         out   = (stx)
cursor_pos_second        out   = (7E(16) soh)

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (em)     label='HOME'
cursor_up                inout = (etb)
cursor_down              inout = (sub)
cursor_left              inout = (bs)
cursor_right             inout = (can)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = wrap_adjacent_next
move_past_left           type  = wrap_adjacent_next
move_past_top            type  = wrap_same_next
move_past_bottom         type  = wrap_same_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = wrap_adjacent_next
char_past_left           type  = wrap_adjacent_next
char_past_last_position  type  = wrap_adjacent_next

"   TERMINAL ATTRIBUTES                                                       "
automatic_tabbing        value = FALSE
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 0
has_hidden               value = TRUE
has_protect              value = TRUE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = TRUE

"   SCREEN SIZES                                                              "
set_size       rows = 30 columns = 80   out = (rs dc2 'H' rs dc2 '^')  ..
 character_specification = (11,70,4) line_specification = (1,29,2) ..
 device = 'TOUCH_PANEL'
set_size rows = 30 columns = 132  out = (rs dc2 'G' rs dc2 '^') ..
 character_positions = (20,26,33,39,45,51,57,64,70,76,82,88, ..
 95,101,107,113) line_specification = (1,29,2) device = 'TOUCH_PANEL'

"   SCREEN AND LINE MODE TRANSITION                                           "
set_screen_mode     out = (push_fn_keys  shift_numeric_pad  enable_clear...
 large_cyber_mode  disable_auto_cr  enable_cr_delim  clear_all_tabs ...
 enable_blink  end_print  page_mode  disable_old_attr ..
 "enable_touchpanel" "enable_autotab" )

set_line_mode       out = (scroll_mode  enable_auto_cr  clear_all_tabs  ...
 "disable_touchpanel" pop_fn_keys "disable_autotab" )

"   TERMINAL CAPABILITIES                                                     "
delete_char         inout = (rs 4e(16))       label='DLETE_C'
delete_line_stay    inout = (rs 51(16))       label='DLETE_L'
erase_char          inout = (1f(16))
erase_end_of_line   inout = (vt)              label='CLR_EOL'
erase_field_stay    inout = (rs 59(16))
erase_field_bof     inout = (rs 5D(16))
erase_page_home     inout = (ff)              label='CLEAR_P'
insert_char         inout = (rs 4f(16))       label='INSRT_C'
insert_line_stay    inout = (rs 52(16))       label='INSRT_L'
tab_backward        inout = (rs 0b(16))
tab_clear           inout = (rs dc2 'X')
tab_clear_all       inout = (clear_all_tabs)
tab_forward         inout = (ht)
tab_set             inout = (rs dc2 'W')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
output_begin        out = (disable_protect)
output_end          out = (enable_protect)
protect_all         out = (rs 'G')

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (rs 71(16)) label= 'f1'
f2        in = (rs 72(16)) label= 'f2'
f3        in = (rs 73(16)) label= 'f3'
f4        in = (rs 74(16)) label= 'f4'
f5        in = (rs 75(16)) label= 'f5'
f6        in = (rs 76(16)) label= 'f6'
f7        in = (rs 77(16)) label= 'f7'
f8        in = (rs 78(16)) label= 'f8'
f9        in = (rs 79(16)) label= 'f9'
f10       in = (rs 7A(16)) label= '10'
f11       in = (rs 7B(16)) label= '11'
f12       in = (rs 7C(16)) label= '12'
f13       in = (rs 7D(16)) label= '13'
f14       in = (rs 7E(16)) label= '14'
f15       in = (rs 70(16)) label= '15'
f16       in = (rs dc2 31(16)) label= '16'
f1_s      in = (rs 61(16))     label= '  SF1'
f2_s      in = (rs 62(16))     label= '  SF2'
f3_s      in = (rs 63(16))     label= '  SF3'
f4_s      in = (rs 64(16))     label= '  SF4'
f5_s      in = (rs 65(16))     label= '  SF5'
f6_s      in = (rs 66(16))     label= '  SF6'
f7_s      in = (rs 67(16))     label= '  SF7'
f8_s      in = (rs 68(16))     label= '  SF8'
f9_s      in = (rs 69(16))     label= '  SF9'
f10_s     in = (rs 6A(16))     label= '  SF10'
f11_s     in = (rs 6B(16))     label= '  SF11'
f12_s     in = (rs 6C(16))     label= '  SF12'
f13_s     in = (rs 6D(16))     label= '  SF13'
f14_s     in = (rs 6E(16))     label= '  SF14'
f15_s     in = (rs 60(16))     label= '  SF15'
f16_s     in = (rs dc2 32(16)) label= '  SF16'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13  label='NEXT'
undo      in = (rs 75(16))     label= 'f5'
undo_s    in = (rs 65(16))     label= '  SF5'
back      in = (rs 5F(16))     label= 'BACK'
back_s    in = (rs 5B(16))     label= 'Shift-BACK'
help      in = (rs 5C(16))     label= 'HELP'
help_s    in = (rs 58(16))     label= 'Shift-HELP'
stop      in = (rs 49(16))     label= 'STOP'
stop_s    in = (rs 4A(16))     label= 'Shift-STOP'
down      in = (rs dc2 20(16)) label= 'DOWN'
down_s    in = (rs dc2 21(16)) label= 'Shift-DOWN'
up        in = (rs dc2 24(16)) label= 'UP'
up_s      in = (rs dc2 25(16)) label= 'Shift-UP'
fwd       in = (rs dc2 28(16)) label= 'FWD'
fwd_s     in = (rs dc2 29(16)) label= 'Shift-FWD'
bkw       in = (rs dc2 2C(16)) label= 'BKW'
bkw_s     in = (rs dc2 2d(16)) label= 'Shift-BKW'
edit      in = (rs 5E(16))     label= 'EDIT'
edit_s    in = (rs 5A(16))     label= 'Shift-EDIT'
data      in = (rs dc2 35(16)) label= 'DATA'
data_s    in = (rs dc2 36(16)) label= 'Shift-DATA'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (fs)
alt_end             out = (gs)
blink_begin         out = (so etx)
blink_end           out = (si)
hidden_begin        out = (rs dc2 '[')
hidden_end          out = (rs dc2 5C(16))
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
protect_begin       out = (rs dc2 'I')
protect_end         out = (rs dc2 'J')
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)
low_intensity_begin  out = (fs)
low_intensity_end    out = (gs)
high_intensity_begin out = (gs)
high_intensity_end   out = (fs)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)
message_begin       out = ()
message_end         out = ()
output_text_begin   out = ()
output_text_end     out = ()
title_begin         out = ()
title_end           out = ()

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = (rs fs)
ld_fine_end              out = (rs gs)
ld_fine_horizontal       out = 20(16)
ld_fine_vertical         out = 21(16)
ld_fine_upper_left       out = 22(16)
ld_fine_upper_right      out = 23(16)
ld_fine_lower_left       out = 24(16)
ld_fine_lower_right      out = 25(16)
ld_fine_up_t             out = 26(16)
ld_fine_down_t           out = 27(16)
ld_fine_left_t           out = 28(16)
ld_fine_right_t          out = 29(16)
ld_fine_cross            out = 2A(16)
ld_medium_begin          out = (rs fs)
ld_medium_end            out = (rs gs)
ld_medium_horizontal     out = 2B(16)
ld_medium_vertical       out = 2C(16)
ld_medium_upper_left     out = 2D(16)
ld_medium_upper_right    out = 2E(16)
ld_medium_lower_left     out = 2F(16)
ld_medium_lower_right    out = 30(16)
ld_medium_up_t           out = 31(16)
ld_medium_down_t         out = 32(16)
ld_medium_left_t         out = 33(16)
ld_medium_right_t        out = 34(16)
ld_medium_cross          out = 35(16)
ld_bold_begin            out = start_inverse
ld_bold_end              out = stop_inverse
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')


"   END OF TERMINAL DEFINITION FILE FOR CDC VIKING 721 TERMINAL               "
*DECK DECK=CSM$CDC722 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR CDC VIKING 722 TERMINAL                      "

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'CDC722'
communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (32)   type = binary_cursor
cursor_pos_column_first  value = TRUE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (esc 31(16))

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (em)      label='HOME'
cursor_up                inout = (sub)
cursor_down              inout = (lf)
cursor_left              inout = (bs)
cursor_right             inout = (nak)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = wrap_adjacent_next
move_past_left           type  = wrap_adjacent_next
move_past_top            type  = wrap_same_next
move_past_bottom         type  = scroll_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = wrap_adjacent_next
char_past_left           type  = wrap_adjacent_next
char_past_last_position  type  = scroll_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = FALSE
function_key_leaves_mark value = 0
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = FALSE
multiple_sizes           value = FALSE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = FALSE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80

"   TERMINAL CAPABILITIES                                                     "
erase_end_of_line   inout = (syn)    label='CLR_EOL'
erase_page_home     inout = (can)    label='CLEAR_P'
tab_forward         inout = (ht)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
output_begin        out = ()
output_end          out = ()
bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (rs 'q')      label = 'f1'
f2        in = (rs 'r')      label = 'f2'
f3        in = (rs 's')      label = 'f3'
f4        in = (rs 't')      label = 'f4'
f5        in = (rs 'u')      label = 'f5'
f6        in = (rs 'v')      label = 'f6'
f7        in = (rs 'w')      label = 'f7'
f8        in = (rs 'x')      label = 'f8'
f9        in = (rs 'y')      label = 'f9'
f10       in = (rs 'z')      label = '10'
f11       in = (rs '{')      label = '11'
f12       in = ()
f13       in = ()
f14       in = ()
f15       in = ()
f16       in = ()

f1_s      in = (rs 'a')      label = '  SF1'
f2_s      in = (rs 'b')      label = '  SF2'
f3_s      in = (rs 'c')      label = '  SF3'
f4_s      in = (rs 'd')      label = '  SF4'
f5_s      in = (rs 'e')      label = '  SF5'
f6_s      in = (rs 'f')      label = '  SF6'
f7_s      in = (rs 'g')      label = '  SF7'
f8_s      in = (rs 'h')      label = '  SF8'
f9_s      in = (rs 'i')      label = '  SF9'
f10_s     in = (rs 'j')      label = '  SF10'
f11_s     in = (rs 'k')      label = '  SF11'
f12_s     in = ()
f13_s     in = ()
f14_s     in = ()
f15_s     in = ()
f16_s     in = ()

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'NEWLINE'
next_s    in = ()
bkw       in = (rs 'q')      label = 'f1'
fwd       in = (rs 'r')      label = 'f2'
back      in = (rs 's')      label = 'f3'
help      in = (rs 't')      label = 'f4'
undo      in = (rs 'u')      label = 'f5'
stop      in = (rs 'v')      label = 'f6'
bkw_s     in = (rs 'a')      label = '  SF1'
fwd_s     in = (rs 'b')      label = '  SF2'
undo_s    in = (rs 'e')      label = '  SF5'
stop_s    in = (rs 'f')      label = '  SF6'
back_s    in = ()
help_s    in = ()
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_horizontal       out = ('-')
ld_fine_vertical         out = ('|')
ld_fine_upper_left       out = ('*')
ld_fine_upper_right      out = ('*')
ld_fine_lower_left       out = ('*')
ld_fine_lower_right      out = ('*')
ld_fine_up_t             out = ('*')
ld_fine_down_t           out = ('*')
ld_fine_left_t           out = ('*')
ld_fine_right_t          out = ('*')
ld_fine_cross            out = ('*')
ld_medium_horizontal     out = ('-')
ld_medium_vertical       out = ('|')
ld_medium_upper_left     out = ('*')
ld_medium_upper_right    out = ('*')
ld_medium_lower_left     out = ('*')
ld_medium_lower_right    out = ('*')
ld_medium_up_t           out = ('*')
ld_medium_down_t         out = ('*')
ld_medium_left_t         out = ('*')
ld_medium_right_t        out = ('*')
ld_medium_cross          out = ('*')
ld_bold_horizontal       out = ('-')
ld_bold_vertical         out = ('|')
ld_bold_upper_left       out = ('*')
ld_bold_upper_right      out = ('*')
ld_bold_lower_left       out = ('*')
ld_bold_lower_right      out = ('*')
ld_bold_up_t             out = ('*')
ld_bold_down_t           out = ('*')
ld_bold_left_t           out = ('*')
ld_bold_right_t          out = ('*')
ld_bold_cross            out = ('*')


"   END OF TERMINAL DEFINITION FILE FOR CDC 722 TERMINAL                      "
*DECK DECK=CSM$CDC722_30 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR CDC 722-30 TERMINAL                          "

"   Note that this terminal definition is supplied with protection and auto-  "
"   tabbing enabled with protected areas dim and unprotected areas bright.    "
"   This arrangement is best for applications that use most of their screen   "
"   area for unprotected (input) fields, such as the Full Screen Editor.      "
"   If you primarily use this terminal with applications that protect most of "
"   the screen area, such as Edit_Catalog, you may prefer to reverse the dim  "
"   and bright assignments.  If you frequently switch between applications    "
"   that are mostly protected versus mostly unprotected, you may prefer to    "
"   use the terminal with all areas bright and no protection.                 "

"   To modify this definition to drop protection and have all areas bright,   "
"   look for statements that have the comments FOR EITHER BRIGHT OR DIM       "
"   PROTECTION and remove or disable (via comments) such statements.  Then    "
"   look for comment-disabled statements that have the comments FOR NO        "
"   PROTECTION and enable these statements by blanking the comments away.     "

"   You also have the option to modify this definition to keep protection and "
"   auto-tabbing, but with the bright/dim exchanged so that protected areas   "
"   are bright and unprotected areas are dim.  To do so, look for statements  "
"   commented as FOR PROTECT=DIM and FOR PROTECT=BRIGHT, and enable/disable   "
"   such statements by reversing th comment quotes.                           "

"   VARIABLES                                                                 "
    prefix              = ( 1B(16) 5B(16))
    clear_stay          = ( prefix 32(16) 4A(16) )
    clear_eop           = ( prefix 4A(16) )
    clear_all_tabs      = ( prefix 33(16) 67(16) )
    home_cursor         = ( prefix 48(16) )
    enable_insertion    = ( prefix 34(16) 68(16) )
    disable_insertion   = ( prefix 34(16) 6C(16) )

    enable_protect      = ( prefix 31(16) 7D(16) )  "for protect=dim"
  " enable_protect      = ( prefix '254'  7D(16) )   for protect=bright"

    disable_protect     = ( prefix 30(16) 7D(16) )
    start_alternate     = ( prefix 31(16) 6D(16) )
    stop_alternate      = ( prefix 6D(16) )
    start_blink         = ( prefix 35(16) 6D(16) )
    stop_blink          = ( prefix 6D(16) )
    erase_all_off       = ( prefix 36(16) 6C(16) )
    erase_all_on        = ( prefix 36(16) 68(16) )
    normal              = ( prefix 6D(16) )
    start_hidden        = ( prefix 36(16) 6D(16) )
    stop_hidden         = ( prefix 6D(16) )
    start_inverse       = ( prefix 37(16) 6D(16) )
    stop_inverse        = ( prefix 6D(16) )
    start_underline     = ( prefix 34(16) 6D(16) )
    stop_underline      = ( prefix 6D(16) )
    enable_buffer       = ( prefix '>h' )
    disable_buffer      = ( prefix '>l' )
    clear_buffer        = ( prefix '1~' )
    release_buffer      = ( prefix '0~' )
    stop_scroll         = ( prefix '?7l' )
    start_scroll        = ( prefix '?7h' )
    start_wrap          = ( prefix 3F(16) 37(16) 68(16))
    stop_wrap           = ( prefix 3F(16) 37(16) 6C(16))

    start_protect       = ( start_alternate )   " for protect=dim "
    stop_protect        = ( stop_alternate )    " for protect=dim "
  " start_protect       = ( stop_alternate )      for protect=bright "
  " stop_protect        = ( start_alternate )     for protect=bright "

    n_pad_shift         = ( 1b(16) '[=1h' 1e(16) 12(16) 'k' 1e(16) 12(16)..
                            'S2' 1b(16) '[2J')
    n_pad_normal        = ( 1b(16) '[=1h' 1e(16) 12(16) 'l' 1e(16) 12(16)..
                            'S2' 1b(16) '[2J')
    designate_text      = ( 1B(16) 28(16) 42(16))
    designate_graphics  = ( 1B(16) 29(16) 30(16))
    invoke_text         = ( 0F(16))
    invoke_graphics     = ( 0E(16))

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'CDC722_30'
    communications      type  = asynch
    application_string  name  = 'VT100_SCROLLING'  out = 'TRUE'

"   BACKSPACE SPECIFIED                                                       "
    backspace           in =  ( 08(16) )

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   =  prefix
    cursor_pos_second        out   = ( 3B(16) )
    cursor_pos_third         out   = ( 48(16) )

"   CURSOR MOVEMENT INFORMATION
    cursor_home              inout = ( home_cursor )   label='HOME'
    cursor_up                inout = ( prefix 41(16) )
    cursor_down              inout = ( prefix 42(16) )
    cursor_left              inout = ( prefix 44(16) )
    cursor_right             inout = ( prefix 43(16) )

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = stop_next
    move_past_left           type  = stop_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = stop_next
    char_past_left           type  = stop_next
    char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "

    automatic_tabbing        value = TRUE  " for either bright or dim protect "
  " automatic_tabbing        value = FALSE   for no protection "

    clears_when_change_size  value = FALSE
    function_key_leaves_mark value = 0
    has_hidden               value = TRUE

    has_protect              value = TRUE  " for either bright or dim protect "
  " has_protect              value = FALSE   for no protection "

    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE

    tabs_to_unprotected      value = TRUE  " for either bright or dim protect "
  " tabs_to_unprotected      value = FALSE   for no protection "

    type_ahead               value = TRUE

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode     out = ( enable_buffer  clear_all_tabs ..
        designate_text  designate_graphics  invoke_text ..
        stop_scroll  stop_wrap   n_pad_shift)

    set_line_mode       out = ( clear_all_tabs  designate_text ..
        designate_graphics  invoke_text  disable_buffer  start_scroll ..
        n_pad_normal  start_wrap    home_cursor)

"   TERMINAL CAPABILITIES                                                     "
    delete_char         inout = ( prefix 50(16) )     label='C_DLETE'
    delete_line_stay    inout = ( prefix 4D(16) )     label='L_DLETE'
    erase_end_of_line   inout = ( prefix 4B(16) )     label='CLR_EOL'
    erase_end_of_page   inout = ( clear_eop )
    erase_line_stay     inout = ( prefix 32(16) 4B(16) )
    erase_page_stay     inout = ( clear_stay )        label='CLEAR_P'
    insert_line_stay    inout = ( prefix 4C(16) )     label='L_INSRT'
    insert_mode_begin   inout = ( enable_insertion )  label='BGN_INS'
    insert_mode_end     inout = ( disable_insertion )
" protect_all out=(start_protect clear_stay stop_protect) for protect=bright "
    tab_backward        inout = ( prefix 46(16) )
    tab_forward         inout = ( 09(16) )
    tab_clear_all       inout = ( clear_all_tabs )
    tab_set             inout = ( 1B(16) 48(16) )

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "

    output_begin        out = ( disable_protect erase_all_on normal) " for either bright or dim protect "
    output_end          out = ( enable_protect erase_all_off release_buffer ) " for either bright or dim protect "
  " output_begin        out = ( erase_all_on normal) for no protection "
  " output_end          out=(erase_all_off release_buffer)  for no protection "

    bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = ( 1B(16) 4F(16) 50(16) )    label='f1'
    f2        in = ( 1B(16) 4F(16) 51(16) )    label='f2'
    f3        in = ( 1B(16) 4F(16) 52(16) )    label='f3'
    f4        in = ( 1B(16) 4F(16) 53(16) )    label='f4'
    f5        in = ( 1B(16) 4F(16) 6D(16) )    label='f5'
    f6        in = ( 1B(16) 4F(16) 6C(16) )    label='f6'
    f7        in = ( 1B(16) 4F(16) 4D(16) )    label='f7'
    f8        in = ( 1B(16) 4F(16) 6E(16) )    label='f8'
    f9        in = ( 1B(16) 4F(16) 41(16) )    label='f9'
    f10       in = ( 1B(16) 4F(16) 42(16) )    label='10'
    f11       in = ( 1B(16) 4F(16) 43(16) )    label='11'
    f12       in = ( 1B(16) 4F(16) 44(16) )    label='12'
    f13       in = ( )
    f14       in = ( )
    f15       in = ( )
    f16       in = ( )
    f1_s      in = ( 1B(16) 4F(16) 71(16) )    label='  SF1'
    f2_s      in = ( 1B(16) 4F(16) 72(16) )    label='  SF2'
    f3_s      in = ( 1B(16) 4F(16) 73(16) )    label='  SF3'
    f4_s      in = ( 1B(16) 4F(16) 74(16) )    label='  SF4'
    f5_s      in = ( 1B(16) 4F(16) 75(16) )    label='  SF5'
    f6_s      in = ( 1B(16) 4F(16) 76(16) )    label='  SF6'
    f7_s      in = ( 1B(16) 4F(16) 77(16) )    label='  SF7'
    f8_s      in = ( 1B(16) 4F(16) 78(16) )    label='  SF8'
    f9_s      in = ( 1B(16) 4F(16) 79(16) )    label='  SF9'
    f10_s     in = ( 1B(16) 4F(16) 70(16) )    label='  SF10'
    f11_s     in = ( 1B(16) 4F(16) 7A(16) )    label='  SF11'
    f12_s     in = ( 1B(16) 4F(16) 7B(16) )    label='  SF12'
    f13_s     in = ( )
    f14_s     in = ( )
    f15_s     in = ( )
    f16_s     in = ( )

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in=13                            label='RETURN'
    next_s    in=()
    bkw       in = ( 1B(16) 4F(16) 50(16) )    label='f1'
    fwd       in = ( 1B(16) 4F(16) 51(16) )    label='f2'
    back      in = ( 1B(16) 4F(16) 52(16) )    label='f3'
    help      in = ( 1B(16) 4F(16) 53(16) )    label='f4'
    undo      in = ( 1B(16) 4F(16) 6D(16) )    label='f5'
    stop      in = ( 1B(16) 4F(16) 6C(16) )    label='f6'
    bkw_s     in = ( 1B(16) 4F(16) 71(16) )    label='  SF1'
    fwd_s     in = ( 1B(16) 4F(16) 72(16) )    label='  SF2'
    undo_s    in = ( 1B(16) 4F(16) 75(16) )    label='  SF5'
    stop_s    in = ( 1B(16) 4F(16) 76(16) )    label='  SF6'
    edit      in = ( esc '[?10l' )
    edit_s    in = ( )
    data      in = ( )
    data_s    in = ( )

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out =  start_alternate
    alt_end             out =  stop_alternate
    blink_begin         out =  start_blink
    blink_end           out =  stop_blink
    hidden_begin        out =  start_hidden
    hidden_end          out =  stop_hidden
    inverse_begin       out =  start_inverse
    inverse_end         out =  stop_inverse

    protect_begin       out =  start_protect  " for either bright or dim protect "
    protect_end         out =  stop_protect   " for either bright or dim protect "
  " protect_begin       out =  ()             for no protection "
  " protect_end         out =  ()             for no protection "

    underline_begin     out =  start_underline
    underline_end       out =  stop_underline

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out =  start_inverse
    error_end           out =  stop_inverse
    input_text_begin    out =  start_underline
    input_text_end      out =  stop_underline
    italic_begin        out =  start_inverse
    italic_end          out =  stop_inverse
    message_begin       out = ()
    message_end         out = ()
    output_text_begin   out = ()
    output_text_end     out = ()
    title_begin         out = ()
    title_end           out = ()

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = ( invoke_graphics )
    ld_fine_end              out = ( invoke_text )
    ld_fine_horizontal       out = ( 71(16) )
    ld_fine_vertical         out = ( 78(16) )
    ld_fine_upper_left       out = ( 6C(16) )
    ld_fine_upper_right      out = ( 6B(16) )
    ld_fine_lower_left       out = ( 6D(16) )
    ld_fine_lower_right      out = ( 6A(16) )
    ld_fine_up_t             out = ( 77(16) )
    ld_fine_down_t           out = ( 76(16) )
    ld_fine_left_t           out = ( 74(16) )
    ld_fine_right_t          out = ( 75(16) )
    ld_fine_cross            out = ( 6E(16) )
    ld_medium_begin          out = ( invoke_graphics )
    ld_medium_end            out = ( invoke_text )
    ld_medium_horizontal     out = ( 71(16) )
    ld_medium_vertical       out = ( 78(16) )
    ld_medium_upper_left     out = ( 6C(16) )
    ld_medium_upper_right    out = ( 6B(16) )
    ld_medium_lower_left     out = ( 6D(16) )
    ld_medium_lower_right    out = ( 6A(16) )
    ld_medium_up_t           out = ( 77(16) )
    ld_medium_down_t         out = ( 76(16) )
    ld_medium_left_t         out = ( 74(16) )
    ld_medium_right_t        out = ( 75(16) )
    ld_medium_cross          out = ( 6E(16) )
    ld_bold_begin            out = ( start_inverse )
    ld_bold_end              out = ( stop_inverse )
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')


"   END OF TERMINAL DEFINITION FILE FOR CDC 722-30 TERMINAL                   "
*DECK DECK=CSM$CDC_721 EXPAND=TRUE


"   TERMINAL DEFINITION FILE FOR CDC VIKING 721 TERMINAL                      "

" Automatic tabbing is available as a user or site option.  To enable it,     "
" change the automatic_tabbing firective from FALSE to TRUE, and look at the  "
" set_screen_mode and set_line_mode directives for comment-disabled references"
" to the variables enable_autotab and disable_autotab -- enable these         "
" references by blanking over the comment quotes.                             "

"   VARIABLES                                                                 "
clear_all_tabs      = (rs dc2 'Y')
disable_autotab     = (rs '#')
disable_blink       = (eot)
disable_auto_cr     = (rs '''')
disable_protect     = (rs dc2 'L')
disable_touchpanel  = (rs dc2 'Q')
disable_old_attr    = (rs '-')
enable_auto_cr      = (rs '&')
enable_autotab      = (rs '"')
enable_clear        = (rs '$')
enable_cr_delim     = (rs enq)
enable_blink        = (etx)
enable_protect      = (rs dc2 'K')
enable_typeamatic   = (rs dc2 'i')
enable_touchpanel   = (rs dc2 'R')
end_print           = (rs 7f(16))
large_cyber_mode    = (rs dc2 'B')
page_mode           = (syn)
pop_fn_keys         = (rs dc2 71(16) cr)
push_fn_keys        = (rs dc2 70(16) cr)
scroll_mode         = (dc2)
shift_numeric_pad   = (rs dc2 6B(16))
start_inverse       = (rs 'D')
start_underline     = (ack)
stop_inverse        = (rs 'E')
stop_underline      = (nak)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'CDC_721'
communications      type  = asynch
application_string  name='insert_delete_scrolling' out='true'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (32)   type = cdc721_cursor
cursor_pos_column_first  value = TRUE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         in    = (1e(16) 4d(16) 1f(16))  label = 'TOUCH'
cursor_pos_begin         out   = (stx)
cursor_pos_second        out   = (7E(16) soh)

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (em)     label='HOME'
cursor_up                inout = (etb)
cursor_down              inout = (sub)
cursor_left              inout = (bs)
cursor_right             inout = (can)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = wrap_adjacent_next
move_past_left           type  = wrap_adjacent_next
move_past_top            type  = wrap_same_next
move_past_bottom         type  = wrap_same_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = wrap_adjacent_next
char_past_left           type  = wrap_adjacent_next
char_past_last_position  type  = wrap_adjacent_next

"   TERMINAL ATTRIBUTES                                                       "
automatic_tabbing        value = FALSE
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 0
has_hidden               value = TRUE
has_protect              value = TRUE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = TRUE

"   SCREEN SIZES                                                              "
set_size       rows = 30 columns = 80   out = (rs dc2 'H' rs dc2 '^')  ..
 character_specification = (11,70,4) line_specification = (1,29,2) ..
 device = 'TOUCH_PANEL'
set_size rows = 30 columns = 132  out = (rs dc2 'G' rs dc2 '^') ..
 character_positions = (20,26,33,39,45,51,57,64,70,76,82,88, ..
 95,101,107,113) line_specification = (1,29,2) device = 'TOUCH_PANEL'

"   SCREEN AND LINE MODE TRANSITION                                           "
set_screen_mode     out = (push_fn_keys  shift_numeric_pad  enable_clear...
 large_cyber_mode  disable_auto_cr  enable_cr_delim  clear_all_tabs ...
 enable_blink  end_print  page_mode  disable_old_attr ..
 "enable_touchpanel" "enable_autotab" )

set_line_mode       out = (scroll_mode  enable_auto_cr  clear_all_tabs  ...
 "disable_touchpanel" pop_fn_keys "disable_autotab" )

"   TERMINAL CAPABILITIES                                                     "
delete_char         inout = (rs 4e(16))       label='DLETE_C'
delete_line_stay    inout = (rs 51(16))       label='DLETE_L'
erase_char          inout = (1f(16))
erase_end_of_line   inout = (vt)              label='CLR_EOL'
erase_field_stay    inout = (rs 59(16))
erase_field_bof     inout = (rs 5D(16))
erase_page_home     inout = (ff)              label='CLEAR_P'
insert_char         inout = (rs 4f(16))       label='INSRT_C'
insert_line_stay    inout = (rs 52(16))       label='INSRT_L'
tab_backward        inout = (rs 0b(16))
tab_clear           inout = (rs dc2 'X')
tab_clear_all       inout = (clear_all_tabs)
tab_forward         inout = (ht)
tab_set             inout = (rs dc2 'W')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
output_begin        out = (disable_protect)
output_end          out = (enable_protect)
protect_all         out = (rs 'G')

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (rs 71(16)) label= 'f1'
f2        in = (rs 72(16)) label= 'f2'
f3        in = (rs 73(16)) label= 'f3'
f4        in = (rs 74(16)) label= 'f4'
f5        in = (rs 75(16)) label= 'f5'
f6        in = (rs 76(16)) label= 'f6'
f7        in = (rs 77(16)) label= 'f7'
f8        in = (rs 78(16)) label= 'f8'
f9        in = (rs 79(16)) label= 'f9'
f10       in = (rs 7A(16)) label= '10'
f11       in = (rs 7B(16)) label= '11'
f12       in = (rs 7C(16)) label= '12'
f13       in = (rs 7D(16)) label= '13'
f14       in = (rs 7E(16)) label= '14'
f15       in = (rs 70(16)) label= '15'
f16       in = (rs dc2 31(16)) label= '16'
f1_s      in = (rs 61(16))     label= '  SF1'
f2_s      in = (rs 62(16))     label= '  SF2'
f3_s      in = (rs 63(16))     label= '  SF3'
f4_s      in = (rs 64(16))     label= '  SF4'
f5_s      in = (rs 65(16))     label= '  SF5'
f6_s      in = (rs 66(16))     label= '  SF6'
f7_s      in = (rs 67(16))     label= '  SF7'
f8_s      in = (rs 68(16))     label= '  SF8'
f9_s      in = (rs 69(16))     label= '  SF9'
f10_s     in = (rs 6A(16))     label= '  SF10'
f11_s     in = (rs 6B(16))     label= '  SF11'
f12_s     in = (rs 6C(16))     label= '  SF12'
f13_s     in = (rs 6D(16))     label= '  SF13'
f14_s     in = (rs 6E(16))     label= '  SF14'
f15_s     in = (rs 60(16))     label= '  SF15'
f16_s     in = (rs dc2 32(16)) label= '  SF16'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13  label='NEXT'
undo      in = (rs 75(16))     label= 'f5'
undo_s    in = (rs 65(16))     label= '  SF5'
back      in = (rs 5F(16))     label= 'BACK'
back_s    in = (rs 5B(16))     label= 'Shift-BACK'
help      in = (rs 5C(16))     label= 'HELP'
help_s    in = (rs 58(16))     label= 'Shift-HELP'
stop      in = (rs 49(16))     label= 'STOP'
stop_s    in = (rs 4A(16))     label= 'Shift-STOP'
down      in = (rs dc2 20(16)) label= 'DOWN'
down_s    in = (rs dc2 21(16)) label= 'Shift-DOWN'
up        in = (rs dc2 24(16)) label= 'UP'
up_s      in = (rs dc2 25(16)) label= 'Shift-UP'
fwd       in = (rs dc2 28(16)) label= 'FWD'
fwd_s     in = (rs dc2 29(16)) label= 'Shift-FWD'
bkw       in = (rs dc2 2C(16)) label= 'BKW'
bkw_s     in = (rs dc2 2d(16)) label= 'Shift-BKW'
edit      in = (rs 5E(16))     label= 'EDIT'
edit_s    in = (rs 5A(16))     label= 'Shift-EDIT'
data      in = (rs dc2 35(16)) label= 'DATA'
data_s    in = (rs dc2 36(16)) label= 'Shift-DATA'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (fs)
alt_end             out = (gs)
blink_begin         out = (so etx)
blink_end           out = (si)
hidden_begin        out = (rs dc2 '[')
hidden_end          out = (rs dc2 5C(16))
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
protect_begin       out = (rs dc2 'I')
protect_end         out = (rs dc2 'J')
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)
low_intensity_begin  out = (fs)
low_intensity_end    out = (gs)
high_intensity_begin out = (gs)
high_intensity_end   out = (fs)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)
message_begin       out = ()
message_end         out = ()
output_text_begin   out = ()
output_text_end     out = ()
title_begin         out = ()
title_end           out = ()

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = (rs fs)
ld_fine_end              out = (rs gs)
ld_fine_horizontal       out = 20(16)
ld_fine_vertical         out = 21(16)
ld_fine_upper_left       out = 22(16)
ld_fine_upper_right      out = 23(16)
ld_fine_lower_left       out = 24(16)
ld_fine_lower_right      out = 25(16)
ld_fine_up_t             out = 26(16)
ld_fine_down_t           out = 27(16)
ld_fine_left_t           out = 28(16)
ld_fine_right_t          out = 29(16)
ld_fine_cross            out = 2A(16)
ld_medium_begin          out = (rs fs)
ld_medium_end            out = (rs gs)
ld_medium_horizontal     out = 2B(16)
ld_medium_vertical       out = 2C(16)
ld_medium_upper_left     out = 2D(16)
ld_medium_upper_right    out = 2E(16)
ld_medium_lower_left     out = 2F(16)
ld_medium_lower_right    out = 30(16)
ld_medium_up_t           out = 31(16)
ld_medium_down_t         out = 32(16)
ld_medium_left_t         out = 33(16)
ld_medium_right_t        out = 34(16)
ld_medium_cross          out = 35(16)
ld_bold_begin            out = start_inverse
ld_bold_end              out = stop_inverse
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')


"   END OF TERMINAL DEFINITION FILE FOR CDC VIKING 721 TERMINAL               "
*DECK DECK=CSM$CDC_722 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR CDC VIKING 722 TERMINAL                      "

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'CDC_722'
communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (32)   type = binary_cursor
cursor_pos_column_first  value = TRUE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (esc 31(16))

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (em)      label='HOME'
cursor_up                inout = (sub)
cursor_down              inout = (lf)
cursor_left              inout = (bs)
cursor_right             inout = (nak)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = wrap_adjacent_next
move_past_left           type  = wrap_adjacent_next
move_past_top            type  = wrap_same_next
move_past_bottom         type  = scroll_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = wrap_adjacent_next
char_past_left           type  = wrap_adjacent_next
char_past_last_position  type  = scroll_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = FALSE
function_key_leaves_mark value = 0
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = FALSE
multiple_sizes           value = FALSE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = FALSE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80

"   TERMINAL CAPABILITIES                                                     "
erase_end_of_line   inout = (syn)    label='CLR_EOL'
erase_page_home     inout = (can)    label='CLEAR_P'
tab_forward         inout = (ht)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
output_begin        out = ()
output_end          out = ()
bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (rs 'q')      label = 'f1'
f2        in = (rs 'r')      label = 'f2'
f3        in = (rs 's')      label = 'f3'
f4        in = (rs 't')      label = 'f4'
f5        in = (rs 'u')      label = 'f5'
f6        in = (rs 'v')      label = 'f6'
f7        in = (rs 'w')      label = 'f7'
f8        in = (rs 'x')      label = 'f8'
f9        in = (rs 'y')      label = 'f9'
f10       in = (rs 'z')      label = '10'
f11       in = (rs '{')      label = '11'
f12       in = ()
f13       in = ()
f14       in = ()
f15       in = ()
f16       in = ()

f1_s      in = (rs 'a')      label = '  SF1'
f2_s      in = (rs 'b')      label = '  SF2'
f3_s      in = (rs 'c')      label = '  SF3'
f4_s      in = (rs 'd')      label = '  SF4'
f5_s      in = (rs 'e')      label = '  SF5'
f6_s      in = (rs 'f')      label = '  SF6'
f7_s      in = (rs 'g')      label = '  SF7'
f8_s      in = (rs 'h')      label = '  SF8'
f9_s      in = (rs 'i')      label = '  SF9'
f10_s     in = (rs 'j')      label = '  SF10'
f11_s     in = (rs 'k')      label = '  SF11'
f12_s     in = ()
f13_s     in = ()
f14_s     in = ()
f15_s     in = ()
f16_s     in = ()

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'NEWLINE'
next_s    in = ()
bkw       in = (rs 'q')      label = 'f1'
fwd       in = (rs 'r')      label = 'f2'
back      in = (rs 's')      label = 'f3'
help      in = (rs 't')      label = 'f4'
undo      in = (rs 'u')      label = 'f5'
stop      in = (rs 'v')      label = 'f6'
bkw_s     in = (rs 'a')      label = '  SF1'
fwd_s     in = (rs 'b')      label = '  SF2'
undo_s    in = (rs 'e')      label = '  SF5'
stop_s    in = (rs 'f')      label = '  SF6'
back_s    in = ()
help_s    in = ()
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_horizontal       out = ('-')
ld_fine_vertical         out = ('|')
ld_fine_upper_left       out = ('*')
ld_fine_upper_right      out = ('*')
ld_fine_lower_left       out = ('*')
ld_fine_lower_right      out = ('*')
ld_fine_up_t             out = ('*')
ld_fine_down_t           out = ('*')
ld_fine_left_t           out = ('*')
ld_fine_right_t          out = ('*')
ld_fine_cross            out = ('*')
ld_medium_horizontal     out = ('-')
ld_medium_vertical       out = ('|')
ld_medium_upper_left     out = ('*')
ld_medium_upper_right    out = ('*')
ld_medium_lower_left     out = ('*')
ld_medium_lower_right    out = ('*')
ld_medium_up_t           out = ('*')
ld_medium_down_t         out = ('*')
ld_medium_left_t         out = ('*')
ld_medium_right_t        out = ('*')
ld_medium_cross          out = ('*')
ld_bold_horizontal       out = ('-')
ld_bold_vertical         out = ('|')
ld_bold_upper_left       out = ('*')
ld_bold_upper_right      out = ('*')
ld_bold_lower_left       out = ('*')
ld_bold_lower_right      out = ('*')
ld_bold_up_t             out = ('*')
ld_bold_down_t           out = ('*')
ld_bold_left_t           out = ('*')
ld_bold_right_t          out = ('*')
ld_bold_cross            out = ('*')


"   END OF TERMINAL DEFINITION FILE FOR CDC 722 TERMINAL                      "
*DECK DECK=CSM$CDC_722_30 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR CDC 722-30 TERMINAL                          "

"   Note that this terminal definition is supplied with protection and auto-  "
"   tabbing enabled with protected areas dim and unprotected areas bright.    "
"   This arrangement is best for applications that use most of their screen   "
"   area for unprotected (input) fields, such as the Full Screen Editor.      "
"   If you primarily use this terminal with applications that protect most of "
"   the screen area, such as Edit_Catalog, you may prefer to reverse the dim  "
"   and bright assignments.  If you frequently switch between applications    "
"   that are mostly protected versus mostly unprotected, you may prefer to    "
"   use the terminal with all areas bright and no protection.                 "

"   To modify this definition to drop protection and have all areas bright,   "
"   look for statements that have the comments FOR EITHER BRIGHT OR DIM       "
"   PROTECTION and remove or disable (via comments) such statements.  Then    "
"   look for comment-disabled statements that have the comments FOR NO        "
"   PROTECTION and enable these statements by blanking the comments away.     "

"   You also have the option to modify this definition to keep protection and "
"   auto-tabbing, but with the bright/dim exchanged so that protected areas   "
"   are bright and unprotected areas are dim.  To do so, look for statements  "
"   commented as FOR PROTECT=DIM and FOR PROTECT=BRIGHT, and enable/disable   "
"   such statements by reversing th comment quotes.                           "

"   VARIABLES                                                                 "
    prefix              = ( 1B(16) 5B(16))
    clear_stay          = ( prefix 32(16) 4A(16) )
    clear_eop           = ( prefix 4A(16) )
    clear_all_tabs      = ( prefix 33(16) 67(16) )
    home_cursor         = ( prefix 48(16) )
    enable_insertion    = ( prefix 34(16) 68(16) )
    disable_insertion   = ( prefix 34(16) 6C(16) )

    enable_protect      = ( prefix 31(16) 7D(16) )  "for protect=dim"
  " enable_protect      = ( prefix '254'  7D(16) )   for protect=bright"

    disable_protect     = ( prefix 30(16) 7D(16) )
    start_alternate     = ( prefix 31(16) 6D(16) )
    stop_alternate      = ( prefix 6D(16) )
    start_blink         = ( prefix 35(16) 6D(16) )
    stop_blink          = ( prefix 6D(16) )
    erase_all_off       = ( prefix 36(16) 6C(16) )
    erase_all_on        = ( prefix 36(16) 68(16) )
    normal              = ( prefix 6D(16) )
    start_hidden        = ( prefix 36(16) 6D(16) )
    stop_hidden         = ( prefix 6D(16) )
    start_inverse       = ( prefix 37(16) 6D(16) )
    stop_inverse        = ( prefix 6D(16) )
    start_underline     = ( prefix 34(16) 6D(16) )
    stop_underline      = ( prefix 6D(16) )
    enable_buffer       = ( prefix '>h' )
    disable_buffer      = ( prefix '>l' )
    clear_buffer        = ( prefix '1~' )
    release_buffer      = ( prefix '0~' )
    stop_scroll         = ( prefix '?7l' )
    start_scroll        = ( prefix '?7h' )
    start_wrap          = ( prefix 3F(16) 37(16) 68(16))
    stop_wrap           = ( prefix 3F(16) 37(16) 6C(16))

    start_protect       = ( start_alternate )   " for protect=dim "
    stop_protect        = ( stop_alternate )    " for protect=dim "
  " start_protect       = ( stop_alternate )      for protect=bright "
  " stop_protect        = ( start_alternate )     for protect=bright "

    n_pad_shift         = ( 1b(16) '[=1h' 1e(16) 12(16) 'k' 1e(16) 12(16)..
                            'S2' 1b(16) '[2J')
    n_pad_normal        = ( 1b(16) '[=1h' 1e(16) 12(16) 'l' 1e(16) 12(16)..
                            'S2' 1b(16) '[2J')
    designate_text      = ( 1B(16) 28(16) 42(16))
    designate_graphics  = ( 1B(16) 29(16) 30(16))
    invoke_text         = ( 0F(16))
    invoke_graphics     = ( 0E(16))

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'CDC_722_30'
    communications      type  = asynch
    application_string  name  = 'VT100_SCROLLING'  out = 'TRUE'

"   BACKSPACE SPECIFIED                                                       "
    backspace           in =  ( 08(16) )

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   =  prefix
    cursor_pos_second        out   = ( 3B(16) )
    cursor_pos_third         out   = ( 48(16) )

"   CURSOR MOVEMENT INFORMATION
    cursor_home              inout = ( home_cursor )   label='HOME'
    cursor_up                inout = ( prefix 41(16) )
    cursor_down              inout = ( prefix 42(16) )
    cursor_left              inout = ( prefix 44(16) )
    cursor_right             inout = ( prefix 43(16) )

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = stop_next
    move_past_left           type  = stop_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = stop_next
    char_past_left           type  = stop_next
    char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "

    automatic_tabbing        value = TRUE  " for either bright or dim protect "
  " automatic_tabbing        value = FALSE   for no protection "

    clears_when_change_size  value = FALSE
    function_key_leaves_mark value = 0
    has_hidden               value = TRUE

    has_protect              value = TRUE  " for either bright or dim protect "
  " has_protect              value = FALSE   for no protection "

    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE

    tabs_to_unprotected      value = TRUE  " for either bright or dim protect "
  " tabs_to_unprotected      value = FALSE   for no protection "

    type_ahead               value = TRUE

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode     out = ( enable_buffer  clear_all_tabs ..
        designate_text  designate_graphics  invoke_text ..
        stop_scroll  stop_wrap   n_pad_shift)

    set_line_mode       out = ( clear_all_tabs  designate_text ..
        designate_graphics  invoke_text  disable_buffer  start_scroll ..
        n_pad_normal  start_wrap    home_cursor)

"   TERMINAL CAPABILITIES                                                     "
    delete_char         inout = ( prefix 50(16) )     label='C_DLETE'
    delete_line_stay    inout = ( prefix 4D(16) )     label='L_DLETE'
    erase_end_of_line   inout = ( prefix 4B(16) )     label='CLR_EOL'
    erase_end_of_page   inout = ( clear_eop )
    erase_line_stay     inout = ( prefix 32(16) 4B(16) )
    erase_page_stay     inout = ( clear_stay )        label='CLEAR_P'
    insert_line_stay    inout = ( prefix 4C(16) )     label='L_INSRT'
    insert_mode_begin   inout = ( enable_insertion )  label='BGN_INS'
    insert_mode_end     inout = ( disable_insertion )
" protect_all out=(start_protect clear_stay stop_protect) for protect=bright "
    tab_backward        inout = ( prefix 46(16) )
    tab_forward         inout = ( 09(16) )
    tab_clear_all       inout = ( clear_all_tabs )
    tab_set             inout = ( 1B(16) 48(16) )

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "

    output_begin        out = ( disable_protect erase_all_on normal) " for either bright or dim protect "
    output_end          out = ( enable_protect erase_all_off release_buffer ) " for either bright or dim protect "
  " output_begin        out = ( erase_all_on normal) for no protection "
  " output_end          out=(erase_all_off release_buffer)  for no protection "

    bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = ( 1B(16) 4F(16) 50(16) )    label='f1'
    f2        in = ( 1B(16) 4F(16) 51(16) )    label='f2'
    f3        in = ( 1B(16) 4F(16) 52(16) )    label='f3'
    f4        in = ( 1B(16) 4F(16) 53(16) )    label='f4'
    f5        in = ( 1B(16) 4F(16) 6D(16) )    label='f5'
    f6        in = ( 1B(16) 4F(16) 6C(16) )    label='f6'
    f7        in = ( 1B(16) 4F(16) 4D(16) )    label='f7'
    f8        in = ( 1B(16) 4F(16) 6E(16) )    label='f8'
    f9        in = ( 1B(16) 4F(16) 41(16) )    label='f9'
    f10       in = ( 1B(16) 4F(16) 42(16) )    label='10'
    f11       in = ( 1B(16) 4F(16) 43(16) )    label='11'
    f12       in = ( 1B(16) 4F(16) 44(16) )    label='12'
    f13       in = ( )
    f14       in = ( )
    f15       in = ( )
    f16       in = ( )
    f1_s      in = ( 1B(16) 4F(16) 71(16) )    label='  SF1'
    f2_s      in = ( 1B(16) 4F(16) 72(16) )    label='  SF2'
    f3_s      in = ( 1B(16) 4F(16) 73(16) )    label='  SF3'
    f4_s      in = ( 1B(16) 4F(16) 74(16) )    label='  SF4'
    f5_s      in = ( 1B(16) 4F(16) 75(16) )    label='  SF5'
    f6_s      in = ( 1B(16) 4F(16) 76(16) )    label='  SF6'
    f7_s      in = ( 1B(16) 4F(16) 77(16) )    label='  SF7'
    f8_s      in = ( 1B(16) 4F(16) 78(16) )    label='  SF8'
    f9_s      in = ( 1B(16) 4F(16) 79(16) )    label='  SF9'
    f10_s     in = ( 1B(16) 4F(16) 70(16) )    label='  SF10'
    f11_s     in = ( 1B(16) 4F(16) 7A(16) )    label='  SF11'
    f12_s     in = ( 1B(16) 4F(16) 7B(16) )    label='  SF12'
    f13_s     in = ( )
    f14_s     in = ( )
    f15_s     in = ( )
    f16_s     in = ( )

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in=13                            label='RETURN'
    next_s    in=()
    bkw       in = ( 1B(16) 4F(16) 50(16) )    label='f1'
    fwd       in = ( 1B(16) 4F(16) 51(16) )    label='f2'
    back      in = ( 1B(16) 4F(16) 52(16) )    label='f3'
    help      in = ( 1B(16) 4F(16) 53(16) )    label='f4'
    undo      in = ( 1B(16) 4F(16) 6D(16) )    label='f5'
    stop      in = ( 1B(16) 4F(16) 6C(16) )    label='f6'
    bkw_s     in = ( 1B(16) 4F(16) 71(16) )    label='  SF1'
    fwd_s     in = ( 1B(16) 4F(16) 72(16) )    label='  SF2'
    undo_s    in = ( 1B(16) 4F(16) 75(16) )    label='  SF5'
    stop_s    in = ( 1B(16) 4F(16) 76(16) )    label='  SF6'
    edit      in = ( esc '[?10l' )
    edit_s    in = ( )
    data      in = ( )
    data_s    in = ( )

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out =  start_alternate
    alt_end             out =  stop_alternate
    blink_begin         out =  start_blink
    blink_end           out =  stop_blink
    hidden_begin        out =  start_hidden
    hidden_end          out =  stop_hidden
    inverse_begin       out =  start_inverse
    inverse_end         out =  stop_inverse

    protect_begin       out =  start_protect  " for either bright or dim protect "
    protect_end         out =  stop_protect   " for either bright or dim protect "
  " protect_begin       out =  ()             for no protection "
  " protect_end         out =  ()             for no protection "

    underline_begin     out =  start_underline
    underline_end       out =  stop_underline

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out =  start_inverse
    error_end           out =  stop_inverse
    input_text_begin    out =  start_underline
    input_text_end      out =  stop_underline
    italic_begin        out =  start_inverse
    italic_end          out =  stop_inverse
    message_begin       out = ()
    message_end         out = ()
    output_text_begin   out = ()
    output_text_end     out = ()
    title_begin         out = ()
    title_end           out = ()

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = ( invoke_graphics )
    ld_fine_end              out = ( invoke_text )
    ld_fine_horizontal       out = ( 71(16) )
    ld_fine_vertical         out = ( 78(16) )
    ld_fine_upper_left       out = ( 6C(16) )
    ld_fine_upper_right      out = ( 6B(16) )
    ld_fine_lower_left       out = ( 6D(16) )
    ld_fine_lower_right      out = ( 6A(16) )
    ld_fine_up_t             out = ( 77(16) )
    ld_fine_down_t           out = ( 76(16) )
    ld_fine_left_t           out = ( 74(16) )
    ld_fine_right_t          out = ( 75(16) )
    ld_fine_cross            out = ( 6E(16) )
    ld_medium_begin          out = ( invoke_graphics )
    ld_medium_end            out = ( invoke_text )
    ld_medium_horizontal     out = ( 71(16) )
    ld_medium_vertical       out = ( 78(16) )
    ld_medium_upper_left     out = ( 6C(16) )
    ld_medium_upper_right    out = ( 6B(16) )
    ld_medium_lower_left     out = ( 6D(16) )
    ld_medium_lower_right    out = ( 6A(16) )
    ld_medium_up_t           out = ( 77(16) )
    ld_medium_down_t         out = ( 76(16) )
    ld_medium_left_t         out = ( 74(16) )
    ld_medium_right_t        out = ( 75(16) )
    ld_medium_cross          out = ( 6E(16) )
    ld_bold_begin            out = ( start_inverse )
    ld_bold_end              out = ( stop_inverse )
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')


"   END OF TERMINAL DEFINITION FILE FOR CDC 722-30 TERMINAL                   "
*DECK DECK=CSM$CDC_910 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR CDC 910 WORKSTATION                          "

" Note: the protocol is essentially equivalent to DEC VT-52   "

"   VARIABLES                                                                 "

alternate_keypad = (esc '=')
normal_keypad    = (esc '>')
alternate_color  = (esc '9P')  " extension beyond VT52 "
normal_color     = (esc '0@')  " extension beyond VT52 "

keypad_0            = (esc '?p')
keypad_1            = (esc '?q')
keypad_2            = (esc '?r')
keypad_3            = (esc '?s')
keypad_4            = (esc '?t')
keypad_5            = (esc '?u')
keypad_6            = (esc '?v')
keypad_7            = (esc '?w')
keypad_8            = (esc '?x')
keypad_9            = (esc '?y')
keypad_minus        = (esc '?m')
keypad_comma        = (esc '?l')
keypad_period       = (esc '?n')
keypad_enter        = (esc '?M')
keypad_pf1          = (esc 'P')
keypad_pf2          = (esc 'Q')
keypad_pf3          = (esc 'R')
keypad_pf4          = (esc 'S')

gold                = keypad_0

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'CDC_910'
communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (32)   type = binary_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (esc 'Y')
cursor_pos_second        out   = ()
cursor_pos_third         out   = ()

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (esc 48(16))
cursor_up                inout = (esc 41(16))
cursor_down              inout = (esc 42(16))
cursor_left              inout = (esc 44(16))
cursor_right             inout = (esc 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = wrap_adjacent_next
char_past_left           type  = stop_next
char_past_last_position  type  = scroll_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 2
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = FALSE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 40 columns = 80   " VT52 has only 24 rows "

set_screen_mode out=(alternate_keypad)

set_line_mode out=(normal_keypad)

"   TERMINAL CAPABILITIES                                                     "
delete_char         in    = (esc 'N')
delete_line_bol     in    = (esc 'M')
erase_end_of_line   inout = (esc 'K')
erase_line_stay     inout = (esc 'I')
erase_page_home     inout = (esc 'v')
insert_line_bol     in    = (esc 'L')
insert_mode_begin   in    = (esc '@')
insert_mode_end     in    = (esc 'O')
tab_forward         inout = (09(16))
tab_clear_all       inout = ()
tab_set             inout = ()

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
backspace           in = bs

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (keypad_1)          label='k1'
f2        in = (keypad_2)          label='k2'
f3        in = (keypad_3)          label='k3'
f4        in = (keypad_4)          label='k4'
f5        in = (keypad_5)          label='k5'
f6        in = (keypad_6)          label='k6'
f7        in = (keypad_7)          label='k7'
f8        in = (keypad_8)          label='k8'
f9        in = (keypad_9)          label='k9'
f10       in = (keypad_pf1)        label='p1'
f11       in = (keypad_pf2)        label='p2'
f12       in = (keypad_pf3)        label='p3'
f13       in = (keypad_pf4)        label='p4'
f14       in = (keypad_minus)      label='k-'
f15       in = (keypad_comma)      label='k,'
f16       in = (keypad_enter)      label='ke'
f1_s      in = (gold keypad_1)     label='01'
f2_s      in = (gold keypad_2)     label='02'
f3_s      in = (gold keypad_3)     label='03'
f4_s      in = (gold keypad_4)     label='04'
f5_s      in = (gold keypad_5)     label='05'
f6_s      in = (gold keypad_6)     label='06'
f7_s      in = (gold keypad_7)     label='07'
f8_s      in = (gold keypad_8)     label='08'
f9_s      in = (gold keypad_9)     label='09'
f10_s     in = (gold keypad_pf1)   label='p1'
f11_s     in = (gold keypad_pf2)   label='p2'
f12_s     in = (gold keypad_pf3)   label='p3'
f13_s     in = (gold keypad_pf4)   label='p4'
f14_s     in = (gold keypad_minus) label='0-'
f15_s     in = (gold keypad_comma) label='0,'
f16_s     in = (gold keypad_enter) label='0e'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = (keypad_1)      label='k1'
fwd       in = (keypad_2)      label='k2'
back      in = (keypad_3)      label='k3'
help      in = (keypad_4)      label='k4'
undo      in = (keypad_5)      label='k5'
stop      in = (keypad_6)      label='k6'
bkw_s     in = (gold keypad_1) label='  01'
fwd_s     in = (gold keypad_2) label='  02'
undo_s    in = (gold keypad_5) label='  05'
stop_s    in = (gold keypad_6) label='  06'
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = ()
alt_end             out = ()
blink_begin         out = ()
blink_end           out = ()
inverse_begin       out = (alternate_color)
inverse_end         out = (normal_color)
underline_begin     out = (alternate_color)
underline_end       out = (normal_color)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = ()
error_end           out = ()
input_text_begin    out = ()
input_text_end      out = ()
italic_begin        out = (alternate_color)
italic_end          out = (normal_color)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = ()
ld_fine_end              out = ()
ld_fine_horizontal       out = '-'
ld_fine_vertical         out = '!'
ld_fine_upper_left       out = '*'
ld_fine_upper_right      out = '*'
ld_fine_lower_left       out = '*'
ld_fine_lower_right      out = '*'
ld_fine_up_t             out = '*'
ld_fine_down_t           out = '*'
ld_fine_left_t           out = '*'
ld_fine_right_t          out = '*'
ld_fine_cross            out = '*'
ld_medium_begin            out = ()
ld_medium_end              out = ()
ld_medium_horizontal       out = '-'
ld_medium_vertical         out = '!'
ld_medium_upper_left       out = '*'
ld_medium_upper_right      out = '*'
ld_medium_lower_left       out = '*'
ld_medium_lower_right      out = '*'
ld_medium_up_t             out = '*'
ld_medium_down_t           out = '*'
ld_medium_left_t           out = '*'
ld_medium_right_t          out = '*'
ld_medium_cross            out = '*'
ld_bold_begin            out = ()
ld_bold_end              out = ()
ld_bold_horizontal       out = '-'
ld_bold_vertical         out = '!'
ld_bold_upper_left       out = '*'
ld_bold_upper_right      out = '*'
ld_bold_lower_left       out = '*'
ld_bold_lower_right      out = '*'
ld_bold_up_t             out = '*'
ld_bold_down_t           out = '*'
ld_bold_left_t           out = '*'
ld_bold_right_t          out = '*'
ld_bold_cross            out = '*'

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR CDC 910 WORKSTATION                  "
*DECK DECK=CSM$DEC_VT100 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR DIGITAL VT100 TERMINAL                       "

"   VARIABLES                                                                 "
prefix              = (1B(16) 5B(16))
clear_all_tabs      = (prefix '3g')
clear_home          = (prefix 32(16) 4A(16))
cursor_key_mode_cur = (prefix '?1l')
enter_ansi_mode     = (1B(16) 3C(16))
g0_us_characters    = (1B(16) 28(16) 42(16))
g1_graphics_chars   = (1B(16) 29(16) 30(16))
home                = (prefix 'H')
home_cursor         = (prefix 48(16))
keypad_applic_mode  = (1B(16) 3D(16))
keypad_numeric_mode = (1B(16) 3E(16))
normal_attributes   = (prefix 'm')
select_g0_char_set  = (0F(16))
set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))
set_to_24x132       = (prefix 3F(16) 33(16) 68(16))
start_alternate     = (prefix 31(16) 6D(16))
start_inverse       = (prefix '7' 6D(16))
start_underline     = (prefix 34(16) 6D(16))
stop_alternate      = normal_attributes
stop_inverse        = normal_attributes
stop_underline      = normal_attributes
wraparound_off      = (prefix '?7l')
wraparound_on       = (prefix '?7h')
redo_set_line_mode  = (enter_ansi_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     keypad_numeric_mode wraparound_on cursor_key_mode_cur)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'DEC_VT100'
communications      type  = asynch
application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (3B(16))
cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 48(16))
cursor_up                inout = (prefix 41(16))
cursor_down              inout = (prefix 42(16))
cursor_left              inout = (prefix 44(16))
cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 1
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80   out = (set_to_24x80)
set_size       rows = 24 columns = 132  out = (set_to_24x132)

"   SCREEN AND LINE MODE TRANSITION                                           "
set_screen_mode     out = (enter_ansi_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     keypad_applic_mode wraparound_off cursor_key_mode_cur)


set_line_mode     out = (enter_ansi_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     keypad_numeric_mode wraparound_on cursor_key_mode_cur ..
     normal_attributes clear_home home_cursor)

application_string name= 'REDO_SET_LINE_MODE' out=(redo_set_line_mode)


"   TERMINAL CAPABILITIES                                                     "
delete_char         in    = (prefix 50(16))
delete_line_bol     in    = (prefix 4D(16))
erase_end_of_line   inout = (prefix 4B(16))
erase_line_stay     inout = (prefix 32(16) 4B(16))
erase_page_home     inout = (clear_home home)
insert_line_bol     in    = (prefix 4C(16))
insert_mode_begin   in    = (prefix 34(16) 68(16))
insert_mode_end     in    = (prefix 34(16) 6C(16))
tab_forward         inout = (09(16))
tab_clear_all       inout = (clear_all_tabs)
tab_set             inout = (1B(16) 48(16))

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
backspace           in = bs

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (1B(16) 4F(16) 71(16)) label='k1'
f2        in = (1B(16) 4F(16) 72(16)) label='k2'
f3        in = (1B(16) 4F(16) 73(16)) label='k3'
f4        in = (1B(16) 4F(16) 74(16)) label='k4'
f5        in = (1B(16) 4F(16) 75(16)) label='k5'
f6        in = (1B(16) 4F(16) 76(16)) label='k6'
f7        in = (1B(16) 4F(16) 77(16)) label='k7'
f8        in = (1B(16) 4F(16) 78(16)) label='k8'
f9        in = (1B(16) 4F(16) 79(16)) label='k9'
f10       in = ()
f11       in = ()
f12       in = ()
f13       in = ()
f14       in = ()
f15       in = ()
f16       in = ()
f1_s      in = (1B(16) 4F(16) 50(16)) label='p1'
f2_s      in = (1B(16) 4F(16) 51(16)) label='p2'
f3_s      in = (1B(16) 4F(16) 52(16)) label='p3'
f4_s      in = (1B(16) 4F(16) 53(16)) label='p4'
f5_s      in = (1B(16) 4F(16) 6D(16)) label='k-'
f6_s      in = (1B(16) 4F(16) 6C(16)) label='k,'
f7_s      in = (1B(16) 4F(16) 4D(16)) label='ke'
f8_s      in = (1B(16) 4F(16) 6E(16)) label='k.'
f9_s      in = (1B(16) 4F(16) 70(16)) label='k0'
f10_s     in = ()
f11_s     in = ()
f12_s     in = ()
f13_s     in = ()
f14_s     in = ()
f15_s     in = ()
f16_s     in = ()

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = (1B(16) 4F(16) 71(16)) label='F1'
fwd       in = (1B(16) 4F(16) 72(16)) label='F2'
back      in = (1B(16) 4F(16) 73(16)) label='F3'
help      in = (1B(16) 4F(16) 74(16)) label='F4'
undo      in = (1B(16) 4F(16) 75(16)) label='F5'
stop      in = (1B(16) 4F(16) 76(16)) label='F6'
bkw_s     in = (1B(16) 4F(16) 50(16)) label='  Shift-F1'
fwd_s     in = (1B(16) 4F(16) 51(16)) label='  Shift-F2'
undo_s    in = (1B(16) 4F(16) 6D(16)) label='  Shift-F5'
stop_s    in = (1B(16) 4F(16) 6C(16)) label='  Shift-F6'
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_alternate)
alt_end             out = (stop_alternate)
blink_begin         out = (prefix 35(16) 6D(16))
blink_end           out = normal_attributes
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = 0E(16)
ld_fine_end              out = 0F(16)
ld_fine_horizontal       out = 71(16)
ld_fine_vertical         out = 78(16)
ld_fine_upper_left       out = 6C(16)
ld_fine_upper_right      out = 6B(16)
ld_fine_lower_left       out = 6D(16)
ld_fine_lower_right      out = 6A(16)
ld_fine_up_t             out = 77(16)
ld_fine_down_t           out = 76(16)
ld_fine_left_t           out = 74(16)
ld_fine_right_t          out = 75(16)
ld_fine_cross            out = 6E(16)
ld_medium_begin          out = (0E(16) start_alternate)
ld_medium_end            out = (0F(16) stop_alternate)
ld_medium_horizontal     out = 71(16)
ld_medium_vertical       out = 78(16)
ld_medium_upper_left     out = 6C(16)
ld_medium_upper_right    out = 6B(16)
ld_medium_lower_left     out = 6D(16)
ld_medium_lower_right    out = 6A(16)
ld_medium_up_t           out = 77(16)
ld_medium_down_t         out = 76(16)
ld_medium_left_t         out = 74(16)
ld_medium_right_t        out = 75(16)
ld_medium_cross          out = 6E(16)
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR DIGITAL VT100 TERMINAL               "
*DECK DECK=CSM$DEC_VT100_GOLD EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR DIGITAL VT100 TERMINAL                       "

"   VARIABLES                                                                 "
prefix              = (1B(16) 5B(16))
clear_all_tabs      = (prefix '3g')
clear_home          = (prefix 32(16) 4A(16))
cursor_key_mode_cur = (prefix '?1l')
enter_ansi_mode     = (1B(16) 3C(16))
g0_us_characters    = (1B(16) 28(16) 42(16))
g1_graphics_chars   = (1B(16) 29(16) 30(16))
home                = (prefix 'H')
home_cursor         = (prefix 48(16))
keypad_applic_mode  = (1B(16) 3D(16))
keypad_numeric_mode = (1B(16) 3E(16))
normal_attributes   = (prefix 'm')
select_g0_char_set  = (0F(16))
set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))
set_to_24x132       = (prefix 3F(16) 33(16) 68(16))
start_alternate     = (prefix 31(16) 6D(16))
start_inverse       = (prefix '7' 6D(16))
start_underline     = (prefix 34(16) 6D(16))
stop_alternate      = normal_attributes
stop_inverse        = normal_attributes
stop_underline      = normal_attributes
wraparound_off      = (prefix '?7l')
wraparound_on       = (prefix '?7h')
redo_set_line_mode  = (enter_ansi_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     keypad_numeric_mode wraparound_on cursor_key_mode_cur)

keypad_0            = (esc 'Op')
keypad_1            = (esc 'Oq')
keypad_2            = (esc 'Or')
keypad_3            = (esc 'Os')
keypad_4            = (esc 'Ot')
keypad_5            = (esc 'Ou')
keypad_6            = (esc 'Ov')
keypad_7            = (esc 'Ow')
keypad_8            = (esc 'Ox')
keypad_9            = (esc 'Oy')
keypad_minus        = (esc 'Om')
keypad_comma        = (esc 'Ol')
keypad_period       = (esc 'On')
keypad_enter        = (esc 'OM')
keypad_pf1          = (esc 'OP')
keypad_pf2          = (esc 'OQ')
keypad_pf3          = (esc 'OR')
keypad_pf4          = (esc 'OS')

gold                = keypad_0

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'DEC_VT100_GOLD'
communications      type  = asynch
application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (3B(16))
cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 48(16))
cursor_up                inout = (prefix 41(16))
cursor_down              inout = (prefix 42(16))
cursor_left              inout = (prefix 44(16))
cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 2
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80   out = (set_to_24x80)
set_size       rows = 24 columns = 132  out = (set_to_24x132)

"   SCREEN AND LINE MODE TRANSITION                                           "
set_screen_mode     out = (enter_ansi_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     keypad_applic_mode wraparound_off cursor_key_mode_cur)


set_line_mode     out = (enter_ansi_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     keypad_numeric_mode wraparound_on cursor_key_mode_cur ..
     normal_attributes clear_home home_cursor)

application_string name= 'REDO_SET_LINE_MODE' out=(redo_set_line_mode)

"   TERMINAL CAPABILITIES                                                     "
delete_char         in    = (prefix 50(16))
delete_line_bol     in    = (prefix 4D(16))
erase_end_of_line   inout = (prefix 4B(16))
erase_line_stay     inout = (prefix 32(16) 4B(16))
erase_page_home     inout = (clear_home home)
insert_line_bol     in    = (prefix 4C(16))
insert_mode_begin   in    = (prefix 34(16) 68(16))
insert_mode_end     in    = (prefix 34(16) 6C(16))
tab_forward         inout = (09(16))
tab_clear_all       inout = (clear_all_tabs)
tab_set             inout = (1B(16) 48(16))

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
backspace           in = bs

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (keypad_1)          label='k1'
f2        in = (keypad_2)          label='k2'
f3        in = (keypad_3)          label='k3'
f4        in = (keypad_4)          label='k4'
f5        in = (keypad_5)          label='k5'
f6        in = (keypad_6)          label='k6'
f7        in = (keypad_7)          label='k7'
f8        in = (keypad_8)          label='k8'
f9        in = (keypad_9)          label='k9'
f10       in = (keypad_pf1)        label='p1'
f11       in = (keypad_pf2)        label='p2'
f12       in = (keypad_pf3)        label='p3'
f13       in = (keypad_pf4)        label='p4'
f14       in = (keypad_minus)      label='k-'
f15       in = (keypad_comma)      label='k,'
f16       in = (keypad_enter)      label='ke'
f1_s      in = (gold keypad_1)     label='01'
f2_s      in = (gold keypad_2)     label='02'
f3_s      in = (gold keypad_3)     label='03'
f4_s      in = (gold keypad_4)     label='04'
f5_s      in = (gold keypad_5)     label='05'
f6_s      in = (gold keypad_6)     label='06'
f7_s      in = (gold keypad_7)     label='07'
f8_s      in = (gold keypad_8)     label='08'
f9_s      in = (gold keypad_9)     label='09'
f10_s     in = (gold keypad_pf1)   label='p1'
f11_s     in = (gold keypad_pf2)   label='p2'
f12_s     in = (gold keypad_pf3)   label='p3'
f13_s     in = (gold keypad_pf4)   label='p4'
f14_s     in = (gold keypad_minus) label='0-'
f15_s     in = (gold keypad_comma) label='0,'
f16_s     in = (gold keypad_enter) label='0e'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = (keypad_1)      label='k1'
fwd       in = (keypad_2)      label='k2'
back      in = (keypad_3)      label='k3'
help      in = (keypad_4)      label='k4'
undo      in = (keypad_5)      label='k5'
stop      in = (keypad_6)      label='k6'
bkw_s     in = (gold keypad_1) label='  01'
fwd_s     in = (gold keypad_2) label='  02'
undo_s    in = (gold keypad_5) label='  05'
stop_s    in = (gold keypad_6) label='  06'
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_alternate)
alt_end             out = (stop_alternate)
blink_begin         out = (prefix 35(16) 6D(16))
blink_end           out = normal_attributes
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = 0E(16)
ld_fine_end              out = 0F(16)
ld_fine_horizontal       out = 71(16)
ld_fine_vertical         out = 78(16)
ld_fine_upper_left       out = 6C(16)
ld_fine_upper_right      out = 6B(16)
ld_fine_lower_left       out = 6D(16)
ld_fine_lower_right      out = 6A(16)
ld_fine_up_t             out = 77(16)
ld_fine_down_t           out = 76(16)
ld_fine_left_t           out = 74(16)
ld_fine_right_t          out = 75(16)
ld_fine_cross            out = 6E(16)
ld_medium_begin          out = (0E(16) start_alternate)
ld_medium_end            out = (0F(16) stop_alternate)
ld_medium_horizontal     out = 71(16)
ld_medium_vertical       out = 78(16)
ld_medium_upper_left     out = 6C(16)
ld_medium_upper_right    out = 6B(16)
ld_medium_lower_left     out = 6D(16)
ld_medium_lower_right    out = 6A(16)
ld_medium_up_t           out = 77(16)
ld_medium_down_t         out = 76(16)
ld_medium_left_t         out = 74(16)
ld_medium_right_t        out = 75(16)
ld_medium_cross          out = 6E(16)
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR DIGITAL VT100 TERMINAL               "
*DECK DECK=CSM$DEC_VT100_HOST_ECHO EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR DIGITAL VT100 TERMINAL                        "

"   VARIABLES                                                                 "
prefix              = (1B(16) 5B(16))
clear_all_tabs      = (prefix '3g')
clear_home          = (prefix 32(16) 4A(16))
cursor_key_mode_cur = (prefix '?1l')
enter_ansi_mode     = (1B(16) 3C(16))
g0_us_characters    = (1B(16) 28(16) 42(16))
g1_graphics_chars   = (1B(16) 29(16) 30(16))
home                = (prefix 'H')
home_cursor         = (prefix 48(16))
keypad_applic_mode  = (1B(16) 3D(16))
keypad_numeric_mode = (1B(16) 3E(16))
normal_attributes   = (prefix 'm')
select_g0_char_set  = (0F(16))
set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))
set_to_24x132       = (prefix 3F(16) 33(16) 68(16))
start_alternate     = (prefix 31(16) 6D(16))
start_inverse       = (prefix '7' 6D(16))
start_underline     = (prefix 34(16) 6D(16))
stop_alternate      = normal_attributes
stop_inverse        = normal_attributes
stop_underline      = normal_attributes
wraparound_off      = (prefix '?7l')
wraparound_on       = (prefix '?7h')
redo_set_line_mode  = (enter_ansi_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     keypad_numeric_mode wraparound_on cursor_key_mode_cur)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'DEC_VT100_HOST_ECHO'
communications      type  = asynch
application_string  name='DRIVER_PROCEDURE' out= 'tup$host_echo_vt100_boot'
application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (3B(16))
cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 48(16))
cursor_up                inout = (prefix 41(16))
cursor_down              inout = (prefix 42(16))
cursor_left              inout = (prefix 44(16))
cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = wrap_adjacent_next
move_past_left           type  = wrap_adjacent_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = wrap_adjacent_next
char_past_left           type  = wrap_adjacent_next
char_past_last_position  type  = wrap_adjacent_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 1
has_hidden               value = TRUE
has_protect              value = TRUE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = TRUE
automatic_tabbing        value = TRUE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80   out = (set_to_24x80)
set_size       rows = 24 columns = 132  out = (set_to_24x132)

"   SCREEN AND LINE MODE TRANSITION                                           "
set_screen_mode     out = (enter_ansi_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     keypad_applic_mode wraparound_off cursor_key_mode_cur)


set_line_mode     out = (enter_ansi_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     keypad_numeric_mode wraparound_on cursor_key_mode_cur ..
     normal_attributes clear_home home_cursor)

application_string name= 'REDO_SET_LINE_MODE' out=(redo_set_line_mode)


"   TERMINAL CAPABILITIES                                                     "
delete_char         in    = (prefix 50(16))
delete_line_bol     in    = (prefix 4D(16))
erase_end_of_line   inout = (prefix 4B(16))
erase_line_stay     inout = (prefix 32(16) 4B(16))
erase_page_home     inout = (clear_home home)
insert_line_bol     in    = (prefix 4C(16))
insert_mode_begin   in    = (prefix 34(16) 68(16))
insert_mode_end     in    = (prefix 34(16) 6C(16))
tab_forward         inout = (09(16))
tab_clear_all       inout = (clear_all_tabs)
tab_set             inout = (1B(16) 48(16))

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
backspace           in = bs

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (1B(16) 4F(16) 71(16)) label='k1'
f2        in = (1B(16) 4F(16) 72(16)) label='k2'
f3        in = (1B(16) 4F(16) 73(16)) label='k3'
f4        in = (1B(16) 4F(16) 74(16)) label='k4'
f5        in = (1B(16) 4F(16) 75(16)) label='k5'
f6        in = (1B(16) 4F(16) 76(16)) label='k6'
f7        in = (1B(16) 4F(16) 77(16)) label='k7'
f8        in = (1B(16) 4F(16) 78(16)) label='k8'
f9        in = (1B(16) 4F(16) 79(16)) label='k9'
f10       in = ()
f11       in = ()
f12       in = ()
f13       in = ()
f14       in = ()
f15       in = ()
f16       in = ()
f1_s      in = (1B(16) 4F(16) 50(16)) label='p1'
f2_s      in = (1B(16) 4F(16) 51(16)) label='p2'
f3_s      in = (1B(16) 4F(16) 52(16)) label='p3'
f4_s      in = (1B(16) 4F(16) 53(16)) label='p4'
f5_s      in = (1B(16) 4F(16) 6D(16)) label='k-'
f6_s      in = (1B(16) 4F(16) 6C(16)) label='k,'
f7_s      in = (1B(16) 4F(16) 4D(16)) label='ke'
f8_s      in = (1B(16) 4F(16) 6E(16)) label='k.'
f9_s      in = (1B(16) 4F(16) 70(16)) label='k0'
f10_s     in = ()
f11_s     in = ()
f12_s     in = ()
f13_s     in = ()
f14_s     in = ()
f15_s     in = ()
f16_s     in = ()

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = (1B(16) 4F(16) 71(16)) label='F1'
fwd       in = (1B(16) 4F(16) 72(16)) label='F2'
back      in = (1B(16) 4F(16) 73(16)) label='F3'
help      in = (1B(16) 4F(16) 74(16)) label='F4'
undo      in = (1B(16) 4F(16) 75(16)) label='F5'
stop      in = (1B(16) 4F(16) 76(16)) label='F6'
bkw_s     in = (1B(16) 4F(16) 50(16)) label='  Shift-F1'
fwd_s     in = (1B(16) 4F(16) 51(16)) label='  Shift-F2'
undo_s    in = (1B(16) 4F(16) 6D(16)) label='  Shift-F5'
stop_s    in = (1B(16) 4F(16) 6C(16)) label='  Shift-F6'
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_alternate)
alt_end             out = (stop_alternate)
blink_begin         out = (prefix 35(16) 6D(16))
blink_end           out = normal_attributes
hidden_begin        out = ()
hidden_end          out = ()
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = 0E(16)
ld_fine_end              out = 0F(16)
ld_fine_horizontal       out = 71(16)
ld_fine_vertical         out = 78(16)
ld_fine_upper_left       out = 6C(16)
ld_fine_upper_right      out = 6B(16)
ld_fine_lower_left       out = 6D(16)
ld_fine_lower_right      out = 6A(16)
ld_fine_up_t             out = 77(16)
ld_fine_down_t           out = 76(16)
ld_fine_left_t           out = 74(16)
ld_fine_right_t          out = 75(16)
ld_fine_cross            out = 6E(16)
ld_medium_begin          out = (0E(16) start_alternate)
ld_medium_end            out = (0F(16) stop_alternate)
ld_medium_horizontal     out = 71(16)
ld_medium_vertical       out = 78(16)
ld_medium_upper_left     out = 6C(16)
ld_medium_upper_right    out = 6B(16)
ld_medium_lower_left     out = 6D(16)
ld_medium_lower_right    out = 6A(16)
ld_medium_up_t           out = 77(16)
ld_medium_down_t         out = 76(16)
ld_medium_left_t         out = 74(16)
ld_medium_right_t        out = 75(16)
ld_medium_cross          out = 6E(16)
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR DIGITAL VT100 TERMINAL               "
*DECK DECK=CSM$DEC_VT220 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR DIGITAL VT220 TERMINAL                       "

"   VARIABLES                                                                 "
prefix              = (1B(16) 5B(16))
fkey                = (1B(16) 4F(16))
escape              = (1B(16))
clear_home          = (prefix 32(16) 4A(16))
clear_all_tabs      = (prefix '3g')
ansi_mode           = (escape '<')
vt100_mode          = (prefix '61"p')
vt220_mode          = (prefix '62;1"p')
designate_ascii_g0  = (escape '(B')
designate_graph_g1  = (escape ')0')
select_g0           = (0F(16))
application_keypad  = (escape '=')
numeric_keypad      = (escape '>')
autowrap_off        = (prefix '?7l')
autowrap_on         = (prefix '?7h')
set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))
set_to_24x132       = (prefix 3F(16) 33(16) 68(16))
start_alternate     = (prefix 31(16) 6D(16))
start_inverse       = (prefix '7' 6D(16))
start_underline     = (prefix 34(16) 6D(16))
normal_attributes   = (prefix 'm')
stop_alternate      = (prefix '22m')
stop_inverse        = (prefix '27m')
stop_underline      = (prefix '24m')
home_cursor         = (prefix 48(16))
redo_set_line_mode = ( vt100_mode  ansi_mode  clear_all_tabs ..
     designate_ascii_g0 designate_graph_g1 select_g0 numeric_keypad ..
     autowrap_on)

start_keyload       = (esc 'P0;1|')
stop_keyload        = (esc '\')
load_f6             = ('17/1b5b4c')          " insert line "
load_f7             = ('18/1b5b4d')          " delete line "
load_f8             = ('19/1b5b40')          " insert blank character "
load_f9             = ('20/1b5b50')          " delete character "
load_f10            = ('21/1b5b3468')        " start insert mode "
load_f11            = ('23/1b5b346c')        " stop insert mode "
load_f12            = ('24/1b5b4b')          " clear to end of line "
load_f13            = ('25/1b5b324a')      " clear screen "
load_f14            = ('26/1b5b3939397e')  " Back "
load_help           = ('28/1b5b32387e')    " Help "
load_do             = ('29/1b5b48')          " Do=home "
load_f17            = ('31/1b5b3939387e')  " First "
load_f18            = ('32/1b5b357e')      " Bkw duplicates PrevScreen "
load_f19            = ('33/1b5b367e')      " Fwd duplicates NextScreen "
load_f20            = ('34/1b5b3939377e')  " Last "
load_all_keys       = (start_keyload load_f6 ';' load_f7 ';' load_f8 ';' ..
  load_f9 ';' load_f10 ';' load_f11 ';' load_f12 ';' load_f13 ';' load_f14 ..
  ';' load_help ';' load_do ';' load_f17 ';' load_f18 ';' load_f19 ';' ..
  load_f20 stop_keyload)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'DEC_VT220'
communications      type  = asynch
application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (3B(16))
cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 48(16))    label='shift-do'
cursor_up                inout = (prefix 41(16))
cursor_down              inout = (prefix 42(16))
cursor_left              inout = (prefix 44(16))
cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 1
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80   out = (set_to_24x80)
set_size       rows = 24 columns = 132  out = (set_to_24x132)

"   SCREEN AND LINE MODE TRANSITION                                           "
set_screen_mode     out=( ansi_mode  vt220_mode clear_all_tabs ..
     designate_ascii_g0  designate_graph_g1 select_g0 autowrap_off ..
     load_all_keys application_keypad)

" If all your applications run on a VT220, you may wish to replace
" vt100_mode with vt220_mode in the following set_line_mode command.

set_line_mode       out=( vt100_mode  ansi_mode  clear_all_tabs ..
     designate_ascii_g0 designate_graph_g1 select_g0 numeric_keypad ..
     autowrap_on normal_attributes clear_home home_cursor)

application_string name= 'REDO_SET_LINE_MODE' out=(redo_set_line_mode)

initialize_terminal sc='$system.change_terminal_attributes fkc=dec_vt220'

"   TERMINAL CAPABILITIES                                                     "
delete_char         inout = (prefix 50(16))    label='shift-f9'
delete_line_bol     inout = (prefix 4D(16))    label='shift-f7'
erase_end_of_line   inout = (prefix 4B(16))    label='shift-f12'
erase_line_stay     inout = (prefix 32(16) 4B(16))
erase_page_home     inout = (clear_home)       label='shift-f13'
insert_char         inout = (prefix 40(16))    label='shift-f8'
insert_line_bol     inout = (prefix 4C(16))         label='shift-f6'
insert_mode_begin   inout = (prefix 34(16) 68(16))  label='shift-f10'
insert_mode_end     inout = (prefix 34(16) 6C(16))  label='shift-f11'
tab_forward         inout = (09(16))
tab_clear_all       inout = (clear_all_tabs)
tab_set             inout = (1B(16) 48(16))

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
backspace           in = bs

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (prefix '17~')         label='f6'
f2        in = (prefix '18~')         label='f7'
f3        in = (prefix '19~')         label='f8'
f4        in = (prefix '20~')         label='f9'
f5        in = (prefix '21~')         label='10'
f6        in = (prefix '23~')         label='11'
f7        in = (prefix '24~')         label='12'
f8        in = (prefix '25~')         label='13'
f9        in = (prefix '26~')         label='14'
f10       in = (prefix '28~')         label='He'
f11       in = (prefix '29~')         label='Do'
f12       in = (prefix '31~')         label='17'
f13       in = (prefix '32~')         label='18'
f14       in = (prefix '33~')         label='19'
f15       in = (prefix '34~')         label='20'

f16       in = (fkey 'M')             label='ke'

f1_s      in = (fkey 'q')             label='k1'
f2_s      in = (fkey 'r')             label='k2'
f3_s      in = (fkey 's')             label='k3'
f4_s      in = (fkey 't')             label='k4'
f5_s      in = (fkey 'u')             label='k5'
f6_s      in = (fkey 'v')             label='k6'
f7_s      in = (fkey 'w')             label='k7'
f8_s      in = (fkey 'x')             label='k8'
f9_s      in = (fkey 'y')             label='k9'
f10_s     in = (fkey 'p')             label='k0'

f11_s     in = (fkey 'P')             label='p1'
f12_s     in = (fkey 'Q')             label='p2'
f13_s     in = (fkey 'R')             label='p3'
f14_s     in = (fkey 'S')             label='p4'

f15_s     in = (fkey 'm')             label='k-'
f16_s     in = (fkey 'l')             label='k,'

"         in = (prefix '2~')          label='IH'   "
"         in = (prefix '1~')          label='Fi'   "
"         in = (prefix '3~')          label='Re'   "
"         in = (prefix '4~')          label='Se'   "

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = (prefix '5~')          label='PS'
fwd       in = (prefix '6~')          label='NS'
back      in = (prefix '999~') label='shift-f14'
undo      in = (prefix '21~') label='10'
help      in = (prefix '28~') label='shift-help'
stop      in = (prefix '23~') label='F6'
bkw_s     in = (prefix '998~') label='  Shift-F17'
fwd_s     in = (prefix '997~') label='  Shift-F20'
undo_s    in = (fkey 'u') label='  Shift-F5'
stop_s    in = (fkey 'v') label='  Shift-F6'
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_alternate)
alt_end             out = (stop_alternate)
blink_begin         out = (prefix 35(16) 6D(16))
blink_end           out = (prefix '25m')
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = 0E(16)
ld_fine_end              out = 0F(16)
ld_fine_horizontal       out = 71(16)
ld_fine_vertical         out = 78(16)
ld_fine_upper_left       out = 6C(16)
ld_fine_upper_right      out = 6B(16)
ld_fine_lower_left       out = 6D(16)
ld_fine_lower_right      out = 6A(16)
ld_fine_up_t             out = 77(16)
ld_fine_down_t           out = 76(16)
ld_fine_left_t           out = 74(16)
ld_fine_right_t          out = 75(16)
ld_fine_cross            out = 6E(16)
ld_medium_begin          out = (0E(16) start_alternate)
ld_medium_end            out = (0F(16) stop_alternate)
ld_medium_horizontal     out = 71(16)
ld_medium_vertical       out = 78(16)
ld_medium_upper_left     out = 6C(16)
ld_medium_upper_right    out = 6B(16)
ld_medium_lower_left     out = 6D(16)
ld_medium_lower_right    out = 6A(16)
ld_medium_up_t           out = 77(16)
ld_medium_down_t         out = 76(16)
ld_medium_left_t         out = 74(16)
ld_medium_right_t        out = 75(16)
ld_medium_cross          out = 6E(16)
ld_bold_begin            out = (0E(16) start_inverse)
ld_bold_end              out = (0F(16) stop_inverse)
ld_bold_horizontal       out = 71(16)
ld_bold_vertical         out = 78(16)
ld_bold_upper_left       out = 6C(16)
ld_bold_upper_right      out = 6B(16)
ld_bold_lower_left       out = 6D(16)
ld_bold_lower_right      out = 6A(16)
ld_bold_up_t             out = 77(16)
ld_bold_down_t           out = 76(16)
ld_bold_left_t           out = 74(16)
ld_bold_right_t          out = 75(16)
ld_bold_cross            out = 6E(16)

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "


"   END OF TERMINAL DEFINITION FILE FOR DIGITAL VT220 TERMINAL               "
*DECK DECK=CSM$DEC_VT220_OLD EXPAND=TRUE


"   TERMINAL DEFINITION FILE FOR DIGITAL VT220 TERMINAL                       "

"   VARIABLES                                                                 "
prefix              = (1B(16) 5B(16))
fkey                = (1B(16) 4F(16))
escape              = (1B(16))
clear_home          = (prefix 32(16) 4A(16))
clear_all_tabs      = (prefix '3g')
ansi_mode           = (escape '<')
vt100_mode          = (prefix '61"p')
vt220_mode          = (prefix '62;1"p')
designate_ascii_g0  = (escape '(B')
designate_graph_g1  = (escape ')0')
select_g0           = (0F(16))
application_keypad  = (escape '=')
numeric_keypad      = (escape '>')
autowrap_off        = (prefix '?7l')
autowrap_on         = (prefix '?7h')
set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))
set_to_24x132       = (prefix 3F(16) 33(16) 68(16))
start_alternate     = (prefix 31(16) 6D(16))
start_inverse       = (prefix '7' 6D(16))
start_underline     = (prefix 34(16) 6D(16))
normal_attributes   = (prefix 'm')
stop_alternate      = (prefix '22m')
stop_inverse        = (prefix '27m')
stop_underline      = (prefix '24m')

start_keyload       = (esc 'P0;1|')
stop_keyload        = (esc '\')
load_f6             = ('17/1b5b4c')          " insert line "
load_f7             = ('18/1b5b4d')          " delete line "
load_f8             = ('19/1b5b40')          " insert blank character "
load_f9             = ('20/1b5b50')          " delete character "
load_f10            = ('21/1b5b3468')        " start insert mode "
load_f11            = ('23/1b5b346c')        " stop insert mode "
load_f12            = ('24/1b5b4b')          " clear to end of line "
load_f13            = ('25/1b5b324a0d')      " clear screen "
load_f14            = ('26/1b5b3939397e0d')  " Back "
load_help           = ('28/1b5b32387e0d')    " Help "
load_do             = ('29/1b5b48')          " Do=home "
load_f17            = ('31/1b5b3939387e0d')  " First "
load_f18            = ('32/1b5b357e0d')      " Bkw duplicates PrevScreen "
load_f19            = ('33/1b5b367e0d')      " Fwd duplicates NextScreen "
load_f20            = ('34/1b5b3939377e0d')  " Last "
load_all_keys       = (start_keyload load_f6 ';' load_f7 ';' load_f8 ';' ..
  load_f9 ';' load_f10 ';' load_f11 ';' load_f12 ';' load_f13 ';' load_f14 ..
  ';' load_help ';' load_do ';' load_f17 ';' load_f18 ';' load_f19 ';' ..
  load_f20 stop_keyload)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'DEC_VT220_OLD'
communications      type  = asynch
application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (3B(16))
cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 48(16))    label='shift-do'
cursor_up                inout = (prefix 41(16))
cursor_down              inout = (prefix 42(16))
cursor_left              inout = (prefix 44(16))
cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 1
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80   out = (set_to_24x80)
set_size       rows = 24 columns = 132  out = (set_to_24x132)

"   SCREEN AND LINE MODE TRANSITION                                           "
set_screen_mode     out=( ansi_mode  vt220_mode clear_all_tabs ..
     designate_ascii_g0  designate_graph_g1 select_g0 autowrap_off ..
     load_all_keys application_keypad)

set_line_mode       out=( vt100_mode  ansi_mode  clear_all_tabs ..
     designate_ascii_g0 designate_graph_g1 select_g0 numeric_keypad autowrap_on)

"et_screen_mode     out = (1B(16) 3C(16) clear_all_tabs ..
"    1B(16) 28(16) 42(16) 1B(16) 29(16) 30(16) 0F(16) 1B(16) ..
"    3D(16) prefix '?7l' vt220_mode )

"et_line_mode       out = (1B(16) 3C(16) clear_all_tabs ..
"    1B(16) 28(16) 42(16) 1B(16) 29(16) 30(16) 0F(16) 1B(16) ..
"    3E(16) prefix '?7h')

"   TERMINAL CAPABILITIES                                                     "
delete_char         inout = (prefix 50(16))    label='shift-f9'
delete_line_bol     inout = (prefix 4D(16))    label='shift-f7'
erase_end_of_line   inout = (prefix 4B(16))    label='shift-f12'
erase_line_stay     inout = (prefix 32(16) 4B(16))
erase_page_home     inout = (clear_home)       label='shift-f13'
insert_char         inout = (prefix 40(16))    label='shift-f8'
insert_line_bol     inout = (prefix 4C(16))         label='shift-f6'
insert_mode_begin   inout = (prefix 34(16) 68(16))  label='shift-f10'
insert_mode_end     inout = (prefix 34(16) 6C(16))  label='shift-f11'
tab_forward         inout = (09(16))
tab_clear_all       inout = (clear_all_tabs)
tab_set             inout = (1B(16) 48(16))

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
backspace           in = bs

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (prefix '17~')         label='f6'
f2        in = (prefix '18~')         label='f7'
f3        in = (prefix '19~')         label='f8'
f4        in = (prefix '20~')         label='f9'
f5        in = (prefix '21~')         label='10'
f6        in = (prefix '23~')         label='11'
f7        in = (prefix '24~')         label='12'
f8        in = (prefix '25~')         label='13'
f9        in = (prefix '26~')         label='14'
f10       in = (prefix '28~')         label='He'
f11       in = (prefix '29~')         label='Do'
f12       in = (prefix '31~')         label='17'
f13       in = (prefix '32~')         label='18'
f14       in = (prefix '33~')         label='19'
f15       in = (prefix '34~')         label='20'

f16       in = (fkey 'M')             label='ke'

f1_s      in = (fkey 'q')             label='k1'
f2_s      in = (fkey 'r')             label='k2'
f3_s      in = (fkey 's')             label='k3'
f4_s      in = (fkey 't')             label='k4'
f5_s      in = (fkey 'u')             label='k5'
f6_s      in = (fkey 'v')             label='k6'
f7_s      in = (fkey 'w')             label='k7'
f8_s      in = (fkey 'x')             label='k8'
f9_s      in = (fkey 'y')             label='k9'
f10_s     in = (fkey 'p')             label='k0'

f11_s     in = (fkey 'P')             label='p1'
f12_s     in = (fkey 'Q')             label='p2'
f13_s     in = (fkey 'R')             label='p3'
f14_s     in = (fkey 'S')             label='p4'

f15_s     in = (fkey 'm')             label='k-'
f16_s     in = (fkey 'l')             label='k,'

"         in = (prefix '2~')          label='IH'   "
"         in = (prefix '1~')          label='Fi'   "
"         in = (prefix '3~')          label='Re'   "
"         in = (prefix '4~')          label='Se'   "

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = (prefix '5~')          label='PS'
fwd       in = (prefix '6~')          label='NS'
back      in = (prefix '999~') label='shift-f14'
undo      in = (prefix '21~') label='10'
help      in = (prefix '28~') label='shift-help'
stop      in = (prefix '23~') label='F6'
bkw_s     in = (prefix '998~') label='  Shift-F17'
fwd_s     in = (prefix '997~') label='  Shift-F20'
undo_s    in = (fkey 'u') label='  Shift-F5'
stop_s    in = (fkey 'v') label='  Shift-F6'
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_alternate)
alt_end             out = (stop_alternate)
blink_begin         out = (prefix 35(16) 6D(16))
blink_end           out = (prefix '25m')
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = 0E(16)
ld_fine_end              out = 0F(16)
ld_fine_horizontal       out = 71(16)
ld_fine_vertical         out = 78(16)
ld_fine_upper_left       out = 6C(16)
ld_fine_upper_right      out = 6B(16)
ld_fine_lower_left       out = 6D(16)
ld_fine_lower_right      out = 6A(16)
ld_fine_up_t             out = 77(16)
ld_fine_down_t           out = 76(16)
ld_fine_left_t           out = 74(16)
ld_fine_right_t          out = 75(16)
ld_fine_cross            out = 6E(16)
ld_medium_begin          out = (0E(16) start_alternate)
ld_medium_end            out = (0F(16) stop_alternate)
ld_medium_horizontal     out = 71(16)
ld_medium_vertical       out = 78(16)
ld_medium_upper_left     out = 6C(16)
ld_medium_upper_right    out = 6B(16)
ld_medium_lower_left     out = 6D(16)
ld_medium_lower_right    out = 6A(16)
ld_medium_up_t           out = 77(16)
ld_medium_down_t         out = 76(16)
ld_medium_left_t         out = 74(16)
ld_medium_right_t        out = 75(16)
ld_medium_cross          out = 6E(16)
ld_bold_begin            out = (0E(16) start_inverse)
ld_bold_end              out = (0F(16) stop_inverse)
ld_bold_horizontal       out = 71(16)
ld_bold_vertical         out = 78(16)
ld_bold_upper_left       out = 6C(16)
ld_bold_upper_right      out = 6B(16)
ld_bold_lower_left       out = 6D(16)
ld_bold_lower_right      out = 6A(16)
ld_bold_up_t             out = 77(16)
ld_bold_down_t           out = 76(16)
ld_bold_left_t           out = 74(16)
ld_bold_right_t          out = 75(16)
ld_bold_cross            out = 6E(16)

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "


"   END OF TERMINAL DEFINITION FILE FOR DIGITAL VT220 TERMINAL               "
*DECK DECK=CSM$HP_2392 EXPAND=TRUE
"                                                                             "
"   TERMINAL DEFINITION FILE FOR HP-2392 TERMINALS                            "
"   **********************************************                            "
"                                                                             "
"    R. G. Gaebel, RZ ETHZ, 26/08/85                                          "
"    TH. Arn, IBETH, 28/08/85, 29/11/85, 29/05/86, 27/06/86, 22/06/87         "
"                    20/01/88
"                                                                             "
"   VARIABLES                                                                 "
"                                                                             "
    prefix                  = (esc '&')          "prefix of many hp commands  "
    spow_no                 = (prefix 's0B')     "blank overwrites character  "
    clear_display           = (esc 'J')
    cursor_home_key         = (esc 'h')
    enable_keyboard         = (esc 'b')
    disable_keyboard        = (esc 'c')
    select_line_drawing_set = (esc ')B')
    send_cursor_movements   = (prefix 's1A')
    local_cursor_movements  = (prefix 's0A')
    memory_lock_off         = (esc 'm')
    insert_char_off         = (esc 'R')
    set_left_margin         = (esc '4')
    set_right_margin        = (esc '5')
    clear_all_tabs          = (esc '3')
    clear_this_tab          = (esc '2')
    pos_00                  = (prefix 'a00C')
    pos_79                  = (prefix 'a79C')
    label_key_off           = (esc '&j@')
    label_key_on            = (esc '&jB')
    fun_1                   = (esc 'p')
    fun_2                   = (esc 'q')
    fun_3                   = (esc 'r')
    fun_4                   = (esc 's')
    fun_5                   = (esc 't')
    fun_6                   = (esc 'u')
    fun_7                   = (esc 'v')
    fun_8                   = (esc 'w')
    f_key_1                 = (prefix 'f1k2a2d2Lf1' fun_1)
    f_key_2                 = (prefix 'f2k2a2d2Lf2' fun_2)
    f_key_3                 = (prefix 'f3k2a2d2Lf3' fun_3)
    f_key_4                 = (prefix 'f4k2a2d2Lf4' fun_4)
    f_key_5                 = (prefix 'f5k2a2d2Lf5' fun_5)
    f_key_6                 = (prefix 'f6k2a2d2Lf6' fun_6)
    f_key_7                 = (prefix 'f7k2a2d2Lf7' fun_7)
    f_key_8                 = (prefix 'f8k2a2d2Lf8' fun_8)
    margins                 = (pos_00 set_left_margin pos_79 set_right_margin)
    f_key_init              = (f_key_1 f_key_2 f_key_3 f_key_4..
                               f_key_5 f_key_6 f_key_7 f_key_8 label_key_off)
    nice                    = (cursor_home_key pos_00 clear_display)
    video_attr              = (prefix 'd')
    inverse_attr            = (video_attr 'B')
    underline_attr          = (video_attr 'D')
    blink_attr              = (video_attr 'A')
    half_bright_attr        = (video_attr 'H')
    video_off               = (video_attr '@')
"                                                                             "
"   MODEL NAME AND COMMUNICATION TYPE                                         "
"                                                                             "
    model_name          value = 'HP_2392'
    communications      type  = asynch
    application_string  name='driver_procedure' out='tup$bootstrap_hp_driver'
"                                                                             "
"   END OF INFORMATION SPECIFICATION                                          "
"                                                                             "
    end_of_information  in    = (0)
"                                                                             "
"   CURSOR POSITIONING INFORMATION                                            "
"                                                                             "
    cursor_pos_encoding      bias  = (0)    type = ansi_cursor
    cursor_pos_column_first  value = TRUE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix 'a')
    cursor_pos_second        out   = ('c')
    cursor_pos_third         out   = ('R')
"                                                                             "
"   CURSOR MOVEMENT INFORMATION                                               "
"                                                                             "
    cursor_home              inout = (cursor_home_key)     label = 'Home'
    cursor_up                inout = (esc 'A')             label = 'Up'
    cursor_down              inout = (esc 'B')             label = 'Down'
    cursor_left              inout = (esc 'D')             label = 'Left'
    cursor_right             inout = (esc 'C')             label = 'Right'
"                                                                             "
"   CURSOR BEHAVIOR (for cursor movement keys)                                "
"                                                                             "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = wrap_same_next
    move_past_bottom         type  = wrap_same_next
"                                                                             "
"   CURSOR BEHAVIOR (for character keys)                                      "
"                                                                             "
    char_past_right          type  = wrap_adjacent_next
    char_past_left           type  = stop_next
    char_past_last_position  type  = scroll_next
"                                                                             "
"   TERMINAL ATTRIBUTES                                                       "
"                                                                             "
    automatic_tabbing        value = FALSE
    clears_when_change_size  value = FALSE
    function_key_leaves_mark value = 0
    has_hidden               value = FALSE
    has_protect              value = FALSE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = TRUE
"                                                                             "
"   SCREEN SIZES                                                              "
"                                                                             "
    set_size       rows = 24 columns = 80   out = (0)
"                                                                             "
"   SCREEN AND LINE MODE TRANSITION                                           "
"                                                                             "
    screen_init         out = (f_key_init spow_no select_line_drawing_set)
"                                                                             "
    line_init           out = ()
"                                                                             "
    set_screen_mode     out = (send_cursor_movements memory_lock_off ..
                               margins nice)
"                                                                             "
    set_line_mode       out = (local_cursor_movements clear_all_tabs ..
                               pos_00 set_left_margin label_key_on  ..
                               enable_keyboard)
"                                                                             "
"   TERMINAL CAPABILITIES                                                     "
"                                                                             "
    backspace           in    = (bs)             label = 'Backspace'
    delete_char         inout = (esc 'P')        label = 'Delete Char'
    delete_line_bol     inout = (esc 'M')        label = 'Delete Line'
    delete_line_stay    inout = ()
    erase_char          inout = ()
    erase_end_of_line   inout = (esc 'K')        label = 'ClrEL'
    erase_field_bof     inout = ()
    erase_field_stay    inout = ()
    erase_line_bol      inout = ()
    erase_line_stay     inout = ()
    erase_page_home     inout = ()
    erase_page_stay     in    = (clear_display)   label = 'Refrsh'
    erase_page_stay     out   = (cursor_home_key clear_display)
    insert_char         inout = ()
    insert_line_bol     inout = (esc 'L')         label = 'Insert Line'
    insert_line_stay    inout = ()
    erase_unprotected   inout = ()
    erase_end_of_page   inout = ()
    erase_end_of_field  inout = ()
    insert_mode_begin   inout = (esc 'Q')         label = 'Insert Char Begin'
    insert_mode_end     inout = (esc 'R')         label = 'Insert Char End'
    insert_mode_toggle  inout = ()
    tab_forward         inout = (ht)              label = 'TAB'
    tab_backward        inout = (esc 'i')         label = 'Cntl TAB'
    tab_clear           inout = (clear_this_tab)  label = 'Clear TAB'
    tab_clear_all       inout = (clear_all_tabs)  label = 'Cntl Clear TAB'
    tab_set             inout = (esc '1')         label = 'Set TAB'
"                                                                             "
"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
"                                                                             "
    bell_nak            out = (bel)
    bell_ack            out = ()
    display_begin       out = ()
    display_end         out = ()
    field_scroll_down   out = ()
    field_scroll_set    out = ()
    field_scroll_up     out = ()
    output_begin        out = (cursor_home_key disable_keyboard)
    output_end          out = (enable_keyboard)
    print_begin         out = ()
    print_end           out = ()
    print_page          out = ()
    protect_all         out = ()
    reset               out = ()
    return              out = ()
"                                                                             "
"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
"                                                                             "
    f1        in = (fun_1)      label = 'F1'
    f2        in = (fun_2)      label = 'F2'
    f3        in = (fun_3)      label = 'F3'
    f4        in = (fun_4)      label = 'F4'
    f5        in = (fun_5)      label = 'F5'
    f6        in = (fun_6)      label = 'F6'
    f7        in = (fun_7)      label = 'F7'
    f8        in = (fun_8)      label = 'F8'
    f9        in = (soh fun_1)  label = 'A1'
    f10       in = (soh fun_2)  label = 'A2'
    f11       in = (soh fun_3)  label = 'A3'
    f12       in = (soh fun_4)  label = 'A4'
    f13       in = (soh fun_5)  label = 'A5'
    f14       in = (soh fun_6)  label = 'A6'
    f15       in = (soh fun_7)  label = 'A7'
    f16       in = (soh fun_8)  label = 'A8'
    f1_s      in = (esc fun_1)   label = 'E1'
    f2_s      in = (esc fun_2)   label = 'E2'
    f3_s      in = (esc fun_3)   label = 'E3'
    f4_s      in = (esc fun_4)   label = 'E4'
    f5_s      in = (esc fun_5)   label = 'E5'
    f6_s      in = (esc fun_6)   label = 'E6'
    f7_s      in = (esc fun_7)   label = 'E7'
    f8_s      in = (esc fun_8)   label = 'E8'
    f9_s      in = (stx fun_1)   label = 'B1'
    f10_s     in = (stx fun_2)   label = 'B2'
    f11_s     in = (stx fun_3)   label = 'B3'
    f12_s     in = (stx fun_4)   label = 'B4'
    f13_s     in = (stx fun_5)   label = 'B5'
    f14_s     in = (stx fun_6)   label = 'B6'
    f15_s     in = (stx fun_7)   label = 'B7'
    f16_s     in = (stx fun_8)   label = 'B8'
"                                                                             "
"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
"                                                                             "
    next      in = (cr)        label = 'RETURN'
    next_s    in = ()          label = ' '
    back      in = (fun_3)     label = 'F3'
    back_s    in = ()          label = ' '
    help      in = (fun_4)     label = 'F4'
    help_s    in = ()          label = ' '
    stop      in = (fun_6)     label = 'F6'
    down      in = (esc 'T')   label = 'DOWN = Roll Down'
    down_s    in = ()          label = ' '
    up        in = (esc 'S')   label = 'UP = Roll Up'
    up_s      in = ()          label = ' '
    fwd       in = (esc 'U')   label = 'FWD = Next Page'
    fwd_s     in = (esc 'F')   label = 'Last = CTL/Home'
    bkw       in = (esc 'V')   label = 'Prev Page'
    bkw_s     in = (ack)       label = 'First = CTL/F'
    edit      in = ()          label = ' '
    undo      in = (fun_5)     label = 'F5'
    undo_s    in = (esc fun_5) label = 'E5 = ESC F5'
"                                                                             "
"   TERMINAL VIDEO ATTRIBUTES                                                 "
"                                                                             "
    alt_begin           out = (half_bright_attr)
    alt_end             out = (video_off)
    blink_begin         out = (blink_attr)
    blink_end           out = (video_off)
    hidden_begin        out = ()
    hidden_end          out = ()
    inverse_begin       out = (inverse_attr)
    inverse_end         out = (video_off)
    protect_begin       out = ()
    protect_end         out = ()
    underline_begin     out = (underline_attr)
    underline_end       out = (video_off)
"                                                                             "
"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
"                                                                             "
"   ERROR                                                                     "
"                                                                             "
    error_begin         out = (inverse_attr)
    error_end           out = (video_off)
"                                                                             "
"   INPUT TEXT                                                                "
"                                                                             "
    input_text_begin    out = (underline_attr)
    input_text_end      out = (video_off)
"                                                                             "
"   ITALIC                                                                    "
"                                                                             "
    italic_begin        out = (inverse_attr)
    italic_end          out = (video_off)
"                                                                             "
"   MESSAGE                                                                   "
"                                                                             "
    message_begin       out = (inverse_attr)
    message_end         out = (video_off)
"                                                                             "
"   OUTPUT TEXT                                                               "
"                                                                             "
    output_text_begin   out = ()
    output_text_end     out = ()
"                                                                             "
"   TITLE                                                                     "
"                                                                             "
    title_begin         out = ()
    title_end           out = ()
"                                                                             "
"   LINE DRAWING CHARACTER SPECIFICATION                                      "
"                                                                             "
"        Fine Line Drawing Begin and End Sequences.                           "
"                                                                             "
    ld_fine_begin            out = (so)
    ld_fine_end              out = (si)
"                                                                             "
"        Horizontal and Vertical Characters.                                  "
"                                                                             "
    ld_fine_horizontal       out = (',')
    ld_fine_vertical         out = ('.')
"                                                                             "
"        Box Corner Characters.                                               "
"                                                                             "
    ld_fine_upper_left       out = ('R')
    ld_fine_upper_right      out = ('T')
    ld_fine_lower_left       out = ('F')
    ld_fine_lower_right      out = ('G')
"                                                                             "
"        Intersection Characters.                                             "
"                                                                             "
    ld_fine_up_t             out = ('7')
    ld_fine_down_t           out = ('8')
    ld_fine_left_t           out = ('5')
    ld_fine_right_t          out = ('6')
    ld_fine_cross            out = ('/')
"                                                                             "
"        Medium Line Drawing Begin and End Sequences.                         "
"                                                                             "
    ld_medium_begin          out = (so)
    ld_medium_end            out = (si)
"                                                                             "
"        Horizontal and Vertical Characters.                                  "
"                                                                             "
    ld_medium_horizontal     out = (';')
    ld_medium_vertical       out = (':')
"                                                                             "
"        Box Corner Characters.                                               "
"                                                                             "
    ld_medium_upper_left     out = ('Q')
    ld_medium_upper_right    out = ('W')
    ld_medium_lower_left     out = ('A')
    ld_medium_lower_right    out = ('S')
"                                                                             "
"        Intersection Characters.                                             "
"                                                                             "
    ld_medium_up_t           out = ('3')
    ld_medium_down_t         out = ('4')
    ld_medium_left_t         out = ('1')
    ld_medium_right_t        out = ('2')
    ld_medium_cross          out = ('0')
"                                                                             "
"        Bold Line Drawing Begin and End Sequences.                           "
"                                                                             "
    ld_bold_begin            out = (inverse_attr)
    ld_bold_end              out = (video_off)
"                                                                             "
"        Horizontal and Vertical Characters.                                  "
"                                                                             "
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
"                                                                             "
"        Box Corner Characters.                                               "
"                                                                             "
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
"                                                                             "
"        Intersection Characters.                                             "
"                                                                             "
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')
"                                                                             "
"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "
"                                                                             "
application_string n=('FSE_FUNCTION_1') o=('mark_lines')
application_string n=('FSE_FUNCTION_2') o=('break_text')
application_string n=('FSE_FUNCTION_3') o=('copy_text l=m p=a')
" F4 is Help as System Default "
application_string n=('FSE_FUNCTION_5') o=('undo')
application_string n=('FSE_FUNCTION_6') o=('end')
get_text = 'text=$screen_input(''Enter search string'')'
locate = 'if text <> '''' then ; locate_text t=text ; ifend'
application_string n=('FSE_FUNCTION_7') ..
                 out=(get_text ';' locate)
application_string name=('FSE_FUNCTION_8') ..
                   o=('locate_next')
application_string n=('FSE_FUNCTION_9') ..
                 o=('position_cursor l=c c=1+$strlen($lt)')
application_string n=('FSE_FUNCTION_10') o=('align_screen m=c')
application_string n=('FSE_FUNCTION_11') o=('format_paragraphs')
application_string n=('FSE_FUNCTION_12') o=('mark_characters')
application_string n=('FSE_FUNCTION_13') o=('delete_word')
application_string n=('FSE_FUNCTION_14') ..
                 o=('insert_characters nt=''        ''')
application_string n=('FSE_FUNCTION_15') o=('indent_text l=m o=1')
locall = 'if text='''' then ; locate_all ; else ; locate_all t=text ; ifend'
application_string n=('FSE_FUNCTION_16') o=(get_text ' ; ' locall)

application_string name=('FSE_FUNCTION_SHIFT_1') out=('unmark')
application_string name=('FSE_FUNCTION_SHIFT_2') out=('join_text')
application_string name=('FSE_FUNCTION_SHIFT_3') out=('move_text l=m p=a')
select_offset = 'if $OFFSET=0 then ; offset=40 ; else ; offset=0 ; ifend ; '
application_string n=('FSE_FUNCTION_SHIFT_4') o=(select_offset 'alis o=offset')
application_string name=('FSE_FUNCTION_SHIFT_5') o=('mark_characters')
application_string name=('FSE_FUNCTION_SHIFT_6') o=('end no')
application_string name=('FSE_FUNCTION_SHIFT_7') out=('delete_text l=m')
application_string n=('FSE_FUNCTION_SHIFT_8') ..
                   o=('position_cursor d=b ; position_cursor rs=true d=b')
application_string name=('FSE_FUNCTION_SHIFT_9') out=()
application_string name=('FSE_FUNCTION_SHIFT_10') out=()
application_string name=('FSE_FUNCTION_SHIFT_11') out=('center_lines')
application_string name=('FSE_FUNCTION_SHIFT_12') out=()
application_string name=('FSE_FUNCTION_SHIFT_13') out=()
application_string name=('FSE_FUNCTION_SHIFT_14') out=()
application_string name=('FSE_FUNCTION_SHIFT_15') out=('indent_text l=m o=-1')
application_string name=('FSE_FUNCTION_SHIFT_16') out=()

application_string n=('FSE_FUNCTION_1_LABEL') out=('Mark')
application_string n=('FSE_FUNCTION_2_LABEL') out=('Break')
application_string n=('FSE_FUNCTION_3_LABEL') out=('Copy')
" F4 is Help as System Default "
application_string n=('FSE_FUNCTION_5_LABEL') out=('Undo')
application_string n=('FSE_FUNCTION_6_LABEL') out=('Quit')
application_string n=('FSE_FUNCTION_7_LABEL') out=('Locate')
application_string n=('FSE_FUNCTION_8_LABEL') out=('LocNxt')
application_string n=('FSE_FUNCTION_9_LABEL') out=('SkpEL')
application_string n=('FSE_FUNCTION_10_LABEL') out=('Middle')
application_string n=('FSE_FUNCTION_11_LABEL') out=('Format')
application_string n=('FSE_FUNCTION_12_LABEL') out=('MrkCh')
application_string n=('FSE_FUNCTION_13_LABEL') out=('DelWd')
application_string n=('FSE_FUNCTION_14_LABEL') out=('InsWd')
application_string n=('FSE_FUNCTION_15_LABEL') out=('Indent')
application_string n=('FSE_FUNCTION_16_LABEL') out=('LocAll')

application_string n=('FSE_FUNCTION_SHIFT_1_LABEL') out=('Unmark')
application_string n=('FSE_FUNCTION_SHIFT_2_LABEL') out=('Join')
application_string n=('FSE_FUNCTION_SHIFT_3_LABEL') out=('Move')
application_string n=('FSE_FUNCTION_SHIFT_4_LABEL') out=('Width')
application_string n=('FSE_FUNCTION_SHIFT_5_LABEL') out=('MrkChr')
application_string n=('FSE_FUNCTION_SHIFT_6_LABEL') out=('Exit')
application_string n=('FSE_FUNCTION_SHIFT_7_LABEL') out=('Delete')
application_string n=('FSE_FUNCTION_SHIFT_8_LABEL') out=('LocPrv')
application_string n=('FSE_FUNCTION_SHIFT_9_LABEL') out=('      ')
application_string n=('FSE_FUNCTION_SHIFT_10_LABEL') out=('     ')
application_string n=('FSE_FUNCTION_SHIFT_11_LABEL') out=('Center')
application_string n=('FSE_FUNCTION_SHIFT_12_LABEL') out=('      ')
application_string n=('FSE_FUNCTION_SHIFT_13_LABEL') out=('      ')
application_string n=('FSE_FUNCTION_SHIFT_14_LABEL') out=('      ')
application_string n=('FSE_FUNCTION_SHIFT_15_LABEL') out=('Dedent')
application_string n=('FSE_FUNCTION_SHIFT_16_LABEL') out=('      ')
"                                                                             "
"   END OF TERMINAL DEFINITION FILE FOR HP-2645 TERMINAL                      "
*DECK DECK=CSM$HP_2645 EXPAND=TRUE
"                                                                             "
"   TERMINAL DEFINITION FILE FOR HP-2645 TERMINALS                            "
"   **********************************************                            "
"                                                                             "
"    R. G. Gaebel, RZ ETHZ, 26/08/85                                          "
"    TH. Arn, IBETH, 28/08/85, 29/11/85, 29/05/86, 22/06/87, 20/01/88         "
"                                                                             "
"   VARIABLES                                                                 "
"                                                                             "
    prefix                 = (esc '&')           "prefix of many hp commands  "
    spow_no                = (prefix 's0B')      "blank overwrites character  "
    clear_display          = (esc 'J')
    cursor_home_key        = (esc 'h')
    send_cursor_movements  = (prefix 's1A')
    local_cursor_movements = (prefix 's0A')
    enable_keyboard        = (esc 'b')
    disable_keyboard       = (esc 'c')
    memory_lock_off        = (esc 'm')
    insert_char_off        = (esc 'R')
    set_left_margin        = (esc '4')
    set_right_margin       = (esc '5')
    clear_all_tabs         = (esc '3')
    clear_this_tab         = (esc '2')
    pos_00                 = (prefix 'a00C')
    pos_79                 = (prefix 'a79C')
    fun_1                  = (esc 'p')
    fun_2                  = (esc 'q')
    fun_3                  = (esc 'r')
    fun_4                  = (esc 's')
    fun_5                  = (esc 't')
    fun_6                  = (esc 'u')
    fun_7                  = (esc 'v')
    fun_8                  = (esc 'w')
    f_key_1                = (prefix 'f1k0a3L' fun_1 cr)
    f_key_2                = (prefix 'f2k0a3L' fun_2 cr)
    f_key_3                = (prefix 'f3k0a3L' fun_3 cr)
    f_key_4                = (prefix 'f4k0a3L' fun_4 cr)
    f_key_5                = (prefix 'f5k0a3L' fun_5 cr)
    f_key_6                = (prefix 'f6k0a3L' fun_6 cr)
    f_key_7                = (prefix 'f7k0a3L' fun_7 cr)
    f_key_8                = (prefix 'f8k0a3L' fun_8 cr)
    margins                = (pos_00 set_left_margin pos_79 set_right_margin)
    f_key_init             = (f_key_1 f_key_2 f_key_3 f_key_4..
                              f_key_5 f_key_6 f_key_7 f_key_8)
    nice                   = (cursor_home_key pos_00 clear_display)
    video_attr             = (prefix 'd')
    blink_attr             = (video_attr 'A')
    inverse_attr           = (video_attr 'B')
    underline_attr         = (video_attr 'D')
    half_bright_attr       = (video_attr 'H')
    video_off              = (video_attr '@')
"                                                                             "
"   MODEL NAME AND COMMUNICATION TYPE                                         "
"                                                                             "
    model_name          value = 'HP_2645'
    communications      type  = asynch
    application_string  name='insert_delete_scrolling' out='true'
    application_string  name='driver_procedure' out='tup$bootstrap_hp_driver'
"                                                                             "
"   END OF INFORMATION SPECIFICATION                                          "
"                                                                             "
    end_of_information  in    = (0)
"                                                                             "
"   CURSOR POSITIONING INFORMATION                                            "
"                                                                             "
    cursor_pos_encoding      bias  = (0)    type = ansi_cursor
    cursor_pos_column_first  value = TRUE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix 'a')
    cursor_pos_second        out   = ('c')
    cursor_pos_third         out   = ('R')
"                                                                             "
"   CURSOR MOVEMENT INFORMATION                                               "
"                                                                             "
    cursor_home              inout = (cursor_home_key)  label='Home'
    cursor_up                inout = (esc 'A')          label='Up'
    cursor_down              inout = (esc 'B')          label='Down'
    cursor_left              inout = (esc 'D')          label='Left'
    cursor_right             inout = (esc 'C')          label='Right'
"                                                                             "
"   CURSOR BEHAVIOR (for cursor movement keys)                                "
"                                                                             "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = wrap_same_next
    move_past_bottom         type  = wrap_same_next
"                                                                             "
"   CURSOR BEHAVIOR (for character keys)                                      "
"                                                                             "
    char_past_right          type  = wrap_adjacent_next
    char_past_left           type  = stop_next
    char_past_last_position  type  = scroll_next
"                                                                             "
"   TERMINAL ATTRIBUTES                                                       "
"                                                                             "
    automatic_tabbing        value = FALSE
    clears_when_change_size  value = FALSE
    function_key_leaves_mark value = 1
    has_hidden               value = FALSE
    has_protect              value = FALSE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = TRUE
"                                                                             "
"   SCREEN SIZES                                                              "
"                                                                             "
    set_size       rows = 24 columns = 80   out = (0)
"                                                                             "
"   SCREEN AND LINE MODE TRANSITION                                           "
"                                                                             "
    screen_init         out = (f_key_init spow_no)
"                                                                             "
    line_init           out = ()
"                                                                             "
    set_screen_mode     out = (send_cursor_movements memory_lock_off ..
                               margins nice)
"                                                                             "
    set_line_mode       out = (local_cursor_movements clear_all_tabs ..
                               pos_00 set_left_margin enable_keyboard)
"                                                                             "
"   TERMINAL CAPABILITIES                                                     "
"                                                                             "
    backspace           in    = (bs)              label='Backspace'
    delete_char         inout = (esc 'P')         label='Delete char'
    delete_line_bol     inout = (esc 'M')         label='Delete line'
    delete_line_stay    inout = ()
    erase_char          inout = ()
    erase_end_of_line   inout = (esc 'K')         label='ClrEL'
    erase_field_bof     inout = ()
    erase_field_stay    inout = ()
    erase_line_bol      inout = ()
    erase_line_stay     inout = ()
    erase_page_home     inout = ()
    erase_page_stay     in    = (clear_display)   label='Refrsh'
    erase_page_stay     out   = (cursor_home_key clear_display)
    insert_char         inout = ()
    insert_line_bol     inout = (esc 'L')   label='Insert line'
    insert_line_stay    inout = ()
    erase_unprotected   inout = ()
    erase_end_of_page   inout = ()
    erase_end_of_field  inout = ()
    insert_mode_begin   inout = (esc 'Q')   label='Insert char'
    insert_mode_end     inout = (esc 'R')   label='Insert char'
    insert_mode_toggle  inout = ()
    tab_forward         inout = (ht)
    tab_backward        inout = (esc 'i')   label='Cntl Backspace'
    tab_clear           inout = (clear_this_tab)   label='TAB'
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (esc '1')
"                                                                             "
"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
"                                                                             "
    bell_nak            out = (bel)
    bell_ack            out = ()
    display_begin       out = ()
    display_end         out = ()
    field_scroll_down   out = ()
    field_scroll_set    out = ()
    field_scroll_up     out = ()
    output_begin        out = (cursor_home_key disable_keyboard)
    output_end          out = (enable_keyboard)
    print_begin         out = ()
    print_end           out = ()
    print_page          out = ()
    protect_all         out = ()
    reset               out = ()
    return              out = (cr) label='Return'
"                                                                             "
"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
"                                                                             "
    f1        in = (fun_1)      label = 'F1'
    f2        in = (fun_2)      label = 'F2'
    f3        in = (fun_3)      label = 'F3'
    f4        in = (fun_4)      label = 'F4'
    f5        in = (fun_5)      label = 'F5'
    f6        in = (fun_6)      label = 'F6'
    f7        in = (fun_7)      label = 'F7'
    f8        in = (fun_8)      label = 'F8'
    f9        in = (soh fun_1)  label = 'A1 = Cntl A + F1'
    f10       in = (soh fun_2)  label = 'A2 = Cntl A + F2'
    f11       in = (soh fun_3)  label = 'A3 = Cntl A + F3'
    f12       in = (soh fun_4)  label = 'A4 = Cntl A + F4'
    f13       in = (soh fun_5)  label = 'A5 = Cntl A + F5'
    f14       in = (soh fun_6)  label = 'A6 = Cntl A + F6'
    f15       in = (soh fun_7)  label = 'A7 = Cntl A + F7'
    f16       in = (soh fun_8)  label = 'A8 = Cntl A + F8'
    f1_s      in = (esc fun_1)   label = 'E1 = ESC + F1'
    f2_s      in = (esc fun_2)   label = 'E2 = ESC + F2'
    f3_s      in = (esc fun_3)   label = 'E3 = ESC + F3'
    f4_s      in = (esc fun_4)   label = 'E4 = ESC + F4'
    f5_s      in = (esc fun_5)   label = 'E5 = ESC + F5'
    f6_s      in = (esc fun_6)   label = 'E6 = ESC + F6'
    f7_s      in = (esc fun_7)   label = 'E7 = ESC + F7'
    f8_s      in = (esc fun_8)   label = 'E8 = ESC + F8'
    f9_s      in = (stx fun_1)  label = 'B1 = Cntl B + F1'
    f10_s     in = (stx fun_2)  label = 'B2 = Cntl B + F2'
    f11_s     in = (stx fun_3)  label = 'B3 = Cntl B + F3'
    f12_s     in = (stx fun_4)  label = 'B4 = Cntl B + F4'
    f13_s     in = (stx fun_5)  label = 'B5 = Cntl B + F5'
    f14_s     in = (stx fun_6)  label = 'B6 = Cntl B + F6'
    f15_s     in = (stx fun_7)  label = 'B7 = Cntl B + F7'
    f16_s     in = (stx fun_8)  label = 'B8 = Cntl B + F8'
"                                                                             "
"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
"                                                                             "
    next      in = (cr)        label = 'RETURN'
    next_s    in = ()          label = ' '
    back      in = (fun_3)     label = 'F3'
    back_s    in = ()          label = ' '
    help      in = (fun_4)     label = 'F4'
    help_s    in = ()          label = ' '
    stop      in = (fun_6)     label = 'F6'
    stop_s    in = (esc fun_6) label = 'E6 = ESC + F6'
    down      in = (esc 'T')   label = 'DOWN = Roll Down'
    down_s    in = ()          label = ' '
    up        in = (esc 'S')   label = 'UP = Roll Up'
    up_s      in = ()          label = ' '
    fwd       in = (esc 'U')   label = 'FWD = Next Page'
    fwd_s     in = (esc 'F')   label = 'Last = CTL/Home'
    bkw       in = (esc 'V')   label = 'BKW = Prev Page'
    bkw_s     in = (ack)       label = 'First = CTL/F'
    edit      in = ()          label = ' '
    undo      in = (fun_5)     label = 'F5'
    undo_s    in = (esc fun_5) label = 'E5 = ESC + F5'
"                                                                             "
"   TERMINAL VIDEO ATTRIBUTES                                                 "
"                                                                             "
    alt_begin           out = ()
    alt_end             out = ()
    blink_begin         out = ()
    blink_end           out = ()
    hidden_begin        out = ()
    hidden_end          out = ()
    inverse_begin       out = (inverse_attr)
    inverse_end         out = (video_off)
    protect_begin       out = ()
    protect_end         out = ()
    underline_begin     out = ()
    underline_end       out = ()
"                                                                             "
"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
"                                                                             "
"   ERROR                                                                     "
"                                                                             "
    error_begin         out = (inverse_attr)
    error_end           out = (video_off)
"                                                                             "
"   INPUT TEXT                                                                "
"                                                                             "
    input_text_begin    out = (inverse_attr)
    input_text_end      out = (video_off)
"                                                                             "
"   ITALIC                                                                    "
"                                                                             "
    italic_begin        out = (inverse_attr)
    italic_end          out = (video_off)
"                                                                             "
"   MESSAGE                                                                   "
"                                                                             "
    message_begin       out = (inverse_attr)
    message_end         out = (video_off)
"                                                                             "
"   OUTPUT TEXT                                                               "
"                                                                             "
    output_text_begin   out = ()
    output_text_end     out = ()
"                                                                             "
"   TITLE                                                                     "
"                                                                             "
    title_begin         out = ()
    title_end           out = ()
"                                                                             "
"   LINE DRAWING CHARACTER SPECIFICATION                                      "
"                                                                             "
"        Fine Line Drawing Begin and End Sequences.                           "
"                                                                             "
    ld_fine_begin            out = ()
    ld_fine_end              out = ()
"                                                                             "
"        Horizontal and Vertical Characters.                                  "
"                                                                             "
    ld_fine_horizontal       out = ('.')
    ld_fine_vertical         out = ('.')
"                                                                             "
"        Box Corner Characters.                                               "
"                                                                             "
    ld_fine_upper_left       out = ('.')
    ld_fine_upper_right      out = ('.')
    ld_fine_lower_left       out = ('.')
    ld_fine_lower_right      out = ('.')
"                                                                             "
"        Intersection Characters.                                             "
"                                                                             "
    ld_fine_up_t             out = ('.')
    ld_fine_down_t           out = ('.')
    ld_fine_left_t           out = ('.')
    ld_fine_right_t          out = ('.')
    ld_fine_cross            out = ('.')
"                                                                             "
"        Medium Line Drawing Begin and End Sequences.                         "
"                                                                             "
    ld_medium_begin          out = ('')
    ld_medium_end            out = ('')
"                                                                             "
"        Horizontal and Vertical Characters.                                  "
"                                                                             "
    ld_medium_horizontal     out = ('-')
    ld_medium_vertical       out = ('|')
"                                                                             "
"        Box Corner Characters.                                               "
"                                                                             "
    ld_medium_upper_left     out = ('+')
    ld_medium_upper_right    out = ('+')
    ld_medium_lower_left     out = ('+')
    ld_medium_lower_right    out = ('+')
"                                                                             "
"        Intersection Characters.                                             "
"                                                                             "
    ld_medium_up_t           out = ('+')
    ld_medium_down_t         out = ('+')
    ld_medium_left_t         out = ('+')
    ld_medium_right_t        out = ('+')
    ld_medium_cross          out = ('+')
"                                                                             "
"        Bold Line Drawing Begin and End Sequences.                           "
"                                                                             "
    ld_bold_begin            out = (inverse_attr)
    ld_bold_end              out = (video_off)
"                                                                             "
"        Horizontal and Vertical Characters.                                  "
"                                                                             "
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
"                                                                             "
"        Box Corner Characters.                                               "
"                                                                             "
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
"                                                                             "
"        Intersection Characters.                                             "
"                                                                             "
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')
"                                                                             "
"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "
"                                                                             "
application_string n=('FSE_FUNCTION_1') o=('mark_lines')
application_string n=('FSE_FUNCTION_2') o=('break_text')
application_string n=('FSE_FUNCTION_3') o=('copy_text l=m p=a')
" F4 is Help as System Default "
application_string n=('FSE_FUNCTION_5') o=('undo')
application_string n=('FSE_FUNCTION_6') o=('end')
get_text = 'text=$screen_input(''Enter search string'')'
locate = 'if text <> '''' then ; locate_text t=text ; ifend'
application_string n=('FSE_FUNCTION_7') ..
                 out=(get_text ';' locate)
application_string name=('FSE_FUNCTION_8') ..
                   o=('locate_next')
application_string n=('FSE_FUNCTION_9') ..
                 o=('position_cursor l=c c=1+$strlen($lt)')
application_string n=('FSE_FUNCTION_10') o=('align_screen m=c')
application_string n=('FSE_FUNCTION_11') o=('format_paragraphs')
application_string n=('FSE_FUNCTION_12') o=('mark_characters')
application_string n=('FSE_FUNCTION_13') o=('delete_word')
application_string n=('FSE_FUNCTION_14') ..
                 o=('insert_characters nt=''        ''')
application_string n=('FSE_FUNCTION_15') o=('indent_text l=m o=1')
locall = 'if text='''' then ; locate_all ; else ; locate_all t=text ; ifend'
application_string n=('FSE_FUNCTION_16') o=(get_text ' ; ' locall)

application_string name=('FSE_FUNCTION_SHIFT_1') out=('unmark')
application_string name=('FSE_FUNCTION_SHIFT_2') out=('join_text')
application_string name=('FSE_FUNCTION_SHIFT_3') out=('move_text l=m p=a')
select_offset = 'if $OFFSET=0 then ; offset=40 ; else ; offset=0 ; ifend ; '
application_string n=('FSE_FUNCTION_SHIFT_4') o=(select_offset 'alis o=offset')
application_string name=('FSE_FUNCTION_SHIFT_5') o=('mark_characters')
application_string name=('FSE_FUNCTION_SHIFT_6') o=('end no')
application_string name=('FSE_FUNCTION_SHIFT_7') out=('delete_text l=m')
application_string n=('FSE_FUNCTION_SHIFT_8') ..
                   o=('position_cursor d=b ; position_cursor rs=true d=b')
application_string name=('FSE_FUNCTION_SHIFT_9') out=()
application_string name=('FSE_FUNCTION_SHIFT_10') out=()
application_string name=('FSE_FUNCTION_SHIFT_11') out=('center_lines')
application_string name=('FSE_FUNCTION_SHIFT_12') out=()
application_string name=('FSE_FUNCTION_SHIFT_13') out=()
application_string name=('FSE_FUNCTION_SHIFT_14') out=()
application_string name=('FSE_FUNCTION_SHIFT_15') out=('indent_text l=m o=-1')
application_string name=('FSE_FUNCTION_SHIFT_16') out=()

application_string n=('FSE_FUNCTION_1_LABEL') out=('Mark')
application_string n=('FSE_FUNCTION_2_LABEL') out=('Break')
application_string n=('FSE_FUNCTION_3_LABEL') out=('Copy')
" F4 is Help as System Default "
application_string n=('FSE_FUNCTION_5_LABEL') out=('Undo')
application_string n=('FSE_FUNCTION_6_LABEL') out=('Quit')
application_string n=('FSE_FUNCTION_7_LABEL') out=('Locate')
application_string n=('FSE_FUNCTION_8_LABEL') out=('LocNxt')
application_string n=('FSE_FUNCTION_9_LABEL') out=('SkpEL')
application_string n=('FSE_FUNCTION_10_LABEL') out=('Middle')
application_string n=('FSE_FUNCTION_11_LABEL') out=('Format')
application_string n=('FSE_FUNCTION_12_LABEL') out=('MrkCh')
application_string n=('FSE_FUNCTION_13_LABEL') out=('DelWd')
application_string n=('FSE_FUNCTION_14_LABEL') out=('InsWd')
application_string n=('FSE_FUNCTION_15_LABEL') out=('Indent')
application_string n=('FSE_FUNCTION_16_LABEL') out=('LocAll')

application_string n=('FSE_FUNCTION_SHIFT_1_LABEL') out=('Unmark')
application_string n=('FSE_FUNCTION_SHIFT_2_LABEL') out=('Join')
application_string n=('FSE_FUNCTION_SHIFT_3_LABEL') out=('Move')
application_string n=('FSE_FUNCTION_SHIFT_4_LABEL') out=('Width')
application_string n=('FSE_FUNCTION_SHIFT_5_LABEL') out=('MrkChr')
application_string n=('FSE_FUNCTION_SHIFT_6_LABEL') out=('Exit')
application_string n=('FSE_FUNCTION_SHIFT_7_LABEL') out=('Delete')
application_string n=('FSE_FUNCTION_SHIFT_8_LABEL') out=('LocPrv')
application_string n=('FSE_FUNCTION_SHIFT_9_LABEL') out=('      ')
application_string n=('FSE_FUNCTION_SHIFT_10_LABEL') out=('     ')
application_string n=('FSE_FUNCTION_SHIFT_11_LABEL') out=('Center')
application_string n=('FSE_FUNCTION_SHIFT_12_LABEL') out=('      ')
application_string n=('FSE_FUNCTION_SHIFT_13_LABEL') out=('      ')
application_string n=('FSE_FUNCTION_SHIFT_14_LABEL') out=('      ')
application_string n=('FSE_FUNCTION_SHIFT_15_LABEL') out=('Dedent')
application_string n=('FSE_FUNCTION_SHIFT_16_LABEL') out=('      ')
"                                                                             "
"   END OF TERMINAL DEFINITION FILE FOR HP-2645 TERMINAL                      "
*DECK DECK=CSM$IBM_3270 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR THE IBM 3270 TERMINAL                        "


"   VARIABLES                                                                 "
    ERASE_UNPROT_TO_ADDRESS  = (12(16))
    GRAPHIC_ESCAPE           = (00(16))
    INSERT_CURSOR            = (13(16))
    MODIFY_FIELD             = (00(16))
    PROGRAM_TAB              = (09(16))
    REPEAT_TO_ADDRESS        = (14(16))
    SET_ATTRIBUTE            = (00(16))
    SET_BUFFER_ADDRESS       = (11(16))
    START_FIELD              = (1D(16))
    START_FIELD_EXTENDED     = (00(16))
    NULL                     = (00(16))

    FIRST_ROW                = (20(16))
    FIRST_COLUMN             = (20(16))
    CURRENT_ROW              = (7E(16))
    CURRENT_COLUMN           = (7E(16))
    MAXIMUM_ROW              = (7F(16))
    MAXIMUM_COLUMN           = (7F(16))

    HOME                     = (FIRST_ROW    FIRST_COLUMN)
    START_OF_ROW             = (CURRENT_ROW  FIRST_COLUMN)
    END_OF_ROW               = (CURRENT_ROW  MAXIMUM_COLUMN)
    END_OF_PAGE              = (MAXIMUM_ROW  MAXIMUM_COLUMN)
    CURRENT_POSITION         = (CURRENT_ROW  CURRENT_COLUMN)

"   VARIABLES FOR FULL SCREEN EDITOR FUNCTION KEY DEFINITIONS                 "

    model_name               value = 'ibm_3270'
    application_string name=('driver_procedure') out=('tup$bootstrap_3270_driver')
    communications           type  = asynch
    end_of_information       in    = (0)
    cursor_pos_encoding      bias  = (0)    type = IBM3270_cursor
    cursor_pos_begin         in    = (set_buffer_address)
    cursor_pos_begin         out   = (set_buffer_address current_position)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = wrap_same_next
    move_past_bottom         type  = wrap_same_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next
    char_past_left           type  = wrap_adjacent_next
    char_past_last_position  type  = wrap_adjacent_next

"   TERMINAL ATTRIBUTES                                                       "
    automatic_tabbing        value = TRUE
    "block_mode               value = TRUE
    clears_when_change_size  value = FALSE
    function_key_leaves_mark value = 0
    has_hidden               value = TRUE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = FALSE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = FALSE

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80


"   SCREEN AND LINE MODE TRANSITION                                           "

"   TERMINAL CAPABILITIES                                                     "
    insert_char         in    = (7F(16) 7F(16) 01(16)) label='x'
    delete_char         in    = (7F(16) 7F(16) 02(16)) label='x'
    erase_end_of_line   out   = (repeat_to_address end_of_row null)
    erase_page_home     in    = (5F(16))               label='x'
    erase_page_home     out   = (set_buffer_address home repeat_to_address home null)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    output_begin        out = (31(16) 43(16) set_buffer_address home)
    output_end          out = (insert_cursor)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "

    f1        in = (31(16)) label = 'F1'
    f2        in = (32(16)) label = 'F2'
    f3        in = (33(16)) label = 'F3'
    f4        in = (34(16)) label = 'F4'
    f5        in = (35(16)) label = 'F5'
    f6        in = (36(16)) label = 'F6'
    f7        in = (37(16)) label = 'F7'
    f8        in = (38(16)) label = 'F8'
    f9        in = (39(16)) label = 'F9'
    f10       in = (3a(16)) label = '10'
    f11       in = (23(16)) label = '11'
    f12       in = (40(16)) label = '12'
    f1_s      in = (41(16)) label = '13'
    f2_s      in = (42(16)) label = '14'
    f3_s      in = (43(16)) label = '15'
    f4_s      in = (44(16)) label = '16'
    f5_s      in = (45(16)) label = '17'
    f6_s      in = (46(16)) label = '18'
    f7_s      in = (47(16)) label = '19'
    f8_s      in = (48(16)) label = '20'
    f9_s      in = (49(16)) label = '21'
    f10_s     in = (5B(16)) label = '22'
    f11_s     in = (2E(16)) label = '23'
    f12_s     in = (3C(16)) label = '24'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = (27(16)) label = 'NEXT'
    next_s    in = (3E(16)) label = 's-NEXT'
    bkw       in = (31(16)) label = 'F1'
    fwd       in = (32(16)) label = 'F2'
    back      in = (33(16)) label = 'F3'
    help      in = (34(16)) label = 'F4'
    undo      in = (35(16)) label = 'F5'
    stop      in = (36(16)) label = 'F6'
    bkw_s     in = (41(16)) label = '13'
    fwd_s     in = (42(16)) label = '14'
    undo_s    in = (45(16)) label = '17'
    stop_s    in = (46(16)) label = '18'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_field)
blink_begin         out = (start_field)
hidden_begin        out = (start_field)
inverse_begin       out = (start_field)
protect_begin       out = (start_field)
underline_begin     out = (start_field)
low_intensity_begin  out = (start_field)
high_intensity_begin out = (start_field)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_field 38(16))
    input_text_begin    out = (start_field 20(16))
    italic_begin        out = (start_field 38(16))
    message_begin       out = (start_field 38(16))
    output_text_begin   out = (start_field 34(16))
    title_begin         out = (start_field 34(16))

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = (null)
    ld_fine_end              out = (null)
    ld_fine_horizontal       out = ('-')
    ld_fine_vertical         out = ('|')
    ld_fine_upper_left       out = ('*')
    ld_fine_upper_right      out = ('*')
    ld_fine_lower_left       out = ('*')
    ld_fine_lower_right      out = ('*')
    ld_fine_up_t             out = ('*')
    ld_fine_down_t           out = ('*')
    ld_fine_left_t           out = ('*')
    ld_fine_right_t          out = ('*')
    ld_fine_cross            out = ('+')
    ld_medium_begin          out = (null)
    ld_medium_end            out = (null)
    ld_medium_horizontal     out = ('-')
    ld_medium_vertical       out = ('|')
    ld_medium_upper_left     out = ('*')
    ld_medium_upper_right    out = ('*')
    ld_medium_lower_left     out = ('*')
    ld_medium_lower_right    out = ('*')
    ld_medium_up_t           out = ('*')
    ld_medium_down_t         out = ('*')
    ld_medium_left_t         out = ('*')
    ld_medium_right_t        out = ('*')
    ld_medium_cross          out = ('+')
    ld_bold_begin            out = (null)
    ld_bold_end              out = (null)
    ld_bold_horizontal       out = ('-')
    ld_bold_vertical         out = ('|')
    ld_bold_upper_left       out = ('*')
    ld_bold_upper_right      out = ('*')
    ld_bold_lower_left       out = ('*')
    ld_bold_lower_right      out = ('*')
    ld_bold_up_t             out = ('*')
    ld_bold_down_t           out = ('*')
    ld_bold_left_t           out = ('*')
    ld_bold_right_t          out = ('*')
    ld_bold_cross            out = ('+')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR THE IBM 3270 TERMINAL                 "
*DECK DECK=CSM$IBM_3270_2 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR THE IBM 3270_2 TERMINAL                        "


"   VARIABLES                                                                 "
    ERASE_UNPROT_TO_ADDRESS  = (12(16))
    GRAPHIC_ESCAPE           = (00(16))
    INSERT_CURSOR            = (13(16))
    MODIFY_FIELD             = (00(16))
    PROGRAM_TAB              = (09(16))
    REPEAT_TO_ADDRESS        = (14(16))
    SET_ATTRIBUTE            = (00(16))
    SET_BUFFER_ADDRESS       = (11(16))
    START_FIELD              = (1D(16))
    START_FIELD_EXTENDED     = (00(16))
    NULL                     = (00(16))

    FIRST_ROW                = (20(16))
    FIRST_COLUMN             = (20(16))
    CURRENT_ROW              = (7E(16))
    CURRENT_COLUMN           = (7E(16))
    MAXIMUM_ROW              = (7F(16))
    MAXIMUM_COLUMN           = (7F(16))

    HOME                     = (FIRST_ROW    FIRST_COLUMN)
    START_OF_ROW             = (CURRENT_ROW  FIRST_COLUMN)
    END_OF_ROW               = (CURRENT_ROW  MAXIMUM_COLUMN)
    END_OF_PAGE              = (MAXIMUM_ROW  MAXIMUM_COLUMN)
    CURRENT_POSITION         = (CURRENT_ROW  CURRENT_COLUMN)

"   VARIABLES FOR FULL SCREEN EDITOR FUNCTION KEY DEFINITIONS                 "

    model_name               value = 'ibm_3270_2'
    application_string name=('driver_procedure') out=('tup$bootstrap_3270_driver')
    communications           type  = asynch
    end_of_information       in    = (0)
    cursor_pos_encoding      bias  = (0)    type = IBM3270_cursor
    cursor_pos_begin         in    = (set_buffer_address)
    cursor_pos_begin         out   = (set_buffer_address current_position)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = wrap_same_next
    move_past_bottom         type  = wrap_same_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next
    char_past_left           type  = wrap_adjacent_next
    char_past_last_position  type  = wrap_adjacent_next

"   TERMINAL ATTRIBUTES                                                       "
    automatic_tabbing        value = TRUE
    "block_mode               value = TRUE
    clears_when_change_size  value = FALSE
    function_key_leaves_mark value = 0
    has_hidden               value = TRUE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = FALSE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = FALSE

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80


"   SCREEN AND LINE MODE TRANSITION                                           "

"   TERMINAL CAPABILITIES                                                     "
    insert_char         in    = (7F(16) 7F(16) 01(16)) label='x'
    delete_char         in    = (7F(16) 7F(16) 02(16)) label='x'
    erase_end_of_line   out   = (repeat_to_address end_of_row null)
    erase_page_home     in    = (5F(16))               label='x'
    erase_page_home     out   = (set_buffer_address home repeat_to_address home null)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    output_begin        out = (31(16) 43(16) set_buffer_address home)
    output_end          out = (insert_cursor)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "

    f1        in = (31(16)) label = 'F1'
    f2        in = (32(16)) label = 'F2'
    f3        in = (33(16)) label = 'F3'
    f4        in = (34(16)) label = 'F4'
    f5        in = (35(16)) label = 'F5'
    f6        in = (36(16)) label = 'F6'
    f7        in = (37(16)) label = 'F7'
    f8        in = (38(16)) label = 'F8'
    f9        in = (39(16)) label = 'F9'
    f10       in = (3a(16)) label = '10'
    f11       in = (23(16)) label = '11'
    f12       in = (40(16)) label = '12'
    f1_s      in = (41(16)) label = '13'
    f2_s      in = (42(16)) label = '14'
    f3_s      in = (43(16)) label = '15'
    f4_s      in = (44(16)) label = '16'
    f5_s      in = (45(16)) label = '17'
    f6_s      in = (46(16)) label = '18'
    f7_s      in = (47(16)) label = '19'
    f8_s      in = (48(16)) label = '20'
    f9_s      in = (49(16)) label = '21'
    f10_s     in = (5B(16)) label = '22'
    f11_s     in = (2E(16)) label = '23'
    f12_s     in = (3C(16)) label = '24'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = (27(16)) label = 'NEXT'
    next_s    in = (3E(16)) label = 's-NEXT'
    bkw       in = (31(16)) label = 'F1'
    fwd       in = (32(16)) label = 'F2'
    back      in = (33(16)) label = 'F3'
    help      in = (34(16)) label = 'F4'
    undo      in = (35(16)) label = 'F5'
    stop      in = (36(16)) label = 'F6'
    bkw_s     in = (41(16)) label = '13'
    fwd_s     in = (42(16)) label = '14'
    undo_s    in = (45(16)) label = '17'
    stop_s    in = (46(16)) label = '18'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_field)
blink_begin         out = (start_field)
hidden_begin        out = (start_field)
inverse_begin       out = (start_field)
protect_begin       out = (start_field)
underline_begin     out = (start_field)
low_intensity_begin  out = (start_field)
high_intensity_begin out = (start_field)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_field 38(16))
    input_text_begin    out = (start_field 20(16))
    italic_begin        out = (start_field 38(16))
    message_begin       out = (start_field 38(16))
    output_text_begin   out = (start_field 34(16))
    title_begin         out = (start_field 34(16))

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = ()
    ld_fine_end              out = ()
    ld_fine_horizontal       out = ('-')
    ld_fine_vertical         out = ('|')
    ld_fine_upper_left       out = ('*')
    ld_fine_upper_right      out = ('*')
    ld_fine_lower_left       out = ('*')
    ld_fine_lower_right      out = ('*')
    ld_fine_up_t             out = ('*')
    ld_fine_down_t           out = ('*')
    ld_fine_left_t           out = ('*')
    ld_fine_right_t          out = ('*')
    ld_fine_cross            out = ('+')
    ld_medium_begin          out = ()
    ld_medium_end            out = ()
    ld_medium_horizontal     out = ('-')
    ld_medium_vertical       out = ('|')
    ld_medium_upper_left     out = ('*')
    ld_medium_upper_right    out = ('*')
    ld_medium_lower_left     out = ('*')
    ld_medium_lower_right    out = ('*')
    ld_medium_up_t           out = ('*')
    ld_medium_down_t         out = ('*')
    ld_medium_left_t         out = ('*')
    ld_medium_right_t        out = ('*')
    ld_medium_cross          out = ('+')
    ld_bold_begin            out = ()
    ld_bold_end              out = ()
    ld_bold_horizontal       out = ('-')
    ld_bold_vertical         out = ('|')
    ld_bold_upper_left       out = ('*')
    ld_bold_upper_right      out = ('*')
    ld_bold_lower_left       out = ('*')
    ld_bold_lower_right      out = ('*')
    ld_bold_up_t             out = ('*')
    ld_bold_down_t           out = ('*')
    ld_bold_left_t           out = ('*')
    ld_bold_right_t          out = ('*')
    ld_bold_cross            out = ('+')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR THE IBM 3270_2 TERMINAL                 "
*DECK DECK=CSM$IBM_3270_3 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR THE IBM 3270_3 TERMINAL                        "

"   VARIABLES                                                                 "
    ERASE_UNPROT_TO_ADDRESS  = (12(16))
    GRAPHIC_ESCAPE           = (00(16))
    INSERT_CURSOR            = (13(16))
    MODIFY_FIELD             = (00(16))
    PROGRAM_TAB              = (09(16))
    REPEAT_TO_ADDRESS        = (14(16))
    SET_ATTRIBUTE            = (00(16))
    SET_BUFFER_ADDRESS       = (11(16))
    START_FIELD              = (1D(16))
    START_FIELD_EXTENDED     = (00(16))
    NULL                     = (00(16))

    FIRST_ROW                = (20(16))
    FIRST_COLUMN             = (20(16))
    CURRENT_ROW              = (7E(16))
    CURRENT_COLUMN           = (7E(16))
    MAXIMUM_ROW              = (7F(16))
    MAXIMUM_COLUMN           = (7F(16))

    HOME                     = (FIRST_ROW    FIRST_COLUMN)
    START_OF_ROW             = (CURRENT_ROW  FIRST_COLUMN)
    END_OF_ROW               = (CURRENT_ROW  MAXIMUM_COLUMN)
    END_OF_PAGE              = (MAXIMUM_ROW  MAXIMUM_COLUMN)
    CURRENT_POSITION         = (CURRENT_ROW  CURRENT_COLUMN)

"   VARIABLES FOR FULL SCREEN EDITOR FUNCTION KEY DEFINITIONS                 "

    model_name               value = 'ibm_3270_3'
    application_string name=('driver_procedure') out=('tup$bootstrap_3270_driver')
    communications           type  = asynch
    end_of_information       in    = (0)
    cursor_pos_encoding      bias  = (0)    type = IBM3270_cursor
    cursor_pos_begin         in    = (set_buffer_address)
    cursor_pos_begin         out   = (set_buffer_address current_position)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = wrap_same_next
    move_past_bottom         type  = wrap_same_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next
    char_past_left           type  = wrap_adjacent_next
    char_past_last_position  type  = wrap_adjacent_next

"   TERMINAL ATTRIBUTES                                                       "
    automatic_tabbing        value = TRUE
    "block_mode               value = TRUE
    clears_when_change_size  value = FALSE
    function_key_leaves_mark value = 0
    has_hidden               value = TRUE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = FALSE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = FALSE

"   SCREEN SIZES                                                              "
    set_size       rows = 32 columns = 80


"   SCREEN AND LINE MODE TRANSITION                                           "

"   TERMINAL CAPABILITIES                                                     "
    insert_char         in    = (7F(16) 7F(16) 01(16)) label='x'
    delete_char         in    = (7F(16) 7F(16) 02(16)) label='x'
    erase_end_of_line   out   = (repeat_to_address end_of_row null)
    erase_page_home     in    = (5F(16))               label='x'
    erase_page_home     out   = (set_buffer_address home repeat_to_address home null)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    output_begin        out = (31(16) 43(16) set_buffer_address home)
    output_end          out = (insert_cursor)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "

    f1        in = (31(16)) label = 'F1'
    f2        in = (32(16)) label = 'F2'
    f3        in = (33(16)) label = 'F3'
    f4        in = (34(16)) label = 'F4'
    f5        in = (35(16)) label = 'F5'
    f6        in = (36(16)) label = 'F6'
    f7        in = (37(16)) label = 'F7'
    f8        in = (38(16)) label = 'F8'
    f9        in = (39(16)) label = 'F9'
    f10       in = (3a(16)) label = '10'
    f11       in = (23(16)) label = '11'
    f12       in = (40(16)) label = '12'
    f1_s      in = (41(16)) label = '13'
    f2_s      in = (42(16)) label = '14'
    f3_s      in = (43(16)) label = '15'
    f4_s      in = (44(16)) label = '16'
    f5_s      in = (45(16)) label = '17'
    f6_s      in = (46(16)) label = '18'
    f7_s      in = (47(16)) label = '19'
    f8_s      in = (48(16)) label = '20'
    f9_s      in = (49(16)) label = '21'
    f10_s     in = (5B(16)) label = '22'
    f11_s     in = (2E(16)) label = '23'
    f12_s     in = (3C(16)) label = '24'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = (27(16)) label = 'NEXT'
    next_s    in = (3E(16)) label = 's-NEXT'
    bkw       in = (31(16)) label = 'F1'
    fwd       in = (32(16)) label = 'F2'
    back      in = (33(16)) label = 'F3'
    help      in = (34(16)) label = 'F4'
    undo      in = (35(16)) label = 'F5'
    stop      in = (36(16)) label = 'F6'
    bkw_s     in = (41(16)) label = '13'
    fwd_s     in = (42(16)) label = '14'
    undo_s    in = (45(16)) label = '17'
    stop_s    in = (46(16)) label = '18'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_field)
blink_begin         out = (start_field)
hidden_begin        out = (start_field)
inverse_begin       out = (start_field)
protect_begin       out = (start_field)
underline_begin     out = (start_field)
low_intensity_begin  out = (start_field)
high_intensity_begin out = (start_field)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_field 38(16))
    input_text_begin    out = (start_field 20(16))
    italic_begin        out = (start_field 38(16))
    message_begin       out = (start_field 38(16))
    output_text_begin   out = (start_field 34(16))
    title_begin         out = (start_field 34(16))

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = ()
    ld_fine_end              out = ()
    ld_fine_horizontal       out = ('-')
    ld_fine_vertical         out = ('|')
    ld_fine_upper_left       out = ('*')
    ld_fine_upper_right      out = ('*')
    ld_fine_lower_left       out = ('*')
    ld_fine_lower_right      out = ('*')
    ld_fine_up_t             out = ('*')
    ld_fine_down_t           out = ('*')
    ld_fine_left_t           out = ('*')
    ld_fine_right_t          out = ('*')
    ld_fine_cross            out = ('+')
    ld_medium_begin          out = ()
    ld_medium_end            out = ()
    ld_medium_horizontal     out = ('-')
    ld_medium_vertical       out = ('|')
    ld_medium_upper_left     out = ('*')
    ld_medium_upper_right    out = ('*')
    ld_medium_lower_left     out = ('*')
    ld_medium_lower_right    out = ('*')
    ld_medium_up_t           out = ('*')
    ld_medium_down_t         out = ('*')
    ld_medium_left_t         out = ('*')
    ld_medium_right_t        out = ('*')
    ld_medium_cross          out = ('+')
    ld_bold_begin            out = ()
    ld_bold_end              out = ()
    ld_bold_horizontal       out = ('-')
    ld_bold_vertical         out = ('|')
    ld_bold_upper_left       out = ('*')
    ld_bold_upper_right      out = ('*')
    ld_bold_lower_left       out = ('*')
    ld_bold_lower_right      out = ('*')
    ld_bold_up_t             out = ('*')
    ld_bold_down_t           out = ('*')
    ld_bold_left_t           out = ('*')
    ld_bold_right_t          out = ('*')
    ld_bold_cross            out = ('+')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR THE IBM 3270_3 TERMINAL                 "
*DECK DECK=CSM$IBM_3270_4 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR THE IBM 3270_4 TERMINAL                        "

"   VARIABLES                                                                 "
    ERASE_UNPROT_TO_ADDRESS  = (12(16))
    GRAPHIC_ESCAPE           = (00(16))
    INSERT_CURSOR            = (13(16))
    MODIFY_FIELD             = (00(16))
    PROGRAM_TAB              = (09(16))
    REPEAT_TO_ADDRESS        = (14(16))
    SET_ATTRIBUTE            = (00(16))
    SET_BUFFER_ADDRESS       = (11(16))
    START_FIELD              = (1D(16))
    START_FIELD_EXTENDED     = (00(16))
    NULL                     = (00(16))

    FIRST_ROW                = (20(16))
    FIRST_COLUMN             = (20(16))
    CURRENT_ROW              = (7E(16))
    CURRENT_COLUMN           = (7E(16))
    MAXIMUM_ROW              = (7F(16))
    MAXIMUM_COLUMN           = (7F(16))

    HOME                     = (FIRST_ROW    FIRST_COLUMN)
    START_OF_ROW             = (CURRENT_ROW  FIRST_COLUMN)
    END_OF_ROW               = (CURRENT_ROW  MAXIMUM_COLUMN)
    END_OF_PAGE              = (MAXIMUM_ROW  MAXIMUM_COLUMN)
    CURRENT_POSITION         = (CURRENT_ROW  CURRENT_COLUMN)

"   VARIABLES FOR FULL SCREEN EDITOR FUNCTION KEY DEFINITIONS                 "

    model_name               value = 'ibm_3270_4'
    application_string name=('driver_procedure') out=('tup$bootstrap_3270_driver')
    communications           type  = asynch
    end_of_information       in    = (0)
    cursor_pos_encoding      bias  = (0)    type = IBM3270_cursor
    cursor_pos_begin         in    = (set_buffer_address)
    cursor_pos_begin         out   = (set_buffer_address current_position)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = wrap_same_next
    move_past_bottom         type  = wrap_same_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next
    char_past_left           type  = wrap_adjacent_next
    char_past_last_position  type  = wrap_adjacent_next

"   TERMINAL ATTRIBUTES                                                       "
    automatic_tabbing        value = TRUE
    "block_mode               value = TRUE
    clears_when_change_size  value = FALSE
    function_key_leaves_mark value = 0
    has_hidden               value = TRUE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = FALSE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = FALSE

"   SCREEN SIZES                                                              "
    set_size       rows = 43 columns = 80

"   SCREEN AND LINE MODE TRANSITION                                           "

"   TERMINAL CAPABILITIES                                                     "
    insert_char         in    = (7F(16) 7F(16) 01(16)) label='x'
    delete_char         in    = (7F(16) 7F(16) 02(16)) label='x'
    erase_end_of_line   out   = (repeat_to_address end_of_row null)
    erase_page_home     in    = (5F(16))               label='x'
    erase_page_home     out   = (set_buffer_address home repeat_to_address home null)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    output_begin        out = (31(16) 43(16) set_buffer_address home)
    output_end          out = (insert_cursor)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "

    f1        in = (31(16)) label = 'F1'
    f2        in = (32(16)) label = 'F2'
    f3        in = (33(16)) label = 'F3'
    f4        in = (34(16)) label = 'F4'
    f5        in = (35(16)) label = 'F5'
    f6        in = (36(16)) label = 'F6'
    f7        in = (37(16)) label = 'F7'
    f8        in = (38(16)) label = 'F8'
    f9        in = (39(16)) label = 'F9'
    f10       in = (3a(16)) label = '10'
    f11       in = (23(16)) label = '11'
    f12       in = (40(16)) label = '12'
    f1_s      in = (41(16)) label = '13'
    f2_s      in = (42(16)) label = '14'
    f3_s      in = (43(16)) label = '15'
    f4_s      in = (44(16)) label = '16'
    f5_s      in = (45(16)) label = '17'
    f6_s      in = (46(16)) label = '18'
    f7_s      in = (47(16)) label = '19'
    f8_s      in = (48(16)) label = '20'
    f9_s      in = (49(16)) label = '21'
    f10_s     in = (5B(16)) label = '22'
    f11_s     in = (2E(16)) label = '23'
    f12_s     in = (3C(16)) label = '24'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = (27(16)) label = 'NEXT'
    next_s    in = (3E(16)) label = 's-NEXT'
    bkw       in = (31(16)) label = 'F1'
    fwd       in = (32(16)) label = 'F2'
    back      in = (33(16)) label = 'F3'
    help      in = (34(16)) label = 'F4'
    undo      in = (35(16)) label = 'F5'
    stop      in = (36(16)) label = 'F6'
    bkw_s     in = (41(16)) label = '13'
    fwd_s     in = (42(16)) label = '14'
    undo_s    in = (45(16)) label = '17'
    stop_s    in = (46(16)) label = '18'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_field)
blink_begin         out = (start_field)
hidden_begin        out = (start_field)
inverse_begin       out = (start_field)
protect_begin       out = (start_field)
underline_begin     out = (start_field)
low_intensity_begin  out = (start_field)
high_intensity_begin out = (start_field)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_field 38(16))
    input_text_begin    out = (start_field 20(16))
    italic_begin        out = (start_field 38(16))
    message_begin       out = (start_field 38(16))
    output_text_begin   out = (start_field 34(16))
    title_begin         out = (start_field 34(16))

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = ()
    ld_fine_end              out = ()
    ld_fine_horizontal       out = ('-')
    ld_fine_vertical         out = ('|')
    ld_fine_upper_left       out = ('*')
    ld_fine_upper_right      out = ('*')
    ld_fine_lower_left       out = ('*')
    ld_fine_lower_right      out = ('*')
    ld_fine_up_t             out = ('*')
    ld_fine_down_t           out = ('*')
    ld_fine_left_t           out = ('*')
    ld_fine_right_t          out = ('*')
    ld_fine_cross            out = ('+')
    ld_medium_begin          out = ()
    ld_medium_end            out = ()
    ld_medium_horizontal     out = ('-')
    ld_medium_vertical       out = ('|')
    ld_medium_upper_left     out = ('*')
    ld_medium_upper_right    out = ('*')
    ld_medium_lower_left     out = ('*')
    ld_medium_lower_right    out = ('*')
    ld_medium_up_t           out = ('*')
    ld_medium_down_t         out = ('*')
    ld_medium_left_t         out = ('*')
    ld_medium_right_t        out = ('*')
    ld_medium_cross          out = ('+')
    ld_bold_begin            out = ()
    ld_bold_end              out = ()
    ld_bold_horizontal       out = ('-')
    ld_bold_vertical         out = ('|')
    ld_bold_upper_left       out = ('*')
    ld_bold_upper_right      out = ('*')
    ld_bold_lower_left       out = ('*')
    ld_bold_lower_right      out = ('*')
    ld_bold_up_t             out = ('*')
    ld_bold_down_t           out = ('*')
    ld_bold_left_t           out = ('*')
    ld_bold_right_t          out = ('*')
    ld_bold_cross            out = ('+')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR THE IBM 3270_4 TERMINAL                 "
*DECK DECK=CSM$IBM_3270_5 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR THE IBM 3270_5 TERMINAL                        "


"   VARIABLES                                                                 "
    ERASE_UNPROT_TO_ADDRESS  = (12(16))
    GRAPHIC_ESCAPE           = (00(16))
    INSERT_CURSOR            = (13(16))
    MODIFY_FIELD             = (00(16))
    PROGRAM_TAB              = (09(16))
    REPEAT_TO_ADDRESS        = (14(16))
    SET_ATTRIBUTE            = (00(16))
    SET_BUFFER_ADDRESS       = (11(16))
    START_FIELD              = (1D(16))
    START_FIELD_EXTENDED     = (00(16))
    NULL                     = (00(16))

    FIRST_ROW                = (20(16))
    FIRST_COLUMN             = (20(16))
    CURRENT_ROW              = (7E(16))
    CURRENT_COLUMN           = (7E(16))
    MAXIMUM_ROW              = (7F(16))
    MAXIMUM_COLUMN           = (7F(16))

    HOME                     = (FIRST_ROW    FIRST_COLUMN)
    START_OF_ROW             = (CURRENT_ROW  FIRST_COLUMN)
    END_OF_ROW               = (CURRENT_ROW  MAXIMUM_COLUMN)
    END_OF_PAGE              = (MAXIMUM_ROW  MAXIMUM_COLUMN)
    CURRENT_POSITION         = (CURRENT_ROW  CURRENT_COLUMN)

"   VARIABLES FOR FULL SCREEN EDITOR FUNCTION KEY DEFINITIONS                 "

    model_name               value = 'ibm_3270_5'
    application_string name=('driver_procedure') out=('tup$bootstrap_3270_driver')
    communications           type  = asynch
    end_of_information       in    = (0)
    cursor_pos_encoding      bias  = (0)    type = IBM3270_cursor
    cursor_pos_begin         in    = (set_buffer_address)
    cursor_pos_begin         out   = (set_buffer_address current_position)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = wrap_same_next
    move_past_bottom         type  = wrap_same_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next
    char_past_left           type  = wrap_adjacent_next
    char_past_last_position  type  = wrap_adjacent_next

"   TERMINAL ATTRIBUTES                                                       "
    automatic_tabbing        value = TRUE
    "block_mode               value = TRUE
    clears_when_change_size  value = FALSE
    function_key_leaves_mark value = 0
    has_hidden               value = TRUE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = FALSE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = FALSE

"   SCREEN SIZES                                                              "
    set_size       rows = 27 columns = 132

"   SCREEN AND LINE MODE TRANSITION                                           "

"   TERMINAL CAPABILITIES                                                     "
    insert_char         in    = (7F(16) 7F(16) 01(16)) label='x'
    delete_char         in    = (7F(16) 7F(16) 02(16)) label='x'
    erase_end_of_line   out   = (repeat_to_address end_of_row null)
    erase_page_home     in    = (5F(16))               label='x'
    erase_page_home     out   = (set_buffer_address home repeat_to_address home null)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    output_begin        out = (31(16) 43(16) set_buffer_address home)
    output_end          out = (insert_cursor)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "

    f1        in = (31(16)) label = 'F1'
    f2        in = (32(16)) label = 'F2'
    f3        in = (33(16)) label = 'F3'
    f4        in = (34(16)) label = 'F4'
    f5        in = (35(16)) label = 'F5'
    f6        in = (36(16)) label = 'F6'
    f7        in = (37(16)) label = 'F7'
    f8        in = (38(16)) label = 'F8'
    f9        in = (39(16)) label = 'F9'
    f10       in = (3a(16)) label = '10'
    f11       in = (23(16)) label = '11'
    f12       in = (40(16)) label = '12'
    f1_s      in = (41(16)) label = '13'
    f2_s      in = (42(16)) label = '14'
    f3_s      in = (43(16)) label = '15'
    f4_s      in = (44(16)) label = '16'
    f5_s      in = (45(16)) label = '17'
    f6_s      in = (46(16)) label = '18'
    f7_s      in = (47(16)) label = '19'
    f8_s      in = (48(16)) label = '20'
    f9_s      in = (49(16)) label = '21'
    f10_s     in = (5B(16)) label = '22'
    f11_s     in = (2E(16)) label = '23'
    f12_s     in = (3C(16)) label = '24'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = (27(16)) label = 'NEXT'
    next_s    in = (3E(16)) label = 's-NEXT'
    bkw       in = (31(16)) label = 'F1'
    fwd       in = (32(16)) label = 'F2'
    back      in = (33(16)) label = 'F3'
    help      in = (34(16)) label = 'F4'
    undo      in = (35(16)) label = 'F5'
    stop      in = (36(16)) label = 'F6'
    bkw_s     in = (41(16)) label = '13'
    fwd_s     in = (42(16)) label = '14'
    undo_s    in = (45(16)) label = '17'
    stop_s    in = (46(16)) label = '18'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_field)
blink_begin         out = (start_field)
hidden_begin        out = (start_field)
inverse_begin       out = (start_field)
protect_begin       out = (start_field)
underline_begin     out = (start_field)
low_intensity_begin  out = (start_field)
high_intensity_begin out = (start_field)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_field 38(16))
    input_text_begin    out = (start_field 20(16))
    italic_begin        out = (start_field 38(16))
    message_begin       out = (start_field 38(16))
    output_text_begin   out = (start_field 34(16))
    title_begin         out = (start_field 34(16))

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = ()
    ld_fine_end              out = ()
    ld_fine_horizontal       out = ('-')
    ld_fine_vertical         out = ('|')
    ld_fine_upper_left       out = ('*')
    ld_fine_upper_right      out = ('*')
    ld_fine_lower_left       out = ('*')
    ld_fine_lower_right      out = ('*')
    ld_fine_up_t             out = ('*')
    ld_fine_down_t           out = ('*')
    ld_fine_left_t           out = ('*')
    ld_fine_right_t          out = ('*')
    ld_fine_cross            out = ('+')
    ld_medium_begin          out = ()
    ld_medium_end            out = ()
    ld_medium_horizontal     out = ('-')
    ld_medium_vertical       out = ('|')
    ld_medium_upper_left     out = ('*')
    ld_medium_upper_right    out = ('*')
    ld_medium_lower_left     out = ('*')
    ld_medium_lower_right    out = ('*')
    ld_medium_up_t           out = ('*')
    ld_medium_down_t         out = ('*')
    ld_medium_left_t         out = ('*')
    ld_medium_right_t        out = ('*')
    ld_medium_cross          out = ('+')
    ld_bold_begin            out = ()
    ld_bold_end              out = ()
    ld_bold_horizontal       out = ('-')
    ld_bold_vertical         out = ('|')
    ld_bold_upper_left       out = ('*')
    ld_bold_upper_right      out = ('*')
    ld_bold_lower_left       out = ('*')
    ld_bold_lower_right      out = ('*')
    ld_bold_up_t             out = ('*')
    ld_bold_down_t           out = ('*')
    ld_bold_left_t           out = ('*')
    ld_bold_right_t          out = ('*')
    ld_bold_cross            out = ('+')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR THE IBM 3270_5 TERMINAL                 "
*DECK DECK=CSM$IBM_3270_FULL_WIDTH_INPUT EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR THE IBM 3270 TERMINAL                        "

" Note:  this definition is identical to IBM_3270 except for:

" the addition of the application string statement to invoke a special device
"   driver

" the removal of the fake key definitions for insert and delete characters

" the usage of blank padding instead of null padding in erase EOL

" For the user, the net effect is that this definition allows applications to
"   define input fields all the way into column 80 and spanning multiple rows.
"   However, the user cannot use the hard-editing key for character insertion,
"   and usage of the hard-editing key for character deletion will cause the
"   serious side-effect of wrapping and snaking text from the left hand columns
"   of lower rows up to the right hand columns of upper rows.  Edit_File will
"   instead offer function keys to simulate character inserts and deletes.

"   VARIABLES                                                                 "
    ERASE_UNPROT_TO_ADDRESS  = (12(16))
    GRAPHIC_ESCAPE           = (00(16))
    INSERT_CURSOR            = (13(16))
    MODIFY_FIELD             = (00(16))
    PROGRAM_TAB              = (09(16))
    REPEAT_TO_ADDRESS        = (14(16))
    SET_ATTRIBUTE            = (00(16))
    SET_BUFFER_ADDRESS       = (11(16))
    START_FIELD              = (1D(16))
    START_FIELD_EXTENDED     = (00(16))
    NULL                     = (00(16))

    FIRST_ROW                = (20(16))
    FIRST_COLUMN             = (20(16))
    CURRENT_ROW              = (7E(16))
    CURRENT_COLUMN           = (7E(16))
    MAXIMUM_ROW              = (7F(16))
    MAXIMUM_COLUMN           = (7F(16))

    HOME                     = (FIRST_ROW    FIRST_COLUMN)
    START_OF_ROW             = (CURRENT_ROW  FIRST_COLUMN)
    END_OF_ROW               = (CURRENT_ROW  MAXIMUM_COLUMN)
    END_OF_PAGE              = (MAXIMUM_ROW  MAXIMUM_COLUMN)
    CURRENT_POSITION         = (CURRENT_ROW  CURRENT_COLUMN)

"   VARIABLES FOR FULL SCREEN EDITOR FUNCTION KEY DEFINITIONS                 "

    model_name               value = 'ibm_3270_full_width_input'
    application_string name=('driver_procedure') out=('tup$boot_3270_full_width_input')
    communications           type  = asynch
    end_of_information       in    = (0)
    cursor_pos_encoding      bias  = (0)    type = IBM3270_cursor
    cursor_pos_begin         in    = (set_buffer_address)
    cursor_pos_begin         out   = (set_buffer_address current_position)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = wrap_same_next
    move_past_bottom         type  = wrap_same_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next
    char_past_left           type  = wrap_adjacent_next
    char_past_last_position  type  = wrap_adjacent_next

"   TERMINAL ATTRIBUTES                                                       "
    automatic_tabbing        value = TRUE
    "block_mode               value = TRUE
    clears_when_change_size  value = FALSE
    function_key_leaves_mark value = 0
    has_hidden               value = TRUE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = FALSE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = FALSE

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80


"   SCREEN AND LINE MODE TRANSITION                                           "

"   TERMINAL CAPABILITIES                                                     "
    erase_end_of_line   out   = (repeat_to_address end_of_row ' ' )
    erase_page_home     in    = (5F(16))               label='x'
    erase_page_home     out   = (set_buffer_address home repeat_to_address home ' ' )

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    output_begin        out = (31(16) 43(16) set_buffer_address home)
    output_end          out = (insert_cursor)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "

    f1        in = (31(16)) label = 'F1'
    f2        in = (32(16)) label = 'F2'
    f3        in = (33(16)) label = 'F3'
    f4        in = (34(16)) label = 'F4'
    f5        in = (35(16)) label = 'F5'
    f6        in = (36(16)) label = 'F6'
    f7        in = (37(16)) label = 'F7'
    f8        in = (38(16)) label = 'F8'
    f9        in = (39(16)) label = 'F9'
    f10       in = (3a(16)) label = '10'
    f11       in = (23(16)) label = '11'
    f12       in = (40(16)) label = '12'
    f1_s      in = (41(16)) label = '13'
    f2_s      in = (42(16)) label = '14'
    f3_s      in = (43(16)) label = '15'
    f4_s      in = (44(16)) label = '16'
    f5_s      in = (45(16)) label = '17'
    f6_s      in = (46(16)) label = '18'
    f7_s      in = (47(16)) label = '19'
    f8_s      in = (48(16)) label = '20'
    f9_s      in = (49(16)) label = '21'
    f10_s     in = (5B(16)) label = '22'
    f11_s     in = (2E(16)) label = '23'
    f12_s     in = (3C(16)) label = '24'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = (27(16)) label = 'NEXT'
    next_s    in = (3E(16)) label = 's-NEXT'
    bkw       in = (31(16)) label = 'F1'
    fwd       in = (32(16)) label = 'F2'
    back      in = (33(16)) label = 'F3'
    help      in = (34(16)) label = 'F4'
    undo      in = (35(16)) label = 'F5'
    stop      in = (36(16)) label = 'F6'
    bkw_s     in = (41(16)) label = '13'
    fwd_s     in = (42(16)) label = '14'
    undo_s    in = (45(16)) label = '17'
    stop_s    in = (46(16)) label = '18'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_field)
blink_begin         out = (start_field)
hidden_begin        out = (start_field)
inverse_begin       out = (start_field)
protect_begin       out = (start_field)
underline_begin     out = (start_field)
low_intensity_begin  out = (start_field)
high_intensity_begin out = (start_field)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_field 38(16))
    input_text_begin    out = (start_field 20(16))
    italic_begin        out = (start_field 38(16))
    message_begin       out = (start_field 38(16))
    output_text_begin   out = (start_field 34(16))
    title_begin         out = (start_field 34(16))

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = (null)
    ld_fine_end              out = (null)
    ld_fine_horizontal       out = ('-')
    ld_fine_vertical         out = ('|')
    ld_fine_upper_left       out = ('*')
    ld_fine_upper_right      out = ('*')
    ld_fine_lower_left       out = ('*')
    ld_fine_lower_right      out = ('*')
    ld_fine_up_t             out = ('*')
    ld_fine_down_t           out = ('*')
    ld_fine_left_t           out = ('*')
    ld_fine_right_t          out = ('*')
    ld_fine_cross            out = ('+')
    ld_medium_begin          out = (null)
    ld_medium_end            out = (null)
    ld_medium_horizontal     out = ('-')
    ld_medium_vertical       out = ('|')
    ld_medium_upper_left     out = ('*')
    ld_medium_upper_right    out = ('*')
    ld_medium_lower_left     out = ('*')
    ld_medium_lower_right    out = ('*')
    ld_medium_up_t           out = ('*')
    ld_medium_down_t         out = ('*')
    ld_medium_left_t         out = ('*')
    ld_medium_right_t        out = ('*')
    ld_medium_cross          out = ('+')
    ld_bold_begin            out = (null)
    ld_bold_end              out = (null)
    ld_bold_horizontal       out = ('-')
    ld_bold_vertical         out = ('|')
    ld_bold_upper_left       out = ('*')
    ld_bold_upper_right      out = ('*')
    ld_bold_lower_left       out = ('*')
    ld_bold_lower_right      out = ('*')
    ld_bold_up_t             out = ('*')
    ld_bold_down_t           out = ('*')
    ld_bold_left_t           out = ('*')
    ld_bold_right_t          out = ('*')
    ld_bold_cross            out = ('+')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR THE IBM 3270 TERMINAL                 "

*DECK DECK=CSM$MAC_CONNECT_10 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR MAC_CONNECT_10  VERSION 1.0   APRIL 14, 1986 "
"                                                                             "
"   NOS/VE TERMINAL DEFINITION FILE FOR Macintosh using Control Data Connect  "
"   (basic VT100 plus function key definitions).  Connect should be run with  "
"   local echo on or echoplex for the insert/delete functions to work.        "
"   Important Terminal... and Compatiblity... settings in Connect are:        "
"     Repeat Ctrls           OFF                                              "
"     New Line               OFF                                              "
"     Auto Wraparound        ON                                               "
"     XON/XOFF Flow Control  ON                                               "
"   If Auto Wraparound is OFF, make the following change:                     "
"     char_past_right          type = stop_next                               "
"     char_past_last_position  type = stop_next                               "
"                                                                             "

"   VARIABLES                                                                 "
    prefix              = (esc 5B(16))
    clear_stay          = (prefix 32(16) 4A(16))
    clear_all_tabs      = (prefix 33(16) 67(16))
    set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))
    set_to_24x132       = (prefix 3F(16) 33(16) 68(16))
    start_alternate     = (prefix 31(16) 6D(16))
    start_blink         = (prefix 35(16) 6D(16))
    start_inverse       = (prefix 37(16) 6D(16))
    start_underline     = (prefix 34(16) 6D(16))
    stop_alternate      = (prefix 6D(16))
    stop_blink          = (prefix 6D(16))
    stop_inverse        = (prefix 6D(16))
    stop_underline      = (prefix 6D(16))

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'MAC_CONNECT_10'
    communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix)
    cursor_pos_second        out   = (3B(16))
    cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (prefix 48(16)) label='Option H'
    cursor_up                inout = (prefix 41(16)) label='Option I'
    cursor_down              inout = (prefix 42(16)) label='Option M'
    cursor_left              inout = (prefix 44(16)) label='Option K'
    cursor_right             inout = (prefix 43(16)) label='Option J'

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = stop_next
    move_past_left           type  = stop_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next
    char_past_left           type  = stop_next
    char_past_last_position  type  = scroll_next

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 0                  "for MAC"
    has_hidden               value = FALSE
    has_protect              value = FALSE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = TRUE

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80   out = (set_to_24x80)
    set_size       rows = 24 columns = 132  out = (set_to_24x132)

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode     out = (esc 3C(16) clear_all_tabs ..
         esc 28(16) 42(16) esc 29(16) 30(16) 0F(16) esc ..
         3D(16))

    set_line_mode       out = (esc 3C(16) clear_all_tabs ..
         esc 28(16) 42(16) esc 29(16) 30(16) 0F(16) esc ..
         3E(16))

"   TERMINAL CAPABILITIES                                                    "
    insert_char         inout = (prefix '@') label='Option Space'
    delete_char         inout = (prefix 'P') label='Option Backspace'
    delete_line_bol     inout = (prefix 'M') label='Option Shift Backspace'
    insert_line_bol     inout = (prefix 'L') label='Option Shift Space'
    erase_end_of_line   inout = (prefix 'K') label='Option C'
    erase_line_stay     inout = (prefix '2K')
    erase_page_stay     inout = (clear_stay) label='Option Shift C'
    backspace           in = (08(16))
    tab_forward         inout = (09(16))
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (esc 48(16))

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    output_begin        out = (prefix 34(16) 6C(16))
    bell_nak            out = (bel)

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = (CR)           label='Return'
    next_s    in = (ESC CR)       label='Shift Return'
    data      in = (ESC 27(16))   label='Option "'
    data_s    in = (ESC '"')      label='Option Shift "'
    back      in = (ESC ';')      label='Option ;'
    back_s    in = (ESC ':')      label='Option Shift ;'
    help      in = (ESC '/')      label='Option ?'
    help_s    in = (ESC '?')      label='Option Shift ?'
    edit      in = (ESC '.')      label='Option .'
    edit_s    in = (ESC 'n')      label='Option Shift .'
    down      in = (ESC 'd')      label='Option D'
    down_s    in = (ESC 'm')      label='Option Shift D'
    up        in = (ESC 'u')      label='Option U'
    up_s      in = (ESC 'U')      label='Option Shift U'
    fwd       in = (ESC 'f')      label='Option F'
    fwd_s     in = (ESC 'F')      label='Option Shift F'
    bkw       in = (ESC 'b')      label='Option B'
    bkw_s     in = (ESC 'B')      label='Option Shift B'
    undo      in = (ESC '5') label='f5  Option 5'
    stop      in = (ESC '6') label='f6  Option 6'
    undo_s    in = (ESC '%') label='    Option Shift 5'
    stop_s    in = (ESC '^') label='    Option Shift 6'

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (ESC '1') label='f1  Option 1'
    f2        in = (ESC '2') label='f2  Option 2'
    f3        in = (ESC '3') label='f3  Option 3'
    f4        in = (ESC '4') label='f4  Option 4'
    f5        in = (ESC '5') label='f5  Option 5'
    f6        in = (ESC '6') label='f6  Option 6'
    f7        in = (ESC 'g') label='f7  Option 7'
    f8        in = (ESC 'h') label='f8  Option 8'
    f9        in = (ESC '9') label='f9  Option 9'
    f10       in = (ESC '0') label=' 0  Option 0'
    f11       in = (ESC 'q') label=' q  Option Q'
    f12       in = (ESC 'w') label=' w  Option W'
    f13       in = (ESC 'e') label=' e  Option E'
    f14       in = (ESC 'r') label=' r  Option R'
    f15       in = (ESC 't') label=' t  Option T'
    f16       in = (ESC 'y') label=' y  Option Y'
    f1_s      in = (ESC '!') label='    Option Shift 1'
    f2_s      in = (ESC '@') label='    Option Shift 2'
    f3_s      in = (ESC 'i') label='    Option Shift 3'
    f4_s      in = (ESC '$') label='    Option Shift 4'
    f5_s      in = (ESC '%') label='    Option Shift 5'
    f6_s      in = (ESC '^') label='    Option Shift 6'
    f7_s      in = (ESC '&') label='    Option Shift 7'
    f8_s      in = (ESC '*') label='    Option Shift 8'
    f9_s      in = (ESC 'j') label='    Option Shift 9'
    f10_s     in = (ESC 'k') label='    Option Shift 0'
    f11_s     in = (ESC 'Q') label='    Option Shift Q'
    f12_s     in = (ESC 'W') label='    Option Shift W'
    f13_s     in = (ESC 'l') label='    Option Shift E'
    f14_s     in = (ESC 'R') label='    Option Shift R'
    f15_s     in = (ESC 'T') label='    Option Shift T'
    f16_s     in = (ESC 'Y') label='    Option Shift Y'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_alternate)
    error_end           out = (stop_alternate)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = 0E(16)
    ld_fine_end              out = 0F(16)
    ld_fine_horizontal       out = 71(16)
    ld_fine_vertical         out = 78(16)
    ld_fine_upper_left       out = 6C(16)
    ld_fine_upper_right      out = 6B(16)
    ld_fine_lower_left       out = 6D(16)
    ld_fine_lower_right      out = 6A(16)
    ld_fine_up_t             out = 77(16)
    ld_fine_down_t           out = 76(16)
    ld_fine_left_t           out = 74(16)
    ld_fine_right_t          out = 75(16)
    ld_fine_cross            out = 6E(16)

    ld_medium_begin          out = (0E(16) start_alternate)
    ld_medium_end            out = (0F(16) stop_alternate)
    ld_medium_horizontal     out = 71(16)
    ld_medium_vertical       out = 78(16)
    ld_medium_upper_left     out = 6C(16)
    ld_medium_upper_right    out = 6B(16)
    ld_medium_lower_left     out = 6D(16)
    ld_medium_lower_right    out = 6A(16)
    ld_medium_up_t           out = 77(16)
    ld_medium_down_t         out = 76(16)
    ld_medium_left_t         out = 74(16)
    ld_medium_right_t        out = 75(16)
    ld_medium_cross          out = 6E(16)

    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')


"   END OF TERMINAL DEFINITION FILE FOR Mac using Control Data Connect        "
*DECK DECK=CSM$MAC_CONNECT_11 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR MACINTOSH WITH CDC CONNECT                   "

"       MAC_CONNECT_11       VERSION 1.1                 OCTOBER 28, 1986     "

"   NOS/VE TERMINAL DEFINITION FILE FOR Macintosh using Control Data Connect  "
"   (basic VT100 plus function key definitions).  Connect should be run with  "
"   local echo on or echoplex for the insert/delete functions to work.        "
"   Important Terminal... and Compatiblity... settings in Connect are:        "
"     Repeat Ctrls           OFF                                              "
"     New Line               OFF                                              "
"     Auto Wraparound        ON                                               "
"     XON/XOFF Flow Control  ON                                               "
"   If Auto Wraparound is OFF, make the following change:                     "
"     char_past_right          type = stop_next                               "
"     char_past_last_position  type = stop_next                               "
"                                                                             "

"   VARIABLES                                                                 "
    prefix              = (esc 5B(16))
    clear_stay          = (prefix 32(16) 4A(16))
    clear_all_tabs      = (prefix 33(16) 67(16))
    set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))
    set_to_24x132       = (prefix 3F(16) 33(16) 68(16))
    start_alternate     = (prefix 31(16) 6D(16))
    start_blink         = (prefix 35(16) 6D(16))
    start_inverse       = (prefix 37(16) 6D(16))
    start_underline     = (prefix 34(16) 6D(16))
    stop_alternate      = (prefix 6D(16))
    stop_blink          = (prefix 6D(16))
    stop_inverse        = (prefix 6D(16))
    stop_underline      = (prefix 6D(16))

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'MAC_CONNECT_11'
    communications      type  = asynch
    application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix)
    cursor_pos_second        out   = (3B(16))
    cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (prefix 48(16)) label='Option H'
    cursor_up                inout = (prefix 41(16)) label='Option I'
    cursor_down              inout = (prefix 42(16)) label='Option M'
    cursor_left              inout = (prefix 44(16)) label='Option J'
    cursor_right             inout = (prefix 43(16)) label='Option K'

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = stop_next
    move_past_left           type  = stop_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next
    char_past_left           type  = stop_next
    char_past_last_position  type  = scroll_next

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 0                  "for MAC"
    has_hidden               value = FALSE
    has_protect              value = FALSE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = TRUE

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80   out = (set_to_24x80)
    set_size       rows = 24 columns = 132  out = (set_to_24x132)

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode     out = (esc 3C(16) clear_all_tabs ..
         esc 28(16) 42(16) esc 29(16) 30(16) 0F(16) esc ..
         3D(16))

    set_line_mode       out = (esc 3C(16) clear_all_tabs ..
         esc 28(16) 42(16) esc 29(16) 30(16) 0F(16) esc ..
         3E(16))

"   TERMINAL CAPABILITIES                                                    "
    insert_char         inout = (prefix '@') label='Option Space'
    delete_char         inout = (prefix 'P') label='Option Backspace'
    delete_line_bol     inout = (prefix 'M') label='Option Shift Backspace'
    insert_line_bol     inout = (prefix 'L') label='Option Shift Space'
    erase_end_of_line   inout = (prefix 'K') label='Option C'
    erase_line_stay     inout = (prefix '2K')
    erase_page_stay     inout = (clear_stay) label='Option Shift C'
    backspace           in = (08(16))
    tab_forward         inout = (09(16))
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (esc 48(16))

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    output_begin        out = (prefix 34(16) 6C(16))
    bell_nak            out = (bel)

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = (CR)           label='Return'
    next_s    in = (ESC CR)       label='Shift Return'
    data      in = (ESC 27(16))   label='Option "'
    data_s    in = (ESC '"')      label='Option Shift "'
    back      in = (ESC ';')      label='Option ;'
    back_s    in = (ESC ':')      label='Option Shift ;'
    help      in = (ESC '/')      label='Option ?'
    help_s    in = (ESC '?')      label='Option Shift ?'
    edit      in = (ESC '.')      label='Option .'
    edit_s    in = (ESC 'n')      label='Option Shift .'
    down      in = (ESC 'd')      label='Option D'
    down_s    in = (ESC 'm')      label='Option Shift D'
    up        in = (ESC 'u')      label='Option U'
    up_s      in = (ESC 'U')      label='Option Shift U'
    fwd       in = (ESC 'f')      label='Option F'
    fwd_s     in = (ESC 'F')      label='Option Shift F'
    bkw       in = (ESC 'b')      label='Option B'
    bkw_s     in = (ESC 'B')      label='Option Shift B'
    undo      in = (ESC '5') label='f5  Option 5'
    stop      in = (ESC '6') label='f6  Option 6'
    undo_s    in = (ESC '%') label='    Option Shift 5'
    stop_s    in = (ESC '^') label='    Option Shift 6'

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (ESC '1') label='f1  Option 1'
    f2        in = (ESC '2') label='f2  Option 2'
    f3        in = (ESC '3') label='f3  Option 3'
    f4        in = (ESC '4') label='f4  Option 4'
    f5        in = (ESC '5') label='f5  Option 5'
    f6        in = (ESC '6') label='f6  Option 6'
    f7        in = (ESC 'g') label='f7  Option 7'
    f8        in = (ESC 'h') label='f8  Option 8'
    f9        in = (ESC '9') label='f9  Option 9'
    f10       in = (ESC '0') label=' 0  Option 0'
    f11       in = (ESC 'q') label=' q  Option Q'
    f12       in = (ESC 'w') label=' w  Option W'
    f13       in = (ESC 'e') label=' e  Option E'
    f14       in = (ESC 'r') label=' r  Option R'
    f15       in = (ESC 't') label=' t  Option T'
    f16       in = (ESC 'y') label=' y  Option Y'
    f1_s      in = (ESC '!') label='    Option Shift 1'
    f2_s      in = (ESC '@') label='    Option Shift 2'
    f3_s      in = (ESC 'i') label='    Option Shift 3'
    f4_s      in = (ESC '$') label='    Option Shift 4'
    f5_s      in = (ESC '%') label='    Option Shift 5'
    f6_s      in = (ESC '^') label='    Option Shift 6'
    f7_s      in = (ESC '&') label='    Option Shift 7'
    f8_s      in = (ESC '*') label='    Option Shift 8'
    f9_s      in = (ESC 'j') label='    Option Shift 9'
    f10_s     in = (ESC 'k') label='    Option Shift 0'
    f11_s     in = (ESC 'Q') label='    Option Shift Q'
    f12_s     in = (ESC 'W') label='    Option Shift W'
    f13_s     in = (ESC 'l') label='    Option Shift E'
    f14_s     in = (ESC 'R') label='    Option Shift R'
    f15_s     in = (ESC 'T') label='    Option Shift T'
    f16_s     in = (ESC 'Y') label='    Option Shift Y'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_alternate)
    error_end           out = (stop_alternate)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = 0E(16)
    ld_fine_end              out = 0F(16)
    ld_fine_horizontal       out = 71(16)
    ld_fine_vertical         out = 78(16)
    ld_fine_upper_left       out = 6C(16)
    ld_fine_upper_right      out = 6B(16)
    ld_fine_lower_left       out = 6D(16)
    ld_fine_lower_right      out = 6A(16)
    ld_fine_up_t             out = 77(16)
    ld_fine_down_t           out = 76(16)
    ld_fine_left_t           out = 74(16)
    ld_fine_right_t          out = 75(16)
    ld_fine_cross            out = 6E(16)

    ld_medium_begin          out = (0E(16) start_alternate)
    ld_medium_end            out = (0F(16) stop_alternate)
    ld_medium_horizontal     out = 71(16)
    ld_medium_vertical       out = 78(16)
    ld_medium_upper_left     out = 6C(16)
    ld_medium_upper_right    out = 6B(16)
    ld_medium_lower_left     out = 6D(16)
    ld_medium_lower_right    out = 6A(16)
    ld_medium_up_t           out = 77(16)
    ld_medium_down_t         out = 76(16)
    ld_medium_left_t         out = 74(16)
    ld_medium_right_t        out = 75(16)
    ld_medium_cross          out = 6E(16)

    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')


"   END OF TERMINAL DEFINITION FILE FOR Mac using Control Data Connect        "
*DECK DECK=CSM$MAC_CONNECT_20 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR MACINTOSH                                    "
"   running Control Data CONNECT V2.0 or Desktop/VE V1.1                      "

"       MAC_CONNECT_20                                        APRIL, 1988     "

"   To change the full screen line count for larger screens, make following   "
"   modifications to this Terminal Definition source before recompiling:      "
"     Replace Full_Screen_Line_Count variable value 24 with full screen line  "
"       count (24 to 100) defined in CONNECT or Desktop/VE Terminal Settings. "
"     Replace rows = 24 in set_size definitions with full screen line count.  "
"     Replace model_name value with unique terminal name such as              "
"       MAC_CONNECT_20_XX where XX is the full screen line count (24 to 100). "


"   VARIABLES                                                                 "
    Full_Screen_Line_Count    = ('24')        "sets Mac Full_Screen_Line_Count"
    clear_all_tabs            = (ESC '[3g')
    set_80_cols               = (ESC '[?3l')
    set_132_cols              = (ESC '[?3h')
    start_bold                = (ESC '[1m')
    start_inverse             = (ESC '[7m')
    start_underline           = (ESC '[4m')
    stop_attrs                = (ESC '[m')
    set_graphics              = (ESC '(B' ESC ')0' SI)
    enable_auto_tab           = (ESC '[=3h')
    enable_auto_wrap          = (ESC '[?7h')
    global_protect_on         = (ESC '[=1h')
    global_protect_off        = (ESC '[=1l')
    cursor_pos_721            = (ESC '[=6h')
    reset_terminal            = (ESC 'c')
    enter_screen_mode         = (ESC '[=5h')
    enter_line_mode           = (ESC '[=5l')
    NOSVE_host                = (ESC '[1t')
    set_screen_size           = (ESC '[' Full_Screen_Line_Count ';80z')
    redo_set_screen_mode      = (NOSVE_host global_protect_on ..
                                clear_all_tabs  set_graphics  enable_auto_wrap  ..
                                enable_auto_tab  cursor_pos_721)
    redo_set_line_mode        = (global_protect_off set_graphics)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'MAC_CONNECT_20'
    communications      type  = asynch
    application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (ESC '[')
    cursor_pos_second        out   = (';')
    cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (ESC '[H')  label='Option H'
    cursor_up                inout = (ESC '[A')  label='up arrow'
    cursor_down              inout = (ESC '[B')  label='down arrow'
    cursor_right             inout = (ESC '[C')  label='right arrow'
    cursor_left              inout = (ESC '[D')  label='left arrow'

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_left           type = wrap_adjacent_next
    char_past_right          type = wrap_adjacent_next
    char_past_last_position  type = wrap_adjacent_next

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE            "for 80/132 column change"
    function_key_leaves_mark value = 0
    has_hidden               value = FALSE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
    automatic_tabbing        value = TRUE

"   SCREEN SIZES                                                              "
    set_size  rows = 24  columns = 80   out = (set_80_cols)
    set_size  rows = 24  columns = 132  out = (set_132_cols)

"   TERMINAL CAPABILITIES                                                     "
    insert_char         inout = (ESC '[@')   label='Option Space'
    insert_line_bol     inout = (ESC '[L')   label='Option Shift Space'
    delete_char         inout = (ESC '[P')   label='Option Delete'
    delete_line_bol     inout = (ESC '[M')   label='Option Shift Delete'
    erase_end_of_line   inout = (ESC '[K')   label='Option Clear'
    erase_line_stay     inout = (ESC '[2K')
    erase_end_of_field  inout = (ESC '[N')
    erase_field_stay    inout = (ESC '[2N')
    erase_page_stay     inout = (ESC '[2J')  label='Clear'
    backspace           in = (BS)            label='Delete'
    tab_forward         inout = (HT)         label='Tab'
    tab_backward        inout = (ESC '[Z')   label='Option Tab'
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (ESC 'H')

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode out = (NOSVE_host  enter_screen_mode  ..
                           clear_all_tabs  set_graphics  enable_auto_wrap  ..
                           enable_auto_tab  cursor_pos_721  set_screen_size)

    set_line_mode   out = (enter_line_mode  set_graphics  reset_terminal)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (ESC 'V')
    protect_end         out = (ESC 'W')
    protect_all         out = (ESC '[1p')
    output_begin        out = (global_protect_off)
    output_end          out = (global_protect_on)
    bell_nak            out = (BEL)

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = (CR)              label='Return'
    data      in = (ESC 'O' 27(16))  label='Option "'
    data_s    in = (ESC 'O' 22(16))  label='Option Shift "'
    back      in = (ESC 'O;')        label='Option ;'
    back_s    in = (ESC 'O:')        label='Option Shift ;'
    help      in = (ESC 'O/')        label='Option ?'
    help_s    in = (ESC 'O?')        label='Option Shift ?'
    edit      in = (ESC 'O.')        label='Option .'
    edit_s    in = (ESC 'O>')        label='Option Shift .'
    down      in = (ESC 'O+')        label='Option D'
    down_s    in = (ESC 'O-')        label='Option Shift D'
    up        in = (ESC 'O(')        label='Option U'
    up_s      in = (ESC 'O)')        label='Option Shift U'
    fwd       in = (ESC 'OX')        label='Option F'
    fwd_s     in = (ESC 'Oo')        label='Option Shift F'
    bkw       in = (ESC 'OW')        label='Option B'
    bkw_s     in = (ESC 'Of')        label='Option Shift B'
    undo      in = (ESC 'Ou')        label='F5  Option 5'
    undo_s    in = (ESC 'Om')        label='    Option Shift 5'
    stop      in = (ESC 'Ov')        label='F6  Option 6'
    stop_s    in = (ESC 'Ol')        label='    Option Shift 6'

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (ESC 'Oq')        label='F1  Option 1'
    f2        in = (ESC 'Or')        label='F2  Option 2'
    f3        in = (ESC 'Os')        label='F3  Option 3'
    f4        in = (ESC 'Ot')        label='F4  Option 4'
    f5        in = (ESC 'Ou')        label='F5  Option 5'
    f6        in = (ESC 'Ov')        label='F6  Option 6'
    f7        in = (ESC 'Ow')        label='F7  Option 7'
    f8        in = (ESC 'Ox')        label='F8  Option 8'
    f9        in = (ESC 'Oy')        label='F9  Option 9'
    f10       in = (ESC 'Oz')        label='10  Option 0'
    f11       in = (ESC 'O{')        label='11  Option Q'
    f12       in = (ESC 'O|')        label='12  Option W'
    f13       in = (ESC 'O}')        label='13  Option E'
    f14       in = (ESC 'O~')        label='14  Option R'
    f15       in = (ESC 'O_')        label='15  Option T'
    f16       in = (ESC 'OU')        label='16  Option Y'
    f1_s      in = (ESC 'Og')        label='    Option Shift 1'
    f2_s      in = (ESC 'Oh')        label='    Option Shift 2'
    f3_s      in = (ESC 'Oi')        label='    Option Shift 3'
    f4_s      in = (ESC 'Oj')        label='    Option Shift 4'
    f5_s      in = (ESC 'Om')        label='    Option Shift 5'
    f6_s      in = (ESC 'Ol')        label='    Option Shift 6'
    f7_s      in = (ESC 'OM')        label='    Option Shift 7'
    f8_s      in = (ESC 'On')        label='    Option Shift 8'
    f9_s      in = (ESC 'Op')        label='    Option Shift 9'
    f10_s     in = (ESC 'OO')        label='    Option Shift 0'
    f11_s     in = (ESC 'Oa')        label='    Option Shift Q'
    f12_s     in = (ESC 'Ob')        label='    Option Shift W'
    f13_s     in = (ESC 'Oc')        label='    Option Shift E'
    f14_s     in = (ESC 'Od')        label='    Option Shift R'
    f15_s     in = (ESC 'Oe')        label='    Option Shift T'
    f16_s     in = (ESC 'OV')        label='    Option Shift Y'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_bold)
    alt_end             out = (stop_attrs)
    blink_begin         out = ()                   "not supported"
    blink_end           out = ()                   "not supported"
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_attrs)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_attrs)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_bold)
    error_end           out = (stop_attrs)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_attrs)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_attrs)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = (SO)
    ld_fine_end              out = (SI)
    ld_fine_horizontal       out = (71(16))
    ld_fine_vertical         out = (78(16))
    ld_fine_upper_left       out = (6C(16))
    ld_fine_upper_right      out = (6B(16))
    ld_fine_lower_left       out = (6D(16))
    ld_fine_lower_right      out = (6A(16))
    ld_fine_up_t             out = (77(16))
    ld_fine_down_t           out = (76(16))
    ld_fine_left_t           out = (74(16))
    ld_fine_right_t          out = (75(16))
    ld_fine_cross            out = (6E(16))

    ld_medium_begin          out = (SO start_bold)
    ld_medium_end            out = (SI stop_attrs)
    ld_medium_horizontal     out = (71(16))
    ld_medium_vertical       out = (78(16))
    ld_medium_upper_left     out = (6C(16))
    ld_medium_upper_right    out = (6B(16))
    ld_medium_lower_left     out = (6D(16))
    ld_medium_lower_right    out = (6A(16))
    ld_medium_up_t           out = (77(16))
    ld_medium_down_t         out = (76(16))
    ld_medium_left_t         out = (74(16))
    ld_medium_right_t        out = (75(16))
    ld_medium_cross          out = (6E(16))

    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_attrs)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')

    application_string name='REDO_SET_SCREEN_MODE' out=(redo_set_screen_mode)
    application_string name='REDO_SET_LINE_MODE' out=(redo_set_line_mode)

"   END OF TERMINAL DEFINITION FILE FOR Macintosh                             "
*DECK DECK=CSM$MAC_CONNECT_21 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR MACINTOSH                                    "
"   running Control Data CONNECT V2.1 or Desktop/VE V1.2                      "

"       MAC_CONNECT_21                                        DECEMBER, 1988  "

"   To change the full screen line count for larger screens, make following   "
"   modifications to this Terminal Definition source before recompiling:      "
"     Replace Full_Screen_Line_Count variable value 24 with full screen line  "
"       count (24 to 100) defined in CONNECT or Desktop/VE Terminal Settings. "
"     Replace rows = 24 in set_size definitions with full screen line count.  "
"     Replace model_name value with unique terminal name such as              "
"       MAC_CONNECT_21_XX where XX is the full screen line count (24 to 100). "


"   VARIABLES                                                                 "
    Full_Screen_Line_Count    = ('24')        "sets Mac Full_Screen_Line_Count"
    clear_all_tabs            = (ESC '[3g')
    set_80_cols               = (ESC '[?3l')
    set_132_cols              = (ESC '[?3h')
    start_bold                = (ESC '[1m')
    start_inverse             = (ESC '[7m')
    start_underline           = (ESC '[4m')
    stop_bold                 = (ESC '[21m')
    stop_inverse              = (ESC '[27m')
    stop_underline            = (ESC '[24m')
    set_graphics              = (ESC '(B' ESC ')0' SI)
    enable_auto_tab           = (ESC '[=3h')
    enable_auto_wrap          = (ESC '[?7h')
    enable_insertion          = (ESC '[4h')
    disable_insertion         = (ESC '[4l')
    global_protect_on         = (ESC '[=1h')
    global_protect_off        = (ESC '[=1l')
    cursor_pos_normal         = (ESC '[=6l')
    reset_terminal            = (ESC 'c')
    enter_screen_mode         = (ESC '[=5h')
    enter_line_mode           = (ESC '[=5l')
    NOSVE_host                = (ESC '[1t')
    set_screen_size           = (ESC '[' Full_Screen_Line_Count ';80z')
    redo_set_screen_mode      = (NOSVE_host global_protect_on ..
                                clear_all_tabs  set_graphics  enable_auto_wrap  ..
                                enable_auto_tab  cursor_pos_normal)
    redo_set_line_mode        = (global_protect_off set_graphics)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'MAC_CONNECT_21'
    communications      type  = asynch
    application_string  name  = 'vt100_scrolling'  out = 'true'
    application_string  name='DRIVER_PROCEDURE' out='TUP$BOOT_CONNECT_CURSOR'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (ESC '[')
    cursor_pos_second        out   = (';')
    cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (ESC '[H')  label='Option H'
    cursor_up                inout = (ESC '[A')  label='up arrow'
    cursor_down              inout = (ESC '[B')  label='down arrow'
    cursor_right             inout = (ESC '[C')  label='right arrow'
    cursor_left              inout = (ESC '[D')  label='left arrow'

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_left           type = wrap_adjacent_next
    char_past_right          type = wrap_adjacent_next
    char_past_last_position  type = wrap_adjacent_next

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE            "for 80/132 column change"
    function_key_leaves_mark value = 0
    has_hidden               value = FALSE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
    automatic_tabbing        value = TRUE

"   SCREEN SIZES                                                              "
    set_size  rows = 24  columns = 80   out = (set_80_cols)
    set_size  rows = 24  columns = 132  out = (set_132_cols)

"   TERMINAL CAPABILITIES                                                     "
    insert_char         inout = (ESC '[@')   label='Option Space'
    insert_line_bol     inout = (ESC '[L')   label='Option Shift Space'
    delete_char         inout = (ESC '[P')   label='Option Delete'
    delete_line_bol     inout = (ESC '[M')   label='Option Shift Delete'
    erase_end_of_line   inout = (ESC '[K')   label='Option Clear'
    erase_line_stay     inout = (ESC '[2K')
    erase_end_of_field  inout = (ESC '[N')
    erase_field_stay    inout = (ESC '[2N')
    erase_page_stay     inout = (ESC '[2J')  label='Clear'
    backspace           in = (BS)            label='Delete'
    tab_forward         inout = (HT)         label='Tab'
    tab_backward        inout = (ESC '[Z')   label='Option Tab'
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (ESC 'H')
    tab_clear           inout = (ESC '[g')
    insert_mode_begin   inout = (enable_insertion)
    insert_mode_end     inout = (disable_insertion)

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode out = (NOSVE_host  enter_screen_mode  ..
                           clear_all_tabs  set_graphics  enable_auto_wrap  ..
                           enable_auto_tab  cursor_pos_normal  set_screen_size)

    set_line_mode   out = (enter_line_mode  set_graphics  reset_terminal)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (ESC 'V')
    protect_end         out = (ESC 'W')
    protect_all         out = (ESC '[1p')
    output_begin        out = (global_protect_off disable_insertion)
    output_end          out = (global_protect_on)
    bell_nak            out = (BEL)

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = (CR)              label='Return'
    data      in = (ESC 'O' 27(16))  label='Option "'
    data_s    in = (ESC 'O' 22(16))  label='Option Shift "'
    back      in = (ESC 'O;')        label='Option ;'
    back_s    in = (ESC 'O:')        label='Option Shift ;'
    help      in = (ESC 'O/')        label='Option ?'
    help_s    in = (ESC 'O?')        label='Option Shift ?'
    edit      in = (ESC 'O.')        label='Option .'
    edit_s    in = (ESC 'O>')        label='Option Shift .'
    down      in = (ESC 'O+')        label='Option D'
    down_s    in = (ESC 'O-')        label='Option Shift D'
    up        in = (ESC 'O(')        label='Option U'
    up_s      in = (ESC 'O)')        label='Option Shift U'
    fwd       in = (ESC 'OX')        label='Option F'
    fwd_s     in = (ESC 'Oo')        label='Option Shift F'
    bkw       in = (ESC 'OW')        label='Option B'
    bkw_s     in = (ESC 'Of')        label='Option Shift B'
    undo      in = (ESC 'Ou')        label='F5  Option 5'
    undo_s    in = (ESC 'Om')        label='    Option Shift 5'
    stop      in = (ESC 'Ov')        label='F6  Option 6'
    stop_s    in = (ESC 'Ol')        label='    Option Shift 6'

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (ESC 'Oq')        label='F1  Option 1'
    f2        in = (ESC 'Or')        label='F2  Option 2'
    f3        in = (ESC 'Os')        label='F3  Option 3'
    f4        in = (ESC 'Ot')        label='F4  Option 4'
    f5        in = (ESC 'Ou')        label='F5  Option 5'
    f6        in = (ESC 'Ov')        label='F6  Option 6'
    f7        in = (ESC 'Ow')        label='F7  Option 7'
    f8        in = (ESC 'Ox')        label='F8  Option 8'
    f9        in = (ESC 'Oy')        label='F9  Option 9'
    f10       in = (ESC 'Oz')        label='10  Option 0'
    f11       in = (ESC 'O{')        label='11  Option Q'
    f12       in = (ESC 'O|')        label='12  Option W'
    f13       in = (ESC 'O}')        label='13  Option E'
    f14       in = (ESC 'O~')        label='14  Option R'
    f15       in = (ESC 'O_')        label='15  Option T'
    f16       in = (ESC 'OU')        label='16  Option Y'
    f1_s      in = (ESC 'Og')        label='    Option Shift 1'
    f2_s      in = (ESC 'Oh')        label='    Option Shift 2'
    f3_s      in = (ESC 'Oi')        label='    Option Shift 3'
    f4_s      in = (ESC 'Oj')        label='    Option Shift 4'
    f5_s      in = (ESC 'Om')        label='    Option Shift 5'
    f6_s      in = (ESC 'Ol')        label='    Option Shift 6'
    f7_s      in = (ESC 'OM')        label='    Option Shift 7'
    f8_s      in = (ESC 'On')        label='    Option Shift 8'
    f9_s      in = (ESC 'Op')        label='    Option Shift 9'
    f10_s     in = (ESC 'OO')        label='    Option Shift 0'
    f11_s     in = (ESC 'Oa')        label='    Option Shift Q'
    f12_s     in = (ESC 'Ob')        label='    Option Shift W'
    f13_s     in = (ESC 'Oc')        label='    Option Shift E'
    f14_s     in = (ESC 'Od')        label='    Option Shift R'
    f15_s     in = (ESC 'Oe')        label='    Option Shift T'
    f16_s     in = (ESC 'OV')        label='    Option Shift Y'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_bold)
    alt_end             out = (stop_bold)
    blink_begin         out = ()                   "not supported"
    blink_end           out = ()                   "not supported"
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_bold)
    error_end           out = (stop_bold)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = (SO)
    ld_fine_end              out = (SI)
    ld_fine_horizontal       out = (71(16))
    ld_fine_vertical         out = (78(16))
    ld_fine_upper_left       out = (6C(16))
    ld_fine_upper_right      out = (6B(16))
    ld_fine_lower_left       out = (6D(16))
    ld_fine_lower_right      out = (6A(16))
    ld_fine_up_t             out = (77(16))
    ld_fine_down_t           out = (76(16))
    ld_fine_left_t           out = (74(16))
    ld_fine_right_t          out = (75(16))
    ld_fine_cross            out = (6E(16))

    ld_medium_begin          out = (SO start_bold)
    ld_medium_end            out = (SI stop_bold)
    ld_medium_horizontal     out = (71(16))
    ld_medium_vertical       out = (78(16))
    ld_medium_upper_left     out = (6C(16))
    ld_medium_upper_right    out = (6B(16))
    ld_medium_lower_left     out = (6D(16))
    ld_medium_lower_right    out = (6A(16))
    ld_medium_up_t           out = (77(16))
    ld_medium_down_t         out = (76(16))
    ld_medium_left_t         out = (74(16))
    ld_medium_right_t        out = (75(16))
    ld_medium_cross          out = (6E(16))

    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')

    application_string name='REDO_SET_SCREEN_MODE' out=(redo_set_screen_mode)
    application_string name='REDO_SET_LINE_MODE' out=(redo_set_line_mode)

"   END OF TERMINAL DEFINITION FILE FOR Macintosh                             "
*DECK DECK=CSM$MAC_CONNECT_22 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR MACINTOSH                                    "
"   running Control Data CONNECT V2.2                                         "

"       MAC_CONNECT_22                                        DECEMBER, 1989  "

"   To change the full screen line count for larger screens, make following   "
"   modifications to this Terminal Definition source before recompiling:      "
"     Replace Full_Screen_Line_Count variable value 24 with full screen line  "
"       count (24 to 100) defined in CONNECT Terminal Settings.               "
"     Replace rows = 24 in set_size definitions with full screen line count.  "
"     Replace model_name value with unique terminal name such as              "
"       MAC_CONNECT_22_XX where XX is the full screen line count (24 to 100). "


"   VARIABLES                                                                 "
    Full_Screen_Line_Count    = ('24')        "sets Mac Full_Screen_Line_Count"
    clear_all_tabs            = (ESC '[3g')
    set_80_cols               = (ESC '[?3l')
    set_132_cols              = (ESC '[?3h')
    start_bold                = (ESC '[1m')
    start_inverse             = (ESC '[7m')
    start_underline           = (ESC '[4m')
    stop_bold                 = (ESC '[21m')
    stop_inverse              = (ESC '[27m')
    stop_underline            = (ESC '[24m')
    set_graphics              = (ESC '(B' ESC ')0' SI)
    enable_auto_tab           = (ESC '[=3h')
    enable_auto_wrap          = (ESC '[?7h')
    enable_insertion          = (ESC '[4h')
    disable_insertion         = (ESC '[4l')
    global_protect_on         = (ESC '[=1h')
    global_protect_off        = (ESC '[=1l')
    cursor_pos_normal         = (ESC '[=6l')
    reset_terminal            = (ESC 'c')
    enter_screen_mode         = (ESC '[=5h')
    enter_line_mode           = (ESC '[=5l')
    enter_term_mode           = (ESC '%!2')
    NOSVE_host                = (ESC '[1t')
    set_screen_size           = (ESC '[' Full_Screen_Line_Count ';80z')
    redo_set_screen_mode      = (NOSVE_host enter_screen_mode global_protect_on ..
                                clear_all_tabs  set_graphics  enable_auto_wrap  ..
                                enable_auto_tab  cursor_pos_normal)
    redo_set_line_mode        = (enter_line_mode global_protect_off set_graphics)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'MAC_CONNECT_22'
    communications      type  = asynch
    application_string  name  = 'vt100_scrolling'  out = 'true'
    application_string  name='DRIVER_PROCEDURE' out='TUP$BOOT_CONNECT_CURSOR'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (ESC '[')
    cursor_pos_second        out   = (';')
    cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (ESC '[H')  label='Option H'
    cursor_up                inout = (ESC '[A')  label='up arrow'
    cursor_down              inout = (ESC '[B')  label='down arrow'
    cursor_right             inout = (ESC '[C')  label='right arrow'
    cursor_left              inout = (ESC '[D')  label='left arrow'

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_left           type = wrap_adjacent_next
    char_past_right          type = wrap_adjacent_next
    char_past_last_position  type = wrap_adjacent_next

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE            "for 80/132 column change"
    function_key_leaves_mark value = 0
    has_hidden               value = FALSE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
    automatic_tabbing        value = TRUE

"   SCREEN SIZES                                                              "
    set_size  rows = 24  columns = 80   out = (set_80_cols)
    set_size  rows = 24  columns = 132  out = (set_132_cols)

"   TERMINAL CAPABILITIES                                                     "
    insert_char         inout = (ESC '[@')   label='Option Space'
    insert_line_bol     inout = (ESC '[L')   label='Option Shift Space'
    delete_char         inout = (ESC '[P')   label='Option Delete'
    delete_line_bol     inout = (ESC '[M')   label='Option Shift Delete'
    erase_end_of_line   inout = (ESC '[K')   label='Option Clear'
    erase_line_stay     inout = (ESC '[2K')
    erase_end_of_field  inout = (ESC '[N')
    erase_field_stay    inout = (ESC '[2N')
    erase_page_stay     inout = (ESC '[2J')  label='Clear'
    backspace           in = (BS)            label='Delete'
    tab_forward         inout = (HT)         label='Tab'
    tab_backward        inout = (ESC '[Z')   label='Option Tab'
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (ESC 'H')
    tab_clear           inout = (ESC '[g')
    insert_mode_begin   inout = (enable_insertion)
    insert_mode_end     inout = (disable_insertion)

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode out = (NOSVE_host  enter_term_mode enter_screen_mode  ..
                           clear_all_tabs  set_graphics  enable_auto_wrap  ..
                           enable_auto_tab  cursor_pos_normal  set_screen_size)

    set_line_mode   out = (enter_line_mode  set_graphics  reset_terminal)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (ESC 'V')
    protect_end         out = (ESC 'W')
    protect_all         out = (ESC '[1p')
    output_begin        out = (global_protect_off disable_insertion)
    output_end          out = (global_protect_on)
    bell_nak            out = (BEL)

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = (CR)              label='Return'
    data      in = (ESC 'O' 27(16))  label='Option "'
    data_s    in = (ESC 'O' 22(16))  label='Option Shift "'
    back      in = (ESC 'O;')        label='Option ;'
    back_s    in = (ESC 'O:')        label='Option Shift ;'
    help      in = (ESC 'O/')        label='Option ?'
    help_s    in = (ESC 'O?')        label='Option Shift ?'
    edit      in = (ESC 'O.')        label='Option .'
    edit_s    in = (ESC 'O>')        label='Option Shift .'
    down      in = (ESC 'O+')        label='Option D'
    down_s    in = (ESC 'O-')        label='Option Shift D'
    up        in = (ESC 'O(')        label='Option U'
    up_s      in = (ESC 'O)')        label='Option Shift U'
    fwd       in = (ESC 'OX')        label='Option F'
    fwd_s     in = (ESC 'Oo')        label='Option Shift F'
    bkw       in = (ESC 'OW')        label='Option B'
    bkw_s     in = (ESC 'Of')        label='Option Shift B'
    undo      in = (ESC 'Ou')        label='F5  Option 5'
    undo_s    in = (ESC 'Om')        label='    Option Shift 5'
    stop      in = (ESC 'Ov')        label='F6  Option 6'
    stop_s    in = (ESC 'Ol')        label='    Option Shift 6'

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (ESC 'Oq')        label='F1  Option 1'
    f2        in = (ESC 'Or')        label='F2  Option 2'
    f3        in = (ESC 'Os')        label='F3  Option 3'
    f4        in = (ESC 'Ot')        label='F4  Option 4'
    f5        in = (ESC 'Ou')        label='F5  Option 5'
    f6        in = (ESC 'Ov')        label='F6  Option 6'
    f7        in = (ESC 'Ow')        label='F7  Option 7'
    f8        in = (ESC 'Ox')        label='F8  Option 8'
    f9        in = (ESC 'Oy')        label='F9  Option 9'
    f10       in = (ESC 'Oz')        label='10  Option 0'
    f11       in = (ESC 'O{')        label='11  Option Q'
    f12       in = (ESC 'O|')        label='12  Option W'
    f13       in = (ESC 'O}')        label='13  Option E'
    f14       in = (ESC 'O~')        label='14  Option R'
    f15       in = (ESC 'O_')        label='15  Option T'
    f16       in = (ESC 'OU')        label='16  Option Y'
    f1_s      in = (ESC 'Og')        label='    Option Shift 1'
    f2_s      in = (ESC 'Oh')        label='    Option Shift 2'
    f3_s      in = (ESC 'Oi')        label='    Option Shift 3'
    f4_s      in = (ESC 'Oj')        label='    Option Shift 4'
    f5_s      in = (ESC 'Om')        label='    Option Shift 5'
    f6_s      in = (ESC 'Ol')        label='    Option Shift 6'
    f7_s      in = (ESC 'OM')        label='    Option Shift 7'
    f8_s      in = (ESC 'On')        label='    Option Shift 8'
    f9_s      in = (ESC 'Op')        label='    Option Shift 9'
    f10_s     in = (ESC 'OO')        label='    Option Shift 0'
    f11_s     in = (ESC 'Oa')        label='    Option Shift Q'
    f12_s     in = (ESC 'Ob')        label='    Option Shift W'
    f13_s     in = (ESC 'Oc')        label='    Option Shift E'
    f14_s     in = (ESC 'Od')        label='    Option Shift R'
    f15_s     in = (ESC 'Oe')        label='    Option Shift T'
    f16_s     in = (ESC 'OV')        label='    Option Shift Y'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_bold)
    alt_end             out = (stop_bold)
    blink_begin         out = ()                   "not supported"
    blink_end           out = ()                   "not supported"
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_bold)
    error_end           out = (stop_bold)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = (SO)
    ld_fine_end              out = (SI)
    ld_fine_horizontal       out = (71(16))
    ld_fine_vertical         out = (78(16))
    ld_fine_upper_left       out = (6C(16))
    ld_fine_upper_right      out = (6B(16))
    ld_fine_lower_left       out = (6D(16))
    ld_fine_lower_right      out = (6A(16))
    ld_fine_up_t             out = (77(16))
    ld_fine_down_t           out = (76(16))
    ld_fine_left_t           out = (74(16))
    ld_fine_right_t          out = (75(16))
    ld_fine_cross            out = (6E(16))

    ld_medium_begin          out = (SO start_bold)
    ld_medium_end            out = (SI stop_bold)
    ld_medium_horizontal     out = (71(16))
    ld_medium_vertical       out = (78(16))
    ld_medium_upper_left     out = (6C(16))
    ld_medium_upper_right    out = (6B(16))
    ld_medium_lower_left     out = (6D(16))
    ld_medium_lower_right    out = (6A(16))
    ld_medium_up_t           out = (77(16))
    ld_medium_down_t         out = (76(16))
    ld_medium_left_t         out = (74(16))
    ld_medium_right_t        out = (75(16))
    ld_medium_cross          out = (6E(16))

    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')

    application_string name='REDO_SET_SCREEN_MODE' out=(redo_set_screen_mode)
    application_string name='REDO_SET_LINE_MODE' out=(redo_set_line_mode)

"   END OF TERMINAL DEFINITION FILE FOR Macintosh                             "
"   running Control Data CONNECT V2.2                                         "
*DECK DECK=CSM$MAC_HOST_ECHO_21 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR MACINTOSH                                    "
"   running Control Data CONNECT V2.1 or Desktop/VE V1.2                      "

"   MAC_HOST_ECHO_21                                           MARCH, 1994    "
"   To change the full screen line count for larger screens, make following   "
"   modifications to this Terminal Definition source before recompiling:      "
"     Replace Full_Screen_Line_Count variable value 24 with full screen line  "
"       count (24 to 100) defined in CONNECT or Desktop/VE Terminal Settings. "
"     Replace rows = 24 in set_size definitions with full screen line count.  "
"     Replace model_name value with unique terminal name such as              "
"       FULL_DUPLEX_MAC_XX where XX is the full screen line count (24 to 100)."


"   VARIABLES                                                                 "
    Full_Screen_Line_Count    = ('24')        "sets Mac Full_Screen_Line_Count"
    clear_all_tabs            = (ESC '[3g')
    set_80_cols               = (ESC '[?3l')
    set_132_cols              = (ESC '[?3h')
    start_bold                = (ESC '[1m')
    start_inverse             = (ESC '[7m')
    start_underline           = (ESC '[4m')
    stop_bold                 = (ESC '[21m')
    stop_inverse              = (ESC '[27m')
    stop_underline            = (ESC '[24m')
    set_graphics              = (ESC '(B' ESC ')0' SI)
    enable_auto_tab           = (ESC '[=3h')
    enable_auto_wrap          = (ESC '[?7h')
    enable_insertion          = (ESC '[4h')
    disable_insertion         = (ESC '[4l')
    global_protect_on         = (ESC '[=1h')
    global_protect_off        = (ESC '[=1l')
    cursor_pos_normal         = (ESC '[=6l')
    reset_terminal            = (ESC 'c')
    enter_screen_mode         = (ESC '[=5h')
    enter_line_mode           = (ESC '[=5l')
    set_echo_on               = (ESC '[12l')
    set_echo_off              = (ESC '[12h')
    NOSVE_host                = (ESC '[1t')
    set_screen_size           = (ESC '[' Full_Screen_Line_Count ';80z')
    redo_set_screen_mode      = (NOSVE_host global_protect_on ..
                                clear_all_tabs  set_graphics  enable_auto_wrap  ..
                                enable_auto_tab  cursor_pos_normal)
    redo_set_line_mode        = (global_protect_off set_graphics)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'MAC_HOST_ECHO_21'
    communications      type  = asynch
    application_string  name  = 'vt100_scrolling'  out = 'true'
    application_string  name='DRIVER_PROCEDURE' out= 'tup$host_echo_mac_boot'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (ESC '[')
    cursor_pos_second        out   = (';')
    cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (ESC '[H')  label='Option H'
    cursor_up                inout = (ESC '[A')  label='up arrow'
    cursor_down              inout = (ESC '[B')  label='down arrow'
    cursor_right             inout = (ESC '[C')  label='right arrow'
    cursor_left              inout = (ESC '[D')  label='left arrow'

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_left           type = wrap_adjacent_next
    char_past_right          type = wrap_adjacent_next
    char_past_last_position  type = wrap_adjacent_next

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE            "For 80/132 column change"
    function_key_leaves_mark value = 0
    has_hidden               value = TRUE            "Full duplex supports hidden"
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
    automatic_tabbing        value = TRUE

"   SCREEN SIZES                                                              "
    set_size  rows = 24  columns = 80   out = (set_80_cols)
    set_size  rows = 24  columns = 132  out = (set_132_cols)

"   TERMINAL CAPABILITIES                                                     "
    insert_char         inout = (ESC '[@')   label='Option Space'
    insert_line_bol     inout = (ESC '[L')   label='Option Shift Space'
    delete_char         inout = (ESC '[P')   label='Option Delete'
    delete_line_bol     inout = (ESC '[M')   label='Option Shift Delete'
    erase_end_of_line   inout = (ESC '[K')   label='Option Clear'
    erase_line_stay     inout = (ESC '[2K')
    erase_end_of_field  inout = (ESC '[N')
    erase_field_stay    inout = (ESC '[2N')
    erase_page_stay     inout = (ESC '[2J')  label='Clear'
    backspace           in = (BS)            label='Delete'
    tab_forward         inout = (HT)         label='Tab'
    tab_backward        inout = (ESC '[Z')   label='Option Tab'
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (ESC 'H')
    tab_clear           inout = (ESC '[g')
    insert_mode_begin   inout = (enable_insertion)
    insert_mode_end     inout = (disable_insertion)

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode out = (NOSVE_host  enter_screen_mode  ..
                           clear_all_tabs  set_graphics  enable_auto_wrap  ..
                           enable_auto_tab  cursor_pos_normal  set_screen_size)

    set_line_mode   out = (enter_line_mode  set_graphics reset_terminal)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (ESC 'V')
    protect_end         out = (ESC 'W')
    protect_all         out = (ESC '[1p')
    output_begin        out = (global_protect_off disable_insertion)
    output_end          out = (global_protect_on)
    bell_nak            out = (BEL)

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = (CR)              label='Return'
    data      in = (ESC 'O' 27(16))  label='Option "'
    data_s    in = (ESC 'O' 22(16))  label='Option Shift "'
    back      in = (ESC 'O;')        label='Option ;'
    back_s    in = (ESC 'O:')        label='Option Shift ;'
    help      in = (ESC 'O/')        label='Option ?'
    help_s    in = (ESC 'O?')        label='Option Shift ?'
    edit      in = (ESC 'O.')        label='Option .'
    edit_s    in = (ESC 'O>')        label='Option Shift .'
    down      in = (ESC 'O+')        label='Option D'
    down_s    in = (ESC 'O-')        label='Option Shift D'
    up        in = (ESC 'O(')        label='Option U'
    up_s      in = (ESC 'O)')        label='Option Shift U'
    fwd       in = (ESC 'OX')        label='Option F'
    fwd_s     in = (ESC 'Oo')        label='Option Shift F'
    bkw       in = (ESC 'OW')        label='Option B'
    bkw_s     in = (ESC 'Of')        label='Option Shift B'
    undo      in = (ESC 'Ou')        label='F5  Option 5'
    undo_s    in = (ESC 'Om')        label='    Option Shift 5'
    stop      in = (ESC 'Ov')        label='F6  Option 6'
    stop_s    in = (ESC 'Ol')        label='    Option Shift 6'

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (ESC 'Oq')        label='F1  Option 1'
    f2        in = (ESC 'Or')        label='F2  Option 2'
    f3        in = (ESC 'Os')        label='F3  Option 3'
    f4        in = (ESC 'Ot')        label='F4  Option 4'
    f5        in = (ESC 'Ou')        label='F5  Option 5'
    f6        in = (ESC 'Ov')        label='F6  Option 6'
    f7        in = (ESC 'Ow')        label='F7  Option 7'
    f8        in = (ESC 'Ox')        label='F8  Option 8'
    f9        in = (ESC 'Oy')        label='F9  Option 9'
    f10       in = (ESC 'Oz')        label='10  Option 0'
    f11       in = (ESC 'O{')        label='11  Option Q'
    f12       in = (ESC 'O|')        label='12  Option W'
    f13       in = (ESC 'O}')        label='13  Option E'
    f14       in = (ESC 'O~')        label='14  Option R'
    f15       in = (ESC 'O_')        label='15  Option T'
    f16       in = (ESC 'OU')        label='16  Option Y'
    f1_s      in = (ESC 'Og')        label='    Option Shift 1'
    f2_s      in = (ESC 'Oh')        label='    Option Shift 2'
    f3_s      in = (ESC 'Oi')        label='    Option Shift 3'
    f4_s      in = (ESC 'Oj')        label='    Option Shift 4'
    f5_s      in = (ESC 'Om')        label='    Option Shift 5'
    f6_s      in = (ESC 'Ol')        label='    Option Shift 6'
    f7_s      in = (ESC 'OM')        label='    Option Shift 7'
    f8_s      in = (ESC 'On')        label='    Option Shift 8'
    f9_s      in = (ESC 'Op')        label='    Option Shift 9'
    f10_s     in = (ESC 'OO')        label='    Option Shift 0'
    f11_s     in = (ESC 'Oa')        label='    Option Shift Q'
    f12_s     in = (ESC 'Ob')        label='    Option Shift W'
    f13_s     in = (ESC 'Oc')        label='    Option Shift E'
    f14_s     in = (ESC 'Od')        label='    Option Shift R'
    f15_s     in = (ESC 'Oe')        label='    Option Shift T'
    f16_s     in = (ESC 'OV')        label='    Option Shift Y'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_bold)
    alt_end             out = (stop_bold)
    blink_begin         out = ()                   "not supported"
    blink_end           out = ()                   "not supported"
    hidden_begin        out = ()
    hidden_end          out = ()
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_bold)
    error_end           out = (stop_bold)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = (SO)
    ld_fine_end              out = (SI)
    ld_fine_horizontal       out = (71(16))
    ld_fine_vertical         out = (78(16))
    ld_fine_upper_left       out = (6C(16))
    ld_fine_upper_right      out = (6B(16))
    ld_fine_lower_left       out = (6D(16))
    ld_fine_lower_right      out = (6A(16))
    ld_fine_up_t             out = (77(16))
    ld_fine_down_t           out = (76(16))
    ld_fine_left_t           out = (74(16))
    ld_fine_right_t          out = (75(16))
    ld_fine_cross            out = (6E(16))

    ld_medium_begin          out = (SO start_bold)
    ld_medium_end            out = (SI stop_bold)
    ld_medium_horizontal     out = (71(16))
    ld_medium_vertical       out = (78(16))
    ld_medium_upper_left     out = (6C(16))
    ld_medium_upper_right    out = (6B(16))
    ld_medium_lower_left     out = (6D(16))
    ld_medium_lower_right    out = (6A(16))
    ld_medium_up_t           out = (77(16))
    ld_medium_down_t         out = (76(16))
    ld_medium_left_t         out = (74(16))
    ld_medium_right_t        out = (75(16))
    ld_medium_cross          out = (6E(16))

    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')

    application_string name='REDO_SET_SCREEN_MODE' out=(redo_set_screen_mode)
    application_string name='REDO_SET_LINE_MODE' out=(redo_set_line_mode)

"   END OF TERMINAL DEFINITION FILE FOR MAC_HOST_ECHO_21                            "
*DECK DECK=CSM$MAC_HOST_ECHO_22 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR MACINTOSH                                    "
"   running Control Data CONNECT V2.2                                         "

"       MAC_HOST_ECHO_22                                      MARCH, 1994     "

"   To change the full screen line count for larger screens, make following   "
"   modifications to this Terminal Definition source before recompiling:      "
"     Replace Full_Screen_Line_Count variable value 24 with full screen line  "
"       count (24 to 100) defined in CONNECT Terminal Settings.               "
"     Replace rows = 24 in set_size definitions with full screen line count.  "
"     Replace model_name value with unique terminal name such as              "
"       MAC_HOST_ECHO_22_XX where XX is the full screen line count (24 to 100). "


"   VARIABLES                                                                 "
    Full_Screen_Line_Count    = ('24')        "sets Mac Full_Screen_Line_Count"
    clear_all_tabs            = (ESC '[3g')
    set_80_cols               = (ESC '[?3l')
    set_132_cols              = (ESC '[?3h')
    start_bold                = (ESC '[1m')
    start_inverse             = (ESC '[7m')
    start_underline           = (ESC '[4m')
    stop_bold                 = (ESC '[21m')
    stop_inverse              = (ESC '[27m')
    stop_underline            = (ESC '[24m')
    set_graphics              = (ESC '(B' ESC ')0' SI)
    enable_auto_tab           = (ESC '[=3h')
    enable_auto_wrap          = (ESC '[?7h')
    enable_insertion          = (ESC '[4h')
    disable_insertion         = (ESC '[4l')
    global_protect_on         = (ESC '[=1h')
    global_protect_off        = (ESC '[=1l')
    cursor_pos_normal         = (ESC '[=6l')
    reset_terminal            = (ESC 'c')
    enter_screen_mode         = (ESC '[=5h')
    enter_line_mode           = (ESC '[=5l')
    enter_term_mode           = (ESC '%!2')
    set_echo_on               = (ESC '[12l')
    set_echo_off              = (ESC '[12h')
    NOSVE_host                = (ESC '[1t')
    set_screen_size           = (ESC '[' Full_Screen_Line_Count ';80z')
    redo_set_screen_mode      = (NOSVE_host enter_screen_mode global_protect_on ..
                                clear_all_tabs  set_graphics  enable_auto_wrap  ..
                                enable_auto_tab  cursor_pos_normal)
    redo_set_line_mode        = (enter_line_mode global_protect_off set_graphics)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'MAC_HOST_ECHO_22'
    communications      type  = asynch
    application_string  name  = 'vt100_scrolling'  out = 'true'
    application_string  name='DRIVER_PROCEDURE' out= 'tup$host_echo_mac_boot'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (ESC '[')
    cursor_pos_second        out   = (';')
    cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (ESC '[H')  label='Option H'
    cursor_up                inout = (ESC '[A')  label='up arrow'
    cursor_down              inout = (ESC '[B')  label='down arrow'
    cursor_right             inout = (ESC '[C')  label='right arrow'
    cursor_left              inout = (ESC '[D')  label='left arrow'

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_left           type = wrap_adjacent_next
    char_past_right          type = wrap_adjacent_next
    char_past_last_position  type = wrap_adjacent_next

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE            "for 80/132 column change"
    function_key_leaves_mark value = 0
    has_hidden               value = TRUE            "Full duplex supports hidden"
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
    automatic_tabbing        value = TRUE

"   SCREEN SIZES                                                              "
    set_size  rows = 24  columns = 80   out = (set_80_cols)
    set_size  rows = 24  columns = 132  out = (set_132_cols)

"   TERMINAL CAPABILITIES                                                     "
    insert_char         inout = (ESC '[@')   label='Option Space'
    insert_line_bol     inout = (ESC '[L')   label='Option Shift Space'
    delete_char         inout = (ESC '[P')   label='Option Delete'
    delete_line_bol     inout = (ESC '[M')   label='Option Shift Delete'
    erase_end_of_line   inout = (ESC '[K')   label='Option Clear'
    erase_line_stay     inout = (ESC '[2K')
    erase_end_of_field  inout = (ESC '[N')
    erase_field_stay    inout = (ESC '[2N')
    erase_page_stay     inout = (ESC '[2J')  label='Clear'
    backspace           in = (BS)            label='Delete'
    tab_forward         inout = (HT)         label='Tab'
    tab_backward        inout = (ESC '[Z')   label='Option Tab'
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (ESC 'H')
    tab_clear           inout = (ESC '[g')
    insert_mode_begin   inout = (enable_insertion)
    insert_mode_end     inout = (disable_insertion)

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode out = (NOSVE_host  enter_term_mode enter_screen_mode  ..
                           clear_all_tabs  set_graphics  enable_auto_wrap  ..
                           enable_auto_tab  cursor_pos_normal  set_screen_size)

    set_line_mode   out = (enter_line_mode  set_graphics reset_terminal)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (ESC 'V')
    protect_end         out = (ESC 'W')
    protect_all         out = (ESC '[1p')
    output_begin        out = (global_protect_off disable_insertion)
    output_end          out = (global_protect_on)
    bell_nak            out = (BEL)

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = (CR)              label='Return'
    data      in = (ESC 'O' 27(16))  label='Option "'
    data_s    in = (ESC 'O' 22(16))  label='Option Shift "'
    back      in = (ESC 'O;')        label='Option ;'
    back_s    in = (ESC 'O:')        label='Option Shift ;'
    help      in = (ESC 'O/')        label='Option ?'
    help_s    in = (ESC 'O?')        label='Option Shift ?'
    edit      in = (ESC 'O.')        label='Option .'
    edit_s    in = (ESC 'O>')        label='Option Shift .'
    down      in = (ESC 'O+')        label='Option D'
    down_s    in = (ESC 'O-')        label='Option Shift D'
    up        in = (ESC 'O(')        label='Option U'
    up_s      in = (ESC 'O)')        label='Option Shift U'
    fwd       in = (ESC 'OX')        label='Option F'
    fwd_s     in = (ESC 'Oo')        label='Option Shift F'
    bkw       in = (ESC 'OW')        label='Option B'
    bkw_s     in = (ESC 'Of')        label='Option Shift B'
    undo      in = (ESC 'Ou')        label='F5  Option 5'
    undo_s    in = (ESC 'Om')        label='    Option Shift 5'
    stop      in = (ESC 'Ov')        label='F6  Option 6'
    stop_s    in = (ESC 'Ol')        label='    Option Shift 6'

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (ESC 'Oq')        label='F1  Option 1'
    f2        in = (ESC 'Or')        label='F2  Option 2'
    f3        in = (ESC 'Os')        label='F3  Option 3'
    f4        in = (ESC 'Ot')        label='F4  Option 4'
    f5        in = (ESC 'Ou')        label='F5  Option 5'
    f6        in = (ESC 'Ov')        label='F6  Option 6'
    f7        in = (ESC 'Ow')        label='F7  Option 7'
    f8        in = (ESC 'Ox')        label='F8  Option 8'
    f9        in = (ESC 'Oy')        label='F9  Option 9'
    f10       in = (ESC 'Oz')        label='10  Option 0'
    f11       in = (ESC 'O{')        label='11  Option Q'
    f12       in = (ESC 'O|')        label='12  Option W'
    f13       in = (ESC 'O}')        label='13  Option E'
    f14       in = (ESC 'O~')        label='14  Option R'
    f15       in = (ESC 'O_')        label='15  Option T'
    f16       in = (ESC 'OU')        label='16  Option Y'
    f1_s      in = (ESC 'Og')        label='    Option Shift 1'
    f2_s      in = (ESC 'Oh')        label='    Option Shift 2'
    f3_s      in = (ESC 'Oi')        label='    Option Shift 3'
    f4_s      in = (ESC 'Oj')        label='    Option Shift 4'
    f5_s      in = (ESC 'Om')        label='    Option Shift 5'
    f6_s      in = (ESC 'Ol')        label='    Option Shift 6'
    f7_s      in = (ESC 'OM')        label='    Option Shift 7'
    f8_s      in = (ESC 'On')        label='    Option Shift 8'
    f9_s      in = (ESC 'Op')        label='    Option Shift 9'
    f10_s     in = (ESC 'OO')        label='    Option Shift 0'
    f11_s     in = (ESC 'Oa')        label='    Option Shift Q'
    f12_s     in = (ESC 'Ob')        label='    Option Shift W'
    f13_s     in = (ESC 'Oc')        label='    Option Shift E'
    f14_s     in = (ESC 'Od')        label='    Option Shift R'
    f15_s     in = (ESC 'Oe')        label='    Option Shift T'
    f16_s     in = (ESC 'OV')        label='    Option Shift Y'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_bold)
    alt_end             out = (stop_bold)
    blink_begin         out = ()                   "not supported"
    blink_end           out = ()                   "not supported"
    hidden_begin        out = ()
    hidden_end          out = ()
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_bold)
    error_end           out = (stop_bold)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = (SO)
    ld_fine_end              out = (SI)
    ld_fine_horizontal       out = (71(16))
    ld_fine_vertical         out = (78(16))
    ld_fine_upper_left       out = (6C(16))
    ld_fine_upper_right      out = (6B(16))
    ld_fine_lower_left       out = (6D(16))
    ld_fine_lower_right      out = (6A(16))
    ld_fine_up_t             out = (77(16))
    ld_fine_down_t           out = (76(16))
    ld_fine_left_t           out = (74(16))
    ld_fine_right_t          out = (75(16))
    ld_fine_cross            out = (6E(16))

    ld_medium_begin          out = (SO start_bold)
    ld_medium_end            out = (SI stop_bold)
    ld_medium_horizontal     out = (71(16))
    ld_medium_vertical       out = (78(16))
    ld_medium_upper_left     out = (6C(16))
    ld_medium_upper_right    out = (6B(16))
    ld_medium_lower_left     out = (6D(16))
    ld_medium_lower_right    out = (6A(16))
    ld_medium_up_t           out = (77(16))
    ld_medium_down_t         out = (76(16))
    ld_medium_left_t         out = (74(16))
    ld_medium_right_t        out = (75(16))
    ld_medium_cross          out = (6E(16))

    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')

    application_string name='REDO_SET_SCREEN_MODE' out=(redo_set_screen_mode)
    application_string name='REDO_SET_LINE_MODE' out=(redo_set_line_mode)

"   END OF TERMINAL DEFINITION FILE FOR Macintosh                             "
"   running Control Data CONNECT V2.2                                         "

*DECK DECK=CSM$NCDX EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR NCD16 and NCD19 Xterminals                   "
"   Terminal is to be using xterm with special .Xdefaults entry 'cyber'       "

"                                                                             "
"                NCDX NOS/VE Terminal Definition Key Mappings                 "
"                                                                             "
"                      Key       Modifier        Action                       "
"             +------------------------------------------------+              "
"             | F1 - F12  |          | F1 - F12                |              "
"             |           | Shift    | F1 - F12 Shifted        |              "
"             |------------------------------------------------|              "
"             | F1 - F4   | Ctrl     | F13 - F16               |              "
"             |           | Alt      | F13 - F16 Shifted       |              "
"             |------------------------------------------------|              "
"             | Insert    |          | Enter Insert Mode       |              "
"             |           | Shift    | Insert Line             |              "
"             |           | Ctrl     | Insert Character        |              "
"             |------------------------------------------------|              "
"             | Delete    |          | Delete Character        |              "
"             |           | Shift    | Delete Line             |              "
"             |------------------------------------------------|              "
"             | Home      |          | Put Cursor on Home Line |              "
"             |------------------------------------------------|              "
"             | End       |          | Exit Insert Mode        |              "
"             |           | Ctrl     | Delete to End of Line   |              "
"             |------------------------------------------------|              "
"             | Page Up   |          | Previous Screen         |              "
"             |           | Shift    | Top                     |              "
"             |           | Ctrl     | Half Page Forward       |              "
"             |------------------------------------------------|              "
"             | Page Down |          | Next Screen             |              "
"             |           | Shift    | Bottom                  |              "
"             |           | Ctrl     | Half Page Backward      |              "
"             +------------------------------------------------+              "
"                                                                             "
"
" To run the NCD terminal you need to install a resource file using xrdb.     "
" You may run xrdb on NOS/VE or on UNIX. This deck gives you the input        "
" for both NOS/VE and UNIX.                                                   "
"                                                                             "
" UNIX Installation                                                           "
"                                                                             "
" The following is file which is required in order to use this TDU.           "
" Take it out of this TDU and remove the double-quotes from each end of the   "
" lines.  It can then be used on the unix host when you use xterm.            "
"                                                                             "
"!------------------- beginning of unix file .Xdefaults ----------------------"
"!                                                                            "
"! define cyber VT100 prefix, use xrdb .Xdefaults                             "
"!                                                                            "
"! Note: You must allow the c pre-processor to run on this file.              "
"!       Do NOT use the -nocpp option on the xrdb command.                    "
"!                                                                            "
"!       To allow these key mappings to work, put them in a file on unix,     "
"!       execute the command:                                                 "
"!            xrdb whatever_filename_you_used                                 "
"!       then invoke an xterm like this:                                      "
"!            xterm -name cyber -132 -j                                       "
"!       the '-name cyber' tells it to use the cyber key mapping              "
"!       the '-132' tells it to allow switching to 132 column mode            "
"!       the '-j' tells it to do jump scrolling instead of smooth scrolling   "
"!                (this one is optional)                                      "
"!                                                                            "
"#define CR string(0x0d)                                                      "
"#define ESC string(0x1b)                                                     "
"#define SH_FKEY string(0x1b) string([9)                                      "
"#define PREFIX string(0x1b) string([)                                        "
"cyber*scrollBar:          on                                                 "
"cyber*saveLines:          150                                                "
"cyber*borderWidth:        2                                                  "
"cyber*font:               10x20                                              "
"cyber*boldFont:           10x20B                                             "
"cyber*VT100.geometry:     80x43                                              "
"cyber*VT100.Translations:   #override\                                       "
"     Alt<Key>F1:     SH_FKEY string(25~) CR    \n\                           "
"    Ctrl<Key>F1:     PREFIX  string(25~) CR    \n\                           "
"    Meta<Key>F1:                               \n\                           "
"  Shift <Key>F1:     SH_FKEY string(11~) CR    \n\                           "
"        <Key>F1:             insert()    CR    \n\                           "
"     Alt<Key>F2:     SH_FKEY string(26~) CR    \n\                           "
"    Ctrl<Key>F2:     PREFIX  string(26~) CR    \n\                           "
"    Meta<Key>F2:                               \n\                           "
"  Shift <Key>F2:     SH_FKEY string(12~) CR    \n\                           "
"        <Key>F2:             insert()    CR    \n\                           "
"     Alt<Key>F3:     SH_FKEY string(28~) CR    \n\                           "
"    Ctrl<Key>F3:     PREFIX  string(28~) CR    \n\                           "
"    Meta<Key>F3:                               \n\                           "
"  Shift <Key>F3:     SH_FKEY string(13~) CR    \n\                           "
"        <Key>F3:             insert()    CR    \n\                           "
"     Alt<Key>F4:     SH_FKEY string(29~) CR    \n\                           "
"    Ctrl<Key>F4:     PREFIX  string(29~) CR    \n\                           "
"    Meta<Key>F4:                               \n\                           "
"  Shift <Key>F4:     SH_FKEY string(14~) CR    \n\                           "
"        <Key>F4:             insert()    CR    \n\                           "
"     Alt<Key>F5:                               \n\                           "
"    Ctrl<Key>F5:                               \n\                           "
"    Meta<Key>F5:                               \n\                           "
"  Shift <Key>F5:     SH_FKEY string(15~) CR    \n\                           "
"        <Key>F5:             insert()    CR    \n\                           "
"     Alt<Key>F6:                               \n\                           "
"    Ctrl<Key>F6:                               \n\                           "
"    Meta<Key>F6:                               \n\                           "
"  Shift <Key>F6:     SH_FKEY string(17~) CR    \n\                           "
"        <Key>F6:             insert()    CR    \n\                           "
"     Alt<Key>F7:                               \n\                           "
"    Ctrl<Key>F7:                               \n\                           "
"    Meta<Key>F7:                               \n\                           "
"  Shift <Key>F7:     SH_FKEY string(18~) CR    \n\                           "
"        <Key>F7:             insert()    CR    \n\                           "
"     Alt<Key>F8:                               \n\                           "
"    Ctrl<Key>F8:                               \n\                           "
"    Meta<Key>F8:                               \n\                           "
"  Shift <Key>F8:     SH_FKEY string(19~) CR    \n\                           "
"        <Key>F8:             insert()    CR    \n\                           "
"     Alt<Key>F9:                               \n\                           "
"    Ctrl<Key>F9:                               \n\                           "
"    Meta<Key>F9:                               \n\                           "
"  Shift <Key>F9:     SH_FKEY string(20~) CR    \n\                           "
"        <Key>F9:             insert()    CR    \n\                           "
"     Alt<Key>F10:                              \n\                           "
"    Ctrl<Key>F10:                              \n\                           "
"    Meta<Key>F10:                              \n\                           "
"  Shift <Key>F10:    SH_FKEY string(21~) CR    \n\                           "
"        <Key>F10:            insert()    CR    \n\                           "
"     Alt<Key>F11:                              \n\                           "
"    Ctrl<Key>F11:                              \n\                           "
"    Meta<Key>F11:                              \n\                           "
"  Shift <Key>F11:    SH_FKEY string(23~) CR    \n\                           "
"        <Key>F11:            insert()    CR    \n\                           "
"     Alt<Key>F12:                              \n\                           "
"    Ctrl<Key>F12:                              \n\                           "
"    Meta<Key>F12:                              \n\                           "
"  Shift <Key>F12:    SH_FKEY string(24~) CR    \n\                           "
"        <Key>F12:            insert()    CR    \n\                           "
"        <Key>Home:   PREFIX  string(H)         \n\                           "
"     Alt<Key>Prior:                            \n\                           "
"    Ctrl<Key>Prior:  ESC SH_FKEY string(5~) CR \n\                           "
"    Meta<Key>Prior:                            \n\                           "
"   Shift<Key>Prior:  SH_FKEY string(5~)  CR    \n\                           "
"        <Key>Prior:          insert()    CR    \n\                           "
"     Alt<Key>End:                              \n\                           "
"    Ctrl<Key>End:    PREFIX  string(K)         \n\                           "
"    Meta<Key>End:                              \n\                           "
"   Shift<Key>End:                              \n\                           "
"        <Key>End:    PREFIX  string(4l)        \n\                           "
"     Alt<Key>Next:                             \n\                           "
"    Ctrl<Key>Next:   ESC SH_FKEY string(6~) CR \n\                           "
"    Meta<Key>Next:                             \n\                           "
"   Shift<Key>Next:   SH_FKEY string(6~)  CR    \n\                           "
"        <Key>Next:           insert()    CR    \n\                           "
"     Alt<Key>Insert:                           \n\                           "
"    Ctrl<Key>Insert: PREFIX  string(@)         \n\                           "
"    Meta<Key>Insert:                           \n\                           "
"   Shift<Key>Insert: PREFIX  string(L)         \n\                           "
"        <Key>Insert: PREFIX  string(4h)        \n\                           "
"     Alt<Key>Delete:                           \n\                           "
"    Ctrl<Key>Delete: PREFIX  string(P)         \n\                           "
"    Meta<Key>Delete:                           \n\                           "
"   Shift<Key>Delete: PREFIX  string(M)         \n\                           "
"        <Key>Delete: PREFIX  string(P)                                       "
"!                                                                            "
"!---------------------- end of unix file .Xdefaults -------------------------"
"
" NOS/VE Installation                                                           "
"
" The following is file which is required in order to use this TDU.
" Take it out of this TDU and remove the quote from the beginning of each line
" lines.  It can then be used to run xrdb from the NOS/VE host.
" To allow these key mappings to work, put them in a file on NOS/VE and
"  execute the command:
"             xrdb whatever_filename_you_used
" ------------------ beginning of NOS/VE file _xdefaults ----------------------
"cyber*scrollBar: on
"cyber*saveLines: 150
"cyber*borderWidth: 2
"cyber*font: 10x20
"cyber*boldFont: 10x20B
"cyber*VT100.geometry: 80x43
"cyber*VT100.Translations: #override\
"     Alt<Key>F1:     string(0x1b) string([9) string(25~) string(0x0d)    \n\
"    Ctrl<Key>F1:     string(0x1b) string([)  string(25~) string(0x0d)    \n\
"    Meta<Key>F1:                               \n\
"  Shift <Key>F1:     string(0x1b) string([9) string(11~) string(0x0d)    \n\
"        <Key>F1:             insert()    string(0x0d)    \n\
"     Alt<Key>F2:     string(0x1b) string([9) string(26~) string(0x0d)    \n\
"    Ctrl<Key>F2:     string(0x1b) string([)  string(26~) string(0x0d)    \n\
"    Meta<Key>F2:                               \n\
"  Shift <Key>F2:     string(0x1b) string([9) string(12~) string(0x0d)    \n\
"        <Key>F2:             insert()    string(0x0d)    \n\
"     Alt<Key>F3:     string(0x1b) string([9) string(28~) string(0x0d)    \n\
"    Ctrl<Key>F3:     string(0x1b) string([)  string(28~) string(0x0d)    \n\
"    Meta<Key>F3:                               \n\
"  Shift <Key>F3:     string(0x1b) string([9) string(13~) string(0x0d)    \n\
"        <Key>F3:             insert()    string(0x0d)    \n\
"     Alt<Key>F4:     string(0x1b) string([9) string(29~) string(0x0d)    \n\
"    Ctrl<Key>F4:     string(0x1b) string([)  string(29~) string(0x0d)    \n\
"    Meta<Key>F4:                               \n\
" Shift <Key>F4:     string(0x1b) string([9) string(14~) string(0x0d)    \n\
"        <Key>F4:             insert()    string(0x0d)    \n\
"     Alt<Key>F5:                               \n\
"    Ctrl<Key>F5:                               \n\
"    Meta<Key>F5:                               \n\
"  Shift <Key>F5:     string(0x1b) string([9) string(15~) string(0x0d)    \n\
"        <Key>F5:             insert()    string(0x0d)    \n\
"     Alt<Key>F6:                               \n\
"    Ctrl<Key>F6:                               \n\
"    Meta<Key>F6:                               \n\
"  Shift <Key>F6:     string(0x1b) string([9) string(17~) string(0x0d)    \n\
"       <Key>F6:             insert()    string(0x0d)    \n\
"    Alt<Key>F7:                               \n\
"   Ctrl<Key>F7:                               \n\
"   Meta<Key>F7:                               \n\
" Shift <Key>F7:     string(0x1b) string([9) string(18~) string(0x0d)    \n\
"       <Key>F7:             insert()    string(0x0d)    \n\
"     Alt<Key>F8:                               \n\
"    Ctrl<Key>F8:                               \n\
"    Meta<Key>F8:                               \n\
"  Shift <Key>F8:     string(0x1b) string([9) string(19~) string(0x0d)    \n\
"        <Key>F8:             insert()    string(0x0d)    \n\
"     Alt<Key>F9:                               \n\
"    Ctrl<Key>F9:                               \n\
"    Meta<Key>F9:                               \n\
"  Shift <Key>F9:     string(0x1b) string([9) string(20~) string(0x0d)    \n\
"        <Key>F9:             insert()    string(0x0d)    \n\
"     Alt<Key>F10:                              \n\
"    Ctrl<Key>F10:                              \n\
"    Meta<Key>F10:                              \n\
"  Shift <Key>F10:    string(0x1b) string([9) string(21~) string(0x0d)    \n\
"        <Key>F10:            insert()    string(0x0d)    \n\
"     Alt<Key>F11:                              \n\
"    Ctrl<Key>F11:                              \n\
"    Meta<Key>F11:                              \n\
"  Shift <Key>F11:    string(0x1b) string([9) string(23~) string(0x0d)    \n\
"        <Key>F11:            insert()    string(0x0d)    \n\
"     Alt<Key>F12:                              \n\
"    Ctrl<Key>F12:                              \n\
"    Meta<Key>F12:                              \n\
"  Shift <Key>F12:    string(0x1b) string([9) string(24~) string(0x0d)    \n\
"        <Key>F12:            insert()    string(0x0d)    \n\
"        <Key>Home:   string(0x1b) string([)  string(H)         \n\
"     Alt<Key>Prior:                            \n\
"    Ctrl<Key>Prior:  string(0x1b) string(0x1b) string([9) string(5~) string(0x0d) \n\
"    Meta<Key>Prior:                            \n\
"   Shift<Key>Prior:  string(0x1b) string([9) string(5~)  string(0x0d)    \n\
"        <Key>Prior:          insert()    string(0x0d)    \n\
"     Alt<Key>End:                              \n\
"    Ctrl<Key>End:    string(0x1b) string([)  string(K)         \n\
"    Meta<Key>End:                              \n\
"   Shift<Key>End:                              \n\
"        <Key>End:    string(0x1b) string([)  string(4l)        \n\
"     Alt<Key>Next:                             \n\
"    Ctrl<Key>Next:   string(0x1b) string(0x1b) string([9) string(6~) string(0x0d) \n\
"    Meta<Key>Next:                             \n\
"   Shift<Key>Next:   string(0x1b) string([9) string(6~)  string(0x0d)    \n\
"        <Key>Next:           insert()    string(0x0d)    \n\
"     Alt<Key>Insert:                           \n\
"    Ctrl<Key>Insert: string(0x1b) string([)  string(@)         \n\
"    Meta<Key>Insert:                           \n\
"   Shift<Key>Insert: string(0x1b) string([)  string(L)         \n\
"        <Key>Insert: string(0x1b) string([)  string(4h)        \n\
"     Alt<Key>Delete:                           \n\
"    Ctrl<Key>Delete: string(0x1b) string([)  string(P)         \n\
"   Meta<Key>Delete:                           \n\
"   Shift<Key>Delete: string(0x1b) string([)  string(M)         \n\
"        <Key>Delete: string(0x1b) string([)  string(P)
" ---------------------- end of NOS/VE file _xdefaults -------------------------

"   VARIABLES                                                                 "
prefix              = (esc '[')
sh_fkey             = (esc '[9')
clear_all_tabs      = (prefix '3g')
clear_home          = (prefix 'H' prefix 'J')
enable_cursor_mode  = (prefix '?1l')
enter_ansi_mode     = (esc '<')
g0_us_characters    = (esc '(B')
g1_graphics_chars   = (esc ')0')
application_keypad  = (esc '=')
numeric_keypad      = (esc '>')
normal_attributes   = (prefix 'm')
select_g0_char_set  = (si)
set_80_cols         = (prefix '?3l')
set_132_cols        = (prefix '?3h')
start_alternate     = (prefix '1m')
start_blink         = (prefix '5m')
start_inverse       = (prefix '7m')
start_underline     = (prefix '4m')
stop_alternate      = (normal_attributes)
stop_blink          = (normal_attributes)
stop_inverse        = (normal_attributes)
stop_underline      = (normal_attributes)
wraparound_off      = (prefix '?7l')
wraparound_on       = (prefix '?7h')
start_insert_mode   = (prefix '4h')
stop_insert_mode    = (prefix '4l')

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'NCDX'
communications      type  = asynch
application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (';')
cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 'H') label='Home'
cursor_up                inout = (prefix 'A')
cursor_down              inout = (prefix 'B')
cursor_left              inout = (prefix 'D')
cursor_right             inout = (prefix 'C')

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 0
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 43 columns = 80   out = (set_80_cols)
set_size       rows = 43 columns = 132  out = (set_132_cols)

"   SCREEN AND LINE MODE TRANSITION                                           "
set_screen_mode     out = (enter_ansi_mode stop_insert_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     wraparound_off enable_cursor_mode)


set_line_mode     out = (enter_ansi_mode stop_insert_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     wraparound_on enable_cursor_mode)

"   TERMINAL CAPABILITIES                                                     "
delete_char         inout = (prefix 'P')  label='Delete'
delete_line_stay    inout = (prefix 'M')  label='Shift-Delete'
erase_end_of_line   inout = (prefix 'K')  label='Ctrl-End'
erase_line_stay     inout = (prefix '2K')
erase_page_home       out = (clear_home)
insert_char         inout = (prefix '@')  label='Ctrl-Insert'
insert_line_stay    inout = (prefix 'L')  label='Shift-Insert'
insert_mode_begin   inout = (start_insert_mode) label='Insert'
insert_mode_end     inout = (stop_insert_mode)  label='End'
tab_forward         inout = (ht)
tab_clear_all       inout = (clear_all_tabs)
tab_set             inout = (esc 'H')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
backspace           in = bs

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (prefix '11~') label='F1'
f2        in = (prefix '12~') label='F2'
f3        in = (prefix '13~') label='F3'
f4        in = (prefix '14~') label='F4'
f5        in = (prefix '15~') label='F5'
f6        in = (prefix '17~') label='F6'
f7        in = (prefix '18~') label='F7'
f8        in = (prefix '19~') label='F8'
f9        in = (prefix '20~') label='F9'
f10       in = (prefix '21~') label='10'
f11       in = (prefix '23~') label='11'
f12       in = (prefix '24~') label='12'
f13       in = (prefix '25~') label='C1'
f14       in = (prefix '26~') label='C2'
f15       in = (prefix '28~') label='C3'
f16       in = (prefix '29~') label='C4'

f1_s      in = (sh_fkey '11~') label='  Sh'
f2_s      in = (sh_fkey '12~') label='  Sh'
f3_s      in = (sh_fkey '13~') label='  Sh'
f4_s      in = (sh_fkey '14~') label='  Sh'
f5_s      in = (sh_fkey '15~') label='  Sh'
f6_s      in = (sh_fkey '17~') label='  Sh'
f7_s      in = (sh_fkey '18~') label='  Sh'
f8_s      in = (sh_fkey '19~') label='  Sh'
f9_s      in = (sh_fkey '20~') label='  Sh'
f10_s     in = (sh_fkey '21~') label='  Sh'
f11_s     in = (sh_fkey '23~') label='  Sh'
f12_s     in = (sh_fkey '24~') label='  Sh'
f13_s     in = (sh_fkey '25~') label='A1'
f14_s     in = (sh_fkey '26~') label='A2'
f15_s     in = (sh_fkey '28~') label='A3'
f16_s     in = (sh_fkey '29~') label='A4'



"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = (prefix '5~') label='PU'
fwd       in = (prefix '6~') label='PD'
back      in = (prefix '13~') label='F3'
help      in = (prefix '14~') label='F4'
undo      in = (prefix '15~') label='F5'
stop      in = (prefix '17~') label='F6'
bkw_s     in = (sh_fkey '5~') label='Shift-PU'
fwd_s     in = (sh_fkey '6~') label='Shift-PD'
undo_s    in = ()
stop_s    in = ()
down      in = (esc sh_fkey '5~') label='Ctrl-PD'
down_s    in = ()
up        in = (esc sh_fkey '6~') label='Ctrl-PU'
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_alternate)
alt_end             out = (stop_alternate)
blink_begin         out = (start_blink)
blink_end           out = (stop_blink)
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = (so)
ld_fine_end              out = (si)
ld_fine_horizontal       out = 'q'
ld_fine_vertical         out = 'x'
ld_fine_upper_left       out = 'l'
ld_fine_upper_right      out = 'k'
ld_fine_lower_left       out = 'm'
ld_fine_lower_right      out = 'j'
ld_fine_up_t             out = 'w'
ld_fine_down_t           out = 'v'
ld_fine_left_t           out = 't'
ld_fine_right_t          out = 'u'
ld_fine_cross            out = 'n'
ld_medium_begin          out = (so start_alternate)
ld_medium_end            out = (si stop_alternate)
ld_medium_horizontal     out = 'q'
ld_medium_vertical       out = 'x'
ld_medium_upper_left     out = 'l'
ld_medium_upper_right    out = 'k'
ld_medium_lower_left     out = 'm'
ld_medium_lower_right    out = 'j'
ld_medium_up_t           out = 'w'
ld_medium_down_t         out = 'v'
ld_medium_left_t         out = 't'
ld_medium_right_t        out = 'u'
ld_medium_cross          out = 'n'
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR xterminal "
*DECK DECK=CSM$NCDX_24_80 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR NCD16 and NCD19 Xterminals                   "
"   Terminal is to be using xterm with special .Xdefaults entry               "

"                                                                             "
"                NCDX NOS/VE Terminal Definition Key Mappings                 "
"                                                                             "
"                      Key       Modifier        Action                       "
"             +------------------------------------------------+              "
"             | F1 - F12  |          | F1 - F12                |              "
"             |           | Shift    | F1 - F12 Shifted        |              "
"             |------------------------------------------------|              "
"             | F1 - F4   | Ctrl     | F13 - F16               |              "
"             |           | Alt      | F13 - F16 Shifted       |              "
"             |------------------------------------------------|              "
"             | Insert    |          | Enter Insert Mode       |              "
"             |           | Shift    | Insert Line             |              "
"             |           | Ctrl     | Insert Character        |              "
"             |------------------------------------------------|              "
"             | Delete    |          | Delete Character        |              "
"             |           | Shift    | Delete Line             |              "
"             |------------------------------------------------|              "
"             | Home      |          | Put Cursor on Home Line |              "
"             |------------------------------------------------|              "
"             | End       |          | Exit Insert Mode        |              "
"             |           | Ctrl     | Delete to End of Line   |              "
"             |------------------------------------------------|              "
"             | Page Up   |          | Previous Screen         |              "
"             |           | Shift    | Top                     |              "
"             |           | Ctrl     | Half Page Forward       |              "
"             |------------------------------------------------|              "
"             | Page Down |          | Next Screen             |              "
"             |           | Shift    | Bottom                  |              "
"             |           | Ctrl     | Half Page Backward      |              "
"             +------------------------------------------------+              "
"                                                                             "
"
" To run the NCD terminal you need to install a resource file using xrdb.     "
" You may run xrdb on NOS/VE or on UNIX. This deck gives you the input        "
" for both NOS/VE and UNIX.                                                   "
"                                                                             "
" UNIX Installation                                                           "
"                                                                             "
" The following is file which is required in order to use this TDU.           "
" Take it out of this TDU and remove the double-quotes from each end of the   "
" lines.  It can then be used on the unix host when you use xterm.            "
"                                                                             "
"!------------------- beginning of unix file .Xdefaults ----------------------"
"!                                                                            "
"! define xterm VT100 prefix, use xrdb .Xdefaults                             "
"!                                                                            "
"! Note: You must allow the c pre-processor to run on this file.              "
"!       Do NOT use the -nocpp option on the xrdb command.                    "
"!                                                                            "
"!       To allow these key mappings to work, put them in a file on unix,     "
"!       execute the command:                                                 "
"!            xrdb whatever_filename_you_used                                 "
"!       then invoke an xterm like this:                                      "
"!            xterm -name xterm -132 -j                                       "
"!       the '-name xterm' tells it to use the xterm key mapping              "
"!       the '-132' tells it to allow switching to 132 column mode            "
"!       the '-j' tells it to do jump scrolling instead of smooth scrolling   "
"!                (this one is optional)                                      "
"!                                                                            "
"#define CR string(0x0d)                                                      "
"#define ESC string(0x1b)                                                     "
"#define SH_FKEY string(0x1b) string([9)                                      "
"#define PREFIX string(0x1b) string([)                                        "
"xterm*scrollBar:          on                                                 "
"xterm*saveLines:          150                                                "
"xterm*borderWidth:        2                                                  "
"xterm*c132:               on                                                 "
"xterm*font:               10x20                                              "
"xterm*boldFont:           10x20B                                             "
"xterm*VT100.geometry:     80x24                                              "
"#xterm*VT100.background: cyan                                                "
"#xterm*VT100.foreground: blue                                                "
"xterm*VT100.Translations:   #override\                                       "
"     Alt<Key>F1:     SH_FKEY string(25~) CR    \n\                           "
"    Ctrl<Key>F1:     PREFIX  string(25~) CR    \n\                           "
"    Meta<Key>F1:                               \n\                           "
"  Shift <Key>F1:     SH_FKEY string(11~) CR    \n\                           "
"        <Key>F1:     PREFIX  string(11~) CR    \n\                           "
"     Alt<Key>F2:     SH_FKEY string(26~) CR    \n\                           "
"    Ctrl<Key>F2:     PREFIX  string(26~) CR    \n\                           "
"    Meta<Key>F2:                               \n\                           "
"  Shift <Key>F2:     SH_FKEY string(12~) CR    \n\                           "
"        <Key>F2:     PREFIX  string(12~) CR    \n\                           "
"     Alt<Key>F3:     SH_FKEY string(28~) CR    \n\                           "
"    Ctrl<Key>F3:     PREFIX  string(28~) CR    \n\                           "
"    Meta<Key>F3:                               \n\                           "
"  Shift <Key>F3:     SH_FKEY string(13~) CR    \n\                           "
"        <Key>F3:     PREFIX  string(13~) CR    \n\                           "
"     Alt<Key>F4:     SH_FKEY string(29~) CR    \n\                           "
"    Ctrl<Key>F4:     PREFIX  string(29~) CR    \n\                           "
"    Meta<Key>F4:                               \n\                           "
"  Shift <Key>F4:     SH_FKEY string(14~) CR    \n\                           "
"        <Key>F4:     PREFIX  string(14~) CR    \n\                           "
"     Alt<Key>F5:                               \n\                           "
"    Ctrl<Key>F5:                               \n\                           "
"    Meta<Key>F5:                               \n\                           "
"  Shift <Key>F5:     SH_FKEY string(15~) CR    \n\                           "
"        <Key>F5:     PREFIX  string(15~) CR    \n\                           "
"     Alt<Key>F6:                               \n\                           "
"    Ctrl<Key>F6:                               \n\                           "
"    Meta<Key>F6:                               \n\                           "
"  Shift <Key>F6:     SH_FKEY string(17~) CR    \n\                           "
"        <Key>F6:     PREFIX  string(17~) CR    \n\                           "
"     Alt<Key>F7:                               \n\                           "
"    Ctrl<Key>F7:                               \n\                           "
"    Meta<Key>F7:                               \n\                           "
"  Shift <Key>F7:     SH_FKEY string(18~) CR    \n\                           "
"        <Key>F7:     PREFIX  string(18~) CR    \n\                           "
"     Alt<Key>F8:                               \n\                           "
"    Ctrl<Key>F8:                               \n\                           "
"    Meta<Key>F8:                               \n\                           "
"  Shift <Key>F8:     SH_FKEY string(19~) CR    \n\                           "
"        <Key>F8:     PREFIX  string(19~) CR    \n\                           "
"     Alt<Key>F9:                               \n\                           "
"    Ctrl<Key>F9:                               \n\                           "
"    Meta<Key>F9:                               \n\                           "
"  Shift <Key>F9:     SH_FKEY string(20~) CR    \n\                           "
"        <Key>F9:     PREFIX  string(20~) CR    \n\                           "
"     Alt<Key>F10:                              \n\                           "
"    Ctrl<Key>F10:                              \n\                           "
"    Meta<Key>F10:                              \n\                           "
"  Shift <Key>F10:    SH_FKEY string(21~) CR    \n\                           "
"        <Key>F10:    PREFIX  string(21~) CR    \n\                           "
"     Alt<Key>F11:                              \n\                           "
"    Ctrl<Key>F11:                              \n\                           "
"    Meta<Key>F11:                              \n\                           "
"  Shift <Key>F11:    SH_FKEY string(23~) CR    \n\                           "
"        <Key>F11:    PREFIX  string(23~) CR    \n\                           "
"     Alt<Key>F12:                              \n\                           "
"    Ctrl<Key>F12:                              \n\                           "
"    Meta<Key>F12:                              \n\                           "
"  Shift <Key>F12:    SH_FKEY string(24~) CR    \n\                           "
"        <Key>F12:    PREFIX  string(24~) CR    \n\                           "
"        <Key>Home:   PREFIX  string(H)         \n\                           "
"     Alt<Key>Prior:                            \n\                           "
"    Ctrl<Key>Prior:  ESC SH_FKEY string(5~) CR \n\                           "
"    Meta<Key>Prior:                            \n\                           "
"   Shift<Key>Prior:  SH_FKEY string(5~)  CR    \n\                           "
"        <Key>Prior:  PREFIX  string(5~)  CR    \n\                           "
"     Alt<Key>End:                              \n\                           "
"    Ctrl<Key>End:    PREFIX  string(K)         \n\                           "
"    Meta<Key>End:                              \n\                           "
"   Shift<Key>End:                              \n\                           "
"        <Key>End:    PREFIX  string(4l)        \n\                           "
"     Alt<Key>Next:                             \n\                           "
"    Ctrl<Key>Next:   ESC SH_FKEY string(6~) CR \n\                           "
"    Meta<Key>Next:                             \n\                           "
"   Shift<Key>Next:   SH_FKEY string(6~)  CR    \n\                           "
"        <Key>Next:   PREFIX  string(6~)  CR    \n\                           "
"     Alt<Key>Insert:                           \n\                           "
"    Ctrl<Key>Insert: PREFIX  string(@)         \n\                           "
"    Meta<Key>Insert:                           \n\                           "
"   Shift<Key>Insert: PREFIX  string(L)         \n\                           "
"        <Key>Insert: PREFIX  string(4h)        \n\                           "
"     Alt<Key>Delete:                           \n\                           "
"    Ctrl<Key>Delete: PREFIX  string(P)         \n\                           "
"    Meta<Key>Delete:                           \n\                           "
"   Shift<Key>Delete: PREFIX  string(M)         \n\                           "
"        <Key>Delete: PREFIX  string(P)                                       "
"!                                                                            "
"!---------------------- end of unix file .Xdefaults -------------------------"
"
" NOS/VE Installation                                                           "
"
" The following is file which is required in order to use this TDU.
" Take it out of this TDU and remove the quote from the beginning of each line
" lines.  It can then be used to run xrdb from the NOS/VE host.
" To allow these key mappings to work, put them in a file on NOS/VE and
"  execute the command:
"             xrdb whatever_filename_you_used
" ------------------ beginning of NOS/VE file _xdefaults ----------------------
"xterm*scrollBar: on
"xterm*saveLines: 150
"xterm*borderWidth: 2
"xterm*c132: on
"xterm*font: 10x20
"xterm*boldFont: 10x20B
"xterm*VT100.geometry: 80x24
"#xterm*VT100.background: cyan
"#xterm*VT100.foreground: blue
"xterm*VT100.Translations: #override\
"     Alt<Key>F1:     string(0x1b) string([9) string(25~) string(0x0d)    \n\
"    Ctrl<Key>F1:     string(0x1b) string([)  string(25~) string(0x0d)    \n\
"    Meta<Key>F1:                               \n\
"  Shift <Key>F1:     string(0x1b) string([9) string(11~) string(0x0d)    \n\
"        <Key>F1:     string(0x1b) string([)  string(11~) string(0x0d)    \n\
"     Alt<Key>F2:     string(0x1b) string([9) string(26~) string(0x0d)    \n\
"    Ctrl<Key>F2:     string(0x1b) string([)  string(26~) string(0x0d)    \n\
"    Meta<Key>F2:                               \n\
"  Shift <Key>F2:     string(0x1b) string([9) string(12~) string(0x0d)    \n\
"        <Key>F2:     string(0x1b) string([) string(12~) string(0x0d)    \n\
"     Alt<Key>F3:     string(0x1b) string([9) string(28~) string(0x0d)    \n\
"    Ctrl<Key>F3:     string(0x1b) string([)  string(28~) string(0x0d)    \n\
"    Meta<Key>F3:                               \n\
"  Shift <Key>F3:     string(0x1b) string([9) string(13~) string(0x0d)    \n\
"        <Key>F3:     string(0x1b) string([) string(13~) string(0x0d)    \n\
"     Alt<Key>F4:     string(0x1b) string([9) string(29~) string(0x0d)    \n\
"    Ctrl<Key>F4:     string(0x1b) string([)  string(29~) string(0x0d)    \n\
"    Meta<Key>F4:                               \n\
" Shift <Key>F4:     string(0x1b) string([9) string(14~) string(0x0d)    \n\
"        <Key>F4:    string(0x1b) string([) string(14~) string(0x0d)    \n\
"     Alt<Key>F5:                               \n\
"    Ctrl<Key>F5:                               \n\
"    Meta<Key>F5:                               \n\
"  Shift <Key>F5:     string(0x1b) string([9) string(15~) string(0x0d)    \n\
"        <Key>F5:     string(0x1b) string([) string(15~) string(0x0d)    \n\
"     Alt<Key>F6:                               \n\
"    Ctrl<Key>F6:                               \n\
"    Meta<Key>F6:                               \n\
"  Shift <Key>F6:     string(0x1b) string([9) string(17~) string(0x0d)    \n\
"       <Key>F6:      string(0x1b) string([) string(17~) string(0x0d)    \n\
"    Alt<Key>F7:                               \n\
"   Ctrl<Key>F7:                               \n\
"   Meta<Key>F7:                               \n\
" Shift <Key>F7:     string(0x1b) string([9) string(18~) string(0x0d)    \n\
"       <Key>F7:     string(0x1b) string([) string(18~) string(0x0d)    \n\
"     Alt<Key>F8:                               \n\
"    Ctrl<Key>F8:                               \n\
"    Meta<Key>F8:                               \n\
"  Shift <Key>F8:     string(0x1b) string([9) string(19~) string(0x0d)    \n\
"        <Key>F8:     string(0x1b) string([) string(19~) string(0x0d)    \n\
"     Alt<Key>F9:                               \n\
"    Ctrl<Key>F9:                               \n\
"    Meta<Key>F9:                               \n\
"  Shift <Key>F9:     string(0x1b) string([9) string(20~) string(0x0d)    \n\
"        <Key>F9:     string(0x1b) string([) string(20~) string(0x0d)    \n\
"     Alt<Key>F10:                              \n\
"    Ctrl<Key>F10:                              \n\
"    Meta<Key>F10:                              \n\
"  Shift <Key>F10:    string(0x1b) string([9) string(21~) string(0x0d)    \n\
"        <Key>F10:    string(0x1b) string([) string(21~) string(0x0d)    \n\
"     Alt<Key>F11:                              \n\
"    Ctrl<Key>F11:                              \n\
"    Meta<Key>F11:                              \n\
"  Shift <Key>F11:    string(0x1b) string([9) string(23~) string(0x0d)    \n\
"        <Key>F11:    string(0x1b) string([) string(23~) string(0x0d)    \n\
"     Alt<Key>F12:                              \n\
"    Ctrl<Key>F12:                              \n\
"    Meta<Key>F12:                              \n\
"  Shift <Key>F12:    string(0x1b) string([9) string(24~) string(0x0d)    \n\
"        <Key>F12:    string(0x1b) string([) string(24~) string(0x0d)    \n\
"        <Key>Home:   string(0x1b) string([)  string(H)         \n\
"     Alt<Key>Prior:                            \n\
"    Ctrl<Key>Prior:  string(0x1b) string(0x1b) string([9) string(5~) string(0x0d) \n\
"    Meta<Key>Prior:                            \n\
"   Shift<Key>Prior:  string(0x1b) string([9) string(5~)  string(0x0d)    \n\
"        <Key>Prior:  string(0x1b) string([) string(5~) string(0x0d)    \n\
"     Alt<Key>End:                              \n\
"    Ctrl<Key>End:    string(0x1b) string([)  string(K)         \n\
"    Meta<Key>End:                              \n\
"   Shift<Key>End:                              \n\
"        <Key>End:    string(0x1b) string([)  string(4l)        \n\
"     Alt<Key>Next:                             \n\
"    Ctrl<Key>Next:   string(0x1b) string(0x1b) string([9) string(6~) string(0x0d) \n\
"    Meta<Key>Next:                             \n\
"   Shift<Key>Next:   string(0x1b) string([9) string(6~)  string(0x0d)    \n\
"        <Key>Next:   string(0x1b) string([) string(6~) string(0x0d)    \n\
"     Alt<Key>Insert:                           \n\
"    Ctrl<Key>Insert: string(0x1b) string([)  string(@)         \n\
"    Meta<Key>Insert:                           \n\
"   Shift<Key>Insert: string(0x1b) string([)  string(L)         \n\
"        <Key>Insert: string(0x1b) string([)  string(4h)        \n\
"     Alt<Key>Delete:                           \n\
"    Ctrl<Key>Delete: string(0x1b) string([)  string(P)         \n\
"   Meta<Key>Delete:                           \n\
"   Shift<Key>Delete: string(0x1b) string([)  string(M)         \n\
"        <Key>Delete: string(0x1b) string([)  string(P)
" ---------------------- end of NOS/VE file _xdefaults -------------------------

"   VARIABLES                                                                 "
prefix              = (esc '[')
alt_screen_buffer   = (prefix '?47h')
sh_fkey             = (esc '[9')
clear_all_tabs      = (prefix '3g')
clear_home          = (prefix 'H' prefix 'J')
disable_mouse       = (prefix '?1002l')
enable_cursor_mode  = (prefix '?1l')
enable_mouse        = (prefix '?1002h')
enter_ansi_mode     = (esc '<')
g0_us_characters    = (esc '(B')
g1_graphics_chars   = (esc ')0')
application_keypad  = (esc '=')
numeric_keypad      = (esc '>')
normal_attributes   = (prefix 'm')
normal_screen_buffer= (prefix '?47l')
restore_cursor      = (esc '8')
save_cursor         = (esc '7')
select_g0_char_set  = (si)
set_80_cols         = (prefix '?3l')
set_132_cols        = (prefix '?3h')
start_alternate     = (prefix '1m')
start_blink         = (prefix '5m')
start_inverse       = (prefix '7m')
start_underline     = (prefix '4m')
stop_alternate      = (normal_attributes)
stop_blink          = (normal_attributes)
stop_inverse        = (normal_attributes)
stop_underline      = (normal_attributes)
wraparound_off      = (prefix '?7l')
wraparound_on       = (prefix '?7h')
start_insert_mode   = (prefix '4h')
stop_insert_mode    = (prefix '4l')

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'NCDX_24_80'
communications      type  = asynch
application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (';')
cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 'H') label='Home'
cursor_up                inout = (prefix 'A')
cursor_down              inout = (prefix 'B')
cursor_left              inout = (prefix 'D')
cursor_right             inout = (prefix 'C')

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 0
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80   out = (set_80_cols)
set_size       rows = 43 columns = 80   out = (set_80_cols)
set_size       rows = 24 columns = 132  out = (set_132_cols)
set_size       rows = 43 columns = 132  out = (set_132_cols)

"   SCREEN AND LINE MODE TRANSITION                                           "

" You may restore the text on the screen after exiting a full screen
" application if you add alt_screen_buffer to the set_screen_command. If you add
" alt_screen_buffer you may see the following results to occur.

" - REDO acts as a full screen utility, so when you hit redo, an empty screen
"   comes up with only the line you are editing.
"
" - With page_width set to 132, when you enter a full screen utility, the
"   xterm window momentarily goes to 80 columns and then back to 132.  The
"   result of this is that when you leave the full screen utility, you only
"   have the information from the first 80 columns left on your screen.
"
" - Sometimes when you exit the full screen utility, especially if you have
"   gone into line mode sometime during the session, the cursor will be left
"   at the top of the screen.  The following line can be used to move your
"   cursor to the bottom of the screen:
"      putl $char(' ' esc '[40B')

set_screen_mode     out = (save_cursor "alt_screen_buffer" ..
     enter_ansi_mode stop_insert_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     wraparound_off enable_cursor_mode enable_mouse)


set_line_mode     out = (enter_ansi_mode stop_insert_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set disable_mouse ..
     wraparound_on normal_screen_buffer restore_cursor enable_cursor_mode)

"   TERMINAL CAPABILITIES                                                     "
delete_char         inout = (prefix 'P')  label='Delete'
delete_line_stay    inout = (prefix 'M')  label='Shift-Delete'
erase_end_of_line   inout = (prefix 'K')  label='Ctrl-End'
erase_line_stay     inout = (prefix '2K')
erase_page_home       out = (clear_home)
insert_char         inout = (prefix '@')  label='Ctrl-Insert'
insert_line_stay    inout = (prefix 'L')  label='Shift-Insert'
insert_mode_begin   inout = (start_insert_mode) label='Insert'
insert_mode_end     inout = (stop_insert_mode)  label='End'
tab_forward         inout = (ht)
tab_clear_all       inout = (clear_all_tabs)
tab_set             inout = (esc 'H')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
backspace           in = bs

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (prefix '11~') label='F1'
f2        in = (prefix '12~') label='F2'
f3        in = (prefix '13~') label='F3'
f4        in = (prefix '14~') label='F4'
f5        in = (prefix '15~') label='F5'
f6        in = (prefix '17~') label='F6'
f7        in = (prefix '18~') label='F7'
f8        in = (prefix '19~') label='F8'
f9        in = (prefix '20~') label='F9'
f10       in = (prefix '21~') label='10'
f11       in = (prefix '23~') label='11'
f12       in = (prefix '24~') label='12'
f13       in = (prefix '25~') label='C1'
f14       in = (prefix '26~') label='C2'
f15       in = (prefix '28~') label='C3'
f16       in = (prefix '29~') label='C4'

f1_s      in = (sh_fkey '11~') label='  Sh'
f2_s      in = (sh_fkey '12~') label='  Sh'
f3_s      in = (sh_fkey '13~') label='  Sh'
f4_s      in = (sh_fkey '14~') label='  Sh'
f5_s      in = (sh_fkey '15~') label='  Sh'
f6_s      in = (sh_fkey '17~') label='  Sh'
f7_s      in = (sh_fkey '18~') label='  Sh'
f8_s      in = (sh_fkey '19~') label='  Sh'
f9_s      in = (sh_fkey '20~') label='  Sh'
f10_s     in = (sh_fkey '21~') label='  Sh'
f11_s     in = (sh_fkey '23~') label='  Sh'
f12_s     in = (sh_fkey '24~') label='  Sh'
f13_s     in = (sh_fkey '25~') label='A1'
f14_s     in = (sh_fkey '26~') label='A2'
f15_s     in = (sh_fkey '28~') label='A3'
f16_s     in = (sh_fkey '29~') label='A4'



"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = (prefix '5~') label='PU'
fwd       in = (prefix '6~') label='PD'
back      in = (prefix '13~') label='F3'
help      in = (prefix '14~') label='F4'
undo      in = (prefix '15~') label='F5'
stop      in = (prefix '17~') label='F6'
bkw_s     in = (sh_fkey '5~') label='Shift-PU'
fwd_s     in = (sh_fkey '6~') label='Shift-PD'
undo_s    in = ()
stop_s    in = ()
down      in = (esc sh_fkey '5~') label='Ctrl-PD'
down_s    in = ()
up        in = (esc sh_fkey '6~') label='Ctrl-PU'
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_alternate)
alt_end             out = (stop_alternate)
blink_begin         out = (start_blink)
blink_end           out = (stop_blink)
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = (so)
ld_fine_end              out = (si)
ld_fine_horizontal       out = 'q'
ld_fine_vertical         out = 'x'
ld_fine_upper_left       out = 'l'
ld_fine_upper_right      out = 'k'
ld_fine_lower_left       out = 'm'
ld_fine_lower_right      out = 'j'
ld_fine_up_t             out = 'w'
ld_fine_down_t           out = 'v'
ld_fine_left_t           out = 't'
ld_fine_right_t          out = 'u'
ld_fine_cross            out = 'n'
ld_medium_begin          out = (so start_alternate)
ld_medium_end            out = (si stop_alternate)
ld_medium_horizontal     out = 'q'
ld_medium_vertical       out = 'x'
ld_medium_upper_left     out = 'l'
ld_medium_upper_right    out = 'k'
ld_medium_lower_left     out = 'm'
ld_medium_lower_right    out = 'j'
ld_medium_up_t           out = 'w'
ld_medium_down_t         out = 'v'
ld_medium_left_t         out = 't'
ld_medium_right_t        out = 'u'
ld_medium_cross          out = 'n'
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR xterminal "
*DECK DECK=CSM$NCDX_43_80 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR NCD16 and NCD19 Xterminals                   "
"   Terminal is to be using xterm with special .Xdefaults                     "

"                                                                             "
"                NCDX NOS/VE Terminal Definition Key Mappings                 "
"                                                                             "
"                      Key       Modifier        Action                       "
"             +------------------------------------------------+              "
"             | F1 - F12  |          | F1 - F12                |              "
"             |           | Shift    | F1 - F12 Shifted        |              "
"             |------------------------------------------------|              "
"             | F1 - F4   | Ctrl     | F13 - F16               |              "
"             |           | Alt      | F13 - F16 Shifted       |              "
"             |------------------------------------------------|              "
"             | Insert    |          | Enter Insert Mode       |              "
"             |           | Shift    | Insert Line             |              "
"             |           | Ctrl     | Insert Character        |              "
"             |------------------------------------------------|              "
"             | Delete    |          | Delete Character        |              "
"             |           | Shift    | Delete Line             |              "
"             |------------------------------------------------|              "
"             | Home      |          | Put Cursor on Home Line |              "
"             |------------------------------------------------|              "
"             | End       |          | Exit Insert Mode        |              "
"             |           | Ctrl     | Delete to End of Line   |              "
"             |------------------------------------------------|              "
"             | Page Up   |          | Previous Screen         |              "
"             |           | Shift    | Top                     |              "
"             |           | Ctrl     | Half Page Forward       |              "
"             |------------------------------------------------|              "
"             | Page Down |          | Next Screen             |              "
"             |           | Shift    | Bottom                  |              "
"             |           | Ctrl     | Half Page Backward      |              "
"             +------------------------------------------------+              "
"                                                                             "
"
" To run the NCD terminal you need to install a resource file using xrdb.     "
" You may run xrdb on NOS/VE or on UNIX. This deck gives you the input        "
" for both NOS/VE and UNIX.                                                   "
"                                                                             "
" UNIX Installation                                                           "
"                                                                             "
" The following is file which is required in order to use this TDU.           "
" Take it out of this TDU and remove the double-quotes from each end of the   "
" lines.  It can then be used on the unix host when you use xterm.            "
"                                                                             "
"!------------------- beginning of unix file .Xdefaults ----------------------"
"!                                                                            "
"! define xterm VT100 prefix, use xrdb .Xdefaults                             "
"!                                                                            "
"! Note: You must allow the c pre-processor to run on this file.              "
"!       Do NOT use the -nocpp option on the xrdb command.                    "
"!                                                                            "
"!       To allow these key mappings to work, put them in a file on unix,     "
"!       execute the command:                                                 "
"!            xrdb whatever_filename_you_used                                 "
"!       then invoke an xterm like this:                                      "
"!            xterm -name xterm -132 -j                                       "
"!       the '-name xterm' tells it to use the xterm key mapping              "
"!       the '-132' tells it to allow switching to 132 column mode            "
"!       the '-j' tells it to do jump scrolling instead of smooth scrolling   "
"!                (this one is optional)                                      "
"!                                                                            "
"#define CR string(0x0d)                                                      "
"#define ESC string(0x1b)                                                     "
"#define SH_FKEY string(0x1b) string([9)                                      "
"#define PREFIX string(0x1b) string([)                                        "
"xterm*scrollBar:          on                                                 "
"xterm*saveLines:          150                                                "
"xterm*borderWidth:        2                                                  "
"xterm*c132:               on                                                 "
"xterm*font:               6x13                                               "
"xterm*boldFont:           6x13B                                              "
"xterm*VT100.geometry:     80x43                                              "
"#xterm*VT100.background: cyan                                                "
"#xterm*VT100.foreground: blue                                                "
"xterm*VT100.Translations:   #override\                                       "
"     Alt<Key>F1:     SH_FKEY string(25~) CR    \n\                           "
"    Ctrl<Key>F1:     PREFIX  string(25~) CR    \n\                           "
"    Meta<Key>F1:                               \n\                           "
"  Shift <Key>F1:     SH_FKEY string(11~) CR    \n\                           "
"        <Key>F1:     PREFIX  string(11~) CR    \n\                           "
"     Alt<Key>F2:     SH_FKEY string(26~) CR    \n\                           "
"    Ctrl<Key>F2:     PREFIX  string(26~) CR    \n\                           "
"    Meta<Key>F2:                               \n\                           "
"  Shift <Key>F2:     SH_FKEY string(12~) CR    \n\                           "
"        <Key>F2:     PREFIX  string(12~) CR    \n\                           "
"     Alt<Key>F3:     SH_FKEY string(28~) CR    \n\                           "
"    Ctrl<Key>F3:     PREFIX  string(28~) CR    \n\                           "
"    Meta<Key>F3:                               \n\                           "
"  Shift <Key>F3:     SH_FKEY string(13~) CR    \n\                           "
"        <Key>F3:     PREFIX  string(13~) CR    \n\                           "
"     Alt<Key>F4:     SH_FKEY string(29~) CR    \n\                           "
"    Ctrl<Key>F4:     PREFIX  string(29~) CR    \n\                           "
"    Meta<Key>F4:                               \n\                           "
"  Shift <Key>F4:     SH_FKEY string(14~) CR    \n\                           "
"        <Key>F4:     PREFIX  string(14~) CR    \n\                           "
"     Alt<Key>F5:                               \n\                           "
"    Ctrl<Key>F5:                               \n\                           "
"    Meta<Key>F5:                               \n\                           "
"  Shift <Key>F5:     SH_FKEY string(15~) CR    \n\                           "
"        <Key>F5:     PREFIX  string(15~) CR    \n\                           "
"     Alt<Key>F6:                               \n\                           "
"    Ctrl<Key>F6:                               \n\                           "
"    Meta<Key>F6:                               \n\                           "
"  Shift <Key>F6:     SH_FKEY string(17~) CR    \n\                           "
"        <Key>F6:     PREFIX  string(17~) CR    \n\                           "
"     Alt<Key>F7:                               \n\                           "
"    Ctrl<Key>F7:                               \n\                           "
"    Meta<Key>F7:                               \n\                           "
"  Shift <Key>F7:     SH_FKEY string(18~) CR    \n\                           "
"        <Key>F7:     PREFIX  string(18~) CR    \n\                           "
"     Alt<Key>F8:                               \n\                           "
"    Ctrl<Key>F8:                               \n\                           "
"    Meta<Key>F8:                               \n\                           "
"  Shift <Key>F8:     SH_FKEY string(19~) CR    \n\                           "
"        <Key>F8:     PREFIX  string(19~) CR    \n\                           "
"     Alt<Key>F9:                               \n\                           "
"    Ctrl<Key>F9:                               \n\                           "
"    Meta<Key>F9:                               \n\                           "
"  Shift <Key>F9:     SH_FKEY string(20~) CR    \n\                           "
"        <Key>F9:     PREFIX  string(20~) CR    \n\                           "
"     Alt<Key>F10:                              \n\                           "
"    Ctrl<Key>F10:                              \n\                           "
"    Meta<Key>F10:                              \n\                           "
"  Shift <Key>F10:    SH_FKEY string(21~) CR    \n\                           "
"        <Key>F10:    PREFIX  string(21~) CR    \n\                           "
"     Alt<Key>F11:                              \n\                           "
"    Ctrl<Key>F11:                              \n\                           "
"    Meta<Key>F11:                              \n\                           "
"  Shift <Key>F11:    SH_FKEY string(23~) CR    \n\                           "
"        <Key>F11:    PREFIX  string(23~) CR    \n\                           "
"     Alt<Key>F12:                              \n\                           "
"    Ctrl<Key>F12:                              \n\                           "
"    Meta<Key>F12:                              \n\                           "
"  Shift <Key>F12:    SH_FKEY string(24~) CR    \n\                           "
"        <Key>F12:    PREFIX  string(24~) CR    \n\                           "
"        <Key>Home:   PREFIX  string(H)         \n\                           "
"     Alt<Key>Prior:                            \n\                           "
"    Ctrl<Key>Prior:  ESC SH_FKEY string(5~) CR \n\                           "
"    Meta<Key>Prior:                            \n\                           "
"   Shift<Key>Prior:  SH_FKEY string(5~)  CR    \n\                           "
"        <Key>Prior:  PREFIX  string(5~)  CR    \n\                           "
"     Alt<Key>End:                              \n\                           "
"    Ctrl<Key>End:    PREFIX  string(K)         \n\                           "
"    Meta<Key>End:                              \n\                           "
"   Shift<Key>End:                              \n\                           "
"        <Key>End:    PREFIX  string(4l)        \n\                           "
"     Alt<Key>Next:                             \n\                           "
"    Ctrl<Key>Next:   ESC SH_FKEY string(6~) CR \n\                           "
"    Meta<Key>Next:                             \n\                           "
"   Shift<Key>Next:   SH_FKEY string(6~)  CR    \n\                           "
"        <Key>Next:   PREFIX  string(6~)  CR    \n\                           "
"     Alt<Key>Insert:                           \n\                           "
"    Ctrl<Key>Insert: PREFIX  string(@)         \n\                           "
"    Meta<Key>Insert:                           \n\                           "
"   Shift<Key>Insert: PREFIX  string(L)         \n\                           "
"        <Key>Insert: PREFIX  string(4h)        \n\                           "
"     Alt<Key>Delete:                           \n\                           "
"    Ctrl<Key>Delete: PREFIX  string(P)         \n\                           "
"    Meta<Key>Delete:                           \n\                           "
"   Shift<Key>Delete: PREFIX  string(M)         \n\                           "
"        <Key>Delete: PREFIX  string(P)                                       "
"!                                                                            "
"!---------------------- end of unix file .Xdefaults -------------------------"
"
" NOS/VE Installation                                                           "
"
" The following is file which is required in order to use this TDU.
" Take it out of this TDU and remove the quote from the beginning of each line
" lines.  It can then be used to run xrdb from the NOS/VE host.
" To allow these key mappings to work, put them in a file on NOS/VE and
"  execute the command:
"             xrdb whatever_filename_you_used
" ------------------ beginning of NOS/VE file _xdefaults ----------------------
"xterm*scrollBar: on
"xterm*saveLines: 150
"xterm*borderWidth: 2
"xterm*font: 6x13
"xterm*c132: on
"xterm*boldFont: 6x13B
"xterm*VT100.geometry: 80x43
"#xterm*VT100.background: cyan                                                  "
"#xterm*VT100.foreground: blue                                                  "
"xterm*VT100.Translations: #override\
"     Alt<Key>F1:     string(0x1b) string([9) string(25~) string(0x0d)    \n\
"    Ctrl<Key>F1:     string(0x1b) string([)  string(25~) string(0x0d)    \n\
"    Meta<Key>F1:                               \n\
"  Shift <Key>F1:     string(0x1b) string([9) string(11~) string(0x0d)    \n\
"        <Key>F1:     string(0x1b) string([)  string(11~) string(0x0d)    \n\
"     Alt<Key>F2:     string(0x1b) string([9) string(26~) string(0x0d)    \n\
"    Ctrl<Key>F2:     string(0x1b) string([)  string(26~) string(0x0d)    \n\
"    Meta<Key>F2:                               \n\
"  Shift <Key>F2:     string(0x1b) string([9) string(12~) string(0x0d)    \n\
"        <Key>F2:     string(0x1b) string([) string(12~) string(0x0d)    \n\
"     Alt<Key>F3:     string(0x1b) string([9) string(28~) string(0x0d)    \n\
"    Ctrl<Key>F3:     string(0x1b) string([)  string(28~) string(0x0d)    \n\
"    Meta<Key>F3:                               \n\
"  Shift <Key>F3:     string(0x1b) string([9) string(13~) string(0x0d)    \n\
"        <Key>F3:     string(0x1b) string([) string(13~) string(0x0d)    \n\
"     Alt<Key>F4:     string(0x1b) string([9) string(29~) string(0x0d)    \n\
"    Ctrl<Key>F4:     string(0x1b) string([)  string(29~) string(0x0d)    \n\
"    Meta<Key>F4:                               \n\
" Shift <Key>F4:     string(0x1b) string([9) string(14~) string(0x0d)    \n\
"        <Key>F4:    string(0x1b) string([) string(14~) string(0x0d)    \n\
"     Alt<Key>F5:                               \n\
"    Ctrl<Key>F5:                               \n\
"    Meta<Key>F5:                               \n\
"  Shift <Key>F5:     string(0x1b) string([9) string(15~) string(0x0d)    \n\
"        <Key>F5:     string(0x1b) string([) string(15~) string(0x0d)    \n\
"     Alt<Key>F6:                               \n\
"    Ctrl<Key>F6:                               \n\
"    Meta<Key>F6:                               \n\
"  Shift <Key>F6:     string(0x1b) string([9) string(17~) string(0x0d)    \n\
"       <Key>F6:      string(0x1b) string([) string(17~) string(0x0d)    \n\
"    Alt<Key>F7:                               \n\
"   Ctrl<Key>F7:                               \n\
"   Meta<Key>F7:                               \n\
" Shift <Key>F7:     string(0x1b) string([9) string(18~) string(0x0d)    \n\
"       <Key>F7:     string(0x1b) string([) string(18~) string(0x0d)    \n\
"     Alt<Key>F8:                               \n\
"    Ctrl<Key>F8:                               \n\
"    Meta<Key>F8:                               \n\
"  Shift <Key>F8:     string(0x1b) string([9) string(19~) string(0x0d)    \n\
"        <Key>F8:     string(0x1b) string([) string(19~) string(0x0d)    \n\
"     Alt<Key>F9:                               \n\
"    Ctrl<Key>F9:                               \n\
"    Meta<Key>F9:                               \n\
"  Shift <Key>F9:     string(0x1b) string([9) string(20~) string(0x0d)    \n\
"        <Key>F9:     string(0x1b) string([) string(20~) string(0x0d)    \n\
"     Alt<Key>F10:                              \n\
"    Ctrl<Key>F10:                              \n\
"    Meta<Key>F10:                              \n\
"  Shift <Key>F10:    string(0x1b) string([9) string(21~) string(0x0d)    \n\
"        <Key>F10:    string(0x1b) string([) string(21~) string(0x0d)    \n\
"     Alt<Key>F11:                              \n\
"    Ctrl<Key>F11:                              \n\
"    Meta<Key>F11:                              \n\
"  Shift <Key>F11:    string(0x1b) string([9) string(23~) string(0x0d)    \n\
"        <Key>F11:    string(0x1b) string([) string(23~) string(0x0d)    \n\
"     Alt<Key>F12:                              \n\
"    Ctrl<Key>F12:                              \n\
"    Meta<Key>F12:                              \n\
"  Shift <Key>F12:    string(0x1b) string([9) string(24~) string(0x0d)    \n\
"        <Key>F12:    string(0x1b) string([) string(24~) string(0x0d)    \n\
"        <Key>Home:   string(0x1b) string([)  string(H)         \n\
"     Alt<Key>Prior:                            \n\
"    Ctrl<Key>Prior:  string(0x1b) string(0x1b) string([9) string(5~) string(0x0d) \n\
"    Meta<Key>Prior:                            \n\
"   Shift<Key>Prior:  string(0x1b) string([9) string(5~)  string(0x0d)    \n\
"        <Key>Prior:  string(0x1b) string([) string(5~) string(0x0d)    \n\
"     Alt<Key>End:                              \n\
"    Ctrl<Key>End:    string(0x1b) string([)  string(K)         \n\
"    Meta<Key>End:                              \n\
"   Shift<Key>End:                              \n\
"        <Key>End:    string(0x1b) string([)  string(4l)        \n\
"     Alt<Key>Next:                             \n\
"    Ctrl<Key>Next:   string(0x1b) string(0x1b) string([9) string(6~) string(0x0d) \n\
"    Meta<Key>Next:                             \n\
"   Shift<Key>Next:   string(0x1b) string([9) string(6~)  string(0x0d)    \n\
"        <Key>Next:   string(0x1b) string([) string(6~) string(0x0d)    \n\
"     Alt<Key>Insert:                           \n\
"    Ctrl<Key>Insert: string(0x1b) string([)  string(@)         \n\
"    Meta<Key>Insert:                           \n\
"   Shift<Key>Insert: string(0x1b) string([)  string(L)         \n\
"        <Key>Insert: string(0x1b) string([)  string(4h)        \n\
"     Alt<Key>Delete:                           \n\
"    Ctrl<Key>Delete: string(0x1b) string([)  string(P)         \n\
"   Meta<Key>Delete:                           \n\
"   Shift<Key>Delete: string(0x1b) string([)  string(M)         \n\
"        <Key>Delete: string(0x1b) string([)  string(P)
" ---------------------- end of NOS/VE file _xdefaults -------------------------

"   VARIABLES                                                                 "
prefix              = (esc '[')
alt_screen_buffer   = (prefix '?47h')
sh_fkey             = (esc '[9')
clear_all_tabs      = (prefix '3g')
clear_home          = (prefix 'H' prefix 'J')
disable_mouse       = (prefix '?1002l')
enable_cursor_mode  = (prefix '?1l')
enable_mouse        = (prefix '?1002h')
enter_ansi_mode     = (esc '<')
g0_us_characters    = (esc '(B')
g1_graphics_chars   = (esc ')0')
application_keypad  = (esc '=')
numeric_keypad      = (esc '>')
normal_attributes   = (prefix 'm')
normal_screen_buffer= (prefix '?47l')
restore_cursor      = (esc '8')
save_cursor         = (esc '7')
select_g0_char_set  = (si)
set_80_cols         = (prefix '?3l')
set_132_cols        = (prefix '?3h')
start_alternate     = (prefix '1m')
start_blink         = (prefix '5m')
start_inverse       = (prefix '7m')
start_underline     = (prefix '4m')
stop_alternate      = (normal_attributes)
stop_blink          = (normal_attributes)
stop_inverse        = (normal_attributes)
stop_underline      = (normal_attributes)
wraparound_off      = (prefix '?7l')
wraparound_on       = (prefix '?7h')
start_insert_mode   = (prefix '4h')
stop_insert_mode    = (prefix '4l')

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'NCDX_43_80'
communications      type  = asynch
application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (';')
cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 'H') label='Home'
cursor_up                inout = (prefix 'A')
cursor_down              inout = (prefix 'B')
cursor_left              inout = (prefix 'D')
cursor_right             inout = (prefix 'C')

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 0
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 43 columns = 80   out = (set_80_cols)
set_size       rows = 43 columns = 132  out = (set_132_cols)

"   SCREEN AND LINE MODE TRANSITION                                           "

" You may restore the text on the screen after exiting a full screen
" application if you add alt_screen_buffer to the set_screen_command. If you add
" alt_screen_buffer you may see the following results to occur.

" - REDO acts as a full screen utility, so when you hit redo, an empty screen
"   comes up with only the line you are editing.
"
" - With page_width set to 132, when you enter a full screen utility, the
"   xterm window momentarily goes to 80 columns and then back to 132.  The
"   result of this is that when you leave the full screen utility, you only
"   have the information from the first 80 columns left on your screen.
"
" - Sometimes when you exit the full screen utility, especially if you have
"   gone into line mode sometime during the session, the cursor will be left
"   at the top of the screen.  The following line can be used to move your
"   cursor to the bottom of the screen:
"      putl $char(' ' esc '[40B')

set_screen_mode     out = (save_cursor "alt_screen_buffer" ..
     enter_ansi_mode stop_insert_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     wraparound_off enable_cursor_mode enable_mouse)

set_line_mode     out = (enter_ansi_mode stop_insert_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set disable_mouse ..
     wraparound_on normal_screen_buffer restore_cursor enable_cursor_mode)

"   TERMINAL CAPABILITIES                                                     "
delete_char         inout = (prefix 'P')  label='Delete'
delete_line_stay    inout = (prefix 'M')  label='Shift-Delete'
erase_end_of_line   inout = (prefix 'K')  label='Ctrl-End'
erase_line_stay     inout = (prefix '2K')
erase_page_home       out = (clear_home)
insert_char         inout = (prefix '@')  label='Ctrl-Insert'
insert_line_stay    inout = (prefix 'L')  label='Shift-Insert'
insert_mode_begin   inout = (start_insert_mode) label='Insert'
insert_mode_end     inout = (stop_insert_mode)  label='End'
tab_forward         inout = (ht)
tab_clear_all       inout = (clear_all_tabs)
tab_set             inout = (esc 'H')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
backspace           in = bs

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (prefix '11~') label='F1'
f2        in = (prefix '12~') label='F2'
f3        in = (prefix '13~') label='F3'
f4        in = (prefix '14~') label='F4'
f5        in = (prefix '15~') label='F5'
f6        in = (prefix '17~') label='F6'
f7        in = (prefix '18~') label='F7'
f8        in = (prefix '19~') label='F8'
f9        in = (prefix '20~') label='F9'
f10       in = (prefix '21~') label='10'
f11       in = (prefix '23~') label='11'
f12       in = (prefix '24~') label='12'
f13       in = (prefix '25~') label='C1'
f14       in = (prefix '26~') label='C2'
f15       in = (prefix '28~') label='C3'
f16       in = (prefix '29~') label='C4'

f1_s      in = (sh_fkey '11~') label='  Sh'
f2_s      in = (sh_fkey '12~') label='  Sh'
f3_s      in = (sh_fkey '13~') label='  Sh'
f4_s      in = (sh_fkey '14~') label='  Sh'
f5_s      in = (sh_fkey '15~') label='  Sh'
f6_s      in = (sh_fkey '17~') label='  Sh'
f7_s      in = (sh_fkey '18~') label='  Sh'
f8_s      in = (sh_fkey '19~') label='  Sh'
f9_s      in = (sh_fkey '20~') label='  Sh'
f10_s     in = (sh_fkey '21~') label='  Sh'
f11_s     in = (sh_fkey '23~') label='  Sh'
f12_s     in = (sh_fkey '24~') label='  Sh'
f13_s     in = (sh_fkey '25~') label='A1'
f14_s     in = (sh_fkey '26~') label='A2'
f15_s     in = (sh_fkey '28~') label='A3'
f16_s     in = (sh_fkey '29~') label='A4'



"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = (prefix '5~') label='PU'
fwd       in = (prefix '6~') label='PD'
back      in = (prefix '13~') label='F3'
help      in = (prefix '14~') label='F4'
undo      in = (prefix '15~') label='F5'
stop      in = (prefix '17~') label='F6'
bkw_s     in = (sh_fkey '5~') label='Shift-PU'
fwd_s     in = (sh_fkey '6~') label='Shift-PD'
undo_s    in = ()
stop_s    in = ()
down      in = (esc sh_fkey '5~') label='Ctrl-PD'
down_s    in = ()
up        in = (esc sh_fkey '6~') label='Ctrl-PU'
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_alternate)
alt_end             out = (stop_alternate)
blink_begin         out = (start_blink)
blink_end           out = (stop_blink)
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = (so)
ld_fine_end              out = (si)
ld_fine_horizontal       out = 'q'
ld_fine_vertical         out = 'x'
ld_fine_upper_left       out = 'l'
ld_fine_upper_right      out = 'k'
ld_fine_lower_left       out = 'm'
ld_fine_lower_right      out = 'j'
ld_fine_up_t             out = 'w'
ld_fine_down_t           out = 'v'
ld_fine_left_t           out = 't'
ld_fine_right_t          out = 'u'
ld_fine_cross            out = 'n'
ld_medium_begin          out = (so start_alternate)
ld_medium_end            out = (si stop_alternate)
ld_medium_horizontal     out = 'q'
ld_medium_vertical       out = 'x'
ld_medium_upper_left     out = 'l'
ld_medium_upper_right    out = 'k'
ld_medium_lower_left     out = 'm'
ld_medium_lower_right    out = 'j'
ld_medium_up_t           out = 'w'
ld_medium_down_t         out = 'v'
ld_medium_left_t         out = 't'
ld_medium_right_t        out = 'u'
ld_medium_cross          out = 'n'
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR xterminal "
*DECK DECK=CSM$NCDX_PL_24 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR NCD16 and NCD19 Xterminals                   "
"   Terminal is to be using xterm with special .Xdefaults entry               "

"                                                                             "
"                NCDX NOS/VE Terminal Definition Key Mappings                 "
"                                                                             "
"                      Key       Modifier        Action                       "
"             +------------------------------------------------+              "
"             | F1 - F12  |          | F1 - F12                |              "
"             |           | Shift    | F1 - F12 Shifted        |              "
"             |------------------------------------------------|              "
"             | F1 - F4   | Ctrl     | F13 - F16               |              "
"             |           | Alt      | F13 - F16 Shifted       |              "
"             |------------------------------------------------|              "
"             | Insert    |          | Enter Insert Mode       |              "
"             |           | Shift    | Insert Line             |              "
"             |           | Ctrl     | Insert Character        |              "
"             |------------------------------------------------|              "
"             | Delete    |          | Delete Character        |              "
"             |           | Shift    | Delete Line             |              "
"             |------------------------------------------------|              "
"             | Home      |          | Put Cursor on Home Line |              "
"             |------------------------------------------------|              "
"             | End       |          | Exit Insert Mode        |              "
"             |           | Ctrl     | Delete to End of Line   |              "
"             |------------------------------------------------|              "
"             | Page Up   |          | Previous Screen         |              "
"             |           | Shift    | Top                     |              "
"             |           | Ctrl     | Half Page Forward       |              "
"             |------------------------------------------------|              "
"             | Page Down |          | Next Screen             |              "
"             |           | Shift    | Bottom                  |              "
"             |           | Ctrl     | Half Page Backward      |              "
"             +------------------------------------------------+              "
"                                                                             "
"
" To run the NCD terminal you need to install a resource file using xrdb.     "
" You may run xrdb on NOS/VE or on UNIX. This deck gives you the input        "
" for both NOS/VE and UNIX.                                                   "
"                                                                             "
" UNIX Installation                                                           "
"                                                                             "
" The following is file which is required in order to use this TDU.           "
" Take it out of this TDU and remove the double-quotes from each end of the   "
" lines.  It can then be used on the unix host when you use xterm.            "
"                                                                             "
"!------------------- beginning of unix file .Xdefaults ----------------------"
"!                                                                            "
"! define xterm VT100 prefix, use xrdb .Xdefaults                             "
"!                                                                            "
"! Note: You must allow the c pre-processor to run on this file.              "
"!       Do NOT use the -nocpp option on the xrdb command.                    "
"!                                                                            "
"!       To allow these key mappings to work, put them in a file on unix,     "
"!       execute the command:                                                 "
"!            xrdb whatever_filename_you_used                                 "
"!       then invoke an xterm like this:                                      "
"!            xterm -name xterm -132 -j                                       "
"!       the '-name xterm' tells it to use the xterm key mapping              "
"!       the '-132' tells it to allow switching to 132 column mode            "
"!       the '-j' tells it to do jump scrolling instead of smooth scrolling   "
"!                (this one is optional)                                      "
"!                                                                            "
"#define CR string(0x0d)                                                      "
"#define ESC string(0x1b)                                                     "
"#define SH_FKEY string(0x1b) string([9)                                      "
"#define PREFIX string(0x1b) string([)                                        "
"xterm*scrollBar:          on                                                 "
"xterm*saveLines:          150                                                "
"xterm*borderWidth:        2                                                  "
"xterm*c132:               on                                                 "
"xterm*font:               10x20                                              "
"xterm*boldFont:           10x20B                                             "
"xterm*VT100.geometry:     80x24                                              "
"#xterm*VT100.background: cyan                                                "
"#xterm*VT100.foreground: blue                                                "
"xterm*VT100.Translations:   #override\                                       "
"     Alt<Key>F1:     SH_FKEY string(25~) CR    \n\                           "
"    Ctrl<Key>F1:     PREFIX  string(25~) CR    \n\                           "
"    Meta<Key>F1:                               \n\                           "
"  Shift <Key>F1:     SH_FKEY string(11~) CR    \n\                           "
"        <Key>F1:     PREFIX  string(11~) CR    \n\                           "
"     Alt<Key>F2:     SH_FKEY string(26~) CR    \n\                           "
"    Ctrl<Key>F2:     PREFIX  string(26~) CR    \n\                           "
"    Meta<Key>F2:                               \n\                           "
"  Shift <Key>F2:     SH_FKEY string(12~) CR    \n\                           "
"        <Key>F2:     PREFIX  string(12~) CR    \n\                           "
"     Alt<Key>F3:     SH_FKEY string(28~) CR    \n\                           "
"    Ctrl<Key>F3:     PREFIX  string(28~) CR    \n\                           "
"    Meta<Key>F3:                               \n\                           "
"  Shift <Key>F3:     SH_FKEY string(13~) CR    \n\                           "
"        <Key>F3:     PREFIX  string(13~) CR    \n\                           "
"     Alt<Key>F4:     SH_FKEY string(29~) CR    \n\                           "
"    Ctrl<Key>F4:     PREFIX  string(29~) CR    \n\                           "
"    Meta<Key>F4:                               \n\                           "
"  Shift <Key>F4:     SH_FKEY string(14~) CR    \n\                           "
"        <Key>F4:     PREFIX  string(14~) CR    \n\                           "
"     Alt<Key>F5:                               \n\                           "
"    Ctrl<Key>F5:                               \n\                           "
"    Meta<Key>F5:                               \n\                           "
"  Shift <Key>F5:     SH_FKEY string(15~) CR    \n\                           "
"        <Key>F5:     PREFIX  string(15~) CR    \n\                           "
"     Alt<Key>F6:                               \n\                           "
"    Ctrl<Key>F6:                               \n\                           "
"    Meta<Key>F6:                               \n\                           "
"  Shift <Key>F6:     SH_FKEY string(17~) CR    \n\                           "
"        <Key>F6:     PREFIX  string(17~) CR    \n\                           "
"     Alt<Key>F7:                               \n\                           "
"    Ctrl<Key>F7:                               \n\                           "
"    Meta<Key>F7:                               \n\                           "
"  Shift <Key>F7:     SH_FKEY string(18~) CR    \n\                           "
"        <Key>F7:     PREFIX  string(18~) CR    \n\                           "
"     Alt<Key>F8:                               \n\                           "
"    Ctrl<Key>F8:                               \n\                           "
"    Meta<Key>F8:                               \n\                           "
"  Shift <Key>F8:     SH_FKEY string(19~) CR    \n\                           "
"        <Key>F8:     PREFIX  string(19~) CR    \n\                           "
"     Alt<Key>F9:                               \n\                           "
"    Ctrl<Key>F9:                               \n\                           "
"    Meta<Key>F9:                               \n\                           "
"  Shift <Key>F9:     SH_FKEY string(20~) CR    \n\                           "
"        <Key>F9:     PREFIX  string(20~) CR    \n\                           "
"     Alt<Key>F10:                              \n\                           "
"    Ctrl<Key>F10:                              \n\                           "
"    Meta<Key>F10:                              \n\                           "
"  Shift <Key>F10:    SH_FKEY string(21~) CR    \n\                           "
"        <Key>F10:    PREFIX  string(21~) CR    \n\                           "
"     Alt<Key>F11:                              \n\                           "
"    Ctrl<Key>F11:                              \n\                           "
"    Meta<Key>F11:                              \n\                           "
"  Shift <Key>F11:    SH_FKEY string(23~) CR    \n\                           "
"        <Key>F11:    PREFIX  string(23~) CR    \n\                           "
"     Alt<Key>F12:                              \n\                           "
"    Ctrl<Key>F12:                              \n\                           "
"    Meta<Key>F12:                              \n\                           "
"  Shift <Key>F12:    SH_FKEY string(24~) CR    \n\                           "
"        <Key>F12:    PREFIX  string(24~) CR    \n\                           "
"        <Key>Home:   PREFIX  string(H)         \n\                           "
"     Alt<Key>Prior:                            \n\                           "
"    Ctrl<Key>Prior:  ESC SH_FKEY string(5~) CR \n\                           "
"    Meta<Key>Prior:                            \n\                           "
"   Shift<Key>Prior:  SH_FKEY string(5~)  CR    \n\                           "
"        <Key>Prior:  PREFIX  string(5~)  CR    \n\                           "
"     Alt<Key>End:                              \n\                           "
"    Ctrl<Key>End:    PREFIX  string(K)         \n\                           "
"    Meta<Key>End:                              \n\                           "
"   Shift<Key>End:                              \n\                           "
"        <Key>End:    PREFIX  string(4l)        \n\                           "
"     Alt<Key>Next:                             \n\                           "
"    Ctrl<Key>Next:   ESC SH_FKEY string(6~) CR \n\                           "
"    Meta<Key>Next:                             \n\                           "
"   Shift<Key>Next:   SH_FKEY string(6~)  CR    \n\                           "
"        <Key>Next:   PREFIX  string(6~)  CR    \n\                           "
"     Alt<Key>Insert:                           \n\                           "
"    Ctrl<Key>Insert: PREFIX  string(@)         \n\                           "
"    Meta<Key>Insert:                           \n\                           "
"   Shift<Key>Insert: PREFIX  string(L)         \n\                           "
"        <Key>Insert: PREFIX  string(4h)        \n\                           "
"     Alt<Key>Delete:                           \n\                           "
"    Ctrl<Key>Delete: PREFIX  string(P)         \n\                           "
"    Meta<Key>Delete:                           \n\                           "
"   Shift<Key>Delete: PREFIX  string(M)         \n\                           "
"        <Key>Delete: PREFIX  string(P)                                       "
"!                                                                            "
"!---------------------- end of unix file .Xdefaults -------------------------"
"
" NOS/VE Installation                                                           "
"
" The following is file which is required in order to use this TDU.
" Take it out of this TDU and remove the quote from the beginning of each line
" lines.  It can then be used to run xrdb from the NOS/VE host.
" To allow these key mappings to work, put them in a file on NOS/VE and
"  execute the command:
"             xrdb whatever_filename_you_used
" ------------------ beginning of NOS/VE file _xdefaults ----------------------
"xterm*scrollBar: on
"xterm*saveLines: 150
"xterm*borderWidth: 2
"xterm*c132: on
"xterm*font: 10x20
"xterm*boldFont: 10x20B
"xterm*VT100.geometry: 80x24
"#xterm*VT100.background: cyan
"#xterm*VT100.foreground: blue
"xterm*VT100.Translations: #override\
"     Alt<Key>F1:     string(0x1b) string([9) string(25~) string(0x0d)    \n\
"    Ctrl<Key>F1:     string(0x1b) string([)  string(25~) string(0x0d)    \n\
"    Meta<Key>F1:                               \n\
"  Shift <Key>F1:     string(0x1b) string([9) string(11~) string(0x0d)    \n\
"        <Key>F1:     string(0x1b) string([)  string(11~) string(0x0d)    \n\
"     Alt<Key>F2:     string(0x1b) string([9) string(26~) string(0x0d)    \n\
"    Ctrl<Key>F2:     string(0x1b) string([)  string(26~) string(0x0d)    \n\
"    Meta<Key>F2:                               \n\
"  Shift <Key>F2:     string(0x1b) string([9) string(12~) string(0x0d)    \n\
"        <Key>F2:     string(0x1b) string([) string(12~) string(0x0d)    \n\
"     Alt<Key>F3:     string(0x1b) string([9) string(28~) string(0x0d)    \n\
"    Ctrl<Key>F3:     string(0x1b) string([)  string(28~) string(0x0d)    \n\
"    Meta<Key>F3:                               \n\
"  Shift <Key>F3:     string(0x1b) string([9) string(13~) string(0x0d)    \n\
"        <Key>F3:     string(0x1b) string([) string(13~) string(0x0d)    \n\
"     Alt<Key>F4:     string(0x1b) string([9) string(29~) string(0x0d)    \n\
"    Ctrl<Key>F4:     string(0x1b) string([)  string(29~) string(0x0d)    \n\
"    Meta<Key>F4:                               \n\
" Shift <Key>F4:     string(0x1b) string([9) string(14~) string(0x0d)    \n\
"        <Key>F4:    string(0x1b) string([) string(14~) string(0x0d)    \n\
"     Alt<Key>F5:                               \n\
"    Ctrl<Key>F5:                               \n\
"    Meta<Key>F5:                               \n\
"  Shift <Key>F5:     string(0x1b) string([9) string(15~) string(0x0d)    \n\
"        <Key>F5:     string(0x1b) string([) string(15~) string(0x0d)    \n\
"     Alt<Key>F6:                               \n\
"    Ctrl<Key>F6:                               \n\
"    Meta<Key>F6:                               \n\
"  Shift <Key>F6:     string(0x1b) string([9) string(17~) string(0x0d)    \n\
"       <Key>F6:      string(0x1b) string([) string(17~) string(0x0d)    \n\
"    Alt<Key>F7:                               \n\
"   Ctrl<Key>F7:                               \n\
"   Meta<Key>F7:                               \n\
" Shift <Key>F7:     string(0x1b) string([9) string(18~) string(0x0d)    \n\
"       <Key>F7:     string(0x1b) string([) string(18~) string(0x0d)    \n\
"     Alt<Key>F8:                               \n\
"    Ctrl<Key>F8:                               \n\
"    Meta<Key>F8:                               \n\
"  Shift <Key>F8:     string(0x1b) string([9) string(19~) string(0x0d)    \n\
"        <Key>F8:     string(0x1b) string([) string(19~) string(0x0d)    \n\
"     Alt<Key>F9:                               \n\
"    Ctrl<Key>F9:                               \n\
"    Meta<Key>F9:                               \n\
"  Shift <Key>F9:     string(0x1b) string([9) string(20~) string(0x0d)    \n\
"        <Key>F9:     string(0x1b) string([) string(20~) string(0x0d)    \n\
"     Alt<Key>F10:                              \n\
"    Ctrl<Key>F10:                              \n\
"    Meta<Key>F10:                              \n\
"  Shift <Key>F10:    string(0x1b) string([9) string(21~) string(0x0d)    \n\
"        <Key>F10:    string(0x1b) string([) string(21~) string(0x0d)    \n\
"     Alt<Key>F11:                              \n\
"    Ctrl<Key>F11:                              \n\
"    Meta<Key>F11:                              \n\
"  Shift <Key>F11:    string(0x1b) string([9) string(23~) string(0x0d)    \n\
"        <Key>F11:    string(0x1b) string([) string(23~) string(0x0d)    \n\
"     Alt<Key>F12:                              \n\
"    Ctrl<Key>F12:                              \n\
"    Meta<Key>F12:                              \n\
"  Shift <Key>F12:    string(0x1b) string([9) string(24~) string(0x0d)    \n\
"        <Key>F12:    string(0x1b) string([) string(24~) string(0x0d)    \n\
"        <Key>Home:   string(0x1b) string([)  string(H)         \n\
"     Alt<Key>Prior:                            \n\
"    Ctrl<Key>Prior:  string(0x1b) string(0x1b) string([9) string(5~) string(0x0d) \n\
"    Meta<Key>Prior:                            \n\
"   Shift<Key>Prior:  string(0x1b) string([9) string(5~)  string(0x0d)    \n\
"        <Key>Prior:  string(0x1b) string([) string(5~) string(0x0d)    \n\
"     Alt<Key>End:                              \n\
"    Ctrl<Key>End:    string(0x1b) string([)  string(K)         \n\
"    Meta<Key>End:                              \n\
"   Shift<Key>End:                              \n\
"        <Key>End:    string(0x1b) string([)  string(4l)        \n\
"     Alt<Key>Next:                             \n\
"    Ctrl<Key>Next:   string(0x1b) string(0x1b) string([9) string(6~) string(0x0d) \n\
"    Meta<Key>Next:                             \n\
"   Shift<Key>Next:   string(0x1b) string([9) string(6~)  string(0x0d)    \n\
"        <Key>Next:   string(0x1b) string([) string(6~) string(0x0d)    \n\
"     Alt<Key>Insert:                           \n\
"    Ctrl<Key>Insert: string(0x1b) string([)  string(@)         \n\
"    Meta<Key>Insert:                           \n\
"   Shift<Key>Insert: string(0x1b) string([)  string(L)         \n\
"        <Key>Insert: string(0x1b) string([)  string(4h)        \n\
"     Alt<Key>Delete:                           \n\
"    Ctrl<Key>Delete: string(0x1b) string([)  string(P)         \n\
"   Meta<Key>Delete:                           \n\
"   Shift<Key>Delete: string(0x1b) string([)  string(M)         \n\
"        <Key>Delete: string(0x1b) string([)  string(P)
" ---------------------- end of NOS/VE file _xdefaults -------------------------

"   VARIABLES                                                                 "
prefix              = (esc '[')
alt_screen_buffer   = (prefix '?47h')
sh_fkey             = (esc '[9')
clear_all_tabs      = (prefix '3g')
clear_home          = (prefix 'H' prefix 'J')
disable_mouse       = (prefix '?1002l')
enable_cursor_mode  = (prefix '?1l')
enable_mouse        = (prefix '?1002h')
enter_ansi_mode     = (esc '<')
g0_us_characters    = (esc '(B')
g1_graphics_chars   = (esc ')0')
application_keypad  = (esc '=')
numeric_keypad      = (esc '>')
normal_attributes   = (prefix 'm')
normal_screen_buffer= (prefix '?47l')
restore_cursor      = (esc '8')
save_cursor         = (esc '7')
select_g0_char_set  = (si)
set_80_cols         = (prefix '?3l')
set_132_cols        = (prefix '?3h')
start_alternate     = (prefix '1m')
start_blink         = (prefix '5m')
start_inverse       = (prefix '7m')
start_underline     = (prefix '4m')
stop_alternate      = (normal_attributes)
stop_blink          = (normal_attributes)
stop_inverse        = (normal_attributes)
stop_underline      = (normal_attributes)
wraparound_off      = (prefix '?7l')
wraparound_on       = (prefix '?7h')
start_insert_mode   = (prefix '4h')
stop_insert_mode    = (prefix '4l')

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'NCDX_PL_24'
communications      type  = asynch
application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (';')
cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 'H') label='Home'
cursor_up                inout = (prefix 'A')
cursor_down              inout = (prefix 'B')
cursor_left              inout = (prefix 'D')
cursor_right             inout = (prefix 'C')

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 0
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80   out = (set_80_cols)
set_size       rows = 24 columns = 132  out = (set_132_cols)

"   SCREEN AND LINE MODE TRANSITION                                           "

" You may restore the text on the screen after exiting a full screen
" application if you add alt_screen_buffer to the set_screen_command. If you add
" alt_screen_buffer you may see the following results to occur.

" - REDO acts as a full screen utility, so when you hit redo, an empty screen
"   comes up with only the line you are editing.
"
" - With page_width set to 132, when you enter a full screen utility, the
"   xterm window momentarily goes to 80 columns and then back to 132.  The
"   result of this is that when you leave the full screen utility, you only
"   have the information from the first 80 columns left on your screen.
"
" - Sometimes when you exit the full screen utility, especially if you have
"   gone into line mode sometime during the session, the cursor will be left
"   at the top of the screen.  The following line can be used to move your
"   cursor to the bottom of the screen:
"      putl $char(' ' esc '[40B')

set_screen_mode     out = (save_cursor "alt_screen_buffer" ..
     enter_ansi_mode stop_insert_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     wraparound_off enable_cursor_mode enable_mouse)


set_line_mode     out = (enter_ansi_mode stop_insert_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set disable_mouse ..
     wraparound_on normal_screen_buffer restore_cursor enable_cursor_mode)

"   TERMINAL CAPABILITIES                                                     "
delete_char         inout = (prefix 'P')  label='Delete'
delete_line_stay    inout = (prefix 'M')  label='Shift-Delete'
erase_end_of_line   inout = (prefix 'K')  label='Ctrl-End'
erase_line_stay     inout = (prefix '2K')
erase_page_home       out = (clear_home)
insert_char         inout = (prefix '@')  label='Ctrl-Insert'
insert_line_stay    inout = (prefix 'L')  label='Shift-Insert'
insert_mode_begin   inout = (start_insert_mode) label='Insert'
insert_mode_end     inout = (stop_insert_mode)  label='End'
tab_forward         inout = (ht)
tab_clear_all       inout = (clear_all_tabs)
tab_set             inout = (esc 'H')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
backspace           in = bs

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (prefix '11~') label='F1'
f2        in = (prefix '12~') label='F2'
f3        in = (prefix '13~') label='F3'
f4        in = (prefix '14~') label='F4'
f5        in = (prefix '15~') label='F5'
f6        in = (prefix '17~') label='F6'
f7        in = (prefix '18~') label='F7'
f8        in = (prefix '19~') label='F8'
f9        in = (prefix '20~') label='F9'
f10       in = (prefix '21~') label='10'
f11       in = (prefix '23~') label='11'
f12       in = (prefix '24~') label='12'
f13       in = (prefix '25~') label='C1'
f14       in = (prefix '26~') label='C2'
f15       in = (prefix '28~') label='C3'
f16       in = (prefix '29~') label='C4'

f1_s      in = (sh_fkey '11~') label='  Sh'
f2_s      in = (sh_fkey '12~') label='  Sh'
f3_s      in = (sh_fkey '13~') label='  Sh'
f4_s      in = (sh_fkey '14~') label='  Sh'
f5_s      in = (sh_fkey '15~') label='  Sh'
f6_s      in = (sh_fkey '17~') label='  Sh'
f7_s      in = (sh_fkey '18~') label='  Sh'
f8_s      in = (sh_fkey '19~') label='  Sh'
f9_s      in = (sh_fkey '20~') label='  Sh'
f10_s     in = (sh_fkey '21~') label='  Sh'
f11_s     in = (sh_fkey '23~') label='  Sh'
f12_s     in = (sh_fkey '24~') label='  Sh'
f13_s     in = (sh_fkey '25~') label='A1'
f14_s     in = (sh_fkey '26~') label='A2'
f15_s     in = (sh_fkey '28~') label='A3'
f16_s     in = (sh_fkey '29~') label='A4'



"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = (prefix '5~') label='PU'
fwd       in = (prefix '6~') label='PD'
back      in = (prefix '13~') label='F3'
help      in = (prefix '14~') label='F4'
undo      in = (prefix '15~') label='F5'
stop      in = (prefix '17~') label='F6'
bkw_s     in = (sh_fkey '5~') label='Shift-PU'
fwd_s     in = (sh_fkey '6~') label='Shift-PD'
undo_s    in = ()
stop_s    in = ()
down      in = (esc sh_fkey '5~') label='Ctrl-PD'
down_s    in = ()
up        in = (esc sh_fkey '6~') label='Ctrl-PU'
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_alternate)
alt_end             out = (stop_alternate)
blink_begin         out = (start_blink)
blink_end           out = (stop_blink)
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = (so)
ld_fine_end              out = (si)
ld_fine_horizontal       out = 'q'
ld_fine_vertical         out = 'x'
ld_fine_upper_left       out = 'l'
ld_fine_upper_right      out = 'k'
ld_fine_lower_left       out = 'm'
ld_fine_lower_right      out = 'j'
ld_fine_up_t             out = 'w'
ld_fine_down_t           out = 'v'
ld_fine_left_t           out = 't'
ld_fine_right_t          out = 'u'
ld_fine_cross            out = 'n'
ld_medium_begin          out = (so start_alternate)
ld_medium_end            out = (si stop_alternate)
ld_medium_horizontal     out = 'q'
ld_medium_vertical       out = 'x'
ld_medium_upper_left     out = 'l'
ld_medium_upper_right    out = 'k'
ld_medium_lower_left     out = 'm'
ld_medium_lower_right    out = 'j'
ld_medium_up_t           out = 'w'
ld_medium_down_t         out = 'v'
ld_medium_left_t         out = 't'
ld_medium_right_t        out = 'u'
ld_medium_cross          out = 'n'
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR xterminal "
*DECK DECK=CSM$OLD_CDC721 EXPAND=TRUE


"   TERMINAL DEFINITION FILE FOR CDC VIKING 721 TERMINAL                      "

" Automatic tabbing is available as a user or site option.  To enable it,     "
" change the automatic_tabbing firective from FALSE to TRUE, and look at the  "
" set_screen_mode and set_line_mode directives for comment-disabled references"
" to the variables enable_autotab and disable_autotab -- enable these         "
" references by blanking over the comment quotes.                             "

"   VARIABLES                                                                 "
clear_all_tabs      = (rs dc2 'Y')
disable_autotab     = (rs '#')
disable_blink       = (eot)
disable_auto_cr     = (rs '''')
disable_protect     = (rs dc2 'L')
disable_touchpanel  = (rs dc2 'Q')
disable_old_attr    = (rs '-')
enable_auto_cr      = (rs '&')
enable_autotab      = (rs '"')
enable_clear        = (rs '$')
enable_cr_delim     = (rs enq)
enable_blink        = (etx)
enable_protect      = (rs dc2 'K')
enable_typeamatic   = (rs dc2 'i')
enable_touchpanel   = (rs dc2 'R')
end_print           = (rs 7f(16))
large_cyber_mode    = (rs dc2 'B')
page_mode           = (syn)
pop_fn_keys         = (rs dc2 71(16) cr)
push_fn_keys        = (rs dc2 70(16) cr)
scroll_mode         = (dc2)
shift_numeric_pad   = (rs dc2 6B(16))
start_inverse       = (rs 'D')
start_underline     = (ack)
stop_inverse        = (rs 'E')
stop_underline      = (nak)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'OLD_CDC721'
communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (32)   type = cdc721_cursor
cursor_pos_column_first  value = TRUE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         in    = (1e(16) 4d(16) 1f(16))  label = 'TOUCH'
cursor_pos_begin         out   = (stx)
cursor_pos_second        out   = (7E(16) soh)

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (em)     label='HOME'
cursor_up                inout = (etb)
cursor_down              inout = (sub)
cursor_left              inout = (bs)
cursor_right             inout = (can)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = wrap_adjacent_next
move_past_left           type  = wrap_adjacent_next
move_past_top            type  = wrap_same_next
move_past_bottom         type  = wrap_same_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = wrap_adjacent_next
char_past_left           type  = wrap_adjacent_next
char_past_last_position  type  = wrap_adjacent_next

"   TERMINAL ATTRIBUTES                                                       "
automatic_tabbing        value = FALSE
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 0
has_hidden               value = TRUE
has_protect              value = TRUE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = TRUE

"   SCREEN SIZES                                                              "
set_size       rows = 30 columns = 80   out = (rs dc2 'H' rs dc2 '^')  ..
 character_specification = (11,70,4) line_specification = (1,29,2) ..
 device = 'TOUCH_PANEL'
set_size rows = 30 columns = 132  out = (rs dc2 'G' rs dc2 '^') ..
 character_positions = (20,26,33,39,45,51,57,64,70,76,82,88, ..
 95,101,107,113) line_specification = (1,29,2) device = 'TOUCH_PANEL'

"   SCREEN AND LINE MODE TRANSITION                                           "
set_screen_mode     out = (push_fn_keys  shift_numeric_pad  enable_clear...
 large_cyber_mode  disable_auto_cr  enable_cr_delim  clear_all_tabs ...
 enable_blink  end_print  page_mode  disable_old_attr ..
 "enable_touchpanel" "enable_autotab" )

set_line_mode       out = (scroll_mode  enable_auto_cr  clear_all_tabs  ...
 "disable_touchpanel" pop_fn_keys "disable_autotab" )

"   TERMINAL CAPABILITIES                                                     "
delete_char         inout = (rs 4e(16))       label='DLETE_C'
delete_line_stay    inout = (rs 51(16))       label='DLETE_L'
erase_char          inout = (1f(16))
erase_end_of_line   inout = (vt)              label='CLR_EOL'
erase_field_stay    inout = (rs 59(16))
erase_field_bof     inout = (rs 5D(16))
erase_page_home     inout = (ff)              label='CLEAR_P'
insert_char         inout = (rs 4f(16))       label='INSRT_C'
insert_line_stay    inout = (rs 52(16))       label='INSRT_L'
tab_backward        inout = (rs 0b(16))
tab_clear           inout = (rs dc2 'X')
tab_clear_all       inout = (clear_all_tabs)
tab_forward         inout = (ht)
tab_set             inout = (rs dc2 'W')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
output_begin        out = (disable_protect)
output_end          out = (enable_protect)
protect_all         out = (rs 'G')

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (rs 71(16)) label= 'f1'
f2        in = (rs 72(16)) label= 'f2'
f3        in = (rs 73(16)) label= 'f3'
f4        in = (rs 74(16)) label= 'f4'
f5        in = (rs 75(16)) label= 'f5'
f6        in = (rs 76(16)) label= 'f6'
f7        in = (rs 77(16)) label= 'f7'
f8        in = (rs 78(16)) label= 'f8'
f9        in = (rs 79(16)) label= 'f9'
f10       in = (rs 7A(16)) label= '10'
f11       in = (rs 7B(16)) label= '11'
f12       in = (rs 7C(16)) label= '12'
f13       in = (rs 7D(16)) label= '13'
f14       in = (rs 7E(16)) label= '14'
f15       in = (rs 70(16)) label= '15'
f16       in = (rs dc2 31(16)) label= '16'
f1_s      in = (rs 61(16))     label= '  SF1'
f2_s      in = (rs 62(16))     label= '  SF2'
f3_s      in = (rs 63(16))     label= '  SF3'
f4_s      in = (rs 64(16))     label= '  SF4'
f5_s      in = (rs 65(16))     label= '  SF5'
f6_s      in = (rs 66(16))     label= '  SF6'
f7_s      in = (rs 67(16))     label= '  SF7'
f8_s      in = (rs 68(16))     label= '  SF8'
f9_s      in = (rs 69(16))     label= '  SF9'
f10_s     in = (rs 6A(16))     label= '  SF10'
f11_s     in = (rs 6B(16))     label= '  SF11'
f12_s     in = (rs 6C(16))     label= '  SF12'
f13_s     in = (rs 6D(16))     label= '  SF13'
f14_s     in = (rs 6E(16))     label= '  SF14'
f15_s     in = (rs 60(16))     label= '  SF15'
f16_s     in = (rs dc2 32(16)) label= '  SF16'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13  label='NEXT'
undo      in = (rs 75(16))     label= 'f5'
undo_s    in = (rs 65(16))     label= '  SF5'
back      in = (rs 5F(16))     label= 'BACK'
back_s    in = (rs 5B(16))     label= 'Shift-BACK'
help      in = (rs 5C(16))     label= 'HELP'
help_s    in = (rs 58(16))     label= 'Shift-HELP'
stop      in = (rs 49(16))     label= 'STOP'
stop_s    in = (rs 4A(16))     label= 'Shift-STOP'
down      in = (rs dc2 20(16)) label= 'DOWN'
down_s    in = (rs dc2 21(16)) label= 'Shift-DOWN'
up        in = (rs dc2 24(16)) label= 'UP'
up_s      in = (rs dc2 25(16)) label= 'Shift-UP'
fwd       in = (rs dc2 28(16)) label= 'FWD'
fwd_s     in = (rs dc2 29(16)) label= 'Shift-FWD'
bkw       in = (rs dc2 2C(16)) label= 'BKW'
bkw_s     in = (rs dc2 2d(16)) label= 'Shift-BKW'
edit      in = (rs 5E(16))     label= 'EDIT'
edit_s    in = (rs 5A(16))     label= 'Shift-EDIT'
data      in = (rs dc2 35(16)) label= 'DATA'
data_s    in = (rs dc2 36(16)) label= 'Shift-DATA'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (fs)
alt_end             out = (gs)
blink_begin         out = (so etx)
blink_end           out = (si)
hidden_begin        out = (rs dc2 '[')
hidden_end          out = (rs dc2 5C(16))
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
protect_begin       out = (rs dc2 'I')
protect_end         out = (rs dc2 'J')
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)
low_intensity_begin  out = (fs)
low_intensity_end    out = (gs)
high_intensity_begin out = (gs)
high_intensity_end   out = (fs)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)
message_begin       out = ()
message_end         out = ()
output_text_begin   out = ()
output_text_end     out = ()
title_begin         out = ()
title_end           out = ()

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = (rs fs)
ld_fine_end              out = (rs gs)
ld_fine_horizontal       out = 20(16)
ld_fine_vertical         out = 21(16)
ld_fine_upper_left       out = 22(16)
ld_fine_upper_right      out = 23(16)
ld_fine_lower_left       out = 24(16)
ld_fine_lower_right      out = 25(16)
ld_fine_up_t             out = 26(16)
ld_fine_down_t           out = 27(16)
ld_fine_left_t           out = 28(16)
ld_fine_right_t          out = 29(16)
ld_fine_cross            out = 2A(16)
ld_medium_begin          out = (rs fs)
ld_medium_end            out = (rs gs)
ld_medium_horizontal     out = 2B(16)
ld_medium_vertical       out = 2C(16)
ld_medium_upper_left     out = 2D(16)
ld_medium_upper_right    out = 2E(16)
ld_medium_lower_left     out = 2F(16)
ld_medium_lower_right    out = 30(16)
ld_medium_up_t           out = 31(16)
ld_medium_down_t         out = 32(16)
ld_medium_left_t         out = 33(16)
ld_medium_right_t        out = 34(16)
ld_medium_cross          out = 35(16)
ld_bold_begin            out = start_inverse
ld_bold_end              out = stop_inverse
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

application_string name=('FSE_FUNCTION_1') out=('mark_lines')
application_string name=('FSE_FUNCTION_1_LABEL') out=(' MARK ')

application_string name=('FSE_FUNCTION_2') out=('mark_characters')
application_string name=('FSE_FUNCTION_2_LABEL') out=(' Chrmk')

application_string name=('FSE_FUNCTION_3') out=('align_screen top=first')
application_string name=('FSE_FUNCTION_3_LABEL') out=(' FIRST')

application_string name=('FSE_FUNCTION_4') out=('align_screen middle=current')
application_string name=('FSE_FUNCTION_4_LABEL') out=('middle')

application_string name=('FSE_FUNCTION_5') out=('undo')
application_string name=('FSE_FUNCTION_5_LABEL') out=(' UNDO ')

application_string name=('FSE_FUNCTION_6') out=('end')
application_string name=('FSE_FUNCTION_6_LABEL') out=(' END  ')

application_string name=('FSE_FUNCTION_7') out=('locate_string t=$screen_input(''Enter search string'')')
application_string name=('FSE_FUNCTION_7_LABEL') out=('LOCATE')

application_string name=('FSE_FUNCTION_8') out=('esv$text=$screen_input(''Enter search string''); if esv$text='''' then; locate_all; else; locate_all t=esv$text; ifend')
application_string name=('FSE_FUNCTION_8_LABEL') out=('locall')

application_string name=('FSE_FUNCTION_9') out=('insert_empty_lines p=b n=$split_size-4; position_cursor d=b n=2; align_screen top=c; position_cursor r=$title_row+3')
application_string name=('FSE_FUNCTION_9_LABEL') out=(' insel')

application_string name=('FSE_FUNCTION_10') out=('insert_characters nt=''                                ''')
application_string name=('FSE_FUNCTION_10_LABEL') out=('inswrd')

application_string name=('FSE_FUNCTION_11') out=('break_text')
application_string name=('FSE_FUNCTION_11_LABEL') out=(' Break')

application_string name=('FSE_FUNCTION_12') out=('join_text')
application_string name=('FSE_FUNCTION_12_LABEL') out=(' Join ')

application_string name=('FSE_FUNCTION_13') out=(' ')
application_string name=('FSE_FUNCTION_13_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_14') out=('copy_text l=m p=b')
application_string name=('FSE_FUNCTION_14_LABEL') out=(' Copy ')

application_string name=('FSE_FUNCTION_15') out=('indent_text l=m offset=2')
application_string name=('FSE_FUNCTION_15_LABEL') out=('INDENT')

application_string name=('FSE_FUNCTION_16') out=('format_paragraphs')
application_string name=('FSE_FUNCTION_16_LABEL') out=('format')


application_string name=('FSE_FUNCTION_SHIFT_1') out=('unmark')
application_string name=('FSE_FUNCTION_SHIFT_1_LABEL') out=(' Unmrk')

application_string name=('FSE_FUNCTION_SHIFT_2') out=('mark_boxes')
application_string name=('FSE_FUNCTION_SHIFT_2_LABEL') out=(' Boxmk')

application_string name=('FSE_FUNCTION_SHIFT_3') out=('align_screen middle=last')
application_string name=('FSE_FUNCTION_SHIFT_3_LABEL') out=(' LAST ')

application_string name=('FSE_FUNCTION_SHIFT_4') out=('position_cursor l=c c=$strlen($lt)+1')
application_string name=('FSE_FUNCTION_SHIFT_4_LABEL') out=('endlin')

application_string name=('FSE_FUNCTION_SHIFT_5') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_5_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_6') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_6_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_7') out=('locate_next')
application_string name=('FSE_FUNCTION_SHIFT_7_LABEL') out=('locnxt')

application_string name=('FSE_FUNCTION_SHIFT_8') out=('exchange_screen_width')
application_string name=('FSE_FUNCTION_SHIFT_8_LABEL') out=('80/132')

application_string name=('FSE_FUNCTION_SHIFT_9') out=('delete_empty_lines')
application_string name=('FSE_FUNCTION_SHIFT_9_LABEL') out=(' delel')

application_string name=('FSE_FUNCTION_SHIFT_10') out=('delete_word')
application_string name=('FSE_FUNCTION_SHIFT_10_LABEL') out=('delwrd')

application_string name=('FSE_FUNCTION_SHIFT_11') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_11_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_12') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_12_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_13') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_13_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_14') out=('move_text l=m p=b; unmark')
application_string name=('FSE_FUNCTION_SHIFT_14_LABEL') out=(' Move ')

application_string name=('FSE_FUNCTION_SHIFT_15') out=('indent_text l=m offset=-2')
application_string name=('FSE_FUNCTION_SHIFT_15_LABEL') out=('dedent')

application_string name=('FSE_FUNCTION_SHIFT_16') out=('center_lines')
application_string name=('FSE_FUNCTION_SHIFT_16_LABEL') out=('center')


"   KEY REDEFINITIONS FOR THE FULL SCREEN EDITOR WHEN USED FROM THE PROGRAMMING ENVIRONMENT "

application_string name=('pe_fix_allerr_func') out=('key=6 shift=true')
application_string name=('pe_fix_assist_func') out=('key=5 shift=true')
application_string name=('pe_fix_format_func') out=('key=16 shift=true')
application_string name=('pe_fix_lookup_func') out=('key=16 shift=false')
application_string name=('pe_fix_nxterr_func') out=('key=12 shift=true')
application_string name=('pe_fix_nxtler_func') out=('key=11 shift=true')
application_string name=('pe_fix_run_func')    out=('key=13 shift=false')
application_string name=('pe_fix_rundbg_func') out=('key=13 shift=true')

application_string name=('pe_fixl_assist_func') out=('key=5 shift=true')
application_string name=('pe_fixl_format_func') out=('key=16 shift=true')
application_string name=('pe_fixl_lookup_func') out=('key=16 shift=false')
application_string name=('pe_fixl_nxterr_func') out=('key=12 shift=true')
application_string name=('pe_fixl_run_func')    out=('key=13 shift=false')
application_string name=('pe_fixl_rundbg_func') out=('key=13 shift=true')

application_string name=('pe_template_modify_format_func') out=('key=16 shift=true')
application_string name=('pe_template_modify_lookup_func') out=('key=16 shift=false')

application_string name=('pe_modify_create_format_func') out=('key=16 shift=true')
application_string name=('pe_modify_create_lookup_func') out=('key=16 shift=false')
application_string name=('pe_modify_create_run_func')    out=('key=13 shift=false')
application_string name=('pe_modify_create_rundbg_func') out=('key=13 shift=true')

application_string name=('pe_view_end_func')    out=('key=6 shift=false')
application_string name=('pe_view_export_func') out=('key=16 shift=true')
application_string name=('pe_view_print_func')  out=('key=16 shift=false')

"   END OF TERMINAL DEFINITION FILE FOR CDC VIKING 721 TERMINAL               "
*DECK DECK=CSM$OLD_CDC722 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR CDC VIKING 722 TERMINAL                      "

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'OLD_CDC722'
communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (32)   type = binary_cursor
cursor_pos_column_first  value = TRUE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (esc 31(16))

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (em)      label='HOME'
cursor_up                inout = (sub)
cursor_down              inout = (lf)
cursor_left              inout = (bs)
cursor_right             inout = (nak)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = wrap_adjacent_next
move_past_left           type  = wrap_adjacent_next
move_past_top            type  = wrap_same_next
move_past_bottom         type  = scroll_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = wrap_adjacent_next
char_past_left           type  = wrap_adjacent_next
char_past_last_position  type  = scroll_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = FALSE
function_key_leaves_mark value = 0
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = FALSE
multiple_sizes           value = FALSE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = FALSE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80

"   TERMINAL CAPABILITIES                                                     "
erase_end_of_line   inout = (syn)    label='CLR_EOL'
erase_page_home     inout = (can)    label='CLEAR_P'
tab_forward         inout = (ht)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
output_begin        out = ()
output_end          out = ()
bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (rs 'q')      label = 'f1'
f2        in = (rs 'r')      label = 'f2'
f3        in = (rs 's')      label = 'f3'
f4        in = (rs 't')      label = 'f4'
f5        in = (rs 'u')      label = 'f5'
f6        in = (rs 'v')      label = 'f6'
f7        in = (rs 'w')      label = 'f7'
f8        in = (rs 'x')      label = 'f8'
f9        in = (rs 'y')      label = 'f9'
f10       in = (rs 'z')      label = '10'
f11       in = (rs '{')      label = '11'
f12       in = ()
f13       in = ()
f14       in = ()
f15       in = ()
f16       in = ()

f1_s      in = (rs 'a')      label = '  SF1'
f2_s      in = (rs 'b')      label = '  SF2'
f3_s      in = (rs 'c')      label = '  SF3'
f4_s      in = (rs 'd')      label = '  SF4'
f5_s      in = (rs 'e')      label = '  SF5'
f6_s      in = (rs 'f')      label = '  SF6'
f7_s      in = (rs 'g')      label = '  SF7'
f8_s      in = (rs 'h')      label = '  SF8'
f9_s      in = (rs 'i')      label = '  SF9'
f10_s     in = (rs 'j')      label = '  SF10'
f11_s     in = (rs 'k')      label = '  SF11'
f12_s     in = ()
f13_s     in = ()
f14_s     in = ()
f15_s     in = ()
f16_s     in = ()

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'NEWLINE'
next_s    in = ()
bkw       in = (rs 'q')      label = 'f1'
fwd       in = (rs 'r')      label = 'f2'
back      in = (rs 's')      label = 'f3'
help      in = (rs 't')      label = 'f4'
undo      in = (rs 'u')      label = 'f5'
stop      in = (rs 'v')      label = 'f6'
bkw_s     in = (rs 'a')      label = '  SF1'
fwd_s     in = (rs 'b')      label = '  SF2'
undo_s    in = (rs 'e')      label = '  SF5'
stop_s    in = (rs 'f')      label = '  SF6'
back_s    in = ()
help_s    in = ()
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_horizontal       out = ('-')
ld_fine_vertical         out = ('|')
ld_fine_upper_left       out = ('*')
ld_fine_upper_right      out = ('*')
ld_fine_lower_left       out = ('*')
ld_fine_lower_right      out = ('*')
ld_fine_up_t             out = ('*')
ld_fine_down_t           out = ('*')
ld_fine_left_t           out = ('*')
ld_fine_right_t          out = ('*')
ld_fine_cross            out = ('*')
ld_medium_horizontal     out = ('-')
ld_medium_vertical       out = ('|')
ld_medium_upper_left     out = ('*')
ld_medium_upper_right    out = ('*')
ld_medium_lower_left     out = ('*')
ld_medium_lower_right    out = ('*')
ld_medium_up_t           out = ('*')
ld_medium_down_t         out = ('*')
ld_medium_left_t         out = ('*')
ld_medium_right_t        out = ('*')
ld_medium_cross          out = ('*')
ld_bold_horizontal       out = ('-')
ld_bold_vertical         out = ('|')
ld_bold_upper_left       out = ('*')
ld_bold_upper_right      out = ('*')
ld_bold_lower_left       out = ('*')
ld_bold_lower_right      out = ('*')
ld_bold_up_t             out = ('*')
ld_bold_down_t           out = ('*')
ld_bold_left_t           out = ('*')
ld_bold_right_t          out = ('*')
ld_bold_cross            out = ('*')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

application_string name=('FSE_FUNCTION_1') out=('align_screen top=last_screen')
application_string name=('FSE_FUNCTION_1_LABEL') out=(' FWD  ')

application_string name=('FSE_FUNCTION_2') out=('align_screen top=current')
application_string name=('FSE_FUNCTION_2_LABEL') out=('Lineup')

application_string name=('FSE_FUNCTION_3') out=('insert_characters nt='' ''')
application_string name=('FSE_FUNCTION_3_LABEL') out=(' INSC ')

application_string name=('FSE_FUNCTION_4') out=('insert_lines p=b nt=''''')
application_string name=('FSE_FUNCTION_4_LABEL') out=(' INSL ')

application_string name=('FSE_FUNCTION_5') out=('mark_lines')
application_string name=('FSE_FUNCTION_5_LABEL') out=(' MARK ')

application_string name=('FSE_FUNCTION_6') out=('copy_text l=m p=b')
application_string name=('FSE_FUNCTION_6_LABEL') out=(' Copy ')

application_string name=('FSE_FUNCTION_7') out=('help')
application_string name=('FSE_FUNCTION_7_LABEL') out=(' HELP ')

application_string name=('FSE_FUNCTION_8') out=('end')
application_string name=('FSE_FUNCTION_8_LABEL') out=(' END  ')

application_string name=('FSE_FUNCTION_9') out=('position_cursor l=c c=$strlen($lt)+1')
application_string name=('FSE_FUNCTION_9_LABEL') out=('Endlin')

application_string name=('FSE_FUNCTION_10') out=(' ')
application_string name=('FSE_FUNCTION_10_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_11') out=(' ')
application_string name=('FSE_FUNCTION_11_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_12') out=(' ')
application_string name=('FSE_FUNCTION_12_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_13') out=(' ')
application_string name=('FSE_FUNCTION_13_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_14') out=(' ')
application_string name=('FSE_FUNCTION_14_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_15') out=(' ')
application_string name=('FSE_FUNCTION_15_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_16') out=(' ')
application_string name=('FSE_FUNCTION_16_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_SHIFT_1') out=('align_screen bottom=first_screen')
application_string name=('FSE_FUNCTION_SHIFT_1_LABEL') out=(' BKW  ')

application_string name=('FSE_FUNCTION_SHIFT_2') out=('align_screen bottom=current')
application_string name=('FSE_FUNCTION_SHIFT_2_LABEL') out=('Linedn')

application_string name=('FSE_FUNCTION_SHIFT_3') out=('delete_characters c=c')
application_string name=('FSE_FUNCTION_SHIFT_3_LABEL') out=(' DELC ')

application_string name=('FSE_FUNCTION_SHIFT_4') out=('delete_lines l=c')
application_string name=('FSE_FUNCTION_SHIFT_4_LABEL') out=(' DELL ')

application_string name=('FSE_FUNCTION_SHIFT_5') out=('undo')
application_string name=('FSE_FUNCTION_SHIFT_5_LABEL') out=(' Undo ')

application_string name=('FSE_FUNCTION_SHIFT_6') out=('move_text l=m p=b; unmark')
application_string name=('FSE_FUNCTION_SHIFT_6_LABEL') out=(' Move ')

application_string name=('FSE_FUNCTION_SHIFT_7') out=('align_screen o=0')
application_string name=('FSE_FUNCTION_SHIFT_7_LABEL') out=(' Left ')

application_string name=('FSE_FUNCTION_SHIFT_8') out=('esv$off=30; if $current_column<>1 then; esv$off=$current_column-1; ifend; align_screen offset=esv$off; position_cursor l=c c=$current_column+30')
application_string name=('FSE_FUNCTION_SHIFT_8_LABEL') out=(' Right')

application_string name=('FSE_FUNCTION_SHIFT_9') out=('unmark')
application_string name=('FSE_FUNCTION_SHIFT_9_LABEL') out=(' Unmrk')

application_string name=('FSE_FUNCTION_SHIFT_10') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_10_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_11') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_11_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_12') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_12_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_13') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_13_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_14') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_14_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_15') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_15_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_16') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_16_LABEL') out=(' ')


"   KEY REDEFINITIONS FOR THE FULL SCREEN EDITOR WHEN USED FROM THE PROGRAMMING ENVIRONMENT "

application_string name=('pe_fix_allerr_func') out=('key=9 shift=false')
application_string name=('pe_fix_assist_func') out=('key=5 shift=false')
application_string name=('pe_fix_format_func') out=('key=8 shift=true')
application_string name=('pe_fix_lookup_func') out=('key=7 shift=true')
application_string name=('pe_fix_nxterr_func') out=('key=6 shift=false')
application_string name=('pe_fix_nxtler_func') out=('key=6 shift=true')
application_string name=('pe_fix_run_func')    out=('key=2 shift=false')
application_string name=('pe_fix_rundbg_func') out=('key=2 shift=true')

application_string name=('pe_fixl_assist_func') out=('key=5 shift=false')
application_string name=('pe_fixl_format_func') out=('key=8 shift=true')
application_string name=('pe_fixl_lookup_func') out=('key=7 shift=true')
application_string name=('pe_fixl_nxterr_func') out=('key=6 shift=false')
application_string name=('pe_fixl_run_func')    out=('key=2 shift=false')
application_string name=('pe_fixl_rundbg_func') out=('key=2 shift=true')

application_string name=('pe_template_modify_format_func') out=('key=8 shift=true')
application_string name=('pe_template_modify_lookup_func') out=('key=7 shift=true')

application_string name=('pe_modify_create_format_func') out=('key=8 shift=true')
application_string name=('pe_modify_create_lookup_func') out=('key=7 shift=true')
application_string name=('pe_modify_create_run_func')    out=('key=2 shift=false')
application_string name=('pe_modify_create_rundbg_func') out=('key=2 shift=true')

application_string name=('pe_view_end_func')    out=('key=8 shift=false')
application_string name=('pe_view_export_func') out=('key=8 shift=true')
application_string name=('pe_view_print_func')  out=('key=7 shift=true')

"   END OF TERMINAL DEFINITION FILE FOR CDC 722 TERMINAL                      "
*DECK DECK=CSM$OLD_CDC722_30 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR CDC 722-30 TERMINAL                          "

"   Note that this terminal definition is supplied with protection and auto-  "
"   tabbing enabled with protected areas dim and unprotected areas bright.    "
"   This arrangement is best for applications that use most of their screen   "
"   area for unprotected (input) fields, such as the Full Screen Editor.      "
"   If you primarily use this terminal with applications that protect most of "
"   the screen area, such as Edit_Catalog, you may prefer to reverse the dim  "
"   and bright assignments.  If you frequently switch between applications    "
"   that are mostly protected versus mostly unprotected, you may prefer to    "
"   use the terminal with all areas bright and no protection.                 "

"   To modify this definition to drop protection and have all areas bright,   "
"   look for statements that have the comments FOR EITHER BRIGHT OR DIM       "
"   PROTECTION and remove or disable (via comments) such statements.  Then    "
"   look for comment-disabled statements that have the comments FOR NO        "
"   PROTECTION and enable these statements by blanking the comments away.     "

"   You also have the option to modify this definition to keep protection and "
"   auto-tabbing, but with the bright/dim exchanged so that protected areas   "
"   are bright and unprotected areas are dim.  To do so, look for statements  "
"   commented as FOR PROTECT=DIM and FOR PROTECT=BRIGHT, and enable/disable   "
"   such statements by reversing th comment quotes.                           "

"   VARIABLES                                                                 "
    prefix              = ( 1B(16) 5B(16))
    clear_stay          = ( prefix 32(16) 4A(16) )
    clear_eop           = ( prefix 4A(16) )
    clear_all_tabs      = ( prefix 33(16) 67(16) )
    home_cursor         = ( prefix 48(16) )
    enable_insertion    = ( prefix 34(16) 68(16) )
    disable_insertion   = ( prefix 34(16) 6C(16) )

    enable_protect      = ( prefix 31(16) 7D(16) )  "for protect=dim"
  " enable_protect      = ( prefix '254'  7D(16) )   for protect=bright"

    disable_protect     = ( prefix 30(16) 7D(16) )
    start_alternate     = ( prefix 31(16) 6D(16) )
    stop_alternate      = ( prefix 6D(16) )
    start_blink         = ( prefix 35(16) 6D(16) )
    stop_blink          = ( prefix 6D(16) )
    erase_all_off       = ( prefix 36(16) 6C(16) )
    erase_all_on        = ( prefix 36(16) 68(16) )
    normal              = ( prefix 6D(16) )
    start_hidden        = ( prefix 36(16) 6D(16) )
    stop_hidden         = ( prefix 6D(16) )
    start_inverse       = ( prefix 37(16) 6D(16) )
    stop_inverse        = ( prefix 6D(16) )
    start_underline     = ( prefix 34(16) 6D(16) )
    stop_underline      = ( prefix 6D(16) )
    enable_buffer       = ( prefix '>h' )
    disable_buffer      = ( prefix '>l' )
    clear_buffer        = ( prefix '1~' )
    release_buffer      = ( prefix '0~' )
    stop_scroll         = ( prefix '?7l' )
    start_scroll        = ( prefix '?7h' )
    start_wrap          = ( prefix 3F(16) 37(16) 68(16))
    stop_wrap           = ( prefix 3F(16) 37(16) 6C(16))

    start_protect       = ( start_alternate )   " for protect=dim "
    stop_protect        = ( stop_alternate )    " for protect=dim "
  " start_protect       = ( stop_alternate )      for protect=bright "
  " stop_protect        = ( start_alternate )     for protect=bright "

    n_pad_shift         = ( 1b(16) '[=1h' 1e(16) 12(16) 'k' 1e(16) 12(16)..
                            'S2' 1b(16) '[2J')
    n_pad_normal        = ( 1b(16) '[=1h' 1e(16) 12(16) 'l' 1e(16) 12(16)..
                            'S2' 1b(16) '[2J')
    designate_text      = ( 1B(16) 28(16) 42(16))
    designate_graphics  = ( 1B(16) 29(16) 30(16))
    invoke_text         = ( 0F(16))
    invoke_graphics     = ( 0E(16))

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'OLD_CDC722_30'
    communications      type  = asynch

"   BACKSPACE SPECIFIED                                                       "
    backspace           in =  ( 08(16) )

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   =  prefix
    cursor_pos_second        out   = ( 3B(16) )
    cursor_pos_third         out   = ( 48(16) )

"   CURSOR MOVEMENT INFORMATION
    cursor_home              inout = ( home_cursor )   label='HOME'
    cursor_up                inout = ( prefix 41(16) )
    cursor_down              inout = ( prefix 42(16) )
    cursor_left              inout = ( prefix 44(16) )
    cursor_right             inout = ( prefix 43(16) )

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next
    char_past_left           type  = stop_next
    char_past_last_position  type  = scroll_next

"   TERMINAL ATTRIBUTES                                                       "

    automatic_tabbing        value = TRUE  " for either bright or dim protect "
  " automatic_tabbing        value = FALSE   for no protection "

    clears_when_change_size  value = FALSE
    function_key_leaves_mark value = 0
    has_hidden               value = TRUE

    has_protect              value = TRUE  " for either bright or dim protect "
  " has_protect              value = FALSE   for no protection "

    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE

    tabs_to_unprotected      value = TRUE  " for either bright or dim protect "
  " tabs_to_unprotected      value = FALSE   for no protection "

    type_ahead               value = TRUE

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode     out = ( enable_buffer  clear_all_tabs ..
        designate_text  designate_graphics  invoke_text ..
        stop_scroll  start_wrap   n_pad_shift)

    set_line_mode       out = ( clear_all_tabs  designate_text ..
        designate_graphics  invoke_text  disable_buffer  start_scroll ..
        n_pad_normal  "stop_wrap"   home_cursor)

"   TERMINAL CAPABILITIES                                                     "
    delete_char         inout = ( prefix 50(16) )     label='C_DLETE'
    delete_line_stay    inout = ( prefix 4D(16) )     label='L_DLETE'
    erase_end_of_line   inout = ( prefix 4B(16) )     label='CLR_EOL'
    erase_end_of_page   inout = ( clear_eop )
    erase_line_stay     inout = ( prefix 32(16) 4B(16) )
    erase_page_stay     inout = ( clear_stay )        label='CLEAR_P'
    insert_line_stay    inout = ( prefix 4C(16) )     label='L_INSRT'
    insert_mode_begin   inout = ( enable_insertion )  label='BGN_INS'
    insert_mode_end     inout = ( disable_insertion )
" protect_all out=(start_protect clear_stay stop_protect) for protect=bright "
    tab_backward        inout = ( prefix 46(16) )
    tab_forward         inout = ( 09(16) )
    tab_clear_all       inout = ( clear_all_tabs )
    tab_set             inout = ( 1B(16) 48(16) )

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "

    output_begin        out = ( disable_protect erase_all_on normal) " for either bright or dim protect "
    output_end          out = ( enable_protect erase_all_off release_buffer ) " for either bright or dim protect "
  " output_begin        out = ( erase_all_on normal) for no protection "
  " output_end          out=(erase_all_off release_buffer)  for no protection "

    bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = ( 1B(16) 4F(16) 50(16) )    label='f1'
    f2        in = ( 1B(16) 4F(16) 51(16) )    label='f2'
    f3        in = ( 1B(16) 4F(16) 52(16) )    label='f3'
    f4        in = ( 1B(16) 4F(16) 53(16) )    label='f4'
    f5        in = ( 1B(16) 4F(16) 6D(16) )    label='f5'
    f6        in = ( 1B(16) 4F(16) 6C(16) )    label='f6'
    f7        in = ( 1B(16) 4F(16) 4D(16) )    label='f7'
    f8        in = ( 1B(16) 4F(16) 6E(16) )    label='f8'
    f9        in = ( 1B(16) 4F(16) 41(16) )    label='f9'
    f10       in = ( 1B(16) 4F(16) 42(16) )    label='10'
    f11       in = ( 1B(16) 4F(16) 43(16) )    label='11'
    f12       in = ( 1B(16) 4F(16) 44(16) )    label='12'
    f13       in = ( )
    f14       in = ( )
    f15       in = ( )
    f16       in = ( )
    f1_s      in = ( 1B(16) 4F(16) 71(16) )    label='  SF1'
    f2_s      in = ( 1B(16) 4F(16) 72(16) )    label='  SF2'
    f3_s      in = ( 1B(16) 4F(16) 73(16) )    label='  SF3'
    f4_s      in = ( 1B(16) 4F(16) 74(16) )    label='  SF4'
    f5_s      in = ( 1B(16) 4F(16) 75(16) )    label='  SF5'
    f6_s      in = ( 1B(16) 4F(16) 76(16) )    label='  SF6'
    f7_s      in = ( 1B(16) 4F(16) 77(16) )    label='  SF7'
    f8_s      in = ( 1B(16) 4F(16) 78(16) )    label='  SF8'
    f9_s      in = ( 1B(16) 4F(16) 79(16) )    label='  SF9'
    f10_s     in = ( 1B(16) 4F(16) 70(16) )    label='  SF10'
    f11_s     in = ( 1B(16) 4F(16) 7A(16) )    label='  SF11'
    f12_s     in = ( 1B(16) 4F(16) 7B(16) )    label='  SF12'
    f13_s     in = ( )
    f14_s     in = ( )
    f15_s     in = ( )
    f16_s     in = ( )

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in=13                            label='RETURN'
    next_s    in=()
    bkw       in = ( 1B(16) 4F(16) 50(16) )    label='f1'
    fwd       in = ( 1B(16) 4F(16) 51(16) )    label='f2'
    back      in = ( 1B(16) 4F(16) 52(16) )    label='f3'
    help      in = ( 1B(16) 4F(16) 53(16) )    label='f4'
    undo      in = ( 1B(16) 4F(16) 6D(16) )    label='f5'
    stop      in = ( 1B(16) 4F(16) 6C(16) )    label='f6'
    bkw_s     in = ( 1B(16) 4F(16) 71(16) )    label='  SF1'
    fwd_s     in = ( 1B(16) 4F(16) 72(16) )    label='  SF2'
    undo_s    in = ( 1B(16) 4F(16) 75(16) )    label='  SF5'
    stop_s    in = ( 1B(16) 4F(16) 76(16) )    label='  SF6'
    edit      in = ( esc '[?10l' )
    edit_s    in = ( )
    data      in = ( )
    data_s    in = ( )

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out =  start_alternate
    alt_end             out =  stop_alternate
    blink_begin         out =  start_blink
    blink_end           out =  stop_blink
    hidden_begin        out =  start_hidden
    hidden_end          out =  stop_hidden
    inverse_begin       out =  start_inverse
    inverse_end         out =  stop_inverse

    protect_begin       out =  start_protect  " for either bright or dim protect "
    protect_end         out =  stop_protect   " for either bright or dim protect "
  " protect_begin       out =  ()             for no protection "
  " protect_end         out =  ()             for no protection "

    underline_begin     out =  start_underline
    underline_end       out =  stop_underline

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out =  start_inverse
    error_end           out =  stop_inverse
    input_text_begin    out =  start_underline
    input_text_end      out =  stop_underline
    italic_begin        out =  start_inverse
    italic_end          out =  stop_inverse
    message_begin       out = ()
    message_end         out = ()
    output_text_begin   out = ()
    output_text_end     out = ()
    title_begin         out = ()
    title_end           out = ()

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = ( invoke_graphics )
    ld_fine_end              out = ( invoke_text )
    ld_fine_horizontal       out = ( 71(16) )
    ld_fine_vertical         out = ( 78(16) )
    ld_fine_upper_left       out = ( 6C(16) )
    ld_fine_upper_right      out = ( 6B(16) )
    ld_fine_lower_left       out = ( 6D(16) )
    ld_fine_lower_right      out = ( 6A(16) )
    ld_fine_up_t             out = ( 77(16) )
    ld_fine_down_t           out = ( 76(16) )
    ld_fine_left_t           out = ( 74(16) )
    ld_fine_right_t          out = ( 75(16) )
    ld_fine_cross            out = ( 6E(16) )
    ld_medium_begin          out = ( invoke_graphics )
    ld_medium_end            out = ( invoke_text )
    ld_medium_horizontal     out = ( 71(16) )
    ld_medium_vertical       out = ( 78(16) )
    ld_medium_upper_left     out = ( 6C(16) )
    ld_medium_upper_right    out = ( 6B(16) )
    ld_medium_lower_left     out = ( 6D(16) )
    ld_medium_lower_right    out = ( 6A(16) )
    ld_medium_up_t           out = ( 77(16) )
    ld_medium_down_t         out = ( 76(16) )
    ld_medium_left_t         out = ( 74(16) )
    ld_medium_right_t        out = ( 75(16) )
    ld_medium_cross          out = ( 6E(16) )
    ld_bold_begin            out = ( start_inverse )
    ld_bold_end              out = ( stop_inverse )
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

application_string name=('FSE_FUNCTION_1') out=('mark_lines')
application_string name=('FSE_FUNCTION_2') out=('mark_characters')
application_string name=('FSE_FUNCTION_3') out=('align_screen top=last_screen')
application_string name=('FSE_FUNCTION_4') out=('align_screen bottom=first_screen')
application_string name=('FSE_FUNCTION_5') out=('undo')
application_string name=('FSE_FUNCTION_6') out=('end')
application_string name=('FSE_FUNCTION_7') out=('locate_text t=$screen_input(''Enter search string'')')
application_string name=('FSE_FUNCTION_8') out=('copy_text l=m p=b')
application_string name=('FSE_FUNCTION_9') out=('align_screen top=first')
application_string name=('FSE_FUNCTION_10') out=('align_screen middle=current')
application_string name=('FSE_FUNCTION_11') out=('break_text')
application_string name=('FSE_FUNCTION_12') out=('join_text')

application_string name=('FSE_FUNCTION_1_LABEL') out=(' MARK ')
application_string name=('FSE_FUNCTION_2_LABEL') out=(' Chrmk')
application_string name=('FSE_FUNCTION_3_LABEL') out=(' FWD  ')
application_string name=('FSE_FUNCTION_4_LABEL') out=(' BKW  ')
application_string name=('FSE_FUNCTION_5_LABEL') out=(' UNDO ')
application_string name=('FSE_FUNCTION_6_LABEL') out=(' END  ')
application_string name=('FSE_FUNCTION_7_LABEL') out=(' Locat')
application_string name=('FSE_FUNCTION_8_LABEL') out=(' COPY ')
application_string name=('FSE_FUNCTION_9_LABEL') out=(' First')
application_string name=('FSE_FUNCTION_10_LABEL') out=(' middl')
application_string name=('FSE_FUNCTION_11_LABEL') out=(' Break')
application_string name=('FSE_FUNCTION_12_LABEL') out=(' Join ')

application_string name=('FSE_FUNCTION_SHIFT_1') out=('unmark')
application_string name=('FSE_FUNCTION_SHIFT_2') out=('mark_boxes')
application_string name=('FSE_FUNCTION_SHIFT_3') out=('align_screen top=current')
application_string name=('FSE_FUNCTION_SHIFT_4') out=('align_screen bottom=current')
application_string name=('FSE_FUNCTION_SHIFT_5') out=('help')
application_string name=('FSE_FUNCTION_SHIFT_6') out=('if $offset=0 then; alis o=53; else; alis o=0; ifend')
application_string name=('FSE_FUNCTION_SHIFT_7') out=('position_cursor; position_cursor rs=true; ')
application_string name=('FSE_FUNCTION_SHIFT_8') out=('move_text l=m p=b; unmark')
application_string name=('FSE_FUNCTION_SHIFT_9') out=('align_screen middle=last')
application_string name=('FSE_FUNCTION_SHIFT_10') out=('position_cursor l=c c=1+$strlen($lt)')

application_string name=('FSE_FUNCTION_SHIFT_1_LABEL') out=(' Unmrk')
application_string name=('FSE_FUNCTION_SHIFT_2_LABEL') out=(' Boxmk')
application_string name=('FSE_FUNCTION_SHIFT_3_LABEL') out=(' LinUp')
application_string name=('FSE_FUNCTION_SHIFT_4_LABEL') out=(' LinDn')
application_string name=('FSE_FUNCTION_SHIFT_5_LABEL') out=(' Help ')
application_string name=('FSE_FUNCTION_SHIFT_6_LABEL') out=('Offset')
application_string name=('FSE_FUNCTION_SHIFT_7_LABEL') out=('locnxt')
application_string name=('FSE_FUNCTION_SHIFT_8_LABEL') out=(' Move ')
application_string name=('FSE_FUNCTION_SHIFT_9_LABEL') out=(' Last ')
application_string name=('FSE_FUNCTION_SHIFT_10_LABEL') out=(' Endln')

"   KEY REDEFINITIONS FOR THE FULL SCREEN EDITOR WHEN USED FROM THE PROGRAMMING ENVIRONMENT "

application_string name=('pe_fix_allerr_func') out=('key=2 shift=false')
application_string name=('pe_fix_assist_func') out=('key=11 shift=false')
application_string name=('pe_fix_format_func') out=('key=2 shift=true')
application_string name=('pe_fix_lookup_func') out=('key=10 shift=true')
application_string name=('pe_fix_nxterr_func') out=('key=9 shift=false')
application_string name=('pe_fix_nxtler_func') out=('key=9 shift=true')
application_string name=('pe_fix_run_func')    out=('key=10 shift=false')
application_string name=('pe_fix_rundbg_func') out=('key=12 shift=false')

application_string name=('pe_fixl_assist_func') out=('key=11 shift=false')
application_string name=('pe_fixl_format_func') out=('key=2 shift=true')
application_string name=('pe_fixl_lookup_func') out=('key=10 shift=true')
application_string name=('pe_fixl_nxterr_func') out=('key=9 shift=false')
application_string name=('pe_fixl_run_func')    out=('key=10 shift=false')
application_string name=('pe_fixl_rundbg_func') out=('key=12 shift=false')

application_string name=('pe_template_modify_format_func') out=('key=2 shift=true')
application_string name=('pe_template_modify_lookup_func') out=('key=10 shift=true')

application_string name=('pe_modify_create_format_func') out=('key=2 shift=true')
application_string name=('pe_modify_create_lookup_func') out=('key=10 shift=true')
application_string name=('pe_modify_create_run_func')    out=('key=10 shift=false')
application_string name=('pe_modify_create_rundbg_func') out=('key=12 shift=false')

application_string name=('pe_view_end_func')    out=('key=6 shift=false')
application_string name=('pe_view_export_func') out=('key=2 shift=true')
application_string name=('pe_view_print_func')  out=('key=10 shift=true')

"   END OF TERMINAL DEFINITION FILE FOR CDC 722-30 TERMINAL                   "
*DECK DECK=CSM$OLD_MAC_CONNECT_10 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR MAC_CONNECT_10  VERSION 1.0   APRIL 14, 1986 "
"                                                                             "
"   NOS/VE TERMINAL DEFINITION FILE FOR Macintosh using Control Data Connect  "
"   (basic VT100 plus function key definitions).  Connect should be run with  "
"   local echo on or echoplex for the insert/delete functions to work.        "
"   Important Terminal... and Compatiblity... settings in Connect are:        "
"     Repeat Ctrls           OFF                                              "
"     New Line               OFF                                              "
"     Auto Wraparound        ON                                               "
"     XON/XOFF Flow Control  ON                                               "
"   If Auto Wraparound is OFF, make the following change:                     "
"     char_past_right          type = stop_next                               "
"     char_past_last_position  type = stop_next                               "
"                                                                             "

"   VARIABLES                                                                 "
    prefix              = (esc 5B(16))
    clear_stay          = (prefix 32(16) 4A(16))
    clear_all_tabs      = (prefix 33(16) 67(16))
    set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))
    set_to_24x132       = (prefix 3F(16) 33(16) 68(16))
    start_alternate     = (prefix 31(16) 6D(16))
    start_blink         = (prefix 35(16) 6D(16))
    start_inverse       = (prefix 37(16) 6D(16))
    start_underline     = (prefix 34(16) 6D(16))
    stop_alternate      = (prefix 6D(16))
    stop_blink          = (prefix 6D(16))
    stop_inverse        = (prefix 6D(16))
    stop_underline      = (prefix 6D(16))

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'OLD_MAC_CONNECT_10'
    communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix)
    cursor_pos_second        out   = (3B(16))
    cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (prefix 48(16)) label='Option H'
    cursor_up                inout = (prefix 41(16)) label='Option I'
    cursor_down              inout = (prefix 42(16)) label='Option M'
    cursor_left              inout = (prefix 44(16)) label='Option K'
    cursor_right             inout = (prefix 43(16)) label='Option J'

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = stop_next
    move_past_left           type  = stop_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next
    char_past_left           type  = stop_next
    char_past_last_position  type  = scroll_next

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 0                  "for MAC"
    has_hidden               value = FALSE
    has_protect              value = FALSE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = TRUE

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80   out = (set_to_24x80)
    set_size       rows = 24 columns = 132  out = (set_to_24x132)

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode     out = (esc 3C(16) clear_all_tabs ..
         esc 28(16) 42(16) esc 29(16) 30(16) 0F(16) esc ..
         3D(16))

    set_line_mode       out = (esc 3C(16) clear_all_tabs ..
         esc 28(16) 42(16) esc 29(16) 30(16) 0F(16) esc ..
         3E(16))

"   TERMINAL CAPABILITIES                                                    "
    insert_char         inout = (prefix '@') label='Option Space'
    delete_char         inout = (prefix 'P') label='Option Backspace'
    delete_line_bol     inout = (prefix 'M') label='Option Shift Backspace'
    insert_line_bol     inout = (prefix 'L') label='Option Shift Space'
    erase_end_of_line   inout = (prefix 'K') label='Option C'
    erase_line_stay     inout = (prefix '2K')
    erase_page_stay     inout = (clear_stay) label='Option Shift C'
    backspace           in = (08(16))
    tab_forward         inout = (09(16))
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (esc 48(16))

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    output_begin        out = (prefix 34(16) 6C(16))
    bell_nak            out = (bel)

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = (CR)           label='Return'
    next_s    in = (ESC CR)       label='Shift Return'
    data      in = (ESC 27(16))   label='Option "'
    data_s    in = (ESC '"')      label='Option Shift "'
    back      in = (ESC ';')      label='Option ;'
    back_s    in = (ESC ':')      label='Option Shift ;'
    help      in = (ESC '/')      label='Option ?'
    help_s    in = (ESC '?')      label='Option Shift ?'
    edit      in = (ESC '.')      label='Option .'
    edit_s    in = (ESC 'n')      label='Option Shift .'
    down      in = (ESC 'd')      label='Option D'
    down_s    in = (ESC 'm')      label='Option Shift D'
    up        in = (ESC 'u')      label='Option U'
    up_s      in = (ESC 'U')      label='Option Shift U'
    fwd       in = (ESC 'f')      label='Option F'
    fwd_s     in = (ESC 'F')      label='Option Shift F'
    bkw       in = (ESC 'b')      label='Option B'
    bkw_s     in = (ESC 'B')      label='Option Shift B'
    undo      in = (ESC '5') label='f5  Option 5'
    stop      in = (ESC '6') label='f6  Option 6'
    undo_s    in = (ESC '%') label='    Option Shift 5'
    stop_s    in = (ESC '^') label='    Option Shift 6'

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (ESC '1') label='f1  Option 1'
    f2        in = (ESC '2') label='f2  Option 2'
    f3        in = (ESC '3') label='f3  Option 3'
    f4        in = (ESC '4') label='f4  Option 4'
    f5        in = (ESC '5') label='f5  Option 5'
    f6        in = (ESC '6') label='f6  Option 6'
    f7        in = (ESC 'g') label='f7  Option 7'
    f8        in = (ESC 'h') label='f8  Option 8'
    f9        in = (ESC '9') label='f9  Option 9'
    f10       in = (ESC '0') label=' 0  Option 0'
    f11       in = (ESC 'q') label=' q  Option Q'
    f12       in = (ESC 'w') label=' w  Option W'
    f13       in = (ESC 'e') label=' e  Option E'
    f14       in = (ESC 'r') label=' r  Option R'
    f15       in = (ESC 't') label=' t  Option T'
    f16       in = (ESC 'y') label=' y  Option Y'
    f1_s      in = (ESC '!') label='    Option Shift 1'
    f2_s      in = (ESC '@') label='    Option Shift 2'
    f3_s      in = (ESC 'i') label='    Option Shift 3'
    f4_s      in = (ESC '$') label='    Option Shift 4'
    f5_s      in = (ESC '%') label='    Option Shift 5'
    f6_s      in = (ESC '^') label='    Option Shift 6'
    f7_s      in = (ESC '&') label='    Option Shift 7'
    f8_s      in = (ESC '*') label='    Option Shift 8'
    f9_s      in = (ESC 'j') label='    Option Shift 9'
    f10_s     in = (ESC 'k') label='    Option Shift 0'
    f11_s     in = (ESC 'Q') label='    Option Shift Q'
    f12_s     in = (ESC 'W') label='    Option Shift W'
    f13_s     in = (ESC 'l') label='    Option Shift E'
    f14_s     in = (ESC 'R') label='    Option Shift R'
    f15_s     in = (ESC 'T') label='    Option Shift T'
    f16_s     in = (ESC 'Y') label='    Option Shift Y'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_alternate)
    error_end           out = (stop_alternate)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = 0E(16)
    ld_fine_end              out = 0F(16)
    ld_fine_horizontal       out = 71(16)
    ld_fine_vertical         out = 78(16)
    ld_fine_upper_left       out = 6C(16)
    ld_fine_upper_right      out = 6B(16)
    ld_fine_lower_left       out = 6D(16)
    ld_fine_lower_right      out = 6A(16)
    ld_fine_up_t             out = 77(16)
    ld_fine_down_t           out = 76(16)
    ld_fine_left_t           out = 74(16)
    ld_fine_right_t          out = 75(16)
    ld_fine_cross            out = 6E(16)

    ld_medium_begin          out = (0E(16) start_alternate)
    ld_medium_end            out = (0F(16) stop_alternate)
    ld_medium_horizontal     out = 71(16)
    ld_medium_vertical       out = 78(16)
    ld_medium_upper_left     out = 6C(16)
    ld_medium_upper_right    out = 6B(16)
    ld_medium_lower_left     out = 6D(16)
    ld_medium_lower_right    out = 6A(16)
    ld_medium_up_t           out = 77(16)
    ld_medium_down_t         out = 76(16)
    ld_medium_left_t         out = 74(16)
    ld_medium_right_t        out = 75(16)
    ld_medium_cross          out = 6E(16)

    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')

application_string name=('FSE_FUNCTION_1') out=('mark_lines')
application_string name=('FSE_FUNCTION_2') out=('mark_characters')
application_string name=('FSE_FUNCTION_3') out=('copy_text l=m p=b; unmark')
application_string name=('FSE_FUNCTION_4') out=('alis middle=current')
application_string name=('FSE_FUNCTION_5') out=('undo')
application_string name=('FSE_FUNCTION_6') out=('end')
application_string name=('FSE_FUNCTION_7') ..
 out=('locate_text t=$screen_input(''Enter search string'')')
application_string name=('FSE_FUNCTION_8') out=('setso mr=1')
application_string name=('FSE_FUNCTION_9') ..
 out=('insert_empty_lines p=b n=$split_size-4; position_cursor d=b n=2; '//..
'align_screen top=c; position_cursor r=$title_row+3')
application_string name=('FSE_FUNCTION_10') out=('align_screen offset=0')
application_string name=('FSE_FUNCTION_11') out=('break_text')
application_string name=('FSE_FUNCTION_12') out=('help')
application_string name=('FSE_FUNCTION_13') ..
 out=('t=$si(''Enter search string''); nt=$si(''Enter new string''); '//..
'if $mark_object_type = ''NULL''; replace_text t nt l=all; '//..
'else; replace_text t nt l=mark; ifend')
application_string name=('FSE_FUNCTION_14') out=('copy_text l=m p=b')
application_string name=('FSE_FUNCTION_15') out=('indent_text l=m offset=2')
application_string name=('FSE_FUNCTION_16') out=('format_paragraphs')

application_string name=('FSE_FUNCTION_1_LABEL') out=(' Mark ')
application_string name=('FSE_FUNCTION_2_LABEL') out=('ChrMrk')
application_string name=('FSE_FUNCTION_3_LABEL') out=('OneCpy')
application_string name=('FSE_FUNCTION_4_LABEL') out=('Middle')
application_string name=('FSE_FUNCTION_5_LABEL') out=(' Undo ')
application_string name=('FSE_FUNCTION_6_LABEL') out=(' End  ')
application_string name=('FSE_FUNCTION_7_LABEL') out=('Locate')
application_string name=('FSE_FUNCTION_8_LABEL') out=('1 Row ')
application_string name=('FSE_FUNCTION_9_LABEL') out=('InsEl ')
application_string name=('FSE_FUNCTION_10_LABEL') out=(' Left ')
application_string name=('FSE_FUNCTION_11_LABEL') out=('BrkTxt')
application_string name=('FSE_FUNCTION_12_LABEL') out=(' Help ')
application_string name=('FSE_FUNCTION_13_LABEL') out=('Replac')
application_string name=('FSE_FUNCTION_14_LABEL') out=(' Copy ')
application_string name=('FSE_FUNCTION_15_LABEL') out=('Indent')
application_string name=('FSE_FUNCTION_16_LABEL') out=('Format')

application_string name=('FSE_FUNCTION_SHIFT_1') out=('unmark')
application_string name=('FSE_FUNCTION_SHIFT_2') out=('mark_boxes')
application_string name=('FSE_FUNCTION_SHIFT_3') ..
 out= ('move_text l=m p=b; unmark')
application_string name=('FSE_FUNCTION_SHIFT_4') ..
 out=('position_cursor l=c c=$strlen($lt)+1')
application_string name=('FSE_FUNCTION_SHIFT_5') ..
 out=('esv$text=$screen_input(''Enter search string''); '//..
'if esv$text='''' then; esv$text=$text; ifend; '//..
'locate_text rs=true l=a v=true t=esv$text')
application_string name=('FSE_FUNCTION_SHIFT_6') out=('end no')
application_string name=('FSE_FUNCTION_SHIFT_7') out=('posc;posc rs=true')
application_string name=('FSE_FUNCTION_SHIFT_8') out=('setso mr=2')
application_string name=('FSE_FUNCTION_SHIFT_9') out=('delete_empty_lines')
application_string name=('FSE_FUNCTION_SHIFT_10') ..
 out=('esv$off=30; if $current_column<>1 then; '//..
'esv$off=$current_column-1; ifend; align_screen offset=esv$off; '//..
'position_cursor l=c c=$current_column+30')
application_string name=('FSE_FUNCTION_SHIFT_11') out=('join_text')
application_string name=('FSE_FUNCTION_SHIFT_12') ..
 out=('posc r=$title_row(1)+1; setso split=1')
application_string name=('FSE_FUNCTION_SHIFT_13') out=('delete_text l=mark')
application_string name=('FSE_FUNCTION_SHIFT_14') out=('exchange_screen_width')
application_string name=('FSE_FUNCTION_SHIFT_15') out=('indt l=m offset=-2')
application_string name=('FSE_FUNCTION_SHIFT_16') out=('center_lines')

application_string name=('FSE_FUNCTION_SHIFT_1_LABEL') out=('UnMark')
application_string name=('FSE_FUNCTION_SHIFT_2_LABEL') out=('BoxMrk')
application_string name=('FSE_FUNCTION_SHIFT_3_LABEL') out=(' Move ')
application_string name=('FSE_FUNCTION_SHIFT_4_LABEL') out=('EndLin')
application_string name=('FSE_FUNCTION_SHIFT_5_LABEL') out=('LocAll')
application_string name=('FSE_FUNCTION_SHIFT_6_LABEL') out=('End No')
application_string name=('FSE_FUNCTION_SHIFT_7_LABEL') out=('LocNxt')
application_string name=('FSE_FUNCTION_SHIFT_8_LABEL') out=('2 Rows')
application_string name=('FSE_FUNCTION_SHIFT_9_LABEL') out=('DelEl ')
application_string name=('FSE_FUNCTION_SHIFT_10_LABEL') out=('Right ')
application_string name=('FSE_FUNCTION_SHIFT_11_LABEL') out=(' Join ')
application_string name=('FSE_FUNCTION_SHIFT_12_LABEL') out=('UnSplt')
application_string name=('FSE_FUNCTION_SHIFT_13_LABEL') out=('DelMrk')
application_string name=('FSE_FUNCTION_SHIFT_14_LABEL') out=('80/132')
application_string name=('FSE_FUNCTION_SHIFT_15_LABEL') out=('Dedent')
application_string name=('FSE_FUNCTION_SHIFT_16_LABEL') out=('Center')

application_string name=('pe_fix_allerr_func') out=('key=11 shift=true')
application_string name=('pe_fix_assist_func') out=('key=11 shift=false')
application_string name=('pe_fix_format_func') out=('key=8 shift=false')
application_string name=('pe_fix_lookup_func') out=('key=8 shift=true')
application_string name=('pe_fix_nxterr_func') out=('key=10 shift=false')
application_string name=('pe_fix_nxtler_func') out=('key=10 shift=true')
application_string name=('pe_fix_run_func')    out=('key=9 shift=false')
application_string name=('pe_fix_rundbg_func') out=('key=9 shift=true')
application_string name=('pe_template_modify_format_func') ..
 out=('key=8 shift=true')
application_string name=('pe_template_modify_lookup_func') ..
 out=('key=8 shift=false')
application_string name=('pe_modify_create_format_func') ..
 out=('key=8 shift=true')
application_string name=('pe_modify_create_lookup_func') ..
 out=('key=8 shift=false')
application_string name=('pe_modify_create_run_func') ..
 out=('key=9 shift=false')
application_string name=('pe_modify_create_rundbg_func') ..
 out=('key=9 shift=true')
application_string name=('pe_view_end_func')    out=('key=8 shift=false')
application_string name=('pe_view_export_func') out=('key=8 shift=true')
application_string name=('pe_view_print_func')  out=('key=9  shift=false')

"   END OF TERMINAL DEFINITION FILE FOR Mac using Control Data Connect        "
*DECK DECK=CSM$OLD_MAC_CONNECT_11 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR MACINTOSH WITH CDC CONNECT                   "

"       MAC_CONNECT_11       VERSION 1.1                 OCTOBER 28, 1986     "

"   NOS/VE TERMINAL DEFINITION FILE FOR Macintosh using Control Data Connect  "
"   (basic VT100 plus function key definitions).  Connect should be run with  "
"   local echo on or echoplex for the insert/delete functions to work.        "
"   Important Terminal... and Compatiblity... settings in Connect are:        "
"     Repeat Ctrls           OFF                                              "
"     New Line               OFF                                              "
"     Auto Wraparound        ON                                               "
"     XON/XOFF Flow Control  ON                                               "
"   If Auto Wraparound is OFF, make the following change:                     "
"     char_past_right          type = stop_next                               "
"     char_past_last_position  type = stop_next                               "
"                                                                             "

"   VARIABLES                                                                 "
    prefix              = (esc 5B(16))
    clear_stay          = (prefix 32(16) 4A(16))
    clear_all_tabs      = (prefix 33(16) 67(16))
    set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))
    set_to_24x132       = (prefix 3F(16) 33(16) 68(16))
    start_alternate     = (prefix 31(16) 6D(16))
    start_blink         = (prefix 35(16) 6D(16))
    start_inverse       = (prefix 37(16) 6D(16))
    start_underline     = (prefix 34(16) 6D(16))
    stop_alternate      = (prefix 6D(16))
    stop_blink          = (prefix 6D(16))
    stop_inverse        = (prefix 6D(16))
    stop_underline      = (prefix 6D(16))

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'OLD_MAC_CONNECT_11'
    communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix)
    cursor_pos_second        out   = (3B(16))
    cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (prefix 48(16)) label='Option H'
    cursor_up                inout = (prefix 41(16)) label='Option I'
    cursor_down              inout = (prefix 42(16)) label='Option M'
    cursor_left              inout = (prefix 44(16)) label='Option J'
    cursor_right             inout = (prefix 43(16)) label='Option K'

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = stop_next
    move_past_left           type  = stop_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next
    char_past_left           type  = stop_next
    char_past_last_position  type  = scroll_next

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 0                  "for MAC"
    has_hidden               value = FALSE
    has_protect              value = FALSE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = TRUE

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80   out = (set_to_24x80)
    set_size       rows = 24 columns = 132  out = (set_to_24x132)

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode     out = (esc 3C(16) clear_all_tabs ..
         esc 28(16) 42(16) esc 29(16) 30(16) 0F(16) esc ..
         3D(16))

    set_line_mode       out = (esc 3C(16) clear_all_tabs ..
         esc 28(16) 42(16) esc 29(16) 30(16) 0F(16) esc ..
         3E(16))

"   TERMINAL CAPABILITIES                                                    "
    insert_char         inout = (prefix '@') label='Option Space'
    delete_char         inout = (prefix 'P') label='Option Backspace'
    delete_line_bol     inout = (prefix 'M') label='Option Shift Backspace'
    insert_line_bol     inout = (prefix 'L') label='Option Shift Space'
    erase_end_of_line   inout = (prefix 'K') label='Option C'
    erase_line_stay     inout = (prefix '2K')
    erase_page_stay     inout = (clear_stay) label='Option Shift C'
    backspace           in = (08(16))
    tab_forward         inout = (09(16))
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (esc 48(16))

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    output_begin        out = (prefix 34(16) 6C(16))
    bell_nak            out = (bel)

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = (CR)           label='Return'
    next_s    in = (ESC CR)       label='Shift Return'
    data      in = (ESC 27(16))   label='Option "'
    data_s    in = (ESC '"')      label='Option Shift "'
    back      in = (ESC ';')      label='Option ;'
    back_s    in = (ESC ':')      label='Option Shift ;'
    help      in = (ESC '/')      label='Option ?'
    help_s    in = (ESC '?')      label='Option Shift ?'
    edit      in = (ESC '.')      label='Option .'
    edit_s    in = (ESC 'n')      label='Option Shift .'
    down      in = (ESC 'd')      label='Option D'
    down_s    in = (ESC 'm')      label='Option Shift D'
    up        in = (ESC 'u')      label='Option U'
    up_s      in = (ESC 'U')      label='Option Shift U'
    fwd       in = (ESC 'f')      label='Option F'
    fwd_s     in = (ESC 'F')      label='Option Shift F'
    bkw       in = (ESC 'b')      label='Option B'
    bkw_s     in = (ESC 'B')      label='Option Shift B'
    undo      in = (ESC '5') label='f5  Option 5'
    stop      in = (ESC '6') label='f6  Option 6'
    undo_s    in = (ESC '%') label='    Option Shift 5'
    stop_s    in = (ESC '^') label='    Option Shift 6'

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (ESC '1') label='f1  Option 1'
    f2        in = (ESC '2') label='f2  Option 2'
    f3        in = (ESC '3') label='f3  Option 3'
    f4        in = (ESC '4') label='f4  Option 4'
    f5        in = (ESC '5') label='f5  Option 5'
    f6        in = (ESC '6') label='f6  Option 6'
    f7        in = (ESC 'g') label='f7  Option 7'
    f8        in = (ESC 'h') label='f8  Option 8'
    f9        in = (ESC '9') label='f9  Option 9'
    f10       in = (ESC '0') label=' 0  Option 0'
    f11       in = (ESC 'q') label=' q  Option Q'
    f12       in = (ESC 'w') label=' w  Option W'
    f13       in = (ESC 'e') label=' e  Option E'
    f14       in = (ESC 'r') label=' r  Option R'
    f15       in = (ESC 't') label=' t  Option T'
    f16       in = (ESC 'y') label=' y  Option Y'
    f1_s      in = (ESC '!') label='    Option Shift 1'
    f2_s      in = (ESC '@') label='    Option Shift 2'
    f3_s      in = (ESC 'i') label='    Option Shift 3'
    f4_s      in = (ESC '$') label='    Option Shift 4'
    f5_s      in = (ESC '%') label='    Option Shift 5'
    f6_s      in = (ESC '^') label='    Option Shift 6'
    f7_s      in = (ESC '&') label='    Option Shift 7'
    f8_s      in = (ESC '*') label='    Option Shift 8'
    f9_s      in = (ESC 'j') label='    Option Shift 9'
    f10_s     in = (ESC 'k') label='    Option Shift 0'
    f11_s     in = (ESC 'Q') label='    Option Shift Q'
    f12_s     in = (ESC 'W') label='    Option Shift W'
    f13_s     in = (ESC 'l') label='    Option Shift E'
    f14_s     in = (ESC 'R') label='    Option Shift R'
    f15_s     in = (ESC 'T') label='    Option Shift T'
    f16_s     in = (ESC 'Y') label='    Option Shift Y'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_alternate)
    error_end           out = (stop_alternate)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = 0E(16)
    ld_fine_end              out = 0F(16)
    ld_fine_horizontal       out = 71(16)
    ld_fine_vertical         out = 78(16)
    ld_fine_upper_left       out = 6C(16)
    ld_fine_upper_right      out = 6B(16)
    ld_fine_lower_left       out = 6D(16)
    ld_fine_lower_right      out = 6A(16)
    ld_fine_up_t             out = 77(16)
    ld_fine_down_t           out = 76(16)
    ld_fine_left_t           out = 74(16)
    ld_fine_right_t          out = 75(16)
    ld_fine_cross            out = 6E(16)

    ld_medium_begin          out = (0E(16) start_alternate)
    ld_medium_end            out = (0F(16) stop_alternate)
    ld_medium_horizontal     out = 71(16)
    ld_medium_vertical       out = 78(16)
    ld_medium_upper_left     out = 6C(16)
    ld_medium_upper_right    out = 6B(16)
    ld_medium_lower_left     out = 6D(16)
    ld_medium_lower_right    out = 6A(16)
    ld_medium_up_t           out = 77(16)
    ld_medium_down_t         out = 76(16)
    ld_medium_left_t         out = 74(16)
    ld_medium_right_t        out = 75(16)
    ld_medium_cross          out = 6E(16)

    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')

application_string name=('FSE_FUNCTION_1') out=('mark_lines')
application_string name=('FSE_FUNCTION_2') out=('mark_characters')
application_string name=('FSE_FUNCTION_3') out=('copy_text l=m p=b; unmark')
application_string name=('FSE_FUNCTION_4') out=('alis middle=current')
application_string name=('FSE_FUNCTION_5') out=('undo')
application_string name=('FSE_FUNCTION_6') out=('end')
application_string name=('FSE_FUNCTION_7') ..
 out=('locate_text t=$screen_input(''Enter search string'')')
application_string name=('FSE_FUNCTION_8') out=('setso mr=1')
application_string name=('FSE_FUNCTION_9') ..
 out=('insert_empty_lines p=b n=$split_size-4; position_cursor d=b n=2; '//..
'align_screen top=c; position_cursor r=$title_row+3')
application_string name=('FSE_FUNCTION_10') out=('align_screen offset=0')
application_string name=('FSE_FUNCTION_11') out=('break_text')
application_string name=('FSE_FUNCTION_12') out=('help')
application_string name=('FSE_FUNCTION_13') ..
 out=('t=$si(''Enter search string''); nt=$si(''Enter new string''); '//..
'if $mark_object_type = ''NULL''; replace_text t nt l=all; '//..
'else; replace_text t nt l=mark; ifend')
application_string name=('FSE_FUNCTION_14') out=('copy_text l=m p=b')
application_string name=('FSE_FUNCTION_15') out=('indent_text l=m offset=2')
application_string name=('FSE_FUNCTION_16') out=('format_paragraphs')

application_string name=('FSE_FUNCTION_1_LABEL') out=(' Mark ')
application_string name=('FSE_FUNCTION_2_LABEL') out=('ChrMrk')
application_string name=('FSE_FUNCTION_3_LABEL') out=('OneCpy')
application_string name=('FSE_FUNCTION_4_LABEL') out=('Middle')
application_string name=('FSE_FUNCTION_5_LABEL') out=(' Undo ')
application_string name=('FSE_FUNCTION_6_LABEL') out=(' End  ')
application_string name=('FSE_FUNCTION_7_LABEL') out=('Locate')
application_string name=('FSE_FUNCTION_8_LABEL') out=('1 Row ')
application_string name=('FSE_FUNCTION_9_LABEL') out=('InsEl ')
application_string name=('FSE_FUNCTION_10_LABEL') out=(' Left ')
application_string name=('FSE_FUNCTION_11_LABEL') out=('BrkTxt')
application_string name=('FSE_FUNCTION_12_LABEL') out=(' Help ')
application_string name=('FSE_FUNCTION_13_LABEL') out=('Replac')
application_string name=('FSE_FUNCTION_14_LABEL') out=(' Copy ')
application_string name=('FSE_FUNCTION_15_LABEL') out=('Indent')
application_string name=('FSE_FUNCTION_16_LABEL') out=('Format')

application_string name=('FSE_FUNCTION_SHIFT_1') out=('unmark')
application_string name=('FSE_FUNCTION_SHIFT_2') out=('mark_boxes')
application_string name=('FSE_FUNCTION_SHIFT_3') ..
 out= ('move_text l=m p=b; unmark')
application_string name=('FSE_FUNCTION_SHIFT_4') ..
 out=('position_cursor l=c c=$strlen($lt)+1')
application_string name=('FSE_FUNCTION_SHIFT_5') ..
 out=('esv$text=$screen_input(''Enter search string''); '//..
'if esv$text='''' then; esv$text=$text; ifend; '//..
'locate_text rs=true l=a v=true t=esv$text')
application_string name=('FSE_FUNCTION_SHIFT_6') out=('end no')
application_string name=('FSE_FUNCTION_SHIFT_7') out=('posc;posc rs=true')
application_string name=('FSE_FUNCTION_SHIFT_8') out=('setso mr=2')
application_string name=('FSE_FUNCTION_SHIFT_9') out=('delete_empty_lines')
application_string name=('FSE_FUNCTION_SHIFT_10') ..
 out=('esv$off=30; if $current_column<>1 then; '//..
'esv$off=$current_column-1; ifend; align_screen offset=esv$off; '//..
'position_cursor l=c c=$current_column+30')
application_string name=('FSE_FUNCTION_SHIFT_11') out=('join_text')
application_string name=('FSE_FUNCTION_SHIFT_12') ..
 out=('posc r=$title_row(1)+1; setso split=1')
application_string name=('FSE_FUNCTION_SHIFT_13') out=('delete_text l=mark')
application_string name=('FSE_FUNCTION_SHIFT_14') out=('exchange_screen_width')
application_string name=('FSE_FUNCTION_SHIFT_15') out=('indt l=m offset=-2')
application_string name=('FSE_FUNCTION_SHIFT_16') out=('center_lines')

application_string name=('FSE_FUNCTION_SHIFT_1_LABEL') out=('UnMark')
application_string name=('FSE_FUNCTION_SHIFT_2_LABEL') out=('BoxMrk')
application_string name=('FSE_FUNCTION_SHIFT_3_LABEL') out=(' Move ')
application_string name=('FSE_FUNCTION_SHIFT_4_LABEL') out=('EndLin')
application_string name=('FSE_FUNCTION_SHIFT_5_LABEL') out=('LocAll')
application_string name=('FSE_FUNCTION_SHIFT_6_LABEL') out=('End No')
application_string name=('FSE_FUNCTION_SHIFT_7_LABEL') out=('LocNxt')
application_string name=('FSE_FUNCTION_SHIFT_8_LABEL') out=('2 Rows')
application_string name=('FSE_FUNCTION_SHIFT_9_LABEL') out=('DelEl ')
application_string name=('FSE_FUNCTION_SHIFT_10_LABEL') out=('Right ')
application_string name=('FSE_FUNCTION_SHIFT_11_LABEL') out=(' Join ')
application_string name=('FSE_FUNCTION_SHIFT_12_LABEL') out=('UnSplt')
application_string name=('FSE_FUNCTION_SHIFT_13_LABEL') out=('DelMrk')
application_string name=('FSE_FUNCTION_SHIFT_14_LABEL') out=('80/132')
application_string name=('FSE_FUNCTION_SHIFT_15_LABEL') out=('Dedent')
application_string name=('FSE_FUNCTION_SHIFT_16_LABEL') out=('Center')

application_string name=('pe_fix_allerr_func') out=('key=11 shift=true')
application_string name=('pe_fix_assist_func') out=('key=11 shift=false')
application_string name=('pe_fix_format_func') out=('key=8 shift=false')
application_string name=('pe_fix_lookup_func') out=('key=8 shift=true')
application_string name=('pe_fix_nxterr_func') out=('key=10 shift=false')
application_string name=('pe_fix_nxtler_func') out=('key=10 shift=true')
application_string name=('pe_fix_run_func')    out=('key=9 shift=false')
application_string name=('pe_fix_rundbg_func') out=('key=9 shift=true')
application_string name=('pe_template_modify_format_func') ..
 out=('key=8 shift=true')
application_string name=('pe_template_modify_lookup_func') ..
 out=('key=8 shift=false')
application_string name=('pe_modify_create_format_func') ..
 out=('key=8 shift=true')
application_string name=('pe_modify_create_lookup_func') ..
 out=('key=8 shift=false')
application_string name=('pe_modify_create_run_func') ..
 out=('key=9 shift=false')
application_string name=('pe_modify_create_rundbg_func') ..
 out=('key=9 shift=true')
application_string name=('pe_view_end_func')    out=('key=8 shift=false')
application_string name=('pe_view_export_func') out=('key=8 shift=true')
application_string name=('pe_view_print_func')  out=('key=9  shift=false')

"   END OF TERMINAL DEFINITION FILE FOR Mac using Control Data Connect        "
*DECK DECK=CSM$OLD_PC_CONNECT_10 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT  Version 0.1 6/26/85 "

"   VARIABLES                                                                 "
    prefix              = (1B(16) 5B(16))                     "esc ["
    clear_stay          = (prefix 32(16) 4A(16))              "2J"
    clear_all_tabs      = (prefix 33(16) 67(16))              "3g"
    set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))       "?3l"
  " set_to_24x132       = (prefix 3F(l6) 33(16) 68(16)) "     "?3h"
    enable_auto_wrap    = (prefix 3F(16) 37(16) 68(16))       "?7h"
    disable_auto_wrap   = (prefix 3F(16) 37(16) 6C(16))       "?7l"
    designate_graphics  = (1B(16) 29(16) 30(16))              "esc )0"
    invoke_graphics     = (0E(16))
    invoke_text         = (0F(16))
    keypad_numeric      = (1B(16) 3E(16))                     "esc >"
    enable_protect      = (prefix 3D(16) 31(16) 68(16))       "=1h"
    disable_protect     = (prefix 3D(16) 31(16) 6C(16))       "=1l"
    enable_insertion    = (prefix 34(16) 68(16))              "4h"
    disable_insertion   = (prefix 34(16) 6C(16))              "4l"
    enable_autotab      = (prefix 3D(16) 33(16) 68(16))       "=3h"
    disable_autotab     = (prefix 3D(16) 33(16) 6C(16))       "=3l"

    start_alternate     = (prefix 31(16) 6D(16))              "1m"
    start_blink         = (prefix 35(16) 6D(16))              "5m"
    start_inverse       = (prefix 37(16) 6D(16))              "7m"
    start_underline     = (prefix 34(16) 6D(16))              "4m"
    stop_alternate      = (prefix 6D(16))                     "m"
    stop_blink          = (prefix 6D(16))                     "m"
    stop_inverse        = (prefix 6D(16))                     "m"
    stop_underline      = (prefix 6D(16))                     "m"

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'OLD_PC_CONNECT_10'
    communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix)
    cursor_pos_second        out   = (3B(16))
    cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (prefix 48(16))      label='Home'
    cursor_up                inout = (prefix 41(16))
    cursor_down              inout = (prefix 42(16))
    cursor_left              inout = (prefix 44(16))
    cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = stop_next
    move_past_left           type  = stop_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = stop_next
    char_past_left           type  = stop_next
    char_past_last_position  type  = scroll_next

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 0
    has_hidden               value = FALSE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = TRUE

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80   out = (set_to_24x80)

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode     out = ( clear_all_tabs  disable_auto_wrap ..
         designate_graphics  invoke_text  enable_protect ..
         enable_autotab )

    set_line_mode       out = ( clear_all_tabs  disable_autotab ..
         designate_graphics  invoke_text  keypad_numeric ..
         enable_auto_wrap  disable_protect  disable_insertion )


"   TERMINAL CAPABILITIES                                                     "

    backspace           in = (bs)
    delete_char         inout = (prefix 50(16))  label='Del'
    delete_line_stay    inout = (prefix 4D(16))  label='Alt-D'

    erase_end_of_line   inout = (prefix 4B(16))
    erase_line_stay     inout = (prefix 32(16) 4B(16))
    erase_page_stay     inout = (clear_stay)

    insert_line_stay    inout = (prefix 4C(16))         label='Alt-I'
    insert_mode_begin   inout = (enable_insertion)      label='Ins'
    insert_mode_end     inout = (disable_insertion)     label='End'

    tab_backward        inout = (prefix 'Z')
    tab_forward         inout = (09(16))
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (1B(16) 48(16))

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (1B(16) 'V')
    protect_end         out = (1B(16) 'W')
    output_begin        out = ()
    output_end          out = ()
    bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (1B(16) 4F(16) 71(16)) label='f1'
    f2        in = (1B(16) 4F(16) 72(16)) label='f2'
    f3        in = (1B(16) 4F(16) 73(16)) label='f3'
    f4        in = (1B(16) 4F(16) 74(16)) label='f4'
    f5        in = (1B(16) 4F(16) 75(16)) label='f5'
    f6        in = (1B(16) 4F(16) 76(16)) label='f6'
    f7        in = (1B(16) 4F(16) 77(16)) label='f7'
    f8        in = (1B(16) 4F(16) 78(16)) label='f8'
    f9        in = (1B(16) 4F(16) 79(16)) label='f9'
    f10       in = (1B(16) 4F(16) 7A(16)) label='10'
    f11       in = (1B(16) 4F(16) 7B(16)) label='c1'
    f12       in = (1B(16) 4F(16) 7C(16)) label='c2'
    f13       in = (1B(16) 4F(16) 7D(16)) label='c3'
    f14       in = (1B(16) 4F(16) 7E(16)) label='c4'
    f15       in = (1B(16) 4F(16) 5F(16)) label='c5'
    f16       in = (1B(16) 4F(16) 55(16)) label='c6'
    f1_s      in = (1B(16) 4F(16) 50(16)) label='  SF1'
    f2_s      in = (1B(16) 4F(16) 51(16)) label='  SF2'
    f3_s      in = (1B(16) 4F(16) 52(16)) label='  SF3'
    f4_s      in = (1B(16) 4F(16) 53(16)) label='  SF4'
    f5_s      in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    f6_s      in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    f7_s      in = (1B(16) 4F(16) 4D(16)) label='  SF7'
    f8_s      in = (1B(16) 4F(16) 6E(16)) label='  SF8'
    f9_s      in = (1B(16) 4F(16) 70(16)) label='  SF9'
    f10_s     in = (1B(16) 4F(16) 4F(16)) label='  SF10'
    f11_s     in = (1B(16) 4F(16) 61(16)) label='A1'
    f12_s     in = (1B(16) 4F(16) 62(16)) label='A2'
    f13_s     in = (1B(16) 4F(16) 63(16)) label='A3'
    f14_s     in = (1B(16) 4F(16) 64(16)) label='A4'
    f15_s     in = (1B(16) 4F(16) 65(16)) label='A5'
    f16_s     in = (1B(16) 4F(16) 56(16)) label='A6'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13  label='NEXT'
    back      in = (1B(16) 4F(16) 73(16)) label='f3'
    help      in = (1B(16) 4F(16) 74(16)) label='f4'
    undo      in = (1B(16) 4F(16) 75(16)) label='f5'
    stop      in = (1B(16) 4F(16) 76(16)) label='f6'
    undo_s    in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    stop_s    in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    down      in = ()
    down_s    in = ()
    up        in = ()
    up_s      in = ()

    fwd       in = (1B(16) 4F(16) 58(16)) label='FWD'
    fwd_s     in = (1B(16) 4F(16) 6F(16)) label='Shift-FWD'

    bkw       in = (1B(16) 4F(16) 57(16)) label='BKW'
    bkw_s     in = (1B(16) 4F(16) 66(16)) label='Shift-BKW'

    edit      in = ()
    edit_s    in = ()
    data      in = ()
    data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)
    protect_begin       out = ()
    protect_end         out = ()

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_inverse)
    error_end           out = (stop_inverse)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = invoke_graphics
    ld_fine_end              out = invoke_text
    ld_fine_horizontal       out = 71(16)
    ld_fine_vertical         out = 78(16)
    ld_fine_upper_left       out = 6C(16)
    ld_fine_upper_right      out = 6B(16)
    ld_fine_lower_left       out = 6D(16)
    ld_fine_lower_right      out = 6A(16)
    ld_fine_up_t             out = 77(16)
    ld_fine_down_t           out = 76(16)
    ld_fine_left_t           out = 74(16)
    ld_fine_right_t          out = 75(16)
    ld_fine_cross            out = 6E(16)
    ld_medium_begin          out = (invoke_graphics start_alternate)
    ld_medium_end            out = (invoke_text stop_alternate)
    ld_medium_horizontal     out = 71(16)
    ld_medium_vertical       out = 78(16)
    ld_medium_upper_left     out = 6C(16)
    ld_medium_upper_right    out = 6B(16)
    ld_medium_lower_left     out = 6D(16)
    ld_medium_lower_right    out = 6A(16)
    ld_medium_up_t           out = 77(16)
    ld_medium_down_t         out = 76(16)
    ld_medium_left_t         out = 74(16)
    ld_medium_right_t        out = 75(16)
    ld_medium_cross          out = 6E(16)
    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

application_string name=('FSE_FUNCTION_1') out=('mark_lines')
application_string name=('FSE_FUNCTION_1_LABEL') out=(' MARK ')

application_string name=('FSE_FUNCTION_SHIFT_1') out=('unmark')
application_string name=('FSE_FUNCTION_SHIFT_1_LABEL') out=(' Unmrk')


application_string name=('FSE_FUNCTION_2') out=('mark_characters')
application_string name=('FSE_FUNCTION_2_LABEL') out=(' Chrmk')

application_string name=('FSE_FUNCTION_SHIFT_2') out=('delete_text l=c b=s c=$cc..max')
application_string name=('FSE_FUNCTION_SHIFT_2_LABEL') out=(' Trunc')


application_string name=('FSE_FUNCTION_3') out=('copy_text l=m p=b')
application_string name=('FSE_FUNCTION_3_LABEL') out=(' COPY ')

application_string name=('FSE_FUNCTION_SHIFT_3') out=('move_text l=m p=b; unmark')
application_string name=('FSE_FUNCTION_SHIFT_3_LABEL') out=(' Move ')


application_string name=('FSE_FUNCTION_4') out=('break_text')
application_string name=('FSE_FUNCTION_4_LABEL') out=(' Break')

application_string name=('FSE_FUNCTION_SHIFT_4') out=('Join_text')
application_string name=('FSE_FUNCTION_SHIFT_4_LABEL') out=(' Join ')


application_string name=('FSE_FUNCTION_5') out=('undo')
application_string name=('FSE_FUNCTION_5_LABEL') out=(' UNDO ')

application_string name=('FSE_FUNCTION_SHIFT_5') out=('acts')
application_string name=('FSE_FUNCTION_SHIFT_5_LABEL') out=(' CLEAR')


application_string name=('FSE_FUNCTION_6') out=('end')
application_string name=('FSE_FUNCTION_6_LABEL') out=(' END  ')

application_string name=('FSE_FUNCTION_SHIFT_6') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_6_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_7') out=('locate_string t=$screen_input(''Enter search string'')')
application_string name=('FSE_FUNCTION_7_LABEL') out=('LOCATE')

application_string name=('FSE_FUNCTION_SHIFT_7') out=('locate_next')
application_string name=('FSE_FUNCTION_SHIFT_7_LABEL') out=('locnxt')


application_string name=('FSE_FUNCTION_8') out=('esv$text=$screen_input(''Enter search string''); if esv$text='''' then; locate_all; else; locate_all t=esv$text; ifend')
application_string name=('FSE_FUNCTION_8_LABEL') out=('Locall')

application_string name=('FSE_FUNCTION_SHIFT_8') out=('if $offset=0 then; alis o=53; else; alis o=0; ifend')
application_string name=('FSE_FUNCTION_SHIFT_8_LABEL') out=('Offset')


application_string name=('FSE_FUNCTION_9') out=('align_screen middle=current')
application_string name=('FSE_FUNCTION_9_LABEL') out=('middle')

application_string name=('FSE_FUNCTION_SHIFT_9') out=('format_paragraphs')
application_string name=('FSE_FUNCTION_SHIFT_9_LABEL') out=('format')


application_string name=('FSE_FUNCTION_10') out=('position_cursor l=c c=$strlen($lt)+1')
application_string name=('FSE_FUNCTION_10_LABEL') out=('endlin')

application_string name=('FSE_FUNCTION_SHIFT_10') out=('center_lines')
application_string name=('FSE_FUNCTION_SHIFT_10_LABEL') out=('Center')


application_string name=('FSE_FUNCTION_11') out=(' ')
application_string name=('FSE_FUNCTION_11_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_11') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_11_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_12') out=(' ')
application_string name=('FSE_FUNCTION_12_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_12') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_12_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_13') out=(' ')
application_string name=('FSE_FUNCTION_13_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_13') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_13_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_14') out=(' ')
application_string name=('FSE_FUNCTION_14_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_14') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_14_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_15') out=(' ')
application_string name=('FSE_FUNCTION_15_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_15') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_15_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_16') out=(' ')
application_string name=('FSE_FUNCTION_16_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_16') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_16_LABEL') out=(' ')


"   KEY REDEFINITIONS FOR THE FULL SCREEN EDITOR WHEN USED FROM THE PROGRAMMING ENVIRONMENT "

application_string name=('pe_fix_allerr_func') out=('key=12 shift=false')
application_string name=('pe_fix_assist_func') out=('key=11 shift=true')
application_string name=('pe_fix_format_func') out=('key=9 shift=true')
application_string name=('pe_fix_lookup_func') out=('key=11 shift=false')
application_string name=('pe_fix_nxterr_func') out=('key=10 shift=false')
application_string name=('pe_fix_nxtler_func') out=('key=10 shift=true')
application_string name=('pe_fix_run_func')    out=('key=13 shift=false')
application_string name=('pe_fix_rundbg_func') out=('key=13 shift=true')

application_string name=('pe_fixl_assist_func') out=('key=11 shift=true')
application_string name=('pe_fixl_format_func') out=('key=9 shift=true')
application_string name=('pe_fixl_lookup_func') out=('key=11 shift=false')
application_string name=('pe_fixl_nxterr_func') out=('key=10 shift=false')
application_string name=('pe_fixl_run_func')    out=('key=13 shift=false')
application_string name=('pe_fixl_rundbg_func') out=('key=13 shift=true')

application_string name=('pe_template_modify_format_func') out=('key=9 shift=true')
application_string name=('pe_template_modify_lookup_func') out=('key=11 shift=false')

application_string name=('pe_modify_create_format_func') out=('key=9 shift=true')
application_string name=('pe_modify_create_lookup_func') out=('key=11 shift=false')
application_string name=('pe_modify_create_run_func')    out=('key=13 shift=false')
application_string name=('pe_modify_create_rundbg_func') out=('key=13 shift=true')

application_string name=('pe_view_end_func')    out=('key=6 shift=false')
application_string name=('pe_view_export_func') out=('key=16 shift=true')
application_string name=('pe_view_print_func')  out=('key=16 shift=false')

"   END OF TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT              "
*DECK DECK=CSM$OLD_PC_CONNECT_11 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT                      "

" Automatic tabbing is available as a user or site option.  To enable it,     "
" change the automatic_tabbing firective from FALSE to TRUE, and look at the  "
" set_screen_mode and set_line_mode directives for comment-disabled references"
" to the variables enable_autotab and disable_autotab -- enable these         "
" references by blanking over the comment quotes.                             "

"       PC_CONNECT_11        VERSION 1.1                MARCH 24, 1986        "

"   VARIABLES                                                                 "
    prefix              = (1B(16) 5B(16))                     "esc ["
    clear_stay          = (prefix 32(16) 4A(16))              "2J"
    clear_all_tabs      = (prefix 33(16) 67(16))              "3g"
    set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))       "?3l"
  " set_to_24x132       = (prefix 3F(l6) 33(16) 68(16)) "     "?3h"
    enable_auto_wrap    = (prefix 3F(16) 37(16) 68(16))       "?7h"
    disable_auto_wrap   = (prefix 3F(16) 37(16) 6C(16))       "?7l"
    designate_graphics  = (1B(16) 29(16) 30(16))              "esc )0"
    invoke_graphics     = (0E(16))
    invoke_text         = (0F(16))
    enable_protect      = (prefix 3D(16) 31(16) 68(16))       "=1h"
    disable_protect     = (prefix 3D(16) 31(16) 6C(16))       "=1l"
    enable_insertion    = (prefix 34(16) 68(16))              "4h"
    disable_insertion   = (prefix 34(16) 6C(16))              "4l"
    enable_autotab      = (prefix 3D(16) 33(16) 68(16))       "=3h"
    disable_autotab     = (prefix 3D(16) 33(16) 6C(16))       "=3l"

    start_alternate     = (prefix 31(16) 6D(16))              "1m"
    start_blink         = (prefix 35(16) 6D(16))              "5m"
    start_inverse       = (prefix 37(16) 6D(16))              "7m"
    start_underline     = (prefix 34(16) 6D(16))              "4m"
    stop_alternate      = (prefix 6D(16))                     "m"
    stop_blink          = (prefix 6D(16))                     "m"
    stop_inverse        = (prefix 6D(16))                     "m"
    stop_underline      = (prefix 6D(16))                     "m"

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'OLD_PC_CONNECT_11'
    communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix)
    cursor_pos_second        out   = (3B(16))
    cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (prefix 48(16))      label='Home'
    cursor_up                inout = (prefix 41(16))
    cursor_down              inout = (prefix 42(16))
    cursor_left              inout = (prefix 44(16))
    cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = wrap_adjacent_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = stop_next
    char_past_left           type  = wrap_adjacent_next
    char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 0
    has_hidden               value = FALSE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
    automatic_tabbing        value = FALSE

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80   out = (set_to_24x80)

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode     out = ( clear_all_tabs  disable_auto_wrap ..
         "enable_autotab" designate_graphics  invoke_text  enable_protect )

    set_line_mode       out = ( prefix '0p' clear_all_tabs "disable_autotab" ..
         designate_graphics  invoke_text  ..
         enable_auto_wrap  disable_protect  disable_insertion )


"   TERMINAL CAPABILITIES                                                     "

    backspace           in = (bs)
    delete_char         inout = (prefix 50(16))  label='Del'
    delete_line_stay    inout = (prefix 4D(16))  label='Alt-D'

    erase_end_of_line   inout = (prefix 'K')
    erase_line_stay     inout = (prefix 32(16) 'K')
    erase_end_of_field  inout = (prefix 'N')
    erase_field_stay    inout = (prefix '2N')
    erase_page_stay     inout = (clear_stay)

    insert_line_stay    inout = (prefix 4C(16))         label='Alt-I'
    insert_mode_begin   inout = (enable_insertion)      label='Ins'
    insert_mode_end     inout = (disable_insertion)     label='End'

    tab_backward        inout = (prefix 'Z')
    tab_forward         inout = (09(16))
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (1B(16) 48(16))

    protect_all         out = (prefix '1p')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (1B(16) 'V')
    protect_end         out = (1B(16) 'W')
    output_begin        out = (disable_protect disable_insertion)
    output_end          out = (enable_protect)
    bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (1B(16) 4F(16) 71(16)) label='f1'
    f2        in = (1B(16) 4F(16) 72(16)) label='f2'
    f3        in = (1B(16) 4F(16) 73(16)) label='f3'
    f4        in = (1B(16) 4F(16) 74(16)) label='f4'
    f5        in = (1B(16) 4F(16) 75(16)) label='f5'
    f6        in = (1B(16) 4F(16) 76(16)) label='f6'
    f7        in = (1B(16) 4F(16) 77(16)) label='f7'
    f8        in = (1B(16) 4F(16) 78(16)) label='f8'
    f9        in = (1B(16) 4F(16) 79(16)) label='f9'
    f10       in = (1B(16) 4F(16) 7A(16)) label='10'
    f11       in = (1B(16) 4F(16) 7B(16)) label='C1'
    f12       in = (1B(16) 4F(16) 7C(16)) label='C2'
    f13       in = (1B(16) 4F(16) 7D(16)) label='C3'
    f14       in = (1B(16) 4F(16) 7E(16)) label='C4'
    f15       in = (1B(16) 4F(16) 5F(16)) label='C5'
    f16       in = (1B(16) 4F(16) 55(16)) label='C6'
    f1_s      in = (1B(16) 4F(16) 50(16)) label='  SF1'
    f2_s      in = (1B(16) 4F(16) 51(16)) label='  SF2'
    f3_s      in = (1B(16) 4F(16) 52(16)) label='  SF3'
    f4_s      in = (1B(16) 4F(16) 53(16)) label='  SF4'
    f5_s      in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    f6_s      in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    f7_s      in = (1B(16) 4F(16) 4D(16)) label='  SF7'
    f8_s      in = (1B(16) 4F(16) 6E(16)) label='  SF8'
    f9_s      in = (1B(16) 4F(16) 70(16)) label='  SF9'
    f10_s     in = (1B(16) 4F(16) 4F(16)) label='  SF10'
    f11_s     in = (1B(16) 4F(16) 61(16)) label='A1'
    f12_s     in = (1B(16) 4F(16) 62(16)) label='A2'
    f13_s     in = (1B(16) 4F(16) 63(16)) label='A3'
    f14_s     in = (1B(16) 4F(16) 64(16)) label='A4'
    f15_s     in = (1B(16) 4F(16) 65(16)) label='A5'
    f16_s     in = (1B(16) 4F(16) 56(16)) label='A6'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13  label='NEXT'
    back      in = (1B(16) 4F(16) 73(16)) label='f3'
    help      in = (1B(16) 4F(16) 74(16)) label='f4'
    undo      in = (1B(16) 4F(16) 75(16)) label='f5'
    stop      in = (1B(16) 4F(16) 76(16)) label='f6'
    undo_s    in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    stop_s    in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    down      in = ()
    down_s    in = ()
    up        in = ()
    up_s      in = ()

    fwd       in = (1B(16) 4F(16) 58(16)) label='FWD'
    fwd_s     in = (1B(16) 4F(16) 6F(16)) label='Shift-FWD'

    bkw       in = (1B(16) 4F(16) 57(16)) label='BKW'
    bkw_s     in = (1B(16) 4F(16) 66(16)) label='Shift-BKW'

    edit      in = ()
    edit_s    in = ()
    data      in = ()
    data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)
    protect_begin       out = ()
    protect_end         out = ()

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_inverse)
    error_end           out = (stop_inverse)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = invoke_graphics
    ld_fine_end              out = invoke_text
    ld_fine_horizontal       out = 71(16)
    ld_fine_vertical         out = 78(16)
    ld_fine_upper_left       out = 6C(16)
    ld_fine_upper_right      out = 6B(16)
    ld_fine_lower_left       out = 6D(16)
    ld_fine_lower_right      out = 6A(16)
    ld_fine_up_t             out = 77(16)
    ld_fine_down_t           out = 76(16)
    ld_fine_left_t           out = 74(16)
    ld_fine_right_t          out = 75(16)
    ld_fine_cross            out = 6E(16)
    ld_medium_begin          out = (invoke_graphics start_alternate)
    ld_medium_end            out = (invoke_text stop_alternate)
    ld_medium_horizontal     out = 71(16)
    ld_medium_vertical       out = 78(16)
    ld_medium_upper_left     out = 6C(16)
    ld_medium_upper_right    out = 6B(16)
    ld_medium_lower_left     out = 6D(16)
    ld_medium_lower_right    out = 6A(16)
    ld_medium_up_t           out = 77(16)
    ld_medium_down_t         out = 76(16)
    ld_medium_left_t         out = 74(16)
    ld_medium_right_t        out = 75(16)
    ld_medium_cross          out = 6E(16)
    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

application_string name=('FSE_FUNCTION_1') out=('mark_lines')
application_string name=('FSE_FUNCTION_1_LABEL') out=(' MARK ')

application_string name=('FSE_FUNCTION_SHIFT_1') out=('unmark')
application_string name=('FSE_FUNCTION_SHIFT_1_LABEL') out=(' Unmrk')


application_string name=('FSE_FUNCTION_2') out=('mark_characters')
application_string name=('FSE_FUNCTION_2_LABEL') out=(' Chrmk')

application_string name=('FSE_FUNCTION_SHIFT_2') ..
                   out=('delete_text l=c b=s c=$cc..max')
application_string name=('FSE_FUNCTION_SHIFT_2_LABEL') out=(' Trunc')


application_string name=('FSE_FUNCTION_3') out=('copy_text l=m p=b')
application_string name=('FSE_FUNCTION_3_LABEL') out=(' COPY ')

application_string name=('FSE_FUNCTION_SHIFT_3') ..
                    out=('move_text l=m p=b; unmark')
application_string name=('FSE_FUNCTION_SHIFT_3_LABEL') out=(' Move ')


application_string name=('FSE_FUNCTION_4') out=('break_text')
application_string name=('FSE_FUNCTION_4_LABEL') out=(' Break')

application_string name=('FSE_FUNCTION_SHIFT_4') out=('Join_text')
application_string name=('FSE_FUNCTION_SHIFT_4_LABEL') out=(' Join ')


application_string name=('FSE_FUNCTION_5') out=('undo')
application_string name=('FSE_FUNCTION_5_LABEL') out=(' UNDO ')

application_string name=('FSE_FUNCTION_SHIFT_5') out=('acts')
application_string name=('FSE_FUNCTION_SHIFT_5_LABEL') out=(' CLEAR')


application_string name=('FSE_FUNCTION_6') out=('end')
application_string name=('FSE_FUNCTION_6_LABEL') out=(' END  ')

application_string name=('FSE_FUNCTION_SHIFT_6') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_6_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_7') ..
            out=('locate_string t=$screen_input(''Enter search string'')')
application_string name=('FSE_FUNCTION_7_LABEL') out=('LOCATE')

application_string name=('FSE_FUNCTION_SHIFT_7') out=('locate_next')
application_string name=('FSE_FUNCTION_SHIFT_7_LABEL') out=('locnxt')


application_string name=('FSE_FUNCTION_8') ..
    out=('esv$text=$screen_input(''Enter search string'');' ..
    'if esv$text='''' then; locate_all; else; locate_all t=esv$text; ifend')

application_string name=('FSE_FUNCTION_8_LABEL') out=('Locall')

application_string name=('FSE_FUNCTION_SHIFT_8') ..
                   out=('if $offset=0 then; alis o=53; else; alis o=0; ifend')
application_string name=('FSE_FUNCTION_SHIFT_8_LABEL') out=('Offset')


application_string name=('FSE_FUNCTION_9') out=('align_screen middle=current')
application_string name=('FSE_FUNCTION_9_LABEL') out=('middle')

application_string name=('FSE_FUNCTION_SHIFT_9') out=('format_paragraphs')
application_string name=('FSE_FUNCTION_SHIFT_9_LABEL') out=('format')


application_string name=('FSE_FUNCTION_10') ..
                   out=('position_cursor l=c c=$strlen($lt)+1')
application_string name=('FSE_FUNCTION_10_LABEL') out=('endlin')

application_string name=('FSE_FUNCTION_SHIFT_10') out=('center_lines')
application_string name=('FSE_FUNCTION_SHIFT_10_LABEL') out=('Center')


application_string name=('FSE_FUNCTION_11') out=(' ')
application_string name=('FSE_FUNCTION_11_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_11') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_11_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_12') out=(' ')
application_string name=('FSE_FUNCTION_12_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_12') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_12_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_13') out=(' ')
application_string name=('FSE_FUNCTION_13_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_13') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_13_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_14') out=(' ')
application_string name=('FSE_FUNCTION_14_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_14') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_14_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_15') out=(' ')
application_string name=('FSE_FUNCTION_15_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_15') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_15_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_16') out=(' ')
application_string name=('FSE_FUNCTION_16_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_16') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_16_LABEL') out=(' ')


"   KEY REDEFINITIONS FOR THE FULL SCREEN EDITOR WHEN USED FROM   "
"   THE PROGRAMMING ENVIRONMENT "

application_string name=('pe_fix_allerr_func') out=('key=12 shift=false')
application_string name=('pe_fix_assist_func') out=('key=11 shift=true')
application_string name=('pe_fix_format_func') out=('key=9 shift=true')
application_string name=('pe_fix_lookup_func') out=('key=11 shift=false')
application_string name=('pe_fix_nxterr_func') out=('key=10 shift=false')
application_string name=('pe_fix_nxtler_func') out=('key=10 shift=true')
application_string name=('pe_fix_run_func')    out=('key=13 shift=false')
application_string name=('pe_fix_rundbg_func') out=('key=13 shift=true')

application_string name=('pe_fixl_assist_func') out=('key=11 shift=true')
application_string name=('pe_fixl_format_func') out=('key=9 shift=true')
application_string name=('pe_fixl_lookup_func') out=('key=11 shift=false')
application_string name=('pe_fixl_nxterr_func') out=('key=10 shift=false')
application_string name=('pe_fixl_run_func')    out=('key=13 shift=false')
application_string name=('pe_fixl_rundbg_func') out=('key=13 shift=true')

application_string name=('pe_template_modify_format_func') ..
                    out=('key=9 shift=true')
application_string name=('pe_template_modify_lookup_func') ..
                    out=('key=11 shift=false')

application_string name=('pe_modify_create_format_func') ..
                    out=('key=9 shift=true')
application_string name=('pe_modify_create_lookup_func') ..
                    out=('key=11 shift=false')
application_string name=('pe_modify_create_run_func') ..
                    out=('key=13 shift=false')
application_string name=('pe_modify_create_rundbg_func') ..
                    out=('key=13 shift=true')

application_string name=('pe_view_end_func')    out=('key=6 shift=false')
application_string name=('pe_view_export_func') out=('key=16 shift=true')
application_string name=('pe_view_print_func')  out=('key=16 shift=false')

"   END OF TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT              "
*DECK DECK=CSM$OLD_PC_CONNECT_12 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT                      "

"       PC_CONNECT_12        VERSION 1.2                NOVEMBER 10, 1986     "

"     This terminal definition is provided by CDC with the autotab option     "
" enabled.  Autotabbing is the behavior of jumping the cursor to the next     "
" unprotected field when text has been entered completely filling the         "
" previous unprotected field, or when a left/right cursor motion is           "
" attempted into a protected location.  Enabling autotab will provide a       "
" convenience for most users, but inability to horizontally position thru     "
" protected areas can interfere with some usage of the Screen Design          "
" Facility if a form is built with a large number of fields.  The SDF user    "
" can usually work around this situation by moving the cursor to the          "
" desired column on an unprotected row, then moving the cursor vertically     "
" into the final position.  In extreme cases, the SDF user may need to        "
" contruct an alternate terminal definition that disables autotab.  To        "
" disable autotab, look for comments embedded within this definition,         "
" containing the string 'autotab', and reverse the position of double-quote   "
" marks to disable the default code and enable the alternate code.            "

"   VARIABLES                                                                 "
    prefix              = (1B(16) 5B(16))                     "esc ["
    clear_stay          = (prefix 32(16) 4A(16))              "2J"
    clear_all_tabs      = (prefix 33(16) 67(16))              "3g"
    set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))       "?3l"
  " set_to_24x132       = (prefix 3F(l6) 33(16) 68(16)) "     "?3h"
    enable_auto_wrap    = (prefix 3F(16) 37(16) 68(16))       "?7h"
    disable_auto_wrap   = (prefix 3F(16) 37(16) 6C(16))       "?7l"
    designate_graphics  = (1B(16) 29(16) 30(16))              "esc )0"
    invoke_graphics     = (0E(16))
    invoke_text         = (0F(16))
    enable_protect      = (prefix 3D(16) 31(16) 68(16))       "=1h"
    disable_protect     = (prefix 3D(16) 31(16) 6C(16))       "=1l"
    enable_insertion    = (prefix 34(16) 68(16))              "4h"
    disable_insertion   = (prefix 34(16) 6C(16))              "4l"
    enable_autotab      = (prefix 3D(16) 33(16) 68(16))       "=3h"
    disable_autotab     = (prefix 3D(16) 33(16) 6C(16))       "=3l"

    start_alternate     = (prefix 31(16) 6D(16))              "1m"
    start_blink         = (prefix 35(16) 6D(16))              "5m"
    start_inverse       = (prefix 37(16) 6D(16))              "7m"
    start_underline     = (prefix 34(16) 6D(16))              "4m"
    stop_alternate      = (prefix 6D(16))                     "m"
    stop_blink          = (prefix 6D(16))                     "m"
    stop_inverse        = (prefix 6D(16))                     "m"
    stop_underline      = (prefix 6D(16))                     "m"

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'OLD_PC_CONNECT_12'  " for autotab"
"   model_name          value = 'OLD_PC_CONNECT_12_SDF'  for no autotab "
    communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix)
    cursor_pos_second        out   = (3B(16))
    cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (prefix 48(16))      label='Home'
    cursor_up                inout = (prefix 41(16))
    cursor_down              inout = (prefix 42(16))
    cursor_left              inout = (prefix 44(16))
    cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next  " for autotab "
"   move_past_right          type  = stop_next             for no autotab "
    move_past_left           type  = wrap_adjacent_next  " for autotab "
"   move_past_left           type  = stop_next             for no autotab "
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next  " for autotab "
"   char_past_right          type  = stop_next             for no autotab "
    char_past_left           type  = wrap_adjacent_next  " for autotab "
"   char_past_left           type  = stop_next             for no autotab "
    char_past_last_position  type  = wrap_adjacent_next  " for autotab "
"   char_past_last_position  type  = stop_next             for no autotab "

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 0
    has_hidden               value = FALSE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
    automatic_tabbing        value = TRUE   " for autotab "
"   automatic_tabbing        value = FALSE    for no autotab "

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80   out = (set_to_24x80)

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode out=(clear_all_tabs enable_auto_wrap ..      "for autotab "
     enable_autotab designate_graphics invoke_text enable_protect)  " autotab "
"   set_screen_mode out=(clear_all_tabs enable_auto_wrap ..    for no autotab "
"    disable_autotab designate_graphics invoke_text enable_protect) no autotab"

    set_line_mode       out = ( prefix '0p' clear_all_tabs  disable_autotab ..
         designate_graphics  invoke_text  ..
         enable_auto_wrap  disable_protect  disable_insertion )


"   TERMINAL CAPABILITIES                                                     "

    backspace           in = (bs)
    delete_char         inout = (prefix 50(16))  label='Del'
    delete_line_stay    inout = (prefix 4D(16))  label='Alt-D'

    erase_end_of_line   inout = (prefix 'K')
    erase_line_stay     inout = (prefix 32(16) 'K')
    erase_end_of_field  inout = (prefix 'N')
    erase_field_stay    inout = (prefix '2N')
    erase_page_stay     inout = (clear_stay)

    insert_line_stay    inout = (prefix 4C(16))         label='Alt-I'
    insert_mode_begin   inout = (enable_insertion)      label='Ins'
    insert_mode_end     inout = (disable_insertion)     label='End'

    tab_backward        inout = (prefix 'Z')
    tab_forward         inout = (09(16))
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (1B(16) 48(16))

    protect_all         out = (prefix '1p')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (1B(16) 'V')
    protect_end         out = (1B(16) 'W')
    output_begin        out = (disable_protect disable_insertion)
    output_end          out = (enable_protect)
    bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (1B(16) 4F(16) 71(16)) label='f1'
    f2        in = (1B(16) 4F(16) 72(16)) label='f2'
    f3        in = (1B(16) 4F(16) 73(16)) label='f3'
    f4        in = (1B(16) 4F(16) 74(16)) label='f4'
    f5        in = (1B(16) 4F(16) 75(16)) label='f5'
    f6        in = (1B(16) 4F(16) 76(16)) label='f6'
    f7        in = (1B(16) 4F(16) 77(16)) label='f7'
    f8        in = (1B(16) 4F(16) 78(16)) label='f8'
    f9        in = (1B(16) 4F(16) 79(16)) label='f9'
    f10       in = (1B(16) 4F(16) 7A(16)) label='10'
    f11       in = (1B(16) 4F(16) 7B(16)) label='C1'
    f12       in = (1B(16) 4F(16) 7C(16)) label='C2'
    f13       in = (1B(16) 4F(16) 7D(16)) label='C3'
    f14       in = (1B(16) 4F(16) 7E(16)) label='C4'
    f15       in = (1B(16) 4F(16) 5F(16)) label='C5'
    f16       in = (1B(16) 4F(16) 55(16)) label='C6'
    f1_s      in = (1B(16) 4F(16) 50(16)) label='  SF1'
    f2_s      in = (1B(16) 4F(16) 51(16)) label='  SF2'
    f3_s      in = (1B(16) 4F(16) 52(16)) label='  SF3'
    f4_s      in = (1B(16) 4F(16) 53(16)) label='  SF4'
    f5_s      in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    f6_s      in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    f7_s      in = (1B(16) 4F(16) 4D(16)) label='  SF7'
    f8_s      in = (1B(16) 4F(16) 6E(16)) label='  SF8'
    f9_s      in = (1B(16) 4F(16) 70(16)) label='  SF9'
    f10_s     in = (1B(16) 4F(16) 4F(16)) label='  SF10'
    f11_s     in = (1B(16) 4F(16) 61(16)) label='A1'
    f12_s     in = (1B(16) 4F(16) 62(16)) label='A2'
    f13_s     in = (1B(16) 4F(16) 63(16)) label='A3'
    f14_s     in = (1B(16) 4F(16) 64(16)) label='A4'
    f15_s     in = (1B(16) 4F(16) 65(16)) label='A5'
    f16_s     in = (1B(16) 4F(16) 56(16)) label='A6'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13  label='NEXT'
    back      in = (1B(16) 4F(16) 73(16)) label='f3'
    help      in = (1B(16) 4F(16) 74(16)) label='f4'
    undo      in = (1B(16) 4F(16) 75(16)) label='f5'
    stop      in = (1B(16) 4F(16) 76(16)) label='f6'
    undo_s    in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    stop_s    in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    down      in = ()
    down_s    in = ()
    up        in = ()
    up_s      in = ()

    fwd       in = (1B(16) 4F(16) 58(16)) label='FWD'
    fwd_s     in = (1B(16) 4F(16) 6F(16)) label='Shift-FWD'

    bkw       in = (1B(16) 4F(16) 57(16)) label='BKW'
    bkw_s     in = (1B(16) 4F(16) 66(16)) label='Shift-BKW'

    edit      in = ()
    edit_s    in = ()
    data      in = ()
    data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_inverse)
    error_end           out = (stop_inverse)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = invoke_graphics
    ld_fine_end              out = invoke_text
    ld_fine_horizontal       out = 71(16)
    ld_fine_vertical         out = 78(16)
    ld_fine_upper_left       out = 6C(16)
    ld_fine_upper_right      out = 6B(16)
    ld_fine_lower_left       out = 6D(16)
    ld_fine_lower_right      out = 6A(16)
    ld_fine_up_t             out = 77(16)
    ld_fine_down_t           out = 76(16)
    ld_fine_left_t           out = 74(16)
    ld_fine_right_t          out = 75(16)
    ld_fine_cross            out = 6E(16)
    ld_medium_begin          out = (invoke_graphics start_alternate)
    ld_medium_end            out = (invoke_text stop_alternate)
    ld_medium_horizontal     out = 71(16)
    ld_medium_vertical       out = 78(16)
    ld_medium_upper_left     out = 6C(16)
    ld_medium_upper_right    out = 6B(16)
    ld_medium_lower_left     out = 6D(16)
    ld_medium_lower_right    out = 6A(16)
    ld_medium_up_t           out = 77(16)
    ld_medium_down_t         out = 76(16)
    ld_medium_left_t         out = 74(16)
    ld_medium_right_t        out = 75(16)
    ld_medium_cross          out = 6E(16)
    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

application_string name=('FSE_FUNCTION_1') out=('mark_lines')
application_string name=('FSE_FUNCTION_1_LABEL') out=(' MARK ')

application_string name=('FSE_FUNCTION_SHIFT_1') out=('unmark')
application_string name=('FSE_FUNCTION_SHIFT_1_LABEL') out=(' Unmrk')


application_string name=('FSE_FUNCTION_2') out=('mark_characters')
application_string name=('FSE_FUNCTION_2_LABEL') out=(' Chrmk')

application_string name=('FSE_FUNCTION_SHIFT_2') ..
                   out=('delete_text l=c b=s c=$cc..max')
application_string name=('FSE_FUNCTION_SHIFT_2_LABEL') out=(' Trunc')


application_string name=('FSE_FUNCTION_3') out=('copy_text l=m p=b')
application_string name=('FSE_FUNCTION_3_LABEL') out=(' COPY ')

application_string name=('FSE_FUNCTION_SHIFT_3') ..
                    out=('move_text l=m p=b; unmark')
application_string name=('FSE_FUNCTION_SHIFT_3_LABEL') out=(' Move ')


application_string name=('FSE_FUNCTION_4') out=('break_text')
application_string name=('FSE_FUNCTION_4_LABEL') out=(' Break')

application_string name=('FSE_FUNCTION_SHIFT_4') out=('Join_text')
application_string name=('FSE_FUNCTION_SHIFT_4_LABEL') out=(' Join ')


application_string name=('FSE_FUNCTION_5') out=('undo')
application_string name=('FSE_FUNCTION_5_LABEL') out=(' UNDO ')

application_string name=('FSE_FUNCTION_SHIFT_5') out=('acts')
application_string name=('FSE_FUNCTION_SHIFT_5_LABEL') out=(' CLEAR')


application_string name=('FSE_FUNCTION_6') out=('end')
application_string name=('FSE_FUNCTION_6_LABEL') out=(' END  ')

application_string name=('FSE_FUNCTION_SHIFT_6') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_6_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_7') ..
            out=('locate_string t=$screen_input(''Enter search string'')')
application_string name=('FSE_FUNCTION_7_LABEL') out=('LOCATE')

application_string name=('FSE_FUNCTION_SHIFT_7') out=('locate_next')
application_string name=('FSE_FUNCTION_SHIFT_7_LABEL') out=('locnxt')


application_string name=('FSE_FUNCTION_8') ..
    out=('esv$text=$screen_input(''Enter search string'');' ..
    'if esv$text='''' then; locate_all; else; locate_all t=esv$text; ifend')

application_string name=('FSE_FUNCTION_8_LABEL') out=('Locall')

application_string name=('FSE_FUNCTION_SHIFT_8') ..
                   out=('if $offset=0 then; alis o=53; else; alis o=0; ifend')
application_string name=('FSE_FUNCTION_SHIFT_8_LABEL') out=('Offset')


application_string name=('FSE_FUNCTION_9') out=('align_screen middle=current')
application_string name=('FSE_FUNCTION_9_LABEL') out=('middle')

application_string name=('FSE_FUNCTION_SHIFT_9') out=('format_paragraphs')
application_string name=('FSE_FUNCTION_SHIFT_9_LABEL') out=('format')


application_string name=('FSE_FUNCTION_10') ..
                   out=('position_cursor l=c c=$strlen($lt)+1')
application_string name=('FSE_FUNCTION_10_LABEL') out=('endlin')

application_string name=('FSE_FUNCTION_SHIFT_10') out=('center_lines')
application_string name=('FSE_FUNCTION_SHIFT_10_LABEL') out=('Center')


application_string name=('FSE_FUNCTION_11') out=(' ')
application_string name=('FSE_FUNCTION_11_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_11') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_11_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_12') out=(' ')
application_string name=('FSE_FUNCTION_12_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_12') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_12_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_13') out=(' ')
application_string name=('FSE_FUNCTION_13_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_13') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_13_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_14') out=(' ')
application_string name=('FSE_FUNCTION_14_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_14') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_14_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_15') out=(' ')
application_string name=('FSE_FUNCTION_15_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_15') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_15_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_16') out=(' ')
application_string name=('FSE_FUNCTION_16_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_16') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_16_LABEL') out=(' ')


"   KEY REDEFINITIONS FOR THE FULL SCREEN EDITOR WHEN USED FROM   "
"   THE PROGRAMMING ENVIRONMENT "

application_string name=('pe_fix_allerr_func') out=('key=12 shift=false')
application_string name=('pe_fix_assist_func') out=('key=11 shift=true')
application_string name=('pe_fix_format_func') out=('key=9 shift=true')
application_string name=('pe_fix_lookup_func') out=('key=11 shift=false')
application_string name=('pe_fix_nxterr_func') out=('key=10 shift=false')
application_string name=('pe_fix_nxtler_func') out=('key=10 shift=true')
application_string name=('pe_fix_run_func')    out=('key=13 shift=false')
application_string name=('pe_fix_rundbg_func') out=('key=13 shift=true')

application_string name=('pe_fixl_assist_func') out=('key=11 shift=true')
application_string name=('pe_fixl_format_func') out=('key=9 shift=true')
application_string name=('pe_fixl_lookup_func') out=('key=11 shift=false')
application_string name=('pe_fixl_nxterr_func') out=('key=10 shift=false')
application_string name=('pe_fixl_run_func')    out=('key=13 shift=false')
application_string name=('pe_fixl_rundbg_func') out=('key=13 shift=true')

application_string name=('pe_template_modify_format_func') ..
                    out=('key=9 shift=true')
application_string name=('pe_template_modify_lookup_func') ..
                    out=('key=11 shift=false')

application_string name=('pe_modify_create_format_func') ..
                    out=('key=9 shift=true')
application_string name=('pe_modify_create_lookup_func') ..
                    out=('key=11 shift=false')
application_string name=('pe_modify_create_run_func') ..
                    out=('key=13 shift=false')
application_string name=('pe_modify_create_rundbg_func') ..
                    out=('key=13 shift=true')

application_string name=('pe_view_end_func')    out=('key=6 shift=false')
application_string name=('pe_view_export_func') out=('key=16 shift=true')
application_string name=('pe_view_print_func')  out=('key=16 shift=false')

"   END OF TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT              "

*DECK DECK=CSM$OLD_VT100 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR DIGITAL VT100 TERMINAL                       "

"   VARIABLES                                                                 "
prefix              = (1B(16) 5B(16))
clear_home          = (prefix 32(16) 4A(16))
clear_all_tabs      = (prefix '3g')
set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))
set_to_24x132       = (prefix 3F(16) 33(16) 68(16))
start_alternate     = (prefix 31(16) 6D(16))
start_inverse       = (prefix '7' 6D(16))
start_underline     = (prefix 34(16) 6D(16))
normal_attributes   = (prefix 'm')
stop_alternate      = normal_attributes
stop_inverse        = normal_attributes
stop_underline      = normal_attributes

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'OLD_VT100'
communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (3B(16))
cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 48(16))
cursor_up                inout = (prefix 41(16))
cursor_down              inout = (prefix 42(16))
cursor_left              inout = (prefix 44(16))
cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 1
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80   out = (set_to_24x80)
set_size       rows = 24 columns = 132  out = (set_to_24x132)

"   SCREEN AND LINE MODE TRANSITION                                           "
set_screen_mode     out = (1B(16) 3C(16) clear_all_tabs ..
     1B(16) 28(16) 42(16) 1B(16) 29(16) 30(16) 0F(16) 1B(16) ..
     3D(16) prefix '?7;1l' )

set_line_mode       out = (1B(16) 3C(16) clear_all_tabs ..
     1B(16) 28(16) 42(16) 1B(16) 29(16) 30(16) 0F(16) 1B(16) ..
     3E(16) prefix '?7;1h')

"   TERMINAL CAPABILITIES                                                     "
delete_char         in    = (prefix 50(16))
delete_line_bol     in    = (prefix 4D(16))
erase_end_of_line   inout = (prefix 4B(16))
erase_line_stay     inout = (prefix 32(16) 4B(16))
erase_page_home     inout = (clear_home)
insert_line_bol     in    = (prefix 4C(16))
insert_mode_begin   in    = (prefix 34(16) 68(16))
insert_mode_end     in    = (prefix 34(16) 6C(16))
tab_forward         inout = (09(16))
tab_clear_all       inout = (clear_all_tabs)
tab_set             inout = (1B(16) 48(16))

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
backspace           in = bs

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (1B(16) 4F(16) 71(16)) label='k1'
f2        in = (1B(16) 4F(16) 72(16)) label='k2'
f3        in = (1B(16) 4F(16) 73(16)) label='k3'
f4        in = (1B(16) 4F(16) 74(16)) label='k4'
f5        in = (1B(16) 4F(16) 75(16)) label='k5'
f6        in = (1B(16) 4F(16) 76(16)) label='k6'
f7        in = (1B(16) 4F(16) 77(16)) label='k7'
f8        in = (1B(16) 4F(16) 78(16)) label='k8'
f9        in = (1B(16) 4F(16) 79(16)) label='k9'
f10       in = ()
f11       in = ()
f12       in = ()
f13       in = ()
f14       in = ()
f15       in = ()
f16       in = ()
f1_s      in = (1B(16) 4F(16) 50(16)) label='p1'
f2_s      in = (1B(16) 4F(16) 51(16)) label='p2'
f3_s      in = (1B(16) 4F(16) 52(16)) label='p3'
f4_s      in = (1B(16) 4F(16) 53(16)) label='p4'
f5_s      in = (1B(16) 4F(16) 6D(16)) label='k-'
f6_s      in = (1B(16) 4F(16) 6C(16)) label='k,'
f7_s      in = (1B(16) 4F(16) 4D(16)) label='ke'
f8_s      in = (1B(16) 4F(16) 6E(16)) label='k.'
f9_s      in = (1B(16) 4F(16) 70(16)) label='k0'
f10_s     in = ()
f11_s     in = ()
f12_s     in = ()
f13_s     in = ()
f14_s     in = ()
f15_s     in = ()
f16_s     in = ()

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = (1B(16) 4F(16) 71(16)) label='F1'
fwd       in = (1B(16) 4F(16) 72(16)) label='F2'
back      in = (1B(16) 4F(16) 73(16)) label='F3'
help      in = (1B(16) 4F(16) 74(16)) label='F4'
undo      in = (1B(16) 4F(16) 75(16)) label='F5'
stop      in = (1B(16) 4F(16) 76(16)) label='F6'
bkw_s     in = (1B(16) 4F(16) 50(16)) label='  Shift-F1'
fwd_s     in = (1B(16) 4F(16) 51(16)) label='  Shift-F2'
undo_s    in = (1B(16) 4F(16) 6D(16)) label='  Shift-F5'
stop_s    in = (1B(16) 4F(16) 6C(16)) label='  Shift-F6'
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_alternate)
alt_end             out = (stop_alternate)
blink_begin         out = (prefix 35(16) 6D(16))
blink_end           out = normal_attributes
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = 0E(16)
ld_fine_end              out = 0F(16)
ld_fine_horizontal       out = 71(16)
ld_fine_vertical         out = 78(16)
ld_fine_upper_left       out = 6C(16)
ld_fine_upper_right      out = 6B(16)
ld_fine_lower_left       out = 6D(16)
ld_fine_lower_right      out = 6A(16)
ld_fine_up_t             out = 77(16)
ld_fine_down_t           out = 76(16)
ld_fine_left_t           out = 74(16)
ld_fine_right_t          out = 75(16)
ld_fine_cross            out = 6E(16)
ld_medium_begin          out = (0E(16) start_alternate)
ld_medium_end            out = (0F(16) stop_alternate)
ld_medium_horizontal     out = 71(16)
ld_medium_vertical       out = 78(16)
ld_medium_upper_left     out = 6C(16)
ld_medium_upper_right    out = 6B(16)
ld_medium_lower_left     out = 6D(16)
ld_medium_lower_right    out = 6A(16)
ld_medium_up_t           out = 77(16)
ld_medium_down_t         out = 76(16)
ld_medium_left_t         out = 74(16)
ld_medium_right_t        out = 75(16)
ld_medium_cross          out = 6E(16)
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "
application_string name=('FSE_FUNCTION_1') out=('align_screen top=last_screen')
application_string name=('FSE_FUNCTION_1_LABEL') out=(' FWD  ')

application_string name=('FSE_FUNCTION_2') out=('align_screen top=current')
application_string name=('FSE_FUNCTION_2_LABEL') out=('Lineup')

application_string name=('FSE_FUNCTION_3') out=('insert_characters nt='' ''')
application_string name=('FSE_FUNCTION_3_LABEL') out=(' INSC ')

application_string name=('FSE_FUNCTION_4') out=('insert_lines p=b nt=''''')
application_string name=('FSE_FUNCTION_4_LABEL') out=(' INSL ')

application_string name=('FSE_FUNCTION_5') out=('mark_lines')
application_string name=('FSE_FUNCTION_5_LABEL') out=(' MARK ')

application_string name=('FSE_FUNCTION_6') out=('copy_text l=m p=b')
application_string name=('FSE_FUNCTION_6_LABEL') out=(' Copy ')

application_string name=('FSE_FUNCTION_7') out=('help')
application_string name=('FSE_FUNCTION_7_LABEL') out=(' HELP ')

application_string name=('FSE_FUNCTION_8') out=('end')
application_string name=('FSE_FUNCTION_8_LABEL') out=(' END  ')

application_string name=('FSE_FUNCTION_9') out=('position_cursor l=c c=$strlen($lt)+1')
application_string name=('FSE_FUNCTION_9_LABEL') out=('Endlin')

application_string name=('FSE_FUNCTION_10') out=(' ')
application_string name=('FSE_FUNCTION_10_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_11') out=(' ')
application_string name=('FSE_FUNCTION_11_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_12') out=(' ')
application_string name=('FSE_FUNCTION_12_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_13') out=(' ')
application_string name=('FSE_FUNCTION_13_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_14') out=(' ')
application_string name=('FSE_FUNCTION_14_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_15') out=(' ')
application_string name=('FSE_FUNCTION_15_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_16') out=(' ')
application_string name=('FSE_FUNCTION_16_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_SHIFT_1') out=('align_screen bottom=first_screen')
application_string name=('FSE_FUNCTION_SHIFT_1_LABEL') out=(' BKW  ')

application_string name=('FSE_FUNCTION_SHIFT_2') out=('align_screen bottom=current')
application_string name=('FSE_FUNCTION_SHIFT_2_LABEL') out=('Linedn')

application_string name=('FSE_FUNCTION_SHIFT_3') out=('delete_characters c=c')
application_string name=('FSE_FUNCTION_SHIFT_3_LABEL') out=(' DELC ')

application_string name=('FSE_FUNCTION_SHIFT_4') out=('delete_lines l=c')
application_string name=('FSE_FUNCTION_SHIFT_4_LABEL') out=(' DELL ')

application_string name=('FSE_FUNCTION_SHIFT_5') out=('undo')
application_string name=('FSE_FUNCTION_SHIFT_5_LABEL') out=(' Undo ')

application_string name=('FSE_FUNCTION_SHIFT_6') out=('move_text l=m p=b; unmark')
application_string name=('FSE_FUNCTION_SHIFT_6_LABEL') out=(' Move ')

application_string name=('FSE_FUNCTION_SHIFT_7') out=('position_cursor r=$home_row c=1')
application_string name=('FSE_FUNCTION_SHIFT_7_LABEL') out=(' HOME ')

application_string name=('FSE_FUNCTION_SHIFT_8') out=('activate_screen')
application_string name=('FSE_FUNCTION_SHIFT_8_LABEL') out=(' Clear')

application_string name=('FSE_FUNCTION_SHIFT_9') out=('unmark')
application_string name=('FSE_FUNCTION_SHIFT_9_LABEL') out=(' Unmrk')

application_string name=('FSE_FUNCTION_SHIFT_10') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_10_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_11') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_11_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_12') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_12_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_13') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_13_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_14') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_14_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_15') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_15_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_16') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_16_LABEL') out=(' ')


"   KEY REDEFINITIONS FOR THE FULL SCREEN EDITOR WHEN USED FROM THE PROGRAMMING ENVIRONMENT "

application_string name=('pe_fix_allerr_func') out=('key=9 shift=true')
application_string name=('pe_fix_assist_func') out=('key=5 shift=false')
application_string name=('pe_fix_format_func') out=('key=8 shift=true')
application_string name=('pe_fix_lookup_func') out=('key=9 shift=false')
application_string name=('pe_fix_nxterr_func') out=('key=6 shift=false')
application_string name=('pe_fix_nxtler_func') out=('key=6 shift=true')
application_string name=('pe_fix_run_func')    out=('key=2 shift=false')
application_string name=('pe_fix_rundbg_func') out=('key=2 shift=true')

application_string name=('pe_fixl_assist_func') out=('key=5 shift=false')
application_string name=('pe_fixl_format_func') out=('key=8 shift=true')
application_string name=('pe_fixl_lookup_func') out=('key=9 shift=false')
application_string name=('pe_fixl_nxterr_func') out=('key=6 shift=false')
application_string name=('pe_fixl_run_func')    out=('key=2 shift=false')
application_string name=('pe_fixl_rundbg_func') out=('key=2 shift=true')

application_string name=('pe_template_modify_format_func') out=('key=8 shift=true')
application_string name=('pe_template_modify_lookup_func') out=('key=9 shift=false')

application_string name=('pe_modify_create_format_func') out=('key=8 shift=true')
application_string name=('pe_modify_create_lookup_func') out=('key=9 shift=false')
application_string name=('pe_modify_create_run_func')    out=('key=2 shift=false')
application_string name=('pe_modify_create_rundbg_func') out=('key=2 shift=true')

application_string name=('pe_view_end_func')    out=('key=8 shift=false')
application_string name=('pe_view_export_func') out=('key=8 shift=true')
application_string name=('pe_view_print_func')  out=('key=9 shift=false')

"   END OF TERMINAL DEFINITION FILE FOR DIGITAL VT100 TERMINAL               "
*DECK DECK=CSM$OLD_Z19 EXPAND=TRUE



"   TERMINAL DEFINITION FILE FOR ZENITH Z19 TERMINAL                          "

"   VARIABLES                                                                 "

prefix              = (1B(16) 5B(16))
end_ins_mode        = (prefix 34(16) 6C(16))
start_inverse       = (prefix 37(16) 6D(16))
stop_inverse        = (prefix 6D(16))

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'OLD_Z19'
communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (3B(16))
cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 48(16))   label='HOME'
cursor_up                inout = (prefix 41(16))
cursor_down              inout = (prefix 42(16))
cursor_left              inout = (prefix 44(16))
cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TAB STOPS                                                                 "
fixed_tab_positions positions = (1,9,17,25,33,41,49,57,65,73)

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = FALSE
function_key_leaves_mark value = 1
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = FALSE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80

"   SCREEN AND LINE MODE TRANSITION                                           "
set_screen_mode     out = (1B(16) 3C(16) prefix 3E(16) 34(16) ..
 3B(16) 36(16) 3B(16) 37(16) 68(16) prefix 3E(16) 33(16)  ..
 6C(16) prefix 3F(16) 37(16) 6C(16) )

set_line_mode       out = (prefix 7A(16))

"   TERMINAL CAPABILITIES                                                     "
backspace           in    = (08(16))
delete_char         inout = (prefix 50(16))         label='DC'
delete_line_bol     inout = (prefix 4D(16))         label='DL'
erase_end_of_line   inout = (prefix 30(16) 4B(16))
erase_end_of_page   inout = (prefix 4A(16))
erase_page_home     inout = (prefix 32(16) 4A(16))  label='ERASE'
insert_char         inout = (prefix 40(16))
insert_line_bol     inout = (prefix 4C(16))         label='IL'
insert_mode_begin   inout = (prefix 34(16) 68(16))  label='IMB'
insert_mode_end     inout = (prefix 34(16) 6C(16))
tab_forward         inout = (09(16))

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
output_begin        out = ()
bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (1B(16) 4F(16) 53(16))  label = 'f1'
f2        in = (1B(16) 4F(16) 54(16))  label = 'f2'
f3        in = (1B(16) 4F(16) 55(16))  label = 'f3'
f4        in = (1B(16) 4F(16) 56(16))  label = 'f4'
f5        in = (1B(16) 4F(16) 57(16))  label = 'f5'
f6        in = (1B(16) 4F(16) 50(16))  label = 'Bl'
f7        in = (1B(16) 4F(16) 51(16))  label = 'Rd'
f8        in = (1B(16) 4F(16) 52(16))  label = 'Wt'
f9        in = ()
f10       in = ()
f11       in = ()
f12       in = ()
f13       in = ()
f14       in = ()
f15       in = ()
f16       in = ()
f1_s      in = (1B(16) 4F(16) 71(16))  label = 's1'
f2_s      in = (1B(16) 4F(16) 72(16))  label = 's2'
f3_s      in = (1B(16) 4F(16) 73(16))  label = 's3'
f4_s      in = (1B(16) 4F(16) 74(16))  label = 's4'
f5_s      in = (1B(16) 4F(16) 75(16))  label = 's5'
f6_s      in = (1B(16) 4F(16) 76(16))  label = 's6'
f7_s      in = (1B(16) 4F(16) 77(16))  label = 's7'
f8_s      in = (1B(16) 4F(16) 78(16))  label = 's8'
f9_s      in = (1B(16) 4F(16) 79(16))  label = 's9'
f10_s     in = (1B(16) 4F(16) 70(16))  label = 'k0'
f11_s     in = (1B(16) 4F(16) 6E(16))  label = 'k.'
f12_s     in = (1B(16) 4F(16) 4D(16))  label = 'ke'
f13_s     in = ()
f14_s     in = ()
f15_s     in = ()
f16_s     in = ()

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = (1B(16) 4F(16) 53(16))  label = 'F1'
fwd       in = (1B(16) 4F(16) 54(16))  label = 'F2'
back      in = (1B(16) 4F(16) 55(16))  label = 'F3'
help      in = (1B(16) 4F(16) 56(16))  label = 'F4'
undo      in = (1B(16) 4F(16) 57(16))  label = 'F5'
stop      in = (1B(16) 4F(16) 50(16))  label = 'F6'
bkw_s     in = (1B(16) 4F(16) 71(16))  label = '  SF1'
fwd_s     in = (1B(16) 4F(16) 72(16))  label = '  SF2'
undo_s    in = (1B(16) 4F(16) 75(16))  label = '  SF5'
stop_s    in = (1B(16) 4F(16) 76(16))  label = '  SF6'
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_inverse)
underline_end       out = (stop_inverse)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_inverse)
input_text_end      out = (stop_inverse)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = (prefix 31(16) 30(16) 6D(16))
ld_fine_end              out = (prefix 31(16) 31(16) 6D(16))
ld_fine_horizontal       out = 61(16)
ld_fine_vertical         out = 60(16)
ld_fine_upper_left       out = 66(16)
ld_fine_upper_right      out = 63(16)
ld_fine_lower_left       out = 65(16)
ld_fine_lower_right      out = 64(16)
ld_fine_up_t             out = 73(16)
ld_fine_down_t           out = 75(16)
ld_fine_left_t           out = 76(16)
ld_fine_right_t          out = 74(16)
ld_fine_cross            out = 62(16)
ld_medium_begin          out = (prefix 31(16) 30(16) 6D(16))
ld_medium_end            out = (prefix 31(16) 31(16) 6D(16))
ld_medium_horizontal     out = 61(16)
ld_medium_vertical       out = 60(16)
ld_medium_upper_left     out = 66(16)
ld_medium_upper_right    out = 63(16)
ld_medium_lower_left     out = 65(16)
ld_medium_lower_right    out = 64(16)
ld_medium_up_t           out = 73(16)
ld_medium_down_t         out = 75(16)
ld_medium_left_t         out = 76(16)
ld_medium_right_t        out = 74(16)
ld_medium_cross          out = 62(16)
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

application_string name=('FSE_FUNCTION_1') out=('align_screen top=last_screen')
application_string name=('FSE_FUNCTION_1_LABEL') out=(' FWD  ')

application_string name=('FSE_FUNCTION_2') out=('align_screen bottom=first_screen')
application_string name=('FSE_FUNCTION_2_LABEL') out=(' BKW  ')

application_string name=('FSE_FUNCTION_3') out=('align_screen top=current')
application_string name=('FSE_FUNCTION_3_LABEL') out=('Lineup')

application_string name=('FSE_FUNCTION_4') out=('align_screen bottom=current')
application_string name=('FSE_FUNCTION_4_LABEL') out=('Linedn')

application_string name=('FSE_FUNCTION_5') out=('align_screen middle=current')
application_string name=('FSE_FUNCTION_5_LABEL') out=('Middle')

application_string name=('FSE_FUNCTION_6') out=('undo')
application_string name=('FSE_FUNCTION_6_LABEL') out=(' UNDO ')

application_string name=('FSE_FUNCTION_7') out=('end')
application_string name=('FSE_FUNCTION_7_LABEL') out=(' Quit ')

application_string name=('FSE_FUNCTION_8') out=('help')
application_string name=('FSE_FUNCTION_8_LABEL') out=(' HELP ')

application_string name=('FSE_FUNCTION_9') out=(' ')
application_string name=('FSE_FUNCTION_9_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_10') out=(' ')
application_string name=('FSE_FUNCTION_10_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_11') out=(' ')
application_string name=('FSE_FUNCTION_11_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_12') out=(' ')
application_string name=('FSE_FUNCTION_12_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_13') out=(' ')
application_string name=('FSE_FUNCTION_13_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_14') out=(' ')
application_string name=('FSE_FUNCTION_14_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_15') out=(' ')
application_string name=('FSE_FUNCTION_15_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_16') out=(' ')
application_string name=('FSE_FUNCTION_16_LABEL') out=(' ')


application_string name=('FSE_FUNCTION_SHIFT_1') out=('mark_lines')
application_string name=('FSE_FUNCTION_SHIFT_1_LABEL') out=(' MARK ')

application_string name=('FSE_FUNCTION_SHIFT_2') out=('mark_characters')
application_string name=('FSE_FUNCTION_SHIFT_2_LABEL') out=('Mrkchr')

application_string name=('FSE_FUNCTION_SHIFT_3') out=('unmark')
application_string name=('FSE_FUNCTION_SHIFT_3_LABEL') out=('Unmark')

application_string name=('FSE_FUNCTION_SHIFT_4') out=('copy_text l=m p=b')
application_string name=('FSE_FUNCTION_SHIFT_4_LABEL') out=(' Copy ')

application_string name=('FSE_FUNCTION_SHIFT_5') out=('move_text l=m p=b; unmark')
application_string name=('FSE_FUNCTION_SHIFT_5_LABEL') out=(' Move ')

application_string name=('FSE_FUNCTION_SHIFT_6') out=('position_cursor l=c c=$strlen($lt)+1')
application_string name=('FSE_FUNCTION_SHIFT_6_LABEL') out=('Endlin')

application_string name=('FSE_FUNCTION_SHIFT_7') out=('align_screen offset=0')
application_string name=('FSE_FUNCTION_SHIFT_7_LABEL') out=(' Left ')

application_string name=('FSE_FUNCTION_SHIFT_8') out=('esv$off=30; if $current_column<>1 then; esv$off=$current_column-1; ifend; align_screen offset=esv$off; position_cursor l=c c=$current_column+30')
application_string name=('FSE_FUNCTION_SHIFT_8_LABEL') out=(' Right')

application_string name=('FSE_FUNCTION_SHIFT_9') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_9_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_10') out=('locate_next')
application_string name=('FSE_FUNCTION_SHIFT_10_LABEL') out=('Locnxt')

application_string name=('FSE_FUNCTION_SHIFT_11') out=('esv$text=$screen_input(''Enter search string''); if esv$text='''' then; locate_all; else; locate_all t=esv$text; ifend')
application_string name=('FSE_FUNCTION_SHIFT_11_LABEL') out=('Locall')

application_string name=('FSE_FUNCTION_SHIFT_12') out=('locate_string t=$screen_input(''Enter search string'')')
application_string name=('FSE_FUNCTION_SHIFT_12_LABEL') out=('LOCATE')

application_string name=('FSE_FUNCTION_SHIFT_13') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_13_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_14') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_14_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_15') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_15_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_16') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_16_LABEL') out=(' ')

"   KEY REDEFINITIONS FOR THE FULL SCREEN EDITOR WHEN USED FROM THE PROGRAMMING ENVIRONMENT "

application_string name=('pe_fix_allerr_func') out=('key=2 shift=true')
application_string name=('pe_fix_assist_func') out=('key=11 shift=true')
application_string name=('pe_fix_format_func') out=('key=8 shift=true')
application_string name=('pe_fix_lookup_func') out=('key=7 shift=true')
application_string name=('pe_fix_nxterr_func') out=('key=5 shift=false')
application_string name=('pe_fix_nxtler_func') out=('key=6 shift=true')
application_string name=('pe_fix_run_func')    out=('key=3 shift=false')
application_string name=('pe_fix_rundbg_func') out=('key=4 shift=false')

application_string name=('pe_fixl_assist_func') out=('key=11 shift=true')
application_string name=('pe_fixl_format_func') out=('key=8 shift=true')
application_string name=('pe_fixl_lookup_func') out=('key=7 shift=true')
application_string name=('pe_fixl_nxterr_func') out=('key=5 shift=false')
application_string name=('pe_fixl_run_func')    out=('key=3 shift=false')
application_string name=('pe_fixl_rundbg_func') out=('key=4 shift=false')

application_string name=('pe_template_modify_format_func') out=('key=8 shift=true')
application_string name=('pe_template_modify_lookup_func') out=('key=7 shift=true')

application_string name=('pe_modify_create_format_func') out=('key=8 shift=true')
application_string name=('pe_modify_create_lookup_func') out=('key=7 shift=true')
application_string name=('pe_modify_create_run_func')    out=('key=3 shift=false')
application_string name=('pe_modify_create_rundbg_func') out=('key=4 shift=false')

application_string name=('pe_view_end_func')    out=('key=7 shift=false')
application_string name=('pe_view_export_func') out=('key=8 shift=true')
application_string name=('pe_view_print_func')  out=('key=7 shift=true')

"   END OF TERMINAL DEFINITION FILE FOR ZENITH Z19 TERMINAL                   "
*DECK DECK=CSM$OLD_Z29 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR ZENITH Z29 TERMINAL                          "

" Note that this definition assumes certain hardware modes will be established "
" when setting line mode at the end of a screen mode task.  The assumptions    "
" are to configure the keypad for numeric unshifted usage, to allow automatic  "
" wraparound at end of line, and to disable the 'hold screen' capability.      "
" users may prefer different settings: modify the 'set_line_mode' statement to "
" do so.  Earlier versions of this definition used the hardware reset, but had "
" the side-effect of causing some types of modems to disconnect; thus the      "
" set of specific modes.                                                       "

"   VARIABLES                                                                 "

prefix              = (esc '[')
clear_all_tabs      = (prefix '3g')
normal_attributes   = (prefix 'm')
end_ins_mode        = (prefix '4l')
start_inverse       = (prefix '7m')
stop_inverse        = normal_attributes
start_underline     = (prefix '4m')
stop_underline      = normal_attributes
start_alternate     = (prefix 31(16) 6D(16))
stop_alternate      = normal_attributes
start_dim           = (prefix '2m')
stop_dim            = normal_attributes
start_hold_screen   = (prefix '>3h')
stop_hold_screen    = (prefix '>3l')
start_block_cursor  = (prefix '>4h')
stop_block_cursor   = (prefix '>4l')
start_keypad_shift  = (prefix '>6h')
stop_keypad_shift   = (prefix '>6l')
start_keypad_alt    = (prefix '>7h')
stop_keypad_alt     = (prefix '>7l')
use_ansi_mode       = (ESC '<')
discard_at_eol      = (prefix '?7l')
wraparound_at_eol   = (prefix '?7h')


"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'OLD_Z29'
communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (';')
cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 'H')    label='HOME'
cursor_up                inout = (prefix 'A')
cursor_down              inout = (prefix 'B')
cursor_left              inout = (prefix 'D')
cursor_right             inout = (prefix 'C')

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = FALSE
function_key_leaves_mark value = 1
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = FALSE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80

"   SCREEN AND LINE MODE TRANSITION                                           "
set_screen_mode     out = (use_ansi_mode  start_block_cursor ..
 start_keypad_shift  start_keypad_alt  stop_hold_screen ..
 discard_at_eol)

set_line_mode       out = (stop_keypad_shift  stop_keypad_alt ..
 wraparound_at_eol stop_hold_screen)

"   TERMINAL CAPABILITIES                                                     "
backspace           in    = (08(16))
delete_char         inout = (prefix 'P')     label='DC'
delete_line_bol     inout = (prefix 'M')     label='DL'
erase_end_of_line   inout = (prefix '0K')
erase_end_of_page   inout = (prefix 'J')
erase_page_home     inout = (prefix '2J')    label='ERASE'
insert_char         inout = (prefix '@')
insert_line_bol     inout = (prefix 'L')     label='IL'
insert_mode_begin   inout = (prefix '4h')    label='IMB'
insert_mode_end     inout = (prefix '4l')
tab_backward        inout = (prefix 'Z')
tab_forward         inout = (09(16))
tab_clear_all       inout = (clear_all_tabs)
tab_set             inout = (esc 'H')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
output_begin        out = ()
bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (esc 'OS')     label='f1'
f2        in = (esc 'OT')     label='f2'
f3        in = (esc 'OU')     label='f3'
f4        in = (esc 'OV')     label='f4'
f5        in = (esc 'OW')     label='f5'
f6        in = (esc 'OP')     label='f6'
f7        in = (esc 'OQ')     label='f7'
f8        in = (esc 'OR')     label='f8'
f9        in = (esc 'OX')     label='f9'
f10       in = ()
f11       in = ()
f12       in = ()
f13       in = ()
f14       in = ()
f15       in = ()
f16       in = ()
f1_s      in = (esc 'Oq')     label='s1'
f2_s      in = (esc 'Or')     label='s2'
f3_s      in = (esc 'Os')     label='s3'
f4_s      in = (esc 'Ot')     label='s4'
f5_s      in = (esc 'Ou')     label='s5'
f6_s      in = (esc 'Ov')     label='s6'
f7_s      in = (esc 'Ow')     label='s7'
f8_s      in = (esc 'Ox')     label='s8'
f9_s      in = (esc 'Oy')     label='s9'
f10_s     in = (esc 'Op')     label='k0'
f11_s     in = (esc 'On')     label='k.'
f12_s     in = (esc 'OM')     label='ke'
f13_s     in = (esc 'Ol')     label='k,'
f14_s     in = (esc 'Om')     label='k-'
f15_s     in = ()
f16_s     in = ()

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13               label='RETURN'
bkw       in = (esc 'OS')     label='F1'
fwd       in = (esc 'OT')     label='F2'
back      in = (esc 'OU')     label='F3'
undo      in = (esc 'OW')     label='F5'
stop      in = (esc 'OP')     label='F6'
bkw_s     in = (esc 'Oq')     label='  SF1'
fwd_s     in = (esc 'Or')     label='  SF2'
undo_s    in = (esc 'Ou')     label='  SF5'
stop_s    in = (esc 'Ov')     label='  SF6'
help      in = (prefix '~')     label='HELP'
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_alternate)
alt_end             out = (stop_alternate)
blink_begin         out = (prefix '5m')
blink_end           out = normal_attributes
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = (prefix '10m')
ld_fine_end              out = (prefix '11m')
ld_fine_horizontal       out = 61(16)
ld_fine_vertical         out = 60(16)
ld_fine_upper_left       out = 66(16)
ld_fine_upper_right      out = 63(16)
ld_fine_lower_left       out = 65(16)
ld_fine_lower_right      out = 64(16)
ld_fine_up_t             out = 73(16)
ld_fine_down_t           out = 75(16)
ld_fine_left_t           out = 76(16)
ld_fine_right_t          out = 74(16)
ld_fine_cross            out = 62(16)
ld_medium_begin          out = (prefix '10m')
ld_medium_end            out = (prefix '11m')
ld_medium_horizontal     out = 61(16)
ld_medium_vertical       out = 60(16)
ld_medium_upper_left     out = 66(16)
ld_medium_upper_right    out = 63(16)
ld_medium_lower_left     out = 65(16)
ld_medium_lower_right    out = 64(16)
ld_medium_up_t           out = 73(16)
ld_medium_down_t         out = 75(16)
ld_medium_left_t         out = 76(16)
ld_medium_right_t        out = 74(16)
ld_medium_cross          out = 62(16)
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

application_string name=('FSE_FUNCTION_1') out=('align_screen top=last_screen')
application_string name=('FSE_FUNCTION_2') out=('align_screen bottom=first_screen')
application_string name=('FSE_FUNCTION_3') out=('align_screen top=current')
application_string name=('FSE_FUNCTION_4') out=('align_screen bottom=current')
application_string name=('FSE_FUNCTION_5') out=('align_screen middle=current')
application_string name=('FSE_FUNCTION_6') out=('undo')
application_string name=('FSE_FUNCTION_7') out=('end')
application_string name=('FSE_FUNCTION_8') out=('align_screen top=first')
application_string name=('FSE_FUNCTION_9') out=('write_file')

application_string name=('FSE_FUNCTION_1_LABEL') out=(' fwd  ')
application_string name=('FSE_FUNCTION_2_LABEL') out=(' bkw  ')
application_string name=('FSE_FUNCTION_3_LABEL') out=('lineup')
application_string name=('FSE_FUNCTION_4_LABEL') out=('linedn')
application_string name=('FSE_FUNCTION_5_LABEL') out=('middle')
application_string name=('FSE_FUNCTION_6_LABEL') out=(' undo ')
application_string name=('FSE_FUNCTION_7_LABEL') out=(' quit ')
application_string name=('FSE_FUNCTION_8_LABEL') out=(' top  ')
application_string name=('FSE_FUNCTION_9_LABEL') out=(' wrif ')

application_string name=('FSE_FUNCTION_SHIFT_1') out=('mark_lines')
application_string name=('FSE_FUNCTION_SHIFT_2') out=('mark_characters')
application_string name=('FSE_FUNCTION_SHIFT_3') out=('unmark')
application_string name=('FSE_FUNCTION_SHIFT_4') out=('copy_text l=m p=b')
application_string name=('FSE_FUNCTION_SHIFT_5') out=('move_text l=m p=b; unmark')
application_string name=('FSE_FUNCTION_SHIFT_6') out=('position_cursor l=c c=$strlen($lt)+1')
application_string name=('FSE_FUNCTION_SHIFT_7') out=('align_screen offset=0')
application_string name=('FSE_FUNCTION_SHIFT_8') out=('esv$off=30; if $current_column<>1 then; esv$off=$current_column-1; ifend; align_screen offset=esv$off; position_cursor l=c c=$current_column+30')
application_string name=('FSE_FUNCTION_SHIFT_9') out=('align_screen middle=last')
application_string name=('FSE_FUNCTION_SHIFT_10') out=('position_cursor; position_cursor rs=true; ')
application_string name=('FSE_FUNCTION_SHIFT_11') out=('esv$text=$screen_input(''Enter search string''); if esv$text='''' then; esv$text=$text; ifend; locate_text rs=true l=a v=true t=esv$text')
application_string name=('FSE_FUNCTION_SHIFT_12') out=('locate_text t=$screen_input(''Enter search string'')')
application_string name=('FSE_FUNCTION_SHIFT_13') out=('join_text')
application_string name=('FSE_FUNCTION_SHIFT_14') out=('break_text')

application_string name=('FSE_FUNCTION_SHIFT_1_LABEL') out=(' MARK ')
application_string name=('FSE_FUNCTION_SHIFT_2_LABEL') out=('MRKCHR')
application_string name=('FSE_FUNCTION_SHIFT_3_LABEL') out=('UNMARK')
application_string name=('FSE_FUNCTION_SHIFT_4_LABEL') out=(' COPY ')
application_string name=('FSE_FUNCTION_SHIFT_5_LABEL') out=(' MOVE ')
application_string name=('FSE_FUNCTION_SHIFT_6_LABEL') out=('ENDLIN')
application_string name=('FSE_FUNCTION_SHIFT_7_LABEL') out=(' LEFT ')
application_string name=('FSE_FUNCTION_SHIFT_8_LABEL') out=(' RIGHT')
application_string name=('FSE_FUNCTION_SHIFT_9_LABEL') out=('BOTTOM')
application_string name=('FSE_FUNCTION_SHIFT_10_LABEL') out=('LOCNXT')
application_string name=('FSE_FUNCTION_SHIFT_11_LABEL') out=('LOCALL')
application_string name=('FSE_FUNCTION_SHIFT_12_LABEL') out=('LOCATE')
application_string name=('FSE_FUNCTION_SHIFT_13_LABEL') out=(' JOIN ')
application_string name=('FSE_FUNCTION_SHIFT_14_LABEL') out=(' BREAK')

"   KEY REDEFINITIONS FOR THE FULL SCREEN EDITOR WHEN USED FROM THE PROGRAMMING ENVIRONMENT "

application_string name=('pe_fix_allerr_func') out=('key=8 shift=false')
application_string name=('pe_fix_assist_func') out=('key=9 shift=true')
application_string name=('pe_fix_format_func') out=('key=6 shift=true')
application_string name=('pe_fix_lookup_func') out=('key=9 shift=false')
application_string name=('pe_fix_nxterr_func') out=('key=13 shift=true')
application_string name=('pe_fix_nxtler_func') out=('key=14 shift=true')
application_string name=('pe_fix_run_func')    out=('key=7 shift=true')
application_string name=('pe_fix_rundbg_func') out=('key=8 shift=true')

application_string name=('pe_fixl_assist_func') out=('key=9 shift=true')
application_string name=('pe_fixl_format_func') out=('key=6 shift=true')
application_string name=('pe_fixl_lookup_func') out=('key=9 shift=false')
application_string name=('pe_fixl_nxterr_func') out=('key=13 shift=true')
application_string name=('pe_fixl_run_func')    out=('key=7 shift=true')
application_string name=('pe_fixl_rundbg_func') out=('key=8 shift=true')

application_string name=('pe_template_modify_format_func') out=('key=6 shift=true')
application_string name=('pe_template_modify_lookup_func') out=('key=9 shift=false')

application_string name=('pe_modify_create_format_func') out=('key=6 shift=true')
application_string name=('pe_modify_create_lookup_func') out=('key=9 shift=false')
application_string name=('pe_modify_create_run_func')    out=('key=7 shift=true')
application_string name=('pe_modify_create_rundbg_func') out=('key=8 shift=true')

application_string name=('pe_view_end_func')    out=('key=7 shift=false')
application_string name=('pe_view_export_func') out=('key=6 shift=true')
application_string name=('pe_view_print_func')  out=('key=9 shift=false')

"   END OF TERMINAL DEFINITION FILE FOR ZENITH Z29 TERMINAL                   "
*DECK DECK=CSM$PC_CONNECT_10 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT  Version 0.1 6/26/85 "

"   VARIABLES                                                                 "
    prefix              = (1B(16) 5B(16))                     "esc ["
    clear_stay          = (prefix 32(16) 4A(16))              "2J"
    clear_all_tabs      = (prefix 33(16) 67(16))              "3g"
    set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))       "?3l"
  " set_to_24x132       = (prefix 3F(l6) 33(16) 68(16)) "     "?3h"
    enable_auto_wrap    = (prefix 3F(16) 37(16) 68(16))       "?7h"
    disable_auto_wrap   = (prefix 3F(16) 37(16) 6C(16))       "?7l"
    designate_graphics  = (1B(16) 29(16) 30(16))              "esc )0"
    invoke_graphics     = (0E(16))
    invoke_text         = (0F(16))
    keypad_numeric      = (1B(16) 3E(16))                     "esc >"
    enable_protect      = (prefix 3D(16) 31(16) 68(16))       "=1h"
    disable_protect     = (prefix 3D(16) 31(16) 6C(16))       "=1l"
    enable_insertion    = (prefix 34(16) 68(16))              "4h"
    disable_insertion   = (prefix 34(16) 6C(16))              "4l"
    enable_autotab      = (prefix 3D(16) 33(16) 68(16))       "=3h"
    disable_autotab     = (prefix 3D(16) 33(16) 6C(16))       "=3l"

    start_alternate     = (prefix 31(16) 6D(16))              "1m"
    start_blink         = (prefix 35(16) 6D(16))              "5m"
    start_inverse       = (prefix 37(16) 6D(16))              "7m"
    start_underline     = (prefix 34(16) 6D(16))              "4m"
    stop_alternate      = (prefix 6D(16))                     "m"
    stop_blink          = (prefix 6D(16))                     "m"
    stop_inverse        = (prefix 6D(16))                     "m"
    stop_underline      = (prefix 6D(16))                     "m"

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'PC_CONNECT_10'
    communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix)
    cursor_pos_second        out   = (3B(16))
    cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (prefix 48(16))      label='Home'
    cursor_up                inout = (prefix 41(16))
    cursor_down              inout = (prefix 42(16))
    cursor_left              inout = (prefix 44(16))
    cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = stop_next
    move_past_left           type  = stop_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = stop_next
    char_past_left           type  = stop_next
    char_past_last_position  type  = scroll_next

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 0
    has_hidden               value = FALSE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = TRUE

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80   out = (set_to_24x80)

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode     out = ( clear_all_tabs  disable_auto_wrap ..
         designate_graphics  invoke_text  enable_protect ..
         enable_autotab )

    set_line_mode       out = ( clear_all_tabs  disable_autotab ..
         designate_graphics  invoke_text  keypad_numeric ..
         enable_auto_wrap  disable_protect  disable_insertion )


"   TERMINAL CAPABILITIES                                                     "

    backspace           in = (bs)
    delete_char         inout = (prefix 50(16))  label='Del'
    delete_line_stay    inout = (prefix 4D(16))  label='Alt-D'

    erase_end_of_line   inout = (prefix 4B(16))
    erase_line_stay     inout = (prefix 32(16) 4B(16))
    erase_page_stay     inout = (clear_stay)

    insert_line_stay    inout = (prefix 4C(16))         label='Alt-I'
    insert_mode_begin   inout = (enable_insertion)      label='Ins'
    insert_mode_end     inout = (disable_insertion)     label='End'

    tab_backward        inout = (prefix 'Z')
    tab_forward         inout = (09(16))
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (1B(16) 48(16))

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (1B(16) 'V')
    protect_end         out = (1B(16) 'W')
    output_begin        out = ()
    output_end          out = ()
    bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (1B(16) 4F(16) 71(16)) label='f1'
    f2        in = (1B(16) 4F(16) 72(16)) label='f2'
    f3        in = (1B(16) 4F(16) 73(16)) label='f3'
    f4        in = (1B(16) 4F(16) 74(16)) label='f4'
    f5        in = (1B(16) 4F(16) 75(16)) label='f5'
    f6        in = (1B(16) 4F(16) 76(16)) label='f6'
    f7        in = (1B(16) 4F(16) 77(16)) label='f7'
    f8        in = (1B(16) 4F(16) 78(16)) label='f8'
    f9        in = (1B(16) 4F(16) 79(16)) label='f9'
    f10       in = (1B(16) 4F(16) 7A(16)) label='10'
    f11       in = (1B(16) 4F(16) 7B(16)) label='c1'
    f12       in = (1B(16) 4F(16) 7C(16)) label='c2'
    f13       in = (1B(16) 4F(16) 7D(16)) label='c3'
    f14       in = (1B(16) 4F(16) 7E(16)) label='c4'
    f15       in = (1B(16) 4F(16) 5F(16)) label='c5'
    f16       in = (1B(16) 4F(16) 55(16)) label='c6'
    f1_s      in = (1B(16) 4F(16) 50(16)) label='  SF1'
    f2_s      in = (1B(16) 4F(16) 51(16)) label='  SF2'
    f3_s      in = (1B(16) 4F(16) 52(16)) label='  SF3'
    f4_s      in = (1B(16) 4F(16) 53(16)) label='  SF4'
    f5_s      in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    f6_s      in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    f7_s      in = (1B(16) 4F(16) 4D(16)) label='  SF7'
    f8_s      in = (1B(16) 4F(16) 6E(16)) label='  SF8'
    f9_s      in = (1B(16) 4F(16) 70(16)) label='  SF9'
    f10_s     in = (1B(16) 4F(16) 4F(16)) label='  SF10'
    f11_s     in = (1B(16) 4F(16) 61(16)) label='A1'
    f12_s     in = (1B(16) 4F(16) 62(16)) label='A2'
    f13_s     in = (1B(16) 4F(16) 63(16)) label='A3'
    f14_s     in = (1B(16) 4F(16) 64(16)) label='A4'
    f15_s     in = (1B(16) 4F(16) 65(16)) label='A5'
    f16_s     in = (1B(16) 4F(16) 56(16)) label='A6'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13  label='NEXT'
    back      in = (1B(16) 4F(16) 73(16)) label='f3'
    help      in = (1B(16) 4F(16) 74(16)) label='f4'
    undo      in = (1B(16) 4F(16) 75(16)) label='f5'
    stop      in = (1B(16) 4F(16) 76(16)) label='f6'
    undo_s    in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    stop_s    in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    down      in = ()
    down_s    in = ()
    up        in = ()
    up_s      in = ()

    fwd       in = (1B(16) 4F(16) 58(16)) label='FWD'
    fwd_s     in = (1B(16) 4F(16) 6F(16)) label='Shift-FWD'

    bkw       in = (1B(16) 4F(16) 57(16)) label='BKW'
    bkw_s     in = (1B(16) 4F(16) 66(16)) label='Shift-BKW'

    edit      in = ()
    edit_s    in = ()
    data      in = ()
    data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)
    protect_begin       out = ()
    protect_end         out = ()

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_inverse)
    error_end           out = (stop_inverse)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = invoke_graphics
    ld_fine_end              out = invoke_text
    ld_fine_horizontal       out = 71(16)
    ld_fine_vertical         out = 78(16)
    ld_fine_upper_left       out = 6C(16)
    ld_fine_upper_right      out = 6B(16)
    ld_fine_lower_left       out = 6D(16)
    ld_fine_lower_right      out = 6A(16)
    ld_fine_up_t             out = 77(16)
    ld_fine_down_t           out = 76(16)
    ld_fine_left_t           out = 74(16)
    ld_fine_right_t          out = 75(16)
    ld_fine_cross            out = 6E(16)
    ld_medium_begin          out = (invoke_graphics start_alternate)
    ld_medium_end            out = (invoke_text stop_alternate)
    ld_medium_horizontal     out = 71(16)
    ld_medium_vertical       out = 78(16)
    ld_medium_upper_left     out = 6C(16)
    ld_medium_upper_right    out = 6B(16)
    ld_medium_lower_left     out = 6D(16)
    ld_medium_lower_right    out = 6A(16)
    ld_medium_up_t           out = 77(16)
    ld_medium_down_t         out = 76(16)
    ld_medium_left_t         out = 74(16)
    ld_medium_right_t        out = 75(16)
    ld_medium_cross          out = 6E(16)
    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')


"   END OF TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT              "
*DECK DECK=CSM$PC_CONNECT_11 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT                      "

" Automatic tabbing is available as a user or site option.  To enable it,     "
" change the automatic_tabbing firective from FALSE to TRUE, and look at the  "
" set_screen_mode and set_line_mode directives for comment-disabled references"
" to the variables enable_autotab and disable_autotab -- enable these         "
" references by blanking over the comment quotes.                             "

"       PC_CONNECT_11        VERSION 1.1                MARCH 24, 1986        "

"   VARIABLES                                                                 "
    prefix              = (1B(16) 5B(16))                     "esc ["
    clear_stay          = (prefix 32(16) 4A(16))              "2J"
    clear_all_tabs      = (prefix 33(16) 67(16))              "3g"
    set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))       "?3l"
  " set_to_24x132       = (prefix 3F(l6) 33(16) 68(16)) "     "?3h"
    enable_auto_wrap    = (prefix 3F(16) 37(16) 68(16))       "?7h"
    disable_auto_wrap   = (prefix 3F(16) 37(16) 6C(16))       "?7l"
    designate_graphics  = (1B(16) 29(16) 30(16))              "esc )0"
    invoke_graphics     = (0E(16))
    invoke_text         = (0F(16))
    enable_protect      = (prefix 3D(16) 31(16) 68(16))       "=1h"
    disable_protect     = (prefix 3D(16) 31(16) 6C(16))       "=1l"
    enable_insertion    = (prefix 34(16) 68(16))              "4h"
    disable_insertion   = (prefix 34(16) 6C(16))              "4l"
    enable_autotab      = (prefix 3D(16) 33(16) 68(16))       "=3h"
    disable_autotab     = (prefix 3D(16) 33(16) 6C(16))       "=3l"

    start_alternate     = (prefix 31(16) 6D(16))              "1m"
    start_blink         = (prefix 35(16) 6D(16))              "5m"
    start_inverse       = (prefix 37(16) 6D(16))              "7m"
    start_underline     = (prefix 34(16) 6D(16))              "4m"
    stop_alternate      = (prefix 6D(16))                     "m"
    stop_blink          = (prefix 6D(16))                     "m"
    stop_inverse        = (prefix 6D(16))                     "m"
    stop_underline      = (prefix 6D(16))                     "m"

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'PC_CONNECT_11'
    communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix)
    cursor_pos_second        out   = (3B(16))
    cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (prefix 48(16))      label='Home'
    cursor_up                inout = (prefix 41(16))
    cursor_down              inout = (prefix 42(16))
    cursor_left              inout = (prefix 44(16))
    cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = wrap_adjacent_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = stop_next
    char_past_left           type  = wrap_adjacent_next
    char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 0
    has_hidden               value = FALSE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
    automatic_tabbing        value = FALSE

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80   out = (set_to_24x80)

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode     out = ( clear_all_tabs  disable_auto_wrap ..
         "enable_autotab" designate_graphics  invoke_text  enable_protect )

    set_line_mode       out = ( prefix '0p' clear_all_tabs "disable_autotab" ..
         designate_graphics  invoke_text  ..
         enable_auto_wrap  disable_protect  disable_insertion )


"   TERMINAL CAPABILITIES                                                     "

    backspace           in = (bs)
    delete_char         inout = (prefix 50(16))  label='Del'
    delete_line_stay    inout = (prefix 4D(16))  label='Alt-D'

    erase_end_of_line   inout = (prefix 'K')
    erase_line_stay     inout = (prefix 32(16) 'K')
    erase_end_of_field  inout = (prefix 'N')
    erase_field_stay    inout = (prefix '2N')
    erase_page_stay     inout = (clear_stay)

    insert_line_stay    inout = (prefix 4C(16))         label='Alt-I'
    insert_mode_begin   inout = (enable_insertion)      label='Ins'
    insert_mode_end     inout = (disable_insertion)     label='End'

    tab_backward        inout = (prefix 'Z')
    tab_forward         inout = (09(16))
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (1B(16) 48(16))

    protect_all         out = (prefix '1p')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (1B(16) 'V')
    protect_end         out = (1B(16) 'W')
    output_begin        out = (disable_protect disable_insertion)
    output_end          out = (enable_protect)
    bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (1B(16) 4F(16) 71(16)) label='f1'
    f2        in = (1B(16) 4F(16) 72(16)) label='f2'
    f3        in = (1B(16) 4F(16) 73(16)) label='f3'
    f4        in = (1B(16) 4F(16) 74(16)) label='f4'
    f5        in = (1B(16) 4F(16) 75(16)) label='f5'
    f6        in = (1B(16) 4F(16) 76(16)) label='f6'
    f7        in = (1B(16) 4F(16) 77(16)) label='f7'
    f8        in = (1B(16) 4F(16) 78(16)) label='f8'
    f9        in = (1B(16) 4F(16) 79(16)) label='f9'
    f10       in = (1B(16) 4F(16) 7A(16)) label='10'
    f11       in = (1B(16) 4F(16) 7B(16)) label='C1'
    f12       in = (1B(16) 4F(16) 7C(16)) label='C2'
    f13       in = (1B(16) 4F(16) 7D(16)) label='C3'
    f14       in = (1B(16) 4F(16) 7E(16)) label='C4'
    f15       in = (1B(16) 4F(16) 5F(16)) label='C5'
    f16       in = (1B(16) 4F(16) 55(16)) label='C6'
    f1_s      in = (1B(16) 4F(16) 50(16)) label='  SF1'
    f2_s      in = (1B(16) 4F(16) 51(16)) label='  SF2'
    f3_s      in = (1B(16) 4F(16) 52(16)) label='  SF3'
    f4_s      in = (1B(16) 4F(16) 53(16)) label='  SF4'
    f5_s      in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    f6_s      in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    f7_s      in = (1B(16) 4F(16) 4D(16)) label='  SF7'
    f8_s      in = (1B(16) 4F(16) 6E(16)) label='  SF8'
    f9_s      in = (1B(16) 4F(16) 70(16)) label='  SF9'
    f10_s     in = (1B(16) 4F(16) 4F(16)) label='  SF10'
    f11_s     in = (1B(16) 4F(16) 61(16)) label='A1'
    f12_s     in = (1B(16) 4F(16) 62(16)) label='A2'
    f13_s     in = (1B(16) 4F(16) 63(16)) label='A3'
    f14_s     in = (1B(16) 4F(16) 64(16)) label='A4'
    f15_s     in = (1B(16) 4F(16) 65(16)) label='A5'
    f16_s     in = (1B(16) 4F(16) 56(16)) label='A6'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13  label='NEXT'
    back      in = (1B(16) 4F(16) 73(16)) label='f3'
    help      in = (1B(16) 4F(16) 74(16)) label='f4'
    undo      in = (1B(16) 4F(16) 75(16)) label='f5'
    stop      in = (1B(16) 4F(16) 76(16)) label='f6'
    undo_s    in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    stop_s    in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    down      in = ()
    down_s    in = ()
    up        in = ()
    up_s      in = ()

    fwd       in = (1B(16) 4F(16) 58(16)) label='FWD'
    fwd_s     in = (1B(16) 4F(16) 6F(16)) label='Shift-FWD'

    bkw       in = (1B(16) 4F(16) 57(16)) label='BKW'
    bkw_s     in = (1B(16) 4F(16) 66(16)) label='Shift-BKW'

    edit      in = ()
    edit_s    in = ()
    data      in = ()
    data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)
    protect_begin       out = ()
    protect_end         out = ()

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_inverse)
    error_end           out = (stop_inverse)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = invoke_graphics
    ld_fine_end              out = invoke_text
    ld_fine_horizontal       out = 71(16)
    ld_fine_vertical         out = 78(16)
    ld_fine_upper_left       out = 6C(16)
    ld_fine_upper_right      out = 6B(16)
    ld_fine_lower_left       out = 6D(16)
    ld_fine_lower_right      out = 6A(16)
    ld_fine_up_t             out = 77(16)
    ld_fine_down_t           out = 76(16)
    ld_fine_left_t           out = 74(16)
    ld_fine_right_t          out = 75(16)
    ld_fine_cross            out = 6E(16)
    ld_medium_begin          out = (invoke_graphics start_alternate)
    ld_medium_end            out = (invoke_text stop_alternate)
    ld_medium_horizontal     out = 71(16)
    ld_medium_vertical       out = 78(16)
    ld_medium_upper_left     out = 6C(16)
    ld_medium_upper_right    out = 6B(16)
    ld_medium_lower_left     out = 6D(16)
    ld_medium_lower_right    out = 6A(16)
    ld_medium_up_t           out = 77(16)
    ld_medium_down_t         out = 76(16)
    ld_medium_left_t         out = 74(16)
    ld_medium_right_t        out = 75(16)
    ld_medium_cross          out = 6E(16)
    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')


"   END OF TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT              "
*DECK DECK=CSM$PC_CONNECT_12 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT                      "

"       PC_CONNECT_12        VERSION 1.2                    JUNE 25, 1987     "

"     This terminal definition is provided by CDC with the autotab option     "
" enabled.  Autotabbing is the behavior of jumping the cursor to the next     "
" unprotected field when text has been entered completely filling the         "
" previous unprotected field, or when a left/right cursor motion is           "
" attempted into a protected location.  Enabling autotab will provide a       "
" convenience for most users, but inability to horizontally position thru     "
" protected areas can interfere with some usage of the Screen Design          "
" Facility if a form is built with a large number of fields.  The SDF user    "
" can usually work around this situation by moving the cursor to the          "
" desired column on an unprotected row, then moving the cursor vertically     "
" into the final position.  In extreme cases, the SDF user may need to        "
" contruct an alternate terminal definition that disables autotab.  To        "
" disable autotab, look for comments embedded within this definition,         "
" containing the string 'autotab', and reverse the position of double-quote   "
" marks to disable the default code and enable the alternate code.            "

"   VARIABLES                                                                 "
    prefix              = (1B(16) 5B(16))                     "esc ["
    clear_stay          = (prefix 32(16) 4A(16))              "2J"
    clear_all_tabs      = (prefix 33(16) 67(16))              "3g"
    set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))       "?3l"
  " set_to_24x132       = (prefix 3F(l6) 33(16) 68(16)) "     "?3h"
    enable_auto_wrap    = (prefix 3F(16) 37(16) 68(16))       "?7h"
    disable_auto_wrap   = (prefix 3F(16) 37(16) 6C(16))       "?7l"
    designate_graphics  = (1B(16) 29(16) 30(16))              "esc )0"
    invoke_graphics     = (0E(16))
    invoke_text         = (0F(16))
    enable_protect      = (prefix 3D(16) 31(16) 68(16))       "=1h"
    disable_protect     = (prefix 3D(16) 31(16) 6C(16))       "=1l"
    enable_insertion    = (prefix 34(16) 68(16))              "4h"
    disable_insertion   = (prefix 34(16) 6C(16))              "4l"
    enable_autotab      = (prefix 3D(16) 33(16) 68(16))       "=3h"
    disable_autotab     = (prefix 3D(16) 33(16) 6C(16))       "=3l"
    start_screenmode    = (prefix 3D(16) 35(16) 68(16))       "=5h"
    start_linemode      = (prefix 3D(16) 35(16) 6C(16))       "=5l"

    start_alternate     = (prefix 31(16) 6D(16))              "1m"
    start_blink         = (prefix 35(16) 6D(16))              "5m"
    start_inverse       = (prefix 37(16) 6D(16))              "7m"
    start_underline     = (prefix 34(16) 6D(16))              "4m"
    stop_alternate      = (prefix 6D(16))                     "m"
    stop_blink          = (prefix 6D(16))                     "m"
    stop_inverse        = (prefix 6D(16))                     "m"
    stop_underline      = (prefix 6D(16))                     "m"

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'PC_CONNECT_12'   " for autotab "
"   model_name          value = 'PC_CONNECT_12_SDF'   for no autotab "
    communications      type  = asynch
    application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix)
    cursor_pos_second        out   = (3B(16))
    cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (prefix 48(16))      label='Home'
    cursor_up                inout = (prefix 41(16))
    cursor_down              inout = (prefix 42(16))
    cursor_left              inout = (prefix 44(16))
    cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next  " for autotab "
"   move_past_right          type  = stop_next             for no autotab "
    move_past_left           type  = wrap_adjacent_next  " for autotab "
"   move_past_left           type  = stop_next             for no autotab "
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next  " for autotab "
"   char_past_right          type  = stop_next             for no autotab "
    char_past_left           type  = wrap_adjacent_next  " for autotab "
"   char_past_left           type  = stop_next             for no autotab "
    char_past_last_position  type  = wrap_adjacent_next  " for autotab "
"   char_past_last_position  type  = stop_next             for no autotab "

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 0
    has_hidden               value = FALSE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
    automatic_tabbing        value = TRUE   " for autotab "
"   automatic_tabbing        value = FALSE    for no autotab "

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80   out = (set_to_24x80)

"   SCREEN AND LINE MODE TRANSITION                                           "

    set_screen_mode out=(clear_all_tabs enable_auto_wrap ..      "for autotab "
     enable_autotab designate_graphics invoke_text ..            "    autotab "
     enable_protect start_screenmode)                            "    autotab "
"   set_screen_mode out=(clear_all_tabs enable_auto_wrap ..    for no autotab "
"    disable_autotab designate_graphics invoke_text                no autotab "
"    enable_protect start_screenmode)                              no autotab "

    set_line_mode       out = ( prefix '0p' clear_all_tabs disable_autotab ..
         start_linemode designate_graphics invoke_text  ..
         enable_auto_wrap disable_protect disable_insertion )


"   TERMINAL CAPABILITIES                                                     "

    backspace           in = (bs)
    delete_char         inout = (prefix 50(16))  label='Del'
    delete_line_stay    inout = (prefix 4D(16))  label='Alt-D'

    erase_end_of_line   inout = (prefix 'K')
    erase_line_stay     inout = (prefix 32(16) 'K')
    erase_end_of_field  inout = (prefix 'N')
    erase_field_stay    inout = (prefix '2N')
    erase_page_stay     inout = (clear_stay)

    insert_line_stay    inout = (prefix 4C(16))         label='Alt-I'
    insert_mode_begin   inout = (enable_insertion)      label='Ins'
    insert_mode_end     inout = (disable_insertion)     label='End'

    tab_backward        inout = (prefix 'Z')
    tab_forward         inout = (09(16))
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (1B(16) 48(16))

    protect_all         out = (prefix '1p')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (1B(16) 'V')
    protect_end         out = (1B(16) 'W')
    output_begin        out = (disable_protect disable_insertion)
    output_end          out = (enable_protect enable_autotab)
    bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (1B(16) 4F(16) 71(16)) label='f1'
    f2        in = (1B(16) 4F(16) 72(16)) label='f2'
    f3        in = (1B(16) 4F(16) 73(16)) label='f3'
    f4        in = (1B(16) 4F(16) 74(16)) label='f4'
    f5        in = (1B(16) 4F(16) 75(16)) label='f5'
    f6        in = (1B(16) 4F(16) 76(16)) label='f6'
    f7        in = (1B(16) 4F(16) 77(16)) label='f7'
    f8        in = (1B(16) 4F(16) 78(16)) label='f8'
    f9        in = (1B(16) 4F(16) 79(16)) label='f9'
    f10       in = (1B(16) 4F(16) 7A(16)) label='10'
    f11       in = (1B(16) 4F(16) 7B(16)) label='C1'
    f12       in = (1B(16) 4F(16) 7C(16)) label='C2'
    f13       in = (1B(16) 4F(16) 7D(16)) label='C3'
    f14       in = (1B(16) 4F(16) 7E(16)) label='C4'
    f15       in = (1B(16) 4F(16) 5F(16)) label='C5'
    f16       in = (1B(16) 4F(16) 55(16)) label='C6'
    f1_s      in = (1B(16) 4F(16) 50(16)) label='  SF1'
    f2_s      in = (1B(16) 4F(16) 51(16)) label='  SF2'
    f3_s      in = (1B(16) 4F(16) 52(16)) label='  SF3'
    f4_s      in = (1B(16) 4F(16) 53(16)) label='  SF4'
    f5_s      in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    f6_s      in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    f7_s      in = (1B(16) 4F(16) 4D(16)) label='  SF7'
    f8_s      in = (1B(16) 4F(16) 6E(16)) label='  SF8'
    f9_s      in = (1B(16) 4F(16) 70(16)) label='  SF9'
    f10_s     in = (1B(16) 4F(16) 4F(16)) label='  SF10'
    f11_s     in = (1B(16) 4F(16) 61(16)) label='A1'
    f12_s     in = (1B(16) 4F(16) 62(16)) label='A2'
    f13_s     in = (1B(16) 4F(16) 63(16)) label='A3'
    f14_s     in = (1B(16) 4F(16) 64(16)) label='A4'
    f15_s     in = (1B(16) 4F(16) 65(16)) label='A5'
    f16_s     in = (1B(16) 4F(16) 56(16)) label='A6'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13  label='NEXT'
    back      in = (1B(16) 4F(16) 73(16)) label='f3'
    help      in = (1B(16) 4F(16) 74(16)) label='f4'
    undo      in = (1B(16) 4F(16) 75(16)) label='f5'
    stop      in = (1B(16) 4F(16) 76(16)) label='f6'
    undo_s    in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    stop_s    in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    down      in = ()
    down_s    in = ()
    up        in = ()
    up_s      in = ()

    fwd       in = (1B(16) 4F(16) 58(16)) label='FWD'
    fwd_s     in = (1B(16) 4F(16) 6F(16)) label='Shift-FWD'

    bkw       in = (1B(16) 4F(16) 57(16)) label='BKW'
    bkw_s     in = (1B(16) 4F(16) 66(16)) label='Shift-BKW'

    edit      in = ()
    edit_s    in = ()
    data      in = ()
    data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_inverse)
    error_end           out = (stop_inverse)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = invoke_graphics
    ld_fine_end              out = invoke_text
    ld_fine_horizontal       out = 71(16)
    ld_fine_vertical         out = 78(16)
    ld_fine_upper_left       out = 6C(16)
    ld_fine_upper_right      out = 6B(16)
    ld_fine_lower_left       out = 6D(16)
    ld_fine_lower_right      out = 6A(16)
    ld_fine_up_t             out = 77(16)
    ld_fine_down_t           out = 76(16)
    ld_fine_left_t           out = 74(16)
    ld_fine_right_t          out = 75(16)
    ld_fine_cross            out = 6E(16)
    ld_medium_begin          out = (invoke_graphics start_alternate)
    ld_medium_end            out = (invoke_text stop_alternate)
    ld_medium_horizontal     out = 71(16)
    ld_medium_vertical       out = 78(16)
    ld_medium_upper_left     out = 6C(16)
    ld_medium_upper_right    out = 6B(16)
    ld_medium_lower_left     out = 6D(16)
    ld_medium_lower_right    out = 6A(16)
    ld_medium_up_t           out = 77(16)
    ld_medium_down_t         out = 76(16)
    ld_medium_left_t         out = 74(16)
    ld_medium_right_t        out = 75(16)
    ld_medium_cross          out = 6E(16)
    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')


"   END OF TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT              "

*DECK DECK=CSM$PC_CONNECT_13 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT                      "

"       PC_CONNECT_13        VERSION 1.3                    JUNE 25, 1987     "

"     This terminal definition is provided by CDC with the autotab option     "
" enabled.  Autotabbing is the behavior of jumping the cursor to the next     "
" unprotected field when text has been entered completely filling the         "
" previous unprotected field, or when a left/right cursor motion is           "
" attempted into a protected location.  Enabling autotab will provide a       "
" convenience for most users, but inability to horizontally position thru     "
" protected areas can interfere with some usage of the Screen Design          "
" Facility if a form is built with a large number of fields.  The SDF user    "
" can usually work around this situation by moving the cursor to the          "
" desired column on an unprotected row, then moving the cursor vertically     "
" into the final position.  In extreme cases, the SDF user may need to        "
" contruct an alternate terminal definition that disables autotab.  To        "
" disable autotab, look for comments embedded within this definition,         "
" containing the string 'autotab', and reverse the position of double-quote   "
" marks to disable the default code and enable the alternate code.            "

"   VARIABLES                                                                 "
    prefix              = (1B(16) 5B(16))                     "esc ["
    clear_stay          = (prefix 32(16) 4A(16))              "2J"
    clear_all_tabs      = (prefix 33(16) 67(16))              "3g"
    set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))       "?3l"
"   set_to_42x80        = (prefix '43;80x'            )                "
    set_to_24x132       = (prefix 3F(16) 33(16) 68(16))       "?3h"
"   set_to_43x132       = (prefix '44;132x'           )                "
    enable_auto_wrap    = (prefix 3F(16) 37(16) 68(16))       "?7h"
    disable_auto_wrap   = (prefix 3F(16) 37(16) 6C(16))       "?7l"
    designate_graphics  = (1B(16) 29(16) 30(16))              "esc )0"
    invoke_graphics     = (0E(16))
    invoke_text         = (0F(16))
    enable_protect      = (prefix 3D(16) 31(16) 68(16))       "=1h"
    disable_protect     = (prefix 3D(16) 31(16) 6C(16))       "=1l"
    enable_insertion    = (prefix 34(16) 68(16))              "4h"
    disable_insertion   = (prefix 34(16) 6C(16))              "4l"
    enable_autotab      = (prefix 3D(16) 33(16) 68(16))       "=3h"
    disable_autotab     = (prefix 3D(16) 33(16) 6C(16))       "=3l"
    start_screenmode    = (prefix 3D(16) 35(16) 68(16))       "=5h"
    start_linemode      = (prefix 3D(16) 35(16) 6C(16))       "=5l"

    start_alternate     = (prefix 31(16) 6D(16))              "1m"
    start_blink         = (prefix 35(16) 6D(16))              "5m"
    start_inverse       = (prefix 37(16) 6D(16))              "7m"
    start_underline     = (prefix 34(16) 6D(16))              "4m"
    stop_alternate      = (prefix 6D(16))                     "m"
    stop_blink          = (prefix 6D(16))                     "m"
    stop_inverse        = (prefix 6D(16))                     "m"
    stop_underline      = (prefix 6D(16))                     "m"

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'PC_CONNECT_13'   " for autotab "
"   model_name          value = 'PC_CONNECT_13_SDF'   for no autotab "
    communications      type  = asynch
    application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix)
    cursor_pos_second        out   = (3B(16))
    cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (prefix 48(16))      label='Home'
    cursor_up                inout = (prefix 41(16))
    cursor_down              inout = (prefix 42(16))
    cursor_left              inout = (prefix 44(16))
    cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next  " for autotab "
"   move_past_right          type  = stop_next             for no autotab "
    move_past_left           type  = wrap_adjacent_next  " for autotab "
"   move_past_left           type  = stop_next             for no autotab "
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next  " for autotab "
"   char_past_right          type  = stop_next             for no autotab "
    char_past_left           type  = wrap_adjacent_next  " for autotab "
"   char_past_left           type  = stop_next             for no autotab "
    char_past_last_position  type  = wrap_adjacent_next  " for autotab "
"   char_past_last_position  type  = stop_next             for no autotab "

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 0
    has_hidden               value = FALSE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
    automatic_tabbing        value = TRUE   " for autotab "
"   automatic_tabbing        value = FALSE    for no autotab "

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80   out = (set_to_24x80)
"   set_size       rows = 42 columns = 80   out = (set_to_42x80)       "
    set_size       rows = 24 columns = 132  out = (set_to_24x132)
"   set_size       rows = 43 columns = 132  out = (set_to_43x132)      "

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode out=(clear_all_tabs enable_auto_wrap ..      "for autotab "
     enable_autotab designate_graphics invoke_text ..            "    autotab "
     enable_protect start_screenmode)                            "    autotab "
"   set_screen_mode out=(clear_all_tabs enable_auto_wrap ..    for no autotab "
"    disable_autotab designate_graphics invoke_text                no autotab "
"    enable_protect start_screenmode)                              no autotab "

    set_line_mode       out = ( prefix '0p' clear_all_tabs disable_autotab ..
         start_linemode designate_graphics invoke_text  ..
         enable_auto_wrap disable_protect disable_insertion )


"   TERMINAL CAPABILITIES                                                     "

    backspace           in = (bs)
    delete_char         inout = (prefix 50(16))  label='Del'
    delete_line_stay    inout = (prefix 4D(16))  label='Alt-D'

    erase_end_of_line   inout = (prefix 'K')
    erase_line_stay     inout = (prefix 32(16) 'K')
    erase_end_of_field  inout = (prefix 'N')
    erase_field_stay    inout = (prefix '2N')
    erase_page_stay     inout = (clear_stay)

    insert_line_stay    inout = (prefix 4C(16))         label='Alt-I'
    insert_mode_begin   inout = (enable_insertion)      label='Ins'
    insert_mode_end     inout = (disable_insertion)     label='End'

    tab_backward        inout = (prefix 'Z')
    tab_forward         inout = (09(16))
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (1B(16) 48(16))

    protect_all         out = (prefix '1p')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (1B(16) 'V')
    protect_end         out = (1B(16) 'W')
    output_begin        out = (disable_protect disable_insertion)
    output_end          out = (enable_protect enable_autotab)
    bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (1B(16) 4F(16) 71(16)) label='f1'
    f2        in = (1B(16) 4F(16) 72(16)) label='f2'
    f3        in = (1B(16) 4F(16) 73(16)) label='f3'
    f4        in = (1B(16) 4F(16) 74(16)) label='f4'
    f5        in = (1B(16) 4F(16) 75(16)) label='f5'
    f6        in = (1B(16) 4F(16) 76(16)) label='f6'
    f7        in = (1B(16) 4F(16) 77(16)) label='f7'
    f8        in = (1B(16) 4F(16) 78(16)) label='f8'
    f9        in = (1B(16) 4F(16) 79(16)) label='f9'
    f10       in = (1B(16) 4F(16) 7A(16)) label='10'
    f11       in = (1B(16) 4F(16) 7B(16)) label='C1'
    f12       in = (1B(16) 4F(16) 7C(16)) label='C2'
    f13       in = (1B(16) 4F(16) 7D(16)) label='C3'
    f14       in = (1B(16) 4F(16) 7E(16)) label='C4'
    f15       in = (1B(16) 4F(16) 5F(16)) label='C5'
    f16       in = (1B(16) 4F(16) 55(16)) label='C6'
    f1_s      in = (1B(16) 4F(16) 50(16)) label='  SF1'
    f2_s      in = (1B(16) 4F(16) 51(16)) label='  SF2'
    f3_s      in = (1B(16) 4F(16) 52(16)) label='  SF3'
    f4_s      in = (1B(16) 4F(16) 53(16)) label='  SF4'
    f5_s      in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    f6_s      in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    f7_s      in = (1B(16) 4F(16) 4D(16)) label='  SF7'
    f8_s      in = (1B(16) 4F(16) 6E(16)) label='  SF8'
    f9_s      in = (1B(16) 4F(16) 70(16)) label='  SF9'
    f10_s     in = (1B(16) 4F(16) 4F(16)) label='  SF10'
    f11_s     in = (1B(16) 4F(16) 61(16)) label='A1'
    f12_s     in = (1B(16) 4F(16) 62(16)) label='A2'
    f13_s     in = (1B(16) 4F(16) 63(16)) label='A3'
    f14_s     in = (1B(16) 4F(16) 64(16)) label='A4'
    f15_s     in = (1B(16) 4F(16) 65(16)) label='A5'
    f16_s     in = (1B(16) 4F(16) 56(16)) label='A6'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13  label='NEXT'
    back      in = (1B(16) 4F(16) 73(16)) label='f3'
    help      in = (1B(16) 4F(16) 74(16)) label='f4'
    undo      in = (1B(16) 4F(16) 75(16)) label='f5'
    stop      in = (1B(16) 4F(16) 76(16)) label='f6'
    undo_s    in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    stop_s    in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    down      in = ()
    down_s    in = ()
    up        in = ()
    up_s      in = ()

    fwd       in = (1B(16) 4F(16) 58(16)) label='FWD'
    fwd_s     in = (1B(16) 4F(16) 6F(16)) label='Shift-FWD'

    bkw       in = (1B(16) 4F(16) 57(16)) label='BKW'
    bkw_s     in = (1B(16) 4F(16) 66(16)) label='Shift-BKW'

    edit      in = ()
    edit_s    in = ()
    data      in = ()
    data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_inverse)
    error_end           out = (stop_inverse)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = invoke_graphics
    ld_fine_end              out = invoke_text
    ld_fine_horizontal       out = 71(16)
    ld_fine_vertical         out = 78(16)
    ld_fine_upper_left       out = 6C(16)
    ld_fine_upper_right      out = 6B(16)
    ld_fine_lower_left       out = 6D(16)
    ld_fine_lower_right      out = 6A(16)
    ld_fine_up_t             out = 77(16)
    ld_fine_down_t           out = 76(16)
    ld_fine_left_t           out = 74(16)
    ld_fine_right_t          out = 75(16)
    ld_fine_cross            out = 6E(16)
    ld_medium_begin          out = (invoke_graphics start_alternate)
    ld_medium_end            out = (invoke_text stop_alternate)
    ld_medium_horizontal     out = 71(16)
    ld_medium_vertical       out = 78(16)
    ld_medium_upper_left     out = 6C(16)
    ld_medium_upper_right    out = 6B(16)
    ld_medium_lower_left     out = 6D(16)
    ld_medium_lower_right    out = 6A(16)
    ld_medium_up_t           out = 77(16)
    ld_medium_down_t         out = 76(16)
    ld_medium_left_t         out = 74(16)
    ld_medium_right_t        out = 75(16)
    ld_medium_cross          out = 6E(16)
    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')


"   END OF TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT              "


*DECK DECK=CSM$PC_CONNECT_20 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT                      "

"       PC_CONNECT_20        VERSION 2.0 (CONNECT VIEW)   OCTOBER 9, 1989     "
"                            (standard 24x80)

"     This terminal definition is provided by CDC with the autotab option     "
" enabled.  Autotabbing is the behavior of jumping the cursor to the next     "
" unprotected field when text has been entered completely filling the         "
" previous unprotected field, or when a left/right cursor motion is           "
" attempted into a protected location.  Enabling autotab will provide a       "
" convenience for most users, but inability to horizontally position thru     "
" protected areas can interfere with some usage of the Screen Design          "
" Facility if a form is built with a large number of fields.  The SDF user    "
" can usually work around this situation by moving the cursor to the          "
" desired column on an unprotected row, then moving the cursor vertically     "
" into the final position.  In extreme cases, the SDF user may need to        "
" contruct an alternate terminal definition that disables autotab.  To        "
" disable autotab, look for comments embedded within this definition,         "
" containing the string 'autotab', and reverse the position of double-quote   "
" marks to disable the default code and enable the alternate code.            "

"    This terminal definition has statements for a color monitor.  The color  "
" statements are given as comments. You may use a color monitor without using "
" these statements. One of the advantages of using the color statements is    "
" underlined fields (usually data entry fields) on forms will appear on the   "
" monitor.  Users of the Screen Design Facility (SDF) may find this helpful.  "
" To use the color statements, look for the string 'color monitor' and make   "
" the indicated changes.

"   VARIABLES                                                                 "
    prefix              = (1B(16) 5B(16))                     "esc ["

    mouse_cold = (prefix '2;1y' prefix '2;2y' ..
                  prefix '1yP(1,3)F(1)' prefix '0y'..
                  prefix '2;6y' ) "2;6 draggable, 2;7 point and shoot"

    clear_stay          = (prefix 32(16) 4A(16))              "2J"
    clear_all_tabs      = (prefix 33(16) 67(16))              "3g"
    set_to_24x80        = (prefix '?3l')
    enable_auto_wrap    = (prefix 3F(16) 37(16) 68(16))       "?7h"
    disable_auto_wrap   = (prefix 3F(16) 37(16) 6C(16))       "?7l"
    designate_graphics  = (1B(16) 29(16) 30(16))              "esc )0"
    invoke_graphics     = (0E(16))
    invoke_text         = (0F(16))
    home_cursor         = (prefix 48(16))
    enable_protect      = (prefix 3D(16) 31(16) 68(16))       "=1h"
    disable_protect     = (prefix 3D(16) 31(16) 6C(16))       "=1l"
    enable_insertion    = (prefix 34(16) 68(16))              "4h"
    disable_insertion   = (prefix 34(16) 6C(16))              "4l"
    enable_autotab      = (prefix 3D(16) 33(16) 68(16))       "=3h"
    disable_autotab     = (prefix 3D(16) 33(16) 6C(16))       "=3l"
    start_screenmode    = (prefix 3D(16) 35(16) 68(16))       "=5h"
    start_linemode      = (prefix 3D(16) 35(16) 6C(16))       "=5l"

    redo_set_line_mode  = ( prefix '0p' clear_all_tabs disable_autotab ..
         start_linemode designate_graphics invoke_text  ..
         enable_auto_wrap disable_protect disable_insertion mouse_cold)

"   ANSI foreground colors               "

    start_black          = (prefix '30m')
    start_red            = (prefix '31m')
    start_green          = (prefix '32m')
    start_yellow         = (prefix '33m')
    start_blue           = (prefix '34m')
    start_magenta        = (prefix '35m')
    start_cyan           = (prefix '36m')
    start_white          = (prefix '37m')

"   ANSI background colors "

    start_black_bg       = (prefix '40m')
    start_red_bg         = (prefix '41m')
    start_green_bg       = (prefix '42m')
    start_yellow_bg      = (prefix '43m')
    start_blue_bg        = (prefix '44m')
    start_magenta_bg     = (prefix '45m')
    start_cyan_bg        = (prefix '46m')
    start_white_bg       = (prefix '47m')


"   ANSI character attributes "

    clear_colors         = (prefix '0m')
    start_bold           = (prefix '1m')
    start_faint          = (prefix '2m')
    start_italic         = (prefix '3m')
    start_underscore     = (prefix '4m')
    start_blinking       = (prefix '5m')
    start_rapid_blink    = (prefix '6m')
    start_reverse_video  = (prefix '7m')
    start_concealed      = (prefix '8m')

" If using a non color monitor, remove quotes from following lines; otherwise quote lines.
    start_alternate     = (prefix 31(16) 6D(16))
    start_blink         = (prefix 35(16) 6D(16))
    start_inverse       = (prefix 37(16) 6D(16))
    start_underline     = (prefix 34(16) 6D(16))
    stop_alternate      = (prefix 6D(16))
    stop_blink          = (prefix 6D(16))
    stop_inverse        = (prefix 6D(16))
    stop_underline      = (prefix 6D(16))
" If end (This line must be quoted.)

" If using a color monitor, remove quotes from following lines; otherwise quote lines.
"   start_alternate      = (start_yellow start_bold)
"   start_blink          = (start_blinking)
"   start_inverse        = (start_reverse_video)
"   start_underline      = (start_blue_bg)
"   stop_alternate       = (clear_colors)
"   stop_blink           = (clear_colors)
"   stop_inverse         = (clear_colors)
"   stop_underline       = (clear_colors)
"   line_mode_color      = (clear_colors start_blue_bg start_cyan)
" If end (This line must be quoted.)

"   MODEL NAME
"   Select model name that suits your needs. Do not quote it. Quote all others.

    model_name          value = 'PC_CONNECT_20'          for autotab
"   model_name          value = 'PC_CONNECT_20_SDF'      for no autotab "
"   model_name          value = 'PC_CONNECT_20_COLOR'    for color monitor"

    communications      type  = asynch
    application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix)
    cursor_pos_begin         in    = (prefix '1;1H')  label='PC_SHELL'
    cursor_pos_second        out   = (3B(16))
    cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (prefix 48(16))      label='Home'
    cursor_up                inout = (prefix 41(16))
    cursor_down              inout = (prefix 42(16))
    cursor_left              inout = (prefix 44(16))
    cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next  " for autotab "
"   move_past_right          type  = stop_next             for no autotab "
    move_past_left           type  = wrap_adjacent_next  " for autotab "
"   move_past_left           type  = stop_next             for no autotab "
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next  " for autotab "
"   char_past_right          type  = stop_next             for no autotab "
    char_past_left           type  = wrap_adjacent_next  " for autotab "
"   char_past_left           type  = stop_next             for no autotab "
    char_past_last_position  type  = wrap_adjacent_next  " for autotab "
"   char_past_last_position  type  = stop_next             for no autotab "

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 0
    has_hidden               value = FALSE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
    automatic_tabbing        value = TRUE   " for autotab "
"   automatic_tabbing        value = FALSE    for no autotab "

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80   out = (set_to_24x80)

"   SCREEN AND LINE MODE TRANSITION                                           "

    set_screen_mode out=(clear_all_tabs enable_auto_wrap ..      "for autotab "
     enable_autotab designate_graphics invoke_text ..            "    autotab "
     enable_protect start_screenmode mouse_cold)                 "    autotab "

"   set_screen_mode out=(clear_all_tabs enable_auto_wrap ..    for no autotab "
"    disable_autotab designate_graphics invoke_text                no autotab "
"    enable_protect start_screenmode)                              no autotab "

" If using a non color monitor, remove quotes from following lines; otherwise quote lines.
    set_line_mode       out = ( prefix '0p' clear_all_tabs disable_autotab ..
         start_linemode designate_graphics invoke_text  ..
         enable_auto_wrap disable_protect disable_insertion mouse_cold ..
         stop_blink clear_stay home_cursor)
" If end (This line must be quoted.)


" If using a color monitor, remove quotes from following lines; otherwise quote lines.
"   set_line_mode       out = ( prefix '0p' clear_all_tabs disable_autotab ..
"        start_linemode designate_graphics invoke_text  ..
"        enable_auto_wrap disable_protect disable_insertion mouse_cold ..
"        line_mode_color clear_stay home_cursor)
" If end (This line must be quoted.)

    application_string name= 'REDO_SET_LINE_MODE' out=(redo_set_line_mode)

"   TERMINAL CAPABILITIES                                                     "

    backspace           in = (bs)
    delete_char         inout = (prefix 50(16))  label='Del'
    delete_line_stay    inout = (prefix 4D(16))  label='Alt-D'

    erase_end_of_line   inout = (prefix 'K')
    erase_line_stay     inout = (prefix 32(16) 'K')
    erase_end_of_field  inout = (prefix 'N')
    erase_field_stay    inout = (prefix '2N')
    erase_page_stay     inout = (clear_stay)

    insert_line_stay    inout = (prefix 4C(16))         label='Alt-I'
    insert_mode_begin   inout = (enable_insertion)      label='Ins'
    insert_mode_end     inout = (disable_insertion)     label='End'

    tab_backward        inout = (prefix 'Z')
    tab_forward         inout = (09(16))
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (1B(16) 48(16))

    protect_all         out = (prefix '1p')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (1B(16) 'V')
    protect_end         out = (1B(16) 'W')
    output_begin        out = (disable_protect disable_insertion)
    output_end          out = (enable_protect enable_autotab)
    bell_nak            out = (bel)

" COLOR DEFINITIONS.
" If using a color monitor, remove quotes from following lines; otherwise quote lines.
"   black_foreground    out = (start_black)
"   red_foreground      out = (start_red)
"   green_foreground    out = (start_green)
"   yellow_foreground   out = (start_yellow)
"   blue_foreground     out = (start_blue)
"   magenta_foreground  out = (start_magenta)
"   cyan_foreground     out = (start_cyan)
"   white_foreground    out = (start_white)
"   black_background    out = (start_black_bg)
"   red_background      out = (start_red_bg)
"   green_background    out = (start_green_bg)
"   yellow_background   out = (start_yellow_bg)
"   blue_background     out = (start_blue_bg)
"   magenta_background  out = (start_magenta_bg)
"   cyan_background     out = (start_cyan_bg)
"   white_background    out = (start_white_bg)
" If end (This line must be quoted.)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (1B(16) 4F(16) 71(16)) label='f1'
    f2        in = (1B(16) 4F(16) 72(16)) label='f2'
    f3        in = (1B(16) 4F(16) 73(16)) label='f3'
    f4        in = (1B(16) 4F(16) 74(16)) label='f4'
    f5        in = (1B(16) 4F(16) 75(16)) label='f5'
    f6        in = (1B(16) 4F(16) 76(16)) label='f6'
    f7        in = (1B(16) 4F(16) 77(16)) label='f7'
    f8        in = (1B(16) 4F(16) 78(16)) label='f8'
    f9        in = (1B(16) 4F(16) 79(16)) label='f9'
    f10       in = (1B(16) 4F(16) 7A(16)) label='10'
    f11       in = (1B(16) 4F(16) 7B(16)) label='C1'
    f12       in = (1B(16) 4F(16) 7C(16)) label='C2'
    f13       in = (1B(16) 4F(16) 7D(16)) label='C3'
    f14       in = (1B(16) 4F(16) 7E(16)) label='C4'
    f15       in = (1B(16) 4F(16) 5F(16)) label='C5'
    f16       in = (1B(16) 4F(16) 55(16)) label='C6'
    f1_s      in = (1B(16) 4F(16) 50(16)) label='  SF1'
    f2_s      in = (1B(16) 4F(16) 51(16)) label='  SF2'
    f3_s      in = (1B(16) 4F(16) 52(16)) label='  SF3'
    f4_s      in = (1B(16) 4F(16) 53(16)) label='  SF4'
    f5_s      in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    f6_s      in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    f7_s      in = (1B(16) 4F(16) 4D(16)) label='  SF7'
    f8_s      in = (1B(16) 4F(16) 6E(16)) label='  SF8'
    f9_s      in = (1B(16) 4F(16) 70(16)) label='  SF9'
    f10_s     in = (1B(16) 4F(16) 4F(16)) label='  SF10'
    f11_s     in = (1B(16) 4F(16) 61(16)) label='A1'
    f12_s     in = (1B(16) 4F(16) 62(16)) label='A2'
    f13_s     in = (1B(16) 4F(16) 63(16)) label='A3'
    f14_s     in = (1B(16) 4F(16) 64(16)) label='A4'
    f15_s     in = (1B(16) 4F(16) 65(16)) label='A5'
    f16_s     in = (1B(16) 4F(16) 56(16)) label='A6'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13  label='Enter'
    back      in = (1B(16) 4F(16) 73(16)) label='f3'
    help      in = (1B(16) 4F(16) 74(16)) label='f4'
    undo      in = (1B(16) 4F(16) 75(16)) label='f5'
    stop      in = (1B(16) 4F(16) 76(16)) label='f6'
    undo_s    in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    stop_s    in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    down      in = ()
    down_s    in = ()
    up        in = ()
    up_s      in = ()

    fwd       in = (1B(16) 4F(16) 58(16)) label='PgDn'
    fwd_s     in = (1B(16) 4F(16) 6F(16)) label='Ctrl-PgDn'

    bkw       in = (1B(16) 4F(16) 57(16)) label='PgUp'
    bkw_s     in = (1B(16) 4F(16) 66(16)) label='Ctrl-PgUp'

    edit      in = ()
    edit_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_inverse)
    error_end           out = (stop_inverse)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = invoke_graphics
    ld_fine_end              out = invoke_text
    ld_fine_horizontal       out = 71(16)
    ld_fine_vertical         out = 78(16)
    ld_fine_upper_left       out = 6C(16)
    ld_fine_upper_right      out = 6B(16)
    ld_fine_lower_left       out = 6D(16)
    ld_fine_lower_right      out = 6A(16)
    ld_fine_up_t             out = 77(16)
    ld_fine_down_t           out = 76(16)
    ld_fine_left_t           out = 74(16)
    ld_fine_right_t          out = 75(16)
    ld_fine_cross            out = 6E(16)
    ld_medium_begin          out = (invoke_graphics start_alternate)
    ld_medium_end            out = (invoke_text stop_alternate)
    ld_medium_horizontal     out = 71(16)
    ld_medium_vertical       out = 78(16)
    ld_medium_upper_left     out = 6C(16)
    ld_medium_upper_right    out = 6B(16)
    ld_medium_lower_left     out = 6D(16)
    ld_medium_lower_right    out = 6A(16)
    ld_medium_up_t           out = 77(16)
    ld_medium_down_t         out = 76(16)
    ld_medium_left_t         out = 74(16)
    ld_medium_right_t        out = 75(16)
    ld_medium_cross          out = 6E(16)
    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')


"   END OF TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT              "


*DECK DECK=CSM$PC_CONNECT_20_42 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT                      "

"       PC_CONNECT_20_42     VERSION 2.0 (CONNECT VIEW)   OCTOBER 9, 1989     "
"                            (42x80 and 24x80)

"     This terminal definition is provided by CDC with the autotab option     "
" enabled.  Autotabbing is the behavior of jumping the cursor to the next     "
" unprotected field when text has been entered completely filling the         "
" previous unprotected field, or when a left/right cursor motion is           "
" attempted into a protected location.  Enabling autotab will provide a       "
" convenience for most users, but inability to horizontally position thru     "
" protected areas can interfere with some usage of the Screen Design          "
" Facility if a form is built with a large number of fields.  The SDF user    "
" can usually work around this situation by moving the cursor to the          "
" desired column on an unprotected row, then moving the cursor vertically     "
" into the final position.  In extreme cases, the SDF user may need to        "
" contruct an alternate terminal definition that disables autotab.  To        "
" disable autotab, look for comments embedded within this definition,         "
" containing the string 'autotab', and reverse the position of double-quote   "
" marks to disable the default code and enable the alternate code.            "

"    This terminal definition has statements for a color monitor.  The color  "
" statements are given as comments. You may use a color monitor without using "
" these statements. One of the advantages of using the color statements is    "
" underlined fields (usually data entry fields) on forms will appear on the   "
" monitor.  Users of the Screen Design Facility (SDF) may find this helpful.  "
" To use the color statements, look for the string 'color monitor' and make   "
" the indicated changes.

"   VARIABLES                                                                 "
    prefix              = (1B(16) 5B(16))                     "esc ["

    mouse_cold = (prefix '2;1y' prefix '2;2y' ..
                  prefix '1yP(1,3)F(1)' prefix '0y'..
                  prefix '2;6y' ) "2;6 draggable, 2;7 point and shoot"

    clear_stay          = (prefix 32(16) 4A(16))              "2J"
    clear_all_tabs      = (prefix 33(16) 67(16))              "3g"
    set_to_24x80        = (prefix '?3l')
    set_to_42x80        = (prefix '43;80x')
    enable_auto_wrap    = (prefix 3F(16) 37(16) 68(16))       "?7h"
    disable_auto_wrap   = (prefix 3F(16) 37(16) 6C(16))       "?7l"
    designate_graphics  = (1B(16) 29(16) 30(16))              "esc )0"
    invoke_graphics     = (0E(16))
    invoke_text         = (0F(16))
    home_cursor         = (prefix 48(16))
    enable_protect      = (prefix 3D(16) 31(16) 68(16))       "=1h"
    disable_protect     = (prefix 3D(16) 31(16) 6C(16))       "=1l"
    enable_insertion    = (prefix 34(16) 68(16))              "4h"
    disable_insertion   = (prefix 34(16) 6C(16))              "4l"
    enable_autotab      = (prefix 3D(16) 33(16) 68(16))       "=3h"
    disable_autotab     = (prefix 3D(16) 33(16) 6C(16))       "=3l"
    start_screenmode    = (prefix 3D(16) 35(16) 68(16))       "=5h"
    start_linemode      = (prefix 3D(16) 35(16) 6C(16))       "=5l"

    redo_set_line_mode  = ( prefix '0p' clear_all_tabs disable_autotab ..
         start_linemode designate_graphics invoke_text  ..
         enable_auto_wrap disable_protect disable_insertion mouse_cold)

"   ANSI foreground colors

    start_black          = (prefix '30m')
    start_red            = (prefix '31m')
    start_green          = (prefix '32m')
    start_yellow         = (prefix '33m')
    start_blue           = (prefix '34m')
    start_magenta        = (prefix '35m')
    start_cyan           = (prefix '36m')
    start_white          = (prefix '37m')

"   ANSI background colors

    start_black_bg       = (prefix '40m')
    start_red_bg         = (prefix '41m')
    start_green_bg       = (prefix '42m')
    start_yellow_bg      = (prefix '43m')
    start_blue_bg        = (prefix '44m')
    start_magenta_bg     = (prefix '45m')
    start_cyan_bg        = (prefix '46m')
    start_white_bg       = (prefix '47m')

"   ANSI character attributes

    clear_colors         = (prefix '0m')
    start_bold           = (prefix '1m')
    start_faint          = (prefix '2m')
    start_italic         = (prefix '3m')
    start_underscore     = (prefix '4m')
    start_blinking       = (prefix '5m')
    start_rapid_blink    = (prefix '6m')
    start_reverse_video  = (prefix '7m')
    start_concealed      = (prefix '8m')

" If using a non color monitor, remove quotes from following lines; otherwise quote lines.
    start_alternate     = (prefix 31(16) 6D(16))
    start_blink         = (prefix 35(16) 6D(16))
    start_inverse       = (prefix 37(16) 6D(16))
    start_underline     = (prefix 34(16) 6D(16))
    stop_alternate      = (prefix 6D(16))
    stop_blink          = (prefix 6D(16))
    stop_inverse        = (prefix 6D(16))
    stop_underline      = (prefix 6D(16))
" If end (This line must be quoted.)

" If using a color monitor, remove quotes from following lines; otherwise quote lines.
"   start_alternate      = (start_yellow start_bold)
"   start_blink          = (start_blinking)
"   start_inverse        = (start_reverse_video)
"   start_underline      = (start_blue_bg)
"   stop_alternate       = (clear_colors)
"   stop_blink           = (clear_colors)
"   stop_inverse         = (clear_colors)
"   stop_underline       = (clear_colors)
"   line_mode_color      = (clear_colors start_blue_bg start_cyan)
" If end (This line must be quoted.)

"   MODEL NAME
"   Select model name that suits your needs. Do not quote it. Quote all others.

    model_name          value = 'PC_CONNECT_20_42'       for autotab
"   model_name          value = 'PC_CONNECT_20_42_SDF'   for no autotab "
"   model_name          value = 'PC_CONNECT_20_42_COLOR' for color monitor"

    communications      type  = asynch
    application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix)
    cursor_pos_begin         in    = (prefix '1;1H')  label='PC_SHELL'
    cursor_pos_second        out   = (3B(16))
    cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (prefix 48(16))      label='Home'
    cursor_up                inout = (prefix 41(16))
    cursor_down              inout = (prefix 42(16))
    cursor_left              inout = (prefix 44(16))
    cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next  " for autotab "
"   move_past_right          type  = stop_next             for no autotab "
    move_past_left           type  = wrap_adjacent_next  " for autotab "
"   move_past_left           type  = stop_next             for no autotab "
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next  " for autotab "
"   char_past_right          type  = stop_next             for no autotab "
    char_past_left           type  = wrap_adjacent_next  " for autotab "
"   char_past_left           type  = stop_next             for no autotab "
    char_past_last_position  type  = wrap_adjacent_next  " for autotab "
"   char_past_last_position  type  = stop_next             for no autotab "

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 0
    has_hidden               value = FALSE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
    automatic_tabbing        value = TRUE   " for autotab "
"   automatic_tabbing        value = FALSE    for no autotab "

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80   out = (set_to_24x80)
    set_size       rows = 42 columns = 80   out = (set_to_42x80)

"   SCREEN AND LINE MODE TRANSITION                                           "

    set_screen_mode out=(clear_all_tabs enable_auto_wrap ..      "for autotab "
     enable_autotab designate_graphics invoke_text ..            "    autotab "
     enable_protect start_screenmode mouse_cold)                 "    autotab "

"   set_screen_mode out=(clear_all_tabs enable_auto_wrap ..    for no autotab "
"    disable_autotab designate_graphics invoke_text                no autotab "
"    enable_protect start_screenmode)                              no autotab "

" If using a non color monitor, remove quotes from following lines; otherwise quote lines.
    set_line_mode       out = ( prefix '0p' clear_all_tabs disable_autotab ..
         start_linemode designate_graphics invoke_text  ..
         enable_auto_wrap disable_protect disable_insertion mouse_cold ..
         stop_blink clear_stay home_cursor)
" If end (This line must be quoted.)


" If using a color monitor, remove quotes from following lines; otherwise quote lines.
"   set_line_mode       out = ( prefix '0p' clear_all_tabs disable_autotab ..
"        start_linemode designate_graphics invoke_text  ..
"        enable_auto_wrap disable_protect disable_insertion mouse_cold ..
"        line_mode_color clear_stay home_cursor)
" If end (This line must be quoted.)

    application_string name= 'REDO_SET_LINE_MODE' out=(redo_set_line_mode)

"   TERMINAL CAPABILITIES                                                     "

    backspace           in = (bs)
    delete_char         inout = (prefix 50(16))  label='Del'
    delete_line_stay    inout = (prefix 4D(16))  label='Alt-D'

    erase_end_of_line   inout = (prefix 'K')
    erase_line_stay     inout = (prefix 32(16) 'K')
    erase_end_of_field  inout = (prefix 'N')
    erase_field_stay    inout = (prefix '2N')
    erase_page_stay     inout = (clear_stay)

    insert_line_stay    inout = (prefix 4C(16))         label='Alt-I'
    insert_mode_begin   inout = (enable_insertion)      label='Ins'
    insert_mode_end     inout = (disable_insertion)     label='End'

    tab_backward        inout = (prefix 'Z')
    tab_forward         inout = (09(16))
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (1B(16) 48(16))

    protect_all         out = (prefix '1p')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (1B(16) 'V')
    protect_end         out = (1B(16) 'W')
    output_begin        out = (disable_protect disable_insertion)
    output_end          out = (enable_protect enable_autotab)
    bell_nak            out = (bel)

" COLOR DEFINITIONS.
" If using a color monitor, remove quotes from following lines; otherwise quote lines.
"   black_foreground    out = (start_black)
"   red_foreground      out = (start_red)
"   green_foreground    out = (start_green)
"   yellow_foreground   out = (start_yellow)
"   blue_foreground     out = (start_blue)
"   magenta_foreground  out = (start_magenta)
"   cyan_foreground     out = (start_cyan)
"   white_foreground    out = (start_white)
"   black_background    out = (start_black_bg)
"   red_background      out = (start_red_bg)
"   green_background    out = (start_green_bg)
"   yellow_background   out = (start_yellow_bg)
"   blue_background     out = (start_blue_bg)
"   magenta_background  out = (start_magenta_bg)
"   cyan_background     out = (start_cyan_bg)
"   white_background    out = (start_white_bg)
" If end (This line must be quoted.)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (1B(16) 4F(16) 71(16)) label='f1'
    f2        in = (1B(16) 4F(16) 72(16)) label='f2'
    f3        in = (1B(16) 4F(16) 73(16)) label='f3'
    f4        in = (1B(16) 4F(16) 74(16)) label='f4'
    f5        in = (1B(16) 4F(16) 75(16)) label='f5'
    f6        in = (1B(16) 4F(16) 76(16)) label='f6'
    f7        in = (1B(16) 4F(16) 77(16)) label='f7'
    f8        in = (1B(16) 4F(16) 78(16)) label='f8'
    f9        in = (1B(16) 4F(16) 79(16)) label='f9'
    f10       in = (1B(16) 4F(16) 7A(16)) label='10'
    f11       in = (1B(16) 4F(16) 7B(16)) label='C1'
    f12       in = (1B(16) 4F(16) 7C(16)) label='C2'
    f13       in = (1B(16) 4F(16) 7D(16)) label='C3'
    f14       in = (1B(16) 4F(16) 7E(16)) label='C4'
    f15       in = (1B(16) 4F(16) 5F(16)) label='C5'
    f16       in = (1B(16) 4F(16) 55(16)) label='C6'
    f1_s      in = (1B(16) 4F(16) 50(16)) label='  SF1'
    f2_s      in = (1B(16) 4F(16) 51(16)) label='  SF2'
    f3_s      in = (1B(16) 4F(16) 52(16)) label='  SF3'
    f4_s      in = (1B(16) 4F(16) 53(16)) label='  SF4'
    f5_s      in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    f6_s      in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    f7_s      in = (1B(16) 4F(16) 4D(16)) label='  SF7'
    f8_s      in = (1B(16) 4F(16) 6E(16)) label='  SF8'
    f9_s      in = (1B(16) 4F(16) 70(16)) label='  SF9'
    f10_s     in = (1B(16) 4F(16) 4F(16)) label='  SF10'
    f11_s     in = (1B(16) 4F(16) 61(16)) label='A1'
    f12_s     in = (1B(16) 4F(16) 62(16)) label='A2'
    f13_s     in = (1B(16) 4F(16) 63(16)) label='A3'
    f14_s     in = (1B(16) 4F(16) 64(16)) label='A4'
    f15_s     in = (1B(16) 4F(16) 65(16)) label='A5'
    f16_s     in = (1B(16) 4F(16) 56(16)) label='A6'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13  label='Enter'
    back      in = (1B(16) 4F(16) 73(16)) label='f3'
    help      in = (1B(16) 4F(16) 74(16)) label='f4'
    undo      in = (1B(16) 4F(16) 75(16)) label='f5'
    stop      in = (1B(16) 4F(16) 76(16)) label='f6'
    undo_s    in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    stop_s    in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    down      in = ()
    down_s    in = ()
    up        in = ()
    up_s      in = ()

    fwd       in = (1B(16) 4F(16) 58(16)) label='PgDn'
    fwd_s     in = (1B(16) 4F(16) 6F(16)) label='Ctrl-PgDn'

    bkw       in = (1B(16) 4F(16) 57(16)) label='PgUp'
    bkw_s     in = (1B(16) 4F(16) 66(16)) label='Ctrl-PgUp'

    edit      in = ()
    edit_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_inverse)
    error_end           out = (stop_inverse)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = invoke_graphics
    ld_fine_end              out = invoke_text
    ld_fine_horizontal       out = 71(16)
    ld_fine_vertical         out = 78(16)
    ld_fine_upper_left       out = 6C(16)
    ld_fine_upper_right      out = 6B(16)
    ld_fine_lower_left       out = 6D(16)
    ld_fine_lower_right      out = 6A(16)
    ld_fine_up_t             out = 77(16)
    ld_fine_down_t           out = 76(16)
    ld_fine_left_t           out = 74(16)
    ld_fine_right_t          out = 75(16)
    ld_fine_cross            out = 6E(16)
    ld_medium_begin          out = (invoke_graphics start_alternate)
    ld_medium_end            out = (invoke_text stop_alternate)
    ld_medium_horizontal     out = 71(16)
    ld_medium_vertical       out = 78(16)
    ld_medium_upper_left     out = 6C(16)
    ld_medium_upper_right    out = 6B(16)
    ld_medium_lower_left     out = 6D(16)
    ld_medium_lower_right    out = 6A(16)
    ld_medium_up_t           out = 77(16)
    ld_medium_down_t         out = 76(16)
    ld_medium_left_t         out = 74(16)
    ld_medium_right_t        out = 75(16)
    ld_medium_cross          out = 6E(16)
    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')


"   END OF TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT              "
*DECK DECK=CSM$PC_CONNECT_20_42_132 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT                      "

"       PC_CONNECT_20_42_132 VERSION 2.0 (CONNECT VIEW)   OCTOBER 9, 1989     "
"                            (42x132, 42x80, 24x132 and 24x80)

"     This terminal definition is provided by CDC with the autotab option     "
" enabled.  Autotabbing is the behavior of jumping the cursor to the next     "
" unprotected field when text has been entered completely filling the         "
" previous unprotected field, or when a left/right cursor motion is           "
" attempted into a protected location.  Enabling autotab will provide a       "
" convenience for most users, but inability to horizontally position thru     "
" protected areas can interfere with some usage of the Screen Design          "
" Facility if a form is built with a large number of fields.  The SDF user    "
" can usually work around this situation by moving the cursor to the          "
" desired column on an unprotected row, then moving the cursor vertically     "
" into the final position.  In extreme cases, the SDF user may need to        "
" contruct an alternate terminal definition that disables autotab.  To        "
" disable autotab, look for comments embedded within this definition,         "
" containing the string 'autotab', and reverse the position of double-quote   "
" marks to disable the default code and enable the alternate code.            "

"    This terminal definition has statements for a color monitor.  The color  "
" statements are given as comments. You may use a color monitor without using "
" these statements. One of the advantages of using the color statements is    "
" underlined fields (usually data entry fields) on forms will appear on the   "
" monitor.  Users of the Screen Design Facility (SDF) may find this helpful.  "
" To use the color statements, look for the string 'color monitor' and make   "
" the indicated changes.

"   VARIABLES                                                                 "
    prefix              = (1B(16) 5B(16))                     "esc ["

    mouse_cold = (prefix '2;1y' prefix '2;2y' ..
                  prefix '1yP(1,3)F(1)' prefix '0y'..
                  prefix '2;6y' ) "2;6 draggable, 2;7 point and shoot"

    clear_stay          = (prefix 32(16) 4A(16))              "2J"
    clear_all_tabs      = (prefix 33(16) 67(16))              "3g"
    set_to_24x80        = (prefix '?3l')
    set_to_42x80        = (prefix '43;80x')
    set_to_24x132       = (prefix '?3h')
    set_to_42x132       = (prefix '43;132x')
    enable_auto_wrap    = (prefix 3F(16) 37(16) 68(16))       "?7h"
    disable_auto_wrap   = (prefix 3F(16) 37(16) 6C(16))       "?7l"
    designate_graphics  = (1B(16) 29(16) 30(16))              "esc )0"
    invoke_graphics     = (0E(16))
    invoke_text         = (0F(16))
    home_cursor         = (prefix 48(16))
    enable_protect      = (prefix 3D(16) 31(16) 68(16))       "=1h"
    disable_protect     = (prefix 3D(16) 31(16) 6C(16))       "=1l"
    enable_insertion    = (prefix 34(16) 68(16))              "4h"
    disable_insertion   = (prefix 34(16) 6C(16))              "4l"
    enable_autotab      = (prefix 3D(16) 33(16) 68(16))       "=3h"
    disable_autotab     = (prefix 3D(16) 33(16) 6C(16))       "=3l"
    start_screenmode    = (prefix 3D(16) 35(16) 68(16))       "=5h"
    start_linemode      = (prefix 3D(16) 35(16) 6C(16))       "=5l"

    redo_set_line_mode  = ( prefix '0p' clear_all_tabs disable_autotab ..
         start_linemode designate_graphics invoke_text  ..
         enable_auto_wrap disable_protect disable_insertion mouse_cold)


"   ANSI foreground colors

    start_black          = (prefix '30m')
    start_red            = (prefix '31m')
    start_green          = (prefix '32m')
    start_yellow         = (prefix '33m')
    start_blue           = (prefix '34m')
    start_magenta        = (prefix '35m')
    start_cyan           = (prefix '36m')
    start_white          = (prefix '37m')

"   ANSI background colors

    start_black_bg       = (prefix '40m')
    start_red_bg         = (prefix '41m')
    start_green_bg       = (prefix '42m')
    start_yellow_bg      = (prefix '43m')
    start_blue_bg        = (prefix '44m')
    start_magenta_bg     = (prefix '45m')
    start_cyan_bg        = (prefix '46m')
    start_white_bg       = (prefix '47m')

"   ANSI character attributes

    clear_colors         = (prefix '0m')
    start_bold           = (prefix '1m')
    start_faint          = (prefix '2m')
    start_italic         = (prefix '3m')
    start_underscore     = (prefix '4m')
    start_blinking       = (prefix '5m')
    start_rapid_blink    = (prefix '6m')
    start_reverse_video  = (prefix '7m')
    start_concealed      = (prefix '8m')

" If using a non color monitor, remove quotes from following lines; otherwise quote lines.
    start_alternate     = (prefix 31(16) 6D(16))
    start_blink         = (prefix 35(16) 6D(16))
    start_inverse       = (prefix 37(16) 6D(16))
    start_underline     = (prefix 34(16) 6D(16))
    stop_alternate      = (prefix 6D(16))
    stop_blink          = (prefix 6D(16))
    stop_inverse        = (prefix 6D(16))
    stop_underline      = (prefix 6D(16))
" If end (This line must be quoted.)

" If using a color monitor, remove quotes from following lines; otherwise quote lines.
"   start_alternate      = (start_yellow start_bold)
"   start_blink          = (start_blinking)
"   start_inverse        = (start_reverse_video)
"   start_underline      = (start_blue_bg)
"   stop_alternate       = (clear_colors)
"   stop_blink           = (clear_colors)
"   stop_inverse         = (clear_colors)
"   stop_underline       = (clear_colors)
"   line_mode_color      = (clear_colors start_blue_bg start_cyan)
" If end (This line must be quoted.)

"   MODEL NAME
"   Select model name that suits your needs. Do not quote it. Quote all others.                                         "
    model_name          value = 'PC_CONNECT_20_42_132'       "for autotab "
"   model_name          value = 'PC_CONNECT_20_42_132_SDF'   for no autotab "
"   model_name          value = 'PC_CONNECT_20_132_COLOR'    for color monitor"

    communications      type  = asynch
    application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix)
    cursor_pos_begin         in    = (prefix '1;1H')  label='PC_SHELL'
    cursor_pos_second        out   = (3B(16))
    cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (prefix 48(16))      label='Home'
    cursor_up                inout = (prefix 41(16))
    cursor_down              inout = (prefix 42(16))
    cursor_left              inout = (prefix 44(16))
    cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next  " for autotab "
"   move_past_right          type  = stop_next             for no autotab "
    move_past_left           type  = wrap_adjacent_next  " for autotab "
"   move_past_left           type  = stop_next             for no autotab "
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next  " for autotab "
"   char_past_right          type  = stop_next             for no autotab "
    char_past_left           type  = wrap_adjacent_next  " for autotab "
"   char_past_left           type  = stop_next             for no autotab "
    char_past_last_position  type  = wrap_adjacent_next  " for autotab "
"   char_past_last_position  type  = stop_next             for no autotab "

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 0
    has_hidden               value = FALSE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
    automatic_tabbing        value = TRUE   " for autotab "
"   automatic_tabbing        value = FALSE    for no autotab "

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80   out = (set_to_24x80)
    set_size       rows = 42 columns = 80   out = (set_to_42x80)
    set_size       rows = 24 columns = 132  out = (set_to_24x132)
    set_size       rows = 42 columns = 132  out = (set_to_42x132)

"   SCREEN AND LINE MODE TRANSITION                                           "

    set_screen_mode out=(clear_all_tabs enable_auto_wrap ..      "for autotab "
     enable_autotab designate_graphics invoke_text ..            "    autotab "
     enable_protect start_screenmode mouse_cold)                 "    autotab "

"   set_screen_mode out=(clear_all_tabs enable_auto_wrap ..    for no autotab "
"    disable_autotab designate_graphics invoke_text                no autotab "
"    enable_protect start_screenmode)                              no autotab "

" If using a non color monitor, remove quotes from following lines; otherwise quote lines.
    set_line_mode       out = ( prefix '0p' clear_all_tabs disable_autotab ..
         start_linemode designate_graphics invoke_text  ..
         enable_auto_wrap disable_protect disable_insertion mouse_cold ..
         stop_blink clear_stay home_cursor)
" If end (This line must be quoted.)


" If using a color monitor, remove quotes from following lines; otherwise quote lines.
"   set_line_mode       out = ( prefix '0p' clear_all_tabs disable_autotab ..
"        start_linemode designate_graphics invoke_text  ..
"        enable_auto_wrap disable_protect disable_insertion mouse_cold ..
"        line_mode_color clear_stay home_cursor)
" If end (This line must be quoted.)

    application_string name= 'REDO_SET_LINE_MODE' out=(redo_set_line_mode)

"   TERMINAL CAPABILITIES                                                     "

    backspace           in = (bs)
    delete_char         inout = (prefix 50(16))  label='Del'
    delete_line_stay    inout = (prefix 4D(16))  label='Alt-D'

    erase_end_of_line   inout = (prefix 'K')
    erase_line_stay     inout = (prefix 32(16) 'K')
    erase_end_of_field  inout = (prefix 'N')
    erase_field_stay    inout = (prefix '2N')
    erase_page_stay     inout = (clear_stay)

    insert_line_stay    inout = (prefix 4C(16))         label='Alt-I'
    insert_mode_begin   inout = (enable_insertion)      label='Ins'
    insert_mode_end     inout = (disable_insertion)     label='End'

    tab_backward        inout = (prefix 'Z')
    tab_forward         inout = (09(16))
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (1B(16) 48(16))

    protect_all         out = (prefix '1p')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (1B(16) 'V')
    protect_end         out = (1B(16) 'W')
    output_begin        out = (disable_protect disable_insertion)
    output_end          out = (enable_protect enable_autotab)
    bell_nak            out = (bel)

" COLOR DEFINITIONS.
" If using a color monitor, remove quotes from following lines; otherwise quote lines.
"   black_foreground    out = (start_black)
"   red_foreground      out = (start_red)
"   green_foreground    out = (start_green)
"   yellow_foreground   out = (start_yellow)
"   blue_foreground     out = (start_blue)
"   magenta_foreground  out = (start_magenta)
"   cyan_foreground     out = (start_cyan)
"   white_foreground    out = (start_white)
"   black_background    out = (start_black_bg)
"   red_background      out = (start_red_bg)
"   green_background    out = (start_green_bg)
"   yellow_background   out = (start_yellow_bg)
"   blue_background     out = (start_blue_bg)
"   magenta_background  out = (start_magenta_bg)
"   cyan_background     out = (start_cyan_bg)
"   white_background    out = (start_white_bg)
" If end (This line must be quoted.)


"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (1B(16) 4F(16) 71(16)) label='f1'
    f2        in = (1B(16) 4F(16) 72(16)) label='f2'
    f3        in = (1B(16) 4F(16) 73(16)) label='f3'
    f4        in = (1B(16) 4F(16) 74(16)) label='f4'
    f5        in = (1B(16) 4F(16) 75(16)) label='f5'
    f6        in = (1B(16) 4F(16) 76(16)) label='f6'
    f7        in = (1B(16) 4F(16) 77(16)) label='f7'
    f8        in = (1B(16) 4F(16) 78(16)) label='f8'
    f9        in = (1B(16) 4F(16) 79(16)) label='f9'
    f10       in = (1B(16) 4F(16) 7A(16)) label='10'
    f11       in = (1B(16) 4F(16) 7B(16)) label='C1'
    f12       in = (1B(16) 4F(16) 7C(16)) label='C2'
    f13       in = (1B(16) 4F(16) 7D(16)) label='C3'
    f14       in = (1B(16) 4F(16) 7E(16)) label='C4'
    f15       in = (1B(16) 4F(16) 5F(16)) label='C5'
    f16       in = (1B(16) 4F(16) 55(16)) label='C6'
    f1_s      in = (1B(16) 4F(16) 50(16)) label='  SF1'
    f2_s      in = (1B(16) 4F(16) 51(16)) label='  SF2'
    f3_s      in = (1B(16) 4F(16) 52(16)) label='  SF3'
    f4_s      in = (1B(16) 4F(16) 53(16)) label='  SF4'
    f5_s      in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    f6_s      in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    f7_s      in = (1B(16) 4F(16) 4D(16)) label='  SF7'
    f8_s      in = (1B(16) 4F(16) 6E(16)) label='  SF8'
    f9_s      in = (1B(16) 4F(16) 70(16)) label='  SF9'
    f10_s     in = (1B(16) 4F(16) 4F(16)) label='  SF10'
    f11_s     in = (1B(16) 4F(16) 61(16)) label='A1'
    f12_s     in = (1B(16) 4F(16) 62(16)) label='A2'
    f13_s     in = (1B(16) 4F(16) 63(16)) label='A3'
    f14_s     in = (1B(16) 4F(16) 64(16)) label='A4'
    f15_s     in = (1B(16) 4F(16) 65(16)) label='A5'
    f16_s     in = (1B(16) 4F(16) 56(16)) label='A6'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13  label='Enter'
    back      in = (1B(16) 4F(16) 73(16)) label='f3'
    help      in = (1B(16) 4F(16) 74(16)) label='f4'
    undo      in = (1B(16) 4F(16) 75(16)) label='f5'
    stop      in = (1B(16) 4F(16) 76(16)) label='f6'
    undo_s    in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    stop_s    in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    down      in = ()
    down_s    in = ()
    up        in = ()
    up_s      in = ()

    fwd       in = (1B(16) 4F(16) 58(16)) label='PgDn'
    fwd_s     in = (1B(16) 4F(16) 6F(16)) label='Ctrl-PgDn'

    bkw       in = (1B(16) 4F(16) 57(16)) label='PgUp'
    bkw_s     in = (1B(16) 4F(16) 66(16)) label='Ctrl-PgUp'

    edit      in = ()
    edit_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_inverse)
    error_end           out = (stop_inverse)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = invoke_graphics
    ld_fine_end              out = invoke_text
    ld_fine_horizontal       out = 71(16)
    ld_fine_vertical         out = 78(16)
    ld_fine_upper_left       out = 6C(16)
    ld_fine_upper_right      out = 6B(16)
    ld_fine_lower_left       out = 6D(16)
    ld_fine_lower_right      out = 6A(16)
    ld_fine_up_t             out = 77(16)
    ld_fine_down_t           out = 76(16)
    ld_fine_left_t           out = 74(16)
    ld_fine_right_t          out = 75(16)
    ld_fine_cross            out = 6E(16)
    ld_medium_begin          out = (invoke_graphics start_alternate)
    ld_medium_end            out = (invoke_text stop_alternate)
    ld_medium_horizontal     out = 71(16)
    ld_medium_vertical       out = 78(16)
    ld_medium_upper_left     out = 6C(16)
    ld_medium_upper_right    out = 6B(16)
    ld_medium_lower_left     out = 6D(16)
    ld_medium_lower_right    out = 6A(16)
    ld_medium_up_t           out = 77(16)
    ld_medium_down_t         out = 76(16)
    ld_medium_left_t         out = 74(16)
    ld_medium_right_t        out = 75(16)
    ld_medium_cross          out = 6E(16)
    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')


"   END OF TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT              "
*DECK DECK=CSM$PC_HOST_ECHO_13 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT                      "

"       PC_HOST_ECHO_13        VERSION 1.3                  MARCH, 1994       "

"     This terminal definition is provided by CDC with the autotab option     "
" enabled.  Autotabbing is the behavior of jumping the cursor to the next     "
" unprotected field when text has been entered completely filling the         "
" previous unprotected field, or when a left/right cursor motion is           "
" attempted into a protected location.  Enabling autotab will provide a       "
" convenience for most users, but inability to horizontally position thru     "
" protected areas can interfere with some usage of the Screen Design          "
" Facility if a form is built with a large number of fields.  The SDF user    "
" can usually work around this situation by moving the cursor to the          "
" desired column on an unprotected row, then moving the cursor vertically     "
" into the final position.  In extreme cases, the SDF user may need to        "
" contruct an alternate terminal definition that disables autotab.  To        "
" disable autotab, look for comments embedded within this definition,         "
" containing the string 'autotab', and reverse the position of double-quote   "
" marks to disable the default code and enable the alternate code.            "

"   VARIABLES                                                                 "
    prefix              = (1B(16) 5B(16))                     "esc ["
    clear_stay          = (prefix 32(16) 4A(16))              "2J"
    clear_all_tabs      = (prefix 33(16) 67(16))              "3g"
    set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))       "?3l"
"   set_to_42x80        = (prefix '43;80x'            )                "
    set_to_24x132       = (prefix 3F(16) 33(16) 68(16))       "?3h"
"   set_to_43x132       = (prefix '44;132x'           )                "
    enable_auto_wrap    = (prefix 3F(16) 37(16) 68(16))       "?7h"
    disable_auto_wrap   = (prefix 3F(16) 37(16) 6C(16))       "?7l"
    designate_graphics  = (1B(16) 29(16) 30(16))              "esc )0"
    invoke_graphics     = (0E(16))
    invoke_text         = (0F(16))
    enable_protect      = (prefix 3D(16) 31(16) 68(16))       "=1h"
    disable_protect     = (prefix 3D(16) 31(16) 6C(16))       "=1l"
    enable_insertion    = (prefix 34(16) 68(16))              "4h"
    disable_insertion   = (prefix 34(16) 6C(16))              "4l"
    enable_autotab      = (prefix 3D(16) 33(16) 68(16))       "=3h"
    disable_autotab     = (prefix 3D(16) 33(16) 6C(16))       "=3l"
    start_screenmode    = (prefix 3D(16) 35(16) 68(16))       "=5h"
    start_linemode      = (prefix 3D(16) 35(16) 6C(16))       "=5l"

    start_alternate     = (prefix 31(16) 6D(16))              "1m"
    start_blink         = (prefix 35(16) 6D(16))              "5m"
    start_inverse       = (prefix 37(16) 6D(16))              "7m"
    start_underline     = (prefix 34(16) 6D(16))              "4m"
    stop_alternate      = (prefix 6D(16))                     "m"
    stop_blink          = (prefix 6D(16))                     "m"
    stop_inverse        = (prefix 6D(16))                     "m"
    stop_underline      = (prefix 6D(16))                     "m"
    set_echo_on         = (ESC '[12l')
    set_echo_off        = (ESC '[12h')

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'PC_HOST_ECHO_13'   " for autotab "
"   model_name          value = 'PC_HOST_ECHO_13_SDF'   for no autotab "
    communications      type  = asynch
    application_string  name  = 'vt100_scrolling'  out = 'true'
    application_string  name  = 'DRIVER_PROCEDURE' out = 'tup$host_echo_pc_boot'
"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix)
    cursor_pos_second        out   = (3B(16))
    cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (prefix 48(16))      label='Home'
    cursor_up                inout = (prefix 41(16))
    cursor_down              inout = (prefix 42(16))
    cursor_left              inout = (prefix 44(16))
    cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next  " for autotab "
"   move_past_right          type  = stop_next             for no autotab "
    move_past_left           type  = wrap_adjacent_next  " for autotab "
"   move_past_left           type  = stop_next             for no autotab "
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next  " for autotab "
"   char_past_right          type  = stop_next             for no autotab "
    char_past_left           type  = wrap_adjacent_next  " for autotab "
"   char_past_left           type  = stop_next             for no autotab "
    char_past_last_position  type  = wrap_adjacent_next  " for autotab "
"   char_past_last_position  type  = stop_next             for no autotab "

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 0
    has_hidden               value = TRUE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
    automatic_tabbing        value = TRUE   " for autotab "
"   automatic_tabbing        value = FALSE    for no autotab "

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80   out = (set_to_24x80)
"   set_size       rows = 42 columns = 80   out = (set_to_42x80)       "
    set_size       rows = 24 columns = 132  out = (set_to_24x132)
"   set_size       rows = 43 columns = 132  out = (set_to_43x132)      "

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode out=(clear_all_tabs enable_auto_wrap ..      "for autotab "
     enable_autotab designate_graphics invoke_text ..            "    autotab "
     enable_protect  start_screenmode)                           "    autotab "
"   set_screen_mode out=(clear_all_tabs enable_auto_wrap ..    for no autotab "
"    disable_autotab designate_graphics invoke_text                no autotab "
"    enable_protect start_screenmode)                              no autotab "

    set_line_mode       out = ( prefix '0p' clear_all_tabs disable_autotab ..
         start_linemode designate_graphics invoke_text  ..
         enable_auto_wrap disable_protect disable_insertion )


"   TERMINAL CAPABILITIES                                                     "

    backspace           in = (bs)
    delete_char         inout = (prefix 50(16))  label='Del'
    delete_line_stay    inout = (prefix 4D(16))  label='Alt-D'

    erase_end_of_line   inout = (prefix 'K')
    erase_line_stay     inout = (prefix 32(16) 'K')
    erase_end_of_field  inout = (prefix 'N')
    erase_field_stay    inout = (prefix '2N')
    erase_page_stay     inout = (clear_stay)

    insert_line_stay    inout = (prefix 4C(16))         label='Alt-I'
    insert_mode_begin   inout = (enable_insertion)      label='Ins'
    insert_mode_end     inout = (disable_insertion)     label='End'

    tab_backward        inout = (prefix 'Z')
    tab_forward         inout = (09(16))
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (1B(16) 48(16))

    protect_all         out = (prefix '1p')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (1B(16) 'V')
    protect_end         out = (1B(16) 'W')
    output_begin        out = (disable_protect disable_insertion)
    output_end          out = (enable_protect enable_autotab)
    bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (1B(16) 4F(16) 71(16)) label='f1'
    f2        in = (1B(16) 4F(16) 72(16)) label='f2'
    f3        in = (1B(16) 4F(16) 73(16)) label='f3'
    f4        in = (1B(16) 4F(16) 74(16)) label='f4'
    f5        in = (1B(16) 4F(16) 75(16)) label='f5'
    f6        in = (1B(16) 4F(16) 76(16)) label='f6'
    f7        in = (1B(16) 4F(16) 77(16)) label='f7'
    f8        in = (1B(16) 4F(16) 78(16)) label='f8'
    f9        in = (1B(16) 4F(16) 79(16)) label='f9'
    f10       in = (1B(16) 4F(16) 7A(16)) label='10'
    f11       in = (1B(16) 4F(16) 7B(16)) label='C1'
    f12       in = (1B(16) 4F(16) 7C(16)) label='C2'
    f13       in = (1B(16) 4F(16) 7D(16)) label='C3'
    f14       in = (1B(16) 4F(16) 7E(16)) label='C4'
    f15       in = (1B(16) 4F(16) 5F(16)) label='C5'
    f16       in = (1B(16) 4F(16) 55(16)) label='C6'
    f1_s      in = (1B(16) 4F(16) 50(16)) label='  SF1'
    f2_s      in = (1B(16) 4F(16) 51(16)) label='  SF2'
    f3_s      in = (1B(16) 4F(16) 52(16)) label='  SF3'
    f4_s      in = (1B(16) 4F(16) 53(16)) label='  SF4'
    f5_s      in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    f6_s      in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    f7_s      in = (1B(16) 4F(16) 4D(16)) label='  SF7'
    f8_s      in = (1B(16) 4F(16) 6E(16)) label='  SF8'
    f9_s      in = (1B(16) 4F(16) 70(16)) label='  SF9'
    f10_s     in = (1B(16) 4F(16) 4F(16)) label='  SF10'
    f11_s     in = (1B(16) 4F(16) 61(16)) label='A1'
    f12_s     in = (1B(16) 4F(16) 62(16)) label='A2'
    f13_s     in = (1B(16) 4F(16) 63(16)) label='A3'
    f14_s     in = (1B(16) 4F(16) 64(16)) label='A4'
    f15_s     in = (1B(16) 4F(16) 65(16)) label='A5'
    f16_s     in = (1B(16) 4F(16) 56(16)) label='A6'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13  label='NEXT'
    back      in = (1B(16) 4F(16) 73(16)) label='f3'
    help      in = (1B(16) 4F(16) 74(16)) label='f4'
    undo      in = (1B(16) 4F(16) 75(16)) label='f5'
    stop      in = (1B(16) 4F(16) 76(16)) label='f6'
    undo_s    in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    stop_s    in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    down      in = ()
    down_s    in = ()
    up        in = ()
    up_s      in = ()

    fwd       in = (1B(16) 4F(16) 58(16)) label='FWD'
    fwd_s     in = (1B(16) 4F(16) 6F(16)) label='Shift-FWD'

    bkw       in = (1B(16) 4F(16) 57(16)) label='BKW'
    bkw_s     in = (1B(16) 4F(16) 66(16)) label='Shift-BKW'

    edit      in = ()
    edit_s    in = ()
    data      in = ()
    data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    hidden_begin        out = ()
    hidden_end          out = ()
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_inverse)
    error_end           out = (stop_inverse)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = invoke_graphics
    ld_fine_end              out = invoke_text
    ld_fine_horizontal       out = 71(16)
    ld_fine_vertical         out = 78(16)
    ld_fine_upper_left       out = 6C(16)
    ld_fine_upper_right      out = 6B(16)
    ld_fine_lower_left       out = 6D(16)
    ld_fine_lower_right      out = 6A(16)
    ld_fine_up_t             out = 77(16)
    ld_fine_down_t           out = 76(16)
    ld_fine_left_t           out = 74(16)
    ld_fine_right_t          out = 75(16)
    ld_fine_cross            out = 6E(16)
    ld_medium_begin          out = (invoke_graphics start_alternate)
    ld_medium_end            out = (invoke_text stop_alternate)
    ld_medium_horizontal     out = 71(16)
    ld_medium_vertical       out = 78(16)
    ld_medium_upper_left     out = 6C(16)
    ld_medium_upper_right    out = 6B(16)
    ld_medium_lower_left     out = 6D(16)
    ld_medium_lower_right    out = 6A(16)
    ld_medium_up_t           out = 77(16)
    ld_medium_down_t         out = 76(16)
    ld_medium_left_t         out = 74(16)
    ld_medium_right_t        out = 75(16)
    ld_medium_cross          out = 6E(16)
    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')


"   END OF TERMINAL DEFINITION FILE FOR PC_HOST_ECHO_13


*DECK DECK=CSM$PC_HOST_ECHO_20 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR IBM/PC WITH CDC CONNECT                      "

"       PC_HOST_ECHO_20     VERSION 2.0 (CONNECT VIEW)  MARCH, 1994           "
"                            (standard 24x80)

"     This terminal definition is provided by CDC with the autotab option     "
" enabled.  Autotabbing is the behavior of jumping the cursor to the next     "
" unprotected field when text has been entered completely filling the         "
" previous unprotected field, or when a left/right cursor motion is           "
" attempted into a protected location.  Enabling autotab will provide a       "
" convenience for most users, but inability to horizontally position thru     "
" protected areas can interfere with some usage of the Screen Design          "
" Facility if a form is built with a large number of fields.  The SDF user    "
" can usually work around this situation by moving the cursor to the          "
" desired column on an unprotected row, then moving the cursor vertically     "
" into the final position.  In extreme cases, the SDF user may need to        "
" contruct an alternate terminal definition that disables autotab.  To        "
" disable autotab, look for comments embedded within this definition,         "
" containing the string 'autotab', and reverse the position of double-quote   "
" marks to disable the default code and enable the alternate code.            "

"    This terminal definition has statements for a color monitor.  The color  "
" statements are given as comments. You may use a color monitor without using "
" these statements. One of the advantages of using the color statements is    "
" underlined fields (usually data entry fields) on forms will appear on the   "
" monitor.  Users of the Screen Design Facility (SDF) may find this helpful.  "
" To use the color statements, look for the string 'color monitor' and make   "
" the indicated changes.

"   VARIABLES                                                                 "
    prefix              = (1B(16) 5B(16))                     "esc ["

    mouse_cold = (prefix '2;1y' prefix '2;2y' ..
                  prefix '1yP(1,3)F(1)' prefix '0y'..
                  prefix '2;6y' ) "2;6 draggable, 2;7 point and shoot"

    clear_stay          = (prefix 32(16) 4A(16))              "2J"
    clear_all_tabs      = (prefix 33(16) 67(16))              "3g"
    set_to_24x80        = (prefix '?3l')
    enable_auto_wrap    = (prefix 3F(16) 37(16) 68(16))       "?7h"
    disable_auto_wrap   = (prefix 3F(16) 37(16) 6C(16))       "?7l"
    designate_graphics  = (1B(16) 29(16) 30(16))              "esc )0"
    invoke_graphics     = (0E(16))
    invoke_text         = (0F(16))
    home_cursor         = (prefix 48(16))
    enable_protect      = (prefix 3D(16) 31(16) 68(16))       "=1h"
    disable_protect     = (prefix 3D(16) 31(16) 6C(16))       "=1l"
    enable_insertion    = (prefix 34(16) 68(16))              "4h"
    disable_insertion   = (prefix 34(16) 6C(16))              "4l"
    enable_autotab      = (prefix 3D(16) 33(16) 68(16))       "=3h"
    disable_autotab     = (prefix 3D(16) 33(16) 6C(16))       "=3l"
    start_screenmode    = (prefix 3D(16) 35(16) 68(16))       "=5h"
    start_linemode      = (prefix 3D(16) 35(16) 6C(16))       "=5l"
    set_echo_on         = (ESC '[12l')
    set_echo_off        = (ESC '[12h')

    redo_set_line_mode  = ( prefix '0p' clear_all_tabs disable_autotab ..
         start_linemode designate_graphics invoke_text  ..
         enable_auto_wrap disable_protect disable_insertion mouse_cold)

"   ANSI foreground colors               "

    start_black          = (prefix '30m')
    start_red            = (prefix '31m')
    start_green          = (prefix '32m')
    start_yellow         = (prefix '33m')
    start_blue           = (prefix '34m')
    start_magenta        = (prefix '35m')
    start_cyan           = (prefix '36m')
    start_white          = (prefix '37m')

"   ANSI background colors "

    start_black_bg       = (prefix '40m')
    start_red_bg         = (prefix '41m')
    start_green_bg       = (prefix '42m')
    start_yellow_bg      = (prefix '43m')
    start_blue_bg        = (prefix '44m')
    start_magenta_bg     = (prefix '45m')
    start_cyan_bg        = (prefix '46m')
    start_white_bg       = (prefix '47m')


"   ANSI character attributes "

    clear_colors         = (prefix '0m')
    start_bold           = (prefix '1m')
    start_faint          = (prefix '2m')
    start_italic         = (prefix '3m')
    start_underscore     = (prefix '4m')
    start_blinking       = (prefix '5m')
    start_rapid_blink    = (prefix '6m')
    start_reverse_video  = (prefix '7m')
    start_concealed      = (prefix '8m')

" If using a non color monitor, remove quotes from following lines; otherwise quote lines.
    start_alternate     = (prefix 31(16) 6D(16))
    start_blink         = (prefix 35(16) 6D(16))
    start_inverse       = (prefix 37(16) 6D(16))
    start_underline     = (prefix 34(16) 6D(16))
    stop_alternate      = (prefix 6D(16))
    stop_blink          = (prefix 6D(16))
    stop_inverse        = (prefix 6D(16))
    stop_underline      = (prefix 6D(16))
" If end (This line must be quoted.)

" If using a color monitor, remove quotes from following lines; otherwise quote lines.
"   start_alternate      = (start_yellow start_bold)
"   start_blink          = (start_blinking)
"   start_inverse        = (start_reverse_video)
"   start_underline      = (start_blue_bg)
"   stop_alternate       = (clear_colors)
"   stop_blink           = (clear_colors)
"   stop_inverse         = (clear_colors)
"   stop_underline       = (clear_colors)
"   line_mode_color      = (clear_colors start_blue_bg start_cyan)
" If end (This line must be quoted.)

"   MODEL NAME
"   Select model name that suits your needs. Do not quote it. Quote all others.

    model_name          value = 'PC_HOST_ECHO_20'          for autotab
"   model_name          value = 'PC_HOST_ECHO_20_SDF'      for no autotab "
"   model_name          value = 'PC_HOST_ECHO_20_COLOR'    for color monitor"

    communications      type  = asynch
    application_string  name='DRIVER_PROCEDURE' out= 'tup$host_echo_pc_boot'
    application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix)
    cursor_pos_begin         in    = (prefix '1;1H')  label='PC_SHELL'
    cursor_pos_second        out   = (3B(16))
    cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (prefix 48(16))      label='Home'
    cursor_up                inout = (prefix 41(16))
    cursor_down              inout = (prefix 42(16))
    cursor_left              inout = (prefix 44(16))
    cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next  " for autotab "
"   move_past_right          type  = stop_next             for no autotab "
    move_past_left           type  = wrap_adjacent_next  " for autotab "
"   move_past_left           type  = stop_next             for no autotab "
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next  " for autotab "
"   char_past_right          type  = stop_next             for no autotab "
    char_past_left           type  = wrap_adjacent_next  " for autotab "
"   char_past_left           type  = stop_next             for no autotab "
    char_past_last_position  type  = wrap_adjacent_next  " for autotab "
"   char_past_last_position  type  = stop_next             for no autotab "

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 0
    has_hidden               value = FALSE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
    automatic_tabbing        value = TRUE   " for autotab "
"   automatic_tabbing        value = FALSE    for no autotab "

"   SCREEN SIZES                                                              "
    set_size       rows = 24 columns = 80   out = (set_to_24x80)

"   SCREEN AND LINE MODE TRANSITION                                           "

    set_screen_mode out=(clear_all_tabs enable_auto_wrap ..      "for autotab "
     enable_autotab designate_graphics invoke_text ..            "    autotab "
     enable_protect start_screenmode mouse_cold)                 "    autotab "

"   set_screen_mode out=(clear_all_tabs enable_auto_wrap ..    for no autotab "
"    disable_autotab designate_graphics invoke_text                no autotab "
"    enable_protect start_screenmode)                              no autotab "

" If using a non color monitor, remove quotes from following lines; otherwise quote lines.
    set_line_mode       out = ( prefix '0p' clear_all_tabs disable_autotab ..
         start_linemode designate_graphics invoke_text  ..
         enable_auto_wrap disable_protect disable_insertion mouse_cold ..
         stop_blink clear_stay home_cursor)
" If end (This line must be quoted.)


" If using a color monitor, remove quotes from following lines; otherwise quote lines.
"   set_line_mode       out = ( prefix '0p' clear_all_tabs disable_autotab ..
"        start_linemode designate_graphics invoke_text  ..
"        enable_auto_wrap disable_protect disable_insertion mouse_cold ..
"        line_mode_color clear_stay home_cursor)
" If end (This line must be quoted.)

    application_string name= 'REDO_SET_LINE_MODE' out=(redo_set_line_mode)

"   TERMINAL CAPABILITIES                                                     "

    backspace           in = (bs)
    delete_char         inout = (prefix 50(16))  label='Del'
    delete_line_stay    inout = (prefix 4D(16))  label='Alt-D'

    erase_end_of_line   inout = (prefix 'K')
    erase_line_stay     inout = (prefix 32(16) 'K')
    erase_end_of_field  inout = (prefix 'N')
    erase_field_stay    inout = (prefix '2N')
    erase_page_stay     inout = (clear_stay)

    insert_line_stay    inout = (prefix 4C(16))         label='Alt-I'
    insert_mode_begin   inout = (enable_insertion)      label='Ins'
    insert_mode_end     inout = (disable_insertion)     label='End'

    tab_backward        inout = (prefix 'Z')
    tab_forward         inout = (09(16))
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (1B(16) 48(16))

    protect_all         out = (prefix '1p')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (1B(16) 'V')
    protect_end         out = (1B(16) 'W')
    output_begin        out = (disable_protect disable_insertion)
    output_end          out = (enable_protect enable_autotab)
    bell_nak            out = (bel)

" COLOR DEFINITIONS.
" If using a color monitor, remove quotes from following lines; otherwise quote lines.
"   black_foreground    out = (start_black)
"   red_foreground      out = (start_red)
"   green_foreground    out = (start_green)
"   yellow_foreground   out = (start_yellow)
"   blue_foreground     out = (start_blue)
"   magenta_foreground  out = (start_magenta)
"   cyan_foreground     out = (start_cyan)
"   white_foreground    out = (start_white)
"   black_background    out = (start_black_bg)
"   red_background      out = (start_red_bg)
"   green_background    out = (start_green_bg)
"   yellow_background   out = (start_yellow_bg)
"   blue_background     out = (start_blue_bg)
"   magenta_background  out = (start_magenta_bg)
"   cyan_background     out = (start_cyan_bg)
"   white_background    out = (start_white_bg)
" If end (This line must be quoted.)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (1B(16) 4F(16) 71(16)) label='f1'
    f2        in = (1B(16) 4F(16) 72(16)) label='f2'
    f3        in = (1B(16) 4F(16) 73(16)) label='f3'
    f4        in = (1B(16) 4F(16) 74(16)) label='f4'
    f5        in = (1B(16) 4F(16) 75(16)) label='f5'
    f6        in = (1B(16) 4F(16) 76(16)) label='f6'
    f7        in = (1B(16) 4F(16) 77(16)) label='f7'
    f8        in = (1B(16) 4F(16) 78(16)) label='f8'
    f9        in = (1B(16) 4F(16) 79(16)) label='f9'
    f10       in = (1B(16) 4F(16) 7A(16)) label='10'
    f11       in = (1B(16) 4F(16) 7B(16)) label='C1'
    f12       in = (1B(16) 4F(16) 7C(16)) label='C2'
    f13       in = (1B(16) 4F(16) 7D(16)) label='C3'
    f14       in = (1B(16) 4F(16) 7E(16)) label='C4'
    f15       in = (1B(16) 4F(16) 5F(16)) label='C5'
    f16       in = (1B(16) 4F(16) 55(16)) label='C6'
    f1_s      in = (1B(16) 4F(16) 50(16)) label='  SF1'
    f2_s      in = (1B(16) 4F(16) 51(16)) label='  SF2'
    f3_s      in = (1B(16) 4F(16) 52(16)) label='  SF3'
    f4_s      in = (1B(16) 4F(16) 53(16)) label='  SF4'
    f5_s      in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    f6_s      in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    f7_s      in = (1B(16) 4F(16) 4D(16)) label='  SF7'
    f8_s      in = (1B(16) 4F(16) 6E(16)) label='  SF8'
    f9_s      in = (1B(16) 4F(16) 70(16)) label='  SF9'
    f10_s     in = (1B(16) 4F(16) 4F(16)) label='  SF10'
    f11_s     in = (1B(16) 4F(16) 61(16)) label='A1'
    f12_s     in = (1B(16) 4F(16) 62(16)) label='A2'
    f13_s     in = (1B(16) 4F(16) 63(16)) label='A3'
    f14_s     in = (1B(16) 4F(16) 64(16)) label='A4'
    f15_s     in = (1B(16) 4F(16) 65(16)) label='A5'
    f16_s     in = (1B(16) 4F(16) 56(16)) label='A6'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13  label='Enter'
    back      in = (1B(16) 4F(16) 73(16)) label='f3'
    help      in = (1B(16) 4F(16) 74(16)) label='f4'
    undo      in = (1B(16) 4F(16) 75(16)) label='f5'
    stop      in = (1B(16) 4F(16) 76(16)) label='f6'
    undo_s    in = (1B(16) 4F(16) 6D(16)) label='  SF5'
    stop_s    in = (1B(16) 4F(16) 6C(16)) label='  SF6'
    down      in = ()
    down_s    in = ()
    up        in = ()
    up_s      in = ()

    fwd       in = (1B(16) 4F(16) 58(16)) label='PgDn'
    fwd_s     in = (1B(16) 4F(16) 6F(16)) label='Ctrl-PgDn'

    bkw       in = (1B(16) 4F(16) 57(16)) label='PgUp'
    bkw_s     in = (1B(16) 4F(16) 66(16)) label='Ctrl-PgUp'

    edit      in = ()
    edit_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    hidden_begin        out = ()
    hidden_end          out = ()
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_inverse)
    error_end           out = (stop_inverse)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = invoke_graphics
    ld_fine_end              out = invoke_text
    ld_fine_horizontal       out = 71(16)
    ld_fine_vertical         out = 78(16)
    ld_fine_upper_left       out = 6C(16)
    ld_fine_upper_right      out = 6B(16)
    ld_fine_lower_left       out = 6D(16)
    ld_fine_lower_right      out = 6A(16)
    ld_fine_up_t             out = 77(16)
    ld_fine_down_t           out = 76(16)
    ld_fine_left_t           out = 74(16)
    ld_fine_right_t          out = 75(16)
    ld_fine_cross            out = 6E(16)
    ld_medium_begin          out = (invoke_graphics start_alternate)
    ld_medium_end            out = (invoke_text stop_alternate)
    ld_medium_horizontal     out = 71(16)
    ld_medium_vertical       out = 78(16)
    ld_medium_upper_left     out = 6C(16)
    ld_medium_upper_right    out = 6B(16)
    ld_medium_lower_left     out = 6D(16)
    ld_medium_lower_right    out = 6A(16)
    ld_medium_up_t           out = 77(16)
    ld_medium_down_t         out = 76(16)
    ld_medium_left_t         out = 74(16)
    ld_medium_right_t        out = 75(16)
    ld_medium_cross          out = 6E(16)
    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')


"   END OF TERMINAL DEFINITION FILE FOR PC_HOST_ECHO_20


*DECK DECK=CSM$SAMPLE EXPAND=TRUE
"                                                                              "
"   TERMINAL DEFINITION FILE FOR -------------- TERMINAL                       "
"                                                                              "
"        The Define_Terminal command (DEFT) allows user definition of most     "
"   character mode asynchronous type terminals for use with all NOS/VE         "
"   full screen products.  A detailed description of Define_Terminal can       "
"   be found in the Terminal Definition for NOS/VE Manual.                     "
"                                                                              "
"        There should be a collection of system defined terminal               "
"   definition files on file $SYSTEM.CYBIL.OSF$PROGRAM_INTERFACE that may      "
"   assist you (and perhaps already define your terminal or one that is        "
"   very similar to it).  The deck names and the terminals that they           "
"   define should include:                                                     "
"                                                                              "
"        CSM$SAMPLE          This template for definitions                     "
"        CSM$CDC_721         CDC 721 (Viking X)                                "
"        CSM$CDC_722         CDC 722                                           "
"        CSM$CDC_722_30      CDC 722_30                                        "
"        CSM$PC_CONNECT_10   IBM PC with version 1.0 CONNECT                   "
"        CSM$PC_CONNECT_11   IBM PC with version 1.1 CONNECT                   "
"        CSM$PC_CONNECT_12   IBM PC with version 1.2 CONNECT                   "
"        CSM$PC_CONNECT_13   IBM PC with version 1.3 CONNECT                   "
"        CSM$MAC_CONNECT_10  APPLE MACINTOSH with version 1.0 CONNECT          "
"        CSM$MAC_CONNECT_11  APPLE MACINTOSH with version 1.1 CONNECT          "
"        CSM$DEC_VT100       DEC VT100                                         "
"        CSM$DEC_VT100_GOLD  DEC VT100 with extra function key combinations    "
"        CSM$DEC_VT220       DEC VT220                                         "
"        CSM$ZEN_Z19         ZENITH Z19/HEATHKIT H19                           "
"        CSM$ZEN_Z29         ZENITH Z29/HEATHKIT H29                           "
"        CSM$IBM_3270        IBM 3270                                          "
"                                                                              "
"        Other definitions may also be present.                                "
"                                                                              "
"        Use the following commands to extract one of these decks into a       "
"   file (named MYFILE) you can manipulate:                                    "
"                                                                              "
"        SCU                                                                   "
"        USE_LIBRARY BASE=$SYSTEM.CYBIL.OSF$PROGRAM_INTERFACE RESULT=$NULL     "
"        EXTRACT_DECK DECK=CSM$name   SOURCE=MYFILE                            "
"        END WRITE_LIBRARY=NO                                                  "
"                                                                              "
"        Where "name" is the definition that most closely matches the terminal "
"   that you wish to define.  If you cannot identify one that is a close match "
"   then you can use this deck, CSM$SAMPLE, which contains all possible        "
"   statement with blanks to fill in.                                          "
"                                                                              "
"        The extracted file, MYFILE is the input file that you will fill with  "
"   the specific terminal dependent data that you should find in the           "
"   hardware reference manual for your terminal.  When the sequences,          "
"   capabilities and attributes of your terminal have been filled in you       "
"   will then compile your terminal definition by using the system command     "
"   Define_Terminal.  This will produce a file named TERMINAL_DEFINITIONS      "
"   which contains an encapsulated copy of the information needed by           "
"   NOS/VE screen formatting products to utilize your terminal.                "
"                                                                              "
"        A number of capabilities are required for your terminal to            "
"   function in screen mode.  These are a clear_page_stay or a                 "
"   clear_page_home, a cursor_home, and the ability to directly position       "
"   the cursor on the screen.  At least a subset (F1 - F16 or F1 - F8 plus     "
"   F1_S - F8_S) of the application keys should be defined. An                 "
"   erase_end_of_line capability is not required but will provide              "
"   considerably better performance for all full screen products.              "
"                                                                              "
"        Any line surrounded by quotation marks (such as this text) is a       "
"   comment line and will be ignored when compiling your terminal capsule.     "
"   This is a way in which you can add your own comments to this file as       "
"   you proceed to fill in the requested information.  Those lines that        "
"   are not surrounded by quotation marks in this file are the input           "
"   directives to Define_Terminal for which you will fill in the correct       "
"   values for your terminal.                                                  "
"                                                                              "
"        Define_Terminal allows you to define variables for commonly used      "
"   character strings and recognizes ASCII mnemonics (such as rs, ack).        "
"   Both your variables and the mnemonics can be used anywhere in this         "
"   file.                                                                      "
"                                                                              "
"        Here are some examples to assist you in your definitions:             "
"                                                                              "
"   VARIABLES                                                                  "
"                                                                              "
"   set_line_mode   = ()          Empty sequence.                              "
"   set_line_mode   = (rs ack)    ASCII mnemonics.                             "
"   set_line_mode   = (14(8))     (8) indicates an octal value.                "
"   set_line_mode   = (14(16))    (16) indicates a hexadecimal value.          "
"   set_line_mode   = (14)        Any nonsubscripted number is decimal.        "
"   blank_character = (' ')       Blank character (see line drawing).          "
"   start_underline = (rs '=')    ASCII Mnemonic and character.                "
"   stop_underline  = (rs '''')   Use of apostrophe.                           "
"                                                                              "
"        There are several basic types of statements that you will             "
"   encounter in this file:                                                    "
"                                                                              "
"   o    VALUE STATEMENTS                                                      "
"                                                                              "
"        terminal_model           value = 'myown'                              "
"        has_protect              value = TRUE                                 "
"        function_key_leaves_mark value = 0                                    "
"                                                                              "
"        Where VALUE is TRUE, FALSE, an alphabetic string or a number.         "
"                                                                              "
"   o    TYPE STATEMENTS                                                       "
"                                                                              "
"        cursor_pos_encoding      type  = ansi_cursor                          "
"        char_past_last_position  type  = wrap_adjacent_next                   "
"                                                                              "
"        Where TYPE is one of a predefined list of choices that will           "
"        be listed preceding the statement.                                    "
"                                                                              "
"   o    IN STATEMENTS                                                         "
"                                                                              "
"        f1                       in    = (rs 71(16))                          "
"        help                     in    = (rs 5C(16))                          "
"                                                                              "
"        Where IN is the sequence that comes upline from the terminal          "
"        when a specific function is performed or key is pressed.              "
"                                                                              "
"   o    OUT STATEMENTS                                                        "
"                                                                              "
"        cursor_pos_begin         out   = (stx)                                "
"        bell_nak                 out   = (bel)                                "
"                                                                              "
"        Where OUT is the sequence sent down line to the terminal to           "
"        perform a certain function.                                           "
"                                                                              "
"   o    INOUT STATEMENTS                                                      "
"                                                                              "
"        erase_page_home          inout = (ff)                                 "
"        tab_forward              inout = (ht)                                 "
"                                                                              "
"        Where INOUT is the identical sequence sent up and down line           "
"        for a certain function.                                               "
"                                                                              "
"        It should be noted that you may break any INOUT statement like        "
"                                                                              "
"        tab_forward              inout = (ht)                                 "
"                                                                              "
"        into a matched pair of statements like                                "
"                                                                              "
"        tab_forward              in    = (ht)                                 "
"        tab_forward              out   = (ht)                                 "
"                                                                              "
"        You will need to do this if your terminal sends a different           "
"        sequence downline to the terminal than is sent upline when a          "
"        particular function is performed.  If in our example                  "
"        your terminal recognized ht (from the host) as a signal               "
"        to perform a tab forward but sent vt (to the host) to indicate        "
"        that the tab forward key had been pressed then the single             "
"        tab_forward inout = () statement would be split into:                 "
"                                                                              "
"        tab_forward              in    = (vt)  [in from the terminal]         "
"        tab_forward              out   = (ht)  [out to the terminal]          "
"                                                                              "
"        Any statement that is IN or OUT only should be left as is.            "
"                                                                              "
"   TD COMPILER STATEMENT DESCRIPTIONS AND COMMENTS                            "
"                                                                              "
"        The file from this point on is arranged by functional groups and      "
"        contains comments for each directive that should assist you in        "
"        filling in the correct sequences for your terminal.                   "
"                                                                              "
"   TERMINAL MODEL AND COMMUNICATION TYPE                                      "
"                                                                              "
"        The terminal_model or model_name is a 1 to 25 character alphanumeric  "
"        name for your terminal.  Lower case letters are translated to upper   "
"        case.  The value specified here is the same name used on the SETTA or "
"        ACTS command.                                                         "
"                                                                              "
    terminal_model      value = 'XXXXXX'
"                                                                              "
"        Communication type is always specified as asynch, but is actually     "
"        disregarded as the network provides all necessary processing for      "
"        synchronous or asynchronous modes.                                    "
"                                                                              "
    communications      type  = asynch
"                                                                              "
"   INITIALIZE TERMINAL COMMAND                                                "
"                                                                              "
"        With this directive any SCL command may be executed during screen     "
"        mode activation.                                                      "
"                                                                              "
    initialize_terminal setta_command = 'any SCL command'
"                                                                              "
"   END OF INFORMATION SPECIFICATION                                           "
"                                                                              "
"        This directive is allowed for NOS compatibility but has no effect     "
"        with NOS/VE.                                                          "
"                                                                              "
    end_of_information  in    = (0)
"                                                                              "
"   CURSOR POSITIONING INFORMATION                                             "
"                                                                              "
"        The way in which your terminal encodes cursor positioning will        "
"        determine your choice for cursor_pos_encoding and                     "
"        cursor_pos_column_first.  The general format for cursor               "
"        positioning is:                                                       "
"                                                                              "
"        Let X    --------------> represent the column coordinate.             "
"        Let Y    --------------> represent the row coordinate.                "
"        Let a    --------------> represent cursor_pos_begin.                  "
"        Let b    --------------> represent cursor_pos_second.                 "
"        Let c    --------------> represent cursor_pos_third.                  "
"        And Bias --------------> is the integer value added to the            "
"                                 row or column for cursor positioning.        "
"                                 You should be able to find the value         "
"                                 for bias in the harware reference            "
"                                 manual for your terminal (often 20(16)).     "
"                                                                              "
"        Then cursor_pos_encoding will be one of four types:                   "
"                                                                              "
"             ansi_cursor   ----> Those terminals which are ansi standard      "
"                                 and use decimalized cursor coordinates.      "
"                                 Format is:                                   "
"                                      a (X + bias) b (Y + bias) c             "
"                                      a (Y + bias) b (X + bias) c             "
"                                 the order of X and Y for your terminal       "
"                                 determines the value for                     "
"                                 cursor_pos_column_first.                     "
"                                                                              "
"             cdc721_cursor ----> The Control Data 721 (Viking X) terminal.    "
"                                 Format is:                                   "
"                                      a   (X + bias)     (Y + bias)           "
"                                          (if X is less than 81)              "
"                                      a b (X + bias -80) (Y + bias)           "
"                                          (if X greater than 80)              "
"                                                                              "
"             binary_cursor ----> Those terminals which use direct co-         "
"                                 ordinate positioning.                        "
"                                 Format is:                                   "
"                                      a (X + bias) b (Y + bias) c             "
"                                      a (Y + bias) b (X + bias) c             "
"                                 the order of X and Y for your terminal       "
"                                 determines the value for                     "
"                                 cursor_pos_column_first.                     "
"                                                                              "
"             ibm3270_cursor ---> A specialized protocol for the 3270.         "
"                                                                              "
    cursor_pos_encoding      bias  = (0)    type = XXXX_cursor
"                                                                              "
"        Cursor_pos_column_first has a value of TRUE if your terminal          "
"        sends the X (or column) coordinate followed by the Y (or row)         "
"        coordinate and has a value of FALSE if the reverse is true.           "
"                                                                              "
    cursor_pos_column_first  value = TRUE
"                                                                              "
"        Cursor_pos_column_length and row_length apply only to ANSI type       "
"        cursor position (these are zero for both other types) and are         "
"        non-zero only if your terminal sends a fixed number of                "
"        decimalized bytes for the column and row coordinates (as opposed      "
"        to a variable number which is the usual case).                        "
"                                                                              "
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
"                                                                              "
"        Cursor_pos_begin, second and third are the sequences sent before      "
"        the first coordinate, in between coordinates and after the last       "
"        coordinate when positioning the cursor (a b and c in the formats      "
"        shown above).  At least a cursor_pos_begin should be supplied for     "
"        your terminal though second and third are often an empty sequence     "
"        and can be left alone.                                                "
"                                                                              "
    cursor_pos_begin         out   = (XXXX)
    cursor_pos_second        out   = ()
    cursor_pos_third         out   = ()
"                                                                              "
"   CURSOR MOVEMENT INFORMATION                                                "
"                                                                              "
"        Cursor_home, up, down, left and right are the sequences sent both     "
"        downline to the terminal to move the cursor to the home position      "
"        or a single column or row up, down, left, or right and upline         "
"        from the terminal when a cursor key is pressed.  Since this is        "
"        both an upline and downline sequence the INOUT keyword is used.       "
"                                                                              "
"        The Label parameter should be added to the cursor_home statement      "
"        if you are certain that the terminal really has a home key, or left   "
"        out if you are making a generic definition for several terminals of   "
"        which some might not actually have the key.  VT100 is an example of   "
"        a generic terminal for which the Home key may or may not be available."
"                                                                              "
    cursor_home              inout = ()  label='something if existence certain'"
    cursor_up                inout = ()
    cursor_down              inout = ()
    cursor_left              inout = ()
    cursor_right             inout = ()
"                                                                              "
"   CURSOR BEHAVIOR (for cursor movement keys)                                 "
"                                                                              "
"        Move_past_right, left, top and bottom describe what happens when      "
"        the cursor on your terminal is urged to move past the right,          "
"        left, top and bottom of the screen by a cursor movement key (not      "
"        by cursor movement caused by character input or a separate            "
"        backspace key your terminal may have in addition to a cursor left     "
"        key, these behaviors may be different from those for cursor           "
"        positioning keys and will be defined in the next section).  The       "
"        possible types are:                                                   "
"                                                                              "
"             wrap_adjacent_next ----> The cursor wraps to the other end       "
"                                      of the screen on the adjacent row       "
"                                      (next row cursor_right or previous      "
"                                      row for cursor_left)                    "
"             wrap_same_next     ----> The cursor wraps to the other           "
"                                      end of the screen still in the          "
"                                      same row or column.                     "
"             scroll_next        ----> The terminal scrolls.                   "
"             stop_next          ----> The cursor stops                        "
"             home_next          ----> The cursor homes.                       "
"                                                                              "
    move_past_right          type  = XXXX
    move_past_left           type  = XXXX
    move_past_top            type  = XXXX
    move_past_bottom         type  = XXXX
"                                                                              "
"   CURSOR BEHAVIOR (for character keys)                                       "
"                                                                              "
"        Char_past_right, left and last_postion describe what happens when     "
"        the cursor on your terminal is urged to move past the right, left     "
"        and end of the screen by character input or a separate backspace      "
"        key your terminal has in addition to (or in place of) a cursor        "
"        left key.  The possible behaviors are the same as those for           "
"        cursor positioning keys.                                              "
"                                                                              "
"             wrap_adjacent_next ----> The cursor wraps to the other end       "
"                                      of the screen on the adjacent row       "
"                                      (next row cursor_right or previous      "
"                                      row for cursor_left)                    "
"             wrap_same_next     ----> The cursor wraps to the other           "
"                                      end of the screen still in the          "
"                                      same row or column.                     "
"             scroll_next        ----> The terminal scrolls.                   "
"             stop_next          ----> The cursor stops                        "
"             home_next          ----> The cursor homes.                       "
"                                                                              "
    char_past_right          type  = XXXX
    char_past_left           type  = XXXX
    char_past_last_position  type  = XXXX
"                                                                              "
"   TERMINAL ATTRIBUTES                                                        "
"                                                                              "
"        These statements describe various attributes and capabilites of       "
"   your terminal that should be either TRUE or FALSE.                         "
"                                                                              "
"        Automatic_tabbing is TRUE if your terminal supports tabbing from      "
"        one completed filled unprotected input field to the next without      "
"        requiring that a tab key is pressed.                                  "
"                                                                              "
    automatic_tabbing        value = FALSE
"                                                                              "
"        Clears_when_change_size is TRUE if your terminal has more than        "
"        one screen size and changing screen sizes causes the screen to be     "
"        cleared.                                                              "
"                                                                              "
    clears_when_change_size  value = FALSE
"                                                                              "
"        Function_key_leaves_mark is non-zero if pressing a function key       "
"        on your terminal leaves a visible mark or character on the screen     "
"        or if function keys for your terminal will be supported by an         "
"        escape or control sequence that will require a character to           "
"        complete.  The full screen editor will then know to rewrite the       "
"        line on the screen that has been overwritten by the mark or           "
"        character(s).                                                         "
"                                                                              "
"        Note that the NOS/VE Define_Terminal command is incompatible with     "
"        the NOS TDU facility for this directive, as NOS uses TRUE/FALSE       "
"        boolean values for this directive rather than an integer count of     "
"        characters.                                                           "
"                                                                              "
    function_key_leaves_mark value = 0
"                                                                              "
"        Has_hidden is TRUE if your terminal supports a hidden attribute       "
"        that allows a field to be defined as input only such that typed       "
"        characters are not displayed on the screen.                           "
"                                                                              "
    has_hidden               value = FALSE
"                                                                              "
"        Has_protect is TRUE if the terminal hardware supports a protected     "
"        field attribute so that users can only enter data within              "
"        specified areas on the screen.                                        "
"                                                                              "
    has_protect              value = FALSE
"                                                                              "
"        Home_at_top is TRUE if the cursor goes to the top of the screen       "
"        when the home key is pressed or FALSE if it goes to the bottom.       "
"                                                                              "
    home_at_top              value = FALSE
"                                                                              "
"        Multiple_sizes is true if your terminal has more than one screen      "
"        size that can be set by a sequence sent downline to the terminal.     "
"                                                                              "
    multiple_sizes           value = FALSE
"                                                                              "
"        Tabs_to_home is TRUE if when tabbing forward from the last            "
"        unprotected field on the screen (or backward from the first) the      "
"        cursor moves to the home position and will move to the field when     "
"        the tab key is pressed again.  Set FALSE if your terminal can tab     "
"        directly from the last unprotected field to the first (and vice       "
"        versa) or if your terminal does not support a protect attribute.      "
"                                                                              "
    tabs_to_home             value = FALSE
"                                                                              "
"        Tabs_to_tab_stops is TRUE if your terminal supports hardware          "
"        tabbing to tab stops, FALSE otherwise.                                "
"                                                                              "
    tabs_to_tab_stops        value = FALSE
"                                                                              "
"        Tabs_to_unprotected is TRUE if your terminal supports tabbing         "
"        from one unprotected field to the next (or previous).  Set to         "
"        FALSE if the terminal does not support protect or protected           "
"        tabbing.                                                              "
"                                                                              "
    tabs_to_unprotected      value = FALSE
"                                                                              "
"        Programmable_tab_stops gives the number of programmable tab stops     "
"        your terminal has allowing an application to set as many as are       "
"        available.                                                            "
"                                                                              "
    programmable_tab_stops   number = 0
"                                                                              "
"        Fixed_tab_positions is given if your terminal has tab stops that      "
"        are fixed.  The tab stop positions are given as a list of integers.   "
"                                                                              "
    fixed_tab_positions      positions = ()
"                                                                              "
"        The type_ahead directive is provided for NOS compatibility, but       "
"        is always considered to be TRUE with NOS/VE.  Type ahead means        "
"        that you do not have to wait for the system response to each          "
"        carriage return (next key) but may continue to type.  Care should     "
"        be exercised not to abuse this capability since it is possible to     "
"        produce a screen that does not reflect the actual file contents.      "
"        If you fear this is the case do a clear page or an                    "
"        ACTIVATE_SCREEN command to tell FSE to repaint the screen.            "
"                                                                              "
    type_ahead               value = TRUE
"                                                                              "
"   SCREEN SIZES                                                               "
"                                                                              "
"        The set_size statement allows setting of the terminal screen          "
"        size by specifing the number of lines and columns in a screen.        "
"        Also, if a pick/locate device is available its name and accuracy      "
"        may be specified.  If a terminal has more than one screen size        "
"        specify them in ascending order (giving columns preference over       "
"        lines) by giving the appropriate parameters for each set_size         "
"        statement.  A maximum of four sizes and a minimum of one are to       "
"        be specified.                                                         "
"                                                                              "
"        Rows is the integer number of rows (lines) on the screen for          "
"        a specific screen size.                                               "
"                                                                              "
"        Columns is the integer number of columns (characters per line)        "
"        for a specified screen size.                                          "
"                                                                              "
"        Out is the sequence to be sent to the terminal to set the             "
"        screen size. If the terminal has only one size, then specify both     "
"        rows and columns, but omit the out = () parameter entirely.           "
"                                                                              "
"        The following parameters give the name and accuracy of the            "
"        pick/locate device. For example a terminal may have a touch panel     "
"        and be accurate within a space of 4 characters by 2 lines which is    "
"        within a range of certain character positions and lines.  The         "
"        horizontal accuracy and vertical accuracy are specified with one      "
"        of two parameters.  A parameter may give the starting, ending and     "
"        increment accuracy or if the accuracy position is not consistent      "
"        use the parameter giving the actual accuracy position.                "
"                                                                              "
"        Character_specification specifies the horizontal accuracy by          "
"        giving the starting character position, ending character position     "
"        and the number of characters to increment between the possible        "
"        character positions.                                                  "
"                                                                              "
"        Character_positions specifies each cursor character position          "
"        possible for a pick/locate operation.                                 "
"                                                                              "
"        Line_specification specifies the vertical accuracy by giving the      "
"        starting line position, ending line position and the number of        "
"        lines to increment between the possible line positions.               "
"                                                                              "
"        Line_positions specifies each cursor line position possible for       "
"        a pick/locate operation.                                              "
"                                                                              "
"        Device gives a character string which names the pick/locate           "
"        device.                                                               "
"                                                                              "
    set_size       rows = 30 columns = 80   out = ()  ..
             character_specification = () line_specification = () ..
             device = ''
"                                                                              "
"   SCREEN AND LINE MODE TRANSITION                                            "
"                                                                              "
"        Set_screen_mode is the sequence that will be sent when the            "
"        terminal enters the full screen editor or a screen formatting         "
"        application.  This is where page mode should be set, tabs             "
"        perhaps cleared and so on to configure for running is screen          "
"        mode.                                                                 "
"                                                                              "
    set_screen_mode     out = ()
"                                                                              "
"        Set_line_mode is the sequence that will be sent when the              "
"        terminal exits the full screen editor or a screen formatting          "
"        application.  This is where roll (or line) should be set and          "
"        what was done by the set_screen_mode sequence reversed.               "
"                                                                              "
    set_line_mode       out = ()
"                                                                              "
"        Screen_Init and Line_Init are used in the same manner as              "
"        Set_Screen_Mode and Set_Line_Mode.  However, Screen_Init and          "
"        Line_Init may be repeated as many time as needed, each occurrence     "
"        providing no more than 256 characters, to concatenate into a string   "
"        larger than 256 characters.  The Set_Screen_Mode and Set_Line_Mode    "
"        statements cannot be repeated to construct large string.              "
"                                                                              "
    screen_init         out = ()
"                                                                              "
    line_init           out = ()
"                                                                              "
"   TERMINAL CAPABILITIES                                                      "
"                                                                              "
"        These define what capabilities such as local insert and delete        "
"   line or character your terminal provides.                                  "
"                                                                              "
"        Backspace allows you to define a key that sends a different (from     "
"        the cursor left key) sequence upline from the terminal to move        "
"        the cursor one character position to the left.  This is of            "
"        particular use if the behavior for the backspace key (which will      "
"        be treated as a character movement key, not a cursor movement key     "
"        and hence is bound by the CHARACTER MOVEMENT BEHAVIOR                 "
"        descriptions) differs from the CURSOR MOVEMENT BEHAVIOR for the       "
"        cursor_left key (as described in the CURSOR MOVEMENT BEHAVIOR         "
"        section of this file).  This is an input only sequence so the IN      "
"        keyword is used here.                                                 "
"                                                                              "
    backspace           in    = ()
"                                                                              "
"        Delete_char is the sequence for local delete character for your       "
"        terminal.  In order for this to function correctly the key that       "
"        does the local (that is on the screen) delete character must send     "
"        a sequence upline to make the full screen product aware that the      "
"        screen has changed.  This is true for all terminal capabilities.      "
"                                                                              "
"        This statement allows an optional Label parameter.  If the label is   "
"        non-blank, this tells the system that you guarantee the key to        "
"        actually exist.  If you define the key without a label, then it will  "
"        be considered to be an optional key; if it is used then the system    "
"        will be able to recognize it, but in case it is not really available  "
"        the Editor will offer equivalent capability on one of the function    "
"        keys.  This is useful for definitions that will generically serve a   "
"        number of terminals that are similar but sometimes lack certain keys. "
"        The CDC-provided VT100 definition uses this technique.                "
"                                                                              "
    delete_char         inout = ()
"                                                                              "
"        Delete_line_bol and delete_line_stay are provided so that full        "
"        screen applications are aware of the cursor position after a          "
"        delete line function has been performed.  If your terminal has a      "
"        local delete line function then one (and only one) of                 "
"        delete_line_bol or delete_line_stay should be filled with the         "
"        correct terminal sequence.  Delete_line_bol if the cursor moves       "
"        to the leftmost position when a line is deleted, delete_line_stay     "
"        if the cursor stays in the column it was in when the delete line      "
"        function was performed.                                               "
"                                                                              "
"        This statement allows an optional Label parameter.  If the label is   "
"        non-blank, this tells the system that you guarantee the key to        "
"        actually exist.  If you define the key without a label, then it will  "
"        be considered to be an optional key; if it is used then the system    "
"        will be able to recognize it, but in case it is not really available  "
"        the Editor will offer equivalent capability on one of the function    "
"        keys.  This is useful for definitions that will generically serve a   "
"        number of terminals that are similar but sometimes lack certain keys. "
"        The CDC-provided VT100 definition uses this technique.                "
"                                                                              "
    delete_line_bol     inout = ()
    delete_line_stay    inout = ()
"                                                                              "
"        Erase_char is the sequence for an erase character function.           "
"                                                                              "
    erase_char          inout = ()
"                                                                              "
"        Erase_end_of_line is the sequence for an erase from the current       "
"        cursor position to the end of that line.  This is not a required      "
"        terminal capability but will provide much better performance for      "
"        all full screen products.                                             "
"                                                                              "
"        This statement allows an optional Label parameter.  If the label is   "
"        non-blank, this tells the system that you guarantee the key to        "
"        actually exist.  If you define the key without a label, then it will  "
"        be considered to be an optional key; if it is used then the system    "
"        will be able to recognize it, but in case it is not really available  "
"        the Editor will offer equivalent capability on one of the function    "
"        keys.  This is useful for definitions that will generically serve a   "
"        number of terminals that are similar but sometimes lack certain keys. "
"        The CDC-provided VT100 definition uses this technique.                "
"                                                                              "
    erase_end_of_line   inout = ()
"                                                                              "
"        Erase_field_bof is reserved for future use.                           "
"                                                                              "
    erase_field_bof     inout = ()
"                                                                              "
"        Erase_field_stay is reserved for future use.                          "
"                                                                              "
    erase_field_stay    inout = ()
"                                                                              "
"        Erase_line_bol and erase_line_stay are provided so that full          "
"        screen applications are aware of the cursor position after a          "
"        erase line function has been performed.  If your terminal has a       "
"        local erase line function then one (and only one) of                  "
"        erase_line_bol or erase_line_stay should be filled with the           "
"        correct terminal sequence.  Erase_line_bol if the cursor moves to     "
"        the leftmost position when a line is erased, erase_line_stay if       "
"        the cursor stays in the column it was in when the erase line          "
"        function was performed.                                               "
"                                                                              "
    erase_line_bol      inout = ()
    erase_line_stay     inout = ()
"                                                                              "
"        Erase_page_home and erase_page_stay are provided so that full         "
"        screen applications are aware of the cursor position after an         "
"        erase page function has been performed.  If your terminal has a       "
"        local erase page function (that sends a a sequence upline) then       "
"        one (and only one) of erase_page_home or erase_page_stay should       "
"        be filled with the correct terminal sequence.  Erase_page_home if     "
"        the cursor moves to the home position when the screen is cleared,     "
"        erase_page_stay if the cursor stays where it was when the erase       "
"        page function was performed.                                          "
"                                                                              "
"        This statement allows an optional Label parameter.  If the label is   "
"        non-blank, this tells the system that you guarantee the key to        "
"        actually exist.  If you define the key without a label, then it will  "
"        be considered to be an optional key; if it is used then the system    "
"        will be able to recognize it, but in case it is not really available  "
"        the Editor will offer equivalent capability on one of the function    "
"        keys.  This is useful for definitions that will generically serve a   "
"        number of terminals that are similar but sometimes lack certain keys. "
"        The CDC-provided VT100 definition uses this technique.                "
"                                                                              "
    erase_page_home     inout = ()
    erase_page_stay     inout = ()
"                                                                              "
"        Insert_char is the sequence for local insert character for your       "
"        terminal.  In order for this to function correctly the key that       "
"        does the local (that is on the screen) insert character must send     "
"        a sequence upline to make the full screen product aware that the      "
"        screen has changed.  This is true for all terminal capabilities.      "
"                                                                              "
"        This statement allows an optional Label parameter.  If the label is   "
"        non-blank, this tells the system that you guarantee the key to        "
"        actually exist.  If you define the key without a label, then it will  "
"        be considered to be an optional key; if it is used then the system    "
"        will be able to recognize it, but in case it is not really available  "
"        the Editor will offer equivalent capability on one of the function    "
"        keys.  This is useful for definitions that will generically serve a   "
"        number of terminals that are similar but sometimes lack certain keys. "
"        The CDC-provided VT100 definition uses this technique.                "
"                                                                              "
    insert_char         inout = ()
"                                                                              "
"        Insert_line_bol and insert_line_stay are provided so that full        "
"        screen applications are aware of the cursor position after a          "
"        insert line function has been performed.  If your terminal has a      "
"        local insert line function (that sends a a sequence upline) then      "
"        one (and only one) of insert_line_bol or insert_line_stay should      "
"        be filled with the correct terminal sequence.  Insert_line_bol if     "
"        the cursor moves to the leftmost position when a line is              "
"        inserted, insert_line_stay if the cursor stays in the column it       "
"        was in when the insert line function was performed.                   "
"                                                                              "
"        This statement allows an optional Label parameter.  If the label is   "
"        non-blank, this tells the system that you guarantee the key to        "
"        actually exist.  If you define the key without a label, then it will  "
"        be considered to be an optional key; if it is used then the system    "
"        will be able to recognize it, but in case it is not really available  "
"        the Editor will offer equivalent capability on one of the function    "
"        keys.  This is useful for definitions that will generically serve a   "
"        number of terminals that are similar but sometimes lack certain keys. "
"        The CDC-provided VT100 definition uses this technique.                "
"                                                                              "
    insert_line_bol     inout = ()
    insert_line_stay    inout = ()
"                                                                              "
"        Erase_unprotected is reserved for future use.                         "
"                                                                              "
    erase_unprotected   inout = ()
"                                                                              "
"        Erase_end_of_page is reserved for future use.                         "
"                                                                              "
    erase_end_of_page   inout = ()
"                                                                              "
"        Erase_end_of_field is reserved for future use.                        "
"                                                                              "
    erase_end_of_field  inout = ()
"                                                                              "
"        Insert_mode_begin is the sequence to enter insert mode.               "
"        Characters are inserted, shifting other characters right rather       "
"        than overstriking them.                                               "
"                                                                              "
"        This statement allows an optional Label parameter.  If the label is   "
"        non-blank, this tells the system that you guarantee the key to        "
"        actually exist.  If you define the key without a label, then it will  "
"        be considered to be an optional key; if it is used then the system    "
"        will be able to recognize it, but in case it is not really available  "
"        the Editor will offer equivalent capability on one of the function    "
"        keys.  This is useful for definitions that will generically serve a   "
"        number of terminals that are similar but sometimes lack certain keys. "
"        The CDC-provided VT100 definition uses this technique.                "
"                                                                              "
    insert_mode_begin   inout = ()
"                                                                              "
"        Insert_mode_end is the sequence to exit insert mode.  Characters      "
"        will now overstrike rather than insert.                               "
"                                                                              "
    insert_mode_end     inout = ()
"                                                                              "
"        Insert_mode_toggle will switch between insert and overstike mode.     "
"        Note that if your terminal allows insert_mode_begin, then             "
"        insert_mode_end will be required.                                     "
"                                                                              "
    insert_mode_toggle  inout = ()
"                                                                              "
"        Tab_backward is the sequence sent (and received) when tabbing         "
"        from a tab stop or unprotected field to the previous tab stop or      "
"        unprotected field.                                                    "
"                                                                              "
    tab_backward        inout = ()
"                                                                              "
"        Tab_clear is the sequence to clear the tab stop at the current        "
"        cursor position.                                                      "
"                                                                              "
    tab_clear           inout = ()
"                                                                              "
"        Tab_clear_all is the sequence to clear all tab stops.                 "
"                                                                              "
    tab_clear_all       inout = ()
"                                                                              "
"        Tab_forward is the sequence sent (and received) when tabbing from     "
"        a tab stop or unprotected field to the next tab stop or               "
"        unprotected field.                                                    "
"                                                                              "
    tab_forward         inout = ()
"                                                                              "
"        Tab_set is the sequence to set a tab stop at the current cursor       "
"        position.                                                             "
"                                                                              "
    tab_set             inout = ()
"                                                                              "
"   MISCELLANEOUS TERMINAL SEQUENCES                                           "
"                                                                              "
"        Bell_nak is the sequence to ring the bell on your terminal.           "
"                                                                              "
    bell_nak            out = ()
"                                                                              "
"        Bell_ack is reserved for future use.                                  "
"                                                                              "
    bell_ack            out = ()
"                                                                              "
"        Display_begin is reserved for future use.                             "
"                                                                              "
    display_begin       out = ()
"                                                                              "
"        Display_end is reserved for future use.                               "
"                                                                              "
    display_end         out = ()
"                                                                              "
"        Field_scroll_down is reserved for future use.                         "
"                                                                              "
    field_scroll_down   out = ()
"                                                                              "
"        Field_scroll_set is reserved for future use.                          "
"                                                                              "
    field_scroll_set    out = ()
"                                                                              "
"        Field_scroll_up is reserved for future use.                           "
"                                                                              "
    field_scroll_up     out = ()
"                                                                              "
"        Output_begin is the sequence that will be sent before each stream     "
"        of output is sent downline to the terminal.  This should include      "
"        the sequence to disable protect if the terminal supports protection.  "
"                                                                              "
"        Note that with the NOS TDU facility, if your terminal provides        "
"        insert_mode_begin, then it is effectively mandatory to duplicate      "
"        the insert_mode_end sequence as output_begin.  The NOS/VE             "
"        Define_Terminal capability does not impose this requirement - it      "
"        will automatically use the the insert_mode_end sequence without       "
"        any explicit action on your part to duplicate it as output_begin,     "
"        and will correctly function if you continue the NOS technique.        "
"        But for best performance, it is advised that NOS/VE terminal          "
"        definitions should not duplicate insert_mode_end within               "
"        output_begin.                                                         "
"                                                                              "
    output_begin        out = ()
"                                                                              "
"        Output_end is the sequence that will be sent after each stream of     "
"        output (and therefore before the next request for input) is sent      "
"        downline to the terminal.  This should include the sequence to        "
"        enable protect if the terminal supports protect.                      "
"                                                                              "
    output_end          out = ()
"                                                                              "
"        Print_begin is reserved for future use.                               "
"                                                                              "
    print_begin         out = ()
"                                                                              "
"        Print_end is reserved for future use.                                 "
"                                                                              "
    print_end           out = ()
"                                                                              "
"        Print_page is reserved for future use.                                "
"                                                                              "
    print_page          out = ()
"                                                                              "
"        Protect_all is the sequence that will set the protect bit for all     "
"        characters positions on the screen.  For some terminals that have     "
"        protect this will be an empty string (an example is is a terminal     "
"        that uses a clear screen to protected character positions             "
"        sequence to accomplish this function).                                "
"                                                                              "
    protect_all         out = ()
"                                                                              "
"        Reset is reserved for future use.                                     "
"                                                                              "
    reset               out = ()
"                                                                              "
"        Return is reserved for future use.                                    "
"                                                                              "
    return              out = ()
"                                                                              "
"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                                "
"                                                                              "
"        All full screen products use programmable function keys so that a     "
"   user can tell the full screen product what they want to do next.           "
"   Programmable function keys in the full screen editor allow a               "
"   frequently used command to be reduced to pressing the correct function     "
"   key (or required sequence of keys) for the terminal in use.                "
"                                                                              "
"        This section allows you to define what input sequences will be        "
"   sent upline by your terminal to be recognized as programmable function     "
"   keys.  The Full Screen Editor can function without any function keys,      "
"   but will provide best convenience if at least eight function keys are      "
"   available.  The Fortran/Cobol environments and the Edit_Catalog            "
"   utility require at least sixteen function keys.  Thus you should           "
"   provide for at least F1 - F16 or F1 - F8 plus F1_S - F8_S.  Note that      "
"   thirty-two function keys are possible, so you should define as many as     "
"   are practical within the constraints of your keyboard.                     "
"                                                                              "
"        The Label parameter is optional on these statements.  If it is left   "
"   out then the key is considered optional; if used it can be honored, but    "
"   no full-screen applications will depend on usage of the key for critical   "
"   operations.  If the label is non-blank, then you guarantee that the user   "
"   really has such a key on the terminal, and applications can count on it    "
"   for important operations.  The first two characters of the letter are      "
"   displayed in between function keys menus, to help the user locate the key  "
"   on the keyboard.                                                           "
"                                                                              "
    f1        in = ()        label = 'F1'
    f2        in = ()        label = 'F2'
    f3        in = ()        label = 'F3'
    f4        in = ()        label = 'F4'
    f5        in = ()        label = 'F5'
    f6        in = ()        label = 'F6'
    f7        in = ()        label = 'F7'
    f8        in = ()        label = 'F8'
    f9        in = ()        label = 'F9'
    f10       in = ()        label = 'F10'
    f11       in = ()        label = 'F11'
    f12       in = ()        label = 'F12'
    f13       in = ()        label = 'F13'
    f14       in = ()        label = 'F14'
    f15       in = ()        label = 'F15'
    f16       in = ()        label = 'F16'
    f1_s      in = ()        label = 'SF1'
    f2_s      in = ()        label = 'SF2'
    f3_s      in = ()        label = 'SF3'
    f4_s      in = ()        label = 'SF4'
    f5_s      in = ()        label = 'SF5'
    f6_s      in = ()        label = 'SF6'
    f7_s      in = ()        label = 'SF7'
    f8_s      in = ()        label = 'SF8'
    f9_s      in = ()        label = 'SF9'
    f10_s     in = ()        label = 'SF10'
    f11_s     in = ()        label = 'SF11'
    f12_s     in = ()        label = 'SF12'
    f13_s     in = ()        label = 'SF13'
    f14_s     in = ()        label = 'SF14'
    f15_s     in = ()        label = 'SF15'
    f16_s     in = ()        label = 'SF16'
"                                                                              "
"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                                "
"                                                                              "
"        All full screen products use what are called CDC standard             "
"   function keys.  These are keys that have the same meaning to a             "
"   particular full screen product regardless of the terminal in use.          "
"   Each of these keys also corresponds to a physical key on the CDC 721       "
"   (Viking X) terminal, except for Undo and Undo_S.                           "
"                                                                              "
"        The next section allows you to define what input sequences the        "
"   terminal you wish to use will send upline to be recognized as CDC          "
"   standard function keys.  This capability will make all full screen         "
"   products more usable to the end user but is not required when using        "
"   the Full Screen Editor.                                                    "
"                                                                              "
"        Local screen formatting applications that have been written to        "
"   use CDC standard function keys (rather than programmable function keys     "
"   described in the previous section) to drive menus or to terminate form     "
"   type input may require that at least some CDC standard function keys       "
"   be defined in this file.                                                   "
"                                                                              "
"        If you omit these statements, then the full-screen applications will  "
"   assign the operations to function keys as defined by the statements F1     "
"   thru F16 and F1_S thru F16_S.  There is a specific default assignment      "
"   for ten of these operations, and the others are services on a first-come   "
"   basis.  You can change the default mapping by providing these statements   "
"   with IN parameters that match the IN parameters for selected function      "
"   keys.                                                                      "
"                                                                              "
    next      in = 13        label = 'RETURN'
    next_s    in = ()        label = 'Shift-NEXT'
    back      in = ()        label = 'BACK'       " default: F3         "
    back_s    in = ()        label = 'Shift-BACK'
    help      in = ()        label = 'HELP'       " default: F4         "
    help_s    in = ()        label = 'Shift-HELP'
    stop      in = ()        label = 'STOP'       " default: F6         "
    stop_s    in = ()        label = 'Shift-STOP' " default: Shift F6   "
    down      in = ()        label = 'DOWN'
    down_s    in = ()        label = 'Shift-DOWN'
    up        in = ()        label = 'UP'
    up_s      in = ()        label = 'Shift-UP'
    fwd       in = ()        label = 'FWD'        " default: F2         "
    fwd_s     in = ()        label = 'Shift-FWD'  " default: Shift F2   "
    bkw       in = ()        label = 'BKW'        " default: F1         "
    bkw_s     in = ()        label = 'Shift-BKW'  " default: Shift F1   "
    edit      in = ()        label = 'EDIT'
    edit_s    in = ()        label = 'Shift-EDIT'
    data      in = ()        label = 'DATA'
    data_s    in = ()        label = 'Shift-DATA'
"                                                                              "
"   TERMINAL VIDEO ATTRIBUTES                                                  "
"                                                                              "
"        These attributes are used mainly by screen formatting                 "
"   applications to define various types of fields (though protect_begin       "
"   and end as well as inverse_begin and end or alternate_begin and end        "
"   where they available are used by the Full Screen Editor)                   "
"                                                                              "
"        Define the attributes sequences below as described in the             "
"   hardware reference manual for your terminal.  The only restriction is      "
"   that attributes that require an actual character position on the           "
"   screen can not be used.  If your terminal has a protect mode that uses     "
"   a video attribute such as alternate video (either bright or dim) then      "
"   you will want to place these sequences in the protect_begin and            "
"   protect_end statements.  These sequences are output only hence the OUT     "
"   keyword is used here.                                                      "
"                                                                              "
"        Alt_begin is the sequence to cause subsequent characters sent         "
"        downline to be displayed in an alternate intensity (which may be      "
"        bright or dim on your terminal).                                      "
"                                                                              "
    alt_begin           out = ()
"                                                                              "
"        Alt_end is the sequence to cause subsequent characters sent           "
"        downline to be in normal intensity.                                   "
"                                                                              "
    alt_end             out = ()
"                                                                              "
"        Low_intensity_begin  is the sequence to cause subsequent              "
"        characters sent downline to be displayed in low intensity.            "
"                                                                              "
    low_intensity_begin   out = ()
"                                                                              "
"        Low_intensity_end is the sequence to cause subsequent characters      "
"        sent downline to not be displayed in low intensity.                   "
"                                                                              "
    low_intensity_end     out = ()
"                                                                              "
"        High_intensity_begin is the sequence to cause subsequent             "
"        characters sent downline to be displayed in high intensity.           "
"                                                                              "
    high_intensity_begin  out = ()
"                                                                              "
"        High_intensity_end is the sequence to cause subsequent characters     "
"        sent downline to not be displayed in high intensity.                  "
"                                                                              "
    high_intensity_end     out = ()
"                                                                              "
"        Blink_begin is the sequence to cause subsequent characters            "
"        sent downline to be displayed with a blinking attribute.              "
"                                                                              "
    blink_begin         out = ()
"                                                                              "
"        Blink_end is the sequence to cause subsequent characters              "
"        sent downline after this with not be displayed with the               "
"        blinking attribute.                                                   "
"                                                                              "
    blink_end           out = ()
"                                                                              "
"        Hidden_begin is the sequence to set the hidden attribute for          "
"        subsequent characters so that data typed in this area can not         "
"        be seen on the screen (also called a guarded attribute).              "
"                                                                              "
    hidden_begin        out = ()
"                                                                              "
"        Hidden_end is the sequence to return to visible characters.           "
"                                                                              "
    hidden_end          out = ()
"                                                                              "
"        Inverse_begin is the sequence to cause subsequent characters          "
"        to be displayed in inverse video.                                     "
"                                                                              "
    inverse_begin       out = ()
"                                                                              "
"        Inverse_end is the sequence to return to normal video.                "
"                                                                              "
    inverse_end         out = ()
"                                                                              "
"        Protect_begin is the sequence to cause subsequent characters sent     "
"        downline to the terminal to be protected, which means data can        "
"        not be typed in these character positions on the screen.              "
"                                                                              "
    protect_begin       out = ()
"                                                                              "
"        Protect_end is the sequence to return to unprotected mode.            "
"                                                                              "
    protect_end         out = ()
"                                                                              "
"        Underline_begin is the sequence to cause subsequent characters        "
"        sent downline to be displayed with an underline attribute.            "
"                                                                              "
    underline_begin     out = ()
"                                                                              "
"        Underline_end is the sequence to cause subsequent characters          "
"        sent downline to no longer be underlined.                             "
"                                                                              "
    underline_end       out = ()
"                                                                              "
"   LOGICAL ATTRIBUTE SPECIFICATIONS                                           "
"                                                                              "
"        Logical attributes are used mainly by screen formatting               "
"   applications to define various types of fields.  You are free to           "
"   equate each logical attribute with any of the standard physical            "
"   attributes or to utilize non-standard physical attributes that your        "
"   terminal might provide, but common sense is advisable.  Typically, a       "
"   'fill in the forms' application would expect you to equate the logical     "
"   'input' attribute with the physical 'underlined' attribute.  The Full      "
"   Screen Editor uses the 'italic' logical attribute for marked text -        "
"   for terminals that do not have a true italics capability it is advised     "
"   that the 'italic' logical attribute should map to the 'inverse video'      "
"   physical attribute.                                                        "
"                                                                              "
"   ERROR                                                                      "
"                                                                              "
    error_begin         out = ()
    error_end           out = ()
"                                                                              "
"   INPUT TEXT                                                                 "
"                                                                              "
"        If your terminal supports protect by use of a video attribute         "
"        such as alternate intensity for unprotected areas of the screen       "
"        you should define input_text_begin and end accordingly so that        "
"        screen formatting applications display the input fields correctly     "
"        as unprotected areas.                                                 "
"                                                                              "
    input_text_begin    out = ()
    input_text_end      out = ()
"                                                                              "
"   ITALIC                                                                     "
"                                                                              "
"        If your terminal supports an alternate character set then here is     "
"        a place that you can make use of it with screen formatting            "
"        applications.  Remember that this attribute is used by the Full       "
"        Screen Editor to emphasize marked text.                               "
"                                                                              "
    italic_begin        out = ()
    italic_end          out = ()
"                                                                              "
"   MESSAGE                                                                    "
"                                                                              "
"        Attributes display here will be used when printing help and error     "
"        messages on the first line of the screen when a screen formatting     "
"        application is running.  Use any physical attributes that you         "
"        wish but remember that if your terminal has a video attribute         "
"        based protect capability this area should be protected data.          "
"                                                                              "
    message_begin       out = ()
    message_end         out = ()
"                                                                              "
"   OUTPUT TEXT                                                                "
"                                                                              "
"        For output only data so if your terminal has a video attribute        "
"        based protect capability this area should be protected data.          "
"                                                                              "
    output_text_begin   out = ()
    output_text_end     out = ()
"                                                                              "
"   TITLE                                                                      "
"                                                                              "
    title_begin         out = ()
    title_end           out = ()
"                                                                              "
"   LINE DRAWING CHARACTER SPECIFICATION                                       "
"                                                                              "
"        Line drawing character sets that your terminal supports should be     "
"   specified here for use with the box drawing capabilty found in NOS/VE      "
"   screen formatting.  There are three line weights, fine, medium, and        "
"   bold, each with a sequence to enable and disable that weight and with      "
"   eleven characters that represent the corners, edges and intersections      "
"   for the corresponding line drawing character set.                          "
"                                                                              "
"        If your terminal has the capability of actual line drawing then       "
"   place the sequences to turn the line drawing on and off in the             "
"   ld_fine_begin, ld_fine_end and so on for up to three types of line         "
"   drawing sets (you may specify the same sequences for all three or for      "
"   any two if your terminal does not have three line drawing sets).  If       "
"   your terminal has no line drawing then the use of a hypen character        "
"   for a horizontal character, a colon or like character for a vertical       "
"   line, and asterisks for all corners and intersections is suggested.        "
"   In this case the ld_fine_begin, ld_fine_end sequences would be blank       "
"   though you could use a terminal attribute such as alternate intensity.     "
"                                                                              "
"        Also for a bold line drawing character set you can define all         "
"   characters as blanks (' ') and use inverse_on and inverse_off as the       "
"   ld_bold_begin and ld_bold_end sequences.                                   "
"                                                                              "
"        Fine Line Drawing Begin and End Sequences.                            "
"                                                                              "
    ld_fine_begin            out = ()
    ld_fine_end              out = ()
"                                                                              "
"        Horizontal and Vertical Characters.                                   "
"                                                                              "
    ld_fine_horizontal       out = ()
    ld_fine_vertical         out = ()
"                                                                              "
"        Box Corner Characters.                                                "
"                                                                              "
    ld_fine_upper_left       out = ()
    ld_fine_upper_right      out = ()
    ld_fine_lower_left       out = ()
    ld_fine_lower_right      out = ()
"                                                                              "
"        Intersection Characters.                                              "
"                                                                              "
    ld_fine_up_t             out = ()
    ld_fine_down_t           out = ()
    ld_fine_left_t           out = ()
    ld_fine_right_t          out = ()
    ld_fine_cross            out = ()
"                                                                              "
"        Medium Line Drawing Begin and End Sequences.                          "
"                                                                              "
    ld_medium_begin          out = ()
    ld_medium_end            out = ()
"                                                                              "
"        Horizontal and Vertical Characters.                                   "
"                                                                              "
    ld_medium_horizontal     out = ()
    ld_medium_vertical       out = ()
"                                                                              "
"        Box Corner Characters.                                                "
"                                                                              "
    ld_medium_upper_left     out = ()
    ld_medium_upper_right    out = ()
    ld_medium_lower_left     out = ()
    ld_medium_lower_right    out = ()
"                                                                              "
"        Intersection Characters.                                              "
"                                                                              "
    ld_medium_up_t           out = ()
    ld_medium_down_t         out = ()
    ld_medium_left_t         out = ()
    ld_medium_right_t        out = ()
    ld_medium_cross          out = ()
"                                                                              "
"        Bold Line Drawing Begin and End Sequences.                            "
"                                                                              "
    ld_bold_begin            out = ()
    ld_bold_end              out = ()
"                                                                              "
"        Horizontal and Vertical Characters.                                   "
"                                                                              "
    ld_bold_horizontal       out = ()
    ld_bold_vertical         out = ()
"                                                                              "
"        Box Corner Characters.                                                "
"                                                                              "
    ld_bold_upper_left       out = ()
    ld_bold_upper_right      out = ()
    ld_bold_lower_left       out = ()
    ld_bold_lower_right      out = ()
"                                                                              "
"        Intersection Characters.                                              "
"                                                                              "
    ld_bold_up_t             out = ()
    ld_bold_down_t           out = ()
    ld_bold_left_t           out = ()
    ld_bold_right_t          out = ()
    ld_bold_cross            out = ()
"                                                                              "
"                                                                              "
"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                         "
"                                                                              "
"        The Define_Terminal facility provides a means to store arbitrary      "
"   text which can be extracted by any application.  In the case of the        "
"   Full Screen Editor, this is the means to provide default NOS/VE            "
"   commands that will associate with each function key.                       "
"                                                                              "
"        The keyword here is APPLICATION_STRING which has a 'name' and an      "
"   'out' value.  The name identifies the application for which the 'out'      "
"   string is relevant.  The application_string directive can be used as       "
"   many times as you need, but each 'out' value is limited to 256             "
"   characters and each 'name' value is limited to 31 characters.  Any         "
"   'name' can appear repeatedly.  With the Full Screen Editor, the 'name'     "
"   values are of the following format:                                        "
"                                                                              "
"        FSE_FUNCTION_1                                                        "
"        FSE_FUNCTION_SHIFT_1                                                  "
"        FSE_FUNCTION_1_LABEL                                                  "
"        FSE_FUNCTION_SHIFT_1_LABEL                                            "
"                                                                              "
"        In this example, the digit '1' indicates the function key number,     "
"   thus it could range from 1 to 16.  The word 'shift' indicates the          "
"   shifted variation of the function key, and the absence of 'shift'          "
"   indicates the unshifted key.  The presence of the word 'label' means       "
"   the 'out' value will be the label displayed on the screen to help you      "
"   remember what the key will do, and the absence of 'label' means that       "
"   the 'out' value will be the NOS/VE command string executed by the          "
"   editor when the key is pressed.  A complete example is:                    "
"                                                                              "
"        application_string name=('FSE_FUNCTION_3_LABEL') ..                   "
"          out=(' First')                                                      "
"        application_string name=('FSE_FUNCTION_SHIFT_3_LABEL') ..             "
"          out=(' Last ')                                                      "
"        application_string name=('FSE_FUNCTION_3') ..                         "
"          out=('align_screen top=first')                                      "
"        application_string name=('FSE_FUNCTION_SHIFT_3') ..                   "
"          out=('align_screen middle=last')                                    "
"                                                                              "
"        Note that the Editor contains a pre-compiled set of commands which    "
"   are matched to your function keys on a first-come basis, if you do not     "
"   provide any Application_String statements as shown in the preceeding       "
"   example.  Since it is rather tedious to construct a full set of function   "
"   key commands thru the application strings, you should first try using your "
"   terminal definition with the automatic defaults, and then add application  "
"   strings only as needed to suit your taste.                                 "
"                                                                              "
"        All screen-mode applications will also look for a few application     "
"   strings that can optimize the way output is sent to your terminal.  For    "
"   instance, some editor commands have the effect of vertically relocating    "
"   text on the screen.  If your terminal has insert/delete-line capabilities, "
"   NOS/VE can use that to scroll existing text to the correct row of the      "
"   screen.  Many terminals support the DEC VT100's "scrolling region" protcol,"
"   which can also be used for the same purpose.                               "
"                                                                              "
"        The NOS/VE screen-mode applications will paint an entire row of the   "
"   screen, by default, when any part of the row needs to be painted.  This is "
"   done to conserve CPU overhead and to support some terminals that behave    "
"   poorly when cursor motion is performed with visual highlighting in effect. "
"   Optionally, your terminal definition can request that NOS/VE optimize to   "
"   use less brute-force output.  This will usually consume more CPU overhead. "
"                                                                              "
"        To optimize horizontal re-painting, add this statement:               "
"                                                                              "
"        application_string name='optimization' out='true'                     "
"                                                                              "
"        Scrolling will be done automatically if your terminal has insert and  "
"   delete capabilities AND if you have requested optimization as shown in the "
"   previous example.  If your terminal suports the VT100 scrolling protocol,  "
"   then you can use the following statement, regardless of whether you select "
"   the optimization feature:                                                  "
"                                                                              "
"        application_string name='vt100_scrolling' out='true'                  "
"                                                                              "
"        Note that if you terminal supports both insert/delete AND the VT100   "
"   protocol, you will generally acchieve best results with the VT100 method,  "
"   as some terminals will have a side-effect with insert/delete of moving     "
"   the function keys menus temporarily out of place.                          "
"                                                                              "
"        There is another use for application strings, which is to supplement  "
"   the Screen_Init and Set_Screen_Mode statements.  Those statements define   "
"   output strings that are used at the start of each screen application.      "
"   Some terminals may require initialization to occur only once per job.  The "
"   NOS system supported this by outputing Screen_Init and Set_Screen_Mode at  "
"   different times.  Since NOS/VE outputs them together, application strings  "
"   are used as follows:                                                       "
"                                                                              "
"        application_string name='screen_init' out='text'                      "
"                                                                              "
"        Where text is up to 256 characters to be output.  You can concatenate "
"   larger strings by repeating the statement.  To utilize this definition,    "
"   your login PROLOG file should contain the following NOS/VE SCL commands:   "
"                                                                              "
"        Change_Terminal_Attributes  Terminal_Model=<name of your terminal>    "
"        Set_Program_Attributes Add_Library=<your terminal_definitions file>   "
"        Change_Interaction_Style  Screen                                      "
"        Initialize_Terminal                                                   "
"                                                                              "
"        Note that the SETPA is needed only if your definition resides in      "
"   a private library, ie, not $SYSTEM.TDU.TERMINAL_DEFINITIONS.  Note that    "
"   you can also re-initialize for line mode by using application strings named"
"   'line_init' and by using 'Line' mode on the CHAIS command.                     "
"                                                                              "
"                                                                              "
"   COMPILING YOUR TERMINAL DEFINITION                                         "
"                                                                              "
"        Now that you have completed your file you need to execute the         "
"   Define_Terminal command.  It will compile this file and produce a file     "
"   named (by default) TERMINAL_DEFINITIONS in your current working            "
"   catalog.  You test your definition by executing the command                "
"   SET_PROGRAM_ATTRIBUTES ADD_LIBRARY=TERMINAL_DEFINITIONS, then execute      "
"   the command CHANGE_TERMINAL_ATTRIBUTES TERMINAL_MODEL=XXXXX (where XXXXX   "
"   is your terminal name) and finally execute any screen oriented             "
"   application program, such as the Full Screen Editor.                       "
"                                                                              "
"        Once your terminal definition is fully debugged, you can automate     "
"   the selection of screen mode.  Make sure your TERMINAL_DEFINITIONS         "
"   file is permanent:  this is already true if you habitually set your        "
"   working catalog to $USER, but the default working catalog is $LOCAL,       "
"   in which case you should use the command COPY_FILE                         "
"   TERMINAL_DEFINITIONS $USER.TERMINAL_DEFINITIONS.  Once the file has        "
"   been made permanent, you can put the SETPA and CHATA commands (see         "
"   previous paragraph) in your login PROLOG file.                             "
"                                                                              "
"                                                                              "
"   END OF TERMINAL DEFINITION FILE FOR -------------- TERMINAL                "
*DECK DECK=CSM$SUN_160 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR SUN WORKSTATION                                  "

"   VARIABLES                                                                 "
prefix              = (1B(16) 5B(16))
clear_home          = (prefix 32(16) 4A(16))
clear_all_tabs      = (prefix '3g')
set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))
set_to_24x132       = (prefix 3F(16) 33(16) 68(16))
nulls=(00(16) 00(16) 00(16) 00(16) 00(16) 00(16) 00(16) 00(16) 00(16) 00(16))
padding =(nulls nulls nulls nulls nulls nulls nulls nulls nulls nulls nulls)
set_window_34       = (prefix '8;34;80t' prefix '7t' padding padding)
set_window_48       = (prefix '8;48;132t' prefix '7t' padding padding)
start_alternate     = (prefix 31(16) 6D(16))
start_inverse       = (prefix '7' 6D(16))
start_underline     = (prefix 34(16) 6D(16))
normal_attributes   = (prefix 'm')
stop_alternate      = normal_attributes
stop_inverse        = normal_attributes
stop_underline      = normal_attributes

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'SUN_160'
communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (3B(16))
cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 48(16))
cursor_up                inout = (prefix 41(16))
cursor_down              inout = (prefix 42(16))
cursor_left              inout = (prefix 44(16))
cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = wrap_adjacent_next
char_past_left           type  = stop_next
char_past_last_position  type  = scroll_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 1
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
fixed_tab_positions positions = (1,9,17,25,33,41,49,57,65,73)
set_size       rows = 34 columns = 80   out = (set_to_24x80 set_window_34)
set_size       rows = 48 columns = 132  out = (set_to_24x132 set_window_48)

"   SCREEN AND LINE MODE TRANSITION                                           "
screen_init out=(prefix 48(16) padding clear_home padding)
screen_init out=set_window_34
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)
screen_init out=(padding)

set_screen_mode     out = (1B(16) 3C(16) clear_all_tabs ..
    "1B(16) 28(16) 42(16)  1B(16) 29(16) 30(16)  0F(16)" 1B(16) ..
     3D(16) prefix '?7;1l' )

set_line_mode       out = (1B(16) 3C(16) clear_all_tabs ..
    "1B(16) 28(16) 42(16)  1B(16) 29(16) 30(16)  0F(16)" 1B(16) ..
     3E(16) prefix '?7;1h')

"   TERMINAL CAPABILITIES                                                     "
delete_char         in    = (prefix 50(16))
delete_line_bol     in    = (prefix 4D(16))
erase_end_of_line   inout = (prefix 4B(16))
erase_line_stay     inout = (prefix 32(16) 4B(16))
erase_page_home     in    = (clear_home)
erase_page_home       out = (padding prefix 48(16) padding clear_home)
insert_line_bol     in    = (prefix 4C(16))
insert_mode_begin   in    = (prefix 34(16) 68(16))
insert_mode_end     in    = (prefix 34(16) 6C(16))
tab_forward         inout = (09(16))
tab_clear_all       in    = (clear_all_tabs)
tab_set             in    = (1b(16) 48(16))

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
backspace           in = bs

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (prefix '193z') label='L2'
f2        in = (prefix '225z') label='f2'
f3        in = (prefix '226z') label='f3'
f4        in = (prefix '227z') label='f4'
f5        in = (prefix '228z') label='f5'
f6        in = (prefix '229z') label='f6'
f7        in = (prefix '230z') label='f7'
f8        in = (prefix '231z') label='f8'
f1_s      in = (prefix '208z') label='r1'
f2_s      in = (prefix '209z') label='r2'
f3_s      in = (prefix '210z') label='r3'
f4_s      in = (prefix '211z') label='r4'
f5_s      in = (prefix '212z') label='r5'
f6_s      in = (prefix '213z') label='r6'
f7_s      in = (prefix '214z') label='r7'
f8_s      in = (prefix '232z') label='f9'

f9        in = (esc prefix '193z') label='L2'
f10       in = (esc prefix '225z') label='f2'
f11       in = (esc prefix '226z') label='f3'
f12       in = (esc prefix '227z') label='f4'
f13       in = (esc prefix '228z') label='f5'
f14       in = (esc prefix '229z') label='f6'
f15       in = (esc prefix '230z') label='f7'
f16       in = (esc prefix '231z') label='f8'
f9_s      in = (esc prefix '208z') label='r1'
f10_s      in = (esc prefix '209z') label='r2'
f11_s      in = (esc prefix '210z') label='r3'
f12_s      in = (esc prefix '211z') label='r4'
f13_s      in = (esc prefix '212z') label='r5'
f14_s      in = (esc prefix '213z') label='r6'
f15_s      in = (esc prefix '214z') label='r7'
f16_s      in = (esc prefix '232z') label='f9'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = (prefix '193z') label='L2'
fwd       in = (prefix '225z') label='f2'
back      in = (prefix '226z') label='f3'
help      in = (prefix '227z') label='f4'
undo      in = (prefix '228z') label='f5'
stop      in = (prefix '229z') label='f6'
bkw_s     in = (prefix '208z') label='r1'
fwd_s     in = (prefix '209z') label='r2'
undo_s    in = (prefix '212z') label='r5'
stop_s    in = (prefix '213z') label='r6'
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_alternate)
alt_end             out = (stop_alternate)
blink_begin         out = (prefix 35(16) 6D(16))
blink_end           out = normal_attributes
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = ()
ld_fine_end              out = ()
ld_fine_horizontal       out = ('-')
ld_fine_vertical         out = ('|')
ld_fine_upper_left       out = ('+')
ld_fine_upper_right      out = ('+')
ld_fine_lower_left       out = ('+')
ld_fine_lower_right      out = ('+')
ld_fine_up_t             out = ('+')
ld_fine_down_t           out = ('+')
ld_fine_left_t           out = ('+')
ld_fine_right_t          out = ('+')
ld_fine_cross            out = ('+')
ld_medium_begin            out = ()
ld_medium_end              out = ()
ld_medium_horizontal       out = ('-')
ld_medium_vertical         out = ('|')
ld_medium_upper_left       out = ('+')
ld_medium_upper_right      out = ('+')
ld_medium_lower_left       out = ('+')
ld_medium_lower_right      out = ('+')
ld_medium_up_t             out = ('+')
ld_medium_down_t           out = ('+')
ld_medium_left_t           out = ('+')
ld_medium_right_t          out = ('+')
ld_medium_cross            out = ('+')
ld_bold_begin            out = ()
ld_bold_end              out = ()
ld_bold_horizontal       out = ('-')
ld_bold_vertical         out = ('|')
ld_bold_upper_left       out = ('+')
ld_bold_upper_right      out = ('+')
ld_bold_lower_left       out = ('+')
ld_bold_lower_right      out = ('+')
ld_bold_up_t             out = ('+')
ld_bold_down_t           out = ('+')
ld_bold_left_t           out = ('+')
ld_bold_right_t          out = ('+')
ld_bold_cross            out = ('+')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR SUN WORKSTATION                      "
*DECK DECK=CSM$SUN_4_43_80 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR SUN with Type4 Keyboard, window with 43 lines
"   and 80 columns.
"
"
"   TO COMPILE: define_terminal input=csm$sun_4_43_80 binary=sun_4_43_80
"
"   TO LOAD:    Extract resources from this file, then use
"               xrdb -load resources
"               See directions appearing later in this file.
"
"   TO USE:     set_program_attributes add_library=sun_4_43_80
"               set_terminal_attributes terminal_model=sun_4_43_80
"
"
"                KEYBOARD LAYOUT
"
"
"   +------+------+------+------+------+    +------+------+------+------+------+
"   |      |      |  F1  |  F2  |  F3  |    | F12  |      |      |      |      |
"   |      |      |  f1  |  f2  |  f3  | ...| f12  |      |      |      |      |
"   +------+------+------+------+------+    +------+------+------+------+------+
"   |      |      |                                |      |      |      |      |
"   |      |      |                                |      |      |      |      |
"   +------+------+                                +------+------+------+------+
"   |      |      |                                |      |  ^   |      |      |
"   |      |      |                                |home  |  |   | PgUP |      |
"   +------+------+                                +------+------+------+      |
"   |      |      |                                |      |      |      |      |
"   |      |      |                                | <-   |      | ->   |      |
"   +------+------+                                +------+------+------+------+
"   |      |      |                                |      |  |   |      |      |
"   |      |      |                                |InsEnd|  v   | PgDn |      |
"   +------+------+                                +------+------+------+      |
"   |             |                                | InsL        | DelL |      |
"   |             |                                | Insert mode | DelC |      |
"   +-------------+                                +-------------+------+------+
"
"
"             FUNCTION ASSIGNMENTS
"
"
"              KEY          MODIFIER  ACTION
"             +------------------------------------------------+
"             | F1 - F12  |          | F1 - F12                |
"             |           | Shift    | F1 - F12 Shifted        |
"             |------------------------------------------------|
"             | F1 - F4   | Ctrl     | F13 - F16               |
"             |           |          |                         |
"             |------------------------------------------------|
"             | F5 - F8   | Ctrl     | F13 - F16 Shifted       |
"             |           |          |                         |
"             |------------------------------------------------|
"             | Insert    |          | Enter Insert Mode       |
"             |           | Shift    | Insert Line             |
"             |           | Ctrl     | Insert Character        |
"             |------------------------------------------------|
"             | Delete    |          | Delete Character        |
"             |           | Shift    | Delete Line             |
"             |------------------------------------------------|
"             | Home      |          | Put Cursor on Home Line |
"             |------------------------------------------------|
"             | End       |          | Exit Insert Mode        |
"             |           | Ctrl     | Delete to End of Line   |
"             |------------------------------------------------|
"             | Page Up   |          | Previous Screen (bkw)   |
"             |           | Shift    | Top (bkw_s)             |
"             |           | Ctrl     | Half Page Forward (up)  |
"             |------------------------------------------------|
"             | Page Down |          | Next Screen (fwd)       |
"             |           | Shift    | Bottom (fwd_s)          |
"             |           | Ctrl     | Half Page Backward(down)|
"             +------------------------------------------------+
"             | F3        |          | Back to previous context|
"             |           |          |                         |
"             |           |          |                         |
"             |------------------------------------------------|
"             | F4        |          | Help                    |
"             |           |          |                         |
"             |           |          |                         |
"             +------------------------------------------------+
"             | F5        |          | Undo                    |
"             |           |          |                         |
"             |           |          |                         |
"             |------------------------------------------------|
"             | F6        |          | Stop                    |
"             |           |          |                         |
"             |           |          |                         |
"             +------------------------------------------------+
"
" To run the Sun terminal you need to install a resource file using xrdb.     "
" You may run xrdb on NOS/VE or on UNIX. This deck gives you the input        "
" for both NOS/VE and UNIX.                                                   "
"                                                                             "
" UNIX Installation                                                           "
"                                                                             "
" The following is file which is required in order to use this TDU.           "
" Take it out of this TDU and remove the double-quotes from each end of the   "
" lines.  It can then be used on the unix host when you use xterm.            "
"                                                                             "
"!------------------- beginning of unix file .Xdefaults ----------------------"
"!                                                                            "
"! define xterm VT100 prefix, use xrdb .Xdefaults                             "
"!                                                                            "
"! Note: You must allow the c pre-processor to run on this file.              "
"!       Do NOT use the -nocpp option on the xrdb command.                    "
"!                                                                            "
"!       To allow these key mappings to work, put them in a file on unix,     "
"!       execute the command:                                                 "
"!            xrdb whatever_filename_you_used                                 "
"!       then invoke an xterm like this:                                      "
"!            xterm -name xterm -132 -j                                       "
"!       the '-name xterm' tells it to use the xterm key mapping              "
"!       the '-132' tells it to allow switching to 132 column mode            "
"!       the '-j' tells it to do jump scrolling instead of smooth scrolling   "
"!                (this one is optional)                                      "
"!                                                                            "
"#define CR string(0x0d)                                                      "
"#define ESC string(0x1b)                                                     "
"#define SH_FKEY string(0x1b) string([9)                                      "
"#define PREFIX string(0x1b) string([)                                        "
"xterm*scrollBar:          on                                                 "
"xterm*saveLines:          150                                                "
"xterm*borderWidth:        2                                                  "
"xterm*c132:               on                                                 "
"xterm*font:               6x13                                               "
"xterm*boldFont:           6x13B                                              "
"xterm*VT100.geometry:     80x43                                              "
"xterm*VT100.Translations:   #override\                                       "
"    Ctrl<Key>F1:     PREFIX  string(25~) CR    \n\                           "
"    Meta<Key>F1:                               \n\                           "
"  Shift <Key>F1:     SH_FKEY string(11~) CR    \n\                           "
"        <Key>F1:     PREFIX  string(11~) CR    \n\                           "
"    Ctrl<Key>F2:     PREFIX  string(26~) CR    \n\                           "
"    Meta<Key>F2:                               \n\                           "
"  Shift <Key>F2:     SH_FKEY string(12~) CR    \n\                           "
"        <Key>F2:     PREFIX  string(12~) CR    \n\                           "
"    Ctrl<Key>F3:     PREFIX  string(28~) CR    \n\                           "
"    Meta<Key>F3:                               \n\                           "
"  Shift <Key>F3:     SH_FKEY string(13~) CR    \n\                           "
"        <Key>F3:     PREFIX  string(13~) CR    \n\                           "
"    Ctrl<Key>F4:     PREFIX  string(29~) CR    \n\                           "
"    Meta<Key>F4:                               \n\                           "
"  Shift <Key>F4:     SH_FKEY string(14~) CR    \n\                           "
"        <Key>F4:     PREFIX  string(14~) CR    \n\                           "
"    Ctrl<Key>F5:     SH_FKEY  string(25~) CR   \n\                           "
"    Meta<Key>F5:                               \n\                           "
"  Shift <Key>F5:     SH_FKEY string(15~) CR    \n\                           "
"        <Key>F5:     PREFIX  string(15~) CR    \n\                           "
"    Ctrl<Key>F6:     SH_FKEY  string(25~) CR   \n\                           "
"    Meta<Key>F6:                               \n\                           "
"  Shift <Key>F6:     SH_FKEY string(17~) CR    \n\                           "
"        <Key>F6:     PREFIX  string(17~) CR    \n\                           "
"    Ctrl<Key>F7:     SH_FKEY  string(28~) CR   \n\                           "
"    Meta<Key>F7:                               \n\                           "
"  Shift <Key>F7:     SH_FKEY string(18~) CR    \n\                           "
"        <Key>F7:     PREFIX  string(18~) CR    \n\                           "
"    Ctrl<Key>F8:     SH_FKEY  string(29~) CR   \n\                           "
"    Meta<Key>F8:                               \n\                           "
"  Shift <Key>F8:     SH_FKEY string(19~) CR    \n\                           "
"        <Key>F8:     PREFIX  string(19~) CR    \n\                           "
"    Ctrl<Key>F9:                               \n\                           "
"    Meta<Key>F9:                               \n\                           "
"  Shift <Key>F9:     SH_FKEY string(20~) CR    \n\                           "
"        <Key>F9:     PREFIX  string(20~) CR    \n\                           "
"    Ctrl<Key>F10:                              \n\                           "
"    Meta<Key>F10:                              \n\                           "
"  Shift <Key>F10:    SH_FKEY string(21~) CR    \n\                           "
"        <Key>F10:    PREFIX  string(21~) CR    \n\                           "
"    Ctrl<Key>F11:                              \n\                           "
"    Meta<Key>F11:                              \n\                           "
"  Shift <Key>F11:    SH_FKEY string(23~) CR    \n\                           "
"        <Key>F11:    PREFIX  string(23~) CR    \n\                           "
"    Ctrl<Key>F12:                              \n\                           "
"    Meta<Key>F12:                              \n\                           "
"  Shift <Key>F12:    SH_FKEY string(24~) CR    \n\                           "
"        <Key>F12:    PREFIX  string(24~) CR    \n\                           "
"        <Key>F27:    PREFIX  string(H)         \n\                           "
"    Ctrl<Key>F29:    ESC SH_FKEY string(6~) CR  \n\                          "
"    Meta<Key>F29:                              \n\                           "
"   Shift<Key>F29:    SH_FKEY string(5~)  CR    \n\                           "
"        <Key>F29:    PREFIX  string(5~)  CR    \n\                           "
"    Ctrl<Key>F35:    ESC SH_FKEY string(5~) CR \n\                           "
"    Meta<Key>F35:                              \n\                           "
"   Shift<Key>F35:    SH_FKEY string(6~)  CR    \n\                           "
"        <Key>F35:    PREFIX  string(6~)  CR    \n\                           "
"    Ctrl<Key>Insert: PREFIX  string(@)         \n\                           "
"    Meta<Key>Insert:                           \n\                           "
"   Shift<Key>Insert: PREFIX  string(L)         \n\                           "
"        <Key>Insert: PREFIX  string(4h)        \n\                           "
"    Ctrl<Key>Delete: PREFIX  string(P)         \n\                           "
"    Meta<Key>Delete:                           \n\                           "
"   Shift<Key>Delete: PREFIX  string(M)         \n\                           "
"        <Key>Delete: PREFIX  string(P)                                       "
"!                                                                            "
"!---------------------- end of unix file .Xdefaults -------------------------"
"
" NOS/VE Installation
"
" The following is file which is required in order to use this TDU.
" Take it out of this TDU and remove the quote from the beginning of each line
" lines.  It can then be used to run xrdb from the NOS/VE host.
" To allow these key mappings to work, put them in a file on NOS/VE and
"  execute the command:
"             xrdb whatever_filename_you_used
" ------------------ beginning of NOS/VE file _xdefaults ----------------------
"xterm*scrollBar: on
"xterm*saveLines: 150
"xterm*borderWidth: 2
"xterm*c132: on
"xterm*font: 6x13
"xterm*boldFont: 6x13B
"xterm*VT100.geometry: 80x43
"xterm*VT100.Translations: #override\
"    Ctrl<Key>F1:     string(0x1b) string([)  string(25~) string(0x0d)    \n\
"    Meta<Key>F1:                               \n\
"  Shift <Key>F1:     string(0x1b) string([9) string(11~) string(0x0d)    \n\
"        <Key>F1:     string(0x1b) string([)  string(11~) string(0x0d)    \n\
"    Ctrl<Key>F2:     string(0x1b) string([)  string(26~) string(0x0d)    \n\
"    Meta<Key>F2:                               \n\
"  Shift <Key>F2:     string(0x1b) string([9) string(12~) string(0x0d)    \n\
"        <Key>F2:     string(0x1b) string([) string(12~) string(0x0d)    \n\
"    Ctrl<Key>F3:     string(0x1b) string([)  string(28~) string(0x0d)    \n\
"    Meta<Key>F3:                               \n\
"  Shift <Key>F3:     string(0x1b) string([9) string(13~) string(0x0d)    \n\
"        <Key>F3:     string(0x1b) string([) string(13~) string(0x0d)    \n\
"    Ctrl<Key>F4:     string(0x1b) string([)  string(29~) string(0x0d)    \n\
"    Meta<Key>F4:                               \n\
" Shift <Key>F4:     string(0x1b) string([9) string(14~) string(0x0d)    \n\
"        <Key>F4:    string(0x1b) string([) string(14~) string(0x0d)    \n\
"    Ctrl<Key>F5:    string(0x1b) string([9) string(25~) string(0x0d)    \n\
"    Meta<Key>F5:                               \n\
"  Shift <Key>F5:     string(0x1b) string([9) string(15~) string(0x0d)    \n\
"        <Key>F5:     string(0x1b) string([) string(15~) string(0x0d)    \n\
"    Ctrl<Key>F6:     string(0x1b) string([9) string(26~) string(0x0d)    \n\
"    Meta<Key>F6:                               \n\
"  Shift <Key>F6:     string(0x1b) string([9) string(17~) string(0x0d)    \n\
"       <Key>F6:      string(0x1b) string([) string(17~) string(0x0d)    \n\
"   Ctrl<Key>F7:      string(0x1b) string([9) string(28~) string(0x0d)    \n\
"   Meta<Key>F7:                               \n\
" Shift <Key>F7:     string(0x1b) string([9) string(18~) string(0x0d)    \n\
"       <Key>F7:     string(0x1b) string([) string(18~) string(0x0d)    \n\
"    Ctrl<Key>F8:    string(0x1b) string([)  string(29~) string(0x0d)    \n\
"    Meta<Key>F8:                               \n\
"  Shift <Key>F8:     string(0x1b) string([9) string(19~) string(0x0d)    \n\
"        <Key>F8:     string(0x1b) string([) string(19~) string(0x0d)    \n\
"    Ctrl<Key>F9:                               \n\
"    Meta<Key>F9:                               \n\
"  Shift <Key>F9:     string(0x1b) string([9) string(20~) string(0x0d)    \n\
"        <Key>F9:     string(0x1b) string([) string(20~) string(0x0d)    \n\
"    Ctrl<Key>F10:                              \n\
"    Meta<Key>F10:                              \n\
"  Shift <Key>F10:    string(0x1b) string([9) string(21~) string(0x0d)    \n\
"        <Key>F10:    string(0x1b) string([) string(21~) string(0x0d)    \n\
"    Ctrl<Key>F11:                              \n\
"    Meta<Key>F11:                              \n\
"  Shift <Key>F11:    string(0x1b) string([9) string(23~) string(0x0d)    \n\
"        <Key>F11:    string(0x1b) string([) string(23~) string(0x0d)    \n\
"    Ctrl<Key>F12:                              \n\
"    Meta<Key>F12:                              \n\
"  Shift <Key>F12:    string(0x1b) string([9) string(24~) string(0x0d)    \n\
"        <Key>F12:    string(0x1b) string([) string(24~) string(0x0d)    \n\
"        <Key>F27:   string(0x1b) string([)  string(H)         \n\
"    Ctrl<Key>F29:    string(0x1b) string(0x1b) string([9) string(6~) string(0x0d)    \n\
"    Meta<Key>F29:                              \n\
"  Shift <Key>F29:    string(0x1b) string([9) string(5~) string(0x0d)    \n\
"        <Key>F29:    string(0x1b) string([) string(5~) string(0x0d)    \n\
"    Ctrl<Key>F35:    string(0x1b) string(0x1b) string([9) string(5~) string(0x0d)    \n\
"    Meta<Key>F35:                              \n\
"  Shift <Key>F35:    string(0x1b) string([9) string(6~) string(0x0d)    \n\
"        <Key>F35:    string(0x1b) string([) string(6~) string(0x0d)    \n\
"    Ctrl<Key>Insert: string(0x1b) string([)  string(@)         \n\
"    Meta<Key>Insert:                           \n\
"   Shift<Key>Insert: string(0x1b) string([)  string(L)         \n\
"        <Key>Insert: string(0x1b) string([)  string(4h)        \n\
"    Ctrl<Key>Delete: string(0x1b) string([)  string(P)         \n\
"  Meta<Key>Delete:                           \n\
"   Shift<Key>Delete: string(0x1b) string([)  string(M)         \n\
"        <Key>Delete: string(0x1b) string([)  string(P)
" ---------------------- end of NOS/VE file _xdefaults -------------------------

"   VARIABLES
prefix              = (esc '[')
alt_screen_buffer   = (prefix '?47h')
sh_fkey             = (esc '[9')
clear_all_tabs      = (prefix '3g')
clear_home          = (prefix 'H' prefix 'J')
disable_mouse       = (prefix '?1002l')
enable_cursor_mode  = (prefix '?1l')
enable_mouse        = (prefix '?1002h')
enter_ansi_mode     = (esc '<')
g0_us_characters    = (esc '(B')
g1_graphics_chars   = (esc ')0')
application_keypad  = (esc '=')
numeric_keypad      = (esc '>')
normal_attributes   = (prefix 'm')
normal_screen_buffer= (prefix '?47l')
restore_cursor      = (esc '8')
save_cursor         = (esc '7')
select_g0_char_set  = (si)
set_80_cols         = (prefix '?3l')
set_132_cols        = (prefix '?3h')
start_alternate     = (prefix '1m')
start_blink         = (prefix '5m')
start_inverse       = (prefix '7m')
start_underline     = (prefix '4m')
stop_alternate      = (normal_attributes)
stop_blink          = (normal_attributes)
stop_inverse        = (normal_attributes)
stop_underline      = (normal_attributes)
wraparound_off      = (prefix '?7l')
wraparound_on       = (prefix '?7h')
start_insert_mode   = (prefix '4h')
stop_insert_mode    = (prefix '4l')

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'SUN_4_43_80'
communications      type  = asynch
application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (';')
cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 'H') label='Home'
cursor_up                inout = (prefix 'A')
cursor_down              inout = (prefix 'B')
cursor_left              inout = (prefix 'D')
cursor_right             inout = (prefix 'C')

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 0
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 43 columns = 80   out = (set_80_cols)
set_size       rows = 43 columns = 132  out = (set_132_cols)

"   SCREEN AND LINE MODE TRANSITION                                           "

" You may restore the text on the screen after exiting a full screen
" application if you add alt_screen_buffer to the set_screen_command. If you add
" alt_screen_buffer you may see the following results to occur.

" - REDO acts as a full screen utility, so when you hit redo, an empty screen
"   comes up with only the line you are editing.
"
" - With page_width set to 132, when you enter a full screen utility, the
"   xterm window momentarily goes to 80 columns and then back to 132.  The
"   result of this is that when you leave the full screen utility, you only
"   have the information from the first 80 columns left on your screen.
"
" - Sometimes when you exit the full screen utility, especially if you have
"   gone into line mode sometime during the session, the cursor will be left
"   at the top of the screen.  The following line can be used to move your
"   cursor to the bottom of the screen:
"      putl $char(' ' esc '[40B')

set_screen_mode     out = (save_cursor "alt_screen_buffer" ..
     enter_ansi_mode stop_insert_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     wraparound_off enable_cursor_mode enable_mouse)


set_line_mode     out = (enter_ansi_mode stop_insert_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set disable_mouse ..
     wraparound_on normal_screen_buffer restore_cursor enable_cursor_mode)

"   TERMINAL CAPABILITIES                                                     "
delete_char         inout = (prefix 'P')  label='  Delete'
delete_line_stay    inout = (prefix 'M')  label='  Shift-Delete'
erase_end_of_line   inout = (prefix 'K')  label='  Ctrl-End'
erase_line_stay     inout = (prefix '2K')
erase_page_home       out = (clear_home)
insert_char         inout = (prefix '@')  label='  Ctrl-Insert'
insert_line_stay    inout = (prefix 'L')  label='  Shift-Insert'
insert_mode_begin   inout = (start_insert_mode) label='  Insert'
insert_mode_end     inout = (stop_insert_mode)  label='  End'
tab_forward         inout = (ht)
tab_clear_all       inout = (clear_all_tabs)
tab_set             inout = (esc 'H')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
backspace           in = bs

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (prefix '11~') label='F1'
f2        in = (prefix '12~') label='F2'
f3        in = (prefix '13~') label='F3'
f4        in = (prefix '14~') label='F4'
f5        in = (prefix '15~') label='F5'
f6        in = (prefix '17~') label='F6'
f7        in = (prefix '18~') label='F7'
f8        in = (prefix '19~') label='F8'
f9        in = (prefix '20~') label='F9'
f10       in = (prefix '21~') label='10'
f11       in = (prefix '23~') label='11'
f12       in = (prefix '24~') label='12'
f13       in = (prefix '25~') label='C1'
f14       in = (prefix '26~') label='C2'
f15       in = (prefix '28~') label='C3'
f16       in = (prefix '29~') label='C4'

f1_s      in = (sh_fkey '11~') label='  Shifted f1'
f2_s      in = (sh_fkey '12~') label='  Shifted f2'
f3_s      in = (sh_fkey '13~') label='  Shifted f3'
f4_s      in = (sh_fkey '14~') label='  Shifted f4'
f5_s      in = (sh_fkey '15~') label='  Shifted f5'
f6_s      in = (sh_fkey '17~') label='  Shifted f6'
f7_s      in = (sh_fkey '18~') label='  Shifted f7'
f8_s      in = (sh_fkey '19~') label='  Shifted f8'
f9_s      in = (sh_fkey '20~') label='  Shifted f9'
f10_s     in = (sh_fkey '21~') label='  Shifted f10'
f11_s     in = (sh_fkey '23~') label='  Shifted f11'
f12_s     in = (sh_fkey '24~') label='  Shifted f12'
f13_s     in = (sh_fkey '25~') label='C5'
f14_s     in = (sh_fkey '26~') label='C6'
f15_s     in = (sh_fkey '28~') label='C7'
f16_s     in = (sh_fkey '29~') label='C8'



"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = (prefix '5~') label='  PgUp'
fwd       in = (prefix '6~') label='  PgDn'
back      in = (prefix '13~') label='F3'
help      in = (prefix '14~') label='F4'
undo      in = (prefix '15~') label='F5'
stop      in = (prefix '17~') label='F6'
bkw_s     in = (sh_fkey '5~') label='  Shift-PgUp'
fwd_s     in = (sh_fkey '6~') label='  Shift-PgDn'
undo_s    in = ()
stop_s    in = ()
down      in = (esc sh_fkey '5~') label='  Ctrl-PgDn'
down_s    in = ()
up        in = (esc sh_fkey '6~') label='  Ctrl-PgUp'
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_alternate)
alt_end             out = (stop_alternate)
blink_begin         out = (start_blink)
blink_end           out = (stop_blink)
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = (so)
ld_fine_end              out = (si)
ld_fine_horizontal       out = 'q'
ld_fine_vertical         out = 'x'
ld_fine_upper_left       out = 'l'
ld_fine_upper_right      out = 'k'
ld_fine_lower_left       out = 'm'
ld_fine_lower_right      out = 'j'
ld_fine_up_t             out = 'w'
ld_fine_down_t           out = 'v'
ld_fine_left_t           out = 't'
ld_fine_right_t          out = 'u'
ld_fine_cross            out = 'n'
ld_medium_begin          out = (so start_alternate)
ld_medium_end            out = (si stop_alternate)
ld_medium_horizontal     out = 'q'
ld_medium_vertical       out = 'x'
ld_medium_upper_left     out = 'l'
ld_medium_upper_right    out = 'k'
ld_medium_lower_left     out = 'm'
ld_medium_lower_right    out = 'j'
ld_medium_up_t           out = 'w'
ld_medium_down_t         out = 'v'
ld_medium_left_t         out = 't'
ld_medium_right_t        out = 'u'
ld_medium_cross          out = 'n'
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR xterminal "
*DECK DECK=CSM$TAB_132 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR TAB 132/15 TERMINAL                          "

"   VARIABLES                                                                 "

prefix              = (esc '[')
prefix_2            = (esc '_')
suffix              = (esc '\')

ansi                = (esc '<')
ascii               = (esc '(B' esc ')0' si)
clear_stay          = (prefix '2J')
clear_all_tabs      = (prefix '3g')
decckm              = (prefix '?1l')   " ansi cursor keys              "
deckpam             = (esc '=')        " shifted keypad                "
deckpnm             = (esc '>')        " normal keypad                 "
normal_attributes   = (prefix 'm')
null                = ( nul nul nul nul nul nul nul nul nul nul )
send_nulls          = ( null null null null null null null null null null )
set_to_24x80        = (prefix '?3l')
set_to_24x132       = (prefix '?3h')
soft_key1           = (prefix_2 'L1   S1    ' suffix ..
                       prefix_2 'M1' esc 'Oa' suffix )
soft_key2           = (prefix_2 'L2   S2    ' suffix ..
                       prefix_2 'M2' esc 'OA' suffix )
soft_key3           = (prefix_2 'L3   S3    ' suffix ..
                       prefix_2 'M3' esc 'Ob' suffix )
soft_key4           = (prefix_2 'L4   S4    ' suffix ..
                       prefix_2 'M4' esc 'OB' suffix )
soft_key5           = (prefix_2 'L5   S5    ' suffix ..
                       prefix_2 'M5' esc 'Oc' suffix )
soft_key6           = (prefix_2 'L6   S6    ' suffix ..
                       prefix_2 'M6' esc 'OC' suffix )
soft_key7           = (prefix_2 'L7   S7    ' suffix ..
                       prefix_2 'M7' esc 'Od' suffix )
soft_key8           = (prefix_2 'L8   S8    ' suffix ..
                       prefix_2 'M8' esc 'OD' suffix )
start_alternate     = (prefix '1m')
start_blink         = (prefix '5m')
start_inverse       = (prefix '7m')
start_underline     = (prefix '4m')
stop_alternate      = (prefix 'm')
stop_blink          = (prefix 'm')
stop_inverse        = (prefix 'm')
stop_underline      = (prefix 'm')
tabon               = (prefix_2 'TABON' suffix )
taboff              = (prefix_2 'TABOFF' suffix )
tabdlgnd            = (esc '9')      " display soft keys legends "
vt132               = (prefix '=2l')

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'TAB_132'
communications      type  = asynch

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (';')
cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 'H')
cursor_up                inout = (prefix 'A')
cursor_down              inout = (prefix 'B')
cursor_left              inout = (prefix 'D')
cursor_right             inout = (prefix 'C')

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 1
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size  rows = 24 columns = 80   out = (set_to_24x80  Clear_stay tabdlgnd )
set_size  rows = 24 columns = 132  out = (set_to_24x132 Clear_stay tabdlgnd )

"   SCREEN AND LINE MODE TRANSITION                                           "
initialize_terminal sc='$system.change_terminal_attributes fkc=dec_vt100'
screen_init     out = ( ansi ascii vt132 tabon send_nulls )
screen_init     out = ( clear_all_tabs deckpam decckm send_nulls )
screen_init     out = ( soft_key1 soft_key2 soft_key3 soft_key4 send_nulls )
screen_init     out = ( soft_key5 soft_key6 soft_key7 soft_key8 send_nulls )

set_line_mode   out = (ansi clear_all_tabs ascii send_nulls ..
                       deckpnm set_to_24x80 taboff )

"   TERMINAL CAPABILITIES                                                     "
delete_char         inout = (prefix 'P')
delete_line_bol     inout = (prefix 'M')
erase_end_of_line   inout = (prefix 'K')
erase_line_stay     inout = (prefix '2K')
erase_page_stay     inout = (clear_stay)
erase_end_of_page   inout = (prefix 'J')
insert_char         inout = ()
insert_line_bol     inout = (prefix 'L')
insert_mode_begin   inout = (prefix '4h')
insert_mode_end     inout = (prefix '4l')
tab_backward        inout = (prefix 'Z')
tab_clear_all       inout = (clear_all_tabs)
tab_forward         inout = (ht)
tab_set             inout = (esc 'H')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
output_begin        out = (prefix '4l')
backspace           in  = (bs)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (esc 'Oq') label='k1'
f2        in = (esc 'Or') label='k2'
f3        in = (esc 'Os') label='k3'
f4        in = (esc 'Ot') label='k4'
f5        in = (esc 'Ou') label='k5'
f6        in = (esc 'Ov') label='k6'
f7        in = (esc 'Ow') label='k7'
f8        in = (esc 'Ox') label='k8'
f9        in = (esc 'Oy') label='k9'
f10       in = (esc 'Oa') label='S1'
f11       in = (esc 'Ob') label='S3'
f12       in = (esc 'Oc') label='S5'
f13       in = (esc 'Od') label='S7'
f14       in = ()
f15       in = ()
f16       in = ()
f1_s      in = (esc 'OP') label='p1'
f2_s      in = (esc 'OQ') label='p2'
f3_s      in = (esc 'OR') label='p3'
f4_s      in = (esc 'OS') label='p4'
f5_s      in = (esc 'Om') label='k-'
f6_s      in = (esc 'Ol') label='kt'
f7_s      in = (esc 'OM') label='ke'
f8_s      in = (esc 'On') label='k.'
f9_s      in = (esc 'Op') label='k0'
f10_s     in = (esc 'OA') label='S2'
f11_s     in = (esc 'OB') label='S4'
f12_s     in = (esc 'OC') label='S6'
f13_s     in = (esc 'OD') label='S8'
f14_s     in = ()
f15_s     in = ()
f16_s     in = ()

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13         label = 'RETURN'
next_s    in = ()
back      in = ()
back_s    in = ()
help      in = ()
help_s    in = ()
stop      in = (dc4)      label = 'STOP'
stop_s    in = (dle)      label = 'Shift-STOP'
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
fwd       in = ()
fwd_s     in = ()
bkw       in = ()
bkw_s     in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_alternate)
alt_end             out = (stop_alternate)
blink_begin         out = (start_blink)
blink_end           out = (stop_blink)
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = so
ld_fine_end              out = si
ld_fine_horizontal       out = 'q'
ld_fine_vertical         out = 'x'
ld_fine_upper_left       out = 'l'
ld_fine_upper_right      out = 'k'
ld_fine_lower_left       out = 'm'
ld_fine_lower_right      out = 'j'
ld_fine_up_t             out = 'w'
ld_fine_down_t           out = 'v'
ld_fine_left_t           out = 't'
ld_fine_right_t          out = 'u'
ld_fine_cross            out = 'n'
ld_medium_begin          out = (so start_alternate)
ld_medium_end            out = (si stop_alternate)
ld_medium_horizontal     out = 'q'
ld_medium_vertical       out = 'x'
ld_medium_upper_left     out = 'l'
ld_medium_upper_right    out = 'k'
ld_medium_lower_left     out = 'm'
ld_medium_lower_right    out = 'j'
ld_medium_up_t           out = 'w'
ld_medium_down_t         out = 'v'
ld_medium_left_t         out = 't'
ld_medium_right_t        out = 'u'
ld_medium_cross          out = 'n'
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

application_string name=('FSE_FUNCTION_1') out=('align_screen top=last_screen')
application_string name=('FSE_FUNCTION_1_LABEL') out=(' Fwd  ')

application_string name=('FSE_FUNCTION_2') out=('align_screen top=current')
application_string name=('FSE_FUNCTION_2_LABEL') out=('LineUp')

application_string name=('FSE_FUNCTION_3') out=('copy_text l=m p=b')
application_string name=('FSE_FUNCTION_3_LABEL') out=(' Copy ')

application_string name=('FSE_FUNCTION_4') out=('mark_lines')
application_string name=('FSE_FUNCTION_4_LABEL') out=(' Mark ')

application_string name=('FSE_FUNCTION_5') out=('undo')
application_string name=('FSE_FUNCTION_5_LABEL') out=(' Undo ')

application_string name=('FSE_FUNCTION_6') out=('Quit')
application_string name=('FSE_FUNCTION_6_LABEL') out=(' Quit ')

application_string name=('FSE_FUNCTION_7') out=('help')
application_string name=('FSE_FUNCTION_7_LABEL') out=(' Help ')

application_string name=('FSE_FUNCTION_8') out=('locate_text $si(''Enter search string'')')
application_string name=('FSE_FUNCTION_8_LABEL') out=('Locate')

application_string name=('FSE_FUNCTION_9') out=('break_text')
application_string name=('FSE_FUNCTION_9_LABEL') out=('Break ')

application_string name=('FSE_FUNCTION_10') out=('align_screen top=first')
application_string name=('FSE_FUNCTION_10_LABEL') out=('First ')

application_string name=('FSE_FUNCTION_11') out=('insert_characters nt='' ''')
application_string name=('FSE_FUNCTION_11_LABEL') out=('InsCh ')

application_string name=('FSE_FUNCTION_12') out=('insel n=1 p=b')
application_string name=('FSE_FUNCTION_12_LABEL') out=('InsLn ')

application_string name=('FSE_FUNCTION_13') out=('exchange_screen_width')
application_string name=('FSE_FUNCTION_13_LABEL') out=('80/132 ')

application_string name=('FSE_FUNCTION_14') out=(' ')
application_string name=('FSE_FUNCTION_14_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_15') out=(' ')
application_string name=('FSE_FUNCTION_15_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_16') out=(' ')
application_string name=('FSE_FUNCTION_16_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_1') out=('align_screen bottom=first_screen')
application_string name=('FSE_FUNCTION_SHIFT_1_LABEL') out=(' Bkw  ')

application_string name=('FSE_FUNCTION_SHIFT_2') out=('align_screen bottom=current')
application_string name=('FSE_FUNCTION_SHIFT_2_LABEL') out=('LineDn')

application_string name=('FSE_FUNCTION_SHIFT_3') out=('move_text l=m p=b')
application_string name=('FSE_FUNCTION_SHIFT_3_LABEL') out=(' Move ')

application_string name=('FSE_FUNCTION_SHIFT_4') out=('unmark')
application_string name=('FSE_FUNCTION_SHIFT_4_LABEL') out=('UnMark')

application_string name=('FSE_FUNCTION_SHIFT_5') out=('end_file')
application_string name=('FSE_FUNCTION_SHIFT_5_LABEL') out=(' Back ')

application_string name=('FSE_FUNCTION_SHIFT_6') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_6_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_7') out=('position_cursor r=$home_row c=1')
application_string name=('FSE_FUNCTION_SHIFT_7_LABEL') out=(' Home ')

application_string name=('FSE_FUNCTION_SHIFT_8') out=('locate_next')
application_string name=('FSE_FUNCTION_SHIFT_8_LABEL') out=('LocNxt')

application_string name=('FSE_FUNCTION_SHIFT_9') out=('join_text')
application_string name=('FSE_FUNCTION_SHIFT_9_LABEL') out=(' Join ')

application_string name=('FSE_FUNCTION_SHIFT_10') out=('align_screen middle=last')
application_string name=('FSE_FUNCTION_SHIFT_10_LABEL') out=(' Last ')

application_string name=('FSE_FUNCTION_SHIFT_11') out=('delete_characters c=c')
application_string name=('FSE_FUNCTION_SHIFT_11_LABEL') out=('DelCh ')

application_string name=('FSE_FUNCTION_SHIFT_12') out=('delete_lines l=c')
application_string name=('FSE_FUNCTION_SHIFT_12_LABEL') out=('DelLn ')

application_string name=('FSE_FUNCTION_SHIFT_13') out=('activate_screen')
application_string name=('FSE_FUNCTION_SHIFT_13_LABEL') out=('Refrsh')

application_string name=('FSE_FUNCTION_SHIFT_14') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_14_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_15') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_15_LABEL') out=(' ')

application_string name=('FSE_FUNCTION_SHIFT_16') out=(' ')
application_string name=('FSE_FUNCTION_SHIFT_16_LABEL') out=(' ')


"   KEY REDEFINITIONS FOR THE FULL SCREEN EDITOR WHEN USED FROM THE PROGRAMMING ENVIRONMENT "

application_string name=('pe_fix_allerr_func') out=('key=9 shift=true')
application_string name=('pe_fix_assist_func') out=('key=5 shift=false')
application_string name=('pe_fix_format_func') out=('key=8 shift=true')
application_string name=('pe_fix_lookup_func') out=('key=9 shift=false')
application_string name=('pe_fix_nxterr_func') out=('key=6 shift=false')
application_string name=('pe_fix_nxtler_func') out=('key=6 shift=true')
application_string name=('pe_fix_run_func')    out=('key=2 shift=false')
application_string name=('pe_fix_rundbg_func') out=('key=2 shift=true')

application_string name=('pe_fixl_assist_func') out=('key=5 shift=false')
application_string name=('pe_fixl_format_func') out=('key=8 shift=true')
application_string name=('pe_fixl_lookup_func') out=('key=9 shift=false')
application_string name=('pe_fixl_nxterr_func') out=('key=6 shift=false')
application_string name=('pe_fixl_run_func')    out=('key=2 shift=false')
application_string name=('pe_fixl_rundbg_func') out=('key=2 shift=true')

application_string name=('pe_template_modify_format_func') out=('key=8 shift=true')
application_string name=('pe_template_modify_lookup_func') out=('key=9 shift=false')

application_string name=('pe_modify_create_format_func') out=('key=8 shift=true')
application_string name=('pe_modify_create_lookup_func') out=('key=9 shift=false')
application_string name=('pe_modify_create_run_func')    out=('key=2 shift=false')
application_string name=('pe_modify_create_rundbg_func') out=('key=2 shift=true')

application_string name=('pe_view_end_func')    out=('key=8 shift=false')
application_string name=('pe_view_export_func') out=('key=8 shift=true')
application_string name=('pe_view_print_func')  out=('key=9 shift=false')

"   END OF TERMINAL DEFINITION FILE FOR TAB 132/15 TERMINAL                   "
*DECK DECK=CSM$TAB_132_EDIT EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR TAB 132 EDIT TERMINAL                        "

"   VARIABLES                                                                 "

prefix              = (esc '[')
prefix_2            = (esc '_')
suffix              = (esc '\')

ansi                = (esc '<')
ascii               = (esc '(B' esc ')0' si)
clear_home          = (prefix '2J')
deckpam             = (esc '=')        " shifted keypad                "
deckpnm             = (esc '>')        " normal keypad                 "
deckckm             = (prefix '?1l')   " ansi cursor keys              "
decstbm             = (prefix 'r')     " set margins                   "
exit_edit           = (prefix '?10l')
lock_keyboard       = (prefix '2h')
normal_attributes   = (prefix 'm')
null                = ( nul nul nul nul nul nul nul nul nul nul )
reset_mode_ansi     = (prefix '1l')
reset_mode_dec      = (prefix '?1;6;11;13l')
reset_mode_tab      = (prefix '=4l')
send_nulls          = ( null null null null null null null null null null )
set_mode_ansi       = (prefix '6;16h')
set_mode_dec        = (prefix '?7;10;14;16h')
set_mode_tab1       = (prefix '=6h')
set_mode_tab2       = (prefix '=7h')
set_to_24x80        = (prefix '?3l')
set_to_24x132       = (prefix '?3h')
soft_key1 = ( prefix_2 'L1   S1    ' suffix ..
              prefix_2 'M1' esc 'Oa' suffix )
soft_key2 = ( prefix_2 'L2   S2    ' suffix ..
              prefix_2 'M2' esc 'OA' suffix )
soft_key3 = ( prefix_2 'L3   S3    ' suffix ..
              prefix_2 'M3' esc 'Ob' suffix )
soft_key4 = ( prefix_2 'L4   S4    ' suffix ..
              prefix_2 'M4' esc 'OB' suffix )
soft_key5 = ( prefix_2 'L5   S5    ' suffix ..
              prefix_2 'M5' esc 'Oc' suffix )
soft_key6 = ( prefix_2 'L6   S6    ' suffix ..
              prefix_2 'M6' esc 'OC' suffix )
soft_key7 = ( prefix_2 'L7   S7    ' suffix ..
              prefix_2 'M7' esc 'Od' suffix )
soft_key8 = ( prefix_2 'L8   S8    ' suffix ..
              prefix_2 'M8' esc 'OD' suffix )
start_alternate     = (prefix '1m')
start_blink         = (prefix '5m')
start_inverse       = (prefix '7m')
start_underline     = (prefix '4m')
stop_alternate      = (prefix 'm')
stop_blink          = (prefix 'm')
stop_inverse        = (prefix 'm')
stop_underline      = (prefix 'm')
taboff              = (prefix_2 'TABOFF' suffix)
tabon               = (prefix_2 'TABON' suffix)
tbc                 = (prefix '3g')    " clear tabs                    "
unlock_keyboard     = (prefix '2l')
vt132               = (prefix '=2l')

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'TAB_132_EDIT'
communications      type  = asynch
application_string name='driver_procedure' out='tup$bootstrap_VT132_driver'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (';')
cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 'H')
cursor_up                inout = (prefix 'A')
cursor_down              inout = (prefix 'B')
cursor_left              inout = (prefix 'D')
cursor_right             inout = (prefix 'C')

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = wrap_adjacent_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = wrap_adjacent_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
automatic_tabbing        value = FALSE
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 0
has_hidden               value = FALSE
has_protect              value = TRUE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = FALSE
tabs_to_unprotected      value = TRUE
type_ahead               value = FALSE

"   SCREEN SIZES                                                              "
set_size    rows = 24 columns = 80   out = (set_to_24x80 clear_home esc '9')
set_size    rows = 24 columns = 132  out = (set_to_24x132 clear_home esc '9')

"   SCREEN AND LINE MODE TRANSITION                                           "
initialize_terminal sc='$system.change_terminal_attributes fkc=dec_vt100'
screen_init    out = ( ansi ascii vt132 tabon deckpnm send_nulls )
screen_init    out = ( reset_mode_dec set_mode_dec decstbm send_nulls )
screen_init    out = ( reset_mode_ansi set_mode_ansi tbc send_nulls )
screen_init    out = ( reset_mode_tab set_mode_tab1 set_mode_tab2 send_nulls )
screen_init    out = ( soft_key1 soft_key2 soft_key3 soft_key4 send_nulls )
screen_init    out = ( soft_key5 soft_key6 soft_key7 soft_key8 send_nulls )

set_line_mode  out = ( ansi ascii vt132 exit_edit deckpnm send_nulls ..
                       unlock_keyboard tbc set_to_24x80 taboff )

"   TERMINAL CAPABILITIES                                                     "
delete_char         in    = (prefix 'P')
delete_line_bol     in    = (prefix 'M')
erase_end_of_line   inout = (prefix 'K')
erase_line_stay     inout = (prefix '2K')
erase_page_home     inout = (clear_home)
insert_line_bol     in    = (prefix 'L')
insert_mode_begin   in    = (prefix '4h')
insert_mode_end     in    = (prefix '4l')
tab_forward         in    = (rs)
tab_clear_all       inout = (tbc)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
backspace           in = bs

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "

f1        in = (esc 'Oa') label='S1'
f2        in = (esc 'OA') label='S2'
f3        in = (esc 'Ob') label='S3'
f4        in = (esc 'OB') label='S4'
f5        in = (esc 'Oc') label='S5'
f6        in = (esc 'OC') label='S6'
f7        in = (esc 'Od') label='S7'
f8        in = (esc 'OD') label='S8'
f9        in = ()
f10       in = ()
f11       in = ()
f12       in = ()
f13       in = ()
f14       in = ()
f15       in = ()
f16       in = ()
f1_s      in = ()
f2_s      in = ()
f3_s      in = ()
f4_s      in = ()
f5_s      in = ()
f6_s      in = ()
f7_s      in = ()
f8_s      in = ()
f9_s      in = ()
f10_s     in = ()
f11_s     in = ()
f12_s     in = ()
f13_s     in = ()
f14_s     in = ()
f15_s     in = ()
f16_s     in = ()

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = ()
fwd       in = ()
back      in = ()
help      in = ()
undo      in = ()
stop      in = ()
bkw_s     in = ()
fwd_s     in = ()
undo_s    in = ()
stop_s    in = ()
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_inverse)
alt_end             out = (stop_inverse)
blink_begin         out = (start_blink)
blink_end           out = normal_attributes
high_intensity_begin  out = (start_inverse)
high_intensity_end  out = (stop_inverse)
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
output_begin        out = (lock_keyboard prefix '}')
output_end          out = (prefix '1}' unlock_keyboard)
protect_begin       out = (start_alternate)
protect_end         out = (stop_alternate)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)



"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = so
ld_fine_end              out = si
ld_fine_horizontal       out = 'q'
ld_fine_vertical         out = 'x'
ld_fine_upper_left       out = 'l'
ld_fine_upper_right      out = 'k'
ld_fine_lower_left       out = 'm'
ld_fine_lower_right      out = 'j'
ld_fine_up_t             out = 'w'
ld_fine_down_t           out = 'v'
ld_fine_left_t           out = 't'
ld_fine_right_t          out = 'u'
ld_fine_cross            out = 'n'
ld_medium_begin          out = (so start_alternate)
ld_medium_end            out = (si stop_alternate)
ld_medium_horizontal     out = 'q'
ld_medium_vertical       out = 'x'
ld_medium_upper_left     out = 'l'
ld_medium_upper_right    out = 'k'
ld_medium_lower_left     out = 'm'
ld_medium_lower_right    out = 'j'
ld_medium_up_t           out = 'w'
ld_medium_down_t         out = 'v'
ld_medium_left_t         out = 't'
ld_medium_right_t        out = 'u'
ld_medium_cross          out = 'n'
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR TAB 132 EDIT TERMINAL                 "
*DECK DECK=CSM$TEKX_40_80 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR Tektronic Xterminal
"   Terminal is to be using xterm with special .Xdefaults entry

" To run the Tektronic terminal you need to install a resource file
" using xrdb. You may run xrdb on NOS/VE.
"
" NOS/VE Installation
"
" The following is file which is required in order to use this TDU.
" Take it out of this TDU and remove the quote from the beginning of each line
" lines.  It can then be used to run xrdb from the NOS/VE host.
" To allow these key mappings to work, put them in a file on NOS/VE and
"  execute the command:
"             xrdb whatever_filename_you_used
" ------------------ beginning of NOS/VE file _xdefaults ----------------------
"xterm*Font:         -adobe-courier-bold-r-normal--18-180-75-75-m-*
"xterm*Font1:        -adobe-courier-medium-r-normal--8-80-75-75-m-*
"xterm*Font2:        -adobe-courier-bold-r-normal--12-120-75-75-m-*
"xterm*Font3:        -adobe-courier-bold-r-normal--18-180-75-75-m-*
"xterm*Font4:        -adobe-courier-bold-r-normal--24-240-75-75-m-*
"xterm*scrollBar:          on
"xterm*saveLines:          150
"xterm*borderWidth:        2
"xterm*font:               10x20
"xterm*VT100.Geometry: 80x40+0+0
"xterm*Tek4014.fontLarge: -adobe-courier-bold-r-normal--18-180-75-75-m-*
"xterm*Tek4014.fontSmall: -adobe-courier-bold-r-normal--12-120-75-75-m-*
"xterm*Tek4014.translations: #override\
"   <Key>F1: tek-page() \n\
"   <Key>F12: set-visibility(tek,off)
"xterm*VT100.translations: #override\
"   <Key>Tab: string(0x09) string(0x0d) \n\
"   Ctrl<Key>T: string(0x14) \n\
"   Ctrl<Key>F12: set-terminal-type(tek) \n\
"   Shift<Key>Delete: string(0x1b) string([) string(M) \n\
"        <Key>Delete: string(0x1b) string([) string(P) \n\
"   Shift<Key>Insert: string(0x1b) string([) string(L) \n\
"        <Key>Insert: string(0x1b) string([) string(4h) \n\
"   Shift<Key>Home:   string(0x1b) string([) string(2J) \n\
"       <Key>Home:   string(0x1b) string([) string(H) \n\
"  Shift<Key>Prior:  string(0x1b) string([) string(5}) string(0x0d) \n\
"       <Key>Prior:  string(0x1b) string([) string(5~) string(0x0d) \n\
"  Shift<Key>Next:   string(0x1b) string([) string(6}) string(0x0d) \n\
"       <Key>Next:   string(0x1b) string([) string(6~) string(0x0d) \n\
"  Shift<Key>Up:     string(0x1b) string([) string(7~) string(0x0d) \n\
"  Shift<Key>Down:   string(0x1b) string([) string(8~) string(0x0d) \n\
"  Shift<Key>End:    string(0x1b) string([) string(K)  \n\
"       <Key>End:    string(0x1b) string([) string(4l) \n\
"  Shift<Key>F1: string(0x1b) string(O) string(P) string(0x0d) \n\
"  Shift<Key>F2: string(0x1b) string(O) string(Q) string(0x0d) \n\
"  Shift<Key>F3: string(0x1b) string(O) string(R) string(0x0d) \n\
"  Shift<Key>F4: string(0x1b) string(O) string(S) string(0x0d) \n\
"  Shift<Key>F5: string(0x1b) string(O) string(m) string(0x0d) \n\
"  Shift<Key>F6: string(0x1b) string(O) string(l) string(0x0d) \n\
"  Shift<Key>F7: string(0x1b) string(O) string(M) string(0x0d) \n\
"  Shift<Key>F8: string(0x1b) string(O) string(n) string(0x0d) \n\
"  Shift<Key>F9: string(0x1b) string(O) string(p) string(0x0d) \n\
"  Shift<Key>F10: string(0x1b) string($) string(E) string(0x0d) \n\
"  Shift<Key>F11: string(0x1b) string($) string(F) string(0x0d) \n\
"  Shift<Key>F12: string(0x1b) string($) string(G) string(0x0d) \n\
"  <Key>F1: string(0x1b) string(O) string(q) string(0x0d) \n\
"  <Key>F2: string(0x1b) string(O) string(r) string(0x0d) \n\
"  <Key>F3: string(0x1b) string(O) string(s) string(0x0d) \n\
"  <Key>F4: string(0x1b) string(O) string(t) string(0x0d) \n\
"  <Key>F5: string(0x1b) string(O) string(u) string(0x0d) \n\
"  <Key>F6: string(0x1b) string(O) string(v) string(0x0d) \n\
"  <Key>F7: string(0x1b) string(O) string(w) string(0x0d) \n\
"  <Key>F8: string(0x1b) string(O) string(x) string(0x0d) \n\
"  <Key>F9: string(0x1b) string(O) string(y) string(0x0d) \n\
"  <Key>F10: string(0x1b) string($) string(A) string(0x0d) \n\
"  <Key>F11: string(0x1b) string($) string(B) string(0x0d) \n\
"  <Key>F12: string(0x1b) string($) string(C) string(0x0d)
" ---------------------- end of NOS/VE file _xdefaults -------------------------

"   Definition of Tektronic X terminal based on VT100

"   VARIABLES
 prefix              = (1B(16) 5B(16))
 clear_home          = (prefix 32(16) 4A(16))
 clear_all_tabs      = (prefix '3g')
 disable_mouse       = (prefix '?1002l')
 enable_mouse        = (prefix '?1002h')
 set_to_40x80        = (prefix 3F(16) 33(16) 6C(16))
 set_to_40x132       = (prefix 3F(16) 33(16) 68(16))
 start_alternate     = (prefix 31(16) 6D(16))
 start_inverse       = (prefix '7' 6D(16))
 start_underline     = (prefix 34(16) 6D(16))
 normal_attributes   = (prefix 'm')
 stop_alternate      = normal_attributes
 stop_inverse        = normal_attributes
 stop_underline      = normal_attributes

"   MODEL NAME AND COMMUNICATION TYPE                                         "
 model_name          value = 'TEKX_40_80'
 communications      type  = asynch
 application_string name = 'vt100_scrolling' out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
 end_of_information  in    = (0)

 "   CURSOR POSITIONING INFORMATION                                            "
 cursor_pos_encoding      bias  = (1)   type = ansi_cursor
 cursor_pos_column_first  value = FALSE
 cursor_pos_column_length value = (0)
 cursor_pos_row_length    value = (0)
 cursor_pos_begin         out   = (prefix)
 cursor_pos_second        out   = (3B(16))
 cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
 cursor_home              inout = (prefix 48(16))  label='HOME'
 cursor_up                inout = (prefix 41(16))
 cursor_down              inout = (prefix 42(16))
 cursor_left              inout = (prefix 44(16))
 cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
 move_past_right          type  = stop_next
 move_past_left           type  = stop_next
 move_past_top            type  = stop_next
 move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
 char_past_right          type  = stop_next
 char_past_left           type  = stop_next
 char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
 clears_when_change_size  value = TRUE
 function_key_leaves_mark value = 1
 has_hidden               value = FALSE
 has_protect              value = FALSE
 home_at_top              value = TRUE
 multiple_sizes           value = TRUE
 tabs_to_home             value = FALSE
 tabs_to_tab_stops        value = TRUE
 tabs_to_unprotected      value = FALSE

"   SCREEN SIZES
 set_size       rows = 40 columns = 80   out = (set_to_40x80)
 set_size       rows = 40 columns = 132  out = (set_to_40x132)

"   SCREEN AND LINE MODE TRANSITION
 set_screen_mode     out = (1B(16) 3C(16) clear_all_tabs ..
      1B(16) 28(16) 42(16) 1B(16) 29(16) 30(16) 0F(16) 1B(16) ..
      3D(16) enable_mouse prefix '?7;1l' )

 set_line_mode       out = (1B(16) 3C(16) clear_all_tabs ..
      1B(16) 28(16) 42(16) 1B(16) 29(16) 30(16) 0F(16) 1B(16) ..
      3E(16) disable_mouse prefix '?7;1h' )

"   TERMINAL CAPABILITIES
 delete_char         in    = (prefix 50(16))         label='Delete'
 delete_line_bol     in    = (prefix 4D(16))         label='Shift-Delete'
 erase_end_of_line   inout = (prefix 4B(16))         label='Clr_EOL'
 erase_line_stay     inout = (prefix 32(16) 4B(16))
 erase_page_home     inout = (clear_home)            label='Clear_P'
 insert_line_bol     in    = (prefix 4C(16))         label='Shift-Insert'
 insert_mode_begin   in    = (prefix 34(16) 68(16))  label='Insert'
 insert_mode_end     inout = (prefix 34(16) 6C(16))  label='End'
 tab_forward         inout = (09(16))
 tab_clear_all       inout = (clear_all_tabs)
 tab_set             inout = (1B(16) 48(16))

"   MISCELLANEOUS TERMINAL SEQUENCES
 bell_nak            out = (bel)
 backspace           in = bs

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION
 f1        in = (1B(16) 4F(16) 71(16)) label='F1'
 f2        in = (1B(16) 4F(16) 72(16)) label='F2'
 f3        in = (1B(16) 4F(16) 73(16)) label='F3'
 f4        in = (1B(16) 4F(16) 74(16)) label='F4'
 f5        in = (1B(16) 4F(16) 75(16)) label='F5'
 f6        in = (1B(16) 4F(16) 76(16)) label='F6'
 f7        in = (1B(16) 4F(16) 77(16)) label='F7'
 f8        in = (1B(16) 4F(16) 78(16)) label='F8'
 f9        in = (1B(16) 4F(16) 79(16)) label='F9'
 f10       in = (1B(16) 24(16) 41(16)) label='10'
 f11       in = (1B(16) 24(16) 42(16)) label='11'
 f12       in = (1B(16) 24(16) 43(16)) label='12'
 f13       in = ()
 f14       in = ()
 f15       in = ()
 f16       in = ()
 f1_s      in = (1B(16) 4F(16) 50(16)) label='S1'
 f2_s      in = (1B(16) 4F(16) 51(16)) label='S2'
 f3_s      in = (1B(16) 4F(16) 52(16)) label='S3'
 f4_s      in = (1B(16) 4F(16) 53(16)) label='S4'
 f5_s      in = (1B(16) 4F(16) 6D(16)) label='S5'
 f6_s      in = (1B(16) 4F(16) 6C(16)) label='S6'
 f7_s      in = (1B(16) 4F(16) 4D(16)) label='S7'
 f8_s      in = (1B(16) 4F(16) 6E(16)) label='S8'
 f9_s      in = (1B(16) 4F(16) 70(16)) label='S9'
 f10_s     in = (1B(16) 24(16) 45(16)) label='10'
 f11_s     in = (1B(16) 24(16) 46(16)) label='11'
 f12_s     in = (1B(16) 24(16) 47(16)) label='12'
 f13_s     in = ()
 f14_s     in = ()
 f15_s     in = ()
 f16_s     in = ()

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION
 next      in = 13            label = 'RETURN'
 next_s    in = ()
 bkw       in = (1B(16) 5B(16) 35(16) 7E(16)) label='BKW'
 fwd       in = (1B(16) 5B(16) 36(16) 7E(16)) label='FWD'
 back      in = (1B(16) 4F(16) 73(16)) label='F3'
 help      in = (1B(16) 4F(16) 74(16)) label='F4'
 undo      in = (1B(16) 4F(16) 75(16)) label='F5'
 stop      in = (1B(16) 4F(16) 76(16)) label='F6'
 bkw_s     in = (1B(16) 5B(16) 35(16) 7D(16)) label='Shift-BKW'
 fwd_s     in = (1B(16) 5B(16) 36(16) 7D(16)) label='Shift-FWD'
 undo_s    in = (1B(16) 4F(16) 6D(16)) label='  Shift-F5'
 stop_s    in = (1B(16) 4F(16) 6C(16)) label='  Shift-F6'
 down      in = (1B(16) 5B(16) 38(16) 7E(16)) label='DOWN'
 down_s    in = ()
 up        in = (1B(16) 5b(16) 37(16) 7E(16)) label='UP'
 up_s      in = ()
 edit      in = ()
 edit_s    in = ()
 data      in = ()
 data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES
 alt_begin           out = (start_alternate)
 alt_end             out = (stop_alternate)
 blink_begin         out = (prefix 35(16) 6D(16))
 blink_end           out = normal_attributes
 inverse_begin       out = (start_inverse)
 inverse_end         out = (stop_inverse)
 underline_begin     out = (start_underline)
 underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS
 error_begin         out = (start_inverse)
 error_end           out = (stop_inverse)
 input_text_begin    out = (start_underline)
 input_text_end      out = (stop_underline)
 italic_begin        out = (start_inverse)
 italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION
 ld_fine_begin            out = 0E(16)
 ld_fine_end              out = 0F(16)
 ld_fine_horizontal       out = 71(16)
 ld_fine_vertical         out = 78(16)
 ld_fine_upper_left       out = 6C(16)
 ld_fine_upper_right      out = 6B(16)
 ld_fine_lower_left       out = 6D(16)
 ld_fine_lower_right      out = 6A(16)
 ld_fine_up_t             out = 77(16)
 ld_fine_down_t           out = 76(16)
 ld_fine_left_t           out = 74(16)
 ld_fine_right_t          out = 75(16)
 ld_fine_cross            out = 6E(16)
 ld_medium_begin          out = (0E(16) start_alternate)
 ld_medium_end            out = (0F(16) stop_alternate)
 ld_medium_horizontal     out = 71(16)
 ld_medium_vertical       out = 78(16)
 ld_medium_upper_left     out = 6C(16)
 ld_medium_upper_right    out = 6B(16)
 ld_medium_lower_left     out = 6D(16)
 ld_medium_lower_right    out = 6A(16)
 ld_medium_up_t           out = 77(16)
 ld_medium_down_t         out = 76(16)
 ld_medium_left_t         out = 74(16)
 ld_medium_right_t        out = 75(16)
 ld_medium_cross          out = 6E(16)
 ld_bold_begin            out = (start_inverse)
 ld_bold_end              out = (stop_inverse)
 ld_bold_horizontal       out = (' ')
 ld_bold_vertical         out = (' ')
 ld_bold_upper_left       out = (' ')
 ld_bold_upper_right      out = (' ')
 ld_bold_lower_left       out = (' ')
 ld_bold_lower_right      out = (' ')
 ld_bold_up_t             out = (' ')
 ld_bold_down_t           out = (' ')
 ld_bold_left_t           out = (' ')
 ld_bold_right_t          out = (' ')
 ld_bold_cross            out = (' ')

"   END OF TERMINAL DEFINITION FILE FOR Tektronic X terminal.
*DECK DECK=CSM$TEK_4109 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR TEKTRONIX T4109 TERMINAL
"      NOS/VE VERSION
"
"   Copyright Control Data Systems Inc. 1992
"
"   AUTHOR: Kirk M. Hoaglund
"           CIM Division
"           AHS225
"           (612) 482-6055
"
"   TO COMPILE: /deft tek4109 b=tek_4109
"
"   TO COMPILE: /deft tek4109 b=tek_4109
"
"   TO USE:     /setpa al=tek_4109
"               /setta tm=tek_4109
"
"
"
"   Keys are defined as:
"
"   +------+------+------+------+   +------+------+------+------+
"   |  F1  |  F2  |  F3  |  F4  |   |  F5  |  F6  |  F7  |  F8  |  SHIFT
"   |  f1  |  f2  |  f3  |  f4  |   |  f5  |  f6  |  f7  |  f8  |  normal
"   +------+------+------+------+   +------+------+------+------+
"
"                                   +------+------+------+------+
"                                   | RepM | Back | HELP |clrSCR|
"                                   | InsM | Data | help |clrEOL|
"                                   +------+------+------+------+
"                            SHIFT  | BKW  | UP   | delL | delC |
"                           normal  | bkw  | up   | delC | delL |
"                                   +------+------+------+------+
"                                   | FWD  | DWN  | insL |      |
"                                   | fwd  | dwn  | insC |      |
"                                   +-------------+------| insC |
"                                   |             | EDIT | insL |
"                                   |    HOME     | edit |      |
"                                   +-------------+------+------+
"
"
"   +------+------+------+------+   +------+------+------+------+
"   |  F9  | F10  | F11  | F12  |   | F13  | F14  | F15  | F16  | cntrl-shft
"   |  f9  | f10  | f11  | f12  |   | f13  | f14  | f15  | f16  | control
"   +------+------+------+------+   +------+------+------+------+
"
"                                   +------+------+------+------+
"                                   |  F7  |  F8  |  F9  | F14  |
"                                   |  f7  |  f8  |  f9  | f14  |
"                                   +------+------+------+------+
"                  control-SHIFT    |  F4  |  F5  |  F6  | F15  |
"                        control    |  f4  |  f5  |  f6  | f15  |
"                                   +------+------+------+------+
"                                   |  F1  |  F2  |  F3  |      |
"                                   |  f1  |  f2  |  f3  |      |
"                                   +-------------+------|      |
"                                   |             |      |      |
"                                   |    HOME     |      |      |
"                                   +-------------+------+------+
"
"   The cursor is controlled by the JoyDisk in the obvious manner.
"      normal JoyDisk = cursor moves one space/line
"      shift  JoyDisk = cursor moves two spaces/lines
"     control JoyDisk = cursor moves four spaces/lines
"  cntrl-shft JoyDisk = cursor moves eight space/lines
"
"   Diagonal moves are supported.
"
"   Other keys (for compatibility):
"
"                           CONTROL:
"                           +------+------+------+------+
"                           | bkw  | home | InsC | DelC |
"                           |  Q   |  W   |  E   |  R   |
"  Tek 4115 Style           ++-----++-----++-----++-----++
"  Standard Keys and         | left | down |  up  |right |
"       Cursor control       |  A   |  S   |  D   |  F   |
"                            ++-----++-----++-----++-----++
"                             | fwd  | edit | InsL | DelL |
"                             |  Z   |  X   |  C   |  V   |
"                             +------+------+------+------+
"
"
"
"   MISC. VARIABLES                                                                 "

    csi                 = ( esc '[' )
    function            = ( esc 'O' )
    extra_func          = ( esc 'P' )
    select_code_tek     = ( esc '%!0' )
    select_code_ansi    = ( esc '%!1' )
    int_32              = ( 'B0' )
    int_80              = ( 'E0' )
    int_100             = ( 'F4' )

"   KEYBOARD MACRO CONTROL CODES

"      JOY DISK KEYCODES

    int_joy_right       = ( 'H''')
    int_joy_up          = ( 'H(' )
    int_joy_left        = ( 'H)' )
    int_joy_down        = ( 'H*' )
    int_joy_right_s     = ( 'H+' )
    int_joy_up_s        = ( 'H,' )
    int_joy_left_s      = ( 'H-' )
    int_joy_down_s      = ( 'H.' )
    int_joy_right_c     = ( 'H/' )
    int_joy_up_c        = ( 'I ' )
    int_joy_left_c      = ( 'I!' )
    int_joy_down_c      = ( 'I"' )
    int_joy_right_cs    = ( 'I#' )
    int_joy_up_cs       = ( 'I$' )
    int_joy_left_cs     = ( 'I%' )
    int_joy_down_cs     = ( 'I&' )

"      KEY PAD KEYCODES
"              unshifted

    int_pad_0           = ( 'C''')
    int_pad_1           = ( 'C(' )
    int_pad_2           = ( 'C)' )
    int_pad_3           = ( 'C*' )
    int_pad_4           = ( 'C+' )
    int_pad_5           = ( 'C,' )
    int_pad_6           = ( 'C-' )
    int_pad_7           = ( 'C.' )
    int_pad_8           = ( 'C/' )
    int_pad_9           = ( 'D ' )
    int_pad_dash        = ( 'D#' )
    int_pad_comma       = ( 'D"' )
    int_pad_enter       = ( 'D$' )
    int_pad_period      = ( 'D!' )

"              shifted

    int_pad_0_s         = ( 'D%' )
    int_pad_1_s         = ( 'D&' )
    int_pad_2_s         = ( 'D''')
    int_pad_3_s         = ( 'D(' )
    int_pad_4_s         = ( 'D)' )
    int_pad_5_s         = ( 'D*' )
    int_pad_6_s         = ( 'D+' )
    int_pad_7_s         = ( 'D,' )
    int_pad_8_s         = ( 'D-' )
    int_pad_9_s         = ( 'D.' )
    int_pad_dash_s      = ( 'E!' )
    int_pad_comma_s     = ( 'E ' )
    int_pad_enter_s     = ( 'E"' )
    int_pad_period_s    = ( 'D/' )

"              controlled

    int_pad_0_c         = ( 'E#' )
    int_pad_1_c         = ( 'E$' )
    int_pad_2_c         = ( 'E%' )
    int_pad_3_c         = ( 'E&' )
    int_pad_4_c         = ( 'E''')
    int_pad_5_c         = ( 'E(' )
    int_pad_6_c         = ( 'E)' )
    int_pad_7_c         = ( 'E*' )
    int_pad_8_c         = ( 'E+' )
    int_pad_9_c         = ( 'E,' )
    int_pad_dash_c      = ( 'E/' )
    int_pad_comma_c     = ( 'E.' )
    int_pad_enter_c     = ( 'F0' )
    int_pad_period_c    = ( 'E-' )

"              control-shifted

    int_pad_0_cs        = ( 'F!' )
    int_pad_1_cs        = ( 'F"' )
    int_pad_2_cs        = ( 'F#' )
    int_pad_3_cs        = ( 'F$' )
    int_pad_4_cs        = ( 'F%' )
    int_pad_5_cs        = ( 'F&' )
    int_pad_6_cs        = ( 'F''')
    int_pad_7_cs        = ( 'F(' )
    int_pad_8_cs        = ( 'F)' )
    int_pad_9_cs        = ( 'F*' )
    int_pad_dash_cs     = ( 'F-' )
    int_pad_comma_cs    = ( 'F,' )
    int_pad_enter_cs    = ( 'F.' )
    int_pad_period_cs   = ( 'F+' )

"      FUNCTION KEY KEYCODES
"              unshifted

    int_f1              = ( 'H0' )
    int_f2              = ( 'H1' )
    int_f3              = ( 'H2' )
    int_f4              = ( 'H3' )
    int_f5              = ( 'H4' )
    int_f6              = ( 'H5' )
    int_f7              = ( 'H6' )
    int_f8              = ( 'H7' )
    int_f9              = ( '"'  )
    int_f10             = ( '#'  )
    int_f11             = ( '$'  )
    int_f12             = ( '%'  )
    int_f13             = ( '&'  )
    int_f14             = ( '''' )
    int_f15             = ( '('  )
    int_f16             = ( ')'  )

"              shifted

    int_f1_s            = ( 'H8' )
    int_f2_s            = ( 'H9' )
    int_f3_s            = ( 'H:' )
    int_f4_s            = ( 'H;' )
    int_f5_s            = ( 'H<' )
    int_f6_s            = ( 'H=' )
    int_f7_s            = ( 'H>' )
    int_f8_s            = ( 'H?' )
    int_f9_s            = ( '*'  )
    int_f10_s           = ( '+'  )
    int_f11_s           = ( ','  )
    int_f12_s           = ( '-'  )
    int_f13_s           = ( '.'  )
    int_f14_s           = ( '/'  )
    int_f15_s           = ( 'A ' )
    int_f16_s           = ( 'A!' )

"     TEK4115 STYLE CURSOR CONTROL AND STANDARD KEY CODES

    int_q_c             = ( 'A1' )
    int_w_c             = ( 'A7' )
    int_e_c             = ( '5'  )
    int_r_c             = ( 'A2' )
    int_a_c             = ( '1'  )
    int_s_c             = ( 'A3' )
    int_d_c             = ( '4'  )
    int_f_c             = ( '6'  )
    int_z_c             = ( 'A:' )
    int_x_c             = ( 'A8' )
    int_c_c             = ( '3'  )
    int_v_c             = ( 'A6' )

"      MISC. KEY CODES

    int_tab_s           = ( 'B.' )

"      TEK INT CODES FOR VARIOUS CHARACTER SEQUENCES

    int_esc             = ( 'A;' )
    int_cr              = ( '=' )
    int_csi             = ( int_esc 'E;' )
    int_ch_4            = ( 'C4' )
    int_EP              = ( 'B1' )
    int_AT              = ( 'D0' )
    int_PS              = ( 'B3' )
    int_DS              = ( 'B4' )
    int_PC              = ( 'B5' )
    int_UA              = ( 'E>' )
    int_GT              = ( 'C>' )
    int_dot             = ( 'B>' )
    int_star            = ( 'B:' )
    int_A               = ( 'D1' )
    int_B               = ( 'D2' )
    int_C               = ( 'D3' )
    int_D               = ( 'D4' )
    int_E               = ( 'D5' )
    int_F               = ( 'D6' )
    int_G               = ( 'D7' )
    int_H               = ( 'D8' )
    int_I               = ( 'D9' )
    int_J               = ( 'D:' )
    int_K               = ( 'D;' )
    int_L               = ( 'D<' )
    int_M               = ( 'D=' )
    int_N               = ( 'D>' )
    int_O               = ( 'D?' )
    int_P               = ( 'E0' )
    int_Z               = ( 'E:' )
    int_l_a             = ( 'F1' )
    int_l_b             = ( 'F2' )
    int_l_c             = ( 'F3' )
    int_l_d             = ( 'F4' )
    int_l_e             = ( 'F5' )
    int_l_f             = ( 'F6' )
    int_l_g             = ( 'F7' )
    int_l_h             = ( 'F8' )
    int_l_i             = ( 'F9' )
    int_l_j             = ( 'F:' )
    int_l_k             = ( 'F;' )
    int_l_l             = ( 'F<' )
    int_l_m             = ( 'F=' )
    int_l_n             = ( 'F>' )
    int_l_o             = ( 'F?' )
    int_l_p             = ( 'G0' )
    int_0               = ( 'C0' )
    int_1               = ( 'C1' )
    int_2               = ( 'C2' )
    int_3               = ( 'C3' )
    int_4               = ( 'C4' )
    int_5               = ( 'C5' )
    int_6               = ( 'C6' )
    int_7               = ( 'C7' )
    int_8               = ( 'C8' )
    int_9               = ( 'C9' )

"      SENDING SEQUENCES

    define_macro        = ( esc 'KD' )
    clear_all_macros    = ( define_macro '!' '0' )

    set_screen_size     = ( select_code_tek esc 'LB' int_32 esc 'LL' ..
                            int_32 select_code_tek esc 'LC' int_80 ..
                            esc '8' esc 'LV' '1' select_code_ansi )

    start_alternate     = ( csi '1m' )
    stop_alternate      = ( csi 'm' )
    start_inverse       = ( csi '7m' )
    stop_inverse        = ( csi 'm' )
    start_underline     = ( csi '4m' )
    stop_underline      = ( csi 'm' )
    start_blink         = ( csi '5m')
    stop_blink          = ( csi 'm')

    forward_tab         = ( 09(16) )
    backward_tab        = ( csi 'Z' )
    clear_all_tabs      = ( csi '3g' )
    set_tab             = ( esc 'H' )

    set_table_1         = ( esc 'KT4' esc 'TM111' esc 'RD14' esc 'RI211' ..
                            esc 'TFA4' )
    set_table_2         = ( '0' '0'     '0'     '0'     ..
                            '1' int_100 int_100 int_100 )
    set_table_3         = ( '2' int_100 '0'     '0'     ..
                            '3' '0'     int_100 '0'     ..
                            '4' '0'     '0'     int_100 )
    set_color_table     = ( set_table_1 set_table_2 set_table_3 )

    set_alpha_cursor    = ( esc 'TD31' )


"     FUNCTION KEY PROGRAM MACROS
"     Tek function keys: unshifted F1..F8      are F1..F8
"                          shifted F1..F8      are shift F1..F8
"                          control F1..F8      are F9..F16
"                  control-shifted F1..F8      are shift F9..F16

    macro_f1    = ( define_macro int_f1  '4' int_esc int_O int_A int_cr )
    macro_f2    = ( define_macro int_f2  '4' int_esc int_O int_B int_cr )
    macro_f3    = ( define_macro int_f3  '4' int_esc int_O int_C int_cr )
    macro_f4    = ( define_macro int_f4  '4' int_esc int_O int_D int_cr )
    macro_f5    = ( define_macro int_f5  '4' int_esc int_O int_E int_cr )
    macro_f6    = ( define_macro int_f6  '4' int_esc int_O int_F int_cr )
    macro_f7    = ( define_macro int_f7  '4' int_esc int_O int_G int_cr )
    macro_f8    = ( define_macro int_f8  '4' int_esc int_O int_H int_cr )
    macro_f9    = ( define_macro int_f9  '4' int_esc int_O int_I int_cr )
    macro_f10   = ( define_macro int_f10 '4' int_esc int_O int_J int_cr )
    macro_f11   = ( define_macro int_f11 '4' int_esc int_O int_K int_cr )
    macro_f12   = ( define_macro int_f12 '4' int_esc int_O int_L int_cr )
    macro_f13   = ( define_macro int_f13 '4' int_esc int_O int_M int_cr )
    macro_f14   = ( define_macro int_f14 '4' int_esc int_O int_N int_cr )
    macro_f15   = ( define_macro int_f15 '4' int_esc int_O int_O int_cr )
    macro_f16   = ( define_macro int_f16 '4' int_esc int_O int_P int_cr )
    macro_f1_s  = ( define_macro int_f1_s  '4' int_esc int_O int_l_a int_cr )
    macro_f2_s  = ( define_macro int_f2_s  '4' int_esc int_O int_l_b int_cr )
    macro_f3_s  = ( define_macro int_f3_s  '4' int_esc int_O int_l_c int_cr )
    macro_f4_s  = ( define_macro int_f4_s  '4' int_esc int_O int_l_d int_cr )
    macro_f5_s  = ( define_macro int_f5_s  '4' int_esc int_O int_l_e int_cr )
    macro_f6_s  = ( define_macro int_f6_s  '4' int_esc int_O int_l_f int_cr )
    macro_f7_s  = ( define_macro int_f7_s  '4' int_esc int_O int_l_g int_cr )
    macro_f8_s  = ( define_macro int_f8_s  '4' int_esc int_O int_l_h int_cr )
    macro_f9_s  = ( define_macro int_f9_s  '4' int_esc int_O int_l_i int_cr )
    macro_f10_s = ( define_macro int_f10_s '4' int_esc int_O int_l_j int_cr )
    macro_f11_s = ( define_macro int_f11_s '4' int_esc int_O int_l_k int_cr )
    macro_f12_s = ( define_macro int_f12_s '4' int_esc int_O int_l_l int_cr )
    macro_f13_s = ( define_macro int_f13_s '4' int_esc int_O int_l_m int_cr )
    macro_f14_s = ( define_macro int_f14_s '4' int_esc int_O int_l_n int_cr )
    macro_f15_s = ( define_macro int_f15_s '4' int_esc int_O int_l_o int_cr )
    macro_f16_s = ( define_macro int_f16_s '4' int_esc int_O int_l_p int_cr )

"     JOY PAD PROGRAM MACROS
"     Tek Joy Pad moves the cursor in obvious directions
"          unshifted moves by one character position
"            shifted moves by two character positions
"            control moves by four character positions
"      control-shift moves by eight character positions

    macro_joy_r = ( define_macro int_joy_right '3' int_csi int_C )
    macro_joy_u = ( define_macro int_joy_up    '3' int_csi int_A )
    macro_joy_l = ( define_macro int_joy_left  '3' int_csi int_D )
    macro_joy_d = ( define_macro int_joy_down  '3' int_csi int_B )

    macro_joy_rs= ( define_macro int_joy_right_s '6' int_csi int_C ..
                    int_csi int_C)
    macro_joy_us= ( define_macro int_joy_up_s '6' int_csi int_A int_csi int_A)
    macro_joy_ls= ( define_macro int_joy_left_s '6' int_csi int_D int_csi int_D)
    macro_joy_ds= ( define_macro int_joy_down_s '6' int_csi int_B int_csi int_B)

    macro_joy_rc= ( define_macro int_joy_right_c '<' int_csi int_C int_csi ..
                    int_C int_csi int_C int_csi int_C )

    macro_joy_uc= ( define_macro int_joy_up_c '<' int_csi int_A int_csi int_A ..
                    int_csi int_A int_csi int_A )

    macro_joy_lc= ( define_macro int_joy_left_c '<' int_csi int_D int_csi ..
                    int_D int_csi int_D int_csi int_D )

    macro_joy_dc= ( define_macro int_joy_down_c  '<' int_csi int_B int_csi ..
                    int_B int_csi int_B int_csi int_B )

    macro_joy_rcs=( define_macro int_joy_right_cs 'A' '8' int_csi int_C ..
                    int_csi int_C int_csi int_C int_csi int_C int_csi int_C ..
                    int_csi int_C int_csi int_C int_csi int_C )

    macro_joy_ucs=( define_macro int_joy_up_cs 'A' '8' int_csi int_A int_csi ..
                    int_A int_csi int_A int_csi int_A int_csi int_A int_csi ..
                    int_A int_csi int_A int_csi int_A )

    macro_joy_lcs=( define_macro int_joy_left_cs 'A' '8' int_csi int_D ..
                    int_csi int_D int_csi int_D int_csi int_D int_csi int_D ..
                    int_csi int_D int_csi int_D int_csi int_D )

    macro_joy_dcs=( define_macro int_joy_down_cs 'A' '8' int_csi int_B ..
                    int_csi int_B int_csi int_B int_csi int_B int_csi int_B ..
                    int_csi int_B int_csi int_B int_csi int_B )

"     NUMERIC PAD KEY PROGRAM MACROS

    macro_pad_0      = (define_macro int_pad_0 '3' int_csi int_H)
    macro_pad_1      = (define_macro int_pad_1 '4' int_esc int_P int_1 int_cr)
    macro_pad_2      = (define_macro int_pad_2 '4' int_esc int_P int_2 int_cr)
    macro_pad_3      = (define_macro int_pad_3 '3' int_csi int_AT)
    macro_pad_4      = (define_macro int_pad_4 '4' int_esc int_P int_4 int_cr)
    macro_pad_5      = (define_macro int_pad_5 '4' int_esc int_P int_5 int_cr)
    macro_pad_6      = (define_macro int_pad_6 '3' int_csi int_P)
    macro_pad_7      = (define_macro int_pad_7 '5' int_csi int_ch_4 int_l_h)
    macro_pad_8      = (define_macro int_pad_8 '4' int_esc int_P int_8 int_cr)
    macro_pad_9      = (define_macro int_pad_9 '4' int_esc int_P int_9 int_cr)
    macro_pad_dash   = (define_macro int_pad_dash   '3' int_csi int_K)
    macro_pad_comma  = (define_macro int_pad_comma  '3' int_csi int_M)
    macro_pad_enter  = (define_macro int_pad_enter  '3' int_csi int_L)
    macro_pad_period = (define_macro int_pad_period '4' int_esc int_P ..
                        int_dot int_cr)

    macro_pad_0_s    = (define_macro int_pad_0_s '3' int_csi int_H)
    macro_pad_1_s    = (define_macro int_pad_1_s '4' int_esc int_P int_EP ..
                        int_cr)
    macro_pad_2_s    = (define_macro int_pad_2_s '4' int_esc int_P int_AT ..
                        int_cr)
    macro_pad_3_s    = (define_macro int_pad_3_s '3' int_csi int_P)
    macro_pad_4_s    = (define_macro int_pad_4_s '4' int_esc int_P int_DS ..
                        int_cr)
    macro_pad_5_s    = (define_macro int_pad_5_s '4' int_esc int_P int_PC ..
                        int_cr)
    macro_pad_6_s    = (define_macro int_pad_6_s '3' int_csi int_AT)
    macro_pad_7_s    = (define_macro int_pad_7_s '5' int_csi int_ch_4 int_l_l)
    macro_pad_8_s    = (define_macro int_pad_8_s '4' int_esc int_P int_star ..
                        int_cr)
    macro_pad_9_s    = (define_macro int_pad_9_s '5' int_csi int_ch_4 int_l_l)
    macro_pad_dash_s = (define_macro int_pad_dash_s   '3' int_csi int_J)
    macro_pad_comma_s= (define_macro int_pad_comma_s  '3' int_csi int_P)
    macro_pad_enter_s= (define_macro int_pad_enter_s  '3' int_csi int_AT)
    macro_pad_period_s=(define_macro int_pad_period_s '4' int_esc int_P ..
                        int_GT int_cr)

    macro_pad_1_c    = ( define_macro int_pad_1_c '4' int_esc int_O int_A int_cr )
    macro_pad_2_c    = ( define_macro int_pad_2_c '4' int_esc int_O int_B int_cr )
    macro_pad_3_c    = ( define_macro int_pad_3_c '4' int_esc int_O int_C int_cr )
    macro_pad_4_c    = ( define_macro int_pad_4_c '4' int_esc int_O int_D int_cr )
    macro_pad_5_c    = ( define_macro int_pad_5_c '4' int_esc int_O int_E int_cr )
    macro_pad_6_c    = ( define_macro int_pad_6_c '4' int_esc int_O int_F int_cr )
    macro_pad_7_c    = ( define_macro int_pad_7_c '4' int_esc int_O int_G int_cr )
    macro_pad_8_c    = ( define_macro int_pad_8_c '4' int_esc int_O int_H int_cr )
    macro_pad_9_c    = ( define_macro int_pad_9_c '4' int_esc int_O int_I int_cr )
    macro_pad_dash_c = ( define_macro int_pad_dash_c '4' int_esc int_O int_N int_cr )
    macro_pad_comma_c= ( define_macro int_pad_comma_c '4' int_esc int_O int_O int_cr )

    macro_pad_1_cs   = ( define_macro int_pad_1_cs '4' int_esc int_O int_l_a int_cr )
    macro_pad_2_cs   = ( define_macro int_pad_2_cs '4' int_esc int_O int_l_b int_cr )
    macro_pad_3_cs   = ( define_macro int_pad_3_cs '4' int_esc int_O int_l_c int_cr )
    macro_pad_4_cs   = ( define_macro int_pad_4_cs '4' int_esc int_O int_l_d int_cr )
    macro_pad_5_cs   = ( define_macro int_pad_5_cs '4' int_esc int_O int_l_e int_cr )
    macro_pad_6_cs   = ( define_macro int_pad_6_cs '4' int_esc int_O int_l_f int_cr )
    macro_pad_7_cs   = ( define_macro int_pad_7_cs '4' int_esc int_O int_l_g int_cr )
    macro_pad_8_cs   = ( define_macro int_pad_8_cs '4' int_esc int_O int_l_h int_cr )
    macro_pad_9_cs   = ( define_macro int_pad_9_cs '4' int_esc int_O int_l_i int_cr )
    macro_pad_dash_cs= ( define_macro int_pad_dash_cs '4' int_esc int_O int_l_n int_cr )
    macro_pad_comma_cs=( define_macro int_pad_comma_cs '4' int_esc int_O int_l_o int_cr )

"     TEK4115 STYLE CURSOR CONTROL AND STANDARD KEY MACROS

    macro_q_c        = (define_macro int_q_c '4' int_esc int_P int_4 int_cr)
    macro_w_c        = (define_macro int_w_c '3' int_csi int_H)
    macro_e_c        = (define_macro int_e_c '3' int_csi int_AT)
    macro_r_c        = (define_macro int_r_c '3' int_csi int_P)
    macro_a_c        = (define_macro int_a_c '3' int_csi int_D)
    macro_s_c        = (define_macro int_s_c '3' int_csi int_B)
    macro_d_c        = (define_macro int_d_c '3' int_csi int_A)
    macro_f_c        = (define_macro int_f_c '3' int_csi int_C)
    macro_z_c        = (define_macro int_z_c '4' int_esc int_P int_1 int_cr)
    macro_x_c        = (define_macro int_x_c '4' int_esc int_P int_0 int_cr)
    macro_c_c        = (define_macro int_c_c '3' int_csi int_L)
    macro_v_c        = (define_macro int_v_c '3' int_csi int_M)

"     OTHER KEY PROGRAM MACROS

    macro_tab_s      = (define_macro int_tab_s      '3' int_csi int_Z)

"     MODE CHANGE CHARACTER SEQUENCES

    set_BG    = ( csi '30;42m' )
    set_GB    = ( csi '32;40m' )
    set_RB    = ( csi '31;40m' )
    set_RR    = ( csi '31;41m' )
    set_WB    = ( csi '37;40m' )
    set_WBl   = ( csi '37;44m' )

    init_tek  = ( esc 'SK!' esc 'SV!0' esc 'KF0' esc 'KA1' esc 'LI100' ..
                  esc 'LS1' esc 'LM0' esc 'LV1' )

    init_ansi = ( select_code_ansi csi '?8h' csi '4l' csi '2l' csi '20l' ..
                  esc ')3' )


"   MODEL NAME AND COMMUNICATION TYPE

    model_name          value = 'TEK_4109'
    communications      type  = asynch

"   END OF INFORMATION SPECIFICATION

    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION

    cursor_pos_encoding      bias  = (1)   type = ansi_cursor

"NOS: cursor_pos_encoding      bias  = (0)   type = ansi_cursor

    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (csi)
    cursor_pos_second        out   = (';')
    cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION

    cursor_home              inout = (csi 'H')  label = ('Cursor Home')
    cursor_up                inout = (csi 'A')  label = ('Cursor Up')
    cursor_down              inout = (csi 'B')  label = ('Cursor Down')
    cursor_left              inout = (csi 'D')  label = ('Cursor Left')
    cursor_right             inout = (csi 'C')  label = ('Cursor Right')

"   CURSOR BEHAVIOR (for cursor movement keys)

    move_past_right          type  = stop_next
    move_past_left           type  = stop_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)

    char_past_right          type  = stop_next
    char_past_left           type  = stop_next
    char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES

    function_key_leaves_mark value = 1

"NOS: function_key_leaves_mark value = TRUE

    automatic_tabbing        value = FALSE
    clears_when_change_size  value = TRUE
    has_hidden               value = FALSE
    has_protect              value = FALSE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = TRUE

"   SCREEN SIZES

    set_size       rows = 32 columns = 80   out = (set_screen_size)

"   SCREEN AND LINE MODE TRANSITION

    screen_init      out =    ( select_code_tek )
    screen_init      out =    ( set_color_table )
    screen_init      out =    ( set_alpha_cursor)
    screen_init      out =    ( init_tek    )
    screen_init      out =    ( macro_f1    )
    screen_init      out =    ( macro_f2    )
    screen_init      out =    ( macro_f3    )
    screen_init      out =    ( macro_f4    )
    screen_init      out =    ( macro_f5    )
    screen_init      out =    ( macro_f6    )
    screen_init      out =    ( macro_f7    )
    screen_init      out =    ( macro_f8    )
    screen_init      out =    ( macro_f9    )
    screen_init      out =    ( macro_f10   )
    screen_init      out =    ( macro_f11   )
    screen_init      out =    ( macro_f12   )
    screen_init      out =    ( macro_f13   )
    screen_init      out =    ( macro_f14   )
    screen_init      out =    ( macro_f15   )
    screen_init      out =    ( macro_f16   )
    screen_init      out =    ( macro_joy_r )
    screen_init      out =    ( macro_joy_u )
    screen_init      out =    ( macro_joy_l )
    screen_init      out =    ( macro_joy_d )
    screen_init      out =    ( macro_joy_rs)
    screen_init      out =    ( macro_joy_us)
    screen_init      out =    ( macro_joy_ls)
    screen_init      out =    ( macro_joy_ds)
    screen_init      out =    ( macro_joy_rc)
    screen_init      out =    ( macro_joy_uc)
    screen_init      out =    ( macro_joy_lc)
    screen_init      out =    ( macro_joy_dc)
    screen_init      out =    ( macro_joy_rcs)
    screen_init      out =    ( macro_joy_ucs)
    screen_init      out =    ( macro_joy_lcs)
    screen_init      out =    ( macro_joy_dcs)
    screen_init      out =    ( macro_f1_s  )
    screen_init      out =    ( macro_f2_s  )
    screen_init      out =    ( macro_f3_s  )
    screen_init      out =    ( macro_f4_s  )
    screen_init      out =    ( macro_f5_s  )
    screen_init      out =    ( macro_f6_s  )
    screen_init      out =    ( macro_f7_s  )
    screen_init      out =    ( macro_f8_s  )
    screen_init      out =    ( macro_f9_s  )
    screen_init      out =    ( macro_f10_s )
    screen_init      out =    ( macro_f11_s )
    screen_init      out =    ( macro_f12_s )
    screen_init      out =    ( macro_f13_s )
    screen_init      out =    ( macro_f14_s )
    screen_init      out =    ( macro_f15_s )
    screen_init      out =    ( macro_f16_s )
    screen_init      out =    ( macro_pad_0 )
    screen_init      out =    ( macro_pad_1 )
    screen_init      out =    ( macro_pad_2 )
    screen_init      out =    ( macro_pad_3 )
    screen_init      out =    ( macro_pad_4 )
    screen_init      out =    ( macro_pad_5 )
    screen_init      out =    ( macro_pad_6 )
    screen_init      out =    ( macro_pad_7 )
    screen_init      out =    ( macro_pad_8 )
    screen_init      out =    ( macro_pad_9 )
    screen_init      out =    ( macro_pad_dash)
    screen_init      out =    ( macro_pad_comma)
    screen_init      out =    ( macro_pad_enter)
    screen_init      out =    ( macro_pad_period)
    screen_init      out =    ( macro_pad_0_s)
    screen_init      out =    ( macro_pad_1_s)
    screen_init      out =    ( macro_pad_2_s)
    screen_init      out =    ( macro_pad_3_s)
    screen_init      out =    ( macro_pad_4_s)
    screen_init      out =    ( macro_pad_5_s)
    screen_init      out =    ( macro_pad_6_s)
    screen_init      out =    ( macro_pad_7_s)
    screen_init      out =    ( macro_pad_8_s)
    screen_init      out =    ( macro_pad_9_s)
    screen_init      out =    ( macro_pad_dash_s)
    screen_init      out =    ( macro_pad_comma_s)
    screen_init      out =    ( macro_pad_enter_s)
    screen_init      out =    ( macro_pad_period_s)
    screen_init      out =    ( macro_pad_1_c)
    screen_init      out =    ( macro_pad_2_c)
    screen_init      out =    ( macro_pad_3_c)
    screen_init      out =    ( macro_pad_4_c)
    screen_init      out =    ( macro_pad_5_c)
    screen_init      out =    ( macro_pad_6_c)
    screen_init      out =    ( macro_pad_7_c)
    screen_init      out =    ( macro_pad_8_c)
    screen_init      out =    ( macro_pad_9_c)
    screen_init      out =    ( macro_pad_dash_c)
    screen_init      out =    ( macro_pad_comma_c)
    screen_init      out =    ( macro_pad_1_cs )
    screen_init      out =    ( macro_pad_2_cs )
    screen_init      out =    ( macro_pad_3_cs )
    screen_init      out =    ( macro_pad_4_cs )
    screen_init      out =    ( macro_pad_5_cs )
    screen_init      out =    ( macro_pad_6_cs )
    screen_init      out =    ( macro_pad_7_cs )
    screen_init      out =    ( macro_pad_8_cs )
    screen_init      out =    ( macro_pad_9_cs )
    screen_init      out =    ( macro_pad_dash_cs )
    screen_init      out =    ( macro_pad_comma_cs )
    screen_init      out =    ( macro_q_c   )
    screen_init      out =    ( macro_w_c   )
    screen_init      out =    ( macro_e_c   )
    screen_init      out =    ( macro_r_c   )
    screen_init      out =    ( macro_a_c   )
    screen_init      out =    ( macro_s_c   )
    screen_init      out =    ( macro_d_c   )
    screen_init      out =    ( macro_f_c   )
    screen_init      out =    ( macro_z_c   )
    screen_init      out =    ( macro_x_c   )
    screen_init      out =    ( macro_c_c   )
    screen_init      out =    ( macro_v_c   )
    screen_init      out =    ( macro_tab_s )
    screen_init      out =    ( init_ansi )

    set_line_mode    out =    ( )
    line_init        out =    ( select_code_tek clear_all_macros )

    set_screen_mode  out =    ( select_code_tek set_color_table ..
                                init_tek set_screen_size ..
                                init_ansi clear_all_tabs )



"   TERMINAL CAPABILITIES

    backspace           in    = (08(16))
    delete_char         inout = (csi 'P')     label='keypad 6'
    insert_char         inout = (csi '@')     label='keypad 3'
    insert_line_stay    inout = (csi 'L' )    label='keypad enter'
    delete_line_stay    inout = (csi 'M' )    label='keypad comma'
    erase_line_stay     inout = (csi '2K')
    erase_page_stay     inout = (csi '2J')
    erase_end_of_page   inout = (csi 'J')     label='shift keypad dash'
    erase_end_of_line   inout = (csi 'K' )    label='keypad dash'
    insert_mode_begin   inout = (csi '4h')
    insert_mode_end     inout = (csi '4l')
    tab_forward         inout = (forward_tab)
    tab_backward        inout = (backward_tab)
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (set_tab)

"   MISCELLANEOUS TERMINAL SEQUENCES

    bell_nak            out = ( bel select_code_tek esc 'TF40' int_100 '00' ..
                                  esc 'TF40000' select_code_ansi )
    output_begin        out = ( )

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION

    f1        in = (function 'A')     label = ('f1')
    f2        in = (function 'B')     label = ('f2')
    f3        in = (function 'C')     label = ('f3')
    f4        in = (function 'D')     label = ('f4')
    f5        in = (function 'E')     label = ('f5')
    f6        in = (function 'F')     label = ('f6')
    f7        in = (function 'G')     label = ('f7')
    f8        in = (function 'H')     label = ('f8')
    f9        in = (function 'I')     label = ('c1')
    f10       in = (function 'J')     label = ('c2')
    f11       in = (function 'K')     label = ('c3')
    f12       in = (function 'L')     label = ('c4')
    f13       in = (function 'M')     label = ('c5')
    f14       in = (function 'N')     label = ('c6')
    f15       in = (function 'O')     label = ('c7')
    f16       in = (function 'P')     label = ('c8')
    f1_s      in = (function 'a')     label = ('F1')
    f2_s      in = (function 'b')     label = ('F2')
    f3_s      in = (function 'c')     label = ('F3')
    f4_s      in = (function 'd')     label = ('F4')
    f5_s      in = (function 'e')     label = ('F5')
    f6_s      in = (function 'f')     label = ('F6')
    f7_s      in = (function 'g')     label = ('F7')
    f8_s      in = (function 'h')     label = ('F8')
    f9_s      in = (function 'i')     label = ('C1')
    f10_s     in = (function 'j')     label = ('C2')
    f11_s     in = (function 'k')     label = ('C3')
    f12_s     in = (function 'l')     label = ('C4')
    f13_s     in = (function 'm')     label = ('C5')
    f14_s     in = (function 'n')     label = ('C6')
    f15_s     in = (function 'o')     label = ('C7')
    f16_s     in = (function 'p')     label = ('C8')

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION

    next      in = 13  label='NEXT'
    data      in = (extra_func '8')   label = ('Data')
    data_s    in = ()                 label = ('UNUSED')
    back      in = (extra_func '*')   label = ('Back')
    back_s    in = ()                 label = ('UNUSED')
    help      in = (extra_func '9')   label = ('Help')
    help_s    in = (extra_func '(')   label = ('Shift-Help')
    down      in = (extra_func '2')   label = ('Down')
    down_s    in = (extra_func '@')   label = ('Shift-Down')
    up        in = (extra_func '5')   label = ('Up')
    up_s      in = (extra_func '%')   label = ('Shift-Up')
    fwd       in = (extra_func '1')   label = ('FWD')
    fwd_s     in = (extra_func '!')   label = ('Shift-FWD')
    bkw       in = (extra_func '4')   label = ('BKW')
    bkw_s     in = (extra_func '$')   label = ('Shift-BKW')
    edit      in = (extra_func '.')   label = ('Edit')
    edit_s    in = (extra_func '>')   label = ('Shift-Edit')
    stop      in = (function 'F')     label = ('F6')
    stop_s    in = (function 'f')     label = ('Shift-F6')
    undo      in = (function 'E')     label = ('F5')
    undo_s    in = (function 'e')     label = ('Shift-F5')

"   Optional for use with command-redo
"   bkw       in = ( stx          )   label = ('BKW')
"   fwd       in = ( soh          )   label = ('FWD')

"   TERMINAL VIDEO ATTRIBUTES

    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    hidden_begin        out = (set_RR)
    hidden_end          out = (set_WB)
    inverse_begin       out = (set_BG)
    inverse_end         out = (set_WB)
    underline_begin     out = (start_underline set_GB)
    underline_end       out = (set_WB stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS

    error_begin         out = (set_RB)
    error_end           out = (set_WB)
    input_text_begin    out = (start_underline set_WBl)
    input_text_end      out = (set_WB stop_underline)
    italic_begin        out = (set_WBl)
    italic_end          out = (set_WB)


"   LINE DRAWING CHARACTER SPECIFICATION

   ld_fine_begin            out = (so )
   ld_fine_end              out = (si )
   ld_fine_horizontal       out = ('q')
   ld_fine_vertical         out = ('x')
   ld_fine_upper_left       out = ('l')
   ld_fine_upper_right      out = ('k')
   ld_fine_lower_left       out = ('m')
   ld_fine_lower_right      out = ('j')
   ld_fine_up_t             out = ('w')
   ld_fine_down_t           out = ('v')
   ld_fine_left_t           out = ('t')
   ld_fine_right_t          out = ('u')
   ld_fine_cross            out = ('n')
   ld_medium_begin          out = (so set_GB)
   ld_medium_end            out = (si set_WB)
   ld_medium_horizontal     out = ('q')
   ld_medium_vertical       out = ('x')
   ld_medium_upper_left     out = ('l')
   ld_medium_upper_right    out = ('k')
   ld_medium_lower_left     out = ('m')
   ld_medium_lower_right    out = ('j')
   ld_medium_up_t           out = ('w')
   ld_medium_down_t         out = ('v')
   ld_medium_left_t         out = ('t')
   ld_medium_right_t        out = ('u')
   ld_medium_cross          out = ('n')
   ld_bold_begin            out = (set_WBl)
   ld_bold_end              out = (set_WB )
   ld_bold_horizontal       out = (' ')
   ld_bold_vertical         out = (' ')
   ld_bold_upper_left       out = (' ')
   ld_bold_upper_right      out = (' ')
   ld_bold_lower_left       out = (' ')
   ld_bold_lower_right      out = (' ')
   ld_bold_up_t             out = (' ')
   ld_bold_down_t           out = (' ')
   ld_bold_left_t           out = (' ')
   ld_bold_right_t          out = (' ')
   ld_bold_cross            out = (' ')


"  DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR

"   END OF TERMINAL DEFINITION FILE FOR TEKTRONIX T4109 TERMINAL
*DECK DECK=CSM$TEK_4115 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR TEKTRONIX T4115 TERMINAL
"      NOS/VE VERSION
"
"   Copyright Control Data Systems Inc. 1992
"
"   AUTHOR: Kirk M. Hoaglund
"           CIM Division
"           AHS225
"           (612) 482-6055
"
"   TO COMPILE: /deft tek4115 b=tek_4115
"
"   TO COMPILE: /deft tek4115 b=tek_4115
"
"   TO USE:     /setpa al=tek_4115
"               /setta tm=tek_4115
"
"
"
"   Keys are defined as:
"
"   SHIFTED and NORMAL:
"
"      s1     s2     s3     s4         s5     s6     s7     s8
"   +------+------+------+------+   +------+------+------+------+
"   |  F1  |  F2  |  F3  |  F4  |   |  F5  |  F6  |  F7  |  F8  |  SHIFT
"   |  f1  |  f2  |  f3  |  f4  |   |  f5  |  f6  |  f7  |  f8  |  normal
"   +------+------+------+------+   +------+------+------+------+
"      f1     f2     f3     f4         f5     f6     f7     f8
"
"   CAUTION: Only F1-F8 and S1-S8 are supported for a total of
"            Sixteen function keys including shifting

"                           CONTROL:
"                           +------+------+------+------+
"                           | bkw  | home | InsC | DelC |
"                           |  Q   |  W   |  E   |  R   |
"                           ++-----++-----++-----++-----++
"  Standard Keys and         | left | down |  up  |right |
"       Cursor control       |  A   |  S   |  D   |  F   |
"                            ++-----++-----++-----++-----++
"                             | fwd  | edit | InsL | DelL |
"                             |  Z   |  X   |  C   |  V   |
"                             +------+------+------+------+
"
"
"   MISC. VARIABLES

    csi                 = ( esc '[' )
    function            = ( esc 'O' )
    extra_func          = ( esc 'P' )
    select_code_tek     = ( esc '%!0' )
    select_code_ansi    = ( esc '%!1' )
    int_32              = ( 'B0' )
    int_34              = ( 'B2' )
    int_64              = ( 'D0' )
    int_80              = ( 'E0' )
    int_100             = ( 'F4' )
    int_160             = ( 'J0' )

"   KEYBOARD MACRO CONTROL CODES

"      FUNCTION KEY KEYCODES
"              unshifted

    int_f1              = ( 'H0' )
    int_f2              = ( 'H1' )
    int_f3              = ( 'H2' )
    int_f4              = ( 'H3' )
    int_f5              = ( 'H4' )
    int_f6              = ( 'H5' )
    int_f7              = ( 'H6' )
    int_f8              = ( 'H7' )

"              shifted

    int_f1_s            = ( 'H8' )
    int_f2_s            = ( 'H9' )
    int_f3_s            = ( 'H:' )
    int_f4_s            = ( 'H;' )
    int_f5_s            = ( 'H<' )
    int_f6_s            = ( 'H=' )
    int_f7_s            = ( 'H>' )
    int_f8_s            = ( 'H?' )

"     CURSOR CONTROL AND STANDARD KEY CODES

    int_q_c             = ( 'A1' )
    int_w_c             = ( 'A7' )
    int_e_c             = ( '5'  )
    int_r_c             = ( 'A2' )
    int_a_c             = ( '1'  )
    int_s_c             = ( 'A3' )
    int_d_c             = ( '4'  )
    int_f_c             = ( '6'  )
    int_z_c             = ( 'A:' )
    int_x_c             = ( 'A8' )
    int_c_c             = ( '3'  )
    int_v_c             = ( 'A6' )

"      MISC. KEY CODES

    int_tab_s           = ( 'B.' )

"      TEK INT CODES FOR VARIOUS CHARACTER SEQUENCES

    int_esc             = ( 'A;' )
    int_cr              = ( '=' )
    int_csi             = ( int_esc 'E;' )
    int_ch_4            = ( 'C4' )
    int_EP              = ( 'B1' )
    int_AT              = ( 'D0' )
    int_PS              = ( 'B3' )
    int_DS              = ( 'B4' )
    int_PC              = ( 'B5' )
    int_UA              = ( 'E>' )
    int_GT              = ( 'C>' )
    int_dot             = ( 'B>' )
    int_star            = ( 'B:' )
    int_A               = ( 'D1' )
    int_B               = ( 'D2' )
    int_C               = ( 'D3' )
    int_D               = ( 'D4' )
    int_E               = ( 'D5' )
    int_F               = ( 'D6' )
    int_G               = ( 'D7' )
    int_H               = ( 'D8' )
    int_I               = ( 'D9' )
    int_J               = ( 'D:' )
    int_K               = ( 'D;' )
    int_L               = ( 'D<' )
    int_M               = ( 'D=' )
    int_N               = ( 'D>' )
    int_O               = ( 'D?' )
    int_P               = ( 'E0' )
    int_Z               = ( 'E:' )
    int_l_a             = ( 'F1' )
    int_l_b             = ( 'F2' )
    int_l_c             = ( 'F3' )
    int_l_d             = ( 'F4' )
    int_l_e             = ( 'F5' )
    int_l_f             = ( 'F6' )
    int_l_g             = ( 'F7' )
    int_l_h             = ( 'F8' )
    int_l_i             = ( 'F9' )
    int_l_j             = ( 'F:' )
    int_l_k             = ( 'F;' )
    int_l_l             = ( 'F<' )
    int_l_m             = ( 'F=' )
    int_l_n             = ( 'F>' )
    int_l_o             = ( 'F?' )
    int_l_p             = ( 'G0' )
    int_0               = ( 'C0' )
    int_1               = ( 'C1' )
    int_2               = ( 'C2' )
    int_3               = ( 'C3' )
    int_4               = ( 'C4' )
    int_5               = ( 'C5' )
    int_6               = ( 'C6' )
    int_7               = ( 'C7' )
    int_8               = ( 'C8' )
    int_9               = ( 'C9' )

"      SENDING SEQUENCES

    define_macro        = ( esc 'KD' )
    clear_all_macros    = ( define_macro '!0' )

    set_small_screen    = ( select_code_tek esc '8' ..
                            esc 'LB' int_34 esc 'LL' int_34 ..
                            esc 'LC' int_80 esc 'LV1' select_code_ansi )

    set_large_screen    = ( select_code_tek esc ';' ..
                            esc 'LB' int_64 esc 'LL' int_64 ..
                            esc 'LC' int_160 esc 'LV1' select_code_ansi )

    start_alternate     = ( csi '1m' )
    stop_alternate      = ( csi 'm' )
    start_inverse       = ( csi '7m' )
    stop_inverse        = ( csi 'm' )
    start_underline     = ( csi '4m' )
    stop_underline      = ( csi 'm' )
    start_blink         = ( csi '5m')
    stop_blink          = ( csi 'm')

    forward_tab         = ( 09(16) )
    backward_tab        = ( csi 'Z' )
    clear_all_tabs      = ( csi '3g' )
    set_tab             = ( esc 'H' )

    set_table_1         = ( esc 'KT4' esc 'TM111' esc 'RD14' esc 'RI211' ..
                            esc 'TG1A4' )
    set_table_2         = ( '0' '0'     '0'     '0'     ..
                            '1' int_100 int_100 int_100 )
    set_table_3         = ( '2' int_100 '0'     '0'     ..
                            '3' '0'     int_100 '0'     ..
                            '4' '0'     '0'     int_100 )
    set_color_table     = ( set_table_1 set_table_2 set_table_3 )

    set_alpha_cursor    = ( esc 'TD31' )


"     FUNCTION KEY PROGRAM MACROS
"     Tek function keys: unshifted F1..F8      are F1..F8
"                          shifted F1..F8      are shift F1..F8

    macro_f1    = ( define_macro int_f1  '4' int_esc int_O int_A int_cr )
    macro_f2    = ( define_macro int_f2  '4' int_esc int_O int_B int_cr )
    macro_f3    = ( define_macro int_f3  '4' int_esc int_O int_C int_cr )
    macro_f4    = ( define_macro int_f4  '4' int_esc int_O int_D int_cr )
    macro_f5    = ( define_macro int_f5  '4' int_esc int_O int_E int_cr )
    macro_f6    = ( define_macro int_f6  '4' int_esc int_O int_F int_cr )
    macro_f7    = ( define_macro int_f7  '4' int_esc int_O int_G int_cr )
    macro_f8    = ( define_macro int_f8  '4' int_esc int_O int_H int_cr )
    macro_f1_s  = ( define_macro int_f1_s  '4' int_esc int_O int_l_a int_cr )
    macro_f2_s  = ( define_macro int_f2_s  '4' int_esc int_O int_l_b int_cr )
    macro_f3_s  = ( define_macro int_f3_s  '4' int_esc int_O int_l_c int_cr )
    macro_f4_s  = ( define_macro int_f4_s  '4' int_esc int_O int_l_d int_cr )
    macro_f5_s  = ( define_macro int_f5_s  '4' int_esc int_O int_l_e int_cr )
    macro_f6_s  = ( define_macro int_f6_s  '4' int_esc int_O int_l_f int_cr )
    macro_f7_s  = ( define_macro int_f7_s  '4' int_esc int_O int_l_g int_cr )
    macro_f8_s  = ( define_macro int_f8_s  '4' int_esc int_O int_l_h int_cr )

"     CURSOR CONTROL AND STANDARD KEY MACROS

    macro_q_c        = (define_macro int_q_c '4' int_esc int_P int_4 int_cr)
    macro_w_c        = (define_macro int_w_c '3' int_csi int_H)
    macro_e_c        = (define_macro int_e_c '3' int_csi int_AT)
    macro_r_c        = (define_macro int_r_c '3' int_csi int_P)
    macro_a_c        = (define_macro int_a_c '3' int_csi int_D)
    macro_s_c        = (define_macro int_s_c '3' int_csi int_B)
    macro_d_c        = (define_macro int_d_c '3' int_csi int_A)
    macro_f_c        = (define_macro int_f_c '3' int_csi int_C)
    macro_z_c        = (define_macro int_z_c '4' int_esc int_P int_1 int_cr)
    macro_x_c        = (define_macro int_x_c '4' int_esc int_P int_0 int_cr)
    macro_c_c        = (define_macro int_c_c '3' int_csi int_L)
    macro_v_c        = (define_macro int_v_c '3' int_csi int_M)


"     OTHER KEY PROGRAM MACROS

    macro_tab_s      = (define_macro int_tab_s '3' int_csi int_Z)


"     MODE CHANGE CHARACTER SEQUENCES

    init_tek  = ( esc 'SK!' esc 'SV!0' esc 'KF0' esc 'KA1' esc 'LI100' ..
                  esc 'LS1' esc 'LM0' esc 'LV1' esc 'LJ3' )

    init_ansi = ( select_code_ansi csi '?8h' csi '4l' csi '2l' csi '20l' ..
                  esc ')3' )


"   MODEL NAME AND COMMUNICATION TYPE

    model_name          value = 'TEK_4115'
    communications      type  = asynch

"   END OF INFORMATION SPECIFICATION

    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION

    cursor_pos_encoding      bias  = (1)   type = ansi_cursor

"NOS: cursor_pos_encoding      bias  = (0)   type = ansi_cursor

    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (csi)
    cursor_pos_second        out   = (';')
    cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION

    cursor_home              inout = (csi 'H')  label = ('Cursor Home')
    cursor_up                inout = (csi 'A')  label = ('Cursor Up')
    cursor_down              inout = (csi 'B')  label = ('Cursor Down')
    cursor_left              inout = (csi 'D')  label = ('Cursor Left')
    cursor_right             inout = (csi 'C')  label = ('Cursor Right')

"   CURSOR BEHAVIOR (for cursor movement keys)

    move_past_right          type  = stop_next
    move_past_left           type  = stop_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)

    char_past_right          type  = stop_next
    char_past_left           type  = stop_next
    char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES

    function_key_leaves_mark value = 1

"NOS: function_key_leaves_mark value = TRUE

    automatic_tabbing        value = FALSE
    clears_when_change_size  value = TRUE
    has_hidden               value = FALSE
    has_protect              value = FALSE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = TRUE

"   SCREEN SIZES

    set_size       rows = 34 columns =  80   out = (set_small_screen)
    set_size       rows = 64 columns = 160   out = (set_large_screen)

"   SCREEN AND LINE MODE TRANSITION

    screen_init      out =    ( select_code_tek )
    screen_init      out =    ( set_color_table )
    screen_init      out =    ( set_alpha_cursor)
    screen_init      out =    ( init_tek    )
    screen_init      out =    ( macro_f1    )
    screen_init      out =    ( macro_f2    )
    screen_init      out =    ( macro_f3    )
    screen_init      out =    ( macro_f4    )
    screen_init      out =    ( macro_f5    )
    screen_init      out =    ( macro_f6    )
    screen_init      out =    ( macro_f7    )
    screen_init      out =    ( macro_f8    )
    screen_init      out =    ( macro_f1_s  )
    screen_init      out =    ( macro_f2_s  )
    screen_init      out =    ( macro_f3_s  )
    screen_init      out =    ( macro_f4_s  )
    screen_init      out =    ( macro_f5_s  )
    screen_init      out =    ( macro_f6_s  )
    screen_init      out =    ( macro_f7_s  )
    screen_init      out =    ( macro_f8_s  )
    screen_init      out =    ( macro_q_c   )
    screen_init      out =    ( macro_w_c   )
    screen_init      out =    ( macro_e_c   )
    screen_init      out =    ( macro_r_c   )
    screen_init      out =    ( macro_a_c   )
    screen_init      out =    ( macro_s_c   )
    screen_init      out =    ( macro_d_c   )
    screen_init      out =    ( macro_f_c   )
    screen_init      out =    ( macro_z_c   )
    screen_init      out =    ( macro_x_c   )
    screen_init      out =    ( macro_c_c   )
    screen_init      out =    ( macro_v_c   )
    screen_init      out =    ( macro_tab_s )
    screen_init      out =    ( init_ansi )

    set_line_mode    out =    ( stop_underline )
    line_init        out =    ( select_code_tek clear_all_macros )

    set_screen_mode  out =    ( select_code_tek set_color_table ..
                                init_tek set_small_screen ..
                                init_ansi clear_all_tabs )


"   TERMINAL CAPABILITIES

    backspace           in    = (08(16))
    delete_char         inout = (csi 'P')     label='keypad 6'
    insert_char         inout = (csi '@')     label='keypad 3'
    insert_line_stay    inout = (csi 'L' )    label='keypad enter'
    delete_line_stay    inout = (csi 'M' )    label='keypad comma'
    erase_line_stay     inout = (csi '2K')
    erase_page_stay     inout = (csi '2J')
    erase_end_of_page   inout = (csi 'J')
    erase_end_of_line   inout = (csi 'K' )
    insert_mode_begin   inout = (csi '4h')
    insert_mode_end     inout = (csi '4l')
    tab_forward         inout = (forward_tab)
    tab_backward        inout = (backward_tab)
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (set_tab)

"   MISCELLANEOUS TERMINAL SEQUENCES

    bell_nak            out = (bel bel)
    output_begin        out = ( )

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION

    f1        in = (function 'A')     label = ('f1')
    f2        in = (function 'B')     label = ('f2')
    f3        in = (function 'C')     label = ('f3')
    f4        in = (function 'D')     label = ('f4')
    f5        in = (function 'E')     label = ('f5')
    f6        in = (function 'F')     label = ('f6')
    f7        in = (function 'G')     label = ('f7')
    f8        in = (function 'H')     label = ('f8')
    f1_s      in = (function 'a')     label = ('s1')
    f2_s      in = (function 'b')     label = ('s2')
    f3_s      in = (function 'c')     label = ('s3')
    f4_s      in = (function 'd')     label = ('s4')
    f5_s      in = (function 'e')     label = ('s5')
    f6_s      in = (function 'f')     label = ('s6')
    f7_s      in = (function 'g')     label = ('s7')
    f8_s      in = (function 'h')     label = ('s8')

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION

    next      in = 13  label='NEXT'
    data      in = (extra_func '8')   label = ('Data')
    data_s    in = ()                 label = ('UNUSED')
    back      in = (extra_func '*')   label = ('Back')
    back_s    in = ()                 label = ('UNUSED')
    help      in = (extra_func '9')   label = ('Help')
    help_s    in = (extra_func '(')   label = ('Shift-Help')
    down      in = (extra_func '2')   label = ('Down')
    down_s    in = (extra_func '@')   label = ('Shift-Down')
    up        in = (extra_func '5')   label = ('Up')
    up_s      in = (extra_func '%')   label = ('Shift-Up')
    fwd       in = (extra_func '1')   label = ('FWD')
    fwd_s     in = (extra_func '!')   label = ('Shift-FWD')
    bkw       in = (extra_func '4')   label = ('BKW')
    bkw_s     in = (extra_func '$')   label = ('Shift-BKW')
    edit      in = (extra_func '.')   label = ('Edit')
    edit_s    in = (extra_func '>')   label = ('Shift-Edit')
    stop      in = (function 'F')     label = ('f6')
    stop_s    in = (function 'f')     label = ('F6')
    undo      in = (function 'E')     label = ('f5')
    undo_s    in = (function 'e')     label = ('F5')


"   TERMINAL VIDEO ATTRIBUTES

    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    hidden_begin        out = ( )
    hidden_end          out = ( )
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline start_alternate)
    underline_end       out = (stop_alternate stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS

    error_begin         out = (start_underline start_inverse)
    error_end           out = (stop_inverse stop_underline)
    input_text_begin    out = (start_underline start_alternate)
    input_text_end      out = (stop_alternate stop_underline)
    italic_begin        out = (start_alternate start_inverse)
    italic_end          out = (stop_inverse stop_alternate)


"   LINE DRAWING CHARACTER SPECIFICATION

   ld_fine_begin            out = (   )
   ld_fine_end              out = (   )
   ld_fine_horizontal       out = ('-')
   ld_fine_vertical         out = ('|')
   ld_fine_upper_left       out = ('+')
   ld_fine_upper_right      out = ('+')
   ld_fine_lower_left       out = ('+')
   ld_fine_lower_right      out = ('+')
   ld_fine_up_t             out = ('+')
   ld_fine_down_t           out = ('+')
   ld_fine_left_t           out = ('+')
   ld_fine_right_t          out = ('+')
   ld_fine_cross            out = ('+')
   ld_medium_begin          out = (start_alternate)
   ld_medium_end            out = (stop_alternate)
   ld_medium_horizontal     out = ('#')
   ld_medium_vertical       out = ('#')
   ld_medium_upper_left     out = ('#')
   ld_medium_upper_right    out = ('#')
   ld_medium_lower_left     out = ('#')
   ld_medium_lower_right    out = ('#')
   ld_medium_up_t           out = ('#')
   ld_medium_down_t         out = ('#')
   ld_medium_left_t         out = ('#')
   ld_medium_right_t        out = ('#')
   ld_medium_cross          out = ('#')
   ld_bold_begin            out = (start_inverse)
   ld_bold_end              out = (stop_inverse)
   ld_bold_horizontal       out = (' ')
   ld_bold_vertical         out = (' ')
   ld_bold_upper_left       out = (' ')
   ld_bold_upper_right      out = (' ')
   ld_bold_lower_left       out = (' ')
   ld_bold_lower_right      out = (' ')
   ld_bold_up_t             out = (' ')
   ld_bold_down_t           out = (' ')
   ld_bold_left_t           out = (' ')
   ld_bold_right_t          out = (' ')
   ld_bold_cross            out = (' ')


"   END OF TERMINAL DEFINITION FILE FOR TEKTRONIX T4115 TERMINAL
*DECK DECK=CSM$TEK_4125 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR TEKTRONIX T4125 TERMINAL
"      NOS/VE VERSION
"
"   Copyright Control Data Systems Inc. 1992
"
"   AUTHOR: Kirk M. Hoaglund
"           CIM Division
"           AHS225
"           (612) 482-6055
"
"   TO COMPILE: /deft tek4125 b=tek_4125
"
"   TO COMPILE: /deft tek4125 b=tek_4125
"
"   TO USE:     /setpa al=tek_4125
"               /setta tm=tek_4125
"
"
"
"   Keys are defined as:
"
"   SHIFTED and NORMAL:
"
"      s1     s2     s3     s4         s5     s6     s7     s8
"   +------+------+------+------+   +------+------+------+------+
"   |  F1  |  F2  |  F3  |  F4  |   |  F5  |  F6  |  F7  |  F8  |  SHIFT
"   |  f1  |  f2  |  f3  |  f4  |   |  f5  |  f6  |  f7  |  f8  |  normal
"   +------+------+------+------+   +------+------+------+------+
"      f1     f2     f3     f4         f5     f6     f7     f8
"
"            Normal Border                     Key Pad
"           +------+------+         +------+------+------+------+
"           |  4x  |  4x  |         | RepM | Back | HELP |clrSCR|
"           |  Up  | Right|         | InsM | Data | help |clrEOL|
"  Cursor   +------+------+         +------+------+------+------+
"  Control  +------+------+         | BKW  | UP   | delL | delC |
"           |  4x  |  4x  |         | bkw  | up   | delC | delL |
"           | Down | Left |         +------+------+------+------+
"           +------+------+         | FWD  | DWN  | insL |      |
"             Pan    View           | fwd  | dwn  | insC |      |
"                                   +-------------+------| insC |
"                                   |             | EDIT | insL |
"                                   |    HOME     | edit |      |
"                                   +-------------+------+------+
"
"   CONTROL and CONTROL-SHIFT
"
"      s1     s2     s3     s4         s5     s6     s7     s8
"   +------+------+------+------+   +------+------+------+------+
"   |  F9  | F10  | F11  | F12  |   | F13  | F14  | F15  | F16  |  SHIFT
"   |  f9  | f10  | f11  | f12  |   | f13  | f14  | f15  | f16  |  normal
"   +------+------+------+------+   +------+------+------+------+
"      f1     f2     f3     f4         f5     f6     f7     f8
"
"            Normal Border                     Key Pad
"           +------+------+         +------+------+------+------+
"           | BKW  | dwn  |         |  F7  |  F8  |  F9  | F14  |
"           | bkw  | up   |         |  f7  |  f8  |  f9  | f14  |
"   Page    +------+------+         +------+------+------+------+
"   Control +------+------+         |  F4  |  F5  |  F6  | F15  |
"           | FWD  |      |         |  f4  |  f5  |  f6  | f15  |
"           | fwd  | HOME |         +------+------+------+------+
"           +------+------+         |  F1  |  F2  |  F3  |      |
"             Pan    View           |  f1  |  f2  |  f3  |      |
"                                   +-------------+------|      |
"                                   |             |      |      |
"                                   |    HOME     |      |      |
"                                   +-------------+------+------+
"
"   Other keys (for compatibility):
"
"                           CONTROL:
"                           +------+------+------+------+
"                           | bkw  | home | InsC | DelC |
"                           |  Q   |  W   |  E   |  R   |
"  Tek 4115 Style           ++-----++-----++-----++-----++
"  Standard Keys and         | left | down |  up  |right |
"       Cursor control       |  A   |  S   |  D   |  F   |
"                            ++-----++-----++-----++-----++
"                             | fwd  | edit | InsL | DelL |
"                             |  Z   |  X   |  C   |  V   |
"                             +------+------+------+------+
"
"
"
"
"   MISC. VARIABLES                                                                 "

    csi                 = ( esc '[' )
    function            = ( esc 'O' )
    extra_func          = ( esc 'P' )
    select_code_tek     = ( esc '%!0' )
    select_code_ansi    = ( esc '%!1' )
    int_32              = ( 'B0' )
    int_34              = ( 'B2' )
    int_64              = ( 'D0' )
    int_80              = ( 'E0' )
    int_100             = ( 'F4' )
    int_160             = ( 'J0' )

"   KEYBOARD MACRO CONTROL CODES

"      VIEWING KEYS KEYCODES

    int_view_zoom       = ( 'A"' )
    int_view_pan        = ( 'A#' )
    int_view_nextview   = ( 'A$' )
    int_view_view       = ( 'A%' )
    int_view_zoom_s     = ( 'A&' )
    int_view_pan_s      = ( 'A''')
    int_view_nextview_s = ( 'A(' )
    int_view_view_s     = ( 'A)' )
    int_view_zoom_c     = ( 'A*' )
    int_view_pan_c      = ( 'A+' )
    int_view_nextview_c = ( 'A,' )
    int_view_view_c     = ( 'A-' )
    int_view_zoom_cs    = ( 'A.' )
    int_view_pan_cs     = ( 'A/' )
    int_view_nextview_cs= ( 'B ' )
    int_view_view_cs    = ( 'B!' )

"      KEY PAD KEYCODES
"              unshifted

    int_pad_0           = ( 'C''')
    int_pad_1           = ( 'C(' )
    int_pad_2           = ( 'C)' )
    int_pad_3           = ( 'C*' )
    int_pad_4           = ( 'C+' )
    int_pad_5           = ( 'C,' )
    int_pad_6           = ( 'C-' )
    int_pad_7           = ( 'C.' )
    int_pad_8           = ( 'C/' )
    int_pad_9           = ( 'D ' )
    int_pad_dash        = ( 'D#' )
    int_pad_comma       = ( 'D"' )
    int_pad_enter       = ( 'D$' )
    int_pad_period      = ( 'D!' )

"              shifted

    int_pad_0_s         = ( 'D%' )
    int_pad_1_s         = ( 'D&' )
    int_pad_2_s         = ( 'D''')
    int_pad_3_s         = ( 'D(' )
    int_pad_4_s         = ( 'D)' )
    int_pad_5_s         = ( 'D*' )
    int_pad_6_s         = ( 'D+' )
    int_pad_7_s         = ( 'D,' )
    int_pad_8_s         = ( 'D-' )
    int_pad_9_s         = ( 'D.' )
    int_pad_dash_s      = ( 'E!' )
    int_pad_comma_s     = ( 'E ' )
    int_pad_enter_s     = ( 'E"' )
    int_pad_period_s    = ( 'D/' )

"              controlled

    int_pad_0_c         = ( 'E#' )
    int_pad_1_c         = ( 'E$' )
    int_pad_2_c         = ( 'E%' )
    int_pad_3_c         = ( 'E&' )
    int_pad_4_c         = ( 'E''')
    int_pad_5_c         = ( 'E(' )
    int_pad_6_c         = ( 'E)' )
    int_pad_7_c         = ( 'E*' )
    int_pad_8_c         = ( 'E+' )
    int_pad_9_c         = ( 'E,' )
    int_pad_dash_c      = ( 'E/' )
    int_pad_comma_c     = ( 'E.' )
    int_pad_enter_c     = ( 'F0' )
    int_pad_period_c    = ( 'E-' )

"              control-shifted

    int_pad_0_cs        = ( 'F!' )
    int_pad_1_cs        = ( 'F"' )
    int_pad_2_cs        = ( 'F#' )
    int_pad_3_cs        = ( 'F$' )
    int_pad_4_cs        = ( 'F%' )
    int_pad_5_cs        = ( 'F&' )
    int_pad_6_cs        = ( 'F''')
    int_pad_7_cs        = ( 'F(' )
    int_pad_8_cs        = ( 'F)' )
    int_pad_9_cs        = ( 'F*' )
    int_pad_dash_cs     = ( 'F-' )
    int_pad_comma_cs    = ( 'F,' )
    int_pad_enter_cs    = ( 'F.' )
    int_pad_period_cs   = ( 'F+' )

"      FUNCTION KEY KEYCODES
"              unshifted

    int_f1              = ( 'H0' )
    int_f2              = ( 'H1' )
    int_f3              = ( 'H2' )
    int_f4              = ( 'H3' )
    int_f5              = ( 'H4' )
    int_f6              = ( 'H5' )
    int_f7              = ( 'H6' )
    int_f8              = ( 'H7' )
    int_f9              = ( '"'  )
    int_f10             = ( '#'  )
    int_f11             = ( '$'  )
    int_f12             = ( '%'  )
    int_f13             = ( '&'  )
    int_f14             = ( '''' )
    int_f15             = ( '('  )
    int_f16             = ( ')'  )

"              shifted

    int_f1_s            = ( 'H8' )
    int_f2_s            = ( 'H9' )
    int_f3_s            = ( 'H:' )
    int_f4_s            = ( 'H;' )
    int_f5_s            = ( 'H<' )
    int_f6_s            = ( 'H=' )
    int_f7_s            = ( 'H>' )
    int_f8_s            = ( 'H?' )
    int_f9_s            = ( '*'  )
    int_f10_s           = ( '+'  )
    int_f11_s           = ( ','  )
    int_f12_s           = ( '-'  )
    int_f13_s           = ( '.'  )
    int_f14_s           = ( '/'  )
    int_f15_s           = ( 'A ' )
    int_f16_s           = ( 'A!' )

"     TEK4115 STYLE CURSOR CONTROL AND STANDARD KEY CODES

    int_q_c             = ( 'A1' )
    int_w_c             = ( 'A7' )
    int_e_c             = ( '5'  )
    int_r_c             = ( 'A2' )
    int_a_c             = ( '1'  )
    int_s_c             = ( 'A3' )
    int_d_c             = ( '4'  )
    int_f_c             = ( '6'  )
    int_z_c             = ( 'A:' )
    int_x_c             = ( 'A8' )
    int_c_c             = ( '3'  )
    int_v_c             = ( 'A6' )


"      MISC. KEY CODES

    int_tab_s           = ( 'B.' )

"      TEK INT CODES FOR VARIOUS CHARACTER SEQUENCES

    int_esc             = ( 'A;' )
    int_cr              = ( '=' )
    int_csi             = ( int_esc 'E;' )
    int_ch_4            = ( 'C4' )
    int_EP              = ( 'B1' )
    int_AT              = ( 'D0' )
    int_PS              = ( 'B3' )
    int_DS              = ( 'B4' )
    int_PC              = ( 'B5' )
    int_UA              = ( 'E>' )
    int_GT              = ( 'C>' )
    int_dot             = ( 'B>' )
    int_star            = ( 'B:' )
    int_A               = ( 'D1' )
    int_B               = ( 'D2' )
    int_C               = ( 'D3' )
    int_D               = ( 'D4' )
    int_E               = ( 'D5' )
    int_F               = ( 'D6' )
    int_G               = ( 'D7' )
    int_H               = ( 'D8' )
    int_I               = ( 'D9' )
    int_J               = ( 'D:' )
    int_K               = ( 'D;' )
    int_L               = ( 'D<' )
    int_M               = ( 'D=' )
    int_N               = ( 'D>' )
    int_O               = ( 'D?' )
    int_P               = ( 'E0' )
    int_Z               = ( 'E:' )
    int_l_a             = ( 'F1' )
    int_l_b             = ( 'F2' )
    int_l_c             = ( 'F3' )
    int_l_d             = ( 'F4' )
    int_l_e             = ( 'F5' )
    int_l_f             = ( 'F6' )
    int_l_g             = ( 'F7' )
    int_l_h             = ( 'F8' )
    int_l_i             = ( 'F9' )
    int_l_j             = ( 'F:' )
    int_l_k             = ( 'F;' )
    int_l_l             = ( 'F<' )
    int_l_m             = ( 'F=' )
    int_l_n             = ( 'F>' )
    int_l_o             = ( 'F?' )
    int_l_p             = ( 'G0' )
    int_0               = ( 'C0' )
    int_1               = ( 'C1' )
    int_2               = ( 'C2' )
    int_3               = ( 'C3' )
    int_4               = ( 'C4' )
    int_5               = ( 'C5' )
    int_6               = ( 'C6' )
    int_7               = ( 'C7' )
    int_8               = ( 'C8' )
    int_9               = ( 'C9' )

"      SENDING SEQUENCES

    define_macro        = ( esc 'KD' )
    clear_all_macros    = ( define_macro '!0' )

    set_small_screen    = ( select_code_tek esc '8' ..
                            esc 'LB' int_34 esc 'LL' int_34 ..
                            esc 'LC' int_80 esc 'LV1' select_code_ansi )

    set_large_screen    = ( select_code_tek esc ';' ..
                            esc 'LB' int_64 esc 'LL' int_64 ..
                            esc 'LC' int_160 esc 'LV1' select_code_ansi )

    start_alternate     = ( csi '1m' )
    stop_alternate      = ( csi 'm' )
    start_inverse       = ( csi '7m' )
    stop_inverse        = ( csi 'm' )
    start_underline     = ( csi '4m' )
    stop_underline      = ( csi 'm' )
    start_blink         = ( csi '5m')
    stop_blink          = ( csi 'm')

    forward_tab         = ( 09(16) )
    backward_tab        = ( csi 'Z' )
    clear_all_tabs      = ( csi '3g' )
    set_tab             = ( esc 'H' )

    set_table_1         = ( esc 'KT4' esc 'TM111' esc 'RD14' esc 'RI211' ..
                            esc 'TG1A4' )
    set_table_2         = ( '0' '0'     '0'     '0'     ..
                            '1' int_100 int_100 int_100 )
    set_table_3         = ( '2' int_100 '0'     '0'     ..
                            '3' '0'     int_100 '0'     ..
                            '4' '0'     '0'     int_100 )
    set_color_table     = ( set_table_1 set_table_2 set_table_3 )

    set_alpha_cursor    = ( esc 'TD31' )


"     FUNCTION KEY PROGRAM MACROS
"     Tek function keys: unshifted F1..F8      are F1..F8
"                          shifted F1..F8      are shift F1..F8
"                          control F1..F8      are F9..F16
"                  control-shifted F1..F8      are shift F9..F16

    macro_f1    = ( define_macro int_f1  '4' int_esc int_O int_A int_cr )
    macro_f2    = ( define_macro int_f2  '4' int_esc int_O int_B int_cr )
    macro_f3    = ( define_macro int_f3  '4' int_esc int_O int_C int_cr )
    macro_f4    = ( define_macro int_f4  '4' int_esc int_O int_D int_cr )
    macro_f5    = ( define_macro int_f5  '4' int_esc int_O int_E int_cr )
    macro_f6    = ( define_macro int_f6  '4' int_esc int_O int_F int_cr )
    macro_f7    = ( define_macro int_f7  '4' int_esc int_O int_G int_cr )
    macro_f8    = ( define_macro int_f8  '4' int_esc int_O int_H int_cr )
    macro_f9    = ( define_macro int_f9  '4' int_esc int_O int_I int_cr )
    macro_f10   = ( define_macro int_f10 '4' int_esc int_O int_J int_cr )
    macro_f11   = ( define_macro int_f11 '4' int_esc int_O int_K int_cr )
    macro_f12   = ( define_macro int_f12 '4' int_esc int_O int_L int_cr )
    macro_f13   = ( define_macro int_f13 '4' int_esc int_O int_M int_cr )
    macro_f14   = ( define_macro int_f14 '4' int_esc int_O int_N int_cr )
    macro_f15   = ( define_macro int_f15 '4' int_esc int_O int_O int_cr )
    macro_f16   = ( define_macro int_f16 '4' int_esc int_O int_P int_cr )
    macro_f1_s  = ( define_macro int_f1_s  '4' int_esc int_O int_l_a int_cr )
    macro_f2_s  = ( define_macro int_f2_s  '4' int_esc int_O int_l_b int_cr )
    macro_f3_s  = ( define_macro int_f3_s  '4' int_esc int_O int_l_c int_cr )
    macro_f4_s  = ( define_macro int_f4_s  '4' int_esc int_O int_l_d int_cr )
    macro_f5_s  = ( define_macro int_f5_s  '4' int_esc int_O int_l_e int_cr )
    macro_f6_s  = ( define_macro int_f6_s  '4' int_esc int_O int_l_f int_cr )
    macro_f7_s  = ( define_macro int_f7_s  '4' int_esc int_O int_l_g int_cr )
    macro_f8_s  = ( define_macro int_f8_s  '4' int_esc int_O int_l_h int_cr )
    macro_f9_s  = ( define_macro int_f9_s  '4' int_esc int_O int_l_i int_cr )
    macro_f10_s = ( define_macro int_f10_s '4' int_esc int_O int_l_j int_cr )
    macro_f11_s = ( define_macro int_f11_s '4' int_esc int_O int_l_k int_cr )
    macro_f12_s = ( define_macro int_f12_s '4' int_esc int_O int_l_l int_cr )
    macro_f13_s = ( define_macro int_f13_s '4' int_esc int_O int_l_m int_cr )
    macro_f14_s = ( define_macro int_f14_s '4' int_esc int_O int_l_n int_cr )
    macro_f15_s = ( define_macro int_f15_s '4' int_esc int_O int_l_o int_cr )
    macro_f16_s = ( define_macro int_f16_s '4' int_esc int_O int_l_p int_cr )

"      VIEWING KEYS MACROS

    macro_view_zoom       = (define_macro int_view_zoom     '3' int_csi int_A )
    macro_view_pan        = (define_macro int_view_pan      '3' int_csi int_B )
    macro_view_nextview   = (define_macro int_view_nextview '3' int_csi int_C )
    macro_view_view       = (define_macro int_view_view     '3' int_csi int_D )

    macro_view_zoom_s     = (define_macro int_view_zoom_s ..
                                '<' int_csi int_A int_csi int_A ..
                                    int_csi int_A int_csi int_A )
    macro_view_pan_s      = (define_macro int_view_pan_s ..
                                '<' int_csi int_B int_csi int_B ..
                                    int_csi int_B int_csi int_B )
    macro_view_nextview_s = (define_macro int_view_nextview_s ..
                                '<' int_csi int_C int_csi int_C ..
                                    int_csi int_C int_csi int_C )
    macro_view_view_s     = (define_macro int_view_view_s ..
                                '<' int_csi int_D int_csi int_D ..
                                    int_csi int_D int_csi int_D )

    macro_view_zoom_c     = (define_macro int_view_zoom_c ..
                                '4' int_esc int_P int_4 int_cr)
    macro_view_pan_c      = (define_macro int_view_pan_c ..
                                '4' int_esc int_P int_1 int_cr)
    macro_view_nextview_c = (define_macro int_view_nextview_c ..
                                '4' int_esc int_P int_5 int_cr)
    macro_view_view_c     = (define_macro int_view_view_c '3' int_csi int_H)


    macro_view_zoom_cs    = (define_macro int_view_zoom_cs ..
                                '4' int_esc int_P int_DS int_cr)
    macro_view_pan_cs     = (define_macro int_view_pan_cs ..
                                '4' int_esc int_P int_EP int_cr)
    macro_view_nextview_cs= (define_macro int_view_nextview_cs ..
                                '4' int_esc int_P int_AT int_cr)
    macro_view_view_cs    = (define_macro int_view_view_cs '3' int_csi int_H)

"     NUMERIC PAD KEY PROGRAM MACROS

    macro_pad_0      = (define_macro int_pad_0 '3' int_csi int_H)
    macro_pad_1      = (define_macro int_pad_1 '4' int_esc int_P int_1 int_cr)
    macro_pad_2      = (define_macro int_pad_2 '4' int_esc int_P int_2 int_cr)
    macro_pad_3      = (define_macro int_pad_3 '3' int_csi int_AT)
    macro_pad_4      = (define_macro int_pad_4 '4' int_esc int_P int_4 int_cr)
    macro_pad_5      = (define_macro int_pad_5 '4' int_esc int_P int_5 int_cr)
    macro_pad_6      = (define_macro int_pad_6 '3' int_csi int_P)
    macro_pad_7      = (define_macro int_pad_7 '5' int_csi int_ch_4 int_l_h)
    macro_pad_8      = (define_macro int_pad_8 '4' int_esc int_P int_8 int_cr)
    macro_pad_9      = (define_macro int_pad_9 '4' int_esc int_P int_9 int_cr)
    macro_pad_dash   = (define_macro int_pad_dash   '3' int_csi int_K)
    macro_pad_comma  = (define_macro int_pad_comma  '3' int_csi int_M)
    macro_pad_enter  = (define_macro int_pad_enter  '3' int_csi int_L)
    macro_pad_period = (define_macro int_pad_period '4' int_esc int_P ..
                        int_dot int_cr)

    macro_pad_0_s    = (define_macro int_pad_0_s '3' int_csi int_H)
    macro_pad_1_s    = (define_macro int_pad_1_s '4' int_esc int_P int_EP ..
                        int_cr)
    macro_pad_2_s    = (define_macro int_pad_2_s '4' int_esc int_P int_AT ..
                        int_cr)
    macro_pad_3_s    = (define_macro int_pad_3_s '3' int_csi int_P)
    macro_pad_4_s    = (define_macro int_pad_4_s '4' int_esc int_P int_DS ..
                        int_cr)
    macro_pad_5_s    = (define_macro int_pad_5_s '4' int_esc int_P int_PC ..
                        int_cr)
    macro_pad_6_s    = (define_macro int_pad_6_s '3' int_csi int_AT)
    macro_pad_7_s    = (define_macro int_pad_7_s '5' int_csi int_ch_4 int_l_l)
    macro_pad_8_s    = (define_macro int_pad_8_s '4' int_esc int_P int_star ..
                        int_cr)
    macro_pad_9_s    = (define_macro int_pad_9_s '5' int_csi int_ch_4 int_l_l)
    macro_pad_dash_s = (define_macro int_pad_dash_s   '3' int_csi int_J)
    macro_pad_comma_s= (define_macro int_pad_comma_s  '3' int_csi int_P)
    macro_pad_enter_s= (define_macro int_pad_enter_s  '3' int_csi int_AT)
    macro_pad_period_s=(define_macro int_pad_period_s '4' int_esc int_P ..
                        int_GT int_cr)

    macro_pad_1_c    = ( define_macro int_pad_1_c '4' int_esc int_O int_A int_cr )
    macro_pad_2_c    = ( define_macro int_pad_2_c '4' int_esc int_O int_B int_cr )
    macro_pad_3_c    = ( define_macro int_pad_3_c '4' int_esc int_O int_C int_cr )
    macro_pad_4_c    = ( define_macro int_pad_4_c '4' int_esc int_O int_D int_cr )
    macro_pad_5_c    = ( define_macro int_pad_5_c '4' int_esc int_O int_E int_cr )
    macro_pad_6_c    = ( define_macro int_pad_6_c '4' int_esc int_O int_F int_cr )
    macro_pad_7_c    = ( define_macro int_pad_7_c '4' int_esc int_O int_G int_cr )
    macro_pad_8_c    = ( define_macro int_pad_8_c '4' int_esc int_O int_H int_cr )
    macro_pad_9_c    = ( define_macro int_pad_9_c '4' int_esc int_O int_I int_cr )
    macro_pad_dash_c = ( define_macro int_pad_dash_c '4' int_esc int_O int_N int_cr )
    macro_pad_comma_c= ( define_macro int_pad_comma_c '4' int_esc int_O int_O int_cr )

    macro_pad_1_cs   = ( define_macro int_pad_1_cs '4' int_esc int_O int_l_a int_cr )
    macro_pad_2_cs   = ( define_macro int_pad_2_cs '4' int_esc int_O int_l_b int_cr )
    macro_pad_3_cs   = ( define_macro int_pad_3_cs '4' int_esc int_O int_l_c int_cr )
    macro_pad_4_cs   = ( define_macro int_pad_4_cs '4' int_esc int_O int_l_d int_cr )
    macro_pad_5_cs   = ( define_macro int_pad_5_cs '4' int_esc int_O int_l_e int_cr )
    macro_pad_6_cs   = ( define_macro int_pad_6_cs '4' int_esc int_O int_l_f int_cr )
    macro_pad_7_cs   = ( define_macro int_pad_7_cs '4' int_esc int_O int_l_g int_cr )
    macro_pad_8_cs   = ( define_macro int_pad_8_cs '4' int_esc int_O int_l_h int_cr )
    macro_pad_9_cs   = ( define_macro int_pad_9_cs '4' int_esc int_O int_l_i int_cr )
    macro_pad_dash_cs= ( define_macro int_pad_dash_cs '4' int_esc int_O int_l_n int_cr )
    macro_pad_comma_cs=( define_macro int_pad_comma_cs '4' int_esc int_O int_l_o int_cr )

"     TEK4115 STYLE CURSOR CONTROL AND STANDARD KEY MACROS

    macro_q_c        = (define_macro int_q_c '4' int_esc int_P int_4 int_cr)
    macro_w_c        = (define_macro int_w_c '3' int_csi int_H)
    macro_e_c        = (define_macro int_e_c '3' int_csi int_AT)
    macro_r_c        = (define_macro int_r_c '3' int_csi int_P)
    macro_a_c        = (define_macro int_a_c '3' int_csi int_D)
    macro_s_c        = (define_macro int_s_c '3' int_csi int_B)
    macro_d_c        = (define_macro int_d_c '3' int_csi int_A)
    macro_f_c        = (define_macro int_f_c '3' int_csi int_C)
    macro_z_c        = (define_macro int_z_c '4' int_esc int_P int_1 int_cr)
    macro_x_c        = (define_macro int_x_c '4' int_esc int_P int_0 int_cr)
    macro_c_c        = (define_macro int_c_c '3' int_csi int_L)
    macro_v_c        = (define_macro int_v_c '3' int_csi int_M)


"     OTHER KEY PROGRAM MACROS

    macro_tab_s      = (define_macro int_tab_s '3' int_csi int_Z)


"     MODE CHANGE CHARACTER SEQUENCES

    init_tek  = ( esc 'SK!' esc 'SV!0' esc 'KF0' esc 'KA1' esc 'LI100' ..
                  esc 'LS1' esc 'LM0' esc 'LV1' esc 'LJ3' )

    init_ansi = ( select_code_ansi csi '?8h' csi '4l' csi '2l' csi '20l' ..
                  esc ')3' )


"   MODEL NAME AND COMMUNICATION TYPE

    model_name          value = 'TEK_4125'
    communications      type  = asynch

"   END OF INFORMATION SPECIFICATION

    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION

    cursor_pos_encoding      bias  = (1)   type = ansi_cursor

"NOS: cursor_pos_encoding      bias  = (0)   type = ansi_cursor

    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (csi)
    cursor_pos_second        out   = (';')
    cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION

    cursor_home              inout = (csi 'H')  label = ('Cursor Home')
    cursor_up                inout = (csi 'A')  label = ('Cursor Up')
    cursor_down              inout = (csi 'B')  label = ('Cursor Down')
    cursor_left              inout = (csi 'D')  label = ('Cursor Left')
    cursor_right             inout = (csi 'C')  label = ('Cursor Right')

"   CURSOR BEHAVIOR (for cursor movement keys)

    move_past_right          type  = stop_next
    move_past_left           type  = stop_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)

    char_past_right          type  = stop_next
    char_past_left           type  = stop_next
    char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES

    function_key_leaves_mark value = 1

"NOS: function_key_leaves_mark value = TRUE

    automatic_tabbing        value = FALSE
    clears_when_change_size  value = TRUE
    has_hidden               value = FALSE
    has_protect              value = FALSE
    home_at_top              value = TRUE
    multiple_sizes           value = FALSE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = TRUE

"   SCREEN SIZES

    set_size       rows = 34 columns =  80   out = (set_small_screen)
    set_size       rows = 64 columns = 160   out = (set_large_screen)

"   SCREEN AND LINE MODE TRANSITION

    screen_init      out =    ( select_code_tek )
    screen_init      out =    ( set_color_table )
    screen_init      out =    ( set_alpha_cursor)
    screen_init      out =    ( init_tek    )
    screen_init      out =    ( macro_f1    )
    screen_init      out =    ( macro_f2    )
    screen_init      out =    ( macro_f3    )
    screen_init      out =    ( macro_f4    )
    screen_init      out =    ( macro_f5    )
    screen_init      out =    ( macro_f6    )
    screen_init      out =    ( macro_f7    )
    screen_init      out =    ( macro_f8    )
    screen_init      out =    ( macro_f9    )
    screen_init      out =    ( macro_f10   )
    screen_init      out =    ( macro_f11   )
    screen_init      out =    ( macro_f12   )
    screen_init      out =    ( macro_f13   )
    screen_init      out =    ( macro_f14   )
    screen_init      out =    ( macro_f15   )
    screen_init      out =    ( macro_f16   )
    screen_init      out =    ( macro_f1_s  )
    screen_init      out =    ( macro_f2_s  )
    screen_init      out =    ( macro_f3_s  )
    screen_init      out =    ( macro_f4_s  )
    screen_init      out =    ( macro_f5_s  )
    screen_init      out =    ( macro_f6_s  )
    screen_init      out =    ( macro_f7_s  )
    screen_init      out =    ( macro_f8_s  )
    screen_init      out =    ( macro_f9_s  )
    screen_init      out =    ( macro_f10_s )
    screen_init      out =    ( macro_f11_s )
    screen_init      out =    ( macro_f12_s )
    screen_init      out =    ( macro_f13_s )
    screen_init      out =    ( macro_f14_s )
    screen_init      out =    ( macro_f15_s )
    screen_init      out =    ( macro_f16_s )
    screen_init      out =    ( macro_view_zoom )
    screen_init      out =    ( macro_view_pan )
    screen_init      out =    ( macro_view_nextview )
    screen_init      out =    ( macro_view_view )
    screen_init      out =    ( macro_view_zoom_s )
    screen_init      out =    ( macro_view_pan_s )
    screen_init      out =    ( macro_view_nextview_s )
    screen_init      out =    ( macro_view_view_s )
    screen_init      out =    ( macro_view_zoom_c )
    screen_init      out =    ( macro_view_pan_c )
    screen_init      out =    ( macro_view_nextview_c )
    screen_init      out =    ( macro_view_view_c )
    screen_init      out =    ( macro_view_zoom_cs )
    screen_init      out =    ( macro_view_pan_cs )
    screen_init      out =    ( macro_view_nextview_cs )
    screen_init      out =    ( macro_view_view_cs )
    screen_init      out =    ( macro_pad_0 )
    screen_init      out =    ( macro_pad_1 )
    screen_init      out =    ( macro_pad_2 )
    screen_init      out =    ( macro_pad_3 )
    screen_init      out =    ( macro_pad_4 )
    screen_init      out =    ( macro_pad_5 )
    screen_init      out =    ( macro_pad_6 )
    screen_init      out =    ( macro_pad_7 )
    screen_init      out =    ( macro_pad_8 )
    screen_init      out =    ( macro_pad_9 )
    screen_init      out =    ( macro_pad_dash)
    screen_init      out =    ( macro_pad_comma)
    screen_init      out =    ( macro_pad_enter)
    screen_init      out =    ( macro_pad_period)
    screen_init      out =    ( macro_pad_0_s)
    screen_init      out =    ( macro_pad_1_s)
    screen_init      out =    ( macro_pad_2_s)
    screen_init      out =    ( macro_pad_3_s)
    screen_init      out =    ( macro_pad_4_s)
    screen_init      out =    ( macro_pad_5_s)
    screen_init      out =    ( macro_pad_6_s)
    screen_init      out =    ( macro_pad_7_s)
    screen_init      out =    ( macro_pad_8_s)
    screen_init      out =    ( macro_pad_9_s)
    screen_init      out =    ( macro_pad_dash_s)
    screen_init      out =    ( macro_pad_comma_s)
    screen_init      out =    ( macro_pad_enter_s)
    screen_init      out =    ( macro_pad_period_s)
    screen_init      out =    ( macro_pad_1_c)
    screen_init      out =    ( macro_pad_2_c)
    screen_init      out =    ( macro_pad_3_c)
    screen_init      out =    ( macro_pad_4_c)
    screen_init      out =    ( macro_pad_5_c)
    screen_init      out =    ( macro_pad_6_c)
    screen_init      out =    ( macro_pad_7_c)
    screen_init      out =    ( macro_pad_8_c)
    screen_init      out =    ( macro_pad_9_c)
    screen_init      out =    ( macro_pad_dash_c)
    screen_init      out =    ( macro_pad_comma_c)
    screen_init      out =    ( macro_pad_1_cs )
    screen_init      out =    ( macro_pad_2_cs )
    screen_init      out =    ( macro_pad_3_cs )
    screen_init      out =    ( macro_pad_4_cs )
    screen_init      out =    ( macro_pad_5_cs )
    screen_init      out =    ( macro_pad_6_cs )
    screen_init      out =    ( macro_pad_7_cs )
    screen_init      out =    ( macro_pad_8_cs )
    screen_init      out =    ( macro_pad_9_cs )
    screen_init      out =    ( macro_pad_dash_cs )
    screen_init      out =    ( macro_pad_comma_cs )
    screen_init      out =    ( macro_q_c   )
    screen_init      out =    ( macro_w_c   )
    screen_init      out =    ( macro_e_c   )
    screen_init      out =    ( macro_r_c   )
    screen_init      out =    ( macro_a_c   )
    screen_init      out =    ( macro_s_c   )
    screen_init      out =    ( macro_d_c   )
    screen_init      out =    ( macro_f_c   )
    screen_init      out =    ( macro_z_c   )
    screen_init      out =    ( macro_x_c   )
    screen_init      out =    ( macro_c_c   )
    screen_init      out =    ( macro_v_c   )
    screen_init      out =    ( macro_tab_s )
    screen_init      out =    ( init_ansi )

    set_line_mode    out =    ( )
    line_init        out =    ( select_code_tek clear_all_macros )

    set_screen_mode  out =    ( select_code_tek set_color_table ..
                                init_tek set_small_screen ..
                                init_ansi clear_all_tabs )


"   TERMINAL CAPABILITIES

    backspace           in    = (08(16))
    delete_char         inout = (csi 'P')     label='keypad 6'
    insert_char         inout = (csi '@')     label='keypad 3'
    insert_line_stay    inout = (csi 'L' )    label='keypad enter'
    delete_line_stay    inout = (csi 'M' )    label='keypad comma'
    erase_line_stay     inout = (csi '2K')
    erase_page_stay     inout = (csi '2J')
    erase_end_of_page   inout = (csi 'J')     label='shift keypad dash'
    erase_end_of_line   inout = (csi 'K' )    label='keypad dash'
    insert_mode_begin   inout = (csi '4h')
    insert_mode_end     inout = (csi '4l')
    tab_forward         inout = (forward_tab)
    tab_backward        inout = (backward_tab)
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (set_tab)

"   MISCELLANEOUS TERMINAL SEQUENCES

    bell_nak            out = ( bel select_code_tek esc 'TF40' int_100 '00' ..
                                  esc 'TF40000' select_code_ansi )
    output_begin        out = ( )

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION

    f1        in = (function 'A')     label = ('f1')
    f2        in = (function 'B')     label = ('f2')
    f3        in = (function 'C')     label = ('f3')
    f4        in = (function 'D')     label = ('f4')
    f5        in = (function 'E')     label = ('f5')
    f6        in = (function 'F')     label = ('f6')
    f7        in = (function 'G')     label = ('f7')
    f8        in = (function 'H')     label = ('f8')
    f9        in = (function 'I')     label = ('c1')
    f10       in = (function 'J')     label = ('c2')
    f11       in = (function 'K')     label = ('c3')
    f12       in = (function 'L')     label = ('c4')
    f13       in = (function 'M')     label = ('c5')
    f14       in = (function 'N')     label = ('c6')
    f15       in = (function 'O')     label = ('c7')
    f16       in = (function 'P')     label = ('c8')
    f1_s      in = (function 'a')     label = ('F1')
    f2_s      in = (function 'b')     label = ('F2')
    f3_s      in = (function 'c')     label = ('F3')
    f4_s      in = (function 'd')     label = ('F4')
    f5_s      in = (function 'e')     label = ('F5')
    f6_s      in = (function 'f')     label = ('F6')
    f7_s      in = (function 'g')     label = ('F7')
    f8_s      in = (function 'h')     label = ('F8')
    f9_s      in = (function 'i')     label = ('C1')
    f10_s     in = (function 'j')     label = ('C2')
    f11_s     in = (function 'k')     label = ('C3')
    f12_s     in = (function 'l')     label = ('C4')
    f13_s     in = (function 'm')     label = ('C5')
    f14_s     in = (function 'n')     label = ('C6')
    f15_s     in = (function 'o')     label = ('C7')
    f16_s     in = (function 'p')     label = ('C8')

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION

    next      in = 13  label='NEXT'
    data      in = (extra_func '8')   label = ('Data')
    data_s    in = ()                 label = ('UNUSED')
    back      in = (extra_func '*')   label = ('Back')
    back_s    in = ()                 label = ('UNUSED')
    help      in = (extra_func '9')   label = ('Help')
    help_s    in = (extra_func '(')   label = ('Shift-Help')
    down      in = (extra_func '2')   label = ('Down')
    down_s    in = (extra_func '@')   label = ('Shift-Down')
    up        in = (extra_func '5')   label = ('Up')
    up_s      in = (extra_func '%')   label = ('Shift-Up')
    fwd       in = (extra_func '1')   label = ('FWD')
    fwd_s     in = (extra_func '!')   label = ('Shift-FWD')
    bkw       in = (extra_func '4')   label = ('BKW')
    bkw_s     in = (extra_func '$')   label = ('Shift-BKW')
    edit      in = (extra_func '.')   label = ('Edit')
    edit_s    in = (extra_func '>')   label = ('Shift-Edit')
    stop      in = (function 'F')     label = ('f6')
    stop_s    in = (function 'f')     label = ('F6')
    undo      in = (function 'E')     label = ('f5')
    undo_s    in = (function 'e')     label = ('F5')


"   TERMINAL VIDEO ATTRIBUTES

    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    hidden_begin        out = ( )
    hidden_end          out = ( )
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline start_alternate)
    underline_end       out = (stop_alternate stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS

    error_begin         out = (start_underline start_inverse)
    error_end           out = (stop_inverse stop_underline)
    input_text_begin    out = (start_underline start_alternate)
    input_text_end      out = (stop_alternate stop_underline)
    italic_begin        out = (start_alternate start_inverse)
    italic_end          out = (stop_inverse stop_alternate)


"   LINE DRAWING CHARACTER SPECIFICATION

   ld_fine_begin            out = (   )
   ld_fine_end              out = (   )
   ld_fine_horizontal       out = ('-')
   ld_fine_vertical         out = ('|')
   ld_fine_upper_left       out = ('+')
   ld_fine_upper_right      out = ('+')
   ld_fine_lower_left       out = ('+')
   ld_fine_lower_right      out = ('+')
   ld_fine_up_t             out = ('+')
   ld_fine_down_t           out = ('+')
   ld_fine_left_t           out = ('+')
   ld_fine_right_t          out = ('+')
   ld_fine_cross            out = ('+')
   ld_medium_begin          out = (start_alternate)
   ld_medium_end            out = (stop_alternate)
   ld_medium_horizontal     out = ('#')
   ld_medium_vertical       out = ('#')
   ld_medium_upper_left     out = ('#')
   ld_medium_upper_right    out = ('#')
   ld_medium_lower_left     out = ('#')
   ld_medium_lower_right    out = ('#')
   ld_medium_up_t           out = ('#')
   ld_medium_down_t         out = ('#')
   ld_medium_left_t         out = ('#')
   ld_medium_right_t        out = ('#')
   ld_medium_cross          out = ('#')
   ld_bold_begin            out = (start_inverse)
   ld_bold_end              out = (stop_inverse)
   ld_bold_horizontal       out = (' ')
   ld_bold_vertical         out = (' ')
   ld_bold_upper_left       out = (' ')
   ld_bold_upper_right      out = (' ')
   ld_bold_lower_left       out = (' ')
   ld_bold_lower_right      out = (' ')
   ld_bold_up_t             out = (' ')
   ld_bold_down_t           out = (' ')
   ld_bold_left_t           out = (' ')
   ld_bold_right_t          out = (' ')
   ld_bold_cross            out = (' ')

"   END OF TERMINAL DEFINITION FILE FOR TEKTRONIX T4125 TERMINAL
*DECK DECK=CSM$TERMINAL_MODELS_DESCRIPTION EXPAND=TRUE
~"create_message_module n=csm$terminal_model_messages
~"create_status_message n=CSE$TEK_4109 c=9000 i='CS' s=i
               Tektronix 4107 or 4109 Function Keys

           s1     s2     s3     s4         s5     s6     s7     s8
        +------+------+------+------+    +-----+------+------+------+
 SHIFT  |  F1  |  F2  |  F3  |  F4  |    | F5  |  F6  |  F7  |  F8  |  SHIFT
 normal |  f1  |  f2  |  f3  |  f4  |    | f5  |  f6  |  f7  |  f8  |  normal
        +------+------+------+------+    +-----+------+------+------+
           f1     f2     f3     f4         f5     f6     f7     f8


 Standard and Cursor Control Keys for Tektronix 4107 or 4109

 These keys are placed on the alphabetic keyboard and are accessed by
 combining the CTRL (CONTROL) key with the character key:

                  +------+------+------+------+
                  | bkw  | home | InsC | DelC |
                  |  Q   |  W   |  E   |  R   |
           +------++-----++-----++-----++-----++
           |       | left | down |  up  |right |
           | CTRL  |  A   |  S   |  D   |  F   |
           +-------++-----++-----++-----++-----++
                    | fwd  | edit | InsL | DelL |
                    |  Z   |  X   |  C   |  V   |
                    +------+------+------+------+

                Numeric Pad for Tektronix 4109 Terminal

 The standard keys are duplicated on the numeric pad:

    Control and Control-Shift
                    +------+------+------+------+
                    |  F7  |  F8  |  F9  | F14  |  shift
              ctrl  |  f7  |  f8  |  f9  | f14  |
                    +------+------+------+------+
                    |  F4  |  F5  |  F6  | F15  |  shift
              ctrl  |  f4  |  f5  |  f6  | f15  |
                    +------+------+------+------+
                    |  F1  |  F2  |  F3  |      |  shift
              ctrl  |  f1  |  f2  |  f3  |      |
                    +------+------+------+      |
                    |             |      |      |  shift
              ctrl  |    HOME     |      |      |
                    +-------------+------+------+

    Normal and Shift
                    +------+------+------+------+
              shift | RepM | Back | HELP |clrSCR|
                    | InsM | Data | help |clrEOL| norm
                    +------+------+------+------+
              shift | BKW  | UP   | delL | delC |
                    | bkw  | up   | delC | delL | norm
                    +------+------+------+------+
              shift | FWD  | DWN  | insL | insC |
                    | fwd  | dwn  | insC |      | norm
                    +------+------+------+      |
              shift |             | EDIT |      |
                    |    HOME     | edit | insL | norm
                    +-------------+------+------+

 Cursor control is duplicated (and enhanced) on the joydisk:

                                  up
                    up-left   /--------\
                            /     ^      \ up-right
                          /    \  |   /    \
                          |      \  /      |
                     left | <---      ---> | right
                          |     /   \      |
                          \   /   |   \    /
                 down-left  \     v      / down-right
                              \--------/
                                 down

      normal JoyDisk = cursor moves one space/line
      shift  JoyDisk = cursor moves two spaces/lines
     control JoyDisk = cursor moves four spaces/lines
  cntrl-shft JoyDisk = cursor moves eight space/lines
~"**
~"create_status_message n=CSE$TEK_4115 c=9001 i='CS' s=i
                    Tektronix 4115 Function Keys

           s1     s2     s3     s4         s5     s6     s7     s8
        +------+------+------+------+    +-----+------+------+------+
 SHIFT  |  F1  |  F2  |  F3  |  F4  |    | F5  |  F6  |  F7  |  F8  |  SHIFT
 normal |  f1  |  f2  |  f3  |  f4  |    | f5  |  f6  |  f7  |  f8  |  normal
        +------+------+------+------+    +-----+------+------+------+
           f1     f2     f3     f4         f5     f6     f7     f8


 Standard and Cursor Control Keys for Tektronix 4115

 These keys are placed on the alphabetic keyboard and are accessed by
 combining the CTRL (CONTROL) key with the character key:

                  +------+------+------+------+
                  | bkw  | home | InsC | DelC |
                  |  Q   |  W   |  E   |  R   |
           +------++-----++-----++-----++-----++
           |       | left | down |  up  |right |
           | CTRL  |  A   |  S   |  D   |  F   |
           +-------++-----++-----++-----++-----++
                    | fwd  | edit | InsL | DelL |
                    |  Z   |  X   |  C   |  V   |
                    +------+------+------+------+
~"**
~"create_status_message n=CSE$TEK_4125 c=9002 i='CS' s=i
            Tektronix 4125, 4128, or 4129 Function Keys

           s1     s2     s3     s4         s5     s6     s7     s8
        +------+------+------+------+    +-----+------+------+------+
 SHIFT  |  F1  |  F2  |  F3  |  F4  |    | F5  |  F6  |  F7  |  F8  |  SHIFT
 normal |  f1  |  f2  |  f3  |  f4  |    | f5  |  f6  |  f7  |  f8  |  normal
        +------+------+------+------+    +-----+------+------+------+
           f1     f2     f3     f4         f5     f6     f7     f8


 Standard and Cursor Control Keys for Tektronix 4125, 4128, or 4129

 These keys are placed on the alphabetic keyboard and are accessed by
 combining the CTRL (CONTROL) key with the character key:

                  +------+------+------+------+
                  | bkw  | home | InsC | DelC |
                  |  Q   |  W   |  E   |  R   |
           +------++-----++-----++-----++-----++
           |       | left | down |  up  |right |
           | CTRL  |  A   |  S   |  D   |  F   |
           +-------++-----++-----++-----++-----++
                    | fwd  | edit | InsL | DelL |
                    |  Z   |  X   |  C   |  V   |
                    +------+------+------+------+

 Numeric Pad for Tektronix 4125 Terminal

 The standard keys are duplicated on the numeric pad:

  Control and Control-Shift
                    +------+------+------+------+
                    |  F7  |  F8  |  F9  | F14  |  shift
              ctrl  |  f7  |  f8  |  f9  | f14  |
                    +------+------+------+------+
                    |  F4  |  F5  |  F6  | F15  |  shift
              ctrl  |  f4  |  f5  |  f6  | f15  |
                    +------+------+------+------+
                    |  F1  |  F2  |  F3  |      |  shift
              ctrl  |  f1  |  f2  |  f3  |      |
                    +------+------+------+      |
                    |             |      |      |  shift
              ctrl  |    HOME     |      |      |
                    +-------------+------+------+

  Normal and Shift
                    +------+------+------+------+
              shift | RepM | Back | HELP |clrSCR|
                    | InsM | Data | help |clrEOL| norm
                    +------+------+------+------+
              shift | BKW  | UP   | delL | delC |
                    | bkw  | up   | delC | delL | norm
                    +------+------+------+------+
              shift | FWD  | DWN  | insL | insC |
                    | fwd  | dwn  | insC |      | norm
                    +------+------+------+      |
              shift |             | EDIT |      |
                    |    HOME     | edit | insL | norm
                    +-------------+------+------+

 Cursor and Page Control for Tektronix 4125

          NORMAL and SHIFT                 CONTROL and CONTROL-SHIFT

            Normal Border                        Normal Border

           +------+------+                      +------+------+
           |  4x  |  4x  |                      | BKW  | dwn  |
           |  Up  | Right|                      | bkw  | up   |
  Cursor   +------+------+              Page    +------+------+
  Control  +------+------+              Control +------+------+
           |  4x  |  4x  |                      | FWD  |      |
           | Down | Left |                      | fwd  | HOME |
           +------+------+                      +------+------+
             Pan    View                          Pan    View

 Additional Keys for Tektronix 4125

      s1     s2     s3     s4         s5     s6     s7     s8
   +------+------+------+------+   +------+------+------+------+
   |  F9  | F10  | F11  | F12  |   | F13  | F14  | F15  | F16  | cntrl-shft
   |  f9  | f10  | f11  | f12  |   | f13  | f14  | f15  | f16  | control
   +------+------+------+------+   +------+------+------+------+
      f1     f2     f3     f4         f5     f6     f7     f8
~"**
~"create_status_message n=CSE$CDC_910 c=9003 i='CS' s=i
                      CYBER 910 Workstation

 The function keys all reside on the keypad.  During full screen
 operation the keypad is automatically converted into function keys and
 during line mode operation the keypad is automatically converted to
 produce numeric and related text keystrokes.

 F1 keypad 1        F5 keypad 5         F9  keypad 9        F13 PF4
 F2 keypad 2        F6 keypad 6         F10 PF1             F14 keypad minus
 F3 keypad 3        F7 keypad 7         F11 PF2             F15 keypad comma
 F4 keypad 5        F8 keypad 8         F12 PF3             F16 keypad enter

 Shift of the above function keys is done by prefixing them with the keypad
 0 key (without an intervening carriage return).  For instance, shift F6 is
 keypad 0, then keypad 6, and then carriage return.

 The carriage return key must be pressed after a function key to get a
 response.  It is possible to press a function key several times before
 pressing the carriage return key.  EDIT_FILE interprets this as
 executing the requested function multiple times.

 The screen size is 40 rows by 80 columns.
~"**
~"create_status_message n=CSE$SUN_160 c=9004 i='CS' s=i
               Sun Microsystems 160 Workstation

          +----------+------------+ +---------+------------+
          | Physical | Logical    | | Physical| Logical    |
          | Sun Key  | NOS/VE Key | | Sun Key | NOS/VE Key |
          +----------+------------+ +---------+------------+
          |  L2      |  F1        | |  F2     |  F2        |
          +----------+------------+ +---------+------------+
          |  F3      |  F3        | |  F4     |  F4        |
          +----------+------------+ +---------+------------+
          |  F5      |  F5        | |  F6     |  F6        |
          +----------+------------+ +---------+------------+
          |  F7      |  F7        | |  F8     |  F8        |
          +----------+------------+ +---------+------------+
          |  R1      |  Shift F1  | |  R2     |  Shift F2  |
          +----------+------------+ +---------+------------+
          |  R3      |  Shift F3  | |  R4     |  Shift F4  |
          +----------+------------+ +---------+------------+
          |  R5      |  Shift F5  | |  R6     |  Shift F6  |
          +----------+------------+ +---------+------------+
          |  R7      |  Shift F7  | |  F9     |  Shift F8  |
          +----------+------------+ +---------+------------+
          | Esc, L2  |  F9        | | Esc, F2 |  F10       |
          +----------+------------+ +---------+------------+
          | Esc, F3  |  F11       | | Esc, F4 |  F12       |
          +----------+------------+ +---------+------------+
          | Esc, F5  |  F13       | | Esc, F6 |  F14       |
          +----------+------------+ +---------+------------+
          | Esc, F7  |  F15       | | Esc, F8 |  F16       |
          +----------+------------+ +---------+------------+
          | Esc, R1  |  Shift F9  | | Esc, R2 |  Shift F10 |
          +----------+------------+ +---------+------------+
          | Esc, R3  |  Shift F11 | | Esc, R4 |  Shift F12 |
          +----------+------------+ +---------+------------+
          | Esc, R5  |  Shift F13 | | Esc, R6 |  Shift F14 |
          +----------+------------+ +---------+------------+
          | Esc, R7  |  Shift F15 | | Esc, F9 |  Shift F16 |
          +----------+------------+ +---------+------------+

 All function keys must be followed by a carriage return to get a
 response.  Note that with the dual (Escape) keypresses, there is no
 intervening carriage return.  EDIT_FILE allows a function key (or Escape
 pair) to be repeated several times before pressing carriage return.

 The Sun Workstation allows two screen sizes:  34 rows by 80 columns and
 48 rows by 132 columns.  The EDIT_FILE WIDTH function switches between
 size.  The smaller size can be used either with or without windowing on
 Sun's Unix system, but if used with windowing the user must be careful
 to never move the cursor beyond the 80th column or 34th row.  The 34*80
 size is primarily intended to be used without windowing.  When the
 windowing system is used, the user should normally use the WIDTH
 function key to convert to the 48*132 format as soon as possible.  If
 the 48*132 size is used without windowing, portions of the screen will
 scroll out of view.
~"**
~"create_status_message n=CSE$DEC_VT100_GOLD c=9005 i='CS' s=i
       Digital Equipment VT100 with 32 Function Keys

 The function keys all reside on the keypad.  During full screen
 operation the keypad is automatically converted into function keys and
 during line mode operation the keypad is automatically converted to
 produce numeric and related text keystrokes.

 Using the Return Key

  If the communications network you are using is:

     CDCNET or X.25 Protocol - You can have the system generate
     automatic returns for all function and keypad keys using the
     FUNCTION_KEY_CLASS parameter on the CHATA command.

       Example:  CHATA FUNCTION_KEY_CLASS=DEC_VT100_GOLD

     NAM/CCP or Intercom - No automatic returns can be added, you must
     press the return key after each function.

 Editing Keys

  All editing operations are performed using the keys located on the
  keypad.

 VT100 Keypad

  +------+------+------+------+  The keys PF1 through PF4 shown here
  | PF1  | PF2  | PF3  | PF4  |  correspond to the key identifiers
  |      |  `   |      |      |  p1 through p4.  Precede the key by
  +------+------+------+------+  a 0 for the TOP(SHIFTED) operation.
  |  7   |  8   |  9   |  -   |
  |      |      |      |      |  The rest of the keys on the keypad
  +------+------+------+------+  correspond to the key identifiers
  |  4   |  5   |  6   |  ,   |  starting with k.
  |      |      |      |      |  To execute an operation using this
  +------+------+------+------+  keypad, press the key (then RETURN).
  |  1   |  2   |  3   | Enter|
  |      |      |      |      |  Key identifiers starting with 0
  +------+------+------+      |  represent the 0 key followed by the
  |      0      |  .   |      |  key identified by the second character
  |             |      |      |  (06 is 0 followed by the 6).
  +-------------+------+------+

  F1 keypad 1        F5 keypad 5         F9  keypad 9        F13 PF4
  F2 keypad 2        F6 keypad 6         F10 PF1             F14 keypad minus
  F3 keypad 3        F7 keypad 7         F11 PF2             F15 keypad comma
  F4 keypad 5        F8 keypad 8         F12 PF3             F16 keypad enter
~"**
~"create_status_message n=CSE$DEC_VT220 c=9006 i='CS' s=i
                   Digital Equipment VT220
                           For CDCNET Users

 Using the Return Key

   If the communications network you are using is:

     CDCNET or X.25 Protocol - The system will give you automatic
     returns for all function and keypad keys.

     NAM/CCP or Intercom - No automatic returns.  You must press the
     return key after each function.

 Editing keys not identified on the screen.

  These operations do not appear in highlighted boxes on the screen.
  You can execute these operations by pressing the shift key along with
  operation keys.  The operation is executed immediately at your
  terminal if you are on CDCNET or X.25 Protocol(you don't have to press
  the return key to start the operation).  If you are on NAM/CCP or
  Intercom you will have to press the return key to execute the
  operation.

  You can create your own template for these keys by taping labels above
  the keys on your terminal.  You can also copy this text to a file you
  can print using the OUTPUT parameter on the DISPLAY_TERMINAL_MODEL
  command.

   F6     F7     F8     F9     F10   F11     F12    F13
                                     (ESC)   (BS)   (LF)   F14
 +------+------+------+------+-- ---+------+------+------+------+
 |      |      |      |      |      |      |      |      |      |
 | InsL | DelL |InBlCh|DelCh | Ins  |StpIns|DelEOL|ReWrSc| BACK |
 +------+------+------+------+------+------+------+------+------+

   HELP      DO           F17    F18    F19    F20
 +-------+--------+     +------+------+------+------+
 |       |        |     |      |      |      |      |
 | HELP  |  Home  |     | 1stSc|Bckwrd|Forwrd| LstSc|
 +-------+--------+     +------+------+------+------+

 Screen Editing

  Function keys F6 through F20, and the keypad ENTER key are the first
  16 unshifted function keys.  To execute operations that map from the
  key menu to these keys, press the key (then press return if you are on
  NAM/CCP or Intercom).

 Editing keypad (used to position the cursor):

 |------|------|------|
 |      |      |      |
 |------|------|------|    Using the arrow keys, moves the cursor
 |      |      |      |    in the direction of the arrow.
 |------|------|------|
        |down  |           Other keys on this keypad are not used.
        |arrow |
 |------|------|------|    The Home key is the shifted Do key on the
 | <--- | up   | ---> |    top row of function keys.
 |      |arrow |      |
 |------|------|------|

 Numeric keypad:

 |-----|-----|-----|-----|    The keys PF1 through PF4 shown here
 | PF1 | PF2 | PF3 | PF4 |    correspond to the key identifiers
 |-----|-----|-----|-----|    p1 through p4.
 |  7  |  8  |  9  |  -  |
 |-----|-----|-----|-----|    The rest of the keys on the keypad
 |  4  |  5  |  6  |  ,  |    correspond to the key identifiers
 |-----|-----|-----|-----|    starting with k.
 |  1  |  2  |  3  |     |
 |-----|-----|-----|Enter|    To execute an operation using this
 |     0     |  .  |     |    keypad, press the key (then
 |-----------|-----|-----|    press return if on NAM/CCP or Intercom).

 Keypad keys 1 through 9, keypad 0, PF1 through PF4, keypad minus, and
 keypad commas are the first 16 shifted function keys.
~"**
~"create_status_message n=CSE$TAB_132 c=9007 i='CS' s=i
                TAB 132/15 Function Keys

  The function keys reside on the keypad and on the soft-keys.
  During full screen operation the keypad is automatically
  converted into function keys and during line mode operation the
  keypad is automatically converted to normal character generation.
  All keypad and soft-key keys generate unique escape sequences;
  each key represents either a function or shifted function key.

  The keypad is labelled 1 thru 9, PF1, PF2, PF3, PF4, (-), TAB,
  ENTER, (.), and 0.  The keypad keys represent the following
  function and shifted function keys:  F1 thru F9, SF1, SF2, SF3,
  SF4, SF5, SF6, SF7, SF8, and SF9.  The soft_keys are labelled
  S1 thru S8 and represent the following function and shifted
  function keys:  F10, SF10, F11, SF11, F12, SF12, F13, and SF13.

                            Keypad
                 +------+------+------+------+
                 |  SF1 |  SF2 |  SF3 |  SF4 |
                 |  PF1 |  PF2 |  PF3 |  PF4 |
                 +------+------+------+------+
                 |  F7  |  F8  |  F9  |  SF5 |
                 |   7  |   8  |   9  |   -  |
                 +------+------+------+------+
                 |  F4  |  F5  |  F6  |  SF6 |
                 |   4  |   5  |   6  |  TAB |
                 +------+------+------+------+
                 |  F1  |  F2  |  F3  |      |
                 |   1  |   2  |   3  |  SF7 |
                 +------+------+------|      |
                 |     SF9     |  SF8 | ENTER|
                 |      0      |   .  |      |
                 +------+------+------+------+

                           Soft Keys
   +------+------+------+------+------+------+------+------+
   |  F10 | SF10 |  F11 | SF11 |  F12 | SF12 |  F13 | SF13 |
   |  S1  |  S2  |  S3  |  S4  |  S5  |  S6  |  S7  |  S8  |
   +------+------+------+------+------+------+------+------+
~"**
~"create_status_message n=CSE$TAB_132_EDIT c=9008 i='CS' s=i
         TAB 132/15 Function Keys in EDIT mode

  The function keys reside on the eight soft-keys and represent
  function keys F1 thru F8.  No additional function keys are
  available.  The enter key is not required after a soft-key to
  get a response.

                          Soft Keys
   +------+------+------+------+------+------+------+------+
   |  F1  |  F2  |  F3  |  F4  |  F5  |  F6  |  F7  |  F8  |
   |  S1  |  S2  |  S3  |  S4  |  S5  |  S6  |  S7  |  S8  |
   +------+------+------+------+------+------+------+------+
~"**
~"create_status_message n=CSE$ADM_31 c=9009 i='CS' s=i
               Lear Siegler ADM-31 Function Keys

  The function key sequences are generated by use of keys on the
  main keyboard, the key labelled 'FUNCTION', and optionally the
  'SHIFT' key.  All function key sequences begin with the 'FUNCTION'
  key, followed by a main keyboard key, which may be shifted.

  The carriage return key must be pressed after a function key to
  get a response.  It is possible to press multiple function keys
  before pressing the carriage return key.  EDIT_FILE interprets
  this as executing the requested functions in the order the keys
  were pressed.

  The main keyboard keys used to generate the function key sequences
  are 1 thru 8, unshifted and shifted, and q thru i, unshifted and
  shifted.  To generate the F1 sequence, the 'FUNCTION' key is
  pressed and released, followed by the '1' key.  A 'RETURN' completes
  the sequence.  The SF10 sequence would be generated by 'FUNCTION',
  'SHIFT', 'W'.  Again a 'RETURN' completes the sequence.

                          F1 thru F16
   +------+------+------+------+------+------+------+------+
   |  F1  |  F2  |  F3  |  F4  |  F5  |  F6  |  F7  |  F8  |
   |   1  |   2  |   3  |   4  |   5  |   6  |   7  |   8  |
   +--+---+--+---+--+---+--+---+--+---+--+---+--+---+--+---+--+
      |  F9  |  F10 |  F11 |  F12 |  F13 |  F14 |  F15 |  F16 |
      |   q  |   w  |   e  |   r  |   t  |   y  |   u  |   i  |
      +------+------+------+------+------+------+------+------+

                         SF1 thru SF16
   +------+------+------+------+------+------+------+------+
   | SF1  | SF2  | SF3  | SF4  | SF5  | SF6  | SF7  | SF8  |
   |   !  |   "  |   #  |   $  |   %  |   &  |   '  |   (  |
   +--+---+--+---+--+---+--+---+--+---+--+---+--+---+--+---+--+
      | SF9  | SF10 | SF11 | SF12 | SF13 | SF14 | SF15 | SF16 |
      |   Q  |   W  |   E  |   R  |   T  |   Y  |   U  |   I  |
      +------+------+------+------+------+------+------+------+
~"**
~"create_status_message n=CSE$ADM_31_PROTECTED c=9010 i='CS' s=i
        Lear Siegler ADM-31 Keys in Protected Mode

  The function key sequences are generated by use of keys on the
  main keyboard, the key labelled 'FUNCTION', and optionally the
  'SHIFT' key.  All function key sequences begin with the 'FUNCTION'
  key, followed by a main keyboard key, which may be shifted.

  The carriage return key must be pressed after a function key to
  get a response.  It is possible to press multiple function keys
  before pressing the carriage return key.  EDIT_FILE interprets
  this as executing the requested functions in the order the keys
  were pressed.

  The main keyboard keys used to generate the function key sequences
  are 1 thru 8, unshifted and shifted, and q thru i, unshifted and
  shifted.  To generate the F1 sequence, the 'FUNCTION' key is
  pressed and released, followed by the '1' key.  A 'RETURN' completes
  the sequence.  The SF10 sequence would be generated by 'FUNCTION',
  'SHIFT', 'W'.  Again a 'RETURN' completes the sequence.

                          F1 thru F16
   +------+------+------+------+------+------+------+------+
   |  F1  |  F2  |  F3  |  F4  |  F5  |  F6  |  F7  |  F8  |
   |   1  |   2  |   3  |   4  |   5  |   6  |   7  |   8  |
   +--+---+--+---+--+---+--+---+--+---+--+---+--+---+--+---+--+
      |  F9  |  F10 |  F11 |  F12 |  F13 |  F14 |  F15 |  F16 |
      |   q  |   w  |   e  |   r  |   t  |   y  |   u  |   i  |
      +------+------+------+------+------+------+------+------+

                         SF1 thru SF16
   +------+------+------+------+------+------+------+------+
   | SF1  | SF2  | SF3  | SF4  | SF5  | SF6  | SF7  | SF8  |
   |   !  |   "  |   #  |   $  |   %  |   &  |   '  |   (  |
   +--+---+--+---+--+---+--+---+--+---+--+---+--+---+--+---+--+
      | SF9  | SF10 | SF11 | SF12 | SF13 | SF14 | SF15 | SF16 |
      |   Q  |   W  |   E  |   R  |   T  |   Y  |   U  |   I  |
      +------+------+------+------+------+------+------+------+
~"**
~"create_status_message n=CSE$TV_970 c=9011 i='CS' s=i
              TeleVideo 970 Function Keys

  The function key sequences are generated by use of keys at the
  top of the main keyboard; the keys are labelled F1 thru F16.
  With the addition of the 'SHIFT' key all 32 function key
  sequences can be generated, F1 thru F16 and SF1 thru SF16.

  The carriage return key is not required after a function key.
  All function keys sequences are programmed with an embedded
  carriage return.

               Additional Edit_File Keys

  There are additional keys available which perform useful
  functions in Edit_File and other full screen applications.
  These additional keys function as labelled, except as noted,
  and are detailed in the following figure.

           +--------+--------+--------+
           |        |        |        |
           |  CHAR  |  LINE  |  LINE  |
           | INSERT | INSERT |  ERASE |
           |        |        |        |           (shifted)
           +--------+--------+--------+--------+  Page
           |        |        |        |        |  Backward
           |  CHAR  |  LINE  |        |  PAGE  |
           | DELETE | DELETE |        |        |
           |        |        |        |        |  Page
           +--------+--------+--------+--------+  Forward


                   +---------+---------+
          Position |    |    |    ^    | Position
            Line   |    v    |    |    |   Line
                   |(shifted |(shifted |
            DOWN   |  down   |   up    |    UP
                   |  arrow) |  arrow) |
                   +---------+---------+
~"**
~"create_status_message n=CSE$DEC_VT100 c=9012 i='CS' s=i
         Digital Equipment VT100 with 16 Function Keys

 Only 16 function keys are available with this terminal definition.
 Use DEC_VT100_GOLD to get additional function keys.

 Using the Return Key

  If the communications network you are using is:

     CDCNET or X.25 Protocol - You can have the system generate
     automatic returns for all function keys using the
     FUNCTION_KEY_CLASS parameter on the CHATA command.

       Example:  CHATA FUNCTION_KEY_CLASS=DEC_VT100

     NAM/CCP or Intercom - No automatic returns can be added, you must
     press the return key after each function.
~"**
~"create_status_message n=CSE$DEC_VT220_OLD c=9013 i='CS' s=i
                    Digital Equipment VT220
                    For NAM/CCP and Intercom Users

 Using the Return Key

  If the communications network you are using is:

     NAM/CCP or Intercom - The system will generate automatic returns
     for shifted function keys only.   You must press the return key
     for all other functions.

     CDCNET or X.25 Protocol - We recommend you use terminal model DEC_VT220.

  There are no automatic returns for the function keys displayed in
  the menu at the bottom of your screen.  You must press the
  return key after each function.

 Editing keys not identified on the screen.

  These operations do not appear in highlighted boxes on the screen.
  You can execute these operations by pressing the shift key along with
  operation keys.  The operation is executed immediately at your
  terminal (you don't have to press the return key to start the operation).

  You can create your own template for these keys by taping labels above
  the keys on your terminal.  You can also copy this text to a file you
  can print using the OUTPUT parameter on the DISPLAY_TERMINAL_MODEL
  command.

   F6     F7     F8     F9     F10   F11     F12    F13
                                     (ESC)   (BS)   (LF)   F14
 +------+------+------+------+-- ---+------+------+------+------+
 |      |      |      |      |      |      |      |      |      |
 | InsL | DelL |InBlCh|DelCh | Ins  |StpIns|DelEOL|ReWrSc| BACK |
 +------+------+------+------+------+------+------+------+------+

   HELP      DO           F17    F18    F19    F20
 +-------+--------+     +------+------+------+------+
 |       |        |     |      |      |      |      |
 | HELP  |  Home  |     | 1stSc|Bckwrd|Forwrd| LstSc|
 +-------+--------+     +------+------+------+------+

 Screen Editing

  Function keys F6 through F20, and the keypad ENTER key are the first
  16 unshifted function keys.  To execute operations that map from the
  key menu to these keys, press the key (then press return depending on
  which network you are using).

 Editing keypad (used to position the cursor):


  |------|------|------|
  |      |      |      |
  |------|------|------|    Using the arrow keys, moves the cursor
  |      |      |      |    in the direction of the arrow.
  |------|------|------|
         |down  |           Other keys on this keypad are not used.
         |arrow |
  |------|------|------|    The Home key is the shifted Do key on the
  | <--- | up   | ---> |    top row of function keys.
  |      |arrow |      |
  |------|------|------|


 Numeric keypad:

  |-----|-----|-----|-----|        The keys PF1 through PF4 shown here
  | PF1 | PF2 | PF3 | PF4 |        correspond to the key identifiers
  |-----|-----|-----|-----|        p1 through p4.
  |  7  |  8  |  9  |  -  |
  |-----|-----|-----|-----|        The rest of the keys on the keypad
  |  4  |  5  |  6  |  ,  |        correspond to the key identifiers
  |-----|-----|-----|-----|        starting with k.
  |  1  |  2  |  3  |     |
  |-----|-----|-----|Enter|        To execute an operation using this
  |     0     |  .  |     |        keypad, press the key (then
  |-----------|-----|-----|        press return depending on which
                                   network you are using).

 Keypad keys 1 through 9, keypad 0, PF1 through PF4, keypad minus, and
 keypad commas are the first 16 shifted function keys.
~"**
~"create_status_message n=CSE$PC_CONNECT_20 c=9014 i='CS' s=i
                IBM PC with Screen Size 24 by 80
                     Using CONNECT VIEW and a Mouse

 Use this terminal model to display a screen size of 24 by 80.

 Function Keys

  A sample keyboard layout is shown below.

 +------+------+-----+------+------+------+------+------+------+
 |  F1  |  F2  |     |a     |a     |a     |a     |a     |a     |
 |  f1  |  f2  | ESC |c  1  |c  2  |c  3  |c  4  |c  5  |c  6  |
 +------+------+-----+-+------+------+------+----+------+------+-+
 |  F3  |  F4  |       |      |      |      |      | \ \    | InsL |
 |  f3  |  f4  |  TAB  |  Q   |  W   |  E   |  R   |  \ \   |a  I  |
 +------+------++------++-----++-----++-----++-----++--\ \--+------+
 |  F5  |  F6  ||       |      |      | DelL |      |
 |  f5  |  f6  || CTRL  |  A   |  S   |a  D  |      |
 +------+------++-------++-----++-----++-----++-----++
 |  F7  |  F8  ||        |      |      |ReWrSc|      |
 |  f7  |  f8  || SHIFT  |  Z   |  X   |a  C  |  V   |
 +------+------++--------+------+------+------+------+
 |  F9  | F10  ||       +
 |  f9  | f10  || ALT   |
 +------+------++-------+

 AT Style Keyboard Function Keys (101 Key) are located along the top of
 the keyboard and number 1 - 12.

 XT Style Keyboard Function Keys (shown above) are placed on the
 alphabetic keyboard. The function key operations are accessed
 by pressing the function key (f1) or combining the SHIFT key with the
 function key (F1). Other operations are performed by combining the
 CTRL (CONTROL) key with a character key [for example CTRL1 (c1),
 CTRL2 (c2)] or their shifted function with the ALT key [for example
 ALT1 (a1), ALT2 (a2)].

 Three other keys on the alphabetic keyboard are accessed by combining
 the ALT key with the character key:
     ALT(I)  (InsL) insert line.
     ALT(D)  (DelL) delete line.
     ALT(C)  (ReWrSc) rewrite screen.

 Other editing operations that can be performed using the CTRL key and
 the Function keys are:
     CTRL f1 (Middle) puts current line to middle of screen.
     CTRL f2 (LinUp) puts current line to top of screen.
     CTRL f3 (Format) moves words across line boundaries and
             standardizes spacing between words to fit current paragraph
             to specified margins.
     CTRL f4 (InsWd) inserts 32 blank characters.
     CTRL f5 (InsBk) inserts n number of empty lines; screen
             dependent.
     CTRL f6 (Indent) inserts 2 blank characters in front of marked
             text.

 Numeric Pad for IBM PC

 These keys are accessed by pressing the character key (shown).
 Functions accessed by pressing the CTRL key and the character key
 simultaneously are:
  CTRL(PgUp) - Aligns screen to display the beginning of the file
  CTRL(PgDn) - Aligns screen centered around the end of the file.

                +---------+-------+------+------+
   Normal       |Backspace|  ~   |NumLck|ScrlLk|
                |         |  `   |      |      |
                +---------+------+------+------+
                   |  7   |  8   |  9   |   -  |
                   | Home |      | PgUp |      |
                   | HmLn |      | NxtSc|      |
                   +------+------+------+------+
                   |  4   |  5   |  6   |   +  |
                   |      |      |      |      |
                   |      |      |      |      |
                   +------+------+------+------+
                   |  1   |  2   |  3   | Enter|
                   |  End |      | PgDn |      |
                   |StpIns|      | PrvSc|      |
               +---+------+------+------+      |
               |   0      |    .    .   |      |
               |   INS    |   DEL       |      |
               | Ins Mode | DelCurChar  |      |
               +----------+-------------+------+
~"**
~"create_status_message n=CSE$PC_CONNECT_20_42 c=9015 i='CS' s=i
                IBM PC with Screen Size 42 by 80
                     Using CONNECT VIEW and a Mouse

 Use this terminal model to display a screen size of 42 by 80.

 Function Keys

  A sample keyboard layout is shown below.

 +------+------+-----+------+------+------+------+------+------+
 |  F1  |  F2  |     |a     |a     |a     |a     |a     |a     |
 |  f1  |  f2  | ESC |c  1  |c  2  |c  3  |c  4  |c  5  |c  6  |
 +------+------+-----+-+------+------+------+----+------+------+-+
 |  F3  |  F4  |       |      |      |      |      | \ \    | InsL |
 |  f3  |  f4  |  TAB  |  Q   |  W   |  E   |  R   |  \ \   |a  I  |
 +------+------++------++-----++-----++-----++-----++--\ \--+------+
 |  F5  |  F6  ||       |      |      | DelL |      |
 |  f5  |  f6  || CTRL  |  A   |  S   |a  D  |      |
 +------+------++-------++-----++-----++-----++-----++
 |  F7  |  F8  ||        |      |      |ReWrSc|      |
 |  f7  |  f8  || SHIFT  |  Z   |  X   |a  C  |  V   |
 +------+------++--------+------+------+------+------+
 |  F9  | F10  ||       +
 |  f9  | f10  || ALT   |
 +------+------++-------+

 AT Style Keyboard Function Keys (101 Key) are located along the top of
 the keyboard and number 1 - 12.

 XT Style Keyboard Function Keys (shown above) are placed on the
 alphabetic keyboard. The function key operations are accessed
 by pressing the function key (f1) or combining the SHIFT key with the
 function key (F1). Other operations are performed by combining the
 CTRL (CONTROL) key with a character key [for example CTRL1 (c1),
 CTRL2 (c2)] or their shifted function with the ALT key [for example
 ALT1 (a1), ALT2 (a2)].

 Three other keys on the alphabetic keyboard are accessed by combining
 the ALT key with the character key:
     ALT(I)  (InsL) insert line.
     ALT(D)  (DelL) delete line.
     ALT(C)  (ReWrSc) rewrite screen.

 Other editing operations that can be performed using the CTRL key and
 the Function keys are:
     CTRL f1 (Middle) puts current line to middle of screen.
     CTRL f2 (LinUp) puts current line to top of screen.
     CTRL f3 (Format) moves words across line boundaries and
             standardizes spacing between words to fit current paragraph
             to specified margins.
     CTRL f4 (InsWd) inserts 32 blank characters.
     CTRL f5 (InsBk) inserts n number of empty lines; screen
             dependent.
     CTRL f6 (Indent) inserts 2 blank characters in front of marked
             text.

 Numeric Pad for IBM PC

 These keys are accessed by pressing the character key (shown).
 Functions accessed by pressing the CTRL key and the character key
 simultaneously are:
  CTRL(PgUp) - Aligns screen to display the beginning of the file
  CTRL(PgDn) - Aligns screen centered around the end of the file.

                +---------+-------+------+------+
   Normal       |Backspace|  ~   |NumLck|ScrlLk|
                |         |  `   |      |      |
                +---------+------+------+------+
                   |  7   |  8   |  9   |   -  |
                   | Home |      | PgUp |      |
                   | HmLn |      | NxtSc|      |
                   +------+------+------+------+
                   |  4   |  5   |  6   |   +  |
                   |      |      |      |      |
                   |      |      |      |      |
                   +------+------+------+------+
                   |  1   |  2   |  3   | Enter|
                   |  End |      | PgDn |      |
                   |StpIns|      | PrvSc|      |
               +---+------+------+------+      |
               |   0      |    .    .   |      |
               |   INS    |   DEL       |      |
               | Ins Mode | DelCurChar  |      |
               +----------+-------------+------+
~"**
~"create_status_message n=CSE$PC_CONNECT_20_42_132 c=9016 i='CS' s=i
                IBM PC with Screen Size 42 by 132
                     Using CONNECT VIEW and a Mouse

 Use this terminal model to display a screen size of 42 by 132.

 Function Keys

  A sample keyboard layout is shown below.

 +------+------+-----+------+------+------+------+------+------+
 |  F1  |  F2  |     |a     |a     |a     |a     |a     |a     |
 |  f1  |  f2  | ESC |c  1  |c  2  |c  3  |c  4  |c  5  |c  6  |
 +------+------+-----+-+------+------+------+----+------+------+-+
 |  F3  |  F4  |       |      |      |      |      | \ \    | InsL |
 |  f3  |  f4  |  TAB  |  Q   |  W   |  E   |  R   |  \ \   |a  I  |
 +------+------++------++-----++-----++-----++-----++--\ \--+------+
 |  F5  |  F6  ||       |      |      | DelL |      |
 |  f5  |  f6  || CTRL  |  A   |  S   |a  D  |      |
 +------+------++-------++-----++-----++-----++-----++
 |  F7  |  F8  ||        |      |      |ReWrSc|      |
 |  f7  |  f8  || SHIFT  |  Z   |  X   |a  C  |  V   |
 +------+------++--------+------+------+------+------+
 |  F9  | F10  ||       +
 |  f9  | f10  || ALT   |
 +------+------++-------+

 AT Style Keyboard Function Keys (101 Key) are located along the top of
 the keyboard and number 1 - 12.

 XT Style Keyboard Function Keys (shown above) are placed on the
 alphabetic keyboard. The function key operations are accessed
 by pressing the function key (f1) or combining the SHIFT key with the
 function key (F1). Other operations are performed by combining the
 CTRL (CONTROL) key with a character key [for example CTRL1 (c1),
 CTRL2 (c2)] or their shifted function with the ALT key [for example
 ALT1 (a1), ALT2 (a2)].

 Three other keys on the alphabetic keyboard are accessed by combining
 the ALT key with the character key:
     ALT(I)  (InsL) insert line.
     ALT(D)  (DelL) delete line.
     ALT(C)  (ReWrSc) rewrite screen.

 Other editing operations that can be performed using the CTRL key and
 the Function keys are:
     CTRL f1 (Middle) puts current line to middle of screen.
     CTRL f2 (LinUp) puts current line to top of screen.
     CTRL f3 (Format) moves words across line boundaries and
             standardizes spacing between words to fit current paragraph
             to specified margins.
     CTRL f4 (InsWd) inserts 32 blank characters.
     CTRL f5 (InsBk) inserts n number of empty lines; screen
             dependent.
     CTRL f6 (Indent) inserts 2 blank characters in front of marked
             text.

 Numeric Pad for IBM PC

 These keys are accessed by pressing the character key (shown).
 Functions accessed by pressing the CTRL key and the character key
 simultaneously are:
  CTRL(PgUp) - Aligns screen to display the beginning of the file
  CTRL(PgDn) - Aligns screen centered around the end of the file.

                +---------+-------+------+------+
   Normal       |Backspace|  ~   |NumLck|ScrlLk|
                |         |  `   |      |      |
                +---------+------+------+------+
                   |  7   |  8   |  9   |   -  |
                   | Home |      | PgUp |      |
                   | HmLn |      | NxtSc|      |
                   +------+------+------+------+
                   |  4   |  5   |  6   |   +  |
                   |      |      |      |      |
                   |      |      |      |      |
                   +------+------+------+------+
                   |  1   |  2   |  3   | Enter|
                   |  End |      | PgDn |      |
                   |StpIns|      | PrvSc|      |
               +---+------+------+------+      |
               |   0      |    .    .   |      |
               |   INS    |   DEL       |      |
               | Ins Mode | DelCurChar  |      |
               +----------+-------------+------+
~"**
~"create_status_message n=CSE$MAC_CONNECT_20 c=9017 i='CS' s=i
                Apple Macintosh Microcomputer

  Below the Macintosh Plus keyboard is annotated with operations.
  You execute the operation by pressing the OPTION key and the
  operation key simultaneously.  When more than one operation is
  listed, the top operation is performed using the shifted key (OPTION and
  SHIFT keys).  The Macintosh II keyboards (regular & extended) have the
  function keys located at the top of the keyboard.  They also have
  separate cursor keys and a numeric keypad.

 +--------+------+------+------+------+---\\-+------+
 |  ~     |(F1)  |(F2)  |(F3)  |(F4)  |(F5)\\|(F10) |
 |        |      |      |      |      |     \\      |
 |  `     |   1  |   2  |   3  |   4  |   5  \\  0  |
 +--------+-+------+------+------+----+--------+----+-+
 |          |(F11) |(F12) |(F13) |(F14) |(F15) |(F16) |
 |          |      |      |      |      |      |      |
 |  TAB     |  Q   |  W   |  E   |  R   |   T  |  Y   |
 +----------++-----++-----++-----++-----+------++-------+
 |           |      |      |      | EOF  |      |      |
 |           |      |      |      | NxtSc|      | HmLn |
 | CAPS LOCK |  A   |  S   |  D   |  F   |   G  |  H   |
 +-----------++-----++-----++-----+-+-----++-----++------+
 |            |      |      |DlChEOL|      |BegFil|      |
 |            |      |      |ReWrSc |      | PrvSc|      |
 |  SHIFT     |  Z   |  X   |  C    |  V   |  B   |  N   |
 +---------+--+------+------+-------+------+------+------+
 |         | Apple   |                     InsBlLn       /
 |  OPTION | CMD Key |     SPACE BAR       InsBlChar     /
 +---------+---------+-----------------------------------/

        /+------+------+------+------+------+-------+
       / | (F8) | (F9) | (F10)|  _   |  +   | DelLn |
      /  |      |      |      |      |      | DelCh |
     /   |  8   |  9   |  0   |  -   |  =   | BkSpac|
    /----+-+----+-+----+-+----+-+----+-+----+-+-----+
   /|      |   ^  |      |      | {    | }    |     |
  / |      |   |  |      |      |      |      |     |
  /  |  U   |  I   | O    | P    | [    | ]    |     |
 \--+-+----+-+----+-+----+-+----+-+---+---+---+     |
  \   |      |      |      | :Back| "Data |         |
   \  |  <-  |  ->  |      |      |       |RETURN   |
    \ |  J   | K    | L    |   ;  | 'Data |         |
    /-+ +----+ +----+-+ ---+-+----+-+-----+--+------+
   /    |  |   | <    | >Edit| Edit-|        |  ^   |
  /     |  V   |      |      | Help |        |  |   |
 /      |  M   | ,    | .Edit|  ?   | SHIFT  |  |   |
 \------+------+------+-+----+-+----+-+------+------+
  /           InsBlLine |  |   |      |      |  |   |
  / SPACE BAR           |      | <--- |--->  |  |   |
  /           InsBlChar |  \   |      |      |  V   |
  /---------------------+------+------+------+------+

 Notes On Screen Editing

  - If you are using a Macintosh SE or Macintosh II you must use
    CONNECT version 2.0 or later.

  - You can position the cursor by pressing the OPTION key while
    clicking the mouse at the new position

  - On the Macintosh Plus the arrow keys position the cursor.  On
    the standard Macintosh you must use the keys defined on the
    keyboard (I, J, K, M).

    If you are using a CONNECT version 1.1 or later, you can
    redefine these keys.

  - The following operations are available for use, but are not
    defined:

          edit           OPTION .
          SHIFT edit     OPTION >
          data           OPTION '
          SHIFT data     OPTION "
          SHIFT back     OPTION :

    To define these operations use the SET_FUNCTION_KEY
    subcommand.
~"**
~"create_status_message n=CSE$PC_CONNECT_13 c=9018 i='CS' s=i
                   IBM PC Without Mouse

 For mouse support, use PC_CONNECT_20.

 Function Keys

  A sample keyboard layout is shown below.

 +------+------+-----+------+------+------+------+------+------+
 |  F1  |  F2  |     |a     |a     |a     |a     |a     |a     |
 |  f1  |  f2  | ESC |c  1  |c  2  |c  3  |c  4  |c  5  |c  6  |
 +------+------+-----+-+------+------+------+----+------+------+-+
 |  F3  |  F4  |       |      |      |      |      | \ \    | InsL |
 |  f3  |  f4  |  TAB  |  Q   |  W   |  E   |  R   |  \ \   |a  I  |
 +------+------++------++-----++-----++-----++-----++--\ \--+------+
 |  F5  |  F6  ||       |      |      | DelL |      |
 |  f5  |  f6  || CTRL  |  A   |  S   |a  D  |      |
 +------+------++-------++-----++-----++-----++-----++
 |  F7  |  F8  ||        |      |      |ReWrSc|      |
 |  f7  |  f8  || SHIFT  |  Z   |  X   |a  C  |  V   |
 +------+------++--------+------+------+------+------+
 |  F9  | F10  ||       +
 |  f9  | f10  || ALT   |
 +------+------++-------+

 AT Style Keyboard Function Keys (101 Key) are located along the top of
 the keyboard and number 1 - 12.

 XT Style Keyboard Function Keys (shown above) are placed on the
 alphabetic keyboard. The function key operations are accessed
 by pressing the function key (f1) or combining the SHIFT key with the
 function key (F1). Other operations are performed by combining the
 CTRL (CONTROL) key with a character key [for example CTRL1 (c1),
 CTRL2 (c2)] or their shifted function with the ALT key [for example
 ALT1 (a1), ALT2 (a2)].

 Three other keys on the alphabetic keyboard are accessed by combining
 the ALT key with the character key:
     ALT(I)  (InsL) insert line.
     ALT(D)  (DelL) delete line.
     ALT(C)  (ReWrSc) rewrite screen.

 Other editing operations that can be performed using the CTRL key and
 the Function keys are:
     CTRL f1 (Middle) puts current line to middle of screen.
     CTRL f2 (LinUp) puts current line to top of screen.
     CTRL f3 (Format) moves words across line boundaries and
             standardizes spacing between words to fit current paragraph
             to specified margins.
     CTRL f4 (InsWd) inserts 32 blank characters.
     CTRL f5 (InsBk) inserts n number of empty lines; screen
             dependent.
     CTRL f6 (Indent) inserts 2 blank characters in front of marked
             text.

 Numeric Pad for IBM PC

 These keys are accessed by pressing the character key (shown).
 Functions accessed by pressing the CTRL key and the character key
 simultaneously are:
  CTRL(PgUp) - Aligns screen to display the beginning of the file
  CTRL(PgDn) - Aligns screen centered around the end of the file.

                +---------+-------+------+------+
   Normal       |Backspace|  ~   |NumLck|ScrlLk|
                |         |  `   |      |      |
                +---------+------+------+------+
                   |  7   |  8   |  9   |   -  |
                   | Home |      | PgUp |      |
                   | HmLn |      | NxtSc|      |
                   +------+------+------+------+
                   |  4   |  5   |  6   |   +  |
                   |      |      |      |      |
                   |      |      |      |      |
                   +------+------+------+------+
                   |  1   |  2   |  3   | Enter|
                   |  End |      | PgDn |      |
                   |StpIns|      | PrvSc|      |
               +---+------+------+------+      |
               |   0      |    .    .   |      |
               |   INS    |   DEL       |      |
               | Ins Mode | DelCurChar  |      |
               +----------+-------------+------+
~"**
~"create_status_message n=CSE$PC_CONNECT_12 c=9019 i='CS' s=i
                   IBM PC Without Mouse

 For mouse support, use PC_CONNECT_20.

 Function Keys

  A sample keyboard layout is shown below.

 +------+------+-----+------+------+------+------+------+------+
 |  F1  |  F2  |     |a     |a     |a     |a     |a     |a     |
 |  f1  |  f2  | ESC |c  1  |c  2  |c  3  |c  4  |c  5  |c  6  |
 +------+------+-----+-+------+------+------+----+------+------+-+
 |  F3  |  F4  |       |      |      |      |      | \ \    | InsL |
 |  f3  |  f4  |  TAB  |  Q   |  W   |  E   |  R   |  \ \   |a  I  |
 +------+------++------++-----++-----++-----++-----++--\ \--+------+
 |  F5  |  F6  ||       |      |      | DelL |      |
 |  f5  |  f6  || CTRL  |  A   |  S   |a  D  |      |
 +------+------++-------++-----++-----++-----++-----++
 |  F7  |  F8  ||        |      |      |ReWrSc|      |
 |  f7  |  f8  || SHIFT  |  Z   |  X   |a  C  |  V   |
 +------+------++--------+------+------+------+------+
 |  F9  | F10  ||       +
 |  f9  | f10  || ALT   |
 +------+------++-------+

 AT Style Keyboard Function Keys (101 Key) are located along the top of
 the keyboard and number 1 - 12.

 XT Style Keyboard Function Keys (shown above) are placed on the
 alphabetic keyboard. The function key operations are accessed
 by pressing the function key (f1) or combining the SHIFT key with the
 function key (F1). Other operations are performed by combining the
 CTRL (CONTROL) key with a character key [for example CTRL1 (c1),
 CTRL2 (c2)] or their shifted function with the ALT key [for example
 ALT1 (a1), ALT2 (a2)].

 Three other keys on the alphabetic keyboard are accessed by combining
 the ALT key with the character key:
     ALT(I)  (InsL) insert line.
     ALT(D)  (DelL) delete line.
     ALT(C)  (ReWrSc) rewrite screen.

 Other editing operations that can be performed using the CTRL key and
 the Function keys are:
     CTRL f1 (Middle) puts current line to middle of screen.
     CTRL f2 (LinUp) puts current line to top of screen.
     CTRL f3 (Format) moves words across line boundaries and
             standardizes spacing between words to fit current paragraph
             to specified margins.
     CTRL f4 (InsWd) inserts 32 blank characters.
     CTRL f5 (InsBk) inserts n number of empty lines; screen
             dependent.
     CTRL f6 (Indent) inserts 2 blank characters in front of marked
             text.

 Numeric Pad for IBM PC

 These keys are accessed by pressing the character key (shown).
 Functions accessed by pressing the CTRL key and the character key
 simultaneously are:
  CTRL(PgUp) - Aligns screen to display the beginning of the file
  CTRL(PgDn) - Aligns screen centered around the end of the file.

                +---------+-------+------+------+
   Normal       |Backspace|  ~   |NumLck|ScrlLk|
                |         |  `   |      |      |
                +---------+------+------+------+
                   |  7   |  8   |  9   |   -  |
                   | Home |      | PgUp |      |
                   | HmLn |      | NxtSc|      |
                   +------+------+------+------+
                   |  4   |  5   |  6   |   +  |
                   |      |      |      |      |
                   |      |      |      |      |
                   +------+------+------+------+
                   |  1   |  2   |  3   | Enter|
                   |  End |      | PgDn |      |
                   |StpIns|      | PrvSc|      |
               +---+------+------+------+      |
               |   0      |    .    .   |      |
               |   INS    |   DEL       |      |
               | Ins Mode | DelCurChar  |      |
               +----------+-------------+------+
~"**
~"create_status_message n=CSE$PC_CONNECT_11 c=9020 i='CS' s=i
                   IBM PC Without Mouse

 For mouse support, use PC_CONNECT_20.

 Function Keys

  A sample keyboard layout is shown below.

 +------+------+-----+------+------+------+------+------+------+
 |  F1  |  F2  |     |a     |a     |a     |a     |a     |a     |
 |  f1  |  f2  | ESC |c  1  |c  2  |c  3  |c  4  |c  5  |c  6  |
 +------+------+-----+-+------+------+------+----+------+------+-+
 |  F3  |  F4  |       |      |      |      |      | \ \    | InsL |
 |  f3  |  f4  |  TAB  |  Q   |  W   |  E   |  R   |  \ \   |a  I  |
 +------+------++------++-----++-----++-----++-----++--\ \--+------+
 |  F5  |  F6  ||       |      |      | DelL |      |
 |  f5  |  f6  || CTRL  |  A   |  S   |a  D  |      |
 +------+------++-------++-----++-----++-----++-----++
 |  F7  |  F8  ||        |      |      |ReWrSc|      |
 |  f7  |  f8  || SHIFT  |  Z   |  X   |a  C  |  V   |
 +------+------++--------+------+------+------+------+
 |  F9  | F10  ||       +
 |  f9  | f10  || ALT   |
 +------+------++-------+

 AT Style Keyboard Function Keys (101 Key) are located along the top of
 the keyboard and number 1 - 12.

 XT Style Keyboard Function Keys (shown above) are placed on the
 alphabetic keyboard. The function key operations are accessed
 by pressing the function key (f1) or combining the SHIFT key with the
 function key (F1). Other operations are performed by combining the
 CTRL (CONTROL) key with a character key [for example CTRL1 (c1),
 CTRL2 (c2)] or their shifted function with the ALT key [for example
 ALT1 (a1), ALT2 (a2)].

 Two other keys on the alphabetic keyboard are accessed by combining
 the ALT key with the character key:
     ALT(I)  (InsL) insert line.
     ALT(D)  (DelL) delete line.

 Other editing operations that can be performed using the CTRL key and
 the Function keys are:
     CTRL f1 (Middle) puts current line to middle of screen.
     CTRL f2 (LinUp) puts current line to top of screen.
     CTRL f3 (Format) moves words across line boundaries and
             standardizes spacing between words to fit current paragraph
             to specified margins.
     CTRL f4 (InsWd) inserts 32 blank characters.
     CTRL f5 (InsBk) inserts n number of empty lines; screen
             dependent.
     CTRL f6 (Indent) inserts 2 blank characters in front of marked
             text.

 Numeric Pad for IBM PC

 These keys are accessed by pressing the character key (shown).
 Functions accessed by pressing the CTRL key and the character key
 simultaneously are:
  CTRL(PgUp) - Aligns screen to display the beginning of the file
  CTRL(PgDn) - Aligns screen centered around the end of the file.

                +---------+-------+------+------+
   Normal       |Backspace|  ~   |NumLck|ScrlLk|
                |         |  `   |      |      |
                +---------+------+------+------+
                   |  7   |  8   |  9   |   -  |
                   | Home |      | PgUp |      |
                   | HmLn |      | NxtSc|      |
                   +------+------+------+------+
                   |  4   |  5   |  6   |   +  |
                   |      |      |      |      |
                   |      |      |      |      |
                   +------+------+------+------+
                   |  1   |  2   |  3   | Enter|
                   |  End |      | PgDn |      |
                   |StpIns|      | PrvSc|      |
               +---+------+------+------+      |
               |   0      |    .    .   |      |
               |   INS    |   DEL       |      |
               | Ins Mode | DelCurChar  |      |
               +----------+-------------+------+
~"**
~"create_status_message n=CSE$PC_CONNECT_10 c=9021 i='CS' s=i
                   IBM PC Without Mouse

 For mouse support, use PC_CONNECT_20.

 Function Keys

  A sample keyboard layout is shown below.

 +------+------+-----+------+------+------+------+------+------+
 |  F1  |  F2  |     |a     |a     |a     |a     |a     |a     |
 |  f1  |  f2  | ESC |c  1  |c  2  |c  3  |c  4  |c  5  |c  6  |
 +------+------+-----+-+------+------+------+----+------+------+-+
 |  F3  |  F4  |       |      |      |      |      | \ \    | InsL |
 |  f3  |  f4  |  TAB  |  Q   |  W   |  E   |  R   |  \ \   |a  I  |
 +------+------++------++-----++-----++-----++-----++--\ \--+------+
 |  F5  |  F6  ||       |      |      | DelL |      |
 |  f5  |  f6  || CTRL  |  A   |  S   |a  D  |      |
 +------+------++-------++-----++-----++-----++-----++
 |  F7  |  F8  ||        |      |      |ReWrSc|      |
 |  f7  |  f8  || SHIFT  |  Z   |  X   |a  C  |  V   |
 +------+------++--------+------+------+------+------+
 |  F9  | F10  ||       +
 |  f9  | f10  || ALT   |
 +------+------++-------+

 AT Style Keyboard Function Keys (101 Key) are located along the top of
 the keyboard and number 1 - 12.

 XT Style Keyboard Function Keys (shown above) are placed on the
 alphabetic keyboard. The function key operations are accessed
 by pressing the function key (f1) or combining the SHIFT key with the
 function key (F1). Other operations are performed by combining the
 CTRL (CONTROL) key with a character key [for example CTRL1 (c1),
 CTRL2 (c2)] or their shifted function with the ALT key [for example
 ALT1 (a1), ALT2 (a2)].

 Two other keys on the alphabetic keyboard are accessed by combining
 the ALT key with the character key:
     ALT(I)  (InsL) insert line.
     ALT(D)  (DelL) delete line.

 Other editing operations that can be performed using the CTRL key and
 the Function keys are:
     CTRL f1 (Middle) puts current line to middle of screen.
     CTRL f2 (LinUp) puts current line to top of screen.
     CTRL f3 (Format) moves words across line boundaries and
             standardizes spacing between words to fit current paragraph
             to specified margins.
     CTRL f4 (InsWd) inserts 32 blank characters.
     CTRL f5 (InsBk) inserts n number of empty lines; screen
             dependent.
     CTRL f6 (Indent) inserts 2 blank characters in front of marked
             text.

 Numeric Pad for IBM PC

 These keys are accessed by pressing the character key (shown).
 Functions accessed by pressing the CTRL key and the character key
 simultaneously are:
  CTRL(PgUp) - Aligns screen to display the beginning of the file
  CTRL(PgDn) - Aligns screen centered around the end of the file.

                +---------+-------+------+------+
   Normal       |Backspace|  ~   |NumLck|ScrlLk|
                |         |  `   |      |      |
                +---------+------+------+------+
                   |  7   |  8   |  9   |   -  |
                   | Home |      | PgUp |      |
                   | HmLn |      | NxtSc|      |
                   +------+------+------+------+
                   |  4   |  5   |  6   |   +  |
                   |      |      |      |      |
                   |      |      |      |      |
                   +------+------+------+------+
                   |  1   |  2   |  3   | Enter|
                   |  End |      | PgDn |      |
                   |StpIns|      | PrvSc|      |
               +---+------+------+------+      |
               |   0      |    .    .   |      |
               |   INS    |   DEL       |      |
               | Ins Mode | DelCurChar  |      |
               +----------+-------------+------+
~"**
~"create_status_message n=CSE$MAC_CONNECT_21 c=9022 i='CS' s=i
                Apple Macintosh Microcomputer

  Below the Macintosh Plus keyboard is annotated with operations.
  You execute the operation by pressing the OPTION key and the
  operation key simultaneously.  When more than one operation is
  listed, the top operation is performed using the shifted key (OPTION and
  SHIFT keys).  The Macintosh II keyboards (regular & extended) have the
  function keys located at the top of the keyboard.  They also have
  separate cursor keys and a numeric keypad.

 +--------+------+------+------+------+---\\-+------+
 |  ~     |(F1)  |(F2)  |(F3)  |(F4)  |(F5)\\|(F10) |
 |        |      |      |      |      |     \\      |
 |  `     |   1  |   2  |   3  |   4  |   5  \\  0  |
 +--------+-+------+------+------+----+--------+----+-+
 |          |(F11) |(F12) |(F13) |(F14) |(F15) |(F16) |
 |          |      |      |      |      |      |      |
 |  TAB     |  Q   |  W   |  E   |  R   |   T  |  Y   |
 +----------++-----++-----++-----++-----+------++-------+
 |           |      |      |      | EOF  |      |      |
 |           |      |      |      | NxtSc|      | HmLn |
 | CAPS LOCK |  A   |  S   |  D   |  F   |   G  |  H   |
 +-----------++-----++-----++-----+-+-----++-----++------+
 |            |      |      |DlChEOL|      |BegFil|      |
 |            |      |      |ReWrSc |      | PrvSc|      |
 |  SHIFT     |  Z   |  X   |  C    |  V   |  B   |  N   |
 +---------+--+------+------+-------+------+------+------+
 |         | Apple   |                     InsBlLn       /
 |  OPTION | CMD Key |     SPACE BAR       InsBlChar     /
 +---------+---------+-----------------------------------/

        /+------+------+------+------+------+-------+
       / | (F8) | (F9) | (F10)|  _   |  +   | DelLn |
      /  |      |      |      |      |      | DelCh |
     /   |  8   |  9   |  0   |  -   |  =   | BkSpac|
    /----+-+----+-+----+-+----+-+----+-+----+-+-----+
   /|      |   ^  |      |      | {    | }    |     |
  / |      |   |  |      |      |      |      |     |
  /  |  U   |  I   | O    | P    | [    | ]    |     |
 \--+-+----+-+----+-+----+-+----+-+---+---+---+     |
  \   |      |      |      | :Back| "Data |         |
   \  |  <-  |  ->  |      |      |       |RETURN   |
    \ |  J   | K    | L    |   ;  | 'Data |         |
    /-+ +----+ +----+-+ ---+-+----+-+-----+--+------+
   /    |  |   | <    | >Edit| Edit-|        |  ^   |
  /     |  V   |      |      | Help |        |  |   |
 /      |  M   | ,    | .Edit|  ?   | SHIFT  |  |   |
 \------+------+------+-+----+-+----+-+------+------+
  /           InsBlLine |  |   |      |      |  |   |
  / SPACE BAR           |      | <--- |--->  |  |   |
  /           InsBlChar |  \   |      |      |  V   |
  /---------------------+------+------+------+------+

 Notes On Screen Editing

  - If you are using a Macintosh SE or Macintosh II you must use
    CONNECT version 2.0 or later.

  - You can position the cursor by pressing the OPTION key while
    clicking the mouse at the new position

  - On the Macintosh Plus the arrow keys position the cursor.  On
    the standard Macintosh you must use the keys defined on the
    keyboard (I, J, K, M).

    If you are using a CONNECT version 1.1 or later, you can
    redefine these keys.

  - The following operations are available for use, but are not
    defined:

          edit           OPTION .
          SHIFT edit     OPTION >
          data           OPTION '
          SHIFT data     OPTION "
          SHIFT back     OPTION :

    To define these operations use the SET_FUNCTION_KEY
    subcommand.
~"**
~"create_status_message n=CSE$MAC_CONNECT_22 c=9023 i='CS' s=i
                Apple Macintosh Microcomputer

  Below the Macintosh Plus keyboard is annotated with operations.
  You execute the operation by pressing the OPTION key and the
  operation key simultaneously.  When more than one operation is
  listed, the top operation is performed using the shifted key (OPTION and
  SHIFT keys).  The Macintosh II keyboards (regular & extended) have the
  function keys located at the top of the keyboard.  They also have
  separate cursor keys and a numeric keypad.

 +--------+------+------+------+------+---\\-+------+
 |  ~     |(F1)  |(F2)  |(F3)  |(F4)  |(F5)\\|(F10) |
 |        |      |      |      |      |     \\      |
 |  `     |   1  |   2  |   3  |   4  |   5  \\  0  |
 +--------+-+------+------+------+----+--------+----+-+
 |          |(F11) |(F12) |(F13) |(F14) |(F15) |(F16) |
 |          |      |      |      |      |      |      |
 |  TAB     |  Q   |  W   |  E   |  R   |   T  |  Y   |
 +----------++-----++-----++-----++-----+------++-------+
 |           |      |      |      | EOF  |      |      |
 |           |      |      |      | NxtSc|      | HmLn |
 | CAPS LOCK |  A   |  S   |  D   |  F   |   G  |  H   |
 +-----------++-----++-----++-----+-+-----++-----++------+
 |            |      |      |DlChEOL|      |BegFil|      |
 |            |      |      |ReWrSc |      | PrvSc|      |
 |  SHIFT     |  Z   |  X   |  C    |  V   |  B   |  N   |
 +---------+--+------+------+-------+------+------+------+
 |         | Apple   |                     InsBlLn       /
 |  OPTION | CMD Key |     SPACE BAR       InsBlChar     /
 +---------+---------+-----------------------------------/

        /+------+------+------+------+------+-------+
       / | (F8) | (F9) | (F10)|  _   |  +   | DelLn |
      /  |      |      |      |      |      | DelCh |
     /   |  8   |  9   |  0   |  -   |  =   | BkSpac|
    /----+-+----+-+----+-+----+-+----+-+----+-+-----+
   /|      |   ^  |      |      | {    | }    |     |
  / |      |   |  |      |      |      |      |     |
  /  |  U   |  I   | O    | P    | [    | ]    |     |
 \--+-+----+-+----+-+----+-+----+-+---+---+---+     |
  \   |      |      |      | :Back| "Data |         |
   \  |  <-  |  ->  |      |      |       |RETURN   |
    \ |  J   | K    | L    |   ;  | 'Data |         |
    /-+ +----+ +----+-+ ---+-+----+-+-----+--+------+
   /    |  |   | <    | >Edit| Edit-|        |  ^   |
  /     |  V   |      |      | Help |        |  |   |
 /      |  M   | ,    | .Edit|  ?   | SHIFT  |  |   |
 \------+------+------+-+----+-+----+-+------+------+
  /           InsBlLine |  |   |      |      |  |   |
  / SPACE BAR           |      | <--- |--->  |  |   |
  /           InsBlChar |  \   |      |      |  V   |
  /---------------------+------+------+------+------+

 Notes On Screen Editing

  - If you are using a Macintosh SE or Macintosh II you must use
    CONNECT version 2.0 or later.

  - You can position the cursor by pressing the OPTION key while
    clicking the mouse at the new position

  - On the Macintosh Plus the arrow keys position the cursor.  On
    the standard Macintosh you must use the keys defined on the
    keyboard (I, J, K, M).

    If you are using a CONNECT version 1.1 or later, you can
    redefine these keys.

  - The following operations are available for use, but are not
    defined:

          edit           OPTION .
          SHIFT edit     OPTION >
          data           OPTION '
          SHIFT data     OPTION "
          SHIFT back     OPTION :

    To define these operations use the SET_FUNCTION_KEY
    subcommand.
~"**
~"create_status_message n=CSE$MAC_CONNECT_11 c=9024 i='CS' s=i
                Apple Macintosh Microcomputer

  Below the Macintosh Plus keyboard is annotated with operations.
  You execute the operation by pressing the OPTION key and the
  operation key simultaneously.  When more than one operation is
  listed, the top operation is performed using the shifted key (OPTION and
  SHIFT keys).  The Macintosh II keyboards (regular & extended) have the
  function keys located at the top of the keyboard.  They also have
  separate cursor keys and a numeric keypad.

 +--------+------+------+------+------+---\\-+------+
 |  ~     |(F1)  |(F2)  |(F3)  |(F4)  |(F5)\\|(F10) |
 |        |      |      |      |      |     \\      |
 |  `     |   1  |   2  |   3  |   4  |   5  \\  0  |
 +--------+-+------+------+------+----+--------+----+-+
 |          |(F11) |(F12) |(F13) |(F14) |(F15) |(F16) |
 |          |      |      |      |      |      |      |
 |  TAB     |  Q   |  W   |  E   |  R   |   T  |  Y   |
 +----------++-----++-----++-----++-----+------++-------+
 |           |      |      |      | EOF  |      |      |
 |           |      |      |      | NxtSc|      | HmLn |
 | CAPS LOCK |  A   |  S   |  D   |  F   |   G  |  H   |
 +-----------++-----++-----++-----+-+-----++-----++------+
 |            |      |      |DlChEOL|      |BegFil|      |
 |            |      |      |ReWrSc |      | PrvSc|      |
 |  SHIFT     |  Z   |  X   |  C    |  V   |  B   |  N   |
 +---------+--+------+------+-------+------+------+------+
 |         | Apple   |                     InsBlLn       /
 |  OPTION | CMD Key |     SPACE BAR       InsBlChar     /
 +---------+---------+-----------------------------------/

        /+------+------+------+------+------+-------+
       / | (F8) | (F9) | (F10)|  _   |  +   | DelLn |
      /  |      |      |      |      |      | DelCh |
     /   |  8   |  9   |  0   |  -   |  =   | BkSpac|
    /----+-+----+-+----+-+----+-+----+-+----+-+-----+
   /|      |   ^  |      |      | {    | }    |     |
  / |      |   |  |      |      |      |      |     |
  /  |  U   |  I   | O    | P    | [    | ]    |     |
 \--+-+----+-+----+-+----+-+----+-+---+---+---+     |
  \   |      |      |      | :Back| "Data |         |
   \  |  <-  |  ->  |      |      |       |RETURN   |
    \ |  J   | K    | L    |   ;  | 'Data |         |
    /-+ +----+ +----+-+ ---+-+----+-+-----+--+------+
   /    |  |   | <    | >Edit| Edit-|        |  ^   |
  /     |  V   |      |      | Help |        |  |   |
 /      |  M   | ,    | .Edit|  ?   | SHIFT  |  |   |
 \------+------+------+-+----+-+----+-+------+------+
  /           InsBlLine |  |   |      |      |  |   |
  / SPACE BAR           |      | <--- |--->  |  |   |
  /           InsBlChar |  \   |      |      |  V   |
  /---------------------+------+------+------+------+

 Notes On Screen Editing

  - If you are using a Macintosh SE or Macintosh II you must use
    CONNECT version 2.0 or later.

  - You can position the cursor by pressing the OPTION key while
    clicking the mouse at the new position

  - On the Macintosh Plus the arrow keys position the cursor.  On
    the standard Macintosh you must use the keys defined on the
    keyboard (I, J, K, M).

    If you are using a CONNECT version 1.1 or later, you can
    redefine these keys.

  - The following operations are available for use, but are not
    defined:

          edit           OPTION .
          SHIFT edit     OPTION >
          data           OPTION '
          SHIFT data     OPTION "
          SHIFT back     OPTION :

    To define these operations use the SET_FUNCTION_KEY
    subcommand.
~"**
~"create_status_message n=CSE$MAC_CONNECT_10 c=9025 i='CS' s=i
                Apple Macintosh Microcomputer

  Below the Macintosh Plus keyboard is annotated with operations.
  You execute the operation by pressing the OPTION key and the
  operation key simultaneously.  When more than one operation is
  listed, the top operation is performed using the shifted key (OPTION and
  SHIFT keys).  The Macintosh II keyboards (regular & extended) have the
  function keys located at the top of the keyboard.  They also have
  separate cursor keys and a numeric keypad.

 +--------+------+------+------+------+---\\-+------+
 |  ~     |(F1)  |(F2)  |(F3)  |(F4)  |(F5)\\|(F10) |
 |        |      |      |      |      |     \\      |
 |  `     |   1  |   2  |   3  |   4  |   5  \\  0  |
 +--------+-+------+------+------+----+--------+----+-+
 |          |(F11) |(F12) |(F13) |(F14) |(F15) |(F16) |
 |          |      |      |      |      |      |      |
 |  TAB     |  Q   |  W   |  E   |  R   |   T  |  Y   |
 +----------++-----++-----++-----++-----+------++-------+
 |           |      |      |      | EOF  |      |      |
 |           |      |      |      | NxtSc|      | HmLn |
 | CAPS LOCK |  A   |  S   |  D   |  F   |   G  |  H   |
 +-----------++-----++-----++-----+-+-----++-----++------+
 |            |      |      |DlChEOL|      |BegFil|      |
 |            |      |      |ReWrSc |      | PrvSc|      |
 |  SHIFT     |  Z   |  X   |  C    |  V   |  B   |  N   |
 +---------+--+------+------+-------+------+------+------+
 |         | Apple   |                     InsBlLn       /
 |  OPTION | CMD Key |     SPACE BAR       InsBlChar     /
 +---------+---------+-----------------------------------/

        /+------+------+------+------+------+-------+
       / | (F8) | (F9) | (F10)|  _   |  +   | DelLn |
      /  |      |      |      |      |      | DelCh |
     /   |  8   |  9   |  0   |  -   |  =   | BkSpac|
    /----+-+----+-+----+-+----+-+----+-+----+-+-----+
   /|      |   ^  |      |      | {    | }    |     |
  / |      |   |  |      |      |      |      |     |
  /  |  U   |  I   | O    | P    | [    | ]    |     |
 \--+-+----+-+----+-+----+-+----+-+---+---+---+     |
  \   |      |      |      | :Back| "Data |         |
   \  |  <-  |  ->  |      |      |       |RETURN   |
    \ |  J   | K    | L    |   ;  | 'Data |         |
    /-+ +----+ +----+-+ ---+-+----+-+-----+--+------+
   /    |  |   | <    | >Edit| Edit-|        |  ^   |
  /     |  V   |      |      | Help |        |  |   |
 /      |  M   | ,    | .Edit|  ?   | SHIFT  |  |   |
 \------+------+------+-+----+-+----+-+------+------+
  /           InsBlLine |  |   |      |      |  |   |
  / SPACE BAR           |      | <--- |--->  |  |   |
  /           InsBlChar |  \   |      |      |  V   |
  /---------------------+------+------+------+------+

 Notes On Screen Editing

  - If you are using a Macintosh SE or Macintosh II you must use
    CONNECT version 2.0 or later.

  - You can position the cursor by pressing the OPTION key while
    clicking the mouse at the new position

  - On the Macintosh Plus the arrow keys position the cursor.  On
    the standard Macintosh you must use the keys defined on the
    keyboard (I, J, K, M).

    If you are using a CONNECT version 1.1 or later, you can
    redefine these keys.

  - The following operations are available for use, but are not
    defined:

          edit           OPTION .
          SHIFT edit     OPTION >
          data           OPTION '
          SHIFT data     OPTION "
          SHIFT back     OPTION :

    To define these operations use the SET_FUNCTION_KEY
    subcommand.
~"**
~"end_message_module
*DECK DECK=CSM$TV_950 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR TELEVIDEO 950 TERMINAL                       "

"   VARIABLES                                                                 "
    ATTRIBUTES_OCCUPY_SPACE = (ESC 'F0')
    CLEAR_PROTECT           = (ESC '(' ESC '''')
    PAGE_BASED_ATTRIBUTES   = (ESC '[=2h')
    HOME                    = (RS)
    NORMAL                  = (ESC 'G0')
    LOCK_KEYBOARD           = (ESC '#')
"   PROTECT_MODE_OFF        = (ESC '''')
"   PROTECT_MODE_ON         = (ESC '&')
    SELECT_FUNCTION_KEY_SET = (ESC '[7;0v')
"   STOP_PROTECT            = (ESC '(')
"   START_PROTECT           = (ESC ')')
    START_INVISIBLE         = (ESC 'G1')
    START_BLINK             = (ESC 'G2')
    START_INVERSE           = (ESC 'G4')
    START_UNDERLINE         = (ESC 'G8')
    TV950_MODE              = (ESC '[10;1v')
    UNLOCK_KEYBOARD         = (ESC '"')
    WRAP_ON                 = (ESC '[=7h')
    WRAP_OFF                = (ESC '[=7l')
    DEFIN1                  = (ESC '~2' TV950_MODE SELECT_FUNCTION_KEY_SET)
    DEFIN2                  = (ATTRIBUTES_OCCUPY_SPACE PAGE_BASED_ATTRIBUTES)
    DEFINIT                 = (DEFIN1 DEFIN2)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'TV_950'
    communications      type  = asynch
    function_key_leaves_mark  value = 1
    application_string name='driver_procedure' out='tup$bootstrap_tv950_driver'
    application_string  name='insert_delete_scrolling' out='true'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (20(16))    type = binary_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_begin         out   = (ESC '=')

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (HOME)         label='Home'
    cursor_up                inout = (VT)
    cursor_down              inout = (SYN)
    cursor_left              inout = (BS)
    cursor_right             inout = (FF)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = stop_next
    move_past_left           type  = stop_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_left           type  = stop_next
    char_past_right          type  = stop_next
    char_past_last_position  type  = scroll_next

    AUTOMATIC_TABBING               value = FALSE  "unprotect"
    CLEARS_WHEN_CHANGE_SIZE         value = FALSE
    FUNCTION_KEY_LEAVES_MARK        value = 0
    HAS_HIDDEN                      value = TRUE
    HAS_PROTECT                     value = FALSE
    HOME_AT_TOP                     value = TRUE
    MULTIPLE_SIZES                  value = FALSE
    TABS_TO_HOME                    value = FALSE
    TABS_TO_TAB_STOPS               value = TRUE
    TABS_TO_UNPROTECTED             value = FALSE
    TYPE_AHEAD                      value = TRUE

"   SCREEN SIZE                                                               "
    set_size                 rows = 24 columns = 80

"   SCREEN AND LINE MODE TRANSITION                                           "
    screen_init         out = (DEFINIT)
    set_screen_mode     out = ()
    set_line_mode       out = (UNLOCK_KEYBOARD)

"   TERMINAL CAPABILITIES                                                     "
    delete_char         inout = (ESC 'W')          label='char del'
    delete_line_bol     inout = (ESC 'R')          label='line del'
    erase_end_of_line   inout = (ESC 'T')          label='line erase'
    erase_page_home     inout = (SUB)              label='page erase'
    erase_unprotected   inout = (ESC '+')
    erase_end_of_page   inout = (ESC 'Y')
    insert_char         inout = (ESC 'Q')          label='char ins'
    insert_line_bol     inout = (ESC 'E')          label='line ins'
    insert_mode_begin   inout = (ESC 'q')          label='insert begin'
    insert_mode_end     inout = (ESC 'r')
    tab_backward        inout = (ESC 'I')
    tab_clear_all       inout = (ESC '3')
    tab_set             inout = (ESC '1')
    tab_forward         inout = (HT)

"   VIDEO ATTRIBUTES AND SEQUENCES                                            "
    bell_nak                 out = (BEL)
    output_begin             out = ("wrap_off")
    output_end               out = ("wrap_on")
    display_begin            out = ()
    display_end              out = ()
    output_text_begin        out = ()
    output_text_end          out = ()
    title_begin              out = ()
    title_end                out = ()
    message_begin            out = ()
    message_end              out = ()
    italic_begin             out = (start_inverse)
    italic_end               out = (normal)
    input_text_begin         out = (START_UNDERLINE)
    input_text_end           out = (NORMAL)
    alt_begin                out = ()
    alt_end                  out = ()
    blink_begin              out = (START_BLINK)
    blink_end                out = (NORMAL)
    hidden_begin             out = (START_INVISIBLE)
    hidden_end               out = (NORMAL)
    inverse_begin            out = (START_INVERSE)
    inverse_end              out = (NORMAL)
    underline_begin          out = (START_UNDERLINE)
    underline_end            out = (NORMAL)
    error_begin              out = (START_INVERSE)
    error_end                out = (NORMAL)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13           label='return'

    f1        in = (SOH '@')    label='f1'
    f2        in = (SOH 'A')    label='f2'
    f3        in = (SOH 'B')    label='f3'
    f4        in = (SOH 'C')    label='f4'
    f5        in = (SOH 'D')    label='f5'
    f6        in = (SOH 'E')    label='f6'
    f7        in = (SOH 'F')    label='f7'
    f8        in = (SOH 'G')    label='f8'
    f9        in = (SOH 'H')    label='f9'
    f10       in = (SOH 'I')    label='10'
    f11       in = (SOH 'J')    label='11'
    f1_s      in = (SOH '`')    label='  f1'
    f2_s      in = (SOH 'a')    label='  f2'
    f3_s      in = (SOH 'b')    label='  f3'
    f4_s      in = (SOH 'c')    label='  f4'
    f5_s      in = (SOH 'd')    label='  f5'
    f6_s      in = (SOH 'e')    label='  f6'
    f7_s      in = (SOH 'f')    label='  f7'
    f8_s      in = (SOH 'g')    label='  f8'
    f9_s      in = (SOH 'h')    label='  f9'
    f10_s     in = (SOH 'i')    label='  10'
    f11_s     in = (SOH 'j')    label='  11'

    bkw       in = (SOH '@')    label='f1'
    fwd       in = (SOH 'A')    label='f2'
    back      in = (SOH 'B')    label='f3'
    help      in = (SOH 'C')    label='f4'
    undo      in = (SOH 'D')    label='f5'
    stop      in = (SOH 'E')    label='f6'
    bkw_s     in = (SOH '`')    label='  f1'
    fwd_s     in = (SOH 'a')    label='  f2'
    undo_s    in = (SOH 'd')    label='  f5'
    stop_s    in = (SOH 'e')    label='  f6'

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = (ESC '$')
    ld_fine_end              out = (ESC '%')
    ld_fine_horizontal       out = ('K')
    ld_fine_vertical         out = ('J')
    ld_fine_upper_left       out = ('F')
    ld_fine_upper_right      out = ('G')
    ld_fine_lower_left       out = ('E')
    ld_fine_lower_right      out = ('H')
    ld_fine_up_t             out = ('N')
    ld_fine_down_t           out = ('O')
    ld_fine_left_t           out = ('M')
    ld_fine_right_t          out = ('L')
    ld_fine_cross            out = ('I')
    ld_medium_begin          out = (ESC '$')
    ld_medium_end            out = (ESC '%')
    ld_medium_horizontal     out = ('K')
    ld_medium_vertical       out = ('J')
    ld_medium_upper_left     out = ('F')
    ld_medium_upper_right    out = ('G')
    ld_medium_lower_left     out = ('E')
    ld_medium_lower_right    out = ('H')
    ld_medium_up_t           out = ('N')
    ld_medium_down_t         out = ('O')
    ld_medium_left_t         out = ('M')
    ld_medium_right_t        out = ('L')
    ld_medium_cross          out = ('I')
    ld_bold_begin            out = (ESC '$')
    ld_bold_end              out = (ESC '%')
    ld_bold_horizontal       out = ('K')
    ld_bold_vertical         out = ('J')
    ld_bold_upper_left       out = ('F')
    ld_bold_upper_right      out = ('G')
    ld_bold_lower_left       out = ('E')
    ld_bold_lower_right      out = ('H')
    ld_bold_up_t             out = ('N')
    ld_bold_down_t           out = ('O')
    ld_bold_left_t           out = ('M')
    ld_bold_right_t          out = ('L')
    ld_bold_cross            out = ('I')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR TELEVIDEO 950T TERMINAL              "
*DECK DECK=CSM$TV_950_PROTECTED EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR TELEVIDEO 950 TERMINAL                       "

"   VARIABLES                                                                 "
    ATTRIBUTES_OCCUPY_SPACE = (ESC 'F0')
    CLEAR_PROTECT           = (ESC '(' ESC '''')
    PAGE_BASED_ATTRIBUTES   = (ESC '[=2h')
    HOME                    = (RS)
    NORMAL                  = (ESC 'G0')
    LOCK_KEYBOARD           = (ESC '#')
    PROTECT_MODE_OFF        = (ESC '''')
    PROTECT_MODE_ON         = (ESC '&')
    SELECT_FUNCTION_KEY_SET = (ESC '[7;0v')
    STOP_PROTECT            = (ESC '(')
    START_PROTECT           = (ESC ')')
    START_INVISIBLE         = (ESC 'G1')
    START_BLINK             = (ESC 'G2')
    START_INVERSE           = (ESC 'G4')
    START_UNDERLINE         = (ESC 'G8')
    TV950_MODE              = (ESC '[10;1v')
    UNLOCK_KEYBOARD         = (ESC '"')
    WRAP_ON                 = (ESC '[=7h')
    WRAP_OFF                = (ESC '[=7l')
    DEFIN1                  = (ESC '~2' TV950_MODE SELECT_FUNCTION_KEY_SET)
    DEFIN2                  = (ATTRIBUTES_OCCUPY_SPACE PAGE_BASED_ATTRIBUTES)
    DEFINIT                 = (DEFIN1 DEFIN2)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'TV_950_protected'
    communications      type  = asynch
    function_key_leaves_mark  value = 1
    application_string name='driver_procedure' out='tup$bootstrap_tv950_driver'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (20(16))    type = binary_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_begin         out   = (ESC '=')

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (HOME)            label='home'
    cursor_up                inout = (VT)
    cursor_down              inout = (SYN)
    cursor_left              inout = (BS)
    cursor_right             inout = (FF)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_left           type  = wrap_adjacent_next
    char_past_right          type  = wrap_adjacent_next
    char_past_last_position  type  = wrap_adjacent_next

    AUTOMATIC_TABBING               value = TRUE
    CLEARS_WHEN_CHANGE_SIZE         value = FALSE
    FUNCTION_KEY_LEAVES_MARK        value = 0
    HAS_HIDDEN                      value = TRUE
    HAS_PROTECT                     value = TRUE
    HOME_AT_TOP                     value = TRUE
    MULTIPLE_SIZES                  value = FALSE
    TABS_TO_HOME                    value = FALSE
    TABS_TO_TAB_STOPS               value = FALSE
    TABS_TO_UNPROTECTED             value = TRUE
    TYPE_AHEAD                      value = TRUE

"   SCREEN SIZE                                                               "
    set_size                 rows = 24 columns = 80

"   SCREEN AND LINE MODE TRANSITION                                           "
    screen_init         out = (DEFINIT)
    set_screen_mode     out = ()
    set_line_mode       out = (CLEAR_PROTECT UNLOCK_KEYBOARD)

"   TERMINAL CAPABILITIES                                                     "
    delete_char         inout = (ESC 'W')          label='char del'
    erase_end_of_line   inout = (ESC 'T')          label='line erase'
"   erase_end_of_line   out   = (START_PROTECT ESC 'T' STOP_PROTECT)
    erase_page_home     inout = (SUB)              label='page erase'
    erase_unprotected   inout = (ESC '+')
    erase_end_of_page   inout = (ESC 'Y')
    insert_char         inout = (ESC 'Q')          label='char ins'
    insert_mode_begin   inout = (ESC 'q')          label='insert begin'
    insert_mode_end     inout = (ESC 'r')
    tab_backward        inout = (ESC 'I')
    tab_clear_all       inout = (ESC '3')
    tab_set             inout = (ESC '1')
    tab_forward         inout = (HT)

"   VIDEO ATTRIBUTES AND SEQUENCES                                            "
    bell_nak                 out = (BEL)
    output_begin             out = (PROTECT_MODE_OFF)
    output_end               out = (protect_mode_on)
    display_begin            out = ()
    display_end              out = ()
    output_text_begin        out = ()
    output_text_end          out = ()
    title_begin              out = ()
    title_end                out = ()
    message_begin            out = ()
    message_end              out = ()
    italic_begin             out = (start_inverse)
    italic_end               out = (normal)
    input_text_begin         out = (START_UNDERLINE)
    input_text_end           out = (NORMAL)
    protect_all              out = ()
    alt_begin                out = ()
    alt_end                  out = ()
    blink_begin              out = (START_BLINK)
    blink_end                out = (NORMAL)
    hidden_begin             out = (START_INVISIBLE)
    hidden_end               out = (NORMAL)
    inverse_begin            out = (START_INVERSE)
    inverse_end              out = (NORMAL)
    protect_begin            out = (START_PROTECT)
    protect_end              out = (STOP_PROTECT)
    underline_begin          out = (START_UNDERLINE)
    underline_end            out = (NORMAL)
    error_begin              out = (START_INVERSE)
    error_end                out = (NORMAL)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13           label='return'
    f1        in = (SOH '@')   label='f1'
    f2        in = (SOH 'A')   label='f2'
    f3        in = (SOH 'B')   label='f3'
    f4        in = (SOH 'C')   label='f4'
    f5        in = (SOH 'D')   label='f5'
    f6        in = (SOH 'E')   label='f6'
    f7        in = (SOH 'F')   label='f7'
    f8        in = (SOH 'G')   label='f8'
    f9        in = (SOH 'H')   label='f9'
    f10       in = (SOH 'I')   label='10'
    f11       in = (SOH 'J')   label='11'
    f1_s      in = (SOH '`')   label='  f1'
    f2_s      in = (SOH 'a')   label='  f2'
    f3_s      in = (SOH 'b')   label='  f3'
    f4_s      in = (SOH 'c')   label='  f4'
    f5_s      in = (SOH 'd')   label='  f5'
    f6_s      in = (SOH 'e')   label='  f6'
    f7_s      in = (SOH 'f')   label='  f7'
    f8_s      in = (SOH 'g')   label='  f8'
    f9_s      in = (SOH 'h')   label='  f9'
    f10_s     in = (SOH 'i')   label='  10'
    f11_s     in = (SOH 'j')   label='  11'

    bkw       in = (SOH '@')    label='f1'
    fwd       in = (SOH 'A')    label='f2'
    back      in = (SOH 'B')    label='f3'
    help      in = (SOH 'C')    label='f4'
    undo      in = (SOH 'D')    label='f5'
    stop      in = (SOH 'E')    label='f6'
    bkw_s     in = (SOH '`')    label='  f1'
    fwd_s     in = (SOH 'a')    label='  f2'
    undo_s    in = (SOH 'd')    label='  f5'
    stop_s    in = (SOH 'e')    label='  f6'

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = (ESC '$')
    ld_fine_end              out = (ESC '%')
    ld_fine_horizontal       out = ('K')
    ld_fine_vertical         out = ('J')
    ld_fine_upper_left       out = ('F')
    ld_fine_upper_right      out = ('G')
    ld_fine_lower_left       out = ('E')
    ld_fine_lower_right      out = ('H')
    ld_fine_up_t             out = ('N')
    ld_fine_down_t           out = ('O')
    ld_fine_left_t           out = ('M')
    ld_fine_right_t          out = ('L')
    ld_fine_cross            out = ('I')
    ld_medium_begin          out = (ESC '$')
    ld_medium_end            out = (ESC '%')
    ld_medium_horizontal     out = ('K')
    ld_medium_vertical       out = ('J')
    ld_medium_upper_left     out = ('F')
    ld_medium_upper_right    out = ('G')
    ld_medium_lower_left     out = ('E')
    ld_medium_lower_right    out = ('H')
    ld_medium_up_t           out = ('N')
    ld_medium_down_t         out = ('O')
    ld_medium_left_t         out = ('M')
    ld_medium_right_t        out = ('L')
    ld_medium_cross          out = ('I')
    ld_bold_begin            out = (ESC '$')
    ld_bold_end              out = (ESC '%')
    ld_bold_horizontal       out = ('K')
    ld_bold_vertical         out = ('J')
    ld_bold_upper_left       out = ('F')
    ld_bold_upper_right      out = ('G')
    ld_bold_lower_left       out = ('E')
    ld_bold_lower_right      out = ('H')
    ld_bold_up_t             out = ('N')
    ld_bold_down_t           out = ('O')
    ld_bold_left_t           out = ('M')
    ld_bold_right_t          out = ('L')
    ld_bold_cross            out = ('I')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR TELEVIDEO 950T TERMINAL              "
*DECK DECK=CSM$TV_955 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR TELEVIDEO 955 TERMINAL                       "

"   VARIABLES                                                                 "
    ATTRIBUTES_SPACELESS    = (ESC 'F1')
    ATTRIBUTE_MODE_LINE     = (ESC '[=2l')
    AUTOWRAP_ON             = (ESC '[=7h')
    AUTOWRAP_OFF            = (ESC '[=7l')
    CLEAR_PROTECT           = (ESC '(' ESC '''')
    HOME                    = (RS)
    LARGE_SCREEN            = (ESC '[=3h')
    SMALL_SCREEN            = (ESC '[=3l')
    LOCK_KEYBOARD           = (ESC '#')
    NORMAL                  = (ESC 'G0')
    SELECT_FUNCTION_KEY_SET = (ESC '[7;0v')
    SET_DOWN_KEY_CTRL_J     = (ESC '[=9l')
    START_BLINK             = (ESC 'G2')
    START_INVISIBLE         = (ESC 'G1')
    START_INVERSE           = (ESC 'G4')
    START_UNDERLINE         = (ESC 'G8')
    TV955_MODE              = (ESC '[10;0v')
    UNLOCK_KEYBOARD         = (ESC '"')
    DEFIN1                  = (ESC '~2' TV955_MODE SELECT_FUNCTION_KEY_SET)
    DEFIN2                  = (ATTRIBUTES_SPACELESS ATTRIBUTE_MODE_LINE)
    DEFIN3                  = (SET_DOWN_KEY_CTRL_J AUTOWRAP_OFF)
    DEFINIT                 = (DEFIN1 DEFIN2 DEFIN3)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name               value = 'TV_955'
    communications           type  = asynch
    application_string name='driver_procedure' out='tup$bootstrap_tv955_driver'
    application_string  name='insert_delete_scrolling' out='true'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information       in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (ESC '[')
    cursor_pos_second        out   = (';')
    cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (HOME)          label='home'
    cursor_up                inout = (VT)
    cursor_down              inout = (SYN)
    cursor_left              inout = (BS)
    cursor_right             inout = (FF)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = stop_next
    move_past_left           type  = stop_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = stop_next
    char_past_left           type  = stop_next
    char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
    automatic_tabbing              value = TRUE
    clears_when_change_size        value = FALSE
    function_key_leaves_mark       value = 1
    has_hidden                     value = TRUE
    has_protect                    value = FALSE
    home_at_top                    value = TRUE
    multiple_sizes                 value = TRUE
    tabs_to_home                   value = FALSE
    tabs_to_tab_stops              value = TRUE
    tabs_to_unprotected            value = FALSE
    type_ahead                     value = TRUE

"   SCREEN SIZE                                                               "
    set_size                 rows  = 24 columns = 80   out = (SMALL_SCREEN)
    set_size                 rows  = 24 columns = 132  out = (LARGE_SCREEN)

"   SCREEN AND LINE MODE TRANSITION                                           "
    screen_init              out   = (DEFINIT)
    set_screen_mode          out   = ()
    set_line_mode            out   = (CLEAR_PROTECT UNLOCK_KEYBOARD AUTOWRAP_ON)

"   TERMINAL CAPABILITIES                                                     "
    delete_char              inout = (ESC 'W')       label='char del'
    delete_line_bol          inout = (ESC 'R')       label='line del'
    erase_end_of_line        inout = (ESC 'T')       label='line erase'
    erase_end_of_page        inout = (ESC 'Y')       label='page erase'
    erase_unprotected        inout = (ESC '+')       label='page erase'
    erase_page_home          inout = (SUB)           label='page erase'
    insert_char              inout = (ESC 'Q')       label='char ins'
    insert_line_bol          inout = (ESC 'E')       label='line ins'
    insert_mode_begin        inout = (ESC 'q')
    insert_mode_end          inout = (ESC 'r')
    tab_backward             inout = (ESC 'I')
    tab_clear_all            inout = (ESC '3')
    tab_set                  inout = (ESC '1')
    tab_forward              inout = (HT)

"   VIDEO ATTRIBUTES AND SEQUENCES                                            "
    bell_nak                 out   = (BEL)
    output_begin             out   = ()
    output_end               out   = ()
    output_text_begin        out   = ()
    output_text_end          out   = ()
    display_begin            out   = ()
    display_end              out   = ()
    title_begin              out   = ()
    title_end                out   = ()
    message_begin            out   = ()
    message_end              out   = ()
    italic_begin             out   = (start_inverse)
    italic_end               out   = (normal)
    input_text_begin         out   = (START_UNDERLINE)
    input_text_end           out   = (NORMAL)
    protect_all              out   = ()
    alt_begin                out   = ()
    alt_end                  out   = ()
    blink_begin              out   = (START_BLINK)
    blink_end                out   = (NORMAL)
    hidden_begin             out   = (START_INVISIBLE)
    hidden_end               out   = (NORMAL)
    inverse_begin            out   = (START_INVERSE)
    inverse_end              out   = (NORMAL)
    protect_begin            out   = ()
    protect_end              out   = ()
    underline_begin          out   = (START_UNDERLINE)
    underline_end            out   = (NORMAL)
    error_begin              out   = (START_INVERSE)
    error_end                out   = (NORMAL)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13           label='return'
    f1        in = (SOH '@')    label='f1'
    f2        in = (SOH 'A')    label='f2'
    f3        in = (SOH 'B')    label='f3'
    f4        in = (SOH 'C')    label='f4'
    f5        in = (SOH 'D')    label='f5'
    f6        in = (SOH 'E')    label='f6'
    f7        in = (SOH 'F')    label='f7'
    f8        in = (SOH 'G')    label='f8'
    f9        in = (SOH 'H')    label='f9'
    f10       in = (SOH 'I')    label='10'
    f11       in = (SOH 'J')    label='11'
    f12       in = (SOH 'K')    label='12'
    f13       in = (SOH 'L')    label='13'
    f14       in = (SOH 'M')    label='14'
    f15       in = (SOH 'N')    label='15'
    f16       in = (SOH 'O')    label='16'
    f1_s      in = (SOH '`')    label='  x'
    f2_s      in = (SOH 'a')    label='  x'
    f3_s      in = (SOH 'b')    label='  x'
    f4_s      in = (SOH 'c')    label='  x'
    f5_s      in = (SOH 'd')    label='  x'
    f6_s      in = (SOH 'e')    label='  x'
    f7_s      in = (SOH 'f')    label='  x'
    f8_s      in = (SOH 'g')    label='  x'
    f9_s      in = (SOH 'h')    label='  x'
    f10_s     in = (SOH 'i')    label='  x'
    f11_s     in = (SOH 'j')    label='  x'
    f12_s     in = (SOH 'k')    label='  x'
    f13_s     in = (SOH 'l')    label='  x'
    f14_s     in = (SOH 'm')    label='  x'
    f15_s     in = (SOH 'n')    label='  x'
    f16_s     in = (SOH 'o')    label='  x'

    bkw       in = (SOH '@')    label='f1'
    fwd       in = (SOH 'A')    label='f2'
    back      in = (SOH 'B')    label='f3'
    help      in = (SOH 'C')    label='f4'
    undo      in = (SOH 'D')    label='f5'
    stop      in = (SOH 'E')    label='f6'
    bkw_s     in = (SOH '`')    label='  f1'
    fwd_s     in = (SOH 'a')    label='  f2'
    undo_s    in = (SOH 'd')    label='  f5'
    stop_s    in = (SOH 'e')    label='  f6'

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out   = (ESC '$')
    ld_fine_end              out   = (ESC '%')
    ld_fine_horizontal       out   = ('K')
    ld_fine_vertical         out   = ('J')
    ld_fine_upper_left       out   = ('F')
    ld_fine_upper_right      out   = ('G')
    ld_fine_lower_left       out   = ('E')
    ld_fine_lower_right      out   = ('H')
    ld_fine_up_t             out   = ('N')
    ld_fine_down_t           out   = ('O')
    ld_fine_left_t           out   = ('M')
    ld_fine_right_t          out   = ('L')
    ld_fine_cross            out   = ('I')
    ld_medium_begin          out   = (ESC '$')
    ld_medium_end            out   = (ESC '%')
    ld_medium_horizontal     out   = ('K')
    ld_medium_vertical       out   = ('J')
    ld_medium_upper_left     out   = ('F')
    ld_medium_upper_right    out   = ('G')
    ld_medium_lower_left     out   = ('E')
    ld_medium_lower_right    out   = ('H')
    ld_medium_up_t           out   = ('N')
    ld_medium_down_t         out   = ('O')
    ld_medium_left_t         out   = ('M')
    ld_medium_right_t        out   = ('L')
    ld_medium_cross          out   = ('I')
    ld_bold_begin            out   = (ESC '$')
    ld_bold_end              out   = (ESC '%')
    ld_bold_horizontal       out   = ('K')
    ld_bold_vertical         out   = ('J')
    ld_bold_upper_left       out   = ('F')
    ld_bold_upper_right      out   = ('G')
    ld_bold_lower_left       out   = ('E')
    ld_bold_lower_right      out   = ('H')
    ld_bold_up_t             out   = ('N')
    ld_bold_down_t           out   = ('O')
    ld_bold_left_t           out   = ('M')
    ld_bold_right_t          out   = ('L')
    ld_bold_cross            out   = ('I')


"   END OF TERMINAL DEFINITION FILE FOR TELEVIDEO 955 TERMINAL               "
*DECK DECK=CSM$TV_955_PROTECTED EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR TELEVIDEO 955 TERMINAL                       "

"   VARIABLES                                                                 "

    ATTRIBUTES_SPACELESS    = (ESC 'F1')
    ATTRIBUTE_MODE_LINE     = (ESC '[=2l')
    AUTOWRAP_ON             = (ESC '[=7h')
    AUTOWRAP_OFF            = (ESC '[=7l')
    CLEAR_PROTECT           = (ESC '(' ESC '''')
    HOME                    = (RS)
    LARGE_SCREEN            = (ESC '[=3h')
    SMALL_SCREEN            = (ESC '[=3l')
    LOCK_KEYBOARD           = (ESC '#')
    NORMAL                  = (ESC 'G0')
    PROTECT_MODE_OFF        = (ESC '''')
    PROTECT_MODE_ON         = (ESC '&')
    SELECT_FUNCTION_KEY_SET = (ESC '[7;0v')
    SET_DOWN_KEY_CTRL_J     = (ESC '[=9l')
    START_BLINK             = (ESC 'G2')
    START_INVISIBLE         = (ESC 'G1')
    START_PROTECT           = (ESC ')')
    STOP_PROTECT            = (ESC '(')
    START_INVERSE           = (ESC 'G4')
    START_UNDERLINE         = (ESC 'G8')
    TV955_MODE              = (ESC '[10;0v')
    UNLOCK_KEYBOARD         = (ESC '"')
    DEFIN1                  = (ESC '~2' TV955_MODE SELECT_FUNCTION_KEY_SET)
    DEFIN2                  = (ATTRIBUTES_SPACELESS ATTRIBUTE_MODE_LINE)
    DEFIN3                  = (SET_DOWN_KEY_CTRL_J AUTOWRAP_OFF)
    DEFINIT                 = (DEFIN1 DEFIN2 DEFIN3)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name               value = 'TV_955_PROTECTED'
    communications           type  = asynch
    application_string name='driver_procedure' out='tup$bootstrap_tv955_driver'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information       in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (ESC '[')
    cursor_pos_second        out   = (';')
    cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (HOME)          label='home'
    cursor_up                inout = (VT)
    cursor_down              inout = (SYN)
    cursor_left              inout = (BS)
    cursor_right             inout = (FF)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next
    char_past_left           type  = wrap_adjacent_next
    char_past_last_position  type  = wrap_adjacent_next

"   CURSOR BEHAVIOR (for cursor movement in a protected environment)         "

"   CURSOR BEHAVIOR (for character input in a protected environment)         "

"   TERMINAL ATTRIBUTES                                                       "
    automatic_tabbing              value = TRUE
    clears_when_change_size        value = FALSE
    function_key_leaves_mark       value = 1
    has_hidden                     value = TRUE
    has_protect                    value = TRUE
    home_at_top                    value = TRUE
    multiple_sizes                 value = TRUE
    tabs_to_home                   value = FALSE
    tabs_to_tab_stops              value = FALSE
    tabs_to_unprotected            value = TRUE
    type_ahead                     value = TRUE

"   SCREEN SIZE                                                               "
    set_size                 rows  = 24 columns = 80   out = (SMALL_SCREEN)
    set_size                 rows  = 24 columns = 132  out = (LARGE_SCREEN)

"   SCREEN AND LINE MODE TRANSITION                                           "
    screen_init              out   = (DEFINIT)
    set_screen_mode          out   = ()
    set_line_mode            out   = (CLEAR_PROTECT UNLOCK_KEYBOARD AUTOWRAP_ON)

"   TERMINAL CAPABILITIES                                                     "
    delete_char              inout = (ESC 'W')       label='char del'
    delete_line_bol          inout = ()
    erase_end_of_line        inout = (ESC 'T')       label='line erase'
    erase_unprotected        inout = (ESC 'Y')       label='page erase'
    erase_page_home          inout = (SUB)           label='page erase'
    insert_char              inout = (ESC 'Q')       label='char ins'
    insert_line_bol          inout = ()
    insert_mode_begin        inout = (ESC 'q')
    insert_mode_end          inout = (ESC 'r')
    tab_backward             inout = (ESC 'I')
    tab_clear_all            inout = (ESC '3')
    tab_set                  inout = (ESC '1')
    tab_forward              inout = (HT)

"   VIDEO ATTRIBUTES AND SEQUENCES                                            "
    bell_nak                 out   = (BEL)
    output_begin             out   = (PROTECT_MODE_OFF)
    output_end               out   = (PROTECT_MODE_ON)
    output_text_begin        out   = ()
    output_text_end          out   = ()
    display_begin            out   = ()
    display_end              out   = ()
    title_begin              out   = ()
    title_end                out   = ()
    message_begin            out   = ()
    message_end              out   = ()
    italic_begin             out   = (start_inverse)
    italic_end               out   = (normal)
    input_text_begin         out   = (START_UNDERLINE)
    input_text_end           out   = (NORMAL)
    protect_all              out   = ()
    alt_begin                out   = ()
    alt_end                  out   = ()
    blink_begin              out   = (START_BLINK)
    blink_end                out   = (NORMAL)
    hidden_begin             out   = (START_INVISIBLE)
    hidden_end               out   = (NORMAL)
    inverse_begin            out   = (START_INVERSE)
    inverse_end              out   = (NORMAL)
    protect_begin            out   = (START_PROTECT)
    protect_end              out   = (STOP_PROTECT)
    underline_begin          out   = (START_UNDERLINE)
    underline_end            out   = (NORMAL)
    error_begin              out   = (START_INVERSE)
    error_end                out   = (NORMAL)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13           label='return'
    f1        in = (SOH '@')    label='f1'
    f2        in = (SOH 'A')    label='f2'
    f3        in = (SOH 'B')    label='f3'
    f4        in = (SOH 'C')    label='f4'
    f5        in = (SOH 'D')    label='f5'
    f6        in = (SOH 'E')    label='f6'
    f7        in = (SOH 'F')    label='f7'
    f8        in = (SOH 'G')    label='f8'
    f9        in = (SOH 'H')    label='f9'
    f10       in = (SOH 'I')    label='10'
    f11       in = (SOH 'J')    label='11'
    f12       in = (SOH 'K')    label='12'
    f13       in = (SOH 'L')    label='13'
    f14       in = (SOH 'M')    label='14'
    f15       in = (SOH 'N')    label='15'
    f16       in = (SOH 'O')    label='16'
    f1_s      in = (SOH '`')    label='  x'
    f2_s      in = (SOH 'a')    label='  x'
    f3_s      in = (SOH 'b')    label='  x'
    f4_s      in = (SOH 'c')    label='  x'
    f5_s      in = (SOH 'd')    label='  x'
    f6_s      in = (SOH 'e')    label='  x'
    f7_s      in = (SOH 'f')    label='  x'
    f8_s      in = (SOH 'g')    label='  x'
    f9_s      in = (SOH 'h')    label='  x'
    f10_s     in = (SOH 'i')    label='  x'
    f11_s     in = (SOH 'j')    label='  x'
    f12_s     in = (SOH 'k')    label='  x'
    f13_s     in = (SOH 'l')    label='  x'
    f14_s     in = (SOH 'm')    label='  x'
    f15_s     in = (SOH 'n')    label='  x'
    f16_s     in = (SOH 'o')    label='  x'

    bkw       in = (SOH '@')    label='f1'
    fwd       in = (SOH 'A')    label='f2'
    back      in = (SOH 'B')    label='f3'
    help      in = (SOH 'C')    label='f4'
    undo      in = (SOH 'D')    label='f5'
    stop      in = (SOH 'E')    label='f6'
    bkw_s     in = (SOH '`')    label='  f1'
    fwd_s     in = (SOH 'a')    label='  f2'
    undo_s    in = (SOH 'd')    label='  f5'
    stop_s    in = (SOH 'e')    label='  f6'

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out   = (ESC '$')
    ld_fine_end              out   = (ESC '%')
    ld_fine_horizontal       out   = ('K')
    ld_fine_vertical         out   = ('J')
    ld_fine_upper_left       out   = ('F')
    ld_fine_upper_right      out   = ('G')
    ld_fine_lower_left       out   = ('E')
    ld_fine_lower_right      out   = ('H')
    ld_fine_up_t             out   = ('N')
    ld_fine_down_t           out   = ('O')
    ld_fine_left_t           out   = ('M')
    ld_fine_right_t          out   = ('L')
    ld_fine_cross            out   = ('I')
    ld_medium_begin          out   = (ESC '$')
    ld_medium_end            out   = (ESC '%')
    ld_medium_horizontal     out   = ('K')
    ld_medium_vertical       out   = ('J')
    ld_medium_upper_left     out   = ('F')
    ld_medium_upper_right    out   = ('G')
    ld_medium_lower_left     out   = ('E')
    ld_medium_lower_right    out   = ('H')
    ld_medium_up_t           out   = ('N')
    ld_medium_down_t         out   = ('O')
    ld_medium_left_t         out   = ('M')
    ld_medium_right_t        out   = ('L')
    ld_medium_cross          out   = ('I')
    ld_bold_begin            out   = (ESC '$')
    ld_bold_end              out   = (ESC '%')
    ld_bold_horizontal       out   = ('K')
    ld_bold_vertical         out   = ('J')
    ld_bold_upper_left       out   = ('F')
    ld_bold_upper_right      out   = ('G')
    ld_bold_lower_left       out   = ('E')
    ld_bold_lower_right      out   = ('H')
    ld_bold_up_t             out   = ('N')
    ld_bold_down_t           out   = ('O')
    ld_bold_left_t           out   = ('M')
    ld_bold_right_t          out   = ('L')
    ld_bold_cross            out   = ('I')


"   END OF TERMINAL DEFINITION FILE FOR TELEVIDEO 955 TERMINAL               "
*DECK DECK=CSM$TV_970 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR TeleVideo970 TERMINAL                       "

"   VARIABLES                                                                "
    prefix              = (esc '[')
    native_mode         = (prefix '?21h')
    page_attr           = (prefix '5;0z')       "single-height/single-width"
    set_to_24x80        = (prefix '1;0z' prefix '?3l')
    set_to_72x80        = (prefix '1;2z' prefix '?3l')
    set_to_24x132       = (prefix '1;0z' prefix '?3h')
    contrast_low        = (prefix '7;0z')       "low intensity"
    start_alternate     = (prefix '1m')         "bright"
    stop_alternate      = (prefix '0m')
    start_blank         = (prefix '3m')
    stop_blank          = (prefix '0m')
    start_underline     = (prefix '4m')
    stop_underline      = (prefix '0m')
    start_blink         = (prefix '5m')
    stop_blink          = (prefix '0m')
    start_inverse       = (prefix '7m')
    stop_inverse        = (prefix '0m')
    disable_protect     = (prefix '?0l')
    ignore_break        = (prefix '?16l')
    recognize_break     = (prefix '?16h')
    enable_attr_action  = (prefix '?18l')
    disable_attr_action = (prefix '?18h')
    char_prim_usa       = (esc '(B')            "US primary character set"
    char_sec_graphic    = (esc ')0')            "graphics secondary set"
    select_char_prim    = (si)
    select_char_sec     = (so)
    autopage_single     = (prefix '?20l')
    autowrap_enable     = (prefix '?7h')
    autowrap_disable    = (prefix '?7l')
    lf_enable           = (prefix '20l')
    tab_forwards        = (prefix '1I')
    control_rep_process = (prefix '3l')
"   cr_turnaround       = (esc '\5;13' cr) "
    ansi_arrows         = (prefix '?1l')
    pad_numeric         = (esc '>')
    ctl_disabl          = (prefix '?9l')
    edit_extent_line    = (prefix '1Q')
    edit_boundary_display  = (prefix '19l')
    edit_vertical_below = (prefix '7l')
    edit_horizontal_right = (prefix '10l')
    replace_mode        = (prefix '4l')
    edit_modes          = (replace_mode autopage_single autowrap_enable ..
                           edit_boundary_display edit_extent_line ..
                           edit_horizontal_right edit_vertical_below)
    clear_home          = (prefix '2J')
    convers_mode        = (prefix '?10l')
    select_block        = (prefix '?10h')
    normal_part_1       = (native_mode page_attr contrast_low char_prim_usa ..
 char_sec_graphic select_char_prim enable_attr_action)
    normal_part_2       = (lf_enable ansi_arrows pad_numeric ctl_disabl ..
 edit_modes convers_mode disable_protect)
"edit_modes convers_mode disable_protect control_rep_process)"
    f1f4_std            = (esc '|1;3;27;63;97;13'   cr ..                "f1  "
                           esc '|2;3;27;63;98;13'   cr ..                "f2  "
                           esc '|3;3;27;63;99;13'   cr ..                "f3  "
                           esc '|4;3;27;63;100;13'  cr)                  "f4  "
    f5f8_std            = (esc '|5;3;27;63;101;13'  cr ..                "f5  "
                           esc '|6;3;27;63;102;13'  cr ..                "f6  "
                           esc '|7;3;27;63;103;13'  cr ..                "f7  "
                           esc '|8;3;27;63;104;13'  cr)                  "f8  "
    f9f12_std           = (esc '|9;3;27;63;105;13'  cr ..                "f9  "
                           esc '|10;3;27;63;106;13' cr ..                "f10 "
                           esc '|11;3;27;63;107;13' cr ..                "f11 "
                           esc '|12;3;27;63;108;13' cr)                  "f12 "
    f13f16_std          = (esc '|13;3;27;63;109;13' cr ..                "f13 "
                           esc '|14;3;27;63;110;13' cr ..                "f14 "
                           esc '|15;3;27;63;111;13' cr ..                "f15 "
                           esc '|16;3;27;63;112;13' cr)                  "f16 "
    f1f4s_std           = (esc '|17;3;27;63;65;13'  cr ..                "f1 s"
                           esc '|18;3;27;63;66;13'  cr ..                "f2 s"
                           esc '|19;3;27;63;67;13'  cr ..                "f3 s"
                           esc '|20;3;27;63;68;13'  cr)                  "f4 s"
    f5f8s_std           = (esc '|21;3;27;63;69;13'  cr ..                "f5 s"
                           esc '|22;3;27;63;70;13'  cr ..                "f6 s"
                           esc '|23;3;27;63;71;13'  cr ..                "f7 s"
                           esc '|24;3;27;63;72;13'  cr)                  "f8 s"
    f9f12s_std          = (esc '|25;3;27;63;73;13'  cr ..                "f9 s"
                           esc '|26;3;27;63;74;13'  cr ..                "f10s"
                           esc '|27;3;27;63;75;13'  cr ..                "f11s"
                           esc '|28;3;27;63;76;13'  cr)                  "f12s"
    f13f16s_std         = (esc '|29;3;27;63;77;13'  cr ..                "f13s"
                           esc '|30;3;27;63;78;13'  cr ..                "f14s"
                           esc '|31;3;27;63;79;13'  cr ..                "f15s"
                           esc '|32;3;27;63;80;13'  cr)                  "f16s"
    cdc_keys           = (esc '\18;27;63;114;13' cr esc '\19;27;63;82;13' cr ..
       esc '\42;27;63;113;13' cr esc '\41;27;91;50;74;13' cr ..
       esc '\58;27;63;81;13' cr)
    back_space_std      = (esc '\31;8' cr)                          "bs"
" change BACK SPACE key to send bs,space,bs"
    back_space_x        = (esc '\31;8;32;8' cr)                     "bs ' ' bs"
    clear_space_std     = (esc '\35;27;91;50;74' cr)                "esc '[2J'"
" change CLEAR SPACE key to send bs,then same as CHAR DELETE"
    clear_space_x       = (esc '\35;8;27;91;80' cr)               "bs esc '[P'"
    tab_mains_std       = (esc '\17;27;91;51;103' cr)               "esc '[3g'"
"                             bytes:  1   2   3   4   5   6   7   8"
    repeat_action_std   = (esc '\73;255;255;255;255;255;255;255;255;' ..
.. "  9  10  11  12  13  14  15  16  17  18  19  20  21  22  23  24"
   '255;255;255;255;255;255;255;255;249;249;207;031;207;014;255;192;' ..
.. " 25  26  27  28  29  30  31  32"
   '000;000;000;000;000;000;003;032' cr)
"                             bytes:  1   2   3   4   5   6   7   8"
    repeat_action_edit  = (esc '\73;255;255;255;255;255;255;255;255;' ..
.. "  9  10  11  12  13  14  15  16  17  18  19 20  21 22  23  24"
   '255;255;255;255;255;255;255;255;249;249;223;31;207;14;255;192;' ..
.. " 25 6 7"
     '0;0;0' cr)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'TV_970'
    communications      type  = asynch
    application_string name='driver_procedure' out='tup$bootstrap_tv955_driver'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (prefix)
    cursor_pos_second        out   = (';')
    cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                              "
    cursor_home              inout = (prefix 'H')    label='HOME'
    cursor_up                inout = (prefix 'A')
    cursor_down              inout = (prefix 'B')
    cursor_left              inout = (prefix 'D')
    cursor_right             inout = (prefix 'C')

"   CURSOR BEHAVIOR (for cursor movement keys)                               "
    move_past_right          type  = stop_next
    move_past_left           type  = stop_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                     "
    char_past_right          type  = stop_next
    char_past_left           type  = stop_next
    char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
    automatic_tabbing        value = TRUE
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 1
    has_hidden               value = FALSE
    has_protect              value = FALSE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = TRUE

"   SCREEN SIZES                                                             "
    set_size       rows = 24 columns = 80   out = (set_to_24x80)
    set_size       rows = 24 columns = 132  out = (set_to_24x132)

"   SCREEN AND LINE MODE TRANSITION                                           "
    screen_init         out = (normal_part_1 normal_part_2)
    screen_init         out = (f1f4_std   f5f8_std)
    screen_init         out = (f9f12_std  f13f16_std)
    screen_init         out = (f1f4s_std  f5f8s_std)
    screen_init         out = (f9f12s_std f13f16s_std)
    screen_init         out = (back_space_x clear_space_x)
    screen_init         out = (cdc_keys)
    screen_init         out = (set_to_24x80)
"   screen_init         out = (set_to_24x80 cr_turnaround) "
    line_init           out = (normal_part_1 normal_part_2)
    line_init           out = (back_space_std clear_space_std)
    line_init           out = (set_to_72x80)
    set_screen_mode     out = (autowrap_disable ignore_break ..
                               repeat_action_edit)
    set_line_mode       out = (autowrap_enable recognize_break ..
                               repeat_action_std set_to_24x80)

"   TERMINAL CAPABILITIES                                                   "
    backspace           in    = (bs)
    delete_char         inout = (prefix 'P')    label='DelC'     "CHAR DELETE"
    delete_line_bol     inout = (prefix 'M')    label='DelL'     "LINE DELETE"
    erase_end_of_line   inout = (prefix 'K')    label='EraEOL'   "LINE ERASE"
    erase_line_stay     inout = (prefix '2K')            "shifted CE"
    erase_page_home       out = (clear_home)
    insert_char         inout = (prefix '@')    label='InsC'     "CHAR INSERT"
    insert_line_bol     inout = (prefix 'L')    label='InsL'     "LINE INSERT"
    insert_mode_begin   inout = (prefix '4h')            "shifted CHAR INSERT"
    insert_mode_end     inout = (replace_mode)           "shifted CHAR DELETE"
    tab_backward        inout = (prefix 'Z')                     "BACK TAB"
    tab_clear           inout = (prefix 'g')             "shifted TAB, keypad"
    tab_clear_all         out = (prefix '3g')
    tab_forward         inout = (ht)                             "TAB"
    tab_set             inout = (esc 'H')                "shifted TAB, main"

"   MISCELLANEOUS TERMINAL SEQUENCES                                         "
    bell_nak            out = (bel)
    output_begin        out = (replace_mode)
    output_end          out = ()

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                              "
    f1        in = (esc '?a')     label = 'F1'
    f2        in = (esc '?b')     label = 'F2'
    f3        in = (esc '?c')     label = 'F3'
    f4        in = (esc '?d')     label = 'F4'
    f5        in = (esc '?e')     label = 'F5'
    f6        in = (esc '?f')     label = 'F6'
    f7        in = (esc '?g')     label = 'F7'
    f8        in = (esc '?h')     label = 'F8'
    f9        in = (esc '?i')     label = 'F9'
    f10       in = (esc '?j')     label = '10'
    f11       in = (esc '?k')     label = '11'
    f12       in = (esc '?l')     label = '12'
    f13       in = (esc '?m')     label = '13'
    f14       in = (esc '?n')     label = '14'
    f15       in = (esc '?o')     label = '15'
    f16       in = (esc '?p')     label = '16'
    f1_s      in = (esc '?A')     label = '  SF1'
    f2_s      in = (esc '?B')     label = '  SF2'
    f3_s      in = (esc '?C')     label = '  SF3'
    f4_s      in = (esc '?D')     label = '  SF4'
    f5_s      in = (esc '?E')     label = '  SF5'
    f6_s      in = (esc '?F')     label = '  SF6'
    f7_s      in = (esc '?G')     label = '  SF7'
    f8_s      in = (esc '?H')     label = '  SF8'
    f9_s      in = (esc '?I')     label = '  SF9'
    f10_s     in = (esc '?J')     label = '  SF10'
    f11_s     in = (esc '?K')     label = '  SF11'
    f12_s     in = (esc '?L')     label = '  SF12'
    f13_s     in = (esc '?M')     label = '  SF13'
    f14_s     in = (esc '?N')     label = '  SF14'
    f15_s     in = (esc '?O')     label = '  SF15'
    f16_s     in = (esc '?P')     label = '  SF16'

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13                    label='RETURN'
    next_s    in = ()
    back      in = ()
    back_s    in = ()
    help      in = ()
    help_s    in = ()
    stop      in = ()
    stop_s    in = ()
    down      in = (esc '?r')    label = 'DOWN'     "shift-down-arrow"
    up        in = (esc '?R')    label = 'UP'       "shift-up-arrow"
    fwd       in = (esc '?q')    label = 'FWD'      "PAGE"
    bkw       in = (esc '?Q')    label = 'BKW'      "shift-PAGE"

"   TERMINAL VIDEO ATTRIBUTES                                                "
    alt_begin           out = (start_alternate)
    alt_end             out = (stop_alternate)
    blink_begin         out = (start_blink)
    blink_end           out = (stop_blink)
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_inverse start_alternate)
    error_end           out = (stop_inverse stop_alternate)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)
    message_begin       out = (start_alternate)
    message_end         out = (stop_alternate)
    output_text_begin   out = ()
    output_text_end     out = ()

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = select_char_sec
    ld_fine_end              out = select_char_prim
    ld_fine_horizontal       out = 'q'
    ld_fine_vertical         out = 'x'
    ld_fine_upper_left       out = 'l'
    ld_fine_upper_right      out = 'k'
    ld_fine_lower_left       out = 'm'
    ld_fine_lower_right      out = 'j'
    ld_fine_up_t             out = 'w'
    ld_fine_down_t           out = 'v'
    ld_fine_left_t           out = 't'
    ld_fine_right_t          out = 'u'
    ld_fine_cross            out = 'n'
    ld_medium_begin          out = (select_char_sec start_alternate)
    ld_medium_end            out = (select_char_prim stop_alternate)
    ld_medium_horizontal     out = 'q'
    ld_medium_vertical       out = 'x'
    ld_medium_upper_left     out = 'l'
    ld_medium_upper_right    out = 'k'
    ld_medium_lower_left     out = 'm'
    ld_medium_lower_right    out = 'j'
    ld_medium_up_t           out = 'w'
    ld_medium_down_t         out = 'v'
    ld_medium_left_t         out = 't'
    ld_medium_right_t        out = 'u'
    ld_medium_cross          out = 'n'
    ld_bold_begin            out = (select_char_prim start_inverse)
    ld_bold_end              out = (select_char_prim stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')

"   END OF TERMINAL DEFINITION FILE FOR TeleVideo970 TERMINAL                "
*DECK DECK=CSM$TV_HALF_FULL_DUPLEX EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR TELEVIDEO 955 TERMINAL                       "
"   USING HOST ECHOING                                                        "

"   VARIABLES                                                                 "

    ATTRIBUTES_SPACELESS    = (ESC 'F1')
    ATTRIBUTE_MODE_LINE     = (ESC '[=2l')
    AUTOWRAP_ON             = (ESC '[=7h')
    AUTOWRAP_OFF            = (ESC '[=7l')
    CLEAR_PROTECT           = (ESC '(' ESC '''')
    HOME                    = (RS)
    LARGE_SCREEN            = (ESC '[=3h')
    SMALL_SCREEN            = (ESC '[=3l')
    LOCK_KEYBOARD           = (ESC '#')
    NORMAL                  = (ESC 'G0')
    PROTECT_MODE_OFF        = (ESC '''')
    PROTECT_MODE_ON         = (ESC '&')
    SELECT_FUNCTION_KEY_SET = (ESC '[7;0v')
    SET_DOWN_KEY_CTRL_J     = (ESC '[=9l')
    START_BLINK             = (ESC 'G2')
    START_INVISIBLE         = (ESC 'G1')
    START_PROTECT           = (ESC ')')
    STOP_PROTECT            = (ESC '(')
    START_INVERSE           = (ESC 'G4')
    START_UNDERLINE         = (ESC 'G8')
    HALF_DUPLEX             = (ESC 'DH')
    FULL_DUPLEX             = (ESC 'DF')
    TV955_MODE              = (ESC '[10;0v')
    UNLOCK_KEYBOARD         = (ESC '"')
    DEFIN1                  = (ESC '~2' TV955_MODE HALF_DUPLEX SELECT_FUNCTION_KEY_SET)
    DEFIN2                  = (ATTRIBUTES_SPACELESS ATTRIBUTE_MODE_LINE)
    DEFIN3                  = (SET_DOWN_KEY_CTRL_J AUTOWRAP_OFF)
    DEFINIT                 = (DEFIN1 DEFIN2 DEFIN3)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name               value = 'TV_HALF_FULL_DUPLEX'
    communications           type  = asynch
    application_string name='driver_procedure' out='tup$bootstrap_tv955_driver'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information       in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (ESC '[')
    cursor_pos_second        out   = (';')
    cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (HOME)          label='home'
    cursor_up                inout = (VT)
    cursor_down              inout = (SYN)
    cursor_left              inout = (BS)
    cursor_right             inout = (FF)

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_right          type  = wrap_adjacent_next
    char_past_left           type  = wrap_adjacent_next
    char_past_last_position  type  = wrap_adjacent_next

"   CURSOR BEHAVIOR (for cursor movement in a protected environment)         "

"   CURSOR BEHAVIOR (for character input in a protected environment)         "

"   TERMINAL ATTRIBUTES                                                       "
    automatic_tabbing              value = TRUE
    clears_when_change_size        value = FALSE
    function_key_leaves_mark       value = 1
    has_hidden                     value = TRUE
    has_protect                    value = TRUE
    home_at_top                    value = TRUE
    multiple_sizes                 value = TRUE
    tabs_to_home                   value = FALSE
    tabs_to_tab_stops              value = FALSE
    tabs_to_unprotected            value = TRUE
    type_ahead                     value = TRUE

"   SCREEN SIZE                                                               "
    set_size                 rows  = 24 columns = 80   out = (SMALL_SCREEN)
    set_size                 rows  = 24 columns = 132  out = (LARGE_SCREEN)

"   SCREEN AND LINE MODE TRANSITION                                           "
    screen_init              out   = (DEFINIT)
    set_screen_mode          out   = ()
    set_line_mode            out   = (CLEAR_PROTECT UNLOCK_KEYBOARD AUTOWRAP_ON FULL_DUPLEX)

"   TERMINAL CAPABILITIES                                                     "
    delete_char              inout = (ESC 'W')       label='char del'
    delete_line_bol          inout = ()
    erase_end_of_line        inout = (ESC 'T')       label='line erase'
    erase_unprotected        inout = (ESC 'Y')       label='page erase'
    erase_page_home          inout = (SUB)           label='page erase'
    insert_char              inout = (ESC 'Q')       label='char ins'
    insert_line_bol          inout = ()
    insert_mode_begin        inout = (ESC 'q')
    insert_mode_end          inout = (ESC 'r')
    tab_backward             inout = (ESC 'I')
    tab_clear_all            inout = (ESC '3')
    tab_set                  inout = (ESC '1')
    tab_forward              inout = (HT)

"   VIDEO ATTRIBUTES AND SEQUENCES                                            "
    bell_nak                 out   = (BEL)
    output_begin             out   = (PROTECT_MODE_OFF)
    output_end               out   = (PROTECT_MODE_ON)
    output_text_begin        out   = ()
    output_text_end          out   = ()
    display_begin            out   = ()
    display_end              out   = ()
    title_begin              out   = ()
    title_end                out   = ()
    message_begin            out   = ()
    message_end              out   = ()
    italic_begin             out   = (start_inverse)
    italic_end               out   = (normal)
    input_text_begin         out   = (START_UNDERLINE)
    input_text_end           out   = (NORMAL)
    protect_all              out   = ()
    alt_begin                out   = ()
    alt_end                  out   = ()
    blink_begin              out   = (START_BLINK)
    blink_end                out   = (NORMAL)
    hidden_begin             out   = (START_INVISIBLE)
    hidden_end               out   = (NORMAL)
    inverse_begin            out   = (START_INVERSE)
    inverse_end              out   = (NORMAL)
    protect_begin            out   = (START_PROTECT)
    protect_end              out   = (STOP_PROTECT)
    underline_begin          out   = (START_UNDERLINE)
    underline_end            out   = (NORMAL)
    error_begin              out   = (START_INVERSE)
    error_end                out   = (NORMAL)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    next      in = 13           label='return'
    f1        in = (SOH '@')    label='f1'
    f2        in = (SOH 'A')    label='f2'
    f3        in = (SOH 'B')    label='f3'
    f4        in = (SOH 'C')    label='f4'
    f5        in = (SOH 'D')    label='f5'
    f6        in = (SOH 'E')    label='f6'
    f7        in = (SOH 'F')    label='f7'
    f8        in = (SOH 'G')    label='f8'
    f9        in = (SOH 'H')    label='f9'
    f10       in = (SOH 'I')    label='10'
    f11       in = (SOH 'J')    label='11'
    f12       in = (SOH 'K')    label='12'
    f13       in = (SOH 'L')    label='13'
    f14       in = (SOH 'M')    label='14'
    f15       in = (SOH 'N')    label='15'
    f16       in = (SOH 'O')    label='16'
    f1_s      in = (SOH '`')    label='  x'
    f2_s      in = (SOH 'a')    label='  x'
    f3_s      in = (SOH 'b')    label='  x'
    f4_s      in = (SOH 'c')    label='  x'
    f5_s      in = (SOH 'd')    label='  x'
    f6_s      in = (SOH 'e')    label='  x'
    f7_s      in = (SOH 'f')    label='  x'
    f8_s      in = (SOH 'g')    label='  x'
    f9_s      in = (SOH 'h')    label='  x'
    f10_s     in = (SOH 'i')    label='  x'
    f11_s     in = (SOH 'j')    label='  x'
    f12_s     in = (SOH 'k')    label='  x'
    f13_s     in = (SOH 'l')    label='  x'
    f14_s     in = (SOH 'm')    label='  x'
    f15_s     in = (SOH 'n')    label='  x'
    f16_s     in = (SOH 'o')    label='  x'

    bkw       in = (SOH '@')    label='f1'
    fwd       in = (SOH 'A')    label='f2'
    back      in = (SOH 'B')    label='f3'
    help      in = (SOH 'C')    label='f4'
    undo      in = (SOH 'D')    label='f5'
    stop      in = (SOH 'E')    label='f6'
    bkw_s     in = (SOH '`')    label='  f1'
    fwd_s     in = (SOH 'a')    label='  f2'
    undo_s    in = (SOH 'd')    label='  f5'
    stop_s    in = (SOH 'e')    label='  f6'

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out   = (ESC '$')
    ld_fine_end              out   = (ESC '%')
    ld_fine_horizontal       out   = ('K')
    ld_fine_vertical         out   = ('J')
    ld_fine_upper_left       out   = ('F')
    ld_fine_upper_right      out   = ('G')
    ld_fine_lower_left       out   = ('E')
    ld_fine_lower_right      out   = ('H')
    ld_fine_up_t             out   = ('N')
    ld_fine_down_t           out   = ('O')
    ld_fine_left_t           out   = ('M')
    ld_fine_right_t          out   = ('L')
    ld_fine_cross            out   = ('I')
    ld_medium_begin          out   = (ESC '$')
    ld_medium_end            out   = (ESC '%')
    ld_medium_horizontal     out   = ('K')
    ld_medium_vertical       out   = ('J')
    ld_medium_upper_left     out   = ('F')
    ld_medium_upper_right    out   = ('G')
    ld_medium_lower_left     out   = ('E')
    ld_medium_lower_right    out   = ('H')
    ld_medium_up_t           out   = ('N')
    ld_medium_down_t         out   = ('O')
    ld_medium_left_t         out   = ('M')
    ld_medium_right_t        out   = ('L')
    ld_medium_cross          out   = ('I')
    ld_bold_begin            out   = (ESC '$')
    ld_bold_end              out   = (ESC '%')
    ld_bold_horizontal       out   = ('K')
    ld_bold_vertical         out   = ('J')
    ld_bold_upper_left       out   = ('F')
    ld_bold_upper_right      out   = ('G')
    ld_bold_lower_left       out   = ('E')
    ld_bold_lower_right      out   = ('H')
    ld_bold_up_t             out   = ('N')
    ld_bold_down_t           out   = ('O')
    ld_bold_left_t           out   = ('M')
    ld_bold_right_t          out   = ('L')
    ld_bold_cross            out   = ('I')


"   END OF TERMINAL DEFINITION FILE FOR TELEVIDEO 955 TERMINAL               "
*DECK DECK=CSM$VISTACOM_MAC_30 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR MACINTOSH                                    "
"   running Control Data VistaCOM MAC V3.0                                    "

"       VISTACOM_MAC_30                                       DECEMBER, 1990  "

"   To change the full screen line count for larger screens, make following   "
"   modifications to this Terminal Definition source before recompiling:      "
"     Replace Full_Screen_Line_Count variable value 24 with full screen line  "
"       count (24 to 100) defined in VistaCOM MAC Terminal Settings.          "
"     Replace rows = 24 in set_size definitions with full screen line count.  "
"     Replace model_name value with unique terminal name such as              "
"       VISTACOM_MAC_30_XX where XX is the full screen line count (24 to 100)."


"   VARIABLES                                                                 "
    Full_Screen_Line_Count    = ('24')        "sets Mac Full_Screen_Line_Count"
    clear_all_tabs            = (ESC '[3g')
    set_80_cols               = (ESC '[?3l')
    set_132_cols              = (ESC '[?3h')
    start_bold                = (ESC '[1m')
    start_inverse             = (ESC '[7m')
    start_underline           = (ESC '[4m')
    stop_bold                 = (ESC '[21m')
    stop_inverse              = (ESC '[27m')
    stop_underline            = (ESC '[24m')
    set_graphics              = (ESC '(B' ESC ')0' SI)
    enable_auto_tab           = (ESC '[=3h')
    enable_auto_wrap          = (ESC '[?7h')
    enable_insertion          = (ESC '[4h')
    disable_insertion         = (ESC '[4l')
    global_protect_on         = (ESC '[=1h')
    global_protect_off        = (ESC '[=1l')
    cursor_pos_normal         = (ESC '[=6l')
    reset_terminal            = (ESC 'c')
    enter_screen_mode         = (ESC '[=5h')
    enter_line_mode           = (ESC '[=5l')
    enter_term_mode           = (ESC '%!2')
    NOSVE_host                = (ESC '[1t')
    set_screen_size           = (ESC '[' Full_Screen_Line_Count ';80z')
    redo_set_screen_mode      = (NOSVE_host global_protect_on ..
                                clear_all_tabs set_graphics enable_auto_wrap ..
                                enable_auto_tab cursor_pos_normal ..
                                enter_screen_mode)
    redo_set_line_mode        = (global_protect_off set_graphics enter_line_mode)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'VISTACOM_MAC_30'
    communications      type  = asynch
    application_string  name  = 'vt100_scrolling'  out = 'true'
    application_string  name='DRIVER_PROCEDURE' out='TUP$BOOT_CONNECT_CURSOR'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (ESC '[')
    cursor_pos_second        out   = (';')
    cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (ESC '[H')  label='Option H'
    cursor_up                inout = (ESC '[A')  label='up arrow'
    cursor_down              inout = (ESC '[B')  label='down arrow'
    cursor_right             inout = (ESC '[C')  label='right arrow'
    cursor_left              inout = (ESC '[D')  label='left arrow'

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_left           type = wrap_adjacent_next
    char_past_right          type = wrap_adjacent_next
    char_past_last_position  type = wrap_adjacent_next

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE            "for 80/132 column change"
    function_key_leaves_mark value = 0
    has_hidden               value = FALSE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
    automatic_tabbing        value = TRUE

"   SCREEN SIZES                                                              "
    set_size  rows = 24  columns = 80   out = (set_80_cols)
    set_size  rows = 24  columns = 132  out = (set_132_cols)

"   TERMINAL CAPABILITIES                                                     "
    insert_char         inout = (ESC '[@')   label='Option Space'
    insert_line_bol     inout = (ESC '[L')   label='Option Shift Space'
    delete_char         inout = (ESC '[P')   label='Option Delete'
    delete_line_bol     inout = (ESC '[M')   label='Option Shift Delete'
    erase_end_of_line   inout = (ESC '[K')   label='Option Clear'
    erase_line_stay     inout = (ESC '[2K')
    erase_end_of_field  inout = (ESC '[N')
    erase_field_stay    inout = (ESC '[2N')
    erase_page_stay     inout = (ESC '[2J')  label='Clear'
    backspace           in = (BS)            label='Delete'
    tab_forward         inout = (HT)         label='Tab'
    tab_backward        inout = (ESC '[Z')   label='Option Tab'
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (ESC 'H')
    tab_clear           inout = (ESC '[g')
    insert_mode_begin   inout = (enable_insertion)
    insert_mode_end     inout = (disable_insertion)

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode out = (NOSVE_host  enter_term_mode enter_screen_mode  ..
                           clear_all_tabs  set_graphics  enable_auto_wrap  ..
                           enable_auto_tab  cursor_pos_normal  set_screen_size)

    set_line_mode   out = (enter_line_mode  set_graphics  reset_terminal)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (ESC 'V')
    protect_end         out = (ESC 'W')
    protect_all         out = (ESC '[1p')
    output_begin        out = (global_protect_off disable_insertion)
    output_end          out = (global_protect_on)
    bell_nak            out = (BEL)

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = (CR)              label='Return'
    data      in = (ESC 'O' 27(16))  label='Option "'
    data_s    in = (ESC 'O' 22(16))  label='Option Shift "'
    back      in = (ESC 'O;')        label='Option ;'
    back_s    in = (ESC 'O:')        label='Option Shift ;'
    help      in = (ESC 'O/')        label='Option ?'
    help_s    in = (ESC 'O?')        label='Option Shift ?'
    edit      in = (ESC 'O.')        label='Option .'
    edit_s    in = (ESC 'O>')        label='Option Shift .'
    down      in = (ESC 'O+')        label='Option D'
    down_s    in = (ESC 'O-')        label='Option Shift D'
    up        in = (ESC 'O(')        label='Option U'
    up_s      in = (ESC 'O)')        label='Option Shift U'
    fwd       in = (ESC 'OX')        label='Option F'
    fwd_s     in = (ESC 'Oo')        label='Option Shift F'
    bkw       in = (ESC 'OW')        label='Option B'
    bkw_s     in = (ESC 'Of')        label='Option Shift B'
    undo      in = (ESC 'Ou')        label='F5  Option 5'
    undo_s    in = (ESC 'Om')        label='    Option Shift 5'
    stop      in = (ESC 'Ov')        label='F6  Option 6'
    stop_s    in = (ESC 'Ol')        label='    Option Shift 6'

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (ESC 'Oq')        label='F1  Option 1'
    f2        in = (ESC 'Or')        label='F2  Option 2'
    f3        in = (ESC 'Os')        label='F3  Option 3'
    f4        in = (ESC 'Ot')        label='F4  Option 4'
    f5        in = (ESC 'Ou')        label='F5  Option 5'
    f6        in = (ESC 'Ov')        label='F6  Option 6'
    f7        in = (ESC 'Ow')        label='F7  Option 7'
    f8        in = (ESC 'Ox')        label='F8  Option 8'
    f9        in = (ESC 'Oy')        label='F9  Option 9'
    f10       in = (ESC 'Oz')        label='10  Option 0'
    f11       in = (ESC 'O{')        label='11  Option Q'
    f12       in = (ESC 'O|')        label='12  Option W'
    f13       in = (ESC 'O}')        label='13  Option E'
    f14       in = (ESC 'O~')        label='14  Option R'
    f15       in = (ESC 'O_')        label='15  Option T'
    f16       in = (ESC 'OU')        label='16  Option Y'
    f1_s      in = (ESC 'Og')        label='    Option Shift 1'
    f2_s      in = (ESC 'Oh')        label='    Option Shift 2'
    f3_s      in = (ESC 'Oi')        label='    Option Shift 3'
    f4_s      in = (ESC 'Oj')        label='    Option Shift 4'
    f5_s      in = (ESC 'Om')        label='    Option Shift 5'
    f6_s      in = (ESC 'Ol')        label='    Option Shift 6'
    f7_s      in = (ESC 'OM')        label='    Option Shift 7'
    f8_s      in = (ESC 'On')        label='    Option Shift 8'
    f9_s      in = (ESC 'Op')        label='    Option Shift 9'
    f10_s     in = (ESC 'OO')        label='    Option Shift 0'
    f11_s     in = (ESC 'Oa')        label='    Option Shift Q'
    f12_s     in = (ESC 'Ob')        label='    Option Shift W'
    f13_s     in = (ESC 'Oc')        label='    Option Shift E'
    f14_s     in = (ESC 'Od')        label='    Option Shift R'
    f15_s     in = (ESC 'Oe')        label='    Option Shift T'
    f16_s     in = (ESC 'OV')        label='    Option Shift Y'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_bold)
    alt_end             out = (stop_bold)
    blink_begin         out = ()                   "not supported"
    blink_end           out = ()                   "not supported"
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_bold)
    error_end           out = (stop_bold)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = (SO)
    ld_fine_end              out = (SI)
    ld_fine_horizontal       out = (71(16))
    ld_fine_vertical         out = (78(16))
    ld_fine_upper_left       out = (6C(16))
    ld_fine_upper_right      out = (6B(16))
    ld_fine_lower_left       out = (6D(16))
    ld_fine_lower_right      out = (6A(16))
    ld_fine_up_t             out = (77(16))
    ld_fine_down_t           out = (76(16))
    ld_fine_left_t           out = (74(16))
    ld_fine_right_t          out = (75(16))
    ld_fine_cross            out = (6E(16))

    ld_medium_begin          out = (SO start_bold)
    ld_medium_end            out = (SI stop_bold)
    ld_medium_horizontal     out = (71(16))
    ld_medium_vertical       out = (78(16))
    ld_medium_upper_left     out = (6C(16))
    ld_medium_upper_right    out = (6B(16))
    ld_medium_lower_left     out = (6D(16))
    ld_medium_lower_right    out = (6A(16))
    ld_medium_up_t           out = (77(16))
    ld_medium_down_t         out = (76(16))
    ld_medium_left_t         out = (74(16))
    ld_medium_right_t        out = (75(16))
    ld_medium_cross          out = (6E(16))

    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')

    application_string name='REDO_SET_SCREEN_MODE' out=(redo_set_screen_mode)
    application_string name='REDO_SET_LINE_MODE' out=(redo_set_line_mode)

"   END OF TERMINAL DEFINITION FILE FOR Macintosh                             "
"   running Control Data VistaCOM MAC V3.0                                    "
*DECK DECK=CSM$VISTA_MAC_HOST_ECHO_30 EXPAND=TRUE
"   TERMINAL DEFINITION FILE FOR MACINTOSH                                    "
"   running Control Data VistaCOM MAC V3.0                                    "

"       VISTA_MAC_HOST_ECHO_MAC_30                           MARCH, 1994      "

"   To change the full screen line count for larger screens, make following   "
"   modifications to this Terminal Definition source before recompiling:      "
"     Replace Full_Screen_Line_Count variable value 24 with full screen line  "
"       count (24 to 100) defined in VistaCOM MAC Terminal Settings.          "
"     Replace rows = 24 in set_size definitions with full screen line count.  "
"     Replace model_name value with unique terminal name such as              "
"       VISTACOM_MAC_30_XX where XX is the full screen line count (24 to 100)."


"   VARIABLES                                                                 "
    Full_Screen_Line_Count    = ('24')        "sets Mac Full_Screen_Line_Count"
    clear_all_tabs            = (ESC '[3g')
    set_80_cols               = (ESC '[?3l')
    set_132_cols              = (ESC '[?3h')
    start_bold                = (ESC '[1m')
    start_inverse             = (ESC '[7m')
    start_underline           = (ESC '[4m')
    stop_bold                 = (ESC '[21m')
    stop_inverse              = (ESC '[27m')
    stop_underline            = (ESC '[24m')
    set_graphics              = (ESC '(B' ESC ')0' SI)
    enable_auto_tab           = (ESC '[=3h')
    enable_auto_wrap          = (ESC '[?7h')
    enable_insertion          = (ESC '[4h')
    disable_insertion         = (ESC '[4l')
    global_protect_on         = (ESC '[=1h')
    global_protect_off        = (ESC '[=1l')
    cursor_pos_normal         = (ESC '[=6l')
    reset_terminal            = (ESC 'c')
    enter_screen_mode         = (ESC '[=5h')
    enter_line_mode           = (ESC '[=5l')
    enter_term_mode           = (ESC '%!2')
    set_echo_on               = (ESC '[12l')
    set_echo_off              = (ESC '[12h')
    NOSVE_host                = (ESC '[1t')
    set_screen_size           = (ESC '[' Full_Screen_Line_Count ';80z')
    redo_set_screen_mode      = (NOSVE_host global_protect_on ..
                                clear_all_tabs set_graphics enable_auto_wrap ..
                                enable_auto_tab cursor_pos_normal ..
                                enter_screen_mode)
    redo_set_line_mode        = (global_protect_off set_graphics enter_line_mode)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
    model_name          value = 'VISTA_MAC_HOST_ECHO_30'
    communications      type  = asynch
    application_string  name  = 'vt100_scrolling'  out = 'true'
    application_string  name='DRIVER_PROCEDURE' out= 'tup$host_echo_mac_boot'

"   END OF INFORMATION SPECIFICATION                                          "
    end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
    cursor_pos_encoding      bias  = (1)   type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (ESC '[')
    cursor_pos_second        out   = (';')
    cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
    cursor_home              inout = (ESC '[H')  label='Option H'
    cursor_up                inout = (ESC '[A')  label='up arrow'
    cursor_down              inout = (ESC '[B')  label='down arrow'
    cursor_right             inout = (ESC '[C')  label='right arrow'
    cursor_left              inout = (ESC '[D')  label='left arrow'

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
    move_past_right          type  = wrap_adjacent_next
    move_past_left           type  = wrap_adjacent_next
    move_past_top            type  = stop_next
    move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
    char_past_left           type = wrap_adjacent_next
    char_past_right          type = wrap_adjacent_next
    char_past_last_position  type = wrap_adjacent_next

"   TERMINAL ATTRIBUTES                                                       "
    clears_when_change_size  value = TRUE            "for 80/132 column change"
    function_key_leaves_mark value = 0
    has_hidden               value = TRUE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
    automatic_tabbing        value = TRUE

"   SCREEN SIZES                                                              "
    set_size  rows = 24  columns = 80   out = (set_80_cols)
    set_size  rows = 24  columns = 132  out = (set_132_cols)

"   TERMINAL CAPABILITIES                                                     "
    insert_char         inout = (ESC '[@')   label='Option Space'
    insert_line_bol     inout = (ESC '[L')   label='Option Shift Space'
    delete_char         inout = (ESC '[P')   label='Option Delete'
    delete_line_bol     inout = (ESC '[M')   label='Option Shift Delete'
    erase_end_of_line   inout = (ESC '[K')   label='Option Clear'
    erase_line_stay     inout = (ESC '[2K')
    erase_end_of_field  inout = (ESC '[N')
    erase_field_stay    inout = (ESC '[2N')
    erase_page_stay     inout = (ESC '[2J')  label='Clear'
    backspace           in = (BS)            label='Delete'
    tab_forward         inout = (HT)         label='Tab'
    tab_backward        inout = (ESC '[Z')   label='Option Tab'
    tab_clear_all       inout = (clear_all_tabs)
    tab_set             inout = (ESC 'H')
    tab_clear           inout = (ESC '[g')
    insert_mode_begin   inout = (enable_insertion)
    insert_mode_end     inout = (disable_insertion)

"   SCREEN AND LINE MODE TRANSITION                                           "
    set_screen_mode out = (NOSVE_host  enter_term_mode enter_screen_mode  ..
                           clear_all_tabs  set_graphics  enable_auto_wrap  ..
                           enable_auto_tab  cursor_pos_normal  set_screen_size)
    set_line_mode   out = (enter_line_mode  set_graphics reset_terminal)

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
    protect_begin       out = (ESC 'V')
    protect_end         out = (ESC 'W')
    protect_all         out = (ESC '[1p')
    output_begin        out = (global_protect_off disable_insertion)
    output_end          out = (global_protect_on)
    bell_nak            out = (BEL)

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
    next      in = (CR)              label='Return'
    data      in = (ESC 'O' 27(16))  label='Option "'
    data_s    in = (ESC 'O' 22(16))  label='Option Shift "'
    back      in = (ESC 'O;')        label='Option ;'
    back_s    in = (ESC 'O:')        label='Option Shift ;'
    help      in = (ESC 'O/')        label='Option ?'
    help_s    in = (ESC 'O?')        label='Option Shift ?'
    edit      in = (ESC 'O.')        label='Option .'
    edit_s    in = (ESC 'O>')        label='Option Shift .'
    down      in = (ESC 'O+')        label='Option D'
    down_s    in = (ESC 'O-')        label='Option Shift D'
    up        in = (ESC 'O(')        label='Option U'
    up_s      in = (ESC 'O)')        label='Option Shift U'
    fwd       in = (ESC 'OX')        label='Option F'
    fwd_s     in = (ESC 'Oo')        label='Option Shift F'
    bkw       in = (ESC 'OW')        label='Option B'
    bkw_s     in = (ESC 'Of')        label='Option Shift B'
    undo      in = (ESC 'Ou')        label='F5  Option 5'
    undo_s    in = (ESC 'Om')        label='    Option Shift 5'
    stop      in = (ESC 'Ov')        label='F6  Option 6'
    stop_s    in = (ESC 'Ol')        label='    Option Shift 6'

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
    f1        in = (ESC 'Oq')        label='F1  Option 1'
    f2        in = (ESC 'Or')        label='F2  Option 2'
    f3        in = (ESC 'Os')        label='F3  Option 3'
    f4        in = (ESC 'Ot')        label='F4  Option 4'
    f5        in = (ESC 'Ou')        label='F5  Option 5'
    f6        in = (ESC 'Ov')        label='F6  Option 6'
    f7        in = (ESC 'Ow')        label='F7  Option 7'
    f8        in = (ESC 'Ox')        label='F8  Option 8'
    f9        in = (ESC 'Oy')        label='F9  Option 9'
    f10       in = (ESC 'Oz')        label='10  Option 0'
    f11       in = (ESC 'O{')        label='11  Option Q'
    f12       in = (ESC 'O|')        label='12  Option W'
    f13       in = (ESC 'O}')        label='13  Option E'
    f14       in = (ESC 'O~')        label='14  Option R'
    f15       in = (ESC 'O_')        label='15  Option T'
    f16       in = (ESC 'OU')        label='16  Option Y'
    f1_s      in = (ESC 'Og')        label='    Option Shift 1'
    f2_s      in = (ESC 'Oh')        label='    Option Shift 2'
    f3_s      in = (ESC 'Oi')        label='    Option Shift 3'
    f4_s      in = (ESC 'Oj')        label='    Option Shift 4'
    f5_s      in = (ESC 'Om')        label='    Option Shift 5'
    f6_s      in = (ESC 'Ol')        label='    Option Shift 6'
    f7_s      in = (ESC 'OM')        label='    Option Shift 7'
    f8_s      in = (ESC 'On')        label='    Option Shift 8'
    f9_s      in = (ESC 'Op')        label='    Option Shift 9'
    f10_s     in = (ESC 'OO')        label='    Option Shift 0'
    f11_s     in = (ESC 'Oa')        label='    Option Shift Q'
    f12_s     in = (ESC 'Ob')        label='    Option Shift W'
    f13_s     in = (ESC 'Oc')        label='    Option Shift E'
    f14_s     in = (ESC 'Od')        label='    Option Shift R'
    f15_s     in = (ESC 'Oe')        label='    Option Shift T'
    f16_s     in = (ESC 'OV')        label='    Option Shift Y'

"   TERMINAL VIDEO ATTRIBUTES                                                 "
    alt_begin           out = (start_bold)
    alt_end             out = (stop_bold)
    blink_begin         out = ()                   "not supported"
    blink_end           out = ()                   "not supported"
    hidden_begin        out = ()
    hidden_end          out = ()                   "
    inverse_begin       out = (start_inverse)
    inverse_end         out = (stop_inverse)
    underline_begin     out = (start_underline)
    underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
    error_begin         out = (start_bold)
    error_end           out = (stop_bold)
    input_text_begin    out = (start_underline)
    input_text_end      out = (stop_underline)
    italic_begin        out = (start_inverse)
    italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
    ld_fine_begin            out = (SO)
    ld_fine_end              out = (SI)
    ld_fine_horizontal       out = (71(16))
    ld_fine_vertical         out = (78(16))
    ld_fine_upper_left       out = (6C(16))
    ld_fine_upper_right      out = (6B(16))
    ld_fine_lower_left       out = (6D(16))
    ld_fine_lower_right      out = (6A(16))
    ld_fine_up_t             out = (77(16))
    ld_fine_down_t           out = (76(16))
    ld_fine_left_t           out = (74(16))
    ld_fine_right_t          out = (75(16))
    ld_fine_cross            out = (6E(16))

    ld_medium_begin          out = (SO start_bold)
    ld_medium_end            out = (SI stop_bold)
    ld_medium_horizontal     out = (71(16))
    ld_medium_vertical       out = (78(16))
    ld_medium_upper_left     out = (6C(16))
    ld_medium_upper_right    out = (6B(16))
    ld_medium_lower_left     out = (6D(16))
    ld_medium_lower_right    out = (6A(16))
    ld_medium_up_t           out = (77(16))
    ld_medium_down_t         out = (76(16))
    ld_medium_left_t         out = (74(16))
    ld_medium_right_t        out = (75(16))
    ld_medium_cross          out = (6E(16))

    ld_bold_begin            out = (start_inverse)
    ld_bold_end              out = (stop_inverse)
    ld_bold_horizontal       out = (' ')
    ld_bold_vertical         out = (' ')
    ld_bold_upper_left       out = (' ')
    ld_bold_upper_right      out = (' ')
    ld_bold_lower_left       out = (' ')
    ld_bold_lower_right      out = (' ')
    ld_bold_up_t             out = (' ')
    ld_bold_down_t           out = (' ')
    ld_bold_left_t           out = (' ')
    ld_bold_right_t          out = (' ')
    ld_bold_cross            out = (' ')

    application_string name='REDO_SET_SCREEN_MODE' out=(redo_set_screen_mode)
    application_string name='REDO_SET_LINE_MODE' out=(redo_set_line_mode)

"   END OF TERMINAL DEFINITION FILE FOR Macintosh                             "
"   running Control Data VistaCOM MAC V3.0                                    "
*DECK DECK=CSM$VT100 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR DIGITAL VT100 TERMINAL                       "

"   VARIABLES                                                                 "
prefix              = (1B(16) 5B(16))
clear_all_tabs      = (prefix '3g')
clear_home          = (prefix 32(16) 4A(16))
cursor_key_mode_cur = (prefix '?1l')
enter_ansi_mode     = (1B(16) 3C(16))
g0_us_characters    = (1B(16) 28(16) 42(16))
g1_graphics_chars   = (1B(16) 29(16) 30(16))
home                = (prefix 'H')
home_cursor         = (prefix 48(16))
keypad_applic_mode  = (1B(16) 3D(16))
keypad_numeric_mode = (1B(16) 3D(16))
normal_attributes   = (prefix 'm')
select_g0_char_set  = (0F(16))
set_to_24x80        = (prefix 3F(16) 33(16) 6C(16))
set_to_24x132       = (prefix 3F(16) 33(16) 68(16))
start_alternate     = (prefix 31(16) 6D(16))
start_inverse       = (prefix '7' 6D(16))
start_underline     = (prefix 34(16) 6D(16))
stop_alternate      = normal_attributes
stop_inverse        = normal_attributes
stop_underline      = normal_attributes
wraparound_off      = (prefix '?7l')
wraparound_on       = (prefix '?7h')
redo_set_line_mode  = (enter_ansi_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     keypad_numeric_mode wraparound_on cursor_key_mode_cur)

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'VT100'
communications      type  = asynch
application_string  name  = 'vt100_scrolling'  out = 'true'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (3B(16))
cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 48(16))
cursor_up                inout = (prefix 41(16))
cursor_down              inout = (prefix 42(16))
cursor_left              inout = (prefix 44(16))
cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = TRUE
function_key_leaves_mark value = 1
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = TRUE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80   out = (set_to_24x80)
set_size       rows = 24 columns = 132  out = (set_to_24x132)

"   SCREEN AND LINE MODE TRANSITION                                           "
set_screen_mode     out = (enter_ansi_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     keypad_applic_mode wraparound_off cursor_key_mode_cur)


set_line_mode     out = (enter_ansi_mode clear_all_tabs ..
     g0_us_characters g1_graphics_chars select_g0_char_set ..
     keypad_numeric_mode wraparound_on cursor_key_mode_cur ..
     normal_attributes clear_home home_cursor)

application_string name= 'REDO_SET_LINE_MODE' out=(redo_set_line_mode)

"   TERMINAL CAPABILITIES                                                     "
delete_char         in    = (prefix 50(16))
delete_line_bol     in    = (prefix 4D(16))
erase_end_of_line   inout = (prefix 4B(16))
erase_line_stay     inout = (prefix 32(16) 4B(16))
erase_page_home     inout = (clear_home home)
insert_line_bol     in    = (prefix 4C(16))
insert_mode_begin   in    = (prefix 34(16) 68(16))
insert_mode_end     in    = (prefix 34(16) 6C(16))
tab_forward         inout = (09(16))
tab_clear_all       inout = (clear_all_tabs)
tab_set             inout = (1B(16) 48(16))

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
bell_nak            out = (bel)
backspace           in = bs

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (1B(16) 4F(16) 71(16)) label='k1'
f2        in = (1B(16) 4F(16) 72(16)) label='k2'
f3        in = (1B(16) 4F(16) 73(16)) label='k3'
f4        in = (1B(16) 4F(16) 74(16)) label='k4'
f5        in = (1B(16) 4F(16) 75(16)) label='k5'
f6        in = (1B(16) 4F(16) 76(16)) label='k6'
f7        in = (1B(16) 4F(16) 77(16)) label='k7'
f8        in = (1B(16) 4F(16) 78(16)) label='k8'
f9        in = (1B(16) 4F(16) 79(16)) label='k9'
f10       in = ()
f11       in = ()
f12       in = ()
f13       in = ()
f14       in = ()
f15       in = ()
f16       in = ()
f1_s      in = (1B(16) 4F(16) 50(16)) label='p1'
f2_s      in = (1B(16) 4F(16) 51(16)) label='p2'
f3_s      in = (1B(16) 4F(16) 52(16)) label='p3'
f4_s      in = (1B(16) 4F(16) 53(16)) label='p4'
f5_s      in = (1B(16) 4F(16) 6D(16)) label='k-'
f6_s      in = (1B(16) 4F(16) 6C(16)) label='k,'
f7_s      in = (1B(16) 4F(16) 4D(16)) label='ke'
f8_s      in = (1B(16) 4F(16) 6E(16)) label='k.'
f9_s      in = (1B(16) 4F(16) 70(16)) label='k0'
f10_s     in = ()
f11_s     in = ()
f12_s     in = ()
f13_s     in = ()
f14_s     in = ()
f15_s     in = ()
f16_s     in = ()

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = (1B(16) 4F(16) 71(16)) label='F1'
fwd       in = (1B(16) 4F(16) 72(16)) label='F2'
back      in = (1B(16) 4F(16) 73(16)) label='F3'
help      in = (1B(16) 4F(16) 74(16)) label='F4'
undo      in = (1B(16) 4F(16) 75(16)) label='F5'
stop      in = (1B(16) 4F(16) 76(16)) label='F6'
bkw_s     in = (1B(16) 4F(16) 50(16)) label='  Shift-F1'
fwd_s     in = (1B(16) 4F(16) 51(16)) label='  Shift-F2'
undo_s    in = (1B(16) 4F(16) 6D(16)) label='  Shift-F5'
stop_s    in = (1B(16) 4F(16) 6C(16)) label='  Shift-F6'
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_alternate)
alt_end             out = (stop_alternate)
blink_begin         out = (prefix 35(16) 6D(16))
blink_end           out = normal_attributes
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = 0E(16)
ld_fine_end              out = 0F(16)
ld_fine_horizontal       out = 71(16)
ld_fine_vertical         out = 78(16)
ld_fine_upper_left       out = 6C(16)
ld_fine_upper_right      out = 6B(16)
ld_fine_lower_left       out = 6D(16)
ld_fine_lower_right      out = 6A(16)
ld_fine_up_t             out = 77(16)
ld_fine_down_t           out = 76(16)
ld_fine_left_t           out = 74(16)
ld_fine_right_t          out = 75(16)
ld_fine_cross            out = 6E(16)
ld_medium_begin          out = (0E(16) start_alternate)
ld_medium_end            out = (0F(16) stop_alternate)
ld_medium_horizontal     out = 71(16)
ld_medium_vertical       out = 78(16)
ld_medium_upper_left     out = 6C(16)
ld_medium_upper_right    out = 6B(16)
ld_medium_lower_left     out = 6D(16)
ld_medium_lower_right    out = 6A(16)
ld_medium_up_t           out = 77(16)
ld_medium_down_t         out = 76(16)
ld_medium_left_t         out = 74(16)
ld_medium_right_t        out = 75(16)
ld_medium_cross          out = 6E(16)
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "

"   END OF TERMINAL DEFINITION FILE FOR DIGITAL VT100 TERMINAL               "
*DECK DECK=CSM$WYSE_60 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR WYSE 60 TERMINAL                       "

"  This terminal definition is one of a pair provided for 'least common    "
"  denominator' support of the various configurations of the Wyse-60.      "
"  You may find it worthwhile to customize these definitions to your       "
"  actual keyboard layout.  Depending on the applications you primarily    "
"  use, you may also find the Wyse-60's Televideo-955 emulation            "
"  capability to be preferable.                                            "

"  The two terminal definitions are named WYSE_60 and WYSE_60_PROTECTED.   "
"  The unprotected definition will generally be preferable for the         "
"  Edit_File application since protection disables insertion and deletion  "
"  of lines, plus columnar tabbing.  The unprotected definition is also    "
"  preferable for applications that expect the user to press the cursor    "
"  motion keys to point within a protected field, such as Edit_Catalog or  "
"  Design_Screen.  The protected definition is best for 'fill in the       "
"  forms' applications since it includes auto-tabbing.                     "

"  The Wyse-60 hardware behavior will not allow cursor motion into a       "
"  protected field.  Note that if the Wyse terminal is placed into         "
"  Televideo 955 emulation and the TV_955_PROTECTED definition is          "
"  selected, the user can move the cursor vertically into protected        "
"  fields, although not horizontally; this is sufficient for most usage    "
"  of Edit_Catalog's 'point and shoot' functions.                          "

"  When the Wyse-60 emulates a Televideo 955, there is an incompatibility  "
"  in the behavior of excessive backward tab keystrokes:  the actual       "
"  Televideo will not move the cursor to any position in front of the      "
"  first input field, while the Wyse emulation can place the cursor into   "
"  the Home position even when it is protected.  If this incompatibility   "
"  cause significant hardships, the workaround is to make a customized     "
"  version of the TV_955_PROTECTED definition which sets the TABS_TO_HOME  "
"  parameter to TRUE instead of the Televideo FALSE value.                 "

"  The two WYSE_60 definitions are packaged with support for 43-row        "
"  display format.  Some applications will always use the 24-row format,   "
"  some (such as Edit_Catalog) will always use the 43-row format, and      "
"  some (such as Edit_File) will support both.  Edit_File will default to  "
"  43 rows.  Some users may consider the 43-row format to be illegible,    "
"  so you might need to customize these definitions to only describe the   "
"  24-row formats.  Note that if you choose to use the Wyse-60 as a        "
"  Televideo-955 emulator, you will only have 24-row formats.              "

"  The two WYSE_60 definitions are packaged to support all four keyboard   "
"  configurations.  This is accomplished by NOT providing LABEL            "
"  parameters on the statements that define keys which might not really    "
"  be available, such as function keys 11 thru 16 plus the                 "
"  insert/delete-line keys.  You may want to customize these definitions   "
"  to your own keyboard configuration by adding the missing LABEL          "
"  parameters.                                                             "

                                                                               "
"  VARIABLES
   prefix       = (ESC 'G')
   graph        = (ESC 'H')
   line_on      = (graph 02(16))
   line_off     = (graph 03(16))

   bold_box     = (graph '7')
   up_t         = (graph '0')
   down_t       = (graph '=')
   left_t       = (graph '4')
   right_t      = (graph '9')
   cross        = (graph '8')
   normal       = (prefix '0')
   blink        = (prefix '2')
   reverse      = (prefix '4')
   underline    = (prefix '8')
   dim          = (prefix 'p')
   wrap_off     = (esc 'd.')
   wrap_on      = (esc 'd/')
   autopage_off = (esc 'd*')
   autoscroll_on    = (esc 'O')
   autoscroll_off   = (esc 'N')

    terminal_model      value = 'WYSE_60'
    communications      type  = asynch
    end_of_information  in    = (0)

    apps name='driver_procedure' out='tup$bootstrap_wyse60_driver'
"
"   CURSOR POSITIONING INFORMATION
"
    cursor_pos_encoding      bias  = (1)    type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (ESC 'a')
    cursor_pos_second        out   = ('R')
    cursor_pos_third         out   = ('C')
"
"   CURSOR MOVEMENT INFORMATION
"
    cursor_home              inout = (rs)       label='Home'
    cursor_up                inout = (vt)
    cursor_down              inout = (lf)
    cursor_left              inout = (bs)
    cursor_right             inout = (ff)
"
"   CURSOR BEHAVIOR (MOVEMENT KEYS)
"
    move_past_right          type  = WRAP_ADJACENT_NEXT
    move_past_left           type  = WRAP_ADJACENT_NEXT
    move_past_top            type  = wrap_same_next
    move_past_bottom         type  = wrap_same_next
"
"   CURSOR BEHAVIOR (CHARACTER KEYS)
"
    char_past_right          type  = WRAP_ADJACENT_NEXT
    char_past_left           type  = WRAP_ADJACENT_NEXT
    char_past_last_position  type  = WRAP_ADJACENT_NEXT
"
"   TERMINAL ATTRIBUTES
"
    automatic_tabbing        value = FALSE
    clears_when_change_size  value = FALSE
    function_key_leaves_mark value = 1
    has_hidden               value = FALSE
    has_protect              value = FALSE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = TRUE
    tabs_to_unprotected      value = FALSE
    type_ahead               value = TRUE
"
"   SCREEN SIZES
"
    set_size       rows = 24 columns = 80    out = (ESC '`:' esc 'e(')
    set_size       rows = 43 columns = 80    out = (ESC '`:' esc 'e+')
    set_size       rows = 24 columns = 132   out = (ESC '`;' esc 'e(')
    set_size       rows = 43 columns = 132   out = (ESC '`;' esc 'e+')
"
"   SCREEN AND LINE MODE TRANSITIONS
"
    set_screen_mode     out = (wrap_on  autoscroll_off autopage_off)
    set_line_mode       out = (wrap_on  autoscroll_on)
"
"   TERMINAL CAPABILITIES
"
    backspace           in    = ()
"
    delete_char         inout = (ESC 'W')        label='Delete Character'
    delete_line_bol     inout = (ESC 'R')
    delete_line_stay    inout = ()
"
    erase_char          inout = ()
    erase_end_of_line   inout = (ESC 'T')
    erase_field_bof     inout = ()
    erase_field_stay    inout = ()
    erase_line_bol      inout = ()
    erase_line_stay     inout = ()
    erase_page_home     inout = (ESC '+')
    erase_page_stay     inout = ()
"
    insert_char         inout = (ESC 'Q')            label='Insert Character'
    insert_line_bol     inout = (ESC 'E')
    insert_line_stay    inout = ()
    insert_mode_begin   inout = (esc 'q')
    insert_mode_end     inout = (esc 'r')
"
    erase_unprotected   inout = ()
    erase_end_of_page   inout = ()
    erase_end_of_field  inout = ()
"
    insert_mode_toggle  inout = ()
"
    tab_backward        inout = (ESC 'I')
    tab_clear           inout = (ESC '2')
    tab_clear_all       inout = (ESC '0')
    tab_forward         inout = (ht)
    tab_set             inout = (ESC '1')
"
"   MISCELLANEOUS TERMINAL SEQUENCES
"
    bell_nak            out = (BEL)
    bell_ack            out = ()
"
    display_begin       out = ()
    display_end         out = ()
    field_scroll_down   out = ()
    field_scroll_set    out = ()
    field_scroll_up     out = ()
    output_begin        out = ()
    output_end          out = ()
    print_begin         out = ()
    print_end           out = ()
    print_page          out = ()
    protect_all         out = ()

    reset               out = ()
    return              out = ()
"
"   PROGRAMMABLE FUNCTION KEYS
"
    f1        in = (SOH '@')        label = 'f1'
    f2        in = (SOH 'A')        label = 'f2'
    f3        in = (SOH 'B')        label = 'f3'
    f4        in = (SOH 'C')        label = 'f4'
    f5        in = (SOH 'D')        label = 'f5'
    f6        in = (SOH 'E')        label = 'f6'
    f7        in = (SOH 'F')        label = 'f7'
    f8        in = (SOH 'G')        label = 'f8'
    f9        in = (SOH 'H')        label = 'f9'
    f10       in = (SOH 'I')        label = '10'
    f11       in = (SOH 'J')      " label = '11' "
    f12       in = (SOH 'K')      " label = '12' "
    f13       in = (SOH 'L')      " label = '13' "
    f14       in = (SOH 'M')      " label = '14' "
    f15       in = (SOH 'N')      " label = '15' "
    f16       in = (SOH 'O')      " label = '16' "
    f1_s      in = (SOH '`')        label = '  sf1'
    f2_s      in = (SOH 'a')        label = '  sf2'
    f3_s      in = (SOH 'b')        label = '  sf3'
    f4_s      in = (SOH 'c')        label = '  sf4'
    f5_s      in = (SOH 'd')        label = '  sf5'
    f6_s      in = (SOH 'e')        label = '  sf6'
    f7_s      in = (SOH 'f')        label = '  sf7'
    f8_s      in = (SOH 'g')        label = '  sf8'
    f9_s      in = (SOH 'h')        label = '  sf9'
    f10_s     in = (SOH 'i')        label = '  sf10'
    f11_s     in = (SOH 'j')      " label = '  11' "
    f12_s     in = (SOH 'k')      " label = '  12' "
    f13_s     in = (SOH 'l')      " label = '  13' "
    f14_s     in = (SOH 'm')      " label = '  14' "
    f15_s     in = (SOH 'n')      " label = '  15' "
    f16_s     in = (SOH 'o')      " label = '  16' "
"
"   CDC STANDARD FUNCTION KEYS
"
    next      in = 13        label = '  ENTER'
    bkw       in = (SOH '@')        label = 'f1'
    fwd       in = (SOH 'A')        label = 'f2'
    back      in = (SOH 'B')        label = 'f3'
    help      in = (SOH 'C')        label = 'f4'
    undo      in = (SOH 'D')        label = 'f5'
    stop      in = (SOH 'E')        label = 'f6'
    bkw_s     in = (SOH '`')        label = '  sf1'
    fwd_s     in = (SOH 'a')        label = '  sf2'
    undo_s    in = (SOH 'd')        label = '  sf5'
    stop_s    in = (SOH 'e')        label = '  sf6'
"
"   TERMINAL VIDEO ATTRIBUTES
"
    alt_begin             out = (dim)
    alt_end               out = (normal)
    low_intensity_begin   out = (dim)
    low_intensity_end     out = (normal)
    high_intensity_begin  out = (reverse)
    high_intensity_end    out = (normal)
    blink_begin           out = (blink)
    blink_end             out = (normal)
    hidden_begin          out = ()
    hidden_end            out = ()
    inverse_begin         out = (reverse)
    inverse_end           out = (normal)
    underline_begin       out = (underline)
    underline_end         out = (normal)
"
"   LOGICAL ATTRIBUTE SPECIFICATIONS
"
    error_begin         out = (reverse)
    error_end           out = (normal)
    input_text_begin    out = (underline)
    input_text_end      out = (normal)
    italic_begin        out = (reverse)
    italic_end          out = (normal)
    message_begin       out = (reverse)
    message_end         out = (normal)
    output_text_begin   out = ()
    output_text_end     out = ()
    title_begin         out = ()
    title_end           out = ()
"
"   LINE DRAWING SPECIFICATION
"
    ld_fine_begin            out = (line_on)
    ld_fine_end              out = (line_off)
    ld_fine_horizontal       out = (graph ':')
    ld_fine_vertical         out = (graph '6')
    ld_fine_upper_left       out = (graph '2')
    ld_fine_upper_right      out = (graph '3')
    ld_fine_lower_left       out = (graph '1')
    ld_fine_lower_right      out = (graph '5')
    ld_fine_up_t             out = (up_t)
    ld_fine_down_t           out = (down_t)
    ld_fine_left_t           out = (left_t)
    ld_fine_right_t          out = (right_t)
    ld_fine_cross            out = (cross)
"
    ld_medium_begin          out = (line_on)
    ld_medium_end            out = (line_off)
    ld_medium_horizontal       out = (graph '<')
    ld_medium_vertical         out = (graph '>')
    ld_medium_upper_left       out = (graph '2')
    ld_medium_upper_right      out = (graph '3')
    ld_medium_lower_left       out = (graph '1')
    ld_medium_lower_right      out = (graph '5')
    ld_medium_up_t             out = (up_t)
    ld_medium_down_t           out = (down_t)
    ld_medium_left_t           out = (left_t)
    ld_medium_right_t          out = (right_t)
    ld_medium_cross            out = (cross)
"
    ld_bold_begin            out = (line_on)
    ld_bold_end              out = (line_off)
    ld_bold_horizontal       out = (bold_box)
    ld_bold_vertical         out = (bold_box)
    ld_bold_upper_left       out = (bold_box)
    ld_bold_upper_right      out = (bold_box)
    ld_bold_lower_left       out = (bold_box)
    ld_bold_lower_right      out = (bold_box)
    ld_bold_up_t             out = (bold_box)
    ld_bold_down_t           out = (bold_box)
    ld_bold_left_t           out = (bold_box)
    ld_bold_right_t          out = (bold_box)
    ld_bold_cross            out = (bold_box)

"   END OF TERMINAL DEFINITION FILE FOR WYSE 60 TERMINAL               "
*DECK DECK=CSM$WYSE_60_HOST_ECHO EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR WYSE 60 TERMINAL                       "

"  The two WYSE_60 definitions are packaged with support for 43-row        "
"  display format.  Some applications will always use the 24-row format,   "
"  some (such as Edit_Catalog) will always use the 43-row format, and      "
"  some (such as Edit_File) will support both.  Edit_File will default to  "
"  43 rows.  Some users may consider the 43-row format to be illegible,    "
"  so you might need to customize these definitions to only describe the   "
"  24-row formats.  Note that if you choose to use the Wyse-60 as a        "
"  Televideo-955 emulator, you will only have 24-row formats.              "

"  The two WYSE_60 definitions are packaged to support all four keyboard   "
"  configurations.  This is accomplished by NOT providing LABEL            "
"  parameters on the statements that define keys which might not really    "
"  be available, such as function keys 11 thru 16 plus the                 "
"  insert/delete-line keys.  You may want to customize these definitions   "
"  to your own keyboard configuration by adding the missing LABEL          "
"  parameters.                                                             "

"  VARIABLES
   prefix       = (ESC 'G')
   graph        = (ESC 'H')
   line_on      = (graph 02(16))
   line_off     = (graph 03(16))
   bold_box     = (graph '7')
   up_t         = (graph '0')
   down_t       = (graph '=')
   left_t       = (graph '4')
   right_t      = (graph '9')
   cross        = (graph '8')
   normal       = (prefix '0')
   hidden       = (prefix '1')
   blink        = (prefix '2')
   reverse      = (prefix '4')
   underline    = (prefix '8')
   dim          = (prefix 'p')
   enable_protect   = (ESC '&')
   disable_protect  = (ESC '''')
   start_protect    = (esc ')')
   stop_protect     = (esc '(')
   wrap_off     = (esc 'd.')
   wrap_on      = (esc 'd/')
   autopage_off = (esc 'd*')
   autoscroll_on    = (esc 'O')
   autoscroll_off   = (esc 'N')

    terminal_model      value = 'wyse_60_host_echo'
    communications      type  = asynch
    end_of_information  in    = (0)

    apps name='driver_procedure' out='tup$host_echo_wyse_60_boot'

"
"   CURSOR POSITIONING INFORMATION
"
    cursor_pos_encoding      bias  = (1)    type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (ESC 'a')
    cursor_pos_second        out   = ('R')
    cursor_pos_third         out   = ('C')
"
"   CURSOR MOVEMENT INFORMATION
"
    cursor_home              inout = (rs)            label='Home'
    cursor_up                inout = (vt)
    cursor_down              inout = (lf)
    cursor_left              inout = (bs)
    cursor_right             inout = (ff)
"
"   CURSOR BEHAVIOR (MOVEMENT KEYS)
"
    move_past_right          type  = WRAP_ADJACENT_NEXT
    move_past_left           type  = WRAP_ADJACENT_NEXT
    move_past_top            type  = wrap_same_next
    move_past_bottom         type  = wrap_same_next
"
"   CURSOR BEHAVIOR (CHARACTER KEYS)
"
    char_past_right          type  = WRAP_ADJACENT_NEXT
    char_past_left           type  = WRAP_ADJACENT_NEXT
    char_past_last_position  type  = WRAP_ADJACENT_NEXT
"
"   TERMINAL ATTRIBUTES
"
    automatic_tabbing        value = TRUE
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 1
    has_hidden               value = TRUE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = FALSE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
"
"   SCREEN SIZES
"
    set_size       rows = 24 columns = 80    out = (ESC '`:' esc 'e(')
    set_size       rows = 43 columns = 80    out = (ESC '`:' esc 'e+')
    set_size       rows = 24 columns = 132   out = (ESC '`;' esc 'e(')
    set_size       rows = 43 columns = 132   out = (ESC '`;' esc 'e+')
"
"   SCREEN AND LINE MODE TRANSITIONS
"
    set_screen_mode     out = (wrap_on  autoscroll_off autopage_off)

    set_line_mode       out = (wrap_on  autoscroll_on)
"
"   TERMINAL CAPABILITIES
"
    backspace           in    = ()
"
    delete_char         inout = (ESC 'W')            label='Delete Character'
    delete_line_bol     inout = (ESC 'R')
    delete_line_stay    inout = ()
"
    erase_char          inout = ()
    erase_end_of_line   inout = (ESC 'T')
    erase_field_bof     inout = ()
    erase_field_stay    inout = ()
    erase_line_bol      inout = ()
    erase_line_stay     inout = ()
    erase_page_home     inout = (ESC '+')
    erase_page_stay     inout = ()
"
    insert_char         inout = (ESC 'Q')           label='Insert Character'
    insert_line_bol     inout = (ESC 'E')
    insert_line_stay    inout = ()
    insert_mode_begin   inout = (esc 'q')
    insert_mode_end     inout = (esc 'r')
"
    erase_unprotected   inout = (ESC ';')
    erase_end_of_page   inout = ()
    erase_end_of_field  inout = ()
"
    insert_mode_toggle  inout = ()
"
    tab_backward        inout = (ESC 'I')
    tab_clear           inout = (ESC '2')
    tab_clear_all       inout = (ESC '0')
    tab_forward         inout = (ht)
    tab_set             inout = (ESC '1')
"
"   MISCELLANEOUS TERMINAL SEQUENCES
"
    bell_nak            out = (BEL)
    bell_ack            out = ()
"
    display_begin       out = ()
    display_end         out = ()
    field_scroll_down   out = ()
    field_scroll_set    out = ()
    field_scroll_up     out = ()
    output_begin        out = (disable_protect)
    output_end          out = (enable_protect)
    print_begin         out = ()
    print_end           out = ()
    print_page          out = ()
    protect_all         out = (ESC ',')

    reset               out = ()
    return              out = ()
"
"   PROGRAMMABLE FUNCTION KEYS
"
    f1        in = (SOH '@')        label = 'f1'
    f2        in = (SOH 'A')        label = 'f2'
    f3        in = (SOH 'B')        label = 'f3'
    f4        in = (SOH 'C')        label = 'f4'
    f5        in = (SOH 'D')        label = 'f5'
    f6        in = (SOH 'E')        label = 'f6'
    f7        in = (SOH 'F')        label = 'f7'
    f8        in = (SOH 'G')        label = 'f8'
    f9        in = (SOH 'H')        label = 'f9'
    f10       in = (SOH 'I')        label = '10'
    f11       in = (SOH 'J')      " label = '11' "
    f12       in = (SOH 'K')      " label = '12' "
    f13       in = (SOH 'L')      " label = '13' "
    f14       in = (SOH 'M')      " label = '14' "
    f15       in = (SOH 'N')      " label = '15' "
    f16       in = (SOH 'O')      " label = '16' "
    f1_s      in = (SOH '`')        label = '  sf1'
    f2_s      in = (SOH 'a')        label = '  sf2'
    f3_s      in = (SOH 'b')        label = '  sf3'
    f4_s      in = (SOH 'c')        label = '  sf4'
    f5_s      in = (SOH 'd')        label = '  sf5'
    f6_s      in = (SOH 'e')        label = '  sf6'
    f7_s      in = (SOH 'f')        label = '  sf7'
    f8_s      in = (SOH 'g')        label = '  sf8'
    f9_s      in = (SOH 'h')        label = '  sf9'
    f10_s     in = (SOH 'i')        label = '  sf10'
    f11_s     in = (SOH 'j')      " label = '  11' "
    f12_s     in = (SOH 'k')      " label = '  12' "
    f13_s     in = (SOH 'l')      " label = '  13' "
    f14_s     in = (SOH 'm')      " label = '  14' "
    f15_s     in = (SOH 'n')      " label = '  15' "
    f16_s     in = (SOH 'o')      " label = '  16' "
"
"   CDC STANDARD FUNCTION KEYS
"
    next      in = 13        label = '  RETURN'
    bkw       in = (SOH '@')        label = 'f1'
    fwd       in = (SOH 'A')        label = 'f2'
    back      in = (SOH 'B')        label = 'f3'
    help      in = (SOH 'C')        label = 'f4'
    undo      in = (SOH 'D')        label = 'f5'
    stop      in = (SOH 'E')        label = 'f6'
    bkw_s     in = (SOH '`')        label = '  sf1'
    fwd_s     in = (SOH 'a')        label = '  sf2'
    undo_s    in = (SOH 'd')        label = '  sf5'
    stop_s    in = (SOH 'e')        label = '  sf6'
"
"   TERMINAL VIDEO ATTRIBUTES
"
    alt_begin             out = (dim)      " instead of dim since protect=dim
    alt_end               out = (normal)
    low_intensity_begin   out = (dim)      " instead of dim since protect=dim
    low_intensity_end     out = (normal)
    high_intensity_begin  out = (reverse)
    high_intensity_end    out = (normal)
    blink_begin           out = (blink)
    blink_end             out = (normal)
    hidden_begin          out = (hidden)
    hidden_end            out = (normal)
    inverse_begin         out = (reverse)
    inverse_end           out = (normal)
    protect_begin         out = (start_protect)
    protect_end           out = (stop_protect)
    underline_begin       out = (underline)
    underline_end         out = (normal)
"
"   LOGICAL ATTRIBUTE SPECIFICATIONS
"
    error_begin         out = (reverse)
    error_end           out = (normal)
    input_text_begin    out = (underline)
    input_text_end      out = (normal)
    italic_begin        out = (reverse)
    italic_end          out = (normal)
    message_begin       out = (reverse)
    message_end         out = (normal)
    output_text_begin   out = ()
    output_text_end     out = ()
    title_begin         out = ()
    title_end           out = ()
"
"   LINE DRAWING SPECIFICATION
"
    ld_fine_begin            out = (line_on)
    ld_fine_end              out = (line_off)
    ld_fine_horizontal       out = (graph ':')
    ld_fine_vertical         out = (graph '6')
    ld_fine_upper_left       out = (graph '2')
    ld_fine_upper_right      out = (graph '3')
    ld_fine_lower_left       out = (graph '1')
    ld_fine_lower_right      out = (graph '5')
    ld_fine_up_t             out = (up_t)
    ld_fine_down_t           out = (down_t)
    ld_fine_left_t           out = (left_t)
    ld_fine_right_t          out = (right_t)
    ld_fine_cross            out = (cross)
"
    ld_medium_begin          out = (line_on)
    ld_medium_end            out = (line_off)
    ld_medium_horizontal       out = (graph '<')
    ld_medium_vertical         out = (graph '>')
    ld_medium_upper_left       out = (graph '2')
    ld_medium_upper_right      out = (graph '3')
    ld_medium_lower_left       out = (graph '1')
    ld_medium_lower_right      out = (graph '5')
    ld_medium_up_t             out = (up_t)
    ld_medium_down_t           out = (down_t)
    ld_medium_left_t           out = (left_t)
    ld_medium_right_t          out = (right_t)
    ld_medium_cross            out = (cross)
"
    ld_bold_begin            out = (line_on)
    ld_bold_end              out = (line_off)
    ld_bold_horizontal       out = (bold_box)
    ld_bold_vertical         out = (bold_box)
    ld_bold_upper_left       out = (bold_box)
    ld_bold_upper_right      out = (bold_box)
    ld_bold_lower_left       out = (bold_box)
    ld_bold_lower_right      out = (bold_box)
    ld_bold_up_t             out = (bold_box)
    ld_bold_down_t           out = (bold_box)
    ld_bold_left_t           out = (bold_box)
    ld_bold_right_t          out = (bold_box)
    ld_bold_cross            out = (bold_box)

"   END OF TERMINAL DEFINITION FILE FOR WYSE 60 TERMINAL               "
*DECK DECK=CSM$WYSE_60_PROTECTED EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR WYSE 60 TERMINAL                       "

"  This terminal definition is one of a pair provided for 'least common    "
"  denominator' support of the various configurations of the Wyse-60.      "
"  You may find it worthwhile to customize these definitions to your       "
"  actual keyboard layout.  Depending on the applications you primarily    "
"  use, you may also find the Wyse-60's Televideo-955 emulation            "
"  capability to be preferable.                                            "

"  The two terminal definitions are named WYSE_60 and WYSE_60_PROTECTED.   "
"  The unprotected definition will generally be preferable for the         "
"  Edit_File application since protection disables insertion and deletion  "
"  of lines, plus columnar tabbing.  The unprotected definition is also    "
"  preferable for applications that expect the user to press the cursor    "
"  motion keys to point within a protected field, such as Edit_Catalog or  "
"  Design_Screen.  The protected definition is best for 'fill in the       "
"  forms' applications since it includes auto-tabbing.                     "

"  The Wyse-60 hardware behavior will not allow cursor motion into a       "
"  protected field.  Note that if the Wyse terminal is placed into         "
"  Televideo 955 emulation and the TV_955_PROTECTED definition is          "
"  selected, the user can move the cursor vertically into protected        "
"  fields, although not horizontally; this is sufficient for most usage    "
"  of Edit_Catalog's 'point and shoot' functions.                          "

"  When the Wyse-60 emulates a Televideo 955, there is an incompatibility  "
"  in the behavior of excessive backward tab keystrokes:  the actual       "
"  Televideo will not move the cursor to any position in front of the      "
"  first input field, while the Wyse emulation can place the cursor into   "
"  the Home position even when it is protected.  If this incompatibility   "
"  cause significant hardships, the workaround is to make a customized     "
"  version of the TV_955_PROTECTED definition which sets the TABS_TO_HOME  "
"  parameter to TRUE instead of the Televideo FALSE value.                 "

"  The two WYSE_60 definitions are packaged with support for 43-row        "
"  display format.  Some applications will always use the 24-row format,   "
"  some (such as Edit_Catalog) will always use the 43-row format, and      "
"  some (such as Edit_File) will support both.  Edit_File will default to  "
"  43 rows.  Some users may consider the 43-row format to be illegible,    "
"  so you might need to customize these definitions to only describe the   "
"  24-row formats.  Note that if you choose to use the Wyse-60 as a        "
"  Televideo-955 emulator, you will only have 24-row formats.              "

"  The two WYSE_60 definitions are packaged to support all four keyboard   "
"  configurations.  This is accomplished by NOT providing LABEL            "
"  parameters on the statements that define keys which might not really    "
"  be available, such as function keys 11 thru 16 plus the                 "
"  insert/delete-line keys.  You may want to customize these definitions   "
"  to your own keyboard configuration by adding the missing LABEL          "
"  parameters.                                                             "

"  VARIABLES
   prefix       = (ESC 'G')
   graph        = (ESC 'H')
   line_on      = (graph 02(16))
   line_off     = (graph 03(16))

   bold_box     = (graph '7')
   up_t         = (graph '0')
   down_t       = (graph '=')
   left_t       = (graph '4')
   right_t      = (graph '9')
   cross        = (graph '8')
   normal       = (prefix '0')
   blink        = (prefix '2')
   reverse      = (prefix '4')
   underline    = (prefix '8')
   dim          = (prefix 'p')
   enable_protect   = (ESC '&')
   disable_protect  = (ESC '''')
   start_protect    = (esc ')')
   stop_protect     = (esc '(')
   wrap_off     = (esc 'd.')
   wrap_on      = (esc 'd/')
   autopage_off = (esc 'd*')
   autoscroll_on    = (esc 'O')
   autoscroll_off   = (esc 'N')

    terminal_model      value = 'wyse_60_protected'
    communications      type  = asynch
    end_of_information  in    = (0)

    apps name='driver_procedure' out='tup$bootstrap_wyse60_driver'

"
"   CURSOR POSITIONING INFORMATION
"
    cursor_pos_encoding      bias  = (1)    type = ansi_cursor
    cursor_pos_column_first  value = FALSE
    cursor_pos_column_length value = (0)
    cursor_pos_row_length    value = (0)
    cursor_pos_begin         out   = (ESC 'a')
    cursor_pos_second        out   = ('R')
    cursor_pos_third         out   = ('C')
"
"   CURSOR MOVEMENT INFORMATION
"
    cursor_home              inout = (rs)            label='Home'
    cursor_up                inout = (vt)
    cursor_down              inout = (lf)
    cursor_left              inout = (bs)
    cursor_right             inout = (ff)
"
"   CURSOR BEHAVIOR (MOVEMENT KEYS)
"
    move_past_right          type  = WRAP_ADJACENT_NEXT
    move_past_left           type  = WRAP_ADJACENT_NEXT
    move_past_top            type  = wrap_same_next
    move_past_bottom         type  = wrap_same_next
"
"   CURSOR BEHAVIOR (CHARACTER KEYS)
"
    char_past_right          type  = WRAP_ADJACENT_NEXT
    char_past_left           type  = WRAP_ADJACENT_NEXT
    char_past_last_position  type  = WRAP_ADJACENT_NEXT
"
"   TERMINAL ATTRIBUTES
"
    automatic_tabbing        value = TRUE
    clears_when_change_size  value = TRUE
    function_key_leaves_mark value = 1
    has_hidden               value = FALSE
    has_protect              value = TRUE
    home_at_top              value = TRUE
    multiple_sizes           value = TRUE
    tabs_to_home             value = FALSE
    tabs_to_tab_stops        value = FALSE
    tabs_to_unprotected      value = TRUE
    type_ahead               value = TRUE
"
"   SCREEN SIZES
"
    set_size       rows = 24 columns = 80    out = (ESC '`:' esc 'e(')
    set_size       rows = 43 columns = 80    out = (ESC '`:' esc 'e+')
    set_size       rows = 24 columns = 132   out = (ESC '`;' esc 'e(')
    set_size       rows = 43 columns = 132   out = (ESC '`;' esc 'e+')
"
"   SCREEN AND LINE MODE TRANSITIONS
"
    set_screen_mode     out = (wrap_on  autoscroll_off autopage_off)

    set_line_mode       out = (wrap_on  autoscroll_on)
"
"   TERMINAL CAPABILITIES
"
    backspace           in    = ()
"
    delete_char         inout = (ESC 'W')            label='Delete Character'
    delete_line_bol     inout = (ESC 'R')
    delete_line_stay    inout = ()
"
    erase_char          inout = ()
    erase_end_of_line   inout = (ESC 'T')
    erase_field_bof     inout = ()
    erase_field_stay    inout = ()
    erase_line_bol      inout = ()
    erase_line_stay     inout = ()
    erase_page_home     inout = (ESC '+')
    erase_page_stay     inout = ()
"
    insert_char         inout = (ESC 'Q')           label='Insert Character'
    insert_line_bol     inout = (ESC 'E')
    insert_line_stay    inout = ()
    insert_mode_begin   inout = (esc 'q')
    insert_mode_end     inout = (esc 'r')
"
    erase_unprotected   inout = (ESC ';')
    erase_end_of_page   inout = ()
    erase_end_of_field  inout = ()
"
    insert_mode_toggle  inout = ()
"
    tab_backward        inout = (ESC 'I')
    tab_clear           inout = (ESC '2')
    tab_clear_all       inout = (ESC '0')
    tab_forward         inout = (ht)
    tab_set             inout = (ESC '1')
"
"   MISCELLANEOUS TERMINAL SEQUENCES
"
    bell_nak            out = (BEL)
    bell_ack            out = ()
"
    display_begin       out = ()
    display_end         out = ()
    field_scroll_down   out = ()
    field_scroll_set    out = ()
    field_scroll_up     out = ()
    output_begin        out = (disable_protect)
    output_end          out = (enable_protect)
    print_begin         out = ()
    print_end           out = ()
    print_page          out = ()
    protect_all         out = (ESC ',')

    reset               out = ()
    return              out = ()
"
"   PROGRAMMABLE FUNCTION KEYS
"
    f1        in = (SOH '@')        label = 'f1'
    f2        in = (SOH 'A')        label = 'f2'
    f3        in = (SOH 'B')        label = 'f3'
    f4        in = (SOH 'C')        label = 'f4'
    f5        in = (SOH 'D')        label = 'f5'
    f6        in = (SOH 'E')        label = 'f6'
    f7        in = (SOH 'F')        label = 'f7'
    f8        in = (SOH 'G')        label = 'f8'
    f9        in = (SOH 'H')        label = 'f9'
    f10       in = (SOH 'I')        label = '10'
    f11       in = (SOH 'J')      " label = '11' "
    f12       in = (SOH 'K')      " label = '12' "
    f13       in = (SOH 'L')      " label = '13' "
    f14       in = (SOH 'M')      " label = '14' "
    f15       in = (SOH 'N')      " label = '15' "
    f16       in = (SOH 'O')      " label = '16' "
    f1_s      in = (SOH '`')        label = '  sf1'
    f2_s      in = (SOH 'a')        label = '  sf2'
    f3_s      in = (SOH 'b')        label = '  sf3'
    f4_s      in = (SOH 'c')        label = '  sf4'
    f5_s      in = (SOH 'd')        label = '  sf5'
    f6_s      in = (SOH 'e')        label = '  sf6'
    f7_s      in = (SOH 'f')        label = '  sf7'
    f8_s      in = (SOH 'g')        label = '  sf8'
    f9_s      in = (SOH 'h')        label = '  sf9'
    f10_s     in = (SOH 'i')        label = '  sf10'
    f11_s     in = (SOH 'j')      " label = '  11' "
    f12_s     in = (SOH 'k')      " label = '  12' "
    f13_s     in = (SOH 'l')      " label = '  13' "
    f14_s     in = (SOH 'm')      " label = '  14' "
    f15_s     in = (SOH 'n')      " label = '  15' "
    f16_s     in = (SOH 'o')      " label = '  16' "
"
"   CDC STANDARD FUNCTION KEYS
"
    next      in = 13        label = '  RETURN'
    bkw       in = (SOH '@')        label = 'f1'
    fwd       in = (SOH 'A')        label = 'f2'
    back      in = (SOH 'B')        label = 'f3'
    help      in = (SOH 'C')        label = 'f4'
    undo      in = (SOH 'D')        label = 'f5'
    stop      in = (SOH 'E')        label = 'f6'
    bkw_s     in = (SOH '`')        label = '  sf1'
    fwd_s     in = (SOH 'a')        label = '  sf2'
    undo_s    in = (SOH 'd')        label = '  sf5'
    stop_s    in = (SOH 'e')        label = '  sf6'
"
"   TERMINAL VIDEO ATTRIBUTES
"
    alt_begin             out = (dim)      " instead of dim since protect=dim
    alt_end               out = (normal)
    low_intensity_begin   out = (dim)      " instead of dim since protect=dim
    low_intensity_end     out = (normal)
    high_intensity_begin  out = (reverse)
    high_intensity_end    out = (normal)
    blink_begin           out = (blink)
    blink_end             out = (normal)
    hidden_begin          out = ()
    hidden_end            out = ()
    inverse_begin         out = (reverse)
    inverse_end           out = (normal)
    protect_begin         out = (start_protect)
    protect_end           out = (stop_protect)
    underline_begin       out = (underline)
    underline_end         out = (normal)
"
"   LOGICAL ATTRIBUTE SPECIFICATIONS
"
    error_begin         out = (reverse)
    error_end           out = (normal)
    input_text_begin    out = (underline)
    input_text_end      out = (normal)
    italic_begin        out = (reverse)
    italic_end          out = (normal)
    message_begin       out = (reverse)
    message_end         out = (normal)
    output_text_begin   out = ()
    output_text_end     out = ()
    title_begin         out = ()
    title_end           out = ()
"
"   LINE DRAWING SPECIFICATION
"
    ld_fine_begin            out = (line_on)
    ld_fine_end              out = (line_off)
    ld_fine_horizontal       out = (graph ':')
    ld_fine_vertical         out = (graph '6')
    ld_fine_upper_left       out = (graph '2')
    ld_fine_upper_right      out = (graph '3')
    ld_fine_lower_left       out = (graph '1')
    ld_fine_lower_right      out = (graph '5')
    ld_fine_up_t             out = (up_t)
    ld_fine_down_t           out = (down_t)
    ld_fine_left_t           out = (left_t)
    ld_fine_right_t          out = (right_t)
    ld_fine_cross            out = (cross)
"
    ld_medium_begin          out = (line_on)
    ld_medium_end            out = (line_off)
    ld_medium_horizontal       out = (graph '<')
    ld_medium_vertical         out = (graph '>')
    ld_medium_upper_left       out = (graph '2')
    ld_medium_upper_right      out = (graph '3')
    ld_medium_lower_left       out = (graph '1')
    ld_medium_lower_right      out = (graph '5')
    ld_medium_up_t             out = (up_t)
    ld_medium_down_t           out = (down_t)
    ld_medium_left_t           out = (left_t)
    ld_medium_right_t          out = (right_t)
    ld_medium_cross            out = (cross)
"
    ld_bold_begin            out = (line_on)
    ld_bold_end              out = (line_off)
    ld_bold_horizontal       out = (bold_box)
    ld_bold_vertical         out = (bold_box)
    ld_bold_upper_left       out = (bold_box)
    ld_bold_upper_right      out = (bold_box)
    ld_bold_lower_left       out = (bold_box)
    ld_bold_lower_right      out = (bold_box)
    ld_bold_up_t             out = (bold_box)
    ld_bold_down_t           out = (bold_box)
    ld_bold_left_t           out = (bold_box)
    ld_bold_right_t          out = (bold_box)
    ld_bold_cross            out = (bold_box)

"   END OF TERMINAL DEFINITION FILE FOR WYSE 60 TERMINAL               "
*DECK DECK=CSM$Z19 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR ZENITH Z19 TERMINAL                          "

"   VARIABLES                                                                 "

prefix              = (1B(16) 5B(16))
end_ins_mode        = (prefix 34(16) 6C(16))
start_inverse       = (prefix 37(16) 6D(16))
stop_inverse        = (prefix 6D(16))
ansi_mode           = (esc '<')
set_block_shift_alt = (prefix '>4;6;7h')
clear_hold_screen   = (prefix '>3l')
clear_wraparound    = (prefix '?7l')
clear_shift_alt     = (prefix '>6;7l')
set_wraparound      = (prefix '?7h')

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'Z19'
communications      type  = asynch
application_string  name='insert_delete_scrolling' out='true'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (3B(16))
cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 48(16))   label='HOME'
cursor_up                inout = (prefix 41(16))
cursor_down              inout = (prefix 42(16))
cursor_left              inout = (prefix 44(16))
cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TAB STOPS                                                                 "
fixed_tab_positions positions = (1,9,17,25,33,41,49,57,65,73)

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = FALSE
function_key_leaves_mark value = 1
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = FALSE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80

"   SCREEN AND LINE MODE TRANSITION                                           "
set_screen_mode     out = (ansi_mode set_block_shift_alt  ..
 clear_hold_screen clear_wraparound)

set_line_mode       out = (clear_shift_alt set_wraparound clear_hold_screen)

"   TERMINAL CAPABILITIES                                                     "
backspace           in    = (08(16))
delete_char         inout = (prefix 50(16))         label='DC'
delete_line_bol     inout = (prefix 4D(16))         label='DL'
erase_end_of_line   inout = (prefix 30(16) 4B(16))
erase_end_of_page   inout = (prefix 4A(16))
erase_page_home     inout = (prefix 32(16) 4A(16))  label='ERASE'
insert_char         inout = (prefix 40(16))
insert_line_bol     inout = (prefix 4C(16))         label='IL'
insert_mode_begin   inout = (prefix 34(16) 68(16))  label='IMB'
insert_mode_end     inout = (prefix 34(16) 6C(16))
tab_forward         inout = (09(16))

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
output_begin        out = ()
bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (1B(16) 4F(16) 53(16))  label = 'f1'
f2        in = (1B(16) 4F(16) 54(16))  label = 'f2'
f3        in = (1B(16) 4F(16) 55(16))  label = 'f3'
f4        in = (1B(16) 4F(16) 56(16))  label = 'f4'
f5        in = (1B(16) 4F(16) 57(16))  label = 'f5'
f6        in = (1B(16) 4F(16) 50(16))  label = 'Bl'
f7        in = (1B(16) 4F(16) 51(16))  label = 'Rd'
f8        in = (1B(16) 4F(16) 52(16))  label = 'Wt'
f9        in = ()
f10       in = ()
f11       in = ()
f12       in = ()
f13       in = ()
f14       in = ()
f15       in = ()
f16       in = ()
f1_s      in = (1B(16) 4F(16) 71(16))  label = 's1'
f2_s      in = (1B(16) 4F(16) 72(16))  label = 's2'
f3_s      in = (1B(16) 4F(16) 73(16))  label = 's3'
f4_s      in = (1B(16) 4F(16) 74(16))  label = 's4'
f5_s      in = (1B(16) 4F(16) 75(16))  label = 's5'
f6_s      in = (1B(16) 4F(16) 76(16))  label = 's6'
f7_s      in = (1B(16) 4F(16) 77(16))  label = 's7'
f8_s      in = (1B(16) 4F(16) 78(16))  label = 's8'
f9_s      in = (1B(16) 4F(16) 79(16))  label = 's9'
f10_s     in = (1B(16) 4F(16) 70(16))  label = 'k0'
f11_s     in = (1B(16) 4F(16) 6E(16))  label = 'k.'
f12_s     in = (1B(16) 4F(16) 4D(16))  label = 'ke'
f13_s     in = ()
f14_s     in = ()
f15_s     in = ()
f16_s     in = ()

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = (1B(16) 4F(16) 53(16))  label = 'F1'
fwd       in = (1B(16) 4F(16) 54(16))  label = 'F2'
back      in = (1B(16) 4F(16) 55(16))  label = 'F3'
help      in = (1B(16) 4F(16) 56(16))  label = 'F4'
undo      in = (1B(16) 4F(16) 57(16))  label = 'F5'
stop      in = (1B(16) 4F(16) 50(16))  label = 'F6'
bkw_s     in = (1B(16) 4F(16) 71(16))  label = '  SF1'
fwd_s     in = (1B(16) 4F(16) 72(16))  label = '  SF2'
undo_s    in = (1B(16) 4F(16) 75(16))  label = '  SF5'
stop_s    in = (1B(16) 4F(16) 76(16))  label = '  SF6'
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_inverse)
underline_end       out = (stop_inverse)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_inverse)
input_text_end      out = (stop_inverse)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = (prefix 31(16) 30(16) 6D(16))
ld_fine_end              out = (prefix 31(16) 31(16) 6D(16))
ld_fine_horizontal       out = 61(16)
ld_fine_vertical         out = 60(16)
ld_fine_upper_left       out = 66(16)
ld_fine_upper_right      out = 63(16)
ld_fine_lower_left       out = 65(16)
ld_fine_lower_right      out = 64(16)
ld_fine_up_t             out = 73(16)
ld_fine_down_t           out = 75(16)
ld_fine_left_t           out = 76(16)
ld_fine_right_t          out = 74(16)
ld_fine_cross            out = 62(16)
ld_medium_begin          out = (prefix 31(16) 30(16) 6D(16))
ld_medium_end            out = (prefix 31(16) 31(16) 6D(16))
ld_medium_horizontal     out = 61(16)
ld_medium_vertical       out = 60(16)
ld_medium_upper_left     out = 66(16)
ld_medium_upper_right    out = 63(16)
ld_medium_lower_left     out = 65(16)
ld_medium_lower_right    out = 64(16)
ld_medium_up_t           out = 73(16)
ld_medium_down_t         out = 75(16)
ld_medium_left_t         out = 76(16)
ld_medium_right_t        out = 74(16)
ld_medium_cross          out = 62(16)
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "


"   END OF TERMINAL DEFINITION FILE FOR ZENITH Z19 TERMINAL                   "
*DECK DECK=CSM$Z29 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR ZENITH Z29 TERMINAL                          "

" Note that this definition assumes certain hardware modes will be established "
" when setting line mode at the end of a screen mode task.  The assumptions    "
" are to configure the keypad for numeric unshifted usage, to allow automatic  "
" wraparound at end of line, and to disable the 'hold screen' capability.      "
" users may prefer different settings: modify the 'set_line_mode' statement to "
" do so.  Earlier versions of this definition used the hardware reset, but had "
" the side-effect of causing some types of modems to disconnect; thus the      "
" set of specific modes.                                                       "

"   VARIABLES                                                                 "

prefix              = (esc '[')
clear_all_tabs      = (prefix '3g')
normal_attributes   = (prefix 'm')
end_ins_mode        = (prefix '4l')
start_inverse       = (prefix '7m')
stop_inverse        = normal_attributes
start_underline     = (prefix '4m')
stop_underline      = normal_attributes
start_alternate     = (prefix 31(16) 6D(16))
stop_alternate      = normal_attributes
start_dim           = (prefix '2m')
stop_dim            = normal_attributes
start_hold_screen   = (prefix '>3h')
stop_hold_screen    = (prefix '>3l')
start_block_cursor  = (prefix '>4h')
stop_block_cursor   = (prefix '>4l')
start_keypad_shift  = (prefix '>6h')
stop_keypad_shift   = (prefix '>6l')
start_keypad_alt    = (prefix '>7h')
stop_keypad_alt     = (prefix '>7l')
use_ansi_mode       = (ESC '<')
discard_at_eol      = (prefix '?7l')
wraparound_at_eol   = (prefix '?7h')


"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'Z29'
communications      type  = asynch
application_string  name  = 'vt100_scrolling'  out='true'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (';')
cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 'H')    label='HOME'
cursor_up                inout = (prefix 'A')
cursor_down              inout = (prefix 'B')
cursor_left              inout = (prefix 'D')
cursor_right             inout = (prefix 'C')

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = FALSE
function_key_leaves_mark value = 1
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = FALSE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80

"   SCREEN AND LINE MODE TRANSITION                                           "
set_screen_mode     out = (use_ansi_mode  start_block_cursor ..
 start_keypad_shift  start_keypad_alt  stop_hold_screen ..
 discard_at_eol)

set_line_mode       out = (stop_keypad_shift  stop_keypad_alt ..
 wraparound_at_eol stop_hold_screen)

"   TERMINAL CAPABILITIES                                                     "
backspace           in    = (08(16))
delete_char         inout = (prefix 'P')     label='DC'
delete_line_bol     inout = (prefix 'M')     label='DL'
erase_end_of_line   inout = (prefix '0K')
erase_end_of_page   inout = (prefix 'J')
erase_page_home     inout = (prefix '2J')    label='ERASE'
insert_char         inout = (prefix '@')
insert_line_bol     inout = (prefix 'L')     label='IL'
insert_mode_begin   inout = (prefix '4h')    label='IMB'
insert_mode_end     inout = (prefix '4l')
tab_backward        inout = (prefix 'Z')
tab_forward         inout = (09(16))
tab_clear_all       inout = (clear_all_tabs)
tab_set             inout = (esc 'H')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
output_begin        out = ()
bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (esc 'OS')     label='f1'
f2        in = (esc 'OT')     label='f2'
f3        in = (esc 'OU')     label='f3'
f4        in = (esc 'OV')     label='f4'
f5        in = (esc 'OW')     label='f5'
f6        in = (esc 'OP')     label='f6'
f7        in = (esc 'OQ')     label='f7'
f8        in = (esc 'OR')     label='f8'
f9        in = (esc 'OX')     label='f9'
f10       in = ()
f11       in = ()
f12       in = ()
f13       in = ()
f14       in = ()
f15       in = ()
f16       in = ()
f1_s      in = (esc 'Oq')     label='s1'
f2_s      in = (esc 'Or')     label='s2'
f3_s      in = (esc 'Os')     label='s3'
f4_s      in = (esc 'Ot')     label='s4'
f5_s      in = (esc 'Ou')     label='s5'
f6_s      in = (esc 'Ov')     label='s6'
f7_s      in = (esc 'Ow')     label='s7'
f8_s      in = (esc 'Ox')     label='s8'
f9_s      in = (esc 'Oy')     label='s9'
f10_s     in = (esc 'Op')     label='k0'
f11_s     in = (esc 'On')     label='k.'
f12_s     in = (esc 'OM')     label='ke'
f13_s     in = (esc 'Ol')     label='k,'
f14_s     in = (esc 'Om')     label='k-'
f15_s     in = ()
f16_s     in = ()

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13               label='RETURN'
bkw       in = (esc 'OS')     label='F1'
fwd       in = (esc 'OT')     label='F2'
back      in = (esc 'OU')     label='F3'
undo      in = (esc 'OW')     label='F5'
stop      in = (esc 'OP')     label='F6'
bkw_s     in = (esc 'Oq')     label='  SF1'
fwd_s     in = (esc 'Or')     label='  SF2'
undo_s    in = (esc 'Ou')     label='  SF5'
stop_s    in = (esc 'Ov')     label='  SF6'
help      in = (prefix '~')     label='HELP'
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_alternate)
alt_end             out = (stop_alternate)
blink_begin         out = (prefix '5m')
blink_end           out = normal_attributes
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = (prefix '10m')
ld_fine_end              out = (prefix '11m')
ld_fine_horizontal       out = 61(16)
ld_fine_vertical         out = 60(16)
ld_fine_upper_left       out = 66(16)
ld_fine_upper_right      out = 63(16)
ld_fine_lower_left       out = 65(16)
ld_fine_lower_right      out = 64(16)
ld_fine_up_t             out = 73(16)
ld_fine_down_t           out = 75(16)
ld_fine_left_t           out = 76(16)
ld_fine_right_t          out = 74(16)
ld_fine_cross            out = 62(16)
ld_medium_begin          out = (prefix '10m')
ld_medium_end            out = (prefix '11m')
ld_medium_horizontal     out = 61(16)
ld_medium_vertical       out = 60(16)
ld_medium_upper_left     out = 66(16)
ld_medium_upper_right    out = 63(16)
ld_medium_lower_left     out = 65(16)
ld_medium_lower_right    out = 64(16)
ld_medium_up_t           out = 73(16)
ld_medium_down_t         out = 75(16)
ld_medium_left_t         out = 76(16)
ld_medium_right_t        out = 74(16)
ld_medium_cross          out = 62(16)
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "


"   END OF TERMINAL DEFINITION FILE FOR ZENITH Z29 TERMINAL                   "
*DECK DECK=CSM$ZEN_Z19 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR ZENITH Z19 TERMINAL                          "

"   VARIABLES                                                                 "

prefix              = (1B(16) 5B(16))
end_ins_mode        = (prefix 34(16) 6C(16))
start_inverse       = (prefix 37(16) 6D(16))
stop_inverse        = (prefix 6D(16))
ansi_mode           = (esc '<')
set_block_shift_alt = (prefix '>4;6;7h')
clear_hold_screen   = (prefix '>3l')
clear_wraparound    = (prefix '?7l')
clear_shift_alt     = (prefix '>6;7l')
set_wraparound      = (prefix '?7h')

"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'ZEN_Z19'
communications      type  = asynch
application_string  name='insert_delete_scrolling' out='true'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (3B(16))
cursor_pos_third         out   = (48(16))

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 48(16))   label='HOME'
cursor_up                inout = (prefix 41(16))
cursor_down              inout = (prefix 42(16))
cursor_left              inout = (prefix 44(16))
cursor_right             inout = (prefix 43(16))

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TAB STOPS                                                                 "
fixed_tab_positions positions = (1,9,17,25,33,41,49,57,65,73)

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = FALSE
function_key_leaves_mark value = 1
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = FALSE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80

"   SCREEN AND LINE MODE TRANSITION                                           "

set_screen_mode     out = (ansi_mode set_block_shift_alt  ..
 clear_hold_screen clear_wraparound)

set_line_mode       out = (clear_shift_alt set_wraparound clear_hold_screen)

"   TERMINAL CAPABILITIES                                                     "
backspace           in    = (08(16))
delete_char         inout = (prefix 50(16))         label='DC'
delete_line_bol     inout = (prefix 4D(16))         label='DL'
erase_end_of_line   inout = (prefix 30(16) 4B(16))
erase_end_of_page   inout = (prefix 4A(16))
erase_page_home     inout = (prefix 32(16) 4A(16))  label='ERASE'
insert_char         inout = (prefix 40(16))
insert_line_bol     inout = (prefix 4C(16))         label='IL'
insert_mode_begin   inout = (prefix 34(16) 68(16))  label='IMB'
insert_mode_end     inout = (prefix 34(16) 6C(16))
tab_forward         inout = (09(16))

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
output_begin        out = ()
bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (1B(16) 4F(16) 53(16))  label = 'f1'
f2        in = (1B(16) 4F(16) 54(16))  label = 'f2'
f3        in = (1B(16) 4F(16) 55(16))  label = 'f3'
f4        in = (1B(16) 4F(16) 56(16))  label = 'f4'
f5        in = (1B(16) 4F(16) 57(16))  label = 'f5'
f6        in = (1B(16) 4F(16) 50(16))  label = 'Bl'
f7        in = (1B(16) 4F(16) 51(16))  label = 'Rd'
f8        in = (1B(16) 4F(16) 52(16))  label = 'Wt'
f9        in = ()
f10       in = ()
f11       in = ()
f12       in = ()
f13       in = ()
f14       in = ()
f15       in = ()
f16       in = ()
f1_s      in = (1B(16) 4F(16) 71(16))  label = 's1'
f2_s      in = (1B(16) 4F(16) 72(16))  label = 's2'
f3_s      in = (1B(16) 4F(16) 73(16))  label = 's3'
f4_s      in = (1B(16) 4F(16) 74(16))  label = 's4'
f5_s      in = (1B(16) 4F(16) 75(16))  label = 's5'
f6_s      in = (1B(16) 4F(16) 76(16))  label = 's6'
f7_s      in = (1B(16) 4F(16) 77(16))  label = 's7'
f8_s      in = (1B(16) 4F(16) 78(16))  label = 's8'
f9_s      in = (1B(16) 4F(16) 79(16))  label = 's9'
f10_s     in = (1B(16) 4F(16) 70(16))  label = 'k0'
f11_s     in = (1B(16) 4F(16) 6E(16))  label = 'k.'
f12_s     in = (1B(16) 4F(16) 4D(16))  label = 'ke'
f13_s     in = ()
f14_s     in = ()
f15_s     in = ()
f16_s     in = ()

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13            label = 'RETURN'
next_s    in = ()
bkw       in = (1B(16) 4F(16) 53(16))  label = 'F1'
fwd       in = (1B(16) 4F(16) 54(16))  label = 'F2'
back      in = (1B(16) 4F(16) 55(16))  label = 'F3'
help      in = (1B(16) 4F(16) 56(16))  label = 'F4'
undo      in = (1B(16) 4F(16) 57(16))  label = 'F5'
stop      in = (1B(16) 4F(16) 50(16))  label = 'F6'
bkw_s     in = (1B(16) 4F(16) 71(16))  label = '  SF1'
fwd_s     in = (1B(16) 4F(16) 72(16))  label = '  SF2'
undo_s    in = (1B(16) 4F(16) 75(16))  label = '  SF5'
stop_s    in = (1B(16) 4F(16) 76(16))  label = '  SF6'
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_inverse)
underline_end       out = (stop_inverse)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_inverse)
input_text_end      out = (stop_inverse)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = (prefix 31(16) 30(16) 6D(16))
ld_fine_end              out = (prefix 31(16) 31(16) 6D(16))
ld_fine_horizontal       out = 61(16)
ld_fine_vertical         out = 60(16)
ld_fine_upper_left       out = 66(16)
ld_fine_upper_right      out = 63(16)
ld_fine_lower_left       out = 65(16)
ld_fine_lower_right      out = 64(16)
ld_fine_up_t             out = 73(16)
ld_fine_down_t           out = 75(16)
ld_fine_left_t           out = 76(16)
ld_fine_right_t          out = 74(16)
ld_fine_cross            out = 62(16)
ld_medium_begin          out = (prefix 31(16) 30(16) 6D(16))
ld_medium_end            out = (prefix 31(16) 31(16) 6D(16))
ld_medium_horizontal     out = 61(16)
ld_medium_vertical       out = 60(16)
ld_medium_upper_left     out = 66(16)
ld_medium_upper_right    out = 63(16)
ld_medium_lower_left     out = 65(16)
ld_medium_lower_right    out = 64(16)
ld_medium_up_t           out = 73(16)
ld_medium_down_t         out = 75(16)
ld_medium_left_t         out = 76(16)
ld_medium_right_t        out = 74(16)
ld_medium_cross          out = 62(16)
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "


"   END OF TERMINAL DEFINITION FILE FOR ZENITH Z19 TERMINAL                   "
*DECK DECK=CSM$ZEN_Z29 EXPAND=TRUE

"   TERMINAL DEFINITION FILE FOR ZENITH Z29 TERMINAL                          "

" Note that this definition assumes certain hardware modes will be established "
" when setting line mode at the end of a screen mode task.  The assumptions    "
" are to configure the keypad for numeric unshifted usage, to allow automatic  "
" wraparound at end of line, and to disable the 'hold screen' capability.      "
" users may prefer different settings: modify the 'set_line_mode' statement to "
" do so.  Earlier versions of this definition used the hardware reset, but had "
" the side-effect of causing some types of modems to disconnect; thus the      "
" set of specific modes.                                                       "

"   VARIABLES                                                                 "

prefix              = (esc '[')
clear_all_tabs      = (prefix '3g')
normal_attributes   = (prefix 'm')
end_ins_mode        = (prefix '4l')
start_inverse       = (prefix '7m')
stop_inverse        = normal_attributes
start_underline     = (prefix '4m')
stop_underline      = normal_attributes
start_alternate     = (prefix 31(16) 6D(16))
stop_alternate      = normal_attributes
start_dim           = (prefix '2m')
stop_dim            = normal_attributes
start_hold_screen   = (prefix '>3h')
stop_hold_screen    = (prefix '>3l')
start_block_cursor  = (prefix '>4h')
stop_block_cursor   = (prefix '>4l')
start_keypad_shift  = (prefix '>6h')
stop_keypad_shift   = (prefix '>6l')
start_keypad_alt    = (prefix '>7h')
stop_keypad_alt     = (prefix '>7l')
use_ansi_mode       = (ESC '<')
discard_at_eol      = (prefix '?7l')
wraparound_at_eol   = (prefix '?7h')


"   MODEL NAME AND COMMUNICATION TYPE                                         "
model_name          value = 'ZEN_Z29'
communications      type  = asynch
application_string  name  = 'vt100_scrolling'  out='true'

"   END OF INFORMATION SPECIFICATION                                          "
end_of_information  in    = (0)

"   CURSOR POSITIONING INFORMATION                                            "
cursor_pos_encoding      bias  = (1)   type = ansi_cursor
cursor_pos_column_first  value = FALSE
cursor_pos_column_length value = (0)
cursor_pos_row_length    value = (0)
cursor_pos_begin         out   = (prefix)
cursor_pos_second        out   = (';')
cursor_pos_third         out   = ('H')

"   CURSOR MOVEMENT INFORMATION                                               "
cursor_home              inout = (prefix 'H')    label='HOME'
cursor_up                inout = (prefix 'A')
cursor_down              inout = (prefix 'B')
cursor_left              inout = (prefix 'D')
cursor_right             inout = (prefix 'C')

"   CURSOR BEHAVIOR (for cursor movement keys)                                "
move_past_right          type  = stop_next
move_past_left           type  = stop_next
move_past_top            type  = stop_next
move_past_bottom         type  = stop_next

"   CURSOR BEHAVIOR (for character keys)                                      "
char_past_right          type  = stop_next
char_past_left           type  = stop_next
char_past_last_position  type  = stop_next

"   TERMINAL ATTRIBUTES                                                       "
clears_when_change_size  value = FALSE
function_key_leaves_mark value = 1
has_hidden               value = FALSE
has_protect              value = FALSE
home_at_top              value = TRUE
multiple_sizes           value = FALSE
tabs_to_home             value = FALSE
tabs_to_tab_stops        value = TRUE
tabs_to_unprotected      value = FALSE

"   SCREEN SIZES                                                              "
set_size       rows = 24 columns = 80

"   SCREEN AND LINE MODE TRANSITION                                           "
set_screen_mode     out = (use_ansi_mode  start_block_cursor ..
 start_keypad_shift  start_keypad_alt  stop_hold_screen ..
 discard_at_eol)

set_line_mode       out = (stop_keypad_shift  stop_keypad_alt ..
 wraparound_at_eol stop_hold_screen)

"   TERMINAL CAPABILITIES                                                     "
backspace           in    = (08(16))
delete_char         inout = (prefix 'P')     label='DC'
delete_line_bol     inout = (prefix 'M')     label='DL'
erase_end_of_line   inout = (prefix '0K')
erase_end_of_page   inout = (prefix 'J')
erase_page_home     inout = (prefix '2J')    label='ERASE'
insert_char         inout = (prefix '@')
insert_line_bol     inout = (prefix 'L')     label='IL'
insert_mode_begin   inout = (prefix '4h')    label='IMB'
insert_mode_end     inout = (prefix '4l')
tab_backward        inout = (prefix 'Z')
tab_forward         inout = (09(16))
tab_clear_all       inout = (clear_all_tabs)
tab_set             inout = (esc 'H')

"   MISCELLANEOUS TERMINAL SEQUENCES                                          "
output_begin        out = ()
bell_nak            out = (bel)

"   PROGRAMMABLE FUNCTION KEY INPUT INFORMATION                               "
f1        in = (esc 'OS')     label='f1'
f2        in = (esc 'OT')     label='f2'
f3        in = (esc 'OU')     label='f3'
f4        in = (esc 'OV')     label='f4'
f5        in = (esc 'OW')     label='f5'
f6        in = (esc 'OP')     label='f6'
f7        in = (esc 'OQ')     label='f7'
f8        in = (esc 'OR')     label='f8'
f9        in = (esc 'OX')     label='f9'
f10       in = ()
f11       in = ()
f12       in = ()
f13       in = ()
f14       in = ()
f15       in = ()
f16       in = ()
f1_s      in = (esc 'Oq')     label='s1'
f2_s      in = (esc 'Or')     label='s2'
f3_s      in = (esc 'Os')     label='s3'
f4_s      in = (esc 'Ot')     label='s4'
f5_s      in = (esc 'Ou')     label='s5'
f6_s      in = (esc 'Ov')     label='s6'
f7_s      in = (esc 'Ow')     label='s7'
f8_s      in = (esc 'Ox')     label='s8'
f9_s      in = (esc 'Oy')     label='s9'
f10_s     in = (esc 'Op')     label='k0'
f11_s     in = (esc 'On')     label='k.'
f12_s     in = (esc 'OM')     label='ke'
f13_s     in = (esc 'Ol')     label='k,'
f14_s     in = (esc 'Om')     label='k-'
f15_s     in = ()
f16_s     in = ()

"   CDC STANDARD FUNCTION KEY INPUT INFORMATION                               "
next      in = 13               label='RETURN'
bkw       in = (esc 'OS')     label='F1'
fwd       in = (esc 'OT')     label='F2'
back      in = (esc 'OU')     label='F3'
undo      in = (esc 'OW')     label='F5'
stop      in = (esc 'OP')     label='F6'
bkw_s     in = (esc 'Oq')     label='  SF1'
fwd_s     in = (esc 'Or')     label='  SF2'
undo_s    in = (esc 'Ou')     label='  SF5'
stop_s    in = (esc 'Ov')     label='  SF6'
help      in = (prefix '~')     label='HELP'
down      in = ()
down_s    in = ()
up        in = ()
up_s      in = ()
edit      in = ()
edit_s    in = ()
data      in = ()
data_s    in = ()

"   TERMINAL VIDEO ATTRIBUTES                                                 "
alt_begin           out = (start_alternate)
alt_end             out = (stop_alternate)
blink_begin         out = (prefix '5m')
blink_end           out = normal_attributes
inverse_begin       out = (start_inverse)
inverse_end         out = (stop_inverse)
underline_begin     out = (start_underline)
underline_end       out = (stop_underline)

"   LOGICAL ATTRIBUTE SPECIFICATIONS                                          "
error_begin         out = (start_inverse)
error_end           out = (stop_inverse)
input_text_begin    out = (start_underline)
input_text_end      out = (stop_underline)
italic_begin        out = (start_inverse)
italic_end          out = (stop_inverse)

"   LINE DRAWING CHARACTER SPECIFICATION                                      "
ld_fine_begin            out = (prefix '10m')
ld_fine_end              out = (prefix '11m')
ld_fine_horizontal       out = 61(16)
ld_fine_vertical         out = 60(16)
ld_fine_upper_left       out = 66(16)
ld_fine_upper_right      out = 63(16)
ld_fine_lower_left       out = 65(16)
ld_fine_lower_right      out = 64(16)
ld_fine_up_t             out = 73(16)
ld_fine_down_t           out = 75(16)
ld_fine_left_t           out = 76(16)
ld_fine_right_t          out = 74(16)
ld_fine_cross            out = 62(16)
ld_medium_begin          out = (prefix '10m')
ld_medium_end            out = (prefix '11m')
ld_medium_horizontal     out = 61(16)
ld_medium_vertical       out = 60(16)
ld_medium_upper_left     out = 66(16)
ld_medium_upper_right    out = 63(16)
ld_medium_lower_left     out = 65(16)
ld_medium_lower_right    out = 64(16)
ld_medium_up_t           out = 73(16)
ld_medium_down_t         out = 75(16)
ld_medium_left_t         out = 76(16)
ld_medium_right_t        out = 74(16)
ld_medium_cross          out = 62(16)
ld_bold_begin            out = (start_inverse)
ld_bold_end              out = (stop_inverse)
ld_bold_horizontal       out = (' ')
ld_bold_vertical         out = (' ')
ld_bold_upper_left       out = (' ')
ld_bold_upper_right      out = (' ')
ld_bold_lower_left       out = (' ')
ld_bold_lower_right      out = (' ')
ld_bold_up_t             out = (' ')
ld_bold_down_t           out = (' ')
ld_bold_left_t           out = (' ')
ld_bold_right_t          out = (' ')
ld_bold_cross            out = (' ')

"   DEFAULT KEY DEFINITIONS FOR THE FULL SCREEN EDITOR                        "


"   END OF TERMINAL DEFINITION FILE FOR ZENITH Z29 TERMINAL                   "
*DECK DECK=CSP$ACCEPT_INPUT EXPAND=FALSE
PROCEDURE [XREF] csp$accept_input
      (VAR control: cst$control;
       VAR x_position: cst$x_position;
       VAR y_position: cst$y_position;
       VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cse$condition_codes
*copyc cst$control
*copyc cst$x_position
*copyc cst$y_position
*copyc ost$status
?? POP ??

*DECK DECK=CSP$ACKNOWLEDGE EXPAND=FALSE

  PROCEDURE [XREF] csp$acknowledge (acknowledge_type:
    cst$audible_acknowledgement;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$audible_acknowledgement
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$ALLOCATE_FIELD EXPAND=FALSE

  PROCEDURE [XREF] csp$allocate_field (field_attributes: cst$field_attributes;
    VAR field_number: cst$field_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_attributes
*copyc cst$field_number
*copyc ost$status
?? POP ??
*DECK DECK=CSP$CHANGE_BACKGROUND_COLOR EXPAND=FALSE

  PROCEDURE [XREF] csp$change_background_color (field_number: cst$field_number;
        color_index: cst$color_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_number
*copyc cst$color_index
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CHANGE_CAPABILITY_LEVEL EXPAND=FALSE

  PROCEDURE [XREF] csp$change_capability_level (capability_level:
    cst$capability_level;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$capability_level
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CHANGE_CHANGED_TEXT_MODE EXPAND=FALSE

  PROCEDURE [XREF] csp$change_changed_text_mode (change_indicator: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CHANGE_CURSOR_POSITION EXPAND=FALSE

  PROCEDURE [XREF] csp$change_cursor_position (field_number: cst$field_number;
        cursor_character_position: cst$character_position;
        cursor_line_number: cst$line_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_number
*copyc cst$character_position
*copyc cst$line_number
*copyc ost$status
*copyc cse$condition_codes
?? POP ??

*DECK DECK=CSP$CHANGE_DEVICE_DIMENSIONS EXPAND=FALSE

  PROCEDURE [XREF] csp$change_device_dimensions (number_of_characters:
    cst$visible_character_position;
        number_of_lines: cst$line_number;
    VAR dimensions_accepted: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$visible_character_position
*copyc cst$line_number
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CHANGE_FIELD_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] csp$change_field_attributes (field_number: cst$field_number;
        field_attributes: cst$field_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_attributes
*copyc cst$field_number
*copyc ost$status
?? POP ??
*DECK DECK=CSP$CHANGE_FIELD_BOUNDARIES EXPAND=FALSE

  PROCEDURE [XREF] csp$change_field_boundaries
    (    fixed_boundaries: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CSP$CHANGE_FIELD_DIRECTION EXPAND=FALSE

  PROCEDURE [XREF] csp$change_field_direction
    (    field_number: cst$field_number;
         display_direction: cst$direction_index;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cst$field_number
*copyc cst$direction_index
?? POP ??
*DECK DECK=CSP$CHANGE_FOREGROUND_COLOR EXPAND=FALSE

  PROCEDURE [XREF] csp$change_foreground_color (field_number: cst$field_number;
        color_index: cst$color_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_number
*copyc cst$color_index
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CHANGE_GRAPHIC_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] csp$change_graphic_attributes (graphic_identifier:
    cst$graphic_identifier;
        attribute_set: cst$attribute_set;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$graphic_identifier
*copyc cst$attribute_set
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CHANGE_INPUT_TIMEOUT EXPAND=FALSE

  PROCEDURE [XREF] csp$change_input_timeout (timeout: cst$input_timeout;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$input_timeout
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CHANGE_INTERACTION_STYLE EXPAND=FALSE

  PROCEDURE [XREF] csp$change_interaction_style
    (    file_identifier: amt$file_identifier;
         interaction_style: cst$interaction_style;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc cst$interaction_style
*copyc ost$status
?? POP ??

*DECK DECK=CSP$CHANGE_IO_POSITION EXPAND=FALSE

  PROCEDURE [XREF] csp$change_io_position (field_number: cst$field_number;
        line_number: cst$line_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_number
*copyc cst$line_number
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CHANGE_LINE_COLOR EXPAND=FALSE

  PROCEDURE [XREF] csp$change_line_color (color_index: cst$color_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$color_index
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CHANGE_LINE_WIDTH EXPAND=FALSE

  PROCEDURE [XREF] csp$change_line_width (line_width: cst$line_width;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$line_width
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CHANGE_LOGICAL_HIGHLIGHTING EXPAND=FALSE

  PROCEDURE [XREF] csp$change_logical_highlighting (field_number:
    cst$field_number;
        highlighting_style: cst$logical_highlighting_style;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_number
*copyc cst$logical_highlighting_style
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CHANGE_MENU_ITEM_STRINGS EXPAND=FALSE

  PROCEDURE [XREF] csp$change_menu_item_strings
    (    new_menu_item_strings: ^array [1 .. * {csc$max_menu_items}] OF
               cst$menu_item_string;
         menu_list: cst$menu_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cse$condition_codes
*copyc cst$menu_item_string
*copyc cst$menu_list
*copyc ost$status
?? POP ??
*DECK DECK=CSP$CHANGE_MODEL_NAME EXPAND=FALSE

  PROCEDURE [XREF] csp$change_model_name (new_model_name: cst$model_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$model_name
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CHANGE_MULTIPLE_SCREENS EXPAND=FALSE

  PROCEDURE [XREF] csp$change_multiple_screens
    (    multiple_screens_allowed: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CSP$CHANGE_PAGE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] csp$change_page_attributes
    (    page_attributes: cst$page_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$page_attributes
*copyc ost$status
?? POP ??
*DECK DECK=CSP$CHANGE_PAGE_COLOR EXPAND=FALSE

  PROCEDURE [XREF] csp$change_page_color (color_index: cst$color_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$color_index
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CHANGE_PAGE_TABS EXPAND=FALSE

  PROCEDURE [XREF] csp$change_page_tabs (tab_array: cst$tab_positions;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$tab_positions
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CHANGE_PARTIAL_SCREEN EXPAND=FALSE

  PROCEDURE [XREF] csp$change_partial_screen
    (    file_identifier: amt$file_identifier;
         interaction_style: cst$interaction_style;
         rows: 0 .. csc$max_y_position;
     VAR old_interaction_style: {input,output} cst$interaction_style;
     VAR reserve: cst$lines_used;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cse$condition_codes
*copyc cst$interaction_style
*copyc cst$lines_used
*copyc cst$y_position
*copyc ost$status
?? POP ??
*DECK DECK=CSP$CHANGE_PHYS_HIGHLIGHTING EXPAND=FALSE

  PROCEDURE [XREF] csp$change_phys_highlighting (field_number: cst$field_number;
        highlighting_style: cst$phys_highlighting_style;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_number
*copyc cst$phys_highlighting_style
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CHANGE_SCREEN_IDENTIFIER EXPAND=FALSE

  PROCEDURE [XREF] csp$change_screen_identifier
    (    new_file_id: amt$file_identifier;
     VAR old_file_id: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=CSP$CHANGE_TEXT_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] csp$change_text_attributes (field_number: cst$field_number;
        attribute_set: cst$attribute_set;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_number
*copyc cst$attribute_set
*copyc ost$status
*copyc cse$condition_codes
 ?? POP ??
*DECK DECK=CSP$CHANGE_WORKSPACE_ATTRIBUTES EXPAND=FALSE
 PROCEDURE [XREF] csp$change_workspace_attributes
      (    x_position: cst$x_position;
           y_position: cst$y_position;
           width: cst$width;
           height: cst$height;
           attribute: cst$attribute;
       VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cse$condition_codes
*copyc cst$attribute
*copyc cst$height
*copyc cst$width
*copyc cst$x_position
*copyc cst$y_position
*copyc ost$status
?? POP ??

*DECK DECK=CSP$CHANGE_WORKSPACE_TEXT EXPAND=FALSE
 PROCEDURE [XREF] csp$change_workspace_text
      (    x_position: cst$x_position;
           y_position: cst$y_position;
           text: cst$string;
           attribute: cst$attribute;
       VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cse$condition_codes
*copyc cst$attribute
*copyc cst$string
*copyc cst$x_position
*copyc cst$y_position
*copyc ost$status
?? POP ??

*DECK DECK=CSP$CLASSIFY_FIELD_EVENT EXPAND=FALSE
PROCEDURE [XREF] csp$classify_field_event (field_number: cst$field_number;
  VAR item_number: cst$menu_item_number; VAR status: ost$status);
*copyc cst$field_number
*copyc cst$menu_item_number
*copyc ost$status
*DECK DECK=CSP$CLEAR_FIELD EXPAND=FALSE

  PROCEDURE [XREF] csp$clear_field (field_number: cst$field_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_number
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CLEAR_PAGE EXPAND=FALSE

  PROCEDURE [XREF] csp$clear_page (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CLEAR_PAGE_TABS EXPAND=FALSE

  PROCEDURE [XREF] csp$clear_page_tabs (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$CLEAR_SCREEN EXPAND=FALSE

  PROCEDURE [XREF] csp$clear_screen (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CSP$CLEAR_WORKSPACE_AREA EXPAND=FALSE
 PROCEDURE [XREF] csp$clear_workspace_area
      (    x_position: cst$x_position;
           y_position: cst$y_position;
           width: cst$width;
           height: cst$height;
           attribute: cst$attribute;
       VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cse$condition_codes
*copyc cst$attribute
*copyc cst$height
*copyc cst$width
*copyc cst$x_position
*copyc cst$y_position
*copyc ost$status
?? POP ??

*DECK DECK=CSP$CLOSE_WORKSTATION EXPAND=FALSE
 PROCEDURE [XREF] csp$close_workstation
      (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cse$condition_codes
*copyc ost$status
?? POP ??

*DECK DECK=CSP$CREATE_FIELD EXPAND=FALSE

  PROCEDURE [XREF] csp$create_field (x_position: cst$x_position;
        y_position: cst$y_position;
        visible_characters: cst$visible_character_position;
        visible_lines: cst$line_number;
        characters: cst$character_position;
        lines: cst$line_number;
        input: boolean;
        output: boolean;
        justification: cst$field_justification;
        boundary_processing: cst$boundary_processing;
    VAR field_number: cst$field_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$x_position
*copyc cst$y_position
*copyc cst$visible_character_position
*copyc cst$line_number
*copyc cst$character_position
*copyc cst$field_justification
*copyc cst$boundary_processing
*copyc cst$field_number
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$DELETE_FIELD EXPAND=FALSE

  PROCEDURE [XREF] csp$delete_field (field_number: cst$field_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_number
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$DELETE_GRAPHIC EXPAND=FALSE

  PROCEDURE [XREF] csp$delete_graphic (graphic_identifier:
    cst$graphic_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$graphic_identifier
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$DISABLE_MENU_ITEM EXPAND=FALSE
PROCEDURE [XREF] csp$disable_menu_item (
  item_number: cst$menu_item_number;
  VAR status: ost$status);
*copyc cst$menu_item_number
*copyc ost$status
*DECK DECK=CSP$DISABLE_PAGE EXPAND=FALSE
  PROCEDURE [XREF] csp$disable_page (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$DISPLAY_MENU EXPAND=FALSE
PROCEDURE [XREF] csp$display_menu(menu_rows: cst$number_of_menu_rows;
        reserve_lines: cst$lines_used;
    VAR lines_used: cst$lines_used;
    VAR status: ost$status);
*copyc cst$number_of_menu_rows
*copyc cst$lines_used
*copyc ost$status
*DECK DECK=CSP$DISPLAY_WORKSPACE EXPAND=FALSE
 PROCEDURE [XREF] csp$display_workspace
      (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cse$condition_codes
*copyc ost$status
?? POP ??

*DECK DECK=CSP$DRAW_LINES EXPAND=FALSE
 PROCEDURE [XREF] csp$draw_lines
      (    xy_coordinates: cst$xy_coordinates;
           attribute: cst$attribute;
       VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cse$condition_codes
*copyc cst$attribute
*copyc cst$xy_coordinates
*copyc ost$status
?? POP ??

*DECK DECK=CSP$ENABLE_MENU_ITEM EXPAND=FALSE
PROCEDURE [XREF] csp$enable_menu_item (
  item_number: cst$menu_item_number;
  VAR status: ost$status);
*copyc cst$menu_item_number
*copyc ost$status
*DECK DECK=CSP$ENABLE_PAGE EXPAND=FALSE
  PROCEDURE [XREF] csp$enable_page (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$FLUSH_EVENTS EXPAND=FALSE

  PROCEDURE [XREF] csp$flush_events (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$GET_APPLICATION_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] csp$get_application_parameters
    (    application_name: cst$application_name;
         parameter_reset: boolean;
     VAR text: cst$string;
     VAR end_of_text: boolean;
     VAR length: 0 .. csc$max_string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$application_name
*copyc cst$string
*copyc csc$max_string
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$GET_CHANGED_TEXT EXPAND=FALSE
 PROCEDURE [XREF] csp$get_changed_text
      (    p_change_container: ^SEQ (*);
       VAR p_changed_text: {output} ^SEQ (*);
       VAR more_changes: boolean;
       VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cse$condition_codes
*copyc cst$text_change_description
*copyc ost$status
?? POP ??

*DECK DECK=CSP$GET_DEVICE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] csp$get_device_attributes
    (VAR device_attributes: cst$device_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$device_attributes
*copyc ost$status
?? POP ??
*DECK DECK=CSP$GET_DEVICE_CHARACTERISTICS EXPAND=FALSE

  PROCEDURE [XREF] csp$get_device_characteristics (VAR terminal_characteristics:
    cst$terminal_characteristics;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$terminal_characteristics
*copyc ost$status
*copyc cse$condition_codes
?? POP ??

*DECK DECK=CSP$GET_DEVICE_DIMENSIONS EXPAND=FALSE

  PROCEDURE [XREF] csp$get_device_dimensions (VAR number_of_characters:
    cst$visible_character_position;
    VAR number_of_lines: cst$line_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$visible_character_position
*copyc cst$line_number
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$GET_DEV_REVERSE_ATTR EXPAND=FALSE

  PROCEDURE [XREF] csp$get_dev_reverse_attr
    (VAR reversed_screen_mode: boolean;
     VAR reversed_field_capability: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=CSP$GET_EVENT EXPAND=FALSE

  PROCEDURE [XREF] csp$get_event (VAR event_identifier: cst$event_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$event_identifier
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$GET_EVENT_LABEL EXPAND=FALSE

  PROCEDURE [XREF] csp$get_event_label (event_identifier: cst$event_identifier;
    VAR label: cst$string;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$event_identifier
*copyc cst$string
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$GET_EVENT_MAPPING EXPAND=FALSE

  PROCEDURE [XREF] csp$get_event_mapping (
        standard_function: cst$standard_functions;
    VAR application_function: cst$application_functions;
    VAR mapped: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$standard_functions
*copyc cst$application_functions
*copyc ost$status
?? POP ??

*DECK DECK=CSP$GET_EVENT_NAME EXPAND=FALSE


  PROCEDURE [XREF] csp$get_event_name
    (    event_identifier: cst$event_name_identifier;
     VAR name: ost$name;
     VAR length: 0 .. osc$max_name_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$event_name_identifier
*copyc ost$name
*copyc ost$status
*copyc cse$condition_codes
?? POP ??

*DECK DECK=CSP$GET_FIELD_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] csp$get_field_attributes (field_number: cst$field_number;
    VAR field_attributes: cst$field_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_attributes
*copyc cst$field_number
*copyc ost$status
?? POP ??
*DECK DECK=CSP$GET_FIELD_DIRECTION EXPAND=FALSE

  PROCEDURE [XREF] csp$get_field_direction
    (    field_number: cst$field_number;
     VAR display_direction: cst$direction_index;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cst$field_number
*copyc cst$direction_index
?? POP ??
*DECK DECK=CSP$GET_IO_POSITION EXPAND=FALSE

  PROCEDURE [XREF] csp$get_io_position (VAR field_number: cst$field_number;
    VAR line_number: cst$line_number;
    VAR end_of_text: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_number
*copyc cst$line_number
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$GET_MENU_ITEM_STRING EXPAND=FALSE

  PROCEDURE [XREF] csp$get_menu_item_string
    (    menu_item: cst$menu_item_number;
     VAR menu_string: ^clt$command_line;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_line
*copyc cse$condition_codes
*copyc cst$menu_item_number
*copyc ost$status
?? POP ??

*DECK DECK=CSP$GET_MENU_STRINGS EXPAND=FALSE

  PROCEDURE [XREF] csp$get_menu_strings
    (    menu_strings: ^cst$menu_strings;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cse$condition_codes
*copyc cst$menu_strings
*copyc ost$status
?? POP ??
*DECK DECK=CSP$GET_NEXT_APPLICATION_PARAM EXPAND=FALSE

  PROCEDURE [XREF] csp$get_next_application_param (reset_to_beginning: boolean;
    VAR application_name: cst$application_name;
    VAR text: cst$string;
    VAR end_of_text: boolean;
    VAR length: 0 .. csc$max_string;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$application_name
*copyc cst$string
*copyc ost$status
?? POP ??
*DECK DECK=CSP$GET_PAGE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] csp$get_page_attributes
    (VAR page_attributes: cst$page_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$page_attributes
*copyc ost$status
?? POP ??
*DECK DECK=CSP$GET_SCREEN_IDENTIFIER EXPAND=FALSE

  PROCEDURE [XREF] csp$get_screen_identifier
    (VAR old_file_id: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=CSP$GET_TEXT EXPAND=FALSE

  PROCEDURE [XREF] csp$get_text (VAR text: cst$data_string;
    VAR length: cst$data_string_length;
    VAR end_of_line: boolean;
    VAR end_of_text: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$data_string
*copyc cst$data_string_length
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$GET_WORKSPACE_TEXT EXPAND=FALSE
 PROCEDURE [XREF] csp$get_workspace_text
      (    x_position: cst$x_position;
           y_position: cst$y_position;
       VAR text: cst$string;
       VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cse$condition_codes
*copyc cst$string
*copyc cst$x_position
*copyc cst$y_position
*copyc ost$status
?? POP ??

*DECK DECK=CSP$MARK EXPAND=FALSE

  PROCEDURE [XREF] csp$mark (field_number: cst$field_number;
        start_character_position: cst$character_position;
        start_line_number: cst$line_number;
        end_character_position: cst$character_position;
        end_line_number: cst$line_number;
        marking_type: cst$marking_type;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_number
*copyc cst$character_position
*copyc cst$line_number
*copyc cst$marking_type
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$MARK_MENU_ITEM EXPAND=FALSE
PROCEDURE [XREF] csp$mark_menu_item (
  item_number: cst$menu_item_number;
  VAR status: ost$status);
*copyc cst$menu_item_number
*copyc ost$status
*DECK DECK=CSP$OPEN_WORKSPACE EXPAND=FALSE

*DECK DECK=CSP$OPEN_WORKSTATION EXPAND=FALSE
 PROCEDURE [XREF] csp$open_workstation
      (    width: cst$width;
           height: cst$height;
           attribute: cst$attribute;
       VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cse$condition_codes
*copyc cst$attribute
*copyc cst$height
*copyc cst$width
*copyc ost$status
?? POP ??

*DECK DECK=CSP$POLY_HV_LINE EXPAND=FALSE

  PROCEDURE [XREF] csp$poly_hv_line (xy_coordinates: cst$xy_coordinates;
    VAR graphic_identifier: cst$graphic_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$xy_coordinates
*copyc cst$graphic_identifier
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$POLY_INTERSECT EXPAND=FALSE

  PROCEDURE [XREF] csp$poly_intersect (graphic_identifier:
    cst$graphic_identifier;
        xy_coordinates: cst$xy_coordinates;
        intersection_types: cst$intersection_types;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$graphic_identifier
*copyc cst$xy_coordinates
*copyc cst$intersection_types
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$POP_PAGE EXPAND=FALSE

  PROCEDURE [XREF] csp$pop_page (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$POSITION_CURSOR EXPAND=FALSE

  PROCEDURE [XREF] csp$position_cursor (field_number: cst$field_number;
        cursor_character_position: cst$character_position;
        cursor_line_number: cst$line_number;
    VAR left_character_position: cst$character_position;
    VAR upper_line_number: cst$line_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_number
*copyc cst$character_position
*copyc cst$line_number
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$POSITION_FIELD_DATA EXPAND=FALSE

  PROCEDURE [XREF] csp$position_field_data (field_number: cst$field_number;
        character_number: cst$character_position;
        line_number: cst$line_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_number
*copyc cst$character_position
*copyc cst$line_number
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$PUSH_PAGE EXPAND=FALSE

  PROCEDURE [XREF] csp$push_page (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$PUT_TEXT EXPAND=FALSE

  PROCEDURE [XREF] csp$put_text (text: ^cst$data_string;
        end_of_line: boolean;
    VAR end_of_text: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$data_string
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$REPOSITION_FIELD EXPAND=FALSE

  PROCEDURE [XREF] csp$reposition_field (field_number: cst$field_number;
        x_position: cst$x_position;
        y_position: cst$y_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_number
*copyc cst$x_position
*copyc cst$y_position
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$RESIZE_FIELD EXPAND=FALSE

  PROCEDURE [XREF] csp$resize_field (field_number: cst$field_number;
        visible_characters: cst$visible_character_position;
        visible_lines: cst$line_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_number
*copyc cst$visible_character_position
*copyc cst$line_number
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$SEND_LINE_INITIALIZATION EXPAND=FALSE

  PROCEDURE [XREF] csp$send_line_initialization (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$SEND_SCREEN_INITIALIZATION EXPAND=FALSE

  PROCEDURE [XREF] csp$send_screen_initialization (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$SET_MENU EXPAND=FALSE
PROCEDURE [XREF] csp$set_menu (menu_classes: cst$menu_class;
     menu_list: cst$menu_list; VAR status: ost$status);
*copyc cst$menu_class
*copyc cst$menu_list
*copyc ost$status
*DECK DECK=CSP$SET_MENU_STRINGS EXPAND=FALSE

  PROCEDURE [XREF] csp$set_menu_strings
    (    menu_strings: ^cst$menu_strings;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cse$condition_codes
*copyc cst$menu_strings
*copyc ost$status
?? POP ??
*DECK DECK=CSP$SET_STANDARD_MENU EXPAND=FALSE

  PROCEDURE [XREF] csp$set_standard_menu (menu_classes: cst$menu_class;
        menu_list: cst$menu_list;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$menu_class
*copyc cst$menu_list
*copyc ost$status
?? POP ??

*DECK DECK=CSP$SET_WORKSPACE_CURSOR EXPAND=FALSE
 PROCEDURE [XREF] csp$set_workspace_cursor
      (    x_position: cst$x_position;
           y_position: cst$y_position;
       VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc cse$condition_codes
*copyc cst$x_position
*copyc cst$y_position
*copyc ost$status
?? POP ??

*DECK DECK=CSP$SHIFT_FIELDS EXPAND=FALSE

  PROCEDURE [XREF] csp$shift_fields (start_field: cst$field_number;
        end_field: cst$field_number;
        offset: cst$shift_field_offset;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_number
*copyc cst$shift_field_offset
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$SHIFT_LINES EXPAND=FALSE

  PROCEDURE [XREF] csp$shift_lines (field_number: cst$field_number;
        start_line: cst$line_number;
        end_line: cst$line_number;
        offset: cst$shift_line_offset;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_number
*copyc cst$line_number
*copyc cst$shift_line_offset
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CSP$TOGGLE_LABEL EXPAND=FALSE
PROCEDURE [XREF] csp$toggle_label (
  item_number: cst$menu_item_number;
  VAR status: ost$status);
*copyc cst$menu_item_number
*copyc ost$status
*DECK DECK=CSP$UNMARK_MENU_ITEM EXPAND=FALSE
PROCEDURE [XREF] csp$unmark_menu_item (
  item_number: cst$menu_item_number;
  VAR status: ost$status);
*copyc cst$menu_item_number
*copyc ost$status
*DECK DECK=CSP$UPDATE_DEVICE EXPAND=FALSE

  PROCEDURE [XREF] csp$update_device (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cse$condition_codes
?? POP ??
*DECK DECK=CST$APPLICATION_FUNCTIONS EXPAND=FALSE
  CONST
    csc$max_fkeys = 16;

  TYPE
    cst$application_functions = (csc$f1, csc$sf1, csc$f2, csc$sf2, csc$f3,
      csc$sf3, csc$f4, csc$sf4, csc$f5, csc$sf5, csc$f6, csc$sf6, csc$f7,
      csc$sf7, csc$f8, csc$sf8, csc$f9, csc$sf9, csc$f10, csc$sf10, csc$f11,
      csc$sf11, csc$f12, csc$sf12, csc$f13, csc$sf13, csc$f14, csc$sf14,
      csc$f15, csc$sf15, csc$f16, csc$sf16);

*DECK DECK=CST$APPLICATION_NAME EXPAND=FALSE

  TYPE
    cst$application_name = string (* <= csc$max_name);

?? PUSH (LISTEXT := ON) ??
*copyc csc$max_name
?? POP ??
*DECK DECK=CST$AREA_CHANGES EXPAND=FALSE

TYPE
  cst$area_changes = set of 1 .. csc$max_x_position;

*copyc csc$max_x_position
*DECK DECK=CST$ATTRIBUTE EXPAND=FALSE

TYPE
  cst$attribute = set of cst$attribute_limits;

*copyc cst$attribute_limits
*DECK DECK=CST$ATTRIBUTE_LIMITS EXPAND=FALSE

TYPE
  cst$attribute_limits = 0 .. csc$max_attribute;

*copyc csc$max_attribute
*DECK DECK=CST$ATTRIBUTE_SET EXPAND=TRUE

  TYPE
    cst$attribute_set = set of (csc$protected, csc$hidden, csc$p_inverse,
          csc$p_alternate_intensity, csc$p_blink, csc$p_underline,
          csc$l_normal, csc$l_italic, csc$l_title, csc$l_input, csc$l_error,
          csc$l_message, csc$f_black, csc$f_white, csc$f_red, csc$f_green,
          csc$f_blue, csc$f_yellow, csc$f_cyan, csc$f_magenta, csc$b_black,
          csc$b_white, csc$b_red, csc$b_green, csc$b_blue, csc$b_yellow,
          csc$b_cyan, csc$b_magenta, csc$line_fine, csc$line_medium,
          csc$line_bold);

*DECK DECK=CST$AUDIBLE_ACKNOWLEDGEMENT EXPAND=FALSE

  TYPE
    cst$audible_acknowledgement = (csc$positive_acknowledgement,
      csc$negative_acknowledgement);

*DECK DECK=CST$BOUNDARY_ATTRIBUTES EXPAND=FALSE

  TYPE
    cst$boundary_attributes = record
      clipping: cst$clipping,
      justification: cst$field_justification,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cst$clipping
*copyc cst$field_justification
?? POP ??
*DECK DECK=CST$BOUNDARY_PROCESSING EXPAND=FALSE

  TYPE
    cst$boundary_processing = record
      case boundary_type: (csc$clip, csc$wrap) of
      = csc$clip =
        ,
      = csc$wrap =
        wrap_type: (csc$character_wrap, csc$word_wrap),
      casend,
    recend;

*DECK DECK=CST$CAPABILITY_LEVEL EXPAND=FALSE
*copyc cst$interaction_style

  TYPE
    cst$capability_level = cst$interaction_style;

*DECK DECK=CST$CHARACTER_POSITION EXPAND=FALSE

*copyc csc$max_character_position

  TYPE
    cst$character_position = 1 .. csc$max_character_position;

*DECK DECK=CST$CLASS_NAME EXPAND=FALSE
*copyc ost$name
  TYPE
    cst$class_name = ost$name;
*DECK DECK=CST$CLIPPING EXPAND=FALSE

{ CSTFCLP  cst$clipping }

  TYPE
    cst$clipping = record
      word_flag: boolean,
      wrap_flag: boolean,
    recend;

*DECK DECK=CST$COLOR_INDEX EXPAND=FALSE

  TYPE
    cst$color_index = (csc$black, csc$blue, csc$green, csc$magenta, csc$red,
      csc$cyan, csc$yellow, csc$white);

*DECK DECK=CST$COLOR_SET EXPAND=FALSE

  TYPE
    cst$color_set = set of cst$color_index;

?? PUSH (LISTEXT := ON ) ??
*copyc cst$color_index
?? POP ??
*DECK DECK=CST$COLOR_SUPPORT EXPAND=FALSE

  TYPE
    cst$color_support = record
      foreground: cst$color_set,
      background: cst$color_set,
    recend;

?? PUSH (LISTEXT := ON ) ??
*copyc cst$color_set
?? POP ??

*DECK DECK=CST$CONTROL EXPAND=FALSE

TYPE
  cst$control = 0 .. csc$max_control;

*copyc csc$max_control
*DECK DECK=CST$DATA_STRING EXPAND=FALSE
*copyc csc$max_character_position

TYPE
  cst$data_string = string ( * <= csc$max_character_position );
*DECK DECK=CST$DATA_STRING_LENGTH EXPAND=FALSE

*copyc csc$max_character_position

  TYPE
    cst$data_string_length = 0 .. csc$max_character_position;

*DECK DECK=CST$DEVICE_ATTRIBUTE EXPAND=FALSE

  TYPE
    cst$device_attribute = record
      case key: cst$device_attribute_keys of
      = csc$da_terminal_model_name =
        terminal_model_name_length: 0 .. csc$max_terminal_model_name,
        terminal_model_name: string (csc$max_terminal_model_name),
      = csc$da_screen_dimensions =
        screen_dimensions: cst$screen_dimensions,
      = csc$da_number_of_characters =
        number_of_characters: cst$character_position,
      = csc$da_number_of_lines =
        number_of_lines: cst$line_number,
      = csc$da_fixed_tabs =
        fixed_tabs: cst$fixed_tabs,
      = csc$da_programmable_tabs =
        programmable_tabs: 0 .. csc$max_tab_stops,
      = csc$da_home_at_top =
        home_at_top: boolean,
      = csc$da_has_protect =
        has_protect: boolean,
      = csc$da_tabs_to_unprotected =
        tabs_to_unprotected: boolean,
      = csc$da_has_invisible =
        has_invisible: boolean,
      = csc$da_last_character_scroll =
        last_character_scroll: boolean,
      = csc$da_bell_ack =
        bell_ack: boolean,
      = csc$da_bell_nak =
        bell_nak: boolean,
      = csc$da_physical_highlighting =
        physical_highlighting: cst$physical_highlighting_style,
      = csc$da_color =
        color: cst$color_support,
      = csc$da_picklocate_accuracy =
        picklocate_accuracy: cst$picklocate_accuracy,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cst$device_attribute_keys
*copyc csc$max_terminal_model_name
*copyc cst$screen_dimensions
*copyc cst$character_position
*copyc cst$line_number
*copyc cst$color_support
*copyc cst$fixed_tabs
*copyc csc$max_tab_stops
*copyc cst$physical_highlighting_style
*copyc cst$picklocate_accuracy
?? POP ??
*DECK DECK=CST$DEVICE_ATTRIBUTES EXPAND=FALSE

  TYPE
    cst$device_attributes = array [1 .. *] of cst$device_attribute;

?? PUSH (LISTEXT := ON) ??
*copyc cst$device_attribute
*copyc cst$device_attribute_keys

?? POP ??
*DECK DECK=CST$DEVICE_ATTRIBUTE_KEYS EXPAND=FALSE

  TYPE
    cst$device_attribute_keys = (csc$da_terminal_model_name,
          csc$da_screen_dimensions, csc$da_number_of_characters,
          csc$da_number_of_lines, csc$da_fixed_tabs, csc$da_programmable_tabs,
          csc$da_home_at_top, csc$da_has_protect, csc$da_tabs_to_unprotected,
          csc$da_has_invisible, csc$da_last_character_scroll, csc$da_bell_ack,
          csc$da_bell_nak, csc$da_physical_highlighting, csc$da_color,
          csc$da_picklocate_accuracy);
*DECK DECK=CST$DIRECTION_INDEX EXPAND=FALSE

  TYPE
    cst$direction_index = (csc$direction_left_to_right,
          csc$direction_right_to_left, csc$direction_unspecified);
*DECK DECK=CST$EVENT_IDENTIFIER EXPAND=FALSE

*copyc cst$event_type
*copyc cst$x_position
*copyc cst$y_position
*copyc cst$page_event_type
*copyc cst$field_number
*copyc cst$character_position
*copyc cst$line_number
*copyc cst$field_event_type

  TYPE
    cst$event_identifier = record
      case event_type: cst$event_type of
      = csc$page_event =
        page_event_x_position: cst$x_position,
        page_event_y_position: cst$y_position,
        page_event: cst$page_event_type,
      = csc$field_event =
        field_event_field_number: cst$field_number,
        field_event_character_position: cst$character_position,
        field_event_line_number: cst$line_number,
        field_event: cst$field_event_type,
      = csc$timeout_event =
        ,
      = csc$end_of_transaction =
        ,
      casend,
    recend;

*DECK DECK=CST$EVENT_NAME_IDENTIFIER EXPAND=FALSE

  TYPE
    cst$event_name_identifier = record
      case event_type: cst$event_type of
      = csc$page_event =
        page_event: cst$page_event_type,
      = csc$field_event =
        field_event: cst$field_event_type,
      = csc$timeout_event =
        ,
      = csc$end_of_transaction =
        ,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cst$event_type
*copyc cst$field_event_type
*copyc cst$page_event_type
?? POP ??
*DECK DECK=CST$EVENT_TYPE EXPAND=FALSE

  TYPE
    cst$event_type = (csc$page_event, csc$field_event, csc$end_of_transaction,
          csc$timeout_event);
*DECK DECK=CST$FIELD_ATTRIBUTE EXPAND=FALSE

  TYPE
    cst$field_attribute = record
      case key: cst$field_attribute_keys of
      = csc$fld_x_position =
        x_position: cst$x_position,
      = csc$fld_y_position =
        y_position: cst$y_position,
      = csc$fld_visible_characters =
        visible_characters: cst$character_position,
      = csc$fld_visible_lines =
        visible_lines: cst$line_number,
      = csc$fld_characters =
        characters: cst$character_position,
      = csc$fld_lines =
        lines: cst$line_number,
      = csc$fld_data_character_position =
        field_data_character_position: cst$character_position,
      = csc$fld_data_line_number =
        field_data_line_number: cst$line_number,
      = csc$fld_input =
        input: boolean,
      = csc$fld_visible =
        visible: boolean,
      = csc$fld_justification =
        justification: cst$field_justification,
      = csc$fld_boundary_processing =
        boundary_processing: cst$boundary_processing,
      = csc$fld_foreground_color_index =
        foreground_color: cst$color_index,
      = csc$fld_background_color_index =
        background_color: cst$color_index,
      = csc$fld_highlighting =
        highlighting_style: (csc$physical_highlighting,
              csc$logical_highlighting),
      = csc$fld_physical_highlighting =
        physical_highlighting: cst$physical_highlighting,
      = csc$fld_logical_highlighting =
        logical_highlighting: cst$logical_highlighting
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cst$field_attribute_keys
*copyc cst$x_position
*copyc cst$y_position
*copyc cst$character_position
*copyc cst$line_number
*copyc cst$field_justification
*copyc cst$boundary_processing
*copyc cst$color_index
*copyc cst$physical_highlighting
*copyc cst$logical_highlighting
?? POP ??
*DECK DECK=CST$FIELD_ATTRIBUTES EXPAND=FALSE

  TYPE
    cst$field_attributes = array [1 .. *] of cst$field_attribute;


?? PUSH (LISTEXT := ON) ??
*copyc cst$field_attribute_keys
*copyc cst$field_attribute
?? POP ??
*DECK DECK=CST$FIELD_ATTRIBUTE_KEYS EXPAND=FALSE

  TYPE
    cst$field_attribute_keys = (csc$fld_x_position, csc$fld_y_position,
          csc$fld_visible_characters, csc$fld_visible_lines,
          csc$fld_characters, csc$fld_lines, csc$fld_data_character_position,
          csc$fld_data_line_number, csc$fld_input, csc$fld_visible,
          csc$fld_justification, csc$fld_boundary_processing,
          csc$fld_foreground_color_index, csc$fld_background_color_index,
          csc$fld_highlighting, csc$fld_physical_highlighting,
          csc$fld_logical_highlighting);

*DECK DECK=CST$FIELD_EVENT_TYPE EXPAND=FALSE

*copyc cst$field_event_types
*copyc cst$menu_item_number
*copyc cst$screen_events
*copyc cst$standard_functions
*copyc cst$application_functions
*copyc cst$pick_resolution
*copyc cst$pick_marking
*copyc cst$mouse_event

  TYPE
    cst$field_event_type = record
      case event_type: cst$field_event_types of
      = csc$pick =
        pick_resolution: cst$pick_resolution,
        pick_marking: cst$pick_marking,
      = csc$field_screen =
        screen_event: cst$screen_events,
      = csc$field_standard_function =
        standard_function: cst$standard_functions,
      = csc$field_application_function =
        application_function: cst$application_functions,
      = csc$field_menu_event =
        menu_item: cst$menu_item_number,
      = csc$field_mouse_event =
        mouse_event: cst$mouse_event,
      casend,
    recend;

*DECK DECK=CST$FIELD_EVENT_TYPES EXPAND=FALSE

  TYPE
    cst$field_event_types = (csc$pick, csc$field_screen,
      csc$field_standard_function, csc$field_application_function,
      csc$field_menu_event,csc$field_mouse_event);
*DECK DECK=CST$FIELD_JUSTIFICATION EXPAND=FALSE

  TYPE
    cst$field_justification = (csc$no_justification, csc$left_justification,
      csc$center_justification, csc$right_justification);

*DECK DECK=CST$FIELD_NUMBER EXPAND=FALSE

*copyc csc$max_field_number

  TYPE
    cst$field_number = 0 .. csc$max_field_number;

*DECK DECK=CST$FIXED_TABS EXPAND=FALSE

  TYPE
    cst$fixed_tabs = record
      fixed_tab_positions: cst$fixed_tab_positions,
      fixed_tabs: array [1 .. csc$max_tab_stops] of cst$fixed_tab_positions,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cst$fixed_tab_positions
?? POP ??
*DECK DECK=CST$FIXED_TAB_POSITIONS EXPAND=FALSE

  TYPE
    cst$fixed_tab_positions = 0 .. csc$max_tab_stops;

?? PUSH (LISTEXT := ON) ??
*copyc csc$max_tab_stops
?? POP ??
*DECK DECK=CST$GRAPHIC_IDENTIFIER EXPAND=FALSE

*copyc csc$max_graphic_id

  TYPE
    cst$graphic_identifier = 0 .. csc$max_graphic_id;

*DECK DECK=CST$HEIGHT EXPAND=FALSE

TYPE
  cst$height = 1 .. csc$max_y_position;

*copyc csc$max_y_position
*DECK DECK=CST$INPUT_TIMEOUT EXPAND=FALSE

*copyc csc$max_timeout

  TYPE
    cst$input_timeout = 0 .. csc$max_timeout;

*DECK DECK=CST$INTERACTION_STYLE EXPAND=FALSE

  TYPE
    cst$interaction_style = (csc$line_level, csc$screen_level);

*DECK DECK=CST$INTERSECTION_TYPE EXPAND=FALSE

  TYPE
    cst$intersection_type = (csc$horizontal, csc$vertical, csc$upper_left,
      csc$upper_right, csc$lower_left, csc$lower_right, csc$top, csc$bottom,
      csc$left_side, csc$right_side, csc$cross, csc$null);

*DECK DECK=CST$INTERSECTION_TYPES EXPAND=FALSE

*copyc cst$intersection_type

  TYPE
    cst$intersection_types = array [1 .. * ] of cst$intersection_type;

*DECK DECK=CST$KEY_TYPE EXPAND=FALSE
  TYPE
    cst$key_type = (csc$standard_function, csc$application_function,
                    csc$screen_function, csc$unused_entry);
*DECK DECK=CST$LINES_USED EXPAND=FALSE
*copyc csc$max_line_number
  TYPE
    cst$lines_used = 0 .. csc$max_line_number;
*DECK DECK=CST$LINE_NUMBER EXPAND=FALSE

*copyc csc$max_line_number

  TYPE
    cst$line_number = 1 .. csc$max_line_number;

*DECK DECK=CST$LINE_WIDTH EXPAND=FALSE

  TYPE
    cst$line_width = (csc$fine, csc$medium, csc$bold);

*DECK DECK=CST$LOCATE_ACCURACY EXPAND=FALSE

  TYPE
    cst$locate_accuracy = record
      start_x: cst$locate_x_accuracy,
      end_x: cst$locate_x_accuracy,
      x_increment: cst$locate_x_accuracy,
      start_y: cst$locate_y_accuracy,
      end_y: cst$locate_y_accuracy,
      y_increment: cst$locate_y_accuracy,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cst$locate_x_accuracy
*copyc cst$locate_y_accuracy
?? POP ??
*DECK DECK=CST$LOCATE_MARKING EXPAND=FALSE

  TYPE
    cst$locate_marking = record
      locate_center_marked: boolean,
      locate_x_mark: cst$x_position,
      locate_y_mark: cst$y_position,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cst$x_position
*copyc cst$y_position
?? POP ??
*DECK DECK=CST$LOCATE_RESOLUTION EXPAND=FALSE

  TYPE
    cst$locate_resolution = record
      x_resolution: boolean,
      y_resolution: boolean,
    recend;
*DECK DECK=CST$LOCATE_X_ACCURACY EXPAND=FALSE

  TYPE
    cst$locate_x_accuracy = 0 .. csc$max_x_position;

?? PUSH (LISTEXT := ON) ??
*copyc csc$max_x_position
?? POP ??
*DECK DECK=CST$LOCATE_Y_ACCURACY EXPAND=FALSE

  TYPE
    cst$locate_y_accuracy = 0 .. csc$max_y_position;

?? PUSH (LISTEXT := ON) ??
*copyc csc$max_y_position
?? POP ??
*DECK DECK=CST$LOGICAL_HIGHLIGHTING EXPAND=FALSE

  TYPE
    cst$logical_highlighting = (csc$logical_normal, csc$italic, csc$title,
      csc$input, csc$error, csc$message);
*DECK DECK=CST$LOGICAL_HIGHLIGHTING_STYLE EXPAND=FALSE
*copyc cst$logical_highlighting

  TYPE
    cst$logical_highlighting_style = cst$logical_highlighting;

*DECK DECK=CST$MARKING_TYPE EXPAND=FALSE

  TYPE
    cst$marking_type = (csc$character_marking, csc$line_marking,
      csc$box_marking, csc$unmark);

*DECK DECK=CST$MAX_CLASSES EXPAND=FALSE
*copyc csc$max_classes
  TYPE
    cst$max_classes = 0 .. csc$max_classes;
*DECK DECK=CST$MENU_CLASS EXPAND=FALSE
*copyc cst$class_name
  TYPE
    cst$menu_class = ^ARRAY [1 .. * {csc$max_classes}] of cst$class_name;
*DECK DECK=CST$MENU_ITEM EXPAND=FALSE
*copyc ost$name
*copyc cst$max_classes
*copyc cst$key_type
*copyc cst$standard_functions
*copyc cst$application_functions
*copyc cst$screen_events

  TYPE
   cst$menu_item = RECORD
     pair_with_previous: boolean,
     short_label: string(6),
     alternate_short_label: string(6),
     long_label: ost$name,
     alternate_long_label: ost$name,
     menu_parent: cst$max_classes,
     item_assigned: boolean,
     CASE menu_type: cst$key_type OF
     = csc$standard_function =
       standard_function: cst$standard_functions,
     = csc$application_function =
       application_function: cst$application_functions,
     = csc$screen_function =
       screen_function: cst$screen_events,
     = csc$unused_entry =
       ,
     CASEND,
   RECEND;

*DECK DECK=CST$MENU_ITEM_NUMBER EXPAND=FALSE
*copyc csc$max_menu_items
  TYPE
    cst$menu_item_number = 0 .. csc$max_menu_items;
*DECK DECK=CST$MENU_ITEM_STRING EXPAND=FALSE

  TYPE
    cst$menu_item_string = RECORD
      menu_string: ^clt$command_line,
      long_label: ost$name,
      alternate_long_label: ost$name,
      short_label: string (6),
      alternate_short_label: string (6),
      item_number: cst$menu_item_number,
      CASE key_type: cst$key_type OF
      = csc$standard_function =
        standard_function: cst$standard_functions,
      = csc$application_function =
        application_function: cst$application_functions,
      = csc$screen_function =
        screen_event: cst$screen_events,
      = csc$unused_entry =
        ,
      CASEND,
    RECEND;

*copyc clt$command_line
*copyc cst$application_functions
*copyc cst$menu_item_number
*copyc cst$standard_functions
*copyc ost$name
*DECK DECK=CST$MENU_LIST EXPAND=FALSE
*copyc cst$menu_item
  TYPE
  cst$menu_list = ^ARRAY [1 .. * {csc$max_menu_items}] of cst$menu_item;

*DECK DECK=CST$MENU_STRINGS EXPAND=FALSE

  TYPE
    cst$menu_strings = array [1 .. * {csc$max_menu_items}] of ^clt$command_line;

*copyc clt$command_line
*DECK DECK=CST$MODEL_NAME EXPAND=FALSE
*copyc csc$max_terminal_model_name

  TYPE
    cst$model_name = string (csc$max_terminal_model_name);

*DECK DECK=CST$MOUSE_EVENT EXPAND=FALSE
*copyc csc$max_mouse_event

  TYPE
    cst$mouse_event = 0 .. csc$max_mouse_event;

*DECK DECK=CST$NAME EXPAND=FALSE

  TYPE
    cst$name = string (* <= csc$max_name);


*copyc csc$max_name
*DECK DECK=CST$NUMBER_OF_MENU_ROWS EXPAND=FALSE
*copyc csc$number_of_menu_rows
  TYPE
    cst$number_of_menu_rows = 0 .. csc$number_of_menu_rows;
*DECK DECK=CST$PAGE_ATTRIBUTE EXPAND=FALSE

  TYPE
    cst$page_attribute = record
      case key: cst$page_attribute_keys of
      = csc$page_color =
        color: cst$color_index,
      = csc$page_changed_text_mode =
        changed_text_mode: boolean,
      = csc$page_length =
        page_length:ift$page_length,
      = csc$page_tab_stops =
        tab_stops: cst$tab_stops,
      = csc$page_terminal_model =
        page_terminal_model: ift$terminal_model,
      = csc$page_width =
        page_width: ift$page_width,
      = csc$page_leave_cursor =
        leave_cursor: boolean,
      = csc$page_event_style =
        event_style: cst$page_event_style,
      = csc$left_mouse_button =
        left_button: integer,
      = csc$menubar_file =
        menubar_enabled: boolean,
        menubar_file: amt$local_file_name,
      = csc$right_mouse_button =
        right_button: integer,
      = csc$menu_rows_displayed =
        menu_rows_displayed: cst$number_of_menu_rows,
      = csc$mouse_reclick_request =
        mouse_reclick_request: boolean,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cst$page_attribute_keys
*copyc cst$color_index
*copyc cst$tab_stops
*copyc cst$page_event_style
*copyc amt$local_file_name
*copyc cst$number_of_menu_rows
*copyc ift$terminal_attribute_types
*copyc ift$terminal_model
?? POP ??
*DECK DECK=CST$PAGE_ATTRIBUTES EXPAND=FALSE

  TYPE
    cst$page_attributes = array [1 .. *] of cst$page_attribute;

?? PUSH (LISTEXT := ON) ??
*copyc cst$page_attribute_keys
*copyc cst$page_attribute
?? POP ??
*DECK DECK=CST$PAGE_ATTRIBUTE_KEYS EXPAND=FALSE

  TYPE
    cst$page_attribute_keys = (csc$page_color, csc$page_changed_text_mode,
          csc$page_tab_stops, csc$page_leave_cursor, csc$page_event_style,
          csc$left_mouse_button, csc$menubar_file, csc$right_mouse_button,
          csc$menu_rows_displayed, csc$mouse_reclick_request,
          csc$page_length, csc$page_width, csc$page_terminal_model);
*DECK DECK=CST$PAGE_EVENT_STYLE EXPAND=FALSE

  TYPE
    cst$page_event_style = (csc$function_next_style,
          csc$end_of_transaction_style);

*DECK DECK=CST$PAGE_EVENT_TYPE EXPAND=FALSE

*copyc cst$menu_item_number
*copyc cst$page_event_types
*copyc cst$screen_events
*copyc cst$standard_functions
*copyc cst$application_functions
*copyc cst$locate_resolution
*copyc cst$locate_marking
*copyc cst$mouse_event

  TYPE
    cst$page_event_type = record
      case event_type: cst$page_event_types of
      = csc$locate =
        locate_resolution: cst$locate_resolution,
        locate_marking: cst$locate_marking,
      = csc$page_screen =
        screen_event: cst$screen_events,
      = csc$page_standard_function =
        standard_function: cst$standard_functions,
      = csc$page_application_function =
        application_function: cst$application_functions,
      = csc$page_menu_event =
        menu_item: cst$menu_item_number,
      = csc$page_mouse_event =
        mouse_event: cst$mouse_event,
      casend,
    recend;

*DECK DECK=CST$PAGE_EVENT_TYPES EXPAND=FALSE

  TYPE
    cst$page_event_types = (csc$locate, csc$page_screen,
      csc$page_standard_function, csc$page_application_function,
      csc$page_menu_event,csc$page_mouse_event);
*DECK DECK=CST$PHYSICAL_HIGHLIGHTING EXPAND=FALSE

  TYPE
    cst$physical_highlighting = record
      case normal: boolean of
      = false =
        physical_highlighting: cst$physical_highlighting_set,
        physical_intensity: csc$alternate_intensity .. csc$normal_intensity,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cst$physical_highlighting_style
*copyc cst$physical_highlighting_set
?? POP ??
*DECK DECK=CST$PHYSICAL_HIGHLIGHTING_SET EXPAND=FALSE

  TYPE
    cst$physical_highlighting_set = set of csc$inverse .. csc$underline;

?? PUSH (LISTEXT := ON) ??
*copyc cst$phys_highlighting_style
?? POP ??
*DECK DECK=CST$PHYSICAL_HIGHLIGHTING_STYLE EXPAND=FALSE

  TYPE
    cst$physical_highlighting_style = set of csc$inverse .. csc$high_intensity;

?? PUSH (LISTEXT := ON) ??
*copyc cst$phys_highlighting_style
?? POP ??
*DECK DECK=CST$PHYS_HIGHLIGHTING_STYLE EXPAND=FALSE

  TYPE
    cst$phys_highlighting_style = set of (csc$phys_normal, csc$inverse,
      csc$blink, csc$underline, csc$alternate_intensity, csc$low_intensity,
      csc$high_intensity, csc$normal_intensity);

*DECK DECK=CST$PICKLOCATE_ACCURACY EXPAND=FALSE

  TYPE
    cst$picklocate_accuracy = record
      x_positions: cst$picklocate_x_position,
      x_accuracy: array [1 .. csc$max_x_position] of cst$picklocate_x_position,
      y_positions: cst$picklocate_y_position,
      y_accuracy: array [1 .. csc$max_y_position] of cst$picklocate_y_position,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cst$picklocate_x_position
*copyc cst$picklocate_y_position
*copyc csc$max_x_position
*copyc csc$max_y_position
?? POP ??
*DECK DECK=CST$PICKLOCATE_X_POSITION EXPAND=FALSE

  TYPE
    cst$picklocate_x_position = 0 .. csc$max_x_position;

?? PUSH (LISTEXT := ON) ??
*copyc csc$max_x_position
?? POP ??
*DECK DECK=CST$PICKLOCATE_Y_POSITION EXPAND=FALSE

  TYPE
    cst$picklocate_y_position = 0 .. csc$max_y_position;

?? PUSH (LISTEXT := ON) ??
*copyc csc$max_y_position
?? POP ??
*DECK DECK=CST$PICK_ACCURACY EXPAND=FALSE

  TYPE
    cst$pick_accuracy = record
      start_character: cst$pick_character_accuracy,
      end_character: cst$pick_character_accuracy,
      character_increment: cst$pick_character_accuracy,
      start_line: cst$pick_line_accuracy,
      end_line: cst$pick_line_accuracy,
      line_increment: cst$pick_line_accuracy,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cst$pick_character_accuracy
*copyc cst$pick_line_accuracy
?? POP ??
*DECK DECK=CST$PICK_CHARACTER_ACCURACY EXPAND=FALSE

  TYPE
    cst$pick_character_accuracy = 0 .. csc$max_visible_char_position;

?? PUSH (LISTEXT := ON) ??
*copyc csc$max_visible_char_position
?? POP ??
*DECK DECK=CST$PICK_LINE_ACCURACY EXPAND=FALSE

  TYPE
    cst$pick_line_accuracy = 0 .. csc$max_line_number;

?? PUSH (LISTEXT := ON) ??
*copyc csc$max_line_number
?? POP ??
*DECK DECK=CST$PICK_MARKING EXPAND=FALSE

  TYPE
    cst$pick_marking = record
      pick_center_marked: boolean,
      pick_x_mark: cst$x_position,
      pick_y_mark: cst$y_position,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cst$x_position
*copyc cst$y_position
?? POP ??
*DECK DECK=CST$PICK_RESOLUTION EXPAND=FALSE

  TYPE
    cst$pick_resolution = record
      field_resolution: boolean,
      character_resolution: boolean,
      line_resolution: boolean,
    recend;
*DECK DECK=CST$SCREEN_DIMENSION EXPAND=FALSE

  TYPE
    cst$screen_dimension = record
      x_screen_dimension: 1 .. csc$max_x_position,
      y_screen_dimension: 1 .. csc$max_y_position,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc csc$max_x_position
*copyc csc$max_y_position
?? POP ??
*DECK DECK=CST$SCREEN_DIMENSIONS EXPAND=FALSE

  TYPE
    cst$screen_dimensions = record
      sets_of_dimensions: 1 .. csc$max_screen_dimensions,
      screen_dimensions: array [1 .. csc$max_screen_dimensions] of
            cst$screen_dimension,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc csc$max_screen_dimensions
*copyc cst$screen_dimension
?? POP ??
*DECK DECK=CST$SCREEN_EVENTS EXPAND=FALSE

  TYPE
    cst$screen_events = (csc$insert_line, csc$delete_line, csc$home, csc$clear,
          csc$insert_char_menu_item, csc$delete_char_menu_item,
          csc$clear_eol_menu_item);
*DECK DECK=CST$SHIFT_FIELD_OFFSET EXPAND=FALSE

*copyc csc$max_field_number

  TYPE
    cst$shift_field_offset = - csc$max_field_number .. csc$max_field_number;

*DECK DECK=CST$SHIFT_LINE_OFFSET EXPAND=FALSE

*copyc csc$max_line_number

  TYPE
    cst$shift_line_offset = - csc$max_line_number .. csc$max_line_number;

*DECK DECK=CST$STANDARD_FUNCTIONS EXPAND=FALSE

  TYPE
    cst$standard_functions = (csc$next, csc$sh_next, csc$help, csc$sh_help,
          csc$stop, csc$sh_stop, csc$back, csc$sh_back, csc$up, csc$sh_up,
          csc$down, csc$sh_down, csc$forward, csc$sh_forward, csc$backward,
          csc$sh_backward, csc$edit, csc$sh_edit, csc$data, csc$sh_data,
          csc$undo, csc$sh_undo);

*DECK DECK=CST$STRING EXPAND=FALSE

*copyc csc$max_string

  TYPE
    cst$string = string ( * <= csc$max_string);

*DECK DECK=CST$TAB_POSITION EXPAND=FALSE

*copyc csc$max_tab_position

  TYPE
    cst$tab_position = 1 .. csc$max_tab_position;

*DECK DECK=CST$TAB_POSITIONS EXPAND=FALSE

*copyc cst$tab_position

  TYPE
    cst$tab_positions = array [1 .. * ] of cst$tab_position;

*DECK DECK=CST$TAB_STOPS EXPAND=FALSE

  TYPE
    cst$tab_stops = record
      programmable_tabs: 0 .. csc$max_tab_position,
      tab_stops: array [cst$tab_position] of cst$tab_position,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cst$tab_position
?? POP ??
*DECK DECK=CST$TERMINAL_CHARACTERISTICS EXPAND=FALSE

  TYPE
    cst$terminal_characteristics = record
      home_at_top: boolean,
      number_of_tab_stops: 0 .. csc$max_tab_stops,
      pick_accuracy: cst$pick_accuracy,
      locate_accuracy: cst$locate_accuracy,
      terminal_model_name: ^cst$string,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc csc$max_tab_stops
*copyc cst$pick_accuracy
*copyc cst$locate_accuracy
*copyc cst$string
?? POP ??
*DECK DECK=CST$TEXT_CHANGE_DESCRIPTION EXPAND=FALSE

TYPE
  cst$text_change_description = record
    x_position: cst$x_position,
    y_position: cst$y_position,
    text_length: 0 .. csc$max_x_position,
  recend;

*copyc csc$max_x_position
*copyc cst$x_position
*copyc cst$y_position
*DECK DECK=CST$VECTOR EXPAND=FALSE

  TYPE
    cst$external_interface_vector = record
      acknowledge: ^PROCEDURE
        (    ack_type: cst$audible_acknowledgement;
         VAR status: ost$status),

      allocate_field: ^PROCEDURE
        (    field_attributes: cst$field_attributes;
         VAR field_number: cst$field_number;
         VAR status: ost$status),

      change_background_color: ^PROCEDURE
        (    field_number: cst$field_number;
             color_index: cst$color_index;
         VAR status: ost$status),

      change_capability_level: ^PROCEDURE
        (    capability_level: cst$capability_level;
         VAR status: ost$status),

      change_changed_text_mode: ^PROCEDURE
        (    change_indicator: boolean;
         VAR status: ost$status),

      change_cursor_position: ^PROCEDURE
        (    field_number: cst$field_number;
             character_position: cst$character_position;
             line_number: cst$line_number;
         VAR status: ost$status),

      change_device_dimensions: ^PROCEDURE
        (    number_of_characters: cst$visible_character_position;
             number_of_lines: cst$line_number;
         VAR dimensions_accepted: boolean;
         VAR status: ost$status),

      change_field_attributes: ^PROCEDURE
        (    field_number: cst$field_number;
             field_attributes: cst$field_attributes;
         VAR status: ost$status),

      change_field_boundaries: ^PROCEDURE
        (    fixed_boundaries: boolean;
         VAR status: ost$status),

      change_field_direction: ^PROCEDURE
        (    field_number: cst$field_number;
             display_direction: cst$direction_index;
         VAR status: ost$status),

      change_foreground_color: ^PROCEDURE
        (    field_number: cst$field_number;
             color_index: cst$color_index;
         VAR status: ost$status),

      change_graphic_attributes: ^PROCEDURE
        (    graphic_identifier: cst$graphic_identifier;
             attribute_set: cst$attribute_set;
         VAR status: ost$status),

      change_input_timeout: ^PROCEDURE
        (    timeout: cst$input_timeout;
         VAR status: ost$status),

      change_interaction_style: ^PROCEDURE
        (    file_identifier: amt$file_identifier;
             interaction_style: cst$interaction_style;
         VAR status: ost$status),

      change_io_position: ^PROCEDURE
        (    field_number: cst$field_number;
             line_number: cst$line_number;
         VAR status: ost$status),

      change_line_color: ^PROCEDURE
        (    color_index: cst$color_index;
         VAR status: ost$status),

      change_line_width: ^PROCEDURE
        (    line_width: cst$line_width;
         VAR status: ost$status),

      change_logical_highlighting: ^PROCEDURE
        (    field_number: cst$field_number;
             logical_attribute: cst$logical_highlighting_style;
         VAR status: ost$status),

      change_menu_item_strings: ^PROCEDURE
        (    new_menu_item_strings: ^array [1 .. * {csc$max_menu_items}] OF
                   cst$menu_item_string;
             menu_list: cst$menu_list;
         VAR status: ost$status),

      change_model_name: ^PROCEDURE
        (    new_model_name: cst$model_name;
         VAR status: ost$status),

      change_multiple_screens: ^PROCEDURE
        (    multiple_screens_allowed: boolean;
         VAR status: ost$status),

      change_page_attributes: ^PROCEDURE
        (    page_attributes: cst$page_attributes;
         VAR status: ost$status),

      change_page_color: ^PROCEDURE
        (    color_index: cst$color_index;
         VAR status: ost$status),

      change_page_tabs: ^PROCEDURE
        (    tab_positions: cst$tab_positions;
         VAR status: ost$status),

      change_partial_screen: ^PROCEDURE
        (    file_identifier: amt$file_identifier;
             interaction_style: cst$interaction_style;
             rows: 0 .. csc$max_y_position;
         VAR old_interaction_style: {input,output} cst$interaction_style;
         VAR reserve: cst$lines_used;
         VAR status: ost$status),

      change_phys_highlighting: ^PROCEDURE
        (    field_number: cst$field_number;
             highlighting_style: cst$phys_highlighting_style;
         VAR status: ost$status),

      change_screen_identifier: ^PROCEDURE
        (    new_file_id: amt$file_identifier;
         VAR old_file_id: amt$file_identifier;
         VAR status: ost$status),

      change_text_attributes: ^PROCEDURE
        (    field_number: cst$field_number;
             attribute_set: cst$attribute_set;
         VAR status: ost$status),

      classify_field_event: ^PROCEDURE
        (    field_number: cst$field_number;
         VAR item_number: cst$menu_item_number;
         VAR status: ost$status),

      clear_field: ^PROCEDURE
        (    field_number: cst$field_number;
         VAR status: ost$status),

      clear_page: ^PROCEDURE
        (VAR status: ost$status),

      clear_page_tabs: ^PROCEDURE
        (VAR status: ost$status),

      clear_screen: ^PROCEDURE
        (VAR status: ost$status),

      create_field: ^PROCEDURE
        (    x_position: cst$x_position;
             y_position: cst$y_position;
             visible_characters: cst$visible_character_position;
             visible_lines: cst$line_number;
             characters: cst$character_position;
             lines: cst$line_number;
             input: boolean;
             output: boolean;
             justification: cst$field_justification;
             boundary_processing: cst$boundary_processing;
         VAR field_number: cst$field_number;
         VAR status: ost$status),

      delete_field: ^PROCEDURE
        (    field_number: cst$field_number;
         VAR status: ost$status),

      delete_graphic: ^PROCEDURE
        (    graphic_identifier: cst$graphic_identifier;
         VAR status: ost$status),

      disable_menu_item: ^PROCEDURE
        (    item_number: cst$menu_item_number;
         VAR status: ost$status),

      disable_page: ^PROCEDURE
        (VAR status: ost$status),

      display_menu: ^PROCEDURE
        (    menu_rows: cst$number_of_menu_rows;
             reserve_lines: cst$lines_used;
         VAR lines_used: cst$lines_used;
         VAR status: ost$status),

      enable_menu_item: ^PROCEDURE
        (    item_number: cst$menu_item_number;
         VAR status: ost$status),

      enable_page: ^PROCEDURE
        (VAR status: ost$status),

      flush_events: ^PROCEDURE
        (VAR status: ost$status),

      get_application_parameters: ^PROCEDURE
        (    application_name: cst$application_name;
             reset_to_beginning: boolean;
         VAR text: cst$string;
         VAR end_of_text: boolean;
         VAR length: 0 .. csc$max_string;
         VAR status: ost$status),

      get_dev_reverse_attr: ^PROCEDURE
        (VAR reversed_screen_mode: boolean;
         VAR reversed_field_capability: boolean;
         VAR status: ost$status),

      get_device_attributes: ^PROCEDURE
        (VAR device_attributes: cst$device_attributes;
         VAR status: ost$status),

      get_device_characteristics: ^PROCEDURE
        (VAR terminal_characteristics: cst$terminal_characteristics;
         VAR status: ost$status),

      get_device_dimensions: ^PROCEDURE
        (VAR number_of_characters: cst$visible_character_position;
         VAR number_of_lines: cst$line_number;
         VAR status: ost$status),

      get_event: ^PROCEDURE
        (VAR event_identifier: cst$event_identifier;
         VAR status: ost$status),

      get_event_label: ^PROCEDURE
        (    event_identifier: cst$event_identifier;
         VAR text: cst$string;
         VAR status: ost$status),

      get_event_mapping: ^PROCEDURE
        (    standard_function: cst$standard_functions;
         VAR application_function: cst$application_functions;
         VAR mapped: boolean;
         VAR status: ost$status),

      get_event_name: ^PROCEDURE
        (    event_identifier: cst$event_name_identifier;
         VAR name: ost$name;
         VAR length: 0 .. osc$max_name_size;
         VAR status: ost$status),

      get_field_attributes: ^PROCEDURE
        (    field_number: cst$field_number;
         VAR field_attributes: cst$field_attributes;
         VAR status: ost$status),

      get_field_direction: ^PROCEDURE
        (    field_number: cst$field_number;
         VAR display_direction: cst$direction_index;
         VAR status: ost$status),

      get_io_position: ^PROCEDURE
        (VAR field_number: cst$field_number;
         VAR line_number: cst$line_number;
         VAR end_of_text: boolean;
         VAR status: ost$status),

      get_menu_item_string: ^PROCEDURE
        (    menu_item_number: cst$menu_item_number;
         VAR menu_string: ^clt$command_line;
         VAR status: ost$status),

      get_menu_strings: ^PROCEDURE
        (    menu_strings: ^cst$menu_strings;
         VAR status: ost$status),

      get_next_application_param: ^PROCEDURE
        (    reset_to_beginning: boolean;
         VAR application_name: cst$application_name;
         VAR text: cst$string;
         VAR end_of_text: boolean;
         VAR length: 0 .. csc$max_string;
         VAR status: ost$status),

      get_page_attributes: ^PROCEDURE
        (VAR page_attributes: cst$page_attributes;
         VAR status: ost$status),

      get_screen_identifier: ^PROCEDURE
        (VAR old_file_id: amt$file_identifier;
         VAR status: ost$status),

      get_text: ^PROCEDURE
        (VAR text: cst$data_string;
         VAR length: cst$data_string_length;
         VAR end_of_line: boolean;
         VAR end_of_text: boolean;
         VAR status: ost$status),

      mark: ^PROCEDURE
        (    field_number: cst$field_number;
             start_character_position: cst$character_position;
             start_line_number: cst$line_number;
             end_character_position: cst$character_position;
             end_line_number: cst$line_number;
             mark_type: cst$marking_type;
         VAR status: ost$status),

      mark_menu_item: ^PROCEDURE
        (    item_number: cst$menu_item_number;
         VAR status: ost$status),

      poly_hv_line: ^PROCEDURE
        (    xy_coordinates: cst$xy_coordinates;
         VAR graphic_identifier: cst$graphic_identifier;
         VAR status: ost$status),

      poly_intersect: ^PROCEDURE
        (    graphic_identifier: cst$graphic_identifier;
             xy_coordinates: cst$xy_coordinates;
             intersection_types: cst$intersection_types;
         VAR status: ost$status),

      pop_page: ^PROCEDURE
        (VAR status: ost$status),

      position_cursor: ^PROCEDURE
        (    field_number: cst$field_number;
             character_position: cst$character_position;
             line_number: cst$line_number;
         VAR left_character_position: cst$character_position;
         VAR upper_line_number: cst$line_number;
         VAR status: ost$status),

      position_field_data: ^PROCEDURE
        (    field_number: cst$field_number;
             character_position: cst$character_position;
             line_number: cst$line_number;
         VAR status: ost$status),

      push_page: ^PROCEDURE
        (VAR status: ost$status),

      put_text: ^PROCEDURE
        (    text: ^cst$data_string;
             end_of_line: boolean;
         VAR end_of_text: boolean;
         VAR status: ost$status),

      reposition_field: ^PROCEDURE
        (    field_number: cst$field_number;
             x_position: cst$x_position;
             y_position: cst$y_position;
         VAR status: ost$status),

      resize_field: ^PROCEDURE
        (    field_number: cst$field_number;
             visible_characters: cst$visible_character_position;
             visible_lines: cst$line_number;
         VAR status: ost$status),

      send_line_initialization: ^PROCEDURE
        (VAR status: ost$status),

      send_screen_initialization: ^PROCEDURE
        (VAR status: ost$status),

      set_menu: ^PROCEDURE
        (    menu_classes: cst$menu_class;
             menu_list: cst$menu_list;
         VAR status: ost$status),

      set_menu_strings: ^PROCEDURE
        (    menu_strings: ^cst$menu_strings;
         VAR status: ost$status),

      set_standard_menu: ^PROCEDURE
        (    menu_classes: cst$menu_class;
             menu_list: cst$menu_list;
         VAR status: ost$status),

      shift_fields: ^PROCEDURE
        (    start_field: cst$field_number;
             end_field: cst$field_number;
             offset: cst$shift_field_offset;
         VAR status: ost$status),

      shift_lines: ^PROCEDURE
        (    field_number: cst$field_number;
             start_line: cst$line_number;
             end_line: cst$line_number;
             offset: cst$shift_line_offset;
         VAR status: ost$status),

      toggle_label: ^PROCEDURE
        (    item_number: cst$menu_item_number;
         VAR status: ost$status),

      unmark_menu_item: ^PROCEDURE
        (    item_number: cst$menu_item_number;
         VAR status: ost$status),

      update_device: ^PROCEDURE
        (VAR status: ost$status),

      accept_input: ^PROCEDURE
        (VAR control: cst$control;
         VAR x_position: cst$x_position;
         VAR y_position: cst$y_position;
         VAR status: ost$status),

      change_workspace_attributes: ^PROCEDURE
        (    x_position: cst$x_position;
             y_position: cst$y_position;
             width: cst$width;
             height: cst$height;
             attribute: cst$attribute;
         VAR status: ost$status),

      change_workspace_text: ^PROCEDURE
        (    x_position: cst$x_position;
             y_position: cst$y_position;
             text: cst$string;
             attribute: cst$attribute;
         VAR status: ost$status),

      clear_workspace_area: ^PROCEDURE
        (    x_position: cst$x_position;
             y_position: cst$y_position;
             width: cst$width;
             height: cst$height;
             attribute: cst$attribute;
         VAR status: ost$status),

      close_workstation: ^PROCEDURE
        (VAR status: ost$status),

      display_workspace: ^PROCEDURE
        (VAR status: ost$status),

      draw_lines: ^PROCEDURE
        (    xy_coordinates: cst$xy_coordinates;
             attribute: cst$attribute;
         VAR status: ost$status),

      get_changed_text: ^PROCEDURE
        (    p_change_container: ^SEQ (*);
         VAR p_changed_text: {output} ^SEQ (*);
         VAR more_changes: boolean;
         VAR status: ost$status),

      get_workspace_text: ^PROCEDURE
        (    x_position: cst$x_position;
             y_position: cst$y_position;
         VAR text: cst$string;
         VAR status: ost$status),

      open_workstation: ^PROCEDURE
        (    width: cst$width;
             height: cst$height;
             attribute: cst$attribute;
         VAR status: ost$status),

      set_workspace_cursor: ^PROCEDURE
        (    x_position: cst$x_position;
             y_position: cst$y_position;
         VAR status: ost$status),

      cdc_extension: ^SEQ (*),
      site_extension: ^SEQ (*),
      user_extension: ^SEQ (*),

    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cst$audible_acknowledgement
*copyc cst$field_attributes
*copyc cst$field_number
*copyc ost$status
*copyc cst$color_index
*copyc cst$capability_level
*copyc cst$character_position
*copyc cst$line_number
*copyc cst$visible_character_position
*copyc cst$direction_index
*copyc cst$graphic_identifier
*copyc cst$attribute_set
*copyc cst$input_timeout
*copyc amt$file_identifier
*copyc cst$interaction_style
*copyc cst$line_width
*copyc cst$logical_highlighting_style
*copyc cst$model_name
*copyc cst$page_attributes
*copyc cst$tab_positions
*copyc cst$phys_highlighting_style
*copyc cst$menu_item_number
*copyc cst$x_position
*copyc cst$y_position
*copyc cst$visible_character_position
*copyc cst$character_position
*copyc cst$line_number
*copyc cst$field_justification
*copyc cst$boundary_processing
*copyc cst$number_of_menu_rows
*copyc cst$lines_used
*copyc cst$application_name
*copyc cst$string
*copyc csc$max_string
*copyc cst$device_attributes
*copyc cst$terminal_characteristics
*copyc cst$event_identifier
*copyc cst$standard_functions
*copyc cst$application_functions
*copyc cst$event_name_identifier
*copyc ost$name
*copyc cst$data_string
*copyc cst$data_string_length
*copyc cst$marking_type
*copyc cst$xy_coordinates
*copyc cst$intersection_types
*copyc cst$menu_class
*copyc cst$menu_list
*copyc cst$shift_field_offset
*copyc cst$shift_line_offset
*copyc cst$menu_item_string
*copyc clt$command_line
*copyc cst$menu_strings
*copyc cst$control
*copyc cst$height
*copyc cst$width
*copyc cst$attribute
*copyc cst$text_change_description
?? POP ??
*DECK DECK=CST$VISIBLE_CHARACTER_POSITION EXPAND=FALSE

*copyc csc$max_visible_char_position

  TYPE
    cst$visible_character_position = 1 .. csc$max_visible_char_position;

*DECK DECK=CST$WIDTH EXPAND=FALSE

TYPE
  cst$width = 1 .. csc$max_x_position;

*copyc csc$max_x_position
*DECK DECK=CST$WORKSPACE_TYPES EXPAND=FALSE

*copyc csc$max_attribute
*copyc csc$max_control
*copyc csc$max_implemented_attributes
*copyc csc$workspace_constants
*copyc cst$area_changes
*copyc cst$attribute
*copyc cst$attribute_limits
*copyc cst$control
*copyc cst$height
*copyc cst$text_change_description
*copyc cst$width
*DECK DECK=CST$XY_COORDINATE EXPAND=FALSE

*copyc cst$x_position
*copyc cst$y_position

  TYPE
    cst$xy_coordinate = record
      x: cst$x_position,
      y: cst$y_position,
    recend;

*DECK DECK=CST$XY_COORDINATES EXPAND=FALSE

*copyc cst$xy_coordinate

  TYPE
    cst$xy_coordinates = array [1 .. * ] of cst$xy_coordinate;

*DECK DECK=CST$X_POSITION EXPAND=FALSE

*copyc csc$max_x_position

  TYPE
    cst$x_position = 1 .. csc$max_x_position;

*DECK DECK=CST$Y_POSITION EXPAND=FALSE

*copyc csc$max_y_position

  TYPE
    cst$y_position = 1 .. csc$max_y_position;
*DECK DECK=CSV$VECTOR EXPAND=FALSE

  VAR
    csv$vector: [XREF] cst$external_interface_vector;

?? PUSH (LISTEXT := ON) ??
*copyc cst$vector
*copyc cst$audible_acknowledgement
*copyc cst$field_attributes
*copyc cst$field_number
*copyc cst$color_index
*copyc cst$capability_level
*copyc cst$character_position
*copyc cst$line_number
*copyc cst$visible_character_position
*copyc cst$graphic_identifier
*copyc cst$attribute_set
*copyc cst$input_timeout
*copyc cst$interaction_style
*copyc cst$line_width
*copyc cst$logical_highlighting_style
*copyc cst$model_name
*copyc cst$page_attributes
*copyc cst$tab_positions
*copyc cst$phys_highlighting_style
*copyc cst$menu_item_number
*copyc cst$x_position
*copyc cst$y_position
*copyc cst$field_justification
*copyc cst$boundary_processing
*copyc cst$number_of_menu_rows
*copyc cst$lines_used
*copyc cst$application_name
*copyc cst$string
*copyc cst$device_attributes
*copyc cst$terminal_characteristics
*copyc cst$event_identifier
*copyc cst$standard_functions
*copyc cst$application_functions
*copyc cst$event_name_identifier
*copyc cst$data_string
*copyc cst$data_string_length
*copyc cst$marking_type
*copyc cst$xy_coordinates
*copyc cst$intersection_types
*copyc cst$menu_class
*copyc cst$menu_list
*copyc cst$shift_field_offset
*copyc cst$shift_line_offset
?? POP ??
*DECK DECK=CTC$BOOT_CONTROL_TABLE EXPAND=FALSE
          CTEXT  CTC$BOOT CONTROL TABLE
          SPACE  4,10
**        CTC$BOOT CONTROL TABLE.
*
*         DEFINES THE BOOT CONTROL TABLE OFFSETS.


*         BOOT CONTROL TABLE POINTERS.

 BCTP     EQU    65B         FIRST WORD OF BOOT CONTROL TABLE
 BCTIL    EQU    4           LENGTH OF BOOT CONTROL TABLE INFORMATION WORDS
 BCTOB    EQU    72B         FIRST WORD OF OS MESSAGE BUFFER
 BCTTL    EQU    BCTIL+11D   TOTAL LENGTH OF BOOT CONTROL TABLE

*         BYTE OFFSETS FOR BOOT CONTROL TABLE FIELDS.

 BCTRV    EQU    0           REVISION LEVEL
 BCTFL    EQU    1*4+0       ACTIVATION FLAGS
 BCTTY    EQU    1*4+1       IOU MODEL NUMBER
 BCTDL    EQU    1*4+2       *DFT* BUFFER LENGTH
 BCTIP    EQU    1*4+3       IOU NUMBER AND *SCI* PP NUMBER
 BCTDT    EQU    2*4+0       PACKED DATE AND TIME OF LAST DEADSTART
 BCTCD    EQU    3*4+0       CIP DIRECTORY POINTER

*         FLAG FIELD BIT POSITIONS.

 BCTEA    EQU    0           EICB ACTIVATION FLAG
 BCTDA    EQU    1           *DFT* ACTIVATION FLAG
 BCTOP    EQU    2           OPERATOR PAUSE FLAG
          SPACE  4,10
          ENDX
*DECK DECK=CTC$DFT_ACTION_NO_OVERFLOW EXPAND=TRUE

          CTEXT  CTC$DFT ACTION NO OVERFLOW.
          SPACE  4,10
***       CTC$DFT ACTION NO OVERFLOW.
*
*         SETS THE CONSTANT, *OFLO*, EQUAL TO 0 WHICH STATES THAT NO OVERFLOW
*         OVERLAY FOR DFT ACTIONS IS REQUIRED.


 OFLO     EQU    0           NO DFT ACTION OVERFLOW OVERLAY REQUIRED

          ENDX
*DECK DECK=CTC$DFT_ACTION_OVERFLOW EXPAND=TRUE

          CTEXT  CTC$DFT ACTION OVERFLOW.
          SPACE  4,10
***       CTC$DFT ACTION OVERFLOW.
*
*         SETS THE CONSTANT, *OFLO*, EQUAL TO 1 WHICH STATES THAT AN OVERFLOW
*         OVERLAY FOR DFT ACTIONS IS REQUIRED.


 OFLO     EQU    1           DFT ACTION OVERFLOW OVERLAY REQUIRED

          ENDX
*DECK DECK=CTC$DFT_CONSTANTS EXPAND=FALSE

          CTEXT  CTC$DFT CONSTANTS.
 CTCDFT   SPACE  4,10
***       CTC$DFT CONSTANTS.
*         G. J. FALCONER.    85/05/02.
 CTCDFT   SPACE  4,10
***              DEFINES DFT-RELATED CONSTANTS.
          SPACE  4,10
*         THE FOLLOWING SYMBOLS DEFINE THE CURRENT AND PREDECESSOR VERSIONS
*         OF DFT.

 CURNTV   EQU    7
 VER7     EQU    7
 VER6     EQU    6
 VER5     EQU    5
 VER4     EQU    4
 VER3     EQU    3
 VER2     EQU    2
 VER1     EQU    1

*         OVERLAY ORIGIN FOR RESIDENT II.

 R2ORG    EQU    5700B

*         S0/S0E PAGE MAP INTERNAL ELEMENT ID.

 DFTPMID  EQU    3

*         FOLLOWING IS THE BASE SIZE DEFINITION FOR THE NON REGISTER STATUS BUFFER

 NRSBL    EQU    5

*         FOLLOWING IS THE MAXIMUM NUMBER OF REGISTER LIST ENTRIES ALLOWED.

 MAXRL    EQU    2*10        MAXIMUM OF 10 REGISTER LISTS

*         FOLLOWING IS THE DEFAULT THRESHOLD FOR MAINFRAME ELEMENT
*         COUNTERS BUFFER.

 THRH     EQU    20D

*         FOLLOWING IS THE CONSTANT DESCRIBING THE MULTIPLE OCCURRENCE BIT
*         BIT 11 ( 0 .. 11).

 MUOC     EQU    0#800       MULTIPLE OCCURRENCE BIT

*         FOLLOWING ARE DEFINITIONS OF TOP OF HOUR STATISTIC DFT ANALYSIS CODES.

 TOHE     EQU    0#1707      ELEMENT COUNTERS ANALYSIS CODE
 TOHS     EQU    0#1708      SECDED ID TABLE ANALYSIS CODE


*         FOLLOWING ARE THE EQUATES FOR REFERENCING THE MAINFRAME
*         ELEMENT COUNTERS BUFFER.

 METH     EQU    0           THRESHOLD FIELD
 MEUL     EQU    1           UNLOGGED COUNTER
 MECO     EQU    2           CORRECTED ERROR
 MEUN     EQU    3           UNCORRECTED ERROR

*         FOLLOWING IS THE EQUATE SPECIFYING THE POINTER BLOCK LENGTH IN
*         THE DFT CONTROL BLOCK.

 DHPL     EQU    6

*         FOLLOWING ARE SHIFT COUNTS FOR ACCESSING DFT HEADER FIELDS.

 DH.NPW   EQU    10          NUMBER OF POINTER WORDS
 DH.RL    EQU    10          REVISION LEVEL
 DH.LBF   EQU    10          LENGTH OF MAINTENANCE REGISTER BUFFER IN CM WORDS
 DH.BKP   EQU    14          PP BREAKPOINT FLAG
 DH.DT    EQU    13          DUAL STATE TRANSITION FLAG
 DH.MO    EQU    12          MANUAL OVERRIDE OF DFT BY MDD
 DH.FFC   EQU    11          FREEZE SYSTEM ON CORRECTED ERROR
 DH.FFU   EQU    10          FREEZE SYSTEM ON UNCORRECTED ERROR
 DH.FV    EQU    7           DFT VERIFICATION FLAG
 DH.FR    EQU    6           DFT REJECT FLAG
 DH.FZ    EQU    5           ZERO COUNTERS AND SECDED ID TABLE
 DH.FC    EQU    4           C170 DEDICATED MODE
 DH.FL    EQU    3           LOGGING FLAG
 DH.FD    EQU    2           DEDICATED MODE FLAG
 DH.FE8   EQU    1           C180 ERROR FLAG
 DH.FE7   EQU    0           C170 ERROR FLAG

*         FOLLOWING ARE EQUATES FOR ACCESSING DFT HEADER CM WORD.

 DHSEQ    EQU    0           SEQUENCE NUMBER
 DHNPW    EQU    0           NUMBER OF POINTER WORDS
 DHRL     EQU    1           REVISION LEVEL
 DHPP     EQU    1           LOGICAL PP NUMBER OF DFT
 DHLBF    EQU    2           LENGTH OF MAINTENANCE REGISTER BUFFER
 DHNBF    EQU    2           NUMBER OF MAINTENANCE REGISTER BUFFERS
 DHFLG    EQU    3           FLAGS

*         FOLLOWING ARE SHIFT COUNTS FOR BUFFER CONTROL WORD FIELDS.

 BC.MO    EQU    13          MULTIPLE OCCURRENCE BIT
 BC.EI    EQU    10          ELEMENT INDEX
 BC.ANP   EQU    14          DFT ANALYSIS CODE PRIORITY
 BC.ANE   EQU    10          DFT ANALYSIS CODE ERROR NUMBER
 BC.SEQ   EQU    10          SEQUENCE NUMBER

*         FOLLOWING ARE SHIFT COUNTS FOR BUFFER CONTROL WORD FLAGS.

*UNUSED   EQU    7           RESERVED FOR FUTURE USE
 BC.MDB   EQU    6           MODEL DEPENDENT BUFFER DATA TO LOG
 BC.CL    EQU    5           LOG MAINTENANCE REGISTERS TO CONSOLE FLAG
 BC.TE    EQU    4           THRESHOLD EXCEEDED
 BC.FL    EQU    3           OS SHOULD LOG MAINTENANCE REGISTERS FLAG
 BC.FI    EQU    2           INTERLOCK FLAG
 BC.FV8   EQU    1           C180 VALID DATA FLAG
 BC.FV7   EQU    0           C170 VALID DATA FLAG

*         FOLLOWING ARE EQUATES FOR ACCESS TO BUFFER CONTROL WORD.

 BCEI     EQU    0           ELEMENT INDEX
 BCOA     EQU    0           OS ACTION CODE
 BCDA     EQU    1           DFT ANALYSIS
 BCSEQ    EQU    2           SEQUENCE NUMBER
 BCFLG    EQU    2           FLAGS
 BCOFF    EQU    3           OFFSET

*         FOLLOWING ARE EQUATES FOR OFFSETS TO DFT STRUCTURES.

 HDRP     EQU    0           OFFSET TO DFT CONTROL WORD
 SECP     EQU    1           OFFSET TO SECDED ID TABLE POINTER
 MRBP     EQU    2           OFFSET TO MAINTENANCE REGISTER BUFFER POINTER
 MDLP     EQU    3           OFFSET TO MODEL-DEPENDENT BUFFER POINTER
 NVEP     EQU    4           OFFSET TO NOS/VE BUFFER POINTER
 C17P     EQU    5           OFFSET TO C170 PP RESIDENT BUFFER POINTER
 OSRP     EQU    6           OFFSET TO C170 OS REQUEST POINTER (VERSION 2-N)
 BCWP     EQU    7           OFFSET TO BUFFER CONTROL WORDS
 MECP     EQU    10          OFFSET TO MAINFRAME ELEMENT COUNTERS
 ECRP     EQU    11          OFFSET TO ERROR CONTROL RECORD
 SSBP     EQU    12          OFFSET TO SUPPORTIVE STATUS BUFFER
 NRSP     EQU    13          OFFSET TO NON REGISTER STATUS BUFFER
 DCMP     EQU    14          OFFSET TO DFT CM RESIDENT BUFFER
 PRDP     EQU    15          OFFSET TO PP REGISTER SAVE AREA
 SDBP     EQU    16          OFFSET TO SECONDARY DFT BUFFER POINTER

*         THE FOLLOWING DEFINES THE STRUCTURE OF THE DFT CM RESIDENT BUFFER.

 CMSS     EQU    0           BITS 48-63:  1/IOU1 SS READ,7/0,8/IOU1 SS
 CMSN     EQU    1           BITS 48-63:  16/NUMBER OF TIMES *SIT* < -2 SECONDS
 CMTO     EQU    1           BITS 32-47:  16/NUMBER OF PACKET TIME OUTS
 CMSM     EQU    1           BITS 16-31:  16/NUMBER OF MISMATCHED PACKET SEQUENCE NUMBERS
 CMRC     EQU    2           BITS 48-63:  RETRY COUNTER FOR 960
 CMRA     EQU    3           BITS 24-63:  R-REGISTER ADDRESS FOR 960 RETRY
 CMPRA    EQU    4           BITS 00-63:  P-REGISTER ADDRESS FOR 960 RETRY
 CMDK     EQU    10 - 16     DISK STATUS BUFFER FROM ERROR ENCOUNTERED BY *2AP*
 CMEPM    EQU    17 - 34     960 ENVIRONMENT POWER MONITOR PACKET DATA

*         FOLLOWING ARE EQUATES FOR OS ACTION CODES (VERSION 1-3).

 OSEW     EQU    1           ENVIRONMENT WARNING
 OSLPW    EQU    2           LONG POWER WARNING
 OSSPW    EQU    3           SHORT POWER WARNING
 OSWC     EQU    4           WARNING CLEAR
 OSFIE    EQU    5           FATAL IOU ERROR
 OSVEI    EQU    6           NOS/VE IOU ERROR
 OSUCM    EQU    7           UNCORRECTED CM ERROR
 OSMOB    EQU    10          MULTIPLE ODD BIT ERROR
 OSUPE    EQU    11          UNCORRECTED PROCESSOR ERROR
 OSNSI    EQU    12          NOS PP FAILURE

*         FOLLOWING ARE EQUATES FOR OS ACTION CODES (VERSION 4-N).

 OSNA     EQU     0          NO OS ACTION
 OSSI     EQU    13          SYSTEM IDLE/CHECKPOINT
 OSSR     EQU    14          SYSTEM RESUME
 OS17I    EQU    15          C170 STATE IDLE (CHECKPOINT)
 OS17R    EQU    16          C170 STATE RESUME (RESTART)
 OS18I    EQU    17          C180 STATE IDLE
 OS18R    EQU    20          C180 STATE RESUME
 OSSS     EQU    21          SYSTEM STEP
 OSSU     EQU    22          SYSTEM UNSTEP
 OS17S    EQU    23          C170 STATE STEP
 OS17U    EQU    24          C170 STATE UNSTEP
 OS18S    EQU    25          C180 STATE STEP
 OS18U    EQU    26          C180 STATE UNSTEP
 OSRME    EQU    27          RECONFIGURE MAINFRAME ELEMENTS
 OSVCD    EQU    30          990 VECTOR DEGRADE
 OSSED    EQU    31          POST SUBELEMENT DEGRADE(SERVICE PROCESSOR)
 OSCMF    EQU    32          FLAW CM PAGE(SERVICE PROCESSOR)
 OSOAM    EQU    33          POST OPERATOR ACTION MESSAGE (SERVICE PROCESSOR)
 OSHGP    EQU    34          HUNG PP PROCESSING
 OSIMB    EQU    35          IOU BIT 57 CM ACCESS BLOCKED

*         FOLLOWING ARE ERROR PRIORITY VALUES.

 EPSW     EQU    6           SHORT WARNING
 EPEN     EQU    5           ENVIRONMENT WARNING
 EPCH     EQU    4           CPU HALT ERROR
 EPUN     EQU    3           UNCORRECTED ERROR
 EPCO     EQU    2           CORRECTED ERROR
 EPTH     EQU    1           TOP OF HOUR PROCESSING
 EPRT     EQU    0           RETRY OPERATION

*         EQUATES FOR TYPE CODES.

 TC.MAC   EQU    0#0         MAC TYPE CODE - MAC, PMF, PSR
 TC.RGU   EQU    0#7         RGU TYPE CODE - RGU
 TC.ACU   EQU    0#4         ACU TYPE CODE - M2, M3, M4
 TC.BDP   EQU    0#5         BDP TYPE CODE - BDP, BP3
 TC.IDU   EQU    0#1         IDU TYPE CODE - CW, CS, INSTR MAP
 TC.EPN   EQU    0#9         EPN TYPE CODE - EPN
 TC.LSU   EQU    0#8         LSU TYPE CODE - LSU

*         EQUATES FOR ELEMENT IDENTIFIERS.

 EIDCM    EQU    1           CENTRAL MEMORY ELEMENT ID
 EIDIOU0  EQU    2           IOU0 ELEMENT ID
 EIDIOU1  EQU    0#12        IOU1 ELEMENT ID
 EIDCPU0  EQU    0#00        CPU0 ELEMENT ID
 EIDCPU1  EQU    0#10        CPU1 ELEMENT ID

*         EQUATES FOR 990 ISSUE TIMEOUT DETECTION.

 VGAT     EQU    0#55        VECTOR GATHER OPCODE
 VSCA     EQU    0#56        VECTOR SCATTER OPCODE
 VMID     EQU    0#80        CIR VMID BIT MASK
 BOB      EQU    7           BYTE OFFSET BITS

*         EQUATES FOR 990 RETRY OPERATIONS.

 TRPC.TH  EQU    0#10        THETA RETRY P COUNTER THRESHOLD
 TRHC.TH  EQU    0#80        THETA RETRY HOURLY COUNTER THRESHOLD
 MICLEV   EQU    3443B       LEVEL 18 IN DISPLAY CODE
 TRPO     EQU    28D         THETA RETRY PROGRAM ADDRESS OFFSET
 TRCO     EQU    29D         THETA RETRY COUNTER OFFSET

*         990 CONTROL STORE ADDRESS EQUATES.

 CSAH     EQU    0#20        CONTROL STORE ADDRESS HALT
 CSHA     EQU    0#24        CONTROL STORE SW HALT ADDR
 CSRA     EQU    0#44        CONTROL STORE RETRY ADDR
 CSHHA    EQU    0#92        CONTROL STORE HW HALT ADDR
 CSBDPI   EQU    0#3FE       CONTROL STORE BDP INIT ADDR

*         EQUATES FOR THE *MRB TYPE* FIELD IN THE SUPPORTIVE STATUS BUFFER.

 MTMRB    EQU    1           MRB REGISTER GROUP
 MTMEC    EQU    4           MAINFRAME ELEMENT COUNTERS
 MTSIT    EQU    5           SECDED ID TABLE
 MTI4C    EQU    6           I4C PACKET STATUS
 MTNRB    EQU    7           ENTRY IN NON REGISTER STATUS BUFFER

*         EQUATES FOR BYTE OFFSETS IN MRB AFTER READ INTO CM.

 OCW1     EQU    CM+2
 OCW2     EQU    CM+3
 OCST     EQU    CM+1
 OBDP     EQU    CM+3
 OACUM4   EQU    CM+2
 OBP31    EQU    CM
 OBP32    EQU    CM+1
 OACUM3   EQU    CM+1
 OLSU     EQU    CM+2
 OIMAP    EQU    CM
 OEPN     EQU    CM+3
 OACUM2   EQU    CM+1

*         CONTROL MEMORY ADDRESS EQUATES.

 ACU.M2   EQU    0#800       FWA ACU M2 SCM
 ACU.M3   EQU    0#900       FWA ACU M3 SCM
 ACU.M4   EQU    0#A00       FWA ACU M4 SCM
 BDP.SCM  EQU    0#C00       FWA BDP SCM
 BP3.FWA  EQU    0#00        FWA OF BP3 TYPE CODE
 EPN.ETM  EQU    0#20        FWA EPN ERROR INFO TABLE
 EPN.SCM  EQU    0#00        FWA EPN SCM
 IDU.CIR  EQU    0#7000      FWA CURRENT INSTR REGISTER
 IDU.CSMM EQU    0#4000      FWA CS MULTIPLE MICRAND MEMORY
 IDU.CSSM EQU    0#5000      FWA CS SINGLE MICRAND MEMORY
 IDU.CW   EQU    0#6000      FWA CONTROL WORD
 INU.IBS  EQU    0#00        FWA INSTRUCTION BUFFER STACK
 INU.IMAP EQU    0#2000      FWA 170 AND 180 MAP MEMORY
 LSU.SCM  EQU    0#00        FWA LSU SCM
 SVA.BN   EQU    0#C00       SVA BYTE NUMBER

*         MODEL-DEPENDENT BUFFER EQUATES.

 MDBL     EQU    0#2D0       MODEL DEPENDENT BUFFER LENGTH
 MBIO     EQU    -12D        MDB INTERLOCK OFFSET
 MDB.IF   EQU    0#8000      MDB INTERLOCK FLAG MASK
 MDB.IM   EQU    0#7FFF      MDB INTERLOCK MASK
 MDB.IC   EQU    3           MDB INTERLOCK CODE
 MDB.NIT  EQU    1           NOT ISSUE TIMEOUT INTERLOCK CODE
 MDB.IT   EQU    2           ISSUE TIMEOUT INTERLOCK CODE
 MDB.MRB  EQU    0#25D
 MDB.HF   EQU    MDB.MRB+30D
 MDB.XP   EQU    MDB.HF+64D
 MDB.P    EQU    MDB.XP+52D
 MDB.CB   EQU    MDB.P+14

*         EQUATES FOR WORD OFFSETS FOR THE ELEMENT FIELDS IN THE DFT ERROR CONTROL RECORD.

 ECRID    EQU    0           IDENTIFIER
 ECRTH    EQU    1           CORRECTED/UNCORRECTED THRESHOLDS
 ECRM1    EQU    2           M1 BIT MASK
 ECRR1    EQU    3           R1 BITS TO SELECT
 ECRM2    EQU    4           M2 BIT MASK
 ECRR2    EQU    5           R2 BITS TO SELECT
 ECRES    EQU    ECRR2+1     ECR ELEMENT SIZE

*         EQUATES FOR ELEMENT IDENTIFIERS IN THE NON REGISTER STATUS BUFFER.

 DFTREID  EQU    0#4         DFT REPORTED ERRORS


*         INDICES FOR THE NON-REGISTER STATUS BUFFERS.

 NRSSB    EQU    0           SCRATCH BUFFER
 NRSTH    EQU    1           TOP OF HOUR BUFFER
 NRSSC    EQU    2           *SCI* BUFFER
 NRSFR    EQU    3           FIRST REGULAR USE BUFFER

*         EQUATES FOR CALL TO *2AP*.

 ORG2AP   EQU    20000B      MAXIMUM ADDRESS OF OVERLAY (ON S0/S0E)
 TOAP     EQU    2502B       LOAD ADDRESS FOR *2AP*
 TOAPS0   EQU    24000B      S0/S0E LOAD ADDRESS FOR *2AP*
 TOEP     EQU    2504B       ENTRY POINT FOR *2AP*
 TOEPS0   EQU    24002B      S0/S0E ENTRY POINT FOR *2AP*
 TOBP     EQU    2002B       START OF CTI BUFFER MINUS LINKAGE WORDS
 TOBPS0   EQU    22004B      S0/S0E CTI BUFFER MINUS LINKAGE WORDS
 TOIP     EQU    2000B       START OF CTI BUFFER FOR INPUT DATA
 TOIPS0   EQU    22000B      S0/S0E CTI BUFFER FOR INPUT DATA

*         REGISTER EQUATES.

 RGU.HF   EQU    0#100       HISTORY FILE
 PFS0     EQU    0#80        PFS REGISTER 81
 PFS4     EQU    0#84        PFS REGISTER 84
 PFS6     EQU    0#86        PFS REGISTER 86
 PFSB     EQU    0#8B        PFS REGISTER 8B
 PFSF     EQU    0#8F        PFS REGISTER 8F

*         FOLLOWING ARE EQUATES FOR THE DFT RUN TIME ERROR MESSAGES.

 DMC      EQU    0           RESET AND CONTINUE
 TDFT     EQU    1S12        TERMINATE DFT INDEX

*         FOLLOWING ARE EQUATES FOR DEREFERENCING THE DFT DEFINITION RECORD

 H77TBLC  EQU    20          NUMBER OF CM WORDS THE 77 TABLE USES
 H77TBLP  EQU    100         NUMBER OF 16 BIT PP WORDS THE 77 TABLE USES

 DBDH1    EQU    H77TBLP     DFT BUFFER DEFINITION HEADER WORD 1
 DBDH2    EQU    DBDH1+4     DFT BUFFER DEFINITION HEADER WORD 2
 DBDH3    EQU    DBDH1+10    DFT BUFFER DEFINITION HEADER WORD 3
 DBDH4    EQU    DBDH1+14    DFT BUFFER DEFINITION HEADER WORD 4
 DBDH5    EQU    DBDH1+20    DFT BUFFER DEFINITION HEADER WORD 5
 DBDHS    EQU    24          NUMBER OF PP WORDS IN DFT HEADERS

 DCWP0    EQU    H77TBLP+DBDHS   DFT BUFFER DEFINITION RECORD DFT CONTROL WORD PARCEL 0
 DCWP1    EQU    DCWP0+1     DFT BUFFER DEFINITION RECORD DFT CONTROL WORD PARCEL 1
 DCWP2    EQU    DCWP0+2     DFT BUFFER DEFINITION RECORD DFT CONTROL WORD PARCEL 2
 DCWP3    EQU    DCWP0+3     DFT BUFFER DEFINITION RECORD DFT CONTROL WORD PARCEL 3

 MDBSIZE  EQU    H77TBLP+2  DFT BUFFER DEFINITION RECORD MODEL DEP BUFFER SIZE
 STRSIZE  EQU    H77TBLP+3  DFT BUFFER DEFINITION RECORD TOTAL DFT STRUCTURE SIZE

*         PACKET CONTROL WORD EQUATES FOR USE IN *CELCW*, *PKTCW* AND *DI4CW*.

 PKWRP    EQU    0#8000      PACKET RESPONSE PENDING
 PKWTO    EQU    0#4000      PACKET TIME OUT
 PKWIU    EQU    0#2000      PACKET IN USE
          SPACE  4,10
          ENDX
*DECK DECK=CTC$DFT_DIRECT_CELLS EXPAND=FALSE
          EJECT
*         CTEXT CTC$DFT_DIRECT_CELLS
          TITLE  DIRECT LOCATION ASSIGNMENTS.
 CELLS    SPACE  4,10
****      DIRECT LOCATION ASSIGNMENTS.
*
*         NOTE THAT CERTAIN DIRECT CELLS HAVE SPECIAL USAGE
*         EARLY IN *DFT* PRESET SINCE THEY CONTAIN HANDOFF VALUES
*         FROM EITHER *SCI* OR *DFT* ITSELF (WHEN STARTING UP
*         DFT-S).


 T0       EQU    0
 T1       EQU    1
 T2       EQU    2
 T3       EQU    3
 T4       EQU    4
 T5       EQU    5
 T6       EQU    6
 T7       EQU    7
 CM       EQU    10 - 13
 BC       EQU    14 - 17
 SN       EQU    20          OFFSET TO SUBROUTINE NAMES
 SS       EQU    21          4/STATUS, 12/COMPOSITE STATUS SUMMARY
 JT       EQU    22 - 25     JOB TYPE FOR 180 REQUESTS
 TF       EQU    26          TEMPORARY FLAG
 FE       EQU    27          TEMPORARY FLAG
 W0       EQU    30          WORKING STORAGE
 W1       EQU    31
 W2       EQU    32
 W3       EQU    33
 W4       EQU    34
 W5       EQU    35
 W6       EQU    36
 W7       EQU    37
 RS       EQU    40 - 43     MODEL DEPENDENT BUFFER POINTER
 BW       EQU    44 - 47     BUFFER CONTROL WORDS POINTER
 EI       EQU    50          ELEMENT INDEX
 ET       EQU    51          ELEMENT TYPE
 RN       EQU    52          MAINTENANCE REGISTER NUMBER
 DO       EQU    53          DIRECTORY OFFSET
 DP       EQU    54 - 56     DFT BLOCK POINTER
 EC       EQU    57          ELEMENT CONNECT CODE
 CP       EQU    60          PROCESSOR NUMBER
 HP       EQU    61 - 62     HARDWARE TABLE POINTER
 MD       EQU    63          MODEL OF HARDWARE ELEMENT
 PO       EQU    64          MEMORY PORT OFFSET
 ST       EQU    65          LAST OVERLAY USED INDEX
 IB       EQU    66 - 70     INTERFACE BLOCK POINTER
          ORG    70
          CON    0           IOU DESIGNATOR AT START UP (SET FOR DFT-S)
 DH       EQU    71 - 73     DIRECTORY POINTER
          ORG    74
 ON       CON    1           CONSTANT ONE
 MP       CON    0,0,0       MAINTENANCE REGISTER BUFFER POINTER
          ORG    100
 CONS     SPACE  4,10
*         ASSEMBLY CONSTANTS.


 RR       EQU    400000      R-REGISTER ACTIVATOR
 CH       EQU    10          DUMMY CHANNEL NUMBER FOR DUMP/LOAD/IDLE ROUTINES

*         END DECK CTC$DFT_DIRECT_CELLS
*DECK DECK=CTC$DFT_ELEMENT_CONVERSIONS EXPAND=FALSE
*         CTEXT  CTC$DFT_ELEMENT_CONVERSIONS
*
*         THIS DECK HOLDS CONSTANTS TO CONVERT THE CTI  ELEMENT NAMING
*         CONVENTION TO THE HARDWARE NAMING CONVENTION.

*         CONVERSION TABLE ELEMENT ID TO CTI ELEMENT

 ETYP     CON    2           EID VALUE 0 = CPU 0 = CTI VALUE 2
          CON    1           EID VALUE 1 = CM = CTI VALUE 1
          CON    0           EID VALUE 2 = IOU = CTI VALUE 0
          CON    3           PSEUDO EID VALUE 3 = PAGE MAP = CTI VALUE 3
          CON    4           PSEUDO EID VALUE 4 = DFT ERROR = CTI VALUE 4
          CON    4           PSEUDO EID VALUE 4 = DFT ERROR = CTI VALUE 4
          CON    4           PSEUDO EID VALUE 4 = DFT ERROR = CTI VALUE 4

*         TABLE OF ORDINAL VALUES FOR SYSTEM ELEMENTS

 OTYP     CON    IOUO        ORDINAL 0,1
          CON    0           NO ORDINAL BEYOND 0
          CON    CPUO        ORDINAL 0,1
          CON    0           NO ORDINAL BEYOND 0
          CON    0           NO ORDINAL BEYOND 0
          CON    0           NO ORDINAL BEYOND 0
          CON    0           NO ORDINAL BEYOND 0

*         END    CTC$DFT_ELEMENT_CONVERSIONS
*DECK DECK=CTC$DFT_GLOBAL_DATA EXPAND=FALSE
          TITLE  GLOBAL DATA LOCATIONS.
*         CTEXT CTC$DFT GLOBAL DATA.
 GLOBAL   SPACE  4,10
****      GLOBAL DATA ITEMS.

 TFLG     CON    0           DELAY TIMING FLAG
 PDSO     CON    0           TOGGLE FOR DUMPING PP REGISTERS
 RDATA    BSS    10B         MAINTENANCE REGISTER BUFFER
 SHRR     CON    0           SHORT WARNING ERROR FLAG
 PERR     CON    0           ENVIRONMENT WARNING FLAG
 CTIB     CON    0           CTI BUFFER
 CTIBR    CON    0           CTI BUFFER RETURNED FROM *2AP*
 SUMS     CON    0           SUMMARY STATUS REGISTER
 OLSS     CON    0           OLD SUMMARY STATUS
 PPNO     CON    0           8/PP TYPE, 8/DFT PP NUMBER
 CPSA     CON    0           NONZERO IF TIME TO CHECK PACKET STATUS
 FNUM     CON    0           FILE NUMBER FOR CONSOLE LOGGING
 FSIZ     CON    0           FILE SIZE FOR CONSOLE LOGGING
 L2AP     CON    1           FORCE *2AP* TO BE LOADED ON NEXT CALL TO *ECM*
 MRTU     CON    0           MRT UPDATE NEEDS TO BE WRITTEN TO S0/S0E CONSOLE
 RST1     CON    0           RESIDENT TEMPORARY SAVE AREA
 SYCD     CON    0           SYNDROME CODE
 R170     CON    0           FLAG FOR 170 REQUESTS
 TIMA     CON    0           1 MILLISECOND COUNTER
 TIMB     CON    0           MILLISECOND COUNTER RESET EVERY SCAN
 CRQA     CON    0           TIMER FOR *SCI* RELOCATION
 SBER     CON    0,0         ADDRESS OF SINGLE BIT ERROR
 CPUO     CON    0           CPU ORDINAL WITHIN *HBUF*
 CPUH     CON    0           CPU ORDINAL HALTED BY *APE* OVERLAY
 IOUO     CON    0           IOU ORDINAL WITHIN *HBUF*
 IOSS     CON    0           4/STATUS, 12/COMPOSITE STATUS SUMMARY
 IOUN     CON    0           4/NUMBER OF IOU-S - 1,12/NUMBER OF CURRENT IOU (0,1)
 DFTD     CON    0           ISSUE TIME OUT MESSAGE FLAG
 MBPS     CON    0           MEMORY BOUNDS PORT SELECT
 S0FLG    CON    0           S0/S0E FLAG (1 = S0/S0E, 0 = OTHER)
 S0PMC    CON    0           S0/S0E PAGE MAP CONNECT CODE (0 ON OTHER MODELS)
 UETV     CON    0           TIME TO UPDATE EICB
 DRCR     CON    0           DFT RELOCATION CHECK REQUIRED
 ELMO     CON    0           ELEMENT ORDINAL FOR SEARCHES
 DFTA     CON    0           DFT ACTION LIST
 TERT     CON    0           TERMINATE TASK FLAG
 EIEF     CON    0           EXPECTED IOU ERROR FLAG
 RLST     CON    0           CORRECTED/UNCORRECTED REGISTER LIST FLAG
 CALB     BSSZ   10          *2AP* CALL BLOCK AREA
 NERR     CON    0           NO ERROR ENCOUNTERED ON A PASS
 UMEM     CON    0           UPDATE THE *2AP* DATA AND OVERLAYS IN MEMORY
 UWCC     CON    0           UPDATE WALL CLOCK CHIP (0=DEFAULT=YES)
 STIM     CON    0           TIME TO COUNT DOWN TO SO AS TO TRIGGER AN EVENT
 TIMU     CON    0           TIME DELAY IS UP
 TENV     CON    0           TIMING ON AN ENVIRONMENT ERROR
 DTEW     CON    0           FLAG DENOTING DONE TIMING AN ENVIRONMENT WARNING  (0=DONE)
 TSIT     CON    0           TIME TO CHECK *SIT*
 NSIT     CON    0           NUMBER OF TIMES *SIT* WAS < -2 SECONDS
 BATT     CON    0           FLAG INDICATING RUNNING ON BATTERY
 PKCT     CON    0           COUNT OF NUMBER OF TIMES DUAL I4 PACKETS TRIED
 PPTY     CON    1           PP TYPE (0 = UPPER PP)
 RTP1     CON    0           RESIDENT TEMPORARY CELL 1
 RTP2     CON    0           RESIDENT TEMPORARY CELL 2
 JOBF     CON    0           180 JOB TASK ERROR FLAG
 JOBS     CON    0,0,0,0     JOB STATUS SAVED ACROSS *2AP* CALLS
 CHEF     CON    0           CPU/PP HANDSHAKING TIMEOUT FLAG (=6 IF MONITOR TIMEOUT)
 VOSD     CON    0           VALID OS DATA FLAGS ACCUMULATED DURING PROCESSING ERROR(S)
                             ON A HARDWARE ELEMENT. THE TWO FLAGS ACCUMULATED ARE THE
                             V7, AND V8 FLAGS FROM THE BUFFER CONTROL WORDS
 REGI     CON    0           REGISTER LIST INDEX FOR BUILD REGISTER LIST
 REGL     BSSZ   MAXRL       REGISTER LISTS TO BE PROCESSED BY *RMR*
 ISPB     CON    0           FLAG DENOTING WHETHER TO IGNORE OS BOUNDS SETTING
 DSIF     CON    0           FLAG DENOTING WHETHER OR NOT DFT SET THE I/L ON A BUFFER CNTRL WD
 ERRC     CON    0           ERROR CODE PASSED TO ERROR HANDLING OVERLAY
 LLOG     CON    0           LENGTH TO LOG IN THE NON REGISTER STATUS BUFFER
 DTLA     CON    0           DEGRADE CPU TASK LIST ADDRESS
 STON     CON    0           STUCK ON ERROR CONDITION FLAG
 REDF     CON    0           FLAG TO INDICATE WHETHER TO READ EPM DATA

*         THE FOLLOWING CELLS HOLD INFORMATION NECESSARY TO
*         ACCOMPLISH THE CALL MECHANISM USED. A TWO WORD STACK
*         IS USED TO SAVE THE OVERLAY NUMBER AND RETURN ADDRESS
*         OF A CALLER.

 OVLS     BSS    1           COUNT OF OVERLAYS ACTUALLY LOADED
 CUOV     CON    0           CURRENT OVERLAY LOADED
 STKL     EQU    11+1        CURRENTLY 11B CALL LIMIT ALLOWED
 STAK     BSSZ   2*STKL-2    CALLERS STACK (11B CALLS - EACH TWO WORDS)
 STKD     BSSZ   1           CURRENT STACK DEPTH

*         FOLLOWING IS NEEDED FOR GET HARDWARE ELEMENT ROUTINES.

          BSSZ   3           SLACK FOR ENTRY
 HBUF     BSSZ   CMXLEN      HARDWARE ELEMENT BUFFER
 ACTB     SPACE  4,10
**        ACTB - ACTIVATION TABLE.
*
*         THE FOLLOWING TABLE IS USED BY ROUTINE *TIM* TO DETERMINE
*         WHICH ROUTINES TO CALL ON A PERIOD OF MILLISECONDS BASIS.
*         THE TABLE CONSISTS OF THREE WORD ENTRIES IN THE FOLLOWING
*         FORMAT.
*
*         16/ROUTINE TO CALL, 16/CALL TIME INTERVAL, 16/ELAPSED TIME.

 ACTB     BSS    0           TABLE OF TIMED ROUTINES

          CON    SEC,1000D/5,0  PROCESS ONCE-PER-SECOND EVENTS
 ACTB1    CON    HTO,105D/5,0   DELAY FOR TRANSIENTS 100 MILLISECONDS
                                + 5 MILLISECONDS FOR GOOD MEASURE
          CON    IHS,5000D/5,0  INITIATE CPU/PP HANDSHAKING EVERY 5 SECONDS
          CON    DPD,30000D/5,0 INITIATE DUMPING OF PP REGISTERS EVERY 30 SECONDS
 ACTBL    EQU    *

*         THE FOLLOWING DATA IS SAVED IN THE DFT BUFFER IN
*         NON-DEDICATED MODE.
*
*         NOTE: THIS AREA MUST BE A MULTIPLE OF CM WORDS IN SIZE.

 SAVE     BSS    0           START OF SAVE AREA
 DHSV     CON    0,0,0       DIRECTORY POINTER
 ELCO     CON    0           TOTAL NUMBER OF ELEMENTS IN MAINFRAME
 FREE     CON    0           LAST OBTAINED MR BUFFER ENTRY
 SWEP     CON    0           OFFSET TO SHORT WARNING ENTRY
 PWEP     CON    0           OFFSET TO POWER WARNING ENTRY
 LBUF     CON    0           LENGTH OF MAINTENANCE REGISTER BUFFERS
 NBUF     CON    0           NUMBER OF MAINTENANCE REGISTER BUFFERS
 MLIT     CON    0           MICROCODE LONG INIT ADDRESS
 MIDL     CON    0           MICROCODE PROCESSOR IDLE ADDRESS
 HEOM     CON    0           MICROCODE HALF EXCHANGE OUT MONITOR ADDRESS
 HEOJ     CON    0           MICROCODE HALF EXCHANGE OUT JOB ADDRESS
 HEIM     CON    0           MICROCODE HALF EXCHANGE IN MONITOR ADDRESS
 HEIJ     CON    0           MICROCODE HALF EXCHANGE IN JOB ADDRESS
 WARC     CON    0           NUMBER OF TIMES *1MB*/*1MR* CALLED WITH WARNING
 WARN     CON    0           ENVIRONMENT OR POWER WARNING ENCOUNTERED
 VRSN     CON    0           VERSION IN DFT HEADER CONTROL WORD
 NUMHW    CON    0           NUMBER OF HEADER WORDS - DFT HEADER + POINTERS
 IOUM     CON    0           IOU MODEL
 I0CC     CON    0           IOU CONNECT CODE
 IO0C     CON    0           IOU CORRECTED ERROR REGISTER LIST
 IO0U     CON    0           IOU UNCORRECTED ERROR REGISTER LIST
 MEMM     CON    0           MEMORY MODEL
 CMCC     CON    0           MEMORY CONNECT CODE
 ME0C     CON    0           MEMORY CORRECTED ERROR REGISTER LIST
 ME0U     CON    0           MEMORY UNCORRECTED ERROR REGISTER LIST
 NPERR    CON    0           NUMBER OF CH15 PARITY ERRORS READING WALL CLOCK CHIP

*         PACKET RELATED DATA.

 PKFLG    CON    0           1, IF PACKETS ARE SUPPORTED ON MAINFRAME
 PKSEQ    CON    0           LAST PACKET SEQUENCE NUMBER
 TCPU     SPACE  4,10
**        TCPU - TABLE OF CPU INFORMATION.
*
*         THE ENTRIES IN THIS TABLE MAY EITHER BE ACCESSED
*         INDIVIDUALLY BY NAME OR BY INDEXING INTO THE TABLE.
*         WHEN INDEXING INTO THE TABLE, IT IS TO BE THOUGHT OF
*         AS A TWO DIMENSIONAL ARRAY:  TCPU[I,J] WHERE J
*         INDICATES THE CPU FOR WHICH INFORMATION IS DESIRED
*         AND I IS ONE OF THE INDICIES:  CPUM, CPUC, CPUP, CPUR, CPUU.


 TCPU     BSS    0           START OF TABLE
 CPU0M    CON    0           CPU0 MODEL
 CP0CC    CON    0           CPU0 CONNECT CODE
 CP0P     CON    0           CPU0 MEMORY PORT
 CP0C     CON    0           CPU0 CORRECTED REGISTER LIST ADDRESS
 CP0U     CON    0           CPU0 UNCORRECTED REGISTER LIST ADDRESS
 CPNR     EQU    *-TCPU      NUMBER OF ROWS IN ARRAY
 CPU1M    CON    0           CPU1 MODEL
 CP1CC    CON    0           CPU1 CONNECT CODE
 CP1P     CON    0           CPU1 MEMORY PORT
 CP1C     CON    0           CPU1 CORRECTED REGISTER LIST ADDRESS
 CP1U     CON    0           CPU1 UNCORRECTED REGISTER LIST ADDRESS

 CPUM     EQU    CPU0M-TCPU  ROW OFFSET TO CPU MODEL NUMBER
 CPUC     EQU    CP0CC-TCPU  ROW OFFSET TO CPU CONNECT CODE
 CPUP     EQU    CP0P-TCPU   ROW OFFSET TO CPU MEMORY PORT
 CPUR     EQU    CP0C-TCPU   ROW OFFSET TO CPU CORRECTED REGISTER LIST ADDRESS
 CPUU     EQU    CP0U-TCPU   ROW OFFSET TO CPU UNCORRECTED REGISTER LIST ADDRESS
          ERRNZ  CPUM-CPU1M+TCPU+CPNR  MODEL NUMBER OUT OF POSITION
          ERRNZ  CPUC-CP1CC+TCPU+CPNR  CONNECT CODE OUT OF POSITION
          ERRNZ  CPUP-CP1P+TCPU+CPNR   MEMORY PORT OUT OF POSITION
          ERRNZ  CPUR-CP1C+TCPU+CPNR   CORRECTED REGISTER LIST ADDRESS OUT OF POSITION
          ERRNZ  CPUU-CP1U+TCPU+CPNR   UNCORRECTED REGISTER LIST ADDRESS OUT OF POSITION

 NNRB     CON    0           NUMBER OF NON REGISTER BUFFERS
 SNRB     CON    0           SIZE OF A NON REGISTER BUFFER
 TOHI     CON    LGC3        STARTING ADDRESS FOR TOP OF HOUR PROCESSING FOR VERSION 5
 LOGB     CON    0           ORDINAL OF AVAILABLE BUFFER TO LOG TO
 CMP0     CON    0           CPU 0 MEMORY PORT
 CMP1     CON    0           CPU 1 MEMORY PORT
 PAD      CON    0,0         PAD TO MULTIPLE OF CM WORDS
 SAVL     EQU    *-SAVE      LENGTH TO SAVE
          ERRNZ  SAVL/4*4-SAVL  MUST BE MULTIPLE OF CM WORDS
****

*         END DECK CTC$DFT_GLOBAL_DATA

*DECK DECK=CTC$DFT_GLOBAL_DATA_NON_S0 EXPAND=FALSE
*         CTEXT CTC$DFT GLOBAL DATA NON S0.
 TOUB     CON    TOBP        *2AP* OUTPUT BUFFER ADJUSTED FOR LINKAGE BYTES
 TINB     CON    TOIP        *2AP* INPUT BUFFER
 MPSR     CON    PMPS        *MPS* REGISTER NUMBER
 JPSR     CON    PJPS        *JPS* REGISTER NUMBER
 CSAR     CON    PCSA        *CSA* REGISTER NUMBER

*         END DECK CTC$DFT_GLOBAL_DATA_NON_S0
*DECK DECK=CTC$DFT_MACROS EXPAND=FALSE
          EJECT
          TITLE  MACRO DEFINITIONS.
*         CTEXT CTC$DFT MACROS.
*
*         THIS DECK DEFINES ALL MACROS USED BY DFT.
*
 CALL     SPACE  4,10
**        CALL - LOAD NECESSARY OVERLAY AND EXECUTE ROUTINE.
*
*         GIVES CONTROL TO A ROUTINE IN THE SAME OR A DIFFERENT
*         OVERLAY.  WHEN THAT ROUTINE COMPLETES, CONTROL RETURNS
*         TO THE STATEMENTS FOLLOWING THIS MACRO.  NOTE THAT *CALL*
*         CANNOT SAFELY BE USED WITHIN A *SUBR*-DEFINED SUBROUTINE
*         OR IF OVERLAY-RESIDENT DATA LOCATIONS ARE DEFINED, SINCE
*         THE ORIGINAL OVERLAY MAY HAVE TO BE RELOADED AFTER THE
*         CALLED OVERLAY (AND ANY OVERLAYS CALLED BY THAT OVERLAY)
*         HAVE COMPLETED.  ALSO, *CALL* MAY NOT BE USED BY ANY
*         ROUTINE DIRECTLY INVOKED BY *TIM* OR A RECURSIVE CALL WILL
*         OCCUR LEADING TO STACK OVERFLOW.
*
*         CALL   RTN
*
*         RTN = NAME OF CORRESPONDING ROUTINE TO CALL.


          PURGMAC  CALL
 CALL     MACRO  NAME
          LDC    NAME_E+NAME_O*10000
          RJM    LNO
          ENDM
 ROUTINE  SPACE  4,10
**        ROUTINE - DEFINE ENTRY POINT FOR CALL MACRO.
*
*         ROUTINE RNAME
*
*         RNAME = NAMED ENTRY POINT.
*
*         NOTE:  PLACE THIS MACRO AFTER DSI$PP_MACROS CALL.

          PURGMAC ROUTINE
 ROUTINE  MACRO  RNAME,NG
          IFC    EQ,$NG$$,1
          QUAL
 RNAME_E  BSS    0
 RNAME_O  EQU    OVLN
          IFC    EQ,$NG$$,1
          QUAL   *
 RNAME_X  EQU    LNOF
          ENDM
*COPYC DSI$MAINTENANCE_REGISTER_MACROS
 MACROS   SPACE  4,10
**        MACRO DEFINITIONS.
*
*         THE FOLLOWING MACROS ARE USED IN BUILDING THE
*         BUFFER CONTROL WORD FOR DFT.
*
*         NOTE:  THESE MACROS EXPECT DIRECT CELLS FOR A CM WORD TO BE
*                DEFINED AT TAG *BC*.
*
*                THESE MACROS ALSO EXPECT COMMON DECK CTC$DFT_CONSTANTS
*                TO BE PRESENT.
*
*                ALSO DIRECT CELL *EI*,AND *DFTA* MUST BE DEFINED.
 BUILDRG  SPACE  4,10
**        BUILDRG - BUILD REGISTER LIST.
*         BUILDS CORRECTED OR UNCORRECTED REGISTER LIST TO BE
*         PROCESSED BY READ MAINTENANCE REGISTER.
*
*         CALL FORMAT    BUILDRG RLIST
*
*         USES   *REGI*, *REGL*, T1.
*
*         CALLS  *RMR*.


          PURGMAC  READRG
 BUILDRG  MACRO  RLIST
          LDC    RLIST
          RJM    BRL
          ENDM
 CHECK    SPACE  4,10
**        CHECK - DETERMINE WHICH OS SHOULD PROCESS ERROR.
*         CHECKS WHETHER THE *E7* OR *E8* FLAG IN THE DFT HEADER
*         SHOULD BE SET BASED ON WHAT OS SHOULD PROCESS THE ERROR.
*
*         CHECK  OS
*
*         OS = *E8* OR *E7* TO SPECIFY WHICH OS SHOULD PROCESS THE
*                ERROR.
*
*         USES   CM - CM+3.
*
*         CALLS  IDA.


          PURGMAC  CHECK
 CHECK    MACRO  OS
          LOCAL  C,D
          LDN    HDRP
          RJM    IDA
          CRDL   CM
          LDDL   CM+DHFLG
          SHN    21-DH.F_OS
          MJN    D           IF VALID DATA FOR SPECIFIED OS ALREADY SET
          LDDL   CM+DHFLG
          SHN    21-DH.FL
 .OS      IFC    EQ,$OS$E8$
          PJN    C           IF 180 LOGGING
 .OS      ELSE
          MJN    C           IF 170 LOGGING
 .OS      ENDIF
          LDML   VOSD
 .OS1     IFC    EQ,$OS$E8$
          SHN    21-BC.FV8
 .OS1     ELSE
          SHN    21-BC.FV7
 .OS1     ENDIF
          MJN    C           IF VALID DATA FOR SPECIFIED OS
          LDN    CM          CLEAR FLAGS IN DFT HEADER
          RJM    SET
          LMBC   DH.F_OS
          STDL   CM+DHFLG
          LDN    HDRP
          RJM    IDA
          RDCL   CM
          UJN    D

 C        LDN    CM          SET FLAGS IN DFT HEADER
          RJM    CLR
          LMBC   DH.F_OS
          STDL   CM+DHFLG
          LDN    HDRP
          RJM    IDA
          RDSL   CM
 D        BSS    0
          ENDM
 READRG   SPACE  4,10
**        READRG - READ REGISTER LIST.
*         READS CORRECTED OR UNCORRECTED REGISTER LIST INTO
*         SCRATCH MAINTENANCE BUFFER REGISTER.
*
*         READRG RLIST
*
*
*         CALLS  *RMR*, *BRL*.


          PURGMAC  READRG
 READRG   MACRO  RLIST
          LDC    RLIST
          RJM    BRL
          CALL   RMR
          ENDM
 REGLST   SPACE  4,10
**        REGLST - DEFINE LIST OF REGISTERS TO BE LOGGED.
*
* NAME    REGLST (RN1,RN2,RN3...)
*
*         NAME = NAME OF LIST.
*         RN(I) = LIST OF REGISTERS TO LOG.


          PURGMAC  REGLST
          MACRO  REGLST,NAME,(RLIST)
          LOCAL  SIZE
 NAME     CON    SIZE
          LIST   G
          IRP    RLIST
          CON    0#_RLIST
          IRP
          LIST   *
 SIZE     EQU    *-NAME-2
          ENDM
 SETDAC   SPACE  4,10
**        SETDAC - SET DFT ACTION CODE.
*
*         SETDAC ACTION
*
*         ACTION = ADDRESS OF DFT ACTION ROUTINE TO EXECUTE.
*
*         USES   DFTA.


          PURGMAC  SETDAC
 SETDAC   MACRO  ACTION
          LDC    ACTION
          STM    DFTA
          ENDM
 SETDAN   SPACE  4,10
**        SETDAN - SET DFT ANALYSIS CODE.
*         SET DFT ANALYSIS CODE IN THE SCRATCH BUFFER CONTROL WORD.
*
*         SETDAN DANAL
*
*         DANAL = ERROR PRIORITY AND DFT ANALYSIS CODE.
*
*         NOTE   THIS MACRO PRESERVES AN EXISTING OS ACTION CODE IN
*                THE BUFFER CONTROL WORD ENTRY.
*
*         USES   BC, ET.


          PURGMAC  SETDAN
 SETDAN   MACRO  DANAL
 V        SET    0
          ECHO   ,M=(0#1000,1),B=(DANAL)
 V        SET    M*B+V
          ENDD
          LDD    ET
          SHN    BC.ANE
          ADK    V
          STDL   BC+BCDA
          LDDL   BC+BCEI
          LPC    0#00FF
          STDL   BC+BCEI
          LDD    EI
          SHN    BC.EI
          LMDL   BC+BCEI
          STDL   BC+BCEI
          ENDM
 SETFLG   SPACE  4,10
**        SETFLG - SET BUFFER CONTROL WORD FLAGS.
*         SETS SPECIFIED FLAGS WHICH ARE REASONABLE IN THE ENVIRONMENT
*         (CYBER 170 STANDALONE, DUAL STATE, CYBER 180 STANDALONE).
*
*         SETFLG (F1,F2,..FN)
*
*         FN = ONE OR MORE OF THE FOLLOWING FLAGS -
*                *BC.CL* = LOG ERROR TO CONSOLE
*                *BC.FL* = LOG ERROR TO OS ERROR LOG
*                *BC.FI* = SET INTERLOCK
*                *BC.F8* = CYBER 180 VALID DATA
*                *BC.F7* = CYBER 170 VALID DATA
*
*         CALLS  CKF.


          PURGMAC  SETFLG
 SETFLG   MACRO  FLAGS
          MACREF SETFLG
          LCN    0
          LMBC   (FLAGS)
          LPDL   BC+BCFLG
          LMBC   (FLAGS)
          STDL   BC+BCFLG
          RJM    CKF         CHECK FLAGS FOR APPLICABILITY
          ENDM
 SETOSA   SPACE  4,15
**        SETOSA - SET OS ACTION CODE.
*         SET OS ACTION CODE IN THE SCRATCH BUFFER CONTROL WORD.
*         IF VERSION <= 3, USE THE OLD OS ACTION CODE.  IF VERSION >= 4,
*         USE THE NEW OS ACTION CODE.
*
*         SETOSA OSA,NOSA
*
*         OSA = OLD OS ACTION CODE (VERSION 3 OR LESS).
*         NOSA = NEW OS ACTION CODE (VERSION 4).
*
*         CALLS  VCK.
*
*         NOTE   THIS MACRO PRESERVES AN EXISTING ELEMENT INDEX IN THE
*                BUFFER CONTROL WORD ENTRY.


          PURGMAC  SETOSA
 SETOSA   MACRO  OSA,NOSA
          LOCAL  A,B
          LDDL   BC+BCEI
          LPC    0#FF00
          STDL   BC+BCEI
          LDN    VER4        CHECK VERSION NUMBER
          RJM    VCK
          PJN    A           IF VERSION 4 OR GREATER
          LDK    OSA         USE OLD OS ACTION CODE
          UJN    B           STORE CODE

 A        LDK    NOSA        USE NEW OS ACTION CODE
 B        RADL   BC+BCEI
          ENDM
 TASK     SPACE  4,10
**        TASK - DEFINE ROUTINES TO BE USED TO PERFORM A TASK.
*         LIST OF ROUTINES WHICH WHEN EXECUTED ACCOMPLISHES A
*         MORE COMPLEX GOAL. WHEN THE TASK TERMINATES, CONTROL PASSES
*         TO *EXTR*.
*
*         TASK   (RTN1,RTN2,...RNTN)
*
*         RTN(I) = ROUTINE TO CALL.


          PURGMAC  TASK
 TASK     MACRO  TLIST
          LOCAL  TASK1
          IRP    TLIST
          CALL   TLIST
          LDM    TERT
          NJP    TASK1       IF TERMINATE TASK = TRUE
          IRP
          LJM    EXTR        END OF TABLE

 TASK1    LDN    0
          STM    TERT        RESET FLAG TO DEFAULT
          LDM    DFTA
          STD    T1
          LJM    0,T1        EXECUTE NEW TASK LIST
          ENDM

*         END OF CTC$DFT MACROS
*DECK DECK=CTC$DFT_MDB_LOGGING_CONSTANTS EXPAND=TRUE
          EJECT
*         CTEXT  CTC$DFT_MDB_LOGGING_CONSTANTS
*
*         J.M. SKOWRONEK     09/25/87.
*
*         THIS DECK IS USED WITH CTP$DFT_LOGGING_ROUTINES

          LIST   X

*         VERSION 4 MODEL DEPENDENT EQUATES.

*         MDB OVERFLOW OFFSET

 OFFO     EQU    2           MDB OVERFLOW OFFSET

*         MDB MAIN HEADER EQUATES.

 V4DHCWD  EQU    0           CW WORD OFFSET
 V4DHPRI  EQU    1           ERROR PRIORITY OFFSET
 V4DHLTL  EQU    3           LENGTH TO LOG OFFSET

*         VERSION 4 ERROR PRIORITIES.

 V4EPRT   EQU    1           ERROR RETRY OPERATION
 V4EPOT   EQU    2           OTHER ERROR
 V4EPIT   EQU    3           ISSUE TIMEOUT

*         BUFFER CONTROL WORD FIELD EQUATES.

 V4BCOST  EQU    3           BUFFER CONTROL WORD OFFSET FIELD

*         BUFFER CONTROL WORD FLAG BIT ASSIGNMENTS.

 BCW.IT   EQU    4           INTERLOCK BIT
 BCW.VD   EQU    0#40        VALID DATA BIT

*         SUPPORTIVE STATUS BUFFER EQUATES.

 V4SBSIZ  EQU    3           SSB HEADER ELEMENT SIZE
 V4SBLOG  EQU    2           LOG AND ORDINAL OFFSET

*         SUPPORTIVE STATUS BUFFER LOG BIT EQUATES.

 SSB.UL   EQU    0#100       UNLOGGABLE
 SSB.OW   EQU    0#200       OVERWRITE

*         THE FOLLOWING CELLS HOLD INFORMATION NECESSARY FOR VERSION 4 DFT.

 CEPR     CON    0           CURRENT ERROR PRIORITY
 LTOL     CON    0           LENGTH OF DATA TO LOG FOR CURRENT ERROR
 OFFF     CON    0           OFFSET FLAG
 CWDC     CON    0           CPU MDB CW WORD
 CWDO     CON    0           OVERFLOW MDB CW WORD
 EPRO     CON    0           ERROR PRIORITY OF OVERFLOW MDB
 BCWF     CON    0           BUFFER CONTROL WORD WRITE FLAG
 MDBW     CON    0           MDB WRITE
 HDAD     CON    0,0,0       MAIN HEADER ADDRESS FOR MDB IN USE
 ITUF     CON    0           UNLOGGABLE FLAG FOR ISSUE TIME OUT
 SHWD     CON    0,0,0,0     SUB HEADER WORD DATA BLOCK
 MFLG     CON    0           ERROR MATCH FLAG

*         END OF DECK CTC_DFT_MDB_LOGGING_CONSTANTS
*DECK DECK=CTC$EI_CONTROL_BLOCK EXPAND=FALSE
          CTEXT  CTC$EI CONTROL BLOCK
          SPACE  4,10
**        CTC$EI CONTROL BLOCK.
*
*         DEFINES THE EI CONTROL BLOCK OFFSETS.


 EICBP    EQU    71B         POINTER TO EICB
 EICL     EQU    5S6         EICB LEVEL

          MACRO  EICBW,NAME,SIZE
 NAME     EQU    N.EICB
 N.EICB   SET    N.EICB+SIZE
          ENDM
 N.EICB   SET    0


 D7TY     EICBW  1           C170 OPERATING SYSTEM TYPE
 D7JP     EICBW  2           C170 JOB INFORMATION
 D7ST     EICBW  1           C170 OPERATING SYSTEM STATUS
 D7RS     EICBW  3           RESERVED
 D7CM     EICBW  2           CENTRAL MEMORY ALLOCATION
 D7SV     EICBW  6           C170 SAVE AREA

 D8TY     EICBW  1           C180 OPERATING SYSTEM TYPE
 D8TM     EICBW  2           TIME SPENT IN C180 OS
 D8JP     EICBW  2           C180 JOB PARAMETERS
 D8ST     EICBW  1           C180 OPERATING SYSTEM STATUS
 D8DS     EICBW  3           C180 DEADSTART WORDS
 D8SV     EICBW  6           C180 OS SCRATCH AREA

 DSCM     EICBW  5           SYSTEM WIDE STATUS
 DFCM     EICBW  11D         DFT MESSAGE BUFFER
 EICBL    EQU    N.EICB
          SPACE  4,10
**        OFFSETS WITHIN THE C180 PORTION OF THE BLOCK.


 D8SSR    EQU    D8SV+1      R-POINTER TO THE SSR
          SPACE  4,10
**        OFFSETS WITHIN THE *DSCM* PORTION OF THE BLOCK.


 DSEBP    EQU    DSCM+2      EI BUFFER R-POINTER
 DSDFT    EQU    DSCM+3      DFT BLOCK R-POINTER
          SPACE  4,10
**        OFFSETS WITHIN THE *DFCM* PORTION OF THE BLOCK.


 D8WT     EQU    DFCM+7      PACKED WALL CLOCK CHIP TIME
 D8CPT    EQU    DFCM+8D     CRITICAL PAGE TABLE POINTER
 D8RLP    EQU    DFCM+9D     DFT/SCI RELOCATION CONTROL POINTER
 D8WC     EQU    DFCM+10D    SCI OVERLAY LOADS, CM/MR WRITES
          SPACE  4,10
          ENDX
*DECK DECK=CTC$ELEMENT_DESCRIPTOR_DEF EXPAND=FALSE
          CTEXT  CTC$ELEMENT DESCRIPTOR DEF.
          BASE   M
 CTCEDD   SPACE  4,10
***       CTC$ELEMENT DESCRIPTOR DEF.
*
*         THIS COMMON DECK DEFINES THE VARIOUS ELEMENT DESCRIPTORS THAT ARE
*         RETURNED BY THE SERVICE PROCESSOR *DFT* IN RESPONSE TO THE *DFT*
*         REQUEST, GET ELEMENT DESCRIPTION (TASKID = 37(8)).
*
*         WITH THE EXCEPTION OF THE SUB-ELEMENTS AND THE DESCRIPTOR LENGTHS,
*         ALL EQUATES ARE PP WORD OFFSETS.
          SPACE  4,10
**        IOU ELEMENT DESCRIPTOR.

 EDIOEN   EQU    0           ELEMENT NUMBER
 EDIOMN   EQU    0           MODEL NUMBER
 EDIOSN   EQU    1           SERIAL NUMBER
 EDIOS    EQU    2           IOU STATE

*         IOU ELEMENT DESCRIPTOR SUB-ELEMENTS.

 IOSUBED  EQU    0           MAIN IOU DESCRIPTOR
 IOSUBCH  EQU    0#100       CHANNEL DESCRIPTOR
 IOSUBPP  EQU    0#200       PP DESCRIPTOR
 IOSUBL   EQU    30          LENGTH OF PP AND CHANNEL SUB-ELEMENTS
          SPACE  4,10
**        CENTRAL MEMORY ELEMENT DESCRIPTOR.

 EDCMEN   EQU    0           ELEMENT NUMBER
 EDCMMN   EQU    0           MODEL NUMBER
 EDCMSN   EQU    1           SERIAL NUMBER
 EDCMPM   EQU    5 - 7       PHYSICAL MEMORY
 EDCMAM   EQU    11 - 13     AVAILABLE MEMORY
 EDCMPS   EQU    14          PAGE SIZE
 EDCMPTL  EQU    15          PAGE TABLE LENGTH

*         CENTRAL MEMORY ELEMENT DESCRIPTOR SUB-ELEMENTS.

 CMSUBED  EQU    0           MAIN CENTRAL MEMORY DESCRIPTOR
 CMSUBFT  EQU    0#100       FLAW TABLE ELEMENT DESCRIPTOR
          SPACE  4,10
**        PROCESSOR ELEMENT DESCRIPTOR.

 EDCPEN   EQU    0           ELEMENT NUMBER
 EDCPMN   EQU    0           MODEL NUMBER
 EDCPSN   EQU    1           SERIAL NUMBER
 EDCPS    EQU    2           CPU STATE
 EDCPP    EQU    2           CPU PORT

*         CPU ELEMENT DESCRIPTOR SUB-ELEMENTS.

 CPSUBED  EQU    0           MAIN CPU DESCRIPTOR

          BASE   *
          ENDX
*DECK DECK=CTH$DEDICATED_FAULT_TOLERANCE EXPAND=FALSE
          CTEXT  CTH$DEDICATED FAULT TOLERANCE.
          SPACE  4,10
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 CTHDFT   SPACE  4,15
***       DICTIONARY.
*
*         BCW    BUFFER CONTROL WORD.
*         CDA    COMMON DISK AREA.
*         CPU0   CENTRAL PROCESSING UNIT 0.
*         CPU1   CENTRAL PROCESSING UNIT 1.
*         DFT-S  THE COPY OF DFT WHICH EXECUTES IN IOU1.
*         IOU0   INPUT OUTPUT UNIT 0 (PRIMARY).
*         IOU1   INPUT OUTPUT UNIT 1 (SECONDARY).
*         MDB    MODEL DEPENDENT BUFFER.
*         MRB    MAINTENANCE REGISTER BUFFER.


          ENDX
*DECK DECK=CTI$COMPASS_OS_LEVELS EXPAND=FALSE
          CTEXT  CTI$COMPASS_OS_LEVELS
          BASE   M
          SPACE  4,10
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4,10
***       CTI$COMPASS_OS_LEVELS
*
*         DEFINES THE CURRENT OS LEVEL WITH RESPECT TO PSR LEVEL.

 DFTPSR   EQU    780D        OS LEVEL WILL START AT 688

          SPACE  4,10
          BASE   *
          ENDX
*DECK DECK=CTI$CONSOLE_PACKET_DEFINITIONS EXPAND=FALSE
          CTEXT  CTI$CONSOLE PACKET DEFINITIONS.
 CTICPD   SPACE  4,10
***       CTI$CONSOLE PACKET DEFINITIONS.
*         D. K. ELDRED.      87/04/28.
 CTICPD   SPACE  4,10
***       DEFINE SYMBOLS USED TO INTERFACE TO CONSOLE VIA PACKETS.
 DFTREQ   SPACE  4,10
**        DFT PACKET REQUEST CODES.
*
*         THESE REQUESTS ARE SENT VIA THE *PKFDR* FUNCTION CODE.


 PKRCI    EQU    0           CHECK-IN WITH CONSOLE   (S0/S0E)
 PKRRR    EQU    1           REQUEST RECOVERY        (S0/S0E - FUTURE)
 PKRUC    EQU    2           UPDATE CONSOLE CLOCK    (S0/S0E)

 PKRMX    EQU    3           MAXIMUM REQUEST CODE + 1

*         THE FOLLOWING REQUEST CAUSES SEVERAL FILE ACCESS PACKETS TO BE
*         GENERATED.

 PKRLE    EQU    0#3F        LOG TO CONSOLE (USED FOR MRB/MRT TRANSFERS)

          ERRPL  PKRMX-PKRLE REQUEST CODES OVERLAP
 FUNC     SPACE  4,10
**        PACKET FUNCTION CODES.


*         FUNCTION CODES USED ON CYBER 930 SYSTEMS.

 PKFAC    EQU    0#01        PACKET ACCEPTED (WITH RESPONSE)
 PKFRJ    EQU    0#02        PACKET REJECTED
 PKFDK    EQU    0#03        DISPLAY/LOG/KEYBOARD REQUEST
 PKFTT    EQU    0#04        TEST TERMINATION NOTICE
 PKF05    EQU    0#05        (RESERVED)
 PKF06    EQU    0#06        (RESERVED)
 PKFEE    EQU    0#07        ENABLE CDC721 EMULATION
 PKFCD    EQU    0#08        SEND CONFIGURATION DATA
 PKFTP    EQU    0#09        TEST PARAMETERS REQUEST
 PKFOF    EQU    0#0A        OPEN CONSOLE FILE
 PKFCF    EQU    0#0B        CLOSE CONSOLE FILE
 PKFRD    EQU    0#0C        READ FROM CONSOLE FILE
 PKFWT    EQU    0#0D        WRITE TO CONSOLE FILE
 PKFDR    EQU    0#0E        DFT REQUESTS (SEE ABOVE)
 PKFDD    EQU    0#0F        DFT DEGRADE REQUEST
 PKFDF    EQU    0#10        DELETE CONSOLE FILE
 PKFCY    EQU    0#11        COPY FILE1 TO FILE2
 PKFAP    EQU    0#12        APPEND FILE1 TO FILE2

*         FUNCTION CODES USED ON A DUAL I4 SYSTEM.

 PKFSC    EQU    0#3B        SYNCHRONIZE CLOCKS
 PKFTD    EQU    0#60        TRANSMIT PP DATA TO ANOTHER PP
 PKFEP    EQU    0#62        EXECUTE PROGRAM IN ANOTHER PP

 PKFMX    EQU    PKFEP+1     MAXIMUM FUNCTION + 1

*         FUNCTION CODES USED FOR 960 EPM DATA COLLECTION.

 PKFET    EQU    0#4A        EPM TASK REQUEST
 EPMBFD   EQU    17D         READ EPM BOARD FLAG ERROR BUFFER
 EPMRD    EQU    23D         READ EPM REVISION DATA AND REVISION NUMBER
 EPMRIC   EQU    16D         READ EXCEPTION INTERRUPT COUNTERS
 EPMRNF   EQU    3           READ AND RESET NEW FAULT FLAGS
 EPMRRB   EQU    9D          READ AND RESET CYCLIC BUFFER 2
 EPMRS    EQU    20D         RESET RAM MEMORY IN EPM

*         TASKS FOR EPM DATA COLLECTION

 GETNF    EQU    0           GET NEW FAULTS
 GETER    EQU    1           GET EPM REVISION
 GETEI    EQU    2           GET EPM EXCEPTION INTERRUPT COUNTERS
 GETEB    EQU    3           GET EPM BOARD ERRORS
*GETCB    EQU    4           PSEUDO TASK FOR READ CYCLIC BUFFER 2
 LOG407   EQU    5           LOG A 407 NRSB ERROR
 LOG408   EQU    6           LOG A 408 NRSB ERROR
 CLEPC    EQU    7           CLEAN UP PACKET COMMUNICATION

 ESER     EQU    11          OFFSET FOR EPM SYSTEM ERROR FLAG IN PACKET BUFFER
 EBDE     EQU    12          OFFSET FOR EPM BOARD ERROR

 OPEN     SPACE  4,10
**        FILE OPEN MODES.


 PKORD    EQU    0#0000      READ
 PKOWR    EQU    0#0001      WRITE
 PKOAP    EQU    0#0002      APPEND
 ERROR    SPACE  4,10
**        PACKET ERROR CODES.
*
*         IF DETECTED BY *2AP* INTERNALLY, ERROR IS BIASED BY 0#100.


*PKENE    EQU    0#00        NO ERROR
 PKECS    EQU    0#01        CHECKSUM ERROR
 PKEIF    EQU    0#02        ILLEGAL FUNCTION
 PKELE    EQU    0#03        LENGTH ERROR (PACKET TOO LONG)
 PKEDE    EQU    0#04        DATA STREAM ERROR
 PKEUF    EQU    0#05        UNAUTHORIZED FUNCTION
 PKEIE    EQU    0#06        INTERNAL (CONSOLE) ERROR
 PKENF    EQU    0#07        FILE NOT FOUND (OR TOO MANY FILES OPEN)
 PKECE    EQU    0#08        FILE CREATION ERROR (OR TOO MANY FILES OPEN)
 PKEAE    EQU    0#09        FILE ACCESS ERROR
 PKEUD    EQU    0#0A        UNABLE TO DELETE FILE
 PKETO    EQU    0#13        TIMEOUT

 PKEMX    EQU    0#14        MAXIMUM ERROR CODE + 1
          SPACE  4,10
          ENDX
*DECK DECK=CTI$DFT_ANALYSIS_CODES EXPAND=FALSE
          CTEXT  CTI$DFT ANALYSIS CODES.
          BASE   M
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 CTIDAC   SPACE  4,10
***       CTI$DFT_ANALYSIS_CODES.
*
*         THIS DECK DEFINES THE DFT ANALYSIS CODES.  INCLUDED ARE
*         RELATED MACROS AND MICROS WHICH MAY AID IN REPORTING THE
*         ANALYSIS.
 DACM     SPACE  4,10
**        DACM - DECLARE ANALYSIS CODE MICRO.
*
* X       DACM   CCC,M
*
*         ENTRY  *CCC* = ANALYSIS CODE.
*                *M* = LAST PART OF MESSAGE (WITHOUT CODE).
*
*         EXIT   *X* = MICRO CONTAINING COMPLETE MESSAGE IN FORM -
*                      (CCC) M.


          PURGMAC  DACM

          MACRO  DACM,X,C,M
          LOCAL  HM,LM
          MACREF DACM
 HM       HEXMIC C,3
 X        MICRO  1,,*(_"HM"_) _M*
 LM       MICCNT X
          ERRNG  24D-LM       MESSAGE EXCEEDS 24 CHARACTERS
 DACM     ENDM
 GACE     SPACE  4,15
**        GACE - GENERATE ANALYSIS CODE ENTRY.
*
* X       GACE   V,M,D
*
*         ENTRY  *X* = STARTING LOCATION OF TABLE IF PRESENT.
*                *V* = ANALYSIS CODE VALUE.
*                *M* = ANALYSIS MICRO.
*                *D* = DISPLAY CODE GENERATED IF DEFINED.
*                PGACE = PREFIX MICRO.
*                SGACE = SUFFIX MICRO.
*
*         EXIT   THE FOLLOWING TWO PP WORD SEQUENCE HAS BEEN GENERATED -
*                16/V,16/FWA OF STRING.
*                STRING GENERATED IN REMOTE BLOCK GACEM.


          PURGMAC  GACE

          MACRO  GACE,X,V,M,D
          LOCAL  A,B,LP,LS,MM
          MACREF GACE
 .A       IFC    NE,$X$$
 X        EQU    *
 .1       SET    X
 .A       ENDIF
          CON    V
          CON    A
 LP       MICCNT PGACE
 LS       MICCNT SGACE
 .A       IFEQ   LP+LS,0
 B        MICRO  1,24,*                        *
 MM       MICRO  1,,*"M"_"B"*
 .A       ELSE
 MM       MICRO  1,,*"PGACE"_"M"_"SGACE"*
 .A       ENDIF
 GACEM    RMT
 .A       IFC    EQ,*D**
 A        ASCII  ("MM")
 .A       ELSE
 A        DATA   C*"MM"*
 .A       ENDIF
          RMT
 GACE     ENDM
 HEXMIC   SPACE  4,15
**        HEXMIC - HEX MICRO.
*
* MICNAM  HEXMIC AEXP,N
*
*         ENTRY  *MICNAM* = MICRO NAME TO BE DEFINED.
*                *AEXP* = ABSOLUTE EXPRESSION.
*                *N* = NUMBER OF CHARACTERS IN GENERATED STRING.
*                      MUST BE .GT. 0 AND .LE. 5.
*
*         EXIT   *MICNAM* = MICRO STRING OF *N* CHARACTERS WHICH
*                           REPRESENTS THE VALUE OF *AEXP* BASE 16.


          PURGMAC  HEXMIC

          MACRO  HEXMIC,M,X,N
          LOCAL  CD,CM,CS,CU,CV
          MACREF HEXMIC
 M        MICRO  1,,**
 CV       SET    X
          ERRNG  5-N         *N* MUST BE .LE. 5
          ERRPL  0-N         *N* MUST BE .GT. 0
 .A       DUP    N
 CD       SET    CV/16D
 CU       SET    CD*16D
 CS       SET    CV-CU
 CV       SET    CD
 .B       IFLE   CS,9D
 CM       DECMIC CS,1
 .B       ELSE
          ECHO   3,V=(10D,11D,12D,13D,14D,15D),C=(A,B,C,D,E,F)
          IFEQ   CS,V,2
 CM       MICRO  1,,*C*
          STOPDUP
 .B       ENDIF
 M        MICRO  1,N,*"CM"_"M"*
 .A       ENDD
 HEXMIC   ENDM
          SPACE  4,10
*         CODES.

*         THE DECKS DST$DFT_ANALYSIS_CODE_CONSTANTS AND
*         DSM$LOG_SYSTEM_MESSAGES MUST ALSO BE CHANGED IF ANY
*         NEW DFT ANALYSIS CODES ARE ADDED.

*         FOLLOWING ARE DFT ANALYSIS ERROR CODES - IOU.
*         THEY WILL BE REPORTED AS *0XX*.

*         EQU    0#1         DEADSTART ERROR LOG IOU ERROR
*         EQU    0#2         EXPRESS DEADSTART DUMP IOU ERROR
 DACIE    EQU    0#3         CORRECTED IOU ERROR (S0/S0E OR I4 ONLY)
 DAUIE    EQU    0#4         UNCORRECTED IOU ERROR
 DA1216   EQU    0#5         12/16 IOU CONVERSION ERROR
 DAFI     EQU    0#6         FATAL IOU ERROR
 DACHE    EQU    0#7         CHANNEL ERROR
 DACFI    EQU    0#8         FATAL CIO PP ERROR
 DACUIE   EQU    0#9         UNCORRECTED CIO PP ERROR (PP HALT)
 DAC1216  EQU    0#A         12/16 ERROR ON CIO PP
 DACCHE   EQU    0#B         CIO CHANNEL ERROR
 DAIB     EQU    0#C         IOU BIT 57 CM ACCESS BLOCK
*DACY2E   EQU    0#FF        CYBER 2000 ERROR (CYBER 2000 DFT ONLY)

*         FOLLOWING ARE DFT ANALYSIS ERROR CODES - MEMORY.
*         THEY WILL BE REPORTED AS *1XX*.

*         EQU    0#1         DEADSTART ERROR LOG MEMORY ERROR
*         EQU    0#2         EXPRESS DEADSTART DUMP MEMORY ERROR
 DACME    EQU    0#3         CORRECTED MEMORY ERROR
 DAUME    EQU    0#4         UNCORRECTED MEMORY ERROR
 DAMOB    EQU    0#5         MULTIPLE ODD BIT MEMORY ERROR
 DAPWP    EQU    0#6         PARTIAL WRITE PARITY ERROR
*RESERVED EQU    0#7         RESERVED FOR FUTURE USE
 DAUMB    EQU    0#8         UNCORRECTED MEMORY BOARD ERROR (S0/S0E)
 DACMI    EQU    0#9         CENTRAL MEMORY INTERFACE ERROR (S0/S0E)


*         FOLLOWING ARE DFT ANALYSIS ERROR CODES - PROCESSOR.
*         THEY WILL BE REPORTED AS *2XX*.

*         EQU    0#1         DEADSTART ERROR LOG PROCESSOR ERROR
*         EQU    0#2         EXPRESS DEADSTART DUMP PROCESSOR ERROR
 DACPE    EQU    0#3         CORRECTED PROCESSOR ERROR
 DAUPE    EQU    0#4         UNCORRECTED PROCESSOR ERROR
 DARP     EQU    0#5         RETRY OPERATION IN PROGRESS
 DARES    EQU    0#6         REPAIRABLE ERROR SUCCESSFUL
 DAREU    EQU    0#7         REPAIRABLE ERROR UNSUCCESSFUL
 DAPH     EQU    0#8         PROCESSOR HALT
*         EQU    0#9         CPU ERROR EXIT MODE 20
*         EQU    0#A         CPU ERROR EXIT MODE 67
 DACRE    EQU    0#B         CATASTROPHIC RECOVERY ERROR
 DACCR    EQU    0#C         CORRECTED ERROR CACHE RELOAD
 DAFUE    EQU    0#D         THETA FATAL UNCORRECTED ERROR
*         EQU    0#E         FATAL CPU ERROR (*DUE* THRESHOLD EXCEEDED)
*         EQU    0#F         FATAL C170 STATE *DUE*
*         EQU    0#10        FATAL C170 STATE EXIT MODE HALT
*         EQU    0#11        FATAL MONITOR *DUE*
*         EQU    0#12        FATAL MONITOR ERROR
*         EQU    0#13        FATAL MONITOR *MCR*
*         EQU    0#14        FATAL EI *DUE*
*         EQU    0#15        FATAL *MCH* ERROR
*         EQU    0#16        FATAL JOB ERROR
*         EQU    0#17        FATAL JOB *MCR*
 DAFC     EQU    0#218       FATAL CPU N ERROR
 DATFU    EQU    0#19        THETA FORCED UNCORRECTED ERROR
 DASWH    EQU    0#1A        PROCESSOR HALT CLASS II
 DARCU    EQU    0#1B        RETRY CONVERTED TO UNCORRECTED ERROR
 DATRE    EQU    0#1C        THETA RETRY EXHAUSTED
 DATHT    EQU    0#1D        THETA RETRY HOUR THRESHOLD
 DAPWE    EQU    0#1E        THETA PARTIAL WRITE PARITY ERROR
 DAFPE    EQU    0#1F        FATAL PROCESSOR ERROR (S0/S0E)
 DADMD    EQU    0#20        FATAL ERROR - PROCESS DAMAGED IN MTR MODE (S0/S0E)
 DADMH    EQU    0#21        FATAL ERROR - DUE WITH MICROHALT (S0/S0E)
 DADNE    EQU    0#22        FATAL ERROR - NO ERROR BITS PRESENT IN SS (S0/S0E)
 DADRF    EQU    0#23        FATAL ERROR - CONTROL STORE RELOAD FAILED (S0/S0E)
 DADRX    EQU    0#24        FATAL ERROR - RETRIES EXHAUSTED (S0/S0E)
 DADTO    EQU    0#25        FATAL ERROR - HALT TIMEOUT (S0/S0E)
 DADUA    EQU    0#26        FATAL ERROR - UNEXPECTED MICROHALT ADDR. (S0/S0E)
 DAUEV    EQU    0#27        UNCORRECTED ERROR - EXCHANGE VECTOR
 DAUTV    EQU    0#28        UNCORRECTED ERROR - TRAP VECTOR
 DAUHV    EQU    0#29        UNCORRECTED ERROR - HALT VECTOR
 DACE     EQU    0#2A        960 CLOCK ERRORS
 DACSJ    EQU    0#2B        CONTROL STORE ERROR - JOB MODE
 DACSM    EQU    0#2C        CONTROL STORE ERROR - MONITOR MODE
 DARS     EQU    0#2D        CORRECTED PROC ERR - RETRY SUCCESSFUL
 DAFCE    EQU    0#2E        FATAL CPU MICROCODE PARITY ERROR
*         EQU    0#2F        RESERVED
 DAMCH    EQU    0#30        CPU MAC HUNG
 DACCT    EQU    0#31        CPU/CM TIMEOUT CONDITION
 DARME    EQU    0#32        FAILURE REFRESHING CPU SCMS
 DARCE    EQU    0#33        CATESTROPHIC ERROR ON HEO DURING REFRESH OF SCM

*         FOLLOWING ARE DFT ANALYSIS ERROR CODES - PAGE MAP.
*         THEY WILL BE REPORTED AS *3XX*.

 DACPM    EQU    0#1         CORRECTED PAGE MAP ERROR (S0/S0E)
 DAUPM    EQU    0#2         UNCORRECTED PAGE MAP ERROR (S0/S0E)

*         FOLLOWING ARE DFT ANALYSIS ERROR CODES - BAD OS REQUESTS TO DFT.
*         THEY WILL BE REPORTED AS *4XX*.

 DABOR    EQU    0#401       BAD RESPONSE TO AN OS REQUEST
 DALP     EQU    0#402       DFT LOGGED PROCESSOR FAILURE MESSAGE
 DAUE     EQU    0#403       ERROR UPDATING THE ECR RECORD
 DAEG     EQU    0#404       ERRONEOUS BIT 59 SET AND NO ERROR DETECTED
 DATG     EQU    0#405       TRANSIENT BIT 59 CONDITION
 DAEP     EQU    0#406       ERROR PROCESSING THE ECR RECORD IN AN ERROR CONDITION
 DAEBE    EQU    0#407       EPM BOARD ERROR DATA
 DAESE    EQU    0#408       EPM SYSTEM ERROR DATA
*                0#409       RESERVED FOR CYBER 2000
 DANSC    EQU    0#40A       NEGATIVE SIT REPORTING

*         FOLLOWING ARE DFT ANALYSIS ERROR CODES - PACKET COMMUNICATION ERRORS.
*         THEY WILL BE REPORTED AS *5XX*.


 DAPC     EQU    0#501       BAD PACKET RESPONSE
 DASQ     EQU    0#502       PACKET SEQUENCE NUMBER MISMATCH
 DABP     EQU    0#503       BAD PACKET PHASE IN DFT
 DAPF     EQU    0#504       DFT/2AP INTERFACE ERROR
 DATO     EQU    0#505       PACKET TIMEOUT CONDITION
 DAQF     EQU    0#507       PACKET REQUEST QUEUE FULL REQUEST IGNORED
 DAIS     EQU    0#508       S0 PACKET ERROR IGNORED
 DATP     EQU    0#509       DLD PATH FAILURE
 DAEF     EQU    0#50A       DFT/EPM INTERFACE ERROR
*DASPI    EQU    0#5FF       SERVICE PROCESSOR INTERNAL ERROR (CYBER 2000 ONLY)

*         FOLLOWING ARE DFT ANALYSIS ERROR CODES - SOFTWARE.
*         THEY WILL BE REPORTED AS *6XX*.
*
*         NOTE THAT THE MICROS WHICH FOLLOW THE ERROR CODE EQUATES
*         SHOULD BE UPDATED WHENEVER EICB MESSAGES CODES ARE
*         CREATED, DELETED, OR MODIFIED.
*
*         IF ADDITIONAL ANALYSIS CODES ARE DEFINED FOR CHANNEL 17
*         ERRORS, CONSIDERATION SHOULD BE GIVEN TO UPDATING
*         TABLE *TCHP* IN DECK *CTP$CONSTRUCT_MESSAGE_IN_EICB*.

 DANE     EQU    0#600       NO ERROR
 DASD     EQU    0#601       SCI NOT RESPONDING
 DADS     EQU    0#602       DFT NOT RESPONDING
 DAMP     EQU    0#603       CH17 PARITY ERROR
 DAMI     EQU    0#604       CH17 INTERLOCK ERR
 DAMA     EQU    0#605       CH17 ACTIVE
 DAPO     EQU    0#606       RESERVED
 DARE     EQU    0#607       DFT REG NOT IN MRB
 DAMD     EQU    0#608       INCOMPAT DFT AND HW MODEL
 DAHP     EQU    0#609       DFT HALT PROCESSOR
 DASC     EQU    0#60A       DFT FATAL STACK
 DASE     EQU    0#60B       DFT BRL SIZE ERR
 DALE     EQU    0#60C       PP LOAD ERROR
 DAMM     EQU    0#60D       170 MTR MCR FAULT - DETECTED BY EI
 DABR     EQU    0#60E       BAD SYSTEM REQUEST - DETECTED BY EI
 DACI     EQU    0#60F       CH17 INACTIVE
 DASP     EQU    0#610       SCI PRESET FAILURE
 DASL     EQU    0#611       SCI LOADED IN PP 0
 DAME     EQU    0#612       DFT NO DESC IN MRT
 DACF     EQU    0#613       DFT COMM FAILURE
 DAVM     EQU    0#614       DFT INCOMPAT VERSN
 DASR     EQU    0#615       SCI RIHT TOO SMALL
 DAWC     EQU    0#616       WALL CLOCK CHIP READ ERROR
 DAMT     EQU    0#617       DFT DETECTED MONITOR TIMEOUT
 DAND     EQU    0#618       NO PP AVAILABLE FOR DFT
 DADV     EQU    0#619       DFT R-POINTER LENGTH EXCEEDED IN *DVR*
 DAPR     EQU    0#61A       DFT IOU FIELD PROCESSING ERROR
 DADN     EQU    0#61B       DFT NOT FOUND IN CIP DIRECTORY
 DASB     EQU    0#61C       DFT-S BUFFER TOO SMALL
 DAPZ     EQU    0#61D       DFT PRESET ALLOCATION SIZE FAILURE
 DAIE     EQU    0#61E       DFT INTERNAL ERROR CONDITION
 DACV     EQU    0#61F       DFT CANNOT FIND COUNTER VALUE
 DATV     EQU    0#620       DFT CANNOT FIND THRESHOLD VALUE
 DADL     EQU    0#621       DFT DISK STATUS LENGTH EXCEEDED
 DASS     EQU    0#622       SCI DETECTED DFT ERROR WHILE LOADING SSR
 DASV     EQU    0#623       SCI DETECTED DFT ERROR WHILE LOADING VCB
 DAH7     EQU    0#624       SCI DETECTED DFT ERROR WHILE HALTING 170 PROCESSOR
 DAS8     EQU    0#625       SCI DETECTED DFT ERROR WHILE STARTING VIRTUAL PROC.
 DASI     EQU    0#626       SCI DETECTED DFT ERROR WHILE IDLING SECONDARY IOU
 DAH8     EQU    0#627       SCI DETECTED DFT ERROR WHILE HALTING VIRTUAL PROC.
 DAS7     EQU    0#628       SCI DETECTED DFT ERROR WHILE STARTING 170 PROCESSOR
 DAED     EQU    0#629       SCI DETECTED DFT ERROR WHILE GETTING ELEMENT DESCR.
 DANV     EQU    0#62A       SCI DETECTED DFT NEVER COMPLETED VERIFICATION
 DARJ     EQU    0#62B       SCI DETECTED DFT SET BUFFER REJECT FLAG
 DAFF     EQU    0#62C       SCI DETECTED DFT ERROR GETTING FLAW FREE MEMORY
*DASP     EQU    0#6FF       SERVICE PROCESSOR EXECUTIVE ERROR (CYBER 2000 ONLY)

 DAMX     EQU    DARJ        MAXIMUM 600 SERIES CODE

*         FOLLOWING ARE DFT ANALYSIS ERROR CODES - MISCELLANEOUS.
*         THEY WILL BE REPORTED AS *7XX*.

 DALW     EQU    0#1         LONG WARNING
 DALPW    EQU    0#2         LONG POWER WARNING
 DASPW    EQU    0#3         SHORT POWER WARNING
 DALWC    EQU    0#4         LONG WARNING CLEAR
 DALPWC   EQU    0#5         LONG POWER WARNING CLEAR
 DASWC    EQU    0#6         SHORT POWER WARN CLEAR
 DATHM    EQU    0#7         TOP OF HOUR MAINFRAME ELEMENT COUNTERS
 DATHS    EQU    0#8         TOP OF HOUR SECDED ID TABLE PROCESSING
*DACYLP   EQU    0#9         CYBER 2000 LONG POWER WARNING
*DACYLC   EQU    0#10        CYBER 2000 LONG POWER WARNING CLEAR
 MICROS   SPACE  4,10
**        EICB MESSAGE MICROS.
*
*         NOTE   ONLY SOME OF THESE MICROS ARE CURRENTLY USED.  THESE ARE:
*                *DMMP*, *DMMI*, *DMMA*, *DMLE*, *DMCI*;  THESE ARE ALL
*                USED BY *SDA*.  WHENEVER A NEW 600-SERIES ANALYSIS CODE
*                IS ADDED, A CORRESPONDING ADDITION TO THE SET OF MICROS
*                SHOULD BE MADE.


 DMNE     MICRO  1,,*                        *  NO ERROR (BLANK)
 DMFC     DACM   DAFC,(FATAL CPU 0 ERROR)

 DMSD     DACM   DASD,(SCI NOT RESPONDING)
 DMDS     DACM   DADS,(DFT NOT RESPONDING)
 DMMP     DACM   DAMP,(CH17 PARITY ERROR)
 DMMI     DACM   DAMI,(CH17 INTERLOCK ERR)
 DMMA     DACM   DAMA,(CH17 ACTIVE)
 DMPO     DACM   DAPO,(DFT PORT OFFSET ER)
 DMRE     DACM   DARE,(DFT REG NOT IN MRB)
 DMMD     DACM   DAMD,(DFT WRONG HW MODEL)
 DMHP     DACM   DAHP,(DFT HALT PROCESSOR)
 DMSC     DACM   DASC,(DFT FATAL STACK)
 DMSE     DACM   DASE,(DFT BRL SIZE ERR)
 DMLE     DACM   DALE,(PP LOAD ERROR)
 DMMM     DACM   DAMM,(170 MTR MCR ERR)
 DMBR     DACM   DABR,(BAD SYSTEM REQ)
 DMCI     DACM   DACI,(CH17 INACTIVE)
 DMSP     DACM   DASP,(SCI PRESET FAILURE)
 DMSL     DACM   DASL,(SCI LOADED IN PP 0)
 DMME     DACM   DAME,(DFT NO DESC IN MRT)
 DMCF     DACM   DACF,(DFT COMM. FAILURE)
 DMVM     DACM   DAVM,(DFT INCOMPAT VERSN)
 DMSR     DACM   DASR,(SCI RIHT TOO SMALL)
 DMWC     DACM   DAWC,(DFT WCC READ ERR)
 DMMT     DACM   DAMT,(DFT DETECT MTR T/O)
 DMND     DACM   DAND,(NO PP FOR DFT)
 DMDV     DACM   DADV,(DFT R-PTR TOO LONG)
 DMPR     DACM   DAPR,(DFT IOU FIELD ERR)
 DMDN     DACM   DADN,(DFT NOT IN CIP DIR)
 DMSB     DACM   DASB,(DFTS BFR TOO SMALL)
 DMPS     DACM   DAPZ,(DFT PRS ALLOC ERR)
 DMIE     DACM   DAIE,(DFT INTERNAL ERR)
 DMCV     DACM   DACV,(DFT COUNTER ERROR)
 DMTV     DACM   DATV,(DFT THRESHOLD ERR)
 DMDL     DACM   DADL,(DFT DISK STATUS LN)
 DMSS     DACM   DASS,(SCI LOADING SSR ER)
 DMSV     DACM   DASV,(SCI LOADING VCB ER)
 DMH7     DACM   DAH7,(SCI HALT 170 PROC.)
 DMS8     DACM   DAS8,(SCI START 180 PROC)
 DMSI     DACM   DASI,(SCI IDLING 2ND IOU)
 DMH8     DACM   DAH8,(SCI HALT 180 PROC)
 DMS7     DACM   DAS7,(SCI START 170 PROC)
 DMED     DACM   DAED,(SCI ELEMENT DESCR)
 DMNV     DACM   DANV,(SCI DFT NEVER VER)
 DMRJ     DACM   DARJ,(SCI DFT SET REJECT)

          BASE   *
          ENDX
*DECK DECK=CTI$MAINTENANCE_DISPLAY_MACROS EXPAND=FALSE
          CTEXT  CTI$MAINTENANCE DISPLAY MACROS.                        
 CTIMDM   SPACE  4,10                                                   
***       CTI$MAINTENANCE DISPLAY MACROS.                               
*         B. R. HANSON.      81/09/10.                                  
 CTIMDM   SPACE  4,10                                                   
***              *CTI$MAINTENANCE_DISPLAY_MACROS* DEFINES MACROS USED   
*         BY *CTM$SYSTEM_CONSOLE_INTERFACE*.                            
*                                                                       
*         BECAUSE OF THE WAY THE *CMND* AND *HELP* MACROS PASS          
*         VALIDATION INFORMATION, THEY MUST BE CONSECUTIVE LINES        
*         OF CODE FOR ANY COMMAND DEFINITION.                           
 CMND     SPACE  4,10                                                   
**        CMND - DEFINE COMMAND.                                        
*                                                                       
* XX      CMND   PROC,DTYPE,PTABL,(SYNTAX),(VALID)                      
*                                                                       
*         XX = TWO CHARACTER COMMAND MNEMONIC.                          
*         PROC = COMMAND PROCESSOR (MUST BE DEFINED BY *ROUTINE*).      
*         DTYPE = MEMORY DISPLAY TYPE.                                  
*         PTABL = PARAMETER TABLE ADDRESS (DEFAULT = CONTIGUOUS).       
*         SYNTAX = COMMAND SYNTAX (FOR *HELP* COMMAND).                 
*         VALID = LIST OF HARDWARE TYPES FOR WHICH COMMAND IS VALID.    
                                                                        
                                                                        
          PURGMAC  CMND                                                 
          MACRO  CMND,XX,PROC,DTYPE,PADR,SYNTAX,VALID                   
          LOCAL  PADDR,V                                                
                                                                        
*         SET COMMAND INDEX.                                            
                                                                        
          IFC    EQ,$PADR$$,1                                           
 PADDR    EQU    *                                                      
                                                                        
*         SET COMMAND VALIDATIONS.                                      
                                                                        
 V        SET    0                                                      
 .1       IFC    EQ,/VALID//                                            
          ERR    APPLICABLE HARDWARE MUST BE SPECIFIED                  
 .1       ELSE                                                          
 V        SET    0                                                      
          IRP    VALID                                                  
 V        SET    V+CMD$_VALID                                           
          IRP                                                           
 .1       ENDIF                                                         
 VAL_XX   SET    V                                                      
                                                                        
*         DEFINE COMMAND TABLE ENTRY IN *CMDS* REMOTE BLOCK.            
                                                                        
 CMDS     RMT                                                           
          CON    2R_XX                                                  
          VFD    10/V                                                   
          VFD    6/PROC_O                                               
          CON    PROC                                                   
          IFC    EQ,$DTYPE$$,2                                          
          CON    0,0                                                    
          ELSE   2                                                      
          CON    PADR PADDR                                             
          CON    DTYPE/10000                                            
          RMT                                                           
                                                                        
*         DEFINE SYNTAX TABLE ENTRY IN *HELP* REMOTE BLOCK.             
                                                                        
 HELP     RMT                                                           
          CODE   N                                                      
          CON    V,=C*SYNTAX*                                           
          CODE   *                                                      
          RMT                                                           
          ENDM                                                          
 HELP     SPACE  4,10                                                   
**        HELP - DESCRIBE COMMAND FOR *HELP* COMMAND.                   
*                                                                       
*         HELP   (XX  TEXT)                                             
*                                                                       
*         TEXT = COMMAND DESCRIPTION FOR COMMAND *XX*.                  
                                                                        
                                                                        
          PURGMAC  HELP                                                 
 HELP     MACRO  DEFIN                                                  
          LOCAL  V                                                      
          IFC    NE,$DEFIN$$,2                                          
 XX       MICRO  1,2,$DEFIN$                                            
 V        EQU    VAL"XX"                                                
 HELD     RMT                                                           
          CODE   N                                                      
          IFC    NE,$DEFIN$$,2                                          
          CON    V,=C*DEFIN*                                            
          ELSE   1                                                      
          CON    -0,0        END OF LIST                                
          CODE   *                                                      
          RMT                                                           
          ENDM                                                          
 ENTER    SPACE  4,10                                                   
**        ENTER - FORM INDEXED TABLES OF DATA.                          
*                                                                       
* ORD     ENTER  V1,V2                                                  
*                                                                       
*         ORD = ORDINAL * 10000.                                        
*         V1 = VALUE TO PLACE IN TABLE *TBLA*.                          
*         V2 = VALUE TO PLACE IN TABLE *TBLB*.                          
                                                                        
                                                                        
          PURGMAC ENTER                                                 
          MACRO  ENTER,ORD,V1,V2                                        
 ORD      EQU    TBLI*10000                                             
          NOREF  TBLI                                                   
 TBLI     SET    TBLI+1                                                 
          IFC    NE,$V1$$,3                                             
 TBLA     RMT                                                           
          CON    V1                                                     
          RMT                                                           
          IFC    NE,$V2$$,3                                             
 TBLB     RMT                                                           
          CON    V2                                                     
          RMT                                                           
          ENDM                                                          
 PRM      SPACE  4,10                                                   
**        PRM - DEFINE PARAMETER LIST FOR COMMAND.                      
*                                                                       
* VAR     PRM    ADDR,WC                                                
*                                                                       
*         VAR = PARAMETER NAME.                                         
*         ADDR = ADDRESS TO STORE VALUE.                                
*         WC = SIZE OF VALUE IN PP WORDS.                               
*                                                                       
*         IF *VAR* IS OMITTED THEN THIS PARAMETER HAS A                 
*         LIST OF SEVERAL NAMES WHICH MAY BE USED.  IN THIS             
*         CASE, *ADDR* IS THE ADDRESS TO STORE THE ADDRESS              
*         GIVEN IN THE SELECTED ALTERNATIVE.  IF *WC* IS                
*         OMITTED, THE PARAMETER MUST BE ONE OF THE ALTERNATIVES        
*         AND MAY NOT HAVE AN EQUIVALENCED VALUE.  IF *VAR*             
*         IS OMITTED, A LIST OF *PRMV* MACROS MUST FOLLOW WHICH         
*         DEFINE THE ALTERNATE NAMES FOR THIS PARAMETER.                
                                                                        
                                                                        
          PURGMAC  PRM                                                  
          MACRO  PRM,VAR,ADDR,WC                                        
          LOCAL  HDR                                                    
          QUAL                                                          
          NOREF  PRMC                                                   
 PRMC     SET    PRMC+1                                                 
 PRMV     DECMIC PRMC,4                                                 
          QUAL   *                                                      
 HDR      SET    WC 0                                                   
          NOREF  P"PRMV"                                                
          IFC    EQ,$VAR$$                                              
 P"PRMV"  CON    HDR+4000,V"PRMV",ADDR                                  
          ELSE                                                          
 P"PRMV"  CON    HDR,V"PRMV"                                            
 VAR      PRMV   ADDR                                                   
          ENDIF                                                         
          ENDM                                                          
                                                                        
 PRMC     SET    0                                                      
 PRMV     SPACE  4,10                                                   
**        PRMV - PARAMETER NAME DESCRIPTOR.                             
*                                                                       
* VAR     PRMV   ADDR                                                   
*                                                                       
*         THIS MACRO IS USED TO LIST OPTIONAL NAMES FOR A GIVEN         
*         PARAMETER.                                                    
*                                                                       
*         VAR = PARAMETER NAME.                                         
*         ADDR = ADDRESS TO STORE THE VALUE OR VALUE ITSELF.            
                                                                        
                                                                        
          PURGMAC  PRMV                                                 
          MACRO  PRMV,VAR,ADDR                                          
          LOCAL  PRML                                                   
 PRML     DECMIC PRMC,4                                                 
          NOREF  V"PRML"                                                
 PRMV     RMT                                                           
          IF     -DEF,V"PRML",1                                         
 V"PRML"  BSS    0                                                      
          CON    2R_VAR                                                 
          CON    P"PRML"                                                
          CON    ADDR                                                   
          RMT                                                           
          ENDM                                                          
 PRME     SPACE  4,10                                                   
**        PRME - END PARAMETER LIST.                                    
*                                                                       
*         PRME                                                          
                                                                        
                                                                        
          PURGMAC  PRME                                                 
 PRME     MACRO                                                         
          CON    0                                                      
 PRMV     HERE                                                          
          CON    0                                                      
          ENDM                                                          
 PRINT    SPACE  4,10                                                   
**        PRINT - PRINT LINE.                                           
                                                                        
                                                                        
          PURGMAC PRINT                                                 
 PRINT    MACRO  M                                                      
          LDC    M                                                      
          RJM    WAS         WRITE ASCII STRING                         
          ENDM                                                          
 MR       SPACE  4,10                                                   
**        MR - DESCRIBE MAINTENANCE REGISTER.                           
*                                                                       
* HV      MR     (STRING),(MODELS)                                      
*                                                                       
*         HV = HEXADECIMAL REGISTER VALUE (IGNORED).                    
*         STRING = DESCRIPTION.                                         
*         MODELS = MODEL(S) APPLICABLE.                                 
                                                                        
          PURGMAC  MR                                                   
          MACRO  MR,HV,STR,DISC                                         
          CON    0#;A                                                   
          BITCON (DISC)                                                 
          CON    =C*STR*                                                
          ENDM                                                          
 LOADOV   SPACE  4,10                                                   
***       LOADOV - LOAD AN OVERLAY AND RETURN.                          
*                                                                       
*         LOADOV  NAME,P                                                
*                                                                       
*         P       IF *P* IS SPECIFIED, CALL THE *LNO* ROUTINE IN THE    
*                 PRESET OVERLAY INSTEAD OF THE ONE IN THE RESIDENT     
*                 OVERLAY.                                              
                                                                        
                                                                        
          PURGMAC LOADOV                                                
 LOADOV   MACRO  NAME,P                                                 
          LOCAL  TAG                                                    
          LDC    NAME_O*10000+TAG                                       
 .A       IFC    EQ,$P$$                                                
          RJM    LNO                                                    
 .A       ELSE                                                          
          RJM    /PRESET/LNO                                            
 .A       ENDIF                                                         
 TAG      BSS    0                                                      
          ENDM                                                          
 STIAO    SPACE  4,10                                                   
**        STIAO - STORE INDIRECT AND ADD ONE.                           
*                                                                       
* TAG     STIAO  DC                                                     
                                                                        
                                                                        
          PURGMAC  STIAO                                                
          MACRO  STIAO,TAG,DC                                           
          MACREF STIAO                                                  
 TAG      STI    DC          PUT CHARACTER IN OUTPUT BUFFER             
          AOD    DC          UPDATE POINTER                             
          ENDM                                                          
 STILAO   SPACE  4,10                                                   
**        STILAO - STORE INDIRECT LONG AND ADD ONE.                     
*                                                                       
* TAG     STILAO DC                                                     
                                                                        
                                                                        
          PURGMAC  STILAO                                               
          MACRO  STILAO,TAG,DC                                          
          MACREF STILAO                                                 
 TAG      STIL   DC          PUT CHARACTER IN OUTPUT BUFFER             
          AOD    DC          UPDATE POINTER                             
          ENDM                                                          
 CTIMDM   SPACE  4,10                                                   
          ENDX                                                          
*DECK DECK=CTI$MDD_COMMAND_LIST EXPAND=FALSE
          CTEXT  MDD COMMAND LIST
          OVERLAY  (MDD COMMAND LIST)
 MDDC     SPACE  4,10
 MDDC     ROUTINE            DUMMY ROUTINE TO IDENTIFY OVERLAY
          QUAL   *
 CMD      SPACE  4,10
***       OVERVIEW.
*
*         MOST *MDD* COMMANDS ARE VALID ON MOST MAINFRAMES.  HOWEVER,
*         SOME COMMANDS, OR THEIR VARIANTS, APPLY ONLY TO SPECIFIC HARDWARE.
*
*         1)  COMMANDS VALID ON ALL HARDWARE MUST BE MARKED *ALL*.
*
*         2)  COMMANDS VALID ON GENERIC HARDWARE MUST BE MARKED *GEN*.
*
*         3)  COMMANDS VALID ON S0/S0E MAINFRAMES MUST BE MARKED *S0*.


 CMD$GEN  EQU    1           COMMAND IS VALID ON GENERIC HARDWARE
 CMD$S0   EQU    2           COMMAND IS VALID FOR S0/S0E MAINFRAMES
 CMD$ALL  EQU    1777        COMMAND IS VALID ON ALL MAINFRAMES

          CODE   A
 DBDCDH   SPACE  4,10
**        DB/DC/DH - DISPLAY REAL MEMORY.
*
*         NOTE   *DC* IS NOT VALID ON S0/S0E MAINFRAMES.


 DB       CMND   DHB,HPNT,CMPL,(DB MA=ADDR. WC=BYTE COUNT),(ALL)
          HELP   (DB  DISPLAY MEMORY C180-BYTE)
 DC       CMND   DCM,OWNT,CMPL,(DC MA=ADDR. WC=WORD COUNT),(GEN)
          HELP   (DC  DISPLAY MEMORY C170-WORD)
 DH       CMND   DHX,HPNT,CMPL,(DH MA=ADDR. WC=WORD COUNT),(ALL)
          HELP   (DH  DISPLAY MEMORY C180-WORD)
 CMPL     BSS    0
 MA       PRM    VAL1,4
 WC       PRM    VAL2,1
          PRME
 DM       SPACE  4,10
**        DM - DISPLAY VIRTUAL MEMORY.


 DM       CMND   DMM,HWNT,,(DM PV WC XP PT BO PS PL),(ALL)
          HELP   (DM  DISPLAY VIRTUAL MEMORY)
 PV       PRM    VMBA,3
 WC       PRM    VAL2,1
          PRM    VMBA+3,2
 MP       PRMV   MPSV
 JP       PRMV   JPSV
 XP       PRMV   XPSV
 PT       PRM    PTAV,2
 BO       PRM    VMBA+1,2
 PS       PRM    PSMV,1
 PL       PRM    PTLV,1
          PRME
 EB       SPACE  4,10
**        EB - ENTER HEX BYTE(S).


 EB       CMND   EBT,HPNT,,(EB MA=ADDR. BYTE1 BYTE2 ..),(ALL)
          HELP   (EB  ENTER HEX BYTE[S])
 MA       PRM    VAL1,4
          PRME
 EC       SPACE  4,10
**        EC - ENTER OCTAL WORD(S).
*
*         NOTE   THIS COMMAND IS NOT VALID ON S0/S0E MAINFRAMES.


 EC       CMND   ECM,OWNT,,(EC MA=ADDR.[8] WV=VALUE),(GEN)
          HELP   (EC  ENTER A C170 WORD)
 MA       PRM    VAL1,4
 WV       PRM    MRBF,5
          PRME
 DR       SPACE  4,10
**        DR - DISPLAY MAINTENANCE REGISTERS.
*
*         NOTE   THIS COMMAND IS NOT VALID ON S0/S0E MAINFRAMES.


 DR       CMND   MRP,MRNT,,(DR [I/P/M] RN=REG. RC=COUNT),(GEN)
          HELP   (DR  DISPLAY REGISTER CONTENTS)
          PRM    MRPV
 M        PRMV   MRML
 I        PRMV   MRIL
 P        PRMV   MRPL
 RN       PRM    MRPE,1
 RC       PRM    VAL2,1
          PRME
 ER       SPACE  4,10
**        ER - ENTER MAINTENANCE REGISTER CONTENTS.
*
*         NOTE   THIS COMMAND IS NOT VALID ON S0/S0E MAINFRAMES.


 ER       CMND   MRW,MRNT,,(ER [I/P/M] RN=REG. RV=VALUE),(GEN)
          HELP   (ER  ENTER REGISTER CONTENTS)
          PRM    MRPV
 M        PRMV   MRML
 I        PRMV   MRIL
 P        PRMV   MRPL
 RN       PRM    MRPE,1
 RV       PRM    MRBF,10
          PRME
 RF       SPACE  4,10
**        RF - DISPLAY REGISTER FILE.
*
*         NOTE   THIS COMMAND IS NOT VALID ON S0/S0E MAINFRAMES.


 RF       CMND   RFP,MRNT,,(RF AD=ADDR. WC=WORD COUNT),(GEN)
          HELP   (RF  DISPLAY REGISTER FILE)
 AD       PRM    RFPA,1
 WC       PRM    RFPB,1
          PRME
 DKDS     SPACE  4,10
**        DK/DS - DISPLAY CONTROL STORE.
*
*         NOTE   THESE COMMANDS ARE NOT VALID ON S0/S0E MAINFRAMES.


 DK       CMND   DKR,HPNT,DKL,(DK AD=ADDR. TC=TYPE WC=WORD COUNT),(GEN)
          HELP   (DK  DISPLAY CONTROL STORE)
 DS       CMND   DSR,HPNT,DKL,(DS AD=ADDR. TC=TYPE WC=WORD COUNT),(GEN)
          HELP   (DS  DISPLAY CONTROL STORE)
 DKL      BSS    0
 AD       PRM    VAL1,4
 TC       PRM    RFPC,1
 WC       PRM    RFPB,1
          PRME
 EKES     SPACE  4,10
**        EK/ES - ENTER CONTROL STORE.
*
*         NOTE   THESE COMMANDS ARE NOT VALID ON S0/S0E MAINFRAMES.


 EK       CMND   EKR,HPNT,EKL,(EK AD=ADDR. TC=TYPE BYTE1 BYTE2 ..),(GEN)
          HELP   (EK  ENTER CONTROL STORE)
 ES       CMND   ESR,HPNT,EKL,(ES AD=ADDR. TC=TYPE BYTE1 BYTE2 ..),(GEN)
          HELP   (ES  ENTER CONTROL STORE)
 EKL      BSS    0
 AD       PRM    VAL1,4
 TC       PRM    RFPC,1
          PRME
 CECX     SPACE  4,10
**        CE/CX - CLEAR ERRORS OR MASTER CLEAR PORT.
*
*         NOTE   THESE COMMANDS ARE NOT VALID ON S0/S0E MAINFRAMES.


 CE       CMND   CER,MRNT,CEL,(CE [I/P/M]),(GEN)
          HELP   (CE  CLEAR ERROR ON PORT)
 CX       CMND   CXR,MRNT,CEL,(CX [I/P/M]),(GEN)
          HELP   (CX  MASTER CLEAR PORT)
 CEL      BSS    0
          PRM    MRPV
 M        PRMV   MRML
 I        PRMV   MRIL
 P        PRMV   MRPL
          PRME
 HP       SPACE  4,10
**        HP - HALT PROCESSOR.
*
*         NOTE   THIS COMMAND IS NOT VALID ON S0/S0E MAINFRAMES.


 HP       CMND   HLT,,,(HP),(GEN)
          HELP   (HP  HALT PROCESSOR)
          PRME
 SE       SPACE  4,10
**        SE - SELECT CPU.


 SE       CMND   SEP,OWNT,,(SE CP=NUMBER),(ALL)
          HELP   (SE  SET CPU VALUE)
 CP       PRM    SEPA,1
          PRME
 SP       SPACE  4,10
**        SP - START PROCESSOR.
*
*         NOTE   THIS COMMAND IS NOT VALID ON S0/S0E MAINFRAMES.


 SP       CMND   SMC,HPNT,,(SP AD=ADDR.),(GEN)
          HELP   (SP  START CONTROL STORE)
 AD       PRM    VAL1,4
          PRME
 MCUC     SPACE  4,10
**        MC/UC - EXPLAIN MCR/UCR BITS.
*
*         NOTE   THESE COMMANDS ARE NOT VALID ON S0/S0E MAINFRAMES.


 MC       CMND   MCR,HWNT,MCL,(MC RV=VALUE),(GEN)
          HELP   (MC  EXPLAIN MCR BITS)
 UC       CMND   UCR,HWNT,MCL,(UC RV=VALUE),(GEN)
          HELP   (UC  EXPLAIN UCR BITS)
 MCL      BSS    0
 RV       PRM    NBUF,1
          PRME
 DP       SPACE  4,10
**        DP - DISPLAY PP REGISTERS.
*
*         NOTE   THIS COMMAND IS NOT VALID ON S0/S0E MAINFRAMES.


 DP       CMND   DPR,OWNT,,(DP [A/P/K/Q]),(GEN)
          HELP   (DP  DISPLAY PP REGISTER)
          PRM    DPRB
 P        PRMV   0
 Q        PRMV   1
 K        PRMV   2
 A        PRMV   3
          PRME
 IP       SPACE  4,10
**        IP - IDLE PP.
*
*         NOTE   THIS COMMAND IS NOT VALID ON S0/S0E MAINFRAMES.


 IP       CMND   IPR,OWNT,,(IP PP=NUMBER [N/C]),(GEN)
          HELP   (IP  IDLE PP)
 PP       PRM    PP,1
          PRM    PPCT
 N        PRMV   0           NON-CONCURRENT PP
 C        PRMV   1           CONCURRENT PP
          PRME
 RP       SPACE  4,10
**        RP - RESTART PP AT SPECIFIED ADDRESS.
*
*         NOTE   THIS COMMAND IS NOT VALID ON S0/S0E MAINFRAMES.


 RP       CMND   RPP,OWNT,,(RP PP=NUMBER AD=ADDR. [N/C]),(GEN)
          HELP   (RP  RESTART PP AT A SPECIFIED ADDRESS)
 PP       PRM    PP,1
 AD       PRM    RPPA,1
          PRM    PPCT
 N        PRMV   0           NON-CONCURRENT PP
 C        PRMV   1           CONCURRENT PP
          PRME
 DF       SPACE  4,10
**        DF - DISPLAY DFT HEADER.


 DF       CMND   DFR,,,(DF),(ALL)
          HELP   (DF  DISPLAY DFT HEADER)
          PRME
 MB       SPACE  4,10
**        MB - DISPLAY DFT MAINTENANCE REGISTER BUFFER DATA.


 MB       CMND   MBR,HWNT,,(MB BN=0..10),(ALL)
          HELP   (MB  DISPLAY DFT MAINTENANCE REGISTER BUFFER)
 BN       PRM    DFTP,1
          PRME
 MD       SPACE  4,10
**        MD - DISPLAY DFT MODEL-DEPENDENT BUFFER.


 MD       CMND   MDR,OWNT,,(MD BI=0..2),(ALL)
          HELP   (MD  DISPLAY DFT MODEL DEPENDENT BUFFER)
 BI       PRM    DFTP,1
          PRME
 NS       SPACE  4,10
**        NS - DISPLAY DFT NON-REGISTER STATUS BUFFER.


 NS       CMND   NSR,HWNT,,(NS BN=0..B),(ALL)
          HELP   (NS  DISPLAY DFT NON-REGISTER STATUS BUFFER)
 BN       PRM    DFTP,1
          PRME
 DD       SPACE  4,10
**        DD - DISPLAY DFT STRUCTURE.


 DD       CMND   DDR,OWNT,,(DD [SI/MR/NV/PR/BC/ME/EC/SS/NS/CM/PS/SD]),(A,
,LL)
          HELP   (DD  DISPLAY DFT STRUCTURE)
          PRM    DDST
 SI       PRMV   SECP
 MR       PRMV   MRBP
 NV       PRMV   NVEP
 PR       PRMV   C17P
 BC       PRMV   BCWP
 ME       PRMV   MECP
 EC       PRMV   ECRP
 SS       PRMV   SSBP
 NS       PRMV   NRSP
 CM       PRMV   DCMP
 PS       PRMV   PRDP
 SD       PRMV   SDBP
          PRME
 SD       SPACE  4,10
**        SD - SET DFT ERROR ACTION.


 SD       CMND   SDR,OWNT,,(SD [T/C/U/A] [ON/OF]),(ALL)
          HELP   (SD  SET DFT STATE FOR ERROR ACTIONS)
          PRM    DFTF
 T        PRMV   0           TOTAL FREEZE
 C        PRMV   1           CORRECTED ERRORS
 U        PRMV   2           UNCORRECTED ERRORS
 A        PRMV   3           ALL ERRORS
          PRM    DFTR
 ON       PRMV   0
 OF       PRMV   3
          PRME
 UE       SPACE  4,10
**        UE - UPDATE DFT ECR ELEMENT.


 UE       CMND   UER,HWNT,,(UE EI=ID AC=A RA=R RB=R RV=V MA=M MB=M),(ALL)
          HELP   (UE  UPDATE DFT ECR ELEMENT)
 EI       PRM    ECEI,1
 AC       PRM    UEP1,1
 RA       PRM    UEP1,1
 RB       PRM    UEP1,1
 RV       PRM    UEP2,4
 MA       PRM    UEP2,4
 MB       PRM    UEP2,4
          PRME
 DE       SPACE  4,10
**        DE - DISPLAY DFT ECR ELEMENT.


 DE       CMND   DER,HWNT,,(DE EI=ID),(ALL)
          HELP   (DE  DISPLAY DFT ECR ELEMENT)
 EI       PRM    ECEI,1
          PRME
 WE       SPACE  4,10
**        WE - WRITE DFT ECR ELEMENT.


 WE       CMND   WER,,,(WE),(ALL)
          HELP   (WE  WRITE DFT ECR ELEMENT)
          PRME
 RR       SPACE  4,10
**        RR - SET REFRESH RATE.


 RR       CMND   RRR,OWNT,,(RR [FA/SL]),(ALL)
          HELP   (RR  SET REFRESH RATE)
          PRM    HLPC
 FA       PRMV   0
 SL       PRMV   1
          PRME
 SR       SPACE  4,10
**        SR - SET/CLEAR REFRESH MODE.


 SR       CMND   CMDF,OWNT,,(SR [ON/OF]),(ALL)
          HELP   (SR  SET REFRESH)
          PRM    RFLG
 OF       PRMV   0
 ON       PRMV   1
          PRME
 BY       SPACE  4,10
**        BY - TERMINATE *MDD* AND POSSIBLY RELEASE PP.


 BY       CMND   BYE,,,(BY),(ALL)
          HELP   (BY  RETURN MDD PP)
          PRME
 HE       SPACE  4,10
**        HE - HELP.


 HE       CMND   HEP,,,(HE COMMAND),(ALL)
          HELP               END OF LIST
          PRME

 CMDS     BSS    0
 CMDS     HERE
          CON    0           END OF LIST

          OVERFLOW  SCMT     CHECK FOR OVERFLOW

          CODE   *
          PURGMAC CMND
          ENDX
*DECK DECK=CTI$SCI_DEADSTART_VE_AFTER_MDD EXPAND=FALSE
          CTEXT  SCI DEADSTART VE AFTER MDD
          OVERLAY  (SCI DEADSTART NOS/VE AFTER MDD),MBUF
 DVM      SPACE  4,10
**        DVM - DEADSTART NOS/VE AFTER MDD HAS BEEN ACTIVE.
*
*         THIS OVERLAY IS LOADED INTO *MBUF* TO AVOID OVERWRITING
*         ITSELF WITH THE *VPB* LOAD.  THIS PORTION OF MEMORY IS
*         ZEROED OUT BY *VPB* MODE.
*
*         ENTRY  A PORT IS SELECTED ON TPM.
*                CH. 15 FLAG IS SET.
*                (PT) = *MDMT*.


 DVM      ROUTINE

          FNC    MXDM,MX     DESELECT PORT
          AJM    *,MX        WAIT FOR FUNCTION TO COMPLETE
          CCF    *,MX        CLEAR CHANNEL 15 FLAG
          PRINT  DVMA+CRLF   OUTPUT DEADSTARTING MESSAGE
          LDC    BPA         FORCE *MDD* TO GIVE UP PORT
          STM    MDMT+RTNP.
          LDN    0           DISABLE *MDD* MR ERROR PROCESSING
          STM    AACA
          CALL   DSA         INITIATE STANDALONE DEADSTART

 DVMA     ASCII  (Initiating OS activation.)
          QUAL   *

          OVERFLOW  SCMT     CHECK FOR OVERFLOW

          ENDX
*DECK DECK=CTI$SCI_F6_F7_KEY EXPAND=FALSE
          CTEXT  SCI F6 F7 KEY
          OVERLAY (SCI F6/F7 KEY)
 CHS      SPACE  4,10
**        CHS - CHANGE DRIVER STATE.
*
*         CLEARS THE RECEIVED A 1E(16) FLAG AND DETERMINES
*         IF THIS ROUTINE WAS CALLED TO PROCESS *F6* OR *F7*.
*         SETS *MDD* TO NON-REFRESHING DISPLAY MODE.
*
*         EXIT   TO *TSM* FOR *F6* KEY.
*                TO *CSM* FOR *F7* KEY.


 CHS      ROUTINE

          LDI    PT          SAVE CURRENT ROUTINE
          STM    NRTP.,PT
          LDN    0
          STM    RSMC.,PT    RESET FOUND 0#1E
          STM    RFLG        TURN OFF *MDD* REPEAT DISPLAY
          LDM    MDMT+PTDB.  CHECK *MDD* STATUS
          ZJN    CHS1        IF NO *MDD*
          LDC    MDD         CLEAR ANY POSSIBLE MIDSTREAM OUTPUT FROM *MDD*
          STM    MDMT+RTNP.
          STM    MDMT+NRTP.
 CHS1     LDM    RDCA        DETERMINE WHICH FUNCTION KEY WAS HIT
          LMC    WW
          ZJP    TSM         IF *F7* KEY
*         LJM    CSM         PROCESS *F6* KEY

          ERRNZ  CSM-*       MUST FALL DIRECTLY INTO *CSM*
 CSM      SPACE  4,10
**        CSM - CHANGE SCD MODE.
*
*         RESETS THE ROUTINE LIST AND NEXT ROUTINE POINTER IF
*         THE CHANGE OF STATE IS POSSIBLE PER THE DEFINITION
*         BYTE (PTDB.) ELSE DOES NOTHING.
*
*         EXIT   TO *RDCX* IF TOGGLE IS MADE.
*                TO *RAB* IF TOGGLE IS NOT POSSIBLE.


 CSM      BSS    0           ENTRY
          LDD    PT          TEST FOR IN *MDD* MODE
          LMC    MDMT
          ZJP    RAB         IF KEY RECEIVED IN *MDD* MODE
          LDM    SCMT+SCDS.
          ZJN    CSM3        IF CURRENTLY *SCD/NOS*

*         TOGGLE FROM *SCD/VE* TO *SCD/NOS*.

          LDML   SCMT+PTDB.  CHECK *SCD/NOS* STATUS
          SHN    21-11
          PJP    RAB         IF *SCD/NOS* NOT PRESENT
          LDN    0
          STM    SCMT+SCDS.  SET *SCD/NOS* STATE
          LDM    SCMT+NRTL.  RESTORE PREVIOUS ROUTINE
          NJN    CSM1        IF PREVIOUS ROUTINE DEFINED
          LDC    NOSCI       SET ADDRESS TABLE
 CSM1     STM    SCMT+RTNL.
          LDC    PCL         ACTIVATE NOS CONTROLWARE NEXT
 CSM2     STI    PT          RESET NEXT ROUTINE
          LJM    RDCX        RETURN

*         TOGGLE FROM *SCD/NOS* TO *SCD/VE*.

 CSM3     LDML   SCMT+PTDB.  CHECK *SCD/VE* STATUS
          SHN    21-12
          PJN    RAB         IF *SCD/VE* NOT PRESENT
          AOM    SCMT+SCDS.  SET *SCD/VE* STATE
          LDN    0
          STM    SCMT+SCRN.  RESET SCREEN OFFSET FOR NOS/VE
          LDM    SCMT+RTNL.  SAVE *SCD/NOS* ROUTINE
          STM    SCMT+NRTL.
          LDC    NVESI       SET NEXT ROUTINE
          STM    SCMT+RTNL.
          LDC    VES         ACTIVATE *SCD/VE* CONSOLE NEXT
          UJN    CSM2        RETURN
 RAB      SPACE  4,10
**        RAB - RING A BELL.
*
*         EXIT   ASCII *BEL* PLACED IN THE OUTPUT STREAM IF THERE IS ROOM.
*                TO *RDCX*.


 RAB      BSS    0           ENTRY
          LDM    PTUS.,PT    GET INPUT PORT
          LPN    1           TEST FOR INPUT ON PORT ONE
          ZJN    RAB1        IF NOT
          LDM    CHP1.,PT    FIND END OF CURRENT OUTPUT LIST
          ADM    CHR1.,PT
          STD    T0
          ADC    -CHARS.     TEST FOR END OF BUFFERS
          SBD    PT
          PJN    RAB3        IF BEYOND BUFFER
          AOM    CHR1.,PT    INCREASE OUTPUT COUNT
          UJN    RAB2        CONTINUE

 RAB1     LDM    PTUS.,PT    GET OUTPUT PORTS
          LPN    1           TEST FOR INPUT ON PORT ONE
          NJN    RAB3        IF SO
          LDM    CHP0.,PT    FIND END OF CURRENT OUTPUT LIST
          ADM    CHR0.,PT
          STD    T0
          ADC    -CHARS.     TEST FOR END OF BUFFERS
          SBD    PT
          PJN    RAB3        IF BEYOND BUFFER
          AOM    CHR0.,PT    INCREASE OUTPUT COUNT
 RAB2     LDN    7           SEND A BELL
          STI    T0
          AOM    CHRC.,PT
 RAB3     LDM    NRTP.,PT    GET LAST ROUTINE BACK
          STI    PT
          LJM    RDCX        RETURN
 TOP      SPACE  4,10
**        TOP - TOGGLE OFF PORT IF REQUESTED.
*
*         EXIT   (A) = 0 IF NO OTHER PP WANTS THE PORT
*                (A) <> 0 IF ANOTHER PP HAS SET REREQUESTED.
*
*         CALLS  RTR.


 TOP2     LDC    BPA         SET ROUTINE TO BREAK PORT ACCESS NEXT
          STI    PT

 TOP      SUBR               ENTRY/EXIT
          LDM    S0FLG       TEST IOU TYPE
          NJN    TOP1        IF ON AN S0/S0E
          RJM    RTR         READ TEST MODE REGISTER
          LPN    60          IGNORE RESERVED BITS
          SHN    -3          ALIGN REREQUESTED BITS WITH PTUS.
          LPML   PTUS.,PT    GET CURRENT PORTS IN USE
          NJN    TOP2        IF REREQUESTED SET FOR A USED PORT
 TOP1     LDN    0           THIS LOOKS WEIRD BUT NEED FOR S0/S0E TEST
          UJN    TOPX        RETURN
 TSM      SPACE  4,10
**        TSM - TOGGLE BETWEEN *SCD* AND *MDD*.
*
*         RESETS THE PORT USAGE AND PORT DEFINITION FOR *MDD* AND
*         *SCD* TO CONVERT THE USAGE OF THE PORT.
*
*         EXIT   TO *RDCX* IF TOGGLE IS POSSIBLE.
*                TO *RAB* IF KEY INAPPROPRIATE AND IGNORED.
*
*         CALLS  TOP.


 TSM      BSS    0           ENTRY
          LDD    PT          TEST ENTRY USER
          LMC    MDMT
          ZJP    TSM5        IF MDD CURRENTLY

*         PROCESS *F7* DETECTED IN *SCD* MODE.

          LDM    MDMT+PTDB.  CHECK *MDD* STATUS
          NJN    TSM2        IF DEFINED
 TSM1     RJM    TOP         TOGGLE OFF PORT
          ZJP    RAB         IF NO ONE WANTS PORT
          LJM    RDCX        RETURN

*         TOGGLE FROM *SCD* TO *MDD*.

 TSM2     LPN    3
          STD    T2          SAVE *MDD* PORT(S)
          SBN    2
          PJN    TSM3        IF *MDD* WANTS BOTH PORTS
          LDM    SCMT+PTDB.  GET WHICH PORT *F7* CAME FROM
          LPN    1
          LMD    T2
          NJN    TSM1        IF *MDD* DOES NOT WANT THIS PORT
 TSM3     LDN    0           CLEAR *SCD* ROUTINE
          STI    PT
          LDM    MDMT+PTDB.  SET THAT *MDD* HAS THE PORT
          LMC    10000
          STML   MDMT+PTDB.
          LDML   SCMT+PTDB.  CLEAR THAT *SCD* HAS THE PORT
          STM    SCMT+PTDB.
          LDM    TSMC,T2     SET UP BIT TOGGLING FOR *PTUS.*
          STD    T4
          LMC    SCNI        FORM *SCN* INSTRUCTION
          STM    TSMA
          LDML   MDMT+PTUS.  UPDATE *MDD* PORT STATUS
 TSMA     SCN    **
*         SCN    2           (PORT 0)
*         SCN    5           (PORT 1)
*         SCN    6           (PORT 0 INPUT, BOTH PORTS OUTPUT)
*         SCN    7           (PORT 1 INPUT, BOTH PORTS OUTPUT)
          LMD    T4
          STML   MDMT+PTUS.
          LDML   SCMT+PTUS.  UPDATE *SCD* PORT STATUS
          LMD    T4
          STML   SCMT+PTUS.
          LDM    MDMT+RTNL.  RESET *MDD* ROUTINE LIST
          STD    T4
          LDI    T4
          STM    MDMT+RTNP.
 TSM4     LJM    RDCX        RETURN

*         PROCESS *F7* DETECTED IN *MDD* MODE.

 TSM5     LDD    DO          TEST IF STANDALONE DEADSTART
          ZJN    TSM5.5      IF DUAL-STATE
          LDDL   VA          TEST FOR *MDD* UTILITY MODE
          SHN    21-14
          MJP    RAB         IF *MDD* UTILITY MODE
          NJN    TSM5.5      IF NOS/VE IS AROUND
          LDM    SCMT+PTDB.  TEST IF *SCD* IS ACTIVE
          NJN    TSM5.5      IF NOT INITIATING DEADSTART FROM *MDD*
          CALL   DVM         DEADSTART NOS/VE FROM *MDD* MODE

 TSM5.5   RJM    TOP         TOGGLE OFF PORT
          NJN    TSM4        IF SOMEONE WANTED THE PORT
          LDM    SCMT+PTDB.  CHECK *SCD* STATUS
          ZJP    RAB         IF NOT DEFINED

*         TOGGLE FROM *MDD* TO *SCD*.

          LPN    3           SAVE *SCD* PORT(S)
          STD    T2
          SBN    2
          PJN    TSM6        IF *SCD* WANTS BOTH PORTS
          LDM    MDMT+PTDB.  GET WHICH PORT *F7* CAME FROM
          LPN    1
          LMD    T2
          NJP    RAB         IF *SCD* DOES NOT WANT THIS PORT
 TSM6     LDM    SCMT+PTDB.  SET THAT *SCD* HAS THE PORT
          LMC    10000
          STML   SCMT+PTDB.
          LDML   MDMT+PTDB.  CLEAR THAT *MDD* HAS THE PORT
          STM    MDMT+PTDB.
          LDM    TSMC,T2     SET UP BIT TOGGLING FOR *PTUS.*
          STD    T4
          LMC    SCNI        FORM *SCN* INSTRUCTION
          STM    TSMB
          LDML   SCMT+PTUS.  UPDATE *SCD* PORT STATUS
 TSMB     SCN    **
*         SCN    2           (PORT 0)
*         SCN    5           (PORT 1)
*         SCN    6           (PORT 0 INPUT, BOTH PORTS OUTPUT)
*         SCN    7           (PORT 1 INPUT, BOTH PORTS OUTPUT)
          LMD    T4
          STML   SCMT+PTUS.
          LDML   MDMT+PTUS.  UPDATE *MDD* PORT STATUS
          LMD    T4
          STML   MDMT+PTUS.
          LDM    SCMT+SCDS.  GET CURRENT *SCD* MODE
          ZJN    TSM7        IF NOS MODE
          LDC    VES         SET *RTNP.* TO SCD/VE STARTUP ROUTINE
          UJN    TSM8        CONTINUE

 TSM7     LDC    PCL         SET *RTNP.* TO LOAD CONTROLWARE
 TSM8     STM    SCMT+RTNP.
          LJM    RDCX        RETURN

 TSMC     CON    2           PORT 0 INPUT/OUTPUT
          CON    5           PORT 1 INPUT/OUTPUT
          CON    6           PORT 0 INPUT, BOTH PORTS OUTPUT
          CON    7           PORT 1 INPUT, BOTH PORTS OUTPUT

          OVERFLOW  SCMT     CHECK FOR OVERFLOW

          ENDX
*DECK DECK=CTI$SCI_MDD_COMMANDS EXPAND=FALSE
          CTEXT  SCI MDD COMMANDS
          OVERLAY  (MDD DISPLAY/ENTER CENTRAL MEMORY COMMANDS)
 DCM      SPACE  4,10
**        DCM - DISPLAY CENTRAL MEMORY.
*
*         CALLS  DMB.


 DCM      ROUTINE

 DCM0     AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDN    2           SET OCTAL/DISPLAY DUMP
          RJM    DMB         DISPLAY MEMORY BLOCK
          LDC    DCM0+OCWD   REFRESH ADDRESS
          LJM    CMDR        RETURN
 DHB      SPACE  4,10
**        DHB - DISPLAY 64 BIT MEMORY FROM A BYTE ADDRESS.
*
*         CALLS  DMB, TBA.


 DHB      ROUTINE

          LDD    PC          GET PARAMETER COUNT
          LPN    1S1
          ZJN    DHB0        IF ADDRESS NOT ENTERED
          RJM    TBA         TRANSLATE BYTE ADDRESS
 DHB0     AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDN    0           SET HEX BYTE DISPLAY
          RJM    DMB         DISPLAY MEMORY BLOCK
          LDC    DHB0+HXBT   REFRESH ADDRESS
          LJM    CMDR        RETURN
 DHX      SPACE  4,10
**        DHX - DISPLAY 64 BIT MEMORY IN HEX.
*
*         CALLS  DMB.


 DHX      ROUTINE

          LDN    1           SET HEX WORD DISPLAY
          STM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          RJM    DMB         DISPLAY MEMORY BLOCK
          LDC    DHX+HXWD    REFRESH ADDRESS
          LJM    CMDR        RETURN
 EBT      SPACE  4,10
**        EBT - ENTER HEX BYTE MEMORY.
*
*         ENTRY  (PC) = PARAMETER COUNT.
*
*         USES   T1, T2, T6.
*
*         CALLS  CBR, DNV, INW, TBA.


 EBT      ROUTINE

          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDD    PC          GET PARAMETER COUNT
          LPN    1S1
          NJN    EBT0        IF ADDRESS SPECIFIED
          LJM    CMDE        SET ERROR

 EBT0     LDM    VAL1+3      SAVE BYTE NUMBER FROM BEGINNING OF WORD
          LPN    7
          STD    T6
          RJM    TBA         TRANSLATE BYTE ADDRESS
          RJM    CBR         CHECK BOUNDS REGISTER
 EBT1     LDN    1+MRNT
          RJM    DNV
          NJN    EBT2        IF ANOTHER BYTE TO WRITE
          AOML   CMWC        INCREMENT CM WRITE COUNTER
          LJM    CMDF        RETURN

 EBT2     LDD    MP+2
          LMC    RR          ACTIVATE R-REGISTER
          CRML   NBUF,ON     READ WORD TO BE PATCHED
          LDD    T6
          SHN    -1
          STD    T2
          LDD    T6
          LPN    1
          STD    T1
          NJN    EBT3        IF ODD BYTE
          LDM    ABUF
          SHN    8D
          STML   ABUF
 EBT3     LDML   NBUF,T2     CHANGE DESIRED BYTE
          LPML   EBTA,T1
          LMML   ABUF
          STML   NBUF,T2
          LDD    MP+2
          LMC    RR          ACTIVATE R-REGISTER
          CWML   NBUF,ON     REWRITE WORD
          AOD    T6
          SBN    8D
          MJN    EBT4        IF NOT AT WORD BOUNDARY
          STD    T6
          RJM    INW         INCREMENT TO NEXT WORD
 EBT4     LJM    EBT1        GET NEXT PARCEL

 EBTA     BSS    0           BYTE MASKS
          LOC    0
          CON    0#00FF
          CON    0#FF00
          LOC    *O
 ECM      SPACE  4,10
**        ECM - ENTER CENTRAL MEMORY.
*
*         CALLS  CBR, SMP.


 ECM      ROUTINE

          RJM    SMP         SET MEMORY PARAMETERS
          RJM    CBR         CHECK BOUNDS REGISTER
          LDD    MP+2        RESET (A)
          LMC    RR          ACTIVATE R-REGISTER
          CWM    MRBF,ON
          AOML   CMWC        INCREMENT CM WRITE COUNTER
          LJM    CMDF        RETURN
 RRR      SPACE  4,10
**        RRR - REFRESH RATE ROUTINE.


 RRR      ROUTINE

          LDM    HLPC        GET PARAMETER VALUE
          ZJN    RRR1        IF FASTER
          LDM    RRRP        GET NUMBER OF INCREASES
          LMN    17
          ZJN    RRR3        IF SLOWEST POSSIBLE NOW
          AOM    RRRP        INCREMENT VALUE
          UJN    RRR2        FORM LOAD INSTRUCTION

 RRR1     LDM    RRRP        GET NUMBER IF INCREASES
          LMN    4
          ZJN    RRR3        IF FASTEST POSSIBLE NOW
          SOM    RRRP        DECREMENT VALUE
 RRR2     SHN    11          SHIFT TO SIGNIFICANCE
          STML   MDDR
 RRR3     LJM    CMDF        RETURN
 CBR      SPACE  4,10
**        CBR - CHECK BOUNDS REGISTER.
*
*         EXIT   BOUNDS REGISTER SET PROPERLY FOR WRITE.
*
*         CALLS  CMB, SPB.


 CBR      SUBR               ENTRY/EXIT
          RJM    CMB         CHECK MEMORY BOUND
          RJM    SPB         SET PP BOUNDARY
          UJN    CBRX        RETURN
 CMB      SPACE  4,10
**        CMB - CHECK MEMORY BOUNDS.
*
*         EXIT   RETURN IF WRITE PERMITTED.
*                TO *CMDF* IF WRITE BEYOND MEMORY BOUNDS.
*
*         USES   RN, T0, T1, T2.
*
*         MACROS PRINT.


 CMB1     READMR RDATA,ELCM,S0MBRG  READ S0/S0E MEMORY BOUNDS REGISTER
          LDM    RDATA       REFORMAT TO NON-S0/S0E REGISTER FORMAT
          STM    RDATA+4
          LDM    RDATA+1
          STM    RDATA+5
          LDC    0#40        SET FAKE ENABLED FLAG
          STM    RDATA
          UJN    CMB2        ENTER COMMON CODE SEQUENCE

 CMB      SUBR               ENTRY/EXIT
          LDM    S0FLG       CHECK MAINFRAME TYPE
          NJN    CMB1        IF S0/S0E
          LDK    MBRG
          STD    RN
          LDM    ELCM
          RJM    RMR         READMR RDATA,ELCM,MBRG MEMORY BOUNDS REGISTER
 CMB2     LDM    RDATA
          LPC    0#40
          ZJN    CMBX        IF PORT BOUNDS CHECKING OFF
          LDM    MEMM        CHECK MEMORY MODEL NUMBER
          LMC    0#34
          ZJN    CMB4        IF MODEL 34 MEMORY
          LMN    0#35&0#34
          ZJN    CMB4        IF MODEL 35 MEMORY
          LDM    RDATA+4     PACK UPPER BOUND
          SHN    8D
          LMM    RDATA+5
          SHN    -3
          STDL   T0          SAVE IT IN T0
 CMB3     SRD    T1          SAVE UPPER 16 BITS OF R-REGISTER
          LDD    T2          GET UPPER 6 FROM LOWER 12
          SHN    -6
          STD    T2
          LDD    T1          GET UPPER 10 BITS
          SHN    6
          LMDL   T2          ADD IN T2
          SBDL   T0          SUBTRACT BOUNDS
          MJP    CMBX        IF WRITE LESS THAN BOUNDS
          AOM    OVLP
          PRINT  CMBM+CRLF   *WRITE WOULD CROSS MEMORY BOUNDS*
          LJM    CMDF        RETURN FROM CM-WRITE

*         EXTRACT MEMORY BOUNDS FOR MODEL 34 MEMORY.

 CMB4     LDM    RDATA+6
          SHN    10
          LMM    RDATA+7
          SHN    -3
          STDL   T0
          LDM    RDATA+5     EXTRACT UPPER 3 BITS OF BOUNDS ADDRESS
          LPN    7
          SHN    17-2
          RADL   T0
          UJP    CMB3        COMPARE VALUES

 CMBM     ASCII  (WRITE WOULD CROSS MEMORY BOUNDS)
 DDT      SPACE  4,10
**        DDT - DISPLAY DISPLAY CODE TEXT.
*
*         ENTRY  (NBUF - NBUF+4) = DISPLAY CODE TEXT.
*
*         USES   T2.
*
*         CALLS  PDC.


 DDT      SUBR               ENTRY/EXIT
          LDN    1R
          STIAO  BP          PUT CHARACTER IN OUTPUT QUEUE
          LDN    0
          STD    T2
 DDT1     LDM    NBUF,T2
          SHN    -6
          RJM    PDC         PRINT UPPER CHARACTER
          LDM    NBUF,T2
          LPN    77
          RJM    PDC         PRINT LOWER CHARACTER
          AOD    T2
          LMN    5
          NJN    DDT1        IF MORE TO DISPLAY
          UJN    DDTX        RETURN
 DMB      SPACE  4,10
**        DMB - DISPLAY MEMORY BLOCK IN DESIRED FORM.
*
*         ENTRY  (A) = MEMORY DISPLAY FORMAT.
*                      0 = HEX BYTE/ASCII.
*                      1 = HEX WORD/ASCII.
*                      2 = OCTAL/DISPLAY.
*
*         USES   T1, WC.
*
*         CALLS  DAT, DDT, EOL, INW, LCA, PRN, SMP, SNP.


 DMB      SUBR               ENTRY/EXIT
          STD    T1
          LDM    DMBB,T1     SET ROUTINE ADDRESS
          STM    DMBA
          RJM    SMP         SET MEMORY PARAMETERS
 DMB1     SOD    WC          DECREMENT WORD COUNT
          MJN    DMBX        IF ALL WORDS DISPLAYED
          LDD    MP          SET ADDRESS FOR *PRN*
          SHN    14
          LMD    MP+1
          SHN    -6
          STM    NBUF        UPPER FOUR CHARACTERS (10 BITS)
                             ** NOTE UPPER 2 BITS INVALID - 0'S **
          LDD    MP+1
          SHN    14
          LPC    770000      CLEAR LOWER 4 BITS
          LMD    MP+2
          SHN    -6
          STM    NBUF+1      NEXT FOUR CHARACTERS (12 BITS)
          LDD    MP+2
          SHN    6
          STM    NBUF+2      LAST TWO CHARACTERS (6 BITS)
          LJM    **          PROCESS MEMORY WORD
 DMBA     EQU    *-1

 DMBB     BSS    0
          LOC    0
          CON    DMB2        HEX BYTE/ASCII
          CON    DMB3        HEX WORD/ASCII
          CON    DMB5        OCTAL/DISPLAY
          LOC    *O

*         HEX BYTE WITH ASCII INTERPRETATION.

 DMB2     RJM    SNB         CHANGE TO BYTE ADDRESS
          LDN    8D          SET DIGITS TO PRINT
          STM    DMBC
          LDN    HBDT/10000
          UJN    DMB4        PROCESS LIKE HEX WORD DISPLAY

*         HEX WORD WITH ASCII INTERPRETATION.

 DMB3     RJM    SNB         CHANGE TO A WORD ADDRESS
          RJM    SNB
          LDN    7           SET DIGITS TO PRINT
          STM    DMBC
          LDN    HMDT/10000
 DMB4     ADC    LDCI
          STM    DMBD        SET DISPLAY TYPE
          LDC    HPDT+7
 DMBC     EQU    *-1
          RJM    PRN         DISPLAY ADDRESS
          RJM    LCA         LOAD ADDRESS
          CRML   NBUF,ON     READ MEMORY WORD
 DMBD     LDC    HMDT+16D    HEX WORD MEMORY DUMP
*         LDC    HBDT+16D    HEX BYTE MEMORY DUMP
          RJM    PRN         DISPLAY CONTENTS OF ADDRESS
          RJM    DAT         DISPLAY ASCII TEXT
          UJN    DMB6        COMPLETE LINE AND INCREMENT ADDRESS

*         OCTAL WITH DISPLAY CODE INTERPRETATION.

 DMB5     LDC    OMDT+12
          RJM    PRN         DISPLAY ADDRESS IN OCTAL
          RJM    LCA         LOAD ADDRESS
          CRM    NBUF,ON
          LDC    OMDT+20D
          RJM    PRN         DISPLAY CONTENTS OF ADDRESS
          RJM    DDT         DISPLAY TEXT
 DMB6     RJM    EOL         END LINE
          RJM    INW         INCREMENT TO NEXT WORD
          LJM    DMB1        CHECK FOR MORE TO DISPLAY
 INW      SPACE  4,10
**        INW - INCREMENT TO NEXT WORD ADDRESS.
*
*         ENTRY  (MP - MP+2) = CM ADDRESS.
*
*         EXIT   (MP - MP+2) = CM ADDRESS + 1.


 INW      SUBR               ENTRY/EXIT
          AOD    MP+2
          SHN    -14         SAVE CARRY BIT
          RAD    MP+1
          SHN    -14         SAVE CARRY BIT
          ADD    MP
          LPN    17          ONLY 4 BITS VALID
          STD    MP
          UJN    INWX        RETURN
 LCA      SPACE  4,10
**        LCA - LOAD CM ADDRESS.
*
*         ENTRY  (MP - MP+2) = CM ADDRESS.
*
*         EXIT   (R-REGISTER) (A) = CM ADDRESS.
*
*         USES   T1, T2.


 LCA      SUBR               ENTRY/EXIT
          LDD    MP+1        BITS 4 TO 15
          SHN    6
          STD    T2          BITS 10 TO 15 OF ADDRESS
                             * BITS 16 TO 21 WILL BE IN A REGISTER
          LPC    770000      BITS 4 TO 9 LEFT
          ADD    MP          GET BITS 0 TO 3
          SHN    6           GET INTO PROPER ORDER
          STD    T1          SAVE UPPER TEN BITS
          LRD    T1
          LDD    MP+2        GET BITS 16 TO 27
          LMC    RR          ACTIVATE R-REGISTER
          UJN    LCAX        RETURN
 PDC      SPACE  4,10
**        PDC - PRINT DISPLAY CODE CHARACTER.
*
*         ENTRY  (A) = DISPLAY CODE CHARACTER.
*
*         EXIT   CHARACTER CONVERTED TO ASCII AND PRINTED.


 PDC2     LDN    1R
 PDC3     STIAO  BP          PUT CHARACTER IN OUTPUT QUEUE

 PDC      SUBR               ENTRY/EXIT
          ZJN    PDC2        IF COLON
          SBN    33
          PJN    PDC1        IF NOT ALPHABETIC
          ADC    1RA-1+33
          UJN    PDC3        PRINT IT

 PDC1     SBN    10D
          PJN    PDC2        IF NOT NUMERIC
          ADN    1R0+10D
          UJN    PDC3        PRINT IT
 SMP      SPACE  4,10
**        SMP - SET MEMORY PARAMETERS.
*
*         ENTRY  (VAL1 - VAL1+3) = MEMORY ADDRESS.
*                (VAL3 - VAL3+2) = INCREMENT VALUE.
*                (VAL2) = WORD COUNT.
*
*         EXIT   TO *CMDE* IF ADDRESS BEYOND PHYSICAL MEMORY SIZE.
*                (MP - MP+2) = MEMORY ADDRESS.
*                (WC) = WORD COUNT.
*                (A) = MEMORY ADDRESS RELATIVE TO R.
*
*         USES   MP - MP+2, WC.
*
*         CALLS  FHE, LCA.


 SMP      SUBR               ENTRY/EXIT
          LDM    VAL3+2      INCREMENT MEMORY ADDRESS
          RAM    VAL1+3      BITS 16 TO 27 OF ADDRESS
          STD    MP+2
          SHN    -14         SAVE CARRY BIT
          ADM    VAL3+1      INCREMENT
          RAM    VAL1+2      BITS 4 TO 15 OF ADDRESS
          STD    MP+1
          SHN    -14         SAVE CARRY BIT
          ADM    VAL3
          RAM    VAL1+1      BITS 0 TO 4 OF ADDRESS
          LPN    17
          STD    MP
          LDN    0
          STM    VAL3        CLEAR INCREMENT
          STM    VAL3+1
          STM    VAL3+2

*         VERIFY THAT ADDRESS IS WITHIN PHYSICAL MEMORY SIZE.  NOTE THAT
*         ONLY THE FWA IS CHECKED, SO THAT IT IS POSSIBLE TO SUBVERT THIS
*         CHECK BY SPECIFYING A VALID FWA WITH A TOO-LARGE WORD COUNT.

          LDN    CMID        READ MEMORY DESCRIPTOR
          RJM    FHE
          LDM    HBUF+CMIPMS CALCULATE PHYSICAL MEMORY SIZE
          SHN    6
          STM    HBUF+2
          SHN    -14
          STM    HBUF+1
          LDM    HBUF+CMIPMS+1
          SHN    6
          STM    HBUF+3
          SHN    -14
          RAM    HBUF+2
          LDM    VAL1        VALIDATE ADDRESS
          NJP    SMP3        IF ADDRESS BEYOND PHYSICAL MEMORY SIZE
          LDM    VAL1+1
          SBM    HBUF+1
          MJN    SMP1        IF ADDRESS VALID
          NJN    SMP3        IF ADDRESS BEYOND PHYSICAL MEMORY SIZE
          LDM    VAL1+2
          SBM    HBUF+2
          MJN    SMP1        IF ADDRESS VALID
          NJN    SMP3        IF ADDRESS BEYOND PHYSICAL MEMORY SIZE
          LDM    VAL1+3
          SBM    HBUF+3
          PJN    SMP3        IF ADDRESS BEYOND PHYSICAL MEMORY SIZE
 SMP1     LDM    VAL2        CHECK WORD COUNT
          SBN    20
          MJN    SMP2        IF <= 16
          LDN    20          LIMIT WORD COUNT TO 16
          STM    VAL2
 SMP2     LDM    VAL2        STORE WORD COUNT
          STD    WC
          RJM    LCA         LOAD CM ADDRESS
          LJM    SMPX        RETURN

 SMP3     LJM    CMDE        PRINT ERROR MESSAGE
 SNB      SPACE  4,10
**        SNB - SHIFT NBUF 1 BIT LEFT.
*
*         EXIT   (NBUF - NBUF+2) LEFT SHIFTED.


 SNB      SUBR               ENTRY/EXIT
          LDM    NBUF+2      LAST SIX BITS
          SHN    15-14       SHIFT LEFT 1
          STM    NBUF+2
          SHN    22-15       MOVE BIT TO END
          LPC    400000      CLEAR REST OF A
          LMM    NBUF+1      GET MIDDLE 12 BITS
          SHN    15-14       SHIFT END BIT AROUND
          STM    NBUF+1
          SHN    22-15       MOVE BIT TO END
          LPC    400000      CLEAR REST OF A
          LMM    NBUF        GET FIRST 12 BITS
          SHN    15-14       SHIFT END BIT AROUND
          STM    NBUF
          UJN    SNBX        RETURN
 TBA      SPACE  4,10
**        TBA - TRANSLATE BYTE ADDRESS.
*
*         EXIT   (VAL1 - VAL1+3) = WORD ADDRESS.
*
*         CALLS  SMP.


 TBA      SUBR               ENTRY/EXIT
          LDM    VAL1        GET HIGH ORDER FIRST
          LPC    177         ONLY POSSIBLE VALID BITS
          SHN    22-3
          STM    VAL1        EFFECT OF SHN -3
          SHN    -3
          LPC    70000
          LMM    VAL1+1
          SHN    22-3
          STM    VAL1+1
          SHN    -3
          LPC    70000
          LMM    VAL1+2
          SHN    22-3
          STM    VAL1+2
          SHN    -3
          LPC    70000
          LMM    VAL1+3
          SHN    -3          SHIFT OFF ODD BYTES
          STM    VAL1+3
          RJM    SMP         SET MEMORY PARAMETERS
          LJM    TBAX        RETURN

          OVERFLOW  SCMT     CHECK FOR OVERFLOW
          OVERLAY  (MDD MAINTENANCE REGISTER ROUTINES)
 CER      SPACE  4,10
**        CER - CLEAR ERROR IN REGISTERS.
*
*         EXIT   TO *CXR1*.
*
*         CALLS  SMO.


 CER      ROUTINE

          LDM    MRPV
          RJM    SMO         SET UP MAINTENANCE REGISTER OPERATION
          FUNCMR ,MRCE
          UJN    CXR1        RETURN
 CXR      SPACE  4,10
**        CXR - CLEAR ERROR IN REGISTERS.
*
*         CALLS  SMO.
*
*         MACROS PRINT.


 CXR      ROUTINE

          LDM    MRPV
          RJM    SMO         SET UP MAINTENANCE REGISTER OPERATION
          FUNCMR ,MRMC
 CXR1     AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          PRINT  CXRM+CRLF   *CLEARED*
          LJM    CMDF        RETURN

 CXRM     ASCII  (CLEARED)
 MRP      SPACE  4,10
**        MRP - MAINTENANCE REGISTER DISPLAY PROCESSOR.
*
*         USES   PP, T0, T1, WC.
*
*         CALLS  DMR, SMO.


 MRP      ROUTINE

          LDD    PC          GET PARAMETER COUNT
          LPN    1S2         TEST FOR REGISTER NUMBER GIVEN
          ZJN    MRP15       IF REGISTER NOT SPECIFIED
          LDD    PC          GET PARAMETER COUNT
          LPN    1S3         TEST FOR COUNT GIVEN
          ZJN    MRP10       IF DISPLAY ONLY ONE REGISTER
          LDM    VAL2        GET REGISTER DISPLAY COUNT
          SBN    20          LIMIT TO REPEAT OF 16
          MJN    MRP5        IF NUMBER IS <= 16
          LDN    20          RESET VAL2 TO MAX
          STM    VAL2
 MRP5     LDM    VAL2        SET NUMBER OF ADDITIONAL REGISTERS TO DISPLAY
 MRP10    STM    MRPC
          LJM    MRP40       PROCESS SPECIFIC REGISTER(S)

 MRP15    AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDM    MRPV        CHECK IF IOU REGISTERS REQUESTED
          LMC    MRIL
          NJP    MRP25       IF MEMORY OR CPU REGISTERS REQUESTED

*         SET UP MODEL-DEPENDENT IOU PROCESSING.

          LDM    IOUM        TEST FOR I4
          LMC    0#43
          ZJP    MRP20       IF MODEL 43
          LMN    0#44&0#43
          ZJP    MRP20       IF MODEL 44
          LDM    IOUM
          LMC    0#42
          ZJN    MRP20       IF MODEL 42
          SHN    -4
          NJN    MRP20       IF NOT I4
          READMR RDATA,I0CC,OIMR  CHECK IF CIO SUBSYSTEM PRESENT
          LDML   RDATA+7     CHECK *OIMR* BIT 56
          SHN    21-63D+56D
          PJN    MRP20       IF CONCURRENT PP-S NOT PRESENT
          LDC    LPNI+2      SET FOR I4 LIST OF REGISTERS
          STM    DMRA        SET MASK IN DISPLAY ROUTINE
          LDC    LPNI+1S5    SET FOR LINE FEED CONTROL
          STM    DMRB        SET MASK IN DISPLAY ROUTINE
 MRP20    UJN    MRP35       DISPLAY REGISTERS

*         SET UP MODEL-DEPENDENT CPU/MEMORY PROCESSING.

 MRP25    LDM    CPUT        GET CLASS OF MACHINE
          LPN    7
          STD    T1
          ZJN    MRP35       IF CLASS FOUND
          LDN    1
          STD    T0
 MRP30    LDD    T0
          SHN    1
          STD    T0          SET MASK IN DISPLAY ROUTINE
          SOD    T1
          NJN    MRP30       IF NOT TO CPU TYPE YET
          LDC    LPNI        SET MASK FOR PROPER LIST
          ADD    T0
          STM    DMRA
          LDD    T0          TEST FOR S3 OR THETA
          SBN    10          BIT SET FOR S3
          MJN    MRP35       IF S1CR/S2
          LDC    LPNI+1S5
          STM    DMRB        SET NO CR/LF FLAG IN DISPLAY ROUTINE

*         DISPLAY DEFAULT LIST OF REGISTERS.

 MRP35    LDM    MRPV        GET LIST TO DISPLAY
          RJM    DMR         READ AND DISPLAY REGISTERS
          LDC    MRP15       REPEAT ADDRESS
          LJM    CMDR        RETURN

*         DISPLAY SPECIFIED REGISTER(S).

 MRP40    LDC    LPNI+77     SET MASK IN DISPLAY ROUTINE
          STM    DMRA
          LDM    MRPV
          RJM    SMO         SET UP MAINTENANCE REGISTER OPERATION
          AOM    OVLP        INHIBIT OVERLAY RELOAD
          LDM    MRPC        GET NUMBER OF REGISTERS TO DISPLAY
          STD    WC
          LDM    MRPE        SAVE STARTING REGISTER NUMBER
          STD    PP
 MRP45    LDC    MRPE
          RJM    DMR         DISPLAY ONE REGISTER
          AOM    MRPE        INCREMENT TO NEXT REGISTER
          SOD    WC          DECREMENT REGISTER COUNT
          PJN    MRP45       IF NEED TO DO ANOTHER REGISTER
          LDD    PP          RESTORE BEGINNING REGISTER NUMBER
          STM    MRPE
          LDC    MRP40       SET REENTRY ADDRESS
          LJM    CMDR        RETURN
 MRW      SPACE  4,10
**        MRW - WRITE MAINTENANCE REGISTER.
*
*         CALLS  DMR, SMO.
*
*         MACROS WRITMR.


 MRW      ROUTINE

          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDM    MRPV
          RJM    SMO         SET UP MAINTENANCE REGISTER OPERATION
          LPN    1S2+1S3
          LMN    1S2+1S3
          NJN    MRW1        IF NOT ENOUGH PARAMETERS
          WRITMR MRBF
          AOML   MRWC        INCREMENT MR WRITE COUNTER
          LDC    LPNI+77     SET ALL MASKS
          STM    DMRA
          LDC    MRPE
          RJM    DMR         DISPLAY REGISTER
          LJM    CMDF        RETURN

 MRW1     LJM    CMDE        PROCESS ERROR
 RFP      SPACE  4,10
**        RFP - DISPLAY REGISTER FILE.
*
*         USES   M1, M2, M3, RN, T1, W1.
*
*         CALLS  AMR, CMI, EOL, PRN.


 RFP      ROUTINE

          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDM    CPUT        GET CPU TYPE
          LPN    7           CLEAR NUMBER OF CPUS
          STD    T1
          LMN    4
          NJN    RFP1        IF NOT A THETA
          LJM    CMDE        ILLEGAL COMMAND ON A THETA

 RFP1     LDM    ELPR        GET PROCESSOR CODE
          SCN    17
          ADM    RFPT,T1
          STD    M3
          LDM    RFPB        GET WORD COUNT
          STD    M1
          LDM    RFPA        GET FIRST ADDRESS TO READ
          STD    M2
 RFP2     LDD    M2
          STD    RN
          STM    NBUF
          LDN    MRDT+2      PRINT TWO DIGIT ADDRESS
          RJM    PRN
          LDC    MRRD        READ CODE
          ADD    M3          ADD IN TYPE CODE
          RJM    AMR
          IAM    NBUF,MR     READ REGISTER
          LDN    10          MUST READ A BLOCK OF 400(8) BYTES
          STD    W1
 RFP3     LDN    37
          IAM    BUF,MR      SKIP UNWANTED DATA
          SOD    W1
          NJN    RFP3        IF NOT DONE SKIPPING DATA
          RJM    CMI         RELEASE INTERLOCK ON MAINTENANCE CHANNEL
          LDN    MRDT+20
          RJM    PRN         PRINT REGISTER VALUE
          RJM    EOL
          AOD    M2
          SOD    M1          DECREMENT COUNT
          NJN    RFP2        IF NOT DONE YET
          LDC    RFP+MRNT    SET REENTRY
          LJM    CMDR        RETURN

 RFPT     DATA   1           CODE FOR AN S1CR
          DATA   1           CODE FOR AN S1
          DATA   5           CODE FOR AN S2
          DATA   7           CODE FOR AN S3
 DMR      SPACE  4,10
**        DMR - DUMP MAINTENANCE REGISTER.
*
*         ENTRY  (A) = LIST OF REGISTERS TO DISPLAY.
*
*         USES   M1, M2, M3.
*
*         CALLS  DTO, EOL, PRN, RMR, SMO, WAS.
*
*         MACROS PRINT, READMR.


 DMR      SUBR               ENTRY/EXIT
          STD    M1
          RJM    SMO         SET UP MAINTENANCE REGISTER OPERATION
 DMR1     LDI    M1
          STD    RN          SET REGISTER NUMBER
          STM    NBUF        SAVE REGISTER NUMBER
          ADC    -400
          PJN    DMRX        IF END OF LIST
          AOD    M1          GET FLAG MASK FOR REGISTER
          LDI    M1
 DMRA     LPN    1           ASSUME S1CR
*         LPN    1           (I1/I1CR/I2)
*         LPN    2           (I4)
*         LPN    1           (S1CR)
*         LPN    2           (S1)
*         LPN    4           (S2)
*         LPN    10          (S3)
*         LPN    20          (THETA)
*         LPN    77          (SPECIFIC REGISTER(S))
          NJN    DMR2        IF MATCH PROCESS REGISTER
 DMR1.5   LDN    2           ADVANCE TO NEXT ENTRY
          RAD    M1          INCREMENT TO NEXT REGISTER
          UJN    DMR1        PROCESS IT

 DMR2     LDN    MRDT+2
          RJM    PRN         PRINT 2 HEX DIGIT REGISTER NUMBER
          LDD    M2          SET CONNECT CODE
          STD    EC
          READMR NBUF
          RJM    DTO         TEST FOR DEADMAN TIMEOUT
          LDN    MRDT+20
          RJM    PRN         DISPLAY 64 BIT REGISTER
 DMR3     LDI    M1          TEST FOR END OF LINE
 DMRB     LPN    **          ASSUME S1CR THROUGH S2
*         LPN    0           (NORMAL)
*         LPN    40          (ALLOW TWO REGISTERS PER LINE)
          ZJN    DMR4        IF NO-EOL BIT IS SET
          PRINT  DMRM        SPACE OVER A LITTLE
          UJN    DMR1.5      GO TO NEXT REGISTER

 DMR4     AOD    M1          PRINT REGISTER NAME
          LDI    M1
          LMC    CRLF        SET TO PRINT EOL
          RJM    WAS
          AOD    M1          INCREMENT TO NEXT REGISTER
          LJM    DMR1        PROCESS IT

 DMRM     ASCII  (        )
 SMO      SPACE  4,10
**        SMO - SET UP MAINTENANCE REGISTER OPERATION.
*
*         ENTRY  (A) = ADDRESS OF MR TABLE.
*                (PC) = PARAMETER COUNT.
*
*         EXIT   (A) = PARAMETER COUNT.
*                (EC) = (M2) = CONNECT CODE.
*                (RN) = (M3) = REGISTER NUMBER.


 SMO      SUBR               ENTRY/EXIT
          STD    T2
          LDM    -1,T2
          STM    MRPE-1
          STD    T2
          LDI    T2          SET ELEMENT CONNECT CODE
          STD    EC
          STD    M2
          LDM    MRPE        FETCH REGISTER NUMBER
          STD    RN
          STD    M3
          LDDL   PC          RETURN WITH (A) = PARAMETER COUNT
          UJN    SMOX        RETURN
          EJECT
**        MAINTENANCE REGISTER TABLES.


          CON    ELIO        IOU PORT CODE ADDRESS
 MRIL     BSS    0           IOU MAINTENANCE REGISTERS
 00       MR     (SS),(1,0)               BIT         MEANING
 12       MR     (OI),(5,1,0)             0           DISPLAY I1 AND I2
 16       MR     (OI),(1)                 1           DISPLAY ON I41
 18       MR     (MASK REG),(5,1,0)       5           DISPLAY NEXT REG.
 1C       MR     (MASK REG),(1)                       ON THIS SAME LINE
 21       MR     (OS BOUNDS),(5,1,0)
 25       MR     (OS BOUNDS),(1)
 30       MR     (EC),(5,1,0)
 34       MR     (EC),(1)
 40       MR     (STATUS),(5,1,0)
 44       MR     (STATUS),(1)
 80       MR     (FS1),(5,1,0)
 84       MR     (FS1),(1)
 81       MR     (FS2),(5,1,0)
 85       MR     (FS2),(1)
 A0       MR     (TM),(5,1,0)
 A4       MR     (TM),(1)
          CON    7777

          CON    ELCM        MEMORY PORT CODE ADDRESS
 MRML     BSS    0           MEMORY MAINTENANCE REGISTERS
 00       MR     (SS),(4,3,2,1,0)         BIT         MEANING
 12       MR     (OI),(4,3,2,1,0)         0           DISPLAY FOR S1CR
 20       MR     (EC),(4,3,2,1,0)         1           DISPLAY FOR S1
 21       MR     (MEM BOUNDS),(4,3,2,1,0) 2           DISPLAY FOR S2
 A0       MR     (CEL),(3,2,1,0)          3           DISPLAY FOR S3
 A0       MR     (CEL0),(4)               4           DISPLAY FOR THETA
 A1       MR     (CEL1),(4)
 A2       MR     (CEL2),(4)
 A3       MR     (CEL3),(4)
 A4       MR     (UEL1),(3,2,1,0)
 A4       MR     (UEL0),(4)
 A5       MR     (UEL1),(4)
 A6       MR     (UEL2),(4)
 A7       MR     (UEL3),(4)
 A8       MR     (UEL2),(3,2,1,0)
          CON    7777
          EJECT
          CON    ELPR        PROCESSOR PORT CODE ADDRESS
 MRPL     BSS    0           PROCESSOR MAINTENANCE REGISTERS
 00       MR     (SS),(4,3,2,1,0)         BIT         MEANING
 30       MR     (DEC),(4,3,2,1,0)        0           DISPLAY FOR S1CR
 31       MR     (S),(4,3,2,1,0)          1           DISPLAY FOR S1
 40       MR     (P),(4,3,2,1,0)          2           DISPLAY FOR S2
 41       MR     (MPS),(4,3,2,1,0)        3           DISPLAY FOR S3
 42       MR     (MCR),(4,3,2,1,0)        4           DISPLAY FOR THETA
 43       MR     (UCR),(4,3,2,1,0)        5           DISPLAY NEXT REG.
 48       MR     (PTA),(4,3,2,1,0)                    ON SAME LINE
 49       MR     (PTL),(4,3,2,1,0)
 4A       MR     (PSM),(4,3,2,1,0)
 51       MR     (MDW),(4,3,2,1,0)
 61       MR     (JPS),(4,3,2,1,0)
 62       MR     (SIT),(4,3,2,1,0)
 80       MR     (PFS),(5,4,3,2,1,0)
 81       MR     (PFS),(4,3,2,0)
 82       MR     (PFS),(5,4,3)
 83       MR     (PFS),(4,3)
 84       MR     (PFS),(5,4,3)
 85       MR     (PFS),(4,3)
 86       MR     (PFS),(5,4,3)
 87       MR     (PFS),(4,3)
 88       MR     (PFS),(5,4,3)
 89       MR     (PFS),(4,3)
 8A       MR     (PFS),(5,4)
 8B       MR     (PFS),(4)
 8C       MR     (PFS),(5,4)
 8D       MR     (PFS),(4)
 8E       MR     (PFS),(5,4)
 8F       MR     (PFS),(4)
 91       MR     (CSEL),(0)
 92       MR     (CCEL),(2)
 93       MR     (MCEL),(2,1,0)
          CON    7777
 BUF      SPACE  4,10
 BUF      EQU    *

          ERRNG  7037B-BUF   MUST SAVE 40 WORDS FOR THIS BUFFER

          QUAL   *
          SPACE  4,10
 MRML     EQUAL
 MRIL     EQUAL
 MRPL     EQUAL

          OVERFLOW  SCMT     CHECK FOR OVERFLOW
          OVERLAY  (MDD PP/CPU DISPLAY/CONTROL ROUTINES)
 DPR      SPACE  4,10
**        DPR - DISPLAY PP REGISTERS.
*
*         USES   M1, M2, M3, PP, T1.
*
*         CALLS  DPP, DTO, EOL, WAS.
*
*         MACROS PRINT, READMR.


 DPR      ROUTINE

          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          READMR MRBF,ELIO,OIMR  GET BARRELS INSTALLED
          RJM    DTO         TEST FOR DEADMAN TIMEOUT
          LDM    MRBF+2
          STD    M1          SAVE BARREL MASK
          LDM    DPRB
          STD    T1
          LDML   DPRT,T1     GET PROPER MESSAGE
          RJM    WAS         PRINT WHICH REGISTERS ARE DISPLAYED
          LDC    ISTR
          STD    M2          SAVE NIO STATUS REGISTER
          LDN    0
          STD    PP          START WITH PP ZERO
          LDN    1
          STD    M3          START WITH BARREL ZERO
 DPR5     LDD    M1
          LPDL   M3          TEST BARREL IS INSTALLED
          ZJN    DPR10       IF BARREL NOT PRESENT
          LDN    DEMR        GET NIO *EC* REGISTER NUMBER
          RJM    DPP         DISPLAY PP-S FROM THIS BARREL
          RJM    EOL         OUTPUT END OF LINE
          LDD    M3          UPDATE BARREL INDICATOR
          RAD    M3
          LMN    20          TEST FOR LAST BARREL
          NJN    DPR5        IF ANOTHER BARREL POSSIBLE
 DPR10    LDM    IOUM        TEST FOR I4
          LMC    0#43
          ZJN    DPR15       IF MODEL 43
          LMN    0#44&0#43
          ZJN    DPR15       IF MODEL 44
          LDM    IOUM
          LMC    0#42
          ZJN    DPR17       IF MODEL 42
          SHN    -4
          ZJP    DPR20       IF AN I4
 DPR15    LJM    DPR25       NOT AN I4

 DPR17    READMR MRBF,ELIO,OIMR  GET BARRELS INSTALLED
          LDM    MRBF+7      GET CIO BARREL INSTALLED
          LPC    0#80
          ZJN    DPR15       IF NO CIO INSTALLED
          LDC    ISTR
          STD    M2          SAVE NIO STATUS REGISTER
          LDN    1
          STD    M3          START WITH BARREL ZERO
          STD    M1          BARREL 0
          LDN    30B
          STD    PP          START WITH PP 0 BIASED BY 30B
          PRINT  DPRC+CRLF   LABEL AS CIO PP
          LDN    DEMR        GET NIO *EC* REGISTER NUMBER
          RJM    DPP         DISPLAY PP-S FROM THIS BARREL
          RJM    EOL         OUTPUT END OF LINE
          LJM    DPR25       GO DISPLAY BARREL

 DPR20    READMR MRBF,ELIO,OIMR+4  GET CIO BARRELS INSTALLED
          RJM    DTO         TEST FOR DEADMAN TIMEOUT
          LDM    MRBF+2
          STD    M1          SAVE BARREL MASK
          LPN    1
          ZJN    DPR25       IF NO CIO BARRELS
          LDC    ISTR+4
          STD    M2          SAVE CIO STATUS REGISTER
          LDN    0
          STD    PP          START WITH PP ZERO
          LDN    DEMR+4      GET CIO *EC* REGISTER NUMBER
          RJM    DPP         DISPLAY THIS BARREL
          PRINT  DPRC+CRLF   LABEL AS CIO PP
          LDD    M1
          LPN    2
          ZJN    DPR25       IF BARREL ONE NOT INSTALLED
          LDN    DEMR+4      GET CIO *EC* REGISTER NUMBER
          RJM    DPP         DISPLAY THIS BARREL
          PRINT  DPRC+CRLF   LABEL AS CIO PP
 DPR25    LDC    DPR         SET REFRESH ADDRESS
          LJM    CMDR        RETURN

 DPRT     CON    DPRP+CRLF
          CON    DPRQ+CRLF
          CON    DPRK+CRLF
          CON    DPRA+CRLF

 DPRP     ASCII  (P REG)
 DPRQ     ASCII  (Q REG)
 DPRK     ASCII  (K REG)
 DPRA     ASCII  (A REG)
 DPRC     ASCII  ( CIO)
 DPRW     CON    0

 HLT      SPACE  4,10
**        HLT - HALT PROCESSOR.
*
*         MACROS PRINT.


 HLT      ROUTINE

          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          FUNCMR ELPR,MRHP
          PRINT  HLTA+CRLF   *CPU HALTED*
          LJM    CMDF        RETURN

 HLTA     ASCII  (CPU HALTED)
 IPR      SPACE  4,10
**        IPR - IDLE PP.
*
*         USES   T0.
*
*         CALLS  IDP.
*
*         MACROS PRINT.


 IPR      ROUTINE

          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDD    PC          GET PARAMETER COUNT
          LPN    1S1
          ZJN    IPR2        IF NO PP NUMBER GIVEN
          LDM    PPCT        GET TYPE OF PP
          ZJN    IPR1        IF NIO PP
          LDM    IOUM        TEST FOR I4
          SHN    -4
          LMN    4
          NJN    IPR2        IF NOT
          LDC    0#100       SET CIO FLAG
 IPR1     ADD    PP          ADD IN PP NUMBER
          STD    T0          SAVE NUMBER
          SBM    PPNO        TEST IF SCI PP
          ZJN    IPR2        ILLEGAL IF SCI PP
          LDD    T0          RETRIEVE NUMBER
          RJM    IDP         IDLE PP
          PRINT  IPRA+CRLF   *PP HALTED*
          LJM    CMDF        RETURN

 IPR2     LJM    CMDE        RETURN *ILL*

 IPRA     ASCII  (PP HALTED)
 RPP      SPACE  4,10
**        RPP - RESTART PP AT ADDRESS.
*
*         USES   PP, T1.
*
*         CALLS  DLP, SCF.


 RPP      ROUTINE

          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDN    MX          SET TO DEADSTART ON CHANNEL 15
          STD    T1
          LDD    PC          GET PARAMETER COUNT
          LPN    1S2
          ZJN    RPP2        IF NO ADDRESS GIVEN
          LDM    PPCT        GET TYPE OF PP
          ZJN    RPP1        IF NIO PP
          LDM    IOUM        TEST FOR I4
          SHN    -4
          LMN    4
          NJN    RPP2        IF NOT
          LDC    0#100       SET CIO PP FLAG
 RPP1     RAD    PP          MERGE PP NUMBER AND CIO FLAG
          LDK    MX          ACQUIRE CHANNEL 15 INTERLOCK
          RJM    SCF
          LDD    PP
          RJM    DLP         DEADSTART LOAD PP
          LDM    RPPA        ADDRESS FROM COMMAND
          SBN    1
          OAN    MX          OUTPUT TO CHANNEL MX
          DCN    MX+40
          CCF    *,MX        RELEASE INTERLOCK
          PRINT  RPPB+CRLF   *PP STARTED*
          LJM    CMDF        RETURN

 RPP2     LJM    CMDE        PROCESS ERROR

*RPPA     EQU    7575        (GLOBAL)
 RPPB     ASCII  (PP STARTED)
 SMC      SPACE  4,10
**        SMC - START MICRO CODE.
*
*         EXIT   PROCESSOR HAS BEEN -
*                  MASTER CLEARED.
*                  S-REGISTER WRITTEN.
*                  STARTED.
*
*         MACROS FUNCMR, PRINT, WRITMR.


 SMC      ROUTINE

          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDD    PC          GET PARAMETER COUNT
          ZJP    SMC1        IF NONE JUST RESTART PROCESSOR
          LDML   VAL1+2      GET STARTING ADDRESS
          SHN    12D
          ADML   VAL1+3
          ZJN    SMC1        IF ADDRESS = 0
          STM    SMCA+7
          SHN    -8D
          STM    SMCA+6
          FUNCMR ELPR,MRMC   MASTER CLEAR PROCESSOR
          WRITMR SMCA,ELPR,PCSA
 SMC1     FUNCMR ELPR,MRSP   START PROCESSOR
          PRINT  SMCB+CRLF   *CPU STARTED*
          LJM    CMDF        RETURN

 SMCA     BSSZ   10B
 SMCB     ASCII  (CPU STARTED)
 DPP      SPACE  4,10
**        DPP - DISPLAY PP REGISTERS.
*
*         ENTRY  (PP) = FIRST LOGICAL PP NUMBER TO DISPLAY.
*                (M2) = STATUS REGISTER TO READ.
*                (A) = *EC* REGISTER TO FUNCTION.
*
*         USES   PP, RN, T6, T7.
*
*         CALLS  PRN.
*
*         MACROS LOCKMR, READMR, WRITMR.


 DPP      SUBR               ENTRY/EXIT
          STD    T6          SAVE *EC* REGISTER NUMBER
          STD    RN          SET *EC* REGISTER TO FUNCTION
          READMR MRBF,ELIO   SAVE CURRENT *EC* REGISTER
          READMR RDATA       GET CURRENT *EC* REGISTER
          LDN    5           SET NUMBER OF PP-S TO DISPLAY PER LINE
          STD    T7
          LDM    DPRB        SET REGISTER (A, K, P, Q) TO DISPLAY
          STM    RDATA+6
          LDD    PP          CHECK PP NUMBER
          SBN    11+1
          NJN    DPP1        IF NOT START OF BARREL 2
          LDN    20          RESET PP NUMBER TO PP20
          STD    PP
 DPP1     LDM    RDATA+4     PRESERVE 8K AND SYSTEM INITIALIZED BITS
          SCN    77
          LMD    PP          SELECT PP TO STATUS
          LMN    40          SET AUTO BIT FOR AN I2
          STM    RDATA+4
          LDD    T6          SET *EC* REGISTER
          STD    RN
          LOCKMR SET
          WRITMR RDATA       FUNCTION PROPER *EC* REGISTER
          LDD    M2          SET STATUS REGISTER NUMBER
          STD    RN
          READMR NBUF
          LOCKMR CLEAR
          LDM    NBUF+4      EXTRACT ADDRESS FROM REGISTER
*         LPN    3           CODE ASSUMES UPPER BITS ARE ZERO
          SHN    10
          LMM    NBUF+5
          SHN    10
          LMM    NBUF+6
          SHN    14
          STM    NBUF        SAVE UPPER 12 BITS
          SHN    14
          STM    NBUF+1      SAVE LOWER 6 BITS
          LDC    6+OMDT      DISPLAY 6-DIGIT OCTAL NUMBER
          RJM    PRN
          AOD    PP          ADVANCE PP NUMBER
          SOD    T7          DECREMENT COUNTER
          NJP    DPP1        IF MORE PP-S TO DISPLAY ON THIS LINE
          LDD    T6          SET *EC* REGISTER TO RESTORE
          STD    RN
          WRITMR MRBF        RESTORE ENVIRONMENT CONTROL REGISTER
          LJM    DPPX        RETURN

          OVERFLOW  SCMT     CHECK FOR OVERFLOW
          OVERLAY  (MDD CONDITION REGS AND CONTROL STORE ROUTINES)
 DKR      SPACE  4,10
**        DKR - DISPLAY CONTROL STORE (128 BITS PER WORD).
*
*         USES   EC, M1, M2, M3, RN.
*
*         CALLS  EOL, PRN, PCR, TPS.
*
*         MACROS READMR.


 DKR      ROUTINE

          LDN    1           READ OPERATION
          STM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          STD    M1          INITIALIZE POINTER
          RJM    TPS         TEST PROCESSOR STATE
          RJM    PCR         PREPARE CONTROL STORE READ
 DKR1     LDD    M2          SET CONNECT CODE
          STD    EC
          LDDL   M3          GET CONTROL STORE ADDRESS
          STDL   RN
          STML   NBUF        PRINT ADDRESS
          LDC    HMDT+4
          RJM    PRN
          READMR NBUF,,,20   READ ONE WORD OF CONTROL STORE
          LDN    MRDT+40
          RJM    PRN         PRINT CONTENTS
          RJM    EOL         PRINT CR-LF
          LDN    2           ADVANCE ADDRESS BY TWO
          AODL   M3
          AOD    M1          INCREMENT COUNTER
          LDM    RFPB        GET WORD COUNT
          SBD    M1          SUBTRACT COUNTER
          PJN    DKR1        IF NOT DONE
          LJM    CMDF        RETURN
 DSR      SPACE  4,10
**        DSR - DISPLAY CONTROL STORE (64 BITS PER WORD).
*
*         USES   EC, M1, M2, M3, RN.
*
*         CALLS  EOL, PRN, PCR, TPS.
*
*         MACROS READMR.


 DSR      ROUTINE

          LDN    1           READ OPERATION
          STD    M1          INITIALIZE POINTER
          STM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          RJM    TPS         TEST PROCESSOR STATE
          RJM    PCR         PREPARE CONTROL STORE READ
 DSR1     LDD    M2          SET CONNECT CODE
          STD    EC
          LDDL   M3          GET CONTROL STORE ADDRESS
          STDL   RN
          STML   NBUF        PRINT ADDRESS
          LDC    HMDT+4
          RJM    PRN
          READMR NBUF,,,10   READ ONE WORD OF CONTROL STORE
          LDN    MRDT+20
          RJM    PRN         PRINT CONTENTS
          RJM    EOL         PRINT CR-LF
          AODL   M3          ADVANCE ADDRESS
          AOD    M1          ADVANCE COUNTER
          LDM    RFPB        GET WORD COUNT
          SBD    M1          SUBTRACT COUNTER
          PJN    DSR1        IF NOT DONE
          LJM    CMDF        RETURN
 EKR      SPACE  4,10
**        EKR - ENTER HEX BYTE MEMORY.
*
*         USES   RN, T7.
*
*         CALLS  DNV, EOL, PRN, PCR, TPS.
*
*         MACROS READMR, WRITMR.


 EKR      ROUTINE

          LDN    0           WRITE OPERATION
          STD    T7          INITIALIZE POINTER
          RJM    TPS         TEST PROCESSOR STATE
          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDD    PC          GET PARAMETER COUNT
          LPN    1S1
          NJN    EKR1        IF ADDRESS SPECIFIED
          LJM    CMDE        SET ERROR

 EKR1     RJM    PCR         PREPARE CONTROL STORE READ
          READMR EBUF,,,16D  READ ONE WORD OF CONTROL STORE
 EKR2     LDN    1+MRNT
          RJM    DNV         DECODE ONE BYTE
          ZJN    EKR3        IF NO MORE TO WRITE
          LDM    ABUF
          STM    EBUF,T7
          AOD    T7
          SBN    16D
          MJN    EKR2        IF NOT DONE WITH WORD
 EKR3     WRITMR EBUF,,,16D  REWRITE WORD
          READMR NBUF,,,16D  READ WORD BACK
          LDN    MRDT+40
          RJM    PRN         PRINT CONTENTS
          RJM    EOL         PRINT CR-LF
          LJM    CMDF        RETURN
 ESR      SPACE  4,10
**        ESR - ENTER HEX BYTE MEMORY.
*
*         USES   RN, T7.
*
*         CALLS  DNV, EOL, PRN, PCR, TPS.
*
*         MACROS READMR, WRITMR.


 ESR      ROUTINE

          LDN    0           WRITE OPERATION
          STD    T7          INITIALIZE POINTER
          RJM    TPS         TEST PROCESSOR STATE
          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDD    PC          GET PARAMETER COUNT
          LPN    1S1
          NJN    ESR1        IF ADDRESS SPECIFIED
          LJM    CMDE        SET ERROR

 ESR1     RJM    PCR         PREPARE CONTROL STORE READ
          READMR EBUF,,,8D   READ ONE WORD OF CONTROL STORE
 ESR2     LDN    1+MRNT
          RJM    DNV         DECODE ONE BYTE
          ZJN    ESR3        IF NO MORE TO WRITE
          LDM    ABUF
          STM    EBUF,T7
          AOD    T7
          SBN    8D
          MJN    ESR2        IF NOT DONE WITH WORD
 ESR3     WRITMR EBUF,,,8D   REWRITE WORD
          READMR NBUF,,,8D   READ WORD BACK
          LDN    MRDT+20
          RJM    PRN         PRINT CONTENTS
          RJM    EOL         PRINT CR-LF
          LJM    CMDF        RETURN
 MCR/UCR  SPACE  4,10
**        MCR - DISPLAY DECODED MCR BITS.
**        UCR - DISPLAY DECODED UCR BITS.
*
*         USES   M1.
*
*         CALLS  TBR.
*
*         MACROS READMR.


 MCR      ROUTINE

          LDC    MCRB        SET MCR BIT LIST
          UJN    UCR1        DECODE MCR BITS

 UCR      ROUTINE

          LDC    UCRB+10000  SET UCR BIT LIST AND UCR FLAG
          ERRNZ  PUCR-PMCR-1 CODE ASSUMES *PUCR* = *PMCR* + 1
 UCR1     STD    M1
          SHN    -14
          ADC    PMCR        ADD MCR REGISTER NUMBER
          STD    RN
          LDD    PC          GET PARAMETER COUNT
          LPN    1S1
          NJN    UCR2        IF PARAMETER 1 SPECIFIED
          READMR NBUF,ELPR   READ MCR/UCR
          LDM    NBUF+6      PACK FLAG BUFFER
          SHN    10
          ADM    NBUF+7
          STML   NBUF        SAVE MCR/UCR VALUE
 UCR2     RJM    TBR         TRANSLATE BIT REGISTER
          LJM    CMDF        COMPLETE COMMAND


 UCRB     CON    =C*UCR = *
          LOC    0
          CON    =C*PRIV FAULT*
          CON    =C*UNIMP INST*
          CON    =C*FREE FLAG*
          CON    =C*PIT*
          CON    =C*I-RING POP*
          CON    =C*CRIT F FLG*
          CON    =C*KEYPT*
          CON    =C*DIVIDE FLT*
          CON    =C*DEBUG*
          CON    =C*A-OVL*
          CON    =C*E-OVL*
          CON    =C*E-UND*
          CON    =C*FP LOSS*
          CON    =C*FP INDEF*
          CON    =C*ARITH LOSS*
          CON    =C*BAD BDP*
          LOC    *O

 MCRB     CON    =C*MCR = *
          LOC    0
          CON    =C*DUE*
          CON    0
          CON    =C*SHRT WARN*
          CON    =C*I-SPEC*
          CON    =C*A-SPEC*
          CON    =C*170 XJ*
          CON    =C*ACCESS FLT*
          CON    =C*E-SPEC*
          CON    =C*EXT INT*
          CON    =C*PAGE FAULT*
          CON    =C*180 XJ*
          CON    =C*SIT*
          CON    =C*INV SEG/RN0*
          CON    =C*CALL/RTN FLT*
          CON    =C*SOFT ERROR*
          CON    =C*TRAP EXCPT*
          LOC    *O
 PCR      SPACE  4,10
**        PCR - PREPARE CONTROL STORE READ.
*
*         ENTRY  (VAL1+2 - VAL1+3) = STARTING ADDRESS.
*                (EC) = CONNECT CODE.
*                (RFPC) = TYPE CODE.
*
*         EXIT   (EC) = (M2) = MODIFIED CONNECT CODE.
*                (RN) = (M3) = ADDRESS.


 PCR      SUBR               ENTRY/EXIT
          LDM    VAL1+2      GET STARTING ADDRESS
          SHN    14
          ADM    VAL1+3
          STDL   RN
          STDL   M3
          LDD    EC          GET CONNECT CODE BACK
          SCN    0#F         CLEAR TYPE CODE
          ADM    RFPC        ADD IN TYPE CODE FOR CONTROL STORE
          STD    EC
          STD    M2
          UJN    PCRX        RETURN
 TBR      SPACE  4,10
**        TBR - TRANSLATE BIT REGISTER.
*
*         ENTRY  (M1) = BIT DEFINITION TEXT TABLE.
*                (NBUF) = BITS TO ANALYZE.
*
*         USES   M1, M2.
*
*         CALLS  EOL, WAS.
*
*         MACROS PRINT.


 TBR1     PRINT  TBRM        TELL USER REGISTER IS CLEAR
 TBR2     RJM    EOL         COMPLETE LINE

 TBR      SUBR               ENTRY/EXIT
          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDI    M1          PRINT HEADER
          RJM    WAS         WRITE STRING
          LDML   NBUF        CHECK REGISTER CONTENTS
          ZJN    TBR1        IF NO ERRORS PRESENT
          STDL   M2
 TBR3     AOD    M1          ADVANCE TO NEXT MESSAGE
          LDDL   M2          CHECK NEXT BIT
          ZJN    TBR2        IF ALL ERRORS PROCESSED
          RADL   M2
          SHN    21-20
          PJN    TBR3        IF BIT NOT SET
          LDI    M1
          ZJN    TBR3        IF NO MESSAGE
          RJM    WAS         WRITE STRING
          LDN    1R,
          STIAO  BP          PUT CHARACTER IN OUTPUT QUEUE
          UJN    TBR3        CHECK NEXT BIT

 TBRM     ASCII  (CLEAR)
 TPS      SPACE  4,10
**        TPS - TEST PROCESSOR STATE.
*
*         EXIT   TO *CMDF* IF PROCESSOR RUNNING.
*                RETURN IF PROCESSOR HALTED.
*
*         USES   RN.
*
*         CALLS  RMR.
*
*         MACROS PRINT.


 TPS      SUBR               ENTRY/EXIT
          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDN    0
          STD    RN
          LDM    ELPR
          RJM    RMR         READ STATUS SUMMARY REGISTER
          SHN    21-3
          MJN    TPSX        IF PROCESSOR HALTED
          PRINT  TPSM        *CPU MUST be HALTED*
          PRINT  TPSN+CRLF   * to access Control Store*
          LJM    CMDF        RETURN

 TPSM     ASCII  (CPU MUST be HALTED)
 TPSN     ASCII  ( to access Control Store)

 EBUF     EQU    *           SAVE AREA FOR WRITING CONTROL STORE

          OVERFLOW  SCMT     CHECK FOR OVERFLOW
          OVERLAY  (MDD VIRTUAL MEMORY COMMANDS)
 DMM      SPACE  4,10
**        DMM - DISPLAY PVA COMMAND.
*
*         USES   T1, T2, T3, WC.
*
*         CALLS  DAT, DPS, EOL, MSA, PRN, SPT.
*
*         MACROS PRINT.


 DMM      ROUTINE            DISPLAY VIRTUAL MEMORY

          LDD    PC          GET PARAMETER COUNT
          SHN    21-6
          PJN    DMM1        IF PAGE SIZE MASK NOT CHANGED
          RJM    DPS         DEFINE PAGE SIZE
 DMM1     AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDM    VAL3+1
          SHN    21-13
          PJN    DMM3        IF INCREMENT
          LMN    0#1F
 DMM3     SHN    21-6
          STDL   T1
          SHN    14-21
          LPC    10000
          ADM    VAL3+2
          SHN    3
          RAML   VMBA+2
          SHN    -20
          ADDL   T1
          RAML   VMBA+1
          LDN    0           CLEAR INCREMENT
          STM    VAL3
          STM    VAL3+1
          STM    VAL3+2
          LDM    VMBA+3      MAKE SYSTEM VIRTUAL ADDRESS
          RJM    MSA         BASED ON JPS
          NJN    DMM4        IF SEGMENT EXISTS
          PRINT  DMMM+CRLF   *SEGMENT MISSING*
          LJM    CMDF        EXIT WITH NO REFRESH

 DMM4     RJM    SPT         SEARCH PAGE TABLE
          STD    T3          SAVE RMA FOR *DC*, *DM* AND *DH* COMMANDS
          SRD    T1
          LDD    T2          LOWER 12 BITS OF R-REGISTER
          SHN    6
          ADD    T3          ADD A REGISTER OFFSET
          STM    VAL1+3      SAVE LOWER 12 BITS
          LPC    770000
          ADD    T1          ADD UPPER 10 BITS OF R-REGISTER
          SHN    6           SHIFT INTO PROPER ORDER
          STM    VAL1+2      SAVE MIDDLE 12 BITS OF ADDRESS
          SHN    -14
          STM    VAL1+1      SAVE UPPER 4 BITS OF ADDRESS
          LDM    VAL2
          SBN    20          LIMIT TO REPEAT OF 16
          MJN    DMM5        IF NUMBER IS <= 16
          LDN    20          RESET VAL2 TO MAX
          STM    VAL2
 DMM5     LDM    VAL2
          STD    WC          SET WORD COUNT
          LDM    VMBA
          STM    NBUF        SET SEGMENT NUMBER
          PRINT  DMMP        PRINT * SEGMENT *
          LDC    3+HPDT
          RJM    PRN         PRINT SEGMENT NUMBER
          RJM    EOL         PRINT END OF LINE
 DMM6     LDDL   MP+1
          STML   NBUF        SET BYTE OFFSET
          LDDL   MP+2
          SCN    7           ROUND BYTE ADDRESS DOWN
          STML   NBUF+1
          LDC    HMDT+8D
          RJM    PRN         PRINT BYTE OFFSET
          RJM    SPT         SEARCH PAGE TABLE
          ZJN    DMM8        IF PAGE MISSING
          CRML   NBUF,ON     READ ONE WORD
          LDC    16D+HBDT
          RJM    PRN         DISPLAY BYTES
          RJM    DAT         DISPLAY ASCII
          RJM    EOL
          LDN    10          INCREMENT TO NEXT WORD
          RADL   MP+2
          SHN    -20
          RADL   MP+1
          SOD    WC          DECREMENT WORD COUNT
          NJN    DMM6        IF MORE TO DISPLAY
 DMM7     LDC    DMM1+HXBT   REENTRY ADDRESS
          LJM    CMDR        RETURN

 DMM8     PRINT  DMMN+CRLF   *PAGE MISSING*
          UJN    DMM7        EXIT

 DMMM     ASCII  (SEGMENT MISSING)
 DMMN     ASCII  (PAGE MISSING)
 DMMP     ASCII  (* SEGMENT *)
 SEP      SPACE  4,10
**        SEP - SET CPU VALUE.
*
*         CALLS  FPC, PVC.
*
*         MACROS PRINT.


 SEP      ROUTINE

          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDM    SEPA        INSPECT PARAMETER VALUE
          ZJN    SEP2        IF CPU 0 SPECIFIED
          SBN    1
          NJN    SEP3        IF CPU GREATER THAN ONE SPECIFIED
          LDN    1
          RJM    FPC         FIND PROPER PORT CODE
          LMN    77
          ZJN    SEP3        IF CPU NOT FOUND
          PRINT  SEPM+CRLF   *CPU 1.*
 SEP1     RJM    PVC         PRESET VIRTUAL CONSTANTS
          LJM    CMDF        RETURN

 SEP2     RJM    FPC         FIND PROPER PORT CODE
          LMN    77
          ZJN    SEP3        IF NOT FOUND
          PRINT  SEPN+CRLF   *CPU 2.*
          UJN    SEP1        CONTINUE PROCESSING COMMAND

 SEP3     PRINT  SEPP+CRLF   *CPU # not found.*
          LDN    0
          STM    SEPA        RESET TO CPU 0
          UJN    SEP2        PROCESS ERROR

 SEPM     ASCII  (CPU 1.)
 SEPN     ASCII  (CPU 0.)
 SEPP     ASCII  (CPU # not found.)
 DPS      SPACE  4,10
**        DPS - DEFINE PAGE SIZE.
*
*         ENTRY  (PSMV) = CONTENTS OF PAGE SIZE MASK REGISTER.
*
*         EXIT   (PSMV) = PAGE SIZE MASK.
*                (SPTS) = SHIFT INSTRUCTION TO EXTRACT PAGE NUMBER.
*
*         USES   T2.


 DPS      SUBR               ENTRY/EXIT
          LDC    SHNI+100
          STM    SPTS        SET SHIFT INTO PAGE TABLE SEARCH
          LDM    PSMV
          LMC    0#7F
          STD    T2
          STM    PSMV        SET PAGE SIZE MASK
 DPS1     SOM    SPTS        ADD TO SHIFT COUNT
          LDD    T2
          SHN    21-0        REMOVE LOWEST BIT
          STD    T2
          NJN    DPS1        IF MORE BITS PRESENT
          UJN    DPSX        RETURN
 FPC      SPACE  4,10
**        FPC - FIND PROCESSOR PORT CODE.
*
*         ENTRY  (A) = CPU NUMBER.
*
*         EXIT   (A) = 77 IF PROCESSOR NOT FOUND.
*                (EC) = (ELPR) = PROCESSOR PORT CODE.
*
*         CALLS  FHE.


 FPC1     LDN    77          SET PROCESSOR NOT FOUND

 FPC      SUBR               ENTRY/EXIT
          SHN    14
          ADN    PROCID
          RJM    FHE         FIND PROCESSOR PORT CODE
          MJN    FPC1        IF NOT FOUND
          LDM    HBUF+CPRPC
          STM    ELPR        SAVE IT
          STD    EC
          LDM    HBUF+CPRE+EM  GET MODEL NUMBER
          UJN    FPCX        RETURN
 LBA      SPACE  4,10
**        LBA - LOAD BYTE ADDRESS.
*
*         ENTRY  (A) = POINTER TO BYTE ADDRESS.
*
*         EXIT   (A) = CM ADDRESS.
*                (M1 - M2) = R-REGISTER VALUE.
*                (M3) = OFFSET FROM R-REGISTER.


 LBA      SUBR               ENTRY/EXIT
          STD    M3
          LDI    M3          SET UPPER PART OF R-REGISTER
          LPN    37
          SHN    7
          STD    M2
          LDIL   M3          SET LOWER PART OF R-REGISTER
          SHN    -5
          LPC    0#3FF
          STD    M1
          LRD    M1
          LDML   1,M3
          SHN    -3
          STDL   M3          SET OFFSET
          LMC    RR          ACTIVATE R-REGISTER
          UJN    LBAX        RETURN
 LWA      SPACE  4,10
**        LWA - LOAD WORD ADDRESS.
*
*         ENTRY  (CM+2 - CM+3) = WORD ADDRESS.
*
*         EXIT   (A) = CM ADDRESS.
*                (CM - CM+1) = R-REGISTER VALUE.
*                (CM+3) = OFFSET FROM R-REGISTER.


 LWA      SUBR               ENTRY/EXIT
          LDD    CM+2        SET UPPER PART OF R-REGISTER
          LPN    3
          SHN    10D
          STD    CM+1
          LDD    CM+2        SET R-REGISTER BITS 12 - 18
          SHN    -2
          STD    CM
          LRD    CM
          LDDL   CM+3        SET OFFSET
          LMC    RR
          UJN    LWAX        RETURN
 MSA      SPACE  4,10
**        MSA - MAKE SYSTEM VIRTUAL ADDRESS.
*
*         ENTRY  (A) = ADDRESS OF EXCHANGE PACKAGE ADDRESS.
*                (VMBA - VMBA+2) = PROCESS VIRTUAL ADDRESS.
*
*         EXIT   (MP - MP+2) = SYSTEM VIRTUAL ADDRESS.
*                TO *CMDE* IF INVALID EXCHANGE PACKAGE ADDRESS.
*
*         USES   MP - MP+2, M3, T1 - T6, W0 - W3.
*
*         CALLS  LBA.


 MSA2     LJM    CMDE        RETURN INVALID COMMAND

 MSA3     LDN    0           FLAG INVALID/MISSING SEGMENT

 MSA      SUBR               ENTRY/EXIT

*         THE EXCHANGE PACKAGE ADDRESS MUST FIRST BE VALIDATED.  IF NOS/VE
*         IS NOT YET DEADSTARTED AND NO *SE* COMMAND HAS BEEN ENTERED, THEN
*         THE EXCHANGE PACKAGE ADDRESS WILL BE ALL ZEROS.  IF ON AN S0/S0E
*         AND THE CPU HAS NOT YET BEEN STARTED, THE EXCHANGE PACKAGE ADDRESS
*         FROM *SE* WILL BE ALL ONES, SINCE THE MPS/JPS ACCESS REQUIRES
*         MICROCODE ASSIST.

          STD    M3
          LDI    M3
          ADML   1,M3
          ZJN    MSA2        IF EXCHANGE PACKAGE ADDRESS = 0
          LDI    M3
          LMC    7777
          NJN    MSA1        IF NOT ALL ONES
          LDML   1,M3
          LMC    177777
          ZJN    MSA2        IF EXCHANGE PACKAGE ADDRESS IS ALL ONES
 MSA1     LDD    M3
          RJM    LBA         LOAD BYTE ADDRESS
          ADN    16D         SEGMENT TABLE LENGTH OFFSET
          CRDL   T1          GET SEGMENT TABLE LENGTH
          ADN    34D-16D     SEGMENT TABLE ADDRESS OFFSET
          CRDL   T2          GET SEGMENT TABLE ADDRESS
          ADN    1
          CRDL   T3
          LDDL   T1
          SBM    VMBA
          MJN    MSA3        IF NOT A VALID SEGMENT
          LDN    T2
          RJM    LBA         LOAD ADDRESS OF SEGMENT TABLE
          ADM    VMBA        ADD SEGMENT OF INTEREST
          CRDL   W0          FETCH ASID
          LDDL   W1
          ZJP    MSA3        IF NOT A VALID ASID
          STDL   MP          SAVE ASID
          LDML   VMBA+1      COPY REMAINDER OF PVA
          STDL   MP+1
          LDML   VMBA+2
          STDL   MP+2
          LDN    1
          LJM    MSAX        RETURN
 PVC      SPACE  4,10
**        PVC - PRESET VIRTUAL ADDRESS CONSTANTS.
*
*         ENTRY  NONE.
*
*         EXIT   (PTAV - PTAV+1) = PAGE TABLE ADDRESS.
*                (JPSV - JPSV+1) = JPS VALUE.
*                (MPSV - MPSV+1) = MPS VALUE.
*                (PSMV) = PAGE SIZE MASK.
*                (PTLV) = PAGE TABLE LENGTH MASK.
*
*         USES   T4, T5, RN.
*
*         CALLS  DPS, RMR.


 PVC      SUBR               ENTRY/EXIT
          LDN    PVCAL
          STD    T5
 PVC1     LDM    PVCA+1,T5
          STD    T4          SET DATA ADDRESS
          LDM    PVCA,T5     GET REGISTER NUMBER
          STD    RN
          LDM    ELPR
          RJM    RMR         READMR RDATA,ELPR
          LDM    RDATA+4     FORM 32 BIT VALUE
          SHN    10
          LMM    RDATA+5
          STIL   T4
          LDM    RDATA+6
          SHN    10
          LMM    RDATA+7
          STML   1,T4
          LCN    2
          RAD    T5
          MJN    PVC2        IF NO MORE REGISTERS TO READ
          UJN    PVC1        GO BACK FOR MORE

 PVC2     RJM    DPS         DEFINE PAGE SIZE
          LJM    PVCX        RETURN

 PVCA     BSS    0           TABLE OF REGISTERS
          LOC    0
          CON    S0PPTA,PTAV    PAGE TABLE ADDRESS
          CON    S0PJPS,JPSV    JPS EXCHANGE PACKAGE ADDRESS
          CON    S0PMPS,MPSV    MPS EXCHANGE PACKAGE ADDRESS
          CON    S0PPSM,PSMV-1  PAGE SIZE MASK
 PVCAL    CON    S0PPTL,PTLV-1  PAGE TABLE LENGTH
          LOC    *O
 SPT      SPACE  4,10
**        SPT - SEARCH PAGE TABLE.
*
*         ENTRY  (MP - MP+2) = SYSTEM VIRTUAL ADDRESS.
*
*         EXIT   (A) = ADDRESS OF WORD.
*                    = 0 IF NOT FOUND.
*
*         USES   T1, T2, T3, T4, T5, T6, T7, CM - CM+3, W0 - W3.
*
*         CALLS  LWA.


 SPT      SUBR               ENTRY/EXIT

*         MODIFY SHIFT INSTRUCTIONS ACCORDING TO PAGE SIZE FUNCTION.

          LDM    SPTS        GET SEARCH PAGE TABLE SHIFT
          STM    SPTA
          STM    SPTC
          STM    SPTH
          ADN    10
          LPC    1077
          STM    SPTB
          LDM    SPTS
          LMC    77          COMPLEMENT SHIFT
          STM    SPTF
          STM    SPTI
          LDM    SPTS
          SBN    12
          STM    SPTG

*         FORM THE PAGE NUMBER FROM THE SYSTEM VIRTUAL ADDRESS.  THE
*         BIT POSITION OF THE 16-BIT PAGE NUMBER IS A FUNCTION OF THE
*         PAGE SIZE AS INDICATED BY THE PAGE SIZE MASK.

          LDDL   MP+2        PAGE OFFSET
          SHN    -9D
 SPTA     SHN    -0          (MODIFIED ACCORDING TO PAGE SIZE FUNCTION)
          STDL   T2
          LDM    PSMV        SAVE CORRECT NUMBER OF BITS
          SHN    9D
          LMC    777
          LPDL   MP+1        PAGE NUMBER
 SPTB     SHN    0           (MODIFIED ACCORDING TO PAGE SIZE FUNCTION)
          RADL   T2          PAGE NUMBER (LOWER)
          LDDL   MP+1
          SHN    -9D
 SPTC     SHN    -0          (MODIFIED ACCORDING TO PAGE SIZE FUNCTION)
          STDL   T1          PAGE NUMBER (UPPER)

*         FORM THE HASH INDEX.  EXCLUSIVE OR THE 16-BIT ASID WITH THE
*         RIGHTMOST 16 BITS OF THE PAGE NUMBER.  CONCATENATE A ZERO ON THE
*         RIGHT.  THIS IS THE RIGHTMOST 17 BITS OF THE HASH INDEX (WORD
*         BOUNDARY).  THE REMAINING LEFT 6 BITS ARE FORMED BY AN EXCLUSIVE
*         OR OF THE LEFTMOST 6 BITS OF THE ASID WITH THE RIGHTMOST 6 BITS OF
*         THE PAGE NUMBER.

          LDDL   T2
          LMDL   MP          EXCLUSIVE OR WITH ASID
          SHN    1           FORM WORD ADDRESS
          STDL   T4          HASH INDEX (LOWER)
          SHN    -20
          STDL   T3          SAVE LEFTMOST BIT OF RIGHT 17 BITS
          LDDL   MP
          SHN    -12
          STM    SPTD+1      FORM INSTRUCTION
          LDDL   T2
          LPN    77
 SPTD     LMC    0
          SHN    1
          RAD    T3          HASH INDEX (UPPER)

*         FORM THE PAGE TABLE LENGTH MASK.

          LDML   PTLV        PAGE TABLE LENGTH
          LPC    177         SAVE 7 BITS
          SHN    9D
          LMC    777
          STDL   T6          PAGE TABLE LENGTH MASK (LOWER)
          LDML   PTLV
          SHN    -7
          STD    T5          PAGE TABLE LENGTH MASK (UPPER)

*         MODIFY THE PAGE NUMBER FROM THE SYSTEM VIRTUAL ADDRESS FOR
*         COMPARISON WITH THE PAGE TABLE ENTRY.  IN THE PAGE TABLE ENTRY,
*         THE PAGE NUMBER IS ZERO FILLED ON THE RIGHT IF THE PAGE SIZE IS
*         LARGER THAN 512 BYTES (I.E. THE PAGE NUMBER IS LESS THAN 22 BITS).

          LDDL   T1
 SPTF     SHN    0           (MODIFIED ACCORDING TO PAGE SIZE FUNCTION)
          STDL   T1
          LDDL   T2
 SPTG     SHN    -0          (MODIFIED ACCORDING TO PAGE SIZE FUNCTION)
          RAD    T1          PAGE NUMBER (UPPER) SHIFTED FOR PAGE SIZE FUNCTION
          LDC    0#FFFF
 SPTH     SHN    -0          (MODIFIED ACCORDING TO PAGE SIZE FUNCTION)
          LPDL   T2
 SPTI     SHN    0           (MODIFIED ACCORDING TO PAGE SIZE FUNCTION)
          STDL   T2          PAGE NUMBER (LOWER) SHIFTED FOR PAGE SIZE FUNCTION

*         FORM A WORD ADDRESS FOR THE PAGE TABLE ADDRESS.

          LDML   PTAV+1
          SHN    -3
          STML   SPTP+1
          LDML   PTAV
          LPN    7
          SHN    13D
          RAML   SPTP+1
          LDML   PTAV
          SHN    -3
          STML   SPTP

*         SEARCH THE PAGE TABLE FOR AN ENTRY WHOSE ASID AND PAGE NUMBER MATCH
*         THAT OF THE SYSTEM VIRTUAL ADDRESS.  UP TO 32 ENTRIES ARE TESTED.
*         THE 32 ENTRIES ARE THOSE CONTIGUOUS, VALID OR INVALID, WHICH START
*         AT THE LOCATION IN THE SYSTEM PAGE TABLE INDICATED BY THE HASH INDEX
*         AND INCLUDE THE NEXT 31 HIGHER ADDRESS WORDS.

          LDN    32D
          STD    T7          SET SEARCH LIMIT
 SPT1     LDDL   T4          HASH INDEX (LOWER)
          LPDL   T6          PAGE TABLE LENGTH MASK (LOWER)
          STDL   CM+1
          LDDL   T3          HASH INDEX (UPPER)
          LPDL   T5          PAGE TABLE LENGTH MASK (UPPER)
          STDL   CM
          LDML   SPTP+1
          ADDL   CM+1        ADD NEW VALUE TO PAGE TABLE ADDRESS
          STDL   CM+3
          SHN    -20         SAVE POSSIBLE CARRY BIT
          STD    CM+2
          LDML   SPTP
          ADDL   CM
          RADL   CM+2        SYSTEM PAGE TABLE ADDRESS TO BEGIN SEARCH
          RJM    LWA         LOAD WORD ADDRESS OF PAGE TABLE
          CRDL   W0          PAGE TABLE ENTRY
          LDDL   W0
          SHN    21-17
          PJN    SPT2        IF INVALID PAGE
          SHN    2
          SCN    0#F
          STDL   W0          EXTRACT ASID
          LDDL   W1
          SHN    4-20
          RADL   W0          COMPLETE ASID
          LMDL   MP
          NJN    SPT2        IF NOT CORRECT ASID
          LDD    W1          EXTRACT SEGMENT/PAGE ID AND POSITION IT
          SHN    -6
          STD    W0          SEGMENT/PAGE ID (UPPER)
          LDDL   W1
          LPN    77
          SHN    12
          STDL   W1
          LDDL   W2
          SHN    -6
          RADL   W1          SEGMENT/PAGE ID (LOWER)
          LMDL   T2          COMPARE WITH PAGE NUMBER
          NJN    SPT2        IF NO MATCH (ON LOWER)
          LDDL   W0
          LMDL   T1
          ZJN    SPT3        IF MATCH (ON UPPER)
 SPT2     AODL   T4          INCREMENT PAGE TABLE HASH INDEX
          SHN    -20         SAVE POSSIBLE CARRY BIT
          RADL   T3
          SOD    T7          DECREMENT SEARCH COUNT
          ZJN    SPT4        IF NO MORE TO SEARCH
          LJM    SPT1        CONTINUE SEARCH

*         THE CORRECT PAGE TABLE ENTRY HAS BEEN FOUND.  CREATE THE REAL MEMORY
*         ADDRESS.

 SPT3     LDDL   MP+2        SAVE PAGE OFFSET
          SHN    -9D
          LPML   PSMV
          STD    T5
          LDDL   W3          CREATE RMA
          STD    T2
          SHN    -14
          STD    T1
          LDD    W2          GET UPPER SIX BITS
          LPN    77
          SHN    4
          RAD    T1          (T1 T2) = R-REGISTER
          LDD    MP+2
          LPC    770
          SHN    11
          LMD    T5          INCLUDE UPPER BITS OF BYTE NUMBER
          SHN    6
          LMC    RR          ACTIVATE R-REGISTER
          LRD    T1
 SPT4     LJM    SPTX        RETURN

 SPTP     CON    0,0         WORD ADDRESS OF PAGE TABLE ADDRESS

          OVERFLOW  SCMT     CHECK FOR OVERFLOW
          OVERLAY  (MDD HELP WITH NO PARAMETERS)
 HEP      SPACE  4,10
**        HEP - HELP ROUTINE (WITH NO PARAMETERS).
*
*         EXIT   TO *HWP* IF PARAMETER SPECIFIED.
*
*         USES   M1, M2, M3.
*
*         CALLS  GKC, SKP, WAS, *HWP*.
*
*         MACROS PRINT.


 HEP6     LDI    BP          SET COMMAND NAME
          SHN    10
          ADM    1,BP
          STML   HLPC
          CALL   HWP         PROCESS HELP WITH PARAMETER

 HEP      ROUTINE

          RJM    SKP         SKIP DELIMITERS
          NJN    HEP6        IF PARAMETER SUPPLIED
          AOM    OVLP        INHIBIT OVERLAY LOADS
          LDN    0           INITIALIZE LINE COUNTER
          STD    M1
          LDC    HEPB        GET FIRST COMMAND
          STD    M2

*         DETERMINE COMMAND MASK.

          LDM    S0FLG       CHECK FOR S0/S0E MAINFRAME
          SHN    1
          NJN    HEP0        IF S0/S0E, SET MASK = 2
          LDN    1           SET MASK = 1 FOR ALL OTHER MAINFRAMES
 HEP0     STD    M3
 HEP1     LDI    M2          CHECK COMMAND RELEVANCE
          LPDL   M3
          ZJN    HEP5        IF COMMAND NOT VALID ON THIS HARDWARE
          LDM    1,M2        CHECK IF LINE PRESENT
          ZJP    CMDF        IF END OF LIST
          AOD    M1          ADVANCE LINE COUNTER
          LMN    23D
          NJN    HEP4        IF PAUSE NOT REQUIRED

*         PAUSE SO HELP TEXT DOES NOT SCROLL.

          PRINT  HEPA+CRLF   NOTIFY OPERATOR OF PAUSE
          LDC    HEP3        SET TEMPORARY REENTRY ADDRESS
          STI    PT
 HEP2     LJM    SMPX        RETURN

 HEP3     RJM    GKC         GET CHARACTER FROM TERMINAL
          ZJN    HEP2        IF NO CHARACTER ENTERED
          LDN    1           RESET LINE COUNTER
          STD    M1

*         PRINT NEXT LINE OF DIRECTORY.

 HEP4     LDM    1,M2        SET ADDRESS OF HELP TEXT
          ADC    CRLF        ADD IN CALL TO *EOL*
          RJM    WAS         PRINT COMMAND
 HEP5     LDN    2           ADVANCE TO NEXT COMMAND
          RAD    M2
          LJM    HEP1        LOOP FOR NEXT COMMAND

 HEPA     ASCII  (Press any key to continue.)

 HEPB     BSS    0           DESCRIPTION OF EACH COMMAND
 HELD     HERE

          OVERFLOW  SCMT     CHECK FOR OVERFLOW
          OVERLAY  (MDD HELP COMMAND WITH PARAMETER)
 HWP      SPACE  4,10
**        HWP - HELP ROUTINE (WITH PARAMETER).
*
*         ENTRY  (HLPC) = COMMAND MNEMONIC.
*
*         USES   T1, T2, T3.
*
*         CALLS  WAS.


 HWP      ROUTINE

          AOM    OVLP        INHIBIT OVERLAY LOADS

*         DETERMINE COMMAND MASK.

          LDM    S0FLG       CHECK FOR S0/S0E MAINFRAME
          SHN    1
          NJN    HWP1        IF S0/S0E, SET MASK = 2
          LDN    1           SET MASK = 1 FOR ALL OTHER MAINFRAMES
 HWP1     STD    T2

*         SEARCH HELP TEXT FOR MATCHING COMMAND.

          LDN    0           INITIALIZE SEARCH INDEX
          STD    T1
 HWP2     LDM    HWPA,T1     CHECK VALIDITY OF COMMAND
          LPDL   T2
          ZJN    HWP3        IF COMMAND NOT VALID ON THIS HARDWARE
          LDM    HWPA+1,T1
          ZJN    HWP5        IF COMMAND NOT PRESENT IN LIST
          STD    T3
          LDIL   T3          GET FIRST WORD OF HELP ENTRY
          LMML   HLPC
          ZJN    HWP4        IF COMMAND FOUND
 HWP3     LDN    2           ADVANCE TO NEXT ENTRY
          RAD    T1
          UJN    HWP2        LOOP

 HWP4     LDM    HWPA+1,T1   SET ADDRESS OF HELP TEXT
          ADC    CRLF        ADD CALL TO *EOL*
          RJM    WAS         PRINT DESIRED SYNTAX
          LJM    CMDF        RETURN

 HWP5     LJM    CMDE        PROCESS ERROR

 HWPA     BSS    0           TEXT FOR INDIVIDUAL COMMANDS
 HELP     HERE

          OVERFLOW  SCMT     CHECK FOR OVERFLOW
          OVERLAY  (MDD *DF* COMMAND ROUTINES)
 DFR      SPACE  4,10
**        DFR - DISPLAY DFT CONTROL BLOCK HEADER.
*
*         USES   CM - CM+3, M2, M3, T1, T2, WC.
*
*         CALLS  FDP, LRR, PRN, TDF, WAS.
*
*         MACROS PRINT.


 DFR      ROUTINE

          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          RJM    FDP         FETCH DFT POINTER
          NJN    DFR5        IF DFT BLOCK EXISTS
          PRINT  DFRB+CRLF   *No DFT*
          LJM    CMDF        RETURN

*         SET UP TO DISPLAY DFT HEADER BLOCK.

 DFR5     AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDN    0           INITIALIZE HEADER BLOCK WORD OFFSET
          STD    M2
          LRD    DP          SET R-REGISTER TO DFT BLOCK
          LDML   DFTO
          LMC    RR          ACTIVATE R-REGISTER
          CRDL   CM          READ DFT HEADER
          LDD    CM+DHNPW    GET NUMBER OF HEADER WORDS
          SHN    -DH.NPW
          NJN    DFR10       IF COUNT PRESENT
          LDN    6           ASSUME DFT LEVEL 1 WITH 6 HEADER WORDS
 DFR10    STD    M3

*         DISPLAY DFT HEADER BLOCK.

 DFR15    RJM    LRR         RESTORE R-REGISTER
          LDD    M2          GET OFFSET INTO BLOCK
          ADM    DFTO
          LMC    RR          ACTIVATE R-REGISTER
          CRML   NBUF,ON     READ WORD FROM BLOCK
          LDC    HMDT+16D    HEX WORD 16 NIBBLES
          RJM    PRN         PRINT WORD
          LDML   DFRA,M2     GET LABEL
          RJM    WAS         OUTPUT LABEL WITH EOL
          AOD    M2          INCREMENT TO NEXT WORD
          LMD    M3          TEST FOR END
          NJN    DFR15       IF MORE HEADER WORDS TO DISPLAY

*         TRANSLATE DFT CONTROL WORD FLAGS.

          RJM    TDF         TRANSLATE DFT HEADER
          LDC    DFR5        GET REPEAT ADDRESS
          LJM    CMDR        RETURN

 DFRA     BSS    0           TABLE OF LABEL ADDRESSES
          LOC    0
 HDRP     CON    DFHM+CRLF   DFT CONTROL WORD
 SECP     CON    DFSP+CRLF   SECDED ID TABLE POINTER
 MRBP     CON    DFRP+CRLF   MAINTENANCE REGISTER BUFFERS POINTER
 MDLP     CON    DFDP+CRLF   MODEL DEPENDENT BUFFER POINTER
 NVEP     CON    DFVP+CRLF   NOS/VE BUFFER POINTER
 C17P     CON    DFPP+CRLF   C170 PP RESIDENT BUFFER POINTER
 OSRP     CON    DFNP+CRLF   C170 OS BUFFER POINTER
 BCWP     CON    DFCW+CRLF   MR BUFFER CONTROL WORDS BUFFER POINTER
 MECP     CON    DFMC+CRLF   MAINFRAME ELEMENT COUNTER BUFFER POINTER
 ECRP     CON    DFCI+CRLF   DFT CONTROL INFORMATION BUFFER POINTER
 SSBP     CON    DFSS+CRLF   SUPPORTIVE STATUS BUFFERS POINTER
 NRSP     CON    DFNR+CRLF   NON-REGISTER STATUS BUFFER POINTER
 DCMP     CON    DFCM+CRLF   DFT CENTRAL MEMORY RESIDENT POINTER
 PRDP     CON    DFPR+CRLF   PP REGISTER SAVE AREA POINTER
 SDBP     CON    DFSD+CRLF   SECONDARY DFT BUFFER POINTER
          LOC    *O

 DFHM     ASCII  ( DFT Control Word)
 DFSP     ASCII  ( SECDED ID Table PTR.)
 DFRP     ASCII  ( Maintenance Reg. Buffers PTR.)
 DFDP     ASCII  ( Model Dependent Buffer PTR.)
 DFVP     ASCII  ( NOS/VE Buffer PTR.)
 DFPP     ASCII  ( C170 PP Resident Buffer PTR.)
 DFNP     ASCII  ( C170 OS Buffer PTR.)
 DFCW     ASCII  ( MR Buf. Control Words Buffer PTR.)
 DFMC     ASCII  ( MF Element Counter Buffer PTR.)
 DFCI     ASCII  ( DFT Control Info. Buffer PTR.)
 DFSS     ASCII  ( Supportive Status Buffers PTR.)
 DFNR     ASCII  ( Non-Register Status Buffer PTR.)
 DFCM     ASCII  ( DFT Central Memory Resident PTR.)
 DFPR     ASCII  ( PP Register Save Area PTR.)
 DFSD     ASCII  ( Secondary DFT Buffer PTR.)

 DFRB     ASCII  (No DFT)
 TDF      SPACE  4,10
**        TDF - TRANSLATE DFT HEADER.
*
*         ENTRY  (DP - DP+1) = POINTER TO DFT HEADER.
*
*         USES   M2, W0 - W3.
*
*         CALLS  DFV.


 TDF      SUBR               ENTRY/EXIT
          LRD    DP          READ THE DFT HEADER
          LDM    DFTO
          LMC    RR
          CRDL   W0

*         THE FOLLOWING CODE MUST BE MODIFIED IF NEW FLAGS ARE ADDED.

          LDDL   W3          GET FLAGS
          LPC    1S13-1      EXTRACT 13 FLAGS
          SHN    20-13D      LEFT JUSTIFY 13 FLAGS IN 16-BIT PP WORD
          STDL   W2
          LDC    TDFB        DFT BIT LIST
          RJM    DFV         DECODE FLAG VALUES
          UJN    TDFX        RETURN


 TDFB     CON    =C*DFT = *
          LOC    0
          CON    =C*DISABLE SCM REFRESH*
          CON    =C*DUAL-STATE TRANSITION*
          CON    =C*DFT FREEZE*
          CON    =C*HALT ON CORRECTED ERROR*
          CON    =C*HALT ON UNCORRECTED ERROR*
          CON    =C*DFT VERIFIED*
          CON    =C*DFT REJECTED*
          CON    =C*LOG SECDED*
          CON    0           RETURN FROM DUAL STATE NON-DEDICATED MODE
          CON    =C*C170 ERROR LOGGING*
          CON    =C*C170 NON-DEDICATED MODE*
          CON    =C*C180 ERRORS LOGGED*
          CON    =C*C170 ERRORS LOGGED*
          LOC    *O
          SPACE  4,10
*         COMMON DECKS.


*COPY     CTP$SCI_MDD_DFT_CMDS_COMMON

          OVERFLOW  SCMT     CHECK FOR OVERFLOW
          OVERLAY  (MDD *MB* COMMAND ROUTINES)
 MBR      SPACE  4,10
**        MBR - DISPLAY DFT MAINTENANCE BUFFER CONTROL WORDS.
*
*         USES   M1, M2, M3, PC, PP, T2, WC, CM - CM+3, CN - CN+3.
*
*         CALLS  DTO, EOL, FDP, FWB, LRR, PHL, PIN, PRN, PSN, SMA, *DOF*, *MRR*.
*
*         MACROS PRINT, READMR.


 MBR      ROUTINE

          RJM    FDP         FETCH DFT POINTER
          NJN    MBR5        IF DFT BLOCK EXISTS
          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          PRINT  MBRF+CRLF   *No DFT*
          LJM    CMDF        RETURN

 MBR5     LDD    PC          GET PARAMETER COUNT
          LPN    1S1
          ZJN    MBR10       IF NOT *MB,NN*
          CALL   MRR         PROCESS MRB OUTPUT

*         GET THE DFT VERSION NUMBER TO DETERMINE WHICH DISPLAY FORMAT TO USE.

 MBR10    LRD    DP          SET R-REGISTER TO DFT BLOCK
          LDML   DFTO
          LMC    RR          ACTIVATE R-REGISTER
          CRDL   CM          READ DFT HEADER
          LDDL   CM+DHRL     GET DFT VERSION
          SHN    -DH.RL
          SBN    VER4
          PJN    MBR15       IF VERSION 4 OR ABOVE
          LJM    DOF         DISPLAY OLD FORMAT OF THE *MB* COMMAND

*         INITIALIZE FOR DISPLAY.

 MBR15    AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDN    0           CLEAR HEADER LINES DISPLAYED FLAG
          STM    MBRA
          STM    MBRB        CLEAR INDEX NUMBER DISPLAYED FLAG
          LDN    1           INITIALIZE DISPLAY INDEX
          STD    M1
          LRD    DP          GET BUFFER CONTROL WORDS POINTER
          LDML   DFTO
          ADC    RR+BCWP
          CRDL   CM
          LDD    CM+3        SAVE NUMBER OF BUFFER CONTROL WORD ENTRIES
          SBN    1           SKIP SCRATCH BUFFER
          STD    WC
          LRD    CM+1
          LDD    CM          SAVE BUFFER CONTROL WORD OFFSET
          STD    PC
          RJM    SMA         SET MEMORY ADDRESS
          LRD    DP          GET SUMMARY STATUS BUFFER POINTER
          LDML   DFTO
          ADC    RR+SSBP
          CRDL   CM
          ADN    1           GET NRSB POINTER
          ERRNZ  NRSP-SSBP-1 (CODE EXPECTS CONSECUTIVE POINTERS)
          CRDL   CN
          LRD    CM+1        GET FIRST WORD OF SUPPORTIVE STATUS BUFFER
          LDD    CM
          ADC    RR
          CRDL   CM
          LDDL   CM+3        SAVE SUPPORTIVE STATUS BUFFER ELEMENT SIZE
          STML   MBRC
          ADN    1           SET SUPPORTIVE STATUS ENTRY OFFSET (SKIP SCRATCH)
          STDL   M2
          LRD    CN+1        GET FIRST WORD OF NRSB
          LDD    CN
          ADC    RR
          CRDL   CN

*         FOR THE NON-REGISTER STATUS BUFFERS, THE FIRST THREE ENTRIES WILL
*         NOT BE DISPLAYED (SCRATCH, TOP OF HOUR AND *SCI* ENTRIES).

          LDD    CN+2        SAVE NUMBER OF NRSB ENTRIES
          SBN    3           SKIP SCRATCH, TOP OF HOUR AND *SCI* ENTRIES
          STD    PP
          LDDL   CN+3        SAVE NRSB ELEMENT SIZE
          STML   MBRD
          STDL   M3          SET OFFSET TO SKIP SCRATCH, TOP OF HOUR AND *SCI*
          SHN    1
          ADN    1           SKIP BUFFER HEADER WORD
          RADL   M3

*         DISPLAY NEXT SUPPORTIVE STATUS BUFFER IF THERE IS ONE.

 MBR20    LDDL   WC          CHECK IF SUPPORTIVE STATUS BUFFER TO DISPLAY
          ZJP    MBR30       IF NO SUPPORTIVE STATUS BUFFER TO DISPLAY
          RJM    LRR         LOAD R-REGISTER FOR MR BUFFER CONTROL WORDS
          LDD    M1          READ NEXT MR BUFFER CONTROL WORD
          ADD    PC
          ADC    RR
          CRDL   CM
          LDDL   CM+2        CHECK SEQUENCE NUMBER
          STML   MBRE+2      SAVE FOR *PSN*
          SHN    -8D
          ZJP    MBR25       IF SEQUENCE NUMBER = 0, THEN END OF SS BUFFER
          RJM    PHL         PRINT HEADER LINES
          LDN    COLSI       GET INDEX NUMBER COLUMN NUMBER
          RJM    PIN         PRINT INDEX NUMBER
          LDN    COLSS       GET SEQUENCE NUMBER COLUMN NUMBER
          RJM    PSN         PRINT SEQUENCE NUMBER
          LRD    DP          GET SUPPORTIVE STATUS BUFFER POINTER
          LDML   DFTO
          ADC    RR+SSBP
          CRDL   CM
          LRD    CM+1
          LDN    4           SET NUMBER OF WORDS TO READ
          STD    T2
          LDD    CM          READ NEXT SUPPORTIVE STATUS BUFFER ENTRY
          ADDL   M2
          ADC    RR
          CRML   MBRE,T2
          LDN    0           SET END OF FAULT SYMPTOM CODE
          STM    MBRE+20
          LDN    COLSF       GET FAULT SYMPTOM CODE COLUMN NUMBER
          RJM    FWB         FILL WITH BLANKS
          PRINT  MBRE+12     DISPLAY FAULT SYMPTOM CODE
          LDML   MBRC        INCREMENT SUPPORTIVE STATUS ENTRY OFFSET
          RADL   M2
          SOD    WC          DECREMENT NUMBER OF BUFFER CONTROL WORDS LEFT
 MBR25    STD    WC

*         DISPLAY NEXT NRSB IF THERE IS ONE.  HOWEVER, DO NOT DISPLAY ANYTHING
*         FOR THE TOP OF HOUR ENTRY (INDEX = 1) OR THE *SCI* ENTRY (INDEX = 2).

 MBR30    LDDL   PP          CHECK IF NRSB ENTRIES LEFT
          ZJP    MBR45       IF NO NRSB ENTRIES LEFT
          LDD    M1
          SBN    3
          PJN    MBR35       IF NOT TOP OF HOUR OR *SCI* INDEX
          LDD    WC          CHECK IF FIRST SS BUFFER CONTAINED DATA
          ZJP    MBR55       IF NO SS DATA
          LJM    MBR50       WRITE END OF LINE

 MBR35    LRD    DP          GET NRSB POINTER
          LDML   DFTO
          ADC    RR+NRSP
          CRDL   CM
          LDN    5           SET NUMBER OF ELEMENT WORDS TO READ
          STD    T2
          LRD    CM+1
          LDD    CM
          ADDL   M3
          ADC    RR
          CRML   MBRE,T2
          LDML   MBRE+2      GET SEQUENCE NUMBER
          SHN    -8D
          ZJP    MBR45       IF SEQUENCE NUMBER = 0, THEN END OF NRSB
          RJM    PHL         PRINT HEADER LINES
          LDN    COLNI       GT INDEX NUMBER COLUMN NUMBER
          RJM    PIN         PRINT INDEX NUMBER
          LDN    COLNS       GET SEQUENCE NUMBER COLUMN NUMBER
          RJM    PSN         PRINT SEQUENCE NUMBER
          LDN    0           SET END OF FAULT SYMPTOM CODE
          STM    MBRE+24
          LDN    COLNF       GET FAULT SYMPTON CODE COLUMN NUMBER
          RJM    FWB         FILL WITH BLANKS
          PRINT  MBRE+16     DISPLAY FAULT SYMPTOM CODE
          LDML   MBRD        INCREMENT NRSB ENTRY OFFSET
          RADL   M3
          SOD    PP          DECREMENT NUMBER OF NRSB ENTRIES LEFT
 MBR45    STD    PP
          LDM    MBRB        CHECK IF ANY ENTRIES PROCESSED
          ZJN    MBR60       IF DONE WITH BOTH SS BUFFER/NRSB
 MBR50    RJM    EOL         WRITE END OF LINE
          LDN    0           RESET INDEX NUMBER DISPLAYED FLAG
          STM    MBRB
 MBR55    AOD    M1          INCREMENT DISPLAY NDEX
          LJM    MBR20       DISPLAY NEXT LINE

*         DISPLAY IOU SUMMARY STATUS REGISTER.

 MBR60    PRINT  MBRK+CRLF   PRINT BLANK LINE
          LDM    I0CC        SET IOU CONNECT CODE
          STD    EC
          LDN    0           SET IOU SUMMARY STATUS REGISTER NUMBER
          STD    RN
          READMR NBUF        READ IOU SUMMARY STATUS
          RJM    DTO         TEST FOR DEADMAN TIMEOUT
          PRINT  MBRH        PRINT LABEL
          LDN    MRDT+2
          RJM    PRN         DISPLAY 2 CHARACTERS OF REGISTER
          RJM    EOL         PRINT END OF LINE
          RJM    EOL         PRINT BLANK LINE
          LDM    MBRA        CHECK IF ANY BUFFER DATA DISPLAYED
          ZJN    MBR65       IF NONE
          PRINT  MBRI        PRINT INFORMATIONAL MESSAGE
          PRINT  MBRJ+CRLF
 MBR65    LDC    MBR15       GET REPEAT ADDRESS
          LJM    CMDR        RETURN

 COLSI    EQU    1           SS INDEX NUMBER COLUMN NUMBER
 COLSS    EQU    8D          SS SEQUENCE NUMBER COLUMN NUMBER
 COLSF    EQU    15D         SS FAULT SYMPTOM CODE COLUMN NUMBER
 COLNI    EQU    30D         NRSB INDEX NUMBER COLUMN NUMBER
 COLNS    EQU    37D         NRSB SEQUENCE NUMBER COLUMN NUMBER
 COLNF    EQU    44D         NRSB FAULT SYMPTOM CODE COLUMN NUMBER
 MBRA     CON    0           HEADER LINES DISPLAYED FLAG
 MBRB     CON    0           INDEX NUMBER DISPLAYED FLAG
 MBRC     CON    0           SUPPORTIVE STATUS BUFFER ELEMENT SIZE
 MBRD     CON    0           NON-REGISTER STATUS BUFFER ELEMENT SIZE
 MBRE     BSS    6*4         ELEMENT BUFFER
 MBRF     ASCII  (No DFT)
 MBRH     ASCII  (IOU SS = )
 MBRI     ASCII  (Enter MB,i or NS,i [i = index )
 MBRJ     ASCII  (number] for more information)
 MBRK     ASCII  ( )
 NSR      SPACE  4,10
**        NSR - DISPLAY NON-REGISTER STATUS BUFFER.
*
*         USES   M1, M2, M3, T1, CM - CM+3.
*
*         CALLS  EOL, FDP, LRR, PRN, SMA.
*
*         MACROS PRINT.


 NSR      ROUTINE

          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          RJM    FDP         FETCH DFT POINTER
          NJN    NSR5        IF DFT BLOCK EXISTS
          PRINT  MBRF+CRLF   *No DFT*
          LJM    CMDF        RETURN

 NSR5     LDDL   W0+1        CHECK DFT VERSION LEVEL
          SHN    -DH.RL
          SBN    VER5
 NSR10    MJP    CMDE        IF DFT VERSION DOES NOT SUPPORT COMMAND
 NSR15    AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LDD    PC          GET PARAMETER COUNT
          LPN    1S1
          NJN    NSR20       IF INDEX SPECIFIED
          STM    DFTP        SET DEFAULT TO INDEX ZERO
 NSR20    LRD    DP
          LDM    DFTO        GET NON-REGISTER STATUS BUFFER POINTER
          ADC    RR+NRSP
          CRDL   CM
          LRD    CM+1
          LDD    CM          SAVE A-OFFSET
          STD    M2
          ADC    RR
          CRDL   CM          READ FIRST WORD OF NRSB
          LDDL   CM+3        SAVE BUFFER SIZE
          STDL   M1
          LDDL   CM+2        GET NUMBER OF BUFFERS
          SBN    1           INDICES START WITH ZERO
          SBM    DFTP
          MJN    NSR10       IF BUFFER INDEX TOO BIG

*         COMPUTE OFFSET TO SPECIFIED ENTRY.

          LDN    1           SKIP HEADER WORD
          RAD    M2
          LDM    DFTP
          STD    T1
 NSR25    SOD    T1          DECREMENT INDEX
          MJN    NSR30       IF OFFSET FOUND
          LDD    CM+3        INCREMENT OFFSET TO NEXT ENTRY
          RADL   M2
          UJN    NSR25       CONTINUE

 NSR30    LDDL   M2
          RJM    SMA         SAVE MEMORY ADDRESS
          LDN    0           INITIALIZE COUNTER
          STD    M3
 NSR35    RJM    LRR         RESTORE R-REGISTER
          LDDL   M2
          ADD    M3
          ADC    RR
          CRML   NBUF,ON     READ NEXT WORD
          LDC    HBDT+16D    HEX BYTE MEMORY DUMP
          RJM    PRN         PRINT THE WORD
          RJM    EOL
          AOD    M3          INCREMENT COUNTER
          SBD    M1          TEST FOR END
          MJN    NSR35       IF MORE TO PROCESS
          LDC    NSR15       GET REPEAT ADDRESS
          LJM    CMDR        RETURN
 DOF      SPACE  4,10
**        DOF - DISPLAY OLD FORMAT OF THE *MB* COMMAND.
*
*         USES   M2, WC, CM - CM+3.
*
*         CALLS  EOL, LRR, PRN, SMA.
*
*         MACROS PRINT.


 DOF      ROUTINE

          AOM    OVLP
          LRD    DP          READ THE DFT BUFFER HEADER WORD
          LDML   DFTO
          LMC    RR
          CRDL   CM
          LDD    CM+DHNBF    GET NUMBER OF MAINTENANCE BUFFERS
          LPN    77
          STD    WC
          LDD    CM+DHNPW    GET NUMBER OF HEADER WORDS
          SHN    -DH.NPW
          NJN    DOF5        IF COUNT PRESENT
          LDN    6           ASSUME DFT LEVEL 1 WITH 6 HEADER WORDS
 DOF5     STD    M2

*         DISPLAY MAINTENANCE REGISTER BUFFER CONTROL WORDS.

          PRINT  DOFA+CRLF   PRINT HEADER AND EOL
          LRD    DP          SET R-REGISTER TO DFT BLOCK
          LDML   DFTO
          RAD    M2
          RJM    SMA         SET MEMORY ADDRESS
          LDD    M2          ADJUST LWA+1 TO DISPLAY
          RAD    WC          SAVE NUMBER
 DOF10    RJM    LRR         RESTORE R-REGISTER
          LDD    M2
          LMC    RR          ACTIVATE R-REGISTER
          CRML   NBUF,ON     READ WORD FROM BLOCK
          LDC    HMDT+16D    HEX WORD 16 NIBBLES
          RJM    PRN         PRINT WORD
          RJM    EOL         WRITE END OF LINE
          AOD    M2          INCREMENT TO NEXT WORD
          SBD    WC          TEST FOR END
          MJN    DOF10       IF NOT DONE
          LDC    DOF         SET REPEAT ADDRESS
          LJM    CMDR        RETURN

 DOFA     ASCII  (MR Buffer Control Words)
 FWB      SPACE  4,10
**        FWB - FILL WITH BLANKS.
*
*         THE OUTPUT LINE IS FILLED WITH BLANKS UP TO THE SPECIFIED
*         COLUMN NUMBER.
*
*         (A) = COLUMN NUMBER.
*
*         USES   T1.
*
*         MACROS PRINT.


 FWB      SUBR               ENTRY/EXIT
          STD    T1          SAVE COLUMN NUMBER
 FWB5     LDD    BP          COMPUTE THE CURRENT NUMBER OF CHARACTERS
          SBD    BA
          SBD    T1
          ADN    1
          PJN    FWBX        IF AT SPECIFIED COLUMN
          PRINT  FWBA        ADD A SPACE TO THE OUTPUT BUFFER
          UJN    FWB5        CONTINUE

 FWBA     ASCII  ( )
 PHL      SPACE  4,10
**        PHL - PRINT HEADER LINES FOR *MB* COMMAND DISPLAY.
*
*         ENTRY  (MBRA) = 0 IF HEADER LINES HAVE NOT YET BEEN PRINTED.
*
*         EXIT   (MBRA) <> 0.
*
*         CALLS  EOL.
*
*         MACROS PRINT.


 PHL      SUBR               ENTRY/EXIT
          LDML   MBRA
          NJN    PHLX        IF HEADER LINES HAVE ALREADY BEEN PRINTED
          PRINT  PHLA        PRINT HEADER LINE 1
          PRINT  PHLB+CRLF
          RJM    EOL         PRINT BLANK LINE
          PRINT  PHLC        PRINT HEADER LINE 2
          PRINT  PHLD+CRLF
          RJM    EOL         PRINT BLANK LINE
          AOM    MBRA        SET HEADER LINES DISPLAYED FLAG
          UJN    PHLX        RETURN

 PHLA     ASCII  (MR Buff. Control Words)
 PHLB     ASCII  (       Non-Reg. Status Buffers)
 PHLC     ASCII  (Index  Seq #  FSC            )
 PHLD     ASCII  (Index  Seq #  FSC)
 PIN      SPACE  4,10
**        PIN - PRINT INDEX NUMBER.
*
*         ENTRY  (A) = COLUMN NUMBER AT WHICH TO START.
*                (M1) = INDEX NUMBER.
*
*         EXIT   (MBRB) <> 0.
*
*         CALLS  FWB, PRN.


 PIN      SUBR               ENTRY/EXIT
          RJM    FWB         FILL WITH BLANKS TO SPECIFIED COLUMN NUMBER
          LDD    M1          GET INDEX NUMBER TO BE DISPLAYED
          STM    NBUF
          LDN    MRDT+2
          RJM    PRN         PRINT NUMBER
          AOM    MBRB        SET INDEX NUMBER DISPLAYED FLAG
          UJN    PINX        RETURN
 PSN      SPACE  4,10
**        PSN - PRINT SEQUENCE NUMBER.
*
*         ENTRY  (A) = COLUMN NUMBER AT WHICH TO START.
*                (MBRE+2) = 8/SEQUENCE NUMBER, 8/.
*
*         CALLS  FWB, PRN.


 PSN      SUBR               ENTRY/EXIT
          RJM    FWB         FILL WITH BLANKS TO SPECIFIED COLUMN NUMBER
          LDML   MBRE+2      GET SEQUENCE NUMBER TO BE DISPLAYED
          SHN    -8D
          STM    NBUF
          LDN    MRDT+2
          RJM    PRN         PRINT SEQUENCE NUMBER
          UJN    PSNX        RETURN
          SPACE  4,10
*         COMMON DECKS.


*COPY     CTP$SCI_MDD_DFT_CMDS_COMMON

          OVERFLOW  SCMT     CHECK FOR OVERFLOW
          OVERLAY  (MDD MRB COMMAND ROUTINES)
 MRR      SPACE  4,10
**        MRR - DISPLAY MAINTENANCE REGISTER BUFFER.
*
*         USES   M1, M2, M3, T1 - T5, WC, W0 - W3.
*
*         CALLS  DBC, EOL, LRR, PRN, SMA, UPR.


 MRR      ROUTINE

          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LRD    DP          SET R-REGISTER TO DFT BLOCK
          LDML   DFTO
          LMC    RR          ACTIVATE R-REGISTER
          CRDL   W0          READ DFT HEADER
          LDD    W0+DHNPW    GET NUMBER OF HEADER WORDS
          SHN    -DH.NPW
          NJN    MRR5        IF HEADER CONTAINS NUMBER OF HEADER WORDS
          LDN    6           ASSUME DFT LEVEL 1 WITH 6 HEADER WORDS
 MRR5     ADC    ADNI        UPDATE INSTRUCTION
          STM    MRRA
          LDDL   W0+DHLBF    GET LENGTH OF MAINTENANCE BUFFERS
          SHN    -10
          STD    WC          SAVE NUMBER
          LDD    W0+DHNBF    GET NUMBER OF MAINTENANCE BUFFERS
          LPN    77
          SBN    1           FOR BEGINNING WITH ZERO
          SBM    DFTP        SUBTRACT BUFFER NUMBER OF INTEREST
          MJP    CMDE        IF TOO LARGE
          LDD    W0+DHRL     CHECK DFT VERSION
          SHN    -DH.RL
          SBN    4
          MJN    MRR10       IF VERSION 3 OR BELOW
          LDM    DFTO        READ BUFFER CONTROL WORD POINTER
          ADC    RR+BCWP
          CRDL   W0
          LDD    W0
          LRD    W0+1
          UJN    MRR15       CONTINUE

 MRR10    LDM    DFTO        SET OFFSET TO DFT CONTROL WORD
 MRRA     ADN    **          BYPASS POINTER AREA
 MRR15    ADM    DFTP        SELECT SPECIFIC POINTER REQUESTED
          LMC    RR          ACTIVATE R-REGISTER
          CRDL   W0          :   :   :   : OFFSET :
          LRD    DP
          LDM    DFTO        READ MR BUFFER POINTER
          ADC    RR+MRBP
          CRDL   T2          : A : R : R : LENGTH :
          LDD    T2
          ADD    W0+3
          STD    M3          SAVE A REGISTER + OFFSET
          LRD    T3          RESET R-REGISTER
          RJM    SMA         SAVE MEMORY ADDRESS
          RJM    DBC         DECODE BUFFER CONTROL WORD
          LDN    0           INITIALIZE COUNTERS
          STD    M1          BLOCK COUNTER
          STD    M2          WORD COUNTER
 MRR20    RJM    LRR         RESTORE R-REGISTER
          LDD    M3
          LMC    RR          ACTIVATE R-REGISTER
          CRML   RHDR,ON     READ IN THE HEADER
 MRR25    LDM    RHDR,M2     GET READY TO PRINT REGISTER NUMBER
          STM    NBUF
          RJM    LRR         RESTORE R-REGISTER
          AOD    M2          INCREMENT TO NEXT WORD
          ADD    M3          ADD IN POINTER + OFFSET
          LMC    RR          ACTIVATE R-REGISTER
          CRML   MRVAL,ON    READ WORD FROM BLOCK
          LDML   MRVAL       ADD REGISTER CONTENTS
          ADML   MRVAL+1
          ADML   MRVAL+2
          ADML   MRVAL+3
          ADML   NBUF        ADD REGISTER NUMBER
          ZJN    MRR30       IF END OF REGISTERS (NUMBER AND CONTENTS = 0)
          LDN    MRDT+2      DISPLAY REGISTER NUMBER
          RJM    PRN
          RJM    UDR         UNPACK AND DISPLAY THE REGISTER
 MRR30    LDD    M2
          SBN    4           TEST FOR END
          MJP    MRR25       IF NOT DONE
          LDN    5           ADVANCE ADDRESS
          RAD    M1
          SBD    WC
          ZJN    MRR35       IF ALL WORDS PROCESSED
          AOD    M2
          RAD    M3          INCREMENT OFFSET TO NEXT BLOCK
          LDN    0           RESET WORD COUNTER
          STD    M2
          LJM    MRR20       LOOP

 MRR35    LDK    OVLN        SET REPEAT OVERLAY NUMBER
          STML   CMDA
          LDC    MRR         SET REPEAT ADDRESS
          LJM    CMDR        RETURN
 DBC      SPACE  4,10
**        DBC - DECODE BUFFER CONTROL WORD.
*
*         ENTRY  (W0 - W3) = BUFFER CONTROL WORD.
*
*         EXIT   TO *TOH* IF TOP-OF-HOUR COUNTERS/SECDED ENTRY.
*
*         USES   M2, W2.
*
*         CALLS  PRN, WAS, *TOH*.
*
*         MACROS PRINT.


 DBC      SUBR               ENTRY/EXIT

*         CHECK FOR TOP-OF-HOUR COUNTERS/SECDED ENTRIES.

          LDD    W0+1        EXTRACT DFT ANALYSIS WITHOUT PRIORITY
          LMC    DATHM+0#0700
          ZJN    DBC1        IF TOP-OF-HOUR MAINFRAME ELEMENT COUNTER ENTRY
          LMN    DATHS&DATHM
 DBC1     ZJP    TOH         IF TOP-OF-HOUR SECDED ENTRY

*         PROCESS NORMAL MAINTENANCE REGISTER BUFFER.

          LDD    W0          GET OS ACTION CODE
          LPC    0#FF
          STM    NBUF        PRINT NUMBER
          LDN    MRDT+2
          RJM    PRN
          PRINT  DBCB        SPACE
          LDDL   W1          DFT ANALYSIS CODE
          STML   NBUF        PRINT NUMBER
          LDK    HMDT+4
          RJM    PRN
          PRINT  DBCB        SPACE
          LDDL   W2          GET SEQUENCE NUMBER
          SHN    -8D
          STM    NBUF        PRINT NUMBER
          LDN    MRDT+2
          RJM    PRN
          PRINT  DBCB        SPACE

*         THE FOLLOWING CODE MUST BE MODIFIED IF NEW FLAGS ARE ADDED.

          LDD    W2          GET FLAGS
          LPN    1S6-1       EXTRACT 6 FLAGS
          SHN    20-6        LEFT JUSTIFY 6 FLAGS IN 16-BIT PP WORD
          STDL   W2
          LDC    DBCA        DFT BIT LIST
          RJM    DFV         DECODE FLAG VALUES
          LJM    DBCX        RETURN


 DBCA     CON    =C*FLAGS = *
          LOC    0
          CON    =C*LOG(CONSOLE)*
          CON    =C*THRESHOLD EXCEEDED*
          CON    =C*LOG(OS)*
          CON    =C*BUFFER INTERLOCKED*
          CON    =C*VALID C180 DATA*
          CON    =C*VALID C170 DATA*
          ERRNZ  *-6         NUMBER OF FLAGS DOES NOT AGREE WITH CODE
          LOC    *O
 DBCB     ASCII  (, )
 ODC      SPACE  4,10
**        ODC - OUTPUT DESCRIPTOR AND ERROR COUNTS.
*
*         ENTRY  (A) = ADDRESS OF ELEMENT DESCRIPTOR.
*                (NBUF - NBUF+3) = MRB ENTRY.
*
*         CALLS  EOL, PRN, WAS.


 ODC      SUBR               ENTRY/EXIT
          RJM    WAS         OUTPUT DESCRIPTOR
          LDML   NBUF+1      PRINT UNLOGGED COUNT
          STML   NBUF
          LDC    HMDT+4
          RJM    PRN
          LDML   NBUF+2      PRINT CORRECTED COUNT
          STML   NBUF
          LDC    HMDT+4
          RJM    PRN
          LDML   NBUF+3      PRINT UNCORRECTED COUNT
          STML   NBUF
          LDC    HMDT+4
          RJM    PRN
          RJM    EOL         ADD END OF LINE
          UJN    ODCX        RETURN
 RNB      SPACE  4,10
**        RNB - READ NEXT BUFFER ENTRY.
*
*         ENTRY  (M1) = MRB ENTRY INDEX.
*                (M3) = OFFSET TO MRB INFORMATION.
*
*         EXIT   (NBUF - NBUF+3) = NEXT MRB ENTRY.
*
*         CALLS  LRR.


 RNB      SUBR               ENTRY/EXIT
          RJM    LRR         RESTORE R-REGISTER
          LDD    M1          READ NEXT ENTRY FROM BUFFER
          ADD    M3
          LMC    RR
          CRML   NBUF,ON
          UJN    RNBX        RETURN
 TOH      SPACE  4,10
**        TOH - PROCESS TOP-OF-HOUR COUNTER/SECDED ENTRY.
*
*         ENTRY  VIA *LJM*.
*                (W0 - W0+3) = MRB CONTROL WORD.
*                (M3) = OFFSET TO MRB INFORMATION.
*
*         USES   M1, M2, T0 - T3, T4.
*
*         CALLS  EOL, LRR, ODC, PRN, RNB, WAS.


 TOH      BSS    0           ENTRY
          LDC    SECP+RR     READ SECDED ID TABLE POINTER
          ADM    DFTO
          LRD    DP
          CRDL   T0
          LDD    T0+3        SET SECDED WORD COUNT IN MRB ENTRY
          ADN    2           INCLUDE OPTIONS INSTALLED AND EID DATA
          STD    M2
          LDM    S0FLG       CHECK MAINFRAME TYPE
          NJN    TOH1        IF S0/S0E
          STM    TOHH        SHORTEN LIST FOR OTHER MAINFRAMES

*         CHECK FOR TOP-OF-HOUR COUNTERS/SECDED ENTRIES.

 TOH1     LDD    W0+1        EXTRACT DFT ANALYSIS WITHOUT PRIORITY
          LMC    DATHS+0#0700
          ZJP    TOH8        IF SECDED ENTRY

*         PROCESS MAINFRAME ELEMENT COUNTERS ENTRY.

          PRINT  TOHA+CRLF   PRINT TITLE
          PRINT  TOHB+CRLF   PRINT COLUMN HEADINGS
          LDN    0           INITIALIZE WORD INDEX
          STD    M1

*         CHECK THE *DFT* REVISION LEVEL.  AT *DFT* REVISION LEVEL 4, THE
*         ELEMENT COUNTERS ARE DISPLAYED IN A DIFFERENT FORMAT.

          LRD    DP          READ *DFT* CONTROL WORD
          LDC    HDRP+RR
          ADM    DFTO
          CRDL   T0
          LDDL   T0+DHRL
          SHN    -DH.RL
          SBN    4
          PJN    TOH4        IF *DFT* VERSION >= 4
 TOH2     RJM    RNB         READ NEXT BUFFER ENTRY
          LDM    TOHG,M1
          RJM    ODC         OUTPUT DESCRIPTOR AND COUNTS
 TOH3     AOD    M1          ADVANCE WORD INDEX
          LDM    TOHG,M1     CHECK FOR END OF DESCRIPTORS
          NJN    TOH2        IF ALL WORDS NOT YET PROCESSED
          LJM    TOH10       SET UP FOR REENTRY

*         PROCESS MAINFRAME ELEMENT COUNTER ENTRY FOR DFT VERSION >= 4.
*         THE ELEMENT ID IN EACH ENTRY IS USED AS AN INDEX INTO THE
*         ELEMENT DESCRIPTOR TABLE.  THE *LOGGED MRB SIZE* IN THE
*         TOP-OF-HOUR SUPPORTIVE STATUS BUFFER ENTRY IS USED TO DETERMINE
*         HOW MANY ELEMENT ID'S TO PROCESS.  THE TOP-OF-HOUR SUPPORTIVE
*         STATUS BUFFER ENTRY IS ASSUMED TO BE ENTRY NUMBER 1.

 TOH4     LDC    SSBP+RR     GET SUPPORTIVE STATUS BUFFER POINTER
          ADM    DFTO
          LRD    DP
          CRDL   T0
          LRD    T1          READ SUPPORTIVE STATUS HEADER WORD
          LDDL   T0
          ADC    RR
          CRDL   T1
          LDDL   T4          BUFFER ELEMENT SIZE
          ADDL   T0          READ TOP-OF-HOUR SUPPORTIVE STATUS ENTRY
          ADC    RR+1
          CRDL   T0
          LDDL   T3          SAVE LOGGED MRB SIZE
          ZJN    TOH7        IF NONE TO LOG
          STDL   M2
 TOH5     RJM    RNB         READ NEXT BUFFER ENTRY
          LDML   NBUF        GET ELEMENT ID CODE
          STDL   T1
          SBN    0#10        ALTER OFFSET TO TABLE IF REQUIRED
          NJN    TOH6        IF NO ALTERING REQUIRED
          LDDL   T1          CHANGE TABLE OFFSET TO EITHER 4 OR 5
          LPN    2
          SHN    -1
          ADN    4
          STDL   T1
 TOH6     LDM    TOHI,T1
          RJM    ODC         OUTPUT DESCRIPTOR AND COUNTS
          AOD    M1
          SBD    M2
          NJN    TOH5        IF ALL WORDS NOT YET PROCESSED
 TOH7     LJM    TOH10       SET UP REENTRY ADDRESS

*         PROCESS SECDED ENTRY.

 TOH8     PRINT  TOHC+CRLF   PRINT TITLE
          LDN    0           INITIALIZE WORD INDEX
          STD    M1
          RJM    RNB         READ BUFFER ENTRY
          LDC    TOHD        *(MEM OI) = *
          RJM    WAS
          LDC    HMDT+16D    PRINT CONTENTS OF *OIMR* WORD
          RJM    PRN
          RJM    EOL         ADD END OF LINE
          RJM    LRR         RESTORE R-REGISTER
          AOD    M1
          ADD    M3          PROCESS ELEMENT ID WORD
          LMC    RR
          CRML   NBUF,ON
          LDC    TOHE        *(MEM EID) = *
          RJM    WAS
          LDC    HMDT+16D    PRINT CONTENTS OF *EIMR* WORD
          RJM    PRN
          RJM    EOL         ADD END OF LINE
          PRINT  TOHF+CRLF   PRINT COLUMN HEADINGS
 TOH9     AOD    M1          READ NEXT DATA WORD
          LMD    M2
          ZJP    TOH10       IF ALL WORDS PROCESSED
          RJM    RNB         READ NEXT BUFFER ENTRY
          LDML   NBUF
          ZJN    TOH10       IF NO MORE ERRORS TO PROCESS
          LDC    HMDT+4      PROCESS COUNT FIELD
          RJM    PRN
          LDML   NBUF+1      MOVE ADDRESS FIELD DATA
          STML   NBUF
          LDML   NBUF+2
          STML   NBUF+1
          LDC    HMDT+8D     PROCESS ADDRESS FIELD
          RJM    PRN
          LDML   NBUF+3      MOVE SYNDROME DATA
          STML   NBUF
          LDC    HMDT+4      PROCESS SYNDROME DATA
          RJM    PRN
          RJM    EOL         ADD END OF LINE
          LJM    TOH9        LOOP FOR NEXT WORD

*         SET UP FOR REENTRY.

 TOH10    LDC    MBR         SET UP REENTRY ADDRESS
          LJM    CMDR        EXIT TO *MDD* RESIDENT

 TOHA     ASCII  (TOP OF HOUR MAINFRAME ELEMENT COUNTERS)
 TOHB     ASCII  (ELEMENT     ULOG CORR UCOR)
 TOHC     ASCII  (TOP OF HOUR SECDED ID TABLE)
 TOHD     ASCII  ((MEM OI)  = )
 TOHE     ASCII  ((MEM EID) = )
 TOHF     ASCII  (CNT  ADDRESS  SYND)

*         DEFINE ASCII ELEMENT DESCRIPTORS AND ADDRESS TABLE FOR *DFT*
*         REVISION LEVEL < 4.

 TOHG     BSS    0
          CON    TOH.IOU     IOU-0
          CON    TOH.MEM     MEMORY-0
          CON    TOH.CPU     CPU-0
          CON    TOH.MFR     MAINFRAME
          CON    TOH.CON     CONSOLE
          CON    TOH.IOU1    IOU-1
          CON    TOH.MEM1    MEMORY-1
          CON    TOH.CPU1    CPU-1
          CON    TOH.GPD     GLOBAL PROCESSOR DESCRIPTOR
          CON    TOH.WCC     WALL CLOCK CHIP
*TOHH     CON    0           (ALL MAINFRAMES EXCEPT S0/S0E)

*         THE FOLLOWING ITEMS ARE ONLY APPLICABLE TO S0/S0E MAINFRAMES.

 TOHH     CON    TOH.MDD     MODEL DEPENDENT DESCRIPTOR
          CON    TOH.MAP     PAGE MAP
          CON    0           END OF LIST

 TOH.IOU  ASCII  (IOU-0     - )
 TOH.MEM  ASCII  (MEMORY-0  - )
 TOH.CPU  ASCII  (CPU-0     - )
 TOH.MFR  ASCII  (MAINFRAME - )
 TOH.CON  ASCII  (CONSOLE   - )
 TOH.IOU1 ASCII  (IOU-1     - )
 TOH.MEM1 ASCII  (MEMORY-1  - )
 TOH.CPU1 ASCII  (CPU-1     - )
 TOH.GPD  ASCII  (GPD MRT   - )
 TOH.WCC  ASCII  (WCC MRT   - )
 TOH.MDD  ASCII  (MOD. DEP. - )
 TOH.MAP  ASCII  (PAGE MAP  - )

*         DEFINE ADDRESS TABLE FOR *DFT* REVISION LEVEL >= 4.

 TOHI     BSS    0
          CON    TOH.CPU     CPU-0
          CON    TOH.MEM     MEMORY
          CON    TOH.IOU     IOU-0
          CON    TOH.MAP     PAGE MAP
          CON    TOH.CPU1    CPU-1
          CON    TOH.IOU1    IOU-1
 UDR      SPACE  4,10
**        UDR - UNPACK AND DISPLAY REGISTER.
*
*         ENTRY  (MRVAL) = PACKED REGISTER.
*
*         EXIT   (NBUF) = UNPACKED REGISTER.
*
*         USES   T1, T2.
*
*         CALLS  EOL, PRN.


 UDR      SUBR               ENTRY/EXIT
          LDN    0
          STD    T2          INITIALIZE POINTERS
          STD    T1
 UDR1     LDML   MRVAL,T2    16 BITS
          SHN    -10
          STM    NBUF,T1     UPPER 8 BITS
          AOD    T1          INCREMENT TO POINTER
          LDM    MRVAL,T2    16 BITS
          LPC    0#FF
          STM    NBUF,T1     LOWER 8 BITS
          AOD    T1          INCREMENT TO POINTER
          AOD    T2          INCREMENT FROM POINTER
          SBN    4
          NJN    UDR1        IF NOT DONE
          LDN    MRDT+16D
          RJM    PRN         DISPLAY THE MAINTENANCE REGISTER
          RJM    EOL         NEXT LINE
          UJN    UDRX        RETURN

 RHDR     BSS    4
 MRVAL    BSS    4
          SPACE  4,10
*         COMMON DECKS.


*COPY     CTP$SCI_MDD_DFT_CMDS_COMMON

          OVERFLOW  SCMT     CHECK FOR OVERFLOW
          OVERLAY  (MDD *DD*/*MD* COMMAND ROUTINES)
 DDR      SPACE  4,10
**        DDR - DISPLAY DFT STRUCTURE.
*
*         USES   M1, M2, M3, T2 - T5.
*
*         CALLS  EOL, FDP, LRR, PRN, SMA.


 DDR      ROUTINE

          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          RJM    FDP         FETCH DFT POINTER
          NJN    DDR10       IF DFT BLOCK EXISTS
          PRINT  DDRA+CRLF   *NO DFT*
          LJM    CMDF        RETURN

 DDR10    LDDL   W0+1        CHECK DFT VERSION LEVEL
          SHN    -DH.RL
          SBN    VER4
          MJP    CMDE        IF DFT VERSION DOES NOT SUPPORT THIS COMMAND
          LDD    PC          CHECK FOR SPECIFIED PARAMETER
          LPN    1S1
          NJN    DDR15       IF STRUCTURE PARAMETER SPECIFIED
          LDN    BCWP        SET DEFAULT TO *BC*
          STM    DDST
 DDR15    LDDL   W0          CHECK IF POINTER EXISTS
          SHN    -10
          SBN    1
          SBML   DDST
          MJP    CMDE        IF SELECTED BUFFER IS NOT IN STRUCTURE
 DDR20    AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LRD    DP          SET R-REGISTER TO DFT BLOCK
          LDN    0           INITIALIZE COUNTER
          STD    M2
          LDM    DFTO
          ADC    RR
          ADM    DDST        GET INDEX TO REQUESTED STRUCTURE
          CRDL   T2          : A : R : R : LENGTH :
          LDDL   T5          SAVE LENGTH OF BUFFER
          NJN    DDR25       IF BUFFER EXISTS
          PRINT  DDRB+CRLF   *Zero buffer length.*
          LJM    CMDR        RETURN

 DDR25    STDL   M1
          LRD    T3
          LDDL   T2          SAVE OFFSET
          STDL   M3
          RJM    SMA         SAVE MEMORY ADDRESS
 DDR30    RJM    LRR         RESTORE R-REGISTER
          LDDL   M3
          ADDL   M2
          LMC    RR
          CRML   NBUF,ON     READ A WORD OF THE STRUCTURE
          LDC    HBDT+16D    HEX BYTE MEMORY DUMP
          RJM    PRN         DISPLAY THE WORD
          RJM    EOL         WRITE END OF LINE
          AODL   M2          INCREMENT COUNTER
          SBDL   M1          TEST FOR END OF STRUCTURE
          MJN    DDR30       IF MORE TO PROCESS
          LDC    DDR20       GET REPEAT ADDRESS
          LJM    CMDR        RETURN

 DDRA     ASCII  (NO DFT)
 DDRB     ASCII  (Zero buffer length.)
 MDR      SPACE  4,10
**        MDR - DISPLAY DFT MODEL-DEPENDENT BUFFER.
*
*         USES   M1, M2, M3, T2 - T5.
*
*         CALLS  EOL, FDP, LRR, PRN, SMA.


 MDR      ROUTINE

          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          RJM    FDP         FETCH DFT POINTER
          NJN    MDR10       IF DFT BLOCK EXISTS
          PRINT  MDRM+CRLF   *NO DFT*
          LJM    CMDF        RETURN

 MDR10    AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          LRD    DP          SET R-REGISTER TO DFT BLOCK
          LDN    0
          STD    M2          INITIALIZE COUNTER
          LDM    DFTO
          ADC    RR+MDLP     ACTIVATE R-REGISTER
          CRDL   T2          : A : R : R : LENGTH :

*         IF THE BUFFER INDEX PARAMETER IS PRESENT, GET THE CORRESPONDING BUFFER POINTER.

          LDD    PC          GET PARAMETER COUNT
          LPN    1S1
          ZJN    MDR30       IF NOT *MD,BI*
          LDDL   W0+1        CHECK DFT VERSION
          SHN    -DH.RL
          SBN    VER4
 MDR20    MJP    CMDE        IF DFT VERSION DOES NOT SUPPORT THIS COMMAND
          LDDL   T2+3        GET NUMBER OF BUFFERS
          SBN    1           INDICES BEGIN WITH ZERO
          SBM    DFTP
          MJN    MDR20       IF BUFFER INDEX TOO LARGE
          LRD    T3
          LDDL   T2          READ THE CORRESPONDING BUFFER POINTER
          ADC    RR
          ADM    DFTP
          CRDL   T2          : A : R : R : LENGTH :
 MDR30    LDDL   T2+3
          STDL   M1          SAVE LENGTH OF BUFFER
          LRD    T3
          LDD    T2
          STD    M3
          RJM    SMA         SAVE MEMORY ADDRESS
 MDR40    RJM    LRR         RESTORE R-REGISTER
          LDD    M3
          ADD    M2
          LMC    RR          ACTIVATE R-REGISTER
          CRML   NBUF,ON     READ A WORD
          LDC    HBDT+16D    HEX BYTE MEMORY DUMP
          RJM    PRN         DISPLAY THE WORD
          RJM    EOL
          AOD    M2          INCREMENT COUNTER
          SBD    M1          TEST FOR END
          MJN    MDR40       IF MORE TO PROCESS
          LDC    MDR10       GET REPEAT ADDRESS
          LJM    CMDR        RETURN

 MDRM     ASCII  (NO DFT)
          SPACE  4,10
*         COMMON DECKS.


*COPY     CTP$SCI_MDD_DFT_CMDS_COMMON

          OVERFLOW  SCMT     CHECK FOR OVERFLOW
          OVERLAY  (MDD DFT/ECR COMMAND ROUTINES)
 DER      SPACE  4,10
**        DER - DISPLAY DFT ECR ELEMENT.
*
*         USES   M1, M2, M3.
*
*         CALLS  CDV, FEB, LRR, PRN, RWE, SMA, WAS.


 DER      ROUTINE

          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          RJM    CDV
          MJP    CMDE        IF DFT VERSION DOES NOT SUPPORT THIS COMMAND
          LDD    PC          CHECK FOR ELEMENT ID PARAMETER
          LPN    1S1
          ZJP    CMDE        IF NO ELEMENT ID SPECIFIED
 DER10    RJM    RWE         READ FIRST WORD OF DFT ECR RECORD
          RJM    FEB         FIND ELEMENT BUFFER
          STDL   M3          SAVE OFFSET
          LDDL   W4          SAVE BUFFER LENGTH
          STDL   M1
          LDN    0           INITIALIZE OFFSET
          STD    M2
          LDDL   M3
          RJM    SMA         SAVE MEMORY ADDRESS
 DER20    RJM    LRR         RESTORE R-REGISTER
          LDD    M3          GET OFFSET INTO TABLE
          ADD    M2
          LMC    RR
          CRML   NBUF,ON     READ WORD FROM TABLE
          LDC    HMDT+16D    HEX WORD 16 NIBBLES
          RJM    PRN         PRINT WORD
          LDML   DERA,M2     GET LABEL
          RJM    WAS         OUTPUT LABEL WITH EOL
          AOD    M2          INCREMENT TO NEXT WORD
          LMD    M1          TEST FOR END
          NJN    DER20       IF MORE WORDS TO DISPLAY
          LDC    DER10       GET REPEAT ADDRESS
          LJM    CMDR        RETURN


 DERA     BSS    0           TABLE OF LABEL ADDRESSES
          LOC    0
 ECRID    CON    DEID+CRLF   ID/ACTION/REGISTER 1/REGISTER 2
 ECRTH    CON    DETH+CRLF   CORRECTED/UNCORRECTED THRESHOLDS
 ECRM1    CON    DEM1+CRLF   M1 BIT MASK FIELD
 ECRR1    CON    DER1+CRLF   R1 BIT MASK FIELD
 ECRM2    CON    DEM2+CRLF   M2 BIT MASK FIELD
 ECRR2    CON    DER2+CRLF   R2 BIT MASK FIELD
          LOC    *O

 DEID     ASCII  ( ID/Action/Register 1/Register 2)
 DETH     ASCII  ( Corrected/Uncorrected Thresh.)
 DEM1     ASCII  ( M1 Bit Mask Field)
 DER1     ASCII  ( R1 Bit Mask Field)
 DEM2     ASCII  ( M2 Bit Mask Field)
 DER2     ASCII  ( R2 Bit Mask Field)
 SDR      SPACE  4,10
**        SDR - SET DFT PROCESSOR FOR ERROR ACTION.
*
*         USES   CM - CM+3, M3.
*
*         CALLS  CDV, DBC, EBC, EUC, FDP, RWE, SPB.
*
*         MACROS FINDCM, PRINT.


 SDR      ROUTINE

          AOM    OVLP        SET INHIBIT OVERLAY LOAD FLAG
          RJM    FDP         FETCH DFT POINTER
          SBN    2
          ZJN    SDR10       IF DFT WAS VERIFIED
          PRINT  SDRM+CRLF   *DFT NOT VERIFIED*
          LJM    CMDF        RETURN

*         CHECK DFT VERSION.  THE *U* AND *C* PARAMETER OPTIONS ARE VALID ONLY IF
*         THE DFT VERSION IS <= 4.  THE *A* PARAMETER OPTION IS VALID ONLY IF THE
*         DFT VERSION IS >= 5.

 SDR10    LDM    DFTF        PICK UP WHICH FLAG
          STD    M3
          LMN    3           CHECK IF *A* SPECIFIED
          ZJP    SDR60       IF ALL ERRORS SPECIFIED
          LDD    M3          CHECK IF *U* OR *C* SPECIFIED
          SBN    1
          ZJN    SDR20       IF *C* SPECIFIED
          SBN    2-1
          NJN    SDR30       IF *U* NOT SPECIFIED
 SDR20    RJM    CDV         CHECK DFT VERSION
          PJP    CMDE        IF DFT VERSION DOES NOT SUPPORT THIS COMMAND
 SDR30    RJM    SPB         SET PP BOUNDARY
          LDM    DFTR        GET IF ON OR OFF
          NJN    SDR40       IF OFF
          STD    CM+DHSEQ    SET UP FOR *RDSL* INSTRUCTION
          STD    CM+DHRL
          STD    CM+DHLBF
          LDML   FDRT,M3
          STDL   CM+DHFLG    SET APPROPRIATE BIT
          LDM    DFTO
          LMC    RR          ACTIVATE R-REGISTER
          RDSL   CM
          PRINT  FDRM+CRLF   *ERROR HANDLING INACTIVE*
          UJN    SDR50       RETURN

 SDR40    LCN    0           SET UP FOR *RDCL* INSTRUCTION
          STDL   CM+DHSEQ
          STDL   CM+DHRL
          STDL   CM+DHLBF
          LDML   TDRT,M3
          STDL   CM+DHFLG    CLEAR APPROPRIATE BIT
          LDM    DFTO
          LMC    RR          ACTIVATE R-REGISTER
          RDCL   CM
          PRINT  TDRM+CRLF   *ERROR HANDLING ACTIVE*
 SDR50    LJM    CMDF        RETURN

 SDR60    RJM    CDV         CHECK IF DFT VERSION SUPPORTS THIS PARAMETER
          MJP    CMDE        IF DFT VERSION DOES NOT SUPPORT THIS COMMAND
          RJM    EUC         ENSURE UPDATE ERROR CONTROL FLAG CLEAR
          FINDCM ECR
          STDL   CM          SAVE OFFSET
          LDN    3           SKIP HEADER WORDS
          RADL   CM
          RJM    SPB         SET PP BOUNDS
          LDM    DFTR        CHECK ACTION
          NJN    SDR70       IF ACTION = OFF
          LDN    2           SET UP ACTION CODE TO FREEZE ON ANY ERROR
          UJN    SDR80       CONTINUE

 SDR70    LDN    0           SET UP ACTION CODE TO PROCESS ALL ERRORS
 SDR80    STD    M3
 SDR90    LDDL   CM          READ NEXT ECR ELEMENT FIRST WORD
          ADC    RR
          CRDL   W0
          LDDL   W0          CHECK IF ELEMENT SHOULD BE SKIPPED
          LPC    0#FF
          LMN    DFTREID
          ZJN    SDR100      IF THIS ELEMENT SHOULD BE SKIPPED
          LDDL   M3          SET ACTION CODE
          STDL   W0+1
          RJM    DBC         DISABLE BOUNDS CHECKING
          LDDL   CM          REWRITE ECR ELEMENT FIRST WORD
          ADC    RR
          CWDL   W0
          RJM    EBC         ENABLE BOUNDS CHECKING
 SDR100   LDDL   W4          SKIP TO NEXT ELEMENT
          RADL   CM
          SOD    W5          DECREMENT NUMBER OF ELEMENTS
          NJN    SDR90       PROCESS NEXT ECR ELEMENT

*         TELL DFT TO UPDATE ITS COPY OF THE ECR.

          RJM    RWE         READ FIRST WORD OF DFT ECR ELEMENT
          LDN    2           SET UPDATE ERROR CONTROL FLAG
          RAML   W3
          RJM    SPB         SET PP BOUNDS
          LDDL   CM          REWRITE FIRST WORD OF DFT ECR ELEMENT
          ADC    RR
          CWDL   W2
          PRINT  ADRM+CRLF   *ECR UPDATED*
          LJM    CMDF        RETURN

*         SINCE THE *A* OPTION DOES NOT HAVE A CORRESPONDING BIT IN THE DFT
*         CONTROL WORD, NO ENTRIES ARE PROVIDED FOR IT IN THE FOLLOWING TABLE.


 FDRT     CON    2000        TOTAL FREEZE OF DFT
          CON    1000        FREEZE ON CORRECTED ERROR
          CON    400         FREEZE ON UNCORRECTED ERROR
 TDRT     CON    175777      TOTAL THAW OF DFT
          CON    176777      THAW ON CORRECTED ERROR
          CON    177377      THAW ON UNCORRECTED ERROR

 ADRM     ASCII  (ECR updated)
 FDRM     ASCII  (Error handling INACTIVE)
 TDRM     ASCII  (Error handling ACTIVE)
 SDRM     ASCII  (DFT not verified)
 UER      SPACE  4,10
**        UER - UPDATE DFT ECR ELEMENT.
*
*         CALLS  CAC, CDV, DBC, EBC, EUC, FEB, SCV, SPB.


 UER      ROUTINE

          RJM    CDV         CHECK DFT VERSION
          MJP    CMDE        IF DFT VERSION DOES NOT SUPPORT THIS COMMAND
          RJM    EUC         ENSURE UPDATE ERROR CONTROL FLAG CLEAR
          LDD    PC          CHECK FOR ELEMENT ID PARAMETER
          LPN    1S1
          ZJP    CMDE        IF NO ELEMENT ID PARAMETER SPECIFIED
          RJM    FEB         FIND ELEMENT BUFFER
          CRML   ECEB,W4     READ ELEMENT BUFFER

*         PROCESS ACTION CODE PARAMETER.

          LDD    PC
          LPN    1S2
          ZJN    UER10       IF ACTION CODE NOT SPECIFIED
          RJM    CAC         CONVERT ACTION CODE
          STML   ECEB+ECRID*4+1  STORE ACTION CODE
          LDN    1S1+1S2     GET PARAMETER MASK
          LJM    UER50       CHECK FOR MORE PARAMETERS SPECIFIED

*         PROCESS REGISTER 1 PARAMETER.

 UER10    LDD    PC
          LPN    1S3
          ZJN    UER20       IF REGISTER 1 PARAMETER NOT SPECIFIED
          LDD    PC          CHECK FOR REGISTER VALUE PARAMETER
          LPN    1S5
          ZJP    CMDE        IF REGISTER VALUE NOT SPECIFIED
          LDML   UEP1        STORE REGISTER NUMBER
          STML   ECEB+ECRID*4+2
          LDC    ECEB+ECRR1*4  GET REGISTER VALUE STORE ADDRESS
          RJM    SCV         STORE CM WORD VALUE
          LDN    1S1+1S3+1S5 GET PARAMETER MASK
          LJM    UER50       CHECK IF MORE PARAMETERS SPECIFIED

*         PROCESS REGISTER 2 PARAMETER.

 UER20    LDD    PC
          LPN    1S4
          ZJN    UER30       IF REGISTER 2 PARAMETER NOT SPECIFIED
          LDD    PC          CHECK FOR REGISTER VALUE PARAMETER
          LPN    1S5
          ZJP    CMDE        IF REGISTER VALUE NOT SPECIFIED
          LDML   UEP1        STORE REGISTER NUMBER
          STML   ECEB+ECRID*4+3
          LDC    ECEB+ECRR2*4  GET REGISTER VALUE STORE ADDRESS
          RJM    SCV         STORE CM WORD VALUE
          LDN    1S1+1S4+1S5 GET PARAMETER MASK
          UJN    UER50       CHECK IF MORE PARAMETERS SPECIFIED

*         PROCESS MASK 1 PARAMETER.

 UER30    LDD    PC
          LPC    1S6
          ZJN    UER40       IF MASK 1 PARAMETER NOT SPECIFIED
          LDC    ECEB+ECRM1*4  GET MASK 1 STORE ADDRESS
          RJM    SCV         STORE CM WORD VALUE
          LDC    1S1+1S6     GET PARAMETER MASK
          UJN    UER50       CHECK IF MORE PARAMETERS SPECIFIED

*         PROCESS MASK 2 PARAMETER.

 UER40    LDD    PC
          LPC    1S7
          ZJP    CMDE        IF MASK 2 PARAMETER NOT SPECIFIED
          LDC    ECEB+ECRM2*4  GET MASK 2 STORE ADDRESS
          RJM    SCV         STORE CM WORD VALUE
          LDC    1S1+1S7     GET PARAMETER MASK
 UER50    LMD    PC
          NJP    CMDE        IF TOO MANY PARAMETERS SPECIFIED

*         WRITE ELEMENT BUFFER BACK TO CM.

          RJM    SPB         SET PP BOUNDARY
          RJM    DBC         DISABLE BOUNDS CHECKING
          LDDL   CM
          ADC    RR
          CWML   ECEB,W4
          RJM    EBC         ENABLE BOUNDS CHECKING
          LJM    CMDF        RETURN
 WER      SPACE  4,10
**        WER - WRITE DFT ECR ELEMENT.
*
*         EXIT   UPDATE ERROR CONTROL FLAG IN THE ECR HAS BEEN SET.
*
*         CALLS  CDV, EUC, SPB.


 WER      ROUTINE
          RJM    CDV         CHECK DFT VERSION
          MJP    CMDE        IF DFT VERSION DOES NOT SUPPORT THIS COMMAND
          RJM    EUC         ENSURE UPDATE ERROR CONTROL FLAG CLEAR
          RJM    SPB
          LDN    2           SET UPDATE ERROR CONTROL FLAG
          RAML   W3
          LDDL   CM          REWRITE FIRST WORD OF ECR RECORD
          ADC    RR
          CWDL   W2
          PRINT  WERA+CRLF   *ECR UPDATED*
          LJM    CMDF        RETURN

 WERA     ASCII  ( ECR updated)
 CAC      SPACE  4,10
**        CAC - CONVERT ACTION CODE.
*
*         THE ACTION CODE IS ENTERED AS A DECIMAL NUMBER.  HOWEVER, THE PARAMETER
*         CRACKER ACCEPTS IT AS A HEXIDECIMAL NUMBER (ALL PARAMETERS ON A COMMAND
*         ARE ACCEPTED IN A SINGLE FORMAT).  THIS ROUTINE CONVERTS THE ACTION
*         CODE TO AN OCTAL FORMAT AS REQUIRED IN THE ECR RECORD.
*
*         ENTRY  (UEP1) = ACTION CODE PARAMETER IN HEXIDECIMAL FORMAT.
*
*         EXIT   (A) = ACTION CODE IN OCTAL FORMAT.
*
*         USES   T1, T2.


 CAC      SUBR               ENTRY/EXIT
          LDML   UEP1
          STDL   T1
          SHN    -4
          STD    T2          NUMBER OF 6'S TO SUBTRACT FOR CONVERSION
          ZJN    CAC20       IF NO CONVERSION NEEDED
 CAC10    LCN    6
          RADL   T1
          SOD    T2
          ZJN    CAC20       IF CONVERSION COMPLETE
          UJN    CAC10       CONTINUE

 CAC20    LDDL   T1          GET OCTAL NUMBER
          UJN    CACX        RETURN
 CDV      SPACE  4,10
**        CDV - CHECK DFT VERSION.
*
*         EXIT   (A) >= 0 IF RUNNING VERSION >= 5.
*
*         CALLS  FDP.


 CDV      SUBR               ENTRY/EXIT
          RJM    FDP         FETCH DFT POINTER
          NJN    CDV10       IF DFT BLOCK EXISTS
          PRINT  RWEA+CRLF   *NO DFT*
          LJM    CMDF        RETURN

 CDV10    LDDL   W0+1        CHECK DFT VERSION LEVEL
          SHN    -8D
          SBN    5
          UJN    CDVX        RETURN
 DBC      SPACE  4,10
**        DBC - DISABLE BOUNDS CHECKING.
*
*         ENTRY  MEMORY BOUNDS ENABLED ON CERTAIN PORTS.
*
*         EXIT   MEMORY BOUNDS CHECKING DISABLED ON ALL PORTS.
*                (M1) = SAVED PORT SELECT VALUE.
*                MAINTENANCE REGISTER INTERLOCKED.
*
*         CALLS  RMR.
*
*         MACROS LOCKMR, READMR, WRITMR.


 DBC      SUBR               ENTRY/EXIT
          LOCKMR SET
          LDM    S0FLG
          NJP    DBC10       IF S0/S0E
          LDK    MBRG
          STD    RN
          LDM    ELCM
          RJM    RMR         READ MEMORY BOUNDS REGISTER
          LDM    RDATA
          STD    M1          SAVE PORT SELECT
          LDN    0
          STM    RDATA       DISABLE ALL PORTS
          WRITMR RDATA,ELCM
          LJM    DBCX        RETURN

 DBC10    LDC    S0MBD       INITIALIZE REGISTER LOOP
          STD    RN
 DBC20    READMR RDATA,ELCM  READ NEXT REGISTER
          LDM    RDATA+2
          LPN    1
          SHN    5
          STD    M1          SAVE BIT 23
          LDM    RDATA+2
          SCN    1           CLEAR BIT 23
          STM    RDATA+2
          LDM    RDATA+3
          SHN    -3
          RAD    M1          ADD BITS 24 - 28 TO SAVED SELECT BITS
          LDM    RDATA+3
          LPN    7           CLEAR BITS 24 - 28
          STM    RDATA+3
          WRITMR RDATA,ELCM  REWRITE REGISTER
          AOD    RN          ADVANCE TO NEXT REGISTER
          LMC    S0MBD+0#10
          NJP    DBC20       IF MORE BOUNDS REGISTERS TO PROCESS
          LJM    DBCX        RETURN
 EBC      SPACE  4,10
**        EBC - ENABLE BOUNDS CHECKING
*
*         ENTRY  MEMORY BOUNDS DISABLED.
*                (M1) = SAVED PORT SELECT.
*                MAINTENANCE REGISTER INTERLOCKED.
*
*         EXIT   MEMORY BOUNDS RESTORED TO PREVIOUS VALUE.
*                MAINTENANCE REGISTER INTERLOCK CLEARED.
*
*         MACROS LOCKMR, READMR, WRITMR.


 EBC      SUBR               ENTRY/EXIT
          LDM    S0FLG
          NJP    EBC10       IF S0/S0E
          LDK    MBRG
          STD    RN
          LDM    ELCM
          RJM    RMR         READ MEMORY BOUNDS REGISTER
          LDD    M1
          STM    RDATA       RESTORE PORT SELECT
          WRITMR RDATA,ELCM
          LJM    EBC30       RELEASE INTERLOCK

 EBC10    LDC    S0MBD       INITIALIZE REGISTER LOOP
          STD    RN

*         NOTE - CODE ASSUMES THAT PORT SELECT IS IDENTICAL FOR ALL.

 EBC20    READMR RDATA,ELCM  READ NEXT REGISTER
          LDD    M1          GET PORT ENABLE BITS
          SHN    -5
          RAM    RDATA+2     RESTORE BIT 23
          LDM    RDATA+3
          LPN    7           ENSURE CLEAR
          STM    RDATA+3
          LDD    M1          GET ENABLE BITS
          LPN    0#1F        JUST 24 - 28
          SHN    3           POSITION
          RAM    RDATA+3     RESTORE BITS
          WRITMR RDATA,ELCM
          AOD    RN          ADVANCE TO NEXT REGISTER
          LMC    S0MBD+0#10
          NJP    EBC20       IF MORE BOUNDS REGISTERS TO PROCESS
 EBC30    LOCKMR CLEAR       RELEASE INTERLOCK
          LJM    EBCX        RETURN
 EUC      SPACE  4,10
**        EUC - ENSURE UPDATE ERROR CONTROL FLAG CLEAR.
*
*         EXIT   UPDATE ERROR CONTROL FLAG CLEAR.
*
*         CALLS  RWE.


 EUC      SUBR               ENTRY/EXIT
          RJM    RWE         READ FIRST WORD OF DFT ECR RECORD
          LDDL   W3          CHECK UPDATE FLAG
          LPN    2
          ZJN    EUCX        IF UPDATE FLAG CLEAR
          LJM    CMDE        RETURN ERROR
 FEB      SPACE  4,10
**        FEB - FIND ELEMENT BUFFER.
*
*         ENTRY  (ECEI) = ELEMENT ID PARAMETER.
*                (W4) = ELEMENT SIZE.
*                (W5) = NUMBER OF ELEMENTS.
*
*         EXIT   (A + R-REGISTER) = CM ADDRESS OF ELEMENT FIRST WORD.
*                (CM) = R-REGISTER OFFSET.
*                (W4) = ELEMENT SIZE.
*                TO *CMDF* IF ELEMENT NOT FOUND.
*                TO *CMDE* IF ELEMENT ID = DFTREID.
*
*         USES   W5, W0 - W3.
*
*         MACROS FINDCM.


 FEB      SUBR               ENTRY/EXIT
          LDML   ECEI
          LMN    DFTREID
          ZJP    CMDE        IF ELEMENT MAY NOT BE CHANGED
          FINDCM ECR         FIND ECR WITHIN THE CIP DIRECTORY
          STDL   CM          SAVE OFFSET
          LDN    3           SKIP HEADER WORDS
          RADL   CM

*         LOOP UNTIL ELEMENT FOUND OR END OF TABLE.

 FEB20    LDDL   CM
          ADC    RR
          CRDL   W0
          LDDL   W0          COMPARE ID'S
          LPC    0#FF
          LMM    ECEI
          ZJN    FEB30       IF ELEMENT FOUND
          LDDL   W4          ADVANCE TO NEXT ELEMENT
          RADL   CM
          SODL   W5          DECREMENT NUMBER OF ELEMENTS
          NJN    FEB20       IF MORE ELEMENTS TO CHECK
          PRINT  FEBB+CRLF   *ELEMENT ID NOT FOUND*
          LJM    CMDF        RETURN

*         SET UP THE ELEMENT ADDRESS.

 FEB30    LDDL   CM
          ADC    RR
          LJM    FEBX        RETURN
 FEBB     ASCII  (ELEMENT ID NOT FOUND)
 ECEB     SPACE  4,10
**        ECEB - ECR ELEMENT BUFFER.


 ECEB     BSS    ECRES       ECR ELEMENT BUFFER
 RWE      SPACE  4,10
**        RWE - READ FIRST WORD OF DFT ECR RECORD.
*
*         EXIT   (CM - CM+3) = DFT ECR POINTER.
*                (W2 - W5) = FIRST WORD OF DFT ECR RECORD.
*
*         CALLS  FDP.


 RWE      SUBR               ENTRY/EXIT
          RJM    FDP         FETCH DFT POINTER
          NJN    RWE10       IF DFT BLOCK EXISTS
          PRINT  RWEA+CRLF   *NO DFT*
          LJM    CMDF        RETURN

 RWE10    LRD    DP          SET R-REGISTER TO DFT BLOCK
          LDM    DFTO        READ ECR POINTER
          ADC    RR+ECRP
          CRDL   CM          : A : R : R : LENGTH :
          LRD    CM+1        READ FIRST WORD OF ECR
          LDDL   CM
          ADC    RR
          CRDL   W2          (W4) = ENTRY SIZE, (W5) = NUMBER OF ELEMENTS
          UJN    RWEX        RETURN

 RWEA     ASCII  (NO DFT)
 SCV      SPACE  4,10
**        SCV - STORE CM WORD VALUE.
*
*         ENTRY  (A) = FIRST PP WORD ADDRESS AT WHICH TO STORE.
*                (UEP2 - UEP2+3) = CM WORD TO STORE.
*
*         USES   T1.
*
*         MACROS STILAO.


 SCV      SUBR               ENTRY/EXIT
          STDL   T1          SAVE BYTE ADDRESS
          LDML   UEP2        STORE CM WORD
          STILAO T1
          LDML   UEP2+1
          STILAO T1
          LDML   UEP2+2
          STILAO T1
          LDML   UEP2+3
          STILAO T1
          UJN    SCVX        RETURN
          SPACE  4,10
*         COMMON DECKS.


*COPY     CTP$SCI_MDD_DFT_CMDS_COMMON

          OVERFLOW  SCMT     CHECK FOR OVERFLOW
          OVERLAY  (MDD *BYE* COMMAND)
 BYE      SPACE  4,10
**        BYE - RETURN MDD PP.
*
*         EXIT   TO *CMDE* IF COMMAND ILLEGAL.
*                TO *RCP* IF NEED TO RELOAD C170 PP RESIDENT.
*                *D8WC* IN EICB UPDATED WITH OVERLAY, CM/MR WRITE COUNTERS.
*
*         USES   T1, CM - CM+3, W0 - W0+3.
*
*         CALLS  CMP, CSI, CTP, IIB, SPB.


 BYE      ROUTINE

          LRD    IB+1        SET UP R-REGISTER
          RJM    SPB         SET PP BOUNDARY

*         WRITE OVERLAY LOAD, CM WRITE, MR WRITE COUNTERS TO *D8WC*.

          LDN    0           CLEAR UNUSED BITS (0 - 15)
          STDL   CM
          LDML   OVLS        REPORT OVERLAY LOADS
          STDL   CM+1
          LDML   CMWC        REPORT CM WRITES
          STDL   CM+2
          LDML   MRWC        REPORT MR WRITES
          STDL   CM+3
          LDN    D8WC        WRITE COUNTERS TO EICB
          RJM    IIB
          CWDL   CM

*         THE BYE COMMAND IS ILLEGAL IF *MDD* WAS INITIATED AT CTI TIME.

          LDN    D7RS        GET SAVE AREA FWA
          RJM    IIB
          CRDL   W0
          LDDL   W0+1
          SHN    21-17
          PJN    BYE10       IF NOT CTI TIME INITIATED
 BYE5     LJM    CMDE        COMMAND ILLEGAL

*         IF THERE IS NO PARAMETER TABLE DEFINED, THEN THIS COPY OF *SCI* IS
*         RUNNING FOR 170 *MDD* MODE ONLY OR FOR CTI/*MDD* (IN THE CASE OF AN
*         OLD VERSION OF THE C170 OS).  IF RUNNING FOR 170 *MDD* MODE, CLEAR
*         THE TWO PORT MUX RESERVES AND RELOAD THE 170 PP RESIDENT.  IF RUNNING
*         FOR CTI/*MDD*, THE COMMAND IS ILLEGAL.

 BYE10    LDD    SB
          ADD    SB+1
          ZJN    BYE15       IF PARAMETER TABLE NOT DEFINED

*         IF *SCD* MODE IS ACTIVE ON THE SAME PORT, SIMPLY DEACTIVATE *MDD* MODE.
*         IF *SCD* MODE IS ACTIVE ON THE OTHER PORT, CLEAR PORT RESERVES AND
*         DEACTIVATE *MDD* MODE.  IF *SCD* MODE NOT ACTIVE, CLEAR PORT RESERVES,
*         DEACTIVATE *MDD* AND RELOAD PP RESIDENT.

          LDM    SCMT+PTDB.
          NJN    BYE20       IF *SCD* MODE ACTIVE
*         LDN    0           CLEAR PP NUMBER
          RJM    CMP         CLEAR *MDD* DATA IN *SCI* PARAMETER TABLE
 BYE15    RJM    CSI         CHECK C170 PP RESIDENT SAVE AREA INTERLOCK
          NJN    BYE5        IF THIS PP DOES NOT HOLD THE INTERLOCK
          RJM    CTP         CLEAR RESERVES
          LJM    RCP         RELOAD PP RESIDENT

 BYE20    LPN    1           ISOLATE *SCD* PORT NUMBER
          STD    T1
          LDM    MDMT+PTDB.  COMPARE *SCD* AND *MDD* PORTS
          LPN    1
          LMD    T1
          ZJN    BYE25       IF *SCD* AND *MDD* ON THE SAME PORT
          RJM    CTP         CLEAR TWO PORT MUX RESERVE
 BYE25    LDN    1           DO NOT CLEAR PP NUMBER
          RJM    CMP         CLEAR *MDD* DATA IN *SCI* PARAMETER TABLE
          LJM    CMDF        RETURN
 PHD      SPACE  4,10
**        PHD - PRINT HEADER.
*
*         SETS UP THE TERMINAL FOR MDD USE.
*
*         EXIT   (MDMT+RTNP.) = *MDD*.
*
*         CALLS  DLY, SCF.
*
*         MACROS PRINT.


 PHD      ROUTINE

          LDN    MX          RESERVE CHANNEL 15
          RJM    SCF
          LDM    MDMT+PTDB.  GET PORT NUMBER
          LPN    1
          ADC    MXPT        ADD IN PORT SELECT FUNCTION
          STM    PHDA
          PSN                NEED ON S0/S0E
          FNC    MXPT+0,MX   SELECT DESIRED PORT
 PHDA     EQU    *-1
          FNC    MXSS,MX     GET PORT STATUS
          ACN    MX
          IAN    MX
          DCN    MX
          SHN    21-DSRB     CHECK DATA SET READY
          MJN    PHD1        IF DATA SET READY
          FNC    MXDR+1,MX   SET DATA TERMINAL READY
          AJM    *,MX        WAIT FOR FUNCTION COMPLETE
          LDC    1000D       DELAY FOR 1 SECOND, NEEDED FOR PC CONSOLE
          RJM    DLY
 PHD1     FNC    MXDM,MX     DESELECT PORT
          AJM    *,MX        WAIT FOR FUNCTION COMPLETE
          CCF    *,MX        RELEASE TPM
          AOM    OVLP        INHIBIT OVERLAY RELOAD
          PRINT  PHDB+CRLF   OUTPUT TERMINAL SETUP AND FIRST TITLE LINE
          PRINT  PHDC+CRLF   OUTPUT SECOND TITLE LINE
          LDN    0
          STM    OVLP        ALLOW OVERLAY RELOAD
          LDC    MDD
          STI    PT          PUT MAIN ROUTINE ADDRESS IN RTNP.
          LJM    SMPX        RETURN

 PHDB     CON    0#0D0D      TERMINATE ANY MULTIPLE CODE
          CON    0#1E33      DISABLE HOST LOADED CODE
          CON    0#1E12      80 CHARACTER LINE
          CON    0#4812      SCROLLING MODE
          CON    0#180C      CLEAR SCREEN (FOR CDC721 AND CDC751)
          ASCII  (SCI/MDD - Level "SCILVL")
 PHDC     ASCII  (COPYRIGHT CONTROL DATA SYSTEMS INC. 1992)
 CMP      SPACE  4,10
**        CMP - CLEAR *MDD* DATA IN *SCI* PARAMETER TABLE.
*
*         ENTRY  (A) = 0 IF PP NUMBER SHOULD BE CLEARED.
*                OS BOUNDS SET TO LOWER PP.
*
*         EXIT   *MDD* DATA IN PARAMETER TABLE CLEARED.
*
*         USES   CM - CM+3.
*
*         CALLS  GSI.


 CMP      SUBR               ENTRY/EXIT
          NJN    CMP1        IF PP NUMBER NOT TO BE CLEARED
          LDC    0#C0F       MASK TO CLEAR PP NUMBER
          STM    CMPA
 CMP1     RJM    GSI         GET PARAMETER TABLE INTERLOCK
          LDDL   CM+1        SET CHANGED FLAG
          LPC    0#AFFF
 CMPA     EQU    *-1
*         LPC    0#AC0F      (CLEAR PP NUMBER TOO)
          LMC    0#4000
          STDL   CM+1
          LDN    0           CLEAR *MDD* DATA
          STDL   CM+3
          LDM    SBAO
          LMC    RR
          CWDL   CM          CLEAR DATA AND INTERLOCK
          UJN    CMPX        RETURN
 CSI      SPACE  4,10
**        CSI - CHECK C170 PP RESIDENT SAVE AREA INTERLOCK.
*
*         ENTRY  (W0 - W0+3) = *D7RS*.
*
*         EXIT   (A) = 0 IF THIS PP HOLDS THE SAVE AREA INTERLOCK.


 CSI1     LDN    1

 CSI      SUBR               ENTRY/EXIT
          LDDL   W0+1
          SHN    21-15
          PJN    CSI1        IF NOT C170 *MDD* MODE
          SHN    0-4-21+15   ISOLATE PP NUMBER
          LPN    77
          SBM    PPNO        COMPARE WITH *SCI* PP NUMBER
          UJN    CSIX        RETURN
 CTP      SPACE  4,10
**        CTP - CLEAR TWO PORT MUX RESERVES.
*
*         EXIT   PORT RESERVE CLEARED.
*                PORT ACCESS CLEARED IF NO OTHER PORT REQUEST WAITING.
*
*         USES   T6.
*
*         CALLS  RTR, SCF.
*
*         MACROS LOCKMR, WRITMR.


 CTP      SUBR               ENTRY/EXIT
          LDM    PTDB.,PT    GET PORT NUMBER
          LPN    1
          STD    T6
          LMC    SHNI        SET UP SHIFT INSTRUCTIONS
          STM    CTPB
          LMN    77
          STM    CTPA
          LDN    MX          RESERVE CHANNEL 15
          RJM    SCF
          LOCKMR SET
          RJM    RTR         READ TEST MODE REGISTER
          SHN    **          PORT 0 BEING USED
 CTPA     EQU    *-1
*         SHN    -1          (PORT 1 BEING USED)
          LPN    24
          NJN    CTP1        IF SOMEONE ELSE WAITING

*         CLEAR PORT ACCESS.

          LDD    T6          SELECT PORT
          ADC    MXPT
          FAN    MX
          FNC    MXMC,MX     MASTER CLEAR PORT
          FNC    MXDR,MX     CLEAR DATA TERMINAL READY
          AJM    *,MX        IF FUNCTION NOT COMPLETE
          FNC    MXRTS,MX    CLEAR REQUEST TO SEND
          AJM    *,MX        IF FUNCTION NOT COMPLETE
          FNC    MXDM,MX     DESELECT MULTIPLEXOR
          AJM    *,MX        IF FUNCTION NOT COMPLETE
 CTP1     CCF    *,MX

*         CLEAR RESERVED, REQUESTED AND REREQUESTED BITS IN A0.

          LDML   PTDB.,PT    CLEAR PORT ATTACHED
          STM    PTDB.,PT
          LDN    25          FORM SELECTIVE CLEAR MASK
          SHN    0           PORT 0
 CTPB     EQU    *-1
*         SHN    1           (PORT 1)
          ADC    SCNI
          STM    CTPC
          LDM    RDATA+7
 CTPC     SCN    **
          STM    RDATA+7
          WRITMR RDATA,ELIO,ITMR
          LOCKMR CLEAR
          LDML   EMC0,T6     CLEAR PORT ATTACHED FLAG
          STM    EMC0,T6
          LJM    CTPX        RETURN
*COPY     CTP$SCI_DELAY_ROUTINE
 RCP      SPACE  4,10
**        RCP - RELOAD C170 PP RESIDENT.
*
*         EXIT   EXECUTION IS TRANSFERRED TO THE ADDRESS AT LOCATION 0
*                OF THE SAVED PP RESIDENT.
*
*         USES   CM, W0 - W0+3.
*
*         CALLS  STA.


 RCP      ROUTINE

          LDN    D7RS
          RJM    IIB
          CRDL   W0
          LDDL   W1          GET PP RESIDENT LENGTH
          LPN    17
          SHN    21-3
          STDL   CM
          LDDL   W2
          SHN    -8D
          RADL   CM
          LDDL   W2          ISOLATE SAVE AREA FWA
          LPC    377
          STDL   W2
          RJM    STA         CONVERT ADDRESS TO R-POINTER
          RJM    SPB         ENSURE THIS IS A LOWER PP
          LDD    W6
          ADC    RR
          CRM    0,CM        LOAD PP RESIDENT

          OVERFLOW  SCMT     CHECK FOR OVERFLOW

          ENDX
*DECK DECK=CTI$SCI_MDD_RESIDENT_CODE EXPAND=FALSE
          CTEXT  SCI MDD RESIDENT CODE
          OVERLAY  (MDD RESIDENT OVERLAY),OVLM
 MDDSI    SPACE  4,10
**        MDD ROUTINE LIST.


 MDDSI    ROUTINE

          LOC    0
 S.LCW    CON    MDDINI      INITIALIZE CONSOLE FOR *MDD* MODE AND PRINT HEADER
 S.WFK    CON    MDD
 S.NIO    CON    MDD
 S.PIO    CON    MDD
          LOC    *O
          QUAL   *
 MDD      SPACE  4,10
**        MDD - MAINTENANCE DISPLAY DRIVER IDLE LOOP.
*
*         ENTRY  (RFLG) = REPEAT FLAG.
*                (RDLY) = REMAINING TIME UNTIL REPEAT.
*                (CMDB) = COMMAND ADDRESS.
*                (CPOP) = NUMBER OF CHARACTERS OUTPUT SO FAR.
*
*         EXITS  TO *SMPX* IF LAST OUTPUT NOT COMPLETE OR NOTHING TO DO.
*                TO *CMD* IF A CARRIAGE RETURN HAS BEEN PROCESSED.
*                TO LAST ROUTINE IF REPEAT IS SET AND HAVE TIMED OUT.
*
*         USES   BA, BP.
*
*         CALLS  CMC, PRI.


 MDDINI   CALL   PHD         SET UP SCREEN AND ISSUE COPYRIGHT NOTICE

 MDD      LDML   CPOP        GET NUMBER OF CHARACTERS OUTPUT SO FAR
          RAD    BA          SET FOR PREVIOUS CHARACTERS ECHOED BY MDD
          LDM    MDMT+CHRC.
          ZJN    MDD2        IF LAST OUTPUT ALL SENT
 MDD1     LJM    SMPX        ELSE WAIT FOR OUTPUT COMPLETION

 MDD2     LDML   CPOP        GET NUMBER OF CHARACTERS OUTPUT SO FAR
          RAD    BP          UPDATE BP ACCORDINGLY
          SHN    -14         CHECK FOR COMPLETED LINE
          ZJN    MDD3        IF A CARRIAGE RETURN HAS NOT BEEN PROCESSED
          LJM    CMD         PROCESS THE NEW COMMAND

 MDD3     RJM    PRI         ELSE CHECK FOR INPUT
          LDM    CPOP        TEST FOR NEW INPUT
          NJN    MDD1        IF WAITING FOR COMMAND TO COMPLETE
          LDM    RFLG        TEST FOR REPEAT DISPLAY
          ZJN    MDD1        IF REPEAT NOT SET
          LDM    CMDB        TEST FOR A COMMAND TO DO
          ZJN    MDD1        IF NOTHING TO DO
          SOML   RDLY
          NJN    MDD1        IF NOT TIME YET
          LDML   MDDR        RESET DELAY
          STML   RDLY
          LDN    0#19        HOME CURSOR
          STIAO  BP
          LJM    CMD3        REPEAT CALL TO ROUTINE
 MDER     SPACE  4,10
**        MDER - PROCESS MR ERROR IN *MDD* MODE.
*
*         ENTRY  FATAL OR NON-FATAL MR ERROR OCCURRED IN *MDD* MODE.
*                CHANNEL 17 STATUS (ACTIVE, CHANNEL FLAG) UNKNOWN.
*
*         EXIT   MESSAGE ISSUED.
*                CHANNEL 17 INACTIVE AND FLAG CLEAR.


 MDER     FCJM   MDER1,MR    IF CHANNEL FLAG CLEAR, NO CLEANUP REQUIRED

*         THIS ASSUMES THAT IF THE CHANNEL FLAG IS SET, *SCI* MUST BE
*         THE LOGICAL OWNER OF THE CHANNEL.  THERE IS A VERY SMALL
*         TIMING WINDOW IN WHICH *SCI* COULD HAVE CLEARED THE FLAG,
*         BRANCHED TO *MDER*, AND IN THE MEANTIME ANOTHER PP ACQUIRED
*         THE CHANNEL FLAG.  WITHOUT MAKING CHANGES TO COMMON DECK
*         *DSI$MAINTENANCE_REGISTER_ACCESS* TO GUARANTEE THAT CHANNEL 17
*         IS ALWAYS IN A KNOWN STATE, THIS WINDOW IS INEVITABLE.  SUCH
*         CHANGES WOULD BE UNWISE, SINCE IN THE CASE OF A MR ERROR IT
*         IS DESIRABLE TO PRESERVE CONDITIONS AS MUCH AS POSSIBLE.

          DCN    MR+40       CLEAN UP CHANNEL STATUS
          CCF    *,MR        RELEASE CHANNEL FLAG
 MDER1    PRINT  MDERA+CRLF  *MR ERROR*
          LJM    MDD         RESUME *MDD* MODE

 MDERA    ASCII  (MR ERROR)
          EJECT
 ASN      SPACE  4,10
**        ASN - ASSEMBLE NAME.
*
*         ENTRY  (BP) = NEXT CHARACTER IN LINE.
*
*         EXIT   (BP) = POSITIONED AFTER NAME.
*
*         CALLS  GAC, SKP.


 ASN      SUBR               ENTRY/EXIT
          RJM    SKP         SKIP DELIMITERS
          ZJN    ASNX        RETURN IF EOLN
          RJM    GAC         GET ALPHABETIC CHARACTER
          MJN    ASNX        IF NOT ALPHABETIC
          SHN    6
          STM    ASNA        STORE IN BUFFER
          RJM    GAC         GET ALPHABETIC CHARACTER
          MJN    ASNX        IF NOT ALPHABETIC
          RAM    ASNA
 ASN1     RJM    GAC         THROW AWAY REST OF NAME
          MJN    ASNX
          UJN    ASN1        IF NOT DONE

 ASNA     BSS    1
 CFI      SPACE  4,10
**        CFI - CHECK FOR INCREMENT.
*
*         ENTRY  (BP) = FIRST CHARACTER.
*                (VAL3 - VAL3+2) = 0.
*
*         EXIT   (A) = 0, IF INCREMENT COMMAND OR EMPTY LINE.
*                (VAL3 - VAL3+2) = INCREMENT VALUE.
*
*         USES   T0.
*
*         CALLS  DNV, SKP.


 CFI      SUBR               ENTRY/EXIT
          RJM    SKP         SKIP LEADING BLANKS
          ZJN    CFIX        IF ENTIRE LINE IS BLANK
          LDI    BP          CHECK NEXT CHARACTER
          SBN    1R+
          STD    T0
          ZJN    CFI1        IF PLUS
          SBN    1R--1R+
          NJN    CFIX        IF NOT MINUS
 CFI1     AOD    BP          ADVANCE CHARACTER COUNT
          LDM    VAL4        PREVIOUS DECODE TYPE
          LPN    7
          SHN    14
          LMN    2
          RJM    DNV         DECODE UP TO 24 BITS
          ZJN    CFI1.5      IF NO VALUE SPECIFIED
          LDM    VAL4
          LPN    40
          ZJN    CFI2        IF WORD ADDRESS
          LDM    ABUF-1      CHANGE BYTE COUNT TO WORD COUNT
          SHN    21-2
          STM    ABUF-1
          SHN    2-21
          SHN    14
          LMM    ABUF
          SHN    -3
          STM    ABUF
          UJN    CFI2

 CFI1.5   LDM    VAL2        USE DISPLAY COUNT
          STM    ABUF
 CFI2     LDD    T0          INCREMENT/DECREMENT FLAG
          ZJN    CFI3        IF INCREMENT
          LCN    0
          STM    VAL3
          LMM    ABUF-1      COMPLEMENT UPPER PART
          STD    T1
          LDC    7777
          LMM    ABUF
          ADN    1           FORM TWOS COMPLEMENT
          STM    ABUF
          SHN    -14
          ADD    T1
          STM    ABUF-1
 CFI3     LDM    ABUF        SET INCREMENT VALUE
          STM    VAL3+2
          LDM    ABUF-1
          STM    VAL3+1
          LDN    0
          LJM    CFIX        RETURN
 CLB      SPACE  4,10
**        CLB - CLEAR BUFFER.
*
*         EXIT   (ABUF) = 0.
*                (MRBF - MRBF+6) = 0.
*                (NBUF - NBUF+7) = 0.
*
*         USES   T2.


 CLB      SUBR               ENTRY/EXIT
          LDN    10          CLEAR *NBUF* AND *ABUF*
          ERRNZ  ABUF-NBUF-10  CHANGE CODE IF BUFFERS CHANGE
          STD    T2
 CLB10    LDN    0
          STM    NBUF,T2     CLEAR BUFFER ENTRY
          SOD    T2
          PJN    CLB10       IF MORE BUFFER TO CLEAR
          LDN    6           CLEAR *MRBF - MRBF+6*
          STD    T2
 CLB20    LDN    0
          STM    MRBF,T2     CLEAR BUFFER ENTRY
          SOD    T2
          PJN    CLB20       IF MORE BUFFER TO CLEAR
          UJN    CLBX        RETURN
 CLC      SPACE  4,15
**        CLC - CLASSIFY CHARACTER.
*
*         ENTRY  (BP) = ADDRESS OF NEXT CHARACTER IN LINE.
*
*         EXIT   (A) = CHARACTER TYPE:
*                      0 = END OF LINE.
*                      1 = CONTROL.
*                      2 = EQUALS SIGN.
*                      3 = NUMERIC.
*                      4 = ALPHABETIC.
*                (W6) = UPPERCASE CHARACTER, IF ALPHABETIC.
*                     = BINARY VALUE, IF NUMERIC.
*
*         USES   T1, W6.


 CLC4     AOD    T1          ALPHABETIC
 CLC3     AOD    T1          NUMERIC
 CLC2     AOD    T1          SEPARATOR
 CLC1     AOD    T1          CONTROL CHARACTOR

 CLC      SUBR               ENTRY/EXIT
          LDN    0
          STD    T1          ASSUME (CR)
          LDI    BP          GET THE NEXT CHARACTER
          ZJN    CLCX        IF END OF LINE
          SBN    1R0
          STD    W6          SAVE NUMERIC VALUE
          MJN    CLC1        IF CONTROL CHARACTER
          SBN    10D
          MJN    CLC3        IF NUMBER
          SBN    1R=-1R9-1
          ZJN    CLC2        IF *=*
          SBN    1RA-1R=
          MJN    CLC2        IF SEPARATOR
          LDI    BP          RETRIEVE CHARACTER
          STD    W6
          UJN    CLC4        IT IS ALPHABETIC

 CRSY     EQU    0           END OF LINE SYMBOL
 CCSY     EQU    1           CONTROL CHARACTER SYMBOL
 EQSY     EQU    2           SEPARATER SYMBOL
 NBSY     EQU    3           NUMBER SYMBOL
 ALSY     EQU    4           ALPHABETIC SYMBOL
 CMD      SPACE  4,10
**        CMD - PROCESS COMMAND.
*
*         ENTRY  (BP) = ADDRESS OF NEXT CHARACTER IN LINE.
*
*         EXIT   COMMAND PROCESSED.
*
*         USES   T2, VAL1 - VAL1+1, OVLP.
*
*         CALLS  ASN, CFI, PRM, SFN.
*
*         MACROS PRINT.


 CMD      ROUTINE            ENTRY

          RJM    CFI         CHECK FOR INCREMENT
          ZJP    CMD2        IF INCREMENT OR EMPTY LINE
          LOADOV MDDC        LOAD *MDD* COMMAND SYNTAX OVERLAY
          RJM    ASN         ASSEMBLE NAME

*         DETERMINE COMMAND MASK.

          LDM    S0FLG       CHECK FOR S0/S0E MAINFRAME
          SHN    1
          NJN    CMD0        IF S0/S0E, SET MASK = 2
          LDN    1           SET MASK = 1 FOR ALL OTHER MAINFRAMES
 CMD0     SHN    6           POSITION MASK
          STD    T1
          LDN    5           SET TABLE ENTRY SIZE
          STD    T2

*         SEARCH FOR COMMAND TABLE ENTRY WHICH MATCHES MNEMONIC AND IS
*         VALID ON THIS HARDWARE.

          LDC    CMDS        SET SYNTAX TABLE ADDRESS
 CMD0.1   RJM    SFN         SEARCH FOR NAME
 CMD1     ZJP    CMDE        IF END OF COMMAND TABLE (ILLEGAL COMMAND)
          LPDL   T1
          NJN    CMD1.1      IF COMMAND VALID ON THIS HARDWARE
          LDD    T2          ADVANCE TO NEXT ENTRY
          RAD    T7
          UJN    CMD0.1      CONTINUE SEARCH

 CMD1.1   LDM    1,T7        SAVE PROCESSOR OVERLAY NUMBER
          LPN    77
          STM    CMDA
          LDM    2,T7        SAVE PROCESSOR ADDRESS
          STM    CMDB
          RJM    PRM         DECODE PARAMETER LIST
 CMD2     LDM    CMDB
          ZJN    CMDE        IF NOT REPEATING COMMAND
          LDM    RFLG
          ZJN    CMD3        IF NO REFRESH
          PRINT  CMDI        CLEAR SCREEN
 CMD3     LDM    CMDB        INSERT ADDRESS AND OVERLAY NUMBER
          STM    CMDC+1
          LDM    CMDA
          ADC    LDCI
          STM    CMDC
          PSN                (REQUIRED FOR CYBER 930 PIPELINE)
 CMDC     CALL   0           PROCESS THE COMMAND

 CMDE     PRINT  CMDM+CRLF   ILLEGAL COMMAND

**        ENTRY POINT FROM *SR* COMMAND.

 CMDF     LDN    0           CLEAR REPEAT ADDRESS

 CMDR     STM    CMDB        SET REPEAT DISPLAY ADDRESS
          SHN    -14
          STM    VAL4        SET ADDRESS DECODE
          LDN    0           CLEAR INHIBIT OVERLAY LOAD FLAG
          STM    OVLP
          STM    CPOP        CLEAR CARRIAGE RETURN FLAG IF WEIRD ENTRY
          LDC    MDD
          STI    PT          RESET RTNP.
          LJM    SMPX        RETURN

 CMDI     CON    0#180C      CLEAR SCREEN (FOR 751 AND 721)
          CON    0           END OF LINE
 CMDM     ASCII  (*ILL*)
 CMDFO    EQU    OVLN        EQUATE TO CURRENT OVERLAY NUMBER
 DAT      SPACE  4,10
**        DAT - DISPLAY ASCII TEXT.
*
*         ENTRY  (NBUF - NBUF+3) = CHARACTERS.
*
*         USES   T2.
*
*         CALLS  PAC.


 DAT      SUBR               ENTRY/EXIT
          LDN    0
          STD    T2
 DAT1     LDML   NBUF,T2
          SHN    -10
          RJM    PAC         PRINT UPPER CHARACTER
          LDM    NBUF,T2
          RJM    PAC         PRINT LOWER CHARACTER
          AOD    T2
          LMN    4
          NJN    DAT1        IF MORE TO DISPLAY
          UJN    DATX        RETURN
 DFV      SPACE  4,10
**        DFV - DECODE FLAG VALUES.
*
*         ENTRY  (A) = ADDRESS OF FLAG MEANINGS.
*                (W2) = LEFT JUSTIFIED FLAGS.
*
*         USES   M2.
*
*         CALLS  WAS.
*
*         MACROS PRINT.


 DFV1     RJM    EOL         COMPLETE LINE

 DFV      SUBR               ENTRY/EXIT
          STD    M2
          LDI    M2          DISPLAY HEADER TEXT
          RJM    WAS
 DFV2     AOD    M2          INCREMENT TABLE INDEX
          LDDL   W2          CHECK NEXT BIT
          ZJN    DFV1        IF DONE THEN RETURN
          RADL   W2          RESET BIT LIST
          SHN    21-20       TEST HIGHEST BIT
          PJN    DFV2        IF BIT NOT SET
          LDI    M2          GET ADDRESS OF ASSOCIATED MESSAGE
          ZJN    DFV2        IF NO MESSAGE
          RJM    WAS         WRITE STRING
          PRINT  DFVA
          UJN    DFV2        CHECK NEXT BIT

 DFVA     ASCII  (, )
 DNV      SPACE  4,10
**        DNV - DECODE NUMERIC VALUE.
*
*         ENTRY  (A) = NUMBER LENGTH + 10000*NUMBER TYPE.
*                (BP) = NEXT CHARACTER IN LINE.
*
*         EXIT   (ABUF) = NUMBER.
*
*         USES   T2, T3, T4, T5.
*
*         CALLS  CLB, SKP, TND.


 DNV      SUBR               ENTRY/EXIT
          STD    T5          SAVE NUMBER LENGTH (MAX)
          SHN    -14
          LPN    7
          STD    T2          SET DECODE TYPE
          LDM    DNVC,T2     SET DIGIT MASK
          STM    DNVA
          LDM    DNVD,T2     SET UNPACKING ROUTINE
          STM    DNVB
          RJM    CLB         CLEAR BUFFER
          RJM    SKP         SKIP DELIMITERS
          ZJN    DNVX        IF END OF LINE
          LDD    BP
          STM    MDMT+TEMP.  SAVE CHARACTER
 DNV1     RJM    TND         TRANSLATE NUMERIC DIGIT
          MJN    DNV3        IF NOT NUMBER
          STI    BP          SAVE DIGIT RETURNED
 DNVA     SCN    7           CHECK IF OUT OF RANGE
          NJP    CMDE        IF NUMBER TOO LARGE
          AOD    BP          ADVANCE CHARACTER POSITION
          UJN    DNV1        PROCESS NEXT CHARACTER

 DNV3     LDD    BP
          SBN    1
          STD    T4
          LDC    ABUF
          STD    T3
          SBD    T5
          STD    T5
          LDN    0
          STD    T2
 DNV4     LDI    T4          GET NEXT DIGIT
          LJM    **,T2
 DNVB     EQU    *-1

 DNV5     STD    T2          SAVE BYTE POSITION
          NJN    DNV6        IF CURRENT WORD NOT COMPLETED
          SOD    T3          DECREMENT BUFFER POSITION
          SBD    T5
          MJP    CMDE        IF NUMBER TOO LARGE
 DNV6     SOD    T4
          SBM    MDMT+TEMP.
          PJN    DNV4        IF MORE DIGITS TO ASSEMBLE
          LDIL   T5
          NJP    CMDE        IF NUMBER OVERFLOW
          LDN    1
          LJM    DNVX        RETURN

*         MRNT - MAINTENANCE REGISTER NUMBER TYPE.

 DNV7     SHN    22-4
          SHN    4
          RAI    T3
          AOD    T2
          LPN    1
          UJN    DNV5        CONTINUE

*         OWNT - OCTAL WORD NUMBER TYPE.

 DNV8     SHN    22-3
          SHN    22-3
          SHN    22-3
          SHN    11
          RAI    T3
 DNV9     AOD    T2
          LPN    3
          UJN    DNV5        CONTINUE

*         HWNT - HEX WORD NUMBER TYPE.

 DNV10    SHN    22-4
          SHN    22-4
          SHN    22-4
          SHN    14
          RAIL   T3
          UJN    DNV9        CONTINUE

*         HPNT - HEX PP WORD NUMBER TYPE.

 DNV11    SHN    22-4
          SHN    22-4
          SHN    10
          RAI    T3
          AOD    T2
          SBN    3
          ZJN    DNV9        IF START NEXT WORD
          LJM    DNV6        CONTINUE


 TBLI     SET    0

 MRNT     ENTER  DNV7,SCNI+17  MAINTENANCE REGISTER NUMBER TYPE
 OWNT     ENTER  DNV8,SCNI+7   OCTAL WORD NUMBER TYPE
 HWNT     ENTER  DNV10,SCNI+17 HEX WORD NUMBER TYPE
 HPNT     ENTER  DNV11,SCNI+17 HEX PP WORD NUMBER TYPE

 DNVC     BSS    0           TABLE OF *SCN*-S
 TBLB     HERE
 DNVD     BSS    0           TABLE OF PROCESSOR ADDRESSES
 TBLA     HERE

 OCWD     EQU    OWNT
 HXWD     EQU    HPNT
 HXBT     EQU    HPNT+400000
 DTO      SPACE  4,10
**        DTO - DEADMAN TIMEOUT CHECK.
*
*         ENTRY  (A) = WORD COUNT FROM *READMR*.
*
*         THIS ROUTINE WILL PRINT A DEADMAN
*         TIMEOUT MESSAGE IF (A) IS NON ZERO.


 DTO      SUBR               ENTRY/EXIT
          ZJN    DTOX        IF COMPLETED NORMALLY
          PRINT  DTOM+CRLF
          LJM    CMDF        RETURN FROM COMMAND

 DTOM     ASCII  (DEADMAN TIMEOUT)
 EOL      SPACE  4,10
**        EOL - WRITE END OF LINE.
*
*         EXIT   TO *CKQ* TO PROCESS OUTPUT LINE.
*                TO *CMDF* IF INTERRUPT RECEIVED.
*
*         CALLS  GKC.
*
*         USES   BP.

 EOL      SUBR               ENTRY/EXIT
          LDC    EOL1        SET RETURN ADDRESS INTO RTNP.
          STI    PT
          LDN    CR          ADD CARRIAGE RETURN TO BUFFER
          STIAO  BP
          LDN    LF          ADD LINE FEED TO BUFFER
          STIAO  BP
          LJM    CKQ         COMPLETE OUTPUT AND RETURN TO IDLE LOOP

 EOL1     LDM    MDMT+CHRC.  TEST IF PREVIOUS OUTPUT DONE
          NJP    SMPX        IF OUTPUT IN PROGRESS
          RJM    GKC         CHECK FOR INTERRUPT
          ZJN    EOLX        IF NO INTERRUPT RECEIVED
          LJM    CMDF        TERMINATE CURRENT COMMAND
 GAC      SPACE  4,10
**        GAC - GET ALPHABETIC CHARACTER.
*
*         ENTRY  (BP) = ADDRESS OF THE NEXT CHARACTER.
*
*         EXIT   (A) = CHARACTER (IF ALPHABETIC).
*                (A) = -1 (IF NOT).
*                (BP) = INCREMENTED IF ALPHABETIC CHARACTER.
*
*         CALLS  CLC.


 GAC1     LCN    1           NOT ALPHABETIC CHARACTER

 GAC      SUBR               ENTRY/EXIT
          RJM    CLC         CLASSIFY NEXT CHARACTER
          SBN    ALSY
          NJN    GAC1        IF NOT ALPHABETIC CHARACTER
          AOD    BP
          LDD    W6          GET ALPHABETIC UPPER CASE CHARACTER
          SBN    40
          UJN    GACX        RETURN
 PAC      SPACE  4,10
**        PAC - PRINT ASCII CHARACTER.
*
*         ENTRY  (A) = CHARACTER.


 PAC      SUBR               ENTRY/EXIT
          LPC    0#7F
          SBN    40
          PJN    PAC1        IF PRINTABLE CHARACTER
          LDN    0
 PAC1     ADN    40
          STIAO  BP          PUT CHARACTER IN OUTPUT QUEUE
          UJN    PACX        RETURN
 PRI      SPACE  4,12
**        PRI - PROCESS INPUT STRING.
*
*         EXIT   (BA) = FWA OF STRING.
*                (BP) = LWA OF STRING.
*                (CPOP) = CARRIAGE RETURN FLAG SET IF FOUND.
*                TO *CMDE* IF *ESC* OR BAD CHARACTER TYPED.
*                TO *CKQ* IF INPUT PROCESSED.
*
*         USES   BP.
*
*         CALLS  EOL, GKC.


 PRI      SUBR               ENTRY/EXIT
          RJM    GKC         READ THE NEXT CHARACTER
          ZJN    PRIX        IF NONE THEN RETURN
          STI    BP          ECHO CHARACTER BACK
          SBN    1R
          MJN    PRI5        IF CONTROL CHARACTER
          ZJN    PRI4        IF BLANK
          SBN    1R0-1R
          MJP    PRI7        IF *!* THROUGH */*
          SBN    1R9+1-1R0
          MJN    PRI4        IF *0* THROUGH *9*
          SBN    1R=-1R9-1
          ZJN    PRI4        IF *=*
          SBN    1RA-1R=
          MJN    PRI3        IF OTHER CHARACTER LESS THAN *A*
          SBN    0#60-1RA
          ZJN    PRI3        IF GRAVE ACCENT
          LDI    BP
          LPC    137         CONVERT TO UPPER CASE
          STI    BP
          ADC    -1RZ-1
          MJN    PRI4        IF VALID LOWER CASE CHARACTER
 PRI3     LJM    CMDE        INVALID CHARACTER ENCOUNTERED

 PRI4     AOD    BP          INCREMENT CHARACTER POINTER
          AOM    CPOP        INCREMENT CHARACTERS OUTPUT
          ADC    -72D
          PJN    PRI3        IF LINE TOO LONG RESTART LINE
 PRI40    LJM    CKQ         IF LINE NOT TOO LONG

 PRI5     ADN    1R -CR
          ZJN    PRI9        IF CARRIAGE RETURN
          ADN    CR-BS
          NJN    PRI3        IF NOT BACKSPACE
          AOD    BP          OUTPUT THE BACKSPACE
          SOM    CPOP        DECREMENT CHARACTERS OUTPUT
          PJN    PRI40       IF NOT BACKSPACE BEYOND START OF LINE
          LJM    CMDF        IGNORE INPUT AND RESTART

 PRI7     ADN    1R0-1R-
          ZJN    PRI4        IF *-*
          ADN    1R--1R,
          ZJN    PRI4        IF *,*
          ADN    1R,-1R+
          ZJN    PRI4        IF *+*
          UJN    PRI3        BAD CHARACTER

 PRI9     STIAO  BP          TERMINATE LINE WITH ZERO CHARACTER
          RJM    EOL         SEND CARRIAGE RETURN AND LINE FEED
          LDC    CRLF        SET CARRIAGE RETURN FLAG IN CPOP
          STML   CPOP        LINE NOW ZERO LENGTH
          LDC    MDD
          STI    PT          RESET RTNP.
          LJM    PRIX        RETURN
 PRM      SPACE  4,10
**        PRM - DECODE PARAMETER LIST.
*
*         ENTRY  (T7) = POINTER TO COMMAND ENTRY.
*                KEYBOARD LINE IN *BUF*.
*
*         EXIT   (PC) = PARAMETER COUNT.
*
*         USES  T1 - T7, CM - CM+3, BP.
*
*         CALLS  ASN, DNV, SKP.


 PRM      SUBR               ENTRY/EXIT
          LDM    3,T7        GET PARAMETER LIST
          ZJN    PRMX        IF NO PARAMETER SYNTAX
          STD    CM          SAVE LIST ADRRESS
          STD    CM+1
          LDM    4,T7        GET PARAMETER TYPE
          STD    CM+3
          LDN    1
          STD    PC
 PRM0     LDD    PC          SET PARAMETER UNUSED FLAG
          SHN    14
          LMI    CM+1
          STIL   CM+1
          SHN    -13
          LPN    1
          ADN    2           ADVANCE TO NEXT PARAMETER
          RAD    CM+1
          AOD    PC          INCREMENT PARAMETER NUMBER
          LDI    CM+1        GET NEXT PARAMETER
          NJN    PRM0        ADVANCE THROUGH LIST
          STD    PC          CLEAR PARAMETER COUNT
          LDM    1,CM        GET PARAMETER NAME LIST
          STD    CM+1
          LJM    PRM11       ENTER LOOP

 PRM1     RJM    SKP         CLASSIFY CHARACTER
          SBN    ALSY
          ZJN    PRM3        IF ALPHABETIC
          ADN    ALSY-NBSY
          ZJN    PRM2.6      IF ERROR
 PRM2     LJM    CMDE        PROCESS ERROR

 PRM2.5   LDD    T5          RESET BUF POINTER
          STD    BP
 PRM2.6   LDD    CM          SET CURRENT PARAMETER
          STD    T6
          LDM    1,T6
          STD    T7          SET CURRENT PARAMETER POINTER
          LDI    T6
          SHN    21-13
          MJN    PRM2        IF PARAMETER MUST BE EQUIVALENCED
          UJN    PRM6        IF NUMBER

 PRM3     LDD    BP
          STD    T5
          RJM    ASN         ASSEMBLE NAME
          ZJN    PRM2.5      IF ERROR
          LDN    3
          STD    T2          SET TABLE ENTRY SIZE
          LDD    CM+1
          RJM    SFN         SEARCH FOR NAME
          ZJN    PRM2.5      IF ERROR
          STD    T6          SET NEW PARAMETER POINTER
          LDI    T6
          SHN    21-13
          PJN    PRM4        IF MULTIPLE EQUIVALENCES
          LDM    2,T6        PARAMETER ADDRESS
          STD    T1
          LDM    2,T7        PARAMETER VALUE
          STI    T1          SET PARAMETER
 PRM4     RJM    SKP         SKIP SPACES
          SBN    EQSY
          ZJN    PRM5        IF *=*
          UJN    PRM10       NO VALUE TO BE SET

 PRM5     AOD    BP          INCREMENT PAST *=*
 PRM6     LDI    T6
          LPN    17
          NJN    PRM8        IF CAN BE EQUIVALENCED
 PRM7     UJP    PRM2        PROCESS ERROR

 PRM8     STD    T1
          LDD    CM+3        GET PARAMETER TYPE
          SHN    14
          LMD    T1
          RJM    DNV         DECODE NUMBER
          LDI    T6
          LPN    17
          STD    T1          SET WORD LENGTH
          LDC    ABUF
          SBD    T1
          STD    T3
          LDM    2,T7        SET VARIABLE ADDRESS
          STD    T4
 PRM9     AOD    T3
          LDIL   T3
          STIL   T4
          AOD    T4
          SOD    T1
          NJN    PRM9        IF NOT DONE COPYING
 PRM10    LDIL   T6          CLEAR NOT REFERENCED BIT
          STI    T6
          SHN    -14
          ZJN    PRM7        IF ALREADY USED
          LMC    SHNI
          STM    PRMA
          LDN    1
 PRMA     SHN    **
          RADL   PC          SET USED BIT FOR PARAMETER
          LDI    CM
          SHN    -13
          LPN    1
          ADN    2
          RAD    CM
 PRM11    LDI    CM
          ZJN    PRM13       IF END OF PARAMETER LIST
          RJM    SKP
          ZJN    PRM13       IF END OF INPUT
          LDD    T3
          ZJN    PRM12.5     IF ONE OR NO COMMAS
          SOD    T3
 PRM12    ZJN    PRM12.5
          SOD    T3
          LDI    CM
          SHN    -13
          LPN    1
          ADN    2
          RAD    CM
          LDD    T3
          UJN    PRM12       CHECK FOR MORE COMMAS

 PRM12.5  LJM    PRM1        GO BACK FOR NEXT PARAMETER

 PRM13    LJM    PRMX        RETURN
 PRN      SPACE  4,10
**        PRN - PRINT NUMBER.
*
*         ENTRY  (A) = NUMBER OF DIGITS TO PRINT.
*                (NBUF) = CONTAINS THE NUMBER TO PRINT.
*
*         USES   T2, T3, T4, W6.
*
*         CALLS  WND.


 PRN      SUBR               ENTRY/EXIT
          STD    T4          SET NUMBER OF DIGITS TO OUTPUT
          SHN    -14
          STD    T2
          LDM    PRNB,T2     GET UNPACKING ROUTINE
          STM    PRNA        SET JUMP ADDRESS
          LDN    0           SET STARTING DIGIT FOR UNPACK
          STD    T2
          LDC    NBUF        SET BUFFER POSITION
          STD    T3
 PRN1     LDIL   T3          READ BUFFER VALUE
          LJM    PRN4,T2     UNPACK DIGITS
 PRNA     EQU    *-1

 PRN2     STD    T2          SET NEXT DIGIT POSITION
          NJN    PRN3        IF NO ADVANCE OF POINTER
          AOD    T3
 PRN3     RJM    WND         OUTPUT TO TERMINAL
          SOD    T4          DECREMENT CHARACTER COUNT
          NJN    PRN1        IF MORE DIGITS TO PRINT
          LDN    1R
          STIAO  BP          PUT BLANK IN OUTPUT QUEUE
          UJN    PRNX        RETURN

*         MAINTENANCE REGISTER DIGITS.

 PRN4     SHN    -4          GET UPPER DIGIT
          STD    W6          SAVE VALUE
          LDD    T2
          LMN    1
          UJN    PRN2        CONTINUE PRINT

*         OCTAL MEMORY DIGIT.

 PRN5     SHN    -3          GET UPPER DIGIT
          SHN    -3          GET UPPER MIDDLE DIGIT
          SHN    -3          GET LOWER MIDDLE DIGIT
          LPN    7
 PRN6     STD    W6          SAVE VALUE
          AOD    T2
          LPN    3
          UJN    PRN2        CONTINUE PRINT

*         HEX MEMORY DIGIT.

 PRN7     SHN    -4          GET UPPER DIGIT
          SHN    -4          GET UPPER MIDDLE DIGIT
          SHN    -4          GET LOWER MIDDLE DIGIT
          UJN    PRN6        SAVE VALUE AND ADVANCE POSITION

*         HEX PP DISPLAY TYPE.

 PRN8     SHN    -4
          SHN    -4
          STD    W6
          AOD    T2
          SBN    3
          ZJN    PRN10
 PRN9     LDD    T2
 PRN10    LJM    PRN2        CONTINUE PRINT

*         HEX BYTE DISPLAY TYPE.

 PRN11    SHN    -4
          SHN    -4
          SHN    -4
          STD    W6
          AOD    T2
          LPN    3
          STD    T2
          LPN    1
          ZJN    PRN9        CONTINUE PRINT
          LDN    1R
          STIAO  BP          PUT BLANK IN OUTPUT QUEUE
          UJN    PRN9        CONTINUE PRINT

 TBLI     SET    0

 MRDT     ENTER  PRN4        MAINTENANCE REGISTER DISPLAY TYPE
 OMDT     ENTER  PRN5        OCTAL MEMORY DISPLAY TYPE
 HMDT     ENTER  PRN7        HEX MEMORY DISPLAY TYPE
 HPDT     ENTER  PRN8        HEX PP DISPLAY TYPE
 HBDT     ENTER  PRN11       HEX BYTE DISPLAY TYPE

 PRNB     BSS    0           INDEXED TABLE
 TBLA     HERE
 RBP      SPACE  4,10
**        RBP - RESET BP DIRECT CELL.
*
*         EXIT   (BP) = (BA), IF CARRIAGE RETURN.
*                (CPOP) = 0.


 RBP      SUBR               ENTRY/EXIT
          LDML   CPOP
          SHN    21-14
          PJN    RBPX        IF NO CARRIAGE RETURN
          LDD    BA          ELSE RESET BP
          STD    BP
          LDN    0           RESET CPOP
          STM    CPOP
          UJN    RBPX
 SFN      SPACE  4,10
**        SFN - SEARCH FOR NAME.
*
*         ENTRY  (A) = TABLE ADDRESS.
*                (T2) = ENTRY SIZE.
*
*         EXIT   (A) = WORD 1 OF TABLE ENTRY, IF FOUND.
*                    = 0, IF NO MATCHING ENTRY IN TABLE.
*                (T7) = COMMAND TABLE ENTRY IF FOUND.
*
*         USES   T7.


 SFN      SUBR               ENTRY/EXIT
          SBD    T2          PRE-DECREMENT TABLE INDEX
          STD    T7
 SFN1     LDD    T2          ADVANCE TABLE INDEX
          RAD    T7
          LDI    T7          GET NEXT COMMAND
          ZJN    SFNX        IF END OF TABLE
          LMM    ASNA        COMPARE TO CHARACTERS FROM LINE
          NJN    SFN1        IF NOT YET MATCHING
          LDML   1,T7        RETURN WORD 1 OF TABLE ENTRY
          UJN    SFNX        RETURN
 SKP      SPACE  4,10
**        SKP - SKIP SEPARATORS.
*
*         EXIT   (A) = CHAR TYPE (0 - 4) PER *CLC*.
*                (BP) = NEXT CHARACTER POSITION.
*                (T3) = NUMBER OF COMMAS FOUND.
*
*         USES   T3, BP.
*
*         CALLS  CLC.


 SKP3     RJM    CLC         CLASSIFY CHARACTER

 SKP      SUBR               ENTRY/EXIT
          LDN    0
          STD    T3
 SKP1     LDI    BP
          ZJN    SKPX        IF END OF LINE
          SBN    1R
          NJN    SKP2        IF NOT SPACE
          AOD    BP
          UJN    SKP1        CHECK NEXT CHARACTER

 SKP2     SBN    1R,-1R
          NJN    SKP3        IF NOT COMMA
          AOD    BP
          AOD    T3
          UJN    SKP1        TEST NEXT CHARACTER
 TND      SPACE  4,10
**        TND - TRANSLATE NUMERIC DIGIT.
*
*         ENTRY  (BP) = ADDRESS OF NEXT CHARACTER IN LINE.
*
*         EXIT   (A) = VALUE OF NUMBER (IF PRESENT).
*                    = -1 (IF NOT PRESENT).
*
*         USES   W6.
*
*         CALLS  CLC.


 TND2     LCN    1           IF NOT A NUMBER

 TND      SUBR               ENTRY/EXIT
          RJM    CLC         CLASSIFY CHARACTER
          SBN    NBSY
          ZJN    TND1        IF NUMBER
          SBN    ALSY-NBSY
          NJN    TND2        IF NOT ALPHABETIC
          LCN    1RA-10D     CONVERT LETTER TO NUMBER
 TND1     RAD    W6          RESET W6 TO NUMBER
          UJN    TNDX        RETURN
 WND      SPACE  4,10
**        WND - WRITE NUMERIC DATA.
*
*         ENTRY  (W6) = DATA TO PRINT.


 WND      SUBR               ENTRY/EXIT
          RJM    RBP         RESET BP?
          LDD    W6
          LPN    17          EXTRACT HEX DIGIT
          SBN    10D
          MJN    WND1        IF DECIMAL DIGIT
          ADN    1RA-1R0-10D
 WND1     ADN    1R0+10D     FORM ASCII DIGIT
          STIAO  BP          PUT CHARACTER IN OUTPUT QUEUE
          UJN    WNDX        RETURN
 WAS      SPACE  4,10
**        WAS - WRITE CODED STRING.
*
*         ENTRY (A) = ADDRESS OF STRING TO OUTPUT.
*
*         USES   T3, T4.
*
*         CALLS  EOL, RBP.


 WAS2     LDD    T4
          ZJN    WAS4        IF NO EOLN TO BE PRINTED
 WAS3     RJM    EOL         OUTPUT A CR/LF
          UJN    WASX        RETURN

 WAS4     LDD    BP          GET LENGTH OF STRING SO FAR
          SBD    BA
          SBN    70
          PJN    WAS3        IF MORE THAN 70 CHARACTERS SO FAR

 WAS      SUBR               ENTRY/EXIT
          STD    T3          SAVE STRING ADDRESS
          SHN    -14         SAVE EOLN FLAG
          STD    T4
          RJM    RBP         RESET BP?
 WAS1     LDIL   T3          LOAD TWO CHARACTERS
          SHN    -10
          ZJN    WAS2        IF END OF LINE
          STIAO  BP          PUT CHARACTER IN OUTPUT QUEUE
          LDI    T3
          LPC    177
          ZJN    WAS2        IF END OF LINE
          STIAO  BP          PUT CHARACTER IN OUTPUT QUEUE
          AOD    T3
          UJN    WAS1        PROCESS NEXT TWO BYTES
          SPACE  4
*         THE FOLLOWING BUFFERS ARE USED FOR COMMAND PARAMETER CRACKING AS WELL
*         AS OTHER TEMPORARY USES.  BE AWARE THAT THE TWO BUFFERS MUST BE
*         CONSECUTIVE DUE TO NEGATIVE INDEXING OF *ABUF*.


 NBUF     BSS    10          ASSEMBLY BUFFER
 ABUF     BSS    10          ASSEMBLY BUFFER
          ERRNZ  NBUF+10-ABUF  NEGATIVE INDEXING OF *ABUF*
          SPACE  4
          CODE   N
 MRPC     CON    0
          CON    ELPR        PORT CODE FOR REGISTER DISPLAY
 MRPE     BSS    0           SINGLE REGISTER DISPLAY
 00       MR     ( ),(4,3,2,1,0)
          CON    7777        END OF TABLE
          CODE   *

          OVERFLOW  OVLA     CHECK FOR OVERFLOW

          ENDX
*DECK DECK=CTI$SCI_SCD_COMMON_ROUTINES EXPAND=FALSE
 BPO      SPACE  4,10
**        BPO - BEGIN PRIORITY OUTPUT.
*
*         SAVE SCREEN POSITION AND ISSUE FUNCTION TO TELL THE
*         CONSOLE TO DO THE SAME. PROCESS THE SCREEN SELECT.
*
*         EXIT   TO *SMPX* IF PREVIOUS OUTPUT INCOMPLETE.
*                TO *CKQ* IF FUNCTION ACTED UPON.
*
*         RESETS RTNP.  TO   PCO.
*
*         CALLS  TCD.
*
*         USES   BP.


 BPO      BSS    0
          LDM    SCMT+CHRC.
          ZJN    BPO1        IF MUX IS FREE
          LJM    SMPX        RETURN

 BPO1     LDM    SCMT+XPOS.
          STM    SCMT+SAVE.  SAVE CURRENT X POSITION
          LDM    SCMT+YPOS.
          STM    SCMT+SAVE.+1  SAVE CURRENT Y POSITION
          LDM    SCMT+SCRN.
          STM    SCMT+SAVE.+2  SAVE SCREEN OFFSET
          LDM    SCMT+CMOV.
          STM    SCMT+SAVE.+3  SAVE POSITION CHANGED FLAG
          LDC    PCO         PRIORITY CHANNEL OUTPUT
          STI    PT          INTO RTNP.
          LDN    0#1F
          STIAO  BP          ADD TO CHARACTER QUEUE
          LDML   SCMT+DATA.
          RJM    TCD         TRANSLATE CHANNEL DATA
          LJM    CKQ         UPDATE CHARACTER QUEUE AND RETURN
 PCO      SPACE  4,10
**        PCO - PRIORITY CHANNEL OUTPUT.
*
*         TRANSLATE CHANNEL DATA FOR THE CONSOLE UNTIL A NON-PRIORITY
*         FUNCTION IS FOUND WHEN IT RESTORES THE SCREEN POSITION
*         AND ISSUES A FUNCTION TO TELL THE CONSOLE TO DO THE SAME.
*
*         EXIT   TO *SMPX* IF CHARACTERS TO BE OUTPUT.
*                TO *TFN* IF VALID FUNCTION FOUND.
*
*         USES   BP.
*
*         CALLS  TCD.


 PCO      BSS    0           PRIORITY CHANNEL OUTPUT
          LDM    SCMT+CHRC.
          ZJN    PCO0        IF MUX IS FREE
          LJM    SMPX        RETURN

 PCO0     LDM    SCMT+NCCH.  ADJUST CHANNEL NUMBER
          STD    T0
          LMC    TSJMI
          STML   PCO1
          LDD    T0
          LMC    EJMI
          STM    PCOB
          LDD    T0
          LMC    IANI
          STM    PCOC
 PCO1     FSJM   SMPX,CH     IF CHANNEL NOT FREE
 PCOB     EJM    SMPX,CH     IF NO DATA ON CHANNEL
 PCOC     IAN    CH
          STML   SCMT+TEMP.  SAVE CHANNEL DATA
          SHN    21-17
          MJN    PCO3        IF 7000 FUNCTION
 PCO2     LDML   SCMT+TEMP.  PROCESS CHANNEL DATA
          RJM    TCD         TRANSLATE CHANNEL DATA
          LDD    BP          CURRENT CHARACTER BUFFER POSITION
          SBD    BA
          ZJN    PCO1        IF NO CHARACTERS TO OUTPUT
          LJM    CKQ         PLACE CHARACTERS INTO OUTPUT AND RETURN

 PCO3     SHN    21-14-21+17
          MJN    PCO4        IF SPECIAL FUNCTION
          SHN    21-6-21+14
          MJN    PCO2        IF PRIORITY FUNCTION
          LDM    SCMT+SAVE.  RESTORE POSITIONING INFORMATION
          STM    SCMT+XPOS.
          LDM    SCMT+SAVE.+1
          STM    SCMT+YPOS.
          LDM    SCMT+SAVE.+2
          STM    SCMT+SCRN.
          LDM    SCMT+SAVE.+3
          STM    SCMT+CMOV.
          LDN    0#1A        GET TERMINAL OUT OF PRIORITY OPERATION
          STIAO  BP
          LDC    PCO4        NEED TO OUTPUT END PRIORITY
          STI    PT
          LJM    CKQ         OUTPUT FUNCTION AND RETURN

 PCO4     LDM    SCMT+CHRC.  TEST IF OUTPUT IS DONE
          ZJN    PCO5        IF FINISHED
          LJM    SMPX        ELSE RETURN

 PCO5     LDML   SCMT+TEMP.
          SHN    21-17
          LJM    TFN         TRANSLATE FUNCTION
 TAD      SPACE  4,10
**        TAD - TRANSLATE ASCII TO DISPLAY.
*
*         ENTRY  (A) = ASCII CHARACTER.
*
*         EXIT   (A) = DISPLAY CODE TRANSLATION.
*
*         USES   T2.


 TAD1     LDC    100

 TAD      SUBR               ENTRY/EXIT
          LPC    0#7F        IGNORE PARITY
          ZJN    TADX        NOTHING TO TRANSLATE
          SBN    0#08
          MJN    TAD1        IF ILLEGAL CHARACTER
          STD    T2
          SBN    0#40-0#08
          MJN    TAD2
          LPN    37          IGNORE UPPER/LOWER CASE
          UJN    TADX        RETURN

 TAD2     LDM    ATDC,T2     FETCH SPECIAL CHARACTER
          UJN    TADX        RETURN
 TCD      SPACE  4,10
**        TCD - TRANSLATE CHANNEL DATA.
*
*         ENTRY  (A) = CHANNEL DATA.
*
*         EXIT   (BP) = ADVANCED FOR EACH CHARACTER TO BE OUTPUT.
*
*         USES   BP, T2.
*
*         CALLS  SCP.


 TCD1     LDC    100         SET BIAS FOR SPECIAL CHARACTER TRANSLATION
          STM    SCMT+TTOF.
          LJM    TCDX        RETURN

 TCD2     SHN    0-4
          STD    T2
          SHN    21-17-0+4
          MJN    TCD4        IF SCREEN SELECT
          RJM    SCP         SET CURSOR POSITION
          LDM    VKXF,T2
          ZJN    TCD3        IF NO FUNCTION
          STIAO  BP
 TCD3     LDD    T2
          SBN    5
          ZJN    TCD1        IF SPECIAL CHARACTER NEXT
          LJM    TCDX        RETURN

 TCD4     SHN    6-12-21+17
          LPC    0#40
          STM    SCMT+SCRN.
          LDN    4
          STM    SCMT+YPOS.  RESET CURSOR TO UPPER PAGE
          LJM    TCD8        SET CURSOR MOVED AND RETURN

 TCD5     ADC    -10000+7000
          PJN    TCD2        IF SPECIAL FUNCTION
          ADN    10000-7764
          PJN    TCD6        IF ABOVE SCREEN
          LMC    -1          COMPLEMENT
          SHN    -1          DIVIDE BY 2
          STD    T3          DIVIDE BY 5
          SHN    1
          ADD    T3
          SHN    2
          ADD    T3
          SHN    22-6
          STD    T0
          SHN    6+2
          SBD    T3
          ADD    T0
 TCD6     SHN    -10
          STM    SCMT+YPOS.  SET Y COORDINATE
          UJN    TCD8        RETURN

 TCD7     STD    T3          SAVE POSSIBLE X COORDINATE
          ADC    -7000+6000
          PJN    TCD5        IF NOT AN X COORDINATE
          LDD    T3          GET X COORDINATE
          SHN    -3
          STM    SCMT+XPOS.
 TCD8     AOM    SCMT+CMOV.

 TCD      SUBR               ENTRY/EXIT
          STML   SCMT+TEMP.
          ADC    -6000
          PJN    TCD7        IF FUNCTION
          RJM    SCP         SET CURSOR POSITION
          LDM    SCMT+TEMP.
          SHN    -6          DECODE UPPER CHARACTER
          STD    T2
          LDM    DCTA,T2
          STIAO  BP
          LDM    SCMT+TEMP.  DECODE LOWER CHARACTER
          LPN    77
          ADM    SCMT+TTOF.  OFFSET FOR SPECIAL CHARACTERS
          STD    T2
          LDM    DCTA,T2
          STIAO  BP
          LDN    0           CLEAR TABLE OFFSET
          STM    SCMT+TTOF.
          LDN    2           INCREMENT X POSITION
          RAM    SCMT+XPOS.
          LJM    TCDX        RETURN
 TFN      SPACE  4,10
**        TFN - TRANSLATE FUNCTION.
*
*         ENTRY  (A) = CHANNEL DATA SHIFTED 21-17.
*
*         USES   T2, T3.
*
*         CALLS  RMT.


 TFN      BSS    0           ENTRY
          SHN    21-14+17-21
          PJP    TFN3        IF CC545 TYPE FUNCTION
          SHN    0-4+14-21
          LPN    3           PICK OUT SUB FUNCTION
          SBN    1
          NJN    TFN1        IF NOT UPDATE MODE FUNCTION
          STM    SCMT+DATA.  CLEAR OLD FUNCTION
          LDM    SCMT+NCCH.  ADJUST CHANNEL NUMBER
          LMC    IAMI
          STM    TFNA
          LDN    2
 TFNA     IAM    T2,CH       READ IN ADDRESS OF TABLE
          CALL   RMT         RESET MODE TABLE

 TFN1     SBN    2-1
          NJN    TFN2        IF NOT GET OFF CHANNEL
          LDM    SCMT+NCCH.  ADJUST CHANNEL NUMBER
          LMC    SCFI
          STM    TFNB
 TFNB     SCF    SMPX,CH
 TFN2     LJM    CKQ         RETURN

 TFN3     SHN    21-10+14-21
          PJN    TFN4        IF NOT INPUT FUNCTION
          LDN    S.WFK
          UJN    TFN6        CALL NEW FUNCTION

 TFN4     SHN    21-6-21+10
          MJN    TFN5        IF PRIORITY OUTPUT
          LDN    S.NIO
          UJN    TFN6        SET NORMAL OUTPUT

 TFN5     LDN    S.PIO
 TFN6     ADM    SCMT+RTNL.  SET ROUTINE INDEX
          STD    T2
          LDI    T2          FETCH NEW ROUTINE ADDRESS
          STI    PT          SET IN RTNP.
          STD    T3
          LDML   SCMT+TEMP.
          STML   SCMT+DATA.  SAVE POSSIBLE OUTPUT FUNCTION
          LJM    0,T3        CALL NEW FUNCTION
 ATDC     SPACE  4,10
**        ATDC - ASCII TO DISPLAY CODE TRANSLATION TABLE.


 ATDC     BSS    0
          DATA   061,100,100,100,100,060,100,100     0#08 - 0#0F
          DATA   100,100,100,100,100,055,100,100     0#10 - 0#17
          DATA   100,053,100,100,100,100,100,061     0#18 - 0#1F
          DATA   062,000,000,000,053,000,000,000     0#20 - 0#27
          DATA   051,052,047,045,056,046,057,050     0#28 - 0#2F
          DATA   033,034,035,036,037,040,041,042     0#30 - 0#37
          DATA   043,044,063,000,000,054,000,000     0#38 - 0#3F
 DCTA     SPACE  4,10
**        DCTA - DISPLAY CODE TO ASCII TRANSLATION TABLE.


 DCTA     BSS    0

*         NORMAL CHARACTERS - *TTOF.* = 0.

          DATA   0#00,0#41,0#42,0#43,0#44,0#45,0#46,0#47      00 - 07
          DATA   0#48,0#49,0#4A,0#4B,0#4C,0#4D,0#4E,0#4F      10 - 17
          DATA   0#50,0#51,0#52,0#53,0#54,0#55,0#56,0#57      20 - 27
          DATA   0#58,0#59,0#5A,0#30,0#31,0#32,0#33,0#34      30 - 37
          DATA   0#35,0#36,0#37,0#38,0#39,0#2B,0#2D,0#2A      40 - 47
          DATA   0#2F,0#28,0#29,0#20,0#3D,0#20,0#2C,0#2E      50 - 57
          DATA   0#00,0#00,0#00,0#00,0#00,0#00,0#00,0#00      60 - 67
          DATA   0#00,0#00,0#00,0#00,0#00,0#00,0#00,0#00      70 - 77

*         SPECIAL CHARACTERS - *TTOF.* = 100.

          DATA   0#3A,0#41,0#42,0#43,0#44,0#45,0#46,0#47      00 - 07
          DATA   0#48,0#49,0#4A,0#4B,0#4C,0#4D,0#4E,0#4F      10 - 17
          DATA   0#50,0#51,0#52,0#53,0#54,0#55,0#56,0#57      20 - 27
          DATA   0#58,0#59,0#5A,0#30,0#31,0#32,0#33,0#34      30 - 37
          DATA   0#35,0#36,0#37,0#38,0#39,0#2B,0#2D,0#2A      40 - 47
          DATA   0#2F,0#28,0#29,0#24,0#3D,0#20,0#2C,0#2E      50 - 57
          DATA   0#23,0#5B,0#5D,0#25,0#22,0#5F,0#21,0#26      60 - 67
          DATA   0#27,0#3F,0#3C,0#3E,0#40,0#5C,0#5E,0#3B      70 - 77
 VKXF     SPACE  4,10
**        VKXF - TRANSLATION TABLE OF SPECIAL FUNCTIONS TO THE CONSOLE.


 VKXF     BSS    0
          DATA   0#1B,0#18   400, 401
          DATA   0#19,0#17   402, 403
          DATA   0#04,0#00   404, 405
          DATA   0#01,0#03   406, 407
          DATA   0#06,0#15   410, 411
          DATA   0#0E,0#0F   412, 413
          DATA   0#1C,0#1D   414, 415
          DATA   0#10,0#14   416, 417
          DATA   0           420
*DECK DECK=CTI$SCI_SCD_NOS_ROUTINES EXPAND=FALSE
          CTEXT  SCI SCD NOS ROUTINES
          OVERLAY  (SCI SCD/NOS CHANNEL ROUTINES)
 NOSSI    SPACE  4,10
**        SCD/NOS CHANNEL INTERFACE ROUTINE LIST.


 NOSCI    ROUTINE
          LOC    0
 S.LCW    CON    PCL         PROCESS CONTROLWARE LOAD
 S.WFK    CON    RKV         WAIT FOR KEYBOARD ROUTINE
 S.NIO    CON    BNO         STANDARD I/O
 S.PIO    CON    BPO         PRIORITY I/O
          LOC    *O
 PCL      SPACE  4,10
**        PCL - PREPARE CONTROLWARE LOAD.
*
*         SEND THE CONTROLWARE LOAD PREAMBLE DOWN TO THE CONSOLE AND
*         PRESET THE CONTROLWARE ADDRESSES.
*
*         EXIT   TO *LCW* IF CONTROLWARE NOT LOADED.
*                TO *LCW2* IF CONTROLWARE IS LOADED.
*
*         RESETS RTNP.  TO  *LCW*.
*
*         USES   CM - CM+3, CN - CN+1.
*
*         NOTE   THIS ROUTINE MUST BE LOCATED AT *OVLA+4*.


 PCL      ROUTINE            PREPARE FOR CONTROLWARE LOAD

          LDM    SCMT+CMBS.  SET CONTROLWARE LOAD FLAG
          LMC    100000
          STML   SCMT+CMBS.
          LDM    SCMT+CWLD.
          NJP    LCW2        IF CONTROLWARE IS LOADED
          LDC    CWLP        TRANSFER CONTROLWARE LOAD PREAMBLE TO BUFFER
          STD    T1
          STM    SCMT+CWLD.  SET LOADED FLAG
 PCL1     LDI    T1          MOVE NEXT WORD
          STIAO  BP
          AOD    T1          ADVANCE INDEX
          LMC    CWLP+CWLP.L
          NJN    PCL1        IF MORE WORDS TO MOVE
          FINDCM SCD         FIND OLD SCD TO GET CONTROLWARE
          SRD    CN          SAVE R REGISTER
          ADN    1
          CRDL   CM          READ SCD HEADER
          ADN    1
          ADDL   CM+1        SCD PROGRAM LENGTH
          STML   SCMT+CMIP.
          CRDL   CM          READ CONTROLWARE HEADER
          LDDL   CM+1        FETCH CONTROLWARE DATA LENGTH
          STML   SCMT+CMOP.
          LDC    LCW         LOAD CONTROLWARE
          STI    PT          INTO RTNP.
          LJM    CKQ         RETURN
 LCW      SPACE  4,10
**        LCW - LOAD CONTROLWARE.
*
*         ENTRY  (CN - CN+1) = R-REGISTER FOR THE CONTROLWARE.
*
*         EXIT   TO *SMPX* IF CHARACTERS TO OUTPUT.
*                TO *CKQ* IF ADDED CHARACTERS TO OUTPUT.
*
*         EXIT   (RTNP.) = *WFF*.
*
*         USES   CM - CM+3, T1.
*
*         CALLS  BAP, *ICLX*.


 LCW      BSS    0           LOAD CONTROLWARE
          LDM    SCMT+CHRC.
          ZJN    LCW1        IF MUX IS FREE
          LJM    SMPX        RETURN

 LCW1     SOML   SCMT+CMOP.  DECREMENT BYTE COUNT
          MJN    LCW2        IF END OF LOAD
          AOML   SCMT+CMIP.  INCREMENT CONTROLWARE ADDRESS
          LMC    RR
          LRD    CN
          CRDL   CM
          LDDL   CM
          RJM    BAP         BUILD ADDRESS PAIRS
          LDDL   CM+1
          RJM    BAP         BUILD ADDRESS PAIRS
          LDDL   CM+2
          RJM    BAP         BUILD ADDRESS PAIRS
          LDDL   CM+3
          RJM    BAP         BUILD ADDRESS PAIRS
          LJM    CKQ         COMPLETE CHARACTER QUEUE

 LCW2     LDC    CCWL        MOVE CONTROLWARE STARTUP SEQUENCE TO BUFFER
          STD    T1
 LCW3     LDI    T1          MOVE NEXT WORD
          STIAO  BP
          AOD    T1          ADVANCE INDEX
          LMC    CCWL+CCWL.L
          NJN    LCW3        IF MORE WORDS TO MOVE
          LDN    1           NOTIFY HOST TO REFRESH DISPLAYS
          STM    SCMT+CHARS.
          STM    SCMT+KBIP.
          LDN    0
          STM    SCMT+KBOP.  RESET KEYBOARD BUFFER
          STM    SCMT+CHARS.+1
          STM    SCMT+CHARS.+2
          STM    SCMT+CHARS.+3
          STML   SCMT+CMBC.  RESET CM BUFFER
          LDML   SCMT+CMBA.
          STML   SCMT+CMIP.
          STML   SCMT+CMOP.
          LDM    SCMT+CMBS.  CLEAR CONTROLWARE LOAD FLAG
          STM    SCMT+CMBS.
          NJN    LCW4        IF BUFFERED I/O ACTIVE
          LDM    SCMT+NCCH.  ADJUST CHANNEL NUMBER
          STD    T0
          LMC    TSJMI
          STML   WFF0
          LDD    T0
          LMC    EJMI
          STM    WFF1
          LDD    T0
          LMC    IANI
          STM    WFFC
          LDC    WFF
          STI    PT          SET RTNP.
          LJM    CKQ         RETURN

 LCW4     CALL   ICLX        RETURN TO BUFFERED I/O OVERLAY
 SEQ      SPACE  4,10
**        CONSOLE CONTROLWARE LOAD PREAMBLE/POSTAMBLE SEQUENCES.


          CODE   ASCII

 CWLP     BSS    0           CONTROLWARE LOAD PREAMBLE
          CON    0#0D,0#0D   TERMINATE ANY POSSIBLE FUNCTION
          CON    0#1E,0#33   DISABLE HOST LOADED CODE
          CON    0#1E,0#12   SET 80 CHARACTER LINE
          CON    0#48          (CLEARS SCREEN)
 CWLP.T   EQU    *-CWLP

          CON    0#02,0#1E   PLACE MESSAGE ON SCREEN
          CON    0#1E
          CON    1RL+40,1RO+40
          CON    1RA+40,1RD+40
          CON    1RI+40,1RN+40
          CON    1RG+40,1R +40
          CON    1RC+40,1RO+40
          CON    1RN+40,1RS+40
          CON    1RO+40,1RL+40
          CON    1RE+40,1R +40
          CON    1RC+40,1RO+40
          CON    1RN+40,1RT+40
          CON    1RR+40,1RO+40
          CON    1RL+40,1RW+40
          CON    1RA+40,1RR+40
          CON    1RE+40
          CON    0#1E,0#09   START CONTROLWARE LOAD
          CON    0#78,0#32
 CWLP.L   EQU    *-CWLP

 CCWL     BSS    0           CONTROLWARE STARTUP SEQUENCE
          CON    0#0D,0#0D   TERMINATE CONTROLWARE LOAD
          CON    0#1E,0#12   START CONTROLWARE
          CON    0#78
 CCWL.L   EQU    *-CCWL

          CODE   *
 BAP      SPACE  4,10
**        BAP - BUILD ADDRESS PAIRS.
*
*         ENTRY  (A) = 16 BIT ADDRESS.
*                (BP) = CHARACTER BUFFER POINTER.
*
*         EXIT   (BP) = INCREMENTED BY 4.
*
*         USES   T1.


 BAP      SUBR               ENTRY/EXIT
          STD    T1
          SHN    -10         TRANSLATE UPPER BYTE TO 20, 60 PAIR
          SHN    22-4
          ADN    0#20
          STI    BP
          SHN    4-22
          ADC    0#60
          STM    1,BP
          LDD    T1          TRANSLATE LOWER BYTE TO 20, 60 PAIR
          SHN    -4
          LPN    0#F
          ADN    0#20
          STM    2,BP
          LDD    T1
          LPN    0#F
          ADC    0#60
          STM    3,BP
          LDN    4           UPDATE CHARACTER QUEUE POINTER
          RAD    BP
          UJN    BAPX        RETURN
*copy     cti$sci_scd_common_routines
 RKV      SPACE  4,10
**        RKV - RETURN KEYBOARD VALUE.
*
*         OUTPUT CHARACTER READ FROM THE TO THE DISPLAY PROGRAM.
*
*         ENTRY  (PT) = MODE TABLE ADDRESS.
*
*         CALLS  CKC, TAD.
*
*         TIMING    BECAUSE OF THE COMMUNICATION WITH THE NOS DISPLAY
*                DRIVER THE CHANNEL INSTRUCTIONS MUST BE SET UP BEFORE
*                THE CHARACTER IS RETURNED.  OTHERWISE NOS MAY ASK
*                FOR ANOTHER CHARACTER BERFORE SCI HAS AN OPPORTUNITY
*                TO RETURN TO THE MUX ROUTINE FOR IT.


 RKV      BSS    0
          LDM    SCMT+NCCH.  ADJUST CHANNEL NUMBER
          STD    T0
          LMC    OANI
          STM    RKVA
          LDD    T0
          LMC    FJMI
          STM    RKVB
          LDD    T0          ADJUST CHANNEL NUMBER IN *WFF*
          LMC    TSJMI
          STML   WFF0
          LDD    T0
          LMC    EJMI
          STM    WFF1
          LDD    T0
          LMC    IANI
          STM    WFFC
          LDN    0
          STM    SCMT+DATA.  CLEAR DATA WORD
          RJM    GKC         GET KEYBOARD CHARACTER
          RJM    TAD         TRANSLATE ASCII TO DISPLAY
 RKVA     OAN    CH
 RKVB     FJM    *,CH
*         UJN    WFF         WAIT FOR FUNCTION
          ERRNG  WFF-*       CODE ASSUMES *WFF* IS ADJACENT
 WFF      SPACE  4,10
**        WFF - WAIT FOR FUNCTION.
*
*         CHECK FOR A VALID DISPLAY FUNCTION.
*
*         ENTRY  (PT) = MODE TABLE ADDRESS.
*
*         EXIT   TO *TFN* IF VALID FUNCTION.
*
*         RESET  RTNP.  TO   WFF0


 WFF      BSS    0           WAIT FOR FUNCTION
          LDC    WFF0
          STI    PT          AS NEXT ROUTINE
          LDML   SCMT+DATA.
          UJN    WFF2        CHECK FOR FUNCTION

 WFF0     FSJM   SMPX,CH     IF CHANNEL NOT AVAILABLE
 WFF1     EJM    SMPX,CH     IF NO DATA ON CHANNEL
 WFFC     IAN    CH
 WFF2     STML   SCMT+TEMP.  SAVE CHANNEL DATA
          SHN    21-17
          PJN    WFF1        IF NOT A VALID FUNCTION
          LJM    TFN         TRANSLATE FUNCTION
 BNO      SPACE  4,10
**        BNO - BEGIN NORMAL OUTPUT.
*
*         ENTRY  (PT) = MODE TABLE ADDRESS.
*
*         EXIT   TO *NCO*.
*
*         RESETS RTNP.  TO   NCO
*
*         CALLS  TCD.


 BNO      BSS    0           BEGIN NORMAL OUTPUT
          LDML   SCMT+DATA.
          RJM    TCD         TRANSLATE CHANNEL DATA
          LDC    NCO         *NORMAL CHANNEL OUTPUT*
          STI    PT          AS NEXT ROUTINE
*         UJN    NCO         START NORMAL CHANNEL OUTPUT
          ERRNZ  NCO-*       CODE ASSUMES *NCO* IS ADJACENT
 NCO      SPACE  4,10
**        NCO - NORMAL CHANNEL OUTPUT.
*
*         READ DATA FROM CHANNEL AND TRANSLATE IT FOR THE TWO PORT MUX.
*
*         ENTRY  (PT) = MODE TABLE ADDRESS.
*
*         EXIT   TO *TFN* IF FUNCTION ENCOUNTERED.
*                TO *SMPX* IF CHARACTERS TO BE OUTPUT
*
*         CALLS  FCN, TCD.


 NCO      BSS    0           NORMAL CHANNEL OUTPUT
          LDM    SCMT+NCCH.  ADJUST CHANNEL NUMBER
          STD    T0
          LMC    TSJMI
          STML   NCO1
          LDD    T0
          LMC    EJMI
          STM    NCOB
          LDD    T0
          LMC    IANI
          STM    NCOC
          LDM    SCMT+CHRC.
          ZJN    NCO1        IF MUX IS READY
          LJM    SMPX        RETURN

 NCO1     FSJM   SMPX,CH     IF CHANNEL NOT AVAILABLE
 NCOB     EJM    SMPX,CH     IF NO DATA ON CHANNEL
 NCOC     IAN    CH
          STML   SCMT+TEMP.
          SHN    21-17
          MJP    TFN         IF IT IS A FUNCTION
 NCO2     LDML   SCMT+TEMP.  RESTORE CHANNEL DATA VALUE
          RJM    TCD         TRANSLATE CHANNEL DATA
          LDD    BP          CURRENT CHARACTER BUFFER POSITION
          SBD    BA
          ZJN    NCO1        IF NO CHARACTERS TO OUTPUT
          LJM    CKQ         RETURN

          OVERFLOW  SCMT     CHECK FOR OVERFLOW
          OVERLAY  (SCI SCD/NOS BUFFERED ROUTINES)
 NOSBI    SPACE  4,10
**        SCD/NOS BUFFERED INTERFACE ROUTINE LIST.


 NOSBI    ROUTINE
          LOC    0
 S.LCW    CON    ICL         INITIATE CONTROLWARE LOAD
 S.WFK    CON    WFK         WAIT FOR KEYBOARD ROUTINE
 S.NIO    CON    BBO         BEGIN BUFFERED I/O
 S.PIO    CON    BPO         BEGIN PRIORITY I/O
          LOC    *O
 ICL      SPACE  4,10
**        ICL - INITIATE CONTROLWARE LOAD.
*
*         CALLS  *PCL*.
*
*         NOTE   THIS ROUTINE MUST BE LOCATED AT *OVLA+4*.


 ICL      CALL   PCL
          ERRNZ  ICL-PCL     *PCL* MISMATCH WITH CHANNEL OVERLAY

 ICLX     ROUTINE            *PCL* RETURNS HERE

          LDC    WFF         WAIT FOR FUNCTION
          STI    PT
          LJM    CKQ         WAIT FOR CONTROLWARE LOADING TO COMPLETE
*copy     cti$sci_scd_common_routines
 WFK      SPACE  4,10
**        WFK - WAIT FOR KEYBOARD.
*
*         WAIT UNTIL A KEY IS TYPED OR THE CM BUFFER IS EMPTY.
*
*         ENTRY  (PT) = MODE TABLE ADDRESS.
*
*         EXIT   TO *WFF* IF COMPLETE.
*                TO *ECB* IF CM BUFFER NOT EMPTY AND NO KEYBOARD INPUT.
*
*         CALLS  GKC, TAD.
*
*         TIMING BECAUSE OF THE COMMUNICATION WITH THE NOS DISPLAY
*                DRIVER THE CHANNEL INSTRUCTIONS MUST BE SET UP BEFORE
*                THE CHARACTER IS RETURNED.  OTHERWISE NOS MAY ASK
*                FOR ANOTHER CHARACTER BERFORE SCI HAS AN OPPORTUNITY
*                TO RETURN TO THE MUX ROUTINE FOR IT.


 WFK      BSS    0
          LDM    SCMT+NCCH.  ADJUST CHANNEL NUMBER
          STD    T0
          LMC    OANI
          STM    WFK2
          LDD    T0
          LMC    FJMI
          STM    WFKB
          LDD    T0          ADJUST CHANNEL NUMBER IN *WFF*
          LMC    TSJMI
          STML   WFF0
          LDD    T0
          LMC    EJMI
          STM    WFF1
          LDD    T0
          LMC    IANI
          STM    WFFC
          RJM    GKC         GET KEYBOARD CHARACTER
          NJN    WFK1        IF CHARACTER INPUT
          LDM    SCMT+CMBC.
          ZJN    WFK2        IF BUFFERED OUTPUT COMPLETE
          LJM    ECB         EMPTY CM BUFFER

 WFK1     RJM    TAD         TRANSLATE ASCII TO DISPLAY
 WFK2     OAN    CH
 WFKB     FJM    *,CH
          LDN    0
          STM    SCMT+DATA.  CLEAR FUNCTION
*         UJN    WFF         WAIT FOR FUNCTION
          ERRNZ  WFF-*       CODE ASSUMES *WFF* IS ADJACENT
 WFF      SPACE  4,10
**        WFF - WAIT FOR FUNCTION.
*
*         WAIT FOR A VALID 7000 TYPE FUNCTION.
*
*         EXIT   TO *TFN* WHEN FUNCTION ENCOUNTERED.
*                TO *ECB* IF NO VALID FUNCTION ON CHANNEL.
*
*         EXIT   (RTNP.) = *WFF0*.


 WFF      BSS    0           WAIT FOR FUNCTION
          LDC    WFF0
          STI    PT          AS NEXT ROUTINE
          LDML   SCMT+DATA.
          UJN    WFF2        CHECK FOR FUNCTION

 WFF0     FSJM   ECB,CH      IF CHANNEL NOT AVAILABLE
 WFF1     EJM    ECB,CH      IF NO DATA ON CHANNEL
 WFFC     IAN    CH
 WFF2     STML   SCMT+TEMP.  SAVE CHANNEL DATA
          SHN    21-17
          PJN    WFF1        IF NOT A VALID FUNCTION
          LJM    TFN         TRANSLATE FUNCTION
 BBO      SPACE  4,10
**        BBO - BEGIN BUFFERED OUTPUT.
*
*         THIS WAITS FOR THE CM BUFFER TO BE EMPTIED AND THEN RESETS
*         THE BUFFER POINTERS, PROCESSES THE FIRST SCREEN SELECT
*         FUNCTION, AND CALLS *BUFFERED CHANNEL OUTPUT*.
*
*         EXIT   TO *BCO3* WHEN CM BUFFER EMPTY.
*                TO *ECB* WHEN CM BUFFER NOT EMPTY.
*
*         RESETS RTNP.  TO   BCO.
*
*         USES   T5.


 BBO      BSS    0
          LDM    SCMT+CMBC.
          ZJN    BBO1        IF CM BUFFER EMPTY
          LJM    ECB         EMPTY CM BUFFER

 BBO1     LDC    BCO         *BUFFERED CHANNEL OUTPUT*
          STI    PT          AS NEXT ROUTINE
          LDM    SCMT+CMWP.
          STD    T5
          LDML   SCMT+DATA.
          STIL   T5
          LJM    BCO3        START BUFFERED OUTPUT
 BCO      SPACE  4,10
**        BCO - BUFFERED CHANNEL OUTPUT.
*
*         COPY DATA FROM CHANNEL 10 TO THE CM BUFFER UNTIL A VALID
*         7000 FUNCTION OTHER THAN *SELECT RIGHT* OR *SELECT LEFT*
*         IS ENCOUNTERED OR CM BUFFER BECOMES FULL.
*
*         EXIT   TO *TFN* IF VALID FUNCTION FOUND.
*                TO *ECB* OTHERWISE.
*
*         USES   T5.
*
*         CALLS  SPB.


 BCO      BSS    0
          LDM    SCMT+NCCH.  ADJUST CHANNEL NUMBER
          STD    T0
          LMC    TSJMI
          STML   BCOB
          LDD    T0
          LMC    EJMI
          STM    BCO2
          LDD    T0
          LMC    IANI
          STM    BCOC
 BCOB     FSJM   BCO5,CH     IF CHANNEL NOT AVAILABLE
          LDM    SCMT+CMWP.
          STD    T5
 BCO1     LDM    SCMT+CMBS.  TEST FOR BUFFER FULL
          SBM    SCMT+CMBC.
          NJN    BCO2
          LJM    ECB         EMPTY CM BUFFER

 BCO2     EJM    BCO5,CH     IF NOT DATA ON CHANNEL
 BCOC     IAN    CH
          STIL   T5
          SHN    21-17
          MJP    BCO4        IF FUNCTION
 BCO3     AOD    T5
          LPN    3
          NJN    BCO2        IF NOT ON WORD BOUNDARY
          LCN    4
          RAD    T5          RESET ADDRESS
          STM    BCOF
          LDM    SCMT+RRUP.  SET UP R-REGISTER
          STD    W0
          LDM    SCMT+RRLW.
          STD    W1
          LRD    W0
          RJM    SPB         SET PP BOUNDARY
          LDML   SCMT+CMOP.
          LMC    RR
          CWML   **,ON
 BCOF     EQU    *-1
          AOM    SCMT+CMBC.
          AOML   SCMT+CMOP.
          LDML   SCMT+CMBL.  TEST FOR END OF BUFFER
          SBML   SCMT+CMOP.
          PJN    BCO3.1      IF NOT
          LDML   SCMT+CMBA.  ELSE RESET TO FIRST
          STML   SCMT+CMOP.
 BCO3.1   LJM    BCO1        CHECK CHANNEL FOR DATA

 BCO4     LPC    424*100
          ZJP    BCO3        IF NOT A INPUT/PRIORITY/SPECIAL FUNCTION
          LDD    T5
          STM    SCMT+CMWP.
          LDIL   T5
          STML   SCMT+TEMP.  SAVE CHANNEL DATA
          SHN    21-17
          LJM    TFN         TRANSLATE FUNCTION

 BCO5     LDD    T5          GET CURRENT DATA POINTER
          STM    SCMT+CMWP.
*         LJM    ECB         EMPTY CM BUFFER
          ERRNZ  ECB-*       CODE ASSUMES *ECB* IS ADJACENT
 ECB      SPACE  4,10
**        ECB - EMPTY CM BUFFER.
*
*         READ CHANNEL DATA FROM THE CM BUFFER AND TRANSLATE IT FOR
*         THE CONSOLE.
*
*         EXIT   TO *CKQ* TO COMPLETE THE CHARACTER BUFFER.
*                TO *SMPX* IF LAST TRANSLATION NOT OUTPUT.
*
*         CALLS  TCD.
*
*         USES   CM - CM+3, T5.


 ECB      BSS    0
          LDM    SCMT+CHRC.
          ZJN    ECB1        IF MUX READY FOR MORE OUTPUT
          LJM    SMPX        RETURN

 ECB1     SOM    SCMT+CMBC.  DECREMENT DATA COUNT
          PJN    ECB3        IF DATA TO OUTPUT
          LDN    0
          STM    SCMT+CMBC.  RESET DATA COUNT
          LDM    SCMT+CMWP.  SET STARTING BUFFER ADDRESS
          SCN    3
          STD    T5
          LDM    SCMT+CMWP.
 ECB2     LPN    3
          NJN    ECB2.2
          LJM    ECB4        RETURN
 ECB2.2   LDIL   T5
          RJM    TCD         TRANSLATE CHANNEL DATA
          AOD    T5
          SOM    SCMT+CMWP.
          UJN    ECB2        LOOP

 ECB3     LDM    SCMT+RRUP.  SET UP R-REGISTER
          STD    W0
          LDM    SCMT+RRLW.
          STD    W1
          LRD    W0
          LDML   SCMT+CMIP.  GET BUFFER ADDRESS
          ADC    RR          FORM CM ADDRESS OF INPUT BUFFER WORD
          CRDL   CM
          AOML   SCMT+CMIP.  INCREMENT BUFFER ADDRESS
          LDML   SCMT+CMBL.  TEST FOR END OF BUFFER
          SBML   SCMT+CMIP.
          PJN    ECB3.1      IF NOT
          LDML   SCMT+CMBA.  ELSE RESET TO BEGINNING
          STML   SCMT+CMIP.
 ECB3.1   LDDL   CM
          RJM    TCD         TRANSLATE FIRST WORD
          LDDL   CM+1
          RJM    TCD         TRANSLATE SECOND WORD
          LDDL   CM+2
          RJM    TCD         TRANSLATE THIRD WORD
          LDDL   CM+3
          RJM    TCD         TRANSLATE FOURTH WORD
 ECB4     LJM    CKQ         UPDATE CHARACTER QUEUE AND RETURN

          OVERFLOW  SCMT     CHECK FOR OVERFLOW

          ENDX
*DECK DECK=CTI$SCI_SCD_VE_ROUTINES EXPAND=FALSE
          CTEXT  SCI SCD VE ROUTINES
          OVERLAY (SCI SCD/VE ROUTINES)
 NVESI    SPACE  4,10
**        SCD/VE ROUTINE LIST.


 NVESI    ROUTINE

          LOC    0
 S.LCW    CON    VES         SCD/VE INITIALIZATION
 S.WFK    CON    VED
 S.NIO    CON    VED
 S.PIO    CON    VED
          LOC    *O
 VED      SPACE  4,10
**        VED - NOS/VE DRIVER.
*
*         *VED* CALLS THE PROCESSING ROUTINES FOR THE NOS/VE
*         CONSOLE DRIVER.  IT EITHER PROCESSES A COMMAND OR
*         ATTEMPTS TO OUTPUT LINES TO THE CONSOLE.
*
*         EXIT   TO *SMPX* IF NO COMMAND PROCESSED.
*                TO PROPER COMMAND IF ONE RECEIVED.
*
*         USES   T1.
*
*         CALLS  CEL, COA, GCB, GET, OUT, RKI, UDB.


 VED      BSS    0           ENTRY
          LDML   SCMT+PTDB.
          ZJN    VED1        IF MODE UNDEFINED
          RJM    RKI         RETURN KEYBOARD INPUT
          LDM    SCMT+CHRC.
          ZJN    VED2        IF LAST OUTPUT ALL SENT
 VED1     LJM    SMPX        RETURN

 VED2     RJM    GCB         GET COMMUNICATION BLOCK
          LDML   SCMT+COMM.+4
          SHN    -8D
          STD    T1
          SBN    CRJTL       TEST IF BEYOND RANGE
          PJN    VED2.5      IF BEYOND END OF JUMP TABLE
          LDM    CRJT,T1     LOAD JUMP ADDRESS OF COMMAND
          STM    VEDA
          PSN                NEED ON AN S0/S0E
          LJM    **          PROCESS COMMAND
 VEDA     EQU    *-1         RETURN TO SMPX

 VED2.5   LDN    0           INFORM COMMAND ACCEPTED
          STML   SCMT+COMM.+4
          LDN    2
          RJM    UDB
 VED3     RJM    CEL         CHECK ERROR LINE
          LDM    SCMT+OPSF.
          NJN    VED1        IF OUTPUT ON HOLD
          RJM    GET         GET NEXT LINE TO OUTPUT
          NJP    OUT         SET UP OUTPUT LINE FOR MUX
          RJM    COA         CHECK DUAL-STATE OS OPERATOR ATTENTION FLAG
          LJM    VED1        RETURN

 CRJT     BSS    0           COMMAND ROUTINE JUMP TABLE
          LOC    0
          CON    VED3        ** (NO COMMAND)
          CON    ABT         ** ABORT OUTPUT
          CON    BNL         ** BEGIN NEW LIST
          CON    ECI         ** ECHO COMMAND INPUT
          CON    RES         ** RESUME OUTPUT
 CRJTL    BSS    0           MAXIMUM REQUEST + 1
          LOC    *O
 ABT      SPACE  4,10
**        ABT - PROCESS THE ABORT COMMAND.
*
*         NOTIFIES NOS/VE COMMAND ACCEPTED AND RESETS LINE LIST.
*
*         EXIT   TO *SMPX*.
*
*         CALLS  UDB.


 ABT      BSS    0           ENTRY
          LDN    0
          STM    SCMT+GOTL.  CLEAR GOT LAST LINE FLAG
          STM    SCMT+OPSF.  CLEAR HOLD FLAG
          STML   SCMT+COMM.+2  END OF OUTPUT LIST
          STML   SCMT+COMM.+3
          STML   SCMT+COMM.+4  COMMAND ACCCEPTED
          LDN    2
          RJM    UDB         UPDATED COMMUNICATION BLOCK
          LJM    SMPX        RETURN
 BNL      SPACE  4,10
**        BNL - BEGIN NEW LIST OF OUTPUT.
*
*         NOTIFIES NOS/VE COMMAND ACCEPTED AND RESETS LINE LIST POINTER.
*         THIS ROUTINE ASSUMES THAT THE PREVIOUS LIST IS COMPLETE.
*
*         EXIT   TO *SMPX*.
*
*         CALLS  UDB.


 BNL      BSS    0           ENTRY
          LDN    0           RESET TO LIST COMPLETE
          STM    SCMT+GOTL.  CLEAR GOT LAST LINE FLAG
          STM    SCMT+COMM.+4  NOTIFY COMMAND ACCEPTED
          LDML   SCMT+COMM.+6  PROCESS RMA FOR NEW OUTPUT LIST
          STML   SCMT+COMM.+2
          LDML   SCMT+COMM.+7
          STML   SCMT+COMM.+3
          LDN    2
          RJM    UDB         UPDATE COMMUNICATIONS BLOCK
          LJM    SMPX        RETURN
 ECI      SPACE  4,10
**        ECI - ECHO COMMAND INPUT.
*
*         THIS ROUTINE PROCESSES THE ECHO INPUT COMMAND.
*
*         ENTRY  COMMAND BLOCK READ IN.
*
*         EXIT   TO *SMPX* IF CHARACTER STILL TO BE OUTPUT.
*                TO *CKQ* IF KEYBOARD IS ECHOED.
*
*         USES   T1, W2, W3.
*
*         CALLS  NVS, STA, UDB.


 ECI      BSS    0           ENTRY
          LDN    11D         SET WORD COUNT
          STD    T1
          LDML   SCMT+COMM.+6  GET READ ADDRESS
          STDL   W2
          LDML   SCMT+COMM.+7
          STDL   W3
          RJM    STA         CONVERT TO R-REGISTER VALUE
          LMC    RR          ACTIVATE R-REGISTER
          CRML   BUFF,T1
          LDML   BUFF        GET LOCATION TO PLACE CURSOR
          LPC    0#FF
          ADN    31D
          STM    SCMT+XPOS.  X-POSITION
          LDML   BUFF
          SHN    -10
          ADN    31D
          STM    SCMT+YPOS.  Y-POSITION
          LDN    0
          RJM    UPK         UNPACK LINE
          LDD    T2
          RAD    BP          OUTPUT THE TRAILING SPACES
          LDM    SCMT+COMM.+4
          LPN    1
          STM    SCMT+OPSF.  WAIT FOR NEXT COMMAND
          LDN    0
          STML   SCMT+COMM.+4  NOTIFY COMMAND ACCEPTED
          STM    SCMT+RKIA.
          LDN    2
          RJM    UDB         NOTIFY COMMAND ACCEPTED

*         CHECK IF NOS/VE SHOULD BE NOTIFIED.

          LDM    SCMT+OPSF.
          NJN    ECI1        IF WAIT FOR COMMAND SET
          LDML   SCMT+COMM.+2
          ADML   SCMT+COMM.+3
          NJN    ECI1        IF LINES REMAIN TO BE SEND
          RJM    NVS         NOTIFY VIRTUAL SYSTEM
 ECI1     LJM    CKQ         RESET POINTERS AND RETURN TO *SMPX*
 RES      SPACE  4,10
**        RES - RESUME OUTPUT.
*
*         NOTIFIES NOS/VE COMMAND ACCEPTED AND ALLOWS OUTPUT.
*
*         EXIT   TO *SMPX*.
*
*         CALLS  UDB.


 RES      BSS    0           ENTRY
          LDN    0
          STM    SCMT+OPSF.  RESUME OUTPUT TO CONSOLE
          STML   SCMT+COMM.+4
          LDN    2
          RJM    UDB         NOTIFY COMMAND ACCEPTED
          LJM    SMPX        RETURN
          EJECT
 CDL      SPACE  4,10
**        CDL - CHECK DFT ERROR LINE.
*
*         ENTRY NONE.
*
*         USES   T1.


 CDL      SUBR               ENTRY/EXIT
          LRD    IB+1        ADDRESS OF DFT ERROR MESSAGE
          LDD    IB
          ADC    DFCM+RR     USE R-REGISTER
          CRML   BUFF,ON     GET LINE
          LDML   BUFF+3      CHECK TO SEE IF A NEW MESSAGE
          SBML   CDLA
          ZJN    CDLX        IF SAME MESSAGE
          LDML   BUFF+3      SAVE MESSAGE ID
          STML   CDLA
          LDML   BUFF+1      CHANGE MESSAGE_LENGTH
          SHN    8D
          STML   BUFF+1
          LDN    3B
          STD    T1
          LDD    IB
          ADC    RR+DFCM+1   USE R-REGISTER
          CRML   BUFF+4,T1   GET LINE
          LDML   BUFF+10B    CHECK MESSAGE (HH:MM:SS MAY BE BLANKS)
          LMC    2R
          ZJP    CDLX        IF BLANK
          LDN    24D         CHARACTERS TO OUTPUT
          LJM    OEL         OUTPUT THE ERROR LINE
 CEL      SPACE  4,10
**        CEL - CHECK ERROR LINE.
*
*         EXIT   TO *EOL* IF NEW ERROR MESSAGE TO DISPLAY.
*
*         USES   T1.
*
*         CALLS  CDL, OEL.


 CEL      SUBR               ENTRY/EXIT
          RJM    CDL         CHECK DFT ERROR LINE
          LDM    SCMT+ELRU.
          STD    T2
          LDM    SCMT+ELRL.
          STD    T3
          LRD    T2          ADDRESS OF ERROR MESSAGE
          LDML   SCMT+ELAO.
          LMC    RR          USE R-REGISTER
          CRML   BUFF,ON     GET LINE
          LDML   BUFF+3      CHECK TO SEE IF A NEW MESSAGE
          SBML   CELA
          ZJN    CELX        IF SAME MESSAGE
          LDML   BUFF+3      SAVE MESSAGE ID
          STML   CELA
          LDN    10D
          STD    T1
          LDML   SCMT+ELAO.
          ADC    RR+1        USE R-REGISTER
          CRML   BUFF+4,T1   GET THE REST OF THE LINE
          SOML   CDLA        ENSURE THAT DFT MESSAGE WILL APPEAR
          LDC    77D         CHARACTERS TO OUTPUT
          LJM    OEL         OUTPUT THE ERROR LINE
 COA      SPACE  4,10
**        COA - CHECK DUAL-STATE OS OPERATOR ATTENTION FLAG.
*
*         EXIT   TO *CKQ* IF FLASHING *170* POSTED OR CLEARED.
*
*         USES   CM - CM+3.
*
*         CALLS  IIB.


 COA      SUBR               ENTRY/EXIT
          LDN    D7ST        CHECK IF C170 OS NEEDS ATTENTION
          RJM    IIB
          CRDL   CM
          LDD    CM          COMPARE PRESENT AND PREVIOUS STATUS
          LPC    400
          STD    CM
          LMM    COAA
          ZJN    COAX        IF NO CHANGE IN BIT STATUS
          LDD    CM
          STM    COAA
          ZJN    COA3        IF BIT HAS CLEARED SINCE LAST CALL

*         POST FLASHING *170* AT UPPER RIGHT CORNER OF CONSOLE DISPLAY.

          LDD    SB
          ADD    SB+1
          ZJN    COA1        IF NO *SCI* PARAMETER TABLE
          LRD    SB          READ *SCI* PARAMETER TABLE FOR BELL STATUS
          LDM    SBAO
          LMC    RR
          CRDL   CM
          LDDL   CM+2
          SHN    21-15
          MJN    COA1        IF BELL ENABLED
          LDC    COAD        SET UP OUTPUT POINTERS
          STD    BA
          ADN    COADL
          UJN    COA2        CONTINUE

 COA1     LDC    COAB        SET UP OUTPUT POINTERS
          STD    BA
          ADN    COABL
 COA2     STD    BP
          UJN    COA4        EXIT TO *CKQ*

*         CLEAR FLASHING *170* SINCE DUAL-STATE OS NO LONGER NEEDS OPERATOR.

 COA3     LDC    COAC        SET UP OUTPUT POINTERS
          STD    BA
          ADN    COACL
          STD    BP
 COA4     LJM    CKQ         RETURN

 COAA     BSS    1           PREVIOUS STATUS OF *D7ST* BIT 56

 COAB     BSS    0           DISPLAY FLASHING *170* AND SOUND BELL
          CON    0#07        SOUND BELL
 COAD     BSS    0           DISPLAY WITHOUT BELL
          CON    0#1E,0#44   TURN ON INVERSE VIDEO
          CON    0#06,0#0E   SET UNDERLINE AND BLINK
          CON    0#02,0#6D   POSITION CURSOR
          CON    0#20
          CON    1R1,1R7     170
          CON    1R0
          CON    0#1E,0#45   TURN OFF INVERSE VIDEO
          CON    0#15,0#0F   END UNDERLINE AND BLINK
 COABL    EQU    *-COAB
 COADL    EQU    *-COAD

 COAC     BSS    0           CLEAR FLASHING *170*
          CON    0#02,0#6D   POSITION CURSOR
          CON    0#20
          CON    0#20,0#20   THREE BLANKS
          CON    0#20
 COACL    EQU    *-COAC
 GCB      SPACE  4,10
**        GCB - GET COMMUNICATIONS BLOCK.
*
*         READS THE NOS/VE COMMUNICATION BLOCK IN CM.


 GCB      SUBR               ENTRY/EXIT
          LDK    COMM.+4     GET COMM. BLOCK ADDRESS
          ADD    PT
          STM    GCBM
          LRD    CB          GET DATA WORD ADDRESS
          LDML   SCMT+CBAO.
          ADC    RR+1        USE R-REGISTER
          CRML   **,ON       READ IN DATA WORD
 GCBM     EQU    *-1
          UJN    GCBX        RETURN
 GET      SPACE  4,10
**        GET - GET OUTPUT LINE.
*
*         GETS THE NEXT LINE IN THE LIST TO BE OUTPUT.
*
*         ENTRY  (COMM.+2 COMM.+3) ADDRESS OF NEXT LINE.
*
*         EXIT   RETURN IF A LINE IS PICKED UP.
*                TO *CKQ* IF LAST LINE OUT AND NEED TO SET CURSOR.
*
*         USES   T1, T2, T3.
*
*         CALLS  NVS, SCP, STA, UDB.


 GET2     LDN    0           SET TO END OF LIST
          STML   SCMT+COMM.+2
          STML   SCMT+COMM.+3
          LDN    1
          RJM    UDB         REPORT LAST RMA PICKED UP
          RJM    NVS         NOTIFY VIRTUAL SYSTEM
          RJM    SCP         GOTO CURSOR POSITION
          ZJN    GET3        IF CURSOR NOT MOVED
          LJM    CKQ         POSITION CURSOR AND RETURN FROM SCD

 GET3     STM    SCMT+GOTL.  SET/CLEAR FLAG FOR END OF LIST NOT SENT

 GET      SUBR               ENTRY/EXIT
          LDM    SCMT+GOTL.
          NJN    GET2        IF LAST RMA PICKED UP BUT NOT REPORTED
          LDML   SCMT+COMM.+2
          STDL   W2
          LDML   SCMT+COMM.+3  SECOND HALF
          STDL   W3
          ADDL   W2
          ZJN    GETX        IF OUT OF RMA'S
          LDN    11D
          STD    T1
          RJM    STA         TRANSLATE RMA INTO AN R-REGISTER VALUE
          LMC    RR          ACTIVATE R-REGISTER
          CRML   BUFF,T1     GET LINE
          LDML   BUFF+2
          ADML   BUFF+3      TEST FOR END OF LIST
          ZJN    GET1        IF END OF LIST
          LDML   BUFF+2
          STML   SCMT+COMM.+2
          LDML   BUFF+3
          STML   SCMT+COMM.+3
          LDN    1
          RJM    UDB         REPORT RMA PICKED UP
          LJM    GETX        RETURN

 GET1     LDN    1
          LJM    GET3        SET FLAG FOR END OF LIST NOT SENT
 MBC      SPACE  4,10
**        MBC - MOVE BLOCK OF CHARACTERS.
*
*         ENTRY  (A) = ADDRESS OF BLOCK TO MOVE.
*                (BP) = BUFFER POINTER.
*
*         USES   BP, T3.


 MBC      SUBR               ENTRY/EXIT
          STD    T3
 MBC1     LDI    T3          GET NEXT CHARACTER TO MOVE
          ZJN    MBCX        IF NO MORE TO MOVE
          STIAO  BP
          AOD    T3
          UJN    MBC1        ADVANCE TO NEXT CHARACTER
 NVS      SPACE  4,10
**        NVS - NOTIFY VIRTUAL SYSTEM.
*
*         SENDS A CPU INTERRUPT TO THE NOS/VE OPERATING SYSTEM.
*
*         USES   T1 - T4.


 NVS      SUBR               ENTRY/EXIT
          LRD    SB
          LDM    SBAO
          ADC    RR+1
          CRDL   T1          GET *SCD/VE* INTERFACE POINTER ADDRESS
          LDD    T2
          LPN    77          MASK OFF PROCESSOR INTERRUPT MASK
          LMC    INPNI       FORM INTERRUPT INSTRUCTION
          STML   NVSA

*         THE FOLLOWING CM READ IS REQUIRED FOR TWO REASONS:
*           1)  ON AN S1CR MAINFRAME, IT IS NEEDED IN ORDER TO RELEASE THE ADU TO
*               THE PARTNER PP.  THE READ MUST INVOLVE THE USE OF THE R-REGISTER
*               TO SUCCESSFULLY RELEASE THE ADU.
*           2)  ON AN S0 MAINFRAME, MEMORY BANK ZERO MUST BE ACCESSED BEFORE THE
*               INTERRUPT INSTRUCTION WILL TAKE AFFECT.  THE LOAD OF THE
*               R-REGISTER ALSO SATISFIES THE REQUIREMENT THAT AT LEAST ONE
*               INSTRUCTION BE EXECUTED BETWEEN AN INSTRUCTION MODIFICATION AND
*               THE USE OF THAT MODIFIED INSTRUCTION ON AN S0 MAINFRAME.

          LDC    RR          READ FROM MEMORY BANK FOR S0 MAINFRAME
 NVSA     INPN   **          ** MODIFIED WITH PORT TO INTERRUPT **
          CRDL   T1          RELEASE THE ADU TO PARTNER PP ON S1CR MAINFRAME
          UJN    NVSX        RETURN
 OEL      SPACE  4,15
**        OEL - OUTPUT ERROR LINE.
*
*         ENTRY  (A) = CHARACTERS TO OUTPUT.
*                    = 24 FOR *DFCM* MESSAGES.
*                    = 77 FOR SYSTEM ERROR MESSAGES.
*
*         EXIT   TO *CKQ*.
*
*         USES   T5, T6, T7, BP.
*
*         CALLS  MBC, UPK.


 OEL      BSS    0           ENTRY
          STD    T7          SAVE LENGTH
          STM    OELA
          LDD    BP          GET BUFFER POINTER
          STD    T5
          LDC    80D         CLEAR 80 CHARACTERS FOR WORST CASE
          STD    T6
 OEL1     LDN    0#20
          STI    T5
          AOD    T5
          SOD    T6
          PJN    OEL1        IF MORE CHARACTERS TO CLEAR
          LDD    T7
          SBN    24D
          NJN    OEL2        IF NOT DFT ERROR MESSAGE
          LDC    OELB        POST DFT MESSAGE
          UJN    OEL3        CONTINUE PROCESSING

 OEL2     LDC    OELC        POST SYSTEM MESSSAGE
 OEL3     RJM    MBC         MOVE BLOCK OF CHARACTERS
          LDD    BP
          RAD    T7          ADD IN CHARACTER COUNT
          LDN    0#20        NOTHING SMALLER THAN A BLANK
          RJM    UPK
          LDD    T7          RESET ENDING VALUE OF BP
          STD    BP
          LDC    **
 OELA     EQU    *-1         (CHARACTER COUNT)
          SBN    24D
          NJN    OEL4        IF NOT DFT MESSAGE
          LDC    OELD        TERMINATE DFT MESSAGE
          RJM    MBC
 OEL4     LJM    CKQ         RETURN

 OELB     BSS    0           DISPLAY DFT MESSAGE
          CON    0#1E,0#44   TURN ON INVERSE VIDEO
          CON    0#06,0#0E   SET UNDERLINE AND BLINK
          CON    0#07,0#07   SOUND BELL
          CON    0#07
          CON    0#02,0#55   POSITION CURSOR
          CON    0#20
          CON    0           END OF BLOCK

 OELC     BSS    0           DISPLAY SYSTEM MESSAGE
          CON    0#02,0#20   POSITION CURSOR
          CON    0#20
          CON    0           END OF BLOCK

 OELD     BSS    0           TERMINATE DFT MESSAGE
          CON    0#1E,0#45   TURN OFF INVERSE VIDEO
          CON    0#15,0#0F   END UNDERLINE AND BLINK
          CON    0           END OF BLOCK
 OUT      SPACE  4,10
**        OUT - SET UP OUTPUT LINE.
*
*         PLACES NEXT LINE INTO BUFFER IF NOT IN USE.
*
*         EXIT   TO *CKQ* IF NEW LINE OUTPUT.
*                TO *SMPX* IF NOT A VALID LINE.
*
*         USES   BP.
*
*         CALLS  SLP, UPK.


 OUT      BSS    0
          LDML   BUFF        PRINT COORDINATES
          NJN    OUT0        IF VALID LINE
          LJM    SMPX        RETURN

 OUT0     RJM    SLP         SET LINE POSITION
          LDML   BUFF+1
          LPC    377B
          STM    OUTA        STORE DISPLAY ATRIBUTE
          NJN    OUT1        IF SPECIAL ATTRIBUTES
          LJM    OUT5        ELSE PRINT LINE

 OUT1     SBN    1
          ZJN    OUT4        IF INVERSE VIDEO
          SBN    2-1
          NJN    OUT2        IF NOT INPUT LINE
          LDML   BUFF+1
          SHN    -8D
          NJN    OUT5        IF LINE LENGTH <> 0
          LDC    0#40        '@' FOR COMMAND PROMPT
          STIAO  BP
          UJN    OUT5        PRINT LINE

 OUT2     SBN    3-2
          NJN    OUT3        IF NOT BLINKING
          LDN    0#0E        SET BLINK
          STIAO  BP
          UJN    OUT5        CONTINUE

 OUT3     SBN    4-3
          NJN    OUT5        IF NOT BOTH BLINK AND INVERSE
          LDN    7           RING BELL
          STIAO  BP
          LDN    0#0E        SET BLINK
          STIAO  BP
 OUT4     LDN    0#1E        SEND 1E(16),44(16)
          STIAO  BP
          LDC    0#44
          STIAO  BP
          LDN    6           UNDERLINE FIELD
          STIAO  BP
 OUT5     LDN    0#20        REPLACE ALL CHARACTERS LESS THEN 20(16)
          RJM    UPK         UNPACK OUTPUT LINE
          LDML   BUFF+1
          SHN    -8D
          SBD    T2          SUBTRACT BLANKS REMOVED
          ADC    -80D
          PJN    OUT6        IF 80 BYTES OR MORE (BLINK CODES FOUND)
          LDN    0#1E        ERASE TO END OF LINE EXTEND ATTRIBUTE
          STIAO  BP
          LDN    0#2A
          STIAO  BP
 OUT6     LDM    OUTA
          SBN    1
          ZJN    OUT8        IF INVERSE VIDEO
          SBN    3-1
          NJN    OUT7        IF BLINK NOT SET
          LDN    0#F         TURN OFF BLINK
          STIAO  BP
          UJN    OUT9        RESET POINTERS FOR MUX

 OUT7     SBN    4-3
          NJN    OUT9        IF BLINKING INVERSE NOT SET
          LDN    0#F         TURN OFF BLINK
          STIAO  BP
 OUT8     LDN    0#1E        TURN OFF INVERSE VIDEO
          STIAO  BP
          LDC    0#45
          STIAO  BP
          LDN    0#15        END UNDERLINE
          STIAO  BP
 OUT9     AOM    SCMT+CMOV.
          LJM    CKQ         RESET POINTERS FOR MUX

 OUTA     BSS    1
 RKI      SPACE  4,10
**        RKI - RETURN KEYBOARD INPUT.
*
*         IF RKIA. FLAG ALLOWS NEW KEYBOARD INPUT TO BE SENT THEN
*         ID COUNTER IS UPDATED FOR NOS/VE AND UP TO THREE CHARACTERS
*         ARE SENT TO NOS/VE.
*
*         CALLS  GKC, NVS, UDB.
*
*         USES   T1.


 RKI      SUBR               ENTRY/EXIT
          LDM    SCMT+RKIA.
          NJN    RKIX        IF KEYBOARD INPUT CANNOT BE SENT
          RJM    GKC         GET A CHARACTER
          ZJN    RKIX        IF NO NEW INPUT
          STD    T1
          LDML   SCMT+COMM.
          SHN    -8D
          ADN    1           INCREMENT ID COUNTER
          SHN    8D
          STML   SCMT+COMM.
          LDD    T1          PUT FIRST CHARACTER IN
          RAML   SCMT+COMM.
          RJM    GKC
          SHN    8D
          STML   SCMT+COMM.+1
          RJM    GKC
          RAML   SCMT+COMM.+1
          LDN    1
          STM    SCMT+RKIA.
          RJM    UDB         STORE NUMBER OF WORDS TO WRITE
          RJM    NVS         NOTIFY VIRTUAL SYSTEM
          LJM    RKIX        RETURN
 SLP      SPACE  4,10
**        SLP - SET LINE POSITION.
*
*         SCROLLS A FIELD (IF NECESSARY) AND POSITIONS
*         THE CURSOR FOR THE NEXT LINE TO BE OUTPUT.
*
*         ENTRY  (A) = DISPLAY COORDINATES.
*
*         USES   T1, BP.


 SLP      SUBR               ENTRY/EXIT
          STDL   T1
          SHN    -8D
          ZJN    SLP1        IF NOT A SCROLLED LINE
          ADN    31D         BIAS
          STM    2,BP        SET UPPER LINE OF SCROLL FIELD
          LDN    0#1E        TELL 721 TO SCROLL
          STI    BP
          STM    4,BP        ISSUE SCROLL FUNCTION TO 721
          LDC    0#57
          STM    1,BP
          LDDL   T1
          LPC    0#FF
          ADN    31D
          STM    3,BP        SET LOWER LINE OF SCROLL FIELD
          LDC    0#55
          STM    5,BP
          LDN    6
          RAD    BP          BRING POINTER UP TO DATE
 SLP1     LDN    2           POSITION TO COLUMN 1 OF NEW LINE
          STIAO  BP
          LDN    31D+1       SET COLUMN 1
          STIAO  BP
          LDD    T1
          LPN    37          LINE NUMBER 0 - 29
          ADN    31D
          STIAO  BP          SET DESIRED LINE
          LJM    SLPX        RETURN
 UPK      SPACE  4,13
**        UPK - UNPACK STRING.
*
*         *UPK* UNPACKS THE CURRENT STRING IN *BUFF* AND
*         PUTS IT IN *CHRB.*, ONE CHARACTER PER PP WORD.
*
*         ENTRY  (A) = SMALLEST VALID CHARACTER.
*
*         EXIT   (T2) = NUMBER OF BLANKS AT THE END OF LINE.
*
*         USES   T1, T2, T3, T4, T5, T6, BP.


 UPK      SUBR               ENTRY/EXIT
          STD    T3          SAVE SMALLEST VALID CHARACTER
          LDC    BUFF+4
          STD    T4          SAVE ADDRESS OF BUFFER TO UNPACK
          LDML   BUFF+1
          SHN    -8D
          STD    T2          GET LENGTH OF LINE
          ZJN    UPKX        IF LINE LENGTH IS ZERO
          ADC    -81D        TEST FOR LINE TOO LONG
          MJN    UPK0        IF NOT
          LDC    80D
          STD    T2          RESET FOR JUST 80 CHARACTERS
 UPK0     LDD    BP          SAVE BEGINNING ADDRESS
          STD    T5

*         IF THE LINE IS NOT ALREADY DESIGNATED AS A FLASHING LINE,
*         THEN IT IS ALLOWED TO CONTAIN TWO CONTROL CODES TO TURN
*         BLINK MODE ON AND OFF FOR A FIELD WITHIN THE LINE. WHEN
*         THE FIRST CODE TO ENABLE BLINKING AND THE FIRST CODE TO
*         DISABLE BLINKING ARE EACH ENCOUNTERED, A BLANK CHARACTER
*         IS INSERTED IN THE OUTPUT BUFFER FOLLOWING THE CONTROL
*         CODE SO THAT A BLANK APPEARS AT THAT POSITION ON THE
*         CONSOLE DISPLAY LINE.

          LDML   BUFF+1
          LPC    377B
          STM    OUTA        RESET OUTA IN CASE CALL WAS NOT FROM -OUT-
          SBN    3
          ZJN    UPK1        IF LINE IS IN BLINK MODE
          LDN    0#0E        SET TO SEARCH FOR -BLINK ON- CODE
 UPK1     STD    T6
 UPK2     LDIL   T4          GET TWO CHARACTERS FROM BUFF
          SHN    -8D
          LPC    0#7F        TRIM TO SEVEN BIT ASCII
          STD    T1
          STIAO  BP          PUT FIRST CHARACTER IN BUFFER
          LDD    T6
          ZJN    UPK4        IF NOT CHECKING FOR BLINK ON/OFF CODES
          SBD    T1
          NJN    UPK4        IF NOT THE CODE BEING SOUGHT
          LDD    T6
          SBN    0#0F
          ZJN    UPK3        IF -BLINK OFF- CODE SOUGHT AND FOUND
          LDN    0#07        -BLINK ON- FOUND, SOUND A BELL
          STIAO  BP
          LDN    0#0F        SET TO SEARCH FOR -BLINK OFF-
 UPK3     STD    T6
          LDN    0#20
          STIAO  BP          STORE A BLANK AFTER THE CONTROL CODE
 UPK4     SOD    T2
          ZJN    UPK9        IF DONE WITH LINE
          LDI    T4
          LPC    0#7F        TRIM TO SEVEN BIT ASCII
          STD    T1
          STIAO  BP          PUT SECOND CHARACTER IN BUFFER
          LDD    T6
          ZJN    UPK6        IF NOT CHECKING FOR BLINK ON/OFF CODES
          SBD    T1
          NJN    UPK6        IF NOT THE CODE BEING SOUGHT
          LDD    T6
          SBN    0#0F
          ZJN    UPK5        IF -BLINK OFF- BEING SOUGHT AND FOUND
          LDN    0#0F        SET TO SEARCH FOR -BLINK OFF- CODE
 UPK5     STD    T6
          LDN    0#20
          STIAO  BP          STORE A BLANK AFTER THE CONTROL CODE
 UPK6     AOD    T4
          SOD    T2
          ZJN    UPK7        IF FINISHED UNPACKING LINE
          LJM    UPK2        NOT FINISHED UNPACKING LINE

 UPK7     LDM    OUTA
          SBN    3
          ZJN    UPK8        IF LINE IS ALREADY IN BLINK MODE
          LDN    0#0E        SET TO SEARCH FOR -BLINK ON- CODE
 UPK8     STD    T6
 UPK9     LDI    T5          TEST FOR ILLEGAL CHARACTERS
          SBD    T3
          PJN    UPK12       IF PRINTABLE CHARACTER
          LDD    T6
          ZJN    UPK11       IF NOT CHECKING FOR BLINK CONTROL CODES
          LDI    T5
          SBD    T6
          NJN    UPK11       IF NOT THE BLINK CODE BEING SOUGHT
          LDD    T6
          SBN    0#0F
          ZJN    UPK10       IF -BLINK OFF- SOUGHT AND FOUND
          AOD    T5          SKIP THE BELL INSERTED AFTER -BLINK ON-
          LDN    0#0F        SET TO SEARCH FOR -BLINK OFF- CODE
 UPK10    STD    T6
          UJN    UPK13       GO CHECK TO SEE IF WE ARE FINISHED

 UPK11    LDN    0#3F        REPLACE UNPRINTABLE CHARACTER WITH *?*
          STI    T5
 UPK12    LDI    T5          TEST FOR PAGE CLEAR
          SBN    0#0C
          NJN    UPK13       IF NOT PAGE CLEAR
          STM    CDLA        RESET TO DISPLAY DFT LINE
          STM    CELA        RESET TO DISPLAY ERROR LINE
          STM    COAA        RESET TO DISPLAY FLASHING *170* IF NECESSARY
 UPK13    AOD    T5
          SBD    BP
          NJN    UPK9        IF NOT DONE WITH LINE
          LDD    T6
          SBN    0#0F        CHECK FOR -BLINK OFF- BEING SOUGHT
          NJN    UPK14       IF NOT SEARCHING FOR -BLINK OFF- CODE

*         IF THE END OF LINE HAS BEEN REACHED AND A -BLINK OFF- IS
*         STILL NEEDED TO TERMINATE A BLINKING FIELD, THEN FORCE
*         ONE INTO THE OUTPUT CHARACTER BUFFER.

          LDN    0#0F
          STIAO  BP
 UPK14    SOD    BP          TEST FOR TRAILING BLANKS
          AOD    T2          COUNT BLANKS REMOVED
          LDI    BP
          SBN    0#20
          ZJN    UPK14       IF FOUND A BLANK
          SOD    T2
          AOD    BP
          LJM    UPKX        RETURN
 VES      SPACE  4,10
**        VES - NOS/VE STARTUP ROUTINE.
*
*         SETS UP THE CONSOLE FOR NOS/VE USE.
*
*         EXIT   (SCMT+RTNP.) = *VED*.
*
*         USES   T1.


 VES      ROUTINE            ENTRY

          LDC    VESA        MOVE NOS/VE CONSOLE SETUP TEXT
          STD    T1
 VES1     LDI    T1          GET NEXT CHARACTER
          ZJN    VES2        IF END OF TEXT
          STIAO  BP
          AOD    T1
          UJN    VES1        LOOP

 VES2     LDN    1
          STM    SCMT+CMOV.  RESET CURSOR
          STM    SCMT+KBIP.
          LDN    0#0C        NOTIFY HOST TO REFRESH DISPLAYS
          STM    SCMT+CHARS.
          LDN    0
          STM    SCMT+RKIA.  ALLOW INPUT TO BE RETURNED
          STM    SCMT+KBOP.  RESET KEYBOARD BUFFER
          STM    SCMT+CHARS.+1
          STM    SCMT+CHARS.+2
          STM    SCMT+CHARS.+3
          LDN    0+0#20
          STM    SCMT+XPOS.
          ADN    30D
          STM    SCMT+YPOS.
          LDC    VED
          STI    PT          PUT MAIN ROUTINE ADDRESS IN RTNP.
          LJM    CKQ         RETURN

 VESA     BSS    0           CONSOLE SETUP TEXT
          CODE   ASCII
          CON    0#0D,0#0D   TERMINATE POSSIBLE MULTIPLE CODE SEQUENCE
          CON    0#1E,0#33   DISABLE HOST LOADED CODE
          CON    0#1E,0#12   ENTER LARGE CYBER MODE
          CON    0#42
          CON    0#1E,0#12   SELECT 30 LINES
          CON    0#5E
          CON    0#1E,0#12   SET 80 CHARACTER LINE AND CLEAR SCREEN
          CON    0#48
          CON    0#1E,0#30   ENABLE CODE BIAS
          CON    0#1E,0#12   SHIFT NUMERIC PAD
          CON    0#6B
          CON    0#16        PAGE SCREEN
          CON    0#02,0#30   POSITION CURSOR
          CON    0#30
          CON    1RS+40,1RC+40  SCD/VE
          CON    1RD+40,1R/+40
          CON    1RV+40,1RE+40
          CON    0           TERMINATOR

          CODE   *

          OVERFLOW  SCMT     CHECK FOR OVERFLOW

          ENDX
*DECK DECK=CTI$SCI_TPM_PRESET EXPAND=FALSE
          CTEXT  SCI TPM PRESET
          OVERLAY  (SCI PRESET MODE TABLES),OVLA
 PMT      SPACE  4,10
**        PMT - PRESET MODE TABLES.
*
*         THIS ROUTINE IS ENTERED FROM THE BOOT CODE.
*
*         ENTRY  (TIMC), (TIMD), (TIME) SET FOR 12-BIT CLOCK.
*
*         EXIT   MODE TABLE(S) INITIALIZED.
*                (TIMA) INITIALIZED FROM CHANNEL 14.
*                (TIMC), (TIMD), (TIME) MODIFIED FOR 16-BIT CLOCK IF S0/S0E.
*
*         CALLS  FHE, SMM, SSM, *SMT*.


 PMT      ROUTINE

          LDML   S0FLG       CHECK IF CY2000
          LMC    10000
          ZJP    PMT2        IF CY2000
          LDN    DISCID      GET CONSOLE DESCRIPTOR
          RJM    FHE
          LDM    CTUF        CHECK FOR CTI UTILITY MODE *MDD*
          NJN    PMT1        IF SO THEN NO *SCD*
          RJM    SSM         SET *SCD* MODE
 PMT1     RJM    SMM         SET *MDD* MODE
          LDM    CTUF        CHECK FOR CTI UTILITY MODE *MDD*
          ZJN    PMT1.1      IF NOT A UTILITY
          LDC    CCFI        GET CLEAR CHANNEL FLAG OP-CODE
          LMM    PPNO        PLACE PP-S CHANNEL NUMBER
          STM    PMTA
          PSN                NEED FOR S0/S0E
 PMTA     CCF    *,**        CLEAR CHANNEL FLAG FOR *SCI* PP
 PMT1.1   BSS    0
          LOADOV IDL         LOAD IDLE OVERLAY
          IAN    14          INITIALIZE TIMER BASE TIME
          STML   TIMA
          LDM    S0FLG       CHECK MAINFRAME TYPE
          ZJN    PMT2        IF NOT S0/S0E
          LDC    SBMLI       CHANGE *SBM* TO *SBML* FOR 16-BIT CLOCK
          STML   TIMC
          LDC    ADCI+20     SET CLOCK OVERFLOW ADJUSTMENT FOR 16-BIT CLOCK
          STM    TIMD
          LDC    RAMLI       CHANGE *RAM* TO *RAML* FOR 16-BIT CLOCK
          STML   TIME
 PMT2     CALL   SMT         CONTINUE
 RMD      SPACE  4,10
**        RMD - RESTORE MISCELLANEOUS DATA FROM CM TABLES.
*
*         ENTRY  *SCI* HAS BEEN RESTARTED BY *DFT*.
*
*         EXIT   TO *PMT*.
*                (DP - DP+1, DFTO) = *DFT* POINTERS FROM EICB.
*                (SB - SB+1, SBAO) = SCDPT POINTERS FROM EICB.
*
*         USES   T1 - T5.
*
*         CALLS  GSI, IIB, PIB, SPA, SSR, *PMT*.


 RMD      ROUTINE

          RJM    PIB         INITIALIZE EICB POINTER
          LDN    DSDFT       RESTORE *DFT* POINTERS
          RJM    IIB
          CRDL   T1
          LDDL   T1
          STML   DFTO
          LRD    T1+1
          SRD    DP
          RJM    SSR         RESTORE *SSR* POINTER
          RJM    SPA         SET UP R-REGISTER FOR *SCI* PARAMETER TABLE
          RJM    GSI         GET *SCI* PARAMETER TABLE INTERLOCK
          LDDL   CM+1        CLEAR BOTH DEFINITION CHANGED FLAGS
          LPC    0#3FFF
          STDL   CM+1

*         UPDATE PORT STATUSES.

          LDDL   CM+2        DETERMINE *SCD* MODE
          ZJN    RMD1        IF *SCD* NOT ACTIVE
          LPN    1
          STD    T5
          LDC    0#8000      SET *SCD* DEFINITION CHANGED
          RADL   CM+1
          LDML   RMDA,T5     SHOW *SCD* ACTIVE ON PORT X
          STML   SCMT+PTUS.
          STML   EMC0,T5
 RMD1     LDDL   CM+3        DETERMINE *MDD* PORT
          ZJN    RMD2        IF *MDD* NOT ACTIVE
          LPN    1
          STD    T5
          LDC    0#4000      SET *MDD* DEFINITION CHANGED
          RADL   CM+1
          LDML   RMDB,T5     SHOW *MDD* ACTIVE ON PORT Y
          STML   MDMT+PTUS.
          STML   EMC0,T5
 RMD2     LDML   SBAO        REWRITE DEFINITION CHANGED FLAGS IN SCDPT
          ADC    RR
          CWDL   CM          WRITE FLAGS AND CLEAR INTERLOCK
          LJM    PMT         PRESET MODE TABLES

 RMDA     CON    10002,10005 *SCD* PORT 0, PORT 1 FLAGS
 RMDB     CON    10002,10005 *MDD* PORT 0, PORT 1 FLAGS
 RMT      SPACE  4,10
**        RMT - RELOCATE PARAMETER TABLE.
*
*         ENTRY  (T2 - T3) = NEW ADDRESS (12-BIT FORMAT) OF SCDPT.
*
*         CALLS  SPB, STA, *SMT*.


 RMT      ROUTINE

          AOM    SCMT+CMBS.  SET FLAG FOR *CPW* ROUTINE
          LDD    T2          CONVERT ADDRESS FROM 12- TO 16-BIT FORMAT
          SHN    14
          LMD    T3
          STDL   W3
          SHN    -20
          STD    W2
          RJM    STA
          STM    SBAO        RESET OFFSET
          SRD    SB          SAVE NEW R-REGISTER

*         PRIOR TO CORRECTIVE CODE FOR PSR NS2F653, NOS DID NOT SET
*         UP THE *SCD* PARAMETER BLOCK CORRECTLY -
*         1)  THE *SCD*/*MDD* DEFINITION CHANGED FLAGS WERE NOT USED.
*         2)  *MDD* WAS NOT DESCRIBED.
*         3)  THE *SCD* PORT WAS ALWAYS REPORTED AS ZERO.
*
*         THE FOLLOWING CODE MODIFIES THE ORIGINAL TABLE TO REFLECT THE
*         ACTUAL *SCD* AND *MDD* INFORMATION AND TO SET THE *SCD* FLAG.
*
*         NOTE THAT THIS CODE DOES NOT FOLLOW INTERLOCK PROTOCOL ON THE
*         *SCI* PARAMETER TABLE.  THERE IS NO NEED TO BECAUSE THE ONLY
*         TIME THIS CODE IS EXECUTED IS VERY EARLY IN NOS DEADSTART
*         DURING THE HANDOFF FROM *SET* TO *DSD*.  NO OTHER CODE IS
*         LOOKING AT THE TABLE AT THIS TIME.
*
*         NOTE ALSO THAT THE SETTING OF THE *SCD* CHANGED FLAG CAUSES
*         *CPW* TO EVENTUALLY GET CALLED WHICH THEN CORRECTLY SETS UP THE
*         CM BUFFER SIZE IN *CMBS.*.  IF THIS CODE IS REMOVED, THAT
*         PROTOCOL MUST ALSO BE CHANGED.

          ADC    RR          READ HEADER WORD
          CRDL   CN
          LDDL   CN+1        CHECK FOR NS2F653 FIX INSTALLED
          LPC    0#C000
          NJN    RMT1        IF *SCD*/*MDD* DEFINITION CHANGED SET
          LDC    0#8000      SET *SCD* DEFINITION CHANGED FLAG
          RADL   CN+1
          LDM    SCMT+PTDB.  SET CURRENT *SCD* PORT BITS
          LPN    3
          RADL   CN+2
          LDML   MDMT+PTDB.  SET CURRENT *MDD* DEFINITION
          SCN    77
          STDL   CN+3
          RJM    SPB         SET PP BOUNDARY
          LDM    SBAO        REWRITE HEADER WORD
          ADC    RR
          CWDL   CN
 RMT1     CALL   SMT         GO RESET THE TABLE
 SMM      SPACE  4,10
**        SMM - SET *MDD* MODE.
*
*         ENTRY  (HBUF) = CONSOLE DESCRIPTOR.
*                (SCIA) = 2000 + PP NUMBER IF C170 *MDD* MODE INITIATED.
*
*         EXIT   (PTDB.) INITIALIZED.
*
*         USES   PT, CM - CM+3.
*
*         CALLS  IIB.


 SMM      SUBR               ENTRY/EXIT
          LDM    NOSL        TEST IF LOADED BY NOS
          ZJN    SMMX        IF SO RETURN
          LDC    MDMT        SET *MDD* TABLE
          STD    PT
          LDM    SCIA
          SHN    21-12
          PJN    SMM1        IF NOT INITIATED BY C170 STATE
          LDN    D7RS        GET PORT NUMBER FROM EICB
          RJM    IIB
          CRDL   CM
          LDD    CM+1        POSITION PORT BITS
          SHN    -4
          LPC    0700        ISOLATE PORT BITS
          LMC    4000
          UJN    SMM2        SAVE VALUES

 SMM1     LDM    HBUF+CDCMDD+1
          SHN    21-3        TEST *MDD* FLAG
          PJN    SMMX        IF NO *MDD*
          SHN    21-13-21+3
          LPC    0700        ISOLATE PORT BITS
          LMC    4000
 SMM2     STM    MDMT+PTDB.  SET VALUE OF *PTDB.*
          LJM    SMMX        RETURN
 SSM      SPACE  4,10
**        SSM - SET *SCD* MODE.
*
*         ENTRY  (HBUF) = CONSOLE DESCRIPTOR.
*
*         EXIT   (PTDB.) INITIALIZED.


 SSM      SUBR               ENTRY/EXIT
          LDN    0           ASSUME SCD MODE UNDEFINED
          STD    CN+3        CLEAR NOS CHANNEL BY DEFAULT
          STM    SCMT+PTDB.
          LDD    DO          GET DEADSTART TYPE
          NJN    SSMX        IF 180 WAIT TO START SCD
          LDM    HBUF+CDCDTYP
          ZJN    SSMX        IF CC545 DEADSTART
          LDM    HBUF+CDCPFLG  GET PORT NUMBER
          LPN    3
          LMC    DEFAULT     SET ACTIVE REAL STATE MODE
          STM    SCMT+PTDB.
          UJN    SSMX        RETURN
          SPACE  4,10
 SCIA     EQU    /PRESET/SCIA

          OVERFLOW SCMT      CHECK FOR OVERFLOW
          OVERLAY  (SCI UPDATE MODES/PORTS),OVLA
 SMT      SPACE  4,10
**        SMT - SET/RESET MODE TABLE.
*
*         LOOKS THROUGH THE *SCDPT* TO DEFINE THE MODE TABLES.
*
*         ENTRY  (T1, T2) = ADDRESS OF *SCDPT*.
*
*         EXIT   TO *EMC*.
*
*         USES   CM - CM+3, CN - CN+3, PT, T3, T4.
*
*         CALLS  CPW, MTA, SPB, UMM, UPD, USM.


 SMT5     LDC    MDMT        PROCESS *MDD* MODE
          STD    PT
          LDML   MDMT+PTDB.
          RJM    UMM         UPDATE *MDD* MODE TABLE
          LDC    SCMT        SET TO *SCD* MODE TABLE
          STD    PT
          LDML   SCMT+PTDB.
          RJM    USM         UPDATE *SCD* MODE DEFINITION
          LJM    EMC         ESTABLISH MODE CONNECTIONS

 SMT      ROUTINE            ENTRY/EXIT

          RJM    MTA         CHECK FOR PARAMETER TABLE
          ZJN    SMT5        IF NO *SCI* PARAMETER TABLE
          RJM    SPB         SET PP BOUNDARY
          LDC    SCMT
          STD    PT
 SMT1     LDN    0
          STD    CM
          LDC    SPIB        SET INTERLOCK BIT
          STDL   CM+1
          LDML   SCMT+PTDB.
          LPC    10000       MASK FOR ATTACHED BIT
          STDL   CM+2
          LDML   MDMT+PTDB.
          LPC    10000       MASK FOR ATTACHED BIT
          STDL   CM+3
          LDM    SBAO
          LMC    RR          ACTIVATE R-REGISTER
          RDSL   CM          SET INTERLOCK AND ATTACHED BITS
          CRDL   CN
          LDDL   CM+1
          LPC    SPIB
          NJN    SMT1        IF INTERLOCK ALREADY SET
          LDDL   CN+1        CHECK *SCD* DEFINITION CHANGED FLAG
          SHN    21-17
          PJN    SMT3        IF *SCD* DEFINITION NOT CHANGED
          LDDL   CN+2
          RJM    USM         UPDATE MODE DEFINITION

*         REREAD FIRST WORD OF *SCI* PARAMETER TABLE BECAUSE CODE IN *USM* MAY
*         HAVE CHANGED IT.

          RJM    MTA         GET MODE TABLE ADDRESS
          CRDL   CN
          LDD    CN+1        CHECK BLOCK LENGTH
          LPN    17
          SBN    4
          MJN    SMT3        IF NO PARAMETER WORDS
          STD    T3
          LDM    SBAO
          STD    T4
 SMT2     LDD    T4
          ADC    RR+3
          CRDL   W0
          RJM    CPW         CHECK PARAMETER WORD
          AOD    T4
          SOD    T3
          PJN    SMT2        IF MORE WORDS TO PROCESS
 SMT3     LDC    MDMT        TEST *MDD* MODE
          STD    PT
          LDDL   CN+1        CHECK *MDD* DEFINITION CHANGED FLAG
          SHN    21-16
          PJN    SMT4        IF *MDD* DEFINITION NOT CHANGED
          LDI    PT          SAVE CURRENT ROUTINE
          STML   MDMT+NRTP.
          LDDL   CN+3
          RJM    UMM         UPDATE *MDD* MODE

*         REREAD FIRST WORD OF *SCI* PARAMETER TABLE BECAUSE CODE IN *UMM* MAY
*         HAVE CHANGED IT.

 SMT4     RJM    MTA         GET MODE TABLE ADDRESS
          CRDL   CN
          LDDL   CN+1        CLEAR DEFINITION CHANGED FLAGS AND INTERLOCK BIT
          STD    CN+1
          RJM    MTA         GET MODE TABLE ADDRESS
          CWDL   CN          WRITE CLEARED CHANGED FLAGS AND INTERLOCK BIT
*         UJN    EMC         GET PORTS ATTACHED

          ERRNZ  EMC-*       CODE ASSUMES CONTIGUOUS LOCATIONS
 EMC      SPACE  4,10
**        EMC - ESTABLISH TWO PORT MUX CONNECTION.
*
*         THIS ROUTINE GETS ACCESS TO THE PROPER PORT ON THE TWO PORT
*         MULTIPLEXOR.  *PTUS.* IS SET UP WITH THE PROPER VALUES FOR THE
*         PORTS WHICH HAVE BEEN OBTAINED BY THE MODE.
*
*         ENTRY  (*PTDB.*) = DEFINED FOR PORTS.
*
*         EXIT   TO *IDL*.
*
*         USES   T7, PT.
*
*         CALLS  SPM.
*
*         RESETS RTNP. TO 0 IF ACCESS FAILS.
*                      TO *ACL* IF ACCESS SUCCESSFUL.


 EMC      ROUTINE            ESTABLISH PORT CONNECTION

          LDC    SCMT        WORK ON *SCD* MODE TABLE FIRST
 EMC1     STD    PT
          LDML   PTDB.,PT    GET PORT BITS FROM THE DEFINITION BYTE
          NJN    EMC3        IF MODE IS DEFINED
 EMC2     LJM    EMC8        CONTINUE FOR UNDEFINED MODE

 EMC3     SHN    21-14       CHECK MODE/PORT STATUS
          MJN    EMC2        IF MODE ALREADY HAS PORT
          SHN    21-13-21+14
          PJN    EMC2        IF MODE NOT ACTIVE
          LDML   PTDB.,PT    GET PORT BITS FROM THE DEFINITION BYTE
          LPN    3
          STD    T7
          SBN    2           CHECK IF BOTH PORTS WANTED
          PJN    EMC4        IF BOTH PORTS WANTED

*         GET SINGLE PORT.

          LDD    T7          SET PORT DESIRED
          RJM    SPM         SELECT PORT ON MULTIPLEXOR
          ZJP    EMC7        IF ACCESS FAILED SET NEXT ROUTINE TO ZERO
          LDC    SHNI        FORM SHIFT INSTRUCTION
          LMD    T7          FORM SHIFT INSTRUCTION
          STM    EMCA
          LDN    2           ASSUME PORT 0
 EMCA     SHN    **          NO SHIFT FOR PORT 0
*EMCA     SHN    1           SHIFT ONE FOR PORT 1
          LMC    10000       SET HAVE ONE PORT
          RADL   T7          ADD IN INPUT PORT NUMBER
          LDM    PTUS.,PT    UPDATE PORTS ATTACHED
          SCN    7           CLEAR ALL PORT FLAGS
          LMDL   T7          SET DESIRED PORT FLAGS
          STML   PTUS.,PT
          LJM    EMC6        FINISH WORK

*         GET FIRST PORT OF TWO PORTS.

 EMC4     STD    T7          SAVE INPUT PORT
          LDML   PTUS.,PT    GET CURRENT VALUE
          SCN    1
          LMDL   T7          SET NEW INPUT PORT
          STML   PTUS.,PT
          LDN    0           GET PORT ZERO
          RJM    SPM         SELECT PORT ON MULTIPLEXOR
          ZJN    EMC5        IF ACCESS FAILED
          LDM    PTUS.,PT    UPDATE PORTS ATTACHED
          LPC    20005       CLEAR PORT 0 FLAG
          LMC    10002       UNCONDITIONALLY SET PORT 0 FLAG
          STML   PTUS.,PT

*         GET SECOND PORT OF TWO PORTS.

 EMC5     LDN    1           GET PORT ONE
          RJM    SPM         SELECT PORT ON MULTIPLEXOR
          ZJN    EMC7        IF ACCESS FAILED CLEAR NEXT ROUTINE
          LDML   PTUS.,PT    UPDATE PORTS ATTACHED
          LPC    10003       CLEAR PORT 1 FLAG
          LMC    20004       UNCONDITIONALLY SET PORT 1 FLAG
          STML   PTUS.,PT
 EMC6     LDC    ACL         ACTIVATE CONTROLWARE LOAD AS NEXT ROUTINE
 EMC7     STI    PT          SET NEXT ROUTINE
 EMC8     LDD    PT          TEST IF TRIED BOTH MODE TABLES
          LMC    SCMT
          NJP    IDL         IF BOTH *SCD* AND *MDD* PROCESSED
          LDC    MDMT        SET TO *MDD* MODE TABLE
          LJM    EMC1        LOOP
 RPR      SPACE  4,10
**        RPR - RELINQUISH PORT RESERVATION.
*
*         EXIT   TO *SMPX*.
*
*         CALLS  DLY, GSI, MTA, RPT.


 RPR      ROUTINE

          RJM    MTA         GET MODE TABLE ADDRESS
          ZJN    RPR1        IF TABLE NOT DEFINED
          RJM    GSI         GET *SCI* PARAMETER TABLE INTERLOCK
 RPR1     RJM    RPT         RELINQUISH PORT
          RJM    MTA         GET MODE TABLE ADDRESS
          ZJN    RPR2        IF TABLE NOT DEFINED
          CRDL   CM
          LDDL   CM+1        CLEAR TABLE INTERLOCK
          LPC    0#EFFF
          STDL   CM+1
          RJM    MTA         GET MODE TABLE ADDRESS
          CWDL   CM          WRITE CLEARED INTERLOCK
 RPR2     LDC    1000D       SET NUMBER OF MILLISECONDS
          RJM    DLY         DELAY FOR ONE SECOND
          LJM    SMPX        RETURN TO IDLE LOOP
 CLR      SPACE  4,10
**        CLR - CLEAN UP PORT DEFINITION.
*
*         ENTRY  (PT) = PORT TABLE ADDRESS.
*
*         USES   T5, T6.
*
*         CALLS  RPT.


 CLR      SUBR               ENTRY/EXIT
          LDML   PTDB.,PT
          ZJN    CLRX        IF ALREADY CLEAN
          SHN    21-14
          PJN    CLR1        IF PORT NOT ATTACHED
          RJM    RPT         CLEAR PORT RESERVATION
 CLR1     LDC    MTBL.L
          STD    T6
          LDD    PT
          STD    T5
 CLR2     LDN    0
          STIAO  T5          CLEAR ALL OF PORT TABLE
          SOD    T6
          PJN    CLR2
          UJN    CLRX        RETURN
 CPW      SPACE  4,10
**        CPW - CHECK PARAMETER WORD.
*
*         TESTS IF A CM BUFFER IS DEFINED AND INITIALIZES POINTERS.
*
*         ENTRY  (W0 - W3) = PARAMETER WORD.
*
*         USES   PT.


 CPW10    LDC    NOSBI       SET NOS ROUTINE LIST
          STM    NRTL.,PT

 CPW      SUBR               ENTRY/EXIT
          LDDL   W0
          SHN    -17+6
          LPN    7           ISOLATE PARAMETER WORD TYPE
          SBN    2
          MJN    CPWX        IF NOT BUFFER DEFINITION
          SBN    2
          PJN    CPWX        IF NOT BUFFER DEFINITION
          LDC    SCMT        FETCH PORT TABLE ADDRESS
          STD    PT
          LDDL   W2          FORM R-REGISTER
          SHN    22-6+4
          STM    SCMT+RRUP.  SAVE R-UPPER
          SHN    14
          STM    SCMT+RRLW.  SAVE R-LOWER
          LDDL   W3          STORE R-REGISTER OFFSET
          STML   SCMT+CMBA.
          STML   SCMT+CMIP.  INITIALIZE POINTERS
          STML   SCMT+CMOP.

*         IF *CMBS.* HAS BEEN SET NON-ZERO BY *RMT* THEN SAVE THE BUFFER SIZE
*         IN *CMBS*.  THIS CHECK AVOIDS THE USE OF THE BUFFER TOO EARLY IN
*         NOS DEADSTART.

          LDML   SCMT+CMBS.  CHECK IF TIME TO SAVE CM BUFFER SIZE
          ZJN    CPW5        IF NOT TIME
          LDDL   W1          SAVE BUFFER SIZE
          STML   SCMT+CMBS.
          ADML   SCMT+CMBA.  COMPUTE END OF BUFFER ADDRESS
          SBN    1
          STML   SCMT+CMBL.
 CPW5     LDM    SCMT+SCDS.
          NJP    CPW10       IF CURRENTLY *SCD/VE* STATE
          LDC    NOSBI       SET ROUTINE LIST
          STM    SCMT+RTNL.
          LJM    CPWX        RETURN
 DLY      SPACE  4,10
**        DLY - DELAY FOR (A) MILLISECONDS.
*
*         ENTRY  (A) = NUMBER OF MILLISECONDS TO DELAY.
*
*         USES   T0.


 DLY      SUBR               ENTRY/EXIT
          STD    T0
 DLY1     IAN    14          INPUT REAL-TIME CLOCK
          LPC    1024D-1     EXTRACT RANGE OF 0 .. 1023 MILLISECONDS
          SBM    DLYA
          PJN    DLY2        IF LESS THAN 1024 MICROSECONDS ELAPSED
          RAM    DLYA        UPDATE BASE TIME
          SOD    T0          DECREMENT MILLISECOND COUNTER
          ZJN    DLYX        IF DELAY EXPIRED
          UJN    DLY1        LOOP TILL DELAY EXPIRED

 DLY2     RAM    DLYA        UPDATE BASE TIME
          UJN    DLY1        LOOP

 DLYA     BSS    1
 GVI      SPACE  4,15
**        GVI - GET VIRTUAL INTERFACE.
*
*         ENTRY  R-REGISTER SET TO *SCI* PARAMETER TABLE.
*
*         EXIT   (CB - CB+1) = NOS/VE COMMUNICATIONS BLOCK R-REGISTER.
*                (SCMT+CBAO.) = NOS/VE COMMUNICATIONS BLOCK A-OFFSET.
*                (SCMT+ELAO. - SCMT+ELRL.) = NOS/VE ERROR LINE R-POINTER.
*
*         USES   W0 - W3.
*
*         CALLS  STA.


 GVI      SUBR               ENTRY/EXIT
          LDM    SBAO        GET *SCD/VE* INTERFACE POINTER ADDRESS
          ADC    RR+1
          CRDL   W0
          RJM    STA         SET UP FOR VE CM READ
          STML   SCMT+CBAO.  SAVE A-OFFSET
          SRD    CB          STORE COMMUNICATIONS BLOCK R-REGISTER
          ADC    RR+2        READ ERROR LINE (TOP LINE) RMA
          CRDL   W0
          RJM    STA
          STML   SCMT+ELAO.  SAVE ERROR LINE RMA
          LDD    W4
          STM    SCMT+ELRU.
          LDD    W5
          STM    SCMT+ELRL.
          LDC    VES         SET *SCD/VE* STARTUP ROUTINE
          STM    SCMT+NRTP.
          LRD    SB          RELOAD R-REGISTER TO POINT TO *SCD/VE* BLOCK
          LJM    GVIX        RETURN
 MTA      SPACE  4,10
**        MTA - MODE TABLE ADDRESS.
*
*         TEST FOR AND SET UP *SCDPT* ADDRESS.
*
*         EXIT   (A) = 0 IF NO *SCI* PARAMETER TABLE.
*                (A + R) = READY FOR CM ACCESS.


 MTA      SUBR               ENTRY/EXIT
          LDM    SBAO
          ADD    SB
          ADD    SB+1
          ZJN    MTAX        IF NO *SCDPT*
          LRD    SB          LOAD R-REGISTER
          LDM    SBAO
          LMC    RR          ACTIVATE R-REGISTER
          UJN    MTAX        RETURN
 PMM      SPACE  4,10
**        PMM - PRESET *MDD* MODE.
*
*         PRESETS VARIABLES FOR *MDD* MODE.


 PMM      SUBR               ENTRY/EXIT
          LDN    3           SET *DFT* FREEZE FLAG
          STM    DFTR
          LDN    12          SET REGISTER COUNT
          STM    RFPB
          LDN    11          SET REFRESH ADJUSTMENT
          STM    RRRP
          SHN    11          SET REFRESH RATE CONTROL
          STML   RDLY
          STML   MDDR
          LDN    10          SET WORD COUNT
          STM    VAL2
          LDC    MRPL        SET REGISTER LIST
          STM    MRPV
          LDC    MPSV        SET UP STATE POINTER TO POINTER
          STM    VMBA+3
          UJN    PMMX        RETURN
 RPT      SPACE  4,10
**        RPT - RELINQUISH PORT RESERVATION IN TEST MODE REGISTER.
*
*         ENTRY  *SCI* PARAMETER TABLE IS INTERLOCKED.
*
*         USES   T6.
*
*         CALLS  MTA, RTR, SMN, USB.
*
*         MACROS LOCKMR.


 RPT      SUBR               ENTRY/EXIT
          RJM    RTR         READ TEST MODE REGISTER
          SHN    -2
          LPN    3
          NJN    RPT1        IF A REQUESTED BIT IS SET
          LDM    PTDB.,PT    ELSE GET INPUT PORT FROM CURRENT MODE
          LPN    1
          UJN    RPT2        CONTINUE

 RPT1     SBN    1           SET PORT NUMBER
 RPT2     STD    T6
          LMC    SHNI        SET UP *USB*
          STM    USBA
          LDML   EMC0,T6     CLEAR PORT ATTACHED FLAG
          STM    EMC0,T6
          RJM    MTA         GET MODE TABLE ADDRESS
          ZJN    RPT3        IF PARAMETER TABLE UNDEFINED
          CRDL   CM          READ FIRST WORD OF *SCI* PARAMETER TABLE
          RJM    SMN         SET MODE NUMBER
          LDIL   T2          CLEAR PORT ATTACHED FLAG IN PARAMETER TABLE
          LPC    0#FFFF-1S12
          STIL   T2
          RJM    MTA         GET MODE TABLE ADDRESS
          CWDL   CM          WRITE CLEARED PORT ATTACHED FLAG
 RPT3     LOCKMR SET
          RJM    RTR         READMR RDATA,ELIO,ITMR
          LDC    25S12+0     CLEAR REREQUESTED, REQUESTED AND RESERVED BITS
          RJM    USB         UPDATE *TM* REGISTER
          LDML   PTDB.,PT
          STM    PTDB.,PT    CLEAR PORT ATTACHED
          LOCKMR CLEAR
          LDD    T6          SET PORT CURRENTLY UNATTACHED
          SHN    1
          LPML   PTUS.,PT
          STM    PTUS.,PT
          LDC    SMPX        WAIT FOR *TPR* TO GET PORT BACK
          STI    PT
          LJM    RPTX        RETURN
 SMN      SPACE  4,10
**        SMN - SET MODE NUMBER.
*
*         EXIT   (T2) = ADDRESS OF CM+X FOR PROPER DEFINITION.


 SMN      SUBR               ENTRY/EXIT
          LDD    PT
          LMC    SCMT
          ZJN    SMN1        IF *SCD* MODE
          LDN    1
 SMN1     ADN    CM+2
          STD    T2          SELECT CM+2 OR CM+3
          UJN    SMNX        RETURN
 SPM      SPACE  4,10
**        SPM - SELECT PORT ON MULTIPLEXOR.
*
*         ENTRY  (A) = PORT TO OBTAIN ACCESS TO.
*
*         EXIT   (A) = 0, IF ACCESS FAILED.
*
*         USES   T2.
*
*         CALLS  DLY, GSI, MTA, RTR, SCF, SMN, USB.
*
*         MACROS LOCKMR.


 SPM3     LDC    25S12+1     CLEAR REREQUESTED, REQUESTED, SET RESERVED
          STML   EMC0,T2     SAVE FACT PORT ACQUIRED
          RJM    USB
          LDM    S0FLG       TEST FOR IOU TYPE
          NJN    SPM4        IF ON AN S0/S0E
          LOCKMR CLEAR
 SPM4     RJM    MTA         GET MODE TABLE ADDRESS
          ZJN    SPM5        IF TABLE DOES NOT EXIST
          RJM    GSI         GET *SCI* PARAMETER TABLE INTERLOCK
          RJM    SMN         SET MODE NUMBER IN T2
          LDIL   T2          SET PORT ACQUIRED BIT
          LPC    0#EFFF
          LMC    0#1000
          STIL   T2
          RJM    MTA         GET *SCI* PARAMETER TABLE ADDRESS
          CWDL   CM          SET PORT ATTACHED FLAG AND CLEAR INTERLOCK
 SPM5     LDML   PTDB.,PT
          LPC    0#0FFF      SET PORT IN USE FLAG
          LMC    0#1000
          STML   PTDB.,PT
          LDK    MX          RESERVE CHANNEL 15
          RJM    SCF
          LDC    MXPT+**     SELECT PORT
 SPMB     EQU    *-1
          FAN    MX
          FNC    305,MX      SET PARAMETERS
          FNC    MXMC,MX     MASTER CLEAR PORT
          FNC    MXDM,MX     CLEAR PORT SELECTION
          AJM    *,MX        WAIT FOR FUNCTION TO COMPLETE
          CCF    *,MX

*         ON AN I2, SCI MUST DELAY AFTER A MASTERCLEAR AND BEFORE ANY CHARACTERS
*         ARE OUTPUT TO THE TPM.

          LDM    IOUM        CHECK MODEL NUMBER
          SBN    0#20
          NJN    SPMX        IF NOT MODEL 20 IOU
          LDN    50D         DELAY 50 MILLESECONDS
          RJM    DLY
          LDN    1           INDICATE ACCESS SUCCESSFUL

 SPM      SUBR               ENTRY/EXIT
          STD    T2          SAVE PORT NUMBER
          LDML   EMC0,T2     TEST IF PORT CURRENTLY ACQUIRED
          SHN    -14
          ZJN    SPM0        IF NOT GET IT
          LDN    0
          UJN    SPMX        RETURN PORT NOT ACQUIRED

 SPM0     LDM    S0FLG       TEST FOR IOU TYPE
          NJP    SPM3        IF ON AN S0/S0E
          LDC    MXPT        FORM PORT SELECT FUNCTION
          ADD    T2
          STM    SPMB
          LMC    SHNI&MXPT   FORM SHIFT INSTRUCTION
          STM    USBA
          LMN    77          COMPLEMENT SHIFT COUNT
          STM    SPMA
          LOCKMR SET
          RJM    RTR         READ TEST MODE REGISTER
 SPMA     SHN    **          (IF PORT 0 BEING USED)
*SPMA     SHN    -1          (IF PORT 1 BEING USED)
          LPN    1
          ZJP    SPM3        IF PORT IS FREE
          LDML   EMC0,T2     GET ESTABLISHED CONNECTION BEFORE FLAG
          ZJN    SPM1        IF NEVER ACQUIRED
          LDC    20S12+20    SET REREQUESTED BIT
          UJN    SPM2        GO UPDATE STATUS BITS

 SPM1     LDC    4S12+4      SET REQUESTED BITS
 SPM2     RJM    USB         UPDATE STATUS BITS IN *TM* REGISTER
          LOCKMR CLEAR       RETURNS (A) = 0
          LJM    SPMX        RETURN
 UMM      SPACE  4,10
**        UMM - UPDATE *MDD* MODE DEFINITION.
*
*         ENTRY  (A) = NEW MODE DEFINITION.
*                (PT) = *MDMT*.
*
*         USES   T7.
*
*         CALLS  CLR, PMM.


 UMM      SUBR               ENTRY/EXIT
          SCN    77          CLEAR *SCD* CHANNEL NUMBER
          STDL   T7          SAVE DEFINITION
          SHN    -6          ALIGN *MDD* PORT BITS
          LPN    3           RETRIEVE PORT BITS
          RADL   T7          PLACE PORT BITS IN LAST 2 BITS
          LMML   MDMT+PTDB.
          LPC    4003        MASK FOR ACTIVE AND PORT BITS
          ZJN    UMM1        IF UNCHANGED
          RJM    CLR         CLEAN UP MODE DEFINITION
          LDD    T7          CLEAR PORT ATTACHED FLAG
          UJN    UMM2

 UMM1     LDDL   T7
 UMM2     STML   MDMT+PTDB.  SET *MDD* DEFINITION
          ZJN    UMMX        IF UNDEFINED RETURN
          LOADOV MDDSI       LOAD *MDD* RESIDENT OVERLAY
          LDC    MDDSI       SET TO *MDD* MODE
          STM    MDMT+RTNL.
          LDM    MDDSI       SET INITIALIZATION ROUTINE
          STI    PT
          RJM    PMM         PRESET *MDD* MODE
          LJM    UMMX        RETURN
 UNC      SPACE  4,10
**        UNC - UPDATE NOS CHANNEL.
*
*         ENTRY  (A) = CHANNEL NUMBER.
*
*         USES   T4.
*
*         NOTE   EXTREME CARE MUST BE TAKEN TO INCLUDE REFERENCE TO
*                ALL CHANNEL 10 INSTRUCTIONS IN THE RESIDENT OVERLAY.


 UNC      SUBR               ENTRY/EXIT
          STD    T4
          LDM    MC1         ADJUST CHANNEL NUMBER IN *SCI* RESIDENT
          SCN    37
          LMD    T4
          STM    MC1
          LDM    MC2         ADJUST CHANNEL NUMBER IN *SCI* RESIDENT
          SCN    37
          LMD    T4
          STM    MC2
          LDM    MC3         ADJUST CHANNEL NUMBER IN *SCI* RESIDENT
          SCN    37
          LMD    T4
          STM    MC3
          LDM    MC4         ADJUST CHANNEL NUMBER IN *SCI* RESIDENT
          SCN    37
          LMD    T4
          STM    MC4
          LDM    MC5         ADJUST CHANNEL NUMBER IN *SCI* RESIDENT
          SCN    37
          LMD    T4
          STM    MC5
          LDM    MC6         ADJUST CHANNEL NUMBER IN *SCI* RESIDENT
          SCN    37
          LMD    T4
          STM    MC6
          LDM    MC7         ADJUST CHANNEL NUMBER IN *SCI* RESIDENT
          SCN    37
          LMD    T4
          STM    MC7
          LJM    UNCX        RETURN
 USB      SPACE  4,10
**        USB - UPDATE STATUS BITS.
*
*         ENTRY  (A) = 5/MASK, 7/0, 5/VALUE
*                (USBA) = *SHN PORT* INSTRUCTION.
*                (RDATA - RDATA+7) = CURRENT TEST MODE REGISTER CONTENTS.
*
*         EXIT   TEST MODE REGISTER REWRITTEN.
*
*         USES   T1.
*
*         MACROS WRITMR.


 USB      SUBR               ENTRY/EXIT
 USBA     SHN    **          (IF PORT 0)
*USBA     SHN    1           (IF PORT 1)
          STD    T1
          SHN    -14
          ADC    SCNI        FORM MASK
          STM    USBB
          LDM    S0FLG       TEST FOR IOU TYPE
          NJN    USBX        IF ON AN S0/S0E
          LDM    RDATA+7
 USBB     SCN    **
          LMD    T1
          STM    RDATA+7
          WRITMR RDATA,ELIO,ITMR
          UJN    USBX        RETURN
 USM      SPACE  4,10
**        USM - UPDATE *SCD* MODE DEFINITION.
*
*         ENTRY  (A) = NEW MODE DEFINITION.
*                (PT) = *SCMT*.
*                (CN+3) = NOS COMMUNICATION CHANNEL.
*
*         USES   T7.
*
*         CALLS  CLR, GVI.


 USM      SUBR               ENTRY/EXIT
          STDL   T7          SAVE DEFINITION
          LMML   SCMT+PTDB.
          LPC    4003        MASK FOR ACTIVE AND PORT BITS
          ZJN    USM1        IF UNCHANGED
          RJM    CLR         CLEAN UP MODE DEFINITION
 USM1     LDDL   T7
          SHN    21-13
          PJN    USMX        IF MODE IS INACTIVE
          LDC    7770        SET UP ADDRESS FOR NOS CM BUFFER
          STM    SCMT+CMWP.
          LDC    OVLA        SET ADDRESS TABLE
          STM    SCMT+RTNL.
          LDN    0           ASSUME NOS STATE
          STM    SCMT+SCDS.
          LDC    PCL         SET *SCD/NOS* STARTUP ROUTINE
          STM    SCMT+NRTP.
          LDDL   T7          RESET MODE DEFINITION BYTE
          STML   SCMT+PTDB.
          SHN    21-12
          PJN    USM2        IF NO VIRTUAL STATE
          LDN    1           SET *SCD/VE*
          STM    SCMT+SCDS.
          RJM    GVI         GET VIRTUAL INTERFACE
 USM2     LDC    EMC         SET *ESTABLISH MODE CONNECTION*
          STI    PT          IN RTNP.
          LDML   SCMT+PTDB.
          SHN    21-14
          PJN    USM3        IF MODE CURRENTLY UNATTACHED
          LDM    SCMT+NRTP.  RESTORE OLD ROUTINE
          STI    PT          RESET RTNP.
 USM3     LDD    CN+3        GET NOS COMMUNICATION CHANNEL NUMBER
          LPN    37
          NJN    USM4        IF A VALUE IS GIVEN
          LDN    CH          USE DEFAULT NOS CHANNEL
 USM4     STM    SCMT+NCCH.  SAVE CHANNEL NUMBER
          RJM    UNC         UPDATE NOS CHANNEL NUMBER
          LJM    USMX        RETURN

          OVERFLOW  SCMT     CHECK FOR OVERFLOW
          ENDX
*DECK DECK=CTI$SCI_VPB_DEADSTART_NOSVE EXPAND=FALSE
          CTEXT  SCI VPB DEADSTART NOSVE
          OVERLAY  (SCI VPB DEADSTART NOS/VE - PHASE 1),MDDSI
 DSTW     SPACE  4,10
**        DSTW - DEADSTART STATUS WORD.


 DSTW     BSSZ   4
 DDS      SPACE  4,10
**        DDS - DEADSTART DUAL-STATE NOS/VE.
*
*         THIS ROUTINE IS CALLED FROM THE *TVO* ROUTINE IN THE IDLE LOOP
*         IF THE LEAST SIGNIFICANT BIT HAS BEEN SET IN WORD *D8DS* OF THE
*         EICB.  THIS ROUTINE WILL PRESET THE *VPB* MODE.
*
*         TO DEADSTART THE PROCESSOR FOR DUAL-STATE, PP ROUTINES *SDA*
*         (A C170-STATE PP), *SCI*, AND *DFT*, AS WELL AS *EI*, ARE
*         INVOLVED IN A SEQUENCE OF EVENTS.  EICB WORD *D8DS* IS USED
*         TO COORDINATE THE VARIOUS ROUTINES.
*
*         THE SEQUENCE OF OPERATIONS IS AS FOLLOWS:
*
*         1.  *SDA* SETS BITS 16 - 31 OF *D8DS* NONZERO.
*
*         2.  *SCI* IS LOADED IF NECESSARY.
*
*         3.  *SDA* SETS BIT 63 OF *D8ST*.
*
*         4.  WHEN *SCI/VPB* PRESET IS COMPLETE AND *VCB* HAS BEEN LOADED,
*             WORD *D8DS* AND BIT 63 OF *D8ST* ARE CLEARED BY *SCI*.
*
*         5.  *SDA* EXITS WHEN BITS 16 - 31 OF *D8DS* AND *D8ST* BIT 63
*             ARE CLEARED.
*
*         6.  *DSMDST* CALLS *EI* WHICH SETS BITS 32 - 63 OF *D8DS* TO -1.
*
*         7.  *EI* ENTERS MONITOR MODE AND SETS *D8DS* BITS 16 - 31 = 3 AND
*             BITS 32 - 63 = 1.
*
*         8.  *SCI* WAITS FOR *D8DS* BIT 63 TO SET.
*
*         9.  *EI* NOW WAITS FOR *D8DS* BIT 63 TO CLEAR; HOWEVER, WHAT WILL
*             ACTUALLY OCCUR IS THAT *DFT* DEADSTARTS *VCB*.
*
*         NOTE   THE PURPOSE OF THE DDS ENTRY POINT
*                IS TO FORCE THE LOADING OF THE COMMON
*                SUBROUTINES AND TO CALL *DD2*.


 DDS      ROUTINE

          CALL   DD2         DEADSTART DUAL-STATE NOS/VE PHASE 2
 DSA      SPACE  4,10
**        DSA - DEADSTART STANDALONE NOS/VE.


 DSA      ROUTINE

          RJM    PS1         PRESET FOR STANDALONE PHASE 1
          CALL   DS2         DEADSTART STANDALONE NOS/VE PHASE 2
 PRR      SPACE  4,10
**        PRR - PROCESS RELOCATION REQUEST.
*
*         NOTE   THE PURPOSE OF THE *PRR* ENTRY POINT IS TO
*                FORCE THE LOADING OF THE COMMON SUBROUTINES
*                AND TO CALL *PR2*.


 PRR      ROUTINE

          CALL   PR2         PROCESS RELOCATION REQUEST PHASE 2
          EJECT
 NOTE     SPACE  4,10
**        PROGRAMMING NOTE.
*
*         THE FOLLOWING ROUTINES ARE USED BY ALL PHASES OF DEADSTART.
*         ADDITIONAL ROUTINES NEEDED BY MORE THAN ONE PHASE SHOULD BE
*         ADDED TO THIS PORTION OF THE OVERLAY.
*COPY     CTP$SCI_ADVANCE_LOAD_ADDRESS
*COPY     CTP$SCI_CLEAR_CENTRAL_MEMORY
*COPY     CTP$SCI_COPY_CM_DATA
*COPY     CTP$SCI_INCREMENT_DFT_BUFFER
*COPY     CTP$SCI_INCREMENT_DFT_VE_BLOCK
 IDR      SPACE  4,10
**        IDR - ISSUE DFT REQUEST.
*
*         ENTRY  (A) = PARAMETER FOR DFT.
*                (VP - VP+3) = DFT REQUEST POINTER.
*
*         EXIT   REQUEST ISSUED TO DFT.
*                (A) = DFT RESPONSE CODE.
*
*         USES   CM - CM+3.
*
*         CALLS  IVB, SPB.


 IDR      SUBR               ENTRY/EXIT
          STDL   CM          SAVE PARAMETER WORD
          LRD    VP+1
          RJM    SPB         SET PP BOUNDARY FOR NOS/VE REQUEST BLOCK
          LDD    VP+3
          RJM    IVB         INDEX TO VPB BLOCK
          CWDL   CM          WRITE DFT REQUEST
          STDL   CM
          ADN    1
          CWML   IDRA,ON     WRITE ADDITIONAL PARAMETERS
          SRD    CM+1        BUILD REQUEST POINTER
          LDN    2
          STD    CM+3
          LDN    0
          RJM    IVB         INDEX NOS/VE BLOCK
          CWDL   CM          WRITE DFT REQUEST POINTER
 IDR1     LDD    VP+3        INDEX TO VPB REQUEST
          RJM    IVB
          CRDL   W0          READ STATUS WORD
          LDDL   W0
          SHN    -10
          ZJN    IDR1        IF NOT COMPLETE
          UJN    IDRX        RETURN

 IDRA     CON    0,0,0,0
*COPY     CTP$SCI_LOAD_CIP_PROGRAM
 PDC      SPACE  4,10
**        PDC - PRESET DIRECT CELLS.
*
*         EXIT   (BL - BL+1) = 0.
*                (LA - LA+1) = 0.
*                (SZ - SZ+1) = 0.
*                (VP - VP+3) = 0.
*
*         USES   T1.


 PDC      SUBR               ENTRY/EXIT
          LDN    BL          SET FWA TO CLEAR
          STD    T1
 PDC1     LDN    0           CLEAR NEXT DIRECT CELL
          STI    T1
          AOD    T1
          LMN    VP+3+1
          NJN    PDC1        IF MORE TO CLEAR
          UJN    PDCX        RETURN
*COPY     CTP$SCI_ZERO_PP_BUFFER
 NOTE     SPACE  4,10
**        PROGRAMMING NOTE.
*
*         DEADSTART PHASE 2 AND PHASE 3 ARE LOADED HERE.  THEREFORE, ANY
*         ROUTINES WHICH ARE NEEDED BY MORE THAN ONE PHASE OF DEADSTART
*         SHOULD PRECEDE THIS NOTE.


 PH2O     BSS    0           PHASE 2 ORIGIN
 ASP      SPACE  4,10
**        ASP - ALLOCATE *SCI* PARAMETER TABLE.
*
*         EXIT   *SCI* PARAMETER TABLE ALLOCATED.
*
*         USES   CM - CM+3, CN - CN+2.
*
*         CALLS  ALA, CCM, IIB.


 ASP      SUBR               ENTRY/EXIT
          LDN    D7RS+2      READ SCIPT POINTER FROM EICB
          RJM    IIB
          CRDL   CM
          LDDL   CM+2        CHECK IF POINTER EXISTS
          ADDL   CM+3
          NJN    ASP1        IF POINTER ALREADY EXISTS

*         CREATE AN RMA FROM THE CURRENT LOAD ADDRESS AND STORE IN THE EICB.

*         LDN    0
          STD    CM
          STD    CM+1
          LDD    LA+1
          SHN    6
          STDL   CM+3        STORE RIGHT 16 BITS
          SHN    -16D
          STD    CM+2        SAVE POSSIBLE CARRY (2 BITS)
          LDD    LA          STORE LEFT 6 BITS
          SHN    6-4
          RAD    CM+2
          LDN    D7RS+2      SET SCIPT RMA INTO THE EICB
          RJM    IIB
          CWDL   CM
          LDN    0           SET UP R-REGISTER FOR SCIPT ADDRESS
          STD    CN
          LRD    LA
          SRD    CN+1
          LDN    SCIPTL
          RJM    CCM         CLEAR *SCI* PARAMETER TABLE
 ASP1     LDN    SCIPTL
          RJM    ALA         ADVANCE LOAD ADDRESS
          LJM    ASPX        RETURN
 BCT      SPACE  4,10
**        BCT - BUILD CIP TABLES.
*
*         EXIT   (IB - IB+2) = R-POINTER TO EICB.
*                EICB AND DFT BUFFERS ARE AVAILABLE.
*
*         USES   CN - CN+3.
*
*         CALLS  ALA, CCM, IIB, PIB.


 BCT      SUBR               ENTRY/EXIT
          RJM    PIB         PRESET EICB POINTER
          LDDL   W2
          NJN    BCT1        IF NO EXISTING EICB (ADDRESS TOO LARGE)
          LDDL   W3
          NJN    BCT2        IF EICB ALREADY EXISTS (VALID ADDRESS)

*         INITIALIZE NEW EICB AND STORE POINTER.

 BCT1     LDN    0           SET UP *CCM* PARAMETERS
          STD    CN
          LRD    LA
          SRD    CN+1
          LDC    100+EICBL   CLEAR FROM WORD 0 TO END OF EICB
          RJM    CCM
          LDN    0
          STD    IB          SAVE POINTER TO EICB
          SRD    IB+1
          LDC    100         SAVE ADDRESS OF EICB
          STM    MBUF+3
          LDN    EICBP
          CWML   MBUF,ON     WRITE THE POINTER TO THE EICB
          RJM    PIB         PRESET EICB POINTER

*         UPDATE EXISTING EICB.

 BCT2     LDN    D8CPT       CLEAR THE CRITICAL PAGE TABLE POINTER
          RJM    IIB         INCREMENT INTERFACE BLOCK
          CWML   BCTA,ON
          LDC    EICL        SET EICB LEVEL
          STM    BCTA+3
          LDN    D7TY        GET POINTER TO EICB HEADER
          RJM    IIB
          CWML   BCTA,ON     CLEAR THE 170 EICB HEADER EXCEPT VERSION NUMBER
          LDN    0           INSERT CURRENT CTI DIRECTORY POINTER
          STD    CD+3
          LDN    DSEBP
          RJM    IIB         INCREMENT INTERFACE BLOCK
          CWDL   CD          WRITE CTI DIRECTORY POINTER
          LDC    100+EICBL   END OF EICB
          RJM    ALA         ADVANCE LOAD ADDRESS
          LJM    BCTX        RETURN

 BCTA     BSSZ   4           USED IN CLEARING EICB WORDS
 PS1      SPACE  4,10
**        PS1 - PRESET STANDALONE PHASE 1.


 PS1      SUBR               ENTRY/EXIT
          RJM    PDC         PRESET DIRECT CELLS
          RJM    BCT         BUILD CIP TABLES
          RJM    UTE         INITIALIZE TIME IN EICB
          RJM    ASP         ALLOCATE *SCI* PARAMETER TABLE
          UJN    PS1X        RETURN
 COMMON   SPACE  4,10
**        COMMON DECKS WHICH MAY BE OVER WRITTEN WITH THE IOU RESOURCE TABLE.


          LIST   X
*copy     ctp$update_time_in_eicb
          LIST   *
 EQUAL    SPACE  4,10
          QUAL   *

 ALA      EQUAL
 CCM      EQUAL
 CPY      EQUAL
 DSTW     EQUAL
 IDR      EQUAL
 IDT      EQUAL
 IDRA     EQUAL
 IVB      EQUAL
 LCP      EQUAL
 PDC      EQUAL
 PH2O     EQUAL
          OVERFLOW  MBUF     CHECK FOR OVERFLOW
          OVERLAY  (SCI VPB DEADSTART NOS/VE - PHASE 2),PH2O
          EJECT
 DD2      SPACE  4,10
**        DD2 - DEADSTART DUAL-STATE NOS/VE PHASE 2.


 DD2      ROUTINE

          RJM    PDS         PRESET FOR DUAL-STATE
          UJN    DS21        CONTINUE DEADSTART
 DS2      SPACE  4,10
**        DS2 - DEADSTART STANDALONE NOS/VE PHASE 2.
*
*         THIS ROUTINE IS CALLED TO PERFORM A STANDALONE NOS/VE DEADSTART.


 DS2      ROUTINE

          RJM    PSA         PRESET FOR STANDALONE
 DS21     CALL   CDS         CONTINUE DEADSTART
 PR2      SPACE  4,10
**        PR2 - PROCESS RELOCATION REQUEST PHASE 2.
*
*         ENTRY  (CM - CM+3) = RELOCATION CONTROL WORD.
*                (W4 - W7) = R-POINTER TO RELOCATION CONTROL WORD.
*
*         EXIT   TO *DSX*.
*                *DFT* RELOCATED IF REQUESTED.
*                *SCI* IDLED IF REQUESTED.
*
*         USES   CM - CM+3, W4 - W7.
*
*         CALLS  IIB, RDT.


 PR2      ROUTINE

*         PROCESS *DFT* FLAGS.

          LDD    CM          CHECK DFT FLAGS
          SHN    21-10
          MJN    PR24        IF *DFT* DELIBERATELY DIED
          SHN    21-7-21+10
          MJN    PR23        IF *DFT* READY TO BE RELOCATED
          SHN    21-6-21+7
          PJN    PR24        IF *REQUEST DFT IDLE* NOT PENDING
          LDM    PRRA        CHECK TIMER VALIDITY
          NJN    PR21        IF TIMER ACTIVE
          LDN    10D+1       INITIALIZE 10 SECOND TIMER
          STM    PRRA
 PR21     SOM    PRRA        DECREMENT TIMER
          ZJN    PR23        IF TIMED OUT
 PR22     CALL   DSX         RELOAD RESIDENT AND EXIT

*         RELOAD *DFT*.

 PR23     RJM    RDT         RELOCATE *DFT*
          LRD    W4+1
          LDD    W4          REREAD RELOCATION CONTROL WORD
          ADC    RR
          CRDL   CM
          LDDL   CM          CLEAR *DFT* FLAGS
          LPC    0#803F
          STDL   CM

*         PROCESS *SCI* FLAGS.

 PR24     LDD    CM+1        PROPAGATE *REQUEST SCI IDLE* TO *SCI IDLED*
          LPC    100
          SHN    1
          RADL   CM+1
          LRD    W4+1
          LDD    W4          REWRITE RELOCATION CONTROL WORD
          ADC    RR
          CWDL   CM
          LDDL   CM+1
          SHN    21-6
          PJN    PR22        IF *REQUEST SCI IDLE* NOT SET
          UJN    *           WAIT FOR *DFT* TO IDLE PP
 ADT      SPACE  4,10
**        ADT - ACTIVATE DFT PROGRAM.
*
*         ENTRY  EICB AND DFTB SET UP.
*                (ADTA) = 4/DFT PP TYPE, 8/DFT PP NUMBER.
*                TO *AAC* IF DFT NOT FOUND.
*
*         USES   T6, CM - CM+3.
*
*         CALLS  LCM, TDF.
*
*         MACROS FINDCM.


 ADT      SUBR               ENTRY/EXIT
          LDC    **          DFT PP TYPE AND NUMBER
 ADTA     EQU    *-1
          STD    T6
          FINDCM DFT         FIND DFT WITHIN THE CIP DIRECTORY
          ZJN    ADT20       IF *DFT* NOT FOUND IN CIP DIRECTORY
          RJM    LCM         LOAD CIP MODULE
          RJM    TDF         TIMEOUT *DFT* AFTER 3 SECONDS
          UJN    ADTX        RETURN

 ADT20    LDC    DADN        61B - DFT NOT FOUND IN CIP DIRECTORY
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR
 BRT      SPACE  4,15
**        BRT - BUILD RESOURCE TABLE.
*
*         ENTRY  EICB INITIALIZED.
*                (DO) = DEADSTART ORIGIN.
*                     = 0, IF DUAL-STATE.
*                     = 1, IF STANDALONE.
*
*         EXIT   (CBUF) = TABLE OF AVAILABLE PPS AND CHANNELS.
*
*         CALLS  FHE, SDU, SSU.
*
*         USES   T1, T2, T3, T5, T6.


 BRT      SUBR               ENTRY/EXIT
          LDC    IRTL-1      INITIALIZE RESOURCE TABLE SIZE
          STD    T1
 BRT10    LDC    0#0F0F      SET ALL PPS AND CHANNELS TO UNAVAILABLE
          STML   CBUF,T1
          SOD    T1
          PJN    BRT10       IF MORE ENTRIES TO SET
          RJM    SSU         READ IOU DESCRIPTOR AND SET *SCI* PP UNAVAILABLE
          LDD    DO          USE DEADSTART ORIGIN FOR IOU 0
          STD    T6
          ZJN    BRT30       IF NOT STANDALONE DEADSTART
          RJM    SDU         SET *DFT* PP UNAVAILABLE
 BRT30    LDM    HBUF+CIOM   CHECK FOR MODEL 44(16)
          SHN    -4
          LMC    0#43
          ZJN    BRT32       IF NOT MODEL 43(16)
          LMN    0#44&0#43
          NJN    BRT35       IF NOT MODEL 44(16)

 BRT32    LDN    IRTL/4      SET OFFSET TO CIO PORTION OF TABLE
          STM    BRTG
          RAM    BRTG+1
          LDN    1           PROCESS PP-S 0-11 AND 20-31
          UJN    BRT36       GET OFFSET TO PP STATUS

 BRT35    LDN    2
 BRT36    STD    T5
 BRT40    LDM    BRTE,T5
          STD    T1          OFFSET TO PP STATUS
          LDM    HBUF,T1
          LPC    1777        PP'S 12 AND 13 IMPOSSIBLE
          LMC    1777
          STD    T1          PP STATUS
          LDM    BRTF,T5
          STD    T2          OFFSET TO CHANNEL STATUS
          LDM    HBUF,T2
          LMC    7777
          STD    T2          CHANNEL STATUS
          LDM    BRTG,T5
          STD    T3          STARTING PP/CH NUMBER
 BRT50    LDD    T1
          SHN    21-0
          STD    T1
          PJN    BRT60       IF PP IS NOT AVAILABLE
          LDD    T6          DEADSTART ORIGIN
          SHN    7           A = 80(16) IF IN STANDALONE
          ADML   CBUF,T3
 BRTA     EQU    *-1
          LPC    0#FF80
          STML   CBUF,T3     DEFINE PP AS ACTIVE/AVAILABLE
 BRTB     EQU    *-1
 BRT60    LDD    T2
          SHN    21-0
          STD    T2
          PJN    BRT70       IF PP IS NOT AVAILABLE
          LDD    T6          DEADSTART ORIGIN
          SHN    17          A = 8000(16) IF IN STANDALONE
          ADML   CBUF,T3
 BRTC     EQU    *-1
          LPC    0#80FF
          STML   CBUF,T3     DEFINE CHANNEL AS ACTIVE/AVAILABLE
 BRTD     EQU    *-1
 BRT70    AOD    T3
          SBN    1+IRTL/2
          MJN    BRT50       IF BARREL NOT FINISHED
          SOD    T5
          PJP    BRT40       IF MORE ENTRIES TO PROCESS
          LDM    BRTH        CHECK IF MAXIMUM IOU ORDINAL PROCESSED
          SBM    MION
          ZJN    BRT80       IF LAST IOU PROCESSED
          AOM    BRTH
          SHN    14
          ADN    IOUID
          RJM    FHE         FIND HARDWARE ELEMENT
          LDN    0
          STD    T6
          LDC    CBUF+IRTL/2 SET OFFSET INTO TABLE FOR IOU 1
          STM    BRTA
          STM    BRTB
          STM    BRTC
          STM    BRTD
          LJM    BRT30       PROCESS NEXT IOU

 BRT80    LJM    BRTX        RETURN

 BRTE     CON    07,10,15    OFFSET TO PP STATUS
 BRTF     CON    12,13,16    OFFSET TO CH STATUS
 BRTG     CON    00,20,34    OFFSET IN PP/CH TABLE
*BRTG     CON    34,54       (I4C)
 BRTH     CON    0           IOU COUNTER
 CDB      SPACE  4,15
**        CDB - CONFIGURE DFT BUFFER.
*
*         ENTRY  (LA - LA+1) = NEXT AVAILABLE CM ADDRESS.
*                (CDBB+1) = DFT PP NUMBER (STANDALONE DEADSTART ONLY).
*
*         EXIT   (DP - DP+1) = R-REGISTER OF DFT BUFFER.
*                (DFTO) = DFT OFFSET TO ACCESS DFT CONTROL WORD.
*                (LA - LA+1) = ADVANCED.
*                (VP - VP+3) = R-POINTER TO NOS/VE REQUEST BLOCK.
*                RELOCATION CONTROL WORD POINTER CLEARED.
*                TO *ABD* TO ABORT DEADSTART IF BOOT PIECES NOT LOADED.
*
*         USES   CM - CM+3, CN - CN+2, T1, T2, W0 - W3.
*
*         CALLS  ALA, CCM, FHE, IDT, IIB, *ABD*.


*         SAVE THE DFT/OS BUFFER INTERFACE VERSION LEVEL IN THE DFT BUFFER.

 CDB2     LDN    VER7        FORCE INTERFACE VERSION LEVEL 7
          SHN    10
          RAML   CDBB+1      MERGE WITH DFT PP NUMBER

*         ALLOCATE SPACE FOR NEW DFT BUFFER.  THE ACTUAL INITIALIZATION
*         OF THE BUFFER WILL BE PERFORMED BY DFT PRESET CODE.

          LDN    1           SET OFFSET TO POINT TO DFT CONTROL WORD
          STM    DFTO
          STD    CM
          LDN    0           SET OFFSET TO CLEAR FROM WORD -1 OF BUFFER
          STD    CN
          LRD    LA          SET DFT R-REGISTER VALUE
          SRD    DP
          SRD    CN+1
          SRD    CM+1
          LDN    DSDFT       WRITE DFT POINTER IN EICB
          RJM    IIB
          CWDL   CM
          CRML   CDBD,ON
          LRD    CN+1        CLEAR DFT BUFFER
          LDML   CDBA+3
          ADN    3+1         INCLUDE TEMPORARY NOS/VE BUFFER
          RJM    CCM

*         WRITE DFT HANDOFF INFORMATION TO DFT BUFFER.

          LDML   CDBA+3      CREATE TEMPORARY NOS/VE REQUEST POINTER
          RAML   CDBD
          LDN    1
          STM    CDBD+3
          LRD    DP
          LDM    DFTO
          ADC    RR-1
          CWML   CDBA,ON     WRITE BUFFER-1 (DFT BUFFER SIZE)
          CWML   CDBB,ON     WRITE BUFFER+0 (DFT INTERFACE VERSION/PP NUMBER)
          CWML   CDBC,ON     WRITE BUFFER+1 (PP RESIDENT BUFFER)
          CWML   CDBD,ON     WRITE BUFFER+2 (NOS/VE REQUEST BUFFER)
          SBN    1
          CRDL   VP          SET POINTER TO TEMPORARY NOS/VE BUFFER

*         UPDATE LOAD ADDRESS.

 CDB3     LDML   CDBA+3      ADVANCE LOAD ADDRESS
          ADN    3+1         INCLUDE TEMPORARY NOS/VE BUFFER
          RJM    ALA

 CDB      SUBR               ENTRY/EXIT
          LDN    D8RLP       CLEAR DFT/SCI RELOCATION CONTROL IN EICB
          RJM    IIB
          CWML   CDBA,ON

*         DETERMINE IF THE BOOT PIECES HAVE BEEN LOADED.

          LDN    DFTID       READ DFT MRT DESCRIPTOR
          RJM    FHE
          MJN    *           IF NOT FOUND
          LDM    HBUF+DOBIV
          SHN    -6
          LMN    77
          NJN    CDB0        IF BOOT PIECES LOADED
          CALL   ABD         ABORT NOS/VE DEADSTART

*         DETERMINE SIZE OF DFT BUFFER.

 CDB0     LDM    HBUF+DFTSZ  SET TOTAL SIZE OF DFT BUFFER
          SHN    14
          ADM    HBUF+DFTSZ+1
          STML   CDBA+3
          LDN    DSDFT       READ DFT POINTER FROM EICB
          RJM    IIB
          CRDL   CM
          LDDL   CM+2        CHECK POSSIBLE DFT POINTER
          ADDL   CM+3
          ZJP    CDB2        IF NO PREVIOUS DFT BUFFER
          LRD    CM+1        SAVE DFT R-REGISTER VALUE
          SRD    DP
          LDD    CM          SAVE OFFSET
          STM    DFTO
          LDD    DO          CHECK TYPE OF DEADSTART
          ZJN    CDB1        IF DUAL-STATE DEADSTART

*         UPDATE DFT CONTROL WORD.

          LDN    HDRP        READ DFT CONTROL WORD
          RJM    IDT
          CRDL   W0
          LDDL   W0+DHPP     CLEAR OLD DFT PP NUMBER
          LPC    0#FF00
          ADM    CDBB+1      MERGE WITH NEW DFT PP NUMBER
          STDL   W0+DHPP
          LDDL   W0+DHFLG    CLEAR DFT VERIFIED FLAG
          LPC    0#FF7F
          ERRNZ  DH.FV-7     MASK ASSUMES *DH.FV* IS 2**7
          STDL   W0+DHFLG
          LRD    DP
          RJM    SPB         SET PP BOUNDARY
          LDN    HDRP        REWRITE DFT CONTROL WORD
          RJM    IDT
          CWDL   W0

*         CLEAR NOS/VE REQUEST BLOCK.

 CDB1     LDN    NVEP        READ NOS/VE REQUEST POINTER
          RJM    IDT
          CRDL   VP
          CRDL   CN
          LRD    CN+1
          RJM    SPB         SET PP BOUNDARY
          LDDL   CN+3        CLEAR NOS/VE REQUEST BLOCK
          RJM    CCM
          LJM    CDB3        UPDATE LOAD ADDRESS

 CDBA     BSSZ   4           BUFFER-1 - DFT BUFFER SIZE IN BITS 48-63
 CDBB     BSSZ   4           BUFFER+0 - DFT PP NUMBER (24-31), I/F VERSION (32-39)
 CDBC     BSSZ   4           BUFFER+1 - PP RESIDENT POINTER (ZERO)
 CDBD     BSSZ   4           BUFFER+2 - DFT/OS REQUEST AREA POINTER
*COPY     CTP$SCI_CREATE_SSR_CHECKSUM
 CSR      SPACE  4,10
**        CSR - CREATE SSR RECORD.
*
*         EXIT   SSR LOADED.
*                TO *AAC*, IF ERROR RETURNED ON *DFT* REQUEST.
*
*         USES   W1 - W3.
*
*         CALLS  CSC, LCP, MCS, SSR, *AAC*.
*
*         MACROS SSRE.


 CSR2     RJM    MCS         MOVE AND COMPLETE THE SSR

 CSR      SUBR               ENTRY/EXIT
          RJM    SSR
          LDD    SA
          ADD    SA+1
          ZJN    CSR1        IF THE SSR IS NOT ALREADY DEFINED
          RJM    CSC         CREATE SSR CHECKSUM
          LDD    T4          CHECK IF *SCKS* ENTRY FOUND
          ZJN    CSR1        IF *SCKS* ENTRY NOT FOUND
          LDDL   W5          COMPARE CHECKSUMS
          LMDL   T3
          ZJN    CSRX        IF SSR CHECKSUM VERIFIES

 CSR1     BSS    0
          CODE   D
          LRD    LA
          LDC    3RSSR
          RJM    LCP         LOAD CIP PROGRAM
          CODE   *
          LMN    RCNE        CHECK FOR NO ERROR ON REQUEST
          ZJN    CSR2        IF DFT REQUEST COMPLETED WITH NO ERROR
          LDC    DASS        622 - *SCI* DETECTED *DFT* ERROR WHILE LOADING SSR
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR
 CVB      SPACE  4,10
**        CVB - CONFIGURE NOS/VE BOOT.
*
*         ENTRY  EICB BUILT.
*
*         EXIT   PAGE SIZE OBTAINED.
*                PAGE LENGTH OBTAINED.
*                MEMORY SIZE OBTAINED.
*                PORT CODES OBTAINED.
*
*         CALLS  FHE, VMB.


 CVB      SUBR               ENTRY/EXIT
          LDN    CMID
          RJM    FHE
          LDM    HBUF+7      SAVE LOGICAL CM SIZE
          STD    SZ
          LDM    HBUF+10
          STD    SZ+1
          LDN    GPDID
          RJM    FHE
          LDM    HBUF+GPDPS  FETCH PAGE SIZE/1000B
          SBN    1           CREATE MASK
          STML   HPSM        SAVE PAGE SIZE MASK
          LMC    7777
          LPDL   SZ+1        ROUND DOWN TO NEAREST MULTIPLE OF PAGE SIZE
          STD    SZ+1
          RJM    VMB         VALIDATE MEMORY BOUNDS
          LDN    GPDID
          RJM    FHE

*         SET THE PAGE TABLE LENGTH.  THE PAGE TABLE LENGTH MASK
*         INCREASED FOR 256 MEGA BYTE MEMORY SUPPORT.  DUE TO
*         PROBLEMS COORDINATING THIS CHANGE FOR ALL MAINFRAMES
*         WITH *CTI* THIS CODE USES THE OLD *MRT* LOCATION IF NEW
*         LOCATION DOES NOT CONTAIN A VALUE.  IN THE FUTURE, WHEN
*         *CTI* HAS MADE THIS CHANGE FOR ALL MAINFRAMES (INCLUDING
*         S0), THIS CODE COULD BE CHANGED TO SIMPLY USE THE NEW
*         LOCATION.

          LDM    HBUF+GPDLPTL PAGE TABLE LENGTH MASK / 10000(8)
          NJN    CVB0        IF PAGE TABLE LENGTH MASK PRESENT
          LDM    HBUF+GPDPTL PAGE TABLE LENGTH MASK / 10000(8)
          LPC    0#FF
CVB0      ADN    1           CHANGE TO PAGE TABLE LENGTH
          SHN    3           CHANGE TO WORDS
          STML   HPTL        SAVE HARDWARE PAGE TABLE LENGTH
          SBN    1           CHECK IF LOAD ADDRESS ALREADY 0 MOD PTL
          LPDL   LA+1
          ZJN    CVB1
          LDML   HPTL
          RAD    LA+1        ROUND LOAD ADDRESS TO MULTIPLE OF PTL
          SHN    -14
          RAD    LA
          LDML   HPTL
          SBN    1
          LMC    7777
          LPDL   LA+1
          STD    LA+1
 CVB1     LDM    HBUF+GPDOPF SAVE OPERATOR PAUSE FLAG
          SHN    -6          TRIM UNDESIRED BITS
          LPN    1
          STM    WAIT
          LJM    CVBX        RETURN
*COPY     CTP$SCI_DELAY_ROUTINE
*COPY     CTP$SCI_FETCH_CM_BOUND_VALUES
 FPD      SPACE  4,15
**        FPD - FIND A PP FOR *DFT*.
*
*         EXIT   FIRST AVAILABLE PP IN SAME BARREL AS *SCI* RESERVED FOR *DFT*.
*                (ADTA) = 4/DFT PP TYPE, 8/DFT PP NUMBER.
*                (SDUA) = *LDN DFTPP*.
*                (CDBB+1) MODIFIED TO REFLECT *DFT* PP.
*                TO *AAC*, IF *DFT* PP NOT FOUND.
*
*         USES   CM, CM+1, T1, T2, T3.
*
*         CALLS  SSU.


 FPD2     LDD    T1          SAVE *DFT* PP NUMBER
          STM    CDBB+1
          RAM    SDUA
          LDD    T1
          LMD    T3
          STM    ADTA

 FPD      SUBR               ENTRY/EXIT
          RJM    SSU         SET *SCI* PP UNAVAILABLE IN *HBUF*
          STD    T2          SAVE BARREL FLAG
          SHN    4
          STD    T1
          ADN    11+1        SET LAST PP IN BARREL
          STD    CM
          LDN    0           SET NIO PP TYPE
          STDL   T3
          LDM    HBUF+CIOM   CHECK FOR MODEL 44(16)
          SHN    -4
          LMC    0#43
          ZJN    FPD05       IF MODEL 43(16)
          LMN    0#44&0#43
          NJN    FPD0        IF NOT MODEL 44(16)
 FPD05    LDD    T1
          ADN    4+1         DFT MUST BE IN CLUSTER ZERO
          STD    CM
          LDC    0#100       SET CIO PP TYPE
          STDL   T3
 FPD0     LDM    HBUF+CIOPLM,T2
          STD    CM+1
 FPD1     LDD    CM+1
          SHN    21-0
          PJP    FPD2        IF PP AVAILABLE
          STD    CM+1
          AOD    T1
          LMD    CM
          NJN    FPD1        IF BARREL/CLUSTER NOT EXHAUSTED
          LDC    DAND        618 - NO PP AVAILABLE FOR DFT
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR
 LCM      SPACE  4,10
**        LCM - LOAD CIP MODULE.
*
*         ENTRY  (A) = CM ADDRESS OF PP DIRECTORY HEADER.
*                (T6) = PP TO LOAD.
*
*         EXIT   PP EXECUTING PROGRAM.
*                TO *AAC* IF PP LOAD ERROR.
*
*         CALLS  DLP, IDP, IIB, SCF.


 LCM      SUBR               ENTRY/EXIT
          ADN    1
          STML   LCMA+SC     SAVE A
          CRML   T3+LCMA,ON  READ DIRECTORY ENTRY
          LDD    CM+1
          STML   LCMA+SC+1
          LDD    CM+2
          STML   LCMA+SC+2
          LDN    DSEBP
          RJM    IIB
          CRML   LCMA+CD,ON  FETCH CIP DIRECTORY POINTER
          LDM    S0FLG       TEST IOU TYPE
          ZJN    LCM1        IF NOT AN S0/S0E
          LDD    T6
          RJM    /"PRGNAM"AD/IDP
          UJN    LCM2        CONTINUE

 LCM1     LDD    T6
          RJM    IDP         IDLE PP
 LCM2     LDN    MX
          STD    T1          DEADSTART ON MUX CHANNEL
          RJM    SCF         SET CHANNEL FLAG ON MUX CHANNEL
          LDM    S0FLG       TEST IOU TYPE
          ZJN    LCM3        IF NOT AN S0/S0E
          LDD    T6
          RJM    /"PRGNAM"AD/DLP
          UJN    LCM4        CONTINUE

 LCM3     LDD    T6
          RJM    DLP         DEADSTART LOAD PP
 LCM4     LDN    LCMAL
          OAM    LCMA,MX     OUTPUT PROGRAM
          FJM    *,MX        WAIT CHANNEL EMPTY
          DCN    MX+40
          CCF    *,MX        CLEAR CHANNEL INTERLOCK
          ZJP    LCMX        IF TRANSFER COMPLETE
          LDC    DALE        60C - PP LOAD ERROR
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR

 LCMA     BSS    0
          LOC    0
          CON    BTS-1
          BSS    2
 T3       CON    0,0,0,0     DIRECTORY ENTRY

 BTS      LDD    T3
          STD    BTSA
          LDD    SC
          ADC    RR+1
          LRD    SC+1
          CRML   **,T3+1
 BTSA     EQU    *-1         LOAD ADDRESS OF PROGRAM
          LDN    0           *DFT* IOU NUMBER
          STD    70
          LJM    100         START RUNNING PROGRAM

 RF       CON    0           *DFT* RESTART FLAG
          ERRNZ  RF-23       *DFT* PRESET MUST BE CHANGED
          BSS    30-*
 SC       CON    0,0,0       ADDRESS OF PROGRAM DIRECTORY ENTRY
          CON    0           (UNUSED)
 CD       CON    0,0,0,0     POINTER TO CIP DIRECTORY
 LCMAL    BSS    0
          LOC    *O
*COPY     CTP$SCI_MOVE_AND_COMPLETE_SSR
 PDS      SPACE  4,10
**        PDS - PRESET FOR DUAL-STATE.
*
*         CALLS  BRT, CDB, CSR, CVB, PDC, PIB, SSI, UDS.


 PDS      SUBR               ENTRY/EXIT
          RJM    PDC         PRESET DIRECT CELLS
          RJM    PIB         PRESET EICB POINTER
          LDN    0           *SCI* ALWAYS IN IOU 0 FOR NON-CYBER 2000
          RJM    SSI         SET *SCI* IOU NUMBER AND MODEL NUMBER
          RJM    UDS         UPDATE DEADSTART STATUS AND SET *SCD/VE* PORT
          RJM    PEM         PRESET EICB MESSAGE BUFFER
          RJM    CDB         CREATE/CONFIGURE DFT BUFFER
          RJM    CVB         CONFIGURE NOS/VE BOOT
          RJM    CSR         SET UP COMMUNICATIONS WITH SSR
          RJM    BRT         BUILD RESOURCE TABLE
          UJN    PDSX        RETURN
*COPY     CTP$SCI_PRESET_EICB_MSG_BUFFER
 PSA      SPACE  4,10
**        PSA - PRESET FOR STANDALONE.
*
*         CALLS  ADT, BCT, BRT, CDB, CSR, CVB, FPD, IAD, INS, PDC, PEM,
*                SBI, SSI, UTE.


 PSA      SUBR               ENTRY/EXIT
          RJM    PEM         PRESET EICB MESSAGE BUFFER
          LDN    0           *SCI* ALWAYS IN IOU 0 FOR NON-CYBER 2000
          RJM    SSI         SET *SCI* IOU NUMBER AND MODEL NUMBER
          RJM    FPD         FIND A PP FOR DFT
          RJM    CDB         CREATE/CONFIGURE DFT BUFFER
          RJM    SBI         SET BARREL INTERLEAVES
          RJM    CVB         CONFIGURE NOS/VE BOOT
          RJM    ADT         ACTIVATE DFT
          RJM    CSR         LOAD AND BUILD THE SSR
          RJM    BRT         BUILD RESOURCE TABLE
          RJM    IAD         IDLE ALL DRIVERS
          LDN    3           SET FAKE *EI* PERMISSION TO DEADSTART
          STM    DSTW+1
          LDN    1           SET DEADSTART FLAG
          STM    DSTW+3
          SSRE   WAIT        SET OPERATOR PAUSE FLAG
          LDM    WAIT
          STD    W5
          LDD    W1
          RJM    INS         UPDATE *WAIT* WITH OPERATOR PAUSE FLAG
          CWDL   W2
          SSRE   DTYP        SET DEADSTART ORIGIN
          LDN    0
          STD    W4          CLEAR DEADSTART TYPE
          STD    W5
          LDD    W1
          RJM    INS         UPDATE CLEARED *DTYP* ENTRY
          CWDL   W2
          LJM    PSAX        RETURN
 RDT      SPACE  4,10
**        RDT - RELOCATE *DFT*.
*
*         ENTRY  (CM - CM+3) = RELOCATION CONTROL WORD.
*
*         CALLS  IDT, IVP, LCM.
*
*         USES   CM - CM+3, W0 - W3.


 RDT      SUBR               ENTRY/EXIT

*         IDLE EXISTING COPY OF *DFT*.

          LDD    CM          SET NEW PP NUMBER FOR *DFT*
          LPN    77
          STM    RDTA
          LDN    HDRP        SET PRESENT PP NUMBER FOR *DFT*
          RJM    IDT
          CRDL   CM
          LDDL   CM+DHPP     SAVE EXISTING *DFT* PP NUMBER
          LPN    77
          STM    RDTA+1
          RJM    IVP         IDLE EXISTING *DFT*

*         UPDATE *DFT* HEADER.

          LDDL   CM+DHPP     UPDATE PP NUMBER IN *DFT* HEADER
          LMM    RDTA+1      CLEAR EXISTING PP NUMBER
          LMM    RDTA        MERGE NEW PP NUMBER
          STDL   CM+DHPP
          LDDL   CM+DHFLG    CLEAR *DFT VERIFIED* FLAG
          ERRNZ  DH.FV-7     MASK ASSUMES *DH.FV* IS 2**7
          LPC    0#FF7F
          STDL   CM+DHFLG
          LDN    HDRP        REWRITE DFT HEADER
          RJM    IDT
          CWDL   CM

*         INITIALIZE DIRECT CELLS IN BOOTSTRAP IMAGE.

 RDT1     LDM    RDTA
          STD    T6
          AOM    LCMA+RF     SET *DFT RESTART* FLAG IN BOOTSTRAP
          FINDCM DFT         LOCATE *DFT* IN THE CIP DIRECTORY
          RJM    LCM         LOAD *CIP* MODULE
          LJM    RDTX        RETURN

 RDTA     BSS    2           NEW/OLD PP NUMBER
 SBI      SPACE  4,10
**        SBI - SET BARREL INTERLEAVES.
*
*         CYBER 810/830 FCO 3364 INTRODUCES THE ABILITY TO SELECT HOW
*         CONCURRENT PP ACCESS TO CM IS INTERLEAVED.  THIS ALLOWS THE
*         OS TO SELECT WORD INTERLEAVE MODE FOR IOU BARREL 0 AND BLOCK
*         INTERLEAVE MODE FOR BARREL 1, AND ASSIGN PERFORMANCE CRITICAL
*         HIGH CM ACCESS PP-S TO BARREL 1 ONLY.
*
*         USES   T6, T7.
*
*         CALLS  RMR.


 SBI      SUBR               ENTRY/EXIT
          LDM    CPUT        TEST FOR S1-CR
          LPN    77
          NJN    SBIX        IF NOT S1-CR
          LDK    ISTR
          STD    RN
          LDM    ELIO
          RJM    RMR         READMR RDATA,ELIO,ISTR  READ STATUS REGISTER
          LPN    20          CHECK RECONFIGURATION
          ADN    20
          SHN    6-4
          STD    T6
          LDK    DEMR
          STD    RN
          LDM    ELIO
          RJM    RMR         READMR RDATA,ELIO,DEMR  READ IOU REGISTER
          LPN    0#3F
          ADD    T6
          STM    RDATA+7     SET BARREL 1 TO BLOCK INTERLEAVE MODE
          WRITMR RDATA,ELIO,DEMR
          LJM    SBIX        RETURN
 SDU      SPACE  4,10
**        SDU - SET *DFT* PP UNAVAILABLE.
*
*         ENTRY  (SDUA) = *DFT* PP NUMBER.
*                (HBUF) = IOU DESCRIPTOR.
*
*         EXIT   *DFT* PP SET UNAVAILABLE IN *HBUF*.
*
*         USES   T5.


 SDU1     LDD    T5          *DFT* PP NUMBER
          ADC    SHNI
          STM    SDUC
          LDN    1
 SDUC     SHN    **
          RAM    HBUF+CIOPLM

 SDU      SUBR               ENTRY/EXIT
          LDN    **
 SDUA     EQU    *-1         (*DFT* PP NUMBER)
          STD    T5
          SBN    20          TEST FOR UPPER PP
          MJN    SDU1        IF LOWER
          ADC    SHNI
          STM    SDUB
          LDN    1
 SDUB     SHN    **
          RAM    HBUF+CIOPLM+1
          UJN    SDUX        RETURN
 SSU      SPACE  4,10
**        SSU - READ IOU DESCRIPTOR AND SET *SCI* PP UNAVAILABLE.
*
*         EXIT   (A) = 0 IF *SCI* IN LOWER BARREL.
*                    = 1 IF *SCI* IN UPPER BARREL.
*                (HBUF) = IOU DESCRIPTOR.
*                *SCI* PP SET UNAVAILABLE IN CORRESPONDING *HBUF+CIOPLM* WORD.
*
*         CALLS  FHE.


 SSU1     LDM    PPNO        GET PP NUMBER
          ADC    SHNI
          STM    SSUB
          LDN    1
 SSUB     SHN    **
          RAM    HBUF+CIOPLM  FORCE PP UNAVAILABLE
          LDN    0           RETURN LOWER BARREL FLAG

 SSU      SUBR               ENTRY/EXIT
          LDN    IOUID
          RJM    FHE         FIND IOU INFORMATION IN *2AP*
          LDM    PPNO        FORCE SCI'S PP AS UNAVAILABLE
          SBN    20          TEST FOR UPPER PP
          MJN    SSU1        IF LOWER
          ADC    SHNI
          STM    SSUA
          LDN    1
 SSUA     SHN    **
          RAM    HBUF+CIOPLM+1  FORCE PP AS UNAVAILABLE
          LDN    1
          UJN    SSUX        RETURN
*COPY     CTP$SCI_TIMEOUT_DFT_VERIFIED
 UDS      SPACE  4,10
**        UDS - UPDATE DEADSTART STATUS AND SET *SCD/VE* PORT.
*
*         EXIT   (*D8ST*) BIT 63 CLEARED.
*                (SCDP) = *SCD/VE* PORT BIT(S).
*
*         USES   CM - CM+3.
*
*         CALLS  IIB, SPB.


 UDS      SUBR               ENTRY/EXIT
          LRD    IB+1
          RJM    SPB         SET PP BOUNDS
          LDN    D8ST        READ DEADSTART STATUS WORD
          RJM    IIB
          CRDL   CM
          LDDL   CM+2        EXTRACT *SCD/VE* PORT NUMBER
          SHN    -2
          LPN    1
          STM    SCDP
          LDDL   CM+3        CLEAR START BIT
          SCN    1
          STDL   CM+3
          LDN    D8ST        REWRITE *D8ST*
          RJM    IIB
          CWDL   CM

*         FORCE *MDD* TO GIVE UP THE PORT IF IT HAS THE SAME PORT ATTACHED.

          LDML   MDMT+PTDB.
*         ZJN    UDSX        IF *MDD* NOT DEFINED
          SHN    21-14
          PJN    UDSX        IF NO PORT ASSIGNED TO *MDD*
          LDM    MDMT+PTUS.
          SHN    -2
          LPN    1
          LMM    SCDP
          NJN    UDS1        IF *MDD* NOT ON SAME PORT
          LDC    BPA         FORCE *MDD* TO GIVE UP PORT
          STM    MDMT+RTNP.
 UDS1     LJM    UDSX        RETURN
*COPY     CTP$SCI_UPDATE_MEMORY_BOUNDS
          SPACE  4,10
*         COMMON DECKS.


*COPY     CTP$SCI_VPB_IDLE_IOU0


          OVERFLOW  CBUF     OVERFLOW INTO IOU RESOURCE TABLE
*COPY     CTP$SCI_SET_IOU_NUMBER
*COPY     CTP$SCI_VERIFY_MEMORY_BOUNDS
          SPACE  4,10
          OVERFLOW  MBUF     CHECK FOR OVERFLOW
          OVERLAY  (SCI VPB DEADSTART NOS/VE - PHASE 3),PH2O
 CDS      SPACE  4,10
**        CDS - CONTINUE DEADSTART.
*
*         ENTRY  PRESET HAS BEEN PERFORMED.
*                (SCDP) = PORT BITS FOR *SCD/VE* MODE.
*
*         EXIT   TO *CRV1* TO CONTINUE DEADSTART.
*
*         CALLS  URT.


 CDS      ROUTINE            ENTRY

          RJM    URT         UPDATE RESOURCE TABLE
          AOD    VA          INDICATE NOS/VE ACTIVE
          LDM    SCDP        UPDATE *SCD* PORT NUMBER
          RAML   ACDS
          RJM    SBL         SET BOOT LOAD OK STATUS IN *D8ST*
          RJM    DVE         DEADSTART NOS/VE
          RJM    SDS         SET DEADSTART STATUS
          RJM    DOP         DEADSTART ONE PROCESSOR
*         CALL   DSX         RETURN TO NORMAL SCI MODE

          ERRNZ  DSX-*       CODE ASSUMES ADJACENT ROUTINE
 DSX      SPACE  4,10
**        DSX - DEADSTART EXIT.
*         RELOAD *MDD* RESIDENT IF NECESSARY AND EXIT.
*
*         EXIT   TO *IDL* IF NOT CALLED FROM *CHK* IN *SCI* PRESET.
*                TO *CHKX* IF CALLED DURING *SCI* PRESET.


 DSX      ROUTINE

          LDML   PPNM        CHECK ENTRY CONDITIONS
          LMC    2R_SC
          ZJN    DSX1        IF IDLE LOOP IS LOADED
          LJM    CHKX        RETURN FROM *VPB* MODE

 DSX1     LDM    MDMT+PTDB.  CHECK IF *MDD* WAS ACTIVE
          SHN    21-13
          MJN    DSX2        IF *MDD* IS ACTIVE
          LJM    IDL         ELSE RETURN FROM *VPB* MODE

 DSX2     LDC    MDDSIO*10000+IDL  RELOAD *MDD* RESIDENT
          RJM    LNO         LOAD OVERLAY
*         LJM    IDL         (PERFORMED BY *LNO*)
 ACD      SPACE  4,10
**        ACD - ACTIVATE CONSOLE DRIVER.
*
*         ENTRY  PORT NUMBER SET IN *ACDS*.
*
*         EXIT   *SCI* PARAMETER TABLE WRITTEN.
*
*         USES   CM - CM+3.
*
*         CALLS  SPA, SPB.


 ACD      SUBR               ENTRY/EXIT
          LDD    SB          CHECK FOR THE PARAMETER TABLE
          ADD    SB+1
          NJP    ACD4        IF AROUND ALREADY
          LDM    PPNO        SET *SCI* PP NUMBER
          SHN    4
          RAML   ACDA+1
          LDML   MDMT+PTDB.  SET *MDD* MODE
          ZJN    ACD1        IF NOT CURRENTLY ACTIVE
          SCN    77
          STML   ACDM
 ACD1     RJM    SPA         SET UP R-REGISTER FOR *SCI* PARAMETER TABLE
          LDD    SB
          ADD    SB+1
          NJP    ACD1.1      IF SCIPT EXISTS

*         LOCATE SCPT ENTRY IN SSR AND USE IT AS THE SCIPT.
*         SET THE ADDRESS FOUND INTO WORD D7RS+2 OF THE EICB.

          SSRE   SCPT        FETCH RESERVED SPACE IN SSR FOR SCIPT
          STML   SBAO        SAVE OFFSET OF SCIPT
          SRD    SB          SAVE R-REGISTER OF SCIPT
          LRD    IB+1        SET R-REGISTER FOR EICB
          RJM    SPB         SET PP BOUNDS
          LDN    0           PREPARE D7RS+2 ENTRY
          STD    CM
          LDN    1           SET *SCIPT IN SSR FLAG*
          STD    CM+1
          LDD    SB+1        CONVERT R-POINTER TO RMA
          SHN    6
          SCN    77
          ADML   SBAO        ADD IN OFFSET
          STDL   CM+3
          SHN    -20         SAVE POSSIBLE CARRY
          STDL   CM+2
          LDD    SB
          SHN    6-4
          RADL   CM+2
          LDN    D7RS+2      WRITE RMA INTO EICB
          RJM    IIB
          CWDL   CM
          RJM    SPA         SET UP SCIPT ADDRESS FROM EICB (GET STD. OFFSET)

*         WRITE INFORMATION TO SCIPT.

 ACD1.1   LRD    SB          R-REGISER FOR SCIPT
          RJM    SPB         SET PP BOUNDS
          LDM    SBAO        OFFSET FOR SCIPT
          LMC    RR
          CWML   ACDA,ON     WRITE *SCI* TABLE
 ACD2     LDC    6000        SET *SCD* MODE
          ADM    ACDS        GET PORT NUMBER
          STM    SCMT+PTDB.
 ACD3     LJM    ACDX        RETURN

 ACD4     LDM    SBAO        CHECK IF *SCD* MODE ALREADY ACTIVE
          LRD    SB
          LMC    RR
          CRDL   CM
          LDDL   CM+2
          LPC    4000
          NJN    ACD3        IF *SCD* MODE WAS ALREADY ACTIVE
          LDML   ACDS        SET *SCD* DEFINITION BYTE
          STDL   CM+2
          LDDL   CM+1        SET *SCD* DEFINITION CHANGED FLAG
          LPC    77777
          LMC    100000
          STDL   CM+1
          RJM    SPB         SET PP BOUNDS
          LDM    SBAO        REWRITE PARAMETER TABLE
          LMC    RR
          CWDL   CM
          LJM    ACD2        SET *SCD* MODE/PORT

 ACDA     VFD    16/0        UNUSED FIELD
          VFD    1/1,1/1     *SCD* DEFINITION CHANGED, *MDD* DEFINITION CHANGED
          VFD    1/0         NO CHANGE IN *SCI* PARAMETER TABLE LENGTH
          VFD    1/0         INTERLOCK = CLEAR
          VFD    2/0         UNUSED FIELD
          VFD    6/0         *SCI* PP NUMBER
          VFD    4/4         LENGTH OF *SCI* PARAMETER TABLE

 ACDS     VFD    4/0         *SCD* CONSOLE DEFINITION BYTE
          VFD    1/0         CONSOLE STATE = INACTIVE
          VFD    2/2         SYSTEM STATE = VIRTUAL STATE
          VFD    3/1         CONSOLE EMULATES A 721
          VFD    3/0         CONTROLWARE CODE = NO CONTROLWARE
          VFD    3/**        PORT BIT(S)

 ACDM     VFD    4/0         *MDD* CONSOLE DEFINITION BYTE
          VFD    1/**        CONSOLE STATE = INACTIVE
          VFD    2/**        SYSTEM STATE = CTI
          VFD    3/**        PORT BIT(S)
          VFD    6/**        NOS COMMUNICATION CHANNEL
*COPY     CTP$SCI_BUILD_HARDWARE_REG
*COPY     CTP$SCI_BUILD_PAGE_TABLE
*COPY     CTP$SCI_COMPRESS_PAGE_TABLE
*COPY     CTP$SCI_COPY_TO_SAVE_AREA
 DOP      SPACE  4,10
**        DOP - DEADSTART ONE PROCESSOR.
*
*         EXIT   TO *AAC*, IF ERROR RETURNED ON *DFT* REQUESTS.
*
*         CALLS  DVP, IDR, IDT, IIB, RMP, SPB, SPR.
*
*         MACROS SSRE.


 DOP      SUBR               ENTRY/EXIT
          LDD    DO
          NJP    DOP3        IF NOT DUAL-STATE
 DOP1     LDN    D8DS
          RJM    IIB
          CRML   DSTW,ON     READ STATUS WORD
          LDML   DSTW+3
          LMN    1
          NJN    DOP1        IF *EI* NOT READY TO BE DEADSTARTED
          SSRE   DSAV
          RJM    SPR         SET UP PROCESSOR REQUEST
          LDN    H1P         HALT THE 170 PROCESSOR
          RJM    IDR         ISSUE DFT REQUEST
          LMN    RCNE        CHECK FOR NO ERROR ON REQUEST
          ZJN    DOP2        IF DFT REQUEST COMPLETED WITH NO ERROR
          LDC    DAH7        624 - *SCI* DETECTED *DFT* ERROR WHILE HALTING
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR

 DOP2     LRD    DP
          RJM    SPB         SET PP BOUNDARY
          LCN    0           UPDATE THE C170/C180 LOGGING FLAG
          STDL   W0
          STDL   W1
          STDL   W2
          LMN    1S3
          STDL   W3
          LDN    HDRP
          RJM    IDT
          RDCL   W0          SET 180 LOGGING
 DOP3     LDN    0           SET C180 DEADSTART COMPLETE
          STM    DSTW+3
          LDN    D8DS
          RJM    IIB
          CWML   DSTW,ON     WRITE DEADSTART WORD
          RJM    RMP         RELOCATE MONITOR PROCESS
          LDN    DVP         DEADSTART VIRTUAL PROCESSOR
          RJM    IDR         ISSUE DFT REQUEST
          LMN    RCNE        CHECK FOR NO ERROR ON REQUEST
          ZJP    DOPX        IF DFT REQUEST COMPLETED WITH NO ERROR
          LDC    DAS8        625 - *SCI* DETECTED *DFT* ERROR WHILE STARTING
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR
 DVE      SPACE  4,10
**        DVE - DEADSTART NOS/VE.
*
*         EXIT   TO *AAC*, IF ERROR RETURNED ON *DFT* REQUEST.
*
*         CALLS  ACD, BHR, BPT, CTS, IDT, IIB, INS, LCP, NRP, SPB.
*
*         MACROS SSRE.


 DVE      SUBR               ENTRY/EXIT
          LRD    IB+1        INTERFACE BLOCK ADDRESS
          RJM    SPB         SET PP BOUNDS
          LDN    D7ST        GET *DROPVE* FLAG WORD FROM EICB
          RJM    IIB
          CRDL   T4
          LDDL   T5
          SCN    20          CLEAR *DROPVE* BIT
          STDL   T5
          LDN    D7ST
          RJM    IIB
          CWDL   T4          REWRITE *DROPVE* FLAG WORD
          SSRE   DFTB        CREATE POINTER TO NOS/VE DFT REQUEST AREA
          SRD    CM+1        BUILD NOS/VE POINTER FOR DFT BUFFER
          RJM    NRP         NORMALIZE R-POINTER
          LDD    W4          NOS/VE BLOCK SIZE
          STD    CM+3
          LDN    NVEP
          RJM    IDT
          CWDL   CM          WRITE DFT NOS/VE REQUEST POINTER
          CRDL   VP          UPDATE VP POINTER
          LRD    SA
          RJM    SPB         SET PP BOUNDARY
          SSRE   BYVE        CLEAR TERMINATION STATUS FLAG
          LDN    0
          STD    W5
          LDDL   W1
          RJM    INS
          CWDL   W2
          RJM    ACD         ACTIVATE SYSTEM CONSOLE
          RJM    CTS         COPY MEMORY WHERE THE BOOT IS TO BE LOADED
                             TO THE SAVE AREA.  MAKE ROOM FOR THE CP BOOT.
          RJM    BPT         BUILD PAGE TABLE
          RJM    BHR         BUILD HARDWARE REGISTERS

          CODE   D
          LRD    BL
          LDC    3RVCB
          RJM    LCP         LOAD CIP PROGRAM
          CODE   *
          LMN    RCNE        CHECK FOR NO ERROR ON REQUEST
          ZJP    DVEX        IF DFT REQUEST COMPLETED WITH NO ERROR
          LDC    DASV        623 - *SCI* DETECTED *DFT* ERROR WHILE LOADING VCB
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR
 NRP      SPACE  4,10
**        NRP - NORMALIZE R-POINTER.
*
*         ENTRY  (A) = OFFSET FROM R.
*                (CM - CM+2) = R-POINTER


 NRP      SUBR               ENTRY/EXIT
          LPC    777777-RR
          STDL   CM
          SHN    -6
          RAD    CM+2        UPDATE R-REGISTER POINTER
          SHN    -14
          RAD    CM+1
          LDD    CM          FORM OFFSET TO A
          LPN    77
          STD    CM
          UJN    NRPX        RETURN
*COPY     CTP$SCI_RELOCATE_MPS_REGISTERS
 SBL      SPACE  4,10
**        SBL - SET BOOT LOAD OK STATUS IN *D8ST*.
*
*         EXIT   *SCI* DEADSTART STATUS IN *D8ST* SET TO INDICATE THAT THE
*                BOOT LOAD WAS SUCCESSFUL AND DEADSTART CAN CONTINUE.
*
*         USES   CM - CM+3.
*
*         CALLS  IIB, SPB.


 SBL      SUBR               ENTRY/EXIT
          LDN    D8ST
          RJM    IIB
          CRDL   CM
          LDN    BLOK        SET BOOT LOAD OK
          SHN    6
          RADL   CM+3
          RJM    SPB
          LDN    D8ST        REWRITE *D8ST*
          RJM    IIB
          CWDL   CM
          UJN    SBLX        RETURN
 SDS      SPACE  4,10
**        SDS - SET DEADSTART STATUS.
*
*         CALLS  IIB, SPB.


 SDS      SUBR               ENTRY/EXIT
          LRD    IB+1
          RJM    SPB         SET PP BOUNDARY
          LDN    D8DS        INFORM *SDA* THAT *SCI/VPB* IS READY
          RJM    IIB
          CWML   DSTW,ON
          UJN    SDSX        RETURN
*COPY     CTP$SCI_SET_UP_PROCESSOR_REQ
 URT      SPACE  4,10
**        URT - UPDATE RESOURCE TABLE IN THE SSR.
*
*         CALLS  SPB.


 URT      SUBR               ENTRY/EXIT
          LRD    SA
          RJM    SPB         SET BOUNDARY FOR PP
          SSRE   VEPP        SSR ENTRY POINTING TO TABLE
          CWML   CBUF,W4     WRITE PP/CHANNEL TABLE
          UJN    URTX        RETURN

          OVERFLOW  CBUF     CHECK FOR OVERFLOW

          ENDX
*DECK DECK=CTI$SCI_VPB_TERMINATE_NOSVE EXPAND=FALSE
          CTEXT  SCI VPB TERMINATE NOSVE
          OVERLAY  (SCI VPB TERMINATE NOS/VE - PART 1)
 CTV      SPACE  4,10
**        CTV - CHECK IF TIME TO TERMINATE NOS/VE.
*
*         CALLS  IIB.


 CTV      ROUTINE

*         SINCE SCI SHOULD NEVER EXECUTE THE TERMINATION CODE ON A CYBER 2000
*         MAINFRAME, THE FOLLOWING CHECK FOR A CYBER 2000 SHOULD NOT BE REQUIRED.
*         HOWEVER, FOR FAULT TOLERANT REASONS, THE CHECK IS INCLUDED JUST IN
*         CASE THE TERMINATE BIT OR THE DROPVE BIT SHOULD EVER GET SOMEHOW SET
*         IN THE EICB.  IN THIS CASE, SIMPLY RETURN TO THE IDLE LOOP.

          LDML   S0FLG       CHECK FOR CYBER 2000
          LMC    10000
          ZJN    CTV2        IF CYBER 2000
          LDN    D7ST        CHECK *DROPVE* FLAG
          RJM    IIB
          CRDL   T1
          LDD    T2
          LPN    20
          ZJN    CTV3        IF *DROPVE* FLAG NOT SET
          LDM    CTVA        CHECK TIMER
          NJN    CTV1        IF TIMER VALID
          LDN    10D+1       START 10 SECOND TIMER FOR TERMINATION REQUEST
          STM    CTVA
 CTV1     SOM    CTVA        DECREMENT TIMER
          ZJN    CTV4        IF TIMER EXPIRED, FORCE NOS/VE TERMINATION
 CTV2     LJM    IDL         RETURN TO IDLE LOOP TO SERVICE OTHER MODES

 CTV3     LDN    0           RESET TIMER
          STM    CTVA
          LDN    D8DS        CHECK NOS/VE TERMINATION FLAG
          RJM    IIB
          CRDL   T1
          LDD    T4
          LMN    1
          NJN    CTV2        IF NOS/VE TERMINATION NOT REQUESTED
 CTV4     CALL   TVE         TERMINATE NOS/VE

          OVERFLOW  SCMT
          OVERLAY  (SCI VPB TERMINATE NOS/VE - PART 2),MDDSI
 ABD      SPACE  4,10
**        ABD - ABORT NOS/VE DEADSTART.
*
*         THIS ROUTINE IS CALLED IF THE NOS/VE BOOT PROGRAMS HAVE NOT BEEN
*         INSTALLED TO THE CIP DEVICE.  DEADSTART IS ABORTED.
*
*         EXIT   TO *RMA*.
*
*         USES   CM - CM+3.
*
*         CALLS  IIB, SPB.


 ABD      ROUTINE

*         SET BOOT NOT INSTALLED STATUS IN *D8ST*.

          LDN    D8ST
          RJM    IIB
          CRDL   CM
          LDN    BPNI        SET BOOT NOT INSTALLED
          SHN    6
          RADL   CM+3
          RJM    SPB
          LDN    D8ST
          RJM    IIB
          CWDL   CM

*         CLEAR *D8DS* SO *SDA* WILL DROP.

          LDN    D8DS
          RJM    IIB
          CRDL   CM
          LDN    0
          STD    CM+1
          LDN    D8DS
          RJM    IIB
          CWDL   CM
          LJM    RMA         RESUME MODE ACTIVITY
 TVE      SPACE  4,10
**        TVE - TERMINATE NOS/VE.
*
*         EXIT   TO *AAC*, IF ERROR RETURNED ON *DFT* REQUESTS.
*
*         CALLS  FRT, IAD, ICD, IDR, IDT, INS, ISI, SPB, SPR, UDW,
*                URT, *REC*.


 TVE      ROUTINE

*         TERMINATE NOS/VE OPERATION AND, FOR DUAL-STATE, RESTART THE C170.

          LRD    DP          FIND THE VE REQUEST POINTER IN THE DFT BLOCK
          LDM    DFTO
          ADC    RR+4        ACTIVATE THE R-REGISTER
          CRDL   VP
          RJM    FRT         FETCH RESOURCE TABLE
          RJM    IAD         IDLE ALL I/O DRIVERS
          RJM    ISI         IDLE SECONDARY IOU
          RJM    URT         UPDATE RESOURCE TABLE
          RJM    ICD         IDLE CONSOLE DRIVER
          SSRE   RSAV
          RJM    SPR         SET UP PROCESSOR REQUEST
          LDN    HVP         HALT VIRTUAL PROCESSORS
          RJM    IDR         ISSUE DFT REQUEST
          LMN    RCNE        CHECK FOR NO ERROR ON REQUEST
          ZJN    TVE1        IF DFT REQUEST COMPLETED WITH NO ERROR
          LDC    DAH8        62C - *SCI* DETECTED *DFT* ERROR WHILE HALTING
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR

 TVE1     RJM    UDW         UPDATE DEADSTART WORD
          LDN    0           CLEAR NOS/VE ACTIVE STATUS
          STD    VA
          LDD    DO
          NJN    TVE2        IF NOT DUAL STATE
          LRD    DP
          RJM    SPB         SET PP BOUNDARY

*         UPDATE THE C170/C180 LOGGING FLAG, SET TRANSITION FROM DUAL STATE.

          LDC    1S11+1S3+1S0
          STDL   W3
          LDN    0
          STDL   W0
          STDL   W1
          STDL   W2
          RJM    IDT
          RDSL   W0          CLEAR 180 LOGGING, SET 170 ERRORS FLAG
          SSRE   DSAV
          RJM    SPR         SET UP PROCESSOR REQUEST
          LDN    S1P         START 170 PROCESSOR
          RJM    IDR         ISSUE DFT REQUEST
          LMN    RCNE        CHECK FOR NO ERROR ON REQUEST
          ZJN    TVE2        IF DFT REQUEST COMPLETED WITH NO ERROR
          LDC    DAS7        62D - *SCI* DETECTED *DFT* ERROR WHILE STARTING
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR

 TVE2     LJM    RMA         RESUME OTHER MODE(S)
          EJECT
 FRT      SPACE  4,10
**        FRT - FETCH RESOURCE TABLE.
*
*         EXIT   (CBUF) = PP/CHANNEL RESOURCE TABLE FROM *SSR*.


 FRT      SUBR               ENTRY/EXIT
          SSRE   VEPP        SSR ENTRY POINTING TO TABLE
          CRML   CBUF,W4     READ PP/CHANNEL TABLE
          UJN    FRTX        RETURN
 ICD      SPACE  4,10
**        ICD - IDLE CONSOLE DRIVER.
*
*         EXIT   (SCDP) = *SCD* PORT BIT(S) AT TIME OF TERMINATION.
*
*         USES   CM - CM+3, T1, T2.
*
*         CALLS  GSI, IIB, RTR.
*
*         MACROS LOCKMR, WRITMR.


 ICD4     LDD    SB
          ADD    SB+1
          ZJN    ICDX        IF NO SCI PARAMETER TABLE
          RJM    GSI         GET *SCI* PARAMETER TABLE INTERLOCK
          LDDL   CM+1        SET CHANGED FLAG
          LPC    0#7FFF
          LMC    0#8000
          STDL   CM+1
          LDDL   CM+2        TURN OFF SCD/VE
          LPC    15777
          STDL   CM+2
          LDM    SBAO
          LMC    RR          ACTIVATE R-REGISTER
          CWDL   CM          WRITE CHANGES AND CLEAR INTERLOCK

 ICD      SUBR               ENTRY/EXIT
          LDM    MDMT+PTDB.  TEST *MDD* ACTIVE
          ZJN    ICD1        IF *MDD* NOT DEFINED
          LDC    BPA         SET TO BREAK PORT ACCESS
 ICD1     STM    MDMT+RTNP.  SET *MDD* ROUTINE
          LDM    SCMT+PTDB.  SET (SCDP) = PORT BITS
          LPN    3
          STM    SCDP
          LDML   SCMT+PTDB.  TURN OFF *SCD/VE*
          LPC    15777
          STML   SCMT+PTDB.
          SHN    21-11
          MJP    ICD4        IF *SCD/NOS* ACTIVE
          LDML   SCMT+PTDB.  TEST IF *SCD/VE* HAD A PORT
          SHN    21-14
          PJN    ICD2        IF NOT
          LOCKMR SET
          RJM    RTR         READ TEST MODE REGISTER
          STD    T1          SAVE RDATA+7
          LDM    SCMT+PTUS.  GET PORTS USED BY *SCD/VE*
          LPN    1
          STD    T2          SAVE PORT NUMBER
          ADN    1
          LMDL   T1          CLEAR PORT NUMBER
          STM    RDATA+7
          WRITMR RDATA,I0CC
          LOCKMR CLEAR
          LDML   EMC0,T2     SET THAT *SCI* DOES NOT HAVE THE PORT
          STM    EMC0,T2

*         IF THERE IS NO *SCI* PARAMETER TABLE ADDRESS IN THE EICB, THEN TURN
*         OFF *SCI* PARAMETER BLOCK CHECKING.

 ICD2     LDN    D7RS+2      CHECK FOR *SCI* PARAMETER TABLE ADDRESS
          RJM    IIB
          CRDL   CM
          LDDL   CM+2
          LPC    377
          ADDL   CM+3
          NJN    ICD3        IF *SCI* PARAMETER TABLE ADDRESS EXISTS
*         LDN    0           TURN OFF *SCI* PARAMETER BLOCK CHECKING
          STD    SB
          STD    SB+1
          STM    SBAO

*         TURN OFF *SCD* MODE.

 ICD3     LDN    0           TURN OFF *SCD* MODE
          STM    SCMT+PTDB.
          STM    SCMT+RTNP.
          LJM    ICDX        RETURN
 IDR      SPACE  4,10
**        IDR - ISSUE DFT REQUEST.
*
*         ENTRY  (A) = PARAMETER FOR DFT.
*                (VP - VP+3) = DFT REQUEST POINTER.
*
*         EXIT   REQUEST ISSUED TO DFT.
*                (A) = DFT RESPONSE CODE.
*
*         USES   CM - CM+3, W0 - W0+3.
*
*         CALLS  IVB, SPB.


 IDR      SUBR               ENTRY/EXIT
          STDL   CM          SAVE PARAMETER WORD
          LRD    VP+1
          RJM    SPB         SET PP BOUNDARY FOR VE REQUEST BLOCK
          LDD    VP+3
          RJM    IVB         INDEX TO VPB BLOCK
          CWDL   CM          WRITE DFT REQUEST
          STDL   CM
          ADN    1
          CWML   IDRA,ON     WRITE ADDITIONAL PARAMETERS
          SRD    CM+1        BUILD REQUEST POINTER
          LDN    2
          STD    CM+3
          LDN    0
          RJM    IVB         INDEX VE BLOCK
          CWDL   CM          WRITE DFT REQUEST POINTER
 IDR1     LDD    VP+3        INDEX TO VPB REQUEST
          RJM    IVB
          CRDL   W0          READ STATUS WORD
          LDDL   W0
          SHN    -10
          ZJN    IDR1        IF NOT COMPLETE
          UJN    IDRX        CONTINUE CURRENT ROUTINE

 IDRA     CON    0,0,0,0
*COPY     CTP$SCI_INCREMENT_DFT_BUFFER
 ISI      SPACE  4,15
**        ISI - IDLE SECONDARY IOU.
*
*         EXIT   TO *AAC*, IF ERROR RETURNED ON *DFT* REQUEST.
*
*         USES   CM - CM+3.
*
*         CALLS  IDR.
*
*         NOTES  THIS ROUTINE IS ONLY EXECUTED IN A DUAL STATE
*                ENVIRONMENT.  *DFT-S* IS NOT IDLED BY *SCI*.
*                INSTEAD IT IS LEFT RUNNING SO IT CAN RETURN VARIOUS
*                TYPES OF INFORMATION, SUCH AS, THE CONTENTS OF THE
*                IOU1 MAINTENANCE REGISTERS AND IOU1 PP-S TO THE *NVE*
*                SUBSYSTEM.  *DFT-S* IS THEN IDLED BY THE *NVE*
*                SUBSYSTEM WHEN IT HAS OBTAINED THE NEEDED INFORMATION.


 ISI      SUBR               ENTRY/EXIT

*         IDLE PP-S AND CHANNELS IN IOU1.

          LDM    MION
          ZJN    ISIX        IF SINGLE IOU
          LDC    0#100       IOU 1/SUBFUNCTION 0
          STDL   CM+1
          LDN    0
          STDL   CM+2
          STDL   CM+3
          LDN    IAP         IDLE ALL PP-S (EXCEPT DFT-S)
          RJM    IDR         ISSUE DFT REQUEST
          LMN    RCNE        CHECK FOR NO ERROR ON REQUEST
          ZJN    ISI5        IF DFT REQUEST COMPLETED WITH NO ERROR
          LDC    DASI        62B - *SCI* DETECTED *DFT* ERROR WHILE IDLING 2ND IOU
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR

*         UPDATE IOU RESOURCE TABLE FOR IOU1.
*         NOTE THAT *DFT-S* CANNOT DO THIS SINCE IT DOES
*         NOT KNOW THE STRUCTURE OF THE IOU RESOURCE TABLE.

 ISI5     LDC    IRTL/2      START AT SECOND HALF OF TABLE (FOR IOU1)
          STDL   T1
 ISI10    LDN    0           INITIALIZE REPLACEMENT ENTRY
          STDL   T2
          LDML   CBUF,T1     TEST WHETHER PP ENTRY IS LOGICALLY OFF
          LPC    0#FF
          LMN    0#F
          NJN    ISI20       IF PP IS LOGICALLY ON
          LDN    0#F
          STDL   T2          INDICATE PP IS LOGICALLY OFF
 ISI20    LDML   CBUF,T1     TEST WHETHER CHANNEL ENTRY IS LOGICALLY OFF
          SHN    -10
          LMN    0#F
          NJN    ISI30       IF CHANNEL IS LOGICALLY ON
          LDC    0#F00
          RADL   T2          INDICATE CHANNEL IS LOGICALLY OFF
 ISI30    LDDL   T2          UPDATE IOU RESOURCE TABLE ENTRY
          STML   CBUF,T1
          AODL   T1
          SBK    IRTL
          NJP    ISI10       PROCESS NEXT TABLE ENTRY
          UJP    ISIX        RETURN
*COPY     CTP$SCI_INCREMENT_DFT_VE_BLOCK
*COPY     CTP$SCI_SET_UP_PROCESSOR_REQ
 UDW      SPACE  4,10
**        UDW - UPDATE DEADSTART WORD AND CLEAR RELOCATION POINTER.
*
*         EXIT   (*D8DS* PARCEL 3) = 0.
*                (*D8RLP* PARCEL 3) = 0.
*
*         USES   CM - CM+3.
*
*         CALLS  IIB, SPB.


 UDW      SUBR               ENTRY/EXIT
          LRD    IB+1
          RJM    SPB         SET PP BOUNDARY
          LDN    D8DS        READ *D8DS*
          RJM    IIB
          CRDL   CM
          LDN    0           CLEAR DEADSTARTED STATUS
          STD    CM+3
          LDN    D8DS
          RJM    IIB
          CWDL   CM          WRITE DEADSTART WORD
          LDN    D8RLP       READ RELOCATION CONTROL WORD
          RJM    IIB
          CRDL   CM
          LDN    0           CLEAR R-POINTER LENGTH
          STD    CM+3
          LDN    D8RLP       REWRITE RELOCATION CONTROL WORD
          RJM    IIB
          CWDL   CM
          UJN    UDWX        RETURN
 URT      SPACE  4,10
**        URT - UPDATE RESOURCE TABLE IN THE SSR.
*
*         ENTRY  (CBUF) = PP/CHANNEL RESOURCE TABLE.
*
*         EXIT   PP/CHANNEL RESOURCE TABLE IN *SSR* UPDATED.
*
*         CALLS  SPB.


 URT      SUBR               ENTRY/EXIT
          LRD    SA
          RJM    SPB         SET BOUNDARY FOR PP
          SSRE   VEPP        SSR ENTRY POINTING TO TABLE
          CWML   CBUF,W4     WRITE PP/CHANNEL TABLE
          UJN    URTX        RETURN
 WFP      SPACE  4,10
**        WFP - WRITE FIRST WORD OF THE *SCI* PARAMETER TABLE.
*
*         ENTRY  (CM - CM+3) = UPDATED FIRST WORD.
*                OS BOUNDS CORRECTLY SET.


 WFP      SUBR               ENTRY/EXIT
          LRD    SB          WRITE WORD
          LDM    SBAO
          LMC    RR
          CWDL   CM
          UJN    WFPX        RETURN
          SPACE  4,10
*         COMMON DECKS.


*COPY     CTP$SCI_VPB_IDLE_IOU0
 RMA      SPACE  4,15
**        RMA - RESUME MODE ACTIVITY.


*         BECAUSE *RMA* MAY RELOAD *MDD* RESIDENT, IT MUST START AT *OVLA*
*         SO THAT *MDD* RESIDENT DOES NOT OVERWRITE IT.

          BSS    OVLA-*      POSITION *RMA* AT OVLA

 RMA      BSS    0           ENTRY

*         CLEAN UP THE *SCI* PARAMETER TABLE.  CLEAR THE *SCD* BYTE IF *SCD/NOS*
*         IS NOT ACTIVE.  CLEAR THE *MDD* BYTE IF *MDD* MODE WAS NOT ACTIVATED
*         BY CTI OR C170.

          LDD    SB
          ADD    SB+1
          NJN    RMA5        IF PARAMETER TABLE DEFINED
          UJN    *           IF PARAMETER TABLE NOT DEFINED, HANG

 RMA5     RJM    GSI         GET *SCI* PARAMETER TABLE INTERLOCK
          LDN    D7RS
          RJM    IIB
          CRDL   W0
          LDM    SCMT+PTDB.  CHECK IF *SCD/NOS* ACTIVE
          SHN    21-11
          PJN    RMA15       IF *SCD/NOS* NOT ACTIVE

*         *SCD/NOS* IS ACTIVE SO THE *SCD* BYTE WILL NOT BE CLEARED.
*         DETERMINE IF THE *MDD* BYTE SHOULD BE CLEARED.

          LDDL   W0+1
          SHN    -15
          LPN    5
          NJN    RMA10       IF CTI/MDD OR C170/MDD INITIATED
          LDN    0           CLEAR *MDD* BYTE
          STDL   CM+3
          LDDL   CM+1        SET *MDD* BYTE CHANGED FLAG
          LPC    0#AFFF
          LMC    0#4000
          STDL   CM+1
 RMA10    RJM    WFP         WRITE FIRST WORD OF PARAMETER TABLE
          LOADOV MDDSI       RELOAD *MDD* RESIDENT
          CALL   SMT         RESET MODE TABLES

*         *SCD/NOS* IS NOT ACTIVE.  CLEAR THE *SCD* BYTE AND DETERMINE IF THE
*         *MDD* BYTE SHOULD BE CLEARED.

 RMA15    LDN    0           CLEAR *SCD* BYTE
          STDL   CM+2
          LDDL   CM+1        SET *SCD* BYTE CHANGED FLAG
          LPC    0#6FFF
          LMC    0#8000
          STDL   CM+1
          LDM    MDMT+PTDB.  CHECK IF *MDD* ACTIVE
          ZJP    RMA20       IF *MDD* NOT ACTIVE
          LDDL   W0+1        CHECK IF CTI OR C170 INITIATED
          SHN    -15
          LPN    5
          NJN    RMA10       IF CTI OR C170 INITIATED

*         *MDD* WAS INITIATED FROM THE C180 SIDE.  CLEAR THE PORT RESERVED BIT IF HELD,
*         THE *MDD* BYTE AND THE PP NUMBER IN THE PARAMETER TABLE.

          LDML   MDMT+PTDB.  CHECK IF *MDD* HAS A PORT RESERVED
          SHN    21-14
          PJP    RMA17       IF *MDD* DOES NOT HAVE A PORT RESERVED
          LDM    S0FLG
          NJN    RMA17       IF ON AN S0/S0E
          LDML   MDMT+PTDB.  GET PORT NUMBER
          LPN    1
          ADC    SCNI+1      CREATE SHIFT INSTRUCTION
          STML   RMAA
          LOCKMR SET
          RJM    RTR         READ TEST MODE REGISTER
 RMAA     SCN    1           CLEAR PORT 0 RESERVED BIT
*         SCN    2           (CLEAR PORT 1 RESERVED BIT)
          STML   RDATA+7
          WRITMR RDATA,ELIO,ITMR  REWRITE TEST MODE REGISTER
          LOCKMR CLEAR
 RMA17    LDN    0           CLEAR *MDD* BYTE
          STDL   CM+3
          LDDL   CM+1        CLEAR PP NUMBER AND SET CHANGED FLAG
          LPC    0#AC0F
          LMC    0#4000
          UJN    RMA25       WRITE FIRST WORD OF PARAMETER TABLE

*         *MDD* IS NOT CURRENTLY ACTIVE.  CLEAR THE PP NUMBER FROM THE
*         PARAMETER TABLE.  THEN CHECK IF THIS COPY OF *SCI* WAS ORIGINALLY
*         LOADED FOR C170 *MDD* MODE.  IF SO, RELOAD THE C170 PP RESIDENT.
*         OTHERWISE HANG WAITING FOR TERMINATION CODE TO IDLE AND RETURN
*         THE PP TO C170.  IN THIS CASE, THE PP MUST BE AN UPPER PP.

 RMA20    LDDL   CM+1        CLEAR PP NUMBER
          LPC    0#FC0F
 RMA25    STDL   CM+1
          RJM    WFP         WRITE FIRST WORD OF PARAMETER TABLE
          LRD    SA          ENSURE THIS IS AN UPPER PP
          RJM    SPB
          LDDL   W0+1
          SHN    21-15
          PJN    *           IF C170 *MDD* MODE NOT SET, HANG
          SHN    0-4-21+15   ISOLATE PP NUMBER
          LPN    77
          SBM    PPNO
          NJN    *           IF NOT C170 *MDD* MODE PP, HANG
          CALL   RCP         RELOAD C170 PP RESIDENT

          OVERFLOW  CBUF     CHECK FOR OVERFLOW

          ENDX
*DECK DECK=CTI$TWO_PORT_MUX_ROUTINES EXPAND=FALSE
          CTEXT  CTI$TWO PORT MUX ROUTINES.                             
          SPACE  4                                                      
QUAL$     IF     -DEF,QUAL$                                             
          QUAL   COMPTMA                                                
QUAL$     ENDIF                                                         
          BASE   M                                                      
          CODE   DECIMAL                                                
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992              
          SPACE  4                                                      
***       COMPTMA - TWO-PORT MULTIPLEXOR ACCESS.                        
*         B. R. HANSON                                                  
          SPACE  4                                                      
***              COMPTMA DEFINES ROUTINES TO TALK WITH A TERMINAL       
*         ON THE TWO PORT MULTIPLEXOR.  THESE ROUTINES OBSERVE THE      
*         PROTOCOL FOR ACCESSING A PORT ON THE MULTIPLEXOR AND FOR      
*         TALKING WITH THAT PORT.  THIS PROTOCOL PROVIDES FOR SHARING   
*         THE PORT AND THE MULTIPLEXOR BETWEEN PP PROGRAMS AND          
*         OPERATING SYSTEMS.                                            
*                                                                       
*         THE PROTOCOL FOR ACCESSING A TERMINAL ON THE TWO PORT MUX     
*         IS AS FOLLOWS.                                                
*                                                                       
*         THE IOU TEST-MODE REGISTER (A0) CONTAINS SIX BITS RESERVED    
*         FOR SOFTWARE USE - BITS 58-63.  THEY ARE DEFINED AS           
*                58 - PORT 1 RE-REQUESTED.                              
*                59 - PORT 0 RE-REQUESTED                               
*                60 - PORT 1 REQUESTED.                                 
*                61 - PORT 0 REQUESTED.                                 
*                62 - PORT 1 RESERVED.                                  
*                63 - PORT 0 RESERVED.                                  
*                                                                       
*         WHEN A PP PROGRAM WANTS TO USE A PORT ON THE TWO PORT MUX,    
*         IT MUST SET THE *RESERVED* BIT IN THE TEST-MODE REGISTER.  IF 
*         THAT BIT IS ALREADY SET, IT MAY SET THE *REQUESTED* BIT IN    
*         THE REGISTER AND WAIT FOR THE OTHER PP TO RELEASE THE PORT    
*         BY CLEARING THE *RESERVED* BIT.                               
*                                                                       
*         IF A PP HAS RELIQUISHED ACCESS TO THE PORT TO ANOTHER         
*         REQUESTING PP.  IT SHOULD SET THE RE-REQUESTED BIT TO         
*         INDICATE THAT IT WISHES TO REACQUIRE THE PORT BUT IS          
*         WILLING TO WAIT FOR THAT ACCESS.                              
*                                                                       
*         THE SHARING OF THE TWO-PORT MULTIPLEXOR BETWEEN TWO PP-S      
*         TALKING TO SEPERATE PORTS ON THE MULTIPLEXOR IS THROUGH       
*         THE CHANNEL 15 AND 17 FLAGS.  SINCE THE *SCF* INSTRUCTION     
*         FOR CHANNEL 15 DOES NOT GUARANTEE EXCLUSIVE ACCESS TO THE     
*         CHANNEL, THE CHANNEL FLAG FOR CHANNEL 17 MUST BE USED TO      
*         ENSURE THIS CONDITION.  THE SEQUENCE OF ACCESS TO CHANNEL     
*         15 SHOULD BE -                                                
*                                                                       
*         SCF 17             INTERLOCK CHANNEL 17                       
*         SCF 15             INTERLOCK CHANNEL 15                       
*         CCF 17             CLEAR INTERLOCK ON 17                      
*         SELECT PORT                                                   
*         STATUS PORT                                                   
*         PERFORM IO OPERATION                                          
*         DESELECT PORT                                                 
*         CCF 15             CLEAR INTERLOCK ON 15                      
*                                                                       
*         THE FUNCTIONS PROVIDED BY THIS COMMON DECK ARE -              
*      *STM* - SELECT TERMINAL ON MULTIPLEXOR.  GAINS ACCESS TO         
*           A SPECIFIC PORT ON THE MULTIPLEXOR.                         
*      *CPR* - CHECK FOR PORT REQUEST.  CHECKS THE TEST-MODE REGISTER   
*           FOR REQUESTS FOR ACCESS TO THE PORT BEING USED.             
*      *RCT* - READ CHARACTER FROM TERMINAL.  PERFORMS THE OPERATIONS   
*           NECESSARY TO READ A CHARACTER FROM THE TERMINAL ON THE      
*           PORT BEING USED.                                            
*      *WCT* - WRITE CHARACTER TO TERMINAL.  PERFORMS THE OPERATIONS    
*           NECESSARY TO WRITE A CHARACTER TO THE TERMINAL CONNECTED    
*           TO THE PORT BEING USED.                                     
*      *GTS* - GET TERMINAL STATUS.  GETS JUST THE STATUS INFORMATION   
*           FOR THE PORT BEING USED.                                    
          SPACE  4,10                                                   
          PURGMAC DCN*                                                  
 DCN*     PPOP   4,7500      DEFINE *DCN**                              
          SPACE  4                                                      
**        GLOBAL DATA FOR ALL ROUTINES.                                 
*                                                                       
                                                                        
                                                                        
 RBUF     BSSZ   10          MAINTENANCE REGISTER BUFFER                
 SFMX     CON    0           PORT SELECT FUNCTION                       
 SSMX     CON    0           LAST TERMINAL STATUS                       
 CPA      SPACE  4                                                      
**        CPA - CLEAR PORT ACCESS.                                      
*                                                                       
*         ENTRY  TWO-PORT MUX IS RESERVED BY THIS PP.                   
*                                                                       
*         EXIT   TWO-PORT MUX IS DESELECTED AND CHANNEL IS RELEASED.    
                                                                        
                                                                        
 CPA      SUBR               ENTRY/EXIT                                 
          FNC    MXDM,MX     DESELECT MULTIPLEXOR                       
          AJM    *,MX        WAIT FOR FUNCTION COMPLETE                 
          CCF    *,MX        RELEASE CHANNEL INTERLOCK                  
          UJN    CPAX        RETURN                                     
 CPR      SPACE  4,10                                                   
**        CPR - CHECK FOR PORT REQUEST.                                 
*                                                                       
*         ENTRY  PORT RESERVED BY THIS PP.                              
*                                                                       
*         EXIT   (A) = 1/REREQUESTED, 0, 1/REQUESTED                    
*                                                                       
*         CALLS  RSB.                                                   
                                                                        
                                                                        
 CPR      SUBR               ENTRY/EXIT                                 
          RJM    RSB         READ STATUS BITS                           
          SHN    -2          IGNORE PORT RESERVED BIT                   
          UJN    CPRX        RETURN                                     
 DLY      SPACE  4,10                                                   
**        DLY - DELAY FOR .05 OF A SECOND.                              
*                                                                       
*         ENTRY  NONE.                                                  
*                                                                       
*         EXIT   0.05 SECONDS LATER.                                    
*                                                                       
*         USES   A.                                                     
                                                                        
                                                                        
 DLY      SUBR               ENTRY/EXIT                                 
          LDC    100000                                                 
 DLY1     SBN    1                                                      
          PJN    DLY1        IF DELAY NOT EXPIRED                       
          UJN    DLYX        RETURN                                     
 DTO      SPACE  4,10                                                   
**        DTO    DEAD MAN TIMEOUT CHECK                                 
*                                                                       
*         ENTRY  (A) = WORD COUNT FROM READMR                           
*                                                                       
*         THIS ROUTINE WILL PRINT A DEADMAN                             
*         TIMEOUT MESSAGE IF A IS NON ZERO.                             
                                                                        
                                                                        
 DTO      SUBR   ENTRY/EXIT                                             
          ZJN    DTOX        IF COMPLETED NORMALLY                      
          PRINT  DTOM                                                   
          LJM    CMDX        RETURN FROM COMMAND                        
                                                                        
 DTOM     ASCII  (DEADMAN TIMOUT)                                       
 GTS      SPACE  4,10                                                   
**        GTS - GET TERMINAL STATUS.                                    
*                                                                       
*         ENTRY  NONE.                                                  
*                                                                       
*         EXIT   (A) = STATUS OF TERMINAL.                              
*                                                                       
*         CALLS  CPA, SPA.                                              
                                                                        
                                                                        
 GTS      SUBR               ENTRY/EXIT                                 
          RJM    SPA         SET PORT ACCESS                            
          RJM    CPA         CLEAR PORT ACCESS                          
          UJN    GTSX        RETURN                                     
 IFN      SPACE  4,10                                                   
**        IFN - ISSUE FUNCTION                                          
*                                                                       
*         ENTRY  (A) = FUNCTION TO BE ISSUED                            
*                PORT SELECTED                                          
                                                                        
                                                                        
 IFN      SUBR               ENTRY/EXIT                                 
          FAN    MX          ISSUE FUNCTION CODE                        
          AJM    *,MX        WAIT FOR FUNCTION COMPLETE                 
          UJN    IFNX                                                   
 RCT      SPACE  4,10                                                   
**        RCT - READ CHARACTER FROM TERMINAL.                           
*                                                                       
*         ENTRY  PORT RESERVED BY THIS PP.                              
*                                                                       
*         EXIT   (A) = CHARACTER DESIRED.                               
*                (A) = 0, IF NO CHARACTER PRESENT.                      
*                                                                       
*         CALLS  CPA, SPA, WCT.                                         
                                                                        
                                                                        
 RCT1     FNC    MXRD,MX     READ CHARACTER FUNCTION                    
          AJM    *,MX        WAIT FOR FUNCTION COMPLETE                 
          ACN    MX                                                     
          IAN    MX                                                     
          DCN*   MX                                                     
          RJM    CPA         CLEAR PORT ACCESS                          
                                                                        
 RCT      SUBR               ENTRY/EXIT                                 
          RJM    SPA         START PORT ACCESS                          
          SHN    21-3                                                   
          MJN    RCT1        IF CHARACTER PRESENT                       
          RJM    CPA         CLEAR PORT ACCESS                          
          LDN    0                                                      
          UJN    RCTX        RETURN WITH NO CHARACTER                   
 RSB      SPACE  4,10                                                   
**        RSB - READ STATUS BITS.                                       
*                                                                       
*         ENTRY  (RSBA) = SET BASED ON PORT BEING USED.                 
*                                                                       
*         EXIT   (A) = 1/RE-REQUESTED, 1/0, 1/REQUESTED,                
*                                      1/0, 1/RESERVED.                 
*                                                                       
*         USES   (RBUF - RBUF+7).                                       
*                                                                       
*         MACROS READMR.                                                
                                                                        
                                                                        
 RSB      SUBR               ENTRY/EXIT                                 
          READMR RBUF,ELIO,ITMR                                         
          LDM    RBUF+7      FETCH BITS 59-63                           
 RSBA     SHN    0           (IF PORT 0 BEING USED)                     
*         SHN    -1          (IF PORT 1 BEING USED)                     
          LPN    25B                                                    
          UJN    RSBX        RETURN                                     
 RTM      SPACE  4,10                                                   
**        RTM - RELEASE TERMINAL ON MULTIPLEXOR.                        
*                                                                       
*         ENTRY  THIS TERMINAL HAS ACCESS TO THE TERMINAL.              
*                                                                       
*         EXIT   THE FLAGS IN THE TEST MODE REGISTER RESET.             
*                                                                       
*         USES   AP, SFMX.                                              
*                                                                       
*         CALLS  RSB, USB.                                              
*                                                                       
*         MACROS LOCKMR.                                                
                                                                        
                                                                        
 RTM      SUBR               ENTRY/EXIT                                 
          LDD    AP          CHECK IF PORT ATTACHED                     
          ZJN    RTMX        IF PORT DETACHED                           
          LOCKMR SET                                                    
          RJM    RSB         READ STATUS BITS                           
          LDC    5S12+0                                                 
          RJM    USB         CLEAR RESERVED/REQUESTED BITS              
          LOCKMR CLEAR                                                  
          LDN    0                                                      
          STD    AP          CLEAR PORT ATTACHED                        
          STM    SFMX        CLEAR ACCESS CODE                          
          UJN    RTMX        RETURN                                     
 SPA      SPACE  4,10                                                   
**        SPA - START PORT ACCESS.                                      
*                                                                       
*         ENTRY  PORT RESERVED BY PP.                                   
*                (SFMX) = FUNCTION CODE TO SELECT PORT.                 
*                                                                       
*         EXIT   PORT ACCESS OBTAINED.                                  
*                (A) = MUX STATUS.                                      
                                                                        
                                                                        
 SPA      SUBR               ENTRY/EXIT                                 
          LDM    LOCK                                                   
          ZJN    SPA0        IF MDD HAS NOT SET A LOCK                  
          SCF    *,MX        INSURE MUX CHANNEL FLAG SET                
          UJN    SPA2        JUST GET MX                                
                                                                        
 SPA0     LDC    1000D       RESET FULL TIMEOUT                         
          STD    T0          STORE TIMEOUT FOR CTE                      
 SPA1     SCF    SPA9,MR     GET ACCESS TO MAINTENANCE CHANNEL          
          SCF    SPA4,MX     GET ACCESS TO TWO-PORT MULTIPLEXOR         
          CCF    *,MR                                                   
 SPA2     LDN    0                                                      
          STM    SPAC        CLEAR MESSAGE SENT FLAG                    
          LDM    SFMX                                                   
          ZJN    SPA3        IF NO FUNCTION TO ISSUE                    
          RJM    IFN         SELECT PORT                                
          FNC    MXSS,MX     FETCH PORT STATUS                          
          AJM    *,MX        WAIT FOR FUNCTION COMPLETE                 
          ACN    MX                                                     
          IAN    MX                                                     
          DCN    MX                                                     
 SPA3     STM    SSMX        SAVE TERMINAL STATUS                       
          UJP    SPAX        RETURN                                     
                                                                        
 SPA4     CCF    *,MR                                                   
          LDN    77          WAIT A BIT                                 
          SBN    1                                                      
          NJN    *-1                                                    
          RJM    CTE         CHECK FOR TIME OUT                         
          MJN    SPA5        IF TIMED OUT                               
          UJP    SPA1        TRY AGAIN FOR MX FLAG                      
                                                                        
 SPA5     AOML   C15H        ADD ONE TO CH-15 ERROR COUNT               
          LDM    SPAC                                                   
          NJN    SPA7        IF MESSAGE ALREADY SENT                    
          LDC    =C* CHANNEL 15 HUNG *                                  
          LMC    ERLN                                                   
          STM    SPAC        SET MESSAGE SENT FLAG                      
          RJM    DFM         SEND MESSAGE TO ERROR LOG                  
 SPA7     LJM    SPA0                                                   
                                                                        
 SPA8     AOML   C17H        ADD ONE TO CH-17 ERROR COUNT               
          LDN    10          RESET TIMEOUT                              
          STD    T0                                                     
                                                                        
 SPA9     RJM    CTE         CHECK FOR TIME OUT                         
          MJN    SPA8        IF EXPIRED                                 
          LJM    SPA1        RETRY                                      
                                                                        
 SPAC     CON    0           DAYFILE MESSAGE SENT                       
 STM      SPACE  4,10                                                   
**        STM - SELECT TERMINAL ON MULTIPLEXOR.                         
*                                                                       
*         ENTRY  (A) = TERMINAL TO OBTAIN ACCESS TO.                    
*                                                                       
*         EXIT   (A) = 0, IF ACCESS FAILED.                             
*                                                                       
*         CALLS  DLY, RSB, USB.                                         
*                                                                       
*         USES   AP, RSBA, SFMX, T2, USBA.                              
*                                                                       
*         MACROS LOCKMR.                                                
                                                                        
                                                                        
 STM3     LDC    25S12+1                                                
          STM    STMA        SAVE FACT PORT ACQUIRED                    
          RJM    USB         SET PORT RESERVED, PORT NOT REQUESTED      
          LOCKMR CLEAR                                                  
          LDN    1                                                      
          STD    AP          SET PORT ATTACHED FLAG                     
                                                                        
 STM      SUBR               ENTRY/EXIT                                 
          ADC    MXPT        FORM PORT SELECT FUNCTION                  
          STM    SFMX                                                   
          LMC    SHNI&MXPT   FORM SHIFT INSTRUCTION                     
          STM    USBA                                                   
          LMN    77          COMPLEMENT SHIFT COUNT                     
          STM    RSBA                                                   
          LDN    0                                                      
          STD    T2                                                     
                                                                        
 STM0     LOCKMR SET                                                    
          RJM    RSB         READ STATUS BITS                           
          LPN    1                                                      
          ZJN    STM3        IF PORT IS FREE                            
          LDC    0                                                      
 STMA     EQU    *-1         PORT ACQUIRED BEFORE FLAG                  
          ZJN    STM1        IF NEVER ACQUIRED                          
          LDC    20S12+20                                               
          UJN    STM1.5                                                 
 STM1     LDC    4S12+4                                                 
 STM1.5   RJM    USB         SET PORT REQUESTED BIT                     
          LOCKMR CLEAR                                                  
          RJM    DLY         DELAY .05 SECONDS                          
          SOD    T2                                                     
          NJN    STM0        TRY AGAIN                                  
          LDN    0                                                      
          STM    AP          CLEAR PRT ATTACHED FLAG                    
          STM    SFMX        CLEAR PORT SELECT FUNCTION                 
          LJM    STMX        RETURN                                     
 USB      SPACE  4,10                                                   
**        USB - UPDATE STATUS BITS.                                     
*                                                                       
*         ENTRY  (A) = 5/MASK, 7/0, 5/VALUE                             
*                (RBUF - RBUF+7) = CURRENT TESTMODE REGISTER CONTENTS.  
*                                                                       
*         EXIT   TESTMODE REGISTER REWRITTEN.                           
*                                                                       
*         USES   T1.                                                    
*                                                                       
*         MACROS WRITMR.                                                
                                                                        
                                                                        
 USB      SUBR               ENTRY/EXIT                                 
 USBA     SHN    0           (IF PORT 0)                                
*         SHN    1           (IF PORT 1)                                
          STD    T1                                                     
          SHN    -14                                                    
          ADC    SCNI        FORM MASK                                  
          STM    USBB                                                   
          LDM    RBUF+7                                                 
 USBB     SCN    0                                                      
          LMD    T1                                                     
          STM    RBUF+7                                                 
          WRITMR RBUF,ELIO,ITMR                                         
          UJN    USBX        RETURN                                     
 WCT      SPACE  4,10                                                   
**        WCT - WRITE CHARACTER TO TERMINAL.                            
*                                                                       
*         ENTRY  (A) = ASCII CHARACTER VALUE.                           
*                                                                       
*         EXIT   (A) = ENTRY VALUE.                                     
*                                                                       
*         CALLS  CPA, DLY, SPA.                                         
*                                                                       
*         USES   T1.                                                    
                                                                        
                                                                        
 WCT1     FNC    MXWT,MX     FUNCTION TO WRITE                          
          LDD    T1                                                     
          AJM    *,MX        WAIT FOR FUNCTION COMPLETE                 
          ACN    MX                                                     
          OAN    MX          OUTPUT CHARACTER                           
          DCN*   MX+40       DISCONNECT CHANNEL                         
          RJM    CPA         CLEAR PORT ACCESS                          
                                                                        
 WCT      SUBR               ENTRY/EXIT                                 
          STD    T1                                                     
 WCT2     RJM    SPA         START PORT ACCESS                          
          SHN    21-4                                                   
          MJN    WCT1        IF BUFFER NOT FULL                         
          RJM    CPA         CLEAR PORT ACCESS                          
          RJM    DLY         DELAY FOR 0.05 SECONDS                     
          UJN    WCT2        TRY TO OUTPUT AGAIN                        
          SPACE  4                                                      
          CODE   *                                                      
          BASE   *                                                      
          PURGMAC DCN*                                                  
 QUAL$    IF     -DEF,QUAL$                                             
          QUAL   *                                                      
 CPA      EQU    /COMPTMA/CPA                                           
 CPR      EQU    /COMPTMA/CPR                                           
 DTO      EQU    /COMPTMA/DTO                                           
 IFN      EQU    /COMPTMA/IFN                                           
 GTS      EQU    /COMPTMA/GTS                                           
 RCT      EQU    /COMPTMA/RCT                                           
 RSB      EQU    /COMPTMA/RSB                                           
 RTM      EQU    /COMPTMA/RTM                                           
 SFMX     EQU    /COMPTMA/SFMX                                          
 SSMX     EQU    /COMPTMA/SSMX                                          
 SPA      EQU    /COMPTMA/SPA                                           
 STM      EQU    /COMPTMA/STM                                           
 WCT      EQU    /COMPTMA/WCT                                           
 QUAL$    ENDIF                                                         
          ENDX                                                          
*DECK DECK=CTM$BCT_VERSION_RECORD EXPAND=TRUE
          IDENT  BCT
          CIPPU  J
          BASE   MIXED
          TITLE  CTM$BCT VERSION RECORD
          COMMENT *SMD* LVL=01
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          EJECT
***       BCT - BOOT CONTROL TABLE IDENTIFICATION RECORD.
*
*         THE SOLE PURPOSE OF THE BCT RECORD IS TO PROVIDE A 77 TABLE
*         CONTAINING THE VERSION LEVEL OF THE BOOT CONTROL RECORD.
*         THIS VERSION LEVEL WILL BE CHECKED BY THE SERVICE PROCESSOR
*         IN A CYBER 2000 ENVIRONMENT AT THE TIME THE BOOT RECORDS ARE
*         LOADED TO THE CIP DEVICE.  IF THE VERSION LEVEL IS NOT ONE
*         THAT IS SUPPORTED BY THE SERVICE PROCESSOR, IT WILL DISPLAY
*         A MESSAGE INDICATING THAT.
*
*         THIS RECORD EXISTS IN A NON-CYBER 2000 ENVIROMENT BUT IS NOT USED.
          SPACE  4
          END
/EOR
*DECK DECK=CTM$DFT_835_CLASS EXPAND=TRUE
          IDENT  DFT2,70B
          CIPPU  J
          MEMSEL 16
          BASE   MIXED
          TITLE  CTM$DFT 835 CLASS (DFT2).
          COMMENT *SMD* LVL=11
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 DFT      SPACE  4,10
***       DFT - DEDICATED FAULT TOLERANCE.
*         B. R. HANSON.      82/06/21. (PRECURSOR KNOWN AS SMU)
*         G. J. FALCONER.    85/08/05. (DFT V1.0)
*         G. J. FALCONER.    86/02/27. (DFT V2.0)
*         G. J. FALCONER.    87/11/20. (DFT V4.0)

 DFT      SPACE  4,10
***       DFT PERFORMS:
*
*         1) CTM$DFT_835_CLASS WILL PROCESS ERRORS FOR THE CONTROL DATA
*         MODEL 835 COMPUTER SYSTEM. THE ERRORS LOGGED AND CLEARED ARE
*         THOSE THAT OCCUR IN THE CPU, IOU, OR CENTRAL MEMORY ELEMENTS AND
*         RESULT IN THE STATUS SUMMARY BIT 59 (SUMMARY STATUS) BIT BEING SET.
*
*         2) DFT WILL ALSO PERFORM A SEQUENCE OF STEPS TO DEADSTART THE SYSTEM FROM
*         C170 STATE OPERATION TO DUAL-STATE OPERATION OR TO RETURN IT TO
*         STANDALONE C170 OPERATION.  THIS IS PERFORMED UPON THE REQUEST
*         OF THE PP BOOT (*VPB* STATE OF *SCI*).
*
*         4) PROVIDING EXTERNALIZATIONS OF *2AP* FUNCTIONS TO NOS/VE.
 CONTROL  SPACE  4,10
**        ASSEMBLY PARAMETERS.

 PPTYPE   EQU    0           TURN ON TRACKING OF UPPER/LOWER PP
 PRGM     SET    2           SET *OVERLAY* MACRO TO *DFT* NAMES
*STEP$    SET    0           ASSEMBLE *STEP* CODE IF SYMBOL DEFINED

          LIST   X
*COPY     CTP$DFT_RELEASE_HISTORY
*COPY     CTH$DEDICATED_FAULT_TOLERANCE
          LIST   *
 COMMON   SPACE  4,10
**        COMMON DECKS.


*COPYC DSI$PP_MACROS
*COPYC DSI$MAINTENANCE_REGISTER_MACROS
*COPYC CTI$COMPASS_OS_LEVELS
*COPYC CTC$DFT_MACROS
*COPYC CTC$DFT_DIRECT_CELLS
*COPYC CTI$DFT_ANALYSIS_CODES
*COPY DSC$PP_MR_AND_TPM_CONSTANTS
*COPY CTC$DFT_CONSTANTS
*COPY CTC$DFT_ACTION_NO_OVERFLOW
*COPY DSA$HARDWARE_TABLE_DEFINITIONS
*COPY DSA$VE_REQUESTS_TO_DFT
          LIST   *
*COPY DSI$PP_INSTRUCTION_MNEMONICS
          LIST   X
*COPY CTC$EI_CONTROL_BLOCK
          LIST   *

**        START DEFINITION OF THE MAIN LOOP OF DFT.
*

*COPYC CTP$DFT_MAIN_LOOP
 UTE      SPACE  4,10
**        UTE - UPDATE WALL CLOCK CHIP TIME IN EICB
*
*         STUB ON 835


 UTE      SUBR               ENTRY/EXIT
          UJN    UTEX
*COPYC CTP$DFT_MAIN_LOOP_DUAL_STATE
*COPYC CTP$DFT_MAIN_LOOP_NO_PACKETS
 CRN      SPACE  4,10
**        CRN - CHECK RELOCATION NECESSARY
*
*         STUB ON A 835

 CRN      SUBR               ENTRY/EXIT
          UJN    CRNX
 CPC      SPACE  4,10
**        CPC - CHECK FOR PACKET COMMUNICATION
*
*         STUB ON 835

 CPC      SUBR               ENTRY/EXIT
          UJN    CPCX

**        END OF DFT MAIN LOOP DEFINITIONS

*COPYC CTC$DFT_GLOBAL_DATA
*COPYC CTC$DFT_GLOBAL_DATA_NON_S0
 CELCW    CON    0           IGNORED ON 810,815,825,830
*COPYC CTP$DFT_RESIDENT_COMMON
*COPYC CTP$DFT_RESIDENT_ECM_NON_S0
*copy dsi$find_cip_module
*copy dsi$get_hardware_element
*COPYC CTP$MR_PROTOCOL_PREPROCESS
*COPYC CTP$MR_RETRY_OPERATION_FOR_DFT
*COPYC CTP$MR_PROTOCOL_PROCESS
*COPYC CTP$MR_PROTOCOL_POSTPROCESS
*copy DSI$PP_UTILITY_SUBROUTINES
          USE    PRESET
          QUAL   PRESET
*COPYC CTP$DFT_PRESET
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_PRESET_NON_DUAL_I4
 SPO      SPACE  4,10
**        SPO - SETUP MEMORY PORT OFFSET.
*
*         EXIT   PO IS SET TO THE MODEL DEPENDENT PORT OFFSET.
*
*         USES   PO.


 SPO      SUBR               ENTRY/EXIT
          LDN    4           SETUP MEMORY PORT OFFSET
          STD    PO
          UJN    SPOX        RETURN
          USE    *
          QUAL   *
          OVERLAY  (RESIDENT PART II),R2ORG
          QUAL   *
*COPYC CTP$DFT_RESIDENT_II_NON_990
*COPYC CTP$DFT_RESIDENT_II_COMMON
*COPYC CTP$DFT_NON_930_RESIDENT_II
*COPYC DSI$PACK_UNPACK_REGISTERS
*COPYC DSI$VALIDATE_PP_BOUNDS
          USE    OVERFLOW
          ERRNG  10000-*     RESIDENT II OVERFLOWS PP
*COPYC CTP$DFT_PRESET_BUILD_STRUCTURE
          OVERLAY (STANDARD PRESET OVERLAY ROUTINES)
*COPYC CTP$DFT_PRESET_STANDARD_OVL
 SSO      SPACE  4,10
**        SSO - PRESET  SPECIAL OVERLAY FOR IOU BIT 57 ERROR.
*         NON OPERATIONAL HERE.


 SSO      SUBR
          UJN    SSOX        RETURN

*COPY CTP$DFT_RETURN_ERROR_CODE
 SMV      SPACE  4,10
**        SMV - SETUP MODEL DEPENDENT VALUES.
*
*         *SMV* WILL SET UP REGISTER LIST ADDRESSES ON A MODEL DEPENDENT BASIS, AND
*         WILL INITIALIZE ALL MODEL DEPENDENT GLOBAL DATA.


 SMV      SUBR               ENTRY/EXIT
          LDC    SXIU        UNCORRECTED REG LIST FOR IOU
          STM    IO0U        SAVE LIST ADDRESS
          STM    IO0C
          LDC    SXMA
          STM    ME0U        UNCORRECTED MEMORY ERROR LIST
          STM    ME0C        CORRECTED MEMORY ERROR LIST
          LDC    S2PC
          STM    CP0C       CORRECTED ERROR LIST
          LDC    S2PU
          STM    CP0U       UNCORRECTED ERROR LIST

*         835 MODELS DONT HAVE WALL CLOCK CHIPS SO CHECK IF EICB
*         LEVEL SUPPORTS ONE AND IF IT DOES WRITE DEFAULT VALUE
*         THERE.

          LDN    D7TY
          RJM    IIB
          CRDL   T4          READ D7TY OF EICB
          LDD    T7
          SHN    -6
          SBN    4
          MJN    SMV10       IF EICB DOES NOT SUPPORT TIMESTAMP FIELD
          LDN    0           ZERO OUT THE TIMESTAMP FIELD IN THE EICB
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDN    D8WT
          RJM    IIB         INCREMENT INTERFACE BUFFER
          CWDL   T1          WRITE DEFAULT TIME VALUE TO EICB
 SMV10    LJM    SMVX        RETURN
*COPY     CTP$DFT_NO_CLEAR_PACKETS
*COPYC CTP$DFT_PRESET_NON_PACKETS
          OVERLAY  (MAIN NON-RESIDENT ROUTINES)

**        START OF THE MAIN NON RESIDENT ROUTINES OVERLAY. ON CYBER 835
*         THIS OVERLAY DEFINES ROUTINES FOR DUAL STATE, NON DUAL I4
*         NON HALT ON ERROR PROCESSING, AND NO PACKET COMMUNICATION.



*COPYC CTP$DFT_MAIN_NON_RES_RTNS
*COPYC CTP$DFT_MAIN_NON_RES_NON_I4
*COPYC CTP$DFT_MAIN_NON_RES_DUAL_STATE
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPY CTP$DFT_PREPARE_FOR_CIP_CALL
*COPYC CTP$DFT_CPU_HANDSHAKER
 BCA      SPACE  4,10
**        BCA - HANDLE BLOCKED CM ACCESS.
*         THIS IS VALID ON A MODEL 44,43 IOU ONLY. (STUB HERE)
          QUAL   HB57


 BCA      SUBR
          UJN    BCAX        RETURN
          QUAL   *

 HOE      SPACE  4,10
**        HOE - HALT ON ERROR
*
*         STUB ON AN 835


          ROUTINE HOE
          LJM    HOEX

 RED      SPACE  4,10
**        RED - READ 960 POWER MONITOR.
*
*         ON ANY MACHINE OTHER THAN THE 960 THIS ROUTINE IS
*         NON FUNCTIONAL.


          ROUTINE RED
          LJM    REDX

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DO DFT ACTIONS)

*COPYC CTP$DFT_ACTION_LIST
*COPYC CTP$DFT_ACTION_LIST_OVERFLOW
*COPYC CTP$DFT_ACTION_LIST_DUAL_STATE
*COPYC CTP$DFT_RETURN_TASK_ERROR
 IAPP     BSS    0           NOT USED ON 835
          TASK   (RRE)

 DDCM     BSS    0           CLEAR CM ERROR
          TASK   (CCE)

 DDCE     BSS    0           CLEAR 835 PROCESSOR ERRORS
          TASK   (CLE,SPR)
          QUAL   *
          QUAL   *
          QUAL   ABC
*COPY CTP$DFT_RETURN_ERROR_CODE
          QUAL   *
          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY (SAVE PP REGISTERS IN CENTRAL MEMORY)
*COPYC CTP$DFT_SAVE_PP_REGISTERS
*COPY  CTP$DFT_DUMP_PP_REGISTERS
*COPY  DSI$DUMP_LOAD_IDLE_PP
          OVERLAY (DFT ERROR CONTROL OVERLAY)
*COPYC CTP$DFT_ERROR_CONTROL

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY (LOG TOP OF HOUR COUNTERS)

*COPYC CTP$DFT_LOG_COUNTERS
 RMC      SPACE  4,10
**        RMC - RESET MODEL DEPENDENT COUNTERS.
*


          ROUTINE RMC        ENTRY/EXIT
          LJM    RMCX

 RMCF     CON    0
*COPY     CTP$DFT_NO_RESET_PIT
*COPY     CTP$DFT_NO_TEST_DLD_PATH

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (ENVIRONMENT/SHORT WARNING PROCESSORS)

**        THIS OVERLAY HAS A STUBBED REFERENCE TO CHECK IF THE CONSOLE IS ALIVE.
*         ON CYBER 835 THIS MECHANISM IS NOT USED. THE STUB REPORTS THE CONSOLE IS ALIVE.

*COPYC CTP$DFT_ENVIRONMENT_RTNS
*COPY  CTP$DFT_FIND_WARNING_IN_NRSB
 CCA      SUBR
          LDN    1
          UJN    CCAX        REPORT CONSOLE ALIVE ON NON S0 MACH.
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (ANALYSE PROCESSOR ERRORS)
 APE      SPACE  4,10
**        APE - ANALYSE PROCESSOR ERRORS.
*
*         CALLS  BRL, CLR, PAC, SCS, *CFF*, *LOG*, *RMR*, *STP*, *SWP*.


          ROUTINE APE

          LDN    0
          STM    NERR        SET NO ERROR FLAG FALSE

*         IT IS NECESSARY TO SAVE THE PREHALT STATUS SUMMARY BECAUSE
*         HALTING THE PROCESSOR WILL SET THIS BIT.

          LDM    SUMS        SUMMARY STATUS
          STM    OLSS        SAVE PRE HALT PROCESSOR SUMMARY STATUS
          SHN    21-SSSW     SHORT WARNING
          PJN    APE0        IF NO SHORT WARNING
          CALL   SWP         CALL SHORT WARNING PROCESSOR
          LJM    APEX        RETURN

 APE0     RJM    CTE         CHECK IF THRESHOLD EXCEEDED
          NJP    APEX        IF EXCEEDED IGNORE ERROR
          CALL   CFF         CHECK FOR FREEZE
          LDM    RTP2
          ZJN    APE0.5      IF NOT TO IGNORE ERROR
          LDN    0
          STM    DFTA        NO ACTION
          STM    REGI        RESET REGISTER LIST
          UJP    APEX
 APE0.5   LDN    0
          RJM    SCS         SAVE PRE-HALT CONTROL STORE ADDRESS
          CALL   STP         CALL STOP PROCESSOR
          LDM    CPUO
          STM    CPUH        HALTED CPU ORDINAL
          LDN    1
          RJM    SCS         SAVE AFTER HALT CONTROL STORE ADDRESS

*         DISABLE *PFS* AND BLOCK EXCHANGE REQUEST BITS SET IN *DEC*.

          LDN    BC
          RJM    CLR
          LDM    OLSS
          SHN    21-SSPH     PROCESSOR HALT IN SUMMARY STATUS
          PJP    APE5        IF PROCESSOR NOT HALTED
          LDML   CP0CC       CPU 0 CONNECT CODE
          STDL   EC
          LDML   CSAR
          STDL   RN
          READMR RDATA
          RJM    PAC         PACK REGISTER TO *MRVAL*
          LDN    1
          STD    T1
 APE1     LDML   MRVAL,T1
          LMML   APEA,T1
          NJN    APE3        IF CLASS I HALT
          AOD    T1
          LPN    4
          ZJN    APE1        IF MORE TO CHECK

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = PROCESSOR HALT CLASS II.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).

          SETDAC DDDC
          SETDAN (EPUN,DASWH)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          UJN    APE4


*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = PROCESSOR HALT CLASS I.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).

 APE3     SETDAC DDDC
          SETDAN (EPUN,DAPH)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
 APE4     LDM    CP0U        GET UNCORR REGISTER LIST FOR CPU0
          RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          LJM    APE14       CONTINUE PROCESSING

 APE5     LDM    SUMS        SUMMARY STATUS
          SHN    21-SSUE     UNCORRECTED ERROR
          PJP    APE8        IF NOT UNCORRECTED ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED PROCESSOR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).
*         DFT ANALYSIS - OS ACTION = UNCORRECTED PROCESSOR ERROR.
*                                  = NO OS ACTION (VERSION 4).

          SETDAN (EPUN,DAUPE)
          SETFLG (BC.FL)
          SETOSA OSUPE,OSNA
          LDM    CPUH        GET ORDINAL OF CPU BEING PROCESSED
          NJN    APE6
          LDM    CP0U        GET UNCORR REGISTER LIST FOR CPU0
          UJN    APE7        CONTINUE

 APE6     LDM    CP1U        GET UNCORR REGISTER LIST FOR CPU1
 APE7     RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          LJM    APE14       CONTINUE PROCESSING

 APE8     LDM    SUMS        SUMMARY STATUS
          SHN    21-SSCE     CORRECTED ERROR
          PJP    APE11       IF NOT CORRECTED ERROR
          LDM    OLSS        GET SAVED STATUS SUMMARY
          SHN    21-SSPH
          MJP    APE11       IF PROCESSOR HALT

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CORRECTED PROCESSOR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAN (EPCO,DACPE)
          SETFLG (BC.FL)
          LDM    CPUH        GET ORDINAL OF CPU BEING PROCESSED
          NJN    APE9
          LDM    CP0C        GET CORR REGISTER LIST FOR CPU0
          UJN    APE10       CONTINUE

 APE9     LDM    CP1C        GET CORR REGISTER LIST FOR CPU1
 APE10    RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          LJM    APE14       CONTINUE PROCESSING


*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED PROCESSOR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).
*         DFT ANALYSIS - OS ACTION = UNCORRECTED PROCESSOR ERROR.
*                                  = NO OS ACTION (VERSION 4).

 APE11    SETDAN (EPUN,DAUPE)
          SETFLG (BC.FL)
          SETOSA OSUPE,OSNA
          LDM    CPUH        GET ORDINAL OF CPU BEING PROCESSED
          NJN    APE12       IF CPU1
          LDM    CP0U        GET UNCORR REGISTER LIST FOR CPU0
          UJN    APE13       CONTINUE

 APE12    LDM    CP1U        GET UNCORR REGISTER LIST FOR CPU1
 APE13    RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS

 APE14    LDM    DFTA
          LMC    DDDC
          ZJN    APE15       IF DISABLE CPU
          SETDAC (DDCE)

 APE15    CALL   LOG
          LJM    APEX        RETURN

*         THE FOLLOWING TABLE DEFINES THE MICROCODE ADDRESSES FOR
*         A CPU HALTED BECAUSE OF A CLASS II(UCR/MCR) CONDITION.

 APEA     CON    0
          CON    0#1B6
          CON    0#1B5
          CON    0#1B5

*COPY     CTP$DFT_SAVE_CONTROL_STORE
*COPY CTP$DFT_CHECK_CPU_THRESHOLD

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY (ANALYZE IOU ERRORS
          QUAL
*COPYC CTP$DFT_ANALYZE_IOU_ERRORS
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (ANALYSE MEMORY ERRORS)
 AME      SPACE  4,10
**        AME - PROCESS MEMORY ERRORS.
*
*         CALLS  CLR, GSC, FMB, *CFF*, *LOG*, *SME*.


          ROUTINE AME

          LDN    0
          STM    RLST        CORRECTED ERROR FLAG
          STM    NERR        SET NO ERROR FLAG FLAG
          STML   SBER
          STML   SBER+1
          STML   SYCD
          LDN    BC
          RJM    CLR         ZERO SCRATCH BUFFER
          LDM    SUMS        SUMMARY STATUS
          SHN    21-SSUE
          PJP    AME1        IF NOT UNCORRECTED
          READMR RDATA,CMCC,MUL2
          LDML   RDATA
          LMC    0#A0        CANCEL OUT VALID AND PARTIAL WRITE PARITY ERROR
          NJP    AME0.1      IF NOT PARTIAL WRITE PARITY ERROR


*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = PARTIAL WRITE PARITY ERROR
*         DFT ANALYSIS - DFT ACTION = CLEAR MEMORY ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).
*         DFT ANALYSIS - OS ACTION = MULTIPLE ODD BIT ERROR.
*                                  = SYSTEM STEP. (VERSION 4)

          SETDAC DDCM
          SETDAN (EPUN,DAPWP)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          SETOSA OSUCM,OSSS
          UJP    AME0.2      LOG THIS ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED CM ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR MEMORY ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).
*         DFT ANALYSIS - OS ACTION = UNCORRECTED MEMORY ERROR.
*                                  = NO OS ACTION (VERSION 4).

 AME0.1   SETDAC DDCM
          SETDAN (EPUN,DAUME)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          SETOSA OSMOB,OSNA
 AME0.2   LDM    ME0U        UNCORRECTED MEMORY REGISTER LIST
          RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          CALL   CFF         CHECK FOR FREEZE
          LDM    RTP2
          ZJN    AME0.3      IF NOT TO IGNORE ERROR
          LDN    0
          STM    DFTA        NO ACTION
          STM    REGI        RESET REGISTER LIST INDEX
          UJP    AMEX

 AME0.3   CALL   LOG
 AME0     LJM    AMEX        RETURN

 AME1     LDM    SUMS
          SHN    21-SSCE
          PJN    AME0        IF NOT A CORRECTED ERROR
          LDN    1
          STM    RLST        SET CORRECTED ERROR LIST FLAG

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CORRECTED CM ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR MEMORY ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAC DDCM
          SETDAN (EPCO,DACME)
          SETFLG (BC.FL)
          LDM    ME0C        CORRECTED MEMORY ERROR REGISTERS
          RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          CALL   CFF
          LDM    RTP2
          ZJN    AME3        IF NOT TO IGNORE ERRORS
          LDN    0
          STM    DFTA        NO ACTION
          STM    REGI        RESET REGISTER LIST INDEX
          UJP    AMEX

*         PROCESS CYBER 835 MEMORY ERRORS.

 AME3     RJM    GSC         GET SYNDROME CODE
          LDDL   W2
          SHN    -14D
          STML   SBER+1      LOWER ADDRESS BITS 32 - 33
          LDDL   W1
          LPC    0#3FFF
          SHN    2
          RAML   SBER+1      BITS 18 - 31 OF ADDRESS
          LDDL   W1
          SHN    -14D
          STML   SBER        BITS 16 - 17 OF ADDRESS
          LDDL   W0
          LPN    7           BITS 13 - 15  OF ADDRESS
          SHN    2
          RAML   SBER
          CALL   SME         SERVICE MEMORY ERROR
          LJM    AMEX        RETURN
 GSC      SPACE  4,10
**        GSC - GET SYNDROME CODE.
*
*         ENTRY  (W0 - W3) = PROPER *CEL* REGISTER.
*
*         EXIT   (SYCD) = SYNDROME CODE.
*
*         USES   W0 - W3, *SYCD*.


 GSC      SUBR               ENTRY/EXIT
          LDN    0
          STM    SYCD

*         PROCESS CYBER 835 SYNDROME CODE.

 GSC2     LDC    MCEL        READ CORRECTED ERROR LOG REGISTER
          RJM    FMB
          CRDL   W0
          LDDL   W0
          SHN    21-17
          PJP    AMEX        IF VALID BIT NOT SET
          LDDL   W2
          LPN    77          BITS 0 - 5
          SHN    2
          STML   SYCD        SAVE WHOLE SYNDROME
          LDDL   W3
          SHN    -14D        BITS 6 - 7 OF SYNDROME
          RAML   SYCD
          LJM    GSCX        RETURN
*COPY CTP$DFT_SERVICE_MEMORY_ERROR
*COPY CTP$DFT_REWRITE_CM_ERROR
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (LOG ERRORS TO BUFFER CONTROL WORDS)

**        ON CYBER 990 THERE IS SPECIAL HANDLING OF COMPARING MULTIPLE
*         RETRY ERRORS.

*COPYC CTP$DFT_LOG_ERROR
*COPY CTP$DFT_FIND_CONTROL_WORD
*COPY CTP$DFT_INCREMENT_ERROR_COUNT
*COPY CTP$DFT_LOG_ERROR_CHECK_MATCH
*COPYC CTP$DFT_LOG_ERROR_NON_990
*COPYC CTP$DFT_LOG_ERROR_NO_CONSOLE
*COPY CTP$DFT_ZERO_SUPPORTIVE_STATUS
*COPY  CTC$DFT_ELEMENT_CONVERSIONS
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (GENERATE FAULT SYMPTOM CODE)

**        CYBER 835 FAULT SYMPTOM CODES.

*COPYC CTP$DFT_GENERATE_FAULT_SYMPTOM
*COPY     CTP$DFT_GENERATE_NO_I4C_CODES
          ROUTINE I4S
          LJM    I4SX        RETURN

          ROUTINE I4A
          LJM    I4AX        RETURN

          ROUTINE I4I
          LJM    I4IX

          QUAL   *

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (READ MAINTENANCE REGISTERS)
          QUAL   *           SO THAT OTHER OVERLAYS MAY ACCESS
 S2PC     SPACE  4,10
**        CYBER 835 PROCESSOR CORRECTED ERROR REGISTER LIST.


 S2PC     REGLST (10,00,12,30,90,92)
 S2PU     SPACE  4,10
**        CYBER 835 PROCESSOR UNCORRECTED ERROR REGISTER LIST.


 S2PU     REGLST (10,00,12,30,80,81)

 SXMA     SPACE  4,10
**        CYBER 835 MEMORY REGISTER LIST FOR ALL MEMORY ERRORS.


 SXMA     REGLST (10,00,12,20,A0,A4,A8,21)
 SXIU     SPACE  4,10
**        I1/I1CR CORRECTED AND UNCORRECTED IOU ERROR LIST.


 SXIU     REGLST (10,00,12,30,40,80,81,A0,18,21)
*COPYC CTP$DFT_READ_MAINTENANCE_REGS
 ZSS      SPACE  4,10
**        ZSS - ZERO SUPPORTIVE STATUS.
*
*         NOTE   THIS ROUTINE IS INOPERATIVE ON A CYBER 180-835.


 ZSS      SUBR               ENTRY/EXIT
          UJN    ZSSX        RETURN
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (PROCESSOR PRIMITIVES)

*COPY CTP$DFT_PROCESSOR_PRIMITIVES

 STRBTS   SPACE  4,10
**        STRBTS - STORE BITS IN *DEC*.


          ROUTINE STRBTS


*         PROCESS CYBER 835.

 SETBTP2  LDM    RDATA+4     SET PRESERVE/DISABLE PP EXCHANGES
          LPC    -0#80
          LMC    0#80        PRESERVE/DISABLE PP EXCHANGES
          STM    RDATA+4
          LDM    RDATA+5     DISABLE *PFS*
          SCN    2
          LMN    2
          STM    RDATA+5
          LJM    STRBTSX     RETURN
 CLRBTS   SPACE  4,10
**        CLRBTS - RESTORE MODEL-DEPENDENT BITS IN *DEC*.
*
*         MACROS READMR, WRITMR.


 CLRBTS   SUBR               ENTRY/EXIT
          READMR RDATA,HBUF+CPRPC,DEMR  READ *DEC* REGISTER


*         PROCESS CYBER 835.

 CLRBTP2  LDM    RDATA+4     RESTORE BER SETTING
          LPC    -0#80
          STM    RDATA+4
          LDM    RDATA+5     RESTORE *PFS* SETTING
          SCN    2
          STM    RDATA+5

          WRITMR RDATA,HBUF+CPRPC  REWRITE *DEC* REGISTER
          LJM    CLRBTSX     RETURN
*COPY CTP$DFT_MANAGE_MEMORY_PORT

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (MASSAGE CPU REGISTERS)
*COPY CTP$DFT_MASSAGE_CPU_REGISTERS

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (CLEAR ERRORS)
 CLE      SPACE  4,10
**        CLE - CLEAR ERRORS.
*
*         EXIT   ALL REGISTERS NECESSARY WILL BE CLEARED OF ERRORS.


          ROUTINE CLE

          LDM    HBUF+HDRPC
          STD    EC
          FUNCMR ,MRCE       CLEAR ERRORS FROM *PFS* REGISTERS
          LJM    CLEX        RETURN

 CCE      SPACE  4,10
**        CCE - CLEAR CM ERRORS.
*
*         CALLS  FMB, UPR.


          ROUTINE CCE


*         PROCESS 835 MAINFRAMES.

 CCE2     LDM    RLST
          NJP    CCE4.5      IF CORRECTED ERROR

*         CLEAR UNCORRECTED ERROR LOG 1 AND 2.

          LDC    MUL1
          STD    RN
          RJM    FMB         GET MAINTENANCE BUFFER POINTER FOR REGISTER
          CRML   MRVAL,ON
          RJM    UPR         UNPACK TO (RDATA)
          LDM    RDATA
          SHN    21-7
          PJN    CCE4        IF VALID NOT SET
          LDM    RDATA
          LPN    0#3F        SAVE ALL BUT VALID, UNLOGGED BITS
          STM    RDATA
          WRITMR RDATA,HBUF+HDRPC
 CCE4     LDC    MUL2
          STD    RN          SET UP *UEL2* REGISTER
          RJM    FMB
          CRML   MRVAL,ON
          RJM    UPR
          LDM    RDATA
          SHN    21-7
          PJN    CCE4.1      IF VALID NOT SET
          LDM    RDATA
          LPN    0#3F        SAVE ALL BUT VALID, UNLOGGED BITS
          STM    RDATA
          WRITMR RDATA,HBUF+HDRPC
 CCE4.1   LJM    CCEX        RETURN

 CCE4.5   LDC    MCEL
          STD    RN          CORRECTED MEMORY ERROR REGISTER
          RJM    FMB
          CRML   MRVAL,ON
          RJM    UPR
          LDM    RDATA
          SHN    21-7
          PJN    CCE4.1      IF VALID NOT SET
          LDM    RDATA
          LPN    0#3F        SAVE ALL BUT VALID, UNLOGGED
          STM    RDATA
          WRITMR RDATA,HBUF+HDRPC
          LJM    CCEX        RETURN
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (UPDATE C170 MEMORY)
*COPYC CTP$DFT_UPDATE_170_MEMORY

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_OS_REQUESTS
*COPYC CTP$DFT_OS_REQUESTS_NON_PACKETS

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS - 2)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_REQUEST_PROCESSOR_2

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (PP REQUEST PROCESSOR)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_PP_UTILITY_REQUESTS
*COPY  CTP$DFT_DUMP_PP_REGISTERS
*COPY  DSI$DUMP_LOAD_IDLE_PP

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT ERROR LOGGING ROUTINES)
*COPY     CTP$DFT_PROCESS_DISK_ERROR
*COPY CTP$DFT_RETURN_ERROR_CODE
          OVERFLOW R2ORG
          OVERLAY  (RESTART SCI PP)
 QUAL$    EQU    0
*COPYC CTP$DFT_RESTART_SCI
*COPY DSI$DUMP_LOAD_IDLE_PP
          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT RUN TIME ERROR HANDLING)
*COPYC CTP$DFT_RUN_TIME_ERROR_HANDLER
*COPY CTP$DFT_RETURN_ERROR_CODE
*copy     ctp$construct_message_in_eicb

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          END
/EOR
*DECK DECK=CTM$DFT_930_CLASS EXPAND=TRUE
          IDENT  DFT0,70B
          CIPPU  J
          MEMSEL 16
          BASE   MIXED
          TITLE  CTM$DFT 930 CLASS (DFT0).
          COMMENT *SMD* LVL=11
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 DFT      SPACE  4,10
***       DFT - DEDICATED FAULT TOLERANCE.
*         B. R. HANSON.      82/06/21. (PRECURSOR KNOWN AS SMU)
*         G. J. FALCONER.    85/08/05. (DFT V1.0)
*         G. J. FALCONER.    86/02/27. (DFT V2.0)
 DFT      SPACE  4,10
***       DFT PERFORMS:
*
*         1) CAPTURING THE CONTENT OF MAINFRAME MAINTENANCE REGISTERS
*         FOR ERROR LOGGING, AND CLEARING HARDWARE ELEMENT ERRORS.
*
*         2) THE ACTUAL SEQUENCE OF STEPS TO DEADSTART THE SYSTEM, UNDER
*         THE DIRECTION OF *VPB* MODE OF *SCI*.
*
*         3) PROVIDING EXTERNALIZATIONS OF *2AP* FUNCTIONS TO NOS/VE.
 CONTROL  SPACE  4,10
**        ASSEMBLY PARAMETERS.


 PRGM     SET    2           SET *OVERLAY* MACRO TO *DFT* NAMES
*STEP$    SET    0           ASSEMBLE *STEP* CODE IF SYMBOL DEFINED

          LIST   X
*COPY     CTP$DFT_RELEASE_HISTORY
*COPY     CTH$DEDICATED_FAULT_TOLERANCE
          LIST   *
 COMMON   SPACE  4,10
**        COMMON DECKS.


*COPYC DSI$PP_MACROS
*COPYC DSI$MAINTENANCE_REGISTER_MACROS
*COPYC CTI$COMPASS_OS_LEVELS
*COPYC CTC$DFT_MACROS
*COPYC CTC$DFT_DIRECT_CELLS

          LIST   X
*COPYC CTI$CONSOLE_PACKET_DEFINITIONS
*COPYC CTI$DFT_ANALYSIS_CODES
*COPY DSC$PP_MR_AND_TPM_CONSTANTS
*COPY CTC$DFT_CONSTANTS
*COPY CTC$DFT_ACTION_NO_OVERFLOW
*COPY DSA$HARDWARE_TABLE_DEFINITIONS
*COPY DSA$VE_REQUESTS_TO_DFT
          LIST   *
*COPY DSI$PP_INSTRUCTION_MNEMONICS
          LIST   X
*COPY CTC$EI_CONTROL_BLOCK
          LIST   *
 MAIN     SPACE  4,10
**        START DEFINITION OF THE MAIN LOOP OF DFT.
*
*         S0/S0E WILL REQUIRE PACKET CODE, EICB UPDATE, AND
*         RELOCATION ROUTINES.

*COPYC CTP$DFT_MAIN_LOOP
*COPYC CTP$DFT_MAIN_LOOP_930
*COPYC CTP$DFT_MAIN_LOOP_PACKETS
*COPYC CTP$DFT_MAIN_LOOP_UPDATE_TIME

**        END OF DFT MAIN LOOP DEFINITIONS.

*COPYC CTC$DFT_GLOBAL_DATA
 TOUB     CON    TOBPS0      *2AP* OUTPUT BUFFER ADJUSTED FOR LINKAGE BYTES
 TINB     CON    TOIPS0      *2AP* INPUT BUFFER
 MPSR     CON    S0PMPS      *MPS* REGISTER NUMBER
 JPSR     CON    S0PJPS      *JPS* REGISTER NUMBER
 CSAR     CON    S0PCSA      *CSA* REGISTER NUMBER

*         MISCELLANEOUS S0/S0E-SPECIFIC GLOBAL LOCATIONS.

 CLST2    CON    0           FLAG DENOTING TWO IOU CLUSTERS  (1 = PRESENT)
 PMEI     CON    0           PAGE MAP ELEMENT INDEX
 S0EFLG   CON    0           SET NONZERO IF S0E MAINFRAME

*         GLOBAL LOCATIONS USED BY *AME* OVERLAY TO ANALYZE MEMORY ERRORS.

 BDER     CON    0           BOARD ERROR FOUND
 BKER     CON    0           BANK ERROR FOUND FLAG
 BKNO     CON    0           BANK NUMBER WITH AN ERROR
 BNKI     CON    0           BANK INDEX
 BRDI     CON    0           BOARD INDEX
 DEGR     CON    0           MEMORY DEGRADATION OFFSET (0 = NO DEGRADE)
 MEER     CON    0           FLAG INDICATING ANY MEMORY ERROR FOUND
 NBNK     CON    4           NUMBER OF BANKS (DEFAULT = 4)
 NBRDS    CON    0           NUMBER OF MEMORY BOARDS INSTALLED
 SBNK     CON    0           STARTING BANK TO SEARCH FROM (DEFAULT = 0)

*         GLOBAL LOCATIONS USED BY *APE* OVERLAY TO ANALYZE PROCESSOR ERRORS.

 CSA0     CON    0           SLOT 0 CONTROL STORE ADDRESS
 CSA1     CON    0           SLOT 1 CONTROL STORE ADDRESS
 CSA2     CON    0           SLOT 2 CONTROL STORE ADDRESS
 DUETRAP  CON    0           *DUE* TRAP FLAG
 PUEL     BSS    2*4         CPU REGISTER 0#880/0#881 CONTENTS
 PFCL     BSS    2*4         CPU REGISTER 0#890/0#891 CONTENTS
 RETRYC   CON    0           RETRY COUNTER
 RETRYL   CON    0           RETRY LIMIT

*         GLOBAL LOCATIONS USED BY FAULT SYMPTOM CODE GENERATION ROUTINES.

 BITN     BSS    1           MOST SIGNIFICANT ERROR BIT FOUND IN *REGN*
 BUS0     BSS    1           NONZERO IF BIT 39 SET IN REGISTER 90 - 94
 BUS2     BSS    1           NONZERO IF BIT 39 SET IN REGISTER A0 - A4
 REGC     BSS    1           NUMBER OF REGISTERS WITH MEANINGFUL ERROR BITS
 REGN     BSS    1           FIRST REGISTER WITH MEANINGFUL ERROR BIT
*COPYC CTP$DFT_RESIDENT_COMMON
 ECM      SPACE  4,10
**        ECM - EXECUTE CIP MODULE.
*
*         ENTRY  (L2AP) = 1, IF *2AP* LOAD REQUIRED.
*                       = 0, IF *2AP* ALREADY LOADED.
*
*         EXIT   RETURNS TO LOCATION *RCMRTN*.
*
*         USES   EI, T1, CM - CM+3, W0 - W3, *CALB*, *RDATA*.
*
*         CALLS  IIB, LOV, LSR, SPB, *TOEP*.
*
*         MACROS FINDCM, READMR, WRITMR.
*
*         NOTE   *2AP* REQUIRES THE OS BOUNDS REGISTER AND THE MEMORY
*         BOUNDS REGISTER TO BE SET UP PRIOR TO *2AP* UPDATING ITSELF
*         IN MEMORY.  MEMORY BOUNDS WILL BE DISABLED AND DFT IN OS BOUNDS
*         IS SET TO UPPER PP.



 ECM      SUBR               ENTRY/EXIT
          RJM    TIM         UPDATE TIMING OF EVENTS

*         FOR S0/S0E MAINFRAMES, *2AP* NEEDS TO BE LOADED ONLY ON FIRST CALL
*         OR AFTER AN MRT UPDATE HAS OCCURRED.

          LDM    L2AP        CHECK IF *2AP* LOAD REQUIRED
          ZJN    ECM0.2      IF NO LOAD REQUIRED
          LDN    0
          STM    L2AP
          FINDCM 2AP         FIND CIP MODULE
          CRDL   W0
          STDL   T1
          SODL   W3          DELETE HEADER WORD
          LDDL   T1
          ADC    RR+1
          CRML   TOAPS0,W3   LOAD *2AP*
 ECM0.2   LDM    UMEM        UPDATE *2AP* IN MEMORY FLAG
          ZJN    ECM1        IF NO UPDATE

*         SET OS BOUNDS AND DISABLE MEMORY BOUNDS, IF NECESSARY, BEFORE
*         CALLING *2AP* SINCE IT WILL OVERLAY THE SECONDARY ROUTINES OVERLAY.

          LDN    DSCM+2
          RJM    IIB
          CRDL   CM          GET CIP POINTER
          LRD    CM+1
          RJM    SPB         SET PP BOUNDS
          RJM    DBC         DISABLE MEMORY BOUNDS CHECKING
 ECM1     LDC    CALB        LOAD CALL BLOCK ADDRESS
          RJM    TOEPS0      CALL *2AP* TO PROCESS FUNCTION
          LDN    0
          STD    EI

*         CALL *2AP* TO UPDATE CIP IMAGE IF NECESSARY.

          LDM    UMEM        UPDATE *2AP* IN MEMORY FLAG
          ZJN    ECM4        IF NO UPDATE
          LDN    27          FUNCTION TO UPDATE *2AP* IN CENTRAL MEMORY
          STM    CALB
          LDC    CALB
          RJM    TOEPS0      RE-CALL *2AP* TO PROCESS FUNCTION
          LDN    0
          STD    EI

*         REENABLE MEMORY BOUNDS CHECKING IF DISABLED FOR *2AP* CALL.

 ECM4     LDM    UMEM        CHECK NEED TO REENABLE MEMORY BOUNDS
          ZJN    ECM6        IF MEMORY BOUNDS WERE NOT DISABLED
          RJM    EBC         ENABLE BOUNDS CHECKING
 ECM6     RJM    TIM         UPDATE TIMING OF EVENTS
          LJM    ECMX        RETURN
 COMMON   SPACE  4,10
**        COMMON DECKS.


*COPY DSI$FIND_CIP_MODULE
*COPY DSI$GET_HARDWARE_ELEMENT
*COPYC CTP$MR_PROTOCOL_PREPROCESS
*COPYC CTP$MR_RETRY_OPERATION_FOR_DFT
*COPYC CTP$MR_PROTOCOL_PROCESS
*COPYC CTP$MR_PROTOCOL_POSTPROCESS_930
*COPY DSI$PP_UTILITY_SUBROUTINES
          TITLE  S0/S0E-SPECIFIC PRESET.
          USE    PRESET
          QUAL   PRESET
*COPYC CTP$DFT_PRESET
*COPYC CTP$DFT_PRESET_NON_DUAL_I4
 SPO      SPACE  4,10
**        SPO - SETUP MEMORY PORT OFFSET.
*
*         NOTE   THIS ROUTINE PERFORMS NO OPERATION ON A 930 SYSTEM.


 SPO      SUBR               ENTRY/EXIT
          UJN    SPOX        RETURN
*COPY CTP$DFT_RETURN_ERROR_CODE
          USE    *
          QUAL   *

          OVERFLOW  10000    CHECK FOR OVERFLOW
          OVERLAY  (RESIDENT PART II),10000
          QUAL   *


*         CAUTION - CAUTION - CAUTION - CAUTION
*
*         DUE TO THE WAY THE CALL MECHANISM WORKS IT CAN ONLY SUPPORT A 12 BIT
*         ADDRESS ON A CALL. DO NOT PUT ANY *ROUTINES* IN THE RESIDENT II AREA WHICH
*         ON THE S0 STARTS AT 10000.
*
*         CAUTION - CAUTION - CAUTION - CAUTION




 CMP      SPACE  4,10
**        CMP - CHECK MEMORY PORT.
*
*         ENTRY  (RDATA) = MEMORY *EC* REGISTER.
*                (HBUF) = PROCESSOR INFORMATION.
*
*         EXIT   (A) = 0, IF CPU MEMORY PORT ENABLED.
*                    > 0, IF CPU MEMORY PORT DISABLED.


 CMP      SUBR               ENTRY/EXIT
          LDM    S0EFLG      CHECK CPU TYPE
          NJN    CMP11       IF S0E

*         CHECK S0 PROCESSOR ENABLE/DISABLE STATUS.

          LDM    RDATA       CHECK MEMORY PORT 2/3 DISABLE STATUS
          LPN    0#18
          UJN    CMPX        RETURN

*         CHECK S0E PROCESSOR ENABLE/DISABLE STATUS.

 CMP11    LDM    HBUF+CPRPC  DETERMINE CPU NUMBER
          LPN    1
          STD    T1
          READMR RDATA,S0PMC,S0PPMC  READ PAGE MAP CONTROL REGISTER
          LDM    RDATA+1     CHECK BIT 8 OR 9 DEPENDING ON CPU NUMBER
          LPML   CMPA,T1
          UJN    CMPX        RETURN

 CMPA     CON    0#80,0#40   SET CPU PORT DISABLE BIT MASK
 DBC      SPACE  4,10
**        DBC - DISABLE BOUNDS CHECKING.
*
*         ENTRY  MEMORY BOUNDS ENABLED ON CERTAIN PORTS.
*
*         EXIT   MEMORY BOUNDS CHECKING DISABLED ON ALL PORTS.
*                (MBPS) = SAVED PORT SELECT VALUE.
*
*         MACROS LOCKMR, READMR, WRITMR.


 DBC      SUBR               ENTRY/EXIT
          LOCKMR SET         ACQUIRE INTERLOCK
          LDN    S0MBD       INITIALIZE REGISTER LOOP
          STD    RN
 DBC1     READMR RDATA,CMCC  READ NEXT REGISTER
          LDM    RDATA+2
          LPN    1
          SHN    5
          STM    MBPS        SAVE BIT 23
          LDM    RDATA+2
          SCN    1           CLEAR BIT 23
          STM    RDATA+2
          LDM    RDATA+3
          SHN    -3
          LMM    MBPS        ADD BITS 24 - 28 TO SAVED SELECT BITS
          STM    MBPS
          LDM    RDATA+3
          LPN    7           CLEAR BITS 24 - 28
          STM    RDATA+3
          WRITMR RDATA,CMCC  REWRITE REGISTER
          AOD    RN          ADVANCE TO NEXT REGISTER
          LMC    S0MBD+0#10
          NJP    DBC1        IF MORE BOUNDS REGISTERS TO PROCESS
          LOCKMR CLEAR       RELEASE INTERLOCK
          LJM    DBCX        RETURN
 EBC      SPACE  4,10
**        EBC - ENABLE BOUNDS CHECKING.
*
*         ENTRY  MEMORY BOUNDS DISABLED.
*                (MBPS) = SAVED PORT SELECT.
*
*         EXIT   MEMORY BOUNDS RESTORED TO PREVIOUS VALUE.
*
*         MACROS LOCKMR, READMR, WRITMR.


 EBC      SUBR               ENTRY/EXIT
          LOCKMR SET         ACQUIRE INTERLOCK
          LDN    S0MBD       INITIALIZE REGISTER LOOP
          STD    RN

*         NOTE - CODE ASSUMES THAT PORT SELECT IS IDENTICAL FOR ALL.

 EBC1     READMR RDATA,CMCC  READ NEXT REGISTER
          LDM    RDATA+2
          SCN    1
          LDM    MBPS        GET PORT ENABLE BITS
          SHN    -5
          LMM    RDATA+2     RESTORE BIT 23
          STM    RDATA+2
          LDM    RDATA+3
          LPN    7           ENSURE CLEAR
          STM    RDATA+3
          LDM    MBPS        GET ENABLE BITS
          LPN    0#1F        JUST 24 - 28
          SHN    3           POSITION
          LMM    RDATA+3     RESTORE BITS
          STM    RDATA+3
          WRITMR RDATA,CMCC
          AOD    RN          ADVANCE TO NEXT REGISTER
          LMC    S0MBD+0#10
          NJP    EBC1        IF MORE BOUNDS REGISTERS TO PROCESS
          LOCKMR CLEAR       RELEASE INTERLOCK
          LJM    EBCX        RETURN
 HTO      SPACE  4,10
**        HTO - HARDWARE TIMEOUT.
*
*         *HTO* IS CALLED EVERY 100 MSEC.
*
*         EXIT   (TFLG) = 1.


 HTO      SUBR               ENTRY/EXIT
          LDN    1           INDICATE 100 MSEC ELAPSED
          STM    TFLG
          UJN    HTOX        RETURN
 PII      SPACE  4,10
**        PII - PRESET IOU INFORMATION.
*
*         THIS IS A DUMMY ROUTINE ON S0/S0E.


 PII      SUBR               ENTRY/EXIT
          UJN    PIIX        RETURN
 SPB      SPACE  4,10
**        SPB - SET PP BOUNDS.
*
*         THIS IS A DUMMY ROUTINE ON S0/S0E.


 SPB      SUBR               ENTRY/EXIT
          UJN    SPBX        RETURN
 TIM      SPACE  4,10
**        TIM - MAINTAIN MILLISECOND TIME AND EXECUTE TIMED ROUTINES.
*
*         *TIM* USES THE CHANNEL 14 CLOCK TO ALLOW THE EXECUTION OF
*         CERTAIN ROUTINES ON A TIMED BASIS.  THE ROUTINES TO BE
*         ACTIVATED PERIODICALLY ARE IN *ACTB*.  TO ENSURE ACCURACY,
*         *TIM* SHOULD BE CALLED AT LEAST EVERY TWO MILLISECONDS.
*         FOR ACCURACY, THE 16 BIT WIDE CHANNEL 14 CLOCK IS PROCESSED IN ITS
*         ENTIRETY, RATHER THAN TRUNCATING IT TO 12 BITS FOR COMPATIBILITY.
*
*         EXIT   (TIMA) IS WITHIN ONE MILLISECOND OF CHANNEL 14 VALUE.
*
*         USES   T1, T7.
*
*         CALLS  SEE *ACTB*.
*
*         NOTE   CHANGES TO THIS ROUTINE SHOULD BE MADE IN *SCI* ALSO.


 TIM      SUBR               ENTRY/EXIT
 TIM1     IAN    14          READ MICROSECOND COUNTER
          SBML   TIMA
          PJN    TIM2        IF NO OVERFLOW
          ADC    200000
 TIM2     ADC    -1000D
          MJN    TIMX        IF LESS THAN ONE MILLISECOND ELAPSED
          LDC    1000D       ADVANCE BASE TIME BY ONE MILLISECOND
          RAML   TIMA
          AOM    TIMB        ADVANCE SCAN COUNTER
          LMN    5
          NJN    TIM1        IF SCAN PERIOD NOT UP
          STM    TIMB        RESET SCAN COUNTER
          LDC    ACTB        PRESET ACTION ENTRY
          STD    T7
          STM    TIMF
 TIM3     AOM    2,T7        ADVANCE ENTRY COUNTER
          SBM    1,T7
          MJN    TIM4        IF DELAY NOT COMPLETE
          LDN    0
          STM    2,T7        RESET COUNTER
          LDIL   T7          CALL SPECIFIED ROUTINE
          STDL   T1
          RJM    0,T1
 TIM4     LDN    3           ADVANCE TABLE INDEX
          RAM    TIMF
          STD    T7
          LMC    ACTBL
          NJN    TIM3        IF MORE ENTRIES TO CHECK
          LJM    TIM1        RETURN

 TIMF     BSS    1           FWA OF ENTRY BEING PROCESSED
*COPYC CTP$DFT_RESIDENT_II_COMMON
 COMMON   SPACE  4,10
**        COMMON DECKS.


*COPYC DSI$PACK_UNPACK_REGISTERS

          USE    OVERFLOW
          ERRNG  20000-*     RESIDENT II OVERFLOWS PP MEMORY
*COPYC CTP$DFT_PRESET_BUILD_STRUCTURE
          OVERLAY (STANDARD PRESET OVERLAY ROUTINES)
*COPYC CTP$DFT_PRESET_STANDARD_OVL
 SSO      SPACE  4,10
**        SSO - PRESET  SPECIAL OVERLAY FOR IOU BIT 57 ERROR.
*         NON OPERATIONAL HERE.


 SSO      SUBR
          UJN    SSOX        RETURN

 GMI      SPACE  4,10
**        GMI - GET MEMORY INSTALLED.
*
*         EXIT   (NBRDS) = NUMBER OF BOARDS PRESENT.
*
*         USES   T0, T1.


 GMI      SUBR               ENTRY/EXIT
          READMR RDATA,I0CC,OIMR  CHECK BOARD CONFIGURATION IN IOU *OI*
          LDML   RDATA+2     CHECK *OI* BIT 16
          STDL   T0
          SHN    -7
          STD    T1
          LDDL   T0          CHECK *OI* BIT 17
          SHN    -6
          LPN    1
          RAD    T1
          LDDL   T0          CHECK *OI* BIT 18
          SHN    -5
          LPN    1
          RAD    T1
          LDDL   T0          CHECK *OI* BIT 19
          SHN    -4
          LPN    1
          ADD    T1
          STM    NBRDS       STORE RESULT

*         NEXT FIND OUT IF MEMORY HAS BEEN DEGRADED. IF IT HAS WHICH
*         SET OF BANKS HAS BEEN DEGRADED. POSSIBILITIES ARE (0,1) (2,3).
*         THE HARDWARE ASSUMES DEGRADED BANKS AS (0,1).

          READMR RDATA,CMCC,ECMR  MEMORY *DEC* REGISTER
          LDM    RDATA
          LPN    6           GET JUST RECONFIGURATION BITS 5-6
          ZJP    GMIX        IF NO RECONFIGURATION
          STD    T1          SAVE RECONFIGURATION BITS
          LDN    2
          STM    NBNK        NUMBER OF BANKS TO SEARCH GOES TO 2 IF RECONFIG
          LDD    T1
          LPN    2
          NJP    GMIX        IF LOWER TWO BANKS
          LDN    2
          STM    SBNK        IF USE UPPER TWO BANKS
          STM    DEGR        SET UP OFFSET W/MEMORY DEGRADED (BANKS 2,3 ARE 0,1)
          LDN    4
          STM    NBNK        FOR UPPER TWO BANKS (2,3)
          LJM    GMIX        RETURN
*COPY CTP$DFT_RETURN_ERROR_CODE
 SMV      SPACE  4,10
**        SMV - SET UP MODEL DEPENDENT VALUES.
*
*         *SMV* WILL SET UP REGISTER LIST ADDRESSES ON A MODEL DEPENDENT BASIS, AND
*         AND WILL INITIALIZE ALL MODEL DEPENDENT GLOBAL DATA.
*
*         EXIT   (CLST2) = 1 IF BOTH CLUSTERS 0 AND 2 PRESENT.
*                (PMEI) = PAGE MAP ELEMENT INDEX.
*                (S0FLG) = 1.
*                (S0EFLG) = 1 IF MAINFRAME IS S0E (MODEL 54/55).
*                (S0PMC) = PAGE MAP CONNECT CODE.
*                PROCESSOR REGISTER NUMBERS INITIALIZED.
*                REGISTER LISTS SET UP.
*                *2AP* VALUES INITIALIZED.


 SMV      SUBR               ENTRY/EXIT

*         SET UP IOU REGISTER LISTS.

          READMR RDATA,I0CC,OIMR  READ OPTIONS INSTALLED
          LDM    RDATA       CHECK *OI* BIT 1 FOR CLUSTER 2 PRESENT
          LPC    0#40
          NJN    SMV1        IF CLUSTERS 0 AND 2 ARE PRESENT
          LDC    RLUIE0      UNCORRECTED REGISTER LIST FOR CLUSTER 0
          STM    IO0U
          LDC    RLCIE0      CORRECTED REGISTER LIST FOR CLUSTER 0
          STM    IO0C
          UJN    SMV2        SET UP MEMORY LISTS

 SMV1     LDC    RLUIE2      UNCORRECTED REGISTER LIST FOR CLUSTERS 0/2
          STM    IO0U
          LDC    RLCIE2      CORRECTED REGISTER LIST FOR CLUSTERS 0/2
          STM    IO0C
          LDN    1           SET FLAG FOR TWO CLUSTERS
          STM    CLST2

*         SET UP MEMORY REGISTER LISTS.

 SMV2     LDC    RLUME       SET UNCORRECTED MEMORY ERROR LIST
          STM    ME0U
          LDC    RLCME       SET CORRECTED MEMORY ERROR LIST
          STM    ME0C
          LDN    1           SET S0/S0E FLAG TRUE
          STM    S0FLG
          RJM    GMI         DETERMINE MEMORY BOARD CONFIGURATION

*         SET UP PAGE MAP INFORMATION.

          LDN    PMID        READ PAGE MAP MRT
          RJM    FHE
          MJP    SMV5        IF NOT FOUND
          STM    PMEI        SAVE PAGE MAP ELEMENT INDEX
          LDM    HBUF+HDRPC  GET PAGE MAP CONNECT CODE
          STM    S0PMC

*         DETERMINE PROCESSOR TYPE (S0 OR S0E).

          AOM    S0FLG       SET S0/S0E FLAG
          LDN    0           SET PORT OFFSET
          STD    PO
          LDM    CPU0M       CHECK CPU MODEL
          LPN    0#F
          STD    T1
          LDM    SMVA,T1     GET S0/S0E FLAG
          NJN    SMV2.5      IF CPU MODEL DEFINED
          SETDAN (EPUN,DAMD)
          LDC    DAMD+TDFT   608 - INCOMPATABLE HARDWARE MODEL
          CALL   ERRH

 SMV2.5   SBN    1
          NJN    SMV3        IF S0E

*         SET UP S0 PROCESSOR REGISTER LISTS.

          LDC    RLUPE       SET UNCORRECTED PROCESSOR ERROR LIST
          STM    CP0U
          STM    CP1U
          LDC    RLCPE       SET CORRECTED PROCESSOR ERROR LIST
          STM    CP0C
          STM    CP1C
          UJN    SMV4        CONTINUE

*         SET UP S0E PROCESSOR REGISTER LISTS.

 SMV3     LDC    /S0E/RLUPE  SET S0E UNCORRECTED PROCESSOR ERROR LIST
          STM    CP0U
          STM    CP1U
          LDC    /S0E/RLCPE  SET S0E CORRECTED PROCESSOR ERROR LIST
          STM    CP0C
          STM    CP1C
          AOM    S0EFLG      SET S0E FLAG
 SMV4     LJM    SMVX        RETURN

*         PROCESS DESCRIPTOR NOT FOUND IN MRT.

 SMV5     SETDAN (EPUN,DAME)
          LDC    DAME+TDFT   613 - DFT NO DESC IN MRT
          STML   RTP1
          CALL   ERRH

 SMVA     CON    1           CPU MODEL 50 IS AN S0
          CON    1           CPU MODEL 51 IS AN S0
          CON    1           CPU MODEL 52 IS AN S0
          CON    1           CPU MODEL 53 IS AN S0
          CON    2           CPU MODEL 54 IS AN S0E
          CON    2           CPU MODEL 55 IS AN S0E
          CON    0           CPU MODEL 56 IS RESERVED
          CON    0           CPU MODEL 57 IS RESERVED
          CON    0           CPU MODEL 58 IS RESERVED
          CON    0           CPU MODEL 59 IS RESERVED
          CON    0           CPU MODEL 5A IS RESERVED
          CON    1           CPU MODEL 5B IS AN S0
          CON    2           CPU MODEL 5C IS AN S0E
          CON    1           CPU MODEL 5D IS AN S0
          CON    1           CPU MODEL 5E IS AN S0
          CON    2           CPU MODEL 5F IS AN S0E

*COPYC CTP$DFT_PRESET_PACKETS
*COPY     CTP$DFT_NO_CLEAR_PACKETS
          OVERLAY  (MAIN NON-RESIDENT ROUTINES)
 NONRES   SPACE  4,10
**        START OF THE MAIN NON RESIDENT ROUTINES OVERLAY.
*
*         ON S0/S0E, THIS OVERLAY DEFINES ROUTINES FOR PACKETS, NON I4,
*         HALT ON ERROR PROCESSING, EICB TIME UPDATE, AND PACKET COMMUNICATION.
*COPYC CTP$DFT_MAIN_NON_RES_RTNS
*COPYC CTP$DFT_MAIN_NON_RES_NON_I4
*COPYC CTP$DFT_MAIN_NON_RES_EICB_TIME
*COPYC CTP$DFT_CHECK_PACKET_STATUS
*COPY CTP$DFT_CHECK_PKT_ERROR_STATUS
*COPY CTP$DFT_CHECK_PKTS_FOR_S0
*COPY CTP$DFT_LOG_PACKET_TIMEOUT
*COPYC CTP$DFT_PP_REQUESTS_RELOCATION
 BCA      SPACE  4,10
**        BCA - HANDLE BLOCKED CM ACCESS.
*         THIS IS VALID ON A MODEL 44, 43 IOU ONLY. (STUB HERE)
          QUAL   HB57


 BCA      SUBR
          UJN    BCAX        RETURN
          QUAL   *
 RSP      SPACE  4,10
**        RSP - RESTART SCI PP.
*
          ROUTINE RSP
          RJM    LRP
          CRDL   W0          GET PARAMETERS
          LDDL   W2          GET PP NUMBER
          SHN    -10
          STD    W0          SET UP FOR *RJM* TO *RSC*
          RJM    RSC         RELOCATE SCI TO SAME PP
          LJM    RSPX        RETURN

*COPY CTP$DFT_PREPARE_FOR_CIP_CALL
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_CPU_HANDSHAKER

 HOE      SPACE  4,10
**        HOE - HALT ON ERROR.
*
*         EXIT   HALT-ON-ERROR SET IN PROCESSOR *DEC* REGISTER.
*
*         CALLS  SHE.
*
*         MACROS LOCKMR.


          ROUTINE  HOE

          LOCKMR SET         ACQUIRE INTERLOCK
          LDN    PROCID      READ MRT ENTRY FOR CPU-0
          RJM    SHE         SET HALT-ON-ERROR
          LDC    PROCID1     READ MRT ENTRY FOR CPU-1
          RJM    SHE         SET HALT-ON-ERROR
          LOCKMR CLEAR       RELEASE INTERLOCK
          LJM    HOEX        RETURN
 SHE      SPACE  4,10
**        SHE - SET HALT-ON-ERROR.
*
*         ENTRY  (A) = HARDWARE ELEMENT TO PROCESS.
*
*         EXIT   HALT-ON-ERROR SET IN CPU *DEC* REGISTER.
*
*         CALLS  FHE.
*
*         MACROS READMR, WRITMR.


 SHE      SUBR               ENTRY/EXIT
          RJM    FHE         READ MRT ENTRY
          MJN    SHEX        IF ELEMENT NOT FOUND
          LDM    HBUF+CPRSTAT+PSCPOFF  CHECK CPU STATUS
          LPN    1
          NJN    SHEX        IF CPU DOWN
          LDM    S0EFLG      CHECK MAINFRAME TYPE
          NJN    SHE1        IF S0E

*         SET HALT-ON-ERROR FOR S0 CPU.

          READMR RDATA,HBUF+CPRPC,S0PCSD  READ CPU *DEC* REGISTER
          LDM    RDATA+4
          SCN    0#20
          LMN    0#20
          STM    RDATA+4
          UJN    SHE2        CONTINUE

*         SET HALT-ON-ERROR FOR S0E CPU.

 SHE1     READMR RDATA,HBUF+CPRPC,SEPCSC  READ CONTROL STORE CONTROL REGISTER
          LDM    RDATA+1
          SCN    0#20
          LMN    0#20
          STM    RDATA+1

*         COMMON EXIT.

 SHE2     WRITMR RDATA,HBUF+CPRPC REWRITE *DEC* REGISTER
          LJM    SHEX        RETURN


 RED      SPACE  4,10
**        RED - READ 960 POWER MONITOR.
*
*         ON ANY MACHINE OTHER THAN THE 960 THIS ROUTINE IS
*         NON FUNCTIONAL.


          ROUTINE RED
          LJM    REDX

          OVERFLOW  10000    CHECK FOR OVERFLOW
          OVERLAY  (DO DFT ACTIONS)
*COPYC CTP$DFT_ACTION_LIST
*COPYC CTP$DFT_ACTION_LIST_OVERFLOW

 S1PG     BSS    0           START 170 PROCESSOR
          TASK   (RRE)       RETURN REQUEST ERROR - NOT USED ON S0/S0E

 H1PG     BSS    0           HALT 170 PROCESSOR
          TASK   (RRE)       RETURN REQUEST ERROR - NOT USED ON S0/S0E

 HVPG     BSS    0           TERMINATE ALL VIRTUAL PROCESSORS
          TASK   (PCP)

 DCEMP    BSS    0           CLEAR PAGE MAP AND PROCESSOR ERRORS
          TASK   (CPE,CLE,SPR)

 IAPP     BSS    0           IDLE ALL PP-S IN IOU-1
          TASK   (RRE)       RETURN REQUEST ERROR - NOT USED ON S0/S0E

 DDCE     BSS    0           CLEAR ERROR ON S0/S0E
          TASK   (CLE,SPR)   CLEAR ERROR AND START CPU
          QUAL   *
*COPYC CTP$DFT_RETURN_TASK_ERROR
          QUAL   ABC
*COPY CTP$DFT_RETURN_ERROR_CODE
          QUAL   *

          QUAL   *

          OVERFLOW  10000    CHECK FOR OVERFLOW
          OVERLAY (SAVE PP REGISTERS IN CENTRAL MEMORY)
*COPYC CTP$DFT_SAVE_PP_REGISTERS
*COPY  CTP$DFT_930_DUMP_PP_REGS
          OVERFLOW 10000     CHECK FOR OVERFLOW
          OVERLAY  (DFT ERROR CONTROL OVERLAY)
*COPYC CTP$DFT_ERROR_CONTROL

          OVERFLOW  10000    CHECK FOR OVERFLOW
          OVERLAY  (LOG TOP OF HOUR COUNTERS)
*COPYC CTP$DFT_LOG_COUNTERS
 RMC      SPACE  4,10
**        RMC - RESET MODEL DEPENDENT COUNTERS.
*
*         THIS IS A DUMMY ROUTINE ON S0/S0E.


          ROUTINE RMC        ENTRY/EXIT
          LJM    RMCX        RETURN

 RMCF     CON    0
*COPY     CTP$DFT_NO_RESET_PIT
*COPY     CTP$DFT_NO_TEST_DLD_PATH

          OVERFLOW  10000    OVERFLOW
          OVERLAY  (ENVIRONMENT/SHORT WARNING PROCESSORS)
*COPYC CTP$DFT_ENVIRONMENT_RTNS
*COPY  CTP$DFT_FIND_WARNING_IN_NRSB
 CCA      SPACE  4,10
**        CCA - CHECK IF CONSOLE IS ALIVE.
*
*         EXIT   A = 0, IF CONSOLE HAS NO POWER.
*                A > 0, IF CONSOLE HAS POWER.
*
*         USES   SCF.


 CCA      SUBR               ENTRY/EXIT
          LDN    MX          MUX CHANNEL
          RJM    SCF         SET CHANNEL FLAG
          DCN    MX+40       DEACTIVATE TPM CHANNEL
          LDN    MXSS        MUX STATUS
          FAN    MX
          LCN    0
 CCA3     SBN    1
          ZJN    CCA4        IF TIMED OUT, REPORT CONSOLE NOT ALIVE
          AJM    CCA3,MX     IF FUNCTION NOT ACCEPTED YET
          ACN    MX          GET TPM STATUS
          IAN    MX
          LPN    6           EXTRACT DATA SET READY, CARRIER ON
 CCA4     DCN    MX+40
          CCF    *,MX        RELEASE CHANNEL INTERLOCK
          LJM    CCAX        RETURN
          QUAL   *

          OVERFLOW  10000    CHECK FOR OVERFLOW
          OVERLAY  (ANALYZE PROCESSOR ERROR)
 APE      SPACE  4,10
**        APE - ANALYZE PROCESSOR ERROR.
*
*         ENTRY  SUMMARY STATUS INDICATES PROCESSOR ERROR.
*                (EC) = CONNECT CODE FOR AFFECTED PROCESSOR.
*                (ET) = *PROCID*.
*                (CPUO) = CPU ORDINAL FOR AFFECTED PROCESSOR.
*                (SUMS) = SUMMARY STATUS.
*
*         EXIT   TO *CCE* IF CORRECTED ERROR.
*                TO *DCE* IF CPU DEAD.
*                TO *PCE* IF DUE ERROR.
*                TO *RFI* TO RETRY FAILING INSTRUCTION.
*                TO *SPR* TO RESTART PROCESSOR.
*                TO *SWP* IF SHORT WARNING INDICATED.
*                TO *UCE* IF UNCORRECTED ERROR.
*
*         CALLS  CLR, CMH, HPR, PCS, REL, *CFF*, *SWP*.
*
*         MACROS READMR.


          ROUTINE  APE

          LDN    0           SET NO ERROR FLAG FALSE
          STM    NERR
          STM    RETRYC      SET RETRY COUNTER = 0 AND *DUETRAP* = FALSE
          STM    DUETRAP

*         SET CPU RETRY LIMIT.
*
*         NOTE - THIS CODE LOGICALLY BELONGS IN *PRS*.  IT IS LOCATED
*         HERE SINCE THE RETRY LIMIT MUST BE CHANGED DURING TESTING,
*         WHICH WOULD REQUIRE REDEADSTARTING IF IT WERE SAVED IN *PRS*.

          LDM    S0EFLG      CHECK MAINFRAME TYPE
          NJN    APE1        IF S0E

*         SET S0 RETRY LIMIT.

          READMR RDATA,CP0CC,S0PPRC  READ PFS/RETRY CONTROL REGISTER
          LDM    RDATA+1     EXTRACT RETRY LIMIT FROM BITS 10-13
          UJN    APE2        CONTINUE

*         SET S0E RETRY LIMIT.

 APE1     READMR RDATA,CP0CC,SEPRPR  READ REGISTER FILE PFS AND RETRY REGISTER
          LDM    RDATA+3     EXTRACT RETRY LIMIT FROM BITS 26-29

*         RESUME COMMON PROCESSING.

 APE2     SHN    -2
          LPN    17
          ADN    1           SAVE LIMIT + 1
          STM    RETRYL

*         IT IS NECESSARY TO SAVE THE PRE-HALT SUMMARY STATUS BECAUSE
*         HALTING THE PROCESSOR WILL SET THIS BIT.  ROUTINE *RMR* USES
*         THE *OLSS* VALUE WHEN BUILDING THE SCRATCH MRB.

          LDM    SUMS        SAVE PRE-HALT SUMMARY STATUS FOR *RMR*
          STM    OLSS
          SHN    21-SSSW     CHECK FOR SHORT WARNING
          PJN    APE3        IF NO SHORT WARNING
          CALL   SWP         CALL SHORT WARNING PROCESSOR
          LJM    APEX        RETURN

*         REENTER HERE AFTER CPU IS RESTARTED.

 APE3     LDM    CPUO        SAVE HALTED CPU ORDINAL
          STM    CPUH
          RJM    HPR         HALT PROCESSOR
          LDN    1
          RJM    SCS         SAVE AFTER HALT CSA AND SS REGISTERS FOR SUPPORTIVE STATUS
          RJM    PCS         PACK CONTROL STORE ADDRESSES
          RJM    REL         READ UNCORRECTED AND FIRST/CORRECTED ERROR LOGS
          CALL   CFF         CHECK IF FREEZE ON ERROR WANTED
          LDN    BC          CLEAR SCRATCH BUFFER CONTROL WORD
          RJM    CLR

*         CHECK FOR FATAL ERROR - BITS 46/47 OF REGISTER 0#881 NONZERO.

          LDML   PUEL+1*4+2  CHECK UNCORRECTED ERROR LOG
          LPN    3
          NJP    PCE         IF FATAL CPU ERROR

*         CHECK FOR *DUE* ERRORS.

          LDM    SUMS        CHECK FOR *DUE*
          SHN    21-SSUE
          PJP    APE6        IF *DUE* NOT SET
          LDML   CSA0        CHECK CONTROL STORE ADDRESS
          LMC    0#100
          ZJP    APE5        IF RETRYABLE ERROR (CONTROL STORE ADDRESS = 100)
          LMN    0#105&0#100
          ZJP    APE5        IF RETRYABLE ERROR (CONTROL STORE ADDRESS = 105)
          RJM    CMH         CHECK MICROHALT (CONTROL STORE ADDRESSES 141 - 158)
          NJN    APE4        IF NOT MICROHALT

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CPU DEAD - MICROCODE HALT.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (CONSOLE), LOG (OS).

          SETDAC (DDDC)
          SETDAN (EPUN,DADMH)
          SETFLG (BC.CL,BC.FL)
          LJM    DCE         PROCESS DEAD CPU

 APE4     LDM    DUETRAP     CHECK *DUETRAP*
          ZJP    PCE         IF DUETRAP NOT SET, PROCESS FATAL CPU ERROR
          LJM    UCE         PROCESS UNCORRECTED CPU ERROR

*         SET UP TO RETRY INSTRUCTION.

 APE5     LDN    1           SET DUETRAP AND RETRY
          STM    DUETRAP
          LJM    SPR         START PROCESSOR

*         CHECK FOR CORRECTED ERROR.

 APE6     LDML   CSA0        CHECK CONTROL STORE ADDRESS
          LMC    0#105
          ZJP    RFI         IF MICROCODE READY FOR RETRY
          RJM    CMH         CHECK MICROHALT (CONTROL STORE ADDRESSES 141 - 158)
          NJP    APE8        IF NOT MICROHALT
          LDML   CSA2        CHECK FOR MCR/UCR HALT
          LMC    0#151
          ZJN    APE7        IF CLASS II HALT

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CPU DEAD - UNEXPECTED MICROHALT ADDRESS.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (CONSOLE), LOG (OS).

          SETDAC (DDDC)
          SETDAN (EPUN,DADUA)
          SETFLG (BC.CL,BC.FL)
          LJM    DCE         PROCESS DEAD CPU

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CLASS II HALT.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (CONSOLE), LOG (OS).

 APE7     SETDAC (DDDC)
          SETDAN (EPUN,DASWH)
          SETFLG (BC.CL,BC.FL)
          LJM    DCE         PROCESS DEAD CPU

 APE8     LDM    SUMS        CHECK FOR CORRECTED ERROR
          SHN    21-SSCE
          MJP    CCE         PROCESS CORRECTED CPU ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CPU DEAD - NO ERROR DETECTED.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (CONSOLE), LOG (OS).

          SETDAC (DDDC)
          SETDAN (EPUN,DADNE)
          SETFLG (BC.CL,BC.FL)
          LJM    DCE         PROCESS DEAD CPU
 CCE      SPACE  4,10
**        CCE - PROCESS CORRECTED CPU ERROR.
*
*         DFT ANALYSIS - ANALYSIS = CORRECTED PROCESSOR ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).


 CCE      BSS    0           ENTRY
          LDM    PFCL+1*4+1  CHECK BIT 23 OF REGISTER #891
          LPC    0#100
          ZJN    CCE1        IF NO PAGE MAP ERROR RESPONSE
          LDN    SSMR        CHECK FOR PAGE MAP ERROR IN MEMORY SUMMARY STATUS
          STD    RN
          LDM    CMCC        READ MEMORY SUMMARY STATUS
          RJM    RMR
          SHN    21-SSPM
          MJP    CME         IF CORRECTED PAGE MAP ERROR
          LDM    HBUF+CPRPC  RESTORE PROCESSOR CONNECT CODE
          STD    EC
 CCE1     SETDAC (DDCE)
          SETDAN (EPCO,DACPE)
          SETFLG (BC.FL)
          RJM    SCL         SET CORRECTED LIST TO BE LOGGED
          LJM    UML         UPDATE MRB AND LOG ERROR
 CME      SPACE  4,10
**        CME - PROCESS CORRECTED PAGE MAP ERROR.
*
*         DFT ANALYSIS - ANALYSIS = CORRECTED PAGE MAP ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERRORS IN PAGE MAP AND CPU.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).


 CME      BSS    0           ENTRY
          RJM    SML         SET PAGE MAP REGISTER LIST
          SETDAC (DCEMP)
          SETDAN (EPCO,DACPM)
          SETFLG (BC.FL)
          CALL   RMR         READ MAINTENANCE REGISTERS
          LJM    UML1        UPDATE MRB AND LOG ERROR
 DCE      SPACE  4,10
**        DCE - PROCESS DEAD CPU ERROR.
*
*         CALLS  SUL.


 DCE      BSS    0           ENTRY
          RJM    SUL         SET UNCORRECTED LIST TO BE LOGGED
          LJM    UML         UPDATE MRB AND LOG ERROR
 PCE      SPACE  4,10
**        PCE - PROCESS CPU ERROR.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED PROCESSOR ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERRORS.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (CONSOLE), LOG (OS).


 PCE      BSS    0           ENTRY
          SETDAC (DDCE)
          SETDAN (EPUN,DAUPE)
          SETFLG (BC.CL,BC.FL)
          RJM    CCU         CHECK FOR CONTROL STORE UNCORRECTED ERROR
 PCE0     NJP    RCM         IF CONTROL STORE RELOAD NECESSARY

*         READ AND SAVE EXCHANGE PACKAGE ADDRESS, SINCE IT WILL NOT BE
*         POSSIBLE TO READ *JPS*/*MPS* AFTER THE HALF-EXCHANGE OUT.

 PCE0.1   LDC    0#1A4       RESTART CPU TO ALLOW *MPS* AND *JPS* ACCESS
          RJM    SMC         START MICROCODE
          LDM    SUMS        DETERMINE MODE OF CPU
          LPN    0#20
          NJN    PCE1        IF MONITOR MODE
          READMR RDATA,,S0PJPS  READ ADDRESS OF JOB MODE EXCHANGE PACKAGE
          UJN    PCE2        CONTINUE

 PCE1     READMR RDATA,,S0PMPS  READ ADDRESS OF MTR MODE EXCHANGE PACKAGE
 PCE2     RJM    PAC         PACK (RDATA - RDATA+7) INTO (MRVAL)
          CALL   HEO         HALF-EXCHANGE OUT
          LDML   MRVAL       VALIDATE EXCHANGE PACKAGE ADDRESS
          LMC    0#FFFF
          ZJP    PCE4        IF EXCHANGE PACKAGE ADDRESS NOT AVAILABLE
          READMR RDATA,,S0PCSA  REREAD CONTROL STORE ADDRESSES
          LDM    RDATA+6     PACK *S2* ADDRESS
          SHN    10
          ADM    RDATA+7
          LMC    0#142
          NJP    PCE4        IF HALF-EXCHANGE OUT FAILED

*         CHECK *PND* FLAG IN EXCHANGE PACKAGE IN CM, AND IF SET,
*         CLEAR *DUE* IN *MCR* OF EXCHANGE PACKAGE IN CM.

          CALL   SRA         CONVERT (MRVAL) TO R-POINTER IN (W4 - W6)
          LRD    W4
          LDDL   W6          READ WORD 2 OF EXCHANGE PACKAGE IN CM
          ADC    RR+2
          CRDL   CM
          LDDL   CM          CHECK FOR PROCESS NOT DAMAGED STATUS
          LPC    0#1000
          ZJP    PCE4        IF *PND* NOT SET
          LDDL   W6          READ *MCR* WORD OF EXCHANGE PACKAGE
          ADC    RR+6
          CRDL   CM
          LDDL   CM+3        CLEAR *DUE* BIT
          LPC    0#7FFF
          STDL   CM+3
          LDDL   W6          REWRITE *MCR* WORD OF EXCHANGE PACKAGE IN CM
          ADC    RR+6
          CWDL   CM
          LDM    SUMS        CHECK MODE OF CPU
          LPN    0#20
          ZJN    PCE2.1      IF NOT MONITOR MODE
          LDN    0
          UJN    PCE3        CONTINUE

 PCE2.1   LDN    0#1A3-0#1A2
 PCE3     ADC    0#1A2
          RJM    SMC         START MICROCODE
          RJM    SCL         SET CORRECTED REGISTER LIST
          LJM    UML         UPDATE MRB AND LOG ERROR

 PCE4     LDM    SUMS        CHECK FOR MONITOR MODE
          LPN    0#20
          ZJP    PCE3        IF NOT MONITOR MODE

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CPU DEAD - MONITOR MODE DUE.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (CONSOLE), LOG (OS).

          SETDAC (DDDC)
          SETDAN (EPUN,DADMD)
          SETFLG (BC.CL,BC.FL)
          LJM    DCE         PROCESS DEAD CPU
 RCM      SPACE  4,10
**        RCM - RELOAD CONTROL STORE.
*
*         NOTE   THIS REQUIRES *2AP* SUPPORT WHICH IS NOT AVAILABLE TODAY.
*                THEREFORE, IT RETURNS A RELOAD FAILED CONDITION AT THIS TIME.
*                WHEN RELOADS ARE DONE, A NORMAL EXIT IS TO PCE0.1.

 RCM      BSS    0           ENTRY

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CPU DEAD - CONTROL STORE RELOAD FAILED.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (CONSOLE), LOG (OS).

          SETDAC (DDDC)
          SETDAN (EPUN,DADRF)
          SETFLG (BC.CL,BC.FL)
          LJM    DCE         PROCESS DEAD CPU
 RFI      SPACE  4,10
**        RFI - RETRY FAILING INSTRUCTION.


 RFI      BSS    0           ENTRY
          AOM    RETRYC      INCREMENT RETRY COUNTER
          LMM    RETRYL
          NJN    SPR         IF RETRIES NOT EXHAUSTED
          STM    RETRYC

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CPU DEAD - RETRIES EXHAUSTED.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (CONSOLE), LOG (OS).

          SETDAC (DDDC)
          SETDAN (EPUN,DADRX)
          SETFLG (BC.CL,BC.FL)
          LJM    DCE         PROCESS DEAD CPU
 SPR      SPACE  4,10
**        SPR - START PROCESSOR.
*
*         MACROS FUNCMR.


 SPR      BSS    0           ENTRY
          FUNCMR ,MRSP       START PROCESSOR
          LJM    APE3        HALT PROCESSOR AND RECHECK
 UCE      SPACE  4,10
**        UCE - PROCESS UNCORRECTED CPU ERROR.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED PROCESSOR ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (CONSOLE), LOG (OS), VALID 180.
*         DFT ANALYSIS - OS ACTION = UNCORRECTED PROCESSOR ERROR.
*                                  = NO OS ACTION (VERSION 4).


 UCE      BSS    0           ENTRY
          LDM    PFCL+1*4+1  CHECK BIT 23 OF REGISTER #891
          LPC    0#100
          ZJN    UCE1        IF NO PAGE MAP ERROR RESPONSE
          LDN    SSMR        CHECK FOR PAGE MAP ERROR IN MEMORY SUMMARY STATUS
          STD    RN
          LDM    CMCC        READ MEMORY SUMMARY STATUS
          RJM    RMR
          SHN    21-SSPM
          MJP    UME         IF UNCORRECTED PAGE MAP ERROR
          LDM    HBUF+CPRPC  RESTORE PROCESSOR CONNECT CODE
          STD    EC
 UCE1     SETDAC (DDCE)
          SETDAN (EPUN,DAUPE)
          SETFLG (BC.CL,BC.FL,BC.FV8)
          SETOSA OSUPE,OSNA
          RJM    CCU         CHECK FOR CONTROL STORE UNCORRECTED ERROR
          NJP    PCE0        IF CONTROL STORE RELOAD NECESSARY
          RJM    SUL         SET UNCORRECTED LIST TO BE LOGGED
          LJM    UML         UPDATE MRB AND LOG ERROR
 UME      SPACE  4,10
**        UME - PROCESS UNCORRECTED PAGE MAP ERROR.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED PAGE MAP ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERRORS IN PAGE MAP AND CPU.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (CONSOLE), LOG (OS).


 UME      BSS    0           ENTRY
          RJM    SML         SET PAGE MAP REGISTER LIST
          SETDAC (DCEMP)
          SETDAN (EPUN,DAUPM)
          SETFLG (BC.CL,BC.FL)
          CALL   RMR         READ MAINTENANCE REGISTERS
          UJN    UML1        UPDATE MRB AND LOG ERROR
 UML      SPACE  4,10
**        UML - UPDATE MRB WITH ORIGINAL ERROR LOG REGISTERS AND LOG ERROR.
*
*         ENTRY  (PUEL - PUEL+7) = ORIGINAL *S0PUEL* REGISTER CONTENTS.
*                (PFCL - PFCL+7) = ORIGINAL *S0PFCL* REGISTER CONTENTS.
*                REGISTER LIST(S) SET UP.
*
*         EXIT   SCRATCH MRB UPDATED WITH ORIGINAL REGISTER CONTENTS.
*                *LOG* CALLED.
*
*         CALLS  CID, FMB, SSE, *LOG*, *RMR*.


 UML      BSS    0           ENTRY
          CALL   RMR         READ MAINTENANCE REGISTERS TO SCRATCH MRB
          LDM    CPUO        GET CPU ORDINAL
          RJM    SSE         SET PROCESSOR ID
          LDC    S0PUEL      UPDATE UNCORRECTED ERROR LOG IN SCRATCH MRB
          RJM    FMB
          CWML   PUEL,ON
          LDC    S0PFCL      UPDATE FIRST/CORRECTED ERROR LOG IN SCRATCH MRB
          RJM    FMB
          CWML   PFCL,ON

*         PAGE MAP PROCESSING ENTERS HERE TO UPDATE ONLY 0#881/0#891.

 UML1     LDC    S0PUEL+1    UPDATE UNCORRECTED ERROR LOG IN SCRATCH MRB
          RJM    FMB
          CWML   PUEL+4,ON
          LDC    S0PFCL+1    UPDATE FIRST/CORRECTED ERROR LOG IN SCRATCH MRB
          RJM    FMB
          CWML   PFCL+4,ON
          RJM    CID         CHECK IF CPU DEGRADABLE
          CALL   LOG         LOG ERROR
          LJM    APEX        RETURN
 CCU      SPACE  4,10
**        CCU - CHECK FOR CONTROL STORE UNCORRECTED ERROR.
*
*         EXIT   (A) = 0 IF NO CONTROL STORE SECDED ERROR INDICATED.
*
*         MACROS READMR.


 CCU      SUBR               ENTRY/EXIT
          LDM    S0EFLG      CHECK MAINFRAME TYPE
          NJN    CCU1        IF S0E

*         PROCESS S0 CPU.

          READMR RDATA,,S0PCSS  CHECK CONTROL STORE SECDED ERRORS
          LDM    RDATA+2
          SHN    10
          ADM    RDATA+3
          LPC    0#5858      EXTRACT BITS 17, 19, 20, 25, 27, 28
          UJN    CCUX        RETURN

*         PROCESS S0E CPU.

 CCU1     READMR RDATA,,SEPCSS  CHECK CONTROL STORE SECDED ERRORS
          LDM    RDATA+2
          SHN    10
          ADM    RDATA+1
          LPC    0#5858      EXTRACT BITS 17, 19, 20, 9, 11, 12
          LJM    CCUX        RETURN
 CMH      SPACE  4,10
**        CMH - CHECK FOR MICROHALT (CONTROL STORE ADDRESSES 141 - 158).
*
*         EXIT   (A) = 0, IF MICROHALT.
*                    = 1, IF NOT MICROHALT.


 CMH      SUBR               ENTRY/EXIT
          LDML   CSA2        CHECK MICROHALT (CONTROL STORE ADDRESSES 141 - 158)
          SBK    0#141
          MJN    CMH1        IF CONTROL STORE ADDRESS BELOW HALT RANGE
          SBK    0#158+1-0#141
          PJN    CMH1        IF CONTROL STORE ADDRESS ABOVE HALT RANGE
          LDN    0           SET MICROHALT STATUS
          UJN    CMHX        RETURN

 CMH1     LDN    1           SET NO MICROHALT STATUS
          UJN    CMHX        RETURN
 HPR      SPACE  4,10
**        HPR - HALT PROCESSOR.
*
*         EXIT   TO *DCE* IF TIMED OUT TRYING TO HALT PROCESSOR.
*                (SUMS) = UPDATED (POST-HALT) SUMMARY STATUS.
*
*         CALLS  RMR, TIM.
*
*         MACROS FUNCMR.


 HPR      SUBR               ENTRY/EXIT
          FUNCMR ,MRHP       STOP PROCESSOR
          LDN    SSMR
          STD    RN

*         WAIT UP TO 500 MILLISECONDS FOR CPU TO HALT.

          LDN    0           RESET TIMER
          STML   ACTB1+2
          STML   TFLG
          STM    HPRA
 HPR1     LDD    EC          RECHECK SUMMARY STATUS
          RJM    RMR
          STM    SUMS
          LPN    0#8
          NJN    HPRX        IF PROCESSOR HALTED
          RJM    TIM         PROCESS TIMED EVENTS
          LDM    TFLG
          ZJN    HPR1        IF 100 MILLISECONDS NOT ELAPSED YET
          LDN    0
          STM    TFLG
          AOM    HPRA        ADVANCE COUNTER
          LMN    5
          NJN    HPR1        IF NOT 500 MILLISECONDS

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CPU DEAD - HALT TIMED OUT.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (CONSOLE), LOG (OS).

          SETDAC (DDDC)
          SETDAN (EPUN,DADTO)
          SETFLG (BC.CL,BC.FL)
          LJM    DCE         PROCESS DEAD CPU

 HPRA     BSS    1
 PCS      SPACE  4,10
**        PCS - PACK CONTROL STORE ADDRESSES.
*
*         EXIT   (CSA0) = SLOT 0 CONTROL STORE ADDRESS.
*                (CSA1) = SLOT 1 CONTROL STORE ADDRESS.
*                (CSA2) = SLOT 2 CONTROL STORE ADDRESS.
*
*         MACROS READMR.


 PCS      SUBR               ENTRY/EXIT
          READMR RDATA,,S0PCSA  READ AND SAVE CONTROL STORE ADDRESSES
          LDM    RDATA+2     PACK SLOT 0 ADDRESS
          SHN    10
          ADM    RDATA+3
          STML   CSA0
          LDM    RDATA+4     PACK SLOT 1 ADDRESS
          SHN    10
          ADM    RDATA+5
          STML   CSA1
          LDM    RDATA+6     PACK SLOT 2 ADDRESS
          SHN    10
          ADM    RDATA+7
          STML   CSA2
          LJM    PCSX        RETURN
 PKR      SPACE  4,10
**        PKR - PACK REGISTER.
*
*         ENTRY  (A) = ADDRESS TO STORE PACKED REGISTER.
*                (RDATA - RDATA+7) = REGISTER CONTENTS.
*
*         EXIT   ((A) - (A)+3) = PACKED REGISTER.
*
*         USES   T0.


 PKR      SUBR               ENTRY/EXIT
          STD    T0          SAVE DESTINATION ADDRESS
          LDM    RDATA       PACK BYTES 0 - 1 INTO FIRST PP WORD
          SHN    10
          ADM    RDATA+1
          STIL   T0
          AOD    T0
          LDM    RDATA+2     PACK BYTES 2 - 3 INTO NEXT PP WORD
          SHN    10
          ADM    RDATA+3
          STIL   T0
          AOD    T0
          LDM    RDATA+4     PACK BYTES 4 - 5 INTO NEXT PP WORD
          SHN    10
          ADM    RDATA+5
          STIL   T0
          AOD    T0
          LDM    RDATA+6     PACK BYTES 6 - 7 INTO NEXT PP WORD
          SHN    10
          ADM    RDATA+7
          STIL   T0
          UJN    PKRX        RETURN
 REL      SPACE  4,10
**        REL - READ ERROR LOG REGISTERS.
*
*         EXIT   (PUEL - PUEL+7) = UNCORRECTED ERROR LOG (PAIR 0#880/0#881).
*                (PFCL - PFCL+7) = FIRST/CORRECTED ERROR LOG (PAIR 0#890/0#891).
*
*         CALLS  PKR.
*
*         MACROS READMR.


 REL      SUBR               ENTRY/EXIT
          READMR RDATA,,S0PUEL  READ UNCORRECTED ERROR LOG (FIRST HALF)
          LDC    PUEL        PACK INTO *PUEL - PUEL+3*
          RJM    PKR
          READMR RDATA,,S0PUEL+1  READ UNCORRECTED ERROR LOG (SECOND HALF)
          LDC    PUEL+4      PACK INTO *PUEL+4 - PUEL+7*
          RJM    PKR
          READMR RDATA,,S0PFCL  READ FIRST/CORRECTED ERROR LOG (FIRST HALF)
          LDC    PFCL        PACK INTO *PFCL - PFCL+3*
          RJM    PKR
          READMR RDATA,,S0PFCL+1  READ FIRST/CORRECTED ERROR LOG (SECOND HALF)
          LDC    PFCL+4      PACK INTO *PFCL+4 - PFCL+7*
          RJM    PKR
          LJM    RELX        RETURN
 SCL      SPACE  4,10
**        SCL - SET CORRECTED LIST TO BE LOGGED.
*
*         CALLS  BRL.


 SCL      SUBR               ENTRY/EXIT
          LDM    CPUH        CHECK CPU ORDINAL
          NJN    SCL1        IF CPU-1
          LDM    CP0C        USE CPU-0 CORRECTED REGISTER LIST
          UJN    SCL2        CONTINUE

 SCL1     LDM    CP1C        USE CPU-1 CORRECTED REGISTER LIST
 SCL2     RJM    BRL
          UJN    SCLX        RETURN
 SML      SPACE  4,10
**        SML - SET PAGE MAP REGISTER LIST.
*
*         EXIT   REGISTER LIST BUILT WITH MEMORY, PAGE MAP, CPU SUBLISTS.
*                (EI) = (PMEI ).
*                (ET) = *DFTPMID*.
*
*         CALLS  BRL.
*
*         NOTE   THIS ASSUMES THAT CORRECTED AND UNCORRECTED LISTS MATCH.


 SML      SUBR               ENTRY/EXIT
          LDN    CMID        SET MEMORY REGISTERS TO LOG
          STD    ET
          LDC    MPMD0
          RJM    BRL
          LDN    DFTPMID     SET PAGE MAP *DEC* REGISTERS TO LOG
          STD    ET
          LDC    PD0
          RJM    BRL
          LDC    PM0         SET PAGE MAP REGISTERS TO LOG
          RJM    BRL
          LDN    PROCID      SET PROCESSOR REGISTERS TO LOG
          STD    ET
          LDC    PPM0
          RJM    BRL
          LDN    DFTPMID     RESTORE (ET)
          STD    ET
          LDM    PMEI        SET PAGE MAP ELEMENT INDEX
          STD    EI
          UJN    SMLX        RETURN
 SUL      SPACE  4,10
**        SUL - SET UNCORRECTED LIST TO BE LOGGED.
*
*         CALLS  BRL.


 SUL      SUBR               ENTRY/EXIT
          LDM    CPUH        CHECK CPU ORDINAL
          NJN    SUL1        IF CPU-1
          LDM    CP0U        USE CPU-0 UNCORRECTED REGISTER LIST
          UJN    SUL2        CONTINUE

 SUL1     LDM    CP1U        USE CPU-1 UNCORRECTED REGISTER LIST
 SUL2     RJM    BRL
          UJN    SULX        RETURN
 COMMON   SPACE  4,10
*         COMMON DECKS.


 QUAL$    EQU    0           DEFINE UNQUALIFIED COMMON DECK
*COPY CTP$DFT_START_MICROCODE
*COPY CTP$DFT_SAVE_CONTROL_STORE
*COPY CTP$DFT_CHECK_DEGRADABLE_CPU
          OVERFLOW  10000    CHECK FOR OVERFLOW
          OVERLAY  (ANALYZE IOU ERROR)
 AIE      SPACE  4,10
**        AIE - ANALYZE IOU ERROR.
*
*         ENTRY  SUMMARY STATUS INDICATES IOU ERROR.
*                (EC) = CONNECT CODE.
*                (ET) = *IOUID*.
*                (SUMS) = SUMMARY STATUS.


          ROUTINE  AIE

          LDN    0           SET NO ERROR FLAG FALSE
          STM    NERR
          LDN    BC          CLEAR SCRATCH BUFFER
          RJM    CLR
          CALL   CFF         CHECK FOR FREEZE
          LDM    RTP2
          ZJN    AIE0.5      IF NOT TO IGNORE ERROR
          LDN    0
          STM    DFTA        NO ACTION
          STM    REGI        RESET REGISTER LIST INDEX
          UJP    AIEX

 AIE0.5   LDM    SUMS        CHECK TYPE OF ERROR
          SHN    21-SSUE
          PJN    PCE         IF CORRECTED ERROR
          LJM    PUE         PROCESS UNCORRECTED ERROR

*         COMMON EXIT FROM CORRECTED/UNCORRECTED ERRORS.

 AIE1     CALL   LOG         LOG ERRORS
          LJM    AIEX        RETURN
 PCE      SPACE  4,10
**        PCE - PROCESS CORRECTED ERROR.
*
*         ENTRY  VIA *LJM*.
*
*         EXIT   TO *AIE1*.
*
*         CALLS  BRL, *RMR*.


 PCE      BSS    0           ENTRY
          LDM    IO0C
          RJM    BRL         BUILD REGISTER LIST FOR CORRECTED IOU ERROR
          CALL   RMR         READ MAINTENANCE REGISTERS

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CORRECTED IOU ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAC DDCL
          SETDAN (EPCO,DACIE)
          SETFLG (BC.FL)
          LJM    AIE1        RETURN
 PUE      SPACE  4,10
**        PUE - PROCESS UNCORRECTED ERROR.
*
*         ENTRY  VIA *LJM*.
*
*         EXIT   TO *AIE1*.
*
*         CALLS  BRL, CCE, CFE, CPH, *RMR*.


 PUE      BSS    0           ENTRY
          LDM    IO0U
          RJM    BRL         BUILD UNCORRECTED ERROR REGISTER LIST
          CALL   RMR         READ MAINTENANCE REGISTERS
          LDM    SUMS        CHECK TYPE OF ERROR
          SHN    21-SSPH
          PJP    PUE3        IF NOT PP HALT
          RJM    CPH         CHECK PP HALT
          ZJP    PUE3        IF NOT PP HALT IN *PFS* REGISTERS

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED IOU ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (CONSOLE), LOG (OS), VALID 180.
*         DFT ANALYSIS - OS ACTION = FATAL IOU ERROR.
*                                  = SYSTEM STEP (VERSION 4).

          SETDAC DDCL
          SETDAN (EPUN,DAUIE)
          SETFLG (BC.CL,BC.FL,BC.FV8)
          SETOSA OSVEI,OSSS

          LDN    D8TY
          RJM    IIB
          CRDL   CM
          LDDL   CM+3
          LPC    0#3F
          SBN    2
          MJN    PUE2        IF DFT LEVEL GREATER THAN OS LEVEL
          SETOSA OSVEI,OSHGP HUNG PP OS ACTION

 PUE2     LJM    PUEX        RETURN

 PUE3     RJM    CFE         CHECK FOR FATAL IOU ERROR
          ZJP    PUE5        IF NOT FATAL IOU ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = FATAL IOU ERROR.
*         DFT ANALYSIS - CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (CONSOLE), LOG (OS), VALID 180.
*         DFT ANALYSIS - OS ACTION = FATAL IOU ERROR.
*                                  = SYSTEM STEP (VERSION 4).

 PUE4     SETDAC DDCL
          SETDAN (EPUN,DAFI)
          SETFLG (BC.CL,BC.FL,BC.FV8)
          SETOSA OSFIE,OSSS
 PUEX     LJM    AIE1        RETURN

 PUE5     RJM    CCE         CHECK FOR CHANNEL ERROR
          ZJP    PUE4        IF NOT CHANNEL DEFAULT IS FATAL

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CHANNEL ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS)

          SETDAC DDCL
          SETDAN (EPCO,DACHE)
          SETFLG (BC.FL)
          UJN    PUEX        RETURN
 CCE      SPACE  4,10
**        CCE - CHECK CHANNEL ERROR.
*
*         EXIT   (A) <> 0 CHANNEL ERROR FOUND.
*                (A) = 0 CHANNEL ERROR NOT FOUND.
*


 CCE0     LDN    0

 CCE      SUBR               ENTRY/EXIT
          LDN    0           INITIALIZE REGISTER LOOP
          STD    T1
 CCE1     LDD    T1          READ NEXT CHANNEL FAULT STATUS REGISTER (CLUSTER 0)
          ADC    S0ICF0
          RJM    FMB         FIND REGISTER IN BUFFER
          CRDL   W0
          LDDL   W0
          LPC    0#0FFF
          NJP    CCEX        IF ERROR FOUND BITS 4-15
          LDDL   W1
          LPC    0#FFF
          NJP    CCEX        IF ERROR FOUND BITS 20-31
          LDDL   W2
          LPC    0#ACFE
          NJP    CCEX        IF ERROR FOUND BITS  32,34-37,40-46
          AOD    T1          ADVANCE TO NEXT REGISTER
          LMN    3
          NJN    CCE1
          LDM    CLST2       GET MULTIPLE CLUSTERS FLAG
          ZJP    CCE0        IF ONLY CLUSTER 0
          LDN    0           INITIALIZE REGISTER LOOP
          STD    T1
 CCE2     LDD    T1          READ NEXT CHANNEL FAULT STATUS REGISTER (CLUSTER 2)
          ADC    S0ICF2
          RJM    FMB         FIND REGISTER IN BUFFER
          CRDL   W0
          LDDL   W0
          LPC    0#0FFF
          NJP    CCEX        IF ERROR FOUND BITS 4-15
          LDDL   W1
          LPC    0#FFF
          NJP    CCEX        IF ERROR FOUND BITS 20-31
          LDDL   W2
          LPC    0#ACFE
          NJP    CCEX        IF ERROR FOUND BITS  32,34-37,40-46
          AOD    T1
          LMN    3
          NJN    CCE2        IF MORE TO CHECK
          LJM    CCEX        RETURN WITH NO ERROR INDICATION
 CFE      SPACE  4,10
**        CFE - CHECK FOR FATAL PP ERROR.
*
*         EXIT   (A) <> 0 IF FATAL PP ERROR FOUND.
*                (A) = 0 IF FATAL PP ERROR NOT FOUND.


 CFE0     LDN    0

 CFE      SUBR               ENTRY/EXIT
          LDC    S0IBF0      READ BUS ARBITER FAULT STATUS REGISTER (CLUSTER 0)
          RJM    FMB         FIND REGISTER IN BUFFER
          CRDL   W0
          LDDL   W0
          LPC    0#58        BITS 9,11,12
          NJN    CFEX        IF ERROR BITS SET
          LDDL   W1
          LPC    0#58        BITS 25,27,28
          NJN    CFEX        IF ERROR BITS SET
          LDM    CLST2       MULTIPLE CLUSTERS FLAG
          ZJN    CFE0        IF ONLY CLUSTER 0
          LDC    S0IBF2      READ BUS ARBITER FAULT STATUS REGISTER (CLUSTER 2)
          RJM    FMB         FIND REGISTER IN BUFFER
          CRDL   W0
          LDDL   W0
          LPC    0#58        BITS 9,11,12
          NJN    CFEX        IF ERROR BITS SET
          LDDL   W1
          LPC    0#58        BITS 25,27,28
          LJM    CFEX        RETURN WITH ERROR CONDITION IN (A)
 CPH      SPACE  4,10
**        CPH - CHECK FOR PP HALT.
*
*         EXIT   (A) <> 0 IF PP HALT FOUND.
*                (A) = 0 IF PP HALT NOT FOUND.


 CPH0     LDN    0           SET UP FOR NOT FOUND CONDITION

 CPH      SUBR               ENTRY/EXIT
          LDN    0           INITIALIZE REGISTER LOOP
          STD    T1
 CPH1     LDD    T1          READ NEXT FAULT STATUS REGISTER
          ADC    S0IFS0
          RJM    FMB         FIND REGISTER IN BUFFER
          CRDL   W0
          LDDL   W2          GET TO DUE, PP HALT BITS
          LPC    0#A000
          NJP    CPHX        IF PP HALTED
          AOD    T1          ADVANCE TO NEXT FAULT STATUS REGISTER
          LMN    5
          NJN    CPH1        IF MORE REGISTERS TO CHECK
          LDM    CLST2       GET MULTIPLE CLUSTERS FLAG
          ZJP    CPH0        IF NOT MULTIPLE CLUSTERS
          LDN    0           INITIALIZE REGISTER LOOP
          STD    T1
 CPH2     LDD    T1          READ NEXT FAULT STATUS REGISTER
          ADC    S0IFS2
          RJM    FMB         FIND REGISTER IN BUFFER
          CRDL   W0
          LDDL   W2          GET TO DUE, PP HALT BITS
          LPC    0#A000
          NJP    CPHX        IF PP HALTED
          AOD    T1
          LMN    5
          NJN    CPH2        IF MORE REGISTERS TO CHECK
          UJP    CPH0        RETURN

          OVERFLOW  10000    CHECK FOR OVERFLOW
          OVERLAY  (ANALYZE MEMORY ERROR)
 AME      SPACE  4,10
**        AME - ANALYZE MEMORY ERROR.
*
*         ENTRY  SUMMARY STATUS INDICATES MEMORY ERROR.
*                (EC) = CONNECT CODE.
*                (ET) = *CMID*.
*                (SUMS) = SUMMARY STATUS.
*
*         CALLS  CLR, GMI, PCE, PUE, *CFF*, *LOG*.


          ROUTINE  AME

          LDN    0           SET NO ERROR FLAG FALSE
          STM    NERR
          STM    RLST
          STM    SBER
          STM    SBER+1
          LDN    BC          CLEAR SCRATCH BUFFER
          RJM    CLR
          CALL   CFF         CHECK FOR FREEZE
          LDM    RTP2
          ZJN    AME0        IF NOT TO IGNORE ERROR
          LDN    0
          STM    DFTA        NO ACTION
          STM    REGI        RESET REGISTER LIST
          UJP    AMEX

 AME0     LDM    SUMS        CHECK TYPE OF ERROR
          SHN    21-SSUE
          MJP    PUE         IF UNCORRECTED ERROR
          SHN    1
          MJP    PCE         IF CORRECTED ERROR

*         CAN GET HERE IF A PAGE MAP ERROR EXISTS. IF IT DOES PASS CONTROL TO
*         ANALYZE PROCESSOR ERRORS, AND DONT DO ANY ACTIONS ON THIS ERROR HERE.

          LDN    0           SET UP NULL ACTION LIST
          STM    DFTA
 AME1     LJM    AMEX        RETURN
 CMRLP    SPACE  4,10
**        CORRECTED MEMORY REGISTER LIST POINTERS.


 CMRLP    CON    MC00        BOARD 0 BANK 0
          CON    MC01        BOARD 0 BANK 1
          CON    MC02        BOARD 0 BANK 2
          CON    MC03        BOARD 0 BANK 3

          CON    MC10        BOARD 1 BANK 0
          CON    MC11        BOARD 1 BANK 1
          CON    MC12        BOARD 1 BANK 2
          CON    MC13        BOARD 1 BANK 3

          CON    MC20        BOARD 2 BANK 0
          CON    MC21        BOARD 2 BANK 1
          CON    MC22        BOARD 2 BANK 2
          CON    MC23        BOARD 2 BANK 3

          CON    MC30        BOARD 3 BANK 0
          CON    MC31        BOARD 3 BANK 1
          CON    MC32        BOARD 3 BANK 2
          CON    MC33        BOARD 3 BANK 3

          ERRNZ  *-CMRLP-20  TABLE SIZE INCORRECT
 UMBE     SPACE  4,10
**        UNCORRECTED REGISTER LIST FOR MEMORY BOARD ERRORS.

 UMBE     CON    MUB0        BOARD 0
          CON    MUB1        BOARD 1
          CON    MUB2        BOARD 2
          CON    MUB3        BOARD 3

          ERRNZ  *-UMBE-4   TABLE SIZE INCORRECT
 UMRLP    SPACE  4,10
**        UNCORRECTED MEMORY REGISTER LIST POINTERS.


 UMRLP    CON    MU00        BOARD 0 BANK 0
          CON    MU01        BOARD 0 BANK 1
          CON    MU02        BOARD 0 BANK 2
          CON    MU03        BOARD 0 BANK 3

          CON    MU10        BOARD 1 BANK 0
          CON    MU11        BOARD 1 BANK 1
          CON    MU12        BOARD 1 BANK 2
          CON    MU13        BOARD 1 BANK 3

          CON    MU20        BOARD 2 BANK 0
          CON    MU21        BOARD 2 BANK 1
          CON    MU22        BOARD 2 BANK 2
          CON    MU23        BOARD 2 BANK 3

          CON    MU30        BOARD 3 BANK 0
          CON    MU31        BOARD 3 BANK 1
          CON    MU32        BOARD 3 BANK 2
          CON    MU33        BOARD 3 BANK 3

          ERRNZ  *-UMRLP-20 TABLE SIZE INCORRECT
 CBE      SPACE  4,10
**        CBE - CHECK FOR BANK ERROR.
*
*         ENTRY  (BRDI) = BOARD BEING CHECKED.
*                (BKER) = 0.
*                (A) = 1 IF PROCESSING UNCORRECTED ERROR.
*                (A) = 0 IF PROCESSING CORRECTED ERROR.
*
*         EXIT   (A) = (BKER) = 1 IF BANK ERROR(S) DETECTED.
*
*         USES   T1 - T4.


 CBE      SUBR               ENTRY/EXIT
          STM    CBEA
          LDN    0
          STM    BKER        RESET BANK ERROR FOUND
          LDM    BRDI        CALCULATE REGISTER TO BE CHECKED
          SHN    2
          ADM    BNKI
          STD    T1
          LDM    CBEA        SET CORRECTED/UNCORRECTED
          STD    T2
          LDM    CBED,T2     GET CORRECT REGISTER BASE FOR EITHER CORR OR UNCORR
          ADD    T1          ADD IN BANK AND BOARD ADJUSTMENT
          STD    RN
          READMR RDATA       CHECK FOR BANK ERROR (BIT 16)
          LDML   RDATA+2
          SHN    21-7
          PJP    CBE2        IF NO BANK ERROR
          LDM    BRDI        GET BOARD NUMBER
          SHN    2           MULTIPLY BY 4 FOR PROPER BOARD OFFSET
          ADM    BNKI        GET BANK INDEX
          STD    T4          ADD BANK INDEX WITHIN BOARD INDEX
          LDM    CBEA        FLAG FOR UNCORR OR CORR ERROR PROCESSING
          STD    T2

*         BUILD COMMON REGISTER LIST.

          LDM    CBEC,T2     GET CORRECT COMMON REGISTER LIST
          STD    T3
          LDI    T3
          RJM    BRL         BUILD REGISTER LIST

*         BUILD REGISTER LIST FOR BANK AFFECTED.

          LDM    CBEB,T2     GET CORRECT LIST HEAD
          RAD    T4          UPDATE WITH UNCORRECTED/CORRECTED LIST HEAD
          LDI    T4
          RJM    BRL         BUILD BANK REGISTER LIST WITHIN THIS BOARD
          AOM    BKER        SET BANK ERROR TRUE
          AOM    MEER        SET ANY MEMORY ERROR FLAG
          LDM    BNKI        SAVE BANK WITH ERROR
          SBM    DEGR        CONVERT BANKS 2,3 TO 0,1 FOR NUMBERING SCHEME
          STM    BKNO
 CBE2     LDM    BKER
          LJM    CBEX        RETURN

 CBEA     BSS    1           CORRECTED/UNCORRECTED FLAG
 CBEB     CON    CMRLP       CORRECTED REGISTER LIST
          CON    UMRLP       UNCORRECTED REGISTER LIST
 CBEC     CON    ME0C        COMMON REGISTERS FOR CORRECTED ERROR
          CON    ME0U        COMMON REGISTERS FOR UNCORRECTED ERROR
 CBED     CON    S0MCD       REGISTER BASE FOR CORRECTED ERROR
          CON    S0MUD       REGISTER BASE FOR UNCORRECTED ERROR
 CBK      SPACE  4,10
**        CBK - PROCESS CORRECTED BANK ERROR.
*
*         ENTRY  VIA *LJM*.
*
*         EXIT   TO *PCE2*.
*
*         CALLS  FMA, GSC, *SME*.


 CBK      BSS    0           ENTRY

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CORRECTED MEMORY ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAC DDCL
          SETDAN (EPCO,DACME)
          SETFLG (BC.FL)

*         REWRITE MEMORY WITH CORRECTED FAILURE.

          RJM    GSC         GET SYNDROME CODE
          RJM    FMA         FORM MEMORY ADDRESS
          CALL   SME         SERVICE MEMORY ERROR
          LJM    PCE2        RETURN
 CBS      SPACE  4,10
**        CBS - CHECK FOR BIT SET IN REGISTERS.
*
*         ENTRY  (A) = BASE REGISTER TO CHECK.
*
*         EXIT   (A) = NONZERO, IF BIT(S) SET IN REGISTER (A) OR (A)+4.


 CBS      SUBR               ENTRY/EXIT
          STD    RN          CHECK BASE REGISTER
          READMR RDATA
          LDML   RDATA       CHECK FOR ANY BIT(S) SET
          ADML   RDATA+1
          ADML   RDATA+2
          ADML   RDATA+3
          ADML   RDATA+4
          ADML   RDATA+5
          ADML   RDATA+6
          ADML   RDATA+7
          NJN    CBSX        IF BIT(S) SET
          LDN    4           CHECK BASE+4
          RAD    RN
          READMR RDATA
          LDML   RDATA       CHECK FOR ANY BIT(S) SET
          ADML   RDATA+1
          ADML   RDATA+2
          ADML   RDATA+3
          ADML   RDATA+4
          ADML   RDATA+5
          ADML   RDATA+6
          ADML   RDATA+7
          LJM    CBSX        RETURN WITH RESULT
 CIF      SPACE  4,10
**        CIF - CENTRAL MEMORY INTERFACE ERROR.
*
*         ENTRY  MAINTENANCE REGISTERS FOR ERROR READ INTO THE SCRATCH BUFFER.
*
*         EXIT   (A) = 0 IMPLIES NO ERROR.
*                (A) = 1 IMPLIES ERROR FOUND.
*
*         USES   CM.
*
*         MACROS READMR, SETDAC, SETDAN, SETFLG, SETOSA.
*
*         CALLS  FMB.


 CIF0     LDN    0           SET FOR NO ERROR FOUND

 CIF      SUBR               ENTRY/EXIT
          READMR RDATA,,S0MBA  CENTRAL MEMORY BUS ARBITRATOR
          LDM    RDATA
          SHN    12          POSITION TO LOGGED ERROR BIT
          PJP    CIF0        IF NOT LOGGED
          LDM    ME0U        UNCORRECTED COMMON REGISTERS
          RJM    BRL         BUILD REGISTER LIST

*         SET UP SCRATCH BUFFER CONTROL WROD.
*
*         DFT ANALYSIS - ANALYSIS = CENTRAL MEMORY INTERFACE ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (CONSOLE), LOG (OS), VALID 180.
*         DFT ANALYSIS - OS ACTION = UNCORRECTED MEMORY ERROR.
*                                  = NO OS ACTION (VERSION 4).

          SETDAC DDCL
          SETDAN (EPUN,DACMI)
          SETFLG (BC.CL,BC.FL,BC.FV8)
          SETOSA OSUCM,OSNA
          LDN    1
          LJM    CIFX        RETURN
 FMA      SPACE  4,10
**        FMA - FORM MEMORY ADDRESS.
*
*         ENTRY  (BRDI) = BOARD INDEX.
*                (BNKI) = BANK INDEX.
*
*         EXIT   (SBER - SBER+1) = ADDRESS OF ERROR -
*                (SBER) = BITS 18-26 FROM REGISTER D_X.
*                (SBER+1) = BITS 27-31 * 2**11
*                (SBER+1) = BITS 0-1 OF REGISTER E_X * 2**9
*                (SBER+1) = (BKNO) IN LEAST SIGNIFICANT BITS (BITS 0,1).
*                           OR IF DEGRADE BIT 0.
*
*         CALLS  FMB.


 FMA      SUBR               ENTRY/EXIT
          LDM    BRDI        READ FIRST REGISTER (E_X)
          SHN    2
          ADM    BNKI
          STD    T1          SAVE LOWER NIBBLE OF REGISTER NUMBER
          ADC    S0MBC       READ CORRECTED BANK CONTROL REGISTER
          RJM    FMB
          CRDL   CM          READ THE REGISTER FROM SCRATCH MRB
          LDDL   CM          EXTRACT BITS 0-1
          SHN    -16
          LPN    3
          SHN    11
          STML   SBER+1
          LDD    T1          GET PROPER (D_X) REGISTER
          ADC    S0MCD       READ CORRECTED BANK DATA AND CONTROL
          RJM    FMB
          CRDL   CM          READ D_X REGISTER FROM SCRATCH MRB
          LDDL   CM+1        EXTRACT BITS 27-31
          LPN    0#1F
          SHN    13
          RAML   SBER+1
          LDDL   CM+1        EXTRACT BITS 18-26
          SHN    -5
          LPC    0#1FF
          STML   SBER
          LDM    BKNO
          RAML   SBER+1      ADD IN BANK NUMBER
          LJM    FMAX        RETURN
 GSC      SPACE  4,10
**        GSC - GET SYNDROME CODE.
*
*         ENTRY  (BRDI) = BOARD INDEX.
*                (BNKI) = BANK INDEX.
*
*         EXIT   (SYCD) = SYNDROME CODE.
*
*         CALLS  FMB.


 GSC      SUBR               ENTRY/EXIT
          LDM    BRDI        BOARD INDEX
          SHN    2
          ADM    BNKI        BANK INDEX
          ADC    S0MCD       READ CORRECTED BANK DATA AND CONTROL
          RJM    FMB
          CRDL   CM          GET D_X REGISTER FROM SCRATCH MRB
          LDDL   CM
          SHN    -10
          STM    SYCD        SAVE SYNDROME CODE
          UJN    GSCX        RETURN
 PBD      SPACE  4,10
**        PBD - PROCESS BOARD ERROR.
*
*         ENTRY  VIA *LJM*.
*                (BRDI) = BOARD BEING CHECKED.
*
*         EXIT   TO *PUE3*.
*
*
*         USES   T3.


 PBD      BSS    0           ENTRY
          LDM    BRDI        BOARD INDEX
          ADC    S0MIB       SET INPUT BUFFER REGISTER
          RJM    CBS         CHECK FOR BIT(S) IN REGISTERS 9X AND 9X+4
          ZJP    PBDX        IF NO BITS SET
          LDM    ME0U        UNCORRECTED COMMON REGISTERS
          RJM    BRL         BUILD REGISTER LIST
          AOM    BDER        SET BOARD ERROR FLAG
          AOM    MEER        SET MEMORY ERROR OCCURRED FLAG
          LDM    BRDI        CURRENT BOARD INDEX
          ADC    UMBE        MEMORY BOARD REGISTER LIST
          STD    T3
          LDI    T3          GET LIST
          RJM    BRL         BUILD REGISTER LIST

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED MEMORY BOARD ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (CONSOLE), LOG (OS), VALID 180.
*         DFT ANALYSIS - OS ACTION = UNCORRECTED MEMORY ERROR.
*                                  = NO OS ACTION (VERSION 4).

          SETDAC DDCL
          SETDAN (EPUN,DAUMB)
          SETFLG (BC.CL,BC.FL,BC.FV8)
          SETOSA OSUCM,OSNA
          CALL   RMR         READ MAINTENANCE REGISTERS
          CALL   LOG         LOG THE ERROR
 PBDX     LJM    PUE3        RETURN
 PCE      SPACE  4,10
**        PCE - PROCESS CORRECTED ERROR.
*
*         ENTRY  VIA *LJM*.
*                (NBRDS) = BOARD CONFIGURATION.
*
*         EXIT   TO *AME1*.
*
*         CALLS  BRL, CBE, CBK, *RMR*.


 PCE      BSS    0           ENTRY
          LDN    0
          STM    BRDI        INITIALIZE BOARD INDEX
          LDM    SBNK        STARTING BANK
          STM    BNKI        INITIALIZE BANK INDEX
          AOM    RLST        SET CORRECTED ERROR FLAG
 PCE1     LDN    0
          STM    BKER        INITIALIZE BANK ERROR
*         LDN    0           SET FLAG FOR CORRECTED ERROR
          RJM    CBE         CHECK BANK ERROR
          ZJN    PCE2        IF NO BANK ERROR
          CALL   RMR         READ MAINTENANCE REGISTERS
          LJM    CBK         PROCESS CORRECTED BANK ERROR

*         *CBK* RETURNS HERE.

 PCE2     AOM    BNKI        INCREMENT BANK INDEX
          LMM    NBNK
          NJN    PCE1        IF MORE BANKS TO CHECK
          LDN    0
          STM    BNKI        RESET BANKS
          AOM    BRDI        BOARD INDEX
          LMM    NBRDS       NUMBER OF BOARDS INSTALLED
          NJN    PCE1        IF MORE BOARDS
          LDM    MEER        GET MEMORY ERROR OCCURRED FLAG
          NJP    AME1        IF AN ERROR WAS FOUND
          LDM    ME0C        CORRECTED REGISTER LIST
          RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ MAINTENANCE REGISTERS
          CALL   LOG         LOG ERROR
          LJM    AME1        RETURN
 PUE      SPACE  4,10
**        PUE - PROCESS UNCORRECTED ERROR.
*
*         ENTRY  VIA *LJM*.
*                (NBRDS) = BOARD CONFIGURATION.
*
*         EXIT   TO *AME1*.
*
*         CALLS  BRL, CBE, CIF, PBD, UBK, *RMR*.


 PUE      BSS    0           ENTRY
          LDN    0
          STM    MEER        INITIALIZE GLOBAL MEMORY ERROR FLAG FALSE
          STM    BRDI        BOARD INDEX
          STM    BNKI        BANK INDEX
 PUE1     LDN    0
          STM    BDER        BOARD ERROR = FALSE
          STM    BKER        BANK ERROR = FALSE
          LDN    1           SET FLAG FOR UNCORRECTED ERROR
          RJM    CBE         CHECK BANK ERROR
          ZJN    PUE2        IF NO BANK ERROR
          CALL   RMR         READ MAINTENANCE REGISTERS
          LJM    UBK         PROCESS UNCORRECTED MEMORY ERROR

*         *UBK* RETURNS HERE.

 PUE2     AOM    BNKI        INCREMENT BANK INDEX
          LMM    NBNK
          NJN    PUE1        IF MORE BANKS
          LDN    0
          STM    BNKI
          LDM    BKER        GET BANK ERROR FOUND
          NJN    PUE3        IF BANK ERROR
          LJM    PBD         CHECK BOARD ERROR

*         *PBD* RETURNS HERE.

 PUE3     LDN    0
          STM    BNKI        RESET BANK INDEX
          AOM    BRDI        INCREMENT BOARD INDEX
          LMM    NBRDS
          NJP    PUE1        IF MORE BOARDS
          LDM    MEER        ANY MEMORY ERROR FOUND
          NJP    PUE5        IF ERROR ISOLATED
          RJM    CIF         CHECK CENTRAL MEMORY INTERFACE
          NJP    PUE4        IF ERROR FOUND
          LDM    ME0U        UNCORRECTED COMMON REGISTER LIST
          RJM    BRL         BUILD REGISTER LIST

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED MEMORY ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (CONSOLE), LOG (OS), VALID 180.
*         DFT ANALYSIS - OS ACTION = UNCORRECTED MEMORY ERROR.
*                                  = NO OS ACTION (VERSION 4).

          SETDAC DDCL
          SETDAN (EPUN,DAUME)
          SETFLG (BC.CL,BC.FL,BC.FV8)
          SETOSA OSUCM,OSNA
 PUE4     CALL   RMR         READ MAINTENANCE REGISTERS
          CALL   LOG         LOG THE ERROR
 PUE5     LJM    AME1        RETURN
 REW      SPACE  4,10
**        REW - REWRITE AREA WITH SINGLE BIT ERROR.
*
*         THE S0/S0E DOES NOT IDENTIFY THE PRECISE WORD WITH AN ERROR,
*         SO 512 WORDS MUST BE REWRITTEN.  CLEVER.
*
*         ENTRY  (SBER - SBER+1) = ADDRESS BASE.


          ROUTINE  REW

          RJM    DBC         DISABLE BOUNDS CHECKING
          LDML   SBER        SET UP R-REGISTER
          STDL   W2
          LDML   SBER+1
          STDL   W3
          RJM    STA         CALCULATE R-REGISTER
          STDL   W0
          SRD    W0+1
          ADC    1000        CALCULATE LWA+1 TO PROCESS
          STDL   W0+3
          READMR RDATA,,ECMR  CHECK DEGRADE MODE
          LDML   RDATA
          LPN    6
          ZJN    REW1        IF MEMORY NOT DEGRADED
          LCN    2
 REW1     ADN    4           SET ADDRESS INCREMENT
          STD    T0
 REW2     LDN    CM          CLEAR (CM - CM+3)
          RJM    CLR
          LDDL   W0          REWRITE NEXT WORD
          ADC    RR
          RDSL   CM
          LDD    T0          ADVANCE ADDRESS
          RADL   W0
          SBDL   W0+3
          MJN    REW2        IF MORE WORDS TO PROCESS
          RJM    EBC         ENABLE BOUNDS CHECKING
          LJM    REWX        RETURN
 UBK      SPACE  4,10
**        UBK - PROCESS UNCORRECTED BANK ERROR.
*
*         ENTRY  VIA *LJM*.
*
*         EXIT   TO *PUE2*.
*                (BDER) = 0.


 UBK      BSS    0           ENTRY
          LDN    0           CLEAR BOARD ERRORS
          STM    BDER

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED MEMORY ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (CONSOLE), LOG (OS), VALID 180.
*         DFT ANALYSIS - OS ACTION = UNCORRECTED MEMORY ERROR.
*                                  = NO OS ACTION (VERSION 4).

          SETDAC DDCL
          SETDAN (EPUN,DAUME)
          SETFLG (BC.CL,BC.FL,BC.FV8)
          SETOSA OSUCM,OSNA
          CALL   LOG         LOG THE ERROR
          LJM    PUE2        RETURN
*COPYC CTP$DFT_SERVICE_MEMORY_ERROR
          QUAL   *

          OVERFLOW  10000    CHECK FOR OVERFLOW
          OVERLAY  (GENERATE FAULT SYMPTOM CODE)
 OVERVIEW SPACE  4,10
***       FAULT SYMPTOM CODE OVERVIEW.
*
*         THIS OVERLAY EXAMINES THE MAINTENANCE REGISTERS ACCORDING TO AN
*         ALGORITHM DEVELOPED BY CANCDD AND PRODUCES A 12-CHARACTER FAULT
*         SYMPTOM CODE WITH THE FOLLOWING FORMAT:
*
*         *DEMMTRRBBNN *
*
*         D = CHARACTER *D* (TO SIGNIFY DFT-PRODUCED ANALYSIS.)
*         E = *C*/*D* FOR CPU 0/1, *I* FOR IOU, *M* FOR MEMORY, *P* FOR MAP.
*         MM = MODEL NUMBER OF ELEMENT WITH FAILURE (SEE NOTE IN *GFS*).
*         T = REGISTER TYPE (0 OR 8) OF FIRST REGISTER WITH FAILURE DATA.
*         RR = HEX NUMBER OF FIRST REGISTER FOUND WITH ERROR BIT(S) SET.
*         BB = DECIMAL NUMBER OF FIRST ERROR BIT (MSB = BIT 0, LSB = BIT 63).
*         NN = DECIMAL NUMBER OF REGISTERS WITH ERROR BIT(S) SET.
*
*         IF THE DFT ANALYSIS CODE IS AN ENVIRONMENT OR SHORT WARNING THE FAULT
*         SYMPTOM CODE PRODUCED IS:
*
*         *DEMMXXX*
*
*         WHERE XXX IS THE DFT ANALYSIS CODE.
 GSB      SPACE  4,10
**        GSB - GENERATE BLANK SYMPTOM CODE.
*
*         EXIT   FAULT SYMPTOM CODE IN SUPPORTIVE STATUS BUFFER ALL BLANKS.
*
*         USES   CM - CM+3, T1, W0 - W0+3.
*
*         CALLS  IDA.


          ROUTINE  GSB

          LDN    2           SET NUMBER OF CM WORDS TO READ/WRITE
          STD    T1
          LDN    SSBP        GET ADDRESS OF SCRATCH ENTRY
          RJM    IDA
          CRDL   CM
          LDN    3           SKIP HEADER WORDS
          RADL   CM
          LRD    CM+1
          ADC    RR
          CRDL   W0
          LDC    2R          SPACE FILL FIRST PART OF SYMPTOM CODE
          STDL   W0+2
          STDL   W0+3
          LDD    CM          REWRITE FIRST PART OF SYMPTOM CODE
          ADC    RR
          CWDL   W0
          LDC    2R          SPACE FILL SECOND PART OF SYMPTOM CODE
          STDL   W0
          STDL   W0+1
          LDD    CM          REWRITE SECOND PART OF SYMPTOM CODE
          ADC    RR+1
          CWDL   W0
          LJM    GSBX        RETURN
 GIE      SPACE  4,10
**        GIE - GENERATE INTERNAL ERROR FSC.
*
*         ENTRY  5XX AND 6XX CODES ARE HANDLED.


          ROUTINE GIE
          LDM    IOUM
          STD    MD
          LDC    2RDI        IOU ELEMENT IDENTIFIER
          RJM    WFC         WRITE FAULT SYMPTOM
          LJM    GIEX
 GSC      SPACE  4,10
**        GSC - GENERATE FAULT SYMPTOM CODE FOR CPU ERROR.
*
*         ENTRY  SCRATCH MRB CONTAINS LOGGED REGISTERS.


          ROUTINE  GSC

          LDDL   BC+BCDA     GET THE DFT ANALYSIS
          SHN    -BC.ANP
          SBN    EPEN
          MJN    GSC0        IF NOT ENVIRONMENT OR LONG WARN
          LDC    2RDC
          ADM    CPUO
          RJM    WFC         WRITE THE FAULT CODE
          LJM    GSCX

 GSC0     LDN    0           INITIALIZE VALUES
          STM    BITN        INITIALIZE BIT NUMBER OF FIRST ERROR
          STM    REGC        INITIALIZE NUMBER OF REGISTERS WITH ERROR(S)
          STM    REGN        INITIALIZE REGISTER NUMBER WITH FIRST ERROR

*         CHECK FIRST FAILURE CAPTURE REGISTERS (0#2890 - 0#2891).

          LDC    0#2890
          RJM    CAB         CHECK IF ANY ERROR BITS SET
          LDC    0#2891
          RJM    CAB         CHECK IF ANY ERROR BITS SET

*         CHECK ACCUMULATED ERROR REGISTERS (0#2880 - 0#2881).

          LDC    0#2880
          RJM    CAB         CHECK IF ANY ERROR BITS SET
          LDC    0#2881
          RJM    CAB         CHECK IF ANY ERROR BITS SET

*         CHECK DETAILED ERROR REGISTERS.
*         FOR S0, CHECK 0#2090 - 0#20AE.
*         FOR S0E, CHECK 0#2090 - 0#20A7.

          LDC    0#2090      INITIALIZE REGISTER LOOP
          STDL   W0
          LDM    S0EFLG      CHECK MAINFRAME TYPE
          ZJN    GSC1        IF NOT S0E
          LCN    0#20AE-0#20A7
 GSC1     ADC    0#20AE+1
          STDL   W1          SET LAST REGISTER TO SCAN
 GSC2     LDDL   W0          CHECK NEXT REGISTER
          RJM    CAB         CHECK IF ANY ERROR BITS SET
          AODL   W0          ADVANCE REGISTER NUMBER
          LMDL   W1
          NJN    GSC2        IF MORE REGISTERS TO CHECK

*         CHECK CONTROL STORE CORRECTED ERROR REGISTER (0#20C0).

          LDC    0#20C0
          RJM    CAB         CHECK IF ANY ERROR BITS SET

*         COMPLETE GENERATION OF FAULT SYMPTOM CODE.

          LDC    2RDC        SET FAULT SYMPTOM CODE PREFIX
          ADM    CPUO
          RJM    GFS         GENERATE FAULT SYMPTOM CODE
          LJM    GSCX        RETURN
 GSI      SPACE  4,10
**        GSI - GENERATE FAULT SYMPTOM CODE FOR IOU ERROR.
*
*         ENTRY  SCRATCH MRB CONTAINS LOGGED REGISTERS.


          ROUTINE  GSI

          LDDL   BC+BCDA
          SHN    -BC.ANP
          SBN    EPEN
          MJP    GSI0        IF NOT ENVIRONMENT ERROR
          LDC    2RDI
          RJM    WFC         WRITE FAULT CODE
          LJM    GSIX        RETURN

 GSI0     LDN    0           INITIALIZE VALUES
          STM    BITN        INITIALIZE BIT NUMBER OF FIRST ERROR
          STM    BUS0        CLEAR BIT 39 FLAG FOR REGISTERS 90 - 94
          STM    BUS2        CLEAR BIT 39 FLAG FOR REGISTERS A0 - A4
          STM    REGC        INITIALIZE NUMBER OF REGISTERS WITH ERROR(S)
          STM    REGN        INITIALIZE REGISTER NUMBER WITH FIRST ERROR

*         CHECK CLUSTER 0 PP ERROR REGISTERS (0#0090 - 0#0094).
*         IF BIT 32 OR 33 IS SET, REGISTER CONTENTS HAVE MEANING.
*         BIT 39 OF EACH REGISTER IS ALSO EXAMINED FOR LATER USE
*         BY BUS ARBITER ERROR REGISTER CHECKING.

          LDC    0#0090      INITIALIZE REGISTER LOOP
          STDL   W0
 GSI1     LDDL   W0          CHECK NEXT REGISTER
          STDL   RN
          RJM    GMB         READ REGISTER FROM SCRATCH MRB
          ZJN    GSI3        IF REGISTER NOT FOUND
          CRDL   CM
          LDDL   CM+2        CHECK BIT 39 STATUS
          LPC    0#0100      EXTRACT BIT 39 FOR BUS ARBITER CHECKING
          RAM    BUS0
          LDDL   CM+2        CHECK BITS 32 - 33
          LPC    0#C000
          ZJN    GSI3        IF NO ERRORS LOGGED
          LDN    0           SET REGISTER ALREADY READ
          RJM    CAB         CHECK IF ANY ERROR BITS SET
 GSI3     AODL   W0          ADVANCE REGISTER NUMBER
          LMC    0#0094+1
          NJN    GSI1        IF MORE REGISTERS TO CHECK

*         CHECK CLUSTER 0 CHANNEL ERROR REGISTERS (0#00B0 - 0#00B2).
*         ONLY BITS 4 - 15, 20 - 32, 34 - 37, 40 - 46 HAVE MEANING.

          LDC    0#00B0      INITIALIZE REGISTER LOOP
          STDL   W0
 GSI4     LDDL   W0          CHECK NEXT REGISTER
          STDL   RN
          RJM    GMB         READ REGISTER FROM SCRATCH MRB
          ZJN    GSI6        IF REGISTER NOT FOUND
          CRDL   CM
          LDDL   CM          PRESERVE BITS 4 - 15
          LPC    0#0FFF
          STDL   CM
          LDDL   CM+1        PRESERVE BITS 20 - 31
          LPC    0#0FFF
          STDL   CM+1
          LDDL   CM+2        PRESERVE BITS 32, 34 - 37, 40 - 46
          LPC    0#BCFE
          STDL   CM+2
          LDN    0
          STDL   CM+3
*         LDN    0           SET REGISTER ALREADY READ
          RJM    CAB         CHECK IF ANY ERROR BITS SET
 GSI6     AODL   W0          ADVANCE REGISTER NUMBER
          LMC    0#00B2+1
          NJN    GSI4        IF MORE REGISTERS TO CHECK

*         CHECK CLUSTER 2 PP ERROR REGISTERS (0#00A0 - 0#00A4).
*         IF BIT 32 OR 33 IS SET, REGISTER CONTENTS HAVE MEANING.

          LDC    0#00A0      INITIALIZE REGISTER LOOP
          STDL   W0
 GSI7     LDDL   W0          CHECK NEXT REGISTER
          STDL   RN
          RJM    GMB         READ REGISTER FROM SCRATCH MRB
          ZJN    GSI9        IF REGISTER NOT FOUND
          CRDL   CM
          LDDL   CM+2        CHECK BIT 39 STATUS
          LPC    0#0100      EXTRACT BIT 39 FOR BUS ARBITER CHECKING
          RAM    BUS2
          LDDL   CM+2        CHECK BITS 32 - 33
          LPC    0#C000
          ZJN    GSI9        IF NO ERRORS LOGGED
          LDN    0           SET REGISTER ALREADY READ
          RJM    CAB         CHECK IF ANY ERROR BITS SET
 GSI9     AODL   W0          ADVANCE REGISTER NUMBER
          LMC    0#00A4+1
          NJN    GSI7        IF MORE REGISTERS TO CHECK

*         CHECK CLUSTER 2 CHANNEL ERROR REGISTERS (0#00B8 - 0#00BA).
*         ONLY BITS 4 - 15, 20 - 32, 34 - 37, 40 - 46 HAVE MEANING.

          LDC    0#00B8      INITIALIZE REGISTER LOOP
          STDL   W0
 GSI10    LDDL   W0          CHECK NEXT REGISTER
          STDL   RN
          RJM    GMB         READ REGISTER FROM SCRATCH MRB
          ZJN    GSI11       IF REGISTER NOT FOUND
          CRDL   CM
          LDDL   CM          PRESERVE BITS 4 - 15
          LPC    0#0FFF
          STDL   CM
          LDDL   CM+1        PRESERVE BITS 20 - 31
          LPC    0#0FFF
          STDL   CM+1
          LDDL   CM+2        PRESERVE BITS 32, 34 - 37, 40 - 46
          LPC    0#BCFE
          STDL   CM+2
          LDN    0
          STDL   CM+3
*         LDN    0           SET REGISTER ALREADY READ
          RJM    CAB         CHECK IF ANY ERROR BITS SET
 GSI11    AODL   W0          ADVANCE REGISTER NUMBER
          LMC    0#00BA+1
          NJN    GSI10       IF MORE REGISTERS TO CHECK

*         CHECK CHANNEL 15/17 ERROR REGISTER.

          LDC    0#00B7
          RJM    CAB         CHECK IF ANY ERROR BITS SET

*         CHECK CLUSTER 0 BUS ARBITER ERROR REGISTER (0#009A).
*         BITS 9, 11, 12, 25, 27, 28 ALWAYS HAVE MEANING.
*         OTHER BITS HAVE MEANING ONLY IF BIT 39 IS SET IN ONE
*         OR MORE OF REGISTERS 0#0090 - 0#0094.

          LDC    0#009A
          STDL   RN
          RJM    GMB         READ REGISTER FROM SCRATCH MRB
          CRDL   CM
          LDM    BUS0        CHECK IF BIT 39 SET IN REGISTERS 90 - 94
          NJN    GSI12       IF ENTIRE REGISTER HAS MEANING
          LDDL   CM          PRESERVE BITS 9, 11, 12
          LPC    0#0058
          STDL   CM
          LDDL   CM+1        PRESERVE BITS 25, 27, 28
          LPC    0#0058
          STDL   CM+1
          LDN    0
          STDL   CM+2
          STDL   CM+3
 GSI12    LDN    0           SET REGISTER ALREADY READ
          RJM    CAB         CHECK IF ANY ERROR BITS SET

*         CHECK CLUSTER 2 BUS ARBITER ERROR REGISTER (0#00AA).
*         BITS 9, 11, 12, 25, 27, 28 ALWAYS HAVE MEANING.
*         OTHER BITS HAVE MEANING ONLY IF BIT 39 IS SET IN ONE
*         OR MORE OF REGISTERS 0#00A0 - 0#00A4.

          LDC    0#00AA
          STDL   RN
          RJM    GMB         READ REGISTER FROM SCRATCH MRB
          CRDL   CM
          LDM    BUS2        CHECK IF BIT 39 SET IN REGISTERS A0 - A4
          NJN    GSI13       IF ENTIRE REGISTER HAS MEANING
          LDDL   CM          PRESERVE BITS 9, 11, 12
          LPC    0#0058
          STDL   CM
          LDDL   CM+1        PRESERVE BITS 25, 27, 28
          LPC    0#0058
          STDL   CM+1
          LDN    0
          STDL   CM+2
          STDL   CM+3
 GSI13    LDN    0           SET REGISTER ALREADY READ
          RJM    CAB         CHECK IF ANY ERROR BITS SET

*         CHECK CLUSTER 0 ADU ERROR REGISTER (0#009B).
*         ONLY BITS 15, 31, 47 HAVE MEANING.

          LDC    0#009B
          STDL   RN
          RJM    GMB         READ REGISTER FROM SCRATCH MRB
          ZJN    GSI14       IF REGISTER NOT FOUND
          CRDL   CM
          LDDL   CM          PRESERVE BIT 15
          LPN    0#0001
          STDL   CM
          LDDL   CM+1        PRESERVE BIT 31
          LPN    0#0001
          STDL   CM+1
          LDDL   CM+2        PRESERVE BIT 47
          LPN    0#0001
          STDL   CM+2
          LDN    0
          STDL   CM+3
*         LDN    0           SET REGISTER ALREADY READ
          RJM    CAB         CHECK IF ANY ERROR BITS SET

*         CHECK CLUSTER 2 ADU ERROR REGISTER (0#00AB).
*         ONLY BITS 15, 31, 47 HAVE MEANING.

 GSI14    LDC    0#00AB
          STDL   RN
          RJM    GMB         READ REGISTER FROM SCRATCH MRB
          ZJN    GSI15       IF REGISTER NOT FOUND
          CRDL   CM
          LDDL   CM          PRESERVE BIT 15
          LPN    0#0001
          STDL   CM
          LDDL   CM+1        PRESERVE BIT 31
          LPN    0#0001
          STDL   CM+1
          LDDL   CM+2        PRESERVE BIT 47
          LPN    0#0001
          STDL   CM+2
          LDN    0
          STDL   CM+3
*         LDN    0           SET REGISTER ALREADY READ
          RJM    CAB         CHECK IF ANY ERROR BITS SET

*         COMPLETE GENERATION OF FAULT SYMPTOM CODE.

 GSI15    LDC    2RDI        SET FAULT SYMPTOM CODE PREFIX
          RJM    GFS         GENERATE FAULT SYMPTOM CODE
          LJM    GSIX        RETURN
 GSM      SPACE  4,10
**        GSM - GENERATE FAULT SYMPTOM CODE FOR MEMORY ERROR.
*
*         ENTRY  SCRATCH MRB CONTAINS LOGGED REGISTERS.


          ROUTINE  GSM

          LDDL   BC+BCDA
          SHN    -BC.ANP
          SBN    EPEN
          MJP    GSM0        IF NOT ENVIRONMENT ERROR
          LDC    2RDM
          RJM    WFC         WRITE FAULT CODE
          LJM    GSMX        RETURN

 GSM0     LDN    0           INITIALIZE VALUES
          STM    BITN        INITIALIZE BIT NUMBER OF FIRST ERROR
          STM    REGC        INITIALIZE NUMBER OF REGISTERS WITH ERROR(S)
          STM    REGN        INITIALIZE REGISTER NUMBER WITH FIRST ERROR

*         CHECK UNCORRECTED CM INTERFACE BOARD ERROR REGISTER.

          LDC    0#1090
          STDL   RN
          RJM    GMB         READ REGISTER FROM SCRATCH MRB
          CRDL   CM
          LDDL   CM          CHECK BIT 0
          SHN    21-17
          PJN    GSM1        IF NO ERROR LOGGED
          LDN    0           PROCESS REGISTER CONTENTS
          RJM    CAB

*         CHECK UNCORRECTED CM BOARD ERROR REGISTERS.
*         IF BIT 0 = 1, BITS 1 - 15 HAVE MEANING.
*         IF BIT 16 = 1, BITS 17 - 31 HAVE MEANING.

 GSM1     LDN    0           INITIALIZE REGISTER LOOP
          STD    W0
 GSM2     LDML   GSMA,W0     CHECK NEXT REGISTER
          ZJN    GSM6        IF END OF LIST
          STDL   RN
          RJM    GMB         READ REGISTER FROM SCRATCH MRB
          ZJN    GSM5        IF REGISTER NOT FOUND
          CRDL   CM
          LDDL   CM          CHECK BIT 0
          LPC    0#8000
          NJN    GSM3        IF ERRORS LOGGED IN BITS 1 - 15
*         LDN    0           CLEAR BITS 0 - 15
          STDL   CM
 GSM3     LDDL   CM+1        CHECK BIT 16
          LPC    0#8000
          NJN    GSM4        IF ERRORS LOGGED IN BITS 17 - 31
*         LDN    0           CLEAR BITS 16 - 31
          STDL   CM+1
 GSM4     LDN    0           CLEAR UNUSED BITS
          STD    CM+2
          STD    CM+3
*         LDN    0           SET REGISTER ALREADY READ
          RJM    CAB         CHECK IF ANY ERROR BITS SET
 GSM5     AOD    W0          ADVANCE REGISTER LIST INDEX
          UJN    GSM2        LOOP FOR ALL REGISTERS IN LIST

*         CHECK UNCORRECTED CM BANK ERROR REGISTERS (10AX, 10BX, 10CX).
*         IF BIT 16 OF REGISTER 10AX = 1, REGISTERS 10AX, 10BX, 10CX
*         HAVE MEANING.

 GSM6     LDC    0#10A0      INITIALIZE REGISTER LOOP
          STDL   W0
 GSM7     LDDL   W0          CHECK NEXT REGISTER
          STDL   RN
          RJM    GMB         READ REGISTER FROM SCRATCH MRB
          ZJN    GSM9        IF REGISTER NOT FOUND
          CRDL   CM
          LDDL   CM+1        CHECK BIT 16
          LPC    0#8000
          ZJN    GSM9        IF NO ERRORS LOGGED
          LDN    0           SET REGISTER ALREADY READ
          RJM    CAB         CHECK IF ANY ERROR BITS SET
          LDDL   W0          CHECK REGISTER 10BX
          ADN    0#10B0-0#10A0
          RJM    CAB
          LDDL   W0          CHECK REGISTER 10CX
          ADN    0#10C0-0#10A0
          RJM    CAB
 GSM9     AODL   W0          ADVANCE REGISTER NUMBER
          LMC    0#10AF+1
          NJN    GSM7        IF MORE REGISTERS TO CHECK

*         CHECK CORRECTED CM BANK ERROR REGISTERS (10DX, 10EX).
*         IF BIT 16 OF REGISTER 10DX = 1, REGISTERS 10DX, 10EX
*         HAVE MEANING.

          LDC    0#10D0      INITIALIZE REGISTER LOOP
          STDL   W0
 GSM10    LDDL   W0          CHECK NEXT REGISTER
          STDL   RN
          RJM    GMB         READ REGISTER FROM SCRATCH MRB
          ZJN    GSM12       IF REGISTER NOT FOUND
          CRDL   CM
          LDDL   CM+1        CHECK BIT 16
          LPC    0#8000
          ZJN    GSM12       IF NO ERRORS LOGGED
          LDN    0           SET REGISTER ALREADY READ
          RJM    CAB         CHECK IF ANY ERROR BITS SET
          LDDL   W0          CHECK REGISTER 10EX
          ADN    0#10E0-0#10D0
          RJM    CAB
 GSM12    AODL   W0          ADVANCE REGISTER NUMBER
          LMC    0#10DF+1
          NJN    GSM10       IF MORE REGISTERS TO CHECK

*         COMPLETE GENERATION OF FAULT SYMPTOM CODE.

          LDC    2RDM        SET FAULT SYMPTOM CODE PREFIX
          RJM    GFS         GENERATE FAULT SYMPTOM CODE
          LJM    GSMX        RETURN

 GSMA     DATA   0#1091,0#1095,0#1092,0#1096  UNCORRECTED CM BOARD ERRORS
          DATA   0#1093,0#1097,0#1094,0#1098
          DATA   0           END OF LIST
 GSP      SPACE  4,10
**        GSP - GENERATE FAULT SYMPTOM CODE FOR PAGE MAP ERROR.
*
*         ENTRY  SCRATCH MRB CONTAINS LOGGED REGISTERS.


          ROUTINE  GSP

          LDN    0           INITIALIZE VALUES
          STM    BITN        INITIALIZE BIT NUMBER OF FIRST ERROR
          STM    REGC        INITIALIZE NUMBER OF REGISTERS WITH ERROR(S)
          STM    REGN        INITIALIZE REGISTER NUMBER WITH FIRST ERROR

*         CHECK FIRST FAILURE CAPTURE AND ACCUMULATED ERROR REGISTERS.

          LDC    0#309C
          RJM    CAB         CHECK IF ANY ERROR BITS SET
          LDC    0#309D
          RJM    CAB         CHECK IF ANY ERROR BITS SET

*         CHECK DETAILED ERROR REGISTERS (0#3090 - 0#309B).

          LDC    0#3090      INITIALIZE REGISTER LOOP
          STDL   W0
 GSP1     LDDL   W0          CHECK NEXT REGISTER
          RJM    CAB         CHECK IF ANY ERROR BITS SET
          AODL   W0          ADVANCE REGISTER NUMBER
          LMC    0#309B+1
          NJN    GSP1        IF MORE REGISTERS TO CHECK

*         COMPLETE GENERATION OF FAULT SYMPTOM CODE.

          LDC    2RDP        SET FAULT SYMPTOM CODE PREFIX
          RJM    GFS         GENERATE FAULT SYMPTOM CODE
          LJM    GSPX        RETURN
 CAB      SPACE  4,10
**        CAB - CHECK FOR ANY BIT SET IN REGISTER.
*
*         ENTRY  (A) = REGISTER NUMBER TO CHECK.
*                    = 0, IF REGISTER DATA ALREADY PRESENT IN (CM - CM+3).
*
*         EXIT   (RN) = REGISTER NUMBER.
*                (REGC) ADVANCED IF ANY BITS SET IN REGISTER.
*
*         USES   CM - CM+3, T4, T4, T6.
*
*         CALLS  GMB, RRB.


 CAB      SUBR               ENTRY/EXIT
          ZJN    CAB1        IF DATA ALREADY PRESENT
          STDL   RN          SAVE REGISTER NUMBER
          RJM    GMB         READ REGISTER FROM SCRATCH MRB
          ZJN    CABX        IF REGISTER NOT PRESET IN SCRATCH MRB
          CRDL   CM
 CAB1     LDDL   CM+0        CHECK IF ANY BITS SET
          ADDL   CM+1
          ADDL   CM+2
          ADDL   CM+3
          ZJN    CABX        IF NO ERROR BITS SET IN REGISTER
          AOM    REGC        ADVANCE COUNT OF REGISTERS WITH ERROR(S)
          LDN    0           INITIALIZE PP WORD OFFSET
          STD    T4
          STD    T5          INITIALIZE BIT NUMBER
          LDC    0#8000      INITIALIZE MASK
          STDL   T6
 CAB2     LDML   CM,T4       GET APPROPRIATE PP WORD
          LPDL   T6          CHECK NEXT BIT
          ZJN    CAB3        IF BIT NOT SET
          RJM    RRB         RECORD REGISTER AND BIT NUMBER
 CAB3     AOD    T5          ADVANCE BIT NUMBER
          LDDL   T6          SHIFT MASK
          SHN    -1
          STDL   T6
          NJN    CAB2        IF MORE BITS TO CHECK IN CURRENT PP WORD
          LDC    0#8000      REINITIALIZE MASK
          STDL   T6
          AOD    T4          ADVANCE TO NEXT PP WORD
          LMN    4
          NJN    CAB2        IF MORE PP WORDS TO CHECK
          LJM    CABX        RETURN
 WFC      SPACE  4,10
**        WFC - WRITE FAULT SYMPTOM CODE.
*
*         ENTRY  (A) = TWO CHARACTER ELEMENT IDENTIFIER.
*                (BC - BC+3) = BUFFER CONTROL WORD.
*                (RTP1) = 0 LOG TO SUPPORTIVE STATUS
*                       = 1 LOG TO NON REGISTER STATUS
*         USES   T1, CM - CM+3.
*
*         CALLS  CDA, CSD, IDA.


 WFC      SUBR               ENTRY/EXIT
          STDL   T1          SAVE ELEMENT IDENTIFIER
          LDN    3
          STM    WFCC        NUMBER OF HEADER WORDS FOR SUPPORTIVE STATUS
          LDM    RTP1        FLAG TO LOG TO SUPPORTIVE STATUS OR NON REGISTER STATUS
          ZJN    WFC1        IF TO LOG TO SUPPORTIVE STATUS
          AOM    WFCC        NON REGISTER STATUS HAS 1 MORE HEADER WORD THAN SUPPORTIVE
          LDN    NRSP        ADDRESS OF SCRATCH NON REGISTER STATUS BUFFER
          UJN    WFC2

*         READ FIRST WORD OF FAULT SYMPTOM CODE TO PRESERVE FIRST TWO BYTES.

 WFC1     LDN    SSBP        GET ADDRESS OF SCRATCH BUFFER
 WFC2     RJM    IDA
          CRDL   CM
          LDM    WFCC        SKIP HEADER WORDS
          RADL   CM
          LRD    CM+1
          ADC    RR
          CRML   WFCA,ON
          LDDL   T1          SET ELEMENT IDENTIFIER
          STML   WFCB

*         SET MODEL NUMBER.

          LDD    MD
          RJM    CDA         CONVERT TWO DIGITS TO ASCII
          STML   WFCB+1

*         SET SYMPTOM CODE.

          LDDL   BC+BCDA     DFT ANALYSIS
          SHN    -10
          LPN    0#F
          STD    T1
          LMN    4           4XX INTERNAL ERROR
          ZJN    WFC2.5      IF INTERNAL ERROR
          LDD    T1
          LMN    5           5XX INTERNAL ERROR
          ZJN    WFC2.5      IF INTERNAL ERROR
          LDD    T1
          LMN    6           6XX CODE
          ZJN    WFC2.5      IF INTERNAL ERROR
          UJN    WFC3

 WFC2.5   LDML   WFCB+2
          LPC    0#FF00
          STML   WFCB+2
          LDDL   BC+BCDA
          SHN    -10
          LPN    0#F
          RJM    CSD         CONVERT SINGLE DIGIT
          LMML   WFCB+2
          STML   WFCB+2
          LDDL   BC+BCDA
          LPC    0#FF
          RJM    CDA         CONVERT DIGITS TO ASCII
          STML   WFCB+3
          UJP    WFC4

 WFC3     LDDL   BC+BCDA     DFT ANALYSIS
          SHN    -4          ISOLATE FIRST TWO CHARACTERS
          LPC    377
          RJM    CDA         CONVERT TWO DIGITS TO ASCII
          STML   WFCB+2
          LDD    BC+BCDA     ISOLATE LAST CHARACTER
          LPN    17
          RJM    CSD         CONVERT SINGLE DIGIT TO ASCII
          SHN    10
          LMC    1R
          STML   WFCB+3

*         WRITE FAULT SYMPTOM CODE TO SCRATCH SUPPORTIVE STATUS BUFFER.

 WFC4     LDN    2           SET NUMBER OF CM WORDS TO WRITE
          STD    T1
          LDDL   CM          LOAD ADDRESS OF SCRATCH BUFFER
          ADC    RR
          CWML   WFCA,T1     WRITE TO SCRATCH BUFFER
          LJM    WFCX        RETURN

 WFCC     BSS    1
 WFCA     BSS    2           RESERVED AREA OF FAULT SYMPTOM CODE
 WFCB     DATA   12HDEMMZCC
 CDD      SPACE  4,10
***       CDD - CONVERT VALUE TO TWO DECIMAL ASCII DIGITS.
*
*         ADAPTED FROM NOS COMMON DECK *COMPCDD*.
*
*         ENTRY  (A) = VALUE TO BE CONVERTED.
*
*         EXIT   (A) = DECIMAL ASCII EQUIVALENT, IF NO ERROR.
*                    = 2R** IF VALUE OUTSIDE RANGE OF 00 - 99.


 CDD3     LDC    2R**        SET (A) = RANGE ERROR

 CDD      SUBR               ENTRY/EXIT
          MJN    CDD3        IF VALUE NEGATIVE
          STD    T0
          SBK    99D+1       CHECK RANGE
          PJN    CDD3        IF VALUE GREATER THAN 99
          LDC    2R00+10D    INITIALIZE ASSEMBLY
          STML   CDDA
 CDD1     LCN    10D         DECREMENT ANOTHER 10
          RAD    T0
          MJN    CDD2        IF REMAINDER .LT. 10
          LDC    1S8         ADVANCE TENS DIGIT
          RAML   CDDA
          UJN    CDD1        LOOP

 CDD2     ADC    2R00+10D    ASSEMBLE TENS AND ONES DIGITS
 CDDA     EQU    *-1
          UJN    CDDX        RETURN
 GFS      SPACE  4,10
**        GFS - GENERATE FAULT SYMPTOM CODE.
*
*         ENTRY  (A) = TWO CHARACTER FAULT SYMPTOM CODE PREFIX.
*                (BITN) = FIRST ERROR BIT SET.
*                (REGC) = NUMBER OF REGISTERS WITH ERROR BIT(S) SET.
*                (REGN) = FIRST REGISTER WITH ERROR BIT(S) SET.
*
*         EXIT   FAULT SYMPTOM CODE WRITTEN TO SUPPORTIVE STATUS BUFFER.
*
*         USES   CM - CM+3, T0, T2, W0 - W0+7.
*
*         CALLS  CDA, CDD, IDA.
*
*         NOTE   SINCE S0/S0E USE THE SAME MODEL NUMBER FOR ALL ELEMENTS,
*                THE IOU MODEL NUMBER WILL BE USED REGARDLESS OF ELEMENT.


 GFS      SUBR               ENTRY/EXIT
          STML   GFSA        SAVE FAULT SYMPTOM CODE PREFIX
          LDN    2           SET NUMBER OF CM WORDS TO READ/WRITE
          STD    T2
          LDN    SSBP        GET ADDRESS OF SCRATCH ENTRY
          RJM    IDA
          CRDL   CM
          LDN    3           SKIP HEADER WORDS
          RADL   CM
          LRD    CM+1
          ADC    RR
          CRML   W0,T2       READ EXISTING WORDS

*         ASSEMBLE FAULT SYMPTOM CODE IN (W0 - W0+7).

          LDML   GFSA        SET FAULT SYMPTOM CODE PREFIX
          STDL   W0+2
          LDM    IOUM        SET MODEL NUMBER
          RJM    CDA         CONVERT TWO HEX DIGITS TO ASCII
          STDL   W0+3
          LDML   REGN        SET REGISTER TYPE AND UPPER HEX DIGIT OF ERROR REG.
          SHN    -4
          RJM    CDA         CONVERT TWO HEX DIGITS TO ASCII
          STDL   W0+4
          LDML   REGN        SET LOWER HEX DIGIT OF ERROR REGISTER
          RJM    CDA         CONVERT TWO HEX DIGITS TO ASCII
          LPC    0#FF
          SHN    10          POSITION LOWER HEX DIGIT OF ERROR REGISTER
          STDL   W0+5
          LDM    BITN        SET BIT NUMBER
          RJM    CDD         CONVERT TWO DECIMAL DIGITS TO ASCII
          STDL   T0          SAVE CONVERTED VALUE
          SHN    -10
          RADL   W0+5        MERGE WITH LOWER DIGIT OF ERROR REGISTER
          LDDL   T0          STORE LOWER DIGIT OF BIT NUMBER
          LPC    0#FF
          SHN    10
          STDL   W0+6
          LDM    REGC        SET NUMBER OF REGISTERS WITH ERRORS
          RJM    CDD         CONVERT TWO DECIMAL DIGITS TO ASCII
          STDL   T0          SAVE CONVERTED VALUE
          SHN    -10
          RADL   W0+6        MERGE WITH LOWER DIGIT OF BIT NUMBER
          LDDL   T0          STORE LOWER DIGIT OF NUMBER OF REGISTERS
          LPC    0#FF
          SHN    10
          ADC    1R          BLANK FILL LAST FIELD
          STDL   W0+7

*         WRITE COMPLETED FAULT SYMPTOM CODE TO SUPPORTIVE STATUS BUFFER.

          LDD    CM          REWRITE SUPPORTIVE STATUS BUFFER ENTRY
          ADC    RR
          CWML   W0,T2
          LJM    GFSX        RETURN

 GFSA     BSS    1           SAVE AREA FOR FAULT SYMPTOM CODE PREFIX
 GMB      SPACE  4,10
**        GMB - GET MAINTENANCE REGISTER FROM SCRATCH BUFFER.
*
*         THIS ROUTINE IS A MODIFIED VERSION OF *FMB* WHICH EXAMINES ALL
*         16 BITS OF THE REGISTER HEADER AND RETURNS (A) = 0 IF THE
*         REGISTER IS NOT FOUND INSTEAD OF REPORTING A 607 ERROR.
*
*         ENTRY  (A) = MAINTENANCE REGISTER TO FIND.
*
*         EXIT   (A) AND (R) SET FOR ACCESS.
*                (A) = 0 IF REGISTER NOT FOUND IN SCRATCH MRB.
*
*         CALLS  IMB.


 GMB      SUBR               ENTRY/EXIT
          STML   GMBB        SAVE REGISTER TO BE FOUND
          LDN    0           INITIALIZE FOR FIRST REGISTER GROUP
          STM    GMBC

*         READ NEXT HEADER WORD.

 GMB1     RJM    IMB         READ HEADER WORD
          CRML   GMBD,ON
          LDC    GMBD        INITIALIZE SEARCH LOOP
          STM    GMBA

*         CHECK IF REGISTER IS IN THIS REGISTER GROUP.

 GMB2     LDML   **          CHECK NEXT REGISTER DESCRIPTOR
 GMBA     EQU    *-1         (HEADER BYTE TO CHECK)
          LMML   GMBB
          ZJN    GMB3        IF REGISTER FOUND
          AOM    GMBA
          LMC    GMBD+4
          NJN    GMB2        IF MORE BYTES IN CURRENT HEADER WORD
          LDN    5           ADVANCE TO NEXT HEADER WORD
          RAM    GMBC
          SBM    LBUF        SUBTRACT LENGTH OF BUFFER FROM PRESENT LOCATION
          ZJN    GMBX        IF AT END OF BUFFER
          LDM    GMBC
          UJN    GMB1        LOOP

*         SET RETURN PARAMETERS FOR REGISTER ADDRESS IN GROUP.

 GMB3     LDM    GMBC        SET OFFSET FOR REGISTER GROUP
          ADN    1
          ADM    GMBA        INCLUDE WORD OFFSET IN FOUR REGISTER GROUP
          ADC    -GMBD
          RJM    IMB         SET (A) AND (R) FOR ACCESS
          LJM    GMBX        RETURN

 GMBB     BSS    1           REGISTER TO LOCATE
 GMBC     BSS    1           HEADER ADDRESS IN BUFFER
 GMBD     BSS    4           HEADER WORD BUFFER
 RRB      SPACE  4,10
**        RRB - RECORD REGISTER NUMBER AND BIT NUMBER.
*
*         ENTRY  (T5) = BIT NUMBER.
*                (RN) = REGISTER NUMBER.
*
*         EXIT   (REGN) = REGISTER NUMBER, IF NOT PREVIOUSLY SET.
*                (BITN) = BIT NUMBER, IF NOT PREVIOUSLY SET.


 RRB      SUBR               ENTRY/EXIT
          LDM    REGN        CHECK FOR PREVIOUS ERROR BIT
          NJN    RRBX        IF PREVIOUS ERROR RECORDED
          LDDL   RN          SAVE REGISTER NUMBER
          STML   REGN
          LDD    T5          SAVE BIT NUMBER
          STM    BITN
          UJN    RRBX        RETURN
 COMMON   SPACE  4,10
*         COMMON DECKS.


*COPY     CTP$CONVERT_DIGITS_TO_ASCII

          QUAL   *

          OVERFLOW  10000    CHECK FOR OVERFLOW
          OVERLAY  (LOG ERROR TO BUFFER CONTROL WORDS)
*COPYC CTP$DFT_LOG_ERROR
*COPY CTP$DFT_INCREMENT_ERROR_COUNT
*COPY  CTP$DFT_FIND_WARNING_IN_NRSB
*COPY CTP$DFT_FIND_CONTROL_WORD
*COPY CTP$DFT_LOG_ERROR_CHECK_MATCH
*COPYC CTP$DFT_LOG_PACKET_TO_CONSOLE
*COPY  CTP$DFT_CHECK_PKTS_FOR_S0
*COPY CTC$DFT_ELEMENT_CONVERSIONS
*COPY CTP$DFT_ZERO_SUPPORTIVE_STATUS
 ABL      SPACE  4,10
**        ABL - ADJUST BUFFER LENGTH.
*
*         THIS IS A DUMMY ROUTINE ON S0/S0E.


 ABL      SUBR               ENTRY/EXIT
          UJN    ABLX        RETURN
 URC      SPACE  4,10
**        URC - UPDATE RETRY COUNTERS.
*
*         THIS IS A DUMMY ROUTINE ON S0/S0E.


 URC      SUBR               ENTRY/EXIT
          UJN    URCX        RETURN
          QUAL   *

          OVERFLOW  10000    CHECK FOR OVERFLOW
          OVERLAY  (READ MAINTENANCE REGISTERS)
          QUAL   *           SO THAT OTHER OVERLAYS MAY ACCESS
 RLCIE0   SPACE  4,10
**        RLCIE0 - REGISTER LIST FOR CORRECTED IOU ERROR - CLUSTER 0.
*
*         NOTE - AT THIS TIME THE CORRECTED/UNCORRECTED LISTS MATCH.


 RLCIE0   REGLST (10,00,12,20,21,22,23,24,2A,2B,40,41,50,51,52,53,54
,,70,71,72,73,74,90,91,92,93,94,9A,9B,B0,B1,B2,B7)
 RLCIE2   SPACE  4,10
**        RLCIE2 - REGISTER LIST FOR CORRECTED IOU ERROR - CLUSTERS 0/2.
*
*         NOTE - AT THIS TIME THE CORRECTED/UNCORRECTED LISTS MATCH.


 RLCIE2   REGLST (10,00,12,20,21,22,23,24,2A,2B,40,41,42,50,51,52,53,54
,,70,71,72,73,74,30,31,32,33,34,3A,3B,48,49,4A,60,61,62,63,64,80,81,82
,,83,84,90,91,92,93,94,9A,9B,B0,B1,B2,B7,A0,A1,A2,A3,A4,AA,AB,B8,B9,BA)
 RLCME    SPACE  4,10
**        RLCME - REGISTER LIST FOR CORRECTED MEMORY ERROR.
*
*         ADDITIONAL REGISTERS WILL BE LOGGED FOR THE SPECIFIC ERROR.


 RLCME    REGLST (10,00,12,58,20)
 RLCPE    SPACE  4,10
**        RLCPE - REGISTER LIST FOR CORRECTED S0 PROCESSOR ERROR.


 RLCPE    REGLST (10,00,12,20,21,22,23,24,25,26,27,28,29,2A,2B,2C,2D,2E
,,2F,30,31,32,33,34,90,91,92,93,94,95,96,97,98,99,9A,9B,9C,9D,9E,9F
,,A0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,C0,880,881,890,891)
 RLCPE    SPACE  4,10
**        RLCPE - REGISTER LIST FOR CORRECTED S0E PROCESSOR ERROR.


          QUAL   S0E
 RLCPE    REGLST (10,00,12,20,21,22,23,24,25,26,27,28,29,2A,2B,2C,2D,2E
,,2F,90,91,92,93,94,95,96,97,98,99,9A,9B,9C,9D,9E,9F,A0,A1,A2,A3,A4,A5
,,A6,A7,C0,880,881,890,891)
          QUAL   *
 RLUIE0   SPACE  4,10
**        RLUIE0 - REGISTER LIST FOR UNCORRECTED IOU ERROR - CLUSTER 0.
*
*         NOTE - AT THIS TIME THE CORRECTED/UNCORRECTED LISTS MATCH.


 RLUIE0   REGLST (10,00,12,20,21,22,23,24,2A,2B,40,41,50,51,52,53,54
,,70,71,72,73,74,90,91,92,93,94,9A,9B,B0,B1,B2,B7)
 RLUIE2   SPACE  4,10
**        RLUIE2 - REGISTER LIST FOR UNCORRECTED IOU ERROR - CLUSTERS 0/2.
*
*         NOTE - AT THIS TIME THE CORRECTED/UNCORRECTED LISTS MATCH.


 RLUIE2   REGLST (10,00,12,20,21,22,23,24,2A,2B,40,41,42,50,51,52,53,54
,,70,71,72,73,74,30,31,32,33,34,3A,3B,48,49,4A,60,61,62,63,64,80,81,82
,,83,84,90,91,92,93,94,9A,9B,B0,B1,B2,B7,A0,A1,A2,A3,A4,AA,AB,B8,B9,BA)
 RLUME    SPACE  4,10
**        RLUME - REGISTER LIST FOR UNCORRECTED MEMORY ERROR.
*
*         ADDITIONAL REGISTERS WILL BE LOGGED FOR THE SPECIFIC ERROR.


 RLUME    REGLST (10,00,12,58,20,90)
 RLUPE    SPACE  4,10
**        RLUPE - REGISTER LIST FOR UNCORRECTED S0 PROCESSOR ERROR.


 RLUPE    REGLST (10,00,12,20,21,22,23,24,25,26,27,28,29,2A,2B,2C,2D,2E
,,2F,30,31,32,33,34,90,91,92,93,94,95,96,97,98,99,9A,9B,9C,9D,9E,9F
,,A0,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,880,881,890,891)
 RLUPE    SPACE  4,10
**        RLUPE - S0E REGISTER LIST FOR UNCORRECTED PROCESSOR ERROR.


          QUAL   S0E
 RLUPE    REGLST (10,00,12,20,21,22,23,24,25,26,27,28,29,2A,2B,2C,2D,2E
,,2F,90,91,92,93,94,95,96,97,98,99,9A,9B,9C,9D,9E,9F,A0,A2,A3,A3,A4,A5
,,A6,A7,880,881,890,891)
          QUAL   *
 PM0      SPACE  4,10
**        S0/S0E PAGE MAP *DEC* REGISTERS.


 PM0      REGLST (90,91,92,93,94,95,96,97,98,99,9A,9B,9C,9D)
 PPM0     SPACE  4,10
**        S0/S0E PROCESSOR PAGE MAP REGISTERS.


 PPM0     REGLST (00,881,891)
 PD0      SPACE  4,10
**        S0/S0E PAGE MAP DEC REGISTERS.


 PD0      REGLST (20,21,22,23,24,25,26,27)
 MPMD0    SPACE  4,10
**        MEMORY PAGE MAP REGISTERS.


 MPMD0    REGLST (10,0,12)
 S0MCV    SPACE  4,10
**        S0/S0E MEMORY CORRECTED ERROR REGISTER LIST - VARIABLE REGISTERS.
*
*         THE EXACT REGISTERS LOGGED DEPEND ON THE BOARD/BANK INVOLVED.
*         THE FORMAT IS MC00 FOR BOARD 0 BANK 0, MC01 FOR BOARD 0 BANK 1, ETC.


 MC00     REGLST (21,25,30,60,D0,E0)
          SPACE  4,10
 MC01     REGLST (21,25,31,61,D1,E1)
          SPACE  4,10
 MC02     REGLST (21,25,32,62,D2,E2)
          SPACE  4,10
 MC03     REGLST (21,25,33,63,D3,E3)
          SPACE  4,10
 MC10     REGLST (22,26,34,64,D4,E4)
          SPACE  4,10
 MC11     REGLST (22,26,35,65,D5,E5)
          SPACE  4,10
 MC12     REGLST (22,26,36,66,D6,E6)
          SPACE  4,10
 MC13     REGLST (22,26,37,67,D7,E7)
          SPACE  4,10
 MC20     REGLST (23,27,38,68,D8,E8)
          SPACE  4,10
 MC21     REGLST (23,27,39,69,D9,E9)
          SPACE  4,10
 MC22     REGLST (23,27,3A,6A,DA,EA)
          SPACE  4,10
 MC23     REGLST (23,27,3B,6B,DB,EB)
          SPACE  4,10
 MC30     REGLST (24,28,3C,6C,DC,EC)
          SPACE  4,10
 MC31     REGLST (24,28,3D,6D,DD,ED)
          SPACE  4,10
 MC32     REGLST (24,28,3E,6E,DE,EE)
          SPACE  4,10
 MC33     REGLST (24,28,3F,6F,DF,EF)
          SPACE  4,10
**        S0/S0E MEMORY UNCORRECTED BOARD LEVEL ERROR REGISTER LISTS.


 MUB0     REGLST (21,25,30,31,32,33,60,61,62,63,91,95,A0,A1,A2,A3,B0
,,B1,B2,B3,C0,C1,C2,C3)
          SPACE  4,10
 MUB1     REGLST (22,26,34,35,36,37,64,65,66,67,92,96,A4,A5,A6,A7,B4
,,B5,B6,B7,C4,C5,C6,C7)
          SPACE  4,10
 MUB2     REGLST (23,27,38,39,3A,3B,68,69,6A,6B,93,97,A8,A9,AA,AB,B8
,,B9,BA,BB,C8,C9,CA,CB)
          SPACE  4,10
 MUB3     REGLST (24,28,3C,3D,3E,3F,6C,6D,6E,6F,94,98,AC,AD,AE,AF,BC
,,BD,BE,BF,CC,CD,CE,CF)
 S0MUV    SPACE  4,10
**        S0/S0E MEMORY UNCORRECTED ERROR REGISTER LIST - VARIABLE REGISTERS.
*
*         THE EXACT REGISTERS LOGGED DEPEND ON THE BOARD/BANK INVOLVED.
*         THE FORMAT IS MU00 FOR BOARD 0 BANK 0, MU01 FOR BOARD 0 BANK 1, ETC.


 MU00     REGLST (21,25,30,60,91,95,A0,B0,C0)
          SPACE  4,10
 MU01     REGLST (21,25,31,61,91,95,A1,B1,C1)
          SPACE  4,10
 MU02     REGLST (21,25,32,62,91,95,A2,B2,C2)
          SPACE  4,10
 MU03     REGLST (21,25,33,63,91,95,A3,B3,C3)
          SPACE  4,10
 MU10     REGLST (22,26,34,64,92,96,A4,B4,C4)
          SPACE  4,10
 MU11     REGLST (22,26,35,65,92,96,A5,B5,C5)
          SPACE  4,10
 MU12     REGLST (22,26,36,66,92,96,A6,B6,C6)
          SPACE  4,10
 MU13     REGLST (22,26,37,67,92,96,A7,B7,C7)
          SPACE  4,10
 MU20     REGLST (23,27,38,68,93,97,A8,B8,C8)
          SPACE  4,10
 MU21     REGLST (23,27,39,69,93,97,A9,B9,C9)
          SPACE  4,10
 MU22     REGLST (23,27,3A,6A,93,97,AA,BA,CA)
          SPACE  4,10
 MU23     REGLST (23,27,3B,6B,93,97,AB,BB,CB)
          SPACE  4,10
 MU30     REGLST (24,28,3C,6C,94,98,AC,BC,CC)
          SPACE  4,10
 MU31     REGLST (24,28,3D,6D,94,98,AD,BD,CD)
          SPACE  4,10
 MU32     REGLST (24,28,3E,6E,94,98,AE,BE,CE)
          SPACE  4,10
 MU33     REGLST (24,28,3F,6F,94,98,AF,BF,CF)

*COPYC CTP$DFT_READ_MAINTENANCE_REGS
 ZSS      SPACE  4,10
**        ZSS - ZERO SUPPORTIVE STATUS.
*
*         NOTE   THIS ROUTINE IS INOPERATIVE ON A CYBER 180-930 SERIES.


 ZSS      SUBR               ENTRY/EXIT
          UJN    ZSSX        RETURN

          OVERFLOW  10000    CHECK FOR OVERFLOW
          OVERLAY  (PROCESSOR PRIMITIVES)
*COPY CTP$DFT_PROCESSOR_PRIMITIVES
*         THE FOLLOWING ROUTINES ARE STUBS BECAUSE THEY ARE
*         NOT NEEDED ON S0/S0E.

          ROUTINE  STRBTS

          LJM    STRBTSX     RETURN


 CLRBTS   SUBR               ENTRY/EXIT
          UJN    CLRBTSX     RETURN
 DIP      SPACE  4,10
**        DIP - DISABLE MEMORY PORT FOR PROCESSOR WITH FATAL ERROR.
*
*         ENTRY  (HBUF) = PROCESSOR INFORMATION.
*
*         NOTE   THIS ROUTINE IS IDENTICAL TO *DMP* EXCEPT THAT THE
*                PROCESSOR IS NOT MASTER CLEARED.


          ROUTINE  DIP

          LOCKMR SET         ACQUIRE INTERLOCK
          LDM    S0EFLG      CHECK CPU TYPE
          NJP    DIP1        IF S0E

*         DISABLE MEMORY PORT FOR S0 PROCESSOR.

          READMR RDATA,CMCC,ECMR  READ MEMORY ENVIRONMENT CONTROL
          LDM    RDATA       SET BITS 3, 4
          LPC    0#E7
          LMN    0#18
          STM    RDATA
          WRITMR RDATA,CMCC  REWRITE *EC* REGISTER
          LJM    DIP2        RELEASE INTERLOCK AND RETURN

*         DISABLE PAGE MAP PORT FOR S0E PROCESSOR.

 DIP1     LDM    HBUF+CPRPC  DETERMINE CPU NUMBER
          LPN    1
          STD    T1
          READMR RDATA,S0PMC,S0PPMC  READ PAGE MAP CONTROL REGISTER
          LDM    RDATA+1     SET BIT 8 OR 9 DEPENDING ON CPU NUMBER
          LPML   DIPA,T1
          LMM    DIPB,T1
          STM    RDATA+1
          WRITMR RDATA,S0PMC REWRITE PAGE MAP CONTROL REGISTER

*         COMMON EXIT.

 DIP2     LOCKMR CLEAR       RELEASE INTERLOCK
          LJM    DIPX        RETURN

 DIPA     CON    0#7F,0#BF   CLEAR CPU PORT DISABLE BIT MASK
 DIPB     CON    0#80,0#40   SET CPU PORT DISABLE BIT MASK
 DMP      SPACE  4,10
**        DMP - DISABLE MEMORY PORT.
*
*         ENTRY  (HBUF) = PROCESSOR INFORMATION.


          ROUTINE  DMP

          LOCKMR SET         ACQUIRE INTERLOCK
          LDM    S0EFLG      CHECK CPU TYPE
          NJP    DMP1        IF S0E

*         DISABLE MEMORY PORT FOR S0 PROCESSOR.

          LDDL   EC          SAVE REGISTER VALUE
          STDL   W0
          LDN    ECMR        *READMR RDATA,CMCC,ECMR*
          STDL   RN
          LDML   CMCC
          RJM    RMR         READ MAINTENANCE REGISTER
          LDM    RDATA       SET BITS 3, 4
          LPC    0#E7
          LMN    0#18
          STM    RDATA
          WRITMR RDATA       REWRITE *EC* REGISTER
          LDDL   W0          RESTORE *EC* DIRECT CELL
          STDL   EC
          LJM    DMP2        RELEASE INTERLOCK AND RETURN

*         DISABLE PAGE MAP PORT FOR S0E PROCESSOR.

 DMP1     LDM    HBUF+CPRPC  DETERMINE CPU NUMBER
          LPN    1
          STD    T1
          READMR RDATA,S0PMC,S0PPMC  READ PAGE MAP CONTROL REGISTER
          LDM    RDATA+1     SET BIT 8 OR 9 DEPENDING ON CPU NUMBER
          LPML   DMPA,T1
          LMM    DMPB,T1
          STM    RDATA+1
          WRITMR RDATA,S0PMC REWRITE PAGE MAP CONTROL REGISTER

*         COMMON EXIT.

 DMP2     FUNCMR HBUF+CPRPC,MRMC  MASTER CLEAR PROCESSOR
          LOCKMR CLEAR       RELEASE INTERLOCK
          LJM    DMPX        RETURN

 DMPA     CON    0#7F,0#BF   CLEAR CPU PORT DISABLE BIT MASK
 DMPB     CON    0#80,0#40   SET CPU PORT DISABLE BIT MASK
 EMP      SPACE  4,10
**        EMP - ENABLE MEMORY PORT.
*
*         ENTRY  (HBUF) = PROCESSOR INFORMATION.


          ROUTINE  EMP

          LOCKMR SET         ACQUIRE INTERLOCK
          LDM    S0EFLG      CHECK CPU TYPE
          NJP    EMP1        IF S0E

*         ENABLE MEMORY PORT FOR S0 PROCESSOR.

          LDDL   EC          SAVE REGISTER VALUE
          STDL   W0
          LDN    ECMR        *READMR RDATA,CMCC,ECMR*
          STDL   RN
          LDML   CMCC
          RJM    RMR         READ MAINTENANCE REGISTER
          LDM    RDATA       CLEAR BITS 3, 4
          LPC    0#E7
          STM    RDATA
          FUNCMR HBUF+CPRPC,MRMC   MASTER CLEAR THE PROCESSOR
          WRITMR RDATA       REWRITE *EC* REGISTER
          LDDL   W0          RESTORE *EC* DIRECT CELL
          STDL   EC
          LJM    EMP2        RELEASE INTERLOCK AND RETURN

*         ENABLE PAGE MAP PORT FOR S0E PROCESSOR.

 EMP1     LDM    HBUF+CPRPC  DETERMINE CPU NUMBER
          LPN    1
          STD    T1
          READMR RDATA,S0PMC,S0PPMC  READ PAGE MAP CONTROL REGISTER
          LDM    RDATA+1     CLEAR BIT 8 OR 9 DEPENDING ON CPU NUMBER
          LPML   EMPA,T1
          STM    RDATA+1
          FUNCMR HBUF+CPRPC,MRMC   MASTER CLEAR PROCESSOR
          WRITMR RDATA,S0PMC REWRITE PAGE MAP CONTROL REGISTER

*         COMMON EXIT.

 EMP2     LOCKMR CLEAR       RELEASE INTERLOCK
          LJM    EMPX        RETURN

 EMPA     CON    0#7F,0#BF   CLEAR CPU PORT DISABLE BIT MASK
 ENP      SPACE  4,10
**        ENP - ENABLE MEMORY PORT.
*
*         ENTRY  (HBUF) = PROCESSOR INFORMATION.
*
*         NOTE   THIS ROUTINE CONTAINS CODE FOR THE S0E WHICH IS SIMILAR TO THE
*                CODE IN *EMP* EXCEPT THAT THE PROCESSOR IS NOT MASTERCLEARED.
*                THIS ROUTINE SHOULD BE EXECUTED ON AN S0E MAINFRAME ONLY SINCE
*                IT DOES NOT CONTAIN CODE TO CORRECTLY ENABLE THE PORT ON AN S0.


          ROUTINE  ENP

          LOCKMR SET         ACQUIRE INTERLOCK

*         ENABLE PAGE MAP PORT FOR S0E PROCESSOR.

          LDM    HBUF+CPRPC  DETERMINE CPU NUMBER
          LPN    1
          STD    T1
          READMR RDATA,S0PMC,S0PPMC  READ PAGE MAP CONTROL REGISTER
          LDM    RDATA+1     CLEAR BIT 8 OR 9 DEPENDING ON CPU NUMBER
          LPML   ENPA,T1
          STM    RDATA+1
          WRITMR RDATA,S0PMC REWRITE PAGE MAP CONTROL REGISTER
          LOCKMR CLEAR       RELEASE INTERLOCK
          LJM    ENPX        RETURN

 ENPA     CON    0#7F,0#BF   CLEAR CPU PORT DISABLE BIT MASK

          OVERFLOW  10000    CHECK FOR OVERFLOW
          OVERLAY  (MASSAGE CPU REGISTERS)
*COPY CTP$DFT_MASSAGE_CPU_REGISTERS

          OVERFLOW  10000    CHECK FOR OVERFLOW
          OVERLAY  (CLEAR ERRORS)
 CLE      SPACE  4,10
**        CLE - CLEAR ERRORS.
*
*         EXIT   ALL REGISTERS NECESSARY WILL BE CLEARED OF ERRORS.


          ROUTINE  CLE

          LDM    HBUF+HDRPC
          STD    EC
          FUNCMR ,MRCE       CLEAR ERRORS FROM PAGE MAP REGISTERS
          LJM    CLEX        RETURN
 CPE      SPACE  4,10
**        CPE - CLEAR PAGE MAP ERRORS.
*
*         EXIT   ALL REGISTERS NECESSARY WILL BE CLEARED OF ERRORS.


          ROUTINE  CPE

          LDM    S0PMC       PAGE MAP CONNECT CODE
          STD    EC
          FUNCMR ,MRCE       CLEAR ERRORS FROM PAGE MAP REGISTERS
          LJM    CPEX        RETURN

          OVERFLOW  10000    CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_OS_REQUESTS
*COPYC CTP$DFT_OS_REQUESTS_PACKETS

          OVERFLOW  10000    CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS - 2)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_REQUEST_PROCESSOR_2

          OVERFLOW  10000    CHECK FOR OVERFLOW
          OVERLAY  (PP REQUEST PROCESSORS)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPY CTP$DFT_PP_UTILITY_REQUESTS
*COPY DSI$930_DUMP_LOAD_IDLE_PP
*COPY CTP$DFT_930_DUMP_PP_REGS
 CIE      SUBR
          UJN    CIEX        STUB ON AN S0

          OVERFLOW  10000    CHECK FOR OVERFLOW
          OVERLAY  (ISSUE MONITOR TIMEOUT MESSAGE)
*COPY     CTP$DFT_UPDATE_170_MEMORY
          OVERFLOW  10000
          OVERLAY  (DFT ERROR LOGGING ROUTINES)
*COPY     CTP$DFT_PROCESS_DISK_ERROR
*COPY CTP$DFT_RETURN_ERROR_CODE

          OVERFLOW  10000
          OVERLAY  (DFT RUN TIME ERROR HANDLING)
*COPY CTP$DFT_RUN_TIME_ERROR_HANDLER
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPY CTP$CONSTRUCT_MESSAGE_IN_EICB

          OVERFLOW  10000    CHECK FOR OVERFLOW
          END
/EOR
*DECK DECK=CTM$DFT_960_CLASS EXPAND=TRUE
          IDENT  DFT5,70B
          CIPPU  J
          MEMSEL 16
          BASE   MIXED
          LIST   X
          TITLE  CTM$DFT 960 CLASS (DFT5).
          COMMENT *SMD* LVL=15
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 DFT      SPACE  4,10
***       DFT - DEDICATED FAULT TOLERANCE.
*         G. J. FALCONER.    85/08/05. (DFT V1.0)
*         G. J. FALCONER.    86/02/27. (DFT V2.0)
*         C. L. WILSON       87/11/13. (PIP3 OVERLAY ENHANCEMENTS)
 DFT      SPACE  4,10
***       DFT PERFORMS:
*
*         1) CAPTURING THE CONTENT OF MAINFRAME MAINTENANCE REGISTERS
*         FOR ERROR LOGGING, AND CLEARING HARDWARE ELEMENT ERRORS.
*
*         3) THE ACTUAL SEQUENCE OF STEPS TO DEADSTART THE SYSTEM FROM
*         C170 STATE OPERATION TO DUAL-STATE OPERATION OR TO RETURN IT TO
*         STANDALONE C170 OPERATION.  THIS IS PERFORMED UPON THE REQUEST
*         OF THE PP BOOT (*VPB* STATE OF *SCI*).
*
*         4) PROVIDING EXTERNALIZATIONS OF *2AP* FUNCTIONS TO NOS/VE.
 CONTROL  SPACE  4,10
**        ASSEMBLY PARAMETERS.

 PPTYPE   EQU    0           TURN ON TRACKING OF UPPER/LOWER PP
 MCH$     EQU    0           DEFINE *MCH* ROUTINE IN *DSI$DUMP LOAD IDLE*
 HCM$     EQU    0           FLAG IF CPU SHOULD BE HALTED BEFORE MEMORY REGISTERS WRITTEN
 PRGM     SET    2           SET *OVERLAY* MACRO TO *DFT* NAMES
*STEP$    SET    0           ASSEMBLE *STEP* CODE IF SYMBOL DEFINED

          LIST   X
*COPY     CTP$DFT_RELEASE_HISTORY
*COPY     CTH$DEDICATED_FAULT_TOLERANCE
          LIST   *
 COMMON   SPACE  4,10
**        COMMON DECKS.


*COPYC DSI$PP_MACROS
*COPYC DSI$MAINTENANCE_REGISTER_MACROS
*COPYC CTI$COMPASS_OS_LEVELS
*COPYC CTC$DFT_MACROS
*COPYC CTP$DFT_SPECIAL_MAC_ACCESS
*COPYC CTC$DFT_DIRECT_CELLS

          LIST   X
*COPYC CTI$CONSOLE_PACKET_DEFINITIONS
*COPYC CTI$DFT_ANALYSIS_CODES
*COPY DSC$PP_MR_AND_TPM_CONSTANTS
*COPY CTC$DFT_CONSTANTS

*         EQUATES FOR TYPE CODES - 960

 TC.IFD   EQU    0#6         INSTR FETCH TYPE CODE
 TC.REF   EQU    0#3         REFROM TYPE CODE

*         EQU'S FOR BYTE OFFSETS IN MRB AFTER READ TO CM (960)

 OCSM     EQU    CM+0
 OIFD     EQU    CM+2
 OACU     EQU    CM+2
 OBDPM    EQU    CM+0
 OREF     EQU    CM+2

*         CONTROL MEMORY ADDRESS EQUATES  - 960

 MA47     EQU    0#47        MICRAND ADDRESS 47
 MA49     EQU    0#49        MICRAND ADDRESS 49
 MA61     EQU    0#61        MICRAND ADDRESS 61
 MA64     EQU    0#64        MICRAND ADDRESS 64
 MA67     EQU    0#67        MICRAND ADDRESS 67
 MA6A     EQU    0#6A        MICRAND ADDRESS 6A
 MA381    EQU    0#381       MICRAND ADDRESS 381
 M367     EQU    0#1300      MASK
 M1905    EQU    0#1F00
 M4101    EQU    0#0040
 M3401    EQU    0#0020
 MSSM     EQU    0#0020
 DEC42    EQU    0#0020      DEC REG MASK FOR BIT 42
 RF.FWA   EQU    0#00        REGISTER FILE FWA
 IFD.FWA  EQU    0#00        INSTR FETCH FWA
 REF.FWA  EQU    0#00        REFROM FWA
 ACU.FWA  EQU    0#40        ACU FWA
 IDU.CSA  EQU    0#00        CONTROL STORE FWA
 BDP.FWA  EQU    0#00        BDP FWA

*         EQUATES FOR MDB LOGGING - TYPE CODES

 SH.CMPE  EQU    1           CONTROL MEMORY PARITY ERROR
 SH.JEP   EQU    4           JOB EXCHANGE PACKAGE
 SH.EW    EQU    5           EXECUTING WORDS AROUND P
 SH.RI    EQU    7           RETRY INFORMATION
 SH.SR    EQU    8D          SOFT REGISTERS
 SH.RF    EQU    9D          REGISTER FILE
 SH.EL    EQU    10D         ERROR DURING LOGGING

*         EQUATES FOR MDB LOGGING - LENGTH

 LOD.CMPE EQU    11D         CONTROL MEMORY PARITY ERROR
 LOD.JEP  EQU    53D         JOB EXCHANGE PACKAGE
 LOD.EW   EQU    15D         EXECUTING WORDS AROUND P
 LOD.RI   EQU    3           RETRY INFORMATION
 LOD.SR   EQU    28D         SOFT REGISTERS
 LOD.RF   EQU    65D         REGISTER FILE
 RFLOG    EQU    LOD.RF-1    REGISTER FILE LOG LENGTH
 LOD.EL   EQU    11D         ERROR DURING LOGGING

*COPY CTC$DFT_ACTION_OVERFLOW
*COPY DSA$HARDWARE_TABLE_DEFINITIONS
*COPY DSA$VE_REQUESTS_TO_DFT
          LIST   *
*COPY DSI$PP_INSTRUCTION_MNEMONICS
          LIST   X
*COPY CTC$EI_CONTROL_BLOCK
          LIST   *

**        START DEFINITION OF THE MAIN LOOP OF DFT.
*
*         THE CYBER 960 WILL REQUIRE PACKET CODE, EICB UPDATE, AND
*         RELOCATION ROUTINES.

*COPYC CTP$DFT_MAIN_LOOP
 CRN      SPACE  4,10
**        CRN - CHECK RELOCATION NECESSARY
*
*         STUB ON 960


 CRN      SUBR               ENTRY/EXIT
          UJN    CRNX
*COPYC CTP$DFT_MAIN_LOOP_PACKETS
*COPYC CTP$DFT_MAIN_LOOP_UPDATE_TIME
*COPYC CTP$DFT_MAIN_LOOP_DUAL_STATE

**        END OF DFT MAIN LOOP DEFINITIONS

*COPYC CTC$DFT_GLOBAL_DATA
*COPYC CTC$DFT_GLOBAL_DATA_NON_S0
 FALT     CON    0           HOLDS EPM FAULT FLAGS
 CMIN     CON    0           NUMBER OF CM WORDS IN EPM PACKET
 CMTL     CON    0           TOTAL CM WORDS FOR EPM PACKETS
 HALT     CON    0           HALT ON ERROR FLAG
 RCTR     CON    0           RETRY CNTR SAVE AREA
 RADR     BSSZ   3           R-REG OFFSET FOR RETRY
 PSAVE    BSSZ   4           P-REG SAVE AREA FOR RETRY
 MARA     CON    0           MICRAND REGISTER SAVE AREA
 FAIL     CON    0           FAILING ADDRESS
 SHWF     CON    0           SUB-HEADER WORD FLAG
 FSAC     CON    0           FAULT SYMTOM ANALYSIS CODE
 EPBA     BSSZ   2           EXCHANGE PACKAGE BYTE ADDRESS
 MACF     CON    0           MAC HANG ERROR FLAG
*COPYC CTC$DFT_MDB_LOGGING_CONSTANTS
*COPYC CTP$DFT_RESIDENT_COMMON
*COPYC CTP$DFT_RESIDENT_ECM_NON_S0
*copy dsi$find_cip_module
*copy dsi$get_hardware_element
*COPYC CTP$MR_PROTOCOL_PREPROCESS
*COPYC CTP$MR_RETRY_OPERATION_FOR_DFT
*COPYC CTP$MR_PROTOCOL_PROCESS
*COPYC CTP$MR_PROTOCOL_POSTPROCESS

*copy DSI$PP_UTILITY_SUBROUTINES
 STP      SPACE  4,10
**        STP - STOP PROCESSOR.
*
*         ENTRY  (A)= PORT CODE OF PROCESSOR.
*
*         CALLS  RMR, *ERRH*.


 STP      SUBR               ENTRY/EXIT
          STML   STPA        CHECK PORT CODE
          ZJN    STPX        IF PORT CODE ZERO RETURN
          LDN    SSMR
          STD    RN
          LDML   STPA
          RJM    RMR         READ SUMMARY STATUS
          LPN    0#8
          NJN    STP2        IF PROCESSOR IS HALTED
          FUNCMR ,MRHP       STOP PROCESSOR
          LDN    0
          STML   ACTB1+2
          STML   TFLG
 STP0     RJM    TIM
          LDM    TFLG
          ZJN    STP0        IF 100 MS WAIT NOT DONE
 STP2     LDML   STPA
          RJM    RMR         READ SUMMARY STATUS
          LPN    0#8
          ZJN    STP2        IF NOT HALTED
          LJM    STPX        RETURN

 STPA     CON    0

          USE    PRESET
          QUAL   PRESET
*COPYC CTP$DFT_PRESET
*COPYC CTP$DFT_PRESET_DUAL_I4
*COPY CTP$DFT_RETURN_ERROR_CODE
 SPO      SPACE  4,10
**        SPO - SETUP MEMORY PORT OFFSET.
*
*         EXIT   PO IS SET TO THE MODEL DEPENDENT PORT OFFSET.
*
*         USES   PO.


 SPO      SUBR               ENTRY/EXIT
          LDN    4           SETUP MEMORY PORT OFFSET
          STD    PO
          UJN    SPOX        RETURN
          USE    *
          QUAL   *
          OVERLAY  (RESIDENT PART II),R2ORG
          QUAL   *
*COPYC CTP$DFT_RESIDENT_II_COMMON
*COPYC CTP$DFT_NON_930_RESIDENT_II
*COPYC DSI$PACK_UNPACK_REGISTERS
*COPYC DSI$VALIDATE_PP_BOUNDS
*COPYC CTP$DFT_RESIDENT_II_NON_990
 HAC      SPACE  4,10
**        HAC - HALT ALL CPUS.
*
*         CALLS  STP.
*
*         NOTE   THIS IS USED FOR HALTING CPUS PRIOR TO WRITING MEMORY REGISTERS.


 HAC      SUBR               ENTRY/EXIT
          LDN    71B
          CRDL   T0
          LDDL   T0
          SHN    7           BIT 5 TELLS IF NOS IN BOTH HEADS
          MJN    HACX        IF TWO HEADED NOS IGNORE HALTS
          LDML   CP0CC       CPU0 CONNECT CODE
          RJM    STP         STOP PROCESSOR
          LDML   CP1CC       CPU1 CONNECT CODE
          RJM    STP         STOP PROCESSOR
          UJN    HACX        RETURN
 SAC      SPACE  4,10
**        SAC - START ALL CPUS.
*
*         ENTRY  (A) = 0 START ALL CPUS.
*                (A) <> 0 DONT START CPU IDENTIFIED IN (A) BY PORT CODE.
*
*         NOTE   THIS IS USED FOR STARTING CPUS AFTER WRITING MEMORY REGISTERS


 SAC      SUBR               ENTRY/EXIT
          STML   SACA        SAVE POTENTIAL PROCESSOR NOT TO START
          LDN    71B
          CRDL   T0
          LDDL   T0
          SHN    7           BIT 5 TELLS IF NOS IN BOTH HEADS
          MJN    SACX        IF TWO HEADED NOS IGNORE START
          LDML   CP0CC
          ZJN    SAC1        IF NOT DEFINED
          SBML   SACA
          ZJN    SAC1        IF NOT TO BE STARTED
          LDN    0           CPU 0
          RJM    CPD         CHECK IF MEMORY PORT DISABLED
          NJN    SAC1        IF PORT IS DISABLED
          FUNCMR CP0CC,MRSP  CPU0 CONNECT CODE
 SAC1     LDML   CP1CC
          ZJP    SACX        IF NOT DEFINED
          SBML   SACA
          ZJP    SACX        IF NOT TO BE STARTED
          LDN    1           CPU 1
          RJM    CPD         CHECK IF MEMORY PORT IS DISABLED
          NJP    SACX        IF PORT IS DISABLED
          FUNCMR CP1CC,MRSP  CPU1 CONNECT CODE
          LJM    SACX        RETURN

 SACA     CON    0           PORT CODE FOR PROCESSOR TO NOT START
 CPD      SPACE  4,10
**        CPD - CHECK IF MEMORY PORT IS DISABLED.
*
*         ENTRY  (A) = 0 CHECK CPU 0 MEMORY PORT.
*                (A) = 1 CHECK CPU 1 MEMORY PORT.
*
*         EXIT   (A) = 0 PORT IS NOT DISABLED.
*                (A) <> 0 PORT IS DISABLED.
*
*         CALLS  RMR.


 CPD      SUBR               ENTRY/EXIT
          STM    CPDA        SAVE CPU SELECTOR
          LDN    ECMR
          STDL   RN
          LDML   CMCC
          RJM    RMR         READ MAINTENANCE REGISTER
          LDM    CPDA
          NJN    CPD2        IF CPU 1
          LDC    SHNI+4+3    GENERATE SHIFT INSTRUCTION
          SBM    CMP0
 CPD1     STM    CPDB
          LDN    1
 CPDB     SHN    4+**
          STM    CPDC
          LDM    RDATA,PO
          LPC    **          EXTRACT CPU PORT DISABLE BIT
 CPDC     EQU    *-1
          UJN    CPDX

 CPD2     LDC    SHNI+4+3
          SBM    CMP1
          UJN    CPD1

 CPDA     CON    0
**        END OF RESIDENT II COMMON AREA

          ERRNG  10000-*     RESIDENT II OVERFLOWS PP MEMORY
*COPY  CTP$DFT_PRESET_DUAL_I4_OVL
*COPYC CTP$DFT_PRESET_BUILD_STRUCTURE
          OVERLAY (PRESET STANDARD OVERLAY)
*COPYC CTP$DFT_PRESET_STANDARD_OVL
*COPY CTP$DFT_RETURN_ERROR_CODE
 SSO      SPACE  4,10
**        SSO - SETUP SPECIAL OVERLAY
*
*         EXIT   OVERLAY TO HANDLE BIT 57 ERRORS ON A MODEL 43(16) OR 44(16)
*                IOU.  LOADED AT LOCATION 10000(8) OF THE PP.

 SSO      SUBR               ENTRY
          LDM    IOUM
          LMC    0#43
          ZJN    SSO1        IF MODEL 43(16)
          LMC    0#44&0#43
          ZJN    SSO1        IF MODEL 44(16)
          UJN    SSOX        RETURN

 SSO1     LDC    SCO_O
          RJM    LOV         LOAD SPECIAL OVERLAY
          UJN    SSOX        RETURN

 SMV      SPACE  4,10
**        SMV - SETUP MODEL DEPENDENT VALUES.
*
*         *SMV* WILL SET UP REGISTER LIST ADDRESSES ON A MODEL DEPENDENT BASIS, AND
*         WILL INITIALIZE ALL MODEL DEPENDENT GLOBAL DATA.


 SMV      SUBR               ENTRY/EXIT
          LDC    DGCP        SET THE TASK LIST ADDRESS FOR DEGRADING A CPU
          STM    DTLA
          LDN    0           CLEAR HALT ON ERROR
          STM    HALT
          LDC    SXIU        UNCORRECTED REG LIST FOR IOU
          STM    IO0U        SAVE LIST ADDRESS
          STM    IO0C
          LDML   IOUM
          LMC    0#43
          ZJP    SMV10       IF MODEL 43
          LMN    0#44&0#43
          ZJN    SMV10       IF MODEL 44
          LDML   IOUM
          LMC    0#42
          ZJN    SMV10       IF MODEL 42
          READMR RDATA,I0CC,OIMR  I4 PROCESSOR
          LDM    RDATA+7
          SHN    10D         CHECK BIT 56 FOR CIO PP PRESENT
          PJN    SMV10       IF NO CIO PPS PRESENT
          LDC    I4IU
          STM    IO0U        UNCORRECTED REGISTER LIST
          LDC    I4IC
          STM    IO0C        CORRECTED REGISTER LIST
 SMV10    LDC    MA960       COMPLETE REGISTER LIST FOR MEMORY ERRORS
          STM    ME0U        UNCORRECTED MEMORY ERROR LIST
          STM    ME0C        CORRECTED MEMORY ERROR LIST
          LDC    PA960
          STM    CP0C        CORR/UNCORR REGISTER LIST
          STM    CP0U
          LDN    PROCID
          RJM    FHE         FIND HARDWARE ELEMENT
          MJP    PRS140      IF CANT FIND CPU0
          LDM    HBUF+CPRPORT
          STM    CMP0        SAVE CPU0 MEMORY PORT
          LDC    PROCID1
          RJM    FHE         FIND HARDWARE ELEMENT
          MJP    SMVX        IF NOT DEFINED
          LDM    HBUF+CPRPORT
          STM    CMP1        SAVE CPU1 MEMORY PORT
          LJM    SMVX

*COPY     CTP$DFT_CLEAR_PACKETS_I4
*COPYC CTP$DFT_PRESET_PACKETS
          OVERLAY  (MAIN NON-RESIDENT ROUTINES)

**        START OF THE MAIN NON RESIDENT ROUTINES OVERLAY. ON CYBER 960
*         THIS OVERLAY DEFINES ROUTINES FOR PACKETS, I4,
*         HALT ON ERROR PROCESSING, EICB TIME UPDATE, AND PACKET COMMUNICATION.

*COPYC CTP$DFT_MAIN_NON_RES_RTNS
*COPY CTP$DFT_SET_SS_DUAL_I4
*COPYC CTP$DFT_MAIN_NON_RES_DUAL_I4
*COPYC CTP$DFT_MAIN_NON_RES_EICB_TIME
*COPY CTP$DFT_CHECK_TPM_PKT_RESPONSE
*COPYC CTP$DFT_MANAGE_PACKET_TRAFFIC
 ERR      CALL   ROS         REPORT OS ERROR



 HOE      SPACE  4,10
**        HOE - HALT ON ERROR FOR 960 CLASS MACHINES.
*
*         ENTRY  DEDICATED FLAG IN DFT HEADER DETERMINES ACTION.
*
*         EXIT   *DEC* REGISTER SET/CLEAR FOR HALT ON ERROR.
*                CELL *HE* SET OR CLEARED DEPENDING ON DEDICATED FLAG.
*
*         CALLS  FHE, IDA, SHE, *MHE*.


          ROUTINE HOE

          LDN    HDRP
          RJM    IDA
          CRDL   CM          GET DFT HEADER
          LDDL   CM+DHFLG    GET FLAGS
          SHN    21-DH.FD    DEDICATED FLAG
          PJN    HOE1        IF DEDICATED MODE
          LDM    HALT
          ZJN    HOE0        IF NO HALT ON ERROR AND NON DEDICATED
          LDN    0
          STM    HALT        CLEAR HALT ON ERROR
          UJN    HOE2        CONTINUE

 HOE0     LJM    HOEX        RETURN

 HOE1     LDN    1
          STM    HOEB        MARK DEDICATED MODE
          LDM    HALT
          NJN    HOE0        IF DEDICATED AND HALT ON ERR ALREADY SET
 HOE2     LDN    0
          STM    HOEA        SAVE ELEMENT COUNTER
          LDN    PROCID
 HOE3     RJM    FHE         FIND HARDWARE ELEMENT HBUF HOLDS RESULT
          MJN    HOE5        IF DONE WITH ALL ELEMENTS
          LDM    HBUF+CPUON
          LPN    1
          NJN    HOE4        IF DOWN
          LDM    HBUF+CPRE+EM  GET MODEL
          SHN    -4
          STD    MD
          RJM    SHE         SET HALT ON ERROR
 HOE4     AOM    HOEA        BUMP ELEMENT NUMBER
          SHN    14
          ADN    PROCID      SET UP PARAMETER TO FHE
          UJN    HOE3        LOOP

 HOE5     CALL   MHE         MONITOR HARDWARE ENVIRONMENT
          LJM    HOEX        RETURN

 HOEA     CON    0           ELEMENT COUNTER
 HOEB     CON    0           DEDICATED MODE FLAG
 SHE      SPACE  4,10
**        SHE - SET HALT ON ERROR.
*
*         EXIT   IF CYBER 960 AND DEDICATED, *HALT* = 1 AND
*                *DEC* REGISTER UPDATED.
*         USES   *HALT*.
*
*         MACROS READMR, WRITMR.


 SHE      SUBR               ENTRY/EXIT
          READMR RDATA,HBUF+HDRPC,DEMR
          LDM    RDATA+5
          LPC    -0#10       CLEAR BIT
          STM    RDATA+5
          LDM    HOEB
          ZJN    SHE1        IF NOT DEDICATED
          LDN    1
          STM    HALT        SET HALT ON ERROR
          LDM    RDATA+5
          LMC    0#10        SET IT
          STM    RDATA+5
 SHE1     WRITMR RDATA,HBUF+HDRPC
          LJM    SHEX        RETURN


          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (AUX MAIN NON RESIDENT ROUTINES)
*COPYC CTP$DFT_MAIN_NON_RES_DUAL_STATE
*COPYC CTP$DFT_LOG_PACKET_TIMEOUT
*COPYC CTP$DFT_CPU_HANDSHAKER
          ROUTINE ROS
          LJM    ERR
*COPY CTP$DFT_PREPARE_FOR_CIP_CALL
*COPY CTP$DFT_RETURN_ERROR_CODE
          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DO DFT ACTIONS)

*COPYC CTP$DFT_ACTION_LIST
*COPY  CTP$DFT_ACTION_LIST_DUAL_I4
*COPYC CTP$DFT_ACTION_LIST_DUAL_STATE

 DDCE     BSS    0           CLEAR 960 PROCESSOR ERRORS
          TASK   (LOG,CLE,SPR)

 DDCM     BSS    0           CLEAR CM ERROR
          TASK   (CCE)

 DGCP     BSS    0           DEGRADE CPU MEMORY PORT
          TASK   (SCW,DIP)

 ROUE     BSS    0           RETRY UNSUCC/UNCORR ERROR
          TASK   (LMB,RCM,ELB,LOG,SCW,CLE,SPR)

 UENH     BSS    0           UNCORR ERR - NOT HALT ON ERROR
          TASK   (RCM,LOG,SCW,CLE,SPR)

*         THE FOLLOWING ACTION LIST IS USED FOR FATAL
*         SOFTWARE AND HARDWARE ERRORS, FATAL CLOCK
*         ERROR, AND CONTROL STORE ERROR IN MONITOR

 PIFE     BSS    0           960 FATAL SOFTWARE/HARDWARE ERR
          TASK   (LMB,CDB,CCM,PJH,ELB,DID,LOG,SCW,DIP,WM7,IFM)

 UEJM     BSS    0           UNCORR ERROR - JOB MODE
          TASK   (LMB,RCM,CLE,MCP,HEO,LEP,ELB,LOG,SCW,CLE,HEI)

 RIPA     BSS    0           960 RETRY IN PROGRESS ACTION
          TASK   (RCM,ELB,LOG,SCW,CLE,SPR)

 RIPC     BSS    0           RETRY IN PROGRESS CONT.
          TASK   (RCM,CLE,SPR)

 MCHI     BSS    0           CPU MAC HUNG INITIALLY
          TASK   (DID,LOG,DIP,WM7,IFM)

 MCHP     BSS    0           CPU MAC HUNG IN PROGRESS
          TASK   (ELB,DID,LOG,SCW,DIP,WM7,IFM)

*COPYC CTP$DFT_RETURN_TASK_ERROR
          QUAL   *
          QUAL   ABC
*COPY CTP$DFT_RETURN_ERROR_CODE
          QUAL   *

          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DO ADDITIONAL DFT ACTIONS)

**        START OF DFT ACTION LISTS OVERFLOW.  THIS IS AN EXTENSION OF THE COMMON
*         DFT ACTIONS.

          QUAL

*COPYC CTP$DFT_ACTION_LIST_OVERFLOW

          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT SEND PACKETS OVERLAY)
*COPYC CTP$DFT_CHECK_PKTS_FOR_NON_S0
*COPYC CTP$DFT_CHECK_PKT_STATUS_NON_S0
*COPYC CTP$DFT_SEND_PACKET_ALL
*COPY  CTP$DFT_SEND_PACKET_FOR_NON_S0
*COPY  CTP$DFT_CLEAR_PACKETS_I4

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY (SAVE PP REGISTERS IN CENTRAL MEMORY)
*COPYC CTP$DFT_SAVE_PP_REGISTERS
*COPY  CTP$DFT_DUMP_PP_REGISTERS
 QUAL$    EQU    1
*COPY  DSI$DUMP_LOAD_IDLE_PP
          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY (DFT ERROR CONTROL OVERLAY)


*COPYC CTP$DFT_ERROR_CONTROL

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (LOG TOP OF HOUR COUNTERS)

*COPYC CTP$DFT_LOG_COUNTERS
 RMC      SPACE  4,10
**        RMC - RESET MODEL DEPENDENT COUNTERS.
*                IF VERSION 4 OR GREATER, CHECK FOR MIDNIGHT.
*                IF SO, CLEAR THE LONGTERM INTERLOCK FLAG IN THE
*                MAIN CPU MODEL DEPENDENT BUFFER HEADER WORD.
*
*         USES   RS-RS+2, CM-CM+3
*
*         CALLS  VCK, IIB, SPC, IDA.
*

          ROUTINE RMC        ENTRY/EXIT
          LDN    VER4
          RJM    VCK
          MJP    RMCX        IF VERSION 3 OR LESS
          LDN    DFCM+7
          RJM    IIB
          CRML   RMCA,ON     GET TIME (TOP OF HOUR)
          LDML   RMCA+2
          LPC    0#FF00
          NJP    RMCX        IF NOT MIDNIGHT
          LRD    DP+1
          RJM    SPB         SET PP BOUNDS
          LDN    MDLP        MDB PTR OFFSET
          RJM    IDA
          CRDL   RS          READ MDB PTR
          LRD    RS+1        LOAD INTO R-REGISTER
          LDD    RS
          ADC    RR
          CRDL   RS          READ CPU0 MDB PTR
          LRD    RS+1        LOAD INTO R-REGISTER
          LDD    RS
          ADC    RR
          CRDL   CM          READ MDB HEADER WORD
          LDDL   CM          BITS 0-16
          LPC    0#F0FF      CLEAR BITS 4-7
          STDL   CM          RESTORE
          LDD    RS
          ADC    RR          ACTIVATE R-REGISTER
          CWDL   CM          WRITE TO MDB
          UJP    RMCX        RETURN

 RMCA     BSS    4           TIME STAMP FROM EICB
 RMCF     CON    0
*COPY     CTP$DFT_RESET_PIT
*COPY     CTP$DFT_TEST_DLD_PATH

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (ENVIRONMENT/SHORT WARNING PROCESSORS)

*COPYC CTP$DFT_ENVIRONMENT_RTNS
 CCA      SUBR
          LDN    1
          UJN    CCAX        REPORT CONSOLE ALIVE ON NON S0 MACH.
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY (ANALYSE 960 CPU ERRORS)

 APE      SPACE  4,10
**        APE - ANALYSE CYBER 960 PROCESSOR ERRORS.
*
*         CALLS  CFF,SWP,SCS,STP,CLR,RMR,PAC,BRL,GCM,PCM,CCF,CCS,CRS,ARS,AFF,SSE


          ROUTINE APE

          CALL   CFF         CHECK FOR FREEZE
          LDN    0
          STM    NERR        SET NO ERROR FLAG FALSE
          STM    MACF        CLEAR MAC ERROR FLAG

*         IT IS NECESSARY TO SAVE THE PREHALT STATUS SUMMARY BECAUSE
*         HALTING THE PROCESSOR WILL SET THIS BIT.

          LDM    SUMS        SUMMARY STATUS
          STM    OLSS        SAVE PRE HALT PROCESSOR SS
          SHN    21-SSSW     SHORT WARNING
          PJN    APE1        IF NO SHORT WARNING
          CALL   SWP         CALL SHORT WARNING PROCESSOR
          LJM    APEX        RETURN

 APE1     RJM    CTE         CHECK THRESHOLD EXCEEDED
          NJP    APEX        IF THRESHOLD EXCEEDED IGNORE ERROR
 APE2     LDN    0
          RJM    SCS         SAVE PREHALT CONTROL STORE ADDRESS
          CALL   STP         CALL STOP PROCESSOR
 APE3     LDN    1
          RJM    SCS         SAVE AFTER HALT CSA
          LDM    CPUO
          STM    CPUH        HALTED CPU ORDINAL
          LDN    BC
          RJM    CLR
          LDN    PCSA        CONTROL STORE ADDRESS
          STD    RN
          LDM    HBUF+HDRPC
          RJM    RMR         READ CSA
          RJM    PAC         MRVAL = CSA
          LDML   MRVAL+3
          LPC    0#7FF
          STML   MARA        SAVE MAR (MICRAND ADDRESS REGISTER)

*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).

          SETFLG (BC.FV7,BC.FV8,BC.FL)

          LDC    DEMR        DEC REG
          STD    RN
          CALL   RPM         READ REG TO TEST STATE OF MAC
          LDM    CP0C        GET REGISTER LIST FOR CPU
          RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          LDM    MACF        ERROR FLAG
          ZJN    APE3.5      IF NO ERROR
          SETDAC MCHI
          UJP    APEX        EXIT
 APE3.5   LDM    OLSS
          LPN    MSSM        MONITOR MASK
          ZJN    APE4        IF JOB MODE
          LDC    PMPS        EXCH PACKAGE FOR MONITOR
          UJN    APE5

 APE4     LDC    PJPS        EXCH PACKAGE FOR JOB
 APE5     STD    RN
          CALL   RPM         READ MPS OR JPS
          LDM    MACF        ERROR FLAG
          ZJN    APE5.5      IF NO ERROR
          SETDAC MCHI
          UJP    APEX        EXIT
 APE5.5   RJM    PAC         MRVAL = MPS OR JPS
          LDML   MRVAL+3
          SHN    -3          FORM WORD ADDRESS FOR LWA ROUTINE
          STML   EPBA+1
          LDM    MRVAL+2
          LPN    7
          SHN    13D
          RAML   EPBA+1
          LDML   MRVAL+2
          SHN    -3
          STML   EPBA        SAVE ADDRESS

*         GET PSAVE, RCTR, RADR FROM CENTRAL MEMORY BUFFER

          LDN    CMRC        RETRY COUNTER
          RJM    GCM
          LDDL   CM+3
          STML   RCTR        UPDATE RETRY COUNTER
          LDN    CMRA        PREVIOUS R-REGISTER ADDR
          RJM    GCM
          LDDL   CM+1
          STML   RADR        UPDATE FOR ARS ROUTINE
          LDDL   CM+2
          STML   RADR+1
          LDDL   CM+3
          STML   RADR+2
          LDN    CMPRA       PREVIOUS P-REGISTER ADDR
          RJM    GCM
          LDDL   CM
          STML   PSAVE       UPDATE FOR ERROR ANALYSIS
          LDDL   CM+1
          STML   PSAVE+1
          LDDL   CM+2
          STML   PSAVE+2
          LDDL   CM+3
          STML   PSAVE+3
          LDM    OLSS
          SHN    21-SSPH
          MJP    APE6        IF PROC ORIGINALLY HALTED
          LDM    HALT
          ZJP    APE6        IF NOT HALT ON ERROR
          LDM    OLSS
          SHN    21-SSUE
          PJN    APE6        IF NOT UNCORRECTED ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = FATAL UNCORR ERR.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = CPU HALT ERROR.

          SETDAC PIFE
          SETDAN (EPCH,DAFUE)
          LJM    APE23       CONTINUE PROCESSING

 APE6     LDM    OLSS
          SHN    21-SSPH     PROCESSOR HALT IN SUMM STAT
          PJP    APE7        IF PROCESSOR NOT HALTED
          LDM    HALT        GET HALT ON ERROR FLAG
          NJP    APE7        IF HALT ON ERROR SET

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = FATAL PROCESSOR HALT.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = CPU HALT ERROR.

          SETDAC PIFE
          SETDAN (EPCH,DAPH)
          LJM    APE23       CONTINUE PROCESSING

*         CHECK FOR CLOCK ERRORS

 APE7     RJM    CCF         CHECK CLOCK FAULT STATUS
          ZJP    APE8        IF NO CLOCK ERRORS

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = FATAL CLOCK ERROR.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = CPU HALT ERROR.

          SETDAC PIFE        FATAL CLOCK ERROR
          SETDAN (EPCH,DACE)
          UJP    APE23       CONTINUE PROCESSING

*         CHECK FOR FATAL SOFTWARE ERROR

 APE8     LDML   MARA
          LMC    MA49
          NJP    APE9        IF MAR .NE. 49
          SETDAN (EPCH,DASWH)  FATAL SOFTWARE ERROR
          SETDAC PIFE        MONITOR MODE
          UJP    APE23       CONTINUE

 APE9     LDM    OLSS        SUMMARY STATUS
          SHN    21-SSUE
          MJP    APE10       IF UNCORRECTED ERROR
          LDM    OLSS
          SHN    21-SSCE     CORRECTED ERROR
          MJP    APE19       IF CORRECTED ERROR
 APE10    LDML   MARA
          LMC    MA61
          ZJP    APE21       IF MICRAND ADDRESS = 61

*         CHECK FOR UNCORRECTED ERROR - UNSUCCESSFUL RETRY

          LDC    PPRG        P-REGISTER ADDRESS
          STD    RN
          CALL   RPM         READ CURRENT P REGISTER
          LDM    MACF        ERROR FLAG
          ZJN    APE10.5     IF NO ERROR
          SETDAC MCHI
          UJP    APEX        EXIT
 APE10.5  RJM    PAC         PACK DATA INTO MRVAL
          LDN    3
          STDL   T2
 APE11    LDML   MRVAL,T2    CURRENT P
          SBML   PSAVE,T2    PREVIOUS P
          NJP    APE13       IF P .NE. PREVIOUS P
          SODL   T2
          PJP    APE11       IF MORE TO COMPARE
          LDML   RCTR        RETRY COUNTER
          ZJP    APE13       NOT UNSUCCESSFUL RETRY CONDITION
          LDN    0
          STML   RCTR        CLEAR RETRY COUNTER

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNSUCCESSFUL RETRY.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.

          SETDAN (EPUN,DATRE)
          LDML   MARA        MAR
          LMC    MA6A
          ZJP    APE12       IF MAR .EQ. 6A

*         DFT ANALYSIS - DFT ACTION = UNCORRECTED ERROR.

          SETDAC ROUE        SET ACTION LIST
          LJM    APE23       CONTINUE

*         DFT ANALYSIS - DFT ACTION = UNCORR ERR - JOB MODE.

 APE12    SETDAC UEJM        DEFAULT TO JOB MODE
          LDM    OLSS        STATUS SUMMARY
          LPN    MSSM        MONITOR MASK
          ZJP    APE23       IF JOB MODE

*         DFT ANALYSIS - ANALYSIS = UNSUCCESSFUL RETRY.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = FATAL CPU HALT ERROR.

          SETDAN (EPCH,DATRE)
          SETDAC PIFE
          UJP    APE23       CONTINUE

*         UNCORRECTED ERROR

 APE13    SETDAC ROUE        PROCESSOR UNCORRECTED ERROR
          LDML   MARA        MAR
          LMC    MA67
          NJN    APE14
          RJM    CCT         CHECK FOR CPU/CM TIMEOUT
          NJP    APE23       IF TIMEOUT
          SETDAN (EPUN,DAUEV)  EXCHANGE VECTOR
          UJP    APE23       CONTINUE

 APE14    LDML   MARA
          LMC    MA64
          NJN    APE15
          SETDAN (EPUN,DAUTV)  TRAP VECTOR
          UJP    APE23       CONTINUE

 APE15    LDML   MARA
          LMC    MA6A
          NJP    APE17       IF MAR .NE. 6A
          SETDAN (EPUN,DAUHV)  HALT VECTOR (JOB MODE)
          SETDAC UEJM
          LDM    OLSS        STATUS SUMMARY
          LPN    MSSM
          ZJN    APE16       IF JOB MODE
          SETDAN (EPCH,DAPH) PROCESSOR HALT (MONITOR MODE)
          SETDAC PIFE
 APE16    UJP    APE23       CONTINUE

*         CHECK FOR FATAL CONTROL STORE ERROR

 APE17    RJM    CCS         CHECK CONTROL STORE ERRORS
          NJP    APE23       IF ERRORS
          LDM    SUMS
          SHN    21-SSUE     UNCORRECTED ERROR
          MJP    APE18       IF UNCORRECTED ERROR SET

*         CHECK FOR POSSIBLE RESTART CONDITION.

          LDML   MARA
          LMN    5
          ZJP    APE22       IF RESTART IS POSSIBLE

*         PIP3 FORCED UNCORRECTED ERROR

          SETDAN (EPUN,DATFU)  FATAL UNCORRECTED ERROR
          SETDAC (UEJM)
          LDM    OLSS        STATUS SUMMARY
          LPN    MSSM
          ZJN    APE17.5     IF JOB MODE
          SETDAN (EPCH,DATFU)
          SETDAC (PIFE)
 APE17.5  UJP    APE23       CONTINUE

*         DEFAULT TO UNCORRECTED ERROR

 APE18    SETDAC ROUE
          SETDAN (EPUN,DAUPE)
          LDM    HALT
          NJP    APE23       IF HALT ON ERROR SET
          SETDAC UENH        ACTION FOR NON-DEDICATED
          UJP    APE23       CONTINUE

*         CHECK FOR SUCCESSFUL RETRY / CORRECTED ERROR

 APE19    LDML   MARA
          LMC    MA61
          ZJP    APE21       IF AT RETRY VECTOR
          RJM    CRS         CHECK SUCCESSFUL RETRY STATUS
          ZJP    APE20       IF NOT SUCCESSFUL RETRY
          SETDAN (EPCO,DARS)
          SETDAC DDCE
          UJP    APE23       CONTINUE

*         CHECK FOR RETRY IN PROGRESS

 APE20    LDML   MARA        MAR
          LMC    MA61
          NJP    APE22       IF NOT RETRY IN PROGRESS
 APE21    SETDAN (EPRT,DARP)
          SETDAC RIPC        DEFAULT TO CONTINUATION ACTION
          CALL   ARS         ANALYZE RETRY STATUS
          LDM    MACF        MAC ERROR FLAG
          ZJN    APE21.5     IF NO ERROR
          SETDAC MCHI
          UJP    APEX        EXIT
 APE21.5  LDM    RTP2        EXIT FLAG FROM ARS
          NJN    APE23       CONTINUE IF FLAGGED
          SETDAC RIPA        RETRY FIRST TIME
          UJN    APE23       CONTINUE

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CORRECTED PROCESSOR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

 APE22    SETDAN (EPCO,DACPE)
          SETDAC DDCE

 APE23    CALL   AFF         ANALYZE FIRST FAILURE CAPTURE DATA

*         SAVE PSAVE, RCTR, RADR IN CENTRAL MEMORY BUFFER

          LDN    CM
          RJM    CLR         CLEAR CELLS
          LDML   RCTR        RETRY COUNTER
          STDL   CM+3
          LDN    CMRC
          RJM    PCM         SAVE IN CENTRAL MEMORY BUFFER
          LDML   RADR        R-REGISTER ADDRESS FOR RETRY
          STDL   CM+1
          LDML   RADR+1
          STDL   CM+2
          LDML   RADR+2
          STDL   CM+3
          LDN    CMRA
          RJM    PCM         SAVE R-REGISTER ADDRESS
          LDML   PSAVE       P-REGISTER ADDRESS FROM THIS ERROR
          STDL   CM
          LDML   PSAVE+1
          STDL   CM+1
          LDML   PSAVE+2
          STDL   CM+2
          LDML   PSAVE+3
          STDL   CM+3
          LDN    CMPRA
          RJM    PCM         SAVE P ADDRESS FOR THIS ERROR
          LDM    CPUO
          RJM    SSE         SET SECONDARY ELEMENT IDENTIFIER
          LJM    APEX        RETURN

*COPY     CTP$DFT_SAVE_CONTROL_STORE
*COPY     CTP$DFT_990_960_DEGRADE_CPU
*COPY CTP$DFT_CHECK_CPU_THRESHOLD

          EJECT
**        CCF -  CHECK CLOCK FAULT STATUS.
*                READ CLOCK PFS BITS (PFS 83,87,89 - BITS 16,17,18,
*                AND PFS 81,85 - BITS 16,17,18,19). IF ANY SET,
*                CHANGE DFT ACTION TO STEP SYSTEM.  SET LOG FLAG
*                FOR OS.
*
*         USES   T2, CM - CM+4.
*
*         EXIT   (A) = 0 IF NO ERRORS
*
*         CALLS  FMB.

 CCF      SUBR               ENTRY / EXIT
          LDN    4           TABLE LENGTH
          STDL   T2
 CCF1     LDML   CCFA,T2     GET TABLE ENTRY
          RJM    FMB         GET ADDR TO SCRATCH BUFFER
          CRDL   CM          READ REG FROM SCRATCH BUFFER
          LDDL   CM+1
          LPML   CCFB,T2     MASK BITS
          NJN    CCF2        IF SET - CLOCK ERROR
          SODL   T2          DECREMENT LOOP COUNTER
          PJP    CCF1        DO FOR ENTIRE TABLE
          LDN    0           FLAG NO ERROR
          UJP    CCFX        EXIT

 CCF2     LDN    1           FLAG ERROR
          UJP    CCFX        EXIT

 CCFA     BSS    0           PFS REGISTERS
          CON    PPFS+1
          CON    PPFS+3
          CON    PPFS+5
          CON    PPFS+7
          CON    PPFS+11

 CCFB     BSS    0           MASK BITS FOR PFS REGISTERS
          CON    0#F000
          CON    0#E000
          CON    0#F000
          CON    0#E000
          CON    0#E000
          EJECT
**        CRS -  CHECK RETRY STATUS.
*                CHECK IF ERROR IS A SUCCESSFUL RETRY OR IF IT
*                IS A SOFT ERROR ONLY.
*
*         CALLED BY  APE
*
*         USES   CM, RCTR.
*
*         CALLS  FMB.
*
*         EXIT   (A) = 0 IF NOT SUCCESSFUL RETRY
*                (A) = 1 IF SUCCESSFUL RETRY


 CRS      SUBR               ENTRY / EXIT
          LDC    PPFS+4
          RJM    FMB         READ REGISTER CONTENTS
          CRDL   CM
          LDDL   CM+2
          LPC    M4101       MASK BIT
          NJN    CRS1        IF BIT SET
          LDN    0           SET FLAG
          UJP    CRSX        EXIT

 CRS1     LDN    0
          STML   RCTR        CLEAR RETRY COUNTER
          LDN    1           FLAG SUCCESSFUL RETRY
          UJP    CRSX        EXIT
          EJECT
**        ARS -  ANALYZE RETRY STATUS.
*                IF FIRST TIME AT THIS ERROR, LOG MODEL DEPENDENT
*                BUFFER AND RETRY INFORMATION.  ELSE, INCREMENT
*                COUNTER OF RETRY ATTEMPTS AND ADJUST PREVIOUS
*                MDB RETRY INFORMATION. FOR EITHER CASE, CLEAR
*                SOFT ERROR IN MONITOR CONDITION REGISTER.
*
*         USES   PSAVE, RCTR, RR, SHWD, CM, RADR, RDATA, RTP2
*
*         CALLS  CSE, LMB, WSH.
*
*         EXITS WITH TEMP CELL RTP2=0 IF FIRST TIME THROUGH

          ROUTINE ARS        ENTRY / EXIT
          CALL   CSE         CLEAR SOFT ERROR IN MCR
          LDM    MACF        ERROR FLAG
          NJP    ARSX        EXIT IF ERROR
          LDML   RCTR
          NJP    ARS1        IF NOT FIRST TIME THROUGH
          AOML   RCTR        BUMP COUNTER
          CALL   LMB         LOG MODEL DEPENDENT BUFFER
          LDML   BCWF        LOGGING FLAG
          SBN    2
          ZJP    ARSX        IF BUFFER NOT AVAILABLE
          LDN    SH.RI       DATA HEADER ID
          STML   SHWD+3
          LDN    LOD.RI      WORDS TO WRITE
          STML   SHWD
          CALL   WSH         WRITE SUBHEADER WORD
          AOML   LTOL        BUMP AMT TO LOG COUNTER
          LRD    RS+1
          AOD    RS          BUMP OFFSET
          ADC    RR
          CWML   PSAVE,ON    WRITE P REGISTER TO MDB
          SRD    RS+1        RESET R-REGISTER FOR SAVE
          LDD    RS+1
          STM    RADR+1
          LDD    RS+2
          STM    RADR+2
          AOML   LTOL        BUMP AMT TO LOG COUNTER
          LDN    CM
          RJM    CLR         CLEAR CM WORDS
          LDML   RCTR
          STDL   CM+3
          AOD    RS
          STM    RADR        SAVE THIS R-REG OFFSET
          ADC    RR
          CWDL   CM          WRITE COUNTER TO MDB
          LDN    0           SET FLAG TO INDICATE FIRST TIME
          STM    RTP2        SAVE TEMPORARILY
          UJP    ARSX        EXIT

 ARS1     LDML   BCWF        LOGGING FLAG
          SBN    2
          ZJP    ARSX        IF BUFFER NOT AVAILABLE
          SRD    RS+1        SAVE R-REGISTER
          LDD    RS          SAVE RS INFO AT RDATA
          STM    RDATA
          LDD    RS+1
          STM    RDATA+1
          LDD    RS+2
          STM    RDATA+2
          LDM    RADR+1      RESET R-REGISTER
          STD    RS+1
          LDM    RADR+2
          STD    RS+2
          LDN    CM
          RJM    CLR         CLEAR 4 WORDS
          AOML   RCTR        BUMP RETRY COUNTER
          STDL   CM+3        SAVE FOR MDB WRITE
          LRD    RS+1
          LDM    RADR        PREVIOUS ERROR OFFSET
          ADC    RR
          CWDL   CM          UPDATE RETRY COUNT
          LDM    RDATA       RESTORE RS DATA
          STD    RS
          LDM    RDATA+1
          STD    RS+1
          LDM    RDATA+2
          STD    RS+2
          LRD    RS+1        RESET R REGISTER
          LDN    1           SET FLAG - 2ND TIME OR MORE
          STM    RTP2        SAVE TEMPORARILY
          UJP    ARSX        EXIT
          EJECT
**        CCS -  CHECK CONTROL STORE ERROR
*                READ PFS 86 - BITS 3,6,7.  IF ANY OF THESE SET,
*                FATAL CONTROL STORE ERROR HAS OCCURRED.
*
*         ENTRY  OLSS = STATUS SUMMARY VALUE
*
*         CALLS  FMB
*
*         USES   CM.
*
*         EXIT   (A) = 0 IF NO ERROR.

 CCS      SUBR               ENTRY/EXIT
          LDC    PPFS+6      PFS REGISTER 86
          RJM    FMB
          CRDL   CM
          LDDL   CM
          LPC    M367        MASK FOR APPROPRIATE BITS
          NJN    CCS1        IF ANY SET
          LDN    0           FLAG NO ERROR
          UJP    CCSX        EXIT

 CCS1     LDM    OLSS        STATUS SUMMARY
          LPN    MSSM
          ZJN    CCS2        IF JOB MODE
          SETDAN (EPCH,DACSM)
          SETDAC PIFE        FATAL ERROR - MONITOR MODE
          UJN    CCS3

 CCS2     SETDAN (EPUN,DACSJ)
          SETDAC UEJM        FATAL ERROR - JOB MODE
 CCS3     LDN    1           FLAG ERROR
          UJP    CCSX        EXIT
          EJECT
**        CCT -  CHECK CPU/CM TIMEOUT
*                READ PFS 84 - BIT 42.  IF SET, CPU/CM TIMEOUT
*                HAS OCCURRED.  SET APPROPRIATE ACTION LIST.
*
*         CALLS  FMB
*
*         USES   CM.
*
*         EXIT   (A) = 0 IF NO ERROR.

 CCT      SUBR               ENTRY/EXIT
          LDC    PPFS+4      PFS REGISTER 84
          RJM    FMB
          CRDL   CM
          LDDL   CM+2
          LPN    0#20        MASK FOR APPROPRIATE BIT
          ZJP    CCTX        IF NOT SET, EXIT
          SETDAN (EPUN,DACCT)  SET ANALSIS CODE
          SETDAC UEJM        SET ACTION LIST
          LDN    1           FLAG ERROR
          UJP    CCTX        EXIT

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY (960 ACTIONS FOR CPU ERRORS)
          SPACE  4,10
**        LMB -  LOG MODEL DEPENDENT BUFFER
*                CLEAR ERRORS AND WRITE SOFT REGISTERS,
*                REGISTER FILE, AND INSTRUCTIONS SURROUNDING
*                P TO MDB.  CHECK IF ANY ERRORS OCCURRED
*                DURING THE LOGGING PROCESS.  IF SO, LOG
*                PFS REGISTERS TO MDB.
*
*         ENTRY  NONE
*
*         CALLS  CLR, CLE, DLC, DEP, WSH, LSR, SDB, LRF, WPC, LNE.

          ROUTINE LMB        ENTRY/EXIT
          CALL   CLE         CLEAR ERRORS
          LDN    HDRP        DFT CONTROL WORD PTR
          RJM    IDA
          CRDL   CM          READ
          LDDL   CM+DHFLG
          SHN    21-DH.FD
          MJP    LMBX        IF NON-DEDICATED
          RJM    DEP         DETERMINE ERROR PRIORITY
          CALL   DLC         DETERMINE LOGGING CONDITIONS
          LDML   BCWF
          SBN    2
          ZJP    LMBX        IF BUFFER NOT AVAILABLE

*         LOG SOFT REGISTERS

          LDC    SHWD
          RJM    CLR         CLEAR CM FOR WRITE OF SUBHEADER
          LDN    SH.SR       TYPE CODE
          STML   SHWD+3
          LDN    LOD.SR      WORDS TO LOG
          STML   SHWD
          CALL   WSH         WRITE SUBHEADER WORD
          CALL   LSR         LOG SOFT REGISTERS
          LDM    MACF        ERROR FLAG
          NJP    LMB1        JUMP IF SET

*         LOG EXECUTING WORDS AROUND P

          LDC    SHWD
          RJM    CLR         CLEAR CM FOR WRITE OF SUBHEADER
          LDN    SH.EW       TYPE CODE
          STML   SHWD+3
          LDC    LOD.EW      WORDS TO LOG
          STML   SHWD
          CALL   WSH         BUILD SUBHEADER WORD
          CALL   WPC         WRITE PROGRAM CONTENTS

*         LOG REGISTER FILE

          CALL   SDB         SET DEC BIT 42
          LDM    MACF        ERROR FLAG
          NJP    LMB1        JUMP IF SET
          LDC    SHWD
          RJM    CLR         CLEAR CM FOR WRITE OF SUBHEADER
          LDN    SH.RF       TYPE CODE
          STML   SHWD+3
          LDC    LOD.RF      WORDS TO LOG
          STML   SHWD
          CALL   WSH         BUILD SUBHEADER WORD
          CALL   LRF         LOG REGISTER FILE
          LDM    MACF        ERROR FLAG
          NJN    LMB1        JUMP IF SET

*         CHECK IF ANY NEW ERRORS

          CALL   LNE         LOG ANY NEW ERRORS
          LDM    MACF        ERROR FLAG
          ZJP    LMBX        EXIT IF NOT SET

 LMB1     LDN    1
          STM    TERT        SET TERMINATE ACTION LIST
          SETDAC MCHP        NEW ACTION LIST
          UJP    LMBX        EXIT
          EJECT
**        DEP -  DETERMINE ERROR PRIORITY.
*                TEST DFT ANALYSIS CODE FOR RETRY IN
*                PROGRESS AND ASSIGN PRIORITY 1.  IF
*                NOT, ASSIGN PRIORITY 2.
*
*         ENTRY  (BDCA) = CURRENT ANALYSIS CODE.
*
*         EXIT   CELL CEPR SET WITH ERROR PRIORITY.

 DEP      SUBR               ENTRY/EXIT
          LDN    1
          STML   CEPR        DEFAULT TO RETRY IN PROGRESS
          LDDL   BC+BCDA     ANALYSIS CODE
          LPC    0#FF
          SBN    DARP        RETRY IN PROGRESS
          ZJN    DEPX        EXIT IF RETRY IN PROGRESS
          LDN    2
          STML   CEPR
          UJN    DEPX        EXIT
          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY (960 ACTIONS I)
          SPACE  4,10
**        TDE - TEST FOR DUPLICATE LOGGED ENTRIES.
*
*         METHOD       TEST FOR A MATCH BETWEEN NEW ERROR
*                      AND PREVIOUS ERROR WITH NO LENGTH
*                      ADJUSTMENT.
*
*         ENTRY  NA.
*
*         USES   LBUF, MFLG, TRMF.
*
*         CALLS  CFM.
*
*         EXIT   MFLG <> 0 = NO MATCH.

          ROUTINE TDE        ENTRY/EXIT
          LDML   LBUF
          RJM    CFM         TEST FOR MATCH
          STML   MFLG        MATCH FLAG
          UJP    TDEX        EXIT

*COPY CTP$DFT_LOG_ERROR_CHECK_MATCH
*COPY CTP$DFT_MDB_LOGGING_ROUTINES

          EJECT
**        LSR -  LOG SOFT REGISTERS.
*
*         ENTRY  (RS) HAS CURRENT R-REGISTER POINTER.
*
*         USES   W5, RS-RS+3, MRVAL, RN, CM.
*
*         CALLS  RPM, PAC, PCM

          ROUTINE LSR        ENTRY/EXIT
          LDD    RS
          STD    T2          SAVE INITIAL OFFSET
          LDN    0           TABLE INDEX
          STDL   W5
 LSR1     LDML   LSRA,W5     REGISTER FILE
          STDL   RN
          CALL   RPM         READ CONTENTS
          LDM    MACF        ERROR FLAG
          NJP    LSRX        EXIT IF SET
          RJM    PAC         PACK DATA IN MRVAL
          AOML   LTOL        INCREMENT AMOUNT TO LOG COUNTER
          LRD    RS+1        LOAD R REGISTER
          AOD    RS
          ADC    RR          ACTIVATE R-REGISTER
          CWML   MRVAL,ON    WRITE ONE WORD TO MDB
          AODL   W5          INCREMENT INDEX
          SBN    LOD.SR-1
          ZJN    LSR2        IF DONE
          UJP    LSR1        READ NEXT REGISTER

 LSR2     LDD    T2          SAVED OFFSET
          ADN    2           INCREMENT TO SECOND WORD (P)
          ADC    RR          ACTIVATE R-REGISTER
          CRML   PSAVE,ON    SAVE P REGISTER FOR FUTURE USE
          UJP    LSRX        EXIT

 LSRA     BSS    0           TABLE FOR SOFT REGISTERS
          CON    PVCM        VIRTUAL MACHINE CAPABILITY
          CON    PPRG        P-ADDRESS
          CON    PMPS        MPS
          CON    PMCR        MCR
          CON    PUCR        UCR
          CON    PUPR        UTP
          CON    PSTL        SEGMENT TABLE LENGTH
          CON    PSTA        SEGMENT TABLE ADDRESS
          CON    PBCR        BASE CONSTANT
          CON    PPTA        PAGE TABLE ADDRESS
          CON    PPTL        PAGE TABLE LENGTH
          CON    PPSM        PAGE SIZE MASK
          CON    PMDF        MODEL DEPENDENT FLAGS
          CON    PMMR        MTR MASK
          CON    PJPS        JPS
          CON    PSIT        SYSTEM INTERVAL TIMER
          CON    PKBP        KEYPOINT BUFFER POINTER
          CON    PTPE        TRAP ENABLE
          CON    PTRP        TRAP POINTER
          CON    PDLP        DEBUG LIST PTR
          CON    PKPM        KEYPOINT MSK
          CON    PPIT        PROCESS INTERVAL TIMER
          CON    PCCF        CRITICAL FRAME FLAG
          CON    POCF        ON CONDITION FLAG
          CON    PDBI        DEBUG INDEX
          CON    PDBM        DEBUG MASK
          CON    PUSM        USER MASK
          EJECT
**        LRF -  LOG REGISTER FILE.
*
*         ENTRY  (RS) SET UP FOR MODEL DEPENDENT BUFFER ACCESS.
*
*         CALLS  PAC, RPM.

          ROUTINE LRF        ENTRY/EXIT
          LRD    RS+1        LOAD R REGISTER
          LDN    0           INDEX
          STML   LRFA        SAVE
 LRF1     RDMEM  RF.FWA,LRFA,,,8,TC.RGU        READ WORD
          ZJP    LRF2        IF READ COMPLETED
          STM    MACF
          FUNCMR HBUF+CPRPC,MRMC    MASTER CLEAR PROCESSOR
          SETDAN (EPCH,DAMCH)       SET NEW ANALYSIS CODE
          UJP    LRFX        EXIT
 LRF2     BSS    0
          RJM    PAC         PACK DATA INTO MRVAL
          AOML   LTOL        INCREMENT MDB COUNTER
          AOD    RS
          ADC    RR          ACTIVATE R-REGISTER
          CWML   MRVAL,ON    WRITE TO MDB
          AOML   LRFA        UPDATE READ INDEX
          LMC    RFLOG
          ZJP    LRFX        EXIT IF DONE
          UJP    LRF1        GET NEXT WORD

 LRFA     CON    0           OFFSET FOR READING
          EJECT
**        LNE -  LOG NEW ERROR.
*
*         CALLS  RPM, PAC, WSH, CLE.
*
*         USES   T2, RN, MRVAL, SHWD, RS.

          ROUTINE LNE        ENTRY/EXIT
          LDN    9D
          STDL   T2          SAVE INDEX
 LNE1     LDML   LNEA,T2     GET REGISTER NUMBER
          STDL   RN
          CALL   RPM         READ REGISTER CONTENTS
          LDM    MACF        ERROR FLAG
          NJP    LNEX        IF ERROR
          RJM    PAC         PACK DATA INTO MRVAL
          LDML   MRVAL
          ADML   MRVAL+1
          ADML   MRVAL+2
          ADML   MRVAL+3
          NJN    LNE2        IF ERROR
          SODL   T2
          PJN    LNE1        READ NEXT REGISTER
          UJP    LNEX        FINISHED, NO ERROR

*         WRITE SUBHEADER WORD

 LNE2     LDC    SHWD
          RJM    CLR         CLEAR CM FOR WRITE OF SUBHEADER
          LDN    SH.EL       TYPE CODE
          STML   SHWD+3
          LDN    LOD.EL      WORDS TO LOG
          STML   SHWD
          CALL   WSH         WRITE SUBHEADER WORD
          LDN    0
          STD    T2
 LNE3     LDML   LNEA,T2
          STDL   RN
          CALL   RPM         READ REGISTER
          LDM    MACF        ERROR FLAG
          NJP    LNEX        IF ERROR
          RJM    PAC         PACK DATA INTO MRVAL
          AOML   LTOL        INCREMENT AMOUNT TO LOG COUNTER
          LRD    RS+1        LOAD R REGISTER
          AOD    RS
          ADC    RR          ACTIVATE R-REGISTER
          CWML   MRVAL,ON    WRITE TO MDB
          AODL   T2          BUMP INDEX
          SBN    LOD.EL-1
          NJN    LNE3        DO NEXT REGISTER

 LNE4     CALL   CLE         CLEAR ERRORS
          UJP    LNEX        EXIT

 LNEA     BSS    0           LIST OF PFS REGISTERS
          CON    PPFS
          CON    PPFS+1
          CON    PPFS+2
          CON    PPFS+3
          CON    PPFS+4
          CON    PPFS+5
          CON    PPFS+6
          CON    PPFS+7
          CON    PPFS+10
          CON    PPFS+11
          EJECT
**        LEP -  LOG EXCHANGE PACKAGE.
*                CALL ROUTINE TO FIX EXCHANGE PACKAGE.  READ
*                EXCHANGE PACKAGE FROM CENTRAL MEMORY AND
*                LOG TO MODEL DEPENDENT BUFFER.
*
*         ENTRY  NONE.
*
*         USES   RDATA, MRVAL, SHWD, T4, W4-W6, RN.
*
*         CALLS  FEP, CLR, WSH, LWA, WMB.

          ROUTINE LEP        ENTRY/EXIT
          RJM    FEP         FIX EXCHANGE PACKAGE
          LDML   BCWF        LOGGING FLAG
          SBN    2
          ZJP    LEP4        IF BUFFER NOT AVAILABLE
          LDN    HDRP        DFT CONTROL WORD PTR
          RJM    IDA
          CRDL   CM          READ
          LDDL   CM+DHFLG
          SHN    21-DH.FD
          MJP    LEP4        IF NON-DEDICATED
          LDC    SHWD
          RJM    CLR         CLEAR CM FOR WRITE OF SUBHEADER
          LDN    SH.JEP      EXCHANGE PACKAGE
          STML   SHWD+3
          LDN    LOD.JEP     WORDS TO LOG
          STML   SHWD
          CALL   WSH         BUILD SUBHEADER WORD
          LDN    LOD.JEP-1   INDEX
          STD    T4
          LDC    EPBA
          RJM    LWA         SET UP R-REGISTER FOR XP READ

*         TRANSFER EXCHANGE PACKAGE TO MDB

 LEP2     CRML   MRVAL,ON    READ XP WORD
          RJM    WMB         WRITE TO MODEL DEPENDENT BUFFER
          SOD    T4
          ZJN    LEP4        IF DONE
          LRD    W4          RESET R-REG TO XP
          AOD    W6
          ADC    RR
          UJN    LEP2        READ NEXT WORD

 LEP4     BSS    0
          ZJP    LEPX        EXIT IF DUE ALREADY SET
          EJECT
**        FEP -  FIX EXCHANGE PACKAGE.
*                CLEAR PND BIT IN EXCHANGE PKG IF ERROR IS
*                JOB HALT. IF ERROR NOT SOFTWARE ERROR, SET
*                MCR BIT 48 IN EXCHANGE PACKAGE.  WRITE P
*                OF ERROR IN EXCHANGE PACKAGE IN CASE IT WAS
*                LOST DURING MASTER CLEAR.
*
*         ENTRY  NONE.
*
*         USES   T1, RDATA, MRVAL.
*
*         CALLS  HAC, LWA, SPB, RMR, SAC.

 FEP      SUBR               ENTRY/EXIT

*         SET PP BOUNDS AND MEMORY BOUNDS

          RJM    HAC         HALT ALL OTHER PROCESSORS
          LDC    EPBA
          RJM    LWA         SET UP R-REGISTER FOR XP READ
          RJM    SPB         SET PP BOUNDS
          LDN    MBRG
          STDL   RN
          LDML   CMCC
          RJM    RMR         READ MEMORY BOUNDS REGISTER
          LDML   RDATA
          STML   FEPA        (FEPA)=MEMORY BOUNDS, BYTE 0
          LPC    0#BF        DISABLE MEM BOUNDS
          STML   RDATA
          WRITMR RDATA,CMCC,MBRG
          LRD    W4

*         CLEAR PND IF NECESSARY

          LDDL   BC+BCDA     ANALYSIS CODE
          LPC    0#FF
          SBN    DAUHV
          NJN    FEP1        IF NOT JOB HALT VECTOR
          LDD    W6          OFFSET
          ADN    2           WORD TWO OF JOB XP
          ADC    RR
          CRML   MRVAL,ON    READ WORD 2
          LDML   MRVAL
          LPC    0#EFFF
          STML   MRVAL       CLEAR PND BIT
          LDD    W6
          ADN    2
          ADC    RR
          CWML   MRVAL,ON    WRITE BACK TO XP

*         SET BIT 48 OF MCR IF NECESSARY

 FEP1     BSS    0
          LDDL   BC+BCDA     ANALYSIS CODE
          LPC    0#FF
          SBN    DASWH       SOFTWARE ERROR
          ZJP    FEP2        DONT SET DUE
          LDD    W6          OFFSET
          ADN    6           READ WORD 6 OF JOB XP
          ADC    RR
          CRML   MRVAL,ON    READ WORD 2
          LDML   MRVAL
          LPC    0#8000
          NJP    FEP2        IF DUE ALREADY SET
          LDC    0#8000
          RAML   MRVAL       SET BIT IN EXCH PKG
          LDD    W6
          ADN    6
          ADC    RR
          CWML   MRVAL,ON    WRITE BACK TO XP

*         RESTORE P IN EXCHANGE PACKAGE

 FEP2     BSS    0
          LDD    W6
          ADC    RR
          CWML   PSAVE,ON    WRITE P TO EXCH PKG

*         RESTORE PP AND MEMORY BOUNDS

 FEP3     BSS    0
          LDML   FEPA
          STML   RDATA
          WRITMR RDATA,CMCC,MBRG
          LRD    DP+1        ENSURE CORRECT BOUNDS
          RJM    SPB         RESTORE PP BOUNDS
          LDML   HBUF+CPRPC
          RJM    SAC         START OTHER PROCESSORS
          UJP    FEPX        RETURN

 FEPA     CON    0
          EJECT
**        WPC -  WRITE PROGRAM CONTENTS.
*
*         METHOD TRANSLATE P FROM A PVA TO AN RMA.
*                WRITE RESPECTIVE PTE TO MDB.  ADD
*                AND SUBTRACT 5 WORDS ON EACH SIDE OF
*                P. IF A PAGE BOUNDARY IS CROSSED, THE
*                APPROPRIATE ROUTINE IS CALLED. OTHERWISE,
*                LOG THE 5 INSTRUCTIONS ON EACH SIDE OF
*                P (INCLUDING P) TO THE MDB.
*
*         ENTRY  NONE.
*
*         CALLS  PVC, MSA, SPT, WRZ, RWP, GPP, GNP, WMB.

          ROUTINE WPC        ENTRY/EXIT
          RJM    PVC         PRESET VIRTUAL CONSTANTS
          RJM    MSA         MAKE SYSTEM VIRTUAL ADDRESS
          ZJP    WPC3        IF NOT VALID
          AOML   LTOL        BUMP MDB COUNTER
          AOD    RS
          LRD    RS+1
          ADC    RR          ACTIVATE R-REGISTER
          CWDL   W0          WRITE SEG TABL ENTRY TO MDB
          RJM    SPT         SEARCH PAGE TABLE
          ZJP    WPC2        IF PAGE MISS

*         SAVE RMA

          STDL   T3
          SRD    T1
          LDDL   T1
          STML   WPCA        SAVE UPPER 10 BITS
          LDDL   T2
          STML   WPCA+1      SAVE MID 12 BITS

*         WRITE PTE TO MODEL DEPENDENT BUFFER

          AOML   LTOL        INCREMENT LENGTH TO LOG COUNTER
          AOD    RS          INCREMENT MDB ADDRESS
          LRD    RS+1
          ADC    RR
          CWML   SPTJ,ON     WRITE PTE TO MDB

*         CHECK PAGE BOUNDARIES

          LDML   PSMV1
          LPML   MSAA+3
          SHN    -3
          STML   WPCB        PAGE OFFSET (IN WORDS)
          SBN    5
          MJN    WPC0
          ADN    11D
          STDL   T4          PAGE OFFSET + 6 WORDS
          LDML   PSMV
          LMC    0#7F
          SHN    6
          LPML   T4          MASK FOR OVERFLOW
          NJN    WPC1        IF CROSSING BOTTOM OF PAGE BDRY

*         WRITE 11 WORDS FROM 1 PAGE TO MDB

          LDN    1
          RJM    WRZ         WRITE ZEROS TO 2ND PTE
          LDN    11D         NUMBER OF WORDS TO WRITE
          STDL   W4
          LDDL   T3
          SBN    5
          RJM    RWP         WRITE PROGRAM CONTENTS TO MDB
          LJM    WPCX

 WPC0     RJM    GPP         GET PREVIOUS PAGE
          LJM    WPCX

 WPC1     LDDL   T4          PO + 6
          LPN    0#3F
          STDL   T4          NUMBER OF WORDS TO READ FROM NEXT PAGE
          RJM    GNP         GET NEXT PAGE
          LJM    WPCX

 WPC2     LDN    12D
          STDL   T2
          UJP    WPC4

 WPC3     LDN    13D
          STDL   T2
 WPC4     LDC    0#FFFF
          STML   MRVAL
          STML   MRVAL+1
          STML   MRVAL+2
          STML   MRVAL+3
          RJM    WMB         WRITE ALL F'S TO MDB
          LDDL   T2
          RJM    WRZ         WRITE ALL ZEROS
          LJM    WPCX        EXIT

 WPCA     CON    0,0,0       STORES RMA FOR P
 WPCB     CON    0           PAGE OFFSET FOR P
          EJECT
**        MSA -  MAKE SYSTEM VIRTUAL ADDRESS.
*
*         ENTRY  NONE
*
*         EXIT   (CM - CM+2) = SYSTEM VIRTUAL ADDRESS.
*                (W0 - W3) = SEGMENT TABLE ENTRY.
*
*         USES   W0-W6, T1-T4, CM.
*
*         CALLS  LWA.
*
*         MACROS NONE.


 MSA1     LDN    0           FLAG INVALID/MISSING SEGMENT

 MSA      SUBR               ENTRY/EXIT
          LDML   PSAVE+1     RING AND SEG NUMBER OF P-REG
          LPC    0#FFF       ZERO OUT RING NUMBER
          STML   MSAA+1
          LDML   PSAVE+3
          LPN    BOB         BYTE OFFSET BITS
          STML   MSAB        (MSAB) = BYTE OFFSET
          LDML   PSAVE+3
          SCN    BOB
          STML   MSAA+3      CHANGE TO WORD BOUNDARY
          LDML   PSAVE+2
          STML   MSAA+2
          LDML   STAV        SEGMENT TABLE ADDRESS
          STD    T2
          LDML   STAV+1
          STDL   T3          SEGMENT TABLE ADDRESS
          LDML   STLV        SEGMENT TABLE LENGTH
          SBML   MSAA+1
          MJP    MSA1        IF NOT A VALID SEGMENT
          LDDL   T3          FORM WORD ADDRESS FOR LWA
          SHN    -3
          STDL   T3
          LDD    T2
          LPN    7
          SHN    13D
          RADL   T3
          LDDL   T2
          SHN    -3
          STDL   T2
          LDN    T2
          RJM    LWA         LOAD ADDRESS OF SEGMENT TABLE
          ADML   MSAA+1      ADD SEGMENT OF INTEREST
          CRDL   W0          FETCH ASID
          LDDL   W0
          LPC    0#8000
          ZJP    MSA1        IF INVALID
          LDDL   W1
          ZJP    MSA1        IF NOT A VALID ASID
          STDL   CM          SAVE ASID
          LDML   MSAA+2      COPY REMAINDER OF PVA
          STDL   CM+1
          LDML   MSAA+3
          STDL   CM+2
          LDN    1
          UJP    MSAX        RETURN

 MSAA     BSSZ   4
 MSAB     CON    0

*COPY CTP$DFT_PVA_TO_RMA_ROUTINES

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY (960 ACTIONS II)
          SPACE  4,10
**        RCM -  RELOAD SOFT CONTROL MEMORIES.
*                READ IN 2AP (CTI) TO RELOAD ALL CONTROL MEMORIES.
*                CHECK SUCCESS OF RELOAD.  IF SUCCESSFUL, EXIT.  IF
*                NOT, SWEEP MEMORIES TO LOCATE FAILING ADDRESS AND
*                WRITE ADDRESS AND ASSOCIATED PFS REGISTER TO MDB.
*
*         ENTRY  CTIB DEFAULTS TO ALL MEMORIES TO RELOAD
*
*         CALLS  ECM, SCM, LSC, SDB.

          ROUTINE RCM        ENTRY / EXIT

*         SAVE R-REGISTER

          LDD    RS
          STM    RDATA
          LDD    RS+1
          STM    RDATA+1
          LDD    RS+2
          STM    RDATA+2
          LDDL   BC          SAVE ANALYSIS CODE
          STML   RDATA+4
          LDDL   BC+1
          STML   RDATA+5
          LDDL   BC+2
          STML   RDATA+6
          LDDL   BC+3
          STML   RDATA+7

*         SET UP CALL BLOCK FOR CTI

          LDC    0           (SHOULD BE 1F HEX - TEMP DISABLED)
          STML   CTIB
          LDN    25B
          STML   CALB        CTI FUNCTION
          LDML   CPUO
          STML   CALB+1      CPU ORDINAL
          LDML   CTIB
          STML   CALB+2      BITS SPECIFYING MEMORIES

*         READ IN 2AP AND EXECUTE

***       RJM    PFC         EXECUTE CIP MODULE (TEMP DISABLED)

*         RESTORE R-REGISTER

          LDM    RDATA
          STD    RS
          LDM    RDATA+1
          STD    RS+1
          LDM    RDATA+2
          STD    RS+2
          LRD    RS+1
          LDML   RDATA+4     RESTORE ANALYSIS CODE
          STDL   BC
          LDML   RDATA+5
          STDL   BC+1
          LDML   RDATA+6
          STDL   BC+2
          LDML   RDATA+7
          STDL   BC+3

*         ANALYZE RELOAD

          LDML   CALB+2
          STML   CTIBR       SAVE RETURNED RESULTS
          ZJP    RCM5        IF RELOAD SUCCESSFUL
          LDML   BCWF        LOGGING FLAG
          SBN    2
          ZJP    RCM5        IF BUFFER NOT AVAILABLE
          LDN    HDRP        DFT CONTROL WORD PTR
          RJM    IDA
          CRDL   CM          READ
          LDDL   CM+DHFLG
          SHN    21-DH.FD
          MJP    RCM5        IF NON-DEDICATED
          LDDL   BC+BCDA     DFT ANALYSIS CODE
          LPC    0#FF        CODE ONLY
          SBN    DARP        RETRY IN PROGRESS
          NJP    RCM0        IF NOT RETRY
          LDML   RCTR        RETRY COUNTER
          SBN    2
          PJP    RCM5        IF NOT FIRST TIME

*         CHECK EACH MEMORY

 RCM0     CALL   SDB         SET SWEEP BIT IN DEC
          LDM    MACF        ERROR FLAG
          NJP    RCM6        IF SET
          LDN    0
          STM    SHWF        INDEX
          LDML   CTIBR
          SHN    21-4
          PJN    RCM1        IF BIT NOT SET
          LDN    0           INDEX FOR SWEEP ROUTINE
          RJM    SCM         SWEEP CONTROL MEMORY
          ZJN    RCM1        IF DID NOT SEE ERROR AGAIN
          LDM    MACF        ERROR FLAG
          NJP    RCM6        IF ERROR
          CALL   LSC         LOG INFORMATION TO MDB
 RCM1     LDML   CTIBR
          SHN    21-3
          PJN    RCM2        IF BIT NOT SET
          LDN    1           INDEX FOR SWEEP ROUTINE
          RJM    SCM         SWEEP CONTROL MEMORY
          ZJN    RCM2        IF DID NOT SEE ERROR AGAIN
          LDM    MACF        ERROR FLAG
          NJP    RCM6        IF ERROR
          CALL   LSC         LOG INFORMATION TO MDB
 RCM2     LDML   CTIBR
          SHN    21-2
          PJN    RCM3        IF BIT NOT SET
          LDN    2           INDEX FOR SWEEP ROUTINE
          RJM    SCM         SWEEP CONTROL MEMORY
          ZJN    RCM3        IF DID NOT SEE ERROR AGAIN
          LDM    MACF        ERROR FLAG
          NJP    RCM6        IF ERROR
          CALL   LSC         LOG INFORMATION TO MDB
 RCM3     LDML   CTIBR
          SHN    21-1
          PJN    RCM4        IF BIT NOT SET
          LDN    3           INDEX FOR SWEEP ROUTINE
          RJM    SCM         SWEEP CONTROL MEMORY
          ZJN    RCM4        IF DID NOT SEE ERROR AGAIN
          LDM    MACF        ERROR FLAG
          NJP    RCM6        IF ERROR
          CALL   LSC         LOG INFORMATION TO MDB
 RCM4     LDML   CTIBR
          SHN    21-0
          PJN    RCM5        IF BIT NOT SET
          LDN    4           INDEX FOR SWEEP ROUTINE
          RJM    SCM         SWEEP CONTROL MEMORY
          ZJN    RCM5        IF DID NOT SEE ERROR AGAIN
          LDM    MACF        ERROR FLAG
          NJP    RCM6        IF ERROR
          CALL   LSC         LOG INFORMATION TO MDB
 RCM5     CALL   SMA         RELOAD MAR TO ORIG VALUE
          LDM    MACF        ERROR FLAG
          NJN    RCM6        IF ERROR
          CALL   CDB         CLEAR SWEEP BIT IN DEC REG
          LDM    MACF        ERROR FLAG
          ZJP    RCMX        EXIT IF CLEAR
 RCM6     LDN    1
          STM    TERT        TERMINATE ACTION LIST
          SETDAC MCHP        NEW ACTION LIST
          LJM    RCMX        EXIT
          EJECT
**        SCM -  SWEEP SOFT CONTROL MEMORIES.
*                SWEEP INDICATED MEMORY AND LOCATE FAILING ADDRESS.
*
*         ENTRY  (A) = INDEX TO DETERMINE WHICH MEMORY TO SWEEP.
*
*         CALLS  AMR, CMI, PAC, RPM.
*
*         EXIT   (A) = 0 IF NO NEW PARITY ERROR OCCURRED
*                MRVAL = ASSOCIATED PFS REGISTER VALUE
*                FAIL = FAILING ADDRESS IF SWEEP DETECTED ERROR
*                (SN) = CODE (INDEX) FOR FAILING MEMORY

 SCM      SUBR               ENTRY / EXIT
          STDL   SN          SAVE OFFSET TO TABLES
          LDM    HBUF+CPRPC
          STDL   EC
          FUNCMR ,MRCE       CLEAR ERRORS (CPU)
          LDN    0
          STML   FAIL        INITIALIZE ADDRESS OFFSET
 SCM2     LDML   SCMA,SN     LOAD STARTING ADDRESS
          ADML   FAIL        ADD OFFSET
          STDL   RN
          LDDL   SN
          NJN    SCM2.5      IF NOT CONTROL STORE
          LDN    0
          STML   SMAA+6
          STML   SMAA+7
          WRITMR SMAA,HBUF+CPRPC,PCSA   SET MAR TO ZERO
 SCM2.5   BSS    0

          EXITMR SCM3

          LDM    HBUF+HDRPC  FORM FUNCTION WORD
          ADC    MRRD
          ADML   SCMB,SN     ADD TYPE CODE
          RJM    AMR         ACCESS MNTCE CHANNEL
          LDDL   SN
          NJN    SCM2.6      IF NOT CONTROL STORE
          LDN    16D         BYTE COUNT FOR CS
          UJN    SCM2.7      CONTINUE
 SCM2.6   LDN    1           BYTE COUNT FOR ALL OTHERS
 SCM2.7   IAM    SCMI,MR     BLOCK INPUT - READ MEMORY
          RJM    CMI         CLEAR MNTCE INTERLOCK

 SCM3     EXITMR FMR

          ZJN    SCM3.5      IF READ COMPLETED
          STM    MACF        SET ERROR FLAG
          UJP    SCMX        EXIT

 SCM3.5   LDML   SCME,SN     ASSOCIATED PFS REGISTER
          STDL   RN
          CALL   RPM         READ CONTENTS
          LDM    MACF        ERROR FLAG
          NJP    SCMX        EXIT IF SET
          RJM    PAC         PACK DATA INTO MRVAL
          LDN    3
          STD    T2
 SCM4     LDML   MRVAL,T2    PFS DATA
          STML   CM,T2       MOVE TO CM
          SOD    T2
          PJN    SCM4        MOVE 4 WORDS
          LDML   SCMC,SN     LOAD ADDRESS
          STDL   T1
          LDI    T1          LOAD INTERESTING BYTE
          LPML   SCMF,SN     MASK
          NJP    SCM6        IF ERROR
          LDD    SN
          SBN    2
          PJN    SCM5        IF NOT CS OR IFD
          LDML   SCMG,SN
          STDL   T1
          LDI    T1          LOAD INTERESTING BYTE
          LPML   SCMH,SN     MASK
          NJN    SCM6        IF ERROR
 SCM5     AOML   FAIL        UPDATE ADDRESS OFFSET
          SBML   SCMD,SN     SUBTRACT LENGTH + 1
          MJP    SCM2        IF NOT DONE SWEEPING
          LDN    0           SET FLAG  - NO ERROR
          UJP    SCMX        EXIT

 SCM6     LDML   SCMA,SN     STARTING ADDRESS OF MEMORY
          RAML   FAIL
          LDM    HBUF+CPRPC
          STDL   EC
          FUNCMR ,MRCE       CLEAR ERRORS (CPU)
          LDN    1           SET ERROR FLAG
          UJP    SCMX        EXIT

 SCMA     BSS    0           STARTING MEMORY ADRESSES
          CON    IDU.CSA
          CON    IFD.FWA
          CON    BDP.FWA
          CON    ACU.FWA
          CON    REF.FWA

 SCMB     BSS    0           TYPE CODES
          CON    TC.IDU
          CON    TC.IFD
          CON    TC.BDP
          CON    TC.ACU
          CON    TC.REF

 SCMC     BSS    0           OFFSETS TO CM (PFS DATA)
          CON    OCSM
          CON    OIFD
          CON    OBDP
          CON    OACU
          CON    OREF

 SCMD     BSS    0           MEMORY SIZE (LENGTH + 1)
          CON    0#800
          CON    0#200
          CON    0#600
          CON    0#100
          CON    0#100

 SCME     BSS    0           ASSOCIATED PFS REGISTERS
          CON    0#86
          CON    0#86
          CON    0#81
          CON    0#80
          CON    0#86

 SCMF     BSS    0           PFS REGISTER BIT MASKS
          CON    0#03FF         ( + FFFC)
          CON    0#00E0
          CON    0#1050
          CON    0#000E
          CON    0#0200

 SCMG     BSS    0           OFFSETS TO CM (EXTRA PFS DATA)
          CON    OCSM+1
          CON    OIFD+1

 SCMH     BSS    0           PFS REG BIT MASKS FOR 2ND WORD
          CON    0#FFFC
          CON    0#E000

 SCMI     BSS    0           BLOCK FOR READ OF SCM
          BSSZ   20          16 DECIMAL WORDS
          EJECT
**        LSC -  LOG SOFT CONTROL INFORMATION.
*                WRITE FAILING ADDRESSES AND ASSOCIATED PFS REGISTER
*                DATA TO THE MODEL DEPENDENT BUFFER.
*
*         ENTRY  FAIL = FAILING ADDRESS OF SOFT CONTROL MEMORY .
*                MRVAL = ASSOCIATED PFS REGISTER DATA.
*                SHWF = FLAG TO DETERMINE LOGGING OF SUBHEADER WORD.
*                       IF 0, LOG SUBHEADER.
*                SN = CODE FOR FAILING MEMORY
*
*         CALLS  CLR, BSW.

          ROUTINE LSC        ENTRY / EXIT
          LDM    SHWF
          NJP    LSC1        BRANCH IF SUBHEADER DONE
          LDN    HDRP        DFT CONTROL WORD PTR
          RJM    IDA
          CRDL   CM          READ TO CM
          LDDL   CM+DHFLG
          SHN    21-DH.FD
          PJN    LSC0        IF DEDICATED MODE
          CALL   LMB         CREATE HEADER WORD IN MDB
          LDML   BCWF
          SBN    2
          ZJP    LSCX        IF NO BUFFER AVAILABLE
 LSC0     LDC    SHWD
          RJM    CLR         CLEAR CM FOR WRITE OF SUBHEADER
          LDN    SH.CMPE     TYPE CODE
          STML   SHWD+3
          LDN    LOD.CMPE    WORDS TO LOG
          STML   SHWD
          CALL   WSH         WRITE SUBHEADER WORD
          AOM    SHWF
 LSC1     AOML   LTOL        BUMP MDB COUNTER
          LDN    CM
          RJM    CLR         CLEAR CM WORDS
          LDML   FAIL        FAILING ADDRESS
          STDL   CM+3
          LDD    SN          CODE TO INDICATE MEMORY
          STDL   CM
          LDML   SCME,SN     PFS REG ASSOCIATED
          STDL   CM+1        SAVE
          AOD    RS
          LRD    RS+1        SET UP R-REGISTER
          ADC    RR          ACTIVATE R-REGISTER
          CWDL   CM          WRITE FAILING ADDRESS
          AOML   LTOL
          AOD    RS
          ADC    RR
          CWML   MRVAL,ON    WRITE PFS REGISTER
          UJP    LSCX        EXIT
          EJECT
**        ELB -  END LOGGING TO MODEL DEPENDENT BUFFER.
*
*         METHOD CALL WSH ROUTINE AND INDICATE THAT LOGGING IS
*                COMPLETE BY SETTING SHWD+0 TO ZERO.  WSH THEN
*                UPDATES AMOUNT LOGGED IN MDB.
*
*         CALLS  WSH.

          ROUTINE ELB        ENTRY / EXIT
          LDML   BCWF        LOGGING FLAG
          SBN    2
          ZJP    ELBX        IF BUFFER NOT AVAILABLE
          LDN    HDRP        DFT CONTROL WORD PTR
          RJM    IDA
          CRDL   CM          READ
          LDDL   CM+DHFLG
          SHN    21-DH.FD
          MJP    ELBX        IF NON-DEDICATED
          LDN    0
          STML   SHWD        FLAG LENGTH = ZERO
          CALL   WSH         CALL ROUTINE TO WRITE AMOUNT LOGGED
          UJP    ELBX        EXIT
          SPACE  4,10
**        MCP -  MASTER CLEAR PROCESSOR.
*
          ROUTINE MCP        ENTRY / EXIT
          LDDL   BC+BCDA     ANALYSIS CODE
          LPC    0#FF        MASK
          SBN    DACCT       CPU/CM TIMEOUT
          NJP    MCPX        EXIT IF NOT TIMEOUT
          FUNCMR HBUF+CPRPC,MRMC   MASTER CLEAR PROCESSOR
          UJP    MCPX        EXIT
          EJECT
**        PJH - PROCESS JOB HALF-EXCHANGE OUT
*
*         METHOD IF MONITOR MODE, EXIT.  ELSE HALF EXCHANGE
*                OUT AND SAVE JOB EXCHANGE PACKAGE IN MDB.
*
*         CALLS  CLR, MCP, HEO, LEP.

          ROUTINE PJH        ENTRY/EXIT

          LDM    OLSS        STATUS SUMMARY
          LPN    MSSM
          NJP    PJHX        EXIT IF MONITOR MODE
          CALL   CLE         CLEAR ERRORS
          CALL   MCP         MASTER CLEAR PROCESSOR
          CALL   HEO         HALF EXCHANGE OUT
          CALL   LEP         LOG EXCHANGE PACKAGE TO MDB
          UJP    PJHX        EXIT ROUTINE
          SPACE  4,10
**        CSE - CLEAR SOFT ERROR FROM MCR
*
*         METHOD IF RETRY ERROR, CLEAR SOFT ERROR BIT IN
*                MONITOR CONDITION REGISTER.
*
*         CALLS  RPM.

          ROUTINE CSE        ENTRY/EXIT

          LDC    PMCR        MONITOR CONDITION REGISTER
          STD    RN
          CALL   RPM         READ REGISTER
          LDM    MACF        ERROR FLAG
          NJP    CSEX        EXIT IF ERROR
          LDML   RDATA+7
          LPC    0#FFFD      MASK OUT SOFT ERROR BIT
          STML   RDATA+7     REWRITE DATA
          WRITMR RDATA,HBUF+CPRPC,PMCR
          UJP    CSEX        EXIT ROUTINE
          EJECT
**        SDB -  SET DEC BIT 42.
*
*         USES   RDATA.
*
*         MACROS READMR, WRITMR.

          ROUTINE SDB        ENTRY / EXIT

          LDC    DEMR        DEC REGISTER
          STD    RN
          CALL   RPM         READ REGISTER
          LDM    MACF        ERROR FLAG
          NJP    SDBX        IF ERROR
          LDML   RDATA+5
          SCN    DEC42                      CLEAR BIT
          LMN    DEC42                      SET/CLEAR BIT
          STML   RDATA+5
          WRITMR RDATA,HBUF+HDRPC,DEMR      WRITE DEC REGISTER
          UJP    SDBX        EXIT
          SPACE  4,10
**        CDB -  CLEAR DEC BIT 42.
*
*         USES   RDATA.
*
*         MACROS READMR, WRITMR.

          ROUTINE CDB        ENTRY / EXIT

          LDC    DEMR        DEC REGISTER
          STD    RN
          CALL   RPM         READ REGISTER
          LDM    MACF
          NJP    CDBX        EXIT IF ERROR FLAG SET
          LDML   RDATA+5
          SCN    DEC42                      CLEAR BIT
          STML   RDATA+5
          WRITMR RDATA,HBUF+HDRPC,DEMR      WRITE DEC REGISTER
          UJP    CDBX        EXIT
          EJECT
**        SMA -  SET MICRAND ADDRESS REGISTER.
*                SET MICRAND ADDRESS REGISTER (MAR OR CSA) EQUAL
*                TO VALUE IN MARA.
*
*         ENTRY  MARA = VALUE TO WRITE INTO MAR (MICRAND ADDR REG).
*
*         MACROS WRITMR

          ROUTINE SMA        ENTRY / EXIT

          CALL   SDB         MAKE SURE DEC BIT 42 IS SET
          LDM    MACF        ERROR FLAG
          NJP    SMAX        EXIT IF SET
          LDML   MARA        GET VALUE TO WRITE
          STML   SMAA+7
          SHN    -10
          STM    SMAA+6
          WRITMR SMAA,HBUF+CPRPC,PCSA       SET CSA (MAR)
          UJP    SMAX        EXIT

SMAA      BSSZ   10B
          SPACE  4,10
**        RPM - READ PIP MAINTENANCE REGISTER.
*
*         ENTRY  (RN) = REGISTER NUMBER.
*                *RDATA - RDATA+7* NEEDS TO BE DEFINED.
*
*         EXIT   IF NO ERROR -
*                (RDATA - RDATA+7) IS REGISTER DATA IN BYTE FORMAT.
*                IF ERROR -
*                (MACF) = NON ZERO.  CPU IS MASTER CLEARED. SETDAN
*                IS EXECUTED TO CHANGE THE DFT ANALYSIS CODE TO '30'.
*

          ROUTINE RPM        ENTRY/EXIT

          LDM    HBUF+HDRPC    ELEMENT CODE
          STD    EC          SAVE ELEMENT CODE
          READMR RDATA       READ REGISTER INTO RDATA
          ZJP    RPMX        IF NO ERROR
          STM    MACF        IF READ DID NOT FINISH
          FUNCMR HBUF+CPRPC,MRMC    MASTER CLEAR PROCESSOR
          SETDAN (EPCH,DAMCH)       SET NEW ANALYSIS CODE
          UJP    RPMX        EXIT ROUTINE
          EJECT
**        CCM -  CHECK CPU MAC HUNG.
*                CHECK TO SET THAT LAST READ OVER THE MAC CHANNEL
*                COMPLETED BY CHECKING VALUE OF MACF CELL.
*
*         ENTRY  MACF = 0 IF LAST OPERATION COMPLETED
*                       1 IF LAST OPERATION HUNG BEFORE COMPLETION
*

          ROUTINE CCM        ENTRY / EXIT

          LDM    MACF        ERROR FLAG
          ZJP    CCMX        EXIT IF CLEAR
          LDN    1
          STM    TERT        TERMINATE CURRENT ACTION LIST
          SETDAC MCHP        NEW ACTION LIST
          UJP    CCMX        EXIT

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY (CREATE FAULT SYMPTOM CODE)
 GIE      SPACE  4,10
**        GIE - GENERATE INTERNAL ERROR FSC.
*
*         ENTRY  4XX, 5XX AND 6XX CODES ARE HANDLED.


          ROUTINE GIE

          LDDL   BC+BCDA
          LMC    0#240A
          NJN    GIE1        IF NOT SPECIAL 40A ANALYSIS
          LDM    CPUO
          STD    T1
          LDML   GSCA,T1
          UJN    GIE2        WRITE FAULT SYMPTOM CODE

 GIE1     LDM    IOUM
          STD    MD
          LDC    2RDI        IOU ELEMENT IDENTIFIER
          ADM    IOUN        NUMBER OF CURRENT IOU (LOWER 12-BITS ONLY)
 GIE2     RJM    WFC         WRITE FAULT SYMPTOM
          LJM    GIEX        RETURN
 WFC      SPACE  4,10
**        WFC - WRITE FAULT SYMPTOM CODE.
*
*         ENTRY  (A) = TWO CHARACTER ELEMENT IDENTIFIER.
*                (BC - BC+3) = BUFFER CONTROL WORD.
*                (RTP1) = 0 LOG TO SUPPORTIVE STATUS
*                       = 1 LOG TO NON REGISTER STATUS
*         USES   T1, CM - CM+3.
*
*         CALLS  CDA, CSD, IDA.


 WFC      SUBR               ENTRY/EXIT
          STDL   T1          SAVE ELEMENT IDENTIFIER
          LDN    3
          STM    WFCC        NUMBER OF HEADER WORDS FOR SUPPORTIVE STATUS
          LDM    RTP1        FLAG TO LOG TO SUPPORTIVE STATUS OR NON REGISTER STATUS
          ZJN    WFC1        IF TO LOG TO SUPPORTIVE STATUS
          AOM    WFCC        NON REGISTER STATUS HAS 1 MORE HEADER WORD THAN SUPPORTIVE
          LDN    NRSP        ADDRESS OF SCRATCH NON REGISTER STATUS BUFFER
          UJN    WFC2

*         READ FIRST WORD OF FAULT SYMPTOM CODE TO PRESERVE FIRST TWO BYTES.

 WFC1     LDN    SSBP        GET ADDRESS OF SCRATCH BUFFER
 WFC2     RJM    IDA
          CRDL   CM
          LDM    WFCC        SKIP HEADER WORDS
          RADL   CM
          LRD    CM+1
          ADC    RR
          CRML   WFCA,ON
          LDDL   T1          SET ELEMENT IDENTIFIER
          STML   WFCB

*         SET MODEL NUMBER.

          LDD    MD
          RJM    CDA         CONVERT TWO DIGITS TO ASCII
          STML   WFCB+1

*         SET SYMPTOM CODE.

          LDDL   BC+BCDA     DFT ANALYSIS
          SHN    -10
          LPN    0#F
          STD    T1
          LMN    4           4XX INTERNAL ERROR
          ZJN    WFC2.5      IF INTERNAL ERROR
          LDD    T1
          LMN    5           5XX INTERNAL ERROR
          ZJN    WFC2.5      IF INTERNAL ERROR
          LDD    T1
          LMN    6           6XX CODE
          ZJN    WFC2.5      IF INTERNAL ERROR
          UJN    WFC3

 WFC2.5   LDML   WFCB+2
          LPC    0#FF00
          STML   WFCB+2
          LDDL   BC+BCDA
          SHN    -10
          LPN    0#F
          RJM    CSD         CONVERT SINGLE DIGIT
          LMML   WFCB+2
          STML   WFCB+2
          LDDL   BC+BCDA
          LPC    0#FF
          RJM    CDA         CONVERT DIGITS TO ASCII
          STML   WFCB+3
          UJP    WFC4

 WFC3     LDDL   BC+BCDA     DFT ANALYSIS
          SHN    -4          ISOLATE FIRST TWO CHARACTERS
          LPC    377
          RJM    CDA         CONVERT TWO DIGITS TO ASCII
          STML   WFCB+2
          LDD    BC+BCDA     ISOLATE LAST CHARACTER
          LPN    17
          RJM    CSD         CONVERT SINGLE DIGIT TO ASCII
          SHN    10
          LMC    1R
          STML   WFCB+3

*         WRITE FAULT SYMPTOM CODE TO SCRATCH SUPPORTIVE STATUS BUFFER.

 WFC4     LDN    2           SET NUMBER OF CM WORDS TO WRITE
          STD    T1
          LDDL   CM          LOAD ADDRESS OF SCRATCH BUFFER
          ADC    RR
          CWML   WFCA,T1     WRITE TO SCRATCH BUFFER
          LJM    WFCX        RETURN

 WFCC     BSS    1
 WFCA     BSS    2           RESERVED AREA OF FAULT SYMPTOM CODE
 WFCB     DATA   12HDEMMZCC
 AFF      SPACE  4,10
**        AFF - ANALYSE FIRST FAILURE CAPTURE DATA
*
*         USES   T1-T6, CM.
*
*         MACROS USED   READMR
*
*         CALLS  RPM, FMB, AFD, FFB.
*
*         EXITS  (FSAC) = FAULT SYMPTOM ANALYSIS CODE

          ROUTINE AFF
          LDC    DEMR        DEC REGISTER
          STD    RN
          CALL   RPM         READ REGISTER
          LDM    MACF        ERROR FLAG
          ZJN    AFF0        IF NO ERROR
          LDN    1
          STM    TERT        TERMINATE CURRENT ACTION LIST
          SETDAC MCHI
          UJP    AFFX        EXIT
 AFF0     LDN    0
          STM    FLAG1
          STM    FLAG2
          STD    T1
          LDML   RDATA+4
          LPC    M3401
          ZJP    AFF9        FIRST FAILURE CAPTURE NOT ENABLED
          LDC    PPFS+7
          RJM    FMB         READ PFS REGISTER 87
          CRDL   CM
          LDDL   CM+1
          LPC    M1905
          ZJP    AFF10       NO BITS SET IN REG 87 (BITS 19-23)
          SHN    5
          UJN    AFF2

 AFF1     SHN    1           POSITION BIT
 AFF2     PJN    AFF3        IF BIT NOT SET
          SHN    1           REMOVE SET BIT
          LPC    0#3F800     ONLY KEEP UPPER BITS
          NJP    AFF8        IF MULTIPLE BITS SET
          LDM    AFFA,T1     LOAD BIT BEING ANALYZED
          STM    AFFE        SAVE
          LDM    AFFB,T1
          STD    T3          SAVE PFS REGISTER TO ANALYZE
          LDM    AFFD,T1
          STD    T4          SAVE INDEX TO MASK TABLE
          LDM    AFFF,T1
          STD    T6          SAVE INDEX TO MASK TABLE
          LDM    AFFC,T1
          STD    T1          SAVE LENGTH FOR FRU LISTS
          RJM    AFD         GO ANALYZE FAILURE DATA
          UJN    AFF4        CONTINUE

 AFF3     STDL   T2          SAVE POSITION OF BITS
          SHN    -2          SAVE BITS 17/18
          LPC    0#C000
          STDL   T5
          AOD    T1          BUMP COUNT OF BITS
          ADC    -5
          ZJP    AFFX        FINISHED
          LDDL   T5          BITS 17/18
          SHN    2
          RADL   T2          BITS 0-16
          UJP    AFF1        GO CHECK NEXT BIT

 AFF4     LDM    FLAG1
          ADM    FLAG2
          ZJN    AFF7        BOTH FLAGS ZERO
          SBN    1
          ZJN    AFF6
          SBN    1
          ZJN    AFF5
          UJN    AFF6
 AFF5     LDD    T3          PFS REGISTER NO
          SHN    8D          POSITION
          STML   FSAC        SAVE
          RJM    FFB         FIND FAILING BIT
          RAML   FSAC        SAVE
          UJP    AFFX

 AFF6     LDD    T3          PFS REGISTER NO
          SHN    8D          POSITION
          STML   FSAC        SAVE
          LDC    0#FF        CODE
          RAML   FSAC        SAVE
          UJP    AFFX

 AFF7     LDC    PPFS+7
          SHN    8D          POSITION
          STML   FSAC        SAVE
          LDM    AFFE        BIT ANALYZED
          RJM    CTD         CONVERT TO DECIMAL
          RAML   FSAC        SAVE
          UJP    AFFX        EXIT

 AFF8     LDC    PPFS+7
          SHN    8D          POSITION
          STML   FSAC        SAVE
          LDC    0#FF        CODE
          RAML   FSAC        SAVE
          UJP    AFFX        EXIT

 AFF9     LDC    0#FFFF      CODE FOR FFC DISABLED
          STML   FSAC
          UJP    AFFX        EXIT

 AFF10    LDC    PPFS+7      CODE 8700 FOR NOT BITS SET
          SHN    8D          POSITION 87
          STML   FSAC
          UJP    AFFX        EXIT

 AFFA     BSS    0           FIRST FAILURE CAPTURE BITS IN PFS 87
          CON    19D
          CON    20D
          CON    21D
          CON    22D
          CON    23D

 AFFB     BSS    0           FIRST FAILURE CAPTURE GROUPS
          CON    PPFS
          CON    PPFS+2
          CON    PPFS+4
          CON    PPFS+6
          CON    PPFS+8D

 AFFC     BSS    0           LENGTH OF MASK WORDS
          CON    60D
          CON    104D
          CON    140D
          CON    160D
          CON    176D

 AFFD     BSS    0           INDEX TO MASK TABLE
          CON    0
          CON    60D
          CON    104D
          CON    140D
          CON    160D

 AFFE     CON    0           FAILING BIT

 AFFF     BSS    0           INDEX TO MASK TABLE
          CON    0
          CON    8D
          CON    16D
          CON    24D
          CON    32D
          EJECT
**        AFD - ANALYSIS FAILURE DATA
*
*         ENTRY  T3 = PFS REGISTER TO READ
*                T1 = LENGTH OF FRU LIST DATA
*                T4 = OFFSET TO MASK TABLE
*                T6 = INDEX TO MASK TABLE
*
*         USES   T1-T7, CM.
*
*         EXIT   T3 = PFS WITH FAILING BIT
*                FLAG1/FLAG2 = FAILURE CODES
*                   0 = NO BITS SET
*                   1 = MULTIPLE BITS SET
*                   2 = ISOLATED TO FRU LIST

 AFD      SUBR               ENTRY/EXIT
          LDD    T4          OFFSET TO MASK TABLE
          STD    T5          SAVE
          STD    T7          SAVE
          LDN    0
          STD    T2
          STM    FLAG1       CLEAR FLAGS
          STM    FLAG2
 AFD1     LDDL   T3          PFS REGISTER TO READ
          RJM    FMB
          CRDL   CM          READ PFS REGISTER
 AFD2     LDML   CM,T2
          LPML   AFDD,T6     MASK OFF UNNECESSARY BITS
          STML   CM,T2
          AOD    T6
          AOD    T2
          SBN    4
          NJN    AFD2        DO FOR 4 PP WORDS
          LDN    0
          STD    T2
 AFD3     LDML   CM,T2       READ PFS DATA
          LPML   AFDB,T4     MASK INTERESTING BITS
          NJP    AFD6        BIT SET - CONTINUE
          AOD    T4
          AOD    T2
          SBN    4
          NJN    AFD3        CHECK ENTIRE PFS DATA
          LDN    0
          STD    T2
          LDDL   T5
          ADN    4
          STDL   T5
          STDL   T4
          SBDL   T1
          NJP    AFD3        TRY NEXT FRU LIST INFORMATION
          LDN    0
          STM    FLAG1       1ST PFS REG HAS NO BITS SET
          LDDL   T7
          STDL   T4          RESET FRU LIST INDEX
          STDL   T5
          AODL   T3          BUMP TO 2ND PFS REG IN SET
          RJM    FMB
          CRDL   CM          READ NEXT PFS REGISTER
 AFD4     LDML   CM,T2
          LPML   AFDD,T6     MASK OFF UNNECESSARY BITS
          STML   CM,T2
          AOD    T6
          AOD    T2
          SBN    4
          NJN    AFD4        DO FOR 4 PP WORDS
          LDN    0
          STD    T2
 AFD5     LDML   CM,T2       READ PFS DATA
          LPML   AFDC,T4     MASK INTERESTING BITS
          NJP    AFD12       BIT SET - CONTINUE
          AOD    T4
          AOD    T2
          SBN    4
          NJN    AFD5        CHECK ENTIRE PFS DATA
          LDN    0
          STD    T2
          LDDL   T4
          SBDL   T1
          NJP    AFD5        TRY NEXT FRU LIST INFORMATION
          LDN    0
          STM    FLAG2       2ND PFS REG HAS NO BITS SET
          UJP    AFDX        EXIT - FLAG1/FLAG2 = 0

 AFD6     LDN    0
          STD    T2          RESET PFS READ INDEX
          LDD    T5
          STD    T4          RESET MASK INDEX
 AFD7     LDML   AFDB,T4     SET IF ANY OTHER BIT NOT IN THIS
          LMC    0#FFFF         FRU LIST IS SET
          LPML   CM,T2       CHECK BITS NOT IN THIS FRU LIST
          ZJN    AFD8        NO BIT SET - CONTINUE
          LDN    1
          STM    FLAG1       FLAG 1ST PFS HAV MULTIPLE BITS SET
          UJP    AFDX        EXIT - FLAG 1 = 1, FLAG 2 = 0

 AFD8     AOD    T4
          AOD    T2
          SBN    4
          NJN    AFD7        CHECK ENTIRE PFS WORD
          AODL   T3
          RJM    FMB
          CRDL   CM          READ 2ND PFS IN SET
          LDN    0
          STD    T2
 AFD9     LDML   CM,T2
          LPML   AFDD,T6     MASK OFF UNNECESSARY BITS
          STML   CM,T2
          AOD    T6
          AOD    T2
          SBN    4
          NJN    AFD9        DO FOR 4 PP WORDS
          LDN    0
          STD    T2
          LDDL   T5
          STDL   T4          RESET FRU INDEX
 AFD10    LDML   AFDC,T4     CHECK 2ND PFS FOR BITS NOT
          LMC    0#FFFF          IN THIS FRU LIST SET
          LPML   CM,T2
          ZJN    AFD11       NO BITS SET - CONTINUE CHECK
          LDN    1
          STM    FLAG2       2ND PFS HAS MULTIPLE BITS SET
          UJP    AFDX        EXIT - FLAG1= 2, FLAG2 = 1

 AFD11    AOD    T4
          AOD    T2
          SBN    4
          NJN    AFD10       CHECK ENTIRE PFS DATA
          SOD    T3          RESET PFS TO 1ST OF SET
          LDN    2
          STM    FLAG1       FLAG 1ST PFS GOOD
          UJP    AFDX        EXIT - FLAG1 = 2, FLAG2 = 0

 AFD12    LDN    0
          STD    T2
          LDDL   T5
          STDL   T4          RESET FRU LIST INDEX
 AFD13    LDML   AFDC,T4     CHECK 2ND PFS FOR BITS NOT
          LMC    0#FFFF          IN THIS FRU LIST SET
          LPML   CM,T2
          ZJN    AFD14       NO BITS SET - CONTINUE CHECK
          LDN    1
          STM    FLAG2       2ND PFS HAS MULTIPLE BITS SET
          UJP    AFDX        EXIT - FLAG1= 0, FLAG2 = 1

 AFD14    AOD    T4
          AOD    T2
          SBN    4
          NJN    AFD13       CHECK ENTIRE PFS DATA
          LDN    2
          STM    FLAG2       FLAG 2ND PFS GOOD
          UJP    AFDX        EXIT - FLAG1 = 0, FLAG2 = 2

 FLAG1    CON    0
 FLAG2    CON    0

 AFDB     BSS    0           MASK FOR PFS REGS 80,82,84,86,88
          CON    0#3000
          CON    0#0000
          CON    0#F000
          CON    0#0000
          CON    0#0F00
          CON    0#FFFF
          CON    0#00F7
          CON    0#F801
          CON    0#00FE
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0001
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0C00
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0300
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0008
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0400
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0300
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#00FE
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
*         REGISTER 82
          CON    0#8000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#4000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#3000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0C00
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0300
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#00FF
          CON    0#0000
          CON    0#1FF0
          CON    0#0000
          CON    0#0000
          CON    0#F0FF
          CON    0#000F
          CON    0#E7FD
          CON    0#0000
          CON    0#0F00
          CON    0#E000
          CON    0#1000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0800
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0002
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
*         REGISTER 84
          CON    0#FFFF
          CON    0#FF80
          CON    0#0010
          CON    0#000F
          CON    0#0000
          CON    0#0070
          CON    0#CF1C
          CON    0#0000
          CON    0#0000
          CON    0#000F
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#3000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0080
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
*         REGISTER 86
          CON    0#3FFF
          CON    0#FFFC
          CON    0#FE00
          CON    0#0000
          CON    0#0000
          CON    0#0003
          CON    0#0000
          CON    0#00F0
          CON    0#0000
          CON    0#0000
          CON    0#0100
          CON    0#0000
          CON    0#C000
          CON    0#0000
          CON    0#00FF
          CON    0#FF0F
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
*         REGISTER 88
          CON    0#FFC0
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#003C
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0003
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000

 AFDC     BSS    0           MASKS FOR PFS REG 81,83,85,87,89
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#8FFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#7E00
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#80F0
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0100
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#000F
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#4000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#3000
          CON    0#0000
          CON    0#0000
*         PFS REGISTER 83
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#4000
          CON    0#0000
          CON    0#0000
          CON    0#FF00
          CON    0#9FFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#00FF
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#2000
          CON    0#0000
          CON    0#0000
*         PFS REGISTER 85
          CON    0#0007
          CON    0#8FFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#4000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#2000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#1000
          CON    0#0000
          CON    0#0000
          CON    0#FFF8
          CON    0#0000
          CON    0#0000
          CON    0#0000
*         PFS REGISTER 87
          CON    0#0000
          CON    0#4000
          CON    0#0000
          CON    0#0000
          CON    0#00F0
          CON    0#0400
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#FF0F
          CON    0#82FF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#0000
          CON    0#2000
          CON    0#0000
          CON    0#0000
*         PFS REGISTER 89
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#0000
          CON    0#FFFF
          CON    0#9FFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#0000
          CON    0#6000
          CON    0#0000
          CON    0#0000

 AFDD     BSS    0           MASKS TO IGNORE UNNECESSARY BITS
          CON    0#3FFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FF9C
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#C0FF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          CON    0#FFFF
          EJECT
**        FFB - FIND FAILING BIT
*
*         ENTRY  T3 = PFS REGISTER TO READ (80-89)
*
*         USES   T2-T4, CM.
*
*         CALLS  CTD
*
*         EXIT   T3 = PFS WITH FAILING BIT
*                (A) = FAILING BIT NUMBER IN DECIMAL
*                FLAG1/FLAG2 = FAILURE CODES

 FFB      SUBR               ENTRY/EXIT
          LDD    T3
          RJM    FMB         GET R-REGISTER POINTER
          CRDL   CM          READ TO CM
          LDDL   T3          PFS REGISTER
          LPN    17          SAVE BOTTOM 4 BITS
          SHN    2           MULTIPLY BY 4
          STD    T3          SAVE RESULT
          LDN    0           CLEAR INDEX
          STD    T4
 FFB0     LDML   CM,T4
          LPML   AFDD,T3     MASK OFF UNINTERESTING BITS
          STML   CM,T4       AND SAVE
          AOD    T3
          AOD    T4
          SBN    4
          NJN    FFB0        DO 4 PP WORDS
          LDN    0
          STD    T4          CLEAR INDEX
 FFB1     LDN    0
          STD    T2
          LDML   CM,T4       READ PART OF PFS
          SHN    1           POSITION FOR LOOP
          STML   FFBA+1      SAVE
          SHN    -2          SAVE BITS 17/18
          LPC    0#C000
          STML   FFBA
 FFB2     LDML   FFBA        LOAD DATA
          SHN    2           POSITION BITS 17/18
          RAML   FFBA+1
          SHN    1
          MJN    FFB3        IF BIT SET
          STML   FFBA+1      SAVE
          SHN    -2          SAVE BITS 17/18
          LPC    0#C000
          STML   FFBA
          AOD    T2          ELSE INCREMENT BIT COUNTER
          SBN    16
          NJN    FFB2        CONTINUE SEARCHING
          AOD    T4
          SBN    4
          NJN    FFB1        CHECK 4 WORDS
 FFB3     LDML   FFBB,T4
          ADD    T2          ADD OFFSET TO BIT COUNT
          RJM    CTD         CONVERT NUMBER TO DECIMAL
          UJP    FFBX

 FFBA     CON    0,0         TEMPORARY STORAGE
 FFBB     BSS    0           TABLE OF BIT OFFSETS
          CON    0
          CON    16D
          CON    32D
          CON    48D
          EJECT
**        CTD - CONVERT TO DECIMAL
*
*         ENTRY  (A) = TWO DIGIT OCTAL NUMBER TO CONVERT
*
*         USES   T3-T4.
*
*         EXIT   (A) = NUMBER IN DECIMAL

 CTD      SUBR               ENTRY/EXIT
          LPN    77B         KEEP ONLY 6 BITS
          STDL   T3          SAVE NUMBER
          LDN    0
          STDL   T4          CLEAR RESULT
 CTD1     LDDL   T3          LOAD NUMBER
          SBN    10D         SUBTRACT 10
          MJN    CTD2        IF NUMBER LESS THAN 10
          STDL   T3          SAVE DIFFERENCE
          LDN    16D         INCREMENTER
          RADL   T4          INCREMENT 10'S COUNTER
          UJN    CTD1        CONTINUE
 CTD2     LDDL   T3          LOAD REMAINDER
          RADL   T4          ADD TO 10'S COUNTER
          UJP    CTDX        RETURN

          EJECT
*
*         THIS CODE CONTAINS ROUTINES TO GENERATE AN IOU, CM
*         OR PROCESSOR FAULT SYMPTOM CODE AND STORE IT IN THE
*         SCRATCH SUPPORTIVE STATUS BUFFER.
 GSB      SPACE  4,10
**        GSB - GENERATE FAULT SYMPTOM CODE CONTAINING BLANKS.
*
*         USES   T1, CM - CM+3.
*
*         CALLS  IDA.


          ROUTINE  GSB

*         WRITE BLANK FAULT SYMPTOM CODE TO SCRATCH SUPPORTIVE STATUS BUFFER.

          LDN    2           SET NUMBER OF CM WORDS TO WRITE
          STD    T1
          LDN    SSBP        GET ADDRESS OF SCRATCH BUFFER
          RJM    IDA
          CRDL   CM
          LDN    3           SKIP HEADER WORDS
          RADL   CM
          LRD    CM+1
          ADC    RR
          CWML   GSBA,T1     WRITE TO SCRATCH BUFFER
          LJM    GSBX        RETURN

 GSBA     CON    0,0         RESERVED AREA OF FAULT SYMPTOM CODE
          DATA   C*            *
 GSC      SPACE  4,10
**        GSC - GENERATE FAULT SYMPTOM CODE FOR (CPU) PROCESSOR .
*
*         CALLS  WFC.
*
*         USES   T1.


          ROUTINE  GSC
          LDDL   BC+BCDA     GET THE ANALYSIS TO BE LOGGED
          SHN    -BC.ANP
          SBN    EPEN
          MJN    GSC1        IF NOT AN ENVIRONMENT OR LONG WARNING
          LDM    CPUO
          STD    T1
          LDML   GSCA,T1
          RJM    WFC         WRITE THE FAULT CODE
          LJM    GSCX        RETURN

 GSC1     LDM    CPUO        CPU OFFSET
          STD    T1
          LDML   GSCA,T1     GET PROCESSOR ELEMENT ID
          RJM    WPF         WRITE PROCESSOR FAULT SYMPTOM CODE
          LJM    GSCX        RETURN

 GSCA     BSS    0
          CON    2RDC        PROCESSOR 0
          CON    2RDD        PROCESSOR 1
          CON    2RDE        PROCESSOR 2
          CON    2RDF        PROCESSOR 3
          CON    2RDR        PROCESSOR 4
          CON    2RDS        PROCESSOR 5
          CON    2RDT        PROCESSOR 6
          CON    2RDU        PROCESSOR 7

 GSP      SPACE  4,10
**        GSP - GENERATE FAULT SYMPTOM CODE FOR PAGE MAP.
*         PAGE MAP IS VALID ONLY ON AN S0.  THEREFORE, THIS ROUTINE
*         GENERATES AN ERROR.
*
*         EXIT   TO *ERRH*.


          ROUTINE  GSP
          LDC    DAIE        624 - DFT INTERNAL ERROR
          STML   RTP1
          CALL   ERRH
 WPF      SPACE  4,10
**        WPF - WRITE PROCESSOR FAULT SYMPTOM CODE.
*
*         ENTRY  (A) = TWO CHARACTER ELEMENT IDENTIFIER.
*
*         USES   T1, CM - CM+3.
*
*         CALLS  CDA, IDA.


 WPF      SUBR               ENTRY/EXIT
          STML   WFCB        STORE ELEMENT IDENTIFIER

*         SET MODEL NUMBER.

          LDD    MD
          RJM    CDA         CONVERT TWO DIGITS TO ASCII
          STML   WFCB+1

*         SET SYMPTOM CODE.

          LDML   FSAC        FAULT SYMPTOM ANALYSIS CODE
          STD    CM
          SHN    -8D         ISOLATE FIRST TWO CHARACTERS
          LPC    377
          RJM    CDA         CONVERT TWO DIGITS TO ASCII
          STML   WFCB+2
          LDD    CM          ISOLATE LAST CHARACTER
          LPC    377
          RJM    CDA         CONVERT TWO DIGITS TO ASCII
          STML   WFCB+3

*         WRITE FAULT SYMPTOM CODE TO SCRATCH SUPPORTIVE STATUS BUFFER.

          LDN    2           SET NUMBER OF CM WORDS TO WRITE
          STD    T1
          LDN    SSBP        GET ADDRESS OF SCRATCH BUFFER
          RJM    IDA
          CRDL   CM
          LDN    3           SKIP HEADER WORDS
          RADL   CM
          LRD    CM+1
          ADC    RR
          CWML   WFCA,T1     WRITE TO SCRATCH BUFFER
          LJM    WPFX        RETURN
          SPACE  4,10
 GSI      SPACE  4,10
**        GSI - GENERATE FAULT SYMPTOM CODE FOR IOU.
*
*         THE ELEMENT IDENTIFIER USED IN THE FAULT SYMPTOM CODE DEPENDS ON
*         THE IOU ORDINAL:
*                I - IOU 0.
*                J - IOU 1.
*                K - IOU 2.
*                L - IOU 3.
*
*         CALLS  WFC.
 GSI      SPACE  4,10
**        GSI - GENERATE FAULT SYMPTOM CODE FOR IOU.
*
*         CALLS  WFC, *I4A*, *I4I*, *I4S*.


          ROUTINE  GSI

          LDDL   MD
          LMC    0#43
          ZJP    GSI4        IF MODEL 43 IOU
          LMN    0#44&0#43
          NJN    GSI1        IF NOT MODEL 44
          CALL   I4I         INTERFACE TO MODEL 44 IOU FSC COMMON DECK
 GSI0     LJM    GSIX        RETURN

 GSI1     LDDL   MD
          LMC    0#42
          NJN    GSI2        IF NOT MODEL 42 IOU
          CALL   I4S
          UJN    GSI0

 GSI2     LDDL   MD
          LMC    0#40
          NJN    GSI3        IF NOT MODEL 40 IOU
          CALL   I4A
          UJN    GSI0

 GSI3     LDC    2RDI        IOU ELEMENT IDENTIFIER
          RJM    WFC         WRITE FAULT SYMPTOM CODE
          LJM    GSIX        RETURN

 GSI4     CALL   I43
          UJN    GSI0

*copy     ctp$convert_digits_to_ascii
*copy     ctp$dft_write_fsc_to_buffer
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY (GENERATE CM FAULT CODE)
*COPY     CTP$DFT_GENERATE_960_MEMORY_FSC
*copy     ctp$convert_digits_to_ascii
*copy     ctp$dft_write_fsc_to_buffer

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (IOU MODEL 44 FSC DECK)
 I4I      SPACE  4,10
**        I4I - INTERFACE TO I4C FSC COMMON DECK.
*
*         CALLS  GS4.


          ROUTINE  I4I

          LDDL   BC+BCDA     GET ANALYSIS TO LOG
          SHN    -BC.ANP
          SBN    EPEN
          PJP    I4I2        IF ENVIRONMENT WARNING
          LDML   CPU0M       CPU0 MODEL NUMBER
          STML   CDIF
          LDC    IFS1
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+1,ON
          LDC    IFS2
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+5,ON
          LDC    CDIF        FWA OF INTERFACE BUFFER
          RJM    /IOUFLT4/IOUFLT4
 I4I1     LDC    2RDI        IOU ELEMENT IDENTIFIER
          ADM    IOUO        INCREMENT BY IOU ORDINAL
          RJM    WFS         WRITE FAULT SYMPTOM CODE TO SUPPORTIVE STATUS
          UJP    I4IX        RETURN

 I4I2     LDN    3
          STD    T1
 I4I3     LDML   I4IA,T1     GET CANNED ENVIRONMENT FAULT SYMPTOM CODE
          STML   CDIF,T1     STORE IN OUTPUT BUFFER
          SOD    T1
          PJN    I4I3        IF NOT DONE
          UJN    I4I1        LOG THE FAULT CODE

 I4IA     DATA   H*701     *
*COPY     CTP$DFT_MODEL_44_IOU_FSC
*copy     ctp$convert_digits_to_ascii
*copy     ctp$dft_generate_i4c_codes
*copy     ctp$dft_write_fsc_to_buffer
          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (IOU MODEL 43 FSC DECK)
 I43      SPACE  4,10
**        I43 - INTERFACE TO I43 FSC COMMON DECK.
*
*         CALLS  GS4.


          ROUTINE  I43

          LDDL   BC+BCDA     GET ANALYSIS TO LOG
          SHN    -BC.ANP
          SBN    EPEN
          PJP    I432        IF ENVIRONMENT WARNING
          LDML   CPU0M       CPU0 MODEL NUMBER
          STML   CDIF
          LDC    IFS1
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+1,ON
          LDC    IFS2
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+5,ON
          LDC    CDIF        FWA OF INTERFACE BUFFER
          RJM    IOU43       !!!DON THIS NEEDS A CHANGE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 I431     LDC    2RDI        IOU ELEMENT IDENTIFIER
          ADM    IOUO        INCREMENT BY IOU ORDINAL
          RJM    WFS         WRITE FAULT SYMPTOM CODE TO SUPPORTIVE STATUS
          UJP    I43X        RETURN

 I432     LDN    3
          STD    T1
 I433     LDML   I43A,T1     GET CANNED ENVIRONMENT FAULT SYMPTOM CODE
          STML   CDIF,T1     STORE IN OUTPUT BUFFER
          SOD    T1
          PJN    I433        IF NOT DONE
          UJN    I431        LOG THE FAULT CODE

 I43A     DATA   H*701     *

*         DON THE NEW COMMON DECK WILL GO HERE  *
                                                *
 IOU43    SUBR               REMOVE THIS!       *
          UJN    IOU43X      AND THIS!          *

*copy     ctp$convert_digits_to_ascii
*copy     ctp$dft_generate_i4c_codes
*copy     ctp$dft_write_fsc_to_buffer
          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY (GENERATE IOU MODEL 40 FSC)

 I4A      SPACE  4,10
**        I4A - INTERFACE TO I4A FSC COMMON DECK.
*


          ROUTINE  I4A

          LDDL   BC+BCDA     GET ANALYSIS TO LOG
          SHN    -BC.ANP
          SBN    EPEN
          PJP    I4A2        IF ENVIRONMENT WARNING
          LDML   CPU0M       CPU0 MODEL NUMBER
          STML   CDIF
          LDC    IFS1
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+1,ON
          LDC    IFS2
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+5,ON
          LDN    OIMR
          RJM    FMB         FIND REGISTER IN MAINTENANCE REGISTER SCRATCH
          CRDL   W0
          LDDL   W3
          SHN    21-7
          PJN    I4A0        IF NO CIO PPS PRESENT
          LDC    CIFS1
          RJM    FMB         FIND REGISTER IN MAINTENANCE REGISTER SCRATCH
          CRML   CDIF+9D,ON
          LDC    CIFS2
          RJM    FMB         FIND REGISTER IN MAINTENANCE REGISTER SCRATCH
          CRML   CDIF+13D,ON
 I4A0     LDC    CDIF        FWA OF INTERFACE BUFFER
          RJM    /IOUFLT0/IOUFLT0
 I4A1     LDC    2RDI        IOU ELEMENT IDENTIFIER
          ADM    IOUO        INCREMENT BY IOU ORDINAL
          RJM    WFS         WRITE FAULT SYMPTOM CODE TO SUPPORTIVE STATUS
          UJP    I4AX        RETURN

 I4A2     LDN    3
          STD    T1
 I4A3     LDML   I4AA,T1     GET CANNED ENVIRONMENT FAULT SYMPTOM CODE
          STML   CDIF,T1     STORE IN OUTPUT BUFFER
          SOD    T1
          PJN    I4A3        IF NOT DONE
          UJN    I4A1        LOG THE FAULT CODE

 I4AA     DATA   H*701     *


*copy     ctp$convert_digits_to_ascii
*copy     ctp$dft_generate_i4c_codes
*copy     ctp$dft_model_40_iou_fsc
*copy     ctp$dft_write_fsc_to_buffer

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY (GENERATE IOU MODEL 42 FSC)
 I4S      SPACE  4,10
**        I4S - INTERFACE TO I4S FSC COMMON DECK.
*
*         CALLS  GS4.


          ROUTINE  I4S

          LDDL   BC+BCDA     GET ANALYSIS TO LOG
          SHN    -BC.ANP
          SBN    EPEN
          PJP    I4S2        IF ENVIRONMENT WARNING
          LDML   CPU0M       CPU0 MODEL NUMBER
          STML   CDIF
          LDC    IFS1
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+1,ON
          LDC    IFS2
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+5,ON
          LDC    CDIF
          RJM    /IOUFLT2/IOUFLT2
 I4S1     LDC    2RDI        IOU ELEMENT IDENTIFIER
          ADM    IOUO        INCREMENT BY IOU ORDINAL
          RJM    WFS         WRITE FAULT SYMPTOM CODE TO SUPPORTIVE STATUS
          LJM    I4SX        RETURN

 I4S2     LDN    3
          STD    T1
 I4S3     LDML   I4SA,T1     GET CANNED ENVIRONMENT FAULT SYMPTOM CODE
          STML   CDIF,T1     STORE IN OUTPUT BUFFER
          SOD    T1
          PJN    I4S3        IF NOT DONE
          UJN    I4S1        LOG THE FAULT CODE

 I4SA     DATA   H*701     *

          QUAL   IOUFLT2
          COMMENT IOUFLT2 - IOU FAULT SYMPTOM CODE DECK *REL. LEVEL 780*
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
BITS      TITLE  IOU FAULT SYMPTOM CODE COMMON DECK
**        BITS - FAULT STATUS 1 TABLE MACRO
*
          PURGMAC  BITS
BITS      MACRO  BIT1,BIT2
+         VFD    16/BIT1,16/BIT2
BITS      ENDM
EQUATES   TITLE  IOUFLT2 COMMON DECK EQUATES
*         EQUATES FOR FAULT SYMPTOM CODES THAT DO NOT REQUIRE THE USE
*         OF THE CLUSTER CODE (A, B, C OR D).

CODE05    EQU    2R05        EQUATE FOR FAULT SYMPTOM CODE 05
CODE10    EQU    2R10        EQUATE FOR FAULT SYMPTOM CODE 10
CODE11    EQU    2R11        EQUATE FOR FAULT SYMPTOM CODE 11
CODE12    EQU    2R12        EQUATE FOR FAULT SYMPTOM CODE 12
CODE17    EQU    2R17        EQUATE FOR FAULT SYMPTOM CODE 17
CODE18    EQU    2R18        EQUATE FOR FAULT SYMPTOM CODE 18
CODE19    EQU    2R19        EQUATE FOR FAULT SYMPTOM CODE 19
CODE20    EQU    2R20        EQUATE FOR FAULT SYMPTOM CODE 20
CODE21    EQU    2R21        EQUATE FOR FAULT SYMPTOM CODE 21
CODE24    EQU    2R24        EQUATE FOR FAULT SYMPTOM CODE 24
CODE26    EQU    2R26        EQUATE FOR FAULT SYMPTOM CODE 26
CODE27    EQU    2R27        EQUATE FOR FAULT SYMPTOM CODE 27
CODE29    EQU    2R29        EQUATE FOR FAULT SYMPTOM CODE 29
CODE31    EQU    2R31        EQUATE FOR FAULT SYMPTOM CODE 31
CODE33    EQU    2R33        EQUATE FOR FAULT SYMPTOM CODE 33
CODE37    EQU    2R37        EQUATE FOR FAULT SYMPTOM CODE 37
CODE38    EQU    2R38        EQUATE FOR FAULT SYMPTOM CODE 38
CODE39    EQU    2R39        EQUATE FOR FAULT SYMPTOM CODE 39
CODE40    EQU    2R40        EQUATE FOR FAULT SYMPTOM CODE 40
CODE41    EQU    2R41        EQUATE FOR FAULT SYMPTOM CODE 41
CODE42    EQU    2R42        EQUATE FOR FAULT SYMPTOM CODE 42
CODE43    EQU    2R43        EQUATE FOR FAULT SYMPTOM CODE 43
CODE44    EQU    2R44        EQUATE FOR FAULT SYMPTOM CODE 44
CODE47    EQU    2R47        EQUATE FOR FAULT SYMPTOM CODE 47
CODE49    EQU    2R49        EQUATE FOR FAULT SYMPTOM CODE 49


*         EQUATES FOR FAULT SYMPTOM CODES THAT END WITH A 0 OR 1
*         FOLLOWING THE CLUSTER CODE (A, B, C OR D) INDICATING THAT
*         BITS 49, AND/OR 50, AND/OR 51 WERE SET OR CLEAR.

CODE22    EQU    2R22        EQUATE FOR FAULT SYMPTOM CODE 22
CODE23    EQU    2R23        EQUATE FOR FAULT SYMPTOM CODE 23
CODE28    EQU    2R28        EQUATE FOR FAULT SYMPTOM CODE 28
CODE30    EQU    2R30        EQUATE FOR FAULT SYMPTOM CODE 30
CODE32    EQU    2R32        EQUATE FOR FAULT SYMPTOM CODE 32
CODE34    EQU    2R34        EQUATE FOR FAULT SYMPTOM CODE 34


*         EQUATES FOR FAULT STATUS BYTE 4 (BITS 32-39).

BT32      EQU    0#8000      FAULT STATUS BIT 32 EQUATE
BT33      EQU    0#4000      FAULT STATUS BIT 33 EQUATE
BT34      EQU    0#2000      FAULT STATUS BIT 34 EQUATE
BT35      EQU    0#1000      FAULT STATUS BIT 35 EQUATE
BT36      EQU    0#0800      FAULT STATUS BIT 36 EQUATE
BT37      EQU    0#0400      FAULT STATUS BIT 37 EQUATE
BT38      EQU    0#0200      FAULT STATUS BIT 38 EQUATE
BT39      EQU    0#0100      FAULT STATUS BIT 39 EQUATE

          EJECT
*         EQUATES FOR FAULT STATUS BYTE 5 (BITS 40-47).

BT40      EQU    0#0080      FAULT STATUS BIT 40 EQUATE
BT41      EQU    0#0040      FAULT STATUS BIT 41 EQUATE
BT42      EQU    0#0020      FAULT STATUS BIT 42 EQUATE
BT43      EQU    0#0010      FAULT STATUS BIT 43 EQUATE
BT44      EQU    0#0008      FAULT STATUS BIT 44 EQUATE
BT45      EQU    0#0004      FAULT STATUS BIT 45 EQUATE
BT46      EQU    0#0002      FAULT STATUS BIT 46 EQUATE
BT47      EQU    0#0001      FAULT STATUS BIT 47 EQUATE


*         EQUATES FOR FAULT STATUS BYTE 6 (BITS 48-55).

BT48      EQU    0#8000      FAULT STATUS BIT 48 EQUATE
BT49      EQU    0#4000      FAULT STATUS BIT 49 EQUATE
BT50      EQU    0#2000      FAULT STATUS BIT 50 EQUATE
BT51      EQU    0#1000      FAULT STATUS BIT 51 EQUATE
BT52      EQU    0#0800      FAULT STATUS BIT 52 EQUATE
BT53      EQU    0#0400      FAULT STATUS BIT 53 EQUATE
BT54      EQU    0#0200      FAULT STATUS BIT 54 EQUATE
BT55      EQU    0#0100      FAULT STATUS BIT 55 EQUATE


*         EQUATES FOR FAULT STATUS BYTE 7 (BITS 56-63).

BT56      EQU    0#0080      FAULT STATUS BIT 56 EQUATE
BT57      EQU    0#0040      FAULT STATUS BIT 57 EQUATE
BT58      EQU    0#0020      FAULT STATUS BIT 58 EQUATE
BT59      EQU    0#0010      FAULT STATUS BIT 59 EQUATE
BT60      EQU    0#0008      FAULT STATUS BIT 60 EQUATE
BT61      EQU    0#0004      FAULT STATUS BIT 61 EQUATE
BT62      EQU    0#0002      FAULT STATUS BIT 62 EQUATE
BT63      EQU    0#0001      FAULT STATUS BIT 63 EQUATE


*         MISCELLANEOUS EQUATES FOR FAULT STATUS 1 AND FAULT STATUS 2.

FS1MSK2   EQU    0#6000      FS1 MASK FOR BITS 49 AND 50
FS1MSK3   EQU    0#7000      FS1 MASK FOR BITS 49, 50 AND 51
FS1MSK4   EQU    0#080F      FS1 MASK FOR BITS 52 AND 60-63
FS1MSK5   EQU    0#F7F0      FS1 MASK FOR BITS 48-51, 53-59
FS1MSK6   EQU    0#020F      FS1 MASK FOR BITS 54 AND 60-63
FS1MSK7   EQU    0#87FF      FS1 MASK TO CLEAR BITS 49-52
FS1MSK8   EQU    0#0300      FS1 MASK TO CLEAR BITS 54 AND 55
FS2MSK0   EQU    0#FFAF      FS2 MASK FOR BITS 32-47
FS2MSK1   EQU    0#1F9F      FS2 MASK FOR BITS 48-63
IOUFLT2   TITLE  GENERATE IOU FAULT SYMPTOM CODE
IOUFLT2X  LJM    0           IOU FAULT SYMPTOM CODE GENERATION
IOUFLT2   EQU    *-1         ENTRY POINT

*         SAVE FAULT STATUS BUFFER ADDRESS IN -A- ON ENTRY.

          STDL   T1          SAVE FAULT STATUS BUFFER ADDRESS
          ADN    1D
          STDL   T3

*         INITIALIZE TEMPORARY LOCATIONS.

          LDN    0
          STDL   T2          INITIALIZE TABLE INDEX
          STDL   T4
          STDL   T5
          STDL   T6          INITIALIZE FAULT SYMPTOM CODE LOCATIONS
          STDL   T7

*         MOVE FAULT STATUS 1 AND 2 TO THE TEMPORARY STATUS BUFFER

IFC10     LDIL   T3          MOVE FAULT STATUS 1 AND 2 TO BUFFER
          STML   FSBUFR,T4
          AODL   T3          UPDATE SOURCE ADDRESS
          AODL   T4          UPDATE BUFFER INDEX
          SBN    8D          CHECK FOR MOVE COMPLETE
          MJN    IFC10       IF MOVE NOT COMPLETE

*         CHECK FOR PIP3 TYPE OF CPU.

          LDIL   T1          GET CPU IDENTIFIER
          LMC    2R3A        CHECK FOR PIP3 CPU
          NJN    IFC20       IF NOT PIP3 CPU

*         IF PIP3 TYPE OF CPU, CHECK FOR BITS 52, 60, 61, 62 AND 63 SET
*         IN FAULT STATUS 1. IF NOT, CHECK FOR BITS 54,60-63 BEING SET.

          LDML   FS1BY6      GET FS1 BYTES 6 AND 7
          LPC    FS1MSK4     MASK FS1 FOR BITS 52 AND 60-63
          LMC    FS1MSK4     COMPARE FOR BITS 52 AND 60-63 ALL SET
          ZJN    IFC30       IF BITS 52 AND 60-63 ALL SET IN FS1
          LDML   FS1BY6
          LPC    FS1MSK6     MASK FS1 BITS FOR BITS 54 AND 60-63
          LMC    FS1MSK6     COMPARE W/SET BITS 54 AND 60-63
IFC20     NJN    IFC40       IF BITS 54 AND 60-63 NOT ALL SET
          LDC    2RE         GET 2ND PART OF 77E FSC
          LJM    IFC110      GO FORM 77E FSC AND EXIT TO CALLING PROGRAM

*         CLEAR BITS 52, 60, 61, 62 AND 63 IN FAULT STATUS 1.
*         POSSIBLY CLEAR BITS 49-52.

IFC30     LDML   FS1BY6      GET FS1 BYTES 6 AND 7
          LPC    FS1MSK5     CLEAR BITS 52, 60, 61, 62, AND 63
          STML   FS1BY6      REPLACE FS1 BYTES 6 AND 7
          LPC    FS1MSK8     COMPARE W/BITS 54 AND 55
          ZJN    IFC40       IF NEITHER BIT 54 OR 55 SET
          LDML   FS1BY6
          LPC    FS1MSK7     CLEAR FS1 BITS 49-52
          STML   FS1BY6      REPLACE FS1 BYTES 6 AND 7

*         CHECK FAULT STATUS 2 BYTES 4 AND 5 FOR CHANNEL FAULT BITS
*         SET.

IFC40     LDML   FS2BY4      GET FS2 BYTES 4 AND 5
          LPC    FS2MSK0     MASK OFF NOT USED AND NOT AVAILABLE BITS
          STML   FS2BY4      SAVE FAULT STATUS WORD
          LDML   FS2BY6      GET FS2 BYTES 6 AND 7
          LPC    FS2MSK1     MASK OFF NOT USED AND NOT AVAILABLE BITS
          STML   FS2BY6      SAVE FAULT STATUS WORD
          ADML   FS2BY4      INCLUDE FAULT STATUS BYTES 4 AND 5
          NJN    IFC60       IF FAULT STATUS 2 ERROR
IFC50     LJM    IFC150      GO TO CHECK FOR FAULT STATUS 1 ERROR

*         DETERMINE THE BIT(S) WHICH ARE SET IN THE FAULT STATUS 2
*         WORD AND GENERATE THE FAULT SYMPTOM CODE.

IFC60     LDC    FS2BY4      INITIALIZE FAULT STATUS BUFFER INDEX
          STDL   T3
IFC70     LDC    0#8000      INITIALIZE FAULT STATUS BIT MASK
IFC80     STDL   T4
          LPIL   T3          CHECK FOR CHANNEL BIT SET IN FS2
          ZJN    IFC90       IF CHANNEL BIT IS NOT SET IN FS2

*         POSSIBLE CHANNEL FAULT BIT HAS BEEN FOUND, CHECK FOR PREVIOUS
*         CHANNEL FAULT BIT DETECTED.

          LDDL   T6          CHECK FOR PREVIOUS CHANNEL FAULT BIT FOUND
          ADDL   T7
          NJN    IFC100      IF PREVIOUS CHANNEL FAULT BIT FOUND

*         THE POSSIBLE CHANNEL FAULT BIT HAS BEEN FOUND, SAVE THE FAULT
*         SYMPTOM CODE FOR THE CHANNEL FAULT BIT.

          LDDL   T2          BUILD FS2FSCT TABLE INDEX
          SHN    1D
          STDL   T5
          LDML   FS2FSCT,T5  SET FS2 FAULT SYMPTOM CODE
          STDL   T6
          LDML   FS2FSCT+1,T5  SET FS2 FAULT SYMPTOM CODE
          STDL   T7
IFC90     AODL   T2          UPDATE FAULT STATUS 2 TABLE INDEX
          SBN    32D         CHECK FOR ALL CHANNEL BITS CHECKED
          PJN    IFC50       IF ALL CHANN BITS CHECKED - GO CHK FS1
          LDDL   T4          UPDATE FAULT STATUS BIT MASK
          SHN    -1D
          NJN    IFC80       IF FS2 BYTES 4 AND 5 NOT CHECKED
          AODL   T3          UPDATE FAULT STATUS BUFFER INDEX
          UJN    IFC70       GO TO CHECK NEXT FAULT STATUS WORD

*         MORE THAN ONE ONE BIT HAS BEEN FOUND SET IN FAULT STATUS 2,
*         FORCE THE FAULT SYMPTOM CODE TO DI4277A.

IFC100    LDC    2RA         GENERATE THE FAULT SYMPTOM CODE DI4277A
IFC110    STDL   T7
          LDC    2R77        GENERATE THE CHARACTERS 77
          STDL   T6

*         MOVE THE FAULT SYMPTOM CODE TO THE BUFFER THAT CONTAINED THE
*         FAULT STATUS REGISTERS 1 AND 2 ON ENTRY AND EXIT.

IFC120    LDDL   T6          CHECK FOR NO FAULT SYMPTOM CODE
          ADDL   T7
          NJN    IFC130      IF FAULT SYMPTOM CODE
          LDC    2RD         SET THE FAULT SYMPTOM CODE TO 77D
          UJN    IFC110

IFC130    LDDL   T6          MOVE FIRST TWO FSC CHARACTERS TO BUFFER
          STIL   T1
          LDDL   T7          MOVE SECOND TWO FSC CHARACTERS TO BUFFER
          NJN    IFC134      IF LAST TWO FSC CHARACTERS ARE AVAILABLE
          LDC    2R          BLANK FILL LAST TWO FSC CHARACTERS
IFC134    STML   1,T1
          LDC    2R          BLANK FILL REMAINDER OF THE BUFFER
          STML   2,T1
          STML   3,T1
          STML   4,T1
          STML   5,T1
          STML   6,T1
          STML   7,T1
          LDDL   T1          SET (A) REGISTER FOR EXIT
          LJM    IOUFLT2X    EXIT

*         GENERATE THE FAULT SYMPTOM CODE DI4277B.

IFC140    LDC    2RB         GENERATE THE FAULT SYMPTOM CODE DI4277B
          LJM    IFC110      GO TO GENERATE THE CHARACTERS 77

          EJECT
*********************************************************************
*         CHECK FAULT STATUS 1 FOR ANY BITS SET AND IF NONE ARE SET,
*         EXIT.

IFC150    LDML   FS1BY4      CHECK FOR FAULT STATUS 1 ERROR(S)
          ADML   FS1BY6
          NJN    IFC160      IF FS1 ERROR PRESENT
          LJM    IFC120      IF NO FAULT STATUS 1 ERROR

*         DETERMINE THE CLUSTER IN WHICH THE FAILURE WAS DETECTED, IF
*         MORE THAN ONE CLUSTER FAILED, REPORT A FAULT SYMPTOM CODE OF
*         DI4277B.

IFC160    LDML   FS1BY0      CHECK FOR CLUSTER 0 FAILURE
          SHN    -8D
          ZJN    IFC170      IF NOT CLUSTER 0 FAILURE
          LDC    2RA         FORCE CLUSTER INDICATOR TO A
          STDL   T7
IFC170    LDML   FS1BY1      CHECK FOR CLUSTER 1 FAILURE
          LPC    0#1F
          ZJN    IFC190      IF NOT CLUSTER 1 FAILURE
          LDDL   T7          CHECK FOR MORE THAN ONE FAILING CLUSTER
IFC180    NJN    IFC140      IF MORE THAN ONE FAILING CLUSTER
          LDC    2RB         FORCE CLUSTER INDICATOR TO B
          STDL   T7
IFC190    LDML   FS1BY2      CHECK FOR CLUSTER 2 FAILURE
          SHN    -8D
          ZJN    IFC200      IF NOT CLUSTER 2 FAILURE
          LDDL   T7          CHECK FOR MORE THAN ONE FAILING CLUSTER
          NJN    IFC180      IF MORE THAN ONE FAILING CLUSTER
          LDC    2RC         FORCE CLUSTER INDICATOR TO C
          STDL   T7
IFC200    LDML   FS1BY3      CHECK FOR CLUSTER 3 FAILURE
          LPC    0#1F
          ZJN    IFC210      IF NOT CLUSTER 3 FAILURE
          LDDL   T7          CHECK FOR MORE THAN ONE FAILING CLUSTER
          NJN    IFC180      IF MORE THAN ONE FAILING CLUSTER
          LDC    2RD         FORCE CLUSTER INDICATOR TO D
          STDL   T7

*         CHECK THE FAULT STATUS 1 REGISTER FOR ERRORS.  THE FS1BTB
*         TABLE CONTAINS THE FAULT STATUS 1 BITS 32-63 THAT ARE TO BE
*         CHECKED.

IFC210    BSS    0
          LDN    0           INITIALIZE THE FS1BTB TABLE INDEX
          STDL   T2
IFC220    LDML   FS1BY4      GET FAULT STATUS 1 BYTES 4 AND 5
          LPML   FS1BTB,T2
          LMML   FS1BTB,T2   COMPARE FOR ALL SELECTED BITS SET
          NJN    IFC230      IF ALL SELECTED BITS NOT SET IN FS1
          LDML   FS1BY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LPML   FS1BTB+1,T2  COMPARE FOR ALL SELECTED BITS SET
          LMML   FS1BTB+1,T2  COMPARE FOR ALL SELECTED BITS SET
          ZJN    IFC250      IF ALL SELECTED BITS SET IN FS1

IFC230    LDN    2D          UPDATE FS1BTB TABLE INDEX
          RADL   T2
          ADC    -FS1BTBL    CHECK OF END OF FS1BTB TABLE
          MJN    IFC220      IF NOT END OF FS1BTB TABLE

          LDML   FS1BY4      GET FAULT STATUS 1 BYTES 4 AND 5
          ADML   FS1BY6      ADD FAULT STATUS 1 BYTES 6 AND 7
          ZJN    IFC240      IF FAULT STATUS 1 COMPLETELY PROCESSED
          LDC    2RD         SET FAULT SYMPTOM CODE TO DI4277D
          LJM    IFC110      GO TO GENERATE THE CHARACTERS 77

IFC240    LJM    IFC120      GO TO SET FAULT SYMPTOM CODE IN BUFFER

*         CLEAR THE FAILING BIT INDICATORS IN FAULT STATUS 1.

IFC250    LDML   FS1BY4      GET FAULT STATUS 1 BYTES 4 AND 5
          LMML   FS1BTB,T2   CLEAR FAILING BIT INDICATORS
          STML   FS1BY4      RESET FAULT STATUS 1 BYTES 4 AND 5
          LDML   FS1BY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LMML   FS1BTB+1,T2  CLEAR FAILING BIT INDICATORS
          STML   FS1BY6      RESET FAULT STATUS 1 BYTES 6 AND 7

*         POSSIBLE FAULT STATUS 1 FAILURE HAS BEEN FOUND, CHECK FOR
*         PREVIOUS FAULT STATUS 1 DETECTED. IF A PREVIOUS FAULT WAS
*         ISOLATED, FORCE THE FAULT SYMPTOM CODE TO DI4277C.

          LDDL   T6          CHECK FOR PREVIOUS FAULT STATUS ERROR
          ZJN    IFC260      IF NO PREVIOUS FAULT STATUS ERROR
          LDC    2RC         SET FAULT SYMPTOM CODE TO DI4277C
          LJM    IFC110      GO TO GENERATE THE CHARACTERS 77

*         THE POSSIBLE FAULT STATUS 1 ERROR HAS BEEN FOUND, SAVE THE
*         FAULT SYMPTOM CODE FOR THE FAULT STATUS 1 REGISTER.

IFC260    LDDL   T2          BUILD FS1FSCT TABLE INDEX
          SHN    -1D
          STDL   T4
          LDML   FS1FSCT,T4  SET FS1 FAULT SYMPTOM CODE
          STDL   T6

*         CHECK FOR FAULT SYMPTOM CODES DI4205, 10-12, 17-21,
*         24, 26, 27, 29, 31, 33, 37-44, 47, AND 49. IF THE FAULT
*         SYMPTOM CODE IS ONE OF THESE CODES, RESET THE CLUSTER
*         INDICATOR TO BLANK DISPLAY CODES.

          ADC    -CODE05     CHECK FOR FAULT SYMPTOM CODE DI4205
          ZJN    IFC270      IF FAULT SYMPTOM CODE DI4205
          ADC    -CODE10+CODE05  CHECK FOR FAULT SYMPTOM CODE DI4210
          ZJN    IFC270      IF FAULT SYMPTOM CODE DI4210
          SBN    CODE11-CODE10  CHECK FOR FAULT SYMPTOM CODE DI4211
          ZJN    IFC270      IF FAULT SYMPTOM CODE DI4211
          SBN    CODE12-CODE11  CHECK FOR FAULT SYMPTOM CODE DI4212
          ZJN    IFC270      IF FAULT SYMPTOM CODE DI4212
          SBN    CODE17-CODE12  CHECK FOR FAULT SYMPTOM CODE DI4217
          ZJN    IFC270      IF FAULT SYMPTOM CODE DI4217
          SBN    CODE18-CODE17  CHECK FOR FAULT SYMPTOM CODE DI4218
          ZJN    IFC270      IF FAULT SYMPTOM CODE DI4218
          SBN    CODE19-CODE18  CHECK FOR FAULT SYMPTOM CODE DI4219
          ZJN    IFC270      IF FAULT SYMPTOM CODE DI4219
          ADC    -CODE20+CODE19  CHECK FOR FAULT SYMPTOM CODE DI4220
          NJN    IFC280      IF FAULT SYMPTOM CODE IS NOT DI4220
 IFC270   LJM    IFC290      FAULT SYMPTOM CODE IS DI4220
 IFC280   SBN    CODE21-CODE20  CHECK FOR FAULT SYMPTOM CODE DI4221
          ZJN    IFC270      IF FAULT SYMPTOM CODE DI4221
          SBN    CODE24-CODE21  CHECK FOR FAULT SYMPTOM CODE DI4224
          ZJN    IFC270      IF FAULT SYMPTOM CODE DI4224
          SBN    CODE26-CODE24  CHECK FOR FAULT SYMPTOM CODE DI4226
          ZJN    IFC270      IF FAULT SYMPTOM CODE DI4226
          SBN    CODE27-CODE26  CHECK FOR FAULT SYMPTOM CODE DI4227
          ZJN    IFC270      IF FAULT SYMPTOM CODE DI4227
          SBN    CODE29-CODE27  CHECK FOR FAULT SYMPTOM CODE DI4229
          ZJN    IFC290      IF FAULT SYMPTOM CODE DI4229
          ADC    -CODE31+CODE29  CHECK FOR FAULT SYMPTOM CODE DI4231
          ZJN    IFC290      IF FAULT SYMPTOM CODE DI4231
          SBN    CODE33-CODE31  CHECK FOR FAULT SYMPTOM CODE DI4233
          ZJN    IFC290      IF FAULT SYMPTOM CODE DI4233
          SBN    CODE37-CODE33  CHECK FOR FAULT SYMPTOM CODE DI4237
          ZJN    IFC290      IF FAULT SYMPTOM CODE DI4237
          SBN    CODE38-CODE37  CHECK FOR FAULT SYMPTOM CODE DI4238
          ZJN    IFC290      IF FAULT SYMPTOM CODE DI4238
          SBN    CODE39-CODE38  CHECK FOR FAULT SYMPTOM CODE DI4239
          ZJN    IFC290      IF FAULT SYMPTOM CODE DI4239
          ADC    -CODE40+CODE39  CHECK FOR FAULT SYMPTOM CODE DI4240
          ZJN    IFC290      IF FAULT SYMPTOM CODE DI4240
          SBN    CODE41-CODE40  CHECK FOR FAULT SYMPTOM CODE DI4241
          ZJN    IFC290      IF FAULT SYMPTOM CODE DI4241
          SBN    CODE42-CODE41  CHECK FOR FAULT SYMPTOM CODE DI4242
          ZJN    IFC290      IF FAULT SYMPTOM CODE DI4242
          SBN    CODE43-CODE42  CHECK FOR FAULT SYMPTOM CODE DI4243
          ZJN    IFC290      IF FAULT SYMPTOM CODE DI4243
          SBN    CODE44-CODE43  CHECK FOR FAULT SYMPTOM CODE DI4244
          ZJN    IFC290      IF FAULT SYMPTOM CODE DI4244
          SBN    CODE47-CODE44  CHECK FOR FAULT SYMPTOM CODE DI4247
          ZJN    IFC290      IF FAULT SYMPTOM CODE DI4247
          SBN    CODE49-CODE47  CHECK FOR FAULT SYMPTOM CODE DI4249
          NJN    IFC300      IF NOT FAULT SYMPTOM CODE DI4249
IFC290    LDC    2R          RESET CLUSTER INDICATOR TO BLANKS
          STDL   T7
          UJN    IFC330      GO TO CONTINUE FAULT STATUS 1 PROCESSING

*         CHECK THAT LOCATION T7 DOES NOT CONTAIN ZERO.  THIS ENSURES
*         THAT THE FAULT CAN BE ISOLATED TO A FAILING CLUSTER.  IF THE
*         FAULT CANNOT BE ISOLATED TO A FAILING CLUSTER, (I.E.  T7
*         CONTAINS ZERO), FORCE THE FAULT SYMPTOM CODE TO DX4277D.

IFC300    LDDL   T7          GET FAILING CLUSTER INDICATOR
          NJN    IFC305      IF FAILING CLUSTER ISOLATED
          LDC    2RD         SET FAULT SYMPTOM CODE TO DX4277D
          LJM    IFC110      GO TO GENERATE THE CHARACTERS 77

*         CHECK FOR FAULT SYMPTOM CODES DI4222. IF THE FAULT SYMPTOM
*         CODE IS A DI4222, RESET THE CLUSTER INDICATOR X (A, B, C, D)
*         TO A X2 IF BITS 49, 50 AND 51 ARE CLEAR, TO A X0 IF EITHER
*         BIT 49 OR 50 IS SET OR TO A X1 IF BIT 51 IS SET.

IFC305    LDDL   T6          GET FAULT SYMPTOM CODE
          ADC    -CODE22     CHECK FOR FAULT SYMPTOM CODE DI4222
          NJN    IFC340      IF NOT FAULT SYMPTOM CODE DI4222
          LDML   FS1BY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LPC    FS1MSK3     CHECK IF BITS 49, OR 50, OR 51 SET
          ZJN    IFC320      IF BITS 49, 50 AND 51 CLEAR
          LPC    BT51        CHECK FOR BIT 51 SET
          ZJN    IFC310      IF BIT 51 IS NOT SET
          LDN    1R1-1R0     SET CLUSTER INDICATOR TO X0
IFC310    SBN    1R2-1R0     SET CLUSTER INDICATOR TO X1
IFC320    ADN    1R2-1R      SET CLUSTER INDICATOR TO X2
          RADL   T7
          LDML   FS1BY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LPC    -FS1MSK3    CLEAR BITS 49, 50 AND 51
          STML   FS1BY6      SAVE UPDATED FS1, BYTES 6 AND 7
IFC330    LJM    IFC230      GO TO CONTINUE FAULT STATUS 1 PROCESSING

*         CHECK FOR FAULT SYMPTOM CODES DI4223, DI4228, DI4230, DI4232
*         AND DI4234. IF THE FAULT SYMPTOM CODE IS ONE OF THESE CODES,
*         RESET THE CLUSTER INDICATOR X (A, B, C, D) TO A X1 IF BITS 49
*         AND 50 ARE CLEAR OR TO A X0 IF EITHER BIT 49 OR 50 IS SET.

IFC340    SBN    CODE23-CODE22  CHECK FOR FAULT SYMPTOM CODE DI4223
          ZJN    IFC350      IF FAULT SYMPTOM CODE DI4223
          SBN    CODE28-CODE23  CHECK FOR FAULT SYMPTOM CODE DI4228
          ZJN    IFC350      IF FAULT SYMPTOM CODE DI4228
          ADC    -CODE30+CODE28  CHECK FOR FAULT SYMPTOM CODE DI4230
          ZJN    IFC350      IF FAULT SYMPTOM CODE DI4230
          SBN    CODE32-CODE30  CHECK FOR FAULT SYMPTOM CODE DI4232
          ZJN    IFC350      IF FAULT SYMPTOM CODE DI4232
          SBN    CODE34-CODE32  CHECK FOR FAULT SYMPTOM CODE DI4234
          NJN    IFC330      IF NOT FAULT SYMPTOM CODE DI4234
IFC350    LDML   FS1BY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LPC    FS1MSK2     CHECK FOR BIT 49 OR 50 SET
          ZJN    IFC360      IF BIT 49 AND 50 IS NOT SET
          LCN    1R1-1R0     SET CLUSTER INDICATOR TO X1
IFC360    ADN    1R1-1R      SET CLUSTER INDICATOR TO X0
          RADL   T7
          LDML   FS1BY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LPC    -FS1MSK2    CLEAR BITS 49 AND 50
          STML   FS1BY6      SAVE UPDATED FS1, BYTES 6 AND 7
          UJN    IFC330      GO TO CONTINUE FAULT STATUS 1 PROCESSING

FSBUFR    TITLE  FAULT STATUS 1 AND 2 TEMPORARY BUFFER
*         FAULT STATUS 1 AND 2 BUFFER.

FSBUFR    BSS    0           FAULT STATUS 1 AND 2 BUFFER
FS1BY0    BSS    0           FAULT STATUS 1, BYTE 0
FS1BY1    BSS    0           FAULT STATUS 1, BYTE 1
          CON    0           FAULT STATUS 1 WORD 1, BYTES 0 AND 1

FS1BY2    BSS    0           FAULT STATUS 1, BYTE 2
FS1BY3    BSS    0           FAULT STATUS 1, BYTE 3
          CON    0           FAULT STATUS 1 WORD 2, BYTES 2 AND 3

FS1BY4    BSS    0           FAULT STATUS 1, BYTE 4
FS1BY5    BSS    0           FAULT STATUS 1, BYTE 5
          CON    0           FAULT STATUS 1 WORD 3, BYTES 4 AND 5

FS1BY6    BSS    0           FAULT STATUS 1, BYTE 6
FS1BY7    BSS    0           FAULT STATUS 1, BYTE 7
          CON    0           FAULT STATUS 1 WORD 4, BYTES 6 AND 7


*         FAULT STATUS 2 BYTE OFFSETS IN THE STATUS BUFFER.

FS2BY0    BSS    0           FAULT STATUS 2, BYTE 0
FS2BY1    BSS    0           FAULT STATUS 2, BYTE 1
          CON    0           FAULT STATUS 2 WORD 1, BYTES 0 AND 1

FS2BY2    BSS    0           FAULT STATUS 2, BYTE 2
FS2BY3    BSS    0           FAULT STATUS 2, BYTE 3
          CON    0           FAULT STATUS 2 WORD 2, BYTES 2 AND 3

FS2BY4    BSS    0           FAULT STATUS 2, BYTE 4
FS2BY5    BSS    0           FAULT STATUS 2, BYTE 5
          CON    0           FAULT STATUS 2 WORD 3, BYTES 4 AND 5

FS2BY6    BSS    0           FAULT STATUS 2, BYTE 6
FS2BY7    BSS    0           FAULT STATUS 2, BYTE 7
          CON    0           FAULT STATUS 2 WORD 4, BYTES 6 AND 7
FS1BTB    TITLE  FAULT STATUS 1 BIT TABLE FOR FAULT SYMPTOM CODES
FS1BTB    BSS    0
          BITS   BT32+BT44,0  FAULT SYMPTOM CODE EQUALS 01
          BITS   BT32+BT47,0  FAULT SYMPTOM CODE EQUALS 02
          BITS   BT32,0       FAULT SYMPTOM CODE EQUALS 03
          BITS   BT33,0       FAULT SYMPTOM CODE EQUALS 04
          BITS   BT34,0       FAULT SYMPTOM CODE EQUALS 05
          BITS   BT35,0       FAULT SYMPTOM CODE EQUALS 06
          BITS   BT46,0       FAULT SYMPTOM CODE EQUALS 07
          BITS   BT36,BT55    FAULT SYMPTOM CODE EQUALS 08
          BITS   BT36,0       FAULT SYMPTOM CODE EQUALS 09
          BITS   BT37,BT48    FAULT SYMPTOM CODE EQUALS 10
          BITS   BT37,BT53    FAULT SYMPTOM CODE EQUALS 11
          BITS   BT37,0       FAULT SYMPTOM CODE EQUALS 12
          BITS   BT38,BT54    FAULT SYMPTOM CODE EQUALS 13
          BITS   BT38,BT55    FAULT SYMPTOM CODE EQUALS 14
          BITS   BT38,BT56    FAULT SYMPTOM CODE EQUALS 15
          BITS   BT39,BT52    FAULT SYMPTOM CODE EQUALS 16
          BITS   BT40,0       FAULT SYMPTOM CODE EQUALS 17
          BITS   BT41,0       FAULT SYMPTOM CODE EQUALS 18
          BITS   BT42,0       FAULT SYMPTOM CODE EQUALS 19
          BITS   BT43,0       FAULT SYMPTOM CODE EQUALS 20
          BITS   0,BT48+BT57  FAULT SYMPTOM CODE EQUALS 21
          BITS   0,BT55+BT57  FAULT SYMPTOM CODE EQUALS 22
          BITS   0,BT55+BT58  FAULT SYMPTOM CODE EQUALS 23
          BITS   0,BT53+BT59  FAULT SYMPTOM CODE EQUALS 24
          BITS   0,BT56+BT59  FAULT SYMPTOM CODE EQUALS 25
          BITS   0,BT59       FAULT SYMPTOM CODE EQUALS 26
          BITS   0,BT52+BT60  FAULT SYMPTOM CODE EQUALS 27
          BITS   0,BT54+BT60  FAULT SYMPTOM CODE EQUALS 28
          BITS   0,BT52+BT61  FAULT SYMPTOM CODE EQUALS 29
          BITS   0,BT54+BT61  FAULT SYMPTOM CODE EQUALS 30
          BITS   0,BT52+BT62  FAULT SYMPTOM CODE EQUALS 31
          BITS   0,BT54+BT62  FAULT SYMPTOM CODE EQUALS 32
          BITS   0,BT52+BT63  FAULT SYMPTOM CODE EQUALS 33
          BITS   0,BT54+BT63  FAULT SYMPTOM CODE EQUALS 34
          BITS   BT44,0       FAULT SYMPTOM CODE EQUALS 35
          BITS   BT45,0       FAULT SYMPTOM CODE EQUALS 36
          BITS   0,BT49       FAULT SYMPTOM CODE EQUALS 37
          BITS   0,BT50       FAULT SYMPTOM CODE EQUALS 37
          BITS   0,BT51       FAULT SYMPTOM CODE EQUALS 37
          BITS   0,BT63       FAULT SYMPTOM CODE EQUALS 38
          BITS   0,BT62       FAULT SYMPTOM CODE EQUALS 39
          BITS   0,BT61       FAULT SYMPTOM CODE EQUALS 40
          BITS   0,BT60       FAULT SYMPTOM CODE EQUALS 41
          BITS   0,BT58       FAULT SYMPTOM CODE EQUALS 42
          BITS   0,BT57       FAULT SYMPTOM CODE EQUALS 43
          BITS   BT39,0       FAULT SYMPTOM CODE EQUALS 44
          BITS   BT38,0       FAULT SYMPTOM CODE EQUALS 45
          BITS   BT47,0       FAULT SYMPTOM CODE EQUALS 46
          BITS   0,BT48       FAULT SYMPTOM CODE EQUALS 47
          BITS   0,BT52       FAULT SYMPTOM CODE EQUALS 48
          BITS   0,BT53       FAULT SYMPTOM CODE EQUALS 49
          BITS   0,BT54       FAULT SYMPTOM CODE EQUALS 60
          BITS   0,BT55       FAULT SYMPTOM CODE EQUALS 61
          BITS   0,BT56       FAULT SYMPTOM CODE EQUALS 62
FS1BTBL   EQU    *-FS1BTB     LENGTH OF THE FAULT STATUS TABLE
FS1FSCT   TITLE  FAULT STATUS 1 FAULT SYMPTOM CODES
*         FAULT STATUS 1 FAULT SYMPTOM CODES TABLE.

FS1FSCT   BSS    0
          DATA   H*01*       FAULT SYMPTOM CODE FOR BITS 32 AND 44
          DATA   H*02*       FAULT SYMPTOM CODE FOR BITS 32 AND 47
          DATA   H*03*       FAULT SYMPTOM CODE FOR BIT 32
          DATA   H*04*       FAULT SYMPTOM CODE FOR BIT 33
          DATA   H*05*       FAULT SYMPTOM CODE FOR BIT 34
          DATA   H*06*       FAULT SYMPTOM CODE FOR BIT 35
          DATA   H*07*       FAULT SYMPTOM CODE FOR BIT 46
          DATA   H*08*       FAULT SYMPTOM CODE FOR BITS 36 AND 55
          DATA   H*09*       FAULT SYMPTOM CODE FOR BIT 36
          DATA   H*10*       FAULT SYMPTOM CODE FOR BITS 37 AND 48
          DATA   H*11*       FAULT SYMPTOM CODE FOR BITS 37 AND 53
          DATA   H*12*       FAULT SYMPTOM CODE FOR BIT 37
          DATA   H*13*       FAULT SYMPTOM CODE FOR BITS 38 AND 54
          DATA   H*14*       FAULT SYMPTOM CODE FOR BITS 38 AND 55
          DATA   H*15*       FAULT SYMPTOM CODE FOR BITS 38 AND 56
          DATA   H*16*       FAULT SYMPTOM CODE FOR BITS 39 AND 52
          DATA   H*17*       FAULT SYMPTOM CODE FOR BIT 40
          DATA   H*18*       FAULT SYMPTOM CODE FOR BIT 41
          DATA   H*19*       FAULT SYMPTOM CODE FOR BIT 42
          DATA   H*20*       FAULT SYMPTOM CODE FOR BIT 43
          DATA   H*21*       FAULT SYMPTOM CODE FOR BITS 48 AND 57
          DATA   H*22*       FAULT SYMPTOM CODE FOR BITS 55 AND 57
          DATA   H*23*       FAULT SYMPTOM CODE FOR BITS 55 AND 58
          DATA   H*24*       FAULT SYMPTOM CODE FOR BITS 53 AND 59
          DATA   H*25*       FAULT SYMPTOM CODE FOR BITS 56 AND 59
          DATA   H*26*       FAULT SYMPTOM CODE FOR BIT 59
          DATA   H*27*       FAULT SYMPTOM CODE FOR BITS 52 AND 60
          DATA   H*28*       FAULT SYMPTOM CODE FOR BITS 54 AND 60
          DATA   H*29*       FAULT SYMPTOM CODE FOR BITS 52 AND 61
          DATA   H*30*       FAULT SYMPTOM CODE FOR BITS 54 AND 61
          DATA   H*31*       FAULT SYMPTOM CODE FOR BITS 52 AND 62
          DATA   H*32*       FAULT SYMPTOM CODE FOR BITS 54 AND 62
          DATA   H*33*       FAULT SYMPTOM CODE FOR BITS 52 AND 63
          DATA   H*34*       FAULT SYMPTOM CODE FOR BITS 54 AND 63
          DATA   H*35*       FAULT SYMPTOM CODE FOR BIT 44
          DATA   H*36*       FAULT SYMPTOM CODE FOR BIT 45
          DATA   H*37*       FAULT SYMPTOM CODE FOR BIT 49
          DATA   H*37*       FAULT SYMPTOM CODE FOR BIT 50
          DATA   H*37*       FAULT SYMPTOM CODE FOR BIT 51
          DATA   H*38*       FAULT SYMPTOM CODE FOR BIT 63
          DATA   H*39*       FAULT SYMPTOM CODE FOR BIT 62
          DATA   H*40*       FAULT SYMPTOM CODE FOR BIT 61
          DATA   H*41*       FAULT SYMPTOM CODE FOR BIT 60
          DATA   H*42*       FAULT SYMPTOM CODE FOR BIT 58
          DATA   H*43*       FAULT SYMPTOM CODE FOR BIT 57
          DATA   H*44*       FAULT SYMPTOM CODE FOR BIT 39
          DATA   H*45*       FAULT SYMPTOM CODE FOR BIT 38
          DATA   H*46*       FAULT SYMPTOM CODE FOR BIT 47
          DATA   H*47*       FAULT SYMPTOM CODE FOR BIT 48
          DATA   H*48*       FAULT SYMPTOM CODE FOR BIT 52
          DATA   H*49*       FAULT SYMPTOM CODE FOR BIT 53
          DATA   H*60*       FAULT SYMPTOM CODE FOR BIT 54
          DATA   H*61*       FAULT SYMPTOM CODE FOR BIT 55
          DATA   H*62*       FAULT SYMPTOM CODE FOR BIT 56
FS2FSCT   TITLE  FAULT STATUS 2 FAULT SYMPTOM CODES
*         FAULT STATUS 2 FAULT SYMPTOM CODES TABLE.

FS2FSCT   BSS    0
          DATA   H*777 *     CHANNEL EQUALS  7
          DATA   H*776 *     CHANNEL EQUALS  6
          DATA   H*775 *     CHANNEL EQUALS  5
          DATA   H*774 *     CHANNEL EQUALS  4
          DATA   H*773 *     CHANNEL EQUALS  3
          DATA   H*772 *     CHANNEL EQUALS  2
          DATA   H*771 *     CHANNEL EQUALS  1
          DATA   H*770 *     CHANNEL EQUALS  0
          DATA   H*7717*     CHANNEL EQUALS 17
          DATA   H*0   *     NOT AVAILABLE
          DATA   H*7715*     CHANNEL EQUALS 15
          DATA   H*0   *     NOT AVAILABLE
          DATA   H*7713*     CHANNEL EQUALS 13
          DATA   H*7712*     CHANNEL EQUALS 12
          DATA   H*7711*     CHANNEL EQUALS 11
          DATA   H*7710*     CHANNEL EQUALS 10
          DATA   H*0   *     NOT AVAILABLE
          DATA   H*0   *     NOT AVAILABLE
          DATA   H*0   *     NOT AVAILABLE
          DATA   H*7724*     CHANNEL EQUALS 24
          DATA   H*7723*     CHANNEL EQUALS 23
          DATA   H*7722*     CHANNEL EQUALS 22
          DATA   H*7721*     CHANNEL EQUALS 21
          DATA   H*7720*     CHANNEL EQUALS 20
          DATA   H*7740*     MAC ERROR
          DATA   H*0   *     NOT AVAILABLE
          DATA   H*0   *     NOT USED
          DATA   H*7741*     RADIAL INTERFACE 1/2/3 ERROR
          DATA   H*7733*     CHANNEL EQUALS 33
          DATA   H*7732*     CHANNEL EQUALS 32
          DATA   H*7731*     CHANNEL EQUALS 31
          DATA   H*7730*     CHANNEL EQUALS 30
          QUAL   *

*copy     ctp$convert_digits_to_ascii
*copy     ctp$dft_write_fsc_to_buffer
          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY (ANALYSE 960 IOU ERRORS)
          QUAL
*COPYC CTP$DFT_ANALYZE_IOU_ERRORS_I4
*COPYC CTP$DFT_PROCESS_DUAL_I4_IOU_ERR
*COPY CTP$DFT_SET_SS_DUAL_I4
 CEE      SPACE  4,10
**        CEE - CHECK FOR EXPECTED IOU ERROR
*
*         STUB ON UPPER 8XX CLASS

 CEE      SUBR               ENTRY/EXIT
          LDN    0
          UJN    CEEX
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (ANALYSE 960 MEMORY ERRORS)
 AME      SPACE  4,10
**        AME - PROCESS MEMORY ERRORS.
*
*         CALLS  CLR, GSC, FMB, *CFF*, *LOG*, *SME*.


          ROUTINE AME

          LDN    0
          STM    RLST        CORRECTED ERROR FLAG
          STM    NERR        SET NO ERROR FLAG FLAG
          STML   SBER
          STML   SBER+1
          STML   SYCD
          LDN    BC
          RJM    CLR         ZERO SCRATCH BUFFER
          LDM    ME0U        MERGED MEMORY ERROR REGISTER LISTS
          RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          CALL   CFF         CHECK FOR FREEZE
          LDM    RTP2
          ZJN    AME0.1      IF NOT TO IGNORE ERROR
          LDN    0
          STM    DFTA        NO ACTION
          STM    REGI        RESET REGISTER LIST INDEX
          UJP    AMEX

 AME0.1   LDM    SUMS        SUMMARY STATUS
          SHN    21-SSUE
          PJP    AME3        IF NOT UNCORRECTED
          LDC    MUL2
          RJM    FMB
          CRDL   W0          READ IN UEL2 REGISTER
          LDDL   W0
          SHN    2
          PJP    AME0        IF DATA IN REGISTER IS NOT VALID
          LDDL   W3          BITS 48 - 55
          SHN    -10
          NJP    AME0        IF NOT PARTIAL WRITE PARITY ERROR
          LDDL   W3          BITS 56 - 63
          LPC    0#FF
          ZJP    AME0        IF NOT PARTIAL WRITE PARITY ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = PARTIAL WRITE PARITY ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR MEMORY ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).
*         DFT ANALYSIS - OS ACTION = MULTIPLE ODD BIT ERROR (VERSION 3).
                                   = STEP SYSTEM (VERSION 4)
          SETDAC DDCM
          SETDAN (EPUN,DAUME)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          SETOSA OSMOB,OSSS
          UJP    AME1        LOG THE ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED CM ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR MEMORY ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).
*         DFT ANALYSIS - OS ACTION = UNCORRECTED MEMORY ERROR.

 AME0     SETDAC DDCM
          SETDAN (EPUN,DAUME)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          SETOSA OSUCM
 AME1     LDM    ME0U        UNCORRECTED MEMORY REGISTER LIST
          RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          CALL   CFF         CHECK FOR FREEZE
          LDM    RTP2
          ZJN    AME1.1      IF NOT TO IGNORE ERROR
          LDN    0
          STM    DFTA        NO ACTION
          STM    REGI        RESET REGISTER LIST INDEX
          UJP    AMEX
 AME1.1   CALL   LOG
 AME2     LJM    AMEX        RETURN

 AME3     LDM    SUMS
          SHN    21-SSCE
          PJN    AME2        IF NOT A CORRECTED ERROR
          LDN    1
          STM    RLST        SET CORRECTED ERROR LIST FLAG

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CORRECTED CM ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR MEMORY ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAC DDCM
          SETDAN (EPCO,DACME)
          SETFLG (BC.FL)
          LDM    ME0C        CORRECTED MEMORY ERROR REGISTERS
          RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          CALL   CFF
          LDM    RTP2
          ZJN    AME3.5      IF NOT TO IGNORE ERROR
          LDN    0
          STM    DFTA        NO ACTION
          STM    REGI        RESET REGISTER LIST INDEX
          UJP    AMEX

*         PROCESS CYBER 960 MEMORY ERRORS.

 AME3.5   RJM    GSC         GET SYNDROME CODE
          LDDL   W2
          SHN    -10
          STML   SBER+1      LOWER ADDRESS BITS 32 - 33
          LDDL   W1
          LPC    0#FF
          SHN    10
          RAML   SBER+1      BITS 13 - 28 OF ADDRESS
          LDDL   W1
          SHN    -10
          STML   SBER        BITS 5 - 12 OF ADDRESS
          LDDL   W0
          LPN    0#F         BITS 1 - 4  OF ADDRESS
          SHN    10
          RAML   SBER

          CALL   SME
          LJM    AMEX        RETURN
 GSC      SPACE  4,10
**        GSC - GET SYNDROME CODE.
*
*         ENTRY  (W0 - W3) = PROPER *CEL* REGISTER.
*
*         EXIT   (SYCD) = SYNDROME CODE.
*
*         USES   W0 - W3, *SYCD*.


 GSC      SUBR               ENTRY/EXIT
          LDN    0
          STM    SYCD
          LDC    MCEL        READ CORRECTED ERROR LOG REGISTER
          RJM    FMB
          CRDL   W0
          LDDL   W0
          SHN    21-17
          PJP    AMEX        IF VALID BIT NOT SET
          LDDL   W3
          SHN    -10
          STML   SYCD
          LJM    GSCX        RETURN

*COPY CTP$DFT_SERVICE_MEMORY_ERROR
*COPY CTP$DFT_REWRITE_CM_ERROR
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (LOG ERROR TO BUFFER CONTROL WORDS)


 QUAL$    EQU    0           DEFINE UNQUALIFIED COMMON DECKS
*COPYC CTP$DFT_LOG_ERROR
*COPY CTP$DFT_LOG_ERROR_CHECK_MATCH
*COPY CTP$DFT_ZERO_SUPPORTIVE_STATUS
*COPY CTP$DFT_INCREMENT_ERROR_COUNT
*COPY CTP$DFT_FIND_CONTROL_WORD
*COPY CTC$DFT_ELEMENT_CONVERSIONS
 ABL      SPACE  4,10
**        ABL - ADJUST BUFFER LENGTH.
*

 ABL      SUBR               ENTRY/EXIT
          LDML   LBUF
          UJN    ABLX
 URC      SPACE  4,10
**        URC - UPDATE RETRY COUNTERS
*
*         NOTE THIS IS A STUB


 URC      SUBR               ENTRY/EXIT
          UJN    URCX
*COPY     CTP$DFT_LOG_ERROR_NO_CONSOLE
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (READ MAINTENANCE REGISTERS)
          QUAL   *           SO THAT OTHER OVERLAYS MAY ACCESS
 PC960    SPACE  4,10
**        CYBER 960 CORRECTED ERROR
*         REGISTER LIST.


 PA960    REGLST (10,00,11,12,30,31,32,80,81,82,83,84,85,86,87,88,89,A0)

 MA960    SPACE  4,10
**        CYBER 960 REGISTER LIST FOR ALL MEMORY ERRORS.

 MA960    REGLST (10,00,12,20,A0,A4,A8,21)
 SXIU     SPACE  4,10
**        I1/I1CR/I2/I4 IN I2 MODE CORRECTED AND/ UNCORRECTED IOU ERROR LIST.


 SXIU     REGLST (10,00,12,30,40,80,81,A0,18,21)
 I4IC     SPACE  4,10
**        I4 CORRECTED IOU ERROR LIST.


 I4IC     REGLST (10,00,12,30,40,80,81,A0,18,21,16,34,44,84,85,A4,1C,25)
 I4IU     SPACE  4,10
**        I4 UNCORRECTED IOU ERROR LIST.


 I4IU     REGLST (10,00,12,30,40,80,81,A0,18,21,16,34,44,84,85,A4,1C,25)

*COPYC CTP$DFT_READ_MAINTENANCE_REGS
*COPY CTP$DFT_ZERO_SUPPORTIVE_STATUS

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (PROCESSOR PRIMITIVES)
*COPY CTP$DFT_PROCESSOR_PRIMITIVES
          SPACE  4,10
**        PHE -  PIP3  HALF-EXCHANGE IN ROUTINE TO START PROCESSOR
*
*         ENTRY  PROCESSOR MASTER CLEARED, *CSA* REGISTER SET TO (STEX)
*                *BLOCK EXCHANGE REQUEST* AND *DISABLE PROCESSOR FAULT
*                STATUS* BITS ARE CLEARED IN *DEC*, PROCESSOR STARTED
*                AND THE DEADSTART INTERLOCK IS CLEARED IN THE *ECIB*.
*
*         EXIT   PROCESSOR HALF EXCHANGED IN TO *MPS* OR *JPS*
*


          ROUTINE PHE

*         START THE PROCESSOR.

          LDN    SSMR
          STD    RN
          LDM    HBUF+CPRPC
          RJM    RMR         READ STATUS SUMMARY
          LPN    MSSM        CHECK FOR MONITOR MODE
          ZJN    PHE1        IF JOB
          LDML   HEIM        GET HALF EXCHANGE IN ADDRESS-MTR
          UJN    PHE2

PHE1      LDML   HEIJ        GET HALF EXCHANGE IN ADDRESS-JOB
PHE2      STM    PHEB+7
          SHN    -8D
          STM    PHEB+6
          LOCKMR SET
          FUNCMR HBUF+CPRPC,MRMC     MASTER CLEAR PROCESSOR
          LDML   CSAR
          STDL   RN
          WRITMR PHEB,HBUF+CPRPC
          FUNCMR HBUF+CPRPC,MRSP     START PROCESSOR
          LDC    200D        WAIT 100 MICRO SECS
 PHE3     SBN    1
          NJN    PHE3        DELAY

*         CLEAR MAINTENANCE REGISTER INTERLOCK.

          LOCKMR CLEAR
          LJM    PHEX        RETURN

 PHEB     BSSZ   10          CONTROL STORE ADDRESS

*         THE FOLLOWING ROUTINES ARE STUBS BECAUSE THEY ARE
*         NOT NEEDED ON AN 960.

          ROUTINE STRBTS
          LJM    STRBTSX


 CLRBTS   SUBR
          LJM    CLRBTSX
*COPYC CTP$DFT_MANAGE_MEMORY_PORT

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY (MASSAGE CPU REGISTERS)
*COPY CTP$DFT_MASSAGE_CPU_REGISTERS

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (CLEAR ERRORS)
 CLE      SPACE  4,10
**        CLE - CLEAR ERRORS.
*
*         EXIT   ALL REGISTERS NECESSARY WILL BE CLEARED OF ERRORS.


          ROUTINE CLE

          LDM    HBUF+HDRPC
          LPC    7417
          STD    EC
          FUNCMR ,MRCE       CLEAR ERRORS FROM *PFS* REGISTERS
          LJM    CLEX        RETURN
 CCE      SPACE  4,10
**        CCE - CLEAR CM ERRORS.
*
*         CALLS  FMB, UPR.


          ROUTINE CCE

          FUNCMR CMCC,MRCE   CLEAR ERRORS FROM *PFS* REGISTERS
          LJM    CCEX        RETURN

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_OS_REQUESTS
*COPYC CTP$DFT_OS_REQUESTS_PACKETS

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS - DUAL I4)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPY  CTP$DFT_REQUESTS_DUAL_I4
*COPY CTP$DFT_CHECK_TPM_PKT_RESPONSE

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS FOR IOU1)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPY  CTP$DFT_REQUESTS_IOU1_DUAL_I4

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS - 2)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_REQUEST_PROCESSOR_2

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (PP REQUEST PROCESSORS)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_PP_UTILITY_REQUESTS
*COPY  CTP$DFT_DUMP_PP_REGISTERS
*COPY  DSI$DUMP_LOAD_IDLE_PP

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (UPDATE C170 MEMORY)
*COPYC CTP$DFT_UPDATE_170_MEMORY

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (READ EPM DATA)
*COPYC CTP$DFT_READ_EPM_DATA

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT ERROR LOGGING ROUTINES)
*COPY     CTP$DFT_PROCESS_DISK_ERROR
*COPY CTP$DFT_RETURN_ERROR_CODE

          OVERFLOW  R2ORG
          OVERLAY  (RESTART SCI PP)
 QUAL$    EQU    0
*COPYC CTP$DFT_RESTART_SCI
*COPY DSI$DUMP_LOAD_IDLE_PP
          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (HANDLE BLOCKED IOU ACCESS TO CM),10000B
*COPY CTP$DFT_HANDLE_IOU_BIT57
          OVERLAY  (DFT RUN TIME ERROR HANDLING)
*COPY CTP$DFT_RUN_TIME_ERROR_HANDLER
*COPY CTP$DFT_RETURN_ERROR_CODE
*copy     ctp$construct_message_in_eicb

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          END
/EOR
*DECK DECK=CTM$DFT_990_CLASS EXPAND=TRUE
          IDENT  DFT4,70B
          CIPPU  J
          MEMSEL 16
          BASE   MIXED
          TITLE  CTM$DFT 990 CLASS (DFT4).
          COMMENT *SMD* LVL=11
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 DFT      SPACE  4,10
***       DFT - DEDICATED FAULT TOLERANCE.
*         B. R. HANSON.      82/06/21. (PRECURSOR KNOWN AS SMU)
*         G. J. FALCONER.    85/08/05. (DFT V1.0)
*         L. K. SCHENECKER.  85/08/05. (CYBER 990 OVERLAY)
*         G. J. FALCONER.    86/02/27. (DFT V2.0)
*         L. K. SCHENECKER.  86/02/27. (CYBER 990 OVERLAY ENHANCEMENTS)
 DFT      SPACE  4,10
***       DFT PERFORMS:
*
*         1) CAPTURING THE CONTENT OF MAINFRAME MAINTENANCE REGISTERS
*         FOR ERROR LOGGING, AND CLEARING HARDWARE ELEMENT ERRORS.
*
*         2) ON CERTAIN MODELS (990) RESTARTING PROCESSOR AFTER CONTROL
*         MEMORY PARITY ERRORS.
*
*         3) THE ACTUAL SEQUENCE OF STEPS TO DEADSTART THE SYSTEM FROM
*         C170 STATE OPERATION TO DUAL-STATE OPERATION OR TO RETURN IT TO
*         STANDALONE C170 OPERATION.  THIS IS PERFORMED UPON THE REQUEST
*         OF THE PP BOOT (*VPB* STATE OF *SCI*).
*
*         4) PROVIDING EXTERNALIZATIONS OF *2AP* FUNCTIONS TO NOS/VE,
*         NOS, AND NOS/BE.
 CONTROL  SPACE  4,10
**        ASSEMBLY PARAMETERS.


 PRGM     SET    2           SET *OVERLAY* MACRO TO *DFT* NAMES
 PPTYPE   EQU    0           TURN ON TRACKING OF UPPER/LOWER PP
 MCH$     EQU    0           DEFINE *MCH* ROUTINE IN DSI$DUMP LOAD IDLE PP
*STEP$    SET    1           ASSEMBLE *STEP* CODE IF SYMBOL DEFINED

          LIST   X
*COPY     CTP$DFT_RELEASE_HISTORY
*COPY     CTH$DEDICATED_FAULT_TOLERANCE
          LIST   *
 COMMON   SPACE  4,10
**        COMMON DECKS.


*COPYC DSI$PP_MACROS
*COPYC DSI$MAINTENANCE_REGISTER_MACROS
*COPYC CTI$COMPASS_OS_LEVELS
*COPYC CTC$DFT_MACROS
*COPY CTP$DFT_SPECIAL_MAC_ACCESS

*COPYC CTC$DFT_DIRECT_CELLS

 COMMON   SPACE  4,10
*         COMMON DECKS.


          LIST   X
*COPYC CTI$CONSOLE_PACKET_DEFINITIONS
*COPYC CTI$DFT_ANALYSIS_CODES
*COPYC DSC$PP_MR_AND_TPM_CONSTANTS
*COPYC CTC$DFT_CONSTANTS

          EJECT
*         VERSION 4 MODEL DEPENDENT EQUATES.

*         MDB SUB HEADER ID EQUATES.

 SH.MR1   EQU    1           SIXTH MRB GROUP
 SH.CB    EQU    2           CAPTURE BUFFER
 SH.HF    EQU    3           HISTORY FILE
 SH.EP    EQU    4           EXCHANGE PACKAGE
 SH.PI    EQU    5           INSTRUCTION AT P AND SURROUNDING INSTRUCTIONS
 SH.EW    EQU    6           EXECUTING WORDS OF SCM
 SH.MR2   EQU    7           LAST 2 WORDS OF SIXTH MRB GROUP

*         MDB SUB HEADER LENGTH OF DATA EQUATES.

 LOD.MR1  EQU    3           SIXTH MRB GROUP
 LOD.MR2  EQU    2           LAST WORDS OF SIXTH MRB GROUP
 LOD.CB   EQU    512D        CAPTURE BUFFER
 LOD.HF   EQU    64D         HISTORY FILE
 LOD.EP   EQU    52D         EXCHANGE PACKAGE
 LOD.PI   EQU    14D         INSTRUCTION AT P AND SURROUNDING INSTRUCTIONS
 LOD.EW   EQU    23D         EXECUTING WORDS OF SCM
 LOD.MR2  EQU    2           LAST 2 WORDS OF SIXTH MRB GROUP

*         MDB SUB HEADER PFS ID EQUATES.

 PFID.EW  EQU    0#8B21      PFS REGISTER 8B BIT 21

*         MDB SUB HEADER EQUATES.

 V4SHLOD  EQU    0           LENGTH OF DATA OFFSET
 V4SHPFS  EQU    2           PFS ERROR ID OFFSET
 V4SHHID  EQU    3           DATA HEADER ID OFFSET

*COPYC CTC$DFT_ACTION_OVERFLOW
*COPYC DSA$HARDWARE_TABLE_DEFINITIONS
*COPYC DSA$VE_REQUESTS_TO_DFT
          LIST   *
*COPYC DSI$PP_INSTRUCTION_MNEMONICS
          LIST   X
*COPYC CTC$EI_CONTROL_BLOCK
          LIST   *

**        START DEFINITION OF THE MAIN LOOP OF DFT.
*
*         BECAUSE CYBER 990 HAS AN I4 THE MAIN LOOP WILL DEFINE
*         DUAL I4 CODE, AND PACKETS. SINCE AN I4 HAS A CLOCK CHIP
*         THE EICB UPDATE TIME CODE IS ALSO INCLUDED.
*         RELOCATION CHECKS ARE STUBBED OFF AS THEY ARE NOT VALID ON CYBER 990.

*COPYC CTP$DFT_MAIN_LOOP
 CRN      SPACE  4,10
**        CRN - CHECK RELOCATION NECESSARY.
*
*         NOTE ON CYBER 990 THIS IS A NO OP.

 CRN      SUBR               ENTRY/EXIT
          UJN    CRNX

*COPYC CTP$DFT_MAIN_LOOP_UPDATE_TIME
*COPYC CTP$DFT_MAIN_LOOP_DUAL_STATE
*COPYC CTP$DFT_MAIN_LOOP_PACKETS

**        END OF DFT MAIN LOOP DEFINITIONS

**        START DEFINITION OF THE GLOBAL DATA COMMON TO ALL DFTS

*COPYC CTC$DFT_GLOBAL_DATA
*COPYC CTC$DFT_GLOBAL_DATA_NON_S0
**        END DEFINITION OF THE GLOBAL DATA COMMON TO ALL DFTS

**        START MODEL DEPENDENT REGION OF GLOBAL DATA

*         MAINTENANCE REGISTER BUFFER ADDRESSES.

 MRBA     CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0

 RBUF     BSSZ   10          CYBER 990 REGISTER SAVE AREA
 TRSP     BSSZ   4           CYBER 990 RETRY SAVED P - CP0
 TRSP1    BSSZ   4           CYBER 990 RETRY SAVED P - CP1
 TRCP     BSSZ   4           CYBER 990 RETRY CURRENT P - CP0
 TRCP1    BSSZ   4           CYBER 990 RETRY CURRENT P - CP1
 TRPC     BSSZ   2           CYBER 990 RETRY P CTR - CP0, CP1
 TRHC     BSSZ   2           CYBER 990 RETRY HOURLY CTR, CP0, CP1
 MICL     CON    0           CYBER 990 UCODE LEVEL FLAG
 TRMF     CON    0           CYBER 990 RETRY MULTIPLE FLAG
 HTFL     CON    0           CYBER 990 HALT TIMING FLAG
 SCPM     CON    0           CYBER 990 SOFT CONTROL PARITY MASK
 C9EF     CON    0           CYBER 990 HALF EXCHANGE ERROR FLAG
 HLTE     CON    0           HALT ON ERROR FLAG
 FAIL     CON    0           FAILING ADDRESS
 FLPE     CON    0           PARITY ERROR = 1
 HALT     CON    0           HALT ON ERROR FLAG
 RMCF     CON    0           REFRESH SCM THIS PASS FLAG

*         THE FOLLOWING CELLS HOLD INFORMATION NECESSARY FOR VERSION 4 DFT.

 CEWF     CON    0           FLAG IF EMV CALLED BY CEW
 E6AD     CON    0,0,0       ADJUSTED MDB ADDRESS AFTER ERROR ID 6
 CSAA     CON    0           CSA ADDRESS FOR DFT RETRY

**        END MODEL DEPENDENT REGION OF GLOBAL DATA

*COPYC CTC$DFT_MDB_LOGGING_CONSTANTS

**        START MAINTENANCE REGISTER ACCESS ROUTINES.
*         SINCE CYBER 990 HAS NO SPECIAL MAINTENANCE ACCESS
*         REQUIREMENTS THE STANDARD 3 ACCESS COMMON DECKS ARE USED.

*COPYC CTP$MR_PROTOCOL_PREPROCESS
*COPYC CTP$MR_RETRY_OPERATION_FOR_DFT
*COPYC CTP$MR_PROTOCOL_PROCESS
*COPYC CTP$MR_PROTOCOL_POSTPROCESS

**        END MAINTENANCE REGISTER ACCESS ROUTINES

**        START THE DFT RESIDENT ROUTINES COMMON TO ALL DFTS.

*COPYC CTP$DFT_RESIDENT_COMMON
*COPYC CTP$DFT_RESIDENT_ECM_NON_S0
          LIST   X
*copy dsi$find_cip_module
*copy dsi$get_hardware_element
*copy DSI$PP_UTILITY_SUBROUTINES
          LIST   *

**        END THE DFT RESIDENT ROUTINES COMMON TO ALL DFTS

**        START THE PRESET AREA OF DFT
*         SINCE CYBER 990 USES AN I4, PACKET PRESET CODE WILL BE INCLUDED.

          USE    PRESET
          QUAL   PRESET
*COPYC CTP$DFT_PRESET
*COPYC CTP$DFT_PRESET_DUAL_I4
*COPY CTP$DFT_RETURN_ERROR_CODE
 SPO      SPACE  4,10
**        SPO - SETUP MEMORY PORT OFFSET.
*
*         EXIT   PO IS SET TO THE MODEL DEPENDENT PORT OFFSET.
*
*         USES   PO.


 SPO      SUBR               ENTRY/EXIT
          LDN    4           SETUP MEMORY PORT OFFSET
          STD    PO
          UJN    SPOX        RETURN

          USE    *
          QUAL   *
          OVERLAY  (RESIDENT PART II),R2ORG

**        START OF DFT RESIDENT II COMMON AREA.
*         CYBER 990 REQUIRES AN ADDITION TO THE COMMON CODE
*         TO PROVIDE A DELAY ROUTINE FOR CPU HALTS.

*COPYC CTP$DFT_RESIDENT_II_COMMON
 HTO      SPACE  4,10
**        HTO - HALT TIME OUT.
*
*         ENTRY  WHEN 105 MILLISEC HAVE PASSED.
*
*         USES   *TFLG*.


 HTO      SUBR               ENTRY/EXIT
          LDN    1
          STML   TFLG        SET TIMING FLAG
          UJN    HTOX        RETURN

*COPYC CTP$DFT_NON_930_RESIDENT_II
*COPYC DSI$PACK_UNPACK_REGISTERS
*COPYC DSI$VALIDATE_PP_BOUNDS
 DLY      SPACE  4,10
**        DLY  - DELAY 100 MILLISECONDS.
*
*         CALLS  TIM.


 DLY      SUBR               ENTRY/EXIT
          LDN    0
          STML   ACTB1+2
          STML   TFLG        TIMER FLAG
 DLY0     RJM    TIM         TIMER
          LDM    TFLG
          ZJP    DLY0        IF NOT DONE TIMING
          UJP    DLYX

**        END OF RESIDENT II COMMON AREA

          ERRNG  10000-*     RESIDENT II OVERFLOWS PP MEMORY

**        START OF DFT PRESET OVERLAY AREA. THE OVERLAYS START AT 4300(8).
*         THESE OVERLAYS ARE PRESENTLY USED FOR INITIALZING DUAL I4 MACHINES

*COPYC CTP$DFT_PRESET_DUAL_I4_OVL
*COPYC CTP$DFT_PRESET_BUILD_STRUCTURE
          OVERLAY (STANDARD PRESET OVERLAY ROUTINES)

*COPYC CTP$DFT_PRESET_STANDARD_OVL
*COPY CTP$DFT_RETURN_ERROR_CODE
 CCL      SPACE  4,10
**        CCL - CHECK CONSOLE LOGGING.
*
*         NON-OPERATIONAL ROUTINE ON THE CYBER 990.


 CCL      SUBR               ENTRY/EXIT
          UJN    CCLX        RETURN
 SSO      SPACE  4,10
**        SSO - SETUP SPECIAL OVERLAY
*
*         EXIT   OVERLAY TO HANDLE BIT 57 ERRORS ON A MODEL 43(16) OR 44(16)
*                IOU.  LOADED AT LOCATION 10000(8) OF THE PP.

 SSO      SUBR               ENTRY
          LDM    IOUM
          LMC    0#43
          ZJN    SSO1        IF MODEL 43(16)
          LMC    0#44&0#43
          ZJN    SSO1        IF MODEL 44(16)
          UJN    SSOX        RETURN

 SSO1     LDC    SCO_O
          RJM    LOV         LOAD SPECIAL OVERLAY
          UJN    SSOX        RETURN


 SMV      SPACE  4,10
**        SMV - SETUP MODEL DEPENDENT VALUES
*
*         *SMV* WILL SET UP REGISTER LIST ADDRESSES ON A MODEL DEPENDENT BASIS
*         FOR CYBER 990 THE PROCESSOR LISTS ARE THPA FOR BOTH CORRECTED AND UNCORRECTED
*         ERRORS. THE IOU USED WILL BE AN I4 IN EITHER I4 OR I2 MODE. MEMORY USED WILL
*         BE CYBER 990 MODEL MEMORY.


 SMV      SUBR               ENTRY/EXIT
          LDC    DGCP        SET THE TASK LIST ADDRESS FOR DEGRADING A CPU
          STM    DTLA
          LDN    0
          STM    HALT        CLEAR HALT ON ERROR
          LDC    THPA
          STM    CP0U
          STM    CP0C
          LDM    CPU1M
          ZJN    SMV1        IF PROCESSOR 1 NOT DEFINED
          LDC    THPA
          STM    CP1U
          STM    CP1C
 SMV1     LDC    I4IU
          STM    IO0U        UNCORRECTED REGISTER LIST
          LDC    I4IC
          STM    IO0C        CORRECTED REGISTER LIST
          LDML   IOUM
          LMC    0#44
          ZJN    SMV2        IF MODEL 44
          READMR RDATA,I0CC,OIMR  I4 PROCESSOR
          LDM    RDATA+7
          SHN    10D         CHECK BIT 56 FOR CIO PP PRESENT
          MJN    SMV3        IF CIO PPS PRESENT
 SMV2     LDC    SXIU        SET UP REGISTERS FOR I4 IN I2 MODE
          STM    IO0U        UNCORRECTED REGISTER LIST
          STM    IO0C        CORRECTED REGISTER LIST

 SMV3     BSS    0           DO MEMORY PROCESSING
          LDC    THMA        COMPLETE REGISTER LIST FOR MEMORY ERRORS
          STM    ME0U        UNCORRECTED MEMORY ERROR
          STM    ME0C        CORRECTED MEMORY ERROR

*         DETERMINE THE MICROCODE LEVEL ON THE 990.  IF THE LEVEL
*         IS NOT AT LEAST 18, THEN SET A FLAG TO DISABLE THE DFT
*         FEATURES USING LEVEL 18 MICROCODE.

 SMV9     LDN    PROCID
          RJM    FHE         FIND HARDWARE ELEMENT
          MJP    SMV20       IF NOT FOUND, TERMINATE
          LDML   HBUF+CPRUNAM+CPRMLX1  MICROCODE NAME
          LPN    0#3F
          SHN    6
          STDL   T6          SAVE 1ST DIGIT OF LEVEL NUMBER
          LDML   HBUF+CPRUNAM+CPRMLX2  MICROCODE NAME
          SHN    -6
          LMDL   T6
          STML   MICL        MICROCODE LEVEL (DISPLAY CODE)
          ADC    -MICLEV
          MJN    SMV10       IF UCODE LEVEL < *MICLEV*
          LDN    1
          STML   MICL        STORE FLAG
          UJN    SMV11       CONTINUE PROCESSING

 SMV10    LDN    0
          STML   MICL        STORE FLAG

*         INITIALIZE THE FIRST WORD OF EACH MODEL DEPENDENT
*         BUFFER THAT IS PRESENT.  THIS INITIALIZES/CLEARS
*         THE INTERLOCK FLAGS STORED IN BYTE 0 OF WORD 0,
*         ALLOWING THE NEXT MODEL DEPENDENT BUFFER TO GET
*         LOGGED.

 SMV11    LDN    VER4        LOAD VERSION
          RJM    VCK         CHECK VERSION
          PJP    SMVX        IF VERSION 4 OR GREATER
          LDN    MDLP        MODEL DEPENDENT BUFFER POINTER
          RJM    IDA
          CRDL   RS          R-REGISTER FOR MDB
          LRD    RS+1
          RJM    SPB         SET PP BOUNDS
          LDD    RS          R-REGISTER OFFSET
          ADC    RR
          CWML   SMVA,ON     WRITE ZEROS TO FIRST WORD OF MDB FOR CPU0
          LDML   CPU1M
          ZJP    SMVX        IF SINGLE CPU EXIT
          LDDL   RS+3        MDB LENGTH
          SHN    -1          DIVIDE LENGTH BY 2
          RAD    RS          ADD LENGTH OF 1 MDB TO OFFSET
          ADC    RR
          CWML   SMVA,ON     WRITE ZEROS TO FIRST WORD OF MDB FOR 2ND CPU
          LJM    SMVX

 SMV20    SETDAN (EPUN,DAME)
          LDC    DAME+TDFT   613 - DFT NO DESC IN MRT
          STML   RTP1
          CALL   ERRH

 SMVA     BSSZ   4           CM WORD OF ZEROS
*COPY     CTP$DFT_CLEAR_PACKETS_I4

**        END OF DFT PRESET OVERLAY AREA.
          OVERLAY  (MAIN NON RESIDENT ROUTINES)
**        START OF THE MAIN NON RESIDENT ROUTINES OVERLAY. ON CYBER 990
*         THIS OVERLAY DEFINES ROUTINES FOR DUAL STATE, DUAL I4,
*         HALT ON ERROR PROCESSING, EICB TIME UPDATE, AND PACKET COMMUNICATION.


*COPYC CTP$DFT_MAIN_NON_RES_RTNS
*COPY CTP$DFT_SET_SS_DUAL_I4
*COPYC CTP$DFT_MAIN_NON_RES_DUAL_STATE
*COPYC CTP$DFT_MAIN_NON_RES_DUAL_I4
*COPYC CTP$DFT_MAIN_NON_RES_EICB_TIME
*COPYC CTP$DFT_HALT_ON_ERROR_990
 ERR      CALL   ROS         REPORT OS ERROR

          OVERFLOW R2ORG     CHECK FOR OVERFLOW

**        END OF DFT MAIN NON RESIDENT ROUTINES.

          OVERFLOW R2ORG     CHECK FOR OVERFLOW

          OVERLAY  (AUX MAIN NON RESIDENT ROUTINES)
*COPYC CTP$DFT_CPU_HANDSHAKER
*COPYC CTP$DFT_MANAGE_PACKET_TRAFFIC
*COPYC CTP$DFT_LOG_PACKET_TIMEOUT
*COPY CTP$DFT_CHECK_TPM_PKT_RESPONSE
          ROUTINE ROS
          LJM    ERR
*COPY CTP$DFT_PREPARE_FOR_CIP_CALL
*COPY CTP$DFT_RETURN_ERROR_CODE

 RED      SPACE  4,10
**        RED - READ 960 POWER MONITOR.
*
*         ON ANY MACHINE OTHER THAN THE 960 THIS ROUTINE IS
*         NON FUNCTIONAL.


          ROUTINE RED
          LJM    REDX

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DO DFT ACTIONS)

**        START OF DFT ACTION LISTS. A COMMON SET OF DFT ACTIONS IS PROVIDED
*         ALONG WITH CYBER 990 SPECIFIC ONES RELATING TO CLEARING PROCESSOR ERRORS
*         AND MEMORY ERRORS.

*COPYC CTP$DFT_ACTION_LIST
*COPYC CTP$DFT_ACTION_LIST_DUAL_I4
*COPYC CTP$DFT_ACTION_LIST_DUAL_STATE


 CETH     BSS    0           CLEAR CYBER 990 ERRORS
          TASK   (LOG,MCP,CLE,CCR,HEO,CCA,MCP,RCM,IBP,CLE,CCR,THE)

 DDCM     BSS    0           CLEAR CM ERROR
          TASK   (CME)

 SDCP     BSS    0
          TASK   (SER,DIP)

 DGCP     BSS    0           DEGRADE CPU MEMORY PORT
          TASK   (SCW,SER,DIP)

 THUN     BSS    0           RELOAD CONTROL MEMORIES
          TASK   (RCM,LMB,IBP,LOG,SCW,CRR,CLE,SDB,THE,SER)

 THCE     BSS    0           CYBER 990 CATASTROPHIC ERROR
          TASK   (LMB,DID,LOG,SCW,DIP,WM7,SER,IFM)

 THFE     BSS    0           CYBER 990 FATAL ERROR
          TASK   (HEO,MCP,LMB,DID,LOG,SCW,DIP,WM7,SER,IFM)

 TREX     BSS    0           CYBER 990 RETRY EXHAUSTED
          TASK   (RCM,LMB,IBP,LOG,SCW,CLE,SDB,THE,SER)

 TRTY     BSS    0           CYBER 990 RETRY
          TASK   (RCM,LMB,IBP,LOG,SCW,CRR,CLE,SDB,THE,SER)

 TFEC     BSS    0           CYBER 990 FALSE ERROR CONDITION
          TASK   (CLE,THE,SER)
          QUAL   *

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (DO ADDITIONAL DFT ACTIONS)

**        START OF DFT ACTION LISTS OVERFLOW.  THIS IS AN EXTENSION OF THE COMMON
*         DFT ACTIONS.

          QUAL

*COPYC CTP$DFT_ACTION_LIST_OVERFLOW
*COPYC CTP$DFT_RETURN_TASK_ERROR
          QUAL   *
          QUAL   ABC
*COPY CTP$DFT_RETURN_ERROR_CODE
          QUAL   *

          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT SEND PACKETS OVERLAY)
*COPYC CTP$DFT_CHECK_PKTS_FOR_NON_S0
*COPYC CTP$DFT_CHECK_PKT_STATUS_NON_S0
*COPYC CTP$DFT_SEND_PACKET_ALL
*COPY  CTP$DFT_SEND_PACKET_FOR_NON_S0
*COPY  CTP$DFT_CLEAR_PACKETS_I4

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY (SAVE PP REGISTERS IN CENTRAL MEMORY)
*COPYC CTP$DFT_SAVE_PP_REGISTERS
*COPY  CTP$DFT_DUMP_PP_REGISTERS
 QUAL$    EQU    1
*COPY  DSI$DUMP_LOAD_IDLE_PP
          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT ERROR CONTROL OVERLAY)


*COPYC CTP$DFT_ERROR_CONTROL

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (LOG TOP OF HOUR COUNTERS)

*COPYC CTP$DFT_LOG_COUNTERS
 RMC      SPACE  4,10
**        RMC - RESET MODEL DEPENDENT COUNTERS
*                IF VERSION 4 OR GREATER, CHECK FOR MIDNIGHT.
*                IF SO, CLEAR THE LONGTERM INTERLOCK FLAG IN
*                THE MAIN CPU MODEL DEPENDENT BUFFER HEADER WORD.
*
*         USES   RS-RS+2, CM-CM+3
*
*         CALLS  VCK, IIB, SPB, IDA, CLR.
*

          ROUTINE RMC        ENTRY/EXIT
          LDN    1
          STM    RMCF
          LDN    VER4        VERSION NUMBER
          RJM    VCK
          MJP    RMC1        IF VERSION 3 OR LESS
          LDN    DFCM+7
          RJM    IIB
          CRML   RMCA,ON     GET TIME (TOP OF HOUR)
          LDML   RMCA+2
          LPC    0#FF00
          NJP    RMC1        IF NOT MIDNIGHT
          LRD    DP+1
          RJM    SPB         SET PP BOUNDS
          LDN    MDLP        MDB PTR OFFSET
          RJM    IDA
          CRDL   RS          READ MDB PTR
          LRD    RS+1        LOAD INTO R-REGISTER
          LDD    RS
          ADC    RR
          CRDL   RS          READ CPU0 MDB PTR
          LRD    RS+1        LOAD INTO R-REGISTER
          LDD    RS
          ADC    RR
          CRDL   CM          READ MDB HEADER WORD
          LDDL   CM          BITS 0-16
          LPC    0#F0FF      CLEAR BITS 4-7 (LONGTERM INTERLOCK)
          STDL   CM          RESTORE
          LDD    RS          R-REGISTER OFFSET
          ADC    RR          ACITIVATE R-REGISTER
          CWDL   CM          WRITE TO MDB
 RMC1     LDN    0           RESET COUNTERS
          STML   TRHC        RETRY HOUR COUNTER
          STML   TRHC+1      RETRY HOUR CNTR, CP 1
          STML   TRPC        RETRY P COUNTER
          STML   TRPC+1      RETRY P COUNTER, CP 1
          LDC    TRSP        RETRY P SAVE AREA
          RJM    CLR         INITIALIZE SAVED P AREA
          LDC    TRSP1
          RJM    CLR         INITIALIZE SAVED P AREA, CP 1

*         EVERY HOUR RELOAD 990 SCM USING 2AP FUNCTION 25(8).
*         IF AN ERROR OCCURS THE RELOAD WILL BE TRIED ONCE MORE. IF THE RELOAD
*         FAILS AGAIN AN ANALYSIS CODE WILL BE GENERATED AND EITHER A CPU WILL
*         BE RECONFIGURED OR THE SYSTEM WILL HALT. THIS IS ONLY DONE IF THE
*         DISABLE REFRESH OF 990 SCMS IS NOT SET IN THE DFT CONTROL WORD.

          LDN    HDRP
          RJM    IDA
          CRDL   CM
          LDDL   CM+3
          SHN    21-14
          MJP    RMCX        IF DISABLE SET QUIT
          LDN    0
          STM    CPUO
          LDN    PROCID
 RMC2     RJM    FHE
          MJP    RMCX        IF CPU NOT PRESENT
          LDN    ECMR        CM DEC REGISTER
          STDL   RN
          LDM    CMCC
          RJM    RMR         READ MEMORY DEC REGISTER
          RJM    CMP         CHECK MEMORY PORT
          NJP    RMC7        IF MEMORY PORT DISABLED

*         PROCESS THIS CPU.

          LDN    10B
          STD    T2
          LDM    HBUF+CPRPC
          STD    EC
 RMC3     READMR RDATA,,SSMR
          LDM    RDATA+7
          LPN    0#F
          NJP    RMCX        IF PROCESSOR HALTED OR HAS ERROR

          FUNCMR ,MRHP       HALT THE PROCESSOR
 RMC3.1   LDN    SSMR        SET REGISTER NUMBER
          STD    RN
          LDD    EC
          RJM    RMR         READ MAINTENANCE REGISTER
          SHN    21-SSPH
          PJN    RMC3.1      IF PROCESSOR NOT HALTED
          SHN    21-SSMM-21+SSPH+22
          PJN    RMC4        IF IN JOB MODE
          FUNCMR ,MRSP       START THE PROCESSOR
          SOD    T2
          PJP    RMC3
          UJP    RMC7        GO TO NEXT CPU

 RMC4     RJM    CCT         CLEAR CAPTURE BUFFER TRIGGER
          FUNCMR HBUF+CPRPC,MRCE  CLEAR ERRORS
          CALL   DMP         DISABLE MEMORY PORT
          CALL   EMP         ENABLE MEMORY PORT
          CALL   HEO         HALF EXCHANGE OUT
          FUNCMR HBUF+CPRPC,MRMC  MASTER CLEAR PROCESSOR
          LDN    SSMR
          STDL   RN
          LDML   HBUF+CPRPC
          RJM    RMR         READ STATUS,SUMMARY
          LPN    4
          ZJP    RMC5        IF NO CATASTROPHIC ERROR
          LRD    DP+1
          RJM    SPB
          LDN    BC
          RJM    CLR
          LDN    PROCID
          STD    ET

          SETDAN (EPCH,DARCE)
          SETFLG (BC.FL,BC.FV8)
          LDN    NRSBL-1
          STM    LLOG
          LDN    1
          STM    RTP1
          CALL   DID         DISABLE CPU
          LDM    TERT
          NJN    RMC4.4      IF DEGRADABLE CPU
          CALL   LOG
          SETDAC (DDDC)
          UJN    RMC4.5      DO DFT ACTION FOR SINGLE CPU

 RMC4.4   LDC    SDCP
          STM    DFTA        SET SPECIAL DFT ACTION
 RMC4.5   LDN    0
          STM    TERT
          CALL   DDA
          UJP    RMC7        DO NEXT CPU

 RMC5     LDN    25B
          STML   CALB
          LDML   CPUO
          STML   CALB+1
          LDC    0#180       RELOAD CONTROL STORE AND CONTROL WORD
          STML   CALB+2
          RJM    ECM         EXECUTE CIP MODULE
          RJM    RPW         RESTORE POINTER WORD
          LDML   CALB+2
          ZJP    RMC6        IF NO ERROR HEI AND PROCESS NEXT CPU

*         IF ERROR TRY RELOAD ONCE MORE AFTER MASTER CLEARING CPU.

          FUNCMR HBUF+HDRPC,MRMC

          LDN    25B
          STML   CALB
          LDML   CPUO
          STML   CALB+1
          LDC    0#180       RELOAD CONTROL STORE AND CONTROL WORD
          STML   CALB+2
          RJM    ECM         EXECUTE CIP MODULE
          RJM    RPW         RESTORE POINTER WORD
          LDML   CALB+2
          ZJP    RMC6        IF NO ERROR HEI AND PROCESS NEXT CPU
          LRD    DP+1
          RJM    SPB
          LDN    BC
          RJM    CLR
          LDN    PROCID
          STD    ET

          SETDAN (EPCH,DARME)
          SETFLG (BC.FL,BC.FV8)
          LDN    NRSBL-1
          STM    LLOG
          LDN    1
          STM    RTP1
          CALL   DID         DISABLE CPU
          LDM    TERT
          NJN    RMC5.4      IF DEGRADABLE CPU
          CALL   LOG
          SETDAC (DDDC)
          UJN    RMC5.5      DO DFT ACTION FOR SINGLE CPU

 RMC5.4   LDC    SDCP
          STM    DFTA        SET SPECIAL ACTION LIST
 RMC5.5   LDN    0
          STM    TERT
          CALL   DDA
          UJP    RMC7        DO NEXT CPU

 RMC6     CALL   IBP         INITIALIZE BDP SEQUENCE
          CALL   CLE         CLEAR ERRORS
          CALL   SDB         SET DEC BIT 18
          CALL   THE         THETA HALF EXCHANGE IN

 RMC7     LDN    0
          STM    TERT
          AOML   CPUO
          SBN    2
          PJP    RMCX        IF DONE WITH ALL CPUS
          LDC    PROCID1
          UJP    RMC2        PROCESS NEXT CPU


 RMCA     BSS    4           TIME STAMP FROM EICB
          SPACE  4,10
**        CCT - CLEAR CAPTURE BUFFER TRIGGER
*
*         CLEAR DEC BIT 18
*
*         USES   RDATA


 CCT      SUBR               ENTRY/EXIT
          READMR RDATA,HBUF+HDRPC,DEMR
          LDML   RDATA+2
          LPC    0#DF        CLEAR DEC BIT 18
          STML   RDATA+2
          WRITMR RDATA,HBUF+HDRPC,DEMR
          UJP    CCTX
*COPY     CTP$DFT_RESET_PIT
*COPY     CTP$DFT_RESTORE_POINTER_WORD
*COPY     CTP$DFT_TEST_DLD_PATH

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (ENVIRONMENT/SHORT WARNING PROCESSORS)

**        THIS OVERLAY HAS A STUBBED REFERENCE TO CHECK IF THE CONSOLE IS ALIVE.
*         ON CYBER 990 THIS MECHANISM IS NOT USED. THE STUB REPORTS THE CONSOLE IS ALIVE.

*COPYC CTP$DFT_ENVIRONMENT_RTNS
*COPY  CTP$DFT_FIND_WARNING_IN_NRSB
 CCA      SUBR
          LDN    1
          UJN    CCAX        REPORT CONSOLE ALIVE ON NON S0 MACH.
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY (ANALYSE CYBER 990 CPU ERRORS)
 APE      SPACE  4,10
**        APE - ANALYSE CYBER 990 PROCESSOR ERRORS.
*
*         CALLS  CLR, FMB, SPB, *ATE*, *CFF*, *LOG*, *STP*, *SWP*.


          ROUTINE APE

          LDN    0
          STM    NERR        SET NO ERROR FLAG FALSE
          STD    TF          TEMPORARY FLAGS
          STD    FE

*         IT IS NECESSARY TO SAVE THE PREHALT STATUS SUMMARY BECAUSE
*         HALTING THE PROCESSOR WILL SET THIS BIT.

          LDN    SSMR
          STD    RN
          LDM    HBUF+CPRPC
          RJM    RMR         READ MAINTENANCE REGISTER
          STM    SUMS
          STM    OLSS
          SHN    21-SSSW     SHORT WARNING
          PJN    APE1        IF NO SHORT WARNING
          CALL   SWP         CALL SHORT WARNING PROCESSOR
          LJM    APEX        RETURN

 APE1     RJM    CTE         CHECK THRESHOLD EXCEEDED
          NJP    APEX        IF THRESHOLD EXCEEDED IGNORE ERROR
          LDM    HALT
          ZJP    APE3        IF NOT HALT ON ERROR
          LDM    SUMS
          SHN    21-SSUE
          PJN    APE3        IF NOT (UNCORRECTED ERROR)
          LDN    0
          STML   HTFL        HALT TIMING FLAG
          RJM    DLY         DELAY 100 MILLISEC
          LDM    SUMS
          SHN    21-SSPH
          MJN    APE4        IF CP HALTED BEFORE DELAY
          LDN    SSMR        READ SUMMARY STATUS
          STD    RN
          LDM    HBUF+CPRPC
          RJM    RMR         READ MAINTENANCE REGISTER
          STML   OLSS
          LPN    8D
          ZJN    APE2        IF NOT HALTED
          LDN    1
          STML   HTFL        CP HALTED AFTER DELAY
          UJN    APE4

 APE2     LDN    2
          STML   HTFL
 APE3     LDN    0
          RJM    SCS         SAVE PRE-HALT CONTROL STORE ADDRESS
          CALL   STP         CALL STOP PROCESSOR
 APE4     LDN    1
          RJM    SCS         SAVE AFTER HALT CONTROL STORE ADDRESS
          LDM    CPUO
          STM    CPUH        HALTED CPU ORDINAL

*         DISABLE *PFS* AND BLOCK EXCHANGE REQUEST BITS SET IN *DEC*.

          LDN    BC
          RJM    CLR
          LDM    OLSS
          SHN    21-SSPH     PROCESSOR HALT IN SUMMARY STATUS
          PJP    APE7        IF PROCESSOR NOT HALTED
          LDM    HALT        GET HALT ON ERROR FLAG
          NJP    APE7        IF HALT ON ERROR SET

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = PROCESSOR HALT.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).

          SETDAC DDDC
          SETDAN (EPUN,DAPH)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          LDM    CPUH        GET ORDINAL OF CPU BEING PROCESSED
          NJN    APE5
          LDM    CP0U        GET UNCORRECTED REGISTER LIST FOR CPU0
          UJN    APE6        CONTINUE

 APE5     LDM    CP1U        GET UNCORRECTED REGISTER LIST FOR CPU1
 APE6     RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          LJM    APE16       CONTINUE PROCESSING

 APE7     LDM    SUMS        SUMMARY STATUS
          SHN    21-SSUE     UNCORRECTED ERROR
          PJP    APE10       IF NOT UNCORRECTED ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED PROCESSOR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).
*         DFT ANALYSIS - OS ACTION = UNCORRECTED PROCESSOR ERROR.
*                                  = NO OS ACTION (VERSION 4).

          SETDAN (EPUN,DAUPE)
          SETFLG (BC.FL)
          SETOSA OSUPE,OSNA
          LDM    CPUH        GET ORDINAL OF CPU BEING PROCESSED
          NJN    APE8
          LDM    CP0U        GET UNCORRECTED REGISTER LIST FOR CPU0
          UJN    APE9        CONTINUE

 APE8     LDM    CP1U        GET UNCORRECTED REGISTER LIST FOR CPU1
 APE9     RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          LJM    APE16       CONTINUE PROCESSING

 APE10    LDM    SUMS        SUMMARY STATUS
          SHN    21-SSCE     CORRECTED ERROR
          PJP    APE13       IF NOT CORRECTED ERROR
          LDM    OLSS        GET SAVED STATUS SUMMARY
          SHN    21-SSPH
          MJP    APE13       IF PROCESSOR HALT

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CORRECTED PROCESSOR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAN (EPCO,DACPE)
          SETFLG (BC.FL)
          LDM    CPUH        GET ORDINAL OF CPU BEING PROCESSED
          NJN    APE11
          LDM    CP0C        GET CORRECTED REGISTER LIST FOR CPU0
          UJN    APE12       CONTINUE

 APE11    LDM    CP1C        GET CORRECTED REGISTER LIST FOR CPU1
 APE12    RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          LJM    APE16       CONTINUE PROCESSING

 APE13    LDM    HALT        HALT ON ERROR FLAG
          ZJP    APE16       IF NO HALT ON ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED PROCESSOR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).
*         DFT ANALYSIS - OS ACTION = UNCORRECTED PROCESSOR ERROR.
*                                  = NO OS ACTION (VERSION 4).

          SETDAN (EPUN,DAUPE)
          SETFLG (BC.FL)
          SETOSA OSUPE,OSNA
          LDM    CPUH        GET ORDINAL OF CPU BEING PROCESSED
          NJN    APE14       IF CPU1
          LDM    CP0U        GET UNCORRECTED REGISTER LIST FOR CPU0
          UJN    APE15       CONTINUE

 APE14    LDM    CP1U        GET UNCORRECTED REGISTER LIST FOR CPU1
 APE15    RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
 APE16    CALL   CFF         CHECK FOR FREEZE
          SETDAC (CETH)
          CALL   ATE         CALL THETA OVERLAY

          LDM    CPUO
          RJM    SSE         SET SECONDARY ELEMENT IDENTIFIER
          LDN    0
          STDL   TF          CLEAR FLAG
          LJM    APEX        RETURN
          QUAL   *

*COPY     CTP$DFT_SAVE_CONTROL_STORE
*COPY CTP$DFT_CHECK_CPU_THRESHOLD
*COPY     CTP$DFT_990_960_DEGRADE_CPU

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (CYBER 990 OVERLAY)
          SPACE  4,10
**        ATE -  ANALYSE THETA ERRORS.
*
*         *ATE* IS CALLED BY GENERIC *APE* TO ANALYSE THETA ERRORS.
*
*         ENTRY  (BC+BCDA) = ANALYSIS CODE FROM ATE.
*                *MICL*      MICROCODE LEVEL FLAG 0 INDICATES THAT THE LEVEL OF MICROCODE
*                            THAT IS RUNNING IS LSS THAN *MICLEV*.  A 1 INDICATES THAT THE
*                            LEVEL IS GREATER THAN *MICLEV*.
*
*         CALLS  ARC, CEW, CIT, SPP, LFA, THO, CCT, RCP, PAC, PEP.


          ROUTINE ATE        ENTRY/EXIT

*         CHECK -  PROCESSOR HALT, CLASS II

          LDN    0
          STML   MRBA        CLEAR SCM PE COUNTER
          STDL   TF          CLEAR TEMPORARY FLAG
          STDL   FE          CLEAR FALSE ERROR FLAG
          LDML   CPUO
          STDL   SN
          READMR RDATA,HBUF+HDRPC,PCSA  READ CSA
          RJM    PAC         MRVAL=CSA
          LDML   MRVAL+3
          LPC    0#7FE
          STML   ATEA        ATEA=CSA
          STML   CSAA        SAVE FOR DFT V4
          SBN    CSHA        CS HALT ADDR
          NJP    ATE1        IF CSA NOT 24/25
          READMR RDATA,HBUF+CPRPC,PMCR
          LDML   RDATA+6
          LPC    0#80
          NJP    ATE2        IF DUE, PROC HALT CLASS I
          SETDAN (EPCH,DASWH) ANALYSIS=FATAL, PROC.HALT CLASS II
          SETDAC THFE        ACTION=THETA FATAL ERROR
          SETFLG (BC.FV7,BC.FV8,BC.FL)  LOGGING FLAGS
          CALL   CEW
          LJM    ATEX        RETURN

*         CHECK - PROCESSOR HALT, CLASS I

 ATE1     LDML   MICL        MICROCODE LEVEL
          ZJP    ATE3        IF MIC LEVEL <= 16
          LDML   ATEA
          ADC    -CSHHA
          NJN    ATE3        IF CSA =/= 92
 ATE2     SETDAN (EPCH,DAPH)  ANAL=FATAL, PROC.HALT CLASS I
          SETDAC THFE        ACTION=THETA FATAL ERROR
          SETFLG (BC.FV7,BC.FV8,BC.FL)  LOGGING FLAGS
          CALL   CEW
          LJM    ATEX        RETURN

*         CHECK - RETRY IN PROGRESS.

 ATE3     LDML   HALT
          ZJN    ATE4        IF NOT HALT ON ERROR
          LDML   MICL        MICROCODE LEVEL
          ZJN    ATE4        IF MIC REV < MICLEV
          LDML   MRVAL+3     CSA
          LPC    0#FE
          ADC    -CSRA       CS RETRY ADDR
          NJN    ATE4        IF NOT RETRY IN PROGRESS
          CALL   CEW         CAPTURE EXECUTING WORDS
          RJM    CCT         CLEAR CAP BUF TRIGGER
          CALL   ARC         ANALYZE RETRY CONDITION
          LDML   C9EF
          NJP    ATE12       IF CATASTROPHIC ERROR
          LJM    ATEX        RETURN

*         CHECK - CORRECTED PROCESSOR ERROR.

 ATE4     LDDL   BC+BCDA     LOAD CURRENT DFT.ANALYSIS CODE
          LPC    0#FF        MASK ERROR CODE
          SBN    DACPE       CORRECTED PROCESSOR ERROR CODE
          NJN    ATE5        IF NOT CORRECTED
          RJM    SPP         SCAN PFS
          LDML   CTIB
          ZJP    ATE4.5      IF NO PARITY ERROR
          SETDAN (EPCO,DARES)
          SETDAC (CETH)
          UJP    ATE11.1

 ATE4.5   RJM    RCP         READ CACHE *PFS*
          LJM    ATEX        RETURN, CORRECTED PROCESSOR ERROR

*         DEFAULT - UNCORRECTED PROCESSOR ERROR.

 ATE5     BSS    0
          LDC    PPFS+6
          RJM    FMB
          CRDL   CM          READ PFS 86 FROM SCRATCH BUFFER
          LDDL   CM+1
          LPC    PFPW        MASK PARTIAL WRITE PE BIT
          NJP    ATE10.5     IF BIT 27 SET
          LDN    HDRP
          RJM    IDA
          CRDL   CM
          LDDL   CM+DHFLG
          SHN    21-DH.FD
          MJP    ATE11       IF NON-DEDICATED

          LDML   OLSS        SAVED SS
          SHN    21-SSUE
          PJP    ATE11       IF NOT UNCORRECTED
          RJM    CIT         CHECK FOR ISSUE TIMEOUT
          ZJP    ATE8        IF NOT ISSUE TIMEOUT
          LDML   ATEA
          SBN    CSAH        CSA HALT ADDRESS
          LPC    0#FFFD      MASK LOWER BIT
          NJP    ATE8        IF NOT CSA = 21/22
          RJM    SOE         SCAN FOR OTHER ERRORS
          NJP    ATE8        IF OTHER CONDITIONS PRESENT
          LDC    IDU.CIR+1
          STDL   RN

          EXITMR ATE6

          LDM    HBUF+HDRPC  FORM FUNCTION WORD
          ADC    MRRD        ADD FUNCTION
          ADC    TC.IDU      ADD TYPE CODE
          RJM    AMR         ACCESS MAINTENANCE CHANNEL
          LDN    10
          IAM    RDATA,MR
          RJM    CMI         CLEAR MAINTENANCE INTERLOCK

 ATE6     EXITMR FMR

          LDML   RDATA+3
          LPC    VMID
          NJP    ATE8        IF VMID=170

*         ANALYSIS = THETA FALSE ERROR

          SETDAC TFEC        ACTION = THETA FALSE ERROR
          LDN    1
          STDL   FE
          CALL   THO         HALF EXCHANGE OUT
          LDML   C9EF
          ZJN    ATE7        IF NO ERROR ON HEO

          CALL   CEW         CAPTURE EXECUTING WORDS
          UJP    ATE13       HANDLE CATASTROPHIC ERROR

 ATE7     CALL   APC         ANALYZE P CONDITION
          CALL   PEP         PATCH EXCHANGE PACKAGE
          LDN    1
          STDL   TF          SET FLAG = NO LOGGING
          UJP    ATEX        RETURN

 ATE8     LDML   HTFL        HALT TIMING FLAG
          ZJP    ATE11       IF CODE = 0, CPU HALTED
          SBN    1
          ZJN    ATE9        IF CODE = 1
          SBN    1
          ZJN    ATE10       IF CODE = 2, FATAL
 ATE9     RJM    CIT         CHECK FOR ISSUE TIMEOUT
          NJP    ATE11       IF ISSUE TIMEOUT


 ATE10    CALL   CEW         WRITE EXECUTING SCM WORDS TO MDB
          SETDAN (EPCH,DAFUE)
          SETDAC THCE
          SETFLG (BC.FV7,BC.FV8)
          LJM    ATEX

 ATE10.5  CALL   CEW         WRITE EXECUTING SCM WORDS TO MDB
          SETDAN (EPCH,DAPWE)
          SETDAC THUN
          SETOSA (OSMOB,OSSS) MULTIPLE ODD BIT-STEP SYSTEM
          UJN    ATE11.0

 ATE11    CALL   CEW         WRITE EXECUTING SCM WORDS TO MDB
          SETDAN (EPUN,DAUPE)
          SETDAC THUN        ACTION=THETA UNCORRECTED
 ATE11.0  RJM    CCT         CLEAR CAP BUF TRIGGER
          CALL   CRR         CLEAR DEC BIT 42
          CALL   THO         THETA HALF EXCHANGE OUT
          LDML   C9EF
          NJP    ATE12       IF CATASTROPHIC ERROR
          CALL   PEP         PATCH XCHG PKG (MCR)
          RJM    SPP         SCAN PFS BITS, SET UP CTIB
          LDML   CTIB        LOAD CTI BUFFER
          ZJP    ATEX        IF NO PE'S, EXIT

*         ANALYSIS = REPAIRABLE ERROR

          LDDL   BC+BCDA     CURRENT ANALYSIS CODE
          SBN    DAPWE       CHECK IF PARTIAL WRITE PE
          ZJN    ATE11.5     IF SO, LEAVE ANALYSIS
          SETDAN (EPUN,DARES) ANALYSIS CODE = REPAIRABLE ERROR SUCCESSFUL
 ATE11.1  LDDL   BC+BCOA
          LPC    0#FF00      CLEAR PREVIOUS OS ACTION CODE
          STDL   BC+BCOA
 ATE11.5  CALL   LFA         SWEEP MEMORIES, LOG FAILING ADDR & CONTENTS
          LJM    ATEX        RETURN

*         ANALYSIS = CATASTROPHIC ERROR

 ATE12    CALL   LOG         LOG PREVIOUS ERROR
          LDN    1
          RJM    SCS         SAVE CONTROL STORE ADDRESS

*         SET UP BUFFER CONTROL WORD
*         DFT.ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR
*         DFT.ANALYSIS - CODE = CATASTROPHIC ERROR
*         DFT ACTION CODE = THETA CATASTROPHIC ERROR
*         FLAGS = VALID 170, LOGGING FLAG

 ATE13    SETDAN (EPCH,DACRE)
          SETDAC THCE
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          LDM    CPUH        GET ORDINAL OF CPU BEING PROCESSED
          NJN    ATE14       IF NOT CPU0
          LDM    CP0U        GET UNCORRECTED ERROR LIST FOR CPU0
          UJN    ATE15

 ATE14    LDM    CP1U        GET UNCORRECTED ERROR LIST FOR CPU1
 ATE15    RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ MAINTENANCE REGISTERS

          LJM    ATEX


 ATEA     CON    0

*COPY CTP$DFT_SAVE_CONTROL_STORE

          EJECT
**        CEW - CAPTURE EXECUTING WORDS OF SCM'S
*
*         METHOD             IF VERSION 4, DO NOT EXECUTE.  IF VERSION 4
*                            AND AN ISSUE TIME OUT IS PRESENT, CALL AND
*                            EXECUTE THE ROUTINE EMV.  IF NOT VERSION 4
*                            READ EXECUTING WORDS OF RESPECTIVE SOFT
*                            CONTROL MEMORIES AND WRITE TO THE BEGINNING
*                            OF THE MODEL DEPENDENT BUFFER.
*                            THIS STEP IS PERFORMED HERE TO CAPTURE THE
*                            DATA BEFORE A MASTER CLEAR.
*
*         CALLED BY          ATE, ARC.
*
*         CALLS              BMP,SPB,IDA,CIT,AMP,RMR,PAC,CMI,AMR, EMV, CIT.
*
*         USES               W6, W7, RS - RS+3, CM, MRVAL, CEWF.
*
*         MACROS             EXITMR.
*
*
*         THE FOLLOWING IS TRUE ONLY IF NOT VERSION 4.
*
*         BEFORE WRITING THE MODEL DEPENDENT BUFFER, THE INTERLOCK
*         CODE MUST BE CHECKED TO ENSURE THAT A HIGHER PRIORITY
*         ERROR HAS OCCURRED.  BITS 14-15 IN THE FIRST WORD OF THE
*         MDB CONTAIN THIS PRIORITY CODE.  THE CODES ARE DEFINED
*         AS FOLLOWS:     0 - MDB HAS NOT BEEN LOGGED
*                         1 - NON ISSUE TIMEOUT ERROR HAS BEEN LOGGED
*                         2 - ISSUE TIMEOUT ERROR HAS BEEN LOGGED
*         IF THE CURRENT CONDITION HAS A HIGHER PRIORITY THAN WHAT
*         IS CURRENTLY LOGGED, THEN THE MDB IS OVERWRITTEN.  IF IT
*         CANNOT BE OVERWRITTEN, BIT 0 IS SET IN THE FIRST WORD AS
*         A FLAG FOR ROUTINE LMB.

          ROUTINE CEW

          LDN    VER4        VERSION NUMBER
          RJM    VCK         CHECK VERSION
          MJN    CEW1        IF NOT VERSION 4
          LDN    0
          STML   CEWF        INITIALIZE CEW FLAG

          RJM    CIT         CHECK FOR ISSUE TIME OUT
          ZJN    CEW0        IF VERSION 4 AND NO ISSUE TIMEOUT

*         VERSION 4 AND ISSUE TIME OUT.

          LDN    1
          STML   CEWF        SET CALLED FROM CEW FLAG
          CALL   EMV         VERSION 4 DFT MAIN

          LDN    0
          STML   CEWF        CLEAR CALLED FROM CEW FLAG
 CEW0     UJP    CEWX        EXIT

 CEW1     RJM    CIT         CHECK FOR ISSUE TIMEOUT
          ZJP    CEW2        IF NO ISSUE TIMEOUT
          LDN    MDB.IT      ISSUE TIMEOUT INTERLOCK CODE
          UJP    CEW3

 CEW2     LDN    MDB.NIT     CODE FOR NO ISSUE TIMEOUT
 CEW3     STDL   W6          (W6) = CODE FOR CURRENT ERROR CONDITION
          CALL   BMP         BUILD MDB POINTER
          LRD    RS+1
          RJM    SPB         SET PP BOUNDS
          LDD    RS
          ADC    RR
          CRDL   CM          (CM - CM+3) = FIRST WORD OF MDB
          LDDL   CM
          LPN    MDB.IC      MASK MDB INTERLOCK CODE
          STDL   W7          (W7) = MDB INTERLOCK CODE
          SBDL   W6
          PJP    CEW4        IF MDB INTERLOCK >= CURRENT ERROR CONDITION, DON'T LOG
          LDN    PCSA        CONTROL STORE ADDRESS REGISTER
          STDL   RN
          LDM    HBUF+CPRPC
          RJM    RMR         READ CONTENTS OF CSA
          RJM    PAC         PACK DATA INTO MRVAL
          LDDL   W6
          STML   MRVAL       SET NEW MDB INTERLOCK CONDITION
          LDD    RS
          ADC    RR
          CWML   MRVAL,ON    WRITE NEW INTERLOCK CODE AND CSA TO MDB

          CALL   RWE         READ/WRITE  EXECUTING WORDS OF SCM'S

 CEW4     LDDL   CM
          LPC    MDB.IM      FORCE INTERLOCK FLAG CLEAR
          LMC    MDB.IF      SET INTERLOCK FLAG
          STDL   CM
          LRD    RS+1
          RJM    SBP
          LDD    RS
          ADC    RR
          CWDL   CM          WRITE BACK TO MDB
          UJP    CEWX
          EJECT
*COPY  CTP$DFT_990_SCAN_PFS_BITS
          EJECT
**        RCP - READ CACHE PFS BITS
*
*         METHOD             READ CACHE PFS BITS (PFS RGTR 8F) TO CHECK
*                            FOR STALE DATA.  IF STALE DATA FOUND, THEN
*                            CHANGE DFT ACTION TO RELOAD CACHE.  SET BIT
*                            5 IN WORD 25 OF SCRATCH BUFFER TO DESIGNATE
*                            CACHE RELOAD
*
*         CALLED             BY ATE
*
*         CALLS              FMB


 RCP      SUBR               ENTRY/EXIT
          LDC    0#8F
          RJM    FMB
          CRDL   CM          READ RGTR 8F FROM SCRATCH BUF
          LDDL   CM
          LPN    0#F         MASK BITS 12-15
          NJP    RCP1        IF STALE DATA
          LDDL   CM+1
          LPN    0#20        MASK BIT 26
          ZJP    RCPX        IF NO STALE DATA
 RCP1     SETDAC CETH        DFT ACTION = THETA CACHE RELOAD
          SETDAN (EPCO,DACCR)
          UJP    RCPX
          EJECT
**        LFA - LOG FAILING ADDRESS
*
*         METHOD             READ CTIB.  IF BIT IS SET THAT INDICATES
*                            A PARITY ERROR IN A CONTROL MEMORY, THEN
*                            LOCATE THE FAILING ADDRESS.  ISOLATE BIT
*                            IN CTIB AND LOG THIS PE INDICATOR ALONG WITH
*                            THE FAILING ADDRESS AND CONTENTS IN WORDS 25-26
*                            OF SCRACH MRB.  IF MORE THAN 1 MEMORY HAS A
*                            PE, LOG THE CURRENT SCRACH BUFFER, SAVING
*                            THE OFFSET OF WHERE IT WAS LOGGED IN THE
*                            MRBA TABLE. OFFSET ZERO OF THE MRBA TABLE
*                            CONTAINS THE NUMBER OF ELEMENTS IN TABLE.
*                            ENTRIES 1..N HOLD OFFSETS OF MRB'S IN THE
*                            ORDER THEY WERE LOGGED.
*
*         CALLED             BY ATE
*
*         ENTRY              CTIB CONTAINS BITS DEFINING WHICH CONTROL
*                            MEMORIES NEED TO BE SWEEPED AND RELOADED.
*
*         CALLS              SBP, IMB, CRB, LOG


          ROUTINE LFA

          LDN    0
          STML   FLPE        INITIALIZE FLAG, 0 OR 1 PE
          LDN    11D
          STDL   T1
 LFA0     LDN    0           INITIALIZE MRBA
          STML   MRBA,T1
          SODL   T1
          PJP    LFA0        IF NOT DONE
          LDN    0
          STDL   SN          UNIQUE MEMORY OFFSET
          LDN    1
          STML   SCPM        SHIFT TO MASK CTIB BITS
 LFA1     LDML   CTIB
          LPML   SCPM        MASK BIT
          ZJP    LFA9        IF NO PE, DO NOT SWEEP MEMORY
          RJM    CRB         INITIALIZE RBUF TO ZEROS
          LDM    HBUF+CPRPC
          STDL   EC
          FUNCMR ,MRCE       CLEAR ERRORS (CPU)
          LDDL   SN
          SBN    9D
          ZJP    LFA5        IF MEMORY = BP3
          LDN    0
          STML   FAIL        INITIALIZE ADDRESS OFFSET
 LFA2     LDML   LFAA,SN     LOAD STARTING ADDRESS
          ADML   FAIL        ADD OFFSET
          STDL   RN

          EXITMR LFA2.5

          LDM    HBUF+HDRPC  FORM FUNCTION WORD
          ADC    MRRD
          ADML   LFAB,SN     ADD TYPE CODE
          RJM    AMR         ACCESS MNTCE CHANNEL
          LDN    7           BYTE COUNT
          IAM    RBUF,MR     BLOCK INPUT
          RJM    CMI         CLEAR MNTCE INTERLOCK

 LFA2.5   EXITMR FMR

          READMR RDATA,HBUF+HDRPC,PFS0  READ PFS 80
          LDML   RDATA
          LPN    0#10        MASK READ DATA PE
          NJP    LFA3        IF FAILING ADDRESS FOUND
          AOML   FAIL        UPDATE ADDRESS OFFSET
          SBML   LFAF,SN     SUBTRACT (LENGTH+1)
          MJP    LFA2        IF NOT DONE SWEEPING
          LDC    0#FFFF
          STML   FAIL        ADDRESS NOT FOUND
          RJM    CRB         CLR RBUF
          UJP    LFA6.5

 LFA3     LDDL   SN
          SBN    5
          ZJP    LFA4        IF IMAP
          SBN    3
          NJP    LFA6        IF NOT CONTROL STORE

          EXITMR LFA3.5

          RDMEM  IDU.CSMM,FAIL,RBUF,,8,TC.IDU

 LFA3.5   EXITMR FMR

          UJP    LFA6

 LFA4     EXITMR LFA4.5

          RDMEM  INU.IMAP,FAIL,RBUF,,8,TC.IDU

 LFA4.5   EXITMR FMR

          UJP    LFA6

 LFA5     RJM    SBP         SWEEP BP3

*         LOG CTIB, TYPE CODE AND FAILING ADDR IN MRB

 LFA6     LDML   LFAA,SN
          RAML   FAIL
 LFA6.5   LDML   FLPE        CHECK IF 2ND OR GREATER PE
          ZJP    LFA7        IF 1ST PE, DO NOT LOG MRB
          CALL   LOG         LOG CURRENT MRB
          LDML   FREE
          ZJP    LFA9        IF NO ENTRY FOUND, SKIP
          AOML   MRBA        ADD ENTRY TO TABLE
          STDL   T2
          LDML   FREE
          STML   MRBA,T2
 LFA7     LDN    1
          STML   FLPE        SET FLAG
          LDN    2
          STDL   T7          # OF WORDS TO TRANSFER
          LDN    25D
          RJM    IMB         GET R-RGTR
          CRML   LFAC,T7     READ 2 CM WORDS

*         MODIFY CONTENTS

          LDML   CTIB
          LPML   SCPM        MASK OUT OTHER BITS
          STML   LFAC        STORE PE INDICATOR
          LDN    0
          STML   LFAC+1      TO BE MODIFIED BY ACTION
          LDML   LFAB,SN
          STML   LFAC+2      STORE TYPE CODE
          LDML   FAIL
          STML   LFAC+3      STORE FAILING ADDR
          LDN    0           PACK RBUF INTO LFAC
          STDL   W3
          STDL   W4
 LFA8     LDML   RBUF,W3    STORE UPPER BYTE
          LPC    377
          SHN    10
          ADM    RBUF+1,W3  ADD LOWER BYTE
          STML   LFAC+4,W4
          LDN    2
          RADL   W3
          AODL   W4
          SBN    4           LOOP 4 TIMES
          NJP    LFA8        IF NOT DONE
          LDN    25D
          RJM    IMB         GET R-RGTR
          CWML   LFAC,T7     WRITE BACK TO MEMORY
 LFA9     AODL   SN          UPDATE
          ADC    -10D
          ZJP    LFAX        IF DONE, RETURN
          LDML   SCPM
          SHN    1
          STML   SCPM
          LJM    LFA1        CHECK NEXT MEMORY


*         EQUATES TO STARTING MEMORY ADDRESSES
*         (ORDER MEMORIES ARE DEFINED IN CTIB)

 LFAA     BSS    0
          CON    ACU.M2
          CON    ACU.M3
          CON    ACU.M4
          CON    BDP.SCM
          CON    EPN.SCM
          CON    INU.IMAP
          CON    LSU.SCM
          CON    IDU.CW
          CON    IDU.CSMM
          CON    BP3.FWA

*         APPROPRIATE TYPE CODES

 LFAB     BSS    0
          CON    TC.ACU
          CON    TC.ACU
          CON    TC.ACU
          CON    TC.BDP
          CON    TC.EPN
          CON    TC.IDU
          CON    TC.LSU
          CON    TC.IDU
          CON    TC.IDU
          CON    TC.BDP

*         TEMP STORAGE LOCATION

 LFAC     CON    0,0,0,0
          CON    0,0,0,0

*         ADDRESS REPORTED IF FAILING ADDR NOT FOUND

 LFAD     BSS    0
          CON    0#900
          CON    0#A00
          CON    0#B00
          CON    0#E00
          CON    0#20
          CON    0#2400
          CON    0#20
          CON    0#6300
          CON    0#5400

*         MEMORY SIZE - (64 BIT LENGTH +1)

 LFAF     BSS    0
          CON    0#100
          CON    0#100
          CON    0#100
          CON    0#200
          CON    0#20
          CON    0#400
          CON    0#20
          CON    0#C00       300H * 4
          CON    0#1400      500H * 4
          EJECT
 CRB      SPACE  4,10
**        CRB - CLEAR RBUF BUFFER.
*
*         METHOD             WRITE 8 PP WORDS, AT ADDRESS RBUF, WITH ZEROS.
*
*         CALLED             BY CALL TO CRB


 CRB      SUBR               ENTRY/EXIT
          LDN    7
          STDL   T4
 CRB0     LDN    0
          STML   RBUF,T4
          SODL   T4
          PJN    CRB0        IF NOT DONE, CLEAR NEXT BYTE
          LJM    CRBX
          EJECT
**        SBP - SWEEP BP3 SOFT CONTROL MEMORIES
*
*         METHOD             RELEASE LATCH ON FIRST WORD OF EACH BP3 MEMORY
*                            READ BP3 CONTROL MEMORY 1 WORD AT A TIME AND CHECK
*                            APPROPRIATE PFS BITS UNTIL FAILING ADDRESS
*                            IS FOUND.  IF ALL ADDRESSES ARE READ AND
*                            THE FAILING ADDRESS IS NOT DETECTED, C00 (16) WILL
*                            BE REPORTED FOR THE FAILING ADDRESS.  THE CONTENTS
*                            WILL ALWAYS BE REPORTED AS ZEROS, SINCE THIS
*                            MEMORY CANNOT BE READ.
*
*         CALLED             BY RJM TO SBP
*
*         EXIT               (FAIL) = FAILING ADDRESS
*                            (RBUF) =  ZEROS
*
*         CALLS              CRB, PAC
*
*         MACROS EXITMR.


 SBP      SUBR               ENTRY/EXIT
          LDC    0#100
          STML   FAIL        ADDRESS OFFSET
          STDL   T4
          LDN    0
          STDL   T3          WORD COUNTER
          LDM    HBUF+CPRPC
          STDL   EC

 SBP0     EXITMR SBP0.5

          RDMEM  BP3.FWA,T4,,,,TC.BDP    RELEASE LATCH

 SBP0.5   EXITMR FMR

          LDC    0#200
          RADL   T4
          ADC    -0#D00
          NJP    SBP0
          FUNCMR ,MRCE

 SBP1     EXITMR SBP1.5

          RDMEM  BP3.FWA,FAIL,,,,TC.BDP    READ BYTE 0

 SBP1.5   EXITMR FMR

          READMR RDATA,HBUF+HDRPC,PFS6
          RJM    PAC         RESULT NOW IN MRVAL -  PACKED
          LDML   MRVAL       MASK PFS BITS
          LPN    0#23
          NJP    SBP2        IF FAILING ADDR FND
          LDML   MRVAL+1
          LPC    0#02C0
          NJP    SBP2        IF FAILING ADDR FOUND
          AOML   FAIL        UPDATE ADDRESS OFFSET
          AODL   T3          UPDATE WORD COUNTER
          SHN    9D
          PJP    SBP1        IF NOT DONE, READ NEXT LOCATION
          LDN    0
          STDL   T3          RESET WORD COUNT
          LDML   FAIL
          ADC    0#100       ADDRESS TO NEXT BP3 MEMORY
          STML   FAIL
          ADC    -0#D00      CHECK IF DONE
          NJP    SBP1        IF NOT DONE, READ NEXT LOC
          LDC    0#C00
          STML   FAIL        ADDRESS NOT FOUND
 SBP2     RJM    CRB         CLEAR RBUF
          LJM    SBPX
          EJECT

          SPACE  4,10

**        CCT - CLEAR CAPTURE BUFFER TRIGGER
*
*         METHOD             CLEAR DEC BIT 18
*
*         USES               RDATA


 CCT      SUBR               ENTRY/EXIT
          READMR RDATA,HBUF+HDRPC,DEMR
          LDML   RDATA+2
          LPC    0#DF        CLEAR DEC BIT 18
          STML   RDATA+2
          WRITMR RDATA,HBUF+HDRPC,DEMR
          UJP    CCTX

          SPACE  4,10
**        CIT - CHECK FOR ISSUE TIMEOUT
*
*         METHOD             READ PFS REGISTER 8B AND MASK BIT 21
*                            TO DETERMINE IF AN ISSUE TIMEOUT IS
*                            PRESENT.
*
*         EXIT               (A) = NONZERO, IF AN ISSUE TIMEOUT IS PRESENT
*                                  ZERO, IF NO ISSUE TIMEOUT IS PRESENT
*
*         USES               *CM*
*
*         CALLS              FMB


 CIT      SUBR               ENTRY/EXIT
          LDC    PFSB
          RJM    FMB
          CRDL   CM          READ PFS 8B FROM SCRATCH BUFFER
          LDDL   CM+1
          LPC    PFIT        MASK ISSUE TIMEOUT BIT
          UJP    CITX
          EJECT
 SOE      SPACE  4,10
**        SOE - SCAN FOR OTHER ERRORS.
*
*         METHOD CHECK IF THE ONLY PFS BITS THAT ARE SET ARE
*                REGISTER 80, BIT 0 AND REGISTER 8B, BIT 21.
*
*         ENTRY  REGISTERS ARE LOGGED IN MRB.
*                REGISTER 8B, BIT 21 IS SET.
*
*         EXIT   (A) = NON-ZERO IF OTHER ERROR CONDITIONS ARE SET.
*
*         USES   T2, W0-W3
*
*         CALLS  FMB.
*
*         MACROS NONE.


 SOE0     LDN    1

 SOE      SUBR               ENTRY/EXIT
          LDC    PPFS
          STDL   T2          (T2) = STARTING REGISTER ADDRESS
 SOE1     LDDL   T2
          RJM    FMB         FORM POINTER TO REGISTER
          CRDL   W0          (W0-W3) = REGISTER CONTENTS
          LDDL   T2
          LMC    PPFS
          NJN    SOE2        IF NOT REGISTER 80
          LDDL   W0
          SHN    2
          PJP    SOE0        IF REGISTER 80 BIT 0 NOT SET
          LDDL   W0
          LPC    0#7FFF
          NJP    SOEX        IF ANY OTHER BITS SET, EXIT
          LDN    0
          UJN    SOE4        CHECK REMAINING BYTES

 SOE2     LDDL   T2
          LMC    PPFS+0#B
          NJN    SOE3        IF NOT REGISTER 8B
          LDDL   W1
          LPC    0#FBFF
          STDL   W1          CLEAR BIT 21
 SOE3     LDN    0
          ADDL   W0
 SOE4     ADDL   W1
          ADDL   W2
          ADDL   W3
          NJP    SOEX        RETURN, IF ANY OTHER ERROR CONDITION
          AODL   T2          INCREMENT REGISTER ADDRESS
          ADC    -PPFS-0#10
          ZJP    SOEX        IF DONE PROCESSING
          UJP    SOE1        CONTINUE PROCESSING
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (CYBER 990 OVERLAY II)
**        ARC -  ANALYSE RETRY CONDITION.
*
*         ENTRY  (SN) = CPUO
*
*         CALLS  PEP
*
*         EXIT   (W7) = 1 IF CATASTROPHIC ERROR OCCURRED


          ROUTINE ARC


          LDML   CPUO
          STDL   SN
          NJP    ARC1        IF CPU1
          LDC    TRCP
          STML   ARCA        MODIFY
          STML   ARCB
          LDC    TRSP
          UJP    ARC2
 ARC1     LDC    TRCP1
          STML   ARCA        MODIFY
          STML   ARCB
          LDC    TRSP1
 ARC2     STML   ARCC        PLUG ADDRESSES
          STML   ARCD
          STML   ARCF

*         CHECK MCR FOR P+ ERROR NOT STACKED

          SETFLG (BC.FV7,BC.FV8,BC.FL)  LOGGING FLAGS
          READMR RDATA,HBUF+CPRPC,PMCR
          RJM    PLB         (A)=MCR
          STDL   T7          T7=MCR
          LPC    0#8000
          NJP    ARC6        IF DUE, NON-RETRYABLE
          LDDL   T7
          LPN    8D
          ZJP    ARC4        IF BIT 60 NOT SET
          READMR RDATA,HBUF+CPRPC,PUPR
          RJM    PAC         MRVAL=UTP
          LDN    3
          STDL   T2
 ARC3     LDML   MRVAL,T2
          NJP    ARC4        IF UTP NON ZERO
          SODL   T2
          NJP    ARC3        IF NOT DONE CHECKING UTP
          UJP    ARC6        UTP=0, P+ ERROR PRESENT

*         CHECK UCR FOR P+ ERROR NOT STACKED

 ARC4     READMR RDATA,HBUF+CPRPC,PUCR
          RJM    PLB         (A)=UCR
          LPC    0#38
          ZJP    ARC5        IF NO UCR P+ ERRORS
          STDL   T7          T7=UCR, P+ ERRORS MASKED
          READMR RDATA,HBUF+CPRPC,PUSM
          RJM    PLB         (A)=USM
          LPDL   T7          MASK WITH UCR P+ ERROR
          ZJP    ARC5        IF NOT(UCR P+ ERROR AND U.M. BIT)
          RJM    RTE         READ TRAPS ENABLED
          NJP    ARC6        IF TRAPS ENABLED, NON-RETRYABLE

*         ANALYSIS = RETRY IN PROGRESS

 ARC5     SETDAN (EPRT,DARP) ANALYSIS CODE = 0205
          SETDAC TRTY        RETRY IN PROGRESS
          UJP    ARC7

*         ANALYSIS = NON-RETRYABLE ERROR

 ARC6     SETDAN (EPUN,DARCU)  ANALYSIS CODE = 321B
          SETDAC TRTY        RETRY IN PROGRESS
          SETOSA OSUPE,OSNA  OS ACTION CODE
 ARC7     AOML   TRHC,SN     INCREMENT HOUR COUNTER
          ADC    -TRHC.TH    HOURLY THRESHHOLD
          MJP    ARC8        IF NOT THRESHHOLD

*         ANALYSIS = HOURLY THRESHHOLD EXCEEDED

          SETDAN (EPCO,DATHT)  ANALYSIS CODE = 221D
          SETOSA OSUPE,OSNA  OS ACTION CODE
          SETDAC TREX        THETA RETRY EXHAUSTED
          LDC    TRHC.TH
          STML   TRHC,SN     RESET HOUR COUNTER
          LDN    0
          STML   TRPC,SN     REINITIALIZE P CTR
          CALL   THO         THETA HALF EXCHANGE OUT
          LDML   C9EF
          NJP    ARCX        IF CATASTROPHIC
          UJP    ARC12

 ARC8     CALL   THO         THETA HALF EXCHANGE OUT
          LDML   C9EF
          NJP    ARCX        IF CATASTROPHIC
          LDD    W6          EXCHANGE PACKAGE
          LRD    W4
          ADC    RR
          CRML   TRCP,ON     SAVE P
 ARCA     EQU    *-1

*         COMPARE CURRENT P AND PREVIOUS P

          LDN    3
          STDL   T2
 ARC9     LDML   TRCP,T2
 ARCB     EQU    *-1         PLUG CORRECT CPU VALUE
          SBML   TRSP,T2
 ARCC     EQU    *-1
          NJP    ARC11       IF P =/= PREVIOUS P
          SODL   T2
          PJP    ARC9        IF MORE TO COMPARE
          AOML   TRPC,SN     INC P COUNTER, SAME P
          SBN    TRPC.TH     P COUNTER THRESHHOLD
          PJP    ARC10       IF THRESHHOLD

*         SET A FLAG (TRMF) TO INDICATE THAT A COMPARE FOR
*         A MULTIPLE OCCURENCE SHOULD NOT LOOK AT THE LAST
*         WORD OF THE MRB.  IT CONTAINS COUNTER INFORMATION
*         WHICH WILL NOT COMPARE, EVEN THOUGH THE ERROR IS
*         THE SAME.

          LDN    1
          STML   TRMF        RETRY MULTIPLE FLAG
          UJP    ARC13

*         ANALYSIS = RETRY EXHAUSTED

 ARC10    SETDAN (EPCO,DATRE)  ANALYSIS CODE = 221C
          SETOSA OSUPE,OSNA  OS ACTION CODE
          SETDAC TREX        THETA RETRY EXHAUSTED
          LDN    0
          STML   TRPC,SN     RESET P COUNTER
          UJP    ARC12

 ARC11    LDN    1
          STML   TRPC,SN     RE-INITIALIZE P COUNTER
          LDDL   BC+BCDA     DFT ANALYSIS
          LPC    0#FF
          SBN    DARP
          NJP    ARC12       IF NOT RETRY IN PROGRESS
          LDDL   BC+BCDA
          LMC    EPCO*0#1000 CHANGE TO ERR PRIORITY - CORR
          STDL   BC+BCDA
 ARC12    LRD    W4
          LDD    W6
          ADC    RR
          CRML   TRSP,ON     SAVE CURRENT P
 ARCD     EQU    *-1
 ARC13    CALL   PEP         PATCH EXCHANGE PACKAGE
          LDN    TRPO        THETA RETRY P OFFSET
          RJM    IMB
          CWML   TRSP,ON     WRITE P TO 6TH BUFFER
 ARCF     EQU    *-1
          LDML   TRHC,SN     STORE RETRY COUNTERS
          STML   ARCG+1
          LDML   TRPC,SN
          STML   ARCG+3
          LDN    TRCO        THETA RETRY COUNTER OFFSET
          RJM    IMB
          CWML   ARCG,ON     WRITE CTRS TO 6TH ENTRY
          RJM    SPP         SCAN PFS PARITY
          LDML   CTIB        CTI BUFFER
          ZJP    ARCX        IF NO SCM PE'S
          CALL   LOG         LOG RETRY ERROR

*         ANALYSIS = REPAIRABLE ERROR

          SETDAN (EPCO,DARES) ANALYSIS CODE = REPAIRABLE ERROR SUCCESSFUL
          LDDL   BC+BCOA
          LPC    0#FF00      CLEAR PREVIOUS OS ACTION CODE
          STDL   BC+BCOA
          CALL   LFA         SWEEP MEMORIES, LOG FAILING ADDR & CONTENTS
          UJP    ARCX        RETURN


 ARCG     BSS    4
          EJECT
**        PLB - PACK LAST BYTE
*
*         METHOD             PACK LAST TWO BYTES OF RDATA INTO THE
*                            R REGISTER.
*
*         EXIT               (A) : LAST TWO BYTES OF RDATA IN PACKED
*                                    FORMAT.


 PLB      SUBR               ENTRY/EXIT
          LDML   RDATA+6
          SHN    8D
          LMML   RDATA+7
          UJN    PLBX
          SPACE  4,10
**        RTE - READ TRAPS ENABLED
*
*         METHOD             READS REGISTER C0, TRAPS ENABLED
*
*         USES               RDATA
*
*         EXIT               (A) : 1 IF TRAPS ARE ENABLED
*                                  0 IF TRAPS ARE DISABLED


 RTE      SUBR               ENTRY/EXIT
          READMR RDATA,HBUF+CPRPC,PTPE
          LDML   RDATA+7
          LPN    2
          UJP    RTEX

*COPY CTP$DFT_990_SCAN_PFS_BITS
          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (CYBER 990 ACTIONS)
 CRR      SPACE  4,10
**        CRR - CLEAR RETRY DECREMENTED (ACTION)
*
*         METHOD             CLEAR, SET DEC BIT 42
*
*         CALLED             BY TASK
*
*         USES               RDATA


           ROUTINE CRR


          READMR RDATA,HBUF+CPRPC,DEMR
          LDML   RDATA+5
          LPC    0#DF        CLEAR DEC BIT 42
          STML   RDATA+5
          WRITMR RDATA,HBUF+CPRPC,DEMR
          LDML   RDATA+5
          LMN    0#20        SET DEC BIT 42
          STML   RDATA+5
          WRITMR RDATA,HBUF+CPRPC,DEMR
          UJP    CRRX

          EJECT
**        SER - SET ERROR FLAG (ACTION)
*
*         METHOD             SET FLAG IN RESIDENT TO INDICATE THAT
*                            A CHANNEL 17 ERROR IS EXPECTED, DUE TO
*                            DFT RECOVERY ON AN UNCORRECTED PROC
*                            ERROR.  PARITY IS NOT RE-GENERATED.
*
*         CALLED             BY TASK
*
*         USES               EIEF
*
*         EXIT               EIEF = 1


           ROUTINE SER
          LDN    1
          STML   EIEF        EXPCTD IOU ERROR FLAG
          UJP    SERX
          EJECT
**        MCP - MASTER CLEAR PROCESSOR (ACTION)
*
*         CALLED             BY TASK


          ROUTINE MCP

          FUNCMR HBUF+CPRPC,MRMC
          UJP    MCPX
          EJECT
**        CCA - CHECK CATASTROPHIC ERROR (ACTION)
*
*         CALLED             BY TASK.
*
*         USES               RBUF, TERT
*
*         CALLS              RMR, CEW, LOG.
*
*         ENTRY              (RBUF) - MCR (UNPACKED).


          ROUTINE CCA
          LDN    SSMR
          STD    RN
          LDN    SSMR
          STD    RN
          LDML   HBUF+CPRPC
          RJM    RMR         READ STATUS SUMMARY
          LPN    4
          ZJP    CCAX        IF NOT UNCORRECTED
          LDN    1
          STM    TERT        SET FLAG - EXIT ACTION LIST
          SETDAN (EPCH,DACRE)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          SETDAC THCE        DISABLE CPU
          LDM    CPUH        GET ORDINAL OF CPU BEING PROCESSED
          NJN    CCA1
          LDM    CP0U        GET UNCORR REGISTER LIST FOR CPU0
          UJN    CCA2
 CCA1     LDM    CP1U        GET UNCORR REGISTER LIST FOR CPU1
 CCA2     RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS

          CALL   SAC
          CALL   CEW
          UJP    CCAX
          EJECT
**        THO - THETA HALF EXCHANGE OUT
*
*         CALLED             BY ATE, ARC
*
*         USES               RDATA,  W4 - W6, RBUF, RN
*
*         CALLS              FEP, SRA, RMR, DMP, EMP, HEO
*
*         EXIT               (C9EF) - NON-ZERO = CATASTROPHIC ERROR ON HEO
*                            (RBUF) = MCR
*                            (W6) = PARTIAL ADDRESS TO EXCHANGE PACKAGE
*                            (W4 - W5) PARTIAL ADDRESS TO EXCHANGE PACKAGE

           ROUTINE THO


          READMR RBUF,HBUF+CPRPC,PMCR  SAVE MCR
          WRITMR THOA,HBUF+CPRPC,PMCR  WRITE ZEROS
          FUNCMR HBUF+CPRPC,MRCE  CLEAR ERRORS
          CALL   DMP         DISABLE MEMORY PORT
          CALL   EMP         ENABLE MEMORY PORT
          CALL   HEO         HALF EXCHANGE OUT
          FUNCMR HBUF+CPRPC,MRMC  MASTER CLEAR PROCESSOR
          LDN    SSMR
          STDL   RN
          LDML   HBUF+CPRPC
          RJM    RMR         READ STATUS,SUMMARY
          LPN    4
          STML   C9EF
          NJP    THOX        IF CATASTROPHIC ERROR ON HEO
          RJM    FEP         FIND XCHG PKGE
          CALL   SRA         CONVERT ADDR TO R FORMAT
          UJP    THOX

 THOA     BSSZ   10

          EJECT
**        FEP - FIND EXCHANGE PACKAGE
*
*         CALLED             BY PEP, LMB
*
*         USES               RDATA,  W4 - W6
*
*         CALLS              PAC
*
*         EXIT               (MRVAL) = ADDR OF XCHG PKG


 FEP      SUBR               ENTRY/EXIT
          READMR RDATA,HBUF+CPRPC,SSMR
          LDML   RDATA+7
          LPN    0#20        CHECK MONITOR MODE
          ZJP    FEP0        IF JOB MODE
          READMR RDATA,HBUF+HDRPC,PMPS  ADDR OF XP AT MPS
          UJP    FEP1

 FEP0     READMR RDATA,HBUF+HDRPC,PJPS  ADDR OF XP AT JPS
 FEP1     RJM    PAC         ADDR IN MRVAL
          UJP    FEPX
          EJECT
**        BMP - BUILD MODEL DEPENDENT BUFFER POINTER.
*
*         ENTRY  N/A
*
*         EXIT   (RS+1) - (RS+2) = PARTIAL ADDRESS TO MODEL DEPENDENT BUFFER.
*                RS = PARTIAL ADDRESS TO MODEL DEPENDENT BUFFER.
*
*         USES   RS.
*
*         CALLS  SPB, VCK.
*
*         MACROS NONE.


          ROUTINE BMP        ENTRY/EXIT

          LRD    DP+1
          RJM    SPB         SET PP BOUNDS
          LDN    MDLP        LOAD PTR TO MODEL DEPENDENT BUFFER
          RJM    IDA
          CRDL   RS          SET UP R-RGTR
          LDN    VER2
          RJM    VCK         VERSION CHECK
          MJP    BMPX        IF VERSION 1

          LDN    VER4
          RJM    VCK         VERSION CHECK
          PJP    BMP1        IF VERSION 4 OR GREATER

          LDML   CPUO
          ZJP    BMPX        IF CPU0
          LDC    MDBL
          RAD    RS
 BMP0     UJP    BMPX        RETURN

 BMP1     LRD    RS+1        DECODE NEXT POINTER
          LDD    RS
          ADML   CPUO
          ADC    RR
          CRDL   RS
          UJN    BMP0

          EJECT
**        LMB - LOAD MODEL DEPENDENT BUFFER (ACTION)
*
*         METHOD             IF RUNNING VERSION 4, CALL THE VERSION 4 PROGRAM.
*                            ELSE, CAPTURE DATA FROM MAINTENANCE REGISTER BUFFER,
*                            HISTORY FILE, EXCHANGE PACKAGE, CURRENT PROGRAM
*                            ADDRESS AND 5 INSTRUCTIONS ON EACH SIDE, AND
*                            THE CAPTURE BUFFER AND WRITE TO THE MODEL
*                            DEPENDENT BUFFER.
*
*         CALLED             BY TASK.
*
*         USES               RS, CM, MRVAL, W2, W4, W5, W6, T3, RN.
*
*         CALLS              AMR, PAC, IMB, SRA, BMP, WMB, FEP, WPC, VCK, EMV.
*
*         MACROS             EXITMR, READMR, FUNCMR, CALL.


           ROUTINE LMB

          LDN    VER4        LOAD VERSION
          RJM    VCK         CHECK VERSION
          MJN    LMB0        IF VERSION 3 OR BELOW
          CALL   EMV         VERSION 4 MAIN PROGRAM
          UJP    LMBX        EXIT

 LMB0     CALL   BMP         BUILD MODEL-DEPENDENT-BUFFER POINTER
          LRD    RS+1
          LDD    RS
          ADC    RR
          CRDL   CM          READ FIRST WORD OF MDB
          LDDL   CM
          SHN    2           MASK INTERLOCK FLAG
          MJP    LMBX        IF INTERLOCK FLAG SET, DON'T LOG MDB

*         READ CSA AFTER MASTER CLEAR

          READMR RDATA,HBUF+HDRPC,PCSA  READ CSA
          RJM    PAC         PACK DATA INTO MRVAL
          LDN    24D
          RAD    RS          START AT MDB WORD 24
          ADC    RR          RELOCATION BIT
          CWML   MRVAL,ON    WRITE TO MDB

*         COPY MRB INTO MODEL DEPENDENT BUFFER

          LDN    0
          STDL   W5
 LMB1     LDDL   W5          LOAD OFFSET
          RJM    IMB         GET R-RGTR
          CRML   MRVAL,ON    READ OUT OF CM
          LDDL   W5
          ADC    -25D
          NJN    LMB2        IF NOT WORD 25
          LDML   CTIB
          STML   MRVAL
          LDML   CTIBR       ALL RELOADED MEMORIES
          STML   MRVAL+1     ALL UNSUCCESSFUL RELOADED MEMORIES
 LMB2     RJM    WMB         WRITE TO MOD DEP BUFFER
          AODL   W5
          ADC    -30D
          NJP    LMB1        IF NOT DONE WITH MRB

*         WRITE HISTORY FILE TO MEMORY

          FUNCMR HBUF+CPRPC,MRMC  MASTER CLEAR THE PROCESSOR
          LDN    0
          STDL   W5

          EXITMR LMB4

 LMB3     RDMEM  RGU.HF,W5,,,8,TC.RGU


          RJM    PAC         PACKED RESULT NOW IN MRVAL
          RJM    WMB         WRITE MODEL DEP BUFFER
          AODL   W5
          ADC    -64D
          NJP    LMB3        IF NOT DONE WITH HISTORY FILE

 LMB4     EXITMR FMR

*         WRITE EXCHANGE PACKAGE TO MEMORY

          LDC    52D         SIZE (WORDS) OF XP
          STDL   T3
          RJM    FEP         FIND XCHG PKG
          CALL   SRA         SET R RGTR
          LDD    W6
          STD    W2          SAVE OFFSET FOR WPC
          LRD    W4
          ADC    RR
          CRML   MRVAL,ON    READ 1ST WORD FROM XP
          UJN    LMB6
 LMB5     AOD    W6          INCREMENT XP CM ADDRESS
          LRD    W4
          ADC    RR
          CRML   MRVAL,ON    READ WORD FROM XP
 LMB6     RJM    WMB         WRITE MODEL DEP BUFFER
          SODL   T3
          NJP    LMB5        IF NOT DONE WITH XP

*         WRITE P AND SURROUNDING INSTR'S

          RJM    WPC         WRITE PROGRAM CONTENTS

*         WRITE CAPTURE BUFFER TO MEMORY

          EXITMR LMB14

          LDK    PMF1        LOAD ADDR OF CAPTURE BUFFER
          STDL   RN
          LDC    MRRD        LOAD FUNCTION
          ADML   HBUF+HDRPC

*         SET CHANNEL INTERLOCK, LOAD FUNCTION, OUTPUT ADDRESS

          RJM    AMR         ACCESS MNTNCE RGTR
          LDN    1
          STML   RMEA
          LDC    512D
          STDL   W5          WORD COUNTER FOR CAPTURE BUFFER
 LMB7     LDN    10
          IAM    RDATA,MR    READ 1 WORD
          ZJN    LMB9        IF NO ERROR
          LDN    0           DEPLETE 512 WORD CTR
          STDL   W5          MCH MUST HAVE DISCONNECTED
 LMB8     LDC    0#FFFF
          STML   MRVAL,W5    STORE ALL 1'S TO DENOTE ERROR
          AODL   W5
          SBN    4
          NJN    LMB8        IF NOT DONE
          LDN    1
          STDL   W5          DEPLETE COUNTER
          UJN    LMB11

 LMB9     LDN    VER2
          RJM    VCK
          PJP    LMB10       IF NOT OS VERSION 1
          LDDL   W5
          ADC    -474D
          PJP    LMB12

 LMB10    RJM    PAC         PACKED DATA NOW IN MRVAL
 LMB11    RJM    WMB         WRITE TO MODEL DEP BUFFERS
 LMB12    SODL   W5          DECREMENT 512 WORD CTR
          ZJN    LMB13       IF DONE
          LJM    LMB7        PROCESS NEXT WORD

 LMB13    RJM    CMI         DEACTIVATE CHANNEL, CLR INTRLK

 LMB14    EXITMR FMR

          LJM    LMBX
          EJECT
**        SDB - SET DEC BIT 18 (ACTION)
*
*         CALLED             BY TASK


          ROUTINE SDB       ENTRY/EXIT
          READMR RDATA,HBUF+HDRPC,DEMR
          LDML   RDATA+2
          LMN    0#20        SET DEC BIT 18
          STML   RDATA+2
          WRITMR RDATA,HBUF+HDRPC,DEMR
          UJP    SDBX
          EJECT
**        RCM - RELOAD CONTROL MEMORIES
*
*         METHOD             READ IN 2AP (CTI) TO RELOAD CONTROL MEMORIES.
*                            CHECK SUCCESS OF RELOAD.  CALL 2AP TO RELOAD
*                            MEMORIES.  AFTER RETURN FROM 2AP, READ CONTENTS
*                            OF PREVIOUSLY FAILING ADDRESSES AND REPORT
*                            DATA IN WORD 27 OF THE RESPECTIVE MRB.   IF
*                            FAILING ADDRESSES WAS NEVER ISOLATED, REPORT
*                            ZEROS.  IF THE RELOAD WAS UNSUCCESSFUL,
*                            CHANGE THE CTI RESULT WORD IN THE MRB AND
*                            THE ANALYSIS CODE IN THE BUFFER CONTROL
*                            WORD TO UNREPAIRABLE ERROR.  IF SUCCESSFUL,
*                            NOTHING NEED BE DONE, BECAUSE DEFAULTS ARE
*                            SET TO REPAIRABLE ERROR.
*
*         CALLED             BY TASK
*
*         ENTRY              CTIB  SET BIT DESIGNATES MEMORY TO RELOAD. CACHE
*                            IS ALWAYS RELOADED.
*
*         CALLS              MMA
*
*         MACROS EXITMR.


          ROUTINE RCM       ENTRY/EXIT
*         SET UP CALL BLOCK FOR CTI

          LDN    25B
          STML   CALB        CTI FUNCTION
          LDML   CPUO
          STML   CALB+1      CPU ORDINAL
          LDML   CTIB
          STML   CALB+2      BITS SPECIFYING MEMORIES

*         READ IN 2AP AND EXECUTE

          RJM    ECM         EXECUTE CIP MODULE
          RJM    RPW         RESTORE POINTER WORD
          LDML   CALB+2
          STML   CTIBR       SAVED RETURNED RESULTS

          LDML   CTIB
          ZJP    RCMX        IF NO SCM RELOADS WERE DONE

*         ADD LAST LOGGED TO MRBA TABLE

          AOML   MRBA        INCREMENT ENTRY CTR
          STDL   T1
          LDN    0           SCRATCH BUFFER
          STML   MRBA,T1     ADD OFFSET OF LAST LOGGED
          LDN    1
          STDL   T7          OFFSET TO MRBA TABLE
          LDML   MRBA
          STML   RCMB        SAVE CRITICAL MRBA

*         READ CONTENTS OF FAILING ADDRESS

 RCM0     LDML   MRBA,T7
          STDL   W4          SAVE OFFSET
          RJM    IBW
          CRDL   CM          READ BUFFER CONTROL WORD
          LDDL   CM+3        OFFSET TO MRB
          ADN    25D
          STDL   W5          SAVE OFFSET
          RJM    IMB
          CRML   RCMA,ON     READ WORD 25
          LDML   RCMA+3
          STDL   RN          FAILING ADDR
          ADC    -0#FFFF
          ZJP    RCM1        IF FAILING ADDR NEVER ISOLATED

          EXITMR RCM0.05

          LDM    HBUF+HDRPC  FORM FUNCTION WORD
          ADC    MRRD
          ADML   RCMA+2      ADD TYPE CODE
          RJM    AMR         ACCESS MNTCE CHANNEL
          LDN    8D          BYTE COUNT
          IAM    RDATA,MR    READ FAILING ADDR
          RJM    PAC         PACK DATA INTO MRVAL
          RJM    CMI         CLEAR MNTCE INTERLOCK

 RCM0.05  EXITMR FMR

          LDN    2
          ADDL   W5          FORM OFFSET OF WORD 27
          RJM    IMB
          CWML   MRVAL,ON    WRITE NEW CONTENTS TO CM
          LDN    27D
          RJM    IMB
          CWML   MRVAL,ON    WRITE TO SCRATCH BUF

*         CHECK SUCCESS OF RELOADS

 RCM1     LDML   RCMA
          LPML   CTIBR
          ZJP    RCM2        IF RELOAD SUCCESSFUL

          STML   RCMA+1
          LDDL   W5          RELOAD OFFSET
          RJM    IMB
          CWML   RCMA,ON     WRITE WORD BACK TO CM

*         CHANGE ANAYSIS CODE IN CONTROL WORD

          LDDL   CM
          LPC    0#FF00      CLEAR PREVIOUS OS ACTION CODE
          STDL   CM
          LDDL   CM+1
          LPC    0#F00
          STDL   CM+1
          LDC    EPUN*10000+DAREU
          LMDL   CM+1
          STDL   CM+1
          LDDL   W4          RELOAD OFFSET
          ZJP    RCM4        IF CHANGE TO BC
          RJM    IBW
          CWDL   CM          WRITE MODIFIED CONTROL WORD TO CM

 RCM2     SOML   MRBA        DECREMENT ENTRY CTR
          ZJP    RCM3

          AODL   T7
          LJM    RCM0

 RCM3     LDML   RCMB
          STML   MRBA        RESTORE MRBA
          LJM    RCMX

*         CHANGE ANAYSIS CODE IN CONTROL WORD BC

 RCM4     LDDL   BC
          LPC    0#FF00      CLEAR PREVIOUS OS ACTION CODE
          STDL   BC
          LDDL   BC+1
          LPC    0#F00
          STDL   BC+1
          LDC    EPUN*10000+DAREU
          LMDL   BC+1
          STDL   BC+1
          UJP    RCM2


*         TEMP LOCATIONS

 RCMA     CON    0,0,0,0
 RCMB     CON 0



          EJECT
**        MSA - MAKE SYSTEM VIRTUAL ADDRESS.
*
*         ENTRY  (W4 - W5) = PARTIAL ADDRESS TO EXCHANGE PACKAGE.
*                (W6) =  R-RGTR OFFSET TO EXCHANGE PACKAGE.
*
*         EXIT   (CM - CM+2) = SYSTEM VIRTUAL ADDRESS.
*                (W0 - W3) = SEGMENT TABLE ENTRY.
*
*         USES   W0-W6, T1-T4, CM.
*
*         CALLS  LWA.
*
*         MACROS NONE.


 MSA1     LDN    0           FLAG INVALID/MISSING SEGMENT

 MSA      SUBR               ENTRY/EXIT
          LRD    W4
          LDD    W6
          ADC    RR
          CRML   MSAA,ON     (MSAA) = P FROM EXCHANGE PACKAGE
          LDML   MSAA+1
          LPC    0#FFF       ZERO OUT RING NUMBER
          STML   MSAA+1
          LDML   MSAA+3
          LPN    BOB         BYTE OFFSET BITS
          STML   MSAB        (MSAB) = BYTE OFFSET
          LDML   MSAA+3
          SCN    BOB
          STML   MSAA+3      CHANGE TO WORD BOUNDARY
          LDD    W6          LOAD BYTE ADDRESS
          ADN    16D         SEGMENT TABLE LENGTH OFFSET
          ADC    RR
          CRDL   T1          GET SEGMENT TABLE LENGTH
          ADN    18D         SEGMENT TABLE ADDRESS OFFSET
          CRDL   T2          GET SEGMENT TABLE ADDRESS
          ADN    1
          CRDL   T3
          LDDL   T1
          SBML   MSAA+1
          MJP    MSA1        IF NOT A VALID SEGMENT
          LDDL   T3          FORM WORD ADDRESS FOR LWA
          SHN    -3
          STDL   T3
          LDD    T2
          LPN    7
          SHN    13D
          RADL   T3
          LDDL   T2
          SHN    -3
          STDL   T2
          LDN    T2
          RJM    LWA         LOAD ADDRESS OF SEGMENT TABLE
          ADML   MSAA+1      ADD SEGMENT OF INTEREST
          CRDL   W0          FETCH ASID
          LDDL   W0
          LPC    0#8000
          ZJP    MSA1        IF INVALID
          LDDL   W1
          ZJP    MSA1        IF NOT A VALID ASID
          STDL   CM          SAVE ASID
          LDML   MSAA+2      COPY REMAINDER OF PVA
          STDL   CM+1
          LDML   MSAA+3
          STDL   CM+2
          LDN    1
          UJP    MSAX        RETURN

 MSAA     BSSZ   4
 MSAB     CON    0

*COPY CTP$DFT_PVA_TO_RMA_ROUTINES
          EJECT
**        WPC - WRITE PROGRAM CONTENTS
*
*         METHOD             TRANSLATE P FROM A PVA TO AN RMA.
*                            WRITE RESPECTIVE PTE TO MDB.  ADD
*                            AND SUBTRACT 5 WORDS ON EACH SIDE OF
*                            P.  IF A PAGE BOUNDARY IS CROSSED, THE
*                            APPROPRIATE ROUTINE IS CALLED.  OTHERWISE,
*                            LOG THE 5 INSTRUCTIONS ON EACH SIDE OF
*                            P (INCLUDING P) TO THE MDB.
*
*         CALLED             BY LMB
*
*         ENTRY              (W2)   - R RGTR OFFSET TO XCHG PKG
*                            (W4-W5) -R RGTR ADDRESS TO XCHG PKG
*
*         USES               LMBA, T1-T4, PSMV, W0-W3, W6, MRVAL
*
*         CALLS              PVC, MSA, SPT, GPP, GNP, RWP, WRZ

+
 WPC      SUBR               ENTRY/EXIT
          RJM    PVC         PRESET VIRTUAL CONSTANTS
          LDDL   W2
          STDL   W6          RESTORE R-RGTR TO XCHG PKG
          RJM    MSA         MAKE SYSTEM VIRTUAL ADDRESS
          ZJP    WPC3        IF NOT VALID
          AOML   LTOL        INCREMENT LENGTH TO LOG COUNTER
          AOD    RS
          LRD    RS+1
          ADC    RR
          CWDL   W0          WRITE SEG TABLE ENTRY
          RJM    SPT         SEARCH PAGE TABLE
          ZJP    WPC2        IF PAGE MISS

*         SAVE RMA

          STDL   T3
          SRD    T1
          LDDL   T1
          STML   WPCA        SAVE UPPER 10 BITS
          LDDL   T2
          STML   WPCA+1      SAVE MID 12 BITS

*         WRITE PTE TO MDB

          AOML   LTOL        INCREMENT LENGTH TO LOG COUNT
          AOD    RS          INCREMENT MDB ADDRESS
          LRD    RS+1
          ADC    RR
          CWML   SPTJ,ON     WRITE PTE TO MDB

*         CHECK PAGE BOUNDARIES.

          LDML   PSMV
          LMC    0#7F
          SHN    9D
          LMC    0#FFFF
          LPML   MSAA+3
          SHN    -3
          STML   WPCB        PAGE OFFSET (IN WORDS)
          SBN    5
          MJN    WPC0        IF CROSSING TOP PAGE BDRY
          ADN    11D
          STDL   T4          PG OFFSET + 6 WORDS
          LDML   PSMV
          LMC    0#7F
          SHN    6
          LPML   T4          MASK FOR OVERFLOW
          NJN    WPC1        IF CROSSING BOTTOM PAGE BDRY

*         WRITE 11 WORDS FROM 1 PAGE TO MDB

          LDN    1
          RJM    WRZ         WRITE ZEROS TO 2ND PTE
          LDN    11D         # WORDS TO READ, WRITE
          STDL   W4
          LDDL   T3
          SBN    5
          RJM    RWP         WRITE PROGRAM CONTENTS TO MDB
          LJM    WPCX

 WPC0     RJM    GPP         GET PREV PAGE
          LJM    WPCX

 WPC1     LDDL   T4          PO + 6
          LPN    0#3F
          STDL   T4          # WORDS TO READ FROM NEXT PAGE
          RJM    GNP         GET NEXT PAGE
          LJM    WPCX

 WPC2     LDN    12D
          STDL   T2
          UJP    WPC4

 WPC3     LDN    13D
          STDL   T2
 WPC4     LDC    0#FFFF
          STML   MRVAL
          STML   MRVAL+1
          STML   MRVAL+2
          STML   MRVAL+3
          RJM    WMB         WRITE ALL F'S TO MDB
          LDDL   T2

          RJM    WRZ         WRITE ALL ZEROS
          LJM    WPCX

 WPCA     CON    0,0,0       STORES RMA FOR P
 WPCB     CON    0           PAGE OFFSET FOR P
          EJECT
**        APC - ANALYZE P CONDITION.
*
*         ENTRY  (W4-W5) = PARTIAL ADDRESS TO EXCHANGE PACKAGE.
*                (W6) = OFFSET TO EXCHANGE PACKAGE.
*
*         EXIT   (W4-W5) = PARTIAL ADDRESS TO EXCHANGE PACKAGE.
*                (W6) = OFFSET TO EXCHANGE PACKAGE.
*                TF = 1 IF VECTOR GATHER/SCATTER OPCODE WAS NOT FOUND.
*
*         USES   MSAB, T4, W4-46.
*
*         CALLS  PVC, MSA, SPT, FEP, SRA, BMP.


          ROUTINE APC

          LDN    0
          STDL   TF          CLEAR TEMPORARY FLAG
          RJM    PVC         PRESET VIRTUAL CONSTANTS
          RJM    MSA         MAKE SYSTEM VIRTUAL ADDRESS
          ZJN    APC1        IF NOT VALID
          RJM    SPT         SEARCH PAGE TABLE
          ZJN    APC1        IF NOT VALID
          CRML   APCA,ON     (APCA) = WORD POINTED TO BY P
          LDML   MSAB        BYTE OFFSET
          SHN    -1
          STDL   T4          (T4) = RMA BYTE OFFSET
          LDML   APCA,T4     CURRENT OPCODE
          SHN    -10
          ADC    -VGAT
          ZJN    APC2        IF OPCODE FOUND
          LDML   APCA,T4
          SHN    -10
          ADC    -VSCA
          ZJN    APC2        IF OPCODE FOUND
 APC1     BSS    0
          CALL   BMP         BUILD MODEL-DEPENDENT-BUFFER POINTER
          RJM    GML         GET MDB LENGTH  (GMLA)
          LDD    RS
          ADML   GMLA        MDB LENGTH - 1
          ADC    RR
          CRML   APCB,ON     READ WORD WITH FALSE ERROR COUNTERS
          AOML   APCB+2      INCREMENT NOT VERIFIED COUNTER
          LDN    1
          STDL   TF          SET TEMPORARY FLAG
          UJN    APC3        WRITE WORD BACK TO MEMORY

 APC2     BSS    0
          CALL   BMP         BUILD MODEL-DEPENDENT-BUFFER POINTER
          RJM    GML         GET MDB LENGTH  (GMLA)
          LDD    RS
          ADML   GMLA        MDB LENGTH - 1
          ADC    RR
          CRML   APCB,ON     READ WORD WITH FALSE ERROR COUNTERS
          AOML   APCB+3      INCREMENT VERIFIED COUNTER
 APC3     LDD    RS
          ADML   GMLA        MDB LENGTH - 1
          ADC    RR
          CWML   APCB,ON     WRITE WORD BACK TO MEMORY
          RJM    FEP         FIND EXCHANGE PACKAGE
          CALL   SRA         SET R-REGISTER
          UJP    APCX        RETURN
 APCA     BSSZ   4
 APCB     BSSZ   4
          EJECT
**        GML - GET MODEL-DEPENDENT-BUFFER LENGTH.
*
*         ENTRY  RS+3 = ENTIRE MODEL DEPENDENT BUFFER LENGTH.
*
*         EXIT   GMLA = LENGTH OF ONE CPU'S MODEL DEPENDENT BUFFER.
*
*         CALLS  SPB.


 GML      SUBR
          LRD    RS+1
          RJM    SPB         SET PP BOUNDS
          LDN    VER4
          RJM    VCK         VERSION CHECK
          PJP    GML0        IF VERSION 4 OR GREATER
          LDML   CPU1M
          ZJP    GML0        IF SINGLE CPU
          LDDL   RS+3
          SHN    -1
          SBN    1
          STML   GMLA        SAVE DUAL LENGTH/2
          UJN    GMLX        RETURN

 GML0     LDDL   RS+3
          SBN    1
          STML   GMLA
          UJN    GMLX

 GMLA     CON    0
 SAVE     BSSZ   10
*COPY     CTP$DFT_RESTORE_POINTER_WORD
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW

          OVERLAY  (CYBER 990 ACTIONS II)
 PEP      SPACE  4,10
**        PEP - PATCH EXCHANGE PACKAGE.
*
*         ENTRY              (RBUF) - MCR (UNPACKED).
*                            (W4-W5) = R REGISTER - EXCHANGE PACKAGE.
*                            (W6) = R REGISTER OFFSET - EXCHANGE PACKAGE.
*                            TF = 1 IF NO VECTOR GATHER/SCATTER OPCODE FOUND IN APC.
*                            FE = 1 IF ANALYSIS IS A FALSE ERROR CONDITION
*
*         USES               W0, RDATA,  W4 - W6, RBUF, CM.
*
*         CALLS              SPB, RMR.


           ROUTINE PEP

          LDML   RBUF+6
          SHN    10
          LMML   RBUF+7
          STML   PEPC        SAVE PACKED MCR
          LRD    W4          LOAD R REGISTER - ADDR EXG PKG
          RJM    SPB         SET PP BOUNDS
          LDN    MBRG
          STDL   RN
          LDML   CMCC
          RJM    RMR         READ MEMORY BOUNDS REGISTER
          LDML   RDATA
          STML   PEPA        (PEPA) = MEMORY BOUNDS, BYTE 0
          LPC    0#BF        DISABLE MEM BOUNDS
          STML   RDATA
          WRITMR RDATA,CMCC,MBRG

*         READ MCR FROM EXCHANGE PACKAGE

          LDD    W6
          ADN    6
          ADC    RR
          CRDL   CM          READ WORD WITH MCR

          LDDL   BC+BCDA
          LPC    0#FF
          STDL   W0          (W0)=CURRENT ANALYSIS CODE
          SBN    DARP
          ZJP    PEP1        IF ANALYSIS = RETRY IN PROGRESS

          LDDL   FE          FALSE ERROR FLAG
          ZJP    PEP0        IF NOT(ANALYSIS = FALSE ERROR)
          LDML   PEPC
          LPC    NDUE
          STML   PEPC        CLEAR DUE IN SAVED MCR
          LDDL   TF
          NJP    PEP2        IF OPCODE WAS NOT FOUND
          LDML   PEPC
          LPC    ISE+ASE+ACV+ESE+PWF+SYC+ISR+OUC+TRE
          NJP    PEP2        IF MCR CONDITION OTHER THAN ASYNC OR DUE

*         INCREMENT PROGRAM ADDRESS IN EXCHANGE PACKAGE

          LDD    W6
          ADC    RR
          CRML   PEPB,ON     (PEPB) = EXCHANGE PACKAGE PROGRAM ADDRESS
          LDN    4
          RAML   PEPB+3
          SHN    -20         SAVE POSSIBLE CARRY BIT
          RAML   PEPB+2
          LDD    W6
          ADC    RR
          CWML   PEPB,ON     WRITE MODIFIED P EXCHANGE PACKAGE
          UJP    PEP2

 PEP0     LDML   PEPC
          LPC    DUE
          NJP    PEP1        IF DUE SET
          LDML   HALT
          ZJP    PEP1        IF NOT(HALT ON ERROR)
          LDML   PEPC
          LMC    DUE
          STML   PEPC        FORCE DUE
          LDDL   W0
          SBN    DAUPE
          NJN    PEP1        IF NOT(ANALYSIS = UNCORRECTED ERROR)

*         ANALYSIS = THETA FORCED UNCORRECTED ERROR

          SETDAN (EPUN,DATFU)
          SETOSA OSUPE,OSNA

 PEP1     LDML   PEPC
          LPC    NSEL
          STML   PEPC        CLEAR SOFT ERROR

*         WRITE MODIFIED MCR TO EXCHANGE PACKAGE, MCR

 PEP2     LDML   PEPC
          STDL   CM          RESTORE MCR
          LDD    W6
          ADN    6
          ADC    RR
          CWDL   CM          WRITE MCR WORD TO XP
          LDML   PEPC
          SHN    -10         POSITION
          STML   RBUF+6      RESTORE MCR
          LDML   PEPC
          LPC    0#FF
          STML   RBUF+7      RESTORE MCR
          WRITMR RBUF,HBUF+CPRPC,PMCR  RESTORE MCR
          LDML   PEPA
          STML   RDATA
          WRITMR RDATA,CMCC,MBRG
          LDN    D8ST
          RJM    IIB
          CRDL   CM          GET FLAG FOR OS TRACKING OF TRAP ENABLES
          LDDL   CM
          SHN    21-11       GET TO BIT 57
          PJN    PEP3        IF NOT SET
          LDML   OLSS
          SHN    21-SSMM
          PJN    PEP3        IF IN JOB MODE
          LDD    W6
          ADC    2+RR
          CRDL   CM          GET TRAP ENABLES WORD
          LDDL   CM
          LPC    0#FD        CLEAR TE
          ADN    2           SET TE
          LDD    W6
          ADC    2+RR
          CWDL   CM          REWRITE TRAP ENABLES WORD
 PEP3     LRD    DP+1
          RJM    SPB         RE-STORE PP BOUNDS
          UJP    PEPX

 PEPA     CON    0
 PEPB     BSSZ   4
 PEPC     CON    0

**        IBP - INITIALIZE BDP.
*
*         ENTRY              (CSAR) = CPU *CSA* REGISTER #.
*                            (HBUF) = PROCESSOR MRT ENTRY.
*
*         EXIT               PROCESSOR HAS BEEN MASTER CLEARED.
*                            BDP HAS BEEN INITIALIZED.
*
*         MACROS             FUNCMR, WRITMR.


           ROUTINE IBP       ENTRY/EXIT

          LDC    CSBDPI      CS BDP INIT ADDR
          STM    IBPA+7
          SHN    -10
          STM    IBPA+6      STORE UNPACKED BDP INIT ADDR
          FUNCMR HBUF+CPRPC,MRMC  MASTER CLEAR THE CPU
          LDM    CSAR
          STD    RN
          WRITMR IBPA,HBUF+CPRPC
          FUNCMR HBUF+CPRPC,MRSP  START PROCESSOR AT BDP INIT
          LDN    0#20        DELAY TO ALLOW SEQUENCE TO COMPLETE
 IBP1     SBN    1
          NJN    IBP1        IF TIMER NOT EXPIRED
          FUNCMR HBUF+CPRPC,MRMC  MASTER CLEAR THE CPU
          LJM    IBPX        RETURN

 IBPA     BSSZ   10B

          OVERFLOW R2ORG     CHECK FOR OVERFLOW

          OVERLAY  (SAVE CONTROL STORE)
 SAC      SPACE  4,10
**        SAC - SAVE CONTROL STORE.

          ROUTINE SAC        ENTRY/EXIT

          LDN    1
          RJM    SCS
          UJP    SACX        EXIT

*COPY     CTP$DFT_SAVE_CONTROL_STORE

          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW


          OVERLAY  (VERSION 4 DFT MDB LOGGING PART I)
 EMV      SPACE  4,10
**        EMV - EXECUTE MAIN PROGRAM FOR VERSION 4 MDB LOGGING.
*
*         METHOD             UPON CPU ERROR, LOG NECESSARY ERROR INFORMATION
*                            IN THE MODEL DEPENDENT BUFFER, OR THE OVERFLOW
*                            BUFFER.  IF THIS INFORMATION IS OVERWRITTEN OR
*                            CANNOT BE LOGGED SET THE NECESSARY FLAGS TO
*                            SIGNAL THE OS THAT THIS SITUATION IS PRESENT.
*
*         ENTRY              IF VERSION 4 MDB LOGGING.
*
*         USES               BCWF, CEPR, CEWF, E6AD - E6AD+2,
*                            HDAD -HDAD+2, LTOL, MRBA, MRVAL+3,
*                            RS - RS+2, SHWD.
*
*                            BCWF = 0 IF LOGGABLE DATA.
*                                 = 1 IF OVERWRITE DATA.
*                                 = 2 IF UNLOGGABLE DATA.
*
*         CALLS              DEP, DLC, ITUF, PAC, SPB, WCB, WEP, WEW,
*                            WHF, WLR, WMR, WPC, WSH.
*
*         EXIT               ALL MODEL DEPENDENT ERROR INFORMATION LOGGED,
*                            OR THE OS IS FLAGGED THAT THE INFORMATION IS
*                            UNLOGGABLE.
*

          ROUTINE EMV        ENTRY/EXIT

          LRD    DP+1        SET R REGISTER
          RJM    SPB         SET PP BOUNDS
          RJM    DEP         DETERMINE ERROR PRIORITY

*         IF ISSUE TIME OUT AND CALL FROM CEW SUB HEADER ID = 6.

          LDML   CEWF        CALLED FROM CEW FLAG
          NJN    EMV0        IF CALLED FROM CEW (IF V4 AND ISSUE TIME OUT)

          LDML   CEPR        ERROR PRIORITY
          SBN    3
          MJN    EMV0        IF NOT ISSUE TIME OUT

*         ISSUE TIME OUT ERROR ID = 3,4,5.

          LDML   ITUF        UNLOGGABLE ISSUE TIME OUT FLAG
          SBN    2
          ZJP    EMVX        IF UNLOGGABLE, EXIT

          LDM    E6AD        LOAD ADJUSTED LOWER MDB ADDRESS FROM ERROR ID 6
          STD    RS
          LDM    E6AD+1      LOAD ADJUSTED UPPER MDB ADDRESS FROM ERROR ID 6
          STD    RS+1
          LDM    E6AD+2      LOAD ADJUSTED UPPER MDB ADDRESS FROM ERROR ID 6
          STD    RS+2
          LJM    EMV7        ISSUE TIME OUT, ERROR ID 3, 4, 5

 EMV0     CALL   DLC         DETERMINE LOGGING CONDITIONS

          LDML   BCWF        BUFFER CONTROL WORD WRITE FLAG
          SBN    2           UNLOGGABLE ERROR
          MJN    EMV1        IF LOGGABLE ERROR
          UJP    EMVX        UNLOGGABLE ERROR, EXIT

*         READ CSA ADDRESS.

 EMV1     READMR RDATA,HBUF+HDRPC,PCSA  READ CSA
          RJM    PAC         PAC CSA IN MRVAL

          LDML   CEPR        ERROR PRIORITY
          SBN    2
          ZJN    EMV3        IF ERROR PRIORITY 2  (OTHER)
          MJN    EMV2        IF ERROR PRIORITY 1  (RETRY)
          LJM    EMV8        ERROR PRIORITY 3  (ISSUE TIMEOUT)
 EMV2     LJM    EMV9        ERROR PRIORITY 1  (RETRY)

 EMV3     LDML   CSAA        CSA ADDRESS SAVED IN ATE
          ADC    -CSRA       ADDRESS 44/45
          ZJN    EMV4        IF ERROR PRIORITY 2 AND RETRY

          LDML   MRBA        SCM PE ENTRY COUNTER
          NJN    EMV5        IF ERROR PRIORITY 2 AND SCM PE
          UJN    EMV6        IF ERROR PRIORITY 2 ONLY

 EMV4     LJM    EMV9        ERROR PRIORITY 2 AND RETRY
 EMV5     LJM    EMV10       ERROR PRIORITY 2 AND SCM PE

*         WRITE MODEL DEPENDENT BUFFER DATA.
*
*         ERROR PRIORITY = 1 (RETRY).             ERROR ID = 7, 2, 3, 4, 5.
*
*         ERROR PRIORITY = 2 (OTHER) AND RETRY.   ERROR ID = 7, 2, 3, 4, 5.
*
*         ERROR PRIORITY = 2 (OTHER), RETRY AND SCM PE.  ERROR ID = 7, 1, 2,
*                                                                   3, 4, 5.
*
*         ERROR PRIORITY = 2 (OTHER) AND SCM PE.  ERROR ID = 1, 2, 3, 4, 5.
*
*         ERROR PRIORITY = 2 (OTHER).             ERROR ID = 2, 3, 4, 5.
*
*         ERROR PRIORITY = 3 (ISSUE TIME OUT).    ERROR ID = 6, 3, 4, 5.
*
*         WRITE CAPTURE BUFFER.        (ERROR ID = 2)  LGTH = 200 HEX
*         WRITE HISTORY FILE.          (ERROR ID = 3)  LGTH = 40  HEX
*         WRITE EXCHANGE PACKAGE.      (ERROR ID = 4)  LGTH = 34  HEX
*         WRITE P AND SURROUNDING INSTRUCTIONS. (ERROR ID = 5) LGTH = E  HEX
*         WRITE EXECUTING WORDS OF SCM TO MDB.  (ERROR ID = 6) LGTH = 17 HEX
*         WRITE LAST TWO WORDS OF MRB6.         (ERROR ID = 7) LGTH = 2  HEX
*         WRITE MRB6.                           (ERROR ID = 1) LGTH = 3  HEX
          EJECT

*         WRITE CAPTURE BUFFER TO MDB.

*         CLEAR THE SUB HEADER WORD BUFFER FOR SUB HEADER BUILD.

 EMV6     LDC    SHWD        LOAD ADDRESS OF SUB HEADER WORD DATA BLOCK
          RJM    CLR         CLEAR BLOCK

*         SET UP SUB HEADER.

          LDN    SH.CB       SUB HEADER ID
          STML   SHWD+V4SHHID  STORE TO BUFFER
          LDC    LOD.CB      LENGTH OF DATA TO WRITE
          ADN    1           ADD 1 FOR SUB HEADER WORD
          STML   SHWD+V4SHLOD  STORE TO BUFFER
          CALL   WSH         WRITE SUB HEADER WORD

          RJM    WCB         WRITE CAPTURE BUFFER TO MDB, (ERROR ID = 2)


*         WRITE HISTORY FILE TO MDB.

*         CLEAR THE SUB HEADER WORD BUFFER FOR SUB HEADER BUILD.

 EMV7     LDC    SHWD        LOAD ADDRESS OF SUB HEADER WORD DATA BLOCK
          RJM    CLR         CLEAR BLOCK

*         SET UP SUB HEADER.

          LDN    SH.HF       SUB HEADER ID
          STML   SHWD+V4SHHID  STORE TO BUFFER
          LDC    LOD.HF      LENGTH OF DATA TO WRITE
          ADN    1           ADD 1 FOR SUB HEADER WORD
          STML   SHWD+V4SHLOD  STORE TO BUFFER
          CALL   WSH         WRITE SUB HEADER WORD
          RJM    WHF         WRITE HISTORY FILE, (ERROR ID = 3)

*         WRITE EXCHANGE PACKAGE TO MDB.

*         CLEAR THE SUB HEADER WORD BUFFER FOR SUB HEADER BUILD.


          LDC    SHWD        LOAD ADDRESS OF SUB HEADER WORD DATA BLOCK
          RJM    CLR         CLEAR BLOCK

*         SET UP SUB HEADER.

          LDN    SH.EP       SUB HEADER ID
          STML   SHWD+V4SHHID  STORE TO BUFFER
          LDC    LOD.EP      LENGTH OF DATA TO WRITE
          ADN    1           ADD 1 FOR SUB HEADER WORD
          STML   SHWD+V4SHLOD  STORE TO BUFFER
          CALL   WSH         WRITE SUB HEADER WORD

          RJM    WEP         WRITE EXCHANGE PACKAGE, (ERROR ID = 4)


*         WRITE P AND SURROUNDING INSTRUCTIONS.

*         CLEAR THE SUB HEADER WORD BUFFER FOR SUB HEADER BUILD.

          LDC    SHWD        LOAD ADDRESS OF SUB HEADER WORD DATA BLOCK
          RJM    CLR         CLEAR BLOCK

*         SET UP SUB HEADER.

          LDN    SH.PI       SUB HEADER ID
          STML   SHWD+V4SHHID  STORE TO BUFFER
          LDC    LOD.PI      LENGTH OF DATA TO WRITE
          ADN    1           ADD 1 FOR SUB HEADER WORD
          STML   SHWD+V4SHLOD  STORE TO BUFFER
          CALL   WSH         WRITE SUB HEADER WORD

          RJM    WPC         WRITE P AND SURROUNDING INSTRUCTIONS, (ERROR ID = 5)
          LDC    SHWD        LOAD SUB HEADER WORD BUFFER ADDRESS
          RJM    CLR         CLEAR BLOCK

          CALL   WSH         INSERT LENGTH TO LOG IN MAIN HEADER
          UJP    EMVX        EXIT


*         WRITE EXECUTING WORDS OF SCM TO MDB.

*         CLEAR THE SUB HEADER WORD BUFFER FOR SUB HEADER BUILD.

 EMV8     LDC    SHWD        LOAD ADDRESS OF SUB HEADER WORD DATA BLOCK
          RJM    CLR         CLEAR BLOCK

*         SET UP SUB HEADER.

          LDN    SH.EW       SUB HEADER ID
          STML   SHWD+V4SHHID  STORE TO BUFFER
          LDC    LOD.EW      LENGTH OF DATA TO WRITE
          ADN    1           ADD 1 FOR SUB HEADER WORD
          STML   SHWD+V4SHLOD  STORE TO BUFFER
          LDC    PFID.EW     PFS ERROR ID
          STML   SHWD+V4SHPFS  STORE TO BUFFER
          CALL   WSH         WRITE SUB HEADER WORD

*         READ, WRITE EXECUTING WORDS OF SCM'S.  (ERROR ID = 6)

          CALL   RWE
          LDD    RS          ADJUSTED LOWER MDB ADDRESS
          STM    E6AD        SAVE
          LDD    RS+1        ADJUSTED UPPER MDB ADDRESS
          STM    E6AD+1      SAVE
          LDD    RS+2        ADJUSTED UPPER MDB ADDRESS
          STM    E6AD+2      SAVE
          UJP    EMVX        EXIT

*         WRITE LAST TWO WORDS OF MRB6 TO MDB.

*         CLEAR THE SUB HEADER WORD BUFFER FOR SUB HEADER BUILD.

 EMV9     LDC    SHWD        LOAD ADDRESS OF SUB HEADER WORD DATA BLOCK
          RJM    CLR         CLEAR BLOCK

*         SET UP SUB HEADER.

          LDN    SH.MR2      SUB HEADER ID
          STML   SHWD+V4SHHID  STORE TO BUFFER
          LDC    LOD.MR2     LENGTH OF DATA TO WRITE
          ADN    1           ADD 1 FOR SUB HEADER WORD
          STML   SHWD+V4SHLOD  STORE TO BUFFER
          CALL   WSH         WRITE SUB HEADER WORD

          CALL   WLR         WRITE LAST TWO WORDS OF MRB6, (ERROR ID = 7)
          LDML   CEPR        ERROR PRIORITY
          SBN    2
          MJN    EMV11       IF ERROR PRIORITY 1 (RETRY)
          LDML   MRBA        SCM PE ENTRY COUNTER
          ZJN    EMV11       IF ERROR PRIORITY 2, RETRY AND SCM PE

*         IF ERROR PRIORITY 2 AND RETRY AND SCM PE.

*         WRITE FIRST 3 WORDS OF MRB6 TO MDB.

 EMV10    CALL   WMR         WRITE MRB6, (ERROR ID = 1)

 EMV11    LJM    EMV6        ERROR ID 2, 3, 4, 5

          EJECT
**        DEP - DETERMINE ERROR PRIORITY.
*
*         METHOD             TEST DFT ERROR ANALYSIS CODE FOR RETRY AND
*                            ASSIGN ERROR PRIORITY 1. IF NOT, TEST PFS 8B FOR
*                            ISSUE TIMEOUT BIT AND ASSIGN ERROR PRIORITY 3.
*                            OTHERWISE ASSIGN ERROR PRIORITY 2.
*
*         ENTRY              NA.
*
*         USES               BC, BCDA, CEPR, CM - CM+1, DARP.
*
*         CALLS              FMB.
*
*         EXIT               ERROR PRIORITY CODE SAVED IN CEPR.

 DEP      SUBR               ENTRY/EXIT

          LDDL   BC+BCDA     DFT ANALYSIS CODE
          LPC    0#FF        JUST CODE
          SBN    DARP        RETRY IN PROGRESS
          NJN    DEP1        IF NO RETRY IN PROGRESS

*         IF RETRY IN PROGRESS.

          LDN    V4EPRT      ERROR PRIORITY 1  (RETRY IN PROGRESS)
 DEP0     STML   CEPR        SAVE
          UJP    DEPX        EXIT

 DEP1     LDC    PFSB        LOAD PFS8B ADDRESS
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRDL   CM          READ PFS8B
          LDDL   CM+1        LOAD LOCATION WITH ISSUE TIMEOUT BIT
          LPC    PFIT        MASK ISSUE TIMEOUT BIT
          ZJN    DEP2        IF NOT ISSUE TIMEOUT

          LDN    V4EPIT      ERROR PRIORITY 3  (ISSUE TIMEOUT)
          UJN    DEP0

 DEP2     LDN    V4EPOT      ERROR PRIORITY 2  (OTHER)
          UJN    DEP0
          EJECT
**        FEP - FIND EXCHANGE PACKAGE.
*
*         METHOD             READS ADDRESS OF EXCHANGE PACKAGE.
*
*         ENTRY              NA.
*
*         USES               RDATA+7.
*
*         CALLS              PAC.
*
*         EXIT               (MRVAL) = ADDRESS OF EXCHANGE PACKAGE.


 FEP      SUBR               ENTRY/EXIT
          READMR RDATA,HBUF+CPRPC,SSMR
          LDML   RDATA+7
          LPN    0#20        CHECK MONITOR MODE
          ZJP    FEP0        IF JOB MODE
          READMR RDATA,HBUF+HDRPC,PMPS  ADDR OF XP AT MPS
          UJP    FEP1        EXIT

 FEP0     READMR RDATA,HBUF+HDRPC,PJPS  ADDR OF XP AT JPS
 FEP1     RJM    PAC         ADDR IN MRVAL
          UJP    FEPX        EXIT
          EJECT
**        MSA - MAKE SYSTEM VIRTUAL ADDRESS.
*
*         METHOD             MAKE SYSTEM VIRTUAL ADDRESSES FOR P.
*
*         ENTRY              (W4 - W5) = PARTIAL ADDRESS TO EXCHANGE PACKAGE.
*                            (W6) =  R-RGTR OFFSET TO EXCHANGE PACKAGE.
*
*         USES               CM - CM+2, MSAA - MSAA+2, MSAB, T1-T4, W0-W6.
*
*         CALLS              LWA.
*
*         EXIT               (CM - CM+2) = SYSTEM VIRTUAL ADDRESS.
*                            (W0 - W3) = SEGMENT TABLE ENTRY.


 MSA1     LDN    0           FLAG INVALID/MISSING SEGMENT

 MSA      SUBR               ENTRY/EXIT
          LRD    W4
          LDD    W6
          ADC    RR          SET BIT 18
          CRML   MSAA,ON     (MSAA) = P FROM EXCHANGE PACKAGE
          LDML   MSAA+1
          LPC    0#FFF       ZERO OUT RING NUMBER
          STML   MSAA+1
          LDML   MSAA+3
          LPN    BOB         BYTE OFFSET BITS
          STML   MSAB        (MSAB) = BYTE OFFSET
          LDML   MSAA+3
          SCN    BOB
          STML   MSAA+3      CHANGE TO WORD BOUNDARY
          LDD    W6          LOAD BYTE ADDRESS
          ADN    16D         SEGMENT TABLE LENGTH OFFSET
          ADC    RR          SET BIT 18
          CRDL   T1          GET SEGMENT TABLE LENGTH
          ADN    18D         SEGMENT TABLE ADDRESS OFFSET
          CRDL   T2          GET SEGMENT TABLE ADDRESS
          ADN    1
          CRDL   T3
          LDDL   T1
          SBML   MSAA+1
          MJP    MSA1        IF NOT A VALID SEGMENT
          LDDL   T3          FORM WORD ADDRESS FOR LWA
          SHN    -3
          STDL   T3
          LDD    T2
          LPN    7
          SHN    13D
          RADL   T3
          LDDL   T2
          SHN    -3
          STDL   T2
          LDN    T2
          RJM    LWA         LOAD ADDRESS OF SEGMENT TABLE
          ADML   MSAA+1      ADD SEGMENT OF INTEREST
          CRDL   W0          FETCH ASID
          LDDL   W0
          LPC    0#8000
          ZJP    MSA1        IF INVALID
          LDDL   W1
          ZJP    MSA1        IF NOT A VALID ASID
          STDL   CM          SAVE ASID
          LDML   MSAA+2      COPY REMAINDER OF SVA
          STDL   CM+1
          LDML   MSAA+3
          STDL   CM+2
          LDN    1
          UJP    MSAX        RETURN

 MSAA     BSSZ   4
 MSAB     CON    0
          EJECT
**        RWE - READ AND WRITE THE EXECUTING WORDS OF THE SCM'S.
*
*         METHOD             READ THE EXECUTING WORD OF THE SELECTED SCM
*                            AND WRITE IT TO THE MDB.
*
*         ENTRY              NA.
*
*         USES               RN, RWEA, RWEB, W5.
*
*         CALLS              AMR, CMI, PAC, WMB.
*
*         EXIT               THE EXECUTING WORDS OF ALL SELECTED SCM'S ARE
*                            WRITTEN TO THE MDB.
*

          ROUTINE RWE        ENTRY/EXIT

          LDN    0
          STDL   W5          TABLE INDEX
 RWE0     LDML   RWEA,W5     SOFT CONTROL ADDRESS
          STDL   RN

          EXITMR RWE1

          LDM    HBUF+HDRPC  FORM FUNCTION WORD
          ADC    MRRD
          ADML   RWEB,W5     ADD TYPE CODE
          RJM    AMR         ACCESS MAINTENANCE CHANNEL
          LDN    8D
          IAM    RDATA,MR
          RJM    PAC         PAC DATA INTO MRVAL
          RJM    CMI         CLEAR MAINT INTERLOCK

 RWE1     EXITMR FMR

          RJM    WMB         WRITE MDB DATA
          AODL   W5          UPDATE INDEX
          ADC    -23D
          ZJP    RWEX        IF DONE READING
          UJP    RWE0        CONTINUE READING



 RWEA     BSS    0           SOFT CONTROL ADDRESSES
          CON    IDU.CIR
          CON    IDU.CIR+1
          CON    IDU.CIR+2
          CON    IDU.CIR+3
          CON    ACU.M2
          CON    ACU.M3
          CON    ACU.M4
          CON    BDP.SCM
          CON    BDP.SCM+1
          CON    EPN.SCM
          CON    EPN.ETM
          CON    IDU.CSMM
          CON    IDU.CSMM+1
          CON    IDU.CSMM+2
          CON    IDU.CSMM+3
          CON    IDU.CW
          CON    IDU.CW+1
          CON    IDU.CW+2
          CON    IDU.CW+3
          CON    INU.IMAP
          CON    INU.IBS
          CON    LSU.SCM
          CON    SVA.BN

 RWEB     BSS    0           TYPE CODES
          CON    TC.IDU
          CON    TC.IDU
          CON    TC.IDU
          CON    TC.IDU
          CON    TC.ACU
          CON    TC.ACU
          CON    TC.ACU
          CON    TC.BDP
          CON    TC.BDP
          CON    TC.EPN
          CON    TC.EPN
          CON    TC.IDU
          CON    TC.IDU
          CON    TC.IDU
          CON    TC.IDU
          CON    TC.IDU
          CON    TC.IDU
          CON    TC.IDU
          CON    TC.IDU
          CON    TC.IDU
          CON    TC.IDU
          CON    TC.LSU
          CON    TC.ACU

          EJECT
**        SRP - SET RELOCATION POINTER.
*
*         ENTRY  (MRVAL) = PACKED REGISTER 32 BIT RMA BYTE ADDRESS.
*
*         EXIT   (A) = PARTIAL ADDRESS.
*                (W6) = PARTIAL ADDRESS.
*                THE INPUT BYTE ADDRESS RMA WILL BE CONVERTED TO
*                AN R-REGISTER POINTER WORD ADDRESS.
*
*         CALLS  STA.

 SRP      SUBR

          LDN    2
          STD    T5
          LDN    3
          STD    T6
          LDML   MRVAL,T5
          STDL   W2
          LDML   MRVAL,T6
          SHN    -3
          STDL   W3
          LDDL   W2
          LPN    7
          SHN    15
          LMDL   W3
          STDL   W3
          LDDL   W2
          SHN    -3
          STDL   W2
          RJM    STA
          LJM    SRPX        RETURN
          EJECT
**        WCB - WRITE THE CAPTURE BUFFER TO THE MDB.
*
*         METHOD             WRITE THE CAPTURE BUFFER TO THE MDB.
*
*         ENTRY              THE MDB TO BE USED HAS THE ADJUSTED MDB ADDRESS
*                            IN RS - RS+2.
*
*         USES               CM, MRRD, MRVAL, PMF1, RDATA, RN, W5.
*
*         CALLS              AMR, CLR, CMI, PAC, WMB.
*
*         EXIT               SUB HEADER WORD FOR CAPTURE BUFFER AND CAPTURE
*                            BUFFER DATA WRITTEN TO SELECTED MDB.
*
*                            THE LAST SELECTED MDB ADDRESS WILL BE IN
*                            RS - RS+2.

 WCB      SUBR               ENTRY/EXIT

*         WRITE CAPTURE BUFFER TO MEMORY.

          EXITMR WCB5

          LDK    PMF1        LOAD ADDRESS OF CAPTURE BUFFER
          STDL   RN          SAVE
          LDC    MRRD        LOAD READ REGISTER FUNCTION
          ADML   HBUF+HDRPC  SELECT RADIAL TO USE

*         SET CHANNEL INTERLOCK, LOAD FUNCTION, OUTPUT ADDRESS.

          RJM    AMR         ACCESS MNTNCE RGTR
          LDN    1
          STML   RMEA
          LDC    512D
          STDL   W5          WORD COUNTER FOR CAPTURE BUFFER
 WCB0     LDN    10
          IAM    RDATA,MR    READ 1 WORD FROM CAPTURE BUFFER
          ZJN    WCB2        IF NO ERROR

          LDN    0           DEPLETE 512 WORD CTR
          STDL   W5          MCH MUST HAVE DISCONNECTED
 WCB1     LDC    0#FFFF
          STML   MRVAL,W5    STORE ALL 1'S TO DENOTE ERROR
          AODL   W5
          SBN    4
          NJN    WCB1        IF NOT DONE
          LDN    1
          STDL   W5          DEPLETE COUNTER
          UJN    WCB3        WRITE MDB WITH ERROR DATA

 WCB2     RJM    PAC         PACKED DATA NOW IN MRVAL

 WCB3     RJM    WMB         WRITE DATA TO MDB

          SODL   W5          DECREMENT 512 WORD CTR
          ZJN    WCB4        IF DONE
          UJN    WCB0        PROCESS NEXT WORD

 WCB4     RJM    CMI         DEACTIVATE CHANNEL, CLEAR INTERLOCK

 WCB5     EXITMR FMR
          UJP    WCBX        EXIT
          EJECT
**        WE1 - WRITE ERROR ID 1 AND DATA LENGTH OF 3 TO MDB SUB HEADER.
*
*         METHOD             SET UP MRB6 ID AND DATA LENGTH AND THEN WRITE
*                            WRITE THE SUB HEADER.
*
*         ENTRY              THE MDB TO BE USED HAS THE ADJUSTED MDB ADDRESS
*                            IN RS - RS+2.
*
*         USES               SHWD.
*
*         CALLS              CLR, WSH.
*
*         EXIT               SUB HEADER WORD FOR ERROR ID 1 WRITTEN TO MDB.
*
*                            THE LAST SELECTED MDB ADDRESS WILL BE IN
*                            RS - RS+2.

          ROUTINE WE1        ENTRY/EXIT

*         CLEAR THE SUB HEADER WORD BUFFER FOR SUB HEADER BUILD.

          LDC    SHWD        LOAD ADDRESS OF SUB HEADER WORD BUFFER
          RJM    CLR         CLEAR BLOCK

*         SET UP SUB HEADER.

          LDN    SH.MR1      SUB HEADER ID
          STML   SHWD+V4SHHID  STORE TO BUFFER
          LDC    LOD.MR1     LENGTH OF DATA TO WRITE
          ADN    1           ADD 1 FOR SUB HEADER WORD
          STML   SHWD+V4SHLOD  STORE TO BUFFER
          CALL   WSH         WRITE SUB HEADER WORD
          UJP    WE1X        EXIT

          EJECT
**        WEP - WRITE THE EXCHANGE PACKAGE TO THE MDB.
*
*         METHOD             WRITE THE EXCHANGE PACKAGE TO THE MDB.
*
*         ENTRY              THE MDB TO BE USED HAS THE ADJUSTED MDB ADDRESS
*                            IN RS - RS+2.
*
*         USES               CM, MRVAL, T3, W2, W4, W6.
*
*         CALLS              CLR, FEP, PAC, SRA, WMB.
*
*         EXIT               SUB HEADER WORD FOR EXCHANGE PACKAGE ID AND
*                            EXCHANGE PACKAGE DATA WRITTEN TO SELECTED MDB.
*
*                            THE LAST SELECTED MDB ADDRESS WILL BE IN
*                            RS - RS+2.

 WEP      SUBR               ENTRY/EXIT

*         WRITE EXCHANGE PACKAGE TO MEMORY.

          LDC    LOD.EP      LENGTH OF EXCHANGE PACKAGE
          STDL   T3          INITIALIZE INDEX
          RJM    FEP         FIND EXCHANGE PACKAGE
          RJM    SRP         SET R RGTR
          LDD    W6
          STD    W2          SAVE OFFSET FOR ROUTINE WPI
          LRD    W4
          ADC    RR          SET BIT 18
          CRML   MRVAL,ON    READ FIRST WORD FROM EXCHANGE PACKAGE
          UJN    WEP1
 WEP0     AOD    W6          INCREMENT EXCHANGE PACKAGE CM ADDRESS
          LRD    W4
          ADC    RR
          CRML   MRVAL,ON    READ WORD FROM EXCHANGE PACKAGE
 WEP1     RJM    WMB         WRITE MODEL DEP BUFFER
          SODL   T3          DECREMENT INDEX
          NJP    WEP0        IF NOT DONE WITH EXCHANGE PACKAGE
          UJP    WEPX        EXIT

          EJECT
**        WHF - WRITE THE HISTORY FILE TO THE MDB.
*
*         METHOD             WRITE THE HISTORY FILE TO THE MDB.
*
*         ENTRY              THE MDB TO BE USED HAS THE ADJUSTED MDB ADDRESS
*                            IN RS - RS+2.
*
*         USES               CM, W5.
*
*         CALLS              CLR, PAC, WMB.
*
*         EXIT               SUB HEADER WORD FOR HISTORY FILE AND HISTORY
*                            FILE DATA WRITTEN TO SELECTED MDB.
*
*                            THE LAST SELECTED MDB ADDRESS WILL BE IN
*                            RS - RS+2.

 WHF      SUBR               ENTRY/EXIT

*         WRITE HISTORY FILE DATA TO MEMORY.

          FUNCMR HBUF+CPRPC,MRMC  MASTER CLEAR THE PROCESSOR
          LDN    0
          STDL   W5          INITIALIZE INDEX

          EXITMR WHF1

 WHF0     RDMEM  RGU.HF,W5,,,8,TC.RGU   READ HISTORY FILE TO RDATA

          RJM    PAC         PACKED RESULT NOW IN MRVAL
          RJM    WMB         WRITE MODEL DEP BUFFER
          AODL   W5          INCREMENT INDEX
          ADC    -64D
          NJP    WHF0        IF NOT DONE WITH HISTORY FILE

 WHF1     EXITMR FMR
          UJP    WHFX        EXIT
          EJECT
**        WLR - WRITE MRB6 DATA TO THE MDB.
*
*         METHOD             WRITE THE LAST TWO WORDS OF MRB6 TO THE MDB.
*
*         ENTRY              THE MDB TO BE USED HAS THE ADJUSTED MDB ADDRESS
*                            IN RS - RS+2.
*
*         USES               MRVAL, TRPO, W6.
*
*         CALLS              WMB.
*
*         EXIT               MRB DATA WRITTEN TO MDB FOR RETRY ERRORS.
*
*                            THE LAST SELECTED MDB ADDRESS WILL BE IN
*                            RS - RS+2.

          ROUTINE WLR        ENTRY/EXIT

          LDN    TRPO        THETA RETRY P OFFSET
          STDL   W6          STORE TO OFFSET INDEX
 WLR0     LDDL   W6          LOAD OFFSET
          RJM    IMB         SET R REGISTER
          CRML   MRVAL,ON    READ MRB
          RJM    WMB         WRITE MRB TO THE MDB
          AODL   W6          INCREMENT OFFSET INDEX
          SBN    TRPO+2
          NJP    WLR0        CONTINUE FOR 2 WORDS
          UJP    WLRX        EXIT
          EJECT
**        WMR - WRITE MRB6 DATA TO THE MDB.
*
*         METHOD             WRITE THE FIRST THREE WORDS OF MRB6 TO THE MDB.
*
*         ENTRY              THE MDB TO BE USED HAS THE ADJUSTED MDB ADDRESS
*                            IN RS - RS+2.
*
*         USES               MRBA, W4, W5, W6.
*
*         CALLS              IBW, IMB, WE1, WMB.
*
*         EXIT               MRB DATA WRITTEN TO MDB FOR SINGLE OR MULTIPLE
*                            SCM PE.
*
*                            THE LAST SELECTED MDB ADDRESS WILL BE IN
*                            RS - RS+2.

          ROUTINE WMR        ENTRY/EXIT

 WMR0     LDN    25D         OFFSET FOR MRB6
          STDL   W6          INITIALIZE INDEX

          CALL   WE1         WRITE MDB SUB HEADER FOR ERROR ID
          LDML   MRBA        SCM PE COUNT
          STDL   W4          SAVE
          LDML   MRBA,W4     FREE
          RJM    IBW         SET R REGISTER

          CRDL   CM          READ MDB BUFFER CONTROL WORD
          LDD    CM+V4BCOST  MRB OFFSET
          ADDL   W6          ADD MRB6 OFFSET
          STDL   W5          INITIALIZE INDEX

 WMR1     RJM    IMB         ADDRESS THE MRB
          CRML   MRVAL,ON    READ THE MRB
          RJM    WMB         WRITE MRB DATA TO MDB
          AODL   W6          INCREMENT MRB INDEX
          SBN    28D
          ZJN    WMR2        IF FINISHED WITH 3 WORDS OF MRB
          AODL   W5          INCREMENT OFFSET
          UJN    WMR1        CONTINUE

 WMR2     SOML   MRBA        DECREMENT PE COUNT
          ZJP    WMRX        EXIT
          UJP    WMR0        NOT FINISHED WITH MULTIPLE ENTRIES
          EJECT
**        WPC - WRITE PROGRAM CONTENTS
*
*         METHOD             TRANSLATE P FROM A PVA TO AN RMA.
*                            WRITE RESPECTIVE PTE TO MDB.  ADD
*                            AND SUBTRACT 5 WORDS ON EACH SIDE OF
*                            P.  IF A PAGE BOUNDARY IS CROSSED, THE
*                            APPROPRIATE ROUTINE IS CALLED.  OTHERWISE,
*                            LOG THE 5 INSTRUCTIONS ON EACH SIDE OF
*                            P (INCLUDING P) TO THE MDB.
*
*         CALLED             BY LMB
*
*         ENTRY              (W2)   - R RGTR OFFSET TO XCHG PKG
*                            (W4-W5) -R RGTR ADDRESS TO XCHG PKG
*
*         USES               LMBA, T1-T4, PSMV, W0-W3, W6, MRVAL
*
*         CALLS              PVC, MSA, SPT, GPP, GNP, RWP, WRZ

 WPC      SUBR               ENTRY/EXIT
          RJM    PVC         PRESET VIRTUAL CONSTANTS
          LDDL   W2
          STDL   W6          RESTORE R-RGTR TO XCHG PKG
          RJM    MSA         MAKE SYSTEM VIRTUAL ADDRESS
          ZJP    WPC3        IF NOT VALID
          AOML   LTOL        INCREMENT LENGTH TO LOG COUNT
          AOD    RS
          LRD    RS+1
          ADC    RR
          CWDL   W0          WRITE SEG TABLE ENTRY
          RJM    SPT         SEARCH PAGE TABLE
          ZJP    WPC2        IF PAGE MISS

*         SAVE RMA

          STDL   T3
          SRD    T1
          LDDL   T1
          STML   WPCA        SAVE UPPER 10 BITS
          LDDL   T2
          STML   WPCA+1      SAVE MID 12 BITS

*         WRITE PTE TO MDB

          AOML   LTOL        INCREMENT LENGTH TO LOG COUNT
          AOD    RS          INCREMENT MDB ADDRESS
          LRD    RS+1
          ADC    RR
          CWML   SPTJ,ON     WRITE PTE TO MDB

*         CHECK PAGE BOUNDARIES.

          LDML   PSMV
          LMC    0#7F
          SHN    9D
          LMC    0#FFFF
          LPML   MSAA+3
          SHN    -3
          STML   WPCB        PAGE OFFSET (IN WORDS)
          SBN    5
          MJN    WPC0        IF CROSSING TOP PAGE BDRY
          ADN    11D
          STDL   T4          PG OFFSET + 6 WORDS
          LDML   PSMV
          LMC    0#7F
          SHN    6
          LPML   T4          MASK FOR OVERFLOW
          NJN    WPC1        IF CROSSING BOTTOM PAGE BDRY

*         WRITE 11 WORDS FROM 1 PAGE TO MDB

          LDN    1
          RJM    WRZ         WRITE ZEROS TO 2ND PTE
          LDN    11D         # WORDS TO READ, WRITE
          STDL   W4
          LDDL   T3
          SBN    5
          RJM    RWP         WRITE PROGRAM CONTENTS TO MDB
          LJM    WPCX

 WPC0     RJM    GPP         GET PREV PAGE
          LJM    WPCX

 WPC1     LDDL   T4          PO + 6
          LPN    0#3F
          STDL   T4          # WORDS TO READ FROM NEXT PAGE
          RJM    GNP         GET NEXT PAGE
          LJM    WPCX

 WPC2     LDN    12D
          STDL   T2
          UJP    WPC4

 WPC3     LDN    13D
          STDL   T2
 WPC4     LDC    0#FFFF
          STML   MRVAL
          STML   MRVAL+1
          STML   MRVAL+2
          STML   MRVAL+3
          RJM    WMB         WRITE ALL F'S TO MDB
          LDDL   T2

          RJM    WRZ         WRITE ALL ZEROS
          LJM    WPCX

 WPCA     CON    0,0,0       STORES RMA FOR P
 WPCB     CON    0           PAGE OFFSET FOR P

*COPY  CTP$DFT_PVA_TO_RMA_ROUTINES


          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW

          OVERLAY  (VERSION 4 DFT MDB LOGGING PART II)
          SPACE  4,10
**        TDE - TEST FOR DUPLICATE LOGGED ENTRIES.
*
*         METHOD             TEST THE RETRY MULTIPLE FLAG.  IF IT IS SET,
*                            ADJUST THE LENGTH OF MAINTENANCE REGISTER
*                            BUFFER AND TEST FOR A MATCH BETWEEN NEW ERROR
*                            AND PREVIOUS ERROR.
*                            IF THE RETRY MULTIPLE FLAG IS CLEAR, TEST FOR
*                            A MATCH BETWEEN NEW ERROR AND PREVIOUS ERROR
*                            WITH NO LENGTH ADJUSTMENT.
*
*         ENTRY              NA.
*
*         USES               LBUF, MFLG, TRMF.
*
*         CALLS              CFM.
*
*         EXIT               MFLG <> 0 = NO MATCH.
*

          ROUTINE TDE        ENTRY/EXIT

          LDML   TRMF        RETRY MULTIPLE FLAG
          ZJN    TDE1        IF NO RETRY MULTIPLE
          LDML   LBUF
          SBN    1
 TDE0     RJM    CFM         TEST FOR MATCH
          STML   MFLG        MATCH FLAG
          UJP    TDEX        EXIT
 TDE1     LDML   LBUF
          UJN    TDE0

*COPY     CTP$DFT_LOG_ERROR_CHECK_MATCH
*COPYC CTP$DFT_MDB_LOGGING_ROUTINES

          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW


          OVERLAY  (ANALYSE I4 IOU ERRORS)
          QUAL
*COPYC CTP$DFT_ANALYZE_IOU_ERRORS_I4
*COPYC CTP$DFT_PROCESS_DUAL_I4_IOU_ERR
*COPY CTP$DFT_SET_SS_DUAL_I4
          QUAL   *
          QUAL   *
 CEE      SPACE  4,10
**        CEE - CHECK FOR EXPECTED IOU ERROR.
*
*         METHOD  - IOU FAULT STATUS REGISTERS ARE READ FROM SCRATCH
*                   BUFFER.  IF ANY ERROR OTHER THAN CHANNEL 17
*                   ERROR EXISTS, THEN *AIE* SHOULD PROCESS ERROR.
*                   CHANNEL 17 ERROR IS FLAGGED BY *FS2* REGISTER.
*                   BOTH NIO AND CIO *FS2* REGISTER DATA ARE CHECKED IF
*                   CIO SUBSYSTEM IS INSTALLED.
*
*         EXIT   (A) = 0 IF ERROR SHOULD BE PROCESSED.
*                (A) = 1 IF ERROR SHOULD BE IGNORED.
*
*         USES   T2, W0 - W3, *EIEF*.
*
*         CALLS  FMB.


 CEE      SUBR               ENTRY/EXIT
          LDML   EIEF        EXPECTED IOU ERROR FLAG
          ZJN    CEEX        IF NOT SET, PROCESS ERROR
          LDN    0           CLEAR EXPECTED ERROR FLAG
          STML   EIEF
          LDN    0
          STDL   T2          INITIALIZE REGISTER LIST INDEX FOR CIO PP-S
          LDN    OIMR        CHECK IF CIO SUBSYSTEM PRESENT
          RJM    FMB
          CRDL   W0
          LDML   W0+3        CHECK *OIMR* BIT 56
          SHN    21-63D+56D
          MJN    CEE1        IF CONCURRENT PP-S PRESENT
          LDN    2           CHECK ONLY NON-CONCURRENT REGISTERS
          STD    T2
 CEE1     LDML   CEEA,T2     READ NEXT REGISTER FROM SCRATCH MRB
          RJM    FMB
          CRDL   W0
          LDDL   W0
          ADDL   W1
          ADDL   W2
          STML   CEEB
          LDDL   T2          CHECK REGISTER
          LPN    1
          ZJN    CEE2        IF NOT *IFS2* (NIO OR CIO)
          LDDL   W3
          SCN    0#10
          UJN    CEE3        CONTINUE

 CEE2     LDDL   W3
 CEE3     ADML   CEEB        PREVIOUS BYTE SUM
          NJN    CEE5        IF OTHER ERROR SET
          AODL   T2
          SBN    4
          NJN    CEE1        IF REGISTERS NOT ALL READ
          SETDAC DDCL        ACTION = CLEAR ERRORS
          LDN    1           INDICATE THAT ERROR SHOULD BE IGNORED
 CEE4     LJM    CEEX        RETURN

 CEE5     LDN    0           INDICATE THAT ERROR SHOULD BE PROCESSED
          UJN    CEE4        RETURN

 CEEA     CON    CIFS1,CIFS2,IFS1,IFS2
 CEEB     CON    0

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (ANALYSE CYBER 990 MEMORY ERRORS)
 AME      SPACE  4,10
**        AME - PROCESS MEMORY ERRORS.
*
*         CALLS  CLR, GSC, FMB, *CFF*, *LOG*, *SME*.


          ROUTINE AME

          LDN    0
          STM    RLST        CORRECTED ERROR FLAG
          STM    NERR        SET NO ERROR FLAG FLAG
          STML   SBER
          STML   SBER+1
          STML   SYCD
          LDN    BC
          RJM    CLR         ZERO SCRATCH BUFFER
          LDM    SUMS        SUMMARY STATUS
          SHN    21-SSUE
          PJP    AME6        IF NOT UNCORRECTED
          LDC    MUL1        CYBER 990 UNCORRECTED ERROR MEMORY ERROR LOG
          STD    RN
 AME0     READMR RDATA,CMCC
          LDM    RDATA
          SHN    12
          PJN    AME1        IF NO VALID DATA IN REGISTER
          LDM    RDATA+7
          LPN    1
          ZJN    AME1        IF NOT PARTIAL WRITE ERROR
          LDM    RDATA+6     BITS 48 - 55
          NJN    AME2        IF PARTIAL WRITE ERROR
 AME1     AOD    RN
          LMC    0#A7+1
          NJN    AME0        IF NOT THRU SCANNING THE UEL REGISTERS
          UJP    AME3        PUT OUT UNCORRECTED ERROR ANALYSIS

*         DFT ANALYSIS - OS ACTION = MULTIPLE ODD BIT ERROR.
*                                  = STEP SYSTEM (VERSION 4).

 AME2     SETDAC DDCM
          SETDAN (EPUN,DAPWP)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          SETOSA OSMOB,OSSS
          UJP    AME4        LOG THE ERROR

*         DFT ANALYSIS - OS ACTION = UNCORRECTED MEMORY ERROR.
*                                  = NO OS ACTION (VERSION 4).

 AME3     SETDAC DDCM
          SETDAN (EPUN,DAUME)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          SETOSA OSUCM,OSNA
 AME4     LDM    ME0U        UNCORRECTED MEMORY REGISTER LIST
          RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          CALL   CFF         CHECK FOR FREEZE
          LDM    RTP2
          ZJN    AME4.5      IF NOT TO IGNORE ERROR
          LDN    0
          STM    DFTA        NO ACTION
          STM    REGI        RESET REGISTER LIST INDEX
          UJP    AMEX
 AME4.5   CALL   LOG
 AME5     LJM    AMEX        RETURN

 AME6     LDM    SUMS
          SHN    21-SSCE
          PJN    AME5        IF NOT A CORRECTED ERROR
          LDN    1
          STM    RLST        SET CORRECTED ERROR LIST FLAG

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CORRECTED CM ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR MEMORY ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAC DDCM
          SETDAN (EPCO,DACME)
          SETFLG (BC.FL)
          LDM    ME0C        CORRECTED MEMORY ERROR REGISTERS
          RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          CALL   CFF
          LDM    RTP2
          ZJN    AME6.5      IF NOT TO IGNORE ERROR
          LDN    0
          STM    DFTA        NO ACTION
          STM    REGI        RESET REGISTER LIST INDEX
          UJP    AMEX

 AME6.5   LDD    MD          GET MODEL
          LMC    0#40
          ZJN    AME7        IF MODEL 40 MEMORY
          UJP    AME11       IF MODEL 41 OR 42 MEMORY

*         PROCESS CYBER 990 MEMORY ERRORS.
*
*         FOR CYBER 990 THERE ARE MULTIPLE *CEL* REGISTERS.  PREPARE
*         LOOP TO READ ALL BUT FIRST SAVE OFFSET OF THE READ
*         IN RESIDENT SAVE AREA BECAUSE OVERLAYS CANT HOLD
*         MODIFIED DATA.

 AME7     LDN    3
          STM    RST1
 AME8     ADC    MCEL
          RJM    FMB
          CRDL   W0          READ *CEL* REGISER (I)
          LDDL   W0
          SHN    2
          MJN    AME10       IF REGISTER TO PROCESS
 AME9     SOM    RST1
          MJP    AMEX        IF DONE WITH *CEL* REGISTERS
          UJN    AME8        LOOP

 AME10    RJM    GSC         GET SYNDROME CODE
          LDDL   W2
          SHN    -11D
          LPN    0#1C        CLEAR LOWER 2 BITS FOR DISTRIBUTOR
          STML   SBER+1
          LDDL   W1
          LPC    0#7FF
          SHN    5
          RAML   SBER+1
          LDDL   W1
          SHN    -11D
          STML   SBER
          LDDL   W0
          LPN    0#7
          SHN    5
          RAML   SBER
          LDML   SBER+1
          LMML   RST1        ADD IN DISTRIBUTOR NUMBER
          STML   SBER+1
          CALL   SME         SERVICE MEMORY ERROR
          LJM    AME9        CONTINUE

*         FOR CYBER 990 THERE ARE MULTIPLE CEL REGISTERS PREPARE
*         LOOP TO READ ALL BUT FIRST SAVE OFFSET OF THE READ
*         IN RESIDENT SAVE AREA BECAUSE OVERLAYS CANT HOLD
*         MODIFIED DATA.

 AME11    LDN    3           CYBER 990 MEMORY
          STM    RST1
 AME12    ADC    MCEL
          RJM    FMB
          CRDL   W0          READ CEL(I) REG
          LDDL   W0
          SHN    2
          MJN    AME14       IF REGISTER TO PROCESS
 AME13    SOM    RST1
          MJP    AMEX        IF DONE WITH CEL REGS
          UJN    AME12       LOOP

 AME14    RJM    GSC         GET SYNDROME CODE
          LDDL   W2
          SHN    -11D
          LPN    0#1C        CLEAR LOWER 2 BITS FOR DISTRIBUTOR
          STML   SBER+1
          LDDL   W1
          LPC    0#7FF
          SHN    5
          RAML   SBER+1
          LDDL   W1
          SHN    -11D
          STML   SBER
          LDDL   W0
          LPN    0#1F        THIS IS DIFFERENCE BETWEEN MODEL 41, 42 AND MODEL 40 MEMORY
          SHN    5
          RAML   SBER
          LDML   SBER+1
          LMML   RST1        ADD IN DISTRIBUTOR NUMBER
          STML   SBER+1
          CALL   SME         SERVICE MEMORY ERROR
          LJM    AME13       LOOP
 GSC      SPACE  4,10
**        GSC - GET SYNDROME CODE.
*
*         ENTRY  (W0 - W3) = PROPER *CEL* REGISTER.
*
*         EXIT   (SYCD) = SYNDROME CODE.
*
*         USES   W0 - W3, *SYCD*.


 GSC      SUBR               ENTRY/EXIT
          LDN    0
          STM    SYCD

*         PROCESS CYBER 990 SYNDROME CODE.

 GSC3     LDDL   W2
          LPC    0#FF        BITS 40 - 47
          STM    SYCD        SAVE SYNDROME CODE
          LJM    GSCX        RETURN
*COPY CTP$DFT_SERVICE_MEMORY_ERROR
*COPY CTP$DFT_REWRITE_CM_ERROR
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (LOG ERRORS TO BUFFER CONTROL WORDS)

**        ON CYBER 990 THERE IS SPECIAL HANDLING OF COMPARING MULTIPLE
*         RETRY ERRORS.


 QUAL$    EQU    0           DEFINE UNQUALIFIED COMMON DECKS
*COPYC CTP$DFT_LOG_ERROR
*COPY CTP$DFT_LOG_ERROR_CHECK_MATCH
*COPY CTP$DFT_ZERO_SUPPORTIVE_STATUS
*COPY CTP$DFT_INCREMENT_ERROR_COUNT
*COPY CTP$DFT_FIND_CONTROL_WORD
*COPY CTC$DFT_ELEMENT_CONVERSIONS


*         IF *TRMF* IS SET, THEN THE BUFFER LENGTH MUST BE DECREASED BY
*         ONE.  THIS ADJUSTMENT IS MADE SO THAT RETRY COUNTERS ARE NOT
*         COMPARED.  IF A DUPLICATE RETRY ERROR HAS OCCURRED, THEN THE
*         RETRY COUNTERS IN THE SCRATCH BUFFER SHOULD OVERWRITE THE RETRY
*         COUNTERS IN THE CURRENT BUFFER.


 ABL      SUBR               ENTRY/EXIT
          LDML   TRMF        THETA RETRY MULTIPLE FLAG
          ZJN    ABL1        IF NO RETRY MULTIPLE
          LDML   LBUF
          SBN    1
          UJN    ABLX        COMPARE BUFFERS
 ABL1     LDML   LBUF
          UJN    ABLX

 URC      SUBR               ENTRY/EXIT
          LDML   HALT
          ZJN    URCX        IF NOT HALT ON ERROR

*         UPDATE RETRY COUNTERS.

          LDN    TRCO        THETA RETRY COUNTER OFFSET
          RJM    IMB
          CRML   LOGA,ON     READ SCRATCH BUF, WORD 29
          LDML   FREE
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          CRDL   CM          BUFFER CONTROL WORD
          LDDL   CM+3
          ADN    TRCO        THETA RETRY COUNTER OFFSET
          RJM    IMB
          CWML   LOGA,ON     UPDATE LOGGED ENTRY
          UJP    URCX        RETURN
*COPYC CTP$DFT_LOG_ERROR_NO_CONSOLE
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (GENERATE FAULT SYMPTOM CODE)

**        CYBER 990 FAULT SYMPTOM CODES.

*COPYC CTP$DFT_GENERATE_FAULT_SYMPTOM
*COPY     CTP$DFT_WRITE_FSC_TO_BUFFER

          ROUTINE I4S        NOT DEFINED ON NON 960 APPLICATIONS
          LJM    I4SX
          QUAL   *

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (MODEL 40 IOU FSC)
 I4A      SPACE  4,10
**        I4A - INTERFACE TO I4A FSC COMMON DECK.
*


          ROUTINE  I4A

          LDDL   BC+BCDA     GET ANALYSIS TO LOG
          SHN    -BC.ANP
          SBN    EPEN
          PJP    I4A2        IF ENVIRONMENT WARNING
          LDML   CPU0M       CPU0 MODEL NUMBER
          STML   CDIF
          LDC    IFS1
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+1,ON
          LDC    IFS2
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+5,ON
          LDN    OIMR
          RJM    FMB         FIND REGISTER IN MAINTENANCE REGISTER SCRATCH
          CRDL   W0
          LDDL   W3
          SHN    21-7
          PJN    I4A0        IF NO CIO PPS PRESENT
          LDC    CIFS1
          RJM    FMB         FIND REGISTER IN MAINTENANCE REGISTER SCRATCH
          CRML   CDIF+9D,ON
          LDC    CIFS2
          RJM    FMB         FIND REGISTER IN MAINTENANCE REGISTER SCRATCH
          CRML   CDIF+13D,ON
 I4A0     LDC    CDIF        FWA OF INTERFACE BUFFER
          RJM    /IOUFLT0/IOUFLT0
 I4A1     LDC    2RDI        IOU ELEMENT IDENTIFIER
          ADM    IOUO        INCREMENT BY IOU ORDINAL
          RJM    WFS         WRITE FAULT SYMPTOM CODE TO SUPPORTIVE STATUS
          UJP    I4AX        RETURN

 I4A2     LDN    3
          STD    T1
 I4A3     LDML   I4AA,T1     GET CANNED ENVIRONMENT FAULT SYMPTOM CODE
          STML   CDIF,T1     STORE IN OUTPUT BUFFER
          SOD    T1
          PJN    I4A3        IF NOT DONE
          UJN    I4A1        LOG THE FAULT CODE

 I4AA     DATA   H*701     *


*copy     ctp$convert_digits_to_ascii
*copy     ctp$dft_generate_i4c_codes
*copy     ctp$dft_model_40_iou_fsc
*copy     ctp$dft_write_fsc_to_buffer

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (IOU MODEL 44 FSC DECK)
 I4I      SPACE  4,10
**        I4I - INTERFACE TO I4C FSC COMMON DECK.
*
*         CALLS  GS4.


          ROUTINE  I4I

          LDDL   BC+BCDA     GET ANALYSIS TO LOG
          SHN    -BC.ANP
          SBN    EPEN
          PJP    I4I2        IF ENVIRONMENT WARNING
          LDML   CPU0M       CPU0 MODEL NUMBER
          STML   CDIF
          LDC    IFS1
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+1,ON
          LDC    IFS2
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+5,ON
          LDC    CDIF        FWA OF INTERFACE BUFFER
          RJM    /IOUFLT4/IOUFLT4
 I4I1     LDC    2RDI        IOU ELEMENT IDENTIFIER
          ADM    IOUO        INCREMENT BY IOU ORDINAL
          RJM    WFS         WRITE FAULT SYMPTOM CODE TO SUPPORTIVE STATUS
          UJP    I4IX        RETURN

 I4I2     LDN    3
          STD    T1
 I4I3     LDML   I4IA,T1     GET CANNED ENVIRONMENT FAULT SYMPTOM CODE
          STML   CDIF,T1     STORE IN OUTPUT BUFFER
          SOD    T1
          PJN    I4I3        IF NOT DONE
          UJN    I4I1        LOG THE FAULT CODE

 I4IA     DATA   H*701     *
*COPY     CTP$DFT_MODEL_44_IOU_FSC
*copy     ctp$convert_digits_to_ascii
*copy     ctp$dft_generate_i4c_codes
*copy     ctp$dft_write_fsc_to_buffer
          OVERFLOW  R2ORG    CHECK FOR OVERFLOW

          OVERLAY  (READ MAINTENANCE REGISTERS)
          QUAL   *           SO THAT OTHER OVERLAYS MAY ACCESS
 THPA     SPACE  4,10
**        CYBER 990/990B PROCESSOR CORRECTED/UNCORRECTED ERROR REGISTER LIST.


 THPA     REGLST (10,00,12,30,80,81,82,83,84,85,86,87,88,89,8A,8B,8C,8D
,,8E,8F)
 THMA     SPACE  4,10
**        CYBER 990/990B MEMORY ERROR REGISTER LIST FOR ALL MEMORY ERRORS.


 THMA     REGLST (10,00,12,20,A0,A1,A2,A3,A4,A5,A6,A7,21)
 SXIU     SPACE  4,10
**        I1/I1CR/I2/I4 IN I2 MODE CORRECTED AND/ UNCORRECTED IOU ERROR LIST.


 SXIU     REGLST (10,00,12,30,40,80,81,A0,18,21)
 I4IC     SPACE  4,10
**        I4 CORRECTED IOU ERROR LIST.


 I4IC     REGLST (10,00,12,30,40,80,81,A0,18,21,16,34,44,84,85,A4,1C,25)
 I4IU     SPACE  4,10
**        I4 UNCORRECTED IOU ERROR LIST.


 I4IU     REGLST (10,00,12,30,40,80,81,A0,18,21,16,34,44,84,85,A4,1C,25)

*COPYC CTP$DFT_READ_MAINTENANCE_REGS
*COPY CTP$DFT_ZERO_SUPPORTIVE_STATUS
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (PROCESSOR PRIMITIVES)

*COPY CTP$DFT_PROCESSOR_PRIMITIVES
 THE      SPACE  4,10
**        THE  - CYBER 990 HALF-EXCHANGE IN ROUTINE TO START PROCESSOR.
*
*         ENTRY  PROCESSOR MASTER CLEARED, *CSA* REGISTER SET TO (STEX)
*                *BLOCK EXCHANGE REQUEST* AND *DISABLE PROCESSOR FAULT
*                STATUS* BITS ARE CLEARED IN *DEC*, PROCESSOR STARTED
*                AND THE DEADSTART INTERLOCK IS CLEARED IN THE *EICB*.
*
*         EXIT   PROCESSOR HALF EXCHANGED OUT TO MONITOR
*                EXCHANGE PACKAGE AT *MPS* OR *JPS*.
*


          ROUTINE THE

*         START THE PROCESSOR.

          LDML   HEIJ        GET HALF EXCHANGE IN ADDRESS
          STM    THEB+7
          SHN    -8D
          STM    THEB+6
          LOCKMR SET
          FUNCMR HBUF+CPRPC,MRMC   MASTER CLEAR PROCESSOR
          LDML   CSAR
          STDL   RN
          WRITMR THEB,HBUF+CPRPC
          FUNCMR HBUF+CPRPC,MRSP   START PROCESSOR
          LDC    200D        WAIT 100 MICRO SECS
 THE1     SBN    1
          NJN    THE1        DELAY

*         CLEAR  MAINTENANCE REGISTER INTERLOCK.

          LOCKMR CLEAR
          LJM    THEX        RETURN

 THEB     BSSZ   10          CONTROL STORE ADDRESS
 CCR      SPACE  4,10
**        CCR - CLEAR CORRECTED ERROR IN *MCR*.


          ROUTINE CCR

          READMR RDATA,HBUF+HDRPC,PMCR
          LDM    RDATA+7
          LPC    0#FD        CLEAR BIT 62 CORRECTED ERROR
          STM    RDATA+7
          WRITMR RDATA,HBUF+HDRPC,PMCR
          LJM    CCRX        RETURN
 CLRBTS   SPACE  4,10
**        CLRBTS - RESTORE MODEL-DEPENDENT BITS IN *DEC*.
*         ON CYBER 990 THIS IS A NO OP BUT FOR GENERALITY A STUB NEEDS
*         TO BE PROVIDED.


 CLRBTS   SUBR               ENTRY/EXIT
          UJN    CLRBTSX

*COPY CTP$DFT_MANAGE_MEMORY_PORT
 STRBTS   SPACE  4,10
**        STRBTS - STORE BITS IN *DEC*.


          ROUTINE STRBTS

*         PROCESS CYBER 990/990B.

 SETBTP4  LDM    RDATA+2     CLEAR BIT 16
          LPC    0#FF-0#80
          STM    RDATA+2
          LJM    STRBTSX     RETURN
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (MASSAGE CPU REGISTERS)
*COPY CTP$DFT_MASSAGE_CPU_REGISTERS

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (CLEAR ERRORS)
 CLE      SPACE  4,10
**        CLE - CLEAR ERRORS.
*
*         EXIT   ALL REGISTERS NECESSARY WILL BE CLEARED OF ERRORS.


          ROUTINE CLE

          LDM    HBUF+HDRPC
          LPC    7417
          STD    EC
          FUNCMR ,MRCE       CLEAR ERRORS FROM *PFS* REGISTERS
          LJM    CLEX        RETURN

          ROUTINE CME


*         PROCESS CYBER 990/990B MAINFRAMES.

 CME5     LDM    RLST
          NJP    CME7.5      IF CORRECTED ERROR
          LDN    3
          STD    T3          NUMBER OF UNCORRECTED ERROR REGISTERS
          LDC    MUL1
          STD    RN
          STD    T2
 CME6     LDD    T2
          RJM    FMB
          CRML   MRVAL,ON    GET NEXT REGISTER
          RJM    UPR         UNPACK IT
          LDM    RDATA
          SHN    21-7
          PJN    CME7        IF VALID NOT SET
          LDM    RDATA
          LPN    0#3F        SAVE ALL BUT VALID, UNLOGGED
          STM    RDATA
          WRITMR RDATA,HBUF+HDRPC
 CME7     AOD    RN          NEXT REGISTER
          AOD    T2          NEXT REGISTER OFFSET IN MAINTENANCE REGISTER BUFFER
          SOD    T3
          PJP    CME6        IF MORE TO PROCESS
          LJM    CMEX        RETURN

 CME7.5   LDN    3           CORRECTED ERROR LOGS
          STD    T3
          LDC    MCEL
          STD    RN
 CME8     LDD    RN
          RJM    FMB
          CRML   MRVAL,ON    GET REGISTER
          RJM    UPR         UNPACK IT
          LDM    RDATA
          SHN    21-7
          PJN    CME9        IF VALID NOT SET
          LDM    RDATA
          LPN    0#3F        SAVE ALL BUT VALID, UNLOGGED
          STM    RDATA
          WRITMR RDATA,HBUF+HDRPC
 CME9     AOD    RN
          SOD    T3
          PJP    CME8        IF MORE TO PROCESS
          LJM    CMEX        RETURN
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (UPDATE C170 MEMORY)
*COPYC CTP$DFT_UPDATE_170_MEMORY

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_OS_REQUESTS
*COPYC CTP$DFT_OS_REQUESTS_PACKETS
          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS - DUAL I4)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_REQUESTS_DUAL_I4
*COPY CTP$DFT_CHECK_TPM_PKT_RESPONSE
          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS FOR IOU1)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_REQUESTS_IOU1_DUAL_I4

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS - 2)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_REQUEST_PROCESSOR_2

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (PP REQUEST PROCESSOR)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_PP_UTILITY_REQUESTS
*COPY  CTP$DFT_DUMP_PP_REGISTERS
*COPY  DSI$DUMP_LOAD_IDLE_PP

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT ERROR LOGGING ROUTINES)
*COPY     CTP$DFT_PROCESS_DISK_ERROR
*COPY CTP$DFT_RETURN_ERROR_CODE

          OVERFLOW  R2ORG
          OVERLAY  (RESTART SCI PP)
 QUAL$    EQU    0
*COPYC CTP$DFT_RESTART_SCI
*COPY DSI$DUMP_LOAD_IDLE_PP
          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (HANDLE BLOCKED IOU ACCESS TO CM),10000B
*COPY CTP$DFT_HANDLE_IOU_BIT57

          OVERLAY  (DFT RUN TIME ERROR HANDLING)
*COPYC CTP$DFT_RUN_TIME_ERROR_HANDLER
*COPY CTP$DFT_RETURN_ERROR_CODE
*copy     ctp$construct_message_in_eicb

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          END
/EOR
*DECK DECK=CTM$DFT_DBD_835_CLASS EXPAND=TRUE
          IDENT  DBD2
          CIPPU  J
          MEMSEL 16
          TITLE  CTM$DFT DBD 835 CLASS (DBD2).
          COMMENT *SMD* LVL=11
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992

*         WORD 0 OF THE DFT BUFFER DEFINITION

          CON    2           NUMBER OF HEADER WORDS
          CON    0           SECONDARY DFT BUFFER SIZE
          CON    0           MODEL DEPENDENT BUFFER SIZE
          CON    0#348       MAXIMUM SIZE OF THE DFT BUFFER AREA

*         WORD 1 OF THE DFT BUFFER DEFINITION

          CON    0#4446
          CON    0#5453
          CON    0,0

*         WORD 2 OF THE DFT BUFFER DEFINITION

          CON    0#4446
          CON    0#5445
          CON    0,0

*         DEFINE THE MAINFRAME ELEMENT COUNTERS (CPU0, IOU0, CM, DFT INTERNAL)

          CON    0#0000
          CON    0#0200
          CON    0#0100
          CON    0#0400

*         WORD 4 OF THE DFT BUFFER DEFINITION

          CON    0#FF
          CON    0
          CON    0
          CON    0

*         WORD 5 OF THE DFT BUFFER DEFINITION DFT CONTROL WORD

          CON    0#0F01
          CON    0#700
          CON    0#0F11
          CON    0

*         WORD 6 STARTS THE DFT POINTER LENGTHS FIRST IS SECDED ID TABLE

          CON    0,0,0,0#A

*         WORD 7 IS MAINTENANCE REGISTER BUFFER POINTER

          CON    0,0,0,0#FF

*         WORD 8 IS THE MODEL DEPENDENT BUFFER POINTER

          CON    0,0,0,0

*         WORD 9 IS THE VE REQUEST POINTER

          CON    0,0,0,0

*         WORD 10 IS THE 170 PP RESIDENT POINTER

          CON    0,0,0,0

*         WORD 11 IS THE 170 0S REQUEST POINTER

          CON    0,0,0,0

*         WORD 12 IS THE MRB CONTROL WORDS POINTER

          CON    0,0,0,0#11

*         WORD 13 IS THE MAINFRAME ELEMENT COUNTERS BUFFER POINTER

          CON    0,0,0,4

*         WORD 14 IS THE ERROR CONTROL RECORD POINTER

          CON    0,0,0,0#19

*         WORD 15 IS THE SUPPORTIVE STATUS BUFFER POINTER

          CON    0,0,0#7,0#78

*         WORD 16 IS THE NON REGISTER SUPPORTIVE STATUS POINTER

          CON    0,0#B,0#11,0#BC

*         WORD 17 IS THE DFT CM RESIDENT POINTER

          CON    0,0,0,0#64

*         WORD 18 IS THE DFT PP REGISTER SAVE AREA

          CON    0,0,0,0#56

*         WORD 19 IS THE SECONDARY DFT BUFFER POINTER.

          CON    0,0,0,0

          END
/EOR
*DECK DECK=CTM$DFT_DBD_930_CLASS EXPAND=TRUE
          IDENT  DBD0
          CIPPU  J
          MEMSEL 16
          TITLE  CTM$DFT DBD 930 CLASS (DBD0).
          COMMENT *SMD* LVL=11
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992

*         WORD 0 OF THE DFT BUFFER DEFINITION

          CON    2           NUMBER OF HEADER WORDS
          CON    0           SECONDARY DFT BUFFER SIZE
          CON    0           MODEL DEPENDENT BUFFER SIZE
          CON    0#7A7       MAXIMUM SIZE OF THE DFT BUFFER AREA

*         WORD 1 OF THE DFT BUFFER DEFINITION

          CON    0#4446
          CON    0#5453
          CON    0,0

*         WORD 2 OF THE DFT BUFFER DEFINITION

          CON    0#4446
          CON    0#5445
          CON    0,0

*         DEFINE THE MAINFRAME ELEMENT COUNTERS (CPU0, CPU1, IOU0, CM, PAGE MAP)

          CON    0#0000
          CON    0#1000
          CON    0#0200
          CON    0#0100

*         WORD 4 OF THE DFT BUFFER DEFINITION

          CON    0#0300
          CON    0#0400
          CON    0#FF
          CON    0

*         WORD 5 OF THE DFT BUFFER DEFINITION DFT CONTROL WORD

          CON    0#0F01
          CON    0#700
          CON    0#5011
          CON    0

*         WORD 6 STARTS THE DFT POINTER LENGTHS FIRST IS SECDED ID TABLE

          CON    0,0,0,0#A

*         WORD 7 IS MAINTENANCE REGISTER BUFFER POINTER

          CON    0,0,0,0#550

*         WORD 8 IS THE MODEL DEPENDENT BUFFER POINTER

          CON    0,0,0,0

*         WORD 9 IS THE VE REQUEST POINTER

          CON    0,0,0,0

*         WORD 10 IS THE 170 PP RESIDENT POINTER

          CON    0,0,0,0

*         WORD 11 IS THE 170 0S REQUEST POINTER

          CON    0,0,0,0

*         WORD 12 IS THE MRB CONTROL WORDS POINTER

          CON    0,0,0,0#11

*         WORD 13 IS THE MAINFRAME ELEMENT COUNTERS BUFFER POINTER

          CON    0,0,0,6

*         WORD 14 IS THE ERROR CONTROL RECORD POINTER

          CON    0,0,0,0#25

*         WORD 15 IS THE SUPPORTIVE STATUS BUFFER POINTER

          CON    0,0,0#7,0#78

*         WORD 16 IS THE NON REGISTER SUPPORTIVE STATUS POINTER

          CON    0,0#B,0#11,0#BC

*         WORD 17 IS THE DFT CM RESIDENT POINTER

          CON    0,0,0,0#64

*         WORD 18 IS THE DFT PP REGISTER SAVE AREA

          CON    0,0,0,0#56

*         WORD 19 IS THE SECONDARY DFT BUFFER POINTER.

          CON    0,0,0,0

          END
/EOR
*DECK DECK=CTM$DFT_DBD_960_CLASS EXPAND=TRUE
          IDENT  DBD5
          CIPPU  J
          MEMSEL 16
          TITLE  CTM$DFT DBD 960 CLASS (DBD5).
          COMMENT *SMD* LVL=11
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992

*         WORD 0 OF THE DFT BUFFER DEFINITION

          CON    2           NUMBER OF HEADER WORDS
          CON    0#39        SECONDARY DFT BUFFER SIZE
          CON    0#C8        MODEL DEPENDENT BUFFER SIZE
          CON    0#968       MAXIMUM SIZE OF THE DFT BUFFER AREA

*         WORD 1 OF THE DFT BUFFER DEFINITION

          CON    0#4446
          CON    0#5453
          CON    0,0

*         WORD 2 OF THE DFT BUFFER DEFINITION

          CON    0#4446
          CON    0#5445
          CON    0,0

*         DEFINE THE MAINFRAME ELEMENT COUNTERS (CPU0, CPU1, IOU0, IOU1, CM)

          CON    0#0000
          CON    0#1000
          CON    0#0200
          CON    0#1200

*         WORD 4 OF THE DFT BUFFER DEFINITION

          CON    0#0100
          CON    0#0400
          CON    0#FF
          CON    0

*         WORD 5 OF THE DFT BUFFER DEFINITION DFT CONTROL WORD

          CON    0#0F01
          CON    0#700
          CON    0#1911
          CON    0

*         WORD 6 STARTS THE DFT POINTER LENGTHS FIRST IS SECDED ID TABLE

          CON    0,0,0,0#A

*         WORD 7 IS MAINTENANCE REGISTER BUFFER POINTER

          CON    0,0,0,0#1A9

*         WORD 8 IS THE MODEL DEPENDENT BUFFER POINTER

          CON    0,0,0,3

*         WORD 9 IS THE VE REQUEST POINTER

          CON    0,0,0,0

*         WORD 10 IS THE 170 PP RESIDENT POINTER

          CON    0,0,0,0

*         WORD 11 IS THE 170 0S REQUEST POINTER

          CON    0,0,0,0

*         WORD 12 IS THE MRB CONTROL WORDS POINTER

          CON    0,0,0,0#11

*         WORD 13 IS THE MAINFRAME ELEMENT COUNTERS BUFFER POINTER

          CON    0,0,0,6

*         WORD 14 IS THE ERROR CONTROL RECORD POINTER

          CON    0,0,0,0#25

*         WORD 15 IS THE SUPPORTIVE STATUS BUFFER POINTER.

          CON    0,0,0#7,0#78

*         WORD 16 IS THE NON REGISTER SUPPORTIVE STATUS POINTER.

          CON    0,0#B,0#44,0#2ED

*         WORD 17 IS THE DFT CM RESIDENT POINTER.

          CON    0,0,0,0#64

*         WORD 18 IS THE DFT PP REGISTER SAVE AREA.

          CON    0,0,0#78,0#F1

*         WORD 19 IS THE DFT SECONDARY BUFFER POINTER.

          CON    0,0,0,0#37

          END
/EOR
*DECK DECK=CTM$DFT_DBD_990_CLASS EXPAND=TRUE
          IDENT  DBD4
          CIPPU  J
          MEMSEL 16
          TITLE  CTM$DFT DBD 990 CLASS (DBD4).
          COMMENT *SMD* LVL=11
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992

*         WORD 0 OF THE DFT BUFFER DEFINITION.

          CON    2           NUMBER OF HEADER WORDS
          CON    0#3E        SECONDARY DFT BUFFER SIZE
          CON    0#2D0       MODEL DEPENDENT BUFFER SIZE
          CON    0#DA9       MAXIMUM SIZE OF THE DFT BUFFER AREA

*         WORD 1 OF THE DFT BUFFER DEFINITION

          CON    0#4446
          CON    0#5453
          CON    0,0

*         WORD 2 OF THE DFT BUFFER DEFINITION

          CON    0#4446
          CON    0#5445
          CON    0,0

*         DEFINE THE MAINFRAME ELEMENT COUNTERS (IOU0, IOU1, CPU0, CPU1, CM, DFT INTERNAL)

          CON    0#0000
          CON    0#1000
          CON    0#0200
          CON    0#1200

*         WORD 4 OF THE DFT BUFFER DEFINITION

          CON    0#0100
          CON    0#0400
          CON    0#FF
          CON    0

*         WORD 5 OF THE DFT BUFFER DEFINITION DFT CONTROL WORD

          CON    0#0F01
          CON    0#700
          CON    0#1E11
          CON    0

*         WORD 6 STARTS THE DFT POINTER LENGTHS FIRST IS SECDED ID TABLE

          CON    0,0,0,0#A

*         WORD 7 IS MAINTENANCE REGISTER BUFFER POINTER

          CON    0,0,0,0#1FE

*         WORD 8 IS THE MODEL DEPENDENT BUFFER POINTER

          CON    0,0,0,3

*         WORD 9 IS THE VE REQUEST POINTER

          CON    0,0,0,0

*         WORD 10 IS THE 170 PP RESIDENT POINTER

          CON    0,0,0,0

*         WORD 11 IS THE 170 0S REQUEST POINTER

          CON    0,0,0,0

*         WORD 12 IS THE MRB CONTROL WORDS POINTER

          CON    0,0,0,0#11

*         WORD 13 IS THE MAINFRAME ELEMENT COUNTERS BUFFER POINTER

          CON    0,0,0,6

*         WORD 14 IS THE ERROR CONTROL RECORD POINTER

          CON    0,0,0,0#25

*         WORD 15 IS THE SUPPORTIVE STATUS BUFFER POINTER

          CON    0,0,0#7,0#78

*         WORD 16 IS THE NON REGISTER SUPPORTIVE STATUS POINTER

          CON    0,0#B,0#11,0#BC

*         WORD 17 IS THE DFT CM RESIDENT POINTER

          CON    0,0,0,0#64

*         WORD 18 IS THE DFT PP REGISTER SAVE AREA

          CON    0,0,0#78,0#F1

*         WORD 19 IS THE SECONDARY DFT BUFFER POINTER.

          CON    0,0,0,0#3C

          END
/EOR
*DECK DECK=CTM$DFT_DBD_LOWER_8XX_CLASS EXPAND=TRUE
          IDENT  DBD1
          CIPPU  J
          MEMSEL 16
          TITLE  CTM$DFT DBD LOWER 8XX CLASS (DBD1).
          COMMENT *SMD* LVL=11
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992

*         WORD 0 OF THE DFT BUFFER DEFINITION

          CON    2           NUMBER OF HEADER WORDS
          CON    0           SECONDARY DFT BUFFER SIZE
          CON    0           MODEL DEPENDENT BUFFER SIZE
          CON    0#34F       MAXIMUM SIZE OF THE DFT BUFFER AREA

*         WORD 1 OF THE DFT BUFFER DEFINITION

          CON    0#4446
          CON    0#5453
          CON    0,0

*         WORD 2 OF THE DFT BUFFER DEFINITION

          CON    0#4446
          CON    0#5445
          CON    0,0

*         DEFINE THE MAINFRAME ELEMENT COUNTERS (CPU0, CPU1, IOU0, CM, DFT INTERNAL ERRORS)

          CON    0#0000
          CON    0#1000
          CON    0#0200
          CON    0#0100

*         WORD 4 OF THE DFT BUFFER DEFINITION

          CON    0#0400
          CON    0#FF
          CON    0
          CON    0

*         WORD 5 OF THE DFT BUFFER DEFINITION DFT CONTROL WORD

          CON    0#0F01
          CON    0#700
          CON    0#0F11
          CON    0

*         WORD 6 STARTS THE DFT POINTER LENGTHS FIRST IS SECDED ID TABLE

          CON    0,0,0,0#A

*         WORD 7 IS MAINTENANCE REGISTER BUFFER POINTER

          CON    0,0,0,0#FF

*         WORD 8 IS THE MODEL DEPENDENT BUFFER POINTER

          CON    0,0,0,0

*         WORD 9 IS THE VE REQUEST POINTER

          CON    0,0,0,0

*         WORD 10 IS THE 170 PP RESIDENT POINTER

          CON    0,0,0,0

*         WORD 11 IS THE 170 0S REQUEST POINTER

          CON    0,0,0,0

*         WORD 12 IS THE MRB CONTROL WORDS POINTER

          CON    0,0,0,0#11

*         WORD 13 IS THE MAINFRAME ELEMENT COUNTERS BUFFER POINTER

          CON    0,0,0,5

*         WORD 14 IS THE ERROR CONTROL RECORD POINTER

          CON    0,0,0,0#1F

*         WORD 15 IS THE SUPPORTIVE STATUS BUFFER POINTER

          CON    0,0,0#7,0#78

*         WORD 16 IS THE NON REGISTER SUPPORTIVE STATUS POINTER

          CON    0,0#B,0#11,0#BC

*         WORD 17 IS THE DFT CM RESIDENT POINTER

          CON    0,0,0,0#64

*         WORD 18 IS THE DFT PP REGISTER SAVE AREA

          CON    0,0,0,0#56

*         WORD 19 IS THE SECONDARY DFT BUFFER POINTER.

          CON    0,0,0,0

          END
/EOR
*DECK DECK=CTM$DFT_DBD_UPPER_8XX_CLASS EXPAND=TRUE
          IDENT  DBD3
          CIPPU  J
          MEMSEL 16
          TITLE  CTM$DFT DBD UPPER 8XX CLASS (DBD3).
          COMMENT *SMD* LVL=11
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992

*         WORD 0 OF THE DFT BUFFER DEFINITION

          CON    2           NUMBER OF HEADER WORDS
          CON    0           SECONDARY DFT BUFFER SIZE
          CON    0           MODEL DEPENDENT BUFFER SIZE
          CON    0#49B       MAXIMUM SIZE OF THE DFT BUFFER AREA

*         WORD 1 OF THE DFT BUFFER DEFINITION

          CON    0#4446
          CON    0#5453
          CON    0,0

*         WORD 2 OF THE DFT BUFFER DEFINITION

          CON    0#4446
          CON    0#5445
          CON    0,0

*         DEFINE THE MAINFRAME ELEMENT COUNTERS (CPU0, CPU1, IOU0, IOU1, CM, DFT INTERNAL)

          CON    0#0000
          CON    0#1000
          CON    0#0200
          CON    0#1200

*         WORD 4 OF THE DFT BUFFER DEFINITION

          CON    0#0100
          CON    0#0400
          CON    0#FF
          CON    0

*         WORD 5 OF THE DFT BUFFER DEFINITION DFT CONTROL WORD

          CON    0#0F01
          CON    0#700
          CON    0#1911
          CON    0

*         WORD 6 STARTS THE DFT POINTER LENGTHS FIRST IS SECDED ID TABLE

          CON    0,0,0,0#A

*         WORD 7 IS MAINTENANCE REGISTER BUFFER POINTER

          CON    0,0,0,0#1A9

*         WORD 8 IS THE MODEL DEPENDENT BUFFER POINTER

          CON    0,0,0,0

*         WORD 9 IS THE VE REQUEST POINTER

          CON    0,0,0,0

*         WORD 10 IS THE 170 PP RESIDENT POINTER

          CON    0,0,0,0

*         WORD 11 IS THE 170 0S REQUEST POINTER

          CON    0,0,0,0

*         WORD 12 IS THE MRB CONTROL WORDS POINTER

          CON    0,0,0,0#11

*         WORD 13 IS THE MAINFRAME ELEMENT COUNTERS BUFFER POINTER

          CON    0,0,0,6

*         WORD 14 IS THE ERROR CONTROL RECORD POINTER

          CON    0,0,0,0#25

*         WORD 15 IS THE SUPPORTIVE STATUS BUFFER POINTER

          CON    0,0,0#7,0#78

*         WORD 16 IS THE NON REGISTER SUPPORTIVE STATUS POINTER

          CON    0,0#B,0#11,0#BC

*         WORD 17 IS THE DFT CM RESIDENT POINTER

          CON    0,0,0,0#64

*         WORD 18 IS THE DFT PP REGISTER SAVE AREA

          CON    0,0,0#78,0#F1

*         WORD 19 IS THE SECONDARY DFT BUFFER POINTER.

          CON    0,0,0,0

          END
/EOR
*DECK DECK=CTM$DFT_ECR_835_CLASS EXPAND=TRUE
          IDENT  ECR2
          CIPPU  J
          MEMSEL 16
          TITLE  CTM$DFT ECR 835 CLASS (ECR2).
          COMMENT *SMD* LVL=11
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992

*         DEFINE THE HEADER WORD FOR THE ERROR CONTROL RECORD

          CON    0,0,6,4

*         DEFINE THE IOU ELEMENT

          CON    0#2,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE CPU ELEMENT

          CON    0,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE CENTRAL MEMORY ELEMENT

          CON    1,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE DFT INTERNAL ERRORS ELEMENT

          CON    4,0,0,0
          CON    0,0,32,32
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          END
/EOR
*DECK DECK=CTM$DFT_ECR_930_CLASS EXPAND=TRUE
          IDENT  ECR0
          CIPPU  J
          MEMSEL 16
          TITLE  CTM$DFT ECR 930 CLASS (ECR0).
          COMMENT *SMD* LVL=11
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992

*         DEFINE THE HEADER WORD FOR THE ERROR CONTROL RECORD

          CON    0,0,6,6

*         DEFINE THE IOU ELEMENT

          CON    0#2,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE CPU ELEMENT

          CON    0,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE CPU 1 ELEMENT

          CON    0#10,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE PAGE MAP ELEMENT

          CON    0#3,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE CENTRAL MEMORY ELEMENT

          CON    1,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE DFT INTERNAL ERRORS ELEMENT

          CON    4,0,0,0
          CON    0,0,32,32
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          END
/EOR
*DECK DECK=CTM$DFT_ECR_960_CLASS EXPAND=TRUE
          IDENT  ECR5
          CIPPU  J
          MEMSEL 16
          TITLE  CTM$DFT ECR 960 CLASS (ECR5).
          COMMENT *SMD* LVL=11
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992

*         DEFINE THE HEADER WORD FOR THE ERROR CONTROL RECORD

          CON    0,0,6,6

*         DEFINE THE IOU ELEMENT

          CON    0#2,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE IOU1 ELEMENT

          CON    0#12,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE CPU ELEMENT

          CON    0,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE CPU 1 ELEMENT

          CON    0#10,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE CENTRAL MEMORY ELEMENT

          CON    1,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE DFT INTERNAL ERRORS ELEMENT

          CON    4,0,0,0
          CON    0,0,32,32
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          END
/EOR
*DECK DECK=CTM$DFT_ECR_990_CLASS EXPAND=TRUE
          IDENT  ECR4
          CIPPU  J
          MEMSEL 16
          TITLE  CTM$DFT ECR 990 CLASS (ECR4).
          COMMENT *SMD* LVL=11
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992

*         DEFINE THE HEADER WORD FOR THE ERROR CONTROL RECORD

          CON    0,0,6,6

*         DEFINE THE IOU ELEMENT

          CON    0#2,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE SECONDARY IOU ELEMENT

          CON    0#12,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE CPU ELEMENT

          CON    0,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE CPU 1 ELEMENT

          CON    0#10,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE CENTRAL MEMORY ELEMENT

          CON    1,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE DFT INTERNAL ERRORS ELEMENT

          CON    4,0,0,0
          CON    0,0,32,32
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          END
/EOR
*DECK DECK=CTM$DFT_ECR_LOWER_8XX_CLASS EXPAND=TRUE
          IDENT  ECR1
          CIPPU  J
          MEMSEL 16
          TITLE  CTM$DFT ECR LOWER 8XX CLASS (ECR1).
          COMMENT *SMD* LVL=11
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992

*         DEFINE THE HEADER WORD FOR THE ERROR CONTROL RECORD

          CON    0,0,6,5

*         DEFINE THE IOU ELEMENT

          CON    0#2,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE CPU ELEMENT

          CON    0,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE CPU 1 ELEMENT

          CON    0#10,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE CENTRAL MEMORY ELEMENT

          CON    1,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE DFT INTERNAL ERRORS ELEMENT

          CON    4,0,0,0
          CON    0,0,32,32
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          END
/EOR

*DECK DECK=CTM$DFT_ECR_UPPER_8XX_CLASS EXPAND=TRUE
          IDENT  ECR3
          CIPPU  J
          MEMSEL 16
          TITLE  CTM$DFT ECR UPPER 8XX CLASS (ECR3).
          COMMENT *SMD* LVL=11
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992

*         DEFINE THE HEADER WORD FOR THE ERROR CONTROL RECORD

          CON    0,0,6,6

*         DEFINE THE IOU ELEMENT

          CON    0#2,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE IOU1 ELEMENT

          CON    0#12,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE CPU ELEMENT

          CON    0,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE CPU 1 ELEMENT

          CON    0#10,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE CENTRAL MEMORY ELEMENT

          CON    1,0,0,0
          CON    0,0,32,256
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0

*         DEFINE THE DFT INTERNAL ERRORS ELEMENT

          CON    4,0,0,0
          CON    0,0,32,32
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          CON    0,0,0,0
          END
/EOR
*DECK DECK=CTM$DFT_LOWER_8XX_CLASS EXPAND=TRUE
          IDENT  DFT1,70B
          CIPPU  J
          MEMSEL 16
          BASE   MIXED
          TITLE  CTM$DFT LOWER 8XX CLASS (DFT1).
          COMMENT *SMD* LVL=11
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 DFT      SPACE  4,10
***       DFT - DEDICATED FAULT TOLERANCE.
*         B. R. HANSON.      82/06/21. (PRECURSOR KNOWN AS SMU)
*         G. J. FALCONER.    85/08/05. (DFT V1.0)
*         G. J. FALCONER.    86/02/27. (DFT V2.0)
 DFT      SPACE  4,10
***       DFT PERFORMS:
*
*         1) CAPTURING THE CONTENT OF MAINFRAME MAINTENANCE REGISTERS
*         FOR ERROR LOGGING, AND CLEARING HARDWARE ELEMENT ERRORS.
*
*         3) THE ACTUAL SEQUENCE OF STEPS TO DEADSTART THE SYSTEM FROM
*         C170 STATE OPERATION TO DUAL-STATE OPERATION OR TO RETURN IT TO
*         STANDALONE C170 OPERATION.  THIS IS PERFORMED UPON THE REQUEST
*         OF THE PP BOOT (*VPB* STATE OF *SCI*).
*
*         4) PROVIDING EXTERNALIZATIONS OF *2AP* FUNCTIONS TO NOS/VE.
 CONTROL  SPACE  4,10
**        ASSEMBLY PARAMETERS.


 PRGM     SET    2           SET *OVERLAY* MACRO TO *DFT* NAMES
 PPTYPE   EQU    0           TURN ON TRACKING OF UPPER/LOWER PP
*STEP$    SET    1           ASSEMBLE *STEP* CODE IF SYMBOL DEFINED
          LIST   X
*COPY     CTP$DFT_RELEASE_HISTORY
*COPY     CTH$DEDICATED_FAULT_TOLERANCE
          LIST   *
 COMMON   SPACE  4,10
**        COMMON DECKS.
*COPYC DSI$PP_MACROS
*COPYC DSI$MAINTENANCE_REGISTER_MACROS
*COPYC CTI$COMPASS_OS_LEVELS
*COPYC CTC$DFT_MACROS
          LIST   X
*COPYC CTC$DFT_DIRECT_CELLS
          LIST   *
*COPYC CTI$DFT_ANALYSIS_CODES
*COPY DSC$PP_MR_AND_TPM_CONSTANTS
*COPY CTC$DFT_CONSTANTS
*COPY CTC$DFT_ACTION_NO_OVERFLOW
*COPY DSA$HARDWARE_TABLE_DEFINITIONS
*COPY DSA$VE_REQUESTS_TO_DFT
*COPY DSI$PP_INSTRUCTION_MNEMONICS
*COPY CTC$EI_CONTROL_BLOCK
          LIST   *

**        START DEFINITION OF THE MAIN LOOP OF DFT.
*
*         THE LOWER 8XX CYBERS REQUIRE EICB UPDATE CODE

*COPYC CTP$DFT_MAIN_LOOP
*COPYC CTP$DFT_MAIN_LOOP_UPDATE_TIME
*COPYC CTP$DFT_MAIN_LOOP_DUAL_STATE
*COPYC CTP$DFT_MAIN_LOOP_NO_PACKETS
 CRN      SPACE  4,10
**        CRN - CHECK RELOCATION NECESSARY
*
*         STUB ON A 810,815,825,830

 CRN      SUBR               ENTRY/EXIT
          UJN    CRNX
 CPC      SPACE  4,10
**        CPC - CHECK FOR PACKET COMMUNICATION
*
*         STUB ON 810,815,825,830

 CPC      SUBR               ENTRY/EXIT
          UJN    CPCX

**        END OF DFT MAIN LOOP DEFINITIONS

*COPYC CTC$DFT_GLOBAL_DATA
*COPYC CTC$DFT_GLOBAL_DATA_NON_S0
 CELCW    CON    0           IGNORED ON 810,815,825,830
 CRFL     CON    0           COST REDUCED MODEL FLAG (810,830)
          LIST   X
*COPYC CTP$DFT_RESIDENT_COMMON
*COPYC CTP$DFT_RESIDENT_ECM_NON_S0
*copy dsi$find_cip_module
*copy dsi$get_hardware_element
*COPYC CTP$MR_PROTOCOL_PREPROCESS_S1
*COPYC CTP$MR_RETRY_OPERATION_FOR_DFT
*COPYC CTP$MR_PROTOCOL_PROCESS
*COPYC CTP$MR_PROTOCOL_POSTPROCESS
*copy DSI$PP_UTILITY_SUBROUTINES
          USE    PRESET
          QUAL   PRESET
*COPYC CTP$DFT_PRESET
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_PRESET_NON_DUAL_I4
 SPO      SPACE  4,10
**        SPO - SETUP MEMORY PORT OFFSET.
*
*         EXIT   PO IS SET TO THE MODEL DEPENDENT PORT OFFSET.
*
*         USES   PO.


 SPO      SUBR               ENTRY/EXIT
          LDN    1           SETUP MEMORY PORT OFFSET
          STD    PO
          UJN    SPOX        RETURN
          USE    *
          QUAL   *
          OVERLAY  (RESIDENT PART II),R2ORG
          QUAL   *
*COPYC CTP$DFT_RESIDENT_II_NON_990
*COPYC CTP$DFT_RESIDENT_II_COMMON
*COPYC CTP$DFT_NON_930_RESIDENT_II
*COPYC DSI$PACK_UNPACK_REGISTERS
*COPYC DSI$VALIDATE_PP_BOUNDS
          USE    OVERFLOW
          ERRNG  10000-*     RESIDENT II OVERFLOWS PP
*COPYC CTP$DFT_PRESET_BUILD_STRUCTURE
          OVERLAY (STANDARD PRESET OVERLAY ROUTINES
*COPYC CTP$DFT_PRESET_STANDARD_OVL
*COPY CTP$DFT_RETURN_ERROR_CODE
 SSO      SPACE  4,10
**        SSO - PRESET  SPECIAL OVERLAY FOR IOU BIT 57 ERROR.
*         NON OPERATIONAL HERE.


 SSO      SUBR
          UJN    SSOX        RETURN
          LIST   *
 SMV      SPACE  4,10
**        SMV - SETUP MODEL DEPENDENT VALUES.
*
*         *SMV* WILL SET UP REGISTER LIST ADDRESSES ON A MODEL DEPENDENT BASIS, AND
*         WILL INITIALIZE ALL MODEL DEPENDENT GLOBAL DATA.


 SMV      SUBR               ENTRY/EXIT
          LDC    SXIU        UNCORRECTED REG LIST FOR IOU
          STM    IO0U        SAVE LIST ADDRESS
          STM    IO0C
          LDC    SXMA        COMPLETE REGISTER LIST FOR MEMORY ERRORS
          STM    ME0U        UNCORRECTED MEMORY ERROR LIST
          STM    ME0C        CORRECTED MEMORY ERROR LIST
          LDM    CPU0M
          LMN    0#14
          ZJN    SMV10       IF 810
          LMN    0#13&0#14
          NJN    SMV20       IF NOT 830
 SMV10    LDN    1
          STM    CRFL        SET COST REDUCED FLAG
          LDC    S1CC
          STM    CP0C        CORRECTED ERROR LIST
          STM    CP1C        SAME FOR CPU 1
          LDC    S1CU
          STM    CP0U        UNCORRECTED ERROR LIST
          STM    CP1U        SAME FOR CPU 1
          UJN    SMV30

 SMV20    LDC    S1PC
          STM    CP0C        CORRECTED ERROR LIST
          LDC    S1PU
          STM    CP0U        UNCORRECTED ERROR LIST
 SMV30    LJM    SMVX

          LIST   X
*COPY     CTP$DFT_NO_CLEAR_PACKETS
*COPYC CTP$DFT_PRESET_NON_PACKETS
          LIST   *
          OVERLAY  (MAIN NON-RESIDENT ROUTINES)

**        START OF THE MAIN NON RESIDENT ROUTINES OVERLAY. ON CYBER 930
*         THIS OVERLAY DEFINES ROUTINES FOR PACKETS, NON I4,
*         HALT ON ERROR PROCESSING, EICB TIME UPDATE, AND PACKET COMMUNICATION.



*COPYC CTP$DFT_MAIN_NON_RES_RTNS
          LIST   X
*COPYC CTP$DFT_MAIN_NON_RES_NON_I4
*COPYC CTP$DFT_MAIN_NON_RES_EICB_TIME
*COPYC CTP$DFT_MAIN_NON_RES_DUAL_STATE
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPY CTP$DFT_PREPARE_FOR_CIP_CALL
*COPYC CTP$DFT_CPU_HANDSHAKER
 BCA      SPACE  4,10
**        BCA - HANDLE BLOCKED CM ACCESS.
*         THIS IS VALID ON A MODEL 44,43 IOU ONLY. (STUB HERE)
          QUAL   HB57


 BCA      SUBR
          UJN    BCAX        RETURN
          QUAL   *

 HOE      SPACE  4,10
**        HOE - HALT ON ERROR
*
*         STUB ON AN S1


          ROUTINE HOE
          LJM    HOEX

 RED      SPACE  4,10
**        RED - READ 960 POWER MONITOR.
*
*         ON ANY MACHINE OTHER THAN THE 960 THIS ROUTINE IS
*         NON FUNCTIONAL.


          ROUTINE RED
          LJM    REDX
          LIST   *
          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DO DFT ACTIONS)
          LIST   X
*COPYC CTP$DFT_ACTION_LIST
*COPYC CTP$DFT_ACTION_LIST_OVERFLOW
*COPYC CTP$DFT_ACTION_LIST_DUAL_STATE
*COPYC CTP$DFT_RETURN_TASK_ERROR
          LIST   *
 IAPP     BSS    0           NOT USED ON 810,815,825,830
          TASK   (RRE)

 DDCM     BSS    0           CLEAR CM ERROR
          TASK   (CCE)

 CEP1     BSS    0           CLEAR P1 ERRORS
          TASK   (CP1)
          QUAL   *
          QUAL   *
          QUAL   ABC
*COPY CTP$DFT_RETURN_ERROR_CODE
          QUAL   *
          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          LIST   X
          OVERLAY (SAVE PP REGISTERS IN CENTRAL MEMORY)
*COPYC CTP$DFT_SAVE_PP_REGISTERS
*COPY  CTP$DFT_DUMP_PP_REGISTERS
*COPY  DSI$DUMP_LOAD_IDLE_PP
          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY (DFT ERROR CONTROL OVERLAY)
*COPYC CTP$DFT_ERROR_CONTROL

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY (LOG TOP OF HOUR COUNTERS)

*COPYC CTP$DFT_LOG_COUNTERS
 RMC      SPACE  4,10
**        RMC - RESET MODEL DEPENDENT COUNTERS.
*


          ROUTINE RMC        ENTRY/EXIT
          LJM    RMCX

 RMCF     CON    0
*COPY     CTP$DFT_NO_RESET_PIT
*COPY     CTP$DFT_NO_TEST_DLD_PATH

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (ENVIRONMENT/SHORT WARNING PROCESSORS)

**        THIS OVERLAY HAS A STUBBED REFERENCE TO CHECK IF THE CONSOLE IS ALIVE.
*         ON CYBER 990 THIS MECHANISM IS NOT USED. THE STUB REPORTS THE CONSOLE IS ALIVE.

*COPYC CTP$DFT_ENVIRONMENT_RTNS
*COPY  CTP$DFT_FIND_WARNING_IN_NRSB
 CCA      SUBR
          LDN    1
          UJN    CCAX        REPORT CONSOLE ALIVE ON NON S0 MACH.
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          LIST   *
          OVERLAY  (ANALYSE PROCESSOR ERRORS)
 APE      SPACE  4,10
**        APE - ANALYSE PROCESSOR ERRORS.
*
*         CALLS  BRL, CID, CLR, PAC, SCS, SSE, *CFF*, *LOG*, *RMR*, *STP*, *SWP*.


          ROUTINE APE

          LDN    0
          STM    NERR        SET NO ERROR FLAG FALSE

*         IT IS NECESSARY TO SAVE THE PRE-HALT STATUS SUMMARY BECAUSE
*         HALTING THE PROCESSOR WILL SET THIS BIT.

          LDM    SUMS        SUMMARY STATUS
          STM    OLSS        SAVE PRE-HALT PROCESSOR SUMMARY STATUS
          SHN    21-SSSW     SHORT WARNING
          PJN    APE0        IF NO SHORT WARNING
          CALL   SWP         CALL SHORT WARNING PROCESSOR
          LJM    APEX        RETURN

 APE0     RJM    CTE         CHECK THRESHOLD EXCEEDED
          NJP    APEX        IF THRESHOLD EXCEEDED IGNORE ERROR
          CALL   CFF         CHECK FOR FREEZE
          LDM    RTP2
          ZJN    APE0.5      IF NOT TO IGNORE ERROR
          LDN    0
          STM    DFTA        NO ACTION
          STM    REGI        RESET REGISTER LIST INDEX
          UJP    APEX

 APE0.5   LDN    0
          RJM    SCS         SAVE PRE-HALT CONTROL STORE ADDRESS
          CALL   STP         CALL STOP PROCESSOR
          LDM    CPUO
          STM    CPUH        HALTED CPU ORDINAL
          LDN    1
          RJM    SCS         SAVE AFTER HALT CONTROL STORE ADDRESS

*         DISABLE *PFS* AND BLOCK EXCHANGE REQUEST BITS SET IN *DEC*.

          LDN    BC
          RJM    CLR
          LDM    OLSS
          SHN    21-SSPH     PROCESSOR HALT IN SUMMARY STATUS
          PJP    APE7        IF PROCESSOR NOT HALTED
          LDM    CPUH        CPU ORDINAL
          NJN    APE1        IF CPU 1
          LDML   CP0CC       CPU 0 CONNECT CODE
          UJN    APE2

 APE1     LDML   CP1CC       CPU 1 CONNECT CODE
 APE2     STDL   EC
          LDML   CSAR
          STDL   RN
          READMR RDATA
          RJM    PAC         PACK REGISTER TO *MRVAL*
          LDML   MRVAL+3
          LMC    0#185
          ZJN    APE3        IF CLASS II ERROR UCR/MCR HALT
          LMN    0#189&0#185
          ZJN    APE3        IF CLASS II ERROR TRAP EXECEPTION IN MONITOR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = PROCESSOR HALT CLASS I.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).

          SETDAC DDDC
          SETDAN (EPUN,DAPH)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          UJN    APE4

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = PROCESSOR HALT CLASS II.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).

 APE3     SETDAC DDDC
          SETDAN (EPUN,DASWH)
          SETFLG (BC.FV7,BC.FV8,BC.FL)

 APE4     LDM    CPUH        GET ORDINAL OF CPU BEING PROCESSED
          NJN    APE5
          LDM    CP0U        GET UNCORRECTED REGISTER LIST FOR CPU0
          UJN    APE6        CONTINUE

 APE5     LDM    CP1U        GET UNCORRECTED REGISTER LIST FOR CPU1
 APE6     RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          LJM    APE16       CONTINUE PROCESSING

 APE7     LDM    SUMS        SUMMARY STATUS
          SHN    21-SSUE     UNCORRECTED ERROR
          PJP    APE10       IF NOT UNCORRECTED ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED PROCESSOR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).
*         DFT ANALYSIS - OS ACTION = UNCORRECTED PROCESSOR ERROR.
*                                  = NO OS ACTION (VERSION 4).

          SETDAN (EPUN,DAUPE)
          SETFLG (BC.FL)
          SETOSA OSUPE,OSNA
          LDM    CPUH        GET ORDINAL OF CPU BEING PROCESSED
          NJN    APE8
          LDM    CP0U        GET UNCORRECTED REGISTER LIST FOR CPU0
          UJN    APE9        CONTINUE

 APE8     LDM    CP1U        GET UNCORRECTED REGISTER LIST FOR CPU1
 APE9     RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          LJM    APE16       CONTINUE PROCESSING

 APE10    LDM    SUMS        SUMMARY STATUS
          SHN    21-SSCE     CORRECTED ERROR
          PJP    APE13       IF NOT CORRECTED ERROR
          LDM    OLSS        GET SAVED STATUS SUMMARY
          SHN    21-SSPH
          MJP    APE13       IF PROCESSOR HALT

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CORRECTED PROCESSOR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAN (EPCO,DACPE)
          SETFLG (BC.FL)
          LDM    CPUH        GET ORDINAL OF CPU BEING PROCESSED
          NJN    APE11
          LDM    CP0C        GET CORRECTED REGISTER LIST FOR CPU0
          UJN    APE12       CONTINUE

 APE11    LDM    CP1C        GET CORRECTED REGISTER LIST FOR CPU1
 APE12    RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          LJM    APE16       CONTINUE PROCESSING


*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED PROCESSOR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).
*         DFT ANALYSIS - OS ACTION = UNCORRECTED PROCESSOR ERROR.
*                                  = NO OS ACTION (VERSION 4).

 APE13    SETDAN (EPUN,DAUPE)
          SETFLG (BC.FL)
          SETOSA OSUPE,OSNA
          LDM    CPUH        GET ORDINAL OF CPU BEING PROCESSED
          NJN    APE14       IF CPU1
          LDM    CP0U        GET UNCORRECTED REGISTER LIST FOR CPU0
          UJN    APE15       CONTINUE

 APE14    LDM    CP1U        GET UNCORRECTED REGISTER LIST FOR CPU1
 APE15    RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS

 APE16    BSS    0           P1 PROCESSING
          LDM    DFTA        DFT ACTION POINTER
          LMC    DDDC        CHECK ACTION
          ZJP    APE18       IF DISABLE CPU
          SETDAC (CEP1)

 APE18    LDM    CPUO
          RJM    SSE         SET SECONDARY ELEMENT IDENTIFIER
          RJM    CID         CHECK IF CPU DEGRADABLE
          CALL   LOG
          LJM    APEX        RETURN

 APEA     CON    0           CPU 0 ID
          CON    0#10        CPU 1 ID

*COPY CTP$DFT_SAVE_CONTROL_STORE
*COPY     CTP$DFT_CHECK_DEGRADABLE_CPU
*COPY CTP$DFT_CHECK_CPU_THRESHOLD

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY (ANALYZE IOU ERRORS
          QUAL
*COPYC CTP$DFT_ANALYZE_IOU_ERRORS
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (ANALYSE MEMORY ERRORS)
 AME      SPACE  4,10
**        AME - PROCESS MEMORY ERRORS.
*
*         CALLS  CLR, GSC, FMB, *CFF*, *LOG*, *SME*.


          ROUTINE AME

          LDN    0
          STM    RLST        CORRECTED ERROR FLAG
          STM    NERR        SET NO ERROR FLAG FLAG
          STML   SBER
          STML   SBER+1
          STML   SYCD
          LDN    BC
          RJM    CLR         ZERO SCRATCH BUFFER
          LDM    SUMS        SUMMARY STATUS
          SHN    21-SSUE
          PJP    AME1        IF NOT UNCORRECTED
          READMR RDATA,CMCC,MUL1
          LDM    RDATA
          LPC    0#80
          ZJP    AMEX        IF NOT VALID ERROR
          LDM    RDATA
          LPN    0#08
          ZJP    AME0.1      IF NOT PARTIAL WRITE PARITY ERROR
          LDM    RDATA
          LPN    6           CHECK BITS 5 AND 6
          NJP    AME0.1      IF NO PARTIAL WRITE PARITY ERROR


*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = PARTIAL WRITE PARITY ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR MEMORY ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).
*         DFT ANALYSIS - OS ACTION = MULTIPLE ODD BIT ERROR
                                   = STEP SYSTEM (VERSION 4)
          SETDAC DDCM
          SETDAN (EPUN,DAPWP)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          SETOSA OSMOB,OSSS
          UJP    AME0.2      LOG THIS ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED CM ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR MEMORY ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).
*         DFT ANALYSIS - OS ACTION = UNCORRECTED MEMORY ERROR.
*                                  = NO OS ACTION (VERSION 4).

 AME0.1   SETDAC DDCM
          SETDAN (EPUN,DAUME)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          SETOSA OSUCM,OSNA
 AME0.2   LDM    ME0U        UNCORRECTED MEMORY REGISTER LIST
          RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          CALL   CFF         CHECK FOR FREEZE
          LDM    RTP2
          ZJN    AME0.3      IF NOT TO IGNORE ERROR
          LDN    0
          STM    DFTA        NO ACTION
          STM    REGI        RESET REGISTER LIST INDEX
          UJN    AME0

 AME0.3   CALL   LOG
 AME0     LJM    AMEX        RETURN

 AME1     LDM    SUMS
          SHN    21-SSCE
          PJN    AME0        IF NOT A CORRECTED ERROR
          LDN    1
          STM    RLST        SET CORRECTED ERROR LIST FLAG

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CORRECTED CM ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR MEMORY ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAC DDCM
          SETDAN (EPCO,DACME)
          SETFLG (BC.FL)
          LDM    ME0C        CORRECTED MEMORY ERROR REGISTERS
          RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          CALL   CFF
          LDM    RTP2
          ZJN    AME1.5      IF NOT TO IGNORE ERROR
          LDN    0
          STM    DFTA        NO ACTION
          STM    REGI        RESET REGISTER LIST INDEX
          UJP    AMEX

*         IN THE MODEL-DEPENDENT ROUTINES THAT FOLLOW
*         THE SYNDROME CODE AND THE ADDRESS BITS ARE
*         OBTAINED FROM THE CORRECTED ERROR LOG REGISTER
*         AND ARE STORED AT *SYCD* AND *SBER* RESPECTIVELY.

 AME1.5   LDM    CRFL        COST REDUCED FLAG
          ZJP    AME8

*         PROCESS CYBER 810/830 MEMORY ERRORS.

 AME2     RJM    GSC         GET SYNDROME CODE
          LDDL   W1
          STML   SBER+1      SAVE LOWER PORTION OF ADDRESS
          LDDL   W0
          LPC    0#1FF
          STML   SBER        SAVE UPPER PORTION OF ADDRESS
          CALL   SME         SERVICE MEMORY ERROR
          LJM    AMEX        RETURN

*         PROCESS CYBER 815/825 MEMORY ERRORS.

 AME8     RJM    GSC
          LDN    OIMR
          RJM    FMB
          CRDL   CM          GET OPTIONS INSTALLED
          LDDL   CM
          SHN    21-3
          MJN    AME9        IF 16 OR 32 MEGABYTES SET
          LDDL   W0
          LPN    7
          SHN    13D
          STML   SBER+1
          LDDL   W0
          LPC    0#FF
          SHN    -3
          STML   SBER
          LDDL   W1
          SHN    -3
          LMML   SBER+1
          STML   SBER+1
          CALL   SME
          LJM    AMEX        RETURN

 AME9     LDDL   W0
          LPC    0#FF
          STML   SBER
          LDDL   W1
          STML   SBER+1
          CALL   SME
          LJM    AMEX        RETURN

 GSC      SPACE  4,10
**        GSC - GET SYNDROME CODE.
*
*         ENTRY  (W0 - W3) = PROPER *CEL* REGISTER.
*
*         EXIT   (SYCD) = SYNDROME CODE.
*
*         USES   W0 - W3, *SYCD*.


 GSC      SUBR               ENTRY/EXIT
          LDN    0
          STM    SYCD

*         PROCESS CYBER 810/815/825/830 SYNDROME CODE.

          LDC    MCEL
          RJM    FMB
          CRDL   W0
          LDDL   W0
          SHN    21-17
          PJP    AMEX        IF NOT VALID BIT
          LDDL   W2          GET SYNDROME
          SHN    -8D
          STM    SYCD
          LJM    GSCX        RETURN
          LIST   X
*COPY CTP$DFT_SERVICE_MEMORY_ERROR
*COPY CTP$DFT_REWRITE_CM_ERROR
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (LOG ERRORS TO CENTRAL MEMORY BUFFERS)

**        ON CYBER 990 THERE IS SPECIAL HANDLING OF COMPARING MULTIPLE
*         RETRY ERRORS.

*COPYC CTP$DFT_LOG_ERROR
*COPY CTP$DFT_FIND_CONTROL_WORD
*COPY CTP$DFT_INCREMENT_ERROR_COUNT
*COPY CTP$DFT_LOG_ERROR_CHECK_MATCH
*COPYC CTP$DFT_LOG_ERROR_NON_990
*COPYC CTP$DFT_LOG_ERROR_NO_CONSOLE
*COPY CTP$DFT_ZERO_SUPPORTIVE_STATUS
*COPY  CTC$DFT_ELEMENT_CONVERSIONS
          QUAL    *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (GENERATE FAULT SYMPTOM CODE)

**        LOWER CYBER FAULT SYMPTOM CODES.

*COPYC CTP$DFT_GENERATE_FAULT_SYMPTOM
*COPY     CTP$DFT_GENERATE_NO_I4C_CODES

          ROUTINE I4S
          LJM    I4SX
          ROUTINE I4A
          LJM    I4AX
          ROUTINE I4I
          LJM    I4IX


          QUAL   *

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          LIST   *
          OVERLAY  (READ MAINTENANCE REGISTERS)
          QUAL   *           SO THAT OTHER OVERLAYS MAY ACCESS
 S1CC     SPACE  4,10
**        CYBER 810/830 PROCESSOR CORRECTED ERROR REGISTER LIST.


 S1CC     REGLST (10,00,12,30,93,90,91)
 S1CU     SPACE  4,10
**        CYBER 810/830 PROCESSOR UNCORRECTED ERROR REGISTER LIST.


 S1CU     REGLST (10,00,12,30,80,81)
 S1PC     SPACE  4,10
**        CYBER 815/825 PROCESSOR CORRECTED ERROR REGISTER LIST.


 S1PC     REGLST (10,00,12,30,90,93)
 S1PU     SPACE  4,10
**        CYBER 815/825 PROCESSOR UNCORRECTED ERROR REGISTER LIST.


 S1PU     REGLST (10,00,12,30,80)
 SXMA     SPACE  4,10
**        CYBER 810/815/825/830 MEMORY ERROR REGISTER LIST.


 SXMA     REGLST (10,00,12,20,A0,A4,A8,21)
 SXIU     SPACE  4,10
**        I1/I1CR CORRECTED AND UNCORRECTED IOU ERROR LIST.


 SXIU     REGLST (10,00,12,30,40,80,81,A0,18,21)
          LIST   X
*COPYC CTP$DFT_READ_MAINTENANCE_REGS
 ZSS      SPACE  4,10
**        ZSS - ZERO SUPPORTIVE STATUS.
*
*         NOTE   THIS ROUTINE IS INOPERATIVE ON A CYBER 180-810/815/825/830.


 ZSS      SUBR               ENTRY/EXIT
          UJN    ZSSX        RETURN
          QUAL   *

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          LIST   *
          OVERLAY  (PROCESSOR PRIMITIVES)

*COPY CTP$DFT_PROCESSOR_PRIMITIVES
 CP1      SPACE  4,10
**        CP1 - CLEAR ERRORS FOR P1 PROCESSORS
*
*         CALLS  HEP, *HEO*, *STP*, *STRBTS*.


          ROUTINE CP1

          LDM    HBUF+CPRPC
          STD    EC
          READMR RDATA,,DEMR *DEC* REGISTER
          CALL   STRBTS      SET MODEL-DEPENDENT *DEC* BITS
          WRITMR RDATA
          FUNCMR ,MRCE       CLEAR ERRORS
          CALL   HEO         HALF EXCHANGE OUT
          RJM    HEP         HALF EXCHANGE IN
          CALL   STP         HALT PROCESSOR
          READMR RDATA,,DEMR *DEC* REGISTER
          CALL   STRBTS      SET MODEL-DEPENDENT *DEC* BITS
          WRITMR RDATA
          FUNCMR ,MRCE       CLEAR ERRORS SECOND TIME
          CALL   HEO
          RJM    HEP
          LJM    CP1X        RETURN
 HEP      SPACE  4,10
**        HEP - HALF EXCHANGE IN FOR P1 PROCESSOR.
*
*         CALLS  CLRBTS.
*
*         MACROS FUNCMR, WRITMR.


 HEP      SUBR               ENTRY/EXIT
          LDM    OLSS
          LPN    0#20
          ZJN    HEP1        IF PROCESSOR IN JOB MODE
          LDML   HEIM
          UJN    HEP2        CONTINUE

 HEP1     LDML   HEIJ
 HEP2     STM    HEPB+7
          SHN    -10
          STM    HEPB+6
          FUNCMR HBUF+CPRPC,MRMC   MASTER CLEAR PROCESSOR
          RJM    CLRBTS      CLEAR MODEL-DEPENDENT *DEC* BITS
          WRITMR HEPB,HBUF+CPRPC,PCSA  SET *CSA*
          FUNCMR HBUF+CPRPC,MRSP  START PROCESSOR
          LDC    200D
 HEP3     SBN    1
          NJN    HEP3        DELAY
          LJM    HEPX        RETURN

 HEPB     BSSZ   10

 STRBTS   SPACE  4,10
**        STRBTS - STORE BITS IN *DEC*.


          ROUTINE STRBTS

*         PROCESS CYBER 810/815/825/830.

 SETBTP1  LDM    RDATA+2     SET PRESERVE PP EXCHANGES BIT
          SCN    0#8         PRESERVE PP EXCHANGE BIT
          LMN    0#8
          STM    RDATA+2
          LJM    STRBTSX     RETURN
 CLRBTS   SPACE  4,10
**        CLRBTS - RESTORE MODEL-DEPENDENT BITS IN *DEC*.
*
*         MACROS READMR, WRITMR.


 CLRBTS   SUBR               ENTRY/EXIT
          READMR RDATA,HBUF+CPRPC,DEMR  READ *DEC* REGISTER

*         PROCESS CYBER 810/815/825/830.

 CLRBTP1  LDM    RDATA+2     ENABLE EXCHANGE
          SCN    0#8
          STM    RDATA+2

          WRITMR RDATA,HBUF+CPRPC  REWRITE *DEC* REGISTER
          LJM    CLRBTSX     RETURN
*COPY CTP$DFT_MANAGE_MEMORY_PORT

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (MASSAGE CPU REGISTERS)
*COPY CTP$DFT_MASSAGE_CPU_REGISTERS

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (CLEAR ERRORS)
 CLE      SPACE  4,10
**        CLE - CLEAR ERRORS.
*
*         EXIT   ALL REGISTERS NECESSARY WILL BE CLEARED OF ERRORS.


          ROUTINE CLE

          LDM    HBUF+HDRPC
          STD    EC
          FUNCMR ,MRCE       CLEAR ERRORS FROM *PFS* REGISTERS
          LJM    CLEX        RETURN

 CCE      SPACE  4,10
**        CCE - CLEAR CM ERRORS.
*
*         CALLS  FMB, UPR.


          ROUTINE CCE


*         PROCESS LOWER 8XX MAINFRAMES.

 CCE2     LDM    RLST
          NJP    CCE4.5      IF CORRECTED ERROR

*         CLEAR UNCORRECTED ERROR LOG 1 AND 2.

          LDC    MUL1
          STD    RN
          RJM    FMB         GET MAINTENANCE BUFFER POINTER FOR REGISTER
          CRML   MRVAL,ON
          RJM    UPR         UNPACK TO (RDATA)
          LDM    RDATA
          SHN    21-7
          PJN    CCE4        IF VALID NOT SET
          LDM    RDATA
          LPN    0#3F        SAVE ALL BUT VALID, UNLOGGED BITS
          STM    RDATA
          WRITMR RDATA,HBUF+HDRPC
 CCE4     LDC    MUL2
          STD    RN          SET UP *UEL2* REGISTER
          RJM    FMB
          CRML   MRVAL,ON
          RJM    UPR
          LDM    RDATA
          SHN    21-7
          PJN    CCE4.1      IF VALID NOT SET
          LDM    RDATA
          LPN    0#3F        SAVE ALL BUT VALID, UNLOGGED BITS
          STM    RDATA
          WRITMR RDATA,HBUF+HDRPC
 CCE4.1   LJM    CCEX        RETURN

 CCE4.5   LDC    MCEL
          STD    RN          CORRECTED MEMORY ERROR REGISTER
          RJM    FMB
          CRML   MRVAL,ON
          RJM    UPR
          LDM    RDATA
          SHN    21-7
          PJN    CCE4.1      IF VALID NOT SET
          LDM    RDATA
          LPN    0#3F        SAVE ALL BUT VALID, UNLOGGED
          STM    RDATA
          WRITMR RDATA,HBUF+HDRPC
          LJM    CCEX        RETURN
          QUAL   *
          LIST   X
          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (UPDATE C170 MEMORY)
*COPYC CTP$DFT_UPDATE_170_MEMORY

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_OS_REQUESTS
*COPYC CTP$DFT_OS_REQUESTS_NON_PACKETS
          QUAL   *
          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS - 2)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_REQUEST_PROCESSOR_2

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (PP REQUEST PROCESSOR)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPY  CTP$DFT_PP_UTILITY_REQUESTS
*COPY  CTP$DFT_DUMP_PP_REGISTERS
*COPY  DSI$DUMP_LOAD_IDLE_PP

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (RESTART SCI PP)
 QUAL$    EQU    0
*COPYC CTP$DFT_RESTART_SCI
*COPY  DSI$DUMP_LOAD_IDLE_PP

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DFT ERROR LOGGING ROUTINES)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPY     CTP$DFT_PROCESS_DISK_ERROR

          OVERFLOW  R2ORG
          OVERLAY  (DFT RUN TIME ERROR HANDLING)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_RUN_TIME_ERROR_HANDLER
*copy     ctp$construct_message_in_eicb

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          END
/EOR
*DECK DECK=CTM$DFT_UPPER_8XX_CLASS EXPAND=TRUE
          IDENT  DFT3,70B
          CIPPU  J
          MEMSEL 16
          BASE   MIXED
          TITLE  CTM$DFT UPPER 8XX CLASS (DFT3).
          COMMENT *SMD* LVL=11
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 DFT      SPACE  4,10
***       DFT - DEDICATED FAULT TOLERANCE.
*         B. R. HANSON.      82/06/21. (PRECURSOR KNOWN AS SMU)
*         G. J. FALCONER.    85/08/05. (DFT V1.0)
*         G. J. FALCONER.    86/02/27. (DFT V2.0)
 DFT      SPACE  4,10
***       DFT PERFORMS:
*
*         1) CAPTURING THE CONTENT OF MAINFRAME MAINTENANCE REGISTERS
*         FOR ERROR LOGGING, AND CLEARING HARDWARE ELEMENT ERRORS.
*
*         3) THE ACTUAL SEQUENCE OF STEPS TO DEADSTART THE SYSTEM FROM
*         C170 STATE OPERATION TO DUAL-STATE OPERATION OR TO RETURN IT TO
*         STANDALONE C170 OPERATION.  THIS IS PERFORMED UPON THE REQUEST
*         OF THE PP BOOT (*VPB* STATE OF *SCI*).
*
*         4) PROVIDING EXTERNALIZATIONS OF *2AP* FUNCTIONS TO NOS/VE.
 CONTROL  SPACE  4,10
**        ASSEMBLY PARAMETERS.


 PRGM     SET    2           SET *OVERLAY* MACRO TO *DFT* NAMES
 PPTYPE   EQU    0           TURN ON TRACKING OF UPPER/LOWER PP
 MCH$     EQU    0           DEFINE *MCH* ROUTINE IN DSI$DUMP LOAD IDLE PP
*STEP$    SET    0           ASSEMBLE *STEP* CODE IF SYMBOL DEFINED

          LIST   X
*COPY     CTP$DFT_RELEASE_HISTORY
*COPY     CTH$DEDICATED_FAULT_TOLERANCE
          LIST   *
 COMMON   SPACE  4,10
**        COMMON DECKS.


*COPYC DSI$PP_MACROS
*COPYC DSI$MAINTENANCE_REGISTER_MACROS
*COPYC CTI$COMPASS_OS_LEVELS
*COPYC CTC$DFT_MACROS
*COPYC CTC$DFT_DIRECT_CELLS
*COPYC CTI$CONSOLE_PACKET_DEFINITIONS
*COPYC CTI$DFT_ANALYSIS_CODES
*COPY DSC$PP_MR_AND_TPM_CONSTANTS
*COPY CTC$DFT_CONSTANTS
*COPY CTC$DFT_ACTION_NO_OVERFLOW
*COPY DSA$HARDWARE_TABLE_DEFINITIONS
*COPY DSA$VE_REQUESTS_TO_DFT
          LIST   *
*COPY DSI$PP_INSTRUCTION_MNEMONICS
          LIST   X
*COPY CTC$EI_CONTROL_BLOCK
          LIST   *

**        START DEFINITION OF THE MAIN LOOP OF DFT.
*

*COPYC CTP$DFT_MAIN_LOOP
*COPYC CTP$DFT_MAIN_LOOP_PACKETS
*COPYC CTP$DFT_MAIN_LOOP_UPDATE_TIME
*COPYC CTP$DFT_MAIN_LOOP_DUAL_STATE
 CRN      SPACE  4,10
**        CRN - CHECK RELOCATION NECESSARY
*
*         STUB ON A UPPER 8XX

 CRN      SUBR               ENTRY/EXIT
          UJN    CRNX

**        END OF DFT MAIN LOOP DEFINITIONS

*COPYC CTC$DFT_GLOBAL_DATA
*COPYC CTC$DFT_GLOBAL_DATA_NON_S0
*COPYC CTP$DFT_RESIDENT_COMMON
*COPYC CTP$DFT_RESIDENT_ECM_NON_S0
*copy dsi$find_cip_module
*copy dsi$get_hardware_element
*COPYC CTP$MR_PROTOCOL_PREPROCESS
*COPYC CTP$MR_RETRY_OPERATION_FOR_DFT
*COPYC CTP$MR_PROTOCOL_PROCESS
*COPYC CTP$MR_PROTOCOL_POSTPROCESS
*copy DSI$PP_UTILITY_SUBROUTINES
          USE    PRESET
          QUAL   PRESET
*COPYC CTP$DFT_PRESET
*COPYC CTP$DFT_PRESET_DUAL_I4
*COPY CTP$DFT_RETURN_ERROR_CODE
 SPO      SPACE  4,10
**        SPO - SETUP MEMORY PORT OFFSET.
*
*         EXIT   PO IS SET TO THE MODEL DEPENDENT PORT OFFSET.
*
*         USES   PO.


 SPO      SUBR               ENTRY/EXIT
          LDN    4           SETUP MEMORY PORT OFFSET
          STD    PO
          UJN    SPOX        RETURN
          USE    *
          QUAL   *
          OVERLAY  (RESIDENT PART II),R2ORG
          QUAL   *
*COPYC CTP$DFT_RESIDENT_II_NON_990
*COPYC CTP$DFT_RESIDENT_II_COMMON
*COPYC CTP$DFT_NON_930_RESIDENT_II
*COPYC DSI$PACK_UNPACK_REGISTERS
*COPYC DSI$VALIDATE_PP_BOUNDS

          USE    OVERFLOW
          ERRNG  10000-*     RESIDENT II OVERFLOWS PP
*COPYC CTP$DFT_PRESET_DUAL_I4_OVL
*COPYC CTP$DFT_PRESET_BUILD_STRUCTURE
          OVERLAY (STANDARD PRESET OVERLAY ROUTINES)
*COPYC CTP$DFT_PRESET_STANDARD_OVL
 SSO      SPACE  4,10
**        SSO - PRESET  SPECIAL OVERLAY FOR IOU BIT 57 ERROR.
*         NON OPERATIONAL HERE.


 SSO      SUBR
          UJN    SSOX        RETURN

*COPY CTP$DFT_RETURN_ERROR_CODE
 SMV      SPACE  4,10
**        SMV - SETUP MODEL DEPENDENT VALUES.
*
*         *SMV* WILL SET UP REGISTER LIST ADDRESSES ON A MODEL DEPENDENT BASIS, AND
*         WILL INITIALIZE ALL MODEL DEPENDENT GLOBAL DATA.


 SMV      SUBR               ENTRY/EXIT
          LDC    SXIU        UNCORRECTED REG LIST FOR IOU
          STM    IO0U        SAVE LIST ADDRESS
          STM    IO0C
          LDM    IOUM
          LMN    0#20
          ZJN    SMV10       IF I2 IOU
          READMR RDATA,I0CC,OIMR  I4 PROCESSOR
          LDM    RDATA+7
          SHN    10D         CHECK BIT 56 FOR CIO PP PRESENT
          PJN    SMV10       IF NO CIO PPS PRESENT
          LDC    I4IU
          STM    IO0U        UNCORRECTED REGISTER LIST
          LDC    I4IC
          STM    IO0C        CORRECTED REGISTER LIST
 SMV10    LDC    SXMA        COMPLETE REGISTER LIST FOR MEMORY ERRORS
          STM    ME0U        UNCORRECTED MEMORY ERROR LIST
          STM    ME0C        CORRECTED MEMORY ERROR LIST
          LDC    S3PA        SET CORRECTED/UNCORRECTED REGISTER LISTS FOR CPU0
          STM    CP0C
          STM    CP0U
          LDM    CPU1M       CHECK IF CPU1 PRESENT
          ZJP    SMVX        IF CPU1 NOT PRESENT
          LDC    S3PA        SET CORRECTED/UNCORRECTED REGISTER LISTS FOR CPU1
          STM    CP1C
          STM    CP1U
          LJM    SMVX        RETURN
*COPY     CTP$DFT_CLEAR_PACKETS_I4
*COPYC CTP$DFT_PRESET_PACKETS
          OVERLAY  (MAIN NON-RESIDENT ROUTINES)

**        START OF THE MAIN NON RESIDENT ROUTINES OVERLAY. ON CYBER 835
*         THIS OVERLAY DEFINES ROUTINES FOR DUAL STATE, NON DUAL I4
*         NON HALT ON ERROR PROCESSING, AND NO PACKET COMMUNICATION.



*COPYC CTP$DFT_MAIN_NON_RES_RTNS
*COPY CTP$DFT_SET_SS_DUAL_I4
*COPYC CTP$DFT_MAIN_NON_RES_DUAL_I4
*COPYC CTP$DFT_MAIN_NON_RES_EICB_TIME
*COPYC CTP$DFT_MAIN_NON_RES_DUAL_STATE
*COPY CTP$DFT_CHECK_TPM_PKT_RESPONSE
*COPYC CTP$DFT_MANAGE_PACKET_TRAFFIC
 BCA      SPACE  4,10
**        BCA - HANDLE BLOCKED CM ACCESS.
*         THIS IS VALID ON A MODEL 44, 43 IOU ONLY. (STUB HERE)
          QUAL   HB57


 BCA      SUBR
          UJN    BCAX        RETURN
 BI57     CON    0           DUMMY FLAG
          QUAL   *

 HOE      SPACE  4,10
**        HOE - HALT ON ERROR
*
*         STUB ON AN UPPER 8XX


          ROUTINE HOE
          LJM    HOEX

 ERR      CALL   ROS         REPORT OS ERROR

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (AUX MAIN NON RESIDENT ROUTINES)
*COPYC CTP$DFT_CPU_HANDSHAKER
          ROUTINE ROS
          LJM    ERR
*COPY CTP$DFT_PREPARE_FOR_CIP_CALL
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_LOG_PACKET_TIMEOUT

 RED      SPACE  4,10
**        RED - READ 960 POWER MONITOR.
*
*         ON ANY MACHINE OTHER THAN THE 960 THIS ROUTINE IS
*         NON FUNCTIONAL.


          ROUTINE RED
          LJM    REDX

          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY  (DO DFT ACTIONS)

*COPYC CTP$DFT_ACTION_LIST
*COPYC CTP$DFT_ACTION_LIST_OVERFLOW
*COPYC CTP$DFT_ACTION_LIST_DUAL_I4
*COPYC CTP$DFT_ACTION_LIST_DUAL_STATE

 DDCM     BSS    0           CLEAR CM ERROR
          TASK   (CCE)

 DDCE     BSS    0           CLEAR UPPER 8XX PROCESSOR ERRORS
          TASK   (CLE,SPR)
*COPYC CTP$DFT_RETURN_TASK_ERROR
          QUAL   *
          QUAL   ABC
*COPY CTP$DFT_RETURN_ERROR_CODE
          QUAL   *

          QUAL   *


          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (DFT SEND PACKETS OVERLAY)
*COPYC CTP$DFT_CHECK_PKTS_FOR_NON_S0
*COPYC CTP$DFT_CHECK_PKT_STATUS_NON_S0
*COPYC CTP$DFT_SEND_PACKET_ALL
*COPY  CTP$DFT_SEND_PACKET_FOR_NON_S0
*COPY  CTP$DFT_CLEAR_PACKETS_I4

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY (SAVE PP REGISTERS IN CENTRAL MEMORY)
*COPYC CTP$DFT_SAVE_PP_REGISTERS
*COPY  CTP$DFT_DUMP_PP_REGISTERS
 QUAL$    EQU    1
*COPY  DSI$DUMP_LOAD_IDLE_PP
          OVERFLOW R2ORG     CHECK FOR OVERFLOW
          OVERLAY (DFT ERROR CONTROL OVERLAY)
*COPYC CTP$DFT_ERROR_CONTROL

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY (LOG TOP OF HOUR COUNTERS)

*COPYC CTP$DFT_LOG_COUNTERS
 RMC      SPACE  4,10
**        RMC - RESET MODEL DEPENDENT COUNTERS.
*


          ROUTINE RMC        ENTRY/EXIT
          LJM    RMCX
 RMCF     BSS    0
*COPY     CTP$DFT_RESET_PIT
*COPY     CTP$DFT_TEST_DLD_PATH

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (ENVIRONMENT/SHORT WARNING PROCESSORS)

**        THIS OVERLAY HAS A STUBBED REFERENCE TO CHECK IF THE CONSOLE IS ALIVE.
*         ON CYBER 835 THIS MECHANISM IS NOT USED. THE STUB REPORTS THE CONSOLE IS ALIVE.

*COPYC CTP$DFT_ENVIRONMENT_RTNS
*COPY  CTP$DFT_FIND_WARNING_IN_NRSB
 CCA      SUBR
          LDN    1
          UJN    CCAX        REPORT CONSOLE ALIVE ON NON S0 MACHINE
          QUAL   *

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (ANALYSE PROCESSOR ERRORS)
 APE      SPACE  4,10
**        APE - ANALYSE PROCESSOR ERRORS.
*
*         CALLS  BRL, CID, CFC, CLR, PAC, SCS, SSE, *AP3*, *CFF*, *LOG*, *RMR*,
*                *STP*, *SWP*.


          ROUTINE APE

          LDN    0
          STM    NERR        SET NO ERROR FLAG FALSE

*         IT IS NECESSARY TO SAVE THE PREHALT STATUS SUMMARY BECAUSE
*         HALTING THE PROCESSOR WILL SET THIS BIT.

          LDM    SUMS        SUMMARY STATUS
          STM    OLSS        SAVE PRE-HALT PROCESSOR SUMMARY STATUS
          SHN    21-SSSW     SHORT WARNING
          PJN    APE0        IF NO SHORT WARNING
          CALL   SWP         CALL SHORT WARNING PROCESSOR
          LJM    APEX        RETURN

 APE0     RJM    CTE         CHECK THRESHOLD EXCEEDED
          NJP    APEX        IF THRESHOLD EXCEEDED IGNORE ERROR
          CALL   CFF         CHECK FOR FREEZE
          LDM    RTP2
          ZJN    APE0.5      IF NOT TO IGNORE ERROR
          LDN    0
          STM    DFTA        NO ACTION
          STM    REGI        RESET REGISTER LIST INDEX
          UJP    APEX

 APE0.5   LDN    0
          RJM    SCS         SAVE PRE-HALT CONTROL STORE ADDRESS
          CALL   STP         CALL STOP PROCESSOR
          LDM    CPUO
          STM    CPUH        HALTED CPU ORDINAL
          LDN    1
          RJM    SCS         SAVE AFTER HALT CONTROL STORE ADDRESS

*         DISABLE *PFS* AND BLOCK EXCHANGE REQUEST BITS SET IN *DEC*.

          LDN    BC
          RJM    CLR
          LDM    OLSS
          SHN    21-SSPH     PROCESSOR HALT IN SUMMARY STATUS
          PJP    APE10       IF PROCESSOR NOT HALTED
          LDML   CSAR
          STDL   RN
          LDM    CPUH        CPU ORDINAL
          NJN    APE1        IF CPU 1
          LDML   CP0CC       CPU 0 CONNECT CODE
          UJN    APE2

 APE1     LDML   CP1CC       CPU 1 CONNECT CODE
 APE2     STDL   EC
          READMR RDATA
          LDML   RDATA+7
          LMC    0#49
          ZJN    APE4        IF POSSIBLE CLASS II ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = PROCESSOR HALT CLASS I.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).

 APE3     SETDAC DDDC
          SETDAN (EPUN,DAPH)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          LJM    APE7

 APE4     LDM    OLSS
          LPN    0#20
          ZJN    APE3        IF CLASS I ERROR
          LDM    OLSS
          LPN    4
          NJP    APE3        IF DUE SET THEN CLASS I ERROR
          LDC    PMCR        MONITOR CONDITION REGISTER
          STDL   RN
          READMR RDATA
          RJM    PAC         PACK TO *MRVAL*
          LDML   MRVAL+3
          LPC    0#5B4C
          ZJP    APE3        IF NO MCR BITS SET MUST BE CLASS I
          LDC    PTPE        TRAP ENABLES REGISTER
          STDL   RN
          READMR RDATA
          LDML   RDATA+7
          NJP    APE3        IF CLASS I ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = PROCESSOR HALT CLASS II.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).

          SETDAC DDDC
          SETDAN (EPUN,DASWH)
          SETFLG (BC.FV7,BC.FV8,BC.FL)

 APE7     LDM    CPUH        GET ORDINAL OF CPU BEING PROCESSED
          NJN    APE8
          LDM    CP0U        GET UNCORRECTED REGISTER LIST FOR CPU0
          UJN    APE9        CONTINUE

 APE8     LDM    CP1U        GET UNCORRECTED REGISTER LIST FOR CPU1
 APE9     RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          LJM    APE19       CONTINUE PROCESSING

 APE10    LDM    SUMS        SUMMARY STATUS
          SHN    21-SSUE     UNCORRECTED ERROR
          PJP    APE13       IF NOT UNCORRECTED ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED PROCESSOR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).
*         DFT ANALYSIS - OS ACTION = UNCORRECTED PROCESSOR ERROR.
*                                  = NO ACTION (VERSION 4).

          SETDAN (EPUN,DAUPE)
          SETFLG (BC.FL)
          SETOSA OSUPE,OSNA
          LDM    CPUH        GET ORDINAL OF CPU BEING PROCESSED
          NJN    APE11
          LDM    CP0U        GET UNCORRECTED REGISTER LIST FOR CPU0
          UJN    APE12       CONTINUE

 APE11    LDM    CP1U        GET UNCORRECTED REGISTER LIST FOR CPU1
 APE12    RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          LJM    APE19       CONTINUE PROCESSING

 APE13    LDM    SUMS        SUMMARY STATUS
          SHN    21-SSCE     CORRECTED ERROR
          PJP    APE16       IF NOT CORRECTED ERROR
          LDM    OLSS        GET SAVED STATUS SUMMARY
          SHN    21-SSPH
          MJP    APE16       IF PROCESSOR HALT

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CORRECTED PROCESSOR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAN (EPCO,DACPE)
          SETFLG (BC.FL)
          LDM    CPUH        GET ORDINAL OF CPU BEING PROCESSED
          NJN    APE14
          LDM    CP0C        GET CORRECTED REGISTER LIST FOR CPU0
          UJN    APE15       CONTINUE

 APE14    LDM    CP1C        GET CORRECTED REGISTER LIST FOR CPU1
 APE15    RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          LJM    APE19       CONTINUE PROCESSING


*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED PROCESSOR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).
*         DFT ANALYSIS - OS ACTION = UNCORRECTED PROCESSOR ERROR.
*                                  = NO ACTION (VERSION 4).

 APE16    SETDAN (EPUN,DAUPE)
          SETFLG (BC.FL)
          SETOSA OSUPE,OSNA
          LDM    CPUH        GET ORDINAL OF CPU BEING PROCESSED
          NJN    APE17       IF CPU1
          LDM    CP0U        GET UNCORRECTED REGISTER LIST FOR CPU0
          UJN    APE18       CONTINUE

 APE17    LDM    CP1U        GET UNCORRECTED REGISTER LIST FOR CPU1
 APE18    RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
 APE19    RJM    CFC         CHECK FOR FATAL CONTROLWARE PARITY ERROR
          CALL   AP3         CHECK FOR P3 SPECIAL CASE
          LDM    RTP2        GET FLAG INDICATING CASE COND. MET
          NJP    APEX        IF MET CONSIDER AS NOT AN ERROR

          LDM    DFTA
          LMC    DDDC
          ZJN    APE20       IF DISABLE CPU
          SETDAC (DDCE)

 APE20    LDM    CPUO
          RJM    SSE         SET SECONDARY ELEMENT IDENTIFIER
          RJM    CID         CHECK IF CPU DEGRADABLE
          CALL   LOG
          LJM    APEX        RETURN
 CFC      SPACE  4,10
**        CFC - CHECK FOR CONTROLWARE PARITY ERROR.
*
*         ENTRY  REGISTERS READ IN SCRATCH BUFFER
*
*         EXIT   DFT ANALYSIS CHANGED IF CONDITION MET.
*
*         CALLS  FMB.
*
*         USES   W0 - W3.


 CFC      SUBR               ENTRY/EXIT
          LDC    EIMR
          RJM    FMB
          CRDL   W0          READ IN ELEMENT ID REGISTER
          LDDL   W3
          ADC    -0#301
          PJN    CFCX        IF SERIAL NUMBER >= 301 NO PROBLEM
          LDC    PPFS+6      PFS REGISTER 86
          RJM    FMB
          CRDL   W0          READ IN PFS REGISTER 86
          LDDL   W1
          LPC    0#CC        BITS 24,25,28,29
          ZJN    CFCX        IF NOT FATAL ERROR
          LDC    PPFS        REGISTER 80
          RJM    FMB         FIND REGISTER IN SCRATCH BUFFER
          CRDL   W0
          LDDL   W0          BIT 1
          SHN    3
          PJN    CFCX        IF NOT FATAL ERROR
          LDDL   W0
          SHN    2
          MJN    CFCX        IF NOT FATAL ERROR
          LDDL   W2
          LPN    1           BIT 47
          NJP    CFCX        IF NOT FATAL ERROR
          LDDL   W2
          LPC    0#40        BIT 41
          NJP    CFCX

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = FATAL CONTROLWARE PARITY ERROR.
*         DFT ANALYSIS - DFT ACTION = DISABLE CPU.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).

          SETDAC DDDC
          SETDAN (EPUN,DAFCE)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          LJM    CFCX
 AP3      SPACE  4,10
**        AP3 - ANALYSE P3 SPECIAL CASE CONDITION.
*
*         METHOD IF ERROR IS ONLY CORRECTED AND BIT 1 IN REG 80 AND
*                BIT 45 IN REG 86 ARE ONLY ONES SET THEN ACTION
*                FOR DFT IS TO IGNORE THE ERROR.
*
*         ENTRY  REGISTERS HAVE BEEN LOGGED IN THE MAINTENANCE REGISTER
*                SCRATCH BUFFER
*
*         EXIT   RTP2 = 0 IMPLIES CONDITIONS NOT MET, RTP2 = 1 IMPLIES
*                CONDITIONS MET.

          ROUTINE AP3
          LDN    1
          STM    RTP2        INITIALIZE TO CONDITIONS MET
          LDM    SUMS        SUMMARY STATUS
          LPBC   (SSUE,SSPH) CHECK UNCORRECTED ERROR PROC HALT
          NJP    AP38        IF EITHER SET
          LDM    SUMS
          SHN    21-SSCE     CORRECTED ERROR
          PJP    AP38        IF NOT A CORRECTED ERROR
          LDN    0#89-0#80
          STD    T1          COUNT OF REGISTERS TO SCAN
          LDC    PPFS        PFS REG 80 TO START AT
          STD    T2
 AP31     LDD    T2          GET CURRENT REGISTER
          RJM    FMB         FORM POINTER TO REGISTER
          CRDL   W0          GET REGISTER
          LDD    T2
          LMC    PPFS
          NJN    AP32        IF NOT PFS REG 80
          LDDL   W0          GET TO BIT 1
          SHN    21-16
          PJP    AP38        IF NOT SET
 AP33     LDDL   W0
          LPC    0#BFFF
          NJP    AP38        IF ANY OTHER BITS SET EXIT
          LDN    0
          UJN    AP36        CHECK REST OF REGISTER

 AP32     LDD    T2          CURRENT REGISTER
          LMC    PPFS+6
          NJN    AP35        IF NOT PFS REG 86
          LDDL   W2
          SHN    21-2        BIT 45
          NJN    AP34        IF SET
          UJN    AP38        IF NOT SET EXIT

 AP34     LDDL   W2
          LPC    0#FFFB      ALL BUT BIT 45
          NJN    AP38        IF ANY OTHERS SET EXIT
          LDN    0
          ADDL   W0          CHECK REST OF WORD
          ADDL   W1
          UJN    AP37        CONTINUE

 AP35     LDN    0
          ADDL   W0
 AP36     ADDL   W1
          ADDL   W2
 AP37     ADDL   W3
          NJN    AP38        IF ANYTHING ELSE SET EXIT
          AOD    T2          MOVE ON TO NEXT REGISTER TO EXAMINE
          SOD    T1          DECREMENT COUNT OF REGISTERS TO SCAN
          PJP    AP31        IF MORE TO DO
          SETDAC (DDCE)      ACTION TO CLEAR ERRORS
          LJM    AP3X        RETURN

 AP38     LDN    0
          STM    RTP2        SET FLAG TO SAY CONDITIONS NOT MET
          LJM    AP3X        RETURN

*COPY     CTP$DFT_SAVE_CONTROL_STORE
*COPY CTP$DFT_CHECK_CPU_THRESHOLD
*COPY     CTP$DFT_CHECK_DEGRADABLE_CPU
          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY (ANALYZE IOU ERRORS

          ROUTINE AIE

          LDM    IOUM
          LMN    0#20
          NJN    AIE10       IF NOT I2 IOU
          CALL   AIE2
          UJP    AIEX

 AIE10    CALL   AIE4        IF I4 IOU
          UJP    AIEX

          QUAL   AI2
          ROUTINE AIE2
          CALL   /AI2/AIE
          LJM    AIE2X
*COPYC CTP$DFT_ANALYZE_IOU_ERRORS

          QUAL   *
          QUAL   AI4
          ROUTINE AIE4
          CALL   /AI4/AIE
          LJM    AIE4X
*COPYC CTP$DFT_ANALYZE_IOU_ERRORS_I4
*COPYC CTP$DFT_PROCESS_DUAL_I4_IOU_ERR
*COPY CTP$DFT_SET_SS_DUAL_I4
 CEE      SPACE  4,10
**        CEE - CHECK FOR EXPECTED IOU ERROR
*
*         STUB ON UPPER 8XX CLASS

 CEE      SUBR               ENTRY/EXIT
          LDN    0           PRESET TO NOT EXPECT AN ERROR
          UJN    CEEX        RETURN
          QUAL   *

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (ANALYSE MEMORY ERRORS)
 AME      SPACE  4,10
**        AME - PROCESS MEMORY ERRORS.
*
*         CALLS  CLR, GSC, FMB, *CFF*, *LOG*, *SME*.


          ROUTINE AME

          LDN    0
          STM    RLST        CORRECTED ERROR FLAG
          STM    NERR        SET NO ERROR FLAG FLAG
          STML   SBER
          STML   SBER+1
          STML   SYCD
          LDN    BC
          RJM    CLR         ZERO SCRATCH BUFFER
          LDM    ME0U        MERGED MEMORY ERROR REGISTER LISTS
          RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ REGISTERS
          CALL   CFF         CHECK FOR FREEZE
          LDM    RTP2
          ZJN    AME0.1      IF NOT TO IGNORE ERRORS
          LDN    0
          STM    DFTA        NO ACTION
          STM    REGI        RESET REGISTER LIST INDEX
          UJP    AMEX

 AME0.1   LDM    SUMS        SUMMARY STATUS
          SHN    21-SSUE
          PJP    AME5        IF NOT UNCORRECTED
          LDC    MUL2
          RJM    FMB         FIND REGISTER IN SCRATCH BUFFER
          CRDL   W0          READ IN UEL2 REGISTER
          LDM    MEMM
          LMC    0#30
          NJP    AME1        IF MODEL 31 MEMORY
          LDD    W0
          LPC    0#B0
          LMC    0#A0        BIT 0, 2 SET, BIT 3 CLEAR
          NJP    AME2        IF NOT PARTIAL WRITE PARITY ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = PARTIAL WRITE PARITY ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR MEMORY ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).
*         DFT ANALYSIS - OS ACTION = MULTIPLE ODD BIT ERROR.
*                                  = STEP SYSTEM (VERSION 4).

 AME0     SETDAC DDCM
          SETDAN (EPUN,DAPWP)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          SETOSA OSMOB,OSSS
          UJP    AME3        LOG THE ERROR

 AME1     LDDL   W0
          SHN    2
          PJN    AME2        IF NOT VALID ERROR
          LDDL   W2
          LPC    0#3FC
          NJN    AME2        IF NOT PARTIAL WRITE PARITY ERROR
          LDD    W2
          LPN    3
          NJP    AME0        IF PARTIAL WRITE PARITY ERROR
          LDD    W3
          LPC    0#FC00
          NJP    AME0        IF PARTIAL WRITE PARITY ERROR


*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED CM ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR MEMORY ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).
*         DFT ANALYSIS - OS ACTION = UNCORRECTED MEMORY ERROR.
*                                  = NO ACTION (VERSION 4).

 AME2     SETDAC DDCM
          SETDAN (EPUN,DAUME)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          SETOSA OSUCM,OSNA
 AME3     CALL   LOG
 AME4     LJM    AMEX        RETURN

 AME5     LDM    SUMS
          SHN    21-SSCE
          PJN    AME4        IF NOT A CORRECTED ERROR
          LDN    1
          STM    RLST        SET CORRECTED ERROR LIST FLAG

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CORRECTED CM ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR MEMORY ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAC DDCM
          SETDAN (EPCO,DACME)
          SETFLG (BC.FL)

          LDM    MEMM        MEMORY MODEL
          LMN    0#30
          NJP    AME6        IF NOT 845,855

*         PROCESS CYBER 845/855 MEMORY ERRORS.

          RJM    GSC         GET SYNDROME CODE
          LDDL   W2
          SHN    -14D
          STML   SBER+1      LOWER ADDRESS BITS 32 - 33
          LDDL   W1
          LPC    0#3FFF
          SHN    2
          RAML   SBER+1      BITS 18 - 31 OF ADDRESS
          LDDL   W1
          SHN    -14D
          STML   SBER        BITS 16 - 17 OF ADDRESS
          LDDL   W0
          LPN    7           BITS 13 - 15  OF ADDRESS
          SHN    2
          RAML   SBER
          CALL   SME         SERVICE MEMORY ERROR
          LJM    AMEX        RETURN

 AME6     BSS    0

*         PROCESS CYBER 840/850/860 MEMORY ERRORS.

          RJM    GSC
          LDDL   W0
          LPC    0#FF        BITS 8 - 15
          SHN    2
          STML   SBER
          LDDL   W1
          SHN    -14D        BITS 16 - 17
          RAML   SBER
          LDDL   W1
          SHN    2           BITS 18 - 31
          STML   SBER+1
          LDDL   W2
          SHN    -14D        BITS 32 - 33
          RAML   SBER+1
          CALL   SME
          LJM    AMEX        RETURN
 GSC      SPACE  4,10
**        GSC - GET SYNDROME CODE.
*
*         ENTRY  (W0 - W3) = PROPER *CEL* REGISTER.
*
*         EXIT   (SYCD) = SYNDROME CODE.
*
*         USES   W0 - W3, *SYCD*.


 GSC      SUBR               ENTRY/EXIT
          LDN    0
          STM    SYCD

*         PROCESS CYBER 840/845/850/855/860 SYNDROME CODE.

 GSC2     LDC    MCEL        READ CORRECTED ERROR LOG REGISTER
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRDL   W0
          LDDL   W0
          SHN    21-17
          PJP    AMEX        IF VALID BIT NOT SET
          LDDL   W2
          LPN    77          BITS 0 - 5
          SHN    2
          STML   SYCD        SAVE WHOLE SYNDROME
          LDDL   W3
          SHN    -14D        BITS 6 - 7 OF SYNDROME
          RAML   SYCD
          LJM    GSCX        RETURN

*COPY CTP$DFT_SERVICE_MEMORY_ERROR
*COPY CTP$DFT_REWRITE_CM_ERROR
          QUAL   *

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (LOG ERRORS TO BUFFER CONTROL WORDS)

**        ON CYBER 990 THERE IS SPECIAL HANDLING OF COMPARING MULTIPLE
*         RETRY ERRORS.


 QUAL$    EQU    0           DEFINE UNQUALIFIED COMMON DECKS
*COPYC CTP$DFT_LOG_ERROR
*COPY CTP$DFT_LOG_ERROR_CHECK_MATCH
*COPYC CTP$DFT_LOG_ERROR_NON_990
*COPYC CTP$DFT_LOG_ERROR_NO_CONSOLE
*COPY CTP$DFT_ZERO_SUPPORTIVE_STATUS
*COPY CTP$DFT_INCREMENT_ERROR_COUNT
*COPY  CTP$DFT_FIND_WARNING_IN_NRSB
*COPY CTP$DFT_FIND_CONTROL_WORD
*COPY CTC$DFT_ELEMENT_CONVERSIONS
          QUAL   *

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (GENERATE FAULT SYMPTOM CODE)

**        CYBER 840/845/850/855/860 FAULT SYMPTOM CODES.

*COPYC CTP$DFT_GENERATE_FAULT_SYMPTOM
*COPY     CTP$DFT_WRITE_FSC_TO_BUFFER

          ROUTINE I4S        NOT DEFINED ON NON 960 APPLICATIONS
          LJM    I4SX
          ROUTINE I4I        NOT DEFINED ON NON MODEL 44 IOU
          LJM    I4IX
          QUAL   *
          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (MODEL 40 IOU FSC)
 I4A      SPACE  4,10
**        I4A - INTERFACE TO I4A FSC COMMON DECK.
*


          ROUTINE  I4A

          LDDL   BC+BCDA     GET ANALYSIS TO LOG
          SHN    -BC.ANP
          SBN    EPEN
          PJP    I4A2        IF ENVIRONMENT WARNING
          LDML   CPU0M       CPU0 MODEL NUMBER
          STML   CDIF
          LDC    IFS1
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+1,ON
          LDC    IFS2
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+5,ON
          LDN    OIMR
          RJM    FMB         FIND REGISTER IN MAINTENANCE REGISTER SCRATCH
          CRDL   W0
          LDDL   W3
          SHN    21-7
          PJN    I4A0        IF NO CIO PPS PRESENT
          LDC    CIFS1
          RJM    FMB         FIND REGISTER IN MAINTENANCE REGISTER SCRATCH
          CRML   CDIF+9D,ON
          LDC    CIFS2
          RJM    FMB         FIND REGISTER IN MAINTENANCE REGISTER SCRATCH
          CRML   CDIF+13D,ON
 I4A0     LDC    CDIF        FWA OF INTERFACE BUFFER
          RJM    /IOUFLT0/IOUFLT0
 I4A1     LDC    2RDI        IOU ELEMENT IDENTIFIER
          ADM    IOUO        INCREMENT BY IOU ORDINAL
          RJM    WFS         WRITE FAULT SYMPTOM CODE TO SUPPORTIVE STATUS
          UJP    I4AX        RETURN

 I4A2     LDN    3
          STD    T1
 I4A3     LDML   I4AA,T1     GET CANNED ENVIRONMENT FAULT SYMPTOM CODE
          STML   CDIF,T1     STORE IN OUTPUT BUFFER
          SOD    T1
          PJN    I4A3        IF NOT DONE
          UJN    I4A1        LOG THE FAULT CODE

 I4AA     DATA   H*701     *


*copy     ctp$convert_digits_to_ascii
*copy     ctp$dft_model_40_iou_fsc
*copy     ctp$dft_write_fsc_to_buffer

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW

          OVERLAY  (READ MAINTENANCE REGISTERS)
          QUAL   *           SO THAT OTHER OVERLAYS MAY ACCESS
 S3PA     SPACE  4,10
**        CYBER 840/845/850/855/860 PROCESSOR CORRECTED/UNCORRECTED ERROR
*         REGISTER LIST.


 S3PA     REGLST (10,00,12,30,80,81,82,83,84,85,86,87,88,89)

 SXMA     SPACE  4,10
**        UPPER 8XX CYBER MEMORY ERROR REGISTER LIST.


 SXMA     REGLST (10,00,12,20,A0,A4,A8,21)
 SXIU     SPACE  4,10
**        I2 CORRECTED AND UNCORRECTED IOU ERROR LIST.


 SXIU     REGLST (10,00,12,30,40,80,81,A0,18,21)
 I4IC     SPACE  4,10
**        I4 CORRECTED IOU ERROR LIST.


 I4IC     REGLST (10,00,12,30,40,80,81,A0,18,21,16,34,44,84,85,A4,1C,25)
 I4IU     SPACE  4,10
**        I4 UNCORRECTED IOU ERROR LIST.


 I4IU     REGLST (10,00,12,30,40,80,81,A0,18,21,16,34,44,84,85,A4,1C,25)
*COPYC CTP$DFT_READ_MAINTENANCE_REGS
*COPY CTP$DFT_ZERO_SUPPORTIVE_STATUS
          QUAL   *

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (PROCESSOR PRIMITIVES)

*COPY CTP$DFT_PROCESSOR_PRIMITIVES

 STRBTS   SPACE  4,10
**        STRBTS - STORE BITS IN *DEC*.
*
*         NOT USED ON UPPER 8XX CLASSES


          ROUTINE STRBTS
          LJM    STRBTSX

 CLRBTS   SPACE  4,10
**        CLRBTS - RESTORE MODEL-DEPENDENT BITS IN *DEC*.
*
*         NOT USED ON UPPER 8XX CLASSES


 CLRBTS   SUBR               ENTRY/EXIT
          UJN    CLRBTSX
*COPY CTP$DFT_MANAGE_MEMORY_PORT

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (MASSAGE CPU REGISTERS)
*COPY CTP$DFT_MASSAGE_CPU_REGISTERS

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (CLEAR ERRORS)
 CLE      SPACE  4,10
**        CLE - CLEAR ERRORS.
*
*         EXIT   ALL REGISTERS NECESSARY WILL BE CLEARED OF ERRORS.


          ROUTINE CLE

          LDM    HBUF+HDRPC
          LPC    7417
          STD    EC
          FUNCMR ,MRCE       CLEAR ERRORS FROM *PFS* REGISTERS
          LJM    CLEX        RETURN

 CCE      SPACE  4,10
**        CCE - CLEAR CM ERRORS.
*
*         CALLS  FMB, UPR.


          ROUTINE CCE


*         PROCESS UPPER 8XX MAINFRAMES.

 CCE2     LDM    RLST
          NJP    CCE4.5      IF CORRECTED ERROR

*         CLEAR UNCORRECTED ERROR LOG 1 AND 2.

          LDC    MUL1
          STD    RN
          RJM    FMB         GET MAINTENANCE BUFFER POINTER FOR REGISTER
          CRML   MRVAL,ON
          RJM    UPR         UNPACK TO (RDATA)
          LDM    RDATA
          SHN    21-7
          PJN    CCE4        IF VALID NOT SET
          LDM    RDATA
          LPN    0#3F        SAVE ALL BUT VALID, UNLOGGED BITS
          STM    RDATA
          WRITMR RDATA,HBUF+HDRPC
 CCE4     LDC    MUL2
          STD    RN          SET UP *UEL2* REGISTER
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   MRVAL,ON
          RJM    UPR
          LDM    RDATA
          SHN    21-7
          PJN    CCE4.1      IF VALID NOT SET
          LDM    RDATA
          LPN    0#3F        SAVE ALL BUT VALID, UNLOGGED BITS
          STM    RDATA
          WRITMR RDATA,HBUF+HDRPC
 CCE4.1   LJM    CCEX        RETURN

 CCE4.5   LDC    MCEL
          STD    RN          CORRECTED MEMORY ERROR REGISTER
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   MRVAL,ON
          RJM    UPR
          LDM    RDATA
          SHN    21-7
          PJN    CCE4.1      IF VALID NOT SET
          LDM    RDATA
          LPN    0#3F        SAVE ALL BUT VALID, UNLOGGED
          STM    RDATA
          WRITMR RDATA,HBUF+HDRPC
          LJM    CCEX        RETURN
          QUAL   *

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (UPDATE C170 MEMORY)
*COPYC CTP$DFT_UPDATE_170_MEMORY

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_OS_REQUESTS
*COPYC CTP$DFT_OS_REQUESTS_PACKETS

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS - DUAL I4)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_REQUESTS_DUAL_I4
*COPY CTP$DFT_CHECK_TPM_PKT_RESPONSE

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS FOR IOU1)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_REQUESTS_IOU1_DUAL_I4

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (DFT REQUEST PROCESSORS - 2)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_REQUEST_PROCESSOR_2

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (PP REQUEST PROCESSOR)
*COPY CTP$DFT_RETURN_ERROR_CODE
*COPYC CTP$DFT_PP_UTILITY_REQUESTS
*COPY  CTP$DFT_DUMP_PP_REGISTERS
*COPY  DSI$DUMP_LOAD_IDLE_PP

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          OVERLAY  (DFT ERROR LOGGING ROUTINES)
*COPY     CTP$DFT_PROCESS_DISK_ERROR
*COPY CTP$DFT_RETURN_ERROR_CODE

          OVERFLOW  R2ORG
          OVERLAY  (RESTART SCI PP)
 QUAL$    EQU    0
*COPYC CTP$DFT_RESTART_SCI
*COPY DSI$DUMP_LOAD_IDLE_PP
          OVERFLOW R2ORG     CHECK FOR OVERFLOW

          OVERLAY  (DFT RUN TIME ERROR HANDLING)
*COPYC CTP$DFT_RUN_TIME_ERROR_HANDLER
*COPY CTP$DFT_RETURN_ERROR_CODE
*copy     ctp$construct_message_in_eicb

          OVERFLOW  R2ORG    CHECK FOR OVERFLOW
          END
/EOR
*DECK DECK=CTM$ECB_VERSION_RECORD EXPAND=TRUE
          IDENT  ECB
          CIPPU  J
          BASE   MIXED
          TITLE  CTM$ECB VERSION RECORD
          COMMENT *SMD* LVL=05
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          EJECT
***       ECB - EICB IDENTIFICATION RECORD.
*
*         THE SOLE PURPOSE OF THE ECB RECORD IS TO PROVIDE A 77 TABLE
*         CONTAINING THE VERSION LEVEL OF THE EICB.  THIS VERSION LEVEL
*         WILL BE CHECKED BY THE SERVICE PROCESSOR IN A CYBER 2000
*         ENVIRONMENT AT THE TIME THE BOOT RECORDS ARE LOADED TO THE CIP
*         DEVICE.  IF THE VERSION LEVEL IS NOT ONE THAT IS SUPPORTED BY
*         THE SERVICE PROCESSOR, IT WILL DISPLAY A MESSAGE INDICATING
*         THAT.
*
*         THIS RECORD EXISTS IN A NON-CYBER 2000 ENVIRONMENT BUT IS NOT USED.
          SPACE  4
          END
/EOR
*DECK DECK=CTM$IDC_RECORD EXPAND=TRUE
          IDENT  IDC
          CIPPU  ,S
          MEMSEL 16
          CODE   DISPLAY
          TITLE  CTM$IDC RECORD
          COMMENT *SMD* LVL=01
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          EJECT
***
*         IDC - CTI TAPE IDENTIFICATION RECORD
*
*         IDC IS A DATA RECORD THAT CONTAINS IDENTIFICATION INFORMATION
*         IN DISPLAY CODE OF WHAT IS CONTAINED ON THE CYBER INITIAL-
*         IZATION PACKAGE (CIP) OR OPERATING SYSTEM TAPE.
*
***
          SPACE  2
 CIPID    DIS    7,VE DS "DATE"
          DATA   0
          SPACE  2
 COSF     DIS    1,OS        CIP/OS FLAG.  IF THE TAPE BEING GENERATED
*                            IS A CIP TAPE, COSF=CI AND =OS IF AN OS
*                            TAPE IS BEING GENERATED.
          BSSZ   17B         FOR COMPATABILITY WITH OTHER IDC RECORDS.
***
*         TABLE OF MICROCODE NAMES RESIDING ON TAPE.
***
 SCI      VFD    30/5L +SCI,6/0
 VCB      VFD    30/5L +VCB,6/0
 SSR      VFD    30/5L +SSR,6/0
 VDT      VFD    30/5L +VDT,6/0
 BCT      VFD    30/5L  BCT,6/0
 ECB      VFD    30/5L  ECB,6/0
          DATA    0
          DATA    0
          DATA    0
          DATA    0
          ERRNG   500B-*-120B   IDC RECORD CANNOT BE MORE THAN 500B WORDS
          END
/EOR
*DECK DECK=CTM$PP_TEST_BINARY EXPAND=TRUE
          IDENT  TST,70B
          CIPPU  J
          BASE   MIXED
          TITLE  CTM$PP TEST BINARY
          COMMENT *SMD* LVL=01
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 PRGM     EQU    3
 OVERLAY  SPACE  4,10
**        OVERLAY - DEFINE OVERLAY TITLE AND LOAD ADDRESS
*
*         OVERLAY  (DESCRIPTION),LOAD ADDRESS


          PURGMAC  OVERLAY
 ALPHABET MICRO  1,25,*ABCDEFGHIJKLMNOP*
 SCI      MICRO  1,4,*SCIO*
 DFT      MICRO  1,4,*DFTO*
 PRGMS    MICRO  1,,*"SCI""DFT""TST"*
 OVERLAY  MACRO  DESC,LOADADD
          LOCAL  AD
          QUAL   *
          NOREF  OVLN
 OVLL     SET    OVLL+1
          IFEQ   OVLL,21,2
 OVLL     SET    1
 OVLU     SET    OVLU+1
 OVLN     SET    OVLU*20+OVLL-21
 PRGNAM   MICRO  PRGM*4-3,4,*"PRGMS"*
 CHL      MICRO  OVLL,1,*"ALPHABET"*
 CHU      MICRO  OVLU,1,*"ALPHABET"*
 NU       OCTMIC OVLN,2
 AD       OCTMIC LOADADD OVLA
          TITLE  "PRGNAM""CHU""CHL" ("NU") - DESC.
          IDENT  "PRGNAM""CHU""CHL","AD"  "NU"  DESC
          QUAL   "PRGNAM""CHU""CHL"
          ORG    "AD"
          ENDM
 OVLL     SET    1           INITIALIZE OVERLAY NUMBER
 OVLU     SET    1
          EJECT
          ORG    100
          CON    0
          OVERLAY  (OVERLAY 1),100
          CON    1
          OVERLAY  (OVERLAY 2),200
          CON    1
          CON    2
          OVERLAY  (OVERLAY 3),300
          CON    1
          CON    2
          CON    3
          OVERLAY  (OVERLAY 4),400
          CON    1
          CON    2
          CON    3
          CON    4
          OVERLAY  (OVERLAY 5),500
          CON    1
          CON    2
          CON    3
          CON    4
          CON    5
          OVERLAY  (OVERLAY 6),600
          CON    1
          CON    2
          CON    3
          CON    4
          CON    5
          CON    6
          OVERLAY  (OVERLAY 7),700
          CON    1
          CON    2
          CON    3
          CON    4
          CON    5
          CON    6
          CON    7
          OVERLAY  (OVERLAY 8),1000
          CON    1
          CON    2
          CON    3
          CON    4
          CON    5
          CON    6
          CON    7
          CON    10
          OVERLAY  (OVERLAY 9),1100
          CON    1
          CON    2
          CON    3
          CON    4
          CON    5
          CON    6
          CON    7
          CON    10
          CON    11
          OVERLAY  (OVERLAY 10),1200
          CON    1
          CON    2
          CON    3
          CON    4
          CON    5
          CON    6
          CON    7
          CON    10
          CON    11
          CON    12
          OVERLAY  (OVERLAY 11),1300
          CON    1
          CON    2
          CON    3
          CON    4
          CON    5
          CON    6
          CON    7
          CON    10
          CON    11
          CON    12
          CON    13
          OVERLAY  (OVERLAY 12),1400
          CON    1
          CON    2
          CON    3
          CON    4
          CON    5
          CON    6
          CON    7
          CON    10
          CON    11
          CON    12
          CON    13
          CON    14
          OVERLAY  (OVERLAY 13),1500
          CON    1
          CON    2
          CON    3
          CON    4
          CON    5
          CON    6
          CON    7
          CON    10
          CON    11
          CON    12
          CON    13
          CON    14
          CON    15
          OVERLAY  (OVERLAY 14),1600
          CON    1
          CON    2
          CON    3
          CON    4
          CON    5
          CON    6
          CON    7
          CON    10
          CON    11
          CON    12
          CON    13
          CON    14
          CON    15
          CON    16
          OVERLAY  (OVERLAY 15),1700
          CON    1
          CON    2
          CON    3
          CON    4
          CON    5
          CON    6
          CON    7
          CON    10
          CON    11
          CON    12
          CON    13
          CON    14
          CON    15
          CON    16
          CON    17
          OVERLAY  (OVERLAY 16),2000
          CON    1
          CON    2
          CON    3
          CON    4
          CON    5
          CON    6
          CON    7
          CON    10
          CON    11
          CON    12
          CON    13
          CON    14
          CON    15
          CON    16
          CON    17
          CON    20
          OVERLAY  (OVERLAY 17),2100
          CON    1
          CON    2
          CON    3
          CON    4
          CON    5
          CON    6
          CON    7
          CON    10
          CON    11
          CON    12
          CON    13
          CON    14
          CON    15
          CON    16
          CON    17
          CON    20
          CON    21
          OVERLAY  (OVERLAY 18),2200
          CON    1
          CON    2
          CON    3
          CON    4
          CON    5
          CON    6
          CON    7
          CON    10
          CON    11
          CON    12
          CON    13
          CON    14
          CON    15
          CON    16
          CON    17
          CON    20
          CON    21
          CON    22
          END
/EOR
*DECK DECK=CTM$SYSTEM_CONSOLE_CONTROLWARE EXPAND=TRUE
          IDENT  CTMVAC,#C000
        MACHINE  Z80
          TITLE  VAC - VIKING-X AUGMENTED CONTROLWARE
          SPACE  4
*  VAC - Viking-X Augmented Controlware
*
*     R.A.ANDERSON 3/84
*     J.C.BOHNHOFF (feasiblity version) 2/83.
*
*  This program resides in the Viking-X (CDC 721-X0)
*  terminal.  It is loaded by the CYBER host through
*  the 2-port multiplexer.
*
*  The load sequence begins with :  [RS][HT](77)(32)
*  (ASCII control codes are in brackets ,  hex bytes
*  are in parens).  This is followed by the LDA(load
*  address,C000),and the code itself. Each byte sent
*  (load address or code) is encoded as described in
*  the Viking-X Vers. 4.x  E.R.S.  The code sequence
*  terminates with a carriage return.  The VAC pack-
*  age is is now installed in RAM. The resident mon-
*  itor still has control of all terminal functions.
*  The VAC package is activated by the "Host Execute
*  Loaded Controlware" code sequence: [RS][DC2](77).
*  VAC now controls all terminal function.  Resident
*  interrupt routines are used for UART printer, and
*  keyboard control.
          TITLE  RESIDENT DEFINITIONS
**      Viking X Resident Definitions.
          SPACE  2
*       Resident Subroutine Entry Points.

INIT02    EQU    #09         INITIALIZATION 02
CRT80     EQU    #0C         SET CRT TO 80 CHARACTERS PER LINE
CRT132    EQU    #0F         SET CRT TO 132 CHARACTERS PER LINE
ALARM     EQU    #33         SOUND ALARM
BFTB      EQU    #3C         COMMUNICATIONS BUFFER TO B
BLDADD    EQU    #3F         BUILD ADDRESS
DSTRNG    EQU    #63         DATA STRING
KINPUT    EQU    #6F         KEYBOARD INPUT
SEND      EQU    #84         SEND NEXT CODE FROM COMMUNICATIONS BUFFER
SENDB     EQU    #87         STORE B IN COMMUNICATIONS SEND BUFFER
SETDE     EQU    #8A         SET CURSOR TO DE
KBDUNL    EQU    #C9         UNLOCK KEYBOARD
PILSR     EQU    #CC         INPUT PRINTER LSR
PRINTC    EQU    #CF         PRINT NEXT CHARACTER
PTTRAP    EQU    #D2         PRINTER INPUT TRAP
          SPACE  3
*         RAM / EQUates.

BFCNT     EQU    #E083       NUMBER OF CHARACTERS IN COMM BUFFER
KBCNT     EQU    #E089       NUMBER OF CHARACTERS IN KEYBOARD BUFFER
TXCNT     EQU    #E08E       NUMBER OF CHARACTERS IN TRANSMIT BUFFER
CNTRL     EQU    #E0B5       CONTROL KEY ACTIVE ODD=TRUE
FLAG1     EQU    #E0BE       FIELD ID SENT
PTXOFF    EQU    #10         2**4 PRINTER X-OFF RECIEVED
HMSGA     EQU    #E0C2       HOST MESSAGE ACTIVE
KBINP     EQU    #E0C9       1=KEYBOARD INPUT ACTIVE
LNSIZE    EQU    #E0D4       LINE SIZE, 79 OR 131 STANDARD
PRINTA    EQU    #E0DD       1=PRINT ALL ACTIVE, 3=PRINT NORMAL ACTIVE
RXOFF     EQU    #E0E1       RECEIVED XOFF
SXOFF     EQU    #E0EB       SENT XOFF
NOPTR     EQU    #E0F8       NO PRINTER ASSIGNED
          TITLE  CONTROLWARE CONSTANTS
**        Symbol Definitions.

LDA       EQU    #C000       LOAD ADDRESS
          SPACE  3
**        Function Codes

NUL       EQU    #00         ADVANCE CURSOR                         (NU)
SOH       EQU    #01         START INVERSE 1 CHAR. BEFORE NEXT TEXT (SH)
STX       EQU    #02         POSITION ON SCREEN (STX,x,y)           (SX)
ETX       EQU    #03         END INVERSE AT NEXT CHARACTER          (EX)
EOT       EQU    #04         TRANSFER HIDDEN TO VISIBLE-CLEAR HIDDEN(ET)
ACK       EQU    #06         START UNDERSCORE                       (AK)
SO        EQU    #0E         START BLINK                            (SO)
SI        EQU    #0F         END BLINK                              (SI)
DLE       EQU    #10         START INVERSE                          (DL)
DC4       EQU    #14         END INVERSE                            (D4)
NAK       EQU    #15         END UNDERSCORE                         (NK)
ETB       EQU    #17         TRANSFER HIDDEN TO VISIBLE             (EB)
CLR       EQU    #18         INITIALIZE HIDDEN SCREEN $ PARAMETERS  (CN)
RSET      EQU    #19         INITIALIZE DISPLAY PAGE SELECTION      (EH)
SUB       EQU    #1A         ACTIVATE NON-PRIORITY PARAMETERS       (SB)
ESC       EQU    #1B         ERASE TO END OF LINE                   (EC)
FS        EQU    #1C         START DIM                              (FS)
GS        EQU    #1D         END DIM                                (GS)
RS        EQU    #1E         EXTENDED SEQUENCE FOLLOWS              (RS)
US        EQU    #1F         ACTIVATE PRIORITY PARAMETERS           (US)
          SPACE  3
**        Attribute Constants
*         Only inverse is changed from the resident values.

UNDLN     EQU    #02         UNDERSCORE
INV       EQU    #06         INVERSE
BLINK     EQU    #08         BLINK
DIM       EQU    #10         DIM
PROTD     EQU    #80         PROTECT
          SPACE  3
**        Hidden Screen Mode Bank Selection.
*                BLOCK 0 = BANK 0 (RESIDENT ROM)
*                      4 =      6 (NVM)
*                      8 =      3 (RAM)
*                      C =      4 (DISPLAY RAM)

HSB       EQU    #1C         BANK SELECTIONS FOR HIDDEN SCREEN MODE
BSP       EQU    #70         BANK SELECT PORT
          EJECT
**        Hidden Screen Addressed and Equates

CWSP      EQU    #4FF0       STACK FRAME AREA
HSCM      EQU    #50         MASK TO COMPUTE RAM ADDR. IN HIDDEN SCREEN
HSCF      EQU    #5000       FIRST ADDRESS OF HIDDEN SCREEN
HSCL      EQU    #838F       LAST ADDRESS OF LINE 49
ERLB      EQU    #8498       ERROR LINE BUFFER
CMLB      EQU    #85A0       COMMAND LINE BUFFER
ENHB      EQU    #36A8       LENGTH OF ALL HIDDEN BUFFERS
          SPACE  2
**        Visible Screen Addresses

VIS28     EQU    #FCE8       VISIBLE LINE # 28 (MESSAGE LINE)
LFTRGT    EQU    VIS28+90    TOGGLE MESSAGE AREA
RHTRGT    EQU    VIS28+224   TOGGLE MESSAGE AREA
VIS29     EQU    #FDF0       VISIBLE LINE # 29 (ERROR LINE)
VIS30     EQU    #FEF8       VISIBLE LINE # 30 (COMMAND LINE)
          SPACE  2
**        ASCII Codes

DC1       EQU    #11         X-ON
DC2       EQU    #12
BL        EQU    #20         SPACE
ONE       EQU    #31
FIVE      EQU    #35
AA        EQU    #41
BB        EQU    #42
CC        EQU    #43
DD        EQU    #44
EE        EQU    #45
FF        EQU    #46
GG        EQU    #47
HH        EQU    #48
II        EQU    #49
JJ        EQU    #4A
KK        EQU    #4B
LL        EQU    #4C
MM        EQU    #4D
NN        EQU    #4E
OO        EQU    #4F
PP        EQU    #50
RR        EQU    #52
SS        EQU    #53
TT        EQU    #54
UU        EQU    #55
VV        EQU    #56
WW        EQU    #57
XX        EQU    #58
YY        EQU    #59
ZZ        EQU    #5A

          LIST   -L
          PURGMAC SET
SET       MACRO  BIT         SET     BIT,(IY)
          IFEQ   BIT,1
          DATA   #FD,#CB,0,#CE
          ENDIF
          IFEQ   BIT,2
          DATA   #FD,#CB,0,#D6
          ENDIF
          IFEQ   BIT,3
          DATA   #FD,#CB,0,#DE
          ENDIF
          IFEQ   BIT,4
          DATA   #FD,#CB,0,#E6
          ENDIF
          ENDM
          LIST   L
          ORG    LDA
INIT      TITLE  INITIALIZATION
**        INIT - INITIALIZE
*
*         INITIALIALIZE THE VIKING-X FOR PROPER MODES

INIT      LD     A,HSB       SELECT HIDDEN SCREEN BANKS
          OUT    (BSP),A

          LD     (SPSA),SP   SAVE CURRENT STACK POINTER
          LD     SP,CWSP     RESET STACK POINTER

          LD     HL,LINE30   SET TO 30 LINE MODE
          CALL   DSTRNG

          XOR    A           CLEAR RECIEVED X-OFF
          LD     (RXOFF),A

          INC    A           SET KBINP TO 1 FOR KEYBOARD ACTIVE
          LD     (KBINP),A

          LD     IY,ATT      SET IY TO CONTAIN ATTRIBUTE

          LD     HL,HSCF     ERASE ENTIRE BUFFER
          LD     (HL),BL     PRIME WITH A BLANK
          INC    HL
          LD     (HL),PROTD  AND THE PROTECT ATTRIBUTE
          DEC    HL
          LD     DE,HSCF+2
          LD     BC,ENHB
          LDIR

          CALL   KBDUNL      UNLOCK THE KEYBOARD

          CALL   MVH         SO OPERATOR SEES BLANK SCREEN

          LD     HL,FRSTMSG  PLACE MESSAGE ON SCREEN
          CALL   DSTRNG
HSM       TITLE  MONITORS
**        HSM - HIDDEN SCREEN MONITOR.

HSM       CALL   MTR         PROCESS MAIN TERMINAL FUNCTIONS
          JR     Z,HSM       LOOP IF NO DOWNLINE DATA

          CALL   BFTB        GET THE DOWNLINE BYTE
          EI                 ENABLE INTERRUPTS

*         TEST FOR A FUNCTION CODE

          LD     A,B         COPY BYTE INTO A
          CP     BL          IF NOT FUNCTION
          JP     P,HSM1      THEN VALID DATA BYTE

*         PROCESS A FUNCTION CODE.

          PUSH   AF          SAVE BYTE
          CALL   PFC         PROCESS FUNCTION CODE
          POP    AF          GET BYTE BACK
          LD     (PREV),A    AND SAVE FOR POSTERITY
          JP     HSM         LOOP FOR MORE DOWNLINE DATA

*         MOVE A DOWNLINE BYTE TO THE HIDDEN PAGE.

HSM1      LD     (PREV),A    SAVE BYTE
          LD     HL,(HSADD)  GET HIDDEN SCREEN CURSOR ADDRESS
          LD     (HL),B      STORE THE DATA BYTE

          LD     A,(INVPS)   TEST IF INVERSE PRIME IS ACTIVE
          AND    A
          CALL   NZ,SIP      IF SO SET PREVIOUS ATTRIBUTE

          INC    HL          STORE THE ATTRIBUTE BYTE
          LD     A,(IY)
          LD     (HL),A

          LD     A,(HSL)     IF BYTE WENT INTO PRIORITY LINE 50 OR 51
          CP     50
          CALL   P,DPB       THEN DISPLAY PRIORITY BYTE

          CALL   ADC         ADVANCE THE CURSOR

          JP     HSM         LOOP FOR MORE DOWNLINE DATA
MTR       EJECT
**        MTR - PROCESS MAIN TERMINAL FUNCTIONS.
*
*         ENTRY    NONE.
*
*         EXIT     'Z' IF NO DOWNLINE DATA IN THE COMMUNICATIONS BUFFER.

MTR       LD     A,(KBCNT)   CHECK KEYBOARD INPUT AVAILABLE
          AND    A
          CALL   NZ,PKB      IF SO, PROCESS INPUT

          LD     A,(TXCNT)   CHECK UPLINE DATA AVAILABLE
          AND    A
          CALL   NZ,SEND     IF SO SEND ONE UPLINE BYTE

          LD     A,(NOPTR)   CHECK SERIAL PRINTER ASSIGNED
          AND    A
          JP     NZ,MTR1     IF NOT

          CALL   PILSR       CHECK PRINTER DATA READY
          AND    1
          CALL   NZ,PTTRAP   IF SO

MTR1      LD     A,(PRINTA)  CHECK PRINT ALL IS ACTIVE
          AND    A
          JP     Z,MTR3      IF NOT

          CALL   PRINTC      PRINT CHARACTER
MTR2      XOR    A
          RET

MTR3      LD     A,(FLAG1)   CHECK PRINTER XOFF RECEIVED
          AND    PTXOFF
          JR     NZ,MTR2     IF SO

          LD     HL,(BFCNT)  CHECK DOWNLINE DATA AVAILABLE
          LD     A,L
          OR     H
          RET
MVH       TITLE  TRANSFER FROM BUFFERS TO DISPLAY
**        MVH - MOVE THE SELECTED PAGE(S) TO THE VISIBLE SCREEN
*
*         RETURNS VIA DPL (DISPLAY PRIORITY LINES)

MVH       LD     HL,(HSC)    SAVE THE HIDDEN CURSOR POSITION
          PUSH   HL
          LD     HL,#0300    SET FOR 4 LINES AT TOP OF SCREEN
          LD     (VSL),HL
          LD     HL,0        ASSUME LEFT SCREEN IS DISPLAYED
          LD     (HSC),HL
          LD     A,(SCREEN)  IF SCREEN NOT DUAL
          AND    A
          JR     NZ,MVH4     THEN

          LD     A,(LNSIZE)  ELSE IF VIDEO CHANGED
          CP     131
          CALL   NZ,CRT132   THEN CHANGE TO 132 COLUMN

          CALL   TDL         TRANSFER THE LEFT HEADER
          LD     HL,#0044    RESET HSC = 68,HSL = 0
          LD     (HSC),HL
          CALL   TDL         TRANSFER THE RIGHT HEADER

          LD     HL,#1604    SET FOR 23 LINES BEGINNING AT FIFTH
          LD     (VSL),HL
          LD     HL,#0400    RESET HSL AND HSC ASSUME TOP PAGE
          LD     (HSC),HL
          LD     A,(LPAGE)   IF LEFT NOT TOP
          AND    A
          JR     NZ,MVH2     THEN BOTTOM
          LD     A,(RPAGE)   ELSE IF RIGHT NOT TOP
          AND    A
          JR     NZ,MVH3     THEN TRANSFER LEFT-TOP RIGHT-BOTTOM

MVH1      CALL   TDL         AND TRANSFER A LEFT SCREEN
          LD     HL,#0444    RESET HSC = 68,HSL = 4
          LD     (HSC),HL
MVH1.1    CALL   TDL         TRANSFER LAST SCREEN
          JP     DTM

MVH2      LD     A,27        SET TO LINE 28 OF HIDDEN BUFFER
          LD     (HSL),A
          LD     A,(RPAGE)   IF RIGHT NOT TOP
          AND    A
          JR     Z,MVH1      THEN TRANSFER LEFT-BOTTOM RIGHT-TOP

MVH3      CALL   TDL         TRANSFER A LEFT SCREEN
          LD     HL,#1B44    RESET HSC = 68,HSL = 27
          LD     (HSC),HL
          JR     MVH1.1      TRANSFER RIGHT-BOTTOM SCREEN
          EJECT
MVH4      LD     A,(LNSIZE)  IF VIDEO CHANGED
          CP     79
          CALL   NZ,CRT80    THEN CHANGE VIDEO TO 80 COLUMN

          LD     A,(SCREEN)  IF NOT LEFT SCREEN ONLY
          CP     1
          JR     NZ,MVH7     THEN RIGHT ONLY

          CALL   TDL         TRANSFER THE HEADER FOR THE LEFT SCREEN
          LD     HL,#1604    SET FOR 23 LINES BEGINNING AT LINE 5
          LD     (VSL),HL
          LD     A,(LPAGE)   IF NOT TOP HALF OF LEFT SCREEN
          AND    A
          JR     NZ,MVH6     THEN BOTTOM

MVH5      LD     A,4         SET HIDDEN TO LINE 4
          LD     (HSL),A
          JR     MVH1.1      TRANSFER THE TOP OF PAGE TO VISIBLE

MVH6      LD     A,27        SET FOR THE BOTTOM HALF OF DISPLAY
          LD     (HSL),A
          JR     MVH1.1      TRANSFER THE BOTTOM 1/2 OF SCREEN

MVH7      LD     A,68        SET FOR RIGHT SCREEN HEADER
          LD     (HSC),A
          CALL   TDL         AND TRANSFER IT
          LD     HL,#1604    SET FOR 23 LINES BEGINNING AT LINE 5
          LD     (VSL),HL
          LD     A,(RPAGE)   IF TOP HALF OF RIGHT SCREEN
          AND    A
          JR     Z,MVH5      THEN

          JR     MVH6        ELSE BOTTOM
TDL       EJECT
**        TDL - TRANSFER THE DESIRED LINES
*
*         ENTRY - LINC,HSL,HSC,AND VSL ARE SET
*
*         EXIT - RETURNS VIA MTR

TDL       CALL   HSA         GET THE HIDDEN SCREEN POSITION
          PUSH   HL          AND SAVE IT

          LD     A,(VSL)     PUT VIS. SCREEN LINE # IN A
          LD     L,A
          LD     H,#E0
          CALL   BLDADD      TO SET DE AS A POINTER TO VISUAL BUFFER
          LD     A,(SCREEN)  IS IT A RIGHT SCREEN ONLY
          CP     2
          JR     Z,TDL1      IF SO

          LD     A,(HSC)
          AND    A
          JR     Z,TDL1      IF NEED TO SHIFT VIS. PNTR FOR DUAL SCREEN

          LD     BC,136      ADD OFFSET INTO VISUAL LINE
          EX     DE,HL
          ADD    HL,BC
          EX     DE,HL       DE POINTS TO VISIBLE ADDRESS

TDL1      POP    HL          HL POINTS TO HIDDEN ADDRESS
          LD     A,(LINC)    GET THE LINE COUNTER

TDL2      LD     BC,128
          LDIR               TRANSFER THE LINE
          LD     BC,136      RESET FOR NEXT LINE
          EX     DE,HL
          ADD    HL,BC
          EX     DE,HL       DE POINTS TO THE NEXT VISUAL LINE
          ADD    HL,BC       HL POINTS TO THE NEXT HIDDEN LINE
          DEC    A           DECRIMENT THE LINE COUNTER
          JP     NZ,TDL2     GO FOR MORE
          LD     BC,128      NUMBER OF CHARACTERS IN LAST LINE

*         UNDERSCORE LAST LINE EACH TRANSFER (LINE 4 OR 27)

TDL3      LDI                TRANSFER A CHARACHTER
          LD     A,(HL)      GET THE ATTRIBUTE
          OR     UNDLN       ADD THE UNDERLINE ATTRIBUTE
          LD     (HL),A      REPLACE IT
          LDI                TRANSFER THE ATTRIBUTE
          LD     A,B         AND TEST FOR LAST BYTE
          OR     C
          JP     NZ,TDL3

          JP     MTR         PROCESS MONITOR FUNCTIONS AND RETURN
MMS       EJECT
**        MMS - MOVES THE MESSAGE TO THE SCREEN

MMS       LD     A,(HL)      IS THERE A MESSAGE?
          AND    A
          JR     Z,MMS3      IF NOT

          INC    HL          GET PAGE SELECTION
          LD     A,(HL)      IS PAGE AT TOP?
          AND    A
          LD     A,B         COPY NUMERAL INTO A
          JR     NZ,MMS2     IF NOT

          LD     HL,LOWER    TRANSFER 'FOR LOWER ' MESSAGE
MMS1      LD     BC,24       SET BYTE COUNTER
          LDIR
          LD     (IX+2),A    PLACE THE NO. IN THE MESSAGE
          RET                RETURN

MMS2      LD     HL,UPPER    TRANSFER 'FOR UPPER' MESSAGE
          JR     MMS1

MMS3      LD     HL,VIS28    ERASE MESSAGE ON SCREEN
          LD     BC,24       SET BYTE COUNTER
          LDIR
          RET                RETURN
          SPACE  3
**        DTM - DISPLAY TOGGLE MESSAGE
*
*         EXIT - VIA DPL

DTM       POP    HL          RESTORE HIDDEN SCREEN ADDRESS
          LD     (HSC),HL

          LD     DE,LFTRGT   DE POINTS TO LEFT/SINGLE DISPLAY TARGET
          LD     IX,LFTRGT   AS DOES IX

          LD     A,(SCREEN)  RIGHT SCREEN ONLY DISPLAYED?
          CP     2
          JR     Z,DTM1      IF SO

          LD     B,ONE       PUT NUMERAL 1 INTO B
          LD     HL,LPTGL    HL = LPTGL
          CALL   MMS         MOVE MESSAGE TO SCREEN
          LD     A,(SCREEN)  IF LEFT SCREEN ONLY DISPLAYED
          AND    A
          JR     NZ,DPL      DISPLAY PRIORITY LINES

          LD     DE,RHTRGT   RE-AIM DESTINATION OF MESSAGE
          LD     IX,RHTRGT   AND IX

DTM1      LD     B,FIVE      PLACE NUMERAL 2 INTO B
          LD     HL,RPTGL    (HL) = IF THERE IS A RIGHT MESSAGE
          CALL   MMS         DISPLAY IT
*         JR     DPL         DISPLAY PRIORITY
DPL       EJECT
**        DPL - DISPLAY PRIORITY LINES
*
*         RETURNS VIA SETTING THE CURSOR ON COMMAND LINE

DPL       LD     HL,ERLB     SET UP BLOCK MOVE FROM PRIORITY BUFFER
          LD     DE,VIS29    TO DISPLAY RAM
          LD     BC,160
          LDIR               TRANSFER THE ERROR LINE

          LD     HL,CMLB     NOW MOVE THE COMMAND LINE
          LD     DE,VIS30    TO DISPLAY RAM
          LD     BC,160
          LDIR

          LD     A,(PRCUR)   GET COMMAND LINE CURSOR POSITION
          LD     D,A         SET UP DE AS A POINTER
          LD     E,29        LINE 29
          JP     SETDE       PUT CURSOR ON COMMAND LINE (RETURN)
          SPACE  3
**        DPB - DISPLAY ONE PRIORITY BYTE
*

DPB       LD     A,(HSL)     GET LINE NUMBER
          CP     51          IF IT IS THE ERROR LINE
          JR     Z,DPB2      THEN

          LD     DE,VIS30    COPY COMMAND LINE ADDRESS INTO DE

DPB1      LD     A,(HSC)     GET CURSOR OFFSET INTO LINE
          RLCA               DOUBLE FOR ATTRIBUTE
          LD     L,A
          LD     H,0
          ADC    HL,DE       GET VISIBLE SCREEN POSITION
          LD     (HL),B      PUT BYTE ON SCREEN
          INC    HL
          LD     A,(IY)      AND ITS ATTRIBUTE
          LD     (HL),A
          RET                RETURN

DPB2      LD     DE,VIS29    ELSE COPY ERROR LINE ADDRESS INTO DE
          JP     DPB1
PFC       TITLE  PROCESS FUNCION CODES
**        PFC - PROCESS A FUNCTION CODE.
*
*         ENTRY    A = FUNCTION CODE.

PFC       RLCA               DOUBLE FUNCTION CODE
          LD     E,A         AND PLACE IT IN DE
          LD     D,0
          LD     HL,FUNT     SET HL AS POINTER TO FUNCTION TABLE
          ADC    HL,DE       HL POINTS TO JUMP ADDRESS
          LD     D,(HL)      GET JUMP ADDRESS IN HL
          INC    HL
          LD     E,(HL)
          EX     DE,HL
          JP     (HL)        GO DO FUNCTION
          SPACE  2
**        INP - INVERSE PRIME

INP       LD     (INVPS),A   SET VALUE NON-ZERO
SIN       SET    2,(IY)      START INVERSE VIDEO
SUN       SET    1,(IY)      START UNDERLINE
          RET

**        EIP - END INVERSE PRIME

EIP       LD     HL,(HSADD)  GET THE CURSOR POSITION
          INC    HL          ADVANCE FOR THE ATTRIBUTE
          LD     A,(IY)      PLACE THE CURRENT ATTRIBUTE INTO PLACE
          LD     (HL),A
EIN       RES    2,(IY)      END INVERSE VIDEO
EUN       RES    1,(IY)      END UNDERLINE
          RET

SBL       SET    3,(IY)      START BLINK
          RET

EBL       RES    3,(IY)      END BLINK
          RET

SDI       SET    4,(IY)      START DIM
          RET

EDI       RES    4,(IY)      END DIM
          RET

BES       CALL   GNB         BEGIN EXTENDED SEQUENCE
          LD     A,B
          CP     #33
          JR     Z,DIE       IF NEXT BYTE IS A '3'

          CP     DC2
          JR     Z,LIT       TO TEST FOR TURN ON LIGHT
          CP     DC4
          RET    NZ          IF NOT A DC4
          LD     B,STX       SEND ACKNOWLEDGEMENT
          JP     SENDB       RETURN
          EJECT
DIE       XOR    A           RESET ACTIVE FUNCTION TO OFF
          LD     (HMSGA),A
          POP    HL          CLEAR STACK FOR RETURN TO RESIDENT MONITOR
          POP    HL
          LD     SP,(SPSA)   RESTORE STACK POINTER

NOOP      RET                RETURN
          SPACE  3
**        SIP - SET INVERSE PRIME

SIP       DEC    HL          BACK UP TO PREVIOUS ATTRIBUTE
          LD     A,(IY)      AND STORE THE INVERSE VIDEO ATTRIBUTE
          LD     (HL),A
          INC    HL          RESET HL
          XOR    A           RESET INVPS
          LD     (INVPS),A
          RET                RETURN
          SPACE  3


LIT       CALL   GNB
          LD     HL,LITE+2   (HL) = TURN LIGHT ON OR OFF
          LD     A,B
          CP     EE+#20
          JR     Z,LIT1      IF TURN ON LIGHT
          CP     FF+#20
          RET    NZ          IF NOT TURN OFF LIGHT
LIT1      LD     (HL),B
          CALL   GNB
          LD     HL,LITE+3   (HL) = WHICH LIGHT TO AFFECT
          LD     (HL),B
          LD     HL,LITE
          JP     DSTRNG      TURN ON/OFF LIGHT
          EJECT
**        ADC - ADVANCE CURSOR.
*
*         ENTRY    HSC, HSL = COLUMN, LINE.
*
*         EXIT     HSC, HSL & HSADD ADVANCED.

ADC       LD     A,(HSL)     IF IT IS A VISIBLE LINE
          CP     50
          LD     A,(HSC)     GET READY FOR NEXT TEST
          JP     P,ADC2      THEN TEST FOR END OF LINE

          CP     63          IF CURSOR = 63
          JR     Z,ADC3      THEN RESET TO 0
          CP     131         ELSE IF CURSOR = 131
          JR     Z,ADC4      THEN RESET TO 68

ADC1      INC    A           ELSE ADVANCE CURSOR
          LD     (HSC),A
          LD     HL,(HSADD)  GET HSADD
          INC    HL          ADVANCE IT
          INC    HL
          LD     (HSADD),HL  RESET HSADD
          RET                RETURN

ADC2      CP     79          IF CURSOR < 79
          JP     M,ADC1      THEN JUST ADVANCE IT

ADC3      XOR    A           SET COLUMN 1
          LD     (HSC),A
          JP     HAC         RESET HSADD (RETURN)

ADC4      LD     A,68
          LD     (HSC),A
          JP     HAC         RESET HSADD (RETURN)
MVC       EJECT
**        MVC - MOVE CURSOR.
*
*         RETURNS VIA HAC

MVC       CALL   GNB         GET COLUMN NUMBER
          LD     A,B         COPY BYTE INTO A
          CP     64          IF ON LEFT SCREEN
          JP     M,MVC1      THEN JUMP
          ADD    A,4         ELSE ADD 4 BLANKS FOR CENTER OF SCREEN

MVC1      LD     (HSC),A     SAVE CURSOR COLUMN
          CALL   GNB         GET LINE NUMBER
          LD     A,(PRIOR)   IF IN PRIORITY MODE
          AND    A
          JR     NZ,MVC5     THEN TEST FOR LAST TWO LINES

MVC2      LD     A,49        ELSE IF BEYOND SCREEN
          CP     B
          JP     M,HAC       THEN IGNORE BYTE & RESET HSADD (RETURN)

          LD     A,26        IF UPPER PAGE
          CP     B
          JP     P,MVC4      THEN GO SAVE LINE NUMBER

          LD     A,(HSC)     ELSE CHECK WHICH SCREEN
          CP     64
          LD     A,1         TO SET TOGGLE POSSIBLE
          JP     M,MVC3

          LD     (RPTGL),A   FOR RIGHT SCREEN
          JR     MVC4

MVC3      LD     (LPTGL),A   FOR LEFT SCREEN

MVC4      LD     A,B
          LD     (HSL),A     SAVE NEW CURSOR LINE
          JP     HAC         RESET HSADD (RETURN)

MVC5      LD     A,48        IF NOT ONE OF VISIBLE LINES
          CP     B
          JP     P,MVC2      THEN DO REGULAR TESTS

          INC    B           OTHERWISE JUMP OVER MESSAGE LINE
          INC    B
          JR     MVC4        AND SAVE LINE NUMBER
IPS       EJECT
**        IPS - INITIALIZE PAGE SELECTION
*
*         RESETS PRESENTLY SELECTED SCREEN TO TOP ONLY

IPS       LD     A,(HSC)     IF RIGHT PAGE
          CP     63
          JP     P,IPS1      THEN RESET RIGHT

          XOR    A
          LD     (LPAGE),A   ELSE SET LEFT TO TOP
          LD     (LPTGL),A   TURN TOGGLE OFF
          RET

IPS1      XOR    A
          LD     (RPAGE),A   SET TO TOP
          LD     (RPTGL),A   TURN TOGGLE OFF
          RET
          SPACE  3
**        TRC - TRANSFER AND CLEAR HIDDEN SCREEN
*

TRC       CALL   MVH         TRANSFER THE HIDDEN TO VISIBLE
*         JP     ERP         ERASE THE HIDDEN SCREEN (RET)
          SPACE  3
**        ERP - ERASE PAGE.
*
*         SETS ALL DATA TO SPACE, ALL ATTRIBUTES TO PROTECTED.

ERP       LD     A,BL        PRIME THE MOVE WITH A SPACE CHARACTER
          LD     (HSCF),A
          LD     A,PROTD     AND A PROTECT ATTRIBUTE
          LD     (HSCF+1),A

          LD     HL,HSCF     MOVE FROM HSCF
          LD     DE,HSCF+2   AND PROPOGATE FOR ALL OF THE BUFFER
          LD     BC,HSCL-HSCF
          LDIR

          LD     (ATT),A     RESET TO PROTECT
          LD     (PATT),A
          RET                RETURN
ERL       EJECT
**        ERL - ERASE TO END OF LINE
*
*         ERASES UP THROUGH COLUMN 64 OR 132 IN HIDDEN SCREEN
*         OR COLUMN 80 ON COMMAND LINE.  IF THE PREVIOUS BYTE
*         WAS A SKIP FUNCTION THE CUSOR IS BACKSPACED BEFORE
*         ERASING.  ALSO IF ON THE COMMAND LINE THE VISIBLE
*         CURSOR IS PLACED AT THIS LOCATION.

ERL       LD     A,(PREV)    TEST IF PREVIOUS BYTE WAS A NUL
          AND    A
          JR     NZ,ERL2     IF NOT

          LD     A,(HSL)     TEST IF COMMAND OR ERROR LINE
          CP     50
          LD     A,(HSC)     GET A READY FOR NEXT TEST
          JP     P,ERL1.4    IF SO

          AND    A           TEST IF NOW FIRST COLUMN LEFT SCREEN
          JR     Z,ERL1.2    IF SO

          CP     68          TEST IF NOW FIRST COLUMN RIGHT SCREEN
          JR     Z,ERL1.1    IF SO

ERL1      DEC    A           OTHERWISE JUST BACKSPACE ONE
          LD     (HSC),A
          LD     HL,(HSADD)  BACKUP THE CURSOR ADDRESS ALSO
          DEC    HL
          DEC    HL
          LD     (HSADD),HL  RESET HSADD
          JR     ERL2

ERL1.1    LD     A,131       RESET TO END OF LINE
          JR     ERL1.3

ERL1.2    LD     A,63        RESET TO END OF LINE
ERL1.3    LD     (HSC),A
          CALL   HAC         RESET HSADD
          JR     ERL2.4      GO ERASE LAST POSITION IN LINE

ERL1.4    AND    A           TEST IF NOW FIRST COLUMN PRIORITY LINE
          JR     NZ,ERL1     IF NOT

          LD     A,79        ELSE RESET TO END OF LONG LINE
          LD     (HSC),A
          CALL   HAC         RESET HSADD
          JR     ERL2.5      GO ERASE LAST POSITION IN LINE
          EJECT
ERL2      LD     A,(HSL)     TEST FOR PRIORITY LINE
          CP     50
          JP     P,ERL2.5    IF SO

ERL2.1    LD     A,(HSC)     TEST IF LEFT HIDDEN SCREEN
          CP     63
          JR     Z,ERL2.4    IF LAST CHARACHTER IN LINE
          JP     M,ERL2.3    IF SO
          CP     131         LAST CHARACTER IN RIGHT SCREEN LINE?
          JR     Z,ERL2.4    IF SO
          LD     A,131

ERL2.2    LD     HL,HSC
          SUB    (HL)        NUMBER OF CHARACTERS TO END OF LINE
          LD     C,A
          LD     B,0
          SLA    C           BC IS A BYTE COUNTER
          LD     HL,(HSADD)  HL POINTS TO (HSC,HSL) IN HIDDEN BUFFER
          LD     (HL),BL     CHANGE TO A BLANK
          INC    HL
          LD     (HL),PROTD  RESET ATTRIBUTE
          LD     D,H         COPY HL INTO DE
          LD     E,L
          INC    DE          TO POINT TO NEXT BYTE
          DEC    HL          TO POINT TO BLANK
          LDIR               COPY TO END OF LINE
          RET                RETURN

ERL2.3    LD     A,63        LAST BYTE NUMBER IN LINE
          JP     ERL2.2

ERL2.4    LD     HL,(HSADD)  (HL) =  CURSOR POSITION IN HIDDEN SCREEN
          LD     (HL),BL     ERASE LAST CHARACTER
          INC    HL
          LD     (HL),PROTD  AND RESET ATTRIBUTE
          RET

ERL2.5    LD     A,(HSL)     ERROR OR COMMAND LINE?
          CP     51
          LD     A,(HSC)     GET READY FOR NEXT TEST
          JR     Z,ERL2.6    IF ERROR LINE

          LD     (PRCUR),A   SAVE CURSOR POSITION

ERL2.6    CP     79
          JR     Z,ERL2.7    IF SO

          LD     A,79        ELSE COMPUTE # OF BYTES LEFT IN LINE
          CALL   ERL2.2
          JP     DPL         DISPLAY THE PRIORITY  LINES (RET)

ERL2.7    CALL   ERL2.4
          JP     DPL         DISPLAY THE PRIORITY LINES (RET)
BPR       TITLE  TOGGLE PRIORITY & NON-PRIORITY
**        BPR - BEGIN PRIORITY OUTPUT
*
*         THIS PROCEDURE SETS THE CURSOR, CHARACTER ATTRIBUTE
*         AND FLAGS FOR PRIORITY MODE.

BPR       LD     A,(PRIOR)   TEST IF ALREADY IN PRIORITY MODE
          AND    A
          RET    NZ          IF SO

          INC    A           ELSE SET TO PRIORITY MODE
          LD     (PRIOR),A

          LD     HL,(INVPS)  EXCHANGE INVPS AND PINVPS
          LD     A,L
          LD     L,H
          LD     H,A
          LD     (INVPS),HL

          LD     HL,(HSC)    SAVE HSC & HSL
          LD     (SAVEC),HL
          LD     HL,(PHSC)   REPLACE WITH PRIORITY CURSOR
          LD     (HSC),HL

          LD     IY,PATT     USE PRIORITY ATTRIBUTE

          JR     HAC         RESET HSADD (RETURN-HSM NOW PRIORITY MODE)
          SPACE  3
**        EPR - END PRIORITY OUTPUT

EPR       LD     A,(PRIOR)   TEST IF IN PRIORITY MODE
          AND    A
          RET    Z           IF NOT

          XOR    A           ELSE RESET PRIORITY MODE FALSE
          LD     (PRIOR),A

          LD     HL,(INVPS)  EXCHANGE INVPS AND PINVPS
          LD     A,L
          LD     L,H
          LD     H,A
          LD     (INVPS),HL

          LD     HL,(HSC)    SAVE THE PRIORITY CURSOR
          LD     (PHSC),HL
          LD     HL,(SAVEC)  RESET TO NON-PRIORITY VALUE
          LD     (HSC),HL

          LD     IY,ATT      USE NON-PRIORITY ATTRIBUTE

*         JR     HAC         RESET HSADD (RETURN-NOW NON-PRIORITY MODE)
HAC       TITLE  INTERNAL ROUTINES
**        HAC - HIDDEN SCREEN ADDRESS CHANGED
*
*         ENTRY    HSC, HSL = COLUMN, LINE.
*         EXIT     HSADD ADJUSTED = HL
*         HSA      CALLED TO NOT ALTER HSADD

HAC       CALL   HSA         GET HIDDEN SCREEN ADDRESS
          LD     (HSADD),HL  AND SAVE IT
          RET                RETURN

HSA       LD     A,(HSL)     GET LINE NUMBER
          LD     L,A         COPY INTO HL
          LD     H,0         COMPUTE LINE BIAS (8 BYTES PER LINE)
          SLA    L           TIMES 2
          SLA    L           TIMES 4
          SLA    L           TIMES 8
          RL     H           CARRY INTO H

          ADD    A,HSCM      BIAS FOR HIDDEN BUFFER ADDRESS
          LD     D,A
          LD     E,0         DE POINTS TO THE FIRST BYTE IN LINE HSL
          ADD    HL,DE       AFTER THE BIAS IS ADDED
          EX     DE,HL
          LD     A,(HSC)     GET CURSOR POSITION NUMBER
          LD     L,A         AND PLACE IT IN HL
          LD     H,0
          ADD    HL,HL       DOUBLE IT FOR BYTE OFFSET INTO LINE
          ADD    HL,DE       ADD FIRST BYTE ADDRESS
          RET                RETURN HL SET TO BYTE ADDRESS
          SPACE  3
**        GNB - GET NEXT BYTE FROM HOST.
*
*         EXIT     B = BYTE.

GNB       CALL   MTR         PROCESS MAIN TERMINAL FUNCTIONS
          JR     Z,GNB       IF NO DOWNLINE DATA

          CALL   BFTB        GET THE DATA BYTE
          EI                 ENABLE INTERRUPTS

          LD     A,H         TEST COUNT OF INPUT BUFFER
          AND    A
          RET    NZ          IF GREATER THAN 256

          LD     A,(SXOFF)   HAS AN X-OFF BEEN SENT?
          RRA
          RET    NC          IF NOT

          XOR    A           CLEAR X-OFF FLAG
          LD     (SXOFF),A
          PUSH   BC          SAVE B
          LD     B,DC1       SEND AN X-ON
          CALL   SENDB
          POP    BC          RESTORE B
          RET                RETURN
PKB       TITLE  KEYBOARD INPUT
**        PKB - PROCESS THE KEYBOARD ENTRY
*
*         IF VALID CODE TO SEND TO HOST - RETURN VIA SENDB

PKB       CALL   KINPUT      GET THE RAW KEY-CODE IN THE BUFFER
          LD     A,B         TEST IF KEY DOWN OR UP
          BIT    7,A
          JR     Z,PKB1      IF DOWN

          CP     #A5         TEST FOR CONTROL KEY UP
          JP     Z,PKB4
          CP     #9C         TEST FOR ALL POSSIBILITIES OF SHIFT KEY
          JP     Z,PKB6
          CP     #A4
          JR     Z,PKB6
          CP     #FC
          JR     Z,PKB6
          RET                OTHERWISE IGNORE KEY UP

PKB1      SUB    #10         SHIFT OFFSET INTO TABLE
          LD     HL,KBDT     GET FIRST ADDRESS OF TABLE IN HL
          LD     E,A         SET DE AS OFFSET INTO TABLE
          XOR    A
          LD     D,A
          ADC    HL,DE       HL POINTS TO KEY ENTRY
          LD     B,(HL)      COPY KEY VALUE INTO B
          CP     B           IS IT A NOOP KEY?
          JP     Z,ALARM     ALARM AND RETURN

          LD     A,#7F       TEST FOR A FUNCTION KEY
          CP     B
          JP     M,PKB3

          LD     A,(SHFT)    TEST IF SHIFT KEY IS ACTIVE
          AND    A
          JR     Z,PKB2      IF NOT

          LD     A,B
          CP     #30         TEST FOR )
          JR     Z,PKB9
          CP     #38         TEST FOR *
          JR     Z,PKB10
          CP     #39         TEST FOR (
          JR     Z,PKB11
          CP     #3D         TEST FOR +
          JR     Z,PKB12
          CP     AA          TEST FOR ALPHA
          JP     M,ALARM     IF NOT

PKB2      LD     A,(CNTRL)   TEST IF CONTROL IS ACTIVE
          AND    A
          JP     Z,SENDB     IF NOT SEND CHARACTER

          LD     A,B         COPY KEY VALUE INTO A
          SUB    #40         CONVERT TO CONTROL CHARACTER
          LD     B,A         COPY BACK INTO B

          CP     GG-#40      CONTROL G?
          JR     Z,PKB13
          CP     II-#40      CONTROL I?
          JR     Z,PKB15
          JP     ALARM       ALARM AND RETURN

PKB3      LD     A,B         COPY FUNCTION CODE INTO A
          SUB    #F1
          RLCA               DOUBLE FUNCTION CODE
          LD     E,A         AND PLACE IT IN DE
          LD     D,0
          LD     HL,FKJT     SET HL AS POINTER TO FUNCTION TABLE
          ADC    HL,DE       HL POINTS TO JUMP ADDRESS
          LD     D,(HL)      GET JUMP ADDRESS IN HL
          INC    HL
          LD     E,(HL)
          EX     DE,HL
          JP     (HL)        GO DO FUNCTION

PKB4      XOR    A           CLEAR
PKB5      RRCA               DIVIDE A BY TWO
          LD     (CNTRL),A   OR SET CONTROL FLAG
          RET                RETURN

PKB6      XOR    A           CLEAR
PKB7      LD     (SHFT),A    OR SET SHIFT FLAG
          RET                RETURN

PKB8      LD     HL,PRINTS   SET HL TO MESSAGE TO
          JP     DSTRNG      ACTIVATE PRINT ROUTINE (RETURN)
PKB9      LD     B,#29       SEND A )
          JP     SENDB
PKB10     LD     B,#2A       SEND A *
          JP     SENDB
PKB11     LD     B,#28       SEND A (
          JP     SENDB
PKB12     LD     B,#2B       SEND A +
          JP     SENDB

PKB13     CALL   INIT02      CLEAR INPUT AND OUTPUT BUFFERS
          JP     SENDB       SENT A CONTROL CHARACTER (RETURN)

PKB14     LD     A,(SHFT)
          AND    A
          JP     Z,ALARM     IF SHIFT NOT ACTIVE
          LD     B,II-#40

PKB15     CALL   PKB13
          JP     DIE
FUN       TITLE  PROCESS FUNCTION KEYS
**        FUN - PROCESS DEFINED KEYPRESS

FUN1      LD     A,(LPTGL)   IF NOT POSSIBLE TO TOGGLE TO OTHER PAGE
          AND    A
          RET    Z           THEN RETURN
          LD     HL,LPAGE    ELSE GET CURRENT SELECTION
          JR     FUN5.1
          SPACE  2
FUN2      LD     A,1         SET SCREEN CHOICE TO LEFT ONLY
          LD     (SCREEN),A
          LD     B,3         NOTIFY HOST F2 SELECTED
          JP     SENDB
          SPACE  2
FUN3      XOR    A           SET SCREEN CHOICE TO DUAL
          LD     (SCREEN),A
          LD     B,4         NOTIFY HOST F3 SELECTED
          JP     SENDB
          SPACE  2
FUN4      LD     A,2         SET SCREEN CHOICE TO RIGHT ONLY
          LD     (SCREEN),A
          LD     B,5         NOTIFY HOST F4 SELECTED
          JP     SENDB
          SPACE  2
FUN5      LD     A,(RPTGL)   IF NOT POSSIBLE TO TOGGLE RIGHT SCREEN
          AND    A
          RET    Z           THEN RETURN
          LD     HL,RPAGE    ELSE GET CURRENT SLECTION

FUN5.1    LD     A,(HL)
          CPL                TOGGLE IT
          LD     (HL),A      AND REPLACE IT
          LD     B,2         NOTIFY HOST REFRESH NEEDED
          JP     SENDB

FUN6      LD     B,RS        SEND MULTIPLE CODE SEQUENCE
          CALL   SENDB
          LD     A,(SHFT)    TEST IF SHIFT KEY IS ACTIVE
          AND    A
          JR     Z,FUN6.1    IF NOT
          LD     B,FF+#20    SEND A LOWER CASE F
          JR     FUN6.2      CONTINUE
FUN6.1    LD     B,VV+#20    SEND A LOWER CASE V
FUN6.2    JP     SENDB       REURN

FUN7      LD     B,RS        SEND MULTIPLE CODE SEQUENCE
          CALL   SENDB
          LD     B,WW+#20
          JP     SENDB
HELP      EJECT
HELP      CALL   KINPUT      GET RID OF HELP KEY UP
          CALL   CRT80       SET TO 80 COL FORMAT AND CLEAR SCREEN
          LD     A,80        CHANGE LNSIZE
          LD     (LNSIZE),A
          LD     A,(LPAGE)   PLACE PROPER MESSAGE FOR LEFT SCREEN
          LD     DE,LPI
          CALL   DPM
          LD     A,(RPAGE)   PLACE PROPER MESSAGE FOR RIGHT SCREEN
          LD     DE,RPI
          CALL   DPM
          LD     A,(SCREEN)  IF SCREEN = DUAL
          AND    A
          JR     Z,HELPB     THEN

          CP     1           ELSE IF SCREEN = LEFT
          JR     Z,HELPA     THEN
          LD     DE,LPOI     PUT NO UNDER LEFT
          CALL   DNO
          LD     DE,DPOI     AND UNDER DUAL
          CALL   DNO
          LD     DE,RPOI     PUT YES UNDER RIGHT
          JR     HELPC

HELPA     LD     DE,DPOI     PUT NO UNDER DUAL
          CALL   DNO
          LD     DE,RPOI     AND UNDER RIGHT
          CALL   DNO
          LD     DE,LPOI     PUT YES UNDER LEFT
          JR     HELPC

HELPB     LD     DE,LPOI     PUT NO UNDER LEFT
          CALL   DNO
          LD     DE,RPOI     AND UNDER RIGHT
          CALL   DNO
          LD     DE,DPOI     PUT YES UNDER DUAL

HELPC     LD     C,4         BC = 4
          LDIR               HL = ' YES'
          LD     HL,HELPMSG  DISPLAY THE HELP MESSAGE
          CALL   DSTRNG
          CALL   DPL         DISPLAY THE PRIORITY LINES

HELPD     CALL   MTR         PROCESS MONITOR FUNCTIONS WHILE WAITING
          LD     A,(KBCNT)   IF NO KEYBOARD ENTRY
          AND    A
          JR     Z,HELPD     THEN LOOP
          LD     B,2         NOTIFY HOST TO REFRESH SCREEN
          JP     SENDB       AND RETURN
DPM       EJECT
**        DPM - PLACES PROPER MESSAGE IN HELP DISPLAY
*
*         ENTRY DE POINTS TO TARGET 'A' CONTAINS VALUE OF PAGE SELECTION

DPM       AND    A
          JR     NZ,DPM2     USE BOTTOM
          LD     HL,TOP
DPM1      LD     BC,5        BYTE COUNTER
          LDIR
          RET                RETURN

DPM2      LD     HL,BOTTOM
          JR     DPM1
          SPACE  3
**        DNO - PLACES A 'NO' IN THE HELP DISPLAY
*
*         ENTRY DE POINTS TO TARGET

DNO       LD     HL,NO       HL POINTS TO '  NO'
          LD     C,4         BC=4 AS BYTE COUNTER
          LDIR               TRANSFER
          RET                RETURN
VAR       TITLE  VARIABLES
**        VARIABLES
*
*         ORDER IS CRITICAL FOR SEVERAL PAIRS :
*            HSC/HSL, VSL/LINC, LPTGL/LPAGE, RPTGL/RPAGE, INVPS/PINVPS

HSC       CON    0           HIDDEN SCREEN CURSOR COLUMN (0..131)
HSL       CON    0           HIDDEN SCREEN CURSOR LINE (0..49,51,52)

VSL       CON    0           LINE NUMBER ON VISIBLE SCREEN
LINC      CON    0           NUMBER OF LINES TO TRANSFER TO VISIBLE

LPTGL     CON    0           LEFT PAGE TOGGLE POSSIBLE (BOOLEAN) 0=FALSE
LPAGE     CON    0           BOOLEAN FOR LEFT BOTTOM SELECTED 0=FALSE

RPTGL     CON    0           RIGHT PAGE TOGGLE POSSIBLE (BOOLEAN)0=FALSE
RPAGE     CON    0           BOOLEAN FOR RIGHT BOTTOM SELECTED 0=FALSE

INVPS     CON    0           BOOLEAN FOR NON-PRIORITY INVERSE PRIME
PINVPS    CON    0           BOOLEAN FOR PRIORITY INVERSE PRIME 0=FALSE

SCREEN    CON    0           CONTAINS SCREEN SELECTION   0 = DUAL
                             *                           1 = LEFT ONLY
                             *                           2 = RIGHT ONLY

PREV      CON    0           PREVIOUS DATA BYTE USED TO TEST FOR ADC

HSADD     CON    0,#50       STORAGE SPACE FOR HIDDEN SCREEN ADDRESS

SPSA      CON    0,0         STACK POINTER SAVE AREA

PHSC      CON    0           PRIORITY CURSOR COLUMN

PHSL      CON    52          PRIORITY LINE NUMBER PRESET TO COMMAND LINE

PRCUR     CON    0           PRIORITY CURSOR POSITION

PRIOR     CON    0           BOOLEAN FOR IN PRIORITY MODE 0 = FALSE

ATT       CON    PROTD       CURRENT ATTRIBUTE FOR STORING IN BUFFER

PATT      CON    PROTD       CURRENT PRIORITY ATTRIBUTES

SAVEC     CON    0,0         SPACE FOR SAVING CURSOR WHEN CHANGING MODE

SHFT      CON    0           BOOLEAN FOR SHIFT KEY ACTIVE 0=FALSE

*         Function Table

FUNT      VFD    16/ADC,16/INP,16/MVC      NUL,SOH,STX
          VFD    16/EIP,16/TRC,16/NOOP     ETX,EOT,ENQ
          VFD    16/SUN,16/ALARM,16/NOOP   ACK,BELL,BS
          VFD    16/NOOP,16/NOOP,16/NOOP   HT,LF,VT
          VFD    16/NOOP,16/NOOP,16/SBL    FF,CR,SO
          VFD    16/EBL,16/SIN,16/NOOP     SI,DLE,DC1
          VFD    16/NOOP,16/NOOP,16/EIN    DC2,DC3,DC4
          VFD    16/EUN,16/NOOP,16/MVH     NAK,SV,ETB
          VFD    16/ERP,16/IPS,16/EPR      CLR,RSET,SUB
          VFD    16/ERL,16/SDI,16/EDI      ESC,FS,GS
          VFD    16/BES,16/BPR             RS,US
          EJECT
*         Keyboard Table

KBDT      CON    #FD,#2B,#28,#2D,#29,#00    PRINT,(,',-,),
          CON    #37,#34,#00,#15,#00        7,4,SETUP,->:,LOCK
          CON    #15,#FB,#FA,#38,#35        ->:,SHIFT,BREAK,8,5
          CON    #F1,#31,#41,#51,#FB,#FC    F1,1,A,Q,SHIFT,CONTROL
          CON    #39,#36,#F2,#32,#53        9,6,F2,2,S
          CON    #57,#5A,#20,#00,#00        W,Z,SPACE,
          CON    #F3,#33,#44,#45,#58,#00    F3,3,D,E,X,
          CON    #00,#00,#F4,#34,#46        TERM ANS,ESC,F4,4,F
          CON    #52,#43,#0D,#2E,#33        R,C,NEXT,.,3
          CON    #F5,#35,#47,#54,#56,#00    F5,5,G,T,V,
          CON    #30,#32,#F6,#36,#48        0,2,F6,6,H
          CON    #59,#42,#00,#2C,#31        Y,B,STOP,,,1
          CON    #F7,#37,#4A,#55,#4E,#2A    F7,7,J,U,N,F15
          CON    #00,#00,#00,#38,#4B        LAB, ,F8,8,K
          CON    #49,#4D,#00,#00,#00        I,M,BACK, ,EDIT
          CON    #00,#39,#4C,#4F,#2C,#00    F9,9,L,O,,,
          CON    #0D,#0D,#00,#30,#00        NEXT,,F10,0,;
          CON    #50,#2E,#F9,#FE,#00        P,.,CLEAR,HELP,COPY
          CON    #00,#2D,#00,#00,#2F,#00    F11,-,',[,/,DLETE
          CON    #08,#19,#00,#3D,#00        BS,ERASE,F12,=,{
          CON    #00,#FB,#00,#00,#19         ,SHIFT, ,`,:<-

*         Function Key Jump Table

FKJT      VFD    16/FUN1,16/FUN2,16/FUN3    F1,F2,F3
          VFD    16/FUN4,16/FUN5,16/FUN6    F4,F5,F6
          VFD    16/FUN7,16/ALARM,16/PKB14  F7,F8,CLEAR
          VFD    16/MVH,16/PKB7,16/PKB5     BREAK,SHIFT,CONTROL
          VFD    16/PKB8,16/HELP            PRINT,HELP

*         Toggle Messages

UPPER     CON    FF,#80,BL,#80,BL,#80
          CON    FF,#80,OO,#80,RR,#80
          CON    BL,#80,UU,#80,PP,#80
          CON    PP,#80,EE,#80,RR,#80

LOWER     CON    FF,#80,BL,#80,BL,#80
          CON    FF,#80,OO,#80,RR,#80
          CON    BL,#80,LL,#80,OO,#80
          CON    WW,#80,EE,#80,RR,#80

TOP       CON    UU,PP,PP,EE,RR
BOTTOM    CON    LL,OO,WW,EE,RR
NO        CON    BL,BL,BL,BL
YES       CON    BL,YY,EE,SS

*         Help Message

HELPMSG   CON    STX,60,33,RS,DD,BL,HH
          CON    EE,LL,PP,BL,BL,SS,CC
          CON    RR,EE,EE,NN,BL,RS,EE
          CON    STX,49,36,ACK,KK,EE,YY
          CON    STX,65,36,FF,UU
          CON    NN,CC,TT,II,OO,NN,NAK
          CON    STX,49,38,FF,49
          CON    STX,65,38,TT,OO,GG,GG
          CON    LL,EE,SS,BL,UU,PP,PP
          CON    EE,RR,47,LL,OO,WW,EE
          CON    RR,BL,LL,EE,FF,TT,BL
          CON    SS,CC,RR,EE,EE,NN
          CON    STX,49,39,FF,50
          CON    STX,65,39,VV,II,EE,WW
          CON    BL,LL,EE,FF,TT,BL
          CON    SS,CC,RR,EE,EE,NN,BL
          CON    OO,NN,LL,YY
          CON    STX,49,40,FF,51
          CON    STX,65,40,VV,II,EE,WW
          CON    BL,LL,EE,FF,TT,BL
          CON    AA,NN,DD,BL
          CON    RR,II,GG,HH,TT,BL
          CON    SS,CC,RR,EE,EE,NN,SS
          CON    STX,49,41,FF,52
          CON    STX,65,41,VV,II,EE,WW
          CON    BL,RR,II,GG,HH,TT,BL
          CON    SS,CC,RR,EE,EE,NN,BL
          CON    OO,NN,LL,YY
          CON    STX,49,42,FF,53
          CON    STX,65,42,TT,OO,GG,GG
          CON    LL,EE,SS,BL,UU,PP,PP
          CON    EE,RR,47,LL,OO,WW,EE
          CON    RR,BL,RR,II,GG,HH,TT
          CON    BL,SS,CC,RR,EE,EE,NN
          CON    STX,49,44,DD,OO,WW,NN
          CON    STX,65,44,VV,II,EE,WW
          CON    BL,NN,EE,XX,TT,BL
          CON    PP,AA,GG,EE,BL
          CON    LL,EE,FF,TT,BL
          CON    SS,CC,RR,EE,EE,NN
          CON    STX,49,45,UU,PP
          CON    STX,65,45,VV,II,EE,WW
          CON    BL,PP,RR,EE,VV,II,OO
          CON    UU,SS,BL,PP,AA,GG,EE
          CON    BL,LL,EE,FF,TT,BL
          CON    SS,CC,RR,EE,EE,NN
          CON    STX,49,46,FF,WW,DD
          CON    STX,65,46,VV,II,EE,WW
          CON    BL,NN,EE,XX,TT,BL
          CON    PP,AA,GG,EE,BL
          CON    RR,II,GG,HH,TT,BL
          CON    SS,CC,RR,EE,EE,NN
          CON    STX,49,47,BB,KK,WW,
          CON    STX,65,47,VV,II,EE,WW
          CON    BL,PP,RR,EE,VV,II,OO
          CON    UU,SS,BL,PP,AA,GG,EE
          CON    BL,RR,II,GG,HH,TT,BL
          CON    SS,CC,RR,EE,EE,NN
          CON    STX,49,49,45,45,62,#7C
          CON    STX,65,49,AA,DD,VV,AA
          CON    NN,CC,EE,BL,DD,SS,DD
          CON    47,DD,II,SS,BL
          CON    DD,II,SS,PP,LL,AA,YY
          CON    STX,49,50,FF,49,53
          CON    STX,65,50,TT
          CON    OO,GG,GG,LL,EE,BL,BB
          CON    EE,TT,WW,EE,EE,NN,BL
          CON    DD,SS,DD,45,DD,II,SS
          CON    STX,49,51,#7C,60,45,45
          CON    STX,65,51,CC,LL,EE,AA
          CON    RR,BL,II,NN,PP,UU,TT
          CON    BL,LL,II,NN,EE
          CON    STX,49,52
          CON    CC,TT,RR,LL,BL,II,
          CON    STX,65,52,RR,EE,45
          CON    II,NN,SS,TT,AA,LL,LL
          CON    BL,CC,OO,NN,TT,RR,OO
          CON    LL,WW,AA,RR,EE
          CON    STX,59,54,ACK
          CON    CC,UU,RR,RR,EE,NN,TT
          CON    BL,SS,CC,RR,EE,EE,NN
          CON    BL,SS,TT,AA,TT,UU,SS
          CON    NAK,STX,49,56,RS,DD
          CON    BL,LL,EE,FF,TT,BL
          CON    RS,EE,BL,BL,BL,RS,DD
          CON    BL,LL,EE,FF,TT,BL
          CON    RS,EE,BL,BL,BL,RS,DD
          CON    BL,DD,UU,AA,LL,BL
          CON    RS,EE,BL,BL,BL,RS,DD
          CON    RR,II,GG,HH,TT,BL
          CON    RS,EE,BL,BL,BL,RS,DD
          CON    RR,II,GG,HH,TT,BL
          CON    RS,EE
          CON    STX,47,57,FF,49,RS,DD
LPI       CON    BL,BL,BL,BL,BL,BL
          CON    RS,EE,BL,FF,50,RS,DD
LPOI      CON    BL,BL,BL,BL,BL,BL
          CON    RS,EE,BL,FF,51,RS,DD
DPOI      CON    BL,BL,BL,BL,BL,BL
          CON    RS,EE,BL,FF,52,RS,DD
RPOI      CON    BL,BL,BL,BL,BL,BL
          CON    RS,EE,BL,FF,53,RS,DD
RPI       CON    BL,BL,BL,BL,BL,BL
          CON    RS,EE
          CON    STX,53,59
          CON    PP,RR,EE,SS,SS,BL,AA
          CON    NN,YY,BL,KK,EE,YY,BL
          CON    TT,OO,BL,EE,XX,II,TT
          CON    BL,HH,EE,LL,PP,BL
          CON    SS,CC,RR,EE,EE,NN,#FF

*         Activates Print Routine

PRINTS    CON    RS,STX,#FF

*         Places a Message on First Blank Screen

FRSTMSG   CON    STX,60,46
          CON    RR,EE,CC,EE,II,VV,II
          CON    NN,GG,BL,
          CON    FF,II,RR,SS,TT,BL
          CON    SS,CC,RR,EE,EE,NN,#FF

*         Turn On/Off Program light 1-2

LITE      CON    RS,DC2,EE+#20,ONE,#FF

*         Sets Terminal to 30 Line Screen

LINE30    CON    RS,DC2,#5E,#FF

          END
/EOR
*DECK DECK=CTM$SYSTEM_CONSOLE_INTERFACE EXPAND=TRUE

          IDENT  SCI,70B
          CIPPU  J
          MEMSEL 8
          BASE   MIXED
 SCILVL   MICRO  1,, 10      *SCI* RELEASE LEVEL MICRO
          TITLE CTM$SYSTEM CONSOLE INTERFACE (SCI - LEVEL "SCILVL").
          COMMENT *SMD* LVL="SCILVL"
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 CTMSCI   SPACE  4,10
***       SCI - SYSTEM CONSOLE INTERFACE.
 CTMSCI   SPACE  4,10
***       CTM$SYSTEM CONSOLE INTERFACE.
*
*         *SCI* IS COMPRISED OF THE FUNCTIONALITIES OF THE OLD *VPB*
*         (NOS/VE PP BOOT), *SCD* (SYSTEM CONSOLE DRIVER), AND *MDD*
*         (MONITOR DISPLAY DRIVER) PROGRAMS.
*
*         *SCI* SUPPLIES THE NOS AND NOS/VE OPERATING SYSTEMS WITH A CC634B
*         (CDC721) CONSOLE, AND SUPPLIES NOS, NOS/BE, AND NOS/VE WITH ANALYST OR
*         MAINTENANCE FUNCTIONS ON THE SAME OR A DIFFERENT CONSOLE.  *SCI*
*         SUPPLIES THE FUNCTIONS PROVIDED BY DISCRETE PROGRAMS *SCD*, *VPB*,
*         AND *MDD* IN EARLIER LEVELS OF CIP.
 HISTORY  SPACE  4,10
***       *SCI* RELEASE HISTORY.
*
*         LEVEL 01 - RELEASED WITH CIP007 AND NOS/VE 1.2.2, APRIL 1987.
*
*         LEVEL 99 - CONTAINED FIXES FOR A VARIETY OF PROBLEMS IN THE
*                    ORIGINAL CIP007 RELEASE.  CIP007 RE-RELEASED, JUNE 1987.
*
*         LEVEL 02 - RELEASED WITH CIP008 AND NOS/VE 1.2.3, SEPT. 1987.
*
*         LEVEL 98 - CONTAINED LRZ DUAL I4 PRE-RELEASE CODE, OCT. 1987.
*
*         LEVEL 97 - CONTAINED FIX FOR NV03447 IN WHICH SCI WAS CORRUPTING
*                    BYTE 0 OF D7ST.  SENT TO SITE UMTL, FEB. 1988.
*
*         LEVEL 03 - RELEASED WITH CIP009 AND NOS/VE 1.3.1, APRIL 1988.
*
*         LEVEL 96 - RELEASED WITH CIP LEVEL 710, SEPTEMBER 1988.
*
*         LEVEL 04 - RELEASED WITH CIP LEVEL 716 AND NOS/VE 1.4.1, DECEMBER 1988.
*
*         LEVEL 05 - RELEASED WITH CIP LEVEL 727 AND NOS/VE 1.4.2, JUNE 1989.
*
*         LEVEL 06 - RELEASED WITH CIP LEVEL 739 AND NOS/VE 1.5.1, DECEMBER 1989.
*
*         LEVEL 07 - RELEASED WITH CIP LEVEL 757 AND NOS/VE 1.5.3, SEPTEMBER 1990.
*
*         LEVEL 08 - RELEASED WITH CIP LEVEL 765 AND NOS/VE 1.5.3, FEBRUARY 1991.
*
*         LEVEL 95 - CONTAINED FIX FOR SCI FAILING TO RELOCATE (NV0U996).
*                    SENT TO SITE FOR NV08708, APRIL, 1991.
*
*         LEVEL 94 - CONTAINED FIX FOR SCI NOT WORKING WITH OLD NOS/BE SYSTEM.
*                    SENT TO SITE FOR NV08832, APRIL, 1991.
*
*         LEVEL 93 - COMBINED FIX FOR NV0U996 AND NV08832 IN BCU L765AB AND LATER
*                    L765 BCU-S.
*
*         LEVEL 09 - RELEASED WITH CIP LEVEL 780 AND NOS/VE 1.6.1, SEPTEMBER 1991.
*
*         LEVEL 10 - RELEASED WITH BCU L780AB, FIRST QUARTER 1992.
 COMMON   SPACE  4,10
*         COMMON DECKS.


*COPY     CTC$BOOT_CONTROL_TABLE
*COPY     CTC$EI_CONTROL_BLOCK
*COPY     DSA$HARDWARE_TABLE_DEFINITIONS
*COPY     DSA$VE_REQUESTS_TO_DFT
*COPY     DSC$PP_MR_AND_TPM_CONSTANTS
*COPY     DSI$MAINTENANCE_REGISTER_MACROS
*COPY     DSI$PP_INSTRUCTION_MNEMONICS
*COPY     DSI$PP_MACROS
          TITLE  OVERVIEW DOCUMENTATION.
 PRESET   SPACE  4,10
***       *SCI* PRESET.
*
*         WHEN *SCI* PRESET IS LOADED FROM THE CIP AREA OF CENTRAL
*         MEMORY, CERTAIN INFORMATION IS PASSED IN DIRECT CELLS:
*
*         ENTRY  (27) = 0, IF INITIATED BY *CTI*.
*                     = PP NUMBER, IF INITIATED BY *SDA* IN DUAL-STATE.
*                     = 2000 + PP NUMBER, IF INITIATED BY C170 *X.MDD*.
*                     = 4000 + PP NUMBER, IF RELOCATED BY *DFT*.
*                     = 177777, IF INITIATED BY THE SERVICE PROCESSOR
*                            IN A SERVICE PROCESSOR ENVIRONMENT.
*                     = 174000, IF RESTARTED BY SERVICE PROCESSOR.
*                (30 - 32) = R-POINTER TO *SCI* CODE IN CIP AREA.
*                (33) = 1 IF INITIATED FOR *UTILITY MDD* MODE.
*                     = 0 FOR ALL OTHER MODES.
*                (34 - 36) = R-POINTER TO *CIP* DIRECTORY.
*
*         IN A NON-CYBER 2000 ENVIRONMENT:
*
*         *SCI* PRESET LOOKS AT THE MRT TO DETERMINE IN WHICH MODE(S) IT
*         SHOULD FUNCTION.  DEADSTART *MDD* MODE TAKES PRECEDENCE AND IS
*         PERFORMED BEFORE *VPB* DEADSTART FUNCTIONS ARE INITIATED.  TO
*         DEADSTART STANDALONE NOS/VE, THE *F7* FUNCTION KEY ON THE *MDD*
*         CONSOLE MUST BE USED.
*
*         THE PP MEMORY IS ZEROED THEN THE RESIDENT OVERLAY IS LOADED AND
*         CONTROL IS PASSED TO THE OVERLAY WHICH ACQUIRES TPM ACCESS FOR
*         THE *MDD* AND/OR *SCD* MODES.
*
*         IN A CYBER 2000 ENVIRONMENT:
*
*         *SCI* PRESET READS REQUIRED INFORMATION FROM THE BOOT CONTROL
*         TABLE AND PERFORMS *VPB* FUNCTIONS FOR THE CYBER 2000 BEFORE
*         CONTINUING ON TO NOS/VE *SCD* MODE.  *MDD* AND NOS *SCD* MODES
*         ARE NOT VALID MODES ON A CYBER 2000 MAINFRAME.
 IDLE     SPACE  4,10
***       IDLE LOOP AND RESIDENT ROUTINES.
*
*         BY SERVICING BOTH *SCD* AND *MDD* ON EVERY PASS THROUGH THE IDLE
*         LOOP, EACH OF THESE MODES IS ENSURED THAT IT HAS AN OPPORTUNITY
*         TO PROCESS ANY INPUT IT HAS RECEIVED FROM THE TWO PORT MUX,
*         CENTRAL MEMORY OR FROM THE OPERATING SYSTEM.
*
*         BY ALTERNATING ACCESS TO THE TWO PORT MUX BOTH *MDD* AND *SCD*
*         HAVE A CHANCE TO RECEIVE INPUT OR HANDLE ANY OUTPUT THEY HAVE
*         TO THE TERMINAL (CONSOLE).
*
*         THE *TIM* SUBROUTINE USES CHANNEL 14 TO MAINTAIN A REAL-TIME
*         CLOCK MECHANISM.  TABLE *ACTB* PROVIDES A MECHANISM TO EXECUTE
*         CERTAIN ROUTINES ON A TIMED PERIODIC BASIS.  THE ROUTINES IN THIS
*         TABLE HANDLE INACTIVE *SCD* STATES, CHECK IF THERE IS A NEED TO
*         DEADSTART OR TERMINATE NOS/VE, SHARE THE TPM WITH OTHER TPM-ACCESS
*         PP ROUTINES, AND CHECK FOR CHANGES TO THE *SCI* PARAMETER TABLE
*         IN CENTRAL MEMORY.
          SPACE  4,10
***       REQUIRED REFERENCES.
*
*         CDC 721 SYSTEM CONSOLE.............................ARH5782.
*         CDC 721 AUGMENTATION CONTROLWARE ERS...............ARH6192.
*         SCI/MONITOR DISPLAY DRIVER ERS.....................ARH7881.
*         NOS/VE SYSTEM CONSOLE DESIGN DIRECTION.............ARH6451.
*         SCD INTERFACE SPECIFICATION........................ARH5783.
*         CTI INTERFACE SPECIFICATION........................ARH2984.
*         DFT/OS INTERFACE SPECIFICATION - TABLE FORMATS.....ARH6853.
          SPACE  4,10
***       DICTIONARY.
*
*         EICB - ENVIRONMENTAL INTERFACE CONTROL BLOCK.
*         SCDCB - SCD COMMUNICATIONS BLOCK WITH NOS/VE.
*         TPM - TWO PORT MUX.
*         SCIPT - SCI PARAMETER TABLE.
          TITLE  MONITOR DISPLAY DRIVER (*MDD*) DOCUMENTATION.
 MDD      SPACE  4,10
***       MONITOR DISPLAY DRIVER (*MDD*) MODE.
*
*         *MDD* IS BROKEN INTO TWO MAIN OVERLAY FUNCTIONALITIES.  THESE ARE
*         THE RESIDENT *MDD* CODE AND SEVERAL *MDD* OVERLAYS.
*
*         *MDD* RESIDENT CONTAINS CODE WHICH IS USED BY COMMAND OVERLAYS
*         AND CODE USED TO COMPUTE THE ROUTINE NEEDED BY A NEW COMMAND.
*
*         OTHER OVERLAYS CONTAIN THE CODE TO EXECUTE SPECIFIC COMMANDS AND
*         AN OVERLAY WHICH CONTAINS A LIST OF COMMANDS AND PARAMETERS
*         FOR A SPECIFIC MAINFRAME.
 TABLES   SPACE  4,10
***       *MDD* TABLE STRUCTURES.
*
*         *MDD* USES SEVERAL TABLES TO PROCESS COMMANDS.  EACH COMMAND IS
*         DESCRIBED BY A COMMAND TABLE ENTRY, WHICH MAY HAVE ONE OR MORE
*         PARAMETERS, AND BY A HELP ENTRY.
*
 CMND     SPACE  4,20
***       *MDD* COMMAND TABLE STRUCTURE.
*
*         COMMAND TABLE ENTRIES ARE 5 WORDS IN LENGTH:
*
* CMND    16/ *XX*
* CMND+1  10/ VALID, 6/ OVL
* CMND+2  4/, 12/ ADDR
* CMND+3  16/ PTBL
* CMND+4  16/ DTYP
*
*         XX = COMMAND MNEMONIC.
*         VALID = BIT MASK INDICATING VALID MAINFRAME(S).
*         OVL = OVERLAY NUMBER FOR COMMAND PROCESSOR.
*         ADDR = ADDRESS OF COMMAND PROCESSOR.
*         PTBL = ADDRESS OF PARAMETER TABLE FOR THIS COMMAND.
*         DTYP = NUMERIC PARAMETER DECODE TYPE.
 PRMT     SPACE  4,20
***       *MDD* PARAMETER TABLE STRUCTURE.
*
*         PARAMETER TABLE ENTRIES HAVE TWO FORMATS:
*
*                FORMAT 1: USED FOR NON-KEYWORD PARAMETERS:
*
* PRMC    4/, 1/ 0, 11/ SIZE
* PRMC+1  16/ ETBL
*
*         SIZE = SIZE OF CONVERTED PARAMETER VALUE IN PP WORDS.
*         ETBL = ADDRESS OF EQUIVALENCE TABLE.
*
*                FORMAT 2: USED FOR PARAMETERS WITH KEYWORD VALUES:
*
* PRMC    4/, 1/ 1, 11/ SIZE
* PRMC+1  16/ ETBL
* PRMC+2  16/ ADDR
*
*         SIZE = SIZE OF CONVERTED PARAMETER VALUE IN PP WORDS.
*         ETBL = ADDRESS OF EQUIVALENCE TABLE.
*         ADDR = ADDRESS OF NEXT PARAMETER TABLE (FORWARD LINK).
 ETBL     SPACE  4,20
***       *MDD* EQUIVALENCE TABLE STRUCTURE.
*
*         EQUIVALENCE TABLE ENTRIES ARE 3 WORDS IN LENGTH:
*
* ETBL    16/ *XX*
* ETBL+1  16/ PTBL
* ETBL+2  16/ ADDR
*
*         XX = PARAMETER MNEMONIC.
*         PTBL = ADDRESS OF ASSOCIATED PARAMETER TABLE ENTRY.
*         ADDR = ADDRESS OF CONVERTED VALUE.
 HELP     SPACE  4,15
***       *MDD* HELP TABLE STRUCTURE.
*
*         HELP ENTRIES ARE 2 WORDS IN LENGTH:
*
* HELP    16/ VALID
* HELP+1  16/ ADDR
*
*         VALID = BIT MASK INDICATING VALID MAINFRAME(S).
*         ADDR = ADDRESS OF HELP TEXT.
          TITLE  SYSTEM CONSOLE DRIVER (*SCD*) DOCUMENTATION.
 SCD      SPACE  4,10
***       SYSTEM CONSOLE DRIVER (*SCD*) MODE.
*
*         *SCD* PROVIDES THE INTERFACE TO THE CC634B (CDC 721) TERMINAL
*         FOR THE OPERATING SYSTEM(S).
*
*         FOR THE C170 BASED OPERATING SYSTEM, *SCD* TRANSLATES CC545 LIKE
*         FUNCTIONS AND DATA INTO A USABLE FORM ON THE CC634B.  THIS
*         TRANSLATION IS AIDED THROUGH CONTROLWARE AUGMENTATION SOFTWARE
*         IN THE CC634B THAT *SCD* DOWNLOADS WHEN CONFIGURING THE TERMINAL.
*
*         FOR THE C180 BASED OPERATING SYSTEM, *SCD* READS FROM CENTRAL
*         MEMORY TO OBTAIN COMMANDS AND POINTERS TO LINES TO BE OUTPUT TO
*         THE CC634B.  NO CONTROLWARE IS DOWNLOADED TO THE CC634B.
 CC545    SPACE  4,10
***       CC545 TERMINAL EMULATION.
*
*         DATA RECEIVED FROM THE OPERATING SYSTEM IS IN THREE CLASSES:
*         CC545 LIKE FUNCTIONS -
*                160400 = READ KEYBOARD                    (7020 * 2**4).
*                160000 = SELECT OUTPUT LEFT               (7000 * 2**4).
*                162000 = SELECT OUTPUT RIGHT              (7100 * 2**4).
*                160100 = SELECT PRIORITY OUTPUT LEFT      (7004 * 2**4).
*                162100 = SELECT PRIORITY OUTPUT RIGHT     (7104 * 2**4).
*                170020 = SELECT *SCD*INITIALIZATION       (7401 * 2**4).
*                170040 = SET CHANNEL 10 CHANNEL FLAG      (7402 * 2**4).
*
*         CC634B SPECIFIC FUNCTIONS -
*                010000 = ERASE TO END OF LINE              (400 * 2**4).
*                010020 = CLEAR HIDDEN BUFFER               (401 * 2**4).
*                010040 = RESET DISPLAY PAGE SELECTION      (402 * 2**4).
*                010060 = TRANSFER HIDDEN TO VISIBLE        (403 * 2**4).
*                010100 = TRANSFER AND CLEAR                (404 * 2**4).
*                010120 = NEXT WORD ON CH. IS SPECIAL CHAR. (405 * 2**4).
*                010140 = START INVERSE ON PREV. CHARACTER  (406 * 2**4).
*                010160 = END INVERSE ON NEXT CHARACTER     (407 * 2**4).
*                010200 = START UNDERSCORE                  (410 * 2**4).
*                010220 = END UNDERSCORE                    (411 * 2**4).
*                010240 = START BLINK                       (412 * 2**4).
*                010260 = END BLINK                         (413 * 2**4).
*                010300 = START REDUCED INTENSITY           (414 * 2**4).
*                010320 = END REDUCED INTENSITY             (415 * 2**4).
*                010340 = START INVERSE/UNDERSCORE          (416 * 2**4).
*                010360 = END INVERSE/UNDERSCORE            (417 * 2**4).
*                010400 = NO-OP                             (420 * 2**4).
*
*         CC545 TYPE DATA.
*                0000 - 5777 = TWO DISPLAY CODE CHARACTERS.
*                6000 - 6777 = Y-POSITION CHANGE.
*                7000 - 7777 = X-POSITION CHANGE.
          TITLE  NOS/VE PP BOOTSTRAP (*VPB*) DOCUMENTATION.
 VPB1     SPACE  4,10
***       NOS/VE PP BOOT (*VPB*) MODE IN A NON-CYBER 2000 ENVIRONMENT.
*
*         *VPB* MODE IS DIVIDED INTO TWO LOGICAL PIECES; A DEADSTART PIECE
*         WHICH IS IMPLEMENTED AS THREE OVERLAYS AND A TERMINATION PIECE
*         IMPLEMENTED AS TWO OVERLAYS.  *VPB* CODE OCCUPIES THE AREA
*         NORMALLY OCCUPIED BY *MDD* RESIDENT AS WELL AS THE OVERLAY AREA.
*         WHILE *VPB* IS ACTIVE, NEITHER *MDD* NOR *SCD* MODES ARE ACTIVE.
*         THE ONE EXCEPTION IS WHILE *VPB* MODE IS WAITING FOR *DROPVE* OR
*         TERMINATE BITS IN THE EICB TO CHANGE; *VPB* MODE IS ACTIVATED ONCE
*         A SECOND BUT RELINQUISHES CONTROL IF FURTHER DELAY IS REQUIRED.
*
*         *VPB* DEADSTART CODE CONTAINS ALL THE PP ROUTINES REQUIRED TO
*         HANDLE STANDALONE AND DUAL-STATE DEADSTARTS AND RECOVERIES.
*
*         *VPB* TERMINATION CODE CONTAINS CODE TO LOGICALLY TERMINATE NOS/VE
*         AND, IN A DUAL-STATE ENVIRONMENT, TO RESTART C170 STANDALONE MODE.
 VPB2     SPACE 4,10
***       NOS/VE PP BOOT (*VPB*) MODE IN A CYBER 2000 ENVIRONMENT.
*
*         *VPB* MODE IS ONE LOGICAL DEADSTART PIECE WHICH IS IMPLEMENTED AS
*         ONE OVERLAY.  IT RESIDES IN THE UPPER 4K OF THE PP AND CONTAINS
*         ALL OF THE ROUTINES REQUIRED TO HANDLE NOS/VE STANDALONE DEADSTART.
*
*         *VPB* TERMINATION CODE IS NOT EXECUTED IN A CYBER 2000 ENVIRONMENT.
          TITLE  MEMORY LAYOUT.
 MEMORY   SPACE  4,10
***       MEMORY LAYOUT.
*
*         0000   +-----------------------------------------------+
*                :  DIRECT CELLS                                 :
*         0100   +-----------------------------------------------+
*                :  *SCI* IDLE LOOP AND RESIDENT ROUTINES.       :
*         OVLM   +-----------------------------------------------+
*                :  *MDD* RESIDENT, IF *MDD* MODE IS ACTIVE.     :
*                :  THIS AREA IS ALSO TEMPORARILY USED FOR *VPB* :
*                :  CODE, ALONG WITH THE *OVLA* OVERLAY AREA, IF :
*                :  NOS/VE DEADSTART OR TERMINATION IS ACTIVE.   :
*         OVLA   +-----------------------------------------------+
*                :  *MDD* COMMAND PROCESSORS, *SCD* CODE, AND    :
*                :  TRANSIENT *SCI* OVERLAYS.  DURING NOS/VE     :
*                :  DEADSTART AND TERMINATION, *VPB* CODE USES   :
*                :  BOTH THIS AREA AND THE *MDD* RESIDENT AREA.  :
*                :  IF AN *MDD* OVERLAY MUST REGAIN CONTROL      :
*                :  AFTER EXITING TEMPORARILY TO THE MAIN LOOP,  :
*                :  TYPICALLY WHEN DOING TERMINAL OUTPUT, IT     :
*                :  MUST SET *OVLP* NONZERO TO INHIBIT ANY OTHER :
*                :  OVERLAYS FROM BEING LOADED.                  :
*         SCMT   +-----------------------------------------------+
*                :  *SCD* MODE TABLE.                            :
*                +-----------------------------------------------+
*                :  GLOBAL LOCATIONS.                            :
*         MDMT   +-----------------------------------------------+
*                :  *MDD* MODE TABLE.                            :
*                +-----------------------------------------------+
*                :  MEMORY BEYOND THE *MDD* MODE TABLE (UP TO    :
*                :  ADDRESS 10000) CONTAINS ADDITIONAL GLOBAL
*                :  LOCATIONS AND A SCRATCH BUFFER USED FOR      :
*                :  VARIOUS PURPOSES BY SEVERAL MODES OF *SCI*.  :
*                +-----------------------------------------------+
*         7777   :  CYBER 2000 *VPB* DEADSTART OVERLAY.          :
*                +-----------------------------------------------+
          TITLE  MODE TABLES AND GLOBAL LOCATIONS.
 TABLE    SPACE  4,15
***       MODE TABLE DEFINITION.
*
*         A MODE TABLE IS DEFINED FOR BOTH *MDD* AND *SCD*.  THE TWO TABLES
*         EACH CONSIST OF A COMMON PORTION, CONTAINING INFORMATION USED BY
*         BOTH *MDD* AND *SCD*, AND AN EXTENSION, CONTAINING MODE-UNIQUE
*         INFORMATION.  NOTE THAT THERE IS ONLY ONE *SCD* MODE TABLE, EVEN
*         THOUGH *SCD* LOGICALLY CONSISTS OF TWO SUB-MODES, *SCD/NOS* AND
*         *SCD/VE*.
 PTDB.    SPACE  4,45
***       *PTDB.* - MODE STATUS FLAGS.
*
*         ALTHOUGH *PTDB.* IS COMMON TO BOTH *MDD* AND *SCD* MODE TABLES,
*         ITS LAYOUT IS SLIGHTLY DIFFERENT FOR EACH MODE.
*
*         FOR *SCD* MODE, *PTDB.* HAS THE FOLLOWING FORMAT:
*
*         3/, 1/ R, 1/A, 2/ SS, 3/ TT, 3/ CT, 3/ PT
*
*         R = *SCD* HAS PORT(S) RESERVED.
*         A = *SCD* MODE IS ACTIVE (*SCD/NOS*, *SCD/VE*, OR BOTH).
*         SS = *SCD* STATE(S) ACTIVE:
*              1 = *SCD/NOS*.
*              2 = *SCD/VE*.
*              3 = BOTH *SCD/NOS* AND *SCD/VE* (DUAL-STATE CONSOLE).
*         TT = TERMINAL TYPE:
*              0 = NON-CC634B (NON-CDC721) CONSOLE.
*              1 = CC634B (CDC721) CONSOLE.
*         CT = CONTROLWARE TYPE:
*              0 = NO CONTROLWARE (*SCD/VE* ONLY).
*              1 = CC545 CONTROLWARE (*SCD/NOS* OR DUAL-STATE CONSOLE).
*         PT = PORT(S) IN USE:
*              0 = ALL I/O ON PORT ZERO.
*              1 = ALL I/O ON PORT ONE.
*              2 = OUTPUT TO BOTH PORTS, INPUT FROM PORT ZERO.
*              3 = OUTPUT TO BOTH PORTS, INPUT FROM PORT ONE.
*
*         FOR *MDD* MODE, *PTDB.* HAS THE FOLLOWING FORMAT:
*
*         3/, 1/ R, 1/A, 2/ IN, 3/ PT, 3/, 3/ PT
*
*         R = *MDD* HAS PORT(S) RESERVED.
*         A = *MDD* MODE IS ACTIVE.
*         IN = *MDD* INITIATOR:
*              0 = CTI.
*              1 = CYBER 170 OS.
*              2 = NOS/VE.
*         PT = PORT(S) IN USE: (*** NOTE THAT *PT* APPEARS TWICE ***)
*              0 = ALL I/O ON PORT ZERO.
*              1 = ALL I/O ON PORT ONE.
*              2 = OUTPUT TO BOTH PORTS, INPUT FROM PORT ZERO.
*              3 = OUTPUT TO BOTH PORTS, INPUT FROM PORT ONE.
 PTUS.    SPACE  4,25
***       *PTUS.* - PORT STATUS.
*
*         13/ UNUSED, 1/ O1, 1/O0, 1/ IP
*
*         UNUSED = UNUSED BITS, BUT MAY BE NONZERO.
*         O1 = OUTPUT ON PORT ONE IF O1=1.
*         O0 = OUTPUT ON PORT ZERO IF O0=1.
*         IP = INPUT PORT:
*              0 = INPUT FROM PORT ZERO.
*              1 = INPUT FROM PORT ONE.
*
*         NOTE THAT *PTDB.* AND *PTUS.* AS WELL AS THE CODE PROVIDE FOR
*         OUTPUTTING ON BOTH PORTS WHILE INPUTTING FROM ONLY ONE.  THIS
*         *SLAVE CONSOLE* CAPABILITY SHOULD NOT BE CONFUSED WITH A
*         SECONDARY CONSOLE, SINCE ONLY ONE KEYBOARD IS ACTIVE AND BOTH
*         CONSOLES WILL DISPLAY IDENTICAL OUTPUT.  ALSO, NOTE THAT THERE
*         IS CURRENTLY NO PROVISION FOR ACTIVATING THIS MODE, SHORT OF
*         MANUALLY SETTING BITS IN THE CENTRAL MEMORY PARAMETER TABLE.
*
*         THIS CAPABILITY IS UNADVERTISED AND UNVERIFIED.
 RTNP.    SPACE  4,10
***       *RTNP.* - CURRENT EXECUTION ADDRESS FOR MODE.
*
*         *RTNP.* SPECIFIES WHERE MODE EXECUTION IS TO BE RESUMED FROM
*         THE MAIN LOOP.  IT MUST BE THE FIRST ENTRY IN THE TABLE, SO THAT
*         INDIRECT ADDRESSING CAN BE USED TO ACCESS IT.
          EJECT
 MODE     SPACE  4,10
***       MODE TABLE - COMMON PORTION.
*
*         IN ADDITION TO THE FOLLOWING DEFINITIONS WHICH APPLY TO BOTH
*         TABLES, BOTH MODES ALSO DEFINE ADDITIONAL TABLE ENTRIES.


          LIST   G
 BEGIN    BSSN   0
 RTNP.    BSSN   1           PROCESSING ROUTINE ADDRESS
          ERRNZ  RTNP.       *RTNP.* MUST BE FIRST ENTRY IN TABLE
 RTNL.    BSSN   1           ROUTINE LIST ADDRESS
 PTDB.    BSSN   1           PORT DEFINITION BYTE
 PTUS.    BSSN   1           PORTS IN USE
 OFFS.    BSSN   1           OFFSET FROM R-REGISTER
 RRUP.    BSSN   1           R-REGISTER UPPER
 RRLW.    BSSN   1           R-REGISTER LOWER
 NRTP.    BSSN   1           NEXT ROUTINE SAVE AREA
 RSMC.    BSSN   1           START MULTIPLE CODE (1E(16))
 CHRC.    BSSN   1           CHARACTER COUNT MASTER
 CHR0.    BSSN   1           CHARACTER COUNT PORT 0
 CHR1.    BSSN   1           CHARACTER COUNT PORT 1
 CHP0.    BSSN   1           POINTER TO CHARACTER STRING PORT 0
 CHP1.    BSSN   1           POINTER TO CHARACTER STRING PORT 1
 CHRB.    BSSN   100D        CHARACTER BUFFER (ONE CHAR/WORD)
 CHARS.   BSSN   4           BUFFER TO HOLD 4 CHAR. FROM MUX
 KBIP.    BSSN   1           KEYBOARD BUFFER INPUT POINTER
 KBOP.    BSSN   1           KEYBOARD BUFFER OUTPUT POINTER
 TEMP.    BSSN   1           TEMPORARY DATA
 MTBL.L   BSSN   0           TABLE LENGTH
 END      BSSN
          LIST   *
          EJECT
 SCMT     SPACE  4,10
***       SCMT - *SCD* MODE TABLE EXTENSION.
*
*         NOTE THAT *SCMT* MUST BE INCLUDED IN THE ADDRESS CALCULATION
*         WHEN USING ANY OF THESE WORDS.


 SCMT     EQU    7120

          LIST   G
 BEGIN    BSSN   MTBL.L
 DATA.    BSSN   1           INPUT DATA FROM NOS
 NRTL.    BSSN   1           NOS ROUTINE LIST
 RKIA.    BSSN   1           WAITING FOR NOS/VE TO ECHO LAST INPUT
 GOTL.    BSSN   1           GOT LAST LINE IN LIST
 SCDS.    BSSN   1           *SCD* STATE (0 = NOS)
 CWLD.    BSSN   1           CONTROLWARE LOADED
 TTOF.    BSSN   1           TRANSLATION TABLE OFFSET
 XPOS.    BSSN   1           X-POSITION
 YPOS.    BSSN   1           Y-POSITION
 SAVE.    BSSN   4           POSITIONING SAVE AREA
 COMM.    BSSN   8D          COMMUNICATION BUFFER FOR SCDCB
 SCRN.    BSSN   1           SCREEN OFFSET
 CMBA.    BSSN   1           CM BUFFER OFFSET FOR *SCD* MODE
 CMBS.    BSSN   1           BUFFER SIZE
 CMBL.    BSSN   1           CM BUFFER END
 CMIP.    BSSN   1           BUFFER INPUT POSITION
 CMOP.    BSSN   1           BUFFER OUTPUT POSITION
 CMBC.    BSSN   1           AMOUNT OF DATA IN BUFFER
 CMWP.    BSSN   1           CM WORD BUFFER POSITION
 OPSF.    BSSN   1           OUTPUT HOLD FLAG
 CBAO.    BSSN   1           *SCD* COMMUNICATIONS BLOCK A-OFFSET
 ELAO.    BSSN   1           NOS/VE ERROR LINE A-OFFSET
 ELRU.    BSSN   1           NOS/VE ERROR LINE UPPER R-REGISTER
 ELRL.    BSSN   1           NOS/VE ERROR LINE LOWER R-REGISTER
 CMOV.    BSSN   1           CURSOR MOVED FLAG
 NCCH.    BSSN   1           NOS COMMUNICATION CHANNEL
 SCMT.L   BSSN   0           LENGTH OF *SCD* MODE TABLE
 END      BSSN
          LIST   *
          EJECT
 GLOBALS  SPACE  4,10
***       GLOBAL LOCATIONS.
*
*         THE SPACE BETWEEN THE END OF THE *SCD* MODE TABLE AND THE
*         BEGINNING OF THE *MDD* MODE TABLE IS USED FOR GLOBAL CELLS.


          LIST   G
 BEGIN    BSSN   SCMT+SCMT.L
 MION     BSSN   1           MAXIMUM IOU ORDINAL LOGICALLY ON (0 OR 1)
 NOSL     BSSN   1           FLAG FOR LOADED BY NOS
 PPNO     BSSN   1           NUMBER OF THE PP WE ARE IN
 OVLS     BSSN   1           NUMBER OF OVERLAYS ACTUALLY LOADED
 CMWC     BSSN   1           NUMBER OF *MDD* CENTRAL MEMORY WRITES
 MRWC     BSSN   1           NUMBER OF *MDD* MAINTENANCE REGISTER WRITES
 CPUT     BSSN   1           CPU TYPE
 RDCA     BSSN   1           LAST KEYBOARD CHARACTER
 DOFF     BSSN   1           *SCI* DIRECTORY OFFSET
 OVLP     BSSN   1           INHIBIT OVERLAY LOADS IF NONZERO
 DFTO     BSSN   1           A-REGISTER OFFSET TO *DFT* BLOCK
 SAAO     BSSN   1           A-REGISTER OFFSET TO *SSR*
 SBAO     BSSN   1           A-REGISTER OFFSET TO *SCI* PARAMETER TABLE
 ISPB     BSSN   1           DISABLE OS BOUNDS MANIPULATION (STANDALONE)
 CTUF     BSSN   1           CTI UTILITY MODE *MDD* FLAG
 CELA     BSSN   1           COUNTER FOR NOS/VE ERROR LINE
 CDLA     BSSN   1           COUNTER FOR *DFT* MESSAGE
 SCDP     BSSN   1           *SCD* PORT
 GLOBEND  BSSN   0           LAST GLOBAL + 1
 END      BSSN
          LIST   *

          ERRNG  MDMT-GLOBEND  GLOBALS OVERFLOW INTO *MDMT*
          EJECT
 MDMT     SPACE  4,10
***       *MDD* MODE TABLE EXTENSION.
*
*         NOTE THAT THESE WORDS ARE ABSOLUTE ADDRESSES, WITH *MDMT* BIAS
*         ALREADY PRESENT.


 MDMT     EQU    7400

          LIST   G
 BEGIN    BSSN   MDMT+MTBL.L
 RFLG     BSSN   1           REPEAT FLAG
 WAIT     BSSN   1           OPERATOR PAUSE FLAG
 HLPC     BSSN   1           HELP PARAMETER
 PPCT     BSSN   1           PP CONCURRENCY TYPE
 RPPA     BSSN   1           ADDRESS TO RESTART A PP
 RFPC     BSSN   1           TYPE CODE
 RFPA     BSSN   1           STARTING REGISTER NUMBER
 RFPB     BSSN   1           REGISTER COUNT
 RDLY     BSSN   1           REPEAT DELAY COUNTER
 MDDR     BSSN   1           REPEAT DELAY
 RRRP     BSSN   1           REFRESH RATE PARAMETER
 SEPA     BSSN   1           SET CPU VARIABLE (0,1)
 SPTS     BSSN   1           SEARCH PAGE TABLE SHIFT
 CMDA     BSSN   1           COMMAND PROCESSOR OVERLAY NUMBER
 CMDB     BSSN   1           COMMAND PROCESSOR ADDRESS
 VAL1     BSSN   4           VALUE 1 SAVE AREA (4 WORDS)
 VAL2     BSSN   1           VALUE 2 SAVE AREA
 VAL3     BSSN   3           INCREMENT VALUE (3 WORDS)
 VAL4     BSSN   1           LAST NUMBER DECODE TYPE
 CPOP     BSSN   1           CHARACTERS PREVIOUSLY OUTPUT TO MUX
 DDST     BSSN   1           DFT STRUCTURE PARAMETER
 DFTF     BSSN   1           DFT ERROR CONDITION FLAG PARAMETER FOR *MDD*
 DFTP     BSSN   1           DFT BUFFER PARAMETER FOR *MDD* MODE
 DFTR     BSSN   1           DFT ON/OFF PARAMETER
 DPRB     BSSN   1           PP REGISTER TYPE
 ECEI     BSSN   1           ECR ELEMENT ID
 HPTL     BSSN   1           PAGE TABLE LENGTH WORDS/100(8)
 HPSM     BSSN   1           MASK OF PAGE SIZE/100(8)
 MPSV     BSSN   2           MONITOR PROCESS STATE POINTER
 MRPV     BSSN   1           MAINTENANCE REGISTER VARIABLE
 PTAV     BSSN   2           PAGE TABLE ADDRESS
 JPSV     BSSN   2           JOB PROCESS STATE POINTER
 PSMV     BSSN   1           PAGE SIZE MASK
 PTLV     BSSN   1           PAGE TABLE LENGTH VALUE
 XPSV     BSSN   2           EXCHANGE PACKAGE (*** NEVER USED ***)
 VMBA     BSSN   5           PVA BUFFER
 UEP1     BSSN   1           UPDATE ELEMENT PARAMETER 1
 UEP2     BSSN   4           UPDATE ELEMENT PARAMETER 2

*         WARNING - BE AWARE THAT DURING PARAMETER CRACKING, ROUTINE *CLB*
*         ZEROS OUT *MRBF* - *MRBF+6*.

 MRBF     BSSN   10          MAINTENANCE REGISTER BUFFER
 ANCD     BSSN   1           ANALYSIS CODE
 PPTY     BSSN   1           PP TYPE (0 = UPPER PP)
 MDMT.L   BSSN   0           END OF *MDD* MODE TABLE
 END      BSSN
          LIST   *

          ERRNG  7677-MDMT.L *MDMT* OVERFLOWS INTO COMMON VARIABLES
          EJECT
 COMMON   SPACE  4,10
***       COMMON VARIABLES.


          LIST   G
 BEGIN    BSSN   7677
 S0FLG    BSSN   1           MACHINE TYPE FLAG
*                            (C2000 = 10000(8), S0/S0E = 1, GENERIC = 0)
 EMC0     BSSN   1           ESTABLISHED PORT 0 CONNECTION PREVIOUSLY
 EMC1     BSSN   1           ESTABLISHED PORT 1 CONNECTION PREVIOUSLY
 ELIO     BSSN   1           IOU CONNECT CODE
 I0CC     EQU    ELIO        ALTERNATE NAME FOR IOU CONNECT CODE
 ELPR     BSSN   1           PROCESSOR CONNECT CODE
 ELCM     BSSN   1           MEMORY CONNECT CODE
 IOUM     BSSN   1           IOU MODEL
 MEMM     BSSN   1           MEMORY MODEL
 MXS0     BSSN   1           PORT 0 STATUS
 MXS1     BSSN   1           PORT 1 STATUS
 XOFF     BSSN   1           *X-OFF* RECEIVED FROM PORT 0
 XOF1     BSSN   1           *X-OFF* RECEIVED FROM PORT 1
 RDATA    BSSN   10          TEST MODE REGISTER (A0) BUFFER
 BUFF     BSSN   0           *SCD/VE* CM BUFFER (REST OF PP)
          BSSN   3           (SLACK FOR *HBUF* USAGE)
 HBUF     BSSN   0           HARDWARE ELEMENT BUFFER
 END      BSSN
          LIST   *

          ERRPL  HBUF+CMXLEN-10000  MRT BUFFER OVERFLOWS PP
          ERRPL  BUFF+11D*4-10000   *SCD/VE* BUFFER OVERFLOWS PP
          TITLE  MISCELLANEOUS EQUATES.
 EQUATES  SPACE  4,10
**        CONSTANT DEFINITIONS.


 BEL      EQU    0#07        BELL (CONTROL-G)
 BS       EQU    0#08        BACK SPACE
 TAB      EQU    0#09        TAB (CONTROL-I)
 LF       EQU    0#0A        LINE FEED
 CR       EQU    0#0D        CARRIAGE RETURN
 XON      EQU    0#11        X-ON
 XOF      EQU    0#13        X-OFF
 ESC      EQU    0#1B        ESCAPE
 RS       EQU    0#1E        RECORD SEPARATOR (FUNCTION KEY PREFIX)
 VV       EQU    0#76        LOWER CASE V (FUNCTION KEY 6)
 WW       EQU    0#77        LOWER CASE W (FUNCTION KEY 7)
 CH       EQU    10          DEFAULT *SCD/NOS* COMMUNICATIONS CHANNEL
 CRLF     EQU    10000       CARRIAGE RETURN LINE FEED FLAG
 RR       EQU    400000      ACTIVATE R-REGISTER IN CM ACCESS
 LNOF     EQU    102         DEFAULT OVERLAY LOAD RETURN ADDRESS
 OVLM     EQU    3540        ORIGIN FOR *MDD* RESIDENT AND *VPB* DEADSTART
 OVLA     EQU    5400        ORIGIN FOR *MDD* AND *SCD* OVERLAYS
 SPIB     EQU    10000       *SCI* PARAMETER TABLE INTERLOCK BIT
 CBUF     EQU    6300        AVAILABLE PP AND CHANNEL BUFFER (DEADSTART ONLY)
 MBUF     EQU    6500        MEMORY BUFFER (DEADSTART ONLY)
 CY2OVL   EQU    7760        CYBER 2000 DEADSTART OVERLAY ORIGIN
 DEFAULT  EQU    5100        DEFAULT ACTIVE REAL-STATE *SCD* MODE
 PRGM     SET    1           OVERLAY MACRO VARIANT FOR *DSI$PP_MACROS*
 SCIPTL   EQU    4           *SCI* PARAMETER TABLE LENGTH
 TSDRBL   EQU    20D         TEMPORARY *SCI* DFT REQUEST BUFFER LENGTH
 EICBFWA  EQU    200         EICB FIRST WORD ADDRESS (CYBER 2000 ONLY)

*         THE IOU RESOURCE TABLE (*VEPP*) IN THE *SSR* CONTAINS
*         THE STATUS OF ALL PP-S AND CHANNELS ACCESSIBLE BY NOS/VE.
*         EACH 16-BIT BYTE CONTAINS THE STATUS OF ONE PP AND ONE
*         CHANNEL.  THE TABLE IS ACCESSED VIA *CYBIL* AS A THREE
*         DIMENSIONAL ARRAY WITH THE INDICIES -
*         IOU NUMBER, NIO/CIO TYPE, AND ELEMENT NUMBER.
*         SINCE SPACE IS ALLOCATED FOR THE MAXIMUM IOU CONFIGURATION,
*         THE REQUIRED SIZE IS DETERMINED BY MULTIPLYING THE
*         MAXIMUM NUMBER OF DIFFERENT STATES OF EACH SUBSCRIPT
*         TOGETHER - 2(UP TO TWO IOUS) * 2(NIO OR CIO TYPE) *
*         34(8) (MAXIMUM NUMBER OF ELEMENTS WHEN ROUNDED UP TO THE
*         NEAREST MULTIPLE OF 4).

 IRTL     EQU    2*2*34      IOU RESOURCE TABLE LENGTH

*         WHEN *SCI* IS REQUESTED TO DEADSTART NOS/VE IN DUAL STATE MODE,
*         THE NVE SUBSYSTEM WAITS FOR *SCI* TO PUT A DEADSTART STATUS IN
*         *D8ST* IN THE EICB TO INDICATE WHETHER DEADSTART SHOULD CONTINUE
*         OR BE ABORTED DUE TO A PROBLEM ENCOUNTERED WHILE LOADING THE
*         BOOT.

 BLOK     EQU    1           BOOT LOAD OK, CONTINUE DEADSTART
 BPNI     EQU    2           BOOT PROGRAM NOT INSTALLED ON CIP DEVICE

          LIST   X
*COPY     CTI$MAINTENANCE_DISPLAY_MACROS
          LIST   *
          TITLE  DIRECT CELL DEFINITIONS.
 DIRECTS  SPACE  4,10
****      DIRECT CELL DEFINITIONS.
*
*         DIRECT CELL USAGE IN *SCI* MUST OBSERVE CERTAIN RULES, SINCE
*         A NUMBER OF DIFFERENT MODES OF *SCI* CAN BE ACTIVE SIMULTANEOUSLY.
*         DIRECT CELLS ARE DIVIDED INTO SEVERAL GROUPS:
*
*         1)  *SCRATCH* CELLS ARE USABLE BY ANY ROUTINE IN ANY MODE, AND
*         THEY CANNOT BE ASSUMED TO RETAIN VALUES ACROSS THE MAIN LOOP.
*         GLOBAL OR MODE-TABLE CELLS MUST BE USED FOR SUCH PURPOSES.
*
*         2)  *POINTER* CELLS SHOULD BE CONSIDERED READ-ONLY, ALTHOUGH
*         A NUMBER OF ROUTINES READ AND STORE THE POINTERS.  THEY SHOULD
*         NOT BE USED FOR ANY OTHER PURPOSE.
*
*         3)  *MDD* DIRECT CELLS CAN BE USED ONLY BY *MDD* ROUTINES.
*         THESE DIRECT CELLS ARE ASSUMED TO REMAIN INTACT ACROSS EXITS
*         TO AND CALLS FROM THE MAIN LOOP, SINCE *MDD* IS PSEUDO-REENTRANT.
*
*         4)  *VPB* MODE IS USED ONLY FOR NOS/VE DEADSTART OR TERMINATION;
*         BECAUSE IT OVERLAYS THE ENTIRE *MDD* AREA, IT CAN SAFELY USE
*         DIRECT CELLS WHICH OVERLAY THE *MDD* SPECIFIC DIRECT CELLS.
*
*         5)  CERTAIN DIRECT CELLS HAVE SPECIAL MEANINGS WHEN *SCI* PRESET
*         IS ACTIVE, AS THEY CONTAIN HANDOFF DATA FROM *CTI* OR *SDA* OR
*         *DFT*.


*         SCRATCH CELLS - AVAILABLE FOR ALL MODES OF *SCI*.

 T0       EQU    0           TEMPORARIES
 T1       EQU    1
 T2       EQU    2
 T3       EQU    3
 T4       EQU    4
 T5       EQU    5
 T6       EQU    6
 T7       EQU    7
 W0       EQU    10          WORKING STORAGE
 W1       EQU    11
 W2       EQU    12
 W3       EQU    13
 W4       EQU    14
 W5       EQU    15
 W6       EQU    16
 W7       EQU    17
 CM       EQU    20 - 23     CENTRAL MEMORY WORD BUFFER
 CN       EQU    24 - 27     CENTRAL MEMORY WORD BUFFER

*         POINTERS - TO BE USED ONLY AS DOCUMENTED.

 SC       EQU    30 - 32     R-POINTER FOR *SCI* IMAGE IN *CIP* AREA
 TI       EQU    33          USED ONLY BY THE TIME OUT ROUTINE
 CD       EQU    34 - 36     R-POINTER FOR *CIP* DIRECTORY
*                            FOR CYBER 2000, CD - CD+3 IS USED TO HOLD THE
*                            R-POINTER TO THE TEMPORARY SCI DFT REQUEST BUFFER.
 IB       EQU    37 - 41     R-POINTER FOR EI CONTROL BLOCK
 CB       EQU    42 - 43     R-REGISTER FOR *SCD/VE* COMMUNICATIONS BLOCK
 DP       EQU    44 - 45     R-REGISTER FOR DFT BUFFER (OFFSET = *DFTO*)
 SA       EQU    46 - 47     R-REGISTER FOR *SSR* (OFFSET IN *SAAO*)
 SB       EQU    50 - 51     R-REGISTER FOR *SCDPT* (OFFSET IN *SBAO*)
 HP       EQU    52 - 53     R-REGISTER FOR *2AP*

*         *MDD*-ONLY DIRECT CELLS, PRESERVED ACROSS MAIN LOOP EXITS/CALLS.

 MP       EQU    54 - 57     MEMORY PARAMETERS
 M1       EQU    60          TEMPORARIES
 M2       EQU    61
 M3       EQU    62
 PC       EQU    63          PARAMETER COUNT
 PP       EQU    64          PP NUMBER (ALSO USED AS GENERAL SCRATCH)
 WC       EQU    65          WORD COUNT
*         EQU    66          UNUSED
*         EQU    67          UNUSED

*         *VPB*-ONLY DIRECT CELLS - OVERLAP *MDD*-ONLY CELLS.

 BL       EQU    54 - 55     BOOT LOAD ADDRESS
 LA       EQU    56 - 57     LOAD ADDRESS/100 (USED ONLY TO DEADSTART NOS/VE)
 SZ       EQU    60 - 61     MEMORY SIZE/100
 VP       EQU    62 - 65     R-POINTER TO *DFT* REQUEST BUFFER

          ORG    70

 DO       CON    1           DEADSTART ORIGIN (1 = STANDALONE)
 BA       CON    0           BUFFER ADDRESS
 BP       CON    0           POINTER INTO CHARACTER BUFFER
 PT       CON    0           CURRENT PORT TABLE ADDRESS
 VA       CON    0           NOS/VE ACTIVE FLAGS
 EC       CON    0           ELEMENT CONNECT CODE FOR *READMR* AND *WRITMR*
 RN       CON    0           REGISTER NUMBER FOR *READMR* AND *WRITMR*
 ON       CON    1           CONSTANT ONE

          ERRNZ  SC-30       *CTI* / *SCI* MISMATCH
          ERRNZ  CD-34       *CTI* / *SCI* MISMATCH
****
 COMMON   SPACE  4,10
*         COMMON DECKS.


*COPY     CTI$DFT_ANALYSIS_CODES
*COPY     CTC$DFT_CONSTANTS
*COPY     CTC$ELEMENT_DESCRIPTOR_DEF
          TITLE  SCI PRESET OVERLAY.
 ORIGIN   SPACE  4,10
**        ORIGIN CHECK.
*
*         BECAUSE A NUMBER OF DIFFERENT ROUTINES INITIATE *SCI*, AND
*         EXECUTE *LJM 100* TO BEGIN *SCI* PRESET, THE FOLLOWING
*         ERROR CHECK IS REQUIRED.


          ERRNZ  *-100       BOOTSTRAPS BEGIN EXECUTION AT 100
          QUAL   PRESET
 CTMSCI   SPACE  4,10
**        SCI - SYSTEM CONSOLE INTERFACE.
*
*         ENTRY  SEE *CTI* HANDOFF DOCUMENTATION.
*
*         EXIT   TO *PMT*, IF NORMAL COPY OF *SCI*.
*                TO *RMD*, IF RESTARTED BY *DFT*.
*                TO *DTE*, IF CYBER 2000 ENVIRONMENT.
*
*         CALLS  CHK, FDO, PDC.


 CTMSCI   BSS    0           ENTRY (FROM BOOTSTRAP OR CTI)
          LDDL   27          GET HANDOFF DATA
          STM    SCIA        SAVE POSSIBLE RESTART FLAG AND PP NUMBER
          SHN    -14
          LMN    17
          NJN    SCI1        IF NOT CYBER 2000
          LDN    BCTP+3      GET CIP DIRECTORY POINTER FROM BOOT CONTROL TABLE
          CRDL   SC
          RJM    FDO         FETCH DIRECTORY HEADER OFFSET
          STDL   T1          SAVE CONTENTS OF *DOFF*
          CALL   DTE         DEADSTART CYBER 2000 - NO RETURN

 SCI1     RJM    PDC         PRESET DIRECT CELLS
          RJM    CHK         CHECK VALIDATION
          LDM    SCIA        CHECK RESTART FLAG
          SHN    21-13
          MJN    SCI2        IF RESTART BY *DFT*
          CALL   PMT         PRESET MODE TABLES *NO RETURN*

 SCI2     AOD    VA          SET NOS/VE ACTIVE FLAG
          CALL   RMD         RESTORE MODE DEFINITIONS FROM SCDPT

 SCIA     BSS    1           ORIGINAL CONTENTS OF DIRECT CELL 27
 LNO      SPACE  4,10
**        LNO - LOAD NEXT OVERLAY.
*
*         ENTRY  (A) = 6/OVERLAY ID, 12/JUMP ADDRESS.
*
*         EXIT   TO ROUTINE IN OVERLAY LOADED.
*
*         USES   CM - CM+3.


 LNO      SUBR               ENTRY
          STM    LNOB        SET OVERLAY JUMP ADDRESS
          SHN    -14         GET OVERLAY INDEX
          ADML   DOFF        DIRECTORY OFFSET
          LRD    SC+1        READ DIRECTORY ENTRY
          LMC    RR
          CRDL   CM
          LDD    CM          SET LOAD ADDRESS
          STM    LNOA
          LDD    SC          READ OVERLAY
          ADDL   CM+3
          ADC    RR+1
          CRML   **,CM+1
 LNOA     EQU    *-1         (OVERLAY LOAD ADDRESS)
          LJM    **          BRANCH TO ENTRY POINT DESIRED
 LNOB     EQU    *-1         (ENTRY POINT)
 CHK      SPACE  4,20
**        CHK - CHECK FOR PROPER VALIDATIONS BEFORE STARTING *MDD*.
*
*         ENTRY  (33) = 1/MDD UTILITY FLAG,2/UNUSED,2/MDD PORT NUMBER.
*
*         EXIT   TO *FIE* IF FATAL ERROR OCCURS DURING INITIALIZATION.
*                TO *DSA* IF STANDALONE DEADSTART REQUIRED.
*                TO *DDS* IF DUAL-STATE DEADSTART REQUIRED.
*                (CPUT) = X00 S1-CR WHERE X = NUMBER OF CPUS.
*                       = X01 S1
*                       = X02 S2
*                       = X03 S3
*                       = X04 THETA
*                       = X05 S0/S0E
*                (ELIO) = IOU PORT CODE.
*                (IOUM) = IOU MODEL.
*                (ELCM) = MEMORY PORT CODE.
*                (ELPR) = PROCESSOR PORT CODE.
*                (MION) = MAXIMUM IOU ORDINAL WHICH IS LOGICALLY ON.
*
*         USES   DA, PT.
*
*         CALLS  FHE, PII.


 CHK      SUBR               ENTRY/EXIT
          LDN    IOUID
          RJM    FHE         FIND IOU PORT CODE
          MJP    FIE         IF NOT FOUND
          LDM    HBUF+CIOPC
          LPC    7417        MASK OUT *SCI* PP TYPE
          STM    I0CC        SAVE IOU-0 CONNECT CODE
          LDM    HBUF+CIOE+EM
          SHN    -4          REMOVE UPPER FOUR BITS OF SERIAL NUMBER
          STM    IOUM        SAVE IOU MODEL
          RJM    PII         PRESET FOR OS-BOUNDS CHECKING
          LDC    10000+IOUID CHECK FOR SECOND IOU
          RJM    FHE         FIND HARDWARE ELEMENT
          MJN    CHK0        IF NO SECOND IOU
          LDM    HBUF+CIOST  CHECK IF LOGICALLY ON
          SHN    21-0
          MJN    CHK0        IF SECOND IOU IS LOGICALLY OFF
          AOM    MION
 CHK0     LDN    CMID
          RJM    FHE         FIND MEMORY PORT CODE
          MJP    FIE         IF NOT FOUND
          LDM    HBUF+CMIPC
          STM    ELCM        SAVE MEMORY PORT CODE
          LDM    HBUF+CMIE+EM
          SHN    -4          REMOVE UPPER FOUR BITS OF SERIAL NUMBER
          STM    MEMM        SAVE MEMORY MODEL
          LDN    0
          STD    T7          SET UP PROCESSOR COUNTER
          LDN    PROCID
          RJM    FHE         FIND PROCESSOR ID
          MJP    FIE         IF NOT FOUND
          LDM    HBUF+CPRPC
          STM    ELPR        SAVE CONNECT CODE
          LDM    HBUF+CPRE+EM  GET MODEL NUMBER
          SHN    -10
          STM    CPUT        SAVE CPU TYPE
          SBN    1           TEST IF AN S1 OR S1-CR
          NJN    CHK2        IF NOT
          LDM    HBUF+CPRE+EM  GET MODEL NUMBER
          SHN    -4
          LPN    7           SAVE JUST 3 BITS
          SBN    3
          ZJN    CHK1        IF AN 830
          SBN    4-3
          NJN    CHK2        IF NOT AN 810
 CHK1     STM    CPUT        SAVE CPU TYPE
 CHK2     AOD    T7
          SHN    14
          ADN    PROCID
          RJM    FHE         FIND PROCESSOR ID
          PJN    CHK2        TRY FOR NEXT ONE
          SOD    T7
          SHN    6           SET NUMBER OF CPUS
          RAM    CPUT
          LPN    77          CHECK MAINFRAME TYPE
          LMN    5
          NJN    CHK3        IF NOT AN S0/S0E
          AOM    S0FLG       SET S0/S0E FLAG
          LOADOV S0DLI       LOAD S0/S0E DUMP LOAD IDLE PP ROUTINES
 CHK3     LDM    CTUF        TEST IF *MDD* IS TO BE ACTIVE
          ADM    DSPI-1
          ZJN    CHK5        IF NO *MDD*
 CHK4     LJM    CHKX        RETURN

 CHK5     LDM    NOSL        CHECK IF LOADED BY CTI
          SBD    DO          AND NOT NOS/VE DEADSTART
          NJN    CHK4        IF LOADED FOR NOS *SCD* MODE OR C170 *MDD* MODE
          LDM    SCIA        CHECK IF *SCI* RELOCATED
          SHN    21-13
          MJN    CHK4        IF *SCI* RELOCATED BY *DFT*
          LDD    DO          CHECK DEADSTART ORIGIN
          ZJN    CHK6        IF LOADED FOR DUAL-STATE DEADSTART
          CALL   DSA         INITIATE STANDALONE NOS/VE DEADSTART

 CHK6     CALL   DDS         INITIATE DUAL-STATE NOS/VE DEADSTART
 FIE      SPACE  4,10
**        FIE - FATAL INITIALIZATION ERROR.
*
*         NOTE   RESIDENT OVERLAY MUST BE LOADED BEFORE THIS IS CALLED.


 FIE      BSS    0           ENTRY
          LDC    DASP        610 - *SCI* PRESET FAILURE
          LJM    AAC         ACTIVATE ANALYSIS CODE PROCESSOR
 PDC      SPACE  4,20
**        PDC - PRESET DIRECT CELLS FOR *SCI* USAGE.
*
*         ENTRY  (DO) = DEADSTART TYPE (1 = STANDALONE, 0 = DUAL-STATE).
*                (SCIA) = PP NUMBER, IF DUAL-STATE.
*                       = PP NUMBER + 2000, IF *SCI* INITIATED BY C170 X.MDD.
*                       = PP NUMBER + 4000, IF *SCI* RESTARTED BY *DFT*.
*
*         EXIT   NON-HANDOFF DIRECT CELL POINTERS CLEARED.
*                (DOFF) = *SCI* DIRECTORY ADDRESS.
*                (PPNO) = *SCI* PP NUMBER.
*                (SCDP) = *SCD* PORT NUMBER.
*                (DSPI-1) = *MDD* ACTIVE AND PORT NUMBER.
*                RESIDENT OVERLAY LOADED.
*                CH 17 INACTIVE.
*                TO *FIE* IF FATAL ERROR OCCURS DURING INITIALIZATION.
*
*         USES   T1, T2, DA, CM - CM+3.
*
*         CALLS  CSP, FDO, FHE, PHT, PIB, SBN, SPA, SPN.
*
*         MACROS LOADOV.


 PDC      SUBR               ENTRY/EXIT
          RJM    SBN         STARTED BY NOS?
          RJM    CSP         CONFIGURE *SCI* PP
          LDN    IB          CLEAR NON-HANDOFF DIRECT CELLS
          STD    T1
 PDC1     LDN    0
          STIAO  T1          CLEAR ADDRESS
          LMN    DO
          NJN    PDC1        IF NOT DONE

*         LOAD RESIDENT OVERLAY.

          RJM    FDO         FETCH DIRECTORY HEADER OFFSET
          LOADOV RESOL       LOAD RESIDENT OVERLAY
          EXITMR AAC         SET MAINTENANCE REGISTER READ EXIT ADDRESS
          FATALMR  AAC       SET FATAL MAINTENANCE REGISTER EXIT ADDRESS
          RJM    PHT         PRESET HARDWARE TABLE
          LDN    GPDID       READ GLOBAL PROCESSOR DESCRIPTOR
          RJM    FHE
          MJP    FIE         IF NOT FOUND

*         INTERLOCK WITH C170 OS (IF ANY) AND INITIALIZE CHANNELS.

          LDM    HBUF+GPDST
          LPN    1           EXTRACT LEAST SIGNIFICANT BIT
          STD    DO          SET DEADSTART ORIGIN
          ZJN    PDC1.1      IF NOT STANDALONE NOS/VE
          AOM    ISPB        DISABLE OS BOUNDS MANIPULATION
          LDM    SCIA        CHECK RESTART FLAG
          SHN    21-13
          MJN    PDC2        IF RESTARTED BY *DFT*
          DCN    MR+40       INITIALIZE CHANNELS FROM CTI
          DCN    MX+40
          CCF    *,MX
          UJN    PDC2        CONTINUE

 PDC1.1   SCF    *,MX        WAIT FOR CYBER 170 OS TO RELEASE *SCI*
          DCN    MX+40
          CCF    *,MX
          SCF    *,MR
          DCN    MR+40
          CCF    *,MR

*         DETERMINE TYPE OF ACTIVATION.

 PDC2     LDN    DISCID      GET *SCD* AND *MDD* MODE INFORMATION
          RJM    FHE
          MJP    FIE         IF NOT FOUND
          RJM    SPN         SET PP NUMBER
          LDM    NOSL        GET LOAD SOURCE
          NJN    PDC4        IF NOT *SDA* LOAD
 PDC3     RJM    PIB         PREPARE INTERFACE BLOCK POINTER
          RJM    SPA         SET *SCI* PARAMETER TABLE ADDRESS
          UJN    PDC5        RETURN

 PDC4     LDM    SCIA
          SHN    21-12
          MJN    PDC3        IF C170 *MDD* MODE LOAD
          LDM    HBUF+CDCPFLG  GET *SCD* PORT NUMBER
          LPN    3           ISOLATE DEADSTART PORT NUMBER
          STM    SCDP
          LDM    HBUF+CDCMDD+1
          SHN    21-3        TEST *MDD* FLAG
          PJN    PDC5        IF NO *MDD*
          SHN    21-13-21+3
          LPC    700         ISOLATE *MDD* PORT NUMBER
          LMC    4000        SET CTI FLAG AND ACTIVE DEFINITION
          STM    DSPI-1
 PDC5     LJM    PDCX        RETURN
 SPN      SPACE  4,10
**        SPN - SET PP NUMBER.
*
*         ENTRY  (NOSL) = LOAD SOURCE (1 = CTI, 0 = SDA).
*                (SCIA) = ORIGINAL CONTENTS OF DIRECT CELL 27.
*                (HBUF) = CONSOLE MRT DESCRIPTOR.
*
*         EXIT   (PPNO) = PP NUMBER PASSED BY *DFT*, IF RESTART.
*                       = PP NUMBER PASSED BY *MDD* BOOT, IF C170 X.MDD LOAD.
*                       = PP NUMBER PASSED BY *SDA*, IF DUAL-STATE.
*                       = PP NUMBER FROM CONSOLE MRT, IF STANDALONE DEADSTART.


 SPN      SUBR               ENTRY/EXIT
          LDM    SCIA        CHECK RESTART FLAG
          SHN    21-13
          MJN    SPN1        IF RESTARTED BY *DFT*
          SHN    21-12-21+13
          MJN    SPN1        IF STARTED BY C170 STATE
          LDM    NOSL        CHECK INITIATION STATUS
          NJN    SPN2        IF INITIATED BY CTI
 SPN1     LDM    SCIA        GET NUMBER PASSED BY *SDA*/*DFT*/*MDD* BOOT
          UJN    SPN3        SET PP NUMBER AND EXIT

 SPN2     LDM    HBUF+CDCSCD DETERMINE PP NUMBER FROM CONSOLE MRT
          LPN    77          MASK OFF FLAG
          NJN    SPN3        IF FOUND
          LDM    HBUF+CDCSCD
          SHN    -6          SHIFT OFF FLAG
 SPN3     LPN    77          MASK OFF POSSIBLE FLAGS
          STM    PPNO        SAVE PP NUMBER
          UJN    SPNX        RETURN

          OVERFLOW  RESOL    CHECK FOR OVERFLOW
 CSP      SPACE  4,10
**        CSP - CONFIGURE *SCI* PP.
*
*         ENTRY  (DO) = *SCI* LOAD SOURCE (0 = *SDA* LOAD).
*
*         EXIT   (NOSL) = *SCI* LOAD SOURCE (0 = *SDA* LOAD).
*                (CTUF) = NONZERO IF *MDD* UTILITY LOAD.
*                (VA) = 10000 IF DEADSTARTED AS *MDD* UTILITY MODE.
*                (EOC - 7777) = 0 EXCEPT AS NOTED.
*
*         USES   T7.


 CSP      SUBR               ENTRY/EXIT
          LDC    EOC         SET START ADDRESS FOR CLEARING MEMORY
          STD    T7
          LDN    0
 CSP1     STIAO  T7
          SHN    -14
          ZJN    CSP1        IF NOT TO 7777+1
          LDD    DO          SET LOAD SOURCE
          STM    NOSL
          STM    PPTY        SET PP TYPE (0 = UPPER PP)
          LDD    33          CHECK IF CTI UTILITY
          ZJN    CSP2        IF NOT *MDD* UTILITY
          STM    CTUF        SET CTI UTILITY FLAG
          LDC    1S12        SET BIT SO *MDD* DOES NOT DEADSTART NOS/VE
          STDL   VA
 CSP2     LJM    CSPX        RETURN
 FDO      SPACE  4,10
**        FDO - FETCH DIRECTORY HEADER OFFSET.
*
*         ENTRY  (SC - SC+2) = CIP DIRECTORY R-POINTER.
*
*         EXIT   (A) = (DOFF) = DIRECTORY HEADER OFFSET.
*
*         USES   CM - CM+3.


 FDO      SUBR               ENTRY/EXIT
          LDD    SC          READ RESIDENT OVERLAY HEADER
          LRD    SC+1
          LMC    RR          ACTIVATE R-REGISTER
          CRDL   CM
          ADDL   CM+1        SKIP RESIDENT
          ADN    1           FOR DIRECTORY HEADER
          STML   DOFF        SAVE DIRECTORY HEADER A-ADDRESS
          UJN    FDOX        RETURN

 EOC      BSS    0           EVERYTHING FROM HERE ON GETS ZEROED OUT
 SBN      SPACE  4,10
**        SBN - STARTED BY NOS.
*
*         IF *SCI* IS LOADED BY *SDA* FOR A DUAL-STATE DEADSTART THE FOLLOWING
*         DIRECT CELLS MUST BE MOVED TO FIT THE STANDARD AS DEFINED.
*
*         ENTRY  (SCIA) = *SCI* PP NUMBER.
*
*         USES   SC - SC+2, PP, CD - CD+2.


 SBN      SUBR               ENTRY/EXIT
          LDD    DO
          NJN    SBNX        IF STANDALONE DEADSTART
          LDM    SCIA
          NJN    SBN1        IF NOT STARTED IN PP ZERO
          LDC    DASL        611 - *SCI* LOADED IN PP 0
          STML   SBNA
          UJN    *           HANG

 SBN1     LDN    0
          STD    33          CLEAR *MDD* UTILITY FLAG
          LDD    21          MOVE *SCI* CODE POINTER TO PROPER ADDRESS
          STD    SC
          LDD    22
          STD    SC+1
          LDD    23
          STD    SC+2
          LDD    24          MOVE CTI DIRECTORY POINTER TO PROPER ADDRESS
          STD    CD
          LDD    25
          STD    CD+1
          LDD    26
          STD    CD+2
          UJN    SBNX        RETURN

 SBNA     CON    0           ANALYSIS CODE IF NON-ZERO

          QUAL   *

 CHKX     EQU    /PRESET/CHKX
 DSPI     EQU    7224B       IN SCMT CHARS. BUFFER
 EOC      EQU    /PRESET/EOC
          OVERLAY  (SCI IDLE LOOP),100
 PPNM     SPACE  4,10
***       PPNM - PP NAME AND REVISION LEVEL.


 PPNM     VFD    24/3HSCI
          VFD    8/0#"SCILVL"
 IDL      SPACE  4,10
**        IDL - IDLE LOOP.
*
*         USES   PT.
*
*         CALLS  MUX, SCF, SMP, TIM.


 IDL      ROUTINE

          LDC    SCMT        SERVICE *SCD* MODE
          RJM    SMP
          AOM    AACA        ENABLE *MDD* PROCESSING OF MR ERRORS
          LDC    MDMT        SERVICE *MDD* MODE
          RJM    SMP
          LDN    0           DISABLE *MDD* PROCESSING OF MR ERRORS
          STM    AACA
          LDN    MX          INTERLOCK TPM
          RJM    SCF
          RJM    MUX         PROCESS MUX FOR *MDD*
          LDC    SCMT
          STD    PT
          RJM    MUX         PROCESS MUX FOR *SCD*
          CCF    *,MX        RELEASE TPM
          RJM    TIM         CALL TIMER
          UJN    IDL         LOOP
          EJECT
 CKQ      SPACE  4,10
**        CKQ - COMPLETE CHARACTER QUEUE.
*
*         ENTRY  (BP) = LAST ADDRESS INTO WHICH A CHARACTER WAS PLACED.
*                (BA) = ADDRESS OF THE BEGINNING OF THE OUTPUT STRING.
*
*         EXIT   TO *SMPX*.
*                (CHRC.) = MASTER NUMBER OF CHARACTERS TO OUTPUT.
*                (CHR0.) = NUMBER OF CHARACTERS TO OUTPUT ON PORT 0.
*                (CHR1.) = NUMBER OF CHARACTERS TO OUTPUT ON PORT 1.
*                (CHP0.) = POINTER TO THE CHARACTERS TO OUTPUT ON PORT 0.
*                (CHP1.) = POINTER TO THE CHARACTERS TO OUTPUT ON PORT 1.


 CKQ      ROUTINE            COMPLETE CHARACTER QUEUE

          LDD    BP
          SBD    BA
          STM    CHRC.,PT    STORE LENGTH OF QUEUE
          STD    T0          SAVE IT
          LDM    PTUS.,PT    GET OUTPUT PORTS
          LPN    2           TEST FOR OUTPUT ON PORT ZERO
          ZJN    CKQ1        IF NOT
          LDD    T0          GET LENGTH OF QUEUE
          STM    CHR0.,PT    STORE LENGTH OF QUEUE FOR PORT ZERO
 CKQ1     LDM    PTUS.,PT    GET OUTPUT PORTS
          LPN    4           TEST FOR OUTPUT ON PORT ONE
          ZJN    CKQ2        IF NOT
          LDD    T0          GET LENGTH OF QUEUE
          STM    CHR1.,PT    STORE LENGTH OF QUEUE FOR PORT ONE
 CKQ2     LDD    BA
          STM    CHP0.,PT    SET START OF QUEUE PORT 0
          STM    CHP1.,PT    SET START OF QUEUE PORT 1
*         UJN    SMPX        RETURN

          ERRNZ  SMPX-*      *SMP*  MUST FOLLOW TO FALL INTO RETURN
 SMP      SPACE  4,10
**        SMP - SERVICE MODE PROCESS.
*
*         ENTRY  (A) = MODE TABLE ADDRESS TO BE SERVICED.
*                (LNOC) = LAST OVERLAY LOADED.
*
*         EXIT   MODE DRIVER SERVICED.
*
*         USES   BA, BP, PT.
*
*         CALLS  MODE ROUTINE SPECIFIED IN MODE TABLE.


 SMP      SUBR               ENTRY/EXIT
          STD    PT          SAVE MODE TABLE ADDRESS
          ADN    CHRB.
          STD    BP
          STD    BA
          LDI    PT          FETCH ROUTINE POINTER
          STM    SMPA
          ZJN    SMPX        IF NO ROUTINE
          LDD    PT          TEST FOR *SCD* MODE
          LMC    SCMT
          NJN    SMP3        IF *MDD* MODE
          LDM    SCMT+SCDS.  TEST WHICH *SCD* TO SERVICE
          ZJN    SMP1        IF *SCD/NOS* REQUIRED
          LOADOV NVESI       LOAD *SCD/VE* OVERLAY
          UJN    SMP3        CONTINUE

*         DETERMINE WHICH *SCD/NOS* MODE (CHANNEL OR BUFFERED) TO USE.

 SMP1     LDML   SCMT+CMBS.  DETERMINE CHANNEL OR BUFFERED MODE
          ZJN    SMP2        IF CHANNEL MODE
          SHN    21-17
          MJN    SMP2        IF LOADING CONTROLWARE
          LOADOV NOSBI       LOAD *SCD/NOS* BUFFERED OVERLAY
          UJN    SMP3        CONTINUE

 SMP2     LOADOV NOSCI       LOAD *SCD/NOS* CHANNEL OVERLAY
*         UJN    SMP3        CONTINUE

 SMP3     LJM    **          CALL INTO PROPER ROUTINE
 SMPA     EQU    *-1         (ENTRY POINT ADDRESS)
 SIS      SPACE  4,10
**        SIS - SERVICE INACTIVE *SCD* MODE.
*
*         THIS ROUTINE CAUSES AN *SCD* MODE NOT CURRENTLY BEING DISPLAYED
*         ON THE CONSOLE TO RESPOND TO THE CORRECT OS AS THOUGH THE
*         DISPLAY WAS AN ACTIVE MODE.
*
*         CALLS  SNS, SVS.


 SIS1     SHN    -16
          LMN    7
          ZJN    SIS2        IF MODE DUAL-STATE
          LDM    SCMT+SCDS.
          ZJN    SIS3        IF NOS STATE PRESENT
 SIS1.1   RJM    SVS         SERVICE NOS/VE STATE
          UJN    SISX        RETURN

 SIS2     RJM    SVS         SERVICE NOS/VE STATE
 SIS3     RJM    SNS         SERVICE NOS STATE

 SIS      SUBR               ENTRY/EXIT
          LDML   SCMT+PTDB.
          ZJN    SISX        IF MODE UNDEFINED
          SHN    21-14
          PJN    SIS1        IF PORT IS RELEASED
          SHN    -16
          LMN    17
          NJN    SISX        IF NOT DUAL-STATE
          LDM    SCMT+SCDS.
          NJN    SIS3        IF NOS/VE STATE ACTIVE
          UJN    SIS1.1      SERVICE NOS/VE STATE
 TIM      SPACE  4,10
**        TIM - MAINTAIN MILLISECOND TIME AND EXECUTE TIMED ROUTINES.
*
*         *TIM* USES THE CHANNEL 14 CLOCK TO ALLOW THE EXECUTION OF
*         CERTAIN ROUTINES ON A TIMED BASIS.  THE ROUTINES TO BE
*         ACTIVATED PERIODICALLY ARE IN *ACTB*.  TO ENSURE ACCURACY,
*         *TIM* SHOULD BE CALLED AT LEAST EVERY TWO MILLISECONDS.
*         THE 16-BIT CHANNEL 14 CLOCK ON S0/S0E MAINFRAMES IS PROCESSED IN ITS
*         ENTIRETY, RATHER THAN TRUNCATING IT TO 12 BITS FOR COMPATIBILITY.
*         THIS RESULTS IN CODE MODIFICATION WHICH MUST BE PERFORMED
*         WHENEVER *TIM* IS LOADED INTO MEMORY.  *TIMA* SHOULD ALSO
*         BE INITIALIZED BEFORE THE FIRST CALL TO *TIM*.
*
*         ENTRY  (TIMC) = INITIALIZED AS 12- OR 16-BIT INSTRUCTION.
*                (TIMD) = INITIALIZED FOR 12- OR 16-BIT CLOCK ROLLOVER.
*                (TIME) = INITIALIZED AS 12- OR 16-BIT INSTRUCTION.
*
*         EXIT   (TIMA) IS WITHIN ONE MILLISECOND OF CHANNEL 14 VALUE.
*
*         USES   T1, TI.
*
*         CALLS  SEE *ACTB*.
*
*         NOTE   CHANGES TO THIS ROUTINE SHOULD BE MADE IN *DFT* ALSO.


 TIM      SUBR               ENTRY/EXIT
 TIM1     IAN    14          READ MICROSECOND COUNTER
 TIMC     SBM    TIMA
*TIMC     SBML   TIMA        (16-BIT CLOCK)
          PJN    TIM2        IF NO OVERFLOW
 TIMD     ADC    10000       COMPENSATE FOR CLOCK OVERFLOW
*TIMD     ADC    200000      (16-BIT CLOCK)
 TIM2     ADC    -1000D
          MJN    TIMX        IF LESS THAN ONE MILLISECOND ELAPSED
          LDC    1000D       ADVANCE BASE TIME BY ONE MILLISECOND
 TIME     RAM    TIMA
*TIME     RAML   TIMA        (16-BIT CLOCK)
          AOM    TIMB        ADVANCE SCAN COUNTER
          LMN    5
          NJN    TIM1        IF SCAN PERIOD NOT UP
          STM    TIMB        RESET SCAN COUNTER
          LDC    ACTB        PRESET ACTION ENTRY
          STD    TI
 TIM3     AOM    2,TI        ADVANCE ENTRY COUNTER
          SBM    1,TI
          MJN    TIM4        IF DELAY NOT COMPLETE
          LDN    0
          STM    2,TI        RESET COUNTER
          LDI    TI          CALL SPECIFIED ROUTINE
          STD    T1
          RJM    0,T1
 TIM4     LDN    3           ADVANCE TABLE INDEX
          RAD    TI
          LMC    ACTBL
          NJN    TIM3        IF MORE ENTRIES TO CHECK
          LJM    TIM1        RETURN

 TIMA     CON    0           1000 MICROSECOND COUNTER
 TIMB     CON    0           MILLISECOND COUNTER

 ACTB     BSS    0
          CON    PCC,1000D/5,0 PROCESS CPU/PP COMMUNICATION FUNCTIONS
          CON    CST,50D/5,0   CHECK FOR *SCD* PARAMETER TABLE CHANGES
          CON    SIS,500D/5,0  SERVICE INACTIVE *SCD* STATES
          CON    TPR,250D/5,0  TEST FOR PORT REQUESTED EVERY 0.25 SECONDS
          CON    TVO,1000D/5,0 TEST FOR NOS/VE OPERATIONAL
          CON    CDP,1000D/5,0 CHECK FOR DELAY ON PORTS
 ACTBL    EQU    *

*         TIMERS USED BY OVERLAYS MUST BE IN RESIDENT.

 PRRA     BSS    1           USED TO DETECT *REQUEST DFT IDLE* TIMEOUT
 CTVA     BSS    1           USED TO DETECT *DROPVE* TIMEOUT
 CDPA     BSSZ   1           USED TO TIME DELAY ON PORT 0
 CDPB     BSSZ   1           USED TO TIME DELAY ON PORT 1
          ERRNZ  CDPB-CDPA-1 CELLS MUST BE CONTIGUOUS
 PCC      SPACE  4,10
**        PCC - PROCESS CPU/PP COMMUNICATION FUNCTIONS.
*
*         UPDATES THE *SCI* TIME WORD IN THE CPU/PP COMMUNICATION BLOCK
*         AND CHECKS FOR RELOCATION REQUESTS.
*
*         ENTRY  (VA) = NOS/VE STATUS (0 = INACTIVE, 1 = ACTIVE).
*
*         EXIT   TO *PRR* IF RELOCATION REQUEST IS PRESENT.
*                *SCI* TIME WORD IN RELOCATION BLOCK UPDATED.
*
*         USES   CM - CM+3, T1 - T4, W4 - W7.
*
*         CALLS  IIB, *PRR*, SPB.
*


 PCC      SUBR               ENTRY/EXIT
          LDD    VA          CHECK STATUS
          ZJN    PCCX        IF NOS/VE NOT ACTIVE

*         CHECK RELOCATION CONTROL WORD.

          LDN    D8RLP       READ RELOCATION CONTROL WORD POINTER
          RJM    IIB
          CRDL   W4
          LDD    W4+3
          ZJN    PCCX        IF NO POINTER
          LRD    W4+1
          RJM    SPB         SET PP BOUNDS
          LDD    W4          READ RELOCATION CONTROL WORD
          ADC    RR
          CRDL   CM
          ADN    1           READ MONITOR TIME WORD
          CRDL   T1
          ADN    1           UPDATE *SCI* TIME WORD
          CWDL   T1
          LDD    CM          IGNORE UPPER BITS (INITIALIZE FLAG)
          SCN    77
          ADDL   CM+1
          SCN    77
          ZJN    PCCX        IF NO REQUESTS PRESENT

*         CALL *PRR* TO PROCESS THE RELOCATION REQUEST.
*
*         (CM - CM+3) = RELOCATION CONTROL WORD.
*         (W4 - W7) = R-POINTER TO RELOCATION CONTROL WORD.

          CALL   PRR
 TPR      SPACE  4,10
**        TPR - TEST FOR PORT REQUESTED.
*
*         TO MINIMIZE OVERLAY LOADING, THIS ROUTINE VERIFIES THAT EITHER
*         THE PORT REQUIRED BY *SCD* OR *MDD* IS AVAILABLE OR THAT A
*         CALL TO *EMC* IS REQUIRED TO SET *REREQUESTED* FOR A PORT.
*
*         ENTRY  (PT) = *SCMT*.
*
*         EXIT   (RTNP.) = *BPA* IF PORT IS TO BE RELEASED.
*
*         USES   PT, T0, T1.
*
*         CALLS  CPS, RTR, *EMC*.


 TPR2     LDM    RDATA+7     DETERMINE WHICH PORT(S) ARE AVAILABLE
          LPN    0#03
          LMN    0#03        CHANGE PORT RESERVED TO PORT AVAILABLE
          STD    T0

*         SINCE *SCI* DOES NOT SET REREQUESTED BITS FOR PORTS BEING SHARED
*         INTERNALLY, SET FAKE REREQUESTED STATUS FOR *SCI*-OWNED PORTS.

          LDML   EMC0+1      DETERMINE WHICH PORT(S) ARE OWNED BY *SCI*
          SHN    1
          ADML   EMC0+0
          SHN    -14+4       POSITION TO REREQUESTED BITS
          LPN    0#30
          STD    T1
          LMC    0#FF        CLEAR EXTERNAL REREQUESTED STATUS FOR *SCI* PORTS
          LPML   RDATA+7
          LMD    T1
          STM    RDATA+7     SAVE MERGED EXTERNAL/INTERNAL REREQUESTED BITS

*         CHECK *SCD* PORT STATUS.

          LDM    SCMT+PTDB.  CHECK PORT STATUS FOR *SCD*
          RJM    CPS
          NJN    TPR4        IF PORT AVAILABLE OR REREQUESTED NOT SET

*         CHECK *MDD* PORT STATUS.

 TPR3     LDM    MDMT+PTDB.  CHECK PORT STATUS FOR *MDD*
          RJM    CPS
          ZJN    TPRX        IF NO PORT(S) AVAILABLE AND REREQUESTED ALREADY SET
 TPR4     CALL   EMC         ACQUIRE PORT(S) AND/OR SET REREQUESTED STATUS

 TPR      SUBR               ENTRY/EXIT
          LDM    S0FLG       TEST IOU TYPE
          NJN    TPRX        IF ON AN S0/S0E
          LDM    OVLP        TEST OVERLAY LOAD PERMITTED
          NJN    TPRX        IF *MDD* COMMAND ACTIVE
          RJM    RTR         READ THE TEST MODE REGISTER
          LPN    14          MASK FOR JUST REQUESTED BITS
          ZJP    TPR2        IF NOT REQUESTED TEST IF NEEDED
          SHN    -1          ALIGN WITH PTUS. FLAGS
          STD    T1
          LDM    SCMT+PTUS.  CHECK *SCD* PORT(S)
          LPDL   T1
          NJN    TPR1        IF REQUESTED PORT IS HELD BY *SCD*
          LDC    MDMT        CHECK *MDD* PORT(S)
          STD    PT
          LDM    MDMT+PTUS.  TEST IF *MDD* HAS THE PORT
          LPDL   T1
          ZJN    TPRX        IF NEITHER MODE CURRENTLY HAS THE PORT
 TPR1     LDC    BPA
          STI    PT          RESET RTNP. FOR THE MODE
          UJN    TPRX        RETURN
 TVO      SPACE  4,15
**        TVO - TEST NOS/VE OPERATIONAL.
*
*         TESTS IF THE *DROPVE* FLAG OR TERMINATE SYSTEM FLAG HAS BEEN
*         SET IN THE EICB.
*
*         EXIT   TO *DDS* IF DEADSTART NOS/VE FLAG IS SET.
*                TO *CTV* IF TERMINATE NOS/VE FLAG IS SET.
*
*         USES   T1 - T6.
*
*         CALLS  SPA.


 TVO2     LDD    SB          CHECK IF PARAMETER TABLE ALREADY FOUND
          ADD    SB+1
          NJN    TVO3        IF ADDRESS ALREADY DEFINED
          RJM    SPA         SET *SCI* PARAMETER TABLE ADDRESS IF DEFINED
 TVO3     LDN    D8ST        TEST IF DEADSTART BIT HAS BEEN SET BY *SDA*
          RJM    IIB
          CRDL   T1
          LDD    T4
          LPN    1
          ZJN    TVOX        IF NOT RETURN
          CALL   DDS         INITIATE DUAL-STATE DEADSTART

 TVO4     LDD    IB          TEST IF EICB HAS BEEN DEFINED
          ADD    IB+1
          ADD    IB+2
          NJN    TVO2        IF DEFINED
          RJM    PIB         TRY FOR IT

 TVO      SUBR               ENTRY/EXIT
          LDDL   VA          TEST FOR *MDD* UTILITY MODE
          ZJN    TVO4        IF NOS/VE NOT AROUND
          LDM    SCMT+PTDB.  TEST IF *SCD* IS ACTIVE
          ZJN    TVOX        IF NOT THEN DONT TERMINATE
          LDK    D7ST        NOS STATUS WORD
          RJM    IIB
          CRDL   T1          READ *DROPVE* FLAG
          ADN    D8DS-D7ST
          CRDL   T3          READ TERMINATE NOS/VE BIT
          LDDL   T2
          LPN    20
          NJN    TVO1        IF *DROPVE* FLAG SET
          LDD    T6
          LMN    1
          NJN    TVOX        RETURN IF NOS/VE STILL OPERATIONAL
 TVO1     LDN    0           CLEAR *MDD* REPEAT FLAG
          STM    RFLG
          CALL   CTV         HANDLE TERMINATING NOS/VE
          QUAL   *

 PPNM     EQUAL
 PRRA     EQUAL
 SMPX     EQUAL
 TIMA     EQUAL
 TIMC     EQUAL
 TIMD     EQUAL
 TIME     EQUAL
 CTVA     EQUAL
 CDPA     EQUAL
 CDPB     EQUAL
          OVERLAY  (RESIDENT OVERLAY),*+5
 RESOL    SPACE  4,10
 RESOL    ROUTINE            DUMMY ROUTINE TO IDENTIFY OVERLAY
          QUAL   *
 AAC      SPACE  4,10
**        AAC - ACTIVATE ANALYSIS CODE ERROR PROCESSOR.
*
*         ENTRY  (A) = ANALYSIS CODE.
*                (AACA) = 1, IF *MDD* IS TO PROCESS MR ERRORS.
*                       = 0, IF *SCI* IS TO HANG ON MR ERRORS.
*
*         EXIT   TO *PAN* TO PROCESS THE ERROR.
*                (ANCD) = ANALYSIS CODE.
*                (OVLP) = 0.


 AAC      STML   ANCD        SAVE ANALYSIS CODE
          LDN    0           ENSURE THAT OVERLAY LOADS ARE PERMITTED
          STM    OVLP
          CALL   PAN         PROCESS ANALYSIS CODE

 AACA     CON    0           NONZERO IF *MDD* SHOULD PROCESS ERROR
 FTE      SPACE  4,10
**        FTE - FUNCTION TIME OUT PROCESSOR.
*
*         ENTRY  SAME AS *AAC*.


 FTE      EQU    AAC         *FTE* PROCESS IS THE SAME AS *AAC*
 ACL      SPACE  4,10
**        ACL - ACTIVATE CONTROLWARE LOAD.
*
*         ENTRY  (PT) = MODE TABLE ADDRESS.
*
*         USES   T2.
*
*         EXIT   (CHRC., PTNP., RTNL.) UPDATED.


 ACL      BSS    0           ENTRY
          LDN    0
          STM    CHRC.,PT    CLEAR CHARACTER COUNT
          STM    CWLD.,PT    CLEAR CONTROLWARE LOADED FLAG
          LDM    RTNL.,PT    GET CONTROLWARE LOAD ROUTINE
          STD    T2
          LDI    T2
          STI    PT          PROCESS CONTROLWARE LOAD NEXT
 ACL1     LJM    SMPX        EXIT
 BPA      SPACE  4,10
**        BPA - BREAK PORT ACCESS.
*
*         ENTRY  *F7* KEY DETECTED OR REQUESTED BIT SET
*                IN THE TESTMODE REGISTER.
*
*         EXIT   TO *RPR*.
*                TO *SMPX* VIA *ACL1* IF OUTPUT IN PROGRESS.
*
*         CALLS  RTR.


 BPA      BSS    0
          LDM    CHRC.,PT
          NJN    ACL1        IF NOT DONE OUTPUTTING
          CALL   RPR         RELINGUISH PORT RESERVATION
 CDP      SPACE  4,15
**        CDP - CHECK FOR DELAY ON PORTS.
*
*         IF A DELAY IS IN PROGRESS ON EITHER PORT, THIS ROUTINE DECREMENTS
*         THE CORRESPONDING DELAY COUNTER.
*
*         ENTRY  (CDPA) <> 0 IF A DELAY IS IN PROGRESS ON PORT 0.
*                (CDPB) <> 0 IF A DELAY IS IN PROGRESS ON PORT 1.
*
*         EXIT   (CDPA) OR (CDPB) DECREMENTED IF DELAY IN PROGRESS.


 CDP      SUBR               ENTRY/EXIT
          LDM    CDPA        CHECK PORT 0 DELAY COUNTER
          ZJN    CDP1        IF NO DELAY IN PROGRESS ON PORT 0
          SOM    CDPA        DECREMENT PORT 0 DELAY COUNTER
 CDP1     LDM    CDPB        CHECK PORT 1 DELAY COUNTER
          ZJN    CDPX        IF NO DELAY IN PROGRESS ON PORT 1
          SOM    CDPB        DECREMENT PORT 1 DELAY COUNTER
          UJN    CDPX        RETURN
 CPS      SPACE  4,10
**        CPS - CHECK PORT STATUS.
*
*         ENTRY  (A) = *PTDB.* FOR PORT BEING CHECKED.
*                (T0) = AVAILABLE PORTS.
*                (RDATA - RDATA+7) = *TM* REGISTER.
*
*         EXIT   (A) = 0, IF PORT(S) UNAVAILABLE AND REREQUESTED SET.
*                    > 0, IF PORT(S) AVAILABLE OR REREQUESTED NOT SET.
*
*         USES   T1.


 CPS      SUBR               ENTRY/EXIT
          ZJN    CPSX        IF MODE UNDEFINED
          LPN    3
          STD    T1
          LDM    CPSA,T1     SET PORT(S) REQUIRED
          LPDL   T0
          NJN    CPSX        IF REQUIRED PORT(S) AVAILABLE
          LDM    RDATA+7     CHECK REREQUESTED STATUS OF UNAVAILABLE PORT(S)
          LPML   CPSA,T1
          LMM    CPSA,T1
          LPN    0#30
          UJN    CPSX        RETURN WITH (A) = REREQUESTED STATUS

 CPSA     BSS    0           PORT REREQUESTED AND AVAILABLE INDEXED BY *PTDB.*
          LOC    0
          CON    0#11        PORT 0 ONLY
          CON    0#22        PORT 1 ONLY
          CON    0#33        PORT 0 INPUT, BOTH PORTS OUTPUT
          CON    0#33        PORT 1 INPUT, BOTH PORTS OUTPUT
          LOC    *O
 CSP      SPACE  4,10
**        CSP - CHECK *SCD* PORT.
*
*         THIS ROUTINE IS CALLED WHENEVER A CONTROL-G OR A LOST CARRIER CONDITION IS
*         DETECTED ON A PORT.  IF THE PORT IS THE SAME ONE THAT *SCD* MODE IS USING,
*         THEN THE *SCD* CONTROLWARE LOADED FLAG IS CLEARED.  NO CHECK IS MADE TO SEE
*         IF *SCD* MODE IS ACTIVE BECAUSE RESIDENT IS TIGHT ON SPACE AND IT DOES NOT
*         HURT IF THE FLAG IS CLEARED WHEN THE MODE IS NOT ACTIVE.
*
*         ENTRY  (T2) = PORT NUMBER THAT RECEIVED THE CONTROL-G OR LOST CARRIER CONDITION.
*
*         EXIT   (SCMT+CWLD.) = 0 IF *SCD* IS USING THE SAME PORT.


 CSP      SUBR               ENTRY/EXIT
          LDML   SCMT+PTUS.  GET *SCD* PORT NUMBER
          SHN    -2
          LPN    1
          LMD    T2          COMPARE WITH THE PORT THAT GOT THE CONDITION
          NJN    CSPX        IF NOT SAME AS *SCD* PORT
          STM    SCMT+CWLD.  CLEAR *SCD* CONTROLWARE LOADED FLAG
          UJN    CSPX        RETURN
 CST      SPACE  4,10
**        CST - CHECK *SCI* PARAMETER TABLE.
*
*         USES   T1, CM - CM+3.
*
*         CALLS  GSI, UDB, *SMT*.


 CST      SUBR               ENTRY/EXIT
          LDD    SB
          ADD    SB+1
          ZJN    CSTX        IF NO *SCI* PARAMETER TABLE
          RJM    GSI         GET *SCI* PARAMETER TABLE INTERLOCK
          LDML   SCMT+PTDB.  PROPAGATE *SCD* PORT ATTACHED FLAG
          LPC    0#1000
          STDL   T1
          LDDL   CM+2
          LPC    0#EFFF
          ADDL   T1
          STDL   CM+2
          LDML   MDMT+PTDB.  PROPAGATE *MDD* PORT ATTACHED FLAG
          LPC    10000
          ADD    CM+3
          STDL   CM+3
          LDM    SBAO        UPDATE PORT STATUS IN CM TABLE
          LMC    RR
          CWDL   CM          PROPAGATE FLAGS AND CLEAR INTERLOCK
          LDDL   CM+1        CHECK *SCD*/*MDD* DEFINITION CHANGED FLAGS
          LPC    0#C000
          ZJN    CSTX        IF NO CHANGES TO TABLE

*         THIS PIECE OF CODE MIGHT BE A CANDIDATE TO MOVE TO SMT.
*         IT IS PLACED HERE TO KEEP FROM GETTING *INVALID MONITOR
*         COMMAND* AT TRANSITION FROM BOOT TO CORE NOS/VE.

          LDD    CB          TEST IF NOS/VE COMMUNICATION IS SET UP
          ADD    CB+1
          ZJN    CST1        IF NOT
          LDM    SCMT+COMM.  RESET INPUT TO NOS/VE
          LPC    0#FF00
          STM    SCMT+COMM.
          LDN    0
          STM    SCMT+COMM.+1
          LDN    1
          RJM    UDB         WRITE WORD FOR NOS/VE
 CST1     CALL   SMT         RESET MODE TABLES
 GKC      SPACE  4,10
**        GKC - GET KEYBOARD CHARACTER.
*
*         EXIT   (A) = NEXT CHARACTER RECEIVED FROM KEYBOARD.
*
*         USES   T1, T2.


 GKC      SUBR               ENTRY/EXIT
          LDM    KBOP.,PT
          LPN    3
          ADD    PT
          ADK    CHARS.
          STD    T1
          LDI    T1          GET LAST CHARACTER
          STD    T2          SAVE CHARACTER
          ZJN    GKCX        IF NONE
          AOM    KBOP.,PT    INCREMENT OUTPUT POINTER
          LDN    0
          STI    T1          CLEAR CHARACTER FROM BUFFER
          LDD    T2
          UJN    GKCX        RETURN
 GSI      SPACE  4,10
**        GSI - GET *SCI* PARAMETER TABLE INTERLOCK.
*
*         EXIT   PARAMETER TABLE INTERLOCKED.
*                (CM - CM+3) = PARAMETER TABLE FIRST WORD WITH
*                              INTERLOCK BIT CLEARED.
*
*         CALLS  SPB.


 GSI      SUBR               ENTRY/EXIT
          LRD    SB
          RJM    SPB         SET PP BOUNDARY
 GSI1     LDN    0
          STD    CM
          STD    CM+2
          STD    CM+3
          LDC    SPIB        INTERLOCK BIT
          STDL   CM+1
          LDM    SBAO        *SCI* PARAMETER TABLE ADDRESS
          LMC    RR
          RDSL   CM          SET INTERLOCK
          LDDL   CM+1
          LPC    SPIB
          NJN    GSI1        IF INTERLOCK ALREADY SET
          UJN    GSIX        RETURN
 LNO      SPACE  4,10
**        LNO - LOAD NEXT OVERLAY.
*
*         ENTRY  (A) = 6/OVERLAY ID, 12/JUMP ADDRESS.
*
*         EXIT   TO ROUTINE IN OVERLAY LOADED.
*                TO *SMPX* IF OVERLAY LOAD INHIBITED.
*                (OVLS) INCREMENTED IF OVERLAY ACTUALLY LOADED.
*
*         USES   T1, W0 - W3.


 LNO2     LJM    SMPX        PRETEND MODE IS FINISHED

 LNO      SUBR               ENTRY
          STM    LNOB        SET OVERLAY JUMP ADDRESS
          SHN    -14         GET OVERLAY INDEX
          STD    T1
          LMC    **          COMPARE WITH CURRENT OVERLAY
 LNOC     EQU    *-1
          ZJN    LNO1        IF CURRENT OVERLAY
          LDM    OVLP        TEST IF OVERLAY LOAD RESTRICTED
          NJN    LNO2        IF SO
          AOML   OVLS        INCREMENT OVERLAY COUNTER
          LDD    T1          LOAD APPROPRIATE OVERLAY
          STM    LNOC        SAVE OVERLAY ID
          ADML   DOFF        (A) = DIRECTORY OFFSET
          LRD    SC+1        (R) = DIRECTORY ADDRESS
          LMC    RR          ACTIVATE R-REGISTER
          CRDL   W0          READ DIRECTORY ENTRY
          LDD    W0
          STM    LNOA        SET LOAD ADDRESS
          LDD    SC          RESIDENT OVERLAY ADDRESS
          ADDL   W3          ADD IN OFFSET
          ADC    RR+1        ACTIVATE R-REGISTER
          CRML   **,W1       READ IN OVERLAY
 LNOA     EQU    *-1
 LNO1     LJM    **          JUMP TO ROUTINE
 LNOB     EQU    *-1
          EJECT
 MUX      SPACE  4,10
**        MUX - DO THE I/O ON THE TWO PORT MUX.
*
*         OUTPUT THE CHARACTERS QUEUED UP FOR THIS MODE AND CHECK FOR
*         ANY INPUT DATA.
*
*         ENTRY  (PT) = MODE TABLE ADDRESS.
*                ((PT)+CHP0.) = ADDRESS OF CHARACTER STRING FOR PORT 0.
*                ((PT)+CHP1.) = ADDRESS OF CHARACTER STRING FOR PORT 1.
*                ((PT)+CHRC.) = SIZE OF CHARACTER STRING.
*
*         USES   T2.
*
*         CALLS  CSP, OTM, RDC.


*         CARRIER HAS BEEN LOST ON THE PORT.

 MUX8     LDN    1           SET CARRIER LOST FLAG FOR THIS PORT
          STM    MUXB,T2
          LDDL   PT          CHECK IF *MDD* PORT
          LMC    MDMT
          NJN    MUX9        IF NOT *MDD* PORT
          STML   OVLP        ALLOW OVERLAY LOADS
 MUX9     RJM    CSP         CHECK *SCD* PORT
          LDC    ACL         ACTIVATE CONTROLWARE LOAD
          STI    PT
          LDN    0           CLEAR *X-OFF* STATUS FOR THIS PORT
          STM    XOFF,T2
 MUX10    FNC    MXDM,MX     DESELECT PORT
          AJM    *,MX        WAIT FOR FUNCTION TO BE ACCEPTED

 MUX      SUBR               ENTRY/EXIT
          LDML   PTDB.,PT
          SHN    21-14
          PJN    MUXX        IF PORT IS NOT ACTIVE
          LDM    PTUS.,PT    GET PORTS USED
          ZJN    MUXX        IF NO OUTPUT PORT
          LPN    1           ISOLATE INPUT PORT
          STD    T2
          ADC    MXPT        ADD IN PORT SELECT FUNCTION
          STM    MUXA
*         PSN                NEED ON S0/S0E IF NO INSTRUCTION BEFORE *FNC*
          LDM    CDPA,T2     CHECK FOR DELAY IN PROGRESS ON THIS PORT
          NJN    MUXX        IF DELAY IN PROGRESS
          FNC    MXPT+0,MX   SELECT DESIRED PORT
 MUXA     EQU    *-1

*         CHECK PORT STATUS.

          FNC    MXSS,MX     GET PORT STATUS
          ACN    MX
          IAN    MX
          DCN    MX
          STM    MXS0,T2     SAVE PORT STATUS
          SHN    21-DCDB
          PJP    MUX8        IF LOST CARRIER
          LDM    MUXB,T2     CHECK IF CARRIER DOWN IN LAST PORT STATUS
          ZJN    MUX2        IF CARRIER NOT DOWN LAST TIME
          LDN    0           CLEAR CARRIER DOWN IN LAST STATUS FLAG
          STM    MUXB,T2

*         A 16 SECOND DELAY IS REQUIRED ON A PORT IF THE CARRIER GOES DOWN AND
*         COMES BACK UP.  THIS IS BECAUSE THE TPM DOES A 12 - 15 SECOND DELAY
*         IN THIS SITUATION DURING WHICH IT DOES NOT RESPOND TO FUNCTIONS OR
*         DATA.

          LDN    16D         SET DELAY TIME TO AT LEAST 15 SECONDS
          STM    CDPA,T2
 MUX1     LJM    MUX10       DESELECT PORT

 MUX2     LDM    MXS0,T2     CHECK DATA SET READY
          SHN    21-DSRB
          MJN    MUX3        IF DATA SET READY
          FNC    MXDR+1,MX   SET DATA TERMINAL READY
          AJM    *,MX        WAIT FOR FUNCTION COMPLETE

*         AFTER A SETDTR FUNCTION, *SCI* MUST DELAY BECAUSE OF A 0.5 SECOND
*         DELAY IN THE PC CONSOLE SOFTWARE.  IF *SCI* SENDS DATA TO THE
*         PC CONSOLE BEFORE THE PC CONSOLE DELAY IS COMPLETE, THAT DATA
*         WILL BE LOST.

          LDN    2           SET DELAY TIME TO AT LEAST 1 SECOND
          STM    CDPA,T2
          UJN    MUX1        DESELECT PORT

 MUX3     SHN    21-INRB-21+DSRB+22
          PJN    MUX4        IF NO INPUT AVAILABLE
          RJM    RDC         READ CHARACTER

*         CHECK FLOW CONTROL.

 MUX4     LDM    XOFF,T2
          NJN    MUX1        IF X-OFF RECEIVED
          LDM    MXS0,T2
          SHN    21-OBRB
          PJN    MUX1        IF OUTPUT BUFFER FULL

*         PROCESS PORT 0 OUTPUT.

          LDM    CHR0.,PT
          ZJN    MUX5        IF NO CHARACTERS TO OUTPUT ON PORT 0
          STD    T2          SAVE NUMBER
          FNC    MXPT+0,MX   SELECT PORT 0
          LDM    CHP0.,PT    GET POINTER FROM WHICH TO OUTPUT
          RJM    OTM         OUTPUT TO MUX
          STM    CHR0.,PT    SAVE REMAINING CHARACTERS
          ZJN    MUX5        IF MULTIPLEXOR ACCEPTED ALL THE CHARACTERS
          LMC    777777
          ADD    T2          COMPUTE NEW BUFFER ADDRESS
          RAM    CHP0.,PT

*         PROCESS PORT 1 OUTPUT.

 MUX5     LDM    CHR1.,PT    CHARACTERS TO OUTPUT ON PORT 1
          ZJN    MUX6        IF NONE
          STD    T2          SAVE NUMBER
          FNC    MXPT+1,MX   SELECT PORT 1
          LDM    CHP1.,PT    GET POINTER FROM WHICH TO OUTPUT
          RJM    OTM         OUTPUT TO MUX
          STM    CHR1.,PT    SAVE REMAINING CHARACTERS
          ZJN    MUX6        IF MULTIPLEXOR ACCEPTED ALL THE CHARACTERS
          LMC    777777
          ADD    T2          COMPUTE NEW BUFFER ADDRESS
          RAM    CHP1.,PT

*         UPDATE MASTER CHARACTER COUNTER.

 MUX6     LDM    CHR0.,PT    RECONCILE CHARACTER COUNTERS
          SBM    CHR1.,PT
          PJN    MUX7        IF PORT 0 HAS MORE CHARACTERS LEFT THAN PORT 1
          LDN    0           USE PORT 1 VALUE
 MUX7     ADM    CHR1.,PT
          STM    CHRC.,PT    SET MASTER CHARACTER COUNTER
          LJM    MUX10       RETURN
 MUXB     BSSZ   1           CARRIER LOST ON PORT 0
 MUXC     BSSZ   1           CARRIER LOST ON PORT 1
          ERRNZ  MUXC-MUXB-1 CELLS MUST BE CONTIGUOUS

 OTM      SPACE  4,10
**        OTM - OUTPUT TO MUX.
*
*         ENTRY  (A) = ADDRESS FROM WHICH TO BEGIN OUTPUT.
*                (T2) = NUMBER OF CHARACTERS TO OUTPUT.
*
*         EXIT   (A) = NUMBER OF UNSENT CHARACTERS.
*
*         USES   T1.


*         PROCESS PREMATURE TERMINATION OF OUTPUT.

 OTM2     STD    T1          SAVE NUMBER OF UNSENT CHARACTERS
          DCN    MX+40
          LDM    S0FLG       SET MAINFRAME TYPE (S0/S0E = 1, GENERIC = 0)
          RAD    T1          ACCOUNT FOR CHARACTER LOST BY S0/S0E

 OTM      SUBR               ENTRY/EXIT
          STM    OTMA        SET CHARACTER BUFFER ADDRESS
          LDD    T2          GET MAXIMUM NUMBER OF CHARACTERS
          FNC    MXWT,MX     ACTIVATE BUFFER FOR OUTPUT
          ACN    MX
          OAM    **,MX       OUTPUT TO PORT ON MUX
 OTMA     EQU    *-1

*         WAIT FOR OUTPUT TO COMPLETE OR TERMINATE PREMATURELY.

 OTM1     IJM    OTM2,MX     IF CHANNEL WENT INACTIVE
          FJM    OTM1,MX     WAIT FOR CHANNEL TO GO INACTIVE -OR- EMPTY
          DCN    MX+40
*         LDN    0
          UJN    OTMX        RETURN WITH (A) = 0
 SPA      SPACE  4,10
**        SPA - SET UP *SCI* PARAMETER TABLE ADDRESS FROM EICB.
*
*         IF THE *SCI* PARAMETER TABLE IS NOT DEFINED, *D7RS+2* MAY CONTAIN
*         EITHER ALL ONES OR ALL ZEROS.  THERE IS NO NEED TO CHECK FOR ALL
*         ZEROS SINCE THE RESULTING R-REGISTER AND OFFSET WOULD STILL BE ZERO.
*
*         EXIT   (SB - SB+1) = R-REGISTER IF PARAMETER TABLE IS DEFINED.
*                (SBAO) = OFFSET.
*
*         USES   W0 - W0+3.
*
*         CALLS  IIB, STA.


 SPA      SUBR               ENTRY/EXIT
          LDN    D7RS+2      GET ADDRESS FROM EICB
          RJM    IIB
          CRDL   W0
          LDDL   W0+2        CHECK IF TABLE DEFINED
          SHN    -15
          NJN    SPAX        IF NO PARAMETER TABLE DEFINED
          RJM    STA         CREATE R-REGISTER ADDRESS
          STM    SBAO        SAVE OFFSET
          SRD    SB          SAVE R-REGISTER
          UJN    SPAX        RETURN
 RDC      SPACE  4,10
**        RDC - READ CHARACTER.
*
*         ENTRY  INPUT AVAILABLE ON MUX.
*                (T2) = PORT NUMBER.
*
*         CHARACTER TRANSFERRED FROM PORT BLOCK TO CHARS. BUFFER.
*         IF CHARS. BUFFER IS FULL THE NEW CHARACTER IS IGNORED.
*
*         EXIT   (RTNP.) = *BPA* IF 1E,77 CHARACTER STRING READ.
*                        = *ACL* IF CONTROL-G RECEIVED IN ANY MODE.
*                        = *ACL* IF CONTROL-I RECEIVED IN *SCD/NOS* MODE.
*
*         USES   T3.
*
*         CALLS  CHS.


 RDC8     LDN    1           SET WAIT FLAG
 RDC9     STM    XOFF,T2     SET/CLEAR WAIT FLAG

 RDC      SUBR               ENTRY/EXIT
          FNC    MXRD,MX
          ACN    MX
          IAN    MX
          DCN    MX
          LPC    0#7F        TRIM PARITY
          ZJN    RDCX        IF NO CHARACTER
          STM    RDCA        SAVE KEYBOARD CHARACTER
          LMN    XON
          ZJN    RDC9        IF X-ON RECEIVED
          LMN    XOF&XON
          ZJN    RDC8        IF X-OFF RECEIVED
          LMN    RS&XOF
          NJN    RDC1        IF NOT START OF MULTIPLE CODE
          LDN    1
          STM    RSMC.,PT    SET FOUND 0#1E
          UJN    RDCX        RETURN

 RDC1     LMC    VV&RS       CHECK FOR LOWER CASE V
          ZJN    RDC3        IF MIGHT BE AN *F6* KEY
          LMN    WW&VV       CHECK FOR LOWER CASE W
          ZJN    RDC3        IF MIGHT BE AN *F7* KEY
          LMC    BEL&WW
          NJN    RDC1.5      IF NOT CONTROL-G
          RJM    CSP         CHECK *SCD* PORT
          LDDL   PT
          LMC    MDMT
          NJN    RDC2        IF NOT *MDD* MODE
          STM    OVLP        CLEAR PROHIBIT OVERLAY LOAD FLAG
          UJN    RDC2        CONTINUE

 RDC1.5   LDD    PT          CHECK FOR CONTROL-I IN *SCD/NOS* MODE
          LMC    SCMT
          NJN    RDC4        IF *MDD* MODE
          LDM    SCMT+SCDS.
          NJN    RDC4        IF *SCD/VE* MODE
          LDM    RDCA
          LMN    TAB
          NJN    RDC4        IF NOT CONTROL-I
 RDC2     LDC    ACL         ACTIVATE CONTROLWARE LOAD
          STI    PT          RESET RTNP.
          LJM    RDCX        RETURN

 RDC3     LDM    RSMC.,PT    TEST FOR *F6* KEY
          ZJN    RDC4        IF 1E NOT FOUND
          LDN    0           ENABLE OVERLAY LOAD
          STM    OVLP
          CALL   CHS         CHANGE DRIVER STATE?

 RDC4     LDM    KBIP.,PT    CALCULATE NEXT CHARACTER POSITION
          LPN    3
          ADC    CHARS.      (T3) = POINTER TO CHARS. BUFFER
          ADD    PT
          STD    T3
          LDD    PT          CHECK FOR *SCD/VE* MODE
          LMC    SCMT
          NJN    RDC6        IF *MDD* MODE
          LDM    SCMT+SCDS.
          ZJN    RDC6        IF *SCD/NOS* MODE
          LDM    RDCA
          SBN    0#12
          NJN    RDC5        IF NOT DC2
          LDM    SCMT+RSMC.
          NJN    RDC7        THROW CHARACTER AWAY
 RDC5     LDM    SCMT+RSMC.
          ZJN    RDC6        IF THE LAST CHARACTER WAS NOT A COMMAND CODE
          LDM    RDCA
          ADC    0#80        SET HIGH ORDER BIT TO FLAG A COMMAND CODE
          STM    RDCA
          LDN    0
          STM    SCMT+RSMC.  CLEAR COMMAND CODE FLAG
 RDC6     LDI    T3          CHECK FOR EMPTY SLOT IN CHARS BUFFER
          NJN    RDC7        IF SLOT NOT EMPTY THROW AWAY CHARACTER
          LDM    RDCA        PLACE CHARACTER IN EMPTY SLOT
          STI    T3
          AOM    KBIP.,PT    INCREMENT INPUT POINTER
 RDC7     LJM    RDCX        RETURN
 RTR      SPACE  4,10
**        RTR - READ TEST MODE REGISTER.
*
*         EXIT   (A) = LEAST SIGNIFICANT BITS IN REGISTER.
*
*         USES   RN.
*
*         CALLS  RMR.


 RTR      SUBR               ENTRY/EXIT
          LDC    ITMR        READ THE TEST MODE REGISTER
          STD    RN
          LDM    ELIO
          RJM    RMR         READMR RDATA,ELIO,ITMR
          UJN    RTRX        RETURN WITH (A) = (RDATA+7)
 SCP      SPACE  4,10
**        SCP - GO TO CURSOR.
*
*         PLACES CURSOR ON SCREEN AT XPOS.,YPOS..
*
*         USES   BP.


 SCP      SUBR               ENTRY/EXIT
          LDM    SCMT+CMOV.
          ZJN    SCPX        IF CURSOR ALREADY POSITIONED
          LDN    0
          STM    SCMT+CMOV.  RESET FLAG FOR CURSOR MOVED
          LDN    0#02        SEND POSITION CURSOR FUNCTION
          STIAO  BP
          LDM    SCMT+XPOS.
          ADM    SCMT+SCRN.  ADD SCREEN OFFSET
          STIAO  BP          X-POSITION
          LDM    SCMT+YPOS.
          STIAO  BP          Y-POSITION
          UJN    SCPX        RETURN
 SNS      SPACE  4,10
**        SNS - SERVICE NOS STATE.
*
*         WHEN NOS IS NOT ACTIVELY BEING DISPLAYED BY THE *SCD* MODE THIS
*         ROUTINE WILL INPUT ONE WORD FROM CHANNEL 10. IF A REQUEST FOR
*         INPUT IS RECEIVED A NUL IS RETURNED. A REQUEST TO GET OFF THE
*         CHANNEL IS ACTED UPON.  ALL OTHER INPUT IS DISCARDED.


 SNS1     SHN    21-10-21+14
          PJN    SNSX        IF NOT INPUT FUNCTION
          LDN    0
 MC1      OAN    CH          RETURN A NUL
 MC2      FJM    *,CH

 SNS      SUBR               ENTRY/EXIT
          LDML   SCMT+DATA.
          STDL   T6
          LDN    0
          STM    SCMT+DATA.
          LDDL   T6
          NJN    SNS3        IF THERE IS PREVIOUS DATA TO DEAL WITH
 SNS2     FSJM   SNSX,CH     IF CHANNEL NOT AVAILABLE
 MC3      EQU    SNS2
 MC4      EJM    SNSX,CH     IF CHANNEL EMPTY
 MC5      IAN    CH
 SNS3     SHN    21-17
          PJN    SNS2        IF NOT A VALID FUNCTION
          SHN    21-14-21+17
          PJN    SNS1        IF CC545 FUNCTION
          SHN    0-4-21+14
          LPN    3
          SBN    1
          NJN    SNS4        IF NOT UPDATE MODE FUNCTION
          LDN    2
 MC6      IAM    T2,CH       READ IN ADDRESS OF SCDPT
          CALL   RMT         RESET MODE TABLE

 SNS4     SBN    2-1
          NJN    SNSX        IF NOT GET OFF CHANNEL FUNCTION
 MC7      SCF    SNSX,CH     GET OFF CHANNEL
          LJM    SNSX        RETURN
 SVS      SPACE  4,10
**        SVS - SERVICE NOS/VE STATE.
*
*         THIS ROUTINE WILL INFORM NOS/VE THAT THE CURRENT LIST OF LINES
*         HAS ALL BEEN DISPLAYED AND THE CURRENT COMMAND HAS BEEN
*         ACCEPTED.
*
*         CALLS  UDB.


 SVS      SUBR               ENTRY/EXIT
          LDN    0
          STM    SCMT+COMM.+2  SET END OF LIST
          STM    SCMT+COMM.+3
          STM    SCMT+COMM.+4  SET COMMAND ACCEPTED
          LDN    2
          RJM    UDB         NOTIFY NOS/VE
          UJN    SVSX        RETURN
 UDB      SPACE  4,10
**        UDB - UPDATE DATA BLOCK.
*
*         INFORMS HOST THROUGH SCD COMMUNICATIONS BLOCK OF *SCD/VE* STATUS.
*
*         ENTRY  (A) = NUMBER OF WORDS TO UPDATE ON SCDCB.
*                (PT) = *SCD* MODE TABLE ADDRESS.
*
*         USES   T6.
*
*         CALLS  SPB.


 UDB      SUBR               ENTRY/EXIT
          STD    T6
          LRD    CB          POINT TO COMMUNICATIONS BLOCK
          RJM    SPB         SET PP BOUNDARY
          LDML   SCMT+CBAO.
          ADC    RR          USE R-REGISTER
          CWML   SCMT+COMM.,T6  WRITE COMMUNICATION BUFFER TO SCDCB
          UJN    UDBX        RETURN
 COMMON   SPACE  4,10
**        COMMON DECKS.


          LIST   X
*COPY     DSI$GET_HARDWARE_ELEMENT
*COPY     DSI$FIND_CIP_MODULE
*COPY     DSI$MAINTENANCE_REGISTER_ACCESS
*COPY     DSI$PP_UTILITY_SUBROUTINES
*COPY     DSI$PP_SSR_INTERFACE
 PPTYPE   SET    0           LOCATION OF *PPTY* IS DEFINED LATER
*COPY     DSI$VALIDATE_PP_BOUNDS


 NIOU     EQU    *
*COPY     DSI$DUMP_LOAD_IDLE_PP
 NIOUL    EQU    *

          OVERFLOW  OVLM     CHECK FOR OVERFLOW

 OVLL     SET    OVLL+1
          IFEQ   OVLL,21,2
 OVLL     SET    1
 OVLU     SET    OVLU+1
 OVLN     SET    OVLU*20+OVLL-21
 CHL      MICRO  OVLL,1,*"ALPHABET"*
 CHU      MICRO  OVLU,1,*"ALPHABET"*
 NU       OCTMIC OVLN,2
          TITLE  "PRGNAM""CHU""CHL" ("NU") - S0/S0E PP SUBROUTINES.
          IDENT  "PRGNAM""CHU""CHL",NIOU  "NU" S0/S0E PP SUBROUTINES
          QUAL   "PRGNAM""CHU""CHL"

          ORG    NIOU
*COPY     DSI$S0_DUMP_LOAD_IDLE_PP

 S0DLI    ROUTINE            DUMMY ROUTINE TO IDENTIFY S0/S0E PP ROUTINE OVERLAY
          QUAL   *

          ERRNG  NIOUL-*     S0/S0E PP ROUTINES ARE LARGER THAN FOR OTHER IOU-S

          OVERFLOW  OVLM     CHECK FOR OVERFLOW

*COPY     CTI$SCI_MDD_RESIDENT_CODE
*COPY     CTI$MDD_COMMAND_LIST
*COPY     CTI$SCI_MDD_COMMANDS
*COPY     CTI$SCI_VPB_DEADSTART_NOSVE
*COPY     CTP$SCI_VPB_DEADSTART_CY2000
*COPY     CTI$SCI_DEADSTART_VE_AFTER_MDD
*COPY     CTI$SCI_VPB_TERMINATE_NOSVE
*COPY     CTI$SCI_F6_F7_KEY
*COPY     CTI$SCI_TPM_PRESET
*COPY     CTI$SCI_SCD_VE_ROUTINES
*COPY     CTI$SCI_SCD_NOS_ROUTINES
*COPY     CTP$SCI_PROCESS_ANALYSIS_CODE
          LIST   *
          SPACE  4,10
          END
/EOR
*DECK DECK=CTM$VDT_RECORD EXPAND=TRUE
          IDENT  VDT
          CIPPU  J
          BASE   MIXED
          TITLE  CTM$VDT RECORD
          COMMENT *SMD* LVL=01
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          EJECT
***
*         VDT - VE DISK AND TAPE IDENTIFICATION RECORD
*
*         VDT IS A DATA RECORD.  ITS MAIN PURPOSE IS TO PROVIDE
*         A 77 TABLE FOR THE VDT RECORD THAT IS STORED IN THE
*         COMMON DISK AREA.  THIS WILL ALLOW THE LEVEL NUMBER
*         TO BE CHANGED.
*
***
          END
/EOR
*DECK DECK=CTP$CONSTRUCT_MESSAGE_IN_EICB EXPAND=FALSE
          CTEXT  CTP$CONSTRUCT MESSAGE IN EICB
          SPACE  4,10
 QUAL$    IF     -DEF,QUAL$
          QUAL   CTPCME
 QUAL$    ENDIF
          BASE   M
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 CME      SPACE  4,10
**        CME - CONSTRUCT MESSAGE IN EICB.
*
*         THIS ROUTINE CONSTRUCTS A MESSAGE IN THE FORM -
*                HH:MM:SS ERR=PEMMZXXX
*         WHERE -
*                P = PRODUCT ID (D FOR DFT, S FOR SCI).
*                E = ELEMENT SPECIFIER (C=CPU0, D=CPU1, I=IOU0, J=IOU1).
*               MM = MODEL NUMBER OF ELEMENT THAT REPORTED ERROR.
*                Z = THE LETTER *Z*.
*              XXX = ANALYSIS CODE.
*
*         ENTRY  (IB - IB+2) = RFA OF EICB.
*                (PPTY) = 0, IF UPPER PP.
*                (CMEA) = PRODUCT ID IN ASCII.
*                (CMEB) = ELEMENT SPECIFIER IN ASCII.
*                (CMEC) = MODEL NUMBER IN ASCII.
*                (CMED) = ANALYSIS CODE.
*
*         EXIT   (A) = 0, IF EICB CAN BE WRITTEN.
*                      1, IF EICB CANNOT BE WRITTEN.
*                      2, IF MESSAGE IS ALREADY PRESENT.
*                (T2) = MESSAGE LENGTH.
*                (CMEE) = FORMATTED MESSAGE AS WRITTEN TO THE EICB.
*
*         USES   T1, T2, T4, T5, T6, T7.
*
*         CALLS  CDA, CSD, GEL, IIB, SPB.


 CME40    LDN    1           EICB CANNOT BE WRITTEN

 CME      SUBR               ENTRY/EXIT
          RJM    GEL         GET EICB LEVEL
          SBN    4
          MJN    CME40       IF NO MESSAGE BUFFER IN EICB (REV < 4)

*         IF C170 OS IS PRESENT, THEN VERIFY THAT THE PP IS ON THE
*         CORRECT SIDE OF THE OS BOUNDS TO WRITE THE MESSAGE TO THE
*         EICB.  IF NOT ON THE CORRECT SIDE OF OS BOUNDS, THEN A
*         CHECK IS MADE TO SEE IF THE REPORTED PROBLEM IS A CH17
*         PROBLEM.  IF THIS IS THE CASE, THEN THE EICB CANNOT BE
*         WRITTEN SINCE SPB WOULD HAVE TO USE CH17.

          LDD    T6          GET THE OS TYPE
          LPN    3
          SHN    21-1
          LMDL   T7
          SHN    5-21
          ZJN    CME20       IF C170 OS NOT PRESENT
          LDM    PPTY
          NJN    CME20       IF A LOWER PP
          STD    T1
          LDK    TCHPL
          STD    T2
 CME10    LDML   TCHP,T1     CHECK FOR CH17 PROBLEM
          LMML   CMED
          ZJN    CME40       IF CH17 PROBLEM
          AOD    T1
          SBD    T2
          MJN    CME10       IF NOT END OF LIST

          LRD    IB+1        GET INTERFACE BLOCK R-POINTER
          RJM    SPB         SET PP BOUNDS

*         CHECK TO SEE IF EICB CURRENTLY HAS A MESSAGE IN IT.

 CME20    LDN    DFCM+2      GET ADDRESS TO READ FROM
          RJM    IIB
          CRML   CMEE,ON
          LDML   CMEE
          ZJN    CME30       IF NO ERROR PRESENT (BEFORE BUFFER BLANKED)
          LMC    2R
          ZJN    CME30       IF NO ERROR PRESENT
          LDN    2
          UJP    CMEX        RETURN

 CME30    LDK    CMEE
          RJM    GAT         GET ASCII TIME
          LDK    1R=         INSERT PRODUCT IDENTIFIER
          SHN    10
          LMML   CMEA
          STML   CMEE+6
          LDML   CMEB        ELEMENT SPECIFIER
          SHN    10
          STDL   T1
          LDML   CMEC        MODEL NUMBER
          SHN    -10         EXTRACT UPPER DIGIT
          LMDL   T1
          STML   CMEE+7
          LDML   CMEC        EXTRACT LOWER DIGIT OF MODEL NUMBER
          LPC    0#FF
          SHN    10
          LMC    1RZ
          STML   CMEE+10
          LDML   CMED        CONVERT UPPER TWO DIGITS OF ANALYSIS CODE
          SHN    -4
          RJM    CDA         CONVERT DIGITS TO ASCII
          STML   CMEE+11
          LDML   CMED        CONVERT LEAST SIGNIFICANT DIGIT OF ANALYSIS CODE
          LPN    17
          RJM    CSD         CONVERT SINGLE DIGIT TO ASCII
          SHN    10
          LMC    1R
          STML   CMEE+12

*         WRITE MESSAGE AND UPDATE HEADER.

          LDN    3           MESSAGE LENGTH IS 24 CHARACTERS
          STD    T2
          LDD    IB
          ADC    RR+DFCM+1   WRITE MESSAGE
          CWML   CMEE,T2
          LDD    IB
          ADC    RR+DFCM     READ OLD MESSAGE ID
          CRDL   T4
          AOD    T7          INCREMENT COUNTER
          LDN    24D
          STD    T5          SET TO 24 CHARACTERS
          LDD    IB
          ADC    RR+DFCM     WRITE OUT MESSAGE ID
          CWDL   T4
          LDN    0           EICB CAN/HAS BEEN WRITTEN
          LJM    CMEX        RETURN

 CMEA     CON    0           ASCII CODE FOR PRODUCT IDENTIFIER
 CMEB     CON    0           ASCII CODE FOR ELEMENT SPECIFIER
 CMEC     CON    0           ASCII CODE FOR MODEL NUMBER
 CMED     CON    0           ANALYSIS CODE
 CMEE     DATA   C*HH.MM.SS ERR=DEMMZ600   *
 TCHP     SPACE  4,10
**        TCHP - TABLE OF CH17 PROBLEM ANALYSIS CODES.


 TCHP     BSS    0
          CON    DAMP        CH17 PARITY ERROR
          CON    DAMI        CH17 INTERLOCK ERROR
          CON    DAMA        CH17 ACTIVE
          CON    DACI        CH17 INACTIVE
 TCHPL    EQU    *-TCHP      LENGTH OF TABLE
 GAT      SPACE  4,10
**        GAT - GET ASCII TIME STAMP.
*
*         ENTRY  (A) = FWA OF 4 BYTE RESULT BUFFER.
*                (R) = R-REGISTER FOR EICB.
*
*         USES   T3, T4.
*
*         CALLS  CDA, CSD.


 GAT10    LDC    2R
          STIL   T3
          AOD    T3
          SBD    T4
          NJN    GAT10       IF BUFFER HAS NOT BEEN BLANK FILLED

 GAT      SUBR               ENTRY/EXIT
          STD    T3          SAVE RESULT BUFFER FWA
          ADN    4           BUFFER LENGTH
          STD    T4
          LDD    IB
          ADC    RR+D8WT     READ WALL CLOCK CHIP VALUE IN EICB
          CRML   GATA,ON
          LDML   GATA+1
          ZJN    GAT10       IF I2 IOU MODEL
          LMC    0#FFFF
          ZJN    GAT10       IF CLOCK ACCESS ERROR

*         CONVERT RESULT OF READING WALL CLOCK CHIP TO
*         HH:MM:SS IN ASCII.

          LDML   GATA+2      HOURS
          SHN    -10
          RJM    CDA         CONSTANT TO DECIMAL ASCII
          STIL   T3
          AOD    T3
          LDML   GATA+2      MINUTES
          SHN    -4          MOST SIGNIFICANT DIGIT
          RJM    CSD         CONVERT SINGLE DIGIT
          SHN    12
          LMC    0#3A        COLON
          SHN    10
          STIL   T3          *:M*
          AOD    T3
          LDML   GATA+2
          RJM    CSD         CONVERT SINGLE DIGIT
          SHN    10
          LMC    0#3A        COLON
          STIL   T3          *M:*
          AOD    T3
          LDML   GATA+3      SECONDS
          SHN    -10
          RJM    CDA         CONSTANT TO DECIMAL ASCII
          STIL   T3
          UJP    GATX        RETURN

 GATA     BSS    4           SCRATCH BUFFER
 GEL      SPACE  4,10
**        GEL - GET EICB LEVEL.
*
*         EXIT   (A) = EICB LEVEL.
*                (T4 - T7) = (EICB WORD D7TY).
*
*         USES   T4, T5, T6, T7.


 GEL      SUBR               ENTRY/EXIT
          LDN    D7TY        TEST *EICB* LEVEL
          RJM    IIB
          CRDL   T4          READ *D7TY*
          LDD    T7          12 BIT LOAD
          SHN    -6          EXTRACT EICB REVISION LEVEL
          UJN    GELX        RETURN

*COPY     CTP$CONVERT_DIGITS_TO_ASCII

          BASE   *
 QUAL$    IF     -DEF,QUAL$
          QUAL   *
 CME      EQU    /CTPCME/CME
 CMEA     EQU    /CTPCME/CMEA
 CMEB     EQU    /CTPCME/CMEB
 CMEC     EQU    /CTPCME/CMEC
 CMED     EQU    /CTPCME/CMED
 CMEE     EQU    /CTPCME/CMEE
 CDA      EQU    /CTPCME/CDA
 CSD      EQU    /CTPCME/CSD
 GEL      EQU    /CTPCME/GEL
 QUAL$    ENDIF

*         END    CTP$CONSTRUCT_MESSAGE_IN_EICB.

          ENDX
*DECK DECK=CTP$CONVERT_DIGITS_TO_ASCII EXPAND=FALSE
          CTEXT  CTP$CONVERT DIGITS TO ASCII
          SPACE  4,10
          BASE   M
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 CDA      SPACE  4,10
**        CDA - CONVERT TWO DIGITS TO ASCII.
*
*         ENTRY (A) = NUMBER TO CONVERT.
*
*         EXIT   (A) = ASCII REPRESENTATION OF NUMBER.
*
*         USES   T1.
*
*         CALLS  CSD.


 CDA      SUBR               ENTRY/EXIT
          STD    T0          SAVE CONSTANT
          SHN    -4
          RJM    CSD         CONVERT SINGLE DIGIT
          SHN    10
          STDL   T1
          LDD    T0
          RJM    CSD         CONVERT SINGLE DIGIT
          LMDL   T1
          UJN    CDAX        RETURN
 CSD      SPACE  4,10
**        CSD - CONVERT SINGLE DIGIT.
*
*         ENTRY  (A) = NUMBER BETWEEN 0 AND 15.
*
*         EXIT   (A) = 10/0,8/ASCII REPRESENTATION OF NUMBER.


 CSD      SUBR               ENTRY/EXIT
          LPN    17
          SBN    10D
          MJN    CSD10       IF 0 - 9
          ADN    1RA-1R0-10D
 CSD10    ADN    1R0+10D
          UJN    CSDX        RETURN


          BASE   *

          ENDX
*DECK DECK=CTP$DFT_930_DUMP_PP_REGS EXPAND=FALSE
 DPR      SPACE  4,10
**        DPR - DUMP S0/S0E PP REGISTERS.  THE PP REGISTERS DUMPED ARE P, A, D
*               AND K.
*
*         ENTRY  (A) = PP TYPE AND NUMBER.
*                (W4 - W7) = POINTER TO AREA FOR PP REGISTERS TO BE WRITTEN
*                IN MEMORY, R-POINTER FORMAT.
*
*         EXIT   PP REGISTERS WRITTEN TO SPECIFIED MEMORY.
*                (W4) = OFFSET IN R-POINTER UPDATED TO REFLECT WORDS WRITTEN.
*
*         CALLS  LRP, SPB.
*
*         USES   EC, RN, T1.


 DPR      SUBR               ENTRY/EXIT
          LDM    PPTN        GET PP NUMBER AND TYPE
          LPN    37          ISOLATE PP NUMBER
          ADC    S0IST       SET STATUS-1 REGISTER NUMBER
          STD    RN
          LDML   I0CC        SET CONNECT CODE
          STDL   EC

*         DUMP THE P, Q, K, A REGISTERS.  EACH REGISTER VALUE IS
*         SAVED IN 2 PP WORDS.

          READMR DPRC1       READ PP STATUS-1 REGISTER
          LDN    0#20        SET PP STATUS-2 REGISTER
          RAD    RN
          READMR DPRC2       READ PP STATUS-2 REGISTER
          LDML   DPRC2
          SHN    10
          ADML   DPRC2+1
          STML   DPRRS0+1    P-REGISTER
          LDML   DPRC1+1
          LPN    37
          STML   DPRRS0+3    D (OR Q)-REGISTER
          LDML   DPRC1+2
          LPC    0#7F
          STML   DPRRS0+5    K-REGISTER
          LDML   DPRC1+3
          SHN    -6
          STML   DPRRS0+6
          LDML   DPRC2+2
          SHN    10
          ADML   DPRC2+3
          STML   DPRRS0+7    A-REGISTER

*         LOAD R-REGISTER WITH POINTER TO MEMORY WHERE REGISTERS ARE TO BE SAVED.

          LRD    W5
          LDN    2           SET WORD COUNT (NO S-REGISTER)
          STD    T1
          LDDL   W4          OFFSET
          LMC    RR
          CWML   DPRRS0,T1   WRITE REGISTER BUFFER TO OUTPUT SEQUENCE
          LDN    2           UPDATE OFFSET IN R-POINTER
          RADL   W4
          LJM    DPRX        RETURN

 DPRC1    BSSZ   10          STATUS-1 BUFFER
 DPRC2    BSSZ   10          STATUS-2 BUFFER
 DPRRS0   BSSZ   14          OUTPUT REGISTER BUFFER

*DECK DECK=CTP$DFT_990_960_DEGRADE_CPU EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT_990_960_DEGRADE_CPU
*
*         THIS DECK CONTAINS ROUTINES TO DETERMINE IF THE CPU IS DEGRADABLE.
*         IF IT IS, THE *DFT* ACTION CODE IS SET TO DISABLE THE MEMORY PORT
*         AND THE CURRENT TASK IS TERMINATED.
 DID      SPACE  4,10
**        DID - DETERMINE IF CPU DEGRADABLE.
*
*         EXIT   (TERT) = 1 IF THE CPU IS DEGRADABLE.
*                ALSO, THE *DFT* ACTION CODE IS SET TO DISABLE THE MEMORY PORT.
*
*         CALLS  CDC, LOG.


          ROUTINE  DID       ENTRY/EXIT
          RJM    CDC         CHECK IF DEGRADABLE CPU
          ZJP    DIDX        IF NOT DEGRADABLE
          CALL   LOG         LOG ERROR
          LDN    1           SET TERMINATE CURRENT TASK FLAG
          STM    TERT
          LJM    DIDX        RETURN

*COPY CTP$DFT_CHECK_DEGRADABLE_CPU

*         END CTP$DFT_990_960_DEGRADE_CPU
*DECK DECK=CTP$DFT_990_SCAN_PFS_BITS EXPAND=FALSE
**        SPP - SCAN PFS PARITY
*
*         METHOD             LOAD THE APPROPRIATE PFS BYTES OUT OF
*                            MAINTENANCE REGISTER BUFFER 0 AND MASK.
*                            IF PFS BIT IS SET, SET THE RESPECTIVE BIT
*                            IN CTIB TO INDICATE A PARITY ERROR IN A
*                            CONTROL MEMORY.
*
*         CALLED             BY RJM TO SPP
*
*         ENTRY              PFS REGISTERS ARE LOGGED IN MAINTENANCE
*                            REGISTER BUFFER 0
*
*         EXIT               (CTIB) :  A SET BIT INDICATES PARITY ERROR
*                                    IN RESPECTIVE CONTROL MEMORY.


 SPP      SUBR               ENTRY/EXIT
          LDN    0
          STML   CTIB        INITIALIZE
          STDL   T5          INDEXES TABLES
          LDN    1
          STDL   T6          SLIDING BIT - USED TO MASK CTIB
 SPP0     LDML   SPPA,T5     LOAD RGTR EQUATE TO MRB
          RJM    FMB         SET UP R-RGTR
          CRDL   CM          READ PFS WORD INTO CM
          LDML   SPPC,T5     LOAD CORRECT BYTE
          STDL   T1
          LDML   0,T1        LOAD BYTE OFFSET
          LPML   SPPB,T5     MASK
          ZJN    SPP1        IF NO PE
          LDDL   T6          SET APPROPRIATE BIT TO RELOAD MEMORY
          LMC    0#FFFF
          LPML   CTIB
          LMDL   T6
          STML   CTIB        SAVE BIT IN CTIB
 SPP1     AODL   T5
          SBN    8D
          ZJP    SPP2        IF CW2
          SBN    3
          ZJP    SPP2        IF BP32
          SBN    1
          ZJP    SPPX        IF DONE
          LDDL   T6
          SHN    1
          STDL   T6          SHIFT MASK BIT
 SPP2     LJM    SPP0        CHECK NEXT MEMORY


*         REGISTER EQUATE LIST

 SPPA     BSS    0
          CON    0#86
          CON    0#86
          CON    0#84
          CON    0#83
          CON    0#8E
          CON    0#8E
          CON    0#8A
          CON    0#81
          CON    0#81
          CON    0#81
          CON    0#86
          CON    0#86

*         PFS BIT MASK LIST.

 SPPB     BSS    0
          CON    0#0004
          CON    0#0002
          CON    0#0100
          CON    0#00C0
          CON    0#800E
          CON    0#FF00
          CON    0#00C6
          CON    0#FFFF
          CON    0#FF00
          CON    0#FFFF
          CON    0#0023
          CON    0#02C0

*         EQUATES HOLDING PP WORD OFFSETS
*         (IN RELATION TO CM)

 SPPC     BSS    0
          CON    OACUM2
          CON    OACUM3
          CON    OACUM4
          CON    OBDP
          CON    OEPN
          CON    OIMAP
          CON    OLSU
          CON    OCW1
          CON    OCW2
          CON    OCST
          CON    OBP31
          CON    OBP32

*DECK DECK=CTP$DFT_ACTION_LIST EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT ACTION LIST.
*
*         THIS DECK DEFINES THE GLOBAL ACTIONS IN DFT TO DEADSTART CPUS, PERFORM
*         OS REQUESTS, EXTERNALIZE CTI FUNCTIONS, ETC.
*
*         A CORRESPONDING DECK, CTP$DFT_ACTION_LIST_OVERFLOW, ALSO EXISTS.  NEW
*         GLOBAL DFT ACTIONS SHOULD BE ADDED TO THAT DECK BECAUSE OF OVERFLOW
*         PROBLEMS IN THE DFT ACTION OVERLAYS IN SOME CLASSES OF *DFT*.  IN THOSE
*         CLASSES OF *DFT* WHERE THERE IS A SPACE PROBLEM, THE OVERFLOW ACTION
*         LIST IS LOCATED IN AN OVERFLOW ACTION OVERLAY.  IF BIT 2**16 OF *DFTA*
*         IS SET, THEN THE OVERFLOW OVERLAY IS LOADED TO PROCESS THE ACTION.
*         THE SETTING OF THE 2**16 BIT IS GOVERNED BY THE CELL *OFLO*.  *OFLO* IS
*         SET TO A ZERO IN THOSE *DFT* CLASSES WHERE NO OVERFLOW OVERLAY IS
*         NEEDED.  IT IS SET TO A ONE IN THOSE *DFT* CLASSES WHERE THE OVERFLOW
*         OVERLAY IS REQUIRED.
 DDA      SPACE  4,10
**        DDA - DO DFT ACTIONS.
*
*         ENTRY  *DFTA* HOLDS ADDRESS OF DFT TASK TO EXECUTE.
*
*         EXIT   TASK LIST SPECIFIED BY *DFTA* HAS BEEN EXECUTED.
*
*         CALLS  EXT.


          ROUTINE DDA

          LDML   DFTA        CHECK IF ACTION RESIDES IN OVERFLOW OVERLAY
          SHN    21-16
          MJN    DDA2        IF IN OVERFLOW OVERLAY
          RJM    EXT         EXECUTE DFT TASK LIST
 DDA1     LJM    DDAX        RETURN

 DDA2     CALL   DOA         CALL OVERFLOW OVERLAY OF DFT ACTIONS
          UJN    DDA1        RETURN
 TAGS     SPACE  4,10
**        FOLLOWING ARE TAGS DESCRIBING DFT TASK LISTS.
*         THE LIST TO BE EXECUTED IS DETERMINED FROM CELL *DFTA*
*         WHICH HOLDS THE LIST ADDRESS. THE ROUTINE *EXT* IS CALLED TO
*         EXECUTE THE TASKS IN ORDER OF OCCURRENCE. TASKS CAN BE
*         OVERLAYS OR ROUTINES WITHIN ONE OVERLAY.  THE TASKS ARE
*         SUBROUTINES DEFINED WITH THE *ROUTINE* MACRO, THE TASKS
*         MAY BE IN OVERLAYS.


          QUAL
 FCDP     BSS    0           LOAD CIP DATA TO MEMORY
          TASK   (FCD)

 LDPG     BSS    0           LOAD DRIVER PP
          TASK   (LDC)

 FCHI     BSS    0           FETCH HARDWARE INFO
          TASK   (FHD)

 PUFC     BSS    0           UPDATE FREE RUNNING COUNTER
          TASK   (UFC)

 PUDT     BSS    0           UPDATE DATE AND TIME FOR OPERATING SYSTEM
          TASK   (UDT)

 PTHR     BSS    0           UPDATE THRESHOLDS FOR OPERATING SYSTEM
          TASK   (THR)

 PUFP     BSS    0           PP UTILITIES: IDLE/DUMP PP, DUMP PP REGISTERS
          TASK   (PUF)

 PURP     BSS    0           PP UTILITIES (CALL FORMAT REVISED FOR LVL 92)
          TASK   (PUR)

 REPP     BSS    0           RESUME PP
          TASK   (REP)

 GCSP     BSS    0           GET NIO CHANNEL STATUS
          TASK   (GCS)

 DVPG     BSS    0           START NEW PROCESSOR (CPU-0 DUAL, CPU-1 NOS)
          TASK   (FPI,HPR,PRI,LCB,SMR,IXP,SB8,HEI)

 DVRG     BSS    0           START NEW PROCESSOR (CALL FORMAT REVISED FOR LVL 92)
          TASK   (FPR,HPR,PRI,LCR,SMP,IXP,HEI)

 CPRG     BSS    0           CHANGE PROCESSOR REGISTERS
          TASK   (FPI,HPR,HEO,IDL,SMR,IXP,HEI)

 CPOG     BSS    0           CHANGE PROCESSOR REG. (FORMAT REVISED FOR LVL 92)
          TASK   (FPR,HPR,HEO,IDL,SMP,IXP,HEI)

 ADSP     BSS    0           READ DEADSTART SECTOR
          TASK   (ADS)

 ADRP     BSS    0           READ DEADSTART SECTOR (FORMAT REVISED FOR LVL 92)
          TASK   (ADR)

 RWCP     BSS    0           ACCESS COMMON DISK AREA
          TASK   (RWC)

 ACAP     BSS    0           ACCESS COMMON DISK AREA (FORMAT REVISED FOR LVL 92)
          TASK   (ACA)

 LDSP     BSS    0           LOAD DFT IN SECONDARY IOU
          TASK   (LDS)

 AHEP     BSS    0           ACCESS HARDWARE ELEMENT DESCRIPTORS
          TASK   (AHE)

 GMRP     BSS    0           RETRIEVE MAINTENANCE REGISTERS
          TASK   (GMR)

 RPLP     BSS    0           REQUEST PROGRAM LENGTH
          TASK   (RPL)

 DDCL     BSS    0           CLEAR ERROR - START CPU
          TASK   (CLE)

 DDDC     BSS    0           DISABLE CPU
          TASK   (DIP,WM7,IFM)

 DIMP     BSS    0           DISABLE CPU MEMORY PORT
          TASK   (DIP)
*         END    CTP$DFT ACTION LIST
*DECK DECK=CTP$DFT_ACTION_LIST_DUAL_I4 EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT_ACTION_LIST_DUAL_I4
*
*         THIS DECK EXTERNALIZES FUNCTIONS USED ONLY ON
*         DUAL I4 SYSTEMS


 IAPP     BSS    0           IDLE ALL PP-S IN IOU
          TASK   (IAP)

*         END OF CTP$DFT_ACTION_LIST_DUAL_I4
*DECK DECK=CTP$DFT_ACTION_LIST_DUAL_STATE EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT_ACTION_LIST_DUAL_STATE
*
*         THIS DECK DEFINES ACTIONS USED IN DUAL STATE PROCESSING


 HVPG     BSS    0           HALT ALL VIRTUAL PROCESSORS
          TASK   (PCP,UCM)
 H1PG     BSS    0           HALT 170 PROCESSOR
          TASK   (FPI,HPR,IDL,SCR,DMP)


 S1PG     BSS    0           START 170 PROCESSOR
          TASK   (FPI,HPR,PRI,LCB,HEI)

*         END OF DECK CTP$DFT_ACTION_LIST_DUAL_STATE
*DECK DECK=CTP$DFT_ACTION_LIST_OVERFLOW EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT ACTION LIST OVERFLOW.
*
*         THIS DECK DEFINES THE ADDITIONAL GLOBAL ACTIONS IN DFT TO DEADSTART
*         CPUS, PERFORM OS REQUESTS, EXTERNALIZE CTI FUNCTIONS, ETC.  NEW
*         GLOBAL DFT ACTIONS SHOULD BE ADDED TO THIS DECK BECAUSE OF OVERFLOW
*         PROBLEMS IN THE DFT ACTION OVERLAYS IN SOME CLASSES OF *DFT*.  IN THOSE
*         CLASSES OF *DFT* WHERE THERE IS A SPACE PROBLEM, THE OVERFLOW ACTION
*         LIST IS LOCATED IN AN OVERFLOW ACTION OVERLAY.  IF BIT 2**16 OF *DFTA*
*         IS SET, THEN THE OVERFLOW OVERLAY IS LOADED TO PROCESS THE ACTION.
*         THE SETTING OF THE 2**16 BIT IS GOVERNED BY THE CELL *OFLO*.  *OFLO* IS
*         SET TO A ZERO IN THOSE *DFT* CLASSES WHERE NO OVERFLOW OVERLAY IS
*         NEEDED.  IT IS SET TO A ONE IN THOSE *DFT* CLASSES WHERE THE OVERFLOW
*         OVERLAY IS REQUIRED.
 DOA      SPACE  4,10
**        DOA - DO OVERFLOW DFT ACTIONS.
*
*         ENTRY  *DFTA* HOLDS ADDRESS OF DFT TASK TO EXECUTE + 0#4000.
*
*         EXIT   TASK LIST SPECIFIED BY *DFTA* HAS BEEN EXECUTED.
*
*         CALLS  EXT.


          ROUTINE DOA

          LDM    DFTA        CLEAR OVERFLOW BIT
          STM    DFTA
          RJM    EXT         EXECUTE DFT TASK LIST
          LJM    DOAX        RETURN
 TAGS     SPACE  4,10
**        FOLLOWING ARE TAGS DESCRIBING DFT TASK LISTS.
*         THE LIST TO BE EXECUTED IS DETERMINED FROM CELL *DFTA*
*         WHICH HOLDS THE LIST ADDRESS. THE ROUTINE *EXT* IS CALLED TO
*         EXECUTE THE TASKS IN ORDER OF OCCURRENCE. TASKS CAN BE
*         OVERLAYS OR ROUTINES WITHIN ONE OVERLAY.  THE TASKS ARE
*         SUBROUTINES DEFINED WITH THE *ROUTINE* MACRO, THE TASKS
*         MAY BE IN OVERLAYS.


 RDLP     BSS    0           REQUEST DATA LENGTH
          TASK   (RDL)

 MVPP     BSS    0           MANAGE VIRTUAL PROCESSOR
          TASK   (MVP)

 SVPG     BSS    0           STOP PROCESSOR
          TASK   (FPI,HPR,HEO,IDL,SCR,DMP)

 PIRP     BSS    0           PROCESS INVALID REQUEST
          TASK   (RRE)

 RISC     BSS    0           RETURN IOU STATUS REGISTER
          TASK   (RIS)

 RSCI     BSS    0           RESTART SCI PP
          TASK   (RSP)

*         END    CTP$DFT ACTION LIST OVERFLOW

*DECK DECK=CTP$DFT_ANALYZE_IOU_ERRORS EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT_ANALYZE_IOU_ERRORS
*
*         ANALYSIS ROUTINES FOR I1,I2 IOUS.
*
*         NOTE:  THIS DECK USES A VARIANT OF THE ROUTINE
*         MACRO. THIS VARIANT REMOVES THE GLOBAL NATURE OF THE
*         ENTRY POINT NAMES (NAME_O, NAME_E) TO ALLOW FOR THE
*         POSSIBILITY OF EITHER I2 OR I4 BEING ON THE SYSTEM.
*
*         THE USAGE OF THIS DECK IS AS FOLLOWS
*
*         QUAL
**COPY CTP$DFT_ANALYZE_IOU_ERRORS
*         QUAL   *

 AIE      SPACE  4,10
**        AIE - ANALYSE IOU ERRORS.
*
*         ENTRY  REGISTERS LOGGED IN SCRATCH BUFFER.
*                (SUMS) = SUMMARY STATUS.
*
*         CALLS  CEE, CLR, GBV, FMB, *CFF*, *LOG*.


          ROUTINE AIE,NG

          LDN    0
          STM    NERR        SET NO ERROR FLAG FALSE
          LDN    BC
          RJM    CLR         ZERO SCRATCH BCW
          CALL   CFF         CHECK FOR FREEZE
          LDM    RTP2
          ZJN    AIE0        IF NOT TO IGNORE ERROR
          LDN    0
          STM    DFTA        NO ACTION
          STM    REGI        RESET REGISTER LIST INDEX
          UJP    AIEX

 AIE0     LDM    SUMS
          SHN    21-SSPH
          PJP    AIE3        IF NOT PROCESSOR HALT

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED IOU ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).
*         DFT ANALYSIS - OS ACTION = FATAL IOU ERROR.
*                                  = SYSTEM STEP (VERSION 4).

          SETDAC DDCL
          SETDAN (EPUN,DAUIE)
          SETFLG (BC.FL)
          SETOSA OSFIE,OSSS
          LDN    0           SET TO NIO PP
          STM    GBVA
          RJM    GBV         GET BOUNDS VIOLATION
          LJM    AIE9        CONTINUE

 AIE3     LDK    IFS1
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRDL   W0
          LDDL   W2          BITS 32 - 39
          SHN    -10
          LPC    0#FB
          ZJP    AIE5        IF BITS 32 - 39 NOT SET

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = FATAL IOU ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).
*         DFT ANALYSIS - OS ACTION = FATAL IOU ERROR.
*                                  = SYSTEM STEP (VERSION 4).

 AIE4     SETDAC DDCL
          SETDAN (EPUN,DAFI)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          SETOSA OSFIE,OSSS
          LJM    AIE9        CONTINUE

 AIE5     LDDL   W2
          LPC    0#FF
          ADDL   W3
          NJP    AIE4        IF ANY BITS SET
          LDDL   W2
          SHN    21-2-10     12/16 CONVERSION ERROR
          PJP    AIE7        IF NOT 12/16 ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = 12/16 CONVERSION ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAC DDCL
          SETDAN (EPCO,DA1216)
          SETFLG (BC.FL)
          UJP    AIE9        CONTINUE

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CHANNEL ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

 AIE7     SETDAC DDCL
          SETDAN (EPCO,DACHE)
          SETFLG (BC.FL)
 AIE9     CALL   LOG
          LJM    AIEX        RETURN

 GBV      SPACE  4,10
**        GBV - GET BOUNDS VIOLATION.
*
*         ENTRY  *GBVA* IS FLAG DENOTING 1=CIO REGISTER, 0=NIO REGISTER.
*
*         EXIT   (A) = 0 PERTINENT *FS1* RESISTER NOT IN ERROR.
*
*         USES   W0 - W7.
*
*         CALLS  FMB, VCK.


 GBV      SUBR               ENTRY/EXIT
          LDM    GBVA
          NJN    GBV0        IF CIO PP
          LDC    IFS1        ADD IN *FS1* REGISTER OFFSET
          UJN    GBV1        CONTINUE

 GBV0     LDC    CIFS1       CIO *FS1* REGISTER
 GBV1     RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRDL   W0          GET *FS1* REGISTER
          LDDL   W0
          ADDL   W1
          ADDL   W2
          ADDL   W3
          ZJN    GBVX        IF NOTHING IN *FS1*
          LDM    GBVA
          NJN    GBV2        IF CIO PP
          LDN    IOSB        NIO OS BOUNDS
          UJN    GBV3        CONTINUE

 GBV2     LDN    CIOSB       CIO OS BOUNDS
 GBV3     RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRDL   W4
          LDDL   W0
          LPDL   W4          USE *OSB* AS A MASK AGAINST *FS1* REGISTER
          ZJN    GBV5        SO FAR 180 PP
 GBV4     SETFLG (BC.FV7)    SET VALID 170 FLAG
          LDN    VER2
          RJM    VCK         CHECK DFT BLOCK VERSION
          MJN    GVB4.1      IF DFT 1 SELECTED

*         DFT ANALYSIS - OS ACTION = C170 STATE STEP.

          SETOSA OSNSI,OS17S C170 STATE STEP
          LDN    1
 GVB4.1   LJM    GBVX        RETURN

 GBV5     LDM    GBVA        GET CIO OR NIO
          NJN    GBV6        IF CIO ONLY HAVE 2 BARRELS
          LDDL   W1
          LPDL   W5          USE OS BOUNDS AS MASK
          NJP    GBV4        IF 170 PP ERROR
 GBV6     SETFLG (BC.FV8)    SET VALID 180 FLAG

*         DFT ANALYSIS - OS ACTION = C180 STATE STEP.

          SETOSA OSVEI,OS18S C180 STATE STEP

          LDN    D8TY
          RJM    IIB
          CRDL   CM
          LDDL   CM+3
          LPC    0#3F
          SBN    2
          MJN    GBV30       IF OS DOESNT SUPPORT HUNG PP PROCESSING
          SETOSA OSVEI,OSHGP HUNG PP OS ACTION
 GBV30    LDN    1
          LJM    GBVX        RETURN

 GBVA     CON    0           FLAG TELLING NIO OR CIO TYPE OF PP

*         END CTP$DFT_ANALYZE_IOU_ERRORS
*DECK DECK=CTP$DFT_ANALYZE_IOU_ERRORS_I4 EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT_ANALYZE_IOU_ERRORS_I4
*
*         ANALYSIS ROUTINES FOR I4 IOUS
*
*         NOTE:  THIS DECK USES A VARIANT OF THE ROUTINE
*         MACRO. THIS VARIANT REMOVES THE GLOBAL NATURE OF THE
*         ENTRY POINT NAMES (NAME_O, NAME_E) TO ALLOW FOR THE
*         POSSIBILITY OF EITHER I2 OR I4 BEING ON THE SYSTEM.
*
*         THE USAGE OF THIS DECK IS AS FOLLOWS
*
*         QUAL
**COPY CTP$DFT_ANALYZE_IOU_ERRORS_I4
*         QUAL   *



 AIE      SPACE  4,10
**        AIE - ANALYSE IOU ERRORS.
*
*         ENTRY  REGISTERS LOGGING IN SCRATCH BUFFER.
*                (IOUO) = IOU ORDINAL.
*                (SUMS) = SUMMARY STATUS.
*
*         CALLS  CEE, CLR, GBV, FMB, *CFF*, *LOG*.


          ROUTINE AIE,NG

          RJM    CEE         CHECK FOR EXPECTED IOU ERROR
          NJP    AIEX        IF NO PROCESSING NEEDED
          LDN    0
          STM    NERR        SET NO ERROR FLAG FALSE
          LDN    BC
          RJM    CLR         ZERO SCRATCH BCW
          LDML   IOUO        GET IOU ORDINAL
          RJM    SSE         SET SECONDARY ELEMENT IDENTIFIER
          CALL   CFF         CHECK FOR FREEZE
          LDM    RTP2
          ZJN    AIE1        IF NOT TO IGNORE ERROR
          LDN    0
          STM    REGI        RESET REGISTER LIST INDEX
          STM    DFTA
          UJP    AIEX

 AIE1     SETDAC DDCL        ACTION TO CLEAR ERRORS
          LDC    IFS2
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRDL   W0
          LDDL   W3
          SHN    21-7        GET MAC ERROR BIT
          PJP    AIE2       IF OK NOT SET
          LDN    BC
          RJM    CLR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = FATAL IOU ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).
*         DFT ANALYSIS - OS ACTION = FATAL IOU ERROR.
*                                  = SYSTEM STEP (VERSION 4).

          SETDAC DDCL
          SETDAN (EPUN,DAFI)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          RJM    SOI         SET OS ACTION BASED ON IOU ORDINAL
          LJM    AIE10       CONTINUE

 AIE2     LDM    IOUM
          LMC    0#43
          ZJN    AIE2.1      IF MODEL 43
          LMN    0#44&0#43
          NJP    AIE2.5      IF NOT MODEL 43, 44 IOU
 AIE2.1   LDM    /HB57/BI57
          ZJP    AIE2.5      IF NOT BIT 57
          LDN    0           CLEAR BIT 57 FLAG
          STM    /HB57/BI57
          LDN    BC
          RJM    CLR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = FATAL IOU ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS =  VALID 180, LOG (OS).
*         DFT ANALYSIS - OS ACTION = FATAL BIT 57 IOU ERROR.
*                                  = SYSTEM STEP (VERSION 4).

          SETDAC DDCL
          SETDAN (EPUN,DAIB)
          SETFLG (BC.FV8,BC.FL)
          SETOSA OSSS,OSIMB
          LDML   IOUO        GET IOU ORDINAL
          ZJN    AIE2.25     IF IOU0 ERROR
          SETOSA OS18S,OSIMB
 AIE2.25  LJM    AIE10       CONTINUE

 AIE2.5   LDM    SUMS
          SHN    21-SSPH
          PJP    AIE3       IF NOT PROCESSOR HALT

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED IOU ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).
*         DFT ANALYSIS - OS ACTION = FATAL IOU ERROR.
*                                  = SYSTEM STEP (VERSION 4).

          SETDAC DDCL
          SETDAN (EPUN,DAUIE)
          SETFLG (BC.FL)
          SETOSA OSFIE,OSSS
          LDN    0
          STM    GBVA        FLAG FOR NIO PP REGISTERS
          RJM    GBV         GET BOUNDS VIOLATION
          ZJN    AIE3        IF NOT NIO PP
          LJM    AIE5        CONTINUE

 AIE3     LDC    IFS1
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRDL   W0          GET *FS1* REGISTER
          LDDL   W2          BITS 32 - 47
          LPC    0#FF07      IGNORE 12/16, BIT 44, CORRECTED ERROR BITS
          RADL   W3          INCLUDE BITS 48 - 63
          ZJP    AIE3.5      IF BITS 32 - 39, 45 - 63 NOT SET

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = FATAL IOU ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).
*         DFT ANALYSIS - OS ACTION = FATAL IOU ERROR.
*                                  = SYSTEM STEP (VERSION 4).

          SETDAC DDCL
          SETDAN (EPUN,DAFI)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          RJM    SOI         SET OS ACTION BASED ON IOU ORDINAL
          LJM    AIE5        CONTINUE

 AIE3.5   LDDL   W2
          SHN    21-3        12/16 CONVERSION ERROR
          PJP    AIE4        IF NOT 12/16 ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = 12/16 CONVERSION ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAC DDCL
          SETDAN (EPCO,DA1216)
          SETFLG (BC.FL)
          LJM    AIE5        CONTINUE

 AIE4     LDC    IFS2        *FS2* REGISTER
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRDL   W0          READ THE REGISTER
          LDC    EIMR
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRDL   W4
          LDDL   W6
          LPC    0#FF
          LMC    0#42
          NJN    AIE4.5      IF NOT MODEL 42 IOU
          LDDL   W3
          LPC    0#1F90
          STDL   W3          CLEAR CIO COMPONENT
 AIE4.5   LDDL   W0
          ADDL   W1          CHECK FOR ANY BITS SET
          ADDL   W2
          ADDL   W3
          ZJP    AIE6        GO CHECK CIO REGISTERS

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CHANNEL ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAC DDCL
          SETDAN (EPCO,DACHE)
          SETFLG (BC.FL)
 AIE5     CALL   LOG         LOG ERROR
          RJM    RSS         RESTORE SCRATCH SUPPORTIVE STATUS BUFFER
          LDN    BC
          RJM    CLR         CLEAR OLD ANALYSIS CODE

 AIE6     LDN    EIMR        ELEMENT ID
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRDL   W0
          LDDL   W2
          LPC    0#FF
          LMC    0#43
          ZJP    AIE11       IF MODEL 43 IOU
          LMN    0#44&0#43
          ZJP    AIE11       IF MODEL 44 IOU
          LDN    OIMR        OPTIONS INSTALLED REGISTER
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRDL   W0
          LDDL   W3
          SHN    10D
          PJP    AIE11       IF NO CIO PPS PRESENT, STILL CHECK FOR CORR ERR
          LDM    SUMS
          SHN    21-SSPH
          PJP    AIE7        IF NOT PROCESSOR HALT

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = UNCORRECTED CIO PP ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS) ALREADY SET.
*         DFT ANALYSIS - OS ACTION = FATAL IOU ERROR.
*                                  = SYSTEM STEP (VERSION 4).

          SETDAC DDCL
          SETDAN (EPUN,DACUIE)
          SETOSA OSFIE,OSSS
          LDN    1
          STM    GBVA        FLAG FOR CIO PP
          RJM    GBV         GET BOUNDS VIOLATION FOR CIO PP
          ZJN    AIE7        IF NOT CIO PP
          LJM    AIE10       CONTINUE

 AIE7     LDN    EIMR
          RJM    FMB         FIND REGISTER IN MAINTENANCE REGISTER SCRATCH
          CRDL   W0
          LDDL   W2
          LPC    0#FF
          LMC    0#42        MODEL 42 IOU
          ZJP    AIE8.5      IF MODEL 42 IOU
          LDC    CIFS1
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRDL   W0          GET *FS1* REGISTER
          LDDL   W2          BITS 32 - 47
          LPC    0#DF07      IGNORE 12/16, UNUSED BITS, CORRECTED ERRORS
          STDL   T1
          LDDL   W3          BITS 48 - 63
          LPC    0#FB00
          RADL   T1          INCLUDE BITS 48 - 63
          ZJP    AIE8        IF NO ERRORS IN *FS1* (EXCEPT 12/16)

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = FATAL IOU ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).
*         DFT ANALYSIS - OS ACTION = FATAL IOU ERROR.
*                                  = SYSTEM STEP (VERSION 4).

          SETDAC DDCL
          SETDAN (EPUN,DACFI)
          SETFLG (BC.FV7,BC.FV8,BC.FL)
          RJM    SOI         SET OS ACTION BASED ON IOU ORDINAL
          LJM    AIE10       LOG ERROR

 AIE8     LDDL   W2
          SHN    21-3        12/16 CONVERSION ERROR
          PJP    AIE9        IF NOT 12/16 ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = 12/16 CONVERSION ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAC DDCL
          SETDAN (EPCO,DAC1216)
          SETFLG (BC.FL)
          LJM    AIE10       LOG ERROR

 AIE8.5   LDC    IFS2
          UJN    AIE9.1      READ NIO FS2 REGISTER ON MODEL 42 IOU

 AIE9     LDC    CIFS2       *FS2* REGISTER
 AIE9.1   RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRDL   W0          READ THE REGISTER
          LDN    EIMR
          RJM    FMB         FIND REGISTER IN MAINTENANCE REGISTER SCRATCH
          CRDL   T1
          LDDL   T3
          LPC    0#FF
          LMC    0#42        MODEL 42 IOU
          NJN    AIE9.5      IF NOT MODEL 42 IOU
          LDDL   W3
          LPN    0#F
          UJN    AIE9.6

 AIE9.5   LDDL   W0
          ADDL   W1          CHECK FOR ANY BITS SET
          ADDL   W2
          ADDL   W3
 AIE9.6   ZJP    AIE11       IF NO ERRORS

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CHANNEL ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAC DDCL
          SETDAN (EPCO,DACCHE)
          SETFLG (BC.FL)
 AIE10    CALL   LOG         LOG ERROR
          RJM    RSS         RESTORE SCRATCH SUPPORTIVE STATUS BUFFER
          LDN    BC
          RJM    CLR         CLEAR OLD ANALYSIS CODE
 AIE11    LDM    SUMS
          SHN    21-SSCE
          PJP    AIE12       IF NOT CORRECTED ERROR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = CORRECTED IOU ERROR.
*         DFT ANALYSIS - DFT ACTION = CLEAR ERROR.
*         DFT ANALYSIS - ERROR PRIORITY = CORRECTED ERROR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAC DDCL
          SETDAN (EPCO,DACIE)
          SETFLG (BC.FL)
          CALL   LOG
 AIE12    RJM    ZSB         ZERO THE SUPPORTIVE STATUS BUFFER
          LJM    AIEX        RETURN

 GBV      SPACE  4,10
**        GBV - GET BOUNDS VIOLATION.
*
*         ENTRY  *GBVA* IS FLAG DENOTING 1=CIO REGISTER, 0=NIO REGISTER.
*
*         EXIT   (A) = 0 PERTINENT *FS1* RESISTER NOT IN ERROR.
*
*         USES   T1, W0 - W7.
*
*         CALLS  FMB, VCK.


 GBV      SUBR               ENTRY/EXIT
          LDN    EIMR        ELEMENT ID REGISTER
          RJM    FMB         FIND REGISTER IN BUFFER
          CRDL   W0
          LDDL   W2
          LPC    0#FF
          LMC    0#42
          STD    T1          SAVE MODEL 42 IOU BOOLEAN
          LDM    GBVA
          NJN    GBV0        IF CIO PP
          LDC    IFS1        ADD IN *FS1* REGISTER OFFSET
          UJN    GBV2        CONTINUE

 GBV0     LDD    T1
          NJN    GBV1        IF NOT MODEL 42 IOU
          LDC    IFS1
          UJN    GBV2

 GBV1     LDC    CIFS1       CIO *FS1* REGISTER
 GBV2     RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRDL   W0          GET *FS1* REGISTER
          LDD    T1
          NJN    GBV5        IF NOT MODEL 42 IOU
          LDM    GBVA
          NJN    GBV3        IF CIO SEARCH
          LDDL   W1
          LPC    0#1F00      CLEAR CIO COMPONENT
          UJN    GBV4

 GBV3     LDN    0
          STDL   W0          CLEAR NIO BARRELS 0,1
          LDDL   W1
          LPC    0#1F
 GBV4     STDL   W1
 GBV5     LDDL   W0
          ADDL   W1
          ADDL   W2
          ADDL   W3
          ZJP    GBVX        IF NOTHING IN *FS1*
          LDM    GBVA
          NJN    GBV6        IF CIO PP
          LDN    IOSB        NIO OS BOUNDS
          UJN    GBV8        CONTINUE

 GBV6     LDD    T1
          NJN    GBV7        IF NOT MODEL 42 IOU
          LDN    IOSB
          UJN    GBV8

 GBV7     LDN    CIOSB       CIO OS BOUNDS
 GBV8     RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRDL   W4
          LDDL   W0
          LPDL   W4          USE *OSB* AS A MASK AGAINST *FS1* REGISTER
          ZJN    GBV11       SO FAR 180 PP
 GBV9     SETFLG (BC.FV7)    SET VALID 170 FLAG
          LDN    VER2
          RJM    VCK         CHECK DFT BLOCK VERSION
          MJN    GVB10       IF DFT 1 SELECTED

*         DFT ANALYSIS - OS ACTION = FATAL IOU ERROR.
*                                  = C170 STATE STEP (VERSION 4).

          SETOSA OSNSI,OS17S
          LDN    1
 GVB10    LJM    GBVX        RETURN

 GBV11    LDM    GBVA        GET CIO OR NIO
          NJN    GBV12       IF CIO ONLY HAVE 2 BARRELS
          LDDL   W1
          LPDL   W5          USE OS BOUNDS AS MASK
          NJP    GBV9        IF 170 PP ERROR
 GBV12    SETFLG (BC.FV8)    SET VALID 180 FLAG

*         DFT ANALYSIS - OS ACTION = FATAL IOU ERROR.
*                                  = C180 STATE STEP (VERSION 4).

          SETOSA OSVEI,OS18S

          LDN    D8TY
          RJM    IIB
          CRDL   CM
          LDDL   CM+3
          LPC    0#3F
          SBN    2
          MJN    GBV13       IF DFT LEVEL GREATER THAN OS LEVEL
          SETOSA OSVEI,OSHGP HUNG PP OS ACTION
 GBV13    LDN    1
          LJM    GBVX        RETURN

 GBVA     CON    0           FLAG TELLING NIO OR CIO TYPE OF PP
 RSS      SPACE  4,10
**        RSS - RESTORE SUPPORTIVE STATUS.
*
*         ENTRY  (LLOG) HOLDS THE LENGTH TO LOG
*

 RSS      SUBR               ENTRY/EXIT
          LDN    VER4
          RJM    VCK         CHECK VERSION
          MJN    RSSX        IF LESS THAN VERSION 4 LEAVE
          LDN    SSBP        READ SUPPORTIVE STATUS HEADER WORD
          RJM    IDA
          CRDL   CM
          AODL   CM          SKIP TO SCRATCH ENTRY HEADER WORD
          LRD    CM+1
          ADC    RR
          CRML   RSSA,ON
          LDML   LLOG        SET LOGGED MRB SIZE
          STML   RSSA+3
          LDN    MTMRB       SET MRB TYPE
          RAML   RSSA
          LDDL   CM          REWRITE HEADER WORD
          ADC    RR
          CWML   RSSA,ON
          UJN    RSSX        RETURN

 RSSA     BSSZ   4
 SOI      SPACE  4,10
**        SOI - SET OS ACTION BASED ON IOU ORDINAL.
*
*         EXIT   APPROPRIATE OS ACTION CODE HAS BEEN SET.
*                FOR VERSION 4 OR LATER THESE ACTION CODES
*                ARE SYSTEM STEP, IF IOU0 ERROR OR
*                C180 STATE STEP, IF IOU1 ERROR.


 SOI1     SETOSA OSFIE,OSSS

 SOI      SUBR               ENTRY/EXIT
          LDML   IOUO        GET IOU ORDINAL
          ZJN    SOI1        IF IOU0 ERROR
          SETOSA OSVEI,OS18S
          UJN    SOIX        RETURN
 ZSB      SPACE  4,10
**        ZSB - ZERO SUPPORTIVE STATUS.
*
*

 ZSB      SUBR               ENTRY/EXIT
          LDN    VER4
          RJM    VCK         CHECK VERSION
          MJN    ZSBX        IF LESS THAN VERSION 4 LEAVE
          LDN    SSBP        READ SUPPORTIVE STATUS HEADER WORD
          RJM    IDA
          CRDL   CM
          AODL   CM          SKIP TO SCRATCH ENTRY HEADER WORD
          LRD    CM+1
          ADC    RR
          CWML   ZSBA,ON     CLEAR SUPPORTIVE STATUS HEADER
          UJN    ZSBX        RETURN

 ZSBA     BSSZ   4

*         END OF CTP$DFT_ANALYZE_IOU_ERRORS_I4





*DECK DECK=CTP$DFT_CHECK_CPU_THRESHOLD EXPAND=TRUE
*         CTEXT  CTP$DFT_CHECK_CPU_THRESHOLD
 CTE      SPACE  4,10
**        CTE - CHECK THRESHOLD EXCEEDED.
*
*         EXIT   (A) <> 0 THRESHOLD EXCEEDED.
*
*         CALLS  GCE.
*
*         USES   CM - CM+3, T1.

 CTE0     LDN    0
 CTE      SUBR               ENTRY/EXIT
          LDN    VER4
          RJM    VCK         CHECK VERSION
          MJN    CTE0        IF LESS THAN VERSION 4
          LDM    SUMS
          LPC    0#FDF       CLEAR MONITOR MODE BIT
          LMN    2           TEST FOR CORRECTED ERROR
          NJN    CTE0        IF MORE THAN CORRECTED ERROR
          LDM    CPUO
          STD    T1
          LDM    CTEA,T1
          STD    T1
          RJM    GCE         GET COUNTER ENTRY
          LDDL   CM
          LPN    1
          ZJP    CTEX        IF NOT AT THRESHOLD
          LDN    0
          STM    DFTA        NULL ACTION
          LDN    1
          STM    STON        SET STUCK ON ERROR FLAG
          UJN    CTEX        RETURN

 CTEA     CON    0#0         CPU 0 ID
          CON    0#10        CPU 1 ID
*COPY CTP$DFT_GET_COUNTER_ENTRY

*         END    CTP$DFT_CHECK_CPU_THRESHOLD
*DECK DECK=CTP$DFT_CHECK_DEGRADABLE_CPU EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT_CHECK_DEGRADABLE_CPU
*
*         THIS DECK CONTAINS ROUTINES THAT DETERMINE IF IT IS POSSIBLE TO
*         DEGRADE THE CPU OUT OF THE SYSTEM ON A FATAL CPU ERROR.
 CDC      SPACE  4,10
**        CDC - CHECK DEGRADABLE CPU.
*
*         EXIT   (A) = 0 IF CPU CANNOT BE DEGRADED.
*                OS ACTION CODE SET TO *OSRME* AND *DFT* ACTION SET TO DISABLE
*                THE MEMORY PORT IF THE CPU IS DEGRADABLE.
*
*         USES   T1 - T4.
*
*         CALLS  CNL, IIB.
*
*         MACROS SETDAC, SETOSA.


*         THE CPU IS NOT DEGRADABLE.  SET THE OS ACTION CODE TO SYSTEM STEP.

 CDC2     SETOSA OSSS,OSSS
 CDC3     LDN    0           INDICATE THAT CPU IS NOT DEGRADABLE

 CDC      SUBR               ENTRY/EXIT
          LDN    D8TY        CHECK VERSION
          RJM    IIB
          CRDL   T1
          LDDL   T2
          ADC    -716D+1
          MJN    CDC3        IF THIS VERSION DOES NOT SUPPORT DEGRADING CPUS

*         CHECK IF C170 OS IS RUNNING IN STANDALONE MODE BY CHECKING THE
*         180 OS TYPE IN *D8TY*.

          LDDL   T4
          SHN    -14
          LMN    1
          ZJN    CDC3        IF C170 STANDALONE MODE
 CDC1     RJM    CNL         CHECK NUMBER OF LOGICALLY ON CPUS
          ZJN    CDC2        IF ONLY ONE CPU LOGICALLY ON
          LDM    WARN        CHECK IF POWER WARNING
          NJP    CDC2        IF POWER WARNING

*         THE CPU IS DEGRADABLE.  CHANGE THE DFT ACTION CODE TO DISABLE THE MEMORY
*         PORT AND CHANGE THE OS ACTION CODE TO RECONFIGURE MAINFRAME ELEMENTS.

          LDM    DTLA        GET THE DEGRADE CPU TASK LIST ADDRESS
          STM    DFTA
          SETOSA OSSS,OSRME
          LDDL   BC+BCFLG    CLEAR VALID 170 FLAG
          SCN    BC.FV7+1
          ERRNZ  BC.FV7      CODE ASSUMES BIT 0
          STDL   BC+BCFLG
          LDN    1           INDICATE CPU DEGRADABLE
          LJM    CDCX        RETURN
 CID      SPACE  4,10
**        CID - CHECK IF DISABLE CPU ERROR AND CPU DEGRADABLE.
*
*         ENTRY  (DFTA) = DFT ACTION POINTER.
*
*         CALLS  CDC.


 CID      SUBR               ENTRY/EXIT
          LDM    DFTA        CHECK DFT ACTION
          LMC    DDDC
          NJN    CIDX        IF NOT DISABLE CPU
          RJM    CDC         CHECK DEGRADABLE CPU
          UJN    CIDX        RETURN
 CNL      SPACE  4,10
**        CNL - CHECK NUMBER OF LOGICALLY ON CPUS.
*
*         EXIT   (A) = 0 IF ONLY ONE LOGICALLY ON CPU.
*
*         USES   T5.
*
*         CALLS  FHE, GPS, *ERRH*.


 CNL      SUBR               ENTRY/EXIT
          LDN    0           INITIALIZE NUMBER OF LOGICALLY ON CPUS
          STD    T5
          LDN    PROCID      READ CPU-0 DESCRIPTOR
          RJM    FHE
          MJN    CNL5        IF NOT FOUND
          RJM    GPS         GET PROCESSOR STATUS
          NJN    CNL1        IF CPU NOT ON OR MEMORY PORT DISABLED
          AOD    T5
 CNL1     LDC    PROCID1     READ CPU-1 DESCRIPTOR
          RJM    FHE
          MJN    CNL2        IF NOT PRESENT
          RJM    GPS         GET PROCESSOR STATUS
          NJN    CNL2        IF NOT LOGICALLY ON
          AOD    T5

*         RESET *HBUF* WITH THE DESCRIPTOR OF THE CURRENT CPU.

 CNL2     LDM    CPUO        GET CURRENT CPU NUMBER
          NJN    CNL3        IF NOT CPU 0
          LDN    PROCID      RESET WITH CPU-0 DATA
          UJN    CNL4        CONTINUE

 CNL3     LDC    PROCID1     RESET WITH CPU-1 DATA
 CNL4     RJM    FHE         RESET *HBUF*
          MJN    CNL5        IF NOT FOUND
          SOD    T5          RETURN ZERO IF ONLY ONE LOGICALLY ON CPU
          LJM    CNLX        RETURN

 CNL5     SETDAN (EPUN,DAME)
          LDC    DAME+TDFT   613 - DFT NO DESC IN MRT
          STML   RTP1
          CALL   ERRH
 GPS      SPACE  4,10
**        GPS - GET PROCESSOR STATUS.
*
*         ENTRY  (HBUF) = CPU DESCRIPTOR.
*
*         EXIT   (A) = 0 IF THE CPU IS ON AND THE MEMORY PORT IS ENABLED.
*
*         CALLS  CMP.
*
*         MACROS READMR.


 GPS      SUBR               ENTRY/EXIT
          LDM    HBUF+CPRSTAT  GET CPU STATUS
          LPC    1001
          NJN    GPSX        IF NOT LOGICALLY ON
          READMR RDATA,CMCC,ECMR  READ ENVIRONMENT CONTROL
          RJM    CMP         CHECK MEMORY PORT
          UJN    GPSX        RETURN

*         END CTP$DFT_CHECK_DEGRADABLE_CPU

*DECK DECK=CTP$DFT_CHECK_PACKET_STATUS EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT CHECK PACKET STATUS.
*
*         THIS DECK DEFINES CODE WHICH PROCESSES THE VARIOUS
*         PHASES OF PACKET COMMUNICATION. THIS DECK SHOULD BE CALLED
*         IN THE MAIN NON RESIDENT OVERLAY OF DFT.
 CPS      SPACE  4,15
**        CPS - CHECK PACKET STATUS.
*
*         ENTRY  (PKTCW) = PACKET CONTROL WORD.
*                (CELCW) = CONSOLE LOGGING CONTROL WORD.
*
*         EXIT   *LTC* CALLED IF CONSOLE LOGGING REQUIRED/IN PROGRESS.
*                MRT LOGGING INITIATED IF REQUIRED AND NO LOGGING ACTIVE.
*                GENERAL RESPONSE PACKET RECEIVED IF AVAILABLE.
*                GENERAL PACKET SENT IF REQUESTED AND NO LOGGING ACTIVITY.
*                *CHECK-IN* PACKET SENT IF NO OTHER ACTIVITY AND FLAG SET.
*
*         CALLS  CRS, LPT, PFC, PKT, SCF, *LTC*.


          ROUTINE  CPS

          LDML   PKTCW       CHECK GENERAL PACKET STATUS
          SHN    21-17
          PJP    CPS2        IF NO RESPONSE PENDING
          SHN    21-16-21+17
          PJP    CPS0        IF NOT TIMED OUT
          CALL   LPT         LOG PACKET TIMEOUT
          LDM    PKTCW       CLEAR TIMEOUT FLAG
          STM    PKTCW
          LJM    CPS2        SEND PACKET DATA IF ANY

 CPS0     RJM    CRS         CHECK RESPONSE STATUS
          ZJP    CPS1        IF NO RESPONSE PACKET AVAILABLE

*         RECEIVE RESPONSE PACKET.

          LDM    PKTCW       CLEAR RESPONSE PENDING
          STM    PKTCW
          LDN    0           CLEAR TIMER CONTROL WORD
          STML   PKTIM
          LDN    40          REQUEST = RECEIVE PACKET
          STM    CALB+0
          LDC    TOIP        BUFFER ADDRESS = *2AP* BUFFER (AT 2000)
          STML   CALB+2
          LDN    MX          GET CHANNEL 15 INTERLOCK
          RJM    SCF
          CALL   PFC         CALL *2AP*
          CCF    *,MX        RELEASE CHANNEL 15 INTERLOCK
          LDM    CALB+1      CHECK FOR ERRORS
          ZJP    CPSX        IF NO ERROR DETECTED
          LDN    BC
          RJM    CLR
          LDN    0
          STD    ET
          SETDAN (EPCO,DAIS)
          SETFLG (BC.FL)
          LDML   CALB+1
          STML   CPSA
          LDN    NRSP
          RJM    IDA
          CRDL   W0
          LRD    W1
          LDDL   W0
          ADC    RR+NRSBL+1
          CWML   CPSA,ON
          LDN    NRSBL
          STML   LLOG
          LDN    4
          STD    ET
          LDN    1
          STM    RTP1
          CALL   LOG
 CPS1     LJM    CPSX        RETURN

*         DETERMINE IF BACKGROUND PACKETS ARE ALLOWED.

 CPS2     LDML   CELCW       CHECK CONSOLE LOGGING STATUS
          NJN    CPS2.1      IF LOGGING OUTSTANDING/IN PROGRESS
          LDM    MRTU        CHECK IF MRT UPDATE NEEDS TO BE LOGGED
          ZJN    CPS3        IF MRT HAS NOT BEEN UPDATED
          LDN    77          INITIATE MRT TRANSFER
          STM    CELCW
 CPS2.1   CALL   LTC         LOG TO CONSOLE
          UJN    CPS1        RETURN

*         CHECK FOR GENERAL PACKET REQUESTS.

 CPS3     LDM    PKTCW
          ZJN    CPS4        IF NO REQUEST PRESENT
          STML   RTP1
          CALL   PKT         SEND REQUESTED PACKET
          UJN    CPS5        SET RESPONSE PENDING AND RETURN

*         SEND CHECK-IN PACKET IF TIME HAS ELAPSED.

 CPS4     LDM    CPSA        CHECK ELAPSED TIME FLAG
          ZJN    CPS1        IF NOT TIME TO SEND CHECK-IN PACKET
          LDN    0           CLEAR FLAG
          STM    CPSA
*         LDN    PKRCI       SEND CHECK-IN PACKET
*         STML   RTP1
*         CALL   PKT
          LJM    CPSX        **** DISABLE CHECK-IN PACKETS FOR NOS/VE 1.3.1 ****

*         UPDATE *PKTCW* AND RETURN.

 CPS5     LDC    PKWRP       CLEAR REQUEST AND SET RESPONSE PENDING
          STML   PKTCW
          LJM    CPSX        RETURN

 CPSA     BSSZ   4
 MPR      SPACE  4,10
**        MPR - MAKE PACKET REQUEST.
*
*         ENTRY  (RTP1) = REQUEST.
*                (PKTCW) = PACKET CONTROL WORD.
*
*         EXIT   (PKTCW) UPDATED IF NO REQUEST PREVIOUSLY PRESENT.
*                (RTP1) = 0, IF REQUEST QUEUED.
*                    = PREVIOUS REQUEST, IF NEW REQUEST NOT QUEUED.


          ROUTINE  MPR

          LDM    PKTCW       CHECK PREVIOUS REQUEST (IGNORE RESPONSE PENDING)
          NJN    MPR1        IF PREVIOUS REQUEST PRESENT
          LDM    RTP1        MERGE REQUEST WITH RESPONSE PENDING STATUS IF ANY
          RAML   PKTCW
          LDN    0           SET REQUEST RECORDED
 MPR1     STML   RTP1
 MPR2     LJM    MPRX        RETURN
 PKT      SPACE  4,15
**        PKT - PROCESS CONSOLE PACKETS VIA *2AP*.
*
*         ENTRY  (RTP1) = 2/0,1/R,1/S,2/C,10/CODE.
*                R = 1, IF CALLER WILL HANDLE ERRORS (*PKT* TO RETURN).
*                S = 1, IF BUFFER AND CALL BLOCK PREPARED.
*                C = OFFSET TO PACKET CONTROL WORD FOR TIMING (2).
*                CODE = *PKFDR* SUBCODE (SEE *CTI$PACKET_DEFINITIONS*).
*                     = *PKRLE* TO LOG INFORMATION TO THE CONSOLE.
*
*         USES   T1, T2, T3.
*
*         CALLS  SCF.


          ROUTINE  PKT

          LDML   RTP1        CALL PARAMETERS
          LPC    1777
          STD    T1          SAVE SUBCODE
          LDML   RTP1
          SHN    -14
          LPN    1
          STD    T2          SAVE SETUP FLAG

*         STORE PARAMETERS IN PACKET BUFFER AND *2AP* CALL BLOCK.

          LDC    140         REQUEST = SEND PACKET
          STM    CALB+0
          LDML   TINB        SET BUFFER ADDRESS (*TOIP* OR *TOIPS0*)
          STML   CALB+2
          STDL   T3
          LDM    PPNO        SOURCE ID = *DFT* PP NUMBER
          LPC    0#FF
          SHN    10
          STIL   T3
          LDD    T2
          NJP    PKT1        IF BUFFER AND CALL BLOCK ALREADY PREPARED
          LDD    T1          STORE *PKFDR* SUBCODE IN PACKET BUFFER
          SHN    10
          STML   1,T3
          LDN    PKFDR       FUNCTION = DFT REQUEST
          STM    CALB+1
          LDN    4           DEFAULT LENGTH = 4 (SOURCE ID, FUNCTION, CODE, PAD)
          STM    CALB+3

*         SEND PACKET TO CONSOLE VIA *2AP* AND CHECK FOR ERRORS.

 PKT1     LDN    MX          GET CHANNEL 15 INTERLOCK
          RJM    SCF
          FNC    MXPT,MX     SELECT PORT
          AJM    *,MX
          CALL   PFC         CALL *2AP*
          FNC    MXDM,MX     DESELECT MUX
          AJM    *,MX
          CCF    *,MX        RELEASE CHANNEL 15 INTERLOCK
          LDM    RTP1        ADD TIMEOUT CONTROL INFORMATION
          LPC    0#C00
          SHN    2
          STML   PKTIM
          LDML   RTP1
          SHN    -14
          LPN    2
          NJN    PKT2        IF CALLER WILL PROCESS ERRORS
          CALL   CER         CHECK ERROR RESPONSE
 PKT2     LDN    0
          STM    RTP1
          LJM    PKTX        RETURN
          SPACE  4,10
*         END    CTP$DFT CHECK PACKET STATUS
*DECK DECK=CTP$DFT_CHECK_PKTS_FOR_NON_S0 EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT CHECK PKTS FOR NON S0.
*
*         COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
*
*         THIS DECK CONTAINS ROUTINES FOR CHECKING ERRORS AND STATUS
*         RELATED TO PACKETS.
 CER      SPACE  4,15
**        CER - CHECK ERROR RESPONSE.
*
*         ENTRY  (CALB+1) = 0, IF NO ERROR.
*                (CALB+2) = FWA OF BUFFER.
*
*         EXIT   (PES1) = 8000(16), IF SEQUENCE NUMBER MISMATCH.
*                       = ERROR CODE.
*
*         USES   T1.
*
*         CALLS  ICC, IDA, *LOG*, SPB, VCK.



          ROUTINE CER        ENTRY/ EXIT

          LDM    CALB+1
          STM    PES1        SAVE CTI STATUS
          LDML   PKTCW
          LPC    0#100
          ZJP    CER0        IF NOT EPM RELATED PACKETS
          LDM    CALB+1
          NJP    CER3        IF PACKET ERROR
          LDML   TOIP+1      NUMBER OF BYTES IN PACKET DATA
          SHN    -10
          SHN    -1          2 BYTES PER PP WORD
          STD    T1
          LDM    TOIP
          LPC    0#FF
          SHN    7
          LMDL   T1          OR IN UPPER BITS
          STD    T1
          LDML   TOIP,T1
          LPC    0#FF
          UJP    CER2

 CER0     LDM    CALB+1
          ZJN    CER1        IF NO ERROR
          STM    PKERR       SAVE LAST RESPONSE PACKET ERROR CODE
          LDN    1           OFFSET TO SEQUENCE NUMBER

*         ENSURE PACKET SEQUENCE NUMBER MATCHES CURRENT REQUEST.

 CER1     ADM    CALB+2
          STD    T1
          LDI    T1
 CER2     LMM    PKSEQ
          LPC    0#FF
          STML   CERA+2      SAVE RETURNED SEQUENCE

          NJP    CER6        IF NUMBERS DO NOT MATCH
          LDM    CALB+1
          ZJP    CERX        IF NO ERROR

*         DFT ANALYSIS - PACKET RESPONSE ERROR.
*         DFT FLAGS -  LOGGING.

 CER3     LDN    BC
          RJM    CLR
          LDN    0
          STD    ET
 CER4     SETDAN (EPUN,DAPC) PACKET COMMUNICATION ERROR
          SETFLG (BC.FL)
          LDM    CALB+1
          STM    CERA+3
 CER5     LDN    NRSP        NON REGISTER STATUS BUFFER
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0
          LRD    W1
          RJM    SPB         SET PP BOUNDARY
          LDDL   W0
          ADC    RR+NRSBL+1  BASE SIZE + HEADER WORD
          CWML   CERA,ON     WRITE ERROR CODE TO SCRATCH SUPPORTIVE STATUS
          LDN    NRSBL
          STM    LLOG        LENGTH TO LOG
          LDN    1
          STM    RTP1
          CALL   LOG         LOG THE ERROR
          LJM    CERX

*         DFT ANALYSIS - SEQUENCE NUMBER ERROR.
*         DFT FLAGS - LOGGING.

 CER6     LDN    BC
          RJM    CLR
          LDN    0
          STD    ET
          SETDAN (EPUN,DASQ) PACKET SEQUENCE NUMBER ERROR
          SETFLG (BC.FL)
          LDM    PKSEQ
          STM    CERA+3
          LDC    0#8000
          STML   PES1        SEQUENCE MISMATCH ERROR CODE
          UJP    CER5

 CERA     BSS    4

*         END    CTP$DFT CHECK PKTS FOR NON S0.
*DECK DECK=CTP$DFT_CHECK_PKTS_FOR_S0 EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT CHECK PKTS FOR S0.
*
*         COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
*
*         THIS DECK CONTAINS ROUTINES TO CHECK ON THE STATUS OF PACKET
*         REQUESTS ON THE S0.
 CRS      SPACE  4,10
**        CRS - CHECK RESPONSE STATUS.
*
*         EXIT   (A) = 0, IF NO RESPONSE PACKET AVAILABLE.
*                    = 1, IF RESPONSE PACKET IS AVAILABLE.
*
*         CALLS  SCF.


 CRS      SUBR               ENTRY/EXIT
          LDN    MX          INTERLOCK CHANNEL 15
          RJM    SCF
          FNC    MXPS+0,MX   READ PORT 0 STATUS
          ACN    MX
          IAN    MX
          DCN    MX+40
          CCF    *,MX        RELEASE CHANNEL 15
          LPN    1           EXTRACT PACKET AVAILABLE BIT
          UJN    CRSX        RETURN

*         END    CTP$DFT_CHECK_PKTS_FOR_S0.
*DECK DECK=CTP$DFT_CHECK_PKT_ERROR_STATUS EXPAND=FALSE
*         CTEXT  CTP$DFT_CHECK_PKT_ERROR_STATUS
 CER      SPACE  4,10
**        CER - CHECK ERROR RESPONSE.
*
*         ENTRY  (CALB+1) = 0, IF NO ERROR.


          ROUTINE CER        ENTRY/EXIT

          LDM    CALB+1      CHECK FOR ERRORS
          ZJP    CERX        IF NO ERROR DETECTED
          LDN    0           CLEAR PACKET TIMEOUT CONTROL
          STML   PKTIM
          LRD    DP+1
          RJM    SPB         SET OS BOUNDS
          LDN    BC
          RJM    CLR
          LDN    0
          STD    ET

*         DFT ANALYSIS - PACKET RESPONSE ERROR.
*         DFT FLAGS - VALID 180, LOGGING.

          SETDAN (EPUN,DAPC) BAD PHASE IN PACKET COMMUNICATION
          SETFLG (BC.FL)
          LDM    CALB+1
          STM    CERA+3      SAVE THE RESPONSE STATUS
          LDML   CELCW
          STML   CERA+2      SAVE THE CONTROL WORD
          LDN    NRSP        NON REGISTER STATUS BUFFER
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0
          LRD    W1
          LDDL   W0
          ADC    RR+NRSBL+1  BASE SIZE + HEADER WORD
          CWML   CERA,ON     WRITE ERROR CODE TO SCRATCH NON REGISTER STATUS
          LDN    NRSBL
          STM    LLOG        LENGTH TO LOG
*         LDC    DAPC+TDFT
          LDN    1           LOG TO NRSB
          STM    RTP1
*         CALL   ERRH        LOG THE ERROR
          CALL   LOG         FOR JUST NOW
*         LDC    DAPC
*         RJM    IDD         IDLE DOWN AND DIE
          LJM    CERX        JUST CONTINUE
 CERA     BSSZ   4

*         END    CTP$DFT_CHECK_PKT_ERROR_STATUS
*DECK DECK=CTP$DFT_CHECK_PKT_STATUS_NON_S0 EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT CHECK PKT STATUS NON S0.
*
*         COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
*
*         THIS DECK DEFINES CODE WHICH PROCESSES THE VARIOUS
*         PHASES OF PACKET COMMUNICATION.  THIS DECK SHOULD BE CALLED
*         IN THE MAIN NON RESIDENT OVERLAY OF DFT.
*         RECEIVE RESPONSE PACKET.

          ROUTINE RRP        ENTRY/EXIT

          LDM    PKTCW       CLEAR RESPONSE PENDING
          STM    PKTCW
          LDN    40          REQUEST = RECEIVE PACKET
          STM    CALB+0
          LDC    TOIP        BUFFER ADDRESS = *2AP* BUFFER (AT 2000)
          STML   CALB+2
          LDN    MX          GET CHANNEL 15 INTERLOCK
          RJM    SCF
          FNC    MXPT,MX     SELECT PORT
          AJM    *,MX
          CALL   PFC         CALL *2AP*
          FNC    MXDM,MX     DESELECT MUX
          AJM    *,MX
          CCF    *,MX        RELEASE CHANNEL 15 INTERLOCK
          CALL   CER         CHECK ERROR RESPONSE
          LDN    0           CLEAR PACKET TIMING CONTROL
          STML   PKTIM
          LJM    RRPX        RETURN

*         END    CTP$DFT CHECK PKT STATUS NON S0.

*DECK DECK=CTP$DFT_CHECK_TPM_PKT_RESPONSE EXPAND=FALSE
*         CTEXT  CTP$DFT_CHECK_TPM_PKT_RESPONSE
*
 CRS      SPACE  4,10
**        CRS - CHECK RESPONSE STATUS.
*
*         EXIT   (A) = 0, IF NO RESPONSE PACKET AVAILABLE.
*                    = 1, IF RESPONSE PACKET IS AVAILABLE.
*
*         CALLS  SCF.


 CRS      SUBR               ENTRY/EXIT
          LDN    MX          INTERLOCK CHANNEL 15
          RJM    SCF
          FNC    MXPT,MX     SELECT PORT 0
          AJM    *,MX
          FNC    MXKS,MX     READ PORT 0 STATUS
          AJM    *,MX
          ACN    MX
          IAN    MX
          AJM    *,MX
          FNC    MXDM,MX     DESELECT PORT
          AJM    *,MX
          CCF    *,MX        RELEASE CHANNEL 15
          LPN    1           EXTRACT PACKET AVAILABLE BIT
          UJN    CRSX        RETURN

*         END CTP$DFT_CHECK_TPM_PKT_RESPONSE
*DECK DECK=CTP$DFT_CLEAR_PACKETS_I4 EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT CLEAR PACKETS I4.
*
*         COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
*
*         THIS DECK CONTAINS ROUTINES TO INITIALIZE FOR PACKET
*         PROCESSING.
 ICP      SPACE  4,10
**        ICP - ISSUE CLEAR PACKETS REQUEST.
*
*         CALLS  SCF.


 ICP      SUBR               ENTRY/EXIT
          LDML   PKFLG
          ZJN    ICPX        IF PACKETS ARE NOT SUPPORTED
          LDN    MX          INTERLOCK CHANNEL 15
          RJM    SCF
          FNC    MXPT,MX     SELECT PORT 0
          AJM    *,MX
          FNC    MXCP,MX     CLEAR PACKETS
          AJM    *,MX
          FNC    MXDM,MX     DESELECT PORT
          AJM    *,MX
          CCF    *,MX        RELEASE CHANNEL 15
          UJN    ICPX        RETURN

*         END    CTP$DFT CLEAR PACKETS I4.

*DECK DECK=CTP$DFT_CPU_HANDSHAKER EXPAND=FALSE
*         CTEXT  CTP$DFT_CPU_HANDSHAKER
 CPH      SPACE  4,10
**        CPH - PERFORM CPU/PP HANDSHAKING.
*
*         DETERMINE WHETHER MONITOR IS STILL ALIVE.  SINCE THIS ROUTINE
*         IS CALLED EVERY FIVE SECONDS, TIMEOUT HAS OCCURRED IF THE
*         TIMEOUT FLAG EVER EQUALS SIX (5 * 6 = 30 SECOND TIMEOUT).
*
*         ENTRY  ONCE EVERY FIVE SECONDS FROM *TIM*.
*
*         EXIT   DFT TIME WORD UPDATED.
*                (DFTE) = *LDN 0*.
*
*         USES   T1 - T4, W0 - W7.
*
*         CALLS  DCD, SPB.


          ROUTINE CPH        ENTRY/EXIT
          LDC    LDNI+0      CLEAR HANDSHAKE FLAG
          STM    DFTE
          RJM    DCD         DETERMINE IF CPU/PP COMMUNICATION BLOCK DEFINED
          ZJP    CPHX        IF NO POINTER OR EICB REVISION < 04
          LRD    W4+1
          LDD    W4          READ MONITOR TIME WORD
          ADN    1
          ADC    RR
          CRDL   W0
          ADN    2           READ DFT TIME WORD
          CRDL   T1
          LDM    IOUN        CHECK WHICH DFT IS ACTIVE
          NJN    CPH5        IF DFT-S

*         COMPARE THE MONITOR AND DFT TIME WORDS TO SEE IF MONITOR HAS
*         UPDATED ITS WORD SINCE THE LAST DFT UPDATE.

          LDDL   W0
          SBDL   T1
          NJN    CPH5        IF TIME WORDS DIFFER
          LDDL   W0+1
          SBDL   T1+1
          NJN    CPH5        IF TIME WORDS DIFFER
          LDDL   W0+2
          SBDL   T1+2
          NJN    CPH5        IF TIME WORDS DIFFER
          LDDL   W0+3
          SBDL   T1+3
          ZJN    CPH15       IF TIME WORDS EQUAL

*         MONITOR HAS NOT TIMED OUT.  UPDATE DFT TIME WORD.

 CPH5     RJM    SPB         SET PP BOUNDS
          LDD    W4
          ADN    3
          ADM    IOUN        SELECT DFT/DFT-S WORD
          ADC    RR
          CWDL   W0
          LDN    0           CLEAR FLAG
          STM    CHEF
 CPH10    LJM    CPHX        RETURN

*         TIME WORDS ARE EQUAL.  WHEN THE EQUAL FLAG = 6, MONITOR
*         TIMEOUT HAS OCCURRED.  IF SO, SET FLAG TO ISSUE TIMEOUT
*         MESSAGE.

 CPH15    LDM    CHEF
          SBN    77
          ZJN    CPH10       IF ALREADY ISSUED TIMEOUT
          AOM    CHEF
          SBN    6
          NJN    CPH10       IF NOT TIMEOUT
          AOM    DFTD        SET ISSUE TIMEOUT MESSAGE FLAG
          LDN    77
          STM    CHEF
          LRD    IB+1        SET PP BOUNDS
          RJM    SPB
          UJN    CPH10       RETURN
 DCD      SPACE  4,10
**        DCD - DETERMINE IF CPU/PP COMMUNICATION BLOCK DEFINED.
*
*         CHECKS FOR EICB REVISION LEVEL < 04 AND DETERMINES IF
*         THE POINTER TO THE CPU/PP COMMUNICATION BLOCK IS DEFINED.
*
*         EXIT   (A) = 0, IF EICB REVISION LEVEL < 04 OR NO POINTER.
*                (W4 - W7) = POINTER TO BLOCK, IF DEFINED.
*
*         USES   W0 - W3.
*
*         CALLS  IIB.


 DCD1     LDN    0           RETURN EICB REVISION < 04

 DCD      SUBR               ENTRY/EXIT
          LDN    D7TY        CHECK EICB REVISION LEVEL
          RJM    IIB
          CRDL   W0
          LDD    W3
          SHN    -6
          SBN    4
          MJN    DCD1        IF EICB REVISION < 04
          LDN    D8RLP       READ CPU/PP COMMUNICATION BLOCK POINTER
          RJM    IIB
          CRDL   W4
          LDD    W4+3
          UJN    DCDX        RETURN ZERO IF NO POINTER

*         END    CTP$DFT_CPU_HANDSHAKER
*DECK DECK=CTP$DFT_DUMP_PP_REGISTERS EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT_DUMP_PP_REGISTERS
*

 DPR      SPACE  4,10
**        DPR - DUMP PP REGISTERS.  THE PP REGISTERS DUMPED ARE A, P, K
*               AND Q.
*
*         ENTRY  (PPTN) = PP TYPE AND NUMBER.
*                (W4 - W7) = POINTER TO AREA FOR PP REGISTERS TO BE WRITTEN
*                          IN MEMORY, R-POINTER FORMAT.
*
*         EXIT   PP REGISTERS WRITTEN TO SPECIFIED MEMORY.
*                (W4) = OFFSET IN R-POINTER UPDATED TO REFLECT WORDS WRITTEN.
*
*         CALLS  LRP, SPB.
*
*         USES   EC, RN, T1, T4, T5.


 DPR      SUBR               ENTRY/EXIT
          LDM    PPTN        GET PP NUMBER AND TYPE
          STD    T1          SAVE PP TYPE AND NUMBER
          LDM    IOUM
          LMC    0#42
          ZJP    DPR1        IF MODEL 42 IOU
          LDD    T1
          SHN    21-10
          PJN    DPR1        IF NIO PP
          LDN    ECIO        CIO *EC* REGISTER
          STM    DPRE
          LDC    SCIO        CIO STATUS REGISTER
          STM    DPRS
          LDD    T1          GET PP
          LPN    0#1F        ISOLATE JUST PP NUMBER
          STM    DPRF        SAVE PP NUMBER
          UJN    DPR2        CONTINUE

 DPR1     LDN    ENIO        NIO *EC* REGISTER
          STM    DPRE
          LDC    SNIO        NIO STATUS REGISTER
          STM    DPRS
          LDD    T1
          LPN    0#1F        ISOLATE JUST PP NUMBER
          LMN    0#20        SET THE AUTO BIT
          STM    DPRF        SAVE PP NUMBER
 DPR2     LDM    I0CC        IOU CONNECT CODE
          STD    EC
          LDN    0
          STD    T4          REGISTER SELECTOR
          STD    T5          BUFFER OFFSET

*         DUMP THE P, A, Q AND K PP REGISTERS.  EACH REGISTER VALUE IS
*         SAVED IN 2 PP WORDS.

 DPR3     LDM    DPRE
          STD    RN
          READMR DPRB        GET *EC* REGISTER
          LDM    DPRB+6      SET REGISTER SELECT
          SCN    3
          LMD    T4
          STM    DPRB+6
          LDD    T1
          SHN    21-10
          PJN    DPR4        IF NIO PP
          LDM    DPRB+4
          SCN    0#1F        CLEAR PP NUMBER
          LMM    DPRF        INSERT PP NUMBER
          STM    DPRB+4      SAVE FOR WRITE
          UJN    DPR5        CONTINUE

 DPR4     LDM    DPRB+4
          SCN    0#3F        CLEAR NIO PP NUMBER
          LMM    DPRF        INSERT PP NUMBER
          STM    DPRB+4
 DPR5     LOCKMR SET
          WRITMR DPRB        WRITE THE *EC* REGISTER WITH PP/REGISTER SELECT
          LDM    DPRS
          STD    RN
          READMR DPRC        READ STATUS REGISTER
          LOCKMR CLEAR
          LDM    DPRC+4
          LPN    3
          STM    DPRR,T5     SAVE UPPER REGISTER VALUE
          LDM    DPRC+5
          SHN    10
          ADM    DPRC+6
          STML   DPRR+1,T5   SAVE LOWER REGISTER VALUE
          LDN    2
          RAD    T5          NEXT BUFFER SLOT
          AOD    T4          NEXT REGISTER
          LPN    4
          ZJP    DPR3        IF MORE REGISTERS

*         LOAD R-REGISTER WITH POINTER TO MEMORY WHERE REGISTERS ARE TO BE SAVED.

          LRD    W5
          RJM    SPB         SET PP BOUNDARY
          LDN    2
          STD    T1          WORD COUNT FOR REGISTER BUFFER SIZE
          LDDL   W4          OFFSET
          LMC    RR
          CWML   DPRR,T1     WRITE REGISTER BUFFER TO OUTPUT SEQUENCE
          LDN    2           UPDATE OFFSET IN R-POINTER
          RADL   W4
          RJM    CIE         CLEAR IOU *EC* REGISTER
          UJP    DPRX        RETURN

 DPRB     BSSZ   10          *EC* REGISTER BUFFER
 DPRC     BSSZ   10          STATUS REGISTER BUFFER
 DPRR     BSSZ   10          OUTPUT REGISTER BUFFER
 DPRE     CON    0           *EC* REGISTER NUMBER
 DPRS     CON    0           STATUS REGISTER NUMBER
 DPRF     CON    0           CIO OR NIO PP NUMBER

*         END CTP$DFT_DUMP_PP_REGISTERS
*DECK DECK=CTP$DFT_DUMP_PP_REGISTERS_930 EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT_DUMP_REGISTERS_930
 DPR      SPACE  4,10
**        DPR - DUMP S0 PP REGISTERS.  THE PP REGISTERS DUMPED ARE P, A, D
*               AND K.
*
*         ENTRY  (PFEA) = PP TYPE AND NUMBER.
*                (W4 - W7) = POINTER TO AREA FOR PP REGISTERS TO BE WRITTEN
*                IN MEMORY, R-POINTER FORMAT.
*
*         EXIT   PP REGISTERS WRITTEN TO SPECIFIED MEMORY.
*                (W4) = OFFSET IN R-POINTER UPDATED TO REFLECT WORDS WRITTEN.
*
*         CALLS  LRP, SPB.
*
*         USES   EC, RN, T1.


 DPR      SUBR               ENTRY/EXIT
          LDM    PPTN        GET PP NUMBER AND TYPE
          LPN    0#1F        ISOLATE PP #
          STD    T1          SAVE PP #
          LDN    I0EC        PP 0 EC REG #
          ADD    T1          ADD PP #
          ADN    I0ST-I0EC   PP 0 STATUS 1 REG #
          STM    DPRSS0
          LDML   I0CC        IOU CONNECT CODE
          STDL   EC

*         DUMP THE P, A, D AND K PP REGISTERS.  EACH REGISTER VALUE IS
*         SAVED IN 2 PP WORDS.

          LDM    DPRSS0      GET PP STATUS 1 REG #
          STD    RN
          READMR DPRC1       READ PP STATUS 1 REG
          LDD    RN          GET PP STATUS 1 REG #
          ADN    40          PP STATUS 2 REG #
          STD    RN
          READMR DPRC2       READ PP STATUS 2 REG
          LDML   DPRC2
          SHN    10
          ADML   DPRC2+1
          STML   DPRRS0+1    P REG
          LDML   DPRC1+3
          SHN    -6
          STML   DPRRS0+2
          LDML   DPRC2+2
          SHN    10
          ADML   DPRC2+3
          STML   DPRRS0+3    A REG
          LDML   DPRC1+1
          LPN    37
          STML   DPRRS0+5    D REG
          LDML   DPRC1+2
          LPC    0#7F
          STML   DPRRS0+7    K REG
          LDML   DPRC1+3
          LPN    37
          STML   DPRRS0+11   S REG

*         LOAD R-REGISTER WITH POINTER TO MEMORY WHERE REGISTERS ARE TO BE SAVED.

          LRD    W5
          LDN    2           S REG NOT DUMPED INITIALLY
          STD    T1          WORD COUNT FOR REGISTER BUFFER SIZE
          LDDL   W4          OFFSET
          LMC    RR
          CWML   DPRRS0,T1   WRITE REGISTER BUFFER TO OUTPUT SEQUENCE
          LDN    2           UPDATE OFFSET IN R POINTER
          RADL   W4
          UJP    DPRX        RETURN

 DPRC1    BSSZ   10          STATUS REGISTER 1 BUFFER
 DPRC2    BSSZ   10          STATUS REGISTER 2 BUFFER
 DPRRS0   BSSZ   14          OUTPUT REGISTER BUFFER
 DPRSS0   CON    0           PP STATUS 1 REGISTER NUMBER

*         END CTP$DFT_DUMP_PP_REGISTERS
*DECK DECK=CTP$DFT_ENVIRONMENT_RTNS EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT_ENVIRONMENT_RTNS
*
*         THIS DECK CONTAINS CODE TO PROCESS
*         ENVIRONMENT AND SHORT WARNINGS

 PEW      SPACE  4,10
**        PEW - PROCESS ENVIRONMENT WARNING.
*
*         CALLS  CIL, CLR, IDA, /PEWQ/ZMR, VCK, *LOG*, *SWI*, *SWP*.


          ROUTINE PEW

          LRD    DP+1
          RJM    SPB         SET PP BOUNDS
          LDN    1
          STM    WARN
          LDN    VER5
          RJM    VCK         CHECK VERSION
          PJP    PEW3        IF VERSION 5 OR GREATER
          LDM    PWEP
          NJP    PEW2        IF ENVIRONMENT ENTRY PRESENT
          RJM    SWA         SET WARNING ENTRY ACTIVE
 PEW1     LDDL   BC+BCDA
          LPC    0#F0FF
          ADC    0#0700      SET ELEMENT ID TO NOT MEANINGFUL
          STDL   BC+BCDA
          LDN    0
          STM    DFTA        NULL ACTION CODE
          RJM    /PEWQ/ZMR
          CALL   SWI
          CALL   LOG
          LDM    FREE
          STM    PWEP
          RJM    CIL         CLEAR INTERLOCK ON THIS ENTRY
          LDN    0
          STM    FREE
          LJM    PEWX        RETURN

 PEW2     RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          CRDL   BC          GET EXISTING BUFFER CONTROL WORD
          CALL   SWI         SET WARNING MAINTENANCE BUFFER ENTRY
          LJM    PEWX        RETURN

 PEW3     LDN    0
          STM    DFTA        NULL DFT ACTION CODE
          RJM    FEI         FORM THE ELEMENT ID REGISTER
          RJM    CWE         CHECK WARNING ENTRY
          ZJP    PEWX        IF THIS WARNING ALREADY SEEN
          RJM    SWA         SET WARNING ENTRY ACTIVE
          LDDL   BC+BCDA
          LPC    0#F0FF
          ADC    0#0700      SET ELEMENT ID TO NOT MEANINGFUL
          STDL   BC+BCDA
          LDN    77
          STM    PWEP        SET POWER WARNING ENTRY ACTIVE
          LDN    NRSP
          RJM    IDA         INCREMENT DFT POINTER  ADDRESS
          CRDL   W0
          LDD    W0
          ADC    NRSBL+RR+1  OFFSET TO *EID* REGISTER PLACEMENT
          LRD    W1
          CWML   MRVAL,ON    WRITE *EID* REGISTER TO SCRATCH NON REGISTER BUFFER
          LDN    1
          STM    RTP1        SET FLAG TO USE NON REGISTER BUFFER
          LDN    NRSBL       NON REGISTER STATUS BUFFER ENTRY BASE LENGTH
          STM    LLOG
          CALL   LOG
          LJM    PEWX        RETURN

 SWI      SPACE  4,10
**        SWI - SET WARNING ENTRY IN MAINTENANCE BUFFER.
*
*         CALLS  IMB, PAC, SPB.
*
*         USES   CM - CM+3, T1, T3.


          ROUTINE SWI

          LRD    DP+1
          RJM    SPB         SET OS BOUNDS
          LDD    EI          ELEMENT ORDINAL
          SHN    -2
          STD    T1
          SHN    2
          RAD    T1
          ADDL   BC+BCOFF
          RJM    IMB
          CRDL   CM
          LDD    EI
          LPN    3
          STD    T3
          LDN    0#10
          STM    CM,T3
          LDD    T1
          ADDL   BC+BCOFF
          RJM    IMB
          CWDL   CM
          RJM    FEI         FORM EID REGISTER
          LDN    1
          ADDL   T1
          ADDL   T3
          ADDL   BC+BCOFF
          RJM    IMB
          CWML   MRVAL,ON    REWRITE ELEMENT ID FOR ELEMENT WITH WARN
          LJM    SWIX        RETURN
          EJECT
 CLW      SPACE  4,10
**        CLW - CLEAR WARNING ENTRY.
*
*         ENTRY  (RTP2) = OFFSET INTO BUFFER CONTROL WORDS.
*                (DP - DP+2) = R-POINTER VALUE.
*
*         USES   T1, T2, CM - CM+3.
*
*         CALLS  CLR, IDA, SET, SPB.


          ROUTINE  CLW

          LDM    RTP2
          STM    CLWA
          LRD    DP+1
          RJM    SPB         SET PP BOUNDS
 CLW1     LDN    BC
          RJM    CLR         CLEAR BC AREA
          LDBC   (BC.FI)
          STDL   BC+BCFLG
          LDM    CLWA
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          RDSL   BC          SET INTERLOCK
          LDDL   BC+BCFLG
          SHN    21-BC.FI
          MJN    CLW1        IF INTERLOCK PREVIOUSLY SET
          LDN    1
          STM    DSIF        DFT HAS SET THE I/L FLAG
          LDN    BC
          RJM    CLR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS), INTERLOCK.
*         DFT ANALYSIS - OS ACTION = WARNING CLEAR.
*                                  = SYSTEM RESUME (VERSION 4).

          SETFLG (BC.FV7,BC.FV8,BC.FL,BC.FI)
          SETOSA OSWC,OSSR
          LDM    CLWA
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          CRDL   CM          GET ASSOC BUFFER CONTROL WORD
          LDDL   CM+BCOA     CLEAR PREVIOUS OS ACTION
          LPC    0#FF00
          LMDL   BC+BCOA     SET NEW OS ACTION
          STDL   CM+BCOA
          LDDL   CM+BCFLG
          LPC    0#FF00      CLEAR OLD FLAGS
          LMDL   BC+BCFLG    SET NEW FLAGS
          STDL   CM+BCFLG
          LDDL   CM+BCDA
          LPC    0#FF        GET OLD ANALYSIS
          STD    T1
          LDN    DALW
          SBD    T1
          NJN    CLW2        IF NOT LONG WARNING
          LDN    DALWC
          UJN    CLW5        PROCESS LONG WARNING

 CLW2     LDN    DALPW
          SBD    T1
          NJN    CLW3        IF NOT LONG POWER WARNING
          LDN    DALPWC
          UJN    CLW5        PROCESS LONG POWER WARNING

 CLW3     LDN    DASPW
          SBD    T1
          NJN    CLW4        IF NOT SHORT POWER WARNING

*         DFT ANALYSIS - OS ACTION = WARNING CLEAR.
*                                  = SYSTEM UNSTEP (VERSION 4).

          SETOSA OSWC,OSSU
          LDDL   CM+BCOA     CLEAR PREVIOUS OS ACTION
          LPC    0#FF00
          LMDL   BC+BCOA     SET NEW OS ACTION
          STDL   CM+BCOA
          LDN    DASWC
          UJN    CLW5        PROCESS SHORT POWER WARNING

 CLW4     LDN    0           ERROR CODE
 CLW5     STD    T2          SAVE ANALYSIS FOR CLEAR CONDITION
          LDDL   CM+BCDA
          LPC    0#FF00      MASK OFF OLD ANALYSIS
          ADD    T2
          STDL   CM+BCDA
          LDM    CLWA
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          CWDL   CM          REWRITE ENTRY WITH CLEAR STATUS
          LDN    CM
          RJM    SET
          LDDL   CM+BCFLG
          LMBC   (BC.FI)
          STDL   CM+BCFLG
          LDM    CLWA
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          RDCL   CM          CLEAR THE INTERLOCK ON THE ENTRY
          LDN    0
          STM    DSIF        DFT HAS CLEARED ITS INTERLOCK ON THE ENTRY

          CHECK  E8
          CHECK  E7

          LDN    0
          STM    VOSD        CLEAR VALID OS DATA ACCUMULATOR
          LJM    CLWX        RETURN

 CLWA     CON    0
 SWA      SPACE  4,10
**        SWA - SET WARNING ACTIVE.
*
*         EXIT   SCRATCH BUFFER CONTROL WORD SET TO LONG WARNING ANALYSIS.
*
*         CALLS  CCA, CLR.


 SWA      SUBR               ENTRY/EXIT
          LDN    BC
          RJM    CLR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = LONG WARNING.
*         DFT ANALYSIS - ERROR PRIORITY = ENVIRONMENT.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180, LOG (OS).
*         DFT ANALYSIS - OS ACTION = ENVIRONMENT WARNING.
*                                  = SYSTEM IDLE/CHECKPOINT (VERSION 4).

          SETDAN (EPEN,DALW)
          SETFLG (BC.FL,BC.FV7,BC.FV8)
          SETOSA OSEW,OSSI
          LDM    BATT        GET IF RUNNING ON BATTERY
          NJN    SWA0        IF USING BATTERY
          RJM    CCA         CHECK IF THE CONSOLE IS ALIVE
          NJP    SWAX        IF CONSOLE OK (OR NOT PRESENT)

*         SET UP SCRATCH BUFFER CONTROL WORD.
*         DFT ANALYSIS - ANALYSIS = LONG POWER WARNING.
*         DFT ANALYSIS - ERROR PRIORITY = ENVIRONMENT.
*         DFT ANALYSIS - OS ACTION = LONG POWER WARNING.
*                                  = SYSTEM IDLE/CHECKPOINT (VERSION 4).

 SWA0     SETDAN (EPEN,DALPW)
          SETOSA OSLPW,OSSI
          LJM    SWAX        RETURN
 FEI      SPACE  4,10
**        FEI - FORM ELEMENT ID REGISTER.
*
*         EXIT   (MRVAL) HOLDS FORMED ELEMENT ID REGISTER.
*
*         NOTE   THE REGISTER IS FORMED FROM A MAINFRAME RECONFIGURATION
*                TABLE ENTRY.


 FEI      SUBR               ENTRY/EXIT
          LDN    0
          STML   MRVAL
          STML   MRVAL+1
          LDML   HBUF+1+EM   MODEL NUMBER
          SHN    -4
          STDL   T2
          LDML   HBUF+1+EN   ELEMENT NUMBER
          SHN    10
          LMDL   T2          ELEMENT NUMBER / MODEL NUMBER
          STML   MRVAL+2
          LDML   HBUF+1+ESU  UPPER PART OF SERIAL NUMBER
          LPN    17
          SHN    14
          LMML   HBUF+1+ELL  LOWER PART OF SERIAL NUMBER
          STML   MRVAL+3
          LDD    ET
          SBN    PROCID
          NJN    FEI1        IF NOT A PROCESSOR
          LDM    CPUO
          ZJN    FEI1        IF PROCESSOR 0
          LDML   MRVAL+2
          LPC    0#FF
          STML   MRVAL+2
          LDN    0#10        SECOND PROCESSOR CODE
          SHN    8D
          LMML   MRVAL+2
          STML   MRVAL+2
          UJP    FEIX        REWRITE ELEMENT ID

 FEI1     LDD    ET
          SBN    IOUID
          NJP    FEIX        IF NOT AN IOU
          LDM    IOUO
          ZJP    FEIX        IF IOU0
          LDML   MRVAL+2
          LPC    0#FF
          STML   MRVAL+2
          LDN    0#10        SECOND IOU CODE
          SHN    8D
          LMML   MRVAL+2
          STML   MRVAL+2
          UJP    FEIX        RETURN
 SWP      SPACE  4,10
**        SWP - SHORT WARNING PROCESSOR.
*
*         CALLS  CIL, CLR, IDA, SPB, VCK, /PEWQ/ZMR, *LOG*, *SWI*.


          ROUTINE SWP

          LRD    DP+1
          RJM    SPB         SET PP OS BOUNDS
          LDN    1
          STM    SHRR        SHORT WARNING ERROR
          STM    WARN
          LDN    VER5
          RJM    VCK         CHECK VERSION
          PJP    SWP4        IF VERSION 5
          LDM    SWEP        EXISTING SHORT WARNING ENTRY OFFSET
          NJP    SWP3        IF EXISTING ENTRY
          LDN    BC
          RJM    CLR

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = SHORT POWER WARNING.
*         DFT ANALYSIS - ERROR PRIORITY = SHORT WARNING.
*         DFT ANALYSIS - FLAGS = LOGGING, VALID 170, VALID 180.
*         DFT ANALYSIS - OS ACTION = SHORT POWER WARNING.
*                                  = SYSTEM STEP (VERSION 4).

          SETDAN (EPSW,DASPW)
          SETFLG (BC.FL,BC.FV7,BC.FV8)
          SETOSA OSSPW,OSSS
          LDN    0           SET NULL ACTION CODE
          STM    DFTA
          RJM    /PEWQ/ZMR   ZERO MAINTENANCE REGISTER BUFFER
          LDDL   BC+BCDA
          LPC    0#F0FF
          LMC    0#0700      SET ELEMENT ID TO NOT MEANINGFUL
          STDL   BC+BCDA
          CALL   SWI         SET WARNING ENTRY
          CALL   LOG
          LDM    FREE
          STM    SWEP        SET UP SHORT WARNING ENTRY OFFSET
          RJM    CIL         CLEAR INTERLOCK ON THIS ENTRY
          LDN    0
          STM    FREE
          LJM    SWPX        RETURN

 SWP3     RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          CRDL   BC          GET EXISTING BUFFER CONTROL WORD
          CALL   SWI         UPDATE EXISTING ENTRY
          LJM    SWPX        RETURN

 SWP4     LDN    0           SET NULL ACTION CODE
          STM    DFTA
          RJM    FEI         FORM THE ELEMENT ID REGISTER
          RJM    CWE         CHECK WARNING ENTRY
          ZJP    SWPX        IF THIS WARNING ALREADY SEEN

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = SHORT POWER WARNING.
*         DFT ANALYSIS - ERROR PRIORITY = SHORT WARNING.
*         DFT ANALYSIS - FLAGS = LOGGING, VALID 170, VALID 180.
*         DFT ANALYSIS - OS ACTION = SHORT POWER WARNING.
*                                  = SYSTEM STEP (VERSION 4).

          SETDAN (EPSW,DASPW)
          SETFLG (BC.FL,BC.FV7,BC.FV8)
          SETOSA OSSPW,OSSS
          LDDL   BC+BCDA
          LPC    0#F0FF
          LMC    0#0700      SET ELEMENT ID TO NOT MEANINGFUL
          STDL   BC+BCDA
          LDN    NRSP
          RJM    IDA         INCREMENT DFT POINTER  ADDRESS
          CRDL   W0
          LDD    W0
          ADC    NRSBL+RR+1  OFFSET TO *EID* REGISTER PLACEMENT
          LRD    W1
          CWML   MRVAL,ON    WRITE *EID* REGISTER TO SCRATCH NON REGISTER BUFFER
          LDN    1
          STM    RTP1        SET FLAG TO USE NON REGISTER BUFFER
          LDN    NRSBL
          STM    LLOG
          CALL   LOG
          LJM    SWPX        RETURN
 CLI      SPACE  4,10
**        CLI - CLEAR INTERLOCK ON ENTRY.
*
*         ENTRY  (FREE) = INDEX OF BUFFER CONTROL WORD INTERLOCK TO CLEAR.
*
*         USES   T3.
*
*         CALLS  IDA, SET.


 CIL      SUBR               ENTRY/EXIT
          LDM    FREE
          STD    T3
          LDN    CM
          RJM    SET
          LDDL   CM+BCFLG
          LMBC   (BC.FI)
          STDL   CM+BCFLG
          LDD    T3
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          RDCL   CM          CLEAR INTERLOCK
          LDN    0
          STM    DSIF        DFT HAS CLEARED ITS INTERLOCK ON THE ENTRY

*         IF C180 ERROR OR NOSVE LOGGING OR VALID C180 ERROR SET
*         C180 ERROR IN DFT HEADER.

          CHECK  E8

*         IF C170 ERROR OR NOS/NOSBE LOGS OR VALID C170 ERROR SET
*         C170 ERROR IN DFT HEADER.

          CHECK  E7

          LDN    0
          STM    VOSD        CLEAR VALID OS DATA ACCUMULATOR
          LJM    CILX        RETURN
CWE       SPACE  4,10
**        CWE - CHECK WARNING ENTRY.
*
*         ENTRY  (MRVAL - MRVAL+3) = EID REGISTER TO CHECK.
*
*         EXIT   (A) = 0 = ENTRY ALREADY LOGGED AND PENDING.
*                (A) <> 0 IMPLIES ENTRY NOT SEEN.
*
*         CALLS  GBE.
*
*         USES   RTP2


 CWE0     LDN    1           NOT SEEN CONDITION
 CWE      SUBR               ENTRY/EXIT
          LDN    1
          STM    RTP1
          LDM    NNRB        NUMBER OF NON REGISTER BUFFERS
          STM    RTP2
 CWE1     RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          CRML   CWEB,ON
          LDML   CWEB+1      GET DFT ANALYSIS
          SHN    -BC.ANP
          SBN    EPEN
          MJP    CWE2        IF NOT AN ENVIRONMENT ENTRY
          LDML   CWEB+1
          LPN    0#F
          SBN    4
          PJP    CWE2        IF WARNING BUT ALREADY CLEARED
          LDML   RTP2
          RJM    IBW
          ADN    NRSBL
          CRML   CWEA,ON     READ IN EID REGISTER
          LDML   MRVAL
          LMML   CWEA
          NJP    CWE2        IF NO MATCH
          LDML   CWEA+1
          LMML   MRVAL+1
          NJN    CWE2        IF NO MATCH
          LDML   CWEA+2
          LMML   MRVAL+2
          NJN    CWE2        IF NO MATCH
          LDML   CWEA+3
          LMML   MRVAL+3
          NJP    CWE2        IF NO MATCH
          UJP    CWEX        RETURN

 CWE2     SOM    RTP2
          NJP    CWE1        IF NOT DONE WITH SEARCH
          UJP    CWE0        RETURN WITH NOT FOUND

 CWEA     BSSZ   4           EID REGISTER IN NRSB
 CWEB     BSSZ   4           DFT ANALYSIS IN NRSB
          QUAL   PEWQ
 ZMR      SPACE  4,10
**        ZMR - ZERO MAINTENANCE REGISTER BLOCK 0.
*
*         USES   T1.
*
*         CALLS  IMB.


 ZMR      SUBR               ENTRY/EXIT
          LDN    0
          STD    T1
 ZMR1     LDD    T1
          RJM    IMB
          CWML   ZERO,ON
          AOD    T1
          SBM    LBUF
          PJN    ZMRX        IF DONE
          UJN    ZMR1        LOOP

 ZERO     BSSZ   4
          QUAL   *

*         END OF CTP$DFT_ENVIRONMENT_RTNS
*DECK DECK=CTP$DFT_ERROR_CONTROL EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT_ERROR_CONTROL
*
*         THIS DECK CONTAINS CODE TO PROCESS
*         VARIOUS DIFFERENT ERROR CONTROLS ON DFT

 CFF      SPACE  4,10
**        CFF - CHECK IF FREEZE FLAG SET.
*
*         CALLS  FHE, IDA, *HAP*, *SAP*.


          ROUTINE CFF
          LDN    0
          STM    RTP2
          LDN    VER5
          RJM    VCK         CHECK VERSION
          PJP    CFF9        IF VERSION 5 OR GREATER
          LDN    HDRP
          RJM    IDA
          CRDL   CM          GET DFT HEADER
          LDDL   CM+DHFLG
          LPBC   (DH.FFC,DH.FFU)
          ZJP    CFFX        IF NEITHER FLAG SPECIFIED
          LDDL   CM+DHFLG
          LPBC   (DH.FFC)
          ZJN    CFF2        IF FREEZE ON CORRECTED ERROR NOT SET
          LDM    SUMS
          LPBC   (SSCE)
          ZJN    CFF2        IF ENTRY NOT A CORRECTED ERROR
          CALL   HAP         HALT ALL PROCESSORS
 CFF1     LDN    HDRP
          RJM    IDA
          CRDL   CM          GET HEADER
          LDDL   CM+DHFLG
          SHN    21-DH.FFC
          MJN    CFF1        IF FREEZE ON CORRECTED ERROR FLAG SET
          UJN    CFF4        START PROCESSORS

 CFF2     LDDL   CM+DHFLG
          LPBC   (DH.FFU)
          ZJP    CFF7        IF FREEZE ON UNCORRECTED NOT SET
          LDM    SUMS
          LPBC   (SSUE)
          ZJN    CFF7        IF ENTRY NOT UNCORRECTED ERROR
          CALL   HAP         HALT ALL PROCESSORS
 CFF3     LDN    HDRP
          RJM    IDA
          CRDL   CM          GET DFT HEADER
          LDDL   CM+DHFLG
          SHN    21-DH.FFU
          MJN    CFF3        IF FREEZE ON UNCORRECTED ERROR FLAG SET
 CFF4     CALL   SAP         START ALL PROCESSORS
          LDD    ET
          SBN    PROCID
          NJN    CFF5        IF NOT A PROCESSOR
          LDM    CPUH        GET THE HALTED PROCESSOR ORDINAL
          SHN    14
          UJN    CFF6        CHECK ELEMENT

 CFF5     LDN    0           ALL OTHERS ARE ZERO
 CFF6     LMD    ET          TYPE OF ELEMENT PREVIOUSLY WORKING ON
          RJM    FHE
          MJN    CFF8        IF CANT FIND WHAT WE WERE DOING
 CFF7     LJM    CFFX        RETURN

 CFF8     SETDAN (EPUN,DAME)
          LDC    DAME+TDFT   613 - DFT NO DESC IN MRT
          STM    RTP1
          CALL   ERRH

 CFF9     BSS    0           VERSION 5 PROCESSING
          LDN    ECRP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0
          LDDL   W0
          LRD    W1
          ADC    RR
          CRDL   W0          READ IN CONTROL FLAGS
          LDDL   W1
          LPN    1
          ZJP    CFFX        IF NO SPECIAL PROCESSING
          RJM    CET         CONVERT ELEMENT TYPE
          RJM    GEE         GET ELEMENT ENTRY IN ERROR CONTROL RECORD
          MJP    CFF29       IF ENTRY NOT FOUND
          STM    CFFC        SAVE ENTRY OFFSET
          LDDL   CM+1        GET ACTION INDEX
          STD    T2
          LDM    CFFA,T2
          STD    T2
          LJM    0,T2        PROCESS ACTION CODE

 CFF10    LJM    CFFX

 CFF11    LDN    1
          STM    RTP2        SET TO IGNORE ERROR HANDLING
          UJN    CFF10

 CFF12    CALL   HAP
 CFF12.1  LDN    ECRP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0          READ IN POINTER WORD
          LDDL   W0
          LRD    W1
          ADC    RR
          CRDL   W0          READ IN ECR HEADER
          LDDL   W1
          LPN    2
          ZJN    CFF12.1     IF NO UPDATE REQUIRED
          CALL   SAP
          RJM    ROE         RESTORE ORIGINAL ELEMENT

          UJP    CFFX

 CFF12.5  LDM    SUMS
          LPBC   (SSUE,SSCE)
          NJP    CFF12       IF ANY ERROR
          UJP    CFF10

 CFF13    LDM    SUMS        SUMMARY STATUS
          LPBC   (SSCE)
          ZJP    CFF10       IF NOT CORRECTED ERROR
          UJP    CFF12

 CFF14    LDM    SUMS        SUMMARY STATUS
          LPBC   (SSUE)
          ZJP    CFF10       IF NOT UNCORRECTED ERROR
          UJP    CFF12

 CFF15    LDM    SUMS        SUMMARY STATUS
          LPBC   (SSCE)
          ZJP    CFF10       IF NOT CORRECTED ERROR
          UJP    CFF11

 CFF16    LDM    SUMS
          LPBC   (SSUE)
          ZJP    CFF10       IF NOT UNCORRECTED ERROR
          UJP    CFF11

 CFF17    RJM    GR1         GET R1 REGISTER
          LDN    0
          RJM    CBR         CHECK BIT RANGE
          ZJP    CFF10       IF NOT IN RANGE
          UJP    CFF12

 CFF18    RJM    GR1         GET R1 REGISTER
          LDN    0
          RJM    CSB         CHECK FOR SPECIFIC BITS SET
          NJP    CFF10       IF SPECIFIC BITS NOT SET
          UJP    CFF12

 CFF19    RJM    GR1         GET R1 REGISTER
          RJM    GR2         GET R2 REGISTER
          LDN    0
          RJM    CBR         CHECK BIT RANGE
          ZJP    CFF10       IF NOT IN RANGE
          LDN    1
          RJM    CBR         CHECK BIT RANGE
          ZJP    CFF10       IF NOT IN RANGE
          UJP    CFF12

 CFF20    RJM    GR1         GET R1 REGISTER
          RJM    GR2         GET R2 REGISTER
          LDN    0
          RJM    CBR         CHECK BIT RANGE
          ZJP    CFF10       IF NOT IN RANGE
          LDN    1
          RJM    CSB         CHECK SPECIFIC BITS
          NJP    CFF10       IF SPECIFIC BITS NOT SET
          UJP    CFF12

 CFF21    RJM    GR1         GET R1 REGISTER
          RJM    GR2         GET R2 REGISTER
          LDN    0
          RJM    CSB         CHECK FOR SPECIFIC BIT
          NJP    CFF10       IF NOT SET
          LDN    1
          RJM    CBR         CHECK BIT RANGE
          ZJP    CFF10       IF NOT SET
          UJP    CFF12

 CFF22    RJM    GR1         GET R1 REGISTER
          RJM    GR2         GET R2 REGISTER
          LDN    0
          RJM    CSB         CHECK SPECIFIC BITS
          NJP    CFF10       IF NOT SET
          LDN    1
          RJM    CSB         CHECK SPECIFIC BITS
          NJP    CFF10       IF NOT SET
          UJP    CFF12

 CFF23    RJM    GR1         GET R1 REGISTER
          RJM    GR2         GET R2 REGISTER
          LDN    0
          RJM    CBR         CHECK BIT RANGE
          ZJP    CFF10       IF NOT IN RANGE
          LDN    1
          RJM    CBR         CHECK BIT RANGE
          ZJP    CFF10       IF NOT IN RANGE
          UJP    CFF11

 CFF24    RJM    GR1         GET R1 REGISTER
          RJM    GR2         GET R2 REGISTER
          LDN    0
          RJM    CBR         CHECK BIT RANGE
          ZJP    CFF10       IF NOT IN RANGE
          LDN    1
          RJM    CSB         CHECK SPECIFIC BITS
          NJP    CFF10       IF NOT SET
          UJP    CFF11

 CFF25    RJM    GR1         GET R1 REGISTER
          RJM    GR2         GET R2 REGISTER
          LDN    0
          RJM    CSB         CHECK SPECIFIC BIT
          NJP    CFF10       IF NOT SET
          LDN    1
          RJM    CBR         CHECK BIT RANGE
          ZJP    CFF10       IF NOT IN RANGE
          UJP    CFF11

 CFF26    RJM    GR1         GET R1 REGISTER
          RJM    GR2         GET R2 REGISTER
          LDN    0
          RJM    CSB         CHECK FOR SPECIFIC BITS
          NJP    CFF10       IF NOT SET
          LDN    1
          RJM    CSB         CHECK FOR SPECIFIC BITS
          NJP    CFF10       IF NOT SET
          UJP    CFF11

 CFF27    RJM    GR1         GET R1 REGISTER
          LDN    0
          RJM    CBR         CHECK BIT RANGE
          ZJP    CFF10       IFF NOT IN RANGE
          UJP    CFF11

 CFF28    RJM    GR1         GET R1 REGISTER
          LDN    0
          RJM    CSB         CHECK SPECIFIC BITS
          NJP    CFF10       IF NOT SET
          UJP    CFF11

*         DFT ANALYSIS - ILLEGAL ELEMENT SPECIFIED ON ERROR CONTROL.
*         DFT FLAGS - LOGGING.

 CFF29    SETDAN (EPUN,DAIE)
          SETFLG (BC.FL)
          LDN    CM
          RJM    CLR
          LDD    T1          GET BAD ELEMENT ID
          STDL   CM
          LDN    NRSP
          RJM    IDA
          CRDL   W0          READ IN NON REGISTER BUFFER POINTER
          LRD    W1
          LDDL   W0
          ADC    RR+NRSBL+1
          CWDL   CM          WRITE REQUEST RESPONSE TO SCRATCH BUFFER
          LDN    NRSBL
          STML   LLOG
          LDN    1
          STML   RTP1
          CALL   LOG
          LJM    CFFX        RETURN

 CFFA     CON    CFFX
          CON    CFF11
          CON    CFF12.5
          CON    CFF13
          CON    CFF14
          CON    CFF15
          CON    CFF16
          CON    CFF17
          CON    CFF18
          CON    CFF19
          CON    CFF20
          CON    CFF21
          CON    CFF22
          CON    CFF23
          CON    CFF24
          CON    CFF25
          CON    CFF26
          CON    CFF27
          CON    CFF28

 CFFC     CON    0           CURRENT ENTRY
 CFFD     BSSZ   4           R1 REGISTER
 CFFE     BSSZ   4           R2 REGISTER
 ROE      SPACE  4,10
**        ROE - RESTORE ORIGINAL ELEMENT.
*
*         EXIT   (HBUF) HOLDS THE ORIGINAL ELEMENT WHICH CAUSED THE ACTION.

 ROE      SUBR               ENTRY/EXIT
          LDD    ET
          SBN    PROCID
          NJN    ROE2        IF NOT CPU
          LDM    CPUO
          SHN    14
          ADN    PROCID
 ROE1     RJM    FHE         RE READ THE ELEMENT
          MJP    ROE5        IF ERROR FINDING ELEMENT
          UJP    ROEX

 ROE2     LDD    ET
          SBN    IOUID
          NJN    ROE3        IF NOT IOU
          LDM    IOUO
          SHN    14
          ADN    IOUID
          UJN    ROE1

 ROE3     LDD    ET
          SBN    CMID
          NJN    ROE4        IF NOT CENTRAL MEMORY
          LDN    CMID
          UJP    ROE1

 ROE4     LDD    ET
          SBN    PMID
          NJN    ROE5        IF NOT PAGE MAP
          LDN    PMID
          UJP    ROE1

*         DFT ANALYSIS - ERROR PROCESSING ERROR CONTROL RECORD.
*         DFT FLAGS - LOGGING.

 ROE5     SETDAN (EPUN,DAEP)
          SETFLG (BC.FL)
          LDN    CM
          RJM    CLR
          LDD    ET          GET ELEMENT TYPE
          STDL   CM+1
          LDN    NRSP
          RJM    IDA
          CRDL   W0          READ IN NON REGISTER BUFFER POINTER
          LRD    W1
          LDDL   W0
          ADC    RR+NRSBL+1
          CWDL   CM          WRITE REQUEST RESPONSE TO SCRATCH BUFFER
          LDN    NRSBL
          STML   LLOG
          LDN    1
          STML   RTP1
          CALL   LOG
          LJM    ROEX        RETURN
 GEE      SPACE  4,10
**        GEE - GET ELEMENT ENTRY.
*
*         ENTRY  (A) = ID OF ENTRY TO FIND.
*
*         EXIT   (A) = CURRENT POSITION OF ENTRY.
*                (A) < 0 = ENTRY NOT FOUND.
*                (W0 - W3) = POINTER TO ERROR CONTROL RECORD.
*                (CM - CM+3) = ENTRY HEADER WORD.


 GEE0     LDM    GEEA
 GEE      SUBR               ENTRY/EXIT
          STD    T1          SAVE ID OF ENTRY
          LDN    ECRP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0          POINTER ADDRESS
          LRD    W1
          LDD    W0
          ADC    RR
          CRML   GEEB,ON     HEADER WORD
 GEE1     LDM    GEEA
          ADD    W0
          ADC    RR
          CRDL   CM          GET ID WORD
          LDDL   CM
          LPC    0#FF
          SBD    T1          ID TO SEARCH FOR
          ZJN    GEE0        IF FOUND THE ENTRY
          LDM    GEEB+2
          RAML   GEEA        GET TO NEXT ENTRY
          SBD    W3
          PJP    GEE2        IF AT END OF TABLE
          UJP    GEE1

 GEE2     LCN    0
          UJP    GEEX

 GEEA     CON    1
 GEEB     BSS    4
 CET      SPACE  4,10
**        CET - CONVERT ELEMENT TYPE.
*
*         EXIT   (A) = ELEMENT ID TO SEARCH FOR.
*
*         USES   T1.


 CET      SUBR               ENTRY/EXIT
          LDD    ET
          STD    T1
          SBN    PROCID
          NJN    CET1        IF NOT PROCESSOR
          LDM    CPUO
          SHN    4
          STM    CETA        SAVE ORDINAL PORTION OF ID
          UJN    CET2

 CET1     LDD    T1
          SBN    IOUID
          NJN    CET2        IF NOT IOU
          LDM    IOUO
          SHN    4
          STM    CETA        SAVE ORDINAL PORTION OF ID
 CET2     LDM    ETYP,T1
          LMML   CETA        FORM COMPLETE ID
          UJN    CETX        RETURN

 CETA     CON    0

*COPY CTC$DFT_ELEMENT_CONVERSIONS


 GCC      SPACE  4,10
**        GCC - GET CONNECT CODE.
*
*         ENTRY  (A) = ELEMENT TYPE.
*
*         EXIT   (A) = CONNECT CODE.


 GCC      SUBR               ENTRY/EXIT
          STD    T1
          LDN    PROCID
          SBD    T1
          NJN    GCC2        IF NOT PROCESSOR
          LDM    CPUO
          NJN    GCC1        IF CPU 1
          LDML   CP0CC
          UJN    GCCX        RETURN

 GCC1     LDML   CP1CC
          UJN    GCCX        RETURN

 GCC2     LDN    IOUID
          SBD    T1
          NJN    GCC3        IF NOT IOU
          LDML   I0CC
          UJN    GCCX        RETURN

 GCC3     LDN    CMID
          SBD    T1
          NJN    GCC4        IF NOT MEMORY
          LDML   CMCC
          UJN    GCCX

 GCC4     LDML   S0PMC       PAGE MAP CONNECT CODE
          UJP    GCCX        RETURN

 CBR      SPACE  4,10
**        CBR - CHECK BIT RANGE.
*
*         ENTRY  (A) = 0 = USE R1 REGISTER DATA.
*                (A) = 1 = USE R2 REGISTER DATA.
*
*         EXIT   (A) <> 0 BIT RANGE MET.
*                (A) = 0 BIT RANGE CONDITION NOT MET.


 CBR      SUBR               ENTRY/EXIT
          STD    T1
          LDN    ECRP
          RJM    IDA
          CRDL   W0          POINTER WORD
          LDD    T1
          NJP    CBR1
          LDDL   W0
          ADM    CFFC        ENTRY OFFSET
          ADC    RR+3
          LRD    W1
          CRML   CBRA,ON     R1 REGISTER
          LDML   CFFD
          LPML   CBRA
          NJP    CBRX        RETURN
          LDML   CFFD+1
          LPML   CBRA+1
          NJP    CBRX
          LDML   CFFD+2
          LPML   CBRA+2
          NJP    CBRX
          LDML   CFFD+3
          LPML   CBRA+3
          UJP    CBRX

 CBR1     LDDL   W0
          ADM    CFFC        ENTRY OFFSET
          ADC    RR+5
          LRD    W1
          CRML   CBRA,ON     R2 REGISTER
          LDML   CFFE
          LPML   CBRA
          NJP    CBRX        RETURN
          LDML   CFFE+1
          LPML   CBRA+1
          NJP    CBRX
          LDML   CFFE+2
          LPML   CBRA+2
          NJP    CBRX
          LDML   CFFE+3
          LPML   CBRA+3
          UJP    CBRX

 CBRA     BSS    4
 CSB      SPACE  4,10
**        CSB - CHECK SPECIFIC BIT.
*
*         ENTRY  (A) = 0 = USE R1 REGISTER DATA.
*                (A) = 1 = USE R2 REGISTER DATA.
*
*         EXIT   (A) <> 0 SPECIFIC BIT CONDITION NOT MET.
*                (A) = 0 SPECIFIC BIT CONDITION MET.


 CSB      SUBR               ENTRY/EXIT
          STD    T1
          LDN    ECRP
          RJM    IDA
          CRDL   W0          POINTER WORD
          LDD    T1
          NJP    CSB1        IF TO R2 REGISTER
          LDDL   W0
          ADM    CFFC        ENTRY OFFSET
          ADC    RR+3
          LRD    W1
          CRML   CSBA,ON     R1 REGISTER
          LDML   CFFD
          LMML   CSBA
          NJP    CSBX        RETURN
          LDML   CFFD+1
          LMML   CSBA+1
          NJP    CSBX
          LDML   CFFD+2
          LMML   CSBA+2
          NJP    CSBX
          LDML   CFFD+3
          LMML   CSBA+3
          UJP    CSBX

 CSB1     LDDL   W0
          ADM    CFFC        ENTRY OFFSET
          ADC    RR+5
          LRD    W1
          CRML   CSBA,ON     R2 REGISTER
          LDML   CFFE
          LMML   CSBA
          NJP    CSBX        RETURN
          LDML   CFFE+1
          LMML   CSBA+1
          NJP    CSBX
          LDML   CFFE+2
          LMML   CSBA+2
          NJP    CSBX
          LDML   CFFE+3
          LMML   CSBA+3
          UJP    CSBX

 CSBA     BSS    4
 GR1      SPACE  4,10
**        GR1 - GET R1 REGISTER.
*
*         ENTRY  - (CM - CM+3) = ENTRY HEADER WORD.
*
*         EXIT   - (CFFD - CFFD+3) R1 REGISTER WITH MASK APPLIED.
*
*         CALLS  GCC, IDA, PAC, *READMR*.
*
*         USES   EC, RN, W0 - W3.


 GR1      SUBR               ENTRY/EXIT
          LDDL   CM+2        GET R1
          STD    RN
          LDDL   CM          GET ID
          LPN    0#F
          STD    T1
          LDML   ETYP,T1    CONVERT TO CTI BASED ID
          RJM    GCC         GET CONNECT CODE
          STDL   EC
          READMR RDATA       READ REGISTER CONTENTS
          RJM    PAC         PACK TO *MRVAL*
          LDN    ECRP
          RJM    IDA
          CRDL   W0          POINTER WORD
          LDDL   W0
          ADM    CFFC        ENTRY POSITION IN ERROR CONTROL RECORD
          LRD    W1
          ADC    RR+2
          CRML   CFFD,ON     READ IN M1 MASK
          LDML   MRVAL
          LPML   CFFD
          STML   CFFD
          LDML   MRVAL+1
          LPML   CFFD+1
          STML   CFFD+1
          LDML   MRVAL+2
          LPML   CFFD+2
          STML   CFFD+2
          LDML   MRVAL+3
          LPML   CFFD+3
          STML   CFFD+3
          UJP    GR1X
 GR2      SPACE  4,10
**        GR2 - GET R2 REGISTER.
*
*         ENTRY  - (CM - CM+3) = ENTRY HEADER WORD.
*
*         EXIT   - (CFFE - CFFE+3) R2 REGISTER WITH MASK APPLIED.
*
*         CALLS  GCC, IDA, PAC, *READMR*.
*
*         USES   EC, RN, W0 - W3.


 GR2      SUBR               ENTRY/EXIT
          LDDL   CM+3        GET R2
          STD    RN
          LDDL   CM          GET ID
          LPN    0#F
          STD    T1
          LDML   ETYP,T1    CONVERT TO CTI BASED ID
          RJM    GCC         GET CONNECT CODE
          STDL   EC
          READMR RDATA       READ REGISTER CONTENTS
          RJM    PAC         PACK TO *MRVAL*
          LDN    ECRP
          RJM    IDA
          CRDL   W0          POINTER WORD
          LDDL   W0
          ADM    CFFC        ENTRY POSITION IN ERROR CONTROL RECORD
          LRD    W1
          ADC    RR+4
          CRML   CFFE,ON     READ IN M2 MASK
          LDML   MRVAL
          LPML   CFFE
          STML   CFFE
          LDML   MRVAL+1
          LPML   CFFE+1
          STML   CFFE+1
          LDML   MRVAL+2
          LPML   CFFE+2
          STML   CFFE+2
          LDML   MRVAL+3
          LPML   CFFE+3
          STML   CFFE+3
          UJP    GR2X

 UER      SPACE  4,10
**        UER - UPDATE ERROR CONTROL RECORD.
*
*         CALLS  ECM, *FINDCM*, IDA, UED.
*
*         USES   CALB, T1, T2, W0 - W7.

          ROUTINE UER
          LJM    UER1        FOR 1.4.1 DONT MAKE 2AP REQUESTS UNILATERALLY
          LDC    0#210       READ CDA FUNCTION
          STML   CALB
          LDC    0503
          STML   CALB+1
          LDC    2200
          STML   CALB+2
          RJM    ECM         EXECUTE CIP MODULE
          LDML   CALB+1
          SBN    4
          MJP    UER5        IF 2AP ERROR
          LDM    CPU0M
          SHN    -4
          LMN    5
          NJN    UER1        IF NOT S0
          LDML   TOUB
          ADC    24+H77TBLP
          UJN    UER2

 UER1     LDML   TOUB
          ADC    H77TBLP
 UER2     STML   UERA
          STML   UERB
          STML   UERC
          LDN    ECRP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W4
          FINDCM ECR
          ADN    2           SKIP HEADER WORDS
          CRML   **,W7       READ IN ECR FROM EI BUFFER AREA
 UERA     EQU    *-1
          LDDL   W4
          LRD    W5
          ADC    RR
          CWML   **,W7       WRITE TO ECR IN DFT STRUCTURE
 UERB     EQU    *-1
          RJM    CSP         CHECK FOR SPECIAL PROCESSING
          NJN    UER3        IF SPECIAL PROCESSING
          LDN    0
          STDL   T1
          UJN    UER4

 UER3     LDN    1
          STDL   T1          SET SPECIAL PROCESSING
 UER4     LDN    ECRP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0
          LDDL   W0
          LRD    W1
          ADC    RR
          CRDL   W4          READ IN CONTROL FLAGS
          LDDL   W5
          LPC    0#FFFC
          LMDL   T1
          STDL   W5
          LDDL   W0
          ADC    RR
          CWDL   W4          REWRITE CONTROL FLAGS
          LDDL   W0
          ADC    RR
          CRML   **,W7       READ ECR BACK INTO PP MEMORY
 UERC     EQU    *-1
*         CALL   UED         UPDATE THE DISK BUT NOT FOR 1.4.1 UNILATERALLY
          UJP    UERX        RETURN

*         DFT ANALYSIS - ERROR UPDATING ERROR CONTROL RECORD.
*         DFT FLAGS - LOGGING.

 UER5     SETDAN (EPUN,DAUE)
          SETFLG (BC.FL)
          LDN    CM
          RJM    CLR
          LDML   CALB+1      GET 2AP RESPONSE
          STDL   CM+1
          LDN    NRSP
          RJM    IDA
          CRDL   W0          READ IN NON REGISTER BUFFER POINTER
          LRD    W1
          LDDL   W0
          ADC    RR+NRSBL+1
          CWDL   CM          WRITE REQUEST RESPONSE TO SCRATCH BUFFER
          LDN    NRSBL
          STML   LLOG
          LDN    1
          STML   RTP1
          CALL   LOG
          LJM    UERX        RETURN
 UED      SPACE  4,10
**        UED - UPDATE ERROR CONTROL RECORD ON DISK.
*
*         CALLS  LOG, PFC.
*
*         USES   CALB.


          ROUTINE UED
          LDC    3120        WRITE 16 BIT CDA SECTOR FUNCTION FOR CTI
          STML   CALB
          LDC    0503
          STML   CALB+1      FIRST PART OF NAME
          LDC    2200
          STML   CALB+2      LAST PART OF NAME
          LDC    360
          STML   CALB+3      LENGTH OF SECTOR
          CALL   PFC         PREPARE FOR 2AP CALL
          LDML   CALB+1
          ZJP    UEDX        IF NO ERRORS
          SBN    76+1
          PJP    UEDX        IF NO ERRORS

*         DFT ANALYSIS - ERROR UPDATING ERROR CONTROL RECORD.
*         DFT FLAGS - LOGGING.

          SETDAN (EPUN,DAUE)
          SETFLG (BC.FL)
          LDN    CM
          RJM    CLR
          LDML   CALB+1      GET 2AP RESPONSE
          STDL   CM+1
          LDN    NRSP
          RJM    IDA
          CRDL   W0          READ IN NON REGISTER BUFFER POINTER
          LRD    W1
          LDDL   W0
          ADC    RR+NRSBL+1
          CWDL   CM          WRITE REQUEST RESPONSE TO SCRATCH BUFFER
          LDN    NRSBL
          STML   LLOG
          LDN    1
          STML   RTP1
          CALL   LOG
          LJM    UEDX        RETURN

 CSP      SPACE  4,10
**        CSP - CHECK FOR DFT SPECIAL PROCESSING.
*
*         EXIT   (A) <> 0 IF SPECIAL PROCESSING REQUIRED.
*
*         USES   CM - CM+3, T1 - T4, W0 - W7.


 CSP      SUBR               ENTRY/EXIT
          LDN    ECRP
          RJM    IDA
          CRDL   W0          POINTER TO ECR
          LDDL   W0
          LRD    W1
          ADC    RR
          CRDL   CM          GET HEADER TO ECR
          LDDL   W0
          ADC    RR
          CRDL   W4          HEADER TO ECR
          AODL   W0
 CSP1     LDDL   W0
          ADC    RR
          CRDL   T1          GET ID/ACTION WORD
          LDDL   T2
          NJN    CSPX        IF SOME ACTION SPECIFIED
          LDDL   CM+2
          RADL   W0
          SODL   CM+3
          NJN    CSP1        IF MORE TO EXAMINE
          LDN    0
          UJP    CSPX        RETURN


*         END CTP$DFT_ERROR_CONTROL
*DECK DECK=CTP$DFT_FIND_CONTROL_WORD EXPAND=FALSE
*         CTEXT  CTP$DFT_FIND_CONTROL_WORD
 FCW      SPACE  4,10
**        FCW - FIND CONTROL WORD.
*
*         IF AN ENTRY IS OVERWRITTEN BY A HIGHER PRIORITY ERROR
*         THAT ENTRY-S UNLOGGED ERROR COUNTER WILL BE UPDATED.
*
*         IF ENOUGH (>4) BUFFERS ARE DEFINED THIS ROUTINE WILL SET ASIDE
*         THE FIRST TWO BUFFERS FOR TOP OF HOUR STATISTICS PROCESSING.
*         THIS IS SO THAT THESE ENTRIES DONT FILL THE BUFFER AND DESTROY
*         ACCUMULATED ERROR HISTORY.
*
*         ENTRY  (RTP1) = 0 IF TO USE BUFFER CONTROL WORDS
*                       = 1 IF TO USE NON REGISTER STATUS BUFFER

*         EXIT   (LOGB) <> 0 OFFSET OF OBTAINED ENTRY.
*                (LOGB) = 0 ENTRY NOT OBTAINABLE.
*
*         USES   T1, T2, T3, T4, T5, T6, T7, CM - CM+3, W0 - W0+3, *LOGB*.
*
*         CALLS  CHF, CLR, IDA.


 FCW      SUBR               ENTRY/EXIT
          LDM    RTP1
          ZJN    FCW0        IF USING BUFFER CONTROL WORDS
          LDN    3
          STD    T4          START WITH THIRD ENTRY IN NRSB
          LDML   NNRB
          SBN    4           MINUS SCRATCH AND RESERVED ENTRIES
          STDL   T1
          LDDL   BC+BCDA
          SHN    -BC.ANP
          LMN    1           1XXX CODE
          NJP    FCW2.5      IF NON TOP OF HOUR
          LDN    1
          STM    LOGB
          UJP    FCWX

 FCW0     LDN    1
          STD    T4          INITIALLY GO TO BUFFER ONE
          LDN    VER5
          RJM    VCK         CHECK VERSION AGAINST CENTRAL MEMORY LEVEL
          PJN    FCW2        IF VERSION 5 OR LATER USE ALL CONTROL WORDS
          LDM    NBUF        NUMBER OF BUFFERS DEFINED
          SBN    4
          MJN    FCW2        IF LESS THAN 4 DONT LOCK DOWN FIRST TWO
          STD    T1
          LDN    3
          STD    T4          SET FIRST BUFFER TO EXAMINE TO NUMBER THREE
          LDDL   BC+BCDA     DFT ANALYSIS CODE
          LMC    TOHE        ELEMENT COUNTERS ANALYSIS
          NJN    FCW1        IF NOT COUNTERS STATISTIC INFO
          LDN    1           ENTRY ONE IS FOR ELEMENT COUNTERS
          STM    LOGB
          UJP    FCWX        RETURN

 FCW1     LDDL   BC+BCDA     GET DFT ANALYSIS CODE
          LMC    TOHS        SECDED ID STATISTIC CODE
          NJN    FCW2.5      IF NOT SECDED STATISTIC INFO
          LDN    2           ENTRY TWO IS FOR SECDED INFO
          STM    LOGB
          UJP    FCWX        RETURN

 FCW2     LDM    NBUF
          SBN    2
          STD    T1
 FCW2.5   LDN    EPSW+1      SET MINIMUM TO ONE GREATER THAN POSSIBLE MAXIMUM
          STD    T3          SET MINIMUM ERROR LEVEL TO MAXIMUM VALUE
          LDD    T4          INITIAL BUFFER INDEX TO SEARCH FROM
          STD    T2          FIRST USABLE BUFFER CONTROL WORD INDEX
          LDN    HDRP
          RJM    IDA
          CRDL   CM          GET DFT HEADER
          LDD    CM+DHSEQ
          LPC    0#FF        GET JUST THE SEQUENCE NUMBER
          STD    T4          HEADER SEQUENCE NUMBER
 FCW3     LDM    CELCW       CHECK CONSOLE LOGGING MRB
          LPN    77
          LMD    T2
          ZJP    FCW9        IF THIS MRB BEING LOGGED TO CONSOLE
          LDD    T2          READ BUFFER CONTROL WORD (T2)
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          CRDL   CM
          RJM    CHF         CHECK IF NOT CURRENTLY USED ENTRY
          NJN    FCW4        IF CURRENTLY BEING USED
          LDN    0
          STD    T5          TEMPORARY ERROR LEVEL = NONE
          UJN    FCW5        CONTINUE

 FCW4     LDDL   CM+BCDA
          SHN    -BC.ANP
          STD    T5          TEMPORARY ERROR LEVEL
 FCW5     SBD    T3          MINIMUM ERROR LEVEL
          ZJN    FCW6        IF TEMPORARY = MINIMUM
          PJN    FCW9        IF TEMPORARY > MINIMUM ERROR LEVEL
 FCW6     LDDL   CM+BCSEQ
          SHN    -10
          STD    T6          TEMPORARY SEQUENCE NUMBER
          SBD    T4          HEADER SEQUENCE NUMBER
          PJN    FCW7        IF TEMPORARY > HEADER

*         ADD 256 (OVERFLOW QUANTITY) TO ALL ENTRIES BELOW THE VALUE
*         IN THE HEADER.  THIS WILL NORMALIZE VALUES SO CORRECT SEQUENCE
*         CAN BE MAINTAINED.

          LDD    T6
          ADC    0#100
          STD    T6
 FCW7     LDD    T5          TEMPORARY ERROR LEVEL
          SBD    T3          MININUM ERROR LEVEL
          PJN    FCW8        IF MININUM > TEMPORARY
          ZJN    FCW8        IF MININUM = TEMPORARY

*         IF TEMPORARY IS LESS THAN MININUM ERROR LEVEL THEN MININUM
*         ERROR LEVEL WILL BE SET LOWER.  THIS DRIVES TOWARDS THE LEAST
*         IMPORTANT ERROR IN THE BUFFER.

          LDD    T5
          STD    T3          UPDATE MININUM ERROR LEVEL
          LDD    T6
          ADN    1
          STD    T7          LOW SEQUENCE + 1
 FCW8     LDD    T6          TEMPORARY SEQUENCE
          SBD    T7          LOW SEQUENCE
          MJN    FCW10       IF LOW SEQUENCE > TEMPORARY SEQUENCE
 FCW9     AOD    T2          INCREMENT BUFFER INDEX
          SOD    T1          NBUF
          PJP    FCW3        IF MORE TO EXAMINE
          UJN    FCW11       CONTINUE

*         SINCE TEMPORARY SEQUENCE IS LESS THAN LOW SEQUENCE THIS
*         TEMPORARY ENTRY IS THE CURRENT BEST CANDIDATE.  UPDATE LOW
*         SEQUENCE WITH THIS VALUE FOR FURTHER COMPARISON PURPOSES.

 FCW10    LDD    T2
          STM    LOGB        THE CURRENT BEST CANDIDATE IS THIS INDEX
          LDD    T6
          STD    T7          LOW SEQUENCE
          UJN    FCW9        CONTINUE

*         AT THIS POINT WE HAVE OUR BEST CANDIDATE AT *LOGB*.  NEXT,
*         READ IN BUFFER CONTROL WORD (LOGB).  IF IT IS AVAILABLE,
*         ASSIGN IT AND LEAVE.  IF IT IS NOT AVAILABLE, DETERMINE IF
*         IT CAN BE OVERWRITTEN.  IF SO, UPDATE THE UNLOGGED COUNTER
*         FOR THE ENTRY BEING OVERWRITTEN AND USE THE ENTRY FOR THIS
*         HIGHER PRIORITY ENTRY.  IF IT CANNOT BE OVERWRITTEN, SET
*         *LOGB* TO ZERO TO INDICATE THAT THIS ERROR CANNOT BE LOGGED.

 FCW11    LDM    LOGB
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          CRDL   CM          GET CONTROL WORD TO BE REPLACED
          RJM    CHF         CHECK IF WAS A LOGB ENTRY
          ZJP    FCW14       IF IT WAS
          LDDL   BC+BCDA
          SHN    -BC.ANP
          SBD    T3
          MJP    FCW15       IF NOT SUFFICIENT PRIORITY TO OVERWRITE
          ZJP    FCW15
          LDN    VER4
          RJM    VCK         CHECK VERSION
          PJN    FCW12
          LDDL   CM+BCEI
          SHN    -10         GET SAVED ELEMENT INDEX TO COUNTERS BUFFER
          ADM    NUMHW
          ADM    NBUF
          STD    T3
          RJM    IDA
          CRDL   CM          GET MAINFRAME ELEMENT COUNTER ENTRY
          AOD    CM+MEUL
          LDD    T3
          RJM    IDA
          CWDL   CM          UPDATE UNLOG FIELD OF OVERWRITTEN ENTRY
          UJN    FCW14

 FCW12    LDDL   CM+BCDA
          SHN    -10
          LPN    0#F
          STD    T3
          LDM    ETYP,T3
          STD    T1
          LDM    OTYP,T3
          STD    T2
          ZJN    FCW13
          LDI    T2
          SHN    4
          LMD    T1
          STD    T1
 FCW13    RJM    GCE         GET COUNTER ENTRY
          AODL   CM+1
          LDD    W0
          LRD    W1
          ADC    RR
          CWDL   CM
 FCW14    LDN    W0
          RJM    CLR         CLEAR AREA FOR INTERLOCK WORD
          LDBC   BC.FI
          STDL   W0+BCFLG
          LDM    LOGB
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          RDSL   W0          SET INTERLOCK ON BUFFER CONTROL WORD
          LDDL   W0+BCFLG
          SHN    21-BC.FI
          MJN    FCW14       IF NEED TO TRY AGAIN
          LDN    1
          STM    DSIF        SET DFT SET I/L FLAG
          LJM    FCWX        RETURN

 FCW15    LDN    0
          STM    LOGB        COULDNT GET AN ENTRY
          LJM    FCWX        RETURN
 CHF      SPACE  4,10
**        CHF - CHECK FLAGS IN BUFFER CONTROL WORD.
*
*         ENTRY  (CM - CM+3) = BUFFER CONTROL WORD.
*
*         EXIT (A) > 0 IF FLAG(S) IS/ARE SET.
*              (A) = 0 IF NO FLAG IS SET.


 CHF      SUBR               ENTRY/EXIT
          LDDL   CM+BCFLG
          LPBC   (BC.CL,BC.FL,BC.FV7,BC.FV8)
          UJN    CHFX        RETURN

*         END    CTP$DFT_FIND_CONTROL_WORD
*DECK DECK=CTP$DFT_FIND_WARNING_IN_NRSB EXPAND=FALSE
*         CTEXT  CTP$DFT_FIND_WARNING_IN_NRSB
*
 FWE      SPACE  4,10
**        FWE - FIND A WARNING ENTRY.
*
*         EXIT   (A) = 0 WHEN NO ENTRY FOUND.
*                (RTP2) = ORDINAL OF ENTRY FOUND.
*
*         CALLS  IDA.
*
*         USES   T1, W0 - W3, W4 - W7.


 FWE      SUBR               ENTRY/EXIT
          LDN    1
          STM    RTP2
 FWE1     RJM    GBE         GET AN ENTRY
          ZJN    FWEX        IF AT END OF TABLE
          CRDL   CM          GET THE CONTROL WORD IN THE ENTRY
          LDDL   CM+1
          SHN    -10
          LPN    0#F         ISOLATE THE ELEMENT TYPE
          SBN    7
          NJN    FWE1        IF NOT A WARNING ENTRY
          LDD    CM+1
          LPN    0#F
          SBN    4
          PJN    FWE1        IF A WARNING BUT MARKED AS WARNING CLEARED
          UJP    FWEX        RETURN
 GBE      SPACE  4,10
**        GBE - GET A NON REGISTER BUFFER ENTRY.
*
*         ENTRY  (A) = ORDINAL TO SEARCH FROM.
*
*         EXIT   (A)= 0 IF END OF BUFFER.
*
*         CALLS  IDA.
*
*         USES   RTP2, W0 - W3.


 GBE0     LDN    0           END OF BUFFER EXIT CONDITION
 GBE      SUBR               ENTRY/EXIT
          LDN    NRSP
          RJM    IDA         INCREMENT POINTER ADDRESS
          CRDL   W0          READ IN POINTER WORD
          LRD    W1
          LDDL   W0
          ADC    RR
          CRDL   W4          READ IN HEADER WORD
          LDML   RTP2        CURRENT ELEMENT POSITION
          ADD    W7          ELEMENT SIZE
          SBD    W3          LENGTH OF BUFFER
          PJN    GBE0        IF AT END OF BUFFER
          LDD    W7          ELEMENT SIZE
          RAML   RTP2        UPDATE NEXT ELEMENT
          ADDL   W0
          ADC    RR
          LJM    GBEX

*         END    CTP$DFT_FIND_WARNING_IN_NRSB
*DECK DECK=CTP$DFT_GENERATE_960_MEMORY_FSC EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT GENERATE 960 MEMORY FSC
          SPACE  4,10
          BASE   D
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4,10
** THIS COMDECK IS TO GENERATE FAULT SYMPTOM CODES FOR ERRORS REPORTED
* FROM THE 960 CENTRAL MEMORY ERROR LOGS.
* THE FOLLOWING FORM GIVES THE PATTERN FOR THE CODES.
*
*(2**N)1   2   3   4   5   6   7   8   9   10  11  12  13  14  15  *
*  24  BF  *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
*  23  *   WP  *   *   *   *   *   *   *   *   *   *   *   *   *   *
*  22  *   *   IF  *   *   *   *   *   *   *   *   *   *   *   *   *
*  21  *   *   E0  *   *   *   *   (8  *   *   *   *   *   *   *   *
*  20  *   *   E1  *   *   *   (7  (8  *   *   *   *   *   *   *   *
*  19  *   *   E2  *   (5  (6  (7  (8  *   *   *   *   *   *   *   *
*  18  *   *   E3  (4  *   (6  (7  (8  *   *   *   *   *   *   *   *
*  17  *   *   *   *   *   *   *   *   RD  *   *   *   *   *   *   *
*  16  *   *   *   *   *   *   *   *   MB  MB  *   *   *   *   *   *
*  15  *   *   *   *   *   *   *   *   *   *   PW  *   *   *   *   *
*  14  *   *   *   *   *   *   *   *   *   *   *   SB  *   *   *   *
*  13  *   *   *   *   *   *   *   *   SS  SS  SS  SS  *   *   *   *
*  12  *   *   *   *   *   *   *   *   MS  MS  MS  MS  *   *   *   *
*  11  *   *   *   *   MP  *   *   *   MS  MS  MS  MS  *   *   *   *
*  10  P0  P0  P0  P0  P0  P0  P0  P0  B0  B0  B0  B0  *   *   *   *
*  09  P1  P1  P1  P1  P1  P1  P1  P1  B1  B1  B1  B1  *   *   *   *
*  08  P2  P2  P2  P2  P2  P2  P2  P2  B2  B2  B2  B2  *   *   *   *
*  07  E0  WB  *   *   ML  *   *   *   RB  RB  PB  SC  *   *   *   *
*  06  E1  WB  *   *   ML  *   *   *   RB  RB  PB  SC  *   *   *   *
*  05  E2  WB  *   *   ML  *   *   *   RB  RB  PB  SC  *   *   *   *
*  04  E3  WB  FC  FC  ML  *   *   *   RB  RB  PB  SC  *   *   *   *
*  03  A0  WB  FC  FC  ML  *   A0  A0  RB  RB  PB  SC  *   *   *   *
*  02  A1  WB  FC  FC  ML  *   A1  A1  RB  RB  PB  SC  *   *   *   *
*  01  A2  WB  FC  FC  ML  *   A2  A2  RB  RB  PB  SC  *   *   *   *
*  00  A3  WB  FP  FP  ML  *   A3  A3  RB  RB  PB  SC  *   *   *   *
*
* (4--ENCODED ERROR = 1 (FUNCTION CODE PE)
* (5--ENCODED ERROR = 2 (MARK LINE PE)
* (6--ENCODED ERROR = 3 (TAG PE)
* (7--ENCODED ERROR = 4-7 (CMC ADDRESS PE)
* (8--ENDODED ERROR = 8-F (CSU ADDRESS PE)
* A0-A3--ADDRESS BYTE PE BYTES 0-3
* B0-B2--BANK SELECT BITS 0-2
* BF - BOUNDS FAULT
* E0-E3--ENCODED ERROR BITS 0-3
* FC--FUNCTION CODE BITS 0-3
* FP--FUNCTION CODE PARITY
* IF--ILLEGAL FUNCTION
* MB--MULTIPLE BIT ERROR
* ML--MARK LINE BITS 0-7
* MP--MARK LINE PARITY BIT
* MS--CM ARRAY MODULE SELECT BIT 0,1
* PB--PARTIAL WRITE DATA BYTE PE BITS 0-7
* RB--READ DATA BYTE PE BITS 0-7
* RD--READ DATA PE
* SB--SINGLE BIT ERROR, IE, CORRECTED ERROR.
* SC--CORRECTED ERROR SYNDROME CODE BITS 0-7
* SS--CM ARRAY MODULE SIDE SELECT BIT
* WB--WRITE BYTE PARITY ERROR BITS 0-7
* WP--WRITE DATA BYTE PE
***
** CURRENT CODE REVISION IS - C -  (14JUN88)     VERSION
          SPACE 1
** EQUATES FOR VARIABLES
I         EQU    T1          TEMPORARY STORE
TEMP      EQU    T2          --MORE VOLATILE CELLS ARE FIRST-
TEMP1     EQU    T3
DEX2      EQU    T4
DEX3      EQU    T5
MSK8      EQU    T6          HOLDS AN 8 BIT MASK
FWAIB     EQU    T7          FWA OF INPUT BUFFER
          SPACE  3
** EQUATES FOR CONSTANTS
MLPEC     EQU    0#2         ERROR CODE FOR MARK LINE PE
D.HSL     EQU    8           HALF SHIFT LEFT 8
D.HSR     EQU    -8          HALF SHIFT RIGHT 8
D.QSR     EQU    -4          QUARTER SHIFT RIGHT 4
D.XF      EQU    0#F         HEX VALUE
D.XA      EQU    0#A         HEX VALUE
D.X30     EQU    0#30        ASCII CODE FOR 0
D.X37     EQU    0#37        ASCII CODE FOR A

** THE FOLLOWING TIES THE COMDECK TOGETHER WITH THE INPUT BUFFER.
A0        EQU    0           LOC OF CELL RELATIVE TO FWA OF INPUT BFR
A01       EQU    1           LOC OF CELL RELATIVE TO FWA OF INPUT BFR
A02       EQU    2           LOC OF CELL RELATIVE TO FWA OF INPUT BFR
A03       EQU    3           LOC OF CELL RELATIVE TO FWA OF INPUT BFR
A4        EQU    4           LOC OF CELL RELATIVE TO FWA OF INPUT BFR
A41       EQU    5           LOC OF CELL RELATIVE TO FWA OF INPUT BFR
A42       EQU    6           LOC OF CELL RELATIVE TO FWA OF INPUT BFR
A43       EQU    7           LOC OF CELL RELATIVE TO FWA OF INPUT BFR
A8        EQU    8           LOC OF CELL RELATIVE TO FWA OF INPUT BFR
A81       EQU    9           LOC OF CELL RELATIVE TO FWA OF INPUT BFR
A82       EQU    10          LOC OF CELL RELATIVE TO FWA OF INPUT BFR
A83       EQU    11          LOC OF CELL RELATIVE TO FWA OF INPUT BFR
MODEL     EQU    12          LOCATION OF CELL RELATIVE TO FWA OF INPUT
          SPACE  3
** RESERVED SPACE/CELLS
ABRT      CON    0           ABORT FLAG
ADPB      CON    0           ADDRESS PARITY ERROR BYTES
FSCBFR    BSSZ   2           TEMPORARY BUFFER
PEBPC     CON    0           PE BYTE POSITION CODE (ENCODED ERROR)

CMFSC     EJECT
***       CMFSC              CM FAULT SYMPTOM CODE GENERATOR
*
*         PURPOSE            TO GENERATE THE LOWER 8 CHARACTERS OF A
*                            FAULT SYMPTOM CODE FOR ERRORS REPORTED IN
*                            THE MEMORY ERROR LOGS.
*
*         METHOD             CHECK ERROR BITS IN A PREDEFINED ORDER AND
*                            GENERATE A CODE BASED ON THE ERROR AND
*                            OTHER SELECTED SUPPORTING DATA FROM THE
*                            ERROR LOGS.
*
*         ENTRY              (A) = FIRST WORD ADDRESS OF A 13 WORD BFR.
*                            THIS BUFFER WILL CONTAIN DATA FROM THE
*                            CM ERROR REGISTERS A0, A4, AND A8. WORD 13
*                            OF THE BUFFER WILL CONTAIN THE MEMORY MODEL
*                            NUMBER.
*
*         EXIT               EXIT WITH FAULT SYMPTOM CODE IN THE FIRST
*                            FOUR WORDS OF THE INPUT BUFFER. THE CODE
*                            WILL BE IN ASCII FORMAT.
*
*         USES               FWAIB, FSCBFR, MSK8, TEMP1
*
*         CALLS              GPC, CAP, GAI, CHW
*
*         MACROS             SUBR

CMFSC     SUBR               SUBROUTINE ENTRY POINT
          STDL   FWAIB       STORE BASE ADDRESS
          STDL   TEMP

* CLEAR STATUS WORDS NOT MARKED AS VALID.
CMFSC02   LDIL   TEMP        LOAD BYTES 0,1 OF STATUS
          SHN    2           POSITION TO SIGN BIT.
          MJN    CMFSC06     IF VALID BIT SET,
          LDN    3           ELSE, CLEAR 8 BYTES(4 WORDS) OF DATA
          STDL   I
CMFSC04   LDN    0
          STIL   TEMP        STORE ZERO TO BUFFER WORD
          AODL   TEMP        INCREMENT BUFFER POINTER
          SODL   I           DECR INDEX COUNT
          PJN    CMFSC04     IF NOT COMPLETE,
          LDDL   TEMP
          UJN    CMFSC08
CMFSC06   LDN    4           LOAD LENGTH OF RGTR DATA WORD
          RADL   TEMP        INCREMENT POINTER
CMFSC08   SBDL   FWAIB       SUBTRACT FWA OF BUFFER.
          SBN    12          SUBTRACT TOTAL LENGTH OF RGTR DATA
          MJN    CMFSC02     IF NOT ALL DATA CHECKED,

          LDN    0
          STML   FSCBFR      CLEAR TEMP BUFFER
          STML   FSCBFR+1
          LDC    0#FF
          STDL   MSK8        PRESET THE MASK VALUE

* LOOK FOR BOUNDS FAULT
          LDML   A8,FWAIB    LOAD A8 BYTE 0,1
          SHN    17-12
          PJN    CMFSC10     IF NOT BOUNDS FAULT,
          LDC    0#100
          STML   FSCBFR      SET BIT 2**24
          LDDL   FWAIB       LOAD ADDRESS OF BUFFER
          ADN    A8          ADD OFFSET
          RJM    GPC         GET PORT CODE AND PLACE IN OUT
          LDDL   FWAIB       LOAD ADDRESS OF BUFFER
          ADN    A8          ADD OFFSET
          RJM    CAP         GO CHECK ADDRESS PE
          RAML   FSCBFR+1    REPLACE TO OUTPUT CODE
          LDML   A42,FWAIB
          LPN    17B         EXTRACT PEBPC
          SHN    4
          RAML   FSCBFR+1    SAVE ENCODED ERROR.
          LJM    CMFSCC0     GO CONVERT AND EXIT.

* LOOK FOR WRITE DATA PE
CMFSC10   LDML   A43,FWAIB   LOAD A4 BYTE 6,7
          SHN    -8
          STDL   TEMP1
          NJN    CMFSC12     IF WRITE DATA PE BYTE IS NONZERO,
          LDML   A8,FWAIB    LOAD A8 BYTE 0,1
          SHN    17-11
          PJN    CMFSC20     IF NO MULTIPLE BIT ERROR,
          LDDL   FWAIB       LOAD BASE ADDRESS
          ADN    A8          ADD RGTR DATA OFFSET
          UJN    CMFSC16
CMFSC12   LDDL   TEMP1       RETRIEVE THE WRITE DATA PE BYTES
          RAML   FSCBFR+1    ADD TO OUTPUT CODE
          LDDL   FWAIB       LOAD ADDRESS OF BUFFER
          ADN    A4          ADD OFFSET
CMFSC16   RJM    GPC         GET THE PORT CODE
          LDC    0#80
          STML   FSCBFR      SET BIT 2**23
          LJM    CMFSCC0     EXIT

* LOOK FOR ILLEGAL FUNCTION
CMFSC20   LDML   A8,FWAIB    LOAD A8 BYTE 0,1
          SHN    17-13
          PJN    CMFSC30     IF NOT ILLEGAL FUNCTION
          LDC    0#40
          STML   FSCBFR      SET BIT 2**22
          LDML   A42,FWAIB   LOAD A4 BYTE 4,5
          LPN    17B         EXTRACT ENCODED ERROR BITS
          SHN    2
          RAML   FSCBFR
          LDDL   FWAIB       LOAD ADDRESS OF BUFFER
          ADN    A8          ADD OFFSET
          RJM    GPC         GET PORT CODE
CMFSC25   LDML   A4,FWAIB    LOAD A4 BYTE 0,1
          SHN    -8
          LPN    37B         EXTRACT FUNCTION CODE, PARITY
          RAML   FSCBFR+1
          LJM    CMFSCC0     CONVERT AND EXIT

* LOOK FOR FUNCTION CODE PE
CMFSC30   LDML   A42,FWAIB   LOAD A4 BYTE 4,5
          LPN    17B         EXTRACT ENCODED ERROR BITS
          STML   PEBPC
          SHN    2
          STML   FSCBFR
          LMN    4
          NJN    CMFSC40     IF NOT FUNCTION CODE PE,
          LDDL   FWAIB       LOAD ADDRESS OF BUFFER
          ADN    A4          ADD OFFSET
          RJM    GPC         GET PORT CODE
          UJN    CMFSC25     GO GET FUNCTION AND PARITY

* LOOK FOR MARK LINE PARITY ERROR.
CMFSC40   LDML   PEBPC
          LMN    MLPEC
          NJN    CMFSC50     IF NOT MARK LINE PE,
          LDDL   FWAIB       LOAD ADDRESS OF BUFFER
          ADN    A4          ADD OFFSET
          RJM    GPC         GET THE PORT CODE
          LDML   A43,FWAIB   LOAD A4 BYTES 6,7
          LPDL   MSK8        EXTRACT THE MARK LINE BITS
          STML   FSCBFR+1
          LDML   A4,FWAIB    LOAD A4 BYTES 0,1
          SHN    -4
          LPN    17B         EXTRACT MARK P AND PORT CODE
          SHN    8
          RAML   FSCBFR+1
          LJM    CMFSCC0     CONVERT AND EXIT

* LOOK FOR TAG PARITY ERROR.
CMFSC50   LDML   PEBPC
          LMN    3
          NJN    CMFSC60     IF NOT TAG PE,
          LDDL   FWAIB       LOAD ADDRESS OF BUFFER
          ADN    A4          ADD OFFSET
          RJM    GPC
          LJM    CMFSCC0     CONVERT AND EXIT

* LOOK FOR ENCODED CM ADDRESS PE OR CSU ADDRESS PE
CMFSC60   LDML   PEBPC
          SBN    4
          MJN    CMFSC70     IF LESS THAN 4 (THIS HAS ALREADY BEEN CHEC
          LDDL   FWAIB       LOAD ADDRESS OF BUFFER
          ADN    A4          ADD OFFSET
          RJM    CAP         CHECK ADDRESS PARITY VIA REPORT
          RAML   FSCBFR+1
          LDDL   FWAIB       LOAD ADDRESS OF BUFFER
          ADN    A4          ADD OFFSET
          RJM    GPC         GET THE PORT CODE
          LJM    CMFSCC0     CONVERT AND EXIT

* LOOK FOR READ DATA PARITY ERROR.
CMFSC70   LDML   A83,FWAIB   LOAD A8 BYTES 6,7
          SHN    -8
          ZJN    CMFSC80     IF NOT READ DATA PE BYTE,
          STML   FSCBFR+1
          LDDL   FWAIB       LOAD ADDRESS OF BUFFER
          ADN    A8          ADD OFFSET
          RJM    GAI         GET ARRAY INDEX (D,MS,BANK)
          LDN    2           2**17  MEANS READ DATA PE
          STML   FSCBFR
          LDML   A4,FWAIB    LOAD A4 BYTES 0,1
          SHN    17-12
          LPN    1           EXTRACT MULTIPLE BIT ERROR
          RAML   FSCBFR
          LJM    CMFSCC0     CONVERT AND EXIT

* LOOK FOR MULTIPLE BIT ERROR
CMFSC80   LDML   A4,FWAIB    LOAD A4 BYTES 0,1
          SHN    17-13
          PJN    CMFSC90     IF NOT MULTIPLE BIT ERROR
          LDN    1
          STML   FSCBFR
          LDDL   FWAIB
          ADN    A4
          RJM    GAI         GET ARRAY INDEX FROM A4 RGTR.
          LJM    CMFSCC0     GO CONVERT AND EXIT.

* LOOK FOR PARTIAL WRITE DATA PE
CMFSC90   LDML   A83,FWAIB   LOAD A8 BYTES 6,7
          LPDL   MSK8
          ZJN    CMFSCA0     IF NO PARTIAL WRITE DATA PE,
          STML   FSCBFR+1    STORE DATA PE BITS, (NOT NEED FOR FRU ISOL
          LDDL   FWAIB       LOAD ADDRESS OF BUFFER
          ADN    A8          ADD OFFSET
          RJM    GAI         GET ARRAY INDEX
          LDC    0#8000      PARTIAL WRT PE INDICATOR
          RAML   FSCBFR+1
          LJM    CMFSCC0     CONVERT AND EXIT

* LOOK FOR A0 DETECTED ERROR, IE, SINGLE BIT ERROR.
CMFSCA0   LDML   A0,FWAIB    LOAD A0 BYTES 0,1
          SHN    2
          PJN    CMFSCB0     IF A0 RGTR NOT VALID,
          LDDL   FWAIB       LOAD ADDRESS OF BUFFER
          ADN    A0          ADD OFFSET
          RJM    GAI         GET ARRAY INDEX
          LDC    0#4000
          RAML   FSCBFR+1
          LDML   A03,FWAIB   LOAD A0 BYTES 6,7
          SHN    -8          EXTRACT SYNDROME CODE.
          RAML   FSCBFR+1
CMFSCB0   LJM    CMFSCC0     CONVERT AND EXIT

** CONVERT RAW STATUS CODE TO ASCII AND STORE FOR EXIT.
** CAUTION--NOTE THAT TEMP, AND TEMP1 ARE USED BY ROUTINE CHW.
CMFSCC0   EQU    *
          LDML   ABRT
          ZJN    CMFSCC1     IF NO ABORT FLAG,
          LDN    0           ELSE, ZERO THE SYMPTOM CODE
          STML   FSCBFR
          STML   FSCBFR+1
CMFSCC1   LDML   FSCBFR      LOAD BYTE 0,1 OF RAW FSC
          RJM    CHW         CONVERT TO ASCII
          STML   0,FWAIB     STORE TO BUFFER FOR OUTPUT
          LDDL   DEX3
          STML   1,FWAIB
          LDML   FSCBFR+1    LOAD BYTE 2,3 OF RAW FSC
          RJM    CHW         CONVERT TO ASCII
          STML   2,FWAIB
          LDDL   DEX3
          STML   3,FWAIB
          LJM    CMFSCX      EXIT FAULT CODE GENERATOR.

CAP       EJECT
***       CAP                CHECK ADDRESS PARITY
*
*         METHOD             EXTRACT THE ADDRESS PRESENTED BY THE
*                            ERROR LOG AND GENERATE THE EXPECTED
*                            PARITY FOR THAT ADDRESS.  COMPARE THE
*                            GENERATED ADDRESS WITH THE ADDRESS PARITY
*                            REPORTED IN THE ERROR LOG.  EXIT WITH THE
*                            DIFFERENCE BITS IN -A-.
*
*         INPUT              (A)= FWA OF THE ERROR LOG DATA OF INTEREST
*
*         EXIT               (ADPB )= ADDRESS BYTE PARITY
*                            (A) = ADDRESS BYTE PARITY ERRORS.
*
*         USES               TEMP1, TEMP, ADPB , DEX3,
*
*         CALLS              GPB
*
*         MACROS             SUBR

CAP       SUBR               ENTRY/EXIT
          STDL   TEMP1
          LDML   0,TEMP1     LOAD BYTE 0,1
          LPN    17B
          SHN    3
          STD    TEMP
          LDML   1,TEMP1     LOAD BYTE 2,3
          SHN    -13
          ADDL   TEMP        ADD THE UPPER BITS
          RJM    GPB         GENERATE EXPECTED PARITY FOR ADDRS BYTE 0
          SHN    3
          STML   ADPB        STORE TO PARITY CELL
          LDML   1,TEMP1     LOAD BYTE 2,3
          SHN    -5
          LPDL   MSK8        MASK FOR ADDRS BYTE 1
          RJM    GPB         GENERATE PARITY ON ADDRESS BYTE
          SHN    2
          RAML   ADPB
          LDML   1,TEMP1     LOAD BYTE 2,3
          LPN    37B         EXTRACT UPPER BITS OF ADDRS BYTE 2
          SHN    3
          STDL   TEMP
          LDML   2,TEMP1     LOAD BYTES 4,5
          STDL   DEX3
          SHN    -16+3       RETAIN LOWER BITS OF ADDRS BYTE 2
          ADDL   TEMP
          RJM    GPB
          SHN    1
          RAML   ADPB
          LDDL   DEX3        RELOAD BYTES 4,5
          SHN    -8
          LPN    37B         RETAIN UPPER BITS OF ADDRS BYTE 3
          RJM    GPB         GENERATE PARITY (LOWER BITS ARE ZERO)
          RAML   ADPB
          LDDL   DEX3        RELOAD BYTES 4,5
          SHN    -4
          LPN    17B         EXTRACT ADDRS PARITY REPORTED.
          LMML   ADPB        COMPARE WITH ADDRS BITS GENERATED
          LJM    CAPX        EXIT
CHW       EJECT
***       CHW                CONVERT HEX WORD TO ASCII
*
*         PURPOSE            CONVERT HEX TO ASCII.
*
*         CALLED             RJM TO CHW
*
*         ENTRY              (A)=VALUE TO CONVERT (EXAMPLE 1234)
*
*         EXIT               VIA CHW ENTRY ADDRESS WITH
*                            (A) = UPPER 2 CHARACTERS (EX 12)
*                            DEX3= LOWER 2 CHARACTERS (EX 34)
*
*         CALLS              CHC
*
*         USES               DEX2, DEX3, TEMP,

CHW       SUBR               ENTRY/EXIT
          STDL   DEX2        SAVE NUMBER TO CONVERT (00)ABCD
          SHN    -12         000A
          RJM    CHC         CONVERT A
          SHN    D.HSL       (XX00)
          STDL   TEMP        SAVE CONVERTED A
          LDDL   DEX2        RELOAD NUMBER (ABCD)
          SHN    D.HSR       (00AB)
          RJM    CHC         CONVERT B
          RADL   TEMP        ADD TO CONVERTED A (AB)
          LDDL   DEX2        RELOAD NUMBER (ABCD)
          SHN    D.QSR       (0ABC)
          RJM    CHC         CONVERT C
          SHN    D.HSL       (XX00)
          STDL   DEX3        SAVE CONVERTED C
          LDDL   DEX2        RELOAD NUMBER (ABCD)
          RJM    CHC         CONVERT D
          RADL   DEX3        ADD TO CONVERTED C (CD)
          LDDL   TEMP        LOAD UPPER TWO CHARS (AB)
          UJN    CHWX        EXIT
CHC      EJECT
***       CHC                CONVERT HEX CHARACTER TO ASCII
*
*         USAGE              CONVERT ONE HEX CHAR TO ASCII
*
*         CALLED             RJM TO CHC FROM CHW
*
*         ENTRY              A=000X (X=NUMBER TO CONVERT)
*
*         EXIT               VIA CHC ENTRY ADDRESS. A=CONVERTED DIGIT
*
*         CALLS              NONE
*
*         USES               TEMP1,
*
CHC       SUBR   *           ENTRY/EXIT
          LPN    D.XF        SAVE ONLY RIGHTMOST DIGIT (000X)
          STDL   TEMP1       SAVE IN DIRECT
          SBN    D.XA        SUBTRACT HEX A
          PJN    CHC10       IF NUMBER IS GREATER THAN HEX A
          LDDL   TEMP1       RELOAD NUMBER
          ADN    D.X30       ADD BIAS -HEX 30 FOR 0-9
          UJN    CHCX        EXIT
CHC10     LDDL   TEMP1       RELOAD NUMBER
          ADN    D.X37       ADD BIAS - HEX 37 FOR A-F
          UJN    CHCX        EXIT

GAI       EJECT
***       GAI                GET ARRAY INDEX
*
*         PURPOSE            TO RETURN THE BITS OF ADDRESS SELECTING
*                            THE CM MODULE. THESE ARE --
*                                  D  - THE ARRAY SIDE
*                                  MS - THE MODULE SELECT
*                                  BK - THE BANK SELECT
*
*         INPUT              (A) - FWA OF THE BUFFER OF INTEREST
*
*         OUTPUT             CODE ADDED TO FSCBFR+1
*
*         USES               TEMP, FSCBFR, ABRT

GAI       SUBR               ENTRY/EXIT
          STDL   TEMP
          LDML   2,TEMP      LOAD RGTR BYTES 4,5
          SHN    -8
          LPN    7B          EXTRACT BANK BITS
          SHN    8
          RAML   FSCBFR+1
          LDML   MODEL,FWAIB LOAD MODEL VALUE
          ADC    -0#34
          NJN    GAI10       IF NOT MODEL 34,
          LDML   1,TEMP      LOAD RGTR BYTE 2,3
          SHN    -15
          SHN    17
          ADIL   TEMP        ADD BYTES 0,1
          SHN    1           BRING DOWN BIT FROM 2**17
GAI05     LPN    3           EXTRACT MS BITS
          SHN    11
          RAML   FSCBFR+1
          UJN    GAIX        EXIT

GAI10     SBN    1           GET MODEL NUMBER
          NJN    GAI20       IF NOT MODEL 35
          LDML   0,TEMP      GET BYTES 0,1
          SHN    -1
          UJN    GAI05       JOIN MAIN TO COMPLETE

GAI20     LDN    5
          STML   ABRT        ELSE, SET ABORT FLAG NONZERO.
          LJM    GAIX
** NEEDS CODE FOR OTHER MODELS..
GPB       EJECT
***       GPB                GENERATE PARITY BITS
*
*         METHOD             COUNT THE BITS PRESENTED IN -A-.  MASK
*                            FOR THE LOWER BIT OF THE COUNT TO GET
*                            THE PROPER BIT FOR EVEN PARITY.
*
*         ENTRY              (A) = THE DATA FOR WHICH THE PARITY BIT IS
*                            TO BE ESTABLISHED.
*
*         EXIT               EXIT WITH DESIRED PARITY IN -A-
*
*         CALLED             CALLED BY RETURN JUMP TO GPB
*
*         USES               TEMP, I
*
*         CALLS              NA
*
*         MACROS             SUBR
*

GPB       SUBR               ENTRY/EXIT
          STDL   TEMP              SAVE THE DATA WORD TO BE EXAMINED
          ZJN    GPB30             IF (A) EQU ZERO, TAKE THE SHORT CUT
          LDN    0                 ELSE, CLEAR THE BIT COUNT
          STDL   I
          LDDL   TEMP              RELOAD THE ENTRY VALUE
GPB10     SHN    17                SHIFT RT END AROUND
          STDL   TEMP              STORE THE RESULTS (RT SHIFTED ONE)
          PJN    GPB20             JUMP IF PREVIOUS LOW BIT IS ZERO
          AODL   I                 ELSE, INCREMENT BIT COUNT
GPB20     LDDL   TEMP              LOAD REMAINING BITS OF WORD
          NJN    GPB10             IF NOT ZERO, REPEAT
          LDDL   I                 ELSE, LOAD BIT COUNT
          LPN    1                 AND MASK FOR LOWER BIT
GPB30     UJN    GPBX              TO GET PROPER PARITY.
GPC       EJECT
***       GPC                GET PORT CODE (FROM NAMED BUFFER)
*
*         PURPOSE            TO GET THE PORT CODE FROM AN ERROR BUFFER
*                            AND TO PLACE IT IN THE RAW FAULT CODE.
*
*         ENTRY              (A) - THE FWA OF THE BUFFER OF INTEREST.
*                            FSCBFR IN AREA OF PORT CODE MUST BE ZERO.
*
*         EXIT               FSCBFR BITS 2**08-10 CONTAIN PORT CODE BIT
*
*         USES               TEMP, FSCBFR,
*
*         MACROS             SUBR

GPC       SUBR               ENTRY/EXIT
          STDL   TEMP        STORE ADDRESS
          LDIL   TEMP        LOAD BYTE 0,1
          SHN    -4
          LPN    7           EXTRACT PORT CODE
          SHN    8
          RAML   FSCBFR+1    ADD TO OUTPUT CODE
          UJN    GPCX

 GSM      SPACE  4,10
**        GSM - GENERATE FAULT SYMPTOM CODE FOR MEMORY.
*
*         CALLS  FMB, WFS.


          ROUTINE  GSM

          LDDL   BC+BCDA     GET ANALYSIS TO LOG
          SHN    -BC.ANP
          SBN    EPEN
          PJP    GSM2        IF ENVIRONMENT WARNING
          LDC    MCEL        CORRECTED ERROR LOG MAINTENANCE REGISTER
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF,ON
          LDC    MUL1        UNCORRECTED ERROR LOG 1 MAINTENANCE REGISTER
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+4,ON
          LDC    MUL2        UNCORRECTED ERROR LOG 2 MAINTENANCE REGISTER
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+10B,ON
          LDML   MEMM        MEMORY MODEL NUMBER
          STML   CDIF+14B
          LDC    CDIF        FWA OF INTERFACE BUFFER
          RJM    CMFSC
 GSM1     LDC    2RDM        MEMORY ELEMENT IDENTIFIER
          RJM    WFS         WRITE FAULT SYMPTOM CODE TO SUPPORTIVE STATUS
          LJM    GSMX        RETURN

 GSM2     LDN    3
          STD    T1
 GSM3     LDML   GSMA,T1     GET CANNED ENVIRONMENT FAULT SYMPTOM CODE
          STML   CDIF,T1     STORE IN OUTPUT BUFFER
          SOD    T1
          PJN    GSM3        IF NOT DONE
          UJN    GSM1        LOG THE FAULT CODE

 GSMA     DATA   H*701     *


          BASE   *
*         ENDX   CTP$DFT GENERATE 960 MEMORY FSC.
*DECK DECK=CTP$DFT_GENERATE_FAULT_SYMPTOM EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT_GENERATE_FAULT_SYMPTOM
*
*         THIS DECK CONTAINS ROUTINES TO GENERATE A FAULT SYMPTOM CODE
*         FOR AN IOU, CPU, MEMORY OR PAGE MAP AND STORE IT IN THE
*         SCRATCH SUPPORTIVE STATUS BUFFER.
*
*         THE 12-CHARACTER FAULT SYMPTOM CODE HAS THE FOLLOWING FORMAT:
*
*         *DEMMCCC     *
*
*         D = CHARACTER *D* (TO SIGNIFY DFT-PRODUCED ANALYSIS).
*         E = ELEMENT IDENTIFIER:
*                *C*/*D*/*E*/*F* FOR CPU 0/1/2/3.
*                *I*/*J*/*K*/*L* FOR IOU 0/1/2/3.
*                *M* FOR MEMORY.
*                *P* FOR PAGE MAP.
*         MM = MODEL NUMBER FOR ELEMENT WITH FAILURE.
*         CCC = 3-CHARACTER *DFT* ANALYSIS CODE.
 GSB      SPACE  4,10
**        GSB - GENERATE FAULT SYMPTOM CODE CONTAINING BLANKS.
*
*         ENTRY  (RTP1) = 0 USE SUPPORTIVE STATUS BUFFER.
*                       = 1 USE NON REGISTER STATUS BUFFER.

*         USES   T1, CM - CM+3.
*
*         CALLS  IDA.


          ROUTINE  GSB

*         READ FIRST WORD OF FAULT SYMPTOM CODE TO PRESERVE FIRST TWO BYTES.

          LDM    RTP1        FLAG FOR EITHER SUPPORTIVE STATUS OR NON REGISTER STATUS
          ZJN    GSB1        IF TO LOG TO SUPPORTIVE STATUS BUFFER
          LDN    NRSP        ADDRESS OF SCRATCH NON REGISTER DATA BUFFER
          UJN    GSB2

 GSB1     LDN    SSBP        GET ADDRESS OF SCRATCH SUPPORTIVE STATUS BUFFER
 GSB2     RJM    IDA
          CRDL   CM
          LDM    RTP1        FLAG FOR EITHER SUPPORTIVE STATUS OR NON REGISTER STATUS
          ZJN    GSB3        IF TO LOG TO SUPPORTIVE STATUS
          LDN    4           SKIP NON REGISTER BUFFER HEADER WORDS
          UJN    GSB4

 GSB3     LDN    3           SKIP HEADER WORDS
 GSB4     RADL   CM
          LRD    CM+1
          ADC    RR
          CRML   GSBA,ON
          LDC    2R          SET BLANKS IN FAULT SYMPTOM CODE FIELD
          STML   GSBB
          STML   GSBB+1

*         WRITE BLANK FAULT SYMPTOM CODE TO SCRATCH SUPPORTIVE STATUS BUFFER.

          LDN    2           SET NUMBER OF CM WORDS TO WRITE
          STD    T1
          LDDL   CM          LOAD ADDRESS OF SCRATCH BUFFER
          ADC    RR
          CWML   GSBA,T1     WRITE TO SCRATCH BUFFER
          LJM    GSBX        RETURN

 GSBA     BSS    2           RESERVED AREA OF FAULT SYMPTOM CODE
 GSBB     DATA   12H
 GSC      SPACE  4,10
**        GSC - GENERATE FAULT SYMPTOM CODE FOR CPU.
*
*         THE ELEMENT IDENTIFIER USED IN THE FAULT SYMPTOM CODE DEPENDS ON
*         THE CPU ORDINAL:
*                C - PROCESSOR 0.
*                D - PROCESSOR 1.
*                E - PROCESSOR 2.
*                F - PROCESSOR 3.
*
*         CALLS  WFC.


          ROUTINE  GSC

          LDC    2RDC        PROCESSOR ELEMENT IDENTIFIER
          ADM    CPUO        INCREMENT BY CPU ORDINAL
          RJM    WFC         WRITE FAULT SYMPTOM CODE
          LJM    GSCX        RETURN
 GSI      SPACE  4,10
**        GSI - GENERATE FAULT SYMPTOM CODE FOR IOU.
*
*         THE ELEMENT IDENTIFIER USED IN THE FAULT SYMPTOM CODE DEPENDS ON
*         THE IOU ORDINAL:
*                I - IOU 0.
*                J - IOU 1.
*                K - IOU 2.
*                L - IOU 3.
*
*         CALLS  WFC.
 GSI      SPACE  4,10
**        GSI - GENERATE FAULT SYMPTOM CODE FOR IOU.
*
*         CALLS  WFC, *I4A*, *I4I*, *I4S*.


          ROUTINE  GSI

          LDDL   MD
          LMC    0#44
          NJN    GSI1        IF NOT MODEL 44
          CALL   I4I         INTERFACE TO MODEL 44 IOU FSC COMMON DECK
 GSI0     LJM    GSIX        RETURN

 GSI1     LDDL   MD
          LMC    0#42
          NJN    GSI2        IF NOT MODEL 42 IOU
          CALL   I4S
          UJN    GSI0

 GSI2     LDDL   MD
          LMC    0#40
          NJN    GSI3        IF NOT MODEL 40 IOU
          CALL   I4A
          UJN    GSI0

 GSI3     LDC    2RDI        IOU ELEMENT IDENTIFIER
          RJM    WFC         WRITE FAULT SYMPTOM CODE
          LJM    GSIX        RETURN


 GIE      SPACE  4,10
**        GIE - GENERATE INTERNAL ERROR FSC.
*
*         ENTRY  4XX, 5XX AND 6XX CODES ARE HANDLED.


          ROUTINE GIE

          LDDL   BC+BCDA
          LMC    0#240A
          NJN    GIE1        IF NOT SPECIAL 40A ANALYSIS
          LDC    2RDC
          ADM    CPUO
          UJN    GIE2        WRITE FAULT SYMPTOM CODE

 GIE1     LDM    IOUM
          STD    MD
          LDC    2RDI        IOU ELEMENT IDENTIFIER
          ADM    IOUN        NUMBER OF CURRENT IOU (LOWER 12 BITS ONLY)
 GIE2     RJM    WFC         WRITE FAULT SYMPTOM
          LJM    GIEX        RETURN
 GSM      SPACE  4,10
**        GSM - GENERATE FAULT SYMPTOM CODE FOR MEMORY.
*
*         CALLS  WFC.


          ROUTINE  GSM

          LDC    2RDM        MEMORY ELEMENT IDENTIFIER
          RJM    WFC         WRITE FAULT SYMPTOM CODE
          LJM    GSMX        RETURN
 GSP      SPACE  4,10
**        GSP - GENERATE FAULT SYMPTOM CODE FOR PAGE MAP.
*
*         PAGE MAP IS VALID ONLY ON AN S0.  THEREFORE, THIS ROUTINE
*         GENERATES AN ERROR.
*
*         EXIT   TO *ERRH*.


          ROUTINE  GSP

*         SETUP SCRATCH BUFFER CONTROL WORD.
*         DFT ANALYSIS - 61E DFT INTERNAL ERROR.

          SETDAN (EPUN,DAIE)
          LDC    TDFT+DAIE
          STML   RTP1
          CALL   ERRH
          SPACE  4,10
*copy     ctp$convert_digits_to_ascii
*copy     ctp$dft_write_fsc
*         END CTP$DFT_GENERATE_FAULT_SYMPTOM

*DECK DECK=CTP$DFT_GENERATE_I4C_CODES EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT GENERATE I4 CLASS IOU FAULT CODES.
*
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992

 GS4      SPACE  4,10
**        GS4 - GENERATE SYMPTOM CODE FOR MODEL 44 IOU.
*
*         USES   CM - CM+3.
*
*         CALLS  FMB, IOUFSC, WFS.


 GS4      SUBR               ENTRY/EXIT
          LDDL   BC+BCDA     GET ANALYSIS TO LOG
          SHN    -BC.ANP
          SBN    EPEN
          PJP    GS42        IF ENVIRONMENT WARNING
          LDML   CPU0M       CPU0 MODEL NUMBER
          STML   CDIF
          LDC    IFS1
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+1,ON
          LDC    IFS2
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRML   CDIF+5,ON
          LDN    EIMR
          RJM    FMB         FIND MAINTENANCE REGISTER BUFFER
          CRDL   W0
          LDDL   W2
          LPC    0#FF
          LMC    0#40
          STD    T1
          NJN    GS40        IF NOT MODEL 40 IOU
          LDN    OIMR
          RJM    FMB         FIND REGISTER IN MAINTENANCE REGISTER SCRATCH
          CRDL   W0
          LDDL   W3
          SHN    21-7
          PJN    GS45        IF NO CIO PPS PRESENT
          LDC    CIFS1
          RJM    FMB         FIND REGISTER IN MAINTENANCE REGISTER SCRATCH
          CRML   CDIF+9D,ON
          LDC    CIFS2
          RJM    FMB         FIND REGISTER IN MAINTENANCE REGISTER SCRATCH
          CRML   CDIF+13D,ON
          UJN    GS45        CREATE I4A FSC

 GS40     LDD    T1
          LMC    0#44
          NJP    GS4X        IF NOT MODEL 44 IOU
          LDC    CDIF        FWA OF INTERFACE BUFFER
          RJM    /IOUFLT4/IOUFLT4
          UJN    GS41

 GS45     BSS    0
          RJM    /IOUFLT0/IOUFLT0
 GS41     LDC    2RDI        IOU ELEMENT IDENTIFIER
          ADM    IOUO        INCREMENT BY IOU ORDINAL
          RJM    WFS         WRITE FAULT SYMPTOM CODE TO SUPPORTIVE STATUS
          UJP    GS4X        RETURN

 GS42     LDN    3
          STD    T1
 GS43     LDML   GS4A,T1     GET CANNED ENVIRONMENT FAULT SYMPTOM CODE
          STML   CDIF,T1     STORE IN OUTPUT BUFFER
          SOD    T1
          PJN    GS43        IF NOT DONE
          UJN    GS41        LOG THE FAULT CODE

 GS4A     DATA   H*701     *

*         END    CTP$DFT_GENERATE_I4C_CODES.
*DECK DECK=CTP$DFT_GENERATE_NO_I4C_CODES EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT GENERATE NO I4C CODES.
*
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
*
*         THIS DECK SATISFIES THE EXTERNAL *GS4* FOR THOSE VERSIONS OF *DFT*
*         WHICH DO NOT NEED TO EXECUTE IT.
 GS4      SPACE  4,10
**        GS4 - GENERATE SYMPTOM CODES FOR MODEL 44.


 GS4      SUBR               ENTRY/EXIT
          UJN    GS4X        RETURN

*         END    CTP$DFT GENERATE NO I4C CODES.
*DECK DECK=CTP$DFT_GET_COUNTER_ENTRY EXPAND=FALSE
 GCE      SPACE  4,10
**        GCE - GET COUNTER ENTRY.
*
*         ENTRY  (T1) = ID TO SEARCH THE COUNTERS BUFFER FOR.
*
*         EXIT   CM - CM+3 HOLDS THE COUNTER ENTRY FOUND.
*                W0 - W3 HOLDS POINTER TO ENTRY.
*                TO *ERRH* IF COUNTER VALUE NOT FOUND.


 GCE      SUBR               ENTRY/EXIT
          LDN    MECP
          RJM    IDA
          CRDL   W0          READ IN THE COUNTER BUFFER POINTER
          SODL   W3          FOR COUNTING
 GCE1     LDD    W0
          LRD    W1
          ADC    RR
          CRDL   CM          READ IN A COUNTER WORD
          LDDL   CM
          SHN    -10
          LMD    T1
          ZJN    GCEX        IF ENTRY FOUND
          AODL   W0
          SODL   W3
          PJN    GCE1        IF MORE TO CHECK

*         DFT ANALYSIS - LOST COUNTER VALUE FOR THIS ELEMENT.

          LDN    BC
          RJM    CLR
          SETDAN (EPUN,DACV)
          LDC    DACV+TDFT   61F - CANNOT FIND COUNTER VALUE
          STML   RTP1
          CALL   ERRH        ISSUE MESSAGE AND HANG
*DECK DECK=CTP$DFT_HALT_ON_ERROR_990 EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT_HALT_ON_ERROR_990
*
*         THIS DECK CONTROLS RETRY AND HALT ON ERROR
*         PROCESSOR DEC SETTINGS FOR THE 990
 HOE      SPACE  4,10
**        HOE - HALT ON ERROR.
*
*         ENTRY  DEDICATED FLAG IN DFT HEADER DETERMINES ACTION.
*
*         EXIT   *DEC* REGISTER SET/CLEAR FOR HALT ON ERROR.
*                CELL *HE* SET OR CLEARED DEPENDING ON DEDICATED FLAG.
*
*         CALLS  FHE, IDA, SHE.


          ROUTINE HOE

          LDN    HDRP
          RJM    IDA
          CRDL   CM          GET DFT HEADER
          LDDL   CM+DHFLG    GET FLAGS
          SHN    21-DH.FD    DEDICATED FLAG
          PJN    HOE1        IF DEDICATED MODE
          LDM    HALT
          ZJP    HOEX        IF NO HALT ON ERROR AND NON DEDICATED
          LDN    0
          STM    HALT        CLEAR HALT ON ERROR
          UJN    HOE2        CONTINUE

 HOE1     LDN    1
          STM    HOEB        MARK DEDICATED MODE
          LDM    HALT
          NJP    HOEX        IF DEDICATED AND HALT ON ERROR ALREADY SET
 HOE2     LDN    0
          STM    HOEA        SAVE ELEMENT COUNTER
          LDN    PROCID
 HOE3     RJM    FHE         FIND HARDWARE ELEMENT HBUF HOLDS RESULT
          MJP    HOEX        IF DONE WITH ALL ELEMENTS
          LDM    HBUF+CPUON
          LPN    1
          NJN    HOE4        IF DOWN
          LDM    HBUF+CPRE+EM  GET MODEL
          SHN    -4
          STD    MD
          RJM    SHE         SET HALT ON ERROR
 HOE4     AOM    HOEA        BUMP ELEMENT NUMBER
          SHN    14
          ADN    PROCID      SET UP PARAMETER TO FHE
          UJN    HOE3        LOOP

 HOEA     CON    0           ELEMENT COUNTER
 HOEB     CON    0           DEDICATED MODE FLAG
 SHE      SPACE  4,10
**        SHE - SET HALT ON ERROR.
*
*         EXIT   IF CYBER 990 AND DEDICATED, *HALT* = 1 AND
*                *DEC* REGISTER UPDATED.
*
*         USES   *HALT*.
*
*         MACROS READMR, WRITMR.


 SHE      SUBR               ENTRY/EXIT
          READMR RDATA,HBUF+HDRPC,DEMR

*         PROCESS CYBER 990/999B.

 SHE1     LDM    RDATA+2
          LPC    -0#40       CLEAR BIT
          STM    RDATA+2
          LDM    HOEB
          ZJN    SHE2        IF NOT DEDICATED
          LDN    1
          STM    HALT        SET HALT ON ERROR
          LDM    RDATA+2
          LMC    0#40        SET IT
          STM    RDATA+2
          LDML   MICL
          ZJN    SHE2        IF MICROCODE REVISION LEVEL < 18
          LDM    RDATA+5
          LMC    0#30
          STM    RDATA+5     SET RETRY COUNT
 SHE2     WRITMR RDATA,HBUF+HDRPC
          LJM    SHEX        RETURN

*         END CTP$DFT_HALT_ON_ERROR_990
*DECK DECK=CTP$DFT_HANDLE_IOU_BIT57 EXPAND=TRUE
*         CTP$DFT_HANDLE_IOU_BIT57
          QUAL   HB57
**
*         THE FOLLOWING STATEMENT IS USED ONLY TO DERIVE THE OVERLAY NUMBER
*         THAT THIS OVERLAY WILL BE ASSIGNED.  SINCE THE OVERLAY STARTS AT
*         10000 IT CANNOT BE "CALLED".
*
          ROUTINE SCO        USED ONLY TO GET THE OVERLAY NUMBER

 BCA      SUBR               ENTRY
          LDN    1
          STM    BI57        SET BIT 57 FLAG
          RJM    IDI         IDLE DRIVERS IN IOU
 BCA2     FUNCMR I0CC,MRMC   MASTER CLEAR THE CMI/ADU
          READMR RDATA,I0CC,DEMR
          LDM    RDATA+7
          LPC    0#EF        CLEAR TEST MODE ENABLED
          STM    RDATA+7
          WRITMR RDATA,I0CC,DEMR
          UJP    BCAX        RETURN


 IDI      SPACE  4,10
**        IDI - IDLE ALL I/O DRIVERS IN IOU.
*
*         EXIT   ALL PPS AND CHANNELS POSSIBLE ARE IDLED AND
*                MASTER CLEARED.
*
*         USES   T1, T4, T5.
*
*         CALLS  IVP, MCH.


 IDI      SUBR               ENTRY/EXIT

*         THIS SECTION WILL IDLE ALL POSSIBLE PPS IN THE IOU.  IT DEPENDS ON
*         ROUTINE IDP TIMING OUT THE WAIT FOR PP IDLE AND DOING NOTHING ABOUT IT.

          LDN    0           INITIAL PP TO START
          STD    T4
 IDI10    LDM    //PPNO
          LPN    0#1F
          SBD    T4
          ZJN    IDI15       IF DFT DONT IDLE
          LDN    1S5         CIO BIT
          SHN    10-5
          LMD    T4          ADD PP NUMBER
          RJM    IVP         IDLE PP
 IDI15    LDN    11B
          SBD    T4
          ZJN    IDI20       IF AT BREAK TO GO TO PP20
          AOD    T4
          SBN    32B
          MJN    IDI10       IF MORE PPS TO DO
          UJN    IDI30       GO MASTER CLEAR CHANNELS

 IDI20    LDN    20B
          STD    T4
          UJN    IDI10       CONTINUE IDLING PPS

*         THIS SECTION WILL MASTER CLEAR ALL POSSIBLE CHANNELS.

 IDI30    LDN    0
          STD    T4
 IDI80    LDN    1S5         CIO BIT
          SHN    10-5
          LMD    T4          ADD CHANNEL NUMBER
          RJM    MCH         MASTER CLEAR CHANNEL
          LDN    11B
          SBD    T4
          ZJN    IDI100      IF AT BREAK NEXT CHANNEL IS 20(8)
          AOD    T4
          SBN    32B
          MJN    IDI80       IF MORE CHANNELS TO DO
          LJM    IDIX        RETURN

 IDI100   LDN    20B
          STD    T4
          UJN    IDI80


 IVP      SPACE  4,10
**        IVP - IDLE VE PP.
*
*         ENTRY  (A) = PP TO IDLE.
*
*         USES   T3.
*
*         CALLS  IDP, SCF.


 IVP      SUBR               ENTRY/EXIT
          STDL   T3
          LDN    MX
          RJM    SCF         INTERLOCK TWO PORT MUX
 IVP1     LDDL   T3
          RJM    IDP         IDLE PP
 IVP2     CCF    *,MX
          UJN    IVPX        RETURN
 QUAL$    EQU    0

*COPY  DSI$DUMP_LOAD_IDLE_PP

 BI57     CON    0           BIT 57 FLAG
          QUAL   *
*         END    CTP$DFT_HANDLE_IOU_BIT57
*DECK DECK=CTP$DFT_IDLE_IOU1 EXPAND=FALSE
          CTEXT  CTP$DFT IDLE IOU1
          SPACE  4,10
          BASE   M
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 IDI      SPACE  4,10
**        IDI - IDLE ALL I/O DRIVERS IN IOU1.
*
*         EXIT   FOR IOU1, ALL LOGICALLY ON PP-S IN THE MRT
*                ARE IDLED.  ALL LOGICALLY ON CHANNELS ARE
*                MASTER CLEARED AND DCN-D (EXCEPT FOR CIO
*                CHANNELS, WHICH ARE NOT DCN-D).
*
*         USES   T1, T4, T5.
*
*         CALLS  FHE, IVP, MCH.


 IDI      SUBR               ENTRY/EXIT
          LDC    10000+IOUID FETCH IOU1 DESCRIPTOR FROM MRT
          RJM    FHE

*         FORCE *DFT-S* PP TO BE LOGICALLY OFF.

          LDM    //PPNO
          LPC    0#FF
          SBN    20          TEST FOR UPPER PP
          MJN    IDI10       IF LOWER
          ADC    SHNI
          STM    IDIA
          LDN    1
 IDIA     SHN    **
          RAM    HBUF+CIOPLM+1  FORCE PP TO BE LOGICALLY OFF
          UJN    IDI20       CONTINUE

 IDI10    LDM    //PPNO
          LPC    0#FF
          ADC    SHNI
          STM    IDIB
          LDN    1
 IDIB     SHN    **
          RAM    HBUF+CIOPLM FORCE PP TO BE LOGICALLY OFF

 IDI20    LDML   IOUM        CHECK IOU MODEL NUMBER
          LMC    0#43
          ZJP    IDI110      IF MODEL 43 IOU
          LMN    0#44&0#43
          NJN    IDI25       IF NOT MODEL 44 IOU
          LJM    IDI110      PRESET FOR MODEL 44 IOU

 IDI25    LDN    2           SET GROUP OFFSET
          STD    T5
 IDI30    LDM    IDID,T5     GET PP OFFSET
          STD    T1
          LDM    HBUF,T1
          LPC    1777
          LMC    1777
          STM    IDIG        PP STATUS
          LDM    IDIE,T5     GET CHANNEL OFFSET
          STD    T1
          LDM    HBUF,T1
          LMC    7777
          STM    IDIH        CHANNEL STATUS
          LDM    IDIF,T5     FIRST PP/CHANNEL NUMBER OF GROUP
          STD    T4
 IDI40    LDM    IDIG
          SHN    21-0
          STM    IDIG
          PJN    IDI70       IF PP IS LOGICALLY OFF
          LDD    T5
          SBN    2
 IDIJ     ZJN    IDI50       IF CIO PP
*         UJN    IDI50       (MODEL 44 IOU)
          LDD    T4
          UJN    IDI60       IDLE PP

 IDI50    LDN    1S5         CIO BIT
          SHN    10-5
          LMD    T4
 IDI60    RJM    IVP         IDLE PP
 IDI70    LDM    IDIH
          SHN    21-0
          STM    IDIH
          PJN    IDI100      IF CHANNEL IS LOGICALLY OFF
          LDD    T5
          SBN    2
 IDIK     ZJN    IDI80       IF CIO CHANNEL
*         UJN    IDI80       (MODEL 44 IOU)
          LDD    T4
          UJN    IDI90       MASTER CLEAR CHANNEL

 IDI80    LDN    1S5         CIO BIT
          SHN    10-5
          LMD    T4          ADD CHANNEL NUMBER
 IDI90    RJM    MCH         MASTER CLEAR CHANNEL
          LDD    T5
          SBN    2
 IDIL     ZJN    IDI100      IF CIO CHANNEL
*         UJN    IDI100      (MODEL 44 IOU)
          LDD    T4
          ADC    DCNI+40     DEACTIVATE POSSIBLE ACTIVE CHANNEL
          STM    IDIC
          PSN
 IDIC     DCN    **+40
 IDI100   AOD    T4          INCREMENT TO NEXT PP/CHANNEL IN TABLE
          SBK    46
          MJP    IDI40       IF NOT FINISHED WITH GROUP
          SOD    T5
          PJP    IDI30       IF ANOTHER GROUP TO PROCESS
          LJM    IDIX        RETURN

*         PRESET FOR MODEL 44 IOU.

 IDI110   ISTORE IDIJ,(UJN IDI50)
          ISTORE IDIK,(UJN IDI80)
          ISTORE IDIL,(UJN IDI100)
          LDN    1           SET GROUP OFFSET
          STDL   T5
          LJM    IDI30       GET PP OFFSET

 IDID     CON    7,10,15     OFFSETS TO PP STATUS
 IDIE     CON    12,13,15    OFFSETS TO CHANNEL STATUS
 IDIF     CON    0,20,0      STARTING PP NUMBERS FOR GROUPS
 IDIG     BSS    1           PP STATUS OF CURRENT GROUP
 IDIH     BSS    1           CHANNEL STATUS OF CURRENT GROUP
 IVP      SPACE  4,10
**        IVP - IDLE VE PP.
*
*         ENTRY  (A) = PP TO IDLE.
*
*         USES   T3.
*
*         CALLS  IDP, SCF.


 IVP      SUBR               ENTRY/EXIT
          STDL   T3
          LDN    MX
          RJM    SCF         INTERLOCK TWO PORT MUX
 IVP1     LDDL   T3
          RJM    IDP         IDLE PP
 IVP2     CCF    *,MX
          UJN    IVPX        RETURN


          BASE   *
          ENDX

*DECK DECK=CTP$DFT_INCREMENT_ERROR_COUNT EXPAND=FALSE
*         CTEXT  CTP$DFT_INCREMENT_ERROR_COUNT
 INC      SPACE  4,10
**        INC - INCREMENT COUNTERS.
*
*         THE CORRECTED, UNCORRECTED, UNLOGGED FIELDS OF THE
*         ASSOCIATED MAINFRAME ELEMENT COUNTERS BUFFER IS UPDATED.
*
*         EXIT   (A) < 0 = DONT LOG ERROR.
*                (A) > 0  LOG ERROR.
*
*         USES   T2, T3, T4, T5, CM - CM+3.
*
*         CALLS  CTV, IDA, SPB, VCK.


 INC      SUBR               ENTRY/EXIT
          LDN    VER2
          RJM    VCK         CHECK VERSION OF OS DFT BLOCK
          PJP    INC5        IF AT LEAST VERSION 2
          LDDL   BC+BCEI
          SHN    -10
          ADM    NBUF
          ADM    NUMHW       HEADER POINTERS BLOCK LENGTH
          STD    T3
          RJM    IDA
          CRDL   CM          GET COUNTER (I)
          LDDL   CM
          SHN    21-17
          PJN    INC.5
          LDN    0
          STM    INCA        IF THRESHOLD FLAG ALREADY SET DONT LOG
 INC.5    LDD    CM+METH
          NJN    INC0
          LDN    THRH        GET DEFAULT THRESHOLD
 INC0     STD    T4
          LDDL   BC+BCDA     DFT ANALYSIS CODE
          SHN    -BC.ANP
          STD    T2
          ZJN    INC1        IF ERROR PRIORITY = NONE
          LDN    EPUN
          SBD    T2
          ZJN    INC2        IF UNCORRECTED ERROR
          SBN    1
          ZJN    INC3        IF CORRECTED ERROR
          LDM    INCA
          LJM    INCX        RETURN

 INC1     AOD    CM+MEUL     UNLOGGED = UNLOGGED + 1
          UJP    INC4        CONTINUE PROCESSING

 INC2     AOD    CM+MEUN     UNCORRECTED = UNCORRECTED + 1
          SBD    T4
          MJN    INC4        IF BELOW THRESHOLD
          LDDL   CM
          SHN    21-17
          PJN    INC2.5
          AOD    CM+MEUL
          LDN    0
          STM    INCA
          UJN    INC4        CONTINUE

 INC2.5   LDN    1
          STM    LOGT        SET THRESHOLD MET
          STM    STON
          UJN    INC4        CONTINUE

 INC3     AOD    CM+MECO     CORRECTED = CORRECTED + 1
          SBD    T4
          MJN    INC4        IF BELOW THRESHOLD
          LDDL   CM
          SHN    21-17
          PJN    INC3.5
          AOD    CM+MEUL
          LDN    0
          STM    INCA
          UJN    INC4        CONTINUE

 INC3.5   LDN    1
          STM    LOGT
          STM    STON
 INC4     LDD    T3
          RJM    IDA
          CWDL   CM          REWRITE COUNTER
          LDM    INCA
          LJM    INCX        RETURN

 INC5     LDN    VER4
          RJM    VCK         CHECK VERSION
          PJP    INC11       IF VERSION 4 OR GREATER

          LDDL   BC+BCEI
          SHN    -10         ISOLATE ELEMENT INDEX
          ADM    NBUF
          ADM    NUMHW       NUMBER OF POINTER WORDS
          STD    T5
          RJM    IDA
          CRDL   CM          GET COUNTER (I)
          LDDL   BC+BCDA
          SHN    -BC.ANP     ISOLATE PRIORITY
          NJN    INC6        IF PRIORITY IS CORRECTED OR UNCORRECTED
 INC5.5   AODL   CM+MEUL     INCREMENT UNLOGGED COUNTER
          LDN    0
          STM    INCA        SET DONT LOG FLAG
          UJN    INC8        REWRITE COUNTER

 INC6     SBN    MECO        CORRECTED ERROR VALUE
          NJP    INC9        IF UNCORRECTED ERROR
          RJM    CTV         CALCULATE THRESHOLD VALUE
          MJN    INC5.5      IF NOT TO LOG ERRORS FOR THIS ELEMENT
          STD    T4
          LDDL   CM          GET THRESHOLDS
          SHN    21-17
          PJN    INC7        IF NO CURRENT THRESHOLD
          UJN    INC5.5      INCREMENT UNLOGGED COUNTER

 INC7     AOD    CM+MECO     INCREMENT CORRECTED COUNTER
          SBD    T4          SAVED THRESHOLD VALUE
          MJN    INC8        IF THRESHOLD NOT EXCEEDED
          LDD    T4
          ZJN    INC8        IF WANT ALL ERRORS LOGGED
          LDN    0
          STM    INCA        THRESHOLD MET DONT LOG ERROR
          LDN    1
          STM    LOGT        SET THRESHOLD MET FLAG
          STM    STON
          SHN    17
          LMDL   CM          SET CORRECTED THRESHOLD FLAG
          STDL   CM
 INC8     LRD    DP+1
          RJM    SPB         SET OS BOUNDS
          LDD    T5
          RJM    IDA
          CWDL   CM
          LDM    INCA
          LJM    INCX        RETURN

 INC9     RJM    CTV         CALCULATE THRESHOLD VALUE
          MJP    INC5.5      IF NOT TO LOG ERRORS FOR THIS ELEMENT
          STD    T4
          LDDL   CM          GET THRESHOLDS
          SHN    21-7
          PJN    INC10       IF NO CURRENT THRESHOLD
          LJM    INC5.5      INCREMENT UNLOGGED COUNTER

 INC10    AOD    CM+MEUN     INCREMENT UNCORRECTED COUNTER
          SBD    T4
          MJN    INC8        IF THRESHOLD NOT EXCEEDED
          LDD    T4
          ZJN    INC8        IF WANT ALL LOGGED
          LDN    1
          STM    LOGT        SET THRESHOLD MET FLAG
          STM    STON
          SHN    7
          LMDL   CM          SET UNCORRECTED THRESHOLD
          STDL   CM
          LJM    INC8        CONTINUE

 INC11    BSS    0           VERSION 4 PROCESSING

          LDDL   BC+BCDA
          SHN    -BC.ANP
          STD    T3          SAVE ERROR PRIORITY
          LDM    ETYP,ET     GET ELEMENT TYPE CTI CONVERSION
          STD    T1
          LDM    OTYP,ET     GET ORDINAL ADJUSTMENT ADDRESS
          STD    T2
          ZJN    INC12       IF ORDINAL CANNOT BE GREATER THAN 0
          LDI    T2
          SHN    4
          LMD    T1          FORM ORDINAL/TYPE FOR ID
          STD    T1
 INC12    RJM    GCE         GET COUNTER FOR THIS ID
          LDD    T1
          RJM    GTV         GET THRESHOLD VALUES FROM ECR
          LDD    T3
          ZJP    INC15       IF ZERO PRIORITY INCREMENT UNLOGGED COUNTER
          SBN    MECO
          ZJP    INC14       IF CORRECTED ERROR
          LDML   INCB+3
          ZJP    INC15       IF ZERO DONT LOG THE ERROR
          LMC    0#FFFF
          ZJP    INC16       IF ALWAYS LOG THE ERROR
          LDDL   CM
          LPN    3           GET THRESHOLD MET FLAGS
          SHN    -1
          NJP    INC15       IF THRESHOLD MET DONT LOG THE ERROR
          LDDL   CM+3
          SBML   INCB+3
          MJP    INC16       IF STILL BELOW THRESHOLD
          AODL   CM+1        BUMP THE UNLOGGED ERROR COUNTER
          LDN    1
          STM    LOGT        SET THRESHOLD MET FLAG
          STM    STON
          SHN    1
          LMDL   CM
          STDL   CM          SET THRESHOLD MET FLAG IN COUNTER
          LDN    0
          STM    INCA
 INC13    LRD    W1
          LDD    W0
          ADC    RR
          CWDL   CM          REWRITE COUNTER
          LDM    INCA
          LJM    INCX

 INC14    LDML   INCB+2
          ZJN    INC15       IF ZERO DONT LOG THE ERROR
          LMC    0#FFFF
          ZJN    INC16       IF ALWAYS LOG THE ERROR
          LDDL   CM
          LPN    1           GET CORRECTED ERROR THRESHOLD MET
          NJN    INC15       IF THRESHOLD MET DONT LOG THE ERROR
          LDDL   CM+2
          SBML   INCB+2
          MJN    INC16       IF NOT AT THRESHOLD YET
          AODL   CM+1        BUMP THE UNLOGGED COUNT
          LDN    1
          STM    LOGT        SET THRESHOLD MET FLAG
          STM    STON
          LMDL   CM
          STDL   CM          SET THE THRESHOLD MET FLAG IN THE COUNTER
          LDN    0
          STM    INCA
          LJM    INC13       WRITE THE COUNTER

 INC15    AODL   CM+1        INCREMENT UNLOGGED COUNTER
          LDN    0
          STM    INCA
          LJM    INC13       WRITE THE COUNTER

 INC16    LDD    T3          GET ERROR PRIORITY
          SBN    MECO
          ZJN    INC17       IF CORRECTED
          AODL   CM+3        BUMP UNCORRECTED COUNT
          LJM    INC13       WRITE COUNTER

 INC17    AODL   CM+2        BUMP CORRECTED ERROR COUNT
          LJM    INC13       WRITE COUNTER
*COPY CTP$DFT_GET_COUNTER_ENTRY
 GTV      SPACE  4,10
**        GTV - GET THRESHOLD VALUE.
*
*         ENTRY  (A) = ID TO SEARCH ECR FOR
*
*         EXIT   (INCB) = THRESHOLDS FOR UNCORRECTED OR CORRECTED ERRORS
*                TO *ERRH* IF THRESHOLD VALUE NOT FOUND.
*
*         USES   T4 - T7, W4 - W7, INCA - INCA+3.


 GTV      SUBR               ENTRY/EXIT
          STM    GTVA        SAVE ID
          LDN    ECRP
          RJM    IDA
          CRDL   T4          READ IN THE ECR POINTER WORD
          LDD    T4
          LRD    T5
          ADC    RR
          CRDL   W4          READ IN ECR HEADER WORD
          SODL   W7          DECREMENT NUMBER OF ENTRIES FOR COUNTING
          AODL   T4          GET PAST HEADER
 GTV1     LDDL   T4
          ADC    RR
          CRML   INCB,ON     READ IN ELEMENT ID WORD
          LDML   INCB
          LMML   GTVA
          ZJP    GTV2        IF FOUND CORRECT WORD
          LDDL   W6          ENTRY SIZE
          RADL   T4          BUMP OFFSET
          SODL   W7
          PJN    GTV1        IF MORE TO EXAMINE

*         DFT ANALYSIS - LOST COUNTER VALUE FOR THIS ELEMENT.

          LDN    BC
          RJM    CLR
          SETDAN (EPUN,DATV)
          LDC    DATV+TDFT   620 - CANNOT FIND THRESHOLD VALUE
          STML   RTP1
          CALL   ERRH        ISSUE MESSAGE AND HANG

 GTV2     AODL   T4
          ADC    RR
          CRML   INCB,ON     READ IN THE THRESHOLD ENTRY
          LJM    GTVX

 GTVA     CON    0

 INCA     CON    1           LOG FLAG
 INCB     BSSZ   4

*         END    CTP$DFT_INCREMENT_ERROR_COUNT
*DECK DECK=CTP$DFT_LOG_COUNTERS EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT_LOG_COUNTERS
*
*         THIS DECK CONTAINS CODE TO PROCESS TOP OF HOUR
*         STATISTICS

          QUAL   *
 LGC      SPACE  4,10
**        LGC - LOG COUNTERS.
*
*         CALLS  CLR, GNE, IDA, IMB, PAC, SLS, SPB, /DSIGHE/RHT, *LOG*.


          ROUTINE LGC
          LDM    RMCF
          NJN    LGC0        IF ALREADY THRU RMC THIS TOP OF HOUR
          CALL   RMC         RESET ANY MODEL DEPENDENT COUNTERS
 LGC0     LRD    DP+1
          RJM    SPB         SET THE OS BOUNDS

*         TOP OF HOUR PROCESSING DOES NOT NEED INFORMATION
*         SUPPLIED BY *ET* *EI* CELLS. IN THIS CASE THEY ARE ZEROED.

          LDN    0
          STD    EI          ELEMENT INDEX
          STD    ET          ELEMENT TYPE
          LDN    BC
          RJM    CLR         CLEAR TEMPORARY BUFFER CONTROL WORD
          LDN    VER5
          RJM    VCK         CHECK VERSION
          PJP    LGC2        IF VERSION 5 OR GREATER
          LDN    VER4
          RJM    VCK
          PJP    LGC1        IF VERSION 4
          RJM    LM3         LOG MAINFRAME ELEMENT COUNTERS PRE VERSION 4
          RJM    /LGC/ZMR
          LDM    ELCO        NUMBER OF ELEMENTS
          STD    T3
          LDN    0
          RJM    IMB         INCREMENT MAINTENANCE REGISTER BUFFER
          CWML   LGCC,T3     WRITE COUNTERS TO SCRATCH MAINTENANCE REGISTER BUFFER
          LDN    0
          STM    RTP1
          CALL   LOG         LOG THE DATA
          LDN    BC
          RJM    CLR
          RJM    PSI         PREPARE SECDED ID TABLE
          RJM    /LGC/ZMR    ZERO OUT MAINTENANCE REGISTER BUFFER
          LDN    0
          RJM    IMB
          CWML   LGCA,W7     WRITE TABLE TO MAINTENANCE REGISTER BUFFER
          CALL   LOG
          RJM    CZF         CLEAR Z FLAG
          LJM    LGCX        RETURN

 LGC1     RJM    LM4         LOG MAINFRAME ELEMENT COUNTERS VERSION 4 AND GREATER
          LDN    0
          RJM    IMB         INCREMENT MAINTENANCE REGISTER BUFFER
          CWML   LGCC,T3
          LDN    0
          STM    RTP1
          CALL   LOG         LOG THE DATA
          LDN    BC
          RJM    CLR
          RJM    PSI         PREPARE SECDED ID TABLE
          RJM    /LGC/ZMR
          LDN    0
          RJM    IMB         INCREMENT MAINTENANCE REGISTER BUFFER
          CWML   LGCA,W7
          LDN    0
          STM    RTP1
          CALL   LOG         LOG THE DATA
          RJM    CZF         CLEAR THE Z FLAG
          UJP    LGCX        RETURN

 LGC2     LDM    TOHI        GET CURRENT PHASE OF PROCESSING
          STD    T1
          LJM    0,T1

 LGC3     RJM    CFB         CHECK FOR FREE BUFFER
          MJP    LGCX        IF BUFFER NOT AVAILABLE
          LDN    1
          STM    RTP1
          RJM    LM4         SETUP ELEMENT COUNTERS FOR VERSION 4 OR GREATER
          LDN    NRSP
          RJM    IDA         INCREMENT POINTER ADDRESS
          CRDL   CM
          LRD    CM+1
          LDD    CM
          ADC    RR+1+5
          CWML   LGCC,T3     WRITE COUNTERS TO SCRATCH NRSB
          LDN    NRSBL-1
          ADD    T3
          STM    LLOG
          CALL   LOG
          LDC    LGC4
          STM    TOHI        SAVE NEXT PHASE TO PROCESS
 LGC4     RJM    CFB         CHECK FOR FREE BUFFER
          MJP    LGCX        IF BUFFER NOT AVAILABLE
          LDN    BC
          RJM    CLR
          RJM    PSI         PREPARE SECDED ID TABLE
          LDN    NRSP
          RJM    IDA         INCREMENT POINTER ADDRESS
          CRDL   CM
          LRD    CM+1
          LDD    CM
          ADC    RR+1+5
          CWML   LGCA,W7     WRITE SECDED ID DATA TO NON REGISTER SCRATCH
          LDN    1
          STM    RTP1
          LDN    NRSBL-1
          ADD    W7
          STM    LLOG
          CALL   LOG         LOG SECDED ID DATA
          CALL   TPD         TEST PATH TO DEDICATED LOAD DEVICE
          RJM    RPT         RESET PIT
          LDC    LGC5
          STML   TOHI        SET NEXT EXECUTION POINT
 LGC5     LDML   PKTCW
          NJP    LGCX        IF PACKET CONTROL WORD IS CURRENTLY BUSY
          CALL   RED         READ 960 EPM DATA
          LDC    LGC3        SET STARTING PROCEDURE
          STML   TOHI
          RJM    CZF         CLEAR THE Z FLAG
          LJM    LGCX        RETURN
 CZF      SPACE  4,10
**        CZF - CLEAR THE Z FLAG.
*
*         CALLS  IDA, SET, SPB.
*
*         USES   CM - CM+3.
*
*         NOTE   THE Z FLAG INDICATES TOP OF HOUR PROCESSING BY DFT. IT
*                IS SET BY THE OPERATING SYSTEM AND CLEARED BY DFT.


 CZF      SUBR               ENTRY/EXIT
          LDN    CM
          RJM    SET         SET UP LOCK WORD
          LMBC   DH.FZ
          STDL   CM+3
          LRD    DP+1
          RJM    SPB         SET PP BOUNDS
          LDN    HDRP
          RJM    IDA
          RDCL   CM          READ AND CLEAR LOCK
          LDN    0
          STM    RMCF        CLEAR RESET MODEL DEP COUNTERS FLAG
          UJN    CZFX        RETURN
 LM3      SPACE  4,10
**        LM3 - LOG MAINFRAME ELEMENT COUNTERS VERSION 3.
*
*         CALLS  GNE, IDA, RHT.
*
*         USES   CM - CM+3, T2, T3, T4.


 LM3      SUBR               ENTRY/EXIT

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = PROCESS MAINFRAME ELEMENT COUNTERS.
*         DFT ANALYSIS - ERROR PRIORITY = TOP OF HOUR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAN (EPTH,DATHM)
          SETFLG (BC.FL)
          LDDL   BC+BCDA
          LPC    0#F0FF
          ADC    0#0700      ELEMENT ID IS NOT MEANINGFUL
          STDL   BC+BCDA
          LDM    ELCO        COUNT OF ELEMENTS IN MAINFRAME
          STD    T3          SAVE FOR MOVES
          LDM    NBUF
          ADM    NUMHW
          RJM    IDA
          CRML   LGCC,T3      READ IN ELEMENT COUNTERS

*         ZERO THE COUNTERS AREA.

          LDM    NBUF
          ADM    NUMHW
          STD    T4
          LDM    ELCO
          SBN    1
          STD    T3
 LM31     LDD    T4
          ADD    T3
          RJM    IDA
          CRDL   CM          GET COUNTER (I)
          LDDL   CM
          LPC    0#7F7F      CLEAR THRESHOLD EXCEEDED BITS
          STDL   CM
          LDN    0
          STD    CM+1
          STD    CM+2
          STD    CM+3
          LDD    T4
          ADD    T3
          RJM    IDA
          CWDL   CM          REPLACE COUNTER(I)
          SOD    T3
          PJN    LM31        IF MORE TO DO

*         PUT ELEMENT TYPE IN THRESHOLD FIELD OF COUNTER ENTRY.

          RJM    /DSIGHE/RHT
          LDN    0
          STD    T2
 LM32     RJM    GNE         GET AN ELEMENT
          MJP    LM3X        IF NO MORE ELEMENTS
          STM    LGCC,T2     STORE ELEMENT TYPE IN THRESHOLD FIELD
          LDN    4
          RAD    T2
          UJN    LM32        PROCESS NEXT ELEMENT
          LJM    LM3X        RETURN
 LM4      SPACE  4,10
**        LM4 - LOG MAINFRAME ELEMENT COUNTERS VERSION 4.
*
*         CALLS  GNE, IDA, SLS, RHT.
*
*         USES   CM - CM+3, T2, T3, T4.


 LM4      SUBR               ENTRY/EXIT

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = PROCESS MAINFRAME ELEMENT COUNTERS.
*         DFT ANALYSIS - ERROR PRIORITY = TOP OF HOUR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAN (EPTH,DATHM)
          SETFLG (BC.FL)
          LDDL   BC+BCDA
          LPC    0#F0FF
          ADC    0#0700      ELEMENT ID IS NOT MEANINGFUL
          STDL   BC+BCDA
          LDN    MECP
          RJM    IDA
          CRDL   W0          READ IN THE MEC POINTER WORD
          LDC    MTMEC*10000 MRB TYPE FOR MEC
          ADDL   W3          LOGGED MRB SIZE
          RJM    SLS         SET LOGGED MRB SIZE/TYPE IN SUPPORTIVE STATUS
          LDDL   W3
          STDL   T3          SAVE LENGTH OF COUNTERS
          STDL   CM+1
          LRD    W1
          LDD    W0
          ADC    RR
          CRML   LGCC,T3     READ IN THE COUNTERS BUFFER

*         RIGHT JUSTIFY THE ID FIELD OF EACH MAINFRAME ELEMENT COUNTERS
*         ENTRY.

          LDN    0
          STD    CM
 LM41     LDML   LGCC,CM
          SHN    -10
          STML   LGCC,CM
          LDN    4           POSITION TO NEXT CENTRAL MEMORY WORD
          RADL   CM
          SODL   CM+1
          NJN    LM41        IF MORE TO RIGHT JUSTIFY

*         ZERO THE COUNTERS AREA.

 LM42     LDD    W0
          ADC    RR
          CRDL   CM          READ IN COUNTER (I)
          LDDL   CM
          LPC    0#FF00
          STDL   CM          CLEAR ANY THRESHOLD EXCEEDED FLAGS
          LDN    0
          STD    CM+1
          STD    CM+2
          STD    CM+3
          LDD    W0
          ADC    RR
          CWDL   CM
          AOD    W0          GET TO NEXT ELEMENT COUNTER
          SOD    W3
          NJN    LM42        IF MORE TO DO
          LJM    LM4X        RETURN
 PSI      SPACE  4,10
**        PSI - PROCESS SECDED ID TABLE.
*
*         EXIT   (W7) = NUMBER OF WORDS TO TRANSFER.
*                (LGCC) = FORMATTED SECDED ID TABLE DATA.
*
*         CALLS  CLR, IDA, PAC, SLS, VCK.
*
*         USES   MRVAL, T3, W4 - W7.


 PSI      SUBR               ENTRY/EXIT

*         SET UP SCRATCH BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ANALYSIS = PROCESSING SECDED ID TABLE.
*         DFT ANALYSIS - ERROR PRIORITY = TOP OF HOUR.
*         DFT ANALYSIS - FLAGS = LOG (OS).

          SETDAN (EPTH,DATHS)
          SETFLG (BC.FL)
          LDDL   BC+BCDA
          LPC    0#F0FF
          ADC    0#0700      ELEMENT ID IS NOT MEANINGFUL
          STDL   BC+BCDA
          LDN    SECP        SECDED ID TABLE POINTER
          RJM    IDA
          CRDL   W4          SECDED ID TABLE POINTER
          LDM    LBUF
          SBD    W7
          PJN    PSI1        IF SECDED ID TABLE < BUFFER SIZE
          LDM    LBUF
          STD    W7
 PSI1     LDC    MTSIT*10000 MRB TYPE FOR SECDED ID TABLE
          ADDL   W7          LOGGED MRB SIZE
          RJM    SLS         SET LOGGED MRB SIZE/TYPE IN SUPPORTIVE STATUS
          LRD    W5
          LDD    W4
          ADC    RR
          CRML   LGCC,W7      READ IN SECDED ID TABLE

*         GET THE OPTIONS INSTALLED REGISTER AND PLACE AT THE
*         BEGINNING OF THE LOGGED SECDED ID TABLE ENTRIES.

 PSI2     READMR RDATA,CMCC,OIMR
          RJM    PAC         PACK THE REGISTER
          LDN    3
          STD    T3
 PSI3     LDML   MRVAL,T3
          STML   LGCA,T3
          SOD    T3
          PJN    PSI3        IF MORE TO DO

*         GET THE *EID* REGISTER AND POSITION AFTER THE *OI* REGISTER.
*         IF AT VERSION 2 OR GREATER.

          LDN    VER2
          RJM    VCK         CHECK VERSION
          MJN    PSI5        IF NOT VERSION 2
          READMR RDATA,CMCC,EIMR
          RJM    PAC         PACK THE REGISTER
          LDN    3
          STD    T3
 PSI4     LDML   MRVAL,T3
          STML   LGCB,T3
          SOD    T3
          PJN    PSI4        IF MORE TO DO

*         ZERO THE SECDED ID TABLE.

 PSI5     LDN    CM
          RJM    CLR
          LDD    W7
          SBN    1
          STD    T3
 PSI6     LDD    W4
          ADD    T3
          ADC    RR
          CWDL   CM
          SOD    T3
          PJN    PSI6        IF MORE TO DO
          AOD    W7          ADD ROOM FOR OPTIONS INSTALLED REGISTER
          AOD    W7          ADD ROOM FOR *EID* REGISTER
          LJM    PSIX        RETURN
 CFB      SPACE  4,10
**        CFB - CHECK FOR FREE TOP OF HOUR BUFFER.
*
*         EXIT   (A) < 0  ENTRY IS NOT AVAILABLE TO BE LOGGED TO.
*
*         CALLS  IDA.
*
*         USES   W0 - W3, CFBA - CFBA+3.


 CFB      SUBR               ENTRY/EXIT
          LDN    NRSP
          RJM    IDA
          CRDL   W0          READ IN NON REGISTER STATUS BUFFER POINTER
          LRD    W1
          LDD    W0
          ADC    RR
          CRML   CFBA,ON     READ IN HEADER VALUE FOR NUMBER OF ELEMENTS AND SIZE
          LDD    W0          POINTER TO BEGINNING PF NON REGISTER BUFFER
          ADML   CFBA+3      ADD ELEMENT SIZE TO GET TO FIRST ENTRY
          ADC    RR+1        ADD IN BUFFER HEADER WORD
          CRML   CFBA,ON     READ IN BUFFER CONTROL WORD FOR TOP OF HOUR ENTRY
          LDML   CFBA+2
          SHN    21-3
          MJP    CFBX        IF LOGGING FLAG SET
          LDML   CFBA+2
          SHN    21-2        INTERLOCK FLAG
          LJM    CFBX

 CFBA     BSSZ   4
 SLS      SPACE  4,10
**        SLS - SET LOGGED MRB SIZE IN SCRATCH SUPPORTIVE STATUS BUFFER.
*
*         ENTRY  (A) = 6/MRB TYPE, 12/LOGGED MRB SIZE.
*
*         USES   T2, T3, CM - CM+3.
*
*         CALLS  IDA, VCK.


 SLS      SUBR               ENTRY/EXIT
          STD    T3          SAVE LOGGED MRB SIZE
          SHN    -14         SAVE MRB TYPE
          STD    T2
          LDN    VER4        CHECK *DFT* VERSION NUMBER
          RJM    VCK
          MJN    SLSX        IF LESS THAN VERSION 4
          LDN    VER5
          RJM    VCK         CHECK VERSION
          PJN    SLS2        IF VERSION 5 OR GREATER
          LDN    SSBP        READ SUPPORTIVE STATUS HEADER WORD
          RJM    IDA
          CRDL   CM
          AODL   CM          SKIP TO SCRATCH ENTRY HEADER WORD
          LRD    CM+1
          ADC    RR
          CRML   SLSA,ON
          LDDL   T3          SET LOGGED MRB SIZE
          STML   SLSA+3
          LDDL   T2          SET MRB TYPE
          RAML   SLSA
 SLS1     LDDL   CM          REWRITE HEADER WORD
          ADC    RR
          CWML   SLSA,ON
          UJP    SLSX        RETURN

 SLS2     LDN    NRSP
          RJM    IDA
          CRDL   CM
          AODL   CM          SKIP BUFFER HEADER WORD
          AODL   CM          SKIP BUFFER CONTROL WORD
          LRD    CM+1
          ADC    RR
          CRML   SLSA,ON
          LDN    NRSBL-1     VERSION 5 NON REGISTER BUFFER ENTRY BASE SIZE
          RAD    T3
          STML   SLSA+3      LENGTH TO LOG
          LDDL   T2
          STML   SLSA+2
          UJN    SLS1

 SLSA     BSS    4
          QUAL   LGC
 ZMR      SPACE  4,10
**        ZMR - ZERO MAINTENANCE REGISTER BLOCK 0.
*
*         EXIT   MAINTENANCE REGISTER BLOCK 0 INITIALIZED TO ZERO.
*
*         USES   T1.
*
*         CALLS  IMB.


 ZMR      SUBR               ENTRY/EXIT
          LDN    0
          STD    T1
 ZMR1     LDD    T1
          RJM    IMB
          CWML   ZERO,ON
          AOD    T1
          SBM    LBUF
          PJN    ZMRX        IF DONE
          UJN    ZMR1        LOOP

 ZERO     BSSZ   4
          QUAL   *

*         LGCC DENOTES THE START OF A BUFFER USED TO HOLD THE
*         MAINFRAME ELEMENT COUNTERS AND THE SECDED ID TABLE.
*         *LGCA* INCLUDES SPACE FOR TWO CM WORDS FOR *OI* AND *EID*
*         REGISTERS WHEN WRITING THE SECDED ID TABLE.

 LGCA     BSS    4           *OI* REGISTER
 LGCB     BSS    4           *EID* REGISTER
 LGCC     EQU    *           START OF LOGGED SECDED ID TABLE ENTRIES

*         END CTP$DFT_LOG_COUNTERS


*DECK DECK=CTP$DFT_LOG_ERROR EXPAND=FALSE
*         CTEXT CTP$DFT_LOG_ERROR
*
*         THIS DECK HOLDS ROUTINES TO LOG ERRORS TO THE
*         APPROPRIATE BUFFER CONTROL WORDS AND/OR TO THE
*         SYSTEM CONSOLE
 LOG      SPACE  4,10
**        LOG - LOG ERROR IN BUFFER CONTROL WORDS.
*
*         CALLS  ABL, CFM, CLR, FCW, IBW, IDA, INC, ISS, MMB, SET, SPB,
*                STF, URC, ZSS, *GSC*, *DSI*, *DSM*, *DSP*.


          ROUTINE LOG

*         IF THE ANALYSIS CODE IS 4XX, 5XX OR 6XX AND THE VERSION
*         OF THE *DFT* INTERFACE IN EFFECT IS LESS THAN 5, THEN
*         THE ERROR IS NOT TO BE LOGGED.

          LDN    VER5
          RJM    VCK         CHECK VERSION
          PJN    LOG0.4      IF VERSION 5 OR GREATER
          LDDL   BC+BCDA     CHECK ANALYSIS CODE
          SHN    -10
          LPN    0#F
          LMN    4
 LOG0.3   ZJP    LOGX        IF ANALYSIS CODE IS NOT TO BE LOGGED
          LMN    5&4
          ZJN    LOG0.3      IF ANALYSIS CODE IS NOT TO BE LOGGED
          LMN    6&5
          ZJN    LOG0.3      IF ANALYSIS CODE IS NOT TO BE LOGGED
 LOG0.4   LDN    0
          STM    LOGB
          LRD    DP+1
          RJM    SPB         SET PP BOUNDS
          LDDL   BC+BCDA     DFT ANALYSIS
          SHN    -BC.ANP
          STD    T1
          SBN    EPTH+1
          MJN    LOG0        IF ERROR IS .LE. TOP OF HOUR DONT INCREMENT
          LDD    T1
          SBN    EPEN
          PJN    LOG0.5      IF ERROR IS ENVIRONMENT OR SHORT DONT INC COUNTERS
          RJM    INC         INCREMENT COUNTERS
          NJN    LOG0        IF THRESHOLD NOT EXCEEDED
          LDN    1
          STM    NERR        RESET NO ERROR FLAG FOR RELEASE OF THE LAST LOGGED ENTRY
          LJM    LOG16       IF THRESHOLD EXCEEDED DONT LOG

 LOG0     LDN    VER5
          RJM    VCK         CHECK VERSION
          MJN    LOG1        IF LESS THAN VERSION 5
 LOG0.5   LDM    RTP1
          NJP    LOG3
 LOG1     LDM    FREE
          ZJP    LOG3        IF NO CURRENT ENTRY

*         IF A CURRENT ENTRY EXISTS CHECK IF WHAT IS ABOUT TO BE LOGGED
*         MATCHES WHATS ALREADY LOGGED IF IT DOES THEN SET MULTIPLE
*         OCCURRENCE BIT AND EXIT. IF NO MATCH THEN CLEAR INTERLOCK ON
*         EXISTING (FREE) ENTRY AND GET ANOTHER ENTRY TO LOG TO.

          RJM    ABL         ADJUST BUFFER LENGTH (VALID ONLY ON THETA)
          RJM    CFM         CHECK FOR MATCH
          NJP    LOG2        IF NO MATCH
          RJM    URC         UPDATE RETRY COUNTERS (VALID ONLY ON THETA)
          LDM    FREE
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          CRDL   CM          BUFFER CONTROL WORD (FREE)
          LDDL   CM+BCDA
          SHN    21-BC.MO
          MJP    LOG14       IF ALREADY SET
          LDDL   CM+BCDA
          ADK    MUOC        SET MULTIPLE OCCURRENCE BIT
          STDL   CM+BCDA
          LDM    FREE
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          CWDL   CM          REWRITE ENTRY
          RJM    STF
          LJM    LOG14       RETURN

 LOG2     LDN    CM
          RJM    SET
          LMBC   (BC.FI)     CLEAR INTERLOCK FLAG
          STDL   CM+BCFLG
          LDM    FREE
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          RDCL   CM          CLEAR INTERLOCK ON FREE BUFFER CONTROL WORD
          LDN    0
          STM    DSIF        DFT HAS REMOVED THE I/L ON THE BUFFER CONTROL WORD

*         IF C180 ERROR OR NOS/VE LOGGING OR VALID C180 ERROR SET
*         C180 ERROR IN DFT HEADER.

          CHECK  E8

*         IF C170 ERROR OR NOS / NOS/BE LOGS OR VALID C170 ERROR SET
*         C170 ERROR IN DFT HEADER.

          CHECK  E7

          LDN    0
          STM    VOSD        CLEAR VALID OS DATA ACCUMULATOR
          STM    FREE
 LOG3     RJM    FCW         FIND A NEW CURRENT BUFFER CONTROL WORD
          LDM    LOGB
          NJN    LOG4        IF AVAILABLE ENTRY FOUND
          LDDL   BC+BCDA
          LPC    0#FFF       SET ERROR PRIORITY TO NONE (ZERO)
          STDL   BC+BCDA
          SHN    -10
          STD    T2
          SBN    6
          ZJN    LOG3.5      IF 6XX ERROR
          LDD    T2
          SBN    5
          ZJN    LOG3.5      IF 5XX ERROR
          LDD    T2
          SBN    4
          NJN    LOG3.6      IF NOT 4XX ERROR
 LOG3.5   LDN    4
          STD    ET          SET ELEMENT TYPE TO DFT INTERNAL ERROR
 LOG3.6   RJM    INC         INCREMENT UNLOGGED COUNTER
          LJM    LOG12       RETURN

*         INITIALIZE SUPPORTIVE STATUS FOR IOU, MEMORY, PROCESSOR AND
*         PAGE MAP ERRORS.  FOR ANY OTHER ERROR TYPE, A BLANK FAULT
*         SYMPTOM CODE IS GENERATED.

 LOG4     LDN    VER4
          RJM    VCK         CHECK VERSION
          MJP    LOG9.5      IF LESS THAN VERSION 4
          LDDL   BC+BCDA
          SHN    -BC.ANP
          LPN    0#F
          SBN    EPEN
          MJN    LOG4.1      IF LESS THAN ENVIRONMENT WARNING
          LDD    ET
          UJN    LOG4.2

 LOG4.1   LDDL   BC+BCDA
          SHN    -10
          LPN    0#F
 LOG4.2   NJN    LOG5        IF NOT IOU
          ERRNZ  IOUID       CODE DEPENDS ON ZERO VALUE
          CALL   GSI         GENERATE IOU FAULT SYMPTOM CODE
          UJP    LOG9        INITIALIZE SUPPORTIVE STATUS

 LOG5     SBN    CMID-IOUID
          NJN    LOG6        IF NOT CM
          CALL   GSM         GENERATE CM FAULT SYMPTOM CODE
          UJP    LOG9        INITIALIZE SUPPORTIVE STATUS

 LOG6     SBN    PROCID-CMID
          NJN    LOG7        IF NOT PROCESSOR
          CALL   GSC         GENERATE PROCESSOR FAULT SYMPTOM CODE
          UJP    LOG9        INITIALIZE SUPPORTIVE STATUS

 LOG7     SBN    DFTPMID-PROCID
          NJN    LOG8        IF NOT PAGE MAP
          CALL   GSP         GENERATE PAGE MAP FAULT SYMPTOM CODE
          UJN    LOG9        INITIALIZE SUPPORTIVE STATUS

 LOG8     LDDL   BC+BCDA
          SHN    -10
          LPN    0#F
          STD    T1
          LMN    5
          ZJN    LOG8.5      IF 5XX ANALYSIS CODE
          LDD    T1
          LMN    6
          ZJN    LOG8.5      IF 6XX ANALYSIS CODE
          LDD    T1
          LMN    4
          ZJN    LOG8.5      IF 4XX ANALYSIS CODE
          UJN    LOG8.6

 LOG8.5   CALL   GIE         GENERATE FAULT SYMPTOM CODE FOR 5XX AND 6XX MESSAGES
          UJN    LOG9

 LOG8.6   CALL   GSB         GENERATE BLANK FAULT SYMPTOM CODE
 LOG9     RJM    ISS         INITIALIZE SCRATCH SUPPORTIVE STATUS
 LOG9.5   RJM    STF
          RJM    MMB         MOVE REGISTERS FROM TEMPORARY TO LOGB
          LDN    HDRP
          RJM    IDA
          CRDL   CM          GET DFT HEADER

*         PREPARE TO MOVE THE SEQUENCE COUNT FROM
*         DFT HEADER TO BUFFER CONTROL WORD ENTRY.

          LDC    0#FF
          LPDL   BC+BCSEQ    CLEAR THE SEQUENCE (FOR REPETITIVE CALLS)
          STDL   BC+BCSEQ
          LDDL   CM+DHSEQ
          SHN    10
          LPC    0#FF00      INSURE JUST THE SEQUENCE NUMBER IS USED
          RADL   BC+BCSEQ
          LDM    LOGB        READ BUFFER CONTROL WORD (LOGB) FOR OFFSET
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          CRDL   CM
          LDDL   BC+BCEI     TRANSFER ELEMENT INDEX AND OS ACTION CODE
          STDL   CM+BCEI
          LDDL   BC+BCDA     TRANSFER DFT ANALYSIS AND PRIORITY
          STDL   CM+BCDA
          LDM    LOGT        CHECK IF THRESHOLD EXCEEDED
          ZJN    LOG10       IF THRESHOLD NOT EXCEEDED
          SETFLG (BC.TE)     SET THRESHOLD EXCEEDED FLAG
 LOG10    LDDL   CM+BCSEQ
          LPN    0#4         SAVE THE INTERLOCK BIT
          STDL   CM+BCSEQ
          LDDL   BC+BCSEQ    TRANSFER SEQUENCE NUMBER AND FLAGS
          RADL   CM+BCSEQ

*         NOTE: THE FOLLOWING WILL PRESERVE THE 170, 180 VALID DATA FLAGS
*         FOR THE EVENTUAL SETTING IN THE DFT CONTROL WORD. THIS IS DONE IN THE
*         CASE OF MULTIPLE CALLS TO LOG IN THE PROCESSING OF AN ERROR.

          LDDL   BC+BCSEQ    GET FLAGS
          LPN    3           ONLY CARE ABOUT V170, V180
          STDL   T1
          LCN    0
          LMDL   T1
          LPML   VOSD
          LMDL   T1
          STML   VOSD        PRESERVE ORING OF BITS ACROSS MULTIPLE CALLS


*         NOTE - KEEP THE OFFSET IN THE BUFFER CONTROL WORD INTACT.
          LDM    LOGB
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          CWDL   CM          WRITE JUST BUILT ENTRY TO (LOGB) ENTRY
          LDN    HDRP
          RJM    IDA
          CRDL   CM          GET DFT HEADER
          LDDL   CM
          ADN    1           INCREMENT HEADER SEQUENCE NUMBER
          LPC    0#FF        MOD 256
          STD    T2
          NJN    LOG11       IF COUNT HASNT ROLLED OVER
          LDN    1
          STD    T2          RESET HEADER SEQUENCE TO 1
 LOG11    LDN    CM
          RJM    SET
          LDC    0#FF00      RETAIN NUMBER OF POINTERS + HEADER VALUE
          STDL   CM+DHSEQ
          LDN    HDRP
          RJM    IDA
          RDCL   CM          CLEAR OLD SEQUENCE
          LDN    CM
          RJM    CLR
          LDDL   T2
          LMDL   CM+DHSEQ    MERGE NUMBER OF POINTERS AND NEW SEQUENCE
          STDL   CM+DHSEQ
          LDN    HDRP
          RJM    IDA
          RDSL   CM          REWRITE HEADER (*RDSL* MUST BE USED)

*         UPDATE CONSOLE LOGGING CONTROL WORD IF NECESSARY.

          LDML   CELCW       CHECK CONSOLE LOGGING STATUS
          NJN    LOG12       IF CONSOLE LOGGING IN PROGRESS
          LDDL   BC+BCFLG    CHECK CONSOLE LOGGING FLAG
          SHN    21-BC.CL
          PJN    LOG12       IF CONSOLE LOGGING NOT REQUIRED
          LDM    LOGB        RECORD MRB TO BE LOGGED TO CONSOLE
          STM    CELCW
 LOG12    RJM    ZSS         ZERO THE SUPPORTIVE STATUS SCRATCH BUFFER
          LDM    RTP1
          ZJP    LOG13       IF LOGGING TO BUFFER CONTROL WORDS
 LOG12.5  LDN    CM
          RJM    SET
          LDDL   CM+BCFLG
          LMBC   (BC.FI)     INTERLOCK FLAG
          STDL   CM+BCFLG
          LDM    LOGB
          RJM    IBW         INDEX TO BUFFER CONTROL WORD
          RDCL   CM          CLEAR INTERLOCK FLAG
          LDN    0
          STM    DSIF
          STM    RTP1
          CHECK  E7
          CHECK  E8
          UJP    LOGX        RETURN

 LOG13    LDM    LOGB
          STM    FREE        SAVE INDEX OF BUFFER CONTROL WORD USED
          LJM    LOGX        RETURN

 LOG14    RJM    ZSS         ZERO SUPPORTIVE STATUS
 LOG15    LJM    LOGX

 LOG16    RJM    ZSS         ZERO SUPPORTIVE STATUS
          LDM    RTP1
          NJP    LOG12.5     IF LOGGING TO NRSB
          UJN    LOG15       RETURN


 LOGT     CON    0           FLAG FOR THRESHOLD LOG CONDITION
 LOGA     BSSZ   4           TEMPORARY RETRY COUNTER STORAGE
 STF      SPACE  4,10
**        STF - SET THRESHOLD FLAG.
*
*         EXIT   THRESHOLD FLAG DENOTING THAT A CORRECTED OR
*                UNCORRECTED COUNT HAS EXCEEDED THE THRESHOLD
*                VALUE IS SET IN ELEMENT COUNTERS BUFFER.
*
*         USES   T3, CM - CM+3.
*
*         CALLS  IDA.


 STF      SUBR               ENTRY/EXIT
          LDN    VER2
          RJM    VCK
          PJN    STFX        IF VERSION 2 OR GREATER IGNORE
          LDM    LOGT
          ZJN    STFX        IF NOT APPLICABLE
          LDDL   BC+BCEI
          SHN    -10
          ADM    NBUF
          ADM    NUMHW
          STD    T3
          RJM    IDA
          CRDL   CM          ELEMENT COUNTER (I)
          LDDL   CM
          LMC    0#8000
          STDL   CM
          LDD    T3
          RJM    IDA
          CWDL   CM
          UJN    STFX        RETURN
 MMB      SPACE  4,10
**        MMB - MOVE MAINFRAME BUFFER.
*
*         EXIT   CONTENTS OF SCRATCH MAINTENANCE REGISTER BUFFER IS
*                MOVED TO MAINTENANCE REGISTER BUFFER (LOGB).
*                CONTENTS OF SCRATCH SUPPORTIVE STATUS BUFFER IS
*                MOVED TO SUPPORTIVE STATUS BUFFER (LOGB).
*
*         USES   T1, T2, T3, CM - CM+3, W0 - W3.
*
*         CALLS  CLR, IBW, IDA.


 MMB      SUBR               ENTRY/EXIT
          LDN    VER5
          RJM    VCK         CHECK VERSION
          MJN    MMB0        IF LESS THAN VERSION 5
          LDM    RTP1
          NJP    MMB1.5      IF VERSION 5 AND LOGGING TO NON REGISTER STATUS BUFFER
 MMB0     LDN    5
          STD    T2          NUMBER OF CM WORDS TO MOVE AS A BLOCK
          LDN    0
          STD    T3          AMOUNT MOVED
          LDN    MRBP
          RJM    IDA
          CRDL   W0          MAINTENANCE REGISTER BUFFER POINTER
          LDM    LOGB
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          CRDL   CM          GET OFFSET TO (LOGB) BUFFER ENTRY
          LRD    W1
 MMB1     LDD    W0          READ NEXT BLOCK
          ADC    RR
          CRML   MMBB,T2
          LDD    CM+3        GET THE OFFSET TO REGISTER BUFFER (LOGB)
          ADD    W0
          ADC    RR
          CWML   MMBB,T2     WRITE BLOCK TO REGISTER BUFFER (LOGB)
          LDN    5
          RAD    W0
          LDN    5
          RADL   T3
          SBM    LBUF
          NJN    MMB1        IF MORE TO MOVE

          LDN    VER4
          RJM    VCK         CHECK VERSION
          MJP    MMBX        IF LESS THAN VERSION 4
          UJN    MMB1.6

*         MOVE SCRATCH SUPPORTIVE STATUS TO SUPPORTIVE STATUS BUFFER (LOGB).

 MMB1.5   LDN    NRSP
          UJN    MMB1.7

 MMB1.6   LDN    SSBP        SUPPORTIVE STATUS BUFFER POINTER
 MMB1.7   RJM    IDA
          CRDL   W0
          LRD    W1          READ SUPPORTIVE STATUS HEADER WORD
          LDD    W0
          ADC    RR
          CRDL   CM          (CM+3) = ELEMENT SIZE
          LDN    0           DETERMINE OFFSET TO (LOGB) ENTRY = (LOGB)*SIZE
          STD    T1
          LDML   LOGB
          STD    T2
 MMB2     LDDL   CM+3        MULTIPLY (LOGB) * SIZE
          RADL   T1
          SOD    T2
          NJN    MMB2        IF MULTIPLICATION NOT COMPLETE
          AODL   W0          SKIP TABLE HEADER WORD
          STDL   T2          SAVE SCRATCH BUFFER OFFSET
          ADD    T1          OFFSET TO (LOGB) BUFFER ENTRY
          STDL   CM
          LDDL   CM+3        SAVE ENTRY SIZE
          STDL   T3
 MMB3     LDD    W0          READ FROM SCRATCH BUFFER
          ADC    RR
          CRML   MMBB,ON
          LDD    CM          WRITE TO (LOGB) BUFFER
          ADC    RR
          CWML   MMBB,ON
          AODL   W0
          AODL   CM
          SOD    CM+3
          NJN    MMB3        IF MORE TO MOVE
          LJM    MMBX        RETURN

 MMBB     BSS    5*4         TEMPORARY BUFFER
 ISS      SPACE  4,10
**        ISS - INITIALIZE SUPPORTIVE STATUS.
*
*         EXIT   FIRST TWO WORDS OF SCRATCH SUPPORTIVE STATUS BUFFER
*                INITIALIZED.
*
*         USES   T1,T2,T3, CM - CM+3.
*
*         CALLS  IDA, IIB.


 ISS      SUBR               ENTRY/EXIT
          LDN    VER5
          RJM    VCK         CHECK VERSION
          MJN    ISS0        IF LESS THAN VERSION 5
          LDM    RTP1
          NJP    ISS4        IF TO LOG TO THE NON REGISTER STATUS
 ISS0     LDN    SSBP        READ HEADER WORD
          RJM    IDA
          CRDL   CM
          AODL   CM          SKIP TO SCRATCH ENTRY HEADER WORD
          LRD    CM+1
          ADC    RR
          CRML   ISSA,ON

*         SET UP ENTRY HEADER WORD.

          LDDL   BC+BCDA     GET ELEMENT TYPE
          SHN    -10
          LPN    0#F
          STD    T2
          LMN    7
          NJN    ISS0.5      IF NOT TOP OF HOUR
          LDN    4
          SHN    10
          LMML   ISSA
          STML   ISSA
          UJN    ISS2

 ISS0.5   LDM    ETYP,T2
          STD    T3          SAVE HARDWARE ELEMENT TYPE CONVERSION
          LDM    OTYP,T2
          ZJN    ISS1        IF NO ORDINAL POSSIBLE
          STD    T1
          LDI    T1          GET ORDINAL NUMBER
          SHN    4
 ISS1     LMDL   T3          OR IN ORDINAL + TYPE
          SHN    10
          LMML   ISSA        OR INTO ELEMENT TYPE FIELD IN SUPPORTIVE STATUS
          STML   ISSA
          LDD    T2          RESTORE ELEMENT ID
          SBN    PROCID
          NJN    ISS2        IF NOT PROCESSOR ERROR
          LDN    6           SET LENGTH FOR PROCESSOR SUPPORTIVE STATUS
          UJN    ISS3        SET LENGTH

 ISS2     LDN    3           SET LENGTH FOR NON-PROCESSOR SUPPORTIVE STATUS
 ISS3     STM    ISSA+1

*         SET DATE AND TIME.

          LDN    DFCM+7
          RJM    IIB
          CRML   ISSA+4,ON

*         WRITE ENTRY TO SCRATCH SUPPORTIVE STATUS BUFFER.

          LDN    2           SET NUMBER OF CM WORDS TO WRITE
          STD    T2
          LDDL   CM
          LRD    CM+1
          ADC    RR
          CWML   ISSA,T2     WRITE TO SCRATCH BUFFER
          LJM    ISSX        RETURN

 ISS4     LDN    NRSP        READ HEADER WORD
          RJM    IDA
          CRDL   CM
          AODL   CM          SKIP TO SCRATCH ENTRY HEADER WORD
          AODL   CM          SKIP PAST BUFFER CONTROL WORD
          LRD    CM+1
          ADC    RR
          CRML   ISSA,ON

*         SET UP ENTRY HEADER WORD.

          LDDL   BC+BCDA     GET ELEMENT TYPE
          SHN    -10
          LPN    0#F
          STD    T2
          LMN    7
          NJN    ISS4.01     IF NOT TOP OF HOUR
          LDDL   BC+BCDA
          SHN    -BC.ANP
          SBN    EPEN
          PJN    ISS4.1      IF ENVIRONMENT WARNING
          LDM    LLOG
          STM    ISSA+3      LENGTH TO LOG
          LDN    4
          SHN    10
          LMML   ISSA+2
          STML   ISSA+2      SET NO ASSOCIATED ELEMENT ID
          UJP    ISS6        IF TOP OF HOUR NO CONVERSION

 ISS4.01  LDD    T2
          LMN    6
          ZJN    ISS4.1      IF 6XX ANALYSIS CODE
          LDD    T2
          LMN    5
          ZJN    ISS4.1      IF 5XX ANALYSIS CODE
          LDD    T2
          LMN    4
          ZJN    ISS4.1      IF 4XX CODE
          LDD    T2
          LMN    2
          NJN    ISS4.5      IF NOT CPU RELATED CODE
 ISS4.1   LDN    MTNRB
          STM    ISSA+2
          LDDL   BC+BCDA
          LMC    0#2407
          ZJN    ISS4.4      IF 407 ANALYSIS
          LDDL   BC+BCDA
          LMC    0#2408
          NJN    ISS4.5      IF 407 0R 408 ANALYSIS
 ISS4.4   LDN    6           SET DATA TYPE TO EPM DATA
          UJP    ISS4.6

 ISS4.5   LDN    4           SET DATA TYPE TO DFT INTERNAL
 ISS4.6   SHN    10
          LMML   ISSA+2      OR INTO ELEMENT TYPE FIELD IN SUPPORTIVE STATUS
          STML   ISSA+2
          LDM    LLOG        GET LENGTH TO LOG
          STM    ISSA+3

*         SET DATE AND TIME.

 ISS6     LDN    DFCM+7
          RJM    IIB
          CRML   ISSA+4,ON

*         WRITE ENTRY TO SCRATCH SUPPORTIVE STATUS BUFFER.

          LDN    2           SET NUMBER OF CM WORDS TO WRITE
          STD    T2
          LDDL   CM
          LRD    CM+1
          ADC    RR
          CWML   ISSA,T2     WRITE TO SCRATCH BUFFER
          LJM    ISSX        RETURN

 ISSA     BSS    4*2         SCRATCH BUFFER HEADER AND TIME WORDS
 CTV      SPACE  4,10
**        CTV - CALCULATE THRESHOLD VALUE.
*
*         ENTRY  (A) <> 0 UNCORRECTED PRIORITY.
*                (A) = 0 CORRECTED PRIORITY.
*
*         EXIT   (A) = CALCULATED THRESHOLD VALUE.
*
*         USES   T1, T2.
*
*         NOTE   A DONT CARE CASE EXISTS IF THRESHOLD EXCEEDED  IS SET.


 CTV      SUBR               ENTRY/EXIT
          NJN    CTV1        IF UNCORRECTED
          LDDL   CM          GET CORRECTED ERROR THRESHOLD
          SHN    -10
          LPC    0#7F        GET EXPONENT VALUE
          UJN    CTV2        CONTINUE

 CTV1     LDD    CM
          LPC    0#7F        GET UNCORRECTED THRESHOLD
 CTV2     STD    T1
          ZJN    CTVX        IF ZERO THRESHOLD LOG ALL ERRORS
          SHN    21-6
          MJN    CTVX        IF DONT WANT ANY ERRORS LOGGED
          LDN    1
          STD    T2          RESULTING POWER OF TWO VALUE
          SOD    T1          ACCOUNT FOR COUNTING FROM ZERO
 CTV3     LDDL   T2
          SHN    1           I := I * 2**1
          STD    T2
          SOD    T1
          PJN    CTV3        IF NOT THRU MULTIPLYING POWERS OF TWO
          LDDL   T2          RETURN RESULT
          UJN    CTVX        RETURN
 PTF      SPACE  4,10
**        PTF - PROCESS DUAL STATE TRANSITION FLAG.
*
*         ENTRY  DUAL STATE TRANSITION BACK TO 170 STANDALONE FLAG IS
*                SET IN THE DFT HEADER WORD.
*
*         EXIT   ALL BUFFER CONTROL WORD ENTRIES WITH VALID 180 FLAGS
*                SET WILL HAVE THOSE FLAGS CLEARED.
*
*         CALLS  CLR, IDA, SET, SPB.
*
*         NOTE   INTERLOCKING THE ENTRY IS NOT NECESSARY BECAUSE NOS/VE
*                IS NOT LOGGING; HOWEVER, *RDCL* IS USED TO CLEAR THE
*                FLAG.

          ROUTINE PTF

          LRD    DP+1
          RJM    SPB         SET PP BOUNDS
          LDN    1
          STD    T2          FIRST USABLE BUFFER CONTROL WORD
          LDM    NBUF
          SBN    2
          STD    T1          NUMBER OF CONTROL WORDS - 1 - SCRATCH ENTRY
 PTF1     LDD    T2
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          CRDL   CM          BUFFER CONTROL WORD (I)
          LDDL   CM+BCFLG
          SHN    21-BC.FV8   180 VALID DATA FLAG
          PJN    PTF2        IF NOT PRESENT

*         WE HAVE AN ENTRY WITH VALID DATA FOR NOS/VE, BUT NOS/VE IS
*         DOWN.  PERFORM A READ AND CLEAR LOCK ON VALID 180 DATA BIT
*         TO MAKE THE ENTRY AVAILABLE.

          LDN    CM
          RJM    SET
          LDN    1
          SHN    BC.FV8
          LMDL   CM+BCFLG    CLEAR VALID 180 DATA BIT
          STDL   CM+BCFLG
          LDD    T2
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          RDCL   CM
 PTF2     AOD    T2
          SOD    T1
          PJN    PTF1        LOOP

*         NEXT CLEAR THE TRANSITION BIT IN THE DFT HEADER
*         ALSO, CLEAR THE C180 ERROR FLAG AND SET THE
*         C170 ERROR FLAG TO CHECK FOR ANY LOGGING REMAINING.

          LDN    CM
          RJM    SET
          LDN    1
          SHN    DH.DT       POSITION TO TRANSITION BIT
          LMDL   CM+DHFLG
          STDL   CM+DHFLG
          LDN    1
          SHN    DH.FE8      POSITION TO C180 ERROR FLAG
          LMDL   CM+DHFLG
          STDL   CM+DHFLG    CLEAR C180 ERROR FLAG
          LDN    HDRP
          RJM    IDA
          RDCL   CM
          LDN    CM
          RJM    CLR         CLEAR FOR SETTING C170 ERROR FLAG
          LDN    1
*         SHN    DH.FE7      POSITION TO C170 ERROR FLAG
          STD    CM+DHFLG
          LDN    HDRP
          RJM    IDA
          RDSL   CM          SET C170 ERROR FLAG
          LJM    PTFX        RETURN

*         END CTP$DFT_LOG_ERROR
*DECK DECK=CTP$DFT_LOG_ERROR_CHECK_MATCH EXPAND=FALSE
*         CTEXT  CTP$DFT_LOG_ERROR_CHECK_MATCH
 CFM      SPACE  4,10
**        CFM - CHECK FOR MATCH BETWEEN NEW ERROR AND PREVIOUS ERROR AT *FREE*.
*
*         ENTRY  (A) = BUFFER LENGTH TO COMPARE.
*
*         EXIT   (A) <> 0 NO MATCH.
*
*         USES   T1, T2, T3, T4, W0 - W7.
*
*         CALLS  IDA.


 CFM      SUBR               ENTRY/EXIT
          STDL   T4          STORE BUFFER LENGTH
          LDM    FREE
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          CRDL   W4          GET BUFFER CONTROL WORD (FREE) OFFSET
          LDN    MRBP
          RJM    IDA
          CRDL   W0          MAINTENANCE REGISTER BUFFER POINTERS
          LDDL   W4+BCDA     INTERLOCKED ANALYSIS CODE
          LPC    0#7FF       CLEAR MULT OCCUR BIT AND PRIORITY
          SBDL   BC+BCDA     CURRENT ANALYSIS CODE
          NJP    CFMX        IF NOT SAME ANALYSIS CODE
          LDD    W4+BCOFF
          ADD    W0
          STD    T1          OFFSET TO (FREE) BUFFER
          LDDL   T4          LOAD BUFFER LENGTH
          SBN    1
          STD    T2
          LRD    W1
 CFM1     LDD    W0
          ADC    RR
          CRML   CFMA,ON     TEMPORARY BUFFER ENTRY
          LDD    T1          LOGGED BUFFER OFFSET
          ADC    RR
          CRML   CFMB,ON     LOGGED BUFFER ENTRY
          LDN    3
          STD    T3          PP WORD COUNT
 CFM2     LDML   CFMA,T3
          SBML   CFMB,T3
          NJP    CFMX        IF THEY DONT MATCH
          SOD    T3
          PJN    CFM2
          AOD    W0          BUMP TEMPORARY OFFSET
          AOD    T1          BUMP LOGGED OFFSET
          SOD    T2
          PJN    CFM1        IF MORE TO COMPARE
          LDN    0           CHECKED OUT OK
          LJM    CFMX        RETURN

 CFMA     BSS    4           TEMPORARY BUFFER SAVE AREA
 CFMB     BSS    4           LOGGED BUFFER SAVE AREA

*         END    CTP$DFT_LOG_ERROR_CHECK_MATCH
*DECK DECK=CTP$DFT_LOG_ERROR_NON_990 EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT_LOG_ERROR_NON_990
*
*         THIS DECK CONTAINS STUBS FOR ROUTINES WHICH EXIST ONLY
*         ON 990 MODELS
 ABL      SPACE  4,10
**        ABL - ADJUST BUFFER LENGTH.
*
*         EXIT   (A) = BUFFER LENGTH.
*
*         NOTE   ON MACHINES OTHER THAN THETA THE VALUE RETURNED
*                IS LBUF.

 ABL      SUBR               ENTRY/EXIT
          LDML   LBUF
          UJN    ABLX        RETURN
 URC      SPACE  4,10
**        URC - UPDATE RETRY COUNTERS.
*
*         NOTE   ON MACHINES OTHER THAN THETA THIS IS A NO OP.

 URC      SUBR               ENTRY/EXIT
          UJN    URCX

*         END CTP$DFT_LOG_ERROR_NON_990
*DECK DECK=CTP$DFT_LOG_ERROR_NO_CONSOLE EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT_LOG_ERROR_NO_CONSOLE
 LTC      SPACE  4,10
**        LTC - LOG ERROR TO CONSOLE.
*
*         NOTE THIS ROUTINE IS TO BE USED WHEN THERE IS NO
*         CONSOLE TO LOG ERRORS TO BUT PACKET COMMUNICATION
*         IS NECESSARY.

          ROUTINE LTC
          LJM    LTCX

*         END CTP$DFT_LOG_ERROR_NO_CONSOLE
*DECK DECK=CTP$DFT_LOG_PACKET_TIMEOUT EXPAND=FALSE
 LPT      SPACE  4,10
**        LPT - LOG PACKET TIMEOUT.
*
*

          ROUTINE LPT

          LDML   PKTCW       SAVE CONTROL WORD
          STML   LPTA
          LDML   PKSEQ       SAVE SEQUENCE NUMBER
          STML   LPTA+1
          LRD    DP+1
          RJM    SPB         SET OS PP BOUNDS
          LDN    BC
          RJM    CLR         CLEAR SCRATCH CONTROL WORD
          LDN    0
          STD    ET
*
*         ERROR PRIORITY - CORRECTED.
*         DFT ANALYSIS - PACKET HAS TIMED OUT WITH NO RESPONSE.
*         FLAGS - LOGGING.
*
          SETDAN (EPCO,DATO)
          SETFLG (BC.FL)
          LDN    NRSP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   CM
          LRD    CM+1
          LDD    CM
          ADC    RR+1+NRSBL
          CWML   LPTA,ON
          LDN    NRSBL
          STM    LLOG
          LDN    1
          STM    RTP1
          CALL   LOG         LOG THE ERROR
          LJM    LPTX        RETURN

 LPTA     BSSZ   4           SCRATCH FOR CONTROL WORD DATA

*         END    CTP$DFT_LOG_PACKET_TIMEOUT
*DECK DECK=CTP$DFT_LOG_PACKET_TO_CONSOLE EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT LOG PACKET TO CONSOLE.
*
*         THIS COMMON DECK CONTAINS THE CODE TO LOG AN MRB OR THE MRT
*         TO THE CONSOLE.  AT THIS TIME, ONLY S0/S0E USE THIS FEATURE.
 LTC      SPACE  4,10
**        LTC - LOG INFORMATION TO CONSOLE.
*
*         ENTRY  (*CELCW*) = MRB NUMBER TO BE LOGGED.
*                          = 77, IF MRT IS TO BE TRANSFERRED.
*
*                ON REENTRY:
*                (FNUM) = FILE NUMBER RETURNED BY CONSOLE ON *OPEN* CALL.
*                (FSIZ) = FILE SIZE RETURNED BY CONSOLE ON *OPEN* CALL.
*                (*CELCW*) = RESPONSE PENDING SET IF APPROPRIATE.
*                (*CELCW*) = PHASE:
*                            0 = OPEN CONSOLE FILE.
*                            1 = WRITE FIRST BLOCK TO CONSOLE FILE.
*                            2 = WRITE SECOND BLOCK TO CONSOLE FILE.
*                            3 = CLOSE CONSOLE FILE.
*                            4 = CLEAR LOGGING FLAG IN MRB AND CHECK FOR MORE.
*
*         EXIT   (*CELCW*) = 0, IF NO MORE LOGGING TO BE PERFORMED.
*                (*CELCW*) UPDATED, IF INTERMEDIATE PHASE.
*                (*CELCW*) = NEW MRB TO BE LOGGED, IF NECESSARY.
*
*         USES   T1, T2, T3.
*
*         CALLS  CCF, CRS, GLH, MMD, PFC, SCF, SMP, VCK, *PKT*.


          ROUTINE  LTC

          LDN    VER4        CHECK DFT VERSION
          RJM    VCK
          MJP    LTC7        IF BELOW DFT VERSION 4, IGNORE LOGGING
          LDN    0
          STM    RTP1        INITIALIZE SCRATCH
          LDML   CELCW       CHECK CONTROL WORD
          SHN    21-17
          PJP    LTC2        IF NO RESPONSE PENDING
          SHN    21-16-21+17
          PJN    LTC0        IF NOT TIMED OUT
          CALL   LPT         LOG PACKET TIMEOUT
          LDML   CELCW       GET MRB BEING PROCESSED
          LPN    77
          STD    T2
          LDM    LTCA+4      PREPARE FOR PHASE 4
          STD    T3
          LJM    0,T3        EXECUTE PHASE 4

 LTC0     RJM    CRS         CHECK RESPONSE STATUS
          ZJP    LTCX        IF NO RESPONSE PACKET AVAILABLE

*         RECEIVE RESPONSE PACKET.

          LDM    CELCW       CLEAR RESPONSE PENDING
          STM    CELCW
          LDN    0           CLEAR TIMER CONTROL WORD
          STM    PKTIM
          LDN    40          REQUEST = RECEIVE PACKET
          STM    CALB+0
          LDC    TOIP        BUFFER ADDRESS = *2AP* BUFFER (AT 2000)
          STML   CALB+2
          LDN    MX          GET CHANNEL 15 INTERLOCK
          RJM    SCF
          CALL   PFC         CALL *2AP*
          CCF    *,MX        RELEASE CHANNEL 15 INTERLOCK
          CALL   CER         CHECK FOR ERRORS
          LDM    CELCW       CHECK LOGGING PHASE
          SHN    -6
          NJN    LTC1        IF NOT FILE OPEN PHASE
          LDML   TOIP+1      SAVE FILE NUMBER RETURNED BY CONSOLE
          STML   FNUM
          LDML   TOIP+2      SAVE FILE SIZE RETURNED BY CONSOLE
          STML   FSIZ
 LTC1     LDC    100         ADVANCE TO NEXT PHASE
          RAM    CELCW
          LJM    LTCX        RETURN

*         PROCESS NEXT PHASE.

 LTC2     LDML   CELCW       UNPACK CONTROL WORD
          SHN    14
          STD    T1          (T1) = PHASE
          SHN    6
          LPN    77
          STD    T2          (T2) = MRB TO LOG
          LDD    T1          CHECK VALIDITY OF PHASE
          SBN    LTCAL
          PJP    LTC10       IF PHASE NOT DEFINED
          LDM    LTCA,T1     SET PHASE PROCESSOR
          STD    T3
          LJM    0,T3        EXECUTE PHASE

*         PHASE 0 - OPEN CONSOLE FILE.
*
*         WHEN LOGGING OF CORRECTED ERRORS IS SUPPORTED, CODE WILL BE REQUIRED
*         TO DETERMINE THE FILENAME BASED ON CORRECTED/UNCORRECTED STATUS.

 LTC3     LDN    PKFOF       FUNCTION = OPEN FILE
          STM    CALB+1
          LDN    1+1+2+12D   LENGTH = 16 (SOURCE ID, FUNCTION, MODE, NAME)
          STM    CALB+3
          LDN    PKOWR       MODE = WRITE
          STML   TOIPS0+1
          LDD    T2          DETERMINE CONSOLE FILENAME TO OPEN
          LMN    77
          NJN    LTC3.1      IF NOT MRT TRANSFER
          LDC    LTCD        CHANGE FILENAME TO *MRT.NVE*
          STM    LTCE
          AOM    L2AP        FORCE *2AP* (AND MRT-S) TO BE RELOADED
 LTC3.1   LDN    0           MOVE FILENAME TO PACKET BUFFER
          STD    T1
 LTC3.2   LDML   LTCB,T1     FILENAME = *DFT.UNC* (UNCORRECTED ERROR)
*         LDML   LTCC,T1     FILENAME = *DFT.COR* (CORRECTED ERROR - FUTURE)
*         LDML   LTCD,T1     FILENAME = *MRT.NVE* (MRT TRANSFER)
 LTCE     EQU    *-1         (ADDRESS OF FILENAME)
          STML   TOIPS0+2,T1
          AOD    T1
          LMN    12D/2
          NJN    LTC3.2      IF MORE TO BE MOVED
          LJM    LTC8        SEND PACKET

*         PHASE 1 - WRITE FIRST BLOCK OF DATA TO CONSOLE FILE.

 LTC4     LDN    PKFWT       FUNCTION = WRITE FILE
          STM    CALB+1
          LDML   FNUM        FILE NUMBER = (SAVED BY *OPEN* PHASE)
          STML   TOIPS0+1
          LDML   FSIZ        FILE SIZE = (SAVED BY *OPEN* PHASE)
          STML   TOIPS0+2
          LDD    T2          DETERMINE TYPE OF TRANSFER
          LMN    77
          NJN    LTC4.1      IF NOT MRT TRANSFER
          RJM    MMD         MOVE MRT DATA INTO PACKET BUFFER
          UJN    LTC4.2      CONTINUE

 LTC4.1   RJM    GLH         GENERATE LOGGING HEADER
          RJM    SMP         SET MRB PARAMETERS
          CRML   TOIPS0+3+10*4,T3  READ MRB INFORMATION INTO PACKET BUFFER
          LDN    10          INCLUDE HEADER LENGTH
          RAD    T3
 LTC4.2   LDD    T3          ADVANCE *FSIZ* FOR NEXT WRITE
          SHN    3
          STD    T3          SAVE DATA BYTE COUNT
          RAML   FSIZ
          LDD    T3          CALCULATE TOTAL PACKET LENGTH
          ADN    1+1+2+2     (SOURCE ID, FUNCTION, FNUM, FSIZ)
          STM    CALB+3
          LJM    LTC8        SEND PACKET

*         PHASE 2 - WRITE SECOND BLOCK OF DATA TO CONSOLE FILE.

 LTC5     LDN    PKFWT       FUNCTION = WRITE FILE
          STM    CALB+1
          LDML   FNUM        FILE NUMBER = (SAVED BY *OPEN* PHASE)
          STML   TOIPS0+1
          LDML   FSIZ        FILE SIZE = (*OPEN* SIZE + BLOCK ONE SIZE)
          STML   TOIPS0+2
          LDD    T2          DETERMINE TYPE OF TRANSFER
          LMN    77
          NJN    LTC5.1      IF NOT MRT TRANSFER
          RJM    MMD         MOVE MRT DATA INTO PACKET BUFFER
          UJN    LTC5.2      CONTINUE

 LTC5.1   RJM    SMP         SET MRB PARAMETERS
          CRML   TOIPS0+3,T3 READ MRB INFORMATION INTO PACKET BUFFER
 LTC5.2   LDD    T3          CALCULATE TOTAL PACKET LENGTH
          SHN    3
          ADN    1+1+2+2     (SOURCE ID, FUNCTION, FNUM, FSIZ)
          STM    CALB+3
          LJM    LTC8        SEND PACKET

*         PHASE 3 - CLOSE CONSOLE FILE.

 LTC6     LDN    PKFCF       FUNCTION = CLOSE FILE
          STM    CALB+1
          LDN    1+1+2       LENGTH = 4 (SOURCE ID, FUNCTION, FNUM)
          STM    CALB+3
          LDML   FNUM        FILE NUMBER = (SAVED BY *OPEN* PHASE)
          STML   TOIPS0+1
          UJN    LTC8        SEND PACKET

*         PHASE 4 - CLEAR LOGGING FLAG IN MRB AND EXIT.

 LTC7     LDN    0           CLEAR FILE NUMBER AND FILE SIZE
          STM    FNUM
          STM    FSIZ
          RJM    CCF         CLEAR CONSOLE LOGGING FLAG AND CHECK FOR MORE
          UJN    LTC9        RETURN

*         COMMON EXIT - SEND PACKET AND RETURN.

 LTC8     LDC    CELCW*0#400-TPKT*0#400+1*0#400+0*0#200+10000+PKRLE  SEND PACKET TO CONSOLE
          STML   RTP1
          CALL   PKT         PROCESS CONSOLE PACKETS VIA *2AP*
          LDC    0#8000      SET RESPONSE PENDING
          RAML   CELCW
 LTC9     LJM    LTCX        RETURN

*         DFT ANALYSIS - PACKET RESPONSE ERROR.
*         DFT FLAGS - LOGGING.

 LTC10    LDD    T2
          STM    LTCF+2      SAVE MRB BEING LOGGED
          LDD    T1
          STM    LTCF+3      SAVE OUT OF PHASE CONDITION
          LDN    BC
          RJM    CLR
          LDN    0
          STD    ET
          SETDAN (EPUN,DABP) BAD PHASE IN PACKET COMMUNICATION
          SETFLG (BC.FL)
          LRD    DP+1
          RJM    SPB         SET OS BOUNDS
          LDN    NRSP        NON REGISTER STATUS BUFFER
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0
          LRD    W1
          LDDL   W0
          ADC    RR+NRSBL+1  BASE SIZE + HEADER WORD
          CWML   LTCF,ON     WRITE ERROR CODE TO SCRATCH SUPPORTIVE STATUS
          LDN    NRSBL
          STM    LLOG        LENGTH TO LOG
          LDC    DABP+TDFT
          STML   RTP1
          CALL   ERRH        LOG THE ERROR


 LTCA     BSS    0           PHASE PROCESSORS
          LOC    0
          CON    LTC3        PHASE 0 - OPEN CONSOLE FILE
          CON    LTC4        PHASE 1 - WRITE FIRST BLOCK TO CONSOLE FILE
          CON    LTC5        PHASE 2 - WRITE SECOND BLOCK TO CONSOLE FILE
          CON    LTC6        PHASE 3 - CLOSE CONSOLE FILE
          CON    LTC7        PHASE 4 - CLEAR LOGGING FLAG IN MRB

 LTCAL    BSS    0           MAXIMUM PHASE + 1
          LOC    *O

 LTCB     DATA   12HDFT.UNC       CONSOLE FILENAME (UNCORRECTED ERROR)
*LTCC     DATA   12HDFT.COR       CONSOLE FILENAME (CORRECTED ERROR - FUTURE)
 LTCD     DATA   12HMRT.NVE       CONSOLE FILENAME (MRT TRANSFER)
 LTCF     BSSZ   4
 CCF      SPACE  4,10
**        CCF - CLEAR CONSOLE LOGGING FLAG AND CHECK FOR MORE TO LOG.
*
*         ENTRY  (T2) = MRB NUMBER JUST SUCCESSFULLY LOGGED.
*                     = 77, IF MRT TRANSFER.
*
*         EXIT   CONSOLE LOGGING FLAG CLEARED FOR MRB JUST LOGGED.
*                (CELCW) = 0, IF NO MORE ERRORS TO LOG TO CONSOLE.
*                        = N, IF MRB(N) TO BE LOGGED TO CONSOLE.
*
*         USES   CM - CM+3, T2.
*
*         CALLS  IBW, SET.


 CCF      SUBR               ENTRY/EXIT
          LDD    T2          CHECK TRANSFER TYPE
          LMN    77
          NJN    CCF1        IF NOT MRT TRANSFER
*         LDN    0           CLEAR MRT UPDATED FLAG
          STM    MRTU
          UJN    CCF2        CONTINUE

*         CLEAR CONSOLE LOGGING FLAG FOR MRB JUST LOGGED.

 CCF1     LDN    CM          SET UP MASK FOR *RDCL* INSTRUCTION
          RJM    SET
          LMBC   (BC.CL)
          STDL   CM+BCFLG
          LDD    T2          CLEAR CONSOLE LOGGING FLAG IN BUFFER CONTROL WORD
          RJM    IBW
          RDCL   CM

*         SCAN BUFFER CONTROL WORDS FOR ANOTHER LOGGING CANDIDATE.
*         NOTE THAT SEQUENCE NUMBERS ARE NOT CHECKED.

 CCF2     LDN    VER5
          RJM    VCK         CHECK VERSION
          MJN    CCF2.5      IF VERSION 4
          LDN    1
          UJN    CCF2.6

 CCF2.5   LDN    3           START WITH FIRST GENERAL MRB
 CCF2.6   STD    T2
 CCF3     LDD    T2          READ BUFFER CONTROL WORD (T2)
          RJM    IBW
          CRDL   CM
          LDDL   CM+BCFLG    CHECK CONSOLE LOGGING FLAG
          LPBC   (BC.CL)
          NJN    CCF5        IF CONSOLE LOGGING FLAG SET
          AOD    T2          ADVANCE MRB INDEX
          LMM    NBUF
          NJN    CCF3        IF MORE MRB-S TO SCAN
*         LDN    0           SET NO MRB TO BE LOGGED
 CCF4     STM    CELCW       UPDATE CONSOLE LOGGING CONTROL WORD
          LJM    CCFX        RETURN

 CCF5     LDD    T2          SET THIS MRB TO BE LOGGED NEXT
          UJN    CCF4        UPDATE *CELCW* AND RETURN
 GLH      SPACE  4,10
**        GLH - GENERATE LOGGING HEADER.
*
*         ENTRY  (T2) = MRB NUMBER TO BE LOGGED.
*
*         EXIT   PACKET BUFFER CONTAINS THE FOLLOWING HEADER:
*
* HDR0    4/, 12/ DFTAC, 8/ DFTCV, 8/ DFTIFV, 16/ OFFSET TO MRS, 16/ DATA LENGTH
* HDR1    16/ RESERVED, 16/ SSDL, 32/ RESERVED
* HDR2    56/ DATE AND TIME, 8/ SEQ. NUMBER
* HDR3    32/ RESERVED, 32/ FAULT SYMPTOM CODE (CHARACTERS 1 - 4)
* HDR4    64/ FAULT SYMPTOM CODE (CHARACTERS 5 - 12)
* HDR5    64/ MAINFRAME ELEMENT STATUS
* HDR6    64/ MAINFRAME ELEMENT STATUS
* HDR7    64/ MAINFRAME ELEMENT STATUS
*
*         DFTAC = DFT ANALYSIS CODE.
*         DFTCV = DFT CODE VERSION.
*         DFTIFV = DFT INTERFACE VERSION.
*         SSDL = SUPPORTIVE STATUS DATA LENGTH.
*
*
*         USES   CM - CM+3, T3, T4, W0 - W0+3.
*
*         CALLS  IBW, IDA.


 GLH      SUBR               ENTRY/EXIT
          LDN    0           INITIALIZE HEADER WORDS TO ZERO
          STD    T3
 GLH1     LDN    0           CLEAR NEXT WORD OF HEADER
          STM    TOIPS0+3,T3
          AOD    T3
          LMN    10*4
          NJN    GLH1        IF MORE WORDS TO INITIALIZE

*         READ SUPPORTIVE STATUS BUFFER ENTRY (T2).

          LDN    SSBP        GET SUPPORTIVE STATUS BUFFER POINTER
          RJM    IDA
          CRDL   W0
          LRD    W0+1        READ SUPPORTIVE STATUS HEADER WORD
          LDD    W0
          ADC    RR
          CRDL   CM
          LDN    0           DETERMINE OFFSET TO DESIRED ENTRY = (T2) * SIZE
          STD    T4
          LDD    T2
          STD    T3
 GLH2     LDDL   CM+3        MULTIPLY (T2) * SIZE
          RADL   T4
          SOD    T3
          NJN    GLH2        IF MULTIPLICATION NOT COMPLETE
          AODL   W0          SKIP TABLE HEADER WORD
          ADDL   T4          OFFSET TO (T2) BUFFER ENTRY
          ADC    RR
          CRML   TOIPS0+3+1*4,CM+3
          LDD    T2          READ BUFFER CONTROL WORD (T2)
          RJM    IBW
          CRDL   CM

*         INITIALIZE HEADER WORD 0.

          LDD    CM+BCDA     SET DFT ANALYSIS CODE (WITHOUT PRIORITY)
          STM    TOIPS0+3+0*4+0
          LDC    CURNTV*0#100  SET DFT CODE VERSION
          ADM    VRSN        MERGE WITH DFT INTERFACE VERSION
          STML   TOIPS0+3+0*4+1
          LDN    10          STORE OFFSET TO REGISTER DATA (IN CM WORDS)
          STML   TOIPS0+3+0*4+2
          ADM    LBUF        SET LENGTH OF DATA INCLUDING HEADER SIZE
          STML   TOIPS0+3+0*4+3

*         COMPLETE INITIALIZATION OF HEADER WORD 1.

          LDN    0
          STM    TOIPS0+3+1*4+0
          STM    TOIPS0+3+1*4+2
          STM    TOIPS0+3+1*4+3

*         COMPLETE INITIALIZATION OF HEADER WORD 2.

          LDDL   CM+BCSEQ    EXTRACT SEQUENCE NUMBER
          SHN    -BC.SEQ
          STD    CM+BCSEQ
          LDML   TOIPS0+3+2*4+3  MERGE TIME AND SEQUENCE NUMBER
          LPC    0#FF00
          LMD    CM+BCSEQ
          STML   TOIPS0+3+2*4+3
          LJM    GLHX        RETURN
 MMD      SPACE  4,10
**        MMD - MOVE MRT DATA TO PACKET BUFFER.
*
*         ENTRY  (T1) = PHASE TO BE PROCESSED.
*
*         EXIT   (T3) = CM WORD COUNT.
*
*         USES   CM - CM+3, T2, T3.
*
*         NOTE   THIS CODE ASSUMES THAT MRT DATA TO BE MOVED IS 500 PP
*                WORDS (EQUIVALENT TO ONE SMALL SECTOR ON MAINFRAME DISK).


 MMD      SUBR               ENTRY/EXIT
          LDML   TOAPS0      SET OFFSET TO MRT DATA
          STDL   T2
          LDN    0
          STD    T3
          LDD    T1          CHECK PHASE
          LMN    1
          ZJN    MMD1        IF PHASE 1
          LDC    500/2       ADVANCE TRANSFER ADDRESS FOR PHASE 2 DATA
          RADL   T2
 MMD1     LDML   TOAPS0,T2   TRANSFER NEXT PP WORD
          STML   TOIPS0+3,T3
          AODL   T2
          AOD    T3
          LMC    500/2
          NJN    MMD1        IF MORE TO MOVE
          LDN    240/4       SET CM WORD COUNT EQUIVALENT
          STD    T3
          UJN    MMDX        RETURN
 SMP      SPACE  4,10
**        SMP - SET MRB PARAMETERS.
*
*         ENTRY  (T1) = PHASE TO BE PROCESSED.
*                (T2) = MRB TO BE PROCESSED.
*
*         EXIT   (A) = FWA OF MRB INFORMATION FOR THIS PHASE.
*                (T3) = CM WORD COUNT.
*
*         USES   CM - CM+3, T3, T4.
*
*         CALLS  IBW, IMB.


 SMP      SUBR               ENTRY/EXIT
          LDM    LBUF        SET MRB DATA SIZE
          STD    T4

*         THE FOLLOWING CODE ENSURES THAT AN ODD WORD COUNT IS HANDLED
*         WITHOUT LOSS OR DUPLICATION.  THE ODD WORD WILL BE WRITTEN IN
*         THE FIRST DATA BLOCK.

          LDD    T1          CHECK PHASE
          LPN    1           (A) = 1 IF PHASE 1, 0 IF PHASE 2
          ADD    T4          SET (POSSIBLY ROUNDED) TOTAL CM WORD COUNT
          SHN    -1
          STD    T3          (T3) = CM WORD COUNT FOR THIS PHASE

*         CALCULATE FWA OF MRB INFORMATION FOR THIS PHASE.

          LDD    T2          READ BUFFER CONTROL WORD (T2)
          RJM    IBW
          CRDL   CM
          LDD    T1          CHECK PHASE
          LMN    1
          ZJN    SMP1        IF PHASE 1, SET FOR READ OF FIRST HALF
          LDD    T4          SET OFFSET TO SECOND HALF
          SBD    T3
 SMP1     ADDL   CM+BCOFF    ADD OFFSET TO MRB INFORMATION
          RJM    IMB         CALCULATE CM ADDRESS
          UJN    SMPX        RETURN

*         END    CTP$DFT LOG PACKET TO CONSOLE
*DECK DECK=CTP$DFT_MAIN_LOOP EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT MAIN LOOP.
          TITLE  MAIN LOOP.
 DFT      SPACE  4,10
***       MAIN LOOP.
*
*         NOTE   THROUGHOUT DFT, OS BOUNDS FAULT PROTECTION IS PROVIDED.
*                THIS PROTECTION ASSUMES THAT ALL DFT DATA STRUCTURES
*                (I.E. CONTROL BLOCK, REGISTER BUFFERS, MODEL-DEPENDENT
*                BUFFER, ETC.) EXIST ON THE SAME SIDE OF THE OS BOUNDS
*                VALUE.  OS BOUNDS IS NOT USED IN STANDALONE NOS/VE.


 DFT      LJM    /PRESET/PRS PRESET PROGRAM
 DFT5     CALL   HOE         SET HALT ON ERROR

*         CHECK FOR HARDWARE ERRORS.

 DFT10    RJM    TIM
          LDM    DFTD        (MONITOR TIMEOUT MESSAGE NEEDED)
          ZJN    DFT15       IF NOT TIMED OUT
          CALL   IMM         ISSUE MONITOR TIMEOUT MESSAGE
 DFT15    BSS    0
 DFTE     LDN    0           SEE IF TIME TO HANDSHAKE
*         LDN    1           (SET NONZERO BY *IHS* EVERY FIVE SECONDS)
          ZJN    DFT20       IF NOT TIME
          CALL   CPH         PROCESS CPU/PP HANDSHAKE
 DFT20    BSS    0
 DFTF     LDN    0           SEE IF TIME TO HANDSHAKE
*         LDN    1           (SET NONZERO BY *DPD* EVERY THIRTY SECONDS)
          ZJN    DFT21       IF NOT TIME
          CALL   SRD         PROCESS DUMP PP REGISTER DATA
 DFT21    LDM    TSIT        SEE IF TIME TO CHECK *SIT*
          ZJN    DFT25       IF NOT TIME
          CALL   CNS         CHECK FOR NEGATIVE *SIT*
 DFT25    CALL   MHE         MONITOR HARDWARE ENVIRONMENT
          LDM    DTEW        DONE TIMING ENVIRONMENT WARNING FLAG
          NJP    DFT10       IF NOT DONE

*         CHECK FOR OPERATING SYSTEM REQUESTS.

 DFT30    CALL   WDR         PROCESS OS REQUESTS
          LDM    IOUN        IOU NUMBER IN WHICH DFT IS RUNNING (12-BIT LOAD)
          NJP    DFT10       IF RUNNING AS DFT-S

*         CHECK FREEZE FLAG.

 DFT35    LDN    HDRP        DFT HEADER OFFSET
          RJM    IDA
          CRDL   CM          GET HEADER
          LDDL   CM+DHFLG
          SHN    21-DH.MO
          MJN    DFT30       IF MANUAL OVERRIDE SET BY *MDD*

*         CHECK FOR TOP-OF-HOUR SECDED LOGGING.

 DFT40    LDDL   CM+DHFLG    CHECK TOP-OF-HOUR FLAG
          SHN    21-DH.FZ
          PJN    DFT45       IF NOT TOP OF HOUR
          CALL   LGC         LOG COUNTERS

*         PERFORM MISCELLANEOUS FUNCTIONS.

 DFT45    RJM    UTE         UPDATE TIME IN EICB
          RJM    CST         CHECK STATE TRANSITION
          RJM    CRN         CHECK IF RELOCATION IS NECESSARY
          RJM    CPC         CHECK PACKET COMMUNICATION
          RJM    CNM         CHECK FOR NON-DEDICATED MODE CASE
          LJM    DFT10       LOOP

*         END CTP$DFT MAIN LOOP
*DECK DECK=CTP$DFT_MAIN_LOOP_930 EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT MAIN LOOP 930.
*
*         ROUTINES CALLED BY S0/S0E MAIN LOOP.
 CRN      SPACE  4,10
**        CRN - CHECK FOR RELOCATION NECESSARY.


 CRN      SUBR               ENTRY/EXIT
          LDML   PKTCW       CHECK FOR OUTSTANDING PACKET ACTIVITY
          ADML   CELCW
          ADML   DI4CW
          NJN    CRNX        IF PACKET ACTIVITY OUTSTANDING
          LDM    DRCR        SEE IF ONE SECOND HAS ELAPSED
          ZJN    CRNX        IF NOT TIME YET
          CALL   CRQ         CHECK FOR RELOCATION REQUESTS
          UJN    CRNX        RETURN
 CST      SPACE  4,10
**        CST - CHECK STATE TRANSITION.
*
*         THIS IS A DUMMY ROUTINE ON S0/S0E.


 CST      SUBR               ENTRY/EXIT
          UJN    CSTX        RETURN
 CNM      SPACE  4,10
**        CNM - CHECK FOR NON DEDICATED MODE
*
*         THIS IS A DUMMY ROUTINE ON S0/S0E.


 CNM      SUBR               ENTRY/EXIT
          UJN    CNMX        RETURN

*         END CTP$DFT MAIN LOOP 930
*DECK DECK=CTP$DFT_MAIN_LOOP_DUAL_STATE EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT_MAIN_LOOP_DUAL_STATE
*
*         THIS COMMON DECK CONTAINS DFT MAIN LOOP ROUTINES
*         WHICH ARE USED IN DUAL STATE ENVIRONMENTS


 CST      SUBR               ENTRY/EXIT

*         CHECK FOR DUAL-STATE TRANSITION.

          LDN    HDRP
          RJM    IDA
          CRDL   CM          GET DFT HEADER
          LDDL   CM+DHFLG    GET DFT FLAGS
          SHN    21-DH.DT
          PJN    CSTX        IF NO  DUAL STATE TRANSITION HAS OCCURRED
          CALL   PTF         PROCESS TRANSITION
          UJP    CSTX        RETURN

*         CHECK IF TIME TO DROP OUT IN NON-DEDICATED MODE.

 CNM      SUBR               ENTRY/EXIT
          CALL   HOE
          LDN    HDRP
          RJM    IDA
          CRDL   CM
          LDDL   CM+DHFLG    DFT HEADER FLAGS
          SHN    21-DH.FD
          PJP    CNMX        IF DEDICATED MODE
          LDM    DTEW        CHECK FOR TIMEOUT COMPLETE ON ENVIRONMENT WARNING
          NJP    CNMX        IF NO PENDING TIMEOUTS
          LDML   PKTCW
          NJN    CNMX        IF PACKET ACTIVITY IS OUTSTANDING
          LDM    WARN        ENVIRONMENT OR SHORT WARNING ENCOUNTERED
          ZJN    CNM10       IF NEITHER
          LDM    WARC        IN NON DEDICATED ONLY CALL *1MB* / *1MR* ONCE
          SBN    2
          PJP    CNMX        IF DEDICATED
          AOM    WARC        BUMP TIMES CALLED
          UJN    CNM20       CONTINUE

 CNM10    STM    WARC        RESET CALLED COUNT
 CNM20    CALL   SST         SAVE DFT STATE AND RETURN TO *1MB* / *1MR*

*         END CTP$DFT_MAIN_LOOP_DUAL_STATE
*DECK DECK=CTP$DFT_MAIN_LOOP_NO_PACKETS EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT MAIN LOOP NO PACKETS
*
*         THIS DECK IS A STUB FOR NO DUAL I4 PRESENT.


 TPKT     BSS    0
 DI4CW    CON    0           SHOW NO PACKET ACTIVITY
 PKTCW    CON    0           SHOW NO PACKET ACTIVITY
 PKTIM    CON    0           SHOW NO TIMING

*         END CTP$DFT MAIN LOOP NO PACKETS
*DECK DECK=CTP$DFT_MAIN_LOOP_PACKETS EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT MAIN LOOP PACKETS.
*
*         THIS DECK DEFINES PACKET CONTROL VARIABLES AND A ROUTINE TO
*         CHECK PACKET STATUS.


 CPC      SUBR               ENTRY/EXIT
          CALL   CPS         CHECK PACKET STATUS
          UJN    CPCX        RETURN
 PKTS     SPACE  4,20
**        PACKET CONTROL WORDS.
*
*         *CELCW* CONTROLS CONSOLE LOGGING, AND *PKTCW* CONTROLS
*         GENERAL PACKET TRAFFIC.  CONSOLE LOGGING HAS A HIGHER
*         PRIORITY THAN GENERAL TRAFFIC.
*
*         NOTE - *PKTCW* CAN ONLY QUEUE ONE REQUEST.  IF PACKETS OTHER
*         THAN CONSOLE LOGGING BECOME NUMEROUS OR FREQUENT, THIS MAY NEED
*         TO BE MODIFIED.
*
*         *DI4CW* CONTROLS THE PHASES OF LOADING *DFT* INTO THE
*         SECONDARY IOU.  THIS CONTROL IS NEEDED ON THOSE MACHINES
*         WHICH HAVE DUAL IOU-S.
*
* CELCW   1/R, 1/T, 2/, 6/ PHASE, 6/ MRB
*
*         R = RESPONSE PENDING.
*         T = PACKET TIMEOUT OCCURRED.
*         PHASE = LOGGING PHASE (SEE ROUTINE *LTC* FOR DETAILS.)
*         MRB = MAINTENANCE REGISTER BUFFER NUMBER TO LOG (BEING LOGGED).
*             = 77, IF MRT IS TO BE LOGGED (BEING LOGGED).
*
*
* PKTCW   1/R, 1/T, 2/0, 2/C, 1/S, 1/P, 8/REQUEST
*
*         R = RESPONSE PENDING.
*         T = PACKET TIMEOUT OCCURRED.
*         C = OFFSET TO PACKET CONTROL WORD FOR TIMING (2).
*         S = 1, IF SEQUENCE BYTE IS IN UPPER PART OF PACKET.
*         P = 1 IF PHASED PACKET OPERATION IN PROGRESS.
*         REQUEST = *PKR__*, IF PACKET REQUEST PRESENT.
*
*
* DI4CW   1/R, 1/T, 1/P, 1/0, 12/ PHASE
*
*         R = RESPONSE PENDING.
*         T = PACKET TIMEOUT OCCURRED.
*         P = 1, IF PROCESSING REQUEST TO START *DFT-S*.
*         PHASE = PHASE OF PROCESSING IN STARTING UP DFT-S.


 TPKT     BSS    0           START OF TABLE OF PACKET CONTROL WORDS
 CELCW    BSS    1           CONSOLE LOGGING CONTROL WORD
 PKTCW    BSS    1           GENERAL PACKETS CONTROL WORD
 DI4CW    CON    0           DUAL I4 DEADSTART PACKET CONTROL WORD
 TPKTL    EQU    *-TPKT      NUMBER OF PACKET CONTROL WORDS
          SPACE  4,10
**        ADDITIONAL GLOBAL PACKET DATA ITEMS.

 PES1     CON    0           PACKET ERROR STATUS
 PKERR    CON    0           LAST RESPONSE PACKET ERROR CODE
 PKTIM    CON    0           4/INDEX TO CW, 12/ELAPSED TIME IN SECONDS
 PKTCW1   CON    0           FIRST WORD OF PACKET CONTROL ROUTINE ADDRESS
 PKTCW2   CON    0           SECOND WORD OF PACKET CONTROL ROUTINE ADDRESS
 PKTPH    CON    0           PKTCW PHASE BEING PROCESSED

*         END    CTP$DFT MAIN LOOP PACKETS
*DECK DECK=CTP$DFT_MAIN_LOOP_UPDATE_TIME EXPAND=TRUE
          EJECT
*         CTEXT  CTP$DFT_MAIN_LOOP_UPDATE_TIME
*
*         THIS DECK WILL UPDATE THE TIME IN THE EICB
*         FROM DFTS MAIN LOOP

 UTE      SUBR               ENTRY/EXIT
          LDM    UETV        SEE IF TIME TO UPDATE EICB TIME
          ZJN    UTEX        IF NOT TIME
          CALL   UWE         UPDATE TIME IN EICB
          UJN    UTEX

*         END CTP$DFT_MAIN_LOOP_UPDATE_TIME
*DECK DECK=CTP$DFT_MAIN_NON_RES_DUAL_I4 EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_MAIN_NON_RES_DUAL_I4
*
*         THIS DECK PROVIDES CODE IN THE MAIN NON RESIDENT OVERLAY
*         OF DFT TO SUPPORT DUAL I4 SYSTEMS
 PSS      SPACE  4,10
**        PSS - PROCESS STATUS SUMMARY REGISTERS.
*
*         EXIT   (SS) = LOGICAL OR OF IOU0 AND IOU1 STATUS SUMMARY.
*                (T3) = IOU1 SUMMARY STATUS (IF IOU1 PRESENT AND RUNNNING
*                       IN IOU0 (*DFT*).
*
*         USES   SS, T1, W0 - W3.
*
*         CALLS  *DDA*, *ERRH*, FHE, IDA, *RIR*, RMR, WSS.
*
*         MACROS SETDAC.


*         PROCESS SS FOR *DFT*.

 PSS60    STDL   T3          INITIALIZE IOU1 SS
          LDML   IOUN        CHECK NUMBER OF IOU-S
          SHN    -14
          ZJN    PSS80       RETURN IF SINGLE IOU
          LDN    CMSS        SUMMARY STATUS WORD
          RJM    GCM         GET CM RESIDENT WORD
          LDDL   CM+3
          LPC    0#FF
          STDL   T3
          LPC    0#40
          ZJN    PSS70       IF NOT BIT 57 ERROR IN IOU1
          LDN    1
          STM    /HB57/BI57  SET BIT 57 ERROR FLAG
 PSS70    LDDL   CM+3
          SHN    21-17
          MJN    PSS85       IF ACKNOWLEDGEMENT SET, CHECK FOR LONG WARN
          LDDL   T3
          NJN    PSS95       IF ERROR IN IOU1
          LDD    T3          PRESERVE IOU1 SUMMARY STATUS
          STM    PSSA
          LDN    1           SET FLAG
          RJM    SER         SET SS ERROR READ FLAG TO VALUE
          LDM    PSSA        RESTORE IOU1 SUMMARY STATUS
          STD    T3
 PSS80    UJN    PSS100      RETURN

 PSS85    LDDL   T3          CHECK FOR LONG WARNING
          LPN    1
          NJN    PSS90       IF LONG WARNING
          STDL   T3
          UJN    PSS100      RETURN NO ERROR IN IOU1

 PSS90    ADN    20          SET SUMMARY STATUS BIT
          STDL   T3
 PSS95    LCN    0           RETURN LOGICAL OR OF SS FOR IOU1 AND IOU0
          LMDL   T3
          LPDL   T1
          LMDL   T3
          STDL   T1
          LDDL   SS
          LPC    0#F000
          ADDL   T1
          STDL   SS
          LDDL   T3
          LMN    21
          NJN    PSS100      IF OTHER THAN LONG WARNING
          LDD    T3          PRESERVE IOU1 SUMMARY STATUS
          STM    PSSA
          LDN    1           SET FLAG
          RJM    SER         SET SS READ FLAG TO VALUE
          LDM    PSSA        RESTORE IOU1 SUMMARY STATUS
          STD    T3
 PSS100   LJM    PSSX        RETURN

          ROUTINE  PSS

*         READ STATUS SUMMARY FOR THE CURRENT IOU.

          LDN    SSMR
          STD    RN
          LDM    I0CC        GET IOU CONNECT CODE
          RJM    RMR         READ THE SUMMARY STATUS (SS)
          STDL   T1
          LDDL   SS
          LPC    0#F000
          ADDL   T1
          STDL   SS
          LPBC   (SSBA)
          ZJN    PSS5        IF CM ACCESS NOT BLOCKED
          RJM    /HB57/BCA   HANDLE BLOCKED ACCESS

 PSS5     LDM    IOUN        CHECK IOU NUMBER
          ZJP    PSS60       IF RUNNING IN IOU0

*         PROCESS SS FOR *DFT-S*.

          LDD    SS          CHECK FOR ERRORS
          NJN    PSS30       IF ERRORS
          LDDL   SS          CHECK ERRORS LAST TIME
          SHN    -14
          NJN    PSS20       IF ERRORS LAST TIME
 PSS10    UJN    PSS100      RETURN - NO ERRORS THIS TIME NOR LAST TIME

*         WHEN *DFT* HAS READ IOU1 SS, THEN CLEAR STATUS SUMMARY IN THE
*         SECONDARY *DFT* BUFFER FOR USE BY *DFT*.

 PSS20    LDN    CMSS        SUMMARY STATUS
          RJM    GCM         GET CM RESIDENT WORD
          LDDL   CM+3
          SHN    21-17       SS ERROR READ FLAG
          PJN    PSS10       IF *DFT* HAS NOT READ PREVIOUS VALUE
          RJM    WSS         WRITE SS
          LDN    0           STATUS IS NO ERROR LAST TIME
          LJM    PSS50       SET STATUS AND RETURN

*         WHEN *DFT* HAS READ IOU1 SS, THEN SET CURRENT STATUS SUMMARY
*         ERROR INTO THE SECONDARY *DFT* BUFFER FOR USE BY *DFT*.
*         THERE ARE THREE STATUS VALUES RECORDED IN THE SS DIRECT CELL
*         TO CONTROL THE RETURNING OF STATUS AND CLEARING OF ERRORS -
*         0 = NO ERROR LAST TIME.
*         1 = REGISTER(S) READ AND PLACED IN BUFFER.
*         2 = ERRORS CLEARED IN IOU.

 PSS30    LDN    CMSS        SUMMARY STATUS
          RJM    GCM         GET CM RESIDENT WORD
          LDDL   CM+3
          SHN    21-17       SS ERROR READ FLAG
          PJN    PSS10       IF *DFT* HAS NOT READ PREVIOUS VALUE
          LDDL   SS          CHECK STATUS
          SHN    -14
          SBN    1
          ZJN    PSS40       IF STATUS IS REGISTERS PASSED
          LDD    SS          SET SUMMARY STATUS
          STM    SUMS
          LPBC   (SSBA)
          ZJN    PSS31       IF MEMORY ACCESS NOT BLOCKED (BIT 57)
          RJM    /HB57/BCA   HANDLE BLOCKED CM ACCESS
 PSS31    LDN    IOUID       SET IOU ELEMENT TYPE
          STDL   ET
          LDC    10000+IOUID READ IOU1 DESCRIPTOR INTO *HBUF*
          RJM    FHE         FIND HARDWARE ELEMENT
          MJN    PSS55       IF ERROR
          CALL   RIR         RETRIEVE IOU REGISTERS
          RJM    WSS
          LDN    1           SET STATUS TO REGISTERS PASSED
          UJN    PSS50       SET STATUS AND RETURN

 PSS40    SETDAC DDCL        CLEAR ERRORS
          CALL   DDA
          LDN    2           SET STATUS TO ERRORS CLEARED

*         SET STATUS AND RETURN.

 PSS50    SHN    14-0        POSITION NEW STATUS
          STDL   T1
          LDD    SS          CLEAR OLD STATUS
          LMDL   T1
          STDL   SS
          LJM    PSSX        RETURN

*         DFT ANALYSIS - MISSING DESCRIPTOR IN THE MRT.

 PSS55    SETDAN (EPUN,DAME)
          LDC    DAME+TDFT   612 - DFT NO DESC IN MRT
          STML   RTP1
          CALL   ERRH

 PSSA     BSS    1           IOU1 SS SAVE AREA
 WSS      SPACE  4,10
**        WSS - WRITE SS TO MEMORY.
*
*         ENTRY  (SS) = 4/, 12/STATUS SUMMARY.
*
*         USES   W4.
*
*         CALLS  SER.


 WSS      SUBR               ENTRY/EXIT
          LDN    CMSS
          RJM    GCM
          LDDL   CM+3
          LPC    0#FF00
          LMD    SS
          STDL   CM+3
          LDN    0           CLEAR FLAG
          RJM    SER         SET SS ERROR READ TO VALUE
          UJN    WSSX        RETURN
 PRO      SPACE  4,15
**        PRO - PASS REQUEST TO OTHER IOU.
*
*         ENTRY  (T1) = IOU FIELD OF REQUEST.
*                (T5) = OFFSET IN NOS/VE REQUEST BLOCK.
*                (W0 - W3) = R-POINTER TO NOS/VE REQUEST BLOCK.
*
*         EXIT   TO *ERRH*, IF ERROR IN PROCESSING IOU FIELD.
*
*         USES   W0, W3 - W7.
*
*         CALLS  IIB, SPB, SRS.


 PRO30    LDD    T5          BUILD R-POINTER TO REQUEST
          RADL   W0
          LDN    1
          STDL   W3
          LDN    SDBP        GET R-POINTER TO SECONDARY DFT BUFFER
          RJM    IDA
          CRDL   W4
          LRD    W5          CHECK IF SECONDARY BUFFER HAS BEEN BUILT
          LDDL   W4
          ADC    RR
          CRDL   T1
          LDDL   T1
          ZJN    PRO10       IF REQUEST FOR DFT-S  BEFORE IT IS ACTIVE
          RJM    SPB         SET PP BOUNDS
          LDN    NVEP        SET NOS/VE POINTER IN SECONDARY DFT BUFFER
          ADD    W4
          ADC    RR
          CWDL   W0

 PRO      SUBR               ENTRY/EXIT
          LDML   IOUN        MAXIMUM IOU ORDINAL
          SHN    -14
          NJN    PRO20       IF MULTI IOU
 PRO10    LJM    ERR         PROCESS ERROR

 PRO20    LDD    T1
          SBN    2
          PJN    PRO10       IF IOU ORDINAL OUT OF RANGE
          LDM    IOUN
          ZJP    PRO30       IF IN IOU 0
          LDC    0#200       TERMINATE REQUEST WITH ERROR
          STM    JOBF
          RJM    SRS         SET REQUEST STATUS
          SETDAN (EPUN,DAPR)
          LDC    TDFT+DAPR   61A - IOU FIELD PROCESSING ERROR
          STML   RTP1
          CALL   ERRH

*         END CTP$DFT_MAIN_NON_RES_DUAL_I4
*DECK DECK=CTP$DFT_MAIN_NON_RES_DUAL_STATE EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_MAIN_NON_RES_DUAL_STATE
*
*         THIS DECK PROVIDES DUAL STATE ROUTINES TO THE
*         MAIN NON RESIDENT OVERLAY OF DFT
 SST      SPACE  4,10
**        SST - SAVE STATE VARIABLES ACROSS NON-DEDICATED CALLS.
*
*         CALLS  CLR, IDA, IMB, SET, SPB.


          ROUTINE SST

          LRD    DP+1
          RJM    SPB         SET PP BOUNDS
          LDM    FREE
          ZJN    SST1        IF NO INTERLOCKS TO CLEAR
          STD    T3
          LDN    CM
          RJM    SET         SET LOCK WORD
          LDDL   CM+BCFLG
          LMBC   (BC.FI)     CLEAR INTERLOCK
          STDL   CM+BCFLG
          LDD    T3
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          RDCL   CM          CLEAR INTERLOCK ON ENTRY
          LDN    0
          STM    DSIF        CLEAR DFT SET I/L FLAG
          STM    FREE        NO MULTIPLE OCCURRENCE IN NON-DEDICATED MODE
 SST1     LDN    CM
          RJM    CLR         CLEAR CM AREA
          LDN    1
          STD    CM+DHFLG    SET E7 FLAG IN MASK
          LDN    HDRP
          RJM    IDA
          RDSL   CM          SET LOCK

*         SAVE THE DIRECTORY POINTER CELLS.

          LDD    DH
          STM    DHSV
          LDD    DH+1
          STM    DHSV+1
          LDD    DH+2
          STM    DHSV+2
          LDN    SAVL/4      SAVE AREA LENGTH
          STD    T1
          LDN    0
          RJM    IMB         GET POINTER TO MAINTENANCE REGISTER BUFFER 0
          CWML   SAVE,T1     SAVE STATE VARIABLES BUFFER
          LDN    C17P
          RJM    IDA         POINTER TO 170 COMMUNICATION AREA
          CRDL   W0          READ POINTER
          LRD    W1
          LDD    W0
          ADC    RR
          CRM    0,W3        READ IN NEW IMAGE
          LJM    SSTX        RETURN

*         END    CTP$DFT_MAIN_NON_RES_DUAL_STATE
*DECK DECK=CTP$DFT_MAIN_NON_RES_EICB_TIME EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_MAIN_NON_RES_EICB_TIME
*
*         THIS DECK UPDATES THE TIME IN THE EICB
*         AND IS CALLED FROM DFTS MAIN LOOP
 UWE      SPACE  4,10
**        UWE - UPDATE WALL CLOCK VALUE IN EICB.
*
*         EXIT   (UETV) = 0.
*
*         CALLS  UTE.


          ROUTINE  UWE

          RJM    UTE         UPDATE TIME IN EICB
          LDN    0           CLEAR FLAG TO CALL UWE (SET IN TUT)
          STM    UETV
          LJM    UWEX        RETURN

*COPY CTP$UPDATE_TIME_IN_EICB

*         END    CTP$DFT_MAIN_NON_RES_EICB_TIME
*DECK DECK=CTP$DFT_MAIN_NON_RES_NON_I4 EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT MAIN NON RES NON I4.
*
*         THIS DECK PROVIDES STUB ROUTINES WHICH HANDLE
*         READING STATUS SUMMARY, AND PROCESSING IOU REGISTERS
*         ON SYSTEMS WHICH DO NOT SUPPORT DUAL IOUS.
 PSS      SPACE  4,10
**        PSS - PROCESS SUMMARY STATUS.
*
*         EXIT   (SS) = 4/ UNCHANGED,12/ NEW SUMMARY STATUS.


          ROUTINE  PSS

          LDN    SSMR        READ SUMMARY STATUS FOR IOU
          STD    RN
          LDM    I0CC        GET IOU CONNECT CODE
          RJM    RMR         READ THE SUMMARY STATUS (SS)
          STDL   T1
          LDDL   SS
          LPC    0#F000
          ADDL   T1
          STDL   SS
          LJM    PSSX        RETURN
 PIR      SPACE  4,10
**        PIR - PROCESS IOU REGISTERS NON I4.
*
*         EXIT   SCRATCH MRB CONTAINS REGISTERS FOR IOU ERROR.
*
*         NOTE   THIS IS A DUMMY ROUTINE ON S0/S0E.


          ROUTINE PIR

          LDM    S0FLG       CHECK MAINFRAME TYPE
          NJP    PIRX        IF S0/S0E
          LDM    SUMS        SUMMARY STATUS
          LPN    14
          ZJN    PIR10       IF NOT PP HALT OR UNCORRECTED ERROR
          LDM    IO0U        UNCORRECTED ERROR LIST
          UJN    PIR20       CONTINUE

 PIR10    LDM    IO0C        CORRECTED ERROR LIST
 PIR20    RJM    BRL         BUILD REGISTER LIST
          CALL   RMR         READ MAINTENANCE REGISTERS
          LJM    PIRX        RETURN
 PRO      SPACE  4,10
**        PRO - PASS REQUEST TO OTHER IOU.
*
*         NOTE   THIS IS A DUMMY ROUTINE ON NON-DUAL I4 SYSTEMS.


 PRO      SUBR               ENTRY/EXIT
          UJN    PROX        RETURN
 LDS      SPACE  4,10
**        LDS - LOAD DFT INTO SECONDARY IOU.
*
*         NOTE   THIS IS A DUMMY ROUTINE ON NON-DUAL I4 SYSTEMS.


          ROUTINE LDS

          LJM    LDSX        RETURN

*         END    CTP$DFT MAIN NON RES NON I4
*DECK DECK=CTP$DFT_MAIN_NON_RES_RTNS EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT MAIN NON RES RTNS.
*
*         THIS DECK FORMS THE CORE OF THE MAIN NON RESIDENT ROUTINES
*         OVERLAY IN DFT. IT CONTAINS *MHE*, *WDR*, *CHW*, *IFM*, AND *WM7*.
 CHW      SPACE  4,10
**        CHW - CHECK WARNING ENTRY.
*
*         CALLS  CLW.


          ROUTINE  CHW

          LDM    WARN
          NJP    CHW2        IF EITHER WARNING STILL PENDING LEAVE
          LDN    VER5
          RJM    VCK         CHECK VERSION
          PJP    CHW3        IF VERSION 5 OR GREATER
          LDM    PWEP
          ZJN    CHW1        IF NO ENVIRONMENT POINTER
          LDM    PERR        POWER ERROR FLAG
          NJN    CHW1        CHECK SHORT WARN
          LDM    PWEP        GET OFFSET OF ENTRY
          STM    RTP2
          CALL   CLW         CLEAR ENVIRONMENT WARNING
          LDN    0
          STM    TENV
          STM    STIM        CLEAR TIMING FLAGS WHEN WARN CLEARS
          STM    TIMU
          STM    DTEW
          STM    PWEP        CLEAR ENVIRONMENT WARN
 CHW1     LDM    SWEP
          ZJN    CHW2        IF NO POINTER - DONE
          LDM    SHRR        SHORT WARN ERROR FLAG
          NJN    CHW2
          LDM    SWEP        POINTER TO SHORT WARNING ENTRY
          STM    RTP2
          CALL   CLW         CLEAR SHORT WARNING
          LDN    0
          STM    SWEP        CLEAR POWER WARNING
 CHW2     LJM    CHWX        RETURN

 CHW3     LDN    1
          STM    RTP1
          LDM    NNRB
          STM    RTP2        SAVE NUMBER OF NON REGISTER BUFFERS
 CHW4     RJM    IBW         INCREMENT BUFFER CONTROL WORD
          CRDL   CM
          RJM    CWE         CHECK WARNING ENTRY
          NJN    CHW5        IF NOT WARNING
          LDN    1
          STM    REDF        SET TO CALL READ EPM DATA
          CALL   CLW         CLEAR WARNING ENTRY
 CHW5     SOML   RTP2
          NJN    CHW4        IF NOT DONE CHECKING BUFFER
          LDN    0
          STM    PWEP
          STM    RTP1
          LDM    REDF
          ZJN    CHW6        IF NO WARNING CLEARED
          LDN    0
          STM    REDF        CLEAR FLAG TO CALL RED
          CALL   RED         READ 960 EPM DATA
 CHW6     LJM    CHWX        RETURN
 CWE      SPACE  4,10
**        CWE - CHECK FOR WARNING ENTRY.
*
*         ENTRY  (CM) - (CM+3) BUFFER CONTROL WORD.
*
*         EXIT   (A) = 1 IF NOT A WARNING ENTRY.
*                (A) = 0 IF A WARNING ENTRY


 CWE0     LDN    1           RETURN
 CWE      SUBR               ENTRY/EXIT
          LDDL   CM+1
          SHN    -BC.ANP
          SBN    EPEN
          MJN    CWE0        IF NOT A WARNING ENTRY
          LDDL   CM+1
          LPN    0#F
          SBN    4
          PJN    CWE0        IF WARNING BUT ALREADY CLEARED
          LDN    0
          UJN    CWEX        RETURN
 CNS      SPACE  4,10
**        CNS - CHECK FOR NEGATIVE SIT.
*
*         USES   T1 - T4, T7.
*
*         CALLS  GCM, ICC, IDA, PCM, RMR.
*
*         MACROS WRITMR.


          ROUTINE  CNS

          LDN    0           CLEAR FLAG
          STM    TSIT
          LDM    IOUN
          NJN    CNS1        IF RUNNING AS DFT-S
          LDN    D8TY        CHECK FOR NOS/VE BEING ACTIVE
          RJM    IIB         INCREMENT INTERFACE BLOCK
          CRDL   T1
          LDDL   T4
          SHN    21-15
          MJN    CNS2        IF 180 STANDALONE OR DUAL STATE
 CNS1     LJM    CNSX        RETURN

*         INITIALIZE FOR PROCESSING ALL CPU-S.

 CNS2     LDN    ECMR        *READMR  RDATA,CMCC,ECMR*
          STDL   RN
          LDM    CMCC
          RJM    RMR         READ MAINTENANCE REGISTER
          LDM    RDATA,PO    SAVE PORT INFORMATION
          STM    CNSB
          LDN    2           NUMBER OF CPU-S TO PROCESS
          STM    CNSD
          LDC    PSIT        *SIT* REGISTER NUMBER
          STDL   RN

*         CHECK IF NEXT CPU IS TO BE PROCESSED.

 CNS3     SOML   CNSD
          MJN    CNS1        IF ALL CPU-S HAVE BEEN CHECKED
          STM    CPUO        SAVE CPU ORDINAL BEING EXAMINED
          STD    T7
          SHN    2
          RAD    T7
          ERRNZ  CPNR-5      CODE ASSUMES VALUE
          LDML   TCPU+CPUM,T7
          ZJN    CNS3        IF CPU NOT PRESENT
          LDC    SHNI+4+3
          SBM    TCPU+CPUP,T7
          STM    CNSA
          LDN    1
 CNSA     SHN    **
          STM    CNSC
          LDC    **
 CNSB     EQU    *-1
          LPC    **
 CNSC     EQU    *-1
          NJN    CNS3        IF PORT DISABLED

*         READ AND COMPARE *SIT* WITH LIMIT VALUE.
*         IF *SIT* BECOMES MORE NEGATIVE THAN APPROXIMATELY
*         2 SECONDS, THEN IT WILL NEED TO BE RESET.

          LDM    TCPU+CPUC,T7
          RJM    RMR         READ MAINTENANCE REGISTER
          LDM    RDATA+6
          SHN    -6
          STD    T1
          LDM    RDATA+4
          SHN    10
          LMM    RDATA+5
          SHN    2
          LMD    T1
          MJN    CNS5        IF *SIT* IS NEGATIVE
 CNS4     LJM    CNS3        PROCESS NEXT CPU

 CNS5     ADC    2000000D/16384D+1
          PJN    CNS4        IF *SIT* > -2 SECONDS

*         RESET *SIT*.
*         THE *SIT* WILL BE SET TO APPROXIMATELY 50000 MICROSECONDS.

          RJM    PAC         PUT VALUE TO *MRVAL*
          LDN    0
          STM    RDATA+4
          STM    RDATA+5
          STM    RDATA+7
          LDC    50000D/0#100
          STM    RDATA+6
          LDM    TCPU+CPUC,T7
          STD    EC
          WRITMR RDATA

*         COUNT THIS OCCURRENCE.

          AOML   NSIT
          LDN    VER5
          RJM    VCK         CHECK VERSION
          PJN    CNS7        IF VERSION 5 OR GREATER
          LDC    CMSN*10000+CM+3
          RJM    ICC         INCREMENT CM BASED COUNTER
 CNS6     UJP    CNSX        RETURN

 CNS7     LDML   NSIT
          STML   CNSE+3
          LDN    0
          STD    ET
          LRD    DP+1
          RJM    SPB         SET PP BOUNDS
          LDN    BC
          RJM    CLR         CLEAR SCRATCH BUFFER CONTROL WORD
          LDC    2*0#1000+DANSC
          STDL   BC+BCDA     SAVE THE DFT ANALYSIS CODE IN THE BCW
          SETFLG (BC.FL)
          LDN    NRSP
          RJM    IDA         POINTER TO NON REGISTER STATUS BUFFER
          CRDL   CM
          LRD    CM+1
          LDD    CM
          ADC    RR+1+5
          CWML   MRVAL,ON     WRITE SIT VALUE TO NON REGISTER STATUS BUFFER
          LDN    NRSBL
          STM    LLOG
          LDN    1
          STM    RTP1
          CALL   LOG         LOG THE OCCURRANCE
          UJP    CNSX

 CNSD     BSS    1           NUMBER OF CPU-S TO PROCESS
 CNSE     BSS    4
 IFM      SPACE  4,10
**        IFM - ISSUE FATAL ERROR MESSAGE.
*
*         CALLS  *ERRH*.


          ROUTINE IFM
          LDN    BC
          RJM    CLR

*         DFT ANALYSIS - FATAL CPU ERROR.

          SETDAN (EPUN,DAFC)
          LDK    DAFC        *(218) FATAL CPU N ERROR*
          STML   RTP1
          CALL   ERRH        ISSUE MESSAGE AND RETURN TO MAIN
 MHE      SPACE  4,10
**        MHE - MONITOR HARDWARE ENVIRONMENT.
*
*         CALLS  CES, CMP, DDA, GNE, IDA, PIR, PSS, RMR, SET, SPB,
*                /DSIGHE/RHT, *APE*, *AI2*, *AI4*,*AIE*,
*                *AME*, *CHW*, *PEW*.


          ROUTINE MHE
          CALL   CES         CHECK ERROR CONTROL RECORD STATUS
          LDN    1
          STM    NERR        RESET ERROR FLAG
          LCN    1
          STM    CPUH        INITIALIZE CPU HALTED ORDINAL

*         CLEAR THE SHORT WARNING AND ENVIRONMENT WARNING
*         ERROR OCCURRED FLAGS.

          LDN    0
          STM    SHRR        CLEAR SHORT WARN ERROR
          STM    STON        RESET STUCK ON ERROR CONDITION MET
          STM    PERR        CLEAR ENVIRONMENT WARN ERROR
          STM    CPUO        RESET CPU ORDINAL
          STM    IOUO        RESET IOU ORDINAL
          STM    WARN        RESET WARNING FLAG
          STM    RTP1        RESET TEMP STORAGE CELL

*         GET SUMMARY STATUS REGISTER.

          LDML   IOSS
          STDL   SS
          CALL   PSS         PROCESS SUMMARY STATUS REGISTERS
          LDDL   SS
          STML   IOSS

          LDM    IOUN
          NJP    MHE200      IF IN IOU1, RETURN
          LDDL   T3          SAVE IOU1 SUMMARY STATUS
          STML   MHEC
          LDD    SS          CHECK COMPOSITE SUMMARY STATUS
          ZJP    MHE160      IF NO ERRORS IN MAINFRAME CHECK LAST ENTRY

*         CHECK FOR ERRORS IN EACH CPU, IOU, AND MEMORY.

          LDN    0
          STD    EI          RESET ELEMENT INDEX
          RJM    /DSIGHE/RHT RESET HARDWARE ELEMENT TABLE
 MHE10    RJM    GNE         GET HARDWARE ELEMENT
          MJP    MHE180      IF NO MORE ELEMENTS
          STD    ET          SAVE ELEMENT ID
          SBN    PROCID+1
          MJN    MHE20       IF CPU/IOU/MEM
          AOD    EI          ADVANCE TO NEXT ELEMENT
          UJN    MHE10       CONTINUE

 MHE20    LDN    0           RESET REGISTER LIST INDEX
          STM    REGI
          LDM    HBUF+CPRE+EM
          SHN    -4
          STD    MD          SAVE MODEL
          LDD    ET
          NJN    MHE30       IF NOT IOU TYPE
          LDM    IOUO
          ZJN    MHE30       IF IOU0
          LDML   MHEC        IOU1 SUMMARY STATUS
          LJM    MHE40       SAVE SUMMARY STATUS

 MHE30    LDD    ET
          SBN    PROCID
          NJN    MHE36       IF NOT A CPU
          LDM    HBUF+CPRSTAT
          LPN    4
          NJN    MHE35       IF CPU IS LOGICALLY OFF
          LDDL   EC          SAVE REGISTER
          STDL   W0
          LDN    ECMR        *READMR RDATA,CMCC,ECMR*
          STDL   RN
          LDML   CMCC
          RJM    RMR         READ MAINTENANCE REGISTER
          LDDL   W0          RESTORE *EC* DIRECT CELL
          STDL   EC
          RJM    CMP
          ZJN    MHE36       IF CPU NOT DISABLED
 MHE35    AOM    CPUO
          LJM    MHE145      CONTINUE PROCESSING

 MHE36    LDN    SSMR
          STD    RN
          LDM    HBUF+HDRPC  GENERIC PORT CODE
          LPC    7417
          RJM    RMR         READ SUMMARY STATUS
 MHE40    STM    SUMS        SAVE SUMMARY STATUS
          SHN    21-SSLW     CHECK ENVIRONMENT WARN
          PJP    MHE80       IF NO ENVIRONMENT ERROR

*         IF CYBER 810 OR 830 CHECK IF BATTERY IS ACTIVE IN STATUS REG.
*         IF SO, THIS IS A LONG POWER WARNING.

          LDD    MD          CHECK MODEL
          LMN    0#14
          ZJN    MHE50       IF CYBER 810
          LMN    0#13&0#14
          NJN    MHE60       IF NOT CYBER 830
 MHE50    LDC    ISTR
          STDL   RN
          LDML   I0CC
          RJM    RMR         *READMR RDATA,I0CC,ISTR*
          LDN    0
          STM    BATT        RESET BATTERY ACTIVE
          LDM    RDATA+3
          SHN    21-0
          PJN    MHE60       IF BATTERY BACKUP NOT ACTIVE
          LDN    1
          STM    BATT        SET RUNNING ON BATTERY FLAG
          UJN    MHE70       CONTINUE

 MHE60    LDM    TENV        GET TIMING ENVIRONMENT WARNING
          ZJN    MHE90       IF NOT DOING ANY TIMING
          LDM    TIMU        GET TIME UP FLAG
          ZJN    MHE80       IF DELAY NOT UP YET
 MHE70    LDN    1
          STM    PERR        SET PEW ERROR
          LDN    0
          STM    DTEW        SET FLAG INDICATING DONE TIMING ENV. WARNING
 MHE75    CALL   PEW         CALL ENVIRONMENT PROCESSOR

*         CHECK STATUS OF CURRENT ELEMENT.

 MHE80    LDM    MHEA,ET     INDEX TO JUMP TABLE
          STD    T1
          LJM    0,T1        EXECUTE PROCESSOR

 MHE90    LDM    PWEP        GET CURRENT ENV ENTRY
          ZJN    MHE100      IF NO CURRENT ENTRY
          LDN    1
          STM    WARN        KEEP CURRENT ENTRY DONT START TIMING
          LDN    VER5
          RJM    VCK
          MJN    MHE80
          UJN    MHE75       CONTINUE

 MHE100   LDN    1
          STM    TENV        SET TIMING FLAG
          STM    DTEW        SET FLAG INDICATING NOT DONE TIMING WARN.
          LDD    MD          GET MODEL
          SHN    -4
          STD    T1
          LDN    3           WAIT THREE SECONDS ON ENVIRONMENT WARNING
          STM    STIM        SET WANTED DELAY
          UJN    MHE80       CONTINUE

*         PROCESS CPU ERRORS.

 MHEP     BSS    0
          LDN    0
          STM    RTP1

 MHE110   LDM    SUMS        PROCESSOR
          LPBC   (SSCE,SSUE,SSSW,SSPH)
          NJN    MHE120      IF ERROR PENDING
          AOM    CPUO
          LJM    MHE145      CONTINUE PROCESSING

 MHE120   CALL   APE         CALL ANALYSE PROCESSOR ERRORS
          UJN    MHE135

*         PROCESS IOU ERRORS.

 MHEI     BSS    0
          LDN    0
          STM    RTP1
          LDM    SUMS
          LPBC   (SSBA,SSUE,SSCE)
          NJP    MHE130      IF ERROR
*         LDN    0
          STML   EIEF        CLEAR EXPECTED ERROR FLAG
          UJN    MHE145      GET ANOTHER ELEMENT

 MHE130   CALL   PIR         PROCESS IOU REGISTERS
          CALL   AIE         ANALYZE IOU ERRORS
 MHE135   UJN    MHE140

*         PROCESS MEMORY ERRORS.

 MHEM     BSS    0
          LDN    0
          STM    RTP1
          LDM    SUMS
          LPBC   (SSUE,SSCE)
          ZJN    MHE145      IF NO ERROR TO PROCESS
          CALL   AME         ANALYZE MEMORY ERROR

*         RESUME COMMON PROCESSING.

 MHE140   CALL   DDA         DO DFT ACTIONS
          LDD    ET
          SBN    PROCID
          NJN    MHE145      IF NOT A CPU
          AOM    CPUO
 MHE145   LDD    ET
          SBN    IOUID
          NJN    MHE150      IF NOT AN IOU
          AOM    IOUO
 MHE150   AOD    EI
          LJM    MHE10       CHECK NEXT PROCESSOR

 MHE160   LDM    TENV        TIMING AN ENVIRONMENT WARNING CONDITION
          ZJN    MHE170      IF NOT TIMING ANYTHING
          LDM    NERR        ERRORS OCCURRED FLAG
          ZJN    MHE170      IF ERRORS
          LDN    0
          STM    TENV        NO ERRORS SO NO LONGER NEED TO TIME
          STM    STIM        CLEAR TIMING FLAGS IF NO ENVIRONMENT WARNING
          STM    TIMU
          STM    DTEW
 MHE170   LDM    FREE        LAST MR BUFFER ENTRY WORKED ON
          ZJP    MHE180
          STD    T7
          LDN    CM
          RJM    SET         SET LOCK WORD
          LDDL   CM+BCFLG
          LMBC   (BC.FI)     CLEAR INTERLOCK
          STDL   CM+BCFLG
          LRD    DP+1
          RJM    SPB         SET PP BOUNDS
          LDD    T7
          RJM    IBW         INCREMENT BUFFER CONTROL WORD
          RDCL   CM          CLEAR INTERLOCK ON ENTRY
          LDN    0
          STM    DSIF        CLEAR THE DFT SET THE I/L BIT FLAG

*         IF C180 ERROR OR NOSVE LOGGING OR VALID C180 ERROR SET
*         C180 ERROR IN DFT HEADER.

          CHECK  E8

*         IF C170 ERROR OR NOS/NOSBE LOGS OR VALID C170 ERROR SET
*         C170 ERROR IN DFT HEADER.

          CHECK  E7

          LDN    0
          STM    VOSD        CLEAR VALID OS DATA ACCUMULATOR
          STM    FREE
 MHE180   LDM    WARN        FORMALLY RECOGNIZED SHORT/LONG WARNING
          ADM    NERR        OR IN NO ERROR ON PASS FLAG
          ADM    STON        ADD IN ANY STUCK ON ERROR
          ZJN    MHE190      IF NO POWER/ENVIRONMENT WARNING
          LDM    FREE
          NJP    MHE160      IF MORE HARDWARE ERRORS TO PROCESS
 MHE190   CALL   CHW         CHECK WARNING ENTRY
 MHE200   LDN    0
          STD    EI
          LJM    MHEX        RETURN

 MHEA     CON    MHEI        IOU
          CON    MHEM        MEM
          CON    MHEP        CPU

 MHEC     BSS    1           IOU1 SUMMARY STATUS
 WDR      SPACE  4,10
**        WDR - WAIT FOR DFT REQUEST.
*
*         CALLS  IDA, LRP, SPB, SRS, VCK, *DDA*, *ERR*.
*
*         NOTES  AN ASSUMPTION MADE BY THIS ROUTINE IS THAT THE
*                REQUESTS FOR DFT-S WILL OCCUR SERIALLY.  THIS
*                IS A VALID ASSUMPTION SINCE THE CP CODE WAITS FOR
*                THE COMPLETION OF A DFT REQUEST BEFORE PROCEEDING.


          ROUTINE WDR

          LDML   DI4CW       CHECK DUAL I4 PACKET OUTSTANDING
          NJP    WDRX        IF DUAL I4 PACKETS OUTSTANDING
          LDN    7
          STD    T1
 WDR10    LDN    0
          STM    CALB,T1     CLEAR PREVIOUS REQUEST
          SOD    T1
          PJN    WDR10       IF NOT DONE
          LDN    NVEP
          RJM    IDA
          CRDL   W0          GET POINTER TO NOS/VE
          LDD    W3          GET LENGTH OF NOS/VE COMMUNICATION AREA
          ZJN    WDR25       IF NOS/VE POINTER NOT DEFINED
          LRD    W1
          LDN    0           INITIALIZE INDEX
          STD    T5
 WDR20    LDDL   W0
          ADD    T5
          ADC    RR
          CRDL   JT          GET JOB TASK
          LDM    IOUN
          NJN    WDR30       IF NOT IOU0
          LDDL   JT+3
          NJN    WDR30       IF TASK REQUEST
          AOD    T5
          SBD    W3          COMPARE WITH LENGTH
          NJN    WDR20       IF MORE VE REQUESTS
 WDR25    LJM    WDR60       VE REQUESTS EXHAUSTED

 WDR30    LDN    0
          STD    JT+3        ACCEPT REQUEST
          RJM    SPB         SET PP BOUNDARY
          LDDL   W0
          ADD    T5
          ADC    RR
          CWDL   JT
          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W4
          RJM    SPB         SET PP BOUNDARY
          LDDL   W4          GET TASK
          STDL   JT+3        SAVE REQUEST
          SBN    JTBLL
          PJP    ERR         IF ILLEGAL REQUEST
          LDML   JTBL,JT+3
          STML   DFTA
          SHN    21-17
          PJN    WDR40       IF NO IOU FIELD ON REQUEST
          LDM    JTBL,JT+3   REMOVE IOU FIELD BIT
          STM    DFTA
          LDDL   W5
          SHN    -10
          STD    T1
          LMM    IOUN
          ZJN    WDR40       IF REQUEST IS FOR THIS DFT
          RJM    PRO         PASS REQUEST TO OTHER IOU
          UJN    WDR60       CHECK VERSION

 WDR40    CALL   DDA         DO DFT ACTIONS
          LDML   DI4CW       CHECK DUAL I4 PACKET OUTSTANDING
          NJP    WDRX        IF REQUEST TO START DFT IN SECONDARY
          LDC    0#100
          STM    JOBF        SET 180 STATUS OK
          RJM    SRS         RESPOND TO VE REQUEST
 WDR60    LDN    VER2        VERSION FEATURE IS IMPLEMENTED
          RJM    VCK         VERSION CHECK
          MJN    WDR70       IF OS NOT AT CORRECT VERSION
          LDN    OSRP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0          GET 170 OS REQUEST POINTER
          LDD    W3
          ZJN    WDR70       IF POINTER NOT SET
          LRD    W1
          LDD    W0
          ADC    RR
          CRDL   JT          GET 170 JOB TASK
          LDD    JT+3
          NJN    WDR80       IF ACTIVE REQUEST
 WDR70    LJM    WDRX        RETURN

 WDR80    SBN    1
          NJN    WDR70       IF IGNORE ENTRY
          LDN    1
          STM    R170        TAG THIS REQUEST AS A 170 ONE
          RJM    LRP         LOAD REQUEST POINTER
          CRDL   CM          GET TASKID WORD OF REQUEST
          RJM    SPB         SET PP BOUNDS ON REQ POINTER
          LDD    CM
          LPC    0#FF        ISOLATE TASKID
          STD    CM          SAVE FOR READ
          SBN    JT170L
          PJP    ERR         IF ILLEGAL TASK
          LDM    JT170,CM
          STM    DFTA
          CALL   DDA         DO DFT ACTIONS
          LDC    0#100
          STM    JOBF        SET COMPLETE STATUS
          RJM    SRS         SET REQUEST STATUS
          LJM    WDRX        RETURN
 JTBL     SPACE  4,10
**        JTBL - JOB TABLE ADDRESS TABLE.
*
*         TABLE ENTRY FORMAT -
*                1/I, 1/OF, 2/0, 12/ATL.
*         WHERE -
*                I = 1, IF IOU FIELD IS PRESENT.
*                OF = 1, IF REQUEST PROCESSOR RESIDES IN THE OVERFLOW OVERLAY
*                        OF DFT ACTIONS.
*                ATL = ADDRESS OF TASK LIST FOR REQUEST.


 JTBL     BSS    0
          QUAL
          LOC    0
          CON    0
 H1P      CON    H1PG        TERMINATE 170 CPU
 HVP      CON    HVPG        TERMINATE ALL CPUS
 DVP      CON    DVPG        DEADSTART VIRTUAL PROCESSOR
 SVP      CON    OFLO*40000+SVPG  STOP VIRTUAL PROCESSOR
 LDP      CON    LDPG        LOAD DRIVER PP
 FHI      CON    FCHI        FETCH HARDWARE INFO
 CPR      CON    CPRG        CHANGE PROCESSOR REGISTER
 FCD      CON    FCDP        LOAD CIP DATA TO MEMORY
 ADS      CON    ADSP        ACCESS DEADSTART SECTOR
 RWC      CON    RWCP        ACCESS COMMON DISK AREA
 WCD      CON    PUDT        WRITE WALL CLOCK CHIP
 S1P      CON    S1PG        START 170 PROCESSOR
 PUF      CON    PUFP        HARDWARE IDLE PP
 REP      CON    REPP        RESUME PP
 UFC      CON    PUFC        UPDATE FREE RUNNING COUNTER
 SDT      CON    PTHR        SET DFT THRESHOLDS
 GCS      CON    0#8000+GCSP GET NIO CHANNEL STATUS
 DVR      CON    DVRG        DEADSTART VIRTUAL PROCESSOR (REVISED FOR LVL 92)
 CPO      CON    CPOG        CHANGE PROCESSOR REGISTER (REVISED FOR LVL 92)
 ADR      CON    0#8000+ADRP ACCESS DEADSTART SECTOR (REVISED FOR LVL 92)
 ACA      CON    ACAP        ACCESS COMMON DISK AREA (REVISED FOR LVL 92)
 PUR      CON    0#8000+PURP PP UTILITY FUNCTION (REVISED FOR LVL 92)
 GMR      CON    0#8000+GMRP RETRIEVE MAINTENANCE REGISTERS
 LDS      CON    LDSP        LOAD DFT IN SECONDARY IOU
 IAP      CON    0#8000+IAPP IDLE ALL PP-S IN IOU1
 AHE      CON    AHEP        ACCESS HARDWARE ELEMENT DESCRIPTOR
 RPL      CON    RPLP        REQUEST PROGRAM LENGTH
 RDL      CON    OFLO*40000+RDLP  REQUEST DATA LENGTH
 MVP      CON    OFLO*40000+MVPP  MANAGE VIRTUAL PROCESSOR
 CES      CON    OFLO*40000+PIRP  PROCESS INVALID REQUEST
 GED      CON    OFLO*40000+PIRP  PROCESS INVALID REQUEST
 ASM      CON    OFLO*40000+PIRP  PROCESS INVALID REQUEST
 CDT      CON    OFLO*40000+PIRP  PROCESS INVALID REQUEST
 RDT      CON    OFLO*40000+PIRP  PROCESS INVALID REQUEST
 F43      CON    OFLO*40000+PIRP  PROCESS INVALID REQUEST
 SSA      CON    OFLO*40000+PIRP  PROCESS INVALID REQUEST
 RIS      CON    OFLO*40000+RISC  RETURN IOU STATUS CONTENTS
 RSP      CON    OFLO*40000+RSCI  RESTART SCI PP
          QUAL   *
          LOC    *O
 JTBLL    EQU    *-JTBL
 JT170    SPACE  4,10
**        JT170 - JOB TABLE ADDRESS TABLE FOR NOS, NOS/BE.


 JT170    BSS    0           170 OS REQUEST TABLE
          QUAL
          LOC    0
          CON    0
 UDT      CON    PUDT        170 OS UPDATE TIME REQUEST
 THR      CON    PTHR        170 OS SET THRESHOLDS REQUEST
 UFV      CON    PUFC        170 OS UPDATE FREE RUNNING COUNTER
          QUAL   *
          LOC    *O
 JT170L   EQU    *-JT170
 WM7      SPACE  4,10
**        WM7 - WRITE MODE 77.
*
*         USES   T1, T2, CM - CM+3.
*
*         CALLS  IIB, SPB.


          ROUTINE WM7

          LDM    CPUO
          NJN    WM71        IF DUAL CPU AND CPU=1
          LDN    D7TY
          RJM    IIB
          CRDL   CM
          LDDL   CM+3
          SHN    -14
          ZJN    WM71        IF 180 STANDALONE
          LDN    0
          STDL   T1
          STDL   T2
          CRDL   CM          READ WORD 0
          LDC    0#FC0       77 CODE AT 60 BIT BOUNDARY
          LMDL   CM
          STDL   CM          SAVE IN WORD 0
          LRD    T1
          RJM    SPB         SET PP BOUNDS
          LDN    0
          CWDL   CM          WRITE EXIT MODE 77
 WM71     LJM    WM7X        RETURN
 CES      SPACE  4,10
**        CES - CHECK ERROR CONTROL RECORD STATUS.
*
*         USES   CM - CM+3.
*
*         CALLS  IDA, SPB, UER, VCK.


          ROUTINE CES

          LDN    VER4        DO NOT ACCESS ECR IF LESS THAN VERSION 4
          RJM    VCK         CHECK VERSION
          MJN    CES5        IF VERSION 3 OR LESS, THEN RETURN
          LRD    DP+1
          RJM    SPB         SET OS BOUNDS
          LDN    ECRP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   CM          GET POINTER TO ERROR CONTROL RECORD
          LDDL   CM
          LRD    CM+1
          ADC    RR
          CRDL   CM          GET ERROR CONTROL RECORD HEADER
          LDDL   CM+1
          LPN    2
          ZJN    CES5        IF NO UPDATE OF ERROR CONTROL RECORD REQUIRED
          CALL   UER         UPDATE ERROR CONTROL RECORD
 CES5     UJP    CESX

*         END    CTP$DFT_MAIN_NON_RES_RTNS
*DECK DECK=CTP$DFT_MANAGE_MEMORY_PORT EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_MANAGE_MEMORY_PORT
*
*         THIS DECK ENABLES OR DISABLES MEMORY PORTS FOR
*         PROCESSORS.
*         NOTE:  IF HCM$ IS DEFINED THE CPUS WILL BE HALTED
*                BEFORE ANY MEMORY REGISTER IS WRITTEN.
 EMP      SPACE  4,10
**        EMP - ENABLE MEMORY PORT.
*
*         ENTRY  (HBUF) = PROCESSOR INFORMATION.


          ROUTINE EMP        ENTRY/EXIT
          IF     DEF,HCM$
          RJM    HAC         HALT ALL CPUS
          ENDIF
          LOCKMR SET
          READMR RDATA,CMCC,ECMR  READ MEMORY ENVIRONMENT CONTROL

 EMP2     LDC    SHNI+4+3    GENERATE SHIFT INSTRUCTION
          SBM    HBUF+CPRPORT GET MEMORY PORT
          STM    EMPA        FORM SHIFT COUNT TO PORT DISABLE BIT
          LDN    1
 EMPA     SHN    4+**
          LMC    0#FF
          LPML   RDATA,PO    CLEAR PORT DISABLE BIT FOR THIS PROCESSOR
          STM    RDATA,PO

          FUNCMR HBUF+CPRPC,MRMC   MASTER CLEAR THE PROCESSOR
          WRITMR RDATA,CMCC  REWRITE *EC* REGISTER
          LOCKMR CLEAR
          IF     DEF,HCM$
          LDML   HBUF+CPRPC
          RJM    SAC         START ALL CPUS
          ENDIF
          LJM    EMPX        RETURN
 DMP      SPACE  4,10
**        DMP - DISABLE MEMORY PORT.
*
*         ENTRY  (HBUF) = PROCESSOR INFORMATION.


          ROUTINE DMP
          IF     DEF,HCM$
          RJM    HAC         HALT ALL CPUS
          ENDIF
          LOCKMR SET
          READMR RDATA,CMCC,ECMR  READ MEMORY ENVIRONMENT CONTROL
          LDC    SHNI+4+3    GENERATE SHIFT INSTRUCTION
          SBM    HBUF+CPRPORT GET MEMORY PORT
          STM    DMPA        STORE SHIFT COUNT
          LDN    1
 DMPA     SHN    4+**
          STD    T3          SET MEMORY PORT DISABLE BIT
          LMC    0#FF
          LPML   RDATA,PO
          LMD    T3          SET MEMORY PORT DISABLE BITS FOR EACH CPU
          STM    RDATA,PO

          WRITMR RDATA,CMCC  REWRITE *EC* REGISTER
          FUNCMR HBUF+CPRPC,MRMC   MASTER CLEAR PROCESSOR
          LOCKMR CLEAR
          IF     DEF,HCM$
          LDML   HBUF+CPRPC
          RJM    SAC         START ALL CPUS
          ENDIF
          LJM    DMPX        RETURN

 DIP      SPACE  4,10
**        DIP - DISABLE MEMORY PORT FOR PROCESSOR WITH FATAL ERROR.
*
*         ENTRY  (HBUF) = PROCESSOR INFORMATION.
*
*         NOTE   THIS IS ESSENTIALLY THE SAME AS *DMP* EXCEPT THE
*                PROCESSOR IS NOT MASTER CLEARED.


          ROUTINE DIP
          IF     DEF,HCM$
          RJM    HAC         HALT ALL CPUS
          ENDIF
          LOCKMR SET
          READMR RDATA,CMCC,ECMR  READ MEMORY ENVIRONMENT CONTROL


          LDC    SHNI+4+3    GENERATE SHIFT INSTRUCTION
          SBM    HBUF+CPRPORT GET MEMORY PORT
          STM    DIPA        STORE SHIFT COUNT
          LDN    1
 DIPA     SHN    4+**
          STD    T3          SET MEMORY PORT DISABLE BIT
          LMC    0#FF
          LPML   RDATA,PO
          LMD    T3          SET MEMORY PORT DISABLE BITS FOR EACH CPU
          STM    RDATA,PO
          WRITMR RDATA,CMCC  REWRITE *EC* REGISTER
          LOCKMR CLEAR
          IF     DEF,HCM$
          LDML   HBUF+CPRPC
          RJM    SAC
          ENDIF
          LJM    DIPX        RETURN
 ENP      SPACE  4,10
**        ENP - ENABLE MEMORY PORT.
*
*         ENTRY  (HBUF) = PROCESSOR INFORMATION.
*
*         NOTE   THIS IS ESSENTIALLY THE SAME AS *EMP* EXCEPT THE
*                PROCESSOR IS NOT MASTER CLEARED.


          ROUTINE ENP        ENTRY/EXIT
          IF     DEF,HCM$
          RJM    HAC         HALT ALL CPUS
          ENDIF
          LOCKMR SET
          READMR RDATA,CMCC,ECMR  READ MEMORY ENVIRONMENT CONTROL

 ENP2     LDC    SHNI+4+3    GENERATE SHIFT INSTRUCTION
          SBM    HBUF+CPRPORT GET MEMORY PORT
          STM    ENPA        FORM SHIFT COUNT TO PORT DISABLE BIT
          LDN    1
 ENPA     SHN    4+**
          LMC    0#FF
          LPML   RDATA,PO    CLEAR PORT DISABLE BIT FOR THIS PROCESSOR
          STM    RDATA,PO

          WRITMR RDATA,CMCC  REWRITE *EC* REGISTER
          LOCKMR CLEAR
          IF     DEF,HCM$
          LDML   HBUF+CPRPC
          RJM    SAC         START ALL CPUS
          ENDIF
          LJM    ENPX        RETURN

*         END    CTP$DFT_MANAGE_MEMORY_PORT
*DECK DECK=CTP$DFT_MANAGE_MEMORY_PORT_960 EXPAND=FALSE

*DECK DECK=CTP$DFT_MANAGE_PACKET_TRAFFIC EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT MANAGE PACKET TRAFFIC
*
*         THIS DECK DEFINES CODE WHICH PROCESSES THE VARIOUS
*         PHASES OF PACKET COMMUNICATION.
 CPS      SPACE  4,10
**        CPS - CHECK PACKET STATUS.
*
*         ENTRY  (PKTCW) = PACKET CONTROL WORD.
*                (CELCW) = CONSOLE LOGGING CONTROL WORD.
*                (DI4CW) = DUAL I4 CONTROL WORD.
*
*         EXIT   *LTC* CALLED IF CONSOLE LOGGING REQUIRED/IN PROGRESS.
*                MRT LOGGING INITIATED IF REQUIRED AND NO LOGGING ACTIVE.
*                GENERAL RESPONSE PACKET RECEIVED IF AVAILABLE.
*                GENERAL PACKET SENT IF REQUESTED AND NO LOGGING ACTIVITY.
*                *CHECK-IN* PACKET SENT IF NO OTHER ACTIVITY AND FLAG SET.
*                *LDS* CALLED IF IN MIDST OF DUAL I4 PACKET PROCESSING.
*                IF LOGGING EPM DATA CONTROL WILL RETURN FROM THIS ROUTINE
*                TO THE EPM OVERLAY FOR FURTHER PROCESSING.
*
*         CALLS  CRS, LNO, *LPT*, *RRP*, *SPD*.
*
*         NOTE   THE ORDER IN WHICH THE DIFFERENT SECTIONS OF CODE ARE
*                EXECUTED IS IMPORTANT.  IT HELPS PREVENT THERE BEING
*                MORE THAN ONE PACKET INTERCHANGE ACTIVE AT A TIME.


          ROUTINE  CPS

          LDM    PKFLG       CHECK FOR PACKET SUPPORT ON MAINFRAME
          ZJP    CPSX        IF PACKETS NOT SUPPORTED ON MAINFRAME
          LDML   PKTCW       CHECK GENERAL PACKET STATUS
          SHN    21-17
          PJN    CPS1        IF NO RESPONSE PENDING
          SHN    21-16-21+17
          PJP    CPS2        IF NOT TIMED OUT
          CALL   LPT         LOG PACKET TIMEOUT
          LDML   PKTCW
          LPC    0#100       CHECK IF PHASED MODE
          ZJN    CPS0        IF NON PHASED PACKET
          LDM    PKTCW1
          SHN    14
          LMML   PKTCW2
          RJM    LNO         PERFORM CALL OPERATION
 CPS0     LDM    PKTCW       CLEAR TIME OUT FLAG
          STM    PKTCW
 CPS1     LDML   DI4CW       CHECK FOR DUAL IOU PACKETS
          ADML   CELCW       CHECK GENERAL PACKETS
          ADML   MRTU        CHECK MRT UPDATE
          ADML   PKTCW       CHECK GENERAL PACKETS
          ZJP    CPSX        IF NOTHING TO INITIATE
          CALL   SPD         SEND PACKET DATA
          UJN    CPS3        RETURN

 CPS2     RJM    CRS         CHECK RESPONSE STATUS
          ZJP    CPSX        IF RESPONSE PACKET NOT AVAILABLE
          CALL   RRP         RECEIVE RESPONSE PACKET
          LDML   PKTCW
          LPC    0#100       CHECK IF PHASED MODE
          ZJN    CPS3        IF NON PHASED PACKET
          LDM    PKTCW1
          SHN    14
          LMML   PKTCW2
          RJM    LNO         PERFORM CALL OPERATION
 CPS3     LJM    CPSX        RETURN


*         END    CTP$DFT CHECK PACKET STATUS
*DECK DECK=CTP$DFT_MASSAGE_CPU_REGISTERS EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT MASSAGE CPU REGISTERS.
*
*         THIS DECK CONTAINS ROUTINES THAT LOAD CPU REGISTERS
*         FOR INITIALIZATION, HALF EXCHANGE OPERATIONS, AND
*         HALTING OPERATIONS.
 HAP      SPACE  4,10
**        HAP - HALT ALL PROCESSORS.
*
*         CALLS  FHE, *STP*.


          ROUTINE HAP

          LDN    0           INITIALIZE ELEMENT ORDINAL
          STM    ELMO
          LDN    PROCID      SEARCH FOR NEXT PROCESSOR
 HAP1     RJM    FHE
          MJP    HAPX        IF ALL PROCESSORS HALTED
          CALL   STP         STOP PROCESSOR
          AOM    ELMO        GET NEXT ELEMENT
          SHN    14
          ADN    PROCID
          UJN    HAP1        LOOP
 IXP      SPACE  4,10
**        IXP - INITIALIZE EXCHANGE PACKAGE.
*
*         ENTRY  *MPS* REGISTER INITIALIZED IN PROCESSOR.
*
*         EXIT   MONITOR EXCHANGE PACKAGE INITIALIZED.
*
*         CALLS  PAC, SPB, *SRA*.


          ROUTINE IXP

          LDM    MPSR
          STD    RN
          READMR RDATA,HBUF+CPRPC  READ *MPS*
          RJM    PAC

*         CONVERT PACKED (8 BIT TO 16 BIT) FORMAT TO R-REGISTER FORMAT.

          LDML   MRVAL+2
          STDL   W2
          LDML   MRVAL+3
          STDL   W3
          CALL   SRA         CONVERT RMA BYTE ADDRESS TO R-POINTER
          RJM    SPB         SET PP BOUNDS
          LDDL   W6
          ADC    RR+1+0#1E
          CRDL   W0          FETCH *XE* REGISTER
          LDDL   W6
          ADC    RR+1+0#0D   GET BASE CONSTANT REGISTER
          CRDL   T4
          LDDL   W1          GET BASE VALUE FROM XE
          STDL   T4          INITIALIZE BASE CONSTANT REGISTER
          LDD    CP          GET CPU INDEX
          STD    T1
          ZJN    IXP6        IF CPU 0

*         CALCULATE BASE CONSTANT = BASE + SIZE * CPU INDEX.

 IXP5     LDDL   W3
          RADL   T4          ADD IN SIZE
          SOD    T1
          MJN    IXP5        IF NEED TO ADD MORE
 IXP6     LDDL   W6
          ADC    RR+1+0#0D
          CWDL   T4          REWRITE BASE CONSTANT
          LJM    IXPX        RETURN
 LCB      SPACE  4,10
**        LCB - LOAD CPU REGISTERS FROM BUFFER.
*
*         ENTRY  REGISTERS POINTED TO BY REQUEST.
*
*         EXIT   REGISTERS LOADED IN CPU.
*
*         CALLS  GNR, LRP, SRB.


          ROUTINE LCB        ENTRY/EXIT

          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0
          LDDL   W1          LOAD OFFSET TO BUFFER
          LRD    W2
          RJM    SRB         SET UP REGISTER BUFFER
 LCB1     RJM    GNR         GET NEXT REGISTER
          ZJP    LCBX        IF NO MORE REGISTERS TO PROCESS
          LDC    0#0800      INCLUDE TYPE-8 REGISTER FLAG FOR S0/S0E MAINFRAMES
          RAD    RN
          WRITMR RDATA,HBUF+CPRPC  LOAD REGISTER
          UJN    LCB1
 LCR      SPACE  4,10
**        LCR - LOAD CPU REGISTERS FROM BUFFER (CALL FORMAT REVISED FOR LVL 92).
*
*         ENTRY  REGISTERS POINTED TO BY REQUEST + 1.
*
*         EXIT   REGISTERS LOADED IN CPU.
*
*         USES   W0 - W4.
*
*         CALLS  GNR, LRP, SRB.


          ROUTINE  LCR       ENTRY/EXIT

          LDM    S0FLG       CHECK MAINFRAME TYPE
          ZJN    LCR1        IF NOT POSSIBLY DUAL-CPU S0E
          RJM    HOC         HALT OTHER CPU
 LCR1     RJM    LRP         LOAD REQUEST POINTER
          ADN    1
          CRDL   W0
          LDML   W3          SAVE LENGTH
          STML   LCRA
          LDDL   W0          LOAD OFFSET TO BUFFER
          LRD    W1
          RJM    SRB         SET UP REGISTER BUFFER
 LCR2     LDC    **          CHECK FOR LENGTH EXHAUSTED
 LCRA     EQU    *-1
          ZJN    LCR4        IF LENGTH HAS BEEN EXCEEDED
          RJM    GNR         GET NEXT REGISTER
          ZJN    LCR3        IF NO MORE REGISTERS TO PROCESS
          LDC    0#0800      INCLUDE TYPE-8 REGISTER FLAG FOR S0/S0E MAINFRAMES
          RAD    RN
          WRITMR RDATA,HBUF+CPRPC  LOAD REGISTER
          SOML   LCRA
          UJN    LCR2        GET NEXT REGISTER

 LCR3     LDM    S0FLG       CHECK MAINFRAME TYPE
          ZJP    LCRX        IF NOT POSSIBLY DUAL-CPU S0E
          RJM    SOC         START OTHER CPU
          LJM    LCRX        RETURN

*         DFT ANALYSIS - R POINTER LENGTH EXCEEDED.

 LCR4     SETDAN (EPUN,DADV)
          LDC    DADV+TDFT   619 -- R-POINTER LENGTH EXCEEDED IN *DVR* PROCESSING
          STML   RTP1
          CALL   ERRH        ISSUE MESSAGE AND HANG
 PRI      SPACE  4,10
**        PRI - PREPARE FOR REGISTER INITIALIZATION.
*
*         PROCESSOR IS MASTER CLEARED, *CSA* REGISTER IS SET TO IDLE,
*         AND PROCESSOR RESTARTED.
*
*         ENTRY  PROCESSOR IS HALTED.
*
*         EXIT   PROCESSOR IS READY FOR REGISTER INITIALIZATION.
*
*         CALLS  SMC, *EMP*.


          ROUTINE PRI

          CALL   EMP         CLEAR PORT DISABLE FOR PROCESSOR
          CALL   CLE         CLEAR ERRORS IN THE CPU BEFORE INITIALIZATION
          LDD    MD          GET MODEL
          SHN    -4
          LMN    2
          NJN    PRI0        IF NOT AN 835
          LDML   MLIT        LONG INIT ADDRESS
          UJN    PRI1

 PRI0     LDML   MIDL
          STDL   T1
          LMC    4000        NULL MICROCODE ADDRESS
          ZJN    PRI2        IF NO MICROCODE ROUTINE NEEDED
          LDDL   T1
 PRI1     RJM    SMC         START MICROCODE
 PRI2     LJM    PRIX        RETURN
 SCR      SPACE  4,10
**        SCR - SAVE CPU REGISTERS.
*
*         THE CPU REGISTERS ARE SAVED IN A BUFFER PROVIDED IN THE
*         CALL TO DFT.
*
*         ENTRY  NOS/VE REQUEST CONTAINS BUFFER ADDRESS.
*
*         EXIT   APPROPRIATE REGISTERS ARE SAVED.
*
*         CALLS  LRP, SNR, SPB, SRB.


          ROUTINE SCR        ENTRY/EXIT

          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0          FETCH REQUEST
          LRD    W2
          RJM    SPB         SET PP BOUNDARY
          LDC    SCRB        *H1P* REGISTER LIST
          STD    T6
          LDD    JT+3
          SBN    H1P
          ZJN    SCR1        IF *H1P* HALT 170 PROCESSOR
          LDC    SCRA        REGISTER LIST FOR ALL OTHERS
          STD    T6
          LDD    CP          FORM OFFSET TO REGISTER LIST (CP * 16)
          SHN    4
 SCR1     ADDL   W1          ADD OFFSET TO BUFFER
          RJM    SRB         SET UP REGISTER BUFFER
 SCR2     LDI    T6
          STD    RN          SAVE REGISTER NUMBER
          ZJP    SCRX        IF END OF REGISTERS
          READMR RDATA       READ REGISTER CONTENTS
          RJM    SNR         STORE NEXT REGISTER
          AOD    T6
          UJN    SCR2        READ NEXT REGISTER

*         REGISTER SAVE LISTS USED FOR DUAL STATE SWITCHING.

 SCRA     CON    PPRG        PROGRAM REGISTER
          CON    PUPR        UNTRANSLATABLE POINTER

*         NOTE: THE ORDER IN THE FOLLOWING REGISTER LIST IS IMPORTANT.
*         *PTL* AND *PSM* SHOULD BE SET UP BEFORE *PTA* IS INITIALIZED.
*         BOGUS VALUES IN THE *PTA* REGISTER WILL RESULT IF THIS ORDER IS
*         NOT FOLLOWED.

 SCRB     CON    PPTL        PAGE TABLE LENGTH
          CON    PPSM        PAGE SIZE MASK
          CON    PPTA        PAGE TABLE ADDRESS
          CON    PSIT        PROCESSOR SIT
          CON    PMPS        MONITOR PROCESS POINTER
          CON    PJPS        JOB PROCESS POINTER
          CON    0           END OF TABLE
 SMP      SPACE  4,10
**        SMP - SET *MPS* REGISTER IN PROCESSOR (CALL REVISED FOR LVL 92).
*
*         ENTRY  *MPS* VALUE IN NOS/VE REQUEST.
*
*         USES   RN, W0 - W3.
*
*         CALLS  LRP, UPR.
*
*         MACROS WRITMR.


          ROUTINE  SMP

          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0          FETCH PARAMETER WITH *MPS*
          LDDL   W2
          STML   MRVAL+2
          LDDL   W3
          STML   MRVAL+3
          RJM    UPR         UNPACK REGISTER
          LDM    MPSR
          STD    RN
          WRITMR RDATA,HBUF+HDRPC
          LJM    SMPX        RETURN
 SMR      SPACE  4,10
**        SMR - SET *MPS* REGISTER IN PROCESSOR.
*
*         ENTRY  *MPS* VALUE IN NOS/VE REQUEST.
*
*         USES   W0 - W3.
*
*         CALLS  UPR.


          ROUTINE SMR

          RJM    LRP
          ADN    1
          CRDL   W0          FETCH PARAMETER WITH *MPS*
          LDDL   W2
          STML   MRVAL+2
          LDDL   W3
          STML   MRVAL+3
          RJM    UPR         UNPACK REGISTER
          LDM    MPSR
          STD    RN
          WRITMR RDATA,HBUF+HDRPC
          LJM    SMRX        RETURN
 SRA      SPACE  4,10
**        SRA - SET RELOCATION ADDRESS.
*
*         ENTRY  (MRVAL) = PACKED REGISTER 32 BIT RMA BYTE ADDRESS.
*
*         EXIT   (A) = PARTIAL ADDRESS.
*                (W6) = PARTIAL ADDRESS.
*                THE INPUT BYTE ADDRESS RMA WILL BE CONVERTED TO
*                AN R-REGISTER POINTER WORD ADDRESS.
*
*         CALLS  STA.


          ROUTINE SRA

          LDN    2
          STD    T5
          LDN    3
          STD    T6
          LDML   MRVAL,T5
          STDL   W2
          LDML   MRVAL,T6
          SHN    -3
          STDL   W3
          LDDL   W2
          LPN    7
          SHN    15
          LMDL   W3
          STDL   W3
          LDDL   W2
          SHN    -3
          STDL   W2
          RJM    STA
          LJM    SRAX        RETURN
 STP      SPACE  4,10
**        STP - STOP PROCESSOR.
*
*         CALLS  RMR, *ERRH*.


          ROUTINE STP

          LDM    HBUF+CPRPC  CHECK PORT CODE
          ZJN    STP3        IF INVALID PORT
          LDN    SSMR
          STD    RN
          LDM    HBUF+CPRPC
          RJM    RMR         READ SUMMARY STATUS
          LPN    0#8
          NJN    STP2        IF PROCESSOR IS HALTED
          FUNCMR ,MRHP       STOP PROCESSOR
 STP2     LDM    HBUF+CPRPC
          RJM    RMR         READ SUMMARY STATUS
          LPN    0#8
          ZJN    STP2        IF NOT HALTED
          LJM    STPX        RETURN

*         DFT ANALYSIS - INVALID PORT CODE FOR CPU.

 STP3     SETDAN (EPUN,DADV)
          LDC    DAHP+TDFT   609 - DFT HALT PROCESSOR
          STML   RTP1
          CALL   ERRH        ISSUE MESSAGE AND HANG
 HOC      SPACE  4,10
**        HOC - HALT OTHER CPU.
*
*         ON DUAL-CPU S0E MAINFRAMES, THE SHARED PAGE MAP ELEMENT REQUIRES
*         THAT NEITHER CPU BE ACTIVE WHEN INITIALIZING *PTA*, *PTL*, OR *PSM*
*         IN EITHER CPU.
*
*         NOTE   THIS ROUTINE ASSUMES THAT NO MORE THAN TWO CPUS EXIST.
*                THE CONTENTS OF *HBUF* MUST NOT BE DISTURBED.
*
*         MACROS FUNCMR, READMR.


 HOC      SUBR               ENTRY/EXIT
          READMR RDATA,S0PMC,S0PPMC  GET CPU PORT ENABLE/DISABLE STATUS
          LDM    HBUF+CPRPC  DETERMINE CPU NUMBER BEING INITIALIZED
          LPN    1
          ZJN    HOC1        IF CPU-0 BEING INITIALIZED

*         HALT CPU-0 IF PRESENT AND ACTIVE.

          LDM    CPU0M       CHECK IF CPU-0 PRESENT
          ZJN    HOCX        IF CPU-0 NOT PRESENT
          LDM    RDATA+1     CHECK CPU-0 ENABLE/DISABLE STATUS
          LPC    0#80
          NJN    HOCX        IF CPU-0 NOT ENABLED
          FUNCMR CP0CC,MRHP  HALT CPU-0
          LJM    HOCX        RETURN

*         HALT CPU-1 IF PRESENT AND ACTIVE.

 HOC1     LDM    CPU1M       CHECK IF CPU-1 PRESENT
          ZJN    HOC2        IF CPU-1 NOT PRESENT
          LDM    RDATA+1     CHECK CPU-1 ENABLE/DISABLE STATUS
          LPC    0#40
          NJN    HOC2        IF CPU-1 NOT ENABLED
          FUNCMR CP1CC,MRHP  HALT CPU-1
 HOC2     LJM    HOCX        RETURN
 SOC      SPACE  4,10
**        SOC - START OTHER CPU.
*
*         ON DUAL-CPU S0E MAINFRAMES, THE SHARED PAGE MAP ELEMENT REQUIRES
*         THAT NEITHER CPU BE ACTIVE WHEN INITIALIZING *PTA*, *PTL*, OR *PSM*
*         IN EITHER CPU.
*
*         NOTE   THIS ROUTINE ASSUMES THAT NO MORE THAN TWO CPUS EXIST.
*                THE CONTENTS OF *HBUF* MUST NOT BE DISTURBED.
*
*         MACROS FUNCMR, READMR.


 SOC      SUBR               ENTRY/EXIT
          READMR RDATA,S0PMC,S0PPMC  GET CPU PORT ENABLE/DISABLE STATUS
          LDM    HBUF+CPRPC  DETERMINE CPU NUMBER BEING INITIALIZED
          LPN    1
          ZJN    SOC1        IF CPU-0 BEING INITIALIZED

*         START CPU-0 IF PRESENT AND ACTIVE.

          LDM    CPU0M       CHECK IF CPU-0 PRESENT
          ZJN    SOCX        IF CPU-0 NOT PRESENT
          LDM    RDATA+1     CHECK CPU-0 ENABLE/DISABLE STATUS
          LPC    0#80
          NJN    SOCX        IF CPU-0 NOT ENABLED
          FUNCMR CP0CC,MRSP  START CPU-0
          LJM    SOCX        RETURN

*         START CPU-1 IF PRESENT AND ACTIVE.

 SOC1     LDM    CPU1M       CHECK IF CPU-1 PRESENT
          ZJN    SOC2        IF CPU-1 NOT PRESENT
          LDM    RDATA+1     CHECK CPU-1 ENABLE/DISABLE STATUS
          LPC    0#40
          NJN    SOC2        IF CPU-1 NOT ENABLED
          FUNCMR CP1CC,MRSP  START CPU-1
 SOC2     LJM    SOCX        RETURN
 COMMON   SPACE  4,10
*         COMMON DECKS.


 QUAL$    EQU    0           DEFINE UNQUALIFIED COMMON DECK
*COPY     CTP$DFT_START_MICROCODE

*         END    CTP$DFT MASSAGE CPU REGISTERS
*DECK DECK=CTP$DFT_MDB_LOGGING_ROUTINES EXPAND=TRUE

          EJECT
*         CTEXT  CTP$DFT_MDB_LOGGING_ROUTINES
*
*         J.M. SKOWRONEK     9/25/87.
*
*         THIS DECK IS USED WITH DECK CTC$DFT_MDB_LOGGING_CONSTANTS.

          LIST   X

**        BBC - BUILD AND WRITE MAINTINANCE BUFFER CONTROL WORD
*
*         METHOD             SET UP THE SCRATCH 0 CONTROL WORD FLAGS PORTION
*                            FOR VALID DATA.
*
*         ENTRY              SCRATCH 0 CONTROL WORD IN BC - BC+3.
*
*         USES               BC.
*
*         CALLS              BSB.
*
*         EXIT               SCRATCH 0 CONTROL WORD FLAGS PORTION SET TO
*                            VALID DATA.

 BBC      SUBR               ENTRY/EXIT

          LDDL   BC+BCFLG    BUFFER CONTROL WORD FLAG
          ADC    BCW.VD      ADD VALID DATA FLAG
          STDL   BC+BCFLG    BUFFER CONTROL WORD FLAG
          RJM    BSB         BUILD AND WRITE SSB WORD
          UJP    BBCX        EXIT
          EJECT
**        BHW - BUILD AND WRITE MDB MAIN HEADER WORD.
*
*         METHOD             SET UP THE MDB MAIN HEADER WORD WITH THE
*                            ERROR PRIORITY FOR THIS ERROR.  WRITE
*                            THE HEADER WORD.  CHECK LONG TERM INTERLOCK
*                            FLAG IN CW0.
*
*         ENTRY              MDB MAIN HEADER IN CM - CM+3.
*
*                            MDB MAIN ADDRESS IN RS+1.
*
*                            CEPR = CURRENT ERROR PRIORITY.
*
*         USES               RS - RS+2.
*
*         CALLS              NA.
*
*         EXIT               MAIN HEADER WORD WRITTEN TO MDB.
*                            UPDATED MAIN HEADER WORD IN CM - CM+3.
*                            (A) = 0 IF LOGGING TO CPU0 BUFFER
*                            (A) = 1 IF CANNOT LOG TO CPU0 BUFFER


 BHW      SUBR               ENTRY/EXIT

          LDML   MDBW
          NJN    BHW4        IF WRITING TO OVERFLOW BUFFER
          LDML   LTIF
          NJN    BHW1        IF LONGTERM INTERLOCK SET
          LDN    1
          UJN    BHW3

 BHW1     LDDL   CM+V4DHPRI  PREVIOUS PRIORITY
          LPC    0#F000
          SHN    -12D        POSITION
          SBM    CEPR        COMPARE TO CURRENT PRIORITY
          MJN    BHW2        IF CURRENT GREATER THAN OLD
          LDN    1           FLAG NOT LOGGABLE
          UJP    BHWX

 BHW2     LDN    8D          SET LTI OVERWRITE CONDITION
 BHW3     SHN    8D          POSITION LTI FLAG
          LMDL   CM+V4DHCWD  SET OTHER BITS
          STDL   CM+V4DHCWD  STORE WITH LTI FLAG SET
 BHW4     LDN    0
          STDL   CM+V4DHLTL  CLEAR LENGTH TO LOG ENTRY

          LDDL   CM+V4DHPRI  LOAD PRIORITY IN WRITE BUFFER
          LPC    0#0FFF      MASK OFF OLD PRIORITY
          STDL   CM+V4DHPRI  STORE WITHOUT PRIORITY IN WRITE BUFFER

          LDML   CEPR        LOAD CURRENT ERROR PRIORITY
          SHN    12D         SHIFT TO NEEDED POSITION
          LMDL   CM+V4DHPRI  SET OTHER BITS
          STDL   CM+V4DHPRI  STORE WITH PRIORITY IN WRITE BUFFER

*         WRITE CPU MDB BUFFER.

          LRD    RS+1        UPPER ADDRESS OF SELECTED MDB
          LDD    RS          OTHER OFFSET
          ADC    RR          SET BIT 18
          CWDL   CM          WRITE MDB HEADER WORD
          AOML   LTOL        INCREMENT LENGTH TO LOG COUNTER
          LDN    0
          UJP    BHWX        EXIT
          EJECT
**        BSB - BUILD AND WRITE SSB WORD.
*
*         METHOD             GET THE SSB ADDRESS AND READ THE SSB WORD.
*                            SET UP THE SSB WORD FOR LOGGABLE, OVERWRITE OR
*                            UNLOGGABLE DATA, AND WRITE THE SSB WORD.
*
*         ENTRY              BCWF = 0 IF LOGGABLE DATA.
*                                 = 1 IF OVERWRITE DATA.
*                                 = 2 IF UNLOGGABLE DATA.
*
*                            CWDO = OFFSET TO MAINTENANCE BUFFER CONTROL/
*                                   SUPPORTIVE STATUS BUFFER WORD.
*
*                            OFFF = 0 USE CPU MDB OFFSET.
*                                 = 1 USE OVERFLOW MDB OFFSET.
*
*                            OFFO = OVERFLOW OFFSET.  (2)
*
*         USES               BCWF, CM, CWDO, OFFF, RS - RS+2.
*
*         CALLS              IDA.
*
*         EXIT               SSB WORD WRITTEN WITH FLAGS SET TO REFLECT
*                            A LOGABLE, UNLOGABLE, OR OVERWRITE CONDITION.
*
*                            IF LOGGABLE DATA, SSB 0 = ORDINAL. (BCWF = 0)
*
*                            IF OVERWRITE DATA, OFFSET SSB = 2, SSB 0 =
*                            OVERFLOW ORDINAL.  (BCWF = 1)
*
*                            IF UNLOGGABLE DATA, SSB 0 = 1.  (BCWF = 2)
*

 BSB      SUBR               ENTRY/EXIT

*         READ SSB HEADER WORD.

          LDN    SSBP        LOAD SSB HEADER POINTER
          RJM    IDA         INCREMENT THE DFT ADDRESS
          CRDL   RS          READ THE SSB HEADER ADDRESS

          LRD    RS+1        UPPER SSB WORD ADDRESS
          LDD    RS
          ADC    RR          SET BIT 18
          CRDL   CM          READ SSB HEADER WORD

*         MULTIPLY SSB ELEMENT SIZE TIMES GROUP OFFSET.

          LDML   CWDO        LOAD OFFSET FOR SSB GROUP
          STML   BSBA        SAVE AS INDEX
          LDN    0
          STML   BSBB        CLEAR LOCATION
 BSB0     LDDL   CM+V4SBSIZ  LOAD SSB ELEMENT SIZE
          RAML   BSBB        ADD
          SOML   BSBA        DECREMENT GROUP OFFSET
          PJN    BSB0        IF NOT ZERO

          LDML   BCWF        WRITE FLAG
          ZJN    BSB1        IF LOGGABLE READ SSB WORD
          SBN    2
          ZJN    BSB1        IF UNLOGGABLE READ SSB WORD
          LJM    BSB6        OVERWRITE CONDITION

*         READ SSB WORD.

 BSB1     ADD    RS
          ADN    1           OFFSET FOR SSB WORD
          ADC    RR          SET BIT 18
          CRDL   CM          READ SSB WORD

          LDML   BCWF        WRITE FLAG
          ZJN    BSB2        IF LOGGABLE SET MDB ORDINAL
          SBN    2
          ZJN    BSB3        IF UNLOGGABLE SET UNLOGGABLE FLAG
          LJM    BSB7        IF OVERWRITE SET OVERWRITE FLAG

 BSB2     LDML   OFFF        OFFSET FLAG
          ZJP    BSB8        SET CPU ORDINAL

*         SET MDB OVERFLOW ORDINAL IN SSB WORD.

          LDDL   CM+V4SBLOG  SSB LOG WORD
          LPC    0#FF00      MASK OUT OLD ORDINAL
          ADN    OFFO        ADD OVERFLOW ORDINAL
          UJN    BSB4

*         SET UNLOGGABLE DATA FLAG.

 BSB3     LDDL   CM+V4SBLOG  SSB LOG WORD
          LPC    0#00FF      MASK OFF OLD LOGGING BITS
          ADC    SSB.UL      SET UNLOGGABLE BIT
 BSB4     STDL   CM+V4SBLOG  STORE TO WRITE BUFFER
          LDD    RS
          ADN    1           OFFSET FOR SSB WORD
 BSB5     ADC    RR          ADD BIT 18
          CWDL   CM          WRITE SSB WORD
          UJP    BSBX        EXIT

*         READ SSB WORD.

 BSB6     LDD    RS
          ADN    1           OFFSET FOR SSB WORD
          ADC    RR          SET BIT 18
          CRDL   CM          READ SSB WORD

*         SET MDB OVERFLOW ORDINAL IN SSB WORD FOR OVERWRITE CONDITION.

          LDDL   CM+V4SBLOG  SSB LOG WORD
          LPC    0#FF00      MASK OUT OLD ORDINAL
          ADN    OFFO        ADD OVERFLOW ORDINAL
          STDL   CM+V4SBLOG  STORE TO WRITE BUFFER
          LDD    RS
          ADN    1           OFFSET FOR SSB WORD
          ADC    RR          ADD BIT 18
          CWDL   CM          WRITE SSB WORD

          LDML   BSBB        SSB OFFSET
          LJM    BSB1        READ OFFSET SSB

*         OVERWRITE DATA

 BSB7     LDDL   CM+V4SBLOG  SSB WORD
          LPC    0#00FF      MASK OFF OLD LOGGING BITS
          ADC    SSB.OW      SET OVERWRITE BIT
          STDL   CM+V4SBLOG  WRITE BUFFER
          LDML   BSBB        SSB OFFSET
          ADD    RS
          ADN    1           OFFSET FOR SSB WORD
          LJM    BSB5

*         SET CPU ORDINAL IN SSB WORD.

 BSB8     LDDL   CM+V4SBLOG  SSB LOG WORD
          LPC    0#FF00      MASK OUT OLD ORDINAL
          ADML   CPUO        ADD CPU ORDINAL
          LJM    BSB4

 BSBA     BSS    1
 BSBB     BSS    1


          EJECT
**        DLC - DETERMINE LOGGING CONDITIONS.
*
*         METHOD             UPON CPU ERROR, DETERMINE IF THE ERROR CAN BE
*                            LOGGED IN THE MODEL DEPENDENT BUFFER, THE
*                            OVERFLOW BUFFER, OVERWRITTEN, OR IF IT IS
*                            UNLOGGABLE.
*
*         ENTRY              CURRENT ERROR PRIORITY IN LOCATION CEPR.
*
*         USES               BCWF, CWDC, CWDO, DSIF, EPRO, INTB, LTOL,
*                            MDBW, MFLG.
*
*         CALLS              BBC, BHW, ITUF, RCH, RBC, ROH, TDE, VCK.
*
*         EXIT               IF A LOGGABLE ERROR EXISTS:
*                            THE ERROR PRIORITY WILL BE INSERTED IN THE MAIN
*                            HEADER WORD, THE MAINTENANCE BUFFER CONTROL WORD
*                            WILL BE VALIDATED AND THE SUPPORTIVE STATUS
*                            BUFFER WORD WILL REFLECT A LOGGABLE ERROR.
*                            THE ADDRESS OF THE MDB MAIN HEADER WORD WILL BE
*                            IN RS - RS+2.
*
*                            IF AN OVERWRITE CONDITION EXISTS:
*                            THE ERROR PRIORITY WILL BE INSERTED IN THE MAIN
*                            HEADER WORD, THE MAINTENANCE BUFFER CONTROL WORD
*                            WILL BE VALIDATED AND THE SUPPORTIVE STATUS
*                            BUFFER WORD WILL REFLECT AN OVERWRITE CONDITION.
*                            THE ADDRESS OF THE MDB MAIN HEADER WORD WILL BE
*                            IN RS - RS+2.
*
*                            IF AN UNLOGGABLE ERROR EXISTS, THE SUPPORTIVE
*                            STATUS BUFFER WORD WILL REFLECT AN UNLOGGABLE
*                            CONDITION.
*
*                            BCWF = 0 IF LOGGABLE DATA.
*                                 = 1 IF OVERWRITE DATA.
*                                 = 2 IF UNLOGGABLE DATA.

          ROUTINE DLC        ENTRY/EXIT

          LDN    VER4        MINIMUM VERSION NUMBER THAT CAN BE USED
          RJM    VCK         CHECK VERSION
          PJN    DLC0.1      IF VERSION 4 OR GREATER

*         CANNOT LOG DATA.

 DLC0     LDN    2
          STML   BCWF        SET UNLOGGABLE DATA FLAG
          UJP    DLCX        EXIT

 DLC0.1   CALL   TDE         TEST FOR DUPLICATE ENTRY
          LDML   MFLG        MATCH FLAG
          ZJN    DLC0        IF NEW ERROR MATCHES PREVIOUS

          LDN    0
          STML   LTOL        INITIALIZE LENGTH OF DATA TO LOG COUNTER
          STML   ITUF        INITIALIZE ISSUE TIME OUT UNLOGGABLE FLAG
          STML   BCWF        SET UP FOR POSSIBLE LOGGABLE CONDITION

          RJM    RCH         FIND CPU MDB, READ MAIN HEADER, SAVE CW WORD

          RJM    ROH         FIND OVERFLOW MDB, READ MAIN HEADER, SAVE CW WORD

          LDML   CWDC        LOAD CPU MDB CW WORD
          ZJN    DLC1        IF CPU MDB CW WORD = 00, LOG ENTRY CAN BE MADE

 DLC0.5   LDML   CWDO        LOAD OVERFLOW MDB CW WORD
          ZJN    DLC2        IF OVERFLOW MDB CW WORD = 00, LOG ENTRY CAN BE MADE

          UJN    DLC4        TEST FOR UNLOGGABLE CONDITION

*         LOG ENTRY CAN BE MADE.

 DLC1     STML   MDBW        ZERO = WRITE TO CPU MDB
          RJM    RCH         FIND CPU MDB AND GET MDB BASE ADDRESS
          UJN    DLC3

 DLC2     LDN    1
          STML   MDBW        ONE = WRITE TO OVERFLOW MDB

*         INSERT ERROR PRIORITY IN MAIN HEADER WORD AND WRITE TO MDB.

 DLC3     RJM    BHW         BUILD AND WRITE MAIN HEADER WORD FOR MDB IN USE
          ZJN    DLC3.5      IF LOGGING TO CPU0 BUFFER
          RJM    ROH         FIND OVERFLOW MDB, READ MAIN HEADER, SAVE CW WORD
          UJP    DLC0.5      GO BEGIN OVERFLOW BUFFER LOGGING

 DLC3.5   RJM    BBC         WRITE SCRATCH 0, BUILD AND WRITE NEW SSB WORD

          LJM    DLC7        GET MDB MAIN HEADER ADDRESS

*         BOTH MDB'S HAVE DATA SO TEST FOR UNLOGGABLE CONDITION.

 DLC4     LDN    1           SET UP FOR POSSIBLE OVERWRITE CONDITION
          STML   BCWF        BUFFER CONTROL WORD WRITE FLAG SAY OVERWRITE
          LDML   DSIF
          NJN    DLC4.1      IF INTERLOCK SET BY DFT AND NOT OS

          RJM    RBC         GET INTERLOCK FROM BUFFER CONTROL WORD
          SHN    15D         SHIFT
          MJN    DLC5        IF INTERLOCK SET

*         TEST FOR OVERWRITE CONDITION.

 DLC4.1   LDML   EPRO        ERROR PRIORITY OF OVERFLOW MDB
          SBML   CEPR        CURRENT ERROR PRIORITY
          MJN    DLC6        IF OVERWRITE CONDITION

*         UNLOGGABLE DATA.

 DLC5     LDN    2           UNLOGGABLE CONDITION
          STML   BCWF        BUFFER CONTROL WORD WRITE FLAG SAY UNLOGGABLE
          STML   ITUF        UNLOGGABLE FLAG FOR ISSUE TIME OUT
          RJM    BBC         BUILD AND WRITE NEW MAINTENANCE BUFFER CONTROL WORD
          UJN    DLC9        EXIT

*         DEFINITE OVERWRITE.

 DLC6     RJM    ROH         FIND OVERFLOW MDB AND READ MAIN HEADER
          LJM    DLC2        CONTINUE AS LOGGABLE ERROR

*         GET THE MAIN HEADER ADDRESS OF THE MDB IN USE.

 DLC7     LDML   MDBW        MDB WRITE FLAG
          NJN    DLC8        IF WRITE TO OVERFLOW MDB
          RJM    RCH         FIND CPU MDB AND GET MAIN HEADER ADDRESS
          UJN    DLC9

 DLC8     RJM    ROH         FIND OVERFLOW MDB AND GET MAIN HEADER ADDRESS
 DLC9     UJP    DLCX        EXIT


          EJECT
**        FDB - FIND DEPENDENT BUFFER, READ HEADER WORD AND SAVE NEEDED
*               INFORMATION.
*
*         METHOD             READ THE ADDRESS OF THE MODEL DEPENDENT BUFFER
*                            FROM THE DFT POINTER BLOCK.  USING THIS ADDRESS
*                            AND THE OFFSET OF THE CPU OR OVERFLOW MDB, READ
*                            THE MAIN HEADER WORD AND SAVE NECESSARY
*                            INFORMATION.
*
*         ENTRY              CPUO = CPU ORDINAL.
*
*                            OFFO = OVERFLOW OFFSET. (2)
*
*                            OFFF = 0 READ CPU MDB HEADER.
*                                 = 1 READ OVERFLOW MDB HEADER.
*
*         USES               CM, CPUO, CWDC, CWDO, EPRO, MDLP, OFFF,
*                            RS - RS+2.
*
*
*         CALLS              IDA, RDH.
*
*         EXIT               CWDC = 0 IF CPU MDB NOT BEING LOGGED, AND
*                                   OFFF = 0.
*                                 = GREATER THEN 0 IF CPU MDB IS BEING LOGGED,
*                                   AND OFFF = 0.
*
*                            CWDO = 0 IF OVERFLOW MDB NOT BEING LOGGED, AND
*                                   OFFF = 1.
*                                 = GREATER THEN 0 IF OVERFLOW MDB IS BEING
*                                   LOGGED, AND OFFF = 1.
*
*
*                            MDB BASE ADDRESS IN RS - RS+2.
*
*                            CURRENT MDB MAIN HEADER IN CM - CM+3.
*
*                            EPRO = OVERFLOW ERROR PRIORITY.


 FDB      SUBR               ENTRY/EXIT

*         SET UP RS - RS+2 TO CONTAIN THE ADDRESS OF CPU0 MDB.

          LDN    MDLP        LOAD MODEL DEPENDENT BUFFER POINTER
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   RS          READ ADDRESS OF MODEL DEPENDENT BUFFER

          LRD    RS+1        UPPER MDB ADDRESS FROM LAST READ
          LDML   OFFF        LOAD OFFSET USE FLAG
          NJP    FDB0        READ OVERFLOW MDB HEADER

*         READ CPU MDB HEADER.

          LDML   CPUO        LOAD CPU ORDINAL
          RJM    RDH         READ CPU HEADER WORD
          STML   CWDC        SAVE CPU MDB CW WORD
          UJP    FDBX        EXIT

 FDB0     LDN    OFFO        LOAD OVERFLOW MDB OFFSET
          RJM    RDH         READ OVERFLOW HEADER WORD
          STML   CWDO        SAVE OVERFLOW MDB CW WORD
          LDDL   CM+V4DHPRI  ERROR PRIORITY
          SHN    -12D
          STML   EPRO        SAVE FOR OVERWRITE CONDITION
          UJP    FDBX        EXIT
          EJECT
**        RBC - READ MAINTENANCE BUFFER CONTROL WORD.
*
*         METHOD             GET THE MAINTENANCE BUFFER CONTROL WORD ADDRESS,
*                            READ THE BUFFER CONTROL WORD AND GET THE
*                            INTERLOCK STATUS.
*
*         ENTRY              BCWF = 0 USE PHANTOM SCRATCH 0 LOCATION.
*                                   (LOGGABLE CONDITION)
*
*                                 = 1 USE SCRATCH 0 ADDRESS PLUS OFFSET.
*                                   (OVERWRITE CONDITION)
*
*                            CWDO = BUFFER CONTROL WORD OFFSET.
*
*         USES               BC, BCWF, CM, CWDO, RS - RS+2.
*
*         CALLS              IDA.
*
*         EXIT               INTERLOCK STATUS IN A REGISTER.
*
*                            MAINTENANCE BUFFER CONTROL WORD IN CM - CM+3.
*                            SCRATCH 0 ADDRESS IN RS+1.


 RBC      SUBR               ENTRY/EXIT

          LDN    BCWP        LOAD MAINTENANCE BUFFER CONTROL WORD POINTER
          RJM    IDA         INCREMENT THE DFT ADDRESS
          CRDL   RS          READ ADDRESS

          LRD    RS+1        UPPER MAINTENANCE BUFFER CONTROL WORD ADDRESS
          LDML   BCWF        BUFFER CONTROL WORD WRITE FLAG
          SBN    1
          ZJN    RBC0        IF OVERWRITE CONDITION

*         LOGGABLE CONDITION.

          LDDL   BC+BCFLG    PHANTOM SCRATCH 0 FLAG WORD
          UJN    RBC1        MASK INTERLOCK BIT

 RBC0     LDML   CWDO        LOAD MAINTENANCE BUFFER CONTROL WORD OFFSET
          ADD    RS
          ADC    RR          SET BIT 18
          CRDL   CM          READ MAINTENANCE BUFFER CONTROL WORD

          LDDL   CM+BCFLG    LOAD FLAG WORD
 RBC1     LPN    BCW.IT      JUST INTERLOCK BIT
          UJP    RBCX        EXIT
          EJECT
**        RCH - READ CPU MDB HEADER WORD.
*
*         METHOD             SET FLAG TO READ CPU MDB.
*
*         ENTRY              NA.
*
*         USES               OFFF.
*
*         CALLS              FDB.
*
*         EXIT               OFFF = 0.


 RCH      SUBR               ENTRY/EXIT

          LDN    0
          STML   OFFF        FLAG TO USE CPUO ORDINAL
          RJM    FDB         FIND MDB AND READ MAIN HEADER WORD
          UJP    RCHX        EXIT
          EJECT
**        RDH - READ MDB HEADER WORD.
*
*         METHOD             READ THE MDB HEADER WORD TO LOCATION CM AND
*                            EXTRACT THE CW WORD.
*
*         ENTRY              MDB OFFSET IN A.
*                            MDB BASE ADDRESS IN RS - RS+2.
*
*         USES               CM, HDAH - HDAH+2, RS - RS+2.
*
*         CALLS              NA.
*
*         EXIT               MDB CW WORD IN A.
*
*                            MDB ADDRESS SAVED IN HDAH - HDAD+2.

 RDH      SUBR               ENTRY/EXIT


          ADD    RS          ADD OTHER OFFSET
          ADC    RR          SET BIT 18
          CRDL   RS          READ MDB ADDRESS POINTER

          LRD    RS+1        UPPER MDB ADDRESS FROM LAST READ
          LDD    RS          LOWER MDB ADDRESS FROM LAST READ
          STM    HDAD        SAVE
          ADC    RR          SET BIT 18
          CRDL   CM          READ MDB PRIMARY HEADER WORD TO LOCATION CM
          LDD    RS+1        UPPER MDB ADDRESS
          STM    HDAD+1      SAVE
          LDD    RS+2        UPPER MDB ADDRESS
          STM    HDAD+2      SAVE
          LDDL   CM
          LPC    0#0F00
          STML   LTIF        SAVE LONGTERM INTERLOCK FLAG
          LDDL   CM+V4DHCWD  LOAD THE CW WORD
          LPC    0#FF        JUST CW WORD
          UJN    RDHX        EXIT

 LTIF     CON    0           LONG TERM INTERLOCK FLAG

          EJECT
**        ROH - READ OVERFLOW MDB HEADER WORD.
*
*         METHOD             SET FLAG TO READ OVERFLOW MDB.
*
*         ENTRY              NA.
*
*         USES               OFFF.
*
*         CALLS              FDB.
*
*         EXIT               OFFF = 1.

 ROH      SUBR               ENTRY/EXIT

          LDN    1
          STML   OFFF        FLAG TO USE OVERFLOW BUFFER OFFSET
          RJM    FDB         FIND MDB AND READ OVERFLOW HEADER WORD
          UJP    ROHX        EXIT
          EJECT
**        SCW - SET THE CONTROL WORD OFFSET AND SEQUENCE NUMBER IN THE
*               MDB MAIN HEADER WORD.
*
*         METHOD             READ THE MDB HEADER AND SET THE NECESSARY
*                            DATA.
*
*         ENTRY              LOCATIONS FREE AND BC+BCSEQ PRESET.
*
*         USES               BC, BCWF, CM, FREE.
*
*         CALLS              VCK.
*
*         EXIT               CWO AND SEQ SET IN MDB HEADER WORD.

          ROUTINE SCW        ENTRY/EXIT

          LDN    VER4        MINIMUM VERSION NUMBER THAT CAN BE USED
          RJM    VCK         CHECK VERSION
          MJP    SCWX        IF NOT AT LEAST VERSION 4

          LDML   BCWF        LOGGABLE DATA FLAG
          SBN    2           UNLOGGABLE DATA
          ZJP    SCWX        IF UNLOGGABLE

*         LOAD MAIN HEADER WORD FOR UPDATES.

          LDM    HDAD+1      SAVED UPPER MDB MAIN HEADER ADDRESS  (ROUTINE RDH)
          STD    RS+1
          LDM    HDAD+2      SAVED UPPER MDB MAIN HEADER ADDRESS  (ROUTINE RDH)
          STD    RS+2
          LDM    HDAD        SAVED LOWER MDB MAIN HEADER ADDRESS  (ROUTINE RDH)
          ADC    RR          ADD BIT 18
          LRD    RS+1
          CRDL   CM          READ MAIN HEADER WORD

*         INSERT CWO IN MAIN HEADER WORD.

          LDDL   CM+V4DHCWD  LOAD CWO WORD
          LPC    0#FF00      MASK OFF OLD CWO WORD
          ADM    FREE        ADD NEW CWO WORD
          STDL   CM+V4DHCWD  STORE TO WRITE BUFFER

*         INSERT SEQ IN MAIN HEADER WORD.


          LDDL   CM+V4DHPRI  LOAD PRI/SEQ WORD
          LPC    0#F00F      MASK OUT OLD SEQ
          STDL   CM+V4DHPRI  STORE WITHOUT SEQ NUMBER
          LDDL   BC+BCSEQ    CURRENT SEQ NUMBER FROM PHANTOM SCRATCH 0
          LPC    0#FF00      JUST SEQUENCE NUMBER
          SHN    -4          SHIFT OVER FOR USE
          LMDL   CM+V4DHPRI  SET OTHER BITS
          STDL   CM+V4DHPRI  STORE WITH SEQ NUMBER

          LDM    HDAD        SAVED LOWER MDB MAIN HEADER ADDRESS  (ROUTINE RDH)
          ADC    RR          ADD BIT 18
          CWDL   CM          WRITE MDB HEADER WORD
          UJP    SCWX        EXIT
          EJECT
**        WSH - WRITE THE MDB SUB HEADER WORD TO THE SELECTED MDB.
*             - RE-WRITE THE MAIN HEADER WORD WITH LENGTH OF DATA TO LOG.
*
*         METHOD             WRITE THE SUB HEADER WORD IF ERROR DATA OR
*                            RE-WRITE THE MAIN HEADER WORD WITH THE LENGTH
*                            OF DATA TO LOG LOGGED.
*
*         ENTRY              THE ADAJUSTED MAIN HEADER ADDRESS OF THE SELECTED
*                            MDB IS IN RS - RS+2 ON THE FIRST CALL TO THIS
*                            ROUTINE.  AFTER THAT, THE ADDRESS WILL POINT TO THE
*                            LAST LOCATION WRITTEN IN THE SELECTED MDB.
*
*                            SHWD = LENGTH OF DATA ASSOCIATED WITH THIS DATA
*                                   ERROR, OR ZERO IF INSERTING LENGTH OF DATA
*                                   TO LOG.
*
*                            SHWD+1 = ZERO.
*
*                            SHWD+2 = PFS ERROR ID IF APPLICABLE, OR ZERO IF
*                                     INSERTING LENGTH OF DATA TO LOG.
*
*                            SHWD+3 = ID OF NEXT REGION OF DATA, OR ZERO IF
*                                     INSERTING LENGTH OF DATA TO LOG.
*
*         USES               CM, HDAD - HDAD+2, LTOL, RS - RS+2, SHWD - SHWD+3.
*
*         CALLS              NA.
*
*         EXIT               IF ALL ERROR INFORMATION IS NOT LOGGED, THE
*                            SUB HEADER WORD, FOR THE INFORMATION TO BE
*                            WRITTEN, IS WRITTEN TO THE SELECTED MDB AND
*                            THE LAST SELECTED MDB ADDRESS WILL BE IN
*                            RS - RS+2.
*
*                            IF SHWD EQUALS ZERO, THE MAIN HEADER WORD WILL
*                            BE RE-WRITTEN WITH THE LENGTH OF DATA TO LOG
*                            AND THE ADDRESS OF THE SELECTED MDB MAIN
*                            HEADER WORD WILL BE IN RS - RS+2.
*

          ROUTINE WSH        ENTRY/EXIT

          LDM    SHWD
          ZJN    WSH1        IF WRITE MAIN HEADER WITH LTOL

*         WRITE THE SUB HEADER.

          LDN    1
          STDL   CM          WORD LENGTH FOR MEMORY WRITE
          AOML   LTOL        INCREMENT LENGTH TO LOG COUNTER
          AOD    RS          INCREMENT THE OFFSET BY 1
          LRD    RS+1        UPPER ADDRESS OF MDB MAIN HEADER WORD
          ADC    RR          SET BIT 18
          CWML   SHWD,CM     WRITE SUB HEADER WORD
 WSH0     UJP    WSHX        EXIT

*         LOAD MAIN HEADER WORD FOR LTOL UPDATE.

 WSH1     LDM    HDAD+1      SAVED UPPER MDB MAIN HEADER ADDRESS  (ROUTINE RDH)
          STD    RS+1
          LDM    HDAD+2      SAVED UPPER MDB MAIN HEADER ADDRESS  (ROUTINE RDH)
          STD    RS+2
          LDM    HDAD        SAVED LOWER MDB MAIN HEADER ADDRESS  (ROUTINE RDH)
          ADC    RR          ADD BIT 18
          LRD    RS+1
          CRDL   CM          READ MAIN HEADER WORD

*         INSERT LENGTH TO LOG IN MAIN HEADER WORD AND WRITE TO MDB.

          LDML   LTOL        LENGTH TO LOG COUNTER
          STDL   CM+V4DHLTL  STORE TO WRITE BUFFER
          LDM    HDAD        SAVED LOWER MDB MAIN HEADER ADDRESS  (ROUTINE RDH)
          ADC    RR          ADD BIT 18
          CWDL   CM          WRITE MDB HEADER WORD
          UJN    WSH0        EXIT

*         END    CTP$DFT_MDB_LOGGING_ROUTINES




*DECK DECK=CTP$DFT_MODEL_40_IOU_FSC EXPAND=FALSE
*         CTEXT  CTP$DFT I4C FAULT SYMPTOM CODES.
          QUAL   IOUFLT0
          COMMENT IOUFLT0 - IOU FAULT SYMPTOM CODE DECK *REL. LEVEL 780*
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
BITS      TITLE  IOU FAULT SYMPTOM CODE COMMON DECK
**        BITS - FAULT STATUS 1 TABLE MACRO
*
          PURGMAC  BITS
BITS      MACRO  BIT1,BIT2
+         VFD    16/BIT1,16/BIT2
BITS      ENDM
EQUATES   TITLE  IOUFLT0 COMMON DECK EQUATES
*         EQUATES FOR FAULT SYMPTOM CODES THAT DO NOT REQUIRE THE USE
*         OF THE BARREL CODE (A, B, C, D, E, OR F).

CODE05    EQU    2R05        EQUATE FOR FAULT SYMPTOM CODE 05
CODE10    EQU    2R10        EQUATE FOR FAULT SYMPTOM CODE 10
CODE11    EQU    2R11        EQUATE FOR FAULT SYMPTOM CODE 11
CODE12    EQU    2R12        EQUATE FOR FAULT SYMPTOM CODE 12
CODE17    EQU    2R17        EQUATE FOR FAULT SYMPTOM CODE 17
CODE18    EQU    2R18        EQUATE FOR FAULT SYMPTOM CODE 18
CODE19    EQU    2R19        EQUATE FOR FAULT SYMPTOM CODE 19
CODE20    EQU    2R20        EQUATE FOR FAULT SYMPTOM CODE 20
CODE21    EQU    2R21        EQUATE FOR FAULT SYMPTOM CODE 21
CODE24    EQU    2R24        EQUATE FOR FAULT SYMPTOM CODE 24
CODE26    EQU    2R26        EQUATE FOR FAULT SYMPTOM CODE 26
CODE27    EQU    2R27        EQUATE FOR FAULT SYMPTOM CODE 27
CODE29    EQU    2R29        EQUATE FOR FAULT SYMPTOM CODE 29
CODE31    EQU    2R31        EQUATE FOR FAULT SYMPTOM CODE 31
CODE33    EQU    2R33        EQUATE FOR FAULT SYMPTOM CODE 33
CODE37    EQU    2R37        EQUATE FOR FAULT SYMPTOM CODE 37
CODE38    EQU    2R38        EQUATE FOR FAULT SYMPTOM CODE 38
CODE39    EQU    2R39        EQUATE FOR FAULT SYMPTOM CODE 39
CODE40    EQU    2R40        EQUATE FOR FAULT SYMPTOM CODE 40
CODE41    EQU    2R41        EQUATE FOR FAULT SYMPTOM CODE 41
CODE42    EQU    2R42        EQUATE FOR FAULT SYMPTOM CODE 42
CODE43    EQU    2R43        EQUATE FOR FAULT SYMPTOM CODE 43
CODE47    EQU    2R47        EQUATE FOR FAULT SYMPTOM CODE 47
CODE49    EQU    2R49        EQUATE FOR FAULT SYMPTOM CODE 49


*         EQUATES FOR FAULT SYMPTOM CODES THAT END WITH A 0 OR 1
*         FOLLOWING THE BARREL CODE (A,B,C,D,E, OR F) INDICATING THAT
*         BITS 49, AND/OR 50, AND/OR 51 WERE SET OR CLEAR.

CODE22    EQU    2R22        EQUATE FOR FAULT SYMPTOM CODE 22
CODE23    EQU    2R23        EQUATE FOR FAULT SYMPTOM CODE 23
CODE28    EQU    2R28        EQUATE FOR FAULT SYMPTOM CODE 28
CODE30    EQU    2R30        EQUATE FOR FAULT SYMPTOM CODE 30
CODE32    EQU    2R32        EQUATE FOR FAULT SYMPTOM CODE 32
CODE34    EQU    2R34        EQUATE FOR FAULT SYMPTOM CODE 34


*         EQUATES FOR FAULT STATUS BYTE 4 (BITS 32-39).

BT32      EQU    0#8000      FAULT STATUS BIT 32 EQUATE
BT33      EQU    0#4000      FAULT STATUS BIT 33 EQUATE
BT34      EQU    0#2000      FAULT STATUS BIT 34 EQUATE
BT35      EQU    0#1000      FAULT STATUS BIT 35 EQUATE
BT36      EQU    0#0800      FAULT STATUS BIT 36 EQUATE
BT37      EQU    0#0400      FAULT STATUS BIT 37 EQUATE
BT38      EQU    0#0200      FAULT STATUS BIT 38 EQUATE
BT39      EQU    0#0100      FAULT STATUS BIT 39 EQUATE
          EJECT
*         EQUATES FOR FAULT STATUS BYTE 5 (BITS 40-47).

BT40      EQU    0#0080      FAULT STATUS BIT 40 EQUATE
BT41      EQU    0#0040      FAULT STATUS BIT 41 EQUATE
BT42      EQU    0#0020      FAULT STATUS BIT 42 EQUATE
BT43      EQU    0#0010      FAULT STATUS BIT 43 EQUATE
BT44      EQU    0#0008      FAULT STATUS BIT 44 EQUATE
BT45      EQU    0#0004      FAULT STATUS BIT 45 EQUATE
BT46      EQU    0#0002      FAULT STATUS BIT 46 EQUATE
BT47      EQU    0#0001      FAULT STATUS BIT 47 EQUATE


*         EQUATES FOR FAULT STATUS BYTE 6 (BITS 48-55).

BT48      EQU    0#8000      FAULT STATUS BIT 48 EQUATE
BT49      EQU    0#4000      FAULT STATUS BIT 49 EQUATE
BT50      EQU    0#2000      FAULT STATUS BIT 50 EQUATE
BT51      EQU    0#1000      FAULT STATUS BIT 51 EQUATE
BT52      EQU    0#0800      FAULT STATUS BIT 52 EQUATE
BT53      EQU    0#0400      FAULT STATUS BIT 53 EQUATE
BT54      EQU    0#0200      FAULT STATUS BIT 54 EQUATE
BT55      EQU    0#0100      FAULT STATUS BIT 55 EQUATE


*         EQUATES FOR FAULT STATUS BYTE 7 (BITS 56-63).

BT56      EQU    0#0080      FAULT STATUS BIT 56 EQUATE
BT57      EQU    0#0040      FAULT STATUS BIT 57 EQUATE
BT58      EQU    0#0020      FAULT STATUS BIT 58 EQUATE
BT59      EQU    0#0010      FAULT STATUS BIT 59 EQUATE
BT60      EQU    0#0008      FAULT STATUS BIT 60 EQUATE
BT61      EQU    0#0004      FAULT STATUS BIT 61 EQUATE
BT62      EQU    0#0002      FAULT STATUS BIT 62 EQUATE
BT63      EQU    0#0001      FAULT STATUS BIT 63 EQUATE


*         MISCELLANEOUS EQUATES FOR FAULT STATUS 1 AND FAULT STATUS 2.

FS1MSK2   EQU    0#6000      FS1 MASK FOR BITS 49 AND 50
FS1MSK3   EQU    0#7000      FS1 MASK FOR BITS 49, 50 AND 51
FS1MSK4   EQU    0#080F      FS1 MASK FOR BITS 52, 60, 61, 62, AND 63
FS1MSK5   EQU    0#F7F0      FS1 MASK FOR BITS 48-51, 53-59
FS1MSK6   EQU    0#020F      FS1 MASK FOR BITS 54 AND 60-63
FS1MSK7   EQU    0#87FF      FS1 MASK TO CLEAR BITS 49-52
FS1MSK8   EQU    0#0300      FS1 MASK TO CLEAR BITS 54 AND 55
F1CMSK0   EQU    0#DFCF      CIO FS1 MASK FOR BITS 32-47
F1CMSK1   EQU    0#FBFF      CIO FS1 MASK FOR BITS 48-63
F2NMSK0   EQU    0#FFAF      FS2 NIO MASK FOR BITS 32-47
F2NMSK1   EQU    0#FFBF      FS2 NIO MASK FOR BITS 48-63
F2CMSK0   EQU    0#FF03      FS2 CIO MASK FOR BITS 32-47
F2CMSK1   EQU    0           FS2 CIO MASK FOR BITS 48-63

IOUFLT0   TITLE  GENERATE IOU FAULT SYMPTOM CODE
IOUFLT0X  LJM    0           IOU FAULT SYMPTOM CODE GENERATION
IOUFLT0   EQU    *-1         ENTRY POINT

*         SAVE FAULT STATUS BUFFER ADDRESS IN -A- ON ENTRY.

          STDL   T1          SAVE FAULT STATUS BUFFER ADDRESS
          ADN    1D
          STDL   T3

*         INITIALIZE TEMPORARY LOCATIONS.

          LDN    0
          STDL   T2          INITIALIZE TABLE INDEX
          STDL   T4
          STDL   T5
          STDL   T6          INITIALIZE FAULT SYMPTOM CODE LOCATIONS
          STDL   T7

*         MOVE FAULT STATUS 1 AND 2 TO THE TEMPORARY STATUS BUFFER
*         (BOTH NIO AND CIO OF FS1 AND FS2 REGISTERS)

IFC00     LDIL   T3          MOVE FS1N, FS1C, FS2N, FS2C TO BUFFER
          STML   FSBUFR,T4
          AODL   T3          UPDATE SOURCE ADDRESS
          AODL   T4          UPDATE BUFFER INDEX
          SBN    16D         CHECK FOR MOVE COMPLETE
          MJN    IFC00       IF MOVE NOT COMPLETE

*         DETERMINE IF ERROR DATA IS IN THE NIO OR CIO FAULT STATUS 1
*         REGISTER.  IF THE ERROR DATE IS IN THE CIO FAULT STATUS 1
*         REGISTER, MOVE BYTE 7 OF THE NIO FAULT STATUS 1 REGISTER TO
*         BYTE 7 OF THE CIO FAULT STATUS 1 REGISTER AND CLEAR BYTE 7 OF
*         OF THE NIO FAULT STATUS 1 REGISTER.

          LDML   F1NBY6      GET NIO FS1 BYTES 6 AND 7
          LPC    0#FF00      MASK NIO FS1 FOR BITS 48-55
          ADML   F1NBY0      ADD NIO FS1 BYTES 0 AND 1
          ADML   F1NBY2      ADD NIO FS1 BYTES 2 AND 3
          ADML   F1NBY4      ADD NIO FS1 BYTES 4 AND 5
          NJN    IFC01       IF ERROR DATA IS IN THE NIO FS1 REGISTER
          LDML   F1CBY6      GET CIO FS1 BYTES 6 AND 7
          LPC    0#FF00      MASK CIO FS1 FOR BITS 48-55
          STML   F1CBY6      SAVE CIO FS1 BYTES 6 AND 7
          LDML   F1NBY6      GET NIO FS1 BYTES 6 AND 7
          LPC    0#00FF      MASK NIO FS1 FOR BITS 56-63
          RAML   F1CBY6      MOVE NIO BYTE 7 TO CIO BYTE 7
          LDML   F1NBY6      GET NIO FS1 BYTES 6 AND 7
          LPC    0#FF00      MASK NIO FS1 FOR BITS 48-55
          STML   F1NBY6      SAVE NIO FS1 BYTES 6 AND 7

*         CHECK FOR PIP3 TYPE OF CPU.

IFC01     LDIL   T1          GET CPU IDENTIFIER
          LMC    2R3A        CHECK FOR PIP3 CPU
          ZJN    IFC02       IF PIP3 CPU
          LJM    IFC10       GO TO PROCESS FAULT STATUS 2

*         IF PIP3 TYPE OF CPU, CHECK FOR BITS 52, 60, 61, 62 AND 63 SET
*         IN FAULT STATUS 1.  IF BITS 52, 60, 61, 62 AND 63 ARE ALL SET
*         IN FAULT STATUS 1, CLEAR BITS 52, 60, 61, 62 AND 63 IN FAULT
*         STATUS 1.  IF BITS 52, 60, 61, 62 AND 63 NOT SET SET IN FAULT
*         STATUS 1, CHECK FOR BITS 54, 60, 61, 62 AND 63 SET IN FAULT
*         STATUS 1.  IF BITS 54, 60, 61, 62 AND 63 SET IN FAULT STATUS
*         1, FORCE THE FAULT SYMPTOM CODE TO DX4077E.

IFC02     LDML   F1NBY6      GET NIO FS1 BYTES 6 AND 7
          LPC    FS1MSK4     MASK NIO FS1 FOR BITS 52 AND 60-63
          LMC    FS1MSK4     COMPARE FOR BITS 52 AND 60-63 ALL SET
          ZJN    IFC06       IF BITS 52 AND 60-63 ALL SET IN NIO FS1
          LDML   F1NBY6
          LPC    FS1MSK6     MASK FS1 BITS FOR BITS 54 AND 60-63
          LMC    FS1MSK6     COMPARE W/SET BITS 54 AND 60-63
          ZJN    IFC04       IF BITS 54 AND 60-63 NOT ALL SET

          LDML   F1CBY6      GET CIO FS1 BYTES 6 AND 7
          LPC    FS1MSK4     MASK CIO FS1 FOR BITS 52 AND 60-63
          LMC    FS1MSK4     COMPARE FOR BITS 52 AND 60-63 ALL SET
          ZJN    IFC08       IF BITS 52 AND 60-63 ALL SET IN CIO FS1
          LDML   F1CBY6
          LPC    FS1MSK6     MASK FS1 BITS FOR BITS 54 AND 60-63
          LMC    FS1MSK6     COMPARE W/SET BITS 54 AND 60-63
          NJN    IFC07       IF BITS 54 AND 60-63 NOT ALL SET
IFC04     LDC    2RE         GET 2ND PART OF 77E FSC
          LJM    IFC70       GO FORM 77E FSC AND EXIT TO CALLING PROGRAM
          EJECT
*         CLEAR BITS 52, 60, 61, 62 AND 63 IN NIO FAULT STATUS 1.
*         POSSIBLY CLEAR BITS 49-52 IN NIO FAULT STATUS 1.

IFC06     LDML   F1NBY6      GET FS1 BYTES 6 AND 7
          LPC    FS1MSK5     CLEAR BITS 52, 60, 61, 62, AND 63
          STML   F1NBY6      REPLACE FS1 BYTES 6 AND 7
          LPC    FS1MSK8     COMPARE W/BITS 54 AND 55
          ZJN    IFC10       IF NEITHER BIT 54 OR 55 SET
          LDML   F1NBY6
          LPC    FS1MSK7     CLEAR FS1 BITS 49-52
          STML   F1NBY6      REPLACE FS1 BYTES 6 AND 7
IFC07     UJN    IFC10       GO TO PROCESS NIO FAULT STATUS 2

*         CLEAR BITS 52, 60, 61, 62 AND 63 IN CIO FAULT STATUS 1.
*         POSSIBLY CLEAR BITS 49-52 IN CIO FAULT STATUS 1.

IFC08     LDML   F1CBY6      GET FS1 BYTES 6 AND 7
          LPC    FS1MSK5     CLEAR BITS 52, 60, 61, 62, AND 63
          STML   F1CBY6      REPLACE FS1 BYTES 6 AND 7
          LPC    FS1MSK8     COMPARE W/BITS 54 AND 55
          ZJN    IFC10       IF NEITHER BIT 54 OR 55 SET
          LDML   F1CBY6
          LPC    FS1MSK7     CLEAR FS1 BITS 49-52
          STML   F1CBY6      REPLACE FS1 BYTES 6 AND 7
          EJECT
**********************************************************************
*         BEGIN ANALYSIS ON NIO FS2 REGISTER...
*         CLEAR ALL UNUSED BITS IN THE FS2 NIO REGISTER

IFC10     LDML   F2NBY4      GET FS2 NIO BYTES 4 AND 5
          LPC    F2NMSK0     MASK OFF NOT USED AND NOT AVAILABLE BITS
          STML   F2NBY4      SAVE FAULT STATUS WORD
          LDML   F2NBY6      GET FS2 NIO BYTES 6 AND 7
          LPC    F2NMSK1     MASK OFF NOT USED AND NOT AVAILABLE BITS
          STML   F2NBY6      SAVE FAULT STATUS WORD

*         CHECK FS2 NIO BYTES 4 AND 5 FOR CHANNEL FAULT BITS SET

          ADML   F2NBY4      INCLUDE FAULT STATUS BYTES 4 AND 5
          NJN    IFC20       IF FAULT STATUS 2 -NIO- ERROR
          LJM    IFC110      GO CHECK FOR FAULT STATUS 2 -CIO- ERROR

*         DETERMINE THE BIT(S) WHICH ARE SET IN THE FAULT STATUS 2
*         NIO WORD AND GENERATE THE FAULT SYMPTOM CODE.

IFC20     LDC    F2NBY4      INITIALIZE FAULT STATUS BUFFER INDEX
          STDL   T3
IFC30     LDC    0#8000      INITIALIZE FAULT STATUS BIT MASK
IFC40     STDL   T4
          LPIL   T3          CHECK FOR CHANNEL BIT SET IN FS2 -NIO-
          ZJN    IFC50       IF CHANNEL BIT IS NOT SET IN FS2 -NIO-

*         POSSIBLE CHANNEL FAULT BIT HAS BEEN FOUND, CHECK FOR PREVIOUS
*         CHANNEL FAULT BIT DETECTED.

          LDDL   T6          CHECK FOR PREVIOUS CHANNEL FAULT BIT FOUND
          ADDL   T7
          ZJN    IFC46       IF NO PREVIOUS FSC ASSIGNED
          LDDL   T7          GET LAST PAIR OF FSC CHARS
          LMC    2R70
          NJN    IFC44       ERROR EXIT IF NOT 70
          LDC    F2NBY6-1    GET INTERNAL FS2 BYTE 6,7 ADDRESS
          SBDL   T3          COMPARE W/CURRENT FS2 WORD ADDRESS
          PJN    IFC44       ERROR EXIT IF LESS THAN FS2 BYTE 6 ADDRESS
          AODL   T7          ADJUST FSC CODE TO 71
          LDIL   T3          GET BYTES 6 AND 7 OF FS2 - NIO
          LMN    40B         CHECK FOR BIT 58 SET
          ZJN    IFC50       IF BIT 58 IS ONLY BIT SET
          AODL   T7          ADJUST FSC CODE TO 72
          LDIL   T3          GET BYTES 6 AND 7 OF FS2 - NIO
          LMN    20B         CHECK FOR JUST BIT 59 SET
          ZJN    IFC50       BIT 59 IS ONLY SET -- CONTINUE PROCESSING

IFC44     UJN    IFC60       ERROR EXIT -- CANNOT CALC FSC

*         THE POSSIBLE CHANNEL FAULT BIT HAS BEEN FOUND, SAVE THE FAULT
*         SYMPTOM CODE FOR THE CHANNEL FAULT BIT.

IFC46     LDDL   T2          BUILD F2NFSCT TABLE INDEX
          SHN    1D
          STDL   T5
          LDML   F2NFSCT,T5  SET FS2 -NIO- FAULT SYMPTOM CODE
          STDL   T6
          LDML   F2NFSCT+1,T5  SET FS2 -NIO- FAULT SYMPTOM CODE
          STDL   T7
IFC50     AODL   T2          UPDATE FAULT STATUS 2 TABLE INDEX
          SBN    32D         CHECK FOR ALL CHANNEL BITS CHECKED
          PJN    IFC56       IF ALL CHANNEL BITS CHECKED
          LDDL   T4          UPDATE FAULT STATUS BIT MASK
          SHN    -1D
          NJN    IFC54       IF FS2 BYTES 4 AND 5 NOT CHECKED
          AODL   T3          UPDATE FAULT STATUS BUFFER INDEX
          LJM    IFC30       GO TO CHECK NEXT FAULT STATUS WORD

IFC54     LJM    IFC40       GO CONTINUE CHECKING 16-BIT WORD
IFC56     LJM    IFC110      GO CHECK FOR FAULT STATUS 2 -CIO- ERROR

*         MORE THAN ONE ONE BIT HAS BEEN FOUND SET IN FAULT STATUS 2,
*         FORCE THE FAULT SYMPTOM CODE TO DX4077A.

IFC60     LDC    2RA         GENERATE THE FAULT SYMPTOM CODE DX4077A
IFC70     STDL   T7
          LDC    2R77        GENERATE THE CHARACTERS 77
          STDL   T6

*         MOVE THE FAULT SYMPTOM CODE TO THE BUFFER THAT CONTAINED THE
*         FAULT STATUS REGISTERS 1 AND 2 ON ENTRY AND EXIT.

IFC80     LDDL   T6          CHECK FOR NO FAULT SYMPTOM CODE
          ADDL   T7
          NJN    IFC90       IF FAULT SYMPTOM CODE
          LDC    2RD         SET THE FAULT SYMPTOM CODE 77D
          UJN    IFC70

IFC90     LDDL   T6          MOVE FIRST TWO FSC CHARACTERS TO BUFFER
          STIL   T1
          LDDL   T7          MOVE SECOND TWO FSC CHARACTERS TO BUFFER
          NJN    IFC94       IF LAST TWO FSC CHARACTERS ARE AVAILABLE
          LDC    2R          BLANK FILL LAST TWO FSC CHARACTERS
IFC94     STML   1,T1
          LDC    2R          BLANK FILL REMAINDER OF THE BUFFER
          STML   2,T1
          STML   3,T1
          STML   4,T1
          STML   5,T1
          STML   6,T1
          STML   7,T1
          LDDL   T1          SET (A) REGISTER FOR EXIT
          LJM    IOUFLT0X    EXIT

*         GENERATE THE FAULT SYMPTOM CODE DX4077B.

IFC100    LDC    2RB         GENERATE THE FAULT SYMPTOM CODE DX4077B
          LJM    IFC70       GO TO GENERATE THE CHARACTERS 77
          EJECT
*********************************************************************
*         BEGIN ANALYSIS ON CIO FS2 REGISTER...
*         CLEAR ALL UNUSED BITS IN THE FS2 CIO REGISTER

IFC110    LDN    0
          STDL   T2          RESET F2CFSCT TABLE INDEX
          LDML   F2CBY4      GET FS2 CIO BYTES 4 AND 5
          LPC    F2CMSK0     MASK OFF NOT USED AND NOT AVAILABLE BITS
          STML   F2CBY4      SAVE FAULT STATUS WORD
          LDML   F2CBY6      GET FS2 CIO BYTES 6 AND 7
          LPC    F2CMSK1     MASK OFF NOT USED AND NOT AVAILABLE BITS
          STML   F2CBY6      SAVE FAULT STATUS WORD

*         CHECK FS2 CIO BYTES 4 AND 5 FOR CHANNEL FAULT BITS SET

          ADML   F2CBY4      INCLUDE FAULT STATUS BYTES 4 AND 5
          NJN    IFC120      IF FAULT STATUS 2 -CIO- ERROR
          LJM    IFC200      GO CHECK FOR FAULT STATUS 1 -NIO- ERROR

*         DETERMINE THE BIT(S) WHICH ARE SET IN THE FAULT STATUS 2
*         CIO WORD AND GENERATE THE FAULT SYMPTOM CODE.

IFC120    LDC    F2CBY4      INITIALIZE FAULT STATUS BUFFER INDEX
          STDL   T3
IFC130    LDC    0#8000      INITIALIZE FAULT STATUS BIT MASK
IFC140    STDL   T4
          LPIL   T3          CHECK FOR CHANNEL BIT SET IN FS2 -CIO-
          ZJN    IFC150      IF CHANNEL BIT IS NOT SET IN FS2 -CIO-

*         POSSIBLE CHANNEL FAULT BIT HAS BEEN FOUND, CHECK FOR PREVIOUS
*         CHANNEL FAULT BIT DETECTED.

          LDDL   T6          CHECK FOR PREVIOUS CHANNEL FAULT BIT FOUND
          ADDL   T7
          NJN    IFC160      IF PREVIOUS CHANNEL FAULT BIT FOUND

*         THE POSSIBLE CHANNEL FAULT BIT HAS BEEN FOUND, SAVE THE FAULT
*         SYMPTOM CODE FOR THE CHANNEL FAULT BIT.

          LDDL   T2          BUILD F2CFSCT TABLE INDEX
          SHN    1D
          STDL   T5
          LDML   F2CFSCT,T5  SET FS2 -CIO- FAULT SYMPTOM CODE
          STDL   T6
          LDML   F2CFSCT+1,T5  SET FS2 -CIO- FAULT SYMPTOM CODE
          STDL   T7
IFC150    AODL   T2          UPDATE FAULT STATUS 2 TABLE INDEX
          SBN    16D         CHECK FOR ALL CHANNEL BITS CHECKED
          PJN    IFC200      IF ALL CHANNEL BITS CHECKED
          LDDL   T4          UPDATE FAULT STATUS BIT MASK
          SHN    -1D
          NJN    IFC140      IF FS2 BYTES 4 AND 5 NOT CHECKED
          AODL   T3          UPDATE FAULT STATUS BUFFER INDEX
          UJN    IFC130      GO TO CHECK NEXT FAULT STATUS WORD
IFC160    LJM    IFC60       MULTIPLE FS2 ERRORS DETECTED
IFC170    LJM    IFC100      MORE THAN ONE FAILING BARREL...
          EJECT
**************************************************************************
*         BEGIN ANALYSIS ON NIO FS1 REGISTER...
*         CHECK FAULT STATUS 1 FOR ANY BITS SET AND IF NONE ARE SET,
*         GO CHECK CIO FS1 REGISTER.

IFC200    LDML   F1NBY4      CHECK FOR FAULT STATUS 1 ERROR(S)
          ADML   F1NBY6
          NJN    IFC210      IF FAULT STATUS 1 ERROR
          LJM    IFC400      GO ANALYZE CIO FS1 REGISTER CONTENTS

*         DETERMINE THE BARREL IN WHICH THE FAILURE WAS DETECTED, IF
*         MORE THAN ONE BARREL FAILED, REPORT A FAULT SYMPTOM CODE OF
*         DX4077B.

IFC210    LDML   F1NBY0      CHECK FOR BARREL 0 FAILURE
          SHN    -8D
          ZJN    IFC220      IF NOT BARREL 0 FAILURE
          LDC    2RA         FORCE BARREL INDICATOR TO A
          STDL   T7
IFC220    LDML   F1NBY1      CHECK FOR BARREL 1 FAILURE
          LPC    0#1F
          ZJN    IFC240      IF NOT BARREL 1 FAILURE
          LDDL   T7          CHECK FOR MORE THAN ONE FAILING BARREL
IFC230    NJN    IFC170      IF MORE THAN ONE FAILING BARREL
          LDC    2RB         FORCE BARREL INDICATOR TO B
          STDL   T7
IFC240    LDML   F1NBY2      CHECK FOR BARREL 2 FAILURE
          SHN    -8D
          ZJN    IFC250      IF NOT BARREL 2 FAILURE
          LDDL   T7          CHECK FOR MORE THAN ONE FAILING BARREL
          NJN    IFC230      IF MORE THAN ONE FAILING BARREL
          LDC    2RC         FORCE BARREL INDICATOR TO C
          STDL   T7
IFC250    LDML   F1NBY3      CHECK FOR BARREL 3 FAILURE
          LPC    0#1F
          ZJN    IFC260      IF NOT BARREL 3 FAILURE
          LDDL   T7          CHECK FOR MORE THAN ONE FAILING BARREL
          NJN    IFC230      IF MORE THAN ONE FAILING BARREL
          LDC    2RD         FORCE BARREL INDICATOR TO D
          STDL   T7

*         CHECK THE FAULT STATUS 1 REGISTER FOR ERRORS.  THE F1NBTB
*         TABLE CONTAINS THE FAULT STATUS 1 BITS 32-63 THAT ARE TO BE
*         CHECKED.

IFC260    BSS    0
          LDN    0           RESET THE F1NBTB TABLE INDEX (NIO FS1)
          STDL   T2
IFC270    LDML   F1NBY4      GET FAULT STATUS 1 BYTES 4 AND 5
          LPML   F1NBTB,T2
          LMML   F1NBTB,T2   COMPARE FOR ALL SELECTED BITS SET
          NJN    IFC280      IF ALL SELECTED BITS NOT SET IN FS1 -NIO-
          LDML   F1NBY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LPML   F1NBTB+1,T2  COMPARE FOR ALL SELECTED BITS SET
          LMML   F1NBTB+1,T2  COMPARE FOR ALL SELECTED BITS SET
          ZJN    IFC300      IF ALL SELECTED BITS SET IN FS1 -NIO-

IFC280    LDN    2D          UPDATE F1NBTB TABLE INDEX
          RADL   T2
          ADC    -F1NBTBL    CHECK OF END OF F1NBTB TABLE
          MJN    IFC270      IF NOT END OF F1NBTB TABLE

          LDML   F1NBY4      GET FAULT STATUS 1 BYTES 4 AND 5
          ADML   F1NBY6      ADD FAULT STATUS 1 BYTES 6 AND 7
          ZJN    IFC290      IF FAULT STATUS 1 COMPLETELY PROCESSED
          LDC    2RD         SET FAULT SYMPTOM CODE TO DX4077D
          LJM    IFC70       GO TO GENERATE THE CHARACTERS 77

IFC290    LJM    IFC400      GO CHECK CIO FS1 REGISTER CONTENTS

*         CLEAR THE FAILING BIT INDICATORS IN FAULT STATUS 1 -NIO-.

IFC300    LDML   F1NBY4      GET FAULT STATUS 1 BYTES 4 AND 5
          LMML   F1NBTB,T2   CLEAR FAILING BIT INDICATORS
          STML   F1NBY4      RESET FAULT STATUS 1 BYTES 4 AND 5
          LDML   F1NBY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LMML   F1NBTB+1,T2  CLEAR FAILING BIT INDICATORS
          STML   F1NBY6      RESET FAULT STATUS 1 BYTES 6 AND 7

*         POSSIBLE FAULT STATUS 1 FAILURE HAS BEEN FOUND, CHECK FOR
*         PREVIOUS FAULT STATUS 1 DETECTED. IF A PREVIOUS FAULT WAS
*         ISOLATED, FORCE THE FAULT SYMPTOM CODE TO DX4077C.

          LDDL   T6          CHECK FOR PREVIOUS FAULT STATUS ERROR
          ZJN    IFC310      IF NO PREVIOUS FAULT STATUS ERROR
          LDC    2RC         SET FAULT SYMPTOM CODE TO DX4077C
          LJM    IFC70       GO TO GENERATE THE CHARACTERS 77

*         THE POSSIBLE FAULT STATUS 1 NIO ERROR HAS BEEN FOUND, SAVE THE
*         FAULT SYMPTOM CODE FOR THE FAULT STATUS 1 REGISTER.

IFC310    LDDL   T2          BUILD F1NFSCT TABLE INDEX
          SHN    -1D
          STDL   T4          STORE FSC ASSIGNMENT INDEX
          LDML   F1NFSCT,T4  SET FS1 FAULT SYMPTOM CODE
          STDL   T6

*         CHECK FOR FAULT SYMPTOM CODES DX4005, 10-12, 19-21,
*         24, 26, 27, 29, 31, 33, 37-43, 47, AND 49. IF THE FAULT
*         SYMPTOM CODE IS ONE OF THESE CODES, RESET THE CLUSTER
*         INDICATOR TO BLANK DISPLAY CODES.

          ADC    -CODE05     CHECK FOR FAULT SYMPTOM CODE DX4005
          ZJN    IFCA1       IF FAULT SYMPTOM CODE DX4005
          ADC    -CODE10+CODE05  CHECK FOR FAULT SYMPTOM CODE DX4010
          ZJN    IFCA1       IF FAULT SYMPTOM CODE DX4010
          SBN    CODE11-CODE10  CHECK FOR FAULT SYMPTOM CODE DX4011
          ZJN    IFCA1       IF FAULT SYMPTOM CODE DX4011
          SBN    CODE12-CODE11  CHECK FOR FAULT SYMPTOM CODE DX4012
          ZJN    IFCA1       IF FAULT SYMPTOM CODE DX4012
          SBN    CODE19-CODE12  CHECK FOR FAULT SYMPTOM CODE DX4019
          ZJN    IFCA1       IF FAULT SYMPTOM CODE DX4019
          ADC    -CODE20+CODE19  CHECK FOR FAULT SYMPTOM CODE DX4020
          NJN    IFCA2       IF FAULT SYMPTOM CODE IS NOT DX4020
 IFCA1    LJM    IFC320      FAULT SYMPTOM CODE IS DX4020
 IFCA2    SBN    CODE21-CODE20  CHECK FOR FAULT SYMPTOM CODE DX4021
          ZJN    IFCA1       IF FAULT SYMPTOM CODE DX4021
          SBN    CODE24-CODE21  CHECK FOR FAULT SYMPTOM CODE DX4024
          ZJN    IFCA1       IF FAULT SYMPTOM CODE DX4024
          SBN    CODE26-CODE24  CHECK FOR FAULT SYMPTOM CODE DX4026
          ZJN    IFCA1       IF FAULT SYMPTOM CODE DX4026
          SBN    CODE27-CODE26  CHECK FOR FAULT SYMPTOM CODE DX4027
          ZJN    IFCA1       IF FAULT SYMPTOM CODE DX4027
          SBN    CODE29-CODE27  CHECK FOR FAULT SYMPTOM CODE DX4029
          ZJN    IFCA1       IF FAULT SYMPTOM CODE DX4029
          ADC    -CODE31+CODE29  CHECK FOR FAULT SYMPTOM CODE DX4031
          ZJN    IFC320      IF FAULT SYMPTOM CODE DX4031
          SBN    CODE33-CODE31  CHECK FOR FAULT SYMPTOM CODE DX4033
          ZJN    IFC320      IF FAULT SYMPTOM CODE DX4033
          SBN    CODE37-CODE33  CHECK FOR FAULT SYMPTOM CODE DX4037
          ZJN    IFC320      IF FAULT SYMPTOM CODE DI4037
          SBN    CODE38-CODE37  CHECK FOR FAULT SYMPTOM CODE DI4038
          ZJN    IFC320      IF FAULT SYMPTOM CODE DI4038
          SBN    CODE39-CODE38  CHECK FOR FAULT SYMPTOM CODE DI4039
          ZJN    IFC320      IF FAULT SYMPTOM CODE DI4039
          ADC    -CODE40+CODE39  CHECK FOR FAULT SYMPTOM CODE DI4040
          ZJN    IFC320      IF FAULT SYMPTOM CODE DI4040
          SBN    CODE41-CODE40  CHECK FOR FAULT SYMPTOM CODE DI4041
          ZJN    IFC320      IF FAULT SYMPTOM CODE DI4041
          SBN    CODE42-CODE41  CHECK FOR FAULT SYMPTOM CODE DI4042
          ZJN    IFC320      IF FAULT SYMPTOM CODE DI4042
          SBN    CODE43-CODE42  CHECK FOR FAULT SYMPTOM CODE DI4043
          ZJN    IFC320      IF FAULT SYMPTOM CODE DI4043
          SBN    CODE47-CODE43  CHECK FOR FAULT SYMPTOM CODE DI4047
          ZJN    IFC320      IF FAULT SYMPTOM CODE DI4047
          SBN    CODE49-CODE47  CHECK FOR FAULT SYMPTOM CODE DI4049
          ZJN    IFC320      IF FAULT SYMPTOM CODE DX4049

*         CHECK FOR FAULT SYMPTOM CODES DX4017 AND DX4018.  IF THE
*         FAULT SYMPTOM CODE IS ONE OF THESE CODES, APPEND THE LETTER G
*         TO THE FAULT SYMPTOM CODE.

          LDDL   T6          GET FAULT SYMPTOM CODE
          ADC    -CODE17     CHECK FOR FAULT SYMPTOM CODE DX4017
          ZJN    IFCA5       IF FAULT SYMPTOM CODE DX4017
          SBN    CODE18-CODE17  CHECK FOR FAULT SYMPTOM CODE DX4018
          NJN    IFC330      IF NOT FAULT SYMPTOM CODE DX4018
IFCA5     LDC    2RG -2R     RESET BARREL INDICATION TO G
IFC320    ADC    2R          RESET BARREL INDICATOR TO BLANKS
          STDL   T7
          UJN    IFC360      GO TO CONTINUE NIO FS1 PROCESSING

*         CHECK THAT LOCATION T7 DOES NOT CONTAIN ZERO.  THIS ENSURES
*         THAT THE FAULT CAN BE ISOLATED TO A FAILING CLUSTER.  IF THE
*         FAULT CANNOT BE ISOLATED TO A FAILING CLUSTER, (I.E.  T7
*         CONTAINS ZERO), FORCE THE FAULT SYMPTOM CODE TO DX4077D.

IFC330    LDDL   T7          GET FAILING CLUSTER INDICATOR
          NJN    IFC335      IF FAILING CLUSTER ISOLATED
          LDC    2RD         SET FAULT SYMPTOM CODE TO DX4077D
          LJM    IFC70       GO TO GENERATE THE CHARACTERS 77

*         CHECK FOR FAULT SYMPTOM CODES DX4022. IF THE FAULT SYMPTOM
*         CODE IS A DX4022, RESET THE BARREL INDICATOR X (A - F) TO
*         A X2 IF BITS 49, 50 AND 51 ARE CLEAR, TO A X0 IF EITHER
*         BIT 49 OR 50 IS SET, OR TO A X1 IF BIT 51 IS SET.

IFC335    LDDL   T6          GET FAULT SYMPTOM CODE
          ADC    -CODE22     CHECK FOR FAULT SYMPTOM CODE DX4022
          NJN    IFC370      IF NOT FAULT SYMPTOM CODE DX4022
          LDML   F1NBY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LPC    FS1MSK3     CHECK IF BITS 49, OR 50, OR 51 SET
          ZJN    IFC350      IF BITS 49, 50 AND 51 CLEAR
          LPC    BT51        CHECK FOR BIT 51 SET
          ZJN    IFC340      IF BIT 51 IS NOT SET
          LDN    1R1-1R0     SET BARREL INDICATOR TO X0
IFC340    SBN    1R2-1R0     SET BARREL INDICATOR TO X1
IFC350    ADN    1R2-1R      SET BARREL INDICATOR TO X2
          RADL   T7
          LDML   F1NBY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LPC    -FS1MSK3    CLEAR BITS 49, 50 AND 51
          STML   F1NBY6      SAVE UPDATED FS1, BYTES 6 AND 7
IFC360    LJM    IFC280      GO TO CONTINUE FAULT STATUS 1 PROCESSING

*         CHECK FOR FAULT SYMPTOM CODES DX4023, DX4028, DX4030, DX4032
*         AND DX4034. IF THE FAULT SYMPTOM CODE IS ONE OF THESE CODES,
*         RESET THE BARREL INDICATOR X (A - F) TO A X1 IF BITS 49
*         AND 50 ARE CLEAR OR TO A X0 IF EITHER BIT 49 OR 50 IS SET.

IFC370    SBN    CODE23-CODE22  CHECK FOR FAULT SYMPTOM CODE DX4023
          ZJN    IFC380      IF FAULT SYMPTOM CODE DX4023
          SBN    CODE28-CODE23  CHECK FOR FAULT SYMPTOM CODE DX4028
          ZJN    IFC380      IF FAULT SYMPTOM CODE DX4028
          ADC    -CODE30+CODE28  CHECK FOR FAULT SYMPTOM CODE DX4030
          ZJN    IFC380      IF FAULT SYMPTOM CODE DX4030
          SBN    CODE32-CODE30  CHECK FOR FAULT SYMPTOM CODE DX4032
          ZJN    IFC380      IF FAULT SYMPTOM CODE DX4032
          SBN    CODE34-CODE32  CHECK FOR FAULT SYMPTOM CODE DX4034
          NJN    IFC360      IF NOT FAULT SYMPTOM CODE DX4034
IFC380    LDML   F1NBY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LPC    FS1MSK2     CHECK FOR BIT 49 OR 50 SET
          ZJN    IFC390      IF BIT 49 AND 50 IS NOT SET
          LCN    1R1-1R0     SET BARREL INDICATOR TO X1
IFC390    ADN    1R1-1R      SET BARREL INDICATOR TO X0
          RADL   T7
          LDML   F1NBY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LPC    -FS1MSK2    CLEAR BITS 49 AND 50
          STML   F1NBY6      SAVE UPDATED FS1, BYTES 6 AND 7
          UJN    IFC360      GO TO CONTINUE FAULT STATUS 1 PROCESSING
          EJECT
**************************************************************************
*         BEGIN ANALYSIS ON CIO FS1 REGISTER...
*         CHECK FAULT STATUS 1 FOR ANY BITS SET AND IF NONE ARE SET,
*         EXIT.

IFC400    LDML   F1CBY4      GET FS1 CIO BYTES 4 AND 5
          LPC    F1CMSK0     MASK OFF NOT USED AND NOT AVAILABLE BITS
          STML   F1CBY4      SAVE FAULT STATUS WORD
          LDML   F1CBY6      GET FS1 CIO BYTES 6 AND 7
          LPC    F1CMSK1     MASK OFF NOT USED AND NOT AVAILABLE BITS
          STML   F1CBY6      SAVE FAULT STATUS WORD
          ADML   F1CBY4      CHECK CIO FS1 FOR ERRORS
          NJN    IFC410      IF FAULT STATUS 1 -CIO- ERROR
          LJM    IFC80       GO ESTABLISH FSC AND EXIT

IFC405    LJM    IFC100      MORE THAN ONE BARREL ERROR

*         DETERMINE THE BARREL IN WHICH THE FAILURE WAS DETECTED, IF
*         MORE THAN ONE BARREL FAILED, REPORT A FAULT SYMPTOM CODE OF
*         DX4077B.

IFC410    LDML   F1CBY0      CHECK FOR BARREL 0 FAILURE
          SHN    -8D
          ZJN    IFC420      IF NOT BARREL 0 FAILURE
          LDC    2RE         FORCE BARREL INDICATOR TO E
          STDL   T7
IFC420    LDML   F1CBY1      CHECK FOR BARREL 1 FAILURE
          LPC    0#1F
          ZJN    IFC440      IF NOT BARREL 1 FAILURE
          LDDL   T7          CHECK FOR MORE THAN ONE FAILING BARREL
IFC430    NJN    IFC405      IF MORE THAN ONE FAILING BARREL
          LDC    2RF         FORCE BARREL INDICATOR TO F
          STDL   T7

*         CHECK THE FAULT STATUS 1 REGISTER FOR ERRORS.  THE F1CBTB
*         TABLE CONTAINS THE FAULT STATUS 1 BITS 32-63 THAT ARE TO BE
*         CHECKED.

IFC440    BSS    0
          LDN    0           RESET THE F1NBTB TABLE INDEX
          STDL   T2
IFC450    LDML   F1CBY4      GET FAULT STATUS 1 BYTES 4 AND 5
          LPML   F1NBTB,T2
          LMML   F1NBTB,T2   COMPARE FOR ALL SELECTED BITS SET
          NJN    IFC460      IF ALL SELECTED BITS NOT SET IN FS1 -CIO-
          LDML   F1CBY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LPML   F1NBTB+1,T2  COMPARE FOR ALL SELECTED BITS SET
          LMML   F1NBTB+1,T2  COMPARE FOR ALL SELECTED BITS SET
          ZJN    IFC480      IF ALL SELECTED BITS SET IN FS1 -CIO-

IFC460    LDN    2D          UPDATE F1NBTB TABLE INDEX
          RADL   T2
          ADC    -F1NBTBL    CHECK OF END OF F1NBTB TABLE
          MJN    IFC450      IF NOT END OF F1NBTB TABLE

          LDML   F1CBY4      GET FAULT STATUS 1 BYTES 4 AND 5
          ADML   F1CBY6      ADD FAULT STATUS 1 BYTES 6 AND 7
          ZJN    IFC470      IF FAULT STATUS 1 COMPLETELY PROCESSED
          LDC    2RD         SET FAULT SYMPTOM CODE TO DX4077D
          LJM    IFC70       GO TO GENERATE THE CHARACTERS 77

IFC470    LJM    IFC80       GO TO SET FAULT SYMPTOM CODE IN BUFFER

*         CLEAR THE FAILING BIT INDICATORS IN FAULT STATUS 1 -CIO-.

IFC480    LDML   F1CBY4      GET FAULT STATUS 1 BYTES 4 AND 5
          LMML   F1NBTB,T2   CLEAR FAILING BIT INDICATORS
          STML   F1CBY4      RESET FAULT STATUS 1 BYTES 4 AND 5
          LDML   F1CBY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LMML   F1NBTB+1,T2  CLEAR FAILING BIT INDICATORS
          STML   F1CBY6      RESET FAULT STATUS 1 BYTES 6 AND 7

*         POSSIBLE FAULT STATUS 1 FAILURE HAS BEEN FOUND, CHECK FOR
*         PREVIOUS FAULT STATUS 1 DETECTED. IF A PREVIOUS FAULT WAS
*         ISOLATED, FORCE THE FAULT SYMPTOM CODE TO DX4077C.

          LDDL   T6          CHECK FOR PREVIOUS FAULT STATUS ERROR
          ZJN    IFC490      IF NO PREVIOUS FAULT STATUS ERROR
          LDC    2RC         SET FAULT SYMPTOM CODE TO DX4077C
          LJM    IFC70       GO TO GENERATE THE CHARACTERS 77

*         THE POSSIBLE FAULT STATUS 1 CIO ERROR HAS BEEN FOUND, SAVE THE
*         FAULT SYMPTOM CODE FOR THE FAULT STATUS 1 REGISTER.

IFC490    LDDL   T2          BUILD F1NFSCT TABLE INDEX
          SHN    -1D
          STDL   T4          STORE FSC ASSIGNMENT INDEX
          LDML   F1NFSCT,T4  SET FS1 FAULT SYMPTOM CODE
          STDL   T6

*         CHECK FOR FAULT SYMPTOM CODES DX4005, 10-12, 19-21,
*         24, 26, 27, 29, 31, 33, 37-43, 47, AND 49. IF THE FAULT
*         SYMPTOM CODE IS ONE OF THESE CODES, RESET THE CLUSTER
*         INDICATOR TO BLANK DISPLAY CODES.

          ADC    -CODE05     CHECK FOR FAULT SYMPTOM CODE DX4005
          ZJN    IFC500      IF FAULT SYMPTOM CODE DX4005
          ADC    -CODE10+CODE05  CHECK FOR FAULT SYMPTOM CODE DX4010
          ZJN    IFC500      IF FAULT SYMPTOM CODE DX4010
          SBN    CODE11-CODE10  CHECK FOR FAULT SYMPTOM CODE DX4011
          ZJN    IFC500      IF FAULT SYMPTOM CODE DX4011
          SBN    CODE12-CODE11  CHECK FOR FAULT SYMPTOM CODE DX4012
          ZJN    IFC500      IF FAULT SYMPTOM CODE DX4012
          SBN    CODE19-CODE12  CHECK FOR FAULT SYMPTOM CODE DX4019
          ZJN    IFC500      IF FAULT SYMPTOM CODE DX4019
          ADC    -CODE20+CODE19  CHECK FOR FAULT SYMPTOM CODE DX4020
          NJN    IFC510      IF FAULT SYMPTOM CODE IS NOT DX4020
IFC500    LJM    IFC530      FAULT SYMPTOM CODE IS DX4020
IFC510    SBN    CODE21-CODE20  CHECK FOR FAULT SYMPTOM CODE DX4021
          ZJN    IFC500      IF FAULT SYMPTOM CODE DX4021
          SBN    CODE24-CODE21  CHECK FOR FAULT SYMPTOM CODE DX4024
          ZJN    IFC500      IF FAULT SYMPTOM CODE DX4024
          SBN    CODE26-CODE24  CHECK FOR FAULT SYMPTOM CODE DX4026
          ZJN    IFC500      IF FAULT SYMPTOM CODE DX4026
          SBN    CODE27-CODE26  CHECK FOR FAULT SYMPTOM CODE DX4027
          ZJN    IFC500      IF FAULT SYMPTOM CODE DX4027
          SBN    CODE29-CODE27  CHECK FOR FAULT SYMPTOM CODE DX4029
          ZJN    IFC500      IF FAULT SYMPTOM CODE DX4029
          ADC    -CODE31+CODE29  CHECK FOR FAULT SYMPTOM CODE DX4031
          ZJN    IFC530      IF FAULT SYMPTOM CODE DX4031
          SBN    CODE33-CODE31  CHECK FOR FAULT SYMPTOM CODE DX4033
          ZJN    IFC530      IF FAULT SYMPTOM CODE DX4033
          SBN    CODE37-CODE33  CHECK FOR FAULT SYMPTOM CODE DX4037
          ZJN    IFC530      IF FAULT SYMPTOM CODE DI4037
          SBN    CODE38-CODE37  CHECK FOR FAULT SYMPTOM CODE DI4038
          ZJN    IFC530      IF FAULT SYMPTOM CODE DI4038
          SBN    CODE39-CODE38  CHECK FOR FAULT SYMPTOM CODE DI4039
          ZJN    IFC530      IF FAULT SYMPTOM CODE DI4039
          ADC    -CODE40+CODE39  CHECK FOR FAULT SYMPTOM CODE DI4040
          ZJN    IFC530      IF FAULT SYMPTOM CODE DI4040
          SBN    CODE41-CODE40  CHECK FOR FAULT SYMPTOM CODE DI4041
          ZJN    IFC530      IF FAULT SYMPTOM CODE DI4041
          SBN    CODE42-CODE41  CHECK FOR FAULT SYMPTOM CODE DI4042
          ZJN    IFC530      IF FAULT SYMPTOM CODE DI4042
          SBN    CODE43-CODE42  CHECK FOR FAULT SYMPTOM CODE DI4043
          ZJN    IFC530      IF FAULT SYMPTOM CODE DI4043
          SBN    CODE47-CODE43  CHECK FOR FAULT SYMPTOM CODE DI4047
          ZJN    IFC530      IF FAULT SYMPTOM CODE DI4047
          SBN    CODE49-CODE47  CHECK FOR FAULT SYMPTOM CODE DI4049
          ZJN    IFC530      IF FAULT SYMPTOM CODE DX4049

*         CHECK FOR FAULT SYMPTOM CODES DX4017 AND DX4018.  IF THE
*         FAULT SYMPTOM CODE IS ONE OF THESE CODES, APPEND THE LETTER H
*         TO THE FAULT SYMPTOM CODE.

          LDDL   T6          GET FAULT SYMPTOM CODE
          ADC    -CODE17     CHECK FOR FAULT SYMPTOM CODE DX4017
          ZJN    IFC520      IF FAULT SYMPTOM CODE DX4017
          SBN    CODE18-CODE17  CHECK FOR FAULT SYMPTOM CODE DX4018
          NJN    IFC540      IF NOT FAULT SYMPTOM CODE DX4018
IFC520    LDC    2RH -2R     RESET BARREL INDICATION TO H
IFC530    ADC    2R          RESET BARREL INDICATOR TO BLANKS
          STDL   T7
          UJN    IFC580      GO TO CONTINUE CIO FS1 PROCESSING

*         CHECK THAT LOCATION T7 DOES NOT CONTAIN ZERO.  THIS ENSURES
*         THAT THE FAULT CAN BE ISOLATED TO A FAILING CLUSTER.  IF THE
*         FAULT CANNOT BE ISOLATED TO A FAILING CLUSTER, (I.E.  T7
*         CONTAINS ZERO), FORCE THE FAULT SYMPTOM CODE TO DX4077D.

IFC540    LDDL   T7          GET FAILING CLUSTER INDICATOR
          NJN    IFC550      IF FAILING CLUSTER ISOLATED
          LDC    2RD         SET FAULT SYMPTOM CODE TO DX4077D
          LJM    IFC70       GO TO GENERATE THE CHARACTERS 77

*         CHECK FOR FAULT SYMPTOM CODES DX4022. IF THE FAULT SYMPTOM
*         CODE IS A DX4022, RESET THE BARREL INDICATOR X (A - F) TO
*         A X2 IF BITS 49, 50 AND 51 ARE CLEAR, TO A X0 IF EITHER
*         BIT 49 OR 50 IS SET, OR TO A X1 IF BIT 51 IS SET.

IFC550    LDDL   T6          GET FAULT SYMPTOM CODE
          ADC    -CODE22     CHECK FOR FAULT SYMPTOM CODE DX4022
          NJN    IFC590      IF NOT FAULT SYMPTOM CODE DX4022
          LDML   F1CBY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LPC    FS1MSK3     CHECK IF BITS 49, OR 50, OR 51 SET
          ZJN    IFC570      IF BITS 49, 50 AND 51 CLEAR
          LPC    BT51        CHECK FOR BIT 51 SET
          ZJN    IFC560      IF BIT 51 IS NOT SET
          LDN    1R1-1R0     SET BARREL INDICATOR TO X0
IFC560    SBN    1R2-1R0     SET BARREL INDICATOR TO X1
IFC570    ADN    1R2-1R      SET BARREL INDICATOR TO X2
          RADL   T7
          LDML   F1CBY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LPC    -FS1MSK3    CLEAR BITS 49, 50 AND 51
          STML   F1CBY6      SAVE UPDATED FS1, BYTES 6 AND 7
IFC580    LJM    IFC460      GO TO CONTINUE FAULT STATUS 1 PROCESSING

*         CHECK FOR FAULT SYMPTOM CODES DX4023, DX4028, DX4030, DX4032
*         AND DX4034. IF THE FAULT SYMPTOM CODE IS ONE OF THESE CODES,
*         RESET THE BARREL INDICATOR X (A - F) TO A X1 IF BITS 49
*         AND 50 ARE CLEAR OR TO A X0 IF EITHER BIT 49 OR 50 IS SET.

IFC590    SBN    CODE23-CODE22  CHECK FOR FAULT SYMPTOM CODE DX4023
          ZJN    IFC600      IF FAULT SYMPTOM CODE DX4023
          SBN    CODE28-CODE23  CHECK FOR FAULT SYMPTOM CODE DX4028
          ZJN    IFC600      IF FAULT SYMPTOM CODE DX4028
          ADC    -CODE30+CODE28  CHECK FOR FAULT SYMPTOM CODE DX4030
          ZJN    IFC600      IF FAULT SYMPTOM CODE DX4030
          SBN    CODE32-CODE30  CHECK FOR FAULT SYMPTOM CODE DX4032
          ZJN    IFC600      IF FAULT SYMPTOM CODE DX4032
          SBN    CODE34-CODE32  CHECK FOR FAULT SYMPTOM CODE DX4034
          NJN    IFC580      IF NOT FAULT SYMPTOM CODE DX4034
IFC600    LDML   F1CBY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LPC    FS1MSK2     CHECK FOR BIT 49 OR 50 SET
          ZJN    IFC610      IF BIT 49 AND 50 IS NOT SET
          LCN    1R1-1R0     SET BARREL INDICATOR TO X1
IFC610    ADN    1R1-1R      SET BARREL INDICATOR TO X0
          RADL   T7
          LDML   F1CBY6      GET FAULT STATUS 1 BYTES 6 AND 7
          LPC    -FS1MSK2    CLEAR BITS 49 AND 50
          STML   F1CBY6      SAVE UPDATED FS1, BYTES 6 AND 7
          UJN    IFC580      GO TO CONTINUE FAULT STATUS 1 PROCESSING
FSBUFR    TITLE  FAULT STATUS 1 AND 2 TEMPORARY BUFFER
*         FAULT STATUS 1 AND 2 BUFFER.
*         F1N = FS1 NIO, F2N = FS2 NIO
*         F1C = FS1 CIO, F2C = FS2 CIO

FSBUFR    BSS    0           FAULT STATUS 1 AND 2 BUFFER
F1NBY0    BSS    0           FAULT STATUS 1, BYTE 0
F1NBY1    BSS    0           FAULT STATUS 1, BYTE 1
          CON    0           FAULT STATUS 1 WORD 1, BYTES 0 AND 1

F1NBY2    BSS    0           FAULT STATUS 1, BYTE 2
F1NBY3    BSS    0           FAULT STATUS 1, BYTE 3
          CON    0           FAULT STATUS 1 WORD 2, BYTES 2 AND 3

F1NBY4    BSS    0           FAULT STATUS 1, BYTE 4
F1NBY5    BSS    0           FAULT STATUS 1, BYTE 5
          CON    0           FAULT STATUS 1 WORD 3, BYTES 4 AND 5

F1NBY6    BSS    0           FAULT STATUS 1, BYTE 6
F1NBY7    BSS    0           FAULT STATUS 1, BYTE 7
          CON    0           FAULT STATUS 1 WORD 4, BYTES 6 AND 7

*         FAULT STATUS 2 -NIO- BYTE OFFSETS IN THE STATUS BUFFER.

F2NBY0    BSS    0           FAULT STATUS 2, BYTE 0
F2NBY1    BSS    0           FAULT STATUS 2, BYTE 1
          CON    0           FAULT STATUS 2 WORD 1, BYTES 0 AND 1

F2NBY2    BSS    0           FAULT STATUS 2, BYTE 2
F2NBY3    BSS    0           FAULT STATUS 2, BYTE 3
          CON    0           FAULT STATUS 2 WORD 2, BYTES 2 AND 3

F2NBY4    BSS    0           FAULT STATUS 2, BYTE 4
F2NBY5    BSS    0           FAULT STATUS 2, BYTE 5
          CON    0           FAULT STATUS 2 WORD 3, BYTES 4 AND 5

F2NBY6    BSS    0           FAULT STATUS 2, BYTE 6
F2NBY7    BSS    0           FAULT STATUS 2, BYTE 7
          CON    0           FAULT STATUS 2 WORD 4, BYTES 6 AND 7
          EJECT
*         FAULT STATUS 1 -CIO- BYTE OFFSETS IN THE STATUS REGISTER.

F1CBY0    BSS    0           FAULT STATUS 1, BYTE 0
F1CBY1    BSS    0           FAULT STATUS 1, BYTE 1
          CON    0           FAULT STATUS 1 WORD 1, BYTES 0 AND 1

F1CBY2    BSS    0           FAULT STATUS 1, BYTE 2
F1CBY3    BSS    0           FAULT STATUS 1, BYTE 3
          CON    0           FAULT STATUS 1 WORD 2, BYTES 2 AND 3

F1CBY4    BSS    0           FAULT STATUS 1, BYTE 4
F1CBY5    BSS    0           FAULT STATUS 1, BYTE 5
          CON    0           FAULT STATUS 1 WORD 3, BYTES 4 AND 5

F1CBY6    BSS    0           FAULT STATUS 1, BYTE 6
F1CBY7    BSS    0           FAULT STATUS 1, BYTE 7
          CON    0           FAULT STATUS 1 WORD 4, BYTES 6 AND 7

*         FAULT STATUS 2 -CIO- BYTE OFFSETS IN THE STATUS BUFFER.

F2CBY0    BSS    0           FAULT STATUS 2, BYTE 0
F2CBY1    BSS    0           FAULT STATUS 2, BYTE 1
          CON    0           FAULT STATUS 2 WORD 1, BYTES 0 AND 1

F2CBY2    BSS    0           FAULT STATUS 2, BYTE 2
F2CBY3    BSS    0           FAULT STATUS 2, BYTE 3
          CON    0           FAULT STATUS 2 WORD 2, BYTES 2 AND 3

F2CBY4    BSS    0           FAULT STATUS 2, BYTE 4
F2CBY5    BSS    0           FAULT STATUS 2, BYTE 5
          CON    0           FAULT STATUS 2 WORD 3, BYTES 4 AND 5

F2CBY6    BSS    0           FAULT STATUS 2, BYTE 6
F2CBY7    BSS    0           FAULT STATUS 2, BYTE 7
          CON    0           FAULT STATUS 2 WORD 4, BYTES 6 AND 7
F1NBTB    TITLE  FAULT STATUS 1 BIT TABLE FOR NIO FAULT SYMPTOM CODES
F1NBTB    BSS    0
          BITS   BT32+BT44,0  FAULT SYMPTOM CODE EQUALS 01
          BITS   BT32+BT47,0  FAULT SYMPTOM CODE EQUALS 02
          BITS   BT32,0       FAULT SYMPTOM CODE EQUALS 03
          BITS   BT33,0       FAULT SYMPTOM CODE EQUALS 04
          BITS   BT34,0       FAULT SYMPTOM CODE EQUALS 05
          BITS   BT35,0       FAULT SYMPTOM CODE EQUALS 06
          BITS   BT46,0       FAULT SYMPTOM CODE EQUALS 07
          BITS   BT36,BT55    FAULT SYMPTOM CODE EQUALS 08
          BITS   BT36,0       FAULT SYMPTOM CODE EQUALS 09
          BITS   BT37,BT48    FAULT SYMPTOM CODE EQUALS 10
          BITS   BT37,BT53    FAULT SYMPTOM CODE EQUALS 11
          BITS   BT37,0       FAULT SYMPTOM CODE EQUALS 12
          BITS   BT38,BT54    FAULT SYMPTOM CODE EQUALS 13
          BITS   BT38,BT55    FAULT SYMPTOM CODE EQUALS 14
          BITS   BT38,BT56    FAULT SYMPTOM CODE EQUALS 15
          BITS   BT39,BT52    FAULT SYMPTOM CODE EQUALS 16
          BITS   BT40,0       FAULT SYMPTOM CODE EQUALS 17
          BITS   BT41,0       FAULT SYMPTOM CODE EQUALS 18
          BITS   BT42,0       FAULT SYMPTOM CODE EQUALS 19
          BITS   BT43,0       FAULT SYMPTOM CODE EQUALS 20
          BITS   0,BT48+BT57  FAULT SYMPTOM CODE EQUALS 21
          BITS   0,BT55+BT57  FAULT SYMPTOM CODE EQUALS 22
          BITS   0,BT55+BT58  FAULT SYMPTOM CODE EQUALS 23
          BITS   0,BT53+BT59  FAULT SYMPTOM CODE EQUALS 24
          BITS   0,BT56+BT59  FAULT SYMPTOM CODE EQUALS 25
          BITS   0,BT59       FAULT SYMPTOM CODE EQUALS 26
          BITS   0,BT52+BT60  FAULT SYMPTOM CODE EQUALS 27
          BITS   0,BT54+BT60  FAULT SYMPTOM CODE EQUALS 28
          BITS   0,BT52+BT61  FAULT SYMPTOM CODE EQUALS 29
          BITS   0,BT54+BT61  FAULT SYMPTOM CODE EQUALS 30
          BITS   0,BT52+BT62  FAULT SYMPTOM CODE EQUALS 31
          BITS   0,BT54+BT62  FAULT SYMPTOM CODE EQUALS 32
          BITS   0,BT52+BT63  FAULT SYMPTOM CODE EQUALS 33
          BITS   0,BT54+BT63  FAULT SYMPTOM CODE EQUALS 34
          BITS   BT44,0       FAULT SYMPTOM CODE EQUALS 35
          BITS   BT45,0       FAULT SYMPTOM CODE EQUALS 36
          BITS   0,BT49       FAULT SYMPTOM CODE EQUALS 37
          BITS   0,BT50       FAULT SYMPTOM CODE EQUALS 37
          BITS   0,BT51       FAULT SYMPTOM CODE EQUALS 37
          BITS   0,BT63       FAULT SYMPTOM CODE EQUALS 38
          BITS   0,BT62       FAULT SYMPTOM CODE EQUALS 39
          BITS   0,BT61       FAULT SYMPTOM CODE EQUALS 40
          BITS   0,BT60       FAULT SYMPTOM CODE EQUALS 41
          BITS   0,BT58       FAULT SYMPTOM CODE EQUALS 42
          BITS   0,BT57       FAULT SYMPTOM CODE EQUALS 43
          BITS   BT39,0       FAULT SYMPTOM CODE EQUALS 44
          BITS   BT38,0       FAULT SYMPTOM CODE EQUALS 45
          BITS   BT47,0       FAULT SYMPTOM CODE EQUALS 46
          BITS   0,BT48       FAULT SYMPTOM CODE EQUALS 47
          BITS   0,BT52       FAULT SYMPTOM CODE EQUALS 48
          BITS   0,BT53       FAULT SYMPTOM CODE EQUALS 49
          BITS   0,BT54       FAULT SYMPTOM CODE EQUALS 60
          BITS   0,BT55       FAULT SYMPTOM CODE EQUALS 61
          BITS   0,BT56       FAULT SYMPTOM CODE EQUALS 62
F1NBTBL   EQU    *-F1NBTB     LENGTH OF THE FAULT STATUS TABLE
F1NFSCT   TITLE  FAULT STATUS 1 -NIO- FAULT SYMPTOM CODES
*         FAULT STATUS 1 -NIO- FAULT SYMPTOM CODES TABLE.

F1NFSCT   BSS    0
          DATA   H*01*       FAULT SYMPTOM CODE FOR BITS 32 AND 44
          DATA   H*02*       FAULT SYMPTOM CODE FOR BITS 32 AND 47
          DATA   H*03*       FAULT SYMPTOM CODE FOR BIT 32
          DATA   H*04*       FAULT SYMPTOM CODE FOR BIT 33
          DATA   H*05*       FAULT SYMPTOM CODE FOR BIT 34
          DATA   H*06*       FAULT SYMPTOM CODE FOR BIT 35
          DATA   H*07*       FAULT SYMPTOM CODE FOR BIT 46
          DATA   H*08*       FAULT SYMPTOM CODE FOR BITS 36 AND 55
          DATA   H*09*       FAULT SYMPTOM CODE FOR BIT 36
          DATA   H*10*       FAULT SYMPTOM CODE FOR BITS 37 AND 48
          DATA   H*11*       FAULT SYMPTOM CODE FOR BITS 37 AND 53
          DATA   H*12*       FAULT SYMPTOM CODE FOR BIT 37
          DATA   H*13*       FAULT SYMPTOM CODE FOR BITS 38 AND 54
          DATA   H*14*       FAULT SYMPTOM CODE FOR BITS 38 AND 55
          DATA   H*15*       FAULT SYMPTOM CODE FOR BITS 38 AND 56
          DATA   H*16*       FAULT SYMPTOM CODE FOR BITS 39 AND 52
          DATA   H*17*       FAULT SYMPTOM CODE FOR BIT 40
          DATA   H*18*       FAULT SYMPTOM CODE FOR BIT 41
          DATA   H*19*       FAULT SYMPTOM CODE FOR BIT 42
          DATA   H*20*       FAULT SYMPTOM CODE FOR BIT 43
          DATA   H*21*       FAULT SYMPTOM CODE FOR BITS 48 AND 57
          DATA   H*22*       FAULT SYMPTOM CODE FOR BITS 55 AND 57
          DATA   H*23*       FAULT SYMPTOM CODE FOR BITS 55 AND 58
          DATA   H*24*       FAULT SYMPTOM CODE FOR BITS 53 AND 59
          DATA   H*25*       FAULT SYMPTOM CODE FOR BITS 56 AND 59
          DATA   H*26*       FAULT SYMPTOM CODE FOR BIT 59
          DATA   H*27*       FAULT SYMPTOM CODE FOR BITS 52 AND 60
          DATA   H*28*       FAULT SYMPTOM CODE FOR BITS 54 AND 60
          DATA   H*29*       FAULT SYMPTOM CODE FOR BITS 52 AND 61
          DATA   H*30*       FAULT SYMPTOM CODE FOR BITS 54 AND 61
          DATA   H*31*       FAULT SYMPTOM CODE FOR BITS 52 AND 62
          DATA   H*32*       FAULT SYMPTOM CODE FOR BITS 54 AND 62
          DATA   H*33*       FAULT SYMPTOM CODE FOR BITS 52 AND 63
          DATA   H*34*       FAULT SYMPTOM CODE FOR BITS 54 AND 63
          DATA   H*35*       FAULT SYMPTOM CODE FOR BIT 44
          DATA   H*36*       FAULT SYMPTOM CODE FOR BIT 45
          DATA   H*37*       FAULT SYMPTOM CODE FOR BIT 49
          DATA   H*37*       FAULT SYMPTOM CODE FOR BIT 50
          DATA   H*37*       FAULT SYMPTOM CODE FOR BIT 51
          DATA   H*38*       FAULT SYMPTOM CODE FOR BIT 63
          DATA   H*39*       FAULT SYMPTOM CODE FOR BIT 62
          DATA   H*40*       FAULT SYMPTOM CODE FOR BIT 61
          DATA   H*41*       FAULT SYMPTOM CODE FOR BIT 60
          DATA   H*42*       FAULT SYMPTOM CODE FOR BIT 58
          DATA   H*43*       FAULT SYMPTOM CODE FOR BIT 57
          DATA   H*44*       FAULT SYMPTOM CODE FOR BIT 39
          DATA   H*45*       FAULT SYMPTOM CODE FOR BIT 38
          DATA   H*46*       FAULT SYMPTOM CODE FOR BIT 47
          DATA   H*47*       FAULT SYMPTOM CODE FOR BIT 48
          DATA   H*48*       FAULT SYMPTOM CODE FOR BIT 52
          DATA   H*49*       FAULT SYMPTOM CODE FOR BIT 53
          DATA   H*60*       FAULT SYMPTOM CODE FOR BIT 54
          DATA   H*61*       FAULT SYMPTOM CODE FOR BIT 55
          DATA   H*62*       FAULT SYMPTOM CODE FOR BIT 56
F2NFSCT   TITLE  FAULT STATUS 2 -NIO- FAULT SYMPTOM CODES
*         FAULT STATUS 2 -NIO- FAULT SYMPTOM CODES TABLE.

F2NFSCT   BSS    0
          DATA   H*7707*     CHANNEL EQUALS  7
          DATA   H*7706*     CHANNEL EQUALS  6
          DATA   H*7705*     CHANNEL EQUALS  5
          DATA   H*7704*     CHANNEL EQUALS  4
          DATA   H*7703*     CHANNEL EQUALS  3
          DATA   H*7702*     CHANNEL EQUALS  2
          DATA   H*7701*     CHANNEL EQUALS  1
          DATA   H*7700*     CHANNEL EQUALS  0
          DATA   H*7770*     CHANNEL EQUALS 17
          DATA   H*0   *     NOT AVAILABLE
          DATA   H*7715*     CHANNEL EQUALS 15
          DATA   H*0   *     NOT AVAILABLE
          DATA   H*7713*     CHANNEL EQUALS 13
          DATA   H*7712*     CHANNEL EQUALS 12
          DATA   H*7711*     CHANNEL EQUALS 11
          DATA   H*7710*     CHANNEL EQUALS 10
          DATA   H*7727*     CHANNEL EQUALS 27
          DATA   H*7726*     CHANNEL EQUALS 26
          DATA   H*7725*     CHANNEL EQUALS 25
          DATA   H*7724*     CHANNEL EQUALS 24
          DATA   H*7723*     CHANNEL EQUALS 23
          DATA   H*7722*     CHANNEL EQUALS 22
          DATA   H*7721*     CHANNEL EQUALS 21
          DATA   H*7720*     CHANNEL EQUALS 20
          DATA   H*50  *     MAC ERROR
          DATA   H*    *     NOT AVAILABLE
          DATA   H*51  *     RADIAL INTERFACE 4/5/6 ERROR
          DATA   H*52  *     RADIAL INTERFACE 1/2/3 ERROR
          DATA   H*7733*     CHANNEL EQUALS 33
          DATA   H*7732*     CHANNEL EQUALS 32
          DATA   H*7731*     CHANNEL EQUALS 31
          DATA   H*7730*     CHANNEL EQUALS 30
F2CFSCT   TITLE  FAULT STATUS 2 -CIO- FAULT SYMPTOM CODES
*         FAULT STATUS 2 -CIO- FAULT SYMPTOM CODES TABLE.

F2CFSCT   BSS    0
          DATA   H*7607*     CIO CHANNEL EQUALS  7
          DATA   H*7606*     CIO CHANNEL EQUALS  6
          DATA   H*7605*     CIO CHANNEL EQUALS  5
          DATA   H*7604*     CIO CHANNEL EQUALS  4
          DATA   H*7603*     CIO CHANNEL EQUALS  3
          DATA   H*7602*     CIO CHANNEL EQUALS  2
          DATA   H*7601*     CIO CHANNEL EQUALS  1
          DATA   H*7600*     CIO CHANNEL EQUALS  0
          DATA   H*0   *     NOT AVAILABLE
          DATA   H*0   *     NOT AVAILABLE
          DATA   H*0   *     NOT AVAILABLE
          DATA   H*0   *     NOT AVAILABLE
          DATA   H*0   *     NOT AVAILABLE
          DATA   H*0   *     NOT AVAILABLE
          DATA   H*7611*     CIO CHANNEL EQUALS 15
          DATA   H*7610*     CIO CHANNEL EQUALS 10

          QUAL   *
*         END    CTP$DFT MODEL 40 IOU FSC.
*DECK DECK=CTP$DFT_MODEL_44_IOU_FSC EXPAND=FALSE
*         CTEXT  CTP$DFT MODEL 44 IOU FSC.

          QUAL   IOUFLT4                                                 IOUFLT4
          COMMENT IOUFLT4 - IOU FAULT SYMPTOM CODE DECK *REL. LEVEL 780*
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992               IOUFLT4
BITS      TITLE  IOU FAULT SYMPTOM CODE COMMON DECK                      IOUFLT4
**        BITS - FAULT STATUS 1 TABLE MACRO                              IOUFLT4
*                                                                        IOUFLT4
          PURGMAC  BITS
BITS      MACRO  BIT1,BIT2                                               IOUFLT4
+         VFD    16/BIT1,16/BIT2                                         IOUFLT4
BITS      ENDM                                                           IOUFLT4
EQUATES   TITLE  IOUFLT4 COMMON DECK EQUATES                             IOUFLT4
*         EQUATES FOR FAULT SYMPTOM CODES THAT DO NOT REQUIRE THE USE    IOUFLT4
*         OF THE CLUSTER CODE (A, B, C OR D).                            IOUFLT4
                                                                         IOUFLT4
CODE05    EQU    2R05        EQUATE FOR FAULT SYMPTOM CODE 05            IOUFLT4
CODE17    EQU    2R17        EQUATE FOR FAULT SYMPTOM CODE 17            IOUFLT4
CODE18    EQU    2R18        EQUATE FOR FAULT SYMPTOM CODE 18            IOUFLT4
CODE19    EQU    2R19        EQUATE FOR FAULT SYMPTOM CODE 19            IOUFLT4
CODE20    EQU    2R20        EQUATE FOR FAULT SYMPTOM CODE 20            IOUFLT4
CODE37    EQU    2R37        EQUATE FOR FAULT SYMPTOM CODE 37            IOUFLT4
CODE38    EQU    2R38        EQUATE FOR FAULT SYMPTOM CODE 38
CODE39    EQU    2R39        EQUATE FOR FAULT SYMPTOM CODE 39
CODE40    EQU    2R40        EQUATE FOR FAULT SYMPTOM CODE 40
CODE41    EQU    2R41        EQUATE FOR FAULT SYMPTOM CODE 41
CODE42    EQU    2R42        EQUATE FOR FAULT SYMPTOM CODE 42
CODE43    EQU    2R43        EQUATE FOR FAULT SYMPTOM CODE 43
CODE47    EQU    2R47        EQUATE FOR FAULT SYMPTOM CODE 47
CODE49    EQU    2R49        EQUATE FOR FAULT SYMPTOM CODE 49
                                                                         IOUFLT4
                                                                         IOUFLT4
*         EQUATES FOR FAULT SYMPTOM CODES THAT END WITH A 0 OR 1         IOUFLT4
*         FOLLOWING THE CLUSTER CODE (A, B, C OR D) INDICATING THAT      IOUFLT4
*         BITS 49, AND/OR 50, AND/OR 51 WERE SET OR CLEAR.               IOUFLT4
                                                                         IOUFLT4
CODE22    EQU    2R22        EQUATE FOR FAULT SYMPTOM CODE 22            IOUFLT4
CODE23    EQU    2R23        EQUATE FOR FAULT SYMPTOM CODE 23            IOUFLT4
CODE28    EQU    2R28        EQUATE FOR FAULT SYMPTOM CODE 28            IOUFLT4
CODE30    EQU    2R30        EQUATE FOR FAULT SYMPTOM CODE 30            IOUFLT4
CODE32    EQU    2R32        EQUATE FOR FAULT SYMPTOM CODE 32            IOUFLT4
CODE34    EQU    2R34        EQUATE FOR FAULT SYMPTOM CODE 34            IOUFLT4
                                                                         IOUFLT4
                                                                         IOUFLT4
*         EQUATES FOR FAULT STATUS BYTE 4 (BITS 32-39).                  IOUFLT4
                                                                         IOUFLT4
BT32      EQU    0#8000      FAULT STATUS BIT 32 EQUATE                  IOUFLT4
BT33      EQU    0#4000      FAULT STATUS BIT 33 EQUATE                  IOUFLT4
BT34      EQU    0#2000      FAULT STATUS BIT 34 EQUATE                  IOUFLT4
BT35      EQU    0#1000      FAULT STATUS BIT 35 EQUATE                  IOUFLT4
BT36      EQU    0#0800      FAULT STATUS BIT 36 EQUATE                  IOUFLT4
BT37      EQU    0#0400      FAULT STATUS BIT 37 EQUATE                  IOUFLT4
BT38      EQU    0#0200      FAULT STATUS BIT 38 EQUATE                  IOUFLT4
BT39      EQU    0#0100      FAULT STATUS BIT 39 EQUATE                  IOUFLT4
                                                                         IOUFLT4
                                                                         IOUFLT4
*         EQUATES FOR FAULT STATUS BYTE 5 (BITS 40-47).                  IOUFLT4
                                                                         IOUFLT4
BT40      EQU    0#0080      FAULT STATUS BIT 40 EQUATE                  IOUFLT4
BT41      EQU    0#0040      FAULT STATUS BIT 41 EQUATE                  IOUFLT4
BT42      EQU    0#0020      FAULT STATUS BIT 42 EQUATE                  IOUFLT4
BT43      EQU    0#0010      FAULT STATUS BIT 43 EQUATE                  IOUFLT4
BT44      EQU    0#0008      FAULT STATUS BIT 44 EQUATE                  IOUFLT4
BT45      EQU    0#0004      FAULT STATUS BIT 45 EQUATE                  IOUFLT4
BT46      EQU    0#0002      FAULT STATUS BIT 46 EQUATE                  IOUFLT4
BT47      EQU    0#0001      FAULT STATUS BIT 47 EQUATE                  IOUFLT4
                                                                         IOUFLT4
                                                                         IOUFLT4
*         EQUATES FOR FAULT STATUS BYTE 6 (BITS 48-55).                  IOUFLT4
                                                                         IOUFLT4
BT48      EQU    0#8000      FAULT STATUS BIT 48 EQUATE                  IOUFLT4
BT49      EQU    0#4000      FAULT STATUS BIT 49 EQUATE                  IOUFLT4
BT50      EQU    0#2000      FAULT STATUS BIT 50 EQUATE                  IOUFLT4
BT51      EQU    0#1000      FAULT STATUS BIT 51 EQUATE                  IOUFLT4
BT52      EQU    0#0800      FAULT STATUS BIT 52 EQUATE                  IOUFLT4
BT53      EQU    0#0400      FAULT STATUS BIT 53 EQUATE                  IOUFLT4
BT54      EQU    0#0200      FAULT STATUS BIT 54 EQUATE                  IOUFLT4
BT55      EQU    0#0100      FAULT STATUS BIT 55 EQUATE                  IOUFLT4
                                                                         IOUFLT4
                                                                         IOUFLT4
*         EQUATES FOR FAULT STATUS BYTE 7 (BITS 56-63).                  IOUFLT4
                                                                         IOUFLT4
BT56      EQU    0#0080      FAULT STATUS BIT 56 EQUATE                  IOUFLT4
BT57      EQU    0#0040      FAULT STATUS BIT 57 EQUATE                  IOUFLT4
BT58      EQU    0#0020      FAULT STATUS BIT 58 EQUATE                  IOUFLT4
BT59      EQU    0#0010      FAULT STATUS BIT 59 EQUATE                  IOUFLT4
BT60      EQU    0#0008      FAULT STATUS BIT 60 EQUATE                  IOUFLT4
BT61      EQU    0#0004      FAULT STATUS BIT 61 EQUATE                  IOUFLT4
BT62      EQU    0#0002      FAULT STATUS BIT 62 EQUATE                  IOUFLT4
BT63      EQU    0#0001      FAULT STATUS BIT 63 EQUATE                  IOUFLT4
                                                                         IOUFLT4
                                                                         IOUFLT4
*         MISCELLANEOUS EQUATES FOR FAULT STATUS 1 AND FAULT STATUS 2.   IOUFLT4
                                                                         IOUFLT4
FS1MSK0   EQU    0#FFF8      FS1 MASK FOR BITS 32-43                     IOUFLT4
FS1MSK1   EQU    0#007F      FS1 MASK FOR BITS 57-63                     IOUFLT4
FS1MSK2   EQU    0#6000      FS1 MASK FOR BITS 49 AND 50                 IOUFLT4
FS1MSK3   EQU    0#7000      FS1 MASK FOR BITS 49, 50 AND 51             IOUFLT4
FS1MSK4   EQU    0#080F      FS1 MASK FOR BITS 52, 60, 61, 62 AND 63     IOUFLT4
FS1MSK5   EQU    0#F7F0      FS1 MASK FOR BITS 48-51, 53-59              IOUFLT4
FS1MSK6   EQU    0#020F      FS1 MASK FOR BITS 54 AND 60-63
FS1MSK7   EQU    0#87FF      FS1 MASK TO CLEAR BITS 49-52
FS1MSK8   EQU    0#0300      FS1 MASK TO CLEAR BITS 54 AND 55
FS2MSK0   EQU    0#FFAF      FS2 MASK FOR BITS 32-47                     IOUFLT4
FS2MSK1   EQU    0#FF9F      FS2 MASK FOR BITS 48-63                     IOUFLT4
IOUFLT4   TITLE  GENERATE IOU FAULT SYMPTOM CODE                         IOUFLT4
IOUFLT4X  LJM    0           IOU FAULT SYMPTOM CODE GENERATION           IOUFLT4
IOUFLT4   EQU    *-1         ENTRY POINT                                 IOUFLT4
                                                                         IOUFLT4
*         SAVE FAULT STATUS BUFFER ADDRESS IN -A- ON ENTRY.              IOUFLT4
                                                                         IOUFLT4
          STDL   T1          SAVE FAULT STATUS BUFFER ADDRESS            IOUFLT4
          ADN    1D                                                      IOUFLT4
          STDL   T3                                                      IOUFLT4
                                                                         IOUFLT4
*         INITIALIZE TEMPORARY LOCATIONS.                                IOUFLT4
                                                                         IOUFLT4
          LDN    0                                                       IOUFLT4
          STDL   T2          INITIALIZE TABLE INDEX                      IOUFLT4
          STDL   T4                                                      IOUFLT4
          STDL   T5                                                      IOUFLT4
          STDL   T6          INITIALIZE FAULT SYMPTOM CODE LOCATIONS     IOUFLT4
          STDL   T7                                                      IOUFLT4
                                                                         IOUFLT4
*         MOVE FAULT STATUS 1 AND 2 TO THE TEMPORARY STATUS BUFFER.      IOUFLT4
                                                                         IOUFLT4
IFC10     LDIL   T3          MOVE FAULT STATUS 1 AND 2 TO BUFFER         IOUFLT4
          STML   FSBUFR,T4                                               IOUFLT4
          AODL   T3          UPDATE SOURCE ADDRESS                       IOUFLT4
          AODL   T4          UPDATE BUFFER INDEX                         IOUFLT4
          SBN    8D          CHECK FOR MOVE COMPLETE                     IOUFLT4
          MJN    IFC10       IF MOVE NOT COMPLETE                        IOUFLT4
                                                                         IOUFLT4
*         CHECK FOR PIP3 TYPE OF CPU.                                    IOUFLT4
                                                                         IOUFLT4
          LDIL   T1          GET CPU IDENTIFIER                          IOUFLT4
          LMC    2R3A        CHECK FOR PIP3 CPU                          IOUFLT4
          NJN    IFC20       IF NOT PIP3 CPU                             IOUFLT4
                                                                         IOUFLT4
*         IF PIP3 TYPE OF CPU, CHECK FOR BITS 52, 60, 61, 62 AND 63 SET  IOUFLT4
*         IN FAULT STATUS 1. IF NOT, CHECK FOR BITS 54,60-63 BEING SET.

          LDML   FS1BY6      GET FS1 BYTES 6 AND 7
          LPC    FS1MSK4     MASK FS1 FOR BITS 52 AND 60-63
          LMC    FS1MSK4     COMPARE FOR BITS 52 AND 60-63 ALL SET
          ZJN    IFC30       IF BITS 52 AND 60-63 ALL SET IN FS1
          LDML   FS1BY6
          LPC    FS1MSK6     MASK FS1 BITS FOR BITS 54 AND 60-63
          LMC    FS1MSK6     COMPARE W/SET BITS 54 AND 60-63
IFC20     NJN    IFC40       IF BITS 54 AND 60-63 NOT ALL SET
          LDC    2RE         GET 2ND PART OF 77E FSC
          LJM    IFC110      GO FORM 77E FSC AND EXIT TO CALLING PROGRAM

*         CLEAR BITS 52, 60, 61, 62 AND 63 IN FAULT STATUS 1.
*         POSSIBLY CLEAR BITS 49-52.

IFC30     LDML   FS1BY6      GET FS1 BYTES 6 AND 7
          LPC    FS1MSK5     CLEAR BITS 52, 60, 61, 62, AND 63
          STML   FS1BY6      REPLACE FS1 BYTES 6 AND 7
          LPC    FS1MSK8     COMPARE W/BITS 54 AND 55
          ZJN    IFC40       IF NEITHER BIT 54 OR 55 SET
          LDML   FS1BY6
          LPC    FS1MSK7     CLEAR FS1 BITS 49-52
          STML   FS1BY6      REPLACE FS1 BYTES 6 AND 7
                                                                         IOUFLT4
*         CHECK FAULT STATUS 2 BYTES 4 AND 5 FOR CHANNEL FAULT BITS      IOUFLT4
*         SET.                                                           IOUFLT4
                                                                         IOUFLT4
IFC40     LDML   FS2BY4      GET FS2 BYTES 4 AND 5                       IOUFLT4
          LPC    FS2MSK0     MASK OFF NOT USED AND NOT AVAILABLE BITS    IOUFLT4
          STML   FS2BY4      SAVE FAULT STATUS WORD                      IOUFLT4
          LDML   FS2BY6      GET FS2 BYTES 6 AND 7                       IOUFLT4
          LPC    FS2MSK1     MASK OFF NOT USED AND NOT AVAILABLE BITS    IOUFLT4
          STML   FS2BY6      SAVE FAULT STATUS WORD                      IOUFLT4
          ADML   FS2BY4      INCLUDE FAULT STATUS BYTES 4 AND 5          IOUFLT4
          NJN    IFC60       IF FAULT STATUS 2 ERROR                     IOUFLT4
IFC50     LJM    IFC150      GO TO CHECK FOR FAULT STATUS 1 ERROR        IOUFLT4
                                                                         IOUFLT4
*         DETERMINE THE BIT(S) WHICH ARE SET IN THE FAULT STATUS 2       IOUFLT4
*         WORD AND GENERATE THE FAULT SYMPTOM CODE.                      IOUFLT4
                                                                         IOUFLT4
IFC60     LDC    FS2BY4      INITIALIZE FAULT STATUS BUFFER INDEX        IOUFLT4
          STDL   T3                                                      IOUFLT4
IFC70     LDC    0#8000      INITIALIZE FAULT STATUS BIT MASK            IOUFLT4
IFC80     STDL   T4                                                      IOUFLT4
          LPIL   T3          CHECK FOR CHANNEL BIT SET IN FS2            IOUFLT4
          ZJN    IFC90       IF CHANNEL BIT IS NOT SET IN FS2            IOUFLT4
                                                                         IOUFLT4
*         POSSIBLE CHANNEL FAULT BIT HAS BEEN FOUND, CHECK FOR PREVIOUS  IOUFLT4
*         CHANNEL FAULT BIT DETECTED.                                    IOUFLT4
                                                                         IOUFLT4
          LDDL   T6          CHECK FOR PREVIOUS CHANNEL FAULT BIT FOUND  IOUFLT4
          ADDL   T7                                                      IOUFLT4
          NJN    IFC100      IF PREVIOUS CHANNEL FAULT BIT FOUND         IOUFLT4
                                                                         IOUFLT4
*         THE POSSIBLE CHANNEL FAULT BIT HAS BEEN FOUND, SAVE THE FAULT  IOUFLT4
*         SYMPTOM CODE FOR THE CHANNEL FAULT BIT.                        IOUFLT4
                                                                         IOUFLT4
          LDDL   T2          BUILD FS2FSCT TABLE INDEX                   IOUFLT4
          SHN    1D                                                      IOUFLT4
          STDL   T5                                                      IOUFLT4
          LDML   FS2FSCT,T5  SET FS2 FAULT SYMPTOM CODE                  IOUFLT4
          STDL   T6                                                      IOUFLT4
          LDML   FS2FSCT+1,T5  SET FS2 FAULT SYMPTOM CODE                IOUFLT4
          STDL   T7                                                      IOUFLT4
IFC90     AODL   T2          UPDATE FAULT STATUS 2 TABLE INDEX           IOUFLT4
          SBN    32D         CHECK FOR ALL CHANNEL BITS CHECKED          IOUFLT4
          PJN    IFC50       IF ALL CHANNEL BITS CHECKED                 IOUFLT4
          LDDL   T4          UPDATE FAULT STATUS BIT MASK                IOUFLT4
          SHN    -1D                                                     IOUFLT4
          NJN    IFC80       IF FS2 BYTES 4 AND 5 NOT CHECKED            IOUFLT4
          AODL   T3          UPDATE FAULT STATUS BUFFER INDEX            IOUFLT4
          UJN    IFC70       GO TO CHECK NEXT FAULT STATUS WORD          IOUFLT4
                                                                         IOUFLT4
*         MORE THAN ONE ONE BIT HAS BEEN FOUND SET IN FAULT STATUS 2,    IOUFLT4
*         FORCE THE FAULT SYMPTOM CODE TO DX4477A.                       IOUFLT4
                                                                         IOUFLT4
IFC100    LDC    2RA         GENERATE THE FAULT SYMPTOM CODE DX4477A     IOUFLT4
IFC110    STDL   T7                                                      IOUFLT4
          LDC    2R77        GENERATE THE CHARACTERS 77                  IOUFLT4
          STDL   T6                                                      IOUFLT4
                                                                         IOUFLT4
*         MOVE THE FAULT SYMPTOM CODE TO THE BUFFER THAT CONTAINED THE   IOUFLT4
*         FAULT STATUS REGISTERS 1 AND 2 ON ENTRY AND EXIT.              IOUFLT4
                                                                         IOUFLT4
IFC120    LDDL   T6          CHECK FOR NO FAULT SYMPTOM CODE             IOUFLT4
          ADDL   T7                                                      IOUFLT4
          NJN    IFC130      IF FAULT SYMPTOM CODE                       IOUFLT4
          LDC    2RD         SET THE FAULT SYMPTOM CODE TO 77D           IOUFLT4
          UJN    IFC110                                                  IOUFLT4
                                                                         IOUFLT4
IFC130    LDDL   T6          MOVE FIRST TWO FSC CHARACTERS TO BUFFER     IOUFLT4
          STIL   T1                                                      IOUFLT4
          LDDL   T7          MOVE SECOND TWO FSC CHARACTERS TO BUFFER    IOUFLT4
          NJN    IFC134      IF LAST TWO FSC CHARACTERS ARE AVAILABLE
          LDC    2R          BLANK FILL LAST TWO FSC CHARACTERS
IFC134    STML   1,T1
          LDC    2R          BLANK FILL REMAINDER OF THE BUFFER          IOUFLT4
          STML   2,T1                                                    IOUFLT4
          STML   3,T1                                                    IOUFLT4
          STML   4,T1                                                    IOUFLT4
          STML   5,T1                                                    IOUFLT4
          STML   6,T1                                                    IOUFLT4
          STML   7,T1                                                    IOUFLT4
          LDDL   T1          SET (A) REGISTER FOR EXIT                   IOUFLT4
          LJM    IOUFLT4X     EXIT                                       IOUFLT4
                                                                         IOUFLT4
*         GENERATE THE FAULT SYMPTOM CODE DX4477B.                       IOUFLT4
                                                                         IOUFLT4
IFC140    LDC    2RB         GENERATE THE FAULT SYMPTOM CODE DX4477B     IOUFLT4
          LJM    IFC110      GO TO GENERATE THE CHARACTERS 77            IOUFLT4
                                                                         IOUFLT4
          EJECT                                                          IOUFLT4
*         CHECK FAULT STATUS 1 FOR ANY BITS SET AND IF NONE ARE SET,     IOUFLT4
*         EXIT.                                                          IOUFLT4
                                                                         IOUFLT4
IFC150    LDML   FS1BY4      CHECK FOR FAULT STATUS 1 ERROR(S)           IOUFLT4
          ADML   FS1BY6                                                  IOUFLT4
          NJN    IFC160      IF FS1 ERROR PRESENT
          LJM    IFC120      IF NO FAULT STATUS 1 ERROR                  IOUFLT4
                                                                         IOUFLT4
*         DETERMINE THE CLUSTER IN WHICH THE FAILURE WAS DETECTED. IF    IOUFLT4
*         MORE THAN ONE CLUSTER FAILED, REPORT A FAULT SYMPTOM CODE OF   IOUFLT4
*         DX4477B.                                                       IOUFLT4
                                                                         IOUFLT4
IFC160    LDML   FS1BY0      CHECK FOR CLUSTER 0 FAILURE                 IOUFLT4
          SHN    -8D                                                     IOUFLT4
          ZJN    IFC170      IF NOT CLUSTER 0 FAILURE                    IOUFLT4
          LDC    2RA         FORCE CLUSTER INDICATOR TO A                IOUFLT4
          STDL   T7                                                      IOUFLT4
IFC170    LDML   FS1BY1      CHECK FOR CLUSTER 1 FAILURE                 IOUFLT4
          LPC    0#1F                                                    IOUFLT4
          ZJN    IFC190      IF NOT CLUSTER 1 FAILURE                    IOUFLT4
          LDDL   T7          CHECK FOR MORE THAN ONE FAILING CLUSTER     IOUFLT4
IFC180    NJN    IFC140      IF MORE THAN ONE FAILING CLUSTER            IOUFLT4
          LDC    2RB         FORCE CLUSTER INDICATOR TO B                IOUFLT4
          STDL   T7                                                      IOUFLT4
IFC190    LDML   FS1BY2      CHECK FOR CLUSTER 2 FAILURE                 IOUFLT4
          SHN    -8D                                                     IOUFLT4
          ZJN    IFC200      IF NOT CLUSTER 2 FAILURE                    IOUFLT4
          LDDL   T7          CHECK FOR MORE THAN ONE FAILING CLUSTER     IOUFLT4
          NJN    IFC180      IF MORE THAN ONE FAILING CLUSTER            IOUFLT4
          LDC    2RC         FORCE CLUSTER INDICATOR TO C                IOUFLT4
          STDL   T7                                                      IOUFLT4
IFC200    LDML   FS1BY3      CHECK FOR CLUSTER 3 FAILURE                 IOUFLT4
          LPC    0#1F                                                    IOUFLT4
          ZJN    IFC210      IF NOT CLUSTER 3 FAILURE                    IOUFLT4
          LDDL   T7          CHECK FOR MORE THAN ONE FAILING CLUSTER     IOUFLT4
          NJN    IFC180      IF MORE THAN ONE FAILING CLUSTER            IOUFLT4
          LDC    2RD         FORCE CLUSTER INDICATOR TO D                IOUFLT4
          STDL   T7                                                      IOUFLT4
                                                                         IOUFLT4
*         CHECK THE FAULT STATUS 1 REGISTER FOR ERRORS.  THE FS1BTB      IOUFLT4
*         TABLE CONTAINS THE FAULT STATUS 1 BITS 32-63 THAT ARE TO BE    IOUFLT4
*         CHECKED.                                                       IOUFLT4
                                                                         IOUFLT4
IFC210    BSS    0                                                       IOUFLT4
          LDN    0           INITIALIZE THE FS1BTB TABLE INDEX           IOUFLT4
          STDL   T2                                                      IOUFLT4
IFC220    LDML   FS1BY4      GET FAULT STATUS 1 BYTES 4 AND 5            IOUFLT4
          LPML   FS1BTB,T2                                               IOUFLT4
          LMML   FS1BTB,T2   COMPARE FOR ALL SELECTED BITS SET           IOUFLT4
          NJN    IFC230      IF ALL SELECTED BITS NOT SET IN FS1         IOUFLT4
          LDML   FS1BY6      GET FAULT STATUS 1 BYTES 6 AND 7            IOUFLT4
          LPML   FS1BTB+1,T2  COMPARE FOR ALL SELECTED BITS SET          IOUFLT4
          LMML   FS1BTB+1,T2  COMPARE FOR ALL SELECTED BITS SET          IOUFLT4
          ZJN    IFC250      IF ALL SELECTED BITS SET IN FS1             IOUFLT4
                                                                         IOUFLT4
IFC230    LDN    2D          UPDATE FS1BTB TABLE INDEX                   IOUFLT4
          RADL   T2                                                      IOUFLT4
          ADC    -FS1BTBL    CHECK OF END OF FS1BTB TABLE                IOUFLT4
          MJN    IFC220      IF NOT END OF FS1BTB TABLE                  IOUFLT4
                                                                         IOUFLT4
          LDML   FS1BY4      GET FAULT STATUS 1 BYTES 4 AND 5            IOUFLT4
          ADML   FS1BY6      ADD FAULT STATUS 1 BYTES 6 AND 7            IOUFLT4
          ZJN    IFC240      IF FAULT STATUS 1 COMPLETELY PROCESSED      IOUFLT4
          LDC    2RD         SET FAULT SYMPTOM CODE TO DX4477D           IOUFLT4
          LJM    IFC110      GO TO GENERATE THE CHARACTERS 77            IOUFLT4
                                                                         IOUFLT4
IFC240    LJM    IFC120      GO TO SET FAULT SYMPTOM CODE IN BUFFER      IOUFLT4
                                                                         IOUFLT4
*         CLEAR THE FAILING BIT INDICATORS IN FAULT STATUS 1.            IOUFLT4
                                                                         IOUFLT4
IFC250    LDML   FS1BY4      GET FAULT STATUS 1 BYTES 4 AND 5            IOUFLT4
          LMML   FS1BTB,T2   CLEAR FAILING BIT INDICATORS                IOUFLT4
          STML   FS1BY4      RESET FAULT STATUS 1 BYTES 4 AND 5          IOUFLT4
          LDML   FS1BY6      GET FAULT STATUS 1 BYTES 6 AND 7            IOUFLT4
          LMML   FS1BTB+1,T2  CLEAR FAILING BIT INDICATORS               IOUFLT4
          STML   FS1BY6      RESET FAULT STATUS 1 BYTES 6 AND 7          IOUFLT4
                                                                         IOUFLT4
*         POSSIBLE FAULT STATUS 1 FAILURE HAS BEEN FOUND, CHECK FOR      IOUFLT4
*         PREVIOUS FAULT STATUS 1 DETECTED. IF A PREVIOUS FAULT WAS      IOUFLT4
*         ISOLATED, FORCE THE FAULT SYMPTOM CODE TO DX4477C.             IOUFLT4
                                                                         IOUFLT4
          LDDL   T6          CHECK FOR PREVIOUS FAULT STATUS ERROR       IOUFLT4
          ZJN    IFC260      IF NO PREVIOUS FAULT STATUS ERROR           IOUFLT4
          LDC    2RC         SET FAULT SYMPTOM CODE TO DX4477C           IOUFLT4
          LJM    IFC110      GO TO GENERATE THE CHARACTERS 77            IOUFLT4
                                                                         IOUFLT4
*         THE POSSIBLE FAULT STATUS 1 ERROR HAS BEEN FOUND, SAVE THE     IOUFLT4
*         FAULT SYMPTOM CODE FOR THE FAULT STATUS 1 REGISTER.            IOUFLT4
                                                                         IOUFLT4
IFC260    LDDL   T2          BUILD FS1FSCT TABLE INDEX                   IOUFLT4
          SHN    -1D                                                     IOUFLT4
          STDL   T4                                                      IOUFLT4
          LDML   FS1FSCT,T4  SET FS1 FAULT SYMPTOM CODE                  IOUFLT4
          STDL   T6                                                      IOUFLT4
                                                                         IOUFLT4
*         CHECK FOR FAULT SYMPTOM CODES DX4405, 17-20, AND 37.           IOUFLT4
*         IF THE FAULT SYMPTOM CODE IS ONE OF THESE CODES, RESET         IOUFLT4
*         THE CLUSTER INDICATOR TO BLANK DISPLAY CODES.                  IOUFLT4
                                                                         IOUFLT4
          ADC    -CODE05     CHECK FOR FAULT SYMPTOM CODE DX4405         IOUFLT4
          ZJN    IFC290      IF FAULT SYMPTOM CODE DX4405                IOUFLT4
          ADC    -CODE17+CODE05  CHECK FOR FAULT SYMPTOM CODE DX4417     IOUFLT4
          ZJN    IFC290      IF FAULT SYMPTOM CODE DX4417                IOUFLT4
          SBN    CODE18-CODE17  CHECK FOR FAULT SYMPTOM CODE DX4418      IOUFLT4
          ZJN    IFC290      IF FAULT SYMPTOM CODE DX4418                IOUFLT4
          SBN    CODE19-CODE18  CHECK FOR FAULT SYMPTOM CODE DX4419      IOUFLT4
          ZJN    IFC290      IF FAULT SYMPTOM CODE DX4419                IOUFLT4
          ADC    -CODE20+CODE19  CHECK FOR FAULT SYMPTOM CODE DX4420     IOUFLT4
          ZJN    IFC290      IF FAULT SYMPTOM CODE DX4420                IOUFLT4
          ADC    -CODE37+CODE20  CHECK FOR FAULT SYMPTOM CODE DX4437     IOUFLT4
          NJN    IFC300      IF NOT FAULT SYMPTOM CODE DX4437            IOUFLT4
IFC290    LDC    2R          RESET CLUSTER INDICATOR TO BLANKS           IOUFLT4
          STDL   T7                                                      IOUFLT4
          UJN    IFC330      GO TO CONTINUE FAULT STATUS 1 PROCESSING    IOUFLT4
                                                                         IOUFLT4
*         CHECK THAT LOCATION T7 DOES NOT CONTAIN ZERO.  THIS ENSURES
*         THAT THE FAULT CAN BE ISOLATED TO A FAILING CLUSTER.  IF THE
*         FAULT CANNOT BE ISOLATED TO A FAILING CLUSTER, (I.E.  T7
*         CONTAINS ZERO), FORCE THE FAULT SYMPTOM CODE TO DX4477D.

IFC300    LDDL   T7          GET FAILING CLUSTER INDICATOR
          NJN    IFC305      IF FAILING CLUSTER ISOLATED
          LDC    2RD         SET FAULT SYMPTOM CODE TO DX4477D
          LJM    IFC110      GO TO GENERATE THE CHARACTERS 77

*         CHECK FOR FAULT SYMPTOM CODES DX4422. IF THE FAULT SYMPTOM     IOUFLT4
*         CODE IS A DX4422, RESET THE CLUSTER INDICATOR X (A, B, C, D)   IOUFLT4
*         TO A X2 IF BITS 49, 50 AND 51 ARE CLEAR, TO A X0 IF EITHER     IOUFLT4
*         BIT 49 OR 50 IS SET OR TO A X1 IF BIT 51 IS SET.               IOUFLT4
                                                                         IOUFLT4
IFC305    LDDL   T6          GET FAULT SYMPTOM CODE
          ADC    -CODE22     CHECK FOR FAULT SYMPTOM CODE DX4422         IOUFLT4
          NJN    IFC340      IF NOT FAULT SYMPTOM CODE DX4422            IOUFLT4
          LDML   FS1BY6      GET FAULT STATUS 1 BYTES 6 AND 7            IOUFLT4
          LPC    FS1MSK3     CHECK IF BITS 49, OR 50, OR 51 SET          IOUFLT4
          ZJN    IFC320      IF BITS 49, 50 AND 51 CLEAR                 IOUFLT4
          LPC    BT51        CHECK FOR BIT 51 SET                        IOUFLT4
          ZJN    IFC310      IF BIT 51 IS NOT SET                        IOUFLT4
          LDN    1R1-1R0     SET CLUSTER INDICATOR TO X0                 IOUFLT4
IFC310    SBN    1R2-1R0     SET CLUSTER INDICATOR TO X1                 IOUFLT4
IFC320    ADN    1R2-1R      SET CLUSTER INDICATOR TO X2                 IOUFLT4
          RADL   T7                                                      IOUFLT4
          LDML   FS1BY6      GET FAULT STATUS 1 BYTES 6 AND 7            IOUFLT4
          LPC    -FS1MSK3    CLEAR BITS 49, 50 AND 51                    IOUFLT4
          STML   FS1BY6      SAVE UPDATED FS1, BYTES 6 AND 7             IOUFLT4
IFC330    LJM    IFC230      GO TO CONTINUE FAULT STATUS 1 PROCESSING    IOUFLT4
                                                                         IOUFLT4
*         CHECK FOR FAULT SYMPTOM CODES DX4423, DX4428, DX4430, DX4432,  IOUFLT4
*         AND DX4434. IF THE FAULT SYMPTOM CODE IS ONE OF THESE CODES,   IOUFLT4
*         RESET THE CLUSTER INDICATOR X (A, B, C, D) TO A X1 IF BITS 49  IOUFLT4
*         AND 50 ARE CLEAR OR TO A X0 IF EITHER BIT 49 OR 50 IS SET.     IOUFLT4
                                                                         IOUFLT4
IFC340    SBN    CODE23-CODE22  CHECK FOR FAULT SYMPTOM CODE DX4423      IOUFLT4
          ZJN    IFC350      IF FAULT SYMPTOM CODE DX4423                IOUFLT4
          SBN    CODE28-CODE23  CHECK FOR FAULT SYMPTOM CODE DX4428      IOUFLT4
          ZJN    IFC350      IF FAULT SYMPTOM CODE DX4428                IOUFLT4
          ADC    -CODE30+CODE28  CHECK FOR FAULT SYMPTOM CODE DX4430     IOUFLT4
          ZJN    IFC350      IF FAULT SYMPTOM CODE DX4430                IOUFLT4
          SBN    CODE32-CODE30  CHECK FOR FAULT SYMPTOM CODE DX4432      IOUFLT4
          ZJN    IFC350      IF FAULT SYMPTOM CODE DX4432                IOUFLT4
          SBN    CODE34-CODE32  CHECK FOR FAULT SYMPTOM CODE DX4434      IOUFLT4
          NJN    IFC330      IF NOT FAULT SYMPTOM CODE DX4434            IOUFLT4
IFC350    LDML   FS1BY6      GET FAULT STATUS 1 BYTES 6 AND 7            IOUFLT4
          LPC    FS1MSK2     CHECK FOR BIT 49 OR 50 SET                  IOUFLT4
          ZJN    IFC360      IF BIT 49 AND 50 IS NOT SET                 IOUFLT4
          LCN    1R1-1R0     SET CLUSTER INDICATOR TO X1                 IOUFLT4
IFC360    ADN    1R1-1R      SET CLUSTER INDICATOR TO X0                 IOUFLT4
          RADL   T7                                                      IOUFLT4
          LDML   FS1BY6      GET FAULT STATUS 1 BYTES 6 AND 7            IOUFLT4
          LPC    -FS1MSK2    CLEAR BITS 49 AND 50                        IOUFLT4
          STML   FS1BY6      SAVE UPDATED FS1, BYTES 6 AND 7             IOUFLT4
          UJN    IFC330      GO TO CONTINUE FAULT STATUS 1 PROCESSING    IOUFLT4

FSBUFR    TITLE  FAULT STATUS 1 AND 2 TEMPORARY BUFFER                   IOUFLT4
*         FAULT STATUS 1 AND 2 BUFFER.                                   IOUFLT4
                                                                         IOUFLT4
FSBUFR    BSS    0           FAULT STATUS 1 AND 2 BUFFER                 IOUFLT4
FS1BY0    BSS    0           FAULT STATUS 1, BYTE 0                      IOUFLT4
FS1BY1    BSS    0           FAULT STATUS 1, BYTE 1                      IOUFLT4
          CON    0           FAULT STATUS 1 WORD 1, BYTES 0 AND 1        IOUFLT4
                                                                         IOUFLT4
FS1BY2    BSS    0           FAULT STATUS 1, BYTE 2                      IOUFLT4
FS1BY3    BSS    0           FAULT STATUS 1, BYTE 3                      IOUFLT4
          CON    0           FAULT STATUS 1 WORD 2, BYTES 2 AND 3        IOUFLT4
                                                                         IOUFLT4
FS1BY4    BSS    0           FAULT STATUS 1, BYTE 4                      IOUFLT4
FS1BY5    BSS    0           FAULT STATUS 1, BYTE 5                      IOUFLT4
          CON    0           FAULT STATUS 1 WORD 3, BYTES 4 AND 5        IOUFLT4
                                                                         IOUFLT4
FS1BY6    BSS    0           FAULT STATUS 1, BYTE 6                      IOUFLT4
FS1BY7    BSS    0           FAULT STATUS 1, BYTE 7                      IOUFLT4
          CON    0           FAULT STATUS 1 WORD 4, BYTES 6 AND 7        IOUFLT4
                                                                         IOUFLT4
                                                                         IOUFLT4
*         FAULT STATUS 2 BYTE OFFSETS IN THE STATUS BUFFER.              IOUFLT4
                                                                         IOUFLT4
FS2BY0    BSS    0           FAULT STATUS 2, BYTE 0                      IOUFLT4
FS2BY1    BSS    0           FAULT STATUS 2, BYTE 1                      IOUFLT4
          CON    0           FAULT STATUS 2 WORD 1, BYTES 0 AND 1        IOUFLT4
                                                                         IOUFLT4
FS2BY2    BSS    0           FAULT STATUS 2, BYTE 2                      IOUFLT4
FS2BY3    BSS    0           FAULT STATUS 2, BYTE 3                      IOUFLT4
          CON    0           FAULT STATUS 2 WORD 2, BYTES 2 AND 3        IOUFLT4
                                                                         IOUFLT4
FS2BY4    BSS    0           FAULT STATUS 2, BYTE 4                      IOUFLT4
FS2BY5    BSS    0           FAULT STATUS 2, BYTE 5                      IOUFLT4
          CON    0           FAULT STATUS 2 WORD 3, BYTES 4 AND 5        IOUFLT4
                                                                         IOUFLT4
FS2BY6    BSS    0           FAULT STATUS 2, BYTE 6                      IOUFLT4
FS2BY7    BSS    0           FAULT STATUS 2, BYTE 7                      IOUFLT4
          CON    0           FAULT STATUS 2 WORD 4, BYTES 6 AND 7        IOUFLT4
FS1BTB    TITLE  FAULT STATUS 1 BIT TABLE FOR FAULT SYMPTOM CODES        IOUFLT4
FS1BTB    BSS    0                                                       IOUFLT4
          BITS   BT32+BT44,0  FAULT SYMPTOM CODE EQUALS 01               IOUFLT4
          BITS   BT32+BT47,0  FAULT SYMPTOM CODE EQUALS 02               IOUFLT4
          BITS   BT32,0       FAULT SYMPTOM CODE EQUALS 03               IOUFLT4
          BITS   BT33,0       FAULT SYMPTOM CODE EQUALS 04               IOUFLT4
          BITS   BT34,0       FAULT SYMPTOM CODE EQUALS 05               IOUFLT4
          BITS   BT35,0       FAULT SYMPTOM CODE EQUALS 06               IOUFLT4
          BITS   BT46,0       FAULT SYMPTOM CODE EQUALS 07               IOUFLT4
          BITS   BT36,BT55    FAULT SYMPTOM CODE EQUALS 08               IOUFLT4
          BITS   BT36,0       FAULT SYMPTOM CODE EQUALS 09               IOUFLT4
          BITS   BT37,BT48    FAULT SYMPTOM CODE EQUALS 10               IOUFLT4
          BITS   BT37,BT53    FAULT SYMPTOM CODE EQUALS 11               IOUFLT4
          BITS   BT37,0       FAULT SYMPTOM CODE EQUALS 12               IOUFLT4
          BITS   BT38,BT54    FAULT SYMPTOM CODE EQUALS 13               IOUFLT4
          BITS   BT38,BT55    FAULT SYMPTOM CODE EQUALS 14               IOUFLT4
          BITS   BT38,BT56    FAULT SYMPTOM CODE EQUALS 15               IOUFLT4
          BITS   BT39,BT52    FAULT SYMPTOM CODE EQUALS 16               IOUFLT4
          BITS   BT40,0       FAULT SYMPTOM CODE EQUALS 17               IOUFLT4
          BITS   BT41,0       FAULT SYMPTOM CODE EQUALS 18               IOUFLT4
          BITS   BT42,0       FAULT SYMPTOM CODE EQUALS 19               IOUFLT4
          BITS   BT43,0       FAULT SYMPTOM CODE EQUALS 20               IOUFLT4
          BITS   0,BT48+BT57  FAULT SYMPTOM CODE EQUALS 21               IOUFLT4
          BITS   0,BT55+BT57  FAULT SYMPTOM CODE EQUALS 22               IOUFLT4
          BITS   0,BT55+BT58  FAULT SYMPTOM CODE EQUALS 23               IOUFLT4
          BITS   0,BT53+BT59  FAULT SYMPTOM CODE EQUALS 24               IOUFLT4
          BITS   0,BT56+BT59  FAULT SYMPTOM CODE EQUALS 25               IOUFLT4
          BITS   0,BT59       FAULT SYMPTOM CODE EQUALS 26               IOUFLT4
          BITS   0,BT52+BT60  FAULT SYMPTOM CODE EQUALS 27               IOUFLT4
          BITS   0,BT54+BT60  FAULT SYMPTOM CODE EQUALS 28               IOUFLT4
          BITS   0,BT52+BT61  FAULT SYMPTOM CODE EQUALS 29               IOUFLT4
          BITS   0,BT54+BT61  FAULT SYMPTOM CODE EQUALS 30               IOUFLT4
          BITS   0,BT52+BT62  FAULT SYMPTOM CODE EQUALS 31               IOUFLT4
          BITS   0,BT54+BT62  FAULT SYMPTOM CODE EQUALS 32               IOUFLT4
          BITS   0,BT52+BT63  FAULT SYMPTOM CODE EQUALS 33               IOUFLT4
          BITS   0,BT54+BT63  FAULT SYMPTOM CODE EQUALS 34               IOUFLT4
          BITS   BT44,0       FAULT SYMPTOM CODE EQUALS 35               IOUFLT4
          BITS   BT45,0       FAULT SYMPTOM CODE EQUALS 36               IOUFLT4
          BITS   0,BT49       FAULT SYMPTOM CODE EQUALS 37               IOUFLT4
          BITS   0,BT50       FAULT SYMPTOM CODE EQUALS 37
          BITS   0,BT51       FAULT SYMPTOM CODE EQUALS 37
          BITS   0,BT63       FAULT SYMPTOM CODE EQUALS 38
          BITS   0,BT62       FAULT SYMPTOM CODE EQUALS 39
          BITS   0,BT61       FAULT SYMPTOM CODE EQUALS 40
          BITS   0,BT60       FAULT SYMPTOM CODE EQUALS 41
          BITS   0,BT58       FAULT SYMPTOM CODE EQUALS 42
          BITS   0,BT57       FAULT SYMPTOM CODE EQUALS 43
          BITS   BT39,0       FAULT SYMPTOM CODE EQUALS 44
          BITS   BT38,0       FAULT SYMPTOM CODE EQUALS 45
          BITS   BT47,0       FAULT SYMPTOM CODE EQUALS 46
          BITS   0,BT48       FAULT SYMPTOM CODE EQUALS 47
          BITS   0,BT52       FAULT SYMPTOM CODE EQUALS 48
          BITS   0,BT53       FAULT SYMPTOM CODE EQUALS 49
          BITS   0,BT54       FAULT SYMPTOM CODE EQUALS 60
          BITS   0,BT55       FAULT SYMPTOM CODE EQUALS 61
          BITS   0,BT56       FAULT SYMPTOM CODE EQUALS 62
FS1BTBL   EQU    *-FS1BTB     LENGTH OF THE FAULT STATUS TABLE           IOUFLT4
FS1FSCT   TITLE  FAULT STATUS 1 FAULT SYMPTOM CODES                      IOUFLT4
*         FAULT STATUS 1 FAULT SYMPTOM CODES TABLE.                      IOUFLT4
                                                                         IOUFLT4
FS1FSCT   BSS    0                                                       IOUFLT4
          DATA   H*01*       FAULT SYMPTOM CODE FOR BITS 32 AND 44       IOUFLT4
          DATA   H*02*       FAULT SYMPTOM CODE FOR BITS 32 AND 47       IOUFLT4
          DATA   H*03*       FAULT SYMPTOM CODE FOR BIT 32               IOUFLT4
          DATA   H*04*       FAULT SYMPTOM CODE FOR BIT 33               IOUFLT4
          DATA   H*05*       FAULT SYMPTOM CODE FOR BIT 34               IOUFLT4
          DATA   H*06*       FAULT SYMPTOM CODE FOR BIT 35               IOUFLT4
          DATA   H*07*       FAULT SYMPTOM CODE FOR BIT 46               IOUFLT4
          DATA   H*08*       FAULT SYMPTOM CODE FOR BITS 36 AND 55       IOUFLT4
          DATA   H*09*       FAULT SYMPTOM CODE FOR BIT 36               IOUFLT4
          DATA   H*10*       FAULT SYMPTOM CODE FOR BITS 37 AND 48       IOUFLT4
          DATA   H*11*       FAULT SYMPTOM CODE FOR BITS 37 AND 53       IOUFLT4
          DATA   H*12*       FAULT SYMPTOM CODE FOR BIT 37               IOUFLT4
          DATA   H*13*       FAULT SYMPTOM CODE FOR BITS 38 AND 54       IOUFLT4
          DATA   H*14*       FAULT SYMPTOM CODE FOR BITS 38 AND 55       IOUFLT4
          DATA   H*15*       FAULT SYMPTOM CODE FOR BITS 38 AND 56       IOUFLT4
          DATA   H*16*       FAULT SYMPTOM CODE FOR BITS 39 AND 52       IOUFLT4
          DATA   H*17*       FAULT SYMPTOM CODE FOR BIT 40               IOUFLT4
          DATA   H*18*       FAULT SYMPTOM CODE FOR BIT 41               IOUFLT4
          DATA   H*19*       FAULT SYMPTOM CODE FOR BIT 42               IOUFLT4
          DATA   H*20*       FAULT SYMPTOM CODE FOR BIT 43               IOUFLT4
          DATA   H*21*       FAULT SYMPTOM CODE FOR BITS 48 AND 57       IOUFLT4
          DATA   H*22*       FAULT SYMPTOM CODE FOR BITS 55 AND 57       IOUFLT4
          DATA   H*23*       FAULT SYMPTOM CODE FOR BITS 55 AND 58       IOUFLT4
          DATA   H*24*       FAULT SYMPTOM CODE FOR BITS 53 AND 59       IOUFLT4
          DATA   H*25*       FAULT SYMPTOM CODE FOR BITS 56 AND 59       IOUFLT4
          DATA   H*26*       FAULT SYMPTOM CODE FOR BIT 59               IOUFLT4
          DATA   H*27*       FAULT SYMPTOM CODE FOR BITS 52 AND 60       IOUFLT4
          DATA   H*28*       FAULT SYMPTOM CODE FOR BITS 54 AND 60       IOUFLT4
          DATA   H*29*       FAULT SYMPTOM CODE FOR BITS 52 AND 61       IOUFLT4
          DATA   H*30*       FAULT SYMPTOM CODE FOR BITS 54 AND 61       IOUFLT4
          DATA   H*31*       FAULT SYMPTOM CODE FOR BITS 52 AND 62       IOUFLT4
          DATA   H*32*       FAULT SYMPTOM CODE FOR BITS 54 AND 62       IOUFLT4
          DATA   H*33*       FAULT SYMPTOM CODE FOR BITS 52 AND 63       IOUFLT4
          DATA   H*34*       FAULT SYMPTOM CODE FOR BITS 54 AND 63       IOUFLT4
          DATA   H*35*       FAULT SYMPTOM CODE FOR BIT 44               IOUFLT4
          DATA   H*36*       FAULT SYMPTOM CODE FOR BIT 45               IOUFLT4
          DATA   H*37*       FAULT SYMPTOM CODE FOR BIT 49               IOUFLT4
          DATA   H*37*       FAULT SYMPTOM CODE FOR BIT 50
          DATA   H*37*       FAULT SYMPTOM CODE FOR BIT 51
          DATA   H*38*       FAULT SYMPTOM CODE FOR BIT 63
          DATA   H*39*       FAULT SYMPTOM CODE FOR BIT 62
          DATA   H*40*       FAULT SYMPTOM CODE FOR BIT 61
          DATA   H*41*       FAULT SYMPTOM CODE FOR BIT 60
          DATA   H*42*       FAULT SYMPTOM CODE FOR BIT 58
          DATA   H*43*       FAULT SYMPTOM CODE FOR BIT 57
          DATA   H*44*       FAULT SYMPTOM CODE FOR BIT 39
          DATA   H*45*       FAULT SYMPTOM CODE FOR BIT 38
          DATA   H*46*       FAULT SYMPTOM CODE FOR BIT 47
          DATA   H*47*       FAULT SYMPTOM CODE FOR BIT 48
          DATA   H*48*       FAULT SYMPTOM CODE FOR BIT 52
          DATA   H*49*       FAULT SYMPTOM CODE FOR BIT 53
          DATA   H*60*       FAULT SYMPTOM CODE FOR BIT 54
          DATA   H*61*       FAULT SYMPTOM CODE FOR BIT 55
          DATA   H*62*       FAULT SYMPTOM CODE FOR BIT 56
FS2FSCT   TITLE  FAULT STATUS 2 FAULT SYMPTOM CODES                      IOUFLT4
*         FAULT STATUS 2 FAULT SYMPTOM CODES TABLE.                      IOUFLT4
                                                                         IOUFLT4
FS2FSCT   BSS    0                                                       IOUFLT4
          DATA   H*7707*     CHANNEL EQUALS 07                           IOUFLT4
          DATA   H*7706*     CHANNEL EQUALS 06                           IOUFLT4
          DATA   H*7705*     CHANNEL EQUALS 05                           IOUFLT4
          DATA   H*7704*     CHANNEL EQUALS 04                           IOUFLT4
          DATA   H*7703*     CHANNEL EQUALS 03                           IOUFLT4
          DATA   H*7702*     CHANNEL EQUALS 02                           IOUFLT4
          DATA   H*50  *     CHANNEL EQUALS 01                           IOUFLT4
          DATA   H*50  *     CHANNEL EQUALS 00                           IOUFLT4
          DATA   H*51  *     CHANNEL EQUALS 17                           IOUFLT4
          DATA   H*0   *     NOT AVAILABLE                               IOUFLT4
          DATA   H*52  *     CHANNEL EQUALS 15                           IOUFLT4
          DATA   H*0   *     NOT AVAILABLE                               IOUFLT4
          DATA   H*53  *     CHANNEL EQUALS 13                           IOUFLT4
          DATA   H*53  *     CHANNEL EQUALS 12                           IOUFLT4
          DATA   H*7711*     CHANNEL EQUALS 11                           IOUFLT4
          DATA   H*7710*     CHANNEL EQUALS 10                           IOUFLT4
          DATA   H*7727*     CHANNEL EQUALS 27                           IOUFLT4
          DATA   H*7726*     CHANNEL EQUALS 26                           IOUFLT4
          DATA   H*7725*     CHANNEL EQUALS 25                           IOUFLT4
          DATA   H*7724*     CHANNEL EQUALS 24                           IOUFLT4
          DATA   H*7723*     CHANNEL EQUALS 23                           IOUFLT4
          DATA   H*7722*     CHANNEL EQUALS 22                           IOUFLT4
          DATA   H*7721*     CHANNEL EQUALS 21                           IOUFLT4
          DATA   H*7720*     CHANNEL EQUALS 20                           IOUFLT4
          DATA   H*54  *     MAC ERROR                                   IOUFLT4
          DATA   H*0   *     NOT AVAILABLE                               IOUFLT4
          DATA   H*0   *     NOT USED                                    IOUFLT4
          DATA   H*55  *     RADIAL INTERFACE 1/2/3 ERROR                IOUFLT4
          DATA   H*0   *     CHANNEL EQUALS 33                           IOUFLT4
          DATA   H*0   *     CHANNEL EQUALS 32                           IOUFLT4
          DATA   H*7731*     CHANNEL EQUALS 31                           IOUFLT4
          DATA   H*7730*     CHANNEL EQUALS 30                           IOUFLT4
          QUAL   *                                                       IOUFLT4
*         END    CTP$DFT MODEL 44 OIU FSC.
*DECK DECK=CTP$DFT_NON_930_RESIDENT_II EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_NON_930_RESIDENT_II
*         IF HCM$ IS DEFINED ALL CPUS WILL BE HALTED BEFORE A MEMORY WRITE IS
*         PERFORMED.
 TIM      SPACE  4,10
**        TIM - MAINTAIN MILLISECOND TIME AND EXECUTE TIMED ROUTINES.
*
*         *TIM* USES THE CHANNEL 14 CLOCK TO ALLOW THE EXECUTION OF
*         CERTAIN ROUTINES ON A TIMED BASIS.  THE ROUTINES TO BE
*         ACTIVATED PERIODICALLY ARE IN *ACTB*.  TO ENSURE ACCURACY,
*         *TIM* SHOULD BE CALLED AT LEAST EVERY TWO MILLISECONDS.
*         *TIMA* SHOULD BE INITIALIZED BEFORE THE FIRST CALL TO *TIM*.
*
*         EXIT   (TIMA) IS WITHIN ONE MILLISECOND OF CHANNEL 14 VALUE.
*
*         USES   T1, T7.
*
*         CALLS  SEE *ACTB*.
*
*         NOTE   CHANGES TO THIS ROUTINE SHOULD BE MADE IN *SCI* ALSO.


 TIM      SUBR               ENTRY/EXIT
 TIM1     IAN    14          READ MICROSECOND COUNTER
 TIMC     SBM    TIMA
          PJN    TIM2        IF NO OVERFLOW
 TIMD     ADC    10000       COMPENSATE FOR CLOCK OVERFLOW
 TIM2     ADC    -1000D
          MJN    TIMX        IF LESS THAN ONE MILLISECOND ELAPSED
          LDC    1000D       ADVANCE BASE TIME BY ONE MILLISECOND
 TIME     RAM    TIMA
          AOM    TIMB        ADVANCE SCAN COUNTER
          LMN    5
          NJN    TIM1        IF SCAN PERIOD NOT UP
          STM    TIMB        RESET SCAN COUNTER
          LDC    ACTB        PRESET ACTION ENTRY
          STD    T7
          STM    TIMF
 TIM3     AOM    2,T7        ADVANCE ENTRY COUNTER
          SBM    1,T7
          MJN    TIM4        IF DELAY NOT COMPLETE
          LDN    0
          STM    2,T7        RESET COUNTER
          LDI    T7          CALL SPECIFIED ROUTINE
          STD    T1
          RJM    0,T1
 TIM4     LDN    3           ADVANCE TABLE INDEX
          RAM    TIMF
          STD    T7
          LMC    ACTBL
          NJN    TIM3        IF MORE ENTRIES TO CHECK
          LJM    TIM1        RETURN

 TIMF     BSS    1           FWA OF ENTRY BEING PROCESSED
 CMP      SPACE  4,10
**        CMP - CHECK MEMORY PORT.
*
*         ENTRY  (RDATA) = MEMORY *EC* REGISTER.
*                (HBUF) = PROCESSOR INFORMATION.
*
*         EXIT   (A) = 0, IF CPU MEMORY PORT ENABLED.
*                    > 0, IF CPU MEMORY PORT DISABLED.


 CMP      SUBR               ENTRY/EXIT
          LDC    SHNI+4+3    GENERATE SHIFT INSTRUCTION
          SBM    HBUF+CPRPORT
          STM    CMPB
          LDN    1
 CMPB     SHN    4+**
          STM    CMPC
          LDM    RDATA,PO
          LPC    **          EXTRACT CPU PORT DISABLE BIT
 CMPC     EQU    *-1
          UJN    CMPX        RETURN
 DBC      SPACE  4,10                                                                                                              *
**        DBC - DISABLE BOUNDS CHECKING.
*
*         ENTRY  MEMORY BOUNDS ENABLED ON CERTAIN PORTS.
*
*         EXIT   MEMORY BOUNDS CHECKING DISABLED ON ALL PORTS.
*                (MBPS) = SAVED PORT SELECT VALUE.
*
*         MACROS LOCKMR, READMR, WRITMR.


 DBC      SUBR               ENTRY/EXIT
          IF     DEF,HCM$
          RJM    HAC         HALT ALL CPUS
          ENDIF
          LOCKMR SET
          READMR RDATA,CMCC,MBRG
          LDM    RDATA
          STM    MBPS        SAVE PORT SELECT
          LDN    0
          STM    RDATA       DISABLE ALL PORTS
          WRITMR RDATA,CMCC,MBRG
 DBC0     LOCKMR CLEAR
          IF     DEF,HCM$
          LDN    0
          RJM    SAC         START ALL CPUS
          ENDIF
          LJM    DBCX        RETURN
 EBC      SPACE  4,10
**        EBC - ENABLE BOUNDS CHECKING
*
*         ENTRY  MEMORY BOUNDS DISABLED.
*                (MBPS) = SAVED PORT SELECT.
*
*         EXIT   MEMORY BOUNDS RESTORED TO PREVIOUS VALUE.
*
*         MACROS LOCKMR, READMR, WRITMR.


 EBC      SUBR               ENTRY/EXIT
          IF     DEF,HCM$
          RJM    HAC         HALT ALL CPUS
          ENDIF
          LOCKMR SET
          READMR RDATA,CMCC,MBRG
          LDM    MBPS
          STM    RDATA       RESTORE PORT SELECT
          WRITMR RDATA,CMCC,MBRG
 EBC0     LOCKMR CLEAR
          IF     DEF,HCM$
          LDN    0
          RJM    SAC         START ALL CPUS
          ENDIF
          LJM    EBCX        RETURN

*         END    CTP$DFT_NON_930_RESIDENT_II
*DECK DECK=CTP$DFT_NO_CLEAR_PACKETS EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT NO CLEAR PACKETS.
*
*         COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
*
*         THIS DECK CONTAINS PRESET CODE FOR PACKET PROCESSING.
 ICP      SPACE  4,10
**        ICP - ISSUE CLEAR PACKETS REQUEST.
*
*         NOTE   THIS ROUTINE IS INOPERATIVE.


 ICP      SUBR               ENTRY/EXIT
          UJN    ICPX        RETURN

*         ENDX   CTP$DFT NO CLEAR PACKETS.
*DECK DECK=CTP$DFT_NO_RESET_PIT EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT NO RESET PIT.
*
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 RPT      SPACE  4,10
**        RPT - RESET PIT.
*
*         NOTE   THIS DECK IS INOPERATIVE.


 RPT      SUBR               ENTRY/EXIT
          UJN    RPTX        RETURN

*         ENDX   CTP$DFT NO RESET PIT.
*DECK DECK=CTP$DFT_NO_TEST_DLD_PATH EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT NO TEST DLD PATH.
*
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 TPD      SPACE  4,10
**        TPD - TEST PATH TO THE DEDICATED LOAD DEVICE.
*
*         NOTE   THIS DECK IS INOPERATIVE.


          ROUTINE  TPD

          LJM    TPDX        RETURN

*         ENDX   CTP$DFT NO TEST DLD PATH.

*DECK DECK=CTP$DFT_OS_REQUESTS EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_OS_REQUESTS
*
*         THIS DECK CONTAINS PROCESSORS FOR OPERATING SYSTEM REQUESTS.
 FPI      SPACE  4,10
**        FPI - FETCH PROCESSOR INFORMATION.
*
*         ENTRY  (VE REQUEST+4) = CPU NUMBER OR 10 FOR FIRST ACTIVE CPU.
*
*         CALLS  FHE, LRP, *ERR*.


          ROUTINE FPI

          RJM    LRP         LOAD REQUEST POINTER
          ADN    1
          CRDL   W4
          LDD    W4          GET CP PARAMETER
          LPN    7           ISOLATE CPU NUMBER
          STD    CP
 FPI1     SHN    14
          ADN    PROCID
          RJM    FHE         FETCH HARDWARE INFORMATION
          MJP    ERR         IF NO MORE CPUS
          LDM    HBUF+CPRSTAT+PSCPOFF
          LPC    1001
          ZJP    FPIX        IF CPU IS ON
          LDD    W4
          LPN    10
          NJN    FPI2        IF LOOKING FOR FIRST ACTIVE CPU
          UJP    ERR         ELSE SPECIFIC CPU NOT FOUND

 FPI2     AOD    CP
          UJN    FPI1        CHECK NEXT CPU
 FHD      SPACE  4,10
**        FHD - FIND HARDWARE DATA.
*
*         CALLS  FHE, LRP, *ERR*.


          ROUTINE FHD        ENTRY/EXIT

          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0          FETCH REQUEST PARAMETERS
          LDDL   W1          FETCH REQUESTED HARDWARE INFORMATION
          LPC    0#FF        PEEL OFF THE KIND OF ELEMENT
          STD    W0
          LMDL   W1
          SHN    14-10       POSITION THE NUMBER OF THE ELEMENT
          ADD    W0
          RJM    FHE         FIND HARDWARE ELEMENT
          MJP    ERR         IF NOT FOUND
          LDML   HBUF        CALCULATE WORD COUNT OF DATA IN HBUF
          SHN    -6
          ADN    3
          SHN    -2
          STD    T2
          RJM    LRP         LOAD REQUEST POINTER
          ADN    1
          CWML   HBUF,T2     WRITE HBUF TO BUFFER
          LJM    FHDX        RETURN
 FCD      SPACE  4,10
**        FCD - LOAD CIP DATA TO MEMORY.
*
*         CALLS  LRP, PFC, SPB, *ERR*.


          ROUTINE FCD

          RJM    LRP
          CRDL   W4
          LDN    24B
          STML   RTP1        SAVE FUNCTION CODE
          ADC    0#1000
          STML   CALB        WRITE FLAG AND *2AP* FUNCTION CODE
          LDD    W6
          STM    CALB+3      R-UPPER
          LDD    W7
          STM    CALB+4      R-LOWER
          LDD    W5
          STM    CALB+5      A-OFFSET
          LRD    W6
          RJM    SPB         SET PP BOUNDARY
          RJM    LRP
          ADN    1
          CRDL   W4
          LDD    W4
          STM    CALB+1      UPPER 12 BITS OF NAME
          LDD    W5
          STM    CALB+2      LOWER 12 BITS OF NAME
          CALL   PFC         SAVE NEEDED INFO AND CALL *2AP* OVERLAY
          LDM    CALB
          ADM    CALB+1
          ADM    CALB+2
          ZJN    FCD1        IF REQUEST HAD NO ERROR(S)
          LDN    0           NO RETURN / DO NOT SET STATUS / NO OFFSET
          STML   RTP2
          CALL   PDE         PROCESS DISK ERROR

 FCD1     LDM    CALB+3      R-UPPER RETURNED
          STD    W5
          LDM    CALB+4      R-LOWER RETURNED
          STD    W6
          LDM    CALB+5      A-OFFSET RETURNED
          STD    W4
          LRD    JT+1
          RJM    SPB         SET PP BOUNDARY
          RJM    LRP
          ADN    2
          CWDL   W4          RETURN LWA+1 OF MEMORY AREA JUST WRITTEN
          LJM    FCDX        RETURN
 ADS      SPACE  4,10
**        ADS - ACCESS DEADSTART SECTOR.
*
*         CALLS  LRP, PFC, *ERR*.


          ROUTINE ADS

          RJM    LRP
          ADN    1
          CRDL   W0          GET PARAMETERS FOR *2AP*
          LDN    30B         FUNCTION FOR READ DEADSTART SECTOR
          STM    CALB
          LDD    W0          DEVICE TYPE
          SHN    6
          LMD    W1          DEVICE TYPE AND CHANNEL
          STM    CALB+1
          LDD    W2
          STM    CALB+2
          LDD    W3          GET WHETHER TO WRITE OR READ
          ZJP    ADS1        IF READ THE SECTOR
          LDC    130B        FUNCTION TO WRITE THE SECTOR
          STM    CALB
          RJM    LRP
          CRDL   W4          GET POINTER TO DATA
          LDC    500/4
          STD    W4
          LRD    W6          GET R-REGISTER
          LDML   TINB        *2AP* INPUT BUFFER
          STML   ADSA
          LDD    W5          GET A OFFSET
          ADC    RR
          CRML   **,W4       READ TO *2AP* BUFFER
 ADSA     EQU    *-1
          CALL   PFC         PRESERVE DATA AND CALL *2AP*
          LDM    CALB
          ADM    CALB+1
          ADM    CALB+2
          NJP    ERR         IF ERRORS ON CALL
          LJM    ADSX        RETURN

 ADS1     CALL   PFC         PRESERVE DATA AND CALL *2AP*
          LDM    CALB
          ADM    CALB+1
          ADM    CALB+2
          NJP    ERR         IF ERROR ON FUNCTION
          RJM    LRP
          CRDL   W4          GET POINTER FOR DATA PLACEMENT
          LDC    500/4       CM SIZE OF A SECTOR
          STD    W4
          LRD    W6
          RJM    SPB         SET PP BOUNDARY
          LDML   TOUB        *2AP* OUTPUT BUFFER WITH LINKAGE BYTES
          STML   ADSB
          LDD    W5
          ADC    RR
          CWML   **,W4       WRITE SECTOR TO MEMORY
 ADSB     EQU    *-1
          LJM    ADSX        RETURN
 GCS      SPACE  4,20
**        GCS - GET NIO CHANNEL STATUS.
*
*         ENTRY  (JT - JT+3) = DFT REQUEST POINTER IN R POINTER FORMAT.
*                DFT REQUEST FORMAT:
*                  WORD 0 = 8/RESPONSE.
*                           8/DFT FUNCTION.
*                           8/IOU NUMBER.
*                           8/CHANNEL NUMBER.
*                           32/0.
*                  WORD 1 = POINTER FOR CHANNEL STATUS, R POINTER
*                           FORMAT.
*
*         EXIT   CHANNEL STATUS DATA AVAILABLE AT R POINTER ADDRESS.
*                  60/0.
*                  1/CHANNEL ACTIVE.
*                  1/CHANNEL FULL.
*                  1/CHANNEL FLAG SET.
*                  1/CHANNEL ERROR FLAG SET.
*
*         USES   T1, W0 - W7.
*
*         CALLS  LRP, SPB.


          ROUTINE GCS

          LDN    2           READ REQUEST WORDS
          STD    T1
          RJM    LRP
          CRML   W0,T1
          LDD    W7          VERIFY R-POINTER LENGTH
          SBN    1
          MJP    ERR         IF R-POINTER LENGTH EQUALS 0
          LDD    W1          GET CHANNEL NUMBER
          LPC    377
          STD    T1
          RAM    GCSA        PLUG CHANNEL INSTRUCTIONS
          LDD    T1
          RAML   GCSB
          LDD    T1
          RAM    GCSC
          LDD    T1
          RAM    GCSD
          CFM    GCS10,0     IF CHANNEL ERROR FLAG NOT SET
 GCSA     EQU    *-2
          AOM    GCSE+3      SET CHANNEL ERROR FLAG BIT
 GCS10    FCJM   GCS20,0     IF CHANNEL FLAG NOT SET
 GCSB     EQU    *-2
          LDN    2           SET CHANNEL FLAG BIT
          RAM    GCSE+3
 GCS20    EJM    GCS30,0     IF CHANNEL EMPTY
 GCSC     EQU    *-2
          LDN    4           SET CHANNEL FULL BIT
          RAM    GCSE+3
 GCS30    IJM    GCS40,0     IF CHANNEL INACTIVE
 GCSD     EQU    *-2
          LDN    10          SET CHANNEL ACTIVE BIT
          RAM    GCSE+3

*         WRITE CHANNEL STATUS DATA.

 GCS40    LRD    W5          LOAD R REGISTER
          RJM    SPB         SET PP BOUNDARY
          LDDL   W4          OFFSET
          LMC    RR
          CWML   GCSE,ON     WRITE STATUS DATA
          LJM    GCSX        RETURN

 GCSE     BSSZ   4           CHANNEL STATUS BUFFER
 RWC      SPACE  4,10
**        RWC - READ/WRITE COMMON DISK AREA.
*
*         CALLS  LRP, PFC, SPB, *ERR*.


          ROUTINE RWC

          RJM    LRP
          ADN    1
          CRDL   W0          READ FUNCTION PARAMETERS
          RJM    LRP
          CRDL   W4          READ POINTER PARAMETER
          LDN    20B
          STM    CALB
          LDDL   W0          VALID FLAG
          SHN    12
          LMM    CALB
          STM    CALB
          LDD    W1          12/16 BIT FILE
          SHN    11
          LMM    CALB
          STM    CALB
          LDD    W2          READ ENTIRE PARTIAL PROGRAM
          SHN    10
          LMM    CALB
          STM    CALB
          LDD    W3          READ OR WRITE FLAG
          STD    T1
          SHN    6
          LMM    CALB
          STM    CALB
          RJM    LRP
          ADN    2
          CRDL   W0          READ SECOND PARAMETER WORD
          LDD    W0
          STM    CALB+1      UPPER 12 BITS OF NAME
          LDD    W1
          STM    CALB+2      LOWER 12 BITS OF NAME
          LDD    T1          WRITE BIT
          NJN    RWC1        IF WRITE TO BE PERFORMED
          CALL   PFC
          RJM    LRP
          ADN    2
          CRDL   W4          READ SPECIAL CASE FOR CEL
          LDD    W7
          NJP    RWC2        IGNORE VALID CHECK IF CEL SECTOR
          LDM    CALB+1
          SHN    21-12       GET V BIT
          MJP    RWC2        IF DATA IS VALID
          LJM    ERR         PROCESS ERROR

*         WRITE DATA TO CDA.

 RWC1     LDD    W2
          STM    CALB+3      SAVE PP WORD COUNT
          SHN    -2
          STD    W2          CM WORD COUNT FOR READ
          LRD    W6
          LDML   TOUB        *2AP* OUTPUT BUFFER OFFSET FOR LINKAGE BYTES
          STML   RWCA
          LDD    W5
          ADC    RR
          CRML   **,W2       READ IN DATA TO BE WRITTEN
 RWCA     EQU    *-1
          CALL   PFC
          LDM    CALB
          ADM    CALB+1
          ADM    CALB+2
          NJP    ERR         IF ERRORS ON FUNCTION CALL
          LJM    RWCX        RETURN

*         READ DATA FROM CDA.

 RWC2     LDM    CALB+1
          LPC    0#3FF       SAVE WORD COUNT
          SHN    -2          CM WORD COUNT
          STD    T5
          RJM    LRP
          CRDL   W4          RE ESTABLISH PARAMETERS
          LRD    W6          POINTER
          RJM    SPB         SET PP BOUNDARY
          LDML   TOUB        *2AP* OUTPUT BUFFER
          STML   RWCB
          LDD    W5
          ADC    RR
          CWML   **,T5       WRITE DATA TO CENTRAL MEMORY
 RWCB     EQU    *-1
          LJM    RWCX        RETURN
 UFC      SPACE  4,10
**        UFC - UPDATE FREE RUNNING COUNTER FOR OPERATING SYSTEM.
*
*         ENTRY  FREE RUNNING COUNTER PARAMETER IN REQUEST.
*
*         EXIT   FREE RUNNING COUNTER UPDATED.
*                DISK ENTRY FOR CLOCK MRT ENTRY UPDATED.
*
*         USES   *UCDA*, T1, T2.
*
*         CALLS  FHE, LRP, RCD, RPK, UPR, *ERR*, *UCD*.


          ROUTINE UFC

          RJM    RCD         READ CLOCK DESCRIPTOR INTO *2AP* INPUT BUFFER
          LDN    1           NUMBER OF PARAMETERS
          STD    T1
          RJM    LRP         GET PARAMETER POINTER
          CRML   UDTA,T1
          LDN    0
          STML   UDTA        ZERO OUT TASKID PORTION LEAVING ONLY *FRC* VALUE

*         MOVE VALUE TO *RDATA* THEN UNPACK IT AND WRITE REGISTER(S).

          LDN    3
          STD    T1
 UFC2     LDML   UDTA,T1
          STML   MRVAL,T1
          SOD    T1
          PJN    UFC2        IF MORE TO MOVE
          IF     DEF,HCM$
          RJM    HAC         HALT ALL CPUS
          ENDIF
          RJM    UPR         UNPACK REGISTER DATA WILL BE IN *RDATA*
          WRITMR RDATA,CMCC,MFRC  WRITE FREE RUNNING COUNTER REGISTER
          IF     DEF,HCM$
          LDN    0
          RJM    SAC
          ENDIF
          LDN    7
          STD    T2          *TOIP* OFFSET FOR *FRC* VALUE
          RJM    RPK         REPACKAGE INTO 12-BIT FORMAT
          LDN    1
          STM    UWCC        DONT WANT TO UPDATE WALL CLOCK CHIP
          CALL   UCD         UDATE CLOCK INFO
          LDN    0
          STM    UWCC        RESET FLAG
          LJM    UFCX        RETURN
 UDT      SPACE  4,10
**        UDT - UPDATE TIME FOR OPERATING SYSTEM.
*
*         CALLS  FHE, LRP, RCD, RPK, *ERR*, *UCD*.


          ROUTINE UDT

          LDML   TINB        *2AP* INPUT BUFFER
          STML   UDTB        PLUG BUFFER ADDRESSES
          STML   UDTC
          STML   UDTD
          RJM    RCD         READ CLOCK DESCRIPTOR INTO *2AP* INPUT BUFFER
          LDN    2           WORDS IN REQUEST
          STD    T1
          RJM    LRP
          CRML   UDTA,T1     READ PARAMETERS INTO *2AP* BUFFER
          LDM    HBUF+WCCHDR
          STM    **          OVERWRITE TASKID IN *2AP* BUFFER
 UDTB     EQU    *-1

*         REFORMAT 16 BIT DATA PER PP WORD TO 8 BIT DATA.

          LDN    1
          STD    T2          INDEX TO STORE TO
          LDN    1
          STD    T1          INDEX TO GET FROM
 UDT1     LDML   UDTA,T1
          SHN    -10
          STM    **,T2       STORE UPPER 8 BITS FIRST
 UDTC     EQU    *-1
          AOD    T2
          LDML   UDTA,T1     GET LOWER PART
          LPC    0#FF        LOWER 8 BITS
          STM    **,T2
 UDTD     EQU    *-1
          AOD    T2
          AOD    T1
          SBN    4
          MJN    UDT1        IF MORE TO MOVE

*         NEXT MOVE FREE RUNNING COUNTER.

          RJM    RPK         REPACKAGE FREE RUNNING COUNTER TO 12 FORMAT
          CALL   UCD         UPDATE CLOCK INFO

*         AT THIS POINT SET BIT 55 OF D7ST WORD OF EICB TO INDICATE
*         AN OPERATOR DATE TIME UPDATE HAS OCCURRED.

          LRD    IB+1
          RJM    SPB         SET OS BOUNDS
          LDN    D7ST
          RJM    IIB
          CRDL   CM          GET D7ST WORD
          LDDL   CM
          LPC    -0#80       CLEAR BIT 55
          LMC    0#80        SET DATE TIME UPDATE FLAG
          STDL   CM
          LDN    D7ST
          RJM    IIB
          RDSL   CM          READ AND SET LOCK ON FLAG BIT
          LJM    UDTX        RETURN

 UDTA     BSSZ   10          BUFFER FOR CYBER 170 DATE/TIME TRANSLATION
 RCD      SPACE  4,10
**        RCD - READ CLOCK DESCRIPTOR.  READS THE CLOCK DESCRIPTOR AND
*                MOVES IT INTO THE *2AP* INPUT BUFFER.
*
*         ENTRY  (TINB) = ADDRESS OF *2AP* INPUT BUFFER.
*
*         EXIT   (HBUF) = ((TINB)) = THE CLOCK DESCRIPTOR AS READ FROM
*                         THE *MRT*.
*
*         CALLS  ERR, FHE.
*
*         USES   T2.
*

 RCD      SUBR               ENTRY/EXIT
          LDML   TINB        SET ADDRESS OF *2AP* INPUT BUFFER
          STML   RCDA
          LDN    WCCID
          RJM    FHE         FETCH CLOCK DESCRIPTOR
          MJP    ERR         IF CLOCK DESCRIPTOR NOT FOUND
          LDML   HBUF
          SHN    -6
          STD    T2          CLOCK DESCRIPTOR LENGTH

*         MOVE CLOCK DESCRIPTOR TO *2AP* INPUT BUFFER.

 RCD1     LDML   HBUF,T2
          STML   **,T2       MOVE TO *2AP* BUFFER
 RCDA     EQU    *-1         ** INSTRUCTION MODIFICATION **
          SOD    T2
          NJN    RCD1        IF MORE TO MOVE
          UJN    RCDX        RETURN

 RPK      SPACE  4,10
**        RPK - REPACKAGE *FRC* INTO 12 BIT FORMAT.
*
*         ENTRY  *FRC* IN *UDTA* IS IN 16 BIT FORMAT.
*                (T2) = INDEX TO *2AP* BUFFER AREA.
*
*         EXIT   16 BIT FORMAT IS CONVERTED TO 5 12 BIT PP WORDS.
*                STORED IN *TOIP* (*2AP* BUFFER).
*
*         USES   T1, T2, T3, T4, *TOIP*.


 RPK      SUBR               ENTRY/EXIT
          LDML   TINB        *2AP* INPUT BUFFER
          STML   RPKA
          STML   RPKB
          STML   RPKC        PLUG BUFFER REFERENCES
          STML   RPKD
          STML   RPKE
          STML   RPKF
          STML   RPKG
          STML   RPKH
          STML   RPKI
          LDN    4
          STD    T1
          LDML   UDTA,T1     *FRC* PARCEL 1 NEEDS NO CONVERSION
          STM    **,T2
 RPKA     EQU    *-1
          AOD    T2
          AOD    T1
          LDML   UDTA,T1     GET 16 BIT SECOND PARCEL
          LPN    0#F
          STD    T3

          LDML   UDTA,T1
          SHN    -4
          STM    **,T2       SECOND WORD OF 12 BITS
 RPKB     EQU    *-1
          AOD    T2
          AOD    T1
          LDML   UDTA,T1
          LPC    0#FF
          STD    T4          SAVE FRACTION FOR NEXT WORD
          LDML   UDTA,T1
          SHN    -10
          STM    **,T2
 RPKC     EQU    *-1
          LDD    T3          GET PREVIOUS FRACTIONAL WORD
          SHN    10
          LMM    **,T2
 RPKD     EQU    *-1
          STM    **,T2       SAVE THIRD WORD OF 12 BITS
 RPKE     EQU    *-1
          AOD    T2
          AOD    T1
          LDML   UDTA,T1     GET 16 BIT PARCEL 4
          LPC    0#FFF
          STD    T3
          LDML   UDTA,T1
          SHN    -14
          STM    **,T2
 RPKF     EQU    *-1
          LDD    T4          GET PREVIOUS FRACTION
          SHN    4
          LMM    **,T2
 RPKG     EQU    *-1
          STM    **,T2       SAVE FOURTH WORD OF 12 BITS
 RPKH     EQU    *-1
          AOD    T2
          LDD    T3          GET LAST FRACTIONAL PART
          STM    **,T2       SAVE FIFTH WORD OF 12 BITS
 RPKI     EQU    *-1
          LJM    RPKX        RETURN
 THR      SPACE  4,10
**        THR - UPDATE THRESHOLD VALUES FOR ERRORS.
*
*         CALLS  FHE, IDA, LRP, SPB, *ERR*.


          ROUTINE THR

          LDN    VER4
          RJM    VCK         CHECK VERSION
          PJP    THRX        IF VERSION 4 OR GREATER EXIT
          LDN    0
          STD    T7          INDEX TO PARAMETER WORDS
 THR1     RJM    LRP         SET UP TO READ PARAMETERS
          ADD    T7          PARAMETER WORD (I)
          CRDL   W0          GET THRESHOLD PARAMETER WORD
          LDD    W1
          LPN    1           CHECK IF VALID
          ZJP    THRX        IF NOT VALID ENTRY MUST BE AT END
          LDDL   W2          GET ELEMENT TYPE AND INDEX
          SHN    -10
          STDL   T1          SAVE ELEMENT TYPE
          LDDL   W2
          LPC    0#FF        ISOLATE ELEMENT INDEX
          SHN    14          POSITION ELEMENT INDEX
          LMDL   T1
          RJM    FHE         FIND HARDWARE ELEMENT
          MJP    ERR         IF NON-EXISTENT
          STD    T6          SAVE FOUND ELEMENT ORDINAL
          ADM    NUMHW
          ADM    NBUF
          RJM    IDA
          CRDL   CM          READ IN PROPER THRESHOLD ENTRY
          LDD    W1
          SHN    -1          GET TO WHICH THRESHOLDS TO UPDATE
          ZJP    ERR         IF NONE - VALID ENTRY NOTHING TO DO
          SBN    1
          ZJN    THR2        IF UNCORRECTED UPDATE
          SBN    1
          ZJN    THR3        IF CORRECTED UPDATE

*         UPDATE BOTH CORRECTED AND UNCORRECTED THRESHOLDS.

          LDDL   W3
          STDL   CM          UPDATE CORRECTED/UNCORRECTED THRESHOLDS
          UJN    THR4        UPDATE DFT BLOCK

*         UPDATE UNCORRECTED THRESHOLD ONLY.

 THR2     LDDL   CM
          LPC    0#FF00      CLEAR OLD UNCORRECTED THRESHOLD
          STDL   CM
          LDDL   W3
          LPC    0#FF        TAKE JUST NEW UNCORRECTED THRESHOLD
          LMDL   CM
          STDL   CM          UPDATE UNCORRECTED
          UJN    THR4        UPDATE DFT BLOCK

*         UPDATE CORRECTED THRESHOLD ONLY.

 THR3     LDDL   CM
          LPC    0#FF        CLEAR OLD CORRECTED
          STDL   CM
          LDDL   W3
          LPC    0#FF00      TAKE JUST NEW CORRECTED THRESHOLD
          LMDL   CM
          STDL   CM
 THR4     LRD    DP+1
          RJM    SPB         SET OS BOUNDS
          LDD    T6
          ADM    NUMHW
          ADM    NBUF
          RJM    IDA
          CWDL   CM          RE WRITE NEW ERROR THRESHOLD
          AOD    T7
          LJM    THR1        LOOP FOR NEXT REQUEST IF ANY

*         END    CTP$DFT_OS_REQUESTS
*DECK DECK=CTP$DFT_OS_REQUESTS_NON_PACKETS EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_OS_REQUESTS_NON_PACKETS
*
*         THIS DECK CONTAINS O.S. REQUESTS WHICH ARE PACKET
*         SENSITIVE AND WHICH WILL BE USED IN AN ENVIRONMENT
*         WHICH DOES NOT SUPPORT PACKETS
 UCD      SPACE  4,10
**        UCD - UPDATE CLOCK DATA.
*
*         ENTRY  (TINB) - SHOULD HAVE THE CLOCK DATA IN THE WALL CLOCK
*                         CHIP DESCRIPTOR FORMAT.
*                UWCC - UPDATE WALL CLOCK CHIP FLAG, = 0 IMPLIES WALL CLOCK
*                       CHIP UPDATED, .NE. 0 IMPLIES WALL CLOCK CHIP NOT
*                       UPDATED.
*
*         EXIT   HDT, CDA, AND THE CHIP IF PRESENT WILL ALL BE UPDATED.
*
*         CALLS  FHE, PFC, *ERR*.


          ROUTINE UCD

          LDC    132         FUNCTION TO WRITE THE HDT
          STM    CALB

*         SET CLOCK DESCRIPTOR LENGTH.

          LDN    WCCID
          RJM    FHE         FETCH WALL CLOCK CHIP ID DESCRIPTOR
          MJP    ERR         IF WALL CLOCK CHIP DESCRIPTOR NOT FOUND
          LDM    HBUF        SET CLOCK DESCRIPTOR LENGTH
          SHN    -6
          STM    CALB+2
          LDN    1
          STM    UMEM        SET FLAG TO WRITE *2AP* TO MEMORY
          CALL   PFC         CALL *2AP* TO WRITE HDT TO ITS DATA AREA AND CM
          LDN    0
          STM    UMEM        CLEAR UPDATE MEMORY FLAG
          LDM    UWCC        GET UPDATE WALL CLOCK CHIP FLAG
          NJP    UCD2        IF NO UPDATE NECESSARY

*         AFTER THE CALL DATA WILL BE IN *TOIP*.  MOVE DATE AND TIME DATA
*         TO THE BEGINNING OF THE BUFFER IN PREPARATION FOR THE CALL TO
*         *2AP* TO UPDATE THE WALL CLOCK CHIP.

          LDN    1
          STD    T1          INDEX
          LDML   TINB
          STML   UCDB
          SBN    1
          STML   UCDC        BUFFER ADDRESS - 1
 UCD1     LDM    **,T1
 UCDB     EQU    *-1
          STM    **,T1       STORE IN PREVIOUS ENTRY
 UCDC     EQU    *-1
          AOD    T1
          SBN    7
          MJN    UCD1        IF NOT DONE MOVING
          LDM    IOUM        IOU MODEL
          SHN    -4
          LMN    2
          ZJN    UCD2        IF NO WALL CLOCK CHIP IN IOU
          LDC    131         FUNCTION TO WRITE THE WALL CLOCK CHIP
          STM    CALB
          CALL   PFC         CALL THE *2AP* OVERLAY

*         FINALLY WRITE THE DISK WITH THE UPDATED HDT.

 UCD2     LDN    33          FUNCTION TO WRITE THE HDT TO DISK
          STM    CALB
          STML   RTP1        SAVE FUNCTION CODE
          CALL   PFC         CALL *2AP* WITH FUNCTION
          LDM    CALB
          ADM    CALB+1
          ADM    CALB+2
          ZJP    UCDX        IF NO ERRORS TRYING TO WRITE THE DISK
          LDN    0           NO RETURN / DO NO SET STATUS / NO OFFSET
          STML   RTP2
          CALL   PDE         PROCESS DISK ERROR

*         END    CTP$DFT_OS_REQUESTS_NON_PACKETS
*DECK DECK=CTP$DFT_OS_REQUESTS_PACKETS EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_OS_REQUESTS_PACKETS
*
*         THIS DECK PROVIDES O.S. REQUEST PROCESSORS WHICH
*         REQUIRE PACKET COMMUNICATION TO FUNCTION PROPERLY
 UCD      SPACE  4,10
**        UCD - UPDATE CLOCK DATA.
*
*         ENTRY  (TINB) - SHOULD HAVE THE CLOCK DATA IN THE WALL CLOCK
*                         CHIP DESCRIPTOR FORMAT.
*                UWCC - UPDATE WALL CLOCK CHIP FLAG, = 0 IMPLIES WALL CLOCK
*                       CHIP UPDATED, .NE. 0 IMPLIES WALL CLOCK CHIP NOT
*                       UPDATED.
*
*         EXIT   HDT, CDA, AND THE CHIP IF PRESENT WILL ALL BE UPDATED.
*
*         CALLS  FHE, PFC, *ERR*.


          ROUTINE UCD

          LDC    132         FUNCTION TO WRITE THE HDT
          STM    CALB

*         SET CLOCK DESCRIPTOR LENGTH.

          LDN    WCCID
          RJM    FHE         FETCH WALL CLOCK CHIP ID DESCRIPTOR
          MJP    ERR         IF WALL CLOCK CHIP DESCRIPTOR NOT FOUND
          LDM    HBUF        SET CLOCK DESCRIPTOR LENGTH
          SHN    -6
          STM    CALB+2
          LDN    1
          STM    UMEM        SET FLAG TO WRITE *2AP* TO MEMORY
          CALL   PFC         CALL *2AP* TO WRITE HDT TO ITS DATA AREA AND CM
          LDN    0
          STM    UMEM        CLEAR UPDATE MEMORY FLAG
          LDM    UWCC        GET UPDATE WALL CLOCK CHIP FLAG
          NJP    UCD2        IF NO UPDATE NECESSARY

*         AFTER THE CALL DATA WILL BE IN *TOIP*.  MOVE DATE AND TIME DATA
*         TO THE BEGINNING OF THE BUFFER IN PREPARATION FOR THE CALL TO
*         *2AP* TO UPDATE THE WALL CLOCK CHIP.

          LDN    1
          STD    T1          INDEX
          LDML   TINB
          STML   UCDB
          SBN    1
          STML   UCDC        BUFFER ADDRESS - 1
 UCD1     LDM    **,T1
 UCDB     EQU    *-1
          STM    **,T1       STORE IN PREVIOUS ENTRY
 UCDC     EQU    *-1
          AOD    T1
          SBN    7
          MJN    UCD1        IF NOT DONE MOVING
          LDM    IOUM        IOU MODEL
          SHN    -4
          LMN    2
          ZJN    UCD2        IF NO WALL CLOCK CHIP IN IOU
          LDC    131         FUNCTION TO WRITE THE WALL CLOCK CHIP
          STM    CALB
          CALL   PFC         CALL THE *2AP* OVERLAY

*         FINALLY WRITE THE DISK WITH THE UPDATED HDT.
*         DONT DO THIS ON 93X MODELS.

          LDM    S0FLG
          NJP    UCD4        IF 93X MAINFRAME
 UCD2     LDN    33          FUNCTION TO WRITE THE HDT TO DISK
          STM    CALB
          STML   RTP1        SAVE FUNCTION CODE
          CALL   PFC         CALL *2AP* WITH FUNCTION
          LDM    CALB
          ADM    CALB+1
          ADM    CALB+2
          ZJN    UCD3        IF NO ERRORS TRYING TO WRITE THE DISK
          LDN    0           NO RETURN / DO NOT SET STATUS / NO OFFSET
          STML   RTP2
          CALL   PDE         PROCESS DISK ERRORS

 UCD3     LDM    PKFLG
          ZJP    UCDX        IF PC CONSOLE IS NOT PRESENT
          LDC    PKTCW*0#400-TPKT*0#400+1*0#400+0*0#200+PKFSC  SET *UPDATE CONSOLE CLOCK* REQUEST
          STML   RTP1
          UJN    UCD5        MAKE PACKET REQUEST

 UCD4     LDM    S0FLG
          ZJN    UCD3        IF NOT S0/S0E PACKETS
          LDC    PKTCW*0#400-TPKT*0#400+1*0#400+0*0#200+PKRUC  SET *UPDATE CONSOLE CLOCK* REQUEST
          STML   RTP1
 UCD5     CALL   MPR         MAKE PACKET REQUEST
          LJM    UCDX        RETURN

*         END    CTP$DFT_OS_REQUESTS_PACKETS
*DECK DECK=CTP$DFT_PP_REQUESTS_RELOCATION EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT PP REQUESTS RELOCATION.
*
*         THIS DECK PROVIDES CODE TO SUPPORT PP RELOCATION
*         WHICH IS DONE ONLY ON S0/S0E MAINFRAMES.
 CRQ      SPACE  4,10
**        CRQ - CHECK FOR RELOCATION REQUEST.
*
*         EXIT   (*DRCR*) = 0.
*                NO ACTION TAKEN IF EICB LEVEL < 4.
*                *SCI* RELOCATED IF REQUESTED.
*                *DFT* IDLED IF REQUESTED.
*
*         USES   T1, W0 - W3.
*
*         CALLS  DCD, IIB, RSC.


          ROUTINE  CRQ

          LDN    0           CLEAR MAIN LOOP FLAG
          STM    DRCR
          RJM    DCD         DETERMINE IF CPU/PP COMMUNICATION BLOCK DEFINED
          ZJP    CRQX        IF NO POINTER OR EICB REVISION < 04

*         CHECK RELOCATION CONTROL WORD.

          LRD    W4+1
          LDD    W4          READ RELOCATION CONTROL WORD
          ADC    RR
          CRDL   W0
          LDD    W0          IGNORE UPPER BITS (INITIALIZE FLAG)
          SCN    77
          ADDL   W0+1
          SCN    77
          ZJP    CRQX        IF NO REQUESTS PRESENT

*         PROCESS *SCI* FLAGS.

          LDD    W0+1        CHECK SCI FLAGS
          SHN    21-10
          MJN    CRQ3        IF *SCI* DELIBERATELY DIED
          SHN    21-7-21+10
          MJN    CRQ2        IF *SCI* READY TO BE RELOCATED
          SHN    21-6-21+7
          PJN    CRQ3        IF *REQUEST SCI IDLE* NOT PENDING
          LDM    CRQA        CHECK TIMER VALIDITY
          NJN    CRQ1        IF TIMER ACTIVE
          LDN    10D+1       INITIALIZE 10 SECOND TIMER
          STM    CRQA
 CRQ1     SOM    CRQA        DECREMENT TIMER
          NJP    CRQX        IF TIMER NOT EXPIRED

*         RELOAD *SCI*.

 CRQ2     RJM    RSC         RELOCATE *SCI*
          LRD    W4+1        REREAD RELOCATION CONTROL WORD
          LDD    W4
          ADC    RR
          CRDL   W0
          LDDL   W0+1        CLEAR ALL *SCI* FLAGS
          LPN    77
          STDL   W0+1

*         PROCESS *DFT* FLAGS.

 CRQ3     LDD    W0          PROPAGATE *REQUEST DFT IDLE* TO *DFT IDLED*
          LPC    100
          SHN    1
          RADL   W0
          LDD    W4          REWRITE RELOCATION CONTROL WORD
          ADC    RR
          CWDL   W0
          LDDL   W0
          SHN    21-6
          PJP    CRQX        IF *REQUEST DFT IDLE* NOT SET
          UJN    *           WAIT FOR *SCI* TO IDLE PP

 RSC      SPACE  4,10
**        RSC - RELOCATE *SCI*.
*
*         ENTRY  (W0 - W0+3) = RELOCATION CONTROL WORD.
*
*         EXIT   *SCI* RELOCATED.
*
*         CALLS  IIB, PFE.
*
*         USES   T1, W0 - W3.
*
*         MACROS FINDCM.


 RSC      SUBR               ENTRY/EXIT

*         IDLE EXISTING COPY OF *SCI*.

          LDD    W0+1        SET NEW PP NUMBER FOR *SCI*
          LPN    77
          STM    RSCA
          LDN    D8ST        SET PRESENT PP NUMBER FOR *SCI*
          RJM    IIB
          CRDL   W0
          LDDL   W0+2
          SHN    -10
          STM    RSCA+1
          STM    PPTN
          RJM    IDP         IDLE EXISTING COPY OF *SCI*

*         UPDATE *EICB* TO REFLECT NEW *SCI* PP NUMBER.

          LDDL   W0+2        UPDATE *SCI* PP NUMBER
          LPC    0#FF
          STDL   W0+2
          LDM    RSCA
          STM    PPTN
          SHN    10
          RADL   W0+2
          LDN    D8ST        REWRITE *EICB* WITH UPDATED PP NUMBER
          RJM    IIB
          CWDL   W0

*         INITIALIZE DIRECT CELLS IN BOOTSTRAP IMAGE.

          FINDCM SCI         LOCATE *SCI* IN THE CIP DIRECTORY
          ADN    1
          STML   RSCB+DE     SAVE ADDRESS OF *SCI* DIRECTORY ENTRY
          CRML   RSCB+T1,ON
          LDD    CM+1
          STML   RSCB+DE+1
          LDD    CM+2
          STML   RSCB+DE+2
          LDN    DSEBP       SAVE ADDRESS OF *CIP* DIRECTORY
          RJM    IIB
          CRML   RSCB+CD,ON
          LDM    RSCA        SAVE PP NUMBER
          LMC    4000        SET RESTART FLAG
          STM    RSCB+27

*         ACTIVATE NEW COPY OF *SCI*.

          LDM    PPTN
          RJM    IDP         IDLE PP
          LDN    MX          GET MUX CHANNEL INTERLOCK
          RJM    SCF
          LDN    MX          USE MUX CHANNEL FOR DEADSTARTING THE PP
          STD    T1
          LDM    PPTN        LOAD SELECTED PP
          RJM    DLP
          LDN    RSCBL       OUTPUT BOOTSTRAP TO PP
          OAM    RSCB,MX
          FJM    *,MX        WAIT FOR PP TO ACCEPT DATA
          DCN    MX+40
          CCF    *,MX        RELEASE CHANNEL INTERLOCK
          LJM    RSCX        RETURN

 RSCA     BSS    2

 RSCB     BSS    0           BOOTSTRAP PROGRAM
          LOC    0

          CON    BTS-1       ADDRESS - 1 TO EXECUTE

 T1       BSS    4           DIRECTORY ENTRY

 BTS      LDD    T1          SET PP LOAD ADDRESS
          STD    BTSA
          LDD    DE          SET CM LOAD ADDRESS
          ADC    RR+1
          LRD    DE+1
          CRML   **,T2       READ PROGRAM INTO PP
 BTSA     EQU    *-1         (LOAD ADDRESS)
          LJM    100         ENTER *SCI* PRESET

          BSS    30-*

 DE       BSS    3           ADDRESS OF *SCI* DIRECTORY ENTRY
          BSS    1           (USED ONLY FOR CTI/MDD LOADS)
 CD       BSS    3           ADDRESS OF *CIP* DIRECTORY
          BSS    1           (UNUSED - REQUIRED BY *CRML* INTO *CD*)
          LOC    *O
 RSCBL    EQU    *-RSCB      LENGTH OF BOOTSTRAP
 PPTN     CON    0           PP TYPE AND NUMBER
*COPY DSI$930_DUMP_LOAD_IDLE_PP

*         END    CTP$DFT PP REQUESTS RELOCATION
*DECK DECK=CTP$DFT_PP_UTILITY_REQUESTS EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT PP UTILITY REQUESTS.
*
*         THIS DECK EXTERNALIZES THE DFT PP UTILITY FUNCTIONS
*         WHICH INCLUDE *LDC*, *PUF*, *PUR*, AND *REP*.
          SPACE  4,10
 QUAL$    EQU    0           DEFINE UNQUALIFIED COMMON DECKS
 PPTN     CON    0           GLOBAL PP TYPE/NUMBER VALUE
 CBUF     BSSZ   100         PP MEMORY BUFFER
 LDC      SPACE  4,10
**        LDC - BEGIN LOAD OF DRIVER CODE.
*
*         ENTRY  (JT - JT+2) = REQUEST POINTER.
*
*         CALLS  LDR, LRP.


          ROUTINE  LDC

          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0          READ FIRST WORD OF REQUEST
          RJM    LRP         LOAD REQUEST POINTER
          ADN    1
          CRDL   W4          READ SECOND WORD OF REQUEST
          RJM    LDR         LOAD DRIVER CODE COMPLETION
          LJM    LDCX        RETURN
 PUF      SPACE  4,10
**        PUF - PP UTILITY FUNCTIONS.
*
*         ENTRY  (JT - JT+3) = DFT REQUEST POINTER IN R POINTER FORMAT.
*                DFT REQUEST FORMAT:
*                   WORD 0 = 8/RESPONSE.
*                            8/DFT FUNCTION.
*                            8/CONCURRENT, = 1 IMPLIES CONCURRENT, = 0 IMPLIES
*                               NON CONCURRENT.
*                            8/PP NUMBER.
*                            8/DUMP REGISTERS ONLY, = 1 IMPLIES DUMP REGISTERS
*                               ONLY, = 0 IMPLIES DUMP BOTH REGISTERS AND MEMORY.
*                            8/DUMP PP, = 1 IMPLIES PP SHOULD BE DUMPED, = 0
*                               IMPLIES PP ONLY IDLED.
*                            8/IDLE PP, = 1 IMPLIES PP IDLED BEFORE DUMPED, = 0
*                               IMPLIES PP NOT IDLED BEFORE DUMP, ONLY REGISTERS
*                               CAN BE DUMPED IN THIS CASE.
*                            8/0.
*                   WORD 1 = POINTER FOR PP REGISTERS AND MEMORY IF BEING DUMPED,
*                            R REGISTER FORMAT.
*
*         EXIT   ONE OF ABOVE REQUESTS IS PERFORMED.
*
*         CALLS   DPM, DPR, IDP, LRP.
*
*         USES   W0 - W5.

          ROUTINE  PUF

          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0          WORD 0 OF DFT REQUEST
          LDDL   W1          GET PP TYPE AND NUMBER
          STML   PPTN
          LDDL   W3
          SHN    -8D         IDLE PP BOOLEAN
          ZJN    PUF5        IF NOT IDLE PP
          LDDL   W1          GET PP TYPE AND NUMBER
          RJM    IDP         HARDWARE IDLE PP
 PUF5     LDDL   W2          DUMP FLAGS
          LPC    0#FF
          ZJP    PUFX        IF NOT DUMPING PP
          RJM    LRP         LOAD REQUEST POINTER
          ADN    1
          CRDL   W4          READ SECOND WORD OF REQUEST
          LDML   PPTN        PP TYPE AND NUMBER
          RJM    DPR         DUMP PP REGISTERS
 PUF6     LDDL   W2          DUMP FLAGS
          SHN    -10
          NJP    PUFX        IF JUST DUMP REGISTERS
          LDML   PPTN        PP TYPE AND NUMBER
          RJM    DPM         DUMP PP MEMORY
          LJM    PUFX        RETURN
 PUR      SPACE  4,30
**        PUR - PP UTILITY FUNCTIONS.
*
*         ENTRY  (JT - JT+3) = DFT REQUEST POINTER IN R-POINTER FORMAT.
*                (REQUEST) = 16/, 8/IOU, 8/CIO, 8/PP, 8/SUBFUNCTION, 16/ADDR.
*                            64/R-POINTER.
*                WHERE -
*                SUBFUNCTION -
*                  1 = DUMP PP REGISTERS ONLY.
*                  2 = IDLE PP ONLY.
*                  3 = IDLE PP AND DUMP PP REGISTERS AND MEMORY.
*                  4 = IDLE PP AND DUMP PP REGISTERS.
*                  5 = LOAD PP.
*                  6 = RESUME PP.
*                  7 = RETURN PP R REGISTER.
*                  8 = MASTER CLEAR A SPECIFIC CHANNEL.
*
*                IOU = IOU NUMBER (0 OR 1).
*                CIO = 1 IF CIO PP, ELSE 0.
*                PP = PP NUMBER.
*                ADDR = RESUME ADDRESS.
*                R-POINTER = POINTER FOR PP REGISTERS AND MEMORY IF BEING DUMPED,
*                            R REGISTER FORMAT.
*
*         EXIT   IF NO ERROR, ONE OF THE ABOVE REQUESTS IS PERFORMED.
*                TO *ERR* IF ERROR ENCOUNTERED IN REQUEST.
*
*         USES   W0 - W7.
*
*         CALLS  DPM, DPR, DPS, IDP, LRP.


          ROUTINE  PUR

          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0          WORD 0 OF DFT REQUEST
          ADN    1
          CRDL   W4          WORD 1 OF DFT REQUEST
          LDDL   W1          PP TYPE
          LPC    0#FF
          SHN    10
          STDL   T1
          LDDL   W2          PP NUMBER
          SHN    -10
          LMDL   T1
          STML   PPTN        PP TYPE AND NUMBER
          STM    PURC

*         FOR IOU1 REQUESTS, VERIFY THAT PP IS LOGICALLY ON.
*         PP WILL BE VIEWED AS LOGICALLY OFF IF IOU1 IS LOGICALLY OFF.

          LDDL   W1
          SHN    -10
          ZJN    PUR40       IF IOU0 REQUEST
          LDML   PPTN        PP TYPE AND NUMBER
          RJM    DPS         DETERMINE PP STATUS
          NJN    PUR40       IF PP IS LOGICALLY ON
 PUR30    LJM    ERR         RETURN ERROR STATUS

*         ALLOW NO OPERATION ON DFT PP.

 PUR40    LDDL   W2          EXTRACT SUBFUNCTION
          LPC    0#FF
          STDL   T3
          LMN    10B         CHECK FOR MASTER CLEAR
          ZJN    PUR50       IF MASTER CLEAR OF SPECIFIC CHANNEL
          LDML   PPTN
          LMML   //PPNO
          ZJN    PUR30       IF MATCH ON PP TYPE AND NUMBER

 PUR50    LDDL   T3          SUBFUNCTION
          SBN    TPURL
          PJN    PUR30       IF REQUEST NOT RECOGNIZED
          LDM    TPUR,T3
          STD    T2
          ZJN    PUR30       IF NO PROCESSOR FOR REQUEST
          LJM    0,T2        EXECUTE SUBFUNCTION

*         SUBFUNCTION 1 - DUMP PP REGISTERS WITHOUT IDLING PP.

 PUR60    LDDL   W7          CHECK LENGTH
          SBN    2
          MJN    PUR30       IF BUFFER WILL NOT HOLD RESULT
          RJM    DPR         DUMP PP REGISTERS
          UJN    PUR80       RETURN

*         SUBFUNCTION 2 - ONLY IDLE PP.

 PUR70    LDML   PPTN        PP TYPE AND NUMBER
          RJM    IDP         IDLE PP
 PUR80    LJM    PURX        RETURN

*         SUBFUNCTION 3 - IDLE AND DUMP PP.

 PUR90    LDDL   W7          ENSURE MINIMUM SPACE IS AVAILABLE
          SBN    100/4+2
          MJP    ERR         IF BUFFER WILL NOT HOLD MINIMUM
          LDML   PPTN
          RJM    IDP         IDLE PP
          RJM    DPR         DUMP PP REGISTERS
 PUR100   LDC    **          PP TYPE AND NUMBER
 PURC     EQU    *-1
          RJM    DPM         DUMP PP MEMORY
          UJP    PUR80       RETURN

*         SUBFUNCTION 4 - IDLE PP AND DUMP REGISTERS.

 PUR120   LDDL   W7          CHECK LENGTH
          SBN    2
          MJP    ERR         IF LENGTH INSUFFICIENT TO RETURN REGISTERS
          LDML   PPTN        PP TYPE AND NUMBER
          RJM    IDP         IDLE PP
          RJM    DPR         DUMP REGISTERS
          LJM    PURX        RETURN

*         SUBFUNCTION 5 - LOAD PP.

 PUR130   LDML   PPTN        PP TYPE AND NUMBER
          STDL   W1
          RJM    LDR         LOAD DRIVER CODE COMPLETION
          LJM    PURX        RETURN

*         SUBFUNCTION 6 - RESUME PP.

 PUR140   LDDL   W3          SET STARTING ADDRESS
          STML   RPCA
          RJM    RPC         RESTART PP (COMMON CODE)
          LJM    PURX

*         SUBFUNCTION 7 - RETURN PP R REGISTER.

 PUR150   LDDL   W4
          STML   BB+GRVA
          LDDL   W5
          STML   AA+GRVA
          LDDL   W6
          STML   AA+1+GRVA
          LDDL   JT
          STML   REQ+GRVA
          LDDL   JT+1
          STML   REQ+GRVA+1
          LDDL   JT+2
          STML   REQ+GRVA+2
          RJM    GRV         GET R REGISTER VALUE
          RJM    RCS         RESET CALL STACK
          LJM    DFT10       RETURN TO MAIN DO NOT ANSWER REQUEST HERE

*         SUBFUNCTION 8 - MASTER CLEAR CHANNEL.

 PUR160   LDM    IOUM
          SHN    -4
          LMN    4                                                                                                                 I
          NJP    ERR         IF NOT AN I4 IOU
          LDC    ENIO
          STD    RN          SETUP FOR NIO DEC
          LDM    IOUM
          LMC    0#42
          ZJN    PUR161      IF MODEL 42 IOU
          LDD    W1          GET NIO/CIO
          ZJN    PUR161      IF NIO
          LDC    ECIO
          STD    RN
 PUR161   LOCKMR SET
          READMR RDATA,I0CC  GET THE IOU DEC REGISTER
          LDDL   W2          CHANNEL NUMBER
          SHN    -10
          STML   RDATA+5
          LDML   RDATA+7
          SCN    2
          LMN    2                                                                                                     S
          STML   RDATA+7     SET CHANNEL MASTER CLEAR
          WRITMR RDATA,I0CC
          RJM    CIE         CLEAN UP DEC REGISTER
          LOCKMR CLEAR
          LJM    PURX        RETURN
 TPUR     SPACE  4,10
**        TPUR - TABLE OF PP UTILITY REQUEST SUBFUNCTION CODES.


 TPUR     BSS    0
          LOC    0
          CON    0
          CON    PUR60       DUMP PP REGISTERS
          CON    PUR70       IDLE PP
          CON    PUR90       IDLE AND DUMP PP
          CON    PUR120      IDLE PP AND DUMP REGISTERS
          CON    PUR130      LOAD PP
          CON    PUR140      RESUME PP
          CON    PUR150      RETURN PP R REGISTER
          CON    PUR160      MASTER CLEAR CHANNEL
          LOC    *O
 TPURL    EQU    *-TPUR      TABLE LENGTH
 REP      SPACE  4,10
**        REP - RESTART PP VIA HARDWARE.
*
*         ENTRY  PP NUMBER TO RESTART AND STARTING ADDRESS.
*
*         EXIT   PP STARTED TO ADDRESS.
*
*         CALLS  LRP, RPC.
*
*         NOTE   LOCATIONS 0, 1 AND (A) WILL BE DESTROYED IN TARGET PP.


          ROUTINE  REP

          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0          GET PARAMETERS
          LDDL   W2          STARTING ADDRESS
          STML   RPCA+T0     SAVE FOR BLOCK INPUT
          LDD    W1          PP NUMBER
          STM    PPTN
          RJM    RPC         RESTART PP (COMMON CODE)
          LJM    REPX        RETURN
 DPM      SPACE  4,10
**        DPM - DUMP PP MEMORY.
*
*         ENTRY  (A) = PP TYPE AND NUMBER.
*                (W4 - W7) = POINTER TO AREA FOR PP MEMORY TO BE WRITTEN
*                          IN MEMORY, R-POINTER FORMAT.
*
*         EXIT   PP MEMORY WRITTEN TO SPECIFIED AREA IN MEMORY.
*                (W4) = OFFSET IN R-POINTER UPDATED TO REFLECT WORDS WRITTEN.
*
*         USES   T1, T4, T5, T6, T7.
*
*         CALLS  DDP, SCF, SPB.


 DPM      SUBR               ENTRY/EXIT
          STD    T6          SAVE PP TYPE AND NUMBER
          LDN    D8TY
          RJM    IIB         INDEX TO INTERFACE BLOCK
          CRDL   CM          GET 180 OS INTERFACE LEVEL
          LDC    DFTPSR      GET PSR LEVEL
          SBDL   CM          SUBTRACT OS SPECIFIED LEVEL
          ZJN    DPM2        IF AT SAME LEVEL
          LDD    T6          PP NUMBER
          SHN    21-10
          PJN    DPM1        IF NIO PP
          LDC    20000/4     PP WORD SIZE CIO
          STDL   T7
          UJN    DPM3

 DPM1     LDC    10000/4     PP WORD SIZE NIO
          STDL   T7
          UJN    DPM3

 DPM2     LDDL   W7
          STDL   T7          GET SIZE FROM R POINTER
 DPM3     LDN    MX          MUX CHANNEL
          STD    T1          SAVE MUX CHANNEL FOR CALL TO *DDP*
          RJM    SCF         SET CHANNEL FLAG
          LDD    T6          PP NUMBER
          RJM    DDP         DEADSTART DUMP PP

*         LOAD R-REGISTER TO WRITE PP MEMORY TO SPECIFIED AREA.

          LRD    W5
          RJM    SPB         SET PP BOUNDARY
          LDN    100/4       WORD COUNT IN BLOCK
          STD    T3
          LDN    0
          STD    T4          TRANSFER COUNT
 DPM4     EJM    DPM2,MX     JUMP ON CHANNEL EMPTY
          LDC    100
          IAM    CBUF,MX     INPUT BLOCK OF 16 BIT PP WORDS
          LDDL   W4          OFFSET
          ADDL   T4          TRANSFER COUNT
          LMC    RR
          CWML   CBUF,T3     WRITE DATA TO BUFFER
          LDDL   T3
          RADL   T4          INCREMENT TRANSFER COUNT
          SBDL   T7          DUMP LENGTH SHORTENS
          MJN    DPM4        IF MORE WORDS TO STORE
          DCN    MX          DEACTIVATE CHANNEL
          CCF    *,15        RELEASE CHANNEL 15
          LDDL   T4          UPDATE OFFSET IN R-POINTER
          RADL   W4
          LJM    DPMX        RETURN
 DPS      SPACE  4,15
**        DPS - DETERMINE IOU1 PP STATUS.
*
*         ENTRY  (A) = 8/CIO, 8/PP.
*                WHERE CIO = 0, IF NIO PP.
*                          = 1, IF CIO PP.
*                      PP  = PP NUMBER (0 - 11, 20 - 31).
*
*         EXIT   (A) = 1, IF PP IS LOGICALLY ON.
*                    = 0, IF PP IS LOGICALLY OFF.
*
*         USES   T1, T2.
*
*         CALLS  FHE.


 DPS40    LDN    0           PP IS LOGICALLY OFF

 DPS      SUBR               ENTRY/EXIT
          STML   DPSB        SAVE PP CHARACTERISTICS
          LDC    10000+IOUID
          RJM    FHE         FIND HARDWARE ELEMENT
          MJN    DPS40       IF NOT FOUND
          LDM    HBUF+CIOST
          SHN    21-0
          MJN    DPS40       IF SECOND IOU IS LOGICALLY OFF
          LDML   DPSB        EXTRACT PP NUMBER
          LPC    0#FF
          STD    T1
          LDML   IOUM        CHECK IOU MODEL NUMBER
          LMC    0#43
          ZJN    DPS3        IF MODEL 43 IOU
          LMN    0#44&0#43
          NJN    DPS4        IF NOT MODEL 44 IOU
 DPS3     LDML   DPSB
          SHN    -10
          ZJN    DPS40       IF NIO SELECTED ON MODEL 44
          UJN    DPS6        PROCESS REQUEST FOR MODEL 44 PP AS IF NIO

 DPS4     LDML   DPSB
          SHN    -10
          NJN    DPS10       IF CIO PP
 DPS6     LDD    T1
          SBN    20
          PJN    DPS20       IF NIO 20 - 31
          LDN    CIOPLM      OFFSET TO STATUS OF NIO PP-S 0 - 11
          STD    T2
          UJN    DPS30       FORM SHIFT INSTRUCTION

 DPS10    LDN    CIOCLM      OFFSET TO STATUS OF CIO PP-S 0 - 11
          STD    T2
          UJN    DPS30       FORM SHIFT INSTRUCTION

 DPS20    STD    T1          SAVE PART OF SHIFT COUNT
          LDN    CIOPLM+1    OFFSET TO STATUS OF NIO PP-S 20 - 31
          STD    T2
 DPS30    LDC    SHNI+21     FORM SHIFT INSTRUCTION
          SBD    T1
          STM    DPSA
          LDML   HBUF,T2
          LPC    1777        USE ONLY DEFINED BITS
 DPSA     SHN    **
          MJP    DPS40       IF PP IS LOGICALLY OFF
          LDN    1           PP IS LOGICALLY ON
          UJP    DPSX        RETURN

 DPSB     BSS    1           8/CIO, 8/PP NUMBER
 LDR      SPACE  4,10
**        LDR - LOAD DRIVER CODE COMPLETION.
*
*         ENTRY  (W1) = 8/PP TYPE, 8/PP NUMBER.
*                (W4 - W7) = R-POINTER.
*
*         EXIT   TO *ERRH* IF PP LOAD ERROR.
*
*         CALLS  DLP, IDP, IIB, LRP, SCF.
*
*         MACROS EXITMR, READMR.


 LDR      SUBR               ENTRY/EXIT
          EXITMR *
          READMR RDATA,I0CC,IOSB
          LDD    W4
          STM    LDRA+LDRB   SAVE OFFSET OF R POINTER
          LDD    W5
          STM    LDRA+LDRC   SAVE R UPPER OF POINTER
          LDD    W6
          STM    LDRA+LDRC+1 SAVE R LOWER OF POINTER
          LDN    D8TY
          RJM    IIB         INDEX TO INTERFACE BLOCK
          CRDL   CM          GET 180 OS INTERFACE LEVEL
          LDC    DFTPSR      GET PSR LEVEL
          SBDL   CM          SUBTRACT OS SPECIFIED LEVEL
          ZJN    LDR20       IF AT SAME LEVEL

*         DETERMINE PP SIZE.

          LDM    S0FLG       CHECK MAINFRAME TYPE
          ZJN    LDR10       IF NOT *S0*
          LDC    37777/4     SET LOAD FOR 16K PP
          UJN    LDR25       CONTINUE

 LDR10    LDD    W1          PP NUMBER AND TYPE
          SHN    21-10       GET TYPE
          PJN    LDR30       IF NIO PP
          LDC    17777/4     SET LOAD FOR 8K CIO PP
          UJN    LDR25       CONTINUE

 LDR20    LDDL   W7          GET SIZE IN R POINTER
 LDR25    STML   LDRA+LDRD   SAVE SIZE FROM R POINTER
 LDR30    EXITMR FMR
          LDD    W1
          STM    PPTN        SAVE PP TYPE/NUMBER
          RJM    IDP         IDLE PP
          LDN    MX
          RJM    SCF         INTERLOCK TWO PORT MUX
          LDN    MX
          STD    T1
          LDM    PPTN
          RJM    DLP         DEADSTART LOAD PP
          LDN    LDRAL
          OAM    LDRA,MX
          FJM    *,MX        WAIT FOR CHANNEL EMPTY
          DCN    MX+40
          CCF    *,MX        CLEAR MUX INTERLOCK
          ZJP    LDR40       IF TRANSFER COMPLETE

*         SINCE THE TRANSFER WAS INCOMPLETE, AN ATTEMPT WILL BE MADE
*         TO IDLE THE PP.  THEN THE REQUEST WILL BE TERMINATED WITH AN
*         ERROR, AND AN ERROR MESSAGE WILL BE PLACED IN THE EICB.

          LDM    PPTN        PP TYPE/NUMBER
          RJM    IDP
          LDC    0#200       TERMINATE REQUEST WITH ERROR
          STM    JOBF
          RJM    SRS         SET REQUEST STATUS

*         DFT ANALYSIS - PP LOAD ERROR.

          SETDAN (EPUN,DALE)
          LDC    DALE        60C - PP LOAD ERROR
          STML   RTP1
          CALL   ERRH        ISSUE MESSAGE TO EICB

 LDR40    LJM    LDRX        RETURN

*         THE FOLLOWING IS A SHORT BOOT PROGRAM WHICH IS SENT TO
*         THE DESTINATION PP.  WHEN IT STARTS EXECUTING IN THE
*         DESTINATION PP, IT WILL READ THE SELECTED PP PROGRAM
*         INTO THE PP.  SINCE IT READS INTO LOCATION ZERO OF THE
*         PP, IT WILL START EXECUTING AT THE ADDRESS CONTAINED
*         IN THE PROGRAM IT IS LOADING AFTER THE READ IS COMPLETE.

 LDRA     BSS    0
          LOC    0
          CON    0
          LRD    LDRC
          LDC    RR
 LDRB     EQU    *-1
          CRML   0,LDRD

 LDRC     CON    0,0         PP R-REGISTER VALUE
 LDRD     CON    7777/4      LOAD SIZE
          LOC    *O
 LDRAL    EQU    *-LDRA      BOOT SIZE
 RPC      SPACE  4,10
**        RPC - RESTART PP (COMMON CODE).
*
*         ENTRY  (RPCA) = STARTING ADDRESS.
*                (PPTN) = 8/PP TYPE, 8/PP NUMBER.
*
*         CALLS  PFE, SCF.


 RPC      SUBR               ENTRY/EXIT
          LDN    MX
          RJM    SCF         INTERLOCK TWO PORT MUX
          LDN    MX
          STD    T1          SAVE TWO PORT MUX CHANNEL
          LDML   PPTN
          RJM    DLP         DEADSTART LOAD PP
          LDN    RPCAL       LENGTH OF BLOCK
          OAM    RPCA,MX
          FJM    *,MX        WAIT CHANNEL EMPTY
          DCN    MX+40B      DEACTIVATE CHANNEL
          CCF    *,MX        CLEAR MUX INTERLOCK
          UJP    RPCX        RETURN

 RPCA     BSS    0
          LOC    0
          CON    **          STARTING ADDRESS
          LOC    *O
 RPCAL    EQU    *-RPCA

 GRV      SPACE  4,10
**        GRV - GET R REGISTER VALUE.
*
*         THIS ROUTINE LOADS A BOOT PROGRAM IN THE TARGET PP THAT
*         READS THAT PPS R REGISTER AND WRITES THE VALUE TO A SPECIFIED
*         LOCATION IN CM.


 GRV      SUBR               ENTRY
          EXITMR FMR
          LDM    PPTN        SAVE PP TYPE/NUMBER
          RJM    IDP         IDLE PP
          LDN    MX
          RJM    SCF         INTERLOCK TWO PORT MUX
          LDN    MX
          STD    T1
          LDM    PPTN
          RJM    DLP         DEADSTART LOAD PP
          LDN    GRVAL
          OAM    GRVA,MX
          FJM    *,MX        WAIT FOR CHANNEL EMPTY
          DCN    MX+40
          CCF    *,MX        CLEAR MUX INTERLOCK
          ZJP    GRVX        IF TRANSFER COMPLETE

*         SINCE THE TRANSFER WAS INCOMPLETE, AN ATTEMPT WILL BE MADE
*         TO IDLE THE PP.  THEN THE REQUEST WILL BE TERMINATED WITH AN
*         ERROR, AND AN ERROR MESSAGE WILL BE PLACED IN THE EICB.

          LDM    PPTN        PP TYPE/NUMBER
          RJM    IDP
          LDC    0#200       TERMINATE REQUEST WITH ERROR
          STM    JOBF
          RJM    SRS         SET REQUEST STATUS

*         DFT ANALYSIS - PP LOAD ERROR.

          SETDAN (EPUN,DALE)
          LDC    DALE        60C - PP LOAD ERROR
          STML   RTP1
          CALL   ERRH        ISSUE MESSAGE TO EICB

*         THE FOLLOWING IS A SHORT BOOT PROGRAM WHICH IS SENT TO
*         THE DESTINATION PP.  WHEN IT STARTS EXECUTING IN THE
*         DESTINATION PP, IT WILL READ THE R REGISTER AND WRITE IT
*         INTO THE SPECIFIED CM AREA.

 GRVA     BSS    0
          LOC    0
          CON    0
          SRD    RRS+2
          LRD    AA
          LDDL   BB
          ADC    RR
          CWDL   RRS         WRITE R REGISTER
          LDDL   REQ
          LRD    REQ+1
          ADC    RR
          CRDL   RETR
          LDN    RCNE        REQUEST COMPLETE CODE
          SHN    10
          LMDL   RETR
          STDL   RETR
          LDDL   REQ         RE-BUILD A OFFSET
          ADC    RR
          CWDL   RETR
          UJN    *

 BB       CON    0
 AA       CON    0,0         PP R - REGISTER VALUE TO WRITE TO
 RRS      CON    0,0,0,0     R - REGISTER TO SAVE
 RETR     CON    0,0,0,0     BUFFER FOR RETURNING REQUEST STATUS
 REQ      CON    0,0,0       REQUEST POINTER
          LOC    *O
 GRVAL    EQU    *-GRVA      BOOT SIZE

 RIS      SPACE  4,10
**        RIS - READ IOU STATUS REGISTER.
*

          ROUTINE RIS        ENTRY

          READMR RDATA,I0CC,ISTR  READ STATUS REGISTER
          RJM    PAC         PACK THE DATA INTO ONE CM WORD
          RJM    LRP
          ADN    1           WRITE TO NEXT WORD
          CWML   MRVAL,ON
          LJM    RISX        EXIT




*         END    CTP$DFT PP UTILITY REQUESTS
*DECK DECK=CTP$DFT_PREPARE_FOR_CIP_CALL EXPAND=FALSE
*         CTEXT  CTP$DFT_PREPARE_FOR_CIP_CALL
 PFC      SPACE  4,10
**        PFC - PREPARE FOR *2AP* CALL.
*
*         USES   *JOBS - JOBS+3*.
*
*         CALLS  ECM, RPW.


          ROUTINE PFC        ENTRY/EXIT

*         AT THIS POINT SAVE DIRECT CELLS *JT - JT+3* ACROSS
*         CALL TO *2AP* OVERLAY.

          LDDL   JT
          STML   JOBS
          LDDL   JT+1
          STML   JOBS+1
          LDDL   JT+2
          STML   JOBS+2
          LDDL   JT+3
          STML   JOBS+3
          RJM    ECM         EXECUTE CIP MODULE
          LDML   JOBS
          STDL   JT
          LDML   JOBS+1
          STDL   JT+1
          LDML   JOBS+2
          STDL   JT+2
          LDML   JOBS+3
          STDL   JT+3
          RJM    RPW
          LJM    PFCX        RETURN

*COPY     CTP$DFT_RESTORE_POINTER_WORD

*         END    CTP$DFT_PREPARE_FOR_CIP_CALL
*DECK DECK=CTP$DFT_PRESET EXPAND=FALSE
          EJECT
          TITLE  DFT PRESET.
*         CTEXT  CTP$DFT PRESET.
*
*         THIS DECK HOLDS THE PRESET FUNCTIONS WHICH MUST
*         BE PROCESSED BEFORE THE CALL MECHANISM OR THE DFT
*         STRUCTURE IS BUILT.
 PRS      SPACE  4,15
**        PRS - PRESET DFT.
*
*         ENTRY  (23) = RESTART FLAG - 0 = NORMAL START, 1 = RESTART,
*                       FLAG IS VALID ONLY FOR NOS/VE START OF DFT.
*                (24 - 26) = OS BOUNDS ADDRESS IF RUNNING IN IOU1.
*                (70) = NUMBER OF IOU IN WHICH DFT IS RUNNING.
*
*         EXIT   DIRECT CELLS AND GLOBAL VARIABLES INITIALIZED AND/OR
*                RESTORED FROM SAVE AREA.
*                TO *DFT5* IF RUNNING IN PRIMARY IOU.
*                TO *DFT10* IF RUNNING IN SECONDARY IOU.


 PRS      BSS    0           ENTRY
          LDD    23          SAVE RESTART FLAG
          STM    PRSA
          LDDL   24          SAVE OS BOUNDS
          STML   PRSC
          LDDL   25
          STML   PRSC+1
          LDDL   26
          STML   PRSC+2
          LDD    70          SAVE IOU NUMBER
          STM    IOUN
          ZJN    PRS10       IF IOU0
          CCF    *,MX        CLEAR MUX CHANNEL FLAG
          CCF    *,MR        CLEAR MAINTENANCE CHANNEL FLAG
          DCN    MR+40       CLEAR ACTIVE ON CHANNEL
 PRS10    IAN    14          INITIALIZE TIMER BASE TIME
          STML   TIMA
          RJM    PIB         INITIALIZE INTERFACE BLOCK

*         SET UP POINTER TO DFT BLOCK.

          LDN    DSCM+3
          RJM    IIB
          CRDL   W0          READ DFT BLOCK POINTER
          LDM    IOUN
          ZJN    PRS12       IF IOU0
          LRD    W1          READ SECONDARY DFT BLOCK POINTER
          LDDL   W0
          ADC    RR+SDBP
          CRDL   W0
 PRS12    LDD    W0
          STD    DP          DFT BLOCK POINTER (A) OFFSET
          LDDL   W1
          STDL   DP+1
          LDDL   W2
          STDL   DP+2        SAVE R-REGISTER

*         DETERMINE TYPE OF DFT START.

          LDN    HDRP        GET DFT HEADER
          RJM    IDA
          CRDL   W0
          LDDL   W3          EXTRACT LOGGING FLAG
          SHN    21-BC.FL
          ZJN    PRS15       IF NOS/VE IS ACTIVE
          LDN    0           SET NORMAL START FOR DFT
          STML   PRSA

 PRS15    LDM    IOUN
          NJN    PRS20       IF NOT IOU0
          LDM    PRSA
          NJN    PRS20       IF RELOCATED DFT
          LDN    0
          STD    W0
          STD    W1
          STD    W2
          STD    W3
          LDN    D8RLP
          RJM    IIB
          CWDL   W0          CLEAR ANY PREVIOUS COMMUNICATION POINTER
          RJM    PEF         PRESET EICB FIELDS
 PRS20    RJM    RCS         SET UP CALL RETURN MECHANISM

*         BEFORE IT IS POSSIBLE TO PROCESS ERRORS WHICH REQUIRE THE
*         ERROR HANDLING OVERLAY, THE FOLLOWING MUST BE SET UP -
*                IB - IB+2
*                *RCS* MUST HAVE BEEN CALLED.

          EXITMR FMR
          FATALMR  FMR

          RJM    PHT         PREPARE HARDWARE TABLES
          FINDCM DFT
          SRD    DH+1        SAVE DFT POINTER
          STD    DH
          ADN    1
          CRDL   W0          GET RESIDENT HEADER
          LDDL   W1
          ADN    2           ADD CIP AND RESIDENT HEADER SIZES
          STDL   DO          SAVE AS DIRECTORY OFFSET
          RJM    SUM         SET UP HARDWARE MODELS AND MAINT CH CONNECT CODES
          LDM    IOUN
          NJN    PRS25       IF IN IOU1
          RJM    /PRS/UTE    UPDATE TIME IN EICB
 PRS25    LDC    DIMP        SET TASK LIST ADDRESS FOR DEGRADING A CPU
          STM    DTLA
          RJM    LSR         LOAD SECONDARY ROUTINES

          RJM    PDI         PRESET DUAL IOUS

*         AFTER THIS POINT IN DUAL STATE, IT IS POSSIBLE WHEN
*         RUNNING IN IOU1 TO WRITE INTO MEMORY (CALLING *SPB* IF
*         APPROPRIATE) SINCE OS BOUNDS HAS BEEN SET CORRECTLY AND THE
*         PP-S (EXCEPT FOR *DFT*) HAVE BEEN SET TO BE UPPER PP-S.

          RJM    SPO         SETUP MEMORY PORT OFFSET
          LDN    HDRP
          RJM    IDA
          CRDL   CM
          LDN    0           SET NIO PP TYPE BY DEFAULT
          STDL   T1
          LDML   IOUM
          LMC    0#43
          ZJN    PRS40       IF MODEL 43
          LMN    0#44&0#43
          NJN    PRS50       IF NOT MODEL 44
 PRS40    LDC    0#100       SET CIO PP TYPE
          STDL   T1
 PRS50    LDD    CM+DHPP
          LPC    0#FF
          LMDL   T1          INSERT PP TYPE FIELD
          STML   PPNO        DFT PP NUMBER
          LDN    HDRP        RE-READ HEADER
          RJM    IDA
          CRDL   CM
          LDDL   CM+DHFLG
          SHN    21-DH.FV    VALIDATION FLAG
          MJP    PRS210      IF RELOAD FROM STATE MEMORY
          RJM    ISD         IDLE SECONDARY IOU DRIVERS
 PRS60    LDN    D7TY
          RJM    IIB
          CRDL   CM
          LDDL   CM+3
          SHN    -14
          NJN    PRS65       IF NOT 180 STANDALONE
          LDN    1
          STM    ISPB        IF 180 STANDALONE IGNORE OS BOUNDS

*         INITIALIZE PROCESSOR MICROCODE ADDRESSES.

 PRS65    LDN    GPDID       GLOBAL PROCESSOR DESCR
          RJM    FHE         FIND HARDWARE ELEMENT
          MJP    PRS140      IF NOT THERE
          LDML   HBUF+GPDLI
          STML   MLIT        MICROCODE LONG INIT ADDRESS
          LDML   HBUF+GPDIDL
          STML   MIDL        MICROCODE IDLE ADDRESS
          LDML   HBUF+GPDMXO
          STML   HEOM        MICROCODE HEO MON MODE
          LDML   HBUF+GPDJXO
          STML   HEOJ        MICROCODE HEO JOB MODE
          LDML   HBUF+GPDMXI
          STML   HEIM        MICROCODE HEI MON MODE
          LDML   HBUF+GPDJXI
          STML   HEIJ        MICROCODE HEI JOB MODE

*         BRANCH TO APPROPRIATE OVERLAY TO CONTINUE PRESET.
*         CONTROL WILL NOT NORMALLY RETURN BACK TO *PRS* AFTER
*         THIS CALL SINCE A JUMP WILL BE MADE TO *DFT5* OR *DFT10*.

 PRS70    LDM    IOUN        CHECK IOU NUMBER
          NJN    PRS80       IF IN SECONDARY IOU
          CALL   BDS         BUILD DFT CENTRAL MEMORY STRUCTURE

 PRS80    CALL   PSO         STANDARD PRESET OVERLAY ROUTINES

*         DFT ANALYSIS - MISSING DESCRIPTOR IN THE MRT.

 PRS140   SETDAN (EPUN,DAME)
          LDC    DAME+TDFT   613 - DFT NO DESC IN MRT
          STML   RTP1
          CALL   ERRH

 PRS210   LDN    MRBP
          RJM    IDA
          CRDL   W0          GET MAINTENANCE REGISTER BUFFER POINTER
          LRD    W1
          SRD    MP+1
          LDD    W0
          STDL   MP
          LDN    SAVL/4
          STD    T1          SET SIZE OF SAVE AREA
          LDN    0
          RJM    IMB
          CRML   SAVE,T1     RESTORE FROM MAINTENANCE REGISTER BUFFER 0
          LDM    DHSV
          STD    DH
          LDM    DHSV+1
          STD    DH+1
          LDM    DHSV+2      RESTORE DIRECTORY POINTER
          STD    DH+2
          LDN    VER4
          RJM    VCK         CHECK VERSION
          MJP    DFT5        IF LESS THAN VERSION 4
          LDN    BCWP
          RJM    IDA
          CRDL   BW          RE ESTABLISH BUFFER CONTROL WORD POINTER
          LJM    DFT5        RETURN

 PRSA     BSS    1
 PRSB     BSS    1           8/PP TYPE, 8/
 PRSC     BSS    3           OS BOUNDS
 SUM      SPACE  4,10
**        SUM - SET UP HARDWARE MODELS.
*
*         THIS ROUTINE SETS UP MODEL AND MAINTENANCE CHANNEL CONNECT CODES
*         FOR THE PROCESSOR, IOU, AND MEMORY ELEMENTS.
*
*         USES   T5.
*
*         CALLS  FHE.


 SUM      SUBR               ENTRY/EXIT
          LDN    PROCID      READ CPU0 DESCRIPTOR
          RJM    FHE
          MJP    PRS140      IF NOT FOUND
          LDM    HBUF+CPRE+EM  SAVE CPU0 MODEL
          SHN    -4
          STM    CPU0M
          LDM    HBUF+HDRPC  SAVE CPU0 CONNECT CODE
          STM    CP0CC
          LDM    HBUF+CPRPORT  SAVE CPU0 MEMORY PORT
          STM    CP0P
          LDC    PROCID1     READ CPU1 DESCRIPTOR
          RJM    FHE
          MJN    SUM1        IF NOT PRESENT
          LDM    HBUF+CPRE+EM  SAVE CPU1 MODEL
          SHN    -4
          STM    CPU1M
          LDM    HBUF+HDRPC  SAVE CPU1 CONNECT CODE
          STM    CP1CC
          LDM    HBUF+CPRPORT  SAVE CPU1 MEMORY PORT
          STM    CP1P
 SUM1     LDN    CMID        READ MEMORY DESCRIPTOR
          RJM    FHE
          MJP    PRS140      IF NOT FOUND
          LDM    HBUF+CPRE+EM  SAVE MEMORY MODEL
          SHN    -4
          STM    MEMM
          LDM    HBUF+CMIPC  SAVE MEMORY CONNECT CODE
          STM    CMCC
          LDM    IOUN
          ZJN    SUM3        IF PRIMARY DFT
          LDC    10000       SELECT IOU1
 SUM3     ADN    IOUID
          RJM    FHE
          MJP    PRS140      IF NOT FOUND
          LDM    HBUF+CPRE+EM  SAVE IOU MODEL
          SHN    -4
          STM    IOUM
          LDM    HBUF+HDRPC  SAVE IOU CONNECT CODE
          LPC    7417        EXTRACT RELEVANT FIELDS
          STM    I0CC
          LDN    0
          STD    T5
          LDC    10000       SELECT IOU1
          ADN    IOUID
          RJM    FHE         GET IOU ELEMENT
          MJN    SUM4        IF NOT FOUND
          LDM    HBUF+CIOST
          SHN    21-0
          MJN    SUM4        IF SECOND IOU IS LOGICALLY OFF
          AOD    T5          MAXIMUM IOU ORDINAL
 SUM4     LDD    T5          SET MAXIMUM IOU ORDINAL FIELD
          SHN    14-0
          RAML   IOUN
          LDN    DISCID      READ CONSOLE DESCRIPTOR
          RJM    FHE         FETCH HARDWARE ELEMENT
          LDM    HBUF+CDCPCI
          LMN    1
          LPN    1
          STM    PKFLG       PACKET FLAG IS SET IF A PC IS PRESENT
          LJM    SUMX        RETURN
 PEF      SPACE  4,10
**        PEF - PRESET EICB FIELDS.
*
*         ENTRY  IF DUAL STATE, THEN PP MUST BE A LOWER PP.
*
*         USES   T1 - T5.


 PEF      SUBR               ENTRY/EXIT

*         PRESET MESSAGE BUFFER.

          LDN    D7TY        TEST *EICB* LEVEL
          RJM    IIB
          CRDL   T1          READ *D7TY*
          LDD    T1+3
          SHN    -6          EXTRACT EICB REVISION LEVEL
          SBN    4
          MJN    PEFX        IF MESSAGE AREA NOT PRESENT
          LDN    3           SET CONSTANT 3
          STM    T3
          LDN    DFCM        SET MESSAGE ID = 1, LENGTH = 24
          RJM    IIB
          CWML   PEFA,ON
          CWML   PEFB,T3     BLANK FILL EICB MESSAGE BUFFER
          UJP    PEFX        RETURN

 PEFA     VFD    16/,16/24D,16/,16/1
 PEFB     DATA   24H
          QUAL   PRS
 QUAL$    EQU    0           UNQUALIFY PRESET COMMON DECKS
          LIST   X
*COPY     CTP$UPDATE_TIME_IN_EICB
          LIST   *
 SPB      SPACE  4,10
**        SPB - SPECIAL PRESET VERSION OF *SPB* - SET PP BOUNDS.
*
*         ENTRY  *DFT* IS ON THE SAME SIDE OF THE OS BOUNDS
*                AS THE *EICB*, OR ELSE OS BOUNDS CHECKING
*                IS NOT BEING DONE.


 SPB      SUBR               ENTRY/EXIT
          UJN    SPBX        RETURN
          QUAL   *
*         END    CTP$DFT PRESET

*DECK DECK=CTP$DFT_PRESET_BUILD_STRUCTURE EXPAND=FALSE
          OVERLAY (BUILD DFT STRUCTURE IN PRESET)

*         CTEXT  CTP$DFT_PRESET_BUILD_STRUCTURE
*
*         THIS DECK IS RESPONSIBLE FOR BUILDING THE DFT OS INTERFACE FOR DFT
*         VERSION 4 AND GREATER. THERE ARE TWO RECORDS USED BY THE ROUTINES IN THIS
*         DECK *DBD*, AND *ECR*. THESE RECORDS DEFINE THE DFT BUFFER AND THE ERROR
*         CONTROL INFORMATION. BOTH OF THESE RECORDS ARE ON THE CIP TAPE AND ARE UNIQUE
*         TO A PARTICULAR DFT CLASS.

 AOFF     EQU    MP
 RUPP     EQU    MP+1
 RLOW     EQU    MP+2


 BDS      SPACE  4,10
**        BDS - BUILD DFT STRUCTURE.
*
*         THIS ROUTINE DIRECTS THE INITIALIZATION OF THE DFT OS INTERFACE AREA WHICH
*         WAS ALLOCATED BY THE HOST OPERATING SYSTEM.


          ROUTINE  BDS

          RJM    VDS         VALIDATE DFT STRUCTURE
          ZJP    BDS6        IF STRUCTURE VALIDATED
          PJP    BDS6.5      IF VERSION 3 OR LESS AND ALREADY BUILT

*         NEXT INITIALIZE THE GLOBAL POINTER TO ALLOCATED SPACE

 BDS00    LDDL   DP
          STDL   AOFF
          LDDL   DP+1
          STDL   RUPP
          LDDL   DP+2
          STDL   RLOW

*         NEXT FUNCTION 2AP TO READ IN THE *DBD* RECORD FROM THE CDA

          LDC    0#210       FUNCTION TO READ THE CDA
          STML   CALB
          LDC    0402        UPPER 12 BITS OF NAME *DB*
          STML   CALB+1
          LDC    0400        LOWER 12 BITS OF NAME *D00*
          STML   CALB+2
          RJM    ECM         EXECUTE CIP MODULE
          LDML   CALB+1
          SBN    4
          PJP    BDS0        IF NO ERRORS
          SETDAN (EPUN,DAPZ)
          LDC    DAPZ+TDFT   61D - PRESET ALLOCATION SIZE FAILURE
          STML   RTP1
          CALL   ERRH


*         AT THIS POINT THE *DBD* RECORD IS IN THE 2AP OUTPUT BUFFER, NEXT BEGIN
*         BUILDING THE DFT POINTER BLOCK.

 BDS0     RJM    RBA         RESTORE 2P INPUT BUFFER ADDRESS
          LDDL   DP
          NJN    BDS1        IF OFFSET IS NON ZERO
          LDDL   DP+2        R-LOWER VALUE
          ZJN    BDS0.2      IF R-LOWER IS ZERO
 BDS0.1   SODL   DP+2
          LDC    0#40
          STDL   DP
          UJN    BDS1        GET HANDOFF TOTAL SIZE

 BDS0.2   SODL   DP+1        BORROW 1 UNIT FROM R-UPPER
          LDC    0#1000      SETUP R-LOWER
          STDL   DP+2
          UJN    BDS0.1      SET UP OFFSET VALUE

 BDS1     LDC    -1
          RJM    IDA
          CRDL   CM          READ IN HANDOFF TOTAL SIZE
          LDDL   T1          2AP BUFFER ADDRESS
          STML   BDSE        SAVE ADDRESS
          ADC    DBDH2
          STML   BDSA
          LDC    -1
          RJM    IDA
          CWML   **,ON       WRITE STRING DFTS TO BEGINNING OF DFT POINTER BLOCK
 BDSA     EQU    *-1
          LDDL   CM+3
          STML   BDSB        SAVE TOTAL SIZE FOR ERROR TEST
          LDDL   DP
          ADC    RR
          CRDL   W0          READ THE DFT CONTROL WORD
          LDML   DCWP0,T1
          STDL   W0          SAVE NUMBER OF POINTERS, SEQ NUMBER
          RJM    SLN         SET LEVEL NUMBER
          STML   BDSD        SAVE REVISED LEVEL NUMBER
          LDML   BDSE        RESTORE *2AP* BUFFER ADDRESS
          STDL   T1
          LDML   DCWP2,T1    DFT CONTROL WORD PARAMETER 2
          STDL   W2          SAVE LBUF, NBUF VALUES
          LDN    HDRP
          RJM    IDA
          CWDL   W0          RE-WRITE DFT HEADER WORD
          LDN    2
          STD    T2
          LDN    1
          RJM    IDA
          CRML   HANDOFF,T2  READ IN HANDOFF PARAMETERS
          LDDL   W0
          SHN    -10
          SBN    1
          STDL   T2          NUMBER OF CM WORDS TO MOVE
          LDDL   T1
          ADC    DCWP3+1
          STML   DBSD
          LDN    SECP
          RJM    IDA
          CWML   **,T2       MOVE POINTER WORD SKELETONS TO DFT BLOCK
 DBSD     EQU    *-1
          LDDL   T2
          ADN    1
          RJM    IRP         INCREMENT R POINTER TO STRUCTURE
          RJM    WTF         WRITE TRAILER FIELD (DFTE)

*         DEFINE THE SECDED ID TABLE

          RJM    WHF         WRITE HEADER FIELD (DFTS)
          LDN    SECP
          RJM    DBS         DEFINE BUFFER SIZE
          RJM    WTF         WRITE TRAILER FIELD (DFTE)

*         DEFINE THE MAINTENANCE REGISTER BUFFERS

          RJM    WHF         WRITE HEADER FIELD (DFTS)
          LDN    MRBP
          RJM    DBS         DEFINE SPACE FOR MAINTENANCE REGISTER BUFFERS
          RJM    WTF         WRITE TRAILER FIELD (DFTE)

*         DEFINE THE OS REQUEST AND PP RESIDENT POINTERS FROM HANDOFF PARAMETERS

          LDN    D7TY
          RJM    IIB
          CRDL   CM
          LDDL   CM+3
          SHN    -14
          NJN    BDS3        IF NOT 180 STANDALONE
          LDN    NVEP        VE REQUEST POINTER
          RJM    IDA
          CWML   HANDOFF+4,ON   WRITE 180 REQUEST POINTER TO PROPER LOCATION IN DFT POINTERS
          UJN    BDS4

 BDS3     LDN    2
          STD    T2
          LDN    C17P        PP RESIDENT POINTER
          RJM    IDA
          CWML   HANDOFF,T2  WRITE PP RESIDENT AND OS REQUEST POINTER

*         BUILD THE BUFFER CONTROL WORD AREA

 BDS4     RJM    WHF         WRITE HEADER FIELD (DFTS)
          LDN    BCWP
          RJM    DBS         DEFINE BUFFER SIZE
          RJM    WTF         WRITE TRAILER FIELD (DFTE)
          RJM    DBW         DEFINE BUFFER CONTROL WORD BUFFER INTERNAL STRUCTURE

*         BUILD THE MAINFRAME ELEMENT COUNTERS BUFFER

          RJM    WHF         WRITE HEADER FIELD (DFTS)
          LDN    MECP
          RJM    DBS         DEFINE BUFFER SIZE
          RJM    WTF         WRITE TRAILER FIELD (DFTE)
          RJM    DEC         DEFINE THE ELEMENT COUNTER DATA

*         BUILD THE ERROR CONTROL RECORD

          RJM    WHF         WRITE HEADER FIELD (DFTS)
          LDN    ECRP
          RJM    DBS         DEFINE BUFFER SIZE
          RJM    WTF         WRITE TRAILER FIELD (DFTE)
          RJM    DER         DEFINE ERROR CONTROL RECORD INTERNAL STRUCTURE
          RJM    RBA

*         DEFINE THE SUPPORTIVE STATUS BUFFER

          RJM    WHF         WRITE HEADER FIELD (DFTS)
          LDN    SSBP
          RJM    IDA
          CRML   DSSA,ON     READ IN THE BUFFER DEFINITION PARAMETERS
          LDN    SSBP
          RJM    DBS         DEFINE BUFFER SIZE
          RJM    WTF         WRITE TRAILER FIELD (DFTE)
          RJM    DSS         DEFINE THE INTERNAL STRUCTURE OF SUPPORTIVE STATUS

*         DEFINE THE NON REGISTER STATUS AREA

          RJM    WHF         WRITE HEADER FIELD (DFTS)
          LDN    NRSP
          RJM    IDA
          CRML   DNRA,ON     READ IN BUFFER DEFINITION PARAMETERS
          LDN    NRSP
          RJM    DBS         DEFINE BUFFER SIZE
          RJM    WTF         WRITE TRAILER FIELD (DFTE)
          RJM    DNR         DEFINE NON REGISTER DATA AREA

*         DEFINE DFT CM RESIDENT AREA

          RJM    WHF         WRITE HEADER FIELD (DFTS)
          LDN    DCMP
          RJM    DBS         DEFINE BUFFER SIZE
          RJM    WTF         WRITE TRAILER FIELD (DFTE)

*         DEFINE PP REGISTER SAVE AREA FOR VERSION 5 OR GREATER

          RJM    WHF         WRITE HEADER FIELD (DFTS)
          LDN    PRDP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   CM          GET HEADER DEFINITION
          LDDL   CM+2
          STDL   CM+3
          LDN    0
          STM    CM+2
          LDN    PRDP
          RJM    DBS         DEFINE BUFFER SIZE
          LDN    PRDP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0          POINTER WORD
          LRD    W1
          LDDL   W0
          ADC    RR
          CWDL   CM          INITIALIZE HEADER WORD
          RJM    WTF         WRITE TRAILER FIELD (DFTE)

*         DEFINE A SECONDARY *DFT* BUFFER IF THE LENGTH FIELD FROM THE
*         SECONDARY *DFT* BUFFER POINTER IN THE *DBD* IS NON-ZERO, AND
*         A SECOND IOU IS PRESENT.

          LDN    SDBP        EXAMINE LENGTH FIELD
          RJM    IDA
          CRDL   W0
          LDML   W3
          ZJN    BDS4.1      IF LENGTH IS DEFINED TO BE ZERO
          ADN    2           ACCOUNT FOR *DFTS* AND *DFTE*
          STML   BDSF        SAVE SIZE OF UNALLOCATED SECONDARY BUFFER
          LDML   IOUN        CHECK FOR NUMBER OF IOUS
          SHN    -14
          ZJN    BDS4.2      IF ONLY ONE IOU
          RJM    WHF         WRITE HEADER FIELD (DFTS)
          LDN    SDBP
          RJM    DBS         DEFINE BUFFER SIZE
          RJM    WTF         WRITE TRAILER FIELD (DFTE)
 BDS4.1   LDN    0           SAVE SIZE OF UNALLOCATED SECONDARY BUFFER
          STML   BDSF
          UJN    BDS4.3      DEFINE MODEL DEPENDENT BUFFER

 BDS4.2   LDN    SDBP        ZERO OUT LENGTH IN SECONDARY POINTER
          RJM    IDA
          CRDL   W0
          LDN    0
          STDL   W3
          LDN    SDBP
          RJM    IDA
          CWDL   W0

*         DEFINE THE MODEL DEPENDENT BUFFER.

 BDS4.3   LDN    MDLP
          RJM    IDA
          CRDL   W0          READ IN THE MDB POINTER WORD
          LDDL   W3
          ZJP    BDS5        IF NO MODEL DEPENDENT BUFFER TO ALLOCATE
          RJM    DMB         DEFINE MODEL DEPENDENT BUFFER
 BDS5     LDML   BDSB        SIZE OF ALLOCATED AREA
          SBML   BDSC        SIZE OF AREA JUST BUILT
          SBML   BDSF        ACCOUNT FOR UNALLOCATED SECONDARY *DFT* BUFFER
          NJN    BDS7        IF AREAS DO NOT MATCH

 BDS6     LDN    NRSP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0          READ IN NRSB POINTER
          LRD    W1
          LDD    W0
          ADC    RR
          CRDL   W0          READ IN THE NRSB HEADER WORD
          LDDL   W2
          STML   NNRB        NUMBER OF NON REGISTER BUFFERS
          LDDL   W3
          STML   SNRB        SIZE OF NON REGISTER BUFFERS

 BDS6.5   CALL   PSO         PRESET STANDARD OVERLAY

*         NOTE THAT NO RETURN IS MADE BACK HERE. THE RETURN IS MADE
*         FROM *PSO* BACK TO THE MAIN LOOP.

 BDS7     SETDAN (EPUN,DAPZ)
          LDC    DAPZ+TDFT   61D - PRESET ALLOCATION SIZE FAILURE
          STML   RTP1
          CALL   ERRH

 BDSB     CON    0           TOTAL SIZE ALLOCATED BY O.S.
 BDSC     CON    1           TOTAL SIZE BUILT BY DFT
 BDSD     BSS    1           STRUCTURE VERSION
 BDSE     BSS    1           OFFSET TO START OF *DBD* IN *2AP* BUFFER
 BDSF     CON    0           SIZE OF UNALLOCATED SECONDARY *DFT* BUFFER

 HANDOFF  BSSZ   10          BUFFER FOR HANDOFF WORDS
 IRP      SPACE  4,10
**        IRP - INCREMENT R POINTER TO STRUCTURE
*
*         ENTRY  (A) = AMMOUNT TO INCREMENT BASE POINTER
*                BASE POINTER IS DEFINED BY *AOFF*, *RUPP*, *RLOW*.
*
*         EXIT   BASE R POINTER HAS BEEN UPDATED AND A OFFSET PORTION
*                IS MODULO 100(8).
*
*         USES   T7.


 IRP      SUBR               ENTRY/EXIT
          STML   IRPA
          RAML   BDSC
          LDML   IRPA
          RADL   AOFF
          SHN    -6
          NJN    IRP1        IF ROLLED OVER 100(8) IN SIZE
          UJN    IRPX

 IRP1     STDL   T7
          LDDL   AOFF
          LPN    77
          STDL   AOFF
          LDDL   T7
          RADL   RLOW
          SHN    -14
          NJN    IRP2        IF CARRY OVER
          UJN    IRPX

 IRP2     STDL   T7
          LDDL   RLOW
          LPC    0#FFF
          STDL   RLOW
          LDDL   T7
          RADL   RUPP
          LJM    IRPX

 IRPA     CON    0
 WHF      SPACE  4,10
**        WHF - WRITE HEADER FIELD.
*
*         THIS ROUTINE WILL WRITE THE STRING *DFTS* TO THE BEGINNING OF A TABLE
*         STRUCTURE. THE GLOBAL R POINTER TO THE STRUCTURE WILL BE INCREMENTED TO
*         REFLECT THE SPACE USED.
*         THIS CODE ASSUMES THAT DBDHPR2 HOLDS THE STRING VALUE TO INITIALIZE TABLE HEAD TO.

 WHF      SUBR               ENTRY/EXIT
          LDDL   T1
          ADC    DBDH2
          STML   WHFA
          LRD    RUPP
          LDDL   AOFF
          ADC    RR
          CWML   **,ON       WRITE INITIALIZATION STRING TO BEGINNING OF TABLE
 WHFA     EQU    *-1
          LDN    1
          RJM    IRP
          UJN    WHFX        RETURN
 WTF      SPACE  4,10
**        WTF - WRITE TRAILER FIELD.
*
*         THIS ROUTINE WILL WRITE THE STRING *DFTE* TO THE END OF A TABLE
*         STRUCTURE. THE GLOBAL R POINTER TO THE STRUCTURE WILL BE INCREMENTED TO
*         REFLECT THE SPACE USED.
*         THIS CODE ASSUMES THAT DBDHPR3 HOLDS THE STRING VALUE TO INITIALIZE TABLE END TO.

 WTF      SUBR               ENTRY/EXIT
          LDDL   T1
          ADC    DBDH3
          STML   WTFA
          LRD    RUPP
          LDDL   AOFF
          ADC    RR
          CWML   **,ON       WRITE INITIALIZATION STRING TO END OF TABLE
 WTFA     EQU    *-1
          LDN    1
          RJM    IRP
          UJN    WTFX        RETURN
 DBS      SPACE  4,10
**        DBS - DEFINE BUFFER SIZE.
*
*         ENTRY  (A) = ORDINAL OF THE DFT POINTER WORD
*
*         USES   T7, AOFF, RUPP, RLOW.
*
*         CALLS  IDA, IRP.


 DBS      SUBR               ENTRY/EXIT
          STD    T7
          RJM    IDA
          CRML   DBSA,ON
          LDML   AOFF
          STML   DBSA        STORE CURRENT STRUCTURE A OFFSET
          LDML   RUPP
          STML   DBSA+1      STORE CURRENT STRUCTURE R UPPER
          LDML   RLOW
          STML   DBSA+2      STORE CURRENT STRUCTURE R LOWER
          LDDL   T7
          RJM    IDA
          CWML   DBSA,ON     REWRITE CURRENT DFT POINTER WORD
          LDML   DBSA+3
          RJM    IRP         INCREMENT R POINTER FOR STRUCTURE
          UJN    DBSX

 DBSA     BSSZ   4           BUFFER FOR DFT POINTER WORD
 DMB      SPACE  4,10
**        DMB - DEFINE MODEL DEPENDENT BUFFER.
*
*         ENTRY  GLOBAL STRUCTURE POINTER (AOFF, RUPP, RLOW) DEFINED
*
*         EXIT   MODEL DEPENDENT BUFFER STRUCTURE DEFINED
*
*         USES   W0 - W3.
*
*         CALLS  IDA, IRP, ACB, FHE, WTF, WHF.


 DMB      SUBR               ENTRY/EXIT
          RJM    WHF         WRITE HEADER FIELD (DFTS)
          LDN    MDLP
          RJM    IDA
          CRDL   W0          GET EXISTING MDB POINTER WORD
          LDDL   AOFF
          STDL   W0          REPLACE A OFFSET WITH CURRENT ONE
          LDDL   RUPP
          STDL   W1          REPLACE R UPPER WITH CURRENT ONE
          LDDL   RLOW
          STDL   W2          REPLACE R LOWER WITH CURRENT ONE
          LDN    MDLP
          RJM    IDA
          CWDL   W0          RE WRITE MDB DFT POINTER WORD
          LDDL   W3
          RJM    IRP         INCREMENT GLOBAL STRUCTURE POINTER BY MDB LENGTH
          RJM    WTF         WRITE TRAILER FIELD (DFTE)

*         DEFINE THE PRIMARY CPU BUFFER

          RJM    WHF         WRITE HEADER FIELD (DFTS)
          LDN    0           CPU 0
          RJM    DCB         DEFINE CPU0 BUFFER
          RJM    WTF         WRITE TRAILER FIELD (DFTE)
          LDC    PROCID1
          RJM    FHE         LOOK FOR SECOND PROCESSOR
          MJN    DMB1        IF SINGLE CPU

*         DEFINE THE SECOND PROCESSOR BUFFER

          RJM    RBA         REBUILD BUFFER ADDRESS
          RJM    WHF         WRITE HEADER FIELD (DFTS)
          LDN    1           CPU 1
          RJM    DCB         DEFINE CPU1 BUFFER
          RJM    WTF         WRITE TRAILER FIELD (DFTE)
          UJN    DMB2

*         ADJUST SIZE FOR ONLY ONE PROCESSOR

 DMB1     RJM    RBA         REBUILD BUFFER ADDRESS
          LDML   BDSC
          ADN    2           FOR HEADER/TRAILER ON MISSING BUFFER
          STML   BDSC

*         DEFINE THE OVERFLOW BUFFER

 DMB2     RJM    WHF         WRITE HEADER FIELD (DFTS)
          LDN    2           OVERFLOW BUFFER
          RJM    DCB         DEFINE OVERFLOW CPU BUFFER
          RJM    WTF         WRITE TRAILER FIELD (DFTE)
          LJM    DMBX
 DCB      SPACE  4,10
**        DCB - DEFINE CPU BUFFER.
*
*         ENTRY  (A) = CPU OFFSET (0, 1, 2)
*
*         EXIT   CPU MODEL DEPENDENT BUFFER ESTABLISHED
*
*         USES   T1, T7, W4 - W7.
*
*         CALLS  IDA, IRP.


 DCB      SUBR               ENTRY/EXIT
          STD    T7
          LDN    MDLP
          RJM    IDA
          CRDL   W0          READ IN MDB POINTER WORD
          LDDL   W0
          LRD    W1
          ADD    T7
          ADC    RR
          CRDL   W4          READ IN CPU BUFFER POINTER
          RJM    RBA         RESTORE BUFFER ADDRESS
          LDML   MDBSIZE,T1
          STDL   W7
          LDDL   AOFF        CURRENT A OFFSET
          STDL   W4
          LDDL   RUPP        CURRENT R UPPER
          STDL   W5
          LDDL   RLOW
          STDL   W6          CURRENT R LOWER
          LDDL   W0
          ADD    T7
          ADC    RR
          CWDL   W4          DEFINE CPU BUFFER POINTER
          LDDL   W7          GET BUFFER SIZE
          RJM    IRP         UPDATE GLOBAL STRUCTURE POINTER
          LJM    DCBX        RETURN
 DBW      SPACE  4,10
**        DBW - DEFINE BUFFER CONTROL WORDS.
*
*         ENTRY  (T1) IS POINTER TO DFT DEFINITION BUFFER.
*
*         EXIT   BUFFER CONTROL WORD OFFSET FIELDS DEFINED.
*
*         USES   W0 - W3.
*
*         CALLS  IDA.


 DBW      SUBR               ENTRY/EXIT
          LDML   DCWP2,T1    LBUF PARAMETER
          SHN    -10
          STD    T2
          LDN    BCWP
          RJM    IDA
          CRDL   W0          READ IN BUFFER CONTROL POINTER WORD
          SODL   W3          FOR COUNTING
          LRD    W1
 DBW1     LDDL   W0
          ADC    RR
          CWML   DBWA,ON     WRITE CONTROL WORD
          LDD    T2
          RAML   DBWA+3      UPDATE OFFSET BY LBUF
          AODL   W0          NEXT INDEX TO CONTROL WORD
          SODL   W3
          PJN    DBW1        IF NOT DONE
          LJM    DBWX

 DBWA     BSSZ   4           BUFFER CONTROL WORD BUFFER
 DER      SPACE  4,10
**        DER - DEFINE DFT ERROR CONTROL RECORD.
*
*         USES   W0 - W7.
*
*         CALLS  FINDCM, IDA


 DER      SUBR               ENTRY/EXIT
          LDN    ECRP
          RJM    IDA
          CRDL   W4
          FINDCM ECR         GET THE ERROR CONTROL RECORD
          ADN    2           GET BY HEADER WORDS
          CRML   DERA,W7    READ ERROR CONTROL RECORD INTO DFT BUFFER
          LDDL   W4
          LRD    W5
          ADC    RR
          CWML   DERA,W7    WRITE TO ERROR CONTROL RECORD IN CENTRAL MEMORY
          UJN    DERX

 DERA     BSSZ   500         SIZE FOR BIGGEST ERROR CONTROL RECORD
 DEC      SPACE  4,10
**        DEC - DEFINE ELEMENT COUNTERS.
*
*         EXIT   ELEMENT COUNTER IDS ARE INITIALIZED IN THE ELEMENT
*                COUNTERS BUFFER.
*
*         USES   T2, W0 - W3.
*
*         CALLS  IDA.


 DEC      SUBR               ENTRY/EXIT
          LDN    MECP
          RJM    IDA
          CRDL   W0          GET ELEMENT COUNTERS POINTER WORD
          SODL   W3          FOR COUNTING
          LRD    W1
          LDDL   T1
          STDL   T2          INITIALIZE OFFSET TO BUFFER BEGINNING
 DEC1     LDML   DBDH4,T2
          LMC    0#FF        TERMINATOR TAG
          ZJN    DECX        IF DONE
          LDML   DBDH4,T2
          STML   DECA
          LDD    W0
          ADC    RR
          CWML   DECA,ON
          AODL   T2          SET INDEX TO NEXT ID
          AOD    W0
          SOD    W3          DECREASE NUMBER OF ELEMENTS BY ONE
          PJN    DEC1        IF MORE TO DO
          UJN    DECX

 DECA     BSSZ   4           ELEMENT COUNTER WORD BUFFER
 DSS      SPACE  4,10
**        DSS - DEFINE SUPPORTIVE STATUS BUFFER
*
*         ENTRY  (T1) POINTS TO THE 2AP INPUT BUFFER HOLDING DBD
*
*         USES   W0 - W3.
*
*         CALLS  IDA.


 DSS      SUBR               ENTRY/EXIT
          LDML   DSSA+2
          STML   DSSA+3      SAVE ELEMENT SIZE
          LDML   DCWP2,T1
          LPC    0#FF
          STML   DSSA+2      SAVE NUMBER OF ELEMENTS
          LDN    SSBP
          RJM    IDA
          CRDL   W0          READ SUPPORTIVE STATUS POINTER
          LRD    W1
          LDD    W0
          ADC    RR
          CWML   DSSA,ON     WRITE SUPPORTIVE STATUS BUFFER HEADER
          UJN    DSSX

 DSSA     BSSZ   4           SUPPORTIVE STATUS HEADER
 DNR      SPACE  4,10
**        DNR - DEFINE NON RESIDENT STATUS BUFFER.
*
*         EXIT   NON RESIDENT STATUS BUFFER HEADER WORD DEFINES
*
*         USES   W0 - W3.
*
*         CALLS  IDA.


 DNR      SUBR               EMTRY/EXIT
          LDML   DNRA+2
          STML   DNRA+3
          LDML   DNRA+1
          STML   DNRA+2
          LDN    0
          STM    DNRA+1
          LDN    NRSP
          RJM    IDA
          CRDL   W0          READ IN DFT POINTER WORD
          LRD    W1
          LDD    W0
          ADC    RR
          CWML   DNRA,ON     WRITE NON REGISTER STATUS HEADER
          UJN    DNRX

 DNRA     BSSZ   4           NON REGISTER STATUS BUFFER HEADER WORD
 RBA      SPACE  4,10
**        RBA - RESTORE BUFFER ADDRESS.
*
*         EXIT   (T1) = OFFSET TO BEGINNING OF *DBD* DATA IN *2AP* BUFFER.
*
*         NOTE   ON THE CYBER 930 AND ON THOSE MAINFRAMES WITH A MODEL 44
*                IOU, IT IS NECESSARY TO ADD 24(8) MORE WORDS TO THE SIZE OF
*                THE 7700 TABLE.  THE TOTAL 7700 TABLE OFFSET IS KEPT IN
*                T1 WHICH MUST REMAIN VALID THRU EXECUTION OF THIS OVERLAY.


 RBA      SUBR               ENTRY/EXIT
          LDML   IOUM        CHECK IOU MODEL NUMBER
          LMC    0#43
          ZJN    RBA0        IF MODEL 43 IOU
          LMN    0#44&0#43
          ZJN    RBA0        IF MODEL 44 IOU
          LDM    CPU0M
          SHN    -4
          LMN    5
          NJN    RBA1        IF NOT AN S0
 RBA0     LDML   TOUB
          ADN    24
          UJN    RBA2        SAVE TABLE OFFSET

 RBA1     LDML   TOUB
 RBA2     STDL   T1
          UJN    RBAX        RETURN
 SLN      SPACE  4,10
**        SLN - SET LEVEL NUMBER OF DFT BUFFER STRUCTURE.
*
*         IF THE REVISION SET IN CENTRAL MEMORY BY THE OS IS
*         LESS THAN 5 THEN NO MODIFICATION OF THE REVISION LEVEL IS MADE.
*         IF THE OS BOOTS ARE NOT INSTALLED (ERGO 170 STANDALONE) THEN
*         THE REVISION LEVEL IS OBTAINED FROM THE *DBD* RECORD.
*         IF THE BOOTS ARE INSTALLED THEN THE REVISION LEVEL FROM THE
*         DFT DESCRIPTOR IS USED.
*
*         ENTRY  (W1) = 8/HEADER LEVEL NUMBER, 8/PP NUMBER.
*
*         EXIT   (A) = REVISED HEADER LEVEL NUMBER.
*                (W1) = 8/REVISED HEADER LEVEL NUMBER, 8/PP NUMBER.
*
*         USES   T1, T2, W1.
*
*         CALLS  FHE.


 SLN      SUBR               ENTRY/EXIT
          LDDL   T1
          STML   SLNB        SAVE 2AP ADDRESS
          LDDL   W1
          SHN    -10
          NJN    SLN1        IF NOT VERSION 4
          LDN    VER4
 SLN1     STML   SLNA        SAVE LEVEL NUMBER PASSED BY OS
          LDDL   W1          CLEAR LEVEL NUMBER FIELD
          LPC    0#FF
          STDL   W1
 SLN2     LDML   SLNA        HEADER VERSION NUMBER
          SBN    VER5
          MJN    SLN3        IF LESS THAN VERSION 5
          LDN    DFTID
          RJM    FHE         FIND HARDWARE ELEMENT
          LDML   HBUF+DOBIV
          SHN    -6
          STDL   T2          VALUE FROM DESCRIPTOR
          LMN    77
          ZJN    SLN5        IF BOOT NOT INSTALLED
          LDDL   T2
          STML   SLNA
 SLN3     LDML   SLNA        SET REVISED LEVEL NUMBER
          SHN    10
 SLN4     LMDL   W1
          STDL   W1
          LDML   SLNA
          UJP    SLNX        RETURN

 SLN5     LDML   SLNB
          STDL   T1
          LDML   DCWP1,T1    GET REVISION LEVEL FROM THE *DBD* RECORD
          LPC    0#FF00
          UJN    SLN4

 SLNA     BSS    1           INITIAL HEADER LEVEL NUMBER
 SLNB     BSS    1           2AP BUFFER ADDRESS
 VDS      SPACE  4,10
**        VDS - VALIDATE DFT STRUCTURE.
*
*         EXIT   (A) < 0 STRUCTURE NOT VALIDATED.
*                (A) = 0 STRUCTURE VALIDATED.
*                (A) > 0 STRUCTURE IS VERSION 3 OR LESS AND IS BUILT
*
*         CALLS  IDA, VCK.
*
*         USES   CM - CM+3, W0 - W3.

 VDS00    LDN    1
          UJN    VDSX

 VDS0     LCN    0           MINUS EXIT CONDITION
 VDS      SUBR               ENTRY/EXIT
          LDN    HDRP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   CM          GET RLI HANDOFF FIELD
          LDDL   CM+1
          SHN    -10
          ZJN    VDS0        IF VERSION 4 BUILD STRUCTURE
          SBN    VER4
          MJN    VDS00       IF VERSION 3 OR LESS THE STRUCTURE IS ALREADY BUILT
          UJN    VDS2

 VDS1     LDN    0
          UJN    VDSX        RETURN

 VDS2     LDDL   CM
          SHN    -10
          LPN    0#F
          ZJP    VDS0        IF STRUCTURE NEEDS TO BE BUILT
          SBN    1
          STD    T7          SAVE NUMBER OF POINTER WORDS
 VDS3     LDD    T7
          RJM    IDA         INCREMENT DFT POINTER ADDRESS
          CRDL   W0
          LDDL   W0
          ADDL   W1
          ADDL   W2
          ADDL   W3
          ZJN    VDS4        IF NIL POINTER WORD
          LDDL   W3
          ADDL   W0
          LRD    W1
          ADC    RR
          CRDL   CM
          LDDL   CM
          LMC    0#4446
          NJP    VDS0        IF NO MATCH
          LDDL   CM+1
          LMC    0#5445
          NJP    VDS0        IF NO MATCH
 VDS4     SOD    T7
          SBN    6
          ZJP    VDS5        IF AT OS REQUEST POINTERS
          LDD    T7
          ZJP    VDS1        IF AT END OF POINTERS
          UJP    VDS3

 VDS5     LDD    T7
          SBN    3
          STD    T7          SKIP OS REQUEST POINTERS
          UJP    VDS3

          OVERFLOW 5700

*         END CTP$DFT_PRESET_BUILD_STRUCTURE
*DECK DECK=CTP$DFT_PRESET_DUAL_I4 EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_PRESET_DUAL_I4
*
*         THIS DECK CONTAINS PRESET CODE NECESSARY FOR DUAL
*         IOU SUPPORT.
 PDI      SPACE  4,10
**        PDI - PRESET DUAL IOU.
*
*         USES   IOUN.
*
*         CALLS  *BSB*, SOS, SPB.


 PDI1     LRD    DP+1        PUT *DFT-S* ON SIDE OF BOUNDS WITH BUFFER
          RJM    SPB         SET OS BOUNDS
          CALL   BSB         BUILD SECONDARY DFT BUFFER

 PDI      SUBR               ENTRY/EXIT
          LDM    IOUN
          ZJN    PDIX        IF *DFT*

*         IF NOT DUAL STATE, THEN DO NOT INITIALIZE OS BOUNDS CHECKING.
*         NOTE THAT THIS CODE IS ONLY EXECUTED IN IOU1 AND THEN VE
*         MUST BE UP (SINCE IT IS THE ONE TO MAKE THE REQUEST TO START
*         UP DFT IN IOU1).  SO, IT IS ONLY NECESSARY TO CHECK FOR
*         THE PRESENCE OF A 170 OS.

          LDN    D7TY        EXTRACT 170 OS TYPE FIELD
          RJM    IIB
          CRDL   W0
          LDDL   W3
          SHN    -14
          STDL   T1
          LDDL   W2
          LPN    3
          SHN    4
          LMDL   T1
          ZJP    PDI1        IF NOT DUAL STATE

*         SET OS BOUNDS FOR ALL PP-S.

          RJM    SOS         SET OS BOUNDS
          UJP    PDI1        BUILD SECONDARY DFT BUFFER
 ISD      SPACE  4,10
**        ISD - IDLE SECONDARY DRIVERS.
*
*         USES   IOUN.
*
*         CALLS  *IAD*.


 ISD      SUBR               ENTRY/EXIT

*         WHEN RUNNING IN THE SECONDARY IOU, IDLE ALL PP'S,
*         MASTER CLEAR AND DCN CHANNELS.

          LDM    IOUN
          ZJN    ISDX        IF IOU0
          CALL   IAD         IDLE ALL DRIVERS
          UJN    ISDX        RETURN
 SOS      SPACE  4,10
**        SOS - SET OS BOUNDS.
*
*         ENTRY  (PRSC - PRSC+2) = OS BOUNDS.


 SOS      SUBR               ENTRY/EXIT
          LDN    IOSB
          STDL   RN
          LDM    I0CC
          RJM    RMR         READ MAINTENANCE REGISTER
          LDN    0           SET ALL PPS TO BE UPPER PPS
          STML   RDATA+0     BARREL 0
          STML   RDATA+1     BARREL 1
          STML   RDATA+2     BARREL 2
          STML   RDATA+3     BARREL 3
          LDML   RDATA+5
          LPC    0#FFFC
          STML   RDATA+5
          LDML   PRSC
          LPN    3
          RAML   RDATA+5
          LDML   PRSC+1
          STML   RDATA+6
          LDML   PRSC+2
          STML   RDATA+7
          WRITMR RDATA,I0CC
          LDML   IOUM
          LMC    0#43
          ZJP    SOSX        IF MODEL 43 IOU
          LMN    0#44&0#43
          ZJP    SOSX        IF MODEL 44 IOU
          LDN    OIMR        CHECK IF CIO SUBSYSTEM IS PRESENT
          STDL   RN
          LDM    I0CC
          RJM    RMR         READ MAINTENANCE REGISTER
          LDML   RDATA+7
          SHN    21-7
          PJP    SOSX        IF CIO SUBSYSTEM IS NOT PRESENT
          LDN    CIFSM
          STDL   RN
          LDM    I0CC
          RJM    RMR         READ MAINTENANCE REGISTER
          LDN    0
          STML   RDATA+0
          STML   RDATA+1
          WRITMR RDATA,I0CC
          UJP    SOSX        RETURN

*         END    CTP$DFT_PRESET_DUAL_I4



*DECK DECK=CTP$DFT_PRESET_DUAL_I4_OVL EXPAND=FALSE
          OVERLAY  (DUAL I4 PRESET FOR IOU1),4200

*         CTEXT  CTP$DFT_PRESET_DUAL_I4_OVL
*
*         THIS DECK CONTAINS A PRESET OVERLAY USED IN DUAL
*         IOU APPLICATIONS.
 BSB      SPACE  4,10
**        BSB - BUILD SECONDARY DFT BUFFER.
*
*         USES   T7, W0 - W7.
*
*         CALLS  IDA, IIB, SPB, *ERRH*.


          ROUTINE  BSB

*         RETRIEVE INFORMATION FROM PRIMARY *DFT* BUFFER.

          LDN    DSCM+3      READ POINTER TO PRIMARY *DFT* BUFFER
          RJM    IIB
          CRDL   W0
          LRD    W1          SET R-REGISTER
          LDDL   W0          READ *START OF TABLE* WORD
          ADC    RR
          SBN    1
          CRML   BSBA,ON
          CRML   BSBB,ON     READ CONTROL WORD
          ADK    MECP-1
          CRML   BSBM,ON     READ *DFT* MAINFRAME ELEMENTS COUNTER POINTER
          ADK    ECRP-MECP-1
          CRML   BSBN,ON     READ *DFT* ERROR CONTROL RECORD POINTER
          ADK    SSBP-ECRP-1
          CRDL   W4          READ *DFT* SUPPORTIVE STATUS BUFFERS POINTER
          ADK    NRSP-SSBP
          CRML   BSBK,ON     READ *DFT* NON REGISTER STATUS BUFFER POINTER
          ADK    DCMP-NRSP-1
          CRML   BSBE,ON     READ *DFT* CENTRAL MEMORY RESIDENT AREA POINTER
          ADK    PRDP-DCMP-1
          CRML   BSBL,ON     READ *DFT* PP REGISTER SAVE AREA POINTER
          LDML   BSBB        GET NUMBER OF POINTER WORDS
          SHN    -10
          STML   BSBG
          ADDL   W0          READ *END OF TABLE* WORD
          ADC    RR
          CRML   BSBF,ON
          LRD    W5          READ SUPPORTIVE STATUS HEADER WORD
          LDDL   W4
          ADC    RR
          CRML   BSBI,ON

*         CONSTRUCT NEW CONTROL WORD.

          LDML   BSBB        NUMBER OF POINTER WORDS
          LPC    0#FF00      START SEQUENCE AT ZERO
          STML   BSBB
          LDML   //PPNO      EXTRACT PP NUMBER
          LPC    0#FF
          STDL   T7
          LDML   BSBB+1      EXTRACT REVISION LEVEL
          LPC    0#FF00
          ADD    T7          ADD ASSIGNED PP NUMBER
          STML   BSBB+1
          LDML   BSBB+2      EXTRACT *LBUF*
          LPC    0#FF00
          LMN    1           SET NUMBER OF BUFFERS TO 1
          STML   BSBB+2
          LDN    0           SET ALL FLAGS TO ZERO
          STML   BSBB+3

*         CONSTRUCT NEW SUPPORTIVE STATUS HEADER WORD.

          LDN    1           NUMBER OF SUPPORTIVE STATUS BUFFERS
          STML   BSBI+2

*         CONSTRUCT POINTER WORDS.

          LDN    DSCM+3      GET POINTER TO SECONDARY *DFT* BUFFER
          RJM    IIB
          CRDL   W4
          LRD    W5
          LDDL   W4
          ADC    RR+SDBP
          CRDL   W4
          CRML   BSBC,ON
          SBN    1
          CRML   BSBD,ON
          SBN    1
          CRML   BSBJ,ON
          LDML   BSBG        NUMBER OF POINTER WORDS
          ADK    2           OFFSET FOR END/START TABLE WORDS
          RAML   BSBD        BUFFER CONTROL WORD POINTER OFFSET
          ADK    1+2         OFFSET FOR CONTROL WORD/END/START TABLE WORDS
          STML   BSBC        MAINTENANCE REGISTER BUFFER POINTER
          LDN    1           BUFFER CONTROL WORD POINTER LENGTH
          STML   BSBD+3
          LDML   BSBB+2      BUFFER LENGTH
          SHN    -10
          STML   BSBC+3      MAINTENANCE REGISTER BUFFER POINTER LENGTH
          STML   BSBH
          ADML   BSBC        OFFSET FOR MAINTENANCE REGISTER BUFFER
          ADK    2           OFFSET FOR END/START TABLE WORDS
          STML   BSBJ        SUPPORTIVE STATUS OFFSET
          LDML   BSBI+3      SUPPORTIVE STATUS ENTRY LENGTH
          ADK    1           ACCOUNT FOR HEADER WORD
          STML   BSBJ+3      SUPPORTIVE STATUS POINTER LENGTH

*         ENSURE THAT ENOUGH SPACE WAS ALLOCATED.

          ADML   BSBJ        LAST OFFSET
          SBDL   W4          OFFSET TO BUFFER START
          STDL   T7
          LDDL   W7          ALLOCATED SIZE
          SBDL   T7          NEEDED SIZE
          PJP    BSB1        IF ALLOCATED SIZE >= NEEDED SIZE

*         RESET THE DFT BUFFER POINTER TO THE PRIMARY CONTROL BLOCK.

          LDN    DSCM+3
          RJM    IIB         INCREMENT INTERFACE BLOCK
          CRDL   DP
          SETDAN (EPUN,DASB) SECONDARY BUFFER TOO SMALL
          LDD    T7
          STM    BSBER+3
          LDD    W7
          STM    BSBER+2
          LDN    NRSP        NON REGISTER STATUS BUFFER
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0
          LRD    W1
          LDDL   W0
          ADC    RR+NRSBL+1  BASE SIZE + HEADER WORD
          CWML   BSBER,ON     WRITE ERROR CODE TO SCRATCH SUPPORTIVE STATUS
          LDN    NRSBL
          STM    LLOG        LENGTH TO LOG
          LDC    DASB+TDFT
          STML   RTP1
          CALL   ERRH        LOG THE ERROR

*         ZERO OUT SECONDARY DFT BUFFER.

 BSB1     LDN    CM          ZERO OUT *CM - CM+3*
          RJM    CLR         CLEAR DIRECT CELLS
          LDN    0           COUNT OF WORDS ZEROED OUT
          STDL   T1
 BSB2     LDD    T1          ZERO NEXT WORD
          RJM    IDA         INCREMENT DFT ADDRESS
          CWDL   CM
          AODL   T1
          SBDL   T7
          MJN    BSB2        IF MORE WORDS TO ZERO OUT

*         WRITE STRUCTURE TO MEMORY.

          LRD    W5
          RJM    SPB         SET PP BOUNDS
          LDN    HDRP        WRITE CONTROL WORD
          RJM    IDA
          CWML   BSBB,ON     WRITE CONTROL WORD
          ADK    MRBP-HDRP-1 WRITE MRB POINTER
          CWML   BSBC,ON
          ADK    BCWP-MRBP-1 WRITE MRB CW POINTER
          CWML   BSBD,ON
          ADK    MECP-BCWP-1 WRITE MAINFRAME ELEMENT COUNTERS POINTER
          CWML   BSBM,ON
          ADK    ECRP-MECP-1 WRITE ERROR CONTROL RECORD POINTER
          CWML   BSBN,ON
          ADK    SSBP-ECRP-1 WRITE SUPPORTIVE STATUS BUFFER POINTER
          CWML   BSBJ,ON
          ADK    NRSP-SSBP-1 WRITE NON REGISTER STATUS BUFFER POINTER
          CWML   BSBK,ON
          ADK    DCMP-NRSP-1 WRITE CENTRAL MEMORY RESIDENT AREA POINTER
          CWML   BSBE,ON
          ADK    PRDP-DCMP-1 WRITE PP SAVE AREA POINTER
          CWML   BSBL,ON
          ADK    SDBP-PRDP-1+1  SKIP SECONDARY DFT BUFFER POINTER
          CWML   BSBF,ON     WRITE *END OF TABLE*
          CWML   BSBA,ON     WRITE *START OF TABLE*
          ADK    1
          CWML   BSBF,ON     WRITE *END OF TABLE*
          CWML   BSBA,ON     WRITE *START OF TABLE*
          ADML   BSBH
          CWML   BSBF,ON     WRITE *END OF TABLE*
          CWML   BSBA,ON     WRITE *START OF TABLE*
          CWML   BSBI,ON     WRITE SUPPORTIVE STATUS HEADER WORD
*         ADML   BSBI+3
*         CWML   BSBF,ON     WRITE *END OF TABLE*
          UJP    BSBX        RETURN

 BSBER    BSSZ   4           BUFFER FOR ERROR
 BSBA     BSSZ   4           *START OF TABLE*
 BSBB     BSSZ   4           CONTROL WORD
 BSBC     BSSZ   4           MRB POINTER
 BSBD     BSSZ   4           MRB CW POINTER
 BSBE     BSSZ   4           CENTRAL MEMORY RESIDENT AREA
 BSBF     BSSZ   4           *END OF TABLE*
 BSBG     CON    0           NUMBER OF POINTER WORDS
 BSBH     CON    0           LENGTH OF MRB
 BSBI     BSSZ   4           SUPPORTIVE STATUS HEADER WORD
 BSBJ     BSSZ   4           SUPPORTIVE STATUS POINTER
 BSBK     BSSZ   4           NON RESIDENT STATUS BUFFER POINTER
 BSBL     BSSZ   4           PP REGISTER SAVE AREA POINTER
 BSBM     BSSZ   4           MAINFRAME ELEMENT COUNTERS POINTER
 BSBN     BSSZ   4           ERROR CONTROL RECORD POINTER
 IAD      SPACE  4,15
**        IAD - IDLE ALL I/O DRIVERS IN IOU1.
*
*         EXIT   FOR IOU1, ALL PPS IN THE MAP IDLED AND CHANNELS
*                DCN-D.
*
*         NOTE   ON AN S0, CHANNELS IN CLUSTER 2 ARE *NOT* DCN-D.
*
*         CALLS  IVP.
*
*         USES   T1 - T4, W0 - W3.


          ROUTINE  IAD

          RJM    IDI         IDLE IOU1
          LJM    IADX        RETURN
          SPACE  4,10
**        COMMON DECKS.


*copy     ctp$dft_idle_iou1
*copy     dsi$dump_load_idle_pp
          SPACE  4,10
          OVERFLOW  5700

*         END    CTP$DFT_PRESET_DUAL_I4_OVL
*DECK DECK=CTP$DFT_PRESET_NON_DUAL_I4 EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_PRESET_NON_DUAL_I4
*
*         THIS DECK CONTAINS STUBS FOR USE IN SYSTEMS WHERE
*         DUAL IOUS ARE NOT USED
 PDI      SPACE  4,10
**        PDI - PRESET DUAL IOU.
*
*         NOTE   THIS IS A STUB FOR MACHINES WHICH DONT SUPPORT
*         DUAL IOUS.


 PDI      SUBR               ENTRY/EXIT
          UJN    PDIX
 ISD      SPACE  4,10
**        ISD - IDLE SECONDARY DRIVERS.
*
*         NOTE THIS VERSION IS A STUB.


 ISD      SUBR               ENTRY/EXIT
          UJN    ISDX

*         END    CTP$DFT_PRESET_NON_DUAL_I4
*DECK DECK=CTP$DFT_PRESET_NON_PACKETS EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_PRESET_NON_PACKETS
*
*         THIS DECK PROVIDES STUBS IN APPLICATIONS WHERE
*         PACKET COMMUNICATION IS NOT USED
 CCL      SPACE  4,10
**        CCL - CHECK CONSOLE LOGGING.
*
*         ON MACHINES WITH NO CONSOLE LOGGING THIS IS A NO OP

 CCL      SUBR               ENTRY/EXIT
          UJN    CCLX

*         END    CTP$DFT_PRESET_NON_PACKETS
*DECK DECK=CTP$DFT_PRESET_PACKETS EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT PRESET PACKETS.
*
*         THIS DECK PROVIDES CONSOLE PRESET CODE.
 CCL      SPACE  4,10
**        CCL - CHECK CONSOLE LOGGING.
*
*         ENTRY  (A) = BUFFER CONTROL WORD FLAGS.
*                (CBWC) = BUFFER CONTROL WORD INDEX TO LOG.
*
*         EXIT   LOGGING INITIATED IF AN ENTRY WITH *BC.CL* SET IS FOUND.


 CCL      SUBR               ENTRY/EXIT
          LPBC   (BC.CL)
          ZJN    CCLX        IF *CONSOLE LOGGING* NOT SET
          LDML   CELCW
          NJN    CCLX        IF LOGGING ALREADY ACTIVE
          LDM    CBWC        INITIATE LOGGING
          STM    CELCW
          UJN    CCLX        RETURN

*         END    CTP$DFT PRESET PACKETS
*DECK DECK=CTP$DFT_PRESET_STANDARD_OVL EXPAND=FALSE
*         CTEXT  CTP$DFT_PRESET_STANDARD_OVL
*
*         THIS DECK HOLDS THE PRESET ACTIVITIES WHICH OCCUR
*         AFTER THE DFT STRUCTURE IS BUILT.

          ROUTINE PSO


*         SAVE MAINTENANCE REGISTER BUFFER POINTER.

          LDN    MRBP
          RJM    IDA
          CRDL   W0          MAINTENANCE REGISTER BUFFER POINTER
          LRD    W1
          SRD    MP+1
          LDD    W0
          STDL   MP
          LDN    HDRP        READ DFT HEADER
          RJM    IDA
          CRDL   CM
          LDDL   CM+DHRL     RELEASE LEVEL
          SHN    -DH.RL
          STM    VRSN        SAVE HEADER VERSION
          LDM    IOUN
          ZJN    PRS70       IF IN IOU 0
          LDN    VER5
          RJM    VCK
          MJN    PRS70       IF LESS THAN VERSION 5
          LDN    NRSP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0          READ IN NRSB POINTER
          LRD    W1
          LDD    W0
          ADC    RR
          CRDL   W0          READ IN THE NRSB HEADER WORD
          LDDL   W2
          STML   NNRB        NUMBER OF NON REGISTER BUFFERS
          LDDL   W3
          STML   SNRB        SIZE OF NON REGISTER BUFFERS
 PRS70    LDDL   CM+DHRL
          SHN    -DH.RL
          SBN    CURNTV      CURRENT DFT VERSION
          ZJP    PRS80       IF LATEST VERSION THEN OK
          MJP    PRS80       IF PREVIOUS VERSION THEN OK ALSO
          LDN    CM
          RJM    CLR
          LDBC   (DH.FR,DH.FV)  REJECT FLAG AND VERIFICATION FLAG
          STDL   CM+DHFLG
          LDN    HDRP
          RJM    IDA
          RDSL   CM          SET REJECT FLAG

*         DFT ANALYSIS - WRONG VERSION IN CENTRAL MEMORY INTERFACE.

          SETDAN (EPUN,DAVM)
          LDC    DAVM+TDFT   IF DFT SAW WRONG VERSION
          STML   RTP1
          CALL   ERRH

*         INITIALIZE REGISTER LIST ADDRESSES FOR CORRECTED AND
*         UNCORRECTED ERRORS ON ALL ELEMENTS.

 PRS80    RJM    SMV         SET UP MODEL DEPENDENT VALUES
          RJM    SSO         SETUP SPECIAL OVERLAY IF REQUIRED
          RJM    ICP         ISSUE CLEAR PACKETS REQUEST
          LDN    HDRP
          RJM    IDA
          CRDL   CM          READ DFT HEADER
          LDD    CM+DHSEQ    GET SEQUENCE NUMBER
          LPC    0#FF        JUST SEQUENCE
          STD    T2
          LDN    CM
          RJM    CLR
          LDBC   DH.FV       SET VERIFICATION FLAG
          STDL   CM+DHFLG
          LDD    T2          GET SAVED SEQUENCE NUMBER
          NJN    PRS90       IF ALREADY SET DONT INITIALIZE
          LDN    1           SEQUENCE COUNT STARTS AT 1
          STDL   CM+DHSEQ

*         SAVE BUFFER CONTROL WORDS POINTER

 PRS90    LDN    VER4
          RJM    VCK         CHECK VERSION
          MJN    PRS95       IF LESS THAN VERSION 4
          LDN    BCWP
          RJM    IDA
          CRDL   BW

 PRS95    LDN    HDRP
          RJM    IDA
          RDSL   CM
          LDM    VRSN
          SBN    VER1
          NJN    PRS100      IF NOT VERSION 1 DFT BLOCK
          LDN    6           1 HEADER + 5 POINTERS
          STM    NUMHW
          LDN    HDRP
          RJM    IDA
          CRDL   CM          GET DFT HEADER
          UJN    PRS110      CONTINUE

 PRS100   LDN    HDRP
          RJM    IDA
          CRDL   CM          GET DFT HEADER WORD
          LDDL   CM
          SHN    -10         GET TO NUMBER OF POINTERS
          LPN    0#F
          STM    NUMHW       SAVE NUMBER OF POINTERS
 PRS110   RJM    MPW         MODIFY POINTER WORDS TO ZERO UPPER 4 BITS
          LDDL   CM+2
          SHN    -10
          STM    LBUF        SAVE LENGTH OF MAINTENANCE BUFFER ENTRY
          LDDL   CM+2
          LPC    0#FF
          STM    NBUF        SAVE NUMBER OF MAINTENANCE BUFFER ENTRIES
          RJM    CBW         CLEAN UP BUFFER CONTROL WORDS
          LDN    VER2
          RJM    VCK         CHECK VERSION
          PJN    PRS120      IF GREATER THAN VERSION 1
          LDN    SECP
          RJM    IDA
          CRDL   CM          GET SECDED ID POINTER
          LDN    CMID        MEMORY ID
          RJM    FHE         GET ELEMENT
          MJP    PRS140      IF NOT FOUND
          STD    EI          SAVE ELEMENT INDEX
          LDM    NBUF
          ADM    NUMHW
          ADD    EI          FROM PREVIOUS FIND OF MEMORY ELEMENT
          STD    T1
          RJM    IDA
          CRDL   W0          GET COUNTER (MEMORY)
          LDDL   W0
          NJN    PRS120
          LDDL   CM+3        LENGTH OF SECDED ID TABLE
          STDL   W0          SAVE AS CORRECTED MEMORY ERROR THRESHOLD
          LDD    T1
          RJM    IDA
          CWDL   W0          REWRITE UPDATED SECDED ID TABLE ENTRY
 PRS120   LDN    0
          STM    ELCO        ELEMENT COUNTER
          RJM    /DSIGHE/RHT
 PRS130   RJM    GNE         GET AN ELEMENT
          MJP    PRS180      IF THROUGH SEARCHING FOR ELEMENTS
          AOM    ELCO
          UJN    PRS130      LOOP

*         DFT ANALYSIS - NO MRT ENTRY FOR ELEMENT.
*         DFT FLAGS - VALID 170, VALID 180, LOGGING.
*         DFT ACTION - TERMINATE PROCESSING.
*         OS ACTION - STEP SYSTEM.

 PRS140   SETDAN (EPUN,DAME)

          LDC    DAME+TDFT   613 - DFT NO DESC IN MRT
          UJP    PRS170      ISSUE MESSAGE

*         DFT ANALYSIS - COMMUNICATION FAILURE.
*         DFT FLAGS - VALID 170, VALID 180, LOGGING.
*         DFT ACTION - TERMINATE PROCESSING.
*         OS ACTION - STEP SYSTEM.

 PRS150   SETDAN (EPUN,DACF)

          LDC    DACF+TDFT   614 - DFT COMM FAILURE
 PRS170   LJM    PRS200      ISSUE MESSAGE

 PRS180   RJM    RCS         RESET CALL STACK
          LDM    IOUN        CHECK IOU NUMBER
          NJP    PRS190      IF IN SECONDARY IOU

*         IF THE SECONDARY DFT BUFFER POINTER IS PRESENT, THEN
*         ZERO OUT THE FIRST TWO BYTES OF THE BUFFER AS A FLAG
*         THAT THE SECONDARY *DFT* IS NOT YET ACTIVE.

          LDN    VER6
          RJM    VCK         CHECK VERSION
          MJP    PRS185      IF PRIOR TO VERSION 6
          LRD    DP+1
          RJM    SPB         SET OS PP BOUNDS
          LDN    SDBP        GET POINTER TO SECONDARY *DFT* BUFFER
          RJM    IDA
          CRDL   T1
          LDDL   T4
          ZJN    PRS185      IF BUFFER NOT PRESENT
          LRD    T2          ZERO OUT FIRST TWO BYTES OF BUFFER
          LDDL   T1
          ADC    RR
          CRDL   T2
          LDN    0
          STDL   T2
          LDDL   T1
          ADC    RR
          CWDL   T2
          LDN    PSO_O
          STM    CUOV        PRESET THIS OVERLAY NUMBER
          LDML   IOUN
          SHN    -14
          NJN    PRS185      IF DUAL IOU DONT READ EPM
          CALL   RED         READ EPM POWER MONITOR DATA
 PRS185   LJM    DFT5        RETURN TO MAIN LOOP

 PRS190   LDN    D8ST        SET DEADSTART DFT-S FLAG
          RJM    IIB
          CRDL   W0
          LDDL   W3
          LPC    0#F7FF      CLEAR DEADSTART DFT-S FLAG
          STDL   W3
          LDN    D8ST
          RJM    IIB
          CWDL   W0
          LJM    DFT10       RETURN TO MAIN LOOP

 PRS200   STML   RTP1        SAVE MESSAGE CODE AND TERMINATION FLAG
          CALL   ERRH        ISSUE MESSAGE AND EXIT

          TITLE  PRESET SUBROUTINES.
 CBW      SPACE  4,10
**        CBW - CLEAN UP BUFFER CONTROL WORDS.
*
*         EXIT   INTERLOCKED ENTRIES CLEARED.
*                DFT HEADER FLAGS FOR 170, 180 OS SET IF NECESSARY.
*                CONSOLE LOGGING INITIATED IF NECESSARY.
*
*         USES   CM - CM+3, T1 - T2.
*
*         CALLS  CLR, COR, IDA, LGF, PMB, SNE, SVE.


 CBW      SUBR               ENTRY/EXIT
          RJM    COR         CLEAR OPERATING SYSTEM REQUESTS
          LDN    0
          STM    RTP1
          LRD    DP+1
          RJM    SPB         RE SET OS PP BOUNDS
          LDN    0
          STM    CBWC
          LDM    NBUF        SET NUMBER OF BUFFERS TO BE SCANNED
          SBN    1
          STM    CBWB
 CBW1     LDM    CBWC        READ BUFFER CONTROL WORD (CBWC)
          RJM    IBW         INCREMENT BUFFER CONTROL WORD
          CRDL   CM
          LDDL   CM+BCOA     CLEAR OS ACTION CODE
          LPC    0#FF00
          STDL   CM+BCOA
          LDDL   CM+BCFLG    CHECK INTERLOCK STATUS
          SHN    21-BC.FI
          PJN    CBW2        IF INTERLOCK NOT SET
          RJM    PMB         PROCESS MODEL DEPENDENT BUFFER
          LDN    0           CLEAR ENTRY
          STD    CM
          STD    CM+1
          STD    CM+2
 CBW2     LDM    CBWC        REWRITE ENTRY
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          CWDL   CM
          LDDL   CM+BCFLG    CHECK FLAGS FOR FURTHER CLEANUP REQUIRED
          LPBC   (BC.FV7,BC.FL,BC.FV8,BC.CL)
          ZJN    CBW6        IF NO VALID DATA FLAGS
          LDDL   CM+BCFLG
          LPBC   (BC.FV8)
          ZJN    CBW3        IF *VALID 180* NOT SET
          RJM    SVE         SET 180 FLAG IN DFT HEADER
 CBW3     LDDL   CM+BCFLG
          LPBC   (BC.FV7)
          ZJN    CBW4        IF *VALID 170* NOT SET
          RJM    SNE         SET 170 FLAG IN DFT HEADER
 CBW4     LDDL   CM+BCFLG
          LPBC   (BC.FL)
          ZJN    CBW5        IF *LOG ERROR* NOT SET
          RJM    LGF         SET LOGGING FLAG IN DFT HEADER
 CBW5     LDDL   CM+BCFLG
          RJM    CCL         CHECK CONSOLE LOGGING (STUB IF NO PACKETS)
 CBW6     AOM    CBWC
          SOM    CBWB
          PJP    CBW1        IF MORE TO PROCESS
          LDML   CBWA
          ZJP    CBW7        IF NO FLAG TO SET
          LDN    CM
          RJM    CLR         CLEAR CM AREA
          LDML   CBWA
          STDL   CM+DHFLG    SET E7 FLAG IN MASK
          LDN    HDRP
          RJM    IDA
          RDSL   CM          SET LOCK
 CBW7     LDM    RTP1
          NJP    CBW8        IF THRU PROCESSING BOTH BCW AND NRSB
          LDN    VER5
          RJM    VCK         CHECK VERSION
          MJN    CBW8        IF LESS THAN VERSION 5
          LDM    IOUN
          NJN    CBW8        IF IN SECONDARY IOU
          LDN    1
          STM    RTP1        SET TO DO NRSB
          LDM    NNRB
          SBN    1
          STM    CBWB
          LDN    0
          STM    CBWC
          UJP    CBW1        DO THE NON REGISTER STATUS BUFFER

 CBW8     LDN    0
          STM    RTP1
          LJM    CBWX        RETURN

 CBWA     CON    0
 CBWB     CON    0           MAXIMUM NUMBER OF BUFFER CONTROL WORDS TO SEARCH
 CBWC     CON    0           INDEX TO BUFFER CONTROL WORDS
 PMB      SPACE  4,15
**        PMB - PROCESS MODEL DEPENDENT BUFFER.
*
*         ENTRY  (CM - CM+3) = THE BUFFER CONTROL WORD (BCW) CURRENTLY
*                BEING EXAMINED.
*
*         EXIT   IF THE BCW HAS THE MDB BIT SET, THE
*                ASSOCIATED MODEL DEPENDENT BUFFER CONTROL
*                WORD OFFSET FIELD WITHIN THE MODEL DEPENDENT BUFFER
*                WILL BE CLEARED THUS MAKING THE MDB AVAILABLE.
*
*         USES   W0 - W7.
*
*         CALLS  GMO, IDA, VCK.


 PMB      SUBR               ENTRY/EXIT
          LDN    MDLP        READ IN MDB POINTER WORD
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0
          LDDL   W3
          ZJN    PMBX        IF NO MDB DEFINED
          LDN    VER4
          RJM    VCK         CHECK VERSION
          MJN    PMBX        IF VERSION 3 OR EARLIER
          LDDL   CM+BCFLG    GET MDB DATA TO LOG FLAG
          SHN    21- BC.MDB
          PJN    PMBX        IF NO MDB DATA TO LOG
          RJM    GMO         GET MODEL DEPENDENT BUFFER OFFSET
          ADD    W0
          LRD    W1
          ADC    RR
          CRDL   W0          READ CORRECT MDB POINTER WORD FROM OFFSET
          LDDL   W0
          LRD    W1
          ADC    RR
          CRDL   W4          READ IN THE FIRST WORD OF THIS MDB
          LDDL   W4
          LPC    0#F000      CLEAR CWO AND LTIF
          STDL   W4
          LDDL   W0          MAKE THE MDB AVAILABLE
          ADC    RR
          CWDL   W4
          LJM    PMBX        RETURN
 GMO      SPACE  4,10
**        GMO - GET MODEL DEPENDENT BUFFER ORDINAL.
*
*         ENTRY  (CBWC) = CURRENT BUFFER CONTROL WORD.
*
*         EXIT   (A) = THE MODEL DEPENDENT BUFFER ORDINAL.
*
*         USES   W4 - W7, T4 - T7, T1, T2, *CBWB*.
*
*         CALLS  IDA.


 GMO      SUBR               ENTRY/EXIT
          LDN    SSBP        READ IN THE SSB POINTER
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W4
          LDDL   W4          READ IN THE SSB HEADER WORD
          LRD    W5
          ADC    RR
          CRDL   T4
          LDM    CBWC        INDEX TO BUFFER CONTROL WORD
          SBN    1           MINUS SCRATCH BUFFER
          STD    T2
          LDN    1           ACCOUNT FOR SSB HEADER
          STD    T1          INITIALIZE OFFSET TO DESIRED SSB
 GMO1     LDDL   T7          SSB SIZE
          RADL   T1
          SODL   T2
          PJN    GMO1        IF NOT AT CORRECT BCW OFFSET YET
          LDDL   W4          READ IN DESIRED SSB HEADER WORD
          ADD    T1          INDEX BY OFFSET TO SSB
          ADC    RR
          CRDL   W4
          LDDL   W6
          LPC    0#FF        RETURN JUST CONTROL WORD OFFSET
          UJN    GMOX        RETURN
 COR      SPACE  4,10
**        COR - CLEAR OPERATING SYSTEM REQUESTS.
*
*         EXIT   ANY REQUESTS WILL BE CLEARED.
*
*         USES   T1, CM - CM+3, W0 - W3.
*
*         CALLS  IDA, IIB.


 COR      SUBR               ENTRY/EXIT
          LDN    NVEP        180 REQUEST POINTER
          RJM    IDA
          CRDL   CM          GET NVE POINTER
          LDD    CM+3        GET LENGTH
          ZJN    CORX        IF NO LENGTH

*         GET WHETHER DUAL-STATE OR STANDALONE.  IF STANDALONE, EXIT,
*         SINCE *SCI/VPB* HAS TAKEN CARE OF IT.

          LDN    D7TY
          RJM    IIB         INCREMENT INTERFACE BLOCK
          CRDL   W0          READ IN D7TY FIELD
          LDDL   W3          GET TO OS TYPE
          SHN    -14
          ZJN    CORX        IF STANDALONE
          LRD    CM+1
          RJM    SPB         SET PP BOUNDS
          LDD    CM+3
          STD    T1          INDEX FOR REQUESTS
          SOD    T1          FOR MJN TEST
 COR1     LDD    CM          GET A OFFSET
          ADD    T1
          ADC    RR
          CWML   CORA,ON     ZERO THE REQUEST
          SOD    T1
          PJN    COR1        IF MORE REQUESTS TO CLEAR
          UJN    CORX        RETURN

 CORA     BSSZ   4           CM WORD OF ZEROES
 LGF      SPACE  4,10
**        LGF - SET LOGGING FLAG.
*
*         ENTRY  (LGFA) = 1 IF FLAG ALREADY SET.
*
*         EXIT   LOGGING FLAG SET.
*
*         USES   W0 - W3.
*
*         CALLS  IDA, SNE, SVE.


 LGF      SUBR               ENTRY/EXIT
          LDM    LGFA
          NJN    LGFX        IF FLAG ALREADY SET
          AOM    LGFA
          LDN    HDRP        READ DFT HEADER
          RJM    IDA
          CRDL   W0
          LDDL   W0+DHFLG    CHECK LOGGING RESPONSIBILITY
          LPBC   (DH.FL)
          ZJN    LGF1        IF 180 LOGS
          RJM    SNE         SET 170 ERROR
          UJN    LGFX        RETURN

 LGF1     RJM    SVE         SET 180 ERROR
          UJN    LGFX        RETURN

 LGFA     CON    0
 MPW      SPACE  4,10
**        MPW - MODIFY POINTER WORD.
*
*         EXIT   UPPER 4 BITS OF MAINTENANCE BUFFER POINTER WORD
*                ARE ZEROED.
*
*         USES   W0, W1, W2, W3.
*
*         NOTE   THIS IS FOR THE CASE OF NOS/BE DUAL STATE WITH
*                NOS/VE LOGGING.


 MPW      SUBR               ENTRY/EXIT
          LRD    DP+1
          RJM    SPB         SET PP BOUNDS
          LDN    MRBP        MODIFY THE MAINTENANCE REGISTER BUFFER POINTER
          RJM    IDA         INDEX INTO DFT BUFFER
          CRDL   W0          READ IN MAINTENANCE BUFFER POINTER WORD
          LDDL   W0
          STD    W0          ZERO OUT THE UPPER 4 BITS OF THE POINTER WORD
          LDN    MRBP
          RJM    IDA
          CWDL   W0          REWRITE POINTER WORD
          UJN    MPWX        RETURN

 SNE      SPACE  4,10
**        SNE - SET 170 FLAG IN HEADER.
*
*         ENTRY  (SNEA) = 1 IF FLAG ALREADY SET.
*
*         EXIT   FLAG SET IN *CBWA*.


 SNE      SUBR               ENTRY/EXIT
          LDM    SNEA
          NJN    SNEX        IF FLAG ALREADY SET
          AOM    SNEA
          LDML   CBWA        SET FLAG IN *CBWA*
          LMBC   (DH.FE7)
          STML   CBWA
          UJN    SNEX        RETURN

 SNEA     CON    0
 SVE      SPACE  4,10
**        SVE - SET 180 FLAG IN HEADER.
*
*         ENTRY  (SVEA) = 1 IF FLAG ALREADY SET.
*
*         EXIT   FLAG SET IN *CBWA*.


 SVE      SUBR               ENTRY/EXIT
          LDM    SVEA
          NJN    SVEX        IF FLAG ALREADY SET
          AOM    SVEA
          LDML   CBWA        SET FLAG IN *CBWA*
          LMBC   (DH.FE8)
          STML   CBWA
          UJN    SVEX        RETURN

 SVEA     CON    0

*         END    CTP$DFT_PRESET_STANDARD_OVL
*DECK DECK=CTP$DFT_PROCESSOR_PRIMITIVES EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT PROCESSOR PRIMITIVES.
*
*         THIS DECK PROVIDES CPU PRIMITIVES WHICH ENABLE
*         HALTING, STARTING, AND HALF EXCHANGE OPERATIONS ON
*         A CPU.
 DCP      SPACE  4,10
**        DCP - DISABLE CPU.
*
*         PERFORMS CALLS TO ROUTINES WHICH ULTIMATELY DISABLE
*         THE CPU.
*
*         CALLS  *DMP*, *HEO*, *HPR*, *IDL*, *SCR*.


          ROUTINE  DCP

          CALL   HPR         HALT PROCESSOR
          CALL   HEO         HALF EXCHANGE OUT
          CALL   IDL         IDLE MICROCODE
          CALL   SCR         SAVE CPU REGISTERS
          CALL   DMP         DISABLE MEMORY PORT
          LJM    DCPX        RETURN
 HEI      SPACE  4,10
**        HEI  - HALF-EXCHANGE IN TO START PROCESSOR.
*
*         ENTRY  PROCESSOR MASTER CLEARED, *CSA* REGISTER SET TO (STEX)
*                *BLOCK EXCHANGE REQUEST* AND *DISABLE PROCESSOR FAULT
*                STATUS* BITS ARE CLEARED IN *DEC*, PROCESSOR STARTED
*                AND THE DEADSTART INTERLOCK IS CLEARED IN THE *EICB*.
*
*         EXIT   PROCESSOR HALF EXCHANGED OUT TO MONITOR
*                EXCHANGE PACKAGE AT *MPS*.
*
*         CALLS  CLRBTS.


          ROUTINE  HEI

*         START THE PROCESSOR.

          LDML   HEIM        GET HALF EXCHANGE IN ADDRESS
          STM    HEIB+7
          SHN    -8D
          STM    HEIB+6
          LOCKMR SET
          FUNCMR HBUF+CPRPC,MRMC   MASTER CLEAR PROCESSOR
          RJM    CLRBTS      CLEAR MODEL-DEPENDENT *DEC* BITS
          LDML   CSAR
          STDL   RN
          WRITMR HEIB,HBUF+CPRPC
          FUNCMR HBUF+CPRPC,MRSP   START PROCESSOR
          LDC    200D        WAIT 100 MICRO SECS
 HEI1     SBN    1
          NJN    HEI1        DELAY

*         CLEAR  MAINTENANCE REGISTER INTERLOCK.

          LOCKMR CLEAR
          LJM    HEIX        RETURN

 HEIB     BSSZ   10          CONTROL STORE ADDRESS
 HEO      SPACE  4,10
**        HEO - HALF EXCHANGE OUT.
*
*         THE CURRENTLY ACTIVE EXCHANGE PACKAGE IS SAVED WITHIN
*         THE EXCHANGE PACKAGE SAVE AREA IN REAL MEMORY.
*
*         ENTRY  PROCESSOR HALTED.
*
*         EXIT   EXCHANGE PACKAGE SAVED IN REAL MEMORY.
*
*         CALLS  RMR, SMC.


          ROUTINE  HEO

          LDN    SSMR
          STD    RN
          LDM    HBUF+CPRPC
          RJM    RMR         READ PROCESSOR SUMMARY STATUS
          LPN    0#20
          ZJN    HEO1        IF PROCESSOR IN JOB MODE
          LDML   HEOM        HALF EXCHANGE OUT MONITOR ADDRESS
          UJN    HEO2        DO EXCHANGE

 HEO1     LDML   HEOJ        HALF EXCHANGE OUT JOB ADDRESS
 HEO2     RJM    SMC         START MICROCODE
 HEO3     LDN    SSMR
          STD    RN
          LDD    EC
          RJM    RMR         READ PROCESSOR SUMMARY STATUS
          LPN    0#8
          ZJN    HEO3        IF PROCESSOR NOT HALTED
          LJM    HEOX        RETURN
 HPR      SPACE  4,10
**        HPR - HALT PROCESSOR.
*
*         PROCESSOR IS HALTED, THE *DISABLE PROCESSOR FAULT
*         STATUS* AND THE *BLOCK EXCHANGE REQUEST* BITS ARE SET
*         IN THE *DEC* REGISTER.
*
*         CALLS  RMR, *ERRH*, *STRBTS*.


          ROUTINE  HPR

          LDM    HBUF+CPRPC  CHECK PORT CODE
          ZJP    HPR4        IF INVALID PORT
          LDM    HBUF+CPRE+EM
          SHN    -4
          STD    MD          SET UP MODEL TYPE
          LDN    SSMR
          STD    RN
          LDM    HBUF+CPRPC
          RJM    RMR         READ SUMMARY STATUS
          LPN    0#8
          NJN    HPR2        IF PROCESSOR IS HALTED
          FUNCMR ,MRHP       STOP PROCESSOR
 HPR2     LDM    HBUF+CPRPC
          RJM    RMR         READ SUMMARY STATUS
          LPN    0#8
          ZJN    HPR2        IF NOT HALTED

*         PREPARE THE *DEC* REGISTER FOR MODEL-DEPENDENT
*         HALF EXCHANGE OPERATIONS.

 HPR3     READMR RDATA,,DEMR READ *DEC* REGISTER
          CALL   STRBTS      SET BITS IN *DEC*
          WRITMR RDATA       REWRITE *DEC* REGISTER
          LJM    HPRX        RETURN

 HPR4     SETDAN (EPUN,DAHP)
          LDC    DAHP+TDFT   609 - DFT HALT PROCESSOR
          STML   RTP1
          CALL   ERRH        ISSUE MESSAGE AND HANG
 IDL      SPACE  4,10
**        IDL - DEADSTART PROCESSOR TO IDLE ADDRESS.
*
*         PROCESSOR IS MASTER CLEARED, *CSA* REGISTER IS SET TO *IDLE*
*         AND PROCESSOR IS STARTED.
*
*         ENTRY  PROCESSOR IS HALTED.
*
*         EXIT   PROCESSOR IS READY FOR REGISTER DUMP.
*
*         USES   T1.
*
*         CALLS  SMC.


          ROUTINE  IDL

          LDML   MIDL
          STDL   T1
          LMC    4000        NULL MICROCODE ADDRESS
          ZJP    IDLX        IF NO MICROCODE NEEDED
          LDDL   T1
          RJM    SMC         START MICROCODE
          LJM    IDLX        RETURN
 PCP      SPACE  4,10
**        PCP - PROCESS CPU.
*
*         EXIT   VE REQUEST UPDATED WITH NUMBER OF FIRST ACTIVE CPU.
*
*         CALLS  CMP, FHE, *DCP*.


          ROUTINE  PCP

          READMR RDATA,CMCC,ECMR
          LDN    0
          STD    CP          CPU ORDINAL
 PCP1     LDD    CP
          SHN    14
          ADN    PROCID
          RJM    FHE         FIND HARDWARE DATA ON SELECTED CPU
          MJP    PCPX        IF THRU WITH ALL CPUS
          LDM    HBUF+CPRSTAT+PSCPOFF
          LPC    1001
          NJN    PCP3        IF CPU OFF OR DOWN
          RJM    CMP
          NJN    PCP3        IF PORT DISABLED
          CALL   DCP         PERFORM STEPS TO DISABLE THIS CPU
 PCP3     AOD    CP
          LDN    EICBP       SCI IS TAKING VE DOWN, SO WE HAVE
          CRDL   CM          SEE IF THIS IS A DUAL CPU, NOS SYSTEM
          LDDL   CM          WITH NOS IN CPU-1.  CHECK WORD 71
          LPC    0#0480      BITS 5 AND 8.  IF SET, THEN LEAVE
          LMC    0#0480      CPU-1 ALONE, AND CLEAR BIT 8.
          NJN    PCP1        NOT DUAL NOS SYSTEM
          LRD    IB+1        SET UP TO GET BOUNDS TO LOWER
          RJM    SPB         SET THE BOUNDS REG
          LDC    0#FF7F      SET UP TO CLEAR BIT 8
          STDL   CM
          LCN    0
          STDL   CM+1
          STDL   CM+2
          STDL   CM+3
          LDN    EICBP       RE-WRITE WORD 71
          RDCL   CM
          LJM    PCPX        DO NOT PROCESS CPU-1
 SAP      SPACE  4,10
**        SAP - START ALL PROCESSORS.
*
*         EXIT   ALL PROCESSORS IN MAINFRAME WILL BE STARTED.
*
*         CALLS  FHE, *SPR*.


          ROUTINE  SAP

          LDN    0
          STM    ELMO        ELEMENT ORDINAL
          LDN    PROCID
 SAP1     RJM    FHE
          MJP    SAPX        IF ALL PROCESSORS STARTED
          RJM    CMP         CHECK MEMORY PORT
          NJN    SAP2        IF PORT DISABLED
          CALL   SPR         CALL START PROCESSOR
 SAP2     AOM    ELMO        GET NEXT ELEMENT
          SHN    14
          ADN    PROCID
          UJN    SAP1        LOOP
 SPR      SPACE  4,10
**        SPR - START PROCESSOR.


          ROUTINE  SPR

          FUNCMR HBUF+CPRPC,MRSP
          LJM    SPRX        RETURN

**        SB8 - SET BIT 8 OF WORD 71 IF BIT 5 IS SET
*
*         THIS ROUTINE IS CALLED DURING A DUAL STATE
*         DEADSTART OF NVE.  IF CM WORD 71, BIT 5 IS
*         SET, THEN THIS IS A DUAL STATE TRANSITION
*         TO CPU-0 ONLY.  BIT 8 MUST BE SET BEFORE
*         CPU-0 IS STARTED, SO THAT NVE WILL HANDLE
*         ALL INTERRUPTS.  THE MICROCODE WILL KEY ON
*         THAT BIT ALSO, TO PASS ALL INTERRUPTS UP.

          ROUTINE   SB8

          LDN    EICBP       READ WORD 71
          CRDL   T1
          LDDL   T1
          SHN    21-12
          PJP    SB8X        BIT 5 NOT SET
          LRD    IB+1        SET THIS PP TO BELOW BOUNDS
          RJM    SPB
          LDC    0#80        SET BIT 8 IN MASK
          STDL   T1
          LDN    0
          STD    T1+1
          STD    T1+2
          STD    T1+3
          LDN    EICBP       SET THE BIT
          RDSL   T1
          UJP    SB8X        EXIT

 COMMON   SPACE  4,10
*         COMMON DECKS.


 QUAL$    EQU    0           DEFINE UNQUALIFIED COMMON DECK
*COPY     CTP$DFT_START_MICROCODE

*         END    CTP$DFT PROCESSOR PRIMITIVES
*DECK DECK=CTP$DFT_PROCESS_DISK_ERROR EXPAND=FALSE
*         CTEXT  CTP$DFT PROCESS DISK ERROR.
*
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 PDE      SPACE  4,15
**        PDE - PROCESS DISK ERROR ENCOUNTERED BY *2AP*.
*
*         ENTRY  (RTP1) = *2AP* FUNCTION NUMBER.
*                (RTP2) = 1/RETURN, 1/SET STATUS, 1/ NOT OS REQUEST, 7/0, 6/OFFSET.
*                IF SET STATUS, THEN RETURN WILL NOT BE PROCESSED.
*                (CALB+1) = *2AP* ERROR STATUS.
*                IF (CALB+1) = 2, THEN THE FOLLOWING IS TRUE -
*                ((TOUB)) = LENGTH OF BUFFER.
*                ((TOUB)+1) = DEVICE TYPE.
*                ((TOUB)+2) = CHANNEL NUMBER.
*                ((TOUB)+3 - (TOUB)+LENGTH-1) = STATUS BUFFER.
*
*         EXIT   TO *ERR1*, IF RETURN NOT REQUESTED.
*                IN THIS CASE A RESPONSE CODE OF EITHER 2 OR 6 IS
*                RETURNED.


          ROUTINE  PDE

          LRD    DP+1
          RJM    SPB         SET PP BOUNDS
          LDN    NRSBL-1
          STM    LLOG        PRESET THE LENGTH TO LOG IN NRSB
          LDML   CALB+1      ERROR CODE
          LMN    2
          NJP    PDE2        IF NOT DISK ERROR
          LDML   TOUB        ADDRESS OF BUFFER
          STDL   T1
          SBN    1           FWA OF BLOCK TO WRITE TO CM
          STML   PDEB
          LDIL   T1          LENGTH
          STDL   T2
          SBN    4
          MJP    PDE2        IF STATUS NOT AVAILABLE
          LDML   1,T1        DEVICE TYPE
          LMN    77
          ZJP    PDE2        IF STATUS NOT AVAILABLE

*         CONSTRUCT BLOCK FOR LOGGING.
*         THE HEADER HAS THE FOLLOWING FORMAT -
*         16/IOU NUMBER, 16/CH NUMBER, 16/DEVICE TYPE, 16/*2AP* FUNCTION NUM.

          LDML   2,T1        CHANNEL NUMBER
          STIL   T1
          LDM    RTP1        *2AP* FUNCTION NUMBER
          STML   2,T1
          SODL   T1
          LDM    IOUN        IOU NUMBER
          STIL   T1
          LDDL   T2          LENGTH
          ADN    3           ROUND UP TO CM WORDS
          SHN    -2
          ADN    1
          STDL   T2
          SBN    7+1
          MJP    PDE1        IF LENGTH TO LOG WITHIN LIMITS

*         DFT ANALYSIS - DISK STATUS LENGTH EXCEEDED.
*         OS ACTION - NO INTERRUPTION.
*         DFT ACTION - CONTINUE PROCESSING.

          LDN    BC
          RJM    CLR
          LDN    0
          STD    ET
          SETDAN (EPUN,DADL)
          SETFLG (BC.FL)
          LDD    T2
          STM    PDEC+3
          LDN    NRSP        NON REGISTER STATUS BUFFER
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0
          LRD    W1
          LDDL   W0
          ADC    RR+NRSBL+1  BASE SIZE + HEADER WORD
          CWML   PDEC,ON     WRITE ERROR CODE TO SCRATCH SUPPORTIVE STATUS
          LDN    NRSBL
          STM    LLOG        LENGTH TO LOG
          LDN    1
          STML   RTP1
          CALL   LOG         LOG THE ERROR
          LJM    PDEX        RETURN

 PDE1     LDN    NRSP        NON REGISTER STATUS BUFFER
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   T4
          LRD    T5
          LDML   RTP2
          SHN    21-15
          PJN    PDE1.5      IF OS REQUEST MAKE ROOM FOR EXTRA WORD
          LDN    NRSBL+7     BASE NRSB PLUS SIZE OF DISK ERROR STATUS
          STM    LLOG
          LDDL   T4
          UJN    PDE1.6      NO EXTRA WORD NECESSARY

 PDE1.5   RJM    LRP
          CRDL   CM          READ IN OS REQUEST WORD
          LDML   CALB+1      GET 2AP RESPONSE
          STDL   CM+1
          LDN    0
          STDL   CM+2
          STDL   CM+3
          LRD    T5
          LDDL   T4
          ADC    RR+NRSBL+1
          CWDL   CM          WRITE REQUEST RESPONSE TO SCRATCH BUFFER
          LDN    NRSBL+7   BASE NRSB PLUS ADDITIONAL OS REQ WORD PLUS DISK ERROR SIZE
          STM    LLOG
          LDD    T4
          ADN    1
 PDE1.6   ADC    RR+NRSBL+1     BASE SIZE + HEADER WORD
          CWML   **,T2
 PDEB     EQU    *-1

*         EXIT AS SELECTED.

 PDE2     LDN    BC
          RJM    CLR
          LDN    0
          STD    ET
          LDML   RTP2        CHECK FOR STATUS
          SHN    21-16
          PJN    PDE3        IF STATUS NOT TO BE WRITTEN
          SHN    5-5-21+16+22
          LPN    77
          RJM    RTE         RETURN *2AP* ERROR STATUS
          UJN    PDE4        LOG THE ERROR

 PDE3     LDML   RTP2        CHECK FOR RETURN
          SHN    21-17
          MJP    PDE5        IF RETURN SELECTED
          LDC    0#200       SET ERROR
          STM    JOBF
 PDE4     SETDAN (EPUN,DAPF)
          SETFLG (BC.FL)
          LDN    4
          STD    ET
          LDN    1
          STM    RTP1
          CALL   LOG         LOG THE ERROR
          LJM    ERR1        PROCESS ERROR

 PDE5     SETDAN (EPUN,DAPF)
          SETFLG (BC.FL)
          LDN    4
          STD    ET
          LDN    1
          STM    RTP1
          CALL   LOG
          LJM    PDEX        RETURN

 PDEC     BSSZ   4           TEMPORARY WORD FOR ERROR STATUS
 RTE      SPACE  4,15
**        RTE - RETURN *2AP* ERROR STATUS.
*
*         ENTRY  (A) = OFFSET TO ERROR STATUS RETURN WORD.
*                (RTP1) = *2AP* FUNCTION NUMBER FOR WHICH ERROR OCCURRED.
*                (CALB+1) = *2AP* ERROR STATUS.
*
*         EXIT   TO *ERR10* TO RETURN NON-STANDARD RESPONSE.
*
*         USES   T1, W0 - W3.
*
*         CALLS  LRP, SPB.


 RTE      SUBR               ENTRY
          STML   RTEA
          RJM    LRP         LOAD REQUEST POINTER
          RJM    SPB         SET PP BOUNDS
          LDM    RTP1        *2AP* FUNCTION NUMBER
          STDL   W0
          LDML   CALB+1      *2AP* ERROR STATUS
          STDL   W1
          LDN    0           RFU FIELD
          STDL   W2
          STDL   W3
          RJM    LRP         LOAD REQUEST POINTER
          ADML   RTEA        RETURN ERROR STATUS
          CWDL   W0
          LDC    0#600       *2AP* ENCOUNTERED ERROR
          STML   JOBF
          LJM    RTEX        RETURN NON-STANDARD RESPONSE

 RTEA     BSS    1           ERROR STATUS
*         ENDX   CTP$DFT PROCESS DISK ERROR.
*DECK DECK=CTP$DFT_PROCESS_DUAL_I4_IOU_ERR EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_PROCESS_DUAL_I4_IOU_ERR
*
*         THIS DECK WILL PREPROCESS DUAL I4 IOU ERRORS SO THAT
*         THE PRIMARY DFT CAN PROCESS THEM.


 CSP      SPACE  4,10
**        CSP - COPY INFORMATION FROM SECONDARY IOU BUFFER TO PRIMARY.
*
*         ENTRY  (A) = NUMBER OF CM WORDS TO COPY.
*                (W0 - W3) = R-POINTER TO FWA OF DESTINATION.
*                (W4 - W7) = R-POINTER TO FWA OF SOURCE
*
*         USES   T1, T2.
*
*         CALLS  SPB.


 CSP      SUBR               ENTRY/EXIT
          STM    CSPA        SAVE NUMBER OF WORDS TO COPY
          LRD    W1
          RJM    SPB         SET PP BOUNDS
          LDM    CSPA        LENGTH OF TRANSFER
          ADN    1
          STD    T1
          LDN    0           WORD OFFSET
          STD    T2
 CSP1     SOD    T1
          ZJN    CSPX        IF TRANSFER COMPLETE
          LRD    W5
          LDDL   W4
          ADD    T2
          ADC    RR
          CRML   CSPB,ON     READ NEXT WORD
          LRD    W1
          LDDL   W0
          ADD    T2
          ADC    RR
          CWML   CSPB,ON     WRITE NEXT WORD
          AOD    T2
          UJN    CSP1        PROCESS NEXT WORD

 CSPA     BSS    1           LENGTH OF TRANSFER
 CSPB     BSS    4           TRANSFER BUFFER
 PIR      SPACE  4,15
**        PIR - PROCESS IOU REGISTERS.
*
*         THE IOU REGISTERS FOR THE SELECTED IOU ORDINAL ARE RETRIEVED.
*         FOR IOU0 THIS OCCURS BY CALLING *RIR* TO READ THE APPROPRIATE
*         MAINTENANCE REGISTERS.  FOR IOU1 THIS OCCURS BY READING THE
*         INFORMATION FROM THE SECONDARY DFT BUFFER.
*
*         ENTRY  (IOUO) = IOU ORDINAL.
*
*         USES   T1, T2, T4 - T7, W0 - W7.
*
*         CALLS  IDA, IIB, *RIR*, SER, SPB.


          ROUTINE  PIR

          LDML   IOUO
          NJN    PIR10       IF NOT IOU0
          CALL   RIR         RETRIEVE IOU REGISTERS
          LJM    PIRX        RETURN

*         COPY SCRATCH MRB FROM THE SECONDARY DFT BUFFER TO THE
*         PRIMARY DFT BUFFER.

 PIR10    LDN    SDBP        READ ADDRESS OF SECONDARY DFT BUFFER
          RJM    IDA
          CRDL   T4
          LRD    T5
          LDDL   T4          SOURCE ADDRESS
          ADC    RR+MRBP
          CRDL   W4
          LDN    MRBP        DESTINATION ADDRESS
          RJM    IDA
          CRDL   W0
          LDML   LBUF        COPY LENGTH
          RJM    CSP         COPY INFORMATION FROM SECONDARY DFT BUFFER TO PRIMARY

*         COPY SCRATCH SUPPORTIVE STATUS FROM THE SECONDARY DFT BUFFER TO THE
*         PRIMARY DFT BUFFER.

          LDN    SDBP        READ ADDRESS OF SECONDARY DFT BUFFER
          RJM    IDA
          CRDL   T4
          LRD    T5
          LDDL   T4          SOURCE ADDRESS
          ADC    RR+SSBP
          CRDL   W4
          AODL   W4          DO NOT COPY THE HEADER WORD
          LDN    SSBP        DESTINATION ADDRESS
          RJM    IDA
          CRDL   W0
          AODL   W0
          LDML   W7          COMPUTE COPY LENGTH
          SBN    1           ALLOW FOR THE LENGTH OF THE HEADER WORD
          RJM    CSP         COPY INFORMATION FROM SECONDARY DFT BUFFER TO PRIMARY

          LDN    CMSS
          RJM    GCM         GET CM RESIDENT WORD
          LDN    1           SET FLAG
          RJM    SER         SET SS ERROR READ FLAG TO VALUE
          LJM    PIRX        RETURN
 RIR      SPACE  4,10
**        RIR - RETRIEVE IOU REGISTERS.
*
*         ENTRY  (SUMS) = 4/, 12/STATUS SUMMARY.
*
*         EXIT   CONTENTS OF RELATED IOU REGISTERS OBTAINED.
*
*         CALLS  BRL, *RMR*.


          ROUTINE  RIR

          LDM    SUMS
          LPN    14
          ZJN    RIR10       IF NOT PROCESSOR HALT OR UNCORRECTED ERROR
          LDM    IO0U        UNCORRECTED IOU ERROR LIST
          RJM    BRL         BUILD REGISTER LIST

 RIR10    LDML   REGI
          NJN    RIR20       IF REGISTERS PRESENT ON LIST
          LDM    SUMS
          LPN    2
          ZJN    RIR20       IF NOT CORRECTED ERROR
          LDM    IO0C        CORRECTED IOU ERROR LIST
          RJM    BRL         BUILD REGISTER LIST

 RIR20    LDML   REGI
          ZJN    RIR30       IF NO REGISTERS ON LIST
          CALL   RMR         READ REGISTERS
 RIR30    LJM    RIRX        RETURN
*DECK DECK=CTP$DFT_PVA_TO_RMA_ROUTINES EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_PVA_TO_RMA_ROUTINES
*
*         C. L. WILSON       09/28/87
          SPACE 4,10

**        DPS -  DEFINE PAGE SIZE.
*
*         ENTRY  (PSMV) = CONTENTS OF PAGE SIZE MASK REGISTER.
*
*         EXIT   (PSMV) = PAGE SIZE MASK.
*                (DPSA) = SHIFT INSTRUCTION TO EXTRACT PAGE NUMBER.


 DPS      SUBR               ENTRY/EXIT
          LDC    SHNI+100
          STM    DPSA        SET SHIFT INTO PAGE TABLE SEARCH
          LDM    PSMV
          LMC    0#7F
          STD    T2
          STM    PSMV        SET PAGE SIZE MASK
          SHN    9D
          ADC    777
          STML   PSMV1
 DPS1     SOM    DPSA        ADD TO SHIFT COUNT
          LDD    T2
          SHN    21-0        REMOVE LOWEST BIT
          STD    T2
          NJN    DPS1        IF MORE BITS PRESENT
          UJN    DPSX        RETURN

 DPSA     CON    0
 PSMV1    CON    0
          EJECT
**        LWA -  LOAD WORD ADDRESS.
*
*         ENTRY  (A) = POINTER TO WORD ADDRESS.
*
*         EXIT   (W4 - W5) = R-REGISTER VALUE.
*                (A) = CM ADDRESS.
*                (W6) = OFFSET FROM R-REGISTER.


 LWA      SUBR               ENTRY/EXIT
          STD    W6
          LDML   1,W6
          SHN    -6
          STDL   W5          10 BITS OF R UPPER
          LDI    W6
          LPN    3
          SHN    12          POSITION 2 BITS
          RAD    W5          R-REGISTER UPPER (12 BITS)
          LDI    W6
          SHN    -2
          STD    W4          R-REGISTER LOWER (10 BITS)
          LRD    W4
          LDML   1,W6
          LPN    77
          STD    W6          SET OFFSET
          LMC    RR          ACTIVATE R-REGISTER
          UJN    LWAX        RETURN
          EJECT
**        PVC -  PRESET VIRTUAL ADDRESS CONSTANTS.
*
*         ENTRY  NONE.
*
*         EXIT   (PTAV - PTAV+1) = PAGE TABLE ADDRESS.
*                (PSMV) = PAGE SIZE MASK.
*                (PTLV) = PAGE TABLE LENGTH MASK.
*                (STLV) = SEGMENT TABLE LENGTH
*                (STAV) = SEGMENT TABLE ADDRESS
*
*         USES   T4, T5, RN.
*
*         CALLS  DPS.
*
*         MACROS READMR.


 PVC      SUBR               ENTRY/EXIT
          LDN    PVCAL
          STD    T5
 PVC1     LDM    PVCA+1,T5
          STD    T4          SET DATA ADDRESS
          LDM    PVCA,T5     GET REGISTER NUMBER
          STD    RN
          READMR RDATA,HBUF+CPRPC
          LDM    RDATA+4     FORM 32 BIT VALUE
          SHN    10
          LMM    RDATA+5
          STIL   T4
          LDM    RDATA+6
          SHN    10
          LMM    RDATA+7
          STML   1,T4
          LCN    2
          RAD    T5
          MJN    PVC2        IF NOT MORE REGISTERS TO READ
          LJM    PVC1        GO BACK FOR MORE

 PVC2     RJM    DPS         DEFINE PAGE SIZE
          LJM    PVCX        RETURN

 PVCA     BSS    0           TABLE OF REGISTERS
          LOC    0
          CON    PPTA,PTAV
          CON    PPSM,PSMV-1
          CON    PPTL,PTLV-1
          CON    PSTL,STLV-1
 PVCAL    CON    PSTA,STAV
          LOC    *O
 PTAV     CON    0,0         PAGE TABLE ADDR
 PSMV     CON    0           PAGE SIZE MASK
 PTLV     CON    0           PAGE TABLE LENGTH
 STLV     CON    0           SEGMENT TABLE LENGTH
 STAV     CON    0,0         SEGMENT TABLE ADDRESS
          EJECT
**        SPT -  SEARCH PAGE TABLE.
*
*         ENTRY  (CM - CM+2) = SYSTEM VIRTUAL ADDRESS.
*
*         EXIT   (A) = ADDRESS OF WORD.
*                (SPTJ) = PAGE TABLE ENTRY.
*
*         USES   T1, T2, T3, T4 ,T5 ,T7, W0 - W4.
*
*         CALLS  LWA.


 SPT      SUBR               ENTRY/EXIT
          LDM    DPSA        GET SEARCH PAGE TABLE SHIFT
          STM    SPTA
          STM    SPTC
          STM    SPTH
          ADN    10
          LPC    1077        CREATE 7-SHIFT COUNT
          STM    SPTB
          LDM    DPSA
          LMC    77          COMPLEMENT SHIFT
          STM    SPTF
          STM    SPTI
          LDM    DPSA
          SBN    12
          STM    SPTG

*         FORM PAGE NUMBER

          LDDL   CM+2        PAGE OFFSET
          SHN    -9D
 SPTA     SHN    -0          MODIFIED
          STDL   T2
          LDDL   CM+1        PAGE NUMBER
          LPML   PSMV1       SAVE CORRECT NUMBER OF BITS
 SPTB     SHN    0           POSITION (MODIFIED)
          RADL   T2          T2 = PN (L)
          LDDL   CM+1
          SHN    -9D
 SPTC     SHN    -0          MODIFIED
          STDL   T1          T1 = PN (U)

*         FORM HASH INDEX

          LDDL   T2
          LMDL   CM          EXCLUSIVE OR WITH ASID
          SHN    1           FORM WORD ADDRESS
          STDL   T4          T4 = HASH INDEX (L)
          SHN    -20
          STDL   T3          LEFT MOST BIT (1)
          LDDL   CM
          SHN    -12
          STM    SPTD+1      FORM INSTRUCTION
          LDDL   T2
          LPN    77
 SPTD     LMC    0
          SHN    1
          RAD    T3          T3 = HASH INDEX (U)

*         FORM PAGE TABLE LENGTH MASK

          LDML   PTLV        PAGE TABLE LENGTH
          LPC    177         SAVE 7 BITS
          SHN    9D
          LMC    777         FOR MASK
          STDL   T6          T6 = PAGE TABLE LENGTH MASK (L)
          LDML   PTLV
          SHN    -7
          STD    T5          T5 = PTL MASK (U)

*         MODIFY PAGE NUMBER FOR COMPARE WITH PTE

          LDDL   T1
 SPTF     SHN    0           MODIFIED
          STDL   T1
          LDDL   T2
 SPTG     SHN    -0          MODIFIED
          RAD    T1          T1 = PN UPPER (SHIFTED)
          LDC    0#FFFF      MASK
 SPTH     SHN    -0          MODIFIED
          LPDL   T2
 SPTI     SHN    0           MODIFIED
          STDL   T2          T2 = PN LOWER (SHIFTED)

*         SEARCH PAGE TABLE

          LDML   PTAV+1      FORM WORD ADDRESS OF PTA
          SHN    -3
          STML   PTAW+1
          LDML   PTAV
          LPN    7
          SHN    13D
          RAML   PTAW+1
          LDML   PTAV
          SHN    -3
          STML   PTAW
          LDN    32D
          STD    T7          SET SEARCH LIMIT
 SPT1     LDDL   T4          HASH INDEX (L)
          LPDL   T6          MASK WITH PTL MASK (L)
          STML   SPTK+1
          LDDL   T3          HASH INDEX (U)
          LPDL   T5          MASK WITH PTL MASK (U)
          STML   SPTK
          LDML   PTAW+1
          ADML   SPTK+1      ADD NEW VALUE TO PTA
          STML   PTAV1+1
          SHN    -20         SAVE POSSIBLE CARRY BIT
          STM    PTAV1
          LDML   PTAW
          ADML   SPTK
          RAML   PTAV1       SPT ADDRESS TO BEGIN SEARCH
          LDC    PTAV1
          RJM    LWA         SET ADDR OF PAGE TABLE IN R-REGISTER
          LDDL   W6          PAGE TABLE OFFSET FROM R
          LMC    RR          ACTIVATE R-REGISTER
          CRDL   W0          PAGE TABLE ENTRY
          CRML   SPTJ,ON     SAVE PTE
          LDDL   W0
          SHN    21-17
          PJN    SPT2        IF INVALID PAGE
          SHN    2
          SCN    0#F
          STDL   W0
          LDDL   W1
          SHN    4-20
          RADL   W0          COMPLETE ASID
          LMDL   CM
          NJN    SPT2        IF NOT CORRECT ASID
          LDDL   W1          EXTRACT SPID AND POSITION
          SHN    -6
          LPN    77
          STD    W0
          LDDL   W1
          LPN    77
          SHN    12
          STDL   W1
          LDDL   W2
          SHN    -6
          RADL   W1          W0/W1 = SPID
          LMDL   T2          COMPARE WITH PN
          NJN    SPT2        IF NO MATCH (ON LOWER)
          LDDL   W0
          LMDL   T1
          ZJN    SPT3        IF MATCH (ON UPPER)
SPT2      AODL   T4          INCREMENT PAGE TABLE HASH INDEX
          SHN    -20         SAVE POSSIBLE CARRY BIT
          RADL   T3
          SOD    T7          DECREMENT SEARCH COUNT
          ZJN    SPT4        IF NO MORE TO SEARCH
          LJM    SPT1        CONTINUE SEARCH

 SPT3     LDDL   CM+2
          LPML   PSMV1
          SHN    -9D
          STD    T5          SAVE PAGE OFFSET FOR A-REGISTER

*         SET UP R-REGISTER AND A-REGISTER OFFSET

          LDDL   W3          CREATE RMA
          STD    T2
          SHN    -14
          STD    T1
          LDD    W2          GET UPPER SIX BITS
          LPN    77
          SHN    4
          RAD    T1          (T1 T2) = R-REGISTER
          LDD    CM+2
          LPC    770
          SHN    11
          LMD    T5          INCLUDE UPPER BITS OF BYTE NUMBER
          SHN    6
          LMC    RR          ACTIVATE R-REGISTER
          LRD    T1
 SPT4     UJP    SPTX        RETURN

 SPTJ     CON    0,0,0,0
 SPTK     CON    0,0
 PTAV1    CON    0,0
 PTAW     CON    0,0
          EJECT
**        WMB -  WRITE TO MODEL DEPENDENT BUFFER
*
*         METHOD             INCREMENT THE PTR TO THE
*                            MODEL DEPENDENT BUFFER AND
*                            WRITE DATA FROM MRVAL.
*
*         ENTRY              (MRVAL) - DATA TO BE WRITTEN TO
*                                      MODEL DEP BUFFER
*
*         CALLED             BY RWP, LMB
*
*         USES               RS, MRVAL
*
*         CALLS



 WMB      SUBR               ENTRY/EXIT
          AOML   LTOL        INCREMENT AMOUNT TO LOG COUNTER
          AOD    RS          INCREMENT OFFSET
          LRD    RS+1
          ADC    RR
          CWML   MRVAL,ON
          UJP    WMBX
          EJECT
**        WRZ -  WRITE ZEROS TO MDB
*
*         METHOD             WRITE (A) WORDS OF ZEROS TO
*                            THE MODEL DEPENDENT BUFFER.
*
*         ENTRY              (A) - # OF WORDS
*
*         CALLED             BY RWP, GPP, GNP, WPC
*
*         USES               MRVAL,W6
*
*         CALLS              WMB


 WRZ      SUBR               ENTRY/EXIT
          STDL   W6          # OF WORDS
          LDN    0
          STML   MRVAL
          STML   MRVAL+1
          STML   MRVAL+2
          STML   MRVAL+3
 WRZ0     RJM    WMB         WRITE MODEL DEP BUFFER
          SODL   W6
          NJP    WRZ0
          UJP    WRZX
          EJECT
**        RWP -  READ, WRITE PROGRAM CONTENTS
*
*         METHOD             ADJUST R-RGTR (W5) LOCATIONS.
*                            READ (A) CM WORDS AND WRITE
*                            DATA TO THE MDB.
*
*         ENTRY              (W4)  - # WORDS TO READ
*                            (A) - START READ - RELATIVE TO RMA
*                            (T1 -T2) R-RGTR VALUE
*                            (T3) - OFFSET
*
*         CALLED             BY WPC, GPP, GNP
*
*         USES               T1 - T3, W4, W5, RS
*
*         CALLS


 RWP      SUBR               ENTRY/EXIT
          MJN    RWP1        IF T3-OFFSET < 0
          STDL   T3
 RWP0     LDDL   T3
          ADC    RR
          LRD    T1
          CRML   MRVAL,ON    READ PROGRAM CONTENTS
          RJM    WMB         WRITE MODEL DEP BUFFER
          SODL   W4
          ZJP    RWPX
          AODL   T3          INCREMENT R-RGTR
          UJP    RWP0        READ NEXT WORD

 RWP1     ADC    0#40
          STDL   T3
          LDDL   T2
          ZJP    RWP2        IF NEED TO BORRW FROM T1
          SODL   T2
          UJP    RWP0

 RWP2     LDDL   T1
          ZJN    RWP4        IF (R-RGTR) < (W5)
          SODL   T1
          LDC    0#FFF
          STDL   T2
          UJP    RWP0

 RWP4     LDDL   W4
          RJM    WRZ         WRITE (W4) WORDS OF ZERO
          UJP    RWPX

          EJECT
**        GPP -  GET PREVIOUS PAGE
*
*         METHOD             SUBTRACT 5 WORDS FROM SVA POINTING TO
*                            TO P.  IF RESULT IS NEG, ZEROS ARE
*                            WRITTEN TO MDB.  OTHERWISE CALCULATE
*                            A NEW RMA, AND WRITE THE PTE TO MDB.
*                            WRITE CONTENTS OF CM STARTING AT NEW
*                            RMA FOR A CALCULATED # OF WORDS.
*                            RESTORE ORIGINAL RMA AND COMPLETE
*                            WRITING DATA (INSTRUCTIONS) TO MDB.
*
*         ENTRY              WPCA - RMA POINTING TO P
*                            WPCB - PAGE OFFSET OF P (WORDS)
*
*         CALLED             BY WPC
*
*         USES               T1 - T4, W5, CM
*
*         CALLS              SPT, RWP, WRZ


 GPP      SUBR               ENTRY/EXIT

*         SAVE PTE OF P

          LDD    RS
          LRD    RS+1
          ADC    RR
          CRML   GPPA,ON

*         SUBTRACT 5 WORDS FROM ORIG SVA

          LDDL   CM+2        SVA.BN (BITS 48-63)
          SBN    40D
          PJN    GPP0        IF NO BORROW NEEDED
          LDDL   CM+1
          ZJP    GPP2        IF (SVA.BN - 40) < 0
          SODL   CM+1
          LDC    0#FFFF
          ADDL   CM+2
          SBN    32D         (-5) + 1 WORDS
 GPP0     STDL   CM+2

*         CALCULATE NEW RMA, WRITE TO MDB

          RJM    SPT         GET NEW RMA
          ZJP    GPP2        IF PAGE MISS
          STDL   T3          STORE OFFSET
          AOML   LTOL        INCREMENT AMOUNT TO LOG COUNTER
          LDD    RS
          LRD    RS+1
          ADC    RR
          CWML   SPTJ,ON     WRITE NEW PTE
          AOD    RS
          ADC    RR
          CWML   GPPA,ON     WRITE PTE OF P
          LDN    5
          SBML   WPCB        5 - PG OFFSET = # WORDS TO READ
          STDL   W4
          LDDL   T3
          RJM    RWP         WRITE PROGRAM CONTENTS

*         RESTORE ORIG RMA, COMPLETE WRITE TO MDB

 GPP1     LDML   WPCA        RE-STORE RMA TO P
          STDL   T1
          LDML   WPCA+1
          STDL   T2
          LDML   WPCB
          ADN    6           # WORDS TO READ
          STDL   W4
          LDN    0
          RJM    RWP         WRITE PROGRAM CONTENTS
          LJM    GPPX

 GPP2     LDN    6
          SBML   WPCB
          RJM    WRZ         WRITE (5 - PG.OFFSET) WORDS W/ZEROS
          UJP    GPP1        FINISH WRITING TO MDB
          SPACE  1
 GPPA     CON    0,0,0,0     SAVED PTE
          EJECT
**        GNP - GET NEXT PAGE
*
*         METHOD             WRITE INSTRUCTIONS FROM FIRST PAGE
*                            TO MDB.  ADD (6-(T4)) TO ORIGINAL
*                            SVA AND USE TO CALCULATE NEW RMA.
*                            FILL IN CALCULATED PTE, AND COMPLETE
*                            WRITING (T4) INSTRUCTIONS TO THE MDB.
*
*         ENTRY              (T4) - # WORDS TO READ FROM NEXT PAGE
*
*         CALLED             BY WPC
*
*         USES               T4 W0 - W5, CM
*
*         CALLS              SPT, RWP, WRZ


 GNP      SUBR               ENTRY/EXIT

*         WRITE INSTRUCTIONS FROM ORIG PAGE

          STML   GNPA        # WORDS ON NEXT PAGE
          LDN    1
          RJM    WRZ         WRITE ZEROS TO 2ND PTE
          LDN    11D
          SBDL   T4
          STDL   W4          # WORDS ON ORIG PAGE
          STML   GNPB
          LDDL   T3
          SBN    5           READ ADDR - RELATIVE TO RMA
          RJM    RWP         READ, WRITE PROGRAM CONTENTS

*         FIND NEXT PAGE, WRITE TO MDB

          LDN    6
          SBDL   T4
          SHN    3           CHANGE TO BYTES
          RADL   CM+2        CALC NEW SVA
          SHN    -20
          RADL   CM+1
          SHN    2
          MJN    GNP0        IF OVERFLOW
          RJM    SPT         SEARCH PAGE TABLE
          ZJN    GNP0        IF PAGE MISS
          STDL   T3          STORE OFFSET
          LRD    RS+1
          LDD    RS
          SBML   GNPB        RESET MDB PTR
          ADC    RR
          CWML   SPTJ,ON     WRITE PAGE TABLE ENTRY
          LDML   GNPA
          STDL   W4
          LDN    0
          RJM    RWP         WRITE DATA FROM 2ND PAGE
          LJM    GNPX

 GNP0     LDML   GNPA        WORDS ON NEXT PAGE
          RJM    WRZ         WRITE (GNPA) WORDS OF ZEROS
          LJM    GNPX
          SPACE  1
*         SAVE AREA

 GNPA     CON    0           # WORDS ON NEXT PAGE
 GNPB     CON    0           # WORDS ON ORIG PAGE

*         END    CTP$DFT_PVA_TO_RMA_ROUTINES
*DECK DECK=CTP$DFT_READ_EPM_DATA EXPAND=FALSE
*         CTEXT CTP$DFT_READ_EPM_DATA
*
*         THIS DECK GATHERS DATA FROM THE ENVIRONMENT POWER
*         MONITOR ON A 960 CLASS MAINFRAME AND LOGS THE DATA
*         TO THE NON REGISTER STATUS BUFFER.
 RED      SPACE  4,10
**        RED - READ EPM POWER MONITOR DATA.
*
*         USES   CM - CM+3, T1 - T5, W0 - W7.
*
*         CALLS  CLR, CPC, IDA, RFP, SPB, *IPF*, *LOG*.


          ROUTINE RED

          LDM    PKFLG
          ZJP    REDX        IF PACKETS ARE NOT SUPPORTED
          LDN    VER5
          RJM    VCK         CHECK VERSION
          MJP    REDX        IF VERSION DOESNT SUPPORT NRSB

*         IF MIDNIGHT, THEN DO NOT READ EPM DATA.

          LDN    DFCM+7
          RJM    IIB
          CRML   REDD,ON     GET TIME (TOP OF HOUR)
          LDML   REDD+2
          LPC    0#FF00
          ZJP    REDX        IF MIDNIGHT

          LDM    CUOV
          STM    PKTCW1      SAVE CURRENT OVERLAY
          LDC    RED1
          STM    PKTCW2      SAVE RE ENTRY POINT
          LDN    1
          SHN    10B
          LMML   PKTCW
          STML   PKTCW       SET CONTROL WORD TO INDICATE PHASED PROCESSING
          LDN    GETNF
          STM    PKTPH       SET PHASE TO GET NEW FAULTS
          LDN    0
          STM    FALT        INITIALIZE ACCUMULATED EPM FAULTS

 RED1     LDML   PKTCW       SUBSEQUENT ENTRY POINT AFTER INITIAL ENTRY
          LPC    PKWTO       CHECK TIMEOUT FLAG SET
          ZJN    RED4        IF NO TIMEOUT
 RED2     LJM    CPC1        CLEANUP PACKET COMMUNICATION

 RED4     LDM    PES1
          NJN    RED2        IF PACKET ERROR ENCOUNTERED

          LDM    PKTPH
          STD    T1
          SBN    PKTPL
          PJP    RED15       IF BAD PHASE IN PACKET PROCESS
          LDM    REDA,T1
          STD    T1
          LJM    0,T1        JUMP TO PHASE TO PROCESS

*         PHASE  0

 RED6     BSS    0           GET NEW FAULTS
          LDN    EPMRNF
          STM    TOIP        SET EPM TASK IN PACKET
          LDN    GETER
          STM    PKTPH       NEXT PHASE TO PROCESS IS GET EPM REVISION

*         LENGTH IS ONE 8 BIT DATA BYTE ONE 8 BIT SEQUENCE NUMBER

          LDN    2
          STM    RTP2

*         SET CONTROL WORD OFFSET TO ONE, FUNCTION, SEQUENCE IN UPPER BYTE

          LDC    0#B*0#100+PKFET
          STML   RTP1
          CALL   IPF         ISSUE PACKET FUNCTION
          LJM    REDX        RETURN

*         PHASE 1

 RED7     BSS    0           GET EPM REVISION
          LDM    TOIP+ESER
          LPC    0#FF
          STML   FALT        SAVE EPM SYSTEM ERROR FLAG
          LDM    TOIP+EBDE
          LPC    0#FF00
          RAML   FALT        SAVE EPM BOARD ERROR FLAG
          NJP    RED8        IF AN ERROR EXISTS PROCESS
          LJM    CPC1        CLEANUP PACKET COMMUNICATION

 RED8     LPC    0#FF00
          ZJP    RED11       IF ONLY A SYSTEM ERROR EXISTS
          LDN    EPMRD
          STM    TOIP        SET EPM TASK IN PACKET
          LDN    GETEI
          STM    PKTPH       NEXT PHASE TO PROCESS IS GET EXCEPTION INTERRUPT COUNTERS

*         LENGTH IS ONE 8 BIT DATA BYTE ONE 8 BIT SEQUENCE NUMBER

          LDN    2
          STM    RTP2

*         SET CONTROL WORD OFFSET TO ONE, FUNCTION, SEQUENCE IN UPPER BYTE

          LDC    0#B*0#100+PKFET
          STML   RTP1
          CALL   IPF         ISSUE PACKET FUNCTION
          LJM    REDX        RETURN

*         PHASE 2

 RED9     BSS    0           GET EXCEPTION INTERRUPT COUNTERS
          RJM    RFP         REFORMAT PACKET DATA
          LDM    CMIN
          STD    T1
          LDN    DCMP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   CM
          LRD    CM+1
          LDD    CM
          ADC    RR+CMEPM
          CWML   REDC,T1     WRITE REVISION LEVEL DATA TO CM RESIDENT
          LDN    EPMRIC
          STM    TOIP        SET EPM TASK IN PACKET
          LDN    GETEB
          STM    PKTPH       NEXT PHASE TO PROCESS IS GET BOARD FLAG ERROR BUFFER

*         LENGTH IS ONE 8 BIT DATA BYTE ONE 8 BIT SEQUENCE NUMBER

          LDN    2
          STM    RTP2

*         SET CONTROL WORD OFFSET TO ONE, FUNCTION, SEQUENCE IN UPPER BYTE

          LDC    0#B*0#100+PKFET
          STML   RTP1
          CALL   IPF         ISSUE PACKET FUNCTION
          LJM    REDX        RETURN

*         PHASE 3

 RED10    BSS    0           GET BOARD FLAG ERROR BUFFER
          LDM    CMTL        SIZE OF EXCEPTION INTERRUPT COUNTERS
          STD    T5
          RJM    RFP         REFORMAT PACKET DATA
          LDM    CMIN
          STD    T1
          LDN    DCMP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   CM
          LRD    CM+1
          LDD    CM
          ADD    T5
          ADC    RR+CMEPM
          CWML   REDC,T1     WRITE EXCEPTION INTERRUPT COUNTERS TO CM RESIDENT
          LDN    EPMBFD
          STM    TOIP        SET EPM TASK IN PACKET
          LDN    LOG407
          STM    PKTPH       NEXT PHASE TO PROCESS IS TO LOG 407 DFT ANALYSIS

*         LENGTH IS ONE 8 BIT DATA BYTE ONE 8 BIT SEQUENCE NUMBER

          LDN    2
          STM    RTP2

*         SET CONTROL WORD OFFSET TO ONE, FUNCTION, SEQUENCE IN UPPER BYTE

          LDC    0#B*0#100+PKFET
          STML   RTP1
          CALL   IPF         ISSUE PACKET FUNCTION
          LJM    REDX        RETURN

*         PHASE 4

 RED11    BSS    0           GET CYCLIC BUFFER 2
          LDN    EPMRRB
          STM    TOIP        SET EPM TASK IN PACKET
          LDN    LOG408
          STM    PKTPH       NEXT PHASE TO PROCESS IS TO LOG 408 DFT ANALYSIS

*         LENGTH IS ONE 8 BIT DATA BYTE ONE 8 BIT SEQUENCE NUMBER

          LDN    2
          STM    RTP2

*         SET CONTROL WORD OFFSET TO ONE, FUNCTION, SEQUENCE IN UPPER BYTE

          LDC    0#B*0#100+PKFET
          STML   RTP1
          CALL   IPF         ISSUE PACKET FUNCTION
          LJM    REDX        RETURN

*         PHASE 5

 RED12    BSS    0           LOG TO NRSB 407
          LDM    CMTL
          STD    T5          SAVE CURRENT CM RESIDENT WORD POSITION
          RJM    RFP         REFORMAT PACKET DATA
          LDM    CMIN
          STD    T1
          LDN    DCMP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   CM
          LRD    CM+1
          LDD    CM
          ADD    T5
          ADC    RR+CMEPM
          CWML   REDC,T1     WRITE BOARD ERROR BUFFER DATA TO CM RESIDENT
          LDN    BC
          RJM    CLR
          LDN    0
          STD    ET

*         ERROR PRIORITY - CORRECTED.
*         DFT ANALYSIS - EPM REPORTED AN INTERNAL BOARD ERROR.
*         FLAGS - LOGGING

          SETDAN (EPCO,DAEBE) EPM REPORTED INTERNAL BOARD ERROR
          SETFLG (BC.FL)
          LRD    DP+1
          RJM    SPB         SET OS BOUNDS
          LDM    CMTL        SIZE OF REVISION DATA, EXCEPTION INTERRUPT COUNTERS, AND BOARD ERRORS
          STD    T1
          LDN    NRSP        NON REGISTER STATUS BUFFER
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0          POINTER TO NRSB
          LDN    DCMP        CENTRAL MEMORY RESIDENT POINTER
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W4          POINTER TO CM RESIDENT
          LDN    CMEPM
          RADL   W4          POSITION TO PACKET DATA PORTION
 RED13    LRD    W5
          LDDL   W4
          ADD    T1
          ADC    RR
          CRDL   CM          GET DATA IN CM RESIDENT
          LRD    W1
          LDD    W0
          ADD    T1
          ADC    RR+NRSBL+1  BASE SIZE + HEADER WORD
          CWDL   CM          WRITE DATA TO SCRATCH NON REGISTER SUPPORTIVE STATUS
          SOD    T1
          PJN    RED13       IF MORE TO MOVE
          LDM    CMTL
          ADN    NRSBL
          SBN    1
          STM    LLOG        LENGTH TO LOG
          LDN    1
          STML   RTP1
          CALL   LOG         LOG THE ERROR
          LDN    0
          STM    CMTL
          STM    CMIN
          LDML   FALT
          LPC    0#FF        ISOLATE POSSIBLE SYSTEM ERROR
          NJP    RED11       IF SYSTEM ERROR EXISTS
          LJM    CPC         CLEANUP PACKET COMMUNICATION

*         PHASE  6

 RED14    BSS    0           LOG TO NRSB 408
*         RJM    FPD         FILTER PACKET DATA
          RJM    RFP         REFORMAT PACKET DATA
          LDN    BC
          RJM    CLR
          LDN    0
          STD    ET

*         ERROR PRIORITY - CORRECTED.
*         DFT ANALYSIS - EPM REPORTED A SYSTEM ERROR.
*         FLAGS - LOGGING.

          SETDAN (EPCO,DAESE) EPM REPORTED SYSTEM ERROR
          SETFLG (BC.FL)
          LRD    DP+1
          RJM    SPB         SET OS BOUNDS
          LDN    NRSP        NON REGISTER STATUS BUFFER
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0          POINTER TO NRSB
          LRD    W1
          LDM    CMTL        SIZE OF CYCLIC BUFFER 2 DATA
          STD    T1
          LDD    W0
          ADC    RR+NRSBL+1  BASE SIZE + HEADER WORD
          CWML   REDC,T1     WRITE BOARD FLAG ERROR DATA TO SCRATCH NRSB
          LDM    CMTL
          ADN    NRSBL
          SBN    1
          STM    LLOG        LENGTH TO LOG
          LDN    1
          STML   RTP1
          CALL   LOG         LOG THE ERROR
          LJM    CPC         CLEANUP PACKET COMMUNICATION

 RED15    BSS    0
          LDD    T1
          STM    REDB+3      SAVE OUT OF PHASE CONDITION
          LDN    BC
          RJM    CLR
          LDN    0
          STD    ET
          SETDAN (EPUN,DABP) BAD PHASE IN PACKET COMMUNICATION
          SETFLG (BC.FL)
          LRD    DP+1
          RJM    SPB         SET OS BOUNDS
          LDN    NRSP        NON REGISTER STATUS BUFFER
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0
          LRD    W1
          LDDL   W0
          ADC    RR+NRSBL+1  BASE SIZE + HEADER WORD
          CWML   REDB,ON     WRITE ERROR CODE TO SCRATCH SUPPORTIVE STATUS
          LDN    NRSBL
          STM    LLOG        LENGTH TO LOG
          LDN    1
          STML   RTP1
          CALL   LOG         LOG THE ERROR
          LJM    CPC         CLEANUP PACKET COMMUNICATION

 REDA     BSS    0
          LOC    0
          CON    RED6        PHASE 0 - GET NEW FAULTS
          CON    RED7        PHASE 1 - GET EPM REVISION
          CON    RED9        PHASE 2 - GET EXCEPTION INTERRUPT COUNTERS
          CON    RED10       PHASE 3 - GET EPM BOARD FLAG ERROR BUFFER
          CON    RED11       PHASE 4 - READ CYCLIC BUFFER 2
          CON    RED12       PHASE 5 - LOG TO NRSB 407
          CON    RED14       PHASE 6 - LOG TO NRSB 408
          CON    CPC1        PHASE 7 - RESET EPM TASK
 PKTPL    BSS    0
          LOC    *O

 REDB     BSSZ   4
 REDD     BSS    4           TIME STAMP FROM EICB
 CPC      SPACE  4,10
**        CPC - CLEANUP PACKET COMMUNICATION.
*
*         THIS ROUTINE RESETS ALL CONTROL VARIABLES USED IN
*         OBTAINING EPM DATA.
*

 CPC      LDM    PKTPH
          LMN    CLEPC
          ZJN    CPC1        IF CLEANUP ALREADY TRIED
          LDN    EPMRS
          STM    TOIP
          LDN    CLEPC
          STM    PKTPH
          LDN    2
          STM    RTP2
          LDC    0#B*0#100+PKFET
          STML   RTP1
          CALL   IPF
          LJM    REDX        RETURN

 CPC1     LDN    0
          STM    PKTCW1
          STM    PKTCW2
          STM    FALT
          STM    PKTPH
          STM    PKTCW
          STM    CMTL
          STM    CMIN
          LJM    REDX        RETURN
 IPF      SPACE  4,10
**        IPF - ISSUE PACKET FUNCTION.
*
*         EXIT   TO *CPC*, IF ERROR ON PACKET SEND.
*
*         CALLS  CLR, IDA, *LOG*, *PKT*, SPB.


          ROUTINE IPF

          CALL   PKT         MAKE PACKET REQUEST
          LDC    PKWRP
          RAML   PKTCW       SET RESPONSE PENDING IN CONTROL WORD
          LDM    CALB+1
          ZJP    IPFX        IF NO ERROR RETURN

*         LOG DFT/EPM INTERFACE ERROR.

          STM    IPFA+3      SAVE ERROR CODE
          LDN    BC
          RJM    CLR
          LDN    0
          STD    ET
          SETDAN (EPUN,DAEF) DFT/EPM INTERFACE ERROR
          SETFLG (BC.FL)
          LRD    DP+1
          LDN    NRSP        NON REGISTER STATUS BUFFER
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0
          LRD    W1
          RJM    SPB         SET OS BOUNDS
          LDDL   W0
          ADC    RR+NRSBL+1  BASE SIZE + HEADER WORD
          CWML   IPFA,ON     WRITE ERROR CODE TO SCRATCH SUPPORTIVE STATUS
          LDN    NRSBL
          STM    LLOG        LENGTH TO LOG
          LDN    1
          STML   RTP1
          CALL   LOG         LOG THE ERROR
          LJM    CPC         CLEANUP PACKET COMMUNICATION

 IPFA     BSSZ   4           48/0, 16/ERROR CODE
 FPD      SPACE  4,15
**        FPD - FILTER PACKET DATA.
*
*         ENTRY  PACKET DATA IN TOIP.
*
*         EXIT   THIS CODE IS CURRENTLY A STUB.
*                THE EPM DATA IS SCANNED LOOKING FOR A 73(16) ERROR
*                CODE. IF THIS CODE IS FOUND THE REMAINING EPM DATA
*                WILL BE TRUNCATED AS IT IS FELT THAT IT IS SUSPECT.
*
*         USES   T1, T2, T3.


 FPD      SUBR               ENTRY/EXIT
          UJP    FPDX        RETURN




 RFP      SPACE  4,15
**        RFP - REFORMAT PACKET DATA.
*
*         ENTRY  PACKET DATA IN TOIP.
*
*         EXIT   REFORMATTED PACKET IN *REDC*.
*                THIS CONSISTS OF REMOVING THE FIRST BYTE IN THE
*                BUFFER AND STRIPPING OFF THE SEQUENCE NUMBER
*                AND CHECKSUM DATA BYTES.
*                (CMIN) = NUMBER OF CM WORDS IN THIS PACKET.
*                (CMTL) = TOTAL NUMBER OF CM WORDS FROM ALL PACKETS
*                         PROCESSED SO FAR.
*
*         USES   T1, T2, T3, T4


 RFP      SUBR               ENTRY/EXIT
          LDM    TOIP
          LPC    0#FF
          SHN    10
          STDL   T1          SAVE UPPER BYTE OF LENGTH
          LDML   TOIP+1
          SHN    -10
          LMDL   T1
          STDL   T1          SAVE BOTH LOWER AND UPPER BYTES OF LENGTH
          ADN    7
          SHN    -3
          STM    CMIN        SAVE NUMBER OF CM WORDS IN THIS PACKET
          RAML   CMTL        UPDATE RUNNING TOTAL
          LDN    0
          STD    T4
          STD    T2
 RFP1     LDML   TOIP,T2
          LPC    0#FF
          SHN    10
          STDL   T3
          SODL   T1
          MJN    RFPX
          AOD    T2
          LDML   TOIP,T2
          SHN    -10
          LMDL   T3
          STML   REDC,T4
          SODL   T1
          AOD    T4
          UJP    RFP1

 REDC     BSSZ   500

*         END    CTP$DFT_READ_EPM_DATA
*DECK DECK=CTP$DFT_READ_MAINTENANCE_REGS EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT READ MAINTENANCE REGS.
 RMR      SPACE  4,10
**        RMR - READ MAINTENANCE REGISTERS.
*
*         ENTRY  (REGI) = NUMBER OF LIST ENTRIES.
*                (REGL) = ARRAY OF LIST ADDRESSES TO PROCESS.
*
*         EXIT   THE MAINTENANCE REGISTERS IN EACH SPECIFIC LIST FOR
*                THE MODEL AND ELEMENT ARE READ AND STORED IN MAINTENANCE
*                REGISTER BUFFER 0.
*
*         CALLS  SLM, SNR, SPB, SRB, ZMR.


          ROUTINE RMR

*         ZERO MAINTENANCE REGISTER BUFFER.

          LRD    DP+1
          RJM    SPB         SET PP BOUNDARY
          RJM    ZMR
          LDM    IOUN
          ZJN    RMR0        IF IN IOU0
          RJM    ZSS         ZERO SUPPORTIVE STATUS BUFFER
 RMR0     LDM    REGI        GET SIZE OF LIST
          STD    T3
          LDN    0
          STD    T4          INITIALIZE CURRENT INDEX
          LDDL   MP
          RJM    SRB         SAVE BASE OFFSET TO BUFFER
 RMR1     LDM    REGL,T4     GET AN ELEMENT TYPE
          STM    RMRA        SAVE ELEMENT TYPE
          RJM    SCC         SET CONNECT CODE
          AOD    T4
          LDM    REGL,T4     GET LIST ADDRESS
          STD    T1
          LDI    T1
          STD    T6          SAVE LIST LENGTH
          AOD    T1          INCREMENT ADDRESS PAST LENGTH HEADER
          LRD    MP+1        SET UP *R* TO POINT TO BUFFER
 RMR2     LDI    T1          GET REGISTER NUMBER FROM LIST
          STD    RN

*         AT THIS POINT CHECK IF REGISTERS ARE BEING READ FOR A PROCESSOR
*         IF THEY ARE AND THE REGISTER IS SUMMARY STATUS THEN GET THE ORIGINAL
*         SUMMARY STATUS BEFORE THE PROCESSOR WAS HALTED BY THE *APE* OVERLAY.

          NJN    RMR4        IF NOT SUMMARY STATUS
          LDM    RMRA        GET ELEMENT TYPE
          SBN    PROCID
          NJN    RMR4        IF NOT A PROCESSOR
          LDN    7
          STD    T5          NUMBER OF BYTES TO STORE
 RMR3     LDM    OLSS        GET OLD SUMMARY STATUS
          STM    RDATA,T5
          SOD    T5
          PJN    RMR3
          UJN    RMR5        CONTINUE

 RMR4     READMR RDATA
 RMR5     LDM    S0FLG       CHECK MAINFRAME TYPE
          ZJN    RMR6        IF NOT S0/S0E
          LDM    RMRA        GET ELEMENT TYPE
          SHN    14          POSITION TO UPPER HEX DIGIT
          LMDL   RN
          STDL   RN          SAVE FOR STORE TO MRB
 RMR6     RJM    SNR         STORE REGISTER IN BUFFER
          SOD    T6
          MJN    RMR7        IF LIST EXHAUSTED
          AOD    T1          ADDRESS OF NEXT REGISTER IN LIST
          LJM    RMR2        LOOP

 RMR7     AOD    T4          BUMP CURRENT INDEX
          SBD    T3          SUBTRACT FROM LENGTH
          MJP    RMR1        LOOP
          LDN    0
          STM    REGI        RESET REGISTER INDEX

*         SET THE LOGGED MRB SIZE IN THE SCRATCH SUPPORTIVE STATUS BUFFER.

          LDDL   T2          DETERMINE LOGGED MRB SIZE
          ZJN    RMR8        IF NO PARTIAL GROUPING
          AODL   T2
 RMR8     LDML   /DSIPUR/RINX
          SBDL   MP
          RAML   T2
          RJM    SLM         SET LOGGED MRB SIZE IN SUPPORTIVE SCRATCH BUFFER
          LJM    RMRX        RETURN

 RMRA     CON    0           STORAGE FOR ELEMENT TYPE

 SCC      SPACE  4,10
**        SCC - SET CONNECT CODE.
*
*         ENTRY  (A) = ELEMENT TYPE FROM REGISTER LIST ENTRY.
*
*         EXIT   *EC* SET TO PROPER ELEMENT CONNECT CODE.
*
*         USES   T1.


 SCC      SUBR               ENTRY/EXIT
          STD    T1          SAVE ELEMENT TYPE
          LMK    IOUID
          NJN    SCC1        IF NOT IOU
          LDM    I0CC
          STD    EC
          UJN    SCCX        RETURN

 SCC1     LDD    T1
          SBN    CMID
          NJN    SCC2        IF NOT MEMORY
          LDM    CMCC
          STD    EC
          UJN    SCCX        RETURN

 SCC2     LDD    T1
          SBN    PROCID
          NJN    SCC5        IF NOT PROCESSOR
          LDM    CPUO        GET CPU ORDINAL
          NJN    SCC3        IF NOT CPU-0
          LDM    CP0CC       PROCESS CPU-0
          UJN    SCC4        CONTINUE

 SCC3     LDM    CP1CC       PROCESS CPU-1
 SCC4     STD    EC
          UJN    SCCX        RETURN

 SCC5     LDM    S0PMC       PAGE MAP CONNECT CODE
          STD    EC
          UJN    SCCX        RETURN
 SLM      SPACE  4,10
**        SLM - SET LOGGED MRB SIZE IN SCRATCH SUPPORTIVE STATUS BUFFER.
*
*         ENTRY  (T2) = LOGGED MRB SIZE.
*
*         EXIT   LOGGED MRD SIZE SET IN SCRATCH SUPPORTIVE STATUS BUFFER.
*                MRB TYPE IS SET TO *MTMRB*.
*
*         USES   CM - CM+3.
*
*         CALLS  IDA, VCK.


 SLM      SUBR               ENTRY/EXIT
          LDN    VER4        CHECK *DFT* VERSION NUMBER
          RJM    VCK
          MJN    SLMX        IF LESS THAN VERSION 4
          LDD    T2
          STM    LLOG        SAVE LENGTH TO LOG
          LDN    SSBP        READ SUPPORTIVE STATUS HEADER WORD
          RJM    IDA
          CRDL   CM
          AODL   CM          SKIP TO SCRATCH ENTRY HEADER WORD
          LRD    CM+1
          ADC    RR
          CRML   SLMA,ON
          LDDL   T2          SET LOGGED MRB SIZE
          STML   SLMA+3
          LDML   SLMA
          LPC    0#FF00
          ADN    MTMRB       SET MRB TYPE
          STML   SLMA
          LDDL   CM          REWRITE HEADER WORD
          ADC    RR
          CWML   SLMA,ON
          LJM    SLMX        RETURN

 SLMA     BSS    4
 ZMR      SPACE  4,10
**        ZMR - ZERO MAINTENANCE REGISTER BLOCK 0.
*
*         EXIT   MAINTENANCE REGISTER BLOCK 0 INITIALIZED TO ZERO.
*
*         USES   T1.
*
*         CALLS  IMB.


 ZMR      SUBR               ENTRY/EXIT
          LDN    0
          STD    T1
 ZMR1     LDD    T1
          RJM    IMB
          CWML   ZERO,ON
          AOD    T1
          SBM    LBUF
          PJN    ZMRX        IF DONE
          UJN    ZMR1        LOOP

 ZERO     BSSZ   4

*         END    CTP$DFT READ MAINTENANCE REGS
*DECK DECK=CTP$DFT_RELEASE_HISTORY EXPAND=FALSE
          CTEXT  CTP$DFT RELEASE HISTORY.
 HISTORY  SPACE  4,10
***       *DFT* RELEASE HISTORY.
*
*         LEVEL 01 - RELEASED WITH CIP005 AND NOS/VE 1.1.4, SEPT. 1985.
*
*         LEVEL 99 - CONTAINED CYBER 810 FIX.
*
*         LEVEL 02 - RELEASED WITH CIP006 AND NOS/VE 1.2.1, AUG. 1986.
*
*         LEVEL 98 - CONTAINED I4 CHANNEL STATUS FIX.
*
*         LEVEL 97 - CONTAINED SEVERAL PSR FIXES, REMOVED TIMEOUT ON
*         ACQUIRING CH17 FLAG, CORRECTED CH17 ERROR HANDLING, AND ADDED
*         SUPPORT FOR 840S MAINFRAME.
*
*         LEVEL 96 - CONTAINED TWO PSR FIXES.
*
*         LEVEL 95 - CONTAINED THREE THETA-RELATED PSR FIXES.
*
*         LEVEL 03 - RELEASED WITH CIP007 AND NOS/VE 1.2.2, APRIL 1987.
*
*         LEVEL 94 - CONTAINED SEVERAL PSR FIXES.  RELEASED JUNE 1987.
*
*         LEVEL 93 - RELEASED WITH CIP008 AND NOS/VE 1.2.3, SEPT. 1987.
*
*         LEVEL 92 - CONTAINED LRZ DUAL I4 PRE-RELEASE CODE, OCT. 1987.
*
*         LEVEL 04 - RELEASED WITH CIP009 AND NOS/VE 1.3.1, APRIL 1988.
*         IN THIS RELEASE DFT WAS SPLIT INTO MODEL-SPECIFIC VARIANTS FOR
*         LOWER CYBER 8XX, CYBER 835, UPPER CYBER 8XX, CYBER 930, CYBER 960,
*         AND CYBER 990.
*
*         LEVEL 89 - CODE REVISION 89 WAS NEVER FIELD RELEASED.  CHANGES
*         INCLUDE SUPPORT FOR ENHANCED I4 PACKETS AND USE OF A COMMON
*         DECK FOR GENERATING FAULT SYMPTOM CODES FOR MEMORY ERRORS
*         ON A CYBER 960.
*
*         LEVEL 88 - RELEASED WITH CIP LEVEL 704, JUNE 1988. CHANGES INCLUDE
*         SUPPORT FOR THE CYBER 960 SERIES HARDWARE.
*
*         LEVEL 87 - RELEASED WITH CIP LEVEL 710, SEP. 1988. CONTAINED FIX
*         FOR A CYBER 960 HARDWARE DEFICIENCY.
*
*         LEVEL 86 - CONTAINED FIX FOR A CYBER 960 PROBELM INVOLVING THE
*         MAC. RELEASED DEC. 1988.
*
*         LEVEL 05 - RELEASED WITH CIP LEVEL 716, DECEMBER, 1988.
*
*         LEVEL 85 - ADDED CAPABILITY TO HANDLE CPU DEADMAN TIMEOUT FROM
*         CENTRAL MEMORY REFERENCE ON 96X. RELEASED JAN. 1989.
*
*         LEVEL 84 - CONTAINED FIX FOR NV05819 IN WHICH DFT PRESET WAS
*         CORRUPTING A WORD IN CENTRAL MEMORY. RELEASED FEB. 1989.
*
*         LEVEL 83 - ADDED DUAL 960 CPU SUPPORT TO DFT.
*
*         LEVEL 82 - CONTAINED A FIX FOR DFTA184 (960 DFT VARIANT).
*         THIS FIX RESTARTS A 960 CPU WHEN IT IS HALTED AND NO
*         CORRECTED OR UNCORRECTED ERRORS ARE PRESENT AND THE MICRAND
*         ADDRESS IS 5.  RELEASED MARCH, 1989.
*
*         LEVEL 06 - ADDED SUPPORT FOR THE SECONDARY DFT POINTER IN THE
*         DFT BUFFER AREA. RELEASED WITH CIP LEVEL 727, JUNE, 1989.
*
*         LEVEL 07 - ADDED SUPPORT FOR DFT TO PUT 1707, 1708, 4XX, 5XX, 6XX
*         AND NEGATIVE SIT ANALYSIS CODES IN THE NON-REGISTER STATUS BUFFER.
*         RELEASED WITH CIP LEVEL 739 DECEMBER, 1989.
*
*         LEVEL 81 - ADDED FIXES FOR: HAVING A 960 WITHOUT A PC CONSOLE,
*         DFT INTERNAL KNOWLEDGE OF WHETHER IT IS AN UPPER OR LOWER PP, AND
*         IGNORING A BAD PACKET STATUS FROM THE PC CONSOLE ON A 930 DOING
*         A DATE/TIME UPDATE. RELEASED IN FEBRUARY, 1990.
*
*         LEVEL 08 - SAME AS LEVEL 81, RELEASED WITH CIP LEVEL 750, JUNE, 1990.
*
*         LEVEL 80 - SUPPORTED RELOAD OF SCM ON THETA MODELS AT TOP OF HOUR.
*
*         LEVEL 80 - SUPPORTED NOT HALTING CPU WHEN IN STANDALONE NOS ON THE 960
*                    AND CHANGING MEMORY REGISTERS.
*
*         LEVEL 79 - CHANGES FOR 990, 960, 830 TO UPDATE MRT ON CIP DISK WHEN
*                    IN STANDALONE VE.
*
*         LEVEL 09 - SUPPORTS LEVEL 1.5.3 CIP L765.
*
*         LEVEL 10 - SUPPORTS LEVEL 1.6.1 CIP L780.
*
*         LEVEL 11 - SUPPORTS LEVEL 780AB.
*
*         LEVEL 12 - CONTAINED A FIX FOR 960 VARIANT OF DFT TO RESOLVE
*         PSR DFT0055.  RELEASED APRIL, 1992.
*
*         LEVEL 13 - CONTAINED A FIX FOR 960 VARIANT OF DFT TO RESOLVE
*         PSR DFTA213 (ALSO INCLUDED DFT0055 FIX).  RELEASED JUNE, 1992.
*
*         LEVEL 14 - FIX TO WAIT 100MS AFTER HALT PROCESSOR
*
*         LEVEL 15 - CHANGES TO 960 VARIANT TO IMPLEMENT DUAL STATE
*         NOS/NOSVE IN CPU-0, AND NOS ONLY IN CPU-1.  DFT WILL TEST
*         WORD 71, BIT 5 (NOS IN BOTH CPU-S) FLAG DURING A DUAL-STATE
*         DEADSTART CALL FROM SCI.  IF SET, THEN DFT SETS BIT 8 IN THAT
*         WORD SO THAT THE 960 MICROCODE WILL PASS CPU-0 PURGE REQUESTS TO
*         NVE TRAP HANDLER, INSTEAD OF HAVING THE MICROCODE HANDLE IT.
*         DFT WILL CLEAR BIT 8 WHEN SCI TAKES NVE DOWN, SO THAT DUAL
*         CPU NOS CAN RESUME.  ALSO, DFT WILL NOT RESET PIT IN CPU-0
*         IF IT FINDS NVE FIELD LENGTH IN THE DUAL-STATE CONTROL BLOCK.
*         NOS USES PIT IN THAT MODE.

          SPACE  4,10
          ENDX
*DECK DECK=CTP$DFT_REQUESTS_DUAL_I4 EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_REQUESTS_DUAL_I4
*
*         NOTE:  IF HCM$ IS DEFINED THE CPUS WILL BE HALTED BEFORE ANY
*                MEMORY REGISTERS ARE WRITTEN.
*         THIS DECK CONTAINS O.S. REQUESTS MADE ON DUAL I4 IOU SYSTEMS
 LDS      SPACE  4,15
**        LDS - LOAD DFT INTO SECONDARY IOU.
*
*         CALLS  IIB, LRP, MPB, SPB, SRS.
*
*         NOTE   LOADING OF *DFT* INTO THE SECONDARY IOU IS SEPARATED INTO
*                THREE PHASES:
*                PHASE 0:  A PACKET IS SENT TO LOAD A BOOT PROGRAM INTO
*                          IOU1.  THIS BOOT PROGRAM WILL LOAD DFT-S.
*                PHASE 1:  A PACKET IS SENT TO START EXECUTION OF THE LOADED
*                          PROGRAM.
*                PHASE 2:  *DFT* WAITS FOR DFT-S TO SIGNAL ITS COMPLETION OF
*                          PRESET BY CLEARING A BIT IN *D8ST*.


          ROUTINE  LDS

          LDML   DI4CW
          SHN    21-16
          PJN    LDS2        IF NO TIME OUT
          LDC    0#8000+PKETO
          STML   LDSQ
          LJM    LDS50       PERFORM ERROR EXIT PROCESSING

 LDS2     SHN    21-17-21+16+22
          PJP    LDS4        IF NO RESPONSE PENDING
          RJM    CRS         CHECK RESPONSE STATUS
          ZJP    LDSX        IF NO RESPONSE PACKET

*         RECEIVE RESPONSE PACKET.

          LDML   DI4CW       CLEAR RESPONSE PENDING
          LPC    0#7FFF
          STML   DI4CW
          LDN    40          REQUEST = RECEIVE PACKET
          STM    CALB+0
          LDC    TOIP        BUFFER ADDRESS = *2AP* BUFFER (AT 2000)
          STML   CALB+2
          LDN    MX          GET CHANNEL 15 INTERLOCK
          RJM    SCF         SET CHANNEL FLAG
          FNC    MXPT,MX     SELECT PORT
          AJM    *,MX
          CALL   PFC         CALL *2AP*
          FNC    MXDM,MX     DESELECT MUX
          AJM    *,MX
          CCF    *,MX        RELEASE CHANNEL 15 INTERLOCK
          CALL   CER         CHECK ERROR RESPONSE
          LDML   PES1
          STML   LDSQ
          LPC    PKWRP       RESET RESPONSE PENDING IF MISMATCH ON SEQUENCE NUMBER
          STDL   T1
          RAML   DI4CW
          LDDL   T1
          NJP    LDSX        IF MISMATCH ON SEQUENCE NUMBER
          LDM    LDSQ
          NJP    LDS50       IF ERROR ON REQUEST
          LDN    1           ADVANCE TO NEXT PHASE
          RAML   DI4CW
          LJM    LDSX        RETURN

 LDS4     LDM    DI4CW       CHECK CONTROL WORD (12 BITS - IGNORE RESPONSE PENDING)
          STD    T1
          SBN    LDSPL       CHECK VALIDITY OF PHASE
          PJP    ERR         IF NOT IN RANGE
          LDM    LDSP,T1     SET PHASE PROCESSOR
          STD    T2
          LJM    0,T2        EXECUTE PHASE

*         PHASE 0 - LOAD BOOT TO PP IN OTHER IOU.

 LDS10    LDN    VER6
          RJM    VCK         CHECK VERSION
          PJN    LDS15       IF VERSION 6 OR GREATER
          LDC    RCVI*0#100  VERSION NOT AT CORRECT LEVEL
          LJM    ERR10       RETURN NON-STANDARD RESPONSE

 LDS15    LDC    PKWIU       SET IN-USE FLAG
          RAML   DI4CW
          LDML   PKTCW
          LPC    PKWRP
          NJP    LDSX        IF RESPONSE IS PENDING FOR GENERAL REQUEST
          AOML   PKCT        INCREMENT RETRY COUNT
          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0          READ REQUEST
          LDDL   W2          GET PP NUMBER
          LPC    0#FF00
          RAML   LDSB
          LDN    IOSB        *READMR RDATA,IOCC,IOSB*
          STDL   RN
          LDM    I0CC
          RJM    RMR         READ MAINTENANCE REGISTER
          LDML   RDATA+5     SAVE OS BOUNDS
          STML   LDSD+OB
          LDML   RDATA+6
          STML   LDSD+OB+1
          LDML   RDATA+7
          STML   LDSD+OB+2
          LRD    DH+1        DFT WITHIN THE CIP DIRECTORY
          LDD    DH
          ADC    RR+1
          STML   LDSD+SC     SAVE A
          CRML   T3+LDSD,ON  READ DIRECTORY ENTRY
          LDDL   DH+1
          STML   LDSD+SC+1
          LDDL   DH+2
          STML   LDSD+SC+2
          LDN    DSEBP
          RJM    IIB         INDEX INTERFACE BLOCK
          CRML   LDSD+CD,ON  FETCH CIP DIRECTORY POINTER
          LDC    LDSAL*10000B+LDSA
          RJM    MPB         MOVE PACKET TO BUFFER

*         COMPLETE REQUEST.

          LDK    2*LDSAL-1   SET LENGTH OF PACKET IN 8-BIT BYTES
          STML   RTP2
          LDC    0*0#200+PKFTD  SET SEQUENCE LOCATION AND FUNCTION
          LJM    LDS70       ISSUE PACKET REQUEST

*         PHASE 1 - START BOOT EXECUTING IN SECOND IOU.

 LDS20    BSS    0           ENABLE THE MEMORY PORT TO SECONDARY IOU
          IF     DEF,HCM$
          RJM    HAC         HALT ALL CPUS
          ENDIF
          LOCKMR SET
          READMR RDATA,CMCC,ECMR
          LDM    RDATA+4
          SCN    20
          STM    RDATA+4
          WRITMR RDATA,CMCC,ECMR
          LOCKMR CLEAR
          IF     DEF,HCM$
          LDN    0
          RJM    SAC         START ALL CPUS
          ENDIF
          LDN    D8ST        SET DEADSTART DFT-S FLAG
          RJM    IIB         INDEX INTERFACE BLOCK
          CRDL   W0
          RJM    SPB         SET PP BOUNDS
          LDDL   W3
          LPC    0#F7FF
          LMC    0#800
          STDL   W3
          LDN    D8ST
          RJM    IIB         INDEX INTERFACE BLOCK
          CWDL   W0
          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0          READ REQUEST
          LDDL   W2          GET PP NUMBER
          LPC    0#FF00
          RAML   LDSG
          LDC    LDSFL*10000B+LDSF
          RJM    MPB         MOVE PACKET TO BUFFER
          LDK    2*LDSFL     SET LENGTH OF PACKET IN 8-BIT BYTES
          STML   RTP2
          LDC    1*0#200+PKFEP  SET SEQUENCE LOCATION AND FUNCTION
          LJM    LDS70       ISSUE PACKET REQUEST

*         PHASE 2 - VERIFY DFT-S PRESET COMPLETE.

 LDS30    LDN    D8ST
          RJM    IIB         INDEX INTERFACE BLOCK
          CRDL   W0
          LDN    0           NO ERROR
          STM    LDSQ
          LDDL   W3
          SHN    21-13
          PJN    LDS40       IF DFT-S PRESET COMPLETE
          LJM    LDSX        RETURN

*         COMPLETE REQUEST PROCESSING.

 LDS40    LDML   LDSQ
          NJN    LDS50       IF ERROR ON REQUEST
          LDN    0
          STML   DI4CW       CLEAR CONTROL WORD
          STML   PKTIM       CLEAR PACKET TIMING WORD
          LDC    0#100       SET REQUEST COMPLETE
          STM    JOBF
          RJM    SRS         RESPOND TO VE REQUEST
          LJM    LDSX        RETURN

*         COMMON ERROR EXIT PROCESSING.

 LDS50    LDM    DI4CW
          SBN    1
          MJP    LDS60       IF PHASE 1 HAS NOT BEEN PROCESSED
          IF     DEF,HCM$
          RJM    HAC         HALT ALL CPUS
          ENDIF
          LOCKMR SET         DISABLE THE SECONDARY IOU MEMORY PORT
          READMR RDATA,CMCC,ECMR
          LDM    RDATA+4
          SCN    20
          LMN    20
          STM    RDATA+4
          WRITMR RDATA,CMCC,ECMR
          LOCKMR CLEAR
          IF     DEF,HCM$
          LDN    0
          RJM    SAC         START ALL CPUS
          ENDIF
 LDS60    LDN    0
          STML   DI4CW       CLEAR CONTROL WORD
          STML   PKTIM       CLEAR PACKET TIMING WORD
          LDML   LDSQ
          LPC    0#FF
          LMN    PKETO       TIMEOUT ERROR
          ZJP    ERR         IF NOT RETRYABLE
          LDC    RCRR*0#100  RETRYABLE ERROR
          LJM    ERR10       RETURN NON-STANDARD RESPONSE

 LDS70    ADC    DI4CW*0#400-TPKT*0#400+1*0#400  START TIMING *DI4CW* REQUEST
          STML   RTP1
          CALL   PKT         PROCESS CONSOLE PACKETS VIA *2AP*
          LDC    PKWRP       SET RESPONSE PENDING
          RAML   DI4CW
          LDML   CALB+1
          STML   LDSQ        SAVE ERROR RESPONSE
          NJP    LDS40       IF ERROR ON REQUEST
 LDS80    LJM    LDSX        RETURN

*         PACKET FOR TRANSMITTING BOOT TO OTHER IOU.

 LDSA     CON    **          8/SOURCE PP, 8/SOURCE IOU
 LDSB     CON    1           8/DESTINATION PP, 8/DESTINATION IOU
 LDSC     CON    0           LOAD ADDRESS
 LDSD     BSS    0           START OF PROGRAM
          LOC    0
          CON    BTS-1
          BSS    2
 T3       CON    0,0,0,0     DIRECTORY ENTRY

 BTS      LDD    T3
          STD    BTSA
          LDD    SC
          ADC    RR+1
          LRD    SC+1
          CRML   **,T3+1
 BTSA     EQU    *-1         LOAD ADDRESS OF PROGRAM
          LDN    1           *DFT* IOU NUMBER
          STD    70
          LJM    100         START RUNNING PROGRAM

 RF       CON    0           *DFT* RESTART FLAG
          ERRNZ  RF-23       *DFT* PRESET MUST BE CHANGED
 OB       CON    0,0,0       OS BOUNDS
          ERRNZ  OB-24
          BSS    30-*
 SC       CON    0,0,0       ADDRESS OF PROGRAM DIRECTORY ENTRY
          CON    0           (UNUSED)
 CD       CON    0,0,0,0     POINTER TO CIP DIRECTORY
 LDSDL    BSS    0
          LOC    *O
 LDSE     CON    **          8/0, 8/SEQUENCE BYTE
 LDSAL    EQU    *-LDSA      LENGTH OF PACKET IF PP WORDS

*         PACKET FOR STARTING EXECUTION OF DFT-S.

 LDSF     CON    0           8/SOURCE PP, 8/SOURCE IOU
 LDSG     CON    1           8/DESTINATION PP, 8/DESTINATION IOU
 LDSH     CON    BTS         EXECUTION ADDRESS
 LDSI     CON    **          8/SEQUENCE BYTE, 8/EXECUTION TYPE
 LDSFL    EQU    *-LDSF      LENGTH OF PACKET IN PP WORDS

*         PHASE PROCESSORS.

 LDSP     BSS    0
          LOC    0
          CON    LDS10       PHASE 0 - LOAD BOOT
          CON    LDS20       PHASE 1 - START EXECUTION
          CON    LDS30       PHASE 2 - VERIFY DFT-S PRESET COMPLETE

 LDSPL    BSS    0           MAXIMUM PHASE + 1
          LOC    *O
 LDSQ     CON    0           ERROR INDICATOR
 MPB      SPACE  4,10
**        MPB - MOVE PACKET TO BUFFER.
*
*         ENTRY  (A) = 6/LENGTH, 12/FWA OF PACKET.
*
*         USES   T1 - T3.


 MPB      SUBR               ENTRY/EXIT
          STD    T1          FWA
          SHN    -14
          ADD    T1          LWA + 1 OF PACKET
          STD    T2
          LDC    TOIP        FWA OF BUFFER
          STD    T3
 MPB10    LDIL   T1
          STIL   T3
          AOD    T3
          AOD    T1
          SBD    T2
          MJN    MPB10       IF TRANSFER NOT COMPLETE
          UJP    MPBX        RETURN

*         END    CTP$DFT_REQUESTS_DUAL_I4
*DECK DECK=CTP$DFT_REQUESTS_DUAL_I4_960 EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_REQUESTS_DUAL_I4_960
*
*         THIS DECK CONTAINS O.S. REQUESTS MADE ON DUAL I4 IOU SYSTEMS
*         NOTE:  THIS DECK IS CLONED FOR THE 960 VERSION OF DFT.  ANY CHANGES
*                SHOULD BE MADE IN CTP$DFT_REQUESTS_DUAL_I4_960.
 LDS      SPACE  4,10
**        LDS - LOAD DFT INTO SECONDARY IOU.
*
*         CALLS  IIB, LRP, MPB, SPB, SRS.
*
*         NOTE   LOADING OF *DFT* INTO THE SECONDARY IOU IS SEPARATED INTO
*                THREE PHASES:
*                PHASE 0:  A PACKET IS SENT TO LOAD A BOOT PROGRAM INTO
*                          IOU1.  THIS BOOT PROGRAM WILL LOAD DFT-S.
*                PHASE 1:  A PACKET IS SENT TO START EXECUTION OF THE LOADED
*                          PROGRAM.
*                PHASE 2:  *DFT* WAITS FOR DFT-S TO SIGNAL ITS COMPLETION OF
*                          PRESET BY CLEARING A BIT IN *D8ST*.


          ROUTINE  LDS

          LDML   DI4CW
          SHN    21-16
          PJN    LDS2        IF NO TIME OUT
          LDC    0#8000+PKETO
          STML   LDSQ
          LJM    LDS50       PERFORM ERROR EXIT PROCESSING

 LDS2     SHN    21-17-21+16+22
          PJP    LDS4        IF NO RESPONSE PENDING
          RJM    CRS         CHECK RESPONSE STATUS
          ZJP    LDSX        IF NO RESPONSE PACKET

*         RECEIVE RESPONSE PACKET.

          LDML   DI4CW       CLEAR RESPONSE PENDING
          LPC    0#7FFF
          STML   DI4CW
          LDN    40          REQUEST = RECEIVE PACKET
          STM    CALB+0
          LDC    TOIP        BUFFER ADDRESS = *2AP* BUFFER (AT 2000)
          STML   CALB+2
          LDN    MX          GET CHANNEL 15 INTERLOCK
          RJM    SCF         SET CHANNEL FLAG
          FNC    MXPT,MX     SELECT PORT
          AJM    *,MX
          CALL   PFC         CALL *2AP*
          FNC    MXDM,MX     DESELECT MUX
          AJM    *,MX
          CCF    *,MX        RELEASE CHANNEL 15 INTERLOCK
          CALL   CER         CHECK ERROR RESPONSE
          LDML   PES1
          STML   LDSQ
          LPC    PKWRP       RESET RESPONSE PENDING IF MISMATCH ON SEQUENCE NUMBER
          STDL   T1
          RAML   DI4CW
          LDDL   T1
          NJP    LDSX        IF MISMATCH ON SEQUENCE NUMBER
          LDM    LDSQ
          NJP    LDS50       IF ERROR ON REQUEST
          LDN    1           ADVANCE TO NEXT PHASE
          RAML   DI4CW
          LJM    LDSX        RETURN

 LDS4     LDM    DI4CW       CHECK CONTROL WORD (12 BITS - IGNORE RESPONSE PENDING)
          STD    T1
          SBN    LDSPL       CHECK VALIDITY OF PHASE
          PJP    ERR         IF NOT IN RANGE
          LDM    LDSP,T1     SET PHASE PROCESSOR
          STD    T2
          LJM    0,T2        EXECUTE PHASE

*         PHASE 0 - LOAD BOOT TO PP IN OTHER IOU.

 LDS10    LDN    VER4
          RJM    VCK         CHECK VERSION
          PJN    LDS15       IF VERSION 4 OR GREATER
          LDC    0#500       VERSION NOT AT CORRECT LEVEL
          LJM    ERR10       RETURN NON-STANDARD RESPONSE

 LDS15    LDC    PKWIU       SET IN-USE FLAG
          RAML   DI4CW
          LDML   PKTCW
          LPC    PKWRP
          NJP    LDSX        IF RESPONSE IS PENDING FOR GENERAL REQUEST
          AOML   PKCT        INCREMENT RETRY COUNT
          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0          READ REQUEST
          ADN    1
          CRDL   W4
          LDDL   W2          GET PP NUMBER
          LPC    0#FF00
          RAML   LDSB
          LRD    DH+1        DFT WITHIN THE CIP DIRECTORY
          LDD    DH
          ADC    RR+1
          STML   LDSD+SC     SAVE A
          CRML   T3+LDSD,ON  READ DIRECTORY ENTRY
          LDDL   DH+1
          STML   LDSD+SC+1
          LDDL   DH+2
          STML   LDSD+SC+2
          LDN    DSEBP
          RJM    IIB         INDEX INTERFACE BLOCK
          CRML   LDSD+CD,ON  FETCH CIP DIRECTORY POINTER
          LDC    LDSAL*10000B+LDSA
          RJM    MPB         MOVE PACKET TO BUFFER

*         SET EICB POINTER TO THE SECONDARY DFT BUFFER.

          RJM    SPB         SET PP BOUNDS
          AOD    W4          SET OFFSET TO POINT AT CONTROL WORD
          LDN    DSCM+4
          RJM    IIB         INDEX INTERFACE BLOCK
          CWDL   W4

*         COMPLETE REQUEST.

          LDK    2*LDSAL-1   SET LENGTH OF PACKET IN 8-BIT BYTES
          STML   RTP2
          LDC    0*0#200+PKFTD  SET SEQUENCE LOCATION AND FUNCTION
          LJM    LDS70       ISSUE PACKET REQUEST

*         PHASE 1 - START BOOT EXECUTING IN SECOND IOU.

 LDS20    RJM    HAC         HALT ALL CPUS
          LOCKMR SET         ENABLE THE MEMORY PORT TO SECONDARY IOU
          READMR RDATA,CMCC,ECMR
          LDM    RDATA+4
          SCN    20
          STM    RDATA+4
          WRITMR RDATA,CMCC,ECMR
          LOCKMR CLEAR
          LDN    0
          RJM    SAC         START ALL CPUS
          LDN    D8ST        SET DEADSTART DFT-S FLAG
          RJM    IIB         INDEX INTERFACE BLOCK
          CRDL   W0
          RJM    SPB         SET PP BOUNDS
          LDDL   W3
          LPC    0#F7FF
          LMC    0#800
          STDL   W3
          LDN    D8ST
          RJM    IIB         INDEX INTERFACE BLOCK
          CWDL   W0
          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0          READ REQUEST
          LDDL   W2          GET PP NUMBER
          LPC    0#FF00
          RAML   LDSG
          LDC    LDSFL*10000B+LDSF
          RJM    MPB         MOVE PACKET TO BUFFER
          LDK    2*LDSFL     SET LENGTH OF PACKET IN 8-BIT BYTES
          STML   RTP2
          LDC    1*0#200+PKFEP  SET SEQUENCE LOCATION AND FUNCTION
          LJM    LDS70       ISSUE PACKET REQUEST

*         PHASE 2 - VERIFY DFT-S PRESET COMPLETE.

 LDS30    LDN    D8ST
          RJM    IIB         INDEX INTERFACE BLOCK
          CRDL   W0
          LDN    0           NO ERROR
          STM    LDSQ
          LDDL   W3
          SHN    21-13
          PJN    LDS40       IF DFT-S PRESET COMPLETE
          LJM    LDSX        RETURN

*         COMPLETE REQUEST PROCESSING.

 LDS40    LDML   LDSQ
          NJN    LDS50       IF ERROR ON REQUEST
          LDN    0
          STML   DI4CW       CLEAR CONTROL WORD
          STML   PKTIM       CLEAR PACKET TIMING WORD
          LDC    0#100       SET REQUEST COMPLETE
          STM    JOBF
          RJM    SRS         RESPOND TO VE REQUEST
          LJM    LDSX        RETURN

*         COMMON ERROR EXIT PROCESSING.

 LDS50    LDN    0           CLEAR EICB POINTER TO SECOND DFT BUFFER
          STDL   W0
          STDL   W1
          STDL   W2
          STDL   W3
          RJM    IIB         INDEX INTERFACE BLOCK
          RJM    SPB         SET PP BOUNDS
          LDN    DSCM+4
          RJM    IIB         INDEX INTERFACE BLOCK
          CWDL   W0
          LDM    DI4CW
          SBN    1
          MJP    LDS60       IF PHASE 1 HAS NOT BEEN PROCESSED
          RJM    HAC         HALT ALL CPUS
          LOCKMR SET         DISABLE THE SECONDARY IOU MEMORY PORT
          READMR RDATA,CMCC,ECMR
          LDM    RDATA+4
          SCN    20
          LMN    20
          STM    RDATA+4
          WRITMR RDATA,CMCC,ECMR
          LOCKMR CLEAR
          LDN    0
          RJM    SAC         START ALL CPUS
 LDS60    LDN    0
          STML   DI4CW       CLEAR CONTROL WORD
          STML   PKTIM       CLEAR PACKET TIMING WORD
          LDML   LDSQ
          LPC    0#FF
          LMN    PKETO       TIMEOUT ERROR
          ZJP    ERR         IF NOT RETRYABLE
          LDC    0#400       RETRYABLE ERROR
          LJM    ERR10       RETURN NON-STANDARD RESPONSE

 LDS70    ADC    DI4CW*0#400-TPKT*0#400+1*0#400  START TIMING *DI4CW* REQUEST
          STML   RTP1
          CALL   PKT         PROCESS CONSOLE PACKETS VIA *2AP*
          LDC    PKWRP       SET RESPONSE PENDING
          RAML   DI4CW
          LDML   CALB+1
          STML   LDSQ        SAVE ERROR RESPONSE
          NJP    LDS40       IF ERROR ON REQUEST
 LDS80    LJM    LDSX        RETURN

*         PACKET FOR TRANSMITTING BOOT TO OTHER IOU.

 LDSA     CON    **          8/SOURCE PP, 8/SOURCE IOU
 LDSB     CON    1           8/DESTINATION PP, 8/DESTINATION IOU
 LDSC     CON    0           LOAD ADDRESS
 LDSD     BSS    0           START OF PROGRAM
          LOC    0
          CON    BTS-1
          BSS    2
 T3       CON    0,0,0,0     DIRECTORY ENTRY

 BTS      LDD    T3
          STD    BTSA
          LDD    SC
          ADC    RR+1
          LRD    SC+1
          CRML   **,T3+1
 BTSA     EQU    *-1         LOAD ADDRESS OF PROGRAM
          LDN    1           *DFT* IOU NUMBER
          STD    70
          LJM    100         START RUNNING PROGRAM

 RF       CON    0           *DFT* RESTART FLAG
          ERRNZ  RF-23       *DFT* PRESET MUST BE CHANGED
          BSS    30-*
 SC       CON    0,0,0       ADDRESS OF PROGRAM DIRECTORY ENTRY
          CON    0           (UNUSED)
 CD       CON    0,0,0,0     POINTER TO CIP DIRECTORY
 LDSDL    BSS    0
          LOC    *O
 LDSE     CON    **          8/0, 8/SEQUENCE BYTE
 LDSAL    EQU    *-LDSA      LENGTH OF PACKET IF PP WORDS

*         PACKET FOR STARTING EXECUTION OF DFT-S.

 LDSF     CON    0           8/SOURCE PP, 8/SOURCE IOU
 LDSG     CON    1           8/DESTINATION PP, 8/DESTINATION IOU
 LDSH     CON    BTS         EXECUTION ADDRESS
 LDSI     CON    **          8/SEQUENCE BYTE, 8/EXECUTION TYPE
 LDSFL    EQU    *-LDSF      LENGTH OF PACKET IN PP WORDS

*         PHASE PROCESSORS.

 LDSP     BSS    0
          LOC    0
          CON    LDS10       PHASE 0 - LOAD BOOT
          CON    LDS20       PHASE 1 - START EXECUTION
          CON    LDS30       PHASE 2 - VERIFY DFT-S PRESET COMPLETE

 LDSPL    BSS    0           MAXIMUM PHASE + 1
          LOC    *O
 LDSQ     CON    0           ERROR INDICATOR
 MPB      SPACE  4,10
**        MPB - MOVE PACKET TO BUFFER.
*
*         ENTRY  (A) = 6/LENGTH, 12/FWA OF PACKET.
*
*         USES   T1 - T3.


 MPB      SUBR               ENTRY/EXIT
          STD    T1          FWA
          SHN    -14
          ADD    T1          LWA + 1 OF PACKET
          STD    T2
          LDC    TOIP        FWA OF BUFFER
          STD    T3
 MPB10    LDIL   T1
          STIL   T3
          AOD    T3
          AOD    T1
          SBD    T2
          MJN    MPB10       IF TRANSFER NOT COMPLETE
          UJP    MPBX        RETURN

*         END    CTP$DFT_REQUESTS_DUAL_I4_960

*DECK DECK=CTP$DFT_REQUESTS_IOU1_DUAL_I4 EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_REQUESTS_IOU1_DUAL_I4
*
*         THIS DECK DEFINES O.S. REQUESTS MADE SPECIFICALLY
*         FOR IOU1 IN A DUAL IOU SYSTEM.
          SPACE  4,10
 QUAL$    EQU    0           UNQUALIFY COMMON DECKS
 IAP      SPACE  4,10
**        IAP - IDLE ALL I/O DRIVERS IN IOU1.
*
*         EXIT   FOR IOU1, ALL PPS IN THE MAP IDLED AND CHANNELS
*                MASTER CLEARED AND DCN-D (EXCEPT FOR CIO CHANNELS,
*                WHICH ARE NOT DCN-D).
*
*         CALLS  IDI, IDP, LRP, SRS.
*
*         USES   W0 - W3.


          ROUTINE  IAP

          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0          FETCH REQUEST PARAMETERS
          LDDL   W1          GET SUBFUNCTION NUMBER
          LPC    0#FF
          SBN    1
          ZJN    IAP10       IF REQUEST TO IDLE DFT-S
          RJM    IDI         IDLE IOU1
          LJM    IAPX        RETURN

*         IDLE *DFT*.

 IAP10    LDC    0#100
          STM    JOBF        SET 180 STATUS OK
          RJM    SRS         RESPOND TO VE REQUEST
          LDM    //PPNO      DFT PP NUMBER
          RJM    IDP         IDLE PP
          LJM    ERR         ERROR IF *DFT* NOT IDLED
          SPACE  4,10
**        COMMON DECKS.


*copy     ctp$dft_idle_iou1
*copy     dsi$dump_load_idle_pp

*         END    CTP$DFT_REQUESTS_IOU1_DUAL_I4
*DECK DECK=CTP$DFT_REQUEST_PROCESSOR_2 EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT REQUEST PROCESSOR 2.
*
*         THIS DECK DEFINES O.S. REQUESTS. THE REQUESTS DEFINED ARE *ACA*,
*         *ADR*, *AHE, *FPR*, *GMR*, *MVP*, *RDL* AND *RPL*.
 ACA      SPACE  4,10
**        ACA - READ/WRITE COMMON DISK AREA.
*
*         EXIT   TO *PDE* IF *2AP* ERROR ENCOUNTERED.
*
*         USES   T1, T5, W0 - W7.
*
*         CALLS  LRP, PFC, SPB, *ERR*.


          ROUTINE  ACA

          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0          READ FUNCTION PARAMETERS
          ADN    1
          CRDL   W4          READ POINTER PARAMETER
          LDN    20B         FUNCTION NUMBER
          STM    CALB
          STM    RTP1
          LDDL   W3          5/0,1/V,1/S,1/P,1/0,1/W,1/C,5/0
          LPC    0#740
          LMML   CALB
          STML   CALB
          LDD    W1
          STM    CALB+1      UPPER 12 BITS OF NAME
          LDD    W2
          STM    CALB+2      LOWER 12 BITS OF NAME
          LDD    W3          WRITE BIT
          LPC    0#40
          NJP    ACA10       IF WRITE TO BE PERFORMED
          CALL   PFC         PREPARE FOR *2AP* CALL
          LDML   CALB+1      CHECK FOR ERROR
          ZJN    ACA5        IF NO ERROR ON CALL
          SBN    76+1
          PJN    ACA5        IF NO ERROR ON CALL
          LDC    0#4002      NO RETURN / SET STATUS / OFFSET TO STATUS WORD
          STML   RTP2
          CALL   PDE         PROCESS DISK ERROR ENCOUNTERED BY *2AP*

 ACA5     RJM    LRP         LOAD REQUEST POINTER
          CRDL   W4          READ SPECIAL CASE FOR CEL
          LDD    W7
          LPC    0#20
          NJP    ACA20       IF CEL SECTOR, IGNORE VALID CHECK
          LDM    CALB+1
          SHN    21-12       GET V BIT
          MJP    ACA20       IF DATA IS VALID
          LDC    0#300       DFT INVALID CDA DATA READ
          LJM    ERR10       RETURN RESPONSE

*         WRITE DATA TO CDA.

 ACA10    LDC    360/4
          STD    T1
          LDML   W3
          SHN    21-11
          MJN    ACA15       IF 16 BIT DATA
          LDC    500/4
          STD    T1
 ACA15    LDD    T1
          SBDL   W7
          MJP    ERR         IF SECTOR LIMIT < LENGTH TO WRITE
          LDD    W7
          STD    W2
          SHN    2
          STM    CALB+3      SAVE PP WORD COUNT
          LRD    W5
          LDML   TOUB        *2AP* OUTPUT BUFFER OFFSET FOR LINKAGE BYTES
          STML   ACAA
          LDD    W4
          ADC    RR
          CRML   **,W2       READ IN DATA TO BE WRITTEN
 ACAA     EQU    *-1
          CALL   PFC         PREPARE FOR *2AP* CALL
          LDML   CALB+1
          ZJP    ACAX        IF NO ERRORS ON FUNCTION CALL
          SBN    76+1
          PJP    ACAX        IF NO ERRORS ON FUNCTION CALL
          LDC    0#4002      NO RETURN / SET STATUS / OFFSET TO ERROR STATUS WORD
          STML   RTP2
          CALL   PDE         PROCESS DISK ERROR ENCOUNTERED BY *2AP*

*         READ DATA FROM CDA.

 ACA20    LDM    CALB+1
          LPC    0#1FF       SAVE WORD COUNT
          ADN    3           ROUND UP TO NEAREST NUMBER OF CM WORDS
          SHN    -2          CM WORD COUNT
          STD    T5
          RJM    LRP         LOAD REQUEST POINTER
          ADN    1           RETURN LENGTH OF DATA READ
          CRDL   W4
          LDDL   W7
          STDL   T1
          LDDL   T5
          STDL   W7
          RJM    LRP         LOAD REQUEST POINTER
          ADN    1
          CWDL   W4
          LDDL   T1          COMPARE LENGTHS
          SBD    T5
          MJP    ERR         IF BUFFER LENGTH < WORD COUNT READ
          LRD    W5          POINTER
          RJM    SPB         SET PP BOUNDARY
          LDML   TOUB        *2AP* OUTPUT BUFFER
          STML   ACAB
          LDD    W4
          ADC    RR
          CWML   **,T5       WRITE DATA TO CENTRAL MEMORY
 ACAB     EQU    *-1
          LJM    ACAX        RETURN
 ADR      SPACE  4,10
**        ADR - ACCESS DEADSTART SECTOR.
*
*         EXIT   TO *PDE* IF *2AP* ERROR ENCOUNTERED.
*
*         USES   W0 - W7.
*
*         CALLS  LRP, PFC, *ERR*.


          ROUTINE  ADR

          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0          GET PARAMETERS FOR *2AP*
          LDN    30B         FUNCTION FOR READ DEADSTART SECTOR
          STM    CALB
          STM    RTP1
          LDDL   W2          DISK TYPE
          LPC    0#FF
          SHN    6
          STDL   T1
          LDDL   W1          CHANNEL
          LPC    0#FF
          LMDL   T1          6/DEVICE TYPE, 6/CHANNEL
          STM    CALB+1
          LDDL   W2          UNIT
          SHN    -10
          STM    CALB+2
          RJM    LRP         LOAD REQUEST POINTER
          ADN    1
          CRDL   W4          GET POINTER TO DATA
          LDML   W7          CHECK LENGTH
          SBK    500/4
          MJP    ERR         IF R-POINTER LENGTH IS LESS THAN ONE SECTOR
          LDC    500/4
          STD    W7
          LDDL   W3          GET WHETHER TO WRITE OR READ
          SHN    -10
          ZJP    ADR10       IF READ THE SECTOR
          LDC    130B        FUNCTION TO WRITE THE SECTOR
          STM    CALB
          LRD    W5          GET R-REGISTER
          LDML   TINB        *2AP* INPUT BUFFER
          STML   ADRA
          LDD    W4          GET A OFFSET
          ADC    RR
          CRML   **,W7       READ TO *2AP* BUFFER
 ADRA     EQU    *-1
          CALL   PFC         PRESERVE DATA AND CALL *2AP*
          LDML   CALB+1
          ZJP    ADRX        IF NO ERRORS ON CALL, RETURN
 ADR5     LDC    0#4002      NO RETURN / SET STATUS / OFFSET TO ERROR STATUS WORD
          STML   RTP2
          CALL   PDE         PROCESS DISK ERROR ENCOUNTERED BY *2AP*

 ADR10    CALL   PFC         PRESERVE DATA AND CALL *2AP*
          LDML   CALB+1
          NJN    ADR5        IF ERROR ON FUNCTION, RETURN *2AP* ERROR STATUS
          LRD    W5
          RJM    SPB         SET PP BOUNDARY
          LDML   TOUB        *2AP* OUTPUT BUFFER W/ LINKAGE BYTES
          STML   ADRB
          LDD    W4          OFFSET
          ADC    RR
          CWML   **,W7       WRITE SECTOR TO MEMORY
 ADRB     EQU    *-1
          LJM    ADRX        RETURN
 AHE      SPACE  4,15
**        AHE - ACCESS HARDWARE DESCRIPTOR.
*
*         THIS ROUTINE EITHER READS OR WRITES A SPECIFIED
*         DESCRIPTOR IN THE *MRT*.
*
*         WHEN A WRITE IS PERFORMED, THE OLD AND NEW DESCRIPTOR FIRST WORDS
*         (PP) MUST BE IDENTICAL (MATCH IN SIZE AND TYPE).  AFTER UPDATING
*         THE CM MRT, THE UPDATED MRT WILL BE WRITTEN TO THE CIP OR CONSOLE
*         DISK SO SUBSEQUENT DEADSTARTS WILL RETAIN THE UPDATED STATUS.
*         IF THE DESCRIPTOR IS A CPU DESCRIPTOR, AND THE CPU STATUS HAS BEEN
*         CHANGED FROM ON TO DOWN/OFF, THEN THE MEMORY PORT IS DISABLED.
*
*         EXIT   TO *PDE* IF *2AP* ERROR ENCOUNTERED.
*
*         CALLS  FHE, LRP, PFC, PHT, SPB, WHE, *DIP*, *ERR*.


          ROUTINE  AHE       ENTRY/EXIT

          RJM    PHT         PRESET HARDWARE TABLE
          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0          FETCH REQUEST PARAMETERS
          ADN    1
          CRDL   W4
          LDDL   W2          NUMBER
          SHN    14-0        POSITION THE NUMBER OF THE ELEMENT
          ADDL   W3          6/NUMBER, 12/TYPE
          RJM    FHE         FIND HARDWARE ELEMENT
          MJP    ERR         IF NOT FOUND
          LDML   HBUF        CALCULATE WORD COUNT OF DATA IN *HBUF*
          SHN    -6
          ADN    3
          SHN    -2
          STD    T7
          LDDL   W1          READ INDICATOR
          ZJN    AHE10       IF WRITE REQUEST
          LDDL   W7          CHECK BUFFER SIZE
          SBD    T7
          MJP    ERR         IF BUFFER WILL NOT HOLD DATA
          LRD    W5
          RJM    SPB         SET PP BOUNDS
          LDDL   W4          OFFSET
          ADC    RR
          CWML   HBUF,T7     WRITE *HBUF* TO BUFFER
          LJM    AHEX        RETURN

*         PROCESS WRITE REQUEST.

 AHE10    LDDL   W7          CM WORD SIZE MUST MATCH
          SBD    T7
          NJP    ERR         IF MISMATCH ON SIZE TO BE WRITTEN
          LDN    CMXLEN/4
          STD    T1
          LRD    W5          READ IN NEW MRT DEFINITION
          LDDL   W4
          ADC    RR
          CRML   AHEA,T1

*         IF WRITING A CPU DESCRIPTOR, SAVE THE ON/DOWN/OFF STATUS OF THE
*         CURRENT DESCRIPTOR.  IF THE STATUS IS CHANGING FROM ON TO DOWN OR
*         OFF, *DFT* NEEDS TO DISABLE THE MEMORY PORT.

          LDM    HBUF+CPRHDR
          LPN    77
          LMN    PROCID
          NJN    AHE20       IF NOT CPU DESCRIPTOR
          LDM    HBUF+CPRSTAT+PSCPOFF
          LPC    1001        SAVE ON/OFF, UP/DOWN BITS
          STM    AHEB
 AHE20    LDC    AHEA        FWA OF NEW MRT DEFINITION
          STDL   T5
          LDDL   W2          NUMBER
          SHN    14-0        POSITION THE NUMBER OF THE ELEMENT
          ADDL   W3          6/NUMBER, 12/TYPE
          RJM    WHE         WRITE HARDWARE ELEMENT
          PJN    AHE30       IF WRITE COMPLETE
          LJM    ERR         PROCESS ERROR

*         IF WRITING A CPU DESCRIPTOR, DETERMINE IF THE CPU STATUS HAS CHANGED
*         SUCH THAT THE MEMORY PORT NEEDS TO BE DISABLED.

 AHE30    LDM    AHEA+CPRHDR
          LPN    77
          LMN    PROCID
          NJP    AHE40       IF NOT CPU DESCRIPTOR
          READMR RDATA,CMCC,ECMR  READ MEMORY ENVIRONMENT CONTROL
          LDM    AHEB        CHECK IF CPU WAS ON
          NJN    AHE40       IF CPU WAS NOT ON

*         THE CPU WAS ON.  IF IT HAS BEEN CHANGED TO OFF OR DOWN IN THE NEW
*         DESCRIPTOR, THEN DISABLE THE MEMORY PORT.

          LDM    AHEA+CPRSTAT+PSCPOFF  CHECK THE NEW DESCRIPTOR
          LPC    1001
          ZJN    AHE40       IF NOT CHANGED TO OFF OR DOWN
          LDN    SSMR
          STD    RN
          LDM    HBUF+CPRPC
          RJM    RMR
          LPN    0#8
          ZJP    ERR         IF PROCESSOR NOT HALTED
          CALL   DIP         DISABLE MEMORY PORT

*         ISSUE *2AP* REQUEST TO WRITE THE MRT TO DISK.  FOR S0/S0E,
*         IT WILL BE WRITTEN TO THE CONSOLE DISK VIA PACKETS.

 AHE40    LDM    S0FLG       CHECK MAINFRAME TYPE
          ZJN    AHE50       IF NOT S0/S0E
          AOM    MRTU        INDICATE THAT MRT LOGGING IS REQUIRED
          LJM    AHEX        RETURN

 AHE50    LDN    33B         FUNCTION NUMBER
          STML   CALB
          STM    RTP1
          CALL   PFC         PREPARE FOR *2AP* CALL
          LDML   CALB+1
          ZJP    AHEX        IF NO ERROR, RETURN
          SBN    76+1
          PJP    AHEX        IF NO ERROR, RETURN
          LDC    0#4002      NO RETURN / SET STATUS / OFFSET TO ERROR STATUS WORD
          STML   RTP2
          CALL   PDE         PROCESS DISK ERROR ENCOUNTERED BY *2AP*

 AHEA     BSS    CMXLEN
 AHEB     BSS    1           CPU STATUS
 FPR      SPACE  4,10
**        FPR - FETCH PROCESSOR INFORMATION.
*
*         ENTRY  (VE REQUEST+2) = CPU NUMBER OR 10 FOR FIRST ACTIVE CPU.
*
*         CALLS  FHE, LRP, *ERR*.


          ROUTINE FPR

          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W4
          LDD    W5          GET CP PARAMETER
          LPN    7           ISOLATE CPU NUMBER
          STD    CP
 FPR10    SHN    14
          ADN    PROCID
          RJM    //FHE       FETCH HARDWARE INFORMATION
          MJP    ERR         IF NO MORE CPUS
          LDM    HBUF+CPRSTAT+PSCPOFF  CHECK CPU STATUS
          LPC    1001
          ZJP    FPRX        IF CPU IS ON
          LDD    W5
          LPN    10
          NJN    FPR20       IF LOOKING FOR FIRST ACTIVE CPU
          LJM    ERR         REPORT ERROR

 FPR20    AOD    CP
          UJN    FPR10       CHECK NEXT CPU
 GMR      SPACE  4,10
**        GMR - GET MAINTENANCE REGISTERS.
*
*         USES   RN, T2, W0 - W7.
*
*         CALLS  LRP, *ERR*.


          ROUTINE  GMR

          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0          READ FUNCTION PARAMETERS
          ADN    1
          CRDL   W4          READ POINTER PARAMETER
          LDDL   W7
          SBN    2
          MJP    ERR         IF RESULT BUFFER < 2 WORDS LONG
          LRD    W5
          RJM    SPB         SET PP BOUNDS
          LDDL   W2          MAINTENANCE REGISTER PORT
          LPC    0#F0F       EXTRACT MAINTENANCE CHANNEL PORT AND TYPE FIELDS
          STML   GMRA
          LDDL   W3          MAINTENANCE REGISTER NUMBER
          STDL   RN          SET REGISTER NUMBER
          READMR RDATA,GMRA
          NJP    ERR         IF READ IS INCOMPLETE
          LDN    2
          STD    T2
          LDDL   W4          OFFSET
          ADC    RR
          CWML   RDATA,T2    WRITE REGISTER BLOCK
          LJM    GMRX        RETURN

 GMRA     BSS    1           PORT
 MVP      SPACE  4,10
**        MVP - MANAGE VIRTUAL PROCESSOR.
*
*         THIS ROUTINE PERFORMS THE SPECIFIED ACTION ON THE SPECIFIED CPU.
*
*         USES   T7, W0 - W3.
*
*         CALLS  ERR, FHE, LRP, RMR, *DIP*, *ENP*.
*
*         MACROS FUNCMR, WRITMR.


          ROUTINE  MVP       ENTRY/EXIT

          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0          FETCH REQUEST PARAMETERS
          LDDL   W1          GET CPU NUMBER
          SHN    -8D
          STM    RTP2
          SHN    14
          ADN    PROCID
          RJM    //FHE       FETCH HARDWARE INFORMATION
          MJP    ERR         IF CPU NOT FOUND
          LDN    SSMR        SET SUMMARY STATUS REGISTER
          STD    RN
          LDML   HBUF+CPRPC  SET CONNECT CODE
          STDL   EC
          LDDL   W1          CHECK ACTION
          LPC    377
          ZJP    MVP60       IF START CPU REQUEST

*         PROCESS HALT CPU REQUEST.

          READMR RDATA,CMCC,ECMR  READ MEMORY ENVIRONMENT CONTROL
          RJM    CMP         CHECK MEMORY PORT
          NJP    ERR         IF MEMORY PORT DISABLED
          LDML   HBUF+CPRPC  SET CONNECT CODE
          STDL   EC
          LDN    SSMR
          STD    RN

          FUNCMR ,MRHP       HALT PROCESSOR
 MVP10    LDDL   EC          CHECK IF CPU HALTED
          RJM    RMR         READ SUMMARY STATUS
          LPN    0#8
          ZJN    MVP10       IF NOT HALTED
          LDM    RTP2
          STD    T7
          SHN    2
          RAD    T7
          ERRNZ  CPNR-5      CODE ASSUMES VALUE
          LDML   TCPU+CPUM,T7  CHECK IF 990 MAINFRAME
          SHN    -4
          LMN    4
          ZJN    MVP15       IF 990 MAINFRAME
          LDML   TCPU+CPUM,T7
          SHN    -4
          LMN    3
          NJN    MVP20       IF NOT 860, 960, OR 990

 MVP15    FUNCMR HBUF+CPRPC,MRMC  MASTER CLEAR PROCESSOR
 MVP20    LDML   HEOM        HALF EXCHANGE OUT MONITOR
          STM    MVPA+7
          SHN    -8D
          STM    MVPA+6
          LDM    CSAR
          STD    RN
          WRITMR MVPA,HBUF+CPRPC
          FUNCMR HBUF+CPRPC,MRSP  START PROCESSOR
          LDC    200D        WAIT 100 MICROSECONDS
 MVP30    SBN    1
          NJN    MVP30       IF DELAY NOT COMPLETE
 MVP40    LDN    SSMR        READ SUMMARY STATUS
          STD    RN
          LDD    EC
          RJM    RMR
          LPN    0#8
          ZJN    MVP40       IF PROCESSOR NOT HALTED
          LDM    RTP2
          STD    T7
          SHN    2
          RAD    T7
          ERRNZ  CPNR-5      CODE ASSUMES VALUE
          LDML   TCPU+CPUM,T7  CHECK IF THETA MAINFRAME
          SHN    -4
          LMN    4
          ZJN    MVP45       IF 990 MAINFRAME
          LDML   TCPU+CPUM,T7
          SHN    -4
          LMN    3
          NJN    MVP50       IF NOT 860, 960, OR 990
 MVP45    FUNCMR HBUF+CPRPC,MRMC  MASTERCLEAR PROCESSOR

 MVP50    CALL   DIP         DISABLE MEMORY PORT
          LJM    MVPX        RETURN

*         PROCESS START CPU REQUEST.

 MVP60    LDDL   EC          ENSURE THAT THE CPU IS CURRENTLY HALTED
          RJM    RMR         READ SUMMARY STATUS
          STD    T7
          LPN    0#8
          ZJP    MVP80       IF NOT CURRENTLY HALTED
          LDD    T7          CHECK IF CPU IN MONITOR MODE
          LPN    0#20
          ZJP    MVP80       IF CPU IN JOB MODE
          CALL   ENP         ENABLE MEMORY PORT
          LDML   HEIM        SET START ADDRESS FOR MONITOR MODE
          STM    MVPA+7
          SHN    -8D
          STM    MVPA+6
          LDML   CSAR
          STDL   RN
          WRITMR MVPA,HBUF+CPRPC  WRITE START ADDRESS
          FUNCMR HBUF+CPRPC,MRSP       START PROCESSOR
          LDC    200D        WAIT 100 MICROSECONDS
 MVP70    SBN    1
          NJN    MVP70       DELAY
          LJM    MVPX        RETURN

 MVP80    LJM    ERR

 MVPA     BSSZ   10          CONTROL STORE ADDRESS
 RDL      SPACE  4,15
**        RDL - REQUEST DATA LENGTH.
*
*         EXIT   TO *PDE* IF *2AP* ERROR ENCOUNTERED.
*
*         USES   W0 - W3.
*
*         CALLS  LRP, PFC.
*
*         NOTES  THE REQUESTED DATA MUST BE GREATER THAN THREE
*                CM WORDS IN LENGTH; OTHERWISE, AN ERROR WILL BE
*                INDICATED WHEN NONE OCCURRED.


          ROUTINE  RDL

          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0
          LDC    1020B       READ 16-BIT DATA SECTOR
          STM    CALB
          LPN    77
          STM    RTP1
          LDD    W1          UPPER 12 BITS OF NAME
          STM    CALB+1
          LDD    W2          LOWER 12 BITS OF NAME
          STM    CALB+2
          CALL   PFC         PREPARE FOR *2AP* CALL
          LDML   CALB+1      CHECK FOR ERROR
          ZJN    RDL0        IF NO ERROR ON CALL
          SBN    76+1
          PJN    RDL0        IF NO ERROR ON CALL
          LDC    0#4001      NO RETURN / SET STATUS / OFFSET TO ERROR STATUS WORD
          STML   RTP2
          CALL   PDE         PROCESS DISK ERROR ENCOUNTERED BY *2AP*

 RDL0     RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0
          LDDL   W1          CHECK IF REQUEST FOR *CEL* LENGTH
          CODE   D
          LMC    2RCE
          CODE   *
          NJN    RDL1        IF NOT *CEL*
          LDDL   W2
          CODE   D
          LMC    2RL
          CODE   *
          ZJN    RDL2        IF *CEL*, IGNORE VALID CHECK
 RDL1     LDM    CALB+1
          SHN    21-12
          MJN    RDL2        IF DATA IS VALID
          LDC    0#300       DFT INVALID CDA DATA READ
          LJM    ERR10       RETURN RESPONSE

 RDL2     LDML   CALB+1      RETURN PROGRAM LENGTH
          LPC    0#1FF
          ADN    3           ROUND UP TO NEAREST NUMBER OF CM WORDS
          SHN    -2
          STML   W3
          RJM    LRP         LOAD REQUEST POINTER
          CWDL   W0
          LJM    RPLX        RETURN
 RPL      SPACE  4,15
**        RPL - REQUEST PROGRAM LENGTH.
*
*         EXIT   TO *PDE* IF *2AP* ERROR ENCOUNTERED.
*
*         USES   W0 - W3.
*
*         CALLS  LRP, PFC.
*
*         NOTES  THE REQUESTED PROGRAM MUST BE GREATER THAN THREE
*                CM WORDS IN LENGTH; OTHERWISE, AN ERROR WILL BE
*                INDICATED WHEN NONE OCCURRED.


          ROUTINE  RPL

          RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0
          LDN    23B         FUNCTION NUMBER
          STM    CALB
          STM    RTP1
          LDD    W1          UPPER 12 BITS OF NAME
          STM    CALB+1
          LDD    W2          LOWER 12 BITS OF NAME
          STM    CALB+2
          CALL   PFC         PREPARE FOR *2AP* CALL
          LDML   CALB+1      CHECK FOR ERROR
          ZJN    RPL1        IF NO ERROR ON CALL
          SBN    76+1
          PJN    RPL1        IF NO ERROR ON CALL
          LDC    0#4001      NO RETURN / SET STATUS / OFFSET TO ERROR STATUS WORD
          STML   RTP2
          CALL   PDE         PROCESS DISK ERROR ENCOUNTERED BY *2AP*

 RPL1     RJM    LRP         LOAD REQUEST POINTER
          CRDL   W0
          LDML   CALB+1      RETURN PROGRAM LENGTH
          STML   W3
          RJM    LRP         LOAD REQUEST POINTER
          CWDL   W0
          LJM    RPLX        RETURN
 COMMON   SPACE  4,10
**        COMMON DECKS.


 WHE$     EQU    0           DEFINE *WHE* ROUTINE IN DSI$GET HARDWARE ELEMENT
 QUAL$    EQU    0           SELECT UNQUALIFIED COMMON DECKS
*copy     dsi$get_hardware_element

*         END    CTP$DFT REQUEST PROCESSOR 2
*DECK DECK=CTP$DFT_RESET_PIT EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_RESET_PIT.
*
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 RPT      SPACE  4,10
**        RPT - RESET PROCESS INTERVAL TIMER.
*
*         USES   T1 - T4, T7.
*
*         CALLS  RMR.
*
*         MACROS WRITMR.


 RPT      SUBR               ENTRY/EXIT
          LDN    EICBP       CHECK FOR PRESENCE OF DUAL CPU NOS
          CRDL   T1
          LDDL   T1
          SHN    21-12
          PJN    RPTX        IF NOT DUAL CPU NOS
          LDM    IOUN
          ZJN    RPT3        IF RUNNING IN IOU0
 RPT2     UJN    RPTX

*         INITIALIZE FOR PROCESSING ALL CPU-S.

 RPT3     LDN    ECMR        *READMR  RDATA,CMCC,ECMR*
          STDL   RN
          LDM    CMCC
          RJM    RMR         READ MAINTENANCE REGISTER
          LDM    RDATA,PO    SAVE PORT INFORMATION
          STM    RPTB
          LDN    2           NUMBER OF CPU-S TO PROCESS
          STM    RPTD
          LDC    PPIT        *PIT* REGISTER NUMBER
          STDL   RN

*         CHECK IF NEXT CPU IS TO BE PROCESSED.

 RPT4     SOML   RPTD
 RPT4A    MJN    RPT2        IF ALL CPU-S HAVE BEEN CHECKED
          STM    CPUO        SAVE CPU ORDINAL BEING EXAMINED
          STD    T7
          SHN    2
          RAD    T7
          ERRNZ  CPNR-5      CODE ASSUMES VALUE
          LDML   TCPU+CPUM,T7
          ZJN    RPT4        IF CPU NOT PRESENT
          LDC    SHNI+4+3
          SBM    TCPU+CPUP,T7
          STM    RPTA
          LDN    1
 RPTA     SHN    **
          STM    RPTC
          LDC    **
 RPTB     EQU    *-1
          LPC    **
 RPTC     EQU    *-1
          NJN    RPT4        IF PORT DISABLED

*         RESET *PIT*.
*         THE *PIT* WILL BE SET TO ALL ONES.

          LDC    0#FF
          STM    RDATA+4
          STM    RDATA+5
          STM    RDATA+6
          STM    RDATA+7
          LDM    TCPU+CPUC,T7
          STD    EC
          WRITMR RDATA
          LDN    D7CM        CHECK IF DUAL STATE IS CAPABLE
          RJM    IIB
          CRDL   T1          IN CPU-0.  IF SO, DO NOT RESET
          LDDL   T1+2        PIT IN CPU-0
          LPC    0#FF        ISOLATE 23-16 OF NVE CM LENGTH
          NJP    RPTX        NON-ZERO MEANS VE CAPABLE
          LDDL   T1+3        TEST THE REST OF NVE CM LENGTH
          NJP    RPTX        VE CAPABLE, NOS IS USING PIT
          LJM    RPT4        CONTINUE WITH NEXT PROCESSOR

 RPTD     BSS    1           NUMBER OF CPU-S TO PROCESS

*         ENDX   CTP$DFT_RESET_PIT.

*DECK DECK=CTP$DFT_RESIDENT_COMMON EXPAND=FALSE
          TITLE  SUBROUTINES.
*         CTEXT  CTP$DFT RESIDENT COMMON.
*
*         THIS COMMON DECK DEFINES RESIDENT ROUTINES COMMON TO ALL
*         VARIANTS OF DFT.
 COL      SPACE  4,10
**        COL - CHECK IF OVERLAY LOAD REQUIRED.
*
*         AN OVERLAY LOAD IS UNNECESSARY IF ANY OF THE FOLLOWING IS TRUE:
*         (1) OVERLAY NUMBER IS 0 (DFT RESIDENT IS ALWAYS LOADED).
*         (2) OVERLAY NUMBER IS 1 (DFT RESIDENT II IS ALWAYS LOADED).
*         (3) OVERLAY NUMBER MATCHES LAST OVERLAY LOADED (CUOV).
*
*         ENTRY  (A) = OVERLAY NUMBER REQUIRED.
*
*         EXIT   SPECIFIED OVERLAY LOADED IF NECESSARY.
*                (CUOV) UPDATED IF OVERLAY WAS ACTUALLY LOADED.
*
*         USES   T0.
*
*         CALLS  LOV.


 COL      SUBR               ENTRY/EXIT
          STD    T0
          SBN    2
          MJN    COLX        IF RESIDENT OR RESIDENT II REQUIRED
          LDD    T0          COMPARE WITH LAST OVERLAY LOADED
          LMM    CUOV
          ZJN    COLX        IF SAME AS LAST OVERLAY LOADED
          LDD    T0          SET OVERLAY TO LOAD
          STM    CUOV        RECORD AS LAST OVERLAY LOADED
          RJM    LOV         LOAD OVERLAY
          UJN    COLX        RETURN
 EXT      SPACE  4,10
**        EXT - EXECUTE TASK.
*
*         ENTRY  (DFTA) = ADDRESS OF TASK TO EXECUTE.
*
*         USES   T1.


 EXT      SUBR               ENTRY/EXIT
          LDM    DFTA
          ZJN    EXTX        NULL LIST
          STD    T1
          LJM    0,T1        JUMP TO NAMED TASK

 EXTR     UJN    EXTX        RETURN
 FMR      SPACE  4,10
**        FMR - FATAL MAINTENANCE REGISTER ERROR HANDLER.
*
*         ENTRY  (A) = DFT ANALYSIS CODE.
*
*         EXIT   MESSAGE WRITTEN TO *EICB* MESSAGE BUFFER.
*                *ERRH* DOES NOT EXIT.
*
*         CALLS  *ERRH*.


 FMR      ADC    TDFT        TERMINATE DFT FLAG
          STML   RTP1
          LMC    0#2000      MAKE UNCORRECTED ERROR PRIORITY
          STDL   BC+1        STORE IN DFT ANALYSIS PART OF SCRATCH ANALYSIS WORD
          CALL   ERRH        ISSUE MESSAGE AND HANG
 FTE      SPACE  4,10
**        FTE - FUNCTION TIME OUT ERROR PROCESSOR.
*
*         ENTRY  (A) = DFT ANAYSIS CODE.


 FTE      EQU    FMR         SAME PROCESSING AS FOR *FMR*
 IDA      SPACE  4,10
**        IDA - INCREMENT DFT ADDRESS.
*
*         ENTRY  (A) = INCREMENT.
*                (DP - DP+2) = R-POINTER DATA.
*
*         EXIT   R-REGISTER LOADED.
*                (A) = (A) + (DP) + 400000.


 IDA      SUBR               ENTRY/EXIT
          LRD    DP+1
          ADDL   DP
          ADC    RR
          UJN    IDAX        RETURN
 IDD      SPACE  4,10
**        IDD -  IDLE DOWN.
*
*         ENTRY  (A) = SOFTWARE ANALYSIS CODE.


 IDD      SUBR               ENTRY
          STML   IDDA        SAVE ANALYSIS CODE
          UJN    *           HANG

 IDDA     CON    0           SOFTWARE ANALYSIS CODE
 IMB      SPACE  4,10
**        IMB - INCREMENT MAINTENANCE BUFFER.
*
*         ENTRY  (A) = INCREMENT.
*                (MP - MP+2) = R-POINTER DATA.
*
*         EXIT   R-REGISTER LOADED.
*                (A) = (A) + (MP) + 400000.


 IMB      SUBR               ENTRY/EXIT
          LRD    MP+1
          ADDL   MP
          ADC    RR
          UJN    IMBX        RETURN
 LNO      SPACE  4,10
**        LNO - LOAD NEXT OVERLAY AND EXECUTE SPECIFIED ROUTINE.
*
*         ENTRY  (A) = 6/ OVL, 12/ ADDRESS.
*                OVL = OVERLAY NUMBER TO LOAD IF NOT ALREADY LOADED.
*                ADDRESS = EXECUTION ADDRESS (ENTERED VIA *LJM*).
*                AT *LNOF* TO RETURN FROM OVERLAY, RELOAD PRIOR OVERLAY,
*                AND RESUME EXECUTION AT LINE FOLLOWING *CALL* MACRO.
*
*         EXIT   OVERLAY LOADED AND *LJM* TO ROUTINE ADDRESS.
*                STACK POPPED AND PRIOR OVERLAY RELOADED IF ENTRY AT *LNOF*.
*                TO *IDD*, IF LOAD ERROR.
*
*         USES   ST, T1, *STKD*.
*
*         CALLS  COL, IDD.


 LNOF     SOD    ST          POP STACK
          SOM    STKD
          PJN    LNO3        IF STACK SIZE IS OK
 LNO2     LDC    DASC        60A - DFT FATAL STACK
          RJM    IDD         IDLE DOWN

 LNO3     LDI    ST          SET OVERLAY NUMBER
          RJM    COL         CHECK IF OVERLAY LOAD REQUIRED
          SOD    ST
          LDIL   ST          GET RETURN ADDRESS
          STDL   T1
          LJM    0,T1        RETURN TO CALLER

 LNO      SUBR               ENTRY/EXIT
          STM    LNOA
          SHN    -14
          STD    T1          OVERLAY NUMBER
          AOM    STKD        CURRENT STACK DEPTH
          SBN    STKL
          PJN    LNO2        IF CALL LIMIT HAS BEEN EXCEEDED
          LDML   LNO         SAVE RETURN ADDRESS ON STACK
          STIL   ST
          AOD    ST
          LDM    CUOV        SAVE OLD OVERLAY NUMBER ON STACK
          STI    ST
          AOD    ST
          LDD    T1          SET OVERLAY NUMBER
          RJM    COL         CHECK IF OVERLAY REQUIRED

*         TO BREAKPOINT ON OVERLAY LOADS, SET THE OVERLAY NUMBER IN
*         THE *LMN* INSTRUCTION, THEN SET A BREAKPOINT FOR THE FIRST
*         *PSN* INSTRUCTION.  WHEN THE BREAKPOINT IS ENCOUNTERED, THE
*         DESIRED OVERLAY HAS BEEN LOADED, SO IT IS POSSIBLE TO LOOK
*         AT AND/OR CHANGE MEMORY, SET BREAKPOINTS, ETC.
*
*         LDD    T1          CHECK FOR REQUESTED OVERLAY
*         LMN    **          *** PLUG DESIRED OVERLAY NUMBER HERE ***
*         NJN    LNO1        IF NOT DESIRED OVERLAY
*         PSN                *** SET BREAKPOINT HERE ***
*         PSN                *** SET BREAKPOINT FOR PREVIOUS WORD ***
*LNO1     BSS    0
          LJM    **          EXECUTE ROUTINE
 LNOA     EQU    *-1
 LOV      SPACE  4,10
**        LOV - LOAD OVERLAY.
*
*         ENTRY  (A) =  OVERLAY NUMBER.
*                (DH - DH+2) = R-POINTER DATA.
*                (DO) = DIRECTORY OFFSET.
*
*         EXIT   OVERLAY LOADED AT ADDRESS SPECIFIED IN HEADER.
*                (OVLS) INCREMENTED.
*
*         USES   CM - CM+3.


 LOV      SUBR               ENTRY/EXIT
          ZJN    LOVX        IF LOAD RESIDENT OVERLAY
          LRD    DH+1
          ADD    DH          OFFSET TO DFT
          ADD    DO          DIRECTORY OFFSET
          ADC    RR
          CRDL   CM          READ IN DIRECTORY ENTRY
          LDDL   CM          STARTING LOAD ADDRESS
          STML   LOVA
          LDDL   CM+3        OFFSET INTO CIP MODULE
          ADD    DH
          ADC    RR+2        FOR DFT HEADER
          CRML   **,CM+1     CM+1 = LENGTH IN DIRECTORY
 LOVA     EQU    *-1
          AOML   OVLS        INCREMENT OVERLAY COUNTER
          UJN    LOVX        RETURN
 LSR      SPACE  4,10
**        LSR - LOAD SECONDARY ROUTINES.
*
*         LOAD AND PRESET THE OVERLAY OF SECONDARY ROUTINES.
*
*         CALLS  LOV, PII.


 LSR      SUBR               ENTRY/EXIT
          LDN    1
          RJM    LOV         LOAD OVERLAY
          RJM    PII         PRESET IOU INFORMATION
          UJN    LSRX        RETURN
 VCK      SPACE  4,10
**        VCK - VERSION CHECK.
*
*         ENTRY (A) = VERSION NECESSARY FOR CODE TO EXECUTE.
*
*         EXIT  (A) < 0 IF NOT CORRECT VERSION.
*


 VCK      SUBR               ENTRY/EXIT
          STM    VCKA        SAVE VERSION
          LDM    VRSN
          SBM    VCKA
          UJN    VCKX        RETURN WITH (A) = RESULT

 VCKA     CON    0
          SPACE  4,10
**        NOTE - PUT NOTHING IN PRESET BEFORE THIS POINT.

          USE    PRESET
          ERRNG  TOIP-*      RESIDENT OF DFT IS TOO LARGE
 OVLA     EQU    TOAP        PRESERVE *2AP* BUFFER AREA
          USE    *

*         END OF CTP$DFT_RESIDENT_COMMON

*DECK DECK=CTP$DFT_RESIDENT_ECM_NON_S0 EXPAND=FALSE
*         CTEXT  CTP$DFT_RESIDENT_ECM_NON_S0
*
*         THIS DECK DEFINES THE EXECUTE CIP MODULE FOR NON S0 MACHINES
 ECM      SPACE  4,15
**        ECM - EXECUTE CIP MODULE.
*
*         EXIT   RETURNS TO LOCATION *RCMRTN*.
*
*         USES   EI, T1, CM - CM+3, W0 - W3, *CALB*, *RDATA*.
*
*         CALLS  IIB, LOV, LSR, SPB, *TOEP*.
*
*         MACROS FINDCM, READMR, WRITMR.
*
*         NOTE   *2AP* REQUIRES THE OS BOUNDS REGISTER AND THE MEMORY
*         BOUNDS REGISTER TO BE SET UP PRIOR TO *2AP* UPDATING ITSELF
*         IN MEMORY.  MEMORY BOUNDS WILL BE DISABLED AND DFT IN OS BOUNDS
*         IS SET TO UPPER PP.



 ECM      SUBR               ENTRY/EXIT
          RJM    TIM         UPDATE TIMING OF EVENTS
          FINDCM 2AP         FIND CIP MODULE
          CRDL   W0
          STDL   T1
          SODL   W3          DELETE HEADER WORD
          LDDL   T1
          ADC    RR+1
          CRML   TOAP,W3     LOAD *2AP*
          LDM    UMEM        UPDATE *2AP* IN MEMORY FLAG
          ZJN    ECM1        IF NO UPDATE

*         SET OS BOUNDS AND DISABLE MEMORY BOUNDS, IF NECESSARY, BEFORE
*         CALLING *2AP* SINCE IT WILL OVERLAY THE SECONDARY ROUTINES OVERLAY.

          LDN    DSCM+2
          RJM    IIB
          CRDL   CM          GET CIP POINTER
          LRD    CM+1
          RJM    SPB         SET PP BOUNDS
          RJM    DBC         DISABLE MEMORY BOUNDS CHECKING
 ECM1     LDC    CALB        LOAD CALL BLOCK ADDRESS
          RJM    TOEP        CALL *2AP* TO PROCESS FUNCTION
          LDN    0
          STD    EI

*         CALL *2AP* TO UPDATE CIP IMAGE IF NECESSARY.

          LDM    UMEM        UPDATE *2AP* IN MEMORY FLAG
          ZJN    ECM3        IF NO UPDATE
          LDN    27          FUNCTION TO UPDATE *2AP* IN CENTRAL MEMORY
          STM    CALB
          LDC    CALB
          RJM    TOEP        RE-CALL *2AP* TO PROCESS FUNCTION
          LDN    0
          STD    EI

*         RELOAD SECONDARY ROUTINES OVERLAY.

 ECM3     RJM    LSR         RELOAD SECONDARY ROUTINES

*         REENABLE MEMORY BOUNDS CHECKING IF DISABLED FOR *2AP* CALL.

 ECM4     LDM    UMEM        CHECK NEED TO REENABLE MEMORY BOUNDS
          ZJN    ECM5        IF MEMORY BOUNDS WERE NOT DISABLED
          RJM    EBC         ENABLE BOUNDS CHECKING

*         RELOAD CURRENT OVERLAY.

 ECM5     LDM    CUOV        GET CURRENT OVERLAY
          RJM    LOV         RELOAD CURRENT OVERLAY
          RJM    TIM         UPDATE TIMING OF EVENTS
          LJM    ECMX        RETURN

*DECK DECK=CTP$DFT_RESIDENT_II_COMMON EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT RESIDENT II COMMON.
*
*         THIS DECK DEFINES ROUTINES IN RESIDENT II WHICH ARE COMMON
*         TO ALL VARIANTS OF DFT.

          QUAL   *

 BRL      SPACE  4,10
**        BRL - BUILD REGISTER LIST.
*
*         ENTRY  (A) IS REGISTER LIST TO ADD.
*                (ET) IS THE ASSOCIATED ELEMENT TYPE
*
*         EXIT   *REGL*, *REGI* UPDATED. IF LIST OVERFLOW EXIT
*                TO ERRH.
*
*         USES   T1.
*
*         NOTE:  REGISTER LIST ENTRIES ARE A TUPLE CONSISTING OF THE ELEMENT TYPE AND
*                ASSOCIATED REGISTER LIST, THUS IT IS POSSIBLE TO BUILD A REGISTER LIST
*                FOR MANY DIFFERENT ELEMENTS DEPENDING ON THE ERROR ANALYZED.


 BRL      SUBR               ENTRY/EXIT
          STM    BRLA        SAVE LIST ADDRESS
          LDM    REGI
          ADN    2
          SBN    MAXRL       MAX LIST LENGTH
          PJN    BRL1
          LDM    REGI        UPDATE LIST INDEX
          STD    T1
          LDD    ET          GET ELEMENT TYPE
          STM    REGL,T1     SAVE ET PART OF TUPLE
          AOD    T1          SAVE LIST ADDRESS PORTION OF TUPLE
          LDC    **          RETRIEVE LIST ADDRESS
 BRLA     EQU    *-1
          STM    REGL,T1
          LDN    2
          RAM    REGI        BUMP LIST INDEX
          UJN    BRLX        RETURN

*         DFT ANALYSIS - LIST SIZE BIGGER THAN ALLOCATED SIZE.

 BRL1     SETDAN (EPUN,DASE)
          LDC    TDFT+DASE   60B - DFT BRL SIZE ERROR
          STML   RTP1
          CALL   ERRH        ISSUE MESSAGE AND HANG
 CKF      SPACE  4,10
**        CKF - CHECK OS FLAGS FOR APPLICABILITY.
*
*         ENTRY  FLAGS SET IN SCRATCH BUFFER CONTROL WORD FROM *SETFLG*
*                MACRO.
*
*         EXIT   ONLY THOSE FLAGS WHICH MAKE SENSE IN THE GIVEN DFT
*                ENVIRONMENT WILL REMAIN SET.  VALID 170 FLAG WILL BE
*                SET IN 170 STANDALONE.  IT WILL ALSO BE SET IN
*                DUAL STATE IF THE ERROR IS NOT FROM IOU1.  VALID 180
*                FLAG WILL BE SET IN DUAL STATE OR 180 STANDALONE.
*
*         CALLS  IDA, IIB.


 CKF      SUBR               ENTRY/EXIT
          LDN    HDRP
          RJM    IDA
          CRML   CKFA,ON     GET DFT HEADER
          LDM    CKFA+DHFLG  GET FLAGS PORTION
          SHN    21-DH.FL
          PJN    CKF1        IF NOS/VE OR DUAL STATE
          LDDL   BC+BCFLG    GET FLAGS IN SCRATCH BUFFER CONTROL WORD
          SCN    2           WE ARE ONLY IN 170 STANDALONE
          STDL   BC+BCFLG
          UJN    CKFX        RETURN

 CKF1     LDN    D7TY        170 DEADSTART TYPE
          RJM    IIB
          CRML   CKFA,ON     GET 170 DEADSTART TYPE FROM EICB
          LDML   CKFA+3
          SHN    -14         GET 4 LEAST SIGNIFICANT BITS OF TYPE
          ZJN    CKF2        IF WE ARE IN 180 STANDALONE
          LDD    ET
          LMN    IOUID
          NJN    CKFX        IF NOT IOU ELEMENT
          LDM    IOUO
          ZJN    CKFX        IF IOU0
 CKF2     LDDL   BC+BCFLG
          SCN    1           CLEAR 170 VALID DATA FLAG
          STDL   BC+BCFLG
          UJP    CKFX        RETURN

 CKFA     BSSZ   4           BUFFER FOR 1 CM WORD
 CLR      SPACE  4,10
**        CLR - CLEAR BUFFER AREA.
*
*         ENTRY  (A) = FWA OF DIRECT CELLS TO CLEAR.
*
*         EXIT   ((A) - (A)+3) = 0.
*
*         USES   T1.


 CLR      SUBR               ENTRY/EXIT
          STD    T1
          LDN    0
          STI    T1
          STM    1,T1
          STM    2,T1
          STM    3,T1
          UJN    CLRX        RETURN
 FMB      SPACE  4,10
**        FMB - FIND MAINTENANCE REGISTER IN SCRATCH BUFFER.
*
*         ENTRY  (A) = MAINTENANCE REGISTER TO FIND.
*
*         EXIT   (A) AND (R) SET FOR ACCESS.
*
*         CALLS  IMB.
*
*         NOTE   THIS ROUTINES USES NO DIRECT CELLS, AS IT IS CALLED
*                FROM A WIDE VARIETY OF ENVIRONMENTS.


 FMB      SUBR               ENTRY/EXIT
          STML   FMBB        SAVE REGISTER TO BE FOUND
          LDN    0           INITIALIZE FOR FIRST REGISTER GROUP
          STML   FMBC

*         READ NEXT HEADER WORD.

 FMB1     RJM    IMB         READ HEADER WORD
          CRML   FMBD,ON
          LDC    FMBD        INITIALIZE SEARCH LOOP
          STML   FMBA

*         CHECK IF REGISTER IS IN THIS REGISTER GROUP.

 FMB2     LDML   **          CHECK NEXT REGISTER DESCRIPTOR
 FMBA     EQU    *-1         (HEADER BYTE TO CHECK)
          LPC    0#FFF       FOR NOW EXCLUDE THE TYPE CODE FROM EXAMINATION
          LMML   FMBB
          ZJN    FMB3        IF REGISTER FOUND
          AOML   FMBA
          LMC    FMBD+4
          NJN    FMB2        IF MORE BYTES IN CURRENT HEADER WORD
          LDN    5           ADVANCE TO NEXT HEADER WORD
          RAML   FMBC
          SBML   LBUF        SUBTRACT LENGTH OF BUFFER FROM PRESENT LOCATION
          ZJN    FMB4        IF AT END OF BUFFER
          LDML   FMBC
          UJN    FMB1        LOOP

*         SET RETURN PARAMETERS FOR REGISTER ADDRESS IN GROUP.

 FMB3     LDML   FMBC        SET OFFSET FOR REGISTER GROUP
          ADN    1
          ADML   FMBA        INCLUDE WORD OFFSET IN FOUR REGISTER GROUP
          ADC    -FMBD
          RJM    IMB         SET (A) AND (R) FOR ACCESS
          LJM    FMBX        RETURN

*         REGISTER NOT FOUND DURING SEARCH.

*         DFT ANALYSIS - REGISTER NOT FOUND DURING SEARCH.

 FMB4     SETDAN (EPUN,DARE)
          LDC    DARE+TDFT   607 - DFT REG NOT IN MRB
          STML   RTP1
          CALL   ERRH


 FMBB     BSS    1           REGISTER TO LOCATE
 FMBC     BSS    1           HEADER ADDRESS IN BUFFER
 FMBD     BSS    4           HEADER WORD BUFFER
 GCM      SPACE  4,10
**        GCM - GET CM RESIDENT WORD.
*
*         ENTRY  (A) = OFFSET TO DESIRED CM WORD.
*
*         EXIT   (CM - CM+3) = REQUESTED CM WORD.
*
*         USES   CM - CM+3.
*
*         CALLS  IDA.


 GCM      SUBR               ENTRY/EXIT
          STDL   T0
          LDK    DCMP        GET POINTER TO CM AREA
          RJM    IDA
          CRDL   CM
          LRD    CM+1        READ DESIRED WORD
          LDDL   CM
          ADDL   T0
          ADC    RR
          CRDL   CM
          UJN    GCMX        RETURN
 ICC      SPACE  4,10
**        ICC - INCREMENT CM BASED COUNTER.
*
*         ENTRY  (A) = 4/OFFSET TO CM WORD, 12/BYTE DESIGNATOR.
*
*         USES   T1, T2.
*
*         CALLS  GCM, PCM, VCK.


 ICC      SUBR               ENTRY/EXIT
          STD    T2          SAVE BYTE DISGNATOR
          SHN    -14
          STD    T1          SAVE OFFSET TO CM WORD
          LDN    VER4
          RJM    VCK         CHECK VERSION
          MJN    ICCX        IF NOT VERSION 4
          LDD    T1
          RJM    GCM         GET CM RESIDENT WORD
          AOIL   T2          INCREMENT COUNTER
          LDD    T1
          RJM    PCM         PUT CM RESIDENT WORD
          UJN    ICCX        RETURN
 IHS      SPACE  4,10
**        IHS - INITIATE CPU/PP HANDSHAKE.
*
*         EXIT   (DFTE) = *LDN 1*.


 IHS      SUBR               ENTRY/EXIT
          LDC    LDNI+1
          STM    DFTE
          UJN    IHSX        RETURN
 DPD      SPACE  4,10
**        DPD - DUMP PP REGISTER DATA.
*
*


 DPD      SUBR               ENTRY/EXIT
          LDC    LDNI+1
          STM    DFTF
          UJN    DPDX        RETURN
 LRP      SPACE  4,10
**        LRP - LOAD REQUEST POINTER.
*
*         ENTRY  (JT - JT+2) = R-POINTER VALUE.
*
*         EXIT   R-REGISTER LOADED.
*                (A) = (JT) + 400000.


 LRP      SUBR               ENTRY/EXIT
          LRD    JT+1
          LDDL   JT
          ADC    RR
          UJN    LRPX        RETURN
 PCM      SPACE  4,10
**        PCM - PUT CM RESIDENT WORD.
*
*         ENTRY  (A) = OFFSET TO DESIRED CM WORD.
*                (CM - CM+3) = CONTENTS OF WORD TO WRITE.
*
*         USES   T4 - T7.
*
*         CALLS  IDA, SPB.


 PCM      SUBR               ENTRY/EXIT
          STML   PCMB
          LDK    DCMP        GET POINTER TO CM AREA
          RJM    IDA
          CRDL   T4
          LRD    T5          SET R-REGISTER FOR *SPB* CALL
          LDD    T4          SAVE OFFSET
          STM    PCMA
          RJM    SPB         SET PP BOUNDS
          LDC    **          OFFSET
 PCMA     EQU    *-1
          ADC    **          OFFSET TO CM WORD
 PCMB     EQU    *-1
          ADC    RR
          CWDL   CM
          UJN    PCMX        RETURN
 SEC      SPACE  4,10
**        SEC - PROCESS ONCE-PER-SECOND ITEMS.
*
*         ENTRY  ONCE PER SECOND FROM *TIM*.
*
*         EXIT   (UETV) = 1.
*                (TSIT) = 1.
*                (DRCR) = 1.
*                (CPSA) = 1.
*                (PKTIM) UPDATED IF LOADING *DFT-S*.
*
*         USES   *STIM*, *TIMU*.
*
*         CALLS  ICC.


 SEC      SUBR               ENTRY/EXIT

*         SET FLAGS FOR VARIOUS PROCESSES.

          LDN    1           SET DFT/SCI RELOCATION CHECK REQUIRED
          STM    DRCR
          AOM    CPSA        SET CHECK-IN PACKET FLAG
          AOM    TSIT        SET FLAG TO CHECK *SIT*
          LDM    IOUN
          NJN    SEC1        IF NOT IOU0
          LDN    1           SET FLAG TO CALL UWE (FLAG CLEARED IN UWE)
          STM    UETV
 SEC1     LDM    STIM        CHECK FOR TIMEOUT VALUE
          ZJN    SEC2        IF NO TIMEOUT VALUE
          SOM    STIM        DECREMENT TIMER FOR THIS MODE
          NJN    SEC2        IF NOT YET TIMED OUT
          LDN    1
          STM    TIMU        SET TIME DELAY HAS EXPIRED

 SEC2     LDML   PKTIM
          ZJN    SECX        IF NOT TIMING PACKET RESPONSES
          AOML   PKTIM       INCREMENT WAITING TIME
          LPC    7777
          SBN    5
          MJN    SEC3        IF WAITING TIME NOT ELAPSED
          SBN    5
          PJN    SEC2.5      IF TIME ELAPSED REGARDLESS OF MAINFRAME TYPE
          LDM    S0FLG
          NJN    SEC3        IF TIME NOT ELAPSED FOR 93X CLASS
 SEC2.5   LDML   PKTIM       SET TIME OUT FLAG
          SHN    -14
          ADC    TPKT-1
          STD    T1
          LDC    PKWTO
          RAIL   T1
          LDN    0           RESET PACKET TIMING WORD
          STML   PKTIM
          LDC    CMTO*10000+CM+2
          RJM    ICC         INCREMENT CM BASED COUNTER
 SEC3     UJP    SECX        RETURN
 SET      SPACE  4,10
**        SET - SET BUFFER TO ONES.
*
*         ENTRY  (A) = ADDRESS OF BUFFER.
*
*         EXIT   ((A) - (A)+3) = 0#FFFF.
*
*         USES T1.


 SET      SUBR               ENTRY/EXIT
          STD    T1
          LDC    0#FFFF
          STIL   T1
          STML   1,T1
          STML   2,T1
          STML   3,T1
          UJN    SETX        RETURN
 SRS      SPACE  4,10
**        SRS - SET REQUEST STATUS.
*
*         ENTRY  (JOBF) = OS REQUEST STATUS.
*
*         EXIT   REQUEST UPDATED WITH STATUS.
*                (R170) = 0.
*
*         USES   CM - CM+3, W0 - W0+7, *R170*.
*
*         CALLS  IDA, LRP, SPB.


 SRS      SUBR               ENTRY/EXIT
          LDM    IOUN
          ZJN    SRS1        IF DFT IS RUNNING IN IOU0
          LDN    NVEP        CLEAR THE LENGTH FIELD OF NOS/VE POINTER
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W0
          LDN    0
          STML   W3
          RJM    SPB         SET PP BOUNDS
          LDN    NVEP
          RJM    IDA         INCREMENT DFT ADDRESS
          CWDL   W0
 SRS1     RJM    LRP
          CRDL   CM
          RJM    SPB         SET PP BOUND
          LDD    CM
          LPN    77
          ADM    JOBF        JOB STATUS FLAG
          STD    CM
          RJM    LRP
          CWDL   CM
          LDM    R170        REQUEST WAS 170 ORIGIN
          ZJP    SRSX        IF NOT
          LDN    OSRP
          RJM    IDA
          CRDL   W0          FETCH POINTER TO OS REQUESTS
          LRD    W1          POINTER TO REQUEST
          LDD    W0
          ADC    RR
          CRDL   W4          READ IN REQUEST POINTER
          LDN    0
          STD    W7          CLEAR ACTIVE REQUEST
          LDD    W0
          ADC    RR
          CWDL   W4          UPDATE STATUS FIELD IN REQUEST POINTER
          LDN    0
          STM    R170        CLEAR 170 REQUEST FLAG
          LJM    SRSX        RETURN
 SSE      SPACE  4,10
**        SSE - SET SECONDARY ELEMENT IDENTIFIER.
*
*         ENTRY  (A) = ELEMENT ORDINAL.
*
*         USES   W0 - W3.
*
*         CALLS  FMB, SPB.


 SSE      SUBR               ENTRY/EXIT
          ZJN    SSEX        IF ELEMENT ZERO
          LDN    EIMR
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CRDL   W0          GET *EID* REGISTER
          LDD    W2
          LMC    0#1000      SECONDARY ELEMENT IDENTIFIER
          STDL   W2
          LRD    DP+1
          RJM    SPB         SET PP BOUNDS
          LDN    EIMR
          RJM    FMB         FIND MAINTENANCE REGISTER IN SCRATCH BUFFER
          CWDL   W0          REWRITE *EID* REGISTER
          UJP    SSEX        RETURN
 IBW      SPACE  4,10
**        IBW - INCREMENT BUFFER CONTROL WORDS POINTER
*
*         ENTRY  (RTP1) = 1 = USE NON REGISTER STATUS BUFFER.
*                       = 0 = USE BUFFER CONTROL WORDS.
*                    (A)= INDEX DESIRED.
*
*         EXIT   R REGISTER AND A OFFSET SETUP TO READ A
*                PARTICULAR BUFFER CONTROL WORD
*
*         CALLS  IDA, VCK.
*
*         USES   W0 - W3.


 IBW      SUBR               ENTRY/EXIT
          STML   IBWA        SAVE CONTROL WORD INDEX
          LDN    0
          STM    IBWB
          LDN    VER4
          RJM    VCK         CHECK VERSION
          MJN    IBW1        IF LESS THAN VERSION 4
          LDM    RTP1
          NJP    IBW3        IF TO USE NON REGISTER STATUS BUFFER
          LDML   IBWA
          ADD    BW
          LRD    BW+1
          ADC    RR
          UJN    IBWX        RETURN

 IBW1     LDML   IBWA
          ADM    NUMHW
          RJM    IDA
          UJN    IBWX        RETURN

 IBW3     SOML   IBWA
          MJN    IBW4        IF REQUESTED INDEX FOUND
          LDML   SNRB        SIZE OF NON REGISTER BUFFER ENTRY
          RAML   IBWB
          UJN    IBW3        CONTINUE

 IBW4     LDN    NRSP        GET ADDRESS OF NON REGISTER BUFFER
          RJM    IDA         INCREMENT DFT POINTER ADDRESS
          CRDL   W0
          LDD    W0          ADD IN A OFFSET
          ADML   IBWB        ADD IN OFFSET TO CURRENT CONTROL WORD
          LRD    W1
          ADC    RR+1
          UJP    IBWX        RETURN

 IBWA     CON    0           STORAGE FOR BUFFER CONTROL WORD INDEX
 IBWB     CON    0           OFFSET TO REQUESTED CONTROL WORD IN NRSB
          EJECT

 STEP$    IF     DEF,STEP$   ASSEMBLE *STEP* CONDITIONALLY
 STEP     SPACE  4,10
**        STEP - STOP AT VARIOUS ADDRESSES TO ALLOW FOR PROGRAM DEBUGGING.
*
*
*                WRITING THE ADDRESS OF THE INSTRUCTION IMMEDIATELY FOLLOWING
*                THE RJM TO STEP TO CM ADDRESS 2 WILL CAUSE THE PROGRAM TO GO
*                INTO STEP MODE.  IT WILL REMAIN HERE UNTIL THE ADDRESS IS
*                CHANGED TO THE NEXT DESIRED STEP.  CLEARING CM ADDRESS 2 WILL
*                DISABLE STEP UNTIL REQUIRED AGAIN.
*
*                CENTRAL MEMORY LOCATION 1 IS USED.
*
*                TO USE STEP, INSERT *RJM STEP* WHEREVER A BREAKPOINT IS DESIRED.


 STEP     SUBR               ENTRY/EXIT
          STML   STEPB
          SHN    -16D
          STML   STEPC
 STEP1    LDN    2
          CRML   STEPA,ON
          LDML   STEPA+3
          LMML   STEP
          ZJP    STEP1
          LDML   STEPC
          SHN    16D
          LMML   STEPB
          UJN    STEPX

 STEPA    CON    0,0,0,0
 STEPB    CON    0
 STEPC    CON    0

 STEP$    ENDIF

*         END    CTP$DFT RESIDENT II COMMON
*DECK DECK=CTP$DFT_RESIDENT_II_NON_990 EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_RESIDENT_II_NON_990
*
*         THIS DECK DEFINES A STUB FOR USE ON NON 990
*         MAINFRAMES
 HTO      SPACE  4,10
**        HTO - HARDWARE TIME OUT.
*
*         NOTE THIS IS A STUB


 HTO      SUBR               ENTRY/EXIT
          LDN    1
          STML   TFLG
          LJM    HTOX

*         END    CTP$DFT_RESIDENT_II_NON_990
*DECK DECK=CTP$DFT_RESTART_SCI EXPAND=FALSE
 RSP      SPACE  4,10
**        RSP - RESTART SCI PP.
*

          ROUTINE RSP
          RJM    LRP
          CRDL   W0          GET PARAMETERS
          LDDL   W1
          LPC    0#FF
          SHN    10
          STDL   T1
          LDDL   W2          GET PP NUMBER
          SHN    -10
          LMDL   T1
          STML   PPTN
          RJM    IDP         IDLE EXISTING COPY OF *SCI*
          CCF    *,MX        CLEAR CHANNEL 15 FLAG TO CLEANUP SCI ENVIRONMENT

          LOCKMR SET
          READMR RDATA,I0CC,ITMR
          LDN    0
          STM    RDATA+7     CLEAR PORT RESERVES THAT MAY EXIST
          WRITMR RDATA,I0CC,ITMR
          LOCKMR CLEAR

*         INITIALIZE DIRECT CELLS IN BOOTSTRAP IMAGE.

          FINDCM SCI         LOCATE *SCI* IN THE CIP DIRECTORY
          ADN    1
          STML   RSCB+DE     SAVE ADDRESS OF *SCI* DIRECTORY ENTRY
          CRML   RSCB+T1,ON
          LDD    CM+1
          STML   RSCB+DE+1
          LDD    CM+2
          STML   RSCB+DE+2
          LDN    DSEBP       SAVE ADDRESS OF *CIP* DIRECTORY
          RJM    IIB
          CRML   RSCB+CD,ON
          LDM    RSCA        SAVE PP NUMBER
          LMC    4000        SET RESTART FLAG
          STM    RSCB+27

*         ACTIVATE NEW COPY OF *SCI*.

          LDML   PPTN
          RJM    IDP         IDLE PP
          LDN    MX          GET MUX CHANNEL INTERLOCK
          RJM    SCF
          LDN    MX          USE MUX CHANNEL FOR DEADSTARTING THE PP
          STD    T1
          LDML   PPTN        LOAD SELECTED PP
          RJM    DLP
          LDN    RSCBL       OUTPUT BOOTSTRAP TO PP
          OAM    RSCB,MX
          FJM    *,MX        WAIT FOR PP TO ACCEPT DATA
          DCN    MX+40
          CCF    *,MX        RELEASE CHANNEL INTERLOCK
          LJM    RSPX        RETURN

 RSCA     BSS    2

 RSCB     BSS    0           BOOTSTRAP PROGRAM
          LOC    0

          CON    BTS-1       ADDRESS - 1 TO EXECUTE

 T1       BSS    4           DIRECTORY ENTRY

 BTS      LDD    T1          SET PP LOAD ADDRESS
          STD    BTSA
          LDD    DE          SET CM LOAD ADDRESS
          ADC    RR+1
          LRD    DE+1
          CRML   **,T2       READ PROGRAM INTO PP
 BTSA     EQU    *-1         (LOAD ADDRESS)
          LJM    100         ENTER *SCI* PRESET

          BSS    30-*

 DE       BSS    3           ADDRESS OF *SCI* DIRECTORY ENTRY
          BSS    1           (USED ONLY FOR CTI/MDD LOADS)
 CD       BSS    3           ADDRESS OF *CIP* DIRECTORY
          BSS    1           (UNUSED - REQUIRED BY *CRML* INTO *CD*)
          LOC    *O
 RSCBL    EQU    *-RSCB      LENGTH OF BOOTSTRAP
 PPTN     CON    0           PP TYPE AND NUMBER

*         END    CTP$DFT_RESTART_SCI
*DECK DECK=CTP$DFT_RESTORE_POINTER_WORD EXPAND=FALSE
*         CTEXT  CTP$DFT_RESTORE_POINTER_WORD
*
*         THIS DECK WILL RESTORE THE BUFFER CONTROL WORD POINTER IN PP MEMORY.

 RPW      SUBR               ENTRY/EXIT
          LDN    VER4
          RJM    VCK         CHECK VERSION OF CM INTERFACE
          MJP    RPWX        IF LESS THAN VERSION 4
          LDN    BCWP
          RJM    IDA
          CRDL   BW          RESTORE POINTER WORD
          UJN    RPWX        RETURN

*         END    CTP$DFT_RESTORE_POINTER_WORD
*DECK DECK=CTP$DFT_RETURN_ERROR_CODE EXPAND=FALSE
*         CTEXT  CTP$DFT_RETURN_ERROR_CODE
 ERR      SPACE  4,10
**        ERR - RESPOND TO REQUEST WITH ERROR.
*
*         ENTRY  VIA *LJM*.
*
*         EXIT   TO *DFT10*.
*
*         USES   *JOBF*.
*
*         CALLS  RCS, SRS.


 ERR      LDC    0#200

*         *ERR10* IS AN ENTRY POINT.  (A) = RESPONSE CODE TO RETURN.

 ERR10    STM    JOBF

*         RESET THE STACK.

          UJP    ERR1        UNTIL ALL ERRORS REPORTED ARE UNDERSTOOD QUIT LOGGING
          LDN    VER5
          RJM    VCK         CHECK VERSION
          MJP    ERR1        IF LESS THAN VERSION 5
          LRD    DP+1
          RJM    SPB         SET OS BOUNDS
          LDN    BC
          RJM    CLR
          LDN    0
          STD    ET          RESET ET FOR THE DFT ANALYSIS CODE FORMATION
          SETDAN (EPUN,DABOR)
          SETFLG (BC.FL)
          RJM    LRP
          CRDL   CM          READ IN OS REQUEST WORD
          LDML   CALB+1      GET 2AP RESPONSE
          STDL   CM+1
          LDML   JOBF
          STDL   CM+2
          LDN    0
          STDL   CM+3
          LDN    NRSP
          RJM    IDA
          CRDL   W0          READ IN NON REGISTER BUFFER POINTER
          LRD    W1
          LDDL   W0
          ADC    RR+NRSBL+1
          CWDL   CM          WRITE REQUEST RESPONSE TO SCRATCH BUFFER
          LDN    NRSBL
          STML   LLOG
          LDN    4
          STD    ET          INITIALIZE ELEMENT TYPE TO DFT INTERNAL ERROR
          LDN    1
          STM    RTP1
          CALL   LOG         LOG THE RESPONSE TO THE NON REGISTER STATUS BUFFER
 ERR1     RJM    RCS         RESET CALL STACK
          RJM    SRS         SET REQUEST STATUS
          LJM    DFT10       GO BACK TO PROCESSING
 RCS      SPACE  4,10
**        RCS - RESET CALL STACK.
*
*         USES   ST, T1, *CUOV*, *STAK*, *STKD*.


 RCS      SUBR               ENTRY/EXIT
          LDC    STAK
          STD    ST          POINTER TO STACK
          LDN    0
          STM    STKD        RESET CURRENT STACK DEPTH
          STM    CUOV        RESET CURRENT OVERLAY
          UJN    RCSX

*         END    CTP$DFT_RETURN_ERROR_CODE

*DECK DECK=CTP$DFT_RETURN_TASK_ERROR EXPAND=FALSE
*         CTEXT  CTP$DFT_RETURN_TASK_ERROR
 RRE      SPACE  4,10
**        RRE - RETURN REQUEST ERROR.
*
*         USED FOR ISSUANCE OF ILLEGAL REQUESTS.


          ROUTINE RRE

          LJM    /ABC/ERR    REPORT ERROR

*         END    CTP$DFT_RETURN_TASK_ERROR
*DECK DECK=CTP$DFT_REWRITE_CM_ERROR EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_REWRITE_CM_ERROR
*
*         THIS DECK CONTAINS ROUTINES WHICH REWRITE SINGLE
*         BIT MEMORY ERRORS.
*         IF HCM$ IS DEFINED THEN SPECIAL CODE FOR THE 960 WILL
*         BE ASSEMBLED WHICH WILL NOT REWRITE ERRORS ABOVE MEMORY BOUNDS.
 REW      SPACE  4,10
**        REW - REWRITE SINGLE BIT ERRORS.
*
*         ENTRY  (SBER - SBER+1) = RMA OF ADDRESS TO REWRITE.
*
*         USES   W2, W3, RS - RS+2, T1, T2, T5 - T6.
*
*         CALLS  CLR, SPB, STA.


          ROUTINE REW

          IF     DEF,HCM$
          READMR RDATA,CMCC,MBRG
          LDML   SBER+1
          SHN    -11         STRIP OFF LOWER 9 BITS
          STDL   T1
          LDM    SBER
          LPC    0#1FF
          SHN    7
          LMDL   T1
          STDL   T1          SAVE LOWER VALUE OF ERROR ADDRESS
          LDM    SBER
          SHN    -11
          STD    T2          SAVE UPPER VALUE OF ERROR ADDRESS
          LDM    RDATA+7     LOWER BYTE OF BOUNDS REGISTER
          STD    T3
          LDM    RDATA+6     MIDDLE BYTE OF BOUNDS REGISTER
          SHN    10
          LMDL   T3
          STDL   T3
          LDM    RDATA+5     UPPER BYTE OF BOUNDS REGISTER
          LPN    7
          STD    T4
          LDDL   T2
          SBDL   T4
          ZJN    REW1        IF TO CONTINUE COMPARISON
          PJP    REWX        IF ERROR ADDRESS ABOVE BOUNDS, DO NOT REWRITE
          UJN    REW2        ERROR ADDRESS BELOW BOUNDS, REWRITE

 REW1     LDDL   T1
          SBDL   T3
          PJP    REWX        IF ERROR ADDRESS ABOVE BOUNDS, DO NOT REWRITE
          ENDIF
 REW2     LDML   SBER
          STDL   W2
          LDML   SBER+1      LOWER R
          STDL   W3
          RJM    STA
          STD    RS
          SRD    RS+1
          RJM    SPB         SET OS BOUNDS
          LDN    CM
          RJM    CLR         CLEAR LOCK WORD
          IF    -DEF,HCM$
          RJM    DBC         DISABLE BOUNDS CHECKING
          ENDIF
          LRD    RS+1
          LDD    RS
          ADC    RR
          RDSL   CM          READ AND SET LOCK WITH INTERLOCK WORD
          IF    -DEF,HCM$
          RJM    EBC         ENABLE BOUNDS CHECKING
          ENDIF
          LRD    DP+1
          RJM    SPB         SET PP BOUNDS
          LJM    REWX        RETURN

*         END    CTP$DFT_REWRITE_CM_ERROR
*DECK DECK=CTP$DFT_RUN_TIME_ERROR_HANDLER EXPAND=FALSE
          EJECT
          CTEXT  CTP$DFT RUN TIME ERROR HANDLER.
*
*         THIS COMMON DECK CONTAINS ERROR HANDLING ROUTINES
*         USED BY ALL VARIANTS OF DFT.
 ERRH     SPACE  4,15
**        ERRH - ERROR HANDLING FOR DFT RUN TIME ERRORS.
*
*         ENTRY  (RTP1) = 4/F,12/ANALYSIS CODE.
*                F = 0, IF PROCESSING IS TO RESUME AFTER MESSAGE PROCESSED.
*                    1, IF DFT IS TO TERMINATE.
*
*                (BC - BC+3) = SCRATCH BUFFER CONTROL WORD USED FOR LOGGING.
*
*                (FREE) = THE LAST LOGGED BUFFER CONTROL WORD FOR CPU ERRORS.
*
*         EXIT   TO *DFT10*, IF NORMAL RUNNING CALL.
*                TO *IDD*, IF TERMINATE CALL.
*
*         USES   ERRC, T1 - T7, W0 - W7.
*
*         CALLS  RCS.


          ROUTINE ERRH

          EXITMR  ERH40
          FATALMR  ERH40
          LDML   RTP1        GET MESSAGE AND ACTION
          STM    CMED
          STD    T1
          SHN    -12D
          STM    ERRC

*         SET THE ELEMENT TYPE IN THE SCRATCH BUFFER CONTROL WORD TO INTERNAL ERROR

          LDN    VER5
          RJM    VCK         CHECK VERSION
          MJN    ERH1        IF LESS THAN VERSION 5
          LDN    6
          STD    ET          RESET ELEMENT TYPE TO INTERNAL ERROR
          LDDL   BC+BCDA
          LPC    0#F0FF
          LMC    0#0600
          STDL   BC+BCDA

*         CHECK FOR SPECIAL ACTION REQUIRED.

 ERH1     LDD    T1
          LMK    DAMT
          ZJN    ERH5        IF 617 - DFT DETECT MTR T/O
          LMK    DAFC&DAMT
          NJP    ERH10       IF NOT 218 - FATAL CPU N ERROR
          LDDL   BC+BCDA
          LPC    0#F000
          LMC    DALP
          STDL   BC+BCDA     SET TO DFT LOGGED PROCESSOR FAILURE ANALYSIS
          LDN    0
          STM    RTP1
          LDM    FREE        GET LAST LOGGED BUFFER CONTROL WORD
          ZJN    ERH4        IF NOT DEFINED USE INITIAL
          RJM    IBW         INCREMENT BUFFER CONTROL WORDS
          CRDL   CM          READ IN BUFFER CONTROL WORD
          LDDL   CM+1        GET DFT ANALAYSIS CODE FROM LIVE ERROR
          LPC    0#FFF
          STML   CMED        SAVE FOR EICB MESSAGE
 ERH4     LDM    CPUO        CPU ORDINAL
 ERH5     NJN    ERH6        IF CPU1
          LDC    1RC         CPU0 ELEMENT SPECIFIER
          STML   CMEB
          LDML   CPU0M       CPU0 MODEL NUMBER
          UJN    ERH7        CONVERT DIGITS TO ASCII

 ERH6     LDC    1RD         CPU1 ELEMENT SPECIFIER
          STML   CMEB
          LDML   CPU1M       CPU1 MODEL NUMBER
 ERH7     RJM    CDA         CONVERT DIGITS TO ASCII
          STML   CMEC
          UJN    ERH20       CONSTRUCT MESSAGE IN EICB

 ERH10    LDM    IOUN        NUMBER OF IOU IN WHICH DFT IS EXECUTING
          STD    T1          TRANSLATE IOU NUMBER TO ELEMENT SPECIFIER
          LDML   ERHA,T1
          STML   CMEB
          LDML   IOUM        IOU MODEL NUMBER
          RJM    CDA         CONVERT DIGITS TO ASCII
          STML   CMEC

 ERH20    LDK    1RD         SET DFT PRODUCT
          STM    CMEA
          RJM    CME         CONSTRUCT MESSAGE IN EICB
          STM    RTP2        SAVE EICB ACCESS FLAG
          LDN    VER5
          RJM    VCK         CHECK VERSION
          MJP    ERH25       IF LESS THAN VERSION 5
          LDM    CMED
          LMC    DAPZ
          ZJP    ERH25       IF BUILD STRUCTURE FAILURE
          LDN    0
          STD    T1
          LDK    /CTPCME/TCHPL
          STD    T2
ERH21     LDML   /CTPCME/TCHP,T1
          LMML   CMED
          ZJP    ERH25       IF CH 17 ERROR
          AOD    T1
          SBD    T2
          MJN    ERH21       IF MORE CODES TO CHECK
          LDN    1
          STM    RTP1        SET TO LOG TO THE NON REGISTER STATUS BUFFER
          SETFLG (BC.FL,BC.FV7,BC.FV8)
          LDM    ERRC
          ZJN    ERH22       IF NOT TO TERMINATE DFT
          SETOSA OSNA,OSSS
 ERH22    LDN    NRSBL-1
          STM    LLOG
          CALL   LOG         LOG THE ERROR
 ERH25    LDM    ERRC        CHECK TERMINATE FLAG
          ZJP    ERH50       IF DFT IS TO CONTINUE
          LDM    RTP2
          SBN    1
          ZJN    ERH30       IF EICB CANNOT BE WRITTEN

*         NOTIFY *SCI* THAT *DFT* HAS DELIBERATELY HUNG ITSELF.

          LDN    D8RLP       READ RELOCATION CONTROL WORD
          RJM    IIB
          CRDL   W0
          LDDL   W3          RELOCATION CONTROL WORD LENGTH
          ZJN    ERH30       IF NOT DEFINED
          LRD    W1
          LDD    W0
          ADC    RR
          CRDL   W4
          LDDL   W4          SET DELIBERATE HANG STATUS
          LPC    177377
          LMC    400
          STDL   W4
          LRD    W1
          RJM    SPB         SET OS BOUNDS
          LDD    W0          REWRITE RELOCATION CONTROL WORD
          ADC    RR
          CWDL   W4
 ERH30    LDDL   BC+BCDA     REPORT ANALYSIS CODE AND HANG
 ERH40    RJM    IDD
 ERH50    EXITMR FMR         RESET TO NORMAL ERROR HANDLER
          FATALMR  FMR
          RJM    RCS         RESET CALL BLOCK
          LJM    DFT10       EXIT TO MAIN LOOP

 ERHA     CON    1RI         IOU0 ELEMENT SPECIFIER
          CON    1RJ         IOU1 ELEMENT SPECIFIER

*         END    CTP$DFT_RUN_TIME_ERROR_HANDLER


*DECK DECK=CTP$DFT_SAVE_CONTROL_STORE EXPAND=FALSE
          EJECT
*         CTEXT CTP$DFT_SAVE_CONTROL_STORE
*
*         THIS DECK CONTAINS ROUTINES TO READ AND SAVE THE
*         CONTROL STORE ADDRESS IN THE SCRATCH SUPPORTIVE
*         STATUS BUFFER.
 SCS      SPACE  4,15
**        SCS - SAVE CONTROL STORE ADDRESS.
*
*         THE CONTROL STORE ADDRESS REGISTER IS SAVED IN THE APPROPRIATE
*         (PRE-HALT OR AFTER HALT) WORD IN THE SCRATCH SUPPORTIVE STATUS
*         BUFFER.  IF AFTER HALT, THEN THE STATUS SUMMARY REGISTER IS
*         ALSO SAVED.
*
*         ENTRY  (A) = 0 IF BEFORE HALT.
*                    = 1 IF AFTER HALT.
*
*         USES   EC, T2.
*
*         CALLS  GCA, PAC, SPB.
*
*         MACROS READMR.


 SCS      SUBR               ENTRY/EXIT
          STM    SCSA
          LDN    VER4
          RJM    VCK         CHECK VERSION
          MJN    SCSX        IF LESS THAN VERSION 4
          LRD    DP+1
          RJM    SPB         SET PP BOUNDS TO WRITE INTO DFT BUFFER
          LDM    CPUO        GET CPU ORDINAL
          NJN    SCS1        IF NOT CPU-0
          LDM    CP0CC       PROCESS CPU-0
          UJN    SCS2        CONTINUE

 SCS1     LDM    CP1CC       PROCESS CPU-1
 SCS2     STD    EC
          LDML   CSAR
          STDL   RN          SET CONTROL STORE ADDRESS REGISTER NUMBER
          READMR RDATA
          RJM    PAC         PACK REGISTER DATA

*         WRITE CONTROL STORE ADDRESS TO SCRATCH SUPPORTIVE STATUS BUFFER.

          RJM    GCA         GET CONTROL STORE WORDS ADDRESS
          ADM    SCSA        ADD ONE IF AFTER HALT
          CWML   MRVAL,ON    WRITE TO BUFFER
          LDM    SCSA
          ZJN    SCS3        IF BEFORE HALT

*         SAVE SUMMARY STATUS REGISTER.

          READMR RDATA,,SSMR
          RJM    PAC
          RJM    GCA         GET CONTROL STATUS WORDS ADDRESS
          ADN    2           SKIP TO SAVE SUMMARY STATUS WORD
          CWML   MRVAL,ON
 SCS3     LJM    SCSX        RETURN

 SCSA     CON    0           BEFORE/AFTER HALT CONDITION
 GCA      SPACE  4,10
**        GCA - GET CONTROL STORE WORDS ADDRESS.
*
*         RETURNS THE ADDRESS OF THE FIRST SAVE CONTROL STORE WORD
*         IN THE SCRATCH SUPPORTIVE STATUS BUFFER.
*
*         EXIT   (A) = ADDRESS OF THE PRE-HALT CONTROL STORE WORD
*                      IN THE SCRATCH SUPPORTIVE STATUS BUFFER.
*
*         USES   CM - CM+3.
*
*         CALLS  IDA.


 GCA      SUBR               ENTRY/EXIT
          LDN    SSBP
          RJM    IDA
          CRDL   CM
          LDN    5           OFFSET TO SAVE CONTROL STORE WORDS
          RADL   CM
          LRD    CM+1
          ADC    RR
          UJN    GCAX        RETURN

*         END CTP$DFT_SAVE_CONTROL_STORE

*DECK DECK=CTP$DFT_SAVE_PP_REGISTERS EXPAND=FALSE
*         CTEXT  CTP$DFT_SAVE_PP_REGISTERS
*
*         THIS DECK CONTAINS THE ROUTINE WHICH WILL SAVE THE P,Q,K,A PP
*         REGISTERS IN THE DFT PP REGISTER SAVE BUFFER. THIS CODE WILL
*         ONLY WORK ON VERSION 5 OR GREATER OF THE DFT CENTRAL MEMORY
*         INTERFACE. TWO COPIES OF AN INDIVIDUAL PPS REGISTERS ARE KEPT
*         ADJACENT TO EACH OTHER. THESE REPRESENT THE LAST PASS SNAPSHOT AND
*         THE CURRENT PASS SNAPSHOT. THE GLOBAL VARIABLE PDSO IS A TOGGLE
*         FOR WHICH SET OF REGISTER DATA TO WRITE NEXT.


 PPTN     CON    0           USED BY ROUTINE DPR TO STORE PP NUMBER


          ROUTINE SRD

          LDN    VER4        CHECK FOR VERSION 4 OR LATER
          RJM    VCK         CHECK VERSION
          MJP    SRDX        IF EARLIER THAN VERSION 4
          LDC    LDNI
          STM    DFTF        RESET FLAG
          LDN    PRDP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   W4          PP SAVE AREA POINTER
          LRD    W5
          LDDL   W4
          ADC    RR
          CRDL   CM          PP SAVE AREA HEADER WORD
          AODL   W4          GET PAST THE HEADER WORD
          LDM    IOUN
          ZJN    SRD1        IF PRIMARY IOU
          LDN    VER5
          RJM    VCK         CHECK VERSION
          MJP    SRDX        IF NOT VERSION 5 OR GREATER DONT SAVE REGISTERS IN SECONDARY
          LDDL   CM+3        GET OFFSET TO SECONDARY BUFFER
          RADL   W4
 SRD1     LDM    PDSO        PP DUMP SELECT OFFSET
          RADL   W4          SELECT WHICH SAVE AREA TO USE
 SRD2     RJM    DPR         DUMP PP REGISTERS
          LDM    PPTN
          SBN    31
          PJP    SRD4        IF DONE DUMPING PP REGISTERS
          AOM    PPTN
          SBN    12
          MJN    SRD3        IF IN LOWER BARREL(S)
          LDM    PPTN
          SBN    20
          PJN    SRD3        IF IN UPPER BARREL(S)
          LDN    20
          STM    PPTN
 SRD3     LDN    2
          RADL   W4          GET TO NEXT PP SAVE AREA
          UJN    SRD2

 SRD4     LDM    IOUM        IOU MODEL NUMBER
          LMC    0#42
          ZJN    SRD4.5      IF MODEL 42 IOU
          LDM    IOUM        IOU MODEL NUMBER
          LMC    0#40
          NJP    SRD6        IF NOT I4 IOU
 SRD4.5   READMR RDATA,I0CC,OIMR
          LDM    RDATA+7
          SHN    10D
          PJP    SRD6        IF NO CIO PPS
          LDC    0#100
          STML   PPTN        RESET PP NUMBER FOR CIO PPS
          LDN    2           ADVANCE TO START OF CIO REGISTER SAVE AREA
          RADL   W4
 SRD5     RJM    DPR         DUMP PP REGISTERS
          LDM    PPTN
          LPC    0#FF
          SBN    11
          PJN    SRD6        IF DONE
          AOML   PPTN
          LDN    2
          RADL   W4          GET TO NEXT PP SAVE AREA
          UJN    SRD5

 SRD6     LDM    PDSO
          LMN    2
          STM    PDSO        TOGGLE SELECTOR
          UJP    SRDX        RETURN

*         END    CTP$DFT_SAVE_PP_REGISTERS
*DECK DECK=CTP$DFT_SEND_PACKET_ALL EXPAND=FALSE
*         CTEXT  CTP$DFT_SEND_PACKET_ALL
*
*         THIS DECK DEFINES ROUTINES WHICH WILL INITIATE PACKET
*         ACTIVITY.
 SPD      SPACE  4,10
**        SPD - SEND PACKET DATA.
*
*

          ROUTINE SPD

*         DETERMINE IF DUAL IOU PACKETS ARE NEEDED.

          LDML   DI4CW       CHECK DUAL I4 PACKETS
          ZJN    SPD1        IF NO REQUEST
          CALL   LDS         LOAD DFT INTO SECONDARY IOU
          UJP    SPDX        RETURN

*         DETERMINE IF BACKGROUND PACKETS ARE ALLOWED.

 SPD1     LDML   CELCW       CHECK CONSOLE LOGGING STATUS
          NJN    SPD2        IF LOGGING OUTSTANDING/IN PROGRESS
          LDM    MRTU        CHECK IF MRT UPDATE NEEDS TO BE LOGGED
          ZJN    SPD3        IF MRT HAS NOT BEEN UPDATED
          LDN    77          INITIATE MRT TRANSFER
          STM    CELCW
 SPD2     CALL   LTC         LOG TO CONSOLE
          UJP    SPDX        RETURN

*         CHECK FOR GENERAL PACKET REQUESTS.

 SPD3     LDM    PKTCW
          ZJN    SPD4        IF NO REQUEST PRESENT
          STML   RTP1
          LDN    1           SET LENGTH TO 1 8-BIT BYTE
          STML   RTP2
          CALL   PKT         SEND REQUESTED PACKET
          LDML   CALB+1      CHECK FOR ERROR
          ZJN    SPD5        IF NO ERROR, SET RESPONSE PENDING AND RETURN
          LDN    0           CLEAR CONTROL WORD
          UJP    SPD6        RETURN

*         SEND CHECK-IN PACKET IF TIME HAS ELAPSED.

 SPD4     LDM    S0FLG
          ZJP    SPDX        IF NOT S0/S0E
          LDM    CPSA        CHECK ELAPSED TIME FLAG
          ZJP    SPDX        IF NOT TIME TO SEND CHECK-IN PACKET
          LDN    0           CLEAR FLAG
          STM    CPSA
*         LDN    PKRCI       SEND CHECK-IN PACKET
*         STML   RTP1
*         CALL   PKT
          UJP    SPDX        **** DISABLE CHECK-IN PACKETS FOR NOW ****

*         UPDATE *PKTCW* AND RETURN.

 SPD5     LDC    PKWRP       CLEAR REQUEST AND SET RESPONSE PENDING
 SPD6     STML   PKTCW
          LJM    SPDX        RETURN
 MPR      SPACE  4,10
**        MPR - MAKE PACKET REQUEST.
*
*         ENTRY  (RTP1) = REQUEST.
*                (PKTCW) = PACKET CONTROL WORD.
*
*         EXIT   (PKTCW) UPDATED IF NO REQUEST PREVIOUSLY PRESENT.
*                (RTP1) = 0, IF REQUEST QUEUED.
*                       = 1, IF REQUEST QUEUE FULL.

          ROUTINE  MPR

          LDM    PKTCW       CHECK PREVIOUS REQUEST (IGNORE RESPONSE PENDING)
          NJN    MPR1        IF PREVIOUS REQUEST PRESENT
          LDM    RTP1        MERGE REQUEST WITH RESPONSE PENDING STATUS IF ANY
          RAML   PKTCW
          LDN    0           SET REQUEST RECORDED
          STML   RTP1
          LJM    MPRX        RETURN

 MPR1     LRD    DP+1
          RJM    SPB         SET OS PP BOUNDS
          LDN    BC
          RJM    CLR         CLEAR SCRATCH CONTROL WORD
          LDN    0
          STD    ET
          SETDAN (EPCO,DAQF)
          SETFLG (BC.FL)
          LDN    NRSBL-1
          STM    LLOG
          LDN    1
          STM    RTP1
          CALL   LOG         LOG THE ERROR
          LJM    MPRX        RETURN
*         END    CTP$DFT_SEND_PACKET_ALL
*DECK DECK=CTP$DFT_SEND_PACKET_FOR_NON_S0 EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT SEND PACKET FOR NON S0.
*
*         COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
*
*         THIS DECK CONTAINS CODE FOR SENDING A PACKET ON NON-S0
*         MAINFRAMES.
 PKT      SPACE  4,15
**        PKT - PROCESS CONSOLE PACKETS VIA *2AP*.
*
*         ENTRY  (RTP1) = 4/0, 2/C, 1/S, 1/0, 8/CODE.
*                (RTP2) = 16/L.
*                C = OFFSET TO PACKET CONTROL WORD IF TIMING DESIRED.
*                S = 1, IF SEQUENCE NUMBER IS IN UPPER 8 BITS.
*                CODE = PACKET FUNCTION CODE (SEE *CTI$PACKET_DEFINITIONS*).
*                L = PACKET LENGTH IN 8-BIT BYTES.
*
*         EXIT   (CALB+1) = 0, IF NO ERROR.
*
*         USES   T1, T2, T3.
*
*         CALLS  CER, ICP, SCF.


          ROUTINE  PKT

*         STORE PARAMETERS IN *2AP* CALL BLOCK.

          LDM    RTP1        CALL PARAMETERS
          LPC    0#FF
          STM    CALB+1      SAVE PACKET FUNCTION CODE
          LDC    140         REQUEST = SEND PACKET
          STM    CALB+0
          LDML   TINB        SET BUFFER ADDRESS (*TOIP*)
          STML   CALB+2
          LDM    RTP2        SET PACKET LENGTH
          STM    CALB+3
          ADN    1           ROUND UP TO NEAREST MULTIPLE OF TWO
          SHN    -1
          STD    T2

*         SET PACKET SEQUENCE NUMBER.

          AOML   PKSEQ       INCREMENT PACKET SEQUENCE NUMBER
          LPC    0#FF
          STDL   T1
          LDD    T2          PACKET LENGTH IN PP WORDS
          SBN    1
          ADML   TINB
          STDL   T2
          LDML   RTP1
          SHN    21-11
          PJN    PKT1        IF SEQUENCE NUMBER IS TO BE IN LOWER PART
          LDDL   T1
          SHN    10
          STDL   T1
          LDIL   T2
          LPC    0#FF
          UJN    PKT2

 PKT1     LDIL   T2
          LPC    0#FF00
 PKT2     LMDL   T1          SET SEQUENCE NUMBER
          STIL   T2

*         ISSUE A CLEAR PACKETS REQUEST TO THE TWO PORT MUX.
*         THIS IS DONE IN CASE A RESPONSE PACKET IS PRESENT
*         IN THE TWO PORT MUX FROM A PREVIOUS TIMED OUT PACKET
*         REQUEST.  IF THIS WAS NOT DONE, THEN AN EXISTING
*         RESPONSE PACKET WOULD PREVENT THE RECEIPT OF THE
*         RESPONSE PACKET FOR THE NEW REQUEST.  THE NEW RESPONSE
*         PACKET WOULD BE DISCARDED IF THE TWO PORT MUX
*         ALREADY CONTAINED A RESPONSE PACKET.

          RJM    ICP         ISSUE CLEAR PACKETS REQUEST

*         SEND PACKET TO CONSOLE VIA *2AP* AND CHECK FOR ERRORS.

          LDN    MX          GET CHANNEL 15 INTERLOCK
          RJM    SCF
          FNC    MXPT,MX     SELECT PORT
          AJM    *,MX
          CALL   PFC         CALL *2AP*
          FNC    MXDM,MX     DESELECT MUX
          AJM    *,MX
          CCF    *,MX        RELEASE CHANNEL 15 INTERLOCK
          LDM    RTP1        SET PACKET TIMING DESIRED
          LPC    0#C00
          SHN    2
          STML   PKTIM
          LDML   CALB+1
          ZJN    PKT3        IF NO ERROR
          LDN    0           CLEAR PACKET TIMING CONTROL
          STML   PKTIM
 PKT3     LJM    PKTX        RETURN

*         END    CTP$DFT SEND PACKET FOR NON S0
*DECK DECK=CTP$DFT_SERVICE_MEMORY_ERROR EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT SERVICE MEMORY ERROR.
*
*         THIS DECK CONTAINS ROUTINES TO CHECK FOR MULTIPLE ODD BIT
*         MEMORY ERRORS, CALL REWRITE MEMORY ERROR, AND UPDATE IN SECDED ID TABLE
 SME      SPACE  4,10
**        SME - SERVICE MEMORY ERROR.
*
*         CALLS  UST, *LOG*, *RWE*.


          ROUTINE SME

          LDC    MOETT
          STD    T3
 SME1     LDM    MOET,T3     GET SYNDROME ENTRY
          SBM    SYCD
          ZJN    SME2        IF HAVE A MATCH
          SOD    T3
          PJN    SME1        IF MORE ENTRIES TO CHECK
          LJM    SME3        PROCESS SINGLE BIT ERROR

*         SET UP BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - CODE = MULTIPLE ODD BIT ERROR.
*         DFT ANALYSIS - FLAGS = VALID 170, VALID 180.
*         DFT ANALYSIS - OS ACTION = MULTIPLE ODD BIT ERROR.
*                                  = SYSTEM STEP (VERSION 4).

 SME2     SETDAN (EPUN,DAMOB)
          SETFLG (BC.FV7,BC.FV8)
          SETOSA OSMOB,OSSS
          CALL   LOG
          UJN    SME4        RETURN

*         PROCESS SINGLE BIT ERROR.

 SME3     CALL   REW         REWRITE SINGLE BIT ERROR
          RJM    UST         UPDATE SECDED ID TABLE
          ZJN    SME4        IF NOT TO LOG THIS ERROR
          CALL   LOG
 SME4     LJM    SMEX        RETURN
 MOET     SPACE  4,10
**        MOET - TABLE OF MULTIPLE ODD BIT ERRORS.
*
*         12/ CODE
*
*         CODE IS SYNDROME FOR MULTIPLE ODD BIT ERROR BEING
*         REPORTED AS SINGLE BIT ERROR.


 MOET     BSS    0
          LOC    0
          DATA   0#13,0#15,0#16,0#19,0#1A,0#1C,0#1F,0#23
          DATA   0#25,0#26,0#29,0#2A,0#2C,0#2F,0#31,0#32
          DATA   0#34,0#38,0#43,0#45,0#46,0#49,0#4A,0#4C
          DATA   0#4F,0#51,0#52,0#54,0#58,0#61,0#62,0#64
          DATA   0#68,0#83,0#85,0#86,0#89,0#8A,0#8C,0#8F
          DATA   0#91,0#92,0#94,0#98,0#A1,0#A2,0#A4,0#A8
          DATA   0#C1,0#C2,0#C4,0#C8,0#F1,0#F2,0#F4,0#F8
 MOETT    EQU    *-1
          LOC    *O
 UST      SPACE  4,10
**        UST - UPDATE SECDED ID TABLE.
*
*         ENTRY  (SBER - SBER+1) = ADDRESS OF ERROR.
*                (SYCD) = SYNDROME CODE.
*
*         EXIT   (A) <> 0 IF ENTRY SHOULD BE LOGGED.
*                (A) = 0 IF ENTRY SHOULD NOT BE LOGGED.
*                A NEW ENTRY IS CREATED OR AN EXISTING ENTRY UPDATED.
*
*         USES   T4, T5, W0 - W7.
*
*         CALLS  IDA, SPB.


 UST      SUBR               ENTRY/EXIT
          LDN    0
          STD    T4
          LDN    SECP        SECDED ID TABLE POINTER OFFSET
          RJM    IDA
          CRDL   W0          READ IN POINTER WORD
          LRD    W1          SET UP R-REGISTER
 UST1     LDD    W0
          ADD    T4
          ADC    RR
          CRDL   W4          READ ENTRY
          LDD    W4          COUNT FIELD
          ZJN    UST3        IF FREE ENTRY
          LDML   SBER
          SBDL   W5
          NJN    UST2        IF NO MATCH
          LDML   SBER+1
          SBDL   W6
          NJN    UST2        IF NO MATCH SECOND PART
          AOD    W4          MATCH - BUMP COUNT
          LDD    W0
          ADD    T4
          ADC    RR
          CWDL   W4          REWRITE ENTRY
          LDN    0
          UJN    USTX        IF OK POSITIVE

 UST2     AOD    T4
          SBD    W3
          ZJN    UST4        IF THROUGH SCANNING
          UJN    UST1        LOOP

 UST3     LDM    USTA
          NJN    UST2
          AOM    USTA        MARK THAT FREE ENTRY FOUND
          LDD    T4
          STD    T5          HOLDS FREE ENTRY
          UJN    UST2        LOOP

 UST4     LDM    USTA
          ZJN    UST5        IF NO FREE ENTRY FOUND
          LDN    1           CREATE A NEW ENTRY
          STD    W4          COUNT IS 1
          LDM    SYCD        SYNDROME
          STD    W7
          LDML   SBER+1      ADDRESS
          STDL   W6
          LDML   SBER
          STDL   W5
          RJM    SPB         SET PP BOUNDS
          LDD    W0
          ADD    T5
          ADC    RR
          CWDL   W4          WRITE NEW ENTRY
          LDN    1
 UST5     LJM    USTX        RETURN

 USTA     CON    0

*         END    CTP$DFT SERVICE MEMORY ERROR
*DECK DECK=CTP$DFT_SET_SS_DUAL_I4 EXPAND=FALSE
*         CTEXT CTP$DFT_SET_SS_DUAL_I4

 SER      SPACE  4,10
**        SER - SET SS ERROR READ FLAG TO INDICATED VALUE.
*
*         ENTRY  (A) = 0 TO CLEAR, 1 TO SET FLAG.
*                (CM - CM+3) = SECONDARY DFT BUFFER HEADER.
*
*         USES   CM+3.
*
*         CALLS  PCM.


 SER      SUBR               ENTRY/EXIT
          SHN    3
          ADC    LMCI
          STML   SERA
          LDDL   CM+3
          LPC    0#7FFF
          LMC    0           SET SS ERROR READ FLAG
 SERA     EQU    *-2
          STDL   CM+3
          LDN    CMSS
          RJM    PCM         PUT CM RESIDENT WORD
          UJN    SERX        RETURN

*         END CTP$DFT_SET_SS_DUAL_I4
*DECK DECK=CTP$DFT_SPECIAL_MAC_ACCESS EXPAND=TRUE
          EJECT
*         CTEXT  CTP$DFT_SPECIAL_MAC_ACCESS
*
*         J.M. SKOWRONEK     9/25/87.

          LIST   X

**        RDMEM - READ CONTROL MEMORIES.
*         PERFORM AN INDEXED READ OF CONTROL MEMORIES.
*
*         RDMEM  ID,IDD,PPFWA,PPD,BC,TC
*
*         ID = CONTROL MEMORY NAME
*         IDD = PP MEMORY CELL ADDRESS OF INDEX TO MEMORY
*         PPFWA = BASE ADDRESS OF MEMORY BUFFER IN PP TO
*                 RECEIVE DATA, DEFAULT = RDATA
*         PPD = PP MEMORY CELL ADDRESS OF INDEX TO PPFWA
*         BC = NUMBER OF BYTES TO READ, DEFAULT = 1
*         TC = TYPE CODE OF CONTROL MEMORY, REQUIRED


          PURGMAC  RDMEM
 RDMEM    MACRO  ID,IDD,PPFWA,PPD,BC,TC
          LOCAL  RDMEM0
          LDK    ID          GET MEMORY ADDRESS
          IFC    NE,$IDD$$,1
          ADML   IDD         ADD OFFSET
          STDL   RN          STORE ADDRESS
 CHK      IFC    NE,$PPFWA_PPD$$
 CHK1     IFC    NE,$PPFWA$$
          IFC    NE,$PPD$$,3
          LDK    PPFWA       LOAD CONSTANT
          ADML   PPD         ADD OFFSET
          SKIP   1
          LDK    PPFWA       GET ADDRESS
 CHK1     ELSE   1
          LDML   PPD         GET ADDRESS
 CHK      ELSE   1
          LDK    RDATA
          STML   RDMEM0+1    MODIFY *IAM* INSTRUCTION
          LDM    HBUF+HDRPC
          ADC    MRRD+TC     LOAD FUNCTION WORD
          RJM    AMR         ACCESS MAINTENANCE CHANNEL
          IFC    EQ,$BC$$    OPTIONAL BYTE COUNT
          LDN    1
          ELSE   1
          LDN    BC_D        USE SPECIFIED BYTE COUNT
 RDMEM0   IAM    0,MR        BLOCK INPUT
          RJM    CMI         CLEAR INTERLOCK
 RDMEM    ENDM

*         END OF DECK CTP$DFT_SPECIAL_MAC_ACCESS



*DECK DECK=CTP$DFT_START_MICROCODE EXPAND=FALSE
          CTEXT  CTP$DFT START MICROCODE.
 CTPDSM   SPACE  4,10
 QUAL$    IF     -DEF,QUAL$
          QUAL   CTPDSM
 QUAL$    ENDIF
          BASE   M
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 CTPDSM   SPACE  4,10
***       CTP$DFT START MICROCODE.
*         D. K. ELDRED.      87/11/12.
 CTPDSM   SPACE  4,10
***       THIS COMMON DECK PROVIDES A UNIFORM INTERFACE TO START CPU MICROCODE
*         AT A SELECTED MICROCODE ADDRESS.
 SMC      SPACE  4,10
**        SMC - START MICRO CODE.
*
*         ENTRY  (A) = MICRO CODE ADDRESS.
*                (CSAR) = CPU *CSA* REGISTER NUMBER.
*                (HBUF) = PROCESSOR MRT ENTRY.
*
*         EXIT   PROCESSOR HAS BEEN -
*                  MASTER CLEARED.
*                  S-REGISTER WRITTEN.
*                  STARTED.
*
*         MACROS FUNCMR, WRITMR.


 SMC      SUBR               ENTRY/EXIT
          STM    SMCA+7
          SHN    -10
          STM    SMCA+6
          FUNCMR HBUF+CPRPC,MRMC  MASTER CLEAR PROCESSOR
          LDM    CSAR
          STD    RN
          WRITMR SMCA,HBUF+CPRPC
          FUNCMR HBUF+CPRPC,MRSP   START PROCESSOR
          LDC    200D        WAIT 100 MICROSECONDS
 SMC1     SBN    1
          NJN    SMC1        IF DELAY NOT COMPLETE
          LJM    SMCX        RETURN

 SMCA     BSSZ   10B
 CTPDSM   SPACE  4,10
          BASE   *
 QUAL$    IF     -DEF,QUAL$
          QUAL   *
 SMC      EQU    /CTPDSM/SMC
 QUAL$    ENDIF
          ENDX
*DECK DECK=CTP$DFT_TEST_DLD_PATH EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT TEST DLD PATH.
*
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 TPD      SPACE  4,10
**        TPD - TEST PATH TO THE DEDICATED LOAD DEVICE.
*
*         CALLS  FHE, *PDE*, PFC, VCK.


          ROUTINE  TPD

          LDN    VER4
          RJM    VCK         CHECK VERSION
          MJP    TPD1        IF CM INTERFACE LESS THAN 4
          LDN    IOUID
          RJM    FHE         GET IOU0 ELEMENT DESCRIPTOR
          LDM    HBUF+CPRE+EM
          SHN    -4
          LMC    0#43
          ZJN    TPD0        IF MODEL 43 IOU
          LMN    0#44&0#43
          NJN    TPD1        IF IOU0 IS NOT MODEL 44
 TPD0     LDN    41B         TEST DEDICATED LOAD DEVICE PATH
          STM    CALB
          STM    RTP1
          CALL   PFC         PREPARE FOR *2AP* CALL
          LDML   CALB+1      CHECK FOR ERROR
          ZJN    TPD1        IF NO ERROR ON PATH TEST
          SBN    76+1
          PJN    TPD1        IF NO ERROR ON PATH TEST
          LDC    0#A000      RETURN / DO NOT SET STATUS / NON OS REQ / NO OFFSET
          STML   RTP2
          CALL   PDE         PROCESS DISK ERROR
 TPD1     LJM    TPDX        RETURN

*         ENDX   CTP$DFT TEST DLD PATH.

*DECK DECK=CTP$DFT_UPDATE_170_MEMORY EXPAND=TRUE
          EJECT
*         CTEXT  CTP$DFT_UPDATE_170_MEMORY
*
*         THIS DECK DEFINES PROCEDURES TO UPDATE THE SCD BLOCK
*         IN CENTRAL MEMORY
 UCM      SPACE  4,10
**        UCM - UPDATE C170 MEMORY.
*
*         CLEARS THE VE CONSOLE STATUS.
*
*         CALLS  IIB, SPB.


          ROUTINE UCM

          LDN    D7RS+2
          RJM    IIB         FIND OFFSET TO SCD INFORMATION
          CRDL   T2
          LDDL   T4          BUILD R-REGISTER TO ACCESS SCD BLOCK
          SHN    -2+22
          STD    T6
          SHN    2-22
          SHN    6+4
          STD    T7
          LDDL   T4          CHECK FOR NOS SCD BLOCK
          ADDL   T5
          ZJP    UCM4        IF NO BLOCK DEFINED
 UCM1     LDN    0           INTERLOCK SCD BLOCK
          STDL   CM
          STDL   CM+2
          STDL   CM+3
          LDC    10000
          STDL   CM+1
          LRD    T6
          RJM    SPB         SET PP BOUNDARY
          LDDL   T5
          LMC    RR
          RDSL   CM          SET INTERLOCK
          LDDL   CM+1
          LPC    10000
          NJN    UCM1        IF INTERLOCK ALREADY SET
          LDDL   CM+1        SET CONSOLE DEFINITION CHANGED BIT
          LPC    0#BFFF
          LMC    0#4000
          STDL   CM+1
          LDDL   CM+2        CHECK IF NOS/SCD ACTIVE
          SHN    21-11
          PJN    UCM2        IF NOT ACTIVE
          LDDL   CM+2        CLEAR VE CONSOLE BIT
          LPC    0#FBFF
          UJN    UCM3        CLEAR BIT

 UCM2     LDN    0           CLEAR ENTIRE *SCD* BYTE
 UCM3     STDL   CM+2
          LDDL   T5          WRITE FIRST WORD AND CLEAR INTERLOCK
          LMC    RR
          CWDL   CM
 UCM4     LJM    UCMX        RETURN
 IMM      SPACE  4,10
**        IMM - ISSUE MONITOR TIMED OUT MESSAGE.
*
*         CALLS  *ERRH*.


          ROUTINE IMM        ENTRY/EXIT
          LDN    0
          RJM    IDA         GET DFT HEADER FLAGS BIT 50
          CRDL   CM
          LDDL   CM+3
          SHN    21-15
          PJN    IMM2        IF NOT SET DONT HAMMER SYSTEM
          LDN    0
          STM    CPUO
          LDN    PROCID
 IMM1     RJM    FHE
          MJP    IMM2        IF DONE PROCESSING CPUS
          CALL   HPR
          CALL   DMP
          AOM    CPUO
          SBN    2
          PJN    IMM2        IF NO MORE CPUS TO DO
          LDC    PROCID1
          UJN    IMM1

 IMM2     SOM    DFTD        CLEAR MESSAGE NEEDED FLAG
          LDN    0
          STD    ET
          LDN    BC
          RJM    CLR

*         DFT ANALYSIS - MONITOR TIMED OUT ON HANDSHAKE.

          SETDAN (EPUN,DAMT)
          LDC    DAMT        SET ANALYSIS CODE
          STML   RTP1
          CALL   ERRH        ISSUE MESSAGE
          UJP    IMMX        RETURN


*         END    CTP$DFT_UPDATE_170_MEMORY
*DECK DECK=CTP$DFT_VALIDATE_STRUCTURE EXPAND=FALSE
*         CTEXT  CTP$DFT_VALIDATE_DFT_STRUCTURE

 VDS      SPACE  4,10
**        VDS - VALIDATE DFT STRUCTURE.
*
*         EXIT   (A) < 0 STRUCTURE NOT VALIDATED.
*                (A) = 0 STRUCTURE VALIDATED.
*
*         CALLS  IDA, VCK.


 VDS0     LCN    0           MINUS EXIT CONDITION
 VDS      SUBR               ENTRY/EXIT
          LDN    HDRP
          RJM    IDA         INCREMENT DFT ADDRESS
          CRDL   CM
          LDDL   CM+DHFLG
          SHN    21-DH.FV
          PJN    VDS0        IF VERIFIED BIT NOT SET
          LDN    VER5
          RJM    VCK         CHECK VERSION
          PJN    VDS2        IF VERSION 5 OR GREATER
 VDS1     LDN    0
          UJN    VDSX        RETURN

 VDS2     LDDL   CM
          SHN    -10
          LPN    0#F
          STD    T7          SAVE NUMBER OF POINTER WORDS
          RJM    IDA         INCREMENT DFT POINTER ADDRESS
          CRDL   W0
          LDDL   W3
          ADDL   W0
          ADC    RR+1
          CRDL   CM
          LDDL   CM
          LMC    0#4446
          NJP    VDS0        IF NO MATCH
          LDDL   CM+1
          LMC    0#5453
          NJP    VDS0        IF NO MATCH
          SOD    T7
          ZJP    VDS1        IF AT END OF POINTERS
          UJP    VDS2

*         END    CTP$DFT_VALIDATE_DFT_STRUCTURE
*DECK DECK=CTP$DFT_WRITE_FSC EXPAND=FALSE
 WFC      SPACE  4,10
**        WFC - WRITE FAULT SYMPTOM CODE.
*
*         ENTRY  (A) = TWO CHARACTER ELEMENT IDENTIFIER.
*                (BC - BC+3) = BUFFER CONTROL WORD.
*                (RTP1) = 0 LOG TO SUPPORTIVE STATUS
*                       = 1 LOG TO NON REGISTER STATUS
*         USES   T1, CM - CM+3.
*
*         CALLS  CDA, CSD, IDA.


 WFC      SUBR               ENTRY/EXIT
          STDL   T1          SAVE ELEMENT IDENTIFIER
          LDN    3
          STM    WFCC        NUMBER OF HEADER WORDS FOR SUPPORTIVE STATUS
          LDM    RTP1        FLAG TO LOG TO SUPPORTIVE STATUS OR NON REGISTER STATUS
          ZJN    WFC1        IF TO LOG TO SUPPORTIVE STATUS
          AOM    WFCC        NON REGISTER STATUS HAS 1 MORE HEADER WORD THAN SUPPORTIVE
          LDN    NRSP        ADDRESS OF SCRATCH NON REGISTER STATUS BUFFER
          UJN    WFC2

*         READ FIRST WORD OF FAULT SYMPTOM CODE TO PRESERVE FIRST TWO BYTES.

 WFC1     LDN    SSBP        GET ADDRESS OF SCRATCH BUFFER
 WFC2     RJM    IDA
          CRDL   CM
          LDM    WFCC        SKIP HEADER WORDS
          RADL   CM
          LRD    CM+1
          ADC    RR
          CRML   WFCA,ON
          LDDL   T1          SET ELEMENT IDENTIFIER
          STML   WFCB

*         SET MODEL NUMBER.

          LDD    MD
          RJM    CDA         CONVERT TWO DIGITS TO ASCII
          STML   WFCB+1

*         SET SYMPTOM CODE.

          LDDL   BC+BCDA     DFT ANALYSIS
          SHN    -10
          LPN    0#F
          STD    T1
          LMN    4           4XX INTERNAL ERROR
          ZJN    WFC2.5      IF INTERNAL ERROR
          LDD    T1
          LMN    5           5XX INTERNAL ERROR
          ZJN    WFC2.5      IF INTERNAL ERROR
          LDD    T1
          LMN    6           6XX CODE
          ZJN    WFC2.5      IF INTERNAL ERROR
          UJN    WFC3

 WFC2.5   LDML   WFCB+2
          LPC    0#FF00
          STML   WFCB+2
          LDDL   BC+BCDA
          SHN    -10
          LPN    0#F
          RJM    CSD         CONVERT SINGLE DIGIT
          LMML   WFCB+2
          STML   WFCB+2
          LDDL   BC+BCDA
          LPC    0#FF
          RJM    CDA         CONVERT DIGITS TO ASCII
          STML   WFCB+3
          UJP    WFC4

 WFC3     LDDL   BC+BCDA     DFT ANALYSIS
          SHN    -4          ISOLATE FIRST TWO CHARACTERS
          LPC    377
          RJM    CDA         CONVERT TWO DIGITS TO ASCII
          STML   WFCB+2
          LDD    BC+BCDA     ISOLATE LAST CHARACTER
          LPN    17
          RJM    CSD         CONVERT SINGLE DIGIT TO ASCII
          SHN    10
          LMC    1R
          STML   WFCB+3

*         WRITE FAULT SYMPTOM CODE TO SCRATCH SUPPORTIVE STATUS BUFFER.

 WFC4     LDN    2           SET NUMBER OF CM WORDS TO WRITE
          STD    T1
          LDDL   CM          LOAD ADDRESS OF SCRATCH BUFFER
          ADC    RR
          CWML   WFCA,T1     WRITE TO SCRATCH BUFFER
          LJM    WFCX        RETURN

 WFCC     BSS    1
 WFCA     BSS    2           RESERVED AREA OF FAULT SYMPTOM CODE
 WFCB     DATA   12HDEMMZCC
*DECK DECK=CTP$DFT_WRITE_FSC_TO_BUFFER EXPAND=FALSE
          EJECT
*         CTEXT  CTP$DFT_WRITE_FSC_TO_BUFFER
*
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4,10
**        DATA GLOBAL TO THIS COMMON DECK.


 FSCB     BSS    0           FAULT SYMPTOM CODE BUFFER
 RFU      BSSZ   2           RESERVED FOR FUTURE USE
 SFS      BSSZ   2           START OF FAULT SYMPTOM CODE
 CDIF     BSSZ   21          COMMON DECK INTERFACE BUFFER
 FSCBL    EQU    *-FSCB-5    LENGTH OF FAULT SYMPTOM CODE BUFFER
 WFS      SPACE  4,10
**        WFS - WRITE FAULT SYMPTOM CODE TO SUPPORTIVE STATUS BUFFER.
*
*         ENTRY  (A) = ELEMENT IDENTIFIER.
*                (CDIF - CDIF+3) = FAULT SYMPTOM CODE.
*                (RTP1) = 0 LOG TO SUPPORTIVE STATUS.
*                (RTP1) = 1 LOG TO NRSB.
*
*         USES   CM - CM+3, T1.
*
*         CALLS  CDA, IDA.


 WFS      SUBR               ENTRY/EXIT
          STDL   T1          SAVE ELEMENT IDENTIFIER
          LDN    3           HEADER WORDS FOR SUPPORTIVE STATUS
          STM    WFSA
          LDM    RTP1
          ZJN    WFS1        IF TO LOG TO SUPPORTIVE STATUS
          AOM    WFSA        NON REGISTER STATUS HAS ONE MORE HEADER WORD
          LDN    NRSP
          UJN    WFS2

*         READ FIRST WORD OF FAULT SYMPTOM CODE TO PRESERVE FIRST TWO BYTES.

 WFS1     LDN    SSBP        GET ADDRESS OF SCRATCH BUFFER
 WFS2     RJM    IDA
          CRDL   CM
          LDM    WFSA        SKIP HEADER WORDS
          RADL   CM
          LRD    CM+1
          ADC    RR
          CRML   FSCB,ON
          LDDL   T1          SET ELEMENT IDENTIFIER
          STML   FSCB+2

*         SET MODEL NUMBER.

          LDD    MD
          RJM    CDA         CONVERT TWO DIGITS TO ASCII
          STML   FSCB+3

*         WRITE FAULT SYMPTOM CODE TO SCRATCH SUPPORTIVE STATUS.

          LDN    2           SET NUMBER OF CM WORDS TO WRITE
          STD    T1
          LDDL   CM          LOAD ADDRESS OF SCRATCH BUFFER
          ADC    RR
          CWML   FSCB,T1     WRITE TO SCRATCH BUFFER
          UJP    WFSX        RETURN

 WFSA     CON    0
*         CTP$DFT_WRITE_FSC_TO_BUFFER.

*DECK DECK=CTP$DFT_ZERO_SUPPORTIVE_STATUS EXPAND=FALSE
          CTEXT  CTP$DFT ZERO SUPPORTIVE STATUS.
          SPACE  4,10
 QUAL$    IF     -DEF,QUAL$
          QUAL   CTPZSS
 QUAL$    ENDIF
          BASE   M
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 ZSS      SPACE  4,10
**        ZSS - ZERO SUPPORTIVE STATUS BUFFER.
*
*         EXIT   THE SCRATCH SUPPORTIVE STATUS BUFFER WILL BE ZEROED.
*
*         USES   CM - CM+3, W0 - W3.
*
*         CALLS  CLR, IDA, VCK.


 ZSS      SUBR               ENTRY/EXIT
          LDN    VER4
          RJM    VCK         CHECK VERSION OF THE CM INTERFACE
          MJP    ZSSX        IF INTERFACE LESS THAN VERSION 4
          LDM    RTP1        FLAG TO USE SUPPORTIVE STATUS OR NON REGISTER STATUS
          ZJN    ZSS1        IF SUPPORTIVE STATUS
          LDN    NRSP        ADDRESS OF SCRATCH NON REGISTER STATUS BUFFER
          UJN    ZSS2

 ZSS1     LDN    SSBP
 ZSS2     RJM    IDA         INDEX DFT ADDRESS
          CRDL   W0          SSB POINTER WORD
          LRD    W1
          LDD    W0
          ADC    RR
          CRDL   CM          (CM+3) = ELEMENT SIZE
          SODL   CM+3
          AODL   W0
          LDN    W4
          RJM    CLR         CLEAR W4 - W7
 ZSS3     LDDL   W0
          ADC    RR
          CWDL   W4          ZERO SUPPORTIVE STATUS BUFFER ENTRY
          AODL   W0
          SODL   CM+3
          PJN    ZSS3        IF MORE ENTRIES TO DO
          LJM    ZSSX        RETURN


          BASE   *
 QUAL$    IF     -DEF,QUAL$
          QUAL   *
 ZSS      EQU    /CTPZSS/ZSS
 QUAL$    ENDIF
          ENDX
*DECK DECK=CTP$MR_PROTOCOL_POSTPROCESS EXPAND=FALSE
          EJECT
*         CTEXT  CTP$MR_PROTOCOL_POSTPROCESS
*
*         THIS DECK DEFINES THE POSTPROCESSING PHASE OF
*         A MAINTENANCE CHANNEL OPERATION

 WCC1     RJM    CMI         CLEAR INTERLOCK

 WCC      SUBR
          FJM    *,MR        INSURE LAST WORD TAKEN
          ZJN    WCC1        IF OUTPUT COMPLETE
          LDN    DACI-DANE   60F - CH 17 INACTIVE
          UJN    SMI2        PROCESS FATAL MAINTENANCE ERROR

*         END    CTP$MR_PROTOCOL_POSTPROCESS
*DECK DECK=CTP$MR_PROTOCOL_POSTPROCESS_930 EXPAND=FALSE
          CTEXT  CTP$MR PROTOCOL POSTPROCESS 930.
          SPACE  4,10
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4,10
***       CTP$MR_PROTOCOL_POSTPROCESS_930.
*         G. J. FALCONER.    87/09/16.
          SPACE  4,10
***       THIS DECK CONTAINS MAINTENANCE REGISTER POSTPROCESSING CODE
*         UNIQUE TO S0/S0E MAINFRAMES.
 WCC      SPACE  4,15
**        WCC - WAIT FOR COMPLETE AND CHECK *SS*.
*
*         DUE TO THE PECULIARITIES OF THE S0/S0E *MAC* IT IS NECESSARY TO
*         WAIT FOR THE CHANNEL TO GO EMPTY, THEN READ *SS* IN ORDER TO
*         ENSURE THAT A MAINTENANCE REGISTER WRITE HAS SUCCESSFULLY
*         COMPLETED.
*
*         EXIT   TO *FMN* IF CH17 INACTIVE.
*
*         CALLS  CMI.


 WCC1     DCN    MR          ENSURE MAINT CHAN INACTIVE
          FNC    MRSS,MR     READ SS TO INSURE WRITE WORKED
          ACN    MR
          IAN    MR
          RJM    CMI         CLEAR INTERLOCK

 WCC      SUBR               ENTRY/EXIT
          FJM    *,MR        INSURE LAST WORD TAKEN
          ZJN    WCC1        IF OUTPUT COMPLETE
          LDN    DACI-DANE   60F - CH17 INACTIVE
          UJN    SMI2        PROCESS FATAL MAINTENANCE ERROR
          SPACE  4,10
          ENDX
*DECK DECK=CTP$MR_PROTOCOL_PREPROCESS EXPAND=FALSE
          CTEXT  CTP$MR PROTOCOL PREPROCESS.
          SPACE  4,10
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4,10
***       CTP$MR_PROTOCOL_PREPROCESS.
*         G. J. FALCONER.    87/08/25.
          SPACE  4,10
***              DEFINES THE MAIN ROUTINE USED TO ACCESS CYBER 180
*         MAINTENANCE REGISTERS.  TOGETHER WITH CODE IN THE APPROPRIATE
*         PREPROCESSING AND POSTPROCESSING COMMON DECKS, THIS CODE USES
*         THE PROTOCOL DEFINED FOR RESERVING AND RELEASING THE CHANNEL.
*         THE ROUTINES ARE DESIGNED FOR USE BY THE MACROS DEFINED IN
*         THE COMMON DECK *DSI$MAINTENANCE_REGISTER_MACROS*.
*         IF ADDITION ANALYSIS CODES ARE DEFINED FOR CH17 ERRORS,
*         CONSIDERATION SHOULD BE GIVEN TO UPDATING TABLE *TCHP*
*         IN CTP$CONSTRUCT_MESSAGE_IN_EICB.
 DCN*     SPACE  4,10
 DCN*     PPOP   4,7500      DEFINE *DCN**
 AMR      SPACE  4,10
**        AMR - ACCESS MAINTENANCE REGISTER.
*
*         ENTRY  (A) = FUNCTION TO ACCESS REGISTER.
*                (RN) = REGISTER NUMBER.
*
*         EXIT   (A) = 10.
*                MAINTENANCE CHANNEL IS ACTIVE.
*                TO *CMO* IF CHANNEL ERROR FLAG SET.
*                TO *FMN* IF CHANNEL GOES INACTIVE PREMATURELY.
*
*         CALLS  SMI.


 AMR      SUBR               ENTRY/EXIT
          RJM    SMI         GET MAINTENANCE CHANNEL
          FAN    MR
 AMR1     SFM    CMO,MR      IF CHANNEL ERROR FLAG SET
          AJM    AMR1,MR     IF FUNCTION NOT YET ACCEPTED
          ACN    MR
          LDDL   RN
          SHN    -10
          OAN    MR
          LDD    RN
          IJM    AMR2,MR     IF CHANNEL HAS GONE INACTIVE
          OAN    MR
          FJM    *,MR        WAIT FOR REGISTER NUMBER ACCEPTED
          DCN*   MR+40
          SFM    CMO,MR      IF CHANNEL ERROR FLAG SET
          ACN    MR
          LDN    10          SET EXPECTED REGISTER BYTE COUNT
          UJN    AMRX        RETURN

 AMR2     LDN    DACI-DANE   60F - CH 17 INACTIVE
          LJM    FMN         PROCESS FATAL MAINTENANCE REGISTER NON-RETRYABLE ERROR
          SPACE  4,10
          ENDX
*DECK DECK=CTP$MR_PROTOCOL_PREPROCESS_S1 EXPAND=FALSE
          EJECT
*         CTEXT  CTP$MR_PROTOCOL_PREPROCESS_S1
*
*         THIS DECK PROVIDES PREPROCESSING FOR ACCESSING THE MAINTENANCE
*         CHANNEL ON AN I1.
 MRA      SPACE  4,10
***              DEFINES SEVERAL ROUTINES USED IN ACCESSING THE
*         CYBER 180 MAINTENANCE REGISTERS.  THESE ROUTINES ENFORCE
*         THE PROTOCOL DEFINED FOR RESERVING AND RELEASING THE CHANNEL.
*         THE ROUTINES ARE DESIGNED FOR USE BY THE MACROS DEFINED IN
*         THE COMMON DECK *DSI$MAINTENANCE_REGISTER_MACROS*.
*         IF ADDITION ANALYSIS CODES ARE DEFINED FOR CH17 ERRORS,
*         CONSIDERATION SHOULD BE GIVEN TO UPDATING TABLE *TCHP*
*         IN CTP$CONSTRUCT_MESSAGE_IN_EICB.
 DCN*     SPACE  4,10
 DCN*     PPOP   4,7500      DEFINE *DCN**
 AMR      SPACE  4,10
**        AMR - ACCESS MAINTENANCE REGISTER.
*
*         ENTRY  (A) = FUNCTION TO ACCESS REGISTER.
*                (RN) = REGISTER NUMBER.
*
*         EXIT   (A) = 10.
*                MAINTENANCE CHANNEL IS ACTIVE.
*                TO *CMO* IF CHANNEL ERROR FLAG SET.
*                TO *FMN* IF CHANNEL GOES INACTIVE PREMATURELY.
*
*         CALLS  SMI.
*
*         TIMING S1CR MAC REQUIRES 9 TRIPS BETWEEN *ACN* AND *OAX*.


 AMR      SUBR               ENTRY/EXIT
          RJM    SMI         GET MAINTENANCE CHANNEL
          FAN    MR
 AMR1     SFM    CMO,MR      IF CHANNEL ERROR FLAG SET
          AJM    AMR1,MR     IF FUNCTION NOT YET ACCEPTED
          ACN    MR
          LDDL   RN
          SHN    -10
          OAN    MR
          LDD    RN
          IJM    AMR2,MR     IF CHANNEL HAS GONE INACTIVE
          OAN    MR
          FJM    *,MR        WAIT FOR REGISTER NUMBER ACCEPTED
          DCN*   MR+40
          SFM    CMO,MR      IF CHANNEL ERROR FLAG SET
          ACN    MR
          LDN    0           KLUDGE - S1CR MAC REQUIRES NINE TRIP DELAY
          RADL   RN          FROM *ACN* TO REGISTER OUTPUT VIA *OAN*/*OAM*
          LDN    10          SET EXPECTED REGISTER BYTE COUNT
          UJN    AMRX        RETURN

 AMR2     LDN    DACI-DANE   60F - CH 17 INACTIVE
          LJM    FMN         PROCESS FATAL MAINTENANCE REGISTER NON-RETRYABLE ERROR

*         END    CTP$MR_PROTOCOL_PREPROCESS_S1
*DECK DECK=CTP$MR_PROTOCOL_PROCESS EXPAND=FALSE
          CTEXT  CTP$MR PROTOCOL PROCESS.
          SPACE  4,10
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4,10
***       CTP$MR_PROTOCOL_PROCESS.
*         G. J. FALCONER.    87/08/25.
          SPACE  4,10
***       THIS DECK FORMS THE MAIN PROCESSING OF MAINTENANCE CHANNEL
*         OPERATIONS. THIS DECK HOUSES *CLI*, *CMI*, *CMO*, *RME*, *SLI*,
*         *FMN*, *SMI*, *RMR*.
 CLI      SPACE  4,10
**        CLI - CLEAR LONG TERM INTERLOCK.
*
*         ENTRY  (LOCK) = 0 IF LONG TERM INTERLOCK IS CLEAR.
*                       = 1 IF LONG TERM INTERLOCK IS SET.
*
*         EXIT   LONG TERM INTERLOCK ON THE MAINTENANCE CHANNEL
*                IS CLEARED.
*                TO *FMN* IF LONG TERM INTERLOCK WAS NOT SET.


 CLI1     CCF    *,MR        RELEASE CHANNEL

 CLI      SUBR               ENTRY/EXIT
          SOM    LOCK
          ZJN    CLI1        IF INTERLOCK WAS SET
          LDN    DAMI-DANE   604 - CH17 INTERLOCK ERROR
          UJN    FMN         PROCESS FATAL MAINTENANCE ERROR
 CMI      SPACE  4,10
**        CMI - CLEAR MAINTENANCE INTERLOCK.
*
*         ENTRY  (LOCK) = 0 IF LONG TERM INTERLOCK IS CLEAR.
*                       = 1 IF LONG TERM INTERLOCK IS SET.
*
*         EXIT   MAINTENANCE CHANNEL RELEASED (UNLESS LONG
*                TERM INTERLOCK WAS SET).
*                LOWER 12 BITS OF A RESTORED IF NO ERROR.
*                TO *RME* TO RETRY IF PARITY ERRORS PRESENT ON READ.
*                TO *FMN* IF NON-READ CHANNEL PARITY ERRORS PRESENT.


 CMI1     NJN    CMI2        IF LONG TERM INTERLOCK SET
          CCF    *,MR        RELEASE CHANNEL
 CMI2     LDC    **          RESTORE (A)
 CMIA     EQU    *-1

 CMI      SUBR               ENTRY/EXIT
          STM    CMIA
          LDM    LOCK

*         THERE MUST BE AT LEAST A 3 MICROSECOND DELAY BETWEEN THE
*         LAST I/O OPERATION PERFORMED ON CH 17 AND THE DCN.

          DCN*   MR+40       ENSURE MAINTENANCE CHANNEL INACTIVE
          CFM    CMI1,MR     IF ERROR FLAG CLEAR
*         UJN    CMO         CHECK MAINTENANCE REGISTER OPERATION

          ERRNZ  *-CMO       CODE ASSUMES CMO FOLLOWS CMI
 CMO      SPACE  4,10
**        CMO - CHECK MAINTENANCE REGISTER OPERATION.
*
*         ENTRY  PARITY ERROR HAS OCCURRED ON MAINTENANCE CHANNEL.
*                (SMIB) = LAST FUNCTION.
*
*         EXIT   TO *RME* TO SEE IF OPERATION MAY BE RETRIED ON A READ.
*                TO *FMN* TO HANDLE NON-RETRIABLE ERROR.


 CMO      BSS    0           ENTRY
          LDML   SMIB        CHECK TYPE OF LAST FUNCTION
          LPC    0#F0
          LMC    MRRD
          ZJP    RME         IF RETRY-ABLE MAINTENANCE ERROR
          LDN    DAMP-DANE   603 - CH17 PARITY ERROR
*         UJP    FMN         PROCESS FATAL MAINTENANCE ERROR
 FMN      SPACE  4,10
**        FMN - PROCESS FATAL MAINTENANCE REGISTER NON-RETRYABLE ERROR.
*
*         ENTRY  (A) = ANALYSIS CODE - 600(16).
*
*         EXIT   TO EXIT ADDRESS IF SUPPLIED.


 FMN      ADC    DANE        REMOVE BIAS
          STML   MRFE        SAVE ANALYSIS CODE
          LJM    *
 MRFN     EQU    *-1         FATAL ERROR EXIT ADDRESS
 SLI      SPACE  4,10
**        SLI - SET LONG TERM INTERLOCK.
*
*         ENTRY  (LOCK) = 0.
*
*         EXIT   MAINTENANCE CHANNEL FLAG SET.
*                (LOCK) = 1.
*                TO *FMN* IF LONG TERM INTERLOCK CONFLICT
*
*         CALLS  SMI.


 SLI      SUBR               ENTRY/EXIT
          RJM    SMI         GET INTERLOCK ON CHANNEL
          AOM    LOCK
          SBN    1
          ZJN    SLIX        IF INTERLOCK JUST SET
          CCF    *,MR        RELEASE CHANNEL
          LDN    DAMI-DANE   604 - CH17 INTERLOCK ERROR
 SLI1     UJN    FMN         PROCESS FATAL MAINTENANCE ERROR
 SMI      SPACE  4,10
**        SMI - SET MAINTENANCE INTERLOCK.
*
*         EXIT   MAINTENANCE CHANNEL OBTAINED.
*                WAIT FOREVER FOR CHANNEL FLAG TO CLEAR.
*                TO *FMN* IF CHANNEL ACTIVE.


 SMI3     SCF    SMI3,MR     IF MAINTENANCE CHANNEL NOT AVAILABLE

 SMI4     AJM    SMI1,MR     IF CHANNEL ACTIVE
          LDML   SMIB        RESTORE FUNCTION

 SMI      SUBR               ENTRY/EXIT
          STML   SMIB        SAVE FUNCTION
          LDC    5           SET RETRY COUNT
 SMIA     EQU    *-1
          STM    RMEA
          LDC    **
 LOCK     EQU    *-1
          NJN    SMI4        IF LONG TERM INTERLOCK SET
          UJN    SMI3        ATTEMPT INTERLOCK

 SMI1     LDN    DAMA-DANE   605 - CH17 ACTIVE
 SMI2     UJN    SLI1        PROCESS FATAL MAINTENANCE ERROR

 SMIB     CON    0
 RTRY     EQU    SMI4        RETRY ADDRESS
          QUAL   CTIMPP
 RMR      SPACE  4,10
**        RMR - READ MAINTENANCE REGISTER.
*
*         ENTRY  (A) = ELEMENT CODE.
*                (RN) = REGISTER NUMBER.
*                *RDATA - RDATA+7* NEEDS TO BE DEFINED.
*
*         EXIT   (RDATA - RDATA+7) IS REGISTER DATA IN BYTE FORMAT.
*                (A) = BYTE 7 OF REGISTER.


 RMR      SUBR               ENTRY/EXIT
          STD    EC          SAVE ELEMENT CODE
          READMR RDATA       READ REGISTER INTO RDATA
          LDM    RDATA+7     GET BYTE 7 OF REGISTER
          UJN    RMRX        RETURN

          QUAL   *
 RMR      EQU    /CTIMPP/RMR
          SPACE  4,10
          ENDX
*DECK DECK=CTP$MR_RETRY_OPERATION_FOR_DFT EXPAND=FALSE
*         CTEXT  CTP$MR_RETRY_OPERATION_FOR_DFT
 RME      SPACE  4,10
**        RME  - RETRY MAINTENANCE REGISTER READ PARITY ERROR.
*
*         ENTRY  (LOCK) = 0 IF LONG TERM INTERLOCK IS SET.
*                       = 1 IF LONG TERM INTERLOCK IS CLEAR.
*                AT *FME* TO FORCE ERROR PROCESSING.
*
*         EXIT   TO *RTRY* IF OPERATION CAN BE RETRIED.
*                TO EXIT ADDRESS, IF OPERATION COULD NOT BE RETRIED.


 RME      AOML   MRRC        EVERY TIME A RETRY IS PERFORMED BUMP CUMULATIVE COUNT
          SOM    RMEA        DECREMENT RETRY COUNT
          ZJN    FME         IF OPERATION CANNOT BE RETRIED
          DCN*   MR+40       ENSURE CHANNEL IS INACTIVE

*         AT THIS POINT WAIT APPROXIMATELY 100 MILLSECONDS FOR ANY POSSIBLE
*         TRANSIENTS TO SETTLE DOWN.

          LDN    0
          STML   ACTB1+2
          STML   TFLG        RESET TIMER FLAG
 RME1     RJM    TIM         TIME THE EVENT
          LDM    TFLG
          ZJN    RME1        IF EVENT HASNT HAPPENED YET
          LJM    RTRY        RETRY LAST OPERATION

 FME      DCN*   MR+40
          CCF    *,MR
          LDN    0           CLEAR LONG TERM INTERLOCK
          STM    LOCK
          LDC    DAMP        603 - CH17 PARITY ERROR
          STML   MRFE
          LJM    *           JUMP TO ERROR TERMINATION PROCESSOR
 MRFA     EQU    *-1         NON-FATAL ERROR EXIT ADDRESS

 RMEA     CON    5           RETRY COUNT FOR CHANNEL PARITY ERRORS
 MRRC     CON    0           MAINTENANCE REGISTER ERROR RETRY COUNT
 MRFE     CON    0           FATAL MAINTENACE ERROR

*         END    CTP$MR_RETRY_OPERATION_FOR_DFT

*DECK DECK=CTP$MR_RETRY_OPERATION_FOR_SCI EXPAND=FALSE
*         CTEXT  CTP$MR_RETRY_OPERATION_FOR_SCI
 RME      SPACE  4,10
**        RME  - RETRY MAINTENANCE REGISTER READ PARITY ERROR.
*
*         ENTRY  (LOCK) = 0 IF LONG TERM INTERLOCK IS SET.
*                       = 1 IF LONG TERM INTERLOCK IS CLEAR.
*                AT *FME* TO FORCE ERROR PROCESSING.
*
*         EXIT   TO *RTRY* IF OPERATION CAN BE RETRIED.
*                TO EXIT ADDRESS, IF OPERATION COULD NOT BE RETRIED.


 RME      AOML   MRRC        EVERY TIME A RETRY IS PERFORMED BUMP CUMULATIVE COUNT
          SOM    RMEA        DECREMENT RETRY COUNT
          ZJN    FME         IF OPERATION CANNOT BE RETRIED
          DCN*   MR+40       ENSURE CHANNEL IS INACTIVE
          LJM    RTRY        RETRY LAST OPERATION

 FME      DCN*   MR+40
          CCF    *,MR
          LDN    0           CLEAR LONG TERM INTERLOCK
          STM    LOCK
          LDC    DAMP        603 - CH17 PARITY ERROR
          STML   MRFE
          LJM    *           JUMP TO ERROR TERMINATION PROCESSOR
 MRFA     EQU    *-1         NON-FATAL ERROR EXIT ADDRESS

 RMEA     CON    5           RETRY COUNT FOR CHANNEL PARITY ERRORS
 MRRC     CON    0           MAINTENANCE REGISTER ERROR RETRY COUNT
 MRFE     CON    0           FATAL MAINTENACE ERROR

*         END    CTP$MR_RETRY_OPERATION_FOR_SCI
*DECK DECK=CTP$SCI_ADVANCE_LOAD_ADDRESS EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI ADVANCE LOAD ADDRESS.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO KEEP TRACK
*         OF MEMORY ALLOCATION AT DEADSTART TIME.
 ALA      SPACE  4,10
**        ALA - ADVANCE LOAD ADDRESS.
*
*         ENTRY  (A) = INCREMENT FOR LOAD ADDRESS.
*
*         EXIT   (LA - LA+1) INCREMENTED.
*                R-REGISTER = OLD LOAD ADDRESS.


 ALA      SUBR               ENTRY/EXIT
          LRD    LA
          ADN    77
          SHN    -6
          RAD    LA+1
          SHN    -14
          RAD    LA
          UJN    ALAX        RETURN

*         ENDX   CTP$SCI ADVANCE LOAD ADDRESS.
*DECK DECK=CTP$SCI_BUILD_HARDWARE_REG EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI BUILD HARDWARE REG.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO SET UP
*         THE HARDWARE REGISTERS FOR THE INITIAL EXCHANGE PACKAGE
*         AT DEADSTART TIME.
 BHR      SPACE  4,10
**        BHR - BUILD HARDWARE REGISTERS.
*
*         ENTRY  (LA - LA+1) = PAGE TABLE ADDRESS.
*                (BL - BL+1) = NOS/VE LOAD ADDRESS.
*                (HPSM) = PAGE SIZE MASK.
*                (HPTL) = PAGE TABLE LENGTH.
*                (MBUF) = CLEARED.
*
*         EXIT   (*HDWR* IN *SSR*) UPDATED.


 BHR      SUBR               ENTRY/EXIT
          LDD    BL          BUILD PAGE TABLE ADDRESS
          SHN    5-0
          STML   MBUF+0*4+2
          LDD    BL+1
          SHN    0-7
          RAML   MBUF+0*4+2
          LDD    BL+1
          SHN    20-7
          SCN    7
          STML   MBUF+0*4+3
          LDD    LA          BUILD PAGE TABLE ADDRESS
          SHN    5-0
          STML   MBUF+1*4+2
          LDD    LA+1
          SHN    0-7
          RAML   MBUF+1*4+2
          LDD    LA+1
          SHN    20-7
          SCN    7
          STML   MBUF+1*4+3
          LDML   HPTL        FORM PAGE TABLE LENGTH
          SHN    -3
          SBN    1
          STML   MBUF+2*4+3
          LDC    0#7F        FORM PAGE SIZE MASK
          SBM    HPSM
          STML   MBUF+3*4+3
          LDN    4           SET REGISTER COUNT
          STD    T4
          SSRE   HDWR        FIND HARDWARE REGISTER BLOCK
          CWML   BHRA,ON     STORE REGISTER NUMBERS
          CWML   MBUF,T4     WRITE REGISTER VALUES
          LJM    BHRX        RETURN

 BHRA     CON    0#41,0#48,0#49,0#4A

*         ENDX   CTP$SCI BUILD HARDWARE REG.

*DECK DECK=CTP$SCI_BUILD_PAGE_TABLE EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI BUILD PAGE TABLE.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO BUILD
*         THE INITIAL PAGE TABLE AT DEADSTART TIME.
 BPT      SPACE  4,10
**        BPT - BUILD PAGE TABLE.
*
*         ENTRY  (LA - LA+1) = PAGE TABLE ADDRESS.
*                (HPTL) = PAGE TABLE LENGTH.
*
*         EXIT   PAGE TABLE BUILT.
*                (BL - BL+1) = BOOT LOAD ADDRESS.
*
*         USES   BL, T0, CN - CN+3.
*
*         CALLS  CCM, SPB.


 BPT      SUBR               ENTRY/EXIT
          LRD    LA
          RJM    SPB         SET PP BOUNDS
          SRD    CN+1
          LDN    0
          STD    CN

*         ZERO OUT THE PAGE TABLE.  THE PAGE TABLE MAY EXCEED THE
*         MAXIMUM VALUE OF THE *A* REGISTER SO IT HAS TO BE CLEARED
*         IN BLOCKS.

          LDML   HPTL        PAGE TABLE LENGTH/100B IN WORDS
          STDL   BL          SAVE PAGE TABLE LENGTH
 BPT5     ADC    -4000B
          MJN    BPT10       IF LESS THAN BLOCK SIZE
          STDL   BL          SAVE REMAINING PAGE TABLE BLOCK SIZE
          LDC    4000B
          UJN    BPT15       CLEAR PAGE TABLE BLOCK

 BPT10    LDDL   BL          REMAINING BLOCK OF PAGE TABLE TO CLEAR
          STDL   T0
          LDN    0           SET PAGE TABLE CLEARED
          STDL   BL
          LDDL   T0
 BPT15    SHN    6
          RJM    CCM         ZERO OUT PAGE TABLE
          LDDL   BL          REMAINING PAGE TABLE BLOCKS TO CLEAR
          NJN    BPT5        IF PAGE TABLE NOT CLEARED
          LDML   HPTL        ADVANCE LOAD ADDRESS BY PAGE TABLE LENGTH
          ADD    LA+1
          STD    BL+1
          SHN    -14
          ADD    LA
          STD    BL
          LDD    LA+1        STORE PAGE TABLE PAGE 0 PAGE ADDRESS
          STM    BPTA+3
          LDD    LA
          SHN    0-4
          STML   BPTA+2
          LDD    LA
          LPN    17
          SHN    20-4
          RAML   BPTA+3
          LDD    BL+1        STORE BOOT PAGE 0 PAGE ADDRESS
          STM    BPTB+3
          LDD    BL
          SHN    0-4
          STML   BPTB+2
          LDD    BL
          LPN    17
          SHN    20-4
          RAML   BPTB+3
          LRD    LA
          LDC    RR+2
          CWML   BPTA,ON     WRITE PAGE TABLE ENTRY FOR PAGE TABLE
          ADN    1
          CWML   BPTB,ON     WRITE PAGE TABLE ENTRY FOR BOOT
          LJM    BPTX        RETURN

 BPTA     VFD    1/1,1/1,1/0,1/0,16/1,22/0,22/0
 BPTB     VFD    1/1,1/1,1/0,1/0,16/2,22/0,22/0

*         ENDX   CTP$SCI BUILD PAGE TABLE.

*DECK DECK=CTP$SCI_CLEAR_CENTRAL_MEMORY EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI CLEAR CENTRAL MEMORY.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO CLEAR A
*         BLOCK OF CENTRAL MEMORY.
 CCM      SPACE  4,10
**        CCM - CLEAR CENTRAL MEMORY BLOCK.
*
*         ENTRY  (A) = NUMBER OF WORDS TO CLEAR.
*                (CN - CN+2) = R-POINTER TO AREA TO CLEAR.
*
*         USES   T1, T2, T3, CN - CN+2.
*
*         EXIT   (CN - CN+2) = R-POINTER UPDATED FOR NEXT BLOCK TO CLEAR.
*
*         CALLS  ZPB.


 CCM5     LDDL   CN          FORM ADDRESS TO BLOCK TO CLEAR
          LRD    CN+1
          LMC    RR
          CWML   MBUF,T1     CLEAR MEMORY BLOCK
          AOD    CN+2        INCREMENT MEMORY BLOCK BY 100(8) WORDS
          SHN    -14
          RAD    CN+1
          SOD    T2          BLOCKS REMAINING TO BE CLEARED
          MJN    CCMX        IF ALL DATA CLEARED
 CCM10    NJN    CCM5        IF MORE BLOCKS TO BE CLEARED
          LDD    T3          SET LENGTH OF LAST BLOCK
          STD    T1
          NJN    CCM5        IF PARTIAL LAST BLOCK TO BE CLEARED

 CCM      SUBR               ENTRY/EXIT
          SHN    22-6
          STD    T2          SAVE NUMBER OF 100 WORD BLOCKS
          SHN    -14
          STD    T3          SAVE NUMBER OF WORDS TO CLEAR IN LAST BLOCK
          LDC    100
          RJM    ZPB         ZERO PP BUFFER
          LDD    T2
          UJN    CCM10       ENTER CLEAR LOOP

*         ENDX   CTP$SCI CLEAR CENTRAL MEMORY.
*DECK DECK=CTP$SCI_COMPRESS_PAGE_TABLE EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI COMPRESS PAGE TABLE.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO CREATE
*         THE PAGE TABLE MODIFY BIT MAP AT DEADSTART TIME.
 CPT      SPACE  4,15
**        CPT - COMPRESS PAGE TABLE.
*
*         SCANS THE PAGE TABLE AND SAVES THE MODIFY BITS IN THE PAGE TABLE
*         MODIFY BIT MAP.  THE PAGE TABLE MODIFY BIT MAP IS SAVED AT THE
*         LOCATION SPECIFIED BY THE *RIHT* SSR ENTRY, ONE BIT FOR EACH PAGE
*         TABLE ENTRY.
*
*         ENTRY  (LA - LA+1) = R-REGISTER ADDRESS OF THE PAGE TABLE.
*                (HPTL) = PAGE TABLE LENGTH IN WORDS/100(8).
*
*         EXIT   TO *AAC* IF *RIHT* IS TOO SMALL.
*
*         USES   CM - CM+3, CN - CN+1, T1 - T4, W0 - W7.
*
*         CALLS  SPB.


 CPT      SUBR               ENTRY/EXIT
          SSRE   RIHT        GET R-POINTER FOR PAGE TABLE MODIFY BIT MAP
          CRDL   CM
          RJM    SPB         SET PP BOUNDS
          LDML   HPTL
          STDL   T4          PAGE TABLE LENGTH IN WORDS/64
          SBDL   CM+3        CHECK IF LONG ENOUGH
          ZJN    CPT5        IF PAGE TABLE MODIFY BIT MAP BIG ENOUGH
          MJN    CPT5        IF PAGE TABLE MODIFY BIT MAP BIG ENOUGH
          LDC    DASR        615 - SCI RIHT TOO SMALL
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR

*         SCAN THE PAGE TABLE 64 ENTRIES AT A TIME AND SAVE THE
*         MODIFY BITS FOR EACH ENTRY.

 CPT5     LRD    LA
          SRD    CN          R-REGISTER VALUE OF PAGE TABLE
 CPT10    LDN    63D
          STD    T3          INDEX OF WORD IN 64 WORD BLOCK
          LDN    3
          STD    T2          INDEX OF 16 WORD BLOCK IN 64 WORD BLOCK

*         (W4 - W7) = WORDS TO ASSEMBLE MODIFY BITS IN.
*         (CM - CM+3) = R-POINTER FOR PAGE TABLE MODIFY BIT MAP.
*         (CN - CN+1) = R-REGISTER VALUE OF PAGE TABLE.

 CPT15    LDN    0
          STML   W4,T2       CLEAR WORD OF PAGE TABLE BIT MAP
          LDC    SHNI+17D-12D+1
          STM    CPTA        INITIALIZE SHIFT INSTRUCTION
          LDN    15D
          STD    T1          INDEX OF WORD IN 16 WORD BLOCK
          LRD    CN

*         SAVE MODIFY BITS FOR A 16 WORD BLOCK OF THE PAGE TABLE.

 CPT20    LDD    T3
          LMC    RR
          CRDL   W0          PAGE TABLE ENTRY
          LDDL   W0
          LPC    10000       MODIFY BIT
 CPTA     SHN    17D-12D+1   POSITION MODIFY BIT FOR PAGE TABLE BIT MAP
          RAML   W4,T2
          AOM    CPTA        INCREMENT SHIFT COUNT
          SOD    T3          DECREMENT 64 WORD BLOCK COUNT
          SOD    T1          DECREMENT INDEX WITHIN 16 WORD BLOCK
          PJN    CPT20       IF HAVE NOT PROCESSED 16 PAGE TABLE ENTRIES
          SOD    T2          DECREMENT 16 WORD BLOCK INDEX
          PJN    CPT15       IF HAVE NOT PROCESSED 64 PAGE TABLE ENTRIES

*         SAVE THE 64 MODIFY BITS THAT HAVE BEEN ASSEMBLED IN THE PAGE
*         TABLE BIT MAP.

          LRD    CM+1
          LDDL   CM          WORD OFFSET
          LMC    RR
          CWDL   W4          SAVE MODIFY BITS IN PAGE TABLE BIT MAP
          AODL   CM          INCREMENT WORD OFFSET
          AOD    CN+1        INCREMENT PAGE TABLE R-REGISTER VALUE
          SHN    -12D
          RAD    CN
          LRD    CN
          SODL   T4          DECREMENT 64 WORD BLOCK COUNT
          NJP    CPT10       IF PAGE TABLE SCAN NOT COMPLETE
          LJM    CPTX        RETURN

*         ENDX   CTP$SCI COMPRESS PAGE TABLE.

*DECK DECK=CTP$SCI_COPY_CM_DATA EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI COPY CM DATA.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO COPY A
*         BLOCK OF CM DATA FROM ONE PLACE TO ANOTHER.
 CPY      SPACE  4,10
**        CPY - COPY CM DATA.
*
*         ENTRY  (A) = LENGTH OF COPY.
*                (CN - CN+2) = R-POINTER TO SOURCE DATA.
*                (CM - CM+2) = R-POINTER TO DESTINATION.
*
*         EXIT   MEMORY COPIED.
*
*         USES   T1, T2, T3, CN - CN+3, CM - CM+2, MBUF - MBUF+3.


 CPY5     LDDL   CN          SET SOURCE ADDRESS
          LRD    CN+1
          LMC    RR
          CRML   MBUF,T1     READ SOURCE DATA
          LDDL   CM          SET DESTINATION ADDRESS
          LRD    CM+1
          LMC    RR
          CWML   MBUF,T1     WRITE DATA TO DESTINATION
          AOD    CN+2        INCREMENT SOURCE ADDRESS BY 100(8) WORDS
          SHN    -14
          RAD    CN+1
          AOD    CM+2        INCREMENT DESTINATION ADDRESS BY 100(8) WORDS
          SHN    -14
          RAD    CM+1
          SOD    T2          DATA REMAINING TO BE COPIED
          MJN    CPYX        IF ALL DATA COPIED
 CPY10    NJN    CPY5        IF MORE 100 WORD BLOCKS TO COPY
          LDD    T3          SET LENGTH OF LAST BLOCK
          STD    T1
          NJN    CPY5        IF PARTIAL LAST BLOCK TO COPY

 CPY      SUBR               ENTRY/EXIT
          SHN    22-6
          STD    T2          SAVE NUMBER OF 100 WORD BLOCKS
          SHN    -14
          STD    T3          SAVE NUMBER OF WORDS TO COPY IN LAST BLOCK
          LDC    100         COPY BLOCKS OF 100 WORDS
          STD    T1
          LDD    T2
          UJN    CPY10       ENTER COPY LOOP

*         ENDX   CTP$SCI COPY CM DATA.

*DECK DECK=CTP$SCI_COPY_TO_SAVE_AREA EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI COPY TO SAVE AREA.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO SAVE THE
*         MEMORY WHERE VCB WILL BE LOADED.
 CTS      SPACE  4,20
**        CTS - COPY TO SAVE AREA.
*
*         COPIES MEMORY WHERE THE CP BOOT IS TO BE LOADED TO THE SAVE AREA
*         AND COMPRESSES THE PAGE TABLE.  THE CP BOOT IS LOADED STARTING AT
*         THE PAGE TABLE ADDRESS.  COMPRESSING THE PAGE TABLE SAVES THE
*         NECESSARY INFORMATION FROM IT (MODIFY BITS) TO RECONSTRUCT IT
*         DURING THE RECOVERY PROCESS.  THE AMOUNT OF MEMORY TO COPY IS
*         DETERMINED BY THE LENGTH OF THE SAVE AREA.
*
*         ENTRY  (LA - LA+1) = R-REGISTER VALUE OF THE PAGE TABLE.
*
*         USES   T4, CM - CM+3, CN - CN+3.
*
*         CALLS  CPT, CPY, INS.
*
*         MACROS SSRE.


 CTS      SUBR               ENTRY/EXIT
          SSRE   IMGS        FETCH IMAGE STATUS
          LDDL   W5
          SBN    1
          PJN    CTSX        IF COPY ALREADY DONE
          RJM    CPT         COMPRESS THE PAGE TABLE
          SSRE   MEMB        FETCH BOOT MEMORY BOUNDS, DEFINES THE SAVE AREA
          CRDL   CM
          LDD    CM+2        GET COPY LENGTH/100
          SHN    12
          ADD    CM+3
          SHN    -11
          STD    T4          COUNT OF 1000 100 WORD BLOCKS TO MOVE
          LDN    0
          LRD    LA          SET UP R-POINTER FOR COPY SOURCE
          SRD    CN+1
          STD    CN
          LRD    CM          COPY DESTINATION
          SRD    CM+1
          STD    CM
          LDML   HPTL        INCREMENT PAST THE PAGE TABLE
          RAD    CN+2
          SHN    -12D
          RAD    CN+1
          LDD    CM+3        REMAINING BLOCK COUNT
          LPC    777
          SHN    6
 CTS5     RJM    CPY         COPY MEMORY TO THE SAVE AREA
          SOD    T4
          MJN    CTS10       IF ENOUGH MEMORY HAS BEEN COPIED
          LDC    100000
          UJN    CTS5        COPY ANOTHER 1000 100 WORD BLOCKS

 CTS10    SSRE   IMGS        UPDATE IMAGE STATUS
          LDN    1           RECORD THAT THE SAVE AREA HAS BEEN COPIED
          STD    W5
          LDDL   W1
          RJM    INS
          CWDL   W2          UPDATE IMGS FLAG
          LJM    CTSX        RETURN

*         ENDX   CTP$SCI COPY TO SAVE AREA.

*DECK DECK=CTP$SCI_CREATE_SSR_CHECKSUM EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI CREATE SSR CHECKSUM.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO CREATE A
*         CHECKSUM OF THE SSR DIRECTORY.
 CSC      SPACE  4,20
**        CSC - CREATE SSR CHECKSUM.
*
*         THIS ROUTINE CREATES A NEW SSR CHECKSUM FROM THE SSR AS IT EXISTS IN
*         MEMORY.  IT ALSO SAVES THE PREVIOUS CHECKSUM FOUND IN SSR ENTRY
*         *SCKS*.  IF THE *SCKS* ENTRY IS NOT FOUND, THEN *SCI* MUST RELOAD THE
*         SSR.
*
*         THE SSR CHECKSUM IS CREATED BY ADDING THE LEFT TWO BYTES OF EACH WORD
*         IN THE SSR DIRECTORY.  THE RESULT IS A 16 BIT CHECKSUM.
*
*         EXIT   (T3) = NEWLY CREATED SSR CHECKSUM.
*                (W5) = PREVIOUS SSR CHECKSUM FROM THE *SCKS* SSR ENTRY.
*                (T4) = 0 IF *SCKS* SSR ENTRY NOT FOUND.
*
*         USES   CN - CN+3, W0 - W0+3.
*
*         CALLS  SSR.


 CSC      SUBR               ENTRY/EXIT
          RJM    SSR         SET UP SSR ADDRESS
          LDM    SAAO        READ SSR FIRST WORD
          ADC    RR
          CRDL   W0          (W0+2) = DIRECTORY LENGTH
          LDN    0           INITIALIZE CHECKSUM
          STD    T3
          STD    T4          PRESET *SCKS* ENTRY NOT FOUND
 CSC5     SOD    W0+2        DECREMENT WORD COUNT
          MJN    CSCX        IF END OF DIRECTORY
          ADC    RR
          CRDL   CN
          LDDL   CN          ADD THIS DIRECTORY ENTRY TO CHECKSUM
          ADDL   CN+1
          RADL   T3
          LDDL   CN          CHECK IF *SCKS* ENTRY
          LMC    2RSC
          ADDL   CN+1
          LMC    2RKS
          NJN    CSC5        IF NOT *SCKS* ENTRY
          AOD    T4          SET *SCKS* ENTRY FOUND FLAG
          LDDL   CN+3        SAVE PREVIOUS SSR CHECKSUM
          STDL   W5
          UJN    CSC5        CONTINUE

*         ENDX   CTP$SCI CREATE SSR CHECKSUM.
*DECK DECK=CTP$SCI_DELAY_ROUTINE EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI DELAY ROUTINE.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO DELAY A
*         SPECIFIED NUMBER OF MILLISECONDS.
 DLY      SPACE  4,10
**        DLY - DELAY FOR (A) MILLISECONDS.
*
*         ENTRY  (A) = NUMBER OF MILLISECONDS TO DELAY.
*
*         USES   T0.


 DLY      SUBR               ENTRY/EXIT
          STD    T0
 DLY1     IAN    14          INPUT REAL-TIME CLOCK
          LPC    1024D-1     EXTRACT RANGE OF 0 .. 1023 MILLISECONDS
          SBM    DLYA
          PJN    DLY2        IF LESS THAN 1024 MICROSECONDS ELAPSED
          RAM    DLYA        UPDATE BASE TIME
          SOD    T0          DECREMENT MILLISECOND COUNTER
          ZJN    DLYX        IF DELAY EXPIRED
          UJN    DLY1        LOOP TILL DELAY EXPIRED

 DLY2     RAM    DLYA        UPDATE BASE TIME
          UJN    DLY1        LOOP

 DLYA     BSS    1

*         ENDX   CTP$SCI DELAY ROUTINE
*DECK DECK=CTP$SCI_FETCH_CM_BOUND_VALUES EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI FETCH CM BOUND VALUES.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO FETCH THE
*         NOS/VE MEMORY BOUND VALUES FROM THE EICB.
 FMV      SPACE  4,10
**        FMV - FETCH MEMORY VALUES FROM EI CONTROL BLOCK.
*
*         EXIT   (CM - CM+1) = CURRENT LOAD ADDRESS IN R-REGISTER FORMAT.
*                (CM+2 - CM+3) = CURRENT LWA OF USABLE MEMORY IN R
*                                 REGISTER FORMAT.
*
*         USES   CM - CM+3, CN - CN+3.
*
*         CALLS  IIB.


 FMV      SUBR               ENTRY/EXIT
          LDN    D7CM+1
          RJM    IIB
          CRDL   CN

*         CONVERT THE MEMORY VALUES IN THE EICB INTO R-REGISTER FORMAT.
*         THE VALUES IN THE EICB ARE WORD ADDRESSES/1000(8) AND 16 BITS
*         PER PPU WORD.  CONVERT INTO WORD ADDRESSES/100(8) AND 12 BITS
*         PER PPU WORD.  CONVERT LAST WORD ADDRESS.

          LDD    CN+3        LOW ORDER 12 BITS OF LWA
          SHN    3           LWA * 100(8)
          STD    CM+3        SSSSSSSSS000
          LDDL   CN+3
          SHN    0-11        7 BITS OF HIGH ORDER 12 BITS OF LWA
          STD    CM+2        00000SSSSSSS
          LDD    CN+2        OTHER 5 BITS OF HIGH ORDER 12 BITS OF LWA
          LPN    37
          SHN    7-0
          RAD    CM+2        SSSSSSSSSSSS, HIGH ORDER 12 BITS OF LWA

*         CONVERT NOS/VE FWA.

          LDDL   CN+2        GET LOW ORDER 11 BITS OF FWA
          SHN    3-10
          SCN    7           FWA * 100(8)
          STD    CM+1        0LLLLLLLL000
          LDD    CN+1        GET OTHER LOW ORDER BIT OF FWA
          LPN    1
          SHN    13-0
          RAD    CM+1        LLLLLLLLL000
          LDDL   CN+1        HIGH ORDER 12 BITS OF FWA
          SHN    0-1
          STD    CM          LLLLLLLLLLLL
          UJN    FMVX        RETURN

*         ENDX   CTP$SCI FETCH CM BOUND VALUES.
*DECK DECK=CTP$SCI_INCREMENT_DFT_BUFFER EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI INCREMENT DFT BUFFER.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO RETRIEVE
*         THE ADDRESS FOR THE DFT BUFFER.
 IDT      SPACE  4,10
**        IDT - INCREMENT DFT BUFFER.
*
*         ENTRY  (A) = OFFSET FROM DFT BUFFER.
*
*         EXIT   (A - R-REGISTER) = ADDRESS OF DESIRED WORD.


 IDT      SUBR               ENTRY/EXIT
          ADM    DFTO        ADD IN OFFSET TO DFT BUFFER
          LMC    RR
          LRD    DP
          UJN    IDTX        RETURN

*         ENDX   CTP$SCI INCREMENT DFT BUFFER.

*DECK DECK=CTP$SCI_INCREMENT_DFT_VE_BLOCK EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI INCREMENT DFT VE BLOCK.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO RETRIEVE
*         THE ADDRESS FOR THE DFT VE REQUEST BLOCK.
 IVB      SPACE  4,10
**        IVB - INCREMENT DFT NOS/VE BLOCK.
*
*         ENTRY  (A) = OFFSET FROM DFT NOS/VE BLOCK.
*
*         EXIT   (A - R-REGISTER) = ADDRESS OF DESIRED WORD.


 IVB      SUBR               ENTRY/EXIT
          ADD    VP
          LMC    RR
          LRD    VP+1
          UJN    IVBX        RETURN

*         ENDX   CTP$SCI INCREMENT DFT VE BLOCK.

*DECK DECK=CTP$SCI_ISSUE_DFT_REQUEST EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI ISSUE DFT REQUEST.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO ISSUE A
*         REQUEST TO DFT.
 IDR      SPACE  4,15
**        IDR - ISSUE DFT REQUEST.
*
*         ENTRY  (A) = PARAMETER FOR DFT.
*                (VP - VP+3) = DFT REQUEST POINTER.
*                (IDRB) CHANGED TO *INPN* INSTRUCTION IF THETA E MAINFRAME.
*
*         EXIT   REQUEST ISSUED TO DFT.
*                (A) = DFT RESPONSE CODE.
*
*         USES   CM - CM+3.
*
*         CALLS  IVB, SPB.


 IDR      SUBR               ENTRY/EXIT
          STDL   CM          SAVE PARAMETER WORD
          LRD    VP+1
          RJM    SPB         SET PP BOUNDARY FOR NOS/VE REQUEST BLOCK
          LDD    VP+3
          RJM    IVB         INDEX TO VPB BLOCK
          CWDL   CM          WRITE DFT REQUEST
          STDL   CM
          ADN    1
          CWML   IDRA,ON     WRITE ADDITIONAL PARAMETERS
          SRD    CM+1        BUILD REQUEST POINTER
          LDN    2
          STD    CM+3
          LDN    0
          RJM    IVB         INDEX NOS/VE BLOCK
          CWDL   CM          WRITE DFT REQUEST POINTER

*         ON A THETA E MAINFRAME, THE SERVICE PROCESSOR *DFT* MUST BE TOLD
*         THAT THERE IS A *DFT* REQUEST PENDING.  THIS IS ACCOMPLISHED BY
*         SENDING AN INTERRUPT TO IOU0.

          PSN
 IDRB     EQU    *-1
*         INPN   2           (INTERRUPT IOU0 ON THETA E)
 IDR5     LDD    VP+3        INDEX TO VPB REQUEST
          RJM    IVB
          CRDL   W0          READ STATUS WORD
          LDDL   W0
          SHN    -10
          ZJN    IDR5        IF NOT COMPLETE
          UJN    IDRX        RETURN

 IDRA     CON    0,0,0,0

*         ENDX   CTP$SCI ISSUE DFT REQUEST.
*DECK DECK=CTP$SCI_LOAD_CIP_PROGRAM EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI VPB LOAD CIP PROGRAM.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO SET UP A DFT
*         REQUEST TO LOAD A CIP PROGRAM.
 LCP      SPACE  4,15
**        LCP - LOAD CIP PROGRAM.
*
*         ENTRY  (A) = NAME OF PROGRAM TO LOAD.
*                (R-REGISTER) = ADDRESS TO LOAD TO.
*
*         EXIT   PROGRAM LOADED.
*                (A) = DFT RESPONSE CODE.
*
*         USES   CM - CM+3.
*
*         CALLS  IDR.


 LCP      SUBR               ENTRY/EXIT
          SHN    22-6
          STM    IDRA
          SHN    -6
          SCN    77
          STM    IDRA+1
          SRD    CM+2
          LDN    0
          STD    CM+1
          LDN    FCD         FETCH CIP DATA
          RJM    IDR         ISSUE DFT REQUEST
          UJN    LCPX        RETURN

*         ENDX   CTP$SCI VPB LOAD CIP PROGRAM.
*DECK DECK=CTP$SCI_MDD_DFT_CMDS_COMMON EXPAND=FALSE
          CTEXT  CTP$SCI MDD DFT CMDS COMMON
          SPACE  4,10
          BASE   MIXED
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 FDP      SPACE  4,10
**        FDP - FIND DFT POINTER.
*
*         EXIT   (A) = 0, IF NO *DFT* BLOCK.
*                SEE ALSO *TDH* EXIT CONDITIONS.
*
*         USES   DP - DP+1, W0 - W3.
*
*         CALLS  IIB, PIB, TDH.


 FDP20    LDN    0           INDICATE NO DFT BLOCK YET

 FDP      SUBR               ENTRY/EXIT
          LDM    DFTO        TEST IF DFT POINTER SET UP
          ADDL   DP
          ADDL   DP+1
          NJN    FDP10       IF DFT POINTER ALREADY SET
          RJM    PIB         PRESET EICB POINTER
          LDDL   W2          CHECK FOR VALID POINTER
          NJN    FDP20       IF POINTER INVALID (PROBABLY FFFF..FFFF)
          LDDL   W3
          ZJN    FDPX        IF POINTER INVALID (ZERO)
          LDK    DSCM+3      GET POINTER TO THE DFT BLOCK
          RJM    IIB
          CRDL   W0          READ IN THE R-REGISTER POINTER
          LDDL   W0          RETRIEVE DIRECT CELL CONTENTS
          LPC    7777        LEFT 4 BITS MAY BE SET ON A C180-994
          STML   DFTO
          LRD    W1          SAVE R-REGISTER
          SRD    DP
 FDP10    LRD    DP          POINT TO DFT HEADER
          LDML   DFTO
          RJM    TDH         TEST DFT HEADER
          UJN    FDPX        RETURN
 LRR      SPACE  4,10
**        LRR - LOAD R-REGISTER.
*
*         ENTRY  (MDMT+RRUP.) = UPPER R-REGISTER.
*                (MDMT+RRLW.) = LOWER R-REGISTER.
*
*         EXIT   (R-REGISTER) LOADED.
*
*         USES   T1, T2.


 LRR      SUBR               ENTRY/EXIT
          LDM    MDMT+RRUP.
          STD    T1
          LDM    MDMT+RRLW.
          STD    T2
          LRD    T1
          UJN    LRRX        RETURN
 SMA      SPACE  4,10
**        SMA - SET MEMORY ADDRESS.
*
*         ENTRY  (A, R) = ADDRESS OF BUFFER.
*
*         EXIT   (VAL1+1 - VAL1+3) = ADDRESS OF BUFFER.
*
*         USES   T0 - T2.


 SMA      SUBR               ENTRY/EXIT
          STDL   T0          SAVE OFFSET
          SRD    T1          SAVE R-REGISTER
          LDD    T1
          STM    MDMT+RRUP.  RESTORE R-REGISTER
          LDD    T2          LOW ORDER R-REGISTER
          STM    MDMT+RRLW.
          SHN    6
          ADDL   T0          ADD IN A REGISTER
          STM    VAL1+3      SAVE VALUE
          SHN    -14         SHIFT OF BITS STORED
          STD    T0
          LDD    T1          HIGH ORDER R-REGISTER
          SHN    6
          ADD    T0
          STM    VAL1+2
          SHN    -14         SHIFT OFF BITS STORED
          STM    VAL1+1
          UJN    SMAX        RETURN
 TDH      SPACE  4,15
**        TDH - TEST DFT HEADER.
*
*         ENTRY  (R-REGISTER) SET UP FOR DFT CONTROL WORD.
*
*         EXIT   (A) = 0, IF NO DFT YET.
*                    = 1, IF DFT REJECTED.
*                    = 2, IF DFT VERIFIED.
*                (W0 - W3) = *DFT* HEADER.
*
*         USES   M2, W0 - W3.
*
*         CALLS  SMA.


 TDH10    AOD    M2          SET THAT DFT VERIFIED
 TDH20    AOD    M2          SET THAT DFT REJECTED

 TDH      SUBR               ENTRY/EXIT
          RJM    SMA         SET MEMORY ADDRESS
          LDN    0           INITIALIZE FLAG
          STD    M2
          LDM    DFTO        SET UP A FOR READ
          LMC    RR          ACTIVATE R-REGISTER
          CRDL   W0
          LDD    W0+DHFLG    TEST VERIFIED BIT
          LPC    300B        VERIFIED OR REJECTED BITS
          ZJN    TDHX        IF NEITHER SET
          LPC    200B
          ZJN    TDH20       IF NOT VERIFIED
          UJN    TDH10       EVERYTHING CHECKS


          BASE   *
          ENDX
*DECK DECK=CTP$SCI_MOVE_AND_COMPLETE_SSR EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI MOVE AND COMPLETE SSR.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO MOVE THE
*         SSR FROM ITS TEMPORARY LOCATION TO ITS PERMANENT LOCATION
*         AND SET THE SSR POINTER INTO THE EICB.
 MCS      SPACE  4,15
**        MCS - MOVE AND COMPLETE SSR.
*
*         ENTRY  (LA - LA+1) = R-REGISTER OF ADDRESS OF TEMPORARY SSR LOCATION.
*                (SZ - SZ+1) = CURRENT MEMORY SIZE.
*
*         EXIT   (SZ - SZ+1) = UPDATED MEMORY SIZE.
*                SSR POINTER SET IN THE EICB.
*                SSR MOVED TO PERMANENT LOCATION.
*
*         USES   CM - CM+3, CN - CN+3, W0 - W5.
*
*         CALLS  CCM, CPY, CSC, IIB, INS, SPB.
*
*         MACROS SSRE.


*         DETERMINE MEMORY ADDRESS WHERE THE SSR WILL RESIDE.

 MCS      SUBR               ENTRY/EXIT
          LDC    RR+1
          LRD    LA
          CRDL   W0          READ SSR DIRECTORY HEADER
          LDC    1000        NOS STACK FRAME AREA
          ADDL   W1          ADD THE SSR LENGTH
          STDL   CN+3
          ADN    77          ROUND UP TO NEAREST 100B WORD MULTIPLE
          SHN    -6          SUBTRACT SSR LENGTH FROM MEMORY SIZE
          LMC    7777
          ADN    1           FORM TWOS COMPLEMENT AND ADD
          RAD    SZ+1
          SHN    -14
          ADC    7777
          RAD    SZ
          LDM    HPSM
          LMC    7777
          LPDL   SZ+1        ROUND ADDRESS TO A PAGE SIZE
          STD    SZ+1
          LRD    SZ
          SRD    CN+1
          LDN    0
          STD    CM
          STD    CM+3
          STD    CN
          STM    SAAO
          RJM    SPB         SET PP BOUNDARY
          LDDL   CN+3        SSR SIZE
          RJM    CCM         CLEAR SSR AREA
          LRD    SZ          MOVE SSR DIRECTORY TO 170 STACK + 1000
          SRD    SA
          LDN    1000/100
          RAD    SA+1
          STD    CM+2
          SHN    -14
          RAD    SA
          STD    CM+1

*         SET SSR POINTER INTO THE *EICB*.

          LRD    IB+1
          RJM    SPB         SET PP BOUNDARY
          LDN    D8SSR
          RJM    IIB
          CWDL   CM          SET SSR POINTER INTO THE EICB
          LDN    3           SET LOCATION OF DIRECTORY IMAGE
          STD    CN
          LRD    LA
          SRD    CN+1
          RJM    SPB         SET PP BOUNDARY
          LDD    W3          SSR DIRECTORY LENGTH
          RJM    CPY         COPY SSR DIRECTORY TO UPPER MEMORY
          RJM    CSC         CREATE SSR CHECKSUM
          SSRE   SCKS        GET SSR CHECKSUM ENTRY
          LDDL   T3          SET NEW CHECKSUM
          STDL   W5
          LDDL   W1          REWRITE SSR CHECKSUM ENTRY
          RJM    INS
          CWDL   W2
          LJM    MCSX        RETURN

*         ENDX   CTP$SCI MOVE AND COMPLETE SSR.
*DECK DECK=CTP$SCI_PRESET_EICB_MSG_BUFFER EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI PRESET EICB MSG BUFFER.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO PRESET THE
*         EICB MESSAGE BUFFER AT DEADSTART TIME.
 PEM      SPACE  4,25
**        PEM - PRESET EICB MESSAGE BUFFER.
*
*         MOVE THE CURRENT EICB MESSAGE BUFFER (DFCM+1 - DFCM+3) TO THE SAVE
*         AREA FOR THE EICB MESSAGE BUFFER (DFCM+4 - DFCM+6) AND ENTER BLANKS
*         IN THE CURRENT MESSAGE BUFFER.  IF THE CURRENT EICB MESSAGE BUFFER
*         CONTAINS ZEROS (EICB HAS JUST BEEN INITIALIZED), THEN SIMPLY ENTER
*         BLANKS INTO BOTH BUFFERS.
*
*         EXIT   EICB MESSAGE BUFFER CONTAINS BLANKS.
*                EICB SAVED MESSAGE BUFFER CONTAINS EITHER THE PREVIOUS MESSAGE
*                OR BLANKS.
*
*         USES   CM - CM+3.
*
*         CALLS  IIB.


 PEM      SUBR               ENTRY/EXIT
          LDN    DFCM        SET MESSAGE ID = 1, LENGTH = 24
          RJM    IIB
          CWML   PEMA,ON
          CRDL   CM          READ FIRST WORD OF CURRENT MESSAGE
          ADN    3           INITIALIZE SAVE AREA TO BLANKS
          CWML   PEMB,ON
          CWML   PEMB,ON
          CWML   PEMB,ON
          LDDL   CM
          ZJN    PEM10       IF CURRENT MESSAGE CONTAINS ZEROS
          LDN    DFCM+4      SAVE FIRST WORD
          RJM    IIB
          CWDL   CM
          SBN    2           GET SECOND WORD
          CRDL   CM
          ADN    3           SAVE SECOND WORD
          CWDL   CM
          SBN    2           GET THIRD WORD
          CRDL   CM
          ADN    3           SAVE THIRD WORD
          CWDL   CM
 PEM10    LDN    DFCM+1      BLANK CURRENT MESSAGE BUFFER
          RJM    IIB
          CWML   PEMB,ON
          CWML   PEMB,ON
          CWML   PEMB,ON
          LJM    PEMX        RETURN

 PEMA     VFD    16/,16/24D,16/,16/1
 PEMB     DATA   8H

*         ENDX   CTP$SCI PRESET EICB MSG BUFFER.
*DECK DECK=CTP$SCI_PROCESS_ANALYSIS_CODE EXPAND=FALSE
          OVERLAY  (CTP$SCI PROCESS ANALYSIS CODE),CBUF-100
 PAN      SPACE  4,15
**        PAN - PROCESS ANALYSIS CODE.
*
*         ENTRY  (ANCD) = ANALYSIS CODE.
*                (AACA) = 1, IF *MDD* IS TO PROCESS MR ERRORS.
*                       = 0, IF *SCI* IS TO HANG ON MR ERRORS.
*
*         EXIT   TO *MDER*, IF *MDD* IS TO PROCESS ERROR.
*                OTHERWISE, NO EXIT.
*
*         USES   T1 - T7.
*
*         CALLS  CDA, CME, CMN, IIB, ITM.
*
*         NOTE   THIS OVERLAY IS LOCATED AT *CBUF-100* TO MINIMIZE THE
*                POSSIBILITY THAT IT WILL OVERLAY WHATEVER CODE MAY
*                HAVE CAUSED OR ENCOUNTERED THE ERROR.


 PAN      ROUTINE

*         IF THE *MDD* FLAG IS SET, THEN LET *MDD* PROCESS THE ERROR
*         ONLY IF IT IS A CH17 ERROR (603, 605, 60F).

          LDML   AACA
          ZJN    PAN20       IF NOT *MDD* ERROR
          LDML   ANCD        ANALYSIS CODE
          LMC    DAMP        603 - CH17 PARITY ERROR
          ZJN    PAN10       IF CH17 PARITY ERROR
          LMN    DAMA-DAMP   605 - CH17 ACTIVE
          ZJN    PAN10       IF CH17 ACTIVE
          LMN    DACI-DAMA   60F - CH17 INACTIVE
          NJN    PAN20       IF NOT CH17 ERROR
 PAN10    STM    LOCK        CLEAR LONG TERM INTERLOCK
          LJM    MDER        LET *MDD* PROCESS ERROR

 PAN20    EXITMR  PAN40
          FATALMR  PAN40
          LDK    1RS         SET SCI PRODUCT
          STML   CMEA
          LDC    1RI         SET ELEMENT SPECIFIER TO IOU0
          STML   CMEB
          LDML   IOUM        IOU MODEL NUMBER
          RJM    CDA         CONVERT DIGITS TO ASCII
          STML   CMEC
          STML   SNFS+1
          LDML   ANCD        ANALYSIS CODE
          STML   CMED
          RJM    CME         CONSTRUCT MESSAGE IN EICB
          SBN    1
          STD    T1          SAVE *CME* EXIT CONDITION
          RJM    ITM         ISSUE CYBER 2000 MESSAGE IF APPROPRIATE
          LDD    T1
          ZJN    PAN30       IF EICB CANNOT BE WRITTEN
          RJM    CMN         CONSTRUCT MESSAGE IN NON-REGISTER STATUS BUFFER

*         NOTIFY *DFT* THAT *SCI* HAS DELIBERATELY HUNG ITSELF.

          LDN    D8RLP       READ RELOCATION CONTROL WORD
          RJM    IIB
          CRDL   T0
          LDDL   T3          RELOCATION CONTROL WORD LENGTH
          ZJN    PAN30       IF NOT DEFINED
          LRD    T0+1
          LDD    T0
          ADC    RR
          CRDL   T4
          LDDL   T5          SET DELIBERATE HANG STATUS
          LPC    177377
          LMC    400
          STDL   T5
          LDD    T0          REWRITE RELOCATION CONTROL WORD
          ADC    RR
          CWDL   T4
 PAN30    LDML   ANCD        REPORT ANALYSIS CODE AND HANG
          UJN    *           HANG

 PAN40    AOM    PANA        SET FLAG
          UJN    PAN30       HANG

 PANA     CON    0           1 = ERROR OCCURRED WHILE PROCESSING ERROR
 CMN      SPACE  4,15
**        CMN - CONSTRUCT MESSAGE IN NON-REGISTER STATUS BUFFER.
*
*         ENTRY  (ANCD) = ANALYSIS CODE.
*                (SNFS+1) = MODEL NUMBER IN ASCII.
*
*         EXIT   MESSAGE SET IN NON-REGISTER STATUS BUFFER.
*                C170 AND/OR C180 ERROR FLAG SET TO TELL OS TO LOG ERROR.
*
*         USES   CM - CM+4, T1 - T4.
*
*         CALLS  CDA, CSD, IIB.


 CMN      SUBR               ENTRY/EXIT

*         CHECK ANALYSIS CODE.

          LDML   ANCD
          LMC    DADN
          ZJN    CMNX        IF DFT NOT IN CIP DIRECTORY
          LMN    DANV&DADN
          ZJN    CMNX        IF DFT NEVER VERIFIED
          LMN    DARJ&DANV
          ZJN    CMNX        IF DFT SET REJECT FLAG

*         CHECK THE *DFT* VERSION.

          LDC    HDRP+RR
          ADML   DFTO
          LRD    DP
          CRDL   CM
          LDDL   CM+1
          SHN    -DH.RL
          SBN    5
          MJN    CMNX        IF *DFT* VERSION DOES NOT SUPPORT NRSB USAGE

*         SET THE DFT ANALYSIS CODE.

          LDC    0#3000      PRIORITY
          ADML   ANCD
          STML   SNRB+1

*         SET THE DATE AND TIME.

          LDN    DFCM+7      GET DATE/TIME FROM EICB
          RJM    IIB
          CRML   SNDT,ON

*         SET THE FAULT SYMPTOM CODE.

          LDML   ANCD        CONVERT LOWER TWO DIGITS OF ANALYSIS CODE
          LPC    0#FF
          RJM    CDA         CONVERT DIGITS TO ASCII
          STML   SNFS+3
          LDML   ANCD        CONVERT UPPER DIGIT OF ANALYSIS CODE
          SHN    -8D
          RJM    CSD         CONVERT SINGLE DIGIT TO ASCII
          LMC    1RZ*400
          STML   SNFS+2

*         SET THE APPROPRIATE OS LOGGING FLAG(S).

          LDML   SCMT+PTDB.  DETERMINE WHICH FLAG(S) TO SET
          LPC    2000
          ZJN    CMN20       IF *SCD/VE* STATE NOT ACTIVE
          LDD    DO
          ZJN    CMN10       IF DUAL STATE
          LDN    1           SET C180 FLAG
          SHN    DH.FE8
          UJN    CMN30       CONTINUE

 CMN10    LMBC   DH.FE8      SET C180 FLAG
 CMN20    LMBC   DH.FE7      SET C170 FLAG
 CMN30    STML   CMNA        SAVE FOR SETTING IN DFT CONTROL WORD
          LMN    10          SET LOGGING FLAG
          ERRNZ  DH.FL-3     CHANGE CODE IF LOGGING FLAG POSITION CHANGES
          STML   SNFG        SET IN NON-REGISTER STATUS BUFFER

*         WRITE THE *SCI* NON-REGISTER STATUS BUFFER TO CENTRAL MEMORY.

          LRD    DP
          LDC    NRSP+RR     GET POINTER TO NRSB
          ADM    DFTO
          CRDL   CM
          LRD    CM+1
          LDDL   CM          READ FIRST WORD OF NRSB
          ADC    RR
          CRDL   T1          GET ELEMENT SIZE
          LDN    5           SET LENGTH TO WRITE
          STD    T1
          AOD    CM          SKIP HEADER WORD
          LDN    NRSSC       GET *SCI* BUFFER INDEX
          STD    T2
 CMN40    LDDL   T4          SKIP BUFFER
          RADL   CM
          SOD    T2          DECREMENT INDEX
          NJN    CMN40       IF NOT YET AT CORRECT BUFFER
          LDDL   CM
          ADC    RR
          CWML   SNRB,T1     WRITE *SCI* NON-REGISTER STATUS BUFFER

*         SET THE C170 AND/OR C180 ERROR FLAG(S) IN THE DFT CONTROL WORD.

          LDN    0           CLEAR BUFFER
          STD    CM
          STD    CM+1
          STD    CM+2
          LRD    DP
          LDC    **          SET APPROPRIATE OS FLAG(S)
 CMNA     EQU    *-1
          STDL   CM+DHFLG
          LDC    HDRP+RR     SET FLAG(S) IN *DFT* HEADER
          ADM    DFTO
          RDSL   CM
          LJM    CMNX        RETURN
 SNRB     SPACE  4,10
**        SNRB - *SCI* NON-REGISTER STATUS BUFFER.


 SNRB     BSS    0
          VFD    8/2         *SCI* ID
          VFD    8/OSSS      OS ACTION CODE = STEP SYSTEM
          VFD    4/3         PRIORITY = UNCORRECTED ERROR
          VFD    12/0        *DFT* ANALYSIS CODE
 SNFG     VFD    8/0         SEQUENCE NUMBER = 0
          VFD    8/0         FLAGS = V180 AND/OR V170, LOG
          VFD    16/0        RESERVED
          VFD    32/0        RESERVED
          VFD    8/4         ELEMENT ID
          VFD    8/7         TYPE
          VFD    16/5        LENGTH
 SNDT     VFD    32/0        DATE
          VFD    32/0        TIME
          VFD    32/0        RESERVED
 SNFS     VFD    32/4RSIMM   FAULT SYMPTOM CODE - PART 1
          VFD    32/4RZ600   FAULT SYMPTOM CODE - PART 2
          VFD    32/0        FAULT SYMPTOM CODE - PART 3
 ITM      SPACE  4,10
**        ITM - ISSUE CYBER 2000 MESSAGE IF APPROPRIATE.
*
*         ENTRY  (A) .GE. 0 IF MESSAGE WRITTEN TO THE EICB.
*                (T2) = MESSAGE LENGTH.
*                (CMEE) = FORMATTED MESSAGE AS WRITTEN TO THE EICB.
*
*         EXIT   MESSAGE WRITTEN TO BOOT CONTROL TABLE OS MESSAGE BUFFER,
*                            IF CYBER 2000 MAINFRAME.


 ITM      SUBR               ENTRY/EXIT
          ZJN    ITMX        IF MESSAGE NOT WRITTEN TO THE EICB
          LDML   S0FLG       CHECK IF CYBER 2000
          LMC    10000
          NJN    ITMX        IF NOT CYBER 2000
          LDN    BCTOB       WRITE MESSAGE TO THE OS MESSAGE BUFFER
          CWML   CMEE,T2
          UJN    ITMX        RETURN

*copy     ctp$construct_message_in_eicb

          OVERFLOW  SCMT     CHECK FOR OVERFLOW

          QUAL   *
*DECK DECK=CTP$SCI_RELOCATE_MPS_REGISTERS EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI RELOCATE MPS REGISTERS.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO CREATE
*         ABSOLUTE ADDRESSES FOR THE DEADSTART EXCHANGE PACKAGE.
 RMP      SPACE  4,15
**        RMP - RELOCATE MONITOR PROCESS.
*
*         ENTRY  BOOT LOADED.
*                (BL - BL+1) = R-ADDRESS OF BOOT.
*                (MBUF - MBUF+3) = FBA OF BOOT.
*
*         EXIT   MPS SEGMENT TABLE ADDRESS RELOCATED.
*                MPS POINTER STORED IN HDWR.
*                (IDRA+2 - IDRA+3) = MPS POINTER.
*
*         USES   T5, CM - CM+3, CN - CN+1, MBUF - MBUF+3*4.
*
*         CALLS  SPB, SPR.
*
*         MACROS SSRE.


 RMP      SUBR               ENTRY/EXIT
          LDC    RR+2        FETCH OFFSET TO MPS
          LRD    BL
          CRDL   CM
          LDDL   CM+1        BUILD MPS FOR HDWR AND DFT REQUEST
          ADML   MBUF+3
          STML   IDRA+3
          STDL   CM+3
          SHN    -20
          ADDL   CM
          ADML   MBUF+2
          STML   IDRA+2
          STDL   CM+2
          LDN    0
          STDL   CM
          STDL   CM+1
          LDDL   CM+2        BUILD R-POINTER TO MPS
          SHN    -5
          STD    CN
          LDDL   CM+2
          LPN    37
          SHN    7
          STD    CN+1
          LDN    2
          STD    T5
          LRD    CN
          LDDL   CM+3
          SHN    -3
          ADC    RR+34D
          CRML   MBUF+2*4,T5 FETCH SEGMENT TABLE ADDRESS
          LDML   MBUF+3
          RAML   MBUF+3*4    RELOCATE LOWER PART OF STA
          SHN    -20
          ADML   MBUF+2
          RAML   MBUF+2*4    RELOCATE UPPER PART OF STA
          RJM    SPB         SET PP BOUNDARY
          LDDL   CM+3
          SHN    -3
          ADC    RR+34D
          CWML   MBUF+2*4,T5 WRITE RELOCATED SEGMENT TABLE ADDRESS
          SSRE   HDWR        WRITE THE MPS WORD IN HBUF
          ADN    1
          CWDL   CM
          SBN    1
          RJM    SPR         SET UP PROCESSOR REQUEST
          LJM    RMPX        RETURN

*         ENDX   CTP$SCI RELOCATE MPS REGISTERS.
*DECK DECK=CTP$SCI_SET_IOU_NUMBER EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI SET IOU NUMBER.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO
*         SET THE SCI IOU NUMBER AND MODEL NUMBER INTO WORD
*         *D8ST* OF THE EICB.
 SSI      SPACE  4,10
**        SSI - SET *SCI* IOU NUMBER AND MODEL NUMBER.
*
*         ENTRY  (A) = *SCI* IOU NUMBER.
*
*         EXIT   (*D8ST*) UPDATED WITH THE *SCI* IOU NUMBER AND MODEL NUMBER,
*                         AND PP NUMBER.
*
*         USES   T1, CM - CM+3.
*
*         CALLS  IIB, SPB.


 SSI      SUBR               ENTRY/EXIT
          STD    T1          SAVE IOU NUMBER
          LDN    D8ST        READ WORD *D8ST*
          RJM    IIB
          CRDL   CM
          LDDL   CM+2
          LPC    0#FC        CLEAR OLD IOU AND PP NUMBERS
          LMDL   T1          SET IOU NUMBER
          STDL   CM+2
          LDM    PPNO        SET PP NUMBER
          SHN    10
          RADL   CM+2
          LDM    IOUM        SET IOU MODEL NUMBER
          SHN    5
          STDL   T1
          LDDL   CM+1
          LPC    160037
          LMDL   T1
          STDL   CM+1
          RJM    SPB         SET PP BOUNDS
          LDN    D8ST        REWRITE WORD *EICB*
          RJM    IIB
          CWDL   CM
          UJN    SSIX        RETURN

*         ENDX   CTP$SCI BUILD CIP TABLES.

*DECK DECK=CTP$SCI_SET_UP_PROCESSOR_REQ EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI SET UP PROCESSOR REQ.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO SET UP
*         A DFT PROCESSOR REQUEST.
 SPR      SPACE  4,10
**        SPR - SET UP PROCESSOR REQUEST.
*
*         ENTRY  (A) = ADDRESS OF CM PARAMETER TO DFT.
*
*         USES   CM - CM+3.


 SPR      SUBR               ENTRY/EXIT
          STDL   CM+1        STORE ADDRESS OF BLOCK
          SRD    CM+2
          LDN    10          SELECT FIRST AVAILABLE CPU
          STM    IDRA
          UJN    SPRX        RETURN

*         ENDX   CTP$SCI SET UP PROCESSOR REQ.

*DECK DECK=CTP$SCI_TIMEOUT_DFT_VERIFIED EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI TIMEOUT DFT VERIFIED.
*
*         THIS DECK CONTAINS A ROUTINE WHICH TIMES OUT THE SETTING
*         OF THE DFT VERIFIED FLAG BY DFT AFTER SIX SECONDS.
 TDF      SPACE  4,10
**        TDF - TIMEOUT DFT VERIFIED.
*
*         EXIT   TO *AAC* IF NO RESPONSE FROM DFT WITHIN 6 SECONDS OR IF
*                DFT SETS THE REJECT FLAG.
*
*         USES   T6, CM - CM+3.
*
*         CALLS  DLY, IDT.


 TDF10    SHN    21-6-21+7   CHECK IF REJECT FLAG IS SET
          PJN    TDFX        IF REJECT FLAG NOT SET
          LDC    DARJ        62B - DFT SET REJECT FLAG
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR

 TDF      SUBR               ENTRY/EXIT
          LDN    6           TIMEOUT *DFT* AFTER 6 SECONDS
          STD    T6
 TDF5     LDC    1000D
          RJM    DLY         DELAY 1 SECOND
          LDN    HDRP        READ *DFT*CONTROL WORD
          RJM    IDT
          CRDL   CM
          LDDL   CM+3
          SHN    21-7
          MJN    TDF10       IF *DFT* VERIFIED
          SOD    T6          DECREMENT TIMEOUT COUNTER
          NJN    TDF5        IF NOT TIMED OUT
          LDC    DANV        62A - DFT NEVER VERIFIED
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR

*         ENDX   CTP$SCI_TIMEOUT_DFT_VERIFIED.

*DECK DECK=CTP$SCI_UPDATE_MEMORY_BOUNDS EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI UPDATE MEMORY BOUNDS.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO UPDATE
*         THE NOS/VE MEMORY BOUNDS IN THE EICB.
 UMB      SPACE  4,15
**        UMB - UPDATE MEMORY BOUNDARY.
*
*         ENTRY  (LA - LA+1) = CURRENT LOAD ADDRESS.
*                (SZ - SZ+1) = CURRENT LWA OF USABLE MEMORY.
*                (DO) = DEADSTART ORIGIN.
*
*         EXIT   DATA WRITTEN TO EICB.
*
*         USES   CM - CM+3.
*
*         CALLS  IIB.


 UMB      SUBR               ENTRY/EXIT
          LDD    DO
          ZJN    UMBX        RETURN IF DUAL-STATE
          LDD    LA+1        ROUND LOAD ADDRESS TO MULTIPLE OF 1000
          ADN    7
          SCN    7
          STD    CM+2
          SHN    -14
          ADD    LA          PACK LOAD ADDRESS
          SHN    1
          STDL   CM+1        000LLLLLLLLLLLL0
          LDD    CM+2
          SHN    0-13
          RADL   CM+1        000LLLLLLLLLLLLL
          LDD    CM+2
          SHN    20-13
          STDL   CM+2        LLLLLLLL00000000
          LDD    SZ
          SHN    0-7
          RADL   CM+2        LLLLLLLL000SSSSS
          LDD    SZ
          SHN    20-7
          SCN    7
          STDL   CM+3        SSSSSSS000000000
          LDD    SZ+1
          SHN    -3
          RADL   CM+3        SSSSSSSSSSSSSSSS
          LDN    D7CM+1
          RJM    IIB
          CWDL   CM          WRITE CURRENT MEMORY BOUNDARY
          LJM    UMBX        RETURN

*         ENDX   CTP$SCI UPDATE MEMORY BOUNDS.

*DECK DECK=CTP$SCI_VERIFY_MEMORY_BOUNDS EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI VERIFY MEMORY BOUNDS.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO VERIFY
*         THE NOS/VE MEMORY BOUNDS IN THE EICB.
 VMB      SPACE  4,10
**        VMB - VERIFY MEMORY BOUNDS.
*
*         EXIT   (LA - LA+1) UPDATED IF REQUIRED.
*                (SZ - SZ+1) UPDATED IF REQUIRED.
*
*         CALLS  FMV, UMB.


 VMB20    RJM    UMB         UPDATE MEMORY BOUND VALUES

 VMB      SUBR               ENTRY/EXIT
          RJM    FMV         FETCH MEMORY BOUND VALUES
          LDD    CM+3        CHECK LWA OF NOS/VE
          ADD    CM+2
          ZJN    VMB20       IF NO MEMORY BOUNDS ESTABLISHED
          LDD    SZ          COMPARE OLD AND NEW MEMORY SIZES
          SBD    CM+2
          NJN    VMB5        IF TEST IS SIGNIFICANT
          LDDL   SZ+1
          SBDL   CM+3
 VMB5     MJN    VMB10       IF NEW SYSTEM HAS LESS MEMORY
          LRD    CM+2
          SRD    SZ
          LDM    HPSM        ROUND CM SIZE DOWN TO PAGE BOUNDARY
          LMC    7777
          LPDL   SZ+1
          STD    SZ+1
 VMB10    LDD    LA          COMPARE OLD AND NEW LOAD ADDRESSES
          SBD    CM
          NJN    VMB15       IF TEST IS SIGNIFICANT
          LDD    LA+1
          SBD    CM+1
 VMB15    PJN    VMB20       IF NEW SYSTEM LOAD ADDRESS IS GREATER
          LRD    CM          SET OLD LOAD ADDRESS
          SRD    LA
          UJN    VMB20       UPDATE CM POINTERS AND RETURN

*         ENDX   CTP$SCI VERIFY MEMORY BOUNDS.
*DECK DECK=CTP$SCI_VPB_DEADSTART_CY2000 EXPAND=FALSE
          CTEXT  SCI VPB DEADSTART CYBER 2000
          CTEXT  SCI VPB DEADSTART CYBER 2000
          OVERLAY  (SCI VPB DEADSTART CYBER 2000),CY2OVL
          SPACE  4,10
*         NOTE - THE FIRST INSTRUCTION OF *DTE* AND ANY CODE THAT LOADS
*                OTHER OVERLAYS MUST RESIDE BEFORE ADDRESS 10000 SO THAT
*                THE *CALL* MACRO AND THE *LNO* ROUTINES WORK CORRECTLY.
*                ALSO, ANY CODE THAT RESIDES BEFORE ADDRESS 10000 CAN
*                NOT BE EXECUTED AFTER *HBUF* HAS BEEN USED.
 LRO      SPACE  4,10
**        LRO - LOAD RESIDENT AND IDLE OVERLAYS.
*
*         EXIT   RESIDENT OVERLAY AND IDLE OVERLAY LOADED.
*                (TIMA) INITIALIZED.
*
*         MACROS LOADOV.


 LRO      SUBR               ENTRY/EXIT
          LOADOV RESOL,P     LOAD RESIDENT OVERLAY
          LOADOV IDL         LOAD IDLE OVERLAY
          IAN    14          INITIALIZE TIMER BASE TIME
          STML   TIMA
          UJN    LROX        RETURN
 DTE      SPACE  4,10
**        DTE - DEADSTART CYBER 2000.


 DTE      ROUTINE

          ERRPL  DTE-10000   SEE ABOVE NOTE

          RJM    PRS         PRESET VPB/CYBER 2000
          LDC    **          GET RESTART FLAG
 DTEA     EQU    *-1
          LMC    4000B
          ZJN    DTE1        IF RESTART
          RJM    BEI         BUILD THE EICB
          RJM    ISP         INITIALIZE *SCI* PARAMETER TABLE
          RJM    ADF         ACTIVATE *DFT*
          RJM    GHI         GET HARDWARE INFORMATION
          RJM    CNB         CONFIGURE NOS/VE BOOT
          RJM    LBS         LOAD AND BUILD THE SSR
          RJM    BRS         BUILD RESOURCE TABLE
          RJM    CTS         COPY MEMORY TO SAVE AREA
          RJM    BPT         BUILD PAGE TABLE
          RJM    LVC         LOAD VCB
          RJM    DFP         DEADSTART FIRST PROCESSOR
          CALL   SMT         SET MODE TABLE
*         LJM    IDL         *SMT* RETURNS TO THE IDLE LOOP

 DTE1     CALL   RMD         RESTORE MODE DEFINITIONS FROM SCDPT
*         LJM    IDL         *RMD* EVENTUALLY RETURNS TO IDLE LOOP
 ADF      SPACE  4,15
**        ADF - ACTIVATE *DFT*.
*
*         ENTRY  (LA - LA+1) = NEXT AVAILABLE CM ADDRESS.
*
*         EXIT   (DP - DP+1) = R-REGISTER OF *DFT* BUFFER.
*                (DFTO) = *DFT* OFFSET TO ACCESS *DFT* CONTROL WORD.
*                (CD - CD+2) = OFFSET AND R-REGISTER TO TEMPORARY SCI DFT
*                              REQUEST BUFFER.
*                (LA - LA+1) = ADVANCED.
*                (VP - VP+3) = R-POINTER TO NOS/VE REQUEST BLOCK.
*                *DFT* ACTIVATED.
*
*         USES   CN - CN+3.
*
*         CALLS  ALA, CCM, IDT, IIB, TDF.


*         ALLOCATE THE *DFT* BUFFER.

 ADF5     LDN    1           SET R-POINTER OFFSET
          STM    DFTO
          STD    CN
          STD    CD
          LRD    LA          SET R-REGISTER
          SRD    DP
          SRD    CN+1
          SRD    CD+1
          LDML   BOCT+BCTDL  CREATE OFFSET TO TEMPORARY SCI DFT REQUEST BUFFER
          RADL   CD
          LDN    DSDFT       WRITE THE BUFFER POINTER TO THE EICB
          RJM    IIB
          CWDL   CN
          LDML   BOCT+BCTDL  ZERO OUT THE BUFFER
          ADN    TSDRBL      INCLUDE TEMPORARY SCI DFT REQUEST BUFFER
          RJM    CCM         CLEAR MEMORY
 ADF10    LDML   BOCT+BCTDL  GET BUFFER LENGTH
          ADN    TSDRBL      INCLUDE TEMPORARY SCI DFT REQUEST BUFFER
          RJM    ALA         ADVANCE LOAD ADDRESS

*         SET THE *DFT* ACTIVATION FLAG IN THE BOOT CONTROL TABLE.

          LDN    1           SET THE FLAG
          SHN    BCTDA
          RAML   BOCT+BCTFL
          LDN    BCTP+1
          CWML   BOCT+BCTFL,ON
          RJM    TDF         TIMEOUT *DFT* AFTER 3 SECONDS

*         FETCH THE NOS/VE REQUEST POINTER FROM THE DFT/OS BUFFER.

          LDN    NVEP
          RJM    IDT
          CRDL   VP

 ADF      SUBR               ENTRY/EXIT
          LDN    DSDFT       GET POSSIBLE *DFT* POINTER
          RJM    IIB
          CRDL   CN
          LDDL   CN+1
          ADDL   CN+2
          ZJP    ADF5        IF NO PREVIOUS *DFT* BUFFER
          LDDL   CN
          STM    DFTO        SAVE *DFT* BUFFER OFFSET
          LRD    CN+1
          SRD    DP          SAVE R-REGISTER
          SRD    CD+1        SAVE TEMPORARY DFT REQUEST BUFFER POINTER
          LDML   BOCT+BCTDL
          ADN    1
          STDL   CD

*         CLEAR *DFT* VERIFIED FLAG.

          LDN    HDRP        READ *DFT* CONTROL WORD
          RJM    IDT
          CRDL   CN
          LDDL   CN+DHFLG
          LPC    0#FF7F
          ERRNZ  DH.FV-7     MASK ASSUMES *DH.FV* IS 2**7
          STDL   CN+DHFLG
          LDN    HDRP        REWRITE *DFT* CONTROL WORD
          RJM    IDT
          CWDL   CN

*         CLEAR THE NOS/VE REQUEST BUFFER.

          LDN    NVEP        READ REQUEST POINTER
          RJM    IDT
          CRDL   CN
          LDDL   CN+3
          RJM    CCM         CLEAR MEMORY
          LJM    ADF10       RETURN
 BCT      SPACE  4,10
**        BCT - BUILD CIP TABLES.
*
*         EXIT   (IB - IB+2) = R-POINTER TO EICB.
*                EICB AND DFT BUFFERS ARE AVAILABLE.
*
*         USES   CN - CN+3.
*
*         CALLS  ALA, CCM, IIB, PEM, PIB.


 BCT      SUBR               ENTRY/EXIT
          RJM    PIB         PRESET EICB POINTER
          LDDL   W2
          NJN    BCT5        IF NO EXISTING EICB (ADDRESS TOO LARGE)
          LDDL   W3
          NJN    BCT10       IF EICB ALREADY EXISTS (VALID ADDRESS)

*         INITIALIZE NEW EICB AND STORE POINTER.

 BCT5     LDN    0           SET UP *CCM* PARAMETERS
          STD    CN
          LRD    LA
          SRD    CN+1
          LDN    BCTP        CLEAR WORD 0 TO BEGINNING OF BOOT CONTROL TABLE
          RJM    CCM
          LDN    BCTP+BCTTL-100
          STD    CN
          LDC    EICBFWA-BCTP-BCTTL+EICBL  BOOT CONTROL TABLE END TO EICB END
          RJM    CCM         CLEAR MEMORY
          LDN    0
          STD    IB          SAVE POINTER TO EICB
          SRD    IB+1
          LDC    EICBFWA     SAVE ADDRESS OF EICB
          STM    MBUF+3
          LDN    EICBP
          CWML   MBUF,ON     WRITE THE POINTER TO THE EICB
          RJM    PIB         PRESET EICB POINTER

*         UPDATE EXISTING EICB.

 BCT10    RJM    PEM         PRESET THE EICB MESSAGE BUFFER
          LDN    D8CPT       CLEAR THE CRITICAL PAGE TABLE POINTER
          RJM    IIB
          CWML   BCTA,ON
          LDC    EICL        SET EICB LEVEL
          STM    BCTA+3
          LDN    D7TY        GET POINTER TO EICB HEADER
          RJM    IIB
          CWML   BCTA,ON     CLEAR THE 170 EICB HEADER EXCEPT VERSION NUMBER

*         IT IS OK TO WRITE THE CIP DIRECTORY POINTER DIRECTLY FROM DIRECT CELLS
*         CD - CD+3 EVEN THOUGH CD+3 IS ACTUALLY DIRECT CELL IB, BECAUSE IB IS
*         ALWAYS ZERO ANYWAY (SET ABOVE AS EICB OFFSET).

          LDN    DSEBP
          RJM    IIB         INCREMENT INTERFACE BLOCK
          CWDL   CD          WRITE CTI DIRECTORY POINTER
          LDC    EICBFWA+EICBL  END OF EICB
          RJM    ALA         ADVANCE LOAD ADDRESS
          LJM    BCTX        RETURN

 BCTA     BSSZ   4           USED IN CLEARING EICB WORDS
 BEI      SPACE  4,10
**        BEI - BUILD THE EICB.
*
*         EXIT   EICB ALLOCATED AND PRESET.
*
*         CALLS  BCT, IIB, SSI.


 BEI      SUBR               ENTRY/EXIT
          RJM    BCT         BUILD CIP TABLES
          LDML   BOCT+BCTIP  GET IOU NUMBER
          SHN    -8D
          RJM    SSI         SET *SCI* IOU NUMBER AND MODEL NUMBER
          LDC    DFCM+7      MOVE PACKED DATE/TIME TO EICB
          RJM    IIB
          CWML   BOCT+BCTDT,ON
          LDN    D8RLP       CLEAR THE CPU/PP COMMUNICATION BUFFER POINTER
          RJM    IIB
          CWML   BEIA,ON
          LDN    1           SET EICB ACTIVATION FLAG IN THE BOOT CONTROL TABLE
*         SHN    BCTEA
          ERRNZ  BCTEA       CODE DEPENDS ON EICB ACTIVATION FLAG IN BIT 0
          RAML   BOCT+BCTFL
          LDN    BCTP+1
          CWML   BOCT+BCTFL,ON
          UJN    BEIX        RETURN

 BEIA     BSSZ   4           WORD OF ZEROS
 BRS      SPACE  4,15
**        BRS - BUILD RESOURCE TABLE.
*
*         ENTRY  (PPNO) = *SCI* PP NUMBER.
*
*         EXIT   RESOURCE TABLE WRITTEN TO THE *VEPP* SSR ENTRY.
*
*         USES   T3, T4, T6.
*
*         CALLS  MCN, PPC.
*
*         MACROS SSRE.


 BRS      SUBR               ENTRY/EXIT
          LDC    IRTL-1      SET RESOURCE TABLE LENGTH
          STD    T3
 BRS5     LDC    0#0F0F      SET ALL PPS AND CHANNELS TO UNAVAILABLE
          STML   CBUF,T3
          SOD    T3
          PJN    BRS5        IF MORE ENTRIES TO SET

*         PROCESS THE PP FIELDS OF THE RESOURCE TABLE.

          LDC    IOSUBPP     SET IOU SUB-ELEMENT TO PP DESCRIPTOR
          STDL   T6
          RJM    PPC         PROCESS PP FIELDS

*         PROCESS THE CHANNEL FIELDS OF THE RESOURCE TABLE.

          LDC    IOSUBCH     SET IOU SUB-ELEMENT TO CHANNEL DESCRIPTOR
          STDL   T6
          LDC    0#FF        RESET MASK TO PROCESS CHANNELS
          STM    PPCA+1
          LDC    LPCI
          STM    PPCA
          RJM    PPC         PROCESS CHANNEL FIELDS

*         ON CYBER 2000, CHANNELS 32 AND 33 ARE REALLY NIO CHANNELS, SO MOVE
*         THEIR ENTRIES FROM CIO TO NIO AND MAKE CIO CHANNELS 32 AND 33
*         UNAVAILABLE.

          LDN    IRTL/4      SET OFFET TO IOU0 CIO CHANNEL 32
          SHN    1
          SBN    2
          STD    T3
          LDN    IRTL/4      SET OFFSET TO IOU0 NIO CHANNEL 32
          SBN    2
          STD    T4
          RJM    MCN         MOVE CIO ENTRIES TO NIO ENTRIES
          LDN    IRTL/4      RESET OFFSETS TO IOU1
          SHN    1
          RAD    T3
          LDN    IRTL/4
          SHN    1
          RAD    T4
          RJM    MCN         MOVE CIO ENTRIES TO NIO ENTRIES


*         SET THE *SCI* PP UNAVAILABLE.

          LDM    PPNO        SET *SCI* PP OFFSET
          SBN    20
          MJN    BRS10       IF LOWER PP
          ADN    20-4        SET UPPER PP OFFSET
          UJN    BRS15       CONTINUE

 BRS10    ADN    20
 BRS15    ADN    IRTL/4      SKIP TO CIO PORTION OF TABLE
          STD    T3
          LDML   CBUF,T3     SET *SCI* PP UNAVAILABLE
          LPC    0#FF00
          ADN    0#0F
          STML   CBUF,T3

*         WRITE THE RESOURCE TABLE TO CENTRAL MEMORY.

          SSRE   VEPP        GET RESOURCE TABLE ADDRESS
          CWML   CBUF,W4     WRITE RESOURCE TABLE
          LJM    BRSX        RETURN
 CNB      SPACE  4,10
**        CNB - CONFIGURE NOS/VE BOOT.
*
*         EXIT   (SZ - SZ+1) = LOGICAL MEMORY SIZE.
*                (HPSM) = PAGE SIZE MASK.
*                (HPTL) = PAGE TABLE LENGTH IN WORDS.
*                TO *FED* IF CENTRAL MEMORY ELEMENT DESCRIPTOR NOT PRESENT.
*
*         USES   CM+2.
*
*         CALLS  IGD, VMB.


 CNB      SUBR               ENTRY/EXIT
          LDN    CMSUBED     SET SUBELEMENT FIELD
          STD    CM+2
          LDN    EIDCM       GET CM ELEMENT DESCRIPTOR
          RJM    IGD         ISSUE GET ELEMENT DESCRIPTOR *DFT* REQUEST
          ZJP    FED         IF ELEMENT NOT PRESENT
          LDML   HBUF+EDCMAM+2  SAVE LOGICAL CM SIZE
          STD    SZ+1
          SHN    -14
          STD    SZ
          LDML   HBUF+EDCMAM+1
          SHN    4
          RAD    SZ
          LDM    HBUF+EDCMPS FETCH PAGE SIZE/1000B
          SBN    1           CREATE MASK
          STML   HPSM        SAVE PAGE SIZE MASK
          LMC    7777
          LPDL   SZ+1        ROUND DOWN TO NEAREST MULTIPLE OF PAGE SIZE
          STD    SZ+1
          RJM    VMB         VALIDATE MEMORY BOUNDS
          LDM    HBUF+EDCMPTL  PAGE TABLE LENGTH MASK/10000(8)
          ADN    1           CHANGE TO PAGE TABLE LENGTH
          SHN    3           CHANGE TO WORDS
          STML   HPTL        SAVE HARDWARE PAGE TABLE LENGTH
          SBN    1           CHECK IF LOAD ADDRESS ALREADY 0 MOD PTL
          LPDL   LA+1
          ZJN    CNB5        IF LOAD ADDRESS ALREADY 0 MOD PTL
          LDML   HPTL        ROUND LOAD ADDRESS TO MULTIPLE OF PTL
          RAD    LA+1
          SHN    -14
          RAD    LA
          LDML   HPTL
          SBN    1
          LMC    7777
          LPDL   LA+1
          STD    LA+1

*         NEXT, PREPARE THE DFT REQUEST FOR FLAW FREE MEMORY.

 CNB5     LDN    D8SV+4
          RJM    IIB
          CRDL   W0
          LDDL   W1
          ADDL   W2
          ZJN    CNB5.5      IF PTA POINTER NOT DEFINED
          LDDL   W1
          STDL   LA
          LDDL   W2
          STDL   LA+1
          LJM    CNBX        RETURN


 CNB5.5   LDN    BCTP
          CRDL   CM
          LDC    0#30C       LEVEL 780(10)
          STDL   T1
          LDDL   CM+1
          SBDL   T1
          PJN    CNB5.6      IF LEVEL SUPPORTS DFT REQUEST
          UJP    CNB7        IGNORE MAKING THE REQUEST

 CNB5.6   LDN    0
          STML   IDRA
          STDL   CM+3
          STDL   CM+2
          STDL   CM+1
          STDL   CM
          LDDL   LA
          STML   IDRA+1      START R UPPER
          LDDL   LA+1
          STML   IDRA+2      START R LOWER
          LDML   HPTL        PAGE TABLE LENGTH IN WORDS
          SHN    -6          /100B
          STML   IDRA+3
          LDN    GGM
          RJM    IDR         ISSUE DFT REQUEST
          LMN    RCNF
          ZJP    CNB7        IF COULD NOT GET FLAW FREE MEMORY
          LMN    RCNE&RCNF
          NJN    CNB6        IF ERROR FROM DFT
          LDDL   CD
          LMC    RR+2
          CRDL   W0          READ RESPONSE
          LDDL   W1
          STDL   LA
          LDDL   W2
          STDL   LA+1        REWRITE LA WITH FLAW FREE RESPONSE
 CNB7     LDN    0           SAVE PAGE TABLE POINTER IN EICB
          STD    W0
          LDDL   LA
          STDL   W1
          LDDL   LA+1
          STDL   W2
          LDML   HPTL
          STDL   W3
          LDN    D8SV+4
          RJM    IIB
          CWDL   W0          WRITE PAGE TABLE ADDRESS TO EICB
          LJM    CNBX        RETURN


 CNB6     LDC    DAFF
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR


 DFP      SPACE  4,10
**        DFP - DEADSTART FIRST PROCESSOR.
*
*         EXIT   TO *AAC* IF ERROR RETURNED ON *DFT* REQUEST.
*
*         CALLS  IDR, *AAC*.


 DFP      SUBR               ENTRY/EXIT
          LDN    DVP         DEADSTART VIRTUAL PROCESSOR
          RJM    IDR         ISSUE *DFT* REQUEST
          LMN    RCNE        CHECK FOR NO ERROR ON REQUEST
          ZJN    DFPX        IF *DFT* REQUEST COMPLETED WITH NO ERROR
          LDC    DAS8        625 - *SCI* DETECTED *DFT* ERROR WHILE STARTING
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR
 FED      SPACE  4,10
**        FED - FATAL ELEMENT DESCRIPTOR ERROR.
*
*         EXIT   TO *AAC* TO ACTIVATE ANALYSIS CODE ERROR PROCESSOR.


 FED      SUBR               ENTRY/EXIT

*         SET ANALYSIS CODE TO 629 - *SCI* DETECTED *DFT* ERROR GETTING
*         ELEMENT DESCR.

          LDC    DAED
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR
 GHI      SPACE  4,10
**        GHI - GET HARDWARE INFORMATION.
*
*         EXIT   (MION) = 1 IF IOU1 PRESENT.
*                (CPUT) = 6/NUMBER OF CPU-S, 6/CPU TYPE.
*                TO *FED* IF CRITICAL ELEMENT IS NOT PRESENT.
*
*         USES   CM+2, T7.
*
*         CALLS  FED, IGD.


 GHI      SUBR               ENTRY/EXIT

*         DETERMINE IF A SECONDARY IOU IS LOGICALLY ON.

          LDN    IOSUBED     SET IOU SUB-ELEMENT
          STD    CM+2
          LDN    EIDIOU1     LOOK FOR IOU1 DESCRIPTOR
          RJM    IGD         ISSUE GET ELEMENT DESCRIPTOR *DFT* REQUEST
          ZJN    GHI5        IF IOU1 ELEMENT NOT PRESENT
          LDM    HBUF+EDIOS  CHECK IF IOU1 LOGICALLY ON
          SHN    -8D
          NJN    GHI5        IF NOT LOGICALLY ON
          AOM    MION        SET IOU1 LOGICALLY ON FLAG

*         GET CPU TYPE AND NUMBER OF CPU-S.

 GHI5     LDN    CPSUBED     SET SUBELEMENT FIELD
          STD    CM+2
          LDN    EIDCPU0     GET CPU0 DESCRIPTOR
          RJM    IGD         ISSUE GET ELEMENT DESCRIPTOR *DFT* REQUEST
          ZJP    FED         IF CPU0 ELEMENT NOT PRESENT
          LDM    HBUF+EDCPMN GET CPU MODEL NUMBER
          SHN    -4
          LPN    17
          STM    CPUT        SAVE CPU TYPE
          LDN    1           INITIALIZE CPU COUNTER
          STD    T7
          LDN    EIDCPU1     INITIALIZE CPU ELEMENT ID
          RJM    IGD         ISSUE GET ELEMENT DESCRIPTOR *DFT* REQUEST
          ZJN    GHI10       IF NEXT CPU NOT PRESENT
          LDM    HBUF+EDCPS
          SHN    -8D
          LMN    77
          ZJN    GHI10       IF NOT PHYSICALLY PRESENT
          AOD    T7          COUNT THIS CPU

 GHI10    LDD    T7          SAVE NUMBER OF CPU-S
          SHN    6
          RAM    CPUT
          LJM    GHIX        RETURN
 IDR      SPACE  4,15
**        IDR - ISSUE DFT REQUEST.
*
*         ENTRY  (A) = PARAMETER FOR DFT REQUEST.
*                (CM+1 - CM+3) = PARAMETERS FOR DFT REQUEST.
*                (CD - CD+2) = SCI DFT REQUEST BUFFER POINTER.
*                (VP - VP+3) = DFT REQUEST POINTER.
*
*         EXIT   (A) = DFT RESPONSE CODE.
*                REQUEST ISSUED TO DFT.
*
*         USES   CM, W0 - W0+3.
*
*         CALLS  IVB.


 IDR      SUBR               ENTRY/EXIT
          STDL   CM          SAVE PARAMETER WORD

*         WRITE THE DFT REQUEST TO THE SCI DFT REQUEST BUFFER.

          LRD    CD+1
          SRD    W0+1
          LDDL   CD
          STDL   W0
          LMC    RR
          CWDL   CM          WRITE DFT REQUEST
          ADN    1
          CWML   IDRA,ON     WRITE ADDITIONAL PARAMETERS

*         WRITE THE POINTER TO THE SCI DFT REQUEST BUFFER INTO THE DFT REQUEST
*         POINTER.

          LDN    2           SET REQUEST LENGTH
          STD    W0+3
          LDN    0
          RJM    IVB         INDEX NOS/VE BLOCK
          CWDL   W0          WRITE DFT REQUEST POINTER

*         ON A CYBER 2000 MAINFRAME, THE SERVICE PROCESSOR *DFT* MUST BE TOLD
*         THAT THERE IS A *DFT* REQUEST PENDING.  THIS IS ACCOMPLISHED BY
*         SENDING AN INTERRUPT TO IOU0.

          INPN   2           INTERRUPT IOU0

*         WAIT FOR REQUEST COMPLETE.

          LRD    CD+1
 IDR5     LDDL   CD          INDEX TO VPB REQUEST
          LMC    RR
          CRDL   W0          READ STATUS WORD
          LDDL   W0
          SHN    -10
          ZJN    IDR5        IF NOT COMPLETE
          UJN    IDRX        RETURN

 IDRA     CON    0,0,0,0
 IGD      SPACE  4,15
**        IGD - ISSUE GET ELEMENT DESCRIPTOR *DFT* REQUEST.
*
*         ENTRY  (A) = DESCRIPTOR ELEMENT ID.
*                (CM+2) = SUB-ELEMENT IF DESCRIPTOR IS AN IOU.
*                (CD - CD+2) = SCI DFT REQUEST BUFFER POINTER.
*
*         EXIT   (A) = 0 IF ELEMENT NOT PRESENT.
*                (HBUF) = ELEMENT DESCRIPTOR.
*                TO *FED* IF ERROR RETURNED ON *DFT* REQUEST.
*
*         USES   CM - CM+3.
*
*         CALLS  IDR, IVB.


 IGD5     LRD    CD+1        READ ELEMENT DESCRIPTOR
          LDN    CMXLEN/4
          STD    CM+3
          LDDL   CD
          ADC    RR+1
          CRML   HBUF,CM+3

 IGD      SUBR               ENTRY/EXIT
          STDL   CM+1
          LDN    CMXLEN/4    SET REQUEST BLOCK LENGTH
          STD    CM+3
          LDN    GED
          RJM    IDR         ISSUE *DFT* REQUEST
          LMN    RCNE        CHECK FOR NO ERROR ON REQUEST
          ZJN    IGD5        IF NO ERROR ON REQUEST
          LMN    RCEN&RCNE   CHECK FOR ELEMENT NOT PRESENT
          ZJN    IGDX        IF ELEMENT NOT PRESENT
          LJM    FED         ISSUE FATAL ELEMENT DESCRIPTOR ERROR
 ISP      SPACE  4,15
**        ISP - INITIALIZE *SCI* PARAMETER TABLE.
*
*         ENTRY  (LA - LA+1) = CURRENT LOAD ADDRESS.
*                (PPNO) = *SCI* PP NUMBER.
*
*         EXIT   *SCI* PARAMETER TABLE INITIALIZED.
*                (LA - LA+1) ADVANCED.
*                (SB - SB+1) = SCIPT R-REGISTER.
*                (SBAO) = OFFSET.
*                (SCMT+DTDB.) = *SCD* DEFINITION BYTE.
*
*         USES   CN - CN+3.
*
*         CALLS  ALA, CCM, IIB, SPA.


 ISP      SUBR               ENTRY/EXIT
          LDN    D7RS+2      GET POSSIBLE SCIPT POINTER
          RJM    IIB
          CRDL   CN
          LDDL   CN+2
          ADDL   CN+3
          NJN    ISP5        IF POINTER ALREADY DEFINED

*         SET SCIPT POINTER INTO THE EICB.

          LDD    LA+1
          SHN    6
          STD    CN+3
          LDD    LA
          SHN    12D
          LMD    LA+1
          SHN    -6
          STD    CN+2
          LDN    D7RS+2      SET ADDRESS IN EICB
          RJM    IIB
          CWDL   CN
 ISP5     RJM    SPA         GET R-REGISTER TO SCIPT
          LDN    0           SET UP *CCM* PARAMETERS
          STD    CN
          SRD    CN+1
          LDN    SCIPTL      LENGTH TO CLEAR
          RJM    CCM         CLEAR MEMORY
          LDM    PPNO        SET *SCI* PP NUMBER
          SHN    4
          RAML   ISPA+1
          LRD    SB          INITIALIZE FIRST WORD
          LDM    SBAO
          LMC    RR
          CWML   ISPA,ON
          LDM    ISPA+2      INITIALIZE PORT DEFINITION BYTE
          STM    SCMT+PTDB.
          LDN    SCIPTL
          RJM    ALA         ADVANCE LOAD ADDRESS
          LJM    ISPX        RETURN

 ISPA     BSS    0           INITIAL FIRST WORD OF THE SCIPT
          VFD    16/0        UNUSED FIELD

          VFD    1/1         *SCD* DEFINITION CHANGED
          VFD    1/0         *MDD* DEFINITION NOT CHANGED
          VFD    1/0         NO CHANGE IN TABLE LENGTH
          VFD    1/0         INTERLOCK = CLEAR
          VFD    2/0         UNUSED FIELD
          VFD    6/0         *SCI* PP NUMBER
          VFD    4/4         LENGTH OF *SCI* PARAMETER TABLE

          VFD    4/0         *SCD* DEFINITION BYTE
          VFD    1/1         CONSOLE STATE = ACTIVE
          VFD    2/2         SYSTEM STATE = VIRTUAL STATE
          VFD    3/1         CONSOLE EMULATES A 721
          VFD    3/0         CONTROLWARE CODE = NO CONTROLWARE
          VFD    3/0         *SCD* PORT NUMBER = PORT 0 ONLY

          VFD    16/0        *MDD* MODE NOT ALLOWED
 LBS      SPACE  4,10
**        LBS - LOAD AND BUILD THE SSR.
*
*         EXIT   SSR LOADED.
*
*         USES   W1 - W5.
*
*         CALLS  CSC, INS, LCP, MCS, SSR, *AAC*.
*
*         MACROS SSRE.


 LBS15    SSRE   BYVE        CLEAR TERMINATION STATUS FLAG
          LDN    0
          STD    W5
          LDDL   W1
          RJM    INS         UPDATE CLEARED *BYVE* ENTRY
          CWDL   W2
          SSRE   DTYP        CLEAR DEADSTART TYPE
          LDN    0
          STD    W4
          STD    W5
          LDDL   W1
          RJM    INS         UPDATE CLEARED *DTYP* ENTRY
          CWDL   W2
 LBS20    SSRE   WAIT        SET OPERATOR PAUSE FLAG
          LDM    WAIT
          STD    W5
          LDDL   W1
          RJM    INS         REWRITE *WAIT* ENTRY
          CWDL   W2

 LBS      SUBR               ENTRY/EXIT
          RJM    SSR         GET SSR ADDRESS
          LDD    SA
          ADD    SA+1
          ZJN    LBS5        IF THE SSR IS NOT ALREADY DEFINED
          RJM    CSC         CREATE SSR CHECKSUM
          LDD    T4          CHECK IF *SCKS* ENTRY FOUND
          ZJN    LBS5        IF *SCKS* ENTRY NOT FOUND
          LDDL   W5          COMPARE CHECKSUMS
          LMDL   T3
          ZJP    LBS15       IF SSR CHECKSUM VERIFIES

 LBS5     BSS    0
          CODE   D
          LRD    LA
          LDC    3RSSR
          RJM    LCP         LOAD PROGRAM FROM COMMON DISK AREA
          CODE   *
          LMN    RCNE        CHECK FOR NO ERROR ON REQUEST
          ZJN    LBS10       IF *DFT* REQUEST COMPLETED WITH NO ERROR
          LDC    DASS        622 - *SCI* DETECTED *DFT* ERROR WHILE LOADING SSR
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR

 LBS10    RJM    MCS         MOVE AND COMPLETE THE SSR
          LJM    LBS20       SET THE OPERATOR PAUSE FLAG


**        MCS - MOVE AND COMPLETE SSR.
*
*         ENTRY  (LA - LA+1) = R-REGISTER OF ADDRESS OF TEMPORARY SSR LOCATION.
*                (SZ - SZ+1) = CURRENT MEMORY SIZE.
*
*         EXIT   (SZ - SZ+1) = UPDATED MEMORY SIZE.
*                SSR POINTER SET IN THE EICB.
*                SSR MOVED TO PERMANENT LOCATION.
*
*         USES   CM - CM+3, CN - CN+3, W0 - W5.
*
*         CALLS  CCM, CPY, CSC, IIB, INS, SPB.
*
*         MACROS SSRE.


*         DETERMINE MEMORY ADDRESS WHERE THE SSR WILL RESIDE.

 MCS      SUBR               ENTRY/EXIT
          LDC    RR+1
          LRD    LA
          CRDL   W0          READ SSR DIRECTORY HEADER
          LDC    1000        NOS STACK FRAME AREA
          ADDL   W1          ADD THE SSR LENGTH
          STDL   CN+3
          ADN    77          ROUND UP TO NEAREST 100B WORD MULTIPLE
          SHN    -6          SUBTRACT SSR LENGTH FROM MEMORY SIZE
          LMC    7777
          ADN    1           FORM TWOS COMPLEMENT AND ADD
          RAD    SZ+1
          SHN    -14
          ADC    7777
          RAD    SZ
          LDM    HPSM
          LMC    7777
          LPDL   SZ+1        ROUND ADDRESS TO A PAGE SIZE
          STD    SZ+1

          LDN    BCTP
          CRDL   CM
          LDC    0#30C       LEVEL 780(10)
          STDL   T1
          LDDL   CM+1
          SBDL   T1
          PJN    MCS0        IF LEVEL SUPPORTS DFT REQUEST
          UJP    MCS1        IGNORE MAKING THE REQUEST

 MCS0     LDN    0
          STDL   CM+3
          STDL   CM+2
          STML   IDRA
          STDL   CM
          LDDL   SZ
          STML   IDRA+1      START R UPPER
          LDDL   SZ+1
          STML   IDRA+2      START R LOWER
          LDDL   W1          PAGE TABLE LENGTH IN WORDS
          SHN    -6          /100B
          STML   IDRA+3
          LDN    1
          SHN    8D
          STDL   CM+1
          LDN    GGM
          RJM    IDR         ISSUE DFT REQUEST
          LMN    RCNF
          ZJN    MCS1        IF COULDN'T GET FLAW FREE MEMORY
          LMN    RCNE&RCNF
          NJP    MCS2        IF ERROR FROM DFT
          LDDL   CD
          LMC    RR+2
          CRDL   T0          READ RESPONSE
          LDDL   T1
          STDL   SZ
          LDDL   T2
          STDL   SZ+1        REWRITE SZ WITH FLAW FREE RESPONSE
 MCS1     LRD    SZ
          SRD    CN+1
          LDN    0
          STD    CM
          STD    CM+3
          STD    CN
          STM    SAAO
          RJM    SPB         SET PP BOUNDARY
          LDDL   CN+3        SSR SIZE
          RJM    CCM         CLEAR SSR AREA
          LRD    SZ          MOVE SSR DIRECTORY TO 170 STACK + 1000
          SRD    SA
          LDN    1000/100
          RAD    SA+1
          STD    CM+2
          SHN    -14
          RAD    SA
          STD    CM+1

*         SET SSR POINTER INTO THE *EICB*.

          LRD    IB+1
          RJM    SPB         SET PP BOUNDARY
          LDN    D8SSR
          RJM    IIB
          CWDL   CM          SET SSR POINTER INTO THE EICB
          LDN    3           SET LOCATION OF DIRECTORY IMAGE
          STD    CN
          LRD    LA
          SRD    CN+1
          RJM    SPB         SET PP BOUNDARY
          LDC    RR+1
          LRD    LA
          CRDL   W0          RE READ THE SSR LENGTH ENTRY
          LDD    W3          SSR DIRECTORY LENGTH
          RJM    /A/CPY      COPY SSR DIRECTORY TO UPPER MEMORY
          RJM    CSC         CREATE SSR CHECKSUM
          SSRE   SCKS        GET SSR CHECKSUM ENTRY
          LDDL   T3          SET NEW CHECKSUM
          STDL   W5
          LDDL   W1          REWRITE SSR CHECKSUM ENTRY
          RJM    INS
          CWDL   W2
          LJM    MCSX        RETURN

 MCS2     LDC    DAFF
          LJM    AAC         DFT ERROR TRYING TO GET FLAW FREE MEMORY
*COPY  CTP$SCI_CREATE_SSR_CHECKSUM
          QUAL   A
*COPY  CTP$SCI_COPY_CM_DATA
          QUAL   *
 LVC      SPACE  4,10
**        LVC - LOAD VCB.
*
*         EXIT   TO *AAC* IF ERROR RETURNED ON *DFT* REQUEST.
*
*         CALLS  BHR, LCP, RMP.


 LVC5     RJM    RMP         RELOCATE MONITOR PROCESS

 LVC      SUBR               ENTRY/EXIT
          RJM    BHR         BUILD HARDWARE REGISTER
          CODE   D
          LRD    BL
          LDC    3RVCB
          RJM    LCP         LOAD PROGRAM FROM CDA
          CODE   *
          LMN    RCNE        CHECK FOR NO ERROR ON REQUEST
          ZJN    LVC5        IF *DFT* REQUEST COMPLETED WITH NO ERROR
          LDC    DASV        623 - *SCI* DETECTED *DFT* ERROR WHILE LOADING VCB
          LJM    AAC         ACTIVATE ANALYSIS CODE ERROR PROCESSOR
 MCN      SPACE  4,10
**        MCN - MOVE CIO ENTRIES TO NIO ENTRIES IN THE RESOURCE TABLE.
*
*         ENTRY  (T3) = OFFSET OF CIO CHANNEL 32 ENTRY.
*                (T4) = OFFSET OF NIO CHANNEL 32 ENTRY.
*                (CBUF) = THE RESOURCE TABLE.
*
*         EXIT   CIO CHANNELS 32 AND 33 ENTRIES MOVED TO NIO CHANNELS 32 AND 33.
*                CIO CHANNELS 32 AND 33 ENTRIES ARE MADE UNAVAILABLE.


 MCN      SUBR               ENTRY/EXIT
          LDML   CBUF,T3     GET CIO CHANNEL 32 STATUS
          STML   CBUF,T4     STORE IN NIO CHANNEL 32 ENTRY
          LDML   CBUF+1,T3   GET CIO CHANNEL 33 ENTRY
          STML   CBUF+1,T4   STORE IN NIO CHANNEL 33 ENTRY
          LDC    0#0F0F      RESET CIO CHANNEL 32 AND 33 TO UNAVAILABLE
          STML   CBUF,T3
          STML   CBUF+1,T3
          UJN    MCNX        RETURN
 PPC      SPACE  4,15
**        PPC - PROCESS PP/CHANNEL FIELDS OF RESOURCE TABLE.
*
*         ENTRY  (T6) = IOU SUB-ELEMENT.
*                (PPCA) SET UP FOR PP OR CHANNEL PROCESSING.
*                (MION) = 1 IF IOU1 IS LOGICALLY ON.
*
*         EXIT   (CBUF) = RESOURCE TABLE WITH PP/CHANNEL FIELDS SET TO
*                         REFLECT THE HARDWARE CONFIGURATION.
*                TO *FED* IF REQUIRED ELEMENT DESCRIPTOR NOT PRESENT.
*
*         USES   CM+2, T3, T4, T5.
*
*         CALLS  FED, IGD.


 PPC      SUBR               ENTRY/EXIT
          LDN    0           PROCESS IOU0 FIRST
          STD    T5
          LDN    IRTL/4      SET OFFSET TO CIO PORTION OF TABLE
          STD    T4
 PPC5     LDDL   T6          SET IOU SUB-ELEMENT
          STDL   CM+2
          LDD    T5          PICK UP IOU1 FLAG
          SHN    4
          ADN    EIDIOU0     GET IOU ELEMENT DESCRIPTOR
          ERRNZ  0#10+EIDIOU0-EIDIOU1  CODE ASSUMES DIFFERENCE OF 10(16)
          RJM    IGD         ISSUE GET ELEMENT DESCRIPTOR *DFT* REQUEST
          ZJP    FED         IF ELEMENT NOT PRESENT
          LDN    0           INITIALIZE DESCRIPTOR INDEX
          STD    T3
 PPC10    LDML   HBUF,T3     CHECK PP/CHANNEL ENTRY
          SHN    -8D
          NJN    PPC15       IF NOT PHYSICALLY PRESENT OR NOT LOGICALLY ON
          LDML   CBUF,T4     SET PP/CHANNEL AVAILABLE IN TABLE
          LPC    0#FF00      PRESERVE CHANNEL STATUS
 PPCA     EQU    *-2
*         LPC    0#FF        (PRESERVE PP STATUS)
          STML   CBUF,T4
 PPC15    AOD    T4          INCREMENT RESOURCE TABLE OFFSET
          SBM    PPCC,T5
          NJN    PPC20       IF NOT SWITCHING BARRELS
          LDN    4           INCREMENT RESOURCE TABLE OFFSET TO NEXT BARREL
          RAD    T4
 PPC20    AOD    T3          INCREMENT DESCRIPTOR INDEX
          SBN    IOSUBL
          NJN    PPC10       IF NOT END OF PP/CHANNEL ENTRIES
          LDM    MION        CHECK FOR SECOND IOU
          ZJN    PPC25       IF NO SECOND IOU
          LDD    T5          CHECK IF IOU1 ALREADY PROCESSED
          NJN    PPC25       IF IOU1 ALREADY PROCESSED
          AOD    T5          SET IOU 1
          LDN    IRTL/4      SET OFFSET TO IOU1 CIO PORTION OF TABLE
          SHN    1
          ADN    IRTL/4
          STD    T4
          LJM    PPC5        PROCESS IOU1

 PPC25    LJM    PPCX        RETURN

*         WHEN THE RESOURCE TABLE OFFSET HITS THIS CONSTANT, INCREMENT TO
*         THE NEXT BARREL.

 PPCC     CON    50,140
 PRS      SPACE  4,15
**        PRS - PRESET VPB/CYBER 2000.
*
*         ENTRY  (T1) = SAVED CONTENTS OF *DOFF*.
*                (SCIA) = 4000, IF RESTART.
*
*         EXIT   UNUSED PP MEMORY ZEROED OUT.
*                VARIABLES PRESET.
*                CHANNELS 15 AND 17 DEACTIVATED.
*                RESIDENT OVERLAY LOADED.
*                IDLE OVERLAY LOADED.
*                MAINTENANCE REGISTER EXIT ADDRESSES SET UP.
*                (BOCT) = BOOT CONTROL TABLE CONTENTS.
*                (IDRB) = *INPN* INSTRUCTION.
*
*         CALLS  LRO.
*
*         MACROS EXITMR, FATALMR.


 PRS      SUBR               ENTRY/EXIT
          LDM    /PRESET/SCIA  SAVE RESTART FLAG
          STM    DTEA

*         ZERO OUT ALL CELLS BEFORE THIS OVERLAY EXCEPT SC - SC+2 AND
*         THE AREA WHERE THE PRESET OVERLAY EXISTS.

          LDDL   SC          SAVE *SC*
          STDL   T2
          LDDL   SC+1        SAVE *SC+1*
          STDL   T3
          LDDL   SC+2        SAVE *SC+2*
          STDL   T4
          LDN    T6          SET STARTING ADDRESS
          STD    T5
 PRS5     LDN    0           CLEAR CELL
          STIAO  T5
          LMC    100
          NJN    PRS5        IF MORE TO CLEAR
          LDDL   T2          RESET *SC*
          STDL   SC
          LDDL   T3          RESET *SC+1*
          STDL   SC+1
          LDDL   T4          RESET *SC+2*
          STDL   SC+2
          LDC    EOC         SET STARTING ADDRESS
          STD    T5
 PRS10    LDN    0           CLEAR CELL
          STIAO  T5
          LMC    CY2OVL
          NJN    PRS10       IF MORE TO CLEAR
          LDDL   T1          RESTORE CONTENTS OF *DOFF*
          STML   DOFF

*         SET VARIABLES AND DIRECT CELLS.  THOSE VARIABLES THAT EQUAL ZERO
*         HAVE ALREADY BEEN SET BY THE CLEARING OF MEMORY.

*         LDN    0
*         STM    CTUF        NOT UTILITY MODE *MDD*
*         STM    PPTY        UPPER PP
*         STM    SCDP        *SCD* PORT = 0
          LDN    1
          STD    DO          DEADSTART ORIGIN = 180 DEADSTART
          STD    ON          CONSTANT ONE
          STD    VA          NOS/VE ACTIVE
          STM    NOSL        NOT LOADED BY NOS
          STM    ISPB        IGNORE BOUNDS SETTINGS
          LDC    10000B      SET CYBER 2000 FLAG IN MACHINE TYPE WORD
          STML   S0FLG

*         FETCH THE BOOT CONTROL TABLE AND SAVE VARIABLES FROM IT.

          LDN    BCTIL       SET BOOT CONTROL TABLE INFORMATION LENGTH
          STD    T4
          LDN    BCTP        ADDRESS OF BOOT CONTROL TABLE
          CRML   BOCT,T4
          SBN    1
          CRDL   CD          SAVE THE CIP DIRECTORY POINTER FOR *BCT*
          LDML   BOCT+BCTTY  SAVE THE IOU MODEL NUMBER
          STML   IOUM
          LDML   BOCT+BCTIP  SAVE THE PP NUMBER
          LPC    377
          STM    PPNO
          LDML   BOCT+BCTFL  SAVE THE OPERATOR PAUSE FLAG
          SHN    -BCTOP
          LPN    1
          STM    WAIT

*         DEACTIVATE CHANNELS 15 AND 17 AND LOAD OVERLAYS.

          DCN    MR+40
          DCN    MX+40
          CCF    *,MX
          RJM    LRO         LOAD RESIDENT AND IDLE OVERLAYS

*         SET UP MAINTENANCE REGISTER ADDRESSES.

          EXITMR AAC         SET MAINTENANCE REGISTER READ EXIT ADDRESS
          FATALMR  AAC       SET FATAL MAINTENANCE REGISTER EXIT ADDRESS
          LJM    PRSX        RETURN
 BOCT     SPACE  4,10
**        BOCT - BOOT CONTROL TABLE BUFFER.


 BOCT     BSS    BCTIL*4     CONTENTS OF BOOT CONTROL TABLE INFORMATION WORDS
          EJECT
*         COMMON DECKS.
          SPACE  4,10
*COPY     CTP$SCI_ADVANCE_LOAD_ADDRESS
*COPY     CTP$SCI_BUILD_HARDWARE_REG
*COPY     CTP$SCI_BUILD_PAGE_TABLE
*COPY     CTP$SCI_CLEAR_CENTRAL_MEMORY
*COPY     CTP$SCI_COMPRESS_PAGE_TABLE
*COPY     CTP$SCI_COPY_CM_DATA
*COPY     CTP$SCI_COPY_TO_SAVE_AREA
*COPY     CTP$SCI_DELAY_ROUTINE
*COPY     CTP$SCI_FETCH_CM_BOUND_VALUES
*COPY     CTP$SCI_INCREMENT_DFT_BUFFER
*COPY     CTP$SCI_INCREMENT_DFT_VE_BLOCK
*COPY     CTP$SCI_LOAD_CIP_PROGRAM
*COPY     CTP$SCI_PRESET_EICB_MSG_BUFFER
*COPY     CTP$SCI_RELOCATE_MPS_REGISTERS
*COPY     CTP$SCI_SET_UP_PROCESSOR_REQ
*COPY     CTP$SCI_SET_IOU_NUMBER
*COPY     CTP$SCI_TIMEOUT_DFT_VERIFIED
*COPY     CTP$SCI_UPDATE_MEMORY_BOUNDS
*COPY     CTP$SCI_VERIFY_MEMORY_BOUNDS
*COPY     CTP$SCI_ZERO_PP_BUFFER

*  THE FOLLOWING IS A BUFFER ALLOCATED BECAUSE THE SIZE OF SCI HAS GOTTEN TO
*  THE POINT WHERE ON THE CYBER 2000 AND OTHER MACHINES WITH A DLD A GLITCH IN
*  THE OS BOOT LOAD PROCESS ISN'T CAPABLE OF DEALING WITH THE RECORD SIZE OF SCI
*  AND A BOOT LOAD ERROR OCCURS. THE FOLLOWING BUFFER WILL INCREASE SCI SIZE PAST
*  THE PROBLEM.


 DUMMY    BSSZ      100



          OVERFLOW  20000    CHECK FOR PP OVERFLOW

          ENDX
*DECK DECK=CTP$SCI_VPB_IDLE_IOU0 EXPAND=FALSE
          CTEXT  CTP$SCI VPB IDLE IOU0
          SPACE  4,10
          BASE   M
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 IAD      SPACE  4,15
**        IAD - IDLE ALL I/O DRIVERS IN IOU 0.
*
*         ENTRY  (CBUF) = PP/CHANNEL MAP.
*
*         EXIT   FOR IOU 0, ALL PPS IN THE MAP IDLED AND CHANNELS
*                DCN-D.
*
*         NOTE   ON AN S0/S0E, CHANNELS IN CLUSTER 2 ARE *NOT* DCN-D.
*
*         CALLS  IVP.
*
*         USES   T3, T4, T5, T7.


 IAD      SUBR               ENTRY/EXIT
          LDN    34          INITIALIZE TABLE SIZE
          STD    T7
          SHN    1
          STD    T5
          LDN    0
          STD    T4
 IAD10    LDM    CBUF,T4
          SHN    21-7
          PJN    IAD40       IF PP IS NOT USED
          LDD    T4
          SBD    T7
          PJN    IAD20       IF CIO PP
          LDD    T4
          UJN    IAD30       IDLE VE PP

 IAD20    LDN    1S5         CIO BIT
          SHN    10-5
          LMD    T4          ADD PP NUMBER
          SBD    T7
 IAD30    RJM    IVP         IDLE VE PP
          LDML   CBUF,T4
          LPC    0#FF00
          STML   CBUF,T4
 IAD40    AOD    T4          INCREMENT TO NEXT PP IN TABLE
          SBD    T5
          NJN    IAD10       IF MORE PP-S TO IDLE
*         LDN    0
          STD    T3
 IAD50    LDML   CBUF,T3     CHECK CHANNEL STATUS
          SHN    21-17
          PJN    IAD70       IF UNUSED CHANNEL
          LDD    T3
          SBD    T7
          PJN    IAD60       IF CIO CHANNEL
          LDD    T3
          ADC    DCNI+40     DEACTIVATE POSSIBLE ACTIVE CHANNEL
          STM    IADA
 IADA     DCN    **+40
 IAD60    LDML   CBUF,T3
          LPC    0#00FF
          STML   CBUF,T3
 IAD70    AOD    T3          INCREMENT TO NEXT CHANNEL IN TABLE
          SBD    T5
          NJN    IAD50       IF MORE CHANNELS TO DEACTIVATE
          LJM    IADX        RETURN
 IVP      SPACE  4,10
**        IVP - IDLE VE PP.
*
*         ENTRY  (A) = PP TO IDLE.
*
*         USES   T3.
*
*         CALLS  IDP, SCF.


 IVP10    LDD    T3
          RJM    IDP         IDLE PP
 IVP20    CCF    *,MX

 IVP      SUBR               ENTRY/EXIT
          STD    T3
          LDN    MX
          RJM    SCF         INTERLOCK TWO PORT MUX
          LDM    S0FLG       TEST IOU TYPE
          ZJN    IVP10       IF NOT AN S0/S0E
          LDD    T3
          RJM    /"PRGNAM"AD/IDP
          UJN    IVP20       CLEAR CHANNEL FLAG AND EXIT


          BASE   *
          ENDX

*DECK DECK=CTP$SCI_ZERO_PP_BUFFER EXPAND=FALSE
          SPACE  4,10
*         CTEXT  CTP$SCI ZERO PP BUFFER.
*
*         THIS DECK CONTAINS A ROUTINE WHICH CAN BE USED TO ZERO OUT
*         THE *MBUF* BUFFER IN *SCI*.
 ZPB      SPACE  4,10
**        ZPB - ZERO PP BUFFER.
*
*         ENTRY  (A) = AMOUNT TO CLEAR.
*
*         EXIT   (MBUF - MBUF+A*4) = CLEARED.
*                (T1) = SIZE CLEARED.
*
*         USES   T4.


 ZPB      SUBR               ENTRY/EXIT
          STD    T1
          SHN    2
          STD    T4
 ZPB5     LDN    0           CLEAR MEMORY BUFFER
          STM    MBUF-4,T4
          STM    MBUF-3,T4
          STM    MBUF-2,T4
          STM    MBUF-1,T4
          LCN    4
          RAD    T4
          NJN    ZPB5        IF MORE BUFFER TO CLEAR
          UJN    ZPBX        RETURN

*         ENDX   CTP$SCI ZERO PP BUFFER.

*DECK DECK=CTP$SYSTEM_CONSOLE_DRIVER EXPAND=TRUE
          IDENT  SCDB,70B
          END
/EOR
*DECK DECK=CTP$UPDATE_TIME_IN_EICB EXPAND=FALSE
          CTEXT  CTP$UPDATE TIME IN EICB
          SPACE  4,10
 QUAL$    IF     -DEF,QUAL$
          QUAL   CTPUTE
 QUAL$    ENDIF
          BASE   M
*         COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4,10
***       USAGE NOTES FOR THIS COMMON DECK.
*
*         THIS COMMON DECK ASSUMES THAT THERE IS AN UNQUALIFIED
*         ENTRY POINT, *FTE*.  THIS ENTRY POINT WILL BE JUMPED TO
*         TO HANDLE THE CASE OF THE INABILITY TO DESELECT THE
*         TWO PORT MUX AFTER ATTEMPTING TO READ THE WALL CLOCK CHIP.
*
*         IF THE SYMBOL *NPERR* IS DEFINED, THEN THIS DECK WILL
*         USE THAT LOCATION TO COUNT THE NUMBER OF PARITY ERRORS
*         DETECTED ON CH15.  *NPERR* MUST BE INITIALIZED TO ZERO.
          SPACE  4,10
**        VARIABLES GLOBAL TO COMMON DECK.


 DELAY    EQU    1205D/4     MAXIMUM DELAY FOR MUX ACCESS (1.205 SECONDS)
 UTE      SPACE  4,10
**        UTE - UPDATE TIME IN EICB FROM WALL CLOCK CHIP.
*
*         ENTRY  (IB - IB+2) = RFA OF EICB.
*                (IOUM) = IOU MODEL NUMBER.
*
*         EXIT   EICB WALL CLOCK TIME UPDATED.
*
*         USES   T1, T2, T3, T4.
*
*         CALLS  IIB, RWC, SPB.


 UTE20    STD    T0          SAVE RESULT
          LDC    UTEA
          STD    T1          FIRST
          ADN    4           BUFFER LENGTH
          STD    T2          LIMIT
          LDC    177777      COULD NOT ACCESS CHIP VALUE
          STDL   T3
          LDD    T0
          SBN    1
          ZJN    UTE30       IF COULD NOT ACCESS CHIP
          LDN    0           I2 TIMESTAMP VALUE
          STDL   T3
 UTE30    LDDL   T3
          STIL   T1
          AOD    T1
          SBD    T2
          MJN    UTE30       IF BUFFER NOT FULL
 UTE40    LRD    IB+1        GET INTERFACE BLOCK R-POINTER
          RJM    SPB         SET PP BOUNDS
          LDN    D8WT
          RJM    IIB
          CWML   UTEA,ON     WRITE THE VALUE IN THE EICB

 UTE      SUBR               ENTRY/EXIT
          LDN    D7TY        TEST *EICB* LEVEL
          RJM    IIB
          CRDL   T4          READ *D7TY*
          LDD    T7          LOAD 12 BITS
          SHN    -6          EXTRACT EICB REVISION LEVEL
          SBN    4
          MJN    UTEX        IF WALL CLOCK CHIP BUFFER NOT PRESENT
          LDC    UTEA
          RJM    RWC         READ WALL CLOCK CHIP
          NJP    UTE20       IF CLOCK NOT READ PROPERLY

*         PACK TIME DATA AND WRITE TO CM.

          LDC    UTEA
          STD    T2
          STD    T3
          ADN    4
          STD    T4
 UTE10    LDI    T2
          SHN    10
          LMM    1,T2
          STIL   T3
          AOD    T2
          AOD    T2
          AOD    T3
          SBD    T4
          NJN    UTE10       IF PACKING NOT COMPLETE
          UJP    UTE40       WRITE RESULT AND RETURN

 UTEA     BSS    2*4         WALL CLOCK CHIP READ/WRITE BUFFER
 RWC      SPACE  4,15
**        RWC - READ WALL CLOCK CHIP.
*
*         ENTRY  (A) = FWA OF 8 PP WORD RESULT BUFFER.
*                (IOUM) = IOU MODEL NUMBER.
*
*         EXIT   (A) = 0, IF WALL CLOCK CHIP READ OK.
*                (RESULT BUFFER) = CLOCK DATA.
*                (A) = -1, IF MODEL 20 IOU.
*                (A) = 1, IF COULD NOT ACCESS WALL CLOCK CHIP.
*
*         USES   T3, T4.
*
*         CALLS  AMA, CTE, ICT, IFN, RMA.


 RWC100   LCN    1

 RWC      SUBR               ENTRY/EXIT
          STM    RWCA        SAVE FWA OF BUFFER
          STD    T3
          LDM    IOUM
          SBK    0#20
          ZJN    RWC100      IF MODEL 20 IOU
          LDC    LDNI
          STM    RWCB        INITIALIZE TO NO INPUT ERROR
          LDC    100D        SET CHECK COUNTER
          STML   RWCC
          RJM    AMA         ACQUIRE MULTIPLEXOR ACCESS
          NJN    RWCX        IF ACCESS NOT POSSIBLE NOW

*         READ DATA FROM THE WALL CLOCK CHIP.  IF THE DATA DOES NOT
*         APPEAR WITHIN *DELAY* AMOUNT OF TIME, THEN AN ERROR CONDITION
*         WILL BE FLAGGED.

          LDC    MXRW        READ WALL CLOCK
          RJM    IFN         ISSUE FUNCTION
          NJN    RWCX        IF FUNCTION TIMED OUT
          RJM    ICT         INITIALIZE CTE
          ACN    MX
 RWC10    SOML   RWCC        CHECK IF TIME CHECK NEEDED
          NJN    RWC30       IF NOT NEEDED
          LDC    100D        RESET CHECK COUNTER
          STML   RWCC
          RJM    CTE         CHECK FUNCTION TIMEOUT EXPIRED
          PJN    RWC30       IF NOT TIMED OUT
 RWC20    AOM    RWCB        SET ERROR FLAG
          UJN    RWC40       DESELECT

 RWC30    IJM    RWC20,MX    IF INACTIVE
          EJM    RWC10,MX    IF EMPTY
          LDN    10
          IAM    **,MX
 RWCA     EQU    *-1
 RWC40    DCN    MX+40
          SFM    RWC50,MX    IF PARITY ERROR
          ZJN    RWC70       IF ALL BYTES OF WALL CLOCK READ
          UJN    RWC60       SET ERROR FLAG

 RWC50    BSS    0
 .A       IF     DEF,NPERR
          AOML   NPERR
 .A       ENDIF
 RWC60    AOM    RWCB        SET ERROR FLAG
 RWC70    RJM    RMA         RELEASE MULTIPLEXER ACCESS
 RWCB     LDN    0
*         LDN    1           (ERROR ON INPUT)
*         LDN    2           (ERROR ON INPUT)
          NJN    RWC90       IF INPUT ERROR
          LDI    T3
          NJN    RWC90       IF INTEGRITY HAS BEEN LOST
 RWC80    UJP    RWCX        RETURN

 RWC90    LDN    1
          UJN    RWC80       RETURN

 RWCC     BSS    1           CHECK TIME COUNTER
 AMA      SPACE  4,10
**        AMA - ACQUIRE MULTIPLEXER ACCESS.
*
*         EXIT   (A) = 0, IF MULTIPLEXER ACCESS OBTAINED.
*                      1, IF ACCESS NOT OBTAINED.
*
*         CALLS  CTE, ICT, IFN.


 AMA50    LDN    1           ACCESS NOT OBTAINED

 AMA      SUBR               ENTRY/EXIT
          RJM    ICT         INITIALIZE CTE
 AMA10    SCF    AMA30,MR    GET ACCESS TO MAINTENANCE CHANNEL
          SCF    AMA20,MX    GET ACCESS TO TWO-PORT MULTIPLEXER
          CCF    *,MR
          LDC    MXPT        PORT SELECT FUNCTION
          RJM    IFN         SELECT PORT
          ZJN    AMAX        IF PORT SELECT WORKED
          CCF    *,MX
          UJN    AMAX        RETURN

 AMA20    CCF    *,MR        CLEAR MAINTENANCE CHANNEL INTERLOCK
 AMA30    LDN    77          BRIEF DELAY
 AMA40    SBN    1
          PJN    AMA40       IF DELAY NOT COMPLETE
          RJM    CTE         CHECK TIMEOUT EXPIRED
          MJN    AMA50       IF ACCESS NOT OBTAINED
          UJN    AMA10       TRY TO RESERVE PORT AGAIN
 CTE      SPACE  4,10
**        CTE - CHECK TIMEOUT EXPIRED.
*
*         ENTRY  (T0) = TIMEOUT REMAINING IN 4096 MICROSECOND UNITS.
*
*         EXIT   (A) = NEGATIVE IF TIMED OUT.
*                (T0) = UPDATED IF 4096 MICROSECOND ELAPSED.
*
*         USES   T0.


 CTE10    RAM    CTEA        SET NEW CLOCK VALUE

 CTE      SUBR               ENTRY/EXIT
          IAN    14
          LPC    7777
          SBM    CTEA        MICROSECONDS SINCE LAST CHECK
          PJN    CTE10       IF LESS THAN 4096 MICROSECONDS
          RAM    CTEA
          SODL   T0          DECREMENT TIMEOUT COUNT
          UJN    CTEX        RETURN

 CTEA     CON    0           REAL TIME CLOCK STORAGE
 ICT      SPACE  4,10
**        ICT - INITIALIZE CTE.
*
*         EXIT   (T0) = NUMBER OF 4 MILLISECOND CYCLES.
*                (CTEA) = 12 BIT CURRENT CLOCK VALUE.


 ICT      SUBR               ENTRY/EXIT
          LDK    DELAY
          STDL   T0
          IAN    14
          STM    CTEA
          UJN    ICTX        RETURN
 IFN      SPACE  4,20
**        IFN - ISSUE FUNCTION.
*
*         ISSUE CHANNEL FUNCTION TO FUNCTION TWO-PORT MUX HARDWARE.
*         IF THE TWO-PORT MULTIPLEXER FAILS TO REPLY TO THE FUNCTION
*         WITHIN *DELAY* SECONDS, *IFN* EXITS TO THE ERROR PROCESSOR
*         *FTE*.
*
*         ENTRY  (A) = FUNCTION TO BE ISSUED.
*                PORT SELECTED.
*
*         EXIT   (A) = 0, IF FUNCTION DID NOT TIME OUT.
*                      1, IF FUNCTION TIMED OUT.  CH15 RELEASED.
*
*         CALLS  CTE, ICT, RMA.


 IFN50    LDN    0           FUNCTION COMPLETED NORMALLY

 IFN      SUBR               ENTRY/EXIT
          STM    IFNA        SAVE FUNCTION CODE
          DCN    MX+40       INSURE CHANNEL DISCONNECT
          FAN    MX          ISSUE FUNCTION CODE
          RJM    ICT         INITIALIZE CTE

*         WAIT FOR CHANNEL DISCONNECT.

 IFN10    IJM    IFN50,MX    IF FUNCTION COMPLETE
          RJM    CTE         CHECK TIMEOUT EXPIRED
          PJN    IFN10       IF NOT TIMED-OUT
          DCN    MX+40       DISCONNECT CHANNEL
          CFM    IFN20,MX    IF NO PARITY ERROR
 .A       IF     DEF,NPERR
          AOML   NPERR
 .A       ENDIF
 IFN20    LDC    **
 IFNA     EQU    *-1
          STM    IFNC
          LMC    MXPT
          ZJN    IFN30       IF SELECT FUNCTION
          LMC    MXDM&MXPT
          ZJN    IFN40       IF DESELECT FAILED
          LDM    IFN         SAVE RETURN ADDRESS (RMA CALLS IFN)
          STM    IFNB
          RJM    RMA         RELEASE MULTIPLEXER ACCESS
          LDM    IFNB        RESTORE RETURN ADDRESS
          STM    IFN
 IFN30    LDN    1           INDICATE ERROR
          UJP    IFNX        RETURN

 IFN40    LDC    DAWC        616 - WALL CLOCK CHIP READ ERROR
          LJM    FTE         EXIT TO FATAL ERROR PROCESSOR

 IFNB     BSS    1           RETURN ADDRESS
 IFNC     BSS    1           LAST FUNCTION ISSUED WITH ERROR
 RMA      SPACE  4,10
**        RMA - RELEASE MULTIPLEXER ACCESS.
*
*         ENTRY  TWO-PORT MUX IS RESERVED BY THIS PP.
*
*         EXIT   TWO-PORT MUX IS DESELECTED AND CHANNEL IS RELEASED.
*
*         CALLS  IFN.


 RMA      SUBR               ENTRY/EXIT
          LDC    MXDM        DESELECT MULTIPLEXER
          RJM    IFN
          CCF    *,MX        RELEASE CHANNEL INTERLOCK
          UJN    RMAX        RETURN
          SPACE  4,10


          BASE   *
 QUAL$    IF     -DEF,QUAL$
          QUAL   *
 UTE      EQU    /CTPUTE/UTE
 RWC      EQU    /CTPUTE/RWC
 QUAL$    ENDIF
          ENDX
*DECK DECK=CTT$B60_GET_C170_77_TABLE EXPAND=FALSE

  TYPE
    b60_get_file_fill = 0..0f(16);

  TYPE
    b60_get_file_comment = packed record
      b60_comment_fill : b60_get_file_fill,
      dc_char1,
      dc_char2,
      dc_char3,
      dc_char4,
      dc_char5,
      dc_char6,
      dc_char7,
      dc_char8,
      dc_char9,
      dc_char10 : 0..77(8),
    recend;

{Any changes made to the type DST$B60_GET_C170_77_TABLE must
{also be made to the type DST$C170_77_TABLE.  Any changes made
{to the CASE statement must also be made to the type C170_TABLE_WORD
{in the module DSM$PROCESS_NOS_FILES.}

  TYPE
    dst$b60_get_c170_77_table = packed record
      first_word_fill : b60_get_file_fill,
      name,
      length : 0..7700(8),
      unused : 0..777777777777(8),
      second_word_fill : b60_get_file_fill,
      module_name : 0..77777777777777(8),
      fill : 0..777777(8),
      third_word_fill : b60_get_file_fill,
      date : packed array [1..9] of 0..77(8),
      datefill : 0..77(8),
      forth_word_fill : b60_get_file_fill,
      time : packed array [1..9] of 0..77(8),
      timefill : 0..77(8),
      fifth_word_fill : b60_get_file_fill,
      op_sys_id_1 : 0..7777777777(8),
      op_sys_id_2 : 0..7777777777(8),
      sixth_word_fill : b60_get_file_fill,
      processor_name : 0..77777777777777(8),
      processor_vers : 0..777777(8),
      seventh_word_fill : b60_get_file_fill,
      mod_level : 0..7777777777(8),
      target_processor,
      valid_processor : 0..0fff(16),
      compass_flag : 0..77(8),
      eigth_word_fill : b60_get_file_fill,
      program_flag : 0..77(8),
      hardware_requirements_1 : 0..7777777777(8),
      hardware_requirements_2 : 0..77777777(8),
      comments : packed array [1..7] of b60_get_file_comment,
      sixteenth_word_fill : b60_get_file_fill,
      CASE table_type : dst$table_id of
      = dsc$5000_table =
        l1,l2 : 0..77(8),
        fwa, lwa : 0..777777(8),
      = dsc$6100_table =
        first_word_address,
        load_address,
        code_length : 0..0ffff(16),
      = dsc$proc_table =
        proc_header: 0 .. 777777(8),
        unused1: 0 .. 7777777777(8),
      = dsc$text_table =
        nos_byte_1a: 0 .. 77(8),
        nos_byte_1b: 0 .. 77(8),
        nos_byte_2: 0 .. 7777(8),
        nos_byte_3: 0 .. 7777(8),
        nos_byte_4: 0 .. 7777(8),
      = dsc$word_table =
        table_type_word: 0 .. 7777777777777777(8),
      CASEND,
    recend;
*DECK DECK=CTT$C170_LOADER_TABLES EXPAND=FALSE
 TYPE
    ctt$c170_address = 0 .. 777777(8),
    ctt$c170_char = 0 .. 77(8),
    ctt$two_c170_chars = packed array [1 .. 2] of ctt$c170_char,
    ctt$three_c170_chars = packed array [1 .. 3] of ctt$c170_char,
    ctt$five_c170_chars = packed array [1 .. 5] of ctt$c170_char,
    ctt$c170_name = packed array [1 .. 7] of ctt$c170_char,
    ctt$nine_c170_chars = packed array [1 .. 9] of ctt$c170_char,
    ctt$ten_c170_chars = packed array [1 .. 10] of ctt$c170_char,
    ctt$c170_byte = 0 .. 7777(8),
    ctt$c170_parcel = 0 .. 77777(8),
    ctt$6_bits = 0 .. 77(8),
    ctt$12_bits = 0 .. 7777(8),
    ctt$15_bits = 0 .. 77777(8),
    ctt$18_bits = 0 .. 777777(8),
    ctt$24_bits = 0 .. 77777777(8),
    ctt$30_bits = 0 .. 7777777777(8),
    ctt$36_bits = 0 .. 777777777777(8),
    ctt$48_bits = 0 .. 7777777777777777(8);

  TYPE
    ctt$c170_prefix_table = packed record
      name: ctt$12_bits,
      length: ctt$12_bits,
      unused: ctt$36_bits,
      module_name: ctt$c170_name,
      fill2: ctt$c170_address,
      date,
      time: ctt$ten_c170_chars,
      operating_system_id: ctt$ten_c170_chars,
      processor_name: ctt$c170_name,
      processor_version: ctt$three_c170_chars,
      processor_mod_level: ctt$five_c170_chars,
      target_processor,
      valid_processors: ctt$two_c170_chars,
      compass_flag: ctt$c170_char,
      program_type: ctt$c170_char,
      hardware_requirements: ctt$nine_c170_chars,
      comments: packed array [1 .. 70] of ctt$c170_char,
    recend;

  TYPE
    ctt$c170_ascm_table = packed record
      name: ctt$12_bits,
      l1,
      l2: ctt$6_bits,
      fwa,
      lwa: ctt$c170_address,
    recend;
*DECK DECK=CYBMLI EXPAND=TRUE
          IDENT  CYBMLI
          TITLE  CYBMLI - CYBIL INTERFACE TO THE C170 MLI MACROS.
          SST
          ENTRY  MLSINON
          ENTRY  MLSINOF
          ENTRY  MLFERL
          ENTRY  MLRECM
          ENTRY  MLSENDM
          ENTRY  MLADDS
          ENTRY  MLDELS
          ENTRY  MLCONF
          ENTRY  INITMLI
          ENTRY  QFWAIT
          EXT    PXSAVE,ZSMRRET,PARSV
          LIST   F
          SYSCOM B1
LEAVE     EQU    ZSMRRET
          IF     -DEF,RA.ORG,1
OPL XTEXT COMCMAC
          LIST   X
*copy COMSMLI
*copy COMSCVS
*copy COMMMLI
*DUMPMLI   EQU    1           SPECIFY CALLVS DEBUG
*copy COMMCVS
*copy MLA$C170_MEMORY_LINK_INTERFACE
          TITLE  THE MAIN STUFF
*
* D. A. HENSELER  10/25/79.
*
INITMLI   BSS    0
          RJ     PXSAVE
          BX6    X1
          RJ     STO
NBESYS    IF     DEF,RA.ORG
          MX6    0
          SA6    NORERUN
          SYSTEM OUX,R,NORERUN,2000B   SET NORERUN FLAG
          EQ     LEAVE
NORERUN   BSS    1
NBESYS    ELSE
          EQ     LEAVE
NBESYS    ENDIF
*
MLSINON   BSS    0
          RJ     PXSAVE
          SIGNON PARSV,PARSV+1,X3,X4
          EQ     LEAVE
*
MLSINOF   BSS    0
          RJ     PXSAVE
          SIGNOFF PARSV,X2
          EQ     LEAVE
*
MLADDS    BSS    0
          RJ     PXSAVE
          ADDSPL PARSV,PARSV+1,X3
          EQ     LEAVE
*
MLDELS    BSS    0
          RJ     PXSAVE
          DELSPL PARSV,PARSV+1,X3
          EQ     LEAVE
*
MLSENDM   BSS    0
          RJ     PXSAVE
          BX3    X1          BECAUSE X1 GETS WRECKED BY MACRO
          SEND   B5,B5+1,X3,X2,PARSV+2,PARSV+3,X5
          EQ     LEAVE
*
MLRECM    BSS    0
          RJ     PXSAVE
          SA3    B5+B1
          SA2    A3+B1       SIGNAL
          SB6    X2
          SA2    A2+B1
          SB4    X2
          BX2    X1          BECAUSE X1 GETS WRECKED BY MACRO
          RECEIVE B5,X3,B6,B4,X2,PARSV+1,PARSV+2,X4,X5
          EQ     LEAVE
*
MLFERL   BSS    0
          RJ     PXSAVE
          FETCHRL PARSV,PARSV+1,X3,X4,X5
          EQ     LEAVE
*
MLCONF    BSS    0
          RJ     PXSAVE
          CONFIRM PARSV,PARSV+1,X3
          EQ     LEAVE
*
* A. J. H. GEERSEN  08/29/84. ( CHANGE FOR NOS/BE )
*
QFWAIT    RJ     =XPXSAVE
NOSSYS    IF     -DEF,RA.ORG
          ROLLOUT ROW
          EQ     LEAVE
ROW       VFD    36/NEEQ,24/15     FIFTEEN SECONDS
NOSSYS    ELSE                     NOS/BE CODE NEEDS SUBSYS INTERFACE
          PPARMD MLFSW,MLPFN
          RJ     MLI=
          EQ     LEAVE
NOSSYS    ENDIF
          END
*DECK DECK=CYC$DEFAULT_HEAP_NAME EXPAND=FALSE
  {The name of the default CYBIL heap.}

  CONST
    cyc$default_heap_name = 'cyb$default_heap               ';
*DECK DECK=CYC$ERROR_CODES_CYBIL_RANGE EXPAND=FALSE

  CONST
*IF $true(osv$unix)
    cyc$min_ecc = (($INTEGER ('C') * 100(16)) + $INTEGER ('Y')) * 10000(16),
*ELSE
    cyc$min_ecc = (($INTEGER ('C') * 100(16)) + $INTEGER ('Y')) * 1000000(16),
*IFEND
    cyc$max_ecc = cyc$min_ecc + 9999;

*DECK DECK=CYC$LOWERVALUE_INTEGER EXPAND=FALSE

  CONST
    cyc$lowervalue_integer = (-cyc$uppervalue_integer) - 1;

*copyc cyc$uppervalue_integer
*DECK DECK=CYC$MAX_STRING_SIZE EXPAND=FALSE

  CONST
    cyc$max_string_size = 0ffff(16);

*DECK DECK=CYC$UPPERVALUE_INTEGER EXPAND=FALSE

  CONST
*IF NOT $true(osv$unix)
    cyc$uppervalue_integer = 7fffffffffffffff(16);
*ELSE
    cyc$uppervalue_integer = 7fffffff(16);
*IFEND

*DECK DECK=CYCLE95_EXCEPTIONS EXPAND=TRUE
*DECK DECK=CYCLEA1_EXCEPTIONS EXPAND=TRUE
*DECK DECK=CYCLEA2_EXCEPTIONS EXPAND=TRUE
IF $variable(build_A202_status, declared)='UNKNOWN' THEN
  create_variable build_A202_status kind=status
IFEND
*IF bev$product_level = 'BUILD_A202'
   include_feature command_level_cond_handling_5   status=build_A202_status
   include_feature handle_monitor_dues             status=build_A202_status
*IFEND
*DECK DECK=CYCLEB1_EXCEPTIONS EXPAND=TRUE
*DECK DECK=CYCLEB2_EXCEPTIONS EXPAND=TRUE
*DECK DECK=CYCLEB3_EXCEPTIONS EXPAND=TRUE
*DECK DECK=CYCLEB4_EXCEPTIONS EXPAND=TRUE
*DECK DECK=CYCLEB5_EXCEPTIONS EXPAND=TRUE
*IF bev$product_level = 'BUILD_B501'
IF $variable(BUILD_B501_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B501_STATUS kind=status
IFEND
 include_feature nv08097                         status=BUILD_B501_STATUS
 include_feature nv08935                         status=BUILD_B501_STATUS
 include_feature nv09083                         status=BUILD_B501_STATUS
 include_feature nv09121                         status=BUILD_B501_STATUS
 include_feature nv09139                         status=BUILD_B501_STATUS
 include_feature nv09150                         status=BUILD_B501_STATUS
 include_feature nv09185                         status=BUILD_B501_STATUS
 include_feature nv09189                         status=BUILD_B501_STATUS
 include_feature nv0v125                         status=BUILD_B501_STATUS
 include_feature nv0v147                         status=BUILD_B501_STATUS
 include_feature nv0v155                         status=BUILD_B501_STATUS
 include_feature nv0v164                         status=BUILD_B501_STATUS
*IFEND
*IF bev$product_level = 'BUILD_B502'
IF $variable(BUILD_B502_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B502_STATUS kind=status
IFEND
 include_feature nfsa175_os                      status=BUILD_B502_STATUS
 include_feature nv07594                         status=BUILD_B502_STATUS
 include_feature nv07811                         status=BUILD_B502_STATUS
 include_feature nv08755                         status=BUILD_B502_STATUS
 include_feature nv09019                         status=BUILD_B502_STATUS
 include_feature nv09041                         status=BUILD_B502_STATUS
 include_feature nv09056                         status=BUILD_B502_STATUS
 include_feature nv09061                         status=BUILD_B502_STATUS
 include_feature nv09067                         status=BUILD_B502_STATUS
 include_feature nv0v101                         status=BUILD_B502_STATUS
 include_feature seg_20_trap_code                status=BUILD_B502_STATUS
 include_feature nv08097                         status=BUILD_B502_STATUS
 include_feature nv08935                         status=BUILD_B502_STATUS
 include_feature nv09083                         status=BUILD_B502_STATUS
 include_feature nv09121                         status=BUILD_B502_STATUS
 include_feature nv09139                         status=BUILD_B502_STATUS
 include_feature nv09150                         status=BUILD_B502_STATUS
 include_feature nv09185                         status=BUILD_B502_STATUS
 include_feature nv09189                         status=BUILD_B502_STATUS
 include_feature nv0v125                         status=BUILD_B502_STATUS
 include_feature nv0v147                         status=BUILD_B502_STATUS
 include_feature nv0v155                         status=BUILD_B502_STATUS
 include_feature nv0v164                         status=BUILD_B502_STATUS
*IFEND
*DECK DECK=CYCLEB6_EXCEPTIONS EXPAND=TRUE
*IF bev$product_level = 'BUILD_B601'
IF $variable(BUILD_B601_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B601_STATUS kind=status
IFEND
 include_feature aio_limit                       status=BUILD_B601_STATUS
 include_feature dynamic_pp_reload               status=BUILD_B601_STATUS
 include_feature nfsa175_os                      status=BUILD_B601_STATUS
 include_feature nv04076                         status=BUILD_B601_STATUS
 include_feature nv07811                         status=BUILD_B601_STATUS
 include_feature nv08097                         status=BUILD_B601_STATUS
 include_feature nv08708                         status=BUILD_B601_STATUS
 include_feature nv08755                         status=BUILD_B601_STATUS
 include_feature nv08935                         status=BUILD_B601_STATUS
 include_feature nv08969                         status=BUILD_B601_STATUS
 include_feature nv09019                         status=BUILD_B601_STATUS
 include_feature nv09061                         status=BUILD_B601_STATUS
 include_feature nv09083                         status=BUILD_B601_STATUS
 include_feature nv09121                         status=BUILD_B601_STATUS
 include_feature nv09139                         status=BUILD_B601_STATUS
 include_feature nv09150                         status=BUILD_B601_STATUS
 include_feature nv09185                         status=BUILD_B601_STATUS
 include_feature nv09189                         status=BUILD_B601_STATUS
 include_feature nv09199                         status=BUILD_B601_STATUS
 include_feature nv0u337                         status=BUILD_B601_STATUS
 include_feature nv0v101                         status=BUILD_B601_STATUS
 include_feature nv0v125                         status=BUILD_B601_STATUS
 include_feature nv0v147                         status=BUILD_B601_STATUS
 include_feature nv0v155                         status=BUILD_B601_STATUS
 include_feature nv0v164                         status=BUILD_B601_STATUS
 include_feature pp_reload                       status=BUILD_B601_STATUS
*IFEND
*IF bev$product_level = 'BUILD_B602'
IF $variable(BUILD_B602_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B602_STATUS kind=status
IFEND
 include_feature nv09048                         status=BUILD_B602_STATUS
 include_feature nv09048_fix                     status=BUILD_B602_STATUS
*IFEND
*IF bev$product_level = 'BUILD_B611'
IF $variable(BUILD_B611_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B611_STATUS kind=status
IFEND
 include_feature pf_condition_handlers           status=BUILD_B611_STATUS
 include_feature nv09048                         status=BUILD_B611_STATUS
 include_feature nv09048_fix                     status=BUILD_B611_STATUS
*IFEND
*IF bev$product_level = 'BUILD_B612'
IF $variable(BUILD_B612_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B612_STATUS kind=status
IFEND
 include_feature nv09048                         status=BUILD_B612_STATUS
 include_feature nv09048_fix                     status=BUILD_B612_STATUS
*IFEND
*IF bev$product_level = 'BUILD_B613'
IF $variable(BUILD_B613_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B613_STATUS kind=status
IFEND
 include_feature nv09048                         status=BUILD_B613_STATUS
 include_feature nv09048_fix                     status=BUILD_B613_STATUS
*IFEND
*IF bev$product_level = 'BUILD_B621'
IF $variable(BUILD_B621_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B621_STATUS kind=status
IFEND
 include_feature nv09048                         status=BUILD_B621_STATUS
 include_feature nv09048_fix                     status=BUILD_B621_STATUS
*IFEND
*IF bev$product_level = 'BUILD_B622'
IF $variable(BUILD_B622_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B622_STATUS kind=status
IFEND
 include_feature nv0u549                         status=BUILD_B622_STATUS
 include_feature nv09048                         status=BUILD_B622_STATUS
 include_feature nv09048_fix                     status=BUILD_B622_STATUS
 include_feature nv09048_fix1                    status=BUILD_B622_STATUS
*IFEND
*IF bev$product_level = 'BUILD_B623'
IF $variable(BUILD_B623_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B623_STATUS kind=status
IFEND
 include_feature nv09048                         status=BUILD_B623_STATUS
 include_feature nv09048_fix                     status=BUILD_B623_STATUS
 include_feature nv09048_fix1                    status=BUILD_B623_STATUS
*IFEND
*DECK DECK=CYCLEB7_EXCEPTIONS EXPAND=TRUE
*IF bev$product_level = 'BUILD_B710'
IF $variable(BUILD_B710_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B710_STATUS kind=status
IFEND
 include_feature nv09489                         status=BUILD_B710_STATUS
*IFEND
*IF bev$product_level = 'BUILD_B711'
IF $variable(BUILD_B711_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B711_STATUS kind=status
IFEND
 include_feature nv09489                         status=BUILD_B711_STATUS
*IFEND
*IF bev$product_level = 'BUILD_B715'
IF $variable(BUILD_B715_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B715_STATUS kind=status
IFEND
 include_feature nv09489                         status=BUILD_B715_STATUS
*IFEND
*IF bev$product_level = 'BUILD_B720'
IF $variable(BUILD_B720_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_B720_STATUS kind=status
IFEND
 include_feature nv09538                         status=BUILD_B720_STATUS
*IFEND
*DECK DECK=CYCLEB8_EXCEPTIONS EXPAND=TRUE
*DECK DECK=CYCLEC1_EXCEPTIONS EXPAND=TRUE
*IF bev$product_level = 'BUILD_C101'
IF $variable(BUILD_C101_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C101_STATUS kind=status
IFEND
 exclude_feature nv09652                         status=BUILD_C101_STATUS
 exclude_feature nv09297                         status=BUILD_C101_STATUS
*IFEND
*IF bev$product_level = 'BUILD_C111'
IF $variable(BUILD_C111_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C111_STATUS kind=status
IFEND
 exclude_feature nv09652                         status=BUILD_C111_STATUS
 exclude_feature nv09297                         status=BUILD_C111_STATUS
*IFEND
*IF bev$product_level = 'BUILD_C121'
IF $variable(BUILD_C121_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C121_STATUS kind=status
IFEND
 exclude_feature nv09652                         status=BUILD_C121_STATUS
 exclude_feature nv09297                         status=BUILD_C121_STATUS
*IFEND
*IF bev$product_level = 'BUILD_C131'
IF $variable(BUILD_C131_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C131_STATUS kind=status
IFEND
 exclude_feature nv09652                         status=BUILD_C131_STATUS
 exclude_feature nv09297                         status=BUILD_C131_STATUS
*IFEND
*IF bev$product_level = 'BUILD_C141'
IF $variable(BUILD_C141_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C141_STATUS kind=status
IFEND
 exclude_feature nv09652                         status=BUILD_C141_STATUS
 exclude_feature nv09297                         status=BUILD_C141_STATUS
*IFEND
*IF bev$product_level = 'BUILD_C151'
IF $variable(BUILD_C151_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C151_STATUS kind=status
IFEND
 exclude_feature nv09652                         status=BUILD_C151_STATUS
 exclude_feature nv09297                         status=BUILD_C151_STATUS
*IFEND
*DECK DECK=CYCLEC2_EXCEPTIONS EXPAND=TRUE
*IF bev$product_level = 'BUILD_C201'
IF $variable(BUILD_C201_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C201_STATUS kind=status
IFEND
 exclude_feature nv09652                         status=BUILD_C201_STATUS
 exclude_feature nv09297                         status=BUILD_C201_STATUS
*IFEND
*DECK DECK=CYCLEC3_EXCEPTIONS EXPAND=TRUE
*DECK DECK=CYCLEC4_EXCEPTIONS EXPAND=TRUE
*DECK DECK=CYCLEC5_EXCEPTIONS EXPAND=TRUE
*IF bev$product_level = 'BUILD_C501'
IF $variable(BUILD_C501_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C501_STATUS kind=status
IFEND
 include_feature disk_ft_phase3m                 status=BUILD_C501_STATUS
*IFEND
*IF bev$product_level = 'BUILD_C505'
IF $variable(BUILD_C505_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_C505_STATUS kind=status
IFEND
 include_feature nv0v116                         status=BUILD_C505_STATUS
*IFEND

*DECK DECK=CYCLEC6_EXCEPTIONS EXPAND=TRUE
*DECK DECK=CYCLED1_EXCEPTIONS EXPAND=TRUE
*IF bev$product_level = 'BUILD_D101'
IF $variable(BUILD_D101_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D101_STATUS kind=status
IFEND
 include_feature nv0t007                         status=BUILD_D101_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D105'
IF $variable(BUILD_D105_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D105_STATUS kind=status
IFEND
 include_feature nv0t007                         status=BUILD_D105_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D111'
IF $variable(BUILD_D111_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D111_STATUS kind=status
IFEND
 include_feature nv0t007                         status=BUILD_D111_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D121'
IF $variable(BUILD_D121_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D121_STATUS kind=status
IFEND
 include_feature nv0t007                         status=BUILD_D121_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D122'
IF $variable(BUILD_D122_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D122_STATUS kind=status
IFEND
 include_feature nv0t007                         status=BUILD_D122_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D125'
IF $variable(BUILD_D125_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D125_STATUS kind=status
IFEND
 include_feature nv0t007                         status=BUILD_D125_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D126'
IF $variable(BUILD_D126_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D126_STATUS kind=status
IFEND
 include_feature nv0t007                         status=BUILD_D126_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D131'
IF $variable(BUILD_D131_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D131_STATUS kind=status
IFEND
 include_feature nv0t007                         status=BUILD_D131_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D135'
IF $variable(BUILD_D135_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D135_STATUS kind=status
IFEND
 include_feature nv0t007                         status=BUILD_D135_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D137'
IF $variable(BUILD_D137_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D137_STATUS kind=status
IFEND
 include_feature nv0t007                         status=BUILD_D137_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D141'
IF $variable(BUILD_D141_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D141_STATUS kind=status
IFEND
 include_feature nv0t007                         status=BUILD_D141_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D142'
IF $variable(BUILD_D142_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D142_STATUS kind=status
IFEND
 include_feature nv0t007                         status=BUILD_D142_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D143'
IF $variable(BUILD_D143_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D143_STATUS kind=status
IFEND
 include_feature nv0t007                         status=BUILD_D143_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D145'
IF $variable(BUILD_D145_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D145_STATUS kind=status
IFEND
 include_feature nv0t007                         status=BUILD_D145_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D146'
IF $variable(BUILD_D146_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D146_STATUS kind=status
IFEND
 include_feature nv0t007                         status=BUILD_D146_STATUS
*IFEND
*DECK DECK=CYCLED2_EXCEPTIONS EXPAND=TRUE
*DECK DECK=CYCLED3_EXCEPTIONS EXPAND=TRUE
*DECK DECK=CYCLED5_EXCEPTIONS EXPAND=TRUE
*IF bev$product_level = 'BUILD_D505'
IF $variable(BUILD_D505_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D505_STATUS kind=status
IFEND
 include_feature nv0v326                         status=BUILD_D505_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D511'
IF $variable(BUILD_D511_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D511_STATUS kind=status
IFEND
 include_feature nv0v326                         status=BUILD_D511_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D521'
IF $variable(BUILD_D521_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D521_STATUS kind=status
IFEND
 include_feature nv08851                         status=BUILD_D521_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D525'
IF $variable(BUILD_D525_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D525_STATUS kind=status
IFEND
 include_feature nv08851                         status=BUILD_D525_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D531'
IF $variable(BUILD_D531_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D531_STATUS kind=status
IFEND
 include_feature nv08851                         status=BUILD_D531_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D536'
IF $variable(BUILD_D536_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D536_STATUS kind=status
IFEND
 include_feature nv08851                         status=BUILD_D536_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D541'
IF $variable(BUILD_D541_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D541_STATUS kind=status
IFEND
 include_feature nv08851                         status=BUILD_D541_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D542'
IF $variable(BUILD_D542_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D542_STATUS kind=status
IFEND
 include_feature nv08851                         status=BUILD_D542_STATUS
*IFEND

*DECK DECK=CYCLED6_EXCEPTIONS EXPAND=TRUE
*IF bev$product_level = 'BUILD_D601'
IF $variable(BUILD_D601_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D601_STATUS kind=status
IFEND
 include_feature nv0s728                         status=BUILD_D601_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D605'
IF $variable(BUILD_D605_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D605_STATUS kind=status
IFEND
 include_feature nv0s728                         status=BUILD_D605_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D611'
IF $variable(BUILD_D611_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D611_STATUS kind=status
IFEND
 include_feature nv0s728                         status=BUILD_D611_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D621'
IF $variable(BUILD_D621_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D621_STATUS kind=status
IFEND
 include_feature nv0s728                         status=BUILD_D621_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D622'
IF $variable(BUILD_D622_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D622_STATUS kind=status
IFEND
 include_feature nv0s728                         status=BUILD_D622_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D631'
IF $variable(BUILD_D631_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D631_STATUS kind=status
IFEND
 include_feature nv0s728                         status=BUILD_D631_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D632'
IF $variable(BUILD_D632_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D632_STATUS kind=status
IFEND
 include_feature nv0s728                         status=BUILD_D632_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D641'
IF $variable(BUILD_D641_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D641_STATUS kind=status
IFEND
 include_feature nv0s728                         status=BUILD_D641_STATUS
*IFEND
*IF bev$product_level = 'BUILD_D642'
IF $variable(BUILD_D642_STATUS, declared) = 'UNKNOWN' THEN
  create_variable BUILD_D642_STATUS kind=status
IFEND
 include_feature nv0s728                         status=BUILD_D642_STATUS
*IFEND
*DECK DECK=CYCLED7_EXCEPTIONS EXPAND=TRUE
*DECK DECK=CYCLED9_EXCEPTIONS EXPAND=TRUE
*DECK DECK=CYCLEE1_EXCEPTIONS EXPAND=TRUE
*DECK DECK=CYCLEE2_EXCEPTIONS EXPAND=TRUE
*DECK DECK=CYCLEE4_EXCEPTIONS EXPAND=TRUE
*DECK DECK=CYD$BINARY_FILE EXPAND=FALSE

{* ZCYDBF  cyd$binary_file *}

*copyc cyp$binary_file_key
*copyc cyp$close_file
*copyc cyp$current_file_position
*copyc cyp$get_keyed_binary
*copyc cyp$get_next_binary
*copyc cyp$length_of_file
*copyc cyp$open_file
*copyc cyp$operating_system
*copyc cyp$position_binary_at_key
*copyc cyp$position_file_at_beginning
*copyc cyp$position_file_at_end
*copyc cyp$put_keyed_binary
*copyc cyp$put_next_binary
*copyc cyp$write_end_of_partition
*DECK DECK=CYD$BINDING_KIND_DEFINITIONS EXPAND=FALSE

  {Deck: CYDKIND}

  TYPE
    bind = (fixed_bind, variable_spare_bind, adaptable_bind, variant_bind),
    bindkinds = set of bind,
    len_kinds = (short_len, long_len, not_fixed_spare_len, adapt_len);
  ?? SKIP := 5 ??
*DECK DECK=CYD$CYBIL_STRUCTURE_DEFINITIONS EXPAND=FALSE

{ COMMON DECK CYDCYBL }

{   This deck contains type declarations for CYBIL data types.}
{ DO NOT USE the record types that begin with ost$ because they will be deleted
{ eventually.  The record types that begin with cyt$ are OK and they may
{ be used instead of the ost$ types.

  TYPE

*IF NOT $true(osv$unix)
    ost$pointer_to_procedure = record
      code_base_pointer_p: ^ost$external_code_base_pointer,
      static_link: ^cell,
    recend,

    ost$adaptable_array_pointer = record
      pointer: ^cell,
      array_size: 0 .. 0ffffffff(16),
      lower_bound: 0 .. 0ffffffff(16),
      element_size: 0 .. 0ffffffff(16),
    recend,

    ost$adaptable_heap_pointer = record
      pva: ^cell,
      length: 0 .. 7fffffff(16),
    recend,

    ost$sequence_pointer = record
      pva: ^cell,
      length: 0 .. 7fffffff(16),
      nextt: 0 .. 7fffffff(16),
    recend,

    ost$bound_variant_pointer = record
      pva: ^cell,
      length: 0 .. 7fffffff(16),
    recend,

    ost$adaptable_string_pointer = record
      pva: ^cell,
      length: 0 .. 0ffff(16),
    recend,
*ELSE
    ost$pointer_to_procedure = cyt$pointer_to_procedure,
    ost$adaptable_array_pointer = cyt$adaptable_array_pointer,
    ost$adaptable_heap_pointer = cyt$adaptable_heap_pointer,
    ost$sequence_pointer = cyt$sequence_pointer,
    ost$bound_variant_pointer = cyt$bound_variant_pointer,
    ost$adaptable_string_pointer = cyt$adaptable_string_pointer,
*IFEND

    cyt$pointer_to_procedure = record
      code_base_pointer_p: ^ost$external_code_base_pointer,
      static_link: ^cell,
    recend,

    cyt$adaptable_array_pointer = record
      pointer: ^cell,
*IF NOT $true(osv$unix)
      array_size: 0 .. 0ffffffff(16),
      lower_bound: 0 .. 0ffffffff(16),
      element_size: 0 .. 0ffffffff(16),
*ELSE
      array_size: 0 .. 7fffffff(16),
      lower_bound: 0 .. 7fffffff(16),
      element_size: 0 .. 7fffffff(16),
*IFEND
    recend,

    cyt$adaptable_heap_pointer = record
      pva: ^cell,
      length: 0 .. 7fffffff(16),
    recend,

    cyt$sequence_pointer = record
*IF NOT $true(osv$unix)
      pva: ^cell,
*ELSE
      pointer_sequence: -80000000(16) .. 7fffffff(16),
*IFEND
      length: 0 .. 7fffffff(16),
      nextt: 0 .. 7fffffff(16),
    recend,

    cyt$bound_variant_pointer = record
      pva: ^cell,
      length: 0 .. 7fffffff(16),
    recend,

    cyt$adaptable_string_pointer = record
      pva: ^cell,
      length: 0 .. 0ffff(16),
    recend;

*copyc OSD$CODE_BASE_POINTER
*DECK DECK=CYD$DEBUG_SYMBOLS EXPAND=FALSE
*copyc CYD$SYMBOL_TABLE_ENTRY_KINDS
*copyc CYD$BINDING_KIND_DEFINITIONS
*copyc CYD$DEBUG_SYMBOL_TABLE
*copyc CYD$MACHINE_DEFINITIONS
*copyc CYD$GLOBAL_PHASE_DEFINITIONS
*DECK DECK=CYD$DEBUG_SYMBOL_TABLE EXPAND=FALSE

{Deck: CYDDSYM

{This deck contains the type definition for the symbol table
{ interface to CID180.

{*callc cydentr
{*callc cydimdp
{*callc cydglph
{*callc cydkind
{*callc lldobmd

{ Symbols for a procedure or module appear sequentially in an array. The
{ last symbol for a procedure or module is indicated by the field
{ 'end_of_chain' set to TRUE.

  TYPE
    cyt$debug_symbol_table_item = record
      symbol_name: pmt$program_name,
      end_of_chain: boolean, {End of symbols for procedure or module = TRUE}
      symtab_no: symbol_no,
      case symbol_type: entry_kinds of
      = int_kind, bool_kind, char_kind, real_kind, longreal_kind, cell_kind =
        ,
      = var_kind =
        var_type: symbol_no,
        var_length: ost$segment_length, {length in bytes}
        base: base_type,
        var_section_ordinal: llt$section_ordinal, {only for base=static_base}
        var_offset: ost$segment_length,
        indirectly_referenced: boolean,
        var_is_parameter: boolean,
      = cons_kind =
        cons_type: symbol_no,
        cons_length_type: (short_constant_type, long_constant_type),
        cons_value: integer_range, {legitimate value only for
              { short_constant_type}
      = label_kind =
        line_no: line_number_range,
      = ordinal_kind = {Immediately followed by cons_kind entries}
        last_const: symbol_no,
        upper_bound: 0 .. 4095,
      = subrange_kind =
        subtype: symbol_no,
        low_value_type: len_kinds,
        high_value_type: len_kinds,
        low_value: integer_range,
        high_value: integer_range,
      = proc_kind =
        lexical_level: 0 .. 255,
        symbol_list: symbol_no, {points to parameters + local declarations}
        proc_section_ordinal: llt$section_ordinal,
        proc_offset: ost$segment_length,
        proc_length: ost$segment_length,
        parent_proc: symbol_no,
        return_type: symbol_no,
      = pointer_kind =
        ptr_type: symbol_no,
        ptr_object_length: ost$segment_length, {length in bytes}
      = set_kind =
        set_element_type: symbol_no,
        set_len: 0 .. 7fff(16),
      = string_kind =
        len_type: len_kinds,
        string_len: strlenrange,
      = array_kind =
        array_binding: bindkinds,
        array_packing: packattrs,
        length_is_bits: boolean,
        index_type: symbol_no,
        array_element_type: symbol_no,
        element_length: ost$segment_length,
      = record_kind =
        record_binding: bindkinds,
        record_packing: packattrs,
        variation_flag: boolean,
        first_field: symbol_no,
        record_length: ost$segment_length,
        selector: symbol_no,
      = field_kind =
        field_offset: machine_addr_in_bits_type,
        field_length: machine_addr_in_bits_type,
        unit_addressed: boolean, {bytes if true, bits if false}
        field_type: symbol_no,
        next_field: symbol_no,
      = selector_kind =
        variation: symbol_no,
        next_selector: symbol_no,
        low_selector: integer_range,
        high_selector: integer_range,
      = heap_kind =
        ,
      = seq_kind =
        ,
      = bound_vrec_kind =
        bound_type: symbol_no,
      = rel_ptr_kind =
        parent_type: symbol_no,
        object_type: symbol_no,
        rel_ptr_object_length: ost$segment_length, {length in bytes}
      casend
    recend,

    cyt$debug_symbol_table = record
      original_name: pmt$program_name,
      language: llt$module_generator,
      optimization_level: 0 .. 255,
      version: string (4), { = cyc$debug_table_version }
      module_symbol_list: symbol_no, {points to module level symbols}
      number_of_symbols: symbol_no,
      item: array [0 .. * ] of cyt$debug_symbol_table_item,
    recend;

  CONST
    cyc$debug_table_version = 'V0.1';

?? SKIP := 5 ??
*copyc cyd$symbol_table_entry_kinds
*copyc cyd$machine_definitions
*copyc cyd$global_phase_definitions
*copyc cyd$binding_kind_definitions
*copyc llt$object_module
*DECK DECK=CYD$DEBUG_SYMBOL_TABLE_HEADER EXPAND=FALSE

  TYPE
    cyt$debug_symbol_table_header = record
      original_name: pmt$program_name,
      language: llt$module_generator,
      optimization_level: 0 .. 255,
      version: string (4),
      module_symbol_list: symbol_no,
      number_of_symbols: symbol_no,
    recend;

*copyc PMT$PROGRAM_NAME
*copyc LOT$LOADER_TYPE_DEFINITIONS
*copyc CYD$DEBUG_SYMBOLS
*DECK DECK=CYD$DISPLAY_FILE EXPAND=FALSE

{* ZCYDDF  cyd$display_file *}

*copyc cyp$current_column
*copyc cyp$current_display_line
*copyc cyp$close_file
*copyc cyp$current_file_position
*copyc cyp$current_page_number
*copyc cyp$display_page_eject
*copyc cyp$display_page_length
*copyc cyp$file_connected_to_terminal
*copyc cyp$length_of_file
*copyc cyp$open_file
*copyc cyp$operating_system
*copyc cyp$position_display_page
*copyc cyp$position_file_at_beginning
*copyc cyp$position_file_at_end
*copyc cyp$put_next_line
*copyc cyp$put_partial_line
*copyc cyp$page_width
*copyc cyp$skip_lines
*copyc cyp$start_new_display_page
*copyc cyp$display_standard_title
*copyc cyp$tab_file
*copyc cyp$write_end_of_line
*copyc cyp$write_end_of_partition
*copyc cyp$flush_line
*DECK DECK=CYD$GLOBAL_PHASE_DEFINITIONS EXPAND=FALSE

  {deck: cydglph }
  {environment: none. }

  CONST
    string_length_max = 65535;

  TYPE
    strlenrange = 0 .. string_length_max,
    symbol_no = 0 .. 65535,
    line_number_range = 0 .. 65535;
  ?? SKIP := 5 ??
*DECK DECK=CYD$MACHINE_DEFINITIONS EXPAND=FALSE

  {DECK: CYDIMDP}

  {FUNCTION: TYPE DEFINITIONS FOR IPL VERSIONS OF MACHINE DEPENDENT}
  { TYPE.}

  {ENVIRONMENT: None.}


  CONST
    word_size = 64 {BITS} ,
    halfword_size = 32 {BITS} ,
    parcel_size = 16 {BITS} ,
    byte_size = 8 {BITS} ,
    bit_size = 1 {BIT} ,
    short_constant_minimum = - 32768, { - 2**15 }
    short_constant_maximum = 32767, { 2**15 - 1 }
    machine_addr_maximum = 7fffffff(16), { 2**31 - 1 }
    max_segment_length = machine_addr_maximum + 1,

    {the next 2 constants define the range within which the constant}
    { part of a computed result should fall to ensure that overflow does}
    { not occur}
    constant_part_hi_value = 1000000(16),
    constant_part_lo_value = - 1000000(16);

  TYPE
    iinteger = - 7fffffff(16) .. 7fffffff(16), { IPL 32-BIT INTEGER }
    int_33_bits = - 0ffffffff(16) .. 0ffffffff(16),
    machine_addr_type = 0 .. machine_addr_maximum, { 31 BITS }
    machine_addr_in_bits_type = 0 .. machine_addr_maximum * byte_size,
    segment_length_type = 0 .. max_segment_length,
    short_constant = short_constant_minimum .. short_constant_maximum,
    integer_range = - 0ffffffffffff(16) .. 0ffffffffffff(16),
    base_type = (null_base, static_base, constant_base, stack_frame_base,
      parm_list_base, xref_base, register_base),
    pseudo_reg_type = 0 .. 0ffff(16),
    computed_result_type = packed record
      computed_part: pseudo_reg_type,
      constant_part: int_33_bits,
    recend,
    array_element_length_type = machine_addr_type,
    record_vsa_offset_type = machine_addr_in_bits_type;

  ?? SKIP := 5 ??

*DECK DECK=CYD$RECORD_FILE EXPAND=FALSE

{* ZCYDRF  cyd$record_file *}

*copyc cyp$close_file
*copyc cyp$current_file_position
*copyc cyp$get_next_record
*copyc cyp$get_partial_record
*copyc cyp$length_of_file
*copyc cyp$open_file
*copyc cyp$operating_system
*copyc cyp$position_file_at_beginning
*copyc cyp$position_file_at_end
*copyc cyp$put_next_record
*copyc cyp$put_partial_record
*copyc cyp$position_record_file
*copyc cyp$write_end_of_record
*copyc cyp$write_end_of_partition
*DECK DECK=CYD$RUN_TIME_ERROR_CONDITION EXPAND=FALSE

  CONST
    cye$run_time_condition = 'CYE$RUN_TIME_CONDITION         ';

*copyc CYE$RUN_TIME_ERROR_CODES
*DECK DECK=CYD$STRING EXPAND=FALSE
*copyc cyc$max_string_size
*copyc cyt$string_index
*copyc cyt$string_size
*DECK DECK=CYD$SYMBOL_TABLE_ENTRY_KINDS EXPAND=FALSE
  {Deck: CYDENTR}
  {Function: Basic declarations for CYBIL symbol table constituents. }

  TYPE
    entry_kinds = (error_kind, int_kind, bool_kind, char_kind, ordinal_kind,
      real_kind, longreal_kind,
      string_kind, vstring_spare_kind, set_kind, pointer_kind,
      record_kind, array_kind, union_spare_kind, subrange_kind,
      rel_ptr_kind, seq_kind, heap_kind, lbl_typ_spare_kind,
      bound_vrec_kind, proc_kind, cell_kind, nil_kind, parameter_kind,
      var_kind, cons_kind, proc_decl_kind, label_kind, file_kind, field_kind,
      selector_kind, union_spare_element_kind, span_elem_kind, module_kind,
      prong_kind, synonym_kind, last_one, section_kind),
    packattrs = (packd, unpackd, not_packd),
    mode_kinds = (val_param, ref_param);
  ?? SKIP := 5 ??

*DECK DECK=CYD$TEXT_FILE EXPAND=FALSE

{* ZCYDTF  cyd$text_file *}

*copyc cyp$current_column
*copyc cyp$close_file
*copyc cyp$current_file_position
*copyc cyp$file_connected_to_terminal
*copyc cyp$get_next_line
*copyc cyp$get_partial_line
*copyc cyp$length_of_file
*copyc cyp$open_file
*copyc cyp$operating_system
*copyc cyp$position_file_at_beginning
*copyc cyp$position_file_at_end
*copyc cyp$put_next_line
*copyc cyp$put_partial_line
*copyc cyp$page_width
*copyc cyp$current_display_line
*copyc cyp$skip_lines
*copyc cyp$tab_file
*copyc cyp$write_end_of_line
*copyc cyp$write_end_of_partition
*copyc cyp$flush_line
*DECK DECK=CYE$CYBIL_COMPILE_ERROR_CODES EXPAND=FALSE
*copyc cyc$error_codes_cybil_range
?? NEWTITLE := '  CYBIL COMPILE TIME ERRORS : ''CY'' 0 - 4999' ??
?? EJECT ??

  CONST
    cyc$cybil_compilation_errors = cyc$min_ecc + 0;

  CONST
    cyc$cybil_diagnostic_errors = cyc$min_ecc + 3;

  CONST
    cye$cybil_warn_error = cyc$cybil_compilation_errors,
    {W *CYBIL* , +P

    cye$cybil_non_fatal_error = cyc$cybil_compilation_errors + 1,
    {E *CYBIL* , +P

    cye$cybil_fatal_error = cyc$cybil_compilation_errors + 2,
    {F *CYBIL FATAL ERROR IN , +P

    cye$cybil_abort_error = cyc$cybil_compilation_errors + 3,
    {C *CYBIL TERMINATED* , +P

    cye#cybil_error_1 = cyc$cybil_diagnostic_errors + 1,
    {W +N Right margin must be at least ten greater than left margin, 'LEFT' :=
    {+P, 'RIGHT' := +P assumed.

    cye#cybil_error_2 = cyc$cybil_diagnostic_errors + 2,
    {W +N Improper toggle assignment operator, ':=' expected.

    cye#cybil_error_3 = cyc$cybil_diagnostic_errors + 3,
    {W +N Missing toggle assignment operator, ':=' expected.

    cye#cybil_error_4 = cyc$cybil_diagnostic_errors + 4,
    {W +N Undefined toggle identifier condition, 'ON' or 'OFF' expected.

    cye#cybil_error_5 = cyc$cybil_diagnostic_errors + 5,
    {W +N Invalid toggle list delimiter, ',' or ')' expected.

    cye#cybil_error_6 = cyc$cybil_diagnostic_errors + 6,
    {W +N Undefined toggle identifier - +P.

    cye#cybil_error_7 = cyc$cybil_diagnostic_errors + 7,
    {W +N Toggle assignment list missing, '(' expected.

    cye#cybil_error_8 = cyc$cybil_diagnostic_errors + 8,
    {W +N Undefined toggle condition, 'ON' or 'OFF' expected.

    cye#cybil_error_9 = cyc$cybil_diagnostic_errors + 9,
    {F +N String constant expected.

    cye#cybil_error_10 = cyc$cybil_diagnostic_errors + 10,
    {F +N Integer constant expected.

    cye#cybil_error_11 = cyc$cybil_diagnostic_errors + 11,
    {W +N Left margin value out of range, value expected to be between 1 and 100
    {'LEFT' := +P ..{assumed.

    cye#cybil_error_12 = cyc$cybil_diagnostic_errors + 12,
    {W +N Right margin value out of range, value expected to be between 11 and 110
    {'RIGHT' := +P assumed.

    cye#cybil_error_13 = cyc$cybil_diagnostic_errors + 13,
    {W +N Undefined pragmat identifier - +P.

    cye#cybil_error_14 = cyc$cybil_diagnostic_errors + 14,
    {W +N Invalid toggle list delimiter, ',' or '??' expected.

    cye#cybil_error_15 = cyc$cybil_diagnostic_errors + 15,
    {F +N An overflow has occurred during compile time addition, intermediate
    {result >= abs (2 ** 63 - 1).

    cye#cybil_error_16 = cyc$cybil_diagnostic_errors + 16,
    {F +N An overflow has occurred during compile time multiplication,
    {intermediate result >= abs (2 ** 63 - 1).

    cye#cybil_error_17 = cyc$cybil_diagnostic_errors + 17,
    {F +N Compile time division by zero has occurred.

    cye#cybil_error_18 = cyc$cybil_diagnostic_errors + 18,
    {F +N An overflow has occurred during compile time exponentiation, exponent >=
    {48.

    cye#cybil_error_19 = cyc$cybil_diagnostic_errors + 19,
    {F +N +P digit(s) found outside realm of radix.

    cye#cybil_error_20 = cyc$cybil_diagnostic_errors + 20,
    {F +N Integer constant >= abs (2 ** 63 - 1).

    cye#cybil_error_21 = cyc$cybil_diagnostic_errors + 21,
    {C +N Compiler table overflow (LST heap) - increase memory field length.

    cye#cybil_error_22 = cyc$cybil_diagnostic_errors + 22,
    {W +N Toggle syntax error, '[' expected.

    cye#cybil_error_23 = cyc$cybil_diagnostic_errors + 23,
    {W +N Toggle syntax error, integer constant expected.

    cye#cybil_error_24 = cyc$cybil_diagnostic_errors + 24,
    {W +N Toggle syntax error, ',' or ']' expected.

    cye#cybil_error_25 = cyc$cybil_diagnostic_errors + 25,
    {W +N Illegal spacing value, spacing must be 1, 2, or 3, previous value
    {assumed.

    cye#cybil_error_26 = cyc$cybil_diagnostic_errors + 26,
    {W +N Real constant is too large for conversion to integer constant. High
    {order digits truncated.

    cye#cybil_error_27 = cyc$cybil_diagnostic_errors + 27,
    {W +N Pagesize must be greater than or equal to 20

    cye#cybil_error_28 = cyc$cybil_diagnostic_errors + 28,
    {W +N Attempt to stack more then 25 toggle states. Maximum number of toggle
    {states is 25.

    cye#cybil_error_29 = cyc$cybil_diagnostic_errors + 29,
    {W +N Improper pragmat assignment operator, ':=' expected.

    cye#cybil_error_30 = cyc$cybil_diagnostic_errors + 30,
    {W +N Missing pragmat assignment operator, ':=' expected.

    cye#cybil_error_31 = cyc$cybil_diagnostic_errors + 31,
    {W +N Empty strings are not allowed on titling pragmat.

    cye#cybil_error_32 = cyc$cybil_diagnostic_errors + 32,
    {W +N Comment toggle is greater than 70 characters and will be truncated.

    cye#cybil_error_33 = cyc$cybil_diagnostic_errors + 33,
    {W +N Library constant is greater than 31 characters and will be truncated.

    cye#cybil_error_34 = cyc$cybil_diagnostic_errors + 34,
    {F +N Left parenthesis missing in +P built in function parameter list.

    cye#cybil_error_35 = cyc$cybil_diagnostic_errors + 35,
    {F +N Parameter of +P built in function must be of type string.

    cye#cybil_error_36 = cyc$cybil_diagnostic_errors + 36,
    {F +N Parameter in +P built in function can only be a type identifier or a
    {variable.

    cye#cybil_error_37 = cyc$cybil_diagnostic_errors + 37,
    {F +N Right parenthesis missing in +P built in function parameter list.

    cye#cybil_error_38 = cyc$cybil_diagnostic_errors + 38,
    {W +N Modend name does not match module name.

    cye#cybil_error_39 = cyc$cybil_diagnostic_errors + 39,
    {F +N Parameter of +P built in function must be a variable.

    cye#cybil_error_40 = cyc$cybil_diagnostic_errors + 40,
    {F +N First parameter of +P built in function must be a direct pointer.

    cye#cybil_error_41 = cyc$cybil_diagnostic_errors + 41,
    {F +N Second parameter of +P built in function must be a variable of storage
    {or aggregate type.

    cye#cybil_error_42 = cyc$cybil_diagnostic_errors + 42,
    {F +N First parameter of +P built in function must be a relative pointer.

    cye#cybil_error_43 = cyc$cybil_diagnostic_errors + 43,
    {F +N First parameter of +P built in function is not equivalent to the type of
    {the parental variable.

    cye#cybil_error_44 = cyc$cybil_diagnostic_errors + 44,
    {F +N First parameter of +P built in function must be of type array.

    cye#cybil_error_45 = cyc$cybil_diagnostic_errors + 45,
    {F +N Comma missing in +P built in function parameter list.

    cye#cybil_error_46 = cyc$cybil_diagnostic_errors + 46,
    {F +N Second parameter of +P built in function must be an integer expression.

    cye#cybil_error_47 = cyc$cybil_diagnostic_errors + 47,
    {F +N Second parameter of +P built in function must be a constant.

    cye#cybil_error_48 = cyc$cybil_diagnostic_errors + 48,
    {F +N Integer constant for +P built in function is too large.

    cye#cybil_error_49 = cyc$cybil_diagnostic_errors + 49,
    {F +N Parameter of +P built in function must be either a scalar type
    {identifier or a variable of type scalar.

    cye#cybil_error_50 = cyc$cybil_diagnostic_errors + 50,
    {F +N First parameter of +P built in function must be a variable of storage
    {type stack.

    cye#cybil_error_51 = cyc$cybil_diagnostic_errors + 51,
    {F +N Second parameter of +P built in function must be a non-negative integer
    {expression.

    cye#cybil_error_52 = cyc$cybil_diagnostic_errors + 52,
    {F +N Parameter of $+P conversion function must be of type char, ordinal or
    {boolean.

    cye#cybil_error_53 = cyc$cybil_diagnostic_errors + 53,
    {F +N Second parameter of $+P conversion function expected to be a character
    {expression.

    cye#cybil_error_54 = cyc$cybil_diagnostic_errors + 54,
    {F +N Parameter of $+P conversion function must be an integer expression.

    cye#cybil_error_55 = cyc$cybil_diagnostic_errors + 55,
    {F +N Constant parameter of $+P conversion function is out of range.

    cye#cybil_error_56 = cyc$cybil_diagnostic_errors + 56,
    {F +N Only nil is allowed for argument of $+P conversion function.

    cye#cybil_error_57 = cyc$cybil_diagnostic_errors + 57,
    {F +N Constant parameter of character conversion function is out of range.

    cye#cybil_error_58 = cyc$cybil_diagnostic_errors + 58,
    {F +N Parameter of character conversion function must be an integer expression.

    cye#cybil_error_59 = cyc$cybil_diagnostic_errors + 59,
    {F +N Argument of +P must be aligned.

    cye#cybil_error_60 = cyc$cybil_diagnostic_errors + 60,
    {F +N +P built in procedure expected to be within the scope of a repdep proc.

    cye#cybil_error_61 = cyc$cybil_diagnostic_errors + 61,
    {F +N Digit expected to follow period in real number.

    cye#cybil_error_62 = cyc$cybil_diagnostic_errors + 62,
    {C +N Premature end of input file.

    cye#cybil_error_63 = cyc$cybil_diagnostic_errors + 63,
    {F +N Line contains an unused mark - character ignored.

    cye#cybil_error_64 = cyc$cybil_diagnostic_errors + 64,
    {F +N First parameter of $+P conversion function expected to be an integer
    {expression.

    cye#cybil_error_65 = cyc$cybil_diagnostic_errors + 65,
    {F +N Second parameter of $+P conversion function expected to be a string
    {expression.

    cye#cybil_error_66 = cyc$cybil_diagnostic_errors + 66,
    {F +N Parameter of ordinal conversion function expected to be an integer
    {expression.

    cye#cybil_error_67 = cyc$cybil_diagnostic_errors + 67,
    {F +N Constant parameter of ordinal conversion function is out of range.

    cye#cybil_error_68 = cyc$cybil_diagnostic_errors + 68,
    {F +N Third parameter of $+P conversion function expected to be a character
    {expression.

    cye#cybil_error_69 = cyc$cybil_diagnostic_errors + 69,
    {F +N Parameter of $+P conversion function expected to be a string expression.

    cye#cybil_error_70 = cyc$cybil_diagnostic_errors + 70,
    {F +N Parameter of array conversion function expected to be of array type.

    cye#cybil_error_71 = cyc$cybil_diagnostic_errors + 71,
    {F +N Target type and source type of array conversion function are not
    {convertible.

    cye#cybil_error_72 = cyc$cybil_diagnostic_errors + 72,
    {F +N Parameter of record conversion function expected to be of record type.

    cye#cybil_error_73 = cyc$cybil_diagnostic_errors + 73,
    {F +N Left parenthesis missing from a built in procedure parameter list.

    cye#cybil_error_74 = cyc$cybil_diagnostic_errors + 74,
    {F +N Right parenthesis missing from a built in procedure parameter list.

    cye#cybil_error_75 = cyc$cybil_diagnostic_errors + 75,
    {F +N First parameter of +P built in procedure expected to be of type string.

    cye#cybil_error_76 = cyc$cybil_diagnostic_errors + 76,
    {F +N Comma missing in built in procedure parameter list.

    cye#cybil_error_77 = cyc$cybil_diagnostic_errors + 77,
    {F +N Second parameter of +P built in procedure can only be a variable.

    cye#cybil_error_78 = cyc$cybil_diagnostic_errors + 78,
    {F +N First parameter of +P built in procedure can only be of type integer or
    {boolean.

    cye#cybil_error_79 = cyc$cybil_diagnostic_errors + 79,
    {F +N Second parameter of +P built in procedure expected to be of type string.

    cye#cybil_error_80 = cyc$cybil_diagnostic_errors + 80,
    {F +N Third parameter of +P built in procedure expected to be an integer
    {expression.

    cye#cybil_error_81 = cyc$cybil_diagnostic_errors + 81,
    {F +N Fourth parameter of +P built in procedure expected to be an integer
    {expression.

    cye#cybil_error_82 = cyc$cybil_diagnostic_errors + 82,
    {F +N Parameter of built in procedure can only be a variable or a type
    {identifier.

    cye#cybil_error_83 = cyc$cybil_diagnostic_errors + 83,
    {F +N Parameter of built in procedure expected to be an integer variable.

    cye#cybil_error_84 = cyc$cybil_diagnostic_errors + 84,
    {F +N Comma missing from conversion function parameter list.

    cye#cybil_error_85 = cyc$cybil_diagnostic_errors + 85,
    {F +N Target identifier of conversion function must be a type identifier.

    cye#cybil_error_86 = cyc$cybil_diagnostic_errors + 86,
    {F +N Left parenthesis missing in $+P conversion function parameter list.

    cye#cybil_error_87 = cyc$cybil_diagnostic_errors + 87,
    {W +N Line longer than 110 characters, line truncated.

    cye#cybil_error_88 = cyc$cybil_diagnostic_errors + 88,
    {F +N +P - identifier longer than 31 characters.

    cye#cybil_error_89 = cyc$cybil_diagnostic_errors + 89,
    {F +N Too many digits in number.

    cye#cybil_error_90 = cyc$cybil_diagnostic_errors + 90,
    {F +N Incorrect format for real/longreal constant.

    cye#cybil_error_91 = cyc$cybil_diagnostic_errors + 91,
    {F +N Too many digits for real/longreal mantissa.

    cye#cybil_error_92 = cyc$cybil_diagnostic_errors + 92,
    {F +N Real number not base 10

    cye#cybil_error_93 = cyc$cybil_diagnostic_errors + 93,
    {F +N Base 16 or base 10 expected in explicit radix.

    cye#cybil_error_94 = cyc$cybil_diagnostic_errors + 94,
    {F +N Error in explicit radix.

    cye#cybil_error_95 = cyc$cybil_diagnostic_errors + 95,
    {F +N ')' expected in explicit radix.

    cye#cybil_error_96 = cyc$cybil_diagnostic_errors + 96,
    {F +N Semicolon not allowed in comment, comment terminated at ';'.

    cye#cybil_error_97 = cyc$cybil_diagnostic_errors + 97,
    {F +N String constant cannot cross line boundary, string terminated at end of
    {line.

    cye#cybil_error_98 = cyc$cybil_diagnostic_errors + 98,
    {F +N Second parameter of +P built in function cannot be less than one.

    cye#cybil_error_99 = cyc$cybil_diagnostic_errors + 99,
    {C +N Compiler table overflow (identifer table) - increase memory field length.

    cye#cybil_error_100 = cyc$cybil_diagnostic_errors + 100,
    {W +N +P - identifiers must begin with a letter.

    cye#cybil_error_101 = cyc$cybil_diagnostic_errors + 101,
    {C +N Compiler error (PH4) - Operator is greater than genlastop.

    cye#cybil_error_102 = cyc$cybil_diagnostic_errors + 102,
    {F +N Parameter of +P built in function expected to be a print file variable.

    cye#cybil_error_103 = cyc$cybil_diagnostic_errors + 103,
    {F +N Second parameter of +P built in function is out of range.

    cye#cybil_error_104 = cyc$cybil_diagnostic_errors + 104,
    {F +N +P built in function is not implemented.

    cye#cybil_error_105 = cyc$cybil_diagnostic_errors + 105,
    {F +N $+P conversion function is not allowed in constant expression.

    cye#cybil_error_106 = cyc$cybil_diagnostic_errors + 106,
    {F +N Parameter of $+P conversion function must be a constant expression.

    cye#cybil_error_107 = cyc$cybil_diagnostic_errors + 107,
    {F +N Adaptable type identifier not allowed in +P built in function parameter
    {list.

    cye#cybil_error_108 = cyc$cybil_diagnostic_errors + 108,
    {F +N Component types of target and source type are not convertible.

    cye#cybil_error_109 = cyc$cybil_diagnostic_errors + 109,
    {F +N Indices of target and source types do not span the same number of
    {elements.

    cye#cybil_error_110 = cyc$cybil_diagnostic_errors + 110,
    {F +N Target and source array types do not have the same dimension.

    cye#cybil_error_111 = cyc$cybil_diagnostic_errors + 111,
    {F +N Type identifier not allowed as a parameter of array conversion functions.

    cye#cybil_error_112 = cyc$cybil_diagnostic_errors + 112,
    {F +N Type identifier not allowed as a parameter of record conversion
    {functions.

    cye#cybil_error_113 = cyc$cybil_diagnostic_errors + 113,
    {F +N First parameter of $+P conversion function cannot be a negative number.

    cye#cybil_error_114 = cyc$cybil_diagnostic_errors + 114,
    {C +N Compiler table overflow (PH3 heap) - increase memory field length.

    cye#cybil_error_115 = cyc$cybil_diagnostic_errors + 115,
    {F +N Third parameter of +P built in procedure expected to be of type string.

    cye#cybil_error_116 = cyc$cybil_diagnostic_errors + 116,
    {F +N $+P is not a valid conversion function, only integer, boolean, char, and
    {ordinal type are allowed.

    cye#cybil_error_117 = cyc$cybil_diagnostic_errors + 117,
    {F +N Parameter of $+P conversion function must be a variable, constant or an
    {expression.

    cye#cybil_error_118 = cyc$cybil_diagnostic_errors + 118,
    {F +N Parameter of +P built in procedure expected to be of type file.

    cye#cybil_error_119 = cyc$cybil_diagnostic_errors + 119,
    {F +N Parameter of +P built in procedure must be a file variable.

    cye#cybil_error_120 = cyc$cybil_diagnostic_errors + 120,
    {C +N Compiler Error (PH2) - Unexpected end of file while reading 'PPTEXT'
    {file.

    cye#cybil_error_121 = cyc$cybil_diagnostic_errors + 121,
    {F +N Missing comma in conversion function parameter list.

    cye#cybil_error_122 = cyc$cybil_diagnostic_errors + 122,
    {F +N Constant parameter out of range in $+P conversion function.

    cye#cybil_error_123 = cyc$cybil_diagnostic_errors + 123,
    {F +N $+P conversion function is not implemented.

    cye#cybil_error_124 = cyc$cybil_diagnostic_errors + 124,
    {F +N Array conversion function is not implemented.

    cye#cybil_error_125 = cyc$cybil_diagnostic_errors + 125,
    {F +N Record conversion function is not implemented.

    cye#cybil_error_126 = cyc$cybil_diagnostic_errors + 126,
    {F +N Unrecognizable operator.

    cye#cybil_error_127 = cyc$cybil_diagnostic_errors + 127,
    {W +N Undefined character encountered - character ignored.

    cye#cybil_error_128 = cyc$cybil_diagnostic_errors + 128,
    {F +N Right parenthesis missing in $+P conversion function parameter list.

    cye#cybil_error_129 = cyc$cybil_diagnostic_errors + 129,
    {F +N First argument of #STRING must be a string variable.

    cye#cybil_error_130 = cyc$cybil_diagnostic_errors + 130,
    {F +N Second parameter expected to be a string expression.

    cye#cybil_error_131 = cyc$cybil_diagnostic_errors + 131,
    {F +N Overflow or underflow converting real/longreal constant.

    cye#cybil_error_132 = cyc$cybil_diagnostic_errors + 132,
    {F +N Incorrect type for $+P built-in function parameter.

    cye#cybil_error_133 = cyc$cybil_diagnostic_errors + 133,
    {F +N Third parameter of #STRING must be of character type.

    cye#cybil_error_134 = cyc$cybil_diagnostic_errors + 134,
    {F +N Too many nested inline procedure calls or recursive inline procedure
    {call.

    cye#cybil_error_135 = cyc$cybil_diagnostic_errors + 135,
    {F +N #STRING must be terminated by ')'.

    cye#cybil_error_136 = cyc$cybil_diagnostic_errors + 136,
    {C +N Compiler table overflow (PH4 heap) - increase memory field length.

    cye#cybil_error_137 = cyc$cybil_diagnostic_errors + 137,
    {F +N Longreal operation not implemented.

    cye#cybil_error_138 = cyc$cybil_diagnostic_errors + 138,
    {F +N Parameter number +P of built-in function +P is out of range.

    cye#cybil_error_139 = cyc$cybil_diagnostic_errors + 139,
    {F +N Parameter number +P of built-in function +P is not a constant or
    {variable.

    cye#cybil_error_140 = cyc$cybil_diagnostic_errors + 140,
    {F +N Parameter number +P of built-in function +P is not type integer.

    cye#cybil_error_141 = cyc$cybil_diagnostic_errors + 141,
    {F +N Parameter number +P of built-in function +P is not a constant, variable
    {or expr.

    cye#cybil_error_142 = cyc$cybil_diagnostic_errors + 142,
    {F +N Parameter of +P function is illegal.

    cye#cybil_error_143 = cyc$cybil_diagnostic_errors + 143,
    {F +N A colon is needed to separate the adaptable type from the fixer list in
    {#SIZE.

    cye#cybil_error_144 = cyc$cybil_diagnostic_errors + 144,
    {F +N The fixer list for an adaptable type must begin with a left bracket.

    cye#cybil_error_145 = cyc$cybil_diagnostic_errors + 145,
    {F +N Parameter number +P of built-in function +P is not a constant.

    cye#cybil_error_146 = cyc$cybil_diagnostic_errors + 146,
    {W +N Lifetime of parental is less than lifetime of pointer.

    cye#cybil_error_147 = cyc$cybil_diagnostic_errors + 147,
    {F +N Right argument of 'IN' operator is not a set.

    cye#cybil_error_148 = cyc$cybil_diagnostic_errors + 148,
    {F +N Base type of set not compatible with subject of 'IN' operator.

    cye#cybil_error_149 = cyc$cybil_diagnostic_errors + 149,
    {F +N Arguments of relational operator are not compatible.

    cye#cybil_error_150 = cyc$cybil_diagnostic_errors + 150,
    {F +N '<', '>' not defined for sets.

    cye#cybil_error_151 = cyc$cybil_diagnostic_errors + 151,
    {F +N '<', '<=', '>', '>=' not defined for cells, arrays, and records.

    cye#cybil_error_152 = cyc$cybil_diagnostic_errors + 152,
    {F +N Arrays, variant records, heaps and sequences cannot be compared.

    cye#cybil_error_153 = cyc$cybil_diagnostic_errors + 153,
    {F +N Records containing variant fields, arrays, heaps or sequences cannot be
    {compared.

    cye#cybil_error_154 = cyc$cybil_diagnostic_errors + 154,
    {F +N String lengths are not compatible.

    cye#cybil_error_155 = cyc$cybil_diagnostic_errors + 155,
    {F +N Unary '+' and '-' require an integer operand.

    cye#cybil_error_156 = cyc$cybil_diagnostic_errors + 156,
    {F +N Operands of '+P' operator not compatible.

    cye#cybil_error_157 = cyc$cybil_diagnostic_errors + 157,
    {F +N Invalid type for '+P' operator.

    cye#cybil_error_158 = cyc$cybil_diagnostic_errors + 158,
    {F +N String lengths must be the same for comparisons.

    cye#cybil_error_159 = cyc$cybil_diagnostic_errors + 159,
    {F +N '+P' not defined on sets.

    cye#cybil_error_160 = cyc$cybil_diagnostic_errors + 160,
    {F +N '+P' not defined on booleans.

    cye#cybil_error_161 = cyc$cybil_diagnostic_errors + 161,
    {F +N '+P' not defined on integers.

    cye#cybil_error_162 = cyc$cybil_diagnostic_errors + 162,
    {F +N Arguments of '+P' operator have non-equivalent base types.

    cye#cybil_error_163 = cyc$cybil_diagnostic_errors + 163,
    {F +N Exponentiation requires integer operands.

    cye#cybil_error_164 = cyc$cybil_diagnostic_errors + 164,
    {F +N +P is illegitimate as initial symbol of factor - perhaps an operand is
    {missing.

    cye#cybil_error_165 = cyc$cybil_diagnostic_errors + 165,
    {F +N Improper structure of parenthesized expression.

    cye#cybil_error_166 = cyc$cybil_diagnostic_errors + 166,
    {F +N Missing right parenthesis.

    cye#cybil_error_167 = cyc$cybil_diagnostic_errors + 167,
    {F +N '^' cannot be followed by expression.

    cye#cybil_error_168 = cyc$cybil_diagnostic_errors + 168,
    {F +N Missing left parenthesis in built in function.

    cye#cybil_error_169 = cyc$cybil_diagnostic_errors + 169,
    {F +N Argument of '#ABS' must be integer.

    cye#cybil_error_170 = cyc$cybil_diagnostic_errors + 170,
    {C +N Compiler error (PH3) - Variable has an invalid type field.

    cye#cybil_error_171 = cyc$cybil_diagnostic_errors + 171,
    {F +N Argument of 'SUCC' must be scalar.

    cye#cybil_error_172 = cyc$cybil_diagnostic_errors + 172,
    {F +N Argument of 'SUCC' has no successor.

    cye#cybil_error_173 = cyc$cybil_diagnostic_errors + 173,
    {F +N Argument of 'PRED' must be scalar.

    cye#cybil_error_174 = cyc$cybil_diagnostic_errors + 174,
    {F +N Argument of 'PRED' has no predecessor.

    cye#cybil_error_175 = cyc$cybil_diagnostic_errors + 175,
    {F +N Constant subscript outside index type of array.

    cye#cybil_error_176 = cyc$cybil_diagnostic_errors + 176,
    {F +N Substring index outside of bounds of string.

    cye#cybil_error_177 = cyc$cybil_diagnostic_errors + 177,
    {F +N Improper value for substring length.

    cye#cybil_error_178 = cyc$cybil_diagnostic_errors + 178,
    {C +N Compiler error (PH4) - Variable has an invalid type field.

    cye#cybil_error_179 = cyc$cybil_diagnostic_errors + 179,
    {F +N Parameter no. +P out of range.

    cye#cybil_error_180 = cyc$cybil_diagnostic_errors + 180,
    {F +N 'CAT' operator requires string constants.

    cye#cybil_error_181 = cyc$cybil_diagnostic_errors + 181,
    {F +N '.' may only be used for field selection.

    cye#cybil_error_182 = cyc$cybil_diagnostic_errors + 182,
    {C +N Compiler error (PH4) - Symbol table overflow, too many expressions of
    {the form ^<var>/^<proc> or inline procedure calls.

    cye#cybil_error_183 = cyc$cybil_diagnostic_errors + 183,
    {W +N Pointer variable dereference is not allowed on left side of assignment
    {in a function.

    cye#cybil_error_184 = cyc$cybil_diagnostic_errors + 184,
    {F +N Relative pointers may only be compared to relative pointers.

    cye#cybil_error_185 = cyc$cybil_diagnostic_errors + 185,
    {F +N Operand of 'NOT' must be boolean.

    cye#cybil_error_186 = cyc$cybil_diagnostic_errors + 186,
    {F +N Missing variable.

    cye#cybil_error_187 = cyc$cybil_diagnostic_errors + 187,
    {F +N Reference to the undefined constant +P.

    cye#cybil_error_188 = cyc$cybil_diagnostic_errors + 188,
    {F +N The constant +P is circularly defined.

    cye#cybil_error_189 = cyc$cybil_diagnostic_errors + 189,
    {F +N The constant +P is improperly defined.

    cye#cybil_error_190 = cyc$cybil_diagnostic_errors + 190,
    {F +N Undeclared identifier - +P.

    cye#cybil_error_191 = cyc$cybil_diagnostic_errors + 191,
    {F +N '+P' cannot be used in this context.

    cye#cybil_error_192 = cyc$cybil_diagnostic_errors + 192,
    {F +N Only pointers may be followed by '^'.

    cye#cybil_error_193 = cyc$cybil_diagnostic_errors + 193,
    {F +N Only arrays may be subscripted.

    cye#cybil_error_194 = cyc$cybil_diagnostic_errors + 194,
    {F +N Subscript does not conform to index type of array.

    cye#cybil_error_195 = cyc$cybil_diagnostic_errors + 195,
    {F +N Missing or misplaced ']'.

    cye#cybil_error_196 = cyc$cybil_diagnostic_errors + 196,
    {F +N Field selection can only be applied to a record.

    cye#cybil_error_197 = cyc$cybil_diagnostic_errors + 197,
    {F +N Field selectors must be identifiers.

    cye#cybil_error_198 = cyc$cybil_diagnostic_errors + 198,
    {F +N '+P' not a field selector of current record.

    cye#cybil_error_199 = cyc$cybil_diagnostic_errors + 199,
    {F +N Param no. - +P must be aligned for inline procedure.

    cye#cybil_error_200 = cyc$cybil_diagnostic_errors + 200,
    {F +N Insufficient space to determine type equivalence.

    cye#cybil_error_201 = cyc$cybil_diagnostic_errors + 201,
    {F +N Ref param no. - +P must be a var or proc.

    cye#cybil_error_202 = cyc$cybil_diagnostic_errors + 202,
    {F +N Ref param no. - +P must be aligned.

    cye#cybil_error_203 = cyc$cybil_diagnostic_errors + 203,
    {F +N Parameter types do not match - param no. +P.

    cye#cybil_error_204 = cyc$cybil_diagnostic_errors + 204,
    {F +N Missing delimiter or operator in parameter list - param no. +P.

    cye#cybil_error_205 = cyc$cybil_diagnostic_errors + 205,
    {F +N Not enough parameters for procedure.

    cye#cybil_error_206 = cyc$cybil_diagnostic_errors + 206,
    {F +N Too many parameters for procedure.

    cye#cybil_error_207 = cyc$cybil_diagnostic_errors + 207,
    {F +N Missing delimiter or operator in substring designator.

    cye#cybil_error_208 = cyc$cybil_diagnostic_errors + 208,
    {F +N Index of substring must be integer.

    cye#cybil_error_209 = cyc$cybil_diagnostic_errors + 209,
    {F +N Length of substring must be integer.

    cye#cybil_error_210 = cyc$cybil_diagnostic_errors + 210,
    {F +N Only procedures and strings can be followed by '('.

    cye#cybil_error_211 = cyc$cybil_diagnostic_errors + 211,
    {F +N '+P' - is an undefined type identifier.

    cye#cybil_error_212 = cyc$cybil_diagnostic_errors + 212,
    {F +N Array references must use '][' instead of a comma.

    cye#cybil_error_213 = cyc$cybil_diagnostic_errors + 213,
    {F +N Cannot pass read-only or FOR control variable to VAR param no. - +P.

    cye#cybil_error_214 = cyc$cybil_diagnostic_errors + 214,
    {F +N Parameterless procedures cannot be followed by '('.

    cye#cybil_error_215 = cyc$cybil_diagnostic_errors + 215,
    {F +N Variables following '^' must be aligned.

    cye#cybil_error_216 = cyc$cybil_diagnostic_errors + 216,
    {F +N Type identifiers cannot be factors of expression.

    cye#cybil_error_217 = cyc$cybil_diagnostic_errors + 217,
    {F +N Value constructor can be used only with set type.

    cye#cybil_error_218 = cyc$cybil_diagnostic_errors + 218,
    {F +N Invalid function reference - $+P.

    cye#cybil_error_219 = cyc$cybil_diagnostic_errors + 219,
    {F +N Length mismatch for parameter number +P.

    cye#cybil_error_220 = cyc$cybil_diagnostic_errors + 220,
    {F +N +P not defined on reals.

    cye#cybil_error_221 = cyc$cybil_diagnostic_errors + 221,
    {F +N +P not defined on longreals.

    cye#cybil_error_222 = cyc$cybil_diagnostic_errors + 222,
    {F +N '^' cannot be used with inline procedure.

    cye#cybil_error_223 = cyc$cybil_diagnostic_errors + 223,
    {F +N '()' expected after function reference.

    cye#cybil_error_224 = cyc$cybil_diagnostic_errors + 224,
    {W +N INLINE PROCEDURES/FUNCTIONS will be kept out of line where possible.

    cye#cybil_error_225 = cyc$cybil_diagnostic_errors + 225,
    {W +N INLINE PROCEDURE/FUNCTION must remain inline.

    cye#cybil_error_226 = cyc$cybil_diagnostic_errors + 226,
    {F +N Unused.

    cye#cybil_error_227 = cyc$cybil_diagnostic_errors + 227,
    {F +N Unused.

    cye#cybil_error_228 = cyc$cybil_diagnostic_errors + 228,
    {F +N +P must be static to initialize static pointer to variable.

    cye#cybil_error_229 = cyc$cybil_diagnostic_errors + 229,
    {F +N +P must be level-0 to initialize static pointer to proc.

    cye#cybil_error_230 = cyc$cybil_diagnostic_errors + 230,
    {F +N Unused.

    cye#cybil_error_231 = cyc$cybil_diagnostic_errors + 231,
    {F +N +P at same block level - may not be used only in variable bounds or
    {initializations.

    cye#cybil_error_232 = cyc$cybil_diagnostic_errors + 232,
    {F +N +P illegal - static bounds and initializations must be constants.

    cye#cybil_error_233 = cyc$cybil_diagnostic_errors + 233,
    {F +N +P - illegal in constant expression.

    cye#cybil_error_234 = cyc$cybil_diagnostic_errors + 234,
    {F +N +P - is not a constant identifier.

    cye#cybil_error_235 = cyc$cybil_diagnostic_errors + 235,
    {F +N Constants cannot be followed by - +P.

    cye#cybil_error_236 = cyc$cybil_diagnostic_errors + 236,
    {F +N Value constructors not allowed in constant expressions.

    cye#cybil_error_237 = cyc$cybil_diagnostic_errors + 237,
    {F +N Unused.

    cye#cybil_error_238 = cyc$cybil_diagnostic_errors + 238,
    {C +N Compiler error (ph4) - declared constant not evaluated.

    cye#cybil_error_239 = cyc$cybil_diagnostic_errors + 239,
    {F +N Only types or type identifiers may follow '$'.

    cye#cybil_error_240 = cyc$cybil_diagnostic_errors + 240,
    {F +N Case selection specification must be a constant scalar expression.

    cye#cybil_error_241 = cyc$cybil_diagnostic_errors + 241,
    {F +N Case selection specification type does not conform to case selector type.

    cye#cybil_error_242 = cyc$cybil_diagnostic_errors + 242,
    {F +N Case selection specification subrange must be increasing.

    cye#cybil_error_243 = cyc$cybil_diagnostic_errors + 243,
    {F +N Constant scalar value too large.

    cye#cybil_error_244 = cyc$cybil_diagnostic_errors + 244,
    {F +N Case selector type must be scalar type.

    cye#cybil_error_245 = cyc$cybil_diagnostic_errors + 245,
    {F +N Case selector must be a variable or expression.

    cye#cybil_error_246 = cyc$cybil_diagnostic_errors + 246,
    {F +N '=' required for case selection specification delimiter.

    cye#cybil_error_247 = cyc$cybil_diagnostic_errors + 247,
    {F +N Case selection specification not unique, value previously specified at
    {line +P.

    cye#cybil_error_248 = cyc$cybil_diagnostic_errors + 248,
    {F +N Label scope violation.

    cye#cybil_error_249 = cyc$cybil_diagnostic_errors + 249,
    {F +N Result length variable must be integer. (Parameter +P)

    cye#cybil_error_250 = cyc$cybil_diagnostic_errors + 250,
    {W +N Label reference required.

    cye#cybil_error_251 = cyc$cybil_diagnostic_errors + 251,
    {F +N Label '+P' reference at line +P not within scope of definition.

    cye#cybil_error_252 = cyc$cybil_diagnostic_errors + 252,
    {F +N

    cye#cybil_error_253 = cyc$cybil_diagnostic_errors + 253,
    {F +N Form 'GOTO EXIT' must be used for non-local label reference.

    cye#cybil_error_254 = cyc$cybil_diagnostic_errors + 254,
    {F +N Form 'GOTO EXIT' used for local label reference.

    cye#cybil_error_255 = cyc$cybil_diagnostic_errors + 255,
    {F +N Type of expression must be boolean.

    cye#cybil_error_256 = cyc$cybil_diagnostic_errors + 256,
    {F +N Invalid label identifier.

    cye#cybil_error_257 = cyc$cybil_diagnostic_errors + 257,
    {F +N Unrecognizable statement.

    cye#cybil_error_258 = cyc$cybil_diagnostic_errors + 258,
    {F +N Left part of assignment statement must be a variable or function
    {identifier.

    cye#cybil_error_259 = cyc$cybil_diagnostic_errors + 259,
    {F +N Bound variant record assignment not allowed.

    cye#cybil_error_260 = cyc$cybil_diagnostic_errors + 260,
    {F +N Incompatible types are not assignable.

    cye#cybil_error_261 = cyc$cybil_diagnostic_errors + 261,
    {F +N Cycle label must reference a statically encompassing repetitive
    {statement.

    cye#cybil_error_262 = cyc$cybil_diagnostic_errors + 262,
    {F +N If statement can not be cycled.

    cye#cybil_error_263 = cyc$cybil_diagnostic_errors + 263,
    {F +N Case statement can not be cycled.

    cye#cybil_error_264 = cyc$cybil_diagnostic_errors + 264,
    {F +N Begin statement can not be cycled.

    cye#cybil_error_265 = cyc$cybil_diagnostic_errors + 265,
    {F +N Procedure statement can not be cycled.

    cye#cybil_error_266 = cyc$cybil_diagnostic_errors + 266,
    {F +N Only repetitive structured statements may be cycled.

    cye#cybil_error_267 = cyc$cybil_diagnostic_errors + 267,
    {F +N Exit label must reference a statically encompassing structured statement.

    cye#cybil_error_268 = cyc$cybil_diagnostic_errors + 268,
    {F +N Procedure reference not within the scope of exit statement.

    cye#cybil_error_269 = cyc$cybil_diagnostic_errors + 269,
    {F +N Procedure to be exited from must statically encompass the exit statement.

    cye#cybil_error_270 = cyc$cybil_diagnostic_errors + 270,
    {F +N Statement ending delimiter required.

    cye#cybil_error_271 = cyc$cybil_diagnostic_errors + 271,
    {F +N Pointer to cell can not be assigned to pointer to non-fixed type or
    {pointer to sequence.

    cye#cybil_error_272 = cyc$cybil_diagnostic_errors + 272,
    {F +N Number read variable must be integer. (Parameter +P)

    cye#cybil_error_273 = cyc$cybil_diagnostic_errors + 273,
    {F +N Write binary statement may only reference a binary file. (Parameter +P)

    cye#cybil_error_274 = cyc$cybil_diagnostic_errors + 274,
    {F +N Write sequential statement may only reference a direct file. (Parameter
    {+P)

    cye#cybil_error_275 = cyc$cybil_diagnostic_errors + 275,
    {F +N Missing delimiter, ')' expected.

    cye#cybil_error_276 = cyc$cybil_diagnostic_errors + 276,
    {F +N Write line statement may only reference a legible or a print file.
    {(Parameter +P)

    cye#cybil_error_277 = cyc$cybil_diagnostic_errors + 277,
    {F +N Pointer variable reference required.

    cye#cybil_error_278 = cyc$cybil_diagnostic_errors + 278,
    {F +N Tag field fixer must be scalar type.

    cye#cybil_error_279 = cyc$cybil_diagnostic_errors + 279,
    {F +N Tag field fixer not specified in variant record selection values.

    cye#cybil_error_280 = cyc$cybil_diagnostic_errors + 280,
    {F +N Tag field fixer type does not agree with variant record tag field
    {selector type.

    cye#cybil_error_281 = cyc$cybil_diagnostic_errors + 281,
    {F +N Not enough fixers in bounds list.

    cye#cybil_error_282 = cyc$cybil_diagnostic_errors + 282,
    {F +N Too many fixers in bounds list.

    cye#cybil_error_283 = cyc$cybil_diagnostic_errors + 283,
    {F +N Missing delimiter, ',' or ']' expected.

    cye#cybil_error_284 = cyc$cybil_diagnostic_errors + 284,
    {F +N Left part of successor statement must be a variable or function
    {identifier.

    cye#cybil_error_285 = cyc$cybil_diagnostic_errors + 285,
    {F +N Left part of predecessor statement must be a variable or function
    {identifier.

    cye#cybil_error_286 = cyc$cybil_diagnostic_errors + 286,
    {F +N Read binary statement may only reference a binary file. (Parameter +P)

    cye#cybil_error_287 = cyc$cybil_diagnostic_errors + 287,
    {F +N Read sequential statement may only reference a direct file. (Parameter
    {+P)

    cye#cybil_error_288 = cyc$cybil_diagnostic_errors + 288,
    {F +N Read legible statement may only reference a legible file. (Parameter +P)

    cye#cybil_error_289 = cyc$cybil_diagnostic_errors + 289,
    {F +N Type of expression must be integer.

    cye#cybil_error_290 = cyc$cybil_diagnostic_errors + 290,
    {F +N Only one label may label a statement.

    cye#cybil_error_291 = cyc$cybil_diagnostic_errors + 291,
    {F +N Missing terminator, ';' expected.

    cye#cybil_error_292 = cyc$cybil_diagnostic_errors + 292,
    {F +N Missing delimiter, 'DO' expected.

    cye#cybil_error_293 = cyc$cybil_diagnostic_errors + 293,
    {F +N +P incongruous with +P statement at line +P.

    cye#cybil_error_294 = cyc$cybil_diagnostic_errors + 294,
    {F +N Left hand side must be of type scalar or subrange thereof.

    cye#cybil_error_295 = cyc$cybil_diagnostic_errors + 295,
    {F +N Not implemented.

    cye#cybil_error_296 = cyc$cybil_diagnostic_errors + 296,
    {F +N Selection value at line +P conflicts with selection value at line +P.

    cye#cybil_error_297 = cyc$cybil_diagnostic_errors + 297,
    {F +N Type of selection value does not conform to type of selector.

    cye#cybil_error_298 = cyc$cybil_diagnostic_errors + 298,
    {F +N Variable reference required.

    cye#cybil_error_299 = cyc$cybil_diagnostic_errors + 299,
    {F +N Missing delimiter, 'OF' expected.

    cye#cybil_error_300 = cyc$cybil_diagnostic_errors + 300,
    {F +N Missing delimiter, '=' expected.

    cye#cybil_error_301 = cyc$cybil_diagnostic_errors + 301,
    {F +N Statement delimiter expected.

    cye#cybil_error_302 = cyc$cybil_diagnostic_errors + 302,
    {F +N Bad class for assign operator.

    cye#cybil_error_303 = cyc$cybil_diagnostic_errors + 303,
    {F +N Span fixer expected, missing '['.

    cye#cybil_error_304 = cyc$cybil_diagnostic_errors + 304,
    {F +N Variant record selection value at line +P must be an increasing subrange.

    cye#cybil_error_305 = cyc$cybil_diagnostic_errors + 305,
    {F +N Type identifier or replication group required.

    cye#cybil_error_306 = cyc$cybil_diagnostic_errors + 306,
    {F +N Replication expression must be integer type.

    cye#cybil_error_307 = cyc$cybil_diagnostic_errors + 307,
    {F +N Unexpected operator encountered, type identifier expected.

    cye#cybil_error_308 = cyc$cybil_diagnostic_errors + 308,
    {F +N Type identifier expected.

    cye#cybil_error_309 = cyc$cybil_diagnostic_errors + 309,
    {F +N Missing delimiter, ']' expected.

    cye#cybil_error_310 = cyc$cybil_diagnostic_errors + 310,
    {F +N Type of fixer does not agree with type of adaptable field, fixer must be
    {scalar type.

    cye#cybil_error_311 = cyc$cybil_diagnostic_errors + 311,
    {F +N Type of fixer does not agree with type of adaptable field.

    cye#cybil_error_312 = cyc$cybil_diagnostic_errors + 312,
    {F +N Subrange star fixer expected.

    cye#cybil_error_313 = cyc$cybil_diagnostic_errors + 313,
    {W +N Operator '..' required, subrange fixer expression expected.

    cye#cybil_error_314 = cyc$cybil_diagnostic_errors + 314,
    {F +N Only a pointer to sequence or a heap variable may be reset.

    cye#cybil_error_315 = cyc$cybil_diagnostic_errors + 315,
    {F +N Pointer variable expected.

    cye#cybil_error_316 = cyc$cybil_diagnostic_errors + 316,
    {F +N Heap storage class can only be reset en-masse, 'TO' clause may not be
    {specified.

    cye#cybil_error_317 = cyc$cybil_diagnostic_errors + 317,
    {F +N Heap variable reference expected.

    cye#cybil_error_318 = cyc$cybil_diagnostic_errors + 318,
    {F +N Pointer to sequence variable reference expected.

    cye#cybil_error_319 = cyc$cybil_diagnostic_errors + 319,
    {F +N Initial value outside of range of control variable.

    cye#cybil_error_320 = cyc$cybil_diagnostic_errors + 320,
    {F +N Final value outside of range of control variable.

    cye#cybil_error_321 = cyc$cybil_diagnostic_errors + 321,
    {F +N Missing delimiter, 'THEN' expected.

    cye#cybil_error_322 = cyc$cybil_diagnostic_errors + 322,
    {F +N Control variable must be a variable.

    cye#cybil_error_323 = cyc$cybil_diagnostic_errors + 323,
    {F +N Control variable must be scalar type.

    cye#cybil_error_324 = cyc$cybil_diagnostic_errors + 324,
    {F +N Control variable may not be an unaligned component of a packed structure.

    cye#cybil_error_325 = cyc$cybil_diagnostic_errors + 325,
    {F +N Missing delimiter, ':=' expected.

    cye#cybil_error_326 = cyc$cybil_diagnostic_errors + 326,
    {F +N Initial value and control variable types are incompatible.

    cye#cybil_error_327 = cyc$cybil_diagnostic_errors + 327,
    {F +N Missing delimiter, 'TO' or 'DOWNTO' expected.

    cye#cybil_error_328 = cyc$cybil_diagnostic_errors + 328,
    {F +N Final value and control variable types are incompatible.

    cye#cybil_error_329 = cyc$cybil_diagnostic_errors + 329,
    {F +N Allocation designator > adaptable string bound.

    cye#cybil_error_330 = cyc$cybil_diagnostic_errors + 330,
    {F +N Missing delimiter, 'IN' expected.

    cye#cybil_error_331 = cyc$cybil_diagnostic_errors + 331,
    {F +N Fixer list specified for non-adaptable pointer.

    cye#cybil_error_332 = cyc$cybil_diagnostic_errors + 332,
    {F +N Too many fixers in adaptable fixer list, ']' expected.

    cye#cybil_error_333 = cyc$cybil_diagnostic_errors + 333,
    {F +N Heap assignment not allowed.

    cye#cybil_error_334 = cyc$cybil_diagnostic_errors + 334,
    {F +N Records or arrays containing a heap are unassignable.

    cye#cybil_error_335 = cyc$cybil_diagnostic_errors + 335,
    {F +N Read only, bound variant tag, and FOR control variables not assignable.

    cye#cybil_error_336 = cyc$cybil_diagnostic_errors + 336,
    {F +N Assignment to a formal type not allowed.

    cye#cybil_error_337 = cyc$cybil_diagnostic_errors + 337,
    {F +N Bound variant pointer may not be assigned to pointer to variant.

    cye#cybil_error_338 = cyc$cybil_diagnostic_errors + 338,
    {F +N Fixer list expected for adaptable or bound variant pointer.

    cye#cybil_error_339 = cyc$cybil_diagnostic_errors + 339,
    {F +N Elements of span fixer must be fixed type.

    cye#cybil_error_340 = cyc$cybil_diagnostic_errors + 340,
    {F +N Case statement must have at least one selection specifier.

    cye#cybil_error_341 = cyc$cybil_diagnostic_errors + 341,
    {F +N Missing delimiter, '[' expected.

    cye#cybil_error_342 = cyc$cybil_diagnostic_errors + 342,
    {F +N Unrecognizable +P statement.

    cye#cybil_error_343 = cyc$cybil_diagnostic_errors + 343,
    {F +N Form 'GOTO EXIT' used for local label reference '+P' at line +P.

    cye#cybil_error_344 = cyc$cybil_diagnostic_errors + 344,
    {F +N Extraneous +P.

    cye#cybil_error_345 = cyc$cybil_diagnostic_errors + 345,
    {F +N +P required for +P statement at line +P.

    cye#cybil_error_346 = cyc$cybil_diagnostic_errors + 346,
    {F +N Missing +P beginning at line +P.

    cye#cybil_error_347 = cyc$cybil_diagnostic_errors + 347,
    {F +N Unexpected +P encountered, +P assumed for +P at line +P.

    cye#cybil_error_348 = cyc$cybil_diagnostic_errors + 348,
    {F +N Unexpected case selector specification encountered.

    cye#cybil_error_349 = cyc$cybil_diagnostic_errors + 349,
    {F +N Unexpected procedure reference, missing ';' suspected.

    cye#cybil_error_350 = cyc$cybil_diagnostic_errors + 350,
    {F +N Redundant +P encountered.

    cye#cybil_error_351 = cyc$cybil_diagnostic_errors + 351,
    {F +N Unexpected +P encountered which corresponds with +P statement at line +P.

    cye#cybil_error_352 = cyc$cybil_diagnostic_errors + 352,
    {F +N Unable to determine ending label correspondance.

    cye#cybil_error_353 = cyc$cybil_diagnostic_errors + 353,
    {F +N Ending label must reference a structured statement.

    cye#cybil_error_354 = cyc$cybil_diagnostic_errors + 354,
    {F +N Unexpected +P encountered.

    cye#cybil_error_355 = cyc$cybil_diagnostic_errors + 355,
    {F +N Ending identifier must be a procedure identifier.

    cye#cybil_error_356 = cyc$cybil_diagnostic_errors + 356,
    {W +N Ending label matches previous statement at line +P.

    cye#cybil_error_357 = cyc$cybil_diagnostic_errors + 357,
    {F +N Ending label matches +P statement at line +P.

    cye#cybil_error_358 = cyc$cybil_diagnostic_errors + 358,
    {W +N Unable to find ending label correspondance within current procedure.

    cye#cybil_error_359 = cyc$cybil_diagnostic_errors + 359,
    {W +N Ending identifier is not in agreement with current procedure.

    cye#cybil_error_360 = cyc$cybil_diagnostic_errors + 360,
    {F +N Expected a label or procedure identifier.

    cye#cybil_error_361 = cyc$cybil_diagnostic_errors + 361,
    {F +N Expected ']', too many fixers in bounds list.

    cye#cybil_error_362 = cyc$cybil_diagnostic_errors + 362,
    {F +N Bound variant record must have at least one variation.

    cye#cybil_error_363 = cyc$cybil_diagnostic_errors + 363,
    {F +N Unordered if statement alternatives beginning at line +P.

    cye#cybil_error_364 = cyc$cybil_diagnostic_errors + 364,
    {F +N Ending label corresponds with +P statement at line +P.

    cye#cybil_error_365 = cyc$cybil_diagnostic_errors + 365,
    {F +N Ending delimiter doesn't, assume extraneous.

    cye#cybil_error_366 = cyc$cybil_diagnostic_errors + 366,
    {F +N Invalid label statement.

    cye#cybil_error_367 = cyc$cybil_diagnostic_errors + 367,
    {F +N Reset key value must be an integer expression. (Parameter +P)

    cye#cybil_error_368 = cyc$cybil_diagnostic_errors + 368,
    {F +N Key variable must be integer. (Parameter +P)

    cye#cybil_error_369 = cyc$cybil_diagnostic_errors + 369,
    {F +N Write partial statement may only reference a print or a legible file.

    cye#cybil_error_370 = cyc$cybil_diagnostic_errors + 370,
    {F +N Write direct statement may only reference a direct file.

    cye#cybil_error_371 = cyc$cybil_diagnostic_errors + 371,
    {F +N Key value must be an integer expression. (Parameter +P)

    cye#cybil_error_372 = cyc$cybil_diagnostic_errors + 372,
    {F +N Partial read boolean variable expected. (Parameter +P)

    cye#cybil_error_373 = cyc$cybil_diagnostic_errors + 373,
    {F +N Key variable expected. (Parameter +P)

    cye#cybil_error_374 = cyc$cybil_diagnostic_errors + 374,
    {F +N Buffer variable expected. (Parameter +P)

    cye#cybil_error_375 = cyc$cybil_diagnostic_errors + 375,
    {F +N String variable expected. (Parameter +P)

    cye#cybil_error_376 = cyc$cybil_diagnostic_errors + 376,
    {F +N Number read variable expected. (Parameter +P)

    cye#cybil_error_377 = cyc$cybil_diagnostic_errors + 377,
    {F +N Result length variable expected. (Parameter +P)

    cye#cybil_error_378 = cyc$cybil_diagnostic_errors + 378,
    {F +N Page statement may only reference a print file.

    cye#cybil_error_379 = cyc$cybil_diagnostic_errors + 379,
    {F +N Eject statement may only reference a print file.

    cye#cybil_error_380 = cyc$cybil_diagnostic_errors + 380,
    {F +N Line statement may only reference a print file.

    cye#cybil_error_381 = cyc$cybil_diagnostic_errors + 381,
    {F +N Number of lines must be an integer expression. (Attribute +P)

    cye#cybil_error_382 = cyc$cybil_diagnostic_errors + 382,
    {F +N Skip statement may only reference a print file.

    cye#cybil_error_383 = cyc$cybil_diagnostic_errors + 383,
    {F +N Only a direct file may be reset to a key value.

    cye#cybil_error_384 = cyc$cybil_diagnostic_errors + 384,
    {F +N Print files may not be read.

    cye#cybil_error_385 = cyc$cybil_diagnostic_errors + 385,
    {F +N File variable expected. (Parameter +P)

    cye#cybil_error_386 = cyc$cybil_diagnostic_errors + 386,
    {F +N File position specified more than once. (Attribute +P)

    cye#cybil_error_387 = cyc$cybil_diagnostic_errors + 387,
    {F +N #CODESET specified more than once. (Attribute +P)

    cye#cybil_error_388 = cyc$cybil_diagnostic_errors + 388,
    {F +N #CODESET argument must be a string expression. (Attribute +P)

    cye#cybil_error_389 = cyc$cybil_diagnostic_errors + 389,
    {F +N #CODESET must be a constant string expression. (Attribute +P)

    cye#cybil_error_390 = cyc$cybil_diagnostic_errors + 390,
    {F +N #PAGEPROC may only be associated with print files. (Attribute +P)

    cye#cybil_error_391 = cyc$cybil_diagnostic_errors + 391,
    {F +N #PAGEPROC specified more than once. (Attribute +P)

    cye#cybil_error_392 = cyc$cybil_diagnostic_errors + 392,
    {F +N Read partial statement may only reference a legible file.

    cye#cybil_error_393 = cyc$cybil_diagnostic_errors + 393,
    {F +N #PAGESIZE specified more than once. (Attribute +P)

    cye#cybil_error_394 = cyc$cybil_diagnostic_errors + 394,
    {F +N Unrecognizable file attribute. (Attribute +P)

    cye#cybil_error_395 = cyc$cybil_diagnostic_errors + 395,
    {F +N File name specified more than once. (Attribute +P)

    cye#cybil_error_396 = cyc$cybil_diagnostic_errors + 396,
    {F +N #OLD-#NEW specified more than once. (Attribute +P)

    cye#cybil_error_397 = cyc$cybil_diagnostic_errors + 397,
    {F +N Print files may only have #OUT for mode. (Attribute +P)

    cye#cybil_error_398 = cyc$cybil_diagnostic_errors + 398,
    {F +N #IN specified more than once. (Attribute +P)

    cye#cybil_error_399 = cyc$cybil_diagnostic_errors + 399,
    {F +N #OUT specified more than once. (Attribute +P)

    cye#cybil_error_400 = cyc$cybil_diagnostic_errors + 400,
    {F +N File attributes may only be applied to files. (Attribute +P)

    cye#cybil_error_401 = cyc$cybil_diagnostic_errors + 401,
    {F +N Field length specifier must be integer. (Parameter +P)

    cye#cybil_error_402 = cyc$cybil_diagnostic_errors + 402,
    {F +N Expected '(' for radix specifier. (Parameter +P)

    cye#cybil_error_403 = cyc$cybil_diagnostic_errors + 403,
    {F +N Radix expression must be integer. (Parameter +P)

    cye#cybil_error_404 = cyc$cybil_diagnostic_errors + 404,
    {F +N Expected ')' for radix specifier. (Parameter +P)

    cye#cybil_error_405 = cyc$cybil_diagnostic_errors + 405,
    {F +N Expected field length or radix spec for scalar field. (Parameter +P)

    cye#cybil_error_406 = cyc$cybil_diagnostic_errors + 406,
    {F +N Missing delimiter, ',' or ')' expected.

    cye#cybil_error_407 = cyc$cybil_diagnostic_errors + 407,
    {F +N Expected positions/char expression. (Parameter +P)

    cye#cybil_error_408 = cyc$cybil_diagnostic_errors + 408,
    {F +N Read direct statement may only reference a direct file.

    cye#cybil_error_409 = cyc$cybil_diagnostic_errors + 409,
    {F +N Radix spec expected for pointer specifier.

    cye#cybil_error_410 = cyc$cybil_diagnostic_errors + 410,
    {F +N Put element must be scalar, string, or pointer expression. (Parameter +P)

    cye#cybil_error_411 = cyc$cybil_diagnostic_errors + 411,
    {F +N Bound variant record read not allowed. (Parameter +P)

    cye#cybil_error_412 = cyc$cybil_diagnostic_errors + 412,
    {F +N Heap read not allowed. (Parameter +P)

    cye#cybil_error_413 = cyc$cybil_diagnostic_errors + 413,
    {F +N Formal types are not readable. (Parameter +P)

    cye#cybil_error_414 = cyc$cybil_diagnostic_errors + 414,
    {F +N Records or arrays containing a heap are unreadable. (Parameter +P)

    cye#cybil_error_415 = cyc$cybil_diagnostic_errors + 415,
    {F +N #PAGESIZE may only be assocated with print files. (Attribute +P)

    cye#cybil_error_416 = cyc$cybil_diagnostic_errors + 416,
    {F +N Expected ')', too many elements in I/O list.  (Only +P allowable)

    cye#cybil_error_417 = cyc$cybil_diagnostic_errors + 417,
    {F +N Expected '(' for +P. (Attribute +P)

    cye#cybil_error_418 = cyc$cybil_diagnostic_errors + 418,
    {F +N Expected ')' for +P. (Attribute +P)

    cye#cybil_error_419 = cyc$cybil_diagnostic_errors + 419,
    {F +N All fixers in bounds list must be constant except last.

    cye#cybil_error_420 = cyc$cybil_diagnostic_errors + 420,
    {F +N Concatenation element must be scalar, string, pointer or floating point
    {(Parameter +P).

    cye#cybil_error_421 = cyc$cybil_diagnostic_errors + 421,
    {W +N Assignment to a non local variable is not allowed in a function.

    cye#cybil_error_422 = cyc$cybil_diagnostic_errors + 422,
    {W +N Assignment to a  reference parameter of a function is not allowed.

    cye#cybil_error_423 = cyc$cybil_diagnostic_errors + 423,
    {W +N User defined procedures may not be called within a function.

    cye#cybil_error_424 = cyc$cybil_diagnostic_errors + 424,
    {W +N Allocation designator must be a local variable or value parameter of the
    {function.

    cye#cybil_error_425 = cyc$cybil_diagnostic_errors + 425,
    {F +N Selector specification is not in range of selector.

    cye#cybil_error_426 = cyc$cybil_diagnostic_errors + 426,
    {F +N Replication expression must be positive.

    cye#cybil_error_427 = cyc$cybil_diagnostic_errors + 427,
    {F +N Fixer not in range of adaptable field.

    cye#cybil_error_428 = cyc$cybil_diagnostic_errors + 428,
    {F +N Subrange fixer not in range of adaptable subrange.

    cye#cybil_error_429 = cyc$cybil_diagnostic_errors + 429,
    {F +N Tag field fixer not in range of tag field.

    cye#cybil_error_430 = cyc$cybil_diagnostic_errors + 430,
    {F +N Tag field fixer value too large.

    cye#cybil_error_431 = cyc$cybil_diagnostic_errors + 431,
    {F +N Number of lines must be a positive expression. (Attribute +P)

    cye#cybil_error_432 = cyc$cybil_diagnostic_errors + 432,
    {F +N Field length must be positive. (Parameter +P)

    cye#cybil_error_433 = cyc$cybil_diagnostic_errors + 433,
    {W +N Heap or sequence variable must be a local variable or value parameter of
    {the function.

    cye#cybil_error_434 = cyc$cybil_diagnostic_errors + 434,
    {F +N Positions per char must be positive. (Parameter +P)

    cye#cybil_error_435 = cyc$cybil_diagnostic_errors + 435,
    {F +N Radix expression value out of range. (Parameter +P)

    cye#cybil_error_436 = cyc$cybil_diagnostic_errors + 436,
    {F +N Unsupported radix. (Parameter +P)

    cye#cybil_error_437 = cyc$cybil_diagnostic_errors + 437,
    {F +N Line number must be positive. (Parameter +P)

    cye#cybil_error_438 = cyc$cybil_diagnostic_errors + 438,
    {F +N Number of lines must be positive. (Parameter +P)

    cye#cybil_error_439 = cyc$cybil_diagnostic_errors + 439,
    {F +N Value out of range.

    cye#cybil_error_440 = cyc$cybil_diagnostic_errors + 440,
    {F +N String value right truncated.

    cye#cybil_error_441 = cyc$cybil_diagnostic_errors + 441,
    {F +N Selection value out of tag field range.

    cye#cybil_error_442 = cyc$cybil_diagnostic_errors + 442,
    {C +N Compiler error (PH3) - Syntactic Processor Failed.

    cye#cybil_error_443 = cyc$cybil_diagnostic_errors + 443,
    {C +N Compiler error (PH2) - Lexical Processor Failed.

    cye#cybil_error_444 = cyc$cybil_diagnostic_errors + 444,
    {F +N Function identifier assignment not within scope of function.

    cye#cybil_error_445 = cyc$cybil_diagnostic_errors + 445,
    {F +N Label reference +P not within scope of definition.

    cye#cybil_error_446 = cyc$cybil_diagnostic_errors + 446,
    {F +N Form 'GOTO EXIT' must be used for non-local label reference +P.

    cye#cybil_error_447 = cyc$cybil_diagnostic_errors + 447,
    {F +N Form 'GOTO EXIT' used for local label reference +P.

    cye#cybil_error_448 = cyc$cybil_diagnostic_errors + 448,
    {F +N Missing delimiter, '(' expected following +P.

    cye#cybil_error_449 = cyc$cybil_diagnostic_errors + 449,
    {F +N Missing delimiter, ',' expected following parameter +P.

    cye#cybil_error_450 = cyc$cybil_diagnostic_errors + 450,
    {F +N Number of lines must be an integer expression. (Parameter +P)

    cye#cybil_error_451 = cyc$cybil_diagnostic_errors + 451,
    {F +N Unrecognizable put element. (Parameter +P)

    cye#cybil_error_452 = cyc$cybil_diagnostic_errors + 452,
    {F +N Final part expression must be boolean. (Parameter +P)

    cye#cybil_error_453 = cyc$cybil_diagnostic_errors + 453,
    {F +N #PAGEPROC argument must be a procedure reference. (Attribute +P)

    cye#cybil_error_454 = cyc$cybil_diagnostic_errors + 454,
    {F +N Pageproc procedure reference incompatible with assumed pageproc.
    {(Attribute +P)

    cye#cybil_error_455 = cyc$cybil_diagnostic_errors + 455,
    {F +N Not enough fixers in adaptable fixer list.

    cye#cybil_error_456 = cyc$cybil_diagnostic_errors + 456,
    {C +N Compiler error (PH1) - Lexical Processor Failed.

    cye#cybil_error_457 = cyc$cybil_diagnostic_errors + 457,
    {C +N Compiler error (PH4) - Syntactic Processor Failed.

    cye#cybil_error_458 = cyc$cybil_diagnostic_errors + 458,
    {F +N Inconsistent FL and fraction width for parameter +P.

    cye#cybil_error_459 = cyc$cybil_diagnostic_errors + 459,
    {F +N Fraction width < 0 for parameter +P.

    cye#cybil_error_460 = cyc$cybil_diagnostic_errors + 460,
    {F +N Parameter +P must be a constant expression.

    cye#cybil_error_461 = cyc$cybil_diagnostic_errors + 461,
    {F +N Parameter +P is not type integer.

    cye#cybil_error_462 = cyc$cybil_diagnostic_errors + 462,
    {F +N Parameter +P is out of range.

    cye#cybil_error_463 = cyc$cybil_diagnostic_errors + 463,
    {F +N Parameter +P must be array or set.

    cye#cybil_error_464 = cyc$cybil_diagnostic_errors + 464,
    {F +N Parameter +P must be boolean variable.

    cye#cybil_error_465 = cyc$cybil_diagnostic_errors + 465,
    {F +N Incorrect length for parameter +P.

    cye#cybil_error_466 = cyc$cybil_diagnostic_errors + 466,
    {F +N Parameter +P must be a string.

    cye#cybil_error_467 = cyc$cybil_diagnostic_errors + 467,
    {F +N Parameter +P must be a variable.

    cye#cybil_error_468 = cyc$cybil_diagnostic_errors + 468,
    {F +N Parameter +P must be a pointer to proc.

    cye#cybil_error_469 = cyc$cybil_diagnostic_errors + 469,
    {F +N Pointer to proc has incorrect number of parameters. (Parameter +P).

    cye#cybil_error_470 = cyc$cybil_diagnostic_errors + 470,
    {F +N Parameter +P has incorrect or inconsistent type.

    cye#cybil_error_471 = cyc$cybil_diagnostic_errors + 471,
    {F +N parameter +P can not be of type pointer.

    cye#cybil_error_472 = cyc$cybil_diagnostic_errors + 472,
    {F +N A negative fixer is not allowed for a string.

    cye#cybil_error_473 = cyc$cybil_diagnostic_errors + 473,
    {W +N Lifetime of object is less than lifetime of pointer.

    cye#cybil_error_474 = cyc$cybil_diagnostic_errors + 474,
    {F +N Constant expression expected.

    cye#cybil_error_475 = cyc$cybil_diagnostic_errors + 475,
    {F +N String expected after ALIAS.

    cye#cybil_error_476 = cyc$cybil_diagnostic_errors + 476,
    {F +N '..' expected.

    cye#cybil_error_477 = cyc$cybil_diagnostic_errors + 477,
    {F +N Missing PROCEND/FUNCEND.

    cye#cybil_error_478 = cyc$cybil_diagnostic_errors + 478,
    {F +N Missing '[' in alignment.

    cye#cybil_error_479 = cyc$cybil_diagnostic_errors + 479,
    {F +N Illegal alignment constant.

    cye#cybil_error_480 = cyc$cybil_diagnostic_errors + 480,
    {F +N Id mismatch at PROCEND/FUNCEND.

    cye#cybil_error_481 = cyc$cybil_diagnostic_errors + 481,
    {F +N Extraneous PROCEND/FUNCEND.

    cye#cybil_error_482 = cyc$cybil_diagnostic_errors + 482,
    {F +N ';' expected.

    cye#cybil_error_483 = cyc$cybil_diagnostic_errors + 483,
    {F +N Illegal initialization.

    cye#cybil_error_484 = cyc$cybil_diagnostic_errors + 484,
    {F +N XDCL proc not level 0.

    cye#cybil_error_485 = cyc$cybil_diagnostic_errors + 485,
    {F +N ',' or ':' expected in parameter list.

    cye#cybil_error_486 = cyc$cybil_diagnostic_errors + 486,
    {F +N TYPE, VAR, SECTION, CONST, or PROCEDURE expected.

    cye#cybil_error_487 = cyc$cybil_diagnostic_errors + 487,
    {F +N Error in selector.

    cye#cybil_error_488 = cyc$cybil_diagnostic_errors + 488,
    {F +N Illegal packing.

    cye#cybil_error_489 = cyc$cybil_diagnostic_errors + 489,
    {F +N Duplicate fields.

    cye#cybil_error_490 = cyc$cybil_diagnostic_errors + 490,
    {F +N Id expected (SECTION).

    cye#cybil_error_491 = cyc$cybil_diagnostic_errors + 491,
    {F +N PROGRAM must be level 0.

    cye#cybil_error_492 = cyc$cybil_diagnostic_errors + 492,
    {F +N Ending delimiter expected.

    cye#cybil_error_493 = cyc$cybil_diagnostic_errors + 493,
    {F +N Illegal symbol in parameter list.

    cye#cybil_error_494 = cyc$cybil_diagnostic_errors + 494,
    {F +N Id expected in parameter list.

    cye#cybil_error_495 = cyc$cybil_diagnostic_errors + 495,
    {F +N Parameter attribute must be READ.

    cye#cybil_error_496 = cyc$cybil_diagnostic_errors + 496,
    {F +N Missing ']' in parameter attribute.

    cye#cybil_error_497 = cyc$cybil_diagnostic_errors + 497,
    {F +N ',' ';' or ')' expected (parameter list).

    cye#cybil_error_498 = cyc$cybil_diagnostic_errors + 498,
    {F +N Integer expression expected.

    cye#cybil_error_499 = cyc$cybil_diagnostic_errors + 499,
    {F +N '*' illegal with REP.

    cye#cybil_error_500 = cyc$cybil_diagnostic_errors + 500,
    {F +N OF expected (REP).

    cye#cybil_error_501 = cyc$cybil_diagnostic_errors + 501,
    {F +N Identifier expected (field).

    cye#cybil_error_502 = cyc$cybil_diagnostic_errors + 502,
    {F +N ',' or ':' expected (field).

    cye#cybil_error_503 = cyc$cybil_diagnostic_errors + 503,
    {F +N RECEND or ',' expected.

    cye#cybil_error_504 = cyc$cybil_diagnostic_errors + 504,
    {F +N Id expected (variant record).

    cye#cybil_error_505 = cyc$cybil_diagnostic_errors + 505,
    {F +N ':' expected (tag field).

    cye#cybil_error_506 = cyc$cybil_diagnostic_errors + 506,
    {F +N OF expected (tag field).

    cye#cybil_error_507 = cyc$cybil_diagnostic_errors + 507,
    {F +N selectors must be enclosed in =.

    cye#cybil_error_508 = cyc$cybil_diagnostic_errors + 508,
    {F +N Selector or CASEND expected.

    cye#cybil_error_509 = cyc$cybil_diagnostic_errors + 509,
    {F +N Multiple PROGRAMs.

    cye#cybil_error_510 = cyc$cybil_diagnostic_errors + 510,
    {F +N Illegal initialization (XREF).

    cye#cybil_error_511 = cyc$cybil_diagnostic_errors + 511,
    {F +N Read only variable not initialized.

    cye#cybil_error_512 = cyc$cybil_diagnostic_errors + 512,
    {F +N MOD missing (alignment).

    cye#cybil_error_513 = cyc$cybil_diagnostic_errors + 513,
    {F +N Identifier expected (ordinal).

    cye#cybil_error_514 = cyc$cybil_diagnostic_errors + 514,
    {F +N ',' or ')' expected (ordinal).

    cye#cybil_error_515 = cyc$cybil_diagnostic_errors + 515,
    {F +N Pointer type attribute must be READ.

    cye#cybil_error_516 = cyc$cybil_diagnostic_errors + 516,
    {F +N ']' expected (ptr attribute).

    cye#cybil_error_517 = cyc$cybil_diagnostic_errors + 517,
    {F +N Missing ']' (alignment).

    cye#cybil_error_518 = cyc$cybil_diagnostic_errors + 518,
    {F +N ':' expected (SECTION).

    cye#cybil_error_519 = cyc$cybil_diagnostic_errors + 519,
    {F +N OF expected (SET).

    cye#cybil_error_520 = cyc$cybil_diagnostic_errors + 520,
    {F +N '(' expected (STRING).

    cye#cybil_error_521 = cyc$cybil_diagnostic_errors + 521,
    {F +N ')' expected (STRING).

    cye#cybil_error_522 = cyc$cybil_diagnostic_errors + 522,
    {F +N string length > 65535.

    cye#cybil_error_523 = cyc$cybil_diagnostic_errors + 523,
    {F +N READ or WRITE expected (SECTION).

    cye#cybil_error_524 = cyc$cybil_diagnostic_errors + 524,
    {F +N Multiple sections (VAR).

    cye#cybil_error_525 = cyc$cybil_diagnostic_errors + 525,
    {F +N Conflicting VAR attrs.

    cye#cybil_error_526 = cyc$cybil_diagnostic_errors + 526,
    {F +N '(' expected (HEAP).

    cye#cybil_error_527 = cyc$cybil_diagnostic_errors + 527,
    {F +N ')' expected (HEAP).

    cye#cybil_error_528 = cyc$cybil_diagnostic_errors + 528,
    {F +N '(' expected (SEQ).

    cye#cybil_error_529 = cyc$cybil_diagnostic_errors + 529,
    {F +N ')' expected (SEQ).

    cye#cybil_error_530 = cyc$cybil_diagnostic_errors + 530,
    {F +N Label identifier expected.

    cye#cybil_error_531 = cyc$cybil_diagnostic_errors + 531,
    {F +N multidimensional arrays illegal.

    cye#cybil_error_532 = cyc$cybil_diagnostic_errors + 532,
    {F +N '[' expected (ARRAY).

    cye#cybil_error_533 = cyc$cybil_diagnostic_errors + 533,
    {F +N ']' expected (ARRAY).

    cye#cybil_error_534 = cyc$cybil_diagnostic_errors + 534,
    {F +N OF expected (ARRAY).

    cye#cybil_error_535 = cyc$cybil_diagnostic_errors + 535,
    {F +N RECEND expected (record).

    cye#cybil_error_536 = cyc$cybil_diagnostic_errors + 536,
    {F +N Conflicting access attrs.

    cye#cybil_error_537 = cyc$cybil_diagnostic_errors + 537,
    {F +N Missing ',' (CONST).

    cye#cybil_error_538 = cyc$cybil_diagnostic_errors + 538,
    {F +N ':' expected (FUNCTION).

    cye#cybil_error_539 = cyc$cybil_diagnostic_errors + 539,
    {F +N Illegal type declaration.

    cye#cybil_error_540 = cyc$cybil_diagnostic_errors + 540,
    {F +N Label declarations illegal.

    cye#cybil_error_541 = cyc$cybil_diagnostic_errors + 541,
    {F +N Id expected (CONST).

    cye#cybil_error_542 = cyc$cybil_diagnostic_errors + 542,
    {F +N '=' expected (CONST).

    cye#cybil_error_543 = cyc$cybil_diagnostic_errors + 543,
    {F +N Id expected (VAR).

    cye#cybil_error_544 = cyc$cybil_diagnostic_errors + 544,
    {F +N ':' or ',' expected (VAR).

    cye#cybil_error_545 = cyc$cybil_diagnostic_errors + 545,
    {F +N Scope conflict (VAR).

    cye#cybil_error_546 = cyc$cybil_diagnostic_errors + 546,
    {F +N Illegal attribute (VAR).

    cye#cybil_error_547 = cyc$cybil_diagnostic_errors + 547,
    {F +N ',' or ']' expected (VAR)

    cye#cybil_error_548 = cyc$cybil_diagnostic_errors + 548,
    {F +N Id expected (TYPE).

    cye#cybil_error_549 = cyc$cybil_diagnostic_errors + 549,
    {F +N '=' expected (TYPE).

    cye#cybil_error_550 = cyc$cybil_diagnostic_errors + 550,
    {C +N Scope conflict (PROCEDURE/FUNCTION).

    cye#cybil_error_551 = cyc$cybil_diagnostic_errors + 551,
    {F +N Illegal attribute (PROCEDURE/FUNCTION).

    cye#cybil_error_552 = cyc$cybil_diagnostic_errors + 552,
    {F +N ']' or ',' expected (PROCEDURE/FUNCTION)

    cye#cybil_error_553 = cyc$cybil_diagnostic_errors + 553,
    {F +N Id expected (PROCEDURE/FUNCTION).

    cye#cybil_error_554 = cyc$cybil_diagnostic_errors + 554,
    {F +N ';' expected (PROCEDURE/FUNCTION).

    cye#cybil_error_555 = cyc$cybil_diagnostic_errors + 555,
    {F +N Module identifier expected.

    cye#cybil_error_556 = cyc$cybil_diagnostic_errors + 556,
    {F +N Variable is not static or is XREF.

    cye#cybil_error_557 = cyc$cybil_diagnostic_errors + 557,
    {F +N ';' expected (MODULE).

    cye#cybil_error_558 = cyc$cybil_diagnostic_errors + 558,
    {F +N Compilation unit no module.

    cye#cybil_error_559 = cyc$cybil_diagnostic_errors + 559,
    {F +N FUNCEND expected, found PROCEND.

    cye#cybil_error_560 = cyc$cybil_diagnostic_errors + 560,
    {F +N PROCEND expected, found FUNCEND.

    cye#cybil_error_561 = cyc$cybil_diagnostic_errors + 561,
    {F +N #GATE attibute requires an XDCL attribute.

    cye#cybil_error_562 = cyc$cybil_diagnostic_errors + 562,
    {F +N Reference parameter not allowed on functions.

    cye#cybil_error_563 = cyc$cybil_diagnostic_errors + 563,
    {F +N Missing span (HEAP or SEQ).

    cye#cybil_error_564 = cyc$cybil_diagnostic_errors + 564,
    {F +N '=' expected (TYPE).

    cye#cybil_error_565 = cyc$cybil_diagnostic_errors + 565,
    {F +N Unbalanced [ ] (initialization).

    cye#cybil_error_566 = cyc$cybil_diagnostic_errors + 566,
    {F +N REP expected (HEAP or SEQ).

    cye#cybil_error_567 = cyc$cybil_diagnostic_errors + 567,
    {F +N Adaptable string bound < 0 or > 65535.

    cye#cybil_error_568 = cyc$cybil_diagnostic_errors + 568,
    {F +N '(' expected.

    cye#cybil_error_569 = cyc$cybil_diagnostic_errors + 569,
    {F +N ')' expected.

    cye#cybil_error_570 = cyc$cybil_diagnostic_errors + 570,
    {F +N '^' expected.

    cye#cybil_error_571 = cyc$cybil_diagnostic_errors + 571,
    {F +N Value constructors can be used with set, array or record types only.

    cye#cybil_error_572 = cyc$cybil_diagnostic_errors + 572,
    {F +N 'REP' specs may be used solely for ARRAY construction.

    cye#cybil_error_573 = cyc$cybil_diagnostic_errors + 573,
    {F +N 'REP' specs must be a positive expression >= 0.

    cye#cybil_error_574 = cyc$cybil_diagnostic_errors + 574,
    {F +N 'REP' specs must be an integer expression.

    cye#cybil_error_575 = cyc$cybil_diagnostic_errors + 575,
    {F +N Missing delimiter, 'OF' expected in 'REP' spec.

    cye#cybil_error_576 = cyc$cybil_diagnostic_errors + 576,
    {F +N '[]' may be used solely for set construction.

    cye#cybil_error_577 = cyc$cybil_diagnostic_errors + 577,
    {F +N Type of value element does not agree with target type +P.

    cye#cybil_error_578 = cyc$cybil_diagnostic_errors + 578,
    {F +N Case selector must be a constant scalar expression.

    cye#cybil_error_579 = cyc$cybil_diagnostic_errors + 579,
    {F +N No variation for this case selector is specified in the definition of
    {the record +P.

    cye#cybil_error_580 = cyc$cybil_diagnostic_errors + 580,
    {F +N Number of value elements does not agree with the number of fields for
    {record +P.

    cye#cybil_error_581 = cyc$cybil_diagnostic_errors + 581,
    {F +N Not enough value elements for array type +P.

    cye#cybil_error_582 = cyc$cybil_diagnostic_errors + 582,
    {F +N Too many value elements for array type +P.

    cye#cybil_error_583 = cyc$cybil_diagnostic_errors + 583,
    {F +N Missing delimiter, ']' expected.

    cye#cybil_error_584 = cyc$cybil_diagnostic_errors + 584,
    {C +N Compiler error (PH3) - Unexpected end of file while reading 'FETEXT'
    {file.

    cye#cybil_error_585 = cyc$cybil_diagnostic_errors + 585,
    {F +N Element of indefinite value constructor and target type are not
    {convertible.

    cye#cybil_error_586 = cyc$cybil_diagnostic_errors + 586,
    {F +N Only 'NIL' is allowed for typed pointer +P.

    cye#cybil_error_587 = cyc$cybil_diagnostic_errors + 587,
    {F +N Type of expression is not in union +P.

    cye#cybil_error_588 = cyc$cybil_diagnostic_errors + 588,
    {C +N Compiler error (PH1) - INSYMBOL encounters unexpected symkind.

    cye#cybil_error_589 = cyc$cybil_diagnostic_errors + 589,
    {C +N Compiler error (PH1) - NOT-DEFINED ident kind encountered unexpectedly
    {in INSYMBOL.

    cye#cybil_error_590 = cyc$cybil_diagnostic_errors + 590,
    {F +N Invalid compile time statement, 'IF', 'VAR', or a compile time variable
    {expected.

    cye#cybil_error_591 = cyc$cybil_diagnostic_errors + 591,
    {F +N Improper compile time statement fragment, '?+P' must be nested within a
    {'?IF' statement. Symbols ignored.

    cye#cybil_error_592 = cyc$cybil_diagnostic_errors + 592,
    {F +N Improper compile time if statement, 'THEN' expected before '?IFEND'.

    cye#cybil_error_593 = cyc$cybil_diagnostic_errors + 593,
    {F +N Improper compile time if statement, '?ORIF' should follow 'THEN'.

    cye#cybil_error_594 = cyc$cybil_diagnostic_errors + 594,
    {F +N Improper compile time if statement, '?ELSE' should follow 'THEN'.

    cye#cybil_error_595 = cyc$cybil_diagnostic_errors + 595,
    {F +N Improper compile time if statement, 'THEN' should follow '?IF'.

    cye#cybil_error_596 = cyc$cybil_diagnostic_errors + 596,
    {F +N Missing macro attribute, '#LOCK' expected after '['.

    cye#cybil_error_597 = cyc$cybil_diagnostic_errors + 597,
    {F +N Missing delimiter, ']' expected after '#LOCK'.

    cye#cybil_error_598 = cyc$cybil_diagnostic_errors + 598,
    {F +N +P appeared more than once in formal macro parameter list.

    cye#cybil_error_599 = cyc$cybil_diagnostic_errors + 599,
    {F +N Identifier expected in formal macro parameter list.

    cye#cybil_error_600 = cyc$cybil_diagnostic_errors + 600,
    {F +N Missing delimiter, ')' expected after formal macro parameter list.

    cye#cybil_error_601 = cyc$cybil_diagnostic_errors + 601,
    {F +N Missing delimiter, ';' expected after macro declaration.

    cye#cybil_error_602 = cyc$cybil_diagnostic_errors + 602,
    {F +N Toggle statement must be completely contained in the macro text.

    cye#cybil_error_603 = cyc$cybil_diagnostic_errors + 603,
    {F +N Macro name expected after '?MACRO'.

    cye#cybil_error_604 = cyc$cybil_diagnostic_errors + 604,
    {F +N Actual parameter list expected for macro +P.

    cye#cybil_error_605 = cyc$cybil_diagnostic_errors + 605,
    {F +N Missing delimiter, '+P' expected after actual macro parameter list.

    cye#cybil_error_606 = cyc$cybil_diagnostic_errors + 606,
    {F +N Unbalanced '+P' in actual macro parameter text.

    cye#cybil_error_607 = cyc$cybil_diagnostic_errors + 607,
    {F +N +P is not a previously defined compile time variable.

    cye#cybil_error_608 = cyc$cybil_diagnostic_errors + 608,
    {F +N Only boolean constants are allowed in compile time expressions.

    cye#cybil_error_609 = cyc$cybil_diagnostic_errors + 609,
    {F +N Missing delimiter, ')' expected in compile time expression.

    cye#cybil_error_610 = cyc$cybil_diagnostic_errors + 610,
    {F +N Constant, compile time variable, or '(' expected, perhaps an operand is
    {missing.

    cye#cybil_error_611 = cyc$cybil_diagnostic_errors + 611,
    {F +N Compile time operand of 'NOT' must be of type boolean.

    cye#cybil_error_612 = cyc$cybil_diagnostic_errors + 612,
    {F +N Compile time operands of '**' must be of type integer.

    cye#cybil_error_613 = cyc$cybil_diagnostic_errors + 613,
    {F +N Compile time operand types of '+P' do not match.

    cye#cybil_error_614 = cyc$cybil_diagnostic_errors + 614,
    {F +N Compile time '+P' is not compatible with integer operands.

    cye#cybil_error_615 = cyc$cybil_diagnostic_errors + 615,
    {F +N Compile time '+P' is not compatible with boolean operands.

    cye#cybil_error_616 = cyc$cybil_diagnostic_errors + 616,
    {F +N Compile time unary '+' or '-' requires an operand of type integer.

    cye#cybil_error_617 = cyc$cybil_diagnostic_errors + 617,
    {F +N Type of compile time expression right of ':=' does not agree with type
    {of +P.

    cye#cybil_error_618 = cyc$cybil_diagnostic_errors + 618,
    {F +N Missing terminator, ';' expected after '?'.

    cye#cybil_error_619 = cyc$cybil_diagnostic_errors + 619,
    {F +N Missing terminator, '?;' expected after compile time expression.

    cye#cybil_error_620 = cyc$cybil_diagnostic_errors + 620,
    {F +N Missing operator, ':=' expected after +P in compile time assignment
    {statement.

    cye#cybil_error_621 = cyc$cybil_diagnostic_errors + 621,
    {F +N +P is a previously declared compile time variable and can not be
    {redeclared.

    cye#cybil_error_622 = cyc$cybil_diagnostic_errors + 622,
    {F +N Unique compile time variable identifier expected.

    cye#cybil_error_623 = cyc$cybil_diagnostic_errors + 623,
    {F +N Missing key word in compile time variable declaration, 'BOOLEAN'
    {expected.

    cye#cybil_error_624 = cyc$cybil_diagnostic_errors + 624,
    {F +N Type of expression right of ':=' does not agree with type of compile
    {time variable.

    cye#cybil_error_625 = cyc$cybil_diagnostic_errors + 625,
    {F +N Missing operator, ':=' expected after compile time type key word.

    cye#cybil_error_626 = cyc$cybil_diagnostic_errors + 626,
    {F +N Missing delimiter, ':' expected after compile time variable list.

    cye#cybil_error_627 = cyc$cybil_diagnostic_errors + 627,
    {F +N Only a boolean expression is allowed in compile time 'IF' statement,
    {value of FALSE assumed.

    cye#cybil_error_628 = cyc$cybil_diagnostic_errors + 628,
    {F +N Missing terminator, 'THEN' expected after compile time expression.

    cye#cybil_error_629 = cyc$cybil_diagnostic_errors + 629,
    {F +N Usage of +P is not compatible with usage established previously.

    cye#cybil_error_630 = cyc$cybil_diagnostic_errors + 630,
    {W +N Error in compile time if statement, value of FALSE assumed.

    cye#cybil_error_631 = cyc$cybil_diagnostic_errors + 631,
    {F +N ?MACROEND must be nested in a ?MACRO, perhaps a macro definition is in
    {error.

    cye#cybil_error_632 = cyc$cybil_diagnostic_errors + 632,
    {C +N Compiler table overflow (PH1 heap) - increase memory field length.

    cye#cybil_error_633 = cyc$cybil_diagnostic_errors + 633,
    {F +N Expression expected after 'REP' spec.

    cye#cybil_error_634 = cyc$cybil_diagnostic_errors + 634,
    {F +N Value element expected after ','.

    cye#cybil_error_635 = cyc$cybil_diagnostic_errors + 635,
    {F +N Missing delimiter, ',' expected between value elements.

    cye#cybil_error_636 = cyc$cybil_diagnostic_errors + 636,
    {F +N Value element is out of range for type +P.

    cye#cybil_error_637 = cyc$cybil_diagnostic_errors + 637,
    {F +N No fields in record +P, value constructor not allowed. Perhaps record
    {definition is in error.

    cye#cybil_error_638 = cyc$cybil_diagnostic_errors + 638,
    {F +N Error in definition of type for this value constructor, rest of value
    {elements skipped.

    cye#cybil_error_639 = cyc$cybil_diagnostic_errors + 639,
    {F +N '#FILL' can be used with string types only.

    cye#cybil_error_640 = cyc$cybil_diagnostic_errors + 640,
    {F +N '#FILL' must be the last value element in a value constructor.

    cye#cybil_error_641 = cyc$cybil_diagnostic_errors + 641,
    {F +N Parameter of '#FILL' must be of char type.

    cye#cybil_error_642 = cyc$cybil_diagnostic_errors + 642,
    {F +N Missing delimiter, '(' expected after '#FILL'.

    cye#cybil_error_643 = cyc$cybil_diagnostic_errors + 643,
    {F +N Missing delimiter, ')' expected after '#FILL' parameter list.

    cye#cybil_error_644 = cyc$cybil_diagnostic_errors + 644,
    {F +N '?;' encountered outside a compile time statement, perhaps a previous
    {compile time statement is in error.

    cye#cybil_error_645 = cyc$cybil_diagnostic_errors + 645,
    {C +N Compiler error (PH4) - Unexpected end of file while reading 'FETEXT'
    {file.

    cye#cybil_error_646 = cyc$cybil_diagnostic_errors + 646,
    {C +N Compiler table overflow (PH2 heap) - increase memory field length.

    cye#cybil_error_647 = cyc$cybil_diagnostic_errors + 647,
    {F +N Type +P undeclared.

    cye#cybil_error_648 = cyc$cybil_diagnostic_errors + 648,
    {F +N Type +P packed.

    cye#cybil_error_649 = cyc$cybil_diagnostic_errors + 649,
    {F +N +P undeclared in +P.

    cye#cybil_error_650 = cyc$cybil_diagnostic_errors + 650,
    {F +N Illegal constant in +P.

    cye#cybil_error_651 = cyc$cybil_diagnostic_errors + 651,
    {F +N Length not integer in +P.

    cye#cybil_error_652 = cyc$cybil_diagnostic_errors + 652,
    {F +N Circular definition in +P.

    cye#cybil_error_653 = cyc$cybil_diagnostic_errors + 653,
    {F +N Illegal type in +P.

    cye#cybil_error_654 = cyc$cybil_diagnostic_errors + 654,
    {F +N Illegal initialization of +P.

    cye#cybil_error_655 = cyc$cybil_diagnostic_errors + 655,
    {F +N Incompatible initialization of +P.

    cye#cybil_error_656 = cyc$cybil_diagnostic_errors + 656,
    {F +N Illegal expression in +P.

    cye#cybil_error_657 = cyc$cybil_diagnostic_errors + 657,
    {F +N Selector too big.

    cye#cybil_error_658 = cyc$cybil_diagnostic_errors + 658,
    {F +N Missing identifiers in +P.

    cye#cybil_error_659 = cyc$cybil_diagnostic_errors + 659,
    {F +N Multiple definition of +P - definition at line +P holds.

    cye#cybil_error_660 = cyc$cybil_diagnostic_errors + 660,
    {F +N Parent type of +P not scalar.

    cye#cybil_error_661 = cyc$cybil_diagnostic_errors + 661,
    {F +N Lower bound > upper bound in +P.

    cye#cybil_error_662 = cyc$cybil_diagnostic_errors + 662,
    {F +N +P must refer to CYBIL type.

    cye#cybil_error_663 = cyc$cybil_diagnostic_errors + 663,
    {F +N Selector must be scalar.

    cye#cybil_error_664 = cyc$cybil_diagnostic_errors + 664,
    {F +N Base type of +P not scalar.

    cye#cybil_error_665 = cyc$cybil_diagnostic_errors + 665,
    {F +N Index type of +P not scalar.

    cye#cybil_error_666 = cyc$cybil_diagnostic_errors + 666,
    {F +N Component of +P must be non-formal.

    cye#cybil_error_667 = cyc$cybil_diagnostic_errors + 667,
    {F +N Adaptable field in +P not last field.

    cye#cybil_error_668 = cyc$cybil_diagnostic_errors + 668,
    {F +N Field in +P must be non-formal.

    cye#cybil_error_669 = cyc$cybil_diagnostic_errors + 669,
    {F +N Adaptable field in variant of +P not last field.

    cye#cybil_error_670 = cyc$cybil_diagnostic_errors + 670,
    {F +N Packing attribute conflict in +P.

    cye#cybil_error_671 = cyc$cybil_diagnostic_errors + 671,
    {F +N Type +P unpacked.

    cye#cybil_error_672 = cyc$cybil_diagnostic_errors + 672,
    {F +N +P- Nested adaptables.

    cye#cybil_error_673 = cyc$cybil_diagnostic_errors + 673,
    {F +N Tag field in +P not scalar.

    cye#cybil_error_674 = cyc$cybil_diagnostic_errors + 674,
    {F +N Missing READ attr in var +P.

    cye#cybil_error_675 = cyc$cybil_diagnostic_errors + 675,
    {F +N +P not variant record.

    cye#cybil_error_676 = cyc$cybil_diagnostic_errors + 676,
    {F +N +P must be basic type.

    cye#cybil_error_677 = cyc$cybil_diagnostic_errors + 677,
    {F +N Parameter +P not CYBIL type.

    cye#cybil_error_678 = cyc$cybil_diagnostic_errors + 678,
    {F +N Adaptable type illegal for non-parameter variable +P.

    cye#cybil_error_679 = cyc$cybil_diagnostic_errors + 679,
    {F +N Illegal type.

    cye#cybil_error_680 = cyc$cybil_diagnostic_errors + 680,
    {F +N Illegal expression.

    cye#cybil_error_681 = cyc$cybil_diagnostic_errors + 681,
    {F +N Circular definition in +P.

    cye#cybil_error_682 = cyc$cybil_diagnostic_errors + 682,
    {F +N Field +P of +P causes circularity.

    cye#cybil_error_683 = cyc$cybil_diagnostic_errors + 683,
    {F +N Variant of +P causes circularity.

    cye#cybil_error_684 = cyc$cybil_diagnostic_errors + 684,
    {F +N attr of +P not SECTION.

    cye#cybil_error_685 = cyc$cybil_diagnostic_errors + 685,
    {F +N Undefined section id.

    cye#cybil_error_686 = cyc$cybil_diagnostic_errors + 686,
    {F +N +P circular.

    cye#cybil_error_687 = cyc$cybil_diagnostic_errors + 687,
    {F +N Static variables not allowed in inline procedures - +P.

    cye#cybil_error_688 = cyc$cybil_diagnostic_errors + 688,
    {F +N Illegal parameter type (BOUND).

    cye#cybil_error_689 = cyc$cybil_diagnostic_errors + 689,
    {W +N Function can not contain parameter #+P of type pointer to procedure.

    cye#cybil_error_690 = cyc$cybil_diagnostic_errors + 690,
    {F +N Parameter number +P unassignable.

    cye#cybil_error_691 = cyc$cybil_diagnostic_errors + 691,
    {F +N +P unassignable.

    cye#cybil_error_692 = cyc$cybil_diagnostic_errors + 692,
    {F +N Adaptable in a variant field not allowed.

    cye#cybil_error_693 = cyc$cybil_diagnostic_errors + 693,
    {F +N A tag field selector is required for bound variant records.

    cye#cybil_error_694 = cyc$cybil_diagnostic_errors + 694,
    {F +N Lower bound > upper bound.

    cye#cybil_error_695 = cyc$cybil_diagnostic_errors + 695,
    {F +N +P must be of type pointer to procedure.

    cye#cybil_error_696 = cyc$cybil_diagnostic_errors + 696,
    {F +N Parameter +P must be of type pointer to procedure.

    cye#cybil_error_697 = cyc$cybil_diagnostic_errors + 697,
    {F +N Unused.

    cye#cybil_error_698 = cyc$cybil_diagnostic_errors + 698,
    {F +N Unused

    cye#cybil_error_699 = cyc$cybil_diagnostic_errors + 699,
    {F +N Unused.

    cye#cybil_error_700 = cyc$cybil_diagnostic_errors + 700,
    {F +N Unused.

    cye#cybil_error_701 = cyc$cybil_diagnostic_errors + 701,
    {F +N +P not CYBIL type.

    cye#cybil_error_702 = cyc$cybil_diagnostic_errors + 702,
    {F +N Length parameter in STRINGREP must be integer.

    cye#cybil_error_703 = cyc$cybil_diagnostic_errors + 703,
    {C +N pass 1 abort.

    cye#cybil_error_704 = cyc$cybil_diagnostic_errors + 704,
    {C +N pass 2 abort.

    cye#cybil_error_705 = cyc$cybil_diagnostic_errors + 705,
    {C +N ps1 . ph1 .

    cye#cybil_error_706 = cyc$cybil_diagnostic_errors + 706,
    {C +N ps1 . ph2 .

    cye#cybil_error_707 = cyc$cybil_diagnostic_errors + 707,
    {F +N Call from +P+P+P.

    cye#cybil_error_708 = cyc$cybil_diagnostic_errors + 708,
    {F +N Error number +P+P+P.

    cye#cybil_error_709 = cyc$cybil_diagnostic_errors + 709,
    {W +N Parsing routine not implemented yet.

    cye#cybil_error_710 = cyc$cybil_diagnostic_errors + 710,
    {C +N Parsing routine has been asked to parse wrong operator.

    cye#cybil_error_711 = cyc$cybil_diagnostic_errors + 711,
    {C +N Unable to allocate more storage.

    cye#cybil_error_712 = cyc$cybil_diagnostic_errors + 712,
    {C +N iph1lnk. Attempt to release block element with active label elements.

    cye#cybil_error_713 = cyc$cybil_diagnostic_errors + 713,
    {C +N iph1lnk. Block element for def_label was not a begin block.

    cye#cybil_error_714 = cyc$cybil_diagnostic_errors + 714,
    {C +N iph1lnk. Block element for free_label was a begin block.

    cye#cybil_error_715 = cyc$cybil_diagnostic_errors + 715,
    {C +N iph1lnk. Block element for free_label has no label_element.

    cye#cybil_error_716 = cyc$cybil_diagnostic_errors + 716,
    {C +N iph1lnk. Block element for free_label has more than one label element.

    cye#cybil_error_717 = cyc$cybil_diagnostic_errors + 717,
    {C +N iph1lnk. Label not found (branch) or not top of stack (structured stmt).

    cye#cybil_error_718 = cyc$cybil_diagnostic_errors + 718,
    {C +N iph1lnk. Incorrect link processor interface invoked.

    cye#cybil_error_719 = cyc$cybil_diagnostic_errors + 719,
    {C +N iph1lnk. Invalid link option requested.

    cye#cybil_error_720 = cyc$cybil_diagnostic_errors + 720,
    {C +N iph1lnk. Unrecognized branch opcode.

    cye#cybil_error_721 = cyc$cybil_diagnostic_errors + 721,
    {C +N iph1alc. Stack overflow.

    cye#cybil_error_722 = cyc$cybil_diagnostic_errors + 722,
    {C +N iph1alc. Stack underflow.

    cye#cybil_error_723 = cyc$cybil_diagnostic_errors + 723,
    {C +N iph1alc. Attempt to free unallocated or permanently allocated space.

    cye#cybil_error_724 = cyc$cybil_diagnostic_errors + 724,
    {C +N iph1alc. Impossible to allocate space with the requested alignment.

    cye#cybil_error_725 = cyc$cybil_diagnostic_errors + 725,
    {C +N iparfor. For statement values on stack do not match terminated statement.

    cye#cybil_error_726 = cyc$cybil_diagnostic_errors + 726,
    {C +N iparfor. For statement stack is full.

    cye#cybil_error_727 = cyc$cybil_diagnostic_errors + 727,
    {C +N iparfor. Attempt to pop empty stack.

    cye#cybil_error_728 = cyc$cybil_diagnostic_errors + 728,
    {C +N isclutl. Unexpected operator node encountered.

    cye#cybil_error_729 = cyc$cybil_diagnostic_errors + 729,
    {C +N isclini. Invalid node encountered.

    cye#cybil_error_730 = cyc$cybil_diagnostic_errors + 730,
    {C +N iexptyp. Type is not a variable reference.

    cye#cybil_error_731 = cyc$cybil_diagnostic_errors + 731,
    {C +N iparcal. Procedure descriptor is not a variable reference.

    cye#cybil_error_732 = cyc$cybil_diagnostic_errors + 732,
    {C +N iparcal. Symbol table entry is incorrect.

    cye#cybil_error_733 = cyc$cybil_diagnostic_errors + 733,
    {C +N iparcal. Valparamop or refparamop expected.

    cye#cybil_error_734 = cyc$cybil_diagnostic_errors + 734,
    {C +N iparcal. Value param does not have corresponding assignment operator.

    cye#cybil_error_735 = cyc$cybil_diagnostic_errors + 735,
    {C +N itrepro. Operand stack top greater than stack limit in operand stack.

    cye#cybil_error_736 = cyc$cybil_diagnostic_errors + 736,
    {C +N itrepro. Operand stack pop request gives underflow on stack limit.

    cye#cybil_error_737 = cyc$cybil_diagnostic_errors + 737,
    {C +N itrepro. Tree builder trying to jump to operator proc with nil ptr.

    cye#cybil_error_738 = cyc$cybil_diagnostic_errors + 738,
    {C +N itrepro. Operand stack underflow, too few operands avail for operator.

    cye#cybil_error_739 = cyc$cybil_diagnostic_errors + 739,
    {F +N Unimplemented feature.

    cye#cybil_error_740 = cyc$cybil_diagnostic_errors + 740,
    {C +N itrepro. Trying to release a tree node when none active.

    cye#cybil_error_741 = cyc$cybil_diagnostic_errors + 741,
    {C +N itrepro. No tree walking.

    cye#cybil_error_742 = cyc$cybil_diagnostic_errors + 742,
    {C +N ibadsrc. Field is greater than 57 bits and it is not byte aligned.

    cye#cybil_error_743 = cyc$cybil_diagnostic_errors + 743,
    {C +N ibadsrc. Memory alignment, length, and word contained info is incorrect.

    cye#cybil_error_744 = cyc$cybil_diagnostic_errors + 744,
    {C +N ibadsrc. Field is too large to fit into a half register.

    cye#cybil_error_745 = cyc$cybil_diagnostic_errors + 745,
    {C +N ibadsrc. Pointer is not 48 bits long or it is not byte aligned.

    cye#cybil_error_746 = cyc$cybil_diagnostic_errors + 746,
    {C +N ibadsrc. Invalid type has been asked to be loaded.

    cye#cybil_error_747 = cyc$cybil_diagnostic_errors + 747,
    {C +N ibadsrc. Variable is not a pointer.

    cye#cybil_error_748 = cyc$cybil_diagnostic_errors + 748,
    {C +N ibadsrc. Length must be known at compile time.

    cye#cybil_error_749 = cyc$cybil_diagnostic_errors + 749,
    {C +N ibadsrc. Case of base type is invalid.

    cye#cybil_error_750 = cyc$cybil_diagnostic_errors + 750,
    {C +N ibadsrc. Case of alignment type is invalid.

    cye#cybil_error_751 = cyc$cybil_diagnostic_errors + 751,
    {C +N ibadsrc. Case of decision is invalid.

    cye#cybil_error_752 = cyc$cybil_diagnostic_errors + 752,
    {C +N ibadsrc. Field longer than 64 bits.

    cye#cybil_error_753 = cyc$cybil_diagnostic_errors + 753,
    {F +N iph1pce. Reference of invalid or decayed pseudo register +P.

    cye#cybil_error_754 = cyc$cybil_diagnostic_errors + 754,
    {F +N ipceequ. Invalid target pseudo register +P.

    cye#cybil_error_755 = cyc$cybil_diagnostic_errors + 755,
    {F +N iipcutl. Cannot alloc hardware reg +P for pseudo inst.

    cye#cybil_error_756 = cyc$cybil_diagnostic_errors + 756,
    {F +N iipcutl. Overflow area length exceeded for pseudo inst +P+P+P.

    cye#cybil_error_757 = cyc$cybil_diagnostic_errors + 757,
    {F +N ipcplpc. Attempt to alter locked register with invalid instruction.

    cye#cybil_error_758 = cyc$cybil_diagnostic_errors + 758,
    {C +N ictxstk. No runtime space available for allocation of runtime stack.

    cye#cybil_error_759 = cyc$cybil_diagnostic_errors + 759,
    {C +N ictxstk. Trying to pop an empty context stack.

    cye#cybil_error_760 = cyc$cybil_diagnostic_errors + 760,
    {W +N A runtime error will occur if this code is executed.

    cye#cybil_error_761 = cyc$cybil_diagnostic_errors + 761,
    {C +N iph1run. Unrecognized runtime routine.

    cye#cybil_error_762 = cyc$cybil_diagnostic_errors + 762,
    {C +N iph1run. Unrecognized branch opcode.

    cye#cybil_error_763 = cyc$cybil_diagnostic_errors + 763,
    {C +N iph1run. Wrong input or output registers provided to runtime routine.

    cye#cybil_error_764 = cyc$cybil_diagnostic_errors + 764,
    {C +N isymprc. Identifier +P was unrecognized from FE.

    cye#cybil_error_765 = cyc$cybil_diagnostic_errors + 765,
    {F +N Type +P not legal for sets.

    cye#cybil_error_766 = cyc$cybil_diagnostic_errors + 766,
    {F +N Type +P not legal as object of pointer.

    cye#cybil_error_767 = cyc$cybil_diagnostic_errors + 767,
    {F +N Type +P is not supported.

    cye#cybil_error_768 = cyc$cybil_diagnostic_errors + 768,
    {F +N Variable bound subrange +P not legal here.

    cye#cybil_error_769 = cyc$cybil_diagnostic_errors + 769,
    {F +N Type +P not legal field.

    cye#cybil_error_770 = cyc$cybil_diagnostic_errors + 770,
    {F +N Type +P not legal array index.

    cye#cybil_error_771 = cyc$cybil_diagnostic_errors + 771,
    {F +N Built-in function or procedure removed.

    cye#cybil_error_772 = cyc$cybil_diagnostic_errors + 772,
    {C +N iparstr. Invalid string expression.

    cye#cybil_error_773 = cyc$cybil_diagnostic_errors + 773,
    {C +N iparstr. Unrecognized type in stringrep.

    cye#cybil_error_774 = cyc$cybil_diagnostic_errors + 774,
    {C +N iparstr. Unknown operator in stringrep.

    cye#cybil_error_775 = cyc$cybil_diagnostic_errors + 775,
    {C +N utility. Comparison opcode utility error.

    cye#cybil_error_776 = cyc$cybil_diagnostic_errors + 776,
    {C +N iparcas. Stack underflow.

    cye#cybil_error_777 = cyc$cybil_diagnostic_errors + 777,
    {C +N iparcas. Case number selector error.

    cye#cybil_error_778 = cyc$cybil_diagnostic_errors + 778,
    {F +N istoops. Invalid free statement.

    cye#cybil_error_779 = cyc$cybil_diagnostic_errors + 779,
    {F +N Array/record +P too large.

    cye#cybil_error_780 = cyc$cybil_diagnostic_errors + 780,
    {F +N +P - Field alignment conflicts with alignment of its type.

    cye#cybil_error_781 = cyc$cybil_diagnostic_errors + 781,
    {F +N +P - Alignment of automatic variable is not MOD 8.

    cye#cybil_error_782 = cyc$cybil_diagnostic_errors + 782,
    {W +N Non-zero alignment offset will be ignored by dynamic allocation.

    cye#cybil_error_783 = cyc$cybil_diagnostic_errors + 783,
    {W +N PUSH cannot honor an alignment base other than 8.

    cye#cybil_error_784 = cyc$cybil_diagnostic_errors + 784,
    {F +N Fixed span too large.

    cye#cybil_error_785 = cyc$cybil_diagnostic_errors + 785,
    {F +N Illegal adaptable span.

    cye#cybil_error_786 = cyc$cybil_diagnostic_errors + 786,
    {F +N Subrange too large for +P.

    cye#cybil_error_787 = cyc$cybil_diagnostic_errors + 787,
    {C +N iparagg. Array/record is greater than 57 bits and it is not byte aligned.

    cye#cybil_error_788 = cyc$cybil_diagnostic_errors + 788,
    {C +N iparcal. Number of parameters is greater than 127.

    cye#cybil_error_789 = cyc$cybil_diagnostic_errors + 789,
    {C +N ibadsr2. Section offset for operand > 65535.

    cye#cybil_error_790 = cyc$cybil_diagnostic_errors + 790,
    {W +N #SIZE returning rounded bit size.

    cye#cybil_error_791 = cyc$cybil_diagnostic_errors + 791,
    {F +N Unexpected variable given as #SIZE argument.

    cye#cybil_error_792 = cyc$cybil_diagnostic_errors + 792,
    {F +N INLINE parameter +P is not a constant.

    cye#cybil_error_793 = cyc$cybil_diagnostic_errors + 793,
    {F +N Invalid INLINE mnemonic (INLINE parameter 1).

    cye#cybil_error_794 = cyc$cybil_diagnostic_errors + 794,
    {W +N Function result is not defined on all paths.

    cye#cybil_error_795 = cyc$cybil_diagnostic_errors + 795,
    {C +N Relocatable offset exceeds instruction range (MODULE too big).

    cye#cybil_error_796 = cyc$cybil_diagnostic_errors + 796,
    {F +N Select array size must be 256 bits.

    cye#cybil_error_797 = cyc$cybil_diagnostic_errors + 797,
    {F +N Sizes unequal in #unchecked_conversion.

    cye#cybil_error_798 = cyc$cybil_diagnostic_errors + 798,
    {F +N Address size must be 6 bytes.

    cye#cybil_error_799 = cyc$cybil_diagnostic_errors + 799,
    {C +N Current stack frame exceeds 2**15 bytes -use PUSH for large data
    {structures.

    cye#cybil_error_800 = cyc$cybil_diagnostic_errors + 800,
    {F +N Constant range exceeded for computed_result.

    cye#cybil_error_801 = cyc$cybil_diagnostic_errors + 801,
    {F +N Maximum section size exceeded.

    cye#cybil_error_802 = cyc$cybil_diagnostic_errors + 802,
    {C +N Pseudo code buffer size exceeded for procedure - reduce procedure size.

    cye#cybil_error_803 = cyc$cybil_diagnostic_errors + 803,
    {I +N Procedure +P has large value parameter, no. +P, length +P bytes.

    cye#cybil_error_804 = cyc$cybil_diagnostic_errors + 804,
    {F +N Found a fixed type in #SIZE when expecting an adaptable type.

    cye#cybil_error_805 = cyc$cybil_diagnostic_errors + 805,
    {F +N Missing fixer subtree for #SIZE of adaptable type.

    cye#cybil_error_806 = cyc$cybil_diagnostic_errors + 806,
    {F +N PUSH or ALLOCATE of string > ffff(16) bytes or other type > ffffffff(16)
    {not allowed.

    cye#cybil_error_807 = cyc$cybil_diagnostic_errors + 807,
    {C +N ibifops. Unexpected subtree encountered.

    cye#cybil_error_808 = cyc$cybil_diagnostic_errors + 808,
    {C +N Invalid tree node encountered in pointer processing.

    cye#cybil_error_809 = cyc$cybil_diagnostic_errors + 809,
    {C +N Invalid substructure encountered while building descriptor.

    cye#cybil_error_810 = cyc$cybil_diagnostic_errors + 810,
    {I +N Parameter no. +P has been copied in the caller.

    cye#cybil_error_811 = cyc$cybil_diagnostic_errors + 811,
    {I +N Parameter no. +P has been copied in the callee.

    cye#cybil_error_812 = cyc$cybil_diagnostic_errors + 812,
    {F +N Rounded bit length was used to build #SEQ.

    cye#cybil_error_813 = cyc$cybil_diagnostic_errors + 813,
    {W +N Some libraries have not been processed.

    cye#cybil_error_814 = cyc$cybil_diagnostic_errors + 814,
    {W +N Range checking ignored when compiled with high optimization level.

    cye#cybil_error_815 = cyc$cybil_diagnostic_errors + 815,
    {W +N Adaptable field alignment mismatch in parameter number +P.

    cye#cybil_error_816 = cyc$cybil_diagnostic_errors + 816,
    {W +N Alignment mismatch in pointer object type.

    cye#cybil_error_817 = cyc$cybil_diagnostic_errors + 817,
    {F +N Parameters #1 thru #4 of #compare_swap must be 1 word long.

    cye#cybil_error_818 = cyc$cybil_diagnostic_errors + 818,
    {W +N Code scheduling abandoned for this block due to register jamming.

    cye#cybil_error_819 = cyc$cybil_diagnostic_errors + 819,
    {F +N Shift count constant out of bounds. Must be in -63..63.

    cye#cybil_error_820 = cyc$cybil_diagnostic_errors + 820,
    {F +N Unused.

    cye#cybil_error_821 = cyc$cybil_diagnostic_errors + 821,
    {F +N Unused.

    cye#cybil_error_822 = cyc$cybil_diagnostic_errors + 822,
    {F +N Unused.

    cye#cybil_error_823 = cyc$cybil_diagnostic_errors + 823,
    {F +N Unused.

    cye#cybil_error_824 = cyc$cybil_diagnostic_errors + 824,
    {F +N Unused.

    cye#cybil_error_825 = cyc$cybil_diagnostic_errors + 825,
    {F +N Unused.

    cye#cybil_error_826 = cyc$cybil_diagnostic_errors + 826,
    {F +N Unused.

    cye#cybil_error_827 = cyc$cybil_diagnostic_errors + 827,
    {F +N Computation will overflow target machine capacity.

    cye#cybil_error_828 = cyc$cybil_diagnostic_errors + 828,
    {C +N ipcppct. Compiler error 1.

    cye#cybil_error_829 = cyc$cybil_diagnostic_errors + 829,
    {F +N Attempt to divide by constant zero.

    cye#cybil_error_830 = cyc$cybil_diagnostic_errors + 830,
    {F +N For CYBIL-CM, a relative ptr cannot be with respect to the system heap.

    cye#cybil_error_831 = cyc$cybil_diagnostic_errors + 831,
    {C +N ipcpjmp. Compiler error 1.

    cye#cybil_error_832 = cyc$cybil_diagnostic_errors + 832,
    {F +N Expression result would always be out of range.

    cye#cybil_error_833 = cyc$cybil_diagnostic_errors + 833,
    {C +N ipcpjmp. Compiler error 2.

    cye#cybil_error_834 = cyc$cybil_diagnostic_errors + 834,
    {C +N ipcpreg. Compiler error 1.

    cye#cybil_error_835 = cyc$cybil_diagnostic_errors + 835,
    {F +N For CYBILM, a relative ptr cannot be used with the system heap.

    cye#cybil_error_836 = cyc$cybil_diagnostic_errors + 836;
    {F +N For CYBILM, the #TEST_SET lock variable must be a byte.

  CONST
    cyc$first_lda_error = cye#cybil_error_1,
    cyc$first_hlw_error = cye#cybil_error_34,
    cyc$first_jnm_error = cye#cybil_error_147,
    cyc$first_djh_error = cye#cybil_error_240,
    cyc$first_mea1_error = cye#cybil_error_474,
    cyc$first_dgl_error = cye#cybil_error_571,
    cyc$first_mea2_error = cye#cybil_error_647,
    cyc$first_cg8_error = cye#cybil_error_702;

?? OLDTITLE ??
*DECK DECK=CYE$ERROR_CODES_CYBIL EXPAND=FALSE
*copyc CYC$ERROR_CODES_CYBIL_RANGE
*copyc CYE$RUN_TIME_ERROR_CODES
*copyc CYE$CYBIL_COMPILE_ERROR_CODES
*copyc CYE$EXCEPTION_CONDITIONS
*DECK DECK=CYE$EXCEPTION_CONDITIONS EXPAND=FALSE

{* ZCYECIO  cye$exception_conditions *}
*copyc CYC$ERROR_CODES_CYBIL_RANGE
?? NEWTITLE := '~~~~~~ cybil i/o errors : CY 6200 .. 6299' ??
?? FMT (FORMAT := OFF) ??

  CONST

    cyc$min_ecc_cybil_input_output  = cyc$min_ecc + 6200,

    cye$file_name_too_long          = cyc$min_ecc_cybil_input_output + 10,
    {E File name too long, +F.}

    cye$file_not_open               = cyc$min_ecc_cybil_input_output + 15,
    {E File NOT open.}

    cye$illegal_file_name           = cyc$min_ecc_cybil_input_output + 20,
    {E Incorrect file name, +F.}

    cye$illegal_input_request       = cyc$min_ecc_cybil_input_output + 25,
    {E Incorrect input request for +F.}

    cye$illegal_line_number         = cyc$min_ecc_cybil_input_output + 30,
    {E Incorrect display line position for +F.}

    cye$illegal_tab_column          = cyc$min_ecc_cybil_input_output + 31,
    {E Incorrect tab column for +F.}

    cye$illegal_open_request        = cyc$min_ecc_cybil_input_output + 35,
    {E Incorrect open request for +F.}

    cye$illegal_operation           = cyc$min_ecc_cybil_input_output + 37,
    {E Incorrect command issued to +F.}

    cye$illegal_output_request      = cyc$min_ecc_cybil_input_output + 40,
    {E Incorrect output request for +F.}

    cye$illegal_skip_count          = cyc$min_ecc_cybil_input_output + 45,
    {E Incorrect skip count +F.}

    cye$key_past_eoi                = cyc$min_ecc_cybil_input_output + 50,
    {E Key beyond E-O-I on +F.}

    cye$premature_end_of_operation  = cyc$min_ecc_cybil_input_output + 51,
    {E Premature end of operation on file +F.}

    cye$no_memory_to_open_file      = cyc$min_ecc_cybil_input_output + 55,
    {E No memory to open file +F.}

    cye$file_not_found              = cyc$min_ecc_cybil_input_output + 56,
    {E Could NOT find file +F.}

    cye$file_already_exists         = cyc$min_ecc_cybil_input_output + 57,
    {E File (+F) already exists.}

    cyc$max_ecc_cybil_input_output  = cyc$min_ecc_cybil_input_output + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=CYE$RUN_TIME_ERROR_CODES EXPAND=FALSE
*copyc CYC$ERROR_CODES_CYBIL_RANGE
?? NEWTITLE := '  CYDRTEC : CYBIL RUNTIME EXCEPTIONS : ''CY'' 5000 - 9999' ??
?? EJECT ??

  CONST
    cyc$run_time_base_exception = cyc$min_ecc + 5000;

  CONST
    cye$nil_called = cyc$run_time_base_exception + 0,
    {E NIL pointer to procedure called at P = +P.}

    cye$cybil_abort = cyc$run_time_base_exception + 1;
    {E CYBIL run time error, +P, detected at line +P of +P.}

?? OLDTITLE ??
*DECK DECK=CYH$BINARY_FILE_KEY EXPAND=TRUE
{
{  The purpose of this request is to return the "file cell address" at which a
{        binary type file is currently positioned.
{
{
{        CYP$BINARY_FILE_KEY (BINARY_FILE)
{
{
{  BINARY_FILE: (input) This parameter names the binary file to be read.
{
*DECK DECK=CYH$CLOSE_FILE EXPAND=TRUE
{
{  The purpose of this request is to close the specified file.
{
{
{        CYP$CLOSE_FILE (FILE, FILE_POSITION, STATUS)
{
{
{  FILE: (input) This parameter specifies the file to be closed.  This is
{        the pointer that was returned by the cyp$open_file call.
{
{  FILE_POSITION: (input) This parameter specifies the position of the file
{        at the close.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{
*DECK DECK=CYH$CURRENT_COLUMN EXPAND=TRUE
{
{  The purpose of this request is to return the current column within the
{        current line of the specified file; that is, the column at which the
{        next read or write will begin.
{
{
{        CYP$CURRENT_COLUMN (FILE)
{
{
{  FILE: (input) This parameter specifies the file to use when determining
{        the current column within the current line.
{











*DECK DECK=CYH$CURRENT_DISPLAY_LINE EXPAND=TRUE
{
{  The purpose of this request is to return the number of the current line
{        within the current page of the display file.
{
{
{        CYP$CURRENT_DISPLAY_LINE (DISPLAY_FILE)
{
{
{  DISPLAY_FILE: (input) This parameter specifies the display file whose
{        current line number is returned.
{
*DECK DECK=CYH$CURRENT_FILE_POSITION EXPAND=TRUE
{
{  The purpose of this request is to return the current position of the
{        specified FILE.
{
{
{        CYP$CURRENT_FILE_POSITION (FILE)
{
{
{  FILE: (input) This parameter specifies the file whose current position is
{        returned.
{
*DECK DECK=CYH$CURRENT_PAGE_NUMBER EXPAND=TRUE
{
{  The purpose of this request is to return the display file's current page
{        number.
{
{
{        CYP$CURRENT_PAGE_NUMBER (DISPLAY_FILE)
{
{
{  DISPLAY_FILE: (input) This parameter specifies the display file whose
{        current page number is returned.
{
*DECK DECK=CYH$DISPLAY_PAGE_EJECT EXPAND=TRUE
{
{  The purpose of this request is to position the display file at the top of
{        the next page.
{
{
{        CYP$DISPLAY_PAGE_EJECT (DISPLAY_FILE, STATUS)
{
{
{  DISPLAY_FILE: (input) This parameter specifies the display file to be
{        positioned.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_operation
{              cye$illegal_output_request
{
*DECK DECK=CYH$DISPLAY_PAGE_LENGTH EXPAND=TRUE
{
{  The purpose of this request is to return the page length associated with
{        the display file.
{
{
{        CYP$DISPLAY_PAGE_LENGTH (DISPLAY_FILE)
{
{
{  DISPLAY_FILE: (input) This parameter specifies the display file whose
{        page length is returned.
{
*DECK DECK=CYH$DISPLAY_STANDARD_TITLE EXPAND=TRUE
{
{  The purpose of this request is to write a title line to the specified file.
{
{
{        CYP$DISPLAY_STANDARD_TITLE (FILE, TITLE, LINES_AFTER_TITLE, STATUS)
{
{
{  FILE: (input) This parameter specifies the file to receive the title.
{
{  TITLE: (input) This parameter specifies the string of characters to be
{        written.
{
{  LINES_AFTER_TITLE: (input) The number of blank lines to follow the title.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_operation
{              cye$illegal_output_request
{
*DECK DECK=CYH$FILE_CONNECTED_TO_TERMINAL EXPAND=TRUE
{
{  The purpose of this request is to return a value of TRUE if the file is
{        connected to a terminal.  Otherwise, a value of FALSE is returned.
{
{
{        CYP$FILE_CONNECTED_TO_TERMINAL (FILE)
{
{
{  FILE: (input) This parameter specifies the file in question.
{
*DECK DECK=CYH$FLUSH_LINE EXPAND=TRUE
{
{  The purpose of this request is to flush the line buffer for the specified
{        file.
{
{
{        CYP$FLUSH_LINE (FILE, STATUS)
{
{
{  FILE: (input) This parameter specifies the file whose line buffer is to be
{        flushed.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_operation
{              cye$illegal_output_request
{
*DECK DECK=CYH$GET_BINARY_FILE_POINTER EXPAND=TRUE
{
{  The purpose of this request is to get the pointer to the binary file
{        specified by FILE.
{
{
{        CYP$GET_BINARY_FILE_POINTER (FILE, BINARY_FILE_POINTER, STATUS)
{
{
{  FILE: (input) This parameter specifies the file that holds the information
{        sought.
{
{  BINARY_FILE_POINTER: (output) This parameter contains the pointer to the
{        binary file.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_operation
{
*DECK DECK=CYH$GET_FILE_IDENTIFIER EXPAND=TRUE
{
{  The purpose of this request is to get the file identifier associated with
{        the specified file.
{
{
{        CYP$GET_FILE_IDENTIFIER (FILE, FILE_IDENTIFIER, STATUS)
{
{
{  FILE: (input) This parameter specifies the file whose file identifier is
{        to be returned.
{
{  FILE_IDENTIFIER: (output) This parameter specifies the identifier
{        associated with the specified file.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{
*DECK DECK=CYH$GET_KEYED_BINARY EXPAND=TRUE
{
{  The purpose of this request is to read data from a binary type file.
{
{
{        CYP$GET_KEYED_BINARY (BINARY_FILE, POINTER_TO_TARGET, FILE_KEY,
{              NUMBER_OF_CELLS_READ, STATUS)
{
{
{  BINARY_FILE: (input) This parameter names the binary file to be read.
{
{  POINTER_TO_TARGET: (input) This parameter specifies the data structure into
{        which data is to be read.
{
{  FILE_KEY: (input) Parameter specifying the "file cell address" at which the
{        read is to begin.
{
{  NUMBER_OF_CELLS_READ: (output) This parameter returns the number of cells
{        actually read.
{
{  STATUS: (output) Parameter which specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_input_request
{              cye$illegal_operation
{              cye$key_past_eoi
{
*DECK DECK=CYH$GET_NEXT_BINARY EXPAND=TRUE
{
{  The purpose of this request is to read data from a binary type file.
{        The data is read from the current position of the file.
{
{
{        CYP$GET_NEST_BINARY (BINARY_FILE, POINTER_TO_TARGET, FILE_KEY,
{              NUMBER_OF_CELLS_READ, STATUS)
{
{
{  BINARY_FILE: (input) This parameter names the binary file to be read.
{
{  POINTER_TO_TARGET: (input) Parameter specifying the data structure into
{        which data is to be read.
{
{  FILE_KEY: (output) This parameter returns the "file cell address" from
{        which the read began.
{
{  NUMBER_OF_CELLS_READ: (output)  Parameter returning the number of cells
{        actually read.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_input_request
{              cye$illegal_operation
{
*DECK DECK=CYH$GET_NEXT_LINE EXPAND=TRUE
{
{  The purpose of this request is to read the next complete line from the
{        specified file.
{
{
{        CYP$GET_NEXT_LINE (FILE, LINE, NUMBER_OF_CHARACTER_READ, STATUS)
{
{
{  FILE: (input) This parameter specifies the file to be read.
{
{  LINE: (output) This parameter specifies the CYBIL string into which the
{        line is read.
{
{  NUMBER_OF_CHARACTERS_READ: (output) This parameter returns the number of
{        characters transferred into LINE.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_input_request
{              cye$illegal_operation
{
*DECK DECK=CYH$GET_NEXT_RECORD EXPAND=TRUE
{
{  The purpose of this request is to read the next record from a record
{        type file.
{
{
{        CYP$GET_NEXT_RECORD (RECORD_FILE, POINTER_TO_TARGET,
{              NUMBER_OF_CELLS_READ, STATUS)
{
{
{  RECORD_FILE: (input) This parameter specifies the record file to read.
{
{  POINTER_TO_TARGET: (input) This parameter specifies the data structure into
{        which data is to be read.
{
{  NUMBER_OF_CELLS_READ: (output) This parameter returns the number of cells
{        actually read.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_input_request
{              cye$illegal_operation
{
*DECK DECK=CYH$GET_PARTIAL_LINE EXPAND=TRUE
{
{  The purpose of this request is to read a character string from the
{        specified file.
{
{
{        CYP$GET_PARTIAL_LINE (FILE, PARTIAL_LINE, NUMBER_OF_CHARACTERS_READ,
{              LAST_PART_OF_LINE, STATUS)
{
{
{  FILE: (input) This parameter specifies the file to be read.
{
{  PARTIAL_LINE: (output) This parameter specifies the CYBIL string into
{        which the character string is read.
{
{  NUMBER_OF_CHARACTERS_READ: (output) This parameter returns the number of
{        characters transferred into partial_line.
{
{  LAST_PART_OF_LINE: (output) This parameter returns a TRUE value if the end
{        of the line was encountered, otherwise a value of FALSE is returned.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_input_request
{              cye$illegal_operation
{
*DECK DECK=CYH$GET_PARTIAL_RECORD EXPAND=TRUE
{
{  The purpose of this request is to read a portion of a record from a record
{        type file.
{
{
{        CYP$GET_PARTIAL_RECORD (RECORD_FILE, POINTER_TO_TARGET,
{              NUMBER_OF_CELLS_READ, LAST_PART_OF_RECORD, STATUS)
{
{
{  RECORD_FILE: (input) This parameter specifies the record file to be read.
{
{  POINTER_TO_TARGET: (input) This parameter specifies the data structure into
{        which data is to be read.
{
{  NUMBER_OF_CELLS_READ: (output) This parameter returns the number of cells
{        actually read.
{
{  LAST_PART_OF_RECORD: (output) This parameter returns a boolean value
{        indicating if the end of the record has been reached.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_input_request
{              cye$illegal_operation
{
*DECK DECK=CYH$LENGTH_OF_FILE EXPAND=TRUE
{
{  The purpose of this request is to return the length of the specified FILE.
{        The length is the number of cells in the file.
{
{
{        CYP$LENGTH_OF_FILE (FILE)
{
{
{  FILE: (input) This parameter specifies the file whose length is to be
{        determined.
{
*DECK DECK=CYH$OPEN_BINARY_FILE EXPAND=TRUE
{
{  The purpose of this request is to open a file specified by FILE_NAME as a
{        binary file type.
{
{
{        CYP$OPEN_BINARY_FILE (FILE_NAME, FILE_ACCESS, FILE_ATTACHMENT,
{              DEFAULT_CREATION_ATTRIBUTE, MANDATED_CREATION_ATTRIBUTE,
{              ATTRIBUTE_VALIDATION, ATTRIBUTE_OVERRIDE, FILE, STATUS)
{
{
{  FILE_NAME: (input) This parameter specifies the file to be opened.
{
{  FILE_ACCESS: (input) This parameter specifies how the file is to be
{        accessed.
{
{  FILE_ATTACHMENT: (input) This parameter specifies the attachment options to
{        be in effect for this instance of open.
{
{  DEFAULT_CREATION_ATTRIBUTE: (input) This parameter specifies file attribute
{        values which are to be used in the absence of a CREATE_FILE command or
{        program request specification.
{
{  MANDATED_CREATION_ATTRIBUTE: (input) This parameter specifies file attribute
{        values which must be used to describe the file, if it is to be
{        initially opened by this request.
{
{  ATTRIBUTE_VALIDATION: (input) This parameter specifies the desired attribute
{        values of the file.
{
{  ATTRIBUTE_OVERRIDE: (input) This parameter specifies an attibute value to
{        be used only for this instance of open of the file or file cycle.
{
{  FILE: (output) This parameter returns a pointer that must be used on all
{        other calls to CYBILIO when referring to the file being opened here.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$illegal_open_request
{              cye$no_memory_to_open_file
{

*DECK DECK=CYH$OPEN_DISPLAY_FILE EXPAND=TRUE
{
{  The purpose of this request is to open a file specified by FILE_NAME as a
{        display file type.
{
{
{        CYP$OPEN_DISPLAY_FILE (FILE_NAME, FILE_ACCESS, FILE_ATTACHMENT,
{              DEFAULT_CREATION_ATTRIBUTE, MANDATED_CREATION_ATTRIBUTE,
{              ATTRIBUTE_VALIDATION, ATTRIBUTE_OVERRIDE, FILE, STATUS)
{
{
{  FILE_NAME: (input) This parameter specifies the file to be opened.
{
{  FILE_ACCESS: (input) This parameter specifies how the file is to be
{        accessed.
{
{  FILE_ATTACHMENT: (input) This parameter specifies the attachment options to
{        be in effect for this instance of open.
{
{  DEFAULT_CREATION_ATTRIBUTE: (input) This parameter specifies file attribute
{        values which are to be used in the absence of a CREATE_FILE command or
{        program request specification.
{
{  MANDATED_CREATION_ATTRIBUTE: (input) This parameter specifies file attribute
{        values which must be used to describe the file, if it is to be
{        initially opened by this request.
{
{  ATTRIBUTE_VALIDATION: (input) This parameter specifies the desired attribute
{        values of the file.
{
{  ATTRIBUTE_OVERRIDE: (input) This parameter specifies an attibute value to
{        be used only for this instance of open of the file or file cycle.
{
{  FILE: (output) This parameter returns a pointer that must be used on all
{        other calls to CYBILIO when referring to the file being opened here.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$illegal_open_request
{              cye$no_memory_to_open_file
{

*DECK DECK=CYH$OPEN_FILE EXPAND=TRUE
{
{  The purpose of this request is to open the file specified by the FILE_NAME
{        parameter.
{
{
{        CYP$OPEN_FILE (FILE_NAME, FILE_SPECIFICATIONS, FILE, STATUS)
{
{
{  FILE_NAME: (input) This parameter specifies the name of the file being
{        opened.  The length of the file_name and the characters included in
{        the file_name must conform to the operating system dependent
{        requirements.
{
{  FILE_SPECIFICATIONS: (input) This parameter specifies how the file is to be
{        used.
{
{  FILE: (output) This parameter returns a pointer that must be used on all
{        other calls to CYBILIO.  Unpredictable results will occur if an
{        attempt is made to call a CYBILIO procedure with an undefined or
{        user-altered pointer.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_already_exists
{              cye$file_not_found
{              cye$illegal_open_request
{              cye$no_memory_to_open_file
{
*DECK DECK=CYH$OPEN_RECORD_FILE EXPAND=TRUE
{
{  The purpose of this request is to open a file specified by FILE_NAME as a
{        record file type.
{
{
{        CYP$OPEN_RECORD_FILE (FILE_NAME, FILE_ACCESS, FILE_ATTACHMENT,
{              DEFAULT_CREATION_ATTRIBUTE, MANDATED_CREATION_ATTRIBUTE,
{              ATTRIBUTE_VALIDATION, ATTRIBUTE_OVERRIDE, FILE, STATUS)
{
{
{  FILE_NAME: (input) This parameter specifies the file to be opened.
{
{  FILE_ACCESS: (input) This parameter specifies how the file is to be
{        accessed.
{
{  FILE_ATTACHMENT: (input) This parameter specifies the attachment options to
{        be in effect for this instance of open.
{
{  DEFAULT_CREATION_ATTRIBUTE: (input) This parameter specifies file attribute
{        values which are to be used in the absence of a CREATE_FILE command or
{        program request specification.
{
{  MANDATED_CREATION_ATTRIBUTE: (input) This parameter specifies file attribute
{        values which must be used to describe the file, if it is to be
{        initially opened by this request.
{
{  ATTRIBUTE_VALIDATION: (input) This parameter specifies the desired attribute
{        values of the file.
{
{  ATTRIBUTE_OVERRIDE: (input) This parameter specifies an attibute value to
{        be used only for this instance of open of the file or file cycle.
{
{  FILE: (output) This parameter returns a pointer that must be used on all
{        other calls to CYBILIO when refering the the file being opened here.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$illegal_open_request
{              cye$no_memory_to_open_file
{

*DECK DECK=CYH$OPEN_TEXT_FILE EXPAND=TRUE
{
{  The purpose of this request is to open a file specified by FILE_NAME as a
{        text file type.
{
{
{        CYP$OPEN_TEXT_FILE (FILE_NAME, FILE_ACCESS, FILE_ATTACHMENT,
{              DEFAULT_CREATION_ATTRIBUTE, MANDATED_CREATION_ATTRIBUTE,
{              ATTRIBUTE_VALIDATION, ATTRIBUTE_OVERRIDE, FILE, STATUS)
{
{
{  FILE_NAME: (input) This parameter specifies the file to be opened.
{
{  FILE_ACCESS: (input) This parameter specifies how the file is to be
{        accessed.
{
{  FILE_ATTACHMENT: (input) This parameter specifies the attachment options to
{        be in effect for this instance of open.
{
{  DEFAULT_CREATION_ATTRIBUTE: (input) This parameter specifies file attribute
{        values which are to be used in the absence of a CREATE_FILE command or
{        program request specification.
{
{  MANDATED_CREATION_ATTRIBUTE: (input) This parameter specifies file attribute
{        values which must be used to describe the file, if it is to be
{        initially opened by this request.
{
{  ATTRIBUTE_VALIDATION: (input) This parameter specifies the desired attribute
{        values of the file.
{
{  ATTRIBUTE_OVERRIDE: (input) This parameter specifies an attibute value to
{        be used only for this instance of open of the file or file cycle.
{
{  FILE: (output) This parameter returns a pointer that must be used on all
{        other calls to CYBILIO when referring to the file being opened here.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$illegal_open_request
{              cye$no_memory_to_open_file
{

*DECK DECK=CYH$OPERATING_SYSTEM EXPAND=TRUE
{
{  The purpose of this request is to return a value that identifies the
{        OPERATING_SYSTEM on which a program is running.
{
{
{        CYP$OPERATING_SYSTEM()
{
*DECK DECK=CYH$PAGE_WIDTH EXPAND=TRUE
{
{  The purpose of this request is to return the page width associated with the
{        file.
{
{
{        CYP$PAGE_WIDTH (FILE)
{
{
{  FILE: (input) This parameter specifies the file whose page width is
{        to be returned.
{
*DECK DECK=CYH$POSITION_BINARY_AT_KEY EXPAND=TRUE
{
{  The purpose of this request is to position a binary type file to a
{        specified "file cell address".
{
{
{        CYP$POSITION_BINARY_AT_KEY (BINARY_FILE, FILE_KEY, STATUS)
{
{
{  BINARY_FILE: (input) This parameter names the binary file to be read.
{
{  FILE_KEY: (input) This parameter specifies the "file cell address" to which
{        the file is to be positioned.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_operation
{              cye$key_past_eoi
{
*DECK DECK=CYH$POSITION_DISPLAY_PAGE EXPAND=TRUE
{
{  The purpose of this request is to position a display file at a specified
{        line.
{
{
{        CYP$POSITION_DISPLAY_PAGE (DISPLAY_FILE, LINE_NUMBER, STATUS)
{
{
{  DISPLAY_FILE: (input) This parameter specifies the display file to be
{        positioned.
{
{  LINE_NUMBER: (input) This parameter specifies the display line at which the
{        file is to be positioned.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_operation
{              cye$illegal_output_request
{
*DECK DECK=CYH$POSITION_FILE_AT_BEGINNING EXPAND=TRUE
{
{  The purpose of this request is to position the specified FILE at its
{        beginning of information.
{
{
{        CYP$POSITION_FILE_AT_BEGINNING (FILE, STATUS)
{
{
{  FILE: (input) This parameter specifies the file to be positioned.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{
*DECK DECK=CYH$POSITION_FILE_AT_END EXPAND=TRUE
{
{  The purpose of this request is to position the specified FILE at the end of
{        information.
{
{
{        CYP$POSITION_FILE_AT_END (FILE, STATUS)
{
{
{  FILE: (input) This parameter specifies the file to be positioned.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_input_request
{
*DECK DECK=CYH$POSITION_RECORD_FILE EXPAND=TRUE
{
{  The purpose of this request is to reposition a record type file.
{
{
{        CYP$POSITION_RECORD_FILE (RECORD_FILE, DIRECTION, COUNT, UNIT,
{              STATUS)
{
{
{  RECORD_FILE: (input) This parameter specifies the file to be repositioned.
{
{  DIRECTION: (input) This parameter specifies forward or backward positioning.
{
{  COUNT: (input) This parameter specifies the number of units the file is to
{        be positioned.
{
{  UNIT: (input) This parameter specifies positioning by records, blocks, or
{        partitions.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_input_request
{              cye$illegal_operation
{              cye$illegal_skip_count
{              cye$premature_end_of_operation
{
*DECK DECK=CYH$PUT_KEYED_BINARY EXPAND=TRUE
{
{  The purpose of this request is to write data to a binary file type.
{
{
{        CYP$PUT_KEYED_BINARY (BINARY_FILE, POINTER_TO_SOURCE, FILE_KEY,
{              STATUS)
{
{  BINARY_FILE: (input) This parameter names the binary file to be written to.
{
{  POINTER_TO_SOURCE: (input) This parameter specifies the data to be written.
{
{  FILE_KEY: (input) Parameter specifying the "file cell address" at which the
{        write is to begin.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_operation
{              cye$illegal_output_request
{
*DECK DECK=CYH$PUT_NEXT_BINARY EXPAND=TRUE
{
{  The purpose of this request is to write data to a file opened as
{        cyc$binary_file.  The data is written to the current position of the
{        file.
{
{
{        CYP$PUT_NEXT_BINARY (BINARY_FILE, POINTER_TO_SOURCE, FILE_KEY,
{              STATUS)
{
{
{  BINARY_FILE: (input) This parameter names the binary file to be written to.
{
{  POINTER_TO_SOURCE: (input) This parameter specifies the data to be written.
{
{  FILE_KEY: (output) This parameter returns the "file cell address" at which
{        the write started.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_operation
{              cye$illegal_output_request
{
*DECK DECK=CYH$PUT_NEXT_LINE EXPAND=TRUE
{
{  The purpose of this request is to write a string of characters to the
{        specified file.
{
{
{        CYP$PUT_NEXT_LINE (FILE, LINE, STATUS)
{
{
{  FILE: (input) This parameter specifies the file to which the line is to
{        be written.
{
{  LINE: (input) This parameter specifies the string of characters to be
{        written.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_operation
{              cye$illegal_output_request
{
*DECK DECK=CYH$PUT_NEXT_RECORD EXPAND=TRUE
{
{  The purpose of this request is to write a record on the specified file.
{
{
{        CYP$PUT_NEXT_RECORD (RECORD_FILE, POINTER_TO_SOURCE, STATUS)
{
{
{  RECORD_FILE: (input) This parameter specifies the file to write to.
{
{  POINTER_TO_SOURCE: (input) This parameter specifies the data to be written.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_operation
{              cye$illegal_output_request
{
*DECK DECK=CYH$PUT_PARTIAL_LINE EXPAND=TRUE
{
{  The purpose of this request is to write a string of characters to the
{  specified FILE.
{
{
{        CYP$PUT_PARTIAL_LINE (FILE, PARTIAL_LINE, LAST_PART_OF_LINE,
{              STATUS)
{
{
{  FILE: (input) This parameter specifies the file to be written to.
{
{  PARTIAL_LINE: (input) This parameter specifies the string of characters to
{        be written.
{
{  LAST_PART_OF_LINE: (input) This parameter specifies whether or not more
{        characters can be written to the current line.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_operation
{              cye$illegal_output_request
{
*DECK DECK=CYH$PUT_PARTIAL_RECORD EXPAND=TRUE
{
{  The purpose of this request is to write a partial record to the specified
{        file.
{
{
{        CYP$PUT_PARTIAL_RECORD (RECORD_FILE, POINTER_TO_SOURCE,
{              LAST_PART_OF_RECORD, STATUS)
{
{
{  RECORD_FILE: (input) This parameter specifies the file to be written to.
{
{  POINTER_TO_SOURCE: (input) This parameter specifies the data to be written.
{
{  LAST_PART_OF_RECORD: (input) This parameter specifies whether or not more
{        data can be appended to the current record.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_output_request
{              cye$illegal_operation
{
*DECK DECK=CYH$SKIP_LINES EXPAND=TRUE
{
{  The purpose of this request is to write one or more blank lines to the
{        specified FILE.
{
{
{        CYP$SKIP_LINES (FILE, NUMBER_OF_LINES, STATUS)
{
{
{  FILE: (input) This parameter specifies the file to which the blank lines
{        are to be written.
{
{  NUMBER_OF_LINES: (input) This parameter specifies the number of blank lines
{        to be written.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_operation
{              cye$illegal_output_request
{
*DECK DECK=CYH$START_NEW_DISPLAY_PAGE EXPAND=TRUE
{
{  The purpose of this request is to invoke the CYBILIO page overflow
{        mechanism.
{
{
{        CYP$START_NEW_DISPLAY_PAGE (DISPLAY_FILE, STATUS)
{
{
{  DISPLAY_FILE: (input) This parameter specifies the file on which a
{        new display page is to be started.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_operation
{              cye$illegal_output_request
{
*DECK DECK=CYH$TAB_FILE EXPAND=TRUE
{
{  The purpose of this request is to position a FILE to a specified column or
{        position within a line.  This procedure performs a write to the file.
{
{
{        CYP$TAB_FILE (FILE, TAB_COLUMN, STATUS)
{
{
{  FILE: (input) This parameter specifies the file to be positioned.
{
{  TAB_COLUMN: (input) This parameter specifies the column to which the file
{        should be positioned.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_operation
{              cye$illegal_output_request
{
*DECK DECK=CYH$WRITE_END_OF_LINE EXPAND=TRUE
{
{  The purpose of this request is to write an end-of-line to the specified FILE.
{        If the last write to the file was partial, that line is completed;
{        otherwise an empty line results.
{
{
{        CYP$WRITE_END_OF_LINE (FILE, STATUS)
{
{
{  FILE: (input) This parameter specifies the file that the end-of-line is
{        written to.
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=CYH$WRITE_END_OF_PARTITION EXPAND=TRUE
{
{  The purpose of this request is to write an end of partition on the
{        specified file.
{
{
{        CYP$WRITE_END_OF_PARTITION (FILE, STATUS)
{
{
{  FILE: (input) This parameter specifies the file to write the end of
{        partition on.
{
{  STATUS: (output) This parameter specified the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_output_request
{
*DECK DECK=CYH$WRITE_END_OF_RECORD EXPAND=TRUE
{
{  The purpose of this request is to write an end of record on the specified
{        record file.
{
{
{        CYP$WRITE_END_OF_RECORD (RECORD_FILE, STATUS)
{
{
{  RECORD_FILE: (input) This parameter specifies the file to which the
{        end of record is to be written.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              cye$file_not_open
{              cye$illegal_operation
{              cye$illegal_output_request
{
*DECK DECK=CYM$ERROR_PROCESSOR EXPAND=TRUE
?? SET (LISTCTS := OFF) ??
?? RIGHT := 110, LEFT := 1 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
?? NEWTITLE := 'NOS/VE: CYBIL Error Procedures' ??
?? NEWTITLE := '  Global System Declarations' ??
MODULE cym$error_processor;
{   PURPOSE:
{     The purpose of this module is to provide the CYBIL error procedures
{     in a manner compatible with NOS/VE.
{
{   DESIGN:
{     The procedures contained in this module are designed to execute in the
{     ring of their caller - execution bracket of 1, 13.
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc OST$STACK_FRAME_SAVE_AREA
?? POP ??
*copyc oss$job_paged_literal
*copyc CYD$RUN_TIME_ERROR_CONDITION
?? TITLE := '  External Procedures' ??
?? EJECT ??
*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc OSP$APPEND_STATUS_INTEGER
*copyc OSP$SYSTEM_ERROR
*copyc PMP$CAUSE_CONDITION

*copyc PMP$ABORT
?? TITLE := '  append_address_to_message' ??
?? EJECT ??

  PROCEDURE append_address_to_message (address: ost$pva;
    VAR message {input, output} : ost$status);

    osp$append_status_integer (osc$status_parameter_delimiter, address.ring, 16, FALSE, message);
    osp$append_status_integer (' ', address.seg, 16, FALSE, message);
    osp$append_status_integer (' ', address.offset, 16, FALSE, message);
  PROCEND append_address_to_message;
?? TITLE := '  [XDCL, #GATE] cyp$nil' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] cyp$nil;

{     The purpose of this procedure is to process calls to a NIL
{     pointer to procedure.

    VAR
      nil_caller: ^ost$stack_frame_save_area,
      executing_ring: ost$ring,
      ignore_status: ost$status,
      status: ost$status;

    nil_caller := #previous_save_area ();
    osp$set_status_abnormal ('CY', cye$nil_called, '', status);
    append_address_to_message (nil_caller^.minimum_save_area.p_register.pva, status);
    pmp$cause_condition (cye$run_time_condition, ^status, ignore_status);

    CASE #ring (^executing_ring) OF
    = osc$tmtr_ring =
      osp$system_error ('R2 cyp$nil called', ^status);
    = osc$tsrv_ring .. osc$user_ring_4 =
      pmp$abort (status);
    CASEND;
  PROCEND cyp$nil;
?? TITLE := '  [XDCL, #GATE] cyp$error' ??
  ?? EJECT ??

  VAR
    err_message: [STATIC, oss$job_paged_literal, READ] array [0 .. 25] of string (24) := [
{} 'unequal string length   ',
{} 'adaptable length error  ',
{} 'subscript error         ',
{} 'range error             ',
{} 'undefined case          ',
{} 'reset_to error          ',
{} 'stack size error        ',
{} 'tag fixer error         ',
{} 'span fixer error        ',
{} 'length fixer error      ',
{} 'subrange fixer error    ',
{} 'division by zero        ',
{} 'mantissa error          ',
{} 'exponent error          ',
{} 'substring start error   ',
{} 'substring length error  ',
{} 'translate length error  ',
{} 'translate table overflow',
{} 'negative allocation     ',
{} 'wrong size expr for REP ',
{} 'nil pointer             ',
{} 'unselected CASE         ',
{} 'free of unalloc. block  ',
{} 'lower merge error       ',
{} 'upper merge error       ',
{} '                        '];

  TYPE
    mod_name = string (31);

  PROCEDURE [XDCL, #GATE] cyp$error (error_number: integer;
        line_number: integer;
        module_name_ptr: ^mod_name);

{   The purpose of this procedure is to process CYBIL runtime detected errors.
{
{       CYP$ERROR (ERROR, LINE_NUMBER, MODULE_NAME)
{
{ ERROR: (input) This parameter indicates the detected error.
{
{ LINE_NUMBER: (input) This parameter the line number within the module which
{       caused the runtime error.
{ MODULE_NAME: (input) This parameter specifies the module name.
{

    VAR
      executing_ring: ost$ring,
      ignore_status: ost$status,
      status: ost$status;


    osp$set_status_abnormal ('CY', cye$cybil_abort, err_message [error_number], status);
    osp$append_status_integer (osc$status_parameter_delimiter, line_number, 10, FALSE, status);
    osp$append_status_parameter (osc$status_parameter_delimiter, module_name_ptr^, status);
    pmp$cause_condition (cye$run_time_condition, ^status, ignore_status);

    CASE #ring (^executing_ring) OF
    = osc$tmtr_ring =
      osp$system_error ('R2 cyp$error called', ^status);
    = osc$tsrv_ring .. osc$user_ring_4 =
      pmp$abort (status);
    CASEND;
  PROCEND cyp$error;
MODEND cym$error_processor;
*DECK DECK=CYM$MESSAGE_TEMPLATE_MODULE EXPAND=TRUE
MODULE cym$message_template_module;
*copyc cye$error_codes_cybil
MODEND cfm$message_template_module;
*DECK DECK=CYP$BINARY_FILE_KEY EXPAND=FALSE

{* ZCYPBFK  cyp$binary_file_key *}

  FUNCTION [XREF] cyp$binary_file_key ALIAS 'ZCYPBFK'
    (binary_file: cyt$file): integer;

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
?? POP ??
*DECK DECK=CYP$CLOSE_FILE EXPAND=FALSE

{* ZCYPCF  cyp$close_file *}

  PROCEDURE [XREF] cyp$close_file ALIAS 'ZCYPCF' (file: cyt$file;
        file_position: cyt$open_close_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cyt$file
*copyc cyt$open_close_position
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$CURRENT_COLUMN EXPAND=FALSE

{* ZCYPCC  cyp$current_column *}

  FUNCTION [XREF] cyp$current_column ALIAS 'ZCYPCC'
    (file: cyt$file): cyt$page_width;

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc cyt$page_width
?? POP ??

*DECK DECK=CYP$CURRENT_DISPLAY_LINE EXPAND=FALSE

{* ZCYPCDL  cyp$current_display_line *}

  FUNCTION [XREF] cyp$current_display_line ALIAS 'ZCYPCDL'
    (display_file: cyt$file): cyt$page_length;

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc cyt$page_length
?? POP ??

*DECK DECK=CYP$CURRENT_FILE_POSITION EXPAND=FALSE

{* ZCYPCFP  cyp$current_file_position *}

  FUNCTION [XREF] cyp$current_file_position ALIAS 'ZCYPCFP'
    (file: cyt$file): cyt$current_file_position;

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc cyt$current_file_position
?? POP ??
*DECK DECK=CYP$CURRENT_PAGE_NUMBER EXPAND=FALSE

{* ZCYPCPN  cyp$current_page_number *}

  FUNCTION [XREF] cyp$current_page_number ALIAS 'ZCYPCPN'
    (display_file: cyt$file): integer;

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
?? POP ??

*DECK DECK=CYP$DISPLAY_PAGE_EJECT EXPAND=FALSE

{* ZCYPDPE  cyp$display_page_eject *}

  PROCEDURE [XREF] cyp$display_page_eject ALIAS 'ZCYPDPE'
   (    display_file: cyt$file;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$DISPLAY_PAGE_LENGTH EXPAND=FALSE

{* ZCYPDPL  cyp$display_page_length *}

  FUNCTION [XREF] cyp$display_page_length ALIAS 'ZCYPDPL'
    (display_file: cyt$file): cyt$page_length;

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc cyt$page_length
?? POP ??

*DECK DECK=CYP$DISPLAY_STANDARD_TITLE EXPAND=FALSE

{* ZCYPDST  cyp$display_standard_title *}

  PROCEDURE [XREF] cyp$display_standard_title ALIAS 'ZCYPDST'
       (file: cyt$file;
        title: string (* <= cyc$title_size);
        lines_after_title: cyt$page_length;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cyt$new_page_procedure
*copyc cyt$page_length
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$FILE_CONNECTED_TO_TERMINAL EXPAND=FALSE

{* ZCYPFCT  cyp$file_connected_to_terminal *}

  FUNCTION [XREF] cyp$file_connected_to_terminal ALIAS 'ZCYPFCT'
    (file: cyt$file): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
?? POP ??
*DECK DECK=CYP$FLUSH_LINE EXPAND=FALSE

{* ZCYPFL  cyp$flush_line *}

  PROCEDURE [XREF] cyp$flush_line ALIAS 'ZCYPFL'
   (    file: cyt$file;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$GET_BINARY_FILE_POINTER EXPAND=FALSE

{* cyp$get_binary_file_pointer *}

  PROCEDURE [XREF] cyp$get_binary_file_pointer (file: cyt$file;
    VAR binary_file_pointer: ^amt$segment_pointer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc amt$segment_pointer
*copyc ost$status
?? POP ??
*DECK DECK=CYP$GET_FILE_IDENTIFIER EXPAND=FALSE

{* cyp$get_file_identifier *}

  PROCEDURE [XREF] cyp$get_file_identifier (file: cyt$file;
    VAR file_identifier: amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc cyt$file_control_block
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??

*DECK DECK=CYP$GET_KEYED_BINARY EXPAND=FALSE

{* ZCYPGKB  cyp$get_keyed_binary *}

  PROCEDURE [XREF] cyp$get_keyed_binary ALIAS 'ZCYPGKB'
   (    binary_file: cyt$file;
        pointer_to_target: ^SEQ ( * );
        file_key: integer;
    VAR number_of_cells_read: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$GET_NEXT_BINARY EXPAND=FALSE

{* ZCYPGNB  cyp$get_next_binary *}

  PROCEDURE [XREF] cyp$get_next_binary ALIAS 'ZCYPGNB'
   (    binary_file: cyt$file;
        pointer_to_target: ^SEQ ( * );
    VAR file_key: integer;
    VAR number_of_cells_read: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$GET_NEXT_LINE EXPAND=FALSE

{* ZCYPGNL  cyp$get_next_line *}

  PROCEDURE [XREF] cyp$get_next_line ALIAS 'ZCYPGNL'
   (    file: cyt$file;
    VAR line: string ( * <= cyc$max_page_width);
    VAR number_of_characters_read: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cyt$page_width
*copyc cye$exception_conditions
?? POP ??

*DECK DECK=CYP$GET_NEXT_RECORD EXPAND=FALSE

{* ZCYPGNR  cyp$get_next_record *}

  PROCEDURE [XREF] cyp$get_next_record ALIAS 'ZCYPGNR'
   (    record_file: cyt$file;
        pointer_to_target: ^SEQ ( * );
    VAR number_of_cells_read: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$GET_PARTIAL_LINE EXPAND=FALSE

{* ZCYPGPL  cyp$get_partial_line *}

  PROCEDURE [XREF] cyp$get_partial_line ALIAS 'ZCYPGPL'
   (    file: cyt$file;
    VAR partial_line: string ( * <= cyc$max_page_width);
    VAR number_of_characters_read: integer;
    VAR last_part_of_line: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cyt$page_width
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$GET_PARTIAL_RECORD EXPAND=FALSE

{* ZCYPGPR  cyp$get_partial_record *}

  PROCEDURE [XREF] cyp$get_partial_record ALIAS 'ZCYPGPR'
   (    record_file: cyt$file;
        pointer_to_target: ^SEQ ( * );
    VAR number_of_cells_read: integer;
    VAR last_part_of_record: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$LENGTH_OF_FILE EXPAND=FALSE

{* ZCYPLOF  cyp$length_of_file *}

  FUNCTION [XREF] cyp$length_of_file ALIAS 'ZCYPLOF'
    (file: cyt$file): integer;

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
?? POP ??

*DECK DECK=CYP$OPEN_BINARY_FILE EXPAND=TRUE

{* cyp$open_binary_file *}

  PROCEDURE [XREF] cyp$open_binary_file (file_name: cyt$file_name;
        file_access: cyt$file_access;
        file_attachment: ^fst$attachment_options;
        default_creation_attribute: ^fst$file_cycle_attributes;
        mandated_creation_attribute: ^fst$file_cycle_attributes;
        attribute_validation: ^fst$file_cycle_attributes;
        attribute_override: ^fst$file_cycle_attributes;
    VAR file_control: cyt$file;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cyt$file_name
*copyc cyt$file_access
*copyc cyt$file
*copyc cye$exception_conditions
*copyc fst$attachment_options
*copyc fst$file_cycle_attributes
?? POP ??
*DECK DECK=CYP$OPEN_DISPLAY_FILE EXPAND=TRUE

{* cyp$open_display_file *}

  PROCEDURE [XREF] cyp$open_display_file (file_name: cyt$file_name;
        file_access: cyt$file_access;
        file_attachment: ^fst$attachment_options;
        default_creation_attribute: ^fst$file_cycle_attributes;
        mandated_creation_attribute: ^fst$file_cycle_attributes;
        attribute_validation: ^fst$file_cycle_attributes;
        attribute_override: ^fst$file_cycle_attributes;
    VAR file_control: cyt$file;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cyt$file_name
*copyc cyt$file_access
*copyc cyt$file
*copyc cye$exception_conditions
*copyc fst$attachment_options
*copyc fst$file_cycle_attributes
?? POP ??
*DECK DECK=CYP$OPEN_FILE EXPAND=FALSE

{* ZCYPOF  cyp$open_file *}

  PROCEDURE [XREF] cyp$open_file ALIAS 'ZCYPOF'
   (    file_name: cyt$file_name;
        file_specifications: cyt$file_specifications;
    VAR file: cyt$file;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cyt$file_name
*copyc cyt$file_specifications
*copyc cyt$file
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$OPEN_RECORD_FILE EXPAND=TRUE

{* cyp$open_record_file *}

  PROCEDURE [XREF] cyp$open_record_file (file_name: cyt$file_name;
        file_access: cyt$file_access;
        file_attachment: ^fst$attachment_options;
        default_creation_attribute: ^fst$file_cycle_attributes;
        mandated_creation_attribute: ^fst$file_cycle_attributes;
        attribute_validation: ^fst$file_cycle_attributes;
        attribute_override: ^fst$file_cycle_attributes;
    VAR file_control: cyt$file;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cyt$file_name
*copyc cyt$file_access
*copyc cyt$file
*copyc cye$exception_conditions
*copyc fst$attachment_options
*copyc fst$file_cycle_attributes
?? POP ??
*DECK DECK=CYP$OPEN_TEXT_FILE EXPAND=TRUE

{* cyp$open_text_file *}

  PROCEDURE [XREF] cyp$open_text_file (file_name: cyt$file_name;
        file_access: cyt$file_access;
        file_attachment: ^fst$attachment_options;
        default_creation_attribute: ^fst$file_cycle_attributes;
        mandated_creation_attribute: ^fst$file_cycle_attributes;
        attribute_validation: ^fst$file_cycle_attributes;
        attribute_override: ^fst$file_cycle_attributes;
    VAR file_control: cyt$file;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cyt$file_name
*copyc cyt$file_access
*copyc cyt$file
*copyc cye$exception_conditions
*copyc fst$attachment_options
*copyc fst$file_cycle_attributes
?? POP ??
*DECK DECK=CYP$OPERATING_SYSTEM EXPAND=FALSE

{* ZCYPOS  cyp$operating_system *}

  FUNCTION [XREF] cyp$operating_system ALIAS 'ZCYPOS': cyt$system_type;

?? PUSH (LISTEXT := ON) ??
*copyc cyt$system_type
?? POP ??
*DECK DECK=CYP$PAGE_WIDTH EXPAND=FALSE

{* ZCYPPW  cyp$page_width *}

  FUNCTION [XREF] cyp$page_width ALIAS 'ZCYPPW'
    (file: cyt$file): cyt$page_width;

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc cyt$page_width
?? POP ??

*DECK DECK=CYP$POSITION_BINARY_AT_KEY EXPAND=FALSE

{* ZCYPPBK  cyp$position_binary_at_key *}

  PROCEDURE [XREF] cyp$position_binary_at_key ALIAS 'ZCYPPBK'
   (    binary_file: cyt$file;
        file_key: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$POSITION_DISPLAY_PAGE EXPAND=FALSE

{* ZCYPPDP  cyp$position_display_page *}

  PROCEDURE [XREF] cyp$position_display_page ALIAS 'ZCYPPDP'
   (    display_file: cyt$file;
        line_number: cyt$page_length;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc cyt$page_length
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$POSITION_FILE_AT_BEGINNING EXPAND=FALSE

{* ZCYPPFB  cyp$position_file_at_beginning *}

  PROCEDURE [XREF] cyp$position_file_at_beginning ALIAS 'ZCYPPFB'
   (    file: cyt$file;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cyt$file
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$POSITION_FILE_AT_END EXPAND=FALSE

{* ZCYPPFE  cyp$position_file_at_end *}

  PROCEDURE [XREF] cyp$position_file_at_end ALIAS 'ZCYPPFE'
   (    file: cyt$file;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc cyt$file
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$POSITION_RECORD_FILE EXPAND=FALSE

{* ZCYPPRF  cyp$position_record_file *}

  PROCEDURE [XREF] cyp$position_record_file ALIAS 'ZCYPPRF'
    (    record_file: cyt$file;
         direction: cyt$skip_direction;
         count: integer;
         unit: cyt$skip_unit;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cyt$skip_direction
*copyc cyt$skip_unit
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$PUT_KEYED_BINARY EXPAND=FALSE

{* ZCYPPKB  cyp$put_keyed_binary *}

  PROCEDURE [XREF] cyp$put_keyed_binary ALIAS 'ZCYPPKB'
    (   binary_file: cyt$file;
        pointer_to_source: ^SEQ ( * );
        file_key: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$PUT_NEXT_BINARY EXPAND=FALSE

{* ZCYPPNB  cyp$put_next_binary *}

  PROCEDURE [XREF] cyp$put_next_binary ALIAS 'ZCYPPNB'
   (    binary_file: cyt$file;
        pointer_to_source: ^SEQ ( * );
    VAR file_key: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$PUT_NEXT_LINE EXPAND=FALSE

{* ZCYPPNL  cyp$put_next_line *}

  PROCEDURE [XREF] cyp$put_next_line ALIAS 'ZCYPPNL'
   (    file: cyt$file;
        line: string ( * <= cyc$max_page_width);
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cyt$page_width
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$PUT_NEXT_RECORD EXPAND=FALSE

{* ZCYPPNR  cyp$put_next_record *}

  PROCEDURE [XREF] cyp$put_next_record ALIAS 'ZCYPPNR'
   (    record_file: cyt$file;
        pointer_to_source: ^SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$PUT_PARTIAL_LINE EXPAND=FALSE

{* ZCYPPPL  cyp$put_partial_line *}

  PROCEDURE [XREF] cyp$put_partial_line ALIAS 'ZCYPPPL'
   (    file: cyt$file;
        partial_line: string ( * <= cyc$max_page_width);
        last_part_of_line: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cyt$page_width
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$PUT_PARTIAL_RECORD EXPAND=FALSE

{* ZCYPPPR  cyp$put_partial_record *}

  PROCEDURE [XREF] cyp$put_partial_record ALIAS 'ZCYPPPR'
   (    record_file: cyt$file;
        pointer_to_source: ^SEQ ( * );
        last_part_of_record: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$SKIP_LINES EXPAND=FALSE

{* ZCYPSL  cyp$skip_lines *}

  PROCEDURE [XREF] cyp$skip_lines ALIAS 'ZCYPSL'
   (    file: cyt$file;
        number_of_lines: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$START_NEW_DISPLAY_PAGE EXPAND=FALSE

{* ZCYPSNP  cyp$start_new_display_page *}

  PROCEDURE [XREF] cyp$start_new_display_page ALIAS 'ZCYPSNP'
   (    display_file: cyt$file;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$TAB_FILE EXPAND=FALSE

{* ZCYPTF  cyp$tab_file *}

  PROCEDURE [XREF] cyp$tab_file ALIAS 'ZCYPTF'
   (    file: cyt$file;
        tab_column: cyt$page_width;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cyt$page_width
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$WRITE_END_OF_LINE EXPAND=FALSE

{* ZCYPWEL  cyp$write_end_of_line *}

  PROCEDURE [XREF] cyp$write_end_of_line ALIAS 'ZCYPWEL'
   (    file: cyt$file;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$WRITE_END_OF_PARTITION EXPAND=FALSE

{* ZCYPWEP  cyp$write_end_of_partition *}

  PROCEDURE [XREF] cyp$write_end_of_partition ALIAS 'ZCYPWEP'
   (    file: cyt$file;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYP$WRITE_END_OF_RECORD EXPAND=FALSE

{* ZCYPWER  cyp$write_end_of_record *}

  PROCEDURE [XREF] cyp$write_end_of_record ALIAS 'ZCYPWER'
   (    record_file: cyt$file;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyt$file
*copyc ost$status
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYT$CLOSE_FILE_DISPOSITION EXPAND=FALSE

{* ZCYTCFD cyt$close_file_disposition *}

  TYPE
    cyt$close_file_disposition = (cyc$delete_file, cyc$retain_file,
      cyc$return_file, cyc$unload_file, cyc$default_file_disposition);

  CONST
    cyc$detach_file = cyc$return_file;
*DECK DECK=CYT$CURRENT_FILE_POSITION EXPAND=FALSE

{* ZCYTCFP  cyt$current_file_position *}

  TYPE
    cyt$current_file_position = (cyc$beginning_of_information,
      cyc$middle_of_record, cyc$end_of_record, cyc$end_of_block,
      cyc$end_of_partition, cyc$end_of_information);
*DECK DECK=CYT$CYBIL_INPUT_OUTPUT EXPAND=FALSE

{* ZCYTCIO  cyt$cybil_input_output *}

?? PUSH (LIST := OFF) ??
*copyc cyt$file
*copyc cyt$file_name
*copyc cyt$file_specifications
*copyc cyt$system_type
*copyc cye$exception_conditions
?? POP ??
*DECK DECK=CYT$FILE EXPAND=FALSE

{* ZCYTFIL  cyt$file *}

  TYPE
    cyt$file = ^SEQ ( * );
*DECK DECK=CYT$FILE_ACCESS EXPAND=FALSE

{* ZCYTFA  cyt$file_access *}

  TYPE
    cyt$file_access = (cyc$read, cyc$write, cyc$read_write);
*DECK DECK=CYT$FILE_CHARACTER_SET EXPAND=FALSE

{* ZCYTFCS  cyt$file_character_set *}

  TYPE
    cyt$file_character_set = (cyc$ascii, cyc$ascii612, cyc$ascii812,
          cyc$display_64, cyc$reserved_code1, cyc$reserved_code2);
*DECK DECK=CYT$FILE_CONTENTS EXPAND=FALSE

{* ZCYTFC cyt$file_contents *}

{}
{ The following are predefined string constants for file_contents:}
{}
?? FMT (FORMAT := OFF) ??
  CONST
    cyc$ascii_log                   = 'ASCII_LOG                      ',
    cyc$binary                      = 'BINARY                         ',
    cyc$binary_log                  = 'BINARY_LOG                     ',
    cyc$data                        = 'DATA                           ',
    cyc$file_backup                 = 'FILE_BACKUP                    ',
    cyc$legible                     = 'LEGIBLE                        ',
    cyc$legible_data                = 'LEGIBLE_DATA                   ',
    cyc$legible_library             = 'LEGIBLE_LIBRARY                ',
    cyc$legible_unknown             = 'LEGIBLE_UNKNOWN                ',
    cyc$list                        = 'LIST                           ',
    cyc$list_unknown                = 'LIST_UNKNOWN                   ',
    cyc$object                      = 'OBJECT                         ',
    cyc$object_data                 = 'OBJECT_DATA                    ',
    cyc$object_library              = 'OBJECT_LIBRARY                 ',
    cyc$screen                      = 'SCREEN                         ',
    cyc$screen_form                 = 'SCREEN_FORM                    ',
    cyc$unknown_contents            = 'UNKNOWN                        ';
?? FMT (FORMAT := ON) ??

  TYPE
    cyt$file_contents = string (31);
*DECK DECK=CYT$FILE_CONTROL_BLOCK EXPAND=FALSE

{* ZCYTFCB cyt$file_control_block *}

  TYPE
    halfword = - 80000000(16) .. 7fffffff(16),
    ring = 0 .. 15,
    segment = 0 .. 4095,
    ptr_control_kind = (official, unofficial),

    seg_ptr_template = packed record
      casebyte: char,
      ring_num: ring,
      segment_number: segment,
      sequence_base: halfword,
      sequence_limit: halfword,
      sequence_avail: halfword,
    recend,


    cyt$segment_info= record
      case kind: ptr_control_kind of
      = official =
        object: amt$segment_pointer,
      = unofficial =
        template: seg_ptr_template,
      casend,
    recend;

  TYPE
    cyt$cybilio_string = record
      size: 0 .. cyc$max_page_width,
      value: string (cyc$max_page_width),
    recend;

  TYPE
    cyt$file_control_block = record
      file_name: string (31),
{     file_name: string (cyc$max_file_name_size),
      file_id: amt$file_identifier,
      last_access_partial: boolean,
      file_kind: cyt$file_kind,
      file_access: cyt$file_access,
      close_disposition: cyt$close_file_disposition,
      data_in_line: boolean,
      new_line_started: boolean,
      line: cyt$cybilio_string,
      column_number: cyt$page_width,
      line_number: 0 .. cyc$page_limit,
      page_number: 0 .. cyc$page_limit,
      include_format_effectors: boolean,
      new_page_procedure: cyt$new_page_procedure,
      new_page_proc_called: boolean,
      page_format: cyt$page_format,
      page_length: 1 .. cyc$page_limit,
      page_width: 1 .. cyc$max_page_width,
      file_position: cyt$current_file_position,
      current_file_length: amt$file_byte_address,
      device_class: rmt$device_class,
      segment_info: cyt$segment_info,
      max_extent: halfword,
    recend;

?? PUSH (LIST := OFF) ??
*copyc cyt$current_file_position
*copyc cyt$file_name
*copyc cyt$close_file_disposition
*copyc cyt$file_access
*copyc cyt$file_kind
*copyc cyt$new_page_procedure
*copyc cyt$page_format
*copyc cyt$page_length
*copyc cyt$page_width
*copyc amt$file_identifier
*copyc amt$segment_pointer
*copyc amt$file_byte_address
*copyc rmt$device_class
?? POP ??
*DECK DECK=CYT$FILE_EXISTENCE EXPAND=FALSE

{* ZCYTFE  cyt$file_existence *}

  TYPE
    cyt$file_existence = (cyc$new_file, cyc$old_file, cyc$new_or_old_file);
*DECK DECK=CYT$FILE_KIND EXPAND=FALSE

{* ZCYTFK  cyt$file_kind *}

  TYPE
    cyt$file_kind = (cyc$binary_file, cyc$display_file, cyc$record_file,
          cyc$text_file);
*DECK DECK=CYT$FILE_NAME EXPAND=FALSE

{* ZCYTFN  cyt$file_name *}

  TYPE
    cyt$file_name = string ( * <= cyc$max_file_name_size);

  CONST
    cyc$max_file_name_size = 512;
*DECK DECK=CYT$FILE_PROCESSOR EXPAND=FALSE

{* ZCYTFP cyt$file_processor *}

{ The following are predefined strings for referring to file processor.}

?? FMT (FORMAT := OFF) ??
  CONST
    cyc$ada                         = 'ADA                            ',
    cyc$apl                         = 'APL                            ',
    cyc$assembler                   = 'ASSEMBLER                      ',
    cyc$basic                       = 'BASIC                          ',
    cyc$c                           = 'C                              ',
    cyc$cobol                       = 'COBOL                          ',
    cyc$cybil                       = 'CYBIL                          ',
    cyc$debugger                    = 'DEBUGGER                       ',
    cyc$fortran                     = 'FORTRAN                        ',
    cyc$lisp                        = 'LISP                           ',
    cyc$pascal                      = 'PASCAL                         ',
    cyc$pli                         = 'PLI                            ',
    cyc$ppu_assembler               = 'PPU_ASSEMBLER                  ',
    cyc$prolog                      = 'PROLOG                         ',
    cyc$scl                         = 'SCL                            ',
    cyc$scu                         = 'SCU                            ',
    cyc$unknown_processor           = 'UNKNOWN                        ',
    cyc$vx                          = 'VX                             ';
?? FMT (FORMAT := ON) ??

  TYPE
    cyt$file_processor = string (31);
*DECK DECK=CYT$FILE_SPECIFICATIONS EXPAND=FALSE

{* ZCYTFS  cyt$file_specifications *}

  TYPE
    cyt$file_specifications = ^array [1 .. * ] of cyt$file_specification,

    cyt$file_specification_selector = (cyc$file_kind, cyc$file_access,
      cyc$file_existence, cyc$open_position, cyc$close_file_disposition,
      cyc$file_contents, cyc$file_processor, cyc$file_character_set,
      cyc$new_page_procedure, cyc$page_length, cyc$page_width,
      cyc$page_format, cyc$future_spec1, cyc$future_spec2, cyc$future_spec3,
      cyc$future_spec4, cyc$future_spec5),


    cyt$file_specification = record
      case selector: cyt$file_specification_selector of
      = cyc$file_kind =
        file_kind: cyt$file_kind,
      = cyc$file_access =
        file_access: cyt$file_access,
      = cyc$file_existence =
        file_existence: cyt$file_existence,
      = cyc$open_position =
        open_position: cyt$open_close_position,
      = cyc$close_file_disposition =
        close_disposition: cyt$close_file_disposition,
      = cyc$file_contents =
        file_contents: cyt$file_contents,
      = cyc$file_processor =
        file_processor: cyt$file_processor,
      = cyc$file_character_set =
        file_character_set: cyt$file_character_set,
      = cyc$new_page_procedure =
        new_page_procedure: cyt$new_page_procedure,
      = cyc$page_length =
        page_length: cyt$page_length,
      = cyc$page_width =
        page_width: cyt$page_width,
      = cyc$page_format =
        page_format: cyt$page_format,
      = cyc$future_spec1 =
        ,
      = cyc$future_spec2 =
        ,
      = cyc$future_spec3 =
        ,
      = cyc$future_spec4 =
        ,
      = cyc$future_spec5 =
        ,
      casend,
    recend;


*copyc cyt$close_file_disposition
*copyc cyt$file_access
*copyc cyt$file_character_set
*copyc cyt$file_existence
*copyc cyt$file_kind
*copyc cyt$file_contents
*copyc cyt$file_processor
*copyc cyt$new_page_procedure
*copyc cyt$open_close_position
*copyc cyt$page_length
*copyc cyt$page_width
*copyc cyt$page_format
*DECK DECK=CYT$NEW_PAGE_PROCEDURE EXPAND=FALSE

{* ZCYTNPP  cyt$new_page_procedure *}

  TYPE
    cyt$new_page_procedure = record
      case kind: cyt$page_procedure_kind of
      = cyc$user_specified_procedure =
        user_procedure: cyt$user_page_procedure,
      = cyc$standard_procedure =
        title: string (cyc$title_size),
      = cyc$omit_page_procedure =
        ,
      casend,
    recend,

    cyt$page_procedure_kind = (cyc$user_specified_procedure,
      cyc$standard_procedure, cyc$omit_page_procedure),

    cyt$user_page_procedure = ^procedure (display_file: cyt$file;
      next_page_number: integer;
      VAR status: ost$status);

  CONST
    cyc$title_size = 45;

*copyc ost$status
*copyc cyt$file
*DECK DECK=CYT$OPEN_CLOSE_POSITION EXPAND=FALSE

{* ZCYTOCP  cyt$open_close_position *}

  TYPE
    cyt$open_close_position = (cyc$beginning, cyc$end, cyc$asis,
          cyc$default_open_position);

*DECK DECK=CYT$PAGE_FORMAT EXPAND=FALSE

{* ZCYTPF  cyt$page_format *}

  TYPE
    cyt$page_format = (cyc$continuous_form, cyc$burstable_form,
          cyc$non_burstable_form, cyc$untitled_form);
*DECK DECK=CYT$PAGE_LENGTH EXPAND=FALSE

{* ZCYTPL  cyt$page_length *}

  TYPE
    cyt$page_length = 1 .. cyc$page_limit;

  CONST
    cyc$page_limit = 439804651103;
*DECK DECK=CYT$PAGE_WIDTH EXPAND=FALSE

{* ZCYTPW  cyt$page_width *}

  TYPE
    cyt$page_width = 1 .. cyc$max_page_width;

  CONST
   cyc$wide_page_width = 132,
   cyc$narrow_page_width = 80,
   cyc$max_page_width = 65535;

*DECK DECK=CYT$SKIP_DIRECTION EXPAND=FALSE

{* ZCYTSD  cyt$skip_direction *}

  TYPE
    cyt$skip_direction = (cyc$forward, cyc$backward);
*DECK DECK=CYT$SKIP_UNIT EXPAND=FALSE

{* ZCYTSU  cyt$skip_unit *}

  TYPE
    cyt$skip_unit = (cyc$record, cyc$block, cyc$partition);
*DECK DECK=CYT$STRING_INDEX EXPAND=FALSE

  TYPE
    cyt$string_index = 1 .. cyc$max_string_size + 1;

*copyc cyc$max_string_size
*DECK DECK=CYT$STRING_SIZE EXPAND=FALSE

  TYPE
    cyt$string_size = 0 .. cyc$max_string_size;

*copyc cyc$max_string_size
*DECK DECK=CYT$SYSTEM_TYPE EXPAND=FALSE

{* ZCYTST  cyt$system_type *}

  TYPE
    cyt$system_type = (cyc$nosve, cyc$nos, cyc$nosbe, cyc$vsos, cyc$eos,
          cyc$aegis);
*DECK DECK=DBH$BEGIN_DEBUG EXPAND=FALSE

{
{   The purpose of this request is to give a debugger control prior to
{ the call to the user's starting procedure.
{   This procedure will not have been called if task debug mode is set
{ "on" after the call to the user's starting procedure or if task
{ debug mode is "off" and the PMP$ABORT request is issued.
{
{       DBP$BEGIN_DEBUG (STARTING_PROCEDURE)
{
{ STARTING_PROCEDURE: (input) This parameter specifies the address of the
{       program's starting procedure.
{
*DECK DECK=DBH$DEBUG EXPAND=FALSE
{
{
{    The purpose of this request is to give a debugger control when a condition
{ arises.
{
{       DBP$DEBUG (CONDITION, CONDITION_DESCRIPTOR, CONDITION_SAVE_AREA,
{             TRAPPED_SAVE_AREA, DEBUG_ID, MULTIPLE_CONDITIONS, STATUS)
{
{ CONDITION: (input)  This parameter specifies the condition which caused the
{       debugger to be called.
{
{ CONDITION_DESCRIPTOR: (input)  This parameter specifies the condition
{       dependent parameters.
{
{ CONDITION_SAVE_AREA: (input)  This parameter specifies the stack frame save
{       area which caused the condition.
{
{ TRAPPED_SAVE_AREA: (input)  This parameter specifies the stack frame save
{       area which caused the debugger to be called.  The trapped save area
{       differs from the condition save area if the condition arose in a ring
{       below the execution bracket of the debugger - in which case the trapped
{       save area is the stack frame which caused the ring crossing (i.e.,
{       called a procedure in a lower ring).
{
{ DEBUG_ID: (input)  This parameter specifies the debug index at the time the
{       condition was caused.
{
{ MULTIPLE_CONDITIONS: (input)  This parameter specifies that there is at least
{       one more condition pending.
{
{ STATUS: (output) This parameter specifies the debugger status.  When
{       normal status is returned, the task will resume execution using
{       the environment defined by trapped save area.  When abnormal
{       status is returned, the task will be terminated returning the
{       the value of this status variable.
{        CONDITIONS:
{            none
*DECK DECK=DBH$DEFINE_APPLIC_IDENTIFIER EXPAND=FALSE

{
{   The purpose of this request is to provide the capability to
{ identify software as an application and account for resources
{ of the current module currently being loaded to the debug
{ table builder.
{
{       DBP$DEFINE_APPLIC_IDENTIFIER (APPLICATION_IDENTIFIER, STATUS)
{
{ APPLICATION_IDENTIFIER: (input) This parameter specifies the
{       application identifier which will be stored in the
{       module header.
{
{ STATUS: (output) This parameter specifies the request status.
{      CONDITION: pme$missing_module_definition.
{      IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=DBH$DEFINE_ENTRY_POINT_ADDRESS EXPAND=FALSE

{ }
{   The purpose of this request is to define the address of an XDCLed }
{ procedure or variable. }
{ }
{       DBP$DEFINE_ENTRY_POINT_ADDRESS (ENTRY_POINT_TABLE_ITEM, STATUS)
{ }
{ ENTRY_POINT_TABLE_ITEM: (input) This parameter specifies the entry point }
{       table item to be added to the entry point table. }
{ }
{ STATUS: (output) This parameter specifies the request status. }
{      CONDITON: pme$too_many_entry_points,
{                pme$entry_pt_segment_overflow.
{      IDENTIFIER: pmc$program_management_id.
{ }
*DECK DECK=DBH$DEFINE_LINE_ADDRESS_TABLE EXPAND=FALSE

{
{   The purpose of this request is to define a line address table of the
{ current module currently being loaded to the debug table builder.
{
{       DBP$DEFINE_LINE_ADDRESS_TABLE (LINE_ADDRESS_TABLE, LOADED_RING, STATUS)
{
{ LINE_ADDRESS_TABLE: (input) This parameter specifies the pointer to the
{       the line address table being defined.
{
{ LOADED_RING: (input) This parameter specifies the ring in which the current
{        module is being loaded in.

{ STATUS: (output) This parameter specifies the request status.
{      CONDITION: pme$missing_module_definition.
{      IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=DBH$DEFINE_MODULE EXPAND=FALSE

{
{   The purpose of this request is to define the start of processing
{ of a new module by the loader to the debug table builder.
{
{       DBP$DEFINE_MODULE (IDENTIFICATION, LANGUAGE, STATUS)
{
{ IDENTIFICATION: (input) This parameter specifies the identification record
{        of the new module.
{
{ LANGUAGE: (input) This parameter specifies the source language used
{       to generate the module.
{
{ STATUS: (output) This parameter specifies the request status.
{      CONDITION: pme$missing_module_termination,
{                 pme$module_segment_overflow.
{      IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=DBH$DEFINE_SECTION EXPAND=FALSE

{
{   The purpose of this request is to define a section of the current
{ module currently being loaded to the debug table builder.
{
{       DBP$DEFINE_SECTION (SECTION_ITEM, STATUS)
{
{ SECTION_ITEM: (input) This parameter specifies the information about
{       the section.
{
{ STATUS: (output) This parameter specifies the request status.
{      CONDITON: pme$invalid_section_ordinal,
{                pme$missing_module_definition.
{      IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=DBH$DEFINE_SUPPLEMENTAL_DTABLES EXPAND=FALSE
{
{   The purpose of this request is to define a supplemental debug table
{ for the module currently being loaded to the debug table builder.
{
{       DBP$DEFINE_SUPPLEMENTAL_DTABLES (SUPPLEMENTAL_DEBUG_TABLES, LOADED_RING,
{         STATUS)
{
{ SUPPLEMENTAL_DEBUG_TABLES: (input) This parameter specifies the pointer to the
{       the supplemental debug table being defined.
{
{ LOADED_RING: (input) This parameter specifies the ring in which the current
{        module is being loaded in.
{
{ STATUS: (output) This parameter specifies the request status.
{      CONDITIONS: pme$missing_module_definition
{                  ose$task_private_full
{      IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=DBH$END_DEBUG EXPAND=FALSE
{
{
{    The purpose of this request is to give a debugger control prior to task
{ exit.  This request is issued if:
{    1.  task debug is on and PMP$EXIT or PMP$ABORT is called; or
{    2.  task debug is off, but PMP$ABORT is called and there is an "abort
{        file" associated with the program.
{
{       DBP$END_DEBUG (ABORT, STATUS)
{
{ ABORT: (input)  This parameter specifies whether PMP$END_DEBUG was called as
{       the result of a PMP$EXIT (FALSE) or a PMP$ABORT (TRUE).
{
{ STATUS: (input) This parameter specifies the task's status on exit.
{       CONDITIONS:
{            none
{
*DECK DECK=DBH$ENTRY_POINT_TABLE_ADDRESS EXPAND=FALSE

{
{   The purpose of this request is to return the address of the entry
{ point address table.  The interactive debugger uses this request to
{ discover where the debug table builder has allocated the entry point
{ address list.
{
{       DBP$ENTRY_POINT_TABLE_ADDRESS: ENTRY_POINT_TABLE_ADDRESS
{
{ ENTRY_POINT_TABLE_ADDRESS: (output) This parameter specifies the address of
{       the entry point table.
{
*DECK DECK=DBH$MODULE_TABLE_ADDRESS EXPAND=FALSE

{
{   The purpose of this request is to return the address of the first
{ item in the module address table.  The interactive debugger uses this
{ request to discover where the debug table builder has allocated the
{ module address table.
{
{       DBP$MODULE_TABLE_ADDRESS: FIRST_ITEM_ADDRESS
{
{ FIRST_ITEM_ADDRESS: (output) This parameter specifies the address of
{       the first item in the module address table.
{
*DECK DECK=DBH$TERMINATE_MODULE EXPAND=FALSE

{
{   The purpose of this request is to inform the debug table builder
{ that loader processing of a module has been completed.
{
{       DBP$TERMINATE_MODULE (STATUS)
{
{ STATUS: (output) This parameter specifies the request status.
{      CONDITION: pme$missing_module_definition,
{                 pme$module_segment_overflow,
{                 pme$invalid_line_address_table.
{      IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=DBP$DEFINE_APPLIC_IDENTIFIER EXPAND=FALSE

   PROCEDURE [XREF] dbp$define_applic_identifier (
     application_identifier: ^llt$application_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc llt$application_identifier
*copyc ost$status
?? POP ??
*DECK DECK=DBP$DEFINE_DEBUG_SYMBOL_TABLES EXPAND=FALSE
 PROCEDURE [XREF] dbp$define_debug_symbol_tables (debug_symbol_table:
    ^llt$symbol_table;
        loaded_ring: ost$ring;
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc llt$symbol_table
*copyc ost$status
?? POP ??
*DECK DECK=DBP$DEFINE_ENTRY_POINT_ADDRESS EXPAND=FALSE

  PROCEDURE [XREF] dbp$define_entry_point_address (entry_point_table_item:
    dbt$entry_point_table_item;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DBT$ENTRY_POINT_TABLE
*copyc OST$STATUS
?? POP ??
*DECK DECK=DBP$DEFINE_LINE_ADDRESS_TABLE EXPAND=FALSE

  PROCEDURE [XREF] dbp$define_line_address_table (line_address_table:
    ^llt$line_address_table;
        loaded_ring: ost$ring;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc LLT$LINE_ADDRESS_TABLE
*copyc OST$STATUS
?? POP ??
*DECK DECK=DBP$DEFINE_MODULE EXPAND=FALSE

  PROCEDURE [XREF] dbp$define_module (identification: ^llt$identification;
    language: llt$module_generator;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc LLT$IDENTIFICATION
*copyc LLT$MODULE_KIND
*copyc LLT$MODULE_ATTRIBUTES
*copyc PMT$PROGRAM_NAME
*copyc OST$DATE
*copyc OST$TIME
*copyc LLT$MODULE_GENERATOR
*copyc llt$section_address
*copyc LLT$OBJECT_TEXT_DESCRIPTOR
*copyc LLT$OBJECT_RECORD_KIND
*copyc OSD$VIRTUAL_ADDRESS
*copyc PMD$PPU_CHARACTERISTICS
*copyc OST$STATUS
?? POP ??
*DECK DECK=DBP$DEFINE_SECTION EXPAND=FALSE

  PROCEDURE [XREF] dbp$define_section (section_item: dbt$section_item;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DBT$MODULE_ADDRESS_TABLE_ITEM
*copyc OST$STATUS
?? POP ??
*DECK DECK=DBP$DEFINE_SUPPLEMENTAL_DTABLES EXPAND=FALSE

  PROCEDURE [XREF] dbp$define_supplemental_dtables
    (    supplemental_debug_tables: ^llt$supplemental_debug_tables;
         loaded_ring: ost$ring;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc llt$supplemental_debug_tables
*copyc ost$status
?? POP ??
*DECK DECK=DBP$ENTRY_POINT_TABLE_ADDRESS EXPAND=FALSE

  FUNCTION [XREF] dbp$entry_point_table_address: ^dbt$entry_point_table;

?? PUSH (LISTEXT := ON) ??
*copyc dbt$entry_point_table
?? POP ??
*DECK DECK=DBP$MODULE_TABLE_ADDRESS EXPAND=FALSE

  FUNCTION [XREF] dbp$module_table_address: ^dbt$module_address_table_item;

?? PUSH (LISTEXT := ON) ??
*copyc dbt$module_address_table_item
?? POP ??
*DECK DECK=DBP$TERMINATE_MODULE EXPAND=FALSE

  PROCEDURE [XREF] dbp$terminate_module (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=DBT$BEGIN_DEBUG EXPAND=FALSE

  TYPE
   dbt$begin_debug = ^procedure (starting_procedure: ^cell);
*DECK DECK=DBT$DEBUG EXPAND=FALSE

  TYPE
    dbt$debug = ^procedure (    condition: pmt$condition;
                                condition_descriptor:
                                 ^pmt$condition_information;
                                condition_save_area:
                                 ^ost$stack_frame_save_area;
                                trapped_save_area: ^ost$stack_frame_save_area;
                                debug_id: pmt$debug_identifier;
                                multiple_conditions: boolean;
                            VAR status: ost$status);

*copyc jmd$job_resource_condition
*copyc mmd$segment_access_condition
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc pmd$debug
*copyc pmt$condition
*copyc pmt$condition_information
*DECK DECK=DBT$END_DEBUG EXPAND=FALSE

  TYPE
    dbt$end_debug = ^procedure (abort: boolean;
      status: ost$status);

*copyc ost$status
*DECK DECK=DBT$ENTRY_POINT_TABLE EXPAND=FALSE


  TYPE
    dbt$entry_point_table = record
      address: ^array [1 .. * ] of dbt$entry_point_table_item,
      item: array [1 .. * ] of dbt$entry_point_table_item,
    recend,

    dbt$entry_point_table_item = record
      name: pmt$program_name,
      call_bracket,
      loaded_ring: ost$ring,
      global_lock: ost$key_lock_value,
      address: ost$pva,
    recend;

  CONST
    dbc$max_entry_point_items = 0ffffff(16);

*copyc osd$virtual_address
*copyc pmt$program_name
*DECK DECK=DBT$MODULE_ADDRESS_TABLE_ITEM EXPAND=FALSE


  TYPE
    dbt$module_address_table_item = record
      name: pmt$program_name,
      language: llt$module_generator,
      greatest_section_ordinal: llt$section_ordinal,
      application_identifier: ^llt$application_identifier,
      reinitialization_information: ^llt$identification,
      next_module: ^dbt$module_address_table_item,
      line_address_tables: ^array [0 .. * ] of ^llt$line_address_table,
      debug_symbol_tables: ^array [0 .. * ] of ^llt$debug_symbol_table,
      supplemental_debug_tables: ^array [0 .. * ] of
            ^llt$supplemental_debug_tables,
      section_item: array [0 .. * ] of dbt$section_item,
    recend,

    dbt$section_item = record
      kind: llt$section_kind,
      section_ordinal: llt$section_ordinal,
      address: ost$pva,
      length: ost$segment_length,
{!    segment_access_control: packed ost$segment_access_control,
      segment_access_control: ost$segment_access_control,
      ring: dbt$ring_attributes,
      key_lock: ost$key_lock,
      name: pmt$program_name,
    recend,

    dbt$ring_attributes = record
      r1,
      r2,
      r3: ost$ring,
    recend;

*copyc cyd$debug_symbols
*copyc llt$application_identifier
*copyc llt$debug_symbol_table
*copyc llt$line_address_table
*copyc llt$module_generator
*copyc llt$object_text_descriptor
*copyc llt$object_record_kind
*copyc llt$obsolete_line_table
*copyc llt$section_address
*copyc llt$supplemental_debug_tables
*copyc osd$virtual_address
*copyc ost$segment_access_control
*copyc pmd$ppu_characteristics
*copyc pmt$program_name
*DECK DECK=DCOPY EXPAND=TRUE
.PROC,DCOPY,F.
.*
.*  THIS PROCEDURE SAVES THE SPECIFIED FILE ON DISK.
.*
IFE,FILE(F,.NOT.AS),NOTLOC.
REVERT. NOT LOCAL.
ENDIF,NOTLOC.
$REWIND,F.
PURGE,F/NA.
DEFINE,YYYYREP=F.
$COPY,F,YYYYREP.
$RETURN,YYYYREP.
REVERT. F SAVED.
/EOR
*DECK DECK=DCT$DISK_CACHE_INFO EXPAND=FALSE
{ This deck contains type definitions to allow conversion between the
{ data field of a keypoint and the types passed to the keypoint
{ processor.

  TYPE
    dct$keypoint_unit_cylinder = packed record
      case boolean of
      = TRUE =
        unit: 0..0ff(16),
        cylinder: 0..0fff(16),
      = FALSE =
        keypoint_data: 0..0fffff(16),
      casend,
    recend;

  TYPE
    dct$keypoint_sfid = packed record
      case boolean of
      = TRUE =
        file_entry_index: gft$file_descriptor_index,
        residence: gft$table_residence,
      = FALSE =
        keypoint_data: 0..0fffff(16),
      casend,
    recend;

  TYPE
    dct$keypoint_functions = packed record
      case boolean of
      = TRUE =
        io_function: iot$io_function,
        command_code: 0 .. 0ff(16),
        disk_type_index: 0 .. 0f(16),
      = FALSE =
        keypoint_data: 0..0fffff(16),
      casend,
    recend;

  TYPE
    dct$keypoint_ijlo = packed record
      case boolean of
      = TRUE =
        ijlo: jmt$ijl_ordinal,
      = FALSE =
        keypoint_data: 0 .. 0fffff(16),
      casend,
    recend;

  TYPE
    dct$keypoint_taskid = packed record
      case boolean of
      = TRUE =
        index: ost$task_index,
        seqno: 0 .. 255,
      = FALSE =
        keypoint_data: 0 .. 0fffff(16),
      casend,
    recend;

  TYPE
    dct$keypoint_aste_data = packed record
      case boolean of
      = TRUE =
        segnum: 0 .. 0fff(16),
        queue_id: 0 .. 0f(16),
        stack_for_ring: 0 .. 0f(16),
      = FALSE =
        keypoint_data: 0 .. 0fffff(16),
      casend,
    recend;

  TYPE
    dct$keypoint_request_info = packed record
      case boolean of
      = TRUE =
        request_type: iot$io_request_type,
        au_previously_written: boolean,
      = FALSE =
        keypoint_data: 0 .. 0fffff(16),
      casend,
    recend;

  TYPE
    dct$keypoint_data = 0 .. 0fffff(16);

?? push (listext := on) ??
*copyc gft$system_file_identifier
*copyc jmt$ijl_ordinal
*copyc ost$global_task_id
*copyc iot$command
*copyc iot$io_function
*copyc iot$io_request_type
?? pop ??
*DECK DECK=DCV$DISK_CACHE_INFO_ENABLED EXPAND=FALSE
  VAR
    dcv$disk_cache_info_enabled: [XREF] boolean;
*DECK DECK=DFC$CLIENT_PAUSE_BREAK EXPAND=FALSE

  CONST
    dfc$client_pause_break = 'DFC$CLIENT_PAUSE_BREAK         ';

*DECK DECK=DFC$CLIENT_TERMINATE_BREAK EXPAND=FALSE

  CONST
    dfc$client_terminate_break = 'DFC$CLIENT_TERMINATE_BREAK     ';

*DECK DECK=DFC$ESM_ALLOCATION_CONSTANTS EXPAND=FALSE
{ DECK: DFC$ESM_ALLOCATION_CONSTANTS

{ These values are in ESM/STORNET memory words.
  CONST
    dfc$division_overwrite_words = 16,
    dfc$esm_maintenance_buf_size = 1000,
    dfc$max_esm_memory_size = 16777216,
    dfc$min_esm_memory_size = 1048576;

{ These values are also declared as constants in File Server's PP driver.
  CONST
    dfc$esm_memory_base_shift = 100(8),
    dfc$esm_division_chwrds_shift = 100(8),
    dfc$max_number_of_mainframes = 8,
    dfc$max_esm_divisions = 16,
    dfc$max_rma_list_entries = 64,
    dfc$header_record_bytes = 24,
    dfc$command_record_bytes = 4096;

  CONST
    dfc$max_data_record_bytes = 262144,
    dfc$min_data_record_bytes = 16384;

{ These values are expressed in number of 60 bit ESM words rounded up by 10(8).
  CONST
    dfc$esm_command_record_size = ((((dfc$command_record_bytes * 8) DIV 60) + 7) DIV 8) * 8,
    dfc$esm_header_record_size = ((((dfc$header_record_bytes * 8) DIV 60) + 7) DIV 8) * 8;

{ These values are expressed as number of 60 bit ESM words.
  CONST
    dfc$max_driver_formed_esm_adrs = 37777777(8),
    dfc$min_esm_division_size =
     ((((((((dfc$min_data_record_bytes * 8) DIV 60) + 7 + dfc$division_overwrite_words) DIV 8) * 8) +
            (dfc$esm_command_record_size + dfc$esm_header_record_size)) + dfc$esm_memory_base_shift-1)
              DIV dfc$esm_memory_base_shift) * dfc$esm_memory_base_shift,
    dfc$max_esm_memory_base = ((dfc$max_esm_memory_size - dfc$min_esm_division_size
                                - dfc$esm_maintenance_buf_size) DIV 1000(8)) * 1000(8);



*DECK DECK=DFC$ESM_DRIVER_ERROR_CODES EXPAND=FALSE
{ DECK: DFC$ESM_DRIVER_ERROR_CODES
{ Error condition codes reported by File Server ESM PP driver.
{ Changes in this deck should be reflected in changes to deck
{ DUM$DISPLAY_ESM_ERROR or possibly CMH$LSP_FAILURE_DATA_DOC.
{
{  The first set of errors indicate hardware errors and are logged to the
{  engineering log.

  CONST
    dfc$function_timeout = 1,
    dfc$iou_channel_parity_error = 2,
    dfc$esm_channel_parity_error = 3,
    dfc$esm_double_bit_parity_error = 4,
    dfc$esm_address_parity_error = 5,
    dfc$esm_flag_operation_abort = 6,
    dfc$adp_uncorrected_cm_error = 7,
    dfc$adp_cm_reject = 8,
    dfc$adp_invalid_cm_response = 9,
    dfc$adp_cm_response_parity_err = 10,
    dfc$adp_cmi_read_parity_err = 11,
    dfc$adp_clock_fault = 12,
    dfc$adp_input_buffer_overflow = 13,
    dfc$adp_input_data_parity_error = 14,
    dfc$adp_12_16_conversion_error = 15,
    dfc$adp_jy_data_parity_error = 16,
    dfc$adp_kx_pp_data_parity_error = 17,
    dfc$adp_kz_board_detected_error = 18,
    dfc$adp_jy_board_detected_error = 19,
    dfc$adp_kx_board_detected_error = 20,
    dfc$esm_address_overflow = 21,
    dfc$channel_inactive_error = 22,
    dfc$dma_xfer_halted_early = 23,
    dfc$lsp_deadman_timeout = 24,
    dfc$unused_reserved_25 = 25,
    dfc$unused_reserved_26 = 26,
    dfc$unused_reserved_27 = 27,
    dfc$unused_reserved_28 = 28,
    dfc$unused_reserved_29 = 29,

{ The following error codes usually indicate software errors caused by
{ improper interface procedures/code between File Server and File Server's
{ PP driver (ESMD).
{ Any error coming from the file server will be displayed in the critical
{ window in HEX and prefaced with  the string  ' Server error response '
{ or ' Server interface error'.
{ For example ' Server error response 0000000000000025'
{ would be displayed and 25 hex is 37 decimal which is
{ dfc$no_held_info_in_queue_entry is the below list.
{ If setsa file_server_debug_enabled 1 is set the
{ system will crash when some of these errors are detected.

    dfc$invalid_command_code = 30,
    {  The PP request command code is not supported by ESMD PP driver.
    {   Only PP request command codes 0 = ACKNOWLEDGE, 1 = STOP UNIT,
    {   4 = IDLE, and 5 = RESUME are supported.

    dfc$invalid_length_in_command = 31,
    {  Something is wrong with page data indirect address list length field:
    {    a. indirect list length is not multiple of 8 bytes.
    {    b. indirect list length is zero.
    {    c. Indirect list length greater than allowed by ESMD PP driver.

    dfc$invalid_address_in_command = 32,
    { Something is wrong with buffer address or data indirect list address :
    {    a. RMA is zero.
    {    b. RMA not on CM word boundry.

    dfc$invalid_length_in_ind_list = 33,
    { Something is wrong with data indirect RMA list entries :
    {    a. RMA length is not multiple of 8 bytes.
    {    b. RMA length is zero.
    {    c. RMA length greater than allowed by ESMD PP driver.

    dfc$invalid_address_in_ind_list = 34,
    { Data indirect RMA list entry has entry with RMA not on CM word boundry.

    dfc$reserved_field_not_zero = 35,
    { Data indirect RMA list entry has non zero reserved field of RMA.

    dfc$pit_lockword_error = 36,
    { THIS ERROR CODE NEVER USED OR REPORTED BY DRIVER

    dfc$no_held_info_in_queue_entry = 37,
    { The send_ready_for_data command flag was set for driver processing when
    {  no page data was available or when page data has already been read.
    {  specifically - driver queue entry HELD_INFO field is zero.
    {  Possible Cause:
    {    1. The indirect list length field in the driver queue entry was
    {       non zero when the message and data was detected in STORNET so that
    {       the page data was already moved to the specified CM locations.
    {    2. The buffer data eroniously indicates page data when in fact there
    {       is non to be delivered by the PP driver.

    dfc$invalid_queue_index = 38,
    { The queue index specified in request buffer or read from STORNET
    {  is zero or greater than number of queues.

    dfc$invalid_queue_entry_index = 39,
    { The queue entry index specified in request buffer or read from STORNET
    {  is zero or greater than number of queue entries.

    dfc$insufficient_length_spec = 40,
    { The size of the command buffer or the total size of page data buffer
    {  is less than the length of the command or page data to be read from
    {  STORNET.

    dfc$driver_action_flag_not_set = 41,
    {  Request buffer entry points to driver queue entry with driver_action
    {  flag clear.

    dfc$destination_machine_down = 42,
    {  The STORNET 4 bit flag register allocated to the destination
    {  mainframe to indicate its status does not contain the mainframe ID
    {  number.
    {  Possible Cause:
    {    1. The ESMD PP driver on the destination mainframe has either
    {       been IDLED or File Server has not been activated.

    dfc$queue_idle = 43,
    {  Request buffer entry points to driver queue with driver queue header
    {  "queue idle" flag set true.
    {  Possible Cause:
    {    1. File Server deactivation or termination proceding without first
    {       idling or unloading the PP driver.

    dfc$inactive_queue_entry = 44,
    {  Request buffer entry points to driver queue entry with active queue
    {  entry flag set false.
    {  Possible Cause:
    {    1. Once entry is placed in request buffer only the PP driver can
    {       remove it, this code does not necessarily indicate an error.
    {       The queue entry was released while PP driver is still
    {       processing requests.

    dfc$invalid_driver_queue_rma = 45,
    { The queue index specified in request buffer or read from STORNET
    {  indexes a zero entry in the PP driver's queue directory table.
    {  This table is constructed by the PP driver at PP activation time by
    {  reading the CM queue interface directory and converting the CM RMAs
    {  to PP RMAs.
    {  Possible Cause:
    {    1. Creating a new queue and allowing File Server processing without
    {       re-activating the PP driver.

    dfc$unused_reserved_46 = 46,
    dfc$unused_reserved_47 = 47,
    dfc$unused_reserved_48 = 48,
    dfc$unused_reserved_49 = 49;


*DECK DECK=DFC$IOU_NAMES EXPAND=FALSE

{ DECK: DFC$IOU_NAMES

  CONST
    dfc$iou_name0 = 'IOU0',
    dfc$iou_name1 = 'IOU1';
*DECK DECK=DFC$LOOPBACK_SERVER_CONSTANTS EXPAND=FALSE
  CONST
    dfc$loopback_server_model = osc$cyber_180_model_990,
    {Note: Serial number is stored in BCD format not as an ordinal.
    dfc$loopback_server_serial = 7777(16);

*copyc dfc$loopback_server_mainframe
*copyc ost$processor_model_number
*DECK DECK=DFC$LOOPBACK_SERVER_MAINFRAME EXPAND=FALSE
  CONST
    dfc$loopback_server_mainframe = '$SYSTEM_0990_7777';

*DECK DECK=DFC$PARTIALLY_REBUILT_FDE_EOI EXPAND=FALSE
  CONST
    dfc$partially_rebuilt_fde_eoi = 10000000000(16);



*DECK DECK=DFC$POLL_CONSTANTS EXPAND=FALSE
{ DECK: DFC$POLL_CONSTANTS.

  CONST

{   dfc$poll_queue_index = Poll task's index to the cpu_queue_entry
{   and to the driver_queue_entry.
    dfc$poll_queue_index = 1,

{   dfc$poll_wait_time = Poll task wait time between each execution,
{   in milliseconds.
    dfc$poll_wait_time = 10000;

  CONST

{   DFC$MAXIMUM_TIMEOUT is the request maximum timeout interval value in SECONDS.
    dfc$maximum_timeout = 255,

{   DFC$MAX_REQ_TIMEOUT_COUNT_VALUE is the maximum value that can be assigned
{   to maximum_request_timeout_count parameter.
    dfc$max_req_timeout_count_value = 255,

{   DFC$MAX_RETRANSMIT_COUNT_VALUE is the maximum value that can be assigned to
{   maximum_retransmission_count parameter.
    dfc$max_retransmit_count_value = 255;

*DECK DECK=DFC$QUEUE_REQUEST_CONSTANTS EXPAND=FALSE

{ Constants for timeout maintenance in task services queueing.

    CONST
      dfc$request_delay = 250, { 0.25 seconds }
      dfc$maximum_delay_time = 10000, { 10 seconds, default value of DFV$TASK_QUEUE_TIMEOUT_INTERVAL }
      dfc$timeout_delay = 30000; { 30 seconds }

*DECK DECK=DFC$REMOTE_CORE_CALL EXPAND=FALSE

  CONST
    dfc$system_core_version = 'CORE',
    dfc$system_core_checksum = 8675309;

*DECK DECK=DFC$SDP_DRIVER_ERROR_CODES EXPAND=FALSE
{
{ DECK: DFC$SDP_DRIVER_ERROR_CODES
{ Error condition codes reported by SDPD PP driver.
{
{ The following set of errors indicate hardware errors and are logged
{ to the System Engineering Log.
{

  CONST
    dfc$sdpd_normal_completion = 1,

{ STORNET/ESM side door port error logging has occurred and SDPD PP
{ driver completion status is normal.

    dfc$sdpd_channel_active_error = 2,

{ The SDPD PP driver found the data channel ACTIVE when it was expected
{ to be INACTIVE.

    dfc$sdpd_no_inactive_to_func = 3,

{ The data channel did not go INACTIVE after a function was issued from
{ the SDPD PP driver to the STORNET/ESM side door port.

    dfc$sdpd_lost_data_on_input = 4,

{ A data transfer from the STORNET/ESM side door port to the SDPD PP
{ driver terminated early.

    dfc$sdpd_channel_parity_error = 5,

{ The SDPD PP driver detected a data channel parity error.

    dfc$sdpd_channel_not_empty = 6,

{ The data channel stayed FULL after a data transfer from the SDPD PP
{ driver to the STORNET/ESM side door port.

    dfc$sdpd_channel_lockword_error = 7;

{ The PP number in the Channel Lockword for the STORNET/ESM side door
{ port channel in the Channel Interlock Table is incorrect.
*DECK DECK=DFC$SDP_LOGGING_ERROR_CODES EXPAND=FALSE
{
{ DECK: DFC$SDP_LOGGING_ERROR_CODES
{ Error condition codes reported by DFP$LOG_SIDE_DOOR_PORT_STATUS.
{
{ The following set of errors indicate software errors that are attributed to
{ configuration and resource problems.
{

  CONST
    dfc$sdp_no_initialization_error = 20,

{ No errors occurred during side door port logging initialization.

    dfc$sdp_channel_incorrect_state = 21,

{ No defined STORNET/ESM side door port channel is found having a channel
{ status state of 'CMC$ON'.  Channel status state is either 'CMC$DOWN'
{ or 'CMC$OFF'.

    dfc$sdp_channel_unavailable = 22,

{ Side door port logging could not RESERVE the defined STORNET/ESM side
{ door port channel from NOS/VE.

    dfc$sdp_pp_unavailable = 23,

{ Side door port logging could not RESERVE a PPU resource having access
{ to the defined STORNET/ESM side door port channel.

    dfc$sdp_no_sdpd_response = 24,

{ Side door port logging did not receive a response from the SDPD driver
{ within the required 4 second interval and a timeout occurred.

    dfc$max_sdp_logging_error_code = 25;

*DECK DECK=DFC$SERVER_MAINFRAMES_CATALOG EXPAND=FALSE

 CONST
   dfc$server_mainframes_catalog = '$DF$SERVER_MAINFRAMES';
*DECK DECK=DFC$TEST_JR_CONSTANTS EXPAND=FALSE
{ Deck: DFC$TEST_JR_CONSTANTS
{ File server has the range of 150 to 199
{ These constants provide a test of file server job recovery
{ by allowing the job to hang at a call to syp$hang_if_job_jrt_set
{ when SET_JOB_RECOVERY_TEST JOB  is used to set the value,
{ or to hang at a call to syp$hang_if_system_jrt_set when
{ SET_JOB_RECOVERY_TEST SYSTEM is used to set the value.
{ SET_JOB_RECOVERY_TEST may only be used after doing
{ SETSA ALLOW_JR_TEST 1 from the console.


  CONST
    { Setable by setjrt SYSTEM
    { Hang in dfp$determine_client_status (poll task on server mainframe)
    dfc$tjr_determine_client_status = 151,

    { Hang in dfp$determine_server_status (poll task on client mainframe)
    dfc$tjr_determine_server_status = 152,

    { Hang in recovery task on client mainframe. State is recovering.
    dfc$tjr_recover_req_to_server = 153,

    { Setable by SETJRT JOB
    { dfp$begin_remote_procedure_call after the queue entry is assigned
    dfc$tjr_begin_rpc = 154,

    { dfp$send_remote_procedure_call after the queue entry is queued
    dfc$tjr_send_rpc  = 155,

    { dfp$end_remote_procedure_call before the queue entry is released.
     dfc$tjr_end_rpc  = 156,

     { Must use SENRCL in DFTU TO send 'setjrt job 157 '
     { Hangs after the remote procedure is called on the server.
     dfc$tjr_server_rpc_after_call = 157,


    { Setable by setjrt SYSTEM
     { allocate space with the entry assigned but not queued
     dfc$tjr_server_allocate_space = 158,

     { reallocate space with the entry assigned but not queued
    dfc$tjr_server_reallocate_space = 159,

    { dfp$set_server_eoi after dfp$begin_remote_procedur_call
    dfc$tjr_server_set_eoi = 160,

    { Process server response <new request > just before the call to
    { mmp$mtr_process_server_complete
    dfc$tjr_prosr_new_request   = 161,

    { Process server response < complete request> just before the call to
    { mmp$mtr_process_server_complete
    dfc$tjr_prosr_complete_request  = 162,


    { dfp$begin_remote_core_call after the queue entry is assigned
    dfc$tjr_begin_core_rpc = 163,

    { dfp$send_remote_core_call  after the queue entry is queued
    dfc$tjr_send_core_rpc  = 164,

    { dfp$end_remote_core_call before the queue entry is released.
    dfc$tjr_end_core_rpc  = 165,

    { Halt during terc - dfp$manage_client_connection before pp unloaded
    dfc$tjr_halt_terc = 166,

    { Setable by SETJRT system
    { Halt during writing the image file on continuation deadstart
    { dfm$manage_image - save_server_file_image  or
    { dfm$recovery_services - save_server_file_pages.
    { Must be set at system core command time
    dfc$tjr_halt_save_server_image = 167,

    { Setable by SETJRT system
    { Hang while rebuilding client jobs
    { dfm$client_mainframe_manager - rebuild_client_jobs
    dfc$tjr_hang_rebuild_clientjobs = 168,

    { Setable by SETJRT system
    { dfm$preserved_family_manager - dfp$flush_served_family_table
    dfc$tjr_flush_served_family = 169,


    dfc$tjr_last_constant =  199;

*DECK DECK=DFD$DRIVER_QUEUE_TYPES EXPAND=FALSE
{ DECK: DFD$DRIVER_QUEUE_TYPES

  CONST
    dfc$max_request_buffer_entries = 256;

  TYPE
    dft$id_number = 1 .. dfc$max_number_of_mainframes,
    dft$divisions_per_mainframe = 1 .. dfc$max_esm_divisions;


  TYPE
    dft$p_queue_interface_table = ^dft$queue_interface_table,

    dft$queue_interface_table = record
      request_buffer_directory: ALIGNED [0 MOD 4096]
            dft$request_buffer_directory,
      esm_base_addresses: dft$esm_base_addresses,
      maximum_data_bytes: INTEGER, {dfc$min_data_record_bytes .. dfc$max_data_record_bytes}
      queue_directory: dft$queue_directory,
    recend;

  TYPE

    dft$esm_base_addresses = record
      number_of_mainframes: ALIGNED [0 MOD 8] 0 .. 0FFFF(16),
      divisions_per_mainframe: ALIGNED [2 MOD 8] 0 .. 0FFFF(16),
      esm_flag_base: ALIGNED [4 MOD 8] 0 .. 0FFFF(16),
      esm_memory_base: ALIGNED [6 MOD 8] 0 .. 0FFFFFFFF(16), {Divided by 100 octal}
      esm_division_size: ALIGNED [2 MOD 8] 0 .. 0FFFF(16),   {Divided by 100 octal}
      esm_divsiz_12bit_cw: ALIGNED [4 MOD 8] 0 .. 0FFFF(16), {Divided by 100 octal}
      esm_divsiz_16bit_cw: ALIGNED [6 MOD 8] 0 .. 0FFFF(16), {Divided by 100 octal}
    recend,

    dft$queue_directory = record
      dma_adapter:ALIGNED [0 MOD 8] dft$dma_adapter,
      send_pp_number: ALIGNED [2 MOD 8] iot$pp_number,
      receive_pp_number: ALIGNED [4 MOD 8] iot$pp_number,
      fill1: ALIGNED [6 MOD 8] 0 .. 0FFFF(16),
      fill2: ALIGNED [0 MOD 8] 0 .. 0FFFF(16),
      fill3: ALIGNED [2 MOD 8] 0 .. 0FFFF(16),
      source_id_number: ALIGNED [4 MOD 8] 0 .. 0FFFF(16),
      number_of_queues: ALIGNED [6 MOD 8] 0 .. 0FFFF(16),
      driver_queue_rma_directory: dft$driver_queue_rma_entries,
      driver_queue_pva_directory: dft$driver_queue_pva_entries,
      cpu_queue_pva_directory: dft$cpu_queue_pva_entries,
    recend,

    dft$dma_adapter = packed record
      use_on_send_channel: boolean,
      use_on_recv_channel: boolean,
      iou_i0_model: boolean,
      fill: 0 .. 1FFF(16),
    recend,

    dft$driver_queue_rma_entries = array [1 .. dfc$max_number_of_queues] of
          dft$driver_queue_rma_entry,
    dft$driver_queue_pva_entries = array [1 .. dfc$max_number_of_queues] of
          dft$driver_queue_pva_entry,
    dft$cpu_queue_pva_entries = array [1 .. dfc$max_number_of_queues] of
          dft$cpu_queue_pva_entry,

    dft$driver_queue_rma_entry = record
      fill: ALIGNED [0 MOD 8] 0 .. 0FFFFFFFF(16),
      driver_queue_rma: ALIGNED [4 MOD 8] ost$real_memory_address,
    recend,

    dft$driver_queue_pva_entry = record
      p_driver_queue: ^dft$driver_queue,
    recend,

    dft$cpu_queue_pva_entry = record
      p_cpu_queue: ^dft$cpu_queue,
    recend;

  TYPE
    dft$driver_queue = record
      queue_header: ALIGNED [0 MOD 4096] dft$driver_queue_header,
      queue_entries: ALIGNED [0 MOD 8] dft$driver_queue_entries,
    recend,

    dft$driver_queue_header = record
      flags: ALIGNED [0 MOD 8] dft$driver_queue_header_flags,
      interrupt: ALIGNED [2 MOD 8] dft$interrupt,
      number_of_queue_entries: ALIGNED [6 MOD 8] 0 .. 0FFFF(16),
      connection_descriptor: ALIGNED [0 MOD 8] dft$connection_descriptor,
    recend,

    dft$driver_queue_header_flags = packed record
      idle: boolean,
      fill: 0 .. 07FFF(16),
    recend,

    dft$interrupt = packed record
      fill: 0 .. 3(16),
      interrupt: iot$interrupt,
    recend,

    dft$connection_descriptor = record
      source: dft$connection_address,
      destination: dft$connection_address,
      fill: ost$word,
    recend,

    dft$connection_address = record
      flags: dft$connection_flags,
      id_number: 0 .. 0FFFF(16),
      fill1: 0 .. 0FFFF(16),
      queue_index: 0 .. 0FF(16),
      queue_entry_index: 0 .. 0FF(16),
    recend,

    dft$connection_flags = packed record
      server_to_client: boolean,
      fill: 0 .. 7FFF(16),
    recend,

    dft$driver_queue_entries = array [1 .. * ] of dft$driver_queue_entry,

    dft$driver_queue_entry = record
      flags: ALIGNED [0 MOD 8] dft$queue_entry_flags,
      error_condition: ALIGNED [2 MOD 8] 0 .. 0FFFF(16),
      { BEGIN  driver usage only }
      held_over_cm_word_count: ALIGNED [4 MOD 8] 0 .. 0FFFF(16),
      held_over_esm_division_number: 0 .. 0FFFF(16),
      { END driver usage only }
      send_buffer_descriptor: ALIGNED [0 MOD 8] dft$data_descriptor,
      receive_buffer_descriptor: ALIGNED [0 MOD 8] dft$data_descriptor,
      data_descriptor: ALIGNED [0 MOD 8] dft$data_descriptor,
    recend,

    dft$queue_entry_flags = packed record
      { queue control }
      active_entry: boolean,
      driver_action: boolean,
      subsystem_action: boolean,
      driver_error_alert: boolean,

      { command driver }
      send_command: boolean,
      send_data: boolean,
      fill: boolean,
      send_ready_for_data: boolean,

      { event status }
      buffer_sent: boolean,
      data_sent: boolean,
      buffer_received: boolean,
      data_received: boolean,

      { driver status }
      ready_for_data_sent: boolean,
      ready_for_data_received: boolean,
      process_response: boolean,
      fill1: boolean,
    recend,

    dft$error_condition = 0 .. 0FFFF(16),

    dft$data_descriptor = packed record
      indirect_address: boolean,
      fill: 0 .. 07FFF(16),
      {  IF NOT indirect_address length (bytes) must be a multiple of word
      { size (8)
      actual_length: 0 .. 0FFFF(16),
      address: ost$real_memory_address,
    recend;


?? PUSH (LISTEXT := ON) ??
*copyc cmc$maximum_esm_size
*copyc dfc$esm_allocation_constants
*copyc dft$cpu_queue
*copyc dft$fs_pp_response
*copyc dft$queue_index
*copyc dft$request_buffer
*copyc iot$pp_number
*copyc iot$request_recovery
*copyc ost$hardware_subranges
?? POP ??
*DECK DECK=DFD$FILE_SERVER_INFO EXPAND=FALSE
{ This deck contains type to allow conversion between the
{ data field of a keypoint and the types passed to the keypoint
{ processor.

  TYPE
    dft$keypoint_catalog_summary = packed record
      case boolean of
      = TRUE =
        remote_catalog: boolean,
        catalog_owner: boolean,
        catalog_depth: 0 .. 1f(16),
        read_access: {or write} boolean,
      = FALSE =
        keypoint_data: 0 .. 0fffff(16),
      casend,
    recend;

  TYPE
    dft$keypoint_file_operation = packed record
      case boolean of
      = TRUE =
        remote: {or local} boolean,
        catalog: {or file} boolean,
      = FALSE =
        keypoint_data: 0 .. 0fffff(16),
      casend,
    recend;

  TYPE
    dft$keypoint_pager_io = packed record
      case boolean of
      = TRUE =
        io_function: iot$io_function,
        pages: 0 .. 0fff(16),
      = FALSE =
        keypoint_data: 0 .. 0fffff(16),
      casend,
    recend;

  TYPE
    dft$keypoint_sfid = packed record
      case boolean of
      = TRUE =
        file_entry_index: gft$file_descriptor_index,
        residence: gft$table_residence,
      = FALSE =
        keypoint_data: 0 .. 0fffff(16),
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc iot$io_function
?? POP ??
*DECK DECK=DFD$REQUEST_PACKAGE EXPAND=FALSE
{ This deck (DFD$REQUEST_PACKAGE) describes the format of the buffer that is
{ sent from
{ the client to the server, or from the server to the client.
{ There are basically 4 different formats: one for standard requests,
{ one for test requests, one for the status package coming back, and
{ and one for polls or poll replies.


  TYPE
    dft$buffer_version = string (8),

    dft$buffer_header = record
      version: dft$buffer_version,
      transaction_count: integer,
      retransmission_count: 0 .. dfc$max_retransmit_count_value,
      remote_processor: dft$procedure_address_ordinal,
      buffer_length_sent: 1 .. dfc$command_buffer_size,
      data_length_sent: ost$segment_length,
    recend;

?? SKIP := 5 ??
{ Sequence format:
{   dft$buffer_header
{   dft$rpc_buffer_header

  CONST
    dfc$rpc_request_buffer_version = 'CYBILRPC';


?? SKIP := 5 ??
  { Poll and Poll Reply cases:
  { Sequence format:
  {   dft$buffer_header
  {   dft$poll_header
  {   CASE poll_header.poll_type of
  {   = dfc$verify_served_family , dfc$verify_family_reply =
  {     dft$poll_family_list
  {   = dfc$verify_queue, dfc$verify_queue_reply =
  {     dft$poll_family_list
  {     dft$poll_queue_information
  {  = dfc$deactivate_server, dfc$deactivate_complete, dfc$normal_poll,
  {    dfc$poll_reply =
  {    ()

  CONST
    dfc$poll_task_version = 'POLL_MSG';

?? SKIP := 5 ??

  CONST
    dfc$page_io_req = 'PAGEIO  ';

  { Describe page io format
  {  dft$buffer_header
  {  dft$page_io_request

?? SKIP := 5 ??
  TYPE
    dft$checksum = integer;
?? SKIP := 5 ??

  CONST
    dfc$allocate_request_version = 'ALLOCATE';

  { Describe allocate format
  {  dft$buffer_header
  {  dft$allocate_space_request

?? SKIP := 5 ??
  { Describe status format
  { dft$status_response
  { IF task services queue entry AND NOT status normal
  {    ost$status
  { IF task services and status normal
  {    dft$rpc_response_buffer_header
  { IF monitor and normal
  {   dft$page_io_response

  TYPE
    dft$status_response = record
      buffer_header: dft$buffer_header,
      status: syt$monitor_status,
    recend;

  CONST
    dfc$status_buffer_version = 'STATUS';


?? PUSH (LISTEXT := ON) ??
*copyc dft$client_job_id
*copyc osd$virtual_address
*copyc dft$cpu_queue
*copyc dft$procedure_address_ordinal
*copyc jmt$system_supplied_name
*copyc syt$monitor_status
?? POP ??

*DECK DECK=DFE$CDCNET_ERRORS EXPAND=FALSE
*copyc dfe$error_condition_codes

  CONST
    dfc$max_cdcnet_errors = dfc$min_cdcnet_errors + 12,

    dfe$header_length_error = dfc$min_cdcnet_errors + 0,
    {E Internal test (cdcnet):    Message Header Length Error.}

    dfe$header_type_error = dfc$min_cdcnet_errors + 1,
    {E Internal test (cdcnet):   Message Header Type Error.}

    dfe$queue_entry_error = dfc$min_cdcnet_errors + 2,
    {E Internal test (cdcnet):   Queue Entry Ordinal Error.}

    dfe$peer_error = dfc$min_cdcnet_errors + 3,
    {E Internal test (cdcnet):   Peer Message Error.}

    dfe$peer_sequence_error = dfc$min_cdcnet_errors + 4,
    {E Internal test (cdcnet):   Peer Message Out of Sequence.}

    dfe$message_length_error = dfc$min_cdcnet_errors + 5,
    {E Internal test (cdcnet):   Message Data Length Error.}

    dfe$network_activity_error = dfc$min_cdcnet_errors + 6,
    {E Internal test (cdcnet):   Network Request Connection Error.}

    dfe$network_error = dfc$min_cdcnet_errors + 7,
    {E Internal test (cdcnet):   Network Status in Error.}

    dfe$data_timeout = dfc$min_cdcnet_errors + 8,
   {E Internal test (cdcnet):   Data Transfer Timeout.}

    dfe$program_logic_error = dfc$min_cdcnet_errors + 9,
    {E Internal test (cdcnet):   Program Logic Error.}

    dfc$null_cdcnet_parameter = '';

*DECK DECK=DFE$DRIVER_TEST_ERRORS EXPAND=FALSE
*copyc dfe$error_condition_codes

  CONST

    dfe$must_execute_setql          = dfc$min_driver_test_errors + 0,
    {E Internal: SET_QUEUE_LOCATION must be executed before first +P command.}

    dfe$queue_index_exceeded        = dfc$min_driver_test_errors + 4,
    {E Internal: Queue index can not be larger than +I.}

    dfe$queue_entry_index_exceeded  = dfc$min_driver_test_errors + 5,
    {E Internal: Queue entry index can not be larger than +I.}

    dfe$queue_index_invalid        = dfc$min_driver_test_errors + 6,
    {E Internal: Specified QUEUE INDEX +P, points to NIL queue.}

    dfc$max_driver_test_errors      = dfc$min_cdcnet_errors - 1;
*DECK DECK=DFE$ERROR_CONDITION_CODES EXPAND=FALSE

  CONST
*IF $true(osv$unix)
    dfc$min_ecc = (($INTEGER ('D') * 100(16)) + $INTEGER ('F')) * 10000(16);
*ELSE
    dfc$min_ecc = (($INTEGER ('D') * 100(16)) + $INTEGER ('F')) * 1000000(16);
*IFEND

  CONST
    dfc$file_server_id = 'DF';

  CONST
  dfe$not_system_administrator =  dfc$min_ecc + 1,
   {E You must be at the system console to use the +P1 command +P2

  dfe$invalid_base_address = dfc$min_ecc + 2,
  {E STORNET memory base address must be expressed in multiples of 1000 octal.

  dfe$page_size_too_small = dfc$min_ecc + 3,
  {E File Server requires that the system page size be at least 4096 bytes.

  dfe$driver_cannot_form_adrs = dfc$min_ecc + 4,
  {E STORNET memory_size greater than 40000000(8) allowed only if half_ecs_switch is TRUE.

  dfe$stornet_memory_surpassed = dfc$min_ecc + 5,
  {E The total space required +P1 plus the BASE_ADDRESS of +P2
  { exceeds the total memory of the STORNET +P3.

  dfe$unknown_model_number  = dfc$min_ecc + 6,
  {E The specified model +P1 for mainframe_id +P2 is
  { not recognized as a valid CYBER 180 model.

  dfe$too_many_queue_entries = dfc$min_ecc + 7,
  {E The total size +P1 of queue entries must fit in a page of size +P2.

  dfe$id_number_in_use  = dfc$min_ecc + 8,
  {E The +P1_id_number has already been used to specify a different +P1 mainframe.

  dfe$unable_to_assign_q_entry = dfc$min_ecc + 9,
  {E Internal error: Unable to assign queue entry index, because +P1

  dfe$family_already_defined = dfc$min_ecc + 10,
  {E Family +P1 is already defined.

  dfe$maximum_families_configured  = dfc$min_ecc + 11,
  {E Family +P1 was NOT defined.  The maximum families is +P2.

  dfe$pp_active_during_define = dfc$min_ecc + 12,
  {E Define subcommand can only be issued when Client/Server is INACTIVE or TERMINATED.

  dfe$client_already_configured  = dfc$min_ecc + 13,
  {E The client mainframe +P1 is already configured.

  dfe$client_job_registered  = dfc$min_ecc + 14,
  {E Internal Error: The client job  +P1 is already registered on the server.

   dfe$maximum_jobs_connected  = dfc$min_ecc + 15,
   {E Only a maximum of +P1 client jobs may be connected to the server.

   dfe$bad_client_job_id = dfc$min_ecc + 16,
   {E Internal error: The client_job_id is invalid "+P1".

   dfe$release_q_entry_error = dfc$min_ecc + 17,
   {E Internal error: Unable to release queue entry +P1.

   dfe$improper_mainframe_id = dfc$min_ecc + 18,
   {E The specified mainframe_id +P1 is NOT of the form $SYSTEM_MMMM_NNNN,
   {  Where MMMM is the model number, and NNNN is the serial number. +P2

   dfe$protocol_error_version = dfc$min_ecc + 19,
   {E Internal error: An unexpected buffer version +P1 was received.  Expected +P2

   dfe$protocol_error_sequence = dfc$min_ecc + 20,
   {E Internal error: Queue entry sequence out of order (+P1).  Expecting transaction +P2, received +P3.

   dfe$path_to_stornet_broken = dfc$min_ecc + 21,
   {E File Server's PP driver cannot communicate with STORNET via element_name +P1,
   { iou_name +P2, channel_name +P3. Please verify physical channel connection to STORNET low speed port.

   dfe$invalid_served_family_index  = dfc$min_ecc + 22,
   {E Internal error: Invalid served family index on +P1, pointers index +P2, family_list +P3

   dfe$unknown_driver  = dfc$min_ecc + 23,
   {E  Internal error: Driver +P1 is unknown.

   dfe$driver_already_recorded  = dfc$min_ecc + 24,
   {E Internal error: Driver +P1 is already registered.

   dfe$mainframe_not_client = dfc$min_ecc + 25,
   {E Mainframe +P1 is not a Client.

   dfe$mainframe_not_server = dfc$min_ecc + 26,
   {E Mainframe +P1 is not a Server.

   dfe$client_active = dfc$min_ecc + 27,
   {E Client mainframe +P1 is already Active.

  dfe$server_active = dfc$min_ecc + 28,
  {E Server mainframe +P1 is already Active.

  dfe$client_not_active = dfc$min_ecc + 29,
  {E Client mainframe +P1 is not Active.

  dfe$server_not_active = dfc$min_ecc + 30,
  {E Server mainframe +P1 is not Active.

  dfe$client_not_deleteable = dfc$min_ecc + 31,
  {E Client mainframe +P1 is not deleteable. +P2

  dfe$server_not_deleteable = dfc$min_ecc + 32,
  {E Server mainframe +P1 is not deleteable. +P2

  dfe$server_already_defined = dfc$min_ecc + 33,
  {E Server mainframe +P1 is already defined.

  dfe$family_not_found = dfc$min_ecc+34,
  {E Internal Error: Family +P1 is not a served family.

  dfe$client_deactivated = dfc$min_ecc+35,
  {E Client +P1 is deactivating, you must wait for deactivation
  {  process to complete.

  dfe$server_deactivated = dfc$min_ecc+36,
  {E Server +P1 is deactivating, you must wait for deactivation
  {  process to complete.

  dfe$client_verification_error = dfc$min_ecc+37,
  {E Client +P1 verification error, +P2.

  dfe$server_verification_error = dfc$min_ecc+38,
  {E Server +P1 verification error, +P2.

  dfe$invalid_channel = dfc$min_ecc+39,
  {E The channel +P1 +P2 for mainframe +P3 is not listed in the element definition
  {  for element +P4.

  dfe$client_already_terminated = dfc$min_ecc+40,
  {E Client +P1 is already terminated.

   dfe$not_stornet_connection = dfc$min_ecc + 41,
   {E  Internal error: Connection +P1 is not an STORNET connection type.

   dfe$connection_not_changed = dfc$min_ecc + 42,
   {E Internal error: Connection +P1 must be deactivated before changing connection.

   dfe$invalid_stornet_product_id = dfc$min_ecc + 43,
   {E Either product number +P1 or model number +P2 is invalid for STORNET product identification.

   dfe$no_configured_channel = dfc$min_ecc + 44,
   {E No configured channel found in element definition for element +P1.

   dfe$no_configured_equipment = dfc$min_ecc + 45,
   {E Channel definition for +P1 has no configured equipment element +P2.

   dfe$server_has_terminated = dfc$min_ecc+46,
   {E Server +P1 has terminated.

   dfe$os_name_conflict = dfc$min_ecc+47,
   {W Server +P1 OS version "+P2" conflicts with Client's OS version "+P3".

   dfe$client_lifetime_error = dfc$min_ecc + 48,
   {E Client/Server -  +P1 - lifetime/birthdate mismatch, +P2.
   {+N3  Recovery not possible. Both client and server will be terminated and re-activated.

   dfe$element_still_reserved = dfc$min_ecc + 49,
   {E Mainframe +P1 cannot be deleted while element +P2 is still reserved.

   dfe$invalid_queue_entry_id  = dfc$min_ecc + 50,
   {E  Internal error: The remote procedure call queue entry location is invalid (+P1)
   { on the +P2 request.

   dfe$family_not_served  = dfc$min_ecc + 51,
   {E  Internal error: Family +P1 is not a served family.

   dfe$invalid_server_locator = dfc$min_ecc + 52,
   {E  Internal error: The server_location is invalid.+P1

   dfe$restart_server_request  = dfc$min_ecc + 53,
   {E internal: The remote procedure call request should be restarted.

   dfe$driver_error_occurred = dfc$min_ecc + 54,
   {E Internal error: An error (+P1) occurred in the file server driver.

   dfe$test_checksum_error  = dfc$min_ecc + 55,
   {E Internal error: A checksum error (+P1) occurred in the test code.

   dfe$data_length_error = dfc$min_ecc + 56,
   {E Internal error: Attempting to send more data than has been referenced.

   dfe$no_families_when_zero_nomqe = dfc$min_ecc + 57,
   {E A served family cannot be specified when the number of monitor queue entries
   { (specified on the DEFINE_SERVER subcommand) is zero.

   dfe$client_too_active_for_chaca = dfc$min_ecc + 58,
   {E CHANGE_CLIENT_ACCESS of an accessed family cannot be processed while
   { client +P1 is ACTIVE, ACTIVATING, or DEACTIVATED.

   dfe$max_families_or_clients = dfc$min_ecc + 59,
   {E The total number of of accessible +P1 (+P2) would exceed the
   { maximum (+P1) if CHANGE_CLIENT_ACCESS processed the given parameters.

   dfe$stornet_side_door_def_err = dfc$min_ecc + 60,
   {E Too many names specified for side_door_port parameter.

   dfe$send_channel_invalid_iou = dfc$min_ecc + 61,
   {E IOU name +P1 specified in SEND_CHANNEL parameter is invalid.

   dfe$too_many_low_speed_ports = dfc$min_ecc + 62,
   {E Internal error : STORNET element +P1 contains too many low_speed_ports.

   dfe$sfid_gfn_mismatch = dfc$min_ecc + 63,
   {E Internal error: Global_file_name on client does not match the
   { global_file_name on server for the remote system_file_id: +P1

   dfe$too_many_servers_or_clients = dfc$min_ecc + 64,
   {E Maximum mainframes for this connection has been reached and they
   { are all Servers or all Clients: definition for +P1 rejected.

   dfe$side_door_iou_name_err = dfc$min_ecc + 65,
   {E Specified STORNET side_door_port IOU name (+P1) is in error.

   dfe$stornet_already_defined = dfc$min_ecc + 66,
   {E STORNET element +P1 has already been defined.

   dfe$stornet_not_defined = dfc$min_ecc + 67,
   {E STORNET element +P1 has not been defined with Define_Stornet_Connection command.

   dfe$system_family_not_allowed = dfc$min_ecc + 68,
   {E System Family +P1 cannot be defined as Served Family.

   dfe$receive_channel_invalid_iou = dfc$min_ecc + 69,
   {E IOU name +P1 specified in RECEIVE_CHANNEL parameter is invalid.

   dfe$stornet_has_mainframes = dfc$min_ecc + 71,
   {E Client(s) and/or Server(s) are still defined with this
   { STORNET (+P1) connection.

   dfe$server_is_activating = dfc$min_ecc+72,
   {E Define_Served_Families cannot be issued while Server is Activating.

   dfe$incorrect_server_mainframe = dfc$min_ecc+73,
   {E Server Poll Reply contains incorrect mainframe, expected +P1,
   { received +P2.

   dfe$client_is_activating = dfc$min_ecc+75,
   {E The client mainframe is already activating.

   dfe$id_number_exceeds_nomf = dfc$min_ecc+76,
   {E +P1_ID_number of +P2 is greater than number_of_mainframes value of +P3.

   dfe$info_full = dfc$min_ecc+77,
   {E Internal Error:  Not enough room in the sequence to receive requested info.

   dfe$no_segment_reserved = dfc$min_ecc+78,
   {E Internal Error: Attempting to receive segment but none reserved on the server.

   dfe$task_not_established = dfc$min_ecc+79,
   {E Internal Error: Unable to establish +P task.

   dfe$force_server_recovery = dfc$min_ecc+80,
   {W The client mainframe +P1 is awaiting_recovery but the server is inactive.
   {+N3 Forcing the state on the server to awaiting_recovery and re-activating.

   dfe$job_needs_recovery  = dfc$min_ecc+81,
   {E Internal:  The job needs recovery for server +P1.

   dfe$client_mf_file_unrecovered = dfc$min_ecc+82,
   {E The client mainframe +P1 cannot be recovered +P2.

   dfe$server_request_terminated  = dfc$min_ecc+83,
   {E The +P1 request to server mainframe +P2 has been terminated due to a server failure.
   {+N3 It is unknown if the request was completed on the server mainframe.

   dfe$force_client_recovery = dfc$min_ecc+84,
   {W The client mainframe +P1 is inactive, but the server is awaiting_recovery.
   {+N3 Forcing the state on the client to awaiting_recovery and re-activating.

   dfe$no_space_for_server_pages = dfc$min_ecc+85,
   {E There was not enough disk space to write the pages for server +P1.
   { +N3 Please consider using the PREALLOCATE_IMAGE_SIZE parameter on DEFINE_SERVER.
   { +N3 +P2

   dfe$restart_server_task  = dfc$min_ecc+86,
   {E Internal: Automatically restarting the system task for server +P1.

   dfe$force_client_termination = dfc$min_ecc+87,
   {W The server mainframe is terminated but the client +P1 is not.
   {+N3 Issuing Terminate_server on the client +P1 and re-activating.

   dfe$force_server_termination = dfc$min_ecc+88,
   {W The client mainframe +P1 is terminated but the server is not.
   {+N3 Issuing Terminate_client on the server mainframe and re-activating.

   dfe$application_not_known = dfc$min_ecc+89,
   {E Application +P1 is not known.

   dfe$procedure_not_known = dfc$min_ecc+90,
   {E Procedure +P1 is not defined for application +P2.

   dfe$application_already_defined = dfc$min_ecc+91,
   {E Application +P1 has already been defined.

   dfe$procedure_already_defined = dfc$min_ecc+92,
   {E Procedure +P1 has already been defined for application +P2.

   dfe$callers_variable_too_large = dfc$min_ecc+93,
   {E +P1 callers +P2 variable is larger than the maximum +P3.

   dfe$callers_variable_too_small = dfc$min_ecc+94,
   {E +P1 callers +P2 variable is smaller than the returned size of +P3.

   dfe$client_terminate_break= dfc$min_ecc+95,
   {E Remote procedure +P1 has received a terminate-break issued by caller on client.

   dfe$remote_proc_load_failure = dfc$min_ecc+96,
   {E Remote procedure +P1 cannot be executed due to a problem encountered while loading.

   dfe$invalid_parameter_pva = dfc$min_ecc+97,
   {E Parameter +P1 for procedure +P2 specifies an invalid PVA.

   dfe$invalid_state_for_def_app = dfc$min_ecc+98,
   {E Subcommand +P1 can be executed only when the state of the partner
   { mainframe +P2 is TERMINATED or AWAITING RECOVERY.

   dfe$no_partner_mainframe = dfc$min_ecc+99,
   {E There is no partner mainframe associated with the caller of +P1.

   dfe$scp_par_requires_lib_par = dfc$min_ecc+100,
   {E A value for the LIBRARY parameter is required if the
   { STATE_CHANGE_PROCEDURE parameter is specified.

   dfe$max_remote_proc_count = dfc$min_ecc+101,
   {E Maximum remote procedure count of +P1 exceeded.

   dfe$max_application_count = dfc$min_ecc+102,
   {E Maximum application count of +P1 exceeded.

   dfe$out_of_range_value = dfc$min_ecc+103,
   {E The value of parameter +P1 +P2 is +P3 which is outside the
   { limits of +P4 to +P5.

   dfe$client_pause_break= dfc$min_ecc+104,
   {E Remote procedure +P1 has received a pause-break issued by caller on client.

   dfe$task_services_timeout = dfc$min_ecc+105,
   {E The mainframe +P1 is blocking a request to a queue a task services request
   { and is being timed out.

   dfe$stornet_channel_mismatch = dfc$min_ecc + 106,
   {E The +P1 channel specified does not match the corresponding channel
   { specified on previously entered DEFINE commands for this STORNET element.

   dfc$null_parameter = '',

   dfc$min_driver_test_errors = dfc$min_ecc + 200,

   dfe$test_startup_error = dfc$min_ecc + 333,
   {E Internal: Test error "+P1"

   dfc$min_cdcnet_errors = dfc$min_ecc + 400,

   dfc$min_mm_recovery_errors = dfc$min_ecc + 600;

*copyc dfe$cdcnet_errors
*copyc dfe$driver_test_errors
*copyc dfe$mm_recovery_errors
*DECK DECK=DFE$MM_RECOVERY_ERRORS EXPAND=FALSE

  CONST
    dfe$server_pages_not_deleted = dfc$min_mm_recovery_errors + 1,
    {E Internal:  A number of pages were not flushed/deleted when a server file
    { was deleted or terminated.

    dfe$server_file_not_deactivated = dfc$min_mm_recovery_errors + 2,
    {E Internal:  +P1 server files were not deactivated.

    dfe$server_file_not_terminated = dfc$min_mm_recovery_errors + 3;
    {E Internal: +P1 server files were not terminated.

*copyc dfe$error_condition_codes
*DECK DECK=DFH$ASSIGN_QUEUE_ENTRY EXPAND=FALSE
{
{  This procedure locates an available  queue entry in the specified
{ queue, sets the active_entry flag to indicate entry is assigned, and returns
{ to queue_entry_index to the caller.
{
{      DFP$ASSIGN_QUEUE_ENTRY (P_QUEUE_INTERFACE_TABLE, QUEUE_INDEX,
{        QUEUE_ENTRY_TYPE, QUEUE_ENTRY_INDEX, ASSIGN_STATUS)
{
{  P_QUEUE_INTERFACE_TABLE: (input) This parameter specifies the
{       queue interface table that points  to the queue specified by queue_index
{                                     .
{  QUEUE_INDEX: (input) This parameter specifies the queue for which an entry
{       is to be assigned.
{
{  QUEUE_ENTRY_TYPE: (input) This parameter specifies the type of the queue
{       entry that is to be assigned. This may be dfc$monitor, dfc$task_services
{
{  QUEUE_ENTRY_INDEX: (output) This parameter returns the queue entry index
{       assigned.  This is only valid is assign_status = dfc$aqes_entry_assigned.
{
{  ASSIGN_STATUS: (output) This parameter returns the status of the request.
{       dfc$aqes_invalid_queue_index - The caller passed an invalid index.
{       dfc$aqes_no_available_entries - There are no available entries, the
{          caller is responsible for waiting and retrying the request.
{       dfc$aqes_entry_assigned - The queue_entry_index returned has been assigned.
{
*DECK DECK=DFH$BEGIN_CH_REMOTE_PROC_CALL EXPAND=FALSE
{
{   The purpose of this request is to provide a condition handling mechanism for
{ unexpected statuses during task_services File Server and then call a procedure
{ to initiate the process by which the client mainframe calls a request on the
{ server mainframe.
{
{ NOTE: This is the preferred method of beginning remote procedure calls on the
{ client mainframe.  The original procedure dfp$begin_remote_procedure_call can
{ still be used, but the application using the interfacee MUST be 'well-behaved',
{ i.e. must not encounter any unexpected conditions.
{
{    DFP$BEGIN_CH_REMOTE_PROCEDURE_CALL (SERVER_LOCATION,
{        ALLOWED_WHEN_SERVER_DEACTIVATED, QUEUE_ENTRY_LOCATION,
{        P_SEND_TO_SERVER_PARAMS, P_SEND_DATA_AREA, STATUS)
{
{ server_location: dft$server_location
{   family_name XOR mainframe_id  XOR served_family_table_index
{      This parameter identifies the  server mainframe to send the request to.
{      If the family_name is specified then the family must be a server
{      family, or an error will be returned.  If the mainframe_id is specified
{      it must be a mainframe already established with a DEFINE_SERVER
{      subcommand of the MANAGE_FILE_SERVER utility.
{      Usage of served_family_table_index is not allowed by applications.
{
{ allowed_when_server_deactivated
{      This parameter indicates whether the request should be honored even
{      when the server is in a deactivated state.  The server is in a deactivated
{      state as a result of a DEACTIVATE_SERVER request on the client, or a
{      DEACTIVATE_CLIENT request on the server.   The only requests that
{      should specify this as TRUE, are those requests involved with the orderly
{      deactivation of the server.  This request will always return an error when
{      the server is in a inactivate, deleted, or terminated state.
{
{      Callers may desire to wait in a higher ring using the procedure
{      osp$wait_on_condition if the server is unavailable.  They may
{      also need to establish a condition handler to allow user to terminate or
{      pause break out of a request waiting for a down server.  If the server
{      becomes deactivated after this request is complete, the subsequent
{      dfp$send_remote_procedure_call request will be allowed to complete.
{      If the server is in an inactive state, or in an awaiting_recovery state
{      the status condition of dfe$server_not_active is returned. If the caller
{      needs to send requests in the recovering state, then the variable
{      dfv$recovery_task must be set to true.  For applications the
{      applications state change procedure is allowed to send requests in the
{      recovering state without setting the variable dfv$recovery_task.
{
{ VAR queue_entry_location: dft$rpc_queue_entry_location
{      This returns the identifier that may be passed to
{      dfp$send_remote_procedure_call and dfp$end_remote_procedure_call to
{      identify the request.  This identifier may not be passed to another job or
{      another task within the same job.
{
{ VAR p_send_to_server_params:   dft$p_user_command_buffer
{     Parameters sent to server
{     Caller responsible for NEXTing in any parameters sent to server.
{
{ VAR p_send_data_area: dft$p_data_area
{     This parameter returns a pointer to a data area that may be used to send
{     data that is too large to fit into the areas provided by the send parameter
{     area.  If the data is to large to fit into this area, the caller must use a
{     served permanent file.
{
{ VAR status: ost$status
{     Conditions
{         dfe$mainframe_not_server
{         dfe$family_not_served
{         dfe$invalid_served_family_index
{         dfe$server_has_terminated
{         dfe$server_not_active
{         dfe$server_has_terminated
*DECK DECK=DFH$BEGIN_REMOTE_PROCEDURE_CALL EXPAND=FALSE
{
{   The purpose of this request is to initiate the process by which the client
{ mainframe calls a request on the server mainframe.   This request reserves
{ a queue entry, and initializes the wired memory areas used for
{ communication between the client and server.   The actual call to the server
{ is made as a result of the dfp$send_remote_procedure_call request or by
{ an application by using dfp$send_application_rpc. Multiple occurrences of
{ dfp$send_remote_procedure_call or dfp$send_application_rpc may be made after
{ a single call to dfp$begin_remote_procedure_call,  however   between the
{ time of the dfp$begin_remote_procedure_call and
{ dfp$end_remote_procedure_call requests, the server is not allowed to go
{ idle (as a result of the DEACTIVATE_SERVER request) and the job will not be
{ recovered following a system failure, so this window should be kept as
{ small as possible.
{
{    DFP$BEGIN_REMOTE_PROCEDURE_CALL (SERVER_LOCATION,
{        ALLOWED_WHEN_SERVER_DEACTIVATED, QUEUE_ENTRY_LOCATION,
{        P_SEND_TO_SERVER_PARAMS, P_SEND_DATA_AREA, STATUS)
{
{ server_location: dft$server_location
{   family_name XOR mainframe_id  XOR served_family_table_index
{      This parameter identifies the  server mainframe to send the request to.
{      If the family_name is specified then the family must be a server
{      family, or an error will be returned.  If the mainframe_id is specified
{      it must be a mainframe already established with a DEFINE_SERVER
{      subcommand of the MANAGE_FILE_SERVER utility.
{      Usage of served_family_table_index is not allowed by applications.
{
{ allowed_when_server_deactivated
{      This parameter indicates whether the request should be honored even
{      when the server is in a deactivated state.  The server is in a deactivated
{      state as a result of a DEACTIVATE_SERVER request on the client, or a
{      DEACTIVATE_CLIENT request on the server.   The only requests that
{      should specify this as TRUE, are those requests involved with the orderly
{      deactivation of the server.  This request will always return an error when
{      the server is in a inactivate, deleted, or terminated state.
{
{      Callers may desire to wait in a higher ring using the procedure
{      osp$wait_on_condition if the server is unavailable.  They may
{      also need to establish a condition handler to allow user to terminate or
{      pause break out of a request waiting for a down server.  If the server
{      becomes deactivated after this request is complete, the subsequent
{      dfp$send_remote_procedure_call request will be allowed to complete.
{      If the server is in an inactive state, or in an awaiting_recovery state
{      the status condition of dfe$server_not_active is returned. If the caller
{      needs to send requests in the recovering state, then the variable
{      dfv$recovery_task must be set to true.  For applications the
{      applications state change procedure is allowed to send requests in the
{      recovering state without setting the variable dfv$recovery_task.
{
{ VAR queue_entry_location: dft$rpc_queue_entry_location
{      This returns the identifier that may be passed to
{      dfp$send_remote_procedure_call and dfp$end_remote_procedure_call to
{      identify the request.  This identifier may not be passed to another job or
{      another task within the same job.
{
{ VAR p_send_to_server_params:   dft$p_user_command_buffer
{     Parameters sent to server
{     Caller responsible for NEXTing in any parameters sent to server.
{
{ VAR p_send_data_area: dft$p_data_area
{     This parameter returns a pointer to a data area that may be used to send
{     data that is too large to fit into the areas provided by the send parameter
{     area.  If the data is to large to fit into this area, the caller must use a
{     served permanent file.
{
{ VAR status: ost$status
{     Conditions
{         dfe$mainframe_not_server
{         dfe$family_not_served
{         dfe$invalid_served_family_index
{         dfe$server_has_terminated
{         dfe$server_not_active
{         dfe$server_has_terminated
*DECK DECK=DFH$CALL_REMOTE_PROCEDURE EXPAND=FALSE
{
{    The purpose of this request is to "call" an application procedure on a
{ remote (server) mainframe.  The procedure must have been defined by execution
{ of the command DEFINE_APPLICATION_RPC on the remote mainframe.
{
{       DFP$CALL_REMOTE_PROCEDURE (SERVER_LOCATION, APPLICATION_NAME,
{             PROCEDURE_NAME, SEND_PARAMETERS, SEND_DATA,
{             RECEIVE_PARAMETERS_SIZE, RECEIVE_PARAMETERS, RECEIVE_DATA_SIZE,
{             RECEIVE_DATA, STATUS)
{
{ SERVER_LOCATION: (input)  This parameter specifies either the family or the
{       mainframe name where the remote procedure will be called.  This
{       parameter is a variant record and must contain the variant identifier
{       of dfc$family_name or dfc$mainframe_id.
{
{ APPLICATION_NAME: (input)  This parameter specifies the name of the
{       application associated with the remote procedure as specified on the
{       DEFINE_APPLICATION_RPC command.
{
{ PROCEDURE_NAME: (input)  This parameter specifies the name of the procedure
{       to be called.
{
{ SEND_PARAMETERS: (input)  This parameter specifies the Cybil sequence
{       containing the input parameters to the remote procedure.  The entire
{       sequence will be transferred to the remote procedure. The size of the
{       specified sequence may not exceed the dfc$maximum_user_buffer_area
{       value (currently 3600 bytes).  This parameter may be NIL.
{
{ SEND_DATA: (input)  This parameter specifies the Cybil sequence containing
{       the input data to the remote procedure.  The entire sequence will be
{       transferred to the remote procedure.  This sequence is set by the user
{       only if the amount of data to be sent to the remote procedure exceeds
{       the maximun allowed of the send_parameters sequence. The size of the
{       specified sequence may not exceed the dfc$maximum_user_data_area value
{       value (currently 524288 bytes).  This parameter may be NIL.
{
{ RECEIVE_PARAMETERS_SIZE: (output)  This parameter specifies the size of the
{       receive parameters sequence returned from the remote procedure.
{
{ RECEIVE_PARAMETERS: (input, output)  This parameter specifies the sequence
{       where the output parameters from the remote procedure are to be stored.
{       If the size of the output parameters sequence returned from the remote
{       procedure is larger than the size of this specified sequence, an error
{       status will be generated and none of the output parameters will be
{       returned to the caller.  In case of such an error status, the value of
{       the RECEIVE_PARAMETERS_SIZE will still specify the size of the receive
{       parameters returned from the remote procedure.
{
{ RECEIVE_DATA_SIZE: (output)  This parameter specifies the size of the receive
{       data sequence returned from the remote procedure.
{
{ RECEIVE_DATA: (input, output)  This parameter specifies the sequence where
{       the output data from the remote procedure are to be stored.  If the
{       size of the output data sequence returned from the remote procedure is
{       larger than the size of this specified sequence, an error status will
{       be generated and none of the output data will be returned to the
{       caller.  In case of such an error status, the value of the
{       RECEIVE_DATA_SIZE will still specify the size of the receive data
{       returned from the remote procedure.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             dfe$callers_variable_too_large
{             dfe$callers_variable_too_small
{             dfe$family_not_served
{             dfe$invalid_parameter_pva
{             dfe$invalid_server_locator
{             dfe$job_needs_recovery
{             dfe$mainframe_not_server
{             dfe$procedure_not_known
{             dfe$server_has_terminated
{             dfe$server_not_active
{             pme$insufficient_privilege
*DECK DECK=DFH$CHECK_JOB_RECOVERY EXPAND=FALSE
{
{    This procedure attempts to perform server job recovery on any servers that
{ it can and that need recovery.
{
{    As a result of this call any server mainframe that the job was using, that
{ is now active will perform server job recovery.  As a result of this, the
{ lifetime of the job and all the files that the job has attached on the server
{ will have their lifetime advanced.
{
{    Any server mainframe that the job was using that is still awaiting
{ recovery will remain unaffected.
{
{    This routine should only be called from a 'safe' place, that is the cycle
{ description table must be readable, the system file table readable, and the
{ job capable of performing remote procedure call requests to the server.
{
{       DFP$CHECK_JOB_RECOVERY (RECOVERY_OCCURRED)
{
{  RECOVERY_OCCURRED: (output)  This parameter returns whether server job
{        recovery was performed on ANY server mainframe.
{
*DECK DECK=DFH$CHECK_JOB_SERVER EXPAND=FALSE
{
{   The purpose of this request is to determine if the calling job has accessed
{ the specified server mainframe previously, and to return the client job
{ identifier that is used to designate the job on the server machine.  If the
{ job has not previously used the server, a request to the server is sent
{ which will connect this job to the server. A previous call to
{ dfp$begin_remote_procedure_call must have been made prior to calling this
{ procedure.  This previous call is required so that it only takes one
{ one queue entry to complete a given request rather than two.  If two were
{ required it would be possible to deadlock - that is two requests have
{ one queue entry assigned, and reqire another one, but no more are available.
{ This routine assumes the caller has inhibited job recovery during this
{ call.
{
{   DFP$CHECK_JOB_SERVER (QUEUE_ENTRY_LOCATION, USER_PARAMETER_LENGTH,
{         JOB_RECOVERY_REQUEST, FORCE_JOB_RECONNECTION,
{         CLIENT_JOB_ID, STATUS)
{
{  QUEUE_ENTRY_LOCATION: (input) This parameter specifies the location of the
{      queue entry already reserved by the caller.
{
{  USER_PARAMETER_LENGTH: (input) This parameter indicates whether information
{      has already been placed into the send parameter area, prior to calling
{      this routine.  If no paramters have been entered 0 should be used. If
{      parameters have already been placed in the send parameter area, this
{      routine will copy the parameters to a holding area, and re-use the
{      the same parameter area, upon completion of this request the user
{      parameters are restored.
{
{  JOB_RECOVERY_REQUEST: (input) This parameter indicates whether request
{      is a request used by job recovery.  If the request is a job recovery
{      request the lifetime of the job is not checked, and the request is
{      set directly to the server.  If the request is NOT a job recovery
{      request, then the lifetime of the job is checked to determine if the
{      job needs recovery.
{
{  FORCE_JOB_RECONNECTION: (input) This parameter indicates whether connection
{      to the server should be forced to be a new connection.  If this is
{      specified as TRUE then job recovery is not attempted, and the lifetime
{      of the job is not checked.  If this is TRUE and the job is already
{      registered on the server mainframe, the old lifetime on the server is
{      removed, and a new lifetime established.
{
{  CLIENT_JOB_ID: (output) This parameter returns the identification of the job
{      on the server. This msut be passed to the server on all subsequent file
{      requests.
{
{  STATUS: (output) This parameter returns the request status.
{
*DECK DECK=DFH$CREATE_QUEUE EXPAND=FALSE
{
{    The purpose of this procedure is to create both the driver queue, and
{ cpu queue.  All queue entries are initialized.
{    If required the queue_interface_table will also be created, and an entry
{ made into the queue interface directory. The p_queue_interface_table
{ will not be stored in the logical unit table (for esm) until the
{ dfp$store_p_qit request is processed.
{    All tables are allocated in the server wired heap.
{ This request may be used on either the client or the server side.
{
{   DFP$CREATE_QUEUE (CONNECTION_PARAMETERS, DESTINATION_MAINFRAME_NAME, DESTINATION_MAINFRAME_ID,
{      SERVER_TO_CLIENT, P_QUEUE_INTERFACE_TABLE, STATUS)
{
{   CONNECTION_PARAMETERS: (input) This parameter specifies all connection
{      associated parameters.  The driver must be specified in this parameter.
{      Verification of queue index will occur in this request, but verification
{      of esm parameters should be done outside the request.
{
{   DESTINATION_MAINFRAME_NAME: (input) This parameter specifies the
{      mainframe id of the destination machine.
{
{   DESTINATION_MAINFRAME_ID: (input) This parameter specifies the binary
{      mainframe id of the destination machine.
{
{   SERVER_TO_CLIENT: (input) This parameter specifies whether the queue is
{     a server to client queue (TRUE) or client to server queue (FALSE).
{
{   P_QUEUE_INTERFACE_TABLE: (output) This parameter returns the pointer to
{     the queue interface table.
{
{   STATUS: (output) This parameter returns the request status.
{
*DECK DECK=DFH$DELETE_CLIENT_RPC_SEGMENT EXPAND=FALSE
{
{    This procedure deletes the client rpc segment if one exists.  This allows
{ freeing extra pages associated with the segment.  The segment was sent from
{ the client by the DFP$SEND_CLIENT_RPC_SEGMENT request.  The server request
{ then used DFP$RECEIVE_CLIENT_RPC_SEGMENT to obtain a pointer to the segment.
{ When done reading the segment the server request should use
{ DFP$DELETE_CLIENT_RPC_SEGMENT to remove the segment.
{
{    DFP$DELETE_CLIENT_RPC_SEGMENT
{
*DECK DECK=DFH$END_CH_REMOTE_PROC_CALL EXPAND=FALSE
{
{  The purpose of this request is to disestablish the condition handler and
{ release resources originally reserved by the dfp$begin_ch_remote_proc_call
{ request.
{
{ NOTE: This is the preferred method of beginning remote procedure calls on the
{ client mainframe.  The original procedure dfp$end_remote_procedure_call can
{ still be used, but the application using the interfacee MUST be 'well-behaved',
{ i.e. must not encounter any unexpected conditions.
{
{     DFP$END_CH_REMOTE_PROC_CALL (QUEUE_ENTRY_LOCATION, STATUS)
{
{   queue_entry_location: (input) This parameter specifies the value of the
{      queue_entry_location returned on the dfp$begin_remote_procedure_call
{      procedure.
{
{   VAR status: (output) This parameter returns the request status.
{       Conditions
{           dfe$invalid_queue_entry_id
{           dfe$server_has_terminated
{           dfe$server_not_active
{
*DECK DECK=DFH$END_REMOTE_PROCEDURE_CALL EXPAND=FALSE
{
{  The purpose of this request is to release resources originally reserved by
{ the dfp$begin_remote_procedure_call
{ request.  The queue entry is released, and any pages assigned as a result of
{ the procedure calls will be freed.   If this is the last outstanding request
{ and the server is deactivating, then the server will be considered 'idle' as a
{ result of this request.
{
{     DFP$END_REMOTE_PROCEDURE_CALL (QUEUE_ENTRY_LOCATION, STATUS)
{
{   queue_entry_location: (input) This parameter specifies the value of the
{      queue_entry_location returned on the dfp$begin_remote_procedure_call
{      procedure.
{
{   VAR status: (output) This parameter returns the request status.
{       Conditions
{           dfe$invalid_queue_entry_id
{           dfe$server_has_terminated
{           dfe$server_not_active
{
*DECK DECK=DFH$FETCH_SERVED_FAMILY_INFO EXPAND=FALSE
{   The purpose of this request is to fetch the information associated with a
{ served family, given a served family table index.
{
{    DFP$FETCH_SERVED_FAMILY_INFO (SERVED_FAMILY_TABLE_INDEX, FAMILY,
{       SERVER_MAINFRAME_ID, P_QUEUE_INTERFACE_TABLE, QUEUE_INDEX,
{       INDEX_VALID)
{
{  SERVED_FAMILY_TABLE_INDEX: (input) This parameters specifes the index
{    the served family table .
{
{  FAMILY: (output) This parameter returns the family name associated with
{    the served family table index.
{
{  SERVER_MAINFRAME_ID: (output) This parameter returns the server mainframe
{    on which the family resides.
{
{  P_QUEUE_INTERFACE_TABLE
{  QUEUE_INDEX: (output) These parameters specify
{   the queue for the server mainframe.
{
{  INDEX_VALID (output) This parameter returns  whether the specified index is
{    valid.  If this is FALSE all other output parameters are undefined.
{

*DECK DECK=DFH$FIND_MAINFRAME_ID EXPAND=TRUE
{
{   The purpose of this request is to find the queue for the specified
{ mainframe.  The requestor specifies whether the specified mainframe is
{ expected to describe a server_to_client connection.  The mainframe is
{ found if the mainframe is in any state but deleted.
{
{  DFP$FIND_MAINFRAME_ID (MAINFRAME_ID, SERVER_TO_CLIENT, MAINFRAME_FOUND,
{     P_QUEUE_INTERFACE_TABLE, P_CPU_QUEUE, QUEUE_INDEX,
{     P_Q_INTERFACE_DIRECTORY_ENTRY)
{
{  MAINFRAME_ID: (input) This parameter specifies the name of the mainframe
{     to search for.
{
{  SERVER_TO_CLIENT: (input)  This parameter specifies whether the specified
{     mainframe is expected to be a server_to_client (TRUE) connection or
{     a client_to_server (FALSE) connection.  Specifying TRUE will NOT
{     find the queue defined for the client_to_server connection.
{
{  MAINFRAME_FOUND: (output) This parameter returns whether the specified
{     mainframe was found with the correct connection type (SERVER_TO_CLIENT).
{     If this is FALSE the remaining parameters are undefinied.
{
{  P_QUEUE_INTERFACE_TABLE: (output) This parameter returns the pointer to the
{     queue interface table in which this mainframe was found.
{
{  P_CPU_QUEUE: (output) This parameter returns the pointer to the
{    cpu queue for the found mainframe.
{
{  QUEUE_INDEX: (output) This parameter returns the index into the queue
{    interface table for this mainframe.
{
{  P_Q_INTERFACE_DIRECTORY_ENTRY: (output) This parameter returns the pointer to the
{     the entry in the queue interface directory for this queue interface
{     table.
{
*DECK DECK=DFH$GET_APPLICATION_INFO EXPAND=FALSE
{
{    The purpose of this procedure is to obtain the information associated with
{ an application defined with either DEFINE_APPLICATION_RPC or
{ DEFINE_CLIENT_APPLICATION_RPC.  This routine is only available from ring 3.
{ Currently the only information particular to an application is the sequence
{ pointer defined on the DEFINE_APPLICATION_RPC or
{ DEFINE_CLIENT_APPLICATION_RPC manage_file_server subcommands.  If the
{ application has not been defined an error will be returned.
{
{       DFP$GET_APPLICATION_INFO (PARTNER_MAINFRAME_ID, PARTNER_IS_SERVER,
{             APPLICATION_NAME, P_SEQUENCE, STATUS)
{
{ PARTNER_MAINFRAME_ID: (input)  This parameter specifies the name of the
{       mainframe for which information is to be obtained.
{
{ PARTNER_IS_SERVER: (input)  This parameter specifies whether the partner
{       mainframe is a server or a client mainframe.  If TRUE is specified then
{       the information about the server mainframe is return.  This is the
{       information specified on the DEFINE_CLIENT_APPLICATION_RPC subcommand
{       is returned.  If the mainframe is not defined as a server then an error
{       status is returned.  If FALSE is specified then the information about
{       the client mainframe is return.  This is the information specified on
{       the DEFINE_APPLICATION_RPC subcommand is returned.  If the mainframe is
{       not defined as a client then an error status is returned.
{
{  APPLICATION_NAME: (input)  This parameter specifies name of application for
{        which information is desired.
{
{  P_SEQUENCE: (output)  This parameter returns the defined applications area
{        in server wired memory.  If none was defined, NIL will be returned.
{
{  STATUS: (output) This parameter returns the request status.
{        CONDITIONS:
{              dfe$application_not_known
{              dfe$mainframe_not_client
{              dfe$mainframe_not_server
{
*DECK DECK=DFH$GET_FAMILY_ACCESS EXPAND=FALSE
{
{    The purpose of this request is to return the family access value and
{ and associated information for the specified family.
{
{       DFP$GET_FAMILY_ACCESS (FAMILY, FAMILY_KNOWN, FAMILY_ACCESS,
{             SERVER_STATE, LEVELER_STATUS)
{
{ FAMILY: (input) This parameter specifies the name of the family of interest.
{
{ FAMILY_KNOWN: (output) This parameter specifies whether the family is known
{       to any server mainframe or to the host mainframe. If the value of this
{       parameter is returned as FALSE, then the remaining output parameters
{       are undefined.
{
{ FAMILY_ACCESS: (output) This parameter returns the access of the family. Note
{       that it may indicate a non-served family (that is, "local") by means of
{       returning an empty set in which case the remaining output paramters are
{       undefined.
{
{ SERVER_STATE: (output) This parameter describes the state of the server
{       mainframe on which the family resides.
{
{ LEVELER_STATUS: (output) This parameter specifies the job leveler status of
{       the server mainframe on which the family resides.
{
*DECK DECK=DFH$GET_FAMILY_LIST EXPAND=FALSE
{
{    The purpose of this procedure is to return information about all families
{ that are known on this mainframe.  The families will be all the families
{ residing on the local mainframe, as well as all served families.  If the
{ input array in too small the error pme$result_array_too_small is returned but
{ the value of NUMBER_OF_FAMILIES will indicate the actual number of families.
{
{       DFP$GET_FAMILY_LIST (FAMILY_INFO_LIST, NUMBER_OF_FAMILIES, STATUS)
{
{ FAMILY_INFO_LIST: (output)  This parameter returns the array of information
{       about the families.
{
{ NUMBER_OF_FAMILIES: (output)  This parameter returns the actual number of
{       families known.  If NUMBER_OF_FAMILIES > UPPERBOUND(FAMILY_INFO_LIST)
{       THEN only as many families as fit in the FAMILY_INFO_LIST will be
{       returned.  If NUMBER_OF_FAMILIES < UPPERBOUND(FAMILY_INFO_LIST) then
{       only NUMBER_OF_FAMILIES will be returned.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS:
{             pme$result_array_too_small
{
*DECK DECK=DFH$GET_FAMILY_STATUS EXPAND=FALSE
{
{    The purpose of this procedure is to obtain information on the location of
{ a particular family.  Information is returned about whether the family
{ resides on the local mainframe or resides on a server mainframe.  If the
{ familiy is a local family the information includes the set_name that the
{ family resides on.  If the family is a served family the information contains
{ the mainframe name of the server mainframe as well as the state of the
{ server.
{
{       DFP$GET_FAMILY_STATUS (FAMILY_NAME, FAMILY_STATE, STATUS)
{
{  FAMILY_NAME: (input)  This parameter specifies the family for which
{        information is requested.
{
{  FAMILY_STATE: (output)  This parameter returns infromation about the
{        location of the family.
{
{  STATUS: (output) This parameter returns the request status.
{      CONDITIONS:
{          pfe$bad_family_name
{          pfe$unknown_family
{
*DECK DECK=DFH$GET_MAINFRAME_LIST EXPAND=FALSE
{
{    The purpose of this request is to return a list of mainframes which are
{ acting as partners to the host mainframe and the state of each.
{
{       DFP$GET_MAINFRAME_LIST (PARTNERS_ARE_SERVERS, PARTNER_MAINFRAMES,
{             PARTNER_COUNT)
{
{ PARTNERS_ARE_SERVERS: (input)  This parameter specifies whether the partner
{       mainframes of interest are servers (value specified as TRUE) or clients
{       (value specified as FALSE).
{
{ PARTNER_MAINFRAMES: (output)  This parameter specifies an array of mainframe
{       entries to be be set by this request.  If the dimension of this array
{       is smaller than the number of partner mainframes, the array will be set
{       to its maximum dimension.  The value of the partner_count parameter
{       returned will always be the total number of partner mainframes which
{       satisfy the partners_are_servers criterion.
{
{ PARTNER_COUNT: (output)  This parameter specifies the number of mainframes
{       found which satisfy the partners_are_servers parameter.  This value
{       could be greater than the dimension of the partner_mainframes parameter
{       array.
*DECK DECK=DFH$GET_MAINFRAME_STATUS EXPAND=FALSE
{
{    The purpose of this request is to return information about a particular
{ partner mainframe in a file server configuration.
{
{       DFP$GET_MAINFRAME_STATUS (PARTNER_MAINFRAME_ID, PARTNER_IS_SERVER,
{             SERVER_STATE, STATUS)
{
{ PARTNER_MAINFRAME_ID: (input)  This parameter specifies the mainframe id of
{       the mainframe for which information is to be obtained.
{
{ PARTNER_IS_SERVER: (input)  This parameter specifies whether the partner
{       mainframe of interest is a server (value specified as TRUE) or client
{       (value specified as FALSE).
{
{ SERVER_STATE: (output)  This parameter returns the state of the file server
{       connection.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS:
{             dfe$mainframe_not_server
{             dfe$mainframe_not_client

*DECK DECK=DFH$GET_PARTNER_MAINFRAMES EXPAND=FALSE
{
{    The purpose of this request is to return a list of mainframes which
{ are acting as partners to the host mainframe and the state of each. The
{ "mainframe" specified by dfc$loopback_server_mainframe will be ignored by
{ the processing of this request.
{
{       DFP$GET_PARTNER_MAINFRAMES (PARTNERS_ARE_SERVERS,
{             P_PARTNER_MAINFRAMES, PARTNER_COUNT)
{
{ PARTNERS_ARE_SERVERS: (input) This parameter specifies whether the partner
{       mainframes of interest are servers or clients.
{
{ P_PARTNER_MAINFRAMES: (output) This parameter specifies a pointer to the
{       array of mainframes to be be set by this request. If the value of
{       this parameter is NIL, only the partner_count is returned.
{
{ PARTNER_COUNT: (output) This parameter specifies the number of mainframes
{       found which satisfy the partners_are_servers parameter. This value
{       could be greater than the upper bound of the p_partner_mainframes
{       parameter.
{
*DECK DECK=DFH$GET_PARTNER_QUEUES EXPAND=FALSE
{
{    The purpose of this request is to return a list of pointers to both driver
{ and cpu queues of the mainframes which are acting as partners to the host
{ mainframe and a count of the number of list entries returned.
{
{       DFP$GET_PARTNER_QUEUES (P_PARTNER_QUEUES, PARTNER_QUEUE_COUNT)
{
{ P_PARTNER_QUEUES: (output^)  This parameter specifies a pointer to the array
{       of queue pointers to be set by this request.  If the pointer is NIL
{       only partner_queue_count is returned.
{
{ PARTNER_QUEUE_COUNT: (output)  This parameter specifies the number of
{       mainframes found.  The value returned may be greater that the number of
{       entries provided for in the array.
{
*DECK DECK=DFH$GET_RPC_ATTACHED_FILES EXPAND=FALSE
{
{ NOTE: Implementation of this request has been DEFERRED.
{
{    The purpose of this request is to transfer to the caller information
{ concerning the files attached as a result of the execution of the command
{ DEFINE_APPLICATION_RPC.  This request is executed only on a server mainframe
{ and the information returned applies only to that mainframe.
{
{       DFP$GET_RPC_ATTACHED_FILES (APPLICATION_NAME, ATTACHED_FILE_POINTERS,
{             ATTACHED_FILE_NAMES, NUMBER_OF_ATTACHED_FILES, STATUS)
{
{ APPLICATION_NAME: (input)  This parameter specifies the name of the
{       application of interest.
{
{ ATTACHED_FILE_POINTERS: (output)  This parameter specifies an array of
{       pointers to be set by this request.  If the size of this array is
{       smaller than the number of defined attached files for the application,
{       no information will be returned to the array and the status condition
{       dfe$callers_variable too small will be returned.
{
{ ATTACHED_FILE_NAMES: ( output) This parameter specifies an array of path
{       names to be set by this request.  If the size of this array is smaller
{       than the number of defined attached files for the application, no
{       information will be returned to the array and the status condition
{       dfe$callers_variable too small will be returned.
{
{ NUMBER_OF_ATTACHED_FILES: (output)  This parameter specifies the number of
{       attached files as defined by the define_application_rpc command.
{
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             dfe$application_not_known
{             dfe$callers_variable_too_small
*DECK DECK=DFH$GET_SERVED_FAMILY_NAMES EXPAND=FALSE
{
{    The purpose of this request is to retrieve a list of all family names that
{  exist on a server mainframe. Families are returned even if the server is
{  in a terminated, inactive or deactivating state.
{
{        DFP$GET_SERVED_FAMILY_NAMES (FAMILY_NAMES, NAME_COUNT, STATUS);
{
{ FAMILY_NAME: (output) This is the array of family names.
{
{ NAME_COUNT: (output) This is the number of families that exist on the system.
{
{ STATUS: (output) This is the status of the request.
{      CONDITION: pme$result_array_too_small
{

*DECK DECK=DFH$LOCATE_SERVED_FAMILY EXPAND=FALSE
{    This procedure determines if the specified family is a served family,
{ that is, a family for which access to a server mainframe is required.
{
{    DFP$LOCATE_SERVED_FAMILY (FAMILY, FAMILY_FOUND, SERVED_FAMILY_TABLE_INDEX,
{       SERVER_MAINFRAME_ID, P_QUEUE_INTERFACE_TABLE, QUEUE_INDEX)
{
{  FAMILY: (input) This parameter specifies the name of the family to locate.
{    This is assumed to be capatalized.
{
{  FAMILY_FOUND: (output) This parameter returns whether the family is a served
{    family.  The following parameters are only valid if this is TRUE.
{
{  SERVED_FAMILY_TABLE_INDEX: (output) This parameters returns the index
{    into the served family table. This may later be used to obtain information
{    about the server mainframe.
{
{  SERVER_MAINFRAME_ID: (output) This parameter returns the server mainframe
{    on which the family resides.
{
{  P_QUEUE_INTERFACE_TABLE: (output)
{  QUEUE_INDEX: (output)             These parameters specify the queue
{    for the server mainframe.
{
{  SERVER_STATE: (output) This parameter returns the server state currently
{    indicated by the Served Family Table entry for this family.
{
{  VERIFIED_BY_SERVER: (output) This boolean field contains the confirmation
{    that the family exists on the specified Server mainframe. If it is FALSE
{    then either the Server did not yet acknowledged existance of this Family
{    or the Family cannot be found on the specified Server mainframe.
*DECK DECK=DFH$PROCESS_JOB_END EXPAND=FALSE
{
{   The purpose of this request is to allow each server mainframe the current
{ job is using to be notified that the client job  no longer will be using
{ the file server.  This allows the release of all resources that the
{ client job is using.
{
{   DFP$PROCESS_JOB_END
{
*DECK DECK=DFH$QUEUE_INQUIRY_REQUEST EXPAND=FALSE
{
{  This process makes the request visable to the driver by obtaining an entry
{ in the request_buffer and storing the request pointers into the entry.
{ Since more than one copy of this program is executing the request_buffer
{ in_offset must be locked when incremented.  Note that the request_buffer is
{ a circular buffer with IN , OUT, and LIMIT offsets.  This process updates the
{ IN offset to point to the next available entry when if entry is assigned.
{ The file server driver updates the OUT offset when an entry is processed.
{
{    DFP$QUEUE_INQUIRY_REQUEST (P_QUEUE_INTERFACE_TABLE, QUEUE_INDEX, QUEUE_ENTRY_INDEX,
{       INQUIRY_MESSAGE, QUEUE_REQUEST_STATUS)
{
{  P_QUEUE_INTERFACE_TABLE: (input) This parameter specifies the
{       queue interface table that points  to the queue specified by queue index.
{
{  QUEUE_INDEX: (input) This parameter specifies the queue for which an entry
{       is to be assigned.
{
{  QUEUE_ENTRY_INDEX: (input) This parameter specifies the queue entry to
{       be queued.
{                                     .
{  INQUIRY_MESSAGE: (input) This parameter is the "inquiry message" to be queued.
{       The ESM driver will not manipulate the queue entry for an "inquiry_message".
{
{  QUEUE_REQUEST_STATUS: (output) This parameter returns wether the request
{       was queued.
{
*DECK DECK=DFH$QUEUE_REQUEST EXPAND=FALSE
{
{  This process makes the request visable to the driver by obtaining an entry
{ in the request_buffer and storing the request pointers into the entry.
{ Since more than one copy of this program is executing the request_buffer
{ in_offset must be locked when incremented.  Note that the request_buffer is
{ a circular buffer with IN , OUT, and LIMIT offsets.  This process updates the
{ IN offset to point to the next available entry when an entry is assigned.
{ The file server driver updates the OUT offset when an entry is processed.
{ This process waits until a request buffer entry is available.
{
{    DFP$QUEUE_REQUEST (P_QUEUE_INTERFACE_TABLE, QUEUE_INDEX, QUEUE_ENTRY_INDEX
{        QUEUE_REQUEST_STATUS)
{
{  P_QUEUE_INTERFACE_TABLE: (input) This parameter specifies the
{       queue interface table that points  to the queue specified by queue index.
{                                     .
{  QUEUE_INDEX: (input) This parameter specifies the queue for which an entry
{       is to be assigned.
{
{  QUEUE_ENTRY_INDEX: (input) This parameter specifies the queue entry to
{       be queued.
{
{  QUEUE_REQUEST_STATUS: (output) This parameter returns wether the request
{       was queued.
{
*DECK DECK=DFH$REBUILD_SET_TABLE_CLIENTS EXPAND=FALSE
{
{    The purpose of this request is to rebuild the client entries in the
{ family set table.  This request is called by stp$build_family_list_for_set
{ during deadstart recovery.  The client entries are rebuilt from the family
{ group permits for the user $system in each family. This request assumes
{ that a PFP$OVERHAUL_CATALOG has been done on the root catalog if called
{ prior to permanent file recovery.
{
{       DFP$REBUILD_SET_TABLE_CLIENTS (FAMILY, STATUS)
{
{ FAMILY: (input) This parameter specifies the name of the family for which
{       the set table entry is to be rebuilt.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS:
{              none
{
*DECK DECK=DFH$RECEIVE_CLIENT_RPC_SEGMENT EXPAND=FALSE
{
{    The purpose of this procedure is to receive a segment sent by the
{ dfp$send_client_rpc_segment request.  If no segment has been sent then an
{ error status is returned.  This procedure must be called from the users
{ procedure on the server mainframe that was called as a result of the client
{ call dfp$send_remote_procedure_call.  The segment must be freed explictly
{ by the DFP$DELETE_CLIENT_RPC_SEGMENT.
{
{    It is the responsibility of the caller of DFP$RECEIVE_CLIENT_RPC_SEGMENT
{ to use the parameter area of dfp$send_remote_procedure_call to provide any
{ information required to read this transient segment.
{
{       DFP$RECEIVE_CLIENT_RPC_SEGMENT (P_SEQ, STATUS)
{
{ P_SEQ: (output)  This parameter returns the pointer to the transient segment.
{       This segment is a copy of the segment specified with
{       dfp$send_client_rpc_request.  The size of the sequence is the highest
{       offset sent from the client.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS:
{             dfe$no_segment_reserved
{
*DECK DECK=DFH$RECEIVE_SERVER_RPC_SEGMENT EXPAND=FALSE
{
{   The purpose of this interface is to allow the client to receive the segment
{ from the server that was reserved  with the dfp$reserve_server_rpc_segment
{ request on the server.  This must be called after the call to
{ dfp$send_remote_procedure_call but before the call to
{ dfp$end_remote_procedure_call.  Any parameters stored in the send_buffer or
{ send_data or returned in the receive_parameters or receive_data of
{ send_remote_procedure_call must be copied, if needed, before using this
{ request, as those parameter and data areas will be reused by this request.
{   The dfp$send_remote_procedure_call request causes a request to be called on
{ the server.  If the server request must return a large amount of data
{ (> 500K bytes), then if must call dfp$reserve_server_rpc_segment to
{ reserve a segment.  The segment may be written to in any manner desired
{ on the server.
{   It is the responsibility of the caller of dfp$receive_server_rpc_segment to
{ use the parameter area of dfp$send_remote_procedure_call to pass back both
{ the size of the segment to be returned and the desired starting offset
{ within the segment on the server.
{   It is the responsibility of the caller of dfp$receive_server_rpc_segment to
{ wait in the advent of the dfe$server_not_active status, and to repeat both
{ this call and the previous call to dfp$send_remote_procedure which set up the
{ server rpc segment.  This request should only be used when the procedure
{ associated with dfp$send_remote_procedure_call is considered restartable.
{
{       DFP$RECEIVE_SERVER_RPC_SEGMENT (QUEUE_ENTRY_LOCATION,
{             SERVER_SEGMENT_OFFSET, REQUEST_SIZE, P_CLIENT_SEGMENT, STATUS)
{
{ QUEUE_ENTRY_LOCATION: (input)  This parameter indicates the
{       queue_entry_location obtained from dfp$begin_remote_procedure_call.
{
{ SERVER_SEGMENT_OFFSET: (input)  This parameter specifies the starting offset
{       of the segment on the server from which to transfer.  The transfer will
{       occur from this location of the server segment to the address specified
{       in  p_client_segment.
{
{       The use of this parameter allows the caller to match segment offsets on
{       the client and server.  On the server, after calling
{       dfp$reserve_server_rpc_segment, the caller would need to set up the
{       offset to match the  offset on the client.  This implies  passing the
{       offset in the parameters used with dfp$send_remote_procedure_call.
{
{ REQUEST_SIZE: (input)  This parameter specifies the amount of data from the
{       transient segment that is to be transferred.  This may be as large as
{       the segment.
{
{ P_CLIENT_SEGMENT: (input, output^)  This parameter indicates the location to
{       write the data to.  This is a sequence pointer.  If the sequence is not
{       large enough, an error status of dfe$info_full is returned.
{
{ STATUS: (output)  This parameter returns the request status.
{       CONDITIONS:
{             dfe$info_full
{             dfe$no_segment_reserved
{             dfe$server_has_terminated
{             dfe$server_not_active
{
*DECK DECK=DFH$RECOVER_JOB EXPAND=FALSE
{
{   The purpose of this request is to perform server job recovery, for the
{ specified server mainframe.  This process involves:
{ - Verifying that the job is still registered on the server mainframe.
{ - For all files attached in the job for this mainframe:
{     Verify that the file is still attached on the server mainframe and
{       return device manager information to the the client.
{     Updating the state and  lifetime of the file in the system file table,
{       the  segment descriptor table extended, and the cycle description on
{       the client mainframe.
{ - Advance the jobs lifetime on both the client and the server mainframe.
{
{    For any files in the attached on the server but not in the attached in the
{ cycle description on the client the file is detached from the server.
{
{    This routine currently assumes that job recovery is inhibited by the
{ caller of this routine.  It is not prepared to handle rollback.
{
{    DFP$RECOVER_JOB (SERVER_MAINFRAME_ID, STATUS)
{
{  SERVER_MAINFRAME_ID: (input)  This parameter specifies the name of the
{        server that this job is to perform job recovery for.
{
{  STATUS: (output) This parameter returns the request status.
{
*DECK DECK=DFH$RELEASE_QUEUE_ENTRY EXPAND=FALSE
{  This process releases the queue entry from assignment.  The entry must be
{  currently assigned. The entry is made available for future use.
{
{    DFP$RELEASE_QUEUE_ENTRY (P_QUEUE_INTERFACE_TABLE, QUEUE_INDEX,
{      QUEUE_ENTRY_INDEX, RELEASE_STATUS)
{
{  P_QUEUE_INTERFACE_TABLE: (input) This parameter specifies the
{       queue interface table that points  to the queue specified by queue index.
{                                     .
{  QUEUE_INDEX: (input) This parameter specifies the queue for which an entry
{       is to be assigned.
{
{  QUEUE_ENTRY_INDEX: (input) This parameter specifies the queue entry to
{       be queued.
{
{  RELEASE_STATUS: (output) This parameter returns the request status.
{      This must be in a format acceptable to both monitor and task services.
{      dfc$rqes_invalid_queue_index - An invalid queue index was input.
{      dfc$rqes_invalid_entry_index - An invalid queue entry was input
{      dfc$rqes_entry_not_assigned - The entry was not assigned
{      dfc$rqes_entry_released - The entry was released.
{
*DECK DECK=DFH$RESERVE_SERVER_RPC_SEGMENT EXPAND=FALSE
{
{   The purpose of this request is to allow the server side of a remote
{ procedure call request to indicate that it wants to send large amounts of
{ data to the client.  The segment obtained  by this request may be received
{ on the client by using the dfp$receive_server_rpc_segment request on the
{ client.  The reserver of this segment may write into this request anyplace it
{ wants, it is the responsibility of the caller of
{ dfp$send_remote_procedure_call to return to the client what
{ the valid offset and length is, so that correct values may be passed to
{ dfp$receive_server_rpc_segment.
{
{       DFP$RESERVE_SERVER_RPC_SEGMENT (P_SEQ, STATUS)
{
{ P_SEQ (output):  This parameter returns the sequence pointer to the segment
{       used for communicating with the client. This sequence has been RESET.
{       The user may use i#build_adaptable_seq_pointer if a different starting
{       offset is required.
{
{ STATUS (output):  This parameter returns the request status.
{       Only conditions from memory manager failure to create a segment are
{       returned.
{
*DECK DECK=DFH$RETURN_FAMILY_SERVED EXPAND=FALSE
{
{   The purpose of this interface is to return whether the specified
{ family is a served family.  A served family is one that resides on
{ another mainframe connected by the file server.  All access to files
{ on a served family will be through the file server.
{
{   DFP$RETURN_FAMILY_SERVED (FAMILY_NAME, FAMILY_SERVED)
{
{  FAMILY_NAME: (input)  This parameter specifies the family name to
{     check.  The specified family is assumed to be capitilized.
{
{  FAMILY_SERVED: (output) This parameter returns whether the specified
{     family resides on a server mainframe.  This is returned even if the
{     file server is in a inactivate, deactivating, or terminated state.
{
*DECK DECK=DFH$SEND_APPLICATION_RPC EXPAND=FALSE
{
{    The purpose of this request is to cause a remote procedure call request to
{ be sent to the server mainframe, and for the remote procedure on the server
{ mainframe to be called.  All input parameters to the server must have been
{ NEXTed into the p_send_to_server_params sequence or the p_send_data_area
{ parameters returned on the dfp$begin_remote_procedure_call request.  All
{ output returned from the server may be read from the
{ p_receive_from_server_param sequence or the p_receive_data_area parameters.
{ The caller of this request waits until the request is processed by the server
{ mainframe and the response is returned.
{
{    If the server is terminated, an error dfe$server_has_terminated is
{ immediately returned and the caller should call
{ dfp$end_remote_procedure_call.  If the state of the server is inactive, or
{ awaiting_recovery then the status dfe$server_not_active is returned.  If the
{ state of the server is active but the job requires recovery the status
{ returned depends upon the job recovery location stored in the procedure
{ address table.  If the job recovery location is
{ dfc$job_rec_in_unavailable_wait then the status of dfe$server_not_active
{ returned and the caller should call osp$wait_on_condition to wait for the
{ server to become active. If the job
{ recovery location is dfc$job_rec_started_by_caller, the status of
{ dfe$job_needs_recovery is returned and the caller should call
{ osp$wait_on_condition after calling dfp$end_remote_procedure_call.
{
{   NOTE:  This procedure is identical to the file server procedure
{         dfp$send_remote_procedure_call except that application_name and
{         procedure_name are used in place of the parameter procedure_ordinal.
{
{       DFP$SEND_APPLICATION_RPC (QUEUE_ENTRY_LOCATION, APPLICATION_NAME,
{             PROCEDURE_NAME, SEND_TO_SERVER_PARAMS_SIZE,
{             DATA_SIZE_TO_SEND_TO_SERVER, P_RECEIVE_FROM_SERVER_PARAMS,
{             P_RECEIVE_DATA_AREA, STATUS)
{
{ QUEUE_ENTRY_LOCATION: (input)  This parameter specifies the paramater value
{       returned from the dfp$begin_remote_procedure_call request and
{       identifies the server mainframe to which the information is to be sent.
{
{ APPLICATION_NAME: (input)  This parameter specifies the name of the
{       application associated with the remote procedure as defined on the
{       DEFINE_APPLICATION_RPC subcommand.
{
{ PROCEDURE_NAME: (input)  This procedure specifies the name of the procedure
{       to be called on the server side.
{
{ SEND_TO_SERVER_PARAMS_SIZE: (input)  This parameter specifies the length of
{       the parameters to send to the server procedure.  This size includes the
{       total length NEXTed by the caller into the sequence
{       p_send_to_server_params returned by dfp$begin_remote_procedure_call.
{       i#current_sequence_position can be used to obtain this size.
{
{ DATA_SIZE_TO_SEND_TO_SERVER: (input)  This parameter specifies the length of
{       total length NEXTed by the caller into the sequence p_send_data
{       returned by dfp$begin_remote_procedure_call.  The caller must have
{       referenced at least the length sent to insure that the pages are wired
{       at the time of the request.
{
{ P_RECEIVE_FROM_SERVER_PARAMS: (output)  This parameter specifies the location
{       of the parameters from the remote procedure.  It will have the value of
{       NIL if no parameter other than status is returned.  The caller should
{       not write into this area.  Size of the sequence is obtained by
{       #SIZE(p_receive_from_server_params^).  This area will be freed on the
{       next call to dfp$send_application_rpc or dfp$end_remote_procedure_call.
{
{ P_RECEIVE_DATA_AREA: (output)  This parameter specifies a pointer to the data
{       area that is too large to fit into the area provided by the receive
{       parameter area.  The value will be NIL if no data is returned.  Size
{       obtainable from #SIZE (p_receive_data_area^).  Caller should not write
{       into this area.  This area will be released on the next call to
{       dfp$send_remote_procedure_call or dfp$end_remote_procedure_call.
{
{ STATUS: (output)  This parameter specifies the request status.
{     procedure on the server or, if a failure occurred in the remote procedure
{     call mechanism (for example, due to a server failure) , this indicates that
{     status.  If this status is abnormal then p_receive_from_server_params
{     and p_receive_data_area are both NIL.
{     Conditions
{         dfe$invalid_queue_entry_id
{         dfe$job_needs_recovery
{         dfe$server_has_terminated
{         dfe$server_not_active
{         dfe$server_request_terminated
{            This condition indicates the server failed while the request was
{            pending.  It is unknown if the request started or completed.
{
*DECK DECK=DFH$SEND_CLIENT_RPC_SEGMENT EXPAND=FALSE
{
{    The purpose of this interface is to allow the client to send a segment to
{ the server.  This must be called after the call to
{ dfp$begin_remote_procedure_call but before the call to
{ dfp$send_remote_procedure_call.  Any parameters stored in the send_buffer or
{ send_data returned from dfp$begin_remote_procedure call must be copied, if
{ needed, before using this request, as those parameter and data areas will be
{ reused by this request.  The dfp$send_remote_procedure_call request causes a
{ request to be called on the server.  That request on the server must call
{ dfp$receive_client_rpc_segment to obtain the sent segment, and then call
{ dfp$delete_client_rpc_segment to remove the segment.
{
{    Multiple calls to this routine may be made to send different portions of
{ the segment.  The size of the sequence returned by
{ dfp$receive_client_rpc_segment will be the highest offset specified to be
{ sent.
{
{    It is the responsibility of the caller of dfp$send_client_rpc_segment to
{ wait in the advent of the dfe$server_not_active status.  This request should
{ only be used when the procedure associated with
{ dfp$send_remote_procedure_call is considered NOT restartable (because the
{ client segment will already have been received and released).
{
{       DFP$SEND_CLIENT_RPC_SEGMENT (QUEUE_ENTRY_LOCATION, P_CLIENT_SEGMENT,
{             SERVER_SEGMENT_OFFSET, REQUEST_SIZE, STATUS)
{
{ QUEUE_ENTRY_LOCATION: (input)  This parameter indicates the
{       queue_entry_location obtained from dfp$begin_remote_procedure_call.
{
{ P_CLIENT_SEGMENT: (input)  This parameter indicates the location to read the
{       data from.  This is a sequence pointer.  If the sequence is not large
{       enough, an error status of dfe$info_full is returned.  The current
{       sequence position is used as the starting address.
{
{ SERVER_SEGMENT_OFFSET: (input)  This parameter specifies the starting offset
{       of the transient segment on the server to transfer to.  The transfer
{       will occur to this location of the server segment from the address
{       specified in p_client_segment.
{
{ REQUEST_SIZE: (input)  This parameter specifies the amount of data from the
{       segment on the client that is to be transferred.  This may be as large
{       as the sequence.
{
{ STATUS: (output)  This parameter returns the request status.
{       CONDITIONS:
{             dfe$info_full
{             dfe$server_has_terminated
{             dfe$server_not_active
{
*DECK DECK=DFH$SEND_REMOTE_PROCEDURE_CALL EXPAND=FALSE
{
{   The purpose of this request is to cause a remote procedure call request to
{ be sent to the server mainframe, and for the remote procedure on the server
{ mainframe to be called.   All input parameters to the server, must have been
{ NEXTed into the p_send_to_server_params  sequence or the
{ p_send_data_area parameters returned on the
{ dfp$begin_remote_procedure_call request.  All output returned from the
{ server may be read from the p_receive_from_server_param sequence or the
{ p_receive_data_area parameters.   The caller of this request waits until the
{ request is processed by the server mainframe and the response is returned.
{
{ If the server is terminated an error dfe$server_has_terminated is immediately
{ returned and the caller should call dfp$end_remote_procedure_call.
{ If the state of the server is inactive, or awaiting_recovery then the status
{ dfe$server_not_active is returned. If the state of the server is active but
{ the job requires job recovery the status returned depends upon the job
{ requires server job recovery the status returned depends upon the job recovery
{ location stored in the procedure address table.  If the job recovery location
{ is dfc$job_rec_in_unavailable_wait then the status of dfe$server_not_active
{ returned and the caller should call osp$wait_on_condition.  If the job
{ recovery location is dfc$job_rec_started_by_caller the caller
{ the status of dfe$job_needs_recovery is returned  and the caller should call
{ dfp$check_job_recovery after calling dfp$end_remote_procedure_call.
{
{    DFP$SEND_REMOTE_PROCEDURE_CALL (QUEUE_ENTRY_LOCATION,
{        PROCEDURE_ORDINAL, SEND_TO_SERVER_PARAMS_SIZE,
{        DATA_SIZE_TO_SEND_TO_SERVER, P_RECEIVE_FROM_SERVER_PARAMS,
{        P_RECEIVE_DATA_AREA, STATUS)
{
{ queue_entry_location
{      This parameter was obtained from the dfp$begin_remote_procedure_call
{      request, and identifies the server mainframe to send the request to.
{
{ procedure_ordinal
{      This parameter specifies the identification of the procedure that is to be
{      called on the server side.  This is defined in deck
{      dft$procedure_address_ordinal.
{
{ send_to_server_params_size
{     Length of parameters to send to server
{         Only includes length under user control.
{     Parameters may have been nexted into p_send_to_server_params returned
{     by dfp$begin_remote_procedure_call.
{     Use i#current_sequence_position to get this length if using NEXTs.
{
{ data_size_to_send_to_server
{     Data must have been written into p_send_data_area.
{     Data to send to the server.
{     The caller must have touched at least the length sent
{         To assure that the pages are wired at the time of the request.
{
{ VAR p_receive_from_server_params: dft$p_user_command_buffer
{     Parameters received from server.
{     Will be NIL if no parameters other than status  returned.
{     Caller should not write into this area .
{     This is the servers VAR parameters.
{     Size obtainable by doing #size(p_receive_from_server_params^).
{     This area will be released on the next call to
{     dfp$send_remote_procedure_call or dfp$end_remote_procedure_call.
{
{ VAR p_receive_data_area: dft$p_data_area
{     This parameter returns a pointer to a data area that may be used to
{     receive data that is too large to fit into the areas provided by the
{     receive  parameter area.
{     Will be NIL if no data returned.
{     Data received from server.
{     Size obtainable from #size(p_receive_data_area^).
{     Caller should not write into this area.
{     This area will be released on the next call to
{     dfp$send_remote_procedure_call or dfp$end_remote_procedure_call.
{
{ VAR status
{     This parameter returns the status.  This is the status from the remote
{     procedure on the server or  if a failure occurred in the remote procedure
{     call mechanism (for example, due to a server failure) , this indicates that
{     status.  If this status is abnormal then p_receive_from_server_params
{     and p_receive_data_area are both NIL.
{     Conditions
{         dfe$invalid_queue_entry_id
{         dfe$job_needs_recovery
{         dfe$server_has_terminated
{         dfe$server_not_active
{         dfe$server_request_terminated
{            This condition indicates the server failed while the request was
{            pending.  It is unknown if the request started or completed.
{
*DECK DECK=DFH$SET_TASK_SEGMENT_STATE EXPAND=FALSE
{
{    The purpose of this procedure is to change the segment descriptor table
{ entries for either all tasks in a job that is swapping in, or for all tasks
{ in all active jobs in the system.  Only those segments that are associated
{ with the server mainframes specified by the inhibit_access_work and
{ terminate_access_work are changed.
{
{    For a file in the segment descriptor table that belongs to a server
{ mainframe that is a member of the set of inhibit_access_work, the
{ access_state in the segment descriptor table extended entry is set to
{ mmc$sas_inhibit_access.  Memory manager will force the user to wait for any
{ file in this state.
{
{    For a file in the segment descriptor table that belongs to a server
{ mainframe that is a member of the set of terminate_access_work, the
{ access_state in the segment descriptor table extended entry is set to
{ mmc$sas_terminate_access.  Memory manager will force a segment access
{ condition on any access to a segment in this state.
{
{       DFP$SET_TASK_SEGMENT_STATE (SEARCH, IJLE_P, INHIBIT_ACCESS_WORK,
{             TERMINATE_ACCESS_WORK)
{
{  SEARCH: (input)  This parameter specifies the scope of the change.
{        tmc$fnx_swapping_job may be used to change all tasks in a swapping in
{          job.
{        tmc$fnx_job may be used to change all tasks in a selected job.
{        tmc$fnx_system may be used to change all active tasks in the
{        system.
{
{  IJLE_P: (input)  If search is tmc$fnx_swapping_job then this specifies the
{        job that is being changed.  If search is tmc$fnx_system then this
{        should be specified as NIL.
{
{  INHIBIT_ACCESS_WORK: (input)  This parameter specifies the servers to which
{        access will be inhibited.
{
{  TERMINATE_ACCESS_WORK: (input)  This parameter specifies the servers to
{        which access will be terminated.  If a mainframe is a member of both
{        sets, the terminate has precedence.
{
*DECK DECK=DFH$STORE_LEVELER_STATUS EXPAND=FALSE
{
{    The purpose of this request is set the job leveler status of the
{ specified server mainframe.
{
{       DFP$STORE_LEVELER_STATUS (SERVER_MAINFRAME_ID, LEVELER_STATUS,
{             STATUS)
{
{ SERVER_MAINFRAME_ID: (input) This is the binary ID of the server
{       mainframe.
{
{ LEVELER_STATUS: (input) This is the job leveler status to be set for the
{       server mainframe.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             dfe$mainframe_not_server
{
*DECK DECK=DFH$VERIFY_CLIENT_JOBS_REQUEST EXPAND=FALSE
{
{    The purpose of this request is to cause the server to remove entries and
{ detach files from the client_mainframe_file which are associated with jobs
{ which no longer exist on the client.
{
{       DFP$VERIFY_CLIENT_JOBS_REQUEST (MAINFRAME_ID, STATUS)
{
{ MAINFRAME_ID: (input)  This parameter specifies the name of the server
{       mainframe.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS:
{
*DECK DECK=DFI$CONSOLE_DISPLAY EXPAND=FALSE

?? PUSH (LISTEXT := ON) ??
*copyc dpp$put_next_line
*copyc dpv$system_core_display
*copyc ost$status
?? POP ??

  PROCEDURE [INLINE] display_to_console
    (    display_line: string ( * <= 255));

    VAR
      length: integer,
      working_string: string (256),
      status: ost$status;

    STRINGREP (working_string, length, ' ', display_line);
    dpp$put_next_line (dpv$system_core_display, working_string (1, length),
          status);
  PROCEND display_to_console;
?? SKIP := 5 ??

  PROCEDURE [INLINE] display_boolean_to_console
    (    descriptor: string ( * <= 128);
         value: boolean);

    VAR
      total_length: integer,
      working_string: string (150);

    STRINGREP (working_string, total_length, descriptor, ' ', value);
    display_to_console (working_string (1, total_length));

  PROCEND display_boolean_to_console;

  PROCEDURE [INLINE] display_integer_to_console
    (    descriptor: string ( * <= 127);
         number: integer);

    VAR
      descriptor_length: integer,
      number_length: integer,
      total_length: integer,
      working_string: string (150);

    working_string := descriptor;
    descriptor_length := STRLENGTH (descriptor);
    STRINGREP (working_string ((descriptor_length + 2), * ), number_length,
          number);
    total_length := number_length + descriptor_length + 2;
    display_to_console (working_string (1, total_length));
  PROCEND display_integer_to_console;
?? SKIP := 5 ??

  PROCEDURE [INLINE] display_pva_to_console
    (    descriptor: string ( * <= 127);
         pva: ^cell);

    VAR
      descriptor_length: integer,
      length: integer,
      working_string: string (150);

    STRINGREP (working_string, length, descriptor, ' ', pva);
    display_to_console (working_string (1, length));
  PROCEND display_pva_to_console;
*DECK DECK=DFI$CORE_LOG_DISPLAY EXPAND=FALSE
  PROCEDURE core_log_display
    (    message: string ( * ));

    VAR
      ignore_status: ost$status,
      log_time: ost$time;

    lgp$add_entry_to_system_log (pmc$msg_origin_system, message, log_time,
          ignore_status);

  PROCEND core_log_display;

  PROCEDURE core_log_display_integer
    (    message: string ( * <= 127);
         number: integer);

    VAR
      descriptor_length: integer,
      number_length: integer,
      total_length: integer,
      working_string: string (150);

    working_string := message;
    descriptor_length := STRLENGTH (message);
    STRINGREP (working_string ((descriptor_length + 2), *), number_length, number);
    total_length := number_length + descriptor_length + 2;
    core_log_display (working_string (1, total_length));

  PROCEND core_log_display_integer;
?? PUSH (LISTEXT := ON) ??
*copyc lgp$add_entry_to_system_log
?? POP ??
*DECK DECK=DFI$DISPLAY EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc clp$put_job_command_response
*copyc clp$put_job_output
*copyc i#move
*copyc osp$format_message
*copyc pmp$log
*copyc oss$job_paged_literal
?? POP ??

  PROCEDURE [INLINE] display
    (    display_line: string ( * <= 255));

    VAR
      length: integer,
      working_string: string (256),
      status: ost$status;

    STRINGREP (working_string, length, ' ', display_line);
    clp$put_job_command_response (working_string (1, length), status);
  PROCEND display;
?? SKIP := 5 ??

   PROCEDURE [INLINE] display_boolean
    (    descriptor: string ( * <= 128);
         value: boolean);

    VAR
      total_length: integer,
      working_string: string (150);

    STRINGREP (working_string, total_length, descriptor, ' ', value);
    display (working_string (1, total_length));

   PROCEND;
?? SKIP := 5 ??
  PROCEDURE display_bytes
    (    address: ^cell;
         length: integer);

    VAR
      hex_digits: [STATIC,oss$job_paged_literal,READ] array [0 .. 15] of char :=
            ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'a', 'b', 'c',
            'd', 'e', 'f'];

    VAR
      data: ^string ( * ),
      data_index: integer,
      line: string (72),
      line_index: integer;

    line_index := 1;
    PUSH data: [length];
    i#move (address, data, length);
    line := ' ';
    FOR data_index := 1 TO length DO
      line (line_index) := hex_digits [$INTEGER (data^ (data_index)) DIV 16];
      line (line_index + 1) := hex_digits [$INTEGER (data^ (data_index)) MOD
            16];
      IF (data_index MOD 8) = 0 THEN
        line (line_index + 2) := ' ';
        line_index := line_index + 1;
      IFEND;
      line_index := line_index + 2;
      IF (line_index > 67) OR (data_index = length) THEN
        display (line (1, (line_index - 1)));
        line := ' ';
        line_index := 1;
      IFEND;
    FOREND;
  PROCEND display_bytes;
?? SKIP := 5 ??
  PROCEDURE [INLINE] display_integer
    (    descriptor: string ( * <= 127);
         number: integer);

    VAR
      descriptor_length: integer,
      number_length: integer,
      total_length: integer,
      working_string: string (150);

    working_string := descriptor;
    descriptor_length := STRLENGTH (descriptor);
    STRINGREP (working_string ((descriptor_length + 2), * ), number_length,
          number);
    total_length := number_length + descriptor_length + 2;
    display (working_string (1, total_length));
  PROCEND display_integer;
?? SKIP := 5 ??
   PROCEDURE [INLINE] display_pva
     (    descriptor: string ( * <= 127);
          pva: ^cell);

    VAR
      descriptor_length: integer,
      length: integer,
      working_string: string (150);

     STRINGREP (working_string, length, descriptor, ' ', pva);
     display (working_string (1, length));
  PROCEND;
?? SKIP := 5 ??

  PROCEDURE display_real
       (    descriptor: string ( * );
         number: real);

    VAR
      descriptor_length: integer,
      length: integer,
      working_string: string (150);

     STRINGREP (working_string, length, ' ', descriptor, ' ', number );
     display (working_string (1, length));
  PROCEND;
?? SKIP := 5 ??
  PROCEDURE display_status
    (    status: ost$status);

    VAR
      line_count: ost$status_message_line_count,
      message: ost$status_message,
      p_line_count: ^ost$status_message_line_count,
      p_line_size: ^ost$status_message_line_size,
      p_message: ^ost$status_message,
      p_message_line: ^string ( * ),
      request_status: ost$status;

    request_status.normal := TRUE;
    IF status.normal THEN
      display (' STATUS NORMAL ');
      RETURN;
    ELSE
      display (' STATUS abnormal');
      display_integer (' condition ', status.condition);
      display (status.text.value (1, status.text.size));
    IFEND;
    p_message := ^message;
    RESET p_message;
    osp$format_message (status, osc$full_message_level, osc$max_string_size,
          p_message^, request_status);
    IF NOT request_status.normal THEN
      display (' unable to display status ');
      RETURN;
    IFEND;
    RESET p_message;
    NEXT p_line_count IN p_message;
    IF p_line_count^ > 0 THEN
      FOR line_count := 1 TO (p_line_count^) DO
        NEXT p_line_size IN p_message;
        NEXT p_message_line: [p_line_size^] IN p_message;
        display (p_message_line^);
      FOREND;
    IFEND;
  PROCEND display_status;

?? SKIP := 5 ??
 PROCEDURE display_trace_back;

  TYPE
    sfsa_type = record
      fill1: 0 .. 0ffff(16),
      p: ^cell,
      a0: integer,
      a1: integer,
      fill2: 0 .. 0ffff(16),
      a2: ^sfsa_type, {previous save area pointer}
    recend;

    VAR
     length: integer,
     message: string (80),
     stack: integer,
     sfsa_p: ^sfsa_type; {pointer to previous stack frame save area};

      sfsa_p := #previous_save_area ();

     /display_calls/
      FOR stack := 0 to 20 do
        stringrep (message, length, ' Stack ', stack, ' P= ', sfsa_p^.p);
        display (message (1, length));
        sfsa_p := sfsa_p^.a2; { move to next previous sfsa }
        IF sfsa_p = NIL THEN
           EXIT /display_calls/;
        IFEND;
     FOREND;
  PROCEND;
?? SKIP := 5 ??
  PROCEDURE display_unformatted_status
    (    status: ost$status);

    IF status.normal THEN
      display (' STATUS NORMAL ');
    ELSE
      display (' STATUS abnormal');
      display_integer (' condition ', status.condition);
      display (status.text.value (1, status.text.size));
    IFEND;
  PROCEND display_unformatted_status;

*DECK DECK=DFI$FSP_OPEN_CLOSE EXPAND=FALSE
?? TITLE := ' DF interfaces to fsp$open/close', EJECT ??
{
{ PURPOSE:
{    The purpose of this "module" is to provide simple interfaces between file
{    server procedures and fsp$open/close_file.
{

?? NEWTITLE := 'Global Declarations', EJECT ??

*copyc amp$fetch_access_information
*copyc amp$get_segment_pointer
*copyc amp$set_segment_position
*copyc cle$file_never_opened
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal

?? TITLE := '    dfp$fsp_open', EJECT ??

  PROCEDURE dfp$fsp_open
    (    local_file_name: amt$local_file_name;
         access_level: amt$access_level;
         read_not_write: boolean;
         open_for_attach: boolean;
         seq_and_free_behind: boolean;
         command_name: string ( * <= osc$max_name_size);
     VAR file_id: amt$file_identifier;
     VAR sequence_pointer: ^SEQ ( * );
     VAR sequence_size: amt$file_byte_address;
     VAR status: ost$status);

    VAR
      attribute_override: ^array [1 .. 3] of fst$file_cycle_attribute,
      fetch_access_selections: array [1 .. 1] of amt$access_info,
      file_attachment: ^array [ * ] of fst$attachment_option,
      file_creation: ^array [1 .. 1] of fst$file_cycle_attribute,
      ignore_status: ost$status,
      segment_pointer: amt$segment_pointer;

    status.normal := TRUE;

    IF open_for_attach THEN
      IF seq_and_free_behind THEN
        PUSH file_attachment: [1 .. 5];
        file_attachment^ [4].selector := fsc$sequential_access;
        file_attachment^ [4].sequential_access := TRUE;
        file_attachment^ [5].selector := fsc$free_behind;
        file_attachment^ [5].free_behind := TRUE;
      ELSE
        PUSH file_attachment: [1 .. 3];
      IFEND;

      file_attachment^ [1].selector := fsc$access_and_share_modes;
      file_attachment^ [1].access_modes.selector := fsc$specific_access_modes;
      file_attachment^ [1].share_modes.selector := fsc$specific_share_modes;
      file_attachment^ [2].selector := fsc$open_share_modes;
      IF read_not_write THEN
        file_attachment^ [1].access_modes.value :=
              $fst$file_access_options [fsc$read];
        file_attachment^ [1].share_modes.value :=
              $fst$file_access_options [fsc$read, fsc$execute];
        file_attachment^ [2].open_share_modes :=
              $fst$file_access_options [fsc$read, fsc$execute];
      ELSE
        file_attachment^ [1].access_modes.value :=
              $fst$file_access_options [fsc$read, fsc$append, fsc$shorten];
        file_attachment^ [1].share_modes.value := $fst$file_access_options [];
        file_attachment^ [2].open_share_modes :=
              $fst$file_access_options [fsc$read, fsc$execute];
      IFEND;
      file_attachment^ [3].selector := fsc$create_file;
      file_attachment^ [3].create_file := TRUE;
    ELSE
      file_attachment := NIL;
    IFEND;

    IF access_level = amc$segment THEN
      PUSH attribute_override;
      attribute_override^ [1].selector := fsc$block_type;
      attribute_override^ [1].block_type := amc$system_specified;
      attribute_override^ [2].selector := fsc$record_type;
      attribute_override^ [2].record_type := amc$undefined;
      attribute_override^ [3].selector := fsc$file_organization;
      attribute_override^ [3].file_organization := amc$sequential;
      file_creation := NIL;
    ELSE
      attribute_override := NIL;
      PUSH file_creation;
      file_creation^ [1].selector := fsc$ring_attributes;
      file_creation^ [1].ring_attributes.r1 := 11;
      file_creation^ [1].ring_attributes.r2 := 11;
      file_creation^ [1].ring_attributes.r3 := 11;
    IFEND;

    fsp$open_file (local_file_name, access_level, file_attachment,
          file_creation, {mandated_creation_attributes=} NIL,
          {attribute_vcalidation=}
          NIL, attribute_override, file_id, status);
    IF NOT status.normal THEN
      IF (status.condition = ame$new_file_requires_append) AND
            (read_not_write) THEN
        osp$set_status_abnormal ('CL', cle$file_never_opened, local_file_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              command_name, status);
      IFEND;
      RETURN;
    IFEND;

    IF access_level = amc$segment THEN
      fetch_access_selections [1].key := amc$eoi_byte_address;
      amp$fetch_access_information (file_id, fetch_access_selections, status);
      IF NOT status.normal THEN
        fsp$close_file (file_id, ignore_status);
        RETURN;
      IFEND;
      amp$get_segment_pointer (file_id, amc$sequence_pointer, segment_pointer,
            status);
      IF status.normal THEN
        sequence_pointer := segment_pointer.sequence_pointer;
        sequence_size := fetch_access_selections [1].eoi_byte_address;
      ELSE
        fsp$close_file (file_id, ignore_status);
        RETURN;
      IFEND;
    ELSE
      sequence_pointer := NIL;
      sequence_size := 0;
    IFEND;

  PROCEND dfp$fsp_open;

?? TITLE := '    dfp$fsp_close', EJECT ??

  PROCEDURE dfp$fsp_close
    (    file_id: amt$file_identifier;
     VAR sequence_pointer: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      segment_pointer: amt$segment_pointer;

    IF sequence_pointer <> NIL THEN
      segment_pointer.kind := amc$sequence_pointer;
      segment_pointer.sequence_pointer := sequence_pointer;
      amp$set_segment_position (file_id, segment_pointer, status);
    IFEND;

    fsp$close_file (file_id, status);

  PROCEND dfp$fsp_close;
?? OLDTITLE ??
?? OLDTITLE ??
?? EJECT ??

*DECK DECK=DFI$LOG_DISPLAY EXPAND=FALSE


?? PUSH (LISTEXT := ON) ??
*copyc i#move
*copyc osp$format_message
*copyc pmp$log_ascii
*copyc oss$job_paged_literal
?? POP ??

  PROCEDURE log_display
    (    logset: pmt$ascii_logset;
         display_line: string ( * <= 255));

    VAR
      length: integer,
      working_string: string (256),
      ignore_status: ost$status;

    STRINGREP (working_string, length, ' ', display_line);
    pmp$log_ascii (working_string (1, length), logset, pmc$msg_origin_system,
          ignore_status);
  PROCEND log_display;
?? SKIP := 5 ??

  PROCEDURE log_display_boolean
    (    logset: pmt$ascii_logset;
         descriptor: string ( * <= 128);
         value: boolean);

    VAR
      total_length: integer,
      working_string: string (150);

    STRINGREP (working_string, total_length, descriptor, ' ', value);
    log_display (logset, working_string (1, total_length));

  PROCEND log_display_boolean;
?? SKIP := 5 ??

  PROCEDURE log_display_bytes
    (    logset: pmt$ascii_logset;
         address: ^cell;
         length: integer);

    VAR
      hex_digits: [STATIC, oss$job_paged_literal, READ] array [0 .. 15] of
            char := ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'a',
            'b', 'c', 'd', 'e', 'f'];

    VAR
      data: ^string ( * ),
      data_index: integer,
      line: string (72),
      line_index: integer;

    line_index := 1;
    PUSH data: [length];
    i#move (address, data, length);
    line := ' ';
    FOR data_index := 1 TO length DO
      line (line_index) := hex_digits [$INTEGER (data^ (data_index)) DIV 16];
      line (line_index + 1) := hex_digits [$INTEGER (data^ (data_index)) MOD
            16];
      IF (data_index MOD 8) = 0 THEN
        line (line_index + 2) := ' ';
        line_index := line_index + 1;
      IFEND;
      line_index := line_index + 2;
      IF (line_index > 67) OR (data_index = length) THEN
        log_display (logset, line (1, (line_index - 1)));
        line := ' ';
        line_index := 1;
      IFEND;
    FOREND;
  PROCEND log_display_bytes;
?? SKIP := 5 ??

  PROCEDURE log_display_integer
    (    logset: pmt$ascii_logset;
         descriptor: string ( * <= 127);
         number: integer);

    VAR
      descriptor_length: integer,
      number_length: integer,
      total_length: integer,
      working_string: string (150);

    working_string := descriptor;
    descriptor_length := STRLENGTH (descriptor);
    STRINGREP (working_string ((descriptor_length + 2), * ), number_length,
          number);
    total_length := number_length + descriptor_length + 2;
    log_display (logset, working_string (1, total_length));
  PROCEND log_display_integer;
?? SKIP := 5 ??

  PROCEDURE log_display_pva
    (    logset: pmt$ascii_logset;
         descriptor: string ( * <= 127);
         pva: ^cell);

    VAR
      descriptor_length: integer,
      length: integer,
      working_string: string (150);

    STRINGREP (working_string, length, descriptor, ' ', pva);
    log_display (logset, working_string (1, length));
  PROCEND log_display_pva;
?? SKIP := 5 ??

  PROCEDURE log_display_real
    (    logset: pmt$ascii_logset;
         descriptor: string ( * );
         number: real);

    VAR
      descriptor_length: integer,
      length: integer,
      working_string: string (150);

    STRINGREP (working_string, length, ' ', descriptor, ' ', number);
    log_display (logset, working_string (1, length));
  PROCEND log_display_real;
?? SKIP := 5 ??

  PROCEDURE log_display_status
    (    logset: pmt$ascii_logset;
         format: boolean;
         status: ost$status);

    VAR
      line_count: ost$status_message_line_count,
      message: ost$status_message,
      p_line_count: ^ost$status_message_line_count,
      p_line_size: ^ost$status_message_line_size,
      p_message: ^ost$status_message,
      p_message_line: ^string ( * ),
      request_status: ost$status;

    request_status.normal := TRUE;
    IF status.normal THEN
      log_display (logset, ' STATUS NORMAL ');
      RETURN;
    ELSE
      log_display (logset, ' STATUS abnormal');
      log_display_integer (logset, ' condition ', status.condition);
      log_display (logset, status.text.value (1, status.text.size));
    IFEND;
    IF NOT format THEN
      RETURN;
    IFEND;
    p_message := ^message;
    RESET p_message;
    osp$format_message (status, osc$full_message_level, osc$max_string_size,
          p_message^, request_status);
    IF NOT request_status.normal THEN
      log_display (logset, ' unable to display status ');
      RETURN;
    IFEND;
    RESET p_message;
    NEXT p_line_count IN p_message;
    IF p_line_count^ > 0 THEN
      FOR line_count := 1 TO (p_line_count^) DO
        NEXT p_line_size IN p_message;
        NEXT p_message_line: [p_line_size^] IN p_message;
        log_display (logset, p_message_line^);
      FOREND;
    IFEND;
  PROCEND log_display_status;

?? SKIP := 5 ??

  PROCEDURE log_display_trace_back
    (    logset: pmt$ascii_logset);

    TYPE
      sfsa_type = record
        fill1: 0 .. 0ffff(16),
        p: ^cell,
        a0: integer,
        a1: integer,
        fill2: 0 .. 0ffff(16),
        a2: ^sfsa_type, {previous save area pointer}
      recend;

    VAR
      length: integer,
      message: string (80),
      stack: integer,
      sfsa_p: ^sfsa_type; {pointer to previous stack frame save area}

    ;

    sfsa_p := #PREVIOUS_SAVE_AREA ();

  /display_calls/
    FOR stack := 0 TO 20 DO
      STRINGREP (message, length, ' Stack ', stack, ' P= ', sfsa_p^.p);
      log_display (logset, message (1, length));
      sfsa_p := sfsa_p^.a2; { move to next previous sfsa }
      IF sfsa_p = NIL THEN
        EXIT /display_calls/;
      IFEND;
    FOREND /display_calls/;
  PROCEND log_display_trace_back;
?? SKIP := 5 ??

  PROCEDURE log_display_unformatted_status
    (    logset: pmt$ascii_logset;
         status: ost$status);

    IF status.normal THEN
      log_display (logset, ' STATUS NORMAL ');
    ELSE
      log_display (logset, ' STATUS abnormal');
      log_display_integer (logset, ' condition ', status.condition);
      log_display (logset, status.text.value (1, status.text.size));
    IFEND;
  PROCEND log_display_unformatted_status;

*DECK DECK=DFI$MONITOR_DISPLAY EXPAND=FALSE

?? PUSH (LISTEXT := ON) ??
*copyc dpp$display_error
?? POP ??
  PROCEDURE [INLINE] display_monitor
    (    display_line: string ( * <= 255));

    dpp$display_error (display_line);
  PROCEND display_monitor;
?? SKIP := 5 ??

  PROCEDURE display_integer_monitor
    (    desc: string ( * <= 60);
         int: integer);

    VAR
      hex_digits: [READ] array [0 .. 15] of char := ['0', '1', '2', '3', '4',
            '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f'];

    TYPE
      convert = record
        case (integ, strng) of
        = integ =
          int: integer,
        = strng =
          strn: string (8),
        casend,
      recend;

    VAR
      conv: convert,
      data: string (8),
      data_index: integer,
      line: string (80),
      line_index: integer;

    line := desc;
    line_index := #SIZE (desc) + 2;
    conv.int := int;
    data := conv.strn;
    FOR data_index := 1 TO 8 DO
      line (line_index) := hex_digits [$INTEGER (data (data_index)) DIV 16];
      line (line_index + 1) := hex_digits [$INTEGER (data (data_index)) MOD 16];
      line_index := line_index + 2;
    FOREND;
    display_monitor (line (1, (line_index - 1)));
  PROCEND display_integer_monitor;


*DECK DECK=DFK$FILE_SERVER_INFO_KEYPOINTS EXPAND=FALSE
 { PURPOSE:
{   This deck contains the keypoints associated with the data from
{   SETSA FILE_SERVER_INFO_ENABLED ON
{   These are processed by its own processor.

  CONST
    dfk$file_server_info_class = 11;

  CONST
    dfk$file_server_info_base = 50;

  CONST
    dfk$attach_info = dfk$file_server_info_base,
    { dft$keypoint_file_operation + dft$keypoint_sfid

    dfk$catalog_access_info = dfk$file_server_info_base + 1,
    { dft$keypoint_catalog_summary

    dfk$close_info = dfk$file_server_info_base + 2,
    { dft$keypoint_sfid

    dfk$create_info = dfk$file_server_info_base + 3,
    { dft$keypoint_file_operation + dft$keypoint_sfid

    dfk$delete_info = dfk$file_server_info_base + 4,
    { dft$keypoint_file_operation + dft$keypoint_sfid (for CATALOGS)

    dfk$detach_sfid = dfk$file_server_info_base + 5,
    { dft$keypoint_sfid

    dfk$open_info = dfk$file_server_info_base + 6,
    { dft$keypoint_sfid

    dfk$pager_io_info = dfk$file_server_info_base + 7,
    { dft$keypoint_pager_io + dft$keypoint_sfid

    dfk$sfid = dfk$file_server_info_base + 8;
    { dft$keypoint_sfid





*DECK DECK=DFK$KEYPOINTS EXPAND=FALSE
{ This deck contains all of the file server keypoint constants.

  CONST

    { ENTRY/EXIT CLASS KEYPOINTS }

    dfk$process_monitor_entry    = dfk$base,
    {E 'process_monitor_entry' 'queentry' I20}
    {X 'process_monitor_entry' 'queentry' I20}

    dfk$process_task_entry    = dfk$base + 1,
    {E 'process_task_entry' 'queentry' I20}
    {X 'process_task_entry'}

    dfk$assign_queue_entry    = dfk$base + 2,
    {E 'dfp$assign_queue_entry' 'queindex' I20}
    {X 'dfp$assign_queue_entry' 'queentry' I20}

    dfk$queue_request    = dfk$base + 3,
    {E 'dfp$queue_request' 'queentry' I20}
    {X 'dfp$queue_request' 'rqbentry' I20}

    dfk$release_queue_entry    = dfk$base + 4,
    {E 'dfp$release_queue_entry' 'queindex' I20}
    {X 'dfp$release_queue_entry' 'queentry' I20}

    dfk$process_server_response  = dfk$base + 5,
    {E 'dfp$process_server_response' 'lun' I20}
    {X 'dfp$process_server_response' 'lun' I20}

    dfk$locate_served_family  = dfk$base + 6,
    {E 'dfp$locate_served_family' }
    {X 'dfp$locate_served_family' 'family' I20}

    dfk$check_job_server = dfk$base + 7,
    {E 'dfp$check_job_server' 'queindex' I20}
    {X 'dfp$check_job_server' 'clijobid' I20}

    mmk$mtr_process_server_complete = dfk$base + 8,
    {E 'mmp$mtr_process_server_complete' 'SFIDindx' I10 }
    {X 'mmp$mtr_process_server_complete' 'state' I10}

    dfk$client_io = dfk$base + 9,
    {E 'dfp$client_io' 'io_type' I10}
    {X 'dfp$client_io' 'cpiostat' I10}

    dfk$send_write_response = dfk$base + 10,
    {E 'dfp$send_write_response' 'queentry' I10}
    {X 'dfp$send_write_response' 'cpiostat' I10}

    dfk$server_io = dfk$base + 11,
    {E 'dfp$server_io' 'io_type' I10}
    {X 'dfp$server_io' 'io_type' I10}

    dfk$queue_inquiry_request    = dfk$base + 12,
    {E 'dfp$queue_inquiry_request' 'queentry' I20}
    {X 'dfp$queue_inquiry_request' 'rqbentry' I20}

    dfk$begin_remote_procedure_call = dfk$base + 13,
    {E 'dfp$begin_remote_procedure_call'  'deact' I4}
    {X 'dfp$begin_remote_procedure_call' 'queentry' I20}

    dfk$send_remote_procedure_call = dfk$base + 14,
    {E 'dfp$send_remote_procedure_call' 'procord' I20}
    {X 'dfp$send_remote_procedure_call'}

    dfk$end_remote_procedure_call = dfk$base + 15,
    {E 'dfp$end_remote_procedure_call'  'queentry' I20 }
    {X 'dfp$end_remote_procedure_call' 'transact' I20}

    dfk$receive_server_rpc_segment  = dfk$base + 16,
    {E 'dfp$receive_server_rpc_segment'}
    {X 'dfp$receive_server_rpc_segment'}

    dfk$reserve_server_rpc_segment  = dfk$base + 17,
    {E 'dfp$reserve_server_rpc_segment'}
    {X 'dfp$reserve_server_rpc_segment'}

    dfk$receive_client_rpc_segment = dfk$base + 18,
    {E 'dfp$receive_client_rpc_segment'}
    {X 'dfp$receive_client_rpc_segment'}

    dfk$send_client_rpc_segment = dfk$base + 19,
    {E 'dfp$send_client_rpc_segment'}
    {X 'dfp$send_client_rpc_segment'}


    { DEBUG CLASS KEYPOINTS }

    dfk$monitor_task_activated = dfk$base,
    {D 'monitor_task_activated'}

    dfk$remote_procedure_call = dfk$base + 1,
    {D 'Server Remote procedure call ' 'procordn'  I20}

    dfk$server_state = dfk$base + 2,
    {D ' Server state' 'state' I10}

    dfk$remote_request = dfk$base + 3,
    {D ' Remote request ' 'remreqst' I10}

    dfk$iocb_condition = dfk$base + 4;
    {D ' Iocb condition ' 'condtion' I10}

?? PUSH (LISTEXT := ON) ??
*copyc amk$base_keypoint_values
?? POP ??
*DECK DECK=DFM$ANALYZE_SERVER_KEYPOINTS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE PERFORMANCE TOOLS : ANALYZE FILE SERVER KEYPOINTS', EJECT ??
MODULE dfm$analyze_server_keypoints;

{  PURPOSE:
{  This module contains the code necessary to analyze
{  raw keypoints generated via the commands
{    SET_SYSTEM_ATTRIBUTE FILE_SERVER_INFO_ENABLED ON
{    RESERVE_KEYPOINT_ENVIRONMENT CF=$USER.KP MM=11 JM=11 KC=100000
{    START_KEYPOINT_COLLECTION
{      - Run the benchmark, to generate keypoints
{    STOP_KEYPOINT_COLLECTION
{    RELEASE_KEYPOINT_ENVIRONMENT
{  The cf (collection_file) may be input to the keypoint_file (kp) of
{  this procedure.
{
{  ANALYZE_SERVER_KEYPOINTS
{  keypoint_file, kf          : file = $required
{     This is the keypoint collection_file to be analyzed.
{  display_options, ..
{  display_option, do         : list of key trace, t, intervals, i, ..
{                                   interval_histogram, ih, summary, s, all ..
{                             = summary
{      trace - Displays each keypoint issued and its data.
{         Usually a huge listing.
{      summary - Displays the total of the keypoints for each catagory
{         ($SYSTEM, REMOTE) of file or catalog.  At the end is a total
{          that sums the file and io activity.
{      intervals - Gives the sum of the requests for each interval of the
{          length selected by interval_microseconds.  This will display
{          for example, the number of operations per second.
{          This may be a large listing if there were alot of intervals in
{          the run.
{      interval_histogram - This summarizes the distribution of the
{           intervals in a histogram.  For example, was the distribution
{           of number of attaches per second.
{  interval_catagory, ic      : key of, total, remote_catalog, remote_file, ..
{                                   system_catalog, system_file, all = remote_file
{       Select a subset of the information.
{  interval_microseconds, im  : integer -1152921504606846974..1152921504606846975 ..
{                             = 1000000
{        Specifies the size of the interval.
{  title, t                   : string = ' Analyze Server Keypoints'
{        This strting is displayed on the listing.
{  output, o                  : file = $listing
{  status                     : var of status = $optional
{
{
{  These keypoints are emitted by various parts of the
{  operating system.  There must be an agreed upon data format for
{  each server keypoint omitted by the operating system and this
{  program.
{    REMOTE = TRUE,  local mainframe = FALSE
{    CATALOG = TRUE, permanent file = FALSE
{
{  The time processing part of this program assumes that there
{  is less than 268 seconds between arriving keypoints.
{  The clock field of the keypoint rolls over every 268 seconds.
{

?? NEWTITLE := '  GLOBAL XREFS', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amp$close
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc clp$close_display
*copyc clp$get_value
*copyc clp$new_display_page
*copyc clp$open_display
*copyc clp$put_display
*copyc clp$scan_parameter_list
*copyc mmp$create_scratch_segment
*copyc osp$set_status_abnormal
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pup$crack_name_list
*copyc pup$determine_if_all_selected
?? POP ??
?? OLDTITLE ??
?? NEWTITLE := '  GLOBAL TYPES', EJECT ??
*copyc dmt$system_file_id
?? SKIP := 9 ??
*copyc iot$io_function
?? SKIP := 9 ??
*copyc osk$common_keypoint_definitions
?? SKIP := 9 ??
*copyc ost$keypoint_environment
?? TITLE := ' FILE SERVER TYPES ', EJECT ??
*copyc dfd$file_server_info
?? SKIP := 9 ??
*copyc dfk$file_server_info_keypoints
?? TITLE := ' SUMMARY TABLES ', EJECT ??

  TYPE
    request_size_ordinal = (one_page, two_pages, three_pages, four_pages, five_to_nine_pages, ten_to_19_pages,
      twenty_to_29_pages, thirty_and_up_pages);

  TYPE
    request_size_range = one_page .. thirty_and_up_pages;




  TYPE
    io_function_record = record
      total_request_count: integer,
      total_page_count: integer,
      request_size_distribution: array [request_size_range] of integer,
    recend;

  TYPE
    io_functions = ioc$read_page .. ioc$keypoint_io;

  VAR
    non_pf_io_summary: array [io_functions] of io_function_record;

  VAR
    non_pf_close_count: integer := 0,
    non_pf_open_count: integer := 0;

?? SKIP := 8 ??
  { Catalog access summary

  VAR
    total_path_accesses: integer := 0,
    remote_path_accesses: integer := 0,
    accesses_for_read: integer := 0,
    total_catalog_depth: integer := 0,
    total_remote_cat_depth: integer := 0,
    accesses_by_owner: integer := 0;

?? EJECT ??

  { file summaries

  TYPE
    file_summary = record
      number_of_attaches: integer,
      number_of_creates: integer,
      number_of_opens: integer,
      number_of_closes: integer,
      number_of_deletes: integer,
      number_of_returns: integer,

      io_summary: array [io_functions] of io_function_record,

      { This is the attach of a file      not already attached
      number_of_unique_attaches: integer,
      { unique_return refers to the last return of the file in the system
      number_of_unique_returns: integer,

      { The following field is only used in time interval data
      transfer_count: integer,
      transfer_size: integer,

      { The following fields are not      used in time interval  records of this type
      {average_time_attached := total_time_all_attaches/ number_of_returns
      total_time_all_attaches: integer,
      current_attached: integer,
      max_number_attached: integer,
    recend;

  VAR
    attach_summary_table: array [boolean {local, remote} ] of array [boolean {file, catalog} ] of
      file_summary;

  VAR
    total_summary: file_summary;

  VAR
    initialized_summary: file_summary;

?? EJECT ??
{   time event analysis figures

  VAR
    overflowed_amount: integer := 0,
    first_keypoint_clock: 0 .. 0fffffff(16) := 0,
    last_keypoint_clock: 0 .. 0fffffff(16) := 0,
    current_keypoint_time: integer := 0,
    interval_number: integer := 0,
    time_start_of_run: integer := 0,
    time_start_of_interval: integer := 0,
    time_interval: integer := 0;

  VAR
    interval_path_accesses: integer := 0,
    interval_remote_path_accesses: integer := 0,
    interval_accesses_for_read: integer := 0,
    interval_total_catalog_depth: integer := 0,
    interval_total_remote_cat_depth: integer := 0,
    interval_accesses_by_owner: integer := 0;

  VAR
    time_interval_total: file_summary;

  TYPE
    low_or_high = (low, high),

    low_to_high = low .. high;

  VAR
    interval_range: array [low_to_high] of file_summary;

  CONST
    number_of_distributions = 20;

  VAR
    interval_distribution: array [0 .. number_of_distributions] of file_summary;

  VAR
    time_interval_summary_table: array [boolean {local, remote} ] of array [boolean {file, catalog} ] of
      file_summary;

  VAR
    interval_selection: array [boolean {local, remote} ] of array [boolean {file, catalog} ] of boolean :=
      [[FALSE, FALSE], [FALSE, FALSE]],

    total_interval_selected: boolean := FALSE;

  CONST
    attach_request_transfer_size = 400,
    create_file_transfer_size = 400,
    open_request_transfer_size = 100,
    close_request_transfer_size = 100,
    delete_request_transfer_size = 400,
    return_request_transfer_size = 100,
    io_page_size = 4096;



?? EJECT ??

  TYPE
    attached_file_entry = record
      case entry_type: (valid_entry, free_entry, damaged_entry) of
      = valid_entry, damaged_entry =
        catalog: {or file} boolean,
        remote: {or local} boolean,
        time_initially_attached: integer,
        attach_count: integer,
        number_of_opens: integer,
      = free_entry =
        ,
      casend,
    recend;

  VAR
    attached_file_table: array [gft$file_descriptor_index] of attached_file_entry;

?? TITLE := '  DISPLAY_TABLES', EJECT ??

  VAR
    display_control: clt$display_control;

  VAR
    title_string: string (72) := ' Process server keypoints';

  CONST
    integer_field_length = 6;

  TYPE
    display_options = (trace, summary, intervals, interval_histogram),

    display_selections = set of display_options;

  VAR
    display_option_selection_table: [READ] array [1 .. 8] of record
      name: ost$name,
      display_option_value: display_options,
    recend := [
      {} ['TRACE                          ', trace],
      {} ['T                              ', trace],
      {} ['INTERVALS                      ', intervals],
      {} ['I                              ', intervals],
      {} ['INTERVAL_HISTOGRAM             ', interval_histogram],
      {} ['IH                             ', interval_histogram],
      {} ['SUMMARY                        ', summary],
      {} ['S                              ', summary]];

  VAR
    interval_option_table: [READ] array [1 .. 6] of record
      name: ost$name,
      selection: array [boolean {local, remote} ] of array [boolean {file, catalog} ] of boolean,
    recend := [
      {} ['ALL                            ', [[TRUE, TRUE], [TRUE, TRUE]]],
      {} ['TOTAL                          ', [[FALSE, FALSE], [FALSE, FALSE]]],
      {} ['SYSTEM_FILE                    ', [[TRUE, FALSE], [FALSE, FALSE]]],
      {} ['SYSTEM_CATALOG                 ', [[FALSE, TRUE], [FALSE, FALSE]]],
      {} ['REMOTE_FILE                    ', [[FALSE, FALSE], [TRUE, FALSE]]],
      {} ['REMOTE_CATALOG                 ', [[FALSE, FALSE], [FALSE, TRUE]]]];

  VAR
    keypoint_name_table: [READ] array [dfk$file_server_info_base .. (dfk$file_server_info_base + 8)] of
      ost$name := [
      {} 'dfk$attach_info',
      {} 'dfk$catalog_access_info',
      {} 'dfk$close_info',
      {} 'dfk$create_info',
      {} 'dfk$delete_info',
      {} 'dfk$detach_sfid',
      {} 'dfk$open_info',
      {} 'dfk$pager_io_info',
      {} 'dfk$sfid'];

  VAR
    residence_name_table: [READ] array [gft$table_residence] of ost$name := [
      {} ' gfc$tr_null_residence',
      {} ' gfc$tr_system',
      {} ' gfc$tr_job',
      {} ' gfc$tr_system_wait_recovery'];

{ DECK: IOT$IO_FUNCTION (Definitions for interface to physical IO requests)

  VAR
    io_function_names: [READ] array [io_functions] of ost$name := [
      {} ' ioc$read_page',
      {} ' ioc$write_page',
      {} ' ioc$explicit_read',
      {} ' ioc$explicit_write',
      {} ' ioc$swap_in',
      {} ' ioc$swap_out',
      {} ' ioc$compare_swap',
      {} ' ioc$write_verify',
      {} ' ioc$read_uft',
      {} ' ioc$read_mass_storage',
      {} ' ioc$write_mass_storage',
      {} ' ioc$no_io',
      {} ' ioc$write_locked_page',
      {} ' ioc$keypoint_io'];

  VAR
    remote_name: [READ] array [boolean] of string (10) := [
      {} ' $SYSTEM',
      {} ' REMOTE'];

  VAR
    catalog_name: [READ] array [boolean] of string (10) := [
      {} ' FILE ',
      {} ' CATALOG'];

  VAR
    request_size_display: [READ] array [request_size_range] of string (18) := [
      {} ' 1 page  ',
      {} ' 2 pages  ',
      {} ' 3 pages  ',
      {} ' 4 pages  ',
      {} ' 5 - 9 pages  ',
      {} ' 10 - 19 pages  ',
      {} ' 20 - 29 pages  ',
      {} ' 30 -> pages  '];

  VAR
    interval_header_table: [READ] array [1 .. 14] of record
      size: 0 .. 40,
      header: string (40),
    recend := [
      {} [10, ' INTERVAL '],
      {} [10, ' REM PATHS'],
      {} [6, '  ATTF '],
      {} [6, '  CREF '],
      {} [6, '  OPEN '],
      {} [6, '  CLOS '],
      {} [6, '  DELE '],
      {} [6, '  RETR '],
      {} [10, ' READ RC'],
      {} [10, ' READ PC'],
      {} [10, ' WRIT RC'],
      {} [10, ' WRIT PC'],
      {} [10, ' TRAN CT'],
      {} [10, ' TRAN SI']];



?? TITLE := '  [XDCL] DFP$ANALYZE_SERVER_KEYPOINTS', EJECT ??

  PROCEDURE [XDCL] dfp$analyze_server_keypoints (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{ pdt analyze_server_keypoints (
{  keypoint_file, kf: file = $required
{  display_options, display_option, do: list of key trace, t, intervals, i, interval_histogram, ih, summary,..
{  s, all = summary
{  interval_catagory, ic: key of total, remote_catalog, remote_file, system_catalog, system_file, all ..
{   = remote_file
{  interval_microseconds, im: integer  = 1000000
{  title, t: string = ' Analyze Server Keypoints'
{  output, o: file = $listing
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      analyze_server_keypoints: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^analyze_server_keypoints_names, ^analyze_server_keypoints_params];

    VAR
      analyze_server_keypoints_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 14] of
        clt$parameter_name_descriptor := [['KEYPOINT_FILE', 1], ['KF', 1], ['DISPLAY_OPTIONS', 2], [
        'DISPLAY_OPTION', 2], ['DO', 2], ['INTERVAL_CATAGORY', 3], ['IC', 3], ['INTERVAL_MICROSECONDS', 4],
        ['IM', 4], ['TITLE', 5], ['T', 5], ['OUTPUT', 6], ['O', 6], ['STATUS', 7]];

    VAR
      analyze_server_keypoints_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 7] of
        clt$parameter_descriptor := [

{ KEYPOINT_FILE KF }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ DISPLAY_OPTIONS DISPLAY_OPTION DO }
      [[clc$optional_with_default, ^analyze_server_keypoints_dv2], 1, clc$max_value_sets, 1, 1,
        clc$value_range_not_allowed, [^analyze_server_keypoints_kv2, clc$keyword_value]],

{ INTERVAL_CATAGORY IC }
      [[clc$optional_with_default, ^analyze_server_keypoints_dv3], 1, 1, 1, 1, clc$value_range_not_allowed,
        [^analyze_server_keypoints_kv3, clc$keyword_value]],

{ INTERVAL_MICROSECONDS IM }
      [[clc$optional_with_default, ^analyze_server_keypoints_dv4], 1, 1, 1, 1, clc$value_range_not_allowed,
        [NIL, clc$integer_value, - 9223372036854775806, 9223372036854775807]],

{ TITLE T }
      [[clc$optional_with_default, ^analyze_server_keypoints_dv5], 1, 1, 1, 1, clc$value_range_not_allowed,
        [NIL, clc$string_value, 0, osc$max_string_size]],

{ OUTPUT O }
      [[clc$optional_with_default, ^analyze_server_keypoints_dv6], 1, 1, 1, 1, clc$value_range_not_allowed,
        [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      analyze_server_keypoints_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 9] of ost$name :=
        ['TRACE', 'T', 'INTERVALS', 'I', 'INTERVAL_HISTOGRAM', 'IH', 'SUMMARY', 'S', 'ALL'];

    VAR
      analyze_server_keypoints_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of ost$name :=
        ['OF', 'TOTAL', 'REMOTE_CATALOG', 'REMOTE_FILE', 'SYSTEM_CATALOG', 'SYSTEM_FILE', 'ALL'];

    VAR
      analyze_server_keypoints_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := 'summary';

    VAR
      analyze_server_keypoints_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (11) := 'remote_file';

    VAR
      analyze_server_keypoints_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '1000000';

    VAR
      analyze_server_keypoints_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (27) :=
        ''' Analyze Server Keypoints''';

    VAR
      analyze_server_keypoints_dv6: [STATIC, READ, cls$pdt_names_and_defaults] string (8) := '$listing';

?? POP ??

    VAR
      catalog: boolean,
      display_selection_set: display_selections,
      first_keypoint: boolean,
      keypoint_file_id: amt$file_identifier,
      keypoint_file_value: clt$value,
      number_of_keypoints: integer,
      output_value: clt$value,
      p_interval_summary: ^file_summary,
      pointer: amt$segment_pointer,
      p_intervals: ^SEQ ( * ),
      p_class_15_keypoint: ^ost$class_15_keypoint,
      p_keypoint: ^ost$keypoint,
      p_keypoint_file: ^SEQ ( * ),
      p_sfid_keypoint: ^ost$keypoint,
      p_word_alignment: ^array [1 .. * ] of cell,
      read_attribute: array [1 .. 1] of amt$file_item,
      remote: boolean,
      segment_pointer: amt$segment_pointer,
      word_alignment_length: integer;

?? EJECT ??

    number_of_keypoints := 0;
    first_keypoint := TRUE;
    initialize_summary_tables;

    { Crack the parameters, and prepare the files for access
    clp$scan_parameter_list (parameter_list, analyze_server_keypoints, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('KEYPOINT_FILE', 1, 1, clc$low, keypoint_file_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    read_attribute [1].key := amc$access_mode;
    read_attribute [1].access_mode := $pft$usage_selections [pfc$read];
    amp$open (keypoint_file_value.file.local_file_name, amc$segment, ^read_attribute, keypoint_file_id,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    amp$get_segment_pointer (keypoint_file_id, amc$sequence_pointer, segment_pointer, status);

    crack_display_options ('DISPLAY_OPTIONS', display_selection_set, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (intervals IN display_selection_set) OR (interval_histogram IN display_selection_set) THEN
      crack_interval_catagory ('INTERVAL_CATAGORY', status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$get_value ('INTERVAL_MICROSECONDS', 1, 1, clc$low, output_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      time_interval := output_value.int.value;
      display_integer (' Time interval (microseconds) : ', time_interval);
    IFEND;

    IF (interval_histogram IN display_selection_set) THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      initialize_interval_range;
      p_intervals := pointer.sequence_pointer;
      RESET p_intervals;
    IFEND;
    clp$get_value ('OUTPUT', 1, 1, clc$low, output_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$open_display (output_value.file, NIL, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('TITLE', 1, 1, clc$low, output_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    title_string := output_value.str.value (1, output_value.str.size);
    display (' ----------------------------------------');
    display (title_string);
    IF intervals IN display_selection_set THEN
      display_time (' Time interval  : ', time_interval);
      display_time_interval_title;
    IFEND;

    word_alignment_length := 8 - (#SIZE (ost$class_15_keypoint) MOD 8);
    IF word_alignment_length = 8 THEN
      word_alignment_length := 0;
    IFEND;

    p_keypoint_file := segment_pointer.sequence_pointer;
    RESET p_keypoint_file;

    { This loop attains all the keypoints on the keypoint file.

  /files_open/
    WHILE TRUE DO
      NEXT p_keypoint IN p_keypoint_file;
      IF p_keypoint = NIL THEN
        EXIT /files_open/;
      IFEND;

      IF p_keypoint^.keypoint_class = osk$pmf_control THEN
        { Skip over the pmf keypoint, and position to the next
        {keypoint (word aligned).

        RESET p_keypoint_file TO p_keypoint;
        NEXT p_class_15_keypoint IN p_keypoint_file;
        IF p_class_15_keypoint = NIL THEN
          EXIT /files_open/
        IFEND;
        IF trace IN display_selection_set THEN
          display_pmf_keypoint (p_class_15_keypoint^);
        IFEND;
        IF word_alignment_length <> 0 THEN { skip to next keypoint }
          NEXT p_word_alignment: [1 .. word_alignment_length] IN p_keypoint_file;
        IFEND;
        CYCLE /files_open/;
      IFEND;

      IF p_keypoint^.keypoint_class = dfk$file_server_info_class THEN
        number_of_keypoints := number_of_keypoints + 1;

        { handle keypoint clock
        {current _keypoint_time is the               number of microseconds  since  the first keypoint
        IF first_keypoint THEN
          first_keypoint := FALSE;
          time_start_of_run := 0;
          time_start_of_interval := 0;
          interval_number := 1;
          overflowed_amount := 0;
          first_keypoint_clock := p_keypoint^.clock;
        ELSEIF p_keypoint^.clock < last_keypoint_clock THEN
          { overflow
          overflowed_amount := overflowed_amount + 0fffffff(16);
        IFEND;
        current_keypoint_time := p_keypoint^.clock + overflowed_amount - first_keypoint_clock;
        last_keypoint_clock := p_keypoint^.clock;
        IF current_keypoint_time >= (time_start_of_interval + time_interval) THEN
          { new time interval
          IF intervals IN display_selection_set THEN
            display_time_interval;
          IFEND;
          IF interval_histogram IN display_selection_set THEN
            NEXT p_interval_summary IN p_intervals;
            IF total_interval_selected THEN
              display_time_interval_line (time_interval_total);
              record_interval_range (time_interval_total);
              p_interval_summary^ := time_interval_total;
            ELSE
              FOR remote := FALSE TO TRUE DO
                FOR catalog := FALSE TO TRUE DO
                  IF interval_selection [remote] [catalog] THEN
                    record_interval_range (time_interval_summary_table [remote] [catalog]);
                    p_interval_summary^ := time_interval_summary_table [remote] [catalog];
                  IFEND;
                FOREND;
              FOREND;
            IFEND;
          IFEND;
          time_start_of_interval := time_start_of_interval + time_interval;
          interval_number := 1 + interval_number;

          { re-initalize the interval tables
          time_interval_total := initialized_summary;
          FOR remote := FALSE TO TRUE DO
            FOR catalog := FALSE TO TRUE DO
              time_interval_summary_table [remote] [catalog] := initialized_summary;
            FOREND;
          FOREND;
          interval_path_accesses := 0;
          interval_remote_path_accesses := 0;
          interval_accesses_for_read := 0;
          interval_total_catalog_depth := 0;
          interval_total_remote_cat_depth := 0;
          interval_accesses_by_owner := 0;
        IFEND;

        CASE p_keypoint^.keypoint_code OF
        = dfk$attach_info =
          { Imbedded locations:
          {pfp$attach_permanent_file\pfm$file_system_interfaces
          {Added remote_catalog boolean                                    on  pfp$attach_catalog
          {pfp$physically_attach_catalog, pfp$access_next_catalog
          {pfp$internal_access_object

          NEXT p_sfid_keypoint IN p_keypoint_file;
          IF p_sfid_keypoint = NIL THEN
            EXIT /files_open/;
          ELSEIF p_sfid_keypoint^.keypoint_code <> dfk$sfid THEN
            display (' unexpected keypoint found - after attach ');
            display_unknown_keypoint (p_sfid_keypoint^);
            CYCLE /files_open/;
          IFEND;
          IF trace IN display_selection_set THEN
            display_file_operation_keypoint (p_keypoint^);
            display_sfid_keypoint (p_sfid_keypoint^);
          IFEND;
          record_attach (p_keypoint^, p_sfid_keypoint^, FALSE);

        = dfk$create_info =
          { Imbedded locations:
          {modified pfp$create_permanent_file to have path
          {Modify pfp$create_catalog_object to have path
          NEXT p_sfid_keypoint IN p_keypoint_file;
          IF p_sfid_keypoint = NIL THEN
            EXIT /files_open/;
          ELSEIF p_sfid_keypoint^.keypoint_code <> dfk$sfid THEN
            display (' unexpected keypoint found  - after create');
            display_unknown_keypoint (p_sfid_keypoint^);
            CYCLE /files_open/;
          IFEND;
          IF trace IN display_selection_set THEN
            display_file_operation_keypoint (p_keypoint^);
            display_sfid_keypoint (p_sfid_keypoint^);
          IFEND;
          record_attach (p_keypoint^, p_sfid_keypoint^, TRUE);

        = dfk$catalog_access_info =
          { Imbedded locations:
          {pfp$get_catalog\pfm$catalog_access_methods
          {pfp$internal_access_object
          record_catalog_access_info (p_keypoint^);
          IF trace IN display_selection_set THEN
            display_catalog_access_keypoint (p_keypoint^);
          IFEND;

        = dfk$detach_sfid =
          { Imbedded locations:
          {pfp$detach_permanent_file\pfm$file_system_interfaces
          {physically_detach_catalog\pfm$file_system_interfaces
          record_detach (p_keypoint^);
          IF trace IN display_selection_set THEN
            display_sfid_keypoint (p_keypoint^);
          IFEND;

        = dfk$pager_io_info =
          { Imbedded locations:
          {iop$pager_io\iom$queue_request
          NEXT p_sfid_keypoint IN p_keypoint_file;
          IF p_sfid_keypoint = NIL THEN
            EXIT /files_open/;
          ELSEIF p_sfid_keypoint^.keypoint_code <> dfk$sfid THEN
            display (' unexpected keypoint found - after pager io');
            display_unknown_keypoint (p_sfid_keypoint^);
            CYCLE /files_open/;
          IFEND;
          record_pager_io (p_keypoint^, p_sfid_keypoint^);
          IF trace IN display_selection_set THEN
            display_io_keypoint (p_keypoint^);
            display_sfid_keypoint (p_sfid_keypoint^);
          IFEND;

        = dfk$open_info =
          { Imbedded locations:
          {mmp$Open_file_segment\mmm$segment_manager_job_temp
          IF trace IN display_selection_set THEN
            display_sfid_keypoint (p_keypoint^);
          IFEND;
          record_open (p_keypoint^);


        = dfk$close_info =
          { Imbedded locations:
          {mmp$close_segment\mmm$segment_manager_job_temp
          IF trace IN display_selection_set THEN
            display_sfid_keypoint (p_keypoint^);
          IFEND;
          record_close (p_keypoint^);

        = dfk$delete_info =
          { Imbedded locations:
          {purge_cycle\pfm$r2_request_processor
          {pfp$destroy_catalog
          IF trace IN display_selection_set THEN
            display_file_operation_keypoint (p_keypoint^);
          IFEND;
          convert_keypoint_to_operation (p_keypoint^, catalog, remote);
          IF catalog THEN
            { A delete for a catalog is accompanied with an sfid
            {which must be used to determine remote or local.
            NEXT p_sfid_keypoint IN p_keypoint_file;
            IF p_sfid_keypoint = NIL THEN
              EXIT /files_open/;
            ELSEIF p_sfid_keypoint^.keypoint_code <> dfk$sfid THEN
              display (' unexpected keypoint found  - delete_catalog');
              display_unknown_keypoint (p_sfid_keypoint^);
              CYCLE /files_open/;
            IFEND;
            IF trace IN display_selection_set THEN
              display_sfid_keypoint (p_sfid_keypoint^);
            IFEND;
            record_delete_catalog (remote, p_sfid_keypoint^);
          ELSE { file
            record_delete_file (remote);
          IFEND;

        ELSE
          display (' Unexpected keypoint code');
          display_unknown_keypoint (p_sfid_keypoint^);
        CASEND;
      ELSE { non server keypoint
        IF trace IN display_selection_set THEN
          display_unknown_keypoint (p_keypoint^);
        IFEND;
      IFEND;
    WHILEND /files_open/;

    display_integer (' Total number of keypoints  (or pairs) = ', number_of_keypoints);
    display_time (' Time of run  = ', current_keypoint_time);

    IF interval_histogram IN display_selection_set THEN
      display_time (' Time interval  : ', time_interval);
      display_interval_histogram ((interval_number - 1), p_intervals);
    IFEND;

    IF summary IN display_selection_set THEN
      display_summary_tables;
    IFEND;

    { close files }
    clp$close_display (display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    amp$close (keypoint_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
  PROCEND dfp$analyze_server_keypoints;
  ?? TITLE := ' compute_transfer_totals', EJECT ??

  PROCEDURE compute_transfer_totals (summary: file_summary;
    VAR transfer_count: integer;
    VAR transfer_size: integer);


    VAR
      io_func: io_functions;


    transfer_count := 0;
    transfer_size := 0;

    transfer_count := transfer_count + summary.number_of_attaches;
    transfer_size := transfer_size + summary.number_of_attaches * attach_request_transfer_size;

    transfer_count := transfer_count + summary.number_of_creates;
    transfer_size := transfer_size + summary.number_of_creates * create_file_transfer_size;

    transfer_count := transfer_count + summary.number_of_opens;
    transfer_size := transfer_size + summary.number_of_opens * open_request_transfer_size;

    transfer_count := transfer_count + summary.number_of_closes;
    transfer_size := transfer_size + summary.number_of_closes * close_request_transfer_size;

    transfer_count := transfer_count + summary.number_of_deletes;
    transfer_size := transfer_size + summary.number_of_deletes * delete_request_transfer_size;


    transfer_count := transfer_count + summary.number_of_returns;
    transfer_size := transfer_size + summary.number_of_returns * return_request_transfer_size;

    FOR io_func := LOWERVALUE (io_func) TO UPPERVALUE (io_func) DO
      transfer_count := transfer_count + summary.io_summary [io_func].total_request_count;
      transfer_size := transfer_size + summary.io_summary [io_func].total_page_count * io_page_size;
    FOREND;
  PROCEND compute_transfer_totals;
  ?? TITLE := 'convert_keypoint_to_cat', EJECT ??

  PROCEDURE convert_keypoint_to_cat (keypoint: ost$keypoint;
    VAR remote_catalog: boolean;
    VAR catalog_owner: boolean;
    VAR catalog_depth: integer;
    VAR read_access: boolean);

    VAR
      data_converter: dft$keypoint_catalog_summary;

    data_converter.keypoint_data := keypoint.keypoint_data;
    remote_catalog := data_converter.remote_catalog;
    catalog_owner := data_converter.catalog_owner;
    catalog_depth := data_converter.catalog_depth;
    read_access := data_converter.read_access;
  PROCEND convert_keypoint_to_cat;

?? TITLE := 'convert_keypoint_to_io_function', EJECT ??

  PROCEDURE convert_keypoint_to_io_function (keypoint: ost$keypoint;
    VAR io_function: iot$io_function;
    VAR page_count: integer);

    VAR
      data_converter: dft$keypoint_pager_io;

    data_converter.keypoint_data := keypoint.keypoint_data;
    io_function := data_converter.io_function;
    page_count := data_converter.pages;

  PROCEND convert_keypoint_to_io_function;

?? TITLE := '    convert_keypoint_to_operation ', EJECT ??

  PROCEDURE convert_keypoint_to_operation (keypoint: ost$keypoint;
    VAR catalog: boolean;
    VAR remote: boolean);

    VAR
      data_converter: dft$keypoint_file_operation;

    data_converter.keypoint_data := keypoint.keypoint_data;
    catalog := data_converter.catalog;
    remote := data_converter.remote;
  PROCEND convert_keypoint_to_operation;
?? TITLE := '    convert_keypoint_to_sfid ', EJECT ??

  PROCEDURE convert_keypoint_to_sfid (keypoint: ost$keypoint;
    VAR file_entry_index: gft$file_descriptor_index;
    VAR residence: gft$table_residence);

    VAR
      data_converter: dft$keypoint_sfid;

    data_converter.keypoint_data := keypoint.keypoint_data;
    file_entry_index := data_converter.file_entry_index;
    residence := data_converter.residence;
  PROCEND convert_keypoint_to_sfid;
?? TITLE := ' convert_page_count_to_ordinal', EJECT ??

  PROCEDURE convert_page_count_to_ordinal (page_count: integer;
    VAR request_size: request_size_ordinal);

    CASE page_count OF
    = 1 =
      request_size := one_page;
    = 2 =
      request_size := two_pages;
    = 3 =
      request_size := three_pages;
    = 4 =
      request_size := four_pages;
    = 5 .. 9 =
      request_size := five_to_nine_pages;
    = 10 .. 19 =
      request_size := ten_to_19_pages;
    = 20 .. 29 =
      request_size := twenty_to_29_pages
    ELSE
      request_size := thirty_and_up_pages;
    CASEND;
  PROCEND convert_page_count_to_ordinal;
  ?? TITLE := ' crack_display_options', EJECT ??

  PROCEDURE crack_display_options (parameter_name: string ( * );
    VAR display_selection: display_selections;
    VAR status: ost$status);

    VAR
      all_selected: boolean,
      display_option: display_options,
      i: 1 .. 20,
      name_list_container: SEQ (REP 20 of ost$name),
      p_name_list: ^array [1 .. * ] of ost$name;

    pup$crack_name_list (parameter_name, name_list_container, p_name_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$determine_if_all_selected (p_name_list^, parameter_name, all_selected, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF all_selected THEN
      display_selection := - $display_selections [];
    ELSE
      display_selection := $display_selections [];
      FOR i := 1 TO UPPERBOUND (p_name_list^) DO
        convert_name_to_do (p_name_list^ [i], display_option, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        display_selection := display_selection + $display_selections [display_option];
      FOREND;
    IFEND;

  PROCEND crack_display_options;

?? TITLE := '  crack_interval_catagory  ', EJECT ??

  PROCEDURE crack_interval_catagory (parameter_name: string ( * );
    VAR status: ost$status);

    VAR
      value: clt$value,
      i: integer;

    clp$get_value (parameter_name, 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    total_interval_selected := value.name.value = 'TOTAL                          ';

    FOR i := 1 TO UPPERBOUND (interval_option_table) DO
      IF interval_option_table [i].name = value.name.value THEN
        interval_selection := interval_option_table [i].selection;
        RETURN;
      IFEND;
    FOREND;
    osp$set_status_abnormal ('DF', cle$name_not_a_keyword_value, value.name.value, status);
  PROCEND crack_interval_catagory;

?? TITLE := '    convert_name_to_do ', EJECT ??

  PROCEDURE convert_name_to_do (name: ost$name;
    VAR display_option: display_options;
    VAR status: ost$status);

    VAR
      i: integer;

    status.normal := TRUE;
    FOR i := 1 TO UPPERBOUND (display_option_selection_table) DO
      IF display_option_selection_table [i].name = name THEN
        display_option := display_option_selection_table [i].display_option_value;
        RETURN;
      IFEND;
    FOREND;
    osp$set_status_abnormal ('DF', cle$name_not_a_keyword_value, name, status);
  PROCEND convert_name_to_do;

?? TITLE := ' display ', EJECT ??

  PROCEDURE display (display_string: string ( * ));

    VAR
      status: ost$status;

    IF display_string = ' ' THEN
      clp$put_display (display_control, display_string, clc$no_trim, status);
    ELSE
      clp$put_display (display_control, display_string, clc$trim, status);
    IFEND;
  PROCEND display;
?? TITLE := ' display_catalog_access_keypoint', EJECT ??

  PROCEDURE display_catalog_access_keypoint (catalog_summary_keypoint: ost$keypoint);

    VAR
      access_string: string (8),
      catalog_depth: integer,
      catalog_owner: boolean,
      length: integer,
      owner_string: string (9),
      read_access: boolean,
      remote_catalog: boolean,
      working_string: string (200);

    convert_keypoint_to_cat (catalog_summary_keypoint, remote_catalog, catalog_owner, catalog_depth,
          read_access);

    IF catalog_owner THEN
      owner_string := 'OWNER';
    ELSE
      owner_string := 'NOT-OWNER';
    IFEND;

    IF read_access THEN
      access_string := 'READ';
    ELSE
      access_string := 'WRITE';
    IFEND;

    STRINGREP (working_string, length, ' ', catalog_summary_keypoint.clock, ' ', keypoint_name_table
          [catalog_summary_keypoint.keypoint_code], '   catalog summary  ', remote_name [remote_catalog], ' ',
          owner_string, ' depth= ', catalog_depth, ' ', access_string);
    display (working_string (1, length));
  PROCEND display_catalog_access_keypoint;
?? TITLE := ' display_distribution', EJECT ??

  PROCEDURE display_distribution (descriptor: string ( * );
        special_case_zero: boolean;
        distribution: array [ * ] OF integer;
        low_value: integer;
        high_value: integer;
        total_requests: integer);

    CONST
      bar_size = 50;

    VAR
      working_low: integer,
      bar: string (bar_size),
      distribution_point: integer,
      length: integer,
      number_of_stars: integer,
      point_low: real,
      point_high: real,
      output: string (120),
      star_bar: [STATIC, READ] string (bar_size) := '**************************************************';

    STRINGREP (output, length, descriptor, 'Total range: ', low_value, ' .. ', high_value,
      '   Total number intervals ', total_requests);
    display (output (1, length));
    IF total_requests <= 0 THEN
      display ('  No requests --- No distribution ');
      RETURN;
    IFEND;

    IF special_case_zero AND (low_value = 0) THEN
      working_low := 1;
    ELSE
      working_low := low_value;
    IFEND;
    FOR distribution_point := LOWERBOUND (distribution) TO UPPERBOUND (distribution) DO
      output := ' ';
      bar := ' ';
      number_of_stars := (distribution [distribution_point] * STRLENGTH (bar)) DIV total_requests;
      bar ((STRLENGTH (bar) + 1 - number_of_stars), * ) := star_bar;
      IF (number_of_stars = 0) AND (distribution [distribution_point] > 0) THEN
        bar (STRLENGTH (bar), 1) := '.';
      IFEND;

      { compute the low and high for   this range
      IF (distribution_point = 0) AND special_case_zero THEN
        point_low := 0.0;
        point_high := 0.0;
      ELSE
        point_low := $REAL (working_low) + ($REAL (distribution_point - 1) * range_point_size (working_low,
              high_value, number_of_distributions));
        point_high := point_low + range_point_size (working_low, high_value, number_of_distributions);
      IFEND;
      STRINGREP (output, length, ' ', bar, ' Range ', point_low: 14: 2, ' .. ', point_high: 14: 2,
        '    count: ', distribution [distribution_point]);
      display (output (1, length));
    FOREND;

  PROCEND display_distribution;
?? TITLE := ' display_file_operation_keypoint ', EJECT ??

  PROCEDURE display_file_operation_keypoint (file_operation_keypoint: ost$keypoint);

    VAR
      catalog: boolean,
      length: integer,
      remote: boolean,
      working_string: string (200);

    convert_keypoint_to_operation (file_operation_keypoint, catalog, remote);

    STRINGREP (working_string, length, ' ', file_operation_keypoint.clock, ' ', keypoint_name_table
          [file_operation_keypoint.keypoint_code], '   file operation  ', remote_name [remote], ' ',
          catalog_name [catalog]);
    display (working_string (1, length));
  PROCEND display_file_operation_keypoint;
?? TITLE := ' display_file_summary', EJECT ??

  PROCEDURE display_file_summary (summary_table: file_summary);

    VAR
      functions: io_functions,
      length: integer,
      transfer_count: integer,
      transfer_size: integer,
      working_string: string (200);

    display_integer (' Number of attaches: ', summary_table.number_of_attaches);
    display_integer (' Number of creates: ', summary_table.number_of_creates);
    display_integer (' Number of opens: ', summary_table.number_of_opens);
    display_integer (' Number of closes: ', summary_table.number_of_closes);
    display_integer (' Number of deletes: ', summary_table.number_of_deletes);
    display_integer (' Number of returns: ', summary_table.number_of_returns);
    display_integer (' Attaches of file not already attached: ', summary_table.number_of_unique_attaches);
    display_integer (' Number of final returns: ', summary_table.number_of_unique_returns);
    IF summary_table.number_of_returns > 0 THEN
      display_time (' Average attach time: ', summary_table.total_time_all_attaches DIV
           summary_table.number_of_returns);
    ELSE
      display (' Average attach time: -- No attaches ');
    IFEND;
    display_integer (' Maximum attached at any time ', summary_table.max_number_attached);

    display_io_function (summary_table.io_summary);

    compute_transfer_totals (summary_table, transfer_count, transfer_size);
    display_integer (' Total transfer count: ', transfer_count);
    display_integer (' Total transfer size: ', transfer_size);
    IF transfer_count > 0 THEN
      display_integer (' Average transfer size: ', $INTEGER ($REAL (transfer_size) /
           ($REAL (transfer_count))));
    ELSE
      display (' Average transfer size: -- No transfers ');
    IFEND;
    display_real (' Transfer count (requests per second): ', ($REAL (transfer_count) / ($REAL
          (current_keypoint_time) / 1000000.0)));
    display_real (' Transfer rate (bytes per second) ', ($REAL (transfer_size) / ($REAL
          (current_keypoint_time) / 1000000.0)));

  PROCEND display_file_summary;
?? TITLE := ' display_integer ', EJECT ??

  PROCEDURE display_integer (display_string: string ( * <= 256);
        display_int: integer);

    VAR
      length: integer,
      status: ost$status,
      working_string: string (256);

    STRINGREP (working_string, length, display_string, display_int);
    clp$put_display (display_control, working_string (1, length), clc$trim, status);
  PROCEND display_integer;
?? TITLE := ' display_interval_histogram', EJECT ??

  PROCEDURE display_interval_histogram (number_of_intervals: integer;
    VAR p_interval_file: ^SEQ ( * ));

    CONST
      special_case_zero = TRUE;

    VAR
      interval_number: integer,
      point: integer,
      single_item_array: array [0 .. number_of_distributions] of integer,
      p_current_interval: ^file_summary;

{ COMPUTE interval distributions
    RESET p_interval_file;
    FOR interval_number := 1 TO number_of_intervals DO
      NEXT p_current_interval IN p_interval_file;
      IF p_current_interval = NIL THEN
        display_integer (' NIL interval and number ', interval_number);
        RETURN;
      IFEND;

      { ATTACH
      point := interval_distribution_index (interval_range [low].number_of_attaches, interval_range [high].
            number_of_attaches, number_of_distributions, special_case_zero, p_current_interval^.
            number_of_attaches);
      interval_distribution [point].number_of_attaches := interval_distribution [point].number_of_attaches +
            1;

      { TRANSFER SIZE
      point := interval_distribution_index (interval_range [low].transfer_size, interval_range [high].
            transfer_size, number_of_distributions, special_case_zero, p_current_interval^.transfer_size);
      interval_distribution [point].transfer_size := interval_distribution [point].transfer_size + 1;

      { TRANSFER COUNT
      point := interval_distribution_index (interval_range [low].transfer_count, interval_range [high].
            transfer_count, number_of_distributions, special_case_zero, p_current_interval^.transfer_count);
      interval_distribution [point].transfer_count := interval_distribution [point].transfer_count + 1;
    FOREND;

    { DISPLAY interval distribution
    {ATTACH
    FOR point := 0 TO number_of_distributions DO
      single_item_array [point] := interval_distribution [point].number_of_attaches;
    FOREND;
    display_new_page;
    display_distribution (' ATTACH_FILE ', special_case_zero, single_item_array, interval_range [low].
          number_of_attaches, interval_range [high].number_of_attaches, number_of_intervals);

    { transfer_count
    FOR point := 0 TO number_of_distributions DO
      single_item_array [point] := interval_distribution [point].transfer_count;
    FOREND;
    display_distribution (' TRANSACTION  COUNT ', special_case_zero, single_item_array, interval_range [low].
          transfer_count, interval_range [high].transfer_count, number_of_intervals);

    { request size
    FOR point := 0 TO number_of_distributions DO
      single_item_array [point] := interval_distribution [point].transfer_size;
    FOREND;
    display_distribution (' TOTAL TRANSFER AMOUNT ', special_case_zero, single_item_array, interval_range
          [low].transfer_size, interval_range [high].transfer_size, number_of_intervals);

  PROCEND display_interval_histogram;


?? TITLE := ' display_io_function', EJECT ??

  PROCEDURE display_io_function (io_summary: array [io_functions] OF io_function_record);

    VAR
      functions: io_functions,
      length: integer,
      working_string: string (200);

    display (' ');
    display (' IO summary ');
    FOR functions := LOWERVALUE (functions) TO UPPERVALUE (functions) DO
      IF io_summary [functions].total_request_count > 0 THEN
        display (' ');
        STRINGREP (working_string, length, io_function_names [functions], ' request count = ', io_summary
              [functions].total_request_count, '      page count = ', io_summary [functions].
              total_page_count);
        display (working_string (1, length));
        display_io_distribution (io_summary [functions].total_request_count, io_summary [functions].
              request_size_distribution);
      IFEND;
    FOREND;
  PROCEND display_io_function;

?? TITLE := ' display_io_distribution ', EJECT ??

  PROCEDURE display_io_distribution (total_requests: integer;
        distribution: array [request_size_range] OF integer);

    CONST
      bar_size = 38;

    VAR
      bar: string (bar_size),
      index: request_size_ordinal,
      length: integer,
      number_of_stars: integer,
      output: string (80),
      star_bar: [STATIC, READ] string (bar_size) := '**************************************';

    IF total_requests <= 0 THEN
      display (' -- no requests --');
      RETURN;
    IFEND;

    display (' Distribution of request counts for page sizes within this io function');
    FOR index := LOWERVALUE (request_size_ordinal) TO UPPERVALUE (request_size_ordinal) DO
      output := ' ';
      bar := ' ';
      number_of_stars := (distribution [index] * STRLENGTH (bar)) DIV total_requests;
      bar ((STRLENGTH (bar) + 1 - number_of_stars), * ) := star_bar;
      IF (number_of_stars = 0) AND (distribution [index] > 0) THEN
        bar (STRLENGTH (bar), 1) := '.';
      IFEND;
      STRINGREP (output, length, ' ', bar, request_size_display [index], ' request count: ', distribution
            [index]);
      display (output (1, length));
    FOREND;

  PROCEND display_io_distribution;
?? TITLE := ' display_io_keypoint ', EJECT ??

  PROCEDURE display_io_keypoint (io_keypoint: ost$keypoint);

    VAR
      io_function: iot$io_function,
      length: integer,
      page_count: integer,
      working_string: string (256);

    convert_keypoint_to_io_function (io_keypoint, io_function, page_count);
    STRINGREP (working_string, length, ' ', io_keypoint.clock, ' ', keypoint_name_table [io_keypoint.
          keypoint_code], '   io operation  ', io_function_names [io_function], ' ', ' pages =', page_count);
    display (working_string (1, length));
  PROCEND display_io_keypoint;

?? TITLE := ' display_new_page ', EJECT ??

  PROCEDURE display_new_page;

    VAR
      status: ost$status;

    clp$new_display_page (display_control, status);
  PROCEND display_new_page;
?? TITLE := 'display_pmf_keypoint', EJECT ??

  PROCEDURE display_pmf_keypoint (pmf_keypoint: ost$class_15_keypoint);

    VAR
      ignore: ost$status,
      date: ost$date,
      time: ost$time,
      length: integer,
      working_string: string (256);

    pmp$format_compact_time (pmf_keypoint.date_time, osc$millisecond_time, time, ignore);
    pmp$format_compact_date (pmf_keypoint.date_time, osc$month_date, date, ignore);
    STRINGREP (working_string, length, ' PMF time ', time.millisecond, ' ', date.month, ' clock ',
          pmf_keypoint.microsecond_clock, ' user_data ', pmf_keypoint.user_data);
    display (working_string (1, length));
    display_unknown_keypoint (pmf_keypoint.keypoint);
    display (' end PMF ');
  PROCEND display_pmf_keypoint;

?? TITLE := ' display_real ', EJECT ??

  PROCEDURE display_real (display_string: string ( * <= 256);
        display_r: real);

    VAR
      length: integer,
      status: ost$status,
      working_string: string (256);

    STRINGREP (working_string, length, display_string, display_r: 20: 4);
    clp$put_display (display_control, working_string (1, length), clc$trim, status);
  PROCEND display_real;
?? TITLE := ' display_summary_table ', EJECT ??

  PROCEDURE display_summary_tables;

    VAR
      catalog: boolean,
      length: integer,
      remote: boolean,
      working_string: string (200);

    display_new_page;
    display (title_string);
    display (' Catalog access summary ');
    display_integer (' Total paths accessed:  ', total_path_accesses);
    display_integer (' Remote path accesses: ', remote_path_accesses);
    display (' ');
    display_integer (' Total catalog depth: ', total_catalog_depth);
    display_integer (' Remote catalog depth: ', total_remote_cat_depth);
    display (' ');
    display_integer (' Last catalog in path accessed for read: ', accesses_for_read);
    display_integer (' Accesses by owner: ', accesses_by_owner);

    FOR remote := FALSE TO TRUE DO
      FOR catalog := FALSE TO TRUE DO
        display_new_page;
        STRINGREP (working_string, length, ' ', remote_name [remote], '   ', catalog_name [catalog]);
        display (working_string (1, length));
        display_file_summary (attach_summary_table [remote] [catalog]);
      FOREND;
    FOREND;

    display_new_page;
    display (' Non permanent file or catalog summary');
    display_integer (' Number of opens: ', non_pf_open_count);
    display_integer (' Number of closes: ', non_pf_close_count);
    display_io_function (non_pf_io_summary);

    display_new_page;
    display (' TOTALS - all activity');
    display (title_string);
    display_file_summary (total_summary);

  PROCEND display_summary_tables;
?? TITLE := ' display_sfid_keypoint ', EJECT ??

  PROCEDURE display_sfid_keypoint (sfid_keypoint: ost$keypoint);

    VAR
      file_entry_index: gft$file_descriptor_index,
      length: integer,
      residence: gft$table_residence,
      working_string: string (200);

    convert_keypoint_to_sfid (sfid_keypoint, file_entry_index, residence);

    STRINGREP (working_string, length, ' ', sfid_keypoint.clock, ' ', keypoint_name_table [sfid_keypoint.
          keypoint_code], '     sfid ', residence_name_table [residence], '  ', file_entry_index);
    display (working_string (1, length));
  PROCEND display_sfid_keypoint;
?? TITLE := ' display_time ', EJECT ??

  PROCEDURE display_time (descriptor: string ( * );
        microseconds: integer);

    VAR
      length: integer,
      working_string: string (200);

    IF microseconds >= 3600000000 THEN
      STRINGREP (working_string, length, ' ', descriptor, ($REAL (microseconds) / 3600000000.0): 20: 4,
        '  hours');
    ELSEIF microseconds >= 60000000 THEN
      STRINGREP (working_string, length, ' ', descriptor, ($REAL (microseconds) / 60000000.0): 20: 4,
        ' minutes');
    ELSEIF microseconds >= 1000000 THEN
      STRINGREP (working_string, length, ' ', descriptor, ($REAL (microseconds) / 1000000.0): 20: 4,
        ' seconds ');
    ELSEIF microseconds >= 1000 THEN
      STRINGREP (working_string, length, ' ', descriptor, ($REAL (microseconds) / 1000.0): 20: 4,
        ' milliseconds');
    ELSE
      STRINGREP (working_string, length, ' ', descriptor, $REAL (microseconds): 20: 4, 'microseconds');
    IFEND;
    display (working_string (1, length));

  PROCEND display_time;
?? TITLE := ' display_time_interval', EJECT ??

  PROCEDURE display_time_interval;

    VAR
      remote: boolean,
      catalog: boolean;

    IF total_interval_selected THEN
      display_time_interval_line (time_interval_total);
    IFEND;
    FOR remote := FALSE TO TRUE DO
      FOR catalog := FALSE TO TRUE DO
        IF interval_selection [remote] [catalog] THEN
          display_time_interval_line (time_interval_summary_table [remote] [catalog]);
        IFEND;
      FOREND;
    FOREND;
  PROCEND display_time_interval;
?? TITLE := ' display_time_interval_line', EJECT ??

  PROCEDURE display_time_interval_line (summary: file_summary);

    VAR
      transfer_count: integer,
      transfer_size: integer,
      working_string: string (128),
      length: integer;

    compute_transfer_totals (summary, transfer_count, transfer_size);

    STRINGREP (working_string, length, interval_number: 9, ' ', interval_remote_path_accesses: 9, summary.
          number_of_attaches: integer_field_length, summary.number_of_creates: integer_field_length, ' ',
          summary.number_of_opens: integer_field_length, '  ', summary.number_of_closes: integer_field_length,
      '   ', summary.number_of_deletes: integer_field_length, ' ', summary.number_of_returns:
        integer_field_length, ' ', summary.io_summary [ioc$read_page].total_request_count: 8, summary.
          io_summary [ioc$read_page].total_page_count: 8, '  ', summary.io_summary [ioc$write_page].
          total_request_count: 8, '  ', summary.io_summary [ioc$write_page].total_page_count: 8, '  ',
          transfer_count: 8, transfer_size: 10);

    display (working_string (1, length));
  PROCEND display_time_interval_line;

?? TITLE := ' display_time_interval_title', EJECT ??

  PROCEDURE display_time_interval_title;

    VAR
      remote: boolean,
      catalog: boolean,
      working_string: string (128),
      length: integer;

    display_time (' time interval ', time_interval);

    IF total_interval_selected THEN
      display (' TOTALS ');
      display_time_interval_line (time_interval_total);
    IFEND;
    FOR remote := FALSE TO TRUE DO
      FOR catalog := FALSE TO TRUE DO
        IF interval_selection [remote] [catalog] THEN
          STRINGREP (working_string, length, ' ', remote_name [remote], '   ', catalog_name [catalog]);
          display (working_string (1, length));
        IFEND;
      FOREND;
    FOREND;

    STRINGREP (working_string, length, ' INTERVAL ', ' REM PATHS', ' ATTA ', ' CREA ', '  OPEN ', '  CLOSE ',
      '  DELETE', '  RETURN', ' READ RC', ' READ PC ', ' WRITE RC ', ' WRITE PC ', ' TRANS COUNT',
      ' TRANS SIZE');

    display (working_string (1, length));

  PROCEND display_time_interval_title;
?? TITLE := ' display_unknown_keypoint  ', EJECT ??

  PROCEDURE display_unknown_keypoint (keypoint: ost$keypoint);

    VAR
      class: string (5),
      length: integer,
      working_string: string (200);

    STRINGREP (working_string, length, ' ', keypoint.clock, ' UNKNOWN  class ', keypoint.keypoint_class,
      ' data ', keypoint.keypoint_data: #(16), '(16)    code ', keypoint.keypoint_code);
    display (working_string (1, length));

  PROCEND display_unknown_keypoint;

?? TITLE := ' initialize_file_summary ', EJECT ??

  PROCEDURE initialize_file_summary (VAR summary_table: file_summary);

    summary_table.number_of_attaches := 0;
    summary_table.number_of_creates := 0;
    summary_table.number_of_opens := 0;
    summary_table.number_of_closes := 0;
    summary_table.number_of_deletes := 0;
    summary_table.number_of_returns := 0;
    { This is the attach of a file                   not already attached
    summary_table.number_of_unique_attaches := 0;
    { unique_return refers to the last return of the file in the system
    summary_table.number_of_unique_returns := 0;

    summary_table.transfer_count := 0;
    summary_table.transfer_size := 0;

    { average_time_attached := total_time_all_attaches/ number_of_returns
    summary_table.total_time_all_attaches := 0;
    summary_table.max_number_attached := 0;
    initialize_io_function (summary_table.io_summary);
  PROCEND initialize_file_summary;
?? TITLE := ' initialize_interval_range', EJECT ??

  PROCEDURE initialize_interval_range;

    { initialize the low value so that the first low value will be the new lowest

    CONST
      largest_integer = 5000000000;


    VAR
      point: integer,
      io_function: io_functions;

    interval_range [low].number_of_attaches := largest_integer;
    interval_range [low].number_of_creates := largest_integer;
    interval_range [low].number_of_opens := largest_integer;
    interval_range [low].number_of_closes := largest_integer;
    interval_range [low].number_of_deletes := largest_integer;
    interval_range [low].number_of_returns := largest_integer;
    FOR io_function := LOWERVALUE (io_function) TO UPPERVALUE (io_function) DO
      interval_range [low].io_summary [io_function].total_request_count := largest_integer;
      interval_range [low].io_summary [io_function].total_page_count := largest_integer;
    FOREND;
    interval_range [low].transfer_count := largest_integer;
    interval_range [low].transfer_size := largest_integer;
{ do not use request size distribution for this

    interval_range [high].number_of_attaches := - 1;
    interval_range [high].number_of_creates := - 1;
    interval_range [high].number_of_opens := - 1;
    interval_range [high].number_of_closes := - 1;
    interval_range [high].number_of_deletes := - 1;
    interval_range [high].number_of_returns := - 1;
    FOR io_function := LOWERVALUE (io_function) TO UPPERVALUE (io_function) DO
      interval_range [high].io_summary [io_function].total_request_count := - 1;
      interval_range [high].io_summary [io_function].total_page_count := - 1;
    FOREND;
    interval_range [high].transfer_count := - 1;
    interval_range [high].transfer_size := - 1;

    { initialize distribution
    FOR point := LOWERBOUND (interval_distribution) TO UPPERBOUND (interval_distribution) DO
      interval_distribution [point] := initialized_summary;
    FOREND;
  PROCEND initialize_interval_range;

?? TITLE := '  initialize_io_function  ', EJECT ??

  PROCEDURE initialize_io_function (VAR io_summary: array [io_functions] OF io_function_record);

    VAR
      io_function: io_functions,
      request_size: request_size_ordinal;

    FOR io_function := LOWERVALUE (io_function) TO UPPERVALUE (io_function) DO
      io_summary [io_function].total_request_count := 0;
      io_summary [io_function].total_page_count := 0;
      FOR request_size := LOWERVALUE (request_size) TO UPPERVALUE (request_size) DO
        io_summary [io_function].request_size_distribution [request_size] := 0;
      FOREND;
    FOREND;
  PROCEND initialize_io_function;
?? TITLE := ' initialize_summary_tables', EJECT ??

  PROCEDURE initialize_summary_tables;

    VAR
      attach_file_table_index: gft$file_descriptor_index,
      catalog: boolean,
      file_residence_remote: boolean;

    { Do not use static initialization on this because of psr with generate_library.
    FOR attach_file_table_index := LOWERBOUND (attached_file_table) TO UPPERBOUND (attached_file_table) DO
      attached_file_table [attach_file_table_index].entry_type := free_entry;
    FOREND;

    initialize_io_function (non_pf_io_summary);

    initialize_file_summary (initialized_summary);
    FOR file_residence_remote := FALSE TO TRUE DO
      FOR catalog := FALSE TO TRUE DO
        attach_summary_table [file_residence_remote] [catalog] := initialized_summary;
        time_interval_summary_table [file_residence_remote] [catalog] := initialized_summary;
      FOREND;
    FOREND;
    total_summary := initialized_summary;
    time_interval_total := initialized_summary;
  PROCEND initialize_summary_tables;
?? TITLE := 'FUNCTION  interval_distribution_index', EJECT ??

  FUNCTION interval_distribution_index (low_value: integer;
        high_value: integer;
        number_of_distributions: integer;
        special_case_zero: boolean;
        value: integer): integer;

    VAR
      working_low: integer,
      range_point: real,
      range_point_siz: real;

    IF (value = 0) AND special_case_zero THEN
      interval_distribution_index := 0;
    ELSE
      IF special_case_zero AND (low_value = 0) THEN
        working_low := 1;
      ELSE
        working_low := low_value;
      IFEND;
      range_point_siz := range_point_size (working_low, high_value, number_of_distributions);
      IF range_point_siz = 0.0 THEN
        range_point := 0.0;
      ELSE
        range_point := $REAL (value - working_low) / range_point_siz;
      IFEND;
      IF range_point = 0.0 THEN
        interval_distribution_index := 1;
      ELSEIF range_point = $REAL ($INTEGER (range_point)) THEN
        interval_distribution_index := $INTEGER (range_point);
      ELSE
        interval_distribution_index := $INTEGER (range_point) + 1;
      IFEND;
    IFEND;
  FUNCEND interval_distribution_index;
?? TITLE := ' FUNCTION range_point_size', EJECT ??

  FUNCTION range_point_size (low_value: integer;
        high_value: integer;
        number_of_distributions: integer): real;

    IF number_of_distributions > 0 THEN
      range_point_size := ($REAL (high_value) - $REAL (low_value)) / $REAL (number_of_distributions);
    ELSE
      range_point_size := 0.0;
    IFEND;
  FUNCEND range_point_size;


?? TITLE := 'record_attach', EJECT ??

  PROCEDURE record_attach (attach_keypoint: ost$keypoint;
        sfid_keypoint: ost$keypoint;
        create: boolean);

    VAR
      catalog: boolean,
      file_entry_index: gft$file_descriptor_index,
      remote: boolean,
      residence: gft$table_residence;

    convert_keypoint_to_sfid (sfid_keypoint, file_entry_index, residence);
    convert_keypoint_to_operation (attach_keypoint, catalog, remote);
    CASE attached_file_table [file_entry_index].entry_type OF
    = valid_entry =
      IF (attached_file_table [file_entry_index].catalog = catalog) AND (attached_file_table
            [file_entry_index].remote = remote) THEN
        attached_file_table [file_entry_index].attach_count := attached_file_table [file_entry_index].
              attach_count + 1;
      ELSE
        display (' -- damaged entry: mismatch on catalog or remote on attach  of existing entry');
        display_file_operation_keypoint (attach_keypoint);
        display_sfid_keypoint (sfid_keypoint);
        attached_file_table [file_entry_index].entry_type := damaged_entry;
        RETURN;
      IFEND;
    = damaged_entry =
      display (' -- damaged entry: reaaccess on attach - data discarded ');
      display_file_operation_keypoint (attach_keypoint);
      display_sfid_keypoint (sfid_keypoint);
      RETURN;
    = free_entry =
      attach_summary_table [remote] [catalog].number_of_unique_attaches := attach_summary_table [remote]
            [catalog].number_of_unique_attaches + 1;
      time_interval_summary_table [remote] [catalog].number_of_unique_attaches := attach_summary_table
            [remote] [catalog].number_of_unique_attaches + 1;

      total_summary.number_of_unique_attaches := total_summary.number_of_unique_attaches + 1;
      time_interval_total.number_of_unique_attaches := time_interval_total.number_of_unique_attaches + 1;

      attached_file_table [file_entry_index].entry_type := valid_entry;
      attached_file_table [file_entry_index].catalog := catalog;
      attached_file_table [file_entry_index].remote := remote;
      attached_file_table [file_entry_index].time_initially_attached := current_keypoint_time;
      attached_file_table [file_entry_index].attach_count := 1;
      attached_file_table [file_entry_index].number_of_opens := 0;
    CASEND;

    attach_summary_table [remote] [catalog].current_attached := attach_summary_table [remote] [catalog].
          current_attached + 1;
    total_summary.current_attached := total_summary.current_attached + 1;

    IF create THEN
      attach_summary_table [remote] [catalog].number_of_creates := attach_summary_table [remote] [catalog].
            number_of_creates + 1;
      time_interval_summary_table [remote] [catalog].number_of_creates := time_interval_summary_table [remote]
            [catalog].number_of_creates + 1;
      total_summary.number_of_creates := total_summary.number_of_creates + 1;
      time_interval_total.number_of_creates := time_interval_total.number_of_creates + 1;
    ELSE
      attach_summary_table [remote] [catalog].number_of_attaches := attach_summary_table [remote] [catalog].
            number_of_attaches + 1;
      time_interval_summary_table [remote] [catalog].number_of_attaches := time_interval_summary_table
            [remote] [catalog].number_of_attaches + 1;
      total_summary.number_of_attaches := total_summary.number_of_attaches + 1;
      time_interval_total.number_of_attaches := time_interval_total.number_of_attaches + 1;
    IFEND;

    IF attach_summary_table [remote] [catalog].current_attached > attach_summary_table [remote] [catalog].
          max_number_attached THEN
      attach_summary_table [remote] [catalog].max_number_attached := attach_summary_table [remote] [catalog].
            current_attached;
    IFEND;
    IF total_summary.current_attached > total_summary.max_number_attached THEN
      total_summary.max_number_attached := total_summary.current_attached;
    IFEND;
  PROCEND record_attach;
?? TITLE := '  record_catalog_access_info', EJECT ??

  PROCEDURE record_catalog_access_info (keypoint: ost$keypoint);

    VAR
      data_converter: dft$keypoint_catalog_summary;

    VAR
      catalog_depth: integer,
      catalog_owner: boolean,
      read_access: boolean,
      remote_catalog: boolean;

    convert_keypoint_to_cat (keypoint, remote_catalog, catalog_owner, catalog_depth, read_access);
    total_path_accesses := total_path_accesses + 1;
    interval_path_accesses := interval_path_accesses + 1;
    IF remote_catalog THEN
      remote_path_accesses := remote_path_accesses + 1;
      interval_remote_path_accesses := interval_remote_path_accesses + 1;
    IFEND;

    IF catalog_owner THEN
      accesses_by_owner := accesses_by_owner + 1;
      interval_accesses_by_owner := interval_accesses_by_owner + 1;
    IFEND;

    total_catalog_depth := total_catalog_depth + catalog_depth;
    interval_total_catalog_depth := interval_total_catalog_depth + catalog_depth;
    IF remote_catalog THEN
      total_remote_cat_depth := total_remote_cat_depth + catalog_depth;
      interval_total_remote_cat_depth := interval_total_remote_cat_depth + catalog_depth;
    IFEND;

    IF read_access THEN
      accesses_for_read := accesses_for_read + 1;
      interval_accesses_for_read := interval_accesses_for_read + 1;
    IFEND;
  PROCEND record_catalog_access_info;
?? TITLE := ' record_close', EJECT ??

  PROCEDURE record_close (sfid_keypoint: ost$keypoint);

    VAR
      catalog: boolean,
      file_entry_index: gft$file_descriptor_index,
      remote: boolean,
      residence: gft$table_residence;

    convert_keypoint_to_sfid (sfid_keypoint, file_entry_index, residence);
    IF attached_file_table [file_entry_index].entry_type = valid_entry THEN
      catalog := attached_file_table [file_entry_index].catalog;
      remote := attached_file_table [file_entry_index].remote;
      attach_summary_table [remote] [catalog].number_of_closes := attach_summary_table [remote] [catalog].
            number_of_closes + 1;
      time_interval_summary_table [remote] [catalog].number_of_closes := time_interval_summary_table [remote]
            [catalog].number_of_closes + 1;
    ELSE
      non_pf_close_count := non_pf_close_count + 1;
    IFEND;
    total_summary.number_of_closes := total_summary.number_of_closes + 1;
    time_interval_total.number_of_closes := total_summary.number_of_closes + 1;
  PROCEND record_close;

?? TITLE := 'record_delete_catalog', EJECT ??

  PROCEDURE record_delete_catalog (remote: boolean;
        sfid_keypoint: ost$keypoint);

    VAR
      file_entry_index: gft$file_descriptor_index,
      residence: gft$table_residence;

    convert_keypoint_to_sfid (sfid_keypoint, file_entry_index, residence);
    IF (attached_file_table [file_entry_index].entry_type = valid_entry) THEN
      IF attached_file_table [file_entry_index].catalog AND (attached_file_table [file_entry_index].remote =
            remote) THEN
        attach_summary_table [remote] [ {catalog = } TRUE].number_of_deletes := attach_summary_table [remote]
              [
              {catalog = } TRUE].number_of_deletes + 1;
        time_interval_summary_table [remote] [ {catalog = } TRUE].number_of_deletes :=
              time_interval_summary_table [remote] [
              {catalog = } TRUE].number_of_deletes + 1;
        record_detach (sfid_keypoint);
      ELSE
        display (' -- damaged entry: mismatch on catalog or remote on delete_catalog');
        display_sfid_keypoint (sfid_keypoint);
        attached_file_table [file_entry_index].entry_type := damaged_entry;
      IFEND;
    ELSE
      display (' unexpected sfid on delete_catalog');
      display_sfid_keypoint (sfid_keypoint);
    IFEND;
    total_summary.number_of_deletes := total_summary.number_of_deletes + 1;
    time_interval_total.number_of_deletes := total_summary.number_of_deletes + 1;
  PROCEND record_delete_catalog;
?? TITLE := 'record_delete_file', EJECT ??

  PROCEDURE record_delete_file (remote: boolean);

    attach_summary_table [remote] [ {catalog = } FALSE].number_of_deletes := attach_summary_table [remote] [
          {catalog = } FALSE].number_of_deletes + 1;
    time_interval_summary_table [remote] [ {catalog = } FALSE].number_of_deletes :=
          time_interval_summary_table [remote] [
          {catalog = } FALSE].number_of_deletes + 1;
    total_summary.number_of_deletes := total_summary.number_of_deletes + 1;
    time_interval_total.number_of_deletes := time_interval_total.number_of_deletes + 1;
  PROCEND record_delete_file;
?? TITLE := 'record_detach', EJECT ??

  PROCEDURE record_detach (sfid_keypoint: ost$keypoint);

    VAR
      catalog: boolean,
      file_entry_index: gft$file_descriptor_index,
      remote: boolean,
      residence: gft$table_residence;

    convert_keypoint_to_sfid (sfid_keypoint, file_entry_index, residence);
    IF attached_file_table [file_entry_index].entry_type = valid_entry THEN
      catalog := attached_file_table [file_entry_index].catalog;
      remote := attached_file_table [file_entry_index].remote;
      attached_file_table [file_entry_index].attach_count := attached_file_table [file_entry_index].
            attach_count - 1;
      attach_summary_table [remote] [catalog].number_of_returns := attach_summary_table [remote] [catalog].
            number_of_returns + 1;
      time_interval_summary_table [remote] [catalog].number_of_returns := time_interval_summary_table [remote]
            [catalog].number_of_returns + 1;
      IF attached_file_table [file_entry_index].attach_count = 0 THEN
        attached_file_table [file_entry_index].entry_type := free_entry;

        attach_summary_table [remote] [catalog].number_of_unique_returns := attach_summary_table [remote]
              [catalog].number_of_unique_returns + 1;
        attach_summary_table [remote] [catalog].current_attached := attach_summary_table [remote] [catalog].
              current_attached - 1;
        attach_summary_table [remote] [catalog].total_time_all_attaches := attach_summary_table [remote]
              [catalog].total_time_all_attaches + (current_keypoint_time - attached_file_table
              [file_entry_index].time_initially_attached);

        total_summary.number_of_unique_returns := total_summary.number_of_unique_returns + 1;
        total_summary.current_attached := total_summary.current_attached - 1;
        total_summary.total_time_all_attaches := total_summary.total_time_all_attaches +
              (current_keypoint_time - attached_file_table [file_entry_index].time_initially_attached);

        time_interval_total.number_of_unique_returns := time_interval_total.number_of_unique_returns + 1;
      IFEND;
    ELSE
      display (' --  detach called with invalid sfid');
      display_sfid_keypoint (sfid_keypoint);
    IFEND;
    total_summary.number_of_returns := total_summary.number_of_returns + 1;
    time_interval_total.number_of_returns := time_interval_total.number_of_returns + 1;
  PROCEND record_detach;

?? TITLE := 'record_interval_range', EJECT ??

  PROCEDURE record_interval_range (VAR interval: file_summary);

    VAR
      transfer_count: integer,
      transfer_size: integer,
      io_function: io_functions;

    compute_transfer_totals (interval, transfer_count, transfer_size);
    interval.transfer_count := transfer_count;
    interval.transfer_size := transfer_size;


{ update new lows
    IF interval.number_of_attaches < interval_range [low].number_of_attaches THEN
      interval_range [low].number_of_attaches := interval.number_of_attaches;
    IFEND;
    IF interval.number_of_creates < interval_range [low].number_of_creates THEN
      interval_range [low].number_of_creates := interval.number_of_creates;
    IFEND;
    IF interval.number_of_opens < interval_range [low].number_of_opens THEN
      interval_range [low].number_of_opens := interval.number_of_opens;
    IFEND;
    IF interval.number_of_closes < interval_range [low].number_of_closes THEN
      interval_range [low].number_of_closes := interval.number_of_closes;
    IFEND;
    IF interval.number_of_deletes < interval_range [low].number_of_deletes THEN
      interval_range [low].number_of_deletes := interval.number_of_deletes;
    IFEND;
    IF interval.number_of_returns < interval_range [low].number_of_returns THEN
      interval_range [low].number_of_returns := interval.number_of_returns;
    IFEND;
    IF interval.transfer_count < interval_range [low].transfer_count THEN
      interval_range [low].transfer_count := interval.transfer_count;
    IFEND;
    IF interval.transfer_size < interval_range [low].transfer_size THEN
      interval_range [low].transfer_size := interval.transfer_size;
    IFEND;

    FOR io_function := LOWERVALUE (io_function) TO UPPERVALUE (io_function) DO
      IF interval.io_summary [io_function].total_request_count < interval_range [low].io_summary
            [io_function].total_request_count THEN
        interval_range [low].io_summary [io_function].total_request_count := interval.io_summary
              [io_function].total_request_count;
      IFEND;
      IF interval.io_summary [io_function].total_page_count < interval_range [low].io_summary [io_function].
            total_page_count THEN
        interval_range [low].io_summary [io_function].total_page_count := interval.io_summary [io_function].
              total_page_count;
      IFEND;
    FOREND;


{ do the same for the high
    IF interval.number_of_attaches > interval_range [high].number_of_attaches THEN
      interval_range [high].number_of_attaches := interval.number_of_attaches;
    IFEND;
    IF interval.number_of_creates > interval_range [high].number_of_creates THEN
      interval_range [high].number_of_creates := interval.number_of_creates;
    IFEND;
    IF interval.number_of_opens > interval_range [high].number_of_opens THEN
      interval_range [high].number_of_opens := interval.number_of_opens;
    IFEND;
    IF interval.number_of_closes > interval_range [high].number_of_closes THEN
      interval_range [high].number_of_closes := interval.number_of_closes;
    IFEND;
    IF interval.number_of_deletes > interval_range [high].number_of_deletes THEN
      interval_range [high].number_of_deletes := interval.number_of_deletes;
    IFEND;
    IF interval.number_of_returns > interval_range [high].number_of_returns THEN
      interval_range [high].number_of_returns := interval.number_of_returns;
    IFEND;
    IF interval.transfer_count > interval_range [high].transfer_count THEN
      interval_range [high].transfer_count := interval.transfer_count;
    IFEND;
    IF interval.transfer_size > interval_range [high].transfer_size THEN
      interval_range [high].transfer_size := interval.transfer_size;
    IFEND;

    FOR io_function := LOWERVALUE (io_function) TO UPPERVALUE (io_function) DO
      IF interval.io_summary [io_function].total_request_count > interval_range [high].io_summary
            [io_function].total_request_count THEN
        interval_range [high].io_summary [io_function].total_request_count := interval.io_summary
              [io_function].total_request_count;
      IFEND;
      IF interval.io_summary [io_function].total_page_count > interval_range [high].io_summary [io_function].
            total_page_count THEN
        interval_range [high].io_summary [io_function].total_page_count := interval.io_summary [io_function].
              total_page_count;
      IFEND;
    FOREND;

  PROCEND record_interval_range;
?? TITLE := ' record_open', EJECT ??

  PROCEDURE record_open (sfid_keypoint: ost$keypoint);

    VAR
      catalog: boolean,
      file_entry_index: gft$file_descriptor_index,
      remote: boolean,
      residence: gft$table_residence;

    convert_keypoint_to_sfid (sfid_keypoint, file_entry_index, residence);
    IF attached_file_table [file_entry_index].entry_type = valid_entry THEN
      catalog := attached_file_table [file_entry_index].catalog;
      remote := attached_file_table [file_entry_index].remote;
      attached_file_table [file_entry_index].number_of_opens := attached_file_table [file_entry_index].
            number_of_opens + 1;
      attach_summary_table [remote] [catalog].number_of_opens := attach_summary_table [remote] [catalog].
            number_of_opens + 1;
      time_interval_summary_table [remote] [catalog].number_of_opens := time_interval_summary_table [remote]
            [catalog].number_of_opens + 1;
    ELSE
      non_pf_open_count := non_pf_open_count + 1;
    IFEND;
    total_summary.number_of_opens := total_summary.number_of_opens + 1;
    time_interval_total.number_of_opens := time_interval_total.number_of_opens + 1;
  PROCEND record_open;

?? TITLE := ' record_pager_io', EJECT ??

  PROCEDURE record_pager_io (keypoint: ost$keypoint;
        sfid_keypoint: ost$keypoint);

    VAR
      catalog: boolean,
      file_entry_index: gft$file_descriptor_index,
      io_function: iot$io_function,
      page_count: integer,
      request_size: request_size_ordinal,
      remote: boolean,
      residence: gft$table_residence;

    convert_keypoint_to_sfid (sfid_keypoint, file_entry_index, residence);
    convert_keypoint_to_io_function (keypoint, io_function, page_count);
    convert_page_count_to_ordinal (page_count, request_size);
    IF (residence = gfc$tr_system) AND (attached_file_table [file_entry_index].entry_type =
          valid_entry) THEN
      catalog := attached_file_table [file_entry_index].catalog;
      remote := attached_file_table [file_entry_index].remote;
      attach_summary_table [remote] [catalog].io_summary [io_function].total_request_count :=
            attach_summary_table [remote] [catalog].io_summary [io_function].total_request_count + 1;
      attach_summary_table [remote] [catalog].io_summary [io_function].total_page_count :=
            attach_summary_table [remote] [catalog].io_summary [io_function].total_page_count + page_count;
      attach_summary_table [remote] [catalog].io_summary [io_function].request_size_distribution
            [request_size] := attach_summary_table [remote] [catalog].io_summary [io_function].
            request_size_distribution [request_size] + 1;

      time_interval_summary_table [remote] [catalog].io_summary [io_function].total_request_count :=
            time_interval_summary_table [remote] [catalog].io_summary [io_function].total_request_count + 1;
      time_interval_summary_table [remote] [catalog].io_summary [io_function].total_page_count :=
            time_interval_summary_table [remote] [catalog].io_summary [io_function].total_page_count +
            page_count;
      time_interval_summary_table [remote] [catalog].io_summary [io_function].request_size_distribution
            [request_size] := time_interval_summary_table [remote] [catalog].io_summary [io_function].
            request_size_distribution [request_size] + 1;
    ELSE
      non_pf_io_summary [io_function].total_page_count := non_pf_io_summary [io_function].total_page_count +
            page_count;
      non_pf_io_summary [io_function].total_request_count := non_pf_io_summary [io_function].
            total_request_count + 1;
      non_pf_io_summary [io_function].request_size_distribution [request_size] := non_pf_io_summary
            [io_function].request_size_distribution [request_size] + 1;
    IFEND;

    total_summary.io_summary [io_function].total_request_count := total_summary.io_summary [io_function].
          total_request_count + 1;
    total_summary.io_summary [io_function].total_page_count := total_summary.io_summary [io_function].
          total_page_count + page_count;
    total_summary.io_summary [io_function].request_size_distribution [request_size] := total_summary.
          io_summary [io_function].request_size_distribution [request_size] + 1;

    time_interval_total.io_summary [io_function].total_request_count := time_interval_total.io_summary
          [io_function].total_request_count + 1;
    time_interval_total.io_summary [io_function].total_page_count := time_interval_total.io_summary
          [io_function].total_page_count + page_count;
    time_interval_total.io_summary [io_function].request_size_distribution [request_size] :=
          time_interval_total.io_summary [io_function].request_size_distribution [request_size] + 1;

  PROCEND record_pager_io;



MODEND dfm$analyze_server_keypoints;
*DECK DECK=DFM$APPLICATION_MANAGER_HELPERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File Server: Server/Client: Load State Change Procedure, etc.' ??
MODULE dfm$application_manager_helpers;

{ PURPOSE:
{   This module contains the procedures which to aid the managing of defined
{   applications.

?? NEWTITLE := '  Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc dfe$error_condition_codes
*copyc dft$cpu_queue
*copyc dft$p_state_change_procedure
*copyc oss$task_shared
*copyc ost$status
*copyc pmt$loaded_address
?? POP ??
*copyc amp$return
*copyc clp$include_line
*copyc dfi$display
*copyc dfi$log_display
*copyc dfp$find_mainframe_id
*copyc dfp$load_application_procedure
*copyc dfp$verify_system_administrator
*copyc osp$set_status_abnormal
*copyc pmp$execute
*copyc pmp$get_unique_name
*copyc dfv$file_server_debug_enabled
*copyc dfv$recovery_task
*copyc osv$task_shared_heap
?? OLDTITLE ??

  VAR
    dfv$p_state_change_task_status: [XDCL, oss$task_shared] ^pmt$task_status := NIL;

?? NEWTITLE := '[XDCL] dfp$attach_application_library', EJECT ??

{ PURPOSE:
{    Attach library file (if any) for each application.

  PROCEDURE [XDCL] dfp$attach_application_library
    (    p_cpu_queue: ^dft$cpu_queue);

    VAR
      line: string (200),
      line_size: integer,
      p_host_info: ^dft$host_application_info,
      status: ost$status,
      unique_name: ost$name;


    p_host_info := p_cpu_queue^.queue_header.p_host_application_info;
    IF p_host_info = NIL THEN
      RETURN;
    IFEND;
    IF dfv$file_server_debug_enabled THEN
      display (' Starting to attach application libraries');
    IFEND;

  /process_applications/
    WHILE p_host_info <> NIL DO
{    Attach library file for this application if it exists
      IF p_host_info^.p_library_file_path <> NIL THEN
        pmp$get_unique_name (unique_name, status);
        STRINGREP (line, line_size, '$system.attach_file file=', p_host_info^.p_library_file_path^, ' lfn=',
              unique_name);
        clp$include_line (line (1, line_size), {echo} TRUE, { utility } osc$null_name, status);
        IF status.normal THEN
          p_host_info^.attached_library_lfn := unique_name;
        ELSE
          display (' Unable to attach application library ');
          display (line (1, line_size));
          display_status (status);
          log_display_status ($pmt$ascii_logset [pmc$job_log, pmc$system_log], TRUE, status);
          p_host_info^.attached_library_lfn := osc$null_name;
        IFEND;
      IFEND;
      p_host_info := p_host_info^.next_p_application_info;
    WHILEND /process_applications/;

  PROCEND dfp$attach_application_library;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] dfp$execute_state_change_task  ', EJECT ??

{  This procedure starts the task that will call of the applications state
{ procedure.  The caller may choose to wait for the task to complete or not.
{ This procedure starts a task with the entry point DFP$STATE_CHANGE_TASK.
{ Parameters are communicated to that task by treating the parameter list
{ as a sequence with contents: mainframe_name, partner_is_server,
{ old_state, new_state, recovery_task.

  PROCEDURE [XDCL] dfp$execute_state_change_task
    (    mainframe_name: pmt$mainframe_id;
         partner_is_server: boolean;
         old_state: dft$server_state;
         new_state: dft$server_state;
         wait: ost$wait;
     VAR status: ost$status);

    VAR
      p_mainframe_name: ^pmt$mainframe_id,
      p_parameter_sequence: ^pmt$program_parameters,
      p_partner_is_server: ^boolean,
      p_program_attributes: ^pmt$program_attributes,
      p_program_description: ^pmt$program_description,
      p_recovery_task: ^boolean,
      p_state: ^dft$server_state,
      taskid: pmt$task_id;

    PUSH p_program_description: [[REP 1 OF pmt$program_attributes]];
    RESET p_program_description;
    NEXT p_program_attributes IN p_program_description;
    p_program_attributes^.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$load_map_options_specified, pmc$term_error_level_specified];
    p_program_attributes^.starting_procedure := 'DFP$STATE_CHANGE_TASK';
    p_program_attributes^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    p_program_attributes^.termination_error_level := pmc$warning_load_errors;

    PUSH p_parameter_sequence: [[REP 1 OF ost$string]];
    RESET p_parameter_sequence;
    NEXT p_mainframe_name IN p_parameter_sequence;
    p_mainframe_name^ := mainframe_name;
    NEXT p_partner_is_server IN p_parameter_sequence;
    p_partner_is_server^ := partner_is_server;
    NEXT p_state IN p_parameter_sequence;
    p_state^ := old_state;
    NEXT p_state IN p_parameter_sequence;
    p_state^ := new_state;
    NEXT p_recovery_task IN p_parameter_sequence;
    p_recovery_task^ := dfv$recovery_task;

    IF dfv$p_state_change_task_status = NIL THEN
      ALLOCATE dfv$p_state_change_task_status IN osv$task_shared_heap^;
    IFEND;

    pmp$execute (p_program_description^, p_parameter_sequence^, wait, taskid, dfv$p_state_change_task_status^,
          status);
  PROCEND dfp$execute_state_change_task;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] dfp$load_and_call_state_change  ', EJECT ??

{ PURPOSE:
{   Load state_change_procedure (if any) for each
{   application and call the state change procedure. The procedure is
{   called directly within the calling task .
{   This procedure assumes that the applications command library has been attached.

  PROCEDURE [XDCL] dfp$load_and_call_state_change
    (    p_cpu_queue: ^dft$cpu_queue;
         partner_is_server: boolean;
         old_state: dft$server_state;
         new_state: dft$server_state;
     VAR status: ost$status);

    VAR
      line: string (200),
      line_size: integer,
      loaded_address: pmt$loaded_address,
      p_host_info: ^dft$host_application_info,
      p_state_change_procedure: dft$p_state_change_procedure;

    status.normal := TRUE;
    IF old_state = new_state THEN
      RETURN;
    IFEND;

    p_host_info := p_cpu_queue^.queue_header.p_host_application_info;
    IF p_host_info = NIL THEN
      RETURN;
    IFEND;
    IF dfv$file_server_debug_enabled THEN
      display (' Starting to load state_change_procedure(s)');
    IFEND;

  /process_applications/
    WHILE p_host_info <> NIL DO

{ Load state change procedure if it was defined.
      IF (p_host_info^.attached_library_lfn <> osc$null_name) AND
            (p_host_info^.state_change_procedure_name <> osc$null_name) THEN
        dfp$load_application_procedure (p_host_info^.state_change_procedure_name,
              p_host_info^.attached_library_lfn, loaded_address, status);
        IF status.normal THEN
          #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, p_state_change_procedure);

          IF dfv$file_server_debug_enabled THEN
            STRINGREP (line, line_size, ' Calling state_change_procedure ',
                  p_host_info^.state_change_procedure_name);
            display (line (1, line_size));
            log_display ($pmt$ascii_logset [pmc$job_log, pmc$system_log], line (1, line_size));
          IFEND;
          p_state_change_procedure^ (p_cpu_queue^.queue_header.destination_mainframe_name, partner_is_server,
                old_state, new_state, status);
          IF NOT status.normal THEN
            IF dfv$file_server_debug_enabled THEN
              display_status (status);
            IFEND;
            STRINGREP (line, line_size, ' Abnormal status from state_change_procedure: ',
                  p_host_info^.state_change_procedure_name);
            log_display ($pmt$ascii_logset [pmc$job_log, pmc$system_log], line (1, line_size));
            log_display_status ($pmt$ascii_logset [pmc$job_log, pmc$system_log], TRUE, status);
            status.normal := TRUE;
          IFEND;
        ELSE
          STRINGREP (line, line_size, ' Abnormal status while loading state_change_procedure: ',
                p_host_info^.state_change_procedure_name);
          IF dfv$file_server_debug_enabled THEN
            display (line (1, line_size));
            display_status (status);
          IFEND;
          log_display ($pmt$ascii_logset [pmc$job_log, pmc$system_log], line (1, line_size));
          log_display_status ($pmt$ascii_logset [pmc$job_log, pmc$system_log], TRUE, status);
          status.normal := TRUE;
        IFEND;
      IFEND;
      p_host_info := p_host_info^.next_p_application_info;
    WHILEND /process_applications/;

  PROCEND dfp$load_and_call_state_change;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] dfp$return_application_library', EJECT ??

{ PURPOSE:
{   The purpose of this request is to return all application libraries which
{   have been attached in this task.

  PROCEDURE [XDCL] dfp$return_application_library
    (    p_cpu_queue: ^dft$cpu_queue);

    VAR
      line: string (200),
      line_size: integer,
      local_status: ost$status,
      p_host_info: ^dft$host_application_info;

    local_status.normal := TRUE;
    p_host_info := p_cpu_queue^.queue_header.p_host_application_info;
    IF p_host_info = NIL THEN
      RETURN;
    IFEND;
    IF dfv$file_server_debug_enabled THEN
      display (' Starting to return application libraries');
    IFEND;

  /process_applications/
    WHILE p_host_info <> NIL DO
{    Return library file for this if it exists.
      IF p_host_info^.attached_library_lfn <> osc$null_name THEN
        IF dfv$file_server_debug_enabled THEN
          STRINGREP (line, line_size, ' Returning library for application: ', p_host_info^.application_name);
          display (line (1, line_size));
        IFEND;
        amp$return (p_host_info^.attached_library_lfn, local_status);
        IF local_status.normal THEN
          p_host_info^.attached_library_lfn := osc$null_name;
        ELSE
          STRINGREP (line, line_size, ' Unable to return library for application: ',
                p_host_info^.application_name);
          display (line (1, line_size));
          display_status (local_status);
          log_display_status ($pmt$ascii_logset [pmc$system_log], TRUE, local_status);
          local_status.normal := TRUE;
        IFEND;
      IFEND;
      p_host_info := p_host_info^.next_p_application_info;
    WHILEND /process_applications/;

  PROCEND dfp$return_application_library;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] dfp$state_change_task  ', EJECT ??

{ This procedure is the entry point for the state change task which was
{ started by calling dfp$execute_state_change_task.  This finds the
{ requested mainframe and then loads and calls all of the state change
{ procedures for each application.

  PROCEDURE [XDCL, #GATE] dfp$state_change_task
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_mainframe_name: ^pmt$mainframe_id,
      p_new_state: ^dft$server_state,
      p_old_state: ^dft$server_state,
      p_parameter_sequence: ^pmt$program_parameters,
      p_partner_is_server: ^boolean,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_recovery_task: ^boolean,
      queue_index: dft$queue_index;

    dfp$verify_system_administrator ('DFP$STATE_CHANGE_TASK', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    { Crack the parameters in the parameter list
    p_parameter_sequence := ^parameter_list;
    RESET p_parameter_sequence;
    NEXT p_mainframe_name IN p_parameter_sequence;
    NEXT p_partner_is_server IN p_parameter_sequence;
    NEXT p_old_state IN p_parameter_sequence;
    NEXT p_new_state IN p_parameter_sequence;
    NEXT p_recovery_task IN p_parameter_sequence;
    dfv$recovery_task := p_recovery_task^;

    dfp$find_mainframe_id (p_mainframe_name^, NOT p_partner_is_server^, mainframe_found,
          p_queue_interface_table, p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF mainframe_found THEN
      dfp$load_and_call_state_change (p_cpu_queue, p_partner_is_server^, p_old_state^, p_new_state^, status);
    ELSE
      IF p_partner_is_server^ THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, p_mainframe_name^, status);
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, p_mainframe_name^, status);
      IFEND;
    IFEND;

    IF dfv$file_server_debug_enabled AND NOT status.normal THEN
      display (' dfp$state_change_task ');
      display_status (status);
    IFEND;
  PROCEND dfp$state_change_task;
?? OLDTITLE ??
MODEND dfm$application_manager_helpers;
*DECK DECK=DFM$CALL_REMOTE_PROCEDURE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server : Client: Call Remote Procedure' ??
MODULE dfm$call_remote_procedure;

{ PURPOSE:
{   This module contains the procedure to allow the application (client)
{   user to request execution of a procedure on a remote (server) mainframe.
{
{ DESIGN:
{   The user request is transferred to the Remote Procedure Call (RPC)
{   mechanism and the output of the remote procedure (as returned by RPC) is
{   returned to the caller.
{

?? NEWTITLE := ' Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dfi$display
*copyc dfi$log_display
*copyc dft$cpu_queue
*copyc dft$procedure_address_ordinal
*copyc dft$rpc_parameters
*copyc ost$caller_identifier
*copyc ost$name
*copyc ost$user_identification
*copyc pme$insufficient_privilege
*copyc pmt$program_name
?? POP ??
*copyc dfp$convert_queue_entry_loc
*copyc dfp$find_extended_rpc_ordinal
*copyc dfp$find_mainframe_id
*copyc dfp$locate_served_family
*copyc dfp$send_application_rpc
*copyc i#current_sequence_position
*copyc mmp$verify_access
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pmp$zero_out_table

*copyc dfv$file_server_debug_enabled
*copyc dfv$p_queue_interface_directory

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] dfp$call_remote_procedure', EJECT ??
*copy dfh$call_remote_procedure

  PROCEDURE [XDCL, #GATE] dfp$call_remote_procedure
    (    server_location: dft$server_location;
         application_name: ost$name;
         procedure_name: pmt$program_name;
         send_parameters: ^SEQ ( * ); {max size = dfc$maximum_user_buffer_area
         send_data: ^SEQ ( * ); {max size = dfc$maximum_user_data_area
     VAR receive_parameters_size: 0 .. dfc$maximum_user_buffer_area;
     VAR receive_parameters: ^SEQ ( * );
     VAR receive_data_size: 0 .. dfc$maximum_user_data_area;
     VAR receive_data: ^SEQ ( * ); {max_size = dfc$maximum_user_data_area
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT dfp$call_remote_procedure;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      caller_id: ost$caller_identifier,
      callers_receive_data_size: 0 .. dfc$maximum_user_data_area,
      callers_receive_parameters_size: 0 .. dfc$maximum_user_buffer_area,
      family_found: boolean,
      line: string (200),
      line_size: integer,
      local_status: ost$status,
      mainframe_found: boolean,
      name: ost$name,
      p_cpu_queue: ^dft$cpu_queue,
      p_generic_seq: ^SEQ ( * ),
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_receive_buffer: dft$p_receive_parameters,
      p_receive_data: dft$p_receive_data,
      p_send_buffer: dft$p_send_parameters,
      p_send_data: dft$p_send_data,
      procedure_ordinal: dft$procedure_address_ordinal,
      queue_entry_loc_int: dft$rpc_queue_entry_loc_int,
      queue_entry_location: dft$rpc_queue_entry_location,
      queue_index: dft$queue_index,
      send_buffer_size: dft$send_parameter_size,
      send_data_size: dft$send_data_size,
      served_family_table_index: dft$served_family_table_index,
      server_binary_mainframe_id: pmt$binary_mainframe_id,
      server_state: dft$server_state,
      server_to_client: boolean;

    status.normal := TRUE;
    local_status.normal := TRUE;
    name := 'DFP$CALL_REMOTE_PROCEDURE';
    #CALLER_ID (caller_id);

    IF server_location.server_location_selector = dfc$served_family_table_index THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_server_locator, '', status);
      RETURN;
    IFEND;

    IF send_parameters <> NIL THEN
      IF NOT mmp$verify_access (#LOC (send_parameters), mmc$va_read) THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_parameter_pva, 'SEND_PARAMETERS', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'DFP$CALL_REMOTE_PROCEDURE', status);
        RETURN;
      IFEND;
      IF #SIZE (send_parameters^) > dfc$maximum_user_buffer_area THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$callers_variable_too_large, name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'SEND_PARAMETERS', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'dfc$maximum_user_buffer_area', status);
        RETURN;
      IFEND;
    IFEND;

    IF send_data <> NIL THEN
      IF NOT mmp$verify_access (#LOC (send_data), mmc$va_read) THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_parameter_pva, 'SEND_DATA', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'DFP$CALL_REMOTE_PROCEDURE', status);
        RETURN;
      IFEND;
      IF #SIZE (send_data^) > dfc$maximum_user_data_area THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$callers_variable_too_large, name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'SEND_DATA', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'dfc$maximum_user_data_area', status);
        RETURN;
      IFEND;
    IFEND;

    IF receive_parameters <> NIL THEN
      IF NOT mmp$verify_access (#LOC (receive_parameters), mmc$va_read_write) THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_parameter_pva, 'RECEIVE_PARAMETERS', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'DFP$CALL_REMOTE_PROCEDURE', status);
        RETURN;
      IFEND;
      IF #SIZE (receive_parameters^) > dfc$maximum_user_buffer_area THEN
        callers_receive_parameters_size := dfc$maximum_user_buffer_area;
      IFEND;
      callers_receive_parameters_size := #SIZE (receive_parameters^);
    ELSE
      callers_receive_parameters_size := 0;
    IFEND;

    IF receive_data <> NIL THEN
      IF NOT mmp$verify_access (#LOC (receive_data), mmc$va_read_write) THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_parameter_pva, 'RECEIVE_DATA', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'DFP$CALL_REMOTE_PROCEDURE', status);
        RETURN;
      IFEND;
      IF #SIZE (receive_data^) > dfc$maximum_user_data_area THEN
        callers_receive_data_size := dfc$maximum_user_data_area;
      IFEND;
      callers_receive_data_size := #SIZE (receive_data^);
    ELSE
      callers_receive_data_size := 0;
    IFEND;

    dfp$begin_ch_remote_proc_call (server_location, {allowed_when_server_deactivated} FALSE,
          queue_entry_location, p_send_buffer, p_send_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /after_begin_call/
    BEGIN

      dfp$convert_qel_ext_to_int (queue_entry_location, queue_entry_loc_int);
      p_cpu_queue := dfv$p_queue_interface_directory^ [queue_entry_loc_int.queue_directory_index].
            p_queue_interface_table^.queue_directory.cpu_queue_pva_directory
            [queue_entry_loc_int.queue_index].p_cpu_queue;

{ Check that callers ring <= application rpc specification

      dfp$find_extended_rpc_ordinal (application_name, procedure_name, p_cpu_queue, procedure_ordinal,
            status);
      IF NOT status.normal THEN
        EXIT /after_begin_call/;
      IFEND;

      IF p_cpu_queue^.queue_header.p_application_rpc_list <> NIL THEN
        IF caller_id.ring > p_cpu_queue^.queue_header.p_application_rpc_list^
              [$INTEGER (procedure_ordinal) - $INTEGER (dfc$last_system_procedure)].application_ring THEN
          osp$set_status_abnormal ('PM', pme$insufficient_privilege, '', status);
          EXIT /after_begin_call/;
        IFEND;
      ELSE {Some sort of problem since dfp$find_extended_rpc_ordinal did not complain
        osp$set_status_abnormal (dfc$file_server_id, dfe$procedure_not_known, procedure_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, application_name, status);
        EXIT /after_begin_call/;
      IFEND;

      IF send_parameters <> NIL THEN
        NEXT p_generic_seq: [[REP #SIZE (send_parameters^) OF cell]] IN p_send_buffer;
        p_generic_seq^ := send_parameters^;
        send_buffer_size := i#current_sequence_position (p_send_buffer);
      ELSE
        send_buffer_size := 0;
      IFEND;

      IF send_data <> NIL THEN
        NEXT p_generic_seq: [[REP #SIZE (send_data^) OF cell]] IN p_send_data;
        p_generic_seq^ := send_data^;
        send_data_size := i#current_sequence_position (p_send_data);
      ELSE
        send_data_size := 0;
      IFEND;

      IF dfv$file_server_debug_enabled THEN
        STRINGREP (line, line_size, ' Sending RPC request. APPL=', application_name, ' PROC=',
              procedure_name);
        log_display ($pmt$ascii_logset [pmc$job_log, pmc$system_log], line (1, line_size));
      IFEND;

      dfp$send_application_rpc (queue_entry_location, application_name, procedure_name, send_buffer_size,
            send_data_size, p_receive_buffer, p_receive_data, status);

      IF NOT status.normal THEN
        IF dfv$file_server_debug_enabled THEN
          display (' ABNORMAL STATUS FROM dfpsend_application_rpc');
          display_status (status);
        IFEND;
        EXIT /after_begin_call/;
      IFEND;

{ Process receive buffer
      IF p_receive_buffer <> NIL THEN
        receive_parameters_size := #SIZE (p_receive_buffer^);
        IF receive_parameters_size <= callers_receive_parameters_size THEN
          RESET receive_parameters;
          NEXT p_generic_seq: [[REP receive_parameters_size OF cell]] IN receive_parameters;
          p_generic_seq^ := p_receive_buffer^;
          RESET receive_parameters;
        ELSE
          osp$set_status_abnormal (dfc$file_server_id, dfe$callers_variable_too_small, name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'RECEIVE_PARAMETERS', status);
          osp$append_status_integer (osc$status_parameter_delimiter, receive_parameters_size, 10, FALSE,
                status);
          EXIT /after_begin_call/;
        IFEND;
      ELSE
        receive_parameters_size := 0;
      IFEND;

      IF p_receive_data <> NIL THEN
        receive_data_size := #SIZE (p_receive_data^);
        IF receive_data_size <= callers_receive_data_size THEN
          RESET receive_data;
          NEXT p_generic_seq: [[REP receive_data_size OF cell]] IN receive_data;
          p_generic_seq^ := p_receive_data^;
          RESET receive_data;
        ELSE
          osp$set_status_abnormal (dfc$file_server_id, dfe$callers_variable_too_small, name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'RECEIVE_DATA', status);
          osp$append_status_integer (osc$status_parameter_delimiter, receive_data_size, 10, FALSE, status);
          EXIT /after_begin_call/;
        IFEND;
      ELSE
        receive_data_size := 0;
        ;
      IFEND;
    END /after_begin_call/;

    dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

  PROCEND dfp$call_remote_procedure;
?? OLDTITLE ??
MODEND dfm$call_remote_procedure;
*DECK DECK=DFM$CDCNET_DRIVER EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'DISTRIBUTED FILES - CDCNET DRIVER', EJECT ??

MODULE dfm$cdcnet_driver;

?? PUSH (LISTEXT := ON) ??
*copyc clp$get_value
*copyc clp$scan_parameter_list
?? POP ??

{===========================================================================
{ DFM$CDCNET_DRIVER contains the code for both the CLIENT and the SERVER
{ drivers. Except for initialization and somewhat different processing of a
{ received message, the two drivers are identical and ascertain which end of
{ a line they are driving from the connection descriptor in the driver queue
{ header.
{ The two drivers communicate with each other  using the application
{ protocol over CDCNET connection(s). The number of connections in use
{ is defined by DFC$MAX_NUMBER_OF_QUEUES.
{
{ Internally, the following global tables are used: Queue_Interface_Table,
{ CPU_Queue, Driver_Queue, and Request_Buffer.
{===========================================================================

?? NEWTITLE := '   Global Declarations   ', EJECT ??

*copyc amt$access_level
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc fst$file_reference
*copyc nat$application_name
*copyc nat$create_attributes
*copyc nat$data_fragments
*copyc nat$network_address
*copyc nat$protocol
*copyc nat$se_peer_operation
*copyc nat$title
*copyc nat$wait_time
*copyc ost$activity_status
*copyc ost$caller_identifier
*copyc ost$name
*copyc ost$status
*copyc ost$wait
*copyc pmt$mainframe_id

*copyc amp$open
*copyc amp$close
*copyc amp$return
*copyc nap$acquire_connection
*copyc nap$attach_server_application
*copyc nap$await_server_response
*copyc nap$detach_server_application
*copyc nap$request_connection
*copyc nap$se_receive_data
*copyc nap$se_send_data
*copyc nlp$get_title_translation
*copyc nlp$translate_title
*copyc osp$set_status_abnormal
*copyc pmp$get_microsecond_clock
*copyc pmp$get_task_cp_time
*copyc pmp$ready_task
*copyc pmp$wait
*copyc dfd$driver_queue_types
*copyc dfe$cdcnet_errors
*copyc dft$cpu_queue
*copyc dft$queue_index
*copyc dfp$process_task_request
*copyc dfp$set_driver_active
*copyc dfi$display
*copyc i#move


?? TITLE := 'DF Constants, Types, and Module-Wide Structures.', EJECT ??

  CONST

{****************************************************************************
{ The line below is to get a clean assembly - take it out.
{****************************************************************************
    dfc$page_size = 4096,
    dfc$cdcnet_max_pages_sendable = 4,
{****************************************************************************
{ The line above is to get a clean assembly - take it out.
{****************************************************************************

    dfc$net_connection_wait_time = 3600 * 1000,
    dfc$data_transfer_timeout = 3600 * 1000,
    dfc$server_maximum_connections = 2;

  CONST
    dfc$min_message_size = 7;

  CONST

    dfc$command_message = 'C',
    dfc$data_message = 'D',
    dfc$connection_idle = 'I';

  TYPE

    dft$connect_status = array [1 .. dfc$max_number_of_queues] of dft$connect_status_entry,

    dft$connect_status_entry = record
      network_file_id: amt$file_identifier,
      network_file_lfn: amt$local_file_name,
      case connection_established: boolean of
      = TRUE =
        network_error: boolean,
        receive_outstanding: boolean,
        wait_for_header: boolean,
        wait_for_buffer: boolean,
        wait_for_ready_for_data: boolean,
        wait_for_data: boolean,
        receive_activity: ost$activity_status,
        peer_action: nat$se_peer_operation,
        received_header: dft$message_header,
        in_message: dft$in_message_buffer,
        send_outstanding: 0 .. dfc$max_queue_entries,
        send_activity: ost$activity_status,
        send_header: dft$message_header,
        out_message: dft$out_message_buffer,
      = FALSE =
        ,
      casend,
    recend,

    dft$message_header = record
      message_type: char,
      entry: dft$queue_entry_index,
      command_length: dfc$min_message_size .. dfc$command_buffer_size,
      data_length: 0 .. dfc$cdcnet_max_pages_sendable * dfc$page_size,
    recend,

    dft$out_message_buffer = record
      head: nat$data_fragment,
      command: nat$data_fragment,
      data: nat$data_fragment,
    recend,

    dft$in_message_buffer = record
      frag1: nat$data_fragment,
      frag2: nat$data_fragment,
    recend;

?? TITLE := '    Global Variables    ', EJECT ??

?? NOCOMPILE ??

  VAR
    dfv$cdcnet_p_qit: [XDCL] dft$p_queue_interface_table := NIL,
    dfv$cdcnet_driver_name: [XDCL] ost$name := ' ',
    queue_status: [XDCL] dft$connect_status;

  VAR
    cdcnet_cycle_time: integer,
    cdcnet_total_time: integer;

?? COMPILE ??

?? TITLE := 'Execute_Driver', EJECT ??

  PROCEDURE [XDCL] dfp$execute_cdcnet_driver
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  pdt execute_driver_pdt (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      execute_driver_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^execute_driver_pdt_names, ^execute_driver_pdt_params];

    VAR
      execute_driver_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      execute_driver_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
            clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

?? NOCOMPILE ??

    VAR
      caller_id: ost$caller_identifier,
      entry_index: dft$queue_entry_index,
      number_of_queue_entries: 1 .. dfc$max_queue_entries,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue: ^dft$driver_queue,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      queue_index: dft$queue_index,
      server: boolean;

{   clp$scan_parameter_list (parameter_list, execute_driver_pdt, status);
{   IF NOT status.normal THEN
{     RETURN;
{   IFEND;

    #CALLER_ID (caller_id);
{ddddddddddddddddddddddddddddddddddddddddddd
    adisplay (' execute_cdcnet_driver ');
{ddddddddddddddddddddddddddddddddddddddddddd
    dfp$set_driver_active (dfv$cdcnet_driver_name, TRUE, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF caller_id.ring = 3 THEN
      {---------------------------------------------
      {The driver is running in hands-on environment
      {---------------------------------------------
      WHILE TRUE DO
        cdcnet_driver (caller_id, dfv$cdcnet_p_qit, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        pmp$wait (500, 500);
      WHILEND;

    ELSE
      {------------------------------------------------
      {The driver is running in Closed-Shop environment
      {------------------------------------------------
      cdcnet_driver (caller_id, dfv$cdcnet_p_qit, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      FOR queue_index := 1 TO dfc$max_number_of_queues DO
        IF queue_status [queue_index].connection_established THEN
          p_driver_queue := dfv$cdcnet_p_qit^.queue_directory.driver_queue_pva_directory [queue_index].
                p_driver_queue;
          server := p_driver_queue^.queue_header.connection_descriptor.source.flags.server_to_client;
          IF server THEN
            number_of_queue_entries := dfv$cdcnet_p_qit^.queue_directory.
                  cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header.
                  number_of_task_queue_entries + dfv$cdcnet_p_qit^.queue_directory.
                  cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header.
                  number_of_monitor_queue_entries;

            FOR entry_index := 1 TO number_of_queue_entries DO
              p_driver_queue_entry := ^p_driver_queue^.queue_entries [entry_index];
              IF p_driver_queue_entry^.flags.subsystem_action THEN
                p_cpu_queue_entry := ^dfv$cdcnet_p_qit^.queue_directory.cpu_queue_pva_directory [queue_index].
                      p_cpu_queue^.queue_entries [entry_index];
{ddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd
                adisplay ('Calling PROCESS_TASK_REQUEST');
{ddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd
                dfp$process_task_request (dfv$cdcnet_p_qit, queue_index, entry_index, p_driver_queue_entry,
                      p_cpu_queue_entry, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              IFEND;
            FOREND;
          IFEND;

        IFEND;
      FOREND;

    IFEND;
?? COMPILE ??
  PROCEND dfp$execute_cdcnet_driver;
?? NOCOMPILE ??
?? TITLE := 'CDCNET Driver', EJECT ??

  PROCEDURE cdcnet_driver
    (    caller_id: ost$caller_identifier;
     VAR p_queue_interface_table: {^input/^output} dft$p_queue_interface_table;
     VAR status: ost$status);

    VAR
      cycle_end: pmt$task_cp_time,
      cycle_start: pmt$task_cp_time,
      driver_cycles: integer,
      p_driver_queue: ^dft$driver_queue,
      queue: dft$queue_index,
      receive_total: integer,
      send_total: integer,
      server: boolean;

    cdcnet_cycle_time := 0;
    driver_cycles := 0;
    receive_total := 0;
    send_total := 0;

    status.normal := TRUE;
    pmp$get_task_cp_time (cycle_start, status);
    receive_messages (caller_id, p_queue_interface_table, queue_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_task_cp_time (cycle_end, status);
    receive_total := receive_total + (cycle_end.task_time - cycle_start.task_time);

    pmp$get_task_cp_time (cycle_start, status);
    examine_request_buffer (caller_id, p_queue_interface_table, queue_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_task_cp_time (cycle_end, status);
    send_total := send_total + (cycle_end.task_time - cycle_start.task_time);
    driver_cycles := driver_cycles + 1;
    cdcnet_total_time := cdcnet_total_time + cdcnet_cycle_time;
    IF dfv$file_server_debug_enabled THEN
      adisplay_integer ('Driver_Cycles =', driver_cycles);
      adisplay_integer ('Avg. SEND time = ', send_total DIV driver_cycles);
      adisplay_integer ('Avg. RECEIVE time = ', receive_total DIV driver_cycles);
      adisplay_integer ('CDCNET cycle time (microsecs)=', cdcnet_cycle_time);
    IFEND;

  PROCEND cdcnet_driver;
?? COMPILE ??
?? TITLE := 'End_client', EJECT ??

  PROCEDURE [XDCL] dfp$end_client
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{    pdt end_client_pdt (client_queue_index, cqi: integer 1 .. 8 = 1
{                          status)

?? PUSH (LISTEXT := ON) ??

    VAR
      end_client_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^end_client_pdt_names, ^end_client_pdt_params];

    VAR
      end_client_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['CLIENT_QUEUE_INDEX', 1], ['CQI', 1], ['STATUS', 2]];

    VAR
      end_client_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ CLIENT_QUEUE_INDEX CQI }
      [[clc$optional_with_default, ^end_client_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$integer_value, 1, 8]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      end_client_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '1';

?? POP ??

    VAR
      length: integer,
      lfn: amt$local_file_name,
      pfn: amt$file_identifier,
      queue_index: dft$queue_index,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, end_client_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('CLIENT_QUEUE_INDEX', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    queue_index := value.int.value;
?? NOCOMPILE ??
    lfn := queue_status [queue_index].network_file_lfn;
    pfn := queue_status [queue_index].network_file_id;
    terminate_connection (pfn, lfn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    queue_status [queue_index].connection_established := FALSE;
?? COMPILE ??
  PROCEND dfp$end_client;

?? TITLE := 'End_Server', EJECT ??

  PROCEDURE [XDCL] dfp$end_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{   pdt end_server_pdt (server_queue_index, sqi: integer 1 .. 8 = 1
{                             status)

?? PUSH (LISTEXT := ON) ??

    VAR
      end_server_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^end_server_pdt_names, ^end_server_pdt_params];

    VAR
      end_server_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['SERVER_QUEUE_INDEX', 1], ['SQI', 1], ['STATUS', 2]];

    VAR
      end_server_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ SERVER_QUEUE_INDEX SQI }
      [[clc$optional_with_default, ^end_server_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$integer_value, 1, 8]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      end_server_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '1';

?? POP ??
?? NOCOMPILE ??

    VAR
      length: integer,
      lfn: amt$local_file_name,
      pfn: amt$file_identifier,
      queue_index: dft$queue_index,
      server: ost$name,
      value: clt$value,
      working_string: string (15);

    clp$scan_parameter_list (parameter_list, end_server_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('SERVER_QUEUE_INDEX', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    queue_index := value.int.value;
    working_string := '';
    STRINGREP (working_string, length, 'DF_SERVER', queue_index);
    server := working_string;
    server (10) := '_';

    lfn := queue_status [queue_index].network_file_lfn;
    pfn := queue_status [queue_index].network_file_id;
    terminate_connection (pfn, lfn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    terminate_server (server, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    queue_status [queue_index].connection_established := FALSE;
?? COMPILE ??
  PROCEND dfp$end_server;

?? TITLE := 'Start_CDCNET_Client', EJECT ??

  PROCEDURE [XDCL] dfp$start_cdcnet_client
    (    p_queue_interface_table: dft$p_queue_interface_table;
         driver_name: ost$name;
         destination_mainframe: pmt$mainframe_id;
         queue_index: dft$queue_index;
     VAR status: ost$status);

?? NOCOMPILE ??

    VAR
      client: ost$name,
      length: integer,
      lfn: amt$local_file_name,
      pfn: amt$file_identifier,
      server: nat$title,
      working_string: string (15);

{ddddddddddddddddddddddddddddddddddddddddddddddddddd
    display (' --- dfp$start_cdcnet_client ');
{ddddddddddddddddddddddddddddddddddddddddddddddddddd
    dfv$cdcnet_p_qit := p_queue_interface_table;
    dfv$cdcnet_driver_name := driver_name;
{ddddddddddddddddddddddddddddddddddddddddddddddddddd
    display (dfv$cdcnet_driver_name);
    adisplay (destination_mainframe);
    display_pva (' queue interface table ', p_queue_interface_table);
    adisplay_integer (' queue index ', queue_index);
{ddddddddddddddddddddddddddddddddddddddddddddddddddd
    working_string := '';
    STRINGREP (working_string, length, 'DF_SERVER', queue_index);
    server := working_string;
    server (10) := '_';

    working_string := '';
    STRINGREP (working_string, length, 'DF_CLIENT', queue_index);
    client := working_string;
    client (10) := '_';

    working_string := '';
    STRINGREP (working_string, length, 'DFF$', destination_mainframe (9, 9), queue_index);
    working_string (14) := '_';
    lfn := working_string;

    queue_status [queue_index].network_file_lfn := lfn;
    initiate_client (client, server, lfn, pfn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    queue_status [queue_index].network_file_id := pfn;
    queue_status [queue_index].connection_established := TRUE;
    queue_status [queue_index].receive_outstanding := FALSE;
    queue_status [queue_index].send_outstanding := 0;
    queue_status [queue_index].network_error := FALSE;
    queue_status [queue_index].wait_for_header := FALSE;
    queue_status [queue_index].wait_for_buffer := FALSE;
    queue_status [queue_index].wait_for_data := FALSE;
    cdcnet_total_time := 0;
?? COMPILE ??
  PROCEND dfp$start_cdcnet_client;

?? TITLE := 'Start_CDCNET_Server', EJECT ??

  PROCEDURE [XDCL] dfp$start_cdcnet_server
    (    p_queue_interface_table: dft$p_queue_interface_table;
         driver_name: ost$name;
         destination_mainframe: pmt$mainframe_id;
         queue_index: dft$queue_index;
     VAR status: ost$status);

?? NOCOMPILE ??

    VAR
      length: integer,
      lfn: amt$local_file_name,
      pfn: amt$file_identifier,
      server: ost$name,
      working_string: string (15);

{ddddddddddddddddddddddddddddddddddddddddddddddddddddddd
    display (' ---- dfp$start_cdcnet_server ');
{ddddddddddddddddddddddddddddddddddddddddddddddddddddddd
    dfv$cdcnet_p_qit := p_queue_interface_table;
    dfv$cdcnet_driver_name := driver_name;
{ddddddddddddddddddddddddddddddddddddddddddddddddddddddd
    display (dfv$cdcnet_driver_name);
    adisplay (destination_mainframe);
    display_pva (' queue interface table ', p_queue_interface_table);
    adisplay_integer (' queue index ', queue_index);
{ddddddddddddddddddddddddddddddddddddddddddddddddddddddd
    working_string := '';
    STRINGREP (working_string, length, 'DF_SERVER', queue_index);
    server := working_string;
    server (10) := '_';

    working_string := '';
    STRINGREP (working_string, length, 'DFF$', destination_mainframe (9, 9), queue_index);
    lfn := working_string;
    lfn (14) := '_';
    queue_status [queue_index].network_file_lfn := lfn;

    initiate_server (server, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_client_connection (server, lfn, pfn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    queue_status [queue_index].network_file_id := pfn;
    queue_status [queue_index].connection_established := TRUE;
    queue_status [queue_index].receive_outstanding := FALSE;
    queue_status [queue_index].send_outstanding := 0;
    queue_status [queue_index].network_error := FALSE;
    queue_status [queue_index].wait_for_header := FALSE;
    queue_status [queue_index].wait_for_buffer := FALSE;
    queue_status [queue_index].wait_for_data := FALSE;
    cdcnet_total_time := 0;
?? COMPILE ??
  PROCEND dfp$start_cdcnet_server;
?? NOCOMPILE ??
?? TITLE := 'Get_Client_Connection', EJECT ??

  PROCEDURE get_client_connection
    (    server_name: ost$name;
         network_file_lfn: amt$local_file_name;
     VAR network_file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      network_file_attribute: array [1 .. 1] of nat$create_attribute,
      network_file_attributes: ^nat$create_attributes,
      network_protocol: nat$protocol,
      network_wait: nat$wait_time;

    network_file_attribute [1].kind := nac$data_transfer_timeout;
    network_file_attribute [1].data_transfer_timeout := dfc$data_transfer_timeout;
    network_file_attributes := ^network_file_attribute;
    network_wait := dfc$net_connection_wait_time;
    nap$acquire_connection (server_name, network_file_lfn, network_file_attributes, network_wait, status);
    IF NOT status.normal THEN
      display ('Abnormal Status from ACQUIRE_CONNECTION.');
      display_status (status);
      RETURN;
    IFEND;
    display ('Connection Acquired - no problem.');

{==============================================================================
{ NOTE: NAP$ACCEPT_CONNECTION is not executed for now because the Distributed
{ Files Server is set up so that the network accepts the connection on behalf
{ of the application. This setup is defined in the Server's application
{ definition file by the network application administrator.
{
{ nap$accept_connection (network_file_lfn, status);
{  IF NOT status.normal THEN
{    display ('Abnormal Status from ACCEPT_CONNECTION.');
{    display_status (status);
{    RETURN;
{  IFEND;
{==============================================================================

    amp$open (network_file_lfn, {access_level=} amc$record, {access_selections=} NIL, network_file_id,
          status);
    IF NOT status.normal THEN
      display ('Abnormal Status from OPEN_FILE.');
      display_status (status);
      RETURN;
    IFEND;

  PROCEND get_client_connection;

?? TITLE := 'Initiate_Client', EJECT ??

  PROCEDURE initiate_client
    (    client: ost$name;
         server_title: nat$title;
         network_file_lfn: amt$local_file_name;
     VAR network_file_id: amt$file_identifier;
     VAR status: ost$status);

{==============================================================================
{ This PROC establishes a single connection to the DFServer. Status indicates
{ whether or not the connection was established.
{==============================================================================

    VAR
      activity_status: ost$activity_status,
      address: nat$translation_address,
      identifier: nat$directory_entry_identifier,
      network_file_attribute: array [1 .. 1] of nat$create_attribute,
      network_file_attributes: ^nat$create_attributes,
      network_protocol: nat$protocol,
      network_wait: nat$wait_time,
      priority: nat$translation_priority,
      protocol_service: nat$service,
      request_id: nat$translation_request_id,
      search_domain: nat$title_domain,
      selected_access: amt$file_access_selections,
      server_location: nat$network_address,
      server_title_returned: nat$title,
      title_class: nat$title_class,
      user_info_length: 0 .. nac$max_user_info;

    status.normal := TRUE;
    protocol_service := nac$session;
    search_domain.kind := nac$catenet_domain;
    title_class := nac$cdna_external;
{ddddddddddddddddddddddddddddddddddddddddddddddddddddddd
    adisplay (' ----- initiate_client, s title, client ');
    display (server_title);
    adisplay (client);
{ddddddddddddddddddddddddddddddddddddddddddddddddddddddd

    nlp$translate_title (server_title, {wild_card=} FALSE, protocol_service, {recurrent_search=} FALSE,
          search_domain, title_class, request_id, status);
    IF NOT status.normal THEN
      display ('Abnormal Status from TRANSLATE_TITLE.');
      display_status (status);
      RETURN;
    IFEND;

    priority := 1;
    protocol_service := nac$service_unknown;
    server_title_returned := '';
    status.normal := TRUE;
    user_info_length := 0;
    nlp$get_title_translation (request_id, server_title_returned, address, protocol_service,
          {user_information=} NIL, user_info_length, priority, identifier, status);
    IF NOT status.normal THEN
      display ('Abnormal Status from GET_TITLE_TRANSLATION.');
      display_status (status);
      RETURN;
    IFEND;

    network_file_attribute [1].kind := nac$data_transfer_timeout;
    network_file_attribute [1].data_transfer_timeout := dfc$data_transfer_timeout;
    network_file_attributes := ^network_file_attribute;
    network_protocol := nac$cdna_session;
    server_location.kind := nac$internet_address;
    server_location.internet_address := address.internet;
    nap$request_connection (server_location, client, network_file_lfn, network_protocol,
          network_file_attributes, {wait_time=} 0, status);
    IF NOT status.normal THEN
      display ('Abnormal Status from REQUEST_CONNECTION.');
      display_status (status);
      RETURN;
    IFEND;
    nap$await_server_response (network_file_lfn, dfc$net_connection_wait_time, status);

    IF NOT status.normal THEN
      display ('Abnormal Status from AWAIT_SERVER_RESPONSE.');
      display_status (status);
      RETURN;

    ELSE
      amp$open (network_file_lfn, {access_level=} amc$record, {access_selections=} NIL, network_file_id,
            status);
      IF NOT status.normal THEN
        display ('Abnormal Status from OPEN_FILE.');
        display_status (status);
        RETURN;
      IFEND;
    IFEND;

  PROCEND initiate_client;

?? TITLE := 'Initiate_Server', EJECT ??

  PROCEDURE initiate_server
    (    server_name: ost$name;
     VAR status: ost$status);

{==============================================================================
{ This PROC activates the DFServer on the CDCNET network. It is issued once
{ per Server job. Status indicates whether or not the SERVER application was
{ attached.
{==============================================================================

    nap$attach_server_application (server_name, dfc$server_maximum_connections, status);
    IF NOT status.normal THEN
      display ('Abnormal Status from ATTACH_SERVER_APPLICATION.');
      display_status (status);
    IFEND;
  PROCEND initiate_server;

?? TITLE := 'Terminate_Connection', EJECT ??

  PROCEDURE terminate_connection
    (    network_file_id: amt$file_identifier;
         network_file_lfn: amt$local_file_name;
     VAR status: ost$status);

{=============================================================================
{ TERMINATE_CONNECTION closes and returns the network file associated with a
{ single connection.
{=============================================================================

    amp$close (network_file_id, status);
    IF NOT status.normal THEN
      display ('Abnormal status from AMP$CLOSE.');
      RETURN;
    IFEND;

    amp$return (network_file_lfn, status);
    IF NOT status.normal THEN
      display ('Abnormal status from AMP$RETURN.');
      RETURN;
    IFEND;

  PROCEND terminate_connection;

?? TITLE := 'Terminate_Server', EJECT ??

  PROCEDURE terminate_server
    (    server_name: ost$name;
     VAR status: ost$status);

{=============================================================================
{ TERMINATE_SERVER detaches the job from the Server application indicated in
{ the input parameter.
{=============================================================================

    nap$detach_server_application (server_name, status);
    IF NOT status.normal THEN
      display ('Abnormal status from DETACH_SERVER_APPLICATION.');
      display_status (status);
    IFEND;

  PROCEND terminate_server;

?? TITLE := 'Receive_Messages', EJECT ??

  PROCEDURE receive_messages
    (    caller_id: ost$caller_identifier;
     VAR p_queue_interface_table: {^input/^output} dft$p_queue_interface_table;
     VAR queue_status: {input/output} dft$connect_status;
     VAR status: ost$status);

{==============================================================================
{ This PROC attempts to receive messages from all Servers/Clients.
{ No attempt is made to issue a receive message request on a connection which
{ already has such request pending and not yet completed.
{ One or two calls are made for each potential message: one (with a small
{ buffer) to receive the message header (which is processed within the
{ driver), and to receive the command buffer (present in every message). If the
{ message includes data page(s) and the data buffer has been pre-allocated then
{ it is also obtained. If the data buffer has not been allocated then completion
{ of the receive request is delayed until the data buffer becomes available.
{
{ The message header is part of the protocol of the two drivers. It is created
{ by one driver and decoded by the other. It is never seen by other Distributed
{ Files tasks. The balance of the message (the command and data) is ultimately
{ received by the other Distributed Files tasks.
{===========================================================================

    VAR
      cdcnet_wait: ost$wait,
      end_of_message: boolean,
      end_time: pmt$task_cp_time,
      entry: dft$queue_entry_index,
      p_buffer: dft$p_command_buffer,
      p_cpu_queue: ^dft$cpu_queue,
      p_data: dft$p_data_area,
      p_driver_queue: ^dft$driver_queue,
      p_flags: ^dft$queue_entry_flags,
      p_queue_status: ^dft$connect_status_entry,
      prealloc_data_buffer: boolean,
      queue: dft$queue_index,
      server: boolean,
{dddddddddddddddddddddddddddddddddddddddddddddd
      dummy: integer,
{dddddddddddddddddddddddddddddddddddddddddddddd
      start_time: pmt$task_cp_time;

    status.normal := TRUE;
    FOR queue := 1 TO dfc$max_number_of_queues DO

      IF queue_status [queue].connection_established AND NOT queue_status [queue].network_error THEN
        p_queue_status := ^queue_status [queue];
        IF p_queue_status^.receive_outstanding THEN
          check_received_status (p_queue_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF NOT queue_status [queue].receive_outstanding THEN
{           --------------------------------------------------------
{           Previously issued receive_request has just completed.
{           Set pointer to a specific connection and examine header.
{           --------------------------------------------------------
            p_cpu_queue := p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue].
                  p_cpu_queue;
            p_driver_queue := p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue].
                  p_driver_queue;
            validate_received_header (p_queue_status, p_driver_queue^.queue_header.number_of_queue_entries,
                  entry, status);

            IF status.normal THEN
{             ---------------------------------------------------------------
{             Set pointers to the queue entry for this connection. Validate
{             flags if appropriate for the received message and read the rest
{             of the message. Set flags to reflect the message just received.
{             ---------------------------------------------------------------
              p_flags := ^p_driver_queue^.queue_entries [entry].flags;
              p_buffer := p_cpu_queue^.queue_entries [entry].p_receive_buffer;
              p_data := p_cpu_queue^.queue_entries [entry].p_data_area;
              prealloc_data_buffer := (p_driver_queue^.queue_entries [entry].data_descriptor.actual_length <>
                    0);
              server := p_driver_queue^.queue_header.connection_descriptor.source.flags.server_to_client;
{ddddddddddddddddddddddddddddddddddddddddddddddddddd
              IF dfv$cdcnet_debug_enabled THEN
                adisplay ('RECEIVE BEFORE process_received_msg');
                adisplay_integer ('Entry =', entry);
                adisplay_bytes ('Flags = ', p_flags, 2);
                adisplay_header ('Received Header=', p_queue_status^.received_header);
                adisplay_boolean ('Wait_for_header =', p_queue_status^.wait_for_header);
                adisplay_boolean ('Wait_for_ready =', p_queue_status^.wait_for_ready_for_data);
                adisplay_boolean ('Receive_Outstan =', p_queue_status^.receive_outstanding);
              IFEND;
{ddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd
              process_received_message (p_buffer, p_data, prealloc_data_buffer, p_flags, p_queue_status,
                    server, status);
{ddddddddddddddddddddddddddddddddddddddddddddddddddd
              IF dfv$cdcnet_debug_enabled THEN
                adisplay ('RECEIVE AFTER process_received_message');
                adisplay_bytes ('Flags = ', p_flags, 2);
                adisplay_boolean ('Wait_for_header =', p_queue_status^.wait_for_header);
                adisplay_boolean ('Wait_for_ready =', p_queue_status^.wait_for_ready_for_data);
                adisplay_boolean ('Receive_Outstan =', p_queue_status^.receive_outstanding);
              IFEND;
{ddddddddddddddddddddddddddddddddddddddddddddddddddd
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              IF p_flags^.subsystem_action AND (caller_id.ring = 3) THEN
{               -----------------------------------------------------------
{               Subsystem_action set in the hands-on environment - activate
{               caller.
{               -----------------------------------------------------------
                pmp$ready_task (p_cpu_queue^.queue_entries [entry].global_task_id, status);
                IF NOT status.normal THEN
                  display ('Abnormal status from pmp$ready_task.');
                  display_status (status);
                  RETURN;
                IFEND;
              IFEND;

            ELSE
              RETURN;
            IFEND;
          IFEND;
        IFEND;

        IF NOT p_queue_status^.receive_outstanding THEN
{         -----------------------------------------------------------------
{         This connection did not have 'receive request' pending or it may
{         have finished processing a just received message. Issue receive
{         request, with the message area for the header only.
{         -----------------------------------------------------------------
{ddddddddddddddddddddddddddddddddddddddddddddddddddd
          IF dfv$cdcnet_debug_enabled THEN
            adisplay ('ISSUE RECEIVE - none outstanding');
            adisplay_bytes ('Flags = ', p_flags, 2);
            adisplay_boolean ('Wait_for_header =', p_queue_status^.wait_for_header);
            adisplay_boolean ('Wait_for_ready =', p_queue_status^.wait_for_ready_for_data);
          IFEND;
{ddddddddddddddddddddddddddddddddddddddddddddddddddd
          p_queue_status^.in_message.frag1.address := ^p_queue_status^.received_header;
          p_queue_status^.in_message.frag1.length := #SIZE (p_queue_status^.received_header);
          p_queue_status^.in_message.frag2.address := NIL;
          p_queue_status^.in_message.frag2.length := 0;
          p_queue_status^.wait_for_header := TRUE;
          cdcnet_wait := osc$nowait;
          issue_receive_request (p_queue_status, cdcnet_wait, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        IFEND;
      IFEND;

    FOREND;

  PROCEND receive_messages;

?? TITLE := 'Check_Received_Length', EJECT ??

  PROCEDURE check_received_length
    (    received_header: dft$message_header;
         data_length: nat$data_length;
         peer_action: nat$se_peer_operation;
     VAR status: ost$status);

{==============================================================================
{ This PROC is called after the last fragment of the message has been received.
{ When only the command has been received then its length and the expected
{ length are compared.
{ If both the command and the data has been received then the comparison is
{ made of the expected and the actual lengths of the received{ data only (not
{ of the command). The Status is set to FALSE (via{ Set_Connection_Error) if
{ the two lengths do not match.
{ If the network did not set 'end_of message' when the data fragment was
{ received then the allocated area was not sufficient to hold the entire data
{ and the tail end of the message is still being held by the network. Something
{ went wrong either at the receiving or the sending end of the driver.
{=============================================================================

    status.normal := TRUE;
    IF peer_action.end_of_message THEN
      IF (received_header.message_type = dfc$command_message) THEN
        IF NOT (data_length = peer_action.data_length) THEN
          display ('Length of Received Command Does Not Match Length in Header.');
          set_connection_error (dfe$peer_error, {receive=} TRUE, status);
        IFEND;

      ELSE
        IF NOT (data_length = peer_action.data_length) THEN
          display ('Length of Received Data Does Not Match Length in Header.');
          set_connection_error (dfe$peer_error, {receive=} TRUE, status);
        IFEND;
      IFEND;

    ELSE
      display ('Data Buffer not Sufficient to Hold Received Message');
      set_connection_error (dfe$peer_error, {receive=} TRUE, status);
{     -----------------------------------------------------------------
{     Something must be done here with the part of the message still in
{     the network.
{     -----------------------------------------------------------------
    IFEND;

  PROCEND check_received_length;

?? TITLE := 'Check_Received_Status', EJECT ??

  PROCEDURE check_received_status
    (    p_queue_status: {^input/^output} ^dft$connect_status_entry;
     VAR status: ost$status);

{=============================================================================
{ This subroutine checks the activity status and the peer operation associated
{ with the received message.
{
{ Message Length returned by the network is not used currently.
{=============================================================================

    status.normal := TRUE;
    IF p_queue_status^.receive_activity.complete THEN
      p_queue_status^.receive_outstanding := FALSE;

      IF NOT p_queue_status^.receive_activity.status.normal THEN
        display ('Abnormal status from RECEIVE_ACTIVITY_STATUS');
        status := p_queue_status^.receive_activity.status;
        display_status (status);
        p_queue_status^.network_error := TRUE;
        RETURN;
      IFEND;

      CASE p_queue_status^.peer_action.kind OF
      = nac$se_send_data =

        IF p_queue_status^.peer_action.qualified_data THEN
          display ('Received QUALIFIED_DATA From the Peer.');
          set_connection_error (dfe$peer_error, {receive=} TRUE, status);
        IFEND;

{****************************************************************************
{ Next 3 lines - Temporary patch to get by CDCNET bug - should be taken out.
{****************************************************************************
        IF p_queue_status^.peer_action.end_of_message AND (p_queue_status^.peer_action.data_length = 3) THEN
          p_queue_status^.peer_action.end_of_message := FALSE;
        IFEND;
{****************************************************************************
{ Above 3 lines - Temporary patch to get by CDCNET bug - should be taken out.
{****************************************************************************

      ELSE
        display ('Peer_Action Other Than NAC$SE_Send_Data.');
        set_connection_error (dfe$peer_error, {receive=} TRUE, status);
      CASEND;

    ELSE
      p_queue_status^.receive_outstanding := TRUE;
      RETURN;

    IFEND;
  PROCEND check_received_status;

?? TITLE := 'Issue_Receive_Request', EJECT ??

  PROCEDURE issue_receive_request
    (    p_queue_status: {^output} ^dft$connect_status_entry;
         cdcnet_wait: ost$wait;
     VAR status: ost$status);

{==========================================================================
{ This PROC issues a 'receive_data' request to the network. The size of the
{ buffer passed to this PROC will determine whether a partial message
{ (header) or the rest (non-header) message is eventually received received
{ from the peer.
{==========================================================================

    VAR
      in_message_p: ^nat$data_fragments;

    VAR
      end_time: pmt$task_cp_time,
      start_time: pmt$task_cp_time;

    PUSH in_message_p: [1 .. 2];
    in_message_p^ [1] := p_queue_status^.in_message.frag1;
    in_message_p^ [2] := p_queue_status^.in_message.frag2;

    pmp$get_task_cp_time (start_time, status);
    nap$se_receive_data (p_queue_status^.network_file_id, in_message_p^, cdcnet_wait,
          p_queue_status^.peer_action, p_queue_status^.receive_activity, status);
    pmp$get_task_cp_time (end_time, status);
    cdcnet_cycle_time := cdcnet_cycle_time + (end_time.task_time - start_time.task_time);

    p_queue_status^.receive_outstanding := TRUE;
    IF NOT status.normal THEN
      display ('Abnormal status from ISSUE_RECEIVE_REQUEST');
      p_queue_status^.network_error := TRUE;
    IFEND;
  PROCEND issue_receive_request;

?? TITLE := 'Process_Received_Message', EJECT ??

  PROCEDURE process_received_message
    (    p_buffer: dft$p_command_buffer;
         p_data: dft$p_data_area;
         prealloc_data_buffer: boolean;
         p_flags: {^input/^output} ^dft$queue_entry_flags;
         p_queue_status: {^output} ^dft$connect_status_entry;
         server: boolean;
     VAR status: ost$status);

{=============================================================================
{ This PROC makes certain that the flags within the driver's entry 'expect'
{ the type of message that is being received, then the balance of the message
{ (command and/or data messages) is read. Some length checking is performed.
{=============================================================================

    VAR
      cdcnet_wait: ost$wait,
      data_length: nat$data_length,
      received_header: dft$message_header,
      peer_action: nat$se_peer_operation,
      in_message: dft$in_message_buffer;

{   -----------------------------------------------
{   Check if the message is for a legitimate entry.
{   -----------------------------------------------
    IF NOT p_flags^.active_entry THEN
      display ('Message received for inactive entry.');
      set_connection_error (dfe$peer_error, {receive=} TRUE, status);
      set_queue_error_flags (p_flags);
      RETURN;
    IFEND;
    CASE p_queue_status^.received_header.message_type OF
    = dfc$data_message =
      IF p_flags^.data_received THEN
        display ('Duplicate Data Message Received');
        set_connection_error (dfe$peer_error, {receive=} TRUE, status);
        set_queue_error_flags (p_flags);
        RETURN;
      IFEND;

      IF p_queue_status^.wait_for_header THEN
{       ----------------------------------------------------------------------
{       Both Client and Server have the command area preassigned so immediate
{       request for the command can be issued on either mainframe.
{
{       IF SERVER: Set the receiving area address for the command buffer only
{                  and set WAIT_FOR_READY_FOR_DATA flag.
{       IF CLIENT:
{          IF data area is preallocated:
{                Set to receive command AND data, finish the RECEIVE processing.
{          ELSEIF data area is not preallocated:
{                Set the receiving area address for the command buffer only
{                and set WAIT_FOR_READY_FOR_DATA.
{       -----------------------------------------------------------
        p_queue_status^.wait_for_header := FALSE;
        p_queue_status^.in_message.frag1.address := p_buffer;
        p_queue_status^.in_message.frag1.length := p_queue_status^.received_header.command_length;
        IF server OR (NOT server AND NOT prealloc_data_buffer) THEN
          p_queue_status^.wait_for_ready_for_data := TRUE;
          cdcnet_wait := osc$nowait;

        ELSE
          p_queue_status^.in_message.frag2.address := p_data;
          p_queue_status^.in_message.frag2.length := p_queue_status^.received_header.data_length;
          cdcnet_wait := osc$wait;
        IFEND;

        issue_receive_request (p_queue_status, cdcnet_wait, status);
        IF NOT status.normal THEN
          set_queue_error_flags (p_flags);
          RETURN;
        IFEND;
        check_received_status (p_queue_status, status);
        IF status.normal THEN
          IF p_queue_status^.receive_outstanding THEN
            display ('ERROR - Receive_Outstanding for BUFFER/DATA.');
            set_queue_error_flags (p_flags);
            RETURN;
          IFEND;
        ELSE
          RETURN;
        IFEND;

        IF p_queue_status^.wait_for_ready_for_data THEN
          p_queue_status^.receive_outstanding := TRUE;
        ELSE
          data_length := p_queue_status^.in_message.frag1.length + p_queue_status^.in_message.frag2.length;
          check_received_length (p_queue_status^.received_header, data_length, p_queue_status^.peer_action,
                status);
          p_flags^.data_received := TRUE;
{RRRRRRRRRRRrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr
{ Try taking out Setting buffer_sent and data_sent in the two lines below
{RRRRRRRRRRRrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr
          p_flags^.buffer_sent := FALSE;
          p_flags^.data_sent := FALSE;
        IFEND;
        p_flags^.buffer_received := TRUE;
        p_flags^.subsystem_action := TRUE;
        p_flags^.driver_action := FALSE;

      ELSEIF p_queue_status^.wait_for_ready_for_data THEN
{       ---------------------------------------------------------------
{       IF READY_FOR_DATA_SENT is set then get rest of data from the
{       network. Otherwise, keep 'receive_outstanding' = TRUE.
{       ---------------------------------------------------------------
        IF p_flags^.ready_for_data_sent THEN
          p_queue_status^.wait_for_ready_for_data := FALSE;
          p_queue_status^.in_message.frag1.address := p_data;
          p_queue_status^.in_message.frag1.length := p_queue_status^.received_header.data_length;
          cdcnet_wait := osc$wait;
          issue_receive_request (p_queue_status, cdcnet_wait, status);
          IF NOT status.normal THEN
            set_queue_error_flags (p_flags);
            RETURN;
          IFEND;
          check_received_status (p_queue_status, status);
          IF status.normal THEN
            IF p_queue_status^.receive_outstanding THEN
              display ('ERROR - Receive_Outstanding for DATA.');
              set_queue_error_flags (p_flags);
              RETURN;
            IFEND;
          ELSE
            RETURN;
          IFEND;

          p_flags^.data_received := TRUE;
          data_length := p_queue_status^.in_message.frag1.length;
          check_received_length (p_queue_status^.received_header, data_length, p_queue_status^.peer_action,
                status);
          p_flags^.subsystem_action := TRUE;
          p_flags^.driver_action := FALSE;
        ELSE
          p_queue_status^.receive_outstanding := TRUE;
          RETURN;
        IFEND;

      ELSE
        display ('Illogical Setting of Queue_Status Wait Flags');
        set_connection_error (dfe$program_logic_error, {receive=} TRUE, status);
        set_queue_error_flags (p_flags);
      IFEND;

    = dfc$command_message =
      IF server OR (NOT server AND p_flags^.buffer_sent) THEN
{       ----------------------------------------------------------------------
{       Set the receiving area address for the coming buffer, get the buffer,
{       check its length, and set the appropriate flags in the DRIVER QUEUE.
{       ----------------------------------------------------------------------
        IF p_queue_status^.wait_for_header THEN
          p_queue_status^.in_message.frag1.address := p_buffer;
          p_queue_status^.in_message.frag1.length := p_queue_status^.received_header.command_length;
          p_queue_status^.wait_for_header := FALSE;
          cdcnet_wait := osc$nowait;
          issue_receive_request (p_queue_status, cdcnet_wait, status);
          IF NOT status.normal THEN
            set_queue_error_flags (p_flags);
          IFEND;
          check_received_status (p_queue_status, status);
          IF status.normal THEN
            IF p_queue_status^.receive_outstanding THEN
              display ('ERROR - Receive_Outstanding for BUFFER.');
              set_queue_error_flags (p_flags);
              RETURN;
            IFEND;
          ELSE
            RETURN;
          IFEND;

{RRRRRRRRRRRrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr
{ Try taking out Setting buffer_sent and data_sent in the code below
{RRRRRRRRRRRrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr
          p_flags^.buffer_received := TRUE;
          p_flags^.buffer_sent := FALSE;
          p_flags^.data_sent := FALSE;
          p_flags^.subsystem_action := TRUE;
          p_flags^.driver_action := FALSE;
          check_received_length (p_queue_status^.received_header, p_queue_status^.in_message.frag1.length,
                p_queue_status^.peer_action, status);

        ELSE
          display ('Illogical Setting of Queue_Status Wait Flags');
          set_connection_error (dfe$program_logic_error, {receive=} TRUE, status);
          set_queue_error_flags (p_flags);
        IFEND;

      ELSE
        display ('Unsolicited Buffer Received From Server');
        set_connection_error (dfe$peer_error, {receive=} TRUE, status);
        set_queue_error_flags (p_flags);
      IFEND;

    = dfc$connection_idle =
{     -------------------------------------------
{     Processing here will be decided upon later.
{     -------------------------------------------
      RETURN;

    ELSE
      display ('Received Unidentified Message Header.');
      set_connection_error (dfe$peer_error, {receive=} TRUE, status);
    CASEND;

  PROCEND process_received_message;

?? TITLE := 'Validate_Received_Header', EJECT ??

  PROCEDURE validate_received_header
    (    p_queue_status: ^dft$connect_status_entry;
         number_of_entries: 0 .. 0FFFF(16);
     VAR entry: dft$queue_entry_index;
     VAR status: ost$status);

{=========================================================================
{ This PROC validates the header of the message received from the peer for
{ the correctness of the message type and size. It also verifies that the
{ end of message indicator is set only for the prompt-type message.
{=========================================================================

    IF NOT ((p_queue_status^.received_header.message_type = dfc$command_message) OR
          (p_queue_status^.received_header.message_type = dfc$data_message) OR
          (p_queue_status^.received_header.message_type = dfc$connection_idle)) THEN
      display ('Unidentified message type in received header.');
      set_connection_error (dfe$peer_error, {receive=} TRUE, status);
      RETURN;
    IFEND;

    IF (p_queue_status^.received_header.message_type = dfc$connection_idle) AND
          NOT p_queue_status^.peer_action.end_of_message THEN
      display ('Received  Connection_Idle Header with Length Too Large.');
      set_connection_error (dfe$peer_error, {receive=} TRUE, status);
      RETURN;

    ELSEIF (p_queue_status^.received_header.message_type = dfc$connection_idle) THEN
{     -------------------------------------------------------------------
{     It has not been decided how to use this message type and what to do
{     with it.
{     -------------------------------------------------------------------
      RETURN;
    IFEND;

    IF (p_queue_status^.received_header.entry < 1) OR (p_queue_status^.received_header.entry >
          number_of_entries) THEN
      display ('Queue entry error in received header.');
      set_connection_error (dfe$peer_error, {receive=} TRUE, status);
      RETURN;
    IFEND;
    entry := p_queue_status^.received_header.entry;

    IF (p_queue_status^.received_header.command_length > dfc$command_buffer_size) OR
          (p_queue_status^.received_header.command_length < dfc$min_message_size) THEN
      display ('Received Erroneous Command Length in the Header.');
      set_connection_error (dfe$peer_error, {receive=} TRUE, status);
      RETURN;
    IFEND;

    IF (p_queue_status^.received_header.message_type = dfc$data_message) THEN
      IF (p_queue_status^.received_header.data_length <> dfc$page_size) AND
            (p_queue_status^.received_header.data_length <> 2 * dfc$page_size) AND
            (p_queue_status^.received_header.data_length <> 3 * dfc$page_size) AND
            (p_queue_status^.received_header.data_length <> 4 * dfc$page_size) THEN
        display ('Received Erroneous Data Length in the Header.');
        set_connection_error (dfe$peer_error, {receive=} TRUE, status);
        RETURN;
      IFEND;
    IFEND;
    status.normal := TRUE;

  PROCEND validate_received_header;

?? TITLE := 'Examine_Request_Buffer', EJECT ??

  PROCEDURE examine_request_buffer
    (    caller_id: ost$caller_identifier;
     VAR p_queue_interface_table: {^input/^output} dft$p_queue_interface_table;
     VAR queue_status: {^input/^output} dft$connect_status;
     VAR status: ost$status);

{=============================================================================
{ This PROC picks up the Request_Buffer entries between OUT and INN indecees.
{ It cleans out those that were previously processed and prepares for sending
{ newly posted requests.
{=============================================================================

    VAR
      command_length: 0 .. dfc$command_buffer_size,
      data_length: 0 .. dfc$page_size * dfc$cdcnet_max_pages_sendable,
      end_time: integer,
      entry: dft$queue_entry_index,
      inn_bytes: integer,
      limit: integer,
      out_index: 1 .. dfc$max_request_buffer_entries,
      out_bytes: integer,
      p_command_pva: dft$p_command_buffer,
      p_cpu_queue: ^dft$cpu_queue,
      p_data_pva: dft$p_data_area,
      p_driver_queue: ^dft$driver_queue,
      p_flags: ^dft$queue_entry_flags,
      p_queue_status: ^dft$connect_status_entry,
      p_request: ^dft$request_buffer_entries,
      p_request_table: ^dft$request_buffer,
      queue: dft$queue_index,
      server: boolean,
{dddddddddddddddddddddddddddddddd
      dummy: integer,
{dddddddddddddddddddddddddddddddd
      start_time: integer;

    finish_send_requests (caller_id, p_queue_interface_table, queue_status, status);

{   -------------------------------------------------------------------------
{   Scan the Request Buffer from the current value of OUT pointer to INN, and
{   initiate the Send request for every new request entry whose connection is
{   not busy. When the Send request has been issued, set the 'Previously
{   Processed' flag in the request entry to indicate that the request is in
{   progress. DO NOT increment the 'real' OUT pointer!
{   -------------------------------------------------------------------------

    p_request_table := p_queue_interface_table^.request_buffer_directory.p_request_buffer;
    p_request := ^p_request_table^.request_buffer_entries;
    limit := p_queue_interface_table^.request_buffer_directory.limit;
    inn_bytes := p_queue_interface_table^.request_buffer_directory.inn;
    out_bytes := p_queue_interface_table^.request_buffer_directory.out;
    out_index := (out_bytes DIV 8) + 1;

    WHILE (inn_bytes <> out_bytes) DO
      IF NOT (p_request^ [out_index].flags.previously_processed OR (p_request^ [out_index].queue_index = 0))
            THEN
        set_request_pointers (p_request, p_queue_interface_table, out_index, queue_status, queue, entry,
              p_cpu_queue, p_driver_queue, p_flags, p_queue_status);

{ddddddddddddddddddddddddddddddddddddddddddddddddddd
        IF dfv$cdcnet_debug_enabled THEN
          adisplay_integer ('/INITIATE_SEND/ - Queue_index= ', p_request^ [out_index].queue_index);
          dummy := p_queue_status^.send_outstanding;
          adisplay_integer ('Send_outstanding =', dummy);
          adisplay_bytes ('Flags = ', p_flags, 2);
          adisplay_header ('Current SEND_header =', p_queue_status^.send_header);
        IFEND;
{ddddddddddddddddddddddddddddddddddddddddddddddddddd
        IF (p_queue_status^.send_outstanding = 0) THEN
          IF (NOT (p_flags^.active_entry AND p_flags^.driver_action) OR p_flags^.driver_error_alert) THEN
            display_integer ('Error-Request Buffer Entry Invalid', out_index);
            set_connection_error (dfe$program_logic_error, {receive=} FALSE, status);
            RETURN;
          IFEND;

          IF p_flags^.send_ready_for_data THEN
{           -------------------------------------------------------------
{           'send_ready_for_data' is a request for the local driver only.
{           The send is faked by turning flags off and on.
{           ------------------------------------------------------------
            p_flags^.ready_for_data_sent := TRUE;
            p_flags^.send_ready_for_data := FALSE;
            p_request^ [out_index].flags.previously_processed := TRUE;

          ELSE
            p_command_pva := p_cpu_queue^.queue_entries [entry].p_send_buffer;
            command_length := p_driver_queue^.queue_entries [entry].send_buffer_descriptor.actual_length;
            p_data_pva := p_cpu_queue^.queue_entries [entry].p_data_area;
            data_length := (p_driver_queue^.queue_entries [entry].data_descriptor.actual_length DIV 8) *
                  dfc$page_size;
            issue_send_request (p_flags, entry, p_command_pva, command_length, p_data_pva, data_length,
                  p_queue_status, status);
{ddddddddddddddddddddddddddddddddddddddddddddddddddd
            IF dfv$cdcnet_debug_enabled THEN
              adisplay ('/INITIATE_SEND/ AFTER issue_send_request');
              adisplay_header ('SEND_HEADER just issued=', p_queue_status^.send_header);
            IFEND;
{ddddddddddddddddddddddddddddddddddddddddddddddddddd
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            p_request^ [out_index].flags.previously_processed := TRUE;
            p_flags^.buffer_sent := TRUE;
            p_flags^.send_command := FALSE;

            IF p_flags^.send_data THEN
              p_flags^.data_sent := TRUE;
              p_flags^.send_data := FALSE;
            ELSE
{             -------------------------------------------------------------
{             If request sends command buffer only, try to finish it (and
{             those issued on other connections) because the network ought
{             to be very fast with this size messages.
{             -------------------------------------------------------------
              finish_send_requests (caller_id, p_queue_interface_table, queue_status, status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      advance_out (limit, out_bytes, out_index);
    WHILEND;

  PROCEND examine_request_buffer;

?? TITLE := 'Check_Send_Status', EJECT ??

  PROCEDURE check_send_status
    (    p_flags: ^dft$queue_entry_flags;
         p_queue_status: {^input/^output} ^dft$connect_status_entry;
     VAR status: ost$status);

{=========================================================================
{ This module checks the status of the SEND_DATA request and, if abnormal,
{ adjusts the Queue_Table.Queue_Flags to reflect the condition of the
{ particular Queue_Table entry. It also adjust the "status" to be the same
{ as that of network's send_activity_status.
{=========================================================================

    status.normal := TRUE;
    IF p_queue_status^.send_activity.complete THEN
      p_queue_status^.send_outstanding := 0;
      IF NOT p_queue_status^.send_activity.status.normal THEN
        status := p_queue_status^.send_activity.status;
        set_queue_error_flags (p_flags);
        display ('Abnormal status in SEND_ACTIVITY_STATUS');
        display_status (status);
      IFEND;

    ELSE
{ddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd
      adisplay ('Send_Activity is NOT complete!');
{ddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd
      RETURN;
    IFEND;

  PROCEND check_send_status;

?? TITLE := 'Complete_Send_Request', EJECT ??

  PROCEDURE complete_send_request
    (    caller_id: ost$caller_identifier;
         p_queue_status: ^dft$connect_status_entry;
         server: boolean;
         p_flags: {^input/^output} ^dft$queue_entry_flags;
     VAR status: ost$status);

{=============================================================================
{ This PROC checks the status of the previously issued network 'send request'
{ and then, in case of a SERVER, adjust the 'flags' in the Driver Queue Entry
{ to reflect the status of the request.
{ NOTE: Presence of 'send_ready_for_data' flag is considered an error
{       because there is no such network message.
{=========================================================================

    check_send_status (p_flags, p_queue_status, status);
    IF NOT status.normal THEN
      display ('Abnormal status from CHECK_SEND_STATUS');
      display_status (status);
      display ('Driver_Flags = ');
      display_bytes (p_flags, 2);
      RETURN;
    IFEND;

    IF p_queue_status^.send_activity.complete THEN

      IF server AND p_flags^.data_sent THEN
        p_flags^.data_sent := FALSE;
        IF (caller_id.ring = 3) THEN
          p_flags^.subsystem_action := TRUE;
          p_flags^.driver_action := FALSE;
        IFEND;
      IFEND;

      IF server THEN
        p_flags^.buffer_sent := FALSE;
{dddddddddddddddddddddddddddddddddddddddddd
        p_flags^.data_received := FALSE;
        p_flags^.buffer_received := FALSE;
{dddddddddddddddddddddddddddddddddddddddddd
      IFEND;
    IFEND;

  PROCEND complete_send_request;

?? TITLE := 'Finish_Send_Requests', EJECT ??

  PROCEDURE finish_send_requests
    (    caller_id: ost$caller_identifier;
     VAR p_queue_interface_table: {^input/^output} dft$p_queue_interface_table;
     VAR queue_status: {^input/^output} dft$connect_status;
     VAR status: ost$status);

{=============================================================================
{ This PROC picks up the Request_Buffer entries between OUT and INN indecees,
{ cleans out those that were previously processed.
{=============================================================================

    VAR
{dddddddddddddddddddddddddddddddd
      dummy: integer,
{dddddddddddddddddddddddddddddddd
      entry: dft$queue_entry_index,
      inn_bytes: integer,
      limit: integer,
      out_index: 1 .. dfc$max_request_buffer_entries,
      out_bytes: integer,
      p_cpu_queue: ^dft$cpu_queue,
      p_driver_queue: ^dft$driver_queue,
      p_flags: ^dft$queue_entry_flags,
      p_queue_status: ^dft$connect_status_entry,
      p_request: ^dft$request_buffer_entries,
      p_request_table: ^dft$request_buffer,
      queue: dft$queue_index,
      server: boolean;


    status.normal := TRUE;
    p_request_table := p_queue_interface_table^.request_buffer_directory.p_request_buffer;
    p_request := ^p_request_table^.request_buffer_entries;
    limit := p_queue_interface_table^.request_buffer_directory.limit;
    inn_bytes := p_queue_interface_table^.request_buffer_directory.inn;
    out_bytes := p_queue_interface_table^.request_buffer_directory.out;
    out_index := (out_bytes DIV 8) + 1;

    WHILE (inn_bytes <> out_bytes) AND (p_request^ [out_index].flags.previously_processed) DO

      set_request_pointers (p_request, p_queue_interface_table, out_index, queue_status, queue, entry,
            p_cpu_queue, p_driver_queue, p_flags, p_queue_status);
      server := p_driver_queue^.queue_header.connection_descriptor.source.flags.server_to_client;

{ddddddddddddddddddddddddddddddddddddddddddddddddddd
      IF dfv$cdcnet_debug_enabled THEN
        dummy := p_queue_status^.send_outstanding;
        adisplay_integer ('/FINISH_SEND/ -Before-  Send_outstanding =', dummy);
        adisplay_bytes ('Flags = ', p_flags, 2);
        adisplay_header ('Previous SEND_header =', p_queue_status^.send_header);
      IFEND;
{ddddddddddddddddddddddddddddddddddddddddddddddddddd
      IF p_flags^.ready_for_data_sent THEN
        IF p_queue_status^.wait_for_ready_for_data THEN
          RETURN;
        IFEND;
      ELSE
        complete_send_request (caller_id, p_queue_status, server, p_flags, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

{ddddddddddddddddddddddddddddddddddddddddddddddddddd
      IF dfv$cdcnet_debug_enabled THEN
        dummy := p_queue_status^.send_outstanding;
        adisplay_integer ('/FINISH_SEND/ -After- Send_outstanding =', dummy);
        adisplay_bytes ('Flags = ', p_flags, 2);
      IFEND;
{ddddddddddddddddddddddddddddddddddddddddddddddddddd

      IF p_queue_status^.send_activity.complete THEN
        p_request^ [out_index].flags.previously_processed := FALSE;
        p_request^ [out_index].queue_index := 0;
        p_request^ [out_index].queue_entry_index := 0;
        advance_out (limit, out_bytes, out_index);
        p_queue_interface_table^.request_buffer_directory.out := out_bytes;
        p_flags^.ready_for_data_sent := FALSE;

        IF p_flags^.subsystem_action AND (caller_id.ring = 3) THEN
{        -------------------------------------------------------------------
{        Subsystem_action set in the hands-on environment - activate caller.
{        -------------------------------------------------------------------
          pmp$ready_task (p_cpu_queue^.queue_entries [entry].global_task_id, status);
          IF NOT status.normal THEN
            display ('Abnormal status from pmp$ready_task.');
            display_status (status);
            RETURN;
          IFEND;
        IFEND;

      ELSE
        RETURN;
      IFEND;

    WHILEND;

  PROCEND finish_send_requests;

?? TITLE := 'Issue_Send_Request', EJECT ??

  PROCEDURE issue_send_request
    (    p_flags: ^dft$queue_entry_flags;
         entry: dft$queue_entry_index;
         p_command_pva: dft$p_command_buffer;
         command_length: dfc$min_message_size .. dfc$command_buffer_size;
         p_data_pva: dft$p_data_area;
         data_length: 0 .. dfc$cdcnet_max_pages_sendable * dfc$page_size;
     VAR p_queue_status: {^input/^output} ^dft$connect_status_entry;
     VAR status: ost$status);

{=============================================================================
{ This PROC issues send request to the network. Although both, 'p_data_pva'
{ and 'p_command_pva' are passed to the PROC, both or only one of them may
{ be used. If the driver's queue entry flags indicate 'send_data' then both of
{ them are used. Otherwise (only 'send_command' is set), 'p_command_pva' is
{ is used.
{=============================================================================

    VAR
      ignore_status: ost$status,
      network_file_id: amt$file_identifier,
      out_buffer_p: ^nat$data_fragments;

    VAR
      end_time: pmt$task_cp_time,
      start_time: pmt$task_cp_time;

    PUSH out_buffer_p: [1 .. 3];

    IF p_flags^.send_command AND p_flags^.send_data THEN
      p_queue_status^.send_header.message_type := dfc$data_message;
      p_queue_status^.send_header.command_length := command_length;
      p_queue_status^.send_header.data_length := data_length;
      p_queue_status^.out_message.command.address := p_command_pva;
      p_queue_status^.out_message.command.length := command_length;
      p_queue_status^.out_message.data.address := p_data_pva;
      p_queue_status^.out_message.data.length := data_length;

    ELSEIF p_flags^.send_command THEN
      p_queue_status^.send_header.message_type := dfc$command_message;
      p_queue_status^.send_header.command_length := command_length;
      p_queue_status^.send_header.data_length := 0;
      p_queue_status^.out_message.command.address := p_command_pva;
      p_queue_status^.out_message.command.length := command_length;
      p_queue_status^.out_message.data.address := NIL;
      p_queue_status^.out_message.data.length := 0;

    ELSE
      display ('Illogical Driver Flags in Issue_Send_Request');
      set_queue_error_flags (p_flags);
      set_connection_error (dfe$program_logic_error, {receive=} FALSE, status);
      RETURN;
    IFEND;

    p_queue_status^.send_header.entry := entry;
    p_queue_status^.out_message.head.address := ^p_queue_status^.send_header;
    p_queue_status^.out_message.head.length := #SIZE (p_queue_status^.send_header);
    out_buffer_p^ [1] := p_queue_status^.out_message.head;
    out_buffer_p^ [2] := p_queue_status^.out_message.command;
    out_buffer_p^ [3] := p_queue_status^.out_message.data;
    network_file_id := p_queue_status^.network_file_id;

    pmp$get_task_cp_time (start_time, ignore_status);
    nap$se_send_data (network_file_id, out_buffer_p^, {end_of_message=} TRUE, {qualifier=} FALSE, osc$nowait,
          p_queue_status^.send_activity, status);
    pmp$get_task_cp_time (end_time, ignore_status);
    cdcnet_cycle_time := cdcnet_cycle_time + (end_time.task_time - start_time.task_time);

    p_queue_status^.send_outstanding := entry;
    IF NOT status.normal THEN
      display ('Abnormal status from SEND_DATA');
      display_status (status);
    IFEND;
  PROCEND issue_send_request;

?? TITLE := 'Advance_Out', EJECT ??

  PROCEDURE advance_out
    (    limit: integer;
     VAR {input/output} out_bytes: integer;
     VAR out_index: 1 .. dfc$max_request_buffer_entries);

{========================================================================
{ This mini procedure increments the 'out pointer', checks for the limit,
{ and converts the out_pointer to a Request Buffer index.
{========================================================================

    out_bytes := out_bytes + 8;
    IF (out_bytes = limit) THEN
      out_bytes := 0;
    IFEND;

    out_index := (out_bytes DIV 8) + 1;
  PROCEND advance_out;

?? TITLE := 'Set Connection Error', EJECT ??

  PROCEDURE set_connection_error
    (    cs_error: dfc$min_cdcnet_errors .. dfc$max_cdcnet_errors;
         receive: boolean;
     VAR status: ost$status);

{=====================================================================
{ This PROC sets the Status variable to the error code passed to it as
{ input parameter. It also sets the product code and the error
{ message text in the status.
{=====================================================================

    osp$set_status_abnormal (dfc$file_server_id, cs_error, '', status);
    display ('Setting Abnormal Status');
    display_status (status);

{------------------------------------------------------------------------
{ Later on, it will be necessary to insert the SYNCHRONIZATION code in
{ here to provide for the recovery of the peer protocol error.
{
{ The synchro code should depend on the RECEIVE input parameter.
{------------------------------------------------------------------------

  PROCEND set_connection_error;

?? TITLE := 'Set_Queue_Error_Flags', EJECT ??

  PROCEDURE set_queue_error_flags
    (    p_flags: {^output} ^dft$queue_entry_flags);

{=======================================================================
{ This mini procedure sets the queue_flags whenever the driver discovers
{ an error to report.
{=======================================================================

    p_flags^.driver_error_alert := TRUE;
    p_flags^.driver_action := FALSE;
    p_flags^.subsystem_action := TRUE;

  PROCEND set_queue_error_flags;

?? TITLE := 'Set_Request_Pointers', EJECT ??

  PROCEDURE set_request_pointers
    (    p_request: ^dft$request_buffer_entries;
         p_queue_interface_table: dft$p_queue_interface_table;
         out_index: 1 .. dfc$max_request_buffer_entries;
     VAR queue_status: dft$connect_status;
     VAR queue: 1 .. dfc$max_number_of_queues;
     VAR entry: 1 .. dfc$max_queue_entries;
     VAR p_cpu_queue: ^dft$cpu_queue;
     VAR p_driver_queue: ^dft$driver_queue;
     VAR p_flags: ^dft$queue_entry_flags;
     VAR p_queue_status: ^dft$connect_status_entry);

    queue := p_request^ [out_index].queue_index;
    entry := p_request^ [out_index].queue_entry_index;

{ddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd
    IF dfv$cdcnet_debug_enabled THEN
{     display_pva ('Set_Req_Ptrs p_request =', p_request);
{     display_pva ('Set_Req_Ptrs p_q_interface_tbl =', p_queue_interface_table);
      adisplay_integer ('Set_Req_Ptrs Out_index =', out_index);
      adisplay_integer ('Set_Req_Ptrs Queue =', queue);
      adisplay_integer ('Set_Req_Ptrs Entry =', entry);
    IFEND;
{ddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd

    p_cpu_queue := p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue].p_cpu_queue;
    p_driver_queue := p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue].
          p_driver_queue;
    p_flags := ^p_driver_queue^.queue_entries [entry].flags;
    p_queue_status := ^queue_status [queue];

  PROCEND set_request_pointers;

  PROCEDURE adisplay
    (    display_line: string ( * <= 200));

    VAR
      length: integer,
      status: ost$status,
      working_string: string (256);

    STRINGREP (working_string, length, ' ', dfv$cdcnet_driver_name, '-', display_line);

    clp$put_job_command_response (working_string (1, length), status);

  PROCEND adisplay;

  PROCEDURE adisplay_integer
    (    display_line: string ( * <= 127);
         number: integer);

    VAR
      length: integer,
      working_string: string (200);

    STRINGREP (working_string, length, display_line, ' ', number);
    adisplay (working_string (1, length));

  PROCEND adisplay_integer;

  PROCEDURE adisplay_boolean
    (    display_line: string ( * <= 127);
         value: boolean);

    VAR
      length: integer,
      working_string: string (200);

    STRINGREP (working_string, length, display_line, ' ', value);
    adisplay (working_string (1, length));

  PROCEND adisplay_boolean;

  PROCEDURE adisplay_bytes
    (    display_line: string ( * <= 127);
         address: ^cell;
         length: integer);

    VAR
      hex_digits: [STATIC, READ] array [0 .. 15] of char := ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
            'a', 'b', 'c', 'd', 'e', 'f'];

    VAR
      data: ^string ( * ),
      data_index: integer,
      length2: integer,
      line: string (72),
      line_index: integer,
      working_string: string (127);

    PUSH data: [length];

    i#move (address, data, length);
    line := ' ';
    line_index := 1;

    FOR data_index := 1 TO length DO

      line (line_index) := hex_digits [$INTEGER (data^ (data_index)) DIV 16];
      line (line_index + 1) := hex_digits [$INTEGER (data^ (data_index)) MOD 16];
      IF (data_index MOD 8) = 0 THEN
        line (line_index + 2) := ' ';
        line_index := line_index + 1;
      IFEND;

      line_index := line_index + 2;
      IF (line_index > 67) OR (data_index = length) THEN
        STRINGREP (working_string, length2, display_line, line (1, line_index - 1));
        adisplay (working_string (1, length2));
        line := ' ';
        line_index := 1;
        working_string := ' ';
      IFEND;

    FOREND;
  PROCEND adisplay_bytes;

  PROCEDURE adisplay_header
    (    display_line: string ( * <= 127);
         header: dft$message_header);

    VAR
      length: integer,
      working_string: string (200);

    STRINGREP (working_string, length, display_line, '***', header.message_type, '*', header.entry, '*',
          header.command_length, '*', header.data_length, '***');
    adisplay (working_string (1, length));

  PROCEND adisplay_header;
?? COMPILE ??
MODEND dfm$cdcnet_driver;
*DECK DECK=DFM$CKB_MIX EXPAND=TRUE
PROC ckb_mix, ckbm (
  number_of_jobs, nj  : integer 1..281474976710655 = 8
  iteration_count, ic : integer 1..281474976710655 = 50
  served_family, sf: name = testing
  compute_checksum, cc: boolean = false
  establish_condition_handler, ech: boolean = true
  status              : var of status = $optional
  )

  family = $strrep($value(served_family))
  cc = $strrep($value(compute_checksum))
  handler = $strrep($value(establish_condition_handler))

  FOR i = 1 TO $value(number_of_jobs) DO
    JOB  jn=$name('CKB_MIX'//$strrep(i)) sm='?'
      IF ?handler? THEN
      WHEN any_fault do
         reqoa ' CKB_MIX?$strrep(i)? failed '//$condition_name(osv$status.condition)
         disv osv$status
         LOGOUT
      WHENEND
      IFEND
      exet sp=dftu
      page_size = $mainframe(page_size)
      FOR j = 1 TO ?$strrep($value(iteration_count))? DO
        test_remote_procedure_call ?family?  sbs=20 rc=50 rbs=0 cc=?cc?
        test_remote_procedure_call ?family?  sds=1*page_size  rc=150  rbs=0 cc=?cc?
        test_remote_procedure_call ?family?  rds=1*page_size rc=150 rbs=0 cc=?cc?
        test_remote_procedure_call ?family?  sbs=30 rc=50  rbs=0 cc=?cc?
        test_remote_procedure_call ?family?  rds=4*page_size rc=25  rbs=0 cc=?cc?
        test_remote_procedure_call ?family?  sds=4*page_size rc=25  rbs=0  cc=?cc?
        test_remote_procedure_call ?family?  sbs=25 rc=30    rbs=0 cc=?cc?
        test_remote_procedure_call ?family?  sbs=40 rc=30   rbs=0 cc=?cc?
        test_remote_procedure_call ?family?  sds=1*page_size rc=117  rbs=0 cc=?cc?
        test_remote_procedure_call ?family?  rds=4*page_size rc=27 rbs=0 cc=?cc?
        test_remote_procedure_call ?family?  sds=4*page_size rc=30 rbs=0 cc=?cc?
        test_remote_procedure_call ?family?  rds=1*page_size rc=116 rbs=0 cc=?cc?
      FOREND
      QUIT
    JOBEND
  FOREND

PROCEND ckb_mix

*DECK DECK=DFM$CLIENT_JOB_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File Server: Server: client_job_manager', EJECT ??
MODULE dfm$client_job_manager;

{
{  This server module manages the connection of client jobs to the server.
{  This involves registering and deleting the client job from the server,
{  and setting the clone's task private data to indicate the desired client job.
{  All client jobs for a single client mainframe are maintained in the
{  client job list, which is part of the client mainframe file.
{  This client job list contains enough information so that the
{  clone tasks may run on behalf of the client job.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfd$request_package
*copyc dfe$error_condition_codes
*copyc dfi$console_display
*copyc dfi$display
*copyc dfi$log_display
*copyc dft$change_client_job_validaton
*copyc dft$delete_client_job
*copyc dft$display_identifier
*copyc dft$end_job_recovery
*copyc dft$entry_type
*copyc dft$establish_client_job
*copyc dft$queue_index
*copyc dft$rpc_served_job_list
*copyc dft$start_job_recovery
*copyc dpt$window_id
*copyc i#current_sequence_position
*copyc osd$integer_limits
*copyc ost$caller_identifier
?? POP ??
*copyc amp$return
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc dfp$acquire_client_mf_file
*copyc dfp$crack_mainframe_id
*copyc dfp$display
*copyc dfp$verify_system_administrator
*copyc dfp$word_boundary
*copyc mmp$close_segment
*copyc osp$append_status_integer
*copyc osp$clear_signature_lock
*copyc osp$decrement_locked_variable
*copyc osp$increment_locked_variable
*copyc osp$initialize_signature_lock
*copyc osp$reset_heap
*copyc osp$set_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pfp$complete_job_recovery
*copyc pfp$detach_all_catalogs
*copyc pfp$process_job_end
*copyc pfp$reset_task_environment
*copyc pfp$setup_attached_pf_recovery
*copyc pfp$set_task_environment
*copyc pmp$get_pseudo_mainframe_id
*copyc qfp$server_job_end
*copyc syp$invoke_system_debugger

*copyc dft$client_job_list
*copyc dfv$file_server_debug_enabled
*copyc jmv$system_job_ssn

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??
?? EJECT ??
*copyc dfv$p_client_mainframe_file

?? TITLE := '[XDCL] dfp$change_client_job_validaton ', EJECT ??

{
{   The purpose of this request is to change the client job environment
{ on the server to have the new validation information.  Subsequent requests
{ to the server will use this validation information.

  PROCEDURE [XDCL] dfp$change_client_job_validaton
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      client_job_id: dft$client_job_id,
      p_client_job_space: ^dft$client_job_space,
      p_parameters: ^dft$change_client_job_valid_in;

    status.normal := TRUE;
    send_parameters_length := 0;
    data_size_to_send_to_client := 0;
    NEXT p_parameters IN p_param_received_from_client;
    client_job_id := p_parameters^.client_job_id;
    dfp$validate_client_job_id (client_job_id, p_parameters^.system_supplied_job_name,
          dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    p_client_job_space := dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root.
          p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
          p_client_job_list^ [client_job_id.job_list_index].p_client_job_space;

{ Remove all the previously queued catalogs, so the new account and project are used.

    pfp$detach_all_catalogs;
    p_client_job_space^.account := p_parameters^.account;
    p_client_job_space^.project := p_parameters^.project;

  PROCEND dfp$change_client_job_validaton;
?? TITLE := '[XDCL] dfp$delete_client_job ', EJECT ??

{
{   The purpose of this request is to remove the client job environment
{ from the server.  All permanent files left attached are detached.
{ All tables on the server associated with the client job are deleted.
{

  PROCEDURE [XDCL] dfp$delete_client_job
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      client_job_id: dft$client_job_id,
      host_binary_mainframe_id: pmt$binary_mainframe_id,
      p_parameters: ^dft$delete_client_job_inp;

    status.normal := TRUE;
    send_parameters_length := 0;
    data_size_to_send_to_client := 0;
    NEXT p_parameters IN p_param_received_from_client;

    IF p_parameters^.job_is_leveled THEN
      pmp$get_pseudo_mainframe_id (host_binary_mainframe_id);
      IF host_binary_mainframe_id = p_parameters^.job_end_info.server_mainframe_id THEN
        qfp$server_job_end (p_parameters^.job_end_info);
      IFEND;
    IFEND;

    IF p_parameters^.client_job_table_exists THEN
      remove_client_job (dfv$p_client_mainframe_file, p_parameters^.client_job_id, status);
    IFEND;

  PROCEND dfp$delete_client_job;
?? TITLE := '[XDCL] dfp$display_client_jobs ', EJECT ??
{ This display is of the form
{  123456789A123456789B123456789C123456789D123456789E123456789F123456789G123456789H1
{ '--SYSTEM SUPPLIED NAME----USER JOB NAME-------------TRANSACTIONS--ACCESS-------'
{
  PROCEDURE [XDCL] dfp$display_client_jobs
    (    p_client_mainframe_file: dft$p_mainframe_file;
     VAR display_identifier: dft$display_identifier;
     VAR status: ost$status);

    VAR
      active_pointer: integer,
      display_string: string (80),
      job_list_entry: dft$client_job_list_entry,
      job_list_index: 1 .. dfc$client_job_list_size,
      length: integer,
      local_status: ost$status;

    osp$set_signature_lock (p_client_mainframe_file^.mainframe_header.client_job_list_lock, osc$wait, status);


  /for_all_job_lists/
    FOR active_pointer := 1 TO p_client_mainframe_file^.mainframe_header.client_job_list_root.
          number_of_active_pointers DO

    /locate_active_job/
      FOR job_list_index := 1 TO dfc$client_job_list_size DO
        IF p_client_mainframe_file^.mainframe_header.client_job_list_root.
              p_job_list_pointer_array^ [active_pointer].assignment (job_list_index) =
              dfc$assigned_entry_char THEN
          job_list_entry := p_client_mainframe_file^.mainframe_header.client_job_list_root.
                p_job_list_pointer_array^ [active_pointer].p_client_job_list^ [job_list_index];
          display_string := ' ';
          display_string (3, * ) := job_list_entry.system_supplied_job_name;
          display_string (26, * ) := job_list_entry.user_supplied_job_name;
          IF job_list_entry.recovering THEN
            display_string (57, * ) := 'RECOVERING';
          ELSEIF job_list_entry.job_lifetime <> p_client_mainframe_file^.mainframe_header.server_lifetime THEN
            display_string (57, * ) := 'AWAIT REC';
          ELSE
            STRINGREP (display_string (57, 7), length, job_list_entry.request_count: 7);
          IFEND;
          IF job_list_entry.p_client_job_space^.family_access_kind = dfc$remote_file_access THEN
            display_string (68, 7) := 'FILE';
          ELSEIF job_list_entry.p_client_job_space^.family_access_kind = dfc$remote_login_access THEN
            display_string (68, 7) := 'LOGIN ';
          ELSEIF job_list_entry.p_client_job_space^.family_access_kind = dfc$job_leveling_access THEN
            display_string (68, 7) := 'LEVELED';
          IFEND;
          IF job_list_entry.job_mode = jmc$batch THEN
            display_string (78) := 'B';
          ELSE { interactive
            display_string (78) := 'I';
          IFEND;
          dfp$display (display_string, display_identifier, status);

        IFEND;
      FOREND /locate_active_job/;
    FOREND /for_all_job_lists/;
    osp$clear_signature_lock (p_client_mainframe_file^.mainframe_header.client_job_list_lock, local_status);


  PROCEND dfp$display_client_jobs;
?? TITLE := '[XDCL] dfp$end_client_job_recovery ', EJECT ??

{
{   The purpose of this request is to complete the recovery sequence for
{ a client job.  This is performed at the end of the server job recovery.
{ This routine involves verifying that the client has relinked all server files
{ and then advances the lifetime of the job.
{

  PROCEDURE [XDCL] dfp$end_client_job_recovery
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      client_job_id: dft$client_job_id,
      host_binary_mainframe_id: pmt$binary_mainframe_id,
      ignore_status: ost$status,
      p_client_job_space: ^dft$client_job_space,
      p_end_job_recovery_params: ^dft$end_job_recovery;

    status.normal := TRUE;
    send_parameters_length := 0;
    data_size_to_send_to_client := 0;
    NEXT p_end_job_recovery_params IN p_param_received_from_client;

    client_job_id := p_end_job_recovery_params^.client_job_id;
    p_client_job_space := dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root.
          p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
          p_client_job_list^ [client_job_id.job_list_index].p_client_job_space;
    dfp$set_client_job_environment (client_job_id, { system administrator } TRUE,
          { family administrator } TRUE, status);
    IF NOT status.normal THEN

{ Terminate the job? Remove it from the file? Detach files?

      RETURN;
    IFEND;
    pfp$complete_job_recovery (dfv$p_client_mainframe_file^.mainframe_header.client_mainframe_id, status);

{ Advance the jobs lifetime

    dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root.
          p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
          p_client_job_list^ [client_job_id.job_list_index].job_lifetime :=
          p_end_job_recovery_params^.server_lifetime;
    dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root.
          p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
          p_client_job_list^ [client_job_id.job_list_index].recovering := FALSE;
  PROCEND dfp$end_client_job_recovery;
?? TITLE := '[XDCL] dfp$establish_client_job ', EJECT ??

{
{   The purpose of this request is to initially establish the connection
{   between a job on the client, and the file server.  As a result of this
{   request a partial job environment is established on the server.  This
{   job environment is used on subsequent requests from the client.
{

  PROCEDURE [XDCL] dfp$establish_client_job
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      client_job_id: dft$client_job_id,
      p_parameters: ^dft$establish_client_job_inp;

    send_parameters_length := 0;
    data_size_to_send_to_client := 0;
    status.normal := TRUE;
    NEXT p_parameters IN p_param_received_from_client;

    IF dfv$file_server_debug_enabled THEN
      display (' Establish client job ');
      display_bytes (p_parameters, #SIZE (p_parameters^));
    IFEND;

    dfp$register_client_job (p_parameters^.user_id, p_parameters^.account, p_parameters^.project,
          p_parameters^.system_supplied_job_name, p_parameters^.user_supplied_job_name,
          p_parameters^.job_mode, p_parameters^.family_access_kind, p_parameters^.job_lifetime,
          dfv$p_client_mainframe_file, client_job_id, status);

    IF status.normal THEN
      build_job_begin_vars (client_job_id, p_send_to_client_params, send_parameters_length);
    ELSEIF (status.condition = dfe$client_job_registered) AND (p_parameters^.forced_reconnection OR
     (p_parameters^.system_supplied_job_name = jmv$system_job_ssn { Needs analysis - Kludge})) THEN
      { Remove the old job, and re-establish the job under a new lifetime.
      IF dfv$file_server_debug_enabled THEN
        display (' Forced reconnection ');
        display (p_parameters^.system_supplied_job_name);
      IFEND;
      dfp$set_client_job_environment (client_job_id, { system administrator } TRUE,
            { family administrator } TRUE, status);
      remove_client_job (dfv$p_client_mainframe_file, client_job_id, status);
      IF status.normal THEN
        dfp$register_client_job (p_parameters^.user_id, p_parameters^.account, p_parameters^.project,
              p_parameters^.system_supplied_job_name, p_parameters^.user_supplied_job_name,
              p_parameters^.job_mode, p_parameters^.family_access_kind, p_parameters^.job_lifetime,
              dfv$p_client_mainframe_file, client_job_id, status);
        IF status.normal THEN
          build_job_begin_vars (client_job_id, p_send_to_client_params, send_parameters_length);
        IFEND;
      IFEND;
    IFEND;
  PROCEND dfp$establish_client_job;
?? TITLE := '[XDCL] dfp$get_client_job_list ', EJECT ??

  PROCEDURE [XDCL] dfp$get_client_job_list
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      job_list_entry: dft$client_job_list_entry,
      job_list_index: dft$client_job_list_index,
      job_list_pointer_index: dft$job_list_ptr_array_index,
      log_string: string (80),
      log_string_length: integer,
      p_job_list_pointer: ^dft$job_list_pointer_array,
      p_served_job_list_data: ^dft$rpc_served_job_list_data,
      p_served_job_list_header: ^dft$rpc_served_job_list_header;

    status.normal := TRUE;

    NEXT p_served_job_list_header IN p_data_to_client;
    p_served_job_list_header^.number_of_jobs := 0;
    p_served_job_list_header^.number_of_jobs_awaiting_rec := 0;

    p_job_list_pointer := dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root.
          p_job_list_pointer_array;

  /search_mainframe_file/
    FOR job_list_pointer_index := 1 TO dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root.
          number_of_active_pointers DO

    /find_active_jobs/
      FOR job_list_index := 1 TO dfc$client_job_list_size DO
        IF p_job_list_pointer^ [job_list_pointer_index].assignment (job_list_index) = dfc$free_entry_char THEN
          CYCLE /find_active_jobs/;
        IFEND;
        job_list_entry := p_job_list_pointer^ [job_list_pointer_index].p_client_job_list^ [job_list_index];
        IF job_list_entry.job_lifetime <> dfv$p_client_mainframe_file^.mainframe_header.server_lifetime THEN
          p_served_job_list_header^.number_of_jobs_awaiting_rec :=
                p_served_job_list_header^.number_of_jobs_awaiting_rec + 1;
        IFEND;

        NEXT p_served_job_list_data IN p_data_to_client;
        p_served_job_list_data^.system_supplied_job_name := job_list_entry.system_supplied_job_name;
        p_served_job_list_data^.client_job_id.job_list_pointer_index := job_list_pointer_index;
        p_served_job_list_data^.client_job_id.job_list_index := job_list_index;

        p_served_job_list_header^.number_of_jobs := p_served_job_list_header^.number_of_jobs + 1;

      FOREND /find_active_jobs/;

    FOREND /search_mainframe_file/;

    data_size_to_send_to_client := i#current_sequence_position (p_data_to_client);
    send_parameters_length := 0;
    STRINGREP (log_string, log_string_length, ' Client ',
     dfv$p_client_mainframe_file^.mainframe_header.client_mainframe_name,
     ' Total_jobs:',  p_served_job_list_header^.number_of_jobs,
     '   Awaiting_recovery:', p_served_job_list_header^.number_of_jobs_awaiting_rec);
    log_display ($pmt$ascii_logset[pmc$system_log], log_string (1, log_string_length));
    IF dfv$file_server_debug_enabled THEN
      display (log_string (1, log_string_length));
      display_to_console (log_string (1, log_string_length));
    IFEND;

  PROCEND dfp$get_client_job_list;
?? TITLE := '[XDCL] dfp$pop_job_unrecoverable ', EJECT ??

  PROCEDURE [XDCL] dfp$pop_job_unrecoverable
    (    client_job_id: dft$client_job_id);

    CONST
      initial_value = 0;

    VAR
      actual_value: integer,
      error: boolean,
      status: ost$status;

    osp$decrement_locked_variable (dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root.
          p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
          p_client_job_list^ [client_job_id.job_list_index].inhibit_job_recovery, initial_value, actual_value,
          error);
    IF error AND dfv$file_server_debug_enabled THEN
      syp$invoke_system_debugger (' INHIBIT JOB RECOVERY CONFLICT ', 0, status);
    IFEND;
  PROCEND dfp$pop_job_unrecoverable;
?? TITLE := '[XDCL] dfp$push_job_unrecoverable ', EJECT ??

  PROCEDURE [XDCL] dfp$push_job_unrecoverable
    (    client_job_id: dft$client_job_id);

    CONST
      initial_value = 0;

    VAR
      actual_value: integer;

    osp$increment_locked_variable (dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root.
          p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
          p_client_job_list^ [client_job_id.job_list_index].inhibit_job_recovery, initial_value,
          actual_value);
  PROCEND dfp$push_job_unrecoverable;

?? TITLE := '[XDCL] dfp$register_client_job ', EJECT ??

  PROCEDURE [XDCL] dfp$register_client_job
    (    user_id: ost$user_identification;
         account_name: avt$account_name;
         project_name: avt$project_name;
         system_supplied_job_name: jmt$system_supplied_name;
         user_supplied_job_name: jmt$user_supplied_name;
         job_mode: jmt$Job_mode;
         family_access_kind: dft$family_access_kinds;
         job_lifetime: dft$lifetime;
         p_client_mainframe_file: ^dft$client_mainframe_file;
     VAR client_job_id: dft$client_job_id;
     VAR status: ost$status);

    VAR
      client_job_found: boolean,
      local_status: ost$status;

    osp$set_signature_lock (p_client_mainframe_file^.mainframe_header.client_job_list_lock, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    locate_client_job (system_supplied_job_name, p_client_mainframe_file^.mainframe_header.
          client_job_list_root, client_job_id, client_job_found);
    IF client_job_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$client_job_registered, system_supplied_job_name,
            status);
    IFEND;

    IF status.normal THEN
      get_free_client_job_table_entry (p_client_mainframe_file^.mainframe_header.client_job_list_root,
            p_client_mainframe_file^.mainframe_heap, client_job_id, status);
    IFEND;

    IF status.normal THEN
      create_client_job_environment (user_id, account_name, project_name, system_supplied_job_name,
            user_supplied_job_name, job_mode, family_access_kind, job_lifetime,
            p_client_mainframe_file^.mainframe_header.client_job_list_root.
            p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
            p_client_job_list^ [client_job_id.job_list_index], p_client_mainframe_file^.mainframe_heap);

      p_client_mainframe_file^.mainframe_header.client_job_list_root.
            p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
            assignment (client_job_id.job_list_index) := dfc$assigned_entry_char;
    IFEND;


    osp$clear_signature_lock (p_client_mainframe_file^.mainframe_header.client_job_list_lock, local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND dfp$register_client_job;

?? TITLE := '[XDCL] dfp$remove_unknown_jobs ', EJECT ??
{   The purpuse of this request is to remove any requested job from the
{ client mainframe file.  The client mainframe supplies the list of jobs and the
{ client_job_id for each requested job.  The list of jobs was first gotton
{ by calling dfp$get_client_job_list, and is really just the list of these
{ jobs that no longer exist on the client mainframe .
{ All attached permanent files for the jobs are removed.
{
  PROCEDURE [XDCL] dfp$remove_unknown_jobs
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      job: ost$non_negative_integers,
      log_string: string (80),
      log_string_length: integer,
      p_job_list_pointer: ^dft$job_list_pointer_array,
      p_served_job_list_data: ^dft$rpc_served_job_list_data,
      p_served_job_list_header: ^dft$rpc_served_job_list_header,
      valid_client_job_id: boolean;

    status.normal := TRUE;
    send_parameters_length := 0;
    data_size_to_send_to_client := 0;

    p_job_list_pointer := dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root.
          p_job_list_pointer_array;

    NEXT p_served_job_list_header IN p_data_from_client;
    STRINGREP (log_string, log_string_length, ' Client ',
      dfv$p_client_mainframe_file^.mainframe_header.client_mainframe_name,
      ' Removing jobs:',  p_served_job_list_header^.number_of_jobs);
    log_display ($pmt$ascii_logset[pmc$system_log], log_string (1, log_string_length));
    IF dfv$file_server_debug_enabled THEN
      display (log_string (1, log_string_length));
      display_to_console (log_string (1, log_string_length));
    IFEND;

  /check_jobs/
    FOR job := 1 TO p_served_job_list_header^.number_of_jobs DO
      NEXT p_served_job_list_data IN p_data_from_client;

      dfp$validate_client_job_id (p_served_job_list_data^.client_job_id,
            p_served_job_list_data^.system_supplied_job_name,
            dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root, status);
      valid_client_job_id := status.normal;
      IF valid_client_job_id THEN
        IF dfv$file_server_debug_enabled THEN
         display_integer (' dfp$remove_unknown_jobs: job_list_pointer_index=',
               p_served_job_list_data^.client_job_id.job_list_pointer_index);
         display_integer ('                          job_list_index=',
               p_served_job_list_data^.client_job_id.job_list_index);
         display (p_served_job_list_data^.system_supplied_job_name);
         log_display ($pmt$ascii_logset[pmc$system_log],
               p_served_job_list_data^.system_supplied_job_name);
        IFEND;
      { Make the task look like its running on behalf of the user job
        dfp$set_client_job_environment (p_served_job_list_data^.client_job_id, {system_administrator} TRUE,
              {family_administrator} TRUE, status);
        remove_client_job (dfv$p_client_mainframe_file, p_served_job_list_data^.client_job_id, status);
      IFEND;

    FOREND /check_jobs/;

    status.normal := TRUE;


    pfp$reset_task_environment;

  PROCEND dfp$remove_unknown_jobs;
?? TITLE := '[XDCL] dfp$set_client_job_environment ', EJECT ??

{ The module is HIGHLY COUPLED with module PFM$TASK_PRIVATE_DATA

  PROCEDURE [XDCL] dfp$set_client_job_environment
    (    client_job_id: dft$client_job_id;
         system_administrator: boolean;
         family_administrator: boolean;
     VAR status: ost$status);

    VAR
      p_client_job_space: ^dft$client_job_space;

    p_client_job_space := dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root.
          p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
          p_client_job_list^ [client_job_id.job_list_index].p_client_job_space;
    dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root.
          p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
          p_client_job_list^ [client_job_id.job_list_index].request_count :=
          dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root.
          p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
          p_client_job_list^ [client_job_id.job_list_index].request_count + 1;

    pfp$set_task_environment (p_client_job_space, system_administrator, family_administrator);
    status.normal := TRUE;

  PROCEND dfp$set_client_job_environment;

?? TITLE := '[XDCL] dfp$start_client_job_recovery ', EJECT ??

{
{   The purpose of this request is to initiate the recovery sequence for
{ a client job.  This is performed at the start of the server job recovery.
{ This routine involves a minimal verification of the client job
{ registration in the client mainframe file, and then a marking of all
{ attached permanent files as awaiting recovery.
{

  PROCEDURE [XDCL] dfp$start_client_job_recovery
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      client_job_found: boolean,
      client_job_id: dft$client_job_id,
      p_client_job_space: ^dft$client_job_space,
      host_binary_mainframe_id: pmt$binary_mainframe_id,
      p_start_job_recovery_out: ^dft$start_job_recovery_out,
      p_start_job_recovery_params: ^dft$start_job_recovery_in;

    status.normal := TRUE;
    send_parameters_length := 0;
    data_size_to_send_to_client := 0;
    NEXT p_start_job_recovery_params IN p_param_received_from_client;

    locate_client_job (p_start_job_recovery_params^.system_supplied_job_name,
          dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root, client_job_id,
          client_job_found);
    IF client_job_found THEN
      NEXT p_start_job_recovery_out IN p_send_to_client_params;
      send_parameters_length := #SIZE (p_start_job_recovery_out^);
      p_start_job_recovery_out^.client_job_id := client_job_id;
      dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root.
            p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
            p_client_job_list^ [client_job_id.job_list_index].recovering := TRUE;
      p_client_job_space := dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root.
            p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
            p_client_job_list^ [client_job_id.job_list_index].p_client_job_space;
      dfp$set_client_job_environment (client_job_id, { system administrator } TRUE,
            { family administrator } TRUE, status);
      IF NOT status.normal THEN

{ Terminate the job? Remove it from the file? Detach files?

        RETURN;
      IFEND;
      pfp$setup_attached_pf_recovery (pfc$attached_pf_awaiting_client, status);
    ELSE
      osp$set_status_abnormal (dfc$file_server_id, dfe$bad_client_job_id,
            ' unknown system job name - start jr ', status);
    IFEND;
  PROCEND dfp$start_client_job_recovery;
?? TITLE := '[XDCL, #GATE] dfp$terminate_client_job ', EJECT ??
{
{    The purpose of this request is to provide for removing a client job from
{ the client mainframe file that exists on the server mainframe.  This
{ subcommand may only be issued on the server mainframe.  This causes the job
{ to be removed and to detach all server files that the client job had
{ attached.
{
{    This subcommand may only be issued when the server-to-client connection is
{ in an awaiting_recovery state or when the job has not yet recovered (that
{ is the server is active or inactive but the jobs lifetime is less than that
{ of ths server).
{ Only when the job is awaiting recovery does
{ the job on the client re-verifies that the job is still registered on the
{ server mainframe.  If the job is no longer registered (for example because of
{ this subcommand) all server files that the job on the client is using are
{ marked as terminated.
{
{    This subcommand is currently only provided for testing purposes.  To
{ exernalize it some of the error messages might need to be cleaned up.  To
{ allow the job in the inactive state some verification would have to be done
{ when the job first detected that the server was active.
{

  PROCEDURE [XDCL, #GATE] dfp$terminate_client_job
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  pdt tercj_pdt (
{   client_mainframe_id, cmid: name 17 = $required
{   system_job_name, sjn: name 19 = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    tercj_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^tercj_pdt_names, ^tercj_pdt_params
  ];

  VAR
    tercj_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
  clt$parameter_name_descriptor := [['CLIENT_MAINFRAME_ID', 1], ['CMID', 1], ['SYSTEM_JOB_NAME', 2], ['SJN', 2
  ], ['STATUS', 3]];

  VAR
    tercj_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ CLIENT_MAINFRAME_ID CMID }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 17, 17]],

{ SYSTEM_JOB_NAME SJN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 19, 19]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      caller_id: ost$caller_identifier,
      client_job_found: boolean,
      client_job_id: dft$client_job_id,
      client_mainframe: pmt$mainframe_id,
      client_mainframe_id: pmt$binary_mainframe_id,
      client_mainframe_lfn: ost$name,
      client_segment_pointer: mmt$segment_pointer,
      local_status: ost$status,
      p_client_job_entry: ^dft$client_job_list_entry,
      p_client_mainframe_file: dft$p_mainframe_file,
      system_supplied_job_name: jmt$system_supplied_name,
      value: clt$value;

    #CALLER_ID (caller_id);
    clp$scan_parameter_list (parameter_list, tercj_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$verify_system_administrator ('TERMINATE_CLIENT_JOB', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$crack_mainframe_id ('CLIENT_MAINFRAME_ID', client_mainframe, client_mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_value ('SYSTEM_JOB_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    system_supplied_job_name := value.name.value;

    dfp$acquire_client_mf_file (client_mainframe, {read_only} FALSE, client_mainframe_lfn,
          client_segment_pointer, p_client_mainframe_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$set_signature_lock (p_client_mainframe_file^.mainframe_header.client_job_list_lock, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    locate_client_job (system_supplied_job_name, p_client_mainframe_file^.mainframe_header.
          client_job_list_root, client_job_id, client_job_found);
    IF NOT client_job_found THEN
      osp$clear_signature_lock (p_client_mainframe_file^.mainframe_header.client_job_list_lock, status);
      mmp$close_segment (client_segment_pointer, caller_id.ring, local_status);
      amp$return (client_mainframe_lfn, local_status);
      osp$set_status_abnormal (dfc$file_server_id, dfe$bad_client_job_id, ' Unknown system_job_name ',
            status);
      RETURN;
    IFEND;

    p_client_job_entry :=  ^p_client_mainframe_file^.mainframe_header.client_job_list_root.
          p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
          p_client_job_list^ [client_job_id.job_list_index];
    IF (p_client_mainframe_file^.mainframe_header.server_state <> dfc$awaiting_recovery) AND
          (p_client_job_entry^.recovering OR (p_client_job_entry^.job_lifetime =
           p_client_mainframe_file^.mainframe_header.server_lifetime)) THEN
      osp$clear_signature_lock (p_client_mainframe_file^.mainframe_header.client_job_list_lock, status);
      mmp$close_segment (client_segment_pointer, caller_id.ring, local_status);
      amp$return (client_mainframe_lfn, local_status);
      osp$set_status_abnormal (dfc$file_server_id, dfe$client_active, 'job must be awaiting_recovery ',
            status);
      RETURN;
    IFEND;

    pfp$set_task_environment (p_client_job_entry^.p_client_job_space, { system_administrator} TRUE,
        { family_administrator} TRUE);

    osp$clear_signature_lock (p_client_mainframe_file^.mainframe_header.client_job_list_lock, status);
    remove_client_job (p_client_mainframe_file, client_job_id, status);

    pfp$reset_task_environment;
    mmp$close_segment (client_segment_pointer, caller_id.ring, local_status);
    amp$return (client_mainframe_lfn, local_status);
  PROCEND dfp$terminate_client_job;
?? TITLE := '[XDCL] dfp$validate_client_job_id ', EJECT ??

  PROCEDURE [XDCL] dfp$validate_client_job_id
    (    client_job_id: dft$client_job_id;
         system_supplied_job_name: jmt$system_supplied_name;
         client_job_list_root: dft$client_job_list_root;
     VAR status: ost$status);

    IF client_job_id.job_list_pointer_index > client_job_list_root.number_of_active_pointers THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$bad_client_job_id, ' job_list_pointer_index ', status);
      RETURN;
    IFEND;

    IF client_job_id.job_list_index > #SIZE (client_job_list_root.
          p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].assignment) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$bad_client_job_id, ' job_list_index size ', status);
      RETURN;
    IFEND;

    IF client_job_list_root.p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
          assignment (client_job_id.job_list_index) <> dfc$assigned_entry_char THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$bad_client_job_id, ' job_list_index free', status);
      RETURN;
    IFEND;

    IF client_job_list_root.p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
          p_client_job_list^ [client_job_id.job_list_index].system_supplied_job_name <>
          system_supplied_job_name THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$bad_client_job_id, ' system_supplied_job_name ',
            status);
      RETURN;
    IFEND;
    status.normal := TRUE;
  PROCEND dfp$validate_client_job_id;
?? TITLE := '[INLINE] build_job_begin_vars  ', EJECT ??

  PROCEDURE [INLINE] build_job_begin_vars
    (    client_job_id: dft$client_job_id;
     VAR p_send_parameters: dft$p_send_parameters;
     VAR send_parameters_size: dft$send_parameter_size);

    VAR
      p_client_job_id: ^dft$client_job_id;

    NEXT p_client_job_id IN p_send_parameters;
    p_client_job_id^ := client_job_id;
    send_parameters_size := #SIZE (client_job_id);
  PROCEND build_job_begin_vars;
?? TITLE := 'create_client_job_environment ', EJECT ??

  PROCEDURE create_client_job_environment
    (    user_id: ost$user_identification;
         account_name: avt$account_name;
         project_name: avt$project_name;
         system_supplied_job_name: jmt$system_supplied_name;
         user_supplied_job_name: jmt$user_supplied_name;
         job_mode: jmt$job_mode;
         family_access_kind: dft$family_access_kinds;
         job_lifetime: dft$lifetime;
     VAR client_job_list_entry: dft$client_job_list_entry;
     VAR mainframe_heap: ost$heap);

    VAR
      status: ost$status,
      p_client_job_space: ^dft$client_job_space;

    client_job_list_entry.system_supplied_job_name := system_supplied_job_name;
    client_job_list_entry.user_supplied_job_name := user_supplied_job_name;
    client_job_list_entry.job_mode := job_mode;
    client_job_list_entry.job_lifetime := job_lifetime;
    client_job_list_entry.inhibit_job_recovery := 0;
    client_job_list_entry.recovering := FALSE;
    ALLOCATE p_client_job_space IN mainframe_heap;
    IF p_client_job_space = NIL THEN
      osp$system_error (' NIL client_job_list_entry.p_client_job_space ', NIL);
    IFEND;

    p_client_job_space^.family := user_id.family;
    p_client_job_space^.user := user_id.user;
    p_client_job_space^.account := account_name;
    p_client_job_space^.project := project_name;
    p_client_job_space^.family_access_kind := family_access_kind;

{  p_client_job_space^.permanent_file_size_limit := UPPERVALUE (integer);

    osp$initialize_signature_lock (p_client_job_space^.queued_catalog_table_lock, status);
    p_client_job_space^.p_queued_catalog_table := NIL;
    p_client_job_space^.p_newest_queued_catalog := NIL;
    p_client_job_space^.p_attached_pf_table := NIL;

    initialize_job_heap (p_client_job_space^.p_job_heap, p_client_job_space^.job_heap);

    client_job_list_entry.request_count := 1;
    {  p_client_job_space^.active_clone_task_count := 0 {????????} ;
    client_job_list_entry.p_client_job_space := p_client_job_space;
  PROCEND create_client_job_environment;
?? TITLE := 'create_job_list ', EJECT ??

  PROCEDURE create_job_list
    (VAR mainframe_heap: {Input, Output} ost$heap;
     VAR client_job_list_pointer: dft$client_job_list_pointer);

    VAR
      job_index: dft$client_job_list_index;

    ALLOCATE client_job_list_pointer.p_client_job_list IN mainframe_heap;
    IF client_job_list_pointer.p_client_job_list = NIL THEN
      osp$system_error (' NIL p_client_job_list', NIL);
    IFEND;
    client_job_list_pointer.assignment := ' ';

  /initialize_jobs/
    FOR job_index := LOWERBOUND (client_job_list_pointer.p_client_job_list^)
          TO UPPERBOUND (client_job_list_pointer.p_client_job_list^) DO
      client_job_list_pointer.p_client_job_list^ [job_index].system_supplied_job_name := ' ';
      client_job_list_pointer.p_client_job_list^ [job_index].p_client_job_space := NIL;
    FOREND /initialize_jobs/;
  PROCEND create_job_list;
?? TITLE := 'delete_client_job_entry ', EJECT ??

  PROCEDURE delete_client_job_entry
    (    client_job_list_root: dft$client_job_list_root;
         client_job_id: dft$client_job_id;
     VAR mainframe_heap: {Input, Output} ost$heap);



    FREE client_job_list_root.p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
          p_client_job_list^ [client_job_id.job_list_index].p_client_job_space IN mainframe_heap;
    client_job_list_root.p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
          p_client_job_list^ [client_job_id.job_list_index].system_supplied_job_name := 'deleted';
    #SPOIL (client_job_list_root.p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].assignment);
    client_job_list_root.p_job_list_pointer_array^ [client_job_id.job_list_pointer_index].
          assignment (client_job_id.job_list_index) := dfc$free_entry_char;
  PROCEND delete_client_job_entry;

?? TITLE := 'get_free_client_job_table_entry', EJECT ??

  PROCEDURE get_free_client_job_table_entry
    (VAR client_job_list_root: {Input, Output} dft$client_job_list_root;
     VAR mainframe_heap: {Input, Output} ost$heap;
     VAR client_job_id: dft$client_job_id;
     VAR status: ost$status);

    VAR
      client_job_list_pointer: dft$client_job_list_pointer,
      free_entry_found: boolean,
      table_full: boolean;

    status.normal := TRUE;
    locate_free_job_entry (client_job_list_root, table_full, free_entry_found, client_job_id);
    IF table_full THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$maximum_jobs_connected, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            (dfc$client_job_list_size * UPPERBOUND (client_job_list_root.p_job_list_pointer_array^)), 10,
            FALSE, status);
    ELSEIF NOT free_entry_found THEN
      create_job_list (mainframe_heap, client_job_list_pointer);
      update_pointer_array (client_job_list_root, client_job_list_pointer,
            client_job_id.job_list_pointer_index);
      client_job_id.job_list_index := LOWERBOUND (client_job_list_pointer.p_client_job_list^);
    IFEND;

  PROCEND get_free_client_job_table_entry;
?? TITLE := 'initialize_job_heap ', EJECT ??

{
{ Must fake out the heap manager into formatting our short heap as a
{ ost$heap
{

  PROCEDURE initialize_job_heap
    (VAR p_job_heap: ^ost$heap;
     VAR job_heap: dft$job_heap);

    TYPE
      converter_type = record
        case (short, long) of
        = short =
          short_heap: ^dft$job_heap,
        = long =
          long_heap: ^ost$heap,
        casend,
      recend;

    VAR
      converter: converter_type;

    converter.short_heap := ^job_heap;
    p_job_heap := converter.long_heap;
    osp$reset_heap (p_job_heap, #SIZE (dft$job_heap), TRUE, 2);

  PROCEND initialize_job_heap;

?? TITLE := 'locate_client_job ', EJECT ??

  PROCEDURE locate_client_job
    (    system_supplied_job_name: jmt$system_supplied_name;
         client_job_list_root: dft$client_job_list_root;
     VAR client_job_id: dft$client_job_id;
     VAR client_job_found: boolean);

    VAR
      job_list_index: dft$client_job_list_index,
      pointer_index: dft$job_list_ptr_array_index;

  /for_all_pointers/
    FOR pointer_index := 1 TO client_job_list_root.number_of_active_pointers DO

    /search_job_list/
      FOR job_list_index := 1 TO #SIZE (client_job_list_root.p_job_list_pointer_array^ [pointer_index].
            assignment) DO
        IF client_job_list_root.p_job_list_pointer_array^ [pointer_index].assignment (job_list_index) =
              dfc$assigned_entry_char THEN
          IF client_job_list_root.p_job_list_pointer_array^ [pointer_index].
                p_client_job_list^ [job_list_index].system_supplied_job_name = system_supplied_job_name THEN
            client_job_found := TRUE;
            client_job_id.job_list_pointer_index := pointer_index;
            client_job_id.job_list_index := job_list_index;
            RETURN;
          IFEND;
        IFEND;
      FOREND /search_job_list/;
    FOREND /for_all_pointers/;
    client_job_found := FALSE;
  PROCEND locate_client_job;
?? TITLE := 'locate_free_job_entry ', EJECT ??

  PROCEDURE locate_free_job_entry
    (    client_job_list_root: dft$client_job_list_root;
     VAR table_full: boolean;
     VAR free_entry_found: boolean;
     VAR client_job_id: dft$client_job_id);

    TYPE
      char_set = set of char;

    VAR
      found_character: integer,
      free_char_set: char_set,
      pointers_index: dft$job_list_ptr_array_index;

    free_char_set := $char_set [dfc$free_entry_char];

  /scan_all_job_lists/
    FOR pointers_index := 1 TO client_job_list_root.number_of_active_pointers DO
      #SCAN (free_char_set, client_job_list_root.p_job_list_pointer_array^ [pointers_index].assignment,
            found_character, free_entry_found);
      IF free_entry_found THEN
        table_full := FALSE;
        client_job_id.job_list_pointer_index := pointers_index;
        client_job_id.job_list_index := found_character;
        RETURN;
      IFEND;
    FOREND /scan_all_job_lists/;

    free_entry_found := FALSE;
    table_full := client_job_list_root.number_of_active_pointers =
          UPPERBOUND (client_job_list_root.p_job_list_pointer_array^);
  PROCEND locate_free_job_entry;

?? TITLE := 'remove_client_job ', EJECT ??

{
{   The purpose of this request is to remove the client job environment
{ from the server.  All permanent files left attached are detached.
{ All tables on the server associated with the client job are deleted.
{

  PROCEDURE remove_client_job
    (    p_client_mainframe_file: dft$p_mainframe_file;
         client_job_id: dft$client_job_id;
     VAR status: ost$status);

    VAR
      return_files_option: pft$return_files_option;

    status.normal := TRUE;
    osp$set_signature_lock (p_client_mainframe_file^.mainframe_header.client_job_list_lock, osc$wait, status);
    IF status.normal THEN
      return_files_option.return_files := TRUE;
      return_files_option.log_returned_files := TRUE;
      return_files_option.wait_for_down_volume := FALSE;
      pfp$process_job_end (p_client_mainframe_file^.mainframe_header.client_mainframe_id,
            return_files_option);

      delete_client_job_entry (p_client_mainframe_file^.mainframe_header.client_job_list_root,
            client_job_id, p_client_mainframe_file^.mainframe_heap);
      osp$clear_signature_lock (p_client_mainframe_file^.mainframe_header.client_job_list_lock, status);
    IFEND;
  PROCEND remove_client_job;
?? TITLE := 'update_pointer_array ', EJECT ??

  PROCEDURE update_pointer_array
    (VAR job_list_table_root: {Input, Output} dft$client_job_list_root;
         client_job_list_pointer: dft$client_job_list_pointer;
     VAR assigned_pointers_index: dft$job_list_ptr_array_index);

    VAR
      actual: integer;

    job_list_table_root.p_job_list_pointer_array^ [job_list_table_root.number_of_active_pointers + 1] :=
          client_job_list_pointer;
    osp$increment_locked_variable (job_list_table_root.number_of_active_pointers,
          job_list_table_root.number_of_active_pointers, actual);
    assigned_pointers_index := job_list_table_root.number_of_active_pointers;
  PROCEND update_pointer_array;


MODEND dfm$client_job_manager;

*DECK DECK=DFM$CLIENT_MAINFRAME_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File Server: Client Mainframe Manager' ??
MODULE dfm$client_mainframe_manager;

{ PURPOSE:
{   This server module contains those processes responsible for initially defining a client mainframe on the
{   server.  This is command driven: all information about the client mainframe must be entered via the
{   DEFINE_CLIENT command.  As a result of this command, a queue will be created on the server, for the
{   specified client mainframe.  Also, a permanent file will be created for the client mainframe.  This
{   permanent file contains information about the the client mainframe, and also contains an 'environment'
{   for each client job, that is using the server.  A job is submitted that services the client mainframe.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfc$iou_names
*copyc dfc$test_jr_constants
*copyc dfe$error_condition_codes
*copyc dfi$console_display
*copyc dfi$display
*copyc dfi$log_display
*copyc dft$client_mainframe_file
*copyc dft$display_identifier
*copyc dft$server_lifetime
*copyc dft$server_state
*copyc dpt$window_id
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc oss$task_shared
*copyc ost$caller_identifier
*copyc pfe$internal_error_conditions
*copyc pmt$binary_mainframe_id
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$return
*copyc amp$set_segment_eoi
*copyc clp$evaluate_parameters
*copyc dfp$build_client_mf_file_name
*copyc dfp$check_if_valid
*copyc dfp$crack_client_mf_file_name
*copyc dfp$create_queue
*copyc dfp$display
*copyc dfp$display_client_jobs
*copyc dfp$find_mainframe_id
*copyc dfp$locate_esm_definition
*copyc dfp$new_crack_mainframe_id
*copyc dfp$register_client_job
*copyc dfp$start_cdcnet_server
*copyc dfp$verify_stornet_channel
*copyc dfp$verify_system_administrator
*copyc fmp$ln_open_chapter
*copyc fsp$change_segment_number
*copyc fsp$close_file
*copyc fsp$open_file
*copyc i#move
*copyc mmp$change_segment_number
*copyc mmp$close_segment
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc mmp$get_segment_length
*copyc mmp$set_segment_length
*copyc mmp$write_modified_pages
*copyc osp$append_status_integer
*copyc osp$clear_job_signature_lock
*copyc osp$initialize_signature_lock
*copyc osp$reset_heap
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osp$test_sig_lock
*copyc pfp$attach
*copyc pfp$define
*copyc pfp$define_catalog
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_multi_item_info
*copyc pfp$process_job_end
*copyc pfp$purge
*copyc pfp$reattach_files_for_client
*copyc pfp$reset_task_environment
*copyc pfp$set_task_environment
*copyc pmp$convert_binary_mainframe_id
*copyc pmp$execute
*copyc pmp$wait
*copyc pmp$get_unique_name
*copyc syp$advised_move_bytes
*copyc syp$hang_if_system_jrt_set
?? EJECT ??
*copyc dfv$client_mainframe_file_lock
*copyc dfv$file_server_debug_enabled
*copyc dfv$maximum_client_job_lists
*copyc dfv$rebuild_client_tasks_stat_p
*copyc dfv$server_state_string
*copyc dfv$server_wired_heap
*copyc osv$page_size
?? TITLE := 'Global Variables Declared by This Module', EJECT ??

  VAR
    dfv$p_client_mainframe_file: [XDCL, oss$task_private] ^dft$client_mainframe_file := NIL,
    segment_attribute: [READ, oss$job_paged_literal] ARRAY [1 .. 1] OF mmt$attribute_descriptor :=
          [[mmc$kw_segment_number, dfc$client_mainframe_segnum]];

?? TITLE := '[XDCL] dfp$acquire_client_mf_file', EJECT ??

  PROCEDURE [XDCL] dfp$acquire_client_mf_file
    (    client_mainframe_name: pmt$mainframe_id;
         read_only: boolean;
     VAR lfn: ost$name;
     VAR client_segment_pointer: mmt$segment_pointer;
     VAR p_file: dft$p_mainframe_file;
     VAR status: ost$status);


    VAR
      amt_segment_pointer: amt$segment_pointer,
      caller_identifier: ost$caller_identifier,
      client_mainframe_file_name: ost$name,
      cycle_selector: pft$cycle_selector,
      local_status: ost$status,
      path: array [1 .. 4] of pft$name,
      p_segment_attribute: ^array [ * ] of mmt$attribute_descriptor,
      repeat_count: 0 .. 15,
      share: pft$share_selections,
      usage: pft$usage_selections;


    #CALLER_ID (caller_identifier);
    dfp$build_client_mf_file_name (client_mainframe_name, client_mainframe_file_name);
    path [1] := '';
    path [2] := '';
    path [3] := dfc$client_mainframe_catalog;
    path [4] := client_mainframe_file_name;
    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := 1;
    pmp$get_unique_name (lfn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF read_only THEN
      usage := $pft$usage_selections [pfc$read];
    ELSE
      usage := $pft$usage_selections [pfc$read, pfc$shorten, pfc$append, pfc$modify];
    IFEND;
    share := $pft$share_selections [pfc$read, pfc$shorten, pfc$append, pfc$modify];


    repeat_count := 5;
    REPEAT
      IF repeat_count <> 5 THEN
        pmp$wait (100, 100);
      IFEND;
      pfp$attach (lfn, path, cycle_selector, osc$null_name, usage, share, pfc$no_wait, status);
      repeat_count := repeat_count - 1;
    UNTIL status.normal OR (status.condition <> pfe$cycle_busy) OR (repeat_count <= 0);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Open the file (segment)

    p_segment_attribute := ^segment_attribute;

    fmp$ln_open_chapter (lfn, 0, caller_identifier.ring, p_segment_attribute, mmc$cell_pointer,
          client_segment_pointer, status);
    IF NOT status.normal THEN
      amp$return (lfn, local_status);

{??   dfp$purge_client_mainframe_file (client_mainframe_name, local_status);

      RETURN;
    IFEND;

    p_file := client_segment_pointer.cell_pointer;
    IF p_file^.mainframe_header.segment_number <> dfc$client_mainframe_segnum THEN
      amt_segment_pointer.kind := amc$cell_pointer;
      amt_segment_pointer.cell_pointer := client_segment_pointer.cell_pointer;
      mmp$change_segment_number (amt_segment_pointer, p_file^.mainframe_header.segment_number,
            caller_identifier.ring, amt_segment_pointer, status);
      IF NOT status.normal THEN
        display_abnormal_status (' dfp$acquire_client_mf_file calling mmp$change_seg..', status);
        mmp$close_segment (client_segment_pointer, caller_identifier.ring, local_status);
        amp$return (lfn, local_status);

{??!!   dfp$purge_client_mainframe_file (client_mainframe_name, local_status);

        RETURN;
      IFEND;
      client_segment_pointer.cell_pointer := amt_segment_pointer.cell_pointer;
      p_file := client_segment_pointer.cell_pointer;
    IFEND;


  PROCEND dfp$acquire_client_mf_file;

?? TITLE := '[XDCL] dfp$display_client_mainframes ', EJECT ??
{ PURPOSE:
{   The purpose of this request is to display the attached mainframes
{   at the operator display and the "Display_Client_Mainframes"
{   subcommand for the MANAGE_FILE_SERVER utility.
{
{ NOTES:
{   Upon entry to this procedure the 'message_written' parameter has been
{   set to FALSE by the calling procedure.  It is set to TRUE if a line is
{   displayed by this procedure.

  PROCEDURE [XDCL] dfp$display_client_mainframes
    (VAR display_identifier: dft$display_identifier;
     VAR message_written {input, output} : boolean;
     VAR status: ost$status);

    VAR
      catalog_content_info: amt$segment_pointer,
      catalog_path: array [1 .. 3] of pft$name,
      group: pft$group,
      ignore_status: ost$status,
      index: pft$array_index,
      lock_status: ost$signature_lock_status,
      p_directory_array: pft$p_directory_array,
      p_info_record: pft$p_info_record;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, catalog_content_info, status);
    IF status.normal THEN
      RESET catalog_content_info.sequence_pointer;
      group.group_type := pfc$public;
      catalog_path [1] := ' ';
      catalog_path [2] := ' ';
      catalog_path [3] := dfc$client_mainframe_catalog;

      pfp$get_multi_item_info (catalog_path, group, $pft$catalog_info_selections [],
            $pft$file_info_selections [pfc$file_directory], catalog_content_info.sequence_pointer, status);
      osp$test_sig_lock (dfv$client_mainframe_file_lock, lock_status);
      IF lock_status <> osc$sls_not_locked THEN
        { If a new client is created after this time we won't know about it since
        { the catalog_content_info will not contain it.
        status.normal := TRUE;
        dfp$display (' Client mainframes being defined ', display_identifier, status);
        mmp$delete_scratch_segment (catalog_content_info, ignore_status);
        RETURN;
      IFEND;
      IF status.normal THEN
        RESET catalog_content_info.sequence_pointer;
        pfp$find_next_info_record (catalog_content_info.sequence_pointer, p_info_record, status);
        IF status.normal THEN
          pfp$find_directory_array (p_info_record, p_directory_array, status);
          IF status.normal AND (p_directory_array <> NIL) THEN
            dfp$display ('--SYSTEM SUPPLIED NAME----USER JOB NAME-------------TRANSACTIONS--ACCESS-------',
                  display_identifier, ignore_status);
            message_written := TRUE;

          /display_all_mainframes/
            FOR index := LOWERBOUND (p_directory_array^) TO UPPERBOUND (p_directory_array^) DO
              CASE p_directory_array^ [index].name_type OF
              = pfc$file_name =
                IF p_directory_array^ [index].name (1, 4) = 'DFF$' THEN
                  display_mainframe (p_directory_array^ [index].name, display_identifier, status);
                IFEND;
              ELSE
              CASEND;
            FOREND /display_all_mainframes/;
          IFEND;
        IFEND;
      IFEND;
      mmp$delete_scratch_segment (catalog_content_info, ignore_status);
    IFEND;
  PROCEND dfp$display_client_mainframes;

?? TITLE := '[XDCL, #GATE] dfp$define_client_command ', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$define_client_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      client_active: boolean,
      client_mainframe: pmt$mainframe_id,
      client_mainframe_id: pmt$binary_mainframe_id,
      connection_parameters: dft$connection_parameters;

    status.normal := TRUE;
    dfp$verify_system_administrator ('DEFINE_CLIENT', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_define_client (parameter_list, client_mainframe, client_mainframe_id, connection_parameters,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF connection_parameters.connection_type = dfc$esm_connection THEN
      dfp$check_if_valid (connection_parameters, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    define_client_request (client_mainframe, client_mainframe_id, connection_parameters, status);

  PROCEND dfp$define_client_command;
?? TITLE := 'define_client_request ', EJECT ??

  PROCEDURE define_client_request
    (    client_mainframe: pmt$mainframe_id;
         client_mainframe_id: pmt$binary_mainframe_id;
         connection_parameters: dft$connection_parameters;
     VAR status: ost$status);

    VAR
      client_found: boolean,
      cpu_queue_p: ^dft$cpu_queue,
      ignore_directory_entry_p: ^dft$q_interface_directory_entry,
      queue_index: dft$queue_index,
      queue_interface_table_p: dft$p_queue_interface_table,
      server_birthdate: integer,
      server_lifetime: dft$server_lifetime,
      server_state: dft$server_state,
      server_to_client: boolean;

    status.normal := TRUE;
    server_to_client := TRUE;
    dfp$find_mainframe_id (client_mainframe, server_to_client, client_found, queue_interface_table_p,
          cpu_queue_p, queue_index, ignore_directory_entry_p);
    IF client_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$client_already_configured, client_mainframe, status);
      RETURN;
    IFEND;

    dfp$create_queue (connection_parameters, client_mainframe, client_mainframe_id, server_to_client,
          queue_interface_table_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cpu_queue_p := queue_interface_table_p^.queue_directory.cpu_queue_pva_directory
         [connection_parameters.server_queue_index].p_cpu_queue;
    dfp$get_client_mf_file_info (client_mainframe_id, client_found, server_state, server_lifetime,
          server_birthdate);
    IF client_found THEN
      CASE server_state OF
      = dfc$active, dfc$deactivated, dfc$inactive, dfc$awaiting_recovery, dfc$recovering =

        { Recover the lifetime and the birthdate from the client mainframe file.

        cpu_queue_p^.queue_header.partner_status.server_state := dfc$awaiting_recovery;
        cpu_queue_p^.queue_header.server_lifetime := server_lifetime;
        cpu_queue_p^.queue_header.server_birthdate := server_birthdate;
      ELSE

        { The client was terminated - do not recover the lifetime, start new.

      CASEND;
    ELSE
      osp$set_job_signature_lock (dfv$client_mainframe_file_lock);
      create_client_mainframe_file (client_mainframe, client_mainframe_id, status);
      osp$clear_job_signature_lock (dfv$client_mainframe_file_lock);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      dfp$set_client_mf_file_info (client_mainframe_id, cpu_queue_p^.queue_header.
            partner_status.server_state, cpu_queue_p^.queue_header.server_lifetime,
            cpu_queue_p^.queue_header.server_birthdate, client_found);
    IFEND;

    IF #RING (queue_interface_table_p) = osc$user_ring THEN

      { Running in a test harness environment

      set_queue_entries_active (queue_interface_table_p, queue_index);
    ELSE

      { In the real environment the entries are set as active by the activate_client process.

    IFEND;

    IF connection_parameters.connection_type = dfc$cdcnet_connection THEN
      dfp$start_cdcnet_server (queue_interface_table_p, connection_parameters.driver_name, client_mainframe,
            queue_index, status);
    IFEND;

  PROCEND define_client_request;
?? TITLE := ' [XDCL]   dfp$delete_client_mainframes ', EJECT ??

{
{ Purpose:
{   This procedure deletes all the files contained in the catalog of
{   client mainframes.  This is done when recovery is not enabled.
{

  PROCEDURE [XDCL] dfp$delete_client_mainframes;

    VAR
      catalog_content_info: amt$segment_pointer,
      catalog_path: array [1 .. 3] of pft$name,
      cycle_selector: pft$cycle_selector,
      file_path: array [1 .. 4] of pft$name,
      group: pft$group,
      index: pft$array_index,
      p_directory_array: pft$p_directory_array,
      p_info_record: pft$p_info_record,
      status: ost$status;

    IF dfv$file_server_debug_enabled THEN
      display ('Not recovering client mainframes ');
    IFEND;
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, catalog_content_info, status);
    IF status.normal THEN
      RESET catalog_content_info.sequence_pointer;
      group.group_type := pfc$public;
      catalog_path [1] := ' ';
      catalog_path [2] := ' ';
      catalog_path [3] := dfc$client_mainframe_catalog;
      pfp$get_multi_item_info (catalog_path, group, $pft$catalog_info_selections [],
            $pft$file_info_selections [pfc$file_directory], catalog_content_info.sequence_pointer, status);
      IF status.normal THEN
        RESET catalog_content_info.sequence_pointer;
        pfp$find_next_info_record (catalog_content_info.sequence_pointer, p_info_record, status);
        IF status.normal THEN
          pfp$find_directory_array (p_info_record, p_directory_array, status);
          IF status.normal AND (p_directory_array <> NIL) THEN
            file_path [1] := ' ';
            file_path [2] := ' ';
            file_path [3] := dfc$client_mainframe_catalog;
            cycle_selector.cycle_option := pfc$highest_cycle;

          /delete_all_mainframes/
            FOR index := LOWERBOUND (p_directory_array^) TO UPPERBOUND (p_directory_array^) DO
              CASE p_directory_array^ [index].name_type OF
              = pfc$file_name =
                file_path [4] := p_directory_array^ [index].name;
                IF dfv$file_server_debug_enabled THEN
                  display (p_directory_array^ [index].name);
                IFEND;
                pfp$purge (file_path, cycle_selector, osc$null_name, status);

{ Make sure any extra cycles get deleted also

                pfp$purge (file_path, cycle_selector, osc$null_name, status);
                pfp$purge (file_path, cycle_selector, osc$null_name, status);
              ELSE
              CASEND;
            FOREND /delete_all_mainframes/;
          IFEND;
        IFEND;
      IFEND;
      mmp$delete_scratch_segment (catalog_content_info, status);
    IFEND;
  PROCEND dfp$delete_client_mainframes;

?? TITLE := '[XDCL] dfp$discard_client_jobs ', EJECT ??

{ Remove all jobs from the client mainframe file, and update the state of
{ in the client mainframe file.

  PROCEDURE [XDCL] dfp$discard_client_jobs
    (    mainframe_id: pmt$mainframe_id;
         new_state: dft$server_state;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      client_mainframe_lfn: ost$name,
      client_mainframe_name: pmt$mainframe_id,
      client_segment_pointer: mmt$segment_pointer,
      p_client_mainframe_file: dft$p_mainframe_file;

    #CALLER_ID (caller_id);
    dfp$acquire_client_mf_file (mainframe_id, {read_only} FALSE, client_mainframe_lfn,
          client_segment_pointer, p_client_mainframe_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    p_client_mainframe_file^.mainframe_header.server_state := new_state;

    remove_client_jobs (p_client_mainframe_file, status);

    mmp$close_segment (client_segment_pointer, caller_id.ring, status);
    amp$return (client_mainframe_lfn, status);

  PROCEND dfp$discard_client_jobs;
?? TITLE := '[XDCL] dfp$get_client_mf_file_info ', EJECT ??

  PROCEDURE [XDCL] dfp$get_client_mf_file_info
    (    client_mainframe_id: pmt$binary_mainframe_id;
     VAR client_found: boolean;
     VAR server_state: dft$server_state;
     VAR server_lifetime: dft$server_lifetime;
     VAR server_birthdate: integer);

    VAR
      caller_id: ost$caller_identifier,
      client_mainframe_lfn: ost$name,
      client_mainframe_name: pmt$mainframe_id,
      client_segment_pointer: mmt$segment_pointer,
      p_client_mainframe_file: dft$p_mainframe_file,
      status: ost$status;

    #CALLER_ID (caller_id);
    client_found := FALSE;
    pmp$convert_binary_mainframe_id (client_mainframe_id, client_mainframe_name, status);
    IF NOT status.normal THEN
      display_abnormal_status (' dfp$get_client_mf_file_info calling pmp$convert_binary..', status);
      RETURN;
    IFEND;
    dfp$acquire_client_mf_file (client_mainframe_name, {read_only} TRUE, client_mainframe_lfn,
          client_segment_pointer, p_client_mainframe_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF p_client_mainframe_file^.mainframe_header.file_update_flag = dfc$client_file_valid THEN
      server_state := p_client_mainframe_file^.mainframe_header.server_state;
      server_lifetime := p_client_mainframe_file^.mainframe_header.server_lifetime;
      server_birthdate := p_client_mainframe_file^.mainframe_header.server_birthdate;
      client_found := TRUE;
    ELSE

{ Note - if file damaged is set in the header then delete the file
{  and return client_found = false

    IFEND;
    mmp$close_segment (client_segment_pointer, caller_id.ring, status);
    amp$return (client_mainframe_lfn, status);
  PROCEND dfp$get_client_mf_file_info;

?? TITLE := '[XDCL, #GATE] dfp$get_client_mainframe_file ', EJECT ??

{ PURPOSE:
{   This procedure is provided for debugging, and returns the client mainframe file for the specified client
{   mainframe.  The file returned is an exact copy of the client mainframe file, and is in binary format.

  PROCEDURE [XDCL, #GATE] dfp$get_client_mainframe_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE get_client_mainframe_file, getcmf (
{   client_mainframe_id, cmid: name pmc$mainframe_id_size = $required
{   output, o: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 9, 4, 12, 34, 46, 703],
    clc$command, 5, 3, 2, 0, 0, 0, 3, ''], [
    ['CLIENT_MAINFRAME_ID            ',clc$nominal_entry, 1],
    ['CMID                           ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [pmc$mainframe_id_size, pmc$mainframe_id_size]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$client_mainframe_id = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      caller_id: ost$caller_identifier,
      cell_array_p: ^ARRAY [1 .. * ] OF cell,
      client_mainframe: pmt$mainframe_id,
      client_mainframe_id: pmt$binary_mainframe_id,
      client_mainframe_lfn: ost$name,
      client_mainframe_segment_length: ost$segment_length,
      client_segment_pointer: mmt$segment_pointer,
      file_creation: ARRAY [1 .. 1] OF fst$file_cycle_attribute,
      ignore_p_file: dft$p_mainframe_file,
      local_status: ost$status,
      output_file_id: amt$file_identifier,
      output_segment_pointer: amt$segment_pointer;

    #CALLER_ID (caller_id);

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$verify_system_administrator ('GET_CLIENT_MAINFRAME_FILE', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    client_mainframe := pvt [p$client_mainframe_id].value^.name_value;
    dfp$new_crack_mainframe_id (client_mainframe, client_mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_creation [1].selector := fsc$ring_attributes;
    file_creation [1].ring_attributes.r1 := 11;
    file_creation [1].ring_attributes.r2 := 11;
    file_creation [1].ring_attributes.r3 := 11;
    fsp$open_file (pvt [p$output].value^.file_value^, amc$segment, NIL, ^file_creation, NIL, NIL, NIL,
          output_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (output_file_id, amc$sequence_pointer, output_segment_pointer, status);
    IF NOT status.normal THEN
      fsp$close_file (output_file_id, local_status);
      RETURN;
    IFEND;

    dfp$acquire_client_mf_file (client_mainframe, {read_only} TRUE, client_mainframe_lfn,
          client_segment_pointer, ignore_p_file, status);
    IF NOT status.normal THEN
      fsp$close_file (output_file_id, local_status);
      RETURN;
    IFEND;

    mmp$get_segment_length (client_segment_pointer.cell_pointer, caller_id.ring,
          client_mainframe_segment_length, status);
    IF status.normal THEN
      RESET output_segment_pointer.sequence_pointer;
      NEXT cell_array_p: [1 .. client_mainframe_segment_length] IN output_segment_pointer.sequence_pointer;
      IF cell_array_p = NIL THEN
        osp$set_status_abnormal (dfc$file_server_id, pfe$info_full, 'get_client_mainframe_file', status);
      ELSE
        i#move (client_segment_pointer.cell_pointer, output_segment_pointer.sequence_pointer,
              client_mainframe_segment_length);
        amp$set_segment_eoi (output_file_id, output_segment_pointer, status);
      IFEND;
    IFEND;
    mmp$close_segment (client_segment_pointer, caller_id.ring, local_status);

    amp$return (client_mainframe_lfn, local_status);
    fsp$close_file (output_file_id, local_status);

  PROCEND dfp$get_client_mainframe_file;

?? TITLE := '[XDCL] dfp$purge_client_mainframe_file', EJECT ??

  PROCEDURE [XDCL] dfp$purge_client_mainframe_file
    (    mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      client_mainframe_file_name: ost$name,
      cycle_selector: pft$cycle_selector,
      path: array [1 .. 4] of pft$name;

    status.normal := TRUE;
    dfp$build_client_mf_file_name (mainframe_id, client_mainframe_file_name);

    path [1] := '';
    path [2] := '';
    path [3] := dfc$client_mainframe_catalog;
    path [4] := client_mainframe_file_name;
    cycle_selector.cycle_option := pfc$highest_cycle;
    pfp$purge (path, cycle_selector, osc$null_name, status);

  PROCEND dfp$purge_client_mainframe_file;
?? TITLE := '[XDCL, #GATE] dfp$rebuild_client_mainframe', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$rebuild_client_mainframe
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE dfp$rebuild_client_mainframe (
{   mainframe_name: name pmc$mainframe_id_size = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 9, 4, 12, 43, 19, 974],
    clc$command, 2, 2, 1, 0, 0, 0, 2, ''], [
    ['MAINFRAME_NAME                 ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [pmc$mainframe_id_size, pmc$mainframe_id_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$mainframe_name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    PROCEDURE remove_old_client_mf_file;

      display (display_string);
      log_display ($pmt$ascii_logset[pmc$system_log], display_string);
      display_status (status);
      log_display_status ($pmt$ascii_logset[pmc$system_log], TRUE, status);
      mmp$close_segment (old_client_segment_pointer, caller_identifier.ring, local_status);
      amp$return (old_client_mainframe_lfn, local_status);
      dfp$purge_client_mainframe_file (client_mainframe_name, local_status);

    PROCEND remove_old_client_mf_file;

    PROCEDURE remove_new_client_mf_file;

      fsp$close_file (new_client_fid, local_status);
      amp$return (new_client_mainframe_lfn, status);

    PROCEND remove_new_client_mf_file;

    VAR
      caller_identifier: ost$caller_identifier,
      client_mainframe_id: pmt$binary_mainframe_id,
      client_mainframe_name: pmt$mainframe_id,
      display_string: string (80),
      display_string_length: integer,
      local_status: ost$status,
      new_client_mainframe_lfn: ost$name,
      new_client_mainframe_file_p: dft$p_mainframe_file,
      new_client_fid: amt$file_identifier,
      old_client_file_id: amt$file_identifier,
      old_client_mainframe_file_p: dft$p_mainframe_file,
      old_client_mainframe_lfn: ost$name,
      old_client_segment_pointer: mmt$segment_pointer;

    #CALLER_ID (caller_identifier);
    status.normal := TRUE;
    dfp$verify_system_administrator ('dfp$rebuild_client_mainframe', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      display_status (status);
      log_display_status ($pmt$ascii_logset[pmc$system_log], {format} TRUE, status);
      RETURN;
    IFEND;

    client_mainframe_name := pvt [p$mainframe_name].value^.name_value;
    dfp$new_crack_mainframe_id (client_mainframe_name, client_mainframe_id, status);
    IF NOT status.normal THEN
      log_display_status ($pmt$ascii_logset[pmc$system_log], {format} TRUE, status);
      display_status (status);
      RETURN;
    IFEND;

    display_string := ' Rebuild client mainframe ';
    display_string (27, * ) := client_mainframe_name;
    display (display_string);
    log_display ($pmt$ascii_logset[pmc$system_log], display_string);
    dfp$acquire_client_mf_file (client_mainframe_name, {read_only} FALSE, old_client_mainframe_lfn,
          old_client_segment_pointer, old_client_mainframe_file_p, status);

    IF NOT status.normal THEN
      log_display ($pmt$ascii_logset[pmc$system_log], display_string);
      display (display_string);
      display_status (status);
      log_display_status ($pmt$ascii_logset[pmc$system_log], TRUE,
           status);
      dfp$purge_client_mainframe_file (client_mainframe_name, local_status);
      RETURN;
    IFEND;

    verify_client_file_recoverable (old_client_mainframe_file_p, status);
    IF NOT status.normal THEN
      remove_old_client_mf_file;
      IF status.condition = dfe$client_already_terminated THEN
        display (' Client already terminated: no recovery possible ');
        log_display ($pmt$ascii_logset [pmc$system_log],
              ' Client already terminated: no recovery possible ');
        display (client_mainframe_name);
        log_display ($pmt$ascii_logset [pmc$system_log], client_mainframe_name);
        status.normal := TRUE;
      IFEND;
      RETURN;
    IFEND;

    create_rebuild_segment (old_client_mainframe_file_p, client_mainframe_name, client_mainframe_id,
          new_client_fid, new_client_mainframe_file_p, new_client_mainframe_lfn, status);
    IF NOT status.normal THEN
      remove_old_client_mf_file;
      remove_new_client_mf_file;
      RETURN;
    IFEND;

    rebuild_client_jobs (old_client_mainframe_file_p, new_client_mainframe_file_p, status);
    IF NOT status.normal THEN
      remove_old_client_mf_file;
      remove_new_client_mf_file;
      RETURN;
    IFEND;

    copy_rebuilt_segment (old_client_mainframe_file_p, new_client_mainframe_file_p, status);

    fsp$close_file (new_client_fid, local_status);
    mmp$close_segment (old_client_segment_pointer, caller_identifier.ring, local_status);
    amp$return (new_client_mainframe_lfn, status);
    amp$return (old_client_mainframe_lfn, status);
    display_string := ' Rebuild client mainframe ';
    display_string (27, * ) := client_mainframe_name;
    display_string (45, * ) := 'completed';
    display (display_string);
    log_display ($pmt$ascii_logset[pmc$system_log], display_string);

  PROCEND dfp$rebuild_client_mainframe;
?? TITLE := ' [XDCL] dfp$rebuild_client_mainframes ', EJECT ??

{
{ Purpose:
{   This procedure rebuilds all the files contained in the catalog of
{   client mainframes. An asynchronous task is started for each client mainframe.
{   This task then waits for all of the tasks to complete.

  PROCEDURE [XDCL] dfp$rebuild_client_mainframes;

    VAR
      catalog_content_info: amt$segment_pointer,
      catalog_path: array [1 .. 3] of pft$name,
      group: pft$group,
      index: pft$array_index,
      local_status: ost$status,
      mainframe_id: pmt$mainframe_id,
      p_directory_array: pft$p_directory_array,
      p_info_record: pft$p_info_record,
      status: ost$status;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, catalog_content_info, status);
    IF status.normal THEN
      RESET catalog_content_info.sequence_pointer;
      group.group_type := pfc$public;
      catalog_path [1] := ' ';
      catalog_path [2] := ' ';
      catalog_path [3] := dfc$client_mainframe_catalog;
      pfp$get_multi_item_info (catalog_path, group, $pft$catalog_info_selections [],
            $pft$file_info_selections [pfc$file_directory], catalog_content_info.sequence_pointer, status);
      IF status.normal THEN
        RESET catalog_content_info.sequence_pointer;
        pfp$find_next_info_record (catalog_content_info.sequence_pointer, p_info_record, status);
        IF status.normal THEN
          pfp$find_directory_array (p_info_record, p_directory_array, status);
          IF status.normal AND (p_directory_array <> NIL) THEN
            ALLOCATE dfv$rebuild_client_tasks_stat_p: [1 .. UPPERBOUND (p_directory_array^)] IN
                  dfv$server_wired_heap^;

          /rebuild_all_mainframes/
            FOR index := LOWERBOUND (p_directory_array^) TO UPPERBOUND (p_directory_array^) DO
              CASE p_directory_array^ [index].name_type OF
              = pfc$file_name =
                IF p_directory_array^ [index].name (1, 4) = 'DFF$' THEN
                  dfp$crack_client_mf_file_name (p_directory_array^ [index].name, mainframe_id);
                  dfv$rebuild_client_tasks_stat_p^ [index].mainframe_id := mainframe_id;
                  start_rebuild_client_task (mainframe_id, dfv$rebuild_client_tasks_stat_p^ [index].
                        task_status, status);
                ELSE
                  dfv$rebuild_client_tasks_stat_p^ [index].mainframe_id := ' ';
                  dfv$rebuild_client_tasks_stat_p^ [index].task_status.status.normal := TRUE;
                  dfv$rebuild_client_tasks_stat_p^ [index].task_status.complete := TRUE;
                IFEND;
              ELSE
                dfv$rebuild_client_tasks_stat_p^ [index].mainframe_id := ' ';
                dfv$rebuild_client_tasks_stat_p^ [index].task_status.status.normal := TRUE;
                dfv$rebuild_client_tasks_stat_p^ [index].task_status.complete := TRUE;
              CASEND;
            FOREND /rebuild_all_mainframes/;
          IFEND;
        IFEND;
      IFEND;
      mmp$delete_scratch_segment (catalog_content_info, local_status);
    IFEND;

    await_rebuild_tasks_completion (dfv$rebuild_client_tasks_stat_p);
    IF dfv$rebuild_client_tasks_stat_p <> NIL THEN
      FREE dfv$rebuild_client_tasks_stat_p IN dfv$server_wired_heap^;
    IFEND;

  PROCEND dfp$rebuild_client_mainframes;
?? TITLE := '[XDCL] dfp$remove_client_jobs ', EJECT ??

  PROCEDURE [XDCL] dfp$remove_client_jobs
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      amt_segment_pointer: amt$segment_pointer,
      caller_identifier: ost$caller_identifier,
      client_mainframe_name: ost$name,
      p_client_mainframe_file: ^dft$client_mainframe_file,
      segment_attribute: array [1 .. 1] of mmt$attribute_descriptor,
      segment_pointer: mmt$segment_pointer;

    dfp$build_client_mf_file_name (mainframe_name, client_mainframe_name);
    segment_attribute [1].keyword := mmc$kw_segment_number;
    segment_attribute [1].segnum := dfc$client_mainframe_segnum;

    #CALLER_ID (caller_identifier);
    fmp$ln_open_chapter (client_mainframe_name, 0, caller_identifier.ring, ^segment_attribute,
          mmc$cell_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    p_client_mainframe_file := segment_pointer.cell_pointer;
    IF p_client_mainframe_file^.mainframe_header.segment_number <> dfc$client_mainframe_segnum THEN
      amt_segment_pointer.kind := amc$cell_pointer;
      amt_segment_pointer.cell_pointer := segment_pointer.cell_pointer;
      mmp$change_segment_number (amt_segment_pointer, p_client_mainframe_file^.mainframe_header.
            segment_number, 3, amt_segment_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      segment_pointer.cell_pointer := amt_segment_pointer.cell_pointer;
      p_client_mainframe_file := segment_pointer.cell_pointer;
    IFEND;
    remove_client_jobs (p_client_mainframe_file, status);

    mmp$close_segment (segment_pointer, caller_identifier.ring, status);
  PROCEND dfp$remove_client_jobs;
?? TITLE := '[XDCL] dfp$set_client_mf_file_info', EJECT ??

  PROCEDURE [XDCL] dfp$set_client_mf_file_info
    (    client_mainframe_id: pmt$binary_mainframe_id;
         server_state: dft$server_state;
         server_lifetime: dft$server_lifetime;
         server_birthdate: integer;
     VAR client_found: boolean);

    VAR
      caller_id: ost$caller_identifier,
      client_mainframe_lfn: ost$name,
      client_mainframe_name: pmt$mainframe_id,
      client_segment_pointer: mmt$segment_pointer,
      log_string: string (80),
      log_string_length: integer,
      p_client_mainframe_file: dft$p_mainframe_file,
      status: ost$status;

    #CALLER_ID (caller_id);
    client_found := FALSE;
    pmp$convert_binary_mainframe_id (client_mainframe_id, client_mainframe_name, status);
    IF NOT status.normal THEN
      display_abnormal_status (' dfp$Set_client_mf_file_info calling pmp$convert_binary..', status);
      RETURN;
    IFEND;
    STRINGREP (log_string, log_string_length, ' Client ', client_mainframe_name,
     ' ', dfv$server_state_string [server_state],
     ' Life/Birth ', server_lifetime, server_birthdate);
    log_display ($pmt$ascii_logset [pmc$system_log, pmc$job_log], log_string (1, log_string_length));
    IF dfv$file_server_debug_enabled THEN
      display_to_console (log_string (1, log_string_length));
    IFEND;
    dfp$acquire_client_mf_file (client_mainframe_name, {read_only} FALSE, client_mainframe_lfn,
          client_segment_pointer, p_client_mainframe_file, status);

    IF NOT status.normal THEN
      display_abnormal_status (' dfp$set_client_mf_file_info calling dfp$acquire..', status);
      RETURN;
    IFEND;
    IF p_client_mainframe_file^.mainframe_header.file_update_flag = dfc$client_file_valid THEN
      p_client_mainframe_file^.mainframe_header.server_state := server_state;
      p_client_mainframe_file^.mainframe_header.server_lifetime := server_lifetime;
      p_client_mainframe_file^.mainframe_header.server_birthdate := server_birthdate;
      client_found := TRUE;
    ELSE
      { Note - if file damaged is set in the header then delete the file  } {??}

{  and return client_found = false

    IFEND;
    mmp$close_segment (client_segment_pointer, caller_id.ring, status);
    amp$return (client_mainframe_lfn, status);
  PROCEND dfp$set_client_mf_file_info;
?? TITLE := 'await_rebuild_task_completion', EJECT ??
{
{    This procedure waits for all of the tasks rebuilding client mainframes to
{ complete.  This is done by checking the task status of each of the
{ rebuild tasks.  A 'deadman' timeout is provided in the event of a hung task.
{
  PROCEDURE await_rebuild_tasks_completion
    (    rebuild_client_tasks_stat_p: ^array [ * ] of dft$mainframe_task_status);

    CONST
      check_wait_time = 30000 { 30 seconds } ,
      maximum_wait_time = 5 {minutes } * 60000 { milliseconds per minute } ;

    VAR
      all_tasks_complete: boolean,
      index: integer,
      local_status: ost$status,
      wait_count: 0 .. 50;

    wait_count := 0;
    all_tasks_complete := TRUE;

    IF rebuild_client_tasks_stat_p <> NIL THEN
      display (' Waiting for rebuild of client mainframes to complete ');

    /await_rebuild_complete/
      REPEAT
        all_tasks_complete := TRUE;
        pmp$wait (check_wait_time, check_wait_time);
        wait_count := wait_count + 1;

      /check_all_tasks/
        FOR index := LOWERBOUND (rebuild_client_tasks_stat_p^)
              TO UPPERBOUND (rebuild_client_tasks_stat_p^) DO
          all_tasks_complete := all_tasks_complete AND rebuild_client_tasks_stat_p^ [index].task_status.
                complete;
          IF rebuild_client_tasks_stat_p^ [index].task_status.complete AND
                NOT rebuild_client_tasks_stat_p^ [index].task_status.status.normal THEN
            display ('Rebuild client_mainframe task failed ');
            log_display ($pmt$ascii_logset[pmc$system_log],
                  'Rebuild client_mainframe task failed ');
            display (rebuild_client_tasks_stat_p^ [index].mainframe_id);
            log_display ($pmt$ascii_logset[pmc$system_log],
                  rebuild_client_tasks_stat_p^ [index].mainframe_id);
            display_status (rebuild_client_tasks_stat_p^ [index].task_status.status);
            log_display_status ($pmt$ascii_logset[pmc$system_log], {format} TRUE,
                 rebuild_client_tasks_stat_p^ [index].task_status.status);
            display (' -- Deadstart required to bring up client - no job recovery possible ');
            log_display ($pmt$ascii_logset[pmc$system_log],
                  ' -- Deadstart required to bring up client - no job recovery possible ');
            rebuild_client_tasks_stat_p^ [index].task_status.status.normal := TRUE;
            dfp$purge_client_mainframe_file (rebuild_client_tasks_stat_p^ [index].mainframe_id,
                  local_status);
          IFEND;
        FOREND /check_all_tasks/;
      UNTIL all_tasks_complete OR ((wait_count * check_wait_time) > maximum_wait_time);

      IF all_tasks_complete THEN
        display (' All rebuild client mainframe tasks have completed ');
        log_display ($pmt$ascii_logset[pmc$system_log],
             ' All rebuild client mainframe tasks have completed ');
      ELSE
        display (' All rebuild client mainframe tasks have not yet completed - proceeding with deadstart ');
        log_display ($pmt$ascii_logset[pmc$system_log],
              ' All rebuild client mainframe tasks have not completed successfully');
      IFEND;
    IFEND;
  PROCEND await_rebuild_tasks_completion;

?? TITLE := 'copy_rebuilt_segment ', EJECT ??

  PROCEDURE copy_rebuilt_segment
    (    old_client_mainframe_p: ^dft$client_mainframe_file;
         new_client_mainframe_p: ^dft$client_mainframe_file;
     VAR status: ost$status);

    VAR
      new_segment_length: ost$segment_length;

    status.normal := TRUE;
    mmp$get_segment_length (new_client_mainframe_p, #RING (new_client_mainframe_p), new_segment_length,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    new_client_mainframe_p^.mainframe_header.file_update_flag := dfc$client_file_damaged;
    old_client_mainframe_p^.mainframe_header.file_update_flag := dfc$client_file_damaged;
    mmp$write_modified_pages (old_client_mainframe_p, 1000, osc$wait, status);

    syp$advised_move_bytes (new_client_mainframe_p, old_client_mainframe_p, new_segment_length, status);
    mmp$write_modified_pages (old_client_mainframe_p, new_segment_length, osc$wait, status);

    old_client_mainframe_p^.mainframe_header.file_update_flag := dfc$client_file_valid;
    mmp$write_modified_pages (old_client_mainframe_p, 1000, osc$wait, status);
    mmp$set_segment_length (old_client_mainframe_p, #RING (new_client_mainframe_p), new_segment_length,
          status);

  PROCEND copy_rebuilt_segment;
?? TITLE := 'crack_define_client', EJECT ??

  PROCEDURE crack_define_client
    (    parameter_list: clt$parameter_list;
     VAR client_mainframe: pmt$mainframe_id;
     VAR client_mainframe_id: pmt$binary_mainframe_id;
     VAR connection_parameters: dft$connection_parameters;
     VAR status: ost$status);

{ PROCEDURE define_client, defc (
{   client_mainframe_identifier, cmi: name pmc$mainframe_id_size = $required
{   client_id_number, cidn, cin: integer 1 .. dfc$max_number_of_mainframes  = $required
{   server_id_number, sidn, sin: integer 1 .. dfc$max_number_of_mainframes = $required
{   number_of_monitor_queue_entries, nomqe: integer 0 .. dfc$max_queue_entries-2 = 50
{   number_of_task_queue_entries, notqe: integer 1 .. dfc$max_queue_entries-2 = 4
{   connection_type, ct: any of key stornet keyend, name, anyend = stornet
{   element_name, en: name = $required
{   send_channel, sc: list 1 .. 2 of name = $required
{   receive_channel, rc: list 1 .. 2 of name
{   dma_available, da: boolean = true
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 23] of clt$pdt_parameter_name,
      parameters: array [1 .. 11] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (2),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type6: 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$name_type_qualifier,
        recend,
        default_value: string (7),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type11: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 9, 6, 7, 30, 35, 924],
    clc$command, 23, 11, 5, 0, 0, 0, 11, ''], [
    ['CIDN                           ',clc$alias_entry, 2],
    ['CIN                            ',clc$abbreviation_entry, 2],
    ['CLIENT_ID_NUMBER               ',clc$nominal_entry, 2],
    ['CLIENT_MAINFRAME_IDENTIFIER    ',clc$nominal_entry, 1],
    ['CMI                            ',clc$abbreviation_entry, 1],
    ['CONNECTION_TYPE                ',clc$nominal_entry, 6],
    ['CT                             ',clc$abbreviation_entry, 6],
    ['DA                             ',clc$abbreviation_entry, 10],
    ['DMA_AVAILABLE                  ',clc$nominal_entry, 10],
    ['ELEMENT_NAME                   ',clc$nominal_entry, 7],
    ['EN                             ',clc$abbreviation_entry, 7],
    ['NOMQE                          ',clc$abbreviation_entry, 4],
    ['NOTQE                          ',clc$abbreviation_entry, 5],
    ['NUMBER_OF_MONITOR_QUEUE_ENTRIES',clc$nominal_entry, 4],
    ['NUMBER_OF_TASK_QUEUE_ENTRIES   ',clc$nominal_entry, 5],
    ['RC                             ',clc$abbreviation_entry, 9],
    ['RECEIVE_CHANNEL                ',clc$nominal_entry, 9],
    ['SC                             ',clc$abbreviation_entry, 8],
    ['SEND_CHANNEL                   ',clc$nominal_entry, 8],
    ['SERVER_ID_NUMBER               ',clc$nominal_entry, 3],
    ['SIDN                           ',clc$alias_entry, 3],
    ['SIN                            ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 11]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 4
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 5
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 6
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 7
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 8
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$required_parameter,
  0, 0],
{ PARAMETER 9
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 10
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 11
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [pmc$mainframe_id_size, pmc$mainframe_id_size]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, dfc$max_number_of_mainframes, 10]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, dfc$max_number_of_mainframes, 10]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [0, dfc$max_queue_entries-2, 10],
    '50'],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [1, dfc$max_queue_entries-2, 10],
    '4'],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['STORNET                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'stornet'],
{ PARAMETER 7
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 8
    [[1, 0, clc$list_type], [5, 1, 2, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 9
    [[1, 0, clc$list_type], [5, 1, 2, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 10
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 11
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$client_mainframe_identifier = 1,
      p$client_id_number = 2,
      p$server_id_number = 3,
      p$number_of_monitor_queue_entri = 4 {NUMBER_OF_MONITOR_QUEUE_ENTRIES} ,
      p$number_of_task_queue_entries = 5,
      p$connection_type = 6,
      p$element_name = 7,
      p$send_channel = 8,
      p$receive_channel = 9,
      p$dma_available = 10,
      p$status = 11;

    VAR
      pvt: array [1 .. 11] of clt$parameter_value;

    VAR
      computed_queue_size: ost$non_negative_integers,
      data_value: clt$data_value,
      esm_table_entry_p: ^dft$esm_definition_table_entry;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Crack the mainframe id.

    client_mainframe := pvt [p$client_mainframe_identifier].value^.name_value;
    dfp$new_crack_mainframe_id (client_mainframe, client_mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    connection_parameters.server_queue_index := pvt [p$client_id_number].value^.integer_value.value;
    connection_parameters.client_queue_index :=
          pvt [p$server_id_number].value^.integer_value.value + dfc$max_number_of_mainframes;
    connection_parameters.number_of_monitor_queue_entries :=
          pvt [p$number_of_monitor_queue_entri].value^.integer_value.value;
    connection_parameters.number_of_task_queue_entries :=
          pvt [p$number_of_task_queue_entries].value^.integer_value.value;

    { Add 1 to the sum of queue entries to account for the Poll Task.

    computed_queue_size := ((connection_parameters.number_of_monitor_queue_entries +
          connection_parameters.number_of_task_queue_entries + 1) * #SIZE (dft$driver_queue_entry)) +
          #SIZE (dft$driver_queue_header);
    IF computed_queue_size > osv$page_size THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$too_many_queue_entries, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, computed_queue_size, 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, osv$page_size, 10, FALSE, status);
      RETURN;
    IFEND;

    connection_parameters.client_to_server.client_to_server := FALSE;
    connection_parameters.client_to_server.users_wait_on_terminated := TRUE;
    connection_parameters.client_to_server.preallocate_image_size := 0;
    connection_parameters.client_to_server.timeout_interval := 1;
    connection_parameters.client_to_server.maximum_request_timeout_count := 1;
    connection_parameters.client_to_server.maximum_retransmission_count := 1;

    IF (pvt [p$connection_type].value^.kind = clc$keyword) AND
          (pvt [p$connection_type].value^.keyword_value = 'STORNET') THEN
      connection_parameters.connection_type := dfc$esm_connection;
      connection_parameters.esm_parameters.element_name := pvt [p$element_name].value^.name_value;

      data_value := pvt [p$send_channel].value^;
      connection_parameters.esm_parameters.send_channel.channel_name := data_value.element_value^.name_value;
      IF data_value.link = NIL THEN
        connection_parameters.esm_parameters.send_channel.iou_name := dfc$iou_name0;
      ELSE
        data_value := data_value.link^;
        IF (data_value.element_value^.name_value <> dfc$iou_name0) AND
              (data_value.element_value^.name_value <> dfc$iou_name1) THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$send_channel_invalid_iou,
                data_value.element_value^.name_value, status);
          RETURN;
        IFEND;
        connection_parameters.esm_parameters.send_channel.iou_name :=
              data_value.element_value^.name_value;
      IFEND;
      dfp$verify_stornet_channel (connection_parameters.esm_parameters.element_name,
            connection_parameters.esm_parameters.send_channel, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT pvt [p$receive_channel].specified THEN
        connection_parameters.esm_parameters.receive_channel :=
              connection_parameters.esm_parameters.send_channel;
      ELSE
        data_value := pvt [p$receive_channel].value^;
        connection_parameters.esm_parameters.receive_channel.channel_name :=
              data_value.element_value^.name_value;
        IF data_value.link = NIL THEN
          connection_parameters.esm_parameters.receive_channel.iou_name :=
                connection_parameters.esm_parameters.send_channel.iou_name;
        ELSE
          data_value := data_value.link^;
          IF (data_value.element_value^.name_value <> dfc$iou_name0) AND
                (data_value.element_value^.name_value <> dfc$iou_name1) THEN
            osp$set_status_abnormal (dfc$file_server_id, dfe$receive_channel_invalid_iou,
                  data_value.element_value^.name_value, status);
            RETURN;
          IFEND;
          connection_parameters.esm_parameters.receive_channel.iou_name :=
                data_value.element_value^.name_value;
        IFEND;
        dfp$verify_stornet_channel (connection_parameters.esm_parameters.element_name,
              connection_parameters.esm_parameters.receive_channel, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      connection_parameters.esm_parameters.destination_id_number :=
            pvt [p$client_id_number].value^.integer_value.value;
      connection_parameters.esm_parameters.source_id_number :=
            pvt [p$server_id_number].value^.integer_value.value;
      connection_parameters.esm_parameters.dma_available := pvt [p$dma_available].value^.boolean_value.value;

      dfp$locate_esm_definition (connection_parameters.esm_parameters.element_name, esm_table_entry_p);
      IF esm_table_entry_p = NIL THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$stornet_not_defined,
             connection_parameters.esm_parameters.element_name, status);
        RETURN;
      IFEND;
      connection_parameters.esm_parameters.esm_memory_size := esm_table_entry_p^.memory_size;
      connection_parameters.esm_parameters.esm_base_addresses := esm_table_entry_p^.esm_base_addresses;
      connection_parameters.client_to_server.maximum_data_bytes := esm_table_entry_p^.maximum_data_bytes;

      connection_parameters.driver_name := connection_parameters.esm_parameters.send_channel.channel_name;

      IF pvt [p$client_id_number].value^.integer_value.value >
            connection_parameters.esm_parameters.esm_base_addresses.number_of_mainframes THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$id_number_exceeds_nomf, 'Client', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              pvt [p$client_id_number].value^.integer_value.value, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              connection_parameters.esm_parameters.esm_base_addresses.number_of_mainframes, 10, FALSE,
              status);
        RETURN;
      IFEND;
      IF pvt [p$server_id_number].value^.integer_value.value >
            connection_parameters.esm_parameters.esm_base_addresses.number_of_mainframes THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$id_number_exceeds_nomf, 'Server', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              pvt [p$server_id_number].value^.integer_value.value, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              connection_parameters.esm_parameters.esm_base_addresses.number_of_mainframes, 10, FALSE,
              status);
        RETURN;
      IFEND;

    ELSEIF pvt [p$connection_type].value^.name_value = 'CDCNET' THEN
      connection_parameters.connection_type := dfc$cdcnet_connection;
      connection_parameters.driver_name := pvt [p$element_name].value^.name_value;
    ELSEIF pvt [p$connection_type].value^.name_value = 'MOCK' THEN
      connection_parameters.connection_type := dfc$mock_connection;
      connection_parameters.driver_name := pvt [p$element_name].value^.name_value;
    ELSE
      connection_parameters.driver_name := pvt [p$element_name].value^.name_value;
    IFEND;

  PROCEND crack_define_client;
?? TITLE := 'create_client_mainframe_file ', EJECT ??

  PROCEDURE create_client_mainframe_file
    (    client_mainframe: pmt$mainframe_id;
         client_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

    VAR
      caller_identifier: ost$caller_identifier,
      catalog_path: array [1 .. 3] of pft$name,
      client_mainframe_name: ost$name,
      cycle_selector: pft$cycle_selector,
      local_status: ost$status,
      mainframe_file_path: array [1 .. 4] of pft$name,
      segment_pointer: mmt$segment_pointer;

    status.normal := TRUE;
    catalog_path [1] := ' ';
    catalog_path [2] := ' ';
    catalog_path [3] := dfc$client_mainframe_catalog;
    pfp$define_catalog (catalog_path, status);
    IF (NOT status.normal) AND (status.condition <> pfe$name_already_subcatalog) THEN
      RETURN;
    IFEND;
    dfp$build_client_mf_file_name (client_mainframe, client_mainframe_name);
    mainframe_file_path [1] := ' ';
    mainframe_file_path [2] := ' ';
    mainframe_file_path [3] := dfc$client_mainframe_catalog;
    mainframe_file_path [4] := client_mainframe_name;
    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := 1;
    pfp$define (client_mainframe_name, mainframe_file_path, cycle_selector, osc$null_name,
          pfc$maximum_retention, pfc$log, status);
    IF NOT status.normal THEN
      IF (status.condition = pfe$name_already_permanent_file) OR (status.condition = pfe$duplicate_cycle) THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$client_already_configured, client_mainframe, status);
      IFEND;
      RETURN;
    IFEND;

    #CALLER_ID (caller_identifier);
    fmp$ln_open_chapter (client_mainframe_name, 0, caller_identifier.ring, ^segment_attribute,
          mmc$cell_pointer, segment_pointer, status);
    IF status.normal THEN
      dfv$p_client_mainframe_file := segment_pointer.cell_pointer;
      initializ_client_mainframe_file (dfv$p_client_mainframe_file, client_mainframe, client_mainframe_id,
            dfc$client_mainframe_segnum);
      mmp$close_segment (segment_pointer, caller_identifier.ring, status);
    IFEND;

    amp$return (client_mainframe_name, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;
  PROCEND create_client_mainframe_file;
?? TITLE := 'create_rebuild_segment', EJECT ??

  PROCEDURE create_rebuild_segment
    (    old_client_mainframe_p: ^dft$client_mainframe_file;
         client_mainframe_name: pmt$mainframe_id;
         client_mainframe_id: pmt$binary_mainframe_id;
     VAR new_client_fid: amt$file_identifier;
     VAR new_client_mainframe_p: ^dft$client_mainframe_file;
     VAR new_client_mainframe_lfn: ost$name;
     VAR status: ost$status);

    VAR
      amt_segment_pointer: amt$segment_pointer,
      local_status: ost$status,
      segment: ost$segment;

    pmp$get_unique_name (new_client_mainframe_lfn, status);
    fsp$open_file (new_client_mainframe_lfn, amc$segment, NIL, NIL, NIL, NIL, NIL, new_client_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (new_client_fid, amc$cell_pointer, amt_segment_pointer, status);
    IF NOT status.normal THEN
      fsp$close_file (new_client_fid, local_status);
      RETURN;
    IFEND;

    IF old_client_mainframe_p^.mainframe_header.segment_number = dfc$client_mainframe_segnum THEN
      segment := dfc$client_mainframe_segnum_b;
    ELSE
      segment := dfc$client_mainframe_segnum;
    IFEND;
    fsp$change_segment_number (new_client_fid, segment, { validation_ring } 3, amc$cell_pointer,
          amt_segment_pointer, status);
    IF NOT status.normal THEN
      display_status (status);
      fsp$close_file (new_client_fid, local_status);
      amp$return (new_client_mainframe_lfn, local_status);
      RETURN;
    IFEND;

    new_client_mainframe_p := amt_segment_pointer.cell_pointer;
    dfv$p_client_mainframe_file := amt_segment_pointer.cell_pointer;
    initializ_client_mainframe_file (dfv$p_client_mainframe_file, client_mainframe_name, client_mainframe_id,
          segment);

    new_client_mainframe_p^.mainframe_header.server_state := dfc$awaiting_recovery;
    new_client_mainframe_p^.mainframe_header.server_lifetime :=
          old_client_mainframe_p^.mainframe_header.server_lifetime;
    new_client_mainframe_p^.mainframe_header.server_birthdate :=
          old_client_mainframe_p^.mainframe_header.server_birthdate;

  PROCEND create_rebuild_segment;

?? TITLE := 'display_abnormal_status', EJECT ??

  PROCEDURE display_abnormal_status
    (    comment: string ( * <= 255);
         abnormal_status: ost$status);

    display ('  ******************ABNORMAL STATUS *********');
    display (comment);
    display_status (abnormal_status);
    log_display ($pmt$ascii_logset[pmc$system_log], comment);
    log_display_status ($pmt$ascii_logset[pmc$system_log], {format} TRUE,
       abnormal_status);
    display ('  ********************');

  PROCEND display_abnormal_status;

?? TITLE := 'display_mainframe ', EJECT ??

  PROCEDURE display_mainframe
    (    client_mainframe_pf_name: ost$name;
     VAR display_identifier: dft$display_identifier;
     VAR status: ost$status);

    VAR
      caller_identifier: ost$caller_identifier,
      client_mainframe_lfn: ost$name,
      local_status: ost$status,
      mainframe_id: pmt$mainframe_id,
      mainframe_title: string (60),
      mainframe_title_size: integer,
      p_client_mainframe_file: dft$p_mainframe_file,
      segment_pointer: mmt$segment_pointer;

    status.normal := TRUE;
    #CALLER_ID (caller_identifier);
    dfp$crack_client_mf_file_name (client_mainframe_pf_name, mainframe_id);
    mainframe_title := ' CLIENT   ';
    mainframe_title (14, * ) := mainframe_id;
    dfp$acquire_client_mf_file (mainframe_id, {read_only} TRUE, client_mainframe_lfn, segment_pointer,
          p_client_mainframe_file, status);
    IF NOT status.normal THEN
      STRINGREP (mainframe_title, mainframe_title_size, mainframe_title (1, 32),
          ' - Error ', status.condition);
      dfp$display (mainframe_title, display_identifier, local_status);
      RETURN;
    IFEND;
    IF (p_client_mainframe_file^.mainframe_header.file_update_flag <> dfc$client_file_valid) THEN
      mainframe_title (40, * ) := ' file being updated or damaged';
      dfp$display (mainframe_title, display_identifier, local_status);
      mmp$close_segment (segment_pointer, caller_identifier.ring, local_status);
      amp$return (client_mainframe_lfn, local_status);
      RETURN;
    IFEND;

    mainframe_title (40, * ) := dfv$server_state_string [p_client_mainframe_file^.mainframe_header.
          server_state];
    dfp$display (mainframe_title, display_identifier, status);

    dfp$display_client_jobs (p_client_mainframe_file, display_identifier, status);

    mmp$close_segment (segment_pointer, caller_identifier.ring, status);
    IF NOT status.normal THEN
      amp$return (client_mainframe_lfn, local_status);
      RETURN;
    IFEND;

    amp$return (client_mainframe_lfn, status);

  PROCEND display_mainframe;

?? TITLE := 'initializ_client_mainframe_file', EJECT ??

  PROCEDURE initializ_client_mainframe_file
    (    p_mainframe_file: dft$p_mainframe_file;
         client_mainframe_name: pmt$mainframe_id;
         client_mainframe_id: pmt$binary_mainframe_id;
         segment_number: ost$segment);

    VAR
      job_list: dft$job_list_ptr_array_index,
      status: ost$status;

    osp$reset_heap (^p_mainframe_file^.mainframe_heap, #SIZE (p_mainframe_file^.mainframe_heap),
          {lock = } TRUE, 1);
    ALLOCATE p_mainframe_file^.mainframe_header.client_job_list_root.p_job_list_pointer_array:
          [1 .. dfv$maximum_client_job_lists] IN p_mainframe_file^.mainframe_heap;
    IF p_mainframe_file^.mainframe_header.client_job_list_root.p_job_list_pointer_array = NIL THEN
      osp$system_error (' NIL JOB_LIST_POINTER_ARRAY', NIL);
    IFEND;
    p_mainframe_file^.mainframe_header.version := dfc$current_mf_file_version;
    p_mainframe_file^.mainframe_header.client_mainframe_id := client_mainframe_id;
    p_mainframe_file^.mainframe_header.client_mainframe_name := client_mainframe_name;
    osp$initialize_signature_lock (p_mainframe_file^.mainframe_header.client_job_list_lock, status);
    p_mainframe_file^.mainframe_header.client_job_list_root.number_of_active_pointers := 0;

  /initialize_job_lists/
    FOR job_list := 1 TO dfv$maximum_client_job_lists DO
      p_mainframe_file^.mainframe_header.client_job_list_root.p_job_list_pointer_array^ [job_list].
            assignment := ' ';
      p_mainframe_file^.mainframe_header.client_job_list_root.p_job_list_pointer_array^ [job_list].
            p_client_job_list := NIL;
    FOREND /initialize_job_lists/;

    #SPOIL (p_mainframe_file^.mainframe_header);
    p_mainframe_file^.mainframe_header.file_update_flag := dfc$client_file_valid;
    p_mainframe_file^.mainframe_header.segment_number := segment_number;
    #SPOIL (p_mainframe_file^.mainframe_header);
  PROCEND initializ_client_mainframe_file;
?? EJECT ??

  PROCEDURE rebuild_client_jobs
    (    p_old_client_mainframe_file: ^dft$client_mainframe_file;
         p_new_client_mainframe_file: ^dft$client_mainframe_file;
     VAR status: ost$status);

    VAR
      client_mainframe_id: pmt$binary_mainframe_id,
      display_string: string (80),
      display_string_length: integer,
      files_reattached: ost$non_negative_integers,
      files_not_reattached: ost$non_negative_integers,
      job_list_index: dft$client_job_list_index,
      job_list_pointer_index: dft$job_list_ptr_array_index,
      new_client_job_id: dft$client_job_id,
      new_job_list_entry: dft$client_job_list_entry,
      new_p_job_list_pointer: ^dft$job_list_pointer_array,
      old_job_list_entry: dft$client_job_list_entry,
      old_p_job_list_pointer: ^dft$job_list_pointer_array,
      p_client_job_space: ^dft$client_job_space,
      p_client_mainframe_file: ^dft$client_mainframe_file,
      p_job_list_pointer: ^dft$job_list_pointer_array,
      p_old_attached_pf_table: ^pft$attached_pf_table,
      recoverable_job_count: ost$non_negative_integers,
      total_files_reattached: ost$non_negative_integers,
      total_files_not_reattached: ost$non_negative_integers,
      unrecoverable_job_count: ost$non_negative_integers,
      user_id: ost$user_identification;

    unrecoverable_job_count := 0;
    recoverable_job_count := 0;
    total_files_reattached := 0;
    total_files_not_reattached := 0;

    client_mainframe_id :=  p_old_client_mainframe_file^.mainframe_header.client_mainframe_id;
    old_p_job_list_pointer := p_old_client_mainframe_file^.mainframe_header.client_job_list_root.
          p_job_list_pointer_array;
    new_p_job_list_pointer := p_new_client_mainframe_file^.mainframe_header.client_job_list_root.
          p_job_list_pointer_array;

  /search_mainframe_file/
    FOR job_list_pointer_index := 1 TO p_old_client_mainframe_file^.mainframe_header.client_job_list_root.
          number_of_active_pointers DO

    /find_active_jobs/
      FOR job_list_index := 1 TO dfc$client_job_list_size DO
        IF old_p_job_list_pointer^ [job_list_pointer_index].assignment (job_list_index) =
              dfc$free_entry_char THEN
          CYCLE /find_active_jobs/;
        IFEND;
        old_job_list_entry := old_p_job_list_pointer^ [job_list_pointer_index].
              p_client_job_list^ [job_list_index];
        IF dfv$file_server_debug_enabled THEN
          display (old_job_list_entry.system_supplied_job_name);
        IFEND;

{ Do some verification of the client job environment (but not the heap).
{  Verify request is not processing unrecoverable request.

        IF old_job_list_entry.inhibit_job_recovery <> 0 THEN
          unrecoverable_job_count := unrecoverable_job_count + 1;
          IF dfv$file_server_debug_enabled THEN
            display_integer (' Unrecoverable job - inhibit_job_recovery ',
                  old_job_list_entry.inhibit_job_recovery);
          IFEND;
          STRINGREP (display_string, display_string_length,
                ' Unrecoverable client job ',
                 old_job_list_entry.system_supplied_job_name);
          display (display_string( 1, display_string_length));
          log_display ($pmt$ascii_logset[pmc$system_log], display_string( 1, display_string_length));
          CYCLE /find_active_jobs/;
        IFEND;

        syp$hang_if_system_jrt_set (dfc$tjr_hang_rebuild_clientjobs);
        p_client_job_space := old_job_list_entry.p_client_job_space;
        user_id.user := p_client_job_space^.user;
        user_id.family := p_client_job_space^.family;
        dfp$register_client_job (user_id, p_client_job_space^.account, p_client_job_space^.project,
              old_job_list_entry.system_supplied_job_name, old_job_list_entry.user_supplied_job_name,
              old_job_list_entry.job_mode,
              p_client_job_space^.family_access_kind, old_job_list_entry.job_lifetime,
              p_new_client_mainframe_file, new_client_job_id, status);
        IF NOT status.normal THEN
          unrecoverable_job_count := unrecoverable_job_count + 1;
          display_status (status);
          display (' Unrecoverable job - dfp$register_client_job');
          log_display ($pmt$ascii_logset [pmc$system_log],
                 ' Unrecoverable job - dfp$register_client_job');
          CYCLE /find_active_jobs/;
        IFEND;

        new_job_list_entry := new_p_job_list_pointer^ [new_client_job_id.job_list_pointer_index].
              p_client_job_list^ [new_client_job_id.job_list_index];
        pfp$set_task_environment (new_job_list_entry.p_client_job_space, TRUE, TRUE);
        p_old_attached_pf_table := p_client_job_space^.p_attached_pf_table;
        pfp$reattach_files_for_client (client_mainframe_id, p_old_attached_pf_table, files_reattached,
              files_not_reattached, status);
        total_files_reattached := total_files_reattached + files_reattached;
        total_files_not_reattached := total_files_not_reattached + files_not_reattached;
        IF dfv$file_server_debug_enabled THEN
          display_integer (' Files reattached ', files_reattached);
          display_integer (' Files NOT reattached ', files_not_reattached);
        IFEND;
        IF status.normal THEN
          recoverable_job_count := recoverable_job_count + 1;
        ELSE
          unrecoverable_job_count := unrecoverable_job_count + 1;
          IF dfv$file_server_debug_enabled THEN
            display (' Unrecoverable job - pfp$reatttach_files_for_client');
            display_status (status);
          IFEND;

{ Remove the job from the new client mainframe file.

          new_p_job_list_pointer^ [new_client_job_id.job_list_pointer_index].
                assignment (new_client_job_id.job_list_index) := dfc$free_entry_char;
          FREE new_job_list_entry.p_client_job_space IN p_new_client_mainframe_file^.mainframe_heap;
          new_p_job_list_pointer^ [new_client_job_id.job_list_pointer_index].
                p_client_job_list^ [new_client_job_id.job_list_index].system_supplied_job_name := 'deleted';
        IFEND;

      FOREND /find_active_jobs/;
    FOREND /search_mainframe_file/;

    pfp$reset_task_environment;

    display (p_old_client_mainframe_file^.mainframe_header.client_mainframe_name);
    display_integer (' - Files reattached ', total_files_reattached);
    display_integer (' - Files NOT reattached ', total_files_not_reattached);
    display_integer (' - Recoverable client jobs ', recoverable_job_count);
    display_integer (' - Unrecoverable client jobs ', unrecoverable_job_count);
    log_display ($pmt$ascii_logset[pmc$system_log],
         p_old_client_mainframe_file^.mainframe_header.client_mainframe_name);
    log_display_integer ($pmt$ascii_logset[pmc$system_log],
          ' - Files reattached ', total_files_reattached);
    log_display_integer ($pmt$ascii_logset[pmc$system_log],
          ' - Files NOT reattached ', total_files_not_reattached);
    log_display_integer ($pmt$ascii_logset[pmc$system_log],
           ' - Recoverable client jobs ', recoverable_job_count);
    log_display_integer ($pmt$ascii_logset[pmc$system_log],
          ' - Unrecoverable client jobs ', unrecoverable_job_count);
  PROCEND rebuild_client_jobs;
?? TITLE := 'remove_client_jobs ', EJECT ??

  PROCEDURE remove_client_jobs
    (    p_client_mainframe_file: ^dft$client_mainframe_file;
     VAR status: ost$status);

    VAR
      job_list_entry: dft$client_job_list_entry,
      job_list_index: dft$client_job_list_index,
      job_list_pointer_index: dft$job_list_ptr_array_index,
      p_job_list_pointer: ^dft$job_list_pointer_array,
      pass: 1 .. 2,
      return_files_option: pft$return_files_option;

    p_job_list_pointer := p_client_mainframe_file^.mainframe_header.client_job_list_root.
          p_job_list_pointer_array;

  /two_pass/
    FOR pass := 1 TO 2 DO

    /search_mainframe_file/
      FOR job_list_pointer_index := 1 TO p_client_mainframe_file^.mainframe_header.client_job_list_root.
            number_of_active_pointers DO

      /find_active_jobs/
        FOR job_list_index := 1 TO dfc$client_job_list_size DO
          IF p_job_list_pointer^ [job_list_pointer_index].assignment (job_list_index) =
                dfc$free_entry_char THEN
            CYCLE /find_active_jobs/;
          IFEND;
          job_list_entry := p_job_list_pointer^ [job_list_pointer_index].p_client_job_list^ [job_list_index];
          IF dfv$file_server_debug_enabled THEN
            display (job_list_entry.system_supplied_job_name);
          IFEND;
          pfp$set_task_environment (job_list_entry.p_client_job_space, { System Administrator } TRUE,
                { Family Administrator } TRUE);
          return_files_option.return_files := TRUE;
          return_files_option.log_returned_files := TRUE;
          return_files_option.wait_for_down_volume := FALSE;
          pfp$process_job_end (p_client_mainframe_file^.mainframe_header.client_mainframe_id,
                return_files_option);
          IF dfv$file_server_debug_enabled THEN
            display_integer ('Files Returned :', return_files_option.files_returned);
          IFEND;
          IF pass = 2 THEN
            IF return_files_option.files_on_down_device > 0 THEN
              return_files_option.wait_for_down_volume := TRUE;
              display_integer ('Waiting for return of files on down device:',
                    return_files_option.files_on_down_device);
              pfp$process_job_end (p_client_mainframe_file^.mainframe_header.client_mainframe_id,
                    return_files_option);
              IF dfv$file_server_debug_enabled THEN
                display_integer ('Files Returned :', return_files_option.files_returned);
              IFEND;
            IFEND;
          IFEND;

          IF ((pass = 1) AND (return_files_option.files_on_down_device = 0)) OR (pass = 2) THEN

{ Remove the job.

            p_job_list_pointer^ [job_list_pointer_index].assignment (job_list_index) := dfc$free_entry_char;
            FREE job_list_entry.p_client_job_space IN p_client_mainframe_file^.mainframe_heap;
            p_job_list_pointer^ [job_list_pointer_index].p_client_job_list^ [job_list_index].
                  system_supplied_job_name := 'deleted';
          IFEND;
        FOREND /find_active_jobs/;
      FOREND /search_mainframe_file/;
    FOREND /two_pass/;

    pfp$reset_task_environment;
  PROCEND remove_client_jobs;
?? TITLE := 'set_queue_entries_active ', EJECT ??

  PROCEDURE set_queue_entries_active
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index);

    VAR
      queue_entry: dft$queue_entry_index;

  /initialize_each_entry/
    FOR queue_entry := 1 TO UPPERBOUND (p_queue_interface_table^.queue_directory.
          driver_queue_pva_directory [queue_index].p_driver_queue^.queue_entries) DO
      p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue^.
            queue_entries [queue_entry].flags.active_entry := TRUE;
    FOREND /initialize_each_entry/;
  PROCEND set_queue_entries_active;

?? TITLE := 'start_rebuild_client_task ', EJECT ??

  PROCEDURE start_rebuild_client_task
    (    mainframe_id: pmt$mainframe_id;
     VAR task_status: pmt$task_status;
     VAR status: ost$status);

    VAR
      p_parameter_sequence: ^pmt$program_parameters,
      p_parameter_string: ^ost$string,
      p_program_attributes: ^pmt$program_attributes,
      p_program_description: ^pmt$program_description,
      taskid: pmt$task_id;

    PUSH p_program_description: [[REP 1 OF pmt$program_attributes]];
    RESET p_program_description;
    NEXT p_program_attributes IN p_program_description;
    p_program_attributes^.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$load_map_options_specified, pmc$term_error_level_specified];
    p_program_attributes^.starting_procedure := 'DFP$REBUILD_CLIENT_MAINFRAME';
    p_program_attributes^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    p_program_attributes^.termination_error_level := pmc$warning_load_errors;

    PUSH p_parameter_sequence: [[REP 1 OF ost$string]];
    RESET p_parameter_sequence;
    NEXT p_parameter_string IN p_parameter_sequence;
    p_parameter_string^.size := #SIZE (mainframe_id);
    p_parameter_string^.value := mainframe_id;

    pmp$execute (p_program_description^, p_parameter_sequence^, osc$nowait, taskid, task_status, status);
  PROCEND start_rebuild_client_task;
?? TITLE := 'verify_client_file_recoverable', EJECT ??

  PROCEDURE verify_client_file_recoverable
    (    p_client_mainframe_file: ^dft$client_mainframe_file;
     VAR status: ost$status);

    status.normal := TRUE;
    IF (p_client_mainframe_file^.mainframe_header.file_update_flag <> dfc$client_file_valid) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$client_mf_file_unrecovered,
            ' SYSTEM FAILURE IN THE MIDDLE OF UPDATE ', status);
      RETURN;
    IFEND;

    IF (p_client_mainframe_file^.mainframe_header.server_state = dfc$terminated) OR
          (p_client_mainframe_file^.mainframe_header.server_state = dfc$deleted) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$client_already_terminated,
            p_client_mainframe_file^.mainframe_header.client_mainframe_name, status);
      RETURN;
    IFEND;

    IF dfv$file_server_debug_enabled THEN
      IF p_client_mainframe_file^.mainframe_header.client_job_list_lock.lock_id <> 0 THEN
        display (p_client_mainframe_file^.mainframe_header.client_mainframe_name);
        display ('     Previous failure while client job list locked.');
       log_display ($pmt$ascii_logset[pmc$system_log],
              '     Previous failure while client job list locked.');
      IFEND;
    IFEND;
  PROCEND verify_client_file_recoverable;
?? OLDTITLE ??
?? OLDTITLE ??
MODEND dfm$client_mainframe_manager;

*DECK DECK=DFM$CLIENT_REMOTE_CORE_CALL EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE File Server : Client : Remote Core Call' ??
MODULE dfm$client_remote_core_call;
{
{   This module contains the client side of the remote procedure call
{   processing provided for system core.  This module very closely  resembles
{   DFM$CLIENT_REMOTE_PROCEDUR_CALL and changes in both modules should be
{   made in tandom.  On the server side the core calls still go through
{   processing in DFM$SERVER_REMOTE_PROCEDUR_CALL.
{
{   The system core remote procedure call mechanism is
{   different than the standard remote procedure call mechanism in that:
{   - Only served family table index may be specified for server location.
{   - No data movement is provided.
{   - Since there is no data movement there is no need to restart requests.
{   - All procedure checksums and versions use the same value.
{   - Waiting is different - pmp$cycle or pmp$delay is used.
{
?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc dfc$remote_core_call
*copyc dfc$test_jr_constants
*copyc dfd$driver_queue_types
*copyc dfd$request_package
*copyc dfe$error_condition_codes
*copyc dfk$keypoints
*copyc dft$cpu_queue
*copyc dft$procedure_version
*copyc dft$rpc_buffer_header
*copyc dft$rpc_parameters
*copyc dft$rpc_queue_entry_location
*copyc dft$rpc_queue_entry_loc_int
*copyc dft$served_family_table_index
*copyc ost$status
?? POP ??
?? EJECT ??
*copyc dfp$await_core_subsystem_action
*copyc dfp$clear_driver_flags
*copyc dfp$convert_queue_entry_loc
*copyc dfp$fetch_queue_entry
*copyc dfp$fetch_served_family_info
*copyc dfp$get_qit_p_from_direct_index
*copyc dfp$get_queue_directory_index
*copyc dfp$get_system_core_queue_entry
*copyc dfp$queue_client_core_request
*copyc dfp$release_task_queue_entry
*copyc dfp$set_invalid_family_index
*copyc dfp$validate_rpc_status
*copyc dfp$word_boundary
*copyc dfv$send_command_flags
*copyc i#current_sequence_position
*copyc osp$set_status_abnormal
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_job_names
*copyc osp$begin_system_activity
*copyc osp$end_system_activity
*copyc syp$core_hang_if_system_jrt_set
?? TITLE := '  Global Declarations Declared by this module', EJECT ??

?? TITLE := ' [XDCL, #GATE] dfp$begin_remote_core_call', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$begin_remote_core_call
    (    server_location: dft$served_family_table_index;
         allowed_when_server_deactivated: boolean;
     VAR queue_entry_location: dft$rpc_queue_entry_location;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR status: ost$status);

    VAR
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_cpu_queue_header: ^dft$cpu_queue_header,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_send_buffer_header: ^dft$buffer_header,
      p_send_rpc_buffer_header: ^dft$rpc_buffer_header,
      queue_entry_loc_int: dft$rpc_queue_entry_loc_int;

    #KEYPOINT (osk$entry, osk$m * $INTEGER (allowed_when_server_deactivated),
          dfk$begin_remote_procedure_call);

    locate_server (server_location, p_queue_interface_table, queue_entry_loc_int, status);
    IF status.normal THEN
      p_cpu_queue_header := ^p_queue_interface_table^.queue_directory.cpu_queue_pva_directory
           [queue_entry_loc_int.queue_index].p_cpu_queue^.queue_header;
      IF (p_cpu_queue_header^.partner_status.server_state = dfc$active) OR
       ((p_cpu_queue_header^.partner_status.server_state = dfc$deactivated) AND
         allowed_when_server_deactivated) THEN
        osp$begin_system_activity;
      ELSE
        dfp$set_terminated_status (p_queue_interface_table, queue_entry_loc_int.queue_index,
            status);
      IFEND;
      IF status.normal THEN
        dfp$get_system_core_queue_entry (p_queue_interface_table, queue_entry_loc_int.queue_index,
              queue_entry_loc_int.queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry, status);
        IF status.normal THEN
          syp$core_hang_if_system_jrt_set (dfc$tjr_begin_core_rpc);
          {  Construct pointer to  user part of send buffer area .
          RESET p_cpu_queue_entry^.p_send_buffer;
          NEXT p_send_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
          NEXT p_send_rpc_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
          NEXT p_send_to_server_params IN p_cpu_queue_entry^.p_send_buffer;
          RESET p_send_to_server_params;
          p_cpu_queue_entry^.maximum_data_sent := 0;
          p_cpu_queue_entry^.maximum_data_received := 0;
          dfp$convert_qel_int_to_ext (queue_entry_loc_int, queue_entry_location);
        ELSE
          osp$end_system_activity;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      #KEYPOINT (osk$exit, osk$m * queue_entry_loc_int.queue_entry_index, dfk$begin_remote_procedure_call);
    ELSE
      #KEYPOINT (osk$exit, 0, dfk$begin_remote_procedure_call);
    IFEND;
  PROCEND dfp$begin_remote_core_call;
?? TITLE := ' [XDCL, #GATE] dfp$end_remote_core_call ', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$end_remote_core_call
    (    queue_entry_location: dft$rpc_queue_entry_location;
     VAR status: ost$status);

    VAR
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_entry_loc_int: dft$rpc_queue_entry_loc_int;

    dfp$convert_qel_ext_to_int (queue_entry_location, queue_entry_loc_int);
    #KEYPOINT (osk$entry, osk$m * queue_entry_loc_int.queue_entry_index, dfk$end_remote_procedure_call);
    dfp$get_qit_p_from_direct_index (queue_entry_loc_int.queue_directory_index, p_queue_interface_table);
    syp$core_hang_if_system_jrt_set (dfc$tjr_end_core_rpc);
    dfp$release_task_queue_entry (p_queue_interface_table, queue_entry_loc_int.queue_index,
          queue_entry_loc_int.queue_entry_index, status);
    osp$end_system_activity;
    #KEYPOINT (osk$exit, 0, dfk$end_remote_procedure_call);

  PROCEND dfp$end_remote_core_call;
?? TITLE := ' [XDCL, #GATE] dfp$send_remote_core_call ', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$send_remote_core_call
    (    queue_entry_location: dft$rpc_queue_entry_location;
         procedure_ordinal: dft$procedure_address_ordinal;
         send_to_server_params_size: dft$send_parameter_size;
     VAR p_receive_from_server_params: dft$p_receive_parameters;
     VAR status: ost$status);

    VAR
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_entry_loc_int: dft$rpc_queue_entry_loc_int;

    #KEYPOINT (osk$entry, osk$m * $INTEGER (procedure_ordinal), dfk$send_remote_procedure_call);
    dfp$convert_qel_ext_to_int (queue_entry_location, queue_entry_loc_int);
    dfp$get_qit_p_from_direct_index (queue_entry_loc_int.queue_directory_index, p_queue_interface_table);
    dfp$fetch_queue_entry (p_queue_interface_table, queue_entry_loc_int.queue_index,
          queue_entry_loc_int.queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry);

    send_remote_core_call (p_queue_interface_table, queue_entry_loc_int.queue_index,
          queue_entry_loc_int.queue_entry_index, p_cpu_queue_entry, p_driver_queue_entry, procedure_ordinal,
          send_to_server_params_size, p_receive_from_server_params, status);

    #KEYPOINT (osk$exit, 0, dfk$send_remote_procedure_call);

  PROCEND dfp$send_remote_core_call;
?? TITLE := ' initialize_rpc_send ', EJECT ??

  PROCEDURE initialize_rpc_send
    (    procedure_ordinal: dft$procedure_address_ordinal;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_send_buffer_header: ^dft$buffer_header;
         p_send_rpc_buffer_header: ^dft$rpc_buffer_header;
         user_parameter_size: dft$send_parameter_size);

    VAR
      ignore_status: ost$status,
      user_supplied_name: jmt$user_supplied_name;

    { Initialize standard buffer header
    p_send_buffer_header^.version := dfc$rpc_request_buffer_version;
    p_send_buffer_header^.remote_processor := procedure_ordinal;
    p_send_buffer_header^.data_length_sent := 0;

    { Initialize remote procedure call buffer header
    pmp$get_job_names (user_supplied_name, p_send_rpc_buffer_header^.system_supplied_job_name, ignore_status);
    p_send_rpc_buffer_header^.procedure_version := dfc$system_core_version;
    p_send_rpc_buffer_header^.procedure_name_checksum := dfc$system_core_checksum;
    p_send_rpc_buffer_header^.procedure_class := dfc$system_core_call;

    { Initialize rpc progress record
    p_send_rpc_buffer_header^.call_progress.transaction_per_rpc_request := 0;
    p_send_rpc_buffer_header^.call_progress.total_data_sent := 0;
    p_send_rpc_buffer_header^.call_progress.total_data_received := 0;
    p_send_rpc_buffer_header^.call_progress.user_buffer_length_sent := user_parameter_size;
    p_send_rpc_buffer_header^.call_progress.user_data_length_sent := 0;

    { Initialize cpu queue entry
    pmp$get_executing_task_gtid (p_cpu_queue_entry^.global_task_id);
    p_cpu_queue_entry^.call_progress := p_send_rpc_buffer_header^.call_progress;
    p_cpu_queue_entry^.total_data_to_receive := 0;
  PROCEND initialize_rpc_send;
?? TITLE := ' locate_server ', EJECT ??

  PROCEDURE locate_server
    (    served_family_table_index: dft$served_family_table_index;
     VAR p_queue_interface_table: dft$p_queue_interface_table;
     VAR queue_entry_loc_int: dft$rpc_queue_entry_loc_int;
     VAR status: ost$status);

    VAR
      family: ost$family_name,
      family_found: boolean,
      server_state: dft$server_state;

    dfp$fetch_served_family_info (served_family_table_index, family,
          queue_entry_loc_int.server_mainframe_id, p_queue_interface_table, queue_entry_loc_int.queue_index,
          family_found);
    IF NOT family_found THEN
      dfp$set_invalid_family_index (served_family_table_index, 'DFP$BEGIN_REMOTE_CORE_CALL',
            status);
    IFEND;
    IF p_queue_interface_table = NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$family_not_served, ' Family deleted ', status);
    IFEND;

    IF status.normal THEN
      dfp$get_queue_directory_index (p_queue_interface_table, queue_entry_loc_int.queue_directory_index);
    IFEND;
  PROCEND locate_server;
?? TITLE := ' send_remote_core_call ', EJECT ??

  PROCEDURE send_remote_core_call
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         procedure_ordinal: dft$procedure_address_ordinal;
         send_to_server_params_size: dft$send_parameter_size;
     VAR p_receive_from_server_params: dft$p_receive_parameters;
     VAR status: ost$status);

    VAR
      p_receive_rpc_buffer_header: ^dft$rpc_response_buffer_header,
      p_send_buffer_header: ^dft$buffer_header,
      p_send_rpc_buffer_header: ^dft$rpc_buffer_header;

    p_receive_from_server_params := NIL;
    RESET p_cpu_queue_entry^.p_send_buffer;
    NEXT p_send_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
    NEXT p_send_rpc_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
    initialize_rpc_send (procedure_ordinal, p_cpu_queue_entry, p_send_buffer_header, p_send_rpc_buffer_header,
          send_to_server_params_size);
    send_request_to_server (p_queue_interface_table, queue_index, queue_entry_index, p_cpu_queue_entry,
          p_driver_queue_entry, send_to_server_params_size, p_send_buffer_header, p_send_rpc_buffer_header,
          p_receive_rpc_buffer_header, status);
    IF status.normal THEN
        IF p_receive_rpc_buffer_header^.call_progress.user_buffer_length_sent > 0 THEN
          NEXT p_receive_from_server_params: [[REP p_receive_rpc_buffer_header^.call_progress.
                user_buffer_length_sent OF cell]] IN p_cpu_queue_entry^.p_receive_buffer;
        IFEND;
    IFEND;
  PROCEND send_remote_core_call;
?? TITLE := ' send_request_to_server ', EJECT ??

  PROCEDURE send_request_to_server
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         send_to_server_params_size: dft$send_parameter_size;
         p_send_buffer_header: ^dft$buffer_header;
         p_send_rpc_buffer_header: ^dft$rpc_buffer_header;
     VAR p_receive_rpc_buffer_header: ^dft$rpc_response_buffer_header;
     VAR status: ost$status);

    p_driver_queue_entry^.data_descriptor.actual_length := 0;
    p_send_buffer_header^.data_length_sent := 0;
    p_send_buffer_header^.buffer_length_sent := dfp$word_boundary
          (#SIZE (dft$buffer_header) + #SIZE (dft$rpc_buffer_header) + send_to_server_params_size);

    { Initialize cpu queue entry
    p_cpu_queue_entry^.retransmission_count := 0;
    p_cpu_queue_entry^.transaction_count := p_cpu_queue_entry^.transaction_count + 1;
    { Update call progress
    p_cpu_queue_entry^.call_progress.transaction_per_rpc_request :=
          p_cpu_queue_entry^.call_progress.transaction_per_rpc_request + 1;

    { Complete initialization standard buffer header
    p_send_buffer_header^.transaction_count := p_cpu_queue_entry^.transaction_count;
    p_send_buffer_header^.retransmission_count := 0;
    { Complete Initialization  Remote procedure call header
    p_send_rpc_buffer_header^.call_progress := p_cpu_queue_entry^.call_progress;

    p_driver_queue_entry^.send_buffer_descriptor.actual_length := p_send_buffer_header^.buffer_length_sent;
    p_driver_queue_entry^.flags := dfv$send_command_flags;
    dfp$queue_client_core_request (p_queue_interface_table, queue_index, queue_entry_index, status);
    syp$core_hang_if_system_jrt_set (dfc$tjr_send_core_rpc);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$await_core_subsystem_action (p_driver_queue_entry);
    dfp$clear_driver_flags (p_driver_queue_entry);
    dfp$validate_rpc_status (p_cpu_queue_entry, p_receive_rpc_buffer_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    p_cpu_queue_entry^.total_data_to_receive := 0;
  PROCEND send_request_to_server;
MODEND dfm$client_remote_core_call;
*DECK DECK=DFM$CLIENT_REMOTE_PROCEDUR_CALL EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE File Server : Client : Remote Procedure Call' ??
MODULE dfm$client_remote_procedur_call;
{
{   This module contains the client side of the remote procedure call
{   processing.  The client side drives the remote procedure call mechanism,
{   looping on sending / receiving data.  The remote procedure call is
{   broken into multiple transactions if there is too much data to be sent.
{   Data is never sent both directions on one transaction. If the server
{   detects that the request needs to be restarted and abnormal status of
{   of dfe$restart_server_request is returned to the client and the
{   complete request is set over again.  Changes in this module may need
{   to be reflected in module DFM$CLIENT_REMOTE_CORE_CALL.
?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfd$request_package
*copyc dfe$error_condition_codes
*copyc dfk$keypoints
*copyc dft$cpu_queue
*copyc dft$job_recovery_location
*copyc dft$procedure_version
*copyc dft$rpc_parameters
*copyc dft$rpc_queue_entry_location
*copyc dft$rpc_queue_entry_loc_int
*copyc dft$rpc_buffer_header
*copyc dft$rpc_procedure_address_list
*copyc dft$server_location
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc ost$caller_identifier
*copyc ost$status
*copyc pme$insufficient_privilege
?? POP ??
?? EJECT ??
*copyc avp$family_administrator
*copyc avp$system_administrator
*copyc clp$validate_name
*copyc dfc$test_jr_constants
*copyc dfi$display
*copyc dfi$log_display
*copyc dfp$await_subsystem_action
*copyc dfp$check_job_server
*copyc dfp$check_queue_entry_assigned
*copyc dfp$clear_driver_flags
*copyc dfp$convert_queue_entry_loc
*copyc dfp$fetch_queue_entry
*copyc dfp$fetch_served_family_info
*copyc dfp$fetch_served_family_state
*copyc dfp$find_mainframe_id
*copyc dfp$form_inquiry_tracer
*copyc dfp$get_qit_p_from_direct_index
*copyc dfp$get_queue_directory_index
*copyc dfp$get_task_queue_entry
*copyc dfp$initialize_rma_list
*copyc dfp$locate_served_family
*copyc dfp$page_count
*copyc dfp$queue_client_task_request
*copyc dfp$queue_inquiry_request
*copyc dfp$recover_job
*copyc dfp$release_task_queue_entry
*copyc dfp$set_invalid_family_index
*copyc dfp$set_job_validation_change
*copyc dfp$touch_pages
*copyc dfp$validate_rpc_status
*copyc dfp$word_boundary
*copyc dfv$file_server_debug_enabled
*copyc dfv$job_recovery_rpc_requests
*copyc dfv$p_queue_interface_directory
*copyc dfv$procedure_address_list
*copyc dfv$send_command_and_data_flags
*copyc dfv$send_command_flags
*copyc dfv$send_ready_for_data_flags
*copyc i#current_sequence_position
*copyc mmp$free_pages
*copyc ofp$display_status_message
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$begin_subsystem_activity
*copyc osp$disestablish_cond_handler
*copyc osp$end_subsystem_activity
*copyc osp$establish_condition_handler
*copyc osp$log_job_recovery_message
*copyc osp$recoverable_system_error
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$verify_system_privilege
*copyc pmh$continue_to_cause
*copyc pmh$establish_condition_handler
*copyc pmp$continue_to_cause
*copyc pmp$delay
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$continue_to_cause
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_job_names
*copyc pmp$long_term_wait
*copyc syp$hang_if_job_jrt_set
*copyc syp$pop_inhibit_job_recovery
*copyc syp$push_inhibit_job_recovery
?? TITLE := '  Global Declarations Declared by this module', EJECT ??
 VAR
   dfv$recovery_task: [XDCL, oss$task_private] boolean := FALSE;
?? TITLE := ' [XDCL, #GATE] dfp$begin_remote_procedure_call', EJECT ??
*copyc dfh$begin_remote_procedure_call
?? EJECT ??
  PROCEDURE [XDCL, #GATE] dfp$begin_remote_procedure_call
    (    server_location: dft$server_location;
         allowed_when_server_deactivated: boolean;
     VAR queue_entry_location: dft$rpc_queue_entry_location;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR p_send_data: dft$p_send_data;
     VAR status: ost$status);


{ PURPOSE:
{   This condition handler is used around the code that is reserving queue entries to the server in
{   the case of job recovery.  The file server queues are kept in server wired and the queue definition
{   is not recovered.  If the job is recovered while it is doing dfp$begin_remote_procedure_call
{   the condition handler will perform a non-local exit with an abnormal status of
{   DFE$SERVER_NOT_ACTIVE - almost all callers are prepared for this.
{
    PROCEDURE begin_rpc_job_rec_cond_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        display_status: ost$status;

      IF (condition.selector = pmc$user_defined_condition) AND
            (condition.user_condition_name = 'OSC$JOB_RECOVERY') THEN
        IF subsystem_activity_began THEN
          osp$end_subsystem_activity;
        IFEND;
        IF dfv$file_server_debug_enabled THEN
          display_trace_back;
        IFEND;
        osp$log_job_recovery_message (
              ' Job recovery rollback dfp$begin_remote_procedure_call',
              display_status);
        osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_active,
              ' job recovery rollback - begin_rpc  ', status);
        IF dfv$file_server_debug_enabled THEN
          display_trace_back;
        IFEND;
        EXIT dfp$begin_remote_procedure_call;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND begin_rpc_job_rec_cond_handler;


    VAR
      caller_id: ost$caller_identifier,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_cpu_queue_header: ^dft$cpu_queue_header,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_send_buffer_header: ^dft$buffer_header,
      p_send_rpc_buffer_header: ^dft$rpc_buffer_header,
      queue_entry_loc_int: dft$rpc_queue_entry_loc_int,
      subsystem_activity_began: boolean;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, osk$m * $INTEGER (allowed_when_server_deactivated),
          dfk$begin_remote_procedure_call);
    #CALLER_ID (caller_id);
    IF caller_id.ring > osc$tsrv_ring THEN
      osp$set_status_abnormal ('PM', pme$insufficient_privilege, '', status);
      RETURN;
    IFEND;
    subsystem_activity_began := FALSE;
    #SPOIL (subsystem_activity_began);

    osp$establish_condition_handler (^begin_rpc_job_rec_cond_handler, FALSE);
    locate_server (server_location, p_queue_interface_table, queue_entry_loc_int, status);
    IF status.normal THEN
      p_cpu_queue_header := ^p_queue_interface_table^.queue_directory.cpu_queue_pva_directory
           [queue_entry_loc_int.queue_index].p_cpu_queue^.queue_header;
     IF (p_cpu_queue_header^.partner_status.server_state = dfc$active) OR
       ((p_cpu_queue_header^.partner_status.server_state = dfc$deactivated) AND
       allowed_when_server_deactivated AND NOT p_cpu_queue_header^.partner_status.deactivate_complete) OR
       ((p_cpu_queue_header^.partner_status.server_state = dfc$recovering) AND dfv$recovery_task) THEN
        osp$begin_subsystem_activity;
        subsystem_activity_began := TRUE;
        #SPOIL (subsystem_activity_began);
      ELSE
        dfp$set_terminated_status (p_queue_interface_table, queue_entry_loc_int.queue_index, status);
      IFEND;
      IF status.normal THEN
        dfp$get_task_queue_entry (p_queue_interface_table, queue_entry_loc_int.queue_index,
              queue_entry_loc_int.queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry, status);
        IF status.normal THEN
          {  Construct pointer to  user part of send buffer area .
          syp$hang_if_job_jrt_set (dfc$tjr_begin_rpc);
          RESET p_cpu_queue_entry^.p_send_buffer;
          NEXT p_send_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
          NEXT p_send_rpc_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
          NEXT p_send_to_server_params IN p_cpu_queue_entry^.p_send_buffer;
          RESET p_send_to_server_params;
          RESET p_cpu_queue_entry^.p_send_data;
          p_send_data := p_cpu_queue_entry^.p_send_data;
          p_cpu_queue_entry^.maximum_data_sent := 0;
          p_cpu_queue_entry^.maximum_data_received := 0;
          pmp$get_executing_task_gtid (p_cpu_queue_entry^.global_task_id);
          dfp$convert_qel_int_to_ext (queue_entry_loc_int, queue_entry_location);
        ELSE
          osp$end_subsystem_activity;
          subsystem_activity_began := FALSE;
          #SPOIL (subsystem_activity_began);
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      syp$push_inhibit_job_recovery;
      #KEYPOINT (osk$exit, osk$m * queue_entry_loc_int.queue_entry_index, dfk$begin_remote_procedure_call);
    ELSE
      #KEYPOINT (osk$exit, 0, dfk$begin_remote_procedure_call);
    IFEND;
  PROCEND dfp$begin_remote_procedure_call;
?? TITLE := ' [XDCL, #GATE] dfp$end_remote_procedure_call ', EJECT ??
*copyc dfh$end_remote_procedure_call

  PROCEDURE [XDCL, #GATE] dfp$end_remote_procedure_call
    (    queue_entry_location: dft$rpc_queue_entry_location;
     VAR status: ost$status);


    VAR
      caller_id: ost$caller_identifier,
      ignore_status: ost$status,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_entry_loc_int: dft$rpc_queue_entry_loc_int;

    status.normal := TRUE;
    dfp$convert_qel_ext_to_int (queue_entry_location, queue_entry_loc_int);
    #KEYPOINT (osk$entry, osk$m * queue_entry_loc_int.queue_entry_index, dfk$end_remote_procedure_call);
    #CALLER_ID (caller_id);
    IF caller_id.ring > osc$tsrv_ring THEN
      osp$set_status_abnormal ('PM', pme$insufficient_privilege, '', status);
      RETURN;
    IFEND;
    dfp$validate_queue_entry_loc (queue_entry_loc_int, 'dfp$end_remote_procedure_call',
          p_queue_interface_table, status);
    IF status.normal THEN

      dfp$fetch_queue_entry (p_queue_interface_table, queue_entry_loc_int.queue_index,
            queue_entry_loc_int.queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry);

      end_remote_procedure_call (p_queue_interface_table, queue_entry_loc_int.queue_index,
              queue_entry_loc_int.queue_entry_index, p_cpu_queue_entry, status);
    ELSEIF (status.condition = dfe$server_has_terminated) OR
           (status.condition = dfe$server_not_active) THEN
      { The server has terminated since the time of the begin remote procedure call.
      { Allow the caller to continue and recover in this case.
      { Termination should have cleaned up any wired pages.
      syp$pop_inhibit_job_recovery;
      osp$end_subsystem_activity;
      status.normal := TRUE;
    IFEND;
    #KEYPOINT (osk$exit, 0, dfk$end_remote_procedure_call);

  PROCEND dfp$end_remote_procedure_call;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] dfp$find_extended_rpc_ordinal', EJECT ??

{ PURPOSE:
{   The purpose of this request is to return the RPC address list
{   ordinal of the specified remote application procedure.

  PROCEDURE [XDCL] dfp$find_extended_rpc_ordinal
    (    application_name: ost$name;
         procedure_name: pmt$program_name;
         p_cpu_queue: ^dft$cpu_queue;
     VAR extended_rpc_ordinal: dft$procedure_address_ordinal;
     VAR status: ost$status);

    VAR
      application_index: dft$number_of_applications,
      application_found: boolean,
      name_is_valid: boolean,
      procedure_found: boolean,
      procedure_index: dft$total_number_of_app_procs,
      procedure_index_offset: dft$total_number_of_app_procs,
      p_remote_application_info: ^dft$remote_application_info,
      valid_application_name: ost$name,
      valid_procedure_name: ost$name;

    status.normal := TRUE;

    application_index := 0;
    application_found := FALSE;
    procedure_found := FALSE;
    p_remote_application_info := p_cpu_queue^.queue_header.p_remote_application_info;

    clp$validate_name (application_name, valid_application_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$application_not_known,
            application_name, status);
      RETURN;
    IFEND;

  /match_application_name/
    WHILE p_remote_application_info <> NIL DO
      application_index := application_index + 1;
      IF p_remote_application_info^.application_name = valid_application_name THEN
        application_found := TRUE;
        EXIT /match_application_name/;
      IFEND;
      p_remote_application_info := p_remote_application_info^.next_p_application_info;
    WHILEND /match_application_name/;

    IF NOT application_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$application_not_known,
            application_name, status);
      RETURN;
    IFEND;
    IF p_cpu_queue^.queue_header.p_application_rpc_list = NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$procedure_not_known,
            procedure_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, application_name, status);
      RETURN;
    IFEND;

    clp$validate_name (procedure_name, valid_procedure_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$procedure_not_known,
            procedure_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, application_name, status);
      RETURN;
    IFEND;
    extended_rpc_ordinal := p_remote_application_info^.first_procedure_rpc_ordinal;
    procedure_index_offset := $INTEGER (extended_rpc_ordinal) - $INTEGER (dfc$last_system_procedure);

  /match_procedure_name/
    FOR procedure_index := procedure_index_offset TO (procedure_index_offset +
          p_remote_application_info^.number_of_procedures - 1) DO
      IF p_cpu_queue^.queue_header.p_application_rpc_list^ [procedure_index].debug_display =
            valid_procedure_name THEN
        procedure_found := TRUE;
        EXIT /match_procedure_name/;
      IFEND;
      extended_rpc_ordinal := SUCC (extended_rpc_ordinal);
    FOREND /match_procedure_name/;
    IF NOT procedure_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$procedure_not_known,
            procedure_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, application_name, status);
    IFEND;
  PROCEND dfp$find_extended_rpc_ordinal;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] dfp$send_application_rpc ', EJECT ??
*copy dfh$send_application_rpc

  PROCEDURE [XDCL, #GATE] dfp$send_application_rpc
    (    queue_entry_location: dft$rpc_queue_entry_location;
         application_name: ost$name;
         procedure_name: pmt$program_name;
         send_to_server_params_size: dft$send_parameter_size;
         data_size_to_send_to_server: dft$send_data_size;
     VAR p_receive_from_server_params: dft$p_receive_parameters;
     VAR p_receive_data: dft$p_receive_data;
     VAR status: ost$status);

    VAR
      p_cpu_queue: ^dft$cpu_queue,
      p_queue_interface_table: dft$p_queue_interface_table,
      procedure_ordinal: dft$procedure_address_ordinal,
      queue_entry_loc_int: dft$rpc_queue_entry_loc_int;

    dfp$convert_qel_ext_to_int (queue_entry_location, queue_entry_loc_int);
    dfp$validate_queue_entry_loc (queue_entry_loc_int, 'dfp$send_application_rpc', p_queue_interface_table,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_cpu_queue := p_queue_interface_table^.queue_directory.
          cpu_queue_pva_directory [queue_entry_loc_int.queue_index].p_cpu_queue;

    dfp$find_extended_rpc_ordinal (application_name, procedure_name, p_cpu_queue, procedure_ordinal, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$send_remote_procedure_call (queue_entry_location, procedure_ordinal, send_to_server_params_size,
          data_size_to_send_to_server, p_receive_from_server_params, p_receive_data, status);

  PROCEND dfp$send_application_rpc;
?? TITLE := ' [XDCL, #GATE] dfp$send_remote_procedure_call ', EJECT ??
*copyc dfh$send_remote_procedure_call
?? EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$send_remote_procedure_call
    (    queue_entry_location: dft$rpc_queue_entry_location;
         procedure_ordinal: dft$procedure_address_ordinal;
         send_to_server_params_size: dft$send_parameter_size;
         data_size_to_send_to_server: dft$send_data_size;
     VAR p_receive_from_server_params: dft$p_receive_parameters;
     VAR p_receive_data: dft$p_receive_data;
     VAR status: ost$status);


    PROCEDURE send_rpc_job_rec_cond_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        display_string_length: integer,
        display_string: string (90),
        display_status: ost$status;

      IF (condition.selector = pmc$user_defined_condition) AND
            (condition.user_condition_name = 'OSC$JOB_RECOVERY') THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_active,
              ' job recovery rollback - send_rpc ', status);
        STRINGREP (display_string, display_string_length,
             ' Job recovery rollback dfp$send_remote_procedure_call ',
              current_rpc_entry.debug_display);
        osp$log_job_recovery_message (display_string (1, display_string_length),
              display_status);
        { Must push here since in the end_rpc will try to pop it.
        syp$push_inhibit_job_recovery;
        IF dfv$file_server_debug_enabled THEN
          display_trace_back;
        IFEND;
        EXIT dfp$send_remote_procedure_call;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND send_rpc_job_rec_cond_handler;


    VAR
      allow_terminate_break: boolean,
      allow_pause_break: boolean,
      caller_id: ost$caller_identifier,
      client_job_id: dft$client_job_id,
      current_rpc_entry: dft$rpc_procedure_address_entry,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_entry_loc_int: dft$rpc_queue_entry_loc_int,
      recovery_condition_enabled: boolean;

    #KEYPOINT (osk$entry, osk$m * $INTEGER (procedure_ordinal), dfk$send_remote_procedure_call);
    IF (send_to_server_params_size > dfc$maximum_user_buffer_area) OR
          (send_to_server_params_size < 0) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$out_of_range_value,
            'SEND_TO_SERVER_PARAMS_SIZE', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            'passed to DFP$SEND_REMOTE_PROCEDURE_CALL',  status);
      osp$append_status_integer (osc$status_parameter_delimiter, send_to_server_params_size,
            10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, 0, 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, dfc$maximum_user_buffer_area,
            10, FALSE, status);
      RETURN;
    IFEND;
    IF (data_size_to_send_to_server > dfc$maximum_user_data_area) OR
          (data_size_to_send_to_server < 0) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$out_of_range_value,
           'DATA_SIZE_TO_SEND_TO_SERVER', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            'passed to DFP$SEND_REMOTE_PROCEDURE_CALL',  status);
      osp$append_status_integer (osc$status_parameter_delimiter, data_size_to_send_to_server,
            10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, 0, 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, dfc$maximum_user_data_area,
            10, FALSE, status);
      RETURN;
    IFEND;

    dfp$convert_qel_ext_to_int (queue_entry_location, queue_entry_loc_int);
    dfp$validate_queue_entry_loc (queue_entry_loc_int, 'dfp$send_remote_procedure_call',
          p_queue_interface_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF procedure_ordinal <= dfc$last_system_procedure THEN
      osp$verify_system_privilege;
      current_rpc_entry := dfv$procedure_address_list [procedure_ordinal];
      allow_terminate_break := FALSE;
      allow_pause_break := FALSE;
    ELSE
      #CALLER_ID (caller_id);
      IF caller_id.ring > osc$tsrv_ring THEN
        osp$set_status_abnormal ('PM', pme$insufficient_privilege, '', status);
        RETURN;
      IFEND;
      current_rpc_entry := p_queue_interface_table^.queue_directory.
            cpu_queue_pva_directory [queue_entry_loc_int.queue_index].p_cpu_queue^.queue_header.
            p_application_rpc_list^ [$INTEGER (procedure_ordinal) - $INTEGER (dfc$last_system_procedure)];
      allow_terminate_break := current_rpc_entry.allow_terminate_break;
      allow_pause_break := current_rpc_entry.allow_pause_break;
    IFEND;
    recovery_condition_enabled := FALSE;
    IF status.normal THEN
      dfp$fetch_queue_entry (p_queue_interface_table, queue_entry_loc_int.queue_index,
            queue_entry_loc_int.queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry);
      IF (procedure_ordinal <> dfc$establish_client_job) AND
         (procedure_ordinal <> dfc$rpc_jl_general_purpose) AND
         (procedure_ordinal <> dfc$rpc_jl_terminate_job) THEN
        dfp$check_job_server (queue_entry_location, queue_entry_loc_int, send_to_server_params_size,
              (procedure_ordinal IN dfv$job_recovery_rpc_requests),
               { Force reconnecting = } FALSE, client_job_id, status);
        IF NOT status.normal AND (status.condition = dfe$job_needs_recovery) THEN
          CASE current_rpc_entry.job_recovery_location OF
          = dfc$job_rec_started_by_caller =
            { Return dfe$job_needs_recovery to allow the caller to initiate the recovery
            { at an appropriate place.
          = dfc$job_rec_in_unavailable_wait =
            { Return the status of dfe$server_not_active to allow the recovery
            { to be performed as a result of waiting for unavailable server.
            osp$set_status_condition (dfe$server_not_active, status);
          = dfc$job_rec_immediately =
            { This assumes that there is a spare queue entry, since the
            { dfp$recover_job will assign and release queue entries.  There
            { is the possibility of deadlock here.
            dfp$recover_job (queue_entry_loc_int.server_mainframe_id, status);
          ELSE
          CASEND;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      IF (current_rpc_entry.request_restartable =
            dfc$request_restartable) AND
         (procedure_ordinal <> dfc$change_job_validation_info) THEN
        { If the request is restartable we allow recovery to occur during this process.
        osp$establish_condition_handler (^send_rpc_job_rec_cond_handler, FALSE);
        syp$pop_inhibit_job_recovery;
        recovery_condition_enabled:= TRUE;
      IFEND;

    /repeat_request_on_retry/
      REPEAT
        IF NOT status.normal AND (status.condition = dfe$restart_server_request) AND
              dfv$file_server_debug_enabled THEN
          display_integer (' CLIENT RESTARTING REQUEST FOR ', queue_entry_loc_int.queue_entry_index);
        IFEND;
        send_remote_procedure_call (p_queue_interface_table, allow_terminate_break, allow_pause_break,
              queue_entry_loc_int.queue_index, queue_entry_loc_int.queue_entry_index, p_cpu_queue_entry,
              p_driver_queue_entry, client_job_id, procedure_ordinal, send_to_server_params_size,
              data_size_to_send_to_server, p_receive_from_server_params, p_receive_data, status);
        IF NOT status.normal AND (status.condition = dfe$bad_client_job_id) AND
           NOT (procedure_ordinal IN dfv$job_recovery_rpc_requests) THEN
          dfp$check_job_server (queue_entry_location, queue_entry_loc_int, send_to_server_params_size,
                (procedure_ordinal IN dfv$job_recovery_rpc_requests),
                 { Force reconnecting = } TRUE, client_job_id, status);
          IF status.normal THEN
            CYCLE /repeat_request_on_retry/;
          IFEND;
        IFEND;
      UNTIL status.normal OR (status.condition <> dfe$restart_server_request);
    IFEND;
    IF status.normal THEN
      IF data_size_to_send_to_server > p_cpu_queue_entry^.maximum_data_sent THEN
        p_cpu_queue_entry^.maximum_data_sent := data_size_to_send_to_server;
      IFEND;
      IF (p_receive_data <> NIL) AND (#SIZE (p_receive_data^) > p_cpu_queue_entry^.maximum_data_received) THEN
        p_cpu_queue_entry^.maximum_data_received := #SIZE (p_receive_data^);
      IFEND;
      IF procedure_ordinal = dfc$get_validation_info THEN
        dfp$set_job_validation_change;
      IFEND;
    IFEND;
    IF recovery_condition_enabled THEN
      syp$push_inhibit_job_recovery;
    IFEND;
    #KEYPOINT (osk$exit, 0, dfk$send_remote_procedure_call);

  PROCEND dfp$send_remote_procedure_call;
?? TITLE := ' [XDCL, INLINE] dfp$validate_queue_entry_loc ', EJECT ??

  PROCEDURE [XDCL,INLINE] dfp$validate_queue_entry_loc
    (    queue_entry_loc_int: dft$rpc_queue_entry_loc_int;
         request: string ( * <= osc$max_name_size);
     VAR p_queue_interface_table: dft$p_queue_interface_table;
     VAR status: ost$status);

    VAR
      global_task_id: ost$global_task_id,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      queue_entry_assigned: boolean;

    status.normal := TRUE;

    IF (dfv$p_queue_interface_directory = NIL) OR (queue_entry_loc_int.queue_directory_index >
          UPPERBOUND (dfv$p_queue_interface_directory^)) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated, 'Nil queue directory',
            status);
      RETURN;
    IFEND;
    dfp$get_qit_p_from_direct_index (queue_entry_loc_int.queue_directory_index, p_queue_interface_table);

    IF p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_entry_loc_int.queue_index].
          p_cpu_queue^.queue_header.destination_mainframe_id <> queue_entry_loc_int.server_mainframe_id THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_queue_entry_id, 'mismatched mainframe id',
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, request, status);
      RETURN;
    IFEND;

    { Give server terminated status precedence to free entry, since termination
    { will free all assigned queue entries.  This is also true in the
    { awaiting recovery state.
    IF (p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_entry_loc_int.queue_index].
          p_cpu_queue^.queue_header.partner_status.server_state = dfc$terminated) OR
          (p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_entry_loc_int.queue_index].
          p_cpu_queue^.queue_header.partner_status.server_state = dfc$awaiting_recovery) THEN
      dfp$set_terminated_status (p_queue_interface_table, queue_entry_loc_int.queue_index, status);
      RETURN;
    IFEND;

    dfp$check_queue_entry_assigned (queue_entry_loc_int.queue_entry_index,
          p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_entry_loc_int.queue_index].
          p_cpu_queue^.queue_header.queue_entry_assignment_table, queue_entry_assigned);
    IF queue_entry_assigned THEN
      dfp$fetch_queue_entry (p_queue_interface_table, queue_entry_loc_int.queue_index,
            queue_entry_loc_int.queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry);
      pmp$get_executing_task_gtid (global_task_id);
      IF global_task_id <> p_cpu_queue_entry^.global_task_id THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_queue_entry_id, 'entry not assigned',
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, request, status);
        RETURN;
      IFEND;
    ELSE
      osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_queue_entry_id, 'entry not assigned', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, request, status);
      RETURN;
    IFEND;
  PROCEND dfp$validate_queue_entry_loc;
?? TITLE := ' end_remote_procedure_call', EJECT ??
  PROCEDURE end_remote_procedure_call
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status;

    status.normal := TRUE;
    IF p_cpu_queue_entry^.maximum_data_sent > 0 THEN
      mmp$free_pages (p_cpu_queue_entry^.p_send_data, p_cpu_queue_entry^.maximum_data_sent, osc$wait,
            ignore_status);
    IFEND;
    IF p_cpu_queue_entry^.maximum_data_received > 0 THEN
      mmp$free_pages (p_cpu_queue_entry^.p_receive_data, p_cpu_queue_entry^.maximum_data_received, osc$wait,
            ignore_status);
    IFEND;

    syp$hang_if_job_jrt_set (dfc$tjr_end_rpc);
    dfp$release_task_queue_entry (p_queue_interface_table, queue_index, queue_entry_index, status);
    syp$pop_inhibit_job_recovery;
    osp$end_subsystem_activity;

  PROCEND end_remote_procedure_call;
?? TITLE := ' initialize_rpc_send ', EJECT ??

{  This procedure initializes the standard send buffer, the remote procedure
{  call buffer header, and the cpu queue entry.
{

  PROCEDURE initialize_rpc_send
    (    client_job_id: dft$client_job_id;
         procedure_ordinal: dft$procedure_address_ordinal;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_send_buffer_header: ^dft$buffer_header;
         p_send_rpc_buffer_header: ^dft$rpc_buffer_header;
         user_parameter_size: dft$send_parameter_size;
         data_size_to_send: dft$send_data_size;
         p_cpu_queue: ^dft$cpu_queue);

    VAR
      current_rpc_entry: dft$rpc_procedure_address_entry,
      ignore_status: ost$status,
      user_supplied_name: jmt$user_supplied_name;

    { Initialize standard buffer header
    p_send_buffer_header^.version := dfc$rpc_request_buffer_version;
    p_send_buffer_header^.remote_processor := procedure_ordinal;
    p_send_buffer_header^.data_length_sent := 0;

    { Initialize remote procedure call buffer header
    IF procedure_ordinal <= dfc$last_system_procedure THEN
      current_rpc_entry := dfv$procedure_address_list [procedure_ordinal];
    ELSE
      current_rpc_entry := p_cpu_queue^.queue_header.p_application_rpc_list^
            [$INTEGER (procedure_ordinal) - $INTEGER (dfc$last_system_procedure)];
    IFEND;
    pmp$get_job_names (user_supplied_name, p_send_rpc_buffer_header^.system_supplied_job_name, ignore_status);
    p_send_rpc_buffer_header^.procedure_version := current_rpc_entry.procedure_version;
    p_send_rpc_buffer_header^.procedure_name_checksum := current_rpc_entry.procedure_name_checksum;
    p_send_rpc_buffer_header^.procedure_class := current_rpc_entry.class;
    IF current_rpc_entry.class = dfc$permanent_file_call THEN
      p_send_rpc_buffer_header^.client_job_id := client_job_id;
      p_send_rpc_buffer_header^.system_administrator := avp$system_administrator ();
      p_send_rpc_buffer_header^.family_administrator := avp$family_administrator ();
    IFEND;

    { Initialize rpc progress record
    p_send_rpc_buffer_header^.call_progress.transaction_per_rpc_request := 0;
    p_send_rpc_buffer_header^.call_progress.total_data_sent := 0;
    p_send_rpc_buffer_header^.call_progress.total_data_received := 0;

    p_send_rpc_buffer_header^.call_progress.user_buffer_length_sent := user_parameter_size;
    p_send_rpc_buffer_header^.call_progress.user_data_length_sent := data_size_to_send;

    { Initialize cpu queue entry
    p_cpu_queue_entry^.call_progress := p_send_rpc_buffer_header^.call_progress;
    p_cpu_queue_entry^.total_data_to_receive := 0;
  PROCEND initialize_rpc_send;
?? TITLE := ' locate_server ', EJECT ??
{
{  This procedure locates the server mainframe, and initializes the queue
{  entry location.  The queue entry index field is not initialized by this
{  procedure.
{

  PROCEDURE locate_server
    (    server_location: dft$server_location;
     VAR p_queue_interface_table: dft$p_queue_interface_table;
     VAR queue_entry_loc_int: dft$rpc_queue_entry_loc_int;
     VAR status: ost$status);

    VAR
      family: ost$family_name,
      family_found: boolean,
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      served_family_table_index: dft$served_family_table_index,
      server_state: dft$server_state,
      server_to_client: boolean;

    status.normal := TRUE;
    CASE server_location.server_location_selector OF
    = dfc$family_name =
      dfp$locate_served_family (server_location.family_name, family_found, served_family_table_index,
            queue_entry_loc_int.server_mainframe_id, p_queue_interface_table, queue_entry_loc_int.queue_index,
            server_state);
      IF NOT family_found THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$family_not_served, server_location.family_name,
              status);
        RETURN;
      IFEND;
      IF (p_queue_interface_table = NIL) THEN
        { Access to a recovering server is occuring prior to the definition of the server.
        { Determine the state of the server.
        dfp$fetch_served_family_state  (served_family_table_index, server_state);
        IF server_state = dfc$awaiting_recovery THEN
         { Return the status of dfe$server_not_active to allow the recovery
         { to be performed as a result of waiting for unavailable server.
           osp$set_status_abnormal (dfc$file_server_id,
              dfe$server_not_active, server_location.family_name, status);
         ELSE
           osp$set_status_abnormal (dfc$file_server_id,
              dfe$server_has_terminated, server_location.family_name, status);
        IFEND;
      IFEND;
    = dfc$mainframe_id =
      server_to_client := FALSE;
      dfp$find_mainframe_id (server_location.server_mainframe, server_to_client, mainframe_found,
            p_queue_interface_table, p_cpu_queue, queue_entry_loc_int.queue_index,
            p_q_interface_directory_entry);
      IF mainframe_found THEN
        queue_entry_loc_int.server_mainframe_id := p_cpu_queue^.queue_header.destination_mainframe_id;
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server,
              server_location.server_mainframe, status);
      IFEND;

    = dfc$served_family_table_index =
      osp$verify_system_privilege;
      dfp$fetch_served_family_info (server_location.served_family_table_index, family,
            queue_entry_loc_int.server_mainframe_id, p_queue_interface_table, queue_entry_loc_int.queue_index,
            family_found);
      IF NOT family_found THEN
        dfp$set_invalid_family_index (server_location.served_family_table_index,
              'DFP$BEGIN_REMOTE_PROCEDURE_CALL', status);
        RETURN;
      IFEND;
      dfp$fetch_served_family_state  (server_location.served_family_table_index, server_state);
      IF (p_queue_interface_table = NIL) OR (server_state = dfc$deleted) THEN
        { Access to a recovering server is occuring prior to the definition of the server.
        { Determine the state of the server.
        IF server_state = dfc$awaiting_recovery THEN
         { Return the status of dfe$server_not_active to allow the recovery
         { to be performed as a result of waiting for unavailable server.
           osp$set_status_abnormal (dfc$file_server_id,
              dfe$server_not_active, family, status);
         ELSE
           osp$set_status_abnormal (dfc$file_server_id,
              dfe$server_has_terminated, family, status);
        IFEND;
        RETURN;
      IFEND;

    ELSE
      osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_server_locator, '', status);
    CASEND;

    IF status.normal THEN
      { This is a temporary kludge until queue directory index is added to
      { Served family table, and returned by the above interfaces.
      { With only one server this interface is not to slow.
      dfp$get_queue_directory_index (p_queue_interface_table, queue_entry_loc_int.queue_directory_index);
    IFEND;
  PROCEND locate_server;
?? TITLE := ' receive_data_from_server ', EJECT ??
{
{   This procedure makes repeated requests to the server to receive
{ any data that is being sent. IF no data was sent to the server, the
{ initial
{ four pages of data is prompted for.  After the initial data is received,
{ the remaining data is received with a new request. The user part of the
{ buffer area is not received until the last data pages are received.
{

  PROCEDURE receive_data_from_server
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         p_send_buffer_header: ^dft$buffer_header;
         p_send_rpc_buffer_header: ^dft$rpc_buffer_header;
     VAR p_receive_rpc_buffer_header: ^dft$rpc_response_buffer_header;
     VAR p_receive_data: dft$p_receive_data;
     VAR status: ost$status);

    VAR
      data_received_this_request: dft$send_data_size,
      p_mtr_status: ^syt$monitor_status,
      p_os_status: ^ost$status,
      p_receive_buffer_header: ^dft$buffer_header,
      page_count: ost$non_negative_integers,
      remaining_data_to_receive: dft$send_data_size;

    status.normal := TRUE;
    RESET p_cpu_queue_entry^.p_receive_buffer;
    NEXT p_receive_buffer_header IN p_cpu_queue_entry^.p_receive_buffer;
    NEXT p_mtr_status IN p_cpu_queue_entry^.p_receive_buffer;

    remaining_data_to_receive := p_cpu_queue_entry^.total_data_to_receive;

    dfp$touch_pages (p_cpu_queue_entry^.p_receive_data, p_cpu_queue_entry^.total_data_to_receive, page_count);

    IF (p_cpu_queue_entry^.call_progress.total_data_sent = 0) THEN
      {No data was sent with the request, prompt for the initial data from esm.
      IF remaining_data_to_receive > p_queue_interface_table^.maximum_data_bytes THEN
        { All the data won't fit in this request
        data_received_this_request := p_queue_interface_table^.maximum_data_bytes;
        remaining_data_to_receive := remaining_data_to_receive - data_received_this_request;
      ELSE { Last receive request
        data_received_this_request := remaining_data_to_receive;
        remaining_data_to_receive := 0;
      IFEND;
      dfp$initialize_rma_list (p_cpu_queue_entry^.p_receive_data, { Offset = } 0, data_received_this_request,
            p_cpu_queue_entry^.p_data_rma_list, p_driver_queue_entry^.data_descriptor, status);
      p_driver_queue_entry^.flags := dfv$send_ready_for_data_flags;
      #SPOIL (p_driver_queue_entry^);
      dfp$queue_client_task_request (p_queue_interface_table, queue_index, queue_entry_index, status);
      IF NOT status.normal THEN
        dfp$clear_driver_flags (p_driver_queue_entry);
        RETURN;
      IFEND;
      #SPOIL (p_driver_queue_entry^);
      dfp$await_subsystem_action (p_driver_queue_entry);
      p_cpu_queue_entry^.call_progress.total_data_received :=
            (p_driver_queue_entry^.data_descriptor.actual_length DIV 8) * osv$page_size;
      dfp$clear_driver_flags (p_driver_queue_entry);
      NEXT p_receive_rpc_buffer_header IN p_cpu_queue_entry^.p_receive_buffer;
    IFEND;

{ Receive any remaining data by a new request
    p_send_buffer_header^.buffer_length_sent := dfp$word_boundary
          (#SIZE (dft$buffer_header) + #SIZE (dft$rpc_buffer_header));
    p_send_buffer_header^.data_length_sent := 0;
    p_driver_queue_entry^.send_buffer_descriptor.actual_length := p_send_buffer_header^.buffer_length_sent;

  /receive_all_data/
    WHILE (remaining_data_to_receive > 0) AND (status.normal) DO
      IF remaining_data_to_receive > p_queue_interface_table^.maximum_data_bytes THEN
        { All the data won't fit in this request
        data_received_this_request := p_queue_interface_table^.maximum_data_bytes;
        remaining_data_to_receive := remaining_data_to_receive - data_received_this_request;

      ELSE { Last receive request
        data_received_this_request := remaining_data_to_receive;
        remaining_data_to_receive := 0;
      IFEND;
      dfp$initialize_rma_list (p_cpu_queue_entry^.p_receive_data,
            { Offset = } p_cpu_queue_entry^.call_progress.total_data_received, data_received_this_request,
            p_cpu_queue_entry^.p_data_rma_list, p_driver_queue_entry^.data_descriptor, status);

      { Initialize cpu queue entry
      p_cpu_queue_entry^.retransmission_count := 0;
      p_cpu_queue_entry^.transaction_count := p_cpu_queue_entry^.transaction_count + 1;
      p_send_buffer_header^.transaction_count := p_cpu_queue_entry^.transaction_count;
      p_cpu_queue_entry^.call_progress.transaction_per_rpc_request :=
            p_cpu_queue_entry^.call_progress.transaction_per_rpc_request + 1;
      { Initialize rpc progress record
      p_send_rpc_buffer_header^.call_progress := p_cpu_queue_entry^.call_progress;

      p_driver_queue_entry^.flags := dfv$send_command_flags;
      #SPOIL (p_driver_queue_entry^);
      #SPOIL (p_cpu_queue_entry^);
      dfp$queue_client_task_request (p_queue_interface_table, queue_index, queue_entry_index, status);
      IF NOT status.normal THEN
        dfp$clear_driver_flags (p_driver_queue_entry);
        RETURN;
      IFEND;
      #SPOIL (p_driver_queue_entry^);
      #SPOIL (p_cpu_queue_entry^);
      dfp$await_subsystem_action (p_driver_queue_entry);
      #SPOIL (p_driver_queue_entry^);
      #SPOIL (p_cpu_queue_entry^);
      dfp$validate_rpc_status (p_cpu_queue_entry, p_receive_rpc_buffer_header, status);
      IF NOT status.normal THEN
        dfp$clear_driver_flags (p_driver_queue_entry);
        RETURN;
      IFEND;
      p_cpu_queue_entry^.call_progress.total_data_received :=
            ((p_driver_queue_entry^.data_descriptor.actual_length DIV 8) * osv$page_size) +
            p_cpu_queue_entry^.call_progress.total_data_received;
      dfp$clear_driver_flags (p_driver_queue_entry);
    WHILEND /receive_all_data/;

    {  Build pointer to p_receive_data
    RESET p_cpu_queue_entry^.p_receive_data;
    NEXT p_receive_data: [[REP p_receive_rpc_buffer_header^.call_progress.user_data_length_sent OF cell]] IN
          p_cpu_queue_entry^.p_receive_data;

  PROCEND receive_data_from_server;
?? TITLE := ' send_remote_procedure_call ', EJECT ??

  PROCEDURE send_remote_procedure_call
    (    p_queue_interface_table: dft$p_queue_interface_table;
         allow_terminate_break: boolean;
         allow_pause_break: boolean;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         client_job_id: dft$client_job_id;
         procedure_ordinal: dft$procedure_address_ordinal;
         send_to_server_params_size: dft$send_parameter_size;
         data_size_to_send_to_server: dft$send_data_size;
     VAR p_receive_from_server_params: dft$p_receive_parameters;
     VAR p_receive_data: dft$p_receive_data;
     VAR status: ost$status);

    VAR
      p_receive_rpc_buffer_header: ^dft$rpc_response_buffer_header,
      p_send_buffer_header: ^dft$buffer_header,
      p_send_rpc_buffer_header: ^dft$rpc_buffer_header;

    p_receive_from_server_params := NIL;
    p_receive_data := NIL;
    RESET p_cpu_queue_entry^.p_send_buffer;
    NEXT p_send_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
    NEXT p_send_rpc_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
    initialize_rpc_send (client_job_id, procedure_ordinal, p_cpu_queue_entry, p_send_buffer_header,
          p_send_rpc_buffer_header, send_to_server_params_size, data_size_to_send_to_server,
          p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].p_cpu_queue);
    send_request_to_server (p_queue_interface_table, allow_terminate_break, allow_pause_break, queue_index,
          queue_entry_index, p_cpu_queue_entry, p_driver_queue_entry, send_to_server_params_size,
          data_size_to_send_to_server, p_send_buffer_header, p_send_rpc_buffer_header,
          p_receive_rpc_buffer_header, status);
    IF status.normal THEN
      IF (p_cpu_queue_entry^.total_data_to_receive > 0) THEN
        receive_data_from_server (p_queue_interface_table, queue_index, queue_entry_index, p_cpu_queue_entry,
              p_driver_queue_entry, p_send_buffer_header, p_send_rpc_buffer_header,
              p_receive_rpc_buffer_header, p_receive_data, status);
      IFEND;
      IF status.normal THEN
        IF p_receive_rpc_buffer_header^.call_progress.user_buffer_length_sent > 0 THEN
          NEXT p_receive_from_server_params: [[REP p_receive_rpc_buffer_header^.call_progress.
                user_buffer_length_sent OF cell]] IN p_cpu_queue_entry^.p_receive_buffer;
        IFEND;
      IFEND;
    IFEND;
  PROCEND send_remote_procedure_call;
?? TITLE := ' send_request_to_server ', EJECT ??

{  This procedure sends the data and buffer over to the server.  If
{  multiple requests are needed to send the data, the portion of the
{  buffer with the user parameters is not sent over till the last
{  request. Each 4 page request is a new transaction.

  PROCEDURE send_request_to_server
    (    p_queue_interface_table: dft$p_queue_interface_table;
         allow_terminate_break: boolean;
         allow_pause_break: boolean;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         send_to_server_params_size: dft$send_parameter_size;
         data_size_to_send_to_server: dft$send_data_size;
         p_send_buffer_header: ^dft$buffer_header;
         p_send_rpc_buffer_header: ^dft$rpc_buffer_header;
     VAR p_receive_rpc_buffer_header: ^dft$rpc_response_buffer_header;
     VAR status: ost$status);

    VAR
      data_send_this_request: dft$send_data_size,
      p_status_response: ^dft$status_response;

  /send_all_data/
    REPEAT

      { Determine amount of data to send.
      IF data_size_to_send_to_server = 0 THEN
        data_send_this_request := 0;
        p_driver_queue_entry^.data_descriptor.actual_length := 0;
        p_send_buffer_header^.data_length_sent := 0;
        p_send_buffer_header^.buffer_length_sent := dfp$word_boundary
              (#SIZE (dft$buffer_header) + #SIZE (dft$rpc_buffer_header) + send_to_server_params_size);
      ELSE {Data to send to server
        IF (data_size_to_send_to_server - p_cpu_queue_entry^.call_progress.total_data_sent) >
            p_queue_interface_table^.maximum_data_bytes THEN
          { All the data won't fit in this request
          data_send_this_request := p_queue_interface_table^.maximum_data_bytes;
          p_send_buffer_header^.buffer_length_sent := dfp$word_boundary
                (#SIZE (dft$buffer_header) + #SIZE (dft$rpc_buffer_header));
        ELSE { Last send request
          { Only send all of the parameters over with the final piece of data
          data_send_this_request := data_size_to_send_to_server -
                p_cpu_queue_entry^.call_progress.total_data_sent;
          p_send_buffer_header^.buffer_length_sent := dfp$word_boundary
                (#SIZE (dft$buffer_header) + #SIZE (dft$rpc_buffer_header) + send_to_server_params_size);
        IFEND;
        dfp$initialize_rma_list (p_cpu_queue_entry^.p_send_data,
              {offset = } p_cpu_queue_entry^.call_progress.total_data_sent, data_send_this_request,
              p_cpu_queue_entry^.p_data_rma_list, p_driver_queue_entry^.data_descriptor, status);
        IF NOT status.normal THEN
          { User has not touched all of the pages.
          RETURN;
        IFEND;
        p_send_buffer_header^.data_length_sent := (p_driver_queue_entry^.data_descriptor.actual_length DIV
              8) * osv$page_size;
        p_cpu_queue_entry^.call_progress.total_data_sent :=
              p_cpu_queue_entry^.call_progress.total_data_sent + p_send_buffer_header^.data_length_sent;
      IFEND;

      { Initialize cpu queue entry
      p_cpu_queue_entry^.retransmission_count := 0;
      p_cpu_queue_entry^.transaction_count := p_cpu_queue_entry^.transaction_count + 1;
      { Update call progress
      p_cpu_queue_entry^.call_progress.transaction_per_rpc_request :=
            p_cpu_queue_entry^.call_progress.transaction_per_rpc_request + 1;

      { Complete initialization standard buffer header
      p_send_buffer_header^.transaction_count := p_cpu_queue_entry^.transaction_count;
      p_send_buffer_header^.retransmission_count := 0;
      { Complete Initialization  Remote procedure call header
      p_send_rpc_buffer_header^.call_progress := p_cpu_queue_entry^.call_progress;

      p_driver_queue_entry^.send_buffer_descriptor.actual_length := p_send_buffer_header^.buffer_length_sent;
      { Set up driver flags
      IF p_send_buffer_header^.data_length_sent > 0 THEN
        p_driver_queue_entry^.flags := dfv$send_command_and_data_flags;
      ELSE
        p_driver_queue_entry^.flags := dfv$send_command_flags;
      IFEND;
      dfp$queue_client_task_request (p_queue_interface_table, queue_index, queue_entry_index, status);
      syp$hang_if_job_jrt_set (dfc$tjr_send_rpc);
      IF NOT status.normal THEN
        dfp$clear_driver_flags (p_driver_queue_entry);
        RETURN;
      IFEND;

      IF (allow_terminate_break) OR (allow_pause_break) THEN
        wait_for_application_action (p_queue_interface_table, queue_index, queue_entry_index,
              p_cpu_queue_entry, p_driver_queue_entry, status);
        IF NOT status.normal THEN {cant establish condition handler
          dfp$await_subsystem_action (p_driver_queue_entry);
        IFEND;
        status.normal := TRUE;
      ELSE
        dfp$await_subsystem_action (p_driver_queue_entry);
      IFEND;
      dfp$clear_driver_flags (p_driver_queue_entry);
      dfp$validate_rpc_status (p_cpu_queue_entry, p_receive_rpc_buffer_header, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      p_cpu_queue_entry^.total_data_to_receive := p_receive_rpc_buffer_header^.call_progress.
            user_data_length_sent;

    UNTIL (p_cpu_queue_entry^.call_progress.total_data_sent >= data_size_to_send_to_server);
  PROCEND send_request_to_server;
?? OLDTITLE ??
?? NEWTITLE := 'send_pause_break', EJECT ??

{ PURPOSE:
{   The purpose of this request is to send a pause break inquiry
{   message to the server.

  PROCEDURE send_pause_break
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry);

    VAR
      ignore_queue_request_status: dft$queue_request_status,
      ignore_status: ost$status,
      inquiry_message: dft$inquiry_message,
      inquiry_tracer: dft$inquiry_tracer;

    dfp$form_inquiry_tracer (p_cpu_queue_entry^.transaction_count, p_cpu_queue_entry^.retransmission_count,
          inquiry_tracer);
    inquiry_message.transaction_state := dfc$pause_break_signal;
    inquiry_message.inquiry_tracer := inquiry_tracer;
    ofp$display_status_message (' Sending pause break to server', ignore_status);
    dfp$queue_inquiry_request (p_queue_interface_table, queue_index, queue_entry_index, inquiry_message,
          ignore_queue_request_status);

  PROCEND send_pause_break;

?? OLDTITLE ??
?? NEWTITLE := 'send_terminate_break', EJECT ??

{ PURPOSE:
{   The purpose of this request is to send a terminate break inquiry
{   message to the server.

  PROCEDURE send_terminate_break
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry);

    VAR
      ignore_queue_request_status: dft$queue_request_status,
      ignore_status: ost$status,
      inquiry_message: dft$inquiry_message,
      inquiry_tracer: dft$inquiry_tracer;

    dfp$form_inquiry_tracer (p_cpu_queue_entry^.transaction_count, p_cpu_queue_entry^.retransmission_count,
          inquiry_tracer);
    inquiry_message.transaction_state := dfc$terminate_break_signal;
    inquiry_message.inquiry_tracer := inquiry_tracer;
    ofp$display_status_message (' Sending terminate break to server', ignore_status);
    dfp$queue_inquiry_request (p_queue_interface_table, queue_index, queue_entry_index, inquiry_message,
          ignore_queue_request_status);

  PROCEND send_terminate_break;

?? OLDTITLE ??
?? NEWTITLE := 'wait_for_application_action', EJECT ??

{ PURPOSE:
{   The purpose of this request is to allow a terminate_break condition or a pause_break condition
{   while waiting for the server to respond.

  PROCEDURE wait_for_application_action
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry;
     VAR status: ost$status);

    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler,
      ignore_status: ost$status;

?? OLDTITLE ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this request is to trap specified conditions and to
{   relay a terminate request or a pause request to the server.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF
      = ifc$interactive_condition =
        IF condition.interactive_condition = ifc$terminate_break THEN
          send_terminate_break (p_queue_interface_table, queue_index, queue_entry_index, p_cpu_queue_entry);
        ELSEIF condition.interactive_condition = ifc$pause_break THEN
          send_pause_break (p_queue_interface_table, queue_index, queue_entry_index, p_cpu_queue_entry);
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      = pmc$block_exit_processing =
        IF condition.reason <> $pmt$block_exit_reason [pmc$block_exit] THEN
          send_terminate_break (p_queue_interface_table, queue_index, queue_entry_index,
                p_cpu_queue_entry);
          REPEAT
            #SPOIL (p_driver_queue_entry^);
            pmp$delay (100, status);
            #SPOIL (p_driver_queue_entry^);
          UNTIL p_driver_queue_entry^.flags.subsystem_action;
         ofp$display_status_message ('  ', ignore_status);

          dfp$clear_driver_flags (p_driver_queue_entry);
          end_remote_procedure_call (p_queue_interface_table, queue_index, queue_entry_index,
                p_cpu_queue_entry, status);
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;
    PROCEND condition_handler;
?? OLDTITLE ??

    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];
    pmp$establish_condition_handler (established_conditions, ^condition_handler,
          ^established_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    REPEAT
      #SPOIL (p_driver_queue_entry^);
      pmp$long_term_wait (100, 100);
      #SPOIL (p_driver_queue_entry^);
    UNTIL p_driver_queue_entry^.flags.subsystem_action;

    pmp$disestablish_cond_handler (established_conditions, ignore_status);

  PROCEND wait_for_application_action;

MODEND dfm$client_remote_procedur_call;
*DECK DECK=DFM$CLONE_TASK_PROCESS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File Server: Server: clone_task_manager', EJECT ??
MODULE dfm$clone_task_process;
{
{  This module contains those processes concerned with the clone tasks.
{  This includes initiating the clone tasks, checking on the status
{  of the clone tasks and finally the processing within the clone tasks
{  themselves.
{    The purpose of the clone tasks is to process requests from the client
{  mainframe.  For permanent file requests, this means that the clone task
{  will act on behalf of the client job, and it must appear to  the permanent file manager
{  that the task is the user on the client requesting access to the permanent file.
{  For monitor requests the clone task is responsible for processing rejects
{  from monitor mode.  Normal monitor requests are processed directly by
{  monitor normally, and the monitor clone task is only activated when needed.
{
?? NEWTITLE := '  Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amp$get_segment_pointer
*copyc amt$local_file_name
*copyc clp$get_value
*copyc clp$include_command
*copyc clp$scan_parameter_list
*copyc dfd$driver_queue_types
*copyc dfd$request_package
*copyc dfe$error_condition_codes
*copyc dfi$display
*copyc dfi$console_display
*copyc dfi$log_display
*copyc dfk$keypoints
*copyc dft$application_support_limits
*copyc dft$app_support_limits_af
*copyc dft$rb_file_server_request
*copyc dfp$build_client_mf_file_name
*copyc dfp$clear_server_driver_flags
*copyc dfp$crack_client_mf_job_name
*copyc dfp$crack_mainframe_id
*copyc dfp$free_entry_assignment
*copyc dfp$get_qit_p_from_direct_index
*copyc dfp$load_application_procedure
*copyc dfp$send_message_to_operator
*copyc dfp$set_message_content_error
*copyc dfp$verify_system_administrator
*copyc dfp$word_boundary
*copyc dft$remote_request
*copyc dfp$fetch_queue_entry
*copyc dfp$find_mainframe_id
*copyc dfp$queue_task_request
*copyc dfp$receive_remote_call
*copyc dft$entry_type
*copyc dft$rpc_procedure_address_list
*copyc dfv$active_queue_entry_flags
*copyc dfv$file_server_debug_enabled
*copyc dfv$null_global_task_id
*copyc dfv$procedure_address_list
*copyc dfv$send_command_flags
*copyc dmp$allocate_file_space_r1
*copyc dpp$put_next_line
*copyc dpv$system_core_display
*copyc fmp$ln_open_chapter
*copyc fsp$change_segment_number
*copyc fsp$open_file
*copyc ioe$st_errors
*copyc i#call_monitor
*copyc i#current_sequence_position
*copyc mme$condition_codes
*copyc mmp$change_segment_number
*copyc mmp$reserve_segment_number
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$begin_system_activity
*copyc osp$end_system_activity
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$system_error
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc osv$task_private_heap
*copyc oss$task_shared
*copyc ost$caller_identifier
*copyc osv$task_shared_heap
*copyc pmp$convert_binary_unique_name
*copyc pmp$exit
*copyc pmp$execute
*copyc pmp$generate_unique_name
*copyc pmp$get_executing_task_gtid
*copyc pmp$wait
*copyc pmt$program_name
?? POP ??

?? TITLE := '   INLINE IN DECKS ', EJECT ??
*copyc dfp$determine_action_for_server
?? EJECT ??
?? TITLE := '  Global variables', EJECT ??

  VAR
    dfv$p_clone_tasks_status: [XDCL, oss$task_shared] ^array [ * ] of pmt$task_status := NIL;
*copyc dfv$p_client_mainframe_file

  VAR
    dfv$p_attached_file_pointers: [XDCL, oss$task_private] ^array [*] of ^cell := NIL,
    dfv$p_proc_addresses: [XDCL, oss$task_private] ^array [*] of dft$rpc_procedure_address := NIL;

?? TITLE := '    all_monitor_queues_waiting', EJECT  ??
  FUNCTION all_monitor_queues_waiting
    (    p_queue_interface_table: ^dft$queue_interface_table;
         queue_index: dft$queue_index): boolean;

     VAR
       p_cpu_queue_entry: ^dft$cpu_queue_entry,
       queue_entry_index: dft$queue_entry_index;

      FOR queue_entry_index := 1 to p_queue_interface_table^.queue_directory.driver_queue_pva_directory
           [queue_index].p_driver_queue^.queue_header.number_of_queue_entries  do
        p_cpu_queue_entry := ^p_queue_interface_table^.queue_directory.
            cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_entries [queue_entry_index];
        IF p_cpu_queue_entry^.processor_type = dfc$monitor THEN
          IF p_cpu_queue_entry^.p_server_iocb^.server_state <> mmc$ss_waiting THEN
            all_monitor_queues_waiting := FALSE;
            RETURN;
          IFEND;
        IFEND;
      FOREND;

      all_monitor_queues_waiting := TRUE;

   FUNCEND all_monitor_queues_waiting;

?? TITLE := '  [XDCL] dfp$establish_clone_task_stable', EJECT ??
  PROCEDURE [XDCL] dfp$establish_clone_task_stable
    (    mainframe_name: pmt$mainframe_id;
         number_of_monitor_queue_entries: 0 .. dfc$max_queue_entries;
         number_of_task_queue_entries: dft$queue_entry_index;
     VAR status: ost$status);

    VAR
      first_index: dft$queue_entry_index,
      length: integer,
      parameters: string (50),
      queue_entry_index: dft$queue_entry_index;

{  It is assumed that the queue entries are ordered as follows:
{     Polling Task, Monitor Entries, Task Services entries.
{
{   The clone task status array is to be generated such that an index into it
{   corresponds to the queue entry index of the associated task. Since there is
{   only one task for all monitor queue entries, the index of the highest monitor
{   queue entry is chosen as the lower bound of the tasks status array. There
{   is no task status for the Polling Task.
{
{   The upper bound is the highest queue entry index of the task services entries.
{

    IF number_of_monitor_queue_entries > 0 THEN
      first_index := dfc$poll_queue_index + number_of_monitor_queue_entries;
    ELSE
      {No monitor entries but the Poll Task and at least one Task Services Task always exist.
      first_index := dfc$poll_queue_index + 1;
    IFEND;

    ALLOCATE dfv$p_clone_tasks_status: [first_index .. (dfc$poll_queue_index +
          number_of_monitor_queue_entries + number_of_task_queue_entries)] IN osv$task_shared_heap^;

    IF number_of_monitor_queue_entries > 0 THEN
      STRINGREP (parameters, length, mainframe_name, ' ', number_of_monitor_queue_entries);
      execute_clone_task ('DFP$MONITOR_CLONE_TASK', parameters (1, length),
            dfv$p_clone_tasks_status^ [number_of_monitor_queue_entries+1], status);
      IF NOT status.normal THEN
        display_status (status);
      RETURN;
      IFEND;
    IFEND;

  /initiate_task_services_clones/
    FOR queue_entry_index := (dfc$poll_queue_index + number_of_monitor_queue_entries + 1) TO
          UPPERBOUND (dfv$p_clone_tasks_status^) DO
      STRINGREP (parameters, length, mainframe_name, ' ', queue_entry_index);
      execute_clone_task ('DFP$TASK_SERVICES_CLONE_TASK', parameters (1, length),
            dfv$p_clone_tasks_status^ [queue_entry_index], status);
      IF NOT status.normal THEN
        display_status (status);
        RETURN;
      IFEND;
    FOREND /initiate_task_services_clones/;

    wait_for_tasks_active (mainframe_name, number_of_monitor_queue_entries,
          number_of_task_queue_entries, status);

  PROCEND dfp$establish_clone_task_stable;

?? TITLE := ' [XDCL, #GATE] dfp$get_rpc_attached_files', EJECT ??
*copyc dfh$get_rpc_attached_files

  PROCEDURE [XDCL, #GATE] dfp$get_rpc_attached_files
    (    application_name: ost$name;
     VAR attached_file_pointers: array [1 .. *] of ^cell;
     VAR attached_file_names: array [1 .. *] of ost$string;
     VAR number_of_attached_files: dft$number_of_attached_files;
     VAR status: ost$status);

    VAR
      application_found: boolean,
      attached_file_index: dft$number_of_attached_files,
      client_mainframe: pmt$mainframe_id,
      ignore_p_q_interf_dir_entry: ^dft$q_interface_directory_entry,
      ignore_p_q_interf_table: ^dft$queue_interface_table,
      ignore_queue_index: dft$queue_index,
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_host_application_info: ^dft$host_application_info,
      previous_attached_files: dft$number_of_attached_files;

    status.normal := TRUE;
    number_of_attached_files := 0;
    application_found := FALSE;

    dfp$verify_system_administrator ('DFP$GET_RPC_ATTACHED_FILES', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{
{ Final implementation of this request is currently DEFERRED.
{

    RETURN;

{  Find client mainframe id, etc.
    dfp$crack_client_mf_job_name (client_mainframe, status);
    IF status.normal THEN
      dfp$find_mainframe_id (client_mainframe, {host_is_server} TRUE, mainframe_found,
            ignore_p_q_interf_table, p_cpu_queue, ignore_queue_index, ignore_p_q_interf_dir_entry);
      IF NOT mainframe_found THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, client_mainframe,
              status);
        RETURN;
      IFEND;
    ELSE
      RETURN;
    IFEND;

    IF p_cpu_queue^.queue_header.p_host_application_info = NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$application_not_known, application_name, status);
      RETURN;
    IFEND;

    previous_attached_files := 0;
    p_host_application_info := p_cpu_queue^.queue_header.p_host_application_info;

  /find_application/
    WHILE p_host_application_info <> NIL DO
      IF p_host_application_info^.application_name = application_name THEN
        application_found := TRUE;
        EXIT /find_application/;
      IFEND;
      IF p_host_application_info^.p_attached_file_info <> NIL THEN
        previous_attached_files := previous_attached_files +
              UPPERBOUND (p_host_application_info^.p_attached_file_info^);
      IFEND;
      p_host_application_info := p_host_application_info^.next_p_application_info;
    WHILEND /find_application/;
    IF NOT application_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$application_not_known, application_name, status);
      RETURN;
    IFEND;

    IF (p_host_application_info^.p_attached_file_info = NIL) OR
          (dfv$p_attached_file_pointers = NIL) THEN
       RETURN;
    IFEND;

    number_of_attached_files := UPPERBOUND (p_host_application_info^.p_attached_file_info^);

    { Return attached file info
      IF (number_of_attached_files <= UPPERBOUND (attached_file_names)) AND
            (number_of_attached_files <= UPPERBOUND (attached_file_pointers))THEN
        FOR attached_file_index := 1 TO number_of_attached_files DO
          previous_attached_files := previous_attached_files + 1;
          attached_file_pointers [attached_file_index] :=
                dfv$p_attached_file_pointers^ [previous_attached_files];
          attached_file_names [attached_file_index].size := #size (
            p_host_application_info^.p_attached_file_info^ [previous_attached_files]^);
          attached_file_names [attached_file_index].value :=
            p_host_application_info^.p_attached_file_info^ [previous_attached_files]^;
        FOREND;
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$callers_variable_too_small,
              'DFP$GET_RPC_ATTACHED_FILES', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'ATTACHED_FILE_POINTERS', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              number_of_attached_files , 10, FALSE, status);
        RETURN;
      IFEND;

  PROCEND dfp$get_rpc_attached_files;
?? TITLE := '  [XDCL, #GATE] dfp$monitor_clone_task', EJECT ??
  PROCEDURE [XDCL, #GATE] dfp$monitor_clone_task
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{      pdt create_monitor_clone_pdt (
{       mainframe_name: name pmc$mainframe_id_size = $required
{       number_of_monitor_queue_entries, nomqe: integer 0 .. dfc$max_queue_entries-2=$required
{       status)

?? PUSH (LISTEXT := ON) ??

  VAR
    create_monitor_clone_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^create_monitor_clone_pdt_names, ^create_monitor_clone_pdt_params];

  VAR
    create_monitor_clone_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
      clt$parameter_name_descriptor := [['MAINFRAME_NAME', 1], ['NUMBER_OF_MONITOR_QUEUE_ENTRIES', 2], [
      'NOMQE', 2], ['STATUS', 3]];

  VAR
    create_monitor_clone_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
      clt$parameter_descriptor := [

{ MAINFRAME_NAME }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, pmc$mainframe_id_size,
      pmc$mainframe_id_size]],

{ NUMBER_OF_MONITOR_QUEUE_ENTRIES NOMQE }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0,
      dfc$max_queue_entries-2]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      global_task_id: ost$global_task_id,
      mainframe_found: boolean,
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id,
      number_of_monitor_queue_entries: 0 .. dfc$max_queue_entries,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: ^dft$queue_interface_table,
      queue_entry_index: dft$queue_entry_index,
      queue_index: dft$queue_index,
      server_to_client: boolean,
      value: clt$value;

    dfp$verify_system_administrator ('DFP$MONITOR_CLONE_TASK', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$scan_parameter_list (parameter_list, create_monitor_clone_pdt, status);
    IF NOT status.normal THEN
      display_status (status);
      RETURN;
    IFEND;

    dfp$crack_mainframe_id ('MAINFRAME_NAME', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      display_status (status);
      RETURN;
    IFEND;

    clp$get_value ('NUMBER_OF_MONITOR_QUEUE_ENTRIES', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      display_status (status);
      RETURN;
    IFEND;
    number_of_monitor_queue_entries := value.int.value;
    IF number_of_monitor_queue_entries = 0 THEN
      {In this case, this procedure should have never be called.
      display (' DFP$MONITOR_CLONE_TASK called with zero monitor queue entries.');
      RETURN;
    IFEND;

    pmp$get_executing_task_gtid (global_task_id);
    IF dfv$file_server_debug_enabled THEN
      display_integer (' monitor clone task gtid.index ', global_task_id.index);
      display_integer (' monitor clone task gtid.seqno ', global_task_id.seqno);
    IFEND;
    server_to_client := TRUE;
    dfp$find_mainframe_id (mainframe_name, server_to_client, mainframe_found, p_queue_interface_table,
         p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      osp$system_error ('INTERNAL ERROR: MAINFRAME NOT FOUND IN MONITOR CLONE TASK.', NIL);
    IFEND;

  /store_task_ids/
{   1ST task is the Poll Task.
    FOR queue_entry_index := 2 TO (number_of_monitor_queue_entries + 1) DO
      p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
            p_cpu_queue^.queue_entries [queue_entry_index].global_task_id := global_task_id;
      p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
            p_driver_queue^.queue_entries [queue_entry_index].flags.active_entry := TRUE;

    FOREND /store_task_ids/;

    receive_monitor_requests (p_queue_interface_table, queue_index, number_of_monitor_queue_entries, status);
    display_status (status);
  PROCEND dfp$monitor_clone_task;

?? TITLE := '  [XDCL] dfp$process_task_request', EJECT ??
  PROCEDURE [XDCL] dfp$process_task_request
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
     VAR status: ost$status);


    VAR
      action_for_server: dft$action_for_server,
      p_buffer_header: ^dft$buffer_header;

    #KEYPOINT (osk$entry, osk$m * queue_entry_index, dfk$process_task_entry);
    status.normal := TRUE;

{   Determine cause of PP response.
    dfp$determine_action_for_server (p_cpu_queue_entry, p_driver_queue_entry, action_for_server);

    RESET p_cpu_queue_entry^.p_receive_buffer;
    NEXT p_buffer_header IN p_cpu_queue_entry^.p_receive_buffer;
    CASE action_for_server OF
    = dfc$transaction_out_of_sequence =
      display (' ENTRY SEQUENCE ERROR ');
      display_integer (' Expecting ', p_cpu_queue_entry^.transaction_count);
      display_integer (' Received from client: ', p_buffer_header^.transaction_count);
      display_integer_to_console (' DF - SERVER - ERROR SEQUENCE ERROR ',
              p_cpu_queue_entry^.transaction_count);
      dfp$set_message_content_error (p_cpu_queue_entry, p_driver_queue_entry);
      RETURN;

    = dfc$complete_request_on_error =
      display (' COMPLETE REQUEST ON ERROR ');
      display_integer_to_console (' DF - SERVER - COMPLETE REQUEST ON ERROR ',
              p_cpu_queue_entry^.transaction_count);
      IF dfv$file_server_debug_enabled THEN
        display_integer (' DRIVER ERROR ALERT - INDEX', queue_entry_index);
        display_integer_to_console (' DRIVER ERROR ALERT - INDEX', queue_entry_index);
        display_integer (' DRIVER ERROR CONDITION ', p_driver_queue_entry^.error_condition);
        display_integer_to_console (' DF - SERVER - DRIVER ERROR CONDITION ',
                p_driver_queue_entry^.error_condition);
        IF p_driver_queue_entry^.flags.send_ready_for_data THEN
          display (' SERVER ATTEMPTED TO READ PAGE DATA.');
          display_to_console (' DF - SERVER ATTEMPTED TO READ PAGE DATA.');
        ELSEIF p_driver_queue_entry^.flags.send_data THEN
          display (' SERVER ATTEMPTED TO SEND PAGE DATA.');
          display_to_console (' DF - SERVER ATTEMPTED TO SEND PAGE DATA.');
        IFEND;
      IFEND;
      dfp$clear_server_driver_flags (p_driver_queue_entry);
      RETURN;
    ELSE
      ;
    CASEND;

    IF dfv$file_server_debug_enabled THEN
      IF (p_buffer_header^.remote_processor > LOWERVALUE (dft$procedure_address_ordinal)) AND
         (p_buffer_header^.remote_processor < UPPERVALUE (dft$procedure_address_ordinal)) THEN
        IF p_buffer_header^.remote_processor <= dfc$last_system_procedure THEN
          display (dfv$procedure_address_list [p_buffer_header^.remote_processor].debug_display);
        ELSE
          display_integer (' Extended procedure ordinal ', $integer (
                p_buffer_header^.remote_processor));
        IFEND;
      ELSE
       display_integer (' Unexpected procedure ordinal', $integer
             (p_buffer_header^.remote_processor));
       dfp$set_message_content_error (p_cpu_queue_entry, p_driver_queue_entry);
       RETURN;
      IFEND;
    IFEND;

    IF p_buffer_header^.version = dfc$rpc_request_buffer_version THEN
      dfp$receive_remote_call (p_queue_interface_table, queue_index,
          queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry,
          action_for_server, status);
    ELSE
      display_integer (' Unexpected request - queue entry:', queue_entry_index);
      display (p_buffer_header^.version);
      dfp$set_message_content_error (p_cpu_queue_entry, p_driver_queue_entry);
    IFEND;
    #KEYPOINT (osk$exit, 0, dfk$process_task_entry);
  PROCEND dfp$process_task_request;
?? TITLE := '  [XDCL, #GATE] dfp$task_services_clone_task', EJECT ??
  PROCEDURE [XDCL, #GATE] dfp$task_services_clone_task
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{    pdt create_task_clone_pdt (
{      mainframe_name: name pmc$mainframe_id_size = $required
{      queue_entry_index, qei: integer 2 .. dfc$max_queue_entries = $required
{      status)

?? PUSH (LISTEXT := ON) ??

  VAR
    create_task_clone_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^create_task_clone_pdt_names, ^create_task_clone_pdt_params];

  VAR
    create_task_clone_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
      clt$parameter_name_descriptor := [['MAINFRAME_NAME', 1], ['QUEUE_ENTRY_INDEX', 2], ['QEI', 2], ['STATUS'
      , 3]];

  VAR
    create_task_clone_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
      clt$parameter_descriptor := [

{ MAINFRAME_NAME }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, pmc$mainframe_id_size,
      pmc$mainframe_id_size]],

{ QUEUE_ENTRY_INDEX QEI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 2,
      dfc$max_queue_entries]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      caller_id: ost$caller_identifier,
      client_mainframe_name: ost$name,
      display_string: string (80),
      display_string_length: integer,
      global_task_id: ost$global_task_id,
      mainframe_found: boolean,
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: ^dft$queue_interface_table,
      queue_index: dft$queue_index,
      queue_entry_index: dft$queue_entry_index,
      scratch_pointer: amt$segment_pointer,
      segment_attribute: array [1 .. 1] of mmt$attribute_descriptor,
      segment_pointer: mmt$segment_pointer,
      server_to_client: boolean,
      value: clt$value;

    dfp$verify_system_administrator ('DFP$TASK_SERVICES_CLONE_TASK', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$scan_parameter_list (parameter_list, create_task_clone_pdt, status);
    IF NOT status.normal THEN
      display_status (status);
      RETURN;
    IFEND;

    dfp$crack_mainframe_id ('MAINFRAME_NAME', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      display_status (status);
      RETURN;
    IFEND;

    clp$get_value ('QUEUE_ENTRY_INDEX', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      display_status (status);
      RETURN;
    IFEND;

    queue_entry_index := value.int.value;
    pmp$get_executing_task_gtid (global_task_id);
    STRINGREP (display_string, display_string_length, ' task queue_entry_index:', queue_entry_index,
          '-- gtid.index:', global_task_id.index);
    IF dfv$file_server_debug_enabled THEN
      display_integer (' task clone task gtid.seqno ', global_task_id.seqno);
      display (display_string (1, display_string_length));
    IFEND;
    server_to_client := TRUE;
    dfp$find_mainframe_id (mainframe_name, server_to_client, mainframe_found, p_queue_interface_table,
         p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, mainframe_name, status);
      RETURN;
    IFEND;
    p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
          p_cpu_queue^.queue_entries [queue_entry_index].global_task_id := global_task_id;
    p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue^.queue_entries [queue_entry_index].flags.active_entry := TRUE;

    dfp$build_client_mf_file_name (mainframe_name, client_mainframe_name);
    segment_attribute [1] .keyword := mmc$kw_segment_number;
    segment_attribute [1] .segnum := dfc$client_mainframe_segnum;

    #CALLER_ID (caller_id);
    fmp$ln_open_chapter (client_mainframe_name, 0, caller_id.ring, ^segment_attribute, mmc$cell_pointer,
          segment_pointer, status);
    IF NOT status.normal THEN
      display_status (status);
      RETURN;
    IFEND;
    dfv$p_client_mainframe_file := segment_pointer.cell_pointer;
      IF dfv$p_client_mainframe_file^.mainframe_header.segment_number <> dfc$client_mainframe_segnum THEN
        scratch_pointer.kind := amc$cell_pointer;
        scratch_pointer.cell_pointer := segment_pointer.cell_pointer;
        mmp$change_segment_number (scratch_pointer, dfv$p_client_mainframe_file^.mainframe_header.
              segment_number, 3, scratch_pointer, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        dfv$p_client_mainframe_file := scratch_pointer.cell_pointer;
      IFEND;

    generate_task_info (^p_cpu_queue^.queue_header, dfv$p_proc_addresses,
          dfv$p_attached_file_pointers, status);
    IF NOT status.normal THEN
      log_display_status ($pmt$ascii_logset [pmc$job_log, pmc$system_log], FALSE, status);
      display_status (status);
      status.normal := TRUE;
    IFEND;

    receive_task_requests (p_queue_interface_table, queue_index, queue_entry_index, status);
    display_status (status);

  PROCEND dfp$task_services_clone_task;
?? TITLE := '  display_condition', EJECT ??
{ This code was stolen from dfm$driver_test_utility

  PROCEDURE display_condition
    (    condition: dft$server_iocb_error_condition);

    CASE condition OF
    = dfc$null_server_condition =
      display (' Condition: null_server_condition');
    = dfc$reissued_rq_no_memory =
      display (' Condition: reissued_rq_no_memory');
    = dfc$reissued_rq_low_on_memory =
      display (' Condition: reissued_rq_low_on_memory');
    = dfc$reissued_rq_pt_full =
      display (' Condition: reissued_rq_pt_full');
    = dfc$reissued_rq_io_temp_reject =
      display (' Condition: reissued_rq_io_temp_reject');
    = dfc$reissu_rq_temp_rej_fde_lock =
      display (' Condition: reissued_rq_temp_reject_fde_locked');
    = dfc$reissued_rq_temp_rej_q_full =
      display (' Condition: reissued_rq_temp_reject_queue_full');
    = dfc$reissued_rq_io_still_active =
      display (' Condition: reissued_rq_io_still_active');
    = dfc$reissued_rq_task_queued =
      display (' Condition: reissued_rq_task_queued');
    = dfc$reissue_rq_client_locked_pg =
      display (' Condition: reissue_rq_client_locked_pg');
    = dfc$server_page_locked =
      display (' Condition: server_page_locked');
    = dfc$server_read_beyond_eoi =
      display (' Condition: server_read_beyond_eoi');
    = dfc$server_beyond_file_limit =
      display (' Condition: server_beyond_file_limit');
    = dfc$server_no_extend_permission =
      display (' Condition: server_no_extend_permission');
    = dfc$server_signal_select_on_pf =
      display (' Condition: server_signal_select_on_pf');
    = dfc$server_beyond_tape_window =
      display (' Condition: server_beyond_tape_window');
    = dfc$server_io_already_active =
      display (' Condition: server_io_already_active');
    = dfc$server_io_not_active =
      display (' Condition: server_io_not_active');
    = dfc$server_pages_not_available =
      display (' Condition: server_pages_not_available');
    = dfc$server_write_client_error =
      display (' Condition: server_write_client_error');
    = dfc$unrecovered_disk_error =
      display (' Condition: unrecovered_disk_error');
    = dfc$pp_not_configured =
      display (' Condition: pp_not_configured');
    = dfc$pp_interlock_set =
      display (' Condition: pp_interlock_set');
    = dfc$no_space_to_allocate =
      display (' Condition: no_space_to_allocate');
    = dfc$invalid_image_request =
      display (' Condition: invalid_image_request');
    = dfc$invalid_disk_type =
      display (' Condition: invalid_disk_type');
    = dfc$disk_media_error =
      display (' Condition: disk_media_error');
    = dfc$requests_full =
      display (' Condition: requests_full');
    = dfc$unable_to_build_io_request =
      display (' Condition: unable_to_build_io_request');
    = dfc$free_failure =
      display (' Condition: free_failure');
    = dfc$address_error =
      display (' Condition: address_error');
    = dfc$unable_to_unlock_rma_list =
      display (' Condition: unable_to_unlock_rma_list');
    = dfc$unable_to_set_system_flag =
      display (' Condition: unable_to_set_system_flag');
    = dfc$allocation_failure =
      display (' Condition: allocation_failure');
    = dfc$unable_to_queue_io_request =
      display (' Condition: unable_to_queue_io_request');
    = dfc$unable_to_destroy_io_req =
      display (' Condition: unable_to_destroy_io_req');
    = dfc$io_completion_table_error =
      display (' Condition: io_completion_table_error');
    = dfc$unsupported_monitor_request =
      display (' Condition: unsupported_monitor_request');
    = dfc$request_id_mismatch =
      display (' Condition: request_id_mismatch');
    = dfc$io_request_error =
      display (' Condition: io_request_error');
    = dfc$ssiot_recovery_required =
      display (' Condition: ssiot_recovery_required');
    ELSE
      display_integer ('UNKNOWN CONDITION ', $INTEGER (condition));
    CASEND;
  PROCEND display_condition;
?? TITLE := '  display_state', EJECT ??
  PROCEDURE display_state
    (    state: mmt$server_state);

    CASE state OF
    = mmc$ss_queue_initialized =
      display (' State: queue_initialized');
    = mmc$ss_waiting =
      display (' State: waiting');
    = mmc$ss_reading_from_disk =
      display (' State: reading_from_disk');
    = mmc$ss_read_disk_error =
      display (' State: read_disk_error');
    = mmc$ss_writing_to_esm =
      display (' State: writing_to_esm');
    = mmc$ss_write_esm_error =
      display (' State: write_esm_error');
    = mmc$ss_reading_from_esm =
      display (' State: reading_from_esm');
    = mmc$ss_read_esm_error =
      display (' State: read_esm_error');
    = mmc$ss_writing_to_disk =
      display (' State: writing_to_disk');
    = mmc$ss_write_disk_error =
      display (' State: write_disk_error');
    = mmc$ss_sending_write_response =
      display (' State: sending_response');
    = mmc$ss_sending_write_resp_error =
      display (' State: send_write_response_error');
    = mmc$ss_allocating_space =
      display (' State: allocating_space');
    = mmc$ss_allocate_space_error =
      display (' State: allocate_space_error');
    = mmc$ss_send_allocate_response =
      display (' State: send_allocate_response');
    = mmc$ss_send_allocate_resp_error =
      display (' State: send_allocate_resp_error');
    = mmc$ss_reading_pages_ahead =
      display (' State: reading_pages_ahead');
    ELSE
      display_integer (' unknown server state', $INTEGER (state));
    CASEND;
  PROCEND display_state;
?? TITLE := '  execute_clone_task', EJECT ??
  PROCEDURE execute_clone_task
    (    starting_procedure: string ( * <= osc$max_name_size);
         parameters: string ( * <= osc$max_string_size);
     VAR task_status: pmt$task_status;
     VAR status: ost$status);

    VAR
      p_parameter_sequence: ^pmt$program_parameters,
      p_parameter_string: ^ost$string,
      p_program_attributes: ^pmt$program_attributes,
      p_program_description: ^pmt$program_description,
      taskid: pmt$task_id;

    PUSH p_program_description: [[REP 1 OF pmt$program_attributes]];
    RESET p_program_description;
    NEXT p_program_attributes IN p_program_description;
    p_program_attributes^.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$load_map_options_specified, pmc$term_error_level_specified];
    p_program_attributes^.starting_procedure := starting_procedure;
    p_program_attributes^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    p_program_attributes^.termination_error_level := pmc$warning_load_errors;

    PUSH p_parameter_sequence: [[REP 1 OF ost$string]];
    RESET p_parameter_sequence;
    NEXT p_parameter_string IN p_parameter_sequence;
    p_parameter_string^.size := #SIZE (parameters);
    p_parameter_string^.value := parameters;

    pmp$execute (p_program_description^, p_parameter_sequence^, osc$nowait, taskid, task_status, status);
  PROCEND execute_clone_task;
?? TITLE := 'generate_task_info', EJECT ??

{ PURPOSE:
{   The purpose of this request is to generate task-dependent application
{   information.
{ NOTES:
{   No checking is made for allocation in system heaps since the system heap
{   manager never returns NIL (AHSE Cybil Coding Standards).
{   An error encountered in loading a remote procedure will result in the
{   pointer to that procedure remaining NIL. At time of calling a remote
{   application, a check must be made to see if the pointer is NIL.

  PROCEDURE generate_task_info
    (    p_cpu_queue_header: ^dft$cpu_queue_header;
     VAR p_proc_addresses: ^array [ * ] of dft$rpc_procedure_address;
     VAR p_attached_file_cells: ^array [ * ] of ^cell;
     VAR status: ost$status);

    VAR
      application_index: dft$number_of_applications,
      application_proc_index: dft$number_of_procs_per_app,
      attached_file_count: dft$number_of_attached_files,
      attached_file_index: dft$number_of_attached_files,
      file_attachment: array [1 .. 1] of fst$attachment_option,
      file_id: amt$file_identifier,
      global_attached_file_index: dft$number_of_attached_files,
      library_lfn: amt$local_file_name,
      line: string (120),
      line_size: integer,
      loaded_address: pmt$loaded_address,
      number_of_applications: dft$number_of_applications,
      p_reserved_file_segment_numbers: ^array [ * ] of ost$segment,
      p_host_application_info: ^dft$host_application_info,
      p_remote_application_info: ^dft$remote_application_info,
      segment_pointer: amt$segment_pointer,
      total_file_index: dft$number_of_attached_files,
      total_number_of_attached_files: dft$number_of_attached_files,
      total_number_of_procs: dft$total_number_of_app_procs,
      total_proc_index: dft$total_number_of_app_procs;

    status.normal := TRUE;
    p_proc_addresses := NIL;
    p_attached_file_cells := NIL;

    IF p_cpu_queue_header^.p_host_application_info = NIL THEN
      RETURN;
    IFEND;

    IF p_cpu_queue_header^.p_application_rpc_list <> NIL THEN
      total_number_of_procs := UPPERBOUND (p_cpu_queue_header^.p_application_rpc_list^);
    ELSE
      stringrep (line, line_size, ' **** Application ',
           p_cpu_queue_header^.p_host_application_info^.application_name,
           ' with no remote procedure info.');
      log_display ($pmt$ascii_logset [pmc$job_log, pmc$system_log], line (1, line_size));
      RETURN;
    IFEND;

    IF dfv$file_server_debug_enabled THEN
      STRINGREP (line, line_size, '    Total number of application procedures = ', total_number_of_procs);
      display (line (1, line_size));
    IFEND;

    ALLOCATE p_proc_addresses: [1 .. total_number_of_procs] IN osv$task_private_heap^;

    FOR total_proc_index := 1 TO total_number_of_procs DO
      p_proc_addresses^ [total_proc_index] := NIL;
    FOREND;

    total_proc_index := 0;
    total_number_of_attached_files := 0;

    p_remote_application_info := p_cpu_queue_header^.p_remote_application_info;
    p_host_application_info := p_cpu_queue_header^.p_host_application_info;
    WHILE p_host_application_info <> NIL DO
      library_lfn := p_host_application_info^.attached_library_lfn;

      IF p_remote_application_info <> NIL THEN

      /load_procedures/
        FOR application_proc_index := 1 TO p_remote_application_info^.number_of_procedures DO
          total_proc_index := total_proc_index + 1;
          IF dfv$file_server_debug_enabled THEN
            STRINGREP (line, line_size, ' Ready to load application procedure: ',
                  p_cpu_queue_header^.p_application_rpc_list^ [total_proc_index].debug_display);
            display (line (1, line_size));
          IFEND;
          dfp$load_application_procedure (p_cpu_queue_header^.p_application_rpc_list^ [total_proc_index].
                debug_display, library_lfn, loaded_address, status);
          IF status.normal THEN
            #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure,
                  p_proc_addresses^ [total_proc_index]);
          ELSE
            stringrep (line, line_size, ' Error while trying to load application procedure: ',
                  p_cpu_queue_header^.p_application_rpc_list^ [total_proc_index].debug_display);
            dfp$send_message_to_operator (line (1, line_size), {host_is_server} TRUE,
                  p_cpu_queue_header^.destination_mainframe_name);
            log_display_status ($pmt$ascii_logset [pmc$system_log], TRUE, status);
            display_status (status);
            status.normal := TRUE;
          IFEND;

        FOREND /load_procedures/;
        p_remote_application_info := p_remote_application_info^.next_p_application_info;
      IFEND;

      IF p_host_application_info^.p_attached_file_info <> NIL THEN
        total_number_of_attached_files := total_number_of_attached_files +
              UPPERBOUND (p_host_application_info^.p_attached_file_info^);
      IFEND;

      p_host_application_info := p_host_application_info^.next_p_application_info;
    WHILEND;

    IF total_number_of_attached_files = 0 THEN
      RETURN;
    IFEND;

{ Open attached files

    ALLOCATE p_attached_file_cells: [1 .. total_number_of_attached_files] IN osv$task_private_heap^;
    FOR attached_file_index := 1 TO total_number_of_attached_files DO
      p_attached_file_cells^ [attached_file_index] := NIL;
    FOREND;
    IF dfv$file_server_debug_enabled THEN
      STRINGREP (line, line_size, '    Number of attached files = ', total_number_of_attached_files);
      display (line (1, line_size));
    IFEND;

    PUSH p_reserved_file_segment_numbers: [1 .. total_number_of_attached_files];
    mmp$reserve_segment_number ({shared_stack_flag} FALSE, p_reserved_file_segment_numbers, status);
    IF NOT status.normal THEN
      log_display ($pmt$ascii_logset [pmc$job_log, pmc$system_log],
             ' Bad status from mmp$reserve_segment_number');
      log_display_status ($pmt$ascii_logset [pmc$job_log, pmc$system_log], TRUE, status);
      RETURN;
    IFEND;
{!!! ??? How to ensure all tasks have the same reserved segment numbers ?????

    file_attachment [1].selector := fsc$access_and_share_modes;
    file_attachment [1].access_modes.selector := fsc$specific_access_modes;
    file_attachment [1].access_modes.value := -$fst$file_access_options [];
    file_attachment [1].share_modes.selector := fsc$specific_share_modes;
    file_attachment [1].share_modes.value := -$fst$file_access_options [];

    p_host_application_info := p_cpu_queue_header^.p_host_application_info;
    WHILE p_host_application_info <> NIL DO

      IF p_host_application_info^.p_attached_file_info <> NIL THEN

      /attach_files/
        FOR attached_file_index := 1 TO UPPERBOUND (p_host_application_info^.p_attached_file_info^) DO

          fsp$open_file (p_host_application_info^.p_attached_file_info^ [attached_file_index]^, amc$segment,
                ^file_attachment, {default_creation_attributes} NIL, {manadated_creation_attributes} NIL,
                {attribute_validation} NIL, {attribute_override} NIL, file_id, status);
          IF NOT status.normal THEN
            log_display_status ($pmt$ascii_logset [pmc$job_log, pmc$system_log], FALSE, status);
            display_status (status);
            status.normal := TRUE;
            CYCLE /attach_files/;
          IFEND;
          amp$get_segment_pointer (file_id, amc$cell_pointer, segment_pointer, status);
          IF NOT status.normal THEN
            log_display ($pmt$ascii_logset [pmc$job_log, pmc$system_log],
                  ' Bad status from amp$get_segment_pointer');
            log_display_status ($pmt$ascii_logset [pmc$job_log, pmc$system_log], TRUE, status);
            status.normal := TRUE;
            CYCLE /attach_files/;
          IFEND;
          IF #SEGMENT (segment_pointer.cell_pointer) <> p_reserved_file_segment_numbers^
                [attached_file_index] THEN
            fsp$change_segment_number (file_id, p_reserved_file_segment_numbers^
                  [attached_file_index], {validation_ring} 3 {??} , amc$cell_pointer,
                  segment_pointer, status);
            IF NOT status.normal THEN
              log_display ($pmt$ascii_logset [pmc$job_log, pmc$system_log],
                   ' Bad status from fsp$change_segment_number');
              log_display_status ($pmt$ascii_logset [pmc$job_log, pmc$system_log], TRUE, status);
              display_status (status);
              status.normal := TRUE;
              CYCLE /attach_files/;
            IFEND;
          IFEND;
          p_attached_file_cells^ [attached_file_index] := segment_pointer.cell_pointer;
        FOREND /attach_files/;
      IFEND;

      p_host_application_info := p_host_application_info^.next_p_application_info;
    WHILEND;

  PROCEND generate_task_info;
?? TITLE := '  process_monitor_entry', EJECT ??
  PROCEDURE process_monitor_entry
    (    p_cpu_queue: ^dft$cpu_queue;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
     VAR status: ost$status);

    VAR
      display_string: string (80),
      display_string_length: integer,
      file_name: ost$name,
      ignored_status: ost$status,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_queue_interface_table: ^dft$queue_interface_table,
      p_server_iocb: ^mmt$server_iocb_entry,
      remote_request: dft$remote_request,
      request_block:  dft$rb_file_server_request,
      allocation_status: ost$status;

    CONST
     { Time in milliseconds.
     restart_delay = 15,          {Delay time before re-starting request}
     maximum_wait_time = 600000,  {10 minutes}
     maximum_restart_count = (maximum_wait_time DIV restart_delay);

    p_server_iocb := p_cpu_queue_entry^.p_server_iocb;

    IF dfv$file_server_debug_enabled THEN
      display_condition (p_server_iocb^.condition);
      display_state (p_server_iocb^.server_state);
      display_integer (' SERVER IOCB ACTIVE IO COUNT ',
            p_server_iocb^.active_io_count);
      display_bytes (p_server_iocb, #size(p_server_iocb^));
    IFEND;

    CASE p_server_iocb^.server_state OF
    = mmc$ss_read_disk_error, mmc$ss_write_esm_error =
      CASE p_server_iocb^.condition OF
      = dfc$bad_sfid =
        send_error_status_response (p_cpu_queue_entry, dfe$sfid_gfn_mismatch, status);
        p_server_iocb^.server_state := mmc$ss_waiting;
        RETURN;
      = dfc$server_terminated =
        p_server_iocb^.server_state := mmc$ss_waiting;
        RETURN;
      = dfc$volume_unavailable, dfc$unit_disabled =
        send_error_status_response (p_cpu_queue_entry, mme$volume_unavailable, status);
        p_server_iocb^.server_state := mmc$ss_waiting;
        RETURN;
      = dfc$disk_media_error, dfc$unrecovered_disk_error =
        send_error_status_response (p_cpu_queue_entry, ioc$disk_media_error, status);
        p_server_iocb^.server_state := mmc$ss_waiting;
        RETURN;
      ELSE
      CASEND;
      p_server_iocb^.server_state := mmc$ss_waiting;
      remote_request := dfc$read_for_client;
      p_server_iocb^.active_io_count := 0;
{     Reset the server_iocb condition.
      p_server_iocb^.condition := dfc$null_server_condition;

    = mmc$ss_read_esm_error =
      CASE p_server_iocb^.condition OF
      = dfc$bad_sfid =
        log_display ($pmt$ascii_logset [pmc$system_log], ' DF - BAD SFID RECEIVED ');
        log_display_integer ($pmt$ascii_logset [pmc$system_log], '      QUEUE INDEX = ',
              p_cpu_queue_entry^.io_id.queue_entry_location.queue_index);
        IF dfv$file_server_debug_enabled THEN
          osp$system_error (' BAD SFID. PROCESS_MONITOR_REQUEST', NIL);
        IFEND;
        send_error_status_response (p_cpu_queue_entry, dfe$sfid_gfn_mismatch, status);
        p_server_iocb^.server_state := mmc$ss_waiting;
        RETURN;
      = dfc$server_terminated =
        p_server_iocb^.server_state := mmc$ss_waiting;
        RETURN;
      = dfc$disk_media_error =
{       FS PP driver detected ESM failure while reading page data.
{       Clean up queue entry and wait for Client to retransmit the request.
        p_server_iocb^.server_state := mmc$ss_waiting;
        p_server_iocb^.active_io_count := 0;
{       Reset the server_iocb condition.
        p_server_iocb^.condition := dfc$null_server_condition;
        dfp$get_qit_p_from_direct_index (p_cpu_queue_entry^.io_id.queue_entry_location.directory_index,
              p_queue_interface_table);
        p_driver_queue_entry := ^p_queue_interface_table^.queue_directory.
           driver_queue_pva_directory [p_cpu_queue_entry^.io_id.queue_entry_location.queue_index].
           p_driver_queue^.queue_entries [p_cpu_queue_entry^.io_id.queue_entry_location.queue_entry_index];
        p_driver_queue_entry^.flags := dfv$active_queue_entry_flags;
        RETURN;

      ELSE
      CASEND;
      p_server_iocb^.server_state := mmc$ss_waiting;
      remote_request := dfc$write_for_client;
      p_server_iocb^.active_io_count := 0;
{     Reset the server_iocb condition.
      p_server_iocb^.condition := dfc$null_server_condition;

    = mmc$ss_sending_write_resp_error =
      IF p_server_iocb^.condition = dfc$server_terminated THEN
        p_server_iocb^.server_state := mmc$ss_waiting;
        RETURN;
      IFEND;
      p_server_iocb^.server_state := mmc$ss_writing_to_disk;
      remote_request := dfc$completing_previous_request;
      p_server_iocb^.active_io_count := 1;
{     Reset the server_iocb condition.
      p_server_iocb^.condition := dfc$null_server_condition;

    = mmc$ss_write_disk_error =
      p_server_iocb^.server_state := mmc$ss_reading_from_esm;
      remote_request := dfc$completing_previous_request;
      p_server_iocb^.active_io_count := 1;
      CASE p_server_iocb^.condition OF
      = dfc$bad_sfid =
        p_server_iocb^.server_state := mmc$ss_waiting;
        send_error_status_response (p_cpu_queue_entry, dfe$sfid_gfn_mismatch, status);
        RETURN;
      = dfc$disk_media_error, dfc$unrecovered_disk_error =
        p_server_iocb^.server_state := mmc$ss_waiting;
        send_error_status_response (p_cpu_queue_entry, ioc$disk_media_error, status);
        RETURN;
      = dfc$volume_unavailable, dfc$unit_disabled =
        p_server_iocb^.server_state := mmc$ss_waiting;
        send_error_status_response (p_cpu_queue_entry, mme$volume_unavailable, status);
        RETURN;
      ELSE
      CASEND;
{     Reset the server_iocb condition.
      p_server_iocb^.condition := dfc$null_server_condition;

    = mmc$ss_allocate_space_error =
      CASE p_server_iocb^.condition OF
      = dfc$reissued_rq_io_temp_reject =
        dmp$allocate_file_space_r1 (p_server_iocb^.sfid, p_server_iocb^.offset, p_server_iocb^.length -
               p_server_iocb^.offset, 0, osc$nowait, sfc$no_limit, allocation_status);
        IF allocation_status.normal THEN
{         Set up a server response indicating a successful allocation and reset the server_iocb condition.
          p_server_iocb^.server_state := mmc$ss_allocating_space;
          remote_request := dfc$completing_previous_request;
          p_server_iocb^.active_io_count := 1;
          p_server_iocb^.condition := dfc$null_server_condition;
        ELSE
{         Set up a server response indicating a failed allocation.
{         DO NOT reset the server_iocb condition to zero (dfc$null_server_condition)!
{         DO NOT reset the server_iocb state either (mmc$ss_allocate_space_error)!
          remote_request := dfc$completing_previous_request;
          p_server_iocb^.active_io_count := 1;
          p_server_iocb^.condition := dfc$allocation_failure;
        IFEND;

      = dfc$volume_unavailable, dfc$unit_disabled =
        p_server_iocb^.server_state := mmc$ss_waiting;
        send_error_status_response (p_cpu_queue_entry, mme$volume_unavailable, status);
        RETURN;
      = dfc$disk_media_error, dfc$unrecovered_disk_error =
        send_error_status_response (p_cpu_queue_entry, ioc$disk_media_error, status);
        p_server_iocb^.server_state := mmc$ss_waiting;
        RETURN;

      ELSE
{ The server_condition, DFC$SERVER_TERMINATED, cannot happen on the mainframe which is executing this code.
        osp$system_error ('Unexpected server_condition in PROCESS_MONITOR_ENTRY', NIL);
      CASEND;

    = mmc$ss_send_allocate_resp_error =
      IF p_server_iocb^.condition = dfc$server_terminated THEN
        p_server_iocb^.server_state := mmc$ss_waiting;
        RETURN;
      IFEND;
      p_server_iocb^.server_state := mmc$ss_allocating_space;
      remote_request := dfc$completing_previous_request;
      p_server_iocb^.active_io_count := 1;
{     Reset the server_iocb condition.
      p_server_iocb^.condition := dfc$null_server_condition;

    ELSE

{ We don't care about the particular server request states here - they all are unexpected.  However, we may be
{ able to react to individual server conditions regardless of the server request state...

      IF p_server_iocb^.condition = dfc$volume_unavailable THEN
        p_server_iocb^.server_state := mmc$ss_waiting;
        send_error_status_response (p_cpu_queue_entry, mme$volume_unavailable, status);
        RETURN;
      ELSE
        log_display ($pmt$ascii_logset[pmc$job_log, pmc$system_log],
              ' Unable to handle DF state/condition combo:');
        log_display_integer ($pmt$ascii_logset[pmc$job_log, pmc$system_log], '    Queue Index = ',
             p_cpu_queue_entry^.io_id.queue_entry_location.queue_index);
        log_display_integer ($pmt$ascii_logset[pmc$job_log, pmc$system_log], '    Queue Entry Index = ',
             p_cpu_queue_entry^.io_id.queue_entry_location.queue_entry_index);
        log_display_integer ($pmt$ascii_logset[pmc$job_log, pmc$system_log], '    DF IOCB state = ',
             $INTEGER (p_server_iocb^.server_state));
        log_display_integer ($pmt$ascii_logset[pmc$job_log, pmc$system_log], '    DF IOCB condition = ',
             $INTEGER (p_server_iocb^.condition));
        osp$system_error (' UNEXPECTED SERVER STATE ', NIL);
      IFEND;
    CASEND;

    IF (p_cpu_queue^.queue_header.partner_status.server_state = dfc$terminated) OR
        (p_cpu_queue^.queue_header.partner_status.server_state = dfc$awaiting_recovery) THEN
       { There is no reason to attempt to restart the request if the server is terminated.
        p_server_iocb^.server_state := mmc$ss_waiting;
       RETURN;
    IFEND;

{   For some reason (most likely the page is locked by another task)
{   File Server cannot complete the request. The following code provides a
{   delay between attempts to complete the request, and also imposes a time
{   limit on completion of the request. If the request cannot be completed
{   after the maximum number of attempts (approx. 10 minutes, 40000 attempts)
{   it is assumed that something is terribly wrong and the File Server
{   connection will be "timed out".
{
{   The iocb field "restart_count" is initialized to zero when a new or
{   retransmitted request is detected in dfp$process_server_response_a.

    IF p_server_iocb^.restart_count >= maximum_restart_count THEN
      pmp$convert_binary_unique_name (p_server_iocb^.global_file_name, file_name, ignored_status);
      STRINGREP (display_string, display_string_length, '    Global File Name - ', file_name);
      display (' DF - Timing out File Server - inaccessible page encountered.');
      display_to_console (' DF - Timing out File Server - inaccessible page encountered.');
      log_display ($pmt$ascii_logset[pmc$system_log],
           ' DF - Timing out File Server - inaccessible page encountered.');
      log_display ($pmt$ascii_logset[pmc$system_log], display_string(1, display_string_length));
      IF dfv$file_server_debug_enabled THEN
        log_display_integer ($pmt$ascii_logset[pmc$system_log], '    Queue Index = ',
             p_cpu_queue_entry^.io_id.queue_entry_location.queue_index);
        log_display_integer ($pmt$ascii_logset[pmc$system_log], '    Queue Entry Index = ',
             p_cpu_queue_entry^.io_id.queue_entry_location.queue_entry_index);
        display (display_string(1, display_string_length));
        display_integer ('    Queue Index = ', p_cpu_queue_entry^.io_id.queue_entry_location
             .queue_index);
        display_integer ('    Queue Entry Index = ', p_cpu_queue_entry^.io_id.queue_entry_location
             .queue_entry_index);
      IFEND;
      p_server_iocb^.server_state := mmc$ss_waiting;
      p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
      RETURN;

    ELSEIF p_server_iocb^.restart_count <> 0 THEN
{     Do not delay before first re-start attempt.
{     This delay is to allow the task, which has the page in question locked,
{     an opportunity to release the locked page.
      pmp$wait (restart_delay, restart_delay);
    IFEND;
    p_server_iocb^.restart_count := p_server_iocb^.restart_count + 1;

    request_block.reqcode := syc$rc_file_server_request;
    request_block.status.normal := TRUE;
    request_block.request := dfc$fsr_restart_server_request;
    request_block.remote_request := remote_request;
    request_block.p_cpu_queue_entry := p_cpu_queue_entry;
    IF dfv$file_server_debug_enabled THEN
      display (' i#call_monitor - RESTART_SERVER_REQUEST ');
      display_integer ('    Re-start count = ', p_server_iocb^.restart_count);
    IFEND;
    i#call_monitor (#LOC(request_block), #SIZE (request_block));
    IF request_block.status.normal THEN
      IF dfv$file_server_debug_enabled THEN
        display (' RETURN FROM MONITOR - NORMAL ');
      IFEND;
    ELSE
      display_integer (' ABNORMAL STATUS FROM MONITOR ',
            request_block.status.condition);
    IFEND;
    status.normal := TRUE;
  PROCEND process_monitor_entry;

?? TITLE := '  receive_monitor_requests', EJECT ??
  PROCEDURE receive_monitor_requests
    (    p_queue_interface_table: ^dft$queue_interface_table;
         queue_index: dft$queue_index;
         number_of_monitor_queue_entries: 0 .. dfc$max_queue_entries;
     VAR status: ost$status);

     CONST
      { Time in milliseconds
      requested_time = 5000,
      expected_time =  5000;

    TYPE
      char_set = set of char;

    VAR
      active_entry_found: boolean,
      active_queue_entry: dft$queue_entry_index,
      assigned_char_set: char_set,
      p_cpu_queue: ^dft$cpu_queue,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_server_state: ^dft$server_state;

    status.normal := TRUE;
    IF number_of_monitor_queue_entries = 0 THEN
      {In this case, this procedure should have never be called.
      display (' RECEIVE_MONITOR_REQUESTS called with zero monitor queue entries.');
      RETURN;
    IFEND;

    assigned_char_set := $char_set [dfc$assigned_entry_char];
    p_cpu_queue := p_queue_interface_table^.queue_directory.
      cpu_queue_pva_directory [queue_index].p_cpu_queue;
    p_server_state := ^p_cpu_queue^.queue_header.
      partner_status.server_state;

  /loop_until_terminated/
    WHILE TRUE DO
      #SPOIL (p_server_state^);
      IF (p_server_state^ = dfc$terminated) OR (p_server_state^ = dfc$awaiting_recovery) THEN
        IF all_monitor_queues_waiting (p_queue_interface_table, queue_index) THEN
          osp$set_status_condition (dfe$client_not_active, status);
          pmp$exit (status);
        IFEND;
      IFEND;
      pmp$wait (requested_time, expected_time);
      #KEYPOINT (osk$debug, 0, dfk$monitor_task_activated);
      REPEAT
        #SPOIL(p_cpu_queue^.queue_header.
              queue_entry_assignment_table);
{       Provide for 1 st entry assigned to Poll Task.
        #SCAN (assigned_char_set, p_cpu_queue^.queue_header.
              queue_entry_assignment_table (2, number_of_monitor_queue_entries), active_queue_entry,
              active_entry_found);
        IF active_entry_found THEN
          active_queue_entry := active_queue_entry + 1;
          IF dfv$file_server_debug_enabled THEN
            display_integer (' MONITOR ACTIVE - ENTRY ', active_queue_entry);
          IFEND;
          dfp$free_entry_assignment (active_queue_entry,
              p_cpu_queue^.queue_header.
              queue_entry_assignment_table);
          p_cpu_queue_entry :=
              ^p_cpu_queue^.queue_entries [active_queue_entry];
          process_monitor_entry (p_cpu_queue, p_cpu_queue_entry, status);
          IF NOT status.normal THEN
            display_status (status);
          IFEND;
        ELSEIF (p_server_state^ = dfc$terminated) OR (p_server_state^ = dfc$awaiting_recovery) THEN
          IF all_monitor_queues_waiting (p_queue_interface_table, queue_index) THEN
            osp$set_status_condition (dfe$client_not_active, status);
            pmp$exit (status);
          IFEND;
        IFEND;
      UNTIL (NOT active_entry_found) OR (NOT status.normal);
    WHILEND /loop_until_terminated/;

  PROCEND receive_monitor_requests;

?? TITLE := '  receive_task_requests', EJECT ??
  PROCEDURE receive_task_requests
    (    p_queue_interface_table: ^dft$queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
     VAR status: ost$status);

    CONST
      { Time in milliseconds
      requested_time = 2000,
      expected_time =  1000;

    VAR
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_server_state: ^dft$server_state;

    dfp$fetch_queue_entry (p_queue_interface_table, queue_index, queue_entry_index,
          p_driver_queue_entry, p_cpu_queue_entry);

 { Probably should be in above procedure, or somewhere
    p_server_state := ^p_queue_interface_table^.queue_directory.
      cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header.
      partner_status.server_state;

    status.normal := TRUE;

  /await_task_activation/
    REPEAT
      #SPOIL (p_server_state^);
      IF NOT ((p_server_state^ = dfc$terminated) OR (p_server_state^ = dfc$awaiting_recovery)) THEN
        REPEAT
          pmp$wait (requested_time, expected_time);
        UNTIL p_driver_queue_entry^.flags.subsystem_action;
      IFEND;
      IF ((p_server_state^ = dfc$terminated) OR (p_server_state^ = dfc$awaiting_recovery)) THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$client_not_active, '', status);
        pmp$exit (status);
      ELSE
        dfp$process_task_request (p_queue_interface_table, queue_index, queue_entry_index,
              p_driver_queue_entry, p_cpu_queue_entry, status);
      IFEND;
    UNTIL NOT status.normal;
    display_status (status);
  PROCEND receive_task_requests;
?? TITLE := '  send_bad_status_response', EJECT ??

  PROCEDURE send_error_status_response
    (    p_cpu_queue_entry: ^dft$cpu_queue_entry;
         error_condition: ost$status_condition;
     VAR status: ost$status);

    VAR
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_req_buffer_header: ^dft$buffer_header,
      p_status_response: ^dft$status_response,
      queue_request_status: dft$queue_request_status;

    IF dfv$file_server_debug_enabled THEN
      display_integer (' send_error_status_response ', $integer (error_condition));
      display_integer_to_console (' send_error_status_response ', $integer (error_condition));
    IFEND;

    RESET p_cpu_queue_entry^.p_send_buffer;
    NEXT p_status_response IN p_cpu_queue_entry^.p_send_buffer;

    p_status_response^.buffer_header.version := dfc$status_buffer_version;

    RESET p_cpu_queue_entry^.p_receive_buffer;
    NEXT p_req_buffer_header IN p_cpu_queue_entry^.p_receive_buffer;

    p_status_response^.buffer_header.remote_processor := p_req_buffer_header^.remote_processor;
    p_status_response^.buffer_header.transaction_count :=
          p_cpu_queue_entry^.transaction_count;
    p_status_response^.buffer_header.retransmission_count :=
          p_cpu_queue_entry^.retransmission_count;
    p_status_response^.buffer_header.data_length_sent := 0;

    p_status_response^.status.normal := FALSE;
    p_status_response^.status.condition := error_condition;

    dfp$get_qit_p_from_direct_index (p_cpu_queue_entry^.io_id.queue_entry_location.directory_index,
          p_queue_interface_table);

    p_driver_queue_entry := ^p_queue_interface_table^.queue_directory.
          driver_queue_pva_directory [p_cpu_queue_entry^.io_id.queue_entry_location.queue_index].
          p_driver_queue^.queue_entries [p_cpu_queue_entry^.io_id.queue_entry_location.queue_entry_index];

    { Set send buffer length in buffer header.
    p_status_response^.buffer_header.buffer_length_sent :=
          dfp$word_boundary (i#current_sequence_position (p_cpu_queue_entry^.p_send_buffer));

    { Setup driver_queue_entry flags for send buffer and data.
    p_driver_queue_entry^.flags := dfv$send_command_flags;

    { Set send buffer length in driver queue entry.
    p_driver_queue_entry^.send_buffer_descriptor.actual_length :=
          p_status_response^.buffer_header.buffer_length_sent;

    { Queue request for driver.
    osp$begin_system_activity;
    dfp$queue_request (p_queue_interface_table,
          p_cpu_queue_entry^.io_id.queue_entry_location.queue_index, p_cpu_queue_entry^.
          io_id.queue_entry_location.queue_entry_index, queue_request_status);
    osp$end_system_activity;
  PROCEND send_error_status_response;

?? TITLE :=  'wait_for_tasks_active', EJECT ??
  PROCEDURE wait_for_tasks_active
    (    mainframe_name: pmt$mainframe_id;
         number_of_monitor_queue_entries: 0 .. dfc$max_queue_entries;
         number_of_task_queue_entries: dft$queue_entry_index;
     VAR status: ost$status);

    VAR
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: ^dft$queue_interface_table,
      queue_entry_index: dft$queue_entry_index,
      queue_index: dft$queue_index,
      wait_count: 0 .. 255;

    dfp$find_mainframe_id (mainframe_name, {server_to_client=} TRUE, mainframe_found,
         p_queue_interface_table, p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, mainframe_name, status);
      RETURN;
    IFEND;

    IF number_of_monitor_queue_entries > 0 THEN
      wait_count := 0;
    /wait_for_monitor_task/
      WHILE p_cpu_queue^.queue_entries [dfc$poll_queue_index + 1].global_task_id =
            dfv$null_global_task_id DO
        IF wait_count > 50 THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$task_not_established, 'MONITOR',
                status);
          RETURN;
        IFEND;
        pmp$wait (100, 100);
        IF (wait_count = 10) AND dfv$file_server_debug_enabled THEN
          display (' Waiting for monitor task to become active.');
        IFEND;
        wait_count := wait_count + 1;
      WHILEND /wait_for_monitor_task/;
    IFEND;

    FOR queue_entry_index := (dfc$poll_queue_index + number_of_monitor_queue_entries + 1) TO
          UPPERBOUND (dfv$p_clone_tasks_status^) DO
      wait_count := 0;
    /wait_for_services_task/
      WHILE p_cpu_queue^.queue_entries [queue_entry_index].global_task_id =
            dfv$null_global_task_id DO
        IF wait_count > 50 THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$task_not_established,
                'TASK SERVICES', status);
          RETURN;
          EXIT /wait_for_services_task/;
        IFEND;
        pmp$wait (100, 100);
        IF (wait_count = 10) AND dfv$file_server_debug_enabled THEN
          display (' Waiting for services task to become active.');
        IFEND;
        wait_count := wait_count + 1;
      WHILEND /wait_for_services_task/;
    FOREND;

  PROCEND wait_for_tasks_active;

?? OLDTITLE ??
MODEND dfm$clone_task_process;
*DECK DECK=DFM$COMMON_ROUTINES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File Server : Common Routines' ??
MODULE dfm$common_routines;

{ PURPOSE:
{   This module contains routines that are of common use to the file server code.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dft$connection_parameters
*copyc jmc$system_family
?? POP ??
*copyc clp$get_value
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc pmp$convert_mainframe_to_binary
*copyc pmp$get_user_identification
?? EJECT ??
*copyc dfv$p_queue_interface_directory
*copyc osv$system_family_name
?? OLDTITLE ??
?? NEWTITLE := 'dfp$check_if_valid', EJECT ??

{ PURPOSE:
{   This procedure determines if the DEFINE_SERVER/DEFINE_CLIENT command is valid.

  PROCEDURE [XDCL] dfp$check_if_valid
    (    connection_parameters: dft$connection_parameters;
     VAR status: ost$status);

    VAR
      index: dft$queue_directory_index;

    status.normal := TRUE;
    IF dfv$p_queue_interface_directory = NIL THEN
      RETURN;
    IFEND;

    FOR index := 1 TO UPPERBOUND (dfv$p_queue_interface_directory^) DO
      IF dfv$p_queue_interface_directory^ [index].connection_type = dfc$esm_connection THEN
        IF dfv$p_queue_interface_directory^ [index].element_name =
              connection_parameters.esm_parameters.element_name THEN

          IF dfv$p_queue_interface_directory^ [index].send_pp.pp_status.activated OR
                dfv$p_queue_interface_directory^ [index].receive_pp.pp_status.activated THEN
            osp$set_status_abnormal (dfc$file_server_id, dfe$pp_active_during_define, '', status);
            RETURN;
          IFEND;

          IF dfv$p_queue_interface_directory^ [index].send_channel <>
                connection_parameters.esm_parameters.send_channel THEN
            osp$set_status_abnormal (dfc$file_server_id, dfe$stornet_channel_mismatch, 'SEND', status);
            RETURN;
          IFEND;

          IF dfv$p_queue_interface_directory^ [index].receive_channel <>
                connection_parameters.esm_parameters.receive_channel THEN
            osp$set_status_abnormal (dfc$file_server_id, dfe$stornet_channel_mismatch, 'RECEIVE', status);
            RETURN;
          IFEND;

          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND dfp$check_if_valid;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$crack_mainframe_id ', EJECT ??

{ PURPOSE:
{   This cracks an 'old types' parameter of the form $SYSTEM_MMMM_NNNN, where MMMM is the model number, and
{   NNNN is the serial number.

  PROCEDURE [XDCL, #GATE] dfp$crack_mainframe_id
    (    parameter_name: string ( * <= osc$max_name_size);
     VAR mainframe_id: pmt$mainframe_id;
     VAR binary_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

    VAR
      value: clt$value;

    status.normal := TRUE;
    clp$get_value (parameter_name, 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    mainframe_id := value.name.value;

    pmp$convert_mainframe_to_binary (mainframe_id, binary_mainframe_id, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$improper_mainframe_id, mainframe_id, status);
      RETURN;
    IFEND;

    IF binary_mainframe_id.model_number = osc$cyber_180_model_unknown THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$unknown_model_number,
            mainframe_id (9, pmc$processor_model_number_size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, mainframe_id, status);
      RETURN;
    IFEND;

  PROCEND dfp$crack_mainframe_id;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$new_crack_mainframe_id ', EJECT ??

{ PURPOSE:
{   This cracks a 'new types' parameter of the form $SYSTEM_MMMM_NNNN, where MMMM is the model number, and
{   NNNN is the serial number.

  PROCEDURE [XDCL, #GATE] dfp$new_crack_mainframe_id
    (    mainframe_id: pmt$mainframe_id;
     VAR binary_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

    status.normal := TRUE;
    pmp$convert_mainframe_to_binary (mainframe_id, binary_mainframe_id, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$improper_mainframe_id, mainframe_id, status);
      RETURN;
    IFEND;

    IF binary_mainframe_id.model_number = osc$cyber_180_model_unknown THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$unknown_model_number,
            mainframe_id (9, pmc$processor_model_number_size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, mainframe_id, status);
      RETURN;
    IFEND;

  PROCEND dfp$new_crack_mainframe_id;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$verify_system_administrator', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$verify_system_administrator
    (    request_name: string ( * <= osc$max_name_size);
     VAR status: ost$status);

    VAR
      user_id: ost$user_identification;

    pmp$get_user_identification (user_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT ((user_id.family = osv$system_family_name) AND (user_id.user = jmc$system_user)) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$not_system_administrator, request_name, status);
    IFEND;

  PROCEND dfp$verify_system_administrator;
?? OLDTITLE ??
MODEND dfm$common_routines;
*DECK DECK=DFM$COMPUTE_CHECKSUM EXPAND=TRUE
dfm$compute_checksum  ident
.
. This module computes checksums for the permanent file manager.
.
. Registers used in this module are defined as follows:
.
index    equ       8         .index into the data to checksum
                             .This is the offset from the start of the data
p_loc    equ       8         .register pointing to location of data
remaining_bytes    equ  9    .register for number of remaining_bytes of data
result   equ       10        .register for checksum result
data     equ       11        .register for data
amacscr  equ       15        .scratch register for macros
.
index    atrib     #regtyp,#xreg
p_loc    atrib     #regtyp,#areg
remaining_bytes    atrib     #regtyp,#xreg
result   atrib     #regtyp,#xreg
data     atrib     #regtyp,#xreg
amacscr  atrib     #regtyp,#areg
.
         page
. COMMON DECKS
*copy OSA$CYBIL_INTERFACE
         page
*copy OSA$BASIC_REGISTER_EQUATES
         page
.______________________________________________________________
. Name:
.        dfp$compute_checksum
.Purpose:
.        This function computes a checksum for  data.
. Input:
.        loc: Pointer to data to checksum.
.        size: Size in bytes of data to checksum.
. Output:
.        sum: Integer value of checksum for data.
._________________________________________________________
.
.
.        PROCEDURE [XREF] dfp$compute_checksum (loc: ^cell;
.                  size: integer;
.                  VAR sum: integer)
.
.
dfp$compute_checksum     procedur
loc      param     val,pointer
size     param     val,integer
sum      param     ref,integer
.
.
         ploada    p_loc,loc             . get PVA of data to checksum
         ploadx    remaining_bytes,size  . get number of bytes to checksum
         entp      index,0               . index := 0
         entp      result,0              . result := 0
.
looptest brreq     remaining_bytes,x0,done  .IF remaining_bytes = 0 goto DONE
         decr      remaining_bytes,8     . remaining_bytes := remaining_bytes - 8
         brrgt     x0,remaining_bytes,lastbyte .IF remaining_bytes<0 THEN goto lastbyte
         lbyts,8   data,p_loc,index,0    . Load the current word into data
         incr      index,8               . Index := index + 8
         xorx      result,data           . result := exclusive or of result and data
         brreq     x0,x0,looptest        . goto looptest
.
lastbyte entp      x0,7                  . Handle the last bytes
         addr      x0,remaining_bytes    . remaining_bytes := 7 + remaining_bytes
         lbyt,x0   data,p_loc,index,0    . Load the remaining_bytes into data
         xorx      result,data           . result := exclusive or of result and data
done     bss        0                    . All bytes processed
.
         brrne     result,x0,zeroend     . IF result <> 0 goto zeroend
         ente      result,6753(16)       . reset result to arbitrary non-zero number
zeroend  bss        0
         pstorxp   result,sum            . Store result into sum before returning
         return
         page
         align     0,8                   . Allows code to be callable
         use       binding
         address   ce,dfp$compute_checksum
         end                             . dfm$compute_checksum
*DECK DECK=DFM$CRACK_VALUES EXPAND=TRUE
*DECK DECK=DFM$DELETE_TABLES_OF_PARTNER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: Client/Server', EJECT ??
MODULE dfm$delete_tables_of_partner;

{ PURPOSE:
{   This server module contains the code to delete tables associated
{   with a partner (server or client) mainframe.
{
{ DESIGN:
{   Implementation is based upon "undoing" those actions performed by the
{   define_client or define_server command. The served family table on the
{   client cannot be physically deleted since pointers to it may exist in
{   other parts of the system.

?? NEWTITLE := '    Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfc$poll_constants
*copyc dfe$error_condition_codes
*copyc dft$client_mainframe_file
*copyc dft$cpu_queue
*copyc dfv$p_queue_interface_directory
*copyc dfv$server_wired_heap
?? POP ??
*copyc amp$return
*copyc dfp$build_client_mf_file_name
*copyc dfp$change_family_server_state
*copyc dfp$clear_family_queues
*copyc dfp$find_mainframe_id
*copyc dfp$purge_image_file
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pfp$purge
*copyc pfp$purge_catalog

?? TITLE := '    [XDCL] dfp$delete_tables_of_partner', EJECT ??

  PROCEDURE [XDCL] dfp$delete_tables_of_partner
    (    mainframe_name: pmt$mainframe_id;
         host_is_server_to_client: boolean;
     VAR status: ost$status);

    VAR
      active_queue: boolean,
      client_mainframe_name: ost$name,
      cycle_selector: pft$cycle_selector,
      element_name: ost$name,
      i: integer,
      ignore_status: ost$status,
      mainframe_found: boolean,
      next_p_host_app_info: ^dft$host_application_info,
      next_p_remote_app_info: ^dft$remote_application_info,
      mainframe_id: pmt$binary_mainframe_id,
      p_catalog_path: ^pft$path,
      p_cpu_queue: ^dft$cpu_queue,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_host_app_info: ^dft$host_application_info,
      p_remote_app_info: ^dft$remote_application_info,
      p_mainframe_file_path: ^pft$path,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      q_d_index: dft$queue_directory_index,
      queue_index: dft$queue_index,
      queue_entry_index: dft$queue_entry_index,
      server_state: dft$server_state,
      total_queue_entries: dft$queue_entry_index;

    status.normal := TRUE;
    dfp$find_mainframe_id (mainframe_name, host_is_server_to_client, mainframe_found,
          p_queue_interface_table, p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found  THEN
      osp$system_error (' UNKNOWN MAINFRAME - DFP$DELETE_TABLES_OF_PARTNER', NIL);
      RETURN;
    IFEND;
     mainframe_id := p_cpu_queue^.queue_header.destination_mainframe_id;

    server_state := p_cpu_queue^.queue_header.partner_status.server_state;
    IF NOT (server_state IN $dft$server_states [dfc$terminated, dfc$awaiting_recovery] ) THEN
      IF host_is_server_to_client THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$client_not_deleteable, mainframe_name, status);
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_deleteable, mainframe_name, status);
      IFEND;
      RETURN;
    IFEND;

  /check_if_reserved/
    {Since the directory has been searched before, there is no need to check pointers, etc.
    FOR q_d_index := 1 to UPPERBOUND (dfv$p_queue_interface_directory^) DO
      IF dfv$p_queue_interface_directory^ [q_d_index].p_queue_interface_table =
             p_queue_interface_table THEN
        IF dfv$p_queue_interface_directory^ [q_d_index].connection_type <> dfc$esm_connection  THEN
          CYCLE /check_if_reserved/;
        IFEND;
        IF (dfv$p_queue_interface_directory^ [q_d_index].send_pp.p_element_reservations <> NIL)  THEN
          element_name :=dfv$p_queue_interface_directory^ [q_d_index].driver_name;
        ELSE
          element_name := ' ';
        IFEND;
        IF element_name <> ' ' THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$element_still_reserved, mainframe_name,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, element_name, status);
          RETURN;
        IFEND;
        EXIT /check_if_reserved/;
      IFEND;
    FOREND /check_if_reserved/;

    IF (NOT host_is_server_to_client) AND (server_state = dfc$terminated) THEN
      dfp$change_family_server_state (dfc$deleted, p_cpu_queue^.queue_header.destination_mainframe_id);
    IFEND;

    total_queue_entries := p_queue_interface_table^.queue_directory.driver_queue_pva_directory
          [queue_index].p_driver_queue^.queue_header.number_of_queue_entries;

{FREE buffers,etc

    FOR queue_entry_index := 1 TO total_queue_entries DO
      p_cpu_queue_entry := ^p_cpu_queue^.queue_entries [queue_entry_index];
      IF p_cpu_queue_entry^.processor_type = dfc$monitor THEN
        IF p_cpu_queue_entry^.p_server_iocb <> NIL THEN
          FREE p_cpu_queue_entry^.p_server_iocb IN dfv$server_wired_heap^;
        IFEND;
      ELSEIF queue_entry_index <> dfc$poll_queue_index THEN
        FREE p_cpu_queue_entry^.p_send_data IN dfv$server_wired_heap^;
        FREE p_cpu_queue_entry^.p_receive_data IN dfv$server_wired_heap^;
      IFEND;

      p_cpu_queue_entry^.p_data_rma_list := NIL;
      FREE p_cpu_queue_entry^.p_receive_buffer IN dfv$server_wired_heap^;
      FREE p_cpu_queue_entry^.p_send_buffer IN dfv$server_wired_heap^;
    FOREND;

    FREE p_cpu_queue^.queue_header.p_allocated_data_rma_list IN dfv$server_wired_heap^;

    p_host_app_info := p_cpu_queue^.queue_header.p_host_application_info;
    WHILE p_host_app_info <> NIL DO
      IF p_host_app_info^.p_library_file_path <> NIL THEN
        FREE p_host_app_info^.p_library_file_path IN dfv$server_wired_heap^;
      IFEND;
      IF p_host_app_info^.sequence_pointer <> NIL THEN
        FREE p_host_app_info^.sequence_pointer IN dfv$server_wired_heap^;
      IFEND;
      IF p_host_app_info^.p_attached_file_info <> NIL THEN
        FOR i := 1 to UPPERBOUND (p_host_app_info^.p_attached_file_info^) do
          FREE p_host_app_info^.p_attached_file_info^ [i] in dfv$server_wired_heap^;
        FOREND;
        FREE p_host_app_info^.p_attached_file_info IN dfv$server_wired_heap^;
      IFEND;
      next_p_host_app_info := p_host_app_info^.next_p_application_info;
      FREE p_host_app_info IN dfv$server_wired_heap^;
      p_host_app_info := next_p_host_app_info;
    WHILEND;

    p_remote_app_info := p_cpu_queue^.queue_header.p_remote_application_info;
    WHILE p_remote_app_info <> NIL DO
      next_p_remote_app_info := p_remote_app_info^.next_p_application_info;
      FREE p_remote_app_info IN dfv$server_wired_heap^;
      p_remote_app_info := next_p_remote_app_info;
    WHILEND;


    IF p_cpu_queue^.queue_header.p_application_rpc_list <> NIL THEN
      FREE p_cpu_queue^.queue_header.p_application_rpc_list IN dfv$server_wired_heap^;
    IFEND;

    FREE p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].p_cpu_queue IN
          dfv$server_wired_heap^;
    FREE p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue IN
          dfv$server_wired_heap^;
    p_queue_interface_table^.queue_directory.driver_queue_rma_directory [queue_index].driver_queue_rma := 0;

{Current queue of interest has been deleted.  Now check for any remaining active queues.

    active_queue := FALSE;

  /check_for_active_queue/
    FOR queue_index := 1 TO p_queue_interface_table^.queue_directory.number_of_queues DO
      active_queue := p_queue_interface_table^.queue_directory.driver_queue_rma_directory [queue_index].
            driver_queue_rma <> 0;
      IF active_queue THEN
        EXIT /check_for_active_queue/;
      IFEND;
    FOREND /check_for_active_queue/;

    IF NOT active_queue THEN
      FREE p_queue_interface_table^.request_buffer_directory.p_request_buffer IN dfv$server_wired_heap^;
      p_q_interface_directory_entry^.p_queue_interface_table := NIL;
      FREE p_queue_interface_table IN dfv$server_wired_heap^;
      p_q_interface_directory_entry^.driver_name := ' ';

    /check_directory/
      BEGIN
        FOR q_d_index := 1 TO UPPERBOUND (dfv$p_queue_interface_directory^) DO
          IF dfv$p_queue_interface_directory^ [q_d_index].p_queue_interface_table <> NIL THEN
            EXIT /check_directory/;
          IFEND;
        FOREND;
        FREE dfv$p_queue_interface_directory IN dfv$server_wired_heap^;
        dfv$p_queue_interface_directory := NIL;
      END /check_directory/;
    IFEND;

    IF server_state = dfc$terminated THEN
      IF host_is_server_to_client THEN
        dfp$build_client_mf_file_name (mainframe_name, client_mainframe_name);
        amp$return (client_mainframe_name, ignore_status);
        PUSH p_mainframe_file_path: [1 .. 4];
        p_mainframe_file_path^ [1] := ' ';
        p_mainframe_file_path^ [2] := ' ';
        p_mainframe_file_path^ [3] := dfc$client_mainframe_catalog;
        p_mainframe_file_path^ [4] := client_mainframe_name;
        cycle_selector.cycle_option := pfc$specific_cycle;
        cycle_selector.cycle_number := 1;
        pfp$purge (p_mainframe_file_path^, cycle_selector, osc$null_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE { Client to server
        dfp$purge_image_file (mainframe_id, status);
      IFEND;
    ELSE { awaiting_recovery
      IF NOT host_is_server_to_client THEN
       dfp$clear_family_queues (mainframe_id);
      IFEND;
    IFEND;
  PROCEND dfp$delete_tables_of_partner;

MODEND dfm$delete_tables_of_partner;
*DECK DECK=DFM$DFTU EXPAND=TRUE


*DECK DECK=DFM$DOIT EXPAND=TRUE
PROCEDURE doit (
  destination_mainframe_is, dmi: key
      (client, c)
      (server, s)
      (loop, l)
    keyend = loop
  destination_mainframe_id, dmid: name 1..17 = $optional
  number_of_monitor_queue_entries, nomqe: integer 0..126 = 50
  number_of_task_queue_entries, notqe: integer 1..126 = 4
  number_of_pps, nopp: key
      one, dual
    keyend = one
  dma: boolean = TRUE
  new_send_channel, nsc: name 3..6 = $optional
  new_receive_channel, nrc: name 3..6 = $optional
  divisions_per_mainframe, dpm: integer 1..16 = 8
  timeout_interval, ti: integer 1..255 = 10
  maximum_request_timeout_count, mrtc: integer 1..255 = 5
  maximum_retransmission_count, mrc: integer 1..255 = 5
  activate, a: boolean = TRUE
  define_served_family, defsf: boolean = FALSE
  family_name, fn: any of
      key
        none
      keyend
      name
    anyend = $optional
  family_access, fa: key
      (file_access, fa)
      (leveled_access, la)
      (login, l)
      none
    keyend = login
  data_transfer_size, dts: key
      #16k, #32k, #65k, #131k, #262k
    keyend = #262k
  side_door_port, sdp: list 0..2 of list 1..3 of name = () " Hardcoded defaults used if () and running on VIOLET, COBALT "
  preallocate_image_size, pis: integer = 0
  change_eval_ring, cer: boolean = FALSE  " Allows UUTL IOTESTP to run. Do 1st time only."
  system_debug_ring, sdr: integer 0..15 = 6
  gen_application_support_procs, gasp: boolean = FALSE
  status)

" This procedure provides the information needed to define the file server connections for the NOS/VE
" development hands-on mainframes.
" This procedure defines one connection to another mainframe.  In loopback mode both client and server
" are defined.
" Changes in this procedure should be reflected in the test procedures TTM$DEFINE_A_CLIENT and
" TTM$DEFINE_A_SERVER.

  "$FORMAT=OFF"
  VAR
    accessed_family: name
    destination_mainframe_name: name
    ignore: status
    iou: name = $name('IOU0')    "    Note that COBALT uses channels on IOU1, not IOU0."
    receive_channel: name
    send_channel: name
    served_family: name
    source_id_number: integer
    stornet_status: status
    test_loopback: (XDCL) string
  VAREND
  "$FORMAT=ON"

" ======= BASIC SETUP COMMANDS =========================================

  set_system_attribute enable_pm_debug_logging 1 status=ignore
  set_system_attribute system_debug_ring system_debug_ring status=ignore
  IF ignore.normal THEN
    display_value ' System_debug_ring =  '//system_debug_ring o=$response
  IFEND

  set_system_attribute file_server_debug_enabled 1 status=ignore
  IF ignore.normal THEN
    display_value ' File_Server_Debug_Enabled ' o=$response
  IFEND

" This allows more tests to run - namely the UUTL test IOTESTP

  IF change_eval_ring THEN
    ADMINISTER_VALIDATION
      use_validation_file :testing.$system.$validations
      CHANGE_USER eval
        change_ring_privilege minr=6
      QUIT
    QUIT
  IFEND

  include_line 'ved file_server ' status=ignore
  ignore.normal = true

" Turn on the equipment.

  display_value ' Turning STORNET on...' o=$response
  LOGICAL_CONFIGURATION_UTILITY
    change_element_state stornet state=on
  QUIT

" Create variables which enable easier testing.

  IF NOT $variable(cl, defined) THEN
    "$FORMAT=OFF"
    VAR
      cl: (JOB) name = $name($mainframe(id))
    VAREND
    "$FORMAT=ON"
  IFEND
  IF NOT $variable(s, defined) THEN
    "$FORMAT=OFF"
    VAR
      s: (JOB) name = $SYSTEM_0990_7777
    VAREND
    "$FORMAT=ON"
  IFEND

" ===== DEFINE_STORNET_CONNECTION =====================================
"  STORNET WORDS -
"          DECIMAL       OCTAL
"         --------      -------
"           524288      2000000
"          1048576      4000000
"          2097152     10000000        Any value larger than 8388608(10)
"          4194304     20000000        requires that the half_ecs_switch
"          8388608     40000000        parameter value be TRUE.
"         16777216    100000000

  base_flag = 0
" Note that STORNET base_address must be multiple of 1000 octal, or zero.
  base_address = 0
  display_value ' Defining STORNET connection...' o=$response
  IF NOT $nil(side_door_port) THEN
    "$FORMAT=OFF"
    define_stornet_connection ..
          element_name=stornet ..
          memory_size=4194304 ..
          memory_base=base_address ..
          flag_base=base_flag ..
          half_ecs_switch=no ..
          number_of_mainframes=8 ..
          divisions_per_mainframe=divisions_per_mainframe ..
          data_transfer_size= data_transfer_size ..
          side_door_port = side_door_port ..
          status=stornet_status
    "$FORMAT=ON"
  ELSEIF $mainframe(id) = '$SYSTEM_0860_0302' THEN
    "$FORMAT=OFF"
    define_stornet_connection ..
          element_name=stornet ..
          memory_size=4194304 ..
          memory_base=base_address ..
          flag_base=base_flag ..
          half_ecs_switch=no ..
          number_of_mainframes=8 ..
          divisions_per_mainframe=divisions_per_mainframe ..
          data_transfer_size= data_transfer_size ..
          side_door_port = ((ch24 $system_0860_0302 iou0)) ..
          status=stornet_status
    "$FORMAT=ON"
  ELSEIF $mainframe(id) = '$SYSTEM_9603_0102' THEN
    "$FORMAT=OFF"
    define_stornet_connection ..
          element_name=stornet ..
          memory_size=4194304 ..
          memory_base=base_address ..
          flag_base=base_flag ..
          half_ecs_switch=no ..
          number_of_mainframes=8 ..
          divisions_per_mainframe=divisions_per_mainframe ..
          data_transfer_size= data_transfer_size ..
          side_door_port = ((cch18 $system_9603_0102 iou1)) ..
          status=stornet_status
    "$FORMAT=ON"
  ELSE
    "$FORMAT=OFF"
    define_stornet_connection ..
          element_name=stornet ..
          memory_size=4194304 ..
          memory_base=base_address ..
          flag_base=base_flag ..
          half_ecs_switch=no ..
          number_of_mainframes=8 ..
          divisions_per_mainframe=divisions_per_mainframe ..
          data_transfer_size= data_transfer_size ..
          status=stornet_status
    "$FORMAT=ON"
  IFEND

  IF NOT stornet_status.normal THEN
    IF $condition_name(stornet_status.condition) = 'DFE$STORNET_ALREADY_DEFINED' THEN
      display_value ' Stornet already defined - Continuing with defining client/server ' o=$response
    ELSE
      EXIT_PROC WITH stornet_status
    IFEND
  IFEND

" ==== DETERMINE DESTINATION MAINFRAME =======================

  IF $specified(destination_mainframe_id) THEN
    destination_mainframe_name = destination_mainframe_id
  ELSEIF destination_mainframe_is = 'LOOP' THEN
    destination_mainframe_name = $name($mainframe(id))
  ELSE " Default mainframe id
    IF $mainframe(id) = '$SYSTEM_0860_0302' THEN
      destination_mainframe_name = $name('$SYSTEM_0830_0604')
    ELSE
      destination_mainframe_name = $name('$SYSTEM_0860_0302')
    IFEND
  IFEND

" ======== DETERMINE ID AND CHANNELS   =========================

" Unless number_of_pps parameter is 'DUAL' the SEND channel is used in
" single PP configuration for both sending ang receiving.

  " === Default values for $SYSTEM_0860_0302 ( VIOLET ) ===
  midn_0860_0302 = 1
  snd_ch_0860_0302 = $name('CCH0a')
  rcv_ch_0860_0302 = $name('CH24')

  " === Default values for $SYSTEM_9603_0102 ( COBALT ) ===
  midn_9603_0102 = 2
  snd_ch_9603_0102 = $name('CCH5')
  rcv_ch_9603_0102 = $name('CCH18')

  " === Default values for $SYSTEM_0830_0604 ( RED ) ===
  midn_0830_0604 = 3
  snd_ch_0830_0604 = $name('CH9')
  rcv_ch_0830_0604 = $name('CH9')

  " === Default values for $SYSTEM_9303_0121 ( PEWTER ) ===
  midn_9303_0121 = 4
  snd_ch_9303_0121 = $name('CH2')
  rcv_ch_9303_0121 = $name('CH2')

  " === Default values for $SYSTEM_0835_0104 ( MAUVE ) ===
  midn_0835_0104 = 5
  snd_ch_0835_0104 = $name('CH3')
  rcv_ch_0835_0104 = $name('CH3')

  " === Default values for $SYSTEM_20S1_0101/$SYSTEM_20V1_0101 ( ZUBA ) ===
  midn_20s1_0101 = 6
  snd_ch_20s1_0101 = $name('CCH16')
  rcv_ch_20s1_0101 = $name('CCH16')

  IF $mainframe(id) = '$SYSTEM_0860_0302' THEN
    source_id_number = midn_0860_0302
    accessed_family = $name('TESTVE860302')
    IF $specified(new_send_channel) THEN
      snd_ch_0860_0302 = new_send_channel
    IFEND
    IF $specified(new_receive_channel) THEN
      rcv_ch_0860_0302 = new_receive_channel
    IFEND
    send_channel = snd_ch_0860_0302
    IF number_of_pps = 'DUAL' THEN
      receive_channel = rcv_ch_0860_0302
    ELSE
      IF dma THEN
        " Since we just happen to know that the default send channel is DMA -
        " (assumes default send channel is dma)"
        send_channel = snd_ch_0860_0302
      IFEND
      receive_channel = send_channel
    IFEND

  ELSEIF $mainframe(id) = '$SYSTEM_9603_0102' THEN
  "    Note that COBALT uses channels on IOU1, not IOU0.
    iou = $name('IOU1')
    source_id_number = midn_9603_0102
    accessed_family = $name('TESTVE960102')
    IF $specified(new_send_channel) THEN
      snd_ch_9603_0102 = new_send_channel
    IFEND
    IF $specified(new_receive_channel) THEN
      rcv_ch_9603_0102 = new_receive_channel
    IFEND
    send_channel = snd_ch_9603_0102
    IF number_of_pps = 'DUAL' THEN
      receive_channel = rcv_ch_9603_0102
    ELSE
      IF dma THEN
        " Since we just happen to know that the default send channel is DMA -
        " (assumes default send channel is dma)"
        send_channel = rcv_ch_9603_0102
      IFEND
      receive_channel = send_channel
    IFEND

  ELSEIF $mainframe(id) = '$SYSTEM_0830_0604' THEN
    accessed_family = $name('TESTVE830604')
    IF $specified(new_send_channel) THEN
      snd_ch_0830_0604 = new_send_channel
    IFEND
    IF $specified(new_receive_channel) THEN
      rcv_ch_0830_0604 = new_receive_channel
    IFEND
    source_id_number = midn_0830_0604
    send_channel = snd_ch_0830_0604
    IF number_of_pps = 'DUAL' THEN
      receive_channel = rcv_ch_0830_0604
    ELSE
      receive_channel = send_channel
    IFEND

  ELSEIF $mainframe(id) = '$SYSTEM_9303_0121' THEN
    source_id_number = midn_9303_0121
    accessed_family = $name('TESTVE930121')
    IF $specified(new_send_channel) THEN
      snd_ch_9303_0121 = new_send_channel
    IFEND
    IF $specified(new_receive_channel) THEN
      rcv_ch_9303_0121 = new_receive_channel
    IFEND
    send_channel = snd_ch_9303_0121
    IF number_of_pps = 'DUAL' THEN
      receive_channel = rcv_ch_9303_0121
    ELSE
      receive_channel = send_channel
    IFEND

  ELSEIF $mainframe(id) = '$SYSTEM_0835_0104' THEN
    source_id_number = midn_0835_0104
    accessed_family = $name('TESTVE835104')
    IF $specified(new_send_channel) THEN
      snd_ch_0835_0104 = new_send_channel
    IFEND
    IF $specified(new_receive_channel) THEN
      rcv_ch_0835_0104 = new_receive_channel
    IFEND
    send_channel = snd_ch_0835_0104
    IF number_of_pps = 'DUAL' THEN
      receive_channel = rcv_ch_0835_0104
    ELSE
      receive_channel = send_channel
    IFEND

    ELSEIF $mainframe(id) = '$SYSTEM_20S1_0101' THEN
      source_id_number = midn_20s1_0101
      accessed_family = $name('TESTVE20S101')
      IF $specified(new_send_channel) THEN
        snd_ch_20s1_0101 = new_send_channel
      IFEND
      IF $specified(new_receive_channel) THEN
        rcv_ch_20s1_0101 = new_receive_channel
      IFEND
      send_channel = snd_ch_20s1_0101
      IF number_of_pps = 'DUAL' THEN
        receive_channel = rcv_ch_20s1_0101
      ELSE
        IF dma THEN
          " Since we just happen to know that the default send channel is DMA -
          " (assumes default send channel is dma)"
          send_channel = snd_ch_20s1_0101
        IFEND
        receive_channel = send_channel
      IFEND

    ELSEIF $mainframe(id) = '$SYSTEM_20V1_0101' THEN
      source_id_number = midn_20s1_0101
      accessed_family = $name('TESTVE20V101')
      IF $specified(new_send_channel) THEN
        snd_ch_20s1_0101 = new_send_channel
      IFEND
      IF $specified(new_receive_channel) THEN
        rcv_ch_20s1_0101 = new_receive_channel
      IFEND
      send_channel = snd_ch_20s1_0101
      IF number_of_pps = 'DUAL' THEN
        receive_channel = rcv_ch_20s1_0101
      ELSE
        IF dma THEN
          " Since we just happen to know that the default send channel is DMA -
          " (assumes default send channel is dma)"
          send_channel = snd_ch_20s1_0101
        IFEND
        receive_channel = send_channel
      IFEND

  ELSE
    EXIT_PROC WITH $status(false, 'DF', 333, ' --- Unknown mainframe: '//$name($mainframe(id)))
  IFEND

  display_value ' Send channel = '//send_channel o=$response
  display_value ' Receive channel = '//receive_channel o=$response

  IF destination_mainframe_name = '$SYSTEM_0860_0302' THEN
    destination_id_number = midn_0860_0302
    served_family = $name('TESTVE860302')
  ELSEIF destination_mainframe_name = '$SYSTEM_0830_0604' THEN
    destination_id_number = midn_0830_0604
    served_family = $name('TESTVE830604')
  ELSEIF destination_mainframe_name = '$SYSTEM_9603_0102' THEN
    destination_id_number = midn_9603_0102
    served_family = $name('TESTVE960102')
  ELSEIF destination_mainframe_name = '$SYSTEM_9303_0121' THEN
    destination_id_number = midn_9303_0121
    served_family = $name('TESTVE930121')
  ELSEIF destination_mainframe_name = '$SYSTEM_0835_0104' THEN
    destination_id_number = midn_0835_0104
    served_family = $name('TESTVE835104')
  ELSEIF destination_mainframe_name = '$SYSTEM_20S1_0101' THEN
    destination_id_number = midn_20s1_0101
    served_family = $name('TESTVE20S101')
  ELSEIF destination_mainframe_name = '$SYSTEM_20V1_0101' THEN
    destination_id_number = midn_20s1_0101
    served_family = $name('TESTVE20V101')
  ELSE
    EXIT_PROC WITH $status(false, 'DF', 333, ..
          ' --- Unknown destination mainframe: '//destination_mainframe_name)
  IFEND

  IF destination_mainframe_is = 'LOOP' THEN
" NOTE: SERVER mainframe name is hard-coded in the deck DFC$LOOPBACK_MAINFRAME_NAME "
    destination_mainframe_name = $name('$SYSTEM_0990_7777')
    served_family = $name('TESTING')
    accessed_family = $name('TESTING')
  IFEND

" ======== DEFINE CLIENT OR SERVER AS NEEDED ==================

  IF destination_mainframe_is = 'SERVER' THEN
    display_value ' Defining server: '//destination_mainframe_name o=$response
    s = destination_mainframe_name
    "$FORMAT=OFF"
    define_server  ..
          server_mainframe_identifier= destination_mainframe_name ..
          client_id_number= source_id_number ..
          server_id_number= destination_id_number ..
          number_of_monitor_queue_entries= number_of_monitor_queue_entries ..
          number_of_task_queue_entries= number_of_task_queue_entries ..
          connection_type= stornet ..
          element_name= stornet ..
          send_channel= (send_channel, iou) ..
          receive_channel= (receive_channel, iou) ..
          dma_available= dma ..
          timeout_interval= timeout_interval ..
          maximum_request_timeout_count= maximum_request_timeout_count ..
          maximum_retransmission_count= maximum_retransmission_count..
          users_wait_on_terminated= FALSE ..
          preallocate_image_size= preallocate_image_size
    "$FORMAT=ON"

    IF define_served_family THEN
      define_served_family server_mainframe_identifier=destination_mainframe_name family=served_family
    IFEND
  IFEND

  IF destination_mainframe_is = 'CLIENT' THEN
    IF $specified(family_name) THEN
      IF family_name <> 'NONE' THEN
        display_value ' Changing client access...' o=$response
        "$FORMAT=OFF"
        change_client_access ..
              client_mainframe_identifier=destination_mainframe_name ..
              family=family_name ..
              family_access=family_access ..
              status=ignore
        "$FORMAT=ON"
        IF NOT ignore.normal THEN
          display_value ' -- WARNING -- CHANGE_CLIENT_ACCESS encountered the following error:' o=$response
          display_value ignore o=$response
          display_value '   Continuing with procedure DOIT...' o=$response
        IFEND
      IFEND
    ELSE
      display_value ' Changing client access...' o=$response
      "$FORMAT=OFF"
      change_client_access ..
            client_mainframe_identifier=destination_mainframe_name ..
            family=accessed_family ..
            family_access=family_access ..
            status=ignore
      "$FORMAT=ON"
      IF NOT ignore.normal THEN
        display_value ' -- WARNING -- CHANGE_CLIENT_ACCESS encountered the following error:' o=$response
        display_value ignore o=$response
        display_value '   Continuing with procedure DOIT...' o=$response
      IFEND
    IFEND

    display_value ' Defining client: '//destination_mainframe_name o=$response
    cl = destination_mainframe_name
    "$FORMAT=OFF"
    define_client ..
          client_mainframe_identifier=destination_mainframe_name ..
          client_id_number= destination_id_number ..
          server_id_number= source_id_number ..
          number_of_monitor_queue_entries= number_of_monitor_queue_entries ..
          number_of_task_queue_entries= number_of_task_queue_entries ..
          connection_type= stornet ..
          element_name= stornet ..
          send_channel= (send_channel, iou) ..
          receive_channel= (receive_channel, iou) ..
          dma_available= dma
    "$FORMAT=ON"
  IFEND

  IF destination_mainframe_is = 'LOOP' THEN
    IF $specified(family_name) THEN
      IF family_name <> 'NONE' THEN
        display_value ' Changing client access...' o=$response
        "$FORMAT=OFF"
        change_client_access ..
              client_mainframe_identifier=$name($mainframe(id)) ..
              family=family_name ..
              family_access=family_access ..
              status=ignore
        "$FORMAT=ON"
        IF NOT ignore.normal THEN
          display_value ' -- WARNING -- CHANGE_CLIENT_ACCESS encountered the following error:' o=$response
          display_value ignore o=$response
          display_value '   Continuing with procedure DOIT...' o=$response
        IFEND
      IFEND
    ELSE
      display_value ' Changing client access...' o=$response
      "$FORMAT=OFF"
      change_client_access ..
            client_mainframe_identifier=$name($mainframe(id)) ..
            family=accessed_family ..
            family_access=family_access ..
            status=ignore
      "$FORMAT=ON"
      IF NOT ignore.normal THEN
        display_value ' -- WARNING -- CHANGE_CLIENT_ACCESS encountered the following error:' o=$response
        display_value ignore o=$response
        display_value '   Continuing with procedure DOIT...' o=$response
      IFEND
    IFEND

    display_value ' Defining client: '//$mainframe(id) o=$response
    cl = $name($mainframe(id))
    "$FORMAT=OFF"
    define_client ..
          client_mainframe_identifier= $name($mainframe(id)) ..
          number_of_monitor_queue_entries= number_of_monitor_queue_entries ..
          number_of_task_queue_entries= number_of_task_queue_entries ..
          connection_type= stornet ..
          element_name= stornet ..
          send_channel= (send_channel, iou) ..
          receive_channel= (receive_channel, iou) ..
          client_id_number= source_id_number ..
          server_id_number= source_id_number ..
          dma_available= dma
    "$FORMAT=ON"

    display_value ' Defining server: '//destination_mainframe_name o=$response
    s = destination_mainframe_name
    "$FORMAT=OFF"
    define_server  ..
          server_mainframe_identifier=destination_mainframe_name ..
          client_id_number= source_id_number ..
          server_id_number= source_id_number  ..
          number_of_monitor_queue_entries= number_of_monitor_queue_entries ..
          number_of_task_queue_entries= number_of_task_queue_entries ..
          connection_type= stornet ..
          element_name= stornet ..
          send_channel= (send_channel, iou) ..
          receive_channel= (receive_channel, iou) ..
          dma_available= dma ..
          timeout_interval= timeout_interval ..
          maximum_request_timeout_count= maximum_request_timeout_count ..
          maximum_retransmission_count= maximum_retransmission_count ..
          users_wait_on_terminated= FALSE ..
          preallocate_image_size= preallocate_image_size
    "$FORMAT=ON"

    IF define_served_family THEN
      define_served_family server_mainframe_identifier=destination_mainframe_name family=testing
    IFEND
  IFEND

  IF (destination_mainframe_is = 'LOOP') OR (destination_mainframe_is = 'CLIENT') THEN
    IF gen_application_support_procs THEN
      TASK r=3
        copy_file $user.osf$builtin_library $user.doit_app_lib
        change_file_attributes $user.doit_app_lib ra=(3, 3, 3) status=ignore
      TASKEND
      IF ignore.normal THEN
        "$FORMAT=OFF"
        define_application_rpc ..
               application_name=doit_app ..
               library=$user.doit_app_lib ..
               remote_procedure=((dfp$server_test_app_support, false, cwfv, false, 11, true)) ..
               client_mainframe_identifier=cl ..
               state_change_procedure=dfp$scp1 ..
               status=ignore
        "$FORMAT=ON"
      IFEND
      IF ignore.normal THEN
        display_value ' DOIT_APP defined' o=$response
      ELSE
        display_value ignore o=$response
        ignore.normal = true
      IFEND
    IFEND
  IFEND

  IF activate THEN
    IF destination_mainframe_is = 'SERVER' THEN
      display_value ' Activating server: '//destination_mainframe_name o=$response
      activate_server destination_mainframe_name
    IFEND

    IF destination_mainframe_is = 'CLIENT' THEN
      display_value ' Activating client: '//destination_mainframe_name o=$response
      activate_client destination_mainframe_name
    IFEND

    IF destination_mainframe_is = 'LOOP' THEN
      display_value ' Activating client: '//$mainframe(id) o=$response
      activate_client $name($mainframe(id))

      display_value ' Activating server: '//destination_mainframe_name o=$response
      activate_server destination_mainframe_name
    IFEND
  IFEND

  display_value ' Setting queue location...' o=$response
  include_line 'set_queue_location stornet send_channel source_id_number ' status=ignore

  display_value ' Procedure DOIT complete.' o=$response

PROCEND doit
*DECK DECK=DFM$DOIT_MOCK EXPAND=TRUE
PROC doit_mock (
  this_mainframe_is, tmi    : key client, server, both, loop = loop
  connection_type, ct       : key mock, cdcnet = mock
   status                    : var of status = $optional
  )

  ELSEIF $string($value(connection_type)) = 'MOCK' THEN
    IF $string($value(this_mainframe_is)) <> 'LOOP' THEN
      EXIT_PROC WITH $status(false, 'GS', 01, 'LOOP REQUIRED WITH MOCK')
    IFEND
    define_client $name(clienta) 1 2 $value(mqe) $value(tqe) mock mock_driver
    define_server (testve608 testing) $name(servera) 1 2 $value(mqe) $value(tqe) mock ..
          mock_driver ..
          $value(ti) $value(mrtc) $value(mrc)
    disv ' Activation of client and server required '
    initiate_test_driver
    set_queue_location mock, mock_driver 1
COLLECT_TEXT, mock_driver
    task,mock_driver
      execute_task sp=dfp$initiate_test_driver p='c=on'
    taskend
**
    disv ' Include_file mock_driver '
  ELSE " CDCNET "
    " Get the file server applications registered with cdcnet "
    IF $job(user) = '$SYSTEM' THEN
      MANAGE_NETWORK_APPLICATIONS
        IF ($string($value(this_mainframe_is)) = 'CLIENT') THEN
          client_title = 'DF_CLIENT_1'
        ELSEIF ($string($value(this_mainframe_is)) = 'SERVER') THEN
          server_title = 'DF_SERVER_1'
        ELSE " LOOP "
          client_title = 'DF_CLIENT_1'
          server_title = 'DF_SERVER_1'
        IFEND

        create_variable server_title_status status
        IF ($string($value(this_mainframe_is)) = 'LOOP') OR ..
              ($string($value(this_mainframe_is)) = 'SERVER') THEN
          display_server_status $name(server_title) status=server_title_status
          IF server_title_status.normal THEN
            disv 'server already registered '//server_title
          ELSE
            DEFINE_SERVER $name(server_title) protocol=cdna_session ..
                  nam_initiated=false
              add_title $name(server_title)
              change_accept_connection true
            QUIT
            activate_server $name(server_title)
            display_server_status
          IFEND
        IFEND

        IF ($string($value(this_mainframe_is)) = 'LOOP') OR ..
              ($string($value(this_mainframe_is)) = 'CLIENT') THEN
          display_client_status $name(client_title) status=server_title_status
          IF server_title_status.normal THEN
            disv ' client already registered '//client_title
          ELSE
            DEFINE_CLIENT $name(client_title) protocol=cdna_session
            QUIT
            activate_client $name(client_title)
            display_client_status
          IFEND
        IFEND
      QUIT
    IFEND
    " Register the client/server with the file server "

COLLECT_TEXT, server_task sm='%'
  task,server
    exet sp=dftu
      define_client %clienta% 1 1 %$strrep($value(mqe))%  %$strrep($value(tqe))% cdcnet cdcnet_server
      execd
  taskend
**

COLLECT_TEXT, client_task sm='%'
  task,client
    exet sp=dftu
      define_server (testve608 testing) %servera% 1 1 %$strrep($value(mqe))% %$strrep($value(tqe))% ..
        cdcnet cdcnet_client ..
        $value(ti) $value(mrtc) $value(mrc)
      execd
  taskend
**

    IF $string($value(this_mainframe_is)) = 'CLIENT' THEN
      disv ' Include_file client_task '
    ELSEIF $string($value(this_mainframe_is)) = 'SERVER' THEN
      disv ' Include_file server_task '
    ELSE "LOOP "
      disv ' Include_file server_task '
      disv ' Include_file client_task '
    IFEND
  IFEND

 PROCEND doit_mock;
*DECK DECK=DFM$DRIVER_TEST_UTILITY EXPAND=TRUE
?? RIGHT := 110 ??
MODULE dfm$driver_test_utility;
{
{   This module contains subcommands for testing the file server.
{

?? PUSH (LISTEXT := ON) ??
*copyc amp$close
*copyc amp$fetch
*copyc amp$get_next
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$put_next
*copyc clp$convert_integer_to_string
*copyc clp$end_scan_command_file
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$pop_utility
*copyc clp$push_parameters
*copyc clp$push_utility
*copyc clp$scan_command_file
*copyc clp$scan_parameter_list
*copyc cmt$element_definition
*copyc dfd$driver_queue_types
*copyc dfd$request_package
*copyc dft$rpc_buffer_header
*copyc dfe$error_condition_codes
*copyc dfi$display
*copyc dfp$fetch_qit
*copyc dfp$file_server_display
*copyc dfp$flush_served_family_table
*copyc dfp$log_side_door_port_status
*copyc dfp$verify_system_administrator
*copyc dfs$server_wired
*copyc dft$assign_queue_entry_status
*copyc dft$cpu_queue
*copyc dft$poll_header
*copyc dft$rpc_test_request_header
*copyc dft$queue_entry_type
*copyc dfv$server_wired_heap
*copyc fsp$close_file
*copyc fsp$open_file
*copyc jmp$convert_date_time_to_clock
*copyc osp$clear_locked_variable
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$fetch_locked_variable
*copyc osp$reset_heap
*copyc osp$set_status_abnormal
*copyc oss$job_paged_literal
*copyc osv$page_size
*copyc osv$task_private_heap
*copyc pmp$compute_date_time
*copyc pmp$convert_binary_unique_name
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pmp$get_compact_date_time
*copyc syp$increment_server_file_count
*copyc syp$decrement_server_file_count
?? POP ??



{ table file_server_commands type=command  sn=oss$job_paged_literal
{ command (activate_pp actpp) dfp$activate_pp_command xref
{ command (display_operator_display, disod) dfp$display_operator_display   ..
{       local
{ command (display_queue, disqe, disq) dfp$display_queue local
{ command (display_queue_header, disqh) dfp$display_queue_header local
{ command (display_server_state, disss) dfp$display_server_state local
{ command (display_transfer_rate, distr) dfp$display_transfer_rate local
{ command (end_client, endc) dfp$end_client xref
{ command (end_server, ends) dfp$end_server xref
{ command (execute_cdcnet_driver, execd) dfp$execute_cdcnet_driver cm=xref
{ command (flush_served_family_table, flusft) flush_family_table local
{ command (get_client_mainframe_file, getcmf)       ..
{   dfp$get_client_mainframe_file cm=xref
{ command (initiate_pp inipp) dfp$store_p_qit xref
{ command (initiate_test_driver, initd) dfp$initiate_test_driver xref
{ command (log_side_door_port_status, logsdps) log_side_door_port local
{ command (quit, qui) quit_command local
{ command (reset_transfer_rate, restr) dfp$reset_transfer_rate local
{ command (send_poll, senp) dfp$manage_server_connection xref
{ command (send_remote_command_line, senrcl) dfp$send_remote_command_line  ..
{        xref
{ command (send_remote_message, senrm) dfp$send_remote_message xref
{ command (send_test, sent) dfp$send_test_command xref
{ command (set_queue_location, setql) dfp$set_queue_location local
{ command (test_application_support, tesas) dfp$client_test_app_sup_r3 xref
{ command (test_remote_procedure_call, tesrpc)       ..
{   dfp$test_remote_procedure_call xref
{ command (terminate_client_job, tercj) dfp$terminate_client_job xref
{ command (verify_client_jobs, vercj) dfp$verify_client_jobs xref
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  file_server_commands: [STATIC, READ, oss$job_paged_literal]
      ^clt$command_table := ^file_server_commands_entries,

  file_server_commands_entries: [STATIC, READ, oss$job_paged_literal]
      array [1 .. 51] of clt$command_table_entry := [
  {} ['ACTIVATE_PP                    ', clc$nominal_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^dfp$activate_pp_command],
  {} ['ACTPP                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^dfp$activate_pp_command],
  {} ['DISOD                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^dfp$display_operator_display],
  {} ['DISPLAY_OPERATOR_DISPLAY       ', clc$nominal_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^dfp$display_operator_display],
  {} ['DISPLAY_QUEUE                  ', clc$nominal_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^dfp$display_queue],
  {} ['DISPLAY_QUEUE_HEADER           ', clc$nominal_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^dfp$display_queue_header],
  {} ['DISPLAY_SERVER_STATE           ', clc$nominal_entry,
        clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
        ^dfp$display_server_state],
  {} ['DISPLAY_TRANSFER_RATE          ', clc$nominal_entry,
        clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
        ^dfp$display_transfer_rate],
  {} ['DISQ                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^dfp$display_queue],
  {} ['DISQE                          ', clc$alias_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^dfp$display_queue],
  {} ['DISQH                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^dfp$display_queue_header],
  {} ['DISSS                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
        ^dfp$display_server_state],
  {} ['DISTR                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
        ^dfp$display_transfer_rate],
  {} ['ENDC                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
        ^dfp$end_client],
  {} ['ENDS                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 8, clc$automatically_log, clc$linked_call,
        ^dfp$end_server],
  {} ['END_CLIENT                     ', clc$nominal_entry,
        clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
        ^dfp$end_client],
  {} ['END_SERVER                     ', clc$nominal_entry,
        clc$normal_usage_entry, 8, clc$automatically_log, clc$linked_call,
        ^dfp$end_server],
  {} ['EXECD                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 9, clc$automatically_log, clc$linked_call,
        ^dfp$execute_cdcnet_driver],
  {} ['EXECUTE_CDCNET_DRIVER          ', clc$nominal_entry,
        clc$normal_usage_entry, 9, clc$automatically_log, clc$linked_call,
        ^dfp$execute_cdcnet_driver],
  {} ['FLUSFT                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 10, clc$automatically_log, clc$linked_call,
        ^flush_family_table],
  {} ['FLUSH_SERVED_FAMILY_TABLE      ', clc$nominal_entry,
        clc$normal_usage_entry, 10, clc$automatically_log, clc$linked_call,
        ^flush_family_table],
  {} ['GETCMF                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 11, clc$automatically_log, clc$linked_call,
        ^dfp$get_client_mainframe_file],
  {} ['GET_CLIENT_MAINFRAME_FILE      ', clc$nominal_entry,
        clc$normal_usage_entry, 11, clc$automatically_log, clc$linked_call,
        ^dfp$get_client_mainframe_file],
  {} ['INIPP                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 12, clc$automatically_log, clc$linked_call,
        ^dfp$store_p_qit],
  {} ['INITD                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 13, clc$automatically_log, clc$linked_call,
        ^dfp$initiate_test_driver],
  {} ['INITIATE_PP                    ', clc$nominal_entry,
        clc$normal_usage_entry, 12, clc$automatically_log, clc$linked_call,
        ^dfp$store_p_qit],
  {} ['INITIATE_TEST_DRIVER           ', clc$nominal_entry,
        clc$normal_usage_entry, 13, clc$automatically_log, clc$linked_call,
        ^dfp$initiate_test_driver],
  {} ['LOGSDPS                        ', clc$abbreviation_entry,
        clc$normal_usage_entry, 14, clc$automatically_log, clc$linked_call,
        ^log_side_door_port],
  {} ['LOG_SIDE_DOOR_PORT_STATUS      ', clc$nominal_entry,
        clc$normal_usage_entry, 14, clc$automatically_log, clc$linked_call,
        ^log_side_door_port],
  {} ['QUI                            ', clc$abbreviation_entry,
        clc$normal_usage_entry, 15, clc$automatically_log, clc$linked_call,
        ^quit_command],
  {} ['QUIT                           ', clc$nominal_entry,
        clc$normal_usage_entry, 15, clc$automatically_log, clc$linked_call,
        ^quit_command],
  {} ['RESET_TRANSFER_RATE            ', clc$nominal_entry,
        clc$normal_usage_entry, 16, clc$automatically_log, clc$linked_call,
        ^dfp$reset_transfer_rate],
  {} ['RESTR                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 16, clc$automatically_log, clc$linked_call,
        ^dfp$reset_transfer_rate],
  {} ['SEND_POLL                      ', clc$nominal_entry,
        clc$normal_usage_entry, 17, clc$automatically_log, clc$linked_call,
        ^dfp$manage_server_connection],
  {} ['SEND_REMOTE_COMMAND_LINE       ', clc$nominal_entry,
        clc$normal_usage_entry, 18, clc$automatically_log, clc$linked_call,
        ^dfp$send_remote_command_line],
  {} ['SEND_REMOTE_MESSAGE            ', clc$nominal_entry,
        clc$normal_usage_entry, 19, clc$automatically_log, clc$linked_call,
        ^dfp$send_remote_message],
  {} ['SEND_TEST                      ', clc$nominal_entry,
        clc$normal_usage_entry, 20, clc$automatically_log, clc$linked_call,
        ^dfp$send_test_command],
  {} ['SENP                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 17, clc$automatically_log, clc$linked_call,
        ^dfp$manage_server_connection],
  {} ['SENRCL                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 18, clc$automatically_log, clc$linked_call,
        ^dfp$send_remote_command_line],
  {} ['SENRM                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 19, clc$automatically_log, clc$linked_call,
        ^dfp$send_remote_message],
  {} ['SENT                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 20, clc$automatically_log, clc$linked_call,
        ^dfp$send_test_command],
  {} ['SETQL                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 21, clc$automatically_log, clc$linked_call,
        ^dfp$set_queue_location],
  {} ['SET_QUEUE_LOCATION             ', clc$nominal_entry,
        clc$normal_usage_entry, 21, clc$automatically_log, clc$linked_call,
        ^dfp$set_queue_location],
  {} ['TERCJ                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 24, clc$automatically_log, clc$linked_call,
        ^dfp$terminate_client_job],
  {} ['TERMINATE_CLIENT_JOB           ', clc$nominal_entry,
        clc$normal_usage_entry, 24, clc$automatically_log, clc$linked_call,
        ^dfp$terminate_client_job],
  {} ['TESAS                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 22, clc$automatically_log, clc$linked_call,
        ^dfp$client_test_app_sup_r3],
  {} ['TESRPC                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 23, clc$automatically_log, clc$linked_call,
        ^dfp$test_remote_procedure_call],
  {} ['TEST_APPLICATION_SUPPORT       ', clc$nominal_entry,
        clc$normal_usage_entry, 22, clc$automatically_log, clc$linked_call,
        ^dfp$client_test_app_sup_r3],
  {} ['TEST_REMOTE_PROCEDURE_CALL     ', clc$nominal_entry,
        clc$normal_usage_entry, 23, clc$automatically_log, clc$linked_call,
        ^dfp$test_remote_procedure_call],
  {} ['VERCJ                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 25, clc$automatically_log, clc$linked_call,
        ^dfp$verify_client_jobs],
  {} ['VERIFY_CLIENT_JOBS             ', clc$nominal_entry,
        clc$normal_usage_entry, 25, clc$automatically_log, clc$linked_call,
        ^dfp$verify_client_jobs]];

  PROCEDURE [XREF] dfp$activate_pp_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$client_test_app_sup_r3
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$end_client
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$end_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$execute_cdcnet_driver
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$get_client_mainframe_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$initiate_test_driver
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$manage_server_connection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$send_remote_command_line
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$send_remote_message
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$send_test_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$store_p_qit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$terminate_client_job
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$test_remote_procedure_call
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$verify_client_jobs
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??



*IF $variable(dfv$compile_mock_code,declared)<>'UNKNOWN'

  VAR
    osv$job_pageable_heap: [XDCL] ^ost$heap;

  VAR
    osv$task_shared_heap: [XDCL] ^ost$heap;

*ELSE
*copyc osv$job_pageable_heap
*copyc osv$task_shared_heap
*IFEND

  TYPE
    outline_string_type = record
      size: 0 .. max_page_width,
      value: string (max_page_width),
    recend,

    output_id = record
      outline: outline_string_type,
      output_file_name: amt$local_file_name,
      page_width: amt$page_width,
      output_open: boolean,
      output_file_fid: amt$file_identifier,
      case alternate_output_open: boolean of
      = TRUE =
        save_output_fid: amt$file_identifier,
        save_page_width: amt$page_width,
      casend,
    recend;



  VAR
    last_queue_entry_index: dft$queue_entry_index := 1,
    p_output_id: ^output_id := NIL,
    selected_queue_index: 1 .. dfc$max_number_of_queues := 1,
    selected_queue_interface_table: dft$p_queue_interface_table := NIL;

  CONST
    default_page_width = 79,
    min_page_width = 50,
    max_page_width = 90,
    utility_name = 'FILE_SERVER_TEST_UTILITY       ';

?? TITLE := '   dfp$driver_test_utility ', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$driver_test_utility
    (    ppp: clt$parameter_list;
     VAR status: ost$status);

{ pdt test_utility_pdt (
{   listing, list, l : file =$OUTPUT
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      test_utility_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^test_utility_pdt_names, ^test_utility_pdt_params];

    VAR
      test_utility_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
            clt$parameter_name_descriptor := [['LISTING', 1], ['LIST', 1], ['L', 1], ['STATUS', 2]];

    VAR
      test_utility_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ LISTING LIST L }
      [[clc$optional_with_default, ^test_utility_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      test_utility_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??

?? NEWTITLE := '    abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      clean_up;
      handler_status.normal := TRUE;

    PROCEND abort_handler;

?? TITLE := '       clean_up', EJECT ??

    PROCEDURE clean_up;

      VAR
        ignore_status: ost$status;

      IF recovery_inhibited THEN
        recovery_inhibited := FALSE;
*IF NOT $variable(dfv$compile_mock_code,declared)<>'UNKNOWN'
        syp$decrement_server_file_count;
*IFEND
        #SPOIL (recovery_inhibited);
      IFEND;

      IF p_output_id^.output_open THEN
        fsp$close_file (p_output_id^.output_file_fid, ignore_status);
        #SPOIL (p_output_id^.output_open);
        p_output_id^.output_open := FALSE;
        #SPOIL (p_output_id^.output_open);
      IFEND;

      IF p_output_id^.alternate_output_open THEN {base output fid saved in p_output_id^.save_output_fid
        fsp$close_file (p_output_id^.save_output_fid, ignore_status);
        #SPOIL (p_output_id^.output_open);
        p_output_id^.output_open := FALSE;
        #SPOIL (p_output_id^.output_open);
      IFEND;

    PROCEND clean_up;


    VAR
      command_file: amt$local_file_name,
      local_status: ost$status,
      recovery_inhibited: boolean,
      value: clt$value;

    PUSH p_output_id;
    dfp$verify_system_administrator ('DRIVER_TEST_UTILITY', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    status.normal := TRUE;
    last_queue_entry_index := 1;

    clp$scan_parameter_list (ppp, test_utility_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('LIST', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    p_output_id^.output_file_name := value.file.local_file_name;

    recovery_inhibited := FALSE;
    p_output_id^.output_open := FALSE;
    p_output_id^.alternate_output_open := FALSE;
    #SPOIL (recovery_inhibited, p_output_id^.output_open, p_output_id^.alternate_output_open);
    osp$establish_block_exit_hndlr (^abort_handler);

    open_output_file (p_output_id^.output_file_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display (' Welcome to the file server ');

*IF $variable(dfv$compile_mock_code,declared)<>'UNKNOWN'
    create_heap ('DFV$SERVER_WIRED_HEAP          ', dfv$server_wired_heap, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_heap ('OSV$TASK_SHARED_HEAP           ', osv$task_shared_heap, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_heap ('OSV$JOB_PAGEABLE_HEAP          ', osv$job_pageable_heap, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
*ELSE
    syp$increment_server_file_count;
    #SPOIL (recovery_inhibited);
    recovery_inhibited := TRUE;
    #SPOIL (recovery_inhibited);
*IFEND

    clp$push_utility (utility_name, clc$global_command_search, file_server_commands, NIL, status);
    IF status.normal THEN
      command_file := '$COMMAND';
      clp$scan_command_file (command_file, utility_name, 'DFU', status);
      clp$pop_utility (local_status);
    IFEND;

    IF status.normal THEN
      fsp$close_file (p_output_id^.output_file_fid, status);
    ELSE
      fsp$close_file (p_output_id^.output_file_fid, local_status);
    IFEND;
  PROCEND dfp$driver_test_utility;
?? EJECT ??
  { Provide a short easy to type alias.

  PROCEDURE [XDCL, #GATE] dftu
    (    ppp: clt$parameter_list;
     VAR status: ost$status);

    dfp$driver_test_utility (ppp, status);
  PROCEND dftu;
?? EJECT ??

  PROCEDURE create_heap
    (    heap_file_name: amt$local_file_name;
     VAR heap_pointer: ^ost$heap;
     VAR status: ost$status);

    VAR
      file_identifier: amt$file_identifier,
      segment_pointer: amt$segment_pointer;

    amp$open (heap_file_name, amc$segment, NIL, file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_identifier, amc$cell_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    heap_pointer := segment_pointer.cell_pointer;
    osp$reset_heap (heap_pointer, #SIZE (heap_pointer^), FALSE, 1);
  PROCEND create_heap;
?? EJECT ??

  PROCEDURE quit_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt quit_pdt ()

?? PUSH (LISTEXT := ON) ??

    VAR
      quit_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??

    clp$scan_parameter_list (parameter_list, quit_pdt, status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_scan_command_file (utility_name, status);
  PROCEND quit_command;

?? TITLE := '  add_integer_to_line', EJECT ??

  PROCEDURE [INLINE] add_integer_to_line
    (    int: integer);

    VAR
      ignore_status: ost$status,
      int_string: ost$string;

    clp$convert_integer_to_string (int, 10, FALSE, int_string, ignore_status);
    add_to_line (int_string.value (1, int_string.size));

  PROCEND add_integer_to_line;

?? TITLE := '  add_hex_to_line', EJECT ??

  PROCEDURE [INLINE] add_hex_to_line
    (    int: integer;
         add_radix: boolean);

    VAR
      ignore_status: ost$status,
      int_string: ost$string;

    clp$convert_integer_to_string (int, 16, FALSE, int_string, ignore_status);
    add_to_line (int_string.value (1, int_string.size));
    IF add_radix THEN
      add_to_line ('(16)');
    IFEND;

  PROCEND add_hex_to_line;

?? TITLE := '  add_to_line', EJECT ??

  PROCEDURE add_to_line
    (    str: string ( * ));

    VAR
      size: 0 .. osc$max_string_size + 1;

    size := STRLENGTH (str);
    IF (p_output_id^.outline.size + size) <= p_output_id^.page_width THEN
      p_output_id^.outline.value (p_output_id^.outline.size + 1, size) := str;
      p_output_id^.outline.size := p_output_id^.outline.size + size;
      RETURN;
    IFEND;

    IF p_output_id^.outline.value (1) = '{' THEN
      flush_line;
      start_line ('  {');
      IF str = '  ' THEN
        RETURN;
      IFEND;
      p_output_id^.outline.value (p_output_id^.outline.size + 1, size) := str;
      p_output_id^.outline.size := p_output_id^.outline.size + size;
      RETURN;
    IFEND;

    flush_line;
    start_line ('      ');
    p_output_id^.outline.value (p_output_id^.outline.size + 1, size) := str;
    p_output_id^.outline.size := p_output_id^.outline.size + size;

  PROCEND add_to_line;

?? TITLE := '  end_line_with_boolean', EJECT ??

  PROCEDURE [INLINE] end_line_with_boolean
    (    bool: boolean);

    IF bool THEN
      add_to_line ('TRUE');
    ELSE
      add_to_line ('FALSE');
    IFEND;
    flush_line;

  PROCEND end_line_with_boolean;

?? TITLE := '  flush_line', EJECT ??

  PROCEDURE [INLINE] flush_line;

    IF p_output_id^.outline.size > 0 THEN
      put_line (p_output_id^.outline.value (1, p_output_id^.outline.size));
    IFEND;

  PROCEND flush_line;

?? TITLE := '  put_line', EJECT ??

  PROCEDURE put_line
    (    line: string ( * ));

    VAR
      status: ost$status,
      ignore_byte_address: amt$file_byte_address;

    amp$put_next (p_output_id^.output_file_fid, ^line, STRLENGTH (line), ignore_byte_address, status);
    IF NOT status.normal THEN
      {???????????????????
    IFEND;
    p_output_id^.outline.size := 0;
    p_output_id^.outline.value := '';

  PROCEND put_line;

?? TITLE := '  start_line', EJECT ??

  PROCEDURE [INLINE] start_line
    (    str: string ( * ));

    p_output_id^.outline.value := str;
    p_output_id^.outline.size := STRLENGTH (str);

  PROCEND start_line;

?? TITLE := '  open_output_file', EJECT ??

  PROCEDURE open_output_file
    (    file_name: amt$local_file_name;
     VAR status: ost$status);

    VAR
      file_attachment: array [1 .. 3] of fst$attachment_option,
      file_creation: array [1 .. 1] of fst$file_cycle_attribute,
      local_status: ost$status,
      output_file_attributes: array [1 .. 1] of amt$fetch_item;

    IF p_output_id^.output_open THEN {alternate output file
      p_output_id^.save_output_fid := p_output_id^.output_file_fid;
      p_output_id^.save_page_width := p_output_id^.page_width;
    IFEND;

    file_attachment [1].selector := fsc$access_and_share_modes;
    file_attachment [1].access_modes.selector := fsc$specific_access_modes;
    file_attachment [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
    file_attachment [1].share_modes.selector := fsc$specific_share_modes;
    file_attachment [1].share_modes.value := $fst$file_access_options [];
    file_attachment [2].selector := fsc$access_and_share_modes;
    file_attachment [2].access_modes.selector := fsc$specific_access_modes;
    file_attachment [2].access_modes.value := $fst$file_access_options [fsc$append];
    file_attachment [2].share_modes.selector := fsc$specific_share_modes;
    file_attachment [2].share_modes.value := $fst$file_access_options [];
    file_attachment [3].selector := fsc$open_share_modes;
    file_attachment [3].open_share_modes := -$fst$file_access_options [];

    file_creation [1].selector := fsc$ring_attributes;
    file_creation [1].ring_attributes.r1 := 11;
    file_creation [1].ring_attributes.r2 := 11;
    file_creation [1].ring_attributes.r3 := 11;

    fsp$open_file (file_name, amc$record, ^file_attachment, ^file_creation,
         NIL, NIL, NIL, p_output_id^.output_file_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF p_output_id^.output_open THEN
      #SPOIL (p_output_id^.alternate_output_open);
      p_output_id^.alternate_output_open := TRUE;
      #SPOIL (p_output_id^.alternate_output_open);
    ELSE
      #SPOIL (p_output_id^.output_open);
      p_output_id^.output_open := TRUE;
      #SPOIL (p_output_id^.output_open);
    IFEND;

    output_file_attributes [1].key := amc$page_width;
    amp$fetch (p_output_id^.output_file_fid, output_file_attributes, status);
    IF NOT status.normal THEN
      fsp$close_file (p_output_id^.output_file_fid, local_status);
      RETURN;
    IFEND;

    p_output_id^.page_width := default_page_width;
    IF (output_file_attributes [1].source <> amc$undefined_attribute) AND
          (output_file_attributes [1].source <> amc$access_method_default) THEN
      p_output_id^.page_width := output_file_attributes [1].page_width;
    ELSE
      p_output_id^.page_width := default_page_width;
    IFEND;

    IF p_output_id^.page_width < min_page_width THEN
      p_output_id^.page_width := min_page_width;
    ELSEIF p_output_id^.page_width > max_page_width THEN
      p_output_id^.page_width := max_page_width;
    IFEND;

  PROCEND open_output_file;

?? TITLE := '  dfp$set_queue_location', EJECT ??

  PROCEDURE dfp$set_queue_location
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{  pdt set_queue_location_pdt (
{   connection_type, ct: key stornet, cdcnet, mock = $required
{   element_name, en, driver_name, dn, send_channel_name, scn: name
{   queue_index, qi: integer 1 .. dfc$max_number_of_queues = $REQUIRED
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    set_queue_location_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^set_queue_location_pdt_names, ^set_queue_location_pdt_params];

  VAR
    set_queue_location_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 11] of
      clt$parameter_name_descriptor := [['CONNECTION_TYPE', 1], ['CT', 1], ['ELEMENT_NAME', 2], ['EN', 2], [
      'DRIVER_NAME', 2], ['DN', 2], ['SEND_CHANNEL_NAME', 2], ['SCN', 2], ['QUEUE_INDEX', 3], ['QI', 3], [
      'STATUS', 4]];

  VAR
    set_queue_location_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
      clt$parameter_descriptor := [

{ CONNECTION_TYPE CT }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^set_queue_location_pdt_kv1, clc$keyword_value
      ]],

{ ELEMENT_NAME EN DRIVER_NAME DN SEND_CHANNEL_NAME SCN }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ QUEUE_INDEX QI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 1,
      dfc$max_number_of_queues]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    set_queue_location_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of ost$name := [
      'STORNET','CDCNET','MOCK'];

?? POP ??

    VAR
      l: integer,
      q_string: string (2),
      value: clt$value;

    clp$scan_parameter_list (parameter_list, set_queue_location_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('CONNECTION_TYPE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('ELEMENT_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$fetch_qit (value.name.value, selected_queue_interface_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('QUEUE_INDEX', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF selected_queue_interface_table^.queue_directory.number_of_queues < value.int.value THEN
      STRINGREP (q_string, l, selected_queue_interface_table^.queue_directory.number_of_queues);
      osp$set_status_abnormal (dfc$file_server_id, dfe$queue_index_exceeded, q_string (1, l), status);
    ELSEIF selected_queue_interface_table^.queue_directory.driver_queue_pva_directory [value.int.value].
          p_driver_queue = NIL THEN
      STRINGREP (q_string, l, value.int.value);
      osp$set_status_abnormal (dfc$file_server_id, dfe$queue_index_invalid, q_string (1, l), status);
      RETURN;
    ELSE
      selected_queue_index := value.int.value;
    IFEND;

  PROCEND dfp$set_queue_location;
?? TITLE := ' [XDCL] dfp$get_test_queue_location ', EJECT ??

  PROCEDURE [XDCL] dfp$get_test_queue_location
    (VAR queue_interface_table: ^dft$queue_interface_table;
     VAR queue_index: dft$queue_index);

    queue_interface_table := selected_queue_interface_table;
    queue_index := selected_queue_index;
  PROCEND dfp$get_test_queue_location;


?? TITLE := '  dfp$reset_transfer_rate', EJECT ??

  PROCEDURE dfp$reset_transfer_rate
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  pdt reset_transfer_rate_pdt  (
{    status)

?? PUSH (LISTEXT := ON) ??

    VAR
      reset_transfer_rate_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^reset_transfer_rate_pdt_names, ^reset_transfer_rate_pdt_params];

    VAR
      reset_transfer_rate_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      reset_transfer_rate_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
            clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      io_types: dft$monitor_io_types,
      p_transaction_data: ^dft$transaction_data,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, reset_transfer_rate_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF selected_queue_interface_table = NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$must_execute_setql, 'RESET_TRANSFER_RATE', status);
      RETURN;
    IFEND;

    p_transaction_data := ^selected_queue_interface_table^.queue_directory.
          cpu_queue_pva_directory [selected_queue_index].p_cpu_queue^.queue_header.transaction_data;
    pmp$get_compact_date_time (p_transaction_data^.transaction_start_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    osp$clear_locked_variable (p_transaction_data^.total_transaction_count, 0);
    osp$clear_locked_variable (p_transaction_data^.total_buffer_length_sent, 0);
    osp$clear_locked_variable (p_transaction_data^.total_data_pages_sent, 0);
    osp$clear_locked_variable (p_transaction_data^.total_buffer_length_received, 0);
    osp$clear_locked_variable (p_transaction_data^.total_data_pages_received, 0);
    FOR io_types := dfc$monitor_io TO dfc$monitor_allocate DO
       osp$clear_locked_variable (
          selected_queue_interface_table^.queue_directory.
          cpu_queue_pva_directory [selected_queue_index].p_cpu_queue^.queue_header.
          monitor_io[io_types].number_of_requests, 0);
       osp$clear_locked_variable (
          selected_queue_interface_table^.queue_directory.
          cpu_queue_pva_directory [selected_queue_index].p_cpu_queue^.queue_header.
          monitor_io[io_types].total_request_time, 0);
       osp$clear_locked_variable (
          selected_queue_interface_table^.queue_directory.
          cpu_queue_pva_directory [selected_queue_index].p_cpu_queue^.queue_header.
          monitor_io[io_types].max_request_time, 0);
    FOREND;
    display ('  Transaction counters reset ');

  PROCEND dfp$reset_transfer_rate;

?? TITLE := '  dfp$display_operator_display ', EJECT ??

  PROCEDURE dfp$display_operator_display
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt disp_operator_display (
{    output, o: file
{    status)

?? PUSH (LISTEXT := ON) ??

    VAR
      disp_operator_display: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^disp_operator_display_names, ^disp_operator_display_params];

    VAR
      disp_operator_display_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['OUTPUT', 1], ['O', 1], ['STATUS', 2]];

    VAR
      disp_operator_display_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ OUTPUT O }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      file_name: amt$local_file_name,
      name: ost$name,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, disp_operator_display, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.kind <> clc$unknown_value THEN
      file_name := value.file.local_file_name;
    ELSE
      file_name := p_output_id^.output_file_name;
    IFEND;
    dfp$file_server_display (0, name, file_name, TRUE, status);

  PROCEND dfp$display_operator_display;

?? TITLE := '  dfp$display_server_state', EJECT ??

  PROCEDURE dfp$display_server_state
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  pdt disp_server_state_pdt (
{    output, o: file
{    status)

?? PUSH (LISTEXT := ON) ??

  VAR
    disp_server_state_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^disp_server_state_pdt_names, ^disp_server_state_pdt_params];

  VAR
    disp_server_state_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['OUTPUT', 1], ['O', 1], ['STATUS', 2]];

  VAR
    disp_server_state_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
      clt$parameter_descriptor := [

{ OUTPUT O }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??


    VAR
      alternate_output_name: amt$local_file_name,
      p_cpu_queue_header: ^dft$cpu_queue_header,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, disp_server_state_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF selected_queue_interface_table = NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$must_execute_setql, 'DISPLAY_SERVER_STATE', status);
      RETURN;
    IFEND;

    IF value.kind <> clc$unknown_value THEN
      alternate_output_name := value.file.local_file_name;
      IF alternate_output_name <> p_output_id^.output_file_name THEN
        open_output_file (alternate_output_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    p_cpu_queue_header := ^selected_queue_interface_table^.queue_directory.
          cpu_queue_pva_directory [selected_queue_index].p_cpu_queue^.queue_header;

    flush_line;
    start_line ('   Queue_Number:  ');
    add_integer_to_line (selected_queue_index);
    flush_line;
    start_line ('   Partner_Status:');
    flush_line;
    start_line ('       Terminate_Partner........');
    end_line_with_boolean (p_cpu_queue_header^.partner_status.terminate_partner);
    start_line ('       Users wait on terminated.');
    end_line_with_boolean (p_cpu_queue_header^.partner_status.terminate_partner);
    flush_line;

    start_line ('       Deactivate complete  ');
    end_line_with_boolean (p_cpu_queue_header^.partner_status.deactivate_complete);

    start_line ('       Server_State.............');
    CASE p_cpu_queue_header^.partner_status.server_state OF
    = dfc$active =
      add_to_line ('dfc$active');
      flush_line;
      start_line ('         Verify_Family.............');
      end_line_with_boolean (p_cpu_queue_header^.partner_status.verify_family);
      start_line ('         Send_Deactivate_Partner...');
      end_line_with_boolean (p_cpu_queue_header^.partner_status.send_deactivate_partner);
      start_line ('         Job_reconcilliation_completed ');
      end_line_with_boolean (p_cpu_queue_header^.partner_status.job_reconcilliation_completed);
    = dfc$inactive, dfc$terminated, dfc$awaiting_recovery =
      CASE p_cpu_queue_header^.partner_status.server_state OF
      = dfc$inactive =
        add_to_line ('dfc$inactive');
      = dfc$terminated =
        add_to_line ('dfc$terminated');
      = dfc$awaiting_recovery =
         add_to_line ('dfc$awaiting_recovery');
      ELSE
      CASEND;
      flush_line;
      start_line ('         Verify_Queue..............');
      end_line_with_boolean (p_cpu_queue_header^.partner_status.verify_queue);
      start_line ('         Server_pages_saved........');
      end_line_with_boolean (p_cpu_queue_header^.partner_status.server_pages_saved);
    = dfc$deactivated =
      add_to_line ('dfc$deactivated');
      flush_line;
    = dfc$recovering =
      add_to_line ('dfc$recovering');
      flush_line;
      start_line ('         Recovery complete ........');
      end_line_with_boolean (p_cpu_queue_header^.partner_status.recovery_complete);
    ELSE
      add_to_line ('UNKNOWN STATE');
      flush_line;
    CASEND;
    flush_line;
    start_line ('       Server_Lifetime..........');
    add_integer_to_line (p_cpu_queue_header^.server_lifetime);
    flush_line;
    start_line ('       Server_Birthdate.........');
    add_integer_to_line (p_cpu_queue_header^.server_birthdate);
    flush_line;

    IF p_output_id^.alternate_output_open THEN
      fsp$close_file (p_output_id^.output_file_fid, status);
      p_output_id^.output_file_fid := p_output_id^.save_output_fid;
      p_output_id^.page_width := p_output_id^.save_page_width;
      p_output_id^.alternate_output_open := FALSE;
    IFEND;

  PROCEND dfp$display_server_state;

?? TITLE := '  dfp$display_transfer_rate', EJECT ??

  PROCEDURE dfp$display_transfer_rate
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  pdt disp_transfer_rate_pdt (
{    output, o: file
{    status)

?? PUSH (LISTEXT := ON) ??

    VAR
      disp_transfer_rate_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^disp_transfer_rate_pdt_names, ^disp_transfer_rate_pdt_params];

    VAR
      disp_transfer_rate_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['OUTPUT', 1], ['O', 1], ['STATUS', 2]];

    VAR
      disp_transfer_rate_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ OUTPUT O }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    CONST
      mps = 1000000; {microseconds per second

    VAR
      alternate_output_name: amt$local_file_name,
      base_date_time: ost$date_time,
      base_micros: jmt$clock_time,
      current_date_time: ost$date_time,
      current_micros: jmt$clock_time,
      formatted_time: ost$time,
      increment: jmt$clock_time,
      p_transaction_data: ^dft$transaction_data,
      rate: integer,
      temp: integer,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, disp_transfer_rate_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF selected_queue_interface_table = NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$must_execute_setql, 'DISPLAY_TRANSFER_RATE', status);
      RETURN;
    IFEND;

    IF value.kind <> clc$unknown_value THEN
      alternate_output_name := value.file.local_file_name;
      IF alternate_output_name <> p_output_id^.output_file_name THEN
        open_output_file (alternate_output_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    p_transaction_data := ^selected_queue_interface_table^.queue_directory.
          cpu_queue_pva_directory [selected_queue_index].p_cpu_queue^.queue_header.transaction_data;

    base_date_time := p_transaction_data^.transaction_start_time;

    pmp$get_compact_date_time (current_date_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$format_compact_time (base_date_time, osc$millisecond_time, formatted_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    start_line (' Initial time .......................');
    add_to_line (formatted_time.millisecond);
    flush_line;

    pmp$format_compact_time (current_date_time, osc$millisecond_time, formatted_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    start_line (' Current time .......................');
    add_to_line (formatted_time.millisecond);
    flush_line;

    jmp$convert_date_time_to_clock (base_date_time, base_micros);

    jmp$convert_date_time_to_clock (current_date_time, current_micros);

    increment := current_micros - base_micros;

    start_line (' Elapsed time .......................');
    add_integer_to_line (increment);
    add_to_line (' Microseconds');
    flush_line;

    start_line (' Transaction count ..................');
    osp$fetch_locked_variable (p_transaction_data^.total_transaction_count, temp);
    add_integer_to_line (temp);
    add_to_line ('    Units per second = ');
    temp := temp * mps;
    rate := temp DIV increment;
    add_integer_to_line (rate);
    flush_line;

    start_line (' buffer_length_sent .................');
    osp$fetch_locked_variable (p_transaction_data^.total_buffer_length_sent, temp);
    add_integer_to_line (temp);
    add_to_line ('    Units per second = ');
    temp := temp * mps;
    rate := temp DIV increment;
    add_integer_to_line (rate);
    flush_line;

    start_line (' buffer_length_received .............');
    osp$fetch_locked_variable (p_transaction_data^.total_buffer_length_received, temp);
    add_integer_to_line (temp);
    add_to_line ('    Units per second = ');
    temp := temp * mps;
    rate := temp DIV increment;
    add_integer_to_line (rate);
    flush_line;

    start_line (' data_pages_sent ....................');
    osp$fetch_locked_variable (p_transaction_data^.total_data_pages_sent, temp);
    add_integer_to_line (temp);
    add_to_line ('    Units per second = ');
    temp := temp * mps;
    rate := temp DIV increment;
    add_integer_to_line (rate);
    flush_line;

    start_line (' data_pages_received ................');
    osp$fetch_locked_variable (p_transaction_data^.total_data_pages_received, temp);
    add_integer_to_line (temp);
    add_to_line ('    Units per second = ');
    temp := temp * mps;
    rate := temp DIV increment;
    add_integer_to_line (rate);
    flush_line;

    IF p_output_id^.alternate_output_open THEN
      fsp$close_file (p_output_id^.output_file_fid, status);
      p_output_id^.output_file_fid := p_output_id^.save_output_fid;
      p_output_id^.page_width := p_output_id^.save_page_width;
      #SPOIL (p_output_id^.alternate_output_open);
      p_output_id^.alternate_output_open := FALSE;
      #SPOIL (p_output_id^.alternate_output_open);
    IFEND;


  PROCEND dfp$display_transfer_rate;

?? TITLE := '  dfp$display_queue_header', EJECT ??

  PROCEDURE dfp$display_queue_header
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   pdt disp_queue_header_pdt (
{      display_options, display_option, do: list of key request_buffer, ..
{          rb, stornet, directory, driver, cpu, all = all
{     output, o: file
{     status)

?? PUSH (LISTEXT := ON) ??

    VAR
      disp_queue_header_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^disp_queue_header_pdt_names, ^disp_queue_header_pdt_params];

    VAR
      disp_queue_header_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
            clt$parameter_name_descriptor := [['DISPLAY_OPTIONS', 1], ['DISPLAY_OPTION', 1], ['DO', 1],
            ['OUTPUT', 2], ['O', 2], ['STATUS', 3]];

    VAR
      disp_queue_header_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
            clt$parameter_descriptor := [

{ DISPLAY_OPTIONS DISPLAY_OPTION DO }
      [[clc$optional_with_default, ^disp_queue_header_pdt_dv1], 1, clc$max_value_sets, 1, 1,
            clc$value_range_not_allowed, [^disp_queue_header_pdt_kv1, clc$keyword_value]],

{ OUTPUT O }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      disp_queue_header_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
            ost$name := ['REQUEST_BUFFER', 'RB', 'STORNET', 'DIRECTORY', 'DRIVER', 'CPU', 'ALL'];

    VAR
      disp_queue_header_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

?? POP ??

    VAR
      alternate_output_name: amt$local_file_name,
      assignments: string (dfc$queue_assignment_strng_size),
      average: integer,
      formatted_date: ost$date,
      formatted_time: ost$time,
      header_line_displayed: boolean,
      i: 0 .. clc$max_value_sets,
      inquiry_request: boolean,
      j: integer,
      previous_processed: boolean,
      p_cpu_queue_header: ^dft$cpu_queue_header,
      p_driver_queue_header: ^dft$driver_queue_header,
      p_esm_base_addresses: ^dft$esm_base_addresses,
      p_queue_directory: ^dft$queue_directory,
      p_request_buffer_directory: ^dft$request_buffer_directory,
      p_request_buffer: ^dft$request_buffer,
      q_count: 0 .. dfc$queue_assignment_strng_size,
      q_index: 0 .. dfc$queue_assignment_strng_size,
      qei: 0 .. 0FF(16),
      qi: 0 .. 0FF(16),
      temp: integer,
      value_set_count: 0 .. clc$max_value_sets,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, disp_queue_header_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF selected_queue_interface_table = NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$must_execute_setql, 'DISPLAY_QUEUE_HEADER', status);
      RETURN;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.kind <> clc$unknown_value THEN
      alternate_output_name := value.file.local_file_name;
      IF alternate_output_name <> p_output_id^.output_file_name THEN
        open_output_file (alternate_output_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;


    clp$get_set_count ('DISPLAY_OPTIONS', value_set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO value_set_count DO
      clp$get_value ('DISPLAY_OPTIONS', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (value.name.value = 'REQUEST_BUFFER') OR (value.name.value = 'RB') OR
            ((value.name.value = 'ALL') AND (value_set_count = 1)) THEN
        p_request_buffer_directory := ^selected_queue_interface_table^.request_buffer_directory;
        start_line (' Request Buffer Directory   ');
        add_pva_to_line (p_request_buffer_directory);
        flush_line;
        start_line ('   Inn ...................................');
        add_integer_to_line (p_request_buffer_directory^.inn);
        flush_line;
        start_line ('   Out ...................................');
        add_integer_to_line (p_request_buffer_directory^.out);
        flush_line;
        start_line ('   Limit .................................');
        add_integer_to_line (p_request_buffer_directory^.limit);
        flush_line;
        start_line ('   Request_buffer_rma ....................');
        add_hex_to_line (p_request_buffer_directory^.request_buffer_rma, TRUE);
        flush_line;
        header_line_displayed := FALSE;
        p_request_buffer := p_request_buffer_directory^.p_request_buffer;
        FOR j := 1 TO (p_request_buffer_directory^.limit DIV 8) DO
          inquiry_request := p_request_buffer^.request_buffer_entries [j].flags.inquiry;
          previous_processed := p_request_buffer^.request_buffer_entries [j].flags.previously_processed;
          qi := p_request_buffer^.request_buffer_entries [j].queue_index;
          qei := p_request_buffer^.request_buffer_entries [j].queue_entry_index;
          IF previous_processed OR (qi <> 0) OR (qei <> 0) THEN
            IF NOT header_line_displayed THEN
              header_line_displayed := TRUE;
              start_line ('     ENTRY   PREV P.   TYPE    Q.I.    Q.E.I.');
              flush_line;
            IFEND;
            start_line ('       ');
            add_integer_to_line ((j - 1) * 8);
            p_output_id^.outline.size := 14;
            IF previous_processed THEN
              add_to_line ('TRUE');
            ELSE
              add_to_line ('FALSE');
            IFEND;
            p_output_id^.outline.size := 24;
            IF inquiry_request THEN
              add_to_line ('INQM');
            ELSE
              add_to_line ('NORM');
            IFEND;
            p_output_id^.outline.size := 32;
            add_integer_to_line (qi);
            p_output_id^.outline.size := 40;
            add_integer_to_line (qei);
            flush_line;
          IFEND;
        FOREND;
      IFEND;

      IF (value.name.value = 'STORNET') OR ((value.name.value = 'ALL') AND (value_set_count = 1)) THEN
        p_esm_base_addresses := ^selected_queue_interface_table^.esm_base_addresses;
        start_line (' ESM Base Addresses         ');
        add_pva_to_line (p_esm_base_addresses);
        flush_line;
        start_line ('   number_of_mainframes...................');
        add_integer_to_line (p_esm_base_addresses^.number_of_mainframes);
        flush_line;
        start_line ('   divisions_per_mainframe................');
        add_integer_to_line (p_esm_base_addresses^.divisions_per_mainframe);
        flush_line;
        start_line ('   esm_flag_base .........................');
        add_hex_to_line (p_esm_base_addresses^.esm_flag_base, TRUE);
        flush_line;
        start_line ('   esm_memory_base .......................');
        add_hex_to_line (p_esm_base_addresses^.esm_memory_base, TRUE);
        flush_line;
        start_line ('   esm_division_size .....................');
        add_hex_to_line (p_esm_base_addresses^.esm_division_size, TRUE);
        flush_line;
        start_line ('   esm_divsiz_12bit_cw ...................');
        add_hex_to_line (p_esm_base_addresses^.esm_divsiz_12bit_cw, TRUE);
        flush_line;
        start_line ('   esm_divsiz_16bit_cw ...................');
        add_hex_to_line (p_esm_base_addresses^.esm_divsiz_16bit_cw, TRUE);
        flush_line;
      IFEND;
      IF (value.name.value = 'DIRECTORY') OR ((value.name.value = 'ALL') AND (value_set_count = 1)) THEN
        start_line (' Maximum Data Bytes ......................');
        add_integer_to_line (selected_queue_interface_table^.maximum_data_bytes);
        flush_line;

        p_queue_directory := ^selected_queue_interface_table^.queue_directory;
        start_line (' Queue Directory   ');
        add_pva_to_line (p_queue_directory);
        flush_line;
        start_line ('   Use DMA Adaptor On Send Channel .......');
        IF p_queue_directory^.dma_adapter.use_on_send_channel THEN
          add_to_line ('TRUE');
        ELSE
          add_to_line ('FALSE');
        IFEND;
        flush_line;
        start_line ('   Use DMA Adaptor On Receive Channel ....');
        IF p_queue_directory^.dma_adapter.use_on_recv_channel THEN
          add_to_line ('TRUE');
        ELSE
          add_to_line ('FALSE');
        IFEND;
        flush_line;
        start_line ('   Machine IOU is I0 model (CY930) .......');
        IF p_queue_directory^.dma_adapter.iou_i0_model THEN
          add_to_line ('TRUE');
        ELSE
          add_to_line ('FALSE');
        IFEND;
        flush_line;
        start_line ('   Send PP Number ........................');
        add_integer_to_line (p_queue_directory^.send_pp_number);
        flush_line;
        start_line ('   Receive PP Number .....................');
        add_integer_to_line (p_queue_directory^.receive_pp_number);
        flush_line;
        start_line ('   Source ID Number ......................');
        add_integer_to_line (p_queue_directory^.source_id_number);
        flush_line;
        start_line ('   Number of Queues ......................');
        add_integer_to_line (p_queue_directory^.number_of_queues);
        flush_line;
        {?????!! directory addresses ????
      IFEND;
      IF (value.name.value = 'DRIVER') OR ((value.name.value = 'ALL') AND (value_set_count = 1)) THEN
        p_driver_queue_header := ^selected_queue_interface_table^.queue_directory.
              driver_queue_pva_directory [selected_queue_index].p_driver_queue^.queue_header;
        start_line (' Driver Queue ');
        add_integer_to_line (selected_queue_index);
        add_to_line ('  HEADER  ');
        add_pva_to_line (p_driver_queue_header);
        flush_line;
        start_line ('   flags.idle ............................');
        IF p_driver_queue_header^.flags.idle THEN
          add_to_line ('TRUE');
        ELSE
          add_to_line ('FALSE');
        IFEND;
        flush_line;
        {????!! interrupt ???
        start_line ('   Number of Queue Entries ...............');
        add_integer_to_line (p_driver_queue_header^.number_of_queue_entries);
        flush_line;
        start_line ('   Connection Descriptor');
        flush_line;
        start_line ('     Source');
        flush_line;
        start_line ('       flags.server_to_client ............');
        IF p_driver_queue_header^.connection_descriptor.source.flags.server_to_client THEN
          add_to_line ('TRUE');
        ELSE
          add_to_line ('FALSE');
        IFEND;
        flush_line;
        start_line ('       id_number .........................');
        add_integer_to_line (p_driver_queue_header^.connection_descriptor.source.id_number);
        flush_line;
        start_line ('       queue_index .......................');
        add_integer_to_line (p_driver_queue_header^.connection_descriptor.source.queue_index);
        flush_line;
        start_line ('       queue_entry_index .................');
        add_integer_to_line (p_driver_queue_header^.connection_descriptor.source.queue_entry_index);
        flush_line;
        start_line ('     Destination');
        flush_line;
        start_line ('       flags.server_to_client ............');
        IF p_driver_queue_header^.connection_descriptor.destination.flags.server_to_client THEN
          add_to_line ('TRUE');
        ELSE
          add_to_line ('FALSE');
        IFEND;
        flush_line;
        start_line ('       id_number .........................');
        add_integer_to_line (p_driver_queue_header^.connection_descriptor.destination.id_number);
        flush_line;
        start_line ('       queue_index .......................');
        add_integer_to_line (p_driver_queue_header^.connection_descriptor.destination.queue_index);
        flush_line;
        start_line ('       queue_entry_index .................');
        add_integer_to_line (p_driver_queue_header^.connection_descriptor.destination.queue_entry_index);
        flush_line;
      IFEND;
      IF (value.name.value = 'CPU') OR ((value.name.value = 'ALL') AND (value_set_count = 1)) THEN
        p_cpu_queue_header := ^selected_queue_interface_table^.queue_directory.
              cpu_queue_pva_directory [selected_queue_index].p_cpu_queue^.queue_header;
        start_line (' CPU Queue ');
        add_integer_to_line (selected_queue_index);
        add_to_line ('  HEADER  ');
        add_pva_to_line (p_cpu_queue_header);
        flush_line;
        start_line ('   Number of Monitor Queue Entries .......');
        add_integer_to_line (p_cpu_queue_header^.number_of_monitor_queue_entries);
        flush_line;
        start_line ('   Number of Task Queue Entries ..........');
        add_integer_to_line (p_cpu_queue_header^.number_of_task_queue_entries);
        flush_line;
        put_line ('   Queue_entry_assignment_table:');
        assignments := p_cpu_queue_header^.queue_entry_assignment_table;
{       Provide for 1st entry being assigned to Poll Task.
        q_count := 1 + p_cpu_queue_header^.number_of_monitor_queue_entries +
              p_cpu_queue_header^.number_of_task_queue_entries;
        FOR q_index := 1 TO q_count DO
          IF assignments (q_index) = ' ' THEN
            assignments (q_index) := 'x';
          IFEND;
        FOREND;
        start_line ('     Poll Task: ');
        add_to_line (assignments (1, 1));
        start_line ('     Monitor: ');
        q_index := p_cpu_queue_header^.number_of_monitor_queue_entries;
        q_count := q_index;
        IF q_count > 50 THEN
          q_count := 50;
        IFEND;
        add_to_line (assignments (2, q_count));
        IF q_index > 50 THEN
          add_to_line (' ..');
        IFEND;
        flush_line;
        start_line ('     Task: ');
        q_count := p_cpu_queue_header^.number_of_task_queue_entries;
        IF q_count > 50 THEN
          q_count := 50;
        IFEND;
{       Provide 1 entry for Poll Task.
        add_to_line (assignments (q_index + 1 + 1, q_count));
        IF p_cpu_queue_header^.number_of_task_queue_entries > 50 THEN
          add_to_line (' ..');
        IFEND;
        flush_line;
        start_line ('   Connection Type .......................');
        CASE p_cpu_queue_header^.connection_type OF
        = dfc$esm_connection =
          add_to_line ('STORNET');
        = dfc$cdcnet_connection =
          add_to_line ('CDCNET');
        = dfc$mock_connection =
          add_to_line ('MOCK');
        ELSE
        CASEND;
        flush_line;
        start_line ('   Destination Mainframe ID Model Number .');
        add_integer_to_line (p_cpu_queue_header^.destination_mainframe_id.model_number);
        flush_line;
        start_line ('   Destination Mainframe ID Serial Number.');
        add_integer_to_line (p_cpu_queue_header^.destination_mainframe_id.serial_number);
        flush_line;
        start_line ('   Destination Mainframe Name ........... ');
        add_to_line (p_cpu_queue_header^.destination_mainframe_name);
        flush_line;
        start_line ('   Leveler Status........................ ');
        CASE p_cpu_queue_header^.leveler_status.leveler_state OF
        = jmc$jl_leveler_enabled =
          add_to_line ('ENABLED');
        = jmc$jl_leveler_disabled =
          add_to_line ('DISABLED');
        = jmc$jl_server_profile_mismatch =
          add_to_line ('PROFILE MISMATCH');
        ELSE
          add_to_line ('UNKNOWN');
        CASEND;
        flush_line;
        start_line ('   Server Lifetime....................... ');
        add_integer_to_line (p_cpu_queue_header^.server_lifetime);
        flush_line;
        start_line ('   Server Birthdate...................... ');
        add_integer_to_line (p_cpu_queue_header^.server_birthdate);
        flush_line;
        start_line ('   Timeout Interval...................... ');
        add_integer_to_line (p_cpu_queue_header^.timeout_interval);
        flush_line;
        start_line ('   Max Request Timout Count.............. ');
        add_integer_to_line (p_cpu_queue_header^.maximum_request_timeout_count);
        flush_line;
        start_line ('   Max Retransmission Count.............. ');
        add_integer_to_line (p_cpu_queue_header^.maximum_retransmission_count);
        flush_line;
        start_line ('   Number of last monitor IO requests ...... ');
        add_integer_to_line (p_cpu_queue_header^.monitor_io [dfc$monitor_io].number_of_requests);
        flush_line;
        start_line ('   Max last monitor IO request time ........ ');
        add_integer_to_line (p_cpu_queue_header^.monitor_io [dfc$monitor_io].max_request_time);
        flush_line;
        start_line ('   Total last monitor IO request time ...... ');
        add_integer_to_line (p_cpu_queue_header^.monitor_io [dfc$monitor_io].total_request_time);
        flush_line;
        IF p_cpu_queue_header^.monitor_io [dfc$monitor_io].number_of_requests > 0 THEN
          average := p_cpu_queue_header^.monitor_io [dfc$monitor_io].total_request_time DIV
                p_cpu_queue_header^.monitor_io [dfc$monitor_io].number_of_requests;
          start_line ('       Average = .... ');
          add_integer_to_line (average);
          flush_line;
        IFEND;
        start_line ('   Number of monitor allocate requests ..... ');
        add_integer_to_line (p_cpu_queue_header^.monitor_io [dfc$monitor_allocate].number_of_requests);
        flush_line;
        start_line ('   Max monitor allocate request time ....... ');
        add_integer_to_line (p_cpu_queue_header^.monitor_io [dfc$monitor_allocate].max_request_time);
        flush_line;
        start_line ('   Total monitor allocate request time ..... ');
        add_integer_to_line (p_cpu_queue_header^.monitor_io [dfc$monitor_allocate].total_request_time);
        flush_line;
        IF p_cpu_queue_header^.monitor_io [dfc$monitor_allocate].number_of_requests > 0 THEN
          average := p_cpu_queue_header^.monitor_io [dfc$monitor_allocate].total_request_time DIV
                p_cpu_queue_header^.monitor_io [dfc$monitor_allocate].number_of_requests;
          start_line ('       Average = .... ');
          add_integer_to_line (average);
          flush_line;
        IFEND;
        start_line ('   Transaction Data');
        flush_line;
        start_line ('     transaction_start_time ..............');
        pmp$format_compact_date (p_cpu_queue_header^.transaction_data.transaction_start_time, osc$iso_date,
              formatted_date, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        add_to_line (formatted_date.iso);
        add_to_line ('  ');
        pmp$format_compact_time (p_cpu_queue_header^.transaction_data.transaction_start_time,
              osc$millisecond_time, formatted_time, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        add_to_line (formatted_time.hms);
        flush_line;
        start_line ('     total_transaction_count .............');
        osp$fetch_locked_variable (p_cpu_queue_header^.transaction_data.total_transaction_count, temp);
        add_integer_to_line (temp);
        flush_line;
        start_line ('     total_buffer_length_sent ............');
        osp$fetch_locked_variable (p_cpu_queue_header^.transaction_data.total_buffer_length_sent, temp);
        add_integer_to_line (temp);
        flush_line;
        start_line ('     total_data_pages_sent ...............');
        osp$fetch_locked_variable (p_cpu_queue_header^.transaction_data.total_data_pages_sent, temp);
        add_integer_to_line (temp);
        flush_line;
        start_line ('     total_buffer_length_received ........');
        osp$fetch_locked_variable (p_cpu_queue_header^.transaction_data.total_buffer_length_received, temp);
        add_integer_to_line (temp);
        flush_line;
        start_line ('     total_data_pages_received ...........');
        osp$fetch_locked_variable (p_cpu_queue_header^.transaction_data.total_data_pages_received, temp);
        add_integer_to_line (temp);
        flush_line;
        start_line ('   p_allocated_data_rma_list............. ');
        add_pva_to_line (p_cpu_queue_header^.p_allocated_data_rma_list);
        flush_line;
      IFEND;
    FOREND;

    IF p_output_id^.alternate_output_open THEN
      fsp$close_file (p_output_id^.output_file_fid, status);
      p_output_id^.output_file_fid := p_output_id^.save_output_fid;
      p_output_id^.page_width := p_output_id^.save_page_width;
      #SPOIL (p_output_id^.alternate_output_open);
      p_output_id^.alternate_output_open := FALSE;
      #SPOIL (p_output_id^.alternate_output_open);
    IFEND;

  PROCEND dfp$display_queue_header;
?? EJECT ??
  PROCEDURE add_pva_to_line
    (    address: ^cell);

    add_to_line (' PVA=');
    add_hex_to_line (#RING (address), FALSE);
    add_to_line ('  ');
    add_hex_to_line (#SEGMENT (address), FALSE);
    add_to_line ('  ');
    add_hex_to_line (#OFFSET (address), TRUE);
  PROCEND add_pva_to_line;
?? TITLE := '  dfp$display_queue', EJECT ??

  PROCEDURE dfp$display_queue
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt display_queue_pdt (
{    queue_entry_index, qei: integer 1 .. 127 or key all, last = last
{    display_options, display_option, do: list of key driver, cpu, buffer, ..
{       all = all
{    output, o : file
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_queue_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^display_queue_pdt_names, ^display_queue_pdt_params];

    VAR
      display_queue_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 8] of
            clt$parameter_name_descriptor := [['QUEUE_ENTRY_INDEX', 1], ['QEI', 1], ['DISPLAY_OPTIONS', 2],
            ['DISPLAY_OPTION', 2], ['DO', 2], ['OUTPUT', 3], ['O', 3], ['STATUS', 4]];

    VAR
      display_queue_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
            clt$parameter_descriptor := [

{ QUEUE_ENTRY_INDEX QEI }
      [[clc$optional_with_default, ^display_queue_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [^display_queue_pdt_kv1, clc$integer_value, 1, 127]],

{ DISPLAY_OPTIONS DISPLAY_OPTION DO }
      [[clc$optional_with_default, ^display_queue_pdt_dv2], 1, clc$max_value_sets, 1, 1,
            clc$value_range_not_allowed, [^display_queue_pdt_kv2, clc$keyword_value]],

{ OUTPUT O }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      display_queue_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := ['ALL',
            'LAST'];

    VAR
      display_queue_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
            ost$name := ['DRIVER', 'CPU', 'BUFFER', 'ALL'];

    VAR
      display_queue_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'last';

    VAR
      display_queue_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

?? POP ??

    VAR
      actual_length: 0 .. 0FFFF(16),
      alternate_output_name: amt$local_file_name,
      current_last: dft$queue_entry_index,
      first: dft$queue_entry_index,
      gfn: ost$name,
      index: integer,
      l: integer,
      last: dft$queue_entry_index,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_driver_queue_header: ^dft$driver_queue_header,
      p_mtr_status: ^syt$monitor_status,
      p_os_status: ^ost$status,
      p_poll_header: ^dft$poll_header,
      p_receive_buffer: dft$p_command_buffer,
      p_receive_buffer_header: ^dft$buffer_header,
      p_rpc_buffer_header: ^dft$rpc_buffer_header,
      p_rpc_response_buffer_header: ^dft$rpc_response_buffer_header,
      p_rpc_test_header: ^dft$rpc_test_request_header,
      p_send_buffer: dft$p_command_buffer,
      p_send_buffer_header: ^dft$buffer_header,
      q_string: string (4),
      queue_entry_index: dft$queue_entry_index,
      value_set_count: 0 .. clc$max_value_sets,
      value_set_index: 0 .. clc$max_value_sets,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, display_queue_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF selected_queue_interface_table = NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$must_execute_setql, 'DISPLAY_QUEUE', status);
      RETURN;
    IFEND;

    clp$get_value ('QUEUE_ENTRY_INDEX', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    current_last := selected_queue_interface_table^.queue_directory.
          driver_queue_pva_directory [selected_queue_index].p_driver_queue^.queue_header.
          number_of_queue_entries;
    IF value.kind = clc$integer_value THEN
      IF current_last < value.int.value THEN
        STRINGREP (q_string, l, current_last);
        osp$set_status_abnormal (dfc$file_server_id, dfe$queue_entry_index_exceeded, q_string (1, l), status);
        RETURN;
      IFEND;
      first := value.int.value;
      current_last := first;
    ELSEIF value.name.value = 'LAST' THEN
      first := last_queue_entry_index;
      current_last := first;
    ELSE
      first := 1;
    IFEND;

    clp$get_set_count ('DISPLAY_OPTIONS', value_set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.kind <> clc$unknown_value THEN
      alternate_output_name := value.file.local_file_name;
      IF alternate_output_name <> p_output_id^.output_file_name THEN
        open_output_file (alternate_output_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    FOR value_set_index := 1 TO value_set_count DO

      clp$get_value ('DISPLAY_OPTIONS', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (value.name.value = 'DRIVER') OR ((value.name.value = 'ALL') AND (value_set_count = 1)) THEN

        FOR queue_entry_index := first TO current_last DO
          p_driver_queue_entry := ^selected_queue_interface_table^.queue_directory.
                driver_queue_pva_directory [selected_queue_index].
                p_driver_queue^.queue_entries [queue_entry_index];
          start_line (' Driver Queue ');
          add_integer_to_line (selected_queue_index);
          add_to_line (',   Entry Index=');
          add_integer_to_line (queue_entry_index);
          add_pva_to_line (p_driver_queue_entry);
          flush_line;
          display_flags (p_driver_queue_entry^.flags);
          start_line ('   error_condition ......... ');
          add_integer_to_line (p_driver_queue_entry^.error_condition);
          flush_line;
          start_line ('   held_over_cm_word_count . ');
          add_integer_to_line (p_driver_queue_entry^.held_over_cm_word_count);
          flush_line;
          start_line ('   held_over_esm_div_numb .. ');
          add_integer_to_line (p_driver_queue_entry^.held_over_esm_division_number);
          flush_line;

          start_line ('   send_buffer_descriptor    ');
          flush_line;
          start_line ('     indirect_address ...... ');
          end_line_with_boolean (p_driver_queue_entry^.send_buffer_descriptor.indirect_address);
          start_line ('     actual_length ......... ');
          add_integer_to_line (p_driver_queue_entry^.send_buffer_descriptor.actual_length);
          flush_line;
          start_line ('     address ............... ');
          add_hex_to_line (p_driver_queue_entry^.send_buffer_descriptor.address, TRUE);
          flush_line;

          start_line ('   receive_buffer_descriptor    ');
          flush_line;
          start_line ('     indirect_address ...... ');
          end_line_with_boolean (p_driver_queue_entry^.receive_buffer_descriptor.indirect_address);
          start_line ('     actual_length ......... ');
          add_integer_to_line (p_driver_queue_entry^.receive_buffer_descriptor.actual_length);
          flush_line;
          start_line ('     address ............... ');
          add_hex_to_line (p_driver_queue_entry^.receive_buffer_descriptor.address, TRUE);
          flush_line;

          start_line ('   data_descriptor    ');
          flush_line;
          start_line ('     indirect_address ...... ');
          end_line_with_boolean (p_driver_queue_entry^.data_descriptor.indirect_address);
          start_line ('     actual_length ......... ');
          actual_length := p_driver_queue_entry^.data_descriptor.actual_length;
          add_integer_to_line (actual_length);
          flush_line;
          start_line ('     address ............... ');
          add_hex_to_line (p_driver_queue_entry^.data_descriptor.address, TRUE);
          flush_line;
          IF actual_length > (selected_queue_interface_table^.maximum_data_bytes DIV osv$page_size) * 8 THEN
            start_line ('     NOTE ACTUAL_LENGTH GREATER THAN ALLOCATED LENGTH.');
            flush_line;
            actual_length := (selected_queue_interface_table^.maximum_data_bytes DIV osv$page_size) * 8;
          IFEND;
          FOR index := 1 TO (actual_length DIV 8) DO
            start_line ('        rma(');
            add_integer_to_line (index);
            add_to_line (') ..... ');
            p_cpu_queue_entry := ^selected_queue_interface_table^.queue_directory.
                  cpu_queue_pva_directory [selected_queue_index].
                  p_cpu_queue^.queue_entries [queue_entry_index];
            add_hex_to_line (p_cpu_queue_entry^.p_data_rma_list^ [index].rma, TRUE);
            flush_line;
          FOREND;
        FOREND;
      IFEND;
      IF (value.name.value = 'CPU') OR ((value.name.value = 'ALL') AND (value_set_count = 1)) THEN

        FOR queue_entry_index := first TO current_last DO
          p_cpu_queue_entry := ^selected_queue_interface_table^.queue_directory.
                cpu_queue_pva_directory [selected_queue_index].p_cpu_queue^.queue_entries [queue_entry_index];
          start_line (' CPU Queue ');
          add_integer_to_line (selected_queue_index);
          add_to_line (',   Entry Index=');
          add_integer_to_line (queue_entry_index);
          add_pva_to_line (p_cpu_queue_entry);
          flush_line;

          start_line ('   transaction_count .......... ');
          add_integer_to_line (p_cpu_queue_entry^.transaction_count);
          flush_line;

          display_transaction_state (p_cpu_queue_entry^.transaction_state);

          start_line ('   request_timeout_count ...... ');
          add_integer_to_line (p_cpu_queue_entry^.request_timeout_count);
          flush_line;

          start_line ('   retransmission_count ....... ');
          add_integer_to_line (p_cpu_queue_entry^.retransmission_count);
          flush_line;

          start_line ('   global_task_id ............. ');
          add_integer_to_line (p_cpu_queue_entry^.global_task_id.index);
          add_to_line (', ');
          add_integer_to_line (p_cpu_queue_entry^.global_task_id.seqno);
          flush_line;
          p_send_buffer := p_cpu_queue_entry^.p_send_buffer;
          start_line ('   p_send_buffer .............. ');
          add_pva_to_line (p_send_buffer);
          flush_line;

          RESET p_send_buffer;
          NEXT p_send_buffer_header IN p_send_buffer;
          p_receive_buffer := p_cpu_queue_entry^.p_receive_buffer;
          RESET p_receive_buffer;
          NEXT p_receive_buffer_header IN p_receive_buffer;

          start_line ('     version ............... ');
          add_to_line (p_send_buffer_header^.version);
          flush_line;
          start_line ('     transaction_count ..... ');
          add_integer_to_line (p_send_buffer_header^.transaction_count);
          flush_line;
          start_line ('     retransmission_count .. ');
          add_integer_to_line (p_send_buffer_header^.retransmission_count);
          flush_line;
          start_line ('     remote_processor ...... ');
          add_integer_to_line ($INTEGER (p_send_buffer_header^.remote_processor));
          flush_line;
          start_line ('     buffer_length_sent .... ');
          add_integer_to_line (p_send_buffer_header^.buffer_length_sent);
          flush_line;
          start_line ('     data_length_sent ...... ');
          add_integer_to_line (p_send_buffer_header^.data_length_sent);
          flush_line;
          IF (p_send_buffer_header^.version = dfc$poll_task_version) THEN
            NEXT p_poll_header IN p_send_buffer;
            start_line ('     poll_mainframe......... ');
            add_to_line (p_poll_header^.mainframe_name);
            flush_line;
            display_poll_type (p_poll_header^.poll_type);
          ELSEIF (p_send_buffer_header^.version = dfc$rpc_request_buffer_version) THEN
            NEXT p_rpc_buffer_header IN p_send_buffer;
            display_rpc_buffer_header (p_rpc_buffer_header^);
            IF (p_send_buffer_header^.remote_processor = dfc$rpc_restartable_test) OR
                  (p_send_buffer_header^.remote_processor = dfc$rpc_unrestartable_test) THEN
              NEXT p_rpc_test_header IN p_send_buffer;
              display_rpc_test_header (p_rpc_test_header^);
            IFEND;
          ELSEIF (p_send_buffer_header^.version = dfc$status_buffer_version) THEN
            { On server side
            NEXT p_mtr_status IN p_send_buffer;
            IF p_mtr_status^.normal THEN
              add_to_line ('        ......Normal status');
              flush_line;
            ELSE
              NEXT p_os_status IN p_send_buffer;
              display_status (p_os_status^);
            IFEND;
            IF p_receive_buffer_header^.version = dfc$rpc_request_buffer_version THEN
              NEXT p_rpc_response_buffer_header IN p_send_buffer;
              display_rpc_response_header (p_rpc_response_buffer_header^);
              IF (p_send_buffer_header^.remote_processor = dfc$rpc_restartable_test) OR
                    (p_send_buffer_header^.remote_processor = dfc$rpc_unrestartable_test) THEN
                NEXT p_rpc_test_header IN p_send_buffer;
                display_rpc_test_header (p_rpc_test_header^);
              IFEND;
            IFEND;
          IFEND;

          start_line ('   p_receive_buffer ........... ');
          add_pva_to_line (p_receive_buffer);
          flush_line;
          start_line ('     version ............... ');
          add_to_line (p_receive_buffer_header^.version);
          flush_line;
          start_line ('     transaction_count ..... ');
          add_integer_to_line (p_receive_buffer_header^.transaction_count);
          flush_line;
          start_line ('     retransmission_count .. ');
          add_integer_to_line (p_receive_buffer_header^.retransmission_count);
          flush_line;
          start_line ('     remote_processor ...... ');
          add_integer_to_line ($INTEGER (p_receive_buffer_header^.remote_processor));
          flush_line;
          start_line ('     buffer_length_sent .... ');
          add_integer_to_line (p_receive_buffer_header^.buffer_length_sent);
          flush_line;
          start_line ('     data_length_sent ...... ');
          add_integer_to_line (p_receive_buffer_header^.data_length_sent);
          flush_line;

          IF (p_receive_buffer_header^.version = dfc$poll_task_version) THEN
            NEXT p_poll_header IN p_receive_buffer;
            start_line ('     rec_poll_mainframe..... ');
            add_to_line (p_poll_header^.mainframe_name);
            flush_line;
            start_line ('     rec_poll_type.......... ');
            display_poll_type (p_poll_header^.poll_type);
            flush_line;
          ELSEIF (p_receive_buffer_header^.version = 'STATUS') THEN
            NEXT p_mtr_status IN p_receive_buffer;
            IF p_mtr_status^.normal THEN
              add_to_line ('    ..    Normal status');
              flush_line;
            ELSE
              NEXT p_os_status IN p_receive_buffer;
              display_status (p_os_status^);
            IFEND;
            IF p_send_buffer_header^.version = dfc$rpc_request_buffer_version THEN
              NEXT p_rpc_response_buffer_header IN p_receive_buffer;
              display_rpc_response_header (p_rpc_response_buffer_header^);
              IF (p_receive_buffer_header^.remote_processor = dfc$rpc_restartable_test) OR
                    (p_receive_buffer_header^.remote_processor = dfc$rpc_unrestartable_test) THEN
                NEXT p_rpc_test_header IN p_receive_buffer;
                display_rpc_test_header (p_rpc_test_header^);
              IFEND;
            IFEND;
          ELSEIF (p_receive_buffer_header^.version = dfc$rpc_request_buffer_version) THEN
            NEXT p_rpc_buffer_header IN p_receive_buffer;
            display_rpc_buffer_header (p_rpc_buffer_header^);
            IF (p_receive_buffer_header^.remote_processor = dfc$rpc_restartable_test) OR
                  (p_receive_buffer_header^.remote_processor = dfc$rpc_unrestartable_test) THEN
              NEXT p_rpc_test_header IN p_receive_buffer;
              display_rpc_test_header (p_rpc_test_header^);
            IFEND;
          IFEND;

          flush_line;
          start_line ('   p_data_rma_list ............ ');
          add_pva_to_line (p_cpu_queue_entry^.p_data_rma_list);
          flush_line;

          start_line ('   data_pages_locked .........  ');
          end_line_with_boolean (p_cpu_queue_entry^.data_pages_locked);

          start_line ('   processor_type ............. ');
          IF queue_entry_index = 1 THEN
            add_to_line ('POLL');
            flush_line;
          ELSEIF p_cpu_queue_entry^.processor_type = dfc$task_services THEN
            add_to_line (' TASK ');
            flush_line;
            put_pva_line ('      p_send_data ..........', p_cpu_queue_entry^.p_send_data);
            put_pva_line ('      p_receive_data........', p_cpu_queue_entry^.p_receive_data);
            put_integer_line ('    total data to receive...... ', p_cpu_queue_entry^.total_data_to_receive);
            display_call_progress (p_cpu_queue_entry^.call_progress);
            IF p_cpu_queue_entry^.server_to_client THEN
              IF p_cpu_queue_entry^.remote_procedure_called THEN
                start_line ('     remote_procedure_called = TRUE ');
              ELSE
                start_line ('     remote_procedure_called = FALSE ');
              IFEND;
              flush_line;
              put_pva_line ('      p_last_wired_data.....', p_cpu_queue_entry^.p_last_wired_data);
              put_integer_line ('      last_wired_length.....', p_cpu_queue_entry^.last_wired_length);
            ELSE
              put_line ('     Server_to_client = FALSE');
              put_integer_line ('       maximum_data_sent ', p_cpu_queue_entry^.maximum_data_sent);
              put_integer_line ('       maximum_data_received ', p_cpu_queue_entry^.maximum_data_received);
            IFEND;
          ELSEIF p_cpu_queue_entry^.processor_type = dfc$monitor THEN
            add_to_line ('MONITOR');
            flush_line;
            start_line ('   io_id ...................... ');
            flush_line;
            start_line ('     specified ................ ');
            end_line_with_boolean (p_cpu_queue_entry^.io_id.specified);
            start_line ('     io_function .............. ');
            add_integer_to_line ($INTEGER (p_cpu_queue_entry^.io_id.io_function));
            flush_line;
            IF (p_cpu_queue_entry^.io_id.io_function >= ioc$read_for_server) AND
                  (p_cpu_queue_entry^.io_id.io_function <= ioc$allocate) THEN
              start_line ('     queue_entry_location:      ');
              flush_line;
              start_line ('       directory_index ........ ');
              add_integer_to_line (p_cpu_queue_entry^.io_id.queue_entry_location.directory_index);
              flush_line;
              start_line ('       queue_index ............ ');
              add_integer_to_line (p_cpu_queue_entry^.io_id.queue_entry_location.queue_index);
              flush_line;
              start_line ('       queue_entry_index ...... ');
              add_integer_to_line (p_cpu_queue_entry^.io_id.queue_entry_location.queue_entry_index);
              flush_line;
            ELSEIF p_cpu_queue_entry^.io_id.io_function = ioc$read_ahead_on_server THEN
              start_line ('       read_ahead_iocb_index .. ');
              add_integer_to_line (p_cpu_queue_entry^.io_id.read_ahead_iocb_index);
              flush_line;
            IFEND;
            start_line ('   ajlo ....................... ');
            add_integer_to_line ($INTEGER (p_cpu_queue_entry^.ajlo));
            flush_line;
            start_line ('   io_type .................... ');
            add_integer_to_line ($INTEGER (p_cpu_queue_entry^.io_type));
            flush_line;
            display_sfid (p_cpu_queue_entry^.sfid);
            start_line ('   p_server_iocb ............... ');
            IF p_cpu_queue_entry^.p_server_iocb = NIL THEN
              add_to_line ('NIL');
              flush_line;
            ELSE
              add_pva_to_line (p_cpu_queue_entry^.p_server_iocb);
              flush_line;
              start_line ('     global_file_name ... ');
              pmp$convert_binary_unique_name (p_cpu_queue_entry^.p_server_iocb^.global_file_name, gfn,
                    status);
              add_to_line (gfn);
              flush_line;

              display_server_state (p_cpu_queue_entry^.p_server_iocb^.server_state);

              display_sfid (p_cpu_queue_entry^.p_server_iocb^.sfid);

              start_line ('     offset ............. ');
              add_integer_to_line (p_cpu_queue_entry^.p_server_iocb^.offset);
              flush_line;
              start_line ('     length ............. ');
              add_integer_to_line (p_cpu_queue_entry^.p_server_iocb^.length);
              flush_line;
              start_line ('     eoi ................ ');
              add_integer_to_line (p_cpu_queue_entry^.p_server_iocb^.eoi);
              flush_line;
              start_line ('     sub_reqcode ........ ');
              CASE p_cpu_queue_entry^.p_server_iocb^.sub_reqcode OF
              = mmc$iorc_read_pages =
                add_to_line ('read_pages');
              = mmc$iorc_write_pages =
                add_to_line ('write_pages');
              = mmc$iorc_await_io_completion =
                add_to_line ('await_io_completion');
              ELSE
                add_to_line ('unknown subreq');
              CASEND;
              flush_line;
              display_server_iocb_condition (p_cpu_queue_entry^.p_server_iocb^.condition);
              flush_line;
              start_line ('     io_already_active... ');
              end_line_with_boolean (p_cpu_queue_entry^.p_server_iocb^.io_already_active);
              start_line ('     active_io_count .... ');
              add_integer_to_line (p_cpu_queue_entry^.p_server_iocb^.active_io_count);
              flush_line;
              start_line ('     reissue_request .... ');
              end_line_with_boolean (p_cpu_queue_entry^.p_server_iocb^.reissue_request);
              start_line ('     restart_count ...... ');
              add_integer_to_line (p_cpu_queue_entry^.p_server_iocb^.restart_count);

            IFEND;
            start_line ('   current_request_type ......... ');
            IF p_cpu_queue_entry^.current_request_type = dfc$monitor_io THEN
              add_to_line (' IO');
            ELSE
              add_to_line (' ALLOCATE');
            IFEND;
            flush_line;
            start_line ('   current_request_time ......... ');
            add_integer_to_line (p_cpu_queue_entry^.current_request_time);
            flush_line;
          ELSE
            add_to_line ('TASK');
            flush_line;
          IFEND;
        FOREND;
      IFEND;
    FOREND;

    IF p_output_id^.alternate_output_open THEN
      fsp$close_file (p_output_id^.output_file_fid, status);
      p_output_id^.output_file_fid := p_output_id^.save_output_fid;
      p_output_id^.page_width := p_output_id^.save_page_width;
      #SPOIL (p_output_id^.alternate_output_open);
      p_output_id^.alternate_output_open := FALSE;
      #SPOIL (p_output_id^.alternate_output_open);
    IFEND;

  PROCEND dfp$display_queue;
?? EJECT ??

  PROCEDURE display_server_state
    (    server_state: mmt$server_state);

    start_line ('     server_state ....... ');
    CASE server_state OF
    = mmc$ss_queue_initialized =
      add_to_line ('queue_initialized');
    = mmc$ss_waiting =
      add_to_line ('waiting');
    = mmc$ss_reading_from_disk =
      add_to_line ('reading_from_disk');
    = mmc$ss_read_disk_error =
      add_to_line ('read_disk_error');
    = mmc$ss_writing_to_esm =
      add_to_line ('writing_to_esm');
    = mmc$ss_write_esm_error =
      add_to_line ('write_esm_error');
    = mmc$ss_reading_from_esm =
      add_to_line ('reading_from_esm');
    = mmc$ss_read_esm_error =
      add_to_line ('read_esm_error');
    = mmc$ss_writing_to_disk =
      add_to_line ('writing_to_disk');
    = mmc$ss_write_disk_error =
      add_to_line ('write_disk_error');
    = mmc$ss_sending_write_response =
      add_to_line ('sending_write_response');
    = mmc$ss_sending_write_resp_error =
      add_to_line ('send_write_response_error');
    = mmc$ss_allocating_space =
      add_to_line ('allocating_space');
    = mmc$ss_allocate_space_error =
      add_to_line ('allocate_space_error');
    = mmc$ss_send_allocate_response =
      add_to_line ('sending_allocate_response');
    = mmc$ss_send_allocate_resp_error =
      add_to_line ('send_allocate_response_error');
    = mmc$ss_reading_pages_ahead =
      add_to_line ('reading_pages_ahead');
    ELSE
      add_integer_to_line ($INTEGER (server_state));
    CASEND;
  PROCEND display_server_state;
?? EJECT ??

  PROCEDURE display_sfid
    (    sfid: gft$system_file_identifier);

    flush_line;
    start_line ('     sfid ............... ');
    flush_line;
    start_line ('       file_entry_index . ');
    add_integer_to_line (sfid.file_entry_index);
    flush_line;
    start_line ('       residence ........ ');
    CASE sfid.residence OF
    = gfc$tr_job =
      add_to_line ('job');
    = gfc$tr_system =
      add_to_line ('system');
    = gfc$tr_null_residence =
      add_to_line ('null_residence');
    = gfc$tr_system_wait_recovery =
      add_to_line ('system_wait_recovery');

    ELSE
      add_to_line ('unknown file location');
    CASEND;
    flush_line;
    start_line ('       file_hash ........ ');
    add_integer_to_line (sfid.file_hash);
    flush_line;
  PROCEND display_sfid;
?? EJECT ??

  PROCEDURE display_server_iocb_condition
    (    condition: dft$server_iocb_error_condition);

    start_line ('     condition .......... ');
    CASE condition OF
    = dfc$null_server_condition =
      add_to_line ('null_server_condition');
    = dfc$reissued_rq_no_memory =
      add_to_line ('reissued_rq_no_memory');
    = dfc$reissued_rq_low_on_memory =
      add_to_line ('reissued_rq_low_on_memory');
    = dfc$reissued_rq_pt_full =
      add_to_line ('reissued_rq_pt_full');
    = dfc$reissued_rq_io_temp_reject =
      add_to_line ('reissued_rq_io_temp_reject');
    = dfc$reissu_rq_temp_rej_fde_lock =
      add_to_line ('reissued_rq_temp_reject_fde_locked');
    = dfc$reissued_rq_temp_rej_q_full =
      add_to_line ('reissued_rq_temp_reject_queue_full');
    = dfc$reissued_rq_io_still_active =
      add_to_line ('reissued_rq_io_still_active');
    = dfc$reissued_rq_task_queued =
      add_to_line ('reissued_rq_task_queued');
    = dfc$reissue_rq_client_locked_pg =
      add_to_line ('reissue_rq_client_locked_pg');
    = dfc$server_page_locked =
      add_to_line ('server_page_locked');
    = dfc$server_read_beyond_eoi =
      add_to_line ('server_read_beyond_eoi');
    = dfc$server_beyond_file_limit =
      add_to_line ('server_beyond_file_limit');
    = dfc$server_no_extend_permission =
      add_to_line ('server_no_extend_permission');
    = dfc$server_signal_select_on_pf =
      add_to_line ('server_signal_select_on_pf');
    = dfc$server_beyond_tape_window =
      add_to_line ('server_beyond_tape_window');
    = dfc$server_io_already_active =
      add_to_line ('server_io_already_active');
    = dfc$server_io_not_active =
      add_to_line ('server_io_not_active');
    = dfc$server_pages_not_available =
      add_to_line ('server_pages_not_available');
    = dfc$server_write_client_error =
      add_to_line ('server_write_client_error');
    = dfc$unrecovered_disk_error =
      add_to_line ('unrecovered_disk_error');
    = dfc$pp_not_configured =
      add_to_line ('pp_not_configured');
    = dfc$pp_interlock_set =
      add_to_line ('pp_interlock_set');
    = dfc$no_space_to_allocate =
      add_to_line ('no_space_to_allocate');
    = dfc$invalid_image_request =
      add_to_line ('invalid_image_request');
    = dfc$invalid_disk_type =
      add_to_line ('invalid_disk_type');
    = dfc$disk_media_error =
      add_to_line ('disk_media_error');
    = dfc$requests_full =
      add_to_line ('requests_full');
    = dfc$unable_to_build_io_request =
      add_to_line ('unable_to_build_io_request');
    = dfc$free_failure =
      add_to_line ('free_failure');
    = dfc$address_error =
      add_to_line ('address_error');
    = dfc$unable_to_unlock_rma_list =
      add_to_line ('unable_to_unlock_rma_list');
    = dfc$unable_to_set_system_flag =
      add_to_line ('unable_to_set_system_flag');
    = dfc$allocation_failure =
      add_to_line ('allocation_failure');
    = dfc$unable_to_queue_io_request =
      add_to_line ('unable_to_queue_io_request');
    = dfc$unable_to_destroy_io_req =
      add_to_line ('unable_to_destroy_io_req');
    = dfc$io_completion_table_error =
      add_to_line ('io_completion_table_error');
    = dfc$unsupported_monitor_request =
      add_to_line ('unsupported_monitor_request');
    = dfc$request_id_mismatch =
      add_to_line ('request_id_mismatch');
    = dfc$io_request_error =
      add_to_line ('io_request_error');
    = dfc$ssiot_recovery_required =
      add_to_line ('ssiot_recovery_required');
    ELSE
      add_integer_to_line ($INTEGER (condition));
    CASEND;
  PROCEND display_server_iocb_condition;
?? EJECT ??

  PROCEDURE display_flags
    (    flags: dft$queue_entry_flags);

    start_line ('  Flags:');
    flush_line;
    start_line ('     active_entry .......... ');
    end_line_with_boolean (flags.active_entry);
    start_line ('     driver_action ......... ');
    end_line_with_boolean (flags.driver_action);
    start_line ('     subsystem_action ...... ');
    end_line_with_boolean (flags.subsystem_action);
    start_line ('     driver_error_alert .... ');
    end_line_with_boolean (flags.driver_error_alert);
    start_line ('     send_command .......... ');
    end_line_with_boolean (flags.send_command);
    start_line ('     send_data ............. ');
    end_line_with_boolean (flags.send_data);
    start_line ('     send_ready_for_data ... ');
    end_line_with_boolean (flags.send_ready_for_data);
    start_line ('     buffer_sent ........... ');
    end_line_with_boolean (flags.buffer_sent);
    start_line ('     data_sent ............. ');
    end_line_with_boolean (flags.data_sent);
    start_line ('     buffer_received ....... ');
    end_line_with_boolean (flags.buffer_received);
    start_line ('     data_received ......... ');
    end_line_with_boolean (flags.data_received);
    start_line ('     ready_for_data_sent ... ');
    end_line_with_boolean (flags.ready_for_data_sent);
    start_line ('     ready_for_data_received ');
    end_line_with_boolean (flags.ready_for_data_received);
    start_line ('     process_response ...... ');
    end_line_with_boolean (flags.process_response);
  PROCEND display_flags;
?? EJECT ??

  PROCEDURE display_transaction_state
    (    transaction_state: dft$transaction_state);

    start_line ('   transaction_state .......... ');
    CASE transaction_state OF
    = dfc$null_state =
      add_to_line ('null_state');
    = dfc$queue_entry_available =
      add_to_line ('queue_entry_available');
    = dfc$queue_entry_assigned =
      add_to_line ('queue_entry_assigned');
    = dfc$request_queued =
      add_to_line ('request_queued');
    = dfc$request_sent =
      add_to_line ('request_sent');
    = dfc$server_must_read_page_data =
      add_to_line ('server_must_read_page_data');
    = dfc$server_received_request =
      add_to_line ('server_received_request');
    = dfc$server_sent_response =
      add_to_line ('server_sent_response');
    = dfc$client_must_read_page_data =
      add_to_line ('client_must_read_page_data');
    = dfc$response_received =
      add_to_line ('response_received');
    = dfc$media_error =
      add_to_line ('media_error');
    = dfc$message_content_error =
      add_to_line ('message_content_error');
    = dfc$server_waiting_request =
      add_to_line ('server_waiting_request');
    ELSE
      add_integer_to_line ($INTEGER (transaction_state));
    CASEND;
    flush_line;
  PROCEND display_transaction_state;
?? EJECT ??

  PROCEDURE display_poll_type
    (    poll_type: dft$poll_type);

    start_line ('     poll_type.............. ');
    CASE poll_type OF
    = dfc$normal_poll =
      add_to_line ('dfc$normal_poll');
    = dfc$verify_served_family =
      add_to_line ('dfc$verify_served_family');
    = dfc$verify_queue =
      add_to_line ('dfc$verify_queue');
    = dfc$deactivate_server =
      add_to_line ('dfc$deactivate_server');
    = dfc$deactivate_complete =
      add_to_line ('dfc$deactivate_complete');
    = dfc$poll_reply =
      add_to_line ('dfc$poll_reply');
    = dfc$recovery_complete_reply =
      add_to_line ('dfc$recovery_complete_reply');
    = dfc$verify_family_reply =
      add_to_line ('dfc$verify_family_reply');
    = dfc$verify_queue_reply =
      add_to_line ('dfc$verify_queue_reply');
    = dfc$deactivate_reply =
      add_to_line ('dfc$deactivate_reply');
    = dfc$req_verify_served_family =
      add_to_line ('dfc$req_verify_served_family');
    ELSE
      add_to_line (' Unknown poll type ');
    CASEND;
    flush_line;
  PROCEND display_poll_type;
?? EJECT ??

  PROCEDURE display_rpc_test_header
    (    test_header: dft$rpc_test_request_header);

    put_line ('  --------- RPC TEST HEADER ');
    put_integer_line ('     compute_checksum ', $INTEGER (test_header.compute_checksum));
    put_integer_line ('     start_time ', test_header.start_time);
    put_integer_line ('     send_buffer_size ', test_header.send_buffer_size);
    put_integer_line ('     receive_buffer_size ', test_header.receive_buffer_size);
    put_integer_line ('     send_buffer_starting_char ', $INTEGER (test_header.send_buffer_starting_char));
    put_integer_line ('     buffer_checksum ', test_header.buffer_checksum);
    put_integer_line ('     send_data_size ', test_header.send_data_size);
    put_integer_line ('     receive_data_size ', test_header.receive_data_size);
    put_integer_line ('     data_starting_char ', $INTEGER (test_header.data_starting_char));
    put_integer_line ('     data_checksum ', test_header.data_checksum);
  PROCEND display_rpc_test_header;

?? EJECT ??

  PROCEDURE display_rpc_buffer_header
    (    rpc_buffer_header: dft$rpc_buffer_header);

    start_line ('   Rpc_buffer_header .......... ');
    flush_line;
    start_line ('   system_supplied_job_name ... ');
    add_to_line (rpc_buffer_header.system_supplied_job_name);
    flush_line;
    start_line ('   procedure_version .......... ');
    add_to_line (rpc_buffer_header.procedure_version);
    flush_line;
    put_integer_line ('   procedure_version .......... ', rpc_buffer_header.procedure_name_checksum);
    CASE rpc_buffer_header.procedure_class OF
    = dfc$permanent_file_call =
      put_line ('   procedure_class............. dfc$permanent_file_call');
      put_integer_line ('   client_job_id.job_list_pointer_index ',
            rpc_buffer_header.client_job_id.job_list_pointer_index);
      put_integer_line ('   client_job_id.job_list_index ', rpc_buffer_header.client_job_id.job_list_index);
    = dfc$system_core_call =
      put_line ('   procedure_class............. dfc$system_core_call');
    ELSE
      put_line ('   procedure_class............. Unknown  ');
    CASEND;
    display_call_progress (rpc_buffer_header.call_progress);

  PROCEND display_rpc_buffer_header;
?? EJECT ??

  PROCEDURE display_rpc_response_header
    (    rpc_response_buffer_header: dft$rpc_response_buffer_header);

    put_line (' Remote procedure call response ');
    display_call_progress (rpc_response_buffer_header.call_progress);
  PROCEND display_rpc_response_header;
?? EJECT ??

  PROCEDURE display_call_progress
    (    call_progress: dft$rpc_progress_record);

    put_line ('   Call progress...............');
    put_integer_line ('   transaction_per_rpc_request.', call_progress.transaction_per_rpc_request);
    put_integer_line ('   total_data_sent.............', call_progress.total_data_sent);
    put_integer_line ('   total_data_received.........', call_progress.total_data_received);
    put_integer_line ('   user_buffer_length_sent.....', call_progress.user_buffer_length_sent);
    put_integer_line ('   user_data_length_sent.......', call_progress.user_data_length_sent);

  PROCEND display_call_progress;
?? EJECT ??
  PROCEDURE flush_family_table
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt quit_pdt ()

?? PUSH (LISTEXT := ON) ??

    VAR
      quit_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??

    clp$scan_parameter_list (parameter_list, quit_pdt, status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$flush_served_family_table (status);
  PROCEND flush_family_table;
?? EJECT ??
  PROCEDURE log_side_door_port
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);



{   pdt lsdp_pdt (status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    lsdp_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
  ^lsdp_pdt_names, ^lsdp_pdt_params];

  VAR
    lsdp_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1]
  of clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    lsdp_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
  clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??
    clp$scan_parameter_list (parameter_list, lsdp_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$log_side_door_port_status (dfc$sdp_top_of_hour, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND log_side_door_port;
?? EJECT ??
  PROCEDURE put_pva_line
    (    descr: string ( * );
         p_cell: ^cell);

    VAR
      length: integer,
      pva_string: string (20);

    start_line (descr);
    IF p_cell = NIL THEN
      add_to_line (' NIL ');
    ELSE
      STRINGREP (pva_string, length, p_cell);
      add_to_line (pva_string (1, length));
    IFEND;
    flush_line;
  PROCEND put_pva_line;

?? EJECT ??

  PROCEDURE put_integer_line
    (    descr: string ( * );
         int: integer);

    start_line (descr);
    add_integer_to_line (int);
    flush_line;
  PROCEND put_integer_line;

MODEND dfm$driver_test_utility;


*DECK DECK=DFM$ESM_DEFINITION_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File Server: ESM Definition Manager and Malet Interface.' ??
MODULE dfm$esm_definition_manager;

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmt$channel_descriptor
*copyc cmt$data_channel_definition
*copyc cmt$element_definition
*copyc cmt$element_descriptor
*copyc cmt$element_type
*copyc cmt$esm_definition
*copyc cmt$upline_connection
*copyc dfc$esm_allocation_constants
*copyc dfc$iou_names
*copyc dfe$error_condition_codes
*copyc dfi$display
*copyc dfi$log_display
*copyc dft$cpu_queue
*copyc dft$esm_definition_table
*copyc dft$esms_defined
*copyc dft$queue_interface_directory
*copyc osd$integer_limits
*copyc oss$job_paged_literal
*copyc pmt$mainframe_id
?? POP ??
*copyc clp$evaluate_parameters
*copyc cmp$get_channel_definition
*copyc cmp$get_element_definition
*copyc dfp$count_mainframes_per_esm
*copyc dfp$log_side_door_port_status
*copyc dfp$verify_element_name
*copyc dfp$verify_system_administrator
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$convert_mainframe_to_binary
*copyc pmp$get_mainframe_id
*copyc pmp$zero_out_table
?? EJECT ??
*copyc dfv$file_server_debug_enabled
*copyc dfv$p_esm_definition_table
*copyc dfv$server_wired_heap
*copyc osv$page_size
?? OLDTITLE ??
?? NEWTITLE := 'dfp$any_esm_defined', EJECT ??

{ PURPOSE:
{   Determine if there is a STORNET/ESM connection defined on this mainframe.

  FUNCTION [XDCL] dfp$any_esm_defined: boolean;

    dfp$any_esm_defined := dfv$p_esm_definition_table <> NIL;

  FUNCEND dfp$any_esm_defined;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$any_sdp_defined', EJECT ??

{ PURPOSE:
{   Determine if there is a STORNET/ESM side door port defined on this mainframe.  This is used by side door
{   port logging.

  PROCEDURE [XDCL] dfp$any_sdp_defined
    (VAR any_sdp_defined: boolean);

    VAR
      current_mainframe_id: pmt$mainframe_id,
      ignore_status: ost$status,
      p_esm_table_entry: ^dft$esm_definition_table_entry,
      side_door_port_index: 1 .. cmc$max_side_door_port_number;

    any_sdp_defined := FALSE;
    pmp$get_mainframe_id (current_mainframe_id, ignore_status);
    p_esm_table_entry := dfv$p_esm_definition_table;

  /for_all_defined_stornets/
    WHILE p_esm_table_entry <> NIL DO

    /determine_if_side_door_port/
      FOR side_door_port_index := 1 TO cmc$max_side_door_port_number DO
        IF (p_esm_table_entry^.p_side_door_ports [side_door_port_index] <> NIL) AND
              (p_esm_table_entry^.p_side_door_ports [side_door_port_index]^.mainframe_id =
              current_mainframe_id) THEN
          any_sdp_defined := TRUE;
          RETURN;
        IFEND;
      FOREND /determine_if_side_door_port/;
      p_esm_table_entry := p_esm_table_entry^.p_next_table_entry;
    WHILEND /for_all_defined_stornets/;
  PROCEND dfp$any_sdp_defined;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$define_esm_command ', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$define_esm_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      current_mainframe_id: pmt$mainframe_id,
      esm_parameters: dft$esm_specifications,
      port: integer;

    status.normal := TRUE;
    dfp$verify_system_administrator ('DEFINE_STORNET_CONNECTION', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF osv$page_size < dfc$command_buffer_size THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$page_size_too_small, '', status);
      RETURN;
    IFEND;

    crack_esm_parameters (parameter_list, esm_parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_esm_def_table_entry (esm_parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_mainframe_id (current_mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

   /start_side_door_port_logging/
    FOR port := 1 TO esm_parameters.side_door_ports.number DO
      IF esm_parameters.side_door_ports.ports [port].mainframe_id = current_mainframe_id THEN
        IF dfv$file_server_debug_enabled THEN
          display ('SIDE DOOR PORT LOGGING INITIATED');
        IFEND;
        log_display ($pmt$ascii_logset [pmc$system_log, pmc$job_log], 'SIDE DOOR PORT LOGGING INITIATED');
        dfp$log_side_door_port_status (dfc$sdp_initialization, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        EXIT /start_side_door_port_logging/;
      IFEND;
    FOREND;

  PROCEND dfp$define_esm_command;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$delete_esm_command ', EJECT ??
  PROCEDURE [XDCL, #GATE] dfp$delete_esm_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE delete_stornet_connection, delsc (
{   element_name, en: name = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 9, 4, 11, 16, 39, 267],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['ELEMENT_NAME                   ',clc$nominal_entry, 1],
    ['EN                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element_name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      any_side_door_port_defined: boolean,
      element_name: cmt$element_name;

    status.normal := TRUE;
    dfp$verify_system_administrator ('DELETE_STORNET_CONNECTION', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$any_sdp_defined (any_side_door_port_defined);

    IF any_side_door_port_defined THEN
      IF dfv$file_server_debug_enabled THEN
        display ('SIDE DOOR PORT LOGGING TERMINATED');
      IFEND;
      log_display ($pmt$ascii_logset [pmc$system_log, pmc$job_log], 'SIDE DOOR PORT LOGGING TERMINATED');
    IFEND;

    element_name := pvt [p$element_name].value^.name_value;
    delete_esm_def_table_entry (element_name, status);

  PROCEND dfp$delete_esm_command;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$locate_esm_definition', EJECT ??

{ PURPOSE:
{   This procedures scans the ESM_DEFINITION_TABLE looking for a match on ELEMENT_NAME. If the element is
{   found in the table then ESM_TABLE_ENTRY_P contains the pointer to the matched table entry.  If the
{   element name is not found in the table then the pointer is returned with a NIL value.

  PROCEDURE [XDCL] dfp$locate_esm_definition
    (    esm_name: cmt$element_name;
     VAR esm_table_entry_p: ^dft$esm_definition_table_entry);

    VAR
      current_esm_table_entry_p: ^dft$esm_definition_table_entry;

    esm_table_entry_p := NIL;
    current_esm_table_entry_p := dfv$p_esm_definition_table;
    WHILE current_esm_table_entry_p <> NIL DO
      IF current_esm_table_entry_p^.element_name = esm_name THEN
        esm_table_entry_p := current_esm_table_entry_p;
        RETURN;
      IFEND;
      current_esm_table_entry_p := current_esm_table_entry_p^.p_next_table_entry;
    WHILEND;

  PROCEND dfp$locate_esm_definition;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$return_esm_base_addresses ', EJECT ??

{ PURPOSE:
{   This procedure pulls ESM base addresses from ESM_DEFINITION_TABLE and returns this record to the caller.

  PROCEDURE [XDCL] dfp$return_esm_base_addresses
    (    element: cmt$element_name;
     VAR esm_base_addresses: dft$esm_base_addresses;
     VAR status: ost$status);

    VAR
      esm_def_table_entry_p: ^dft$esm_definition_table_entry;

    status.normal := TRUE;
    dfp$locate_esm_definition (element, esm_def_table_entry_p);
    IF esm_def_table_entry_p = NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$stornet_not_defined, element, status);
      RETURN;
    IFEND;

    esm_base_addresses := esm_def_table_entry_p^.esm_base_addresses;

  PROCEND dfp$return_esm_base_addresses;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$return_esm_definition ', EJECT ??
  PROCEDURE [XDCL, #GATE] dfp$return_esm_definition
    (    element: cmt$element_descriptor;
     VAR definition: cmt$esm_definition;
     VAR status: ost$status);

    VAR
      channel_configured: boolean,
      element_definition: cmt$element_definition,
      low_speed_port_index: 1 .. cmc$max_low_speed_port_number,
      mainframe_name: pmt$mainframe_id,
      p_esm_def_table_entry: ^dft$esm_definition_table_entry,
      port_number: cmt$communications_port_number,
      side_door_port: boolean,
      side_door_port_index: 1 .. cmc$max_side_door_port_number;

{------------------------------------------------------------------------
{  This procedure pulls information about ESM from CM ELEMENT_DEFINITION
{  and DF ESM_DEFINITION tables and returns it to the caller.
{------------------------------------------------------------------------

    status.normal := TRUE;

{   Get the channel/mainframe_id array for the element.
    cmp$get_element_definition (element, element_definition, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Verify that the specified element is the ESM product.
    dfp$verify_esm_product_id (element_definition.product_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Get the location of ESM_DEFINITION_TABLE.
    dfp$locate_esm_definition (element_definition.element_name, p_esm_def_table_entry);
    IF p_esm_def_table_entry = NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$stornet_not_defined, element_definition.
           element_name, status);
      RETURN;
    IFEND;

{   Initialize all ports to NOT CONFIGURED.
    FOR side_door_port_index := 1 TO cmc$max_side_door_port_number DO
      definition.side_door_port [side_door_port_index].configured := FALSE;
    FOREND;
    FOR port_number := 1 TO cmc$max_low_speed_port_number DO
      definition.low_speed_port [port_number].configured := FALSE;
    FOREND;

    definition.element_name := element_definition.element_name;
    definition.product_id := element_definition.product_id;
    definition.serial_number := element_definition.serial_number;
    definition.peripheral_driver_name := element_definition.communications_element.peripheral_driver_name;
    definition.memory_size := p_esm_def_table_entry^.memory_size;
    definition.maintenance_buffer_location := p_esm_def_table_entry^.maintenance_buffer_loc;

    channel_configured := FALSE;
    low_speed_port_index := 1;
  /get_channel_info/
    FOR port_number := LOWERVALUE (cmt$communications_port_number)
          TO UPPERVALUE (cmt$communications_port_number) DO
      IF element_definition.communications_element.connection.port [port_number].configured THEN
        channel_configured := TRUE;

        side_door_port := FALSE;

      /determine_if_side_door_port/
        FOR side_door_port_index := 1 to cmc$max_side_door_port_number DO
          IF p_esm_def_table_entry^.p_side_door_ports [side_door_port_index] = NIL THEN
            EXIT /determine_if_side_door_port/;

          ELSE
            IF (p_esm_def_table_entry^.p_side_door_ports [side_door_port_index]^.channel_name =
                    element_definition.communications_element.connection.port [port_number].element_name) AND
              (p_esm_def_table_entry^.p_side_door_ports [side_door_port_index]^.mainframe_id =
                    element_definition.communications_element.connection.port [port_number].
                    mainframe_ownership) THEN
              definition.side_door_port [side_door_port_index] := element_definition.communications_element.
                   connection.port [port_number];
              side_door_port := TRUE;
              EXIT /determine_if_side_door_port/;
            IFEND;
          IFEND;
        FOREND /determine_if_side_door_port/;

        IF NOT side_door_port THEN
          IF low_speed_port_index = cmc$max_low_speed_port_number THEN
            osp$set_status_abnormal (dfc$file_server_id, dfe$too_many_low_speed_ports,
                 element_definition.element_name, status);
            RETURN;
          IFEND;
          definition.low_speed_port [low_speed_port_index] := element_definition.communications_element.
               connection.port [port_number];
          low_speed_port_index := low_speed_port_index + 1;
        IFEND;
      IFEND;
    FOREND /get_channel_info/;

    IF NOT channel_configured THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$no_configured_channel,
           element_definition.element_name, status);
      RETURN;
    IFEND;

  PROCEND dfp$return_esm_definition;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$return_esms_defined ', EJECT ??

{ PURPOSE:
{   This procedure returns all STORNET/ESM element names defined on this mainframe.

  PROCEDURE [XDCL] dfp$return_esms_defined
    (VAR esms_defined: dft$esms_defined_count;
     VAR esm_name_array: dft$esms_defined);

    VAR
      p_esm_table_entry: ^dft$esm_definition_table_entry;

    esms_defined := 0;
    p_esm_table_entry := dfv$p_esm_definition_table;
    WHILE p_esm_table_entry <> NIL DO
      esms_defined := esms_defined + 1;
      IF esms_defined <= UPPERBOUND (esm_name_array) THEN
        esm_name_array [esms_defined] := p_esm_table_entry^.element_name;
      IFEND;
      p_esm_table_entry := p_esm_table_entry^.p_next_table_entry;
    WHILEND;

  PROCEND dfp$return_esms_defined;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$verify_esm_product_id ', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$verify_esm_product_id
    (    product_id: cmt$product_identification;
     VAR status: ost$status);

    VAR
      esm2_product_id: [READ, OSS$JOB_PAGED_LITERAL] cmt$product_identification :=
         [' $7040', '_', '200'],
      stornet_product_id: [READ, OSS$JOB_PAGED_LITERAL] cmt$product_identification :=
         [' $5380', '_', '100'];

    status.normal := TRUE;
    IF product_id = esm2_product_id THEN

      { Valid ESM product identification, DO NOTHING.

    ELSEIF product_id = stornet_product_id THEN

      { Valid ESM product identification, DO NOTHING.

    ELSE {invalid ESM product identification.}
      osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_stornet_product_id, product_id.product_number,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, product_id.model_number, status);
    IFEND;

  PROCEND dfp$verify_esm_product_id;
?? OLDTITLE ??
?? NEWTITLE := 'calculate_division_size ', EJECT ??

{ PURPOSE:
{   This procedure calculates the size of the ESM division so that
{    1. ESM division size is a multiple of 100 octal 60 bit ESM words.
{    2. The ESM starting address of both the Command record and the Data record is a multiple of 10 octal 60
{       bit ESM words.
{    3. The space provided for the Data record within the division is at least three ESM 8 word records larger
{       than what is required for the data, and the division size is a multiple of 8 ESM words (ESM records).
{       The extra division space is necessary so that the driver can write beyond what is actually required to
{       clear ESM memory parity errors caused by power loss. Because ESM reads ahead, any parity error beyond
{       the real data will be detected.
{
{   The maximum_data_bytes field of the esm_specifications record is the number of bytes which will fit into
{   the Data record. This value may be specified as the input parameter requested_data_bytes. If a value of
{   zero is specified, the largest value which will fit within the available ESM space and which meets the
{   following criteria will be calculated.  The value of maximum_data_bytes must be within the range of
{   (dfc$min_data_record_bytes * 4 .. dfc$max_data_record_bytes), and values in between must be equal to
{   (dfc$min_data_record_bytes * 4) times a power of 2 multiplier.
{
{     The following values are stored into the ESM_SPECIFICATIONS record :
{
{     MAXIMUM_DATA_BYTES   - The maximum number of data bytes which may be sent/received by this machine in a
{                            single File Server transaction.
{
{     ESM_DIVISION_SIZE    - The number of 60 bit ESM words divided by 100 octal per ESM division.
{
{     ESM_DIVSIZ_12BIT_CW  - The ESM division size in 12 bit channel words divided by 100 octal.
{
{     ESM_DIVSIZ_16BIT_CW  - The ESM division size in 16 bit channel words divided by 100 octal.

  PROCEDURE calculate_division_size
    (    requested_data_bytes: 0 .. dfc$max_data_record_bytes;
     VAR esm_specifications: dft$esm_specifications;
     VAR status: ost$status);

    VAR
      base_esm_address: 0 .. dfc$max_esm_memory_size,
      data_record_bytes: 0 .. dfc$max_data_record_bytes,
      division_size: integer,
      division_space: integer,
      esm_space: integer,
      esm_space_per_mf: integer,
      number_of_divisions: 1 .. dfc$max_esm_divisions,
      number_of_mainframes: 1 .. dfc$max_number_of_mainframes,
      total_required: integer;

    status.normal := TRUE;

    number_of_divisions := esm_specifications.esm_base_addresses.divisions_per_mainframe;
    number_of_mainframes := esm_specifications.esm_base_addresses.number_of_mainframes;
    base_esm_address := (esm_specifications.esm_base_addresses.esm_memory_base * dfc$esm_memory_base_shift);
    esm_space := (esm_specifications.memory_size - base_esm_address) - dfc$esm_maintenance_buf_size;
    esm_space_per_mf := esm_space DIV number_of_mainframes;
    division_space := esm_space_per_mf DIV number_of_divisions;

    IF requested_data_bytes > 0 THEN
      data_record_bytes := requested_data_bytes;
      division_size := ((((((((data_record_bytes * 8) DIV 60) + 7 + dfc$division_overwrite_words) DIV 8) * 8)
          + (dfc$esm_command_record_size + dfc$esm_header_record_size)) + dfc$esm_memory_base_shift-1)
          DIV dfc$esm_memory_base_shift) * dfc$esm_memory_base_shift;

    ELSE
      data_record_bytes := dfc$max_data_record_bytes;
      WHILE ((((((((data_record_bytes * 8) DIV 60) + 7 + dfc$division_overwrite_words) DIV 8) * 8) +
             (dfc$esm_command_record_size + dfc$esm_header_record_size)) + dfc$esm_memory_base_shift-1)
              DIV dfc$esm_memory_base_shift) * dfc$esm_memory_base_shift > division_space DO
        data_record_bytes := data_record_bytes DIV 2;
      WHILEND;
      IF data_record_bytes < dfc$min_data_record_bytes THEN
        data_record_bytes := dfc$min_data_record_bytes;
      IFEND;
      division_size := ((((((((data_record_bytes * 8) DIV 60) + 7 + dfc$division_overwrite_words) DIV 8) * 8)
          + (dfc$esm_command_record_size + dfc$esm_header_record_size)) + dfc$esm_memory_base_shift-1)
          DIV dfc$esm_memory_base_shift) * dfc$esm_memory_base_shift;
    IFEND;

    IF division_size > division_space THEN

      { Not enough ESM space for requested Data Transfer Size.

      total_required := (division_size * esm_specifications.esm_base_addresses.divisions_per_mainframe) *
            esm_specifications.esm_base_addresses.number_of_mainframes;
      osp$set_status_abnormal (dfc$file_server_id, dfe$stornet_memory_surpassed, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, total_required, 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            esm_specifications.esm_base_addresses.esm_memory_base * dfc$esm_memory_base_shift, 10, FALSE,
            status);
      osp$append_status_integer (osc$status_parameter_delimiter, esm_specifications.memory_size, 10, FALSE,
            status);
      RETURN;
    IFEND;

    esm_specifications.maximum_data_bytes := data_record_bytes;
    esm_specifications.esm_base_addresses.esm_division_size := division_size DIV dfc$esm_memory_base_shift;

    { Calculate number of channel words per ESM division for PP driver.

    esm_specifications.esm_base_addresses.esm_divsiz_12bit_cw :=
          ((division_size * 60) DIV 12) DIV dfc$esm_division_chwrds_shift;
    esm_specifications.esm_base_addresses.esm_divsiz_16bit_cw :=
          ((division_size * 60) DIV 16) DIV dfc$esm_division_chwrds_shift;

  PROCEND calculate_division_size;
?? OLDTITLE ??
?? NEWTITLE := 'crack_esm_parameters ', EJECT ??

{ PURPOSE:
{   This procedure cracks the command parameters.

  PROCEDURE crack_esm_parameters
    (    parameter_list: clt$parameter_list;
     VAR esm_parameters: dft$esm_specifications;
     VAR status: ost$status);

{ PROCEDURE define_stornet_connection, defsc (
{   element_name, en: name = $required
{   memory_size, ms: integer dfc$min_esm_memory_size .. dfc$max_esm_memory_size = 4194304
{   memory_base, mb: integer 0 .. dfc$max_esm_memory_base = 0
{   flag_base, fb: integer  0 ..16000 = 0
{   half_ecs_switch, hes: boolean = FALSE
{   number_of_mainframes, nom: integer 1 .. dfc$max_number_of_mainframes = 2
{   divisions_per_mainframe, dpm: integer 1 .. dfc$max_esm_divisions = 8
{   data_transfer_size, dts: key #16K, #32K, #65K, #131K, #262K keyend = #16K
{   side_door_port, side_door_ports, sdp: list 1 .. 2 of list 1 .. 3 of name
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 20] of clt$pdt_parameter_name,
      parameters: array [1 .. 10] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier_v2,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 9, 19, 8, 31, 3, 858],
    clc$command, 20, 10, 1, 0, 0, 0, 10, ''], [
    ['DATA_TRANSFER_SIZE             ',clc$nominal_entry, 8],
    ['DIVISIONS_PER_MAINFRAME        ',clc$nominal_entry, 7],
    ['DPM                            ',clc$abbreviation_entry, 7],
    ['DTS                            ',clc$abbreviation_entry, 8],
    ['ELEMENT_NAME                   ',clc$nominal_entry, 1],
    ['EN                             ',clc$abbreviation_entry, 1],
    ['FB                             ',clc$abbreviation_entry, 4],
    ['FLAG_BASE                      ',clc$nominal_entry, 4],
    ['HALF_ECS_SWITCH                ',clc$nominal_entry, 5],
    ['HES                            ',clc$abbreviation_entry, 5],
    ['MB                             ',clc$abbreviation_entry, 3],
    ['MEMORY_BASE                    ',clc$nominal_entry, 3],
    ['MEMORY_SIZE                    ',clc$nominal_entry, 2],
    ['MS                             ',clc$abbreviation_entry, 2],
    ['NOM                            ',clc$abbreviation_entry, 6],
    ['NUMBER_OF_MAINFRAMES           ',clc$nominal_entry, 6],
    ['SDP                            ',clc$abbreviation_entry, 9],
    ['SIDE_DOOR_PORT                 ',clc$nominal_entry, 9],
    ['SIDE_DOOR_PORTS                ',clc$alias_entry, 9],
    ['STATUS                         ',clc$nominal_entry, 10]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 6
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 7
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 8
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 9
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 37, clc$optional_parameter,
  0, 0],
{ PARAMETER 10
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [dfc$min_esm_memory_size, dfc$max_esm_memory_size, 10],
    '4194304'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, dfc$max_esm_memory_base, 10],
    '0'],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [0, 16000, 10],
    '0'],
{ PARAMETER 5
    [[1, 0, clc$boolean_type],
    'FALSE'],
{ PARAMETER 6
    [[1, 0, clc$integer_type], [1, dfc$max_number_of_mainframes, 10],
    '2'],
{ PARAMETER 7
    [[1, 0, clc$integer_type], [1, dfc$max_esm_divisions, 10],
    '8'],
{ PARAMETER 8
    [[1, 0, clc$keyword_type], [5], [
    ['#131K                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['#16K                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['#262K                          ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['#32K                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['#65K                           ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ,
    '#16K'],
{ PARAMETER 9
    [[1, 0, clc$list_type], [21, 1, 2, 0, FALSE, FALSE],
      [[1, 0, clc$list_type], [5, 1, 3, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 10
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element_name = 1,
      p$memory_size = 2,
      p$memory_base = 3,
      p$flag_base = 4,
      p$half_ecs_switch = 5,
      p$number_of_mainframes = 6,
      p$divisions_per_mainframe = 7,
      p$data_transfer_size = 8,
      p$side_door_port = 9,
      p$status = 10;

    VAR
      pvt: array [1 .. 10] of clt$parameter_value;

    VAR
      ignore_binary_id: pmt$binary_mainframe_id,
      index: 1 .. cmc$max_side_door_port_number,
      list_1_p: ^clt$data_value,
      list_2_p: ^clt$data_value,
      mainframe_name: pmt$mainframe_id,
      requested_data_bytes: 0 .. dfc$max_data_record_bytes;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Verify that the specified element is the ESM product.

    esm_parameters.element_name := pvt [p$element_name].value^.name_value;
    dfp$verify_element_name (esm_parameters.element_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    esm_parameters.memory_size := pvt [p$memory_size].value^.integer_value.value;
    IF (esm_parameters.memory_size DIV 1000(8)) * 1000(8) <> esm_parameters.memory_size THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_base_address, 'MEMORY_SIZE', status);
      RETURN;
    IFEND;

    esm_parameters.half_ecs_switch := pvt [p$half_ecs_switch].value^.boolean_value.value;
    IF esm_parameters.half_ecs_switch THEN
      esm_parameters.memory_size := esm_parameters.memory_size DIV 2;
    ELSE
      IF esm_parameters.memory_size > dfc$max_driver_formed_esm_adrs + 1 THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$driver_cannot_form_adrs, '', status);
        RETURN;
      IFEND;
    IFEND;

    esm_parameters.esm_base_addresses.esm_flag_base := pvt [p$flag_base].value^.integer_value.value;
    esm_parameters.esm_base_addresses.number_of_mainframes :=
          pvt [p$number_of_mainframes].value^.integer_value.value;
    esm_parameters.esm_base_addresses.divisions_per_mainframe :=
          pvt [p$divisions_per_mainframe].value^.integer_value.value;

    IF (pvt [p$memory_base].value^.integer_value.value DIV 1000(8)) * 1000(8) <>
          pvt [p$memory_base].value^.integer_value.value THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_base_address, 'MEMORY_BASE', status);
      RETURN;
    IFEND;
    esm_parameters.esm_base_addresses.esm_memory_base :=
          pvt [p$memory_base].value^.integer_value.value DIV dfc$esm_memory_base_shift;

    esm_parameters.maintenance_buffer_loc.length := dfc$esm_maintenance_buf_size;

    IF NOT pvt [p$data_transfer_size].specified THEN
      requested_data_bytes := 0;
    ELSE
      IF pvt [p$data_transfer_size].value^.keyword_value = '#16K' THEN
        requested_data_bytes := dfc$min_data_record_bytes;
      ELSEIF pvt [p$data_transfer_size].value^.keyword_value = '#32K' THEN
        requested_data_bytes := dfc$min_data_record_bytes * 2;
      ELSEIF pvt [p$data_transfer_size].value^.keyword_value = '#65K' THEN
        requested_data_bytes := dfc$min_data_record_bytes * 4;
      ELSEIF pvt [p$data_transfer_size].value^.keyword_value = '#131K' THEN
        requested_data_bytes := dfc$min_data_record_bytes * 8;
      ELSEIF pvt [p$data_transfer_size].value^.keyword_value = '#262K' THEN
        requested_data_bytes := dfc$min_data_record_bytes * 16;
      ELSE
        requested_data_bytes := 0;
      IFEND;
    IFEND;

    calculate_division_size (requested_data_bytes, esm_parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    esm_parameters.maintenance_buffer_loc.first_word_address :=
          ((esm_parameters.esm_base_addresses.number_of_mainframes *
          esm_parameters.esm_base_addresses.divisions_per_mainframe) *
          (esm_parameters.esm_base_addresses.esm_division_size * dfc$esm_memory_base_shift)) +
          (esm_parameters.esm_base_addresses.esm_memory_base * dfc$esm_memory_base_shift);

    { Side_door_ports is an optional parameter and is a list of lists.  Maximum number of side door ports that
    { may appear on the DEFINE_STORNET_CONNECTION command is cmc$max_side_door_port_number.  Within each
    { side_door_port specification is a list of three names: channel name, mainframe name and iou name. Only
    { channel name is required to define side_door_port. Iou name defaults to IOU0, and mainframe name
    { defaults to the mainframe_id of the machine on which the procedure executes.

    esm_parameters.side_door_ports.number := 0;
    IF pvt [p$side_door_port].specified THEN
      pmp$get_mainframe_id (mainframe_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      list_1_p := pvt [p$side_door_port].value;
      WHILE list_1_p <> NIL DO
        esm_parameters.side_door_ports.number := esm_parameters.side_door_ports.number + 1;
        index := esm_parameters.side_door_ports.number;
        list_2_p := list_1_p^.element_value;
        list_1_p := list_1_p^.link;

        { Get channel_name. This is the mandatory name for the side_door_port.

        esm_parameters.side_door_ports.ports [index].channel_name := list_2_p^.element_value^.name_value;
        list_2_p := list_2_p^.link;

        IF list_2_p = NIL THEN
          esm_parameters.side_door_ports.ports [index].mainframe_id := mainframe_name;
        ELSE
          esm_parameters.side_door_ports.ports [index].mainframe_id := list_2_p^.element_value^.name_value;
          pmp$convert_mainframe_to_binary (esm_parameters.side_door_ports.ports [index].mainframe_id,
                ignore_binary_id, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          list_2_p := list_2_p^.link;
        IFEND;

        IF list_2_p = NIL THEN
          esm_parameters.side_door_ports.ports [index].iou_name := dfc$iou_name0;
        ELSE
          IF (list_2_p^.element_value^.name_value <> dfc$iou_name0) AND
                (list_2_p^.element_value^.name_value <> dfc$iou_name1) THEN
            osp$set_status_abnormal (dfc$file_server_id, dfe$side_door_iou_name_err,
                  list_2_p^.element_value^.name_value, status);
            RETURN;
          IFEND;
          esm_parameters.side_door_ports.ports [index].iou_name := list_2_p^.element_value^.name_value;
        IFEND;

        verify_esm_configured (esm_parameters.element_name, esm_parameters.side_door_ports.ports [index],
              mainframe_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      WHILEND;
    IFEND;

  PROCEND crack_esm_parameters;
?? OLDTITLE ??
?? NEWTITLE := 'create_esm_def_table_entry ', EJECT ??

{ PURPOSE:
{   The purpose of this routine is to allocate esm_definition_table entry, to initialize it, and to link it
{   to the previous entry in the table.

  PROCEDURE create_esm_def_table_entry
    (    esm_parameters: dft$esm_specifications;
     VAR status: ost$status);

    VAR
      current_esm_table_entry_p: ^dft$esm_definition_table_entry,
      last_esm_table_entry_p: ^dft$esm_definition_table_entry,
      port_index: 1 .. cmc$max_side_door_port_number;

    status.normal := TRUE;

    { Make sure that this ESM is not allocated already.

    dfp$locate_esm_definition (esm_parameters.element_name, current_esm_table_entry_p);
    IF current_esm_table_entry_p <> NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$stornet_already_defined, esm_parameters.element_name,
           status);
      RETURN;
    IFEND;

    { Allocate new table entry.

    ALLOCATE current_esm_table_entry_p IN dfv$server_wired_heap^;
    IF current_esm_table_entry_p = NIL THEN
      osp$system_error ('NIL current_esm_table_entry_p.', NIL);
    IFEND;

    current_esm_table_entry_p^.element_name := esm_parameters.element_name;
    current_esm_table_entry_p^.memory_size := esm_parameters.memory_size;
    current_esm_table_entry_p^.half_ecs_switch := esm_parameters.half_ecs_switch;
    current_esm_table_entry_p^.esm_base_addresses := esm_parameters.esm_base_addresses;
    current_esm_table_entry_p^.maximum_data_bytes := esm_parameters.maximum_data_bytes;
    current_esm_table_entry_p^.maintenance_buffer_loc := esm_parameters.maintenance_buffer_loc;
    current_esm_table_entry_p^.number_of_pps_using_esm := 0;
    current_esm_table_entry_p^.p_element_reservation := NIL;
    current_esm_table_entry_p^.p_next_table_entry := NIL;

    { Move side_door_port information into table entry.

    FOR port_index := 1 to cmc$max_side_door_port_number DO
      current_esm_table_entry_p^.p_side_door_ports [port_index] := NIL;
    FOREND;
    IF esm_parameters.side_door_ports.number <> 0 THEN
      FOR port_index := 1 TO esm_parameters.side_door_ports.number DO
        ALLOCATE current_esm_table_entry_p^.p_side_door_ports [port_index] IN dfv$server_wired_heap^;
        IF current_esm_table_entry_p^.p_side_door_ports [port_index] = NIL THEN
          osp$system_error ('NIL p_side_door_ports.', NIL);
        IFEND;
        current_esm_table_entry_p^.p_side_door_ports [port_index]^ :=
              esm_parameters.side_door_ports.ports [port_index];
      FOREND;
    IFEND;

    { Link the new entry to the previous one.

    get_last_esm_definition (last_esm_table_entry_p);
    IF last_esm_table_entry_p <> NIL THEN
      last_esm_table_entry_p^.p_next_table_entry := current_esm_table_entry_p;
    ELSE
      dfv$p_esm_definition_table := current_esm_table_entry_p;
    IFEND;

  PROCEND create_esm_def_table_entry;
?? OLDTITLE ??
?? NEWTITLE := 'delete_esm_def_table_entry ', EJECT ??

{ PURPOSE:
{   The purpose of this routine is to find and delete the ESM table entry for the ESM element name specified
{   on input. The remaining entries are re-linked.

  PROCEDURE delete_esm_def_table_entry
    (    esm_name: cmt$element_name;
     VAR status: ost$status);

    VAR
      current_esm_table_entry_p: ^dft$esm_definition_table_entry,
      mainframe_count: 0 .. dfc$max_number_of_mainframes,
      previous_esm_table_entry_p: ^dft$esm_definition_table_entry;

    status.normal := TRUE;

    { Make sure that this ESM is defined.

    get_esm_definition_pointers (esm_name, current_esm_table_entry_p, previous_esm_table_entry_p);
    IF current_esm_table_entry_p = NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$stornet_not_defined, esm_name, status);
      RETURN;
    IFEND;

    { Make sure there are neither Clients nor Servers are defined with this ESM element.

    dfp$count_mainframes_per_esm (esm_name, mainframe_count);
    IF mainframe_count <> 0 THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$stornet_has_mainframes, esm_name, status);
      RETURN;
    IFEND;

    { Relink the ESM_Definition_Table entries.

    IF previous_esm_table_entry_p <> NIL THEN
      previous_esm_table_entry_p^.p_next_table_entry := current_esm_table_entry_p^.p_next_table_entry;
    ELSE
      dfv$p_esm_definition_table := current_esm_table_entry_p^.p_next_table_entry;
    IFEND;

    { De-allocate the old entry.

    FREE current_esm_table_entry_p IN dfv$server_wired_heap^;

  PROCEND delete_esm_def_table_entry;
?? OLDTITLE ??
?? NEWTITLE := 'get_esm_definition_pointers', EJECT ??

{ PURPOSE:
{   This procedures scans the ESM_DEFINITION_TABLE looking for a match on ESM element_name. If the element is
{   found in the table then CURRENT_ESM_TABLE_ENTRY_P contains the pointer to the matched table entry and the
{   PREVIOUS_ESM_TABLE_ENTRY_P contains the pointer to the previous entry. If current_esm_table_entry_p is not
{   NIL and the previous_esm_table_entry_p is NIL then the found entry is the first one in the list.  If the
{   element name is not found in the table then current_esm_table_entry_p is returned with NIL value and
{   previous_esm_table_entry_p points to the last entry in the table.

  PROCEDURE get_esm_definition_pointers
    (    esm_name: cmt$element_name;
     VAR current_esm_table_entry_p: ^dft$esm_definition_table_entry;
     VAR previous_esm_table_entry_p: ^dft$esm_definition_table_entry);

    current_esm_table_entry_p := NIL;
    previous_esm_table_entry_p := NIL;
    IF dfv$p_esm_definition_table <> NIL THEN
      current_esm_table_entry_p := dfv$p_esm_definition_table;
      REPEAT
        IF current_esm_table_entry_p^.element_name = esm_name THEN
          RETURN;
        IFEND;
        previous_esm_table_entry_p := current_esm_table_entry_p;
        current_esm_table_entry_p := current_esm_table_entry_p^.p_next_table_entry;
      UNTIL current_esm_table_entry_p = NIL;
    IFEND;

  PROCEND get_esm_definition_pointers;
?? OLDTITLE ??
?? NEWTITLE := 'get_last_esm_definition', EJECT ??

{ PURPOSE:
{   This procedures scans the ESM_DEFINITION_TABLE entries examining the pointers to the next table entry. The
{   NIL pointer indicates the last valid entry. The pointer to the last valid entry is returned to the caller.
{   If no entry has been allocated the returned pointer is NIL.

  PROCEDURE get_last_esm_definition
    (VAR last_esm_table_entry_p: ^dft$esm_definition_table_entry);

    VAR
      current_esm_table_entry_p: ^dft$esm_definition_table_entry;

    last_esm_table_entry_p := NIL;
    IF dfv$p_esm_definition_table <> NIL THEN
      current_esm_table_entry_p := dfv$p_esm_definition_table;
      REPEAT
        last_esm_table_entry_p := current_esm_table_entry_p;
        current_esm_table_entry_p := current_esm_table_entry_p^.p_next_table_entry;
      UNTIL current_esm_table_entry_p = NIL;
    IFEND;

  PROCEND get_last_esm_definition;
?? OLDTITLE ??
?? NEWTITLE := 'verify_esm_configured ', EJECT ??

{ PURPOSE:
{   This procedure verifies that the specified element with the namedchannel is an ESM device, configured on
{   this mainframe.

  PROCEDURE verify_esm_configured
    (    esm_element_name: cmt$element_name;
         channel_name: dft$channel_definition;
         mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      channel_address: cmt$physical_equipment_number,
      channel_definition: cmt$data_channel_definition,
      channel_descriptor: cmt$channel_descriptor,
      element_definition: cmt$element_definition,
      element_descriptor: cmt$element_descriptor,
      element_found: boolean,
      port_number: cmt$communications_port_number;

    status.normal := TRUE;

    element_descriptor.element_type := cmc$communications_element;
    element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
    element_descriptor.peripheral_descriptor.element_name := esm_element_name;

    { Get the channel/mainframe_id array for the element.

    cmp$get_element_definition (element_descriptor, element_definition, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Verify that the specified element is the ESM product.

    dfp$verify_esm_product_id (element_definition.product_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    element_found := FALSE;
  /verify_mainframe_iou_names/
    FOR port_number := LOWERVALUE (cmt$communications_port_number)
          TO UPPERVALUE (cmt$communications_port_number) DO
      IF element_definition.communications_element.connection.port [port_number].configured THEN
        IF ((channel_name.mainframe_id = element_definition.communications_element.
                connection.port [port_number].mainframe_ownership) AND
            (channel_name.iou_name = element_definition.communications_element.
                connection.port [port_number].iou) AND
            (channel_name.channel_name = element_definition.communications_element.
                connection.port [port_number].element_name)) THEN
          element_found := TRUE;

          IF element_definition.communications_element.connection.port[port_number]
             .mainframe_ownership = mainframe_name THEN

            { Make sure that the channel definition is around.

            channel_descriptor.use_logical_identification := TRUE;
            channel_descriptor.iou := channel_name.iou_name;
            channel_descriptor.name := channel_name.channel_name;
            cmp$get_channel_definition (channel_descriptor, channel_definition, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
          EXIT /verify_mainframe_iou_names/;
        IFEND;
      IFEND;
    FOREND /verify_mainframe_iou_names/;

    IF NOT element_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$no_configured_channel, channel_name.channel_name,
            status);
      RETURN;
    IFEND;

  PROCEND verify_esm_configured;
?? OLDTITLE ??
MODEND dfm$esm_definition_manager;
*DECK DECK=DFM$FAMILY_CLIENT_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: Server: Family Client Access Manager', EJECT ??
MODULE dfm$family_client_manager;

{ PURPOSE:
{   The purpose of this module is to provide procedures for the
{   creation, display, and maintenance of client family accesses.
{
{ DESIGN:
{   Each family on the server mainframe can be assigned a particular
{   "family access" for one or more client mainframes. The family access
{   determines how a user on the client mainframe may access the family.
{   At installation deadstart time all families allow no access from any
{   client. The CHANGE_CLIENT_ACCESS (implemented in this module) allows the
{   site personnel on the server mainframes to specify how the client users
{   may access server files.
{
{   Access designations start as catalog permits and are also placed in the
{   set/family table.  At recovery deadstart time, the catlog permits are
{   used to re-generate the access information in the set/family table.
{   Manipulations of the set/family are performed by procedures in Ring 1.
{
{   The catalog permits for the access designations of a family consist of
{   "family" groups with the "family_name" being the name of the client
{   mainframe prefixed with the 3 characters "DF$".  Application_information
{   is used to store the family access allowed.
{
{   On the change_client_access command and in the application_information
{   of the catalog permit the family_access is a single name.
{   In the served family table, and family table this single 'access' is
{   stored as a set of family_access_kinds under the following rules.
{   Login implies login and file access.
{   Leveled_access implies login and file access.
{
{ NOTES:
{   1. The order of procedures in this deck is
{       .XDCL procedures.
{       .Local procedures
{      Procedures are arranged alphabetically within each group.

?? TITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc cle$all_must_be_used_alone
*copyc dfe$error_condition_codes
*copyc dft$family_access
*copyc dft$family_list
*copyc dft$served_family_table_index
*copyc jmc$system_family
*copyc ost$family_table
*copyc pfd$catalog
*copyc pfd$complete_path
?? POP ??
*copyc amp$put_next
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$scan_argument_list
*copyc clp$scan_parameter_list
*copyc dfp$crack_mainframe_id
*copyc dfp$find_mainframe_id
*copyc dfp$get_partner_mainframes
*copyc dfi$display
*copyc dfi$fsp_open_close
*copyc dfp$verify_system_administrator
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$clear_mainframe_sig_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$get_accessed_families
*copyc osp$get_accessed_clients
*copyc osp$get_client_family_access
*copyc osp$get_families_for_client
*copyc osp$set_client_access
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$verify_system_privilege
*copyc pfp$find_direct_info_record
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$find_permit_array
*copyc pfp$get_item_info
*copyc pfp$permit_catalog
*copyc pfp$validate_local_family
*copyc pmp$convert_binary_mainframe_id
*copyc pmp$convert_mainframe_to_binary
*copyc amv$nil_file_identifier
*copyc dfv$number_served_family_lists
*copyc osv$family_table
*copyc osv$system_family_name
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??
  {Constants used for translating family access to legible and vice-versa

  CONST
    access_value_size_in_app_info = 7,
    legible_for_remote_file_access = 'FILE   ',
    legible_for_remote_login_access = 'LOGIN  ',
    legible_for_job_leveling_access = 'LEVELED';


?? TITLE := '     [XDCL, #GATE] dfp$change_client_access', EJECT ??

{ PURPOSE:
{   The purpose of this request is to change the family access allowed to
{   specified clients. This command can be issued only by the system       .
{   administrator.
{
{ NOTES:
{
{   1.This command is disallowed if any family-client combination exists
{     such that the access of the family before this command is not NONE
{     and the state of the client is active, inactive or deactivated. That
{     is, no family known to a client can have its access changed unless
{     the client is terminated.
{
{   2.For each client in an active state, the list of new families (access
{     changed from NONE) will be transmitted to the client.  This is done
{     by the server notifying the client that new families exist and the
{     client sending a verify_family request poll as though the operator
{     had typed a DEFINE_SERVED_FAMILY command.

  PROCEDURE [XDCL, #GATE] dfp$change_client_access_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt change_client_access_pdt (
{ client_mainframe_identifier, client_mainframe_identifiers, cmi: ..
{         list 1 .. dfc$maximum_partner_mainframes of name ..
{         pmc$mainframe_id_size or key all = $required
{ family, families, f: list 1 .. dfc$max_family_parameters of name = $required
{ family_access, fa: key file_access, fa, login, l, leveled_access, ..
{         la, none = $required
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      change_client_access_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^change_client_access_pdt_names, ^change_client_access_pdt_params];

    VAR
      change_client_access_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 9] of
            clt$parameter_name_descriptor := [['CLIENT_MAINFRAME_IDENTIFIER', 1],
            ['CLIENT_MAINFRAME_IDENTIFIERS', 1], ['CMI', 1], ['FAMILY', 2], ['FAMILIES', 2], ['F', 2],
            ['FAMILY_ACCESS', 3], ['FA', 3], ['STATUS', 4]];

    VAR
      change_client_access_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
            clt$parameter_descriptor := [

{ CLIENT_MAINFRAME_IDENTIFIER CLIENT_MAINFRAME_IDENTIFIERS CMI }
      [[clc$required], 1, dfc$maximum_partner_mainframes, 1, 1, clc$value_range_not_allowed,
            [^change_client_access_pdt_kv1, clc$name_value, pmc$mainframe_id_size, pmc$mainframe_id_size]],

{ FAMILY FAMILIES F }
      [[clc$required], 1, dfc$max_family_parameters, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$name_value, 1, osc$max_name_size]],

{ FAMILY_ACCESS FA }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed,
            [^change_client_access_pdt_kv3, clc$keyword_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      change_client_access_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            ost$name := ['ALL'];

    VAR
      change_client_access_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
            ost$name := ['FILE_ACCESS', 'FA', 'LOGIN', 'L', 'LEVELED_ACCESS', 'LA', 'NONE'];

?? POP ??

    VAR
      all_clients: boolean,
      application_info: pft$application_info,
      client_index: 0 .. clc$max_value_sets,
      family: ost$family_name,
      family_access: dft$family_access,
      family_index: 0 .. clc$max_value_sets,
      found: boolean,
      group: pft$group,
      mainframe_found: boolean,
      number_of_clients: 0 .. dfc$maximum_partner_mainframes,
      number_of_clients_input: 0 .. clc$max_value_sets,
      number_of_families: 0 .. dfc$max_family_ptr_array_size,
      number_of_families_input: 0 .. clc$max_value_sets,
      path: array [1 .. 2] of pft$name,
      permit_selections: pft$permit_selections,
      p_binary_client_list: ^array [1 .. * ] of pmt$binary_mainframe_id,
      p_client_list: ^array [1 .. * ] of pmt$mainframe_id,
      p_family_list: ^array [1 .. * ] of ost$family_name,
      set_table_family_access: dft$family_access,
      share_requirements: pft$share_requirements,
      value: clt$value;

    status.normal := TRUE;

    dfp$verify_system_administrator ('CHANGE_CLIENT_ACCESS', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{
{   Process the input parameters.
{

    clp$scan_parameter_list (parameter_list, change_client_access_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('CLIENT_MAINFRAME_IDENTIFIER', number_of_clients_input, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    number_of_clients := number_of_clients_input;

    PUSH p_binary_client_list: [1 .. number_of_clients];
    PUSH p_client_list: [1 .. number_of_clients];
    crack_clients (number_of_clients, p_client_list, p_binary_client_list, all_clients, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('FAMILY', number_of_families_input, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    number_of_families := number_of_families_input;

    PUSH p_family_list: [1 .. number_of_families];

    crack_families (number_of_families, number_of_clients, p_client_list, all_clients, p_family_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_family_access (family_access, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{
{   Input parameters have been cracked and checked.
{   Generate the permanent file permits for each family. The type of permit
{   is "family" and the "family name" is the client mainframe name prefixed
{   with "DF$".
{

    path [2] := jmc$system_user;

    group.group_type := pfc$family;

    permit_selections := $pft$permit_selections [];
    share_requirements := -$pft$share_requirements [];

    build_a_i_from_family_access (family_access, application_info);

    FOR family_index := 1 TO number_of_families DO
      family := p_family_list^ [family_index];
      path [1] := family;

      IF all_clients THEN
        group.family_description.family (1, * ) := 'DF$ALL';
        pfp$permit_catalog (path, group, permit_selections, share_requirements, application_info, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        FOR client_index := 1 TO number_of_clients DO
          group.family_description.family (1, * ) := 'DF$';
          group.family_description.family (4, * ) := p_client_list^ [client_index];
          pfp$permit_catalog (path, group, permit_selections, share_requirements, application_info, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
      IFEND;

{
{     Generate the family/set table entries
{

      osp$set_client_access (family, family_access, all_clients, p_binary_client_list, number_of_clients,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

{
{   Set flags to inform clients that new families exist.
{

    set_verify_family (all_clients, p_client_list, status);

  PROCEND dfp$change_client_access_cmnd;

?? TITLE := '  [XDCL, #GATE] dfp$display_client_access_cmnd', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display the family accesses for the
{   specified client mainframe(s). This command can be issued only by the
{   system administrator.
{

  PROCEDURE [XDCL, #GATE] dfp$display_client_access_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  pdt display_client_pdt (
{   client_mainframe_identifier, client_mainframe_identifiers, cmi, ..
{         mainframe_identifier, mi: ..
{         list 1 .. dfc$maximum_partner_mainframes of name ..
{         pmc$mainframe_id_size or key all = $required
{    output, o: file = $OUTPUT
{    status)

?? PUSH (LISTEXT := ON) ??

  VAR
    display_client_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^display_client_pdt_names,
  ^display_client_pdt_params];

  VAR
    display_client_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 8] of
  clt$parameter_name_descriptor := [['CLIENT_MAINFRAME_IDENTIFIER', 1], ['CLIENT_MAINFRAME_IDENTIFIERS', 1], [
  'CMI', 1], ['MAINFRAME_IDENTIFIER', 1], ['MI', 1], ['OUTPUT', 2], ['O', 2], ['STATUS', 3]];

  VAR
    display_client_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor
  := [

{ CLIENT_MAINFRAME_IDENTIFIER CLIENT_MAINFRAME_IDENTIFIERS CMI MAINFRAME_IDENTIFIER MI }
    [[clc$required], 1, dfc$maximum_partner_mainframes, 1, 1, clc$value_range_not_allowed, [^
  display_client_pdt_kv1, clc$name_value, pmc$mainframe_id_size, pmc$mainframe_id_size]],

{ OUTPUT O }
    [[clc$optional_with_default, ^display_client_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    display_client_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['ALL'];

  VAR
    display_client_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??
?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

       clean_up;

    PROCEND abort_handler;
?? TITLE := 'clean_up', EJECT ??

    PROCEDURE clean_up;

      VAR
        ignore_status: ost$status;

      IF output_fid <> amv$nil_file_identifier THEN
        dfp$fsp_close (output_fid, seqp, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    VAR
      access_list: array [1 .. dfc$max_family_ptr_array_size] of dft$family_access,
      all_clients: boolean,
      application_info: pft$application_info,
      client_binary_id: pmt$binary_mainframe_id,
      client_count: 0 .. dfc$maximum_partner_mainframes,
      client_index: 1 .. dfc$maximum_partner_mainframes,
      family_count: 0 .. dfc$max_family_ptr_array_size,
      family_list: array [1 .. dfc$max_family_ptr_array_size] of ost$family_name,
      header_written: boolean,
      ignore_byte_address: amt$file_byte_address,
      ignore_eoi: amt$file_byte_address,
      index: 1 .. dfc$max_family_ptr_array_size,
      local_status: ost$status,
      line: string (100),
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id,
      number_of_clients_input: 0 .. clc$max_value_sets,
      output_fid: amt$file_identifier,
      output_file_name: amt$local_file_name,
      p_binary_client_list: ^array [1 .. dfc$maximum_partner_mainframes] of pmt$binary_mainframe_id,
      p_client_names: ^array [1 .. *] of pmt$mainframe_id,
      search_completed: boolean,
      seqp: ^SEQ ( * ),
      size: integer,
      value: clt$value;

    dfp$verify_system_administrator ('DISPLAY_CLIENT_ACCESS', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, display_client_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('CLIENT_MAINFRAME_IDENTIFIER', number_of_clients_input, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    client_count := number_of_clients_input;
    all_clients := FALSE;

    IF number_of_clients_input = 1 THEN
      clp$get_value ('CLIENT_MAINFRAME_IDENTIFIER', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.name.value = 'ALL' THEN
        all_clients := TRUE;
        PUSH p_binary_client_list;
        osp$get_accessed_clients (p_binary_client_list, client_count);
      IFEND;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output_file_name := value.file.local_file_name;

    output_fid := amv$nil_file_identifier;
    osp$establish_block_exit_hndlr (^abort_handler);

    dfp$fsp_open (output_file_name, amc$record, {read_not_write} FALSE,
          {open_for_attach} FALSE, {seq_and_read_behind} FALSE,
          'DISPLAY_CLIENT_ACCESS', output_fid, seqp, ignore_eoi, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    header_written := FALSE;
 /process_clients/
    FOR client_index := 1 TO client_count DO
      IF all_clients THEN
        client_binary_id := p_binary_client_list^ [client_index];
        pmp$convert_binary_mainframe_id (client_binary_id, mainframe_name, status);
        IF NOT status.normal THEN
          EXIT /process_clients/;
        IFEND;
      ELSE
        clp$get_value ('CLIENT_MAINFRAME_IDENTIFIER',  client_index, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /process_clients/;
        IFEND;
        mainframe_name := value.name.value;
        IF mainframe_name = 'ALL' THEN
          osp$set_status_abnormal ('CL', cle$all_must_be_used_alone, 'CLIENT_MAINFRAME_IDENTIFIER',
                status);
          EXIT /process_clients/;
        IFEND;
        pmp$convert_mainframe_to_binary (mainframe_name, client_binary_id, status);
        IF NOT status.normal THEN
          EXIT /process_clients/;
        IFEND;
      IFEND;
      IF NOT header_written THEN
        header_written := TRUE;
        line := '  MAINFRAME             FAMILY';
        line (59, 6) := 'ACCESS';
        amp$put_next (output_fid, ^line, 65, ignore_byte_address, status);
        IF NOT status.normal THEN
          EXIT /process_clients/;
        IFEND;
      IFEND;

      amp$put_next (output_fid, ^line, 1, ignore_byte_address, status);
      IF NOT status.normal THEN
        EXIT /process_clients/;
      IFEND;

      osp$get_families_for_client (client_binary_id, ^family_list, ^access_list, family_count);

      FOR index := 1 TO family_count DO
        IF access_list [index] = $dft$family_access [] THEN
          application_info := 'NONE';
        ELSE
          build_a_i_from_family_access (access_list [index], application_info);
        IFEND;
        STRINGREP (line, size, '  ', mainframe_name, '     ', family_list[index], '   ',
              application_info (1, access_value_size_in_app_info));
        amp$put_next (output_fid, ^line, size, ignore_byte_address, status);
        IF NOT status.normal THEN
          EXIT /process_clients/;
        IFEND;
      FOREND;

      IF family_count = 0 THEN
        STRINGREP (line, size , '    No served families can be accessed by client mainframe ',
              mainframe_name);
        amp$put_next (output_fid, ^line, size, ignore_byte_address, status);
        IF NOT status.normal THEN
          EXIT /process_clients/;
        IFEND;
      IFEND;

    FOREND /process_clients/;

    IF client_count = 0 THEN
      line := '   (No served families can be accessed by any client.)';
      amp$put_next (output_fid, ^line, 70, ignore_byte_address, status);
    IFEND;

    dfp$fsp_close (output_fid, seqp, local_status);
    IF status.normal THEN
      status := local_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND dfp$display_client_access_cmnd;

?? TITLE := '  [XDCL] dfp$rebuild_set_table_clients', EJECT ??
*copy dfh$rebuild_set_table_clients

  PROCEDURE [XDCL] dfp$rebuild_set_table_clients
    (    family: ost$family_name;
     VAR status: ost$status);

    VAR
      binary_client_list: array [1 .. 1] of pmt$binary_mainframe_id,
      catalog_info_selections: pft$catalog_info_selections,
      family_access: dft$family_access,
      group: pft$group,
      info_segment_pointer: amt$segment_pointer,
      local_status: ost$status,
      mainframe_id: pmt$mainframe_id,
      number_of_clients: integer,
      path: array [1 .. 2] of pft$name,
      permit_index: pft$array_index,
      p_directory_array: pft$p_directory_array,
      p_info_record: pft$p_info_record,
      p_info: pft$p_info,
      p_permit_array: pft$p_permit_array;

    status.normal := TRUE;
    osp$verify_system_privilege;
    catalog_info_selections := $pft$catalog_info_selections
          [pfc$catalog_directory, pfc$catalog_permits, pfc$indirect_catalog_permits];

    path [1] := family;
    path [2] := jmc$system_user;

  /main/
    BEGIN

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, info_segment_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      p_info := info_segment_pointer.sequence_pointer;
      RESET p_info;

      group.group_type := pfc$member;
      group.member_description.family := osc$null_name;
      group.member_description.account := osc$null_name;
      group.member_description.project := osc$null_name;
      group.member_description.user := osc$null_name;

      pfp$get_item_info (path, group, catalog_info_selections, $pft$file_info_selections [], p_info, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      RESET p_info;

      pfp$find_next_info_record (p_info, p_info_record, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      pfp$find_directory_array (p_info_record, p_directory_array, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF p_directory_array = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_master_catalog, family, status);
        EXIT /main/;
      IFEND;

      pfp$find_direct_info_record (^p_info_record^.body, p_directory_array^ [1].info_offset, p_info_record,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      pfp$find_permit_array (p_info_record, p_permit_array, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF p_permit_array = NIL THEN
        EXIT /main/;
      IFEND;

{     Since osp$set_client_access sets all known clients to the access specifed,
{     ALL is processed first here in order to prevent resetting values which
{     may have been set after the "change_client_access all .." command had
{     been issued.

    /do_df$all_first/
      FOR permit_index := LOWERBOUND (p_permit_array^) TO UPPERBOUND (p_permit_array^) DO
        IF p_permit_array^ [permit_index].group.group_type = pfc$family THEN
          IF p_permit_array^ [permit_index].group.family_description.family = 'DF$ALL ' THEN
            get_family_access_from_a_i (p_permit_array^ [permit_index].application_info, family_access);
            osp$set_client_access (family, family_access, {all_mainframes =}
                  TRUE, ^binary_client_list, 1, status);
            IF NOT status.normal THEN
              EXIT /main/;
            IFEND;
            EXIT /do_df$all_first/;
          IFEND
        IFEND;
      FOREND /do_df$all_first/;

    /do_each_client/
      FOR permit_index := LOWERBOUND (p_permit_array^) TO UPPERBOUND (p_permit_array^) DO
        IF p_permit_array^ [permit_index].group.group_type = pfc$family THEN
          IF p_permit_array^ [permit_index].group.family_description.family = 'DF$ALL ' THEN
            CYCLE /do_each_client/;
          IFEND;
          IF p_permit_array^ [permit_index].group.family_description.family(1, 3) <> 'DF$' THEN
            CYCLE /do_each_client/;
          IFEND;
          mainframe_id := p_permit_array^ [permit_index].group.family_description.
                family (4, pmc$mainframe_id_size);
          pmp$convert_mainframe_to_binary (mainframe_id, binary_client_list [1], status);
          IF NOT status.normal THEN
            EXIT /main/;
          IFEND;
          get_family_access_from_a_i (p_permit_array^ [permit_index].application_info, family_access);
          osp$set_client_access (family, family_access, {all_mainframes =}
                FALSE, ^binary_client_list, 1, status);
          IF NOT status.normal THEN
            EXIT /main/;
          IFEND;

        IFEND;
      FOREND /do_each_client/;


    END /main/;

    IF info_segment_pointer.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (info_segment_pointer, local_status);
      info_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

  PROCEND dfp$rebuild_set_table_clients;

?? TITLE := ' [XDCL, #GATE] dfp$$client_family_access', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to implement the command language
{   function $client_family_access.
{

  PROCEDURE [XDCL, #GATE] dfp$$client_family_access
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      client_adt: [STATIC, READ, cls$adt] array [1 .. 2] of clt$argument_descriptor :=
            [[[clc$required], [NIL, clc$name_value, 1, osc$max_name_size]],
            [[clc$required], [NIL, clc$name_value, 1, osc$max_name_size]]];

    VAR
      access_string: pft$application_info,
      avt: array [1 .. 2] of clt$value,
      client_binary_id: pmt$binary_mainframe_id,
      client_mainframe_name: pmt$mainframe_id,
      family_access: dft$family_access,
      family_name: ost$family_name;

    clp$scan_argument_list (function_name, argument_list, ^client_adt, ^avt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    client_mainframe_name := avt [1].name.value;
    pmp$convert_mainframe_to_binary (client_mainframe_name, client_binary_id, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$improper_mainframe_id, client_mainframe_name, status);
      RETURN;
    IFEND;
    IF status.normal AND (client_binary_id.model_number = osc$cyber_180_model_unknown) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$unknown_model_number,
            client_mainframe_name (9, pmc$processor_model_number_size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, client_mainframe_name, status);
      RETURN;
    IFEND;

    family_name := avt [2].name.value;
    osp$get_client_family_access (client_binary_id, family_name, family_access);

    value.descriptor := 'STRING';
    value.kind := clc$string_value;

    value.str.size := access_value_size_in_app_info;
    IF family_access = $dft$family_access [] THEN
      value.str.value := 'NONE';
    ELSE
      build_a_i_from_family_access (family_access, access_string);
      value.str.value := access_string;
    IFEND;

  PROCEND dfp$$client_family_access;
?? TITLE := ' build_a_i_from_family_access', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to build the application information
{   (actually a string) from the given specified family access.
{
{ NOTES:
{   1.Although family_access is a set the application_information is only
{     stored as one value (see the CHANGE_CLIENT_ACCESS command).
{

  PROCEDURE build_a_i_from_family_access
    (    family_access: dft$family_access;
     VAR application_info: pft$application_info);

    application_info := ' ';
    IF dfc$job_leveling_access IN family_access THEN
      application_info (1, access_value_size_in_app_info) := legible_for_job_leveling_access;
    ELSEIF dfc$remote_login_access IN family_access THEN
      application_info (1, access_value_size_in_app_info) := legible_for_remote_login_access;
    ELSEIF dfc$remote_file_access IN family_access THEN
      application_info (1, access_value_size_in_app_info) := legible_for_remote_file_access;
    IFEND;

  PROCEND build_a_i_from_family_access;

?? TITLE := ' crack_clients', EJECT ??

{ PURPOSE:
{   The purpose of this request is to crack and validate the
{   client_mainframe_identifier parameter of the change_client_access command.
{
{ NOTES:
{
{   1.This procedure ensures that the total number of client mainframes
{     known to this server does not exceed the maximum.  This requires
{     obtaining the list of all the currently known clients and checking
{     this list for each client specified. If a specified client is not in
{     the list, it will be added (locally) provided that the maximum is not
{     reached.

  PROCEDURE crack_clients
    (    number_of_clients: 1 .. dfc$maximum_partner_mainframes;
         p_client_list {output} : ^array [1 .. * ] of pmt$mainframe_id;
         p_binary_client_list {output} : ^array [1 .. * ] of pmt$binary_mainframe_id;
     VAR all_clients: boolean;
     VAR status: ost$status);

    VAR
      all_clients_array: array [1 .. dfc$maximum_partner_mainframes] of dft$partner_mainframe_entry,
      client_index: 0 .. clc$max_value_sets,
      found: boolean,
      i_client: 0 .. dfc$maximum_partner_mainframes,
      mainframe_name: pmt$mainframe_id,
      p_all_clients_array: ^dft$partner_mainframe_list,
      total_number_of_clients: 0 .. dfc$maximum_partner_mainframes,
      value: clt$value;

    status.normal := TRUE;
    all_clients := FALSE;

    IF number_of_clients = 1 THEN
      clp$get_value ('CLIENT_MAINFRAME_IDENTIFIER', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.name.value = 'ALL ' THEN
        all_clients := TRUE;
        RETURN;
      IFEND;
    IFEND;

    p_all_clients_array := ^all_clients_array;
    dfp$get_partner_mainframes (FALSE, p_all_clients_array, total_number_of_clients);

  /get_clients/
    FOR client_index := 1 TO number_of_clients DO
      clp$get_value ('CLIENT_MAINFRAME_IDENTIFIER', client_index, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      mainframe_name := value.name.value;
      IF mainframe_name = 'ALL' THEN
        osp$set_status_abnormal ('CL', cle$all_must_be_used_alone, 'CLIENT_MAINFRAME_IDENTIFIER', status);
        RETURN;
      IFEND;
      p_client_list^ [client_index] := mainframe_name;
      pmp$convert_mainframe_to_binary (mainframe_name, p_binary_client_list^ [client_index], status);
      IF (NOT status.normal) OR (status.normal AND (p_binary_client_list^ [client_index].model_number =
            osc$cyber_180_model_unknown)) THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$improper_mainframe_id, value.name.value, status);
        RETURN;
      IFEND;

      found := FALSE;

    /search_all_clients/
      FOR i_client := 1 TO total_number_of_clients DO
        IF all_clients_array [i_client].mainframe_id = p_binary_client_list^ [client_index] THEN
          found := TRUE;
          EXIT /search_all_clients/;
        IFEND;
      FOREND /search_all_clients/;

      IF NOT found THEN
        IF total_number_of_clients >= dfc$maximum_partner_mainframes THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$max_families_or_clients, 'clients', status);
          osp$append_status_integer (osc$status_parameter_delimiter, dfc$maximum_partner_mainframes, 10,
                FALSE, status);
          RETURN;
        IFEND;
        total_number_of_clients := total_number_of_clients + 1;
        all_clients_array [total_number_of_clients].mainframe_id := p_binary_client_list^ [client_index];
      IFEND;

    FOREND /get_clients/;

  PROCEND crack_clients;

?? TITLE := ' crack_families', EJECT ??

{ PURPOSE:
{   The purpose of this request is to crack and validate the
{   family parameter of the change_client_access command.
{
{ NOTES:
{
{   1.This procedure ensures that the total number accessible families
{     known to this server does not exceed the maximum.  This requires
{     obtaining the list of all the currently known families and checking
{     this list for each family specified. If a specified family is not in
{     the list, it will be added (locally) provided that the maximum is not
{     reached.
{
{   2.Since it is not permitted to change the access of a family which is
{     already accessible to an active client, checks must be made for
{     each family concerning possible current accesses by active clients.
{

  PROCEDURE crack_families
    (    number_of_families: 0 .. dfc$max_family_ptr_array_size;
         number_of_clients: 0 .. dfc$maximum_partner_mainframes;
         p_client_list: ^array [1 .. * ] of pmt$mainframe_id;
         all_clients: boolean;
         p_family_list: ^array [1 .. * ] of ost$family_name;
     VAR status: ost$status);

    VAR
      accessed_client_index: 1 .. dfc$maximum_partner_mainframes,
      all_families_array: array [1 .. dfc$max_family_ptr_array_size] of ost$family_name,
      client_access_array: array [1 .. dfc$maximum_partner_mainframes] of dft$family_access,
      client_index: 0 .. dfc$maximum_partner_mainframes,
      client_specified_on_command: boolean,
      clients_with_access_array: array [1 .. dfc$maximum_partner_mainframes] of pmt$mainframe_id,
      family: ost$family_name,
      family_index: 0 .. clc$max_value_sets,
      found: boolean,
      ignore_p_q_interf_direc: ^dft$q_interface_directory_entry,
      ignore_p_q_interf_table: dft$p_queue_interface_table,
      ignore_queue_index: dft$queue_index,
      i_family: 1 .. dfc$max_family_ptr_array_size,
      mainframe_found: boolean,
      mainframe_name: pmt$mainframe_id,
      max_families: 0 .. dfc$max_family_ptr_array_size,
      number_of_clients_with_access: 0 .. dfc$maximum_partner_mainframes,
      p_cpu_queue: ^dft$cpu_queue,
      server_state: dft$server_state,
      total_number_of_families: 0 .. dfc$max_family_ptr_array_size,
      value: clt$value;

    status.normal := TRUE;
    max_families := dfc$served_family_list_size * dfv$number_served_family_lists;
    osp$get_accessed_families (^all_families_array, total_number_of_families);

  /process_family_input/
    FOR family_index := 1 TO number_of_families DO
      clp$get_value ('FAMILY', family_index, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      family := value.name.value;
      IF family = osv$system_family_name THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$system_family_not_allowed, family, status);
        RETURN;
      IFEND;

      pfp$validate_local_family (family, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      found := FALSE;

{
{     Ensure that the number of accessible families on this server does no
{     exceed the maximum.
{

    /search_all_families/
      FOR i_family := 1 TO total_number_of_families DO
        IF all_families_array [i_family] = family THEN
          found := TRUE;
          EXIT /search_all_families/;
        IFEND;
      FOREND /search_all_families/;

      IF NOT found THEN
        IF total_number_of_families >= max_families THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$max_families_or_clients, 'families', status);
          osp$append_status_integer (osc$status_parameter_delimiter, max_families, 10, FALSE, status);
          RETURN;
        IFEND;
        total_number_of_families := total_number_of_families + 1;
        all_families_array [total_number_of_families] := family;
      IFEND;
      p_family_list^ [family_index] := family;

{
{     Verify that the family is not currently accessible by an active (or
{     semi_active) client.
{

      find_clients_for_family (family, ^clients_with_access_array, ^client_access_array,
            number_of_clients_with_access, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    /check_clients_with_access/
      FOR accessed_client_index := 1 TO number_of_clients_with_access DO
        mainframe_name := clients_with_access_array [accessed_client_index];
        IF mainframe_name = 'ALL' THEN
          CYCLE /check_clients_with_access/;
        IFEND;
        IF client_access_array [accessed_client_index] = $dft$family_access [] THEN
          CYCLE /check_clients_with_access/;
        IFEND;

        client_specified_on_command := FALSE;
        IF all_clients THEN
          client_specified_on_command := TRUE;
        ELSE

        /search_client_input/
          FOR client_index := 1 TO number_of_clients DO
            IF mainframe_name = p_client_list^ [client_index] THEN
              client_specified_on_command := TRUE;
              EXIT /search_client_input/
            IFEND;
          FOREND /search_client_input/;
        IFEND;

        IF client_specified_on_command THEN
          dfp$find_mainframe_id (mainframe_name, {host_is_server=} TRUE, mainframe_found,
                ignore_p_q_interf_table, p_cpu_queue, ignore_queue_index, ignore_p_q_interf_direc);
          IF mainframe_found THEN
            server_state := p_cpu_queue^.queue_header.partner_status.server_state;
            IF (server_state = dfc$active) OR (server_state = dfc$deactivated) OR
                  (((server_state = dfc$terminated) OR (server_state = dfc$inactive)
                  OR (server_state = dfc$awaiting_recovery)) AND
                  p_cpu_queue^.queue_header.partner_status.verify_queue) THEN
              osp$set_status_abnormal (dfc$file_server_id, dfe$client_too_active_for_chaca, mainframe_name,
                    status);
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      FOREND /check_clients_with_access/;
    FOREND /process_family_input/;

  PROCEND crack_families;

?? TITLE := ' crack_family_access ', EJECT ??

  PROCEDURE crack_family_access
    (VAR family_access: dft$family_access;
     VAR status: ost$status);

    VAR
      value: clt$value;

    status.normal := TRUE;
    family_access := $dft$family_access [];
    clp$get_value ('FAMILY_ACCESS', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.name.value (1) = 'A' THEN
      family_access := $dft$family_access [dfc$remote_file_access, dfc$remote_login_access,
            dfc$job_leveling_access];
    ELSEIF value.name.value (1) = 'F' THEN
      family_access := $dft$family_access [dfc$remote_file_access];
    ELSEIF (value.name.value (1, 2) = 'LE') OR (value.name.value (1, 2) = 'LA') THEN
      family_access := $dft$family_access [dfc$remote_file_access, dfc$remote_login_access,
            dfc$job_leveling_access];
    ELSEIF (value.name.value (1, 2) = 'LO') OR (value.name.value (1, 2) = 'L ') THEN
      family_access := $dft$family_access [dfc$remote_file_access, dfc$remote_login_access];
    IFEND;

  PROCEND crack_family_access;

?? TITLE := '  find_clients_for_family', EJECT ??

{ PURPOSE:
{   The purpose of this request is to find all the clients for the specified
{   family and to return the client names and associated family accesses.
{
{ NOTES:
{   1.The information is obtained from the permanent file permit array in the
{     permanent file catalog.
{

  PROCEDURE find_clients_for_family
    (    family: ost$family_name;
         p_client_list: ^array [1 .. * ] of pmt$mainframe_id;
         p_access_list: ^array [1 .. * ] of dft$family_access;
     VAR number_of_entries: 0 .. dfc$maximum_partner_mainframes;
     VAR status: ost$status);

    VAR
      catalog_info_selections: pft$catalog_info_selections,
      client_list_size: integer,
      family_access: dft$family_access,
      group: pft$group,
      info_segment_pointer: amt$segment_pointer,
      local_status: ost$status,
      mainframe_id: pmt$mainframe_id,
      path: array [1 .. 2] of pft$name,
      permit_index: pft$array_index,
      p_directory_array: pft$p_directory_array,
      p_info_record: pft$p_info_record,
      p_info: pft$p_info,
      p_permit_array: pft$p_permit_array;

    catalog_info_selections := $pft$catalog_info_selections
          [pfc$catalog_directory, pfc$catalog_permits, pfc$indirect_catalog_permits];

    path [1] := family;
    path [2] := jmc$system_user;
    client_list_size := UPPERBOUND (p_client_list^) - LOWERBOUND (p_client_list^) + 1;
    number_of_entries := 0;

  /main/
    BEGIN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, info_segment_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      p_info := info_segment_pointer.sequence_pointer;
      RESET p_info;

      group.group_type := pfc$member;
      group.member_description.family := osc$null_name;
      group.member_description.account := osc$null_name;
      group.member_description.project := osc$null_name;
      group.member_description.user := osc$null_name;

      pfp$get_item_info (path, group, catalog_info_selections, $pft$file_info_selections [], p_info, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      RESET p_info;

      pfp$find_next_info_record (p_info, p_info_record, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      pfp$find_directory_array (p_info_record, p_directory_array, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF p_directory_array = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_master_catalog, family, status);
        EXIT /main/;
      IFEND;

      pfp$find_direct_info_record (^p_info_record^.body, p_directory_array^ [1].info_offset, p_info_record,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      pfp$find_permit_array (p_info_record, p_permit_array, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF p_permit_array = NIL THEN
        EXIT /main/;
      IFEND;

    /search/
      FOR permit_index := LOWERBOUND (p_permit_array^) TO UPPERBOUND (p_permit_array^) DO
        IF p_permit_array^ [permit_index].group.group_type = pfc$family THEN
          IF p_permit_array^ [permit_index].group.family_description.family (1, 3) = 'DF$' THEN
            number_of_entries := number_of_entries + 1;
            IF number_of_entries <= client_list_size THEN
              p_client_list^ [number_of_entries] := p_permit_array^ [permit_index].group.family_description.
                    family (4, pmc$mainframe_id_size);
              IF p_access_list <> NIL THEN
                get_family_access_from_a_i (p_permit_array^ [permit_index].
                      application_info, p_access_list^ [number_of_entries]);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND /search/;
    END /main/;

    IF info_segment_pointer.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (info_segment_pointer, local_status);
      info_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

  PROCEND find_clients_for_family;

?? TITLE := '    [INLINE] get_family_access_from_a_i', EJECT ??

{ PURPOSE:
{   The purpose of this request is to return the family access from the
{   application_information string.
{
{ NOTES:
{   1.Although dft$family_access is a set, only one element of the set is
{     is stored in the application information.  The set is expanded here
{     so that login_access includes file_access, and leveled_access
{     includes login_access and file_access.
{

  PROCEDURE [INLINE] get_family_access_from_a_i
    (    application_info: pft$application_info;
     VAR family_access: dft$family_access);

    family_access := $dft$family_access [];
    IF application_info (1, access_value_size_in_app_info) = legible_for_remote_file_access THEN
      family_access := $dft$family_access [dfc$remote_file_access];
    ELSEIF application_info (1, access_value_size_in_app_info) = legible_for_remote_login_access THEN
      family_access := $dft$family_access [dfc$remote_file_access, dfc$remote_login_access];
    ELSEIF application_info (1, access_value_size_in_app_info) = legible_for_job_leveling_access THEN
      family_access := $dft$family_access [dfc$remote_file_access, dfc$remote_login_access,
            dfc$job_leveling_access];
    IFEND;

  PROCEND get_family_access_from_a_i;

?? TITLE := '  set_verify_family', EJECT ??

{ PURPOSE:
{   The purpose of this request is to inform the file server poller - via the cpu queue header -
{   that new families are available to the client/

  PROCEDURE set_verify_family
    (    all_clients: boolean,
         p_client_list: ^array [1 .. * ] of pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      client_index: 0 .. dfc$maximum_partner_mainframes,
      ignore_p_q_interf_direc: ^dft$q_interface_directory_entry,
      ignore_p_q_interf_table: dft$p_queue_interface_table,
      ignore_queue_index: dft$queue_index,
      mainframe_found: boolean,
      mainframe_name: pmt$mainframe_id,
      number_of_clients: 0 .. dfc$maximum_partner_mainframes,
      p_all_clients: ^array [1 .. dfc$maximum_partner_mainframes] of dft$partner_mainframe_entry,
      p_cpu_queue: ^dft$cpu_queue;

    IF all_clients THEN
      PUSH p_all_clients;
      dfp$get_partner_mainframes ({partners_are_servers=} FALSE, p_all_clients, number_of_clients);
    ELSE
      number_of_clients := UPPERBOUND (p_client_list^);
    IFEND;


    FOR client_index := 1 TO number_of_clients DO
      IF all_clients THEN
        pmp$convert_binary_mainframe_id (p_all_clients^ [client_index].mainframe_id, mainframe_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        mainframe_name := p_client_list^ [client_index];
      IFEND;

      dfp$find_mainframe_id (mainframe_name, {host_is_server=} TRUE, mainframe_found, ignore_p_q_interf_table,
            p_cpu_queue, ignore_queue_index, ignore_p_q_interf_direc);
      IF mainframe_found THEN
        IF p_cpu_queue^.queue_header.partner_status.server_state = dfc$active THEN
          IF p_cpu_queue^.queue_header.number_of_monitor_queue_entries > 0 THEN
            p_cpu_queue^.queue_header.partner_status.verify_family := TRUE;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND set_verify_family;

MODEND dfm$family_client_manager;
*DECK DECK=DFM$FETCH_PAGE_STATUS EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE : File Server - dfm$fetch_page_status' ??
MODULE dfm$fetch_page_status;

{ PURPOSE:
{   This module contain the following procedures:
{
{      dfp$fetch_page_status - used by memory manager to determine whether a
{           page is on server or is a new page to be created.
{
{

?? NEWTITLE := '  XREF Variables', EJECT ??
*copyc dfv$served_family_table_root
?? OLDTITLE, NEWTITLE := '  XREF Procedures', EJECT ??
*copyc dfp$get_served_file_desc_p
?? OLDTITLE, NEWTITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dft$served_family_table
*copyc gft$locked_file_desc_entry_p
*copyc gft$page_status
*copyc osd$virtual_address
?? POP ??
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL] dfp$fetch_page_status', EJECT ??
{
{   This subroutine provides MM with the information needed to administer
{   page faults on the server.  It determines whether the requested page
{   is within or beyond the current server file or if space needs to be allocated
{   for the server file.

  PROCEDURE [XDCL] dfp$fetch_page_status
    (    fde_p: gft$locked_file_desc_entry_p;
         offset: ost$segment_offset;
     VAR page_status: gft$page_status);

    VAR
      p_served_family_entry: ^dft$served_family_table_entry,
      server_descriptor_p: dft$server_descriptor_p,
      served_family_table_index: dft$served_family_table_index;


{ Locate the server descriptor.

    dfp$get_served_file_desc_p (fde_p, server_descriptor_p);
    served_family_table_index := server_descriptor_p^.header.served_family_table_index;

    p_served_family_entry := ^dfv$served_family_table_root.
          p_family_list_pointer_array^ [served_family_table_index.pointers_index].
          p_served_family_list^ [served_family_table_index.family_list_index];


{ Check if the file was missed in the recovery process - lifetime <> current lifetime
{ No matter what the state of the server is, if the file is marked
{ as terminated, do not allow access to the file.

    IF ((server_descriptor_p^.header.file_state = dfc$terminated) OR
          (p_served_family_entry^.server_state = dfc$deleted) OR
          (p_served_family_entry^.server_state = dfc$terminated)) THEN
      page_status := gfc$ps_server_terminated;


{ Even if the server is now active, but recovery has not been performed
{ on this particular file force the page fault back to job mode, to force recovery of this file.

    ELSEIF (server_descriptor_p^.header.file_state = dfc$awaiting_recovery) OR
          (p_served_family_entry^.server_state <> dfc$active) THEN
      page_status := gfc$ps_volume_unavailable;


{ A file was missed in the recovery process if lifetime <> current lifetime

    ELSEIF p_served_family_entry^.server_lifetime <> server_descriptor_p^.header.server_lifetime THEN
      page_status := gfc$ps_server_terminated;


{ The state of the file must be active or deactive and writing.

{ If the segment_offset passed in is greater than, or equal to, the total allocated length
{ in the server_descriptor, an allocation request must be made to the server before any further
{ processing can be done.

    ELSEIF offset >= server_descriptor_p^.header.total_allocated_length THEN
      page_status := gfc$ps_server_allocate_required;


{ The page must be on the server if it is within range of EOI, otherwise it
{ doesnt exist.

    ELSEIF offset < fde_p^.eoi_byte_address THEN
      page_status := gfc$ps_page_on_server;
    ELSE
      page_status := gfc$ps_page_doesnt_exist;
    IFEND;

  PROCEND dfp$fetch_page_status;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL] dfp$fetch_multi_page_status', EJECT ??

{
{ PURPOSE:
{    This procedure verifies that a range of pages resides on accessible server volumes.
{

  PROCEDURE [XDCL] dfp$fetch_multi_page_status
    (    fde_p: gft$locked_file_desc_entry_p;
         offset: ost$segment_offset; {will be on page boundary}
         length: ost$segment_length; {will be multiple of page size
     VAR page_status: gft$page_status);

    VAR
      allocation_unit_size: integer,
      last_offset: integer;

    allocation_unit_size := fde_p^.allocation_unit_size;
    last_offset := ((offset + length - 1) DIV allocation_unit_size) * allocation_unit_size;

    dfp$fetch_page_status (fde_p, last_offset, page_status);

  PROCEND dfp$fetch_multi_page_status;
?? OLDTITLE, OLDTITLE ??
MODEND dfm$fetch_page_status;
*DECK DECK=DFM$FILE_SERVER_ALLOCATION EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE File Server: client allocation interface to server' ??
MODULE dfm$file_server_allocation;
{
{
{ This module is the module containing procedures to set up client allocation on the server.
{
{
?? NEWTITLE := '  Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfd$request_package
*copyc dfe$error_condition_codes
*copyc dft$allocate_space_request
*copyc dmt$error_condition_codes
*copyc dft$server_descriptor
*copyc gft$system_file_identifier
*copyc ioe$st_errors
*copyc jmt$initiated_job_list_entry

*copyc dfp$assign_queue_entry
*copyc dfp$convert_list_pointer
*copyc dfp$fetch_queue_entry
*copyc dfp$fetch_served_family_info
*copyc dfp$queue_request
*copyc dfp$release_queue_entry
*copyc dfp$set_terminated_mtr_status
*copyc dfp$uncomplement_gfn
*copyc dfp$word_boundary
*copyc dfp$get_served_file_desc_p
*copyc gfp$mtr_get_locked_fde_p
*copyc gfp$mtr_unlock_fde_p
*copyc i#current_sequence_position
*copyc mmp$build_lock_rma_list
*copyc mmp$unlock_rma_list
*copyc mtp$error_stop
*copyc mtp$set_status_abnormal
*copyc sfp$mtr_accumulate_file_space

*copyc osv$page_size
?? POP ??
?? OLDTITLE, NEWTITLE := '  [XDCL] dfp$file_server_allocation', EJECT ??

{
{   This procedure executes on the client mainframe and performs the allocation function called in
{ MMP$PAGE_PULL. It sets up the queue_entry (specified via IO_ID) so that the allocation length
{ requested by the client is input to the link device by the link driver.  It is patterned after
{ DFP$SERVER_IO.
{
  PROCEDURE [XDCL] dfp$file_server_allocation
    (    sfid: gft$system_file_identifier;
         segment_offset: ost$segment_offset;
         segment_length: ost$segment_length;
         io_id: mmt$io_identifier;
         buffer_descriptor: mmt$buffer_descriptor;
         file_space_limit: sft$file_space_limit_kind;
     VAR spio_status: syt$monitor_status);

    VAR
      assign_status: dft$assign_queue_entry_status,
      family_name: ost$family_name,
      index_valid: boolean,
      io_error: iot$io_error,
      list_length: mmt$rma_list_length,
      m_status: syt$monitor_status,
      p_buffer_header: ^dft$buffer_header,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_fde: gft$file_desc_entry_p,
      p_allocate_space_request: ^dft$allocate_space_request,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_rma_list: ^mmt$rma_list,
      p_server_descriptor: dft$server_descriptor_p,
      p_status_response: ^dft$status_response,
      queue_index: dft$queue_index,
      queue_entry_index: dft$queue_entry_index,
      queue_request_status: dft$queue_request_status,
      release_queue_entry_status: dft$release_queue_entry_status,
      served_mainframe_id: pmt$binary_mainframe_id,
      space_limit_exceeded: boolean;

    gfp$mtr_get_locked_fde_p (sfid, NIL, p_fde);

{ Locate server descriptor for file.

    dfp$get_served_file_desc_p (p_fde, p_server_descriptor);
    IF p_server_descriptor = NIL THEN
      mtp$error_stop ('DF - p_server_descriptor = NIL: DFP$FILE_SERVER_ALLOCATION');
    IFEND;

    dfp$fetch_served_family_info (p_server_descriptor^.header.served_family_table_index, family_name,
          served_mainframe_id, p_queue_interface_table, queue_index, index_valid);

    IF NOT index_valid THEN
      spio_status.normal := FALSE;
      spio_status.condition := dfe$server_has_terminated;
      gfp$mtr_unlock_fde_p (p_fde);
      RETURN;
    IFEND; { index_valid }

    IF (p_server_descriptor^.header.file_state = dfc$awaiting_recovery) THEN
      { Force a wait
      spio_status.normal := FALSE;
      spio_status.condition := ioe$unit_disabled;
      gfp$mtr_unlock_fde_p (p_fde);
      RETURN;
    IFEND;

    dfp$assign_queue_entry ( p_queue_interface_table, queue_index, dfc$monitor, queue_entry_index,
          assign_status);

    IF assign_status <> dfc$aqes_entry_assigned THEN
      spio_status.normal := FALSE;
      IF assign_status = dfc$aqes_server_terminated THEN
        dfp$set_terminated_mtr_status (p_queue_interface_table, queue_index,
          spio_status);
      ELSE
        spio_status.condition := dme$transient_error;
      IFEND;
      gfp$mtr_unlock_fde_p (p_fde);
      RETURN;
    IFEND; { assign queue entry }


{   Locate driver and cpu queue entries.

    dfp$fetch_queue_entry (p_queue_interface_table, queue_index, queue_entry_index,
          p_driver_queue_entry, p_cpu_queue_entry);

{   Build request package in send_buffer.

    RESET p_cpu_queue_entry^.p_send_buffer;
    NEXT p_buffer_header IN p_cpu_queue_entry^.p_send_buffer;

{   Fill in request header.

    p_buffer_header^.version := dfc$allocate_request_version;
{   Increment in Q entry when request queued.
    p_buffer_header^.transaction_count := p_cpu_queue_entry^.transaction_count + 1;
    p_buffer_header^.retransmission_count := 0;
    p_cpu_queue_entry^.retransmission_count := 0;

    p_buffer_header^.remote_processor := dfc$allocate;
    p_buffer_header^.data_length_sent := 0;
    p_driver_queue_entry^.flags.send_data := FALSE;

    NEXT p_allocate_space_request IN p_cpu_queue_entry^.p_send_buffer;

{   Fill in page I/O request

    p_allocate_space_request^.segment_offset := segment_offset;
    p_allocate_space_request^.segment_length := segment_length;
    dfp$uncomplement_gfn (p_fde^.global_file_name, p_allocate_space_request^.global_file_name);
    p_allocate_space_request^.eoi_byte_address := p_fde^.eoi_byte_address;
    p_allocate_space_request^.remote_sfid := p_server_descriptor^.header.remote_sfid;

{   Set send buffer length in buffer header.

    p_buffer_header^.buffer_length_sent := dfp$word_boundary (i#current_sequence_position
          (p_cpu_queue_entry^.p_send_buffer));

{   Set fields in cpu queue entry.

    p_cpu_queue_entry^.io_id := io_id;
    p_cpu_queue_entry^.io_type := ioc$allocate;
    p_cpu_queue_entry^.sfid := sfid;

{   Set up driver_queue_entry flags for send buffer and data.
    p_driver_queue_entry^.flags.subsystem_action := FALSE;
    p_driver_queue_entry^.flags.driver_action := TRUE;
    p_driver_queue_entry^.flags.send_command := TRUE;
    p_driver_queue_entry^.flags.send_ready_for_data := FALSE;
    p_driver_queue_entry^.flags.buffer_sent := FALSE;
    p_driver_queue_entry^.flags.data_sent := FALSE;

{   Set send buffer length in driver queue entry.
    p_driver_queue_entry^.send_buffer_descriptor.actual_length := p_buffer_header^.buffer_length_sent;

{   Lock data pages.
{   Set list length in CM words.
    list_length := buffer_descriptor.page_count;

    dfp$convert_list_pointer (p_cpu_queue_entry^.p_data_rma_list, p_rma_list);

    mmp$build_lock_rma_list (buffer_descriptor, buffer_descriptor.page_count * osv$page_size, ioc$allocate,
          p_rma_list, list_length, m_status);

    IF m_status.normal THEN

      p_cpu_queue_entry^.data_pages_locked := TRUE;

{     Set indirect list length in bytes for driver.

      p_driver_queue_entry^.data_descriptor.actual_length := list_length * 8;

{     Queue request for driver.

      dfp$queue_request (p_queue_interface_table, queue_index, queue_entry_index, queue_request_status);
      IF queue_request_status = dfc$qrs_entry_queued THEN

{       Increment read write count, and transaction_count.

        p_server_descriptor^.header.read_write_count := p_server_descriptor^.header.read_write_count + 1;
        p_cpu_queue_entry^.transaction_count := p_cpu_queue_entry^.transaction_count + 1;

        spio_status.normal := TRUE;
        spio_status.condition := 0;

      ELSE { Request buffer queue full, or server terminated.}

{       Restore entry state.

        io_error := ioc$no_error;
        mmp$unlock_rma_list (ioc$no_io, p_rma_list, list_length, io_id, {MF_JOB_FILE} FALSE,
              io_error, m_status);
        IF NOT m_status.normal THEN
          mtp$error_stop ('DF - bad status:   unlock_rma_list: DFP$FILE_SERVER_ALLOCATION');
        IFEND;

        p_driver_queue_entry^.flags.driver_action := FALSE;
        dfp$release_queue_entry (p_queue_interface_table, queue_index, queue_entry_index,
              release_queue_entry_status);
        IF release_queue_entry_status <> dfc$rqes_entry_released THEN
          mtp$error_stop ('DF - unable to release queue entry: DFP$FILE_SERVER_ALLOCATION');
        IFEND;

        spio_status.normal := FALSE;
        IF queue_request_status = dfc$qrs_server_terminated THEN

{       The file_server has terminated sometime between the call to DFP$ASSIGN_QUEUE_ENTRY and the call to
{       DFP$QUEUE_REQUEST.  Send an abnormal status back to the caller of this procedure.

          spio_status.condition := dfe$server_has_terminated;
        ELSE
          spio_status.condition := dme$transient_error;
        IFEND;

      IFEND; {queue request status}

    ELSE {mmp$build_lock_rma_list m_status NOT normal}

      mtp$error_stop ('Unexpected system failure: DFP$FILE_SERVER_ALLOCATION');

    IFEND; {build lock rma list status}

    IF file_space_limit <> sfc$no_limit THEN
      sfp$mtr_accumulate_file_space (file_space_limit, (segment_length - segment_offset),
          space_limit_exceeded);
    IFEND;
    gfp$mtr_unlock_fde_p (p_fde);

  PROCEND dfp$file_server_allocation;
?? OLDTITLE, OLDTITLE ??
MODEND dfm$file_server_allocation;
*DECK DECK=DFM$FILE_SERVER_MANAGEMENT EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := ' NOS/VE File Server: Manage_File_Server Utility', EJECT ??
MODULE dfm$file_server_management;
{
{  This module accepts the operator commands and does the preliminary
{  command verification. It then calls the next level procedure for farther
{  verification of each command and for the command execution.
{
?? NEWTITLE := '    Global Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??

*copyc amp$fetch
*copyc amp$put_next
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc amt$page_width
*copyc clp$end_scan_command_file
*copyc clp$get_value
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$scan_command_file
*copyc clp$scan_parameter_list
*copyc clt$command_table
*copyc clt$function_table
*copyc dfe$error_condition_codes
*copyc dfi$display
*copyc dfp$activate_client
*copyc dfp$activate_server
*copyc dfp$client_mainframes_display
*copyc dfp$crack_mainframe_id
*copyc dfp$deactivate_client
*copyc dfp$deactivate_server
*copyc dfp$delete_client
*copyc dfp$delete_server
*copyc dfp$display_client
*copyc dfp$display_server
*copyc dfp$display_stornet_connection
*copyc dfp$terminate_client
*copyc dfp$terminate_server
*copyc dfp$timeout_client
*copyc dfp$timeout_server
*copyc dfp$verify_system_administrator
*copyc fsp$close_file
*copyc fsp$open_file
*copyc oss$job_paged_literal
*copyc pmt$binary_mainframe_id
*copyc pmt$mainframe_id

?? POP ??


{ table fs_manager_commands type=command sn=oss$job_paged_literal version=0
{ command (activate_client, actc) activate_client local
{ command (activate_server, acts) activate_server local
{ command (change_client_access, chaca) dfp$change_client_access_cmnd xref
{ command (deactivate_client, deac) deactivate_client local
{ command (deactivate_server, deas) deactivate_server local
{ command (define_application_rpc, defarpc, defar)           dfp$define_application_rpc_cmnd xref
{ command (define_client,defc) dfp$define_client_command xref
{ command (define_client_application_info, defcai)           dfp$define_client_app_info_cmnd xref
{ command (define_served_families, define_served_family, defsf)           ..
{   dfp$define_served_families_cmnd xref
{ command (define_server, defs) dfp$define_server_command xref
{ command (define_stornet_connection,defsc) dfp$define_esm_command xref
{ command (delete_application_rpc, delarpc, delar)           dfp$delete_application_rpc_cmnd xref
{ command (delete_client, delc) delete_client local
{ command (delete_client_application_info delcai)           dfp$delete_client_app_info_cmnd xref
{ command (delete_server, dels) delete_server local
{ command (delete_stornet_connection,delsc) dfp$delete_esm_command xref
{ command (dftu) processor=dfp$driver_test_utility call_method=xref           ..
{   availability=hidden log=automatic
{ command (display_application_rpc, disar) dfp$display_application_rpc xref
{ command (display_client, disc) display_client local
{ command (display_client_access, disca) dfp$display_client_access_cmnd xref
{ command (display_client_application_info, discai)       dfp$display_client_app_info_cmn xref
{ command (display_client_mainframe, display_client_mainframes, discm) ..
{   display_client_mainframes local
{ command (display_server, diss) display_server local
{ command (display_stornet_connection, dissc) display_stornet_connection           local
{ command (terminate_client, terc) terminate_client local
{ command (terminate_server, ters) terminate_server local
{ command (timeout_client, timc) timeout_client local
{ command (timeout_server, tims) timeout_server local
{ command (quit, qui) quit_command local
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  fs_manager_commands: [STATIC, READ, oss$job_paged_literal] ^clt$command_table :=
      ^fs_manager_commands_entries,

  fs_manager_commands_entries: [STATIC, READ, oss$job_paged_literal] array [1 .. 61] of
      clt$command_table_entry := [
  {} ['ACTC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^activate_client],
  {} ['ACTIVATE_CLIENT                ', clc$nominal_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^activate_client],
  {} ['ACTIVATE_SERVER                ', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^activate_server],
  {} ['ACTS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^activate_server],
  {} ['CHACA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^dfp$change_client_access_cmnd],
  {} ['CHANGE_CLIENT_ACCESS           ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^dfp$change_client_access_cmnd],
  {} ['DEAC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^deactivate_client],
  {} ['DEACTIVATE_CLIENT              ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^deactivate_client],
  {} ['DEACTIVATE_SERVER              ', clc$nominal_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^deactivate_server],
  {} ['DEAS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^deactivate_server],
  {} ['DEFAR                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^dfp$define_application_rpc_cmnd],
  {} ['DEFARPC                        ', clc$alias_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^dfp$define_application_rpc_cmnd],
  {} ['DEFC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^dfp$define_client_command],
  {} ['DEFCAI                         ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^dfp$define_client_app_info_cmnd],
  {} ['DEFINE_APPLICATION_RPC         ', clc$nominal_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^dfp$define_application_rpc_cmnd],
  {} ['DEFINE_CLIENT                  ', clc$nominal_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^dfp$define_client_command],
  {} ['DEFINE_CLIENT_APPLICATION_INFO ', clc$nominal_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^dfp$define_client_app_info_cmnd],
  {} ['DEFINE_SERVED_FAMILIES         ', clc$nominal_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^dfp$define_served_families_cmnd],
  {} ['DEFINE_SERVED_FAMILY           ', clc$alias_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^dfp$define_served_families_cmnd],
  {} ['DEFINE_SERVER                  ', clc$nominal_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^dfp$define_server_command],
  {} ['DEFINE_STORNET_CONNECTION      ', clc$nominal_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^dfp$define_esm_command],
  {} ['DEFS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
         clc$automatically_log, clc$linked_call, ^dfp$define_server_command],
  {} ['DEFSC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 11,
         clc$automatically_log, clc$linked_call, ^dfp$define_esm_command],
  {} ['DEFSF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^dfp$define_served_families_cmnd],
  {} ['DELAR                          ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
         clc$automatically_log, clc$linked_call, ^dfp$delete_application_rpc_cmnd],
  {} ['DELARPC                        ', clc$alias_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^dfp$delete_application_rpc_cmnd],
  {} ['DELC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 13,
         clc$automatically_log, clc$linked_call, ^delete_client],
  {} ['DELCAI                         ', clc$abbreviation_entry, clc$normal_usage_entry, 14,
         clc$automatically_log, clc$linked_call, ^dfp$delete_client_app_info_cmnd],
  {} ['DELETE_APPLICATION_RPC         ', clc$nominal_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^dfp$delete_application_rpc_cmnd],
  {} ['DELETE_CLIENT                  ', clc$nominal_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^delete_client],
  {} ['DELETE_CLIENT_APPLICATION_INFO ', clc$nominal_entry, clc$normal_usage_entry, 14,
        clc$automatically_log, clc$linked_call, ^dfp$delete_client_app_info_cmnd],
  {} ['DELETE_SERVER                  ', clc$nominal_entry, clc$normal_usage_entry, 15,
        clc$automatically_log, clc$linked_call, ^delete_server],
  {} ['DELETE_STORNET_CONNECTION      ', clc$nominal_entry, clc$normal_usage_entry, 16,
        clc$automatically_log, clc$linked_call, ^dfp$delete_esm_command],
  {} ['DELS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 15,
         clc$automatically_log, clc$linked_call, ^delete_server],
  {} ['DELSC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 16,
         clc$automatically_log, clc$linked_call, ^dfp$delete_esm_command],
  {} ['DFTU                           ', clc$nominal_entry, clc$hidden_entry, 17,
        clc$automatically_log, clc$linked_call, ^dfp$driver_test_utility],
  {} ['DISAR                          ', clc$abbreviation_entry, clc$normal_usage_entry, 18,
         clc$automatically_log, clc$linked_call, ^dfp$display_application_rpc],
  {} ['DISC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 19,
         clc$automatically_log, clc$linked_call, ^display_client],
  {} ['DISCA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 20,
         clc$automatically_log, clc$linked_call, ^dfp$display_client_access_cmnd],
  {} ['DISCAI                         ', clc$abbreviation_entry, clc$normal_usage_entry, 21,
         clc$automatically_log, clc$linked_call, ^dfp$display_client_app_info_cmn],
  {} ['DISCM                          ', clc$abbreviation_entry, clc$normal_usage_entry, 22,
         clc$automatically_log, clc$linked_call, ^display_client_mainframes],
  {} ['DISPLAY_APPLICATION_RPC        ', clc$nominal_entry, clc$normal_usage_entry, 18,
        clc$automatically_log, clc$linked_call, ^dfp$display_application_rpc],
  {} ['DISPLAY_CLIENT                 ', clc$nominal_entry, clc$normal_usage_entry, 19,
        clc$automatically_log, clc$linked_call, ^display_client],
  {} ['DISPLAY_CLIENT_ACCESS          ', clc$nominal_entry, clc$normal_usage_entry, 20,
        clc$automatically_log, clc$linked_call, ^dfp$display_client_access_cmnd],
  {} ['DISPLAY_CLIENT_APPLICATION_INFO', clc$nominal_entry, clc$normal_usage_entry, 21,
        clc$automatically_log, clc$linked_call, ^dfp$display_client_app_info_cmn],
  {} ['DISPLAY_CLIENT_MAINFRAME       ', clc$nominal_entry, clc$normal_usage_entry, 22,
        clc$automatically_log, clc$linked_call, ^display_client_mainframes],
  {} ['DISPLAY_CLIENT_MAINFRAMES      ', clc$alias_entry, clc$normal_usage_entry, 22,
        clc$automatically_log, clc$linked_call, ^display_client_mainframes],
  {} ['DISPLAY_SERVER                 ', clc$nominal_entry, clc$normal_usage_entry, 23,
        clc$automatically_log, clc$linked_call, ^display_server],
  {} ['DISPLAY_STORNET_CONNECTION     ', clc$nominal_entry, clc$normal_usage_entry, 24,
        clc$automatically_log, clc$linked_call, ^display_stornet_connection],
  {} ['DISS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 23,
         clc$automatically_log, clc$linked_call, ^display_server],
  {} ['DISSC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 24,
         clc$automatically_log, clc$linked_call, ^display_stornet_connection],
  {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 29,
         clc$automatically_log, clc$linked_call, ^quit_command],
  {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 29,
        clc$automatically_log, clc$linked_call, ^quit_command],
  {} ['TERC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 25,
         clc$automatically_log, clc$linked_call, ^terminate_client],
  {} ['TERMINATE_CLIENT               ', clc$nominal_entry, clc$normal_usage_entry, 25,
        clc$automatically_log, clc$linked_call, ^terminate_client],
  {} ['TERMINATE_SERVER               ', clc$nominal_entry, clc$normal_usage_entry, 26,
        clc$automatically_log, clc$linked_call, ^terminate_server],
  {} ['TERS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 26,
         clc$automatically_log, clc$linked_call, ^terminate_server],
  {} ['TIMC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 27,
         clc$automatically_log, clc$linked_call, ^timeout_client],
  {} ['TIMEOUT_CLIENT                 ', clc$nominal_entry, clc$normal_usage_entry, 27,
        clc$automatically_log, clc$linked_call, ^timeout_client],
  {} ['TIMEOUT_SERVER                 ', clc$nominal_entry, clc$normal_usage_entry, 28,
        clc$automatically_log, clc$linked_call, ^timeout_server],
  {} ['TIMS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 28,
         clc$automatically_log, clc$linked_call, ^timeout_server]];

  PROCEDURE [XREF] dfp$change_client_access_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$define_application_rpc_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$define_client_app_info_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$define_client_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$define_esm_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$define_served_families_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$define_server_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$delete_application_rpc_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$delete_client_app_info_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$delete_esm_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$display_application_rpc
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$display_client_access_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$display_client_app_info_cmn
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$driver_test_utility
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??



{ table manfs_functions t=f sn=oss$job_paged_literal v=0
{ function ($client_family_access, $cfa)  dfp$$client_family_access xref a=h
{ function ($client_state, $cs)  dfp$$client_state   xref a=h
{ function ($served_family_access, $sfa)  dfp$$served_family_access xref a=h
{ function ($server_state, $ss)  dfp$$server_state  xref a=h
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  manfs_functions: [STATIC, READ, oss$job_paged_literal] ^clt$function_table := ^manfs_functions_entries,

  manfs_functions_entries: [STATIC, READ, oss$job_paged_literal] array [1 .. 8] of
      clt$function_table_entry := [
  {} ['$CFA                           ', clc$abbreviation_entry, clc$hidden_entry, 1, clc$linked_call,
        ^dfp$$client_family_access],
  {} ['$CLIENT_FAMILY_ACCESS          ', clc$nominal_entry, clc$hidden_entry, 1, clc$linked_call,
        ^dfp$$client_family_access],
  {} ['$CLIENT_STATE                  ', clc$nominal_entry, clc$hidden_entry, 2, clc$linked_call,
        ^dfp$$client_state],
  {} ['$CS                            ', clc$abbreviation_entry, clc$hidden_entry, 2, clc$linked_call,
        ^dfp$$client_state],
  {} ['$SERVED_FAMILY_ACCESS          ', clc$nominal_entry, clc$hidden_entry, 3, clc$linked_call,
        ^dfp$$served_family_access],
  {} ['$SERVER_STATE                  ', clc$nominal_entry, clc$hidden_entry, 4, clc$linked_call,
        ^dfp$$server_state],
  {} ['$SFA                           ', clc$abbreviation_entry, clc$hidden_entry, 3, clc$linked_call,
        ^dfp$$served_family_access],
  {} ['$SS                            ', clc$abbreviation_entry, clc$hidden_entry, 4, clc$linked_call,
        ^dfp$$server_state]];

  PROCEDURE [XREF] dfp$$client_family_access
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$$client_state
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$$served_family_access
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$$server_state
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

?? POP ??



  CONST
    utility_name = 'MANAGE_FILE_SERVER             ';

  CONST
    default_page_width = 79,
    minimum_page_width = 50,
    maximum_page_width = 110;

?? TITLE := '   dfp$manage_file_server', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$manage_file_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      command_file: amt$local_file_name,
      local_status: ost$status;

{    pdt manage_file_server_pdt (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      manage_file_server_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^manage_file_server_pdt_names, ^manage_file_server_pdt_params];

    VAR
      manage_file_server_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      manage_file_server_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
            clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    clp$scan_parameter_list (parameter_list, manage_file_server_pdt, status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$verify_system_administrator ('MANAGE_FILE_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$push_utility (utility_name, clc$global_command_search, fs_manager_commands,
          manfs_functions, status);
    IF status.normal THEN
      command_file := '$COMMAND';
      clp$scan_command_file (command_file, utility_name, 'manfs', status);
      clp$pop_utility (local_status);
    IFEND;

  PROCEND dfp$manage_file_server;

?? TITLE := '   dfp$manage_file_server - ALIAS', EJECT ??

  PROCEDURE [XDCL, #GATE] manfs
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    { Provide a short easy to type alias.
    dfp$manage_file_server (parameter_list, status);

  PROCEND manfs;

?? TITLE := '   activate_client', EJECT ??

  PROCEDURE activate_client
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   pdt activate_client_pdt (
{     mainframe_identifier, mi: name pmc$mainframe_id_size = $required
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    activate_client_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^activate_client_pdt_names
      , ^activate_client_pdt_params];

  VAR
    activate_client_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['MAINFRAME_IDENTIFIER', 1], ['MI', 1], ['STATUS', 2]];

  VAR
    activate_client_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor
      := [

{ MAINFRAME_IDENTIFIER MI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, pmc$mainframe_id_size,
      pmc$mainframe_id_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id;

    clp$scan_parameter_list (parameter_list, activate_client_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$crack_mainframe_id ('MAINFRAME_IDENTIFIER', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$activate_client (mainframe_name, status);

  PROCEND activate_client;

?? TITLE := '   activate_server', EJECT ??

  PROCEDURE activate_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{    pdt activate_server_pdt (
{      mainframe_identifier, mi: name pmc$mainframe_id_size = $required
{      status)

?? PUSH (LISTEXT := ON) ??

  VAR
    activate_server_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^activate_server_pdt_names
      , ^activate_server_pdt_params];

  VAR
    activate_server_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['MAINFRAME_IDENTIFIER', 1], ['MI', 1], ['STATUS', 2]];

  VAR
    activate_server_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor
      := [

{ MAINFRAME_IDENTIFIER MI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, pmc$mainframe_id_size,
      pmc$mainframe_id_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id;

    clp$scan_parameter_list (parameter_list, activate_server_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$crack_mainframe_id ('MAINFRAME_IDENTIFIER', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$activate_server (mainframe_name, status);

  PROCEND activate_server;

?? TITLE := '   deactivate_client', EJECT ??

  PROCEDURE deactivate_client
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   pdt deactivate_client_pdt (mainframe_identifier, mi: name pmc$mainframe_id_size = $required
{         status)

?? PUSH (LISTEXT := ON) ??

  VAR
    deactivate_client_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^deactivate_client_pdt_names, ^deactivate_client_pdt_params];

  VAR
    deactivate_client_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['MAINFRAME_IDENTIFIER', 1], ['MI', 1], ['STATUS', 2]];

  VAR
    deactivate_client_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
      clt$parameter_descriptor := [

{ MAINFRAME_IDENTIFIER MI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, pmc$mainframe_id_size,
      pmc$mainframe_id_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id;

    clp$scan_parameter_list (parameter_list, deactivate_client_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$crack_mainframe_id ('MAINFRAME_IDENTIFIER', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$deactivate_client (mainframe_name, status);

  PROCEND deactivate_client;

?? TITLE := '   deactivate_server', EJECT ??

  PROCEDURE deactivate_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{     pdt deactivate_server_pdt (
{       mainframe_identifier, mi: name pmc$mainframe_id_size = $required
{       status)

?? PUSH (LISTEXT := ON) ??

  VAR
    deactivate_server_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^deactivate_server_pdt_names, ^deactivate_server_pdt_params];

  VAR
    deactivate_server_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['MAINFRAME_IDENTIFIER', 1], ['MI', 1], ['STATUS', 2]];

  VAR
    deactivate_server_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
      clt$parameter_descriptor := [

{ MAINFRAME_IDENTIFIER MI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, pmc$mainframe_id_size,
      pmc$mainframe_id_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id;

    clp$scan_parameter_list (parameter_list, deactivate_server_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$crack_mainframe_id ('MAINFRAME_IDENTIFIER', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$deactivate_server (mainframe_name, status);

  PROCEND deactivate_server;

?? TITLE := '   delete_client', EJECT ??

  PROCEDURE delete_client
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{     pdt delete_client_pdt (
{       mainframe_identifier, mi: name pmc$mainframe_id_size = $required
{       status)

?? PUSH (LISTEXT := ON) ??

  VAR
    delete_client_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^delete_client_pdt_names,
      ^delete_client_pdt_params];

  VAR
    delete_client_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['MAINFRAME_IDENTIFIER', 1], ['MI', 1], ['STATUS', 2]];

  VAR
    delete_client_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor
      := [

{ MAINFRAME_IDENTIFIER MI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, pmc$mainframe_id_size,
      pmc$mainframe_id_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id;

    clp$scan_parameter_list (parameter_list, delete_client_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$crack_mainframe_id ('MAINFRAME_IDENTIFIER', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$delete_client (mainframe_name, status);

  PROCEND delete_client;

?? TITLE := '   delete_server', EJECT ??

  PROCEDURE delete_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{    pdt delete_server_pdt (
{      mainframe_identifier, mi: name pmc$mainframe_id_size = $required
{      status)

?? PUSH (LISTEXT := ON) ??

  VAR
    delete_server_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^delete_server_pdt_names,
      ^delete_server_pdt_params];

  VAR
    delete_server_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['MAINFRAME_IDENTIFIER', 1], ['MI', 1], ['STATUS', 2]];

  VAR
    delete_server_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor
      := [

{ MAINFRAME_IDENTIFIER MI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, pmc$mainframe_id_size,
      pmc$mainframe_id_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id;

    clp$scan_parameter_list (parameter_list, delete_server_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$crack_mainframe_id ('MAINFRAME_IDENTIFIER', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$delete_server (mainframe_name, status);

  PROCEND delete_server;

?? TITLE := '  display_client', EJECT ??

  PROCEDURE display_client
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{    pdt display_client_pdt (
{      mainframe_identifier, mi: name pmc$mainframe_id_size = $required
{      output, o: file = $OUTPUT
{      status)

?? PUSH (LISTEXT := ON) ??

  VAR
    display_client_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^display_client_pdt_names,
      ^display_client_pdt_params];

  VAR
    display_client_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['MAINFRAME_IDENTIFIER', 1], ['MI', 1], ['OUTPUT', 2], ['O', 2], [
      'STATUS', 3]];

  VAR
    display_client_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor
      := [

{ MAINFRAME_IDENTIFIER MI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, pmc$mainframe_id_size,
      pmc$mainframe_id_size]],

{ OUTPUT O }
    [[clc$optional_with_default, ^display_client_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    display_client_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??

    VAR
      ignore_status: ost$status,
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id,
      output_file_fid: amt$file_identifier,
      output_file_name: amt$local_file_name,
      page_width: amt$page_width,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, display_client_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$crack_mainframe_id ('MAINFRAME_IDENTIFIER', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output_file_name := value.file.local_file_name;
    open_output_file (output_file_name, output_file_fid, page_width, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$display_client (mainframe_name, output_file_fid, page_width, status);
    IF status.normal THEN
      fsp$close_file (output_file_fid, status);
    ELSE
      fsp$close_file (output_file_fid, ignore_status);
    IFEND;

  PROCEND display_client;

?? TITLE := '  display_client_mainframes ', EJECT ??

  PROCEDURE display_client_mainframes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt display_client_mfs (
{    output, o: file = $output
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

    VAR
      display_client_mfs: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^display_client_mfs_names , ^display_client_mfs_params];

    VAR
      display_client_mfs_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['OUTPUT', 1], ['O', 1], ['STATUS', 2]];

    VAR
      display_client_mfs_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ OUTPUT O }
            [[clc$optional_with_default, ^display_client_mfs_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$file_value]],

{ STATUS }
            [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
            clc$array_not_allowed, clc$status_value]]];

    VAR
      display_client_mfs_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$output';

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      file_name: amt$local_file_name,
      name: ost$name,
      value: clt$value;


    status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, display_client_mfs, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$client_mainframes_display (value.file.local_file_name, status);

  PROCEND display_client_mainframes;
?? TITLE := '  display_server', EJECT ??

  PROCEDURE display_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{    pdt display_server_pdt (
{      mainframe_identifier, mi: name pmc$mainframe_id_size = $required
{      output, o: file = $OUTPUT
{      status)

?? PUSH (LISTEXT := ON) ??

  VAR
    display_server_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^display_server_pdt_names,
      ^display_server_pdt_params];

  VAR
    display_server_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['MAINFRAME_IDENTIFIER', 1], ['MI', 1], ['OUTPUT', 2], ['O', 2], [
      'STATUS', 3]];

  VAR
    display_server_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor
      := [

{ MAINFRAME_IDENTIFIER MI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, pmc$mainframe_id_size,
      pmc$mainframe_id_size]],

{ OUTPUT O }
    [[clc$optional_with_default, ^display_server_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    display_server_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??

    VAR
      ignore_status: ost$status,
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id,
      output_file_fid: amt$file_identifier,
      output_file_name: amt$local_file_name,
      page_width: amt$page_width,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, display_server_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$crack_mainframe_id ('MAINFRAME_IDENTIFIER', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output_file_name := value.file.local_file_name;
    open_output_file (output_file_name, output_file_fid, page_width, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$display_server (mainframe_name, output_file_fid, page_width, status);
    IF status.normal THEN
      fsp$close_file (output_file_fid, status);
    ELSE
      fsp$close_file (output_file_fid, ignore_status);
    IFEND;

  PROCEND display_server;

?? TITLE := '  display_stornet_connection', EJECT ??
  PROCEDURE display_stornet_connection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{     pdt display_stornet_pdt (
{       element_name, en: name = $required
{       output, o: file = $OUTPUT
{       status)

?? PUSH (LISTEXT := ON) ??

  VAR
    display_stornet_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^display_stornet_pdt_names
      , ^display_stornet_pdt_params];

  VAR
    display_stornet_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['ELEMENT_NAME', 1], ['EN', 1], ['OUTPUT', 2], ['O', 2], ['STATUS', 3]
      ];

  VAR
    display_stornet_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor
      := [

{ ELEMENT_NAME EN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ OUTPUT O }
    [[clc$optional_with_default, ^display_stornet_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    display_stornet_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??

    VAR
      element_name: cmt$element_name,
      ignore_status: ost$status,
      output_file_fid: amt$file_identifier,
      output_file_name: amt$local_file_name,
      page_width: amt$page_width,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, display_stornet_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('ELEMENT_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    element_name := value.name.value;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output_file_name := value.file.local_file_name;
    open_output_file (output_file_name, output_file_fid, page_width, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$display_stornet_connection (element_name, output_file_fid, page_width, status);
    IF status.normal THEN
      fsp$close_file (output_file_fid, status);
    ELSE
      fsp$close_file (output_file_fid, ignore_status);
    IFEND;

  PROCEND display_stornet_connection;

?? TITLE := '  open_output_file', EJECT ??

  PROCEDURE open_output_file
    (    file_name: amt$local_file_name;
     VAR output_file_fid: amt$file_identifier;
     VAR page_width: amt$page_width;
     VAR status: ost$status);

    VAR
      file_attachment: array [1 .. 3] of fst$attachment_option,
      local_status: ost$status,

      output_file_attributes: array [1 .. 1] of amt$fetch_item;

    file_attachment [1].selector := fsc$access_and_share_modes;
    file_attachment [1].access_modes.selector := fsc$specific_access_modes;
    file_attachment [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
    file_attachment [1].share_modes.selector := fsc$specific_share_modes;
    file_attachment [1].share_modes.value := $fst$file_access_options [];
    file_attachment [2].selector := fsc$access_and_share_modes;
    file_attachment [2].access_modes.selector := fsc$specific_access_modes;
    file_attachment [2].access_modes.value := $fst$file_access_options [fsc$append];
    file_attachment [2].share_modes.selector := fsc$specific_share_modes;
    file_attachment [2].share_modes.value := $fst$file_access_options [];
    file_attachment [3].selector := fsc$open_share_modes;
    file_attachment [3].open_share_modes := -$fst$file_access_options [];

    fsp$open_file (file_name, amc$record, ^file_attachment, NIL, NIL, NIL, NIL, output_file_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_file_attributes [1].key := amc$page_width;
    amp$fetch (output_file_fid, output_file_attributes, status);
    IF NOT status.normal THEN
      fsp$close_file (output_file_fid, local_status);
      RETURN;
    IFEND;

    IF (output_file_attributes [1].source <> amc$undefined_attribute) AND
          (output_file_attributes [1].source <> amc$access_method_default) THEN
      page_width := output_file_attributes [1].page_width;
    ELSE
      page_width := default_page_width;
    IFEND;

    IF page_width < minimum_page_width THEN
      page_width := minimum_page_width;
    ELSEIF page_width > maximum_page_width THEN
      page_width := maximum_page_width;
    IFEND;

  PROCEND open_output_file;

?? TITLE := '   terminate_client', EJECT ??

  PROCEDURE terminate_client
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{     pdt terminate_client_pdt (
{       mainframe_identifier, mi: name pmc$mainframe_id_size = $required
{       status)

?? PUSH (LISTEXT := ON) ??

  VAR
    terminate_client_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^terminate_client_pdt_names, ^terminate_client_pdt_params];

  VAR
    terminate_client_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['MAINFRAME_IDENTIFIER', 1], ['MI', 1], ['STATUS', 2]];

  VAR
    terminate_client_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
      clt$parameter_descriptor := [

{ MAINFRAME_IDENTIFIER MI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, pmc$mainframe_id_size,
      pmc$mainframe_id_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id;

    clp$scan_parameter_list (parameter_list, terminate_client_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$crack_mainframe_id ('MAINFRAME_IDENTIFIER', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$terminate_client (mainframe_name, status);

  PROCEND terminate_client;

?? TITLE := '   terminate_server', EJECT ??

  PROCEDURE terminate_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt terminate_server_pdt (
{   mainframe_identifier, mi: name pmc$mainframe_id_size = $required
{   users_wait_on_terminated, uwot: boolean
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    terminate_server_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
  ^terminate_server_pdt_names, ^terminate_server_pdt_params];

  VAR
    terminate_server_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
  clt$parameter_name_descriptor := [['MAINFRAME_IDENTIFIER', 1], ['MI', 1], ['USERS_WAIT_ON_TERMINATED', 2], [
  'UWOT', 2], ['STATUS', 3]];

  VAR
    terminate_server_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
  clt$parameter_descriptor := [

{ MAINFRAME_IDENTIFIER MI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, pmc$mainframe_id_size,
  pmc$mainframe_id_size]],

{ USERS_WAIT_ON_TERMINATED UWOT }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? POP ??
    VAR
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id,
      users_wait_on_term_specified: boolean,
      users_wait_on_terminated: boolean,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, terminate_server_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$crack_mainframe_id ('MAINFRAME_IDENTIFIER', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('USERS_WAIT_ON_TERMINATED', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind = clc$unknown_value THEN
      users_wait_on_term_specified := FALSE;
    ELSE
      users_wait_on_term_specified := TRUE;
      users_wait_on_terminated := value.bool.value;
    IFEND;

    dfp$terminate_server (mainframe_name, users_wait_on_term_specified,
          users_wait_on_terminated, status);

  PROCEND terminate_server;
?? TITLE := '   timeout_client', EJECT ??

  PROCEDURE timeout_client
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{     pdt timeout_client_pdt (
{       mainframe_identifier, mi: name pmc$mainframe_id_size = $required
{       status)

?? PUSH (LISTEXT := ON) ??

  VAR
    timeout_client_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^timeout_client_pdt_names, ^timeout_client_pdt_params];

  VAR
    timeout_client_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['MAINFRAME_IDENTIFIER', 1], ['MI', 1], ['STATUS', 2]];

  VAR
    timeout_client_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
      clt$parameter_descriptor := [

{ MAINFRAME_IDENTIFIER MI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, pmc$mainframe_id_size,
      pmc$mainframe_id_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id;

    clp$scan_parameter_list (parameter_list, timeout_client_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$crack_mainframe_id ('MAINFRAME_IDENTIFIER', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$timeout_client (mainframe_name, status);

  PROCEND timeout_client;
?? TITLE := '   timeout_server', EJECT ??

  PROCEDURE timeout_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{     pdt timeout_server_pdt (
{       mainframe_identifier, mi: name pmc$mainframe_id_size = $required
{       status)

?? PUSH (LISTEXT := ON) ??

  VAR
    timeout_server_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^timeout_server_pdt_names, ^timeout_server_pdt_params];

  VAR
    timeout_server_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['MAINFRAME_IDENTIFIER', 1], ['MI', 1], ['STATUS', 2]];

  VAR
    timeout_server_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
      clt$parameter_descriptor := [

{ MAINFRAME_IDENTIFIER MI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, pmc$mainframe_id_size,
      pmc$mainframe_id_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id;

    clp$scan_parameter_list (parameter_list, timeout_server_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$crack_mainframe_id ('MAINFRAME_IDENTIFIER', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$timeout_server (mainframe_name, status);

  PROCEND timeout_server;

?? TITLE := '   QUIT', EJECT ??

  PROCEDURE quit_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   pdt quit_pdt ()

?? PUSH (LISTEXT := ON) ??

    VAR
      quit_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??

    clp$scan_parameter_list (parameter_list, quit_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$end_scan_command_file (utility_name, status);

  PROCEND quit_command;

MODEND dfm$file_server_management;
*DECK DECK=DFM$FILE_SERVER_PAGE_IO EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE File Server: client/server page I/O procs ', EJECT ??
MODULE dfm$file_server_page_io;
{
{  This module contains the file server page input/output processes for
{ the client and server.
{
?? NEWTITLE := '  Global Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??

*copyc amt$file_byte_address
*copyc dmt$error_condition_codes
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc dfk$keypoints
*copyc dft$cpu_queue
*copyc dft$allocate_space_response
*copyc dft$allocate_space_request
*copyc dft$page_io_response
*copyc dft$page_io_request
*copyc dft$queue_request_status
*copyc dft$server_descriptor
*copyc dmt$file_allocation_descriptor
*copyc ioe$st_errors
*copyc mmt$buffer_descriptor
*copyc mmt$file_server_io_status
*copyc syt$monitor_status
*copyc i#current_sequence_position
*copyc dfv$active_queue_entry_flags
*copyc dfv$file_server_debug_enabled
*copyc dfv$send_command_flags
*copyc dfv$send_command_and_data_flags
*copyc dfv$send_ready_for_data_flags
*copyc osv$page_size
*copyc dfd$request_package
*copyc dfi$monitor_display
*copyc dfp$assign_queue_entry
*copyc dfp$fetch_served_family_info
*copyc dfp$fetch_queue_entry
*copyc dfp$get_qit_p_from_direct_index
*copyc dfp$queue_request
*copyc dfp$set_terminated_mtr_status
*copyc dfp$uncomplement_gfn
*copyc dfp$release_queue_entry
*copyc dfp$word_boundary
*copyc dmp$get_disk_file_descriptor_p
*copyc dfp$get_served_file_desc_p
*copyc mmp$build_lock_rma_list
*copyc mmp$unlock_rma_list
*copyc mtp$error_stop
?? POP ??
?? TITLE := '  INLINE DECKS ', EJECT ??
*copyc dfp$convert_list_pointer
*copyc gfp$mtr_get_locked_fde_p
*copyc gfp$mtr_get_sfid_from_fde_p
*copyc gfp$mtr_unlock_fde_p
?? TITLE := '  [XDCL] dfp$client_io', EJECT ??
{
{   This procedure executes on the server mainframe and performs the output
{ function for mmp$write_pages_to_client, and the input function for
{ mmp$read_pages_from_client. It sets up the queue_entry (specified via IO_ID)
{ so that the pages sent or requested by the client are input or output to the
{ link device by the link driver.

  PROCEDURE [XDCL] dfp$client_io
    (    p_server_iocb: ^mmt$server_iocb_entry;
         io_type: iot$io_function;
         io_id: mmt$io_identifier;
         buffer_descriptor: mmt$buffer_descriptor;
     VAR cpio_status: mmt$file_server_io_status);


    VAR
      disk_file_descriptor_p: ^dmt$disk_file_descriptor,
      io_error: iot$io_error,
      list_length: mmt$rma_list_length,
      m_status: syt$monitor_status,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_fde: gft$file_desc_entry_p,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_req_buffer_header: ^dft$buffer_header,
      p_status_response: ^dft$status_response,
      p_page_io_response: ^dft$page_io_response,
      p_rma_list: ^mmt$rma_list,
      queue_request_status: dft$queue_request_status;

    #KEYPOINT (osk$entry, osk$m * $integer(io_type), dfk$client_io);

    gfp$mtr_get_locked_fde_p (p_server_iocb^.sfid, NIL, p_fde);

      { Locate driver and cpu queue entries.
      dfp$get_qit_p_from_direct_index (io_id.queue_entry_location.directory_index, p_queue_interface_table);
      dfp$fetch_queue_entry (p_queue_interface_table, io_id.queue_entry_location.queue_index,
          io_id.queue_entry_location.queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry);

      p_cpu_queue_entry^.io_type := io_type;
      p_cpu_queue_entry^.sfid := p_server_iocb^.sfid;

{ Update System File Table Entry if new EOI greater than current.

      IF p_server_iocb^.eoi > p_fde^.eoi_byte_address THEN
        p_fde^.flags.eoi_modified := TRUE;
        p_fde^.eoi_byte_address := p_server_iocb^.eoi;
      IFEND;

{ Locate disk file descriptor for file.

      dmp$get_disk_file_descriptor_p (p_fde, disk_file_descriptor_p);

      CASE io_type OF
      = ioc$write_to_client =

          { Build page I/O response in send_buffer.
          RESET p_cpu_queue_entry^.p_send_buffer;

          { Fill in response header.
          NEXT p_status_response IN p_cpu_queue_entry^.p_send_buffer;

          p_status_response^.buffer_header.version := dfc$status_buffer_version;

          RESET p_cpu_queue_entry^.p_receive_buffer;
          NEXT p_req_buffer_header IN p_cpu_queue_entry^.p_receive_buffer;

          p_status_response^.buffer_header.remote_processor :=
              p_req_buffer_header^.remote_processor;
          p_status_response^.buffer_header.transaction_count :=
               p_cpu_queue_entry^.transaction_count;
          p_status_response^.buffer_header.retransmission_count :=
               p_cpu_queue_entry^.retransmission_count;
          p_status_response^.buffer_header.data_length_sent :=
               p_server_iocb^.length;

          { Fill in response status.
          p_status_response^.status.normal := TRUE;
          p_status_response^.status.condition := 0;

          { Fill in page I/O response.
          NEXT p_page_io_response IN p_cpu_queue_entry^.p_send_buffer;
          p_page_io_response^.segment_offset := p_server_iocb^.offset;
          p_page_io_response^.segment_length := p_server_iocb^.length;
          p_page_io_response^.global_file_name := p_fde^.global_file_name;

{ NOTE: The following statement will NOT work with sparse permanent files.

          p_page_io_response^.total_allocated_length := disk_file_descriptor_p^.highest_offset_allocated;
          { Set send buffer length in buffer header.
          p_status_response^.buffer_header.buffer_length_sent :=
               dfp$word_boundary (
                i#current_sequence_position (p_cpu_queue_entry^.p_send_buffer));

          { Setup driver_queue_entry flags for send buffer and data.
          p_driver_queue_entry^.flags := dfv$send_command_and_data_flags;

          { Set send buffer length in driver queue entry.
          p_driver_queue_entry^.send_buffer_descriptor.actual_length :=
                p_status_response^.buffer_header.buffer_length_sent;

          cpio_status := mmc$df_io_active;

      = ioc$read_from_client=

          { Setup driver_queue_entry flags for receive page data.
          p_driver_queue_entry^.flags := dfv$send_ready_for_data_flags;

          cpio_status := mmc$df_page_in_esm;

      ELSE
        display_monitor ('DF - INFORMATIVE, CLI_IO, INVALID IO_TYPE.');
        display_integer_monitor ('DF - QUEUE INDEX = ',
              io_id.queue_entry_location.queue_index);
        display_integer_monitor ('DF - QUEUE ENTRY INDEX = ',
              io_id.queue_entry_location.queue_entry_index);
        IF dfv$file_server_debug_enabled THEN
          mtp$error_stop ('DF - CLI_IO, INVALID IO_TYPE.');
        IFEND;
        display_monitor (' Timing Out File Server because io_type invalid.');
        p_queue_interface_table^.queue_directory.
              cpu_queue_pva_directory [io_id.queue_entry_location.queue_index].
              p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
        cpio_status := mmc$df_server_terminated;
        gfp$mtr_unlock_fde_p (p_fde);
        RETURN;
      CASEND;

      list_length := p_server_iocb^.length DIV osv$page_size;
      dfp$convert_list_pointer (p_cpu_queue_entry^.p_data_rma_list, p_rma_list);
      mmp$build_lock_rma_list (buffer_descriptor, p_server_iocb^.length,
          io_type, p_rma_list, list_length, m_status);

      IF m_status.normal THEN
        p_cpu_queue_entry^.data_pages_locked := TRUE;
        p_driver_queue_entry^.data_descriptor.actual_length := list_length * 8;

        { Queue request for driver.
        dfp$get_qit_p_from_direct_index (io_id.queue_entry_location.directory_index, p_queue_interface_table);
        dfp$queue_request (p_queue_interface_table, io_id.queue_entry_location.queue_index,
            io_id.queue_entry_location.queue_entry_index, queue_request_status);

        IF queue_request_status = dfc$qrs_entry_queued THEN
          { Increment read write count.
          disk_file_descriptor_p^.read_write_count := disk_file_descriptor_p^.read_write_count + 1;

        ELSE { Request buffer queue full or server terminated.}
          { Restore entry state.
          IF dfv$file_server_debug_enabled THEN
            display_monitor ('DF - REQUEST BUFFER FULL OR TERMINATED dfp$client_io ');
            display_integer_monitor (' QUEUE ', io_id.queue_entry_location.queue_index);
          IFEND;
          IF io_type = ioc$read_from_client THEN
            io_error := ioc$error_on_init;
            mmp$unlock_rma_list (ioc$read_from_client, p_rma_list, list_length, io_id, {MF_JOB_FILE} FALSE,
                  io_error, m_status);
          ELSE
            io_error := ioc$no_error;
            mmp$unlock_rma_list (ioc$no_io, p_rma_list, list_length, io_id, {MF_JOB_FILE} FALSE, io_error,
                m_status);
          IFEND;
          IF NOT m_status.normal THEN
            display_monitor ('DF - INFORMATIVE, CLI_IO, ABNORMAL STATUS FROM UNLOCK_RMA_LIST.');
            display_integer_monitor ('DF - QUEUE INDEX = ',
                  io_id.queue_entry_location.queue_index);
            display_integer_monitor ('DF - QUEUE ENTRY INDEX = ',
                  io_id.queue_entry_location.queue_entry_index);
            IF dfv$file_server_debug_enabled THEN
              mtp$error_stop ('DF - CLI_IO, ABNORMAL STATUS FROM UNLOCK_RMA_LIST.');
            IFEND;
            display_monitor (' Terminating File Server because unlock RMA list failed.');
            p_queue_interface_table^.queue_directory.
                  cpu_queue_pva_directory [io_id.queue_entry_location.queue_index].
                  p_cpu_queue^.queue_header.partner_status.terminate_partner := TRUE;
            cpio_status := mmc$df_server_terminated;
            gfp$mtr_unlock_fde_p (p_fde);
            RETURN;
          IFEND;

          p_cpu_queue_entry^.data_pages_locked := FALSE;
          p_driver_queue_entry^.data_descriptor.actual_length := 0;
          #spoil ( p_driver_queue_entry^);

          { Clear driver queue entry flags.
          p_driver_queue_entry^.flags := dfv$active_queue_entry_flags;
          #spoil ( p_driver_queue_entry^);

          IF queue_request_status = dfc$qrs_server_terminated THEN
            cpio_status := mmc$df_server_terminated;
          ELSE
            cpio_status := mmc$df_temp_reject_queue_full;
          IFEND;
        IFEND;

      ELSE {mmp$build_lock_rma_list m_status NOT normal}

        { Clear driver queue entry flags.
        p_driver_queue_entry^.flags := dfv$active_queue_entry_flags;

        cpio_status := mmc$df_pages_not_available;
      IFEND;

    gfp$mtr_unlock_fde_p (p_fde);
    #KEYPOINT (osk$exit, osk$m * $integer(cpio_status), dfk$client_io);

  PROCEND dfp$client_io;
?? TITLE := '  [XDCL] dfp$send_allocate_response', EJECT ??
{
{   This process executes on the server mainframe.  It is called to send a
{ response to the client after the request to allocate space on the server
{ has been (at least) attempted.  It will send the resulting status of the
{ server's attempt to allocate for the client.
{

  PROCEDURE [XDCL] dfp$send_allocate_response
    (    p_server_iocb: ^mmt$server_iocb_entry;
         io_id: mmt$io_identifier;
     VAR cpio_status: mmt$file_server_io_status);

    VAR
      disk_file_descriptor_p: ^dmt$disk_file_descriptor,
      p_allocate_space_response: ^dft$allocate_space_response,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_fde: gft$file_desc_entry_p,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_req_buffer_header: ^dft$buffer_header,
      p_status_response: ^dft$status_response,
      queue_request_status: dft$queue_request_status;


    gfp$mtr_get_locked_fde_p (p_server_iocb^.sfid, NIL, p_fde);
    dmp$get_disk_file_descriptor_p (p_fde, disk_file_descriptor_p);

{   Locate the driver- and cpu-queue entries.

    dfp$get_qit_p_from_direct_index (io_id.queue_entry_location.directory_index, p_queue_interface_table);
    dfp$fetch_queue_entry (p_queue_interface_table, io_id.queue_entry_location.queue_index,
          io_id.queue_entry_location.queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry);

    p_cpu_queue_entry^.io_type := ioc$no_io;
    p_cpu_queue_entry^.sfid := p_server_iocb^.sfid;


{   Build the allocate response in the send_buffer.

    RESET p_cpu_queue_entry^.p_send_buffer;

{   Fill in the response header.

    NEXT p_status_response IN p_cpu_queue_entry^.p_send_buffer;
    p_status_response^.buffer_header.version := dfc$status_buffer_version;

    RESET p_cpu_queue_entry^.p_receive_buffer;
    NEXT p_req_buffer_header IN p_cpu_queue_entry^.p_receive_buffer;

    p_status_response^.buffer_header.remote_processor := p_req_buffer_header^.remote_processor;
    p_status_response^.buffer_header.transaction_count := p_cpu_queue_entry^.transaction_count;
    p_status_response^.buffer_header.retransmission_count := p_cpu_queue_entry^.retransmission_count;
    p_status_response^.buffer_header.data_length_sent := 0;

{   Fill in the response status.

    IF p_server_iocb^.condition = dfc$null_server_condition THEN
      p_status_response^.status.normal := TRUE;
      p_status_response^.status.condition := 0;
    ELSEIF p_server_iocb^.condition = dfc$allocation_failure THEN
      p_status_response^.status.normal := FALSE;
      p_status_response^.status.condition := ioe$allocation_failure;
    ELSE
      display_monitor ('DF - INFORMATIVE, SEN_A_R, UNEXPECTED SERVER_IOCB CONDITION.');
      display_integer_monitor ('DF - QUEUE INDEX = ', io_id.queue_entry_location.queue_index);
      display_integer_monitor ('DF - QUEUE ENTRY INDEX = ', io_id.queue_entry_location.queue_entry_index);
      IF dfv$file_server_debug_enabled THEN
        mtp$error_stop ('DF - SEN_A_R, UNEXPECTED SERVER_IOCB CONDITION.');
      IFEND;
      display_monitor (' Timing Out File Server because unexpected server_iocb condition.');
      p_queue_interface_table^.queue_directory.
            cpu_queue_pva_directory [io_id.queue_entry_location.queue_index].
            p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
      cpio_status := mmc$df_server_terminated;
      gfp$mtr_unlock_fde_p (p_fde);
      RETURN;
    IFEND;

{   Fill in the allocate response.

    NEXT p_allocate_space_response IN p_cpu_queue_entry^.p_send_buffer;
    p_allocate_space_response^.segment_offset := p_server_iocb^.offset;
    p_allocate_space_response^.segment_length := p_server_iocb^.length;
    p_allocate_space_response^.global_file_name := p_fde^.global_file_name;

{ NOTE: The following statement will NOT work with sparse permanent files.

    p_allocate_space_response^.total_allocated_length := disk_file_descriptor_p^.highest_offset_allocated;

{   Set the send buffer length in the buffer header.

    p_status_response^.buffer_header.buffer_length_sent := dfp$word_boundary (i#current_sequence_position
          (p_cpu_queue_entry^.p_send_buffer));

{   Set up the driver_queue_entry flags for the send_buffer.
    p_driver_queue_entry^.flags := dfv$send_command_flags;

{   Set the send_buffer length in the driver_queue_entry.

    p_driver_queue_entry^.send_buffer_descriptor.actual_length := p_status_response^.buffer_header.
          buffer_length_sent;

{   Queue the request for the driver.

    dfp$queue_request (p_queue_interface_table, io_id.queue_entry_location.queue_index,
          io_id.queue_entry_location.queue_entry_index, queue_request_status);

    IF queue_request_status = dfc$qrs_entry_queued THEN

      cpio_status := mmc$df_io_active;

    ELSEIF queue_request_status = dfc$qrs_server_terminated THEN

      cpio_status := mmc$df_server_terminated;

    ELSE { The request_buffer queue is full.}
     IF dfv$file_server_debug_enabled THEN
       display_monitor ('DF - REQUEST BUFFER FULL dfp$send_allocate_response');
       display_integer_monitor (' QUEUE ', io_id.queue_entry_location.queue_index);
     IFEND;
{     Restore the entry state: clear the driver_queue_entry flags.
      p_driver_queue_entry^.flags := dfv$active_queue_entry_flags;
      cpio_status := mmc$df_temp_reject_queue_full;
    IFEND;
    gfp$mtr_unlock_fde_p (p_fde);

  PROCEND dfp$send_allocate_response;
?? TITLE := '  [XDCL] dfp$send_write_response', EJECT ??
{
{   This process executes on the server mainframe.  It is called to send a
{ response to the client after the data received from the client has been
{ sucessfully written to the disk.

  PROCEDURE [XDCL] dfp$send_write_response
    (    p_server_iocb: ^mmt$server_iocb_entry;
         io_id: mmt$io_identifier;
     VAR cpio_status: mmt$file_server_io_status);


    VAR
      disk_file_descriptor_p: ^dmt$disk_file_descriptor,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_fde: gft$file_desc_entry_p,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_req_buffer_header: ^dft$buffer_header,
      p_status_response: ^dft$status_response,
      p_page_io_response: ^dft$page_io_response,
      queue_request_status: dft$queue_request_status;

    #KEYPOINT (osk$entry, osk$m * io_id.queue_entry_location.
      queue_entry_index , dfk$send_write_response);

    gfp$mtr_get_locked_fde_p (p_server_iocb^.sfid, NIL, p_fde);


{ Update the EOI on the server file to the correct EOI as reflected on the client.
{ This code handles the case where the client has a larger page size than the server. If client EOI
{ is in the first half of the client page, mmp$write_page_to_disk will set the EOI to the end
{ of the client page instead of leaving it alone.

      IF (p_fde^.eoi_byte_address >= p_server_iocb^.offset + 1) AND (p_fde^.eoi_byte_address <=
            (p_server_iocb^.offset + p_server_iocb^.length + 1)) THEN
        p_fde^.flags.eoi_modified := TRUE;
        p_fde^.eoi_byte_address := p_server_iocb^.eoi;
      IFEND;

      { Locate driver and cpu queue entries.
      dfp$get_qit_p_from_direct_index (io_id.queue_entry_location.directory_index, p_queue_interface_table);
      dfp$fetch_queue_entry (p_queue_interface_table, io_id.queue_entry_location.queue_index,
          io_id.queue_entry_location.queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry);

      p_cpu_queue_entry^.io_type := ioc$no_io;
      p_cpu_queue_entry^.sfid := p_server_iocb^.sfid;

      { Build page I/O response in send_buffer.
      RESET p_cpu_queue_entry^.p_send_buffer;

      { Fill in response header.
      NEXT p_status_response IN p_cpu_queue_entry^.p_send_buffer;

      p_status_response^.buffer_header.version := dfc$status_buffer_version;

      RESET p_cpu_queue_entry^.p_receive_buffer;
      NEXT p_req_buffer_header IN p_cpu_queue_entry^.p_receive_buffer;

      p_status_response^.buffer_header.remote_processor :=
          p_req_buffer_header^.remote_processor;
      p_status_response^.buffer_header.transaction_count :=
          p_cpu_queue_entry^.transaction_count;
      p_status_response^.buffer_header.retransmission_count :=
          p_cpu_queue_entry^.retransmission_count;
      p_status_response^.buffer_header.data_length_sent := 0;

      { Fill in response status.
      p_status_response^.status.normal := TRUE;
      p_status_response^.status.condition := 0;

      { Fill in page I/O response.
      NEXT p_page_io_response IN p_cpu_queue_entry^.p_send_buffer;
      p_page_io_response^.segment_offset := p_server_iocb^.offset;
      p_page_io_response^.segment_length := p_server_iocb^.length;
      p_page_io_response^.global_file_name := p_fde^.global_file_name;

{ NOTE: The following statement will NOT work with sparse permanent files.

      dmp$get_disk_file_descriptor_p (p_fde, disk_file_descriptor_p);
      p_page_io_response^.total_allocated_length := disk_file_descriptor_p^.highest_offset_allocated;

      { Set send buffer length in buffer header.
      p_status_response^.buffer_header.buffer_length_sent := dfp$word_boundary (
          i#current_sequence_position (p_cpu_queue_entry^.p_send_buffer));

      { Setup driver_queue_entry flags for send buffer.
      p_driver_queue_entry^.flags := dfv$send_command_flags;

      { Set send buffer length in driver queue entry.
      p_driver_queue_entry^.send_buffer_descriptor.actual_length :=
          p_status_response^.buffer_header.buffer_length_sent;

      { Queue request for driver.
      dfp$queue_request (p_queue_interface_table, io_id.queue_entry_location.queue_index,
          io_id.queue_entry_location.queue_entry_index, queue_request_status);

      IF queue_request_status = dfc$qrs_entry_queued THEN
        cpio_status := mmc$df_io_active;

      ELSEIF queue_request_status = dfc$qrs_server_terminated THEN
        cpio_status := mmc$df_server_terminated;

      ELSE { Request buffer queue full.}
        IF dfv$file_server_debug_enabled THEN
          display_monitor ('DF - REQUEST BUFFER FULL dfp$send_write_response');
          display_integer_monitor (' QUEUE ', io_id.queue_entry_location.queue_index);
        IFEND;
        { Restore entry state.
        { Clear driver queue entry flags.
        p_driver_queue_entry^.flags := dfv$active_queue_entry_flags;

        cpio_status := mmc$df_temp_reject_queue_full;
      IFEND;

    gfp$mtr_unlock_fde_p (p_fde);
    #KEYPOINT (osk$exit, osk$m * $integer(cpio_status), dfk$send_write_response);

  PROCEND dfp$send_write_response;
?? TITLE := '  [XDCL] dfp$server_io', EJECT ??
{
{   This procedure executes on the client mainframe and performs the output
{ function for mmp$write_pages_to_server, and the input function for
{ mmp$read_pages_from_server. It sets up the queue_entry (specified via IO_ID)
{ so that the pages sent or requested by the client are input or output to the
{ link device by the link driver.

  PROCEDURE [XDCL] dfp$server_io
    (    fde_p: gft$locked_file_desc_entry_p;
         io_type: iot$io_function;
         segment_offset: ost$segment_offset;
         segment_length: ost$segment_length;
         io_id: mmt$io_identifier;
         buffer_descriptor: mmt$buffer_descriptor;

     VAR spio_status: syt$monitor_status);

    VAR
      assign_status: dft$assign_queue_entry_status,
      dummy_ijlo: jmt$ijl_ordinal,
      end_of_file: amt$file_byte_address,
      family_name: ost$family_name,
      index_valid: boolean,
      io_error: iot$io_error,
      list_length: mmt$rma_list_length,
      m_status: syt$monitor_status,
      p_buffer_header: ^dft$buffer_header,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_page_io_request: ^dft$page_io_request,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_rma_list: ^mmt$rma_list,
      p_server_descriptor: dft$server_descriptor_p,
      p_status_response: ^dft$status_response,
      queue_index: dft$queue_index,
      queue_entry_index: dft$queue_entry_index,
      queue_request_status: dft$queue_request_status,
      release_queue_entry_status: dft$release_queue_entry_status,
      served_mainframe_id: pmt$binary_mainframe_id,
      sfid: gft$system_file_identifier;

    #KEYPOINT (osk$entry, osk$m * $integer(io_type), dfk$server_io);

      { Locate server discriptor for file.
      dfp$get_served_file_desc_p (fde_p, p_server_descriptor);

      dfp$fetch_served_family_info (
          p_server_descriptor^.header.served_family_table_index,
          family_name, served_mainframe_id, p_queue_interface_table,
          queue_index, index_valid);

      IF NOT index_valid THEN
        display_monitor ('DF - INFORMATIVE, SER_IO, INVALID INDEX FROM FETCH_SERV_FAMILY_INFO.');
        IF dfv$file_server_debug_enabled THEN
          mtp$error_stop ('DF - SER_IO, INVALID INDEX FROM FETCH_SERV_FAMILY_INFO.');
        IFEND;
        spio_status.normal := FALSE;
        spio_status.condition := dfe$server_has_terminated;
        gfp$mtr_unlock_fde_p (fde_p);
        RETURN;

      ELSE

        IF (p_server_descriptor^.header.file_state = dfc$awaiting_recovery) THEN
          { Force a wait
          spio_status.normal := FALSE;
          spio_status.condition := ioe$unit_disabled;
          gfp$mtr_unlock_fde_p (fde_p);
          RETURN;
        IFEND;

        dfp$assign_queue_entry ( p_queue_interface_table, queue_index,
            dfc$monitor, queue_entry_index, assign_status);

        IF assign_status <> dfc$aqes_entry_assigned THEN
          spio_status.normal := FALSE;
          IF assign_status = dfc$aqes_server_terminated THEN
            dfp$set_terminated_mtr_status (p_queue_interface_table, queue_index,
                 spio_status);
          ELSE
            spio_status.condition := dme$transient_error;
          IFEND;

        ELSE { queue entry assigned }
          { Locate driver and cpu queue entries.
          dfp$fetch_queue_entry (p_queue_interface_table, queue_index,
             queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry);

          { Build request package in send_buffer.
          RESET p_cpu_queue_entry^.p_send_buffer;
          NEXT p_buffer_header IN p_cpu_queue_entry^.p_send_buffer;

          { Fill in request header.
          p_buffer_header^.version := dfc$page_io_req;
          p_buffer_header^.transaction_count := p_cpu_queue_entry^.
             transaction_count + 1;  {increment in Q entry when request queued.
          p_buffer_header^.retransmission_count := 0;

          p_cpu_queue_entry^.retransmission_count := 0;

          CASE io_type OF
          = ioc$read_page =
            p_buffer_header^.remote_processor := dfc$read_pages;
            p_buffer_header^.data_length_sent := 0;
            p_driver_queue_entry^.flags := dfv$send_command_flags;

          = ioc$write_page =
            p_buffer_header^.remote_processor := dfc$write_pages;
            p_buffer_header^.data_length_sent := segment_length;
            p_driver_queue_entry^.flags := dfv$send_command_and_data_flags;


          ELSE
            mtp$error_stop ('DF - SER_IO, INVALID IO_TYPE.');
          CASEND;

          NEXT p_page_io_request IN p_cpu_queue_entry^.p_send_buffer;

          { Fill in page I/O request
          gfp$mtr_get_sfid_from_fde_p (fde_p, sfid, dummy_ijlo);
          p_page_io_request^.segment_offset := segment_offset;
          p_page_io_request^.segment_length := segment_length;
          dfp$uncomplement_gfn (fde_p^.global_file_name,
              p_page_io_request^.global_file_name);
          p_page_io_request^.eoi_byte_address := fde_p^.eoi_byte_address;
          p_page_io_request^.remote_sfid := p_server_descriptor^.header.
              remote_sfid;

          { Set send buffer length in buffer header.
          p_buffer_header^.buffer_length_sent := dfp$word_boundary (
          i#current_sequence_position (p_cpu_queue_entry^.p_send_buffer));

          { Set fields in cpu queue entry.
          p_cpu_queue_entry^.io_id := io_id;
          p_cpu_queue_entry^.io_type := io_type;
          p_cpu_queue_entry^.sfid := sfid;

          { Set send buffer length in driver queue entry.
          p_driver_queue_entry^.send_buffer_descriptor.actual_length :=
             p_buffer_header^.buffer_length_sent;

          { Lock data pages.
          { Set list length in CM words.
          list_length := segment_length DIV osv$page_size;

          dfp$convert_list_pointer (p_cpu_queue_entry^.p_data_rma_list, p_rma_list);

          mmp$build_lock_rma_list (buffer_descriptor, segment_length, io_type,
             p_rma_list, list_length, m_status);

          IF m_status.normal THEN

            p_cpu_queue_entry^.data_pages_locked := TRUE;

            { Set indirect list length in bytes for driver.
            p_driver_queue_entry^.data_descriptor.actual_length :=
               list_length * 8;

            { Queue request for driver.
            dfp$queue_request (p_queue_interface_table, queue_index,
               queue_entry_index, queue_request_status);

            IF queue_request_status = dfc$qrs_entry_queued THEN

              { increment read write count, and transaction_count.
              p_server_descriptor^.header.read_write_count := p_server_descriptor^.header.read_write_count
                    + 1;
              p_cpu_queue_entry^.transaction_count :=
                  p_cpu_queue_entry^.transaction_count + 1;

              spio_status.normal := TRUE;
              spio_status.condition := 0;

            ELSE { Request buffer queue full or server terminated.}
              IF dfv$file_server_debug_enabled THEN
                display_monitor ('DF - REQUEST BUFFER FULL OR TERMINATED dfp$server_io');
               display_integer_monitor (' QUEUE ',
                    io_id.queue_entry_location.queue_index);
              IFEND;
              { Restore entry state.
              io_error := ioc$no_error;
              mmp$unlock_rma_list (ioc$no_io, p_rma_list, list_length, io_id,
                  {MF_JOB_FILE} FALSE, io_error, m_status);
              IF NOT m_status.normal THEN
                display_monitor ('DF - INFORMATIVE, SER_IO, ABNORMAL STATUS FROM UNLOC_RMA_LIST.');
                display_integer_monitor ('DF - QUEUE INDEX = ', queue_index);
                display_integer_monitor ('DF - QUEUE ENTRY INDEX = ', queue_entry_index);
                IF dfv$file_server_debug_enabled THEN
                  mtp$error_stop ('DF - SER_IO, ABNORMAL STATUS FROM UNLOC_RMA_LIST.');
                IFEND;
                display_monitor (' Terminating File Server because unlock RMA list failed.');
                p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
                     p_cpu_queue^.queue_header.partner_status.terminate_partner := TRUE;
                spio_status.normal := FALSE;
                spio_status.condition  := dfe$server_has_terminated;
                gfp$mtr_unlock_fde_p (fde_p);
                RETURN;
              IFEND;

              p_driver_queue_entry^.flags := dfv$active_queue_entry_flags;
              dfp$release_queue_entry (p_queue_interface_table, queue_index,
                  queue_entry_index, release_queue_entry_status);
              IF release_queue_entry_status <> dfc$rqes_entry_released THEN
                display_monitor ('DF - INFORMATIVE, SER_IO, UNABLE TO RELEASE QUEUE ENTRY.');
                display_integer_monitor ('DF - QUEUE INDEX = ', queue_index);
                display_integer_monitor ('DF - QUEUE ENTRY INDEX = ', queue_entry_index);
                IF dfv$file_server_debug_enabled THEN
                  mtp$error_stop ('DF - SER_IO, UNABLE TO RELEASE QUEUE ENTRY.');
                IFEND;
                display_monitor (' Timing Out File Server because release QE failed.');
                p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
                     p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
                spio_status.normal := FALSE;
                spio_status.condition  := dfe$server_has_terminated;
                gfp$mtr_unlock_fde_p (fde_p);
                RETURN;
              IFEND;

              spio_status.normal := FALSE;
              IF queue_request_status = dfc$qrs_server_terminated THEN
                spio_status.condition := dfe$server_has_terminated;
              ELSE
                spio_status.condition := dme$transient_error;
              IFEND;

            IFEND; {queue request status}

          ELSE {mmp$build_lock_rma_list m_status NOT normal}

            display_monitor ('DF - INFORMATIVE, SER_IO, ABNORMAL STATUS FROM BUILD_LOCK_RMA_LIST.');
            display_integer_monitor ('DF - QUEUE INDEX = ', queue_index);
            display_integer_monitor ('DF - QUEUE ENTRY INDEX = ', queue_entry_index);
            IF dfv$file_server_debug_enabled THEN
              mtp$error_stop ('DF - SER_IO, ABNORMAL STATUS FROM BUILD_LOCK_RMA_LIST.');
            IFEND;
            display_monitor (' Terminating File Server because build lock RMA list failed.');
            p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
                 p_cpu_queue^.queue_header.partner_status.terminate_partner := TRUE;
            spio_status.normal := FALSE;
            spio_status.condition  := dfe$server_has_terminated;
            gfp$mtr_unlock_fde_p (fde_p);
            RETURN;

          IFEND; {build lock rma list status}

        IFEND; { assign queue entry }

      IFEND; { index_valid }

    gfp$mtr_unlock_fde_p (fde_p);
    #KEYPOINT (osk$exit, osk$m * $integer(spio_status.normal), dfk$server_io)

  PROCEND dfp$server_io;
?? OLDTITLE, OLDTITLE ??
MODEND dfm$file_server_page_io;
*DECK DECK=DFM$FILE_SERVER_PP_MGNT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File Server: file_server_pp_mgnt', EJECT ??
MODULE dfm$file_server_pp_mgnt;
{
{  This module contains procedures which provide for control of
{  the File Server ESM PP driver.
{
?? NEWTITLE := '    Global Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmt$pp_program_description
*copyc dfc$iou_names
*copyc dfd$driver_queue_types
*copyc dft$esm_definition_table
*copyc dft$pp_element_reservations
*copyc dft$queue_interface_directory
*copyc dft$request_buffer
*copyc pmt$mainframe_id
?? POP ??
*copyc dfe$error_condition_codes
*copyc dfv$one_word_response_handler
*copyc dfv$p_queue_interface_directory
*copyc dfv$server_wired_heap
*copyc osv$page_size
*copyc cmp$execute_pp_program
*copyc cmp$get_channel_definition
*copyc cmp$get_element_definition
*copyc cmp$get_iou_definition
*copyc cmp$get_logical_pp_index
*copyc cmp$idle_pp
*copyc cmp$pc_get_element
*copyc cmp$release_element
*copyc cmp$reserve_element
*copyc cmp$resume_pp
*copyc dfp$active_queue_exists
*copyc cmp$store_file_server_info
*copyc dfp$convert_p_qit_to_io_request
*copyc dfp$locate_esm_definition
*copyc dfp$verify_esm_product_id
*copyc osp$append_status_parameter
*copyc osp$clear_signature_lock
*copyc osp$set_signature_lock
*copyc osp$set_status_abnormal
*copyc pmp$get_mainframe_id
*copyc pmp$long_term_wait
*copyc pmp$zero_out_table
?? TITLE := '    Inline Procedures ', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfi$display
?? POP ??

?? TITLE := ' [XDCL]  dfp$activate_pp ', EJECT ??
{    This procedure brings the file server's ESM PP driver to a state
{    of readiness to process file server requests.
{    The PP and channel elements will be reserved; the PP will be loaded
{    and executed; the pointer to the file server queue interface table
{    will be stored into the next unit request pointer word of the PP
{    interface table (PIT), and, since the PP driver initializes itself
{    as idle, a resume PP request will be queued to the PP.
{
{    DFP$ACTIVATE_PP (P_Q_INTERFACE_DIRECTORY_ENTRY, USE_DMA, STATUS)
{
{    P_Q_INTERFACE_DIRECTORY_ENTRY: (input) This parameter is a pointer to
{      queue_interface_directory entry of the ESM connection to be activated.
{
{    USE_DMA: (input) This parameter, if true, specifies that the PP driver
{      is to utilize the DMA capability of the channel if that capability
{      is available. If false or the channel does not have DMA capability
{      the PP will move data through PP memory to/from the channel.
{
{    STATUS: (output) This is ost$status which indicates success or failure
{      of the activation procedure.


  PROCEDURE [XDCL] dfp$activate_pp
    (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
         use_dma: boolean;
     VAR status: ost$status);


    VAR
      ignore_status: ost$status,
      iou_definition: cmt$iou_definition,
      iou_name: cmt$element_name,
      p_io_request: ^iot$io_request;

    IF p_q_interface_directory_entry^.connection_type <> dfc$esm_connection THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$not_stornet_connection,
            p_q_interface_directory_entry^.driver_name, status);
      RETURN;
    IFEND;

    { Insure PP(s) are loaded to establish IOU tables (PIT etc.)
    dfp$load_pp (p_q_interface_directory_entry, status);
    IF NOT status.normal THEN
      dfp$unload_pp (p_q_interface_directory_entry, ignore_status);
      RETURN;
    IFEND;

    { Activate the send PP.
    p_q_interface_directory_entry^.p_queue_interface_table^.queue_directory.dma_adapter.
          use_on_send_channel := (p_q_interface_directory_entry^.send_pp.dma_capability) AND (use_dma);
    p_q_interface_directory_entry^.p_queue_interface_table^.queue_directory.dma_adapter.
          use_on_recv_channel := (p_q_interface_directory_entry^.receive_pp.dma_capability) AND (use_dma);

    dfp$convert_p_qit_to_io_request (p_q_interface_directory_entry^.p_queue_interface_table, p_io_request);
    cmp$store_file_server_info (p_q_interface_directory_entry^.p_queue_interface_table^.
         queue_directory.send_pp_number, p_io_request, {one word response allowed = } TRUE,
         dfv$one_word_response_handler, status);
    IF status.normal THEN
      p_q_interface_directory_entry^.send_pp.pp_status.activated := TRUE;

      IF p_q_interface_directory_entry^.send_channel <> p_q_interface_directory_entry^.receive_channel THEN
        { Activate the receive PP.
         cmp$store_file_server_info (p_q_interface_directory_entry^.p_queue_interface_table^.
              queue_directory.receive_pp_number, p_io_request, {one word response allowed = } TRUE,
              dfv$one_word_response_handler, status);
        IF status.normal THEN
          p_q_interface_directory_entry^.receive_pp.pp_status.activated := TRUE;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
{   This code is needed for CYBER 930.
      iou_name := dfc$iou_name0;
      cmp$get_iou_definition (iou_name, iou_definition, status);
      p_q_interface_directory_entry^.p_queue_interface_table^.queue_directory.dma_adapter.iou_i0_model :=
            (iou_definition.kind = dsc$imn_i0_5x_model);
    IFEND;

    IF status.normal THEN
      p_q_interface_directory_entry^.driver_active := TRUE;
      dfp$resume_pp (p_q_interface_directory_entry, status);
    IFEND;

  PROCEND dfp$activate_pp;

?? TITLE := ' [XDCL]  dfp$change_pp ', EJECT ??
{    This procedure changes the file servers ESM connection element name
{    in the queue interface directory table. The PP(s) must be inactive/unloaded
{    before this process will allow the change.
{
{    DFP$CHANGE_PP (P_Q_INTERFACE_DIRECTORY_ENTRY, NEW_NAME, PP_TASK, STATUS)
{
{    P_Q_INTERFACE_DIRECTORY_ENTRY: (input) This parameter is a pointer to
{      queue_interface_directory entry of the ESM connection to be changed.
{
{    NEW_NAME: (input) This parameter specifies the new ESM element name.
{
{    PP_TASK: (input) This parameter specifies the task the PP performs on
{      behalf of the connection.
{      SEND, PP processes file server request from the request buffer.
{  ==> RECEIVE, PP process file server requests queue in ESM flag registers.
{  ==> BOTH, PP performs both send and receive processing.
{
{    STATUS: (output) This is ost$status which indicates success or failure
{      of this procedure.
{

  PROCEDURE [XDCL] dfp$change_pp
    (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
         new_name: cmt$element_name;
         pp_task: ost$name;
     VAR status: ost$status);


    IF p_q_interface_directory_entry^.connection_type <> dfc$esm_connection THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$not_stornet_connection,
            p_q_interface_directory_entry^.driver_name, status);
      RETURN;
    IFEND;
    dfp$verify_element_name (new_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (p_q_interface_directory_entry^.send_pp.p_element_reservations = NIL) AND
          (NOT p_q_interface_directory_entry^.send_pp.pp_status.activated) THEN
      IF (pp_task = 'SEND') OR (pp_task = 'BOTH') THEN
        p_q_interface_directory_entry^.element_name := new_name;
      IFEND;
      IF (pp_task = 'RECEIVE') THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$connection_not_changed,
             p_q_interface_directory_entry^.element_name, status);
      IFEND;
    ELSE
      osp$set_status_abnormal (dfc$file_server_id, dfe$connection_not_changed,
            p_q_interface_directory_entry^.element_name, status);
    IFEND;

  PROCEND dfp$change_pp;
?? TITLE := ' [XDCL]  dfp$idle_pp ', EJECT ??
{    This procedure causes an idle PP request to be issued to the file server's
{    ESM PP(s). The PP(s) must be active and not already idle before an idle
{    request will be issued.
{
{    DFP$IDLE_PP (P_Q_INTERFACE_DIRECTORY_ENTRY, STATUS)
{
{    P_Q_INTERFACE_DIRECTORY_ENTRY: (input) This parameter is a pointer to
{      queue_interface_directory entry of the ESM connection to be idled.
{
{    STATUS: (output) This is ost$status which indicates success or failure
{      of this procedure.
{

  PROCEDURE [XDCL] dfp$idle_pp
    (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
     VAR status: ost$status);

    VAR
      pp_memory_length: cmt$pp_memory_length,
      pp_registers: cmt$pp_registers,
      soft_idled: boolean;


    IF p_q_interface_directory_entry^.connection_type <> dfc$esm_connection THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$not_stornet_connection,
            p_q_interface_directory_entry^.driver_name, status);
      RETURN;
    IFEND;

    IF (p_q_interface_directory_entry^.send_pp.p_element_reservations <> NIL) AND
          (NOT p_q_interface_directory_entry^.send_pp.pp_status.idled) THEN
      IF p_q_interface_directory_entry^.send_pp.pp_status.activated THEN
        cmp$idle_pp (p_q_interface_directory_entry^.send_pp.p_element_reservations^ [1].pp_reservation.
              acquired_pp_identification, FALSE {break_interlocks} , FALSE {hard idle} ,
              NIL {pp_memory_area} , pp_memory_length, pp_registers, soft_idled, status);
        p_q_interface_directory_entry^.send_pp.pp_status.idled := (status.normal) AND (soft_idled);
      IFEND;
    IFEND;
    IF status.normal THEN
      IF p_q_interface_directory_entry^.send_channel <> p_q_interface_directory_entry^.receive_channel THEN
        IF (p_q_interface_directory_entry^.receive_pp.p_element_reservations <> NIL) AND
              (NOT p_q_interface_directory_entry^.receive_pp.pp_status.idled) THEN
          IF p_q_interface_directory_entry^.receive_pp.pp_status.activated THEN
            cmp$idle_pp (p_q_interface_directory_entry^.receive_pp.p_element_reservations^ [1].pp_reservation.
                  acquired_pp_identification, FALSE {break_interlocks} , FALSE {hard idle} , NIL
                  {pp_memory_area} , pp_memory_length, pp_registers, soft_idled, status);
            p_q_interface_directory_entry^.receive_pp.pp_status.idled := (status.normal) AND (soft_idled);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND dfp$idle_pp;

?? TITLE := ' [XDCL]  dfp$load_pp ', EJECT ??
{    This procedure provides for the hardware reservation and loading of the
{    driver into PP(s) which will service the file server connection when
{    activated. This procedure does not activate the PP(s).
{
{    DFP$LOAD_PP (P_Q_INTERFACE_DIRECTORY_ENTRY, STATUS)
{
{    P_Q_INTERFACE_DIRECTORY_ENTRY: (input) This parameter is a pointer to
{      queue_interface_directory entry of the ESM connection to be loaded.
{
{    STATUS: (output) This is ost$status which indicates success or failure
{      of this procedure.
{

  PROCEDURE [XDCL] dfp$load_pp
    (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
     VAR status: ost$status);


    IF p_q_interface_directory_entry^.connection_type <> dfc$esm_connection THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$not_stornet_connection,
            p_q_interface_directory_entry^.driver_name, status);
      RETURN;
    IFEND;

    { Insure PP and channel elements are reserved.
    IF p_q_interface_directory_entry^.send_pp.p_element_reservations = NIL THEN
      { Reserve send ESM element and PP.
      reserve_esm_element (p_q_interface_directory_entry^.element_name,
            p_q_interface_directory_entry^.send_channel,
            p_q_interface_directory_entry^.send_pp.p_element_reservations,
            p_q_interface_directory_entry^.send_pp.channel_address,
            p_q_interface_directory_entry^.send_pp.dma_capability, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      { Incase only one channel make receive same as send dma capability.
      p_q_interface_directory_entry^.receive_pp.dma_capability :=
            p_q_interface_directory_entry^.send_pp.dma_capability;
    IFEND;

    IF p_q_interface_directory_entry^.receive_channel <> p_q_interface_directory_entry^.send_channel THEN
      IF p_q_interface_directory_entry^.receive_pp.p_element_reservations = NIL THEN
        { Reserve receive ESM element and PP.
        reserve_esm_element (p_q_interface_directory_entry^.element_name,
              p_q_interface_directory_entry^.receive_channel,
              p_q_interface_directory_entry^.receive_pp.p_element_reservations,
              p_q_interface_directory_entry^.receive_pp.channel_address,
              p_q_interface_directory_entry^.receive_pp.dma_capability, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    { IF the send and receive channels are different then two PPs are loaded.

    IF NOT p_q_interface_directory_entry^.send_pp.pp_status.loaded THEN
      load_and_execute (p_q_interface_directory_entry^.send_pp.channel_address,
            p_q_interface_directory_entry^.send_channel,
            p_q_interface_directory_entry^.send_pp.p_element_reservations,
            p_q_interface_directory_entry^.p_queue_interface_table^.queue_directory.send_pp_number, status);
      IF status.normal THEN
        p_q_interface_directory_entry^.send_pp.pp_status.activated := FALSE;
        p_q_interface_directory_entry^.send_pp.pp_status.loaded := TRUE;
        p_q_interface_directory_entry^.send_pp.pp_status.idled := TRUE;

      ELSE
        RETURN;
      IFEND;
      IF p_q_interface_directory_entry^.receive_channel = p_q_interface_directory_entry^.send_channel THEN
        p_q_interface_directory_entry^.p_queue_interface_table^.queue_directory.receive_pp_number :=
              p_q_interface_directory_entry^.p_queue_interface_table^.queue_directory.send_pp_number;
      IFEND;
    IFEND;

    IF p_q_interface_directory_entry^.receive_channel <> p_q_interface_directory_entry^.send_channel THEN
      IF NOT p_q_interface_directory_entry^.receive_pp.pp_status.loaded THEN
        load_and_execute (p_q_interface_directory_entry^.receive_pp.channel_address,
              p_q_interface_directory_entry^.receive_channel,
              p_q_interface_directory_entry^.receive_pp.p_element_reservations,
              p_q_interface_directory_entry^.p_queue_interface_table^.queue_directory.receive_pp_number,
              status);
        IF status.normal THEN
          p_q_interface_directory_entry^.receive_pp.pp_status.activated := FALSE;
          p_q_interface_directory_entry^.receive_pp.pp_status.loaded := TRUE;
          p_q_interface_directory_entry^.receive_pp.pp_status.idled := TRUE;

        ELSE
          RETURN;
        IFEND;
      IFEND;
    IFEND;
  PROCEND dfp$load_pp;

?? TITLE := ' [XDCL]  dfp$load_pp_if_first ', EJECT ??
{    This procedure provides for requesting the loading (activating) of
{    the PP driver if all queues of the associated queue interface table are
{    idle. A signature lock is used here in order to prevent two processes
{    from requesting loading at approximately the same time  (that is, loading
{    is initiated but before appropriate flags are set another process
{    initiates the loading also).
{
{    DFP$LOAD_PP_IF_FIRST (P_Q_INTERFACE_DIRECTORY_ENTRY, QUEUE_INDEX, STATUS)
{
{    P_Q_INTERFACE_DIRECTORY_ENTRY: (input) This parameter is a pointer to
{      queue_interface_directory entry of the ESM connection to be loaded.
{
{    QUEUE_INDEX: (input) This parameter specifies the index of the queue which
{      is being activated.
{
{    STATUS: (output) This is ost$status which indicates success or failure
{      of this procedure.
{

  PROCEDURE [XDCL] dfp$load_pp_if_first
    (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
         queue_index: dft$queue_index;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      other_queue_active: boolean,
      p_driver_queue: ^dft$driver_queue,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_request_buffer_directory: ^dft$request_buffer_directory;

    status.normal := TRUE;

    p_queue_interface_table := p_q_interface_directory_entry^.p_queue_interface_table;
    p_driver_queue := p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue;

    osp$set_signature_lock (p_q_interface_directory_entry^.load_unload_pp_lock, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    other_queue_active := dfp$active_queue_exists (p_queue_interface_table);
    p_driver_queue^.queue_header.flags.idle := FALSE;
    IF NOT other_queue_active THEN
      {Initialization of request_buffer_directory should be a call to a procedure in queue_initialization
      p_request_buffer_directory := ^p_queue_interface_table^.request_buffer_directory;
      pmp$zero_out_table (p_request_buffer_directory^.p_request_buffer, #SIZE (
            p_request_buffer_directory^.p_request_buffer^));
      p_request_buffer_directory^.inn := 0;
      p_request_buffer_directory^.out := 0;
      dfp$activate_pp (p_q_interface_directory_entry, p_q_interface_directory_entry^.use_dma, status);
    IFEND;

    osp$clear_signature_lock (p_q_interface_directory_entry^.load_unload_pp_lock, ignore_status);

  PROCEND dfp$load_pp_if_first;

?? TITLE := ' [XDCL]  dfp$resume_pp ', EJECT ??
{    This procedure causes a resume PP request to be issued to the file server's
{    ESM PP(s). The PP(s) must be active and idle before a resume request will
{    be issued.
{
{    DFP$RESUME_PP (P_Q_INTERFACE_DIRECTORY_ENTRY, STATUS)
{
{    P_Q_INTERFACE_DIRECTORY_ENTRY: (input) This parameter is a pointer to
{      queue_interface_directory entry of the ESM connection to be resumed.
{
{    STATUS: (output) This is ost$status which indicates success or failure
{      of this procedure.
{

  PROCEDURE [XDCL] dfp$resume_pp
    (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
     VAR status: ost$status);


    VAR
      pp_registers: cmt$pp_registers,
      start_address: cmt$pp_memory_length,
      soft_resumed: boolean;



    status.normal := TRUE;

    IF p_q_interface_directory_entry^.connection_type <> dfc$esm_connection THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$not_stornet_connection,
            p_q_interface_directory_entry^.driver_name, status);
      RETURN;
    IFEND;

    { If the send and receive element names are different, then each
    { of the PPs will be resumed.

    IF (p_q_interface_directory_entry^.send_pp.p_element_reservations <> NIL) AND
          (p_q_interface_directory_entry^.send_pp.pp_status.activated) AND
          (p_q_interface_directory_entry^.send_pp.pp_status.idled) THEN
      cmp$resume_pp (p_q_interface_directory_entry^.send_pp.p_element_reservations^ [1].pp_reservation.
            acquired_pp_identification, FALSE {hardware resume} , start_address, soft_resumed, status);

      p_q_interface_directory_entry^.send_pp.pp_status.idled := NOT ((status.normal) AND (soft_resumed));
      IF NOT soft_resumed THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$path_to_stornet_broken,
              p_q_interface_directory_entry^.element_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              p_q_interface_directory_entry^.send_channel.iou_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              p_q_interface_directory_entry^.send_channel.channel_name, status);
        RETURN;
      IFEND;
    IFEND;

    IF status.normal THEN
      IF p_q_interface_directory_entry^.send_channel <> p_q_interface_directory_entry^.receive_channel THEN
        IF (p_q_interface_directory_entry^.receive_pp.p_element_reservations <> NIL) AND
              (p_q_interface_directory_entry^.receive_pp.pp_status.activated) AND
              (p_q_interface_directory_entry^.receive_pp.pp_status.loaded) THEN
          cmp$resume_pp (p_q_interface_directory_entry^.receive_pp.p_element_reservations^ [1].pp_reservation.
                acquired_pp_identification, FALSE {hardware resume} , start_address, soft_resumed, status);
          p_q_interface_directory_entry^.receive_pp.pp_status.idled :=
                NOT ((status.normal) AND (soft_resumed));
          IF NOT soft_resumed THEN
            osp$set_status_abnormal (dfc$file_server_id, dfe$path_to_stornet_broken,
                  p_q_interface_directory_entry^.element_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  p_q_interface_directory_entry^.receive_channel.iou_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  p_q_interface_directory_entry^.receive_channel.channel_name, status);
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND dfp$resume_pp;


?? TITLE := ' [XDCL]  dfp$set_esm_divisions ', EJECT ??
{    This procedure provides for setting the number of ESM memory subdivisions.
{
{    DFP$SET_ESM_DIVISIONS (P_Q_INTERFACE_DIRECTORY_ENTRY, NUMBER_OF_DIVISIONS, STATUS)
{
{    P_Q_INTERFACE_DIRECTORY_ENTRY: (input) This parameter is a pointer to
{      queue_interface_directory entry of the ESM connection for which the
{      number of divisions is to be changed.
{
{    NUMBER_OF_DIVISIONS: (input) specifies ESM memory divisions per mainframe
{      (number of subdivisions the block of ESM memory allocated to each
{       mainframe is to be divided into).
{
{    STATUS: (output) This is ost$status which indicates success or failure
{      of this procedure.
{

  PROCEDURE [XDCL] dfp$set_esm_divisions
    (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
         number_of_divisions: dft$divisions_per_mainframe;
     VAR status: ost$status);



    IF p_q_interface_directory_entry^.connection_type <> dfc$esm_connection THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$not_stornet_connection,
            p_q_interface_directory_entry^.driver_name, status);

    ELSE
      p_q_interface_directory_entry^.p_queue_interface_table^.esm_base_addresses.divisions_per_mainframe :=
            number_of_divisions;
      status.normal := TRUE;

    IFEND;

  PROCEND dfp$set_esm_divisions;

?? TITLE := ' [XDCL]  dfp$unload_pp ', EJECT ??
{    This procedure brings the file server's ESM PP driver to an inactive
{    state. An idle PP request is issued to the PP(s), and the PP and channel
{    element reservations are released.
{
{    DFP$UNLOAD_PP (P_Q_INTERFACE_DIRECTORY_ENTRY, STATUS)
{
{    P_Q_INTERFACE_DIRECTORY_ENTRY: (input) This parameter is a pointer to
{      queue_interface_directory entry of the ESM connection to be unloaded.
{
{    STATUS: (output) This is ost$status which indicates success or failure
{      of the unload PP procedure.


  PROCEDURE [XDCL] dfp$unload_pp
    (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      p_esm_def_table_entry: ^dft$esm_definition_table_entry,
      pp_registers: cmt$pp_registers,
      start_address: cmt$pp_memory_length;

    status.normal := TRUE;

    IF p_q_interface_directory_entry^.connection_type <> dfc$esm_connection THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$not_stornet_connection,
            p_q_interface_directory_entry^.driver_name, status);
      RETURN;
    IFEND;

    dfp$locate_esm_definition (p_q_interface_directory_entry^.element_name, p_esm_def_table_entry);
    IF p_esm_def_table_entry = NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$stornet_not_defined,
            p_q_interface_directory_entry^.element_name, status);
      RETURN;
    IFEND;

    IF p_q_interface_directory_entry^.send_pp.p_element_reservations <> NIL THEN
      IF NOT p_q_interface_directory_entry^.send_pp.pp_status.idled THEN
        { soft idle PPs, cmp$release_element will issue hard idle.
        dfp$idle_pp (p_q_interface_directory_entry, ignore_status);
      IFEND;
      { Return the reserved elements.}
      cmp$release_element (p_q_interface_directory_entry^.send_pp.p_element_reservations^, status);
      IF status.normal THEN
        mark_unload (p_q_interface_directory_entry, p_q_interface_directory_entry^.send_channel);
        FREE p_q_interface_directory_entry^.send_pp.p_element_reservations IN dfv$server_wired_heap^;
        IF p_esm_def_table_entry^.number_of_pps_using_esm <> 0 THEN
          p_esm_def_table_entry^.number_of_pps_using_esm := p_esm_def_table_entry^.
               number_of_pps_using_esm - 1;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      IF p_q_interface_directory_entry^.send_channel <> p_q_interface_directory_entry^.receive_channel THEN
        IF p_q_interface_directory_entry^.receive_pp.p_element_reservations <> NIL THEN
          IF NOT p_q_interface_directory_entry^.send_pp.pp_status.idled THEN
            { soft idle PPs, cmp$release_element will issue hard idle.
            dfp$idle_pp (p_q_interface_directory_entry, ignore_status);
          IFEND;
          { Return the reserved receive elements.}
          cmp$release_element (p_q_interface_directory_entry^.receive_pp.p_element_reservations^, status);
          IF status.normal THEN
            mark_unload (p_q_interface_directory_entry, p_q_interface_directory_entry^.receive_channel);
            FREE p_q_interface_directory_entry^.receive_pp.p_element_reservations IN dfv$server_wired_heap^;
            IF p_esm_def_table_entry^.number_of_pps_using_esm <> 0 THEN
              p_esm_def_table_entry^.number_of_pps_using_esm := p_esm_def_table_entry^.
                   number_of_pps_using_esm - 1;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF p_esm_def_table_entry^.number_of_pps_using_esm = 0 THEN
      IF p_esm_def_table_entry^.p_element_reservation <> NIL THEN
{       Return the reserved ESM device.
        cmp$release_element (p_esm_def_table_entry^.p_element_reservation^, status);
        IF status.normal THEN
          FREE p_esm_def_table_entry^.p_element_reservation IN dfv$server_wired_heap^;
        IFEND;
      IFEND;
    IFEND;
  PROCEND dfp$unload_pp;
?? TITLE := '  [XDCL] dfp$unload_pp_if_last', EJECT ??
{    This procedure provides for requesting the unloading of the PP driver
{    if all the queues of the associated queue interface table are idle. A
{    signature lock is used here in order to prevent two processes from
{    requesting unloading at approximately the same time.
{
{    DFP$UNLOAD_PP_IF_LAST (P_Q_INTERFACE_DIRECTORY_ENTRY, QUEUE_INDEX, STATUS)
{
{    P_Q_INTERFACE_DIRECTORY_ENTRY: (input) This parameter is a pointer to
{      queue_interface_directory entry of the ESM connection to be unloaded.
{
{    QUEUE_INDEX: (input) This parameter specifies the index of the queue which
{      is being deactivated.
{
{    STATUS: (output) This is ost$status which indicates success or failure
{      of the unload PP procedure.


  PROCEDURE [XDCL] dfp$unload_pp_if_last
    (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
         queue_index: dft$queue_index;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      p_queue_interface_table: dft$p_queue_interface_table;

    status.normal := TRUE;

    p_queue_interface_table := p_q_interface_directory_entry^.p_queue_interface_table;

    IF NOT p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue^.
          queue_header.flags.idle THEN
      p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue^.
            queue_header.flags.idle := TRUE;
{Delay since at present the PP does not acknowledge the idle request set by caller.
      pmp$long_term_wait (2000, 2000);
    IFEND;

{Check for any active queues.

    osp$set_signature_lock (p_q_interface_directory_entry^.load_unload_pp_lock, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT dfp$active_queue_exists (p_queue_interface_table) THEN
      dfp$unload_pp (p_q_interface_directory_entry, status);
    IFEND;

    osp$clear_signature_lock (p_q_interface_directory_entry^.load_unload_pp_lock, ignore_status);

  PROCEND dfp$unload_pp_if_last;

?? TITLE := ' [XDCL] dfp$verify_element_name ', EJECT ??
{    This procedure verifies that the specified element name belongs to
{    an element assigned an ESM product id.
{
{    DFP$VERIFY_ELEMENT_NAME (ELEMENT_NAME, STATUS)
{
{    ELEMENT_NAME: (input) This parameter is the element name to be verified.
{
{    STATUS: (output) This is ost$status which indicates success or failure
{      of this procedure.
{

  PROCEDURE [XDCL] dfp$verify_element_name
    (    element_name: cmt$element_name;
     VAR status: ost$status);

    VAR
      element_definition: cmt$element_definition,
      element_descriptor: cmt$element_descriptor;


    element_descriptor.element_type := cmc$communications_element;
    element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
    element_descriptor.peripheral_descriptor.element_name := element_name;

    cmp$get_element_definition (element_descriptor, element_definition, status);
    IF status.normal THEN
      { Verify that the specified element is the ESM product.
      dfp$verify_esm_product_id (element_definition.product_id, status);
    IFEND;

  PROCEND dfp$verify_element_name;

?? TITLE := '    [XDCL] dfp$verify_stornet_channel ', EJECT ??
  PROCEDURE [XDCL] dfp$verify_stornet_channel
    (    esm_element_name: cmt$element_name;
         channel: dft$channel_specification;
     VAR status: ost$status);

    VAR
      element_definition: cmt$element_definition,
      element_descriptor: cmt$element_descriptor,
      found: boolean,
      mainframe_id: pmt$mainframe_id,
      port_number: cmt$communications_port_number;


    status.normal := TRUE;
    pmp$get_mainframe_id (mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Get ESM element_descriptor.
    element_descriptor.element_type := cmc$communications_element;
    element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
    element_descriptor.peripheral_descriptor.element_name := esm_element_name;
    cmp$get_element_definition (element_descriptor, element_definition, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Verify that the specified element is the ESM product.
    dfp$verify_esm_product_id (element_definition.product_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Find channel in ESM element_definition.
    found := FALSE;
  /find_channel/
    FOR port_number := LOWERVALUE (cmt$communications_port_number)
          TO UPPERVALUE (cmt$communications_port_number) DO
      IF element_definition.communications_element.connection.port [port_number].configured THEN
        IF ((channel.channel_name = element_definition.communications_element.connection.port [port_number].
              element_name) AND
            (channel.iou_name = element_definition.communications_element.connection.port [port_number].
              iou) AND
            (mainframe_id = element_definition.communications_element.connection.port [port_number].
              mainframe_ownership)) THEN
          found := TRUE;
          EXIT /find_channel/;
       IFEND;
      IFEND;
    FOREND /find_channel/;

    IF NOT found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_channel, channel.channel_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, channel.iou_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, mainframe_id, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, esm_element_name, status);
    IFEND;

  PROCEND dfp$verify_stornet_channel;

?? TITLE := ' load_and_execute ', EJECT ??

  PROCEDURE load_and_execute
    (    channel_address: cmt$physical_equipment_number;
         channel_specification: dft$channel_specification;
         p_element_reservations: ^dft$pp_element_reservations;
     VAR pp_number: iot$pp_number;
     VAR status: ost$status);


    VAR
      element_access: array [1 .. 1] of cmt$hardware_address,
      local_status: ost$status,
      p_channel_element_definition: ^cmt$element_definition,
      pp_index : iot$pp_number,
      program_description: array [1 .. 1] of cmt$pp_program_description;


    { Build the program descriptor and request load and execute of a PP.

    program_description [1].pp_identification := p_element_reservations^ [1].pp_reservation.
          acquired_pp_identification;
    program_description [1].iou_program_name := 'ESMD';
    program_description [1].pp_program := NIL;
    program_description [1].master_pp := TRUE;
    program_description [1].communication_buffer_length := osv$page_size;
    program_description [1].communication_buffer := NIL;

    element_access [1].physical_address_specifier := $cmt$physical_address_specifier
          [cmc$iou, cmc$channel, cmc$channel_address];
    element_access [1].iou := p_element_reservations^ [1].pp_reservation.channel.iou;
    element_access [1].channel.ordinal := p_element_reservations^ [1].pp_reservation.channel.ordinal;
    element_access [1].channel.iou := p_element_reservations^ [1].pp_reservation.channel.iou;
    element_access [1].channel_address := channel_address;

    program_description [1].element_access := ^element_access;

    cmp$execute_pp_program (program_description, status);
    IF status.normal THEN
      cmp$pc_get_element (channel_specification.channel_name, channel_specification.iou_name,
                          p_channel_element_definition, status);
      IF status.normal THEN
        cmp$get_logical_pp_index (p_channel_element_definition^, pp_index, status);
        IF status.normal THEN
          pp_number := pp_index;
        IFEND;
      IFEND;
    IFEND;

  PROCEND load_and_execute;

?? TITLE := ' mark_unload ', EJECT ??

  PROCEDURE mark_unload
    (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
         channel: dft$channel_specification);


    { This procedure sets ESM PP status flags in the queue directory entry
    { to reflect the unloaded/inactive state of the specified PP.


    IF channel = p_q_interface_directory_entry^.send_channel THEN
      p_q_interface_directory_entry^.driver_active := FALSE;
      p_q_interface_directory_entry^.send_pp.pp_status.activated := FALSE;
      p_q_interface_directory_entry^.send_pp.pp_status.loaded := FALSE;
      p_q_interface_directory_entry^.send_pp.pp_status.idled := TRUE;
      p_q_interface_directory_entry^.p_queue_interface_table^.queue_directory.send_pp_number := 0;
      IF p_q_interface_directory_entry^.send_channel = p_q_interface_directory_entry^.receive_channel THEN
        p_q_interface_directory_entry^.receive_pp.pp_status.activated := FALSE;
        p_q_interface_directory_entry^.receive_pp.pp_status.loaded := FALSE;
        p_q_interface_directory_entry^.receive_pp.pp_status.idled := TRUE;
        p_q_interface_directory_entry^.p_queue_interface_table^.queue_directory.receive_pp_number := 0;
      IFEND;

    ELSE { Receive channel different than send channel }
      p_q_interface_directory_entry^.receive_pp.pp_status.activated := FALSE;
      p_q_interface_directory_entry^.receive_pp.pp_status.loaded := FALSE;
      p_q_interface_directory_entry^.receive_pp.pp_status.idled := TRUE;
      p_q_interface_directory_entry^.p_queue_interface_table^.queue_directory.receive_pp_number := 0;
    IFEND;

  PROCEND mark_unload;

?? TITLE := ' reserve_esm_element ', EJECT ??

  PROCEDURE reserve_esm_element
    (    esm_element_name: cmt$element_name;
         channel: dft$channel_specification;
     VAR p_element_reservations: ^dft$pp_element_reservations;
     VAR channel_address: cmt$physical_equipment_number;
     VAR dma: boolean;
     VAR status: ost$status);

    VAR
      channel_definition: cmt$data_channel_definition,
      channel_descriptor: cmt$channel_descriptor,
      found: boolean,
      p_esm_def_table_entry: ^dft$esm_definition_table_entry;


    { This procedure allocates and fills in the required fields of the
    { element reservation record for the specified ESM element. A PP and
    { a channel (accessable by the PP) are reserved.

    dfp$locate_esm_definition (esm_element_name, p_esm_def_table_entry);
    IF p_esm_def_table_entry = NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$stornet_not_defined, esm_element_name, status);
      RETURN;
    IFEND;

    dfp$verify_stornet_channel (esm_element_name, channel, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    channel_descriptor.use_logical_identification := TRUE;
    channel_descriptor.name := channel.channel_name;
    channel_descriptor.iou := channel.iou_name;

    cmp$get_channel_definition (channel_descriptor, channel_definition, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    found := FALSE;

  /verify_channel_esm_connection/
    FOR channel_address := LOWERVALUE (cmt$physical_equipment_number)
          TO UPPERVALUE (cmt$physical_equipment_number) DO
      IF (channel_definition.connection.equipment [channel_address].configured) AND
            (channel_definition.connection.equipment [channel_address].element_name = esm_element_name) THEN
        dma := channel_definition.direct_memory_access;
        found := TRUE;
        EXIT /verify_channel_esm_connection/;
      IFEND;
    FOREND /verify_channel_esm_connection/;

    IF NOT found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$no_configured_equipment, channel_descriptor.name,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, esm_element_name, status);
      RETURN;
    IFEND;

{   Reserve the STORNET/ESM element if not already reserved.
    IF p_esm_def_table_entry^.p_element_reservation = NIL THEN
      ALLOCATE p_esm_def_table_entry^.p_element_reservation IN dfv$server_wired_heap^;
      p_esm_def_table_entry^.p_element_reservation^ [1].element_type := cmc$communications_element;
      p_esm_def_table_entry^.p_element_reservation^ [1].peripheral_descriptor.
           use_logical_identification := TRUE;
      p_esm_def_table_entry^.p_element_reservation^[1].peripheral_descriptor.element_name := esm_element_name;
      cmp$reserve_element (p_esm_def_table_entry^.p_element_reservation^, status);
      IF NOT status.normal THEN
        FREE p_esm_def_table_entry^.p_element_reservation IN dfv$server_wired_heap^;
        RETURN;
      IFEND;
    IFEND;

{   Reserve the CHANNEL/PP element.
    ALLOCATE p_element_reservations IN dfv$server_wired_heap^;
    p_element_reservations^ [1].element_type := cmc$pp_element;
    p_element_reservations^ [1].pp_reservation.selector := cmc$choose_pp_by_channel;
    p_element_reservations^ [1].pp_reservation.channel.ordinal := channel_definition.ordinal;
    p_element_reservations^ [1].pp_reservation.channel.iou := channel_definition.iou;
    cmp$reserve_element (p_element_reservations^, status);
    IF NOT status.normal THEN
      FREE p_element_reservations IN dfv$server_wired_heap^;
      RETURN;
    IFEND;
    p_esm_def_table_entry^.number_of_pps_using_esm := p_esm_def_table_entry^.number_of_pps_using_esm + 1;

  PROCEND reserve_esm_element;


MODEND dfm$file_server_pp_mgnt;
*DECK DECK=DFM$FS_CONFIDENCE_TEST EXPAND=TRUE
PROC fs_confidence_test, fsct (served_family, sf:  name= testing
 pf_number, pn: integer 0 .. 1000000 = 2
 ckb_number, cn: integer 0 .. 1000000 = 0
 establish_condition_handler, ech: boolean = true
 compare_times, ct: boolean = TRUE
 save_print, sp: boolean = false
 status)

  IF $value(compare_times) AND (($mainframe(id) = '$SYSTEM_0860_0302') OR ..
        ($mainframe(id) = '$SYSTEM_0830_0604')) THEN
    generate_ptu_summary size=10000000 family=$value(served_family) user=$system ..
          write_modified_pages=TRUE free_pages=TRUE loop_count=1 collect_mmio_data=TRUE ..
          compare_times=TRUE allocation_size=#16k
  IFEND

  IF $value(ckb_number) > 0 THEN
    ckbm nj=$value(ckb_number)  ic=3  sf=$value(served_family) cc=true ..
        $value(establish_condition_handler)
  IFEND
  family = $string($value(served_family))
  handler = $strrep($value(establish_condition_handler))
  save_output = $strrep($value(save_print))
  FOR i = 1 to $value(pf_number) DO
    JOB jn =$name('PF_TEST'//$strrep(i))   sm ='?'
       IF ?handler? THEN
         WHEN any_fault do
           reqoa ' PF_TEST?$strrep(i)? failed  '//$condition_name(osv$status.condition)
           display_value osv$status
           logout
         WHENEND
       IFEND

      " Clean up - just in case
      " Enter system_operator_utility to get system privilege
      system_operator_utility
      crev ignore status
      delete_file  $fname(':?family?.$system.scu?$strrep(i)?') status=ignore
      delete_file  $fname(':?family?.$system.scq?$strrep(i)?') status=ignore


      " test allocate
      copy_file $system.scu.bound_product ..
         $fname(':?family?.$system.scu?$strrep(i)?')
      " test write
      copy_file $system.scu.bound_product ..
         $fname(':?family?.$system.scu?$strrep(i)?')
      " test permanent files
      crefp $fname(':?family?.$system.scu?$strrep(i)?') g=public
      disce $fname(':?family?.$system.scu?$strrep(i)?') do=c
      " test read - write
      copy_file $fname(':?family?.$system.scu?$strrep(i)?')  ..
           $fname(':?family?.$system.scq?$strrep(i)?')
      compare_file $system.scu.bound_product ..
           $fname(':?family?.$system.scq?$strrep(i)?')
      delete_file  $fname(':?family?.$system.scu?$strrep(i)?')
      delete_file  $fname(':?family?.$system.scq?$strrep(i)?')
      disc $fname(':?family?.$system')
      quit " system_operator_utility "
       IF NOT ?save_output? THEN
         terp output
      IFEND
    JOBEND
  FOREND

PROCEND fs_confidence_test

*DECK DECK=DFM$GENPS EXPAND=TRUE
PROCEDURE generate_ptu_summary, genps (
  size, s: integer 0..999999999 = 10000000
  family, f: name = testing
  user, u: name = $system
  configuration, c: string 1..10 = 'C302 S302'
  tab_file, tf: file = $user.ptu.tf.$next
  collection_file, cf: file = $user.ptu.cf
  write_modified_pages, wmp: boolean = TRUE
  free_pages, fp: boolean = TRUE
  loop_count, lc: integer = 1
  output, o: file = $user.ptu.sum.$next
  collect_keypoints, ck: key
      (all, a)
      (write_normal, wn)
      (write_sequential, ws)
      (write_advise, wa)
      (read_normal, rn)
      (read_sequential, rs)
      (read_advise, ra)
      (none, n)
    keyend = none
  keypoint_selection, ks: key
      (server, s)
      (disk, d)
      (both, b)
    keyend = server
  keypoint_param, kp: name = system
  collect_mmio_data, cmd: boolean = TRUE
  compare_times, compare_time, ct: boolean = FALSE
  flush_in_millions, fim: integer 0..500 = 0
  allocation_size, as: key
      #16k, #32k, #65k, #131k, #262k, #524k, #1048k, all, a
    keyend = #16K
  transfer_size, ts: key
      #16K, #32K, #65K, #131K, #262K, #524k, #1048k, all, a
    keyend = #16K
  server_initial_volume, siv: (BY_NAME) any of key (system_device, sd), keyend,
       name 6..6, anyend = $optional
  local_initial_volume, liv: (BY_NAME) any of key (system_device, sd), keyend,
       name 6..6, anyend = $optional
  help, h: file = $optional
  status)

  "$FORMAT=OFF
  VAR
    un: string = $unique
  VAREND
  "$FORMAT=ON"
COLLECT_TEXT $fname(un)

  PROC GENERATE_PTU_SUMMARY

  This purpose of this procedure is to collect data concerning file server
  file transfers.  Files of the specified SIZE are written to the FAMILY
  and USER specified. Files are written and read using NORMAL, SEQUENTIAL,
  and ADVISED methods. For comparison purposes, similar files are written
  and read in the user catalog (which assumes the user's catalog is not in
  a served family).
  When running GENPS you need to have (read, write) permission to the user
  specified by FAMILY and USER catalog. If the FREE_PAGES parameter is TRUE,
  the specified USER must also have granted READ/WRITE permission to the
  the user :$SYSTEM.$SYSTEM. If running GENPS from the system console these
  permissions are already defined.

  If the COLLECT_MMIO_DATA value is set TRUE, the a remote procedure call will
  be made after each server file operation to collect the memory management
  data for that operation.

  The CONFIGURATION parameter is for documention. C302 S608 would mean that the
  run was made with SN302 as the Client and SN608 as the Server.

  The TAB_FILE consists of the output data separated by tabs. This file is
  used as an input to an EXCEL program

  The COLLECTION_FILE is the file used for collecting keypoints if the
  COLLECT_KEYPOINTS value is other than NONE.

  WRITE_MODIFIED_PAGES controls a Memory Manager operation.

  FREE_PAGES controls whether mmp$free_pages should be called after writing
  each file. This parameter is provided only to check whether the free pages
  actions are effective.

  LOOP_COUNT cntrols the numebr of times the main loop of this procedure is
  executed.

  OUTPUT specifies the listable output file.

  The COLLECT_KEYPOINTS parameter specifies for which operation keypoints are
  to be collected. Since keypoint data is rather voluminous, it is suggested
  that if keypoints are to be collected that the size of the files be limited.
  Usually the size is set to 1MB if keypoints are specified.

  KEYPOINT_SELECTION specifies for what keypoints sre to be collected - server,
  disk, or both. This parameter is valid only if the value of the
  COLLECT_KEYPOINTS parameter is other than NONE.

  KEYPOINT_PARAM is the parameter to the reserve_keypoint_environment command
  which specifies the environment.

  COLLECT_MMIO_DATA controls whether a remote procedure call will be made to the
  server to return Memory Manager io data.

  COMPARE_TIMES provides for a regression-type test. If specified true, then
  the results of the current run are compared with result of previous runs.
  Previous results are hard coded in this procedure and are valid for loopback
  runs of SN302(860) orSN604(830) using the "standard" parameter values of
  this procedure.

  FLUSH_IN_MILLIONS is an attempt to flush all server pages to disk by writing
  a server file the size (* one million) specified prior to reading the files
  of interest. This should not be necessary if free_pages is specified as true.

  ALLOCATION_SIZE is used to determine the allocation_size parameter value to
  be specified on the request_mass_storage command.

  TRANSFER_SIZE is used to determine the transfer_size parameter value to
  be specified on the request_mass_storage command.

  SERVER_INITIAL_VOLUME is the Initial_Volume parameter value to be specified on
  the REQUEST_MASS_STORAGE commands issued by GENPS for the "served file" tests.

  LOCAL_INITIAL_VOLUME is the Initial_Volume parameter value to be specified on
  the REQUEST_MASS_STORAGE commands issued by GENPS for the "local file" tests.

     The GENPS parameters SERVER_INITIAL_VOLUME and LOCAL_INITIAL_VOLUME
     provide the option of selecting mass storage devices within the user's
     validation limits. The specified parameter value is passed along on the
     REQUEST_MASS_STORAGE command to allow selection of a specific mass
     storage volume for the file.
     Users are each validated to have their files on a specific mass
     storage set. Each set consists of one or more mass storage volumes
     that are candidates for assignment to user's files.
     The tester using GENPS should be aware that I/O speeds for
     different mass storage devices may vary.

  HELP specifies the file to which this info will be written.

  STATUS returns the status of this command.
**
  IF $specified(help) THEN
    copy_file input=$fname(un) output=help
    detach_file $fname(un)
    EXIT_PROC
  ELSE
    detach_file $fname(un)
  IFEND

  "$FORMAT=OFF
  VAR
    as_array: array 1..7 of integer
    as_par_array: array 1..7 of string
    as_array_index: integer 1..7
    as_array_start_index: integer 1..7 = 1
    as_array_stop_index: integer 1..7 = 1
    compare_errors: integer = 0
    ignore_status: status
    mmio_file: string = $unique
"
" The next four variables are generated to specify temporary files for the output
" and tab_files.  This is done since if these files are specified with $NEXT,
" SCL will now ('new' types) generate a new cycle every time such files are
" opened (which happens with each PUT_LINE)
    out: string
    out_unique: string
    tab_out: string
    tab_out_unique: string
"
    ts_array: array 1..7 of integer
    ts_par_array: array 1..7 of string
    ts_array_index: integer 1..7
    ts_array_start_index: integer 1..7 = 1
    ts_array_stop_index: integer 1..7 = 1
  VAREND
  "$FORMAT=ON"

  crec $user.ptu status=ignore_status
  setpa al=cyf$run_time_library status=ignore_status
  tab = $char(9)
  ck_value = $string(collect_keypoints)
  ks_value = $string(keypoint_selection)

  IF (ks_value = 'SERVER') OR (ks_value = 'S') THEN
    kp_server = true
    kp_disk = false
  ELSEIF (ks_value = 'DISK') OR (ks_value = 'D') THEN
    kp_server = false
    kp_disk = true
  ELSE
    kp_server = true
    kp_disk = true
  IFEND

" Process allocation_size and transfer_size parameters

    as_par_array(1) = '#16K'
    as_par_array(2) = '#32K'
    as_par_array(3) = '#65K'
    as_par_array(4) = '#131K'
    as_par_array(5) = '#262K'
    as_par_array(6) = '#524K'
    as_par_array(7) = '#1048K'

    as_array(1) = 16384
    as_array(2) = 32768
    as_array(3) = 65536
    as_array(4) = 131072
    as_array(5) = 262144
    as_array(6) = 524288
    as_array(7) = 1048576

  as_value = $string(allocation_size)
  IF as_value = '#16K' THEN
    as_array_start_index = 1
    as_array_stop_index =  1
  ELSEIF as_value = '#32K' THEN
    as_array_start_index = 2
    as_array_stop_index =  2
  ELSEIF as_value = '#65K' THEN
    as_array_start_index = 3
    as_array_stop_index =  3
  ELSEIF as_value = '#131K' THEN
    as_array_start_index = 4
    as_array_stop_index =  4
  ELSEIF as_value = '#262K' THEN
    as_array_start_index = 5
    as_array_stop_index =  5
  ELSEIF as_value = '#524K' THEN
    as_array_start_index = 6
    as_array_stop_index =  6
  ELSEIF as_value = '#1048K' THEN
    as_array_start_index = 7
    as_array_stop_index =  7
  ELSEIF as_value(1) = 'A' THEN
    as_array_start_index = 1
    as_array_stop_index =  7
  IFEND

    ts_par_array(1) = '#16K'
    ts_par_array(2) = '#32K'
    ts_par_array(3) = '#65K'
    ts_par_array(4) = '#131K'
    ts_par_array(5) = '#262K'
    ts_par_array(6) = '#524K'
    ts_par_array(7) = '#1048K'

    ts_array(1) = 16384
    ts_array(2) = 32768
    ts_array(3) = 65536
    ts_array(4) = 131072
    ts_array(5) = 262144
    ts_array(6) = 524288
    ts_array(7) = 1048576

  ts_value = $string(transfer_size)
  IF ts_value = '#16K' THEN
    ts_array_start_index = 1
    ts_array_stop_index =  1
  ELSEIF ts_value = '#32K' THEN
    ts_array_start_index = 2
    ts_array_stop_index =  2
  ELSEIF ts_value = '#65K' THEN
    ts_array_start_index = 3
    ts_array_stop_index =  3
  ELSEIF ts_value = '#131K' THEN
    ts_array_start_index = 4
    ts_array_stop_index =  4
  ELSEIF ts_value = '#262K' THEN
    ts_array_start_index = 5
    ts_array_stop_index =  5
  ELSEIF ts_value = '#524K' THEN
    ts_array_start_index = 6
    ts_array_stop_index =  6
  ELSEIF ts_value = '#1048K' THEN
    ts_array_start_index = 7
    ts_array_stop_index =  7
  ELSEIF ts_value(1) = 'A' THEN
    ts_array_start_index = 1
    ts_array_stop_index =  7
  IFEND

"

  set_file_attributes file=output file_contents=list file_structure=data status=ignore_status
  get_mmio_parameters = 'family=' // $string(family)// ' mmio_file=' // mmio_file
  IF free_pages THEN
    get_mmio_parameters = get_mmio_parameters//' free_pages=TRUE user='//$strrep(user)//' file='
  ELSE
    get_mmio_parameters = get_mmio_parameters//' free_pages=FALSE'
  IFEND

  " Create the mmio file so that it will have ring attributes of this job/task.
COLT $fname(mmio_file)
**

  "Create statistics array
  "$FORMAT=OFF
  VAR
    stats: array 1..2  "disk, server       " of ..
           array 1..2  "write, read        " of ..
           array 1..3  "normal, seq, advise" of ..
           array 1..3  "elapsed, ioc, alc  " of ..
           array 1..3  "mon, max, ave      " of integer
    disk@: integer = 1
    server@: integer = 2

    write@: integer = 1
    read@: integer = 2

    normal@: integer = 1
    seq@: integer = 2
    advise@: integer = 3

    elapsed@: integer = 1
    ioc@: integer = 2  "IO count"
    alc@: integer = 3 "allocation count"

    min@: integer = 1
    max@: integer = 2
    ave@: integer = 3
  VAREND
  "$FORMAT=ON

  IF compare_times THEN
    IF NOT (($mainframe(id) = '$SYSTEM_0830_0604') OR ($mainframe(id) = '$SYSTEM_0860_0302')) THEN
      EXIT_PROC WITH $status(false, 'DF', 333, ' COMPARE_OUTPUT is valid only for SN302 or SN604')
    IFEND
  IFEND

  IF compare_times AND ($mainframe(id) = '$SYSTEM_0830_0604') THEN
    " The following values were generated from several GENPS runs on SN604
    " with default GENPS parameter values.
    " Memory size was 16MB.
    " File server was running loopback, no other jobs.
    " The system had been deadstarted with the default configuration prolog,
    "   that is, USECP SN604_ISD2_2X4.
    stats(disk@)(write@)(normal@)(elapsed@)(min@) = 11
    stats(disk@)(write@)(normal@)(elapsed@)(max@) = 17
    stats(server@)(write@)(normal@)(elapsed@)(min@) = 30
    stats(server@)(write@)(normal@)(elapsed@)(max@) = 41
    stats(server@)(write@)(normal@)(ioc@)(min@) = 605
    stats(server@)(write@)(normal@)(ioc@)(max@) = 630
    stats(server@)(write@)(normal@)(alc@)(min@) = 145
    stats(server@)(write@)(normal@)(alc@)(max@) = 160

    stats(disk@)(write@)(seq@)(elapsed@)(min@) = 9
    stats(disk@)(write@)(seq@)(elapsed@)(max@) = 18
    stats(server@)(write@)(seq@)(elapsed@)(min@) = 21
    stats(server@)(write@)(seq@)(elapsed@)(max@) = 31
    stats(server@)(write@)(seq@)(ioc@)(min@) = 610
    stats(server@)(write@)(seq@)(ioc@)(max@) = 618
    stats(server@)(write@)(seq@)(alc@)(min@) = 145
    stats(server@)(write@)(seq@)(alc@)(max@) = 160

    stats(disk@)(write@)(advise@)(elapsed@)(min@) = 9
    stats(disk@)(write@)(advise@)(elapsed@)(max@) = 14
    stats(server@)(write@)(advise@)(elapsed@)(min@) = 25
    stats(server@)(write@)(advise@)(elapsed@)(max@) = 31
    stats(server@)(write@)(advise@)(ioc@)(min@) = 608
    stats(server@)(write@)(advise@)(ioc@)(max@) = 620
    stats(server@)(write@)(advise@)(alc@)(min@) = 145
    stats(server@)(write@)(advise@)(alc@)(max@) = 160

    stats(disk@)(read@)(normal@)(elapsed@)(min@) = 8
    stats(disk@)(read@)(normal@)(elapsed@)(max@) = 12
    stats(server@)(read@)(normal@)(elapsed@)(min@) = 25
    stats(server@)(read@)(normal@)(elapsed@)(max@) = 31
    stats(server@)(read@)(normal@)(ioc@)(min@) = 605
    stats(server@)(read@)(normal@)(ioc@)(max@) = 630
    stats(server@)(read@)(normal@)(alc@)(min@) = 0
    stats(server@)(read@)(normal@)(alc@)(max@) = 0

    stats(disk@)(read@)(seq@)(elapsed@)(min@) = 7
    stats(disk@)(read@)(seq@)(elapsed@)(max@) = 10
    stats(server@)(read@)(seq@)(elapsed@)(min@) = 25
    stats(server@)(read@)(seq@)(elapsed@)(max@) = 30
    stats(server@)(read@)(seq@)(ioc@)(min@) = 605
    stats(server@)(read@)(seq@)(ioc@)(max@) = 630
    stats(server@)(read@)(seq@)(alc@)(min@) = 0
    stats(server@)(read@)(seq@)(alc@)(max@) = 0

    stats(disk@)(read@)(advise@)(elapsed@)(min@) = 7
    stats(disk@)(read@)(advise@)(elapsed@)(max@) = 10
    stats(server@)(read@)(advise@)(elapsed@)(min@) = 18
    stats(server@)(read@)(advise@)(elapsed@)(max@) = 22
    stats(server@)(read@)(advise@)(ioc@)(min@) = 605
    stats(server@)(read@)(advise@)(ioc@)(max@) = 630
    stats(server@)(read@)(advise@)(alc@)(min@) = 0
    stats(server@)(read@)(advise@)(alc@)(max@) = 0
  IFEND

  IF compare_times AND ($mainframe(id) = '$SYSTEM_0860_0302') THEN
    " The following values were generated from several GENPS runs on SN302
    " with default GENPS parameter values.
    " Memory size was 16MB.
    " File server was running loopback, no other jobs.
    " The system had been deadstarted with the default configuration prolog,
    "   that is, USECP SN302_895_2X4.
    stats(disk@)(write@)(normal@)(elapsed@)(min@) = 5
    stats(disk@)(write@)(normal@)(elapsed@)(max@) = 7
    stats(server@)(write@)(normal@)(elapsed@)(min@) = 8
    stats(server@)(write@)(normal@)(elapsed@)(max@) = 12
    stats(server@)(write@)(normal@)(ioc@)(min@) = 605
    stats(server@)(write@)(normal@)(ioc@)(max@) = 630
    stats(server@)(write@)(normal@)(alc@)(min@) = 145
    stats(server@)(write@)(normal@)(alc@)(max@) = 160

    stats(disk@)(write@)(seq@)(elapsed@)(min@) = 4
    stats(disk@)(write@)(seq@)(elapsed@)(max@) = 6
    stats(server@)(write@)(seq@)(elapsed@)(min@) = 4
    stats(server@)(write@)(seq@)(elapsed@)(max@) = 7
    stats(server@)(write@)(seq@)(ioc@)(min@) = 610
    stats(server@)(write@)(seq@)(ioc@)(max@) = 618
    stats(server@)(write@)(seq@)(alc@)(min@) = 145
    stats(server@)(write@)(seq@)(alc@)(max@) = 160

    stats(disk@)(write@)(advise@)(elapsed@)(min@) = 4
    stats(disk@)(write@)(advise@)(elapsed@)(max@) = 6
    stats(server@)(write@)(advise@)(elapsed@)(min@) = 5
    stats(server@)(write@)(advise@)(elapsed@)(max@) = 8
    stats(server@)(write@)(advise@)(ioc@)(min@) = 608
    stats(server@)(write@)(advise@)(ioc@)(max@) = 622
    stats(server@)(write@)(advise@)(alc@)(min@) = 145
    stats(server@)(write@)(advise@)(alc@)(max@) = 160

    stats(disk@)(read@)(normal@)(elapsed@)(min@) = 4
    stats(disk@)(read@)(normal@)(elapsed@)(max@) = 6
    stats(server@)(read@)(normal@)(elapsed@)(min@) = 7
    stats(server@)(read@)(normal@)(elapsed@)(max@) = 9
    stats(server@)(read@)(normal@)(ioc@)(min@) = 605
    stats(server@)(read@)(normal@)(ioc@)(max@) = 630
    stats(server@)(read@)(normal@)(alc@)(min@) = 0
    stats(server@)(read@)(normal@)(alc@)(max@) = 0

    stats(disk@)(read@)(seq@)(elapsed@)(min@) = 4
    stats(disk@)(read@)(seq@)(elapsed@)(max@) = 6
    stats(server@)(read@)(seq@)(elapsed@)(min@) = 7
    stats(server@)(read@)(seq@)(elapsed@)(max@) = 9
    stats(server@)(read@)(seq@)(ioc@)(min@) = 605
    stats(server@)(read@)(seq@)(ioc@)(max@) = 630
    stats(server@)(read@)(seq@)(alc@)(min@) = 0
    stats(server@)(read@)(seq@)(alc@)(max@) = 0

    stats(disk@)(read@)(advise@)(elapsed@)(min@) = 4
    stats(disk@)(read@)(advise@)(elapsed@)(max@) = 6
    stats(server@)(read@)(advise@)(elapsed@)(min@) = 4
    stats(server@)(read@)(advise@)(elapsed@)(max@) = 6
    stats(server@)(read@)(advise@)(ioc@)(min@) = 605
    stats(server@)(read@)(advise@)(ioc@)(max@) = 630
    stats(server@)(read@)(advise@)(alc@)(min@) = 0
    stats(server@)(read@)(advise@)(alc@)(max@) = 0
  IFEND

  as_loop: ..
   FOR as_array_index = as_array_start_index to as_array_stop_index DO
     alloc_size = as_array(as_array_index)
     as_par = as_par_array(as_array_index)

  ts_loop: ..
   FOR ts_array_index = ts_array_start_index to ts_array_stop_index DO
     trans_size = ts_array(ts_array_index)
     ts_par = ts_par_array(ts_array_index)

loop_counter_loop: ..
  FOR loop_counter = 1 TO loop_count DO

     out_unique = $unique
     out = out_unique//'.$eoi'
     tab_out_unique = $unique
     tab_out = tab_out_unique//'.$eoi'

    config_base = configuration// tab //$date(mdy) // tab // ..
       as_par// tab //ts_par// tab // $strrep(size)
    config_base_d = $substring(configuration, 1, 5)// ' disk' // tab // $date(mdy) // ..
       tab //as_par// tab //ts_par// tab // $strrep(size)
    dest = ':' // $string(family)// '.' // $string(user)

    incl 'display_system_configuration output='//out status=ignore_status
    put_line '1 FILE SERVER PERFORMANCE TEST UTILITY   Date = '//$date(mdy)//'  Time = '//$time(hms) ..
          output=$fname(out)
    put_line '  Mainframe = '//$mainframe(id) output=$fname(out)
    put_line '      Collect_keypoint option = '//ck_value output=$fname(out)
    put_line '      Configuration = '//configuration output=$fname(out)
    put_line '      Collect_MMIO_Data = '//$strrep(collect_mmio_data) output=$fname(out)
    put_line '      Size = '//$strrep(size) output=$fname(out)
    put_line '      Allocation_size option = '//as_par//' ('//as_value//')' output=$fname(out)
    put_line '        Allocation Size = '//$strrep(alloc_size) output=$fname(out)
    put_line '      Transfer_size option = '//ts_par//' ('//ts_value//')' output=$fname(out)
    put_line '        Transfer Size = '//$strrep(trans_size) output=$fname(out)
    IF $specified(server_initial_volume) THEN
      put_line '      Server_initial_volume = '//$strrep(Server_initial_volume) output=$fname(out)
    IFEND
    IF $specified(server_initial_volume) THEN
      put_line '      Local_initial_volume = '//$strrep(local_initial_volume) output=$fname(out)
    IFEND
    put_line '      FMI = '//$strrep(flush_in_millions) output=$fname(out)
    put_line '      Free_pages = '//$strrep(free_pages) output=$fname(out)
    IF $specified(collect_keypoints) THEN
      put_line '      Keypoint_collection_file = '//$string(collection_file) output=$fname(out)
      cf_string = $string(collection_file)// '.$next'
      put_line '      Keypoint_selection = '//$string(keypoint_selection) output=$fname(out)
    IFEND
    put_line ' ' output=$fname(out)
    put_line '       NON-FILE-SERVER             FILE-SERVER' output=$fname(out)
    put_line '                              CLIENT         SERVER MONITOR STATS' output=$fname(out)
    put_line ' ' output=$fname(out)
    put_line '                                              AVE             MAX        COUNT' ..
          output=$fname(out)
    put_line '  WRITE' output=$fname(out)

" Process NORMAL
    putl ' Start Normal WRITE - Server' output=$output
    destn = dest // '.genpsN'
    detf $local.genpsn status=ignore_status
    IF loop_counter = 1 THEN
      delf $fname(destn) status=ignore_status
      IF ($specified(allocation_size)) OR ($specified(transfer_size)) ..
         OR ($specified(server_initial_volume)) THEN
        request_mass_storage f= $fname(destn) as = alloc_size ..
             ts = trans_size iv = server_initial_volume status = ignore_status
        IF NOT ignore_status.normal THEN
          putl ' ERROR on REQMS for server device -' output=$output
          DISV ignore_status output=$output
        IFEND
        detf $fname(destn) status=ignore_status
        attf $fname(destn) genpsn am=all
      ELSE
        create_file file=$fname(destn) local_file_name=genpsn
      IFEND
    ELSE
      attf $fname(destn) genpsn am=all
    IFEND


    IF ((ck_value = 'WN') OR (ck_value = 'A') OR (ck_value = 'ALL') OR (ck_value = 'WRITE_NORMAL')) AND ..
          kp_server THEN
      reske keypoint_param cf=$fname(cf_string) kc=1000000 ds='NORMAL SERVER WRITE'
      stakc
      dfp$ptu $local.genpsn w m=n s=size wmp=write_modified_pages fp=free_pages
      detach_file $local.genpsn
      stokc
      relke
      chafa collection_file ra=(11, 11, 11)
    ELSE
      dfp$ptu $local.genpsn w m=n s=size wmp=write_modified_pages fp=free_pages
      detach_file $local.genpsn
    IFEND
    incf $user.ptu_report
    server_elapsed = ptu#elapsed_time
    server_mon = ptu#mon_time
    server_task = ptu#task_time

    putl ' Start Normal WRITE - noserver' output=$output

    IF loop_counter = 1 THEN
      delf $user.ugenpsn status=ignore_status
      IF ($specified(allocation_size)) OR ($specified(transfer_size)) ..
         OR ($specified(local_initial_volume)) THEN
        request_mass_storage f= $user.ugenpsn as = alloc_size ..
             ts = trans_size iv = local_initial_volume status = ignore_status
        IF NOT ignore_status.normal THEN
          putl ' ERROR on REQMS for local device -' output=$output
          DISV ignore_status output=$output
        IFEND
        detf $user.ugenpsn status=ignore_status
        attf $user.ugenpsn ugenpsn am=all
      ELSE
        create_file file=$user.ugenpsn local_file_name=ugenpsn status=ignore_status
      IFEND
    ELSE
      attf $user.ugenpsn ugenpsn am=all
    IFEND
    IF ((ck_value = 'WN') OR (ck_value = 'A') OR (ck_value = 'ALL') OR (ck_value = 'WRITE_NORMAL')) AND ..
          kp_disk THEN
      reske keypoint_param cf=$fname(cf_string) kc=1000000 ds='NORMAL DISK WRITE'
      stakc
      dfp$ptu ugenpsn w m=n s=size wmp=write_modified_pages fp=free_pages
      detf ugenpsn
      stokc
      relke
      chafa collection_file ra=(11, 11, 11)
    ELSE
      dfp$ptu ugenpsn w m=n s=size wmp=write_modified_pages fp=free_pages
      detf ugenpsn
    IFEND

    incf $user.ptu_report

    IF collect_mmio_data THEN
      send_mmio_parameters = get_mmio_parameters
      IF free_pages THEN
        send_mmio_parameters = send_mmio_parameters//'genpsn'
      IFEND
      exet sp=dfp$get_mmio_data parameter=send_mmio_parameters
      chafa $fname(mmio_file) ra=(11, 11, 11) status=ignore_status
      incf $fname(mmio_file)
    ELSE
      ptu@mon_ave_io_time = '0.00000'
      ptu@mon_max_io_time = '0.00000'
      ptu@mon_io_count = '1'
      ptu@mon_ave_allocate_time = '0.00000'
      ptu@mon_max_allocate_time = '0.00000'
      ptu@mon_allocate_count = '1'
      ptu@mon_trace_count = 0
    IFEND

    put_line '    N    E  '//ptu#elapsed_time//'      '//server_elapsed//'    IO   '//ptu@mon_ave_io_time//..
'     '//ptu@mon_max_io_time//'      '//ptu@mon_io_count output=$fname(out)
    put_line '         M  '//ptu#mon_time//'      '//server_mon//'    AL   '//ptu@mon_ave_allocate_time//..
'     '//ptu@mon_max_allocate_time//'      '//ptu@mon_allocate_count output=$fname(out)
    put_line '         T  '//ptu#task_time//'      '//server_task//'            trace_count = '//..
$strrep(ptu@mon_trace_count) output=$fname(out)

    IF compare_times THEN
      "disk elapsed
      IF ($integer($real(ptu#elapsed_time)) < stats(disk@)(write@)(normal@)(elapsed@)(min@)) OR ..
            ($integer($real(ptu#elapsed_time)) > stats(disk@)(write@)(normal@)(elapsed@)(max@)) THEN
        put_line ' *** CHANGE in disk,write,normal,elapsed ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(disk@)(write@)(normal@)(elapsed@)(min@))..
//' to '//$strrep(stats(disk@)(write@)(normal@)(elapsed@)(max@)) output=$response
        put_line ' Found '//ptu#elapsed_time output=$response
        compare_errors = compare_errors+1
      IFEND
      "server elapsed
      IF ($integer($real(server_elapsed)) < stats(server@)(write@)(normal@)(elapsed@)(min@)) OR ..
            ($integer($real(server_elapsed)) > stats(server@)(write@)(normal@)(elapsed@)(max@)) THEN
        put_line ' *** CHANGE in server,write,normal,elapsed ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(write@)(normal@)(elapsed@)(min@))..
//' to '//$strrep(stats(server@)(write@)(normal@)(elapsed@)(max@)) output=$response
        put_line ' Found '//server_elapsed output=$response
        compare_errors = compare_errors+1
      IFEND
      "server io count
      IF ($integer(ptu@mon_io_count) < stats(server@)(write@)(normal@)(ioc@)(min@)) OR ..
            ($integer(ptu@mon_io_count) > stats(server@)(write@)(normal@)(ioc@)(max@)) THEN
        put_line ' *** CHANGE in server,write,normal,ioc ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(write@)(normal@)(ioc@)(min@))..
//' to '//$strrep(stats(server@)(write@)(normal@)(ioc@)(max@)) output=$response
        put_line ' Found '//ptu@mon_io_count output=$response
        compare_errors = compare_errors+1
      IFEND
      "server allocate count
      IF ($integer(ptu@mon_allocate_count) < stats(server@)(write@)(normal@)(alc@)(min@)) OR ..
            ($integer(ptu@mon_allocate_count) > stats(server@)(write@)(normal@)(alc@)(max@)) THEN
        put_line ' *** CHANGE in server,write,normal,alc ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(write@)(normal@)(alc@)(min@))..
//' to '//$strrep(stats(server@)(write@)(normal@)(alc@)(max@)) output=$response
        put_line ' Found '//ptu@mon_allocate_count output=$response
        compare_errors = compare_errors+1
      IFEND
    IFEND


    put_line '  ' output=$fname(out)

    config = config_base // tab // 'Write Normal'
    config = config // tab // server_elapsed // tab // server_mon // tab // server_task
    config = config // tab // ptu@mon_ave_io_time // tab // ptu@mon_max_io_time
    config = config // tab // ptu@mon_io_count // tab // $strrep(ptu@mon_trace_count)
    config = config // tab // ptu@mon_ave_allocate_time // tab // ptu@mon_max_allocate_time // tab // ..
          ptu@mon_allocate_count
    put_line config output=$fname(tab_out)
    config = config_base_d // tab // 'Write Normal'
    config = config // tab // ptu#elapsed_time // tab // ptu#mon_time // tab // ptu#task_time
    put_line config output=$fname(tab_out)

" Process SEQUENTIAL

    putl ' Start Sequen WRITE - Server' output=$output
    dests = dest // '.genpsS'
    IF loop_counter = 1 THEN
      delf $fname(dests) status=ignore_status
      IF ($specified(allocation_size)) OR ($specified(transfer_size)) ..
         OR ($specified(server_initial_volume)) THEN
        request_mass_storage f= $fname(dests) as = alloc_size ..
             ts = trans_size iv = server_initial_volume status = ignore_status
        IF NOT ignore_status.normal THEN
          putl ' ERROR on REQMS for server device -' output=$output
          DISV ignore_status output=$output
        IFEND
        detf $fname(dests) status=ignore_status
      ELSE
        create_file file=$fname(dests) local_file_name=genpss status=ignore_status
        detf $fname(dests) status=ignore_status
      IFEND
    IFEND
    IF ((ck_value = 'WS') OR (ck_value = 'A') OR (ck_value = 'ALL') OR ..
          (ck_value = 'WRITE_SEQUENTIAL')) AND kp_server THEN
      reske keypoint_param cf=$fname(cf_string) kc=1000000 ds='SEQUENTIAL SERVER WRITE'
      stakc
      dfp$ptu $fname(dests) w m=s s=size wmp=write_modified_pages fp=free_pages
      detach_file $fname(dests) status=ignore_status
      stokc
      relke
      chafa collection_file ra=(11, 11, 11)
    ELSE
      dfp$ptu $fname(dests) w m=s s=size wmp=write_modified_pages fp=free_pages
      detach_file $fname(dests) status=ignore_status
    IFEND
    incf $user.ptu_report
    server_elapsed = ptu#elapsed_time
    server_mon = ptu#mon_time
    server_task = ptu#task_time

    putl ' Start Sequen WRITE - noserver' output=$output
    IF loop_counter = 1 THEN
      delf $user.ugenpss status=ignore_status
      IF ($specified(allocation_size)) OR ($specified(transfer_size)) ..
         OR ($specified(local_initial_volume)) THEN
        request_mass_storage f= $user.ugenpss as = alloc_size ..
             ts = trans_size iv = local_initial_volume status = ignore_status
        IF NOT ignore_status.normal THEN
          putl ' ERROR on REQMS for local device -' output=$output
          DISV ignore_status output=$output
        IFEND
        detf $user.ugenpss status=ignore_status
      ELSE
        create_file file=$user.ugenpss local_file_name=ugenpss status=ignore_status
        detf $user.ugenpss
      IFEND
    IFEND
    IF ((ck_value = 'WS') OR (ck_value = 'A') OR (ck_value = 'ALL') OR ..
          (ck_value = 'WRITE_SEQUENTIAL')) AND kp_disk THEN
      reske keypoint_param cf=$fname(cf_string) kc=1000000 ds='SEQUENTIAL DISK WRITE'
      stakc
      dfp$ptu $user.ugenpss w m=s s=size wmp=write_modified_pages fp=free_pages
      detf $user.ugenpss  status=ignore_status
      stokc
      relke
      chafa collection_file ra=(11, 11, 11)
    ELSE
      dfp$ptu $user.ugenpss w m=s s=size wmp=write_modified_pages fp=free_pages
      detf $user.ugenpss status=ignore_status
    IFEND
    incf $user.ptu_report

    IF collect_mmio_data THEN
      send_mmio_parameters = get_mmio_parameters
      IF free_pages THEN
        send_mmio_parameters = send_mmio_parameters//'genpss'
      IFEND
      exet sp=dfp$get_mmio_data parameter=send_mmio_parameters
      chafa $fname(mmio_file) ra=(11, 11, 11) status=ignore_status
      incf $fname(mmio_file)
    IFEND

    put_line '    S    E  '//ptu#elapsed_time//'      '//server_elapsed//'    IO   '//ptu@mon_ave_io_time//..
'     '//ptu@mon_max_io_time//'      '//ptu@mon_io_count output=$fname(out)
    put_line '         M  '//ptu#mon_time//'      '//server_mon//'    AL   '//ptu@mon_ave_allocate_time//..
'     '//ptu@mon_max_allocate_time//'      '//ptu@mon_allocate_count output=$fname(out)
    put_line '         T  '//ptu#task_time//'      '//server_task//'            trace_count = '//..
$strrep(ptu@mon_trace_count) output=$fname(out)

    IF compare_times THEN
      "disk elapsed
      IF ($integer($real(ptu#elapsed_time)) < stats(disk@)(write@)(seq@)(elapsed@)(min@)) OR ..
            ($integer($real(ptu#elapsed_time)) > stats(disk@)(write@)(seq@)(elapsed@)(max@)) THEN
        put_line ' *** CHANGE in disk,write,seq,elapsed ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(disk@)(write@)(seq@)(elapsed@)(min@))..
//' to '//$strrep(stats(disk@)(write@)(seq@)(elapsed@)(max@)) output=$response
        put_line ' Found '//ptu#elapsed_time output=$response
        compare_errors = compare_errors+1
      IFEND
      "server elapsed
      IF ($integer($real(server_elapsed)) < stats(server@)(write@)(seq@)(elapsed@)(min@)) OR ..
            ($integer($real(server_elapsed)) > stats(server@)(write@)(seq@)(elapsed@)(max@)) THEN
        put_line ' *** CHANGE in server,write,seq,elapsed ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(write@)(seq@)(elapsed@)(min@))..
//' to '//$strrep(stats(server@)(write@)(seq@)(elapsed@)(max@)) output=$response
        put_line ' Found '//server_elapsed output=$response
        compare_errors = compare_errors+1
      IFEND
      "server io count
      IF ($integer(ptu@mon_io_count) < stats(server@)(write@)(seq@)(ioc@)(min@)) OR ..
            ($integer(ptu@mon_io_count) > stats(server@)(write@)(seq@)(ioc@)(max@)) THEN
        put_line ' *** CHANGE in server,write,seq,ioc ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(write@)(seq@)(ioc@)(min@))//' to '//$strrep(stats(server@)(write@)(seq@)(ioc@)(max@))..
 output=$response
        put_line ' Found '//ptu@mon_io_count output=$response
        compare_errors = compare_errors+1
      IFEND
      "server allocate count
      IF ($integer(ptu@mon_allocate_count) < stats(server@)(write@)(seq@)(alc@)(min@)) OR ..
            ($integer(ptu@mon_allocate_count) > stats(server@)(write@)(seq@)(alc@)(max@)) THEN
        put_line ' *** CHANGE in server,write,seq,alc ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(write@)(seq@)(alc@)(min@))//' to '//$strrep(stats(server@)(write@)(seq@)(alc@)(max@))..
 output=$response
        put_line ' Found '//ptu@mon_allocate_count output=$response
        compare_errors = compare_errors+1
      IFEND
    IFEND

    config = config_base // tab // 'Write Sequen'
    config = config // tab // server_elapsed // tab // server_mon // tab // server_task
    config = config // tab // ptu@mon_ave_io_time // tab // ptu@mon_max_io_time
    config = config // tab // ptu@mon_io_count // tab // $strrep(ptu@mon_trace_count)
    config = config // tab // ptu@mon_ave_allocate_time // tab // ptu@mon_max_allocate_time // tab // ..
          ptu@mon_allocate_count
    put_line config output=$fname(tab_out)
    config = config_base_d // tab // 'Write Sequen'
    config = config // tab // ptu#elapsed_time // tab // ptu#mon_time // tab // ptu#task_time
    put_line config output=$fname(tab_out)


    putl ' Start Advised WRITE - Server' output=$output
" Process ADVISED
    put_line '     ' output=$fname(out)
    desta = dest // '.genpsA'
    IF loop_counter = 1 THEN
      delf $fname(desta) status=ignore_status
      IF ($specified(allocation_size)) OR ($specified(transfer_size)) ..
         OR ($specified(server_initial_volume)) THEN
        request_mass_storage f= $fname(desta) as = alloc_size ..
             ts = trans_size iv = server_initial_volume status = ignore_status
        IF NOT ignore_status.normal THEN
          putl ' ERROR on REQMS for server device -' output=$output
          DISV ignore_status output=$output
        IFEND
        detf $fname(desta) status=ignore_status
        attf $fname(desta) genpsa am=all
      ELSE
        create_file file=$fname(desta) local_file_name=genpsa status=ignore_status
      IFEND
    ELSE
      attf $fname(desta) genpsa am=all
    IFEND
    IF ((ck_value = 'WA') OR (ck_value = 'A') OR (ck_value = 'ALL') OR ..
          (ck_value = 'WRITE_ADVISE')) AND kp_server THEN
      reske keypoint_param cf=$fname(cf_string) kc=1000000 ds='ADVISE SERVER WRITE'
      stakc
      dfp$ptu $local.genpsa w m=a s=size wmp=write_modified_pages fp=free_pages
      detach_file $local.genpsa
      stokc
      relke
      chafa collection_file ra=(11, 11, 11)
    ELSE
      dfp$ptu $local.genpsa w m=a s=size wmp=write_modified_pages fp=free_pages
      detach_file $local.genpsa
    IFEND
    incf $user.ptu_report
    server_elapsed = ptu#elapsed_time
    server_mon = ptu#mon_time
    server_task = ptu#task_time

    putl ' Start Advised WRITE - noserver' output=$output
    IF loop_counter = 1 THEN
      delf $user.ugenpsa status=ignore_status
      IF ($specified(allocation_size)) OR ($specified(transfer_size)) ..
         OR ($specified(local_initial_volume)) THEN
        request_mass_storage f= $user.ugenpsa as = alloc_size ..
             ts = trans_size iv = local_initial_volume status = ignore_status
        IF NOT ignore_status.normal THEN
          putl ' ERROR on REQMS for local device -' output=$output
          DISV ignore_status output=$output
        IFEND
        detf $user.ugenpsa status=ignore_status
        attf $user.ugenpsa ugenpsa am=all
      ELSE
        create_file file=$user.ugenpsa local_file_name=ugenpsa status=ignore_status
      IFEND
    ELSE
      attf $user.ugenpsa ugenpsa am=all
    IFEND
    IF ((ck_value = 'WA') OR (ck_value = 'A') OR (ck_value = 'ALL') OR ..
          (ck_value = 'WRITE_ADVISE')) AND kp_disk THEN
      reske keypoint_param cf=$fname(cf_string) kc=1000000 ds='ADVISE DISK WRITE'
      stakc
      dfp$ptu ugenpsa w m=a s=size wmp=write_modified_pages fp=free_pages
      detf ugenpsa
      stokc
      relke
      chafa collection_file ra=(11, 11, 11)
    ELSE
      dfp$ptu ugenpsa w m=a s=size wmp=write_modified_pages fp=free_pages
      detf ugenpsa
    IFEND
    incf $user.ptu_report

    IF collect_mmio_data THEN
      send_mmio_parameters = get_mmio_parameters
      IF free_pages THEN
        send_mmio_parameters = send_mmio_parameters//'genpsa'
      IFEND
      exet sp=dfp$get_mmio_data parameter=send_mmio_parameters
      chafa $fname(mmio_file) ra=(11, 11, 11) status=ignore_status
      incf $fname(mmio_file)
    IFEND

    put_line '    A    E  '//ptu#elapsed_time//'      '//server_elapsed//'    IO   '//ptu@mon_ave_io_time//..
'     '//ptu@mon_max_io_time//'      '//ptu@mon_io_count output=$fname(out)
    put_line '         M  '//ptu#mon_time//'      '//server_mon//'    AL   '//ptu@mon_ave_allocate_time//..
'     '//ptu@mon_max_allocate_time//'      '//ptu@mon_allocate_count output=$fname(out)
    put_line '         T  '//ptu#task_time//'      '//server_task//'            trace_count = '//..
$strrep(ptu@mon_trace_count) output=$fname(out)

    IF compare_times THEN
      "disk elapsed
      IF ($integer($real(ptu#elapsed_time)) < stats(disk@)(write@)(advise@)(elapsed@)(min@)) OR ..
            ($integer($real(ptu#elapsed_time)) > stats(disk@)(write@)(advise@)(elapsed@)(max@)) THEN
        put_line ' *** CHANGE in disk,write,advise,elapsed ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(disk@)(write@)(advise@)(elapsed@)(min@))..
//' to '//$strrep(stats(disk@)(write@)(advise@)(elapsed@)(max@)) output=$response
        put_line ' Found '//ptu#elapsed_time output=$response
        compare_errors = compare_errors+1
      IFEND
      "server elapsed
      IF ($integer($real(server_elapsed)) < stats(server@)(write@)(advise@)(elapsed@)(min@)) OR ..
            ($integer($real(server_elapsed)) > stats(server@)(write@)(advise@)(elapsed@)(max@)) THEN
        put_line ' *** CHANGE in server,write,advise,elapsed ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(write@)(advise@)(elapsed@)(min@))..
//' to '//$strrep(stats(server@)(write@)(advise@)(elapsed@)(max@)) output=$response
        put_line ' Found '//server_elapsed output=$response
        compare_errors = compare_errors+1
      IFEND
      "server io count
      IF ($integer(ptu@mon_io_count) < stats(server@)(write@)(advise@)(ioc@)(min@)) OR ..
            ($integer(ptu@mon_io_count) > stats(server@)(write@)(advise@)(ioc@)(max@)) THEN
        put_line ' *** CHANGE in server,write,advise,ioc ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(write@)(advise@)(ioc@)(min@))..
//' to '//$strrep(stats(server@)(write@)(advise@)(ioc@)(max@)) output=$response
        put_line ' Found '//ptu@mon_io_count output=$response
        compare_errors = compare_errors+1
      IFEND
      "server allocate count
      IF ($integer(ptu@mon_allocate_count) < stats(server@)(write@)(advise@)(alc@)(min@)) OR ..
            ($integer(ptu@mon_allocate_count) > stats(server@)(write@)(advise@)(alc@)(max@)) THEN
        put_line ' *** CHANGE in server,write,advise,alc ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(write@)(advise@)(alc@)(min@))..
//' to '//$strrep(stats(server@)(write@)(advise@)(alc@)(max@)) output=$response
        put_line ' Found '//ptu@mon_allocate_count output=$response
        compare_errors = compare_errors+1
      IFEND
    IFEND


    config = config_base // tab // 'Write Advise'
    config = config // tab // server_elapsed // tab // server_mon // tab // server_task
    config = config // tab // ptu@mon_ave_io_time // tab // ptu@mon_max_io_time
    config = config // tab // ptu@mon_io_count // tab // $strrep(ptu@mon_trace_count)
    config = config // tab // ptu@mon_ave_allocate_time // tab // ptu@mon_max_allocate_time // tab // ..
          ptu@mon_allocate_count
    put_line config output=$fname(tab_out)
    config = config_base_d // tab // 'Write Advise'
    config = config // tab // ptu#elapsed_time // tab // ptu#mon_time // tab // ptu#task_time
    put_line config output=$fname(tab_out)

    IF flush_in_millions> 0 THEN
      putl '    Start page flush - Server' output=$output
      destn = dest // '.genpsF'
      detach_file $local.genpsf status=ignore_status
      delf $fname(destn) status=ignore_status
      cref $fname(destn) genpsf status=ignore_status
      IF NOT ignore_status.normal THEN
        attf $fname(destn) genpsf am=all
      IFEND
      dfp$ptu $local.genpsf w m=n s=flush_in_millions*1000000 wmp=write_modified_pages fp=free_pages
      detach_file $local.genpsf
      IF collect_mmio_data THEN
        send_mmio_parameters = get_mmio_parameters
        IF free_pages THEN
          send_mmio_parameters = send_mmio_parameters//'genpsa'
        IFEND
        exet sp=dfp$get_mmio_data parameter=send_mmio_parameters
        chafa $fname(mmio_file) ra=(11, 11, 11) status=ignore_status
        delf $fname(mmio_file) status=ignore_status
      IFEND
      delf $fname(destn) status=ignore_status
    IFEND

    put_line '  ' output=$fname(out)
    put_line '  READ' output=$fname(out)

" Process NORMAL

    putl ' Start Normal READ  - Server' output=$output
    destn = dest // '.genpsN'
    attf $fname(destn) genpsn
    IF ((ck_value = 'RN') OR (ck_value = 'A') OR (ck_value = 'ALL') OR ..
          (ck_value = 'READ_NORMAL')) AND kp_server THEN
      reske keypoint_param cf=$fname(cf_string) kc=1000000 ds='NORMAL SERVER READ'
      stakc
      dfp$ptu $local.genpsn r m=n wmp=false
      detach_file $local.genpsn
      stokc
      relke
      chafa collection_file ra=(11, 11, 11)
    ELSE
      dfp$ptu $local.genpsn r m=n wmp=false
      detach_file $local.genpsn
    IFEND
    incf $user.ptu_report
    server_elapsed = ptu#elapsed_time
    server_mon = ptu#mon_time
    server_task = ptu#task_time

    putl ' Start Normal READ  - noserver' output=$output
    attf $user.ugenpsn ugenpsn
    IF ((ck_value = 'RN') OR (ck_value = 'A') OR (ck_value = 'ALL') OR (ck_value = 'READ_NORMAL')) AND kp_disk..
           THEN
      reske keypoint_param cf=$fname(cf_string) kc=1000000 ds='NORMAL DISK READ'
      stakc
      dfp$ptu ugenpsn r m=n wmp=false
      detf ugenpsn
      stokc
      relke
      chafa collection_file ra=(11, 11, 11)
    ELSE
      dfp$ptu ugenpsn r m=n wmp=false
      detf ugenpsn
    IFEND
    incf $user.ptu_report

    IF collect_mmio_data THEN
      send_mmio_parameters = get_mmio_parameters
      IF free_pages THEN
        send_mmio_parameters = send_mmio_parameters//'genpsn'
      IFEND
      exet sp=dfp$get_mmio_data parameter=send_mmio_parameters
      chafa $fname(mmio_file) ra=(11, 11, 11) status=ignore_status
      incf $fname(mmio_file)
    ELSE
      ptu@mon_ave_io_time = '0.00000'
      ptu@mon_max_io_time = '0.00000'
      ptu@mon_io_count = '1'
      ptu@mon_trace_count = 0
    IFEND

    put_line '    N    E  '//ptu#elapsed_time//'      '//server_elapsed//'    IO   '//ptu@mon_ave_io_time//..
'     '//ptu@mon_max_io_time//'      '//ptu@mon_io_count output=$fname(out)
    put_line '         M  '//ptu#mon_time//'      '//server_mon//'    AL   '//ptu@mon_ave_allocate_time//..
'     '//ptu@mon_max_allocate_time//'      '//ptu@mon_allocate_count output=$fname(out)
    put_line '         T  '//ptu#task_time//'      '//server_task//'            trace_count = '//..
$strrep(ptu@mon_trace_count) output=$fname(out)


    IF compare_times THEN
      "disk elapsed
      IF ($integer($real(ptu#elapsed_time)) < stats(disk@)(read@)(normal@)(elapsed@)(min@)) OR ..
            ($integer($real(ptu#elapsed_time)) > stats(disk@)(read@)(normal@)(elapsed@)(max@)) THEN
        put_line ' *** CHANGE in disk,read,normal,elapsed ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(disk@)(read@)(normal@)(elapsed@)(min@))..
//' to '//$strrep(stats(disk@)(read@)(normal@)(elapsed@)(max@)) output=$response
        put_line ' Found '//ptu#elapsed_time output=$response
        compare_errors = compare_errors+1
      IFEND
      "server elapsed
      IF ($integer($real(server_elapsed)) < stats(server@)(read@)(normal@)(elapsed@)(min@)) OR ..
            ($integer($real(server_elapsed)) > stats(server@)(read@)(normal@)(elapsed@)(max@)) THEN
        put_line ' *** CHANGE in server,read,normal,elapsed ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(read@)(normal@)(elapsed@)(min@))..
//' to '//$strrep(stats(server@)(read@)(normal@)(elapsed@)(max@)) output=$response
        put_line ' Found '//server_elapsed output=$response
        compare_errors = compare_errors+1
      IFEND
      "server io count
      IF ($integer(ptu@mon_io_count) < stats(server@)(read@)(normal@)(ioc@)(min@)) OR ..
            ($integer(ptu@mon_io_count) > stats(server@)(read@)(normal@)(ioc@)(max@)) THEN
        put_line ' *** CHANGE in server,read,normal,ioc ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(read@)(normal@)(ioc@)(min@))..
//' to '//$strrep(stats(server@)(read@)(normal@)(ioc@)(max@)) output=$response
        put_line ' Found '//ptu@mon_io_count output=$response
        compare_errors = compare_errors+1
      IFEND
      "server allocate count
      IF ($integer(ptu@mon_allocate_count) < stats(server@)(read@)(normal@)(alc@)(min@)) OR ..
            ($integer(ptu@mon_allocate_count) > stats(server@)(read@)(normal@)(alc@)(max@)) THEN
        put_line ' *** CHANGE in server,read,normal,alc ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(read@)(normal@)(alc@)(min@))..
//' to '//$strrep(stats(server@)(read@)(normal@)(alc@)(max@)) output=$response
        put_line ' Found '//ptu@mon_allocate_count output=$response
        compare_errors = compare_errors+1
      IFEND
    IFEND

    put_line '  ' output=$fname(out)

    config = config_base // tab // 'Read Normal'
    config = config // tab // server_elapsed // tab // server_mon // tab // server_task
    config = config // tab // ptu@mon_ave_io_time // tab // ptu@mon_max_io_time
    config = config // tab // ptu@mon_io_count // tab // $strrep(ptu@mon_trace_count)
    config = config // tab // ptu@mon_ave_allocate_time // tab // ptu@mon_max_allocate_time // tab // ..
          ptu@mon_allocate_count
    put_line config output=$fname(tab_out)
    config = config_base_d // tab // 'Read Normal'
    config = config // tab // ptu#elapsed_time // tab // ptu#mon_time // tab // ptu#task_time
    put_line config output=$fname(tab_out)


" Process SEQUENTIAL

    putl ' Start Sequen READ  - Server' output=$output
    dests = dest // '.genpsS'
    IF ((ck_value = 'RS') OR (ck_value = 'A') OR (ck_value = 'ALL') OR ..
          (ck_value = 'READ_SEQUENTIAL')) AND kp_server THEN
      reske keypoint_param cf=$fname(cf_string) kc=1000000 ds='SEQUENTIAL SERVER READ'
      stakc
      dfp$ptu $fname(dests) r m=s wmp=false
      detach_file $fname(dests) status=ignore_status
      stokc
      relke
      chafa collection_file ra=(11, 11, 11)
    ELSE
      dfp$ptu $fname(dests) r m=s wmp=false
      detach_file $fname(dests) status=ignore_status
    IFEND
    incf $user.ptu_report
    server_elapsed = ptu#elapsed_time
    server_mon = ptu#mon_time
    server_task = ptu#task_time

    putl ' Start Sequen READ  - noserver' output=$output
    IF ((ck_value = 'RS') OR (ck_value = 'A') OR (ck_value = 'ALL') OR ..
          (ck_value = 'READ_SEQUENTIAL')) AND kp_disk THEN
      reske keypoint_param cf=$fname(cf_string) kc=1000000 ds='SEQUENTIAL DISK READ'
      stakc
      dfp$ptu $user.ugenpss r m=s wmp=false
      detf $user.ugenpss status=ignore_status
      stokc
      relke
      chafa collection_file ra=(11, 11, 11)
    ELSE
      dfp$ptu $user.ugenpss r m=s wmp=false
      detf $user.ugenpss status=ignore_status
    IFEND
    incf $user.ptu_report

    IF collect_mmio_data THEN
      send_mmio_parameters = get_mmio_parameters
      IF free_pages THEN
        send_mmio_parameters = send_mmio_parameters//'genpss'
      IFEND
      exet sp=dfp$get_mmio_data parameter=send_mmio_parameters
      chafa $fname(mmio_file) ra=(11, 11, 11) status=ignore_status
      incf $fname(mmio_file)
    IFEND

    put_line '    S    E  '//ptu#elapsed_time//'      '//server_elapsed//'    IO   '//ptu@mon_ave_io_time//..
'     '//ptu@mon_max_io_time//'      '//ptu@mon_io_count output=$fname(out)
    put_line '         M  '//ptu#mon_time//'      '//server_mon//'    AL   '//ptu@mon_ave_allocate_time//..
'     '//ptu@mon_max_allocate_time//'      '//ptu@mon_allocate_count output=$fname(out)
    put_line '         T  '//ptu#task_time//'      '//server_task//'            trace_count = '//..
$strrep(ptu@mon_trace_count) output=$fname(out)


    IF compare_times THEN
      "disk elapsed
      IF ($integer($real(ptu#elapsed_time)) < stats(disk@)(read@)(seq@)(elapsed@)(min@)) OR ..
            ($integer($real(ptu#elapsed_time)) > stats(disk@)(read@)(seq@)(elapsed@)(max@)) THEN
        put_line ' *** CHANGE in disk,read,seq,elapsed ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(disk@)(read@)(seq@)(elapsed@)(min@))..
//' to '//$strrep(stats(disk@)(read@)(seq@)(elapsed@)(max@)) output=$response
        put_line ' Found '//ptu#elapsed_time output=$response
        compare_errors = compare_errors+1
      IFEND
      "server elapsed
      IF ($integer($real(server_elapsed)) < stats(server@)(read@)(seq@)(elapsed@)(min@)) OR ..
            ($integer($real(server_elapsed)) > stats(server@)(read@)(seq@)(elapsed@)(max@)) THEN
        put_line ' *** CHANGE in server,read,seq,elapsed ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(read@)(seq@)(elapsed@)(min@))..
//' to '//$strrep(stats(server@)(read@)(seq@)(elapsed@)(max@)) output=$response
        put_line ' Found '//server_elapsed output=$response
        compare_errors = compare_errors+1
      IFEND
      "server io count
      IF ($integer(ptu@mon_io_count) < stats(server@)(read@)(seq@)(ioc@)(min@)) OR ..
            ($integer(ptu@mon_io_count) > stats(server@)(read@)(seq@)(ioc@)(max@)) THEN
        put_line ' *** CHANGE in server,read,seq,ioc ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(read@)(seq@)(ioc@)(min@))//' to '//$strrep(stats(server@)(read@)(seq@)(ioc@)(max@)) ..
              output=$response
        put_line ' Found '//ptu@mon_io_count output=$response
        compare_errors = compare_errors+1
      IFEND
      "server allocate count
      IF ($integer(ptu@mon_allocate_count) < stats(server@)(read@)(seq@)(alc@)(min@)) OR ..
            ($integer(ptu@mon_allocate_count) > stats(server@)(read@)(seq@)(alc@)(max@)) THEN
        put_line ' *** CHANGE in server,read,seq,alc ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(read@)(seq@)(alc@)(min@))//' to '//$strrep(stats(server@)(read@)(seq@)(alc@)(max@)) ..
              output=$response
        put_line ' Found '//ptu@mon_allocate_count output=$response
        compare_errors = compare_errors+1
      IFEND
    IFEND

    config = config_base // tab // 'Read Sequen'
    config = config // tab // server_elapsed // tab // server_mon // tab // server_task
    config = config // tab // ptu@mon_ave_io_time // tab // ptu@mon_max_io_time
    config = config // tab // ptu@mon_io_count // tab // $strrep(ptu@mon_trace_count)
    config = config // tab // ptu@mon_ave_allocate_time // tab // ptu@mon_max_allocate_time // tab // ..
          ptu@mon_allocate_count
    put_line config output=$fname(tab_out)
    config = config_base_d // tab // 'Read Sequen'
    config = config // tab // ptu#elapsed_time // tab // ptu#mon_time // tab // ptu#task_time
    put_line config output=$fname(tab_out)


" Process ADVISED
    putl ' Start Advised READ  - Server' output=$output
    put_line '     ' output=$fname(out)
    desta = dest // '.genpsA'
    attf $fname(desta) genpsa
    IF ((ck_value = 'RA') OR (ck_value = 'A') OR (ck_value = 'ALL') OR ..
          (ck_value = 'READ_ADVISE')) AND kp_server THEN
      reske keypoint_param cf=$fname(cf_string) kc=1000000 ds='ADVISE SERVER READ'
      stakc
      dfp$ptu $local.genpsa r m=a wmp=false
      detach_file $local.genpsa
      stokc
      relke
      chafa collection_file ra=(11, 11, 11)
    ELSE
      dfp$ptu $local.genpsa r m=a wmp=false
      detach_file $local.genpsa
    IFEND
    incf $user.ptu_report
    server_elapsed = ptu#elapsed_time
    server_mon = ptu#mon_time
    server_task = ptu#task_time

    putl ' Start Advised READ  - noServer' output=$output
    attf $user.ugenpsa ugenpsa
    IF ((ck_value = 'RA') OR (ck_value = 'A') OR (ck_value = 'ALL') OR (ck_value = 'READ_ADVISE')) AND kp_disk..
           THEN
      reske keypoint_param cf=$fname(cf_string) kc=1000000 ds='ADVISE DISK READ'
      stakc
      dfp$ptu ugenpsa r m=a wmp=false
      detf ugenpsa
      stokc
      relke
      chafa collection_file ra=(11, 11, 11)
    ELSE
      dfp$ptu ugenpsa r m=a wmp=false
      detf ugenpsa
    IFEND
    incf $user.ptu_report

    IF collect_mmio_data THEN
      send_mmio_parameters = get_mmio_parameters
      IF free_pages THEN
        send_mmio_parameters = send_mmio_parameters//'genpsa'
      IFEND
      exet sp=dfp$get_mmio_data parameter=send_mmio_parameters
      chafa $fname(mmio_file) ra=(11, 11, 11) status=ignore_status
      incf $fname(mmio_file)
    IFEND

    put_line '    A    E  '//ptu#elapsed_time//'      '//server_elapsed//'    IO   '//ptu@mon_ave_io_time//..
'     '//ptu@mon_max_io_time//'      '//ptu@mon_io_count output=$fname(out)
    put_line '         M  '//ptu#mon_time//'      '//server_mon//'    AL   '//ptu@mon_ave_allocate_time//..
'     '//ptu@mon_max_allocate_time//'      '//ptu@mon_allocate_count output=$fname(out)
    put_line '         T  '//ptu#task_time//'      '//server_task//'            trace_count = '//..
$strrep(ptu@mon_trace_count) output=$fname(out)


    IF compare_times THEN
      "disk elapsed
      IF ($integer($real(ptu#elapsed_time)) < stats(disk@)(read@)(advise@)(elapsed@)(min@)) OR ..
            ($integer($real(ptu#elapsed_time)) > stats(disk@)(read@)(advise@)(elapsed@)(max@)) THEN
        put_line ' *** CHANGE in disk,read,advise,elapsed ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(disk@)(read@)(advise@)(elapsed@)(min@))..
//' to '//$strrep(stats(disk@)(read@)(advise@)(elapsed@)(max@)) output=$response
        put_line ' Found '//ptu#elapsed_time output=$response
        compare_errors = compare_errors+1
      IFEND
      "server elapsed
      IF ($integer($real(server_elapsed)) < stats(server@)(read@)(advise@)(elapsed@)(min@)) OR ..
            ($integer($real(server_elapsed)) > stats(server@)(read@)(advise@)(elapsed@)(max@)) THEN
        put_line ' *** CHANGE in server,read,advise,elapsed ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(read@)(advise@)(elapsed@)(min@))..
//' to '//$strrep(stats(server@)(read@)(advise@)(elapsed@)(max@)) output=$response
        put_line ' Found '//server_elapsed output=$response
        compare_errors = compare_errors+1
      IFEND
      "server io count
      IF ($integer(ptu@mon_io_count) < stats(server@)(read@)(advise@)(ioc@)(min@)) OR ..
            ($integer(ptu@mon_io_count) > stats(server@)(read@)(advise@)(ioc@)(max@)) THEN
        put_line ' *** CHANGE in server,read,advise,ioc ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(read@)(advise@)(ioc@)(min@))..
//' to '//$strrep(stats(server@)(read@)(advise@)(ioc@)(max@)) output=$response
        put_line ' Found '//ptu@mon_io_count output=$response
        compare_errors = compare_errors+1
      IFEND
      "server allocate count
      IF ($integer(ptu@mon_allocate_count) < stats(server@)(read@)(advise@)(alc@)(min@)) OR ..
            ($integer(ptu@mon_allocate_count) > stats(server@)(read@)(advise@)(alc@)(max@)) THEN
        put_line ' *** CHANGE in server,read,advise,alc ..' output=$response
        put_line ' Expecting '//..
$strrep(stats(server@)(read@)(advise@)(alc@)(min@))..
//' to '//$strrep(stats(server@)(read@)(advise@)(alc@)(max@)) output=$response
        put_line ' Found '//ptu@mon_allocate_count output=$response
        compare_errors = compare_errors+1
      IFEND
    IFEND

    config = config_base // tab // 'Read Advise'
    config = config // tab // server_elapsed // tab // server_mon // tab // server_task
    config = config // tab // ptu@mon_ave_io_time // tab // ptu@mon_max_io_time
    config = config // tab // ptu@mon_io_count // tab // $strrep(ptu@mon_trace_count)
    config = config // tab // ptu@mon_ave_allocate_time // tab // ptu@mon_max_allocate_time // tab // ..
          ptu@mon_allocate_count
    put_line config output=$fname(tab_out)
    config = config_base_d // tab // 'Read Advise'
    config = config // tab // ptu#elapsed_time // tab // ptu#mon_time // tab // ptu#task_time
    put_line config output=$fname(tab_out)

  IF compare_times THEN
    IF compare_errors > 0 THEN
      put_line '  '//$strrep(compare_errors)//' compare errors encountered.' output=$response
    ELSE
      put_line '  NO compare errors.' output=$response
    IFEND
  IFEND

  chafa $fname(out_unique) ra=(11, 11, 11)
  chafa $fname(tab_out_unique) ra=(11, 11, 11)
  copf $fname(out_unique//'.$boi') $fname($string(output)//'.$eoi')
  copf $fname(tab_out_unique//'.$boi') $fname($string(tab_file)//'.$eoi')
  delete_file $fname(out_unique)
  delete_file $fname(tab_out_unique)
  FOREND loop_counter_loop

    FOREND ts_loop
   FOREND as_loop

  detach_file $fname(mmio_file) status=ignore_status

  delete_file $fname(destn)
  delete_file $user.ugenpsn
  delete_file $fname(dests)
  delete_file $user.ugenpss
  delete_file $fname(desta)
  delete_file $user.ugenpsa

PROCEND generate_ptu_summary
*DECK DECK=DFM$IDLE_REQUESTS_TO_SERVER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: Client', EJECT ??
MODULE dfm$idle_requests_to_server;

{ PURPOSE:
{   The purpose of this module is to idle all requests to the server
{   present on the client mainframe.  This occurs when the server is
{   being de-activated.
{
{ NOTES:
{   This procedure will execute as a separate system task
{   and the possibility exists that server termination may be started
{   while this task is executing .

?? NEWTITLE := '    Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfc$poll_constants
*copyc dfe$error_condition_codes
*copyc dft$cpu_queue
*copyc dft$entry_type
*copyc dft$rb_file_server_request
*copyc ost$status
?? POP ??
*copyc clp$scan_parameter_list
*copyc dfi$log_display
*copyc dfi$display
*copyc dfp$crack_mainframe_id
*copyc dfp$deactivate_server_files
*copyc dfp$execute_state_change_task
*copyc dfp$find_mainframe_id
*copyc dfp$locate_server_translation
*copyc dfp$verify_system_administrator
*copyc dfp$wait_until_leveler_complete
*copyc dfv$file_server_debug_enabled
*copyc i#call_monitor
*copyc jmp$ready_job_leveler_task
*copyc osp$set_status_abnormal
*copyc pmp$long_term_wait

{ pdt idle_task_pdt (
{   mainframe_name, mn : name pmc$mainframe_id_size = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    idle_task_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^idle_task_pdt_names,
      ^idle_task_pdt_params];

  VAR
    idle_task_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['MAINFRAME_NAME', 1], ['MN', 1], ['STATUS', 2]];

  VAR
    idle_task_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ MAINFRAME_NAME MN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, pmc$mainframe_id_size,
      pmc$mainframe_id_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

?? TITLE := '    [XDCL, #GATE] dfp$idle_requests_to_server', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$idle_requests_to_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      all_queue_entries_free: boolean,
      host_is_server_to_client: boolean,
      leveler_complete: boolean,
      leveler_executing: boolean,
      mainframe_found: boolean,
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id,
      mainframe_ordinal: 1 .. dfc$max_number_of_mainframes,
      p_cpu_queue: ^dft$cpu_queue,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      queue_index: dft$queue_index,
      request_block: dft$rb_file_server_request;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, idle_task_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$crack_mainframe_id ('MAINFRAME_NAME', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$verify_system_administrator ('IDLE_REQUESTS_TO_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    host_is_server_to_client := FALSE;
    dfp$find_mainframe_id (mainframe_name, host_is_server_to_client, mainframe_found, p_queue_interface_table,
          p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, mainframe_name, status);
      RETURN;
    IFEND;

    { Ready the leveler task early to let it get started.
    jmp$ready_job_leveler_task (leveler_executing);

    IF (p_cpu_queue^.queue_header.partner_status.server_state = dfc$terminated) OR
      (p_cpu_queue^.queue_header.partner_status.server_state = dfc$awaiting_recovery) THEN
      RETURN;
    IFEND;

    dfp$execute_state_change_task (mainframe_name,
        TRUE, dfc$active, dfc$deactivated, osc$wait, status);

    { Idle all server files.
    dfp$locate_server_translation (mainframe_id, mainframe_ordinal, mainframe_found);

    request_block.reqcode := syc$rc_file_server_request;
    request_block.request := dfc$fsr_set_task_segment_state;
    request_block.status.normal := TRUE;
    request_block.inhibit_access_work := $dft$mainframe_set [mainframe_ordinal];
    request_block.terminate_access_work := $dft$mainframe_set [];
    i#call_monitor (#LOC (request_block), #SIZE (request_block));


    dfp$deactivate_server_files (mainframe_id, status);
    IF NOT status.normal THEN
{     Possible abnormal status conditions are:
{     . dfe$server_file_not_deactivated        status.text = number of files not deactivated
{     . dfe$server_has_terminated              status.text = model and serial number of terminated server
      IF status.condition = dfe$server_file_not_deactivated THEN
        log_display ($pmt$ascii_logset[pmc$system_log], ' Some server files not deactivated' );
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;
    IF (p_cpu_queue^.queue_header.partner_status.server_state = dfc$terminated) OR
     (p_cpu_queue^.queue_header.partner_status.server_state = dfc$awaiting_recovery) THEN
      RETURN;
    IFEND;

    dfp$wait_until_leveler_complete (p_cpu_queue, leveler_complete);
    IF (p_cpu_queue^.queue_header.partner_status.server_state = dfc$terminated) OR
     (p_cpu_queue^.queue_header.partner_status.server_state = dfc$awaiting_recovery) THEN
      RETURN;
    IFEND;

    dfp$await_all_queue_entrys_free (p_cpu_queue, {2 mins} 120000, all_queue_entries_free);
    { Allow the poll task to reverify that all_queue_entries_free.
    { If the poller sees that they aren't it will force a timeout

    p_cpu_queue^.queue_header.partner_status.deactivate_complete := TRUE;

  PROCEND dfp$idle_requests_to_server;

?? TITLE := ' [XDCL] dfp$await_all_queue_entrys_free ', EJECT ??
  PROCEDURE [XDCL] dfp$await_all_queue_entrys_free
    (    p_cpu_queue: ^dft$cpu_queue;
         maximum_time_milliseconds: 0 .. 0ffffffffffff(16);
     VAR all_queue_entries_free: boolean);

    VAR
      assigned_entry_count: 0 .. dfc$max_queue_entries,
      current_elapsed_time: 0 .. 0ffffffffffff(16),
      queue_entry_index: dft$queue_entry_index;

    current_elapsed_time := 0;

  /await_all_entries_free/
    REPEAT
      assigned_entry_count := 0;
      all_queue_entries_free := TRUE;
      #SPOIL (p_cpu_queue^.queue_header);

    /check_all_queue_entries/
      FOR queue_entry_index := dfc$poll_queue_index + 1 TO
            (dfc$poll_queue_index + p_cpu_queue^.queue_header.number_of_monitor_queue_entries +
            p_cpu_queue^.queue_header.number_of_task_queue_entries) DO
        IF p_cpu_queue^.queue_header.queue_entry_assignment_table (queue_entry_index) =
              dfc$assigned_entry_char THEN
          assigned_entry_count := assigned_entry_count + 1;
        IFEND;
      FOREND /check_all_queue_entries/;

      IF (p_cpu_queue^.queue_header.partner_status.server_state = dfc$terminated) OR
       (p_cpu_queue^.queue_header.partner_status.server_state = dfc$awaiting_recovery) THEN
        all_queue_entries_free := TRUE;
        RETURN;
      IFEND;

      IF assigned_entry_count > 0 THEN
        all_queue_entries_free := FALSE;
        IF current_elapsed_time >= maximum_time_milliseconds THEN
          { Give up
          IF dfv$file_server_debug_enabled THEN
            display_integer (' Still some queue entries assigned', assigned_entry_count);
          IFEND;
          log_display_integer ($pmt$ascii_logset[pmc$system_log],
                ' Still some queue entries assigned', assigned_entry_count);
          RETURN;
        IFEND;
        current_elapsed_time := current_elapsed_time + 2000;
        pmp$long_term_wait (2000, 2000);
      IFEND;
    UNTIL assigned_entry_count = 0;
    all_queue_entries_free := TRUE;
  PROCEND dfp$await_all_queue_entrys_free;
MODEND dfm$idle_requests_to_server;
*DECK DECK=DFM$JOB_SERVER_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: Client: job_server_manager', EJECT ??
MODULE dfm$job_server_manager;

{
{  This module manages the association of a job on the client to a server mainframe.
{  This envolves establishing the job on the server, and maintaining a list
{  (the job server table) of server mainframes that the client job is using.
{  At job termination all server mainframes are informed of the termination
{  of the job.
{

?? NEWTITLE := '    Global Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avp$system_administrator
*copyc avp$family_administrator
*copyc dfd$driver_queue_types
*copyc dfi$display
*copyc dfe$error_condition_codes
*copyc dfi$display
*copyc dfi$log_display
*copyc dfp$clear_inhibit_access_work
*copyc dfp$fetch_access_work
*copyc dfp$verify_all_sdtxs_recovered
*copyc dfk$keypoints
*copyc dft$family_access
*copyc dft$mainframe_set
*copyc dfp$extract_send_parameters
*copyc dfp$find_mainframe_id
*copyc dfp$get_qit_p_from_direct_index
*copyc dfp$locate_served_family
*copyc dfv$file_server_debug_enabled
*copyc dfv$defined_server_translation
*copyc dfp$send_remote_procedure_call
*copyc dfv$job_recovery_enabled
*copyc fmp$recover_server_files
*copyc fmp$terminate_server_files
*copyc i#move
*copyc jmp$system_job
*copyc jmp$get_server_job_end_info
*copyc jmp$job_is_being_leveled
*copyc ofp$display_status_message
*copyc osc$server_job_recovery_cond
*copyc osd$integer_limits
*copyc ose$job_recovery_exceptions
*copyc osp$clear_job_signature_lock
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$increment_locked_variable
*copyc osp$initialize_signature_lock
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$test_signature_lock
*copyc oss$job_pageable
*copyc oss$job_paged_literal
*copyc ost$signature_lock
*copyc osp$system_error
*copyc osp$test_sig_lock
*copyc osv$initial_exception_context
*copyc osv$job_pageable_heap
*copyc pfe$internal_error_conditions
*copyc pmp$convert_binary_mainframe_id
*copyc pmp$cause_condition_in_tasks
*copyc pmp$get_account_project
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_job_mode
*copyc pmp$get_job_names
*copyc pmp$get_pseudo_mainframe_id
*copyc pmp$get_user_identification
*copyc pmp$log_ascii
*copyc syp$pop_inhibit_job_recovery
*copyc syp$push_inhibit_job_recovery
?? POP ??
*copyc dft$job_server_table
?? TITLE := '  Parameter passing protocols ', EJECT ??
*copyc dft$start_job_recovery
*copyc dft$end_job_recovery
*copyc dft$establish_client_job
?? SKIP := 5 ??
*copyc dft$delete_client_job
?? SKIP := 5 ??
*copyc dft$change_client_job_validaton
?? TITLE := '    Global Variables ', EJECT ??

  CONST
    job_end_notification_timeout = 5 * 60 * 1000; {5 minutes}

  VAR
    dfv$p_job_server_table: [oss$job_pageable, XDCL, #GATE] dft$p_job_server_table := NIL,
    dfv$job_server_count: [oss$job_pageable, XDCL, #GATE] integer := 0,
    dfv$job_server_table_lock: [oss$job_pageable, XDCL, #GATE] ost$signature_lock := [0],
    dfv$job_recovery_lock: [oss$job_pageable, XDCL, #GATE] ost$signature_lock := [0];


  VAR
    dfv$job_recovery_rpc_requests: [XDCL, #GATE, READ, oss$job_paged_literal]
          dft$procedure_address_ordinals := [dfc$initiate_job_recovery, dfc$complete_job_recovery,
          dfc$relink_server_file];

?? TITLE := ' [XDCL, #GATE] dfp$check_job_server  ', EJECT ??

*copyc dfh$check_job_server

  PROCEDURE [XDCL, #GATE] dfp$check_job_server
    (    queue_entry_location: dft$rpc_queue_entry_location;
         queue_entry_loc_int: dft$rpc_queue_entry_loc_int;
         user_parameter_size: dft$send_parameter_size;
         job_recovery_request: boolean;
         force_job_reconnection: boolean;
     VAR client_job_id: dft$client_job_id;
     VAR status: ost$status);

    VAR
      change_validation_info: boolean,
      current_lifetime: dft$lifetime,
      display_string: string (60),
      forced_reconnection: boolean,
      p_ignore_status: ^ost$status,
      family_access_kind: dft$family_access_kinds,
      job_server_table_index: dft$job_server_table_index,
      job_table_entry_exists: boolean,
      job_using_server_mainframe: boolean,
      p_queue_interface_table: dft$p_queue_interface_table;

    #KEYPOINT (osk$entry, osk$m * queue_entry_loc_int.queue_index, dfk$check_job_server);
    forced_reconnection := FALSE;
    change_validation_info := FALSE;
    dfp$get_qit_p_from_direct_index (queue_entry_loc_int.queue_directory_index, p_queue_interface_table);

{ There is probably a window here where a terminate_server and delete_server could take
{ place while this is happening - thus deleting tables out from under this
{ operation.

    current_lifetime := p_queue_interface_table^.queue_directory.
          cpu_queue_pva_directory [queue_entry_loc_int.queue_index].p_cpu_queue^.queue_header.
          server_lifetime;
    set_job_server_table_lock;

    locate_jobs_server_mainframe (queue_entry_loc_int.server_mainframe_id, job_using_server_mainframe,
          job_server_table_index);
    job_table_entry_exists := job_using_server_mainframe;
    IF force_job_reconnection OR (job_table_entry_exists AND
          dfv$p_job_server_table^ [job_server_table_index].force_server_reconnection) THEN
      dfv$p_job_server_table^ [job_server_table_index].force_server_reconnection := FALSE;
      job_using_server_mainframe := FALSE;
      forced_reconnection := TRUE;
    ELSEIF job_using_server_mainframe THEN
      IF job_recovery_request THEN
        client_job_id := dfv$p_job_server_table^ [job_server_table_index].client_job_id;
        status.normal := TRUE;
      ELSEIF dfv$p_job_server_table^ [job_server_table_index].server_lifetime = current_lifetime THEN
        client_job_id := dfv$p_job_server_table^ [job_server_table_index].client_job_id;
        IF dfv$p_job_server_table^ [job_server_table_index].change_validation_info THEN
          dfv$p_job_server_table^ [job_server_table_index].change_validation_info := FALSE;
          change_validation_info := TRUE;
        IFEND;
        status.normal := TRUE;
      ELSEIF dfv$job_recovery_enabled THEN
        IF jmp$system_job () THEN
          status.normal := TRUE;
          job_using_server_mainframe := FALSE;
          forced_reconnection := TRUE;
        ELSE

{ The job either needs to recover or the server has been terminated
{ GO back to the caller to force recovery, or re-establishment
          pmp$convert_binary_mainframe_id (queue_entry_loc_int.server_mainframe_id,
                display_string (1, pmc$mainframe_id_size), status);
          IF p_queue_interface_table^.queue_directory.
                cpu_queue_pva_directory [queue_entry_loc_int.queue_index].
                 p_cpu_queue^.queue_header.partner_status.server_state = dfc$terminated THEN
            osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated,
                  display_string (1, pmc$mainframe_id_size), status);
          ELSEIF p_queue_interface_table^.queue_directory.
                cpu_queue_pva_directory [queue_entry_loc_int.queue_index].
                 p_cpu_queue^.queue_header.partner_status.server_state <> dfc$active THEN
            osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_active,
                  display_string (1, pmc$mainframe_id_size), status);
          ELSE
            osp$set_status_abnormal (dfc$file_server_id, dfe$job_needs_recovery,
                  display_string (1, pmc$mainframe_id_size), status);
            IF dfv$file_server_debug_enabled THEN
              display_string := ' Job needs recovery for server ';
              PUSH p_ignore_status;
              pmp$convert_binary_mainframe_id (queue_entry_loc_int.server_mainframe_id,
                    display_string (32, pmc$mainframe_id_size), p_ignore_status^);
              pmp$log_ascii (display_string, $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system,
                    p_ignore_status^);
            IFEND;
          IFEND;
        IFEND;
      ELSE

{ The job will be re-connected to the server.
{ All server files in the job will be at the wrong lifetime.
        fmp$terminate_server_files (queue_entry_loc_int.server_mainframe_id,
             status);
        forced_reconnection := TRUE;
        status.normal := TRUE;
        job_using_server_mainframe := FALSE;
      IFEND;
    ELSE { No job server table entry exists
      { Set forced reconnection to true for the case where a client job list
      { entry exists on the server.
      forced_reconnection := TRUE;
    IFEND;

    IF status.normal AND NOT job_using_server_mainframe THEN
      inform_server_of_client_job (queue_entry_location, queue_entry_loc_int, user_parameter_size,
            forced_reconnection, current_lifetime, client_job_id, family_access_kind, status);
      IF status.normal THEN
        display_string := ' Job using server ';
        pmp$convert_binary_mainframe_id (queue_entry_loc_int.server_mainframe_id,
              display_string (20, pmc$mainframe_id_size), status);
        IF forced_reconnection AND job_table_entry_exists THEN
          display_string (40, 20) := '  reconnecting';
        IFEND;
        pmp$log_ascii (display_string, $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, status);
        create_job_server_entry (queue_entry_loc_int.server_mainframe_id, client_job_id, current_lifetime,
              job_table_entry_exists, family_access_kind, job_server_table_index);
      IFEND;
    IFEND;
    clear_job_server_table_lock;

    IF status.normal AND change_validation_info THEN

{ Change the validation info without the lock being set so that the
{ normal remote procedure call mechanism can work. (the normal mechanism
{ calls dfp$check_job_server).

      change_server_validation_info (queue_entry_location, queue_entry_loc_int, user_parameter_size,
            client_job_id, status);
    IFEND;
    IF status.normal THEN
      #KEYPOINT (osk$exit, osk$m * client_job_id.job_list_index, dfk$check_job_server);
    ELSE
      #KEYPOINT (osk$exit, 0, dfk$check_job_server);
    IFEND;
  PROCEND dfp$check_job_server;
?? TITLE := ' [XDCL, #GATE] dfp$get_job_server_state  ', EJECT ??


  PROCEDURE [XDCL, #GATE] dfp$get_job_server_state
    (    mainframe_id: pmt$binary_mainframe_id;
     VAR server_found: boolean;
     VAR server_lifetime: dft$lifetime);

    VAR
      job_server_table_index: dft$job_server_table_index;

    locate_jobs_server_mainframe (mainframe_id, server_found, job_server_table_index);
    IF server_found THEN
      server_lifetime := dfv$p_job_server_table^ [job_server_table_index].server_lifetime;
    IFEND;
  PROCEND dfp$get_job_server_state;
?? TITLE := ' dfp$process_job_end ', EJECT ??

*copyc dfh$process_job_end

  PROCEDURE [XDCL, #GATE] dfp$process_job_end;

    VAR
      job: dft$job_server_table_index,
      job_is_leveled: boolean,
      status: ost$status;

{ Dont set a lock here:
{ 1. There is no asynchronous task executing now.
{ 2. This request calls dfp$send_remote_procedure_call which for
{    permanent file requests, calls dfp$check_job_server which would
{    attempt to set this same lock.   An alternative would be to not
{    treat this request as a permanent file request, and have the server
{    procedure dfp$delete_client_job call dfp$validate_client_job_id
{    and pfp$set_task_environment.

    job_is_leveled := jmp$job_is_being_leveled ();
    IF (dfv$job_server_count = 0) AND job_is_leveled THEN

{This  assumes that the only way the job can be leveled and not have a
{  job server table is due to an abort during job_begin; that is, before
{  the job could access any other server.

      inform_server_of_client_job_end (NIL, job_is_leveled, status);
    IFEND;

  /inform_all_servers/
    FOR job := 1 TO dfv$job_server_count DO
      inform_server_of_client_job_end (^dfv$p_job_server_table^ [job], job_is_leveled, status);
    FOREND /inform_all_servers/;

    dfv$job_server_count := 0;

  PROCEND dfp$process_job_end;

?? TITLE := '  dfp$r2_check_job_recovery  ', EJECT ??
*copyc dfh$check_job_recovery

{ This procedure must handle the case of a delete_server of a server in the
{  job server table.
{ There is probably a window here where a terminate_server and delete_server could take
{  place while this is happening - thus deleting tables out from under this
{  operation.

  PROCEDURE [XDCL, #GATE] dfp$r2_check_job_recovery (VAR recovery_occurred: boolean);

    VAR
      display_string: string (60),
      inhibit_access_work: dft$mainframe_set,
      job: dft$job_server_table_index,
      lock_status: ost$signature_lock_status,
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
      status: ost$status,
      terminate_access_work: dft$mainframe_set;

{ LOCKING NEEDS MORE WORK
{ 1. There may be asynchronous task executing now.
{ 2. This request calls dfp$send_remote_procedure_call which
{    calls dfp$check_job_server which would
{    attempt to set the job server lock.
{ 3. What should dfp$check_job_server do while this going on? I
{    think it should wait, but it would be nice if recovery for one
{    server would not prevent a different task from using a different server.

    recovery_occurred := FALSE;

    osp$test_sig_lock (dfv$job_recovery_lock, lock_status);
    IF lock_status <> osc$sls_not_locked THEN

{ Force the wait at a higher ring

      RETURN;
    IFEND;
    syp$push_inhibit_job_recovery;
    osp$set_job_signature_lock (dfv$job_recovery_lock);

  /inform_all_servers/
    FOR job := 1 TO dfv$job_server_count DO
      dfp$find_mainframe_id (dfv$p_job_server_table^ [job].server_mainframe, { Server_to_client = } FALSE,
            mainframe_found, p_queue_interface_table, p_cpu_queue, queue_index,
            p_q_interface_directory_entry);
      IF NOT mainframe_found THEN
        { The queues are not defined yet - wait.
        CYCLE /inform_all_servers/;
      IFEND;
      IF (p_cpu_queue^.queue_header.partner_status.server_state = dfc$active) AND
            (p_cpu_queue^.queue_header.server_lifetime <> dfv$p_job_server_table^ [job].server_lifetime) THEN
        dfp$recover_job (p_cpu_queue^.queue_header.destination_mainframe_id, status);
        recovery_occurred := status.normal OR recovery_occurred;
      IFEND;
    FOREND /inform_all_servers/;

    IF NOT recovery_occurred THEN
      dfp$fetch_access_work (inhibit_access_work, terminate_access_work);
      IF inhibit_access_work <> $dft$mainframe_set [] THEN
        clear_inhibit_access_now_active  (inhibit_access_work);
      IFEND;
    IFEND;
    osp$clear_job_signature_lock (dfv$job_recovery_lock);
    syp$pop_inhibit_job_recovery;

  PROCEND dfp$r2_check_job_recovery;
?? TITLE := ' dfp$recover_job  ', EJECT ??
*copyc dfh$recover_job
  PROCEDURE [XDCL, #GATE] dfp$recover_job
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

    VAR
      file_manager_status: ost$status,
      ignore: ost$status,
      job_server_table_index: dft$job_server_table_index,
      job_using_server_mainframe: boolean,
      p_job_server_table_entry: ^dft$job_server_table_entry,
      mainframe_found: boolean,
      message: string (ofc$max_display_message),
      message_length: integer,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
      server_mainframe: pmt$mainframe_id;

  /job_recovery_block/
    BEGIN
      dfp$clear_inhibit_access_work (server_mainframe_id, {clear_sdtx} FALSE);

      pmp$convert_binary_mainframe_id (server_mainframe_id, server_mainframe, status);
      dfp$find_mainframe_id (server_mainframe, { Server_to_client = } FALSE, mainframe_found,
            p_queue_interface_table, p_cpu_queue, queue_index, p_q_interface_directory_entry);
      IF NOT mainframe_found THEN
        fmp$terminate_server_files (server_mainframe_id, file_manager_status);
        osp$set_status_condition (dfe$server_has_terminated, status);
        EXIT /job_recovery_block/;
      IFEND;

      locate_jobs_server_mainframe (server_mainframe_id, job_using_server_mainframe, job_server_table_index);
      IF NOT job_using_server_mainframe THEN
        fmp$terminate_server_files (server_mainframe_id, file_manager_status);
        osp$set_status_condition (dfe$server_has_terminated, status);
        EXIT /job_recovery_block/;
      IFEND;
      p_job_server_table_entry := ^dfv$p_job_server_table^ [job_server_table_index];

      IF NOT dfv$job_recovery_enabled THEN
        fmp$terminate_server_files (server_mainframe_id, file_manager_status);
        p_job_server_table_entry^.force_server_reconnection := TRUE;
        STRINGREP (message, message_length, 'Server ', server_mainframe, ' job recovery disabled');
        log_display ($pmt$ascii_logset [pmc$job_log, pmc$system_log], message (1, message_length));
        osp$set_status_condition (dfe$server_has_terminated, status);
        EXIT /job_recovery_block/;
      IFEND;

      STRINGREP (message, message_length, 'Server ', server_mainframe, ' job recovery in progress');
      ofp$display_status_message (message (1, message_length), ignore);
      start_job_recovery (server_mainframe, p_job_server_table_entry,
            status);
      IF NOT status.normal THEN
        STRINGREP (message, message_length, 'Server ', server_mainframe, ' job recovery failed');
        ofp$display_status_message (message (1, message_length), ignore);
        log_display ($pmt$ascii_logset [pmc$job_log, pmc$system_log], message (1, message_length));
        log_display_status ($pmt$ascii_logset [pmc$job_log, pmc$system_log], FALSE, status);
        IF (status.condition <> dfe$server_not_active) AND (status.condition <> dfe$server_request_terminated)
              THEN
          fmp$terminate_server_files (server_mainframe_id, file_manager_status);

{ Need to force the next access to this server to be as if new.

          p_job_server_table_entry^.force_server_reconnection := TRUE;
        IFEND;
        RETURN;
      IFEND;

      IF dfv$file_server_debug_enabled THEN
        log_display ($pmt$ascii_logset [pmc$job_log], ' fmp$recover_server_files');
      IFEND;
      fmp$recover_server_files (server_mainframe_id, file_manager_status);
      IF NOT file_manager_status.normal THEN
        log_display_status ($pmt$ascii_logset [pmc$job_log, pmc$system_log], FALSE, file_manager_status);

{ Despite the fact that some files did not recover allow the job to
{ proceed.
      IFEND;

      dfp$verify_all_sdtxs_recovered (server_mainframe_id);

      end_job_recovery (server_mainframe, p_job_server_table_entry,
            p_cpu_queue^.queue_header.server_lifetime, status);
      IF NOT status.normal THEN
        log_display_status ($pmt$ascii_logset [pmc$job_log], FALSE, status);
      IFEND;
      STRINGREP (message, message_length, 'Server ', server_mainframe, ' job recovery complete');
      ofp$display_status_message (message (1, message_length), ignore);
      log_display ($pmt$ascii_logset [pmc$job_log, pmc$system_log], message (1, message_length));
    END /job_recovery_block/;

    pmp$cause_condition_in_tasks (osc$server_job_recovery_cond);
  PROCEND dfp$recover_job;
?? TITLE := ' [XDCL, #GATE] dfp$recover_jobs_servers ', EJECT ??

{
{   The purpose of this routine is to set up for server recovery in the job.
{ IF recovery is enabled THEN
{   This routine verifies that the job server table can be read.
{ ELSE - recovery is NOT enabled
{      IF the job had used the file server but no longer had any server files
{         attached the job will recover.
{      IF the job had server files attach then
{         pfp$reattach_permanent_file procedure will detect the files then,
{         and the job will not be recovered.
{

  PROCEDURE [XDCL, #GATE] dfp$recover_jobs_servers
    (VAR status: ost$status);

    VAR
      lock_status: ost$signature_lock_status;

    status.normal := TRUE;

    IF (dfv$job_server_count > 0) AND dfv$file_server_debug_enabled THEN
      pmp$log_ascii (' Recovering Job using file server', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
            pmc$msg_origin_system, status);
    IFEND;

    osp$test_signature_lock (dfv$job_server_table_lock, lock_status, status);
    IF lock_status <> osc$sls_not_locked THEN
      log_display ($pmt$ascii_logset [pmc$job_log, pmc$system_log],
            ' dfv$job_server_table_lock  set - cant recover job ');
      osp$set_status_abnormal (dfc$file_server_id, ose$job_severely_damaged,
            ' dfv$job_server_table_lock set ', status);
      RETURN;
    IFEND;
    osp$test_signature_lock (dfv$job_recovery_lock, lock_status, status);
    IF lock_status <> osc$sls_not_locked THEN
      log_display ($pmt$ascii_logset [pmc$job_log, pmc$system_log],
            ' dfv$job_recovery_lock set cant recovery job ');
      osp$set_status_abnormal (dfc$file_server_id, ose$job_severely_damaged, ' dfv$job_recovery_lock set ',
            status);
      RETURN;
    IFEND;
  PROCEND dfp$recover_jobs_servers;
?? TITLE := ' [XDCL, #GATE] dfp$set_job_validation_change ', EJECT ??

{
{   The purpose of this routine is to indicate that the validation information
{ for the current job has changed.  This is marked in the job server table entry
{ for each server that the job is using.  On the next request to this server the
{ change is noted (see dfp$check_job_server) and a request is made to that
{ server to update the information.

  PROCEDURE [XDCL, #GATE] dfp$set_job_validation_change;

    VAR
      job_server_table_index: dft$job_server_table_index;

    set_job_server_table_lock;

  /change_all_servers/
    FOR job_server_table_index := 1 TO dfv$job_server_count DO
      dfv$p_job_server_table^ [job_server_table_index].change_validation_info := TRUE;
    FOREND /change_all_servers/;

    clear_job_server_table_lock;

  PROCEND dfp$set_job_validation_change;
?? TITLE := ' [INLINE] build_job_begin_send_buffer ', EJECT ??

  PROCEDURE [INLINE] build_job_begin_send_buffer
    (    server_mainframe_id: pmt$binary_mainframe_id;
         server_lifetime: dft$lifetime;
         forced_reconnection: boolean;
     VAR family_access_kind: dft$family_access_kinds;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameters_length: dft$send_parameter_size);

    VAR
      family_found: boolean,
      family_mainframe_id: pmt$binary_mainframe_id,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_send_parameters: ^dft$establish_client_job_inp,
      queue_index: dft$queue_index,
      served_family_table_index: dft$served_family_table_index,
      server_state: dft$server_state,
      status: ost$status;

    NEXT p_send_parameters IN p_send_to_server_params;

{ Fetch required information to send to server

    pmp$get_user_identification (p_send_parameters^.user_id, status);
    pmp$get_account_project (p_send_parameters^.account, p_send_parameters^.project, status);
    pmp$get_job_names (p_send_parameters^.user_supplied_job_name, p_send_parameters^.system_supplied_job_name,
          status);
    pmp$get_job_mode (p_send_parameters^.job_mode, status);
    dfp$locate_served_family (p_send_parameters^.user_id.family, family_found, served_family_table_index,
          family_mainframe_id, p_queue_interface_table, queue_index, server_state);
    family_access_kind := dfc$remote_file_access;
    IF family_found THEN
      IF family_mainframe_id = server_mainframe_id THEN
        IF jmp$job_is_being_leveled () THEN
          family_access_kind := dfc$job_leveling_access;
        ELSE
          family_access_kind := dfc$remote_login_access;
        IFEND;
      IFEND;
    IFEND;
    p_send_parameters^.family_access_kind := family_access_kind;
    p_send_parameters^.system_administrator := avp$system_administrator ();
    p_send_parameters^.family_administrator := avp$family_administrator ();
    p_send_parameters^.forced_reconnection := forced_reconnection;
    p_send_parameters^.job_lifetime := server_lifetime;
    parameters_length := #SIZE (p_send_parameters^);
  PROCEND build_job_begin_send_buffer;

?? TITLE := ' [INLINE] build_job_end_send_buffer ', EJECT ??

  PROCEDURE [INLINE] build_job_end_send_buffer
    (    job_server_table_exists: boolean;
         client_job_id: dft$client_job_id;
         job_is_leveled: boolean;
         job_end_info: jmt$jl_server_job_end_info;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameters_length: dft$send_parameter_size);

    VAR
      p_send_parameters: ^dft$delete_client_job_inp,
      status: ost$status,
      user_supplied_name: jmt$user_supplied_name;

    NEXT p_send_parameters IN p_send_to_server_params;

    pmp$get_job_names (user_supplied_name, p_send_parameters^.system_supplied_job_name, status);
    p_send_parameters^.client_job_table_exists := job_server_table_exists;
    p_send_parameters^.client_job_id := client_job_id;
    p_send_parameters^.job_end_info := job_end_info;
    p_send_parameters^.job_is_leveled := job_is_leveled;
    parameters_length := #SIZE (p_send_parameters^);
  PROCEND build_job_end_send_buffer;
?? TITLE := ' change_server_validation_info', EJECT ??

  PROCEDURE change_server_validation_info
    (    queue_entry_location: dft$rpc_queue_entry_location;
         queue_entry_loc_int: dft$rpc_queue_entry_loc_int;
         users_parameter_size: dft$send_parameter_size;
         client_job_id: dft$client_job_id;
     VAR status: ost$status);

    VAR
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_saved_parameters: ^SEQ ( * ),
      p_send_parameters: ^dft$change_client_job_valid_in,
      p_send_to_server_params: dft$p_send_parameters,
      user_supplied_name: jmt$user_supplied_name;

    dfp$extract_send_parameters (queue_entry_loc_int, p_send_to_server_params);
    IF users_parameter_size > 0 THEN
      PUSH p_saved_parameters: [[REP users_parameter_size OF cell]];
      i#move (p_send_to_server_params, p_saved_parameters, users_parameter_size);
    IFEND;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.client_job_id := client_job_id;
    pmp$get_job_names (user_supplied_name, p_send_parameters^.system_supplied_job_name, status);
    pmp$get_account_project (p_send_parameters^.account, p_send_parameters^.project, status);
    dfp$send_remote_procedure_call (queue_entry_location, dfc$change_job_validation_info,
          #SIZE (p_send_parameters^), 0, p_receive_from_server_params, p_receive_data, status);
    IF users_parameter_size > 0 THEN
      i#move (p_saved_parameters, p_send_to_server_params, users_parameter_size);
    IFEND;
  PROCEND change_server_validation_info;
?? TITLE := ' clear_inhibit_access_now_active', EJECT ??
{
{   The purpose of this procedure is to clear the inhibit access for any server
{ mainframe that was inactive but is now active.  For a server that was
{ awaiting recovery and is now active, the access state is changed by server
{ job recovery.  In the inactive state the only change that is made in the state
{ transistion is go go through the segment descriptor table extended and mark all
{ server files with an access_state of inhibit_access.  This is the process that
{ marks the files to allow access again.

  PROCEDURE clear_inhibit_access_now_active
    (    inhibit_access_work: dft$mainframe_set);

    VAR
      job_server_table_index: dft$job_server_table_index,
      server_mainframe_found: boolean,
      server_mainframe_id: pmt$binary_mainframe_id,
      server_mainframe_ordinal: 1 .. dfc$max_number_of_mainframes,
      server_mainframe_name: pmt$mainframe_id,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: ^dft$queue_interface_table,
      queue_index: dft$queue_index,
      status: ost$status;

  /check_all_inhibit_mainframes/
    FOR server_mainframe_ordinal := 1 TO dfc$max_number_of_mainframes DO
      IF server_mainframe_ordinal IN inhibit_access_work THEN
        server_mainframe_id := dfv$defined_server_translation [server_mainframe_ordinal];
        pmp$convert_binary_mainframe_id (server_mainframe_id, server_mainframe_name, status);
        dfp$find_mainframe_id (server_mainframe_name, { Server_to_client = } FALSE, server_mainframe_found,
              p_queue_interface_table, p_cpu_queue, queue_index, p_q_interface_directory_entry);
        IF server_mainframe_found THEN
          IF (p_cpu_queue^.queue_header.partner_status.server_state = dfc$active) THEN
            locate_jobs_server_mainframe (server_mainframe_id, server_mainframe_found,
                  job_server_table_index);
            IF NOT server_mainframe_found OR (dfv$p_job_server_table^ [job_server_table_index].
                  server_lifetime = p_cpu_queue^.queue_header.server_lifetime) THEN
              IF dfv$file_server_debug_enabled THEN
                log_display ($pmt$ascii_logset [pmc$job_log], ' Inactive server now active');;
              IFEND;
              dfp$clear_inhibit_access_work (server_mainframe_id, { Clear sdtx} TRUE);
            IFEND;
          IFEND;
        ELSE { treat as terminated
        IFEND;
      IFEND;
    FOREND /check_all_inhibit_mainframes/;
  PROCEND clear_inhibit_access_now_active;
?? TITLE := ' [INLINE] clear_job_server_table_lock ', EJECT ??

  PROCEDURE [INLINE] clear_job_server_table_lock;

    osp$clear_job_signature_lock (dfv$job_server_table_lock);
  PROCEND clear_job_server_table_lock;
?? TITLE := ' create_job_server_entry ', EJECT ??

  PROCEDURE create_job_server_entry
    (    server_mainframe_id: pmt$binary_mainframe_id;
         client_job_id: dft$client_job_id;
         server_lifetime: dft$server_lifetime;
         job_table_entry_exists: boolean;
         family_access_kind: dft$family_access_kinds;
     VAR job_server_table_index {input output} : dft$job_server_table_index);

    VAR
      actual: integer,
      ignore_status: ost$status;

    IF NOT job_table_entry_exists THEN
      get_free_job_server_table_entry (job_server_table_index);
    IFEND;

    pmp$convert_binary_mainframe_id (server_mainframe_id,
          dfv$p_job_server_table^ [job_server_table_index].server_mainframe, ignore_status);
    dfv$p_job_server_table^ [job_server_table_index].server_mainframe_id := server_mainframe_id;
    dfv$p_job_server_table^ [job_server_table_index].client_job_id := client_job_id;
    dfv$p_job_server_table^ [job_server_table_index].server_lifetime := server_lifetime;
    dfv$p_job_server_table^ [job_server_table_index].family_access_kind := family_access_kind;
    dfv$p_job_server_table^ [job_server_table_index].force_server_reconnection := FALSE;
    dfv$p_job_server_table^ [job_server_table_index].change_validation_info := FALSE;
    #SPOIL (dfv$p_job_server_table^ [job_server_table_index]);

    IF NOT job_table_entry_exists THEN
      osp$increment_locked_variable (dfv$job_server_count, dfv$job_server_count, actual);
    IFEND;
  PROCEND create_job_server_entry;

?? TITLE := 'end_job_recovery ', EJECT ??
  PROCEDURE end_job_recovery
    (    server_mainframe: pmt$mainframe_id;
         p_job_server_table_entry: ^dft$job_server_table_entry;
         server_lifetime: dft$lifetime;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT end_job_recovery;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_end_job_recovery_params: ^dft$end_job_recovery,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location,
      server_location: dft$server_location;

    status.normal := TRUE;
    IF dfv$file_server_debug_enabled THEN
      log_display ($pmt$ascii_logset [pmc$job_log], ' end_job_recovery ');
    IFEND;

    server_location.server_location_selector := dfc$mainframe_id;
    server_location.server_mainframe := server_mainframe;
    dfp$begin_ch_remote_proc_call (server_location, {send_if_deactivated=} TRUE, queue_entry_location,
          p_send_parameters, p_send_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT p_end_job_recovery_params IN p_send_parameters;
    p_end_job_recovery_params^.client_job_id := p_job_server_table_entry^.client_job_id;
    p_end_job_recovery_params^.server_lifetime := server_lifetime;
    dfp$send_remote_procedure_call (queue_entry_location, dfc$complete_job_recovery,
          #SIZE (p_end_job_recovery_params^), 0, p_receive_parameters, p_receive_data, status);
    dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
    IF status.normal OR (status.condition = pfe$not_all_pfs_recovered) THEN
      IF dfv$file_server_debug_enabled THEN
        log_display ($pmt$ascii_logset [pmc$job_log], 'Completed job_recovery ');
      IFEND;
      p_job_server_table_entry^.server_lifetime := server_lifetime;
    ELSEIF (status.condition <> dfe$server_not_active) AND
          (status.condition <> dfe$server_request_terminated) THEN
      p_job_server_table_entry^.force_server_reconnection := TRUE;
    IFEND;
  PROCEND end_job_recovery;
?? TITLE := '  get_free_job_server_table_entry  ', EJECT ??

{  PURPOSE:
{    The purpose of this procedure is
{    to get a free entry in the job server table; this includes initially
{    creating the table, expanding the table if necessary, and
{    searching for an free entry.
{    The procedure contains two nested procedures,
{      get_free_job_server_table_entry and  find_free_server_table_entry
{      followed by the main body of the code.
{
  PROCEDURE get_free_job_server_table_entry
    (VAR job_server_table_index: dft$job_server_table_index);

    CONST
      dfc$expand_server_table_amount = 3,
      dfc$initial_server_table_size = 1;

    VAR
      p_new_job_server_table: dft$p_job_server_table,
      p_old_job_server_table: dft$p_job_server_table,
      space_found: boolean,
      status: ost$status;

?? NEWTITLE := '     find_free_server_table_entry  ', EJECT ??

    PROCEDURE [INLINE] find_free_server_table_entry
      (    p_job_server_table: dft$p_job_server_table;
       VAR job_server_table_index: dft$job_server_table_index;
       VAR free_found: boolean);

      free_found := (p_job_server_table <> NIL) AND (dfv$job_server_count <
            (UPPERBOUND (p_job_server_table^)));
      IF free_found THEN
        job_server_table_index := dfv$job_server_count + 1;
      IFEND;
    PROCEND find_free_server_table_entry;
?? OLDTITLE ??
?? NEWTITLE := '     transfer_old_to_new_server_tabl   ', EJECT ??

{  PURPOSE:
{    This procedure transfers an old job server table to a new one.  The
{    new table must be equal to or larger than the old table.

    PROCEDURE transfer_old_to_new_server_tabl
      (    p_old_job_server_table: dft$p_job_server_table;
           p_new_job_server_table: dft$p_job_server_table);

      VAR
        job_server_table_index: dft$job_server_table_index;

    /copy_existing_entries/
      FOR job_server_table_index := LOWERBOUND (p_old_job_server_table^)
            TO UPPERBOUND (p_old_job_server_table^) DO
        p_new_job_server_table^ [job_server_table_index] := p_old_job_server_table^ [job_server_table_index];
      FOREND /copy_existing_entries/;

    PROCEND transfer_old_to_new_server_tabl;
?? OLDTITLE ??
?? EJECT ??
{ This is the main body of the code for procedure get_free_job_server_table_entry

    space_found := FALSE;
    IF dfv$p_job_server_table = NIL THEN
      ALLOCATE dfv$p_job_server_table: [1 .. dfc$initial_server_table_size] IN osv$job_pageable_heap^;
      find_free_server_table_entry (dfv$p_job_server_table, job_server_table_index, space_found);
    ELSE
      find_free_server_table_entry (dfv$p_job_server_table, job_server_table_index, space_found);
      IF NOT space_found THEN {expand the old table }
        ALLOCATE p_new_job_server_table: [1 .. (UPPERBOUND (dfv$p_job_server_table^) +
              dfc$expand_server_table_amount)] IN osv$job_pageable_heap^;
        transfer_old_to_new_server_tabl (dfv$p_job_server_table, p_new_job_server_table);
        p_old_job_server_table := dfv$p_job_server_table;
        dfv$p_job_server_table := p_new_job_server_table;
        FREE p_old_job_server_table IN osv$job_pageable_heap^;
        find_free_server_table_entry (dfv$p_job_server_table, job_server_table_index, space_found);
      IFEND;
    IFEND;
  PROCEND get_free_job_server_table_entry;
?? TITLE := ' inform_server_of_client_job', EJECT ??

  PROCEDURE inform_server_of_client_job
    (    queue_entry_location: dft$rpc_queue_entry_location;
         queue_entry_loc_int: dft$rpc_queue_entry_loc_int;
         users_parameter_size: dft$send_parameter_size;
         forced_reconnection: boolean;
         server_lifetime: dft$lifetime;
     VAR client_job_id: dft$client_job_id;
     VAR family_access_kind: dft$family_access_kinds;
     VAR status: ost$status);

    VAR
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_saved_parameters: ^SEQ ( * ),
      p_send_to_server_params: dft$p_send_parameters,
      parameters_length: dft$send_parameter_size;


    dfp$extract_send_parameters (queue_entry_loc_int, p_send_to_server_params);
    IF users_parameter_size > 0 THEN
      PUSH p_saved_parameters: [[REP users_parameter_size OF cell]];
      i#move (p_send_to_server_params, p_saved_parameters, users_parameter_size);
    IFEND;
    build_job_begin_send_buffer (queue_entry_loc_int.server_mainframe_id, server_lifetime,
          forced_reconnection, family_access_kind, p_send_to_server_params, parameters_length);
    dfp$send_remote_procedure_call (queue_entry_location, dfc$establish_client_job, parameters_length, 0,
          p_receive_from_server_params, p_receive_data, status);
    IF status.normal THEN
      parse_job_begin_receive_params (p_receive_from_server_params, client_job_id);
    IFEND;
    IF users_parameter_size > 0 THEN
      i#move (p_saved_parameters, p_send_to_server_params, users_parameter_size);
    IFEND;
  PROCEND inform_server_of_client_job;
?? TITLE := '  inform_server_of_client_job_end', EJECT ??

{
{  This procedure must handle the case of a delete_server of a server in the
{  job server table.
{

  PROCEDURE inform_server_of_client_job_end
    (    p_job_server_table_entry: ^dft$job_server_table_entry;
         job_is_leveled: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT inform_server_of_client_job_end;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      client_job_id: dft$client_job_id,
      context: ^ost$ecp_exception_context,
      job_end_info: jmt$jl_server_job_end_info,
      local_status: ost$status,
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: ^dft$queue_interface_table,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      p_server_state: ^dft$server_state,
      parameters_size: dft$send_parameter_size,
      queue_entry_location: dft$rpc_queue_entry_location,
      queue_index: dft$queue_index,
      server_location: dft$server_location,
      server_mainframe_id: pmt$mainframe_id;

    status.normal := TRUE;
    context := NIL;

    IF job_is_leveled THEN
      jmp$get_server_job_end_info (job_end_info);
    ELSE

{Invalidate end job info by setting id of this CLIENT mainframe into server id

      pmp$get_pseudo_mainframe_id (job_end_info.server_mainframe_id);
    IFEND;
    IF p_job_server_table_entry <> NIL THEN
      server_mainframe_id := p_job_server_table_entry^.server_mainframe;
      client_job_id := p_job_server_table_entry^.client_job_id;
    ELSE

{    It is assumed that since there is no job server table entry then the
{    job must be being leveled otherwise this procedure would not have
{    been called.

      pmp$convert_binary_mainframe_id (job_end_info.server_mainframe_id, server_mainframe_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    dfp$find_mainframe_id (server_mainframe_id, {server_to_client} FALSE, mainframe_found,
          p_queue_interface_table, p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated, '', status);
      RETURN;
    IFEND;
    IF p_job_server_table_entry <> NIL THEN
      IF p_job_server_table_entry^.server_lifetime <> p_cpu_queue^.queue_header.server_lifetime THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated, '', status);
        RETURN;
      IFEND;
    IFEND;

    server_location.server_location_selector := dfc$mainframe_id;
    server_location.server_mainframe := server_mainframe_id;
    p_server_state := ^p_cpu_queue^.queue_header.partner_status.server_state;

  /wait_for_active/
    REPEAT
      dfp$begin_ch_remote_proc_call (server_location, {send_if_deactivated} TRUE, queue_entry_location,
            p_send_parameters, p_send_data, status);
      IF osp$file_access_condition (status) THEN
        #SPOIL (p_server_state^);
        CASE p_server_state^ OF
        = dfc$active =
          CYCLE /wait_for_active/;
        = dfc$terminated =
          osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated, '', status);
          RETURN;
        = dfc$deactivated, dfc$inactive =
          ;
        = dfc$awaiting_recovery =
          { Allow the activation to remove this job
          RETURN;
        ELSE
        CASEND;
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.wait_time := job_end_notification_timeout;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
    IF status.normal THEN
      build_job_end_send_buffer (p_job_server_table_entry <> NIL, client_job_id, job_is_leveled, job_end_info,
            p_send_parameters, parameters_size);

      dfp$send_remote_procedure_call (queue_entry_location, dfc$delete_client_job, parameters_size, 0,
            p_receive_parameters, p_receive_data, status);
      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      IF (NOT status.normal) AND (status.condition = dfe$server_not_active) THEN
        status.normal := TRUE;
      IFEND;
    IFEND;
  PROCEND inform_server_of_client_job_end;

?? TITLE := ' [INLINE] locate_jobs_server_mainframe  ', EJECT ??

  PROCEDURE [INLINE] locate_jobs_server_mainframe
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR server_mainframe_found: boolean;
     VAR job_server_table_index: dft$job_server_table_index);


  /search_for_server_mainframe/
    FOR job_server_table_index := 1 TO dfv$job_server_count DO
      IF (dfv$p_job_server_table^ [job_server_table_index].server_mainframe_id = server_mainframe_id) THEN
        server_mainframe_found := TRUE;
        RETURN;
      IFEND;
    FOREND /search_for_server_mainframe/;
    server_mainframe_found := FALSE;
  PROCEND locate_jobs_server_mainframe;
?? TITLE := '  [INLINE] parse_job_begin_receive_params ', EJECT ??

  PROCEDURE [INLINE] parse_job_begin_receive_params
    (VAR p_receive_parameters: dft$p_receive_parameters;
     VAR client_job_id: dft$client_job_id);

    VAR
      p_client_job_id: ^dft$client_job_id;

    NEXT p_client_job_id IN p_receive_parameters;
    client_job_id := p_client_job_id^;
  PROCEND parse_job_begin_receive_params;
?? TITLE := ' [INLINE] set_job_server_table_lock  ', EJECT ??

  PROCEDURE [INLINE] set_job_server_table_lock;

    osp$set_job_signature_lock (dfv$job_server_table_lock);
  PROCEND set_job_server_table_lock;
?? TITLE := ' start_job_recovery', EJECT ??
  PROCEDURE start_job_recovery
    (    server_mainframe: pmt$mainframe_id;
         p_job_server_table_entry: ^dft$job_server_table_entry;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT start_job_recovery;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      global_task_id: ost$global_task_id,
      local_status: ost$status,
      p_start_job_recovery_out: ^dft$start_job_recovery_out,
      p_start_job_recovery_params: ^dft$start_job_recovery_in,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      user_supplied_name: jmt$user_supplied_name,
      queue_entry_location: dft$rpc_queue_entry_location,
      server_location: dft$server_location;

    status.normal := TRUE;
    IF dfv$file_server_debug_enabled THEN
      log_display ($pmt$ascii_logset [pmc$job_log], ' Start_job_recovery ');
      pmp$get_executing_task_gtid (global_task_id);
      log_display_integer ($pmt$ascii_logset [pmc$job_log],' global_task_id.index ', global_task_id.index);
      log_display_integer ($pmt$ascii_logset [pmc$job_log],' global_task_id.seqno ', global_task_id.seqno);
    IFEND;

    server_location.server_location_selector := dfc$mainframe_id;
    server_location.server_mainframe := server_mainframe;
    dfp$begin_ch_remote_proc_call (server_location, {send_if_deactivated=} TRUE, queue_entry_location,
          p_send_parameters, p_send_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT p_start_job_recovery_params IN p_send_parameters;
    pmp$get_job_names (user_supplied_name, p_start_job_recovery_params^.system_supplied_job_name, status);
    IF NOT status.normal THEN
      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      RETURN;
    IFEND;

    dfp$send_remote_procedure_call (queue_entry_location, dfc$initiate_job_recovery,
          #SIZE (p_start_job_recovery_params^), 0, p_receive_parameters, p_receive_data, status);
    IF status.normal THEN
      NEXT p_start_job_recovery_out IN p_receive_parameters;
      p_job_server_table_entry^.client_job_id := p_start_job_recovery_out^.client_job_id;
    IFEND;
    dfp$end_ch_remote_proc_call (queue_entry_location, local_status);

  PROCEND start_job_recovery;

MODEND dfm$job_server_manager;
*DECK DECK=DFM$KICKIT EXPAND=TRUE
 PROCEDURE dfm$kickit, kickit (
  sets, s:integer 1 .. 100 = 2
  tasks_per_job, tpj, tasks, t: integer 1 .. 20 = 1
  total_minutes, tm: integer 1 .. 1000 = 30
  wait_milliseconds, wm: integer = 10000
  update_each_loop, uel: boolean = true
  kickit_option, ko: list of key
    all
    shared
    worksetp
    bigsegp
    krunchp
    krunchn
    iotestp
    sparsep
    shadowp
  keyend = all
  job_class, jc: name = BATCH
  family_name, fn: name = TESTING
  user, u: name = EVAL
  password, pw: (SECURE) name = EVALPW
  establish_condition_handler, ech: boolean = true
  status)

  " This PROCEDURE is provided to provide testing of the the file server
  " or permanent files memory manager requests.
  " This proc submits jobs that do all of the UUTL memory manager tests, that
  " use permanent files.
  " all times here are milliseconds.  See deck osm$misc_test_commands

  var
   worksetp_option: $type(kickit_option) = (worksetp, all)
   bigsegp_option: $type(kickit_option) = (bigsegp, all)
   krunchp_option: $type(kickit_option) = (krunchp, all)
   krunchn_option: $type(kickit_option) = (krunchn, shared, all)
   iotestp_option: $type(kickit_option) = (iotestp, all)
   sparsep_option: $type(kickit_option) = (sparsep, all)
   shadowp_option: $type(kickit_option) = (shadowp, all)
 varend

   total_time =  total_minutes * 60000 " milliseconds per minute"
   total_time_string = $string(total_time)
   waittime_string =  $string(wait_milliseconds)
   page_size_string = $string($mainframe(page_size))
   family_name_string = $string(family_name)
   job_class_string = $string(job_class)
   user_string = $string(user)
   password_string = $string(password)
   handler = $string(establish_condition_handler)

   FOR i = 1 to sets DO

    " Working set test
    IF update_each_loop THEN
      readopt =  '0'
      jn = 'W'
    ELSE
      readopt =  '1'
      jn='R'
    IFEND
    tasks = $string(tasks_per_job)

    IF NOT $nil($intersection(worksetp_option,kickit_option))  THEN
    colt $local.j1   until='      END_JOB' sm='%'
      LOGIN USER=%user_string% PASSWORD=%password_string% FN=%family_name_string% ..
         JOB_CLASS=%job_class_string%
        " Workset test - pages, totaltime, waittime, readpage (<> 1 means update)
       IF %handler% THEN
         WHEN any_fault do
           reqoa ' WORKSETP%$strrep(i)% failed  '//$condition_name(osv$status.condition)
           display_value osv$status
          logout
          WHENEND
        IFEND
        FOR t = 2 TO %tasks% DO
          exet sp=uutl p='WORKSETP, 100,%total_time_string%, %waittime_string%, %readopt%' tn=$name('task'//$strrep(t))
        FOREND
        exet sp=uutl p='WORKSETP, 100,%total_time_string%, %waittime_string%, %readopt%'
      LOGOUT
      END_JOB
    submit_job $local.j1 user_job_name=$name('WORKSETP'//jn//$strrep(i))
    IFEND

    " Big segment test
    IF NOT $nil($intersection(bigsegp_option,kickit_option))  THEN
    colt $local.j1   until='      END_JOB' sm='%'
      LOGIN USER=%user_string% PASSWORD=%password_string% FN=%family_name_string% ..
         JOB_CLASS=%job_class_string%
       IF %handler% THEN
         WHEN any_fault do
           reqoa ' BIGSEGP%$strrep(i)% failed  '//$condition_name(osv$status.condition)
           display_value osv$status
          logout
          WHENEND
        IFEND
        " Bigsegp  - byte count
        FOR t = 2 TO %tasks% DO
          exet sp=uutl p='BIGSEGP, 10000000 '    tn=$name('task'//$strrep(t))
        FOREND
        exet sp=uutl p='BIGSEGP, 10000000 '
      LOGOUT
      END_JOB
    submit_job $local.j1 user_job_name=$name('BIGSEGP'//$strrep(i))
    IFEND

    " Krunch test
    IF update_each_loop THEN
      readopt =  '10'
      jn='W'
    ELSE
      readopt =  '0'
      jn='R'
    IFEND
    IF NOT $nil($intersection(krunchp_option,kickit_option))  THEN
    colt $local.j1   until='      END_JOB'  sm='%'
      LOGIN USER=%user_string% PASSWORD=%password_string% FN=%family_name_string% ..
         JOB_CLASS=%job_class_string%
        " KRUNCHP test - segments, totaltime, waittime, readopt (<> 0 means check + write randomly
       IF %handler% THEN
         WHEN any_fault do
           reqoa ' KRUNCHP%$strrep(i)% failed  '//$condition_name(osv$status.condition)
           display_value osv$status
          logout
          WHENEND
        IFEND
        FOR t = 2 TO %tasks% DO
         exet sp=uutl p='KRUNCHP, 40,%total_time_string%, %waittime_string%, %readopt%'  tn=$name('task'//$strrep(t))
        FOREND
        exet sp=uutl p='KRUNCHP, 40,%total_time_string%, %waittime_string%, %readopt%'
      LOGOUT
      END_JOB
    submit_job $local.j1 user_job_name=$name('KRUNCHP'//jn//$strrep(i))
    IFEND

    IF NOT $nil($intersection(krunchn_option,kickit_option))  THEN
    colt $local.j1   until='      END_JOB'  sm='%'
      LOGIN USER=%user_string% PASSWORD=%password_string% FN=%family_name_string%   ..
         JOB_CLASS=%job_class_string%
        " KRUNCHN test - segments, totaltime, waittime, readopt (<> 0 means check + write randomly
       IF %handler% THEN
         WHEN any_fault do
           reqoa ' KRUNCHN%$strrep(i)% failed  '//$condition_name(osv$status.condition)
           display_value osv$status
          logout
          WHENEND
        IFEND
        FOR t = 2 TO %tasks% DO
          exet sp=uutl p='KRUNCHN, 40,%total_time_string%, %waittime_string%, %readopt%'   tn=$name('task'//$strrep(t))
         FOREND
        exet sp=uutl p='KRUNCHN, 40,%total_time_string%, %waittime_string%, %readopt%'
      LOGOUT
      END_JOB
    submit_job $local.j1 user_job_name=$name('KRUNCHN'//jn//$strrep(i))
    IFEND

    IF NOT $nil($intersection(iotestp_option,kickit_option))  THEN
    " IOtest
    colt $local.j1   until='      END_JOB'  sm='%'
      LOGIN USER=%user_string% PASSWORD=%password_string% FN=%family_name_string% ..
         JOB_CLASS=%job_class_string%
        " Iotestp test - segments, totaltime, waittime, pages per seg
       IF %handler% THEN
         WHEN any_fault do
           reqoa ' IOTESTP%$strrep(i)% failed  '//$condition_name(osv$status.condition)
           display_value osv$status
          logout
          WHENEND
        IFEND
        FOR t = 2 TO %tasks% DO
          TASK RING=6   tn=$name('task'//$strrep(t))
            exet sp=uutl p='IOTESTP, 15  %total_time_string%, %waittime_string%, 20 '
          TASKEND
        FOREND
        TASK RING=6
          exet sp=uutl p='IOTESTP, 15  %total_time_string%, %waittime_string%, 20 '
        TASKEND
      LOGOUT
      END_JOB
    submit_job $local.j1 user_job_name=$name('IOTESTP'//$strrep(i))
    IFEND

    IF NOT $nil($intersection(sparsep_option,kickit_option))  THEN
    " Sparse test
    colt $local.j1   until='      END_JOB'  sm='%'
      LOGIN USER=%user_string% PASSWORD=%password_string% FN=%family_name_string%   ..
         JOB_CLASS=%job_class_string%
        " Sparse test - segments, totaltime, waittime, page size
       IF %handler% THEN
         WHEN any_fault do
           reqoa ' SPARSEP%$strrep(i)% failed  '//$condition_name(osv$status.condition)
           display_value osv$status
          logout
          WHENEND
        IFEND
        FOR t = 2 TO %tasks% DO
          exet sp=uutl p='SPARSEP, 15  %total_time_string%, %waittime_string%, %page_size_string% '  tn=$name('task'//$strrep(t))
        FOREND
        exet sp=uutl p='SPARSEP, 15  %total_time_string%, %waittime_string%, %page_size_string% '
      LOGOUT
      END_JOB
    submit_job $local.j1 user_job_name=$name('SPARSEP'//$strrep(i))
    IFEND

    IF NOT $nil($intersection(shadowp_option,kickit_option))  THEN
    " Shadow test
    colt $local.j1   until='      END_JOB'  sm='%'
      LOGIN USER=%user_string% PASSWORD=%password_string% FN=%family_name_string%     ..
         JOB_CLASS=%job_class_string%
        " Shadow test - segments, totaltime, waittime, page size
       IF %handler% THEN
         WHEN any_fault do
           reqoa ' SHADOWP%$strrep(i)% failed  '//$condition_name(osv$status.condition)
           display_value osv$status
          logout
          WHENEND
        IFEND
        pass_time = %total_time_string%/5
        FOR t = 2 TO %tasks% DO
          TASK   tn=$name('task'//$strrep(t))
          FOR pass = 1 to 5 do
            exet sp=uutl p='SHADOWP, 15, pass_time, %waittime_string%,  %page_size_string% '
          FOREND
          TASKEND
        FOREND
        FOR pass = 1 to 5 do
          exet sp=uutl p='SHADOWP, 15, pass_time, %waittime_string%,  %page_size_string% '
        FOREND
      LOGOUT
      END_JOB
    submit_job $local.j1 user_job_name=$name('SHADOWP'//$strrep(i))
    IFEND

  FOREND

 PROCEND dfm$kickit
*DECK DECK=DFM$LOG_ESM_DATA EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: log_esm_data ', EJECT ??
MODULE dfm$log_esm_data;
{
{  This module contains the processes which construct the Engineering log entry
{  for ESM/Stornet failure data.
{
?? TITLE := '    Global Declarations ', EJECT ??
*copyc dft$esm_log_data
*copyc ost$status
*copyc cml$5380_100_lsp_failure_data
*copyc cml$7040_200_lsp_failure_data
*copyc dfc$esm_driver_error_codes
*copyc oss$job_paged_literal
*copyc dfi$console_display
*copyc cmp$get_element_definition
*copyc cmp$get_element_name_via_lun
*copyc cmp$return_desc_data_by_lun_lpn
*copyc sfp$activate_system_statistic
*copyc sfp$emit_statistic
?? TITLE := '    [XDCL] dfp$log_esm_data', EJECT ??
  PROCEDURE [XDCL] dfp$log_esm_data (p_data: ^SEQ ( * );
    VAR status: ost$status);


    VAR
      counters_p: ^array [1 .. * ] of sft$counter,
      data_p: ^SEQ ( * ),
      descriptor_data: ost$string,
      element_definition: cmt$element_definition,
      element_descriptor: cmt$element_descriptor,
      esm_log_data_p: ^dft$esm_log_data,
      iou_number: dst$iou_number,
      length: integer,
      logical_unit: iot$logical_unit,
      phy_pp_number: 0 .. 31,
      pp_number: iot$pp_number,
      seq_p: ^SEQ ( * ),
      statistic_code: sft$statistic_code,
      statistics_established: [STATIC] boolean := FALSE,
      stornet_product_id: [READ, oss$job_paged_literal] cmt$product_identification
            := [' $5380', '_', '100'],
      symptom_code: integer;


    status.normal := TRUE;
    IF NOT statistics_established THEN
      establish_statistics (status);
      IF status.normal THEN
        statistics_established := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    data_p := p_data;
    NEXT esm_log_data_p IN data_p;
    pp_number := esm_log_data_p^.pp_number;
    logical_unit := esm_log_data_p^.logical_unit;

{ Get product_id.
    cmp$get_element_name_via_lun (logical_unit,
        element_descriptor.peripheral_descriptor.element_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    element_descriptor.element_type := cmc$communications_element;
    element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
    cmp$get_element_definition (element_descriptor, element_definition, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Get descriptor data.
    cmp$return_desc_data_by_lun_lpn (logical_unit, pp_number, iou_number, descriptor_data, phy_pp_number);

    length := 21;

    PUSH counters_p: [1 .. length];

    {   Set counter [1] to the PP number. Set bit 57 for an I4 concurrent PP.
    {                                     Set bits 46 - 51 to IOU number.
    {   Set counter [2] to the Channel number.  Set bit 57 if an I4 concurrent channel.
    {                                           Set bit 56 if I4 concurrent PORT B.
    {                                           Set bit 55 if I4 concurrent PORT A.
    {                                           Set bits 46 - 51 to IOU number.
    IF esm_log_data_p^.channel.concurrent THEN
      counters_p^ [1] := pp_number + 40(16);
      IF esm_log_data_p^.channel.port = cmc$port_a THEN
        counters_p^ [2] := esm_log_data_p^.channel.number + 40(16) + 100(16);
      ELSE {port_b
        counters_p^ [2] := esm_log_data_p^.channel.number + 40(16) + 80(16);
      IFEND;
    ELSE
      counters_p^ [1] := pp_number;
      counters_p^ [2] := esm_log_data_p^.channel.number;
    IFEND;
    counters_p^ [1] := counters_p^ [1] + iou_number * 1000(16);
    counters_p^ [2] := counters_p^ [2] + iou_number * 1000(16);

    counters_p^ [3] := 0;
    counters_p^ [4] := 0;

    IF element_definition.product_id = stornet_product_id THEN
      counters_p^ [5] := 1;
      statistic_code := cml$5380_100_lsp_failure_data;
    ELSE
      counters_p^ [5] := 0;
      statistic_code := cml$7040_200_lsp_failure_data;
    IFEND;

    counters_p^ [6] := 1;  {logical operation always READ}

    IF esm_log_data_p^.error_log_response.flags.unrecovered_error THEN
      counters_p^ [7] := 1;
    ELSE
      counters_p^ [7] := 0;
    IFEND;

    counters_p^ [8] := esm_log_data_p^.error_log_response.error_condition;

    counters_p^ [9] := esm_log_data_p^.error_log_response.retry_count;

    counters_p^ [10] := esm_log_data_p^.error_log_response.esm_address;

    counters_p^ [11] := esm_log_data_p^.error_log_response.transfer_byte_count DIV 8;

    counters_p^ [12] := 0; {Unused}

    counters_p^ [13] := esm_log_data_p^.error_log_response.last_ch_function;

    counters_p^ [14] := esm_log_data_p^.error_log_response.residual_byte_count;

    counters_p^ [15] := esm_log_data_p^.error_log_response.esm_lsp_status;

    IF esm_log_data_p^.error_log_response.flags.c170_dma_adapter AND
       esm_log_data_p^.error_log_response.flags.executing_adapter_io THEN
      IF esm_log_data_p^.error_log_response.flags.adapter_t_register_loaded THEN
        counters_p^ [16] := (esm_log_data_p^.error_log_response.initial_adapter_t_register
           .byte_count * 100000000(16)) + esm_log_data_p^.error_log_response
           .initial_adapter_t_register.cm_address;
        counters_p^ [21] := (esm_log_data_p^.error_log_response.adapter_t_register.byte_count * 100000000(16))
            + esm_log_data_p^.error_log_response.adapter_t_register.cm_address;
      ELSE
        counters_p^ [16] := -1;
        counters_p^ [21] := -1;
      IFEND;
      counters_p^ [17] := esm_log_data_p^.error_log_response.adapter_control_register;
      counters_p^ [18] := esm_log_data_p^.error_log_response.adapter_op_status_register;
      counters_p^ [19] := esm_log_data_p^.error_log_response.adapter_error_status;
      counters_p^ [20] := 2; {PP word counter always 2}
    ELSE { Driver not C170 DMA Adapter mode.
      counters_p^ [16] := -1;
      counters_p^ [17] := -1;
      counters_p^ [18] := -1;
      counters_p^ [19] := -1;
      counters_p^ [20] := -1;
      counters_p^ [21] := -1;
    IFEND;

    emit_statistic (statistic_code, counters_p, descriptor_data, esm_log_data_p, status);

  PROCEND dfp$log_esm_data;
?? TITLE := '    emit_statistic', EJECT ??
  PROCEDURE emit_statistic
    (    statistic_code: sft$statistic_code;
         counters_p: ^array [1 .. * ] OF sft$counter;
         descriptor_data: ost$string;
         esm_log_data_p: ^dft$esm_log_data;
     VAR status: ost$status);


    VAR
      k: integer,
      m_length: integer,
      message_p: ^string ( * ),
      size: integer;


    status.normal := TRUE;

{ Combine descriptor data with class and symptom message.

    size := descriptor_data.size;
    m_length := size + 4 + dfc$symptom_message_length;
    PUSH message_p: [m_length];
    message_p^ (1, size) := descriptor_data.value;
    k := size + 1;
    CASE counters_p^ [7] OF
    = 0 =
      message_p^ (k, 4) := '.RF.';
    = 1 =
      message_p^ (k, 4) := '.UF.';
    ELSE
    CASEND;
    k := k + 4;
    message_p^ (k, * ) := esm_log_data_p^.symptom_message;
    IF counters_p^ [5] = 1 THEN
      message_p^ (k+6 , 4) := '7302'; {element id was $5380_100}
    ELSE
      message_p^ (k+6 , 4) := '7303'; {element id was $7040_200}
    IFEND;

    sfp$emit_statistic (statistic_code, message_p^, counters_p, status);

    display_to_console (message_p^);

  PROCEND emit_statistic;
?? TITLE := '    establish_statistics ', EJECT ??
  PROCEDURE establish_statistics (VAR status: ost$status);

    CONST
      number_of_statistics = 2;

    VAR
      statistics: array [1 .. number_of_statistics] of sft$statistic_code,
      i: integer;


    statistics [1] := cml$5380_100_lsp_failure_data;
    statistics [2] := cml$7040_200_lsp_failure_data;

    FOR i := 1 TO number_of_statistics DO
      sfp$activate_system_statistic (statistics [i], $sft$binary_logset [pmc$engineering_log], status);
      IF status.normal = FALSE THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND establish_statistics;

MODEND dfm$log_esm_data;
*DECK DECK=DFM$LOG_SDP_DATA EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: log_sdp_data ', EJECT ??
MODULE dfm$log_sdp_data;

{
{  This module contains the processes which construct the System Engineering
{  Log entry for STORNET/ESM side door port Error Log data.
{

?? TITLE := '    Global Definitions ', EJECT ??
*copyc clp$convert_integer_to_string
*copyc cml$5380_100_sdp_failure_data
*copyc cml$7040_200_sdp_failure_data
*copyc cmt$product_identification
*copyc dfi$display
*copyc dfi$log_display
*copyc dfv$file_server_debug_enabled
*copyc oss$job_paged_literal
*copyc ost$status
*copyc pmp$get_compact_date_time
*copyc pmp$zero_out_table
*copyc sfp$activate_system_statistic
*copyc sfp$emit_statistic
?? TITLE := '    Global Declarations ', EJECT ??
*copyc dfc$sdp_driver_error_codes
*copyc dfc$sdp_logging_error_codes
*copyc dft$descriptive_data_descriptor
*copyc dft$sdp_communication_buffer
*copyc dft$sdp_logging_code
?? TITLE := '    build_descriptive_data_message ', EJECT ??

{
{ PURPOSE:
{ This procedure builds the descriptive data portion of the STORNET/ESM
{ statistic.
{

  PROCEDURE build_descriptive_data_message
    (    reason: dft$sdp_logging_code;
         log_data_p: ^dft$sdp_communication_buffer;
         descriptive_data_descriptor: dft$descriptive_data_descriptor;
     VAR communication_buffer_p: ^dft$sdp_communication_buffer;
     VAR descriptive_data_message: ost$string;
     VAR symptom_code: integer;
     VAR status: ost$status);

    VAR
      integer_string: ost$string,
      temporary_string: ost$string,
      symptom_code_message_text: [STATIC, READ, oss$job_paged_literal] array [
            0 .. dfc$max_sdp_logging_error_code - 1] of ost$string :=
            [[52, 'ERR=VP73000000, SIDE DOOR PORT INITIALIZATION STATUS'],
             [49, 'ERR=VP73000001, SIDE DOOR PORT TOP OF HOUR STATUS'],
             [51, 'ERR=VP73000002, SIDE DOOR PORT CHANNEL ACTIVE ERROR'],
             [54, 'ERR=VP73000003, SIDE DOOR PORT NO INACTIVE TO FUNCTION'],
             [49, 'ERR=VP73000004, SIDE DOOR PORT LOST DATA ON INPUT'],
             [51, 'ERR=VP73000005, SIDE DOOR PORT CHANNEL PARITY ERROR'],
             [48, 'ERR=VP73000006, SIDE DOOR PORT CHANNEL NOT EMPTY'],
             [53, 'ERR=VP73000007, SIDE DOOR PORT CHANNEL LOCKWORD ERROR'],
             [0, ''], [0, ''], [0, ''], [0, ''], [0, ''], [0, ''],
             [0, ''], [0, ''], [0, ''], [0, ''], [0, ''], [0, ''],
             [54, 'ERR=VP73000020, SIDE DOOR PORT NO INITIALIZATION ERROR'],
             [54, 'ERR=VP73000021, SIDE DOOR PORT CHANNEL STATE INCORRECT'],
             [50, 'ERR=VP73000022, SIDE DOOR PORT CHANNEL UNAVAILABLE'],
             [45, 'ERR=VP73000023, SIDE DOOR PORT PP UNAVAILABLE'],
             [47, 'ERR=VP73000024, SIDE DOOR PORT NO SDPD RESPONSE']];

{
{ Validate log_data_p.
{

    IF log_data_p <> NIL THEN
      communication_buffer_p := log_data_p;
    IFEND;

{
{ Build the descriptive data message portion of the statistic.
{
{ <mainframe>.

    descriptive_data_message.value (1, STRLENGTH (descriptive_data_descriptor.mainframe)) :=
          descriptive_data_descriptor.mainframe;
    descriptive_data_message.size := STRLENGTH (descriptive_data_descriptor.mainframe);
    descriptive_data_message.value (descriptive_data_message.size + 1, 1) := '.';
    descriptive_data_message.size := descriptive_data_message.size + 1;

{ <iou>.

    temporary_string.value := descriptive_data_descriptor.iou;
    set_string_length (temporary_string);
    descriptive_data_message.value ((descriptive_data_message.size + 1),
          temporary_string.size) := temporary_string.value;
    descriptive_data_message.size := descriptive_data_message.size + temporary_string.size;
    descriptive_data_message.value (descriptive_data_message.size + 1, 1) := '.';
    descriptive_data_message.size := descriptive_data_message.size + 1;

{ <pp>.

    IF log_data_p = NIL THEN
      temporary_string.value := descriptive_data_descriptor.pp;
      set_string_length (temporary_string);
      descriptive_data_message.value ((descriptive_data_message.size + 1),
            temporary_string.size) := temporary_string.value;
      descriptive_data_message.size := descriptive_data_message.size + temporary_string.size;
    ELSE
      IF communication_buffer_p^.word_one.concurrent_pp = 1 THEN
        descriptive_data_message.value (descriptive_data_message.size + 1, 3) := 'CPP';
        descriptive_data_message.size := descriptive_data_message.size + 3;
      ELSE
        descriptive_data_message.value (descriptive_data_message.size + 1, 2) := 'PP';
        descriptive_data_message.size := descriptive_data_message.size + 2;
      IFEND;
      clp$convert_integer_to_string (communication_buffer_p^.word_one.pp_number, 10, FALSE, integer_string,
            status);
      descriptive_data_message.value (descriptive_data_message.size + 1,
            integer_string.size) := integer_string.value;
      descriptive_data_message.size := descriptive_data_message.size + integer_string.size;
    IFEND;
    descriptive_data_message.value (descriptive_data_message.size + 1, 1) := '.';
    descriptive_data_message.size := descriptive_data_message.size + 1;

{ <ch>.

    temporary_string.value := descriptive_data_descriptor.ch;
    set_string_length (temporary_string);
    descriptive_data_message.value ((descriptive_data_message.size + 1),
          temporary_string.size) := temporary_string.value;
    descriptive_data_message.size := descriptive_data_message.size + temporary_string.size;
    descriptive_data_message.value (descriptive_data_message.size + 1, 1) := '.';
    descriptive_data_message.size := descriptive_data_message.size + 1;

{ <element>*

    temporary_string.value := descriptive_data_descriptor.element;
    set_string_length (temporary_string);
    descriptive_data_message.value ((descriptive_data_message.size + 1),
          temporary_string.size) := temporary_string.value;
    descriptive_data_message.size := descriptive_data_message.size + temporary_string.size;
    descriptive_data_message.value (descriptive_data_message.size + 1, 1) := '*';
    descriptive_data_message.size := descriptive_data_message.size + 1;

{ <message>
{
{ Determine symptom code for reference of symptom code message text.

    IF descriptive_data_descriptor.symptom_code > dfc$sdp_no_initialization_error THEN
      symptom_code := descriptive_data_descriptor.symptom_code;
      communication_buffer_p^.word_one.ppu_status := symptom_code;
    ELSEIF communication_buffer_p^.word_one.ppu_status > dfc$sdpd_normal_completion THEN
      symptom_code := communication_buffer_p^.word_one.ppu_status;
    ELSE
      symptom_code := $INTEGER (reason);
    IFEND;
    descriptive_data_message.value (descriptive_data_message.size + 1,
          symptom_code_message_text [symptom_code].size) := symptom_code_message_text [symptom_code].value;
    IF descriptive_data_descriptor.product_id.product_number = ' $7040' THEN
      descriptive_data_message.value (descriptive_data_message.size + 10, 1) := '1';
    IFEND;
    descriptive_data_message.size := descriptive_data_message.size +
          symptom_code_message_text [symptom_code].size;
  PROCEND build_descriptive_data_message;
?? TITLE := '    establish_statistics ', EJECT ??

{
{ PURPOSE:
{ This procedure activates the STORNET/ESM side door port logging statistics
{ (CM7300 & CM7301) in the system.
{

  PROCEDURE establish_statistics
    (    reason: dft$sdp_logging_code;
         descriptive_data_descriptor: dft$descriptive_data_descriptor;
     VAR statistic_code: sft$statistic_code;
     VAR status: ost$status);

    CONST
      number_of_statistics = 2;

    VAR
      statistics: array [1 .. number_of_statistics] of sft$statistic_code,
      statistic: integer;

{
{ Specify statistic code from product identification of the STORNET/ESM
{ memory device.
{

    IF descriptive_data_descriptor.product_id.product_number = ' $5380' THEN
      statistic_code := cml$5380_100_sdp_failure_data;
    ELSE
      statistic_code := cml$7040_200_sdp_failure_data;
    IFEND;

{
{ Establish statistic codes for the STORNET/ESM memory device.
{

    IF reason = dfc$sdp_initialization THEN
      statistics [1] := cml$5380_100_sdp_failure_data;
      statistics [2] := cml$7040_200_sdp_failure_data;
      FOR statistic := 1 TO number_of_statistics DO
        sfp$activate_system_statistic (statistics [statistic], $sft$binary_logset [pmc$engineering_log],
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;
  PROCEND establish_statistics;
?? TITLE := '    set_string_length ', EJECT ??

{
{ PURPOSE:
{   This procedure finds the length of a string that is passed in as a parameter.  It also removes
{   any spaces that are at the beginning and at the end of the string.
{

  PROCEDURE set_string_length
    (VAR string_data: ost$string);

    VAR
      begin_index: ost$string_size,
      end_index: ost$string_size,
      temp_string: string (osc$max_string_size);

{
{ If the string is all blank set the string length to one and return.
{

    IF string_data.value = ' ' THEN
      string_data.size := 1;
      RETURN;
    IFEND;

{
{ Find the first non-blank character in the string.
{

    begin_index := 1;
    WHILE (begin_index <= osc$max_string_size) AND (string_data.value (begin_index) = ' ') DO
      begin_index := begin_index + 1;
    WHILEND;

{
{ Find the last non-blank character in the string.
{

    end_index := osc$max_string_size;
    WHILE (end_index > begin_index) AND (string_data.value (end_index) = ' ') DO
      end_index := end_index - 1;
    WHILEND;

{
{ Move the data in the string so the first non-blank character is the first character in the string and
{ determine the size of the string from the first non-blank character to the last non-blank character.
{

    temp_string := string_data.value;
    string_data.value := temp_string (begin_index, (end_index - begin_index) + 1);
    string_data.size := (end_index - begin_index) + 1;
  PROCEND set_string_length;
?? TITLE := '    [XDCL] dfp$log_sdp_data', EJECT ??

{
{ PURPOSE:
{ This procedure emits STORNET/ESM side door port logging statistics (CM7300 &
{ CM7301 respectively) into the system Engineering Log.
{

  PROCEDURE [XDCL] dfp$log_sdp_data
    (    reason: dft$sdp_logging_code;
         log_data_p: ^dft$sdp_communication_buffer;
         descriptive_data_descriptor: dft$descriptive_data_descriptor;
     VAR status: ost$status);

    VAR
      communication_buffer_p: ^dft$sdp_communication_buffer,
      counters_p: sft$counters,
      date_time_p: ^ost$date_time,
      descriptive_data_message: ost$string,
      sdp_communications_p: ^dft$sdp_communication_buffer,
      statistic_code: sft$statistic_code,
      statistic_data_sequence_p: ^SEQ ( * ),
      statistic_data_size: integer,
      symptom_code: integer;

    status.normal := TRUE;

{
{ Establish statistics for STORNET/ESM side door port logging (CM7300 &
{ CM7301 respectively).
{

    establish_statistics (reason, descriptive_data_descriptor, statistic_code, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{
{ Build the descriptive data message portion of this statistic as follows:
{ <mainframe>.<iou>.<pp>.<ch>.<element>*<message>
{

    PUSH communication_buffer_p;
    pmp$zero_out_table (communication_buffer_p, #SIZE (dft$sdp_communication_buffer));
    build_descriptive_data_message (reason, log_data_p, descriptive_data_descriptor, communication_buffer_p,
          descriptive_data_message, symptom_code, status);

{
{ Create a SEQ to use to build the data to place in the statistic counters.
{
{ Statistic Counters Format:
{ Set counter [1] to DATE/TIME Stamp.
{ Set counter [2] to Analysis Code.
{ Set counter [3] to STORNET/ESM SDP Path.
{ Set counter [4] to STORNET/ESM Error Logs.
{       .                    .
{       .                    .
{ Set counter [20] to STORNET/ESM Error Logs.
{

    statistic_data_size := #SIZE (ost$date_time) + #SIZE (dft$sdp_communication_buffer);
    PUSH statistic_data_sequence_p: [[REP statistic_data_size OF cell]];
    RESET statistic_data_sequence_p;
    NEXT date_time_p IN statistic_data_sequence_p;
    pmp$get_compact_date_time (date_time_p^, status);
    NEXT sdp_communications_p IN statistic_data_sequence_p;
    sdp_communications_p^ := communication_buffer_p^;
    RESET statistic_data_sequence_p;
    NEXT counters_p: [1 .. (statistic_data_size DIV 8)] IN statistic_data_sequence_p;

{
{ The communication_buffer_p.word_zero data is superfluous, an integer symptom
{ code is required.
{

    counters_p^ [2] := symptom_code;

{
{ Emit a statistic to the System Engineering Log via a call to system
{ interface SFP$EMIT_STATISTIC.
{

    sfp$emit_statistic (statistic_code, descriptive_data_message.value (1, descriptive_data_message.size),
          counters_p, status);
    IF dfv$file_server_debug_enabled THEN
      display (descriptive_data_message.value (1, descriptive_data_message.size));
      log_display ($pmt$ascii_logset [pmc$system_log, pmc$job_log],
            descriptive_data_message.value (1, descriptive_data_message.size));
    IFEND;
  PROCEND dfp$log_sdp_data;
MODEND dfm$log_sdp_data;
*DECK DECK=DFM$LOG_SIDE_DOOR_PORT_STATUS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: log_side_door_port_status ', EJECT ??
MODULE dfm$log_side_door_port_status;

{
{  This module contains the processes which capture STORNET/ESM side
{  door port status and initiates generation of the system Engineering
{  Log entry.
{

?? TITLE := '    Global Definitions ', EJECT ??
*copyc cmp$execute_pp_program
*copyc cmp$get_channel_definition
*copyc cmp$get_element_information
*copyc cmp$get_iou_definition
*copyc cmp$idle_pp
*copyc cmp$release_element
*copyc cmp$reserve_element
*copyc dfe$error_condition_codes
*copyc dfi$log_display
*copyc dfp$log_sdp_data
*copyc dfp$return_esm_definition
*copyc dfp$return_esms_defined
*copyc pmp$get_mainframe_id
*copyc pmp$get_microsecond_clock
*copyc osp$await_activity_completion
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
?? TITLE := '    Global Declarations ', EJECT ??
*copyc dfc$sdp_logging_error_codes
*copyc dft$descriptive_data_descriptor
*copyc dft$sdp_communication_buffer
*copyc dft$sdp_logging_code

?? TITLE := '    acquire_channel_for_sdpd ', EJECT ??

{
{ PURPOSE:
{ This procedure reserves the STORNET/ESM side door port channel from NOS/VE.
{

  PROCEDURE acquire_channel_for_sdpd
    (    current_port_in_definition: 1 .. cmc$max_side_door_port_number;
         stornet_esm_element_definition: cmt$esm_definition;
     VAR sdp_channel_reservation: array [1 .. 1] of cmt$element_reservation;
     VAR sdp_channel_reserved: boolean;
     VAR status: ost$status);

    sdp_channel_reserved := FALSE;

{
{ Build a channel descriptor of the STORNET/ESM side door port channel
{ element name.  This descriptor is used to acquire a channel resource
{ from NOSE/VE.
{

    sdp_channel_reservation [1].element_type := cmc$data_channel_element;
    sdp_channel_reservation [1].channel_descriptor.iou := stornet_esm_element_definition.
          side_door_port [current_port_in_definition].iou;
    sdp_channel_reservation [1].channel_descriptor.use_logical_identification := TRUE;
    sdp_channel_reservation [1].channel_descriptor.name := stornet_esm_element_definition.
          side_door_port [current_port_in_definition].element_name;
    cmp$reserve_element (sdp_channel_reservation, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    sdp_channel_reserved := TRUE;
  PROCEND acquire_channel_for_sdpd;
?? TITLE := '    acquire_pp_for_sdpd ', EJECT ??

{
{ PURPOSE:
{ This procedure reserves a PPU having access to the STORNET/ESM side door
{ port channel from NOS/VE.
{

  PROCEDURE acquire_pp_for_sdpd
    (    sdp_channel_definition: cmt$data_channel_definition;
     VAR sdp_pp_reservation: array [1 .. 1] of cmt$element_reservation;
     VAR sdp_pp_identification: cmt$pp_identification;
     VAR sdp_pp_reserved: boolean;
     VAR status: ost$status);

    sdp_pp_reserved := FALSE;

{
{ Build a channel descriptor for the STORNET/ESM side door port channel.
{ This descriptor is used to acquire a PP resource from NOSE/VE.
{

    sdp_pp_reservation [1].element_type := cmc$pp_element;
    sdp_pp_reservation [1].pp_reservation.selector := cmc$choose_pp_by_channel;
    sdp_pp_reservation [1].pp_reservation.channel.ordinal := sdp_channel_definition.ordinal;
    sdp_pp_reservation [1].pp_reservation.channel.iou := sdp_channel_definition.iou;
    cmp$reserve_element (sdp_pp_reservation, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    sdp_pp_identification := sdp_pp_reservation [1].pp_reservation.acquired_pp_identification;
    sdp_pp_reserved := TRUE;
  PROCEND acquire_pp_for_sdpd;
?? TITLE := '    await_activity_completion ', EJECT ??

{
{ Procedure AWAIT_ACTIVITY_COMPLETION is used to wait for SDPD driver
{ completion of side door port error log processing.  WAIT_LIMIT is used
{ to specify a time interval in milliseconds of how long the procedure
{ will wait before returning to its caller.  If the elapsed time during
{ which the procedure has been waiting for activity completion reaches
{ the value of this time interval, TIMEOUT is set to TRUE and the procedure
{ returns.
{
{ During the wait for activity completion, the procedure samples PP_STATUS
{ at periodic intervals.  The period of these intervals is specified in
{ milliseconds in WAIT_FIXED_QUERY_INTERVAL.  Between the queries of PP_STATUS
{ the CPU resource is released to the operating system.  If, at a given query,
{ PP_STATUS indicates that the activity is complete, the procedure returns
{ to its caller.
{
{ There are two ways an exit from the above timeout loop can occur:
{  1) condition tested is active or
{  2) timeout has occurred.
{

  PROCEDURE await_activity_completion
    (    communication_buffer_p: ^dft$sdp_communication_buffer;
     VAR descriptive_data_descriptor: dft$descriptive_data_descriptor;
     VAR status: ost$status);

    CONST
      wait_limit = 4000, { 4 seconds }
      fixed_wait_query_interval = 50; { 50 milliseconds }

    VAR
      ready_index: integer,
      running_time: integer,
      starting_time: integer,
      timeout: boolean,
      wait_list: array [1 .. 1] of ost$activity;

    wait_list [1].activity := osc$await_time;
    wait_list [1].milliseconds := fixed_wait_query_interval;
    pmp$get_microsecond_clock (starting_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{
{ Begin timeout of SDPD driver response to detect PP/SDPD driver hangs.
{

    timeout := FALSE;

  /timeout_loop/
    WHILE ((communication_buffer_p^.word_one.ppu_status = 0) AND (NOT timeout)) DO
      osp$await_activity_completion (wait_list, ready_index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF communication_buffer_p^.word_one.ppu_status <> 0 THEN
        EXIT /timeout_loop/;
      IFEND;
      pmp$get_microsecond_clock (running_time, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF running_time < starting_time THEN
        starting_time := running_time;
        CYCLE /timeout_loop/;
      ELSEIF running_time - starting_time > wait_limit * 1000 THEN

{ No response from SDPD driver so assume a hang condition exits.

        descriptive_data_descriptor.symptom_code := dfc$sdp_no_sdpd_response;
        timeout := TRUE;
      IFEND;
    WHILEND /timeout_loop/;
  PROCEND await_activity_completion;
?? TITLE := '    build_descriptive_data_desc ', EJECT ??

  PROCEDURE build_descriptive_data_desc
    (    current_port_in_definition: 1 .. cmc$max_side_door_port_number;
         stornet_esm_element_definition: cmt$esm_definition;
     VAR descriptive_data_descriptor: dft$descriptive_data_descriptor);

{
{ Build a descriptive data descriptor to use in the generation of the
{ descriptive message portion in a statistic.
{

    descriptive_data_descriptor.mainframe := stornet_esm_element_definition.
          side_door_port [current_port_in_definition].mainframe_ownership;
    descriptive_data_descriptor.iou := stornet_esm_element_definition.
          side_door_port [current_port_in_definition].iou;
    descriptive_data_descriptor.pp := '0';
    descriptive_data_descriptor.ch := stornet_esm_element_definition.
          side_door_port [current_port_in_definition].element_name;
    descriptive_data_descriptor.element := stornet_esm_element_definition.element_name;
    descriptive_data_descriptor.product_id := stornet_esm_element_definition.product_id;
    descriptive_data_descriptor.symptom_code := dfc$sdp_no_initialization_error;
  PROCEND build_descriptive_data_desc;
?? TITLE := '    establish_sdpd_communications ', EJECT ??

{
{ PURPOSE:
{ This procedure is used to establish communications between the CPU and the
{ and the SDPD PP driver.  All communications are through the SDPD PP
{ Communication Buffer.
{

  PROCEDURE establish_sdpd_communications
    (    sdp_channel_definition: cmt$data_channel_definition;
         sdp_pp_identification: cmt$pp_identification;
     VAR sdpd_communications_p: ^SEQ ( * );
     VAR communication_buffer_p: ^dft$sdp_communication_buffer;
     VAR status: ost$status);

    CONST
      initialization_complete = 1;

    RESET sdpd_communications_p;
    NEXT communication_buffer_p IN sdpd_communications_p;
    IF communication_buffer_p = NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_parameter_pva, 'communication_buffer_p',
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'establish_sdpd_communications', status);
      RETURN;
    IFEND;

{
{ Initialize the SDPD Communication Buffer used to communicate between the
{ CPU and PPU.  All data structures are explicitly reset.
{

    initialize_communication_buffer (sdp_channel_definition, sdp_pp_identification, communication_buffer_p,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{
{ Inform SDPD that the CPU has completed its initialization of the SDPD
{ Communication Buffer and is ready to communicate via codes stored in
{ PPU_STATUS and is ready to receive side door port status.
{

    communication_buffer_p^.word_zero.cpu_status := initialization_complete;
  PROCEND establish_sdpd_communications;
?? TITLE := '    find_side_door_port_channel ', EJECT ??

{
{ PURPOSE:
{ Build a channel element descriptor for each STORNET/ESM channel element
{ name.  This descriptor is used to obtain side door port channel status.
{ Channel status is searched for the state of CMC$ON.
{

  PROCEDURE find_side_door_port_channel
    (    reason: dft$sdp_logging_code;
         current_port_in_definition: 1 .. cmc$max_side_door_port_number;
         host_mainframe_id: pmt$mainframe_id;
         stornet_esm_element_definition: cmt$esm_definition;
     VAR descriptive_data_descriptor: dft$descriptive_data_descriptor;
     VAR sdp_channel_definition: cmt$data_channel_definition;
     VAR side_door_port_channel_found: boolean;
     VAR status: ost$status);

    VAR
      sdp_channel_element_descriptor: cmt$element_descriptor,
      sdp_channel_element_information: array [1 .. 1] of cmt$element_info_item;

    side_door_port_channel_found := FALSE;

{
{ Build a channel element descriptor for each STORNET/ESM channel element
{ name.  This descriptor is used to obtain side door port channel status.
{

    IF ((stornet_esm_element_definition.side_door_port [current_port_in_definition].configured) AND
          (stornet_esm_element_definition.side_door_port [current_port_in_definition].mainframe_ownership =
          host_mainframe_id)) THEN
      build_descriptive_data_desc (current_port_in_definition, stornet_esm_element_definition,
            descriptive_data_descriptor);

{
{ Control is given to the following statements when a side door port channel
{ has been identified in upline connection information for the STORNET/ESM
{ element.
{

      sdp_channel_element_descriptor.element_type := cmc$data_channel_element;
      sdp_channel_element_descriptor.channel_descriptor.iou := stornet_esm_element_definition.
            side_door_port [current_port_in_definition].iou;
      sdp_channel_element_descriptor.channel_descriptor.use_logical_identification := TRUE;
      sdp_channel_element_descriptor.channel_descriptor.name :=
            stornet_esm_element_definition.side_door_port [current_port_in_definition].element_name;

{
{ Obtain channel status for each STORNET/ESM side door port channel element
{ name via a call to system interface CMP$GET_ELEMENT_INFORMATION.
{

      sdp_channel_element_information [1].selector := cmc$element_status;
      cmp$get_element_information (sdp_channel_element_descriptor, sdp_channel_element_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF ((sdp_channel_element_information [1].item_returned) AND
            (sdp_channel_element_information [1].element_status.state = cmc$on)) THEN
        get_sdp_channel_definition (current_port_in_definition, stornet_esm_element_definition,
              sdp_channel_definition, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        side_door_port_channel_found := TRUE;
      ELSE
        descriptive_data_descriptor.symptom_code := dfc$sdp_channel_incorrect_state;
        dfp$log_sdp_data (reason, NIL, descriptive_data_descriptor, status);
      IFEND;
    IFEND;
  PROCEND find_side_door_port_channel;
?? TITLE := '    get_pp_number ', EJECT ??

{
{ PURPOSE:
{ This procedure is used to convert a CMC$PP ordinal to a physical PP number.
{

  PROCEDURE get_pp_number
    (    sdp_pp_identification: cmt$pp_identification;
     VAR pp_number: ost$physical_pp_number;
     VAR pp_concurrent: boolean);

    CONST
      cio_pp_threshold_value = 20;

{
{ Convert a PP ordinal to a physical PP number.
{

    IF $INTEGER (sdp_pp_identification.ordinal) >= cio_pp_threshold_value + 10 THEN
      pp_number := $INTEGER (sdp_pp_identification.ordinal) - cio_pp_threshold_value + 6;
      pp_concurrent := TRUE;
    ELSEIF $INTEGER (sdp_pp_identification.ordinal) >= cio_pp_threshold_value THEN
      pp_number := $INTEGER (sdp_pp_identification.ordinal) - cio_pp_threshold_value;
      pp_concurrent := TRUE;
    ELSEIF $INTEGER (sdp_pp_identification.ordinal) > 9 THEN
      pp_number := $INTEGER (sdp_pp_identification.ordinal) + 6;
      pp_concurrent := FALSE;
    ELSE
      pp_number := $INTEGER (sdp_pp_identification.ordinal);
      pp_concurrent := FALSE;
    IFEND;
  PROCEND get_pp_number;
?? TITLE := '    get_sdp_channel_definition ', EJECT ??

{
{ PURPOSE:
{ This procedure is used to obatain a channel definition of the STORNET/ESM
{ side door port channel element name.
{

  PROCEDURE get_sdp_channel_definition
    (    current_port_in_definition: 1 .. cmc$max_side_door_port_number;
         stornet_esm_element_definition: cmt$esm_definition;
     VAR sdp_channel_definition: cmt$data_channel_definition;
     VAR status: ost$status);

    VAR
      sdp_channel_descriptor: cmt$channel_descriptor;

{
{ Build a channel descriptor of the STORNET/ESM side door port channel.
{

    sdp_channel_descriptor.iou := stornet_esm_element_definition.side_door_port [current_port_in_definition].
          iou;
    sdp_channel_descriptor.use_logical_identification := TRUE;
    sdp_channel_descriptor.name := stornet_esm_element_definition.side_door_port [current_port_in_definition].
          element_name;

{
{ Obtain a channel definition of the STORNET/ESM side door port channel
{ element name via a call to CMP$GET_CHANNEL_DEFINITION.
{

    cmp$get_channel_definition (sdp_channel_descriptor, sdp_channel_definition, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
  PROCEND get_sdp_channel_definition;
?? TITLE := '    get_stornet_esm_definition ', EJECT ??

{
{ PURPOSE:
{ This procedure is used to obtain side door port channel information for each
{ STORNET/ESM element name.
{

  PROCEDURE get_stornet_esm_definition
    (    current_element: integer;
         stornet_esm_element_names: dft$esms_defined;
     VAR stornet_esm_element_definition: cmt$esm_definition;
     VAR status: ost$status);

    VAR
      stornet_esm_element_descriptor: cmt$element_descriptor;

{
{ Build an element descriptor for each STORNET/ESM element name.  This
{ descriptor is used to obtain side door port channel information.
{

    stornet_esm_element_descriptor.element_type := cmc$communications_element;
    stornet_esm_element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
    stornet_esm_element_descriptor.peripheral_descriptor.element_name :=
          stornet_esm_element_names [current_element];

{
{ Obtain side door port channel information for each STORNET/ESM element name
{ via a call to system interface DFP$RETURN_ESM_DEFINITION.
{

    dfp$return_esm_definition (stornet_esm_element_descriptor, stornet_esm_element_definition, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
  PROCEND get_stornet_esm_definition;
?? TITLE := '    get_type_of_iou ', EJECT ??

{
{ PURPOSE:
{ This procedure is used to get the IOU definition for this mainframe.
{

  PROCEDURE get_type_of_iou
    (    sdp_pp_identification: cmt$pp_identification;
     VAR type_of_iou: 0 .. 1;
     VAR status: ost$status);

    CONST
      i0_iou = 0,
      all_other_ious = 1;

    VAR
      iou_definition: cmt$iou_definition;

    cmp$get_iou_definition (sdp_pp_identification.iou, iou_definition, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF iou_definition.kind = dsc$imn_i0_5x_model THEN
      type_of_iou := i0_iou;
    ELSE
      type_of_iou := all_other_ious;
    IFEND;
  PROCEND get_type_of_iou;
?? TITLE := '    initialize_communication_buffer ', EJECT ??

{
{ PURPOSE:
{ This procedure performs initialization of the SDPD Communication Buffer used
{ as the communication mechanism between the CPU and the PPU.  All data
{ structures are explicitly reset.
{

  PROCEDURE initialize_communication_buffer
    (    sdp_channel_definition: cmt$data_channel_definition;
         sdp_pp_identification: cmt$pp_identification;
     VAR communication_buffer_p: ^dft$sdp_communication_buffer;
     VAR status: ost$status);

    CONST
      iou0 = 0,
      iou1 = 1;

    VAR
      pp_concurrency: boolean,
      pp_number: ost$physical_pp_number,
      type_of_iou: 0 .. 1;

    get_pp_number (sdp_pp_identification, pp_number, pp_concurrency);
    get_type_of_iou (sdp_pp_identification, type_of_iou, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    communication_buffer_p^.word_zero.cpu_status := 0(16);
    communication_buffer_p^.word_zero.iou_type := type_of_iou;
    communication_buffer_p^.word_zero.channel_number := sdp_channel_definition.number;
    communication_buffer_p^.word_zero.reserved := 0(16);
    communication_buffer_p^.word_one.ppu_status := 0(16);
    IF pp_concurrency THEN
      communication_buffer_p^.word_one.concurrent_pp := 1;
    ELSE
      communication_buffer_p^.word_one.concurrent_pp := 0;
    IFEND;
    communication_buffer_p^.word_one.pp_number := pp_number;
    IF sdp_channel_definition.iou = 'IOU0' THEN
      communication_buffer_p^.word_one.iou_number := iou0;
    ELSE
      communication_buffer_p^.word_one.iou_number := iou1;
    IFEND;
    IF sdp_channel_definition.concurrent THEN
      communication_buffer_p^.word_one.concurrent_channel := 1;
    ELSE
      communication_buffer_p^.word_one.concurrent_channel := 0;
    IFEND;
    communication_buffer_p^.word_one.channel_number := sdp_channel_definition.number;
    communication_buffer_p^.word_two := 0(16);
    communication_buffer_p^.word_three := 0(16);
    communication_buffer_p^.word_four := 0(16);
    communication_buffer_p^.word_five := 0(16);
    communication_buffer_p^.word_six := 0(16);
    communication_buffer_p^.word_seven := 0(16);
    communication_buffer_p^.word_eight := 0(16);
    communication_buffer_p^.word_nine := 0(16);
    communication_buffer_p^.word_ten := 0(16);
    communication_buffer_p^.word_eleven := 0(16);
    communication_buffer_p^.word_twelve := 0(16);
    communication_buffer_p^.word_thirteen := 0(16);
    communication_buffer_p^.word_fourteen := 0(16);
    communication_buffer_p^.word_fifteen := 0(16);
    communication_buffer_p^.word_sixteen := 0(16);
    communication_buffer_p^.word_seventeen := 0(16);
    communication_buffer_p^.word_eighteen := 0(16);
  PROCEND initialize_communication_buffer;
?? TITLE := '    load_sdpd_into_ppu ', EJECT ??

{
{ PURPOSE:
{ This procedure is used to allocate a SDPD communication buffer and to load
{ SDPD into the acquired PPU resource.
{

  PROCEDURE load_sdpd_into_ppu
    (    sdp_pp_identification: cmt$pp_identification;
     VAR sdpd_communications_p: ^SEQ ( * );
     VAR sdpd_active: boolean;
     VAR status: ost$status);

    VAR
      sdpd_program_description: array [1 .. 1] of cmt$pp_program_description;

    sdpd_active := FALSE;

{
{ Build a SDPD driver program description for use in loading SDPD PP driver
{ into the PPU.
{

    sdpd_program_description [1].pp_identification := sdp_pp_identification;
    sdpd_program_description [1].iou_program_name := 'SDPD                           ';
    sdpd_program_description [1].pp_program := NIL;
    sdpd_program_description [1].master_pp := TRUE;
    sdpd_program_description [1].element_access := NIL;
    sdpd_program_description [1].communication_buffer_length := #SIZE (dft$sdp_communication_buffer);

{
{ Request NOS/VE to allocate a SDPD communication buffer and to load SDPD
{ into the acquired PPU and give control of the PPU to SDPD via a call
{ to system interface CMP$EXECUTE_PP_PROGRAM.
{

    cmp$execute_pp_program (sdpd_program_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    sdpd_communications_p := sdpd_program_description [1].communication_buffer;
    sdpd_active := TRUE;
  PROCEND load_sdpd_into_ppu;
?? TITLE := '    perform_side_door_port_clean_up ', EJECT ??

{
{ PURPOSE:
{ This procedure is used to perform SDPD PP driver clean-up for both normal
{ and abnormal cases.
{

  PROCEDURE perform_side_door_port_clean_up
    (    sdp_channel_reservation: array [1 .. 1] of cmt$element_reservation;
         sdp_pp_identification: cmt$pp_identification;
         sdp_pp_reservation: array [1 .. 1] of cmt$element_reservation;
     VAR sdpd_active: {input, output} boolean;
     VAR sdp_channel_reserved: {input, output} boolean;
     VAR sdp_pp_reserved: {input, output} boolean;
     VAR status: ost$status);

    VAR
      actual_pp_memory_size: cmt$pp_memory_length,
      ignore_status: ost$status,
      pp_registers: cmt$pp_registers,
      pp_software_idled: boolean;

{
{ Perform SDPD PP driver clean-up for both the normal and abnormal cases.
{

    IF sdpd_active THEN
      cmp$idle_pp (sdp_pp_identification, TRUE, TRUE, NIL, actual_pp_memory_size, pp_registers,
            pp_software_idled, ignore_status);
      sdpd_active := FALSE;
    IFEND;
    IF sdp_pp_reserved THEN
      cmp$release_element (sdp_pp_reservation, ignore_status);
      sdp_pp_reserved := FALSE;
    IFEND;
    IF sdp_channel_reserved THEN
      cmp$release_element (sdp_channel_reservation, ignore_status);
      sdp_channel_reserved := FALSE;
    IFEND;
  PROCEND perform_side_door_port_clean_up;
?? TITLE := '    [XDCL] dfp$log_side_door_port_status ', EJECT ??

{
{ PURPOSE:
{ This procedure is used to log STORNET/ESM side door port status to the
{ system Engineering Log.
{

  PROCEDURE [XDCL] dfp$log_side_door_port_status
    (    reason: dft$sdp_logging_code;
     VAR status: ost$status);

    VAR
      communication_buffer_p: ^dft$sdp_communication_buffer,
      current_element: integer,
      current_port_in_definition: 1 .. cmc$max_side_door_port_number,
      descriptive_data_descriptor: dft$descriptive_data_descriptor,
      host_mainframe_id: pmt$mainframe_id,
      ignore_status: ost$status,
      number_of_elements: dft$esms_defined_count,
      sdp_channel_definition: cmt$data_channel_definition,
      sdp_channel_reservation: array [1 .. 1] of cmt$element_reservation,
      sdp_channel_reserved: boolean,
      sdp_pp_identification: cmt$pp_identification,
      sdp_pp_reservation: array [1 .. 1] of cmt$element_reservation,
      sdp_pp_reserved: boolean,
      sdpd_active: boolean,
      sdpd_communications_p: ^SEQ ( * ),
      side_door_port_channel_found: boolean,
      stornet_esm_element_definition: cmt$esm_definition,
      stornet_esm_element_names: array [1 .. dfc$max_esms_defined] of cmt$element_name;

    sdp_channel_reserved := FALSE;
    sdp_pp_reserved := FALSE;
    sdpd_active := FALSE;
    side_door_port_channel_found := FALSE;

{
{ Obtain host mainframe identification.
{

    pmp$get_mainframe_id (host_mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{
{ Obtain STORNET/ESM element names.
{

    dfp$return_esms_defined (number_of_elements, stornet_esm_element_names);

{
{ Loop processing all STORNET/ESM element names on this mainframe.
{

  /process_stornet_esm_elements/
    FOR current_element := 1 TO number_of_elements DO
      get_stornet_esm_definition (current_element, stornet_esm_element_names, stornet_esm_element_definition,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{
{ Loop processing all side door port channels on this STORNET/ESM element
{ searching for a channel status state of CMC$ON.
{

    /process_side_door_port_channels/
      FOR current_port_in_definition := 1 TO cmc$max_side_door_port_number DO
        find_side_door_port_channel (reason, current_port_in_definition, host_mainframe_id,
              stornet_esm_element_definition, descriptive_data_descriptor, sdp_channel_definition,
              side_door_port_channel_found, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF side_door_port_channel_found THEN

{
{ Acquire the STORNET/ESM side door port channel from NOS/VE via a call to
{ system interface CMP$RESERVE_ELEMENT.
{

          acquire_channel_for_sdpd (current_port_in_definition, stornet_esm_element_definition,
                sdp_channel_reservation, sdp_channel_reserved, status);
          IF NOT status.normal THEN
            descriptive_data_descriptor.symptom_code := dfc$sdp_channel_unavailable;
            dfp$log_sdp_data (reason, NIL, descriptive_data_descriptor, ignore_status);
            CYCLE /process_side_door_port_channels/;
          IFEND;

{
{ Acquire a PP from NOS/VE such that the PP has access to the STORNET/ESM
{ side door port channel via a call to system interface CMP$RESERVE_ELEMENT.
{

          acquire_pp_for_sdpd (sdp_channel_definition, sdp_pp_reservation, sdp_pp_identification,
                sdp_pp_reserved, status);
          IF NOT status.normal THEN
            descriptive_data_descriptor.symptom_code := dfc$sdp_pp_unavailable;
            dfp$log_sdp_data (reason, NIL, descriptive_data_descriptor, ignore_status);
            perform_side_door_port_clean_up (sdp_channel_reservation, sdp_pp_identification,
                  sdp_pp_reservation, sdpd_active, sdp_channel_reserved, sdp_pp_reserved, ignore_status);
            CYCLE /process_side_door_port_channels/;
          IFEND;

{
{ Load SDPD driver into the PP acquired from NOS/VE and initiate execution
{ of SDPD.
{

          load_sdpd_into_ppu (sdp_pp_identification, sdpd_communications_p, sdpd_active, status);
          IF NOT status.normal THEN
            perform_side_door_port_clean_up (sdp_channel_reservation, sdp_pp_identification,
                  sdp_pp_reservation, sdpd_active, sdp_channel_reserved, sdp_pp_reserved, ignore_status);
            RETURN;
          IFEND;

{
{ Establish communications with SDPD via a communication protocol which
{ utilizes the SDPD Communication Buffer and involves the CPU_STATUS and
{ PPU_STATUS fields.
{

          establish_sdpd_communications (sdp_channel_definition, sdp_pp_identification, sdpd_communications_p,
                communication_buffer_p, status);
          IF NOT status.normal THEN
            perform_side_door_port_clean_up (sdp_channel_reservation, sdp_pp_identification,
                  sdp_pp_reservation, sdpd_active, sdp_channel_reserved, sdp_pp_reserved, ignore_status);
            RETURN;
          IFEND;

{
{ Wait for SDPD driver to complete side door port error log processing.
{ Begin timeout of SDPD driver to detect PP/driver hangs.
{

          await_activity_completion (communication_buffer_p, descriptive_data_descriptor, status);
          IF NOT status.normal THEN
            perform_side_door_port_clean_up (sdp_channel_reservation, sdp_pp_identification,
                  sdp_pp_reservation, sdpd_active, sdp_channel_reserved, sdp_pp_reserved, ignore_status);
            RETURN;
          IFEND;

{
{ Process SDPD driver completion status and create an entry in the System
{ Engineering Log via a call to DFP$LOG_SDP_DATA.
{

          dfp$log_sdp_data (reason, communication_buffer_p, descriptive_data_descriptor, status);
          IF NOT status.normal THEN
            perform_side_door_port_clean_up (sdp_channel_reservation, sdp_pp_identification,
                  sdp_pp_reservation, sdpd_active, sdp_channel_reserved, sdp_pp_reserved, ignore_status);
            RETURN;
          IFEND;

{
{ Perform log side door port status process clean-up (ie. idle the PP and
{ release the PPU and channel resource).
{

          perform_side_door_port_clean_up (sdp_channel_reservation, sdp_pp_identification, sdp_pp_reservation,
                sdpd_active, sdp_channel_reserved, sdp_pp_reserved, status);
        IFEND;
      FOREND /process_side_door_port_channels/;
    FOREND /process_stornet_esm_elements/;
  PROCEND dfp$log_side_door_port_status;
MODEND dfm$log_side_door_port_status;
*DECK DECK=DFM$MANAGE_APPLICATION_INFO EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File Server: Server/Client: Application Information Manager' ??
MODULE dfm$manage_application_info;

{ PURPOSE:
{   This module contains the procedures to generate, display and delete
{   information required for applications "calling" from a client mainframe
{   procedures which reside and execute on a server mainframe.
{
{ DESIGN:
{   Procedures are provided to process the commands concerning the information.
{   The commands are sub-commands of the MANAGE_FILE_SERVER utility.
{   Externally referenced procedures appear in this module before local
{   procedures.

?? NEWTITLE := '  Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dfi$console_display
*copyc dfi$display
*copyc dfi$log_display
*copyc dft$application_support_limits
*copyc dft$app_support_limits_af
*copyc dft$cpu_queue
*copyc dft$rpc_parameters
*copyc dft$rpc_procedure_address_list
*copyc pmt$mainframe_id
*copyc ost$name
?? POP ??
*copyc amp$return
*copyc clp$close_display
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc clp$include_command
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dfp$find_mainframe_id
*copyc dfp$get_mainframe_list
*copyc dfp$verify_system_administrator
*copyc i#current_sequence_position
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$clear_job_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osp$test_sig_lock
*copyc pmp$zero_out_table
*copyc dfv$application_info_lock
*copyc dfv$file_server_debug_enabled
*copyc dfv$p_client_mainframe_file
*copyc dfv$server_wired_heap
?? OLDTITLE ??
?? NEWTITLE := 'Server: [XDCL, #GATE] dfp$define_application_rpc_cmnd', EJECT ??

{ PURPOSE:
{   The purpose of this request is to define the applications procedures which
{   can be called on the server mainframe from application procedures on
{   specified client mainframes.

  PROCEDURE [XDCL, #GATE] dfp$define_application_rpc_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE define_application_rpc, defar (
{   application_name, an: name = $required
{   library, l: file = $required
{   remote_procedure, rp: list 1 .. 50 of record
{     remote_procedure_name: name = $required
{     request_restartable: boolean = "FALSE" $optional
{     job_recovery_location: key
{       (caller_waits_for_volume, cwfv)
{       (caller_starts_recovery, csr)
{      keyend = "caller_waits_for_volume" $optional
{      recover_job_on_server: boolean ="FALSE" $optional
{      application_ring: integer 3..15 = "6" $optional
{      allow_terminate_break: boolean = "TRUE" $optional
{      allow_pause_break: boolean = "TRUE" $optional
{    recend = $required
{    client_mainframe_identifiers, client_mainframe_identifier, cmi: any of
{      list of name 17..17
{        key
{          all
{        keyend
{     anyend = $REQUIRED
{     state_change_procedure, scp: any of
{       program_name
{       key
{         none
{       keyend
{     anyend = none
{     sequence_size, ss: any of
{       integer 0..524288
{       key
{         none
{       keyend
{     anyend = none
{     attach_file, attach_files, af: (hidden) any of
{       list 1 ..25 of file
{       key
{         none
{       keyend
{     anyend = none
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 17] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 4] of clt$keyword_specification,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: record
            header: clt$type_specification_header,
          recend,
          field_spec_5: clt$field_specification,
          element_type_spec_5: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_6: clt$field_specification,
          element_type_spec_6: record
            header: clt$type_specification_header,
          recend,
          field_spec_7: clt$field_specification,
          element_type_spec_7: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type4: 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$list_type_qualifier_v2,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
      recend,
      type5: 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (4),
      recend,
      type6: 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$integer_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (4),
      recend,
      type7: 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$list_type_qualifier_v2,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (4),
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 8, 23, 6, 56, 16, 65],
    clc$command, 17, 8, 4, 0, 1, 0, 8, ''], [
    ['AF                             ',clc$abbreviation_entry, 7],
    ['AN                             ',clc$abbreviation_entry, 1],
    ['APPLICATION_NAME               ',clc$nominal_entry, 1],
    ['ATTACH_FILE                    ',clc$nominal_entry, 7],
    ['ATTACH_FILES                   ',clc$alias_entry, 7],
    ['CLIENT_MAINFRAME_IDENTIFIER    ',clc$alias_entry, 4],
    ['CLIENT_MAINFRAME_IDENTIFIERS   ',clc$nominal_entry, 4],
    ['CMI                            ',clc$abbreviation_entry, 4],
    ['L                              ',clc$abbreviation_entry, 2],
    ['LIBRARY                        ',clc$nominal_entry, 2],
    ['REMOTE_PROCEDURE               ',clc$nominal_entry, 3],
    ['RP                             ',clc$abbreviation_entry, 3],
    ['SCP                            ',clc$abbreviation_entry, 5],
    ['SEQUENCE_SIZE                  ',clc$nominal_entry, 6],
    ['SS                             ',clc$abbreviation_entry, 6],
    ['STATE_CHANGE_PROCEDURE         ',clc$nominal_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 8]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 467,
  clc$required_parameter, 0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$required_parameter,
  0, 0],
{ PARAMETER 5
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 67,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 6
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 7
    [4, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 83,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 8
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$list_type], [451, 1, 50, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [7],
      ['REMOTE_PROCEDURE_NAME          ', clc$required_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['REQUEST_RESTARTABLE            ', clc$optional_field, 3], [[1, 0, clc$boolean_type]],
      ['JOB_RECOVERY_LOCATION          ', clc$optional_field, 155], [[1, 0, clc$keyword_type], [4], [
        ['CALLER_STARTS_RECOVERY         ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['CALLER_WAITS_FOR_VOLUME        ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['CSR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['CWFV                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1]]
        ],
      ['RECOVER_JOB_ON_SERVER          ', clc$optional_field, 3], [[1, 0, clc$boolean_type]],
      ['APPLICATION_RING               ', clc$optional_field, 20], [[1, 0, clc$integer_type], [3, 15, 10]],
      ['ALLOW_TERMINATE_BREAK          ', clc$optional_field, 3], [[1, 0, clc$boolean_type]],
      ['ALLOW_PAUSE_BREAK              ', clc$optional_field, 3], [[1, 0, clc$boolean_type]]
      ]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [17, 17]]
      ],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$program_name_type],
    FALSE, 2],
    3, [[1, 0, clc$program_name_type]],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'none'],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    20, [[1, 0, clc$integer_type], [0, 524288, 10]],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'none'],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    19, [[1, 0, clc$list_type], [3, 1, 25, 0, FALSE, FALSE],
        [[1, 0, clc$file_type]]
      ],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'none'],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application_name = 1,
      p$library = 2,
      p$remote_procedure = 3,
      p$client_mainframe_identifiers = 4,
      p$state_change_procedure = 5,
      p$sequence_size = 6,
      p$attach_file = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    VAR
      attached_file_index: dft$number_of_attached_files,
      client_id: pmt$mainframe_id,
      client_index: clt$list_size,
      client_list_count: clt$list_size,
      command_name: ost$name,
      host_application_info: dft$host_application_info,
      j: dft$number_of_procs_per_app,
      local_status: ost$status,
      mainframe_found: boolean,
      number_of_attached_files: dft$number_of_attached_files,
      number_of_procedures: dft$number_of_procs_per_app,
      p_application_rpc_list: ^array [ * ] of dft$rpc_procedure_address_entry,
      p_attached_file_info: ^array [ * ] of ^fst$file_reference,
      p_client_list: ^dft$partner_mainframe_list,
      p_cpu_queue: ^dft$cpu_queue,
      p_library_file_path: ^fst$file_reference,
      p_list_value: ^clt$data_value,
      partner_count: dft$partner_mainframe_count,
      procedure_index: dft$number_of_procs_per_app,
      procedure_name: pmt$program_name,
      remote_application_info: dft$remote_application_info,
      sequence_size: dft$send_data_size;

?? NEWTITLE := 'block_exit_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to clear the application info lock if
{   it is set.

    PROCEDURE block_exit_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        lock_status: ost$signature_lock_status;

      osp$test_sig_lock (dfv$application_info_lock, lock_status);
      IF lock_status = osc$sls_locked_by_current_task THEN
        osp$clear_job_signature_lock (dfv$application_info_lock);
      IFEND;

    PROCEND block_exit_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    local_status.normal := TRUE;
    command_name := 'DEFINE_APPLICATION_RPC';

    dfp$verify_system_administrator (command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Crack host application information.

    host_application_info.application_name := pvt [p$application_name].value^.name_value;
    p_library_file_path := pvt [p$library].value^.file_value;

    IF (pvt [p$state_change_procedure].value^.kind = clc$program_name) AND
          (pvt [p$state_change_procedure].value^.program_name_value <> 'NONE') THEN
      host_application_info.state_change_procedure_name := pvt [p$state_change_procedure].value^.name_value;
    ELSE
      host_application_info.state_change_procedure_name := osc$null_name;
    IFEND;

    IF pvt [p$sequence_size].value^.kind = clc$integer THEN
      sequence_size := pvt [p$sequence_size].value^.integer_value.value;
    ELSE
      sequence_size := 0;
    IFEND;

    host_application_info.next_p_application_info := NIL;

{ NOTE: Implemention of attached file processing has been DEFERRED
{   IF pvt [p$attach_file].specified THEN
{     number_of_attached_files := clp$count_list_elements (pvt [p$attach_file].value);
{     p_list_value := pvt [p$attach_file].value;
{
{     PUSH p_attached_file_info: [1 .. number_of_attached_files];
{
{     FOR attached_file_index := 1 TO number_of_attached_files DO
{       p_attached_file_info^ [attached_file_index] := p_list_value^.element_value^.file_value;
{
{       p_list_value := p_list_value^.link;
{     FOREND;
{   ELSE
    p_attached_file_info := NIL;
{   IFEND;

{ Crack remote application information.

    remote_application_info.application_name := pvt [p$application_name].value^.name_value;
    remote_application_info.next_p_application_info := NIL;
    number_of_procedures := clp$count_list_elements (pvt [p$remote_procedure].value);
    remote_application_info.number_of_procedures := number_of_procedures;

{ Build procedure address list (without address)

    p_list_value := pvt [p$remote_procedure].value;

    PUSH p_application_rpc_list: [1 .. number_of_procedures];

  /process_remote_procedures/
    FOR procedure_index := 1 TO number_of_procedures DO
      procedure_name := p_list_value^.element_value^.field_values^ [1].value^.name_value;
      IF procedure_index > 1 THEN

      /check_name_uniqueness/
        FOR j := 1 TO procedure_index - 1 DO
          IF p_application_rpc_list^ [j].debug_display = procedure_name THEN
            osp$set_status_abnormal (dfc$file_server_id, dfe$procedure_already_defined, procedure_name,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  host_application_info.application_name, status);
            RETURN;
          IFEND;
        FOREND /check_name_uniqueness/;
      IFEND;
      p_application_rpc_list^ [procedure_index].debug_display := procedure_name;

      p_application_rpc_list^ [procedure_index].procedure_address := NIL;
      { procedure_address to be added when loaded

      p_application_rpc_list^ [procedure_index].class := dfc$application_call;

      IF p_list_value^.element_value^.field_values^ [2].value = NIL THEN { default }
        p_application_rpc_list^ [procedure_index].request_restartable := dfc$request_not_restartable;
      ELSEIF p_list_value^.element_value^.field_values^ [2].value^.boolean_value.value THEN
        p_application_rpc_list^ [procedure_index].request_restartable := dfc$request_restartable;
      ELSE
        p_application_rpc_list^ [procedure_index].request_restartable := dfc$request_not_restartable;
      IFEND;

      IF p_list_value^.element_value^.field_values^ [3].value = NIL THEN
        p_application_rpc_list^ [procedure_index].job_recovery_location := dfc$job_rec_in_unavailable_wait;
      ELSEIF (p_list_value^.element_value^.field_values^ [3].value^.keyword_value =
            'CALLER_WAITS_FOR_VOLUME') OR (p_list_value^.element_value^.field_values^ [3].value^.
            keyword_value = 'CWFV') THEN
        p_application_rpc_list^ [procedure_index].job_recovery_location := dfc$job_rec_in_unavailable_wait;
      ELSE
        p_application_rpc_list^ [procedure_index].job_recovery_location := dfc$job_rec_started_by_caller;
      IFEND;

      IF p_list_value^.element_value^.field_values^ [4].value = NIL THEN
        p_application_rpc_list^ [procedure_index].recover_job_on_server_call := FALSE;
      ELSE
        p_application_rpc_list^ [procedure_index].recover_job_on_server_call :=
              p_list_value^.element_value^.field_values^ [4].value^.boolean_value.value;
      IFEND;

      p_application_rpc_list^ [procedure_index].procedure_version := '1234';
      p_application_rpc_list^ [procedure_index].procedure_name_checksum := #FREE_RUNNING_CLOCK (0);

      IF p_list_value^.element_value^.field_values^ [5].value = NIL THEN
        p_application_rpc_list^ [procedure_index].application_ring := 6;
      ELSE
        p_application_rpc_list^ [procedure_index].application_ring :=
              p_list_value^.element_value^.field_values^ [5].value^.integer_value.value;
      IFEND;

      IF p_list_value^.element_value^.field_values^ [6].value = NIL THEN
        p_application_rpc_list^ [procedure_index].allow_terminate_break := TRUE;
      ELSE
        p_application_rpc_list^ [procedure_index].allow_terminate_break :=
              p_list_value^.element_value^.field_values^ [6].value^.boolean_value.value;
      IFEND;

      IF p_list_value^.element_value^.field_values^ [7].value = NIL THEN
        p_application_rpc_list^ [procedure_index].allow_pause_break := TRUE;
      ELSE
        p_application_rpc_list^ [procedure_index].allow_pause_break :=
              p_list_value^.element_value^.field_values^ [7].value^.boolean_value.value;
      IFEND;

      p_list_value := p_list_value^.link;

    FOREND /process_remote_procedures/;

    IF pvt [p$client_mainframe_identifiers].value^.kind = clc$keyword THEN {must be ALL
      PUSH p_client_list: [1 .. 10];
      dfp$get_mainframe_list ({partners_are_servers} FALSE, p_client_list^, partner_count);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF partner_count = 0 THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$no_partner_mainframe, command_name, status);
        RETURN;
      IFEND;
      IF partner_count > 10 THEN
        PUSH p_client_list: [1 .. partner_count];
        dfp$get_mainframe_list ({partners_are_servers} FALSE, p_client_list^, partner_count);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      client_list_count := partner_count;
      FOR client_index := 1 TO client_list_count DO
        IF (p_client_list^ [client_index].partner_state <> dfc$terminated) AND
              (p_client_list^ [client_index].partner_state <> dfc$awaiting_recovery) THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_state_for_def_app, command_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                p_client_list^ [client_index].mainframe_name, status);
          RETURN;
        IFEND;
      FOREND;
    ELSE
      p_list_value := pvt [p$client_mainframe_identifiers].value;
      client_list_count := clp$count_list_elements (pvt [p$client_mainframe_identifiers].value);
    IFEND;

    osp$establish_block_exit_hndlr (^block_exit_handler);

    osp$set_job_signature_lock (dfv$application_info_lock);

  /add_application_info_for_client/
    FOR client_index := 1 TO client_list_count DO
      IF pvt [p$client_mainframe_identifiers].value^.kind = clc$keyword THEN {must be ALL
        client_id := p_client_list^ [client_index].mainframe_name;
      ELSE
        client_id := p_list_value^.element_value^.name_value;
        p_list_value := p_list_value^.link;
      IFEND;
      add_host_application_info (host_application_info, {host_is_server} TRUE, client_id, sequence_size,
            p_attached_file_info, p_library_file_path, command_name, p_cpu_queue, status);
      IF NOT status.normal THEN
        IF dfv$file_server_debug_enabled THEN
          display_status (status);
          log_display_status ($pmt$ascii_logset [pmc$system_log], TRUE, status);
        IFEND;
        EXIT /add_application_info_for_client/;
      IFEND;
      add_remote_application_info (remote_application_info, p_cpu_queue, p_application_rpc_list, status);
      IF NOT status.normal THEN
        delete_host_application (host_application_info.application_name, client_id, {host_is_server} TRUE,
              command_name, local_status);
        EXIT /add_application_info_for_client/;
      IFEND;

    FOREND /add_application_info_for_client/;

    osp$clear_job_signature_lock (dfv$application_info_lock);
    osp$disestablish_cond_handler;

    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

  PROCEND dfp$define_application_rpc_cmnd;
?? OLDTITLE ??
?? NEWTITLE := 'Client:[XDCL, #GATE] dfp$define_client_app_info_cmnd', EJECT ??

{ PURPOSE:
{   The purpose of this request is to define the application information
{   on a client mainframe.


  PROCEDURE [XDCL, #GATE] dfp$define_client_app_info_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{     PROCEDURE define_client_application_info, defcai (
{       application_name, an: name = $required
{       library, l: file
{       server_mainframe_identifiers, server_mainframe_identifier, smi: any of
{         list of name 17..17
{         key
{           all
{         keyend
{       anyend = $REQUIRED
{       state_change_procedure, scp: any of
{         program_name
{         key
{           none
{         keyend
{       anyend = none
{       sequence_size, ss: any of
{         integer 0..524288
{         key
{           none
{         keyend
{       anyend = none
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 12] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
      recend,
      type4: 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (4),
      recend,
      type5: 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$integer_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (4),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 12, 9, 42, 12, 772],
    clc$command, 12, 6, 2, 0, 0, 0, 6, ''], [
    ['AN                             ',clc$abbreviation_entry, 1],
    ['APPLICATION_NAME               ',clc$nominal_entry, 1],
    ['L                              ',clc$abbreviation_entry, 2],
    ['LIBRARY                        ',clc$nominal_entry, 2],
    ['SCP                            ',clc$abbreviation_entry, 4],
    ['SEQUENCE_SIZE                  ',clc$nominal_entry, 5],
    ['SERVER_MAINFRAME_IDENTIFIER    ',clc$alias_entry, 3],
    ['SERVER_MAINFRAME_IDENTIFIERS   ',clc$nominal_entry, 3],
    ['SMI                            ',clc$abbreviation_entry, 3],
    ['SS                             ',clc$abbreviation_entry, 5],
    ['STATE_CHANGE_PROCEDURE         ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$required_parameter,
  0, 0],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 67,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 5
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [17, 17]]
      ],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$program_name_type],
    FALSE, 2],
    3, [[1, 0, clc$program_name_type]],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'none'],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    20, [[1, 0, clc$integer_type], [0, 524288, 10]],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'none'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application_name = 1,
      p$library = 2,
      p$server_mainframe_identifiers = 3,
      p$state_change_procedure = 4,
      p$sequence_size = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      command_name: ost$name,
      host_application_info: dft$host_application_info,
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_library_file_path: ^fst$file_reference,
      p_list_value: ^clt$data_value,
      p_server_list: ^dft$partner_mainframe_list,
      partner_count: dft$partner_mainframe_count,
      sequence_size: dft$send_data_size,
      server_id: pmt$mainframe_id,
      server_index: clt$list_size,
      server_list_count: clt$list_size;

?? NEWTITLE := 'block_exit_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to clear the application info lock if
{   it is set.

    PROCEDURE block_exit_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        lock_status: ost$signature_lock_status;

      osp$test_sig_lock (dfv$application_info_lock, lock_status);
      IF lock_status = osc$sls_locked_by_current_task THEN
        osp$clear_job_signature_lock (dfv$application_info_lock);
      IFEND;

    PROCEND block_exit_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    command_name := 'DEFINE_CLIENT_APPLICATION_INFO';

    dfp$verify_system_administrator (command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    host_application_info.application_name := pvt [p$application_name].value^.name_value;

    IF pvt [p$library].specified THEN
      p_library_file_path := pvt [p$library].value^.file_value;
    ELSE
      p_library_file_path := NIL;
    IFEND;

    host_application_info.attached_library_lfn := osc$null_name;

    IF (pvt [p$state_change_procedure].value^.kind = clc$program_name) AND
          (pvt [p$state_change_procedure].value^.program_name_value <> 'NONE') THEN
      IF pvt [p$library].specified THEN
        host_application_info.state_change_procedure_name := pvt [p$state_change_procedure].value^.name_value;
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$scp_par_requires_lib_par, '', status);
        RETURN;
      IFEND;
    ELSE
      host_application_info.state_change_procedure_name := osc$null_name;
    IFEND;

    IF pvt [p$sequence_size].value^.kind = clc$integer THEN
      sequence_size := pvt [p$sequence_size].value^.integer_value.value;
    ELSE
      sequence_size := 0;
    IFEND;

    host_application_info.p_attached_file_info := NIL;
    host_application_info.next_p_application_info := NIL;

    IF pvt [p$server_mainframe_identifiers].value^.kind = clc$keyword THEN {must be ALL
      PUSH p_server_list: [1 .. 10];
      dfp$get_mainframe_list ({partners_are_servers} TRUE, p_server_list^, partner_count);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF partner_count = 0 THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$no_partner_mainframe, command_name, status);
        RETURN;
      IFEND;
      IF partner_count > 10 THEN
        PUSH p_server_list: [1 .. partner_count];
        dfp$get_mainframe_list ({partners_are_servers} TRUE, p_server_list^, partner_count);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      server_list_count := partner_count;
      FOR server_index := 1 TO server_list_count DO
        IF (p_server_list^ [server_index].partner_state <> dfc$terminated) AND
              (p_server_list^ [server_index].partner_state <> dfc$awaiting_recovery) THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_state_for_def_app, command_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                p_server_list^ [server_index].mainframe_name, status);
          RETURN;
        IFEND;
      FOREND;
    ELSE
      p_list_value := pvt [p$server_mainframe_identifiers].value;
      server_list_count := clp$count_list_elements (pvt [p$server_mainframe_identifiers].value);
    IFEND;

    osp$establish_block_exit_hndlr (^block_exit_handler);

    osp$set_job_signature_lock (dfv$application_info_lock);

  /add_application_info_for_server/
    FOR server_index := 1 TO server_list_count DO
      IF pvt [p$server_mainframe_identifiers].value^.kind = clc$keyword THEN {must be ALL
        server_id := p_server_list^ [server_index].mainframe_name;
      ELSE
        server_id := p_list_value^.element_value^.name_value;
        p_list_value := p_list_value^.link;
      IFEND;
      add_host_application_info (host_application_info, FALSE, server_id, sequence_size, NIL,
            p_library_file_path, command_name, p_cpu_queue, status);
      IF NOT status.normal THEN
        IF dfv$file_server_debug_enabled THEN
          display_status (status);
          log_display_status ($pmt$ascii_logset [pmc$system_log], TRUE, status);
        IFEND;
        RETURN;
      IFEND;

    FOREND /add_application_info_for_server/;

    osp$clear_job_signature_lock (dfv$application_info_lock);
    osp$disestablish_cond_handler;

  PROCEND dfp$define_client_app_info_cmnd;
?? OLDTITLE ??
?? NEWTITLE := 'Server: [XDCL, #GATE] dfp$delete_application_rpc_cmnd', EJECT ??

{ PURPOSE:
{   The purpose of this request is to delete all application information
{   previously defined by the define_application_rpc command for the
{   specified client mainframes.

  PROCEDURE [XDCL, #GATE] dfp$delete_application_rpc_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE delete_application_rpc, delar (
{     application_name, an: name = $REQUIRED
{     client_mainframe_identifiers, client_mainframe_identifier, cmi: any of
{       list of name 17..17
{       key
{         all
{       keyend
{     anyend = $REQUIRED
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 28, 14, 55, 57, 909],
    clc$command, 6, 3, 2, 0, 0, 0, 3, ''], [
    ['AN                             ',clc$abbreviation_entry, 1],
    ['APPLICATION_NAME               ',clc$nominal_entry, 1],
    ['CLIENT_MAINFRAME_IDENTIFIER    ',clc$alias_entry, 2],
    ['CLIENT_MAINFRAME_IDENTIFIERS   ',clc$nominal_entry, 2],
    ['CMI                            ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [17, 17]]
      ],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application_name = 1,
      p$client_mainframe_identifiers = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      application_name: ost$name,
      client_id: pmt$mainframe_id,
      client_index: clt$list_size,
      client_list_count: clt$list_size,
      command_name: ost$name,
      p_client_list: ^dft$partner_mainframe_list,
      p_list_value: ^clt$data_value,
      partner_count: dft$partner_mainframe_count;

?? NEWTITLE := 'block_exit_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to clear the application info lock if
{   it is set.

    PROCEDURE block_exit_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        lock_status: ost$signature_lock_status;

      osp$test_sig_lock (dfv$application_info_lock, lock_status);
      IF lock_status = osc$sls_locked_by_current_task THEN
        osp$clear_job_signature_lock (dfv$application_info_lock);
      IFEND;

    PROCEND block_exit_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    command_name := 'DELETE_APPLICATION_RPC';

    dfp$verify_system_administrator (command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    application_name := pvt [p$application_name].value^.name_value;

    IF pvt [p$client_mainframe_identifiers].value^.kind = clc$keyword THEN {must be ALL
      PUSH p_client_list: [1 .. 10];
      dfp$get_mainframe_list ({partners_are_servers} FALSE, p_client_list^, partner_count);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF partner_count = 0 THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$no_partner_mainframe, command_name, status);
        RETURN;
      IFEND;
      IF partner_count > 10 THEN
        PUSH p_client_list: [1 .. partner_count];
        dfp$get_mainframe_list ({partners_are_servers} FALSE, p_client_list^, partner_count);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      client_list_count := partner_count;
      FOR client_index := 1 TO client_list_count DO
        IF (p_client_list^ [client_index].partner_state <> dfc$terminated) AND
              (p_client_list^ [client_index].partner_state <> dfc$awaiting_recovery) THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_state_for_def_app, command_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                p_client_list^ [client_index].mainframe_name, status);
          RETURN;
        IFEND;
      FOREND;
    ELSE
      p_list_value := pvt [p$client_mainframe_identifiers].value;
      client_list_count := clp$count_list_elements (pvt [p$client_mainframe_identifiers].value);
    IFEND;

    osp$establish_block_exit_hndlr (^block_exit_handler);

    osp$set_job_signature_lock (dfv$application_info_lock);

  /del_info_for_client/
    FOR client_index := 1 TO client_list_count DO
      IF pvt [p$client_mainframe_identifiers].value^.kind = clc$keyword THEN {must be ALL
        client_id := p_client_list^ [client_index].mainframe_name;
      ELSE
        client_id := p_list_value^.element_value^.name_value;
        p_list_value := p_list_value^.link;
      IFEND;

      delete_host_application (application_name, client_id, {host_is_server} TRUE, command_name, status);
      IF status.normal THEN
        delete_remote_application (application_name, client_id, {host_is_server} TRUE, status);
      IFEND;
      IF NOT status.normal THEN
        IF dfv$file_server_debug_enabled THEN
          display_status (status);
          log_display_status ($pmt$ascii_logset [pmc$system_log], TRUE, status);
        IFEND;
        RETURN;
      IFEND;

    FOREND /del_info_for_client/;

    osp$clear_job_signature_lock (dfv$application_info_lock);
    osp$disestablish_cond_handler;

  PROCEND dfp$delete_application_rpc_cmnd;
?? OLDTITLE ??
?? NEWTITLE := 'Client: [XDCL, #GATE] dfp$delete_client_app_info_cmnd', EJECT ??

{ PURPOSE:
{   The purpose of this request is to delete all application information
{   previously defined by the define_client_application command for the
{   specified server mainframes.

  PROCEDURE [XDCL, #GATE] dfp$delete_client_app_info_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE delete_client_application_info, delcai (
{     application_name, an: name = $REQUIRED
{     server_mainframe_identifiers, server_mainframe_identifier, smi: any of
{       list of name 17..17
{       key
{         all
{       keyend
{     anyend = $REQUIRED
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 28, 15, 8, 38, 342],
    clc$command, 6, 3, 2, 0, 0, 0, 3, ''], [
    ['AN                             ',clc$abbreviation_entry, 1],
    ['APPLICATION_NAME               ',clc$nominal_entry, 1],
    ['SERVER_MAINFRAME_IDENTIFIER    ',clc$alias_entry, 2],
    ['SERVER_MAINFRAME_IDENTIFIERS   ',clc$nominal_entry, 2],
    ['SMI                            ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [17, 17]]
      ],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application_name = 1,
      p$server_mainframe_identifiers = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      application_name: ost$name,
      command_name: ost$name,
      p_list_value: ^clt$data_value,
      p_server_list: ^dft$partner_mainframe_list,
      partner_count: dft$partner_mainframe_count,
      server_id: pmt$mainframe_id,
      server_index: clt$list_size,
      server_list_count: clt$list_size;

?? NEWTITLE := 'block_exit_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to clear the application info lock if
{   it is set.

    PROCEDURE block_exit_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        lock_status: ost$signature_lock_status;

      osp$test_sig_lock (dfv$application_info_lock, lock_status);
      IF lock_status = osc$sls_locked_by_current_task THEN
        osp$clear_job_signature_lock (dfv$application_info_lock);
      IFEND;

    PROCEND block_exit_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    command_name := 'DELETE_CLIENT_APPLICATION_INFO';

    dfp$verify_system_administrator (command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    application_name := pvt [p$application_name].value^.name_value;

    IF pvt [p$server_mainframe_identifiers].value^.kind = clc$keyword THEN {must be ALL
      PUSH p_server_list: [1 .. 10];
      dfp$get_mainframe_list ({partners_are_servers} TRUE, p_server_list^, partner_count);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF partner_count = 0 THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$no_partner_mainframe, command_name, status);
        RETURN;
      IFEND;
      IF partner_count > 10 THEN
        PUSH p_server_list: [1 .. partner_count];
        dfp$get_mainframe_list ({partners_are_servers} TRUE, p_server_list^, partner_count);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      server_list_count := partner_count;
      FOR server_index := 1 TO server_list_count DO
        IF (p_server_list^ [server_index].partner_state <> dfc$terminated) AND
              (p_server_list^ [server_index].partner_state <> dfc$awaiting_recovery) THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_state_for_def_app, command_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                p_server_list^ [server_index].mainframe_name, status);
          RETURN;
        IFEND;
      FOREND;
    ELSE
      p_list_value := pvt [p$server_mainframe_identifiers].value;
      server_list_count := clp$count_list_elements (pvt [p$server_mainframe_identifiers].value);
    IFEND;

    osp$establish_block_exit_hndlr (^block_exit_handler);

    osp$set_job_signature_lock (dfv$application_info_lock);

  /del_application_info_for_server/
    FOR server_index := 1 TO server_list_count DO
      IF pvt [p$server_mainframe_identifiers].value^.kind = clc$keyword THEN {must be ALL
        server_id := p_server_list^ [server_index].mainframe_name;
      ELSE
        server_id := p_list_value^.element_value^.name_value;
        p_list_value := p_list_value^.link;
      IFEND;
      delete_host_application (application_name, server_id, {host_is_server} FALSE, command_name, status);
      IF NOT status.normal THEN
        IF dfv$file_server_debug_enabled THEN
          display_status (status);
          log_display_status ($pmt$ascii_logset [pmc$system_log], TRUE, status);
        IFEND;
        RETURN;
      IFEND;

    FOREND /del_application_info_for_server/;

    osp$clear_job_signature_lock (dfv$application_info_lock);
    osp$disestablish_cond_handler;

  PROCEND dfp$delete_client_app_info_cmnd;
?? OLDTITLE ??
?? NEWTITLE := 'Server: [XDCL, #GATE] dfp$display_application_rpc', EJECT ??

{ PURPOSE:
{   The purpose of this request is to process the command requesting
{   display of information concerning application procedures previously
{   defined by the define_application_rpc_command.

  PROCEDURE [XDCL, #GATE] dfp$display_application_rpc
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{    PROCEDURE display_application_rpc, disar (
{      application_name, an: any of name
{        key
{          all
{        keyend
{      anyend = all
{      client_mainframe_identifiers, client_mainframe_identifier, cmi: any of
{        list of name 17..17
{        key
{          all
{        keyend
{      anyend = $REQUIRED
{      display_options, display_option, do : KEY
{       (brief, b)
{       (full, f)
{      keyend = brief
{      output, o : FILE = $output
{      status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type2: 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 4, 12, 46, 38, 834],
    clc$command, 11, 5, 1, 0, 0, 0, 5, ''], [
    ['AN                             ',clc$abbreviation_entry, 1],
    ['APPLICATION_NAME               ',clc$nominal_entry, 1],
    ['CLIENT_MAINFRAME_IDENTIFIER    ',clc$alias_entry, 2],
    ['CLIENT_MAINFRAME_IDENTIFIERS   ',clc$nominal_entry, 2],
    ['CMI                            ',clc$abbreviation_entry, 2],
    ['DISPLAY_OPTION                 ',clc$alias_entry, 3],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 3],
    ['DO                             ',clc$abbreviation_entry, 3],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OUTPUT                         ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [17, 17]]
      ],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BRIEF                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FULL                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'brief'],
{ PARAMETER 4
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application_name = 1,
      p$client_mainframe_identifiers = 2,
      p$display_options = 3,
      p$output = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      all_applications: boolean,
      application_found: boolean,
      application_name: ost$name,
      client_index: clt$list_size,
      client_list_count: clt$list_size,
      client_id: pmt$mainframe_id,
      command_name: ost$name,
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      ignore_p_q_interf_dir_entry: ^dft$q_interface_directory_entry,
      ignore_p_q_interf_table: ^dft$queue_interface_table,
      ignore_queue_index: dft$queue_index,
      ignore_status: ost$status,
      line: string (200),
      line_size: integer,
      mainframe_found: boolean,
      next_p_info: ^dft$host_application_info,
      number_of_applications: dft$number_of_applications,
      p_cpu_queue: ^dft$cpu_queue,
      p_client_list: ^dft$partner_mainframe_list,
      p_host_application_info: ^dft$host_application_info,
      p_list_value: ^clt$data_value,
      p_remote_application_info: ^dft$remote_application_info,
      partner_count: dft$partner_mainframe_count;

?? NEWTITLE := 'block_exit_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to gracefully terminate the generated
{   display in case of an abnormal termination.

    PROCEDURE block_exit_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status,
        lock_status: ost$signature_lock_status;

      osp$test_sig_lock (dfv$application_info_lock, lock_status);
      IF lock_status = osc$sls_locked_by_current_task THEN
        osp$clear_job_signature_lock (dfv$application_info_lock);
      IFEND;
      clp$close_display (display_control, ignore_status);

    PROCEND block_exit_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    command_name := ' DISPLAY_APPLICATION_RPC';

    dfp$verify_system_administrator (command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    application_name := pvt [p$application_name].value^.name_value;
    all_applications := application_name = 'ALL';

    client_list_count := clp$count_list_elements (pvt [p$client_mainframe_identifiers].value);

    IF pvt [p$client_mainframe_identifiers].value^.kind = clc$keyword THEN {must be ALL
      PUSH p_client_list: [1 .. 10];
      dfp$get_mainframe_list ({partners_are_servers} FALSE, p_client_list^, partner_count);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF partner_count = 0 THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$no_partner_mainframe, 'DISPLAY_APPLICATION_RPC',
              status);
        RETURN;
      IFEND;
      IF partner_count > 10 THEN
        PUSH p_client_list: [1 .. partner_count];
        dfp$get_mainframe_list ({partners_are_servers} FALSE, p_client_list^, partner_count);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      client_list_count := partner_count;
    ELSE
      p_list_value := pvt [p$client_mainframe_identifiers].value;
      client_list_count := clp$count_list_elements (pvt [p$client_mainframe_identifiers].value);
    IFEND;

    osp$establish_block_exit_hndlr (^block_exit_handler);

    default_ring_attributes.r1 := 11;
    default_ring_attributes.r2 := 11;
    default_ring_attributes.r3 := 11;

    clp$open_display_reference (pvt [p$output].value^.file_value^, NIL, fsc$list, default_ring_attributes,
          display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    clp$put_display (display_control, command_name, clc$trim, status);

    osp$set_job_signature_lock (dfv$application_info_lock);

    application_found := FALSE;

  /display_client/
    FOR client_index := 1 TO client_list_count DO
      IF pvt [p$client_mainframe_identifiers].value^.kind = clc$keyword THEN {must be ALL
        client_id := p_client_list^ [client_index].mainframe_name;
      ELSE
        client_id := p_list_value^.element_value^.name_value;
        p_list_value := p_list_value^.link;
      IFEND;
      STRINGREP (line, line_size, ' Client Mainframe: ', client_id);
      clp$put_display (display_control, ' ', clc$trim, status);
      clp$put_display (display_control, line (1, line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_client/;
      IFEND;
      dfp$find_mainframe_id (client_id, {host_is_server} TRUE, mainframe_found, ignore_p_q_interf_table,
            p_cpu_queue, ignore_queue_index, ignore_p_q_interf_dir_entry);
      IF NOT mainframe_found THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, client_id, status);
        EXIT /display_client/;
      IFEND;
      p_host_application_info := p_cpu_queue^.queue_header.p_host_application_info;
      p_remote_application_info := p_cpu_queue^.queue_header.p_remote_application_info;

    /display_application/
      WHILE p_host_application_info <> NIL DO
        IF all_applications THEN
          application_name := p_host_application_info^.application_name;
        IFEND;
        IF p_host_application_info^.application_name = application_name THEN
          display_host_application_info ({host_is_server} TRUE, p_host_application_info,
                p_remote_application_info, p_cpu_queue, display_control, status);
          IF NOT status.normal THEN
            EXIT /display_client/;
          IFEND;
          application_found := TRUE;
          IF pvt [p$display_options].value^.keyword_value (1) = 'F' THEN
            display_remote_info (p_remote_application_info, p_cpu_queue, display_control, status);
            IF NOT status.normal THEN
              EXIT /display_application/;
            IFEND;
          IFEND;
          IF NOT all_applications THEN
            EXIT /display_application/;
          IFEND;
        IFEND;
        p_host_application_info := p_host_application_info^.next_p_application_info;
        p_remote_application_info := p_remote_application_info^.next_p_application_info;
      WHILEND /display_application/;

      IF p_host_application_info = NIL THEN
        IF NOT all_applications THEN
          STRINGREP (line, line_size, ' Undefined application: ', application_name);
          clp$put_display (display_control, line (1, line_size), clc$trim, status);
        IFEND;
      IFEND;

    FOREND /display_client/;

    IF (NOT application_found) AND (NOT all_applications) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$application_not_known, application_name, status);
    IFEND;

    IF status.normal THEN
      clp$close_display (display_control, status);
    ELSE
      clp$close_display (display_control, ignore_status);
    IFEND;

    osp$clear_job_signature_lock (dfv$application_info_lock);
    osp$disestablish_cond_handler;

  PROCEND dfp$display_application_rpc;
?? OLDTITLE ??
?? NEWTITLE := 'Client: [XDCL, #GATE] dfp$display_client_app_info_cmn', EJECT ??

{ PURPOSE:
{   The purpose of this request is to process the command requesting
{   display of information concerning application defined on this client.

  PROCEDURE [XDCL, #GATE] dfp$display_client_app_info_cmn
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE display_client_app_info, discai (
{    application_name, an: any of name
{      key
{        all
{      keyend
{    anyend = all
{    server_mainframe_identifiers, server_mainframe_identifier, smi: any of
{      list of name 17..17
{        key
{          all
{        keyend
{      anyend = $REQUIRED
{      display_options, display_option, do : KEY
{       (brief, b)
{       (full, f)
{     keyend = brief
{     output, o : FILE = $output
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type2: 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 28, 15, 11, 57, 978],
    clc$command, 11, 5, 1, 0, 0, 0, 5, ''], [
    ['AN                             ',clc$abbreviation_entry, 1],
    ['APPLICATION_NAME               ',clc$nominal_entry, 1],
    ['DISPLAY_OPTION                 ',clc$alias_entry, 3],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 3],
    ['DO                             ',clc$abbreviation_entry, 3],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OUTPUT                         ',clc$nominal_entry, 4],
    ['SERVER_MAINFRAME_IDENTIFIER    ',clc$alias_entry, 2],
    ['SERVER_MAINFRAME_IDENTIFIERS   ',clc$nominal_entry, 2],
    ['SMI                            ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [17, 17]]
      ],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BRIEF                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FULL                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'brief'],
{ PARAMETER 4
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application_name = 1,
      p$server_mainframe_identifiers = 2,
      p$display_options = 3,
      p$output = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      all_applications: boolean,
      application_found: boolean,
      application_name: ost$name,
      command_name: ost$name,
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      ignore_p_q_interf_dir_entry: ^dft$q_interface_directory_entry,
      ignore_p_q_interf_table: ^dft$queue_interface_table,
      ignore_queue_index: dft$queue_index,
      ignore_status: ost$status,
      line: string (200),
      line_size: integer,
      mainframe_found: boolean,
      next_p_info: ^dft$host_application_info,
      number_of_applications: dft$number_of_applications,
      p_cpu_queue: ^dft$cpu_queue,
      p_host_application_info: ^dft$host_application_info,
      p_list_value: ^clt$data_value,
      p_remote_application_info: ^dft$remote_application_info,
      p_server_list: ^dft$partner_mainframe_list,
      partner_count: dft$partner_mainframe_count,
      server_index: clt$list_size,
      server_list_count: clt$list_size,
      server_id: pmt$mainframe_id;

?? NEWTITLE := 'block_exit_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to gracefully terminate the generated
{   display in case of an abnormal termination.

    PROCEDURE block_exit_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status,
        lock_status: ost$signature_lock_status;

      osp$test_sig_lock (dfv$application_info_lock, lock_status);
      IF lock_status = osc$sls_locked_by_current_task THEN
        osp$clear_job_signature_lock (dfv$application_info_lock);
      IFEND;
      clp$close_display (display_control, ignore_status);

    PROCEND block_exit_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    command_name := ' DISPLAY_CLIENT_APPLICATION_INF';

    dfp$verify_system_administrator (command_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    application_name := pvt [p$application_name].value^.name_value;
    all_applications := application_name = 'ALL';

    server_list_count := clp$count_list_elements (pvt [p$server_mainframe_identifiers].value);

    IF pvt [p$server_mainframe_identifiers].value^.kind = clc$keyword THEN {must be ALL
      PUSH p_server_list: [1 .. 10];
      dfp$get_mainframe_list ({partners_are_servers} TRUE, p_server_list^, partner_count);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF partner_count = 0 THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$no_partner_mainframe,
              'DISPLAY_CLIENT_APPLICATION_INFO', status);
        RETURN;
      IFEND;
      IF partner_count > 10 THEN
        PUSH p_server_list: [1 .. partner_count];
        dfp$get_mainframe_list ({partners_are_servers} TRUE, p_server_list^, partner_count);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      server_list_count := partner_count;
    ELSE
      p_list_value := pvt [p$server_mainframe_identifiers].value;
      server_list_count := clp$count_list_elements (pvt [p$server_mainframe_identifiers].value);
    IFEND;

    osp$establish_block_exit_hndlr (^block_exit_handler);

    default_ring_attributes.r1 := 11;
    default_ring_attributes.r2 := 11;
    default_ring_attributes.r3 := 11;

    clp$open_display_reference (pvt [p$output].value^.file_value^, NIL, fsc$list, default_ring_attributes,
          display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    clp$put_display (display_control, command_name, clc$trim, status);

    osp$set_job_signature_lock (dfv$application_info_lock);

    application_found := FALSE;

  /display_server/
    FOR server_index := 1 TO server_list_count DO
      IF pvt [p$server_mainframe_identifiers].value^.kind = clc$keyword THEN {must be ALL
        server_id := p_server_list^ [server_index].mainframe_name;
      ELSE
        server_id := p_list_value^.element_value^.name_value;
        p_list_value := p_list_value^.link;
      IFEND;
      STRINGREP (line, line_size, ' Server Mainframe: ', server_id);
      clp$put_display (display_control, ' ', clc$trim, status);
      clp$put_display (display_control, line (1, line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_server/;
      IFEND;
      dfp$find_mainframe_id (server_id, {host_is_server} FALSE, mainframe_found, ignore_p_q_interf_table,
            p_cpu_queue, ignore_queue_index, ignore_p_q_interf_dir_entry);
      IF NOT mainframe_found THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, server_id, status);
        RETURN;
      IFEND;
      p_host_application_info := p_cpu_queue^.queue_header.p_host_application_info;
      p_remote_application_info := NIL;

    /display_application/
      WHILE p_host_application_info <> NIL DO
        IF all_applications THEN
          application_name := p_host_application_info^.application_name;
        IFEND;
        IF p_host_application_info^.application_name = application_name THEN
          display_host_application_info ({host_is_server} FALSE, p_host_application_info,
                p_remote_application_info, p_cpu_queue, display_control, status);
          IF NOT status.normal THEN
            EXIT /display_server/;
          IFEND;
          application_found := TRUE;
          IF NOT all_applications THEN
            EXIT /display_application/;
          IFEND;
        IFEND;

        p_host_application_info := p_host_application_info^.next_p_application_info;

      WHILEND /display_application/;

      IF pvt [p$display_options].value^.keyword_value (1) = 'F' THEN
        { Since client applications may be defined in a different order than applications on the server,
        { the remote application info array is processed separately from the client info

        p_remote_application_info := p_cpu_queue^.queue_header.p_remote_application_info;
        IF p_remote_application_info = NIL THEN
          clp$put_display (display_control, ' ', clc$trim, status);
          clp$put_display (display_control, ' No remote_information from server.', clc$trim, status);
          CYCLE /display_server/;
        IFEND;

      /display_remote/
        WHILE p_remote_application_info <> NIL DO
          IF all_applications THEN
            application_name := p_remote_application_info^.application_name;
          IFEND;
          IF p_remote_application_info^.application_name = application_name THEN
            clp$put_display (display_control, '  ', clc$trim, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            STRINGREP (line, line_size, '  Application_name: ', application_name);
            clp$put_display (display_control, line (1, line_size), clc$trim, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            application_found := TRUE;
            display_remote_info (p_remote_application_info, p_cpu_queue, display_control, status);
            IF NOT status.normal THEN
              display_status (status);
              status.normal := TRUE;
            IFEND;
            IF NOT all_applications THEN
              EXIT /display_remote/;
            IFEND;
          IFEND;
          p_remote_application_info := p_remote_application_info^.next_p_application_info;
        WHILEND /display_remote/;
      IFEND;

      IF p_host_application_info = NIL THEN
        IF NOT all_applications THEN
          STRINGREP (line, line_size, ' Undefined application: ', application_name);
          clp$put_display (display_control, line (1, line_size), clc$trim, status);
        IFEND;
      IFEND;

    FOREND /display_server/;

    IF (NOT application_found) AND (NOT all_applications) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$application_not_known, application_name, status);
    IFEND;

    IF status.normal THEN
      clp$close_display (display_control, status);
    ELSE
      clp$close_display (display_control, ignore_status);
    IFEND;

    osp$clear_job_signature_lock (dfv$application_info_lock);
    osp$disestablish_cond_handler;

  PROCEND dfp$display_client_app_info_cmn;

?? OLDTITLE ??
?? TITLE := ' [XDCL, #GATE] dfp$get_application_info', EJECT ??
*copyc dfh$get_application_info

  PROCEDURE [XDCL, #GATE] dfp$get_application_info
    (    partner_mainframe_id: pmt$mainframe_id;
         partner_is_server: boolean;
         application_name: ost$name;
     VAR sequence_pointer: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      application_found: boolean,
      ignore_p_q_interf_dir_entry: ^dft$q_interface_directory_entry,
      ignore_p_q_interf_table: ^dft$queue_interface_table,
      ignore_queue_index: dft$queue_index,
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_host_application_info: ^dft$host_application_info;

    status.normal := TRUE;
    sequence_pointer := NIL;
    application_found := FALSE;

    dfp$find_mainframe_id (partner_mainframe_id, NOT partner_is_server, mainframe_found,
          ignore_p_q_interf_table, p_cpu_queue, ignore_queue_index, ignore_p_q_interf_dir_entry);
    IF NOT mainframe_found THEN
      IF partner_is_server THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, partner_mainframe_id, status);
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, partner_mainframe_id, status);
      IFEND;
      RETURN;
    IFEND;


    IF p_cpu_queue^.queue_header.p_host_application_info = NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$application_not_known, application_name, status);
      RETURN;
    IFEND;

    p_host_application_info := p_cpu_queue^.queue_header.p_host_application_info;

  /find_application/
    WHILE p_host_application_info <> NIL DO
      IF p_host_application_info^.application_name = application_name THEN
        application_found := TRUE;
        EXIT /find_application/;
      IFEND;
      p_host_application_info := p_host_application_info^.next_p_application_info;
    WHILEND /find_application/;
    IF NOT application_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$application_not_known, application_name, status);
      RETURN;
    IFEND;

    sequence_pointer := p_host_application_info^.sequence_pointer;

  PROCEND dfp$get_application_info;
?? NEWTITLE := 'Server: [XDCL] dfp$send_remote_app_info ', EJECT ??

{ PURPOSE:
{   The purpose of this request is to satisfy the requirement for a remote
{   procedure to transfer application information to the client.

  PROCEDURE [XDCL] dfp$send_remote_app_info
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      ignore_p_q_interf_dir_entry: ^dft$q_interface_directory_entry,
      ignore_p_q_interf_table: ^dft$queue_interface_table,
      ignore_queue_index: dft$queue_index,
      line: string (200),
      line_size: integer,
      log_string: string (80),
      log_string_length: integer,
      mainframe_found: boolean,
      p_application_name: ^ost$name,
      p_cpu_queue: ^dft$cpu_queue,
      p_mainframe_name: ^pmt$mainframe_id,
      p_number_of_applications: ^dft$number_of_applications,
      p_proc_list: ^array [ * ] of dft$rpc_procedure_address_entry,
      p_remote_application_info: ^dft$remote_application_info,
      p_send_remote_app_info: ^dft$remote_application_info,
      p_total_proc_count: ^dft$total_number_of_app_procs;

    status.normal := TRUE;
    send_parameters_length := 0;

    NEXT p_mainframe_name IN p_param_received_from_client;

    dfp$find_mainframe_id (p_mainframe_name^, {host_is_server=} TRUE, mainframe_found,
          ignore_p_q_interf_table, p_cpu_queue, ignore_queue_index, ignore_p_q_interf_dir_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, p_mainframe_name^, status);
      RETURN;
    IFEND;

    NEXT p_number_of_applications IN p_data_to_client;
    NEXT p_total_proc_count IN p_data_to_client;
    p_number_of_applications^ := 0;
    p_total_proc_count^ := 0;
    IF p_cpu_queue^.queue_header.p_remote_application_info = NIL THEN
      data_size_to_send_to_client := i#current_sequence_position (p_data_to_client);
      RETURN;
    IFEND;

    p_remote_application_info := p_cpu_queue^.queue_header.p_remote_application_info;
    WHILE p_remote_application_info <> NIL DO
      p_number_of_applications^ := p_number_of_applications^ +1;
      NEXT p_send_remote_app_info IN p_data_to_client;
      p_send_remote_app_info^ := p_remote_application_info^;
      p_remote_application_info := p_remote_application_info^.next_p_application_info;
    WHILEND;

    p_total_proc_count^ := UPPERBOUND (p_cpu_queue^.queue_header.p_application_rpc_list^);

    NEXT p_proc_list: [1 .. p_total_proc_count^] IN p_data_to_client;
    p_proc_list^ := p_cpu_queue^.queue_header.p_application_rpc_list^;

    data_size_to_send_to_client := i#current_sequence_position (p_data_to_client);

    STRINGREP (log_string, log_string_length, ' Client ', p_mainframe_name^, ' Total_applications:',
          p_number_of_applications^, '   Total_procedures:', p_total_proc_count^);
    log_display ($pmt$ascii_logset [pmc$system_log], log_string (1, log_string_length));
    IF dfv$file_server_debug_enabled THEN
      display (log_string (1, log_string_length));
      display_to_console (log_string (1, log_string_length));
    IFEND;

  PROCEND dfp$send_remote_app_info;
?? OLDTITLE ??
?? NEWTITLE := 'add_host_application_info', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to allocate in server-wired the
{   specified host application information.

  PROCEDURE add_host_application_info
    (    host_application_info: dft$host_application_info;
         host_is_server: boolean;
         partner_id: pmt$mainframe_id;
         sequence_size: dft$send_data_size;
         p_attached_file_info: ^array [ * ] of ^fst$file_reference;
         p_library_file_path: ^fst$file_reference;
         command_name: ost$name;
     VAR p_cpu_queue: ^dft$cpu_queue;
     VAR status: ost$status);

    VAR
      attached_file_index: dft$number_of_attached_files,
      defined_application_count: dft$number_of_applications,
      hold_p_host_application_info: ^dft$host_application_info,
      number_of_attached_files: dft$number_of_attached_files,
      p_cpu_queue_header: ^dft$cpu_queue_header,
      p_host_application_info: ^dft$host_application_info;

    status.normal := TRUE;

    check_partner_state (partner_id, host_is_server, command_name, p_cpu_queue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_cpu_queue_header := ^p_cpu_queue^.queue_header;

    hold_p_host_application_info := NIL;
    p_host_application_info := p_cpu_queue_header^.p_host_application_info;
    defined_application_count := 0;

  /find_last_application/
    WHILE p_host_application_info <> NIL DO
      IF p_host_application_info^.application_name = host_application_info.application_name THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$application_already_defined,
              host_application_info.application_name, status);
        RETURN;
      IFEND;
      defined_application_count := defined_application_count + 1;
      hold_p_host_application_info := p_host_application_info;
      p_host_application_info := p_host_application_info^.next_p_application_info;
    WHILEND /find_last_application/;

    IF defined_application_count >= dfc$max_number_of_applications THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$max_application_count, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, dfc$max_number_of_applications, 10, FALSE,
            status);
      RETURN;
    IFEND;

    ALLOCATE p_host_application_info IN dfv$server_wired_heap^;
    IF p_host_application_info = NIL THEN
      osp$system_error (' NIL p_host_application_info', NIL);
    IFEND;

    p_host_application_info^ := host_application_info;

    IF p_library_file_path = NIL THEN
      p_host_application_info^.p_library_file_path := NIL;
    ELSE
      ALLOCATE p_host_application_info^.p_library_file_path: [#SIZE (p_library_file_path^)] IN
            dfv$server_wired_heap^;
      IF p_host_application_info^.p_library_file_path = NIL THEN
        osp$system_error (' NIL p_library_file_path', NIL);
      IFEND;
      p_host_application_info^.p_library_file_path^ := p_library_file_path^;
    IFEND;

    IF sequence_size > 0 THEN
      ALLOCATE p_host_application_info^.sequence_pointer: [[REP sequence_size OF cell]] IN
            dfv$server_wired_heap^;
      IF p_host_application_info^.sequence_pointer = NIL THEN
        osp$system_error (' NIL sequence_pointer', NIL);
      IFEND;
      RESET p_host_application_info^.sequence_pointer;
      pmp$zero_out_table (p_host_application_info^.sequence_pointer, sequence_size);
    ELSE
      p_host_application_info^.sequence_pointer := NIL;
    IFEND;

    IF p_attached_file_info = NIL THEN
      p_host_application_info^.p_attached_file_info := NIL;
    ELSE
      number_of_attached_files := UPPERBOUND (p_attached_file_info^);
      ALLOCATE p_host_application_info^.p_attached_file_info: [1 .. number_of_attached_files] IN
            dfv$server_wired_heap^;
      IF p_host_application_info^.p_attached_file_info = NIL THEN
        osp$system_error (' NIL p_attached_file_info', NIL);
      IFEND;
      FOR attached_file_index := 1 TO number_of_attached_files DO
        ALLOCATE p_host_application_info^.p_attached_file_info^
              [attached_file_index]: [#SIZE (p_attached_file_info^ [attached_file_index]^)] IN
              dfv$server_wired_heap^;
        IF p_host_application_info^.p_attached_file_info^ [attached_file_index] = NIL THEN
          osp$system_error (' NIL p_attached_file_info^', NIL);
        IFEND;
        p_host_application_info^.p_attached_file_info^ [attached_file_index]^ :=
              p_attached_file_info^ [attached_file_index]^;
      FOREND;
    IFEND;

{ Link in with CPU queue.
    IF hold_p_host_application_info = NIL THEN
      p_cpu_queue_header^.p_host_application_info := p_host_application_info;
    ELSE
      hold_p_host_application_info^.next_p_application_info := p_host_application_info;
    IFEND;

  PROCEND add_host_application_info;
?? OLDTITLE ??
?? NEWTITLE := 'add_remote_application_info', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to add to server-wired the remote application
{   information and the extended application address list.
{ NOTES:
{   Although the remote application info pointed to by the cpu queue header,
{   the application rpc list  consists of information for all applications.


  PROCEDURE add_remote_application_info
    (    remote_application_info: dft$remote_application_info;
         p_cpu_queue: ^dft$cpu_queue;
         p_application_rpc_list: ^array [ * ] of dft$rpc_procedure_address_entry;
     VAR status: ost$status);

    VAR
      add_procedure_count: dft$number_of_procs_per_app,
      application_index: dft$number_of_applications,
      hold_p_application_rpc_list: ^array [ * ] of dft$rpc_procedure_address_entry,
      hold_p_remote_application_info: ^dft$remote_application_info,
      next_procedure_ordinal: dft$procedure_address_ordinal,
      old_procedure_count: dft$total_number_of_app_procs,
      p_cpu_queue_header: ^dft$cpu_queue_header,
      p_remote_application_info: ^dft$remote_application_info,
      procedure_index: dft$total_number_of_app_procs;

    status.normal := TRUE;
    IF p_application_rpc_list = NIL THEN
      RETURN;
    IFEND;

    p_cpu_queue_header := ^p_cpu_queue^.queue_header;
    application_index := 1;
    p_remote_application_info := p_cpu_queue_header^.p_remote_application_info;
    hold_p_remote_application_info := NIL;

  /find_last_application/
    WHILE p_remote_application_info <> NIL DO
      application_index := application_index + 1;
      hold_p_remote_application_info := p_remote_application_info;
      p_remote_application_info := p_remote_application_info^.next_p_application_info;
    WHILEND /find_last_application/;

    IF p_cpu_queue_header^.p_application_rpc_list <> NIL THEN
      check_for_dup_proc_names (p_cpu_queue_header^.p_application_rpc_list, p_application_rpc_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    ALLOCATE p_remote_application_info IN dfv$server_wired_heap^;
    IF p_remote_application_info = NIL THEN
      osp$system_error (' NIL p_remote_application_info', NIL);
    IFEND;

    IF hold_p_remote_application_info <> NIL THEN
      hold_p_remote_application_info^.next_p_application_info := p_remote_application_info;
    ELSE
      p_cpu_queue_header^.p_remote_application_info := p_remote_application_info;
    IFEND;

    p_remote_application_info^ := remote_application_info;

{ Process rpc address list
    add_procedure_count := UPPERBOUND (p_application_rpc_list^);
    old_procedure_count := 0;
    next_procedure_ordinal := SUCC (dfc$last_system_procedure);

    IF p_cpu_queue_header^.p_application_rpc_list <> NIL THEN
      old_procedure_count := UPPERBOUND (p_cpu_queue_header^.p_application_rpc_list^);
      PUSH hold_p_application_rpc_list: [1 .. old_procedure_count];
      hold_p_application_rpc_list^ := p_cpu_queue_header^.p_application_rpc_list^;
      FREE p_cpu_queue_header^.p_application_rpc_list IN dfv$server_wired_heap^;

      ALLOCATE p_cpu_queue^.queue_header.p_application_rpc_list:
            [1 .. (old_procedure_count + add_procedure_count)] IN dfv$server_wired_heap^;
      IF p_cpu_queue^.queue_header.p_application_rpc_list = NIL THEN
        osp$system_error (' NIL p_application_rpc_list', NIL);
      IFEND;

    /copy_old_procedure_list/
      FOR procedure_index := 1 TO old_procedure_count DO
        p_cpu_queue_header^.p_application_rpc_list^ [procedure_index] :=
              hold_p_application_rpc_list^ [procedure_index];
        next_procedure_ordinal := SUCC (next_procedure_ordinal);
      FOREND /copy_old_procedure_list/;

    ELSE
      ALLOCATE p_cpu_queue^.queue_header.p_application_rpc_list: [1 .. add_procedure_count] IN
            dfv$server_wired_heap^;
      IF p_cpu_queue^.queue_header.p_application_rpc_list = NIL THEN
        osp$system_error (' NIL p_application_rpc_list', NIL);
      IFEND;
    IFEND;

    p_remote_application_info^.first_procedure_rpc_ordinal := next_procedure_ordinal;

  /add_new_procedures/
    FOR procedure_index := 1 TO add_procedure_count DO
      p_application_rpc_list^ [procedure_index].application_index := application_index;
      p_cpu_queue_header^.p_application_rpc_list^ [procedure_index + old_procedure_count] :=
            p_application_rpc_list^ [procedure_index];
    FOREND /add_new_procedures/;

  PROCEND add_remote_application_info;
?? OLDTITLE ??
?? NEWTITLE := 'check_for dup_proc_names', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to check that no name of remote procedures
{   being added duplicate a name already in the remote procedure list. It is
{   assumed that all names in the new list are unique.

  PROCEDURE check_for_dup_proc_names
    (    old_procedure_list: ^array [ * ] of dft$rpc_procedure_address_entry;
         new_procedure_list: ^array [ * ] of dft$rpc_procedure_address_entry;
     VAR status: ost$status);

    VAR
      old_index: dft$total_number_of_app_procs,
      new_index: dft$number_of_procs_per_app,
      proc_name: pmt$program_name;

    IF UPPERBOUND (old_procedure_list^) + UPPERBOUND (new_procedure_list^) > dfc$max_number_of_app_procs THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$max_remote_proc_count, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, dfc$max_number_of_app_procs, 10, FALSE,
            status);
      RETURN;
    IFEND;

    FOR new_index := 1 TO UPPERBOUND (new_procedure_list^) DO
      proc_name := new_procedure_list^ [new_index].debug_display;

    /search_old_procedure_list/
      FOR old_index := 1 TO UPPERBOUND (old_procedure_list^) DO
        IF proc_name = old_procedure_list^ [old_index].debug_display THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$procedure_already_defined, proc_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, ' (previous) ', status);
          RETURN;
        IFEND;
      FOREND /search_old_procedure_list/;
    FOREND;

    status.normal := TRUE;

  PROCEND check_for_dup_proc_names;
?? OLDTITLE ??
?? NEWTITLE := 'check_partner_state', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to obtain the state of the partner mainframe
{   and to check that it is either terminated or awaiting_recovery.

  PROCEDURE check_partner_state
    (    partner_id: pmt$mainframe_id;
         host_is_server: boolean;
         command_name: ost$name;
     VAR p_cpu_queue: ^dft$cpu_queue;
     VAR status: ost$status);

    VAR
      ignore_p_q_interf_dir_entry: ^dft$q_interface_directory_entry,
      ignore_p_q_interf_table: ^dft$queue_interface_table,
      ignore_queue_index: dft$queue_index,
      mainframe_found: boolean,
      partner_state: dft$server_state;

    status.normal := TRUE;

    dfp$find_mainframe_id (partner_id, host_is_server, mainframe_found, ignore_p_q_interf_table, p_cpu_queue,
          ignore_queue_index, ignore_p_q_interf_dir_entry);
    IF NOT mainframe_found THEN
      IF host_is_server THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, partner_id, status);
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, partner_id, status);
      IFEND;
      RETURN;
    IFEND;

    partner_state := p_cpu_queue^.queue_header.partner_status.server_state;
    IF (partner_state <> dfc$terminated) AND (partner_state <> dfc$awaiting_recovery) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_state_for_def_app, command_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, partner_id, status);
      RETURN;
    IFEND;

  PROCEND check_partner_state;
?? OLDTITLE ??
?? NEWTITLE := ' delete_host_application', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to delete host application information
{   associated with a particular partner mainframe.

  PROCEDURE delete_host_application
    (    application_name: ost$name;
         mainframe_id: pmt$mainframe_id;
         host_is_server: boolean;
         command_name: ost$name;
     VAR status: ost$status);

    VAR
      attached_file_index: dft$number_of_attached_files,
      ignore_p_q_interf_dir_entry: ^dft$q_interface_directory_entry,
      ignore_p_q_interf_table: ^dft$queue_interface_table,
      ignore_queue_index: dft$queue_index,
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_host_application_info: ^dft$host_application_info,
      p_p_host_application_info: ^^dft$host_application_info;

    status.normal := TRUE;
    check_partner_state (mainframe_id, host_is_server, command_name, p_cpu_queue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_host_application_info := p_cpu_queue^.queue_header.p_host_application_info;
    p_p_host_application_info := ^p_cpu_queue^.queue_header.p_host_application_info;

  /search_for_application/
    WHILE p_host_application_info <> NIL DO
      IF p_host_application_info^.application_name = application_name THEN
        IF p_host_application_info^.p_attached_file_info <> NIL THEN

        /free_file_info/
          FOR attached_file_index := 1 TO UPPERBOUND (p_host_application_info^.p_attached_file_info^) DO
            FREE p_host_application_info^.p_attached_file_info^ [attached_file_index] IN
                  dfv$server_wired_heap^;
          FOREND /free_file_info/;
          FREE p_host_application_info^.p_attached_file_info IN dfv$server_wired_heap^;
        IFEND;

        IF p_host_application_info^.sequence_pointer <> NIL THEN
          FREE p_host_application_info^.sequence_pointer IN dfv$server_wired_heap^;
        IFEND;

        IF p_host_application_info^.p_library_file_path <> NIL THEN
          FREE p_host_application_info^.p_library_file_path IN dfv$server_wired_heap^;
        IFEND;
        p_p_host_application_info^ := p_host_application_info^.next_p_application_info;
        FREE p_host_application_info IN dfv$server_wired_heap^;
        RETURN;
      IFEND;
      p_p_host_application_info := ^p_host_application_info^.next_p_application_info;
      p_host_application_info := p_host_application_info^.next_p_application_info;
    WHILEND /search_for_application/;

    osp$set_status_abnormal (dfc$file_server_id, dfe$application_not_known, application_name, status);

  PROCEND delete_host_application;
?? OLDTITLE ??
?? NEWTITLE := ' delete_remote_application', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to remove from server-wired the remote
{   application information associated with a particular partner mainframe.

  PROCEDURE delete_remote_application
    (    application_name: ost$name;
         mainframe_id: pmt$mainframe_id;
         host_is_server: boolean;
     VAR status: ost$status);

    VAR
      application_found_index: dft$number_of_applications,
      application_index: dft$number_of_applications,
      free_p_remote_application_info: ^dft$remote_application_info,
      ignore_p_q_interf_dir_entry: ^dft$q_interface_directory_entry,
      ignore_p_q_interf_table: ^dft$queue_interface_table,
      ignore_queue_index: dft$queue_index,
      last_procedure_index: dft$total_number_of_app_procs,
      mainframe_found: boolean,
      old_procedure_count: dft$total_number_of_app_procs,
      p_cpu_queue: ^dft$cpu_queue,
      p_new_application_rpc_list: ^array [ * ] of dft$rpc_procedure_address_entry,
      p_next_remote_application_info: ^dft$remote_application_info,
      p_old_application_rpc_list: ^array [ * ] of dft$rpc_procedure_address_entry,
      p_p_remote_application_info: ^^dft$remote_application_info,
      p_remote_application_info: ^dft$remote_application_info,
      procedure_index: dft$total_number_of_app_procs,
      procedure_ordinal: dft$procedure_address_ordinal,
      remove_procedure_count: dft$number_of_procs_per_app,
      start_remove_index: dft$total_number_of_app_procs;

    status.normal := TRUE;
    dfp$find_mainframe_id (mainframe_id, host_is_server, mainframe_found, ignore_p_q_interf_table,
          p_cpu_queue, ignore_queue_index, ignore_p_q_interf_dir_entry);
    IF NOT mainframe_found THEN
      IF host_is_server THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, mainframe_id, status);
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, mainframe_id, status);
      IFEND;
      RETURN;
    IFEND;

    p_remote_application_info := p_cpu_queue^.queue_header.p_remote_application_info;
    p_old_application_rpc_list := p_cpu_queue^.queue_header.p_application_rpc_list;
    p_p_remote_application_info := ^p_cpu_queue^.queue_header.p_remote_application_info;
    free_p_remote_application_info := NIL;
    application_index := 0;
    application_found_index := 0;

  /find_application/
    WHILE p_remote_application_info <> NIL DO
      application_index := application_index + 1;
      IF p_remote_application_info^.application_name = application_name THEN
        application_found_index := application_index;
        p_p_remote_application_info^ := p_remote_application_info^.next_p_application_info;
        IF p_cpu_queue^.queue_header.p_application_rpc_list <> NIL THEN
          old_procedure_count := UPPERBOUND (p_old_application_rpc_list^);
          remove_procedure_count := p_remote_application_info^.number_of_procedures;
          procedure_ordinal := p_remote_application_info^.first_procedure_rpc_ordinal;
          start_remove_index := $INTEGER (p_remote_application_info^.first_procedure_rpc_ordinal) -
                $INTEGER (dfc$last_system_procedure);
          IF old_procedure_count > remove_procedure_count THEN
            ALLOCATE p_new_application_rpc_list: [1 .. (old_procedure_count - remove_procedure_count)] IN
                  dfv$server_wired_heap^;
            IF p_new_application_rpc_list = NIL THEN
              osp$system_error (' NIL p_new_application_rpc_list', NIL);
            IFEND;
            FOR procedure_index := 1 TO start_remove_index - 1 DO
              p_new_application_rpc_list^ [procedure_index] := p_old_application_rpc_list^ [procedure_index];
            FOREND;
            last_procedure_index := start_remove_index - 1;
          ELSE
            p_new_application_rpc_list := NIL;
          IFEND;
          free_p_remote_application_info := p_remote_application_info;
          application_index := application_index - 1; {for next application
        IFEND;

      ELSEIF application_found_index > 0 THEN { Entry is beyond the deleted entry
        p_remote_application_info^.first_procedure_rpc_ordinal := procedure_ordinal;
        FOR procedure_index := (last_procedure_index + 1) TO
              (last_procedure_index + p_remote_application_info^.number_of_procedures) DO
          p_new_application_rpc_list^ [procedure_index] := p_old_application_rpc_list^
                [procedure_index + remove_procedure_count];
          p_new_application_rpc_list^ [procedure_index].application_index := application_index;
          procedure_ordinal := SUCC (procedure_ordinal);
        FOREND;

      IFEND;
      p_p_remote_application_info := ^p_remote_application_info^.next_p_application_info;
      p_remote_application_info := p_remote_application_info^.next_p_application_info;
    WHILEND /find_application/;

    IF application_found_index = 0 THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$application_not_known, application_name, status);
      RETURN;
    IFEND;

    IF free_p_remote_application_info <> NIL THEN
      FREE free_p_remote_application_info IN dfv$server_wired_heap^;
      free_p_remote_application_info := NIL;
    IFEND;

    FREE p_cpu_queue^.queue_header.p_application_rpc_list IN dfv$server_wired_heap^;
    p_cpu_queue^.queue_header.p_application_rpc_list := p_new_application_rpc_list;

  PROCEND delete_remote_application;
?? OLDTITLE ??
?? NEWTITLE := 'display_host_application_info', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to display the information associated
{   with one application.

  PROCEDURE display_host_application_info
    (    host_is_server: boolean;
         p_host_application_info: ^dft$host_application_info;
         p_remote_application_info: ^dft$remote_application_info;
         p_cpu_queue: ^dft$cpu_queue;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      first_proc_index: dft$total_number_of_app_procs,
      i: dft$number_of_attached_files,
      line: string (200),
      line_size: integer,
      next_p_app_info: ^dft$host_application_info,
      number_of_attached_files: dft$number_of_attached_files,
      p_app_info: ^dft$host_application_info,
      p_attached_file_info: ^array [ * ] of ^fst$file_reference,
      p_cpu_queue_header: ^dft$cpu_queue_header,
      sequence_size: dft$send_data_size,
      str: string (25);

    clp$put_display (display_control, '  ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    p_app_info := p_host_application_info;
    p_cpu_queue_header := ^p_cpu_queue^.queue_header;

    STRINGREP (line, line_size, '  Application_name: ', p_app_info^.application_name);
    clp$put_display (display_control, line (1, line_size), clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_app_info^.p_library_file_path = NIL THEN
      STRINGREP (line, line_size, '  Library: (none specified)');
    ELSE
      STRINGREP (line, line_size, '  Library: ', p_app_info^.p_library_file_path^);
    IFEND;
    clp$put_display (display_control, line (1, line_size), clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF dfv$file_server_debug_enabled THEN
      STRINGREP (line, line_size, '  p_library_file_path: ', p_app_info^.p_library_file_path);
      clp$put_display (display_control, line (1, line_size), clc$trim, status);
    IFEND;
    IF p_app_info^.state_change_procedure_name = osc$null_name THEN
      STRINGREP (line, line_size, '  State_change_procedure:  (none)');
    ELSE
      STRINGREP (line, line_size, '  State_change_procedure: ', p_app_info^.state_change_procedure_name);
    IFEND;
    clp$put_display (display_control, line (1, line_size), clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF p_app_info^.sequence_pointer = NIL THEN
      sequence_size := 0;
    ELSE
      sequence_size := #SIZE (p_app_info^.sequence_pointer^);
    IFEND;
    STRINGREP (line, line_size, '  Sequence_size: ', sequence_size);
    clp$put_display (display_control, line (1, line_size), clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT host_is_server THEN
      RETURN;
    IFEND;

    IF dfv$file_server_debug_enabled THEN
      IF p_app_info^.p_attached_file_info = NIL THEN
        number_of_attached_files := 0;
      ELSE
        p_attached_file_info := p_app_info^.p_attached_file_info;
        number_of_attached_files := UPPERBOUND (p_attached_file_info^);
      IFEND;
      STRINGREP (line, line_size, '  Number of Attach_files: ', number_of_attached_files);
      clp$put_display (display_control, line (1, line_size), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      FOR i := 1 TO number_of_attached_files DO
        STRINGREP (line, line_size, '    ', p_attached_file_info^ [i]^);
        clp$put_display (display_control, line (1, line_size), clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    IF p_remote_application_info^.number_of_procedures > 0 THEN
      STRINGREP (line, line_size, '  Remote procedure count: ',
            p_remote_application_info^.number_of_procedures);
    ELSE
      STRINGREP (line, line_size, '  Remote procedure count: (none)');
    IFEND;
    clp$put_display (display_control, line (1, line_size), clc$trim, status);

  PROCEND display_host_application_info;
?? OLDTITLE ??
?? NEWTITLE := 'display_remote_info', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to display the remote application information.

  PROCEDURE display_remote_info
    (    p_remote_application_info: ^dft$remote_application_info;
         p_cpu_queue: ^dft$cpu_queue;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      first_proc_index: dft$total_number_of_app_procs,
      line: string (200),
      line_size: integer,
      p_cpu_queue_header: ^dft$cpu_queue_header,
      proc_index: dft$total_number_of_app_procs,
      procedure_ordinal: dft$procedure_address_ordinal,
      str: string (25);

    clp$put_display (display_control, '  ', clc$trim, status);
    status.normal := TRUE;
    p_cpu_queue_header := ^p_cpu_queue^.queue_header;

    IF p_cpu_queue_header^.p_application_rpc_list = NIL THEN
      clp$put_display (display_control, ' No extended procedure list', clc$trim, status);
      RETURN;
    IFEND;
    clp$put_display (display_control, '  Remote_procedures:', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    first_proc_index := $INTEGER (p_remote_application_info^.first_procedure_rpc_ordinal) -
          $INTEGER (dfc$last_system_procedure);
    procedure_ordinal := p_remote_application_info^.first_procedure_rpc_ordinal;
    FOR proc_index := first_proc_index TO (first_proc_index +
          p_remote_application_info^.number_of_procedures - 1) DO
      clp$put_display (display_control, '  ', clc$trim, status);
      STRINGREP (line, line_size, '    Name: ', p_cpu_queue_header^.p_application_rpc_list^ [proc_index].
            debug_display);
      clp$put_display (display_control, line (1, line_size), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF dfv$file_server_debug_enabled THEN
        STRINGREP (line, line_size, '    Procedure ordinal: ', procedure_ordinal);
        clp$put_display (display_control, line (1, line_size), clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      IF p_cpu_queue_header^.p_application_rpc_list^ [proc_index].request_restartable =
            dfc$request_restartable THEN
        str := 'TRUE';
      ELSE
        str := 'FALSE';
      IFEND;
      STRINGREP (line, line_size, '    Request_restartable: ', str);
      clp$put_display (display_control, line (1, line_size), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      CASE p_cpu_queue_header^.p_application_rpc_list^ [proc_index].job_recovery_location OF
      = dfc$job_rec_started_by_caller =
        str := 'caller_starts_recovery';
      = dfc$job_rec_in_unavailable_wait =
        str := 'caller_waits_for_volume';
      ELSE
        str := ' ???  ';
      CASEND;
      STRINGREP (line, line_size, '    Job_recovery_location: ', str);
      clp$put_display (display_control, line (1, line_size), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF p_cpu_queue_header^.p_application_rpc_list^ [proc_index].recover_job_on_server_call THEN
        str := 'TRUE'
      ELSE
        str := 'FALSE';
      IFEND;
      STRINGREP (line, line_size, '    Recover_job_on_server_call: ',
            p_cpu_queue_header^.p_application_rpc_list^ [proc_index].recover_job_on_server_call);
      clp$put_display (display_control, line (1, line_size), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF dfv$file_server_debug_enabled THEN
        STRINGREP (line, line_size, '    Procedure_version: ', p_cpu_queue_header^.
              p_application_rpc_list^ [proc_index].procedure_version);
        clp$put_display (display_control, line (1, line_size), clc$trim, status);
        STRINGREP (line, line_size, '    Procedure_name_checksum: ',
              p_cpu_queue_header^.p_application_rpc_list^ [proc_index].procedure_name_checksum);
        clp$put_display (display_control, line (1, line_size), clc$trim, status);
        STRINGREP (line, line_size, '    Application_index: ', p_cpu_queue_header^.
              p_application_rpc_list^ [proc_index].application_index);
        clp$put_display (display_control, line (1, line_size), clc$trim, status);
      IFEND;

      STRINGREP (line, line_size, '    Application_ring: ', p_cpu_queue_header^.
            p_application_rpc_list^ [proc_index].application_ring);
      clp$put_display (display_control, line (1, line_size), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF p_cpu_queue_header^.p_application_rpc_list^ [proc_index].allow_terminate_break THEN
        str := 'TRUE';
      ELSE
        str := 'FALSE';
      IFEND;

      STRINGREP (line, line_size, '    Allow_terminate_break: ', str);
      clp$put_display (display_control, line (1, line_size), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF p_cpu_queue_header^.p_application_rpc_list^ [proc_index].allow_pause_break THEN
        str := 'TRUE';
      ELSE
        str := 'FALSE';
      IFEND;
      STRINGREP (line, line_size, '    Allow_pause_break: ', str);
      clp$put_display (display_control, line (1, line_size), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF proc_index < (first_proc_index + p_remote_application_info^.number_of_procedures - 1) THEN
        procedure_ordinal := SUCC (procedure_ordinal);
      IFEND;

    FOREND;
  PROCEND display_remote_info;
?? OLDTITLE ??

MODEND dfm$manage_application_info;
*DECK DECK=DFM$MANAGE_CLIENT_CONNECTION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: Server: Connection Manager', EJECT ??
MODULE dfm$manage_client_connection;

{================================================================================
{
{  This module is a Clone Master task managing the connection with the
{  DF Client mainframe. This includes reacting to the operator's commands:
{
{     Activate_Client
{     Deactivate_Client
{     Terminate_Client
{
{  as well as responding to the periodic polls that the Client sends to the
{  Server. This task also supervises and times out the requests to the Server
{  posted by the stable clones.
{
{  The operator requests come to this task indirectly: the various action
{  signals are set in the CPU_Queue header (Partner_Status record) by the
{  command processors and this task acts upon them.
{
{  Abnormal conditions will cause dfm$manage_client_connection to abort
{  the connection with the Client and to time itself out. Such conditions
{  include: garbled poll messages from the Server, time-out of the poll message,
{  and incorrect info contained in the request to verify Server Queue definition
{  on the Client. An incorrect family name in the Verify_Queue request or in
{  Verify_Family request, however, does not cause an abort. The family in question
{  will simply not be validated. Family will remain inaccessible to the users
{  on the Client in this case.
{
{===============================================================================

?? NEWTITLE := '    Global Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??

*copyc clp$scan_parameter_list
*copyc dfc$test_jr_constants
*copyc dfc$loopback_server_mainframe
*copyc dfc$esm_allocation_constants
*copyc dfc$poll_constants
*copyc dfc$test_jr_constants
*copyc dfd$driver_queue_types
*copyc dfd$request_package
*copyc dfe$error_condition_codes
*copyc dfi$display
*copyc dfi$log_display
*copyc dft$application_support_limits
*copyc dfp$attach_application_library
*copyc dfp$build_client_mf_file_name
*copyc dfp$crack_mainframe_id
*copyc dfp$determine_action_for_server
*copyc dfp$establish_clone_task_stable
*copyc dfp$execute_state_change_task
*copyc dfp$fetch_queue_entry
*copyc dfp$find_mainframe_id
*copyc dfp$get_queue_directory_index
*copyc dfp$load_pp_if_first
*copyc dfp$queue_task_request
*copyc dfp$remove_client_jobs
*copyc dfp$reset_mainframe_tables
*copyc dfp$send_message_to_operator
*copyc dfp$set_client_mf_file_info
*copyc dfp$submit_client_mainframe_job
*copyc dfp$term_processing_on_server
*copyc dfp$timeout_requests_on_server
*copyc dfp$unload_pp_if_last
*copyc dfp$verify_system_administrator
*copyc dfp$word_boundary
*copyc dft$client_mainframe_file
*copyc dft$command_buffer
*copyc dft$cpu_queue
*copyc dft$display_identifier
*copyc dft$entry_type
*copyc dft$family_access
*copyc dft$family_list
*copyc dft$poll_family_list
*copyc dft$poll_header
*copyc dft$poll_message
*copyc dft$poll_queue_information
*copyc dft$procedure_address_ordinal
*copyc dft$queue_index
*copyc dfv$display_poll
*copyc dfv$file_server_debug_enabled
*copyc dfv$send_command_flags
*copyc dft$queue_interface_directory
*copyc dpp$put_next_line
*copyc i#current_sequence_position
*copyc ofd$type_definition
*copyc osc$server_state_change
*copyc osc$status_parameter_delimiter
*copyc osp$append_status_parameter
*copyc osp$establish_block_exit_hndlr
*copyc osp$format_message
*copyc osp$get_families_for_client
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc oss$task_private
*copyc oss$task_shared
*copyc osv$task_shared_heap
*copyc pfp$attach
*copyc pfp$validate_local_family
*copyc pmd$system_log_interface
*copyc pmp$cause_condition_in_tasks
*copyc pmp$exit
*copyc pmp$get_compact_date_time
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_job_names
*copyc pmp$get_mainframe_id
*copyc pmp$log_ascii
*copyc pmp$wait
*copyc pmt$binary_mainframe_id
*copyc pmt$mainframe_id
*copyc qfp$discard_client_jobs
*copyc syp$hang_if_system_jrt_set
*copyc syp$invoke_system_debugger
*copyc syv$test_jr_job
?? POP ??
?? TITLE := '    Global Variables ', EJECT ??

  VAR
    dfv$normal_client_termination: [XDCL, oss$task_shared] boolean := FALSE;

  CONST
    client = 'Client ';

*copyc dfv$job_recovery_enabled
*copyc dfv$poll_type_string
*copyc dfv$p_clone_tasks_status
*copyc dpv$system_core_display
*copyc osv$os_defaults
*copyc osv$page_size

?? TITLE := '    dfp$manage_client_connection', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$manage_client_connection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{       pdt manage_client_pdt (
{           mainframe_name: name pmc$mainframe_id_size = $required
{           status)

?? PUSH (LISTEXT := ON) ??

    VAR
      manage_client_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^manage_client_pdt_names, ^manage_client_pdt_params];

    VAR
      manage_client_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of
            clt$parameter_name_descriptor := [['MAINFRAME_NAME', 1], ['STATUS', 2]];

    VAR
      manage_client_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ MAINFRAME_NAME

      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$name_value, pmc$mainframe_id_size, pmc$mainframe_id_size]],

{ STATUS

      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id;

    dfp$verify_system_administrator ('MANAGE_CLIENT_CONNECTION', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, manage_client_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$crack_mainframe_id ('MAINFRAME_NAME', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_client_mainframe_file (mainframe_name, status);
    IF NOT status.normal THEN
      display_error_status (status);
      RETURN;
    IFEND;
    dfp$determine_client_status (mainframe_name, status);

  PROCEND dfp$manage_client_connection;

?? TITLE := '    dfp$determine_client_status', EJECT ??

  PROCEDURE [XDCL] dfp$determine_client_status
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);


?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

  PROCEDURE handle_block_exit
    (    condition: pmt$condition;
         condition_information_p: ^pmt$condition_information;
         sfsa_p: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    VAR
      ignore_status: ost$status;

    IF NOT dfv$normal_client_termination THEN
       send_message_to_operator (' Abnormal client termination ', mainframe_name);
      { Catch aborts, or terminate_job
      CASE p_cpu_queue^.queue_header.partner_status.server_state OF
      = dfc$terminated, dfc$awaiting_recovery, dfc$inactive =
        p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
      ELSE
        timeout_job (p_cpu_queue, queue_index, p_queue_interface_table, ' Client block exit', FALSE);
      CASEND;

      IF status.normal THEN
        osp$set_status_from_condition (dfc$file_server_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    IFEND;
  PROCEND handle_block_exit;
?? OLDTITLE ??

    VAR
      ignore_status: ost$status,
      mainframe_found: boolean,
      operator_message: string (79),
      p_cpu_queue: ^dft$cpu_queue,
      p_poll_header: ^dft$poll_header,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: ^dft$queue_interface_table,
      queue_index: dft$queue_index,
      reply_header: dft$poll_header,
      server_to_client: boolean,
      time_before_wait: integer,
      wait_time: integer;

{-------------------------------------
{   Set values for the life of the task.
{-------------------------------------

    status.normal := TRUE;
    dfp$verify_system_administrator ('ACTIVATE_CLIENT', status);
    IF NOT status.normal THEN
      display_error_status (status);
      RETURN;
    IFEND;
    server_to_client := TRUE;
    dfp$find_mainframe_id (mainframe_name, server_to_client, mainframe_found, p_queue_interface_table,
          p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      system_error ('INCORRECT SERVER MAINFRAME ID IN CLONE MASTER.');
    IFEND;
    osp$establish_block_exit_hndlr (^handle_block_exit);
    pmp$get_executing_task_gtid (p_cpu_queue^.queue_entries [dfc$poll_queue_index].global_task_id);
    pmp$get_mainframe_id (reply_header.mainframe_name, ignore_status);
    wait_time := p_cpu_queue^.queue_header.timeout_interval DIV 1000;

    dfp$attach_application_library (p_cpu_queue);

{   Check for "Loopback" mode and fudge in the mainframe_name.
{   NOTE: The invented Mainframe_Name must be passed in as the name of this SERVER.

    IF (reply_header.mainframe_name = mainframe_name) THEN
      reply_header.mainframe_name := dfc$loopback_server_mainframe;
    IFEND;

  /main_loop/
    WHILE TRUE DO
      #SPOIL (p_cpu_queue^.queue_header.partner_status);
      syp$hang_if_system_jrt_set (dfc$tjr_determine_client_status);

{ Termination conditions have priority over timeout.

      IF p_cpu_queue^.queue_header.partner_status.terminate_partner THEN
        operator_message := '  Operator terminated Client.';
        terminate_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message,
          { Restart}  FALSE);

      ELSEIF p_cpu_queue^.queue_header.partner_status.timeout_partner THEN
        operator_message := '  System timing out Client.';
        timeout_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message,
          { Restart}  FALSE);
      ELSE

{--------------------------
{       Check Server State.
{--------------------------

        CASE p_cpu_queue^.queue_header.partner_status.server_state OF

        = dfc$inactive =
          IF p_cpu_queue^.queue_header.partner_status.verify_queue THEN
            pmp$get_executing_task_gtid (p_cpu_queue^.queue_entries [dfc$poll_queue_index].
                  global_task_id);
            wait_for_verify_queue_message (p_cpu_queue, queue_index, p_queue_interface_table,
                  p_q_interface_directory_entry, reply_header);
          IFEND;

        = dfc$terminated, dfc$awaiting_recovery =
          IF p_cpu_queue^.queue_header.partner_status.verify_queue THEN
            wait_for_verify_queue_message (p_cpu_queue, queue_index, p_queue_interface_table,
                  p_q_interface_directory_entry, reply_header);
          ELSE
            system_error (' STATE=TERM/ AREC, NO VERIFY_QUEUE, AND POLL TASK RUNNING');
          IFEND;

        = dfc$active, dfc$deactivated, dfc$recovering =

{         Need not do anything here.

        ELSE
          system_error ('INCORRECT SERVER_STATE in Clone Master');
        CASEND;
      IFEND;

{-----------------------------------------
{     Process or time-out Poll message.
{-----------------------------------------

      time_before_wait := #FREE_RUNNING_CLOCK (0);

      pmp$wait (wait_time, wait_time);
      determine_wakeup_cause (p_cpu_queue, queue_index, p_queue_interface_table, time_before_wait,
            reply_header);
      time_out_poll (p_cpu_queue, queue_index, p_queue_interface_table);
      check_clones_status (p_cpu_queue, queue_index, p_queue_interface_table);

    WHILEND /main_loop/;

  PROCEND dfp$determine_client_status;

?? TITLE := '    call_state_change_procedures', EJECT ??

  PROCEDURE call_state_change_procedures
    (    old_state: dft$server_state;
         new_state: dft$server_state;
         p_cpu_queue: ^dft$cpu_queue);

    VAR
      local_status: ost$status,
      wait: ost$wait;

    local_status.normal := TRUE;
    IF old_state = new_state THEN
      RETURN;
    IFEND;

    IF p_cpu_queue^.queue_header.p_remote_application_info <> NIL THEN
      IF old_state IN $dft$server_states [dfc$deactivated, dfc$active, dfc$recovering] THEN
        { The application may be processing a remote procedure call
        log_display ($pmt$ascii_logset [pmc$job_log, pmc$system_log],
              ' Calling pmp$cause_condition_in_tasks for osc$server_state_change');
        pmp$cause_condition_in_tasks (osc$server_state_change);
      IFEND;
    IFEND;

    IF new_state IN $dft$server_states [dfc$deactivated, dfc$active, dfc$recovering] THEN
      {We must allow the poller task to continue so it can detect timeouts
      wait := osc$nowait;
    ELSE
      wait := osc$wait;
    IFEND;

    dfp$execute_state_change_task (p_cpu_queue^.queue_header.destination_mainframe_name,
          { Partner_is_server } FALSE, old_state, new_state, wait, local_status);

  PROCEND call_state_change_procedures;

?? TITLE := '    check_clones_status', EJECT ??

  PROCEDURE check_clones_status
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table);

    VAR
      operator_message: string (79),
      queue_entry_index: dft$queue_entry_index,
      string_length: integer;

{   --------------------------------------------------------------------
{   This procedure checks the status of each clone task.
{   None of the clones should have completed. If any clone has completed
{   then the Client job will be terminated.
{   --------------------------------------------------------------------

    IF dfv$p_clone_tasks_status <> NIL THEN

    /check_each_clone_task/
      FOR queue_entry_index := LOWERBOUND (dfv$p_clone_tasks_status^)
            TO UPPERBOUND (dfv$p_clone_tasks_status^) DO

        IF dfv$p_clone_tasks_status^ [queue_entry_index].complete THEN
          IF NOT dfv$p_clone_tasks_status^ [queue_entry_index].status.normal THEN
            display_error_status (dfv$p_clone_tasks_status^ [queue_entry_index].status);
          IFEND;
          STRINGREP (operator_message, string_length, '  Clone number # ', queue_entry_index,
                ' completed prematurely - TIMING OUT CLIENT');
          timeout_job (p_cpu_queue, queue_index, p_queue_interface_table,
                operator_message (1, string_length), {restart } FALSE);
        IFEND;
      FOREND /check_each_clone_task/;
    IFEND;
  PROCEND check_clones_status;

?? TITLE := '    determine_wakeup_cause', EJECT ??

  PROCEDURE determine_wakeup_cause
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table;
         time_before_wait: integer;
     VAR reply_header: dft$poll_header);

    VAR
      client_found: boolean,
      operator_message: string (79),
      p_driver_flags: ^dft$queue_entry_flags,
      remaining_wait_time: integer,
      status: ost$status,
      time_after_wait: integer,
      wait_time: integer;

    p_driver_flags := ^p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue^.queue_entries [dfc$poll_queue_index].flags;
    wait_time := p_cpu_queue^.queue_header.timeout_interval DIV 1000;

{---------------------------------------------------
{   Check if Poll arrived and process it immediately
{---------------------------------------------------

    REPEAT
      #SPOIL (p_cpu_queue^.queue_header.partner_status);
      #SPOIL (p_driver_flags);

      IF p_cpu_queue^.queue_header.partner_status.terminate_partner THEN
        operator_message := '  Operator terminated Client.';
        terminate_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, FALSE);
      IFEND;

      IF p_cpu_queue^.queue_header.partner_status.timeout_partner THEN
        operator_message := '  System timed out Client.';
        timeout_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, FALSE);
      IFEND;

      IF p_driver_flags^.subsystem_action THEN
        IF p_driver_flags^.driver_error_alert THEN
          dfp$set_client_mf_file_info (p_cpu_queue^.queue_header.destination_mainframe_id, dfc$terminated,
                p_cpu_queue^.queue_header.server_lifetime, p_cpu_queue^.queue_header.server_birthdate,
                client_found);
          p_cpu_queue^.queue_header.partner_status.server_state := dfc$terminated;
          system_error ('PP ERROR: DRIVER ERROR FLAG SET IN DETERMINE_WAKEUP_CAUSE');
        ELSE
          status.normal := TRUE;
          process_poll (p_cpu_queue, queue_index, p_queue_interface_table, reply_header, status);
          IF NOT status.normal THEN
            display_error_status (status);
            operator_message := ' TIMEOUT CLIENT.';
            timeout_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, FALSE);
          IFEND;

        IFEND;
      IFEND;

{     ------------------------------------
{     Wait the balance of the wait period.
{     ------------------------------------

      time_after_wait := #FREE_RUNNING_CLOCK (0);
      remaining_wait_time := wait_time - ((time_after_wait - time_before_wait) DIV 1000);
      IF (remaining_wait_time > 0) THEN
        pmp$wait (remaining_wait_time, remaining_wait_time);
      IFEND;

    UNTIL NOT (remaining_wait_time > 0);

  PROCEND determine_wakeup_cause;

?? TITLE := '      display_error_status', EJECT ??

  PROCEDURE display_error_status
    (    status: ost$status);

    VAR
      destination_log: pmt$ascii_logset,
      ignore_status: ost$status,
      line_count: ost$status_message_line_count,
      message: ost$status_message,
      p_line_count: ^ost$status_message_line_count,
      p_line_size: ^ost$status_message_line_size,
      p_message: ^ost$status_message,
      p_message_line: ^string ( * ),
      window: dpt$window_id;

    window := dpv$system_core_display;
    destination_log := $pmt$ascii_logset [pmc$system_log, pmc$job_log];
    p_message := ^message;
    osp$format_message (status, osc$full_message_level, ofc$max_display_message, p_message^, ignore_status);
    RESET p_message;
    NEXT p_line_count IN p_message;
    IF p_line_count^ > 0 THEN

    /display_each_line/
      FOR line_count := 1 TO (p_line_count^) DO
        NEXT p_line_size IN p_message;
        NEXT p_message_line: [p_line_size^] IN p_message;
        dpp$put_next_line (window, p_message_line^ (1, p_line_size^), ignore_status);
        pmp$log_ascii (p_message_line^ (1, p_line_size^), destination_log, pmc$msg_origin_system,
              ignore_status);
      FOREND /display_each_line/;
    IFEND;
  PROCEND display_error_status;

?? TITLE := '    format_family_list', EJECT ??

  PROCEDURE format_family_list
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table;
     VAR number_of_families: 0 .. dfc$max_family_parameters;
     VAR {input/output} p_receive_buffer: dft$p_command_buffer;
     VAR p_families: ^SEQ (REP dfc$max_family_parameters of dft$family_verification);
     VAR {input/output} p_family_list: ^dft$poll_family_list);

    VAR
      ignore_status: ost$status,
      operator_message: string (79),
      p_number_of_families: ^0 .. dfc$max_family_parameters,
      p_received_families: ^dft$poll_family_list;

    NEXT p_number_of_families IN p_receive_buffer;
    number_of_families := p_number_of_families^;
    IF (number_of_families = 0) THEN
      p_family_list := NIL;
    ELSE
      NEXT p_received_families: [1 .. number_of_families] IN p_receive_buffer;
      RESET p_families;
      NEXT p_family_list: [1 .. number_of_families] IN p_families;
      p_family_list^ := p_received_families^;
    IFEND;
    process_family_verification (p_cpu_queue^.queue_header.destination_mainframe_id, number_of_families,
          p_families^);
    IF number_of_families > 0 THEN
      RESET p_families;
      NEXT p_family_list: [1 .. number_of_families] IN p_families;
    IFEND;


  PROCEND format_family_list;

?? TITLE := '    get_client_mainframe_file', EJECT ??

  PROCEDURE get_client_mainframe_file
    (    client_mainframe: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      client_mainframe_file: ost$name,
      cycle_selector: pft$cycle_selector,
      error: string (60),
      p_mainframe_file_path: ^pft$path,
      string_length: integer;

    status.normal := TRUE;

    dfp$build_client_mf_file_name (client_mainframe, client_mainframe_file);
    PUSH p_mainframe_file_path: [1 .. 4];
    p_mainframe_file_path^ [1] := ' ';
    p_mainframe_file_path^ [2] := ' ';
    p_mainframe_file_path^ [3] := dfc$client_mainframe_catalog;
    p_mainframe_file_path^ [4] := client_mainframe_file;
    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := 1;

    pfp$attach (client_mainframe_file, p_mainframe_file_path^, cycle_selector, osc$null_name,
          $pft$usage_selections [pfc$read, pfc$shorten, pfc$append, pfc$modify],
          $pft$share_selections [pfc$read, pfc$shorten, pfc$append, pfc$modify], pfc$no_wait, status);
    IF NOT status.normal THEN
      STRINGREP (error, string_length, client, '- error status from ATTACH ', client_mainframe_file);
      display (error (1, string_length));
    IFEND;

  PROCEND get_client_mainframe_file;

?? TITLE := '    issue_poll_reply', EJECT ??

  PROCEDURE issue_poll_reply
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table;
         reply_header: dft$poll_header;
         p_family_list: ^dft$poll_family_list;
         p_queue_information: ^dft$poll_queue_information);

    VAR
      actual_length: integer,
      ignore_status:  ost$status,
      operator_message: string (79),
      p_driver_entry: ^dft$driver_queue_entry,
      p_number_of_families: ^0 .. dfc$max_family_parameters,
      p_poll_family_list: ^dft$poll_family_list,
      p_poll_queue_information: ^dft$poll_queue_information,
      p_send_buffer: dft$p_command_buffer,
      p_send_parameters: ^dft$poll_message;

    p_send_buffer := p_cpu_queue^.queue_entries [dfc$poll_queue_index].p_send_buffer;
    p_driver_entry := ^p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue^.queue_entries [dfc$poll_queue_index];

{-----------------------------------
{   Format Poll_Reply buffer header.
{-----------------------------------

    RESET p_send_buffer;
    NEXT p_send_parameters IN p_send_buffer;
    p_send_parameters^.buffer_header.version := dfc$poll_task_version;
    p_send_parameters^.buffer_header.transaction_count :=
          p_cpu_queue^.queue_entries [dfc$poll_queue_index].transaction_count;
    p_send_parameters^.buffer_header.retransmission_count := p_cpu_queue^.
          queue_entries [dfc$poll_queue_index].retransmission_count;
    p_send_parameters^.buffer_header.remote_processor := dfc$poll_task;
    p_send_parameters^.buffer_header.data_length_sent := 0;
    p_send_parameters^.poll_header := reply_header;

{---------------------------------
{   Format Poll_Reply message.
{---------------------------------

    CASE reply_header.poll_type OF
    = dfc$poll_reply, dfc$deactivate_reply, dfc$deactivate_server, dfc$recovery_complete_reply,
          dfc$req_verify_served_family =

{     These poll reply types only require poll_header.

    = dfc$verify_family_reply, dfc$verify_queue_reply =
      NEXT p_number_of_families IN p_send_buffer;
      IF (p_family_list = NIL) THEN
        p_number_of_families^ := 0;
      ELSE
        p_number_of_families^ := UPPERBOUND (p_family_list^.families);
        NEXT p_poll_family_list: [1 .. UPPERBOUND (p_family_list^.families)] IN p_send_buffer;
        p_poll_family_list^ := p_family_list^;
      IFEND;

      IF (reply_header.poll_type = dfc$verify_queue_reply) THEN
        IF (p_queue_information = NIL) THEN
          system_error (' NO QUEUE INFO LIST FOR POLL_REPLY IN ISSUE_POLL_REPLY');

        ELSE
          NEXT p_poll_queue_information IN p_send_buffer;
          p_poll_queue_information^ := p_queue_information^;
        IFEND;
      IFEND;

    ELSE
      system_error ('INCORRECT POLL REPLY IN ISSUE_POLL_REPLY.');
    CASEND;

    actual_length := dfp$word_boundary (i#current_sequence_position (p_send_buffer));
    p_send_parameters^.buffer_header.buffer_length_sent := actual_length;
    p_driver_entry^.flags := dfv$send_command_flags;
    p_driver_entry^.send_buffer_descriptor.actual_length := actual_length;
    IF reply_header.poll_type = dfc$verify_queue_reply THEN
      pmp$get_compact_date_time (p_poll_queue_information^.server_date_time, ignore_status);
    IFEND;
    IF dfv$display_poll THEN
      send_message_to_operator (dfv$poll_type_string [reply_header.poll_type],
      ' Issue Poll Reply');
    IFEND;
    dfp$queue_task_request (p_queue_interface_table, queue_index, dfc$poll_queue_index);

  PROCEND issue_poll_reply;

?? TITLE := '    process_family_verification', EJECT ??

  PROCEDURE process_family_verification
    (    client_binary_id: pmt$binary_mainframe_id;
     VAR number_of_families: 0 .. dfc$max_family_parameters;
     VAR family_container: SEQ (REP dfc$max_family_parameters of dft$family_verification));

    VAR
      access_list: array [1 .. dfc$max_family_ptr_array_size] of dft$family_access,
      family_index: 1 .. dfc$max_family_parameters,
      family_list: array [1 .. dfc$max_family_ptr_array_size] of ost$family_name,
      client_family_count: 0 .. dfc$max_family_ptr_array_size,
      out_index: 0 .. dfc$max_family_ptr_array_size,
      p_family_container: ^SEQ (REP dfc$max_family_parameters of dft$family_verification),
      p_family_verification: ^dft$family_verification;

    p_family_container := ^family_container;
    RESET p_family_container;

    osp$get_families_for_client (client_binary_id, ^family_list, ^access_list, client_family_count);

  /search_list/
    FOR out_index := 1 TO client_family_count DO

      IF access_list [out_index] = $dft$family_access [] THEN
        CYCLE /search_list/;
      IFEND;

      RESET p_family_container;

    /search_container/
      FOR family_index := 1 TO number_of_families DO
        NEXT p_family_verification IN p_family_container;
        IF p_family_verification^.family = family_list [out_index] THEN
          p_family_verification^.family_access := access_list [out_index];
          p_family_verification^.valid := TRUE;
          CYCLE /search_list/;
        IFEND;
      FOREND /search_container/;

{Family not found in family container - that is, not specified by client.
{  Add entry from family list on this (server) mainframe.

      NEXT p_family_verification IN p_family_container;
      p_family_verification^.family := family_list [out_index];
      p_family_verification^.family_access := access_list [out_index];
      p_family_verification^.valid := TRUE;
      number_of_families := number_of_families + 1;
    FOREND /search_list/;

  PROCEND process_family_verification;

?? TITLE := '    process_poll', EJECT ??

  PROCEDURE process_poll
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table;
     VAR reply_header: dft$poll_header;
     VAR status: ost$status);

    VAR
      client_found: boolean,
      families: SEQ (REP dfc$max_family_parameters of dft$family_verification),
      ignore_status: ost$status,
      mainframe_name: pmt$mainframe_id,
      new_poll: boolean,
      number_of_families: 0 .. dfc$max_family_parameters,
      operator_message: string (79),
      operator_message_length: integer,
      p_buffer_parameters: ^dft$poll_message,
      p_families: ^SEQ (REP dfc$max_family_parameters of dft$family_verification),
      p_family_list: ^dft$poll_family_list,
      p_number_of_families: ^0 .. dfc$max_family_parameters,
      p_poll_header: ^dft$poll_header,
      p_queue_information: ^dft$poll_queue_information,
      p_queue_information_received: ^dft$poll_queue_information,
      p_receive_buffer: dft$p_command_buffer,
      queue_directory_index: dft$queue_directory_index,
      queue_information_received: dft$poll_queue_information,
      reactivating_partner: boolean,
      restart: boolean;

    mainframe_name := p_cpu_queue^.queue_header.destination_mainframe_name;
    restart := FALSE;
    reactivating_partner := FALSE;
    p_receive_buffer := p_cpu_queue^.queue_entries [dfc$poll_queue_index].p_receive_buffer;
    RESET p_receive_buffer;
    NEXT p_buffer_parameters IN p_receive_buffer;
    p_queue_information_received := NIL;
    p_family_list := NIL;

    validate_received_poll (p_cpu_queue, queue_index, p_queue_interface_table, new_poll);
    status.normal := TRUE;
    IF NOT new_poll THEN
      RETURN;
    IFEND;

{------------------------------------
{   Match Poll Type with Server State
{------------------------------------

    p_poll_header := ^p_buffer_parameters^.poll_header;
    CASE p_cpu_queue^.queue_header.partner_status.server_state OF
    = dfc$active, dfc$recovering =
      CASE p_poll_header^.poll_type OF
      = dfc$normal_poll =
        IF (p_cpu_queue^.queue_header.partner_status.server_state = dfc$active) AND
              p_cpu_queue^.queue_header.partner_status.send_deactivate_partner THEN
          reply_header.poll_type := dfc$deactivate_server;
          p_cpu_queue^.queue_header.partner_status.send_deactivate_partner := FALSE;
        ELSEIF p_cpu_queue^.queue_header.partner_status.verify_family THEN
          reply_header.poll_type := dfc$req_verify_served_family;
          p_cpu_queue^.queue_header.partner_status.verify_family := FALSE;
        ELSE
          reply_header.poll_type := dfc$poll_reply;
        IFEND;
      = dfc$recovery_complete =
        p_cpu_queue^.queue_header.partner_status.send_deactivate_partner :=  FALSE;
        p_cpu_queue^.queue_header.partner_status.server_state := dfc$active;
        dfp$set_client_mf_file_info (p_cpu_queue^.queue_header.destination_mainframe_id, dfc$active,
              p_cpu_queue^.queue_header.server_lifetime, p_cpu_queue^.queue_header.server_birthdate,
              client_found);
        reply_header.poll_type := dfc$recovery_complete_reply;
        operator_message := '  Recovery complete';
        send_message_to_operator (operator_message, mainframe_name);
        call_state_change_procedures (dfc$recovering, dfc$active, p_cpu_queue);

      = dfc$deactivate_server =
        p_cpu_queue^.queue_header.partner_status.server_state := dfc$deactivated;
        dfp$set_client_mf_file_info (p_cpu_queue^.queue_header.destination_mainframe_id, dfc$deactivated,
              p_cpu_queue^.queue_header.server_lifetime, p_cpu_queue^.queue_header.server_birthdate,
              client_found);
        p_cpu_queue^.queue_header.partner_status.send_deactivate_partner := FALSE;
        reply_header.poll_type := dfc$deactivate_reply;
        operator_message := '  Deactivating.';
        send_message_to_operator (operator_message, mainframe_name);
        call_state_change_procedures (dfc$active, dfc$deactivated, p_cpu_queue);

      = dfc$verify_served_family =
        IF p_cpu_queue^.queue_header.partner_status.send_deactivate_partner THEN
          reply_header.poll_type := dfc$deactivate_server;
          p_cpu_queue^.queue_header.partner_status.server_state := dfc$deactivated;
          dfp$set_client_mf_file_info (p_cpu_queue^.queue_header.destination_mainframe_id, dfc$deactivated,
                p_cpu_queue^.queue_header.server_lifetime, p_cpu_queue^.queue_header.server_birthdate,
                client_found);
          call_state_change_procedures (dfc$active, dfc$deactivated, p_cpu_queue);
          p_cpu_queue^.queue_header.partner_status.send_deactivate_partner := FALSE;
        ELSE
          p_families := ^families;
          format_family_list (p_cpu_queue, queue_index, p_queue_interface_table, number_of_families,
                p_receive_buffer, p_families, p_family_list);
          reply_header.poll_type := dfc$verify_family_reply;
        IFEND;
      = dfc$verify_queue =
        { Unexpected verify queue occurred.
        operator_message := '  Beginning CLIENT Re-activation.';
        restart := TRUE;
        timeout_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, restart);

      ELSE
        operator_message := ' ';
        STRINGREP (operator_message, operator_message_length,
              ' TIMING CLIENT:incorrect POLL received - active', $integer (
               p_poll_header^.poll_type));
        timeout_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, restart);
      CASEND;

    = dfc$deactivated =
      IF p_poll_header^.poll_type = dfc$deactivate_complete THEN
        p_cpu_queue^.queue_header.partner_status.server_state := dfc$inactive;
        dfp$set_client_mf_file_info (p_cpu_queue^.queue_header.destination_mainframe_id, dfc$inactive,
              p_cpu_queue^.queue_header.server_lifetime, p_cpu_queue^.queue_header.server_birthdate,
              client_found);
        call_state_change_procedures (dfc$deactivated, dfc$inactive, p_cpu_queue);
        operator_message := '  Turned inactive.';
        send_message_to_operator (operator_message, mainframe_name);

      ELSEIF p_poll_header^.poll_type = dfc$verify_queue THEN
        { Unexpected verify queue
        operator_message := '  Beginning CLIENT Re-activation.';
        restart := TRUE;
        timeout_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, restart);

      ELSE
        operator_message := ' ';
        STRINGREP (operator_message, operator_message_length,
              ' TIMING CLIENT:incorrect POLL received - deact', $integer (
               p_poll_header^.poll_type));
        timeout_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, restart);
      IFEND;

{   ----------------------------------------------
{   Validate contents of Verify_Queue Poll Type
{   ----------------------------------------------

    = dfc$inactive, dfc$terminated, dfc$awaiting_recovery =
      IF p_poll_header^.poll_type = dfc$verify_queue THEN
        operator_message := '  Queue verification message arrived.';
        send_message_to_operator (operator_message, mainframe_name);
        p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
        p_families := ^families;
        format_family_list (p_cpu_queue, queue_index, p_queue_interface_table, number_of_families,
              p_receive_buffer, p_families, p_family_list);

        NEXT p_queue_information IN p_receive_buffer;
        queue_information_received := p_queue_information^;
        verify_queue_information (reply_header, p_cpu_queue, queue_index, p_queue_interface_table,
              queue_information_received, status);

        reply_header.poll_type := dfc$verify_queue_reply;
        p_queue_information_received := ^queue_information_received;
        queue_information_received.status := status;
        IF status.normal OR (status.condition = dfe$os_name_conflict) THEN
          status.normal := TRUE;
          p_cpu_queue^.queue_header.server_lifetime := queue_information_received.server_lifetime;
          p_cpu_queue^.queue_header.server_birthdate := queue_information_received.server_birthdate;
          p_cpu_queue^.queue_header.timeout_interval := queue_information_received.timeout_interval;
          p_cpu_queue^.queue_header.maximum_request_timeout_count :=
                queue_information_received.maximum_timeout_count;
          p_cpu_queue^.queue_header.maximum_retransmission_count :=
                queue_information_received.maximum_retransmission_count;


          CASE p_cpu_queue^.queue_header.partner_status.server_state OF
          = dfc$terminated, dfc$awaiting_recovery =
            IF (p_cpu_queue^.queue_header.partner_status.server_state = dfc$awaiting_recovery) THEN
              p_cpu_queue^.queue_header.partner_status.server_state := dfc$recovering;
              dfp$set_client_mf_file_info (p_cpu_queue^.queue_header.destination_mainframe_id, dfc$recovering,
                    p_cpu_queue^.queue_header.server_lifetime, p_cpu_queue^.queue_header.server_birthdate,
                    client_found);
              call_state_change_procedures (dfc$awaiting_recovery, dfc$recovering, p_cpu_queue);

            ELSE
              p_cpu_queue^.queue_header.partner_status.server_state := dfc$active;
              dfp$set_client_mf_file_info (p_cpu_queue^.queue_header.destination_mainframe_id, dfc$active,
                    p_cpu_queue^.queue_header.server_lifetime, p_cpu_queue^.queue_header.server_birthdate,
                    client_found);
              call_state_change_procedures (dfc$terminated, dfc$active, p_cpu_queue);
            IFEND;
            p_cpu_queue^.queue_header.partner_status.send_deactivate_partner := FALSE;
            dfp$establish_clone_task_stable (mainframe_name, p_cpu_queue^.queue_header.
                  number_of_monitor_queue_entries, p_cpu_queue^.queue_header.number_of_task_queue_entries,
                  status);
            IF NOT status.normal THEN
              display_error_status (status);
              operator_message := '  Clone Master cannot establish clone tasks - timing out client.';
              { Allow conditions to be cleaned up.
              timeout_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, restart);
            IFEND;

          ELSE { Inactive
            p_cpu_queue^.queue_header.partner_status.server_state := dfc$active;
            p_cpu_queue^.queue_header.partner_status.send_deactivate_partner := FALSE;
            dfp$set_client_mf_file_info (p_cpu_queue^.queue_header.destination_mainframe_id, dfc$active,
                  p_cpu_queue^.queue_header.server_lifetime, p_cpu_queue^.queue_header.server_birthdate,
                  client_found);
            call_state_change_procedures (dfc$inactive, dfc$active, p_cpu_queue);
          CASEND;

        ELSEIF status.condition = dfe$force_client_recovery THEN
          { The client is inactive but the server is awaiting recovery.
          { Force the client to awaiting_recovery and re-activate.
          send_message_to_operator ('Forcing recovery of client ', mainframe_name);
          p_cpu_queue^.queue_header.partner_status.verify_queue := TRUE;
          reactivating_partner := TRUE;
          status.normal := TRUE;
        ELSEIF status.condition = dfe$force_client_termination THEN
          { The client is inactive or awaiting recovery, but the server is terminated.
          { Force the client to terminate and re-activate.
          send_message_to_operator ('Forcing termination of client ', mainframe_name);
          p_cpu_queue^.queue_header.partner_status.verify_queue := TRUE;
          reactivating_partner := TRUE;
          status.normal := TRUE;
        ELSEIF status.condition = dfe$force_server_recovery THEN
          { The client is awaiting_recovery, but the server is inactive.
          { Force the server to awaiting_recovery and re-activate.
          timeout_job (p_cpu_queue, queue_index, p_queue_interface_table,
                ' Forcing recovery of server ', TRUE);
        ELSEIF status.condition = dfe$force_server_termination THEN
          { The client is terminated, but the server is awaiting_recovery or inactive.
          { Force the server to terminate and re-activate.
          terminate_job (p_cpu_queue, queue_index, p_queue_interface_table,
              ' Forcing termination of server ', TRUE);
        ELSEIF status.condition = dfe$client_lifetime_error THEN
          { This is the most difficult case. Both mainframes have to be
          { terminated and restarted.
          { First terminate the server and on the
          { next re-activation the client will be forced to terminate and
          { re-activate.
          terminate_job (p_cpu_queue, queue_index, p_queue_interface_table,
              ' force termination of server - client next ', TRUE);
        ELSEIF status.condition = dfe$client_verification_error THEN
          p_cpu_queue^.queue_header.partner_status.verify_queue := TRUE;
        ELSE { Any other unexpected status?
        IFEND;

      ELSE
        operator_message := ' ';
        STRINGREP (operator_message, operator_message_length,
              ' TIMING CLIENT:incorrect POLL received - AwaitRec', $integer (
               p_poll_header^.poll_type));
        timeout_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, restart);
      IFEND;

    ELSE
      system_error (' SERVER STATE INVALID IN PROCESS_POLL');
    CASEND;

    IF (p_poll_header^.poll_type = dfc$deactivate_complete) THEN

{     ------------------------------------------------------------
{     If the deactivation process is complete - do not reply to
{     the poll, just go INACTIVE after setting transaction_state to
{     follow standard file server protocol.
{     ------------------------------------------------------------

      p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue^.
            queue_entries [dfc$poll_queue_index].flags.subsystem_action := FALSE;
      p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].p_cpu_queue^.
            queue_entries [dfc$poll_queue_index].transaction_state := dfc$server_waiting_request;
      dfp$get_queue_directory_index (p_queue_interface_table, queue_directory_index);
      dfp$unload_pp_if_last (^dfv$p_queue_interface_directory^ [queue_directory_index], queue_index, status);
    ELSE
      issue_poll_reply (p_cpu_queue, queue_index, p_queue_interface_table, reply_header, p_family_list,
            p_queue_information_received);
      IF reactivating_partner THEN
        { Reset transaction count and retransmission count so the reactivation
        { request will occur.
         p_cpu_queue^.queue_entries [dfc$poll_queue_index].transaction_count := 0;
         p_cpu_queue^.queue_entries [dfc$poll_queue_index].retransmission_count := 0;
      IFEND;
    IFEND;

  PROCEND process_poll;

?? TITLE := '      restart_client_job ', EJECT ??
{ This procedure re-submits the client mainframe job.
{ No one gets out of here alive.

  PROCEDURE restart_client_job
    (    p_cpu_queue: ^dft$cpu_queue);

    VAR
      status: ost$status;

    dfp$reset_mainframe_tables (p_cpu_queue^.queue_header.destination_mainframe_name,
          {server_to_client=} TRUE, status);
    IF status.normal THEN
      p_cpu_queue^.queue_header.partner_status.verify_queue := TRUE;
      dfp$submit_client_mainframe_job (p_cpu_queue^.queue_header.destination_mainframe_name, status);
    IFEND;

    IF status.normal THEN
      send_message_to_operator (' Client Re-activation Started.',
            p_cpu_queue^.queue_header.destination_mainframe_name);
    ELSE
      p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
      display_error_status (status);
      send_message_to_operator (' Client  Re-activation Aborted.',
            p_cpu_queue^.queue_header.destination_mainframe_name);
      status.normal := TRUE;
    IFEND;

    dfv$normal_client_termination := TRUE;
    pmp$exit (status);

  PROCEND restart_client_job;
?? TITLE := '      send_message_to_operator ', EJECT ??
  PROCEDURE send_message_to_operator
    (    message: string ( * <= 125);
         mainframe_name: pmt$mainframe_id);

    dfp$send_message_to_operator (message, { Server_to_client } TRUE, mainframe_name);
  PROCEND send_message_to_operator;

?? TITLE := '      set_verification_error ', EJECT ??

  PROCEDURE set_verification_error
    (    parameter_message: string ( * <= 79);
         mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    osp$set_status_abnormal (dfc$file_server_id, dfe$client_verification_error, mainframe_name, status);
    osp$append_status_parameter (osc$status_parameter_delimiter, parameter_message, status);
    display_error_status (status);

  PROCEND set_verification_error;

?? TITLE := '    system_error  ', EJECT ??

  PROCEDURE system_error
    (    text: string ( * ));

    VAR
      user_supplied_name: jmt$user_supplied_name,
      system_supplied_name: jmt$system_supplied_name,
      local_status: ost$status;

    pmp$get_job_names (user_supplied_name, system_supplied_name, local_status);

    dpp$put_next_line (dpv$system_core_display, ' Client mainframe job - File server system error:',
          local_status);
    dpp$put_next_line (dpv$system_core_display, user_supplied_name, local_status);
    dpp$put_next_line (dpv$system_core_display, text, local_status);

    pmp$log_ascii (text, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
          local_status);
    pmp$log_ascii (user_supplied_name, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
          local_status);

    IF dfv$file_server_debug_enabled THEN
      syp$invoke_system_debugger (text, 0, local_status);
    IFEND;
    local_status.normal := TRUE;
    dfv$normal_client_termination := TRUE;
    pmp$exit (local_status);
  PROCEND system_error;
?? TITLE := '    terminate_job', EJECT ??
{
{   This procedure terminates the Client job. Depending on the value of the
{   RESTART parameter another Client job may be submitted here.
{
{   If any call out of this procedure returns an abnormal status, that status
{   is merely reported and the processing continues until the job termination
{   is completed.
{
{   The exception to the status handling occurs when another Client job is
{   to be submitted and a termination process of the current Client job produces
{   a bad status. In this case the new Client job is NOT started.
{
{   There is no return from this procedure.
{

  PROCEDURE terminate_job
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table;
         operator_message: string ( * <= 79);
         restart: boolean);

    VAR
      client_found: boolean,
      local_status: ost$status,
      p_driver_flags: ^dft$queue_entry_flags,
      old_state: dft$server_state,
      queue_directory_index: dft$queue_directory_index,
      status: ost$status,
      submit: boolean;

    local_status.normal := TRUE;
    status.normal := TRUE;
    submit := restart;

    send_message_to_operator (operator_message, p_cpu_queue^.queue_header.destination_mainframe_name);
    p_driver_flags := ^p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue^.queue_entries [dfc$poll_queue_index].flags;

    p_driver_flags^.subsystem_action := FALSE;
    old_state :=  p_cpu_queue^.queue_header.partner_status.server_state;
    p_cpu_queue^.queue_header.partner_status.server_state := dfc$terminated;
    p_cpu_queue^.queue_header.partner_status.terminate_partner := FALSE;
    p_cpu_queue^.queue_header.partner_status.timeout_partner := FALSE;
    p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
    p_cpu_queue^.queue_header.partner_status.deactivate_complete := FALSE;
    dfp$set_client_mf_file_info (p_cpu_queue^.queue_header.destination_mainframe_id, dfc$terminated,
          p_cpu_queue^.queue_header.server_lifetime, p_cpu_queue^.queue_header.server_birthdate,
          client_found);

    dfp$term_processing_on_server (p_cpu_queue^.queue_header.destination_mainframe_name, status);
    IF NOT status.normal THEN
      send_message_to_operator (' Client Termination Error - term processing.',
            p_cpu_queue^.queue_header.destination_mainframe_name);
      display_error_status (status);
      submit := FALSE;
    IFEND;

    dfp$remove_client_jobs (p_cpu_queue^.queue_header.destination_mainframe_name, status);
    IF NOT status.normal THEN
      send_message_to_operator (' Client Termination Error - remove client jobs   .',
            p_cpu_queue^.queue_header.destination_mainframe_name);
      display_error_status (status);
      submit := FALSE;
    IFEND;

    qfp$discard_client_jobs (p_cpu_queue^.queue_header.destination_mainframe_id);
    IF dfc$tjr_halt_terc IN syv$test_jr_job THEN
      { LRZ TEST CASE
      dfv$normal_client_termination := TRUE;
      p_driver_flags := NIL;
      p_driver_flags^.subsystem_action := FALSE;
    IFEND;

    dfp$get_queue_directory_index (p_queue_interface_table, queue_directory_index);
    dfp$unload_pp_if_last (^dfv$p_queue_interface_directory^ [queue_directory_index], queue_index, status);
    IF NOT status.normal THEN
      send_message_to_operator (' Client Termination Error - unload pp.',
            p_cpu_queue^.queue_header.destination_mainframe_name);
      submit := FALSE;
      display_error_status (status);
    IFEND;

    call_state_change_procedures (old_state, dfc$terminated, p_cpu_queue);

    IF submit THEN
      restart_client_job (p_cpu_queue);
    ELSE
      IF restart THEN
        send_message_to_operator (' Client Terminated, Re-activation Aborted.',
              p_cpu_queue^.queue_header.destination_mainframe_name);
      IFEND;
      send_message_to_operator (' Client Termination Complete.',
            p_cpu_queue^.queue_header.destination_mainframe_name);
      local_status.normal := TRUE;
      dfv$normal_client_termination := TRUE;
      pmp$exit (local_status);
    IFEND;

  PROCEND terminate_job;
?? TITLE := '    timeout_job', EJECT ??

{------------------------------------------------------------------------------------
{   This procedure terminates the Client job on a timeout situation.
{
{   If any call out of this procedure returns an abnormal status, that status
{   is merely reported and the processing continues until the job termination
{   is completed.
{
{   The exception to the status handling occurs when another Client job is
{   to be submitted and a termination process of the current Client job produces
{   a bad status. In this case the new Client job is NOT started.
{------------------------------------------------------------------------------------

  PROCEDURE timeout_job
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table;
         operator_message: string ( * <= 79);
         restart: boolean);

    VAR
      client_found: boolean,
      local_status: ost$status,
      old_state: dft$server_state,
      p_driver_flags: ^dft$queue_entry_flags,
      queue_directory_index: dft$queue_directory_index,
      status: ost$status,
      submit_new_job: boolean;


    local_status.normal := TRUE;
    status.normal := TRUE;
    submit_new_job := restart;
    IF (NOT dfv$job_recovery_enabled) OR
          (p_cpu_queue^.queue_header.partner_status.server_state = dfc$terminated) THEN
      terminate_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, restart);
      RETURN;
    IFEND;

    send_message_to_operator (operator_message, p_cpu_queue^.queue_header.destination_mainframe_name);
    p_driver_flags := ^p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue^.queue_entries [dfc$poll_queue_index].flags;

    old_state := p_cpu_queue^.queue_header.partner_status.server_state;
    p_driver_flags^.subsystem_action := FALSE;
    p_cpu_queue^.queue_header.partner_status.server_state := dfc$awaiting_recovery;
    p_cpu_queue^.queue_header.partner_status.timeout_partner := FALSE;
    p_cpu_queue^.queue_header.partner_status.terminate_partner := FALSE;
    p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
    p_cpu_queue^.queue_header.partner_status.deactivate_complete := FALSE;
    dfp$set_client_mf_file_info (p_cpu_queue^.queue_header.destination_mainframe_id, dfc$awaiting_recovery,
          p_cpu_queue^.queue_header.server_lifetime, p_cpu_queue^.queue_header.server_birthdate,
          client_found);
    status.normal := TRUE;

    dfp$term_processing_on_server (p_cpu_queue^.queue_header.destination_mainframe_name, status);
    IF NOT status.normal THEN
      display_error_status (status);
      submit_new_job := FALSE;
    IFEND;
    dfp$get_queue_directory_index (p_queue_interface_table, queue_directory_index);
    dfp$unload_pp_if_last (^dfv$p_queue_interface_directory^ [queue_directory_index], queue_index, status);
    IF NOT status.normal THEN
      submit_new_job := FALSE;
      display_error_status (status);
    IFEND;

    call_state_change_procedures (old_state, dfc$awaiting_recovery, p_cpu_queue);

    IF submit_new_job THEN
      restart_client_job (p_cpu_queue);
    ELSE
      send_message_to_operator (' Client Timeout Complete.',
            p_cpu_queue^.queue_header.destination_mainframe_name);
      local_status.normal := TRUE;
      dfv$normal_client_termination := TRUE;
      pmp$exit (local_status);
    IFEND;

  PROCEND timeout_job;

?? TITLE := '    time_out_poll', EJECT ??

  PROCEDURE time_out_poll
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table);

    VAR
      current_time: integer,
      elapsed_time: integer,
      operator_message: string (79),
      request_time: integer,
      restart: boolean,
      status: ost$status;

    IF NOT ((p_cpu_queue^.queue_header.partner_status.server_state = dfc$active) OR
          (p_cpu_queue^.queue_header.partner_status.server_state = dfc$deactivated) OR
          (p_cpu_queue^.queue_header.partner_status.server_state = dfc$recovering)) THEN
      RETURN;
    IFEND;

{   --------------------------------------------------------------------------
{   This procedure times out the Client mainframe by comparing the time
{   of the poll_reply request to the current time. If the time difference
{   is greater than the specified timeout value then the fresh poll message
{   has still not arrived from the Client mainframe. This means that either
{   the poll_reply has not reached the Client or the Client is unable to issue
{   a new poll. As a result the Client mainframe is going to be Terminated.
{
{   The specified timeout value is computed from the values obtained from the
{   Client during the queue verification processing.
{   --------------------------------------------------------------------------

    current_time := #FREE_RUNNING_CLOCK (0);
    request_time := p_cpu_queue^.queue_entries [dfc$poll_queue_index].request_start_time;
    elapsed_time := current_time - request_time;

    IF (elapsed_time >= (p_cpu_queue^.queue_header.timeout_interval *
          p_cpu_queue^.queue_header.maximum_request_timeout_count *
          p_cpu_queue^.queue_header.maximum_retransmission_count)) THEN
      restart := FALSE;
      IF dfv$job_recovery_enabled THEN
        operator_message := '  Client Poll Message TIMED OUT - TIMING OUT CLIENT.';
        timeout_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, restart);
      ELSE
        operator_message := '  Client Poll Message TIMED OUT - TERMINATING CLIENT.';
        terminate_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, restart);
      IFEND;
    IFEND;

  PROCEND time_out_poll;

?? TITLE := '    validate_received_poll', EJECT ??

  PROCEDURE validate_received_poll
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table;
     VAR new_poll: boolean);

    VAR
      action_for_server: dft$action_for_server,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      mainframe_name: pmt$mainframe_id,
      operator_message: string (79),
      p_buffer_parameters: ^dft$poll_message,
      p_receive_buffer: dft$p_command_buffer,
      restart: boolean;


{---------------------------------------------------------------------------
{   This procedure will verify the content of the received Poll header.
{   If incorrect, it will terminate the Client job.
{   It will also check the transaction and the retransmission counts. Again,
{   an error will result in the Client job termination.
{---------------------------------------------------------------------------

    dfp$fetch_queue_entry (p_queue_interface_table, queue_index, dfc$poll_queue_index, p_driver_queue_entry,
          p_cpu_queue_entry);

    restart := FALSE;
    mainframe_name := p_cpu_queue^.queue_header.destination_mainframe_name;
    p_receive_buffer := p_cpu_queue_entry^.p_receive_buffer;
    RESET p_receive_buffer;
    NEXT p_buffer_parameters IN p_receive_buffer;
    new_poll := TRUE;

{-------------------------
{   Validate Poll Header.
{-------------------------

    IF NOT ((p_buffer_parameters^.buffer_header.version = dfc$poll_task_version) AND
          (p_buffer_parameters^.buffer_header.remote_processor = dfc$poll_task) AND
          (p_buffer_parameters^.buffer_header.data_length_sent = 0)) THEN
      operator_message := '  TIMEOUT CLIENT because incorrect BUFFER HEADER was received.';
      timeout_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, restart);
    IFEND;

    IF NOT (p_buffer_parameters^.poll_header.mainframe_name = mainframe_name) THEN
      operator_message := '  TERMINATING CLIENT because incorrect MAINFRAME NAME was received.';
       { It wont get any better on second attempt.
      terminate_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, restart);
    IFEND;

{----------------------------------------------------------------------------
{   Validate Transaction Count:
{     If the transaction count in the Poll message is 1 greater than the
{       transaction count in the CPU Queue then this is a new Poll message.
{     If the transaction counts in the Poll and in the CPU Queue are the same
{       but retransmission counts are not equal then the Poll_Reply will be
{       retransmitted out of here.
{     All other conditions result in Client job termination.
{----------------------------------------------------------------------------

    dfp$determine_action_for_server (p_cpu_queue_entry, p_driver_queue_entry, action_for_server);

    CASE action_for_server OF
    = dfc$new_request =
{     This is a new Poll - process it in Process_Poll.
      RETURN;

    = dfc$retransmitted_request =
{     This is a RETRANSMITTED Poll - retransmit Poll_Reply.
      p_driver_queue_entry^.flags := dfv$send_command_flags;
      dfp$queue_task_request (p_queue_interface_table, queue_index, dfc$poll_queue_index);
      new_poll := FALSE;

    = dfc$transaction_out_of_sequence =

{--------------------------------------------------------------------------
{     If poll_type = dfc$verify_queue disregard the transaction count error
{     because the Client job will have to be terminated and then restarted.
{--------------------------------------------------------------------------

      IF p_buffer_parameters^.poll_header.poll_type = dfc$verify_queue THEN
        send_message_to_operator (' Unexpected verify queue - out of seq', mainframe_name);
        { An unexpected verify queue came.  Perhaps the client mainframe
        { timed out and was re-activated.  process_poll will know what to
        { do with this unexpected poll so the transaction counts are set to
        { match.
        p_cpu_queue_entry^.transaction_count :=
            p_buffer_parameters^.buffer_header.transaction_count;
        p_cpu_queue_entry^.retransmission_count :=
            p_buffer_parameters^.buffer_header.retransmission_count;
        RETURN;
      ELSE

{ Despite this error a reactivation will cleanup everything.

        operator_message := '  TIMEOUT CLIENT because of TRANSACTION COUNT mismatch.';
        timeout_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, restart);
      IFEND;

    = dfc$complete_request =
      IF p_buffer_parameters^.poll_header.poll_type = dfc$verify_queue THEN
        send_message_to_operator (' Unexpected verify_queue -complete req', mainframe_name);
        p_cpu_queue_entry^.transaction_count :=
            p_buffer_parameters^.buffer_header.transaction_count;
        p_cpu_queue_entry^.retransmission_count :=
            p_buffer_parameters^.buffer_header.retransmission_count;
        RETURN;
      ELSE
        system_error ('COMPLETE REQUEST INVALID FOR POLL PROCESS.');
      IFEND;
    = dfc$complete_request_on_error =
      system_error ('COMPLETE REQUEST ON ERROR INVALID FOR POLL PROCESS.');

    ELSE
      system_error ('ACTION_FOR_SERVER CASE NOT RECOGNIZED.');
    CASEND;

  PROCEND validate_received_poll;

?? TITLE := '      verify_queue_information', EJECT ??

  PROCEDURE verify_queue_information
    (    reply_header: dft$poll_header;
         p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table;
         queue_information: dft$poll_queue_information;
     VAR status: ost$status);

    VAR
      destination_log: pmt$ascii_logset,
      error_message: string (125),
      ignore_boolean: boolean,
      ignore_character: char,
      ignore_status: ost$status,
      mainframe_name: pmt$mainframe_id,
      message_length: integer,
      p_driver_header: ^dft$driver_queue_header,
      window: dpt$window_id;

    status.normal := TRUE;
    mainframe_name := p_cpu_queue^.queue_header.destination_mainframe_name;
    destination_log := $pmt$ascii_logset [pmc$system_log, pmc$job_log];
    window := dpv$system_core_display;

{   -------------------------------------------------------------
{   Compare the content of the queue_information block with the
{   local tables. Set status to abnormal and exit verification
{   block when any mismatch is encountered.
{   ------------------------------------------------------------

  /verification/
    BEGIN
      IF (reply_header.mainframe_name <> queue_information.destination_mainframe_name) THEN
        STRINGREP (error_message, message_length, 'Server mainframe name mismatch, received: ',
              queue_information.destination_mainframe_name, ', expected: ', reply_header.mainframe_name);
        set_verification_error (error_message (1, message_length), mainframe_name, status);
        EXIT /verification/;
      IFEND;

{     ----------------------------
{     Match CPU_Queue information.
{     Chances are we won't actually be able to communicate if these disagree.

      IF (queue_information.number_of_monitor_queue_entries <>
            p_cpu_queue^.queue_header.number_of_monitor_queue_entries) THEN
        STRINGREP (error_message, message_length, 'Monitor queue entries mismatch, received: ',
              queue_information.number_of_monitor_queue_entries, ', expected: ',
              p_cpu_queue^.queue_header.number_of_monitor_queue_entries);
        set_verification_error (error_message (1, message_length), mainframe_name, status);
        EXIT /verification/;
      IFEND;
      IF (queue_information.number_of_task_queue_entries <>
            p_cpu_queue^.queue_header.number_of_task_queue_entries) THEN
        STRINGREP (error_message, message_length, 'Task queue entries mismatch, received: ',
              queue_information.number_of_task_queue_entries, ', expected: ',
              p_cpu_queue^.queue_header.number_of_task_queue_entries);
        set_verification_error (error_message (1, message_length), mainframe_name, status);
        EXIT /verification/;
      IFEND;

{     ----------------------------------------
{     Match Queue_Interface_Table information.
{     Chances are we won't actually be able to communicate if these disagree.
{     ----------------------------------------

      IF (queue_information.esm_base_addresses <> p_queue_interface_table^.esm_base_addresses) THEN
        error_message := 'ESM base addresses mismatch:';
        message_length := 28;
        dpp$put_next_line (window, error_message (1, message_length), ignore_status);
        pmp$log_ascii (error_message (1, message_length), destination_log, pmc$msg_origin_program,
              ignore_status);
        STRINGREP (error_message, message_length, 'Number of mainframes received =',
              queue_information.esm_base_addresses.number_of_mainframes);
        set_verification_error (error_message (1, message_length), mainframe_name, status);
        STRINGREP (error_message, message_length, 'Divisions_per_mainframe_received =',
              queue_information.esm_base_addresses.divisions_per_mainframe);
        set_verification_error (error_message (1, message_length), mainframe_name, status);
        STRINGREP (error_message, message_length, 'ESM flag base received =',
              queue_information.esm_base_addresses.esm_flag_base);
        set_verification_error (error_message (1, message_length), mainframe_name, status);
        STRINGREP (error_message, message_length, 'ESM memory base received =',
              queue_information.esm_base_addresses.esm_memory_base * dfc$esm_memory_base_shift);
        set_verification_error (error_message (1, message_length), mainframe_name, status);
        STRINGREP (error_message, message_length, 'ESM division size received =',
              queue_information.esm_base_addresses.esm_division_size * dfc$esm_memory_base_shift);
        set_verification_error (error_message (1, message_length), mainframe_name, status);
        STRINGREP (error_message, message_length, 'ESM divsiz 12bit cw received =',
              queue_information.esm_base_addresses.esm_divsiz_12bit_cw * dfc$esm_division_chwrds_shift);
        set_verification_error (error_message (1, message_length), mainframe_name, status);
        STRINGREP (error_message, message_length, 'ESM divsiz 16bit cw received =',
              queue_information.esm_base_addresses.esm_divsiz_16bit_cw * dfc$esm_division_chwrds_shift);
        set_verification_error (error_message (1, message_length), mainframe_name, status);
        EXIT /verification/;
      IFEND;

      p_driver_header := ^p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
            p_driver_queue^.queue_header;

{     -------------------------------
{     Match Driver_Queue information.
{     Chances are we won't actually be able to communicate if these disagree.
{     -------------------------------

      IF (queue_information.driver_number_of_queue_entries <> p_driver_header^.number_of_queue_entries) THEN
        STRINGREP (error_message, message_length, 'Driver queue entries mismatch, received: ',
              queue_information.driver_number_of_queue_entries, ', expected: ',
              p_driver_header^.number_of_queue_entries);
        set_verification_error (error_message (1, message_length), mainframe_name, status);
        EXIT /verification/;
      IFEND;
      IF (queue_information.driver_source_id_number <> p_driver_header^.connection_descriptor.destination.
            id_number) THEN
        STRINGREP (error_message, message_length, 'Driver destination ID mismatch, ID received: ',
              queue_information.driver_source_id_number, ', expected: ',
              p_driver_header^.connection_descriptor.destination.id_number);
        set_verification_error (error_message (1, message_length), mainframe_name, status);
        EXIT /verification/;
      IFEND;
      IF (queue_information.driver_source_queue_index <> p_driver_header^.connection_descriptor.destination.
            queue_index) THEN
        STRINGREP (error_message, message_length, 'Driver destination queue index mismatch: received: ',
              queue_information.driver_destination_queue_index, ', expected: ',
              p_driver_header^.connection_descriptor.destination.queue_index);
        set_verification_error (error_message (1, message_length), mainframe_name, status);
        EXIT /verification/;
      IFEND;
      IF (queue_information.driver_destination_id_number <>
            p_driver_header^.connection_descriptor.source.id_number) THEN
        STRINGREP (error_message, message_length, 'Driver source id mismatch, id received: ',
              queue_information.driver_destination_id_number, ', expected: ',
              p_driver_header^.connection_descriptor.source.id_number);
        set_verification_error (error_message (1, message_length), mainframe_name, status);
        EXIT /verification/;
      IFEND;
      IF (queue_information.driver_destination_queue_index <>
            p_driver_header^.connection_descriptor.source.queue_index) THEN
        STRINGREP (error_message, message_length, 'Driver source queue index mismatch: index received: ',
              queue_information.driver_destination_queue_index, ', expected: ',
              p_driver_header^.connection_descriptor.source.queue_index);
        set_verification_error (error_message (1, message_length), mainframe_name, status);
        EXIT /verification/;
      IFEND;

{     Match the system information.  These are all non-fatal errors, and the
{     verification should continue.

      IF queue_information.client_page_size < osv$page_size THEN
        STRINGREP (error_message, message_length, 'System page size incompatibility: Client page size: ',
              queue_information.client_page_size, ' < Server page size: ', osv$page_size);
        set_verification_error (error_message (1, message_length), mainframe_name, status);
        EXIT /verification/;
      IFEND;
      IF (queue_information.client_page_size <> 1000(16)) AND
            (queue_information.client_page_size <> 2000(16)) THEN
        STRINGREP (error_message, message_length, 'System page size incompatibility: Client page size: ',
              queue_information.client_page_size, ' <> 4k AND <> 8k');
        set_verification_error (error_message (1, message_length), mainframe_name, status);
        EXIT /verification/;
      IFEND;
      IF queue_information.client_os_name <> osv$os_defaults_os_name THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$os_name_conflict, mainframe_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, osv$os_defaults_os_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, queue_information.client_os_name,
              status);
        display_error_status (status);
      IFEND;

      verify_state_information (p_cpu_queue, mainframe_name, queue_information, status);
      IF NOT status.normal THEN
        display_error_status (status);
      IFEND;

    END /verification/;

  PROCEND verify_queue_information;
?? TITLE := ' verify_state_information ', EJECT ??
  PROCEDURE verify_state_information
    (    p_cpu_queue: ^dft$cpu_queue;
         mainframe_name: pmt$mainframe_id;
         queue_information: dft$poll_queue_information;
     VAR status: ost$status);

    VAR
      client_state: dft$server_state,
      error_message: string (125),
      message_length: integer,
      server_state: dft$server_state;

    client_state := queue_information.server_state;
    server_state := p_cpu_queue^.queue_header.partner_status.server_state;
    status.normal := TRUE;

    IF (client_state = dfc$terminated) OR (server_state = dfc$terminated) THEN
      IF (client_state = dfc$terminated) AND (server_state <> dfc$terminated) THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$force_server_termination, mainframe_name, status);
        RETURN;
      IFEND;

      IF (client_state <> dfc$terminated) AND (server_state = dfc$terminated) THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$force_client_termination, mainframe_name, status);
        RETURN;
      IFEND;

      { Both client and server are terminated all is ok.
      RETURN;
    IFEND;

    IF (queue_information.previous_server_lifetime <> p_cpu_queue^.queue_header.server_lifetime) OR
          (queue_information.previous_server_birthdate <> p_cpu_queue^.queue_header.server_birthdate) THEN
      STRINGREP (error_message, message_length, ' Lifetime/Birthdate  mismatch- Received: ',
            queue_information.previous_server_lifetime, '/', queue_information.previous_server_birthdate,
            ', expected: ', p_cpu_queue^.queue_header.server_lifetime, '/',
            p_cpu_queue^.queue_header.server_birthdate);
      osp$set_status_abnormal (dfc$file_server_id, dfe$client_lifetime_error, mainframe_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, error_message (1, message_length), status);
      RETURN;
    IFEND;

{  If one of the mainframes is inactivate and the other awaiting_recovery, we
{ need to force the inactive mainframe to go through recovery.
    IF (client_state = dfc$inactive) AND (server_state = dfc$awaiting_recovery) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$force_client_recovery, mainframe_name, status);
      RETURN;
    IFEND;

    IF (client_state = dfc$awaiting_recovery) AND (server_state = dfc$inactive) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$force_server_recovery, mainframe_name, status);
      RETURN;
    IFEND;

  PROCEND verify_state_information;
?? TITLE := '      wait_for_verify_queue_message ', EJECT ??

  PROCEDURE wait_for_verify_queue_message
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table;
         p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
     VAR reply_header: dft$poll_header);

{------------------------------------------------------------------------
{   Arbitrary value of the wait time before the queue information is
{   received. The value is in milliseconds.
{------------------------------------------------------------------------

    CONST
      initial_wait_time = 10 * 1000;

    VAR
      operator_message: string (79),
      p_driver_flags: ^dft$queue_entry_flags,
      poll_received: boolean,
      restart: boolean,
      status: ost$status,
      time_before_wait: integer;

{--------------------------------------------------------------------------
{   This procedure is executed whenever Activate_Client subcommand has been
{   issued and Server_State = dfc$terminated dfc$inactive or dfc$awaiting_recovery
{   The procedure sets the Queue IDLE flag to FALSE and activates PP driver.
{   (Should Activate_PP return abnormal status, IDLE will be set again by
{   Unload_PP_If_Last called in Terminate_Task).
{   It then waits until Subsystem_Action is set in Driver_Queue_Entry.
{   Finally it calls Determine_Wakeup_Cause to process the (presumed) message
{   from the Client.
{--------------------------------------------------------------------------

    status.normal := TRUE;
    restart := FALSE;

    dfp$load_pp_if_first (p_q_interface_directory_entry, queue_index, status);
    IF NOT status.normal THEN
      display_error_status (status);
      p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
      operator_message := '  TIMEOUT CLIENT.';
      timeout_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, restart);
    IFEND;

    p_driver_flags := ^p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue^.queue_entries [dfc$poll_queue_index].flags;
    REPEAT
      #SPOIL (p_cpu_queue^.queue_header.partner_status);
      #SPOIL (p_driver_flags^.subsystem_action);
      IF p_cpu_queue^.queue_header.partner_status.terminate_partner THEN
        p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
        operator_message := '  Operator terminated Client.';
        terminate_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, restart);
      ELSEIF p_cpu_queue^.queue_header.partner_status.timeout_partner THEN
        p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
        operator_message := '  Operator timeout Client.';
        timeout_job (p_cpu_queue, queue_index, p_queue_interface_table, operator_message, restart);
      IFEND;
      time_before_wait := #FREE_RUNNING_CLOCK (0);
      pmp$wait (initial_wait_time, initial_wait_time);
    UNTIL p_driver_flags^.subsystem_action;

    determine_wakeup_cause (p_cpu_queue, queue_index, p_queue_interface_table, time_before_wait,
          reply_header);

  PROCEND wait_for_verify_queue_message;

MODEND dfm$manage_client_connection;

*DECK DECK=DFM$MANAGE_IJL_ACCESS_WORK EXPAND=TRUE
?? RIGHT := 110 ??
MODULE dfm$manage_ijl_access_work;
{
{   The purpose of this module is to manage fetching and clearing the
{ inhibit_access_work in a initiated_job_list entry.  The particular mainframe
{ inhibit_access_work is set by use of delayed swap in work.
{
?? PUSH (LISTEXT := ON) ??
*copyc dfp$locate_server_translation
*copyc dft$rb_file_server_request
*copyc i#call_monitor
*copyc jmv$jcb
*copyc dfv$file_server_debug_enabled
*copyc dft$mainframe_set
*copyc pmt$binary_mainframe_id
?? POP ??
?? TITLE := ' [XDCL, #GATE] dfp$clear_inhibit_access_work', EJECT ??
{  There is a small window here is the state of the server changes an
{ delayed swap in is being performed while this routine executes.
{
{ The purpose of this routine is to change the inhibit_access_work in
{ the initiated_job_list_entry.  The particular requested mainframe
{ is removed from the callers job inhibit_access_work.
{  The inhibit_access_state in the segment_descriptor_table_ex
{ may optionally be changed as a result of this request.
{
  PROCEDURE [XDCL, #GATE] dfp$clear_inhibit_access_work
    (    server_mainframe_id: pmt$binary_mainframe_id;
         clear_sdtx: boolean);

    VAR
      mainframe_id_ordinal: 1 .. dfc$max_number_of_mainframes,
      request_block: dft$rb_file_server_request,
      server_found: boolean;

    dfp$locate_server_translation (server_mainframe_id, mainframe_id_ordinal, server_found);
    IF server_found THEN
      jmv$jcb.ijle_p^.inhibit_access_work := jmv$jcb.ijle_p^.inhibit_access_work -
            $dft$mainframe_set [mainframe_id_ordinal];
      IF clear_sdtx THEN
        request_block.reqcode := syc$rc_file_server_request;
        request_block.request := dfc$fsr_clear_inhibit_access;
        request_block.status.normal := TRUE;
        request_block.clear_ijl_ordinal := jmv$jcb.ijl_ordinal;
        request_block.clear_inhibit_work := $dft$mainframe_set [mainframe_id_ordinal];
        i#call_monitor (#LOC (request_block), #SIZE (request_block));
      IFEND;
    IFEND;
  PROCEND dfp$clear_inhibit_access_work;
?? TITLE := ' [XDCL, #GATE] dfp$fetch_access_work', EJECT ??

{  This routine fetches the inhibit and terminated access work
{ for the requesting job.

  PROCEDURE [XDCL, #GATE] dfp$fetch_access_work
    (VAR inhibit_access_work: dft$mainframe_set;
     VAR terminate_access_work: dft$mainframe_set);

    inhibit_access_work := jmv$jcb.ijle_p^.inhibit_access_work;
    terminate_access_work := jmv$jcb.ijle_p^.terminate_access_work;
  PROCEND dfp$fetch_access_work;

?? TITLE := ' [XDCL, #GATE] dfp$verify_all_sdtxs_recovered', EJECT ??
{  This procedure interfaces to monitor to verify that all
{ segments for the current job have recovered.

  PROCEDURE [XDCL, #GATE] dfp$verify_all_sdtxs_recovered
    (    server_mainframe_id: pmt$binary_mainframe_id);

    VAR
      mainframe_id_ordinal: 1 .. dfc$max_number_of_mainframes,
      request_block: dft$rb_file_server_request,
      server_found: boolean;

    dfp$locate_server_translation (server_mainframe_id, mainframe_id_ordinal, server_found);
    IF server_found THEN
      request_block.reqcode := syc$rc_file_server_request;
      request_block.request := dfc$fsr_verify_sdtx_recovery;
      request_block.status.normal := TRUE;
      request_block.recovered_job_ijl_ordinal := jmv$jcb.ijl_ordinal;
      request_block.recovered_mainframe := $dft$mainframe_set [mainframe_id_ordinal];
      request_block.job_terminate_access_work := $dft$mainframe_set [];
      i#call_monitor (#LOC (request_block), #SIZE (request_block));
    IFEND;
  PROCEND dfp$verify_all_sdtxs_recovered;
MODEND dfm$manage_ijl_access_work;
*DECK DECK=DFM$MANAGE_IMAGE EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE File Server: Manage Image' ??
MODULE dfm$manage_image;

{
{   This module includes the processes involved with the server image file.
{  The server image file is the permanent file that is used to retain pages
{  on the client mainframe belonging to a server mainframe.
{  On the client mainframe this includes:
{  - Continuation deadstart:
{    Referencing the old system file table from the image.
{    For each server file copy the server pages to the server image.
{ -  Timeout processing
{    Using the system file table from memory move
{    pages from real memory to the server image file.
{  This module also includes the process involved with flushing the image
{    file to the server mainframe on activation from the awaiting_recovery
{    state.
{
{ The general flow within this module is as follows.
{   DEFINE_SERVER
{      dfp$create_image_file
{
{   Continuation deadstart
{     dfp$save_server_image
{        get_image_file
{        recover_server_files
{          for all server files
{             save_server_file_image
{                move pages from old image to server image file
{        return_image_file
{
{   activation of file server
{     dfp$flush_image_file
{       get_image_file
{       dfp$begin_ch_remote_proc_call
{       dfp$send_client_rpc_segment
{       dfp$send_remote_procedure_call
{                                             dfp$server_flush_image_file
{                                               dfp$receive_client_rpc_segment
{                                               recover_served_file
{                                                  update_served_file_image
{                                                    allocate_file_space
{                                                    open the disk file and
{                                                    move the pages
{                                                    free the pages from the recovery job's working set
{                                                  dmp$set_eoi
{       terminate_unrecovered_files
{       dfp$end_ch_remote_proc_call
{


?? NEWTITLE := '  Global Declarations Reference by this Module', EJECT ??
*copyc dft$image_file
?? SKIP := 6 ??
*copyc dft$image_file_id
*copyc osc$volume_unavailable_cond
?? SKIP := 6 ??
*copyc dfp$initialize_block_header
?? SKIP := 6 ??
*copyc dfp$expand_image_file
?? SKIP := 6 ??
*copyc dfp$get_next_image_block
?? PUSH (LISTEXT := ON) ??
*copyc amp$close
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$return
*copyc clp$get_value
*copyc clp$operator_intervention
*copyc clp$scan_parameter_list
*copyc dfc$partially_rebuilt_fde_eoi
*copyc dfc$server_mainframes_catalog
*copyc dfc$test_jr_constants
*copyc dfi$display
*copyc dfi$log_display
*copyc dfp$build_image_file_name
*copyc dfp$complement_gfn
*copyc dfp$crack_mainframe_id
*copyc dfp$delete_client_rpc_segment
*copyc dfp$find_mainframe_id
*copyc dfp$get_served_file_desc_p
*copyc dfp$r1_timeout_server_files
*copyc dfp$receive_client_rpc_segment
*copyc dfp$send_client_rpc_segment
*copyc dfp$send_message_to_operator
*copyc dfp$send_remote_procedure_call
*copyc dfp$uncomplement_gfn
*copyc dfp$verify_system_administrator
*copyc dfv$file_server_debug_enabled
*copyc dfv$recovery_task
*copyc dmp$allocate_file_space_r1
*copyc dmp$change_overflow_allowed
*copyc dmp$close_file
*copyc dmp$generate_gfn_hash
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_old_image_pointers
*copyc dmp$get_total_allocated_length
*copyc dmp$open_file
*copyc dmp$search_fdt_by_gfn
*copyc dmp$set_eoi
*copyc dmp$terminate_server_file_list
*copyc dmt$error_condition_codes
*copyc dsp$system_committed
*copyc fsp$close_file
*copyc fsp$open_file
*copyc gfp$get_fde_p
*copyc gfp$scan_all_fdes_in_image
*copyc i#build_adaptable_seq_pointer
*copyc i#current_sequence_position
*copyc i#move
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc mmp$fetch_image_page_count
*copyc mmp$fetch_pvas_of_image_pages
*copyc mmp$free_pages
*copyc mmp$get_allocated_addresses
*copyc mmp$os_preallocate_file_space
*copyc mmp$set_segment_length
*copyc mmp$write_modified_pages
*copyc osp$append_status_parameter
*copyc osp$establish_condition_handler
*copyc osp$get_condition_status
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$verify_system_privilege
*copyc osv$page_size
*copyc pfp$attach
*copyc pfp$define
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_multi_item_info
*copyc pfp$purge
*copyc pfp$restricted_attach
*copyc pmp$continue_to_cause
*copyc pmp$convert_mainframe_to_binary
*copyc pmp$convert_binary_mainframe_id
*copyc pmp$convert_binary_unique_name
*copyc pmp$delay
*copyc pmp$exit
*copyc pmp$get_mainframe_id
*copyc syp$hang_if_system_jrt_set
?? POP ??
?? TITLE := 'Client: [XDCL] dfp$create_image_file ', EJECT ??

{
{   This procedure creates the image file for the specified server mainframe.
{ If preallocated_size is greater than zero,  space is preallocated for the
{ file.  If the file already exists but the specified preallocated_size is
{ greater than the current allocated length for the file, the file will be
{ extended.  During this time the file is allowed to overflow devices, but
{ when written by timeout or continuation deadstart it is not allowed to
{ overflow.

  PROCEDURE [XDCL] dfp$create_image_file
    (    server_mainframe_id: pmt$binary_mainframe_id;
         preallocated_size: ost$segment_length;
     VAR image_file_already_exists: boolean;
     VAR status: ost$status);

    VAR
      cycle_selector: pft$cycle_selector,
      file_id: amt$file_identifier,
      local_status: ost$status,
      mainframe_file_path: array [1 .. 4] of pft$name,
      p_seq: ^SEQ ( * ),
      p_server_image_header: ^dft$image_header,
      segment_pointer: amt$segment_pointer,
      server_image_file_name: ost$name;

    dfp$build_image_file_name (server_mainframe_id, server_image_file_name);
    IF dfv$file_server_debug_enabled THEN
      display (server_image_file_name);
    IFEND;

    mainframe_file_path [1] := ' ';
    mainframe_file_path [2] := ' ';
    mainframe_file_path [3] := dfc$server_mainframes_catalog;
    mainframe_file_path [4] := server_image_file_name;
    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := 1;
    pfp$define (server_image_file_name, mainframe_file_path, cycle_selector, osc$null_name,
          pfc$maximum_retention, pfc$log, status);
    IF NOT status.normal THEN
      IF (status.condition = pfe$name_already_permanent_file) OR (status.condition = pfe$duplicate_cycle) THEN
        image_file_already_exists := TRUE;
        status.normal := TRUE;
        IF preallocated_size > 0 THEN
          increase_preallocated_size (server_mainframe_id, preallocated_size, status);
        IFEND;
      IFEND;
      RETURN;
    IFEND;

    image_file_already_exists := FALSE;
    amp$open (server_image_file_name, amc$segment, NIL, file_id, status);
    IF NOT status.normal THEN
      amp$return (server_image_file_name, local_status);
      RETURN;
    IFEND;
    amp$get_segment_pointer (file_id, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      amp$close (file_id, local_status);
      amp$return (server_image_file_name, local_status);
      RETURN;
    IFEND;
    p_seq := segment_pointer.sequence_pointer;

    IF preallocated_size > 0 THEN
      mmp$os_preallocate_file_space (p_seq, preallocated_size, { wait secs } 60, status);
      IF status.normal THEN
        mmp$set_segment_length (p_seq, { ring } 2, preallocated_size, status);
      IFEND;
      IF NOT status.normal THEN
        { Despite this abnormal status continue.  The image file write
        { process during continuation deadstart or timeout will attempt to
        { preallocate space as it goes.
        display_integer (' Unable to preallocate server image space: ', preallocated_size);
        log_display_integer ($pmt$ascii_logset [pmc$system_log],
              ' Unable to preallocate server image space: ', preallocated_size);
        display_status (status);
        log_display_status ($pmt$ascii_logset [pmc$system_log], { format } TRUE, status);
      IFEND;
    IFEND;

    initialize_image_file (server_mainframe_id, preallocated_size, p_seq);

    RESET p_seq;
    NEXT p_server_image_header IN p_seq;
    p_server_image_header^.file_update_flag := dfc$image_file_valid;
    amp$close (file_id, status);

    change_overflow_allowed (server_image_file_name, FALSE, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

    amp$return (server_image_file_name, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;
  PROCEND dfp$create_image_file;
?? TITLE := 'Client: [XDCL, #GATE] dfp$display_image_file ', EJECT ??

{ This procedure is provided for debugging file server.
{  display_image_file (mainframe_name: name 17  = $optional
{    image_file, if: file = $optional
{    display_pages, dp: boolean = FALSE
{    status)
{ This command processor displays the image file to the $response
{ file.  This includes display of all headers in the image file.
{ If the image_file parameter is specified the image file is displayed from the
{   specified file.  This may be used to look at an image file from a dump
{   by using a copy_memory command to command memory from the dump to a
{   file that would be specified as this parameter.
{ If the image file is not specified, then the mainframe_name parameter
{   must be specified and the image file for that server mainframe is
{   displayed and is attached from the $system.$df$client_mainframes catalog.
{   This option is only allowed from the console.
{ The display_pages parameter indicates whether the actual page data for
{   each file is to be displayed.
{

  PROCEDURE [XDCL, #GATE] dfp$display_image_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{   pdt display_image_file (mainframe_name: name 17  = $optional
{    image_file, if: file = $optional
{    display_pages, dp: boolean = FALSE
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    display_image_file: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^display_image_file_names,
  ^display_image_file_params];

  VAR
    display_image_file_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
  clt$parameter_name_descriptor := [['MAINFRAME_NAME', 1], ['IMAGE_FILE', 2], ['IF', 2], ['DISPLAY_PAGES', 3]
  , ['DP', 3], ['STATUS', 4]];

  VAR
    display_image_file_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor
  := [

{ MAINFRAME_NAME }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 17, 17]],

{ IMAGE_FILE IF }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ DISPLAY_PAGES DP }
    [[clc$optional_with_default, ^display_image_file_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    display_image_file_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'FALSE';

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      block_advanced: boolean,
      display_pages: boolean,
      file_count: gft$file_descriptor_index,
      image_file_id: dft$image_file_id,
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id,
      p_data: ^cell,
      p_file_header: ^dft$image_file_header,
      p_page_header: ^dft$image_page_header,
      page_count: 0 .. osc$max_page_frames,
      value: clt$value;

    dfp$verify_system_administrator ('DISPLAY_IMAGE_FILE', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, display_image_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DISPLAY_PAGES', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display_pages := value.bool.value;

    clp$get_value ('IMAGE_FILE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind = clc$unknown_value THEN
      dfp$crack_mainframe_id ('MAINFRAME_NAME', mainframe_name, mainframe_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      get_image_file (mainframe_id, dfc$read_image_file, image_file_id, status);
    ELSE
      open_file_as_image (value.file.local_file_name, image_file_id, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display_pva (' Current eoi ', image_file_id.p_current_eoi);
    display_integer (' Current allocated_length', image_file_id.allocated_size);
    display_image_header (image_file_id.p_image_header^);
    block_advanced := FALSE;

  /for_all_blocks_in_image/
    WHILE image_file_id.p_current_block_header <> NIL DO
      IF NOT block_advanced THEN
        display_block_header (image_file_id.p_current_block_header);
      IFEND;
      block_advanced := FALSE;

    /for_all_files_starting_in_block/
      FOR file_count := 1 TO image_file_id.p_current_block_header^.file_count DO
        NEXT p_file_header IN image_file_id.p_current_block_seq;
        display_file_header (p_file_header);

      /for_all_pages_of_file/
        FOR page_count := 1 TO p_file_header^.page_count DO
          NEXT p_page_header IN image_file_id.p_current_block_seq;
          IF p_page_header = NIL THEN
            display (' --- Pages for a file crossing block boundary ');
            advance_to_next_block (image_file_id);
            block_advanced := TRUE;
            display_block_header (image_file_id.p_current_block_header);
            NEXT p_page_header IN image_file_id.p_current_block_seq;
          IFEND;
          display_pva ('  - dft$image_page_header ', p_page_header);
          display_integer ('    <page count > ', page_count);
          display_integer ('    file_offset', p_page_header^.file_offset);
          display_integer ('    image_offset', p_page_header^.image_offset);
          IF display_pages THEN
            p_data := #ADDRESS (#RING (image_file_id.p_current_block_header),
                  #SEGMENT (image_file_id.p_current_block_header), p_page_header^.image_offset);
            display_bytes (p_data, image_file_id.p_image_header^.page_size);
          IFEND;
        FOREND /for_all_pages_of_file/;
      FOREND /for_all_files_starting_in_block/;
      IF block_advanced THEN

{ The block header is all set up

      ELSEIF image_file_id.p_current_block_header^.next_block_header_offset = 0 THEN
        image_file_id.p_current_block_header := NIL;
      ELSE
        advance_to_next_block (image_file_id);
      IFEND;

    WHILEND /for_all_blocks_in_image/;

    return_image_file (image_file_id, status);

  PROCEND dfp$display_image_file;
?? TITLE := 'Client: [XDCL, #GATE] dfp$flush_image_file_command', EJECT ??

{ This procedure is provided for debugging file server.

  PROCEDURE [XDCL, #GATE] dfp$flush_image_file_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  pdt flush_image_file (mainframe_name: name 17  = $required
{  status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    flush_image_file: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
[^flush_image_file_names,
  ^flush_image_file_params];

  VAR
    flush_image_file_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1
.. 2] of
  clt$parameter_name_descriptor := [['MAINFRAME_NAME', 1], ['STATUS', 2]];

  VAR
    flush_image_file_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2]
of clt$parameter_descriptor
  := [

{ MAINFRAME_NAME }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
clc$name_value, 17, 17]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id;

    dfp$verify_system_administrator ('FLUSH_IMAGE_FILE', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, flush_image_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$crack_mainframe_id ('MAINFRAME_NAME', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$flush_image_file (mainframe_id, mainframe_name, status);
  PROCEND dfp$flush_image_file_command;
?? TITLE := 'Client [XDCL] dfp$flush_image_file', EJECT ??

{   The purpose of this procedure (which executes on the client) is to
{ transfer the image file that exists on the client mainframe to the server
{ mainframe. This uses the RPC mechanism of sending a segment to the
{ server.  The companion RPC procedure on the server is
{ dfp$server_flush_image_file.   The server procedure returns the list
{ of files that did not recover.

  PROCEDURE [XDCL] dfp$flush_image_file
    (    mainframe_id: pmt$binary_mainframe_id;
         mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT dfp$flush_image_file;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      image_file_id: dft$image_file_id,
      local_status: ost$status,
      msg_string: string (80),
      msg_string_length: integer,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location,
      server_location: dft$server_location;

    get_image_file (mainframe_id, dfc$read_image_file, image_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (image_file_id.p_current_block_header = NIL) OR (image_file_id.p_current_block_header^.file_count = 0)
          THEN
      STRINGREP (msg_string, msg_string_length, ' Empty server image ', mainframe_name);
      log_display ($pmt$ascii_logset [pmc$system_log], msg_string (1, msg_string_length));
      display (msg_string (1, msg_string_length));
      return_image_file (image_file_id, status);
      RETURN;
    IFEND;
    dfv$recovery_task := TRUE;
    server_location.server_location_selector := dfc$mainframe_id;
    server_location.server_mainframe := mainframe_name;
    dfp$begin_ch_remote_proc_call (server_location, {allowed_when_server_deactivated } FALSE,
          queue_entry_location, p_send_to_server_params, p_send_data, status);

    IF status.normal THEN
      IF dfv$file_server_debug_enabled THEN
        display_integer (' Sending image to server ', #OFFSET (image_file_id.p_current_eoi));
      IFEND;
      dfp$send_client_rpc_segment (queue_entry_location, image_file_id.p_image_file, { offset = } 0, { size }
            #OFFSET (image_file_id.p_current_eoi), status);
      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$flush_image_file, {parameter_size } 0,
              {data size} 0, p_receive_from_server_params, p_receive_data, status);
        IF status.normal THEN
          terminate_unrecovered_files (mainframe_name, p_receive_data);
        IFEND;
      IFEND;
      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
    IFEND;

    return_image_file (image_file_id, local_status);

  PROCEND dfp$flush_image_file;
?? TITLE := 'Client: [XDCL, #GATE] dfp$free_image_file_command ', EJECT ??

{  This procedure is provided for testing file server.

  PROCEDURE [XDCL, #GATE] dfp$free_image_file_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  pdt free_image_file (mainframe_name: name 17  = $required
{  status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    free_image_file: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
[^free_image_file_names,
  ^free_image_file_params];

  VAR
    free_image_file_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1
.. 2] of
  clt$parameter_name_descriptor := [['MAINFRAME_NAME', 1], ['STATUS', 2]];

  VAR
    free_image_file_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2]
of clt$parameter_descriptor
  := [

{ MAINFRAME_NAME }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
clc$name_value, 17, 17]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id;

    dfp$verify_system_administrator ('FREE_IMAGE_FILE', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, free_image_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$crack_mainframe_id ('MAINFRAME_NAME', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$free_image_file (mainframe_id, status);
  PROCEND dfp$free_image_file_command;
?? TITLE := 'Client: [XDCL] dfp$free_image_file', EJECT ??

{  This procedure removes all pages from the image file. The allocated
{ length for the file is NOT changed.
{

  PROCEDURE [XDCL] dfp$free_image_file
    (    mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

    VAR
      image_file_id: dft$image_file_id;

    get_image_file (mainframe_id, dfc$reset_image_file, image_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    initialize_image_file (mainframe_id, image_file_id.p_image_header^.requested_preallocation_size,
          image_file_id.p_image_file);

    return_image_file (image_file_id, status);

  PROCEND dfp$free_image_file;

?? TITLE := 'Client: [XDCL] dfp$purge_all_image_files ', EJECT ??

{
{ Purpose:
{   This procedure purges all the image files contained in the catalog of
{   server mainframes.  This is done when we are not recovering server
{   mainframes.
{

  PROCEDURE [XDCL] dfp$purge_all_image_files;

    VAR
      catalog_content_info: amt$segment_pointer,
      catalog_path: array [1 .. 3] of pft$name,
      cycle_selector: pft$cycle_selector,
      file_path: array [1 .. 4] of pft$name,
      group: pft$group,
      index: pft$array_index,
      p_directory_array: pft$p_directory_array,
      p_info_record: pft$p_info_record,
      status: ost$status;

    IF dfv$file_server_debug_enabled THEN
      display ('Not recovering server mainframes ');
    IFEND;
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, catalog_content_info, status);
    IF status.normal THEN
      RESET catalog_content_info.sequence_pointer;
      group.group_type := pfc$public;
      catalog_path [1] := ' ';
      catalog_path [2] := ' ';
      catalog_path [3] := dfc$server_mainframes_catalog;
      pfp$get_multi_item_info (catalog_path, group, $pft$catalog_info_selections [],
            $pft$file_info_selections [pfc$file_directory], catalog_content_info.sequence_pointer, status);
      IF status.normal THEN
        RESET catalog_content_info.sequence_pointer;
        pfp$find_next_info_record (catalog_content_info.sequence_pointer, p_info_record, status);
        IF status.normal THEN
          pfp$find_directory_array (p_info_record, p_directory_array, status);
          IF status.normal AND (p_directory_array <> NIL) THEN
            file_path [1] := ' ';
            file_path [2] := ' ';
            file_path [3] := dfc$server_mainframes_catalog;
            cycle_selector.cycle_option := pfc$specific_cycle;
            cycle_selector.cycle_number := 1;

          /delete_all_images/
            FOR index := LOWERBOUND (p_directory_array^) TO UPPERBOUND (p_directory_array^) DO
              IF (p_directory_array^ [index].name_type = pfc$file_name) AND
                    (p_directory_array^ [index].name (1, 4) = 'DFF$') AND
                    (p_directory_array^ [index].name (22, 5) = 'IMAGE') THEN
                file_path [4] := p_directory_array^ [index].name;
                IF dfv$file_server_debug_enabled THEN
                  display (p_directory_array^ [index].name);
                IFEND;
                pfp$purge (file_path, cycle_selector, osc$null_name, status);
              IFEND;
            FOREND /delete_all_images/;
          IFEND;
        IFEND;
      IFEND;
      mmp$delete_scratch_segment (catalog_content_info, status);
    IFEND;
  PROCEND dfp$purge_all_image_files;
?? TITLE := 'Client:  [XDCL] dfp$purge_image_file', EJECT ??

{  This procedure deletes the image file for the specified server mainframe.

  PROCEDURE [XDCL] dfp$purge_image_file
    (    mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

    VAR
      cycle_selector: pft$cycle_selector,
      mainframe_file_path: array [1 .. 4] of pft$name,
      server_image_file_name: pft$name;

    dfp$build_image_file_name (mainframe_id, server_image_file_name);

    mainframe_file_path [1] := ' ';
    mainframe_file_path [2] := ' ';
    mainframe_file_path [3] := dfc$server_mainframes_catalog;
    mainframe_file_path [4] := server_image_file_name;
    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := 1;
    pfp$purge (mainframe_file_path, cycle_selector, osc$null_name, status);
  PROCEND dfp$purge_image_file;

?? TITLE := 'Client: [XDCL, #GATE] dfp$save_server_image ', EJECT ??

{
{    This procedure copies all pages for a single server mainframe from
{ the memory image to the server image file. This procedure is executed
{ during continuation deadstart.
{

  PROCEDURE [XDCL] dfp$save_server_image
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      image_available: boolean,
      image_page_count: 0 .. osc$max_page_frames,
      image_file_id: dft$image_file_id,
      local_status: ost$status,
      mainframe_id: pmt$binary_mainframe_id,
      msg_string: string (75),
      msg_string_length: integer,
      old_image_pointers: dmt$old_image_pointers;

    dfp$verify_system_administrator ('SAVE_SERVER_IMAGE', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$convert_mainframe_to_binary (mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$improper_mainframe_id, mainframe_name, status);
      RETURN;
    IFEND;

    IF mainframe_id.model_number = osc$cyber_180_model_unknown THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$unknown_model_number,
         mainframe_name (9, pmc$processor_model_number_size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, mainframe_name, status);
      RETURN;
    IFEND;

    STRINGREP (msg_string, msg_string_length, ' Recovering server ', mainframe_name, ' image.');
    log_display ($pmt$ascii_logset [pmc$system_log], msg_string (1, msg_string_length));
    display (msg_string (1, msg_string_length));

    dmp$get_old_image_pointers (old_image_pointers, image_available);
    mmp$fetch_image_page_count (image_page_count);
    IF (NOT image_available) OR (image_page_count = 0) THEN
      STRINGREP (msg_string, msg_string_length, '  Server Image unavailable ', mainframe_name, ' image.');
      log_display ($pmt$ascii_logset [pmc$system_log], msg_string (1, msg_string_length));
      display (msg_string (1, msg_string_length));
      RETURN;
    IFEND;

    get_image_file (mainframe_id, dfc$image_source_deadstart, image_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    recover_server_files (mainframe_id, mainframe_name, image_page_count, old_image_pointers, image_file_id,
          status);

    return_image_file (image_file_id, local_status);

  PROCEND dfp$save_server_image;
?? TITLE := 'Server: [XDCL, #GATE] dfp$server_flush_image_file', EJECT ??

{ This procedure is the server side of the RPC request started by
{ dfp$flush_image_file.  This procedure receives the segment containing the
{ image from the client mainframe.  This then cycles through the image file
{ and writes the pages to the actual permanent file. The p_send_to_client_data
{ area is used to return the list of files that did not recover to the client.
{

  PROCEDURE [XDCL, #GATE] dfp$server_flush_image_file
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      block_advanced: boolean,
      file_count: ost$non_negative_integers,
      files_not_recovered: ost$non_negative_integers,
      files_recovered: ost$non_negative_integers,
      gfn_name: ost$name,
      image_file_id: dft$image_file_id,
      local_status: ost$status,
      mainframe_found: boolean,
      msg_string: string (80),
      msg_string_length: integer,
      p_cpu_queue: ^dft$cpu_queue,
      p_file_header: ^dft$image_file_header,
      p_gfn: ^dmt$global_file_name,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: ^dft$queue_interface_table,
      pages_recovered_for_file: 0 .. osc$max_page_frames,
      queue_index: dft$queue_index,
      total_pages: ost$non_negative_integers;

    osp$verify_system_privilege;
    status.normal := TRUE;
    send_parameters_size := 0;
    send_data_size := 0;
    files_recovered := 0;
    files_not_recovered := 0;
    total_pages := 0;

    dfp$receive_client_rpc_segment (image_file_id.p_image_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    NEXT image_file_id.p_image_header IN image_file_id.p_image_file;
    IF dfv$file_server_debug_enabled THEN
      display_image_header (image_file_id.p_image_header^);
    IFEND;
    dfp$find_mainframe_id (image_file_id.p_image_header^.client_mainframe_name, { server_to_client } TRUE,
          mainframe_found, p_queue_interface_table, p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN

{ Server was probably terminated and deleted

      RETURN;
    IFEND;

    i#build_adaptable_seq_pointer (#RING (image_file_id.p_image_file), #SEGMENT (image_file_id.p_image_file),
          image_file_id.p_image_header^.page_size, { Size } image_file_id.p_image_header^.page_size,
          { next } 0, image_file_id.p_current_block_seq);
    NEXT image_file_id.p_current_block_header IN image_file_id.p_current_block_seq;
    image_file_id.client := FALSE;
    image_file_id.operation := dfc$read_image_file;

    block_advanced := FALSE;

  /for_all_blocks_in_image/
    WHILE image_file_id.p_current_block_header <> NIL DO
      IF dfv$file_server_debug_enabled THEN
        display_block_header (image_file_id.p_current_block_header);
      IFEND;
      block_advanced := FALSE;

    /recover_files_starting_in_block/
      FOR file_count := 1 TO image_file_id.p_current_block_header^.file_count DO
        #SPOIL (p_cpu_queue^.queue_header.partner_status.server_state);
        IF p_cpu_queue^.queue_header.partner_status.server_state <> dfc$recovering THEN
          osp$set_status_condition (dfe$server_has_terminated, status);
          RETURN;
        IFEND;

        NEXT p_file_header IN image_file_id.p_current_block_seq;
        IF dfv$file_server_debug_enabled THEN
          display_file_header (p_file_header);
        IFEND;
        recover_served_file (p_file_header^, p_cpu_queue^.queue_header.partner_status.server_state,
              image_file_id, block_advanced, pages_recovered_for_file, status);
        IF status.normal THEN
          files_recovered := files_recovered + 1;
          total_pages := total_pages + pages_recovered_for_file;
        ELSEIF status.condition = dfe$server_has_terminated THEN
          RETURN;
        ELSE
          pmp$convert_binary_unique_name (p_file_header^.global_file_name, gfn_name, local_status);
          STRINGREP (msg_string, msg_string_length, ' Client ',
                image_file_id.p_image_header^.client_mainframe_name, ' unrecovered file ',
                gfn_name);
          log_display ($pmt$ascii_logset [pmc$system_log, pmc$job_log], msg_string (1, msg_string_length));
          display_status (status);
          files_not_recovered := files_not_recovered + 1;
          NEXT p_gfn IN p_send_to_client_data;
          IF p_gfn = NIL THEN

{ Too many files - terminate the server

            p_cpu_queue^.queue_header.partner_status.terminate_partner := TRUE;
            osp$set_status_condition (dfe$server_has_terminated, status);
            RETURN;
          IFEND;

{ The gfn must be complemented because that is how the client
{ must terminate it.

          dfp$complement_gfn (p_file_header^.global_file_name, p_gfn^);
        IFEND;
      FOREND /recover_files_starting_in_block/;

      IF block_advanced THEN

      ELSEIF image_file_id.p_current_block_header^.next_block_header_offset = 0 THEN
        image_file_id.p_current_block_header := NIL;
      ELSE
        advance_to_next_block (image_file_id);
      IFEND;
    WHILEND /for_all_blocks_in_image/;

    STRINGREP (msg_string, msg_string_length, files_recovered, ' file(s) recovered');
    dfp$send_message_to_operator (msg_string (1, msg_string_length),
        {server_to_client} TRUE, image_file_id.p_image_header^.client_mainframe_name);

    STRINGREP (msg_string, msg_string_length, total_pages, ' page(s) recovered');
    dfp$send_message_to_operator (msg_string (1, msg_string_length),
          {server_to_client} TRUE, image_file_id.p_image_header^.client_mainframe_name);

    STRINGREP (msg_string, msg_string_length, files_not_recovered, ' file(s) not recovered');
    dfp$send_message_to_operator (msg_string (1, msg_string_length),
          {server_to_client} TRUE, image_file_id.p_image_header^.client_mainframe_name);
    send_data_size := i#current_sequence_position (p_send_to_client_data);

    dfp$delete_client_rpc_segment;

  PROCEND dfp$server_flush_image_file;
?? TITLE := 'Client: [XDCL, #GATE] dfp$timeout_server_files_cmnd', EJECT ??

{ FOR TEST PURPOSES ONLY !!!
{ DONT EVEN THINK ABOUT USING UNLESS THE SERVER IS AWAITING RECOVERY

  PROCEDURE [XDCL, #GATE] dfp$timeout_server_files_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  pdt timeout_server_files (mainframe_name: name 17  = $required
{  status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    timeout_server_files: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
[^timeout_server_files_names,
  ^timeout_server_files_params];

  VAR
    timeout_server_files_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1
.. 2] of
  clt$parameter_name_descriptor := [['MAINFRAME_NAME', 1], ['STATUS', 2]];

  VAR
    timeout_server_files_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2]
of clt$parameter_descriptor
  := [

{ MAINFRAME_NAME }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
clc$name_value, 17, 17]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      local_status: ost$status,
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id;

    dfp$verify_system_administrator ('TIMEOUT_SERVER_FILES', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, timeout_server_files, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$crack_mainframe_id ('MAINFRAME_NAME', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$timeout_server_files (mainframe_id, status);
  PROCEND dfp$timeout_server_files_cmnd;

?? TITLE := 'Client: dfp$timeout_server_files ', EJECT ??

  PROCEDURE [XDCL] dfp$timeout_server_files
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

    VAR
      image_file_id: dft$image_file_id,
      local_status: ost$status,
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: ^dft$queue_interface_table,
      p_server_state : ^dft$server_state,
      queue_index: dft$queue_index,
      server_mainframe_name: pmt$mainframe_id;

    display (' Saving pages belonging to server ');
    log_display ($pmt$ascii_logset [pmc$system_log], ' Saving pages belonging to server ');
    pmp$convert_binary_mainframe_id (server_mainframe_id, server_mainframe_name,
          status);
    dfp$find_mainframe_id (server_mainframe_name, { server_to_client } FALSE,
          mainframe_found, p_queue_interface_table, p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN

{ Server was probably terminated and deleted

      RETURN;
    IFEND;
    p_server_state :=  ^p_cpu_queue^.queue_header.partner_status.server_state;

    get_image_file (server_mainframe_id, dfc$image_source_timeout, image_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$r1_timeout_server_files (server_mainframe_id, p_server_state, image_file_id, status);

    return_image_file (image_file_id, local_status);

    display (' Saving server pages complete ');
    log_display ($pmt$ascii_logset [pmc$system_log], ' Saving server pages complete ');
  PROCEND dfp$timeout_server_files;

?? TITLE := 'Server: allocate_file_space', EJECT ??

{  This procedure increases the size of the disk file on the server mainframe
{ if it is required. This procedure waits one minute before giving up with
{ the status of  dme$unable_to_alloc_all_space.

  PROCEDURE allocate_file_space
    (    sfid: gft$system_file_identifier;
         file_header: dft$image_file_header;
     VAR server_state: dft$server_state;
     VAR status: ost$status);

    VAR
      allocate_attempt: 1 .. 5,
      allocated_length: amt$file_byte_address,
      fde_p: gft$file_desc_entry_p;

    gfp$get_fde_p (sfid, fde_p);
    dmp$get_total_allocated_length (fde_p, allocated_length);

    IF (file_header.page_count > 0) AND (allocated_length < (file_header.highest_file_offset + osv$page_size))
          THEN

    /attempt_allocate_file_space/
      FOR allocate_attempt := 1 TO 5 DO
        IF dfv$file_server_debug_enabled THEN
          display_integer (' Extending file to ', file_header.highest_file_offset);
        IFEND;
        #SPOIL (server_state);
        IF server_state <> dfc$recovering THEN
          osp$set_status_condition (dfe$server_has_terminated, status);
          RETURN;
        IFEND;
        dmp$allocate_file_space_r1 (sfid, { byte address} file_header.highest_file_offset,
              { size } osv$page_size, {chapter } 0, osc$nowait, sfc$no_limit, status);
        IF dfv$file_server_debug_enabled THEN
          display_status (status);
        IFEND;
        IF status.normal OR (status.condition <> dme$unable_to_alloc_all_space) THEN
          EXIT /attempt_allocate_file_space/;
        IFEND;
        pmp$delay (12000 { 12 seconds} , status);
      FOREND /attempt_allocate_file_space/;
    IFEND;
  PROCEND allocate_file_space;

?? TITLE := ' advance_to_next_block ', EJECT ??

  PROCEDURE advance_to_next_block
    (VAR image_file_id: dft$image_file_id);

    i#build_adaptable_seq_pointer (#RING (image_file_id.p_image_file), #SEGMENT (image_file_id.p_image_file),
          image_file_id.p_current_block_header^.next_block_header_offset,
          { Size } image_file_id.p_image_header^.page_size, { next } 0, image_file_id.p_current_block_seq);
    NEXT image_file_id.p_current_block_header IN image_file_id.p_current_block_seq;

  PROCEND advance_to_next_block;
?? TITLE := 'Client: change_overflow_allowed ', EJECT ??

  PROCEDURE change_overflow_allowed
    (    lfn: amt$local_file_name;
         overflow_allowed: boolean;
     VAR status: ost$status);

    VAR
      contains_data: boolean,
      existing_file: boolean,
      local_file: boolean,
      p_file_attributes: ^amt$get_attributes;

    PUSH p_file_attributes: [1 .. 1];
    p_file_attributes^ [1].key := amc$global_file_name;
    amp$get_file_attributes (lfn, p_file_attributes^, local_file, existing_file, contains_data, status);
    IF status.normal THEN
      dmp$change_overflow_allowed (p_file_attributes^ [1].global_file_name, overflow_allowed, status);
      IF dfv$file_server_debug_enabled THEN
        display_boolean (' dmp$change_overflow_allowed ', overflow_allowed);
        display_status (status);
      IFEND;
    IFEND;
  PROCEND change_overflow_allowed;
?? TITLE := ' display_block_header ', EJECT ??

  PROCEDURE display_block_header
    (    p_block_header: ^dft$image_block_header);

    display_pva (' ****************  dft$image_block_header ', p_block_header);
    IF p_block_header = NIL THEN
      RETURN;
    IFEND;
    display (p_block_header^.block_header_string);
    display_integer ('   file_count', p_block_header^.file_count);
    display_integer ('   page_count', p_block_header^.page_count);
    CASE p_block_header^.page_source OF
    = dfc$image_source_timeout =
      display ('    dfc$image_source_timeout');
    = dfc$image_source_deadstart =
      display ('    dfc$image_source_deadstart');
    ELSE
      display_integer (' Unknown image source ', $INTEGER (p_block_header^.page_source));
    CASEND;
    display_integer ('   next_block_header_offset', p_block_header^.next_block_header_offset);

  PROCEND display_block_header;
?? TITLE := ' display_file_header ', EJECT ??

  PROCEDURE display_file_header
    (    p_file_header: ^dft$image_file_header);

    VAR
      gfn_name: ost$name,
      status: ost$status;

    display_pva ('   -- dft$image_file_header ', p_file_header);
    display_boolean (' file_completed', p_file_header^.file_completed);
    pmp$convert_binary_unique_name (p_file_header^.global_file_name, gfn_name, status);
    display (gfn_name);
    display_integer (' eoi_byte_address', p_file_header^.eoi_byte_address);
    display_integer (' highest_file_offset', p_file_header^.highest_file_offset);
    display_integer (' page_count ', p_file_header^.page_count);
  PROCEND display_file_header;
?? TITLE := ' display_image_header ', EJECT ??

  PROCEDURE display_image_header
    (    image_header: dft$image_header);

    display (' -------  dft$image_header ');
    display (image_header.file_update_flag);
    display (image_header.version);
    display ('  Server / Client ');
    display (image_header.server_mainframe_name);
    display (image_header.client_mainframe_name);
    display_integer (' current_eoi ', image_header.current_eoi);
    display_integer (' requested_preallocation_size ', image_header.requested_preallocation_size);
    display_integer (' page_size ', image_header.page_size);
  PROCEND display_image_header;

?? TITLE := 'Client: get_image_file ', EJECT ??

{ This procedure gains access to the image file for the specified server
{ mainframe. The image file must exist for this request to work.
{ This procedure sets up the image_file_id which is used to reference
{ the image file.
{ This procedure will attempt to repair the image file if the system crashed
{ previously while the image file was being written.
{ The operation parameter controls what is done to the image file and how
{ the image file is positioned:
{ = dfc$read_image_file =
{   Image file position at first block.
{ = dfc$reset_image_file =
{   Previous pages discarded.
{   Image file re-initialized and positioned at new first block.
{ = dfc$image_source_timeout, dfc$image_source_deadstart =
{   New block created at the end of the image file.

  PROCEDURE get_image_file
    (    server_mainframe_id: pmt$binary_mainframe_id;
         operation: dft$image_file_operation;
     VAR image_file_id: dft$image_file_id;
     VAR status: ost$status);

    VAR
      address_pairs_returned: integer,
      allocated_length_list: array [1 .. 1] of dmt$addr_length_pair,
      cycle_number: pft$cycle_number,
      cycle_selector: pft$cycle_selector,
      list_overflow: boolean,
      local_status: ost$status,
      mainframe_file_path: array [1 .. 4] of pft$name,
      p_last_block: ^dft$image_block_header,
      p_next_to_last_block: ^dft$image_block_header,
      segment_pointer: amt$segment_pointer,
      server_image_file_name: ost$name,
      server_mainframe_name: pmt$mainframe_id;

    image_file_id.client := TRUE;
    dfp$build_image_file_name (server_mainframe_id, server_image_file_name);
    IF dfv$file_server_debug_enabled THEN
      display (server_image_file_name);
    IFEND;

    mainframe_file_path [1] := ' ';
    mainframe_file_path [2] := ' ';
    mainframe_file_path [3] := dfc$server_mainframes_catalog;
    mainframe_file_path [4] := server_image_file_name;
    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := 1;
    IF dsp$system_committed () THEN
      pfp$attach (server_image_file_name, mainframe_file_path, cycle_selector, osc$null_name,
            -$pft$usage_selections [], $pft$share_selections [pfc$read], pfc$wait, status);
    ELSE { Prior to the point of commitment
      pfp$restricted_attach (server_image_file_name, mainframe_file_path, cycle_selector, osc$null_name,
            -$pft$usage_selections [], $pft$share_selections [pfc$read], cycle_number, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (server_image_file_name, amc$segment, NIL, image_file_id.file_id, status);
    IF NOT status.normal THEN
      amp$return (server_image_file_name, local_status);
      RETURN;
    IFEND;
    amp$get_segment_pointer (image_file_id.file_id, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      amp$close (image_file_id.file_id, local_status);
      amp$return (server_image_file_name, local_status);
      RETURN;
    IFEND;

    image_file_id.p_image_file := segment_pointer.sequence_pointer;
    NEXT image_file_id.p_image_header IN segment_pointer.sequence_pointer;
    mmp$get_allocated_addresses (image_file_id.p_image_file, { Starting address } 0, allocated_length_list,
          address_pairs_returned, list_overflow, status);
    image_file_id.allocated_size := allocated_length_list [1].length;
    IF dfv$file_server_debug_enabled THEN
      display_integer (' mmp$get_allocated_addresses ', image_file_id.allocated_size);
      IF NOT status.normal THEN
        display_status (status);
      IFEND;
      display_integer (' current eoi ', image_file_id.p_image_header^.current_eoi);
    IFEND;
    image_file_id.local_file_name := server_image_file_name;
    image_file_id.operation := operation;
    image_file_id.p_current_eoi := #ADDRESS (#RING (image_file_id.p_image_file),
          #SEGMENT (image_file_id.p_image_file), { Offset } image_file_id.p_image_header^.current_eoi);
    IF (image_file_id.p_image_header^.current_eoi = osv$page_size) OR
          (image_file_id.p_image_header^.current_eoi = image_file_id.p_image_header^.page_size) THEN
      image_file_id.p_current_block_header := NIL;
      image_file_id.p_current_block_seq := NIL;
    ELSE
      i#build_adaptable_seq_pointer (#RING (image_file_id.p_image_file),
            #SEGMENT (image_file_id.p_image_file), osv$page_size, { Size } osv$page_size, { next } 0,
            image_file_id.p_current_block_seq);
      NEXT image_file_id.p_current_block_header IN image_file_id.p_current_block_seq;
    IFEND;

    IF (operation <> dfc$reset_image_file) THEN
      repair_image_file (server_mainframe_id, image_file_id, status);
    IFEND;

    IF (operation = dfc$reset_image_file) THEN
      initialize_image_file (server_mainframe_id, image_file_id.p_image_header^.requested_preallocation_size,
            image_file_id.p_image_file);
    ELSEIF (operation = dfc$read_image_file) THEN
      image_file_id.p_current_eoi := #ADDRESS (#RING (image_file_id.p_image_file),
            #SEGMENT (image_file_id.p_image_file), { Offset } image_file_id.p_image_header^.current_eoi);
    ELSEIF (#OFFSET (image_file_id.p_current_eoi) = osv$page_size) THEN
      initialize_image_file (server_mainframe_id, image_file_id.p_image_header^.requested_preallocation_size,
            image_file_id.p_image_file);

{ Create the first block_sequence and header

      i#build_adaptable_seq_pointer (#RING (image_file_id.p_image_file),
            #SEGMENT (image_file_id.p_image_file), osv$page_size, { Size } osv$page_size, { next } 0,
            image_file_id.p_current_block_seq);
      NEXT image_file_id.p_current_block_header IN image_file_id.p_current_block_seq;
      dfp$initialize_block_header (image_file_id.operation, image_file_id.p_current_block_header^);
      image_file_id.p_current_eoi := #ADDRESS (#RING (image_file_id.p_image_file),
            #SEGMENT (image_file_id.p_image_file), { Offset- One page header, One page block} 2 *
            osv$page_size);
      image_file_id.p_image_header^.current_eoi := #OFFSET (image_file_id.p_current_eoi);
    ELSEIF operation IN $dft$image_file_operations [dfc$image_source_timeout, dfc$image_source_deadstart] THEN
      dfp$expand_image_file (image_file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      locate_last_block (image_file_id, p_next_to_last_block, p_last_block);

{ Create the next block_sequence and header

      i#build_adaptable_seq_pointer (#RING (image_file_id.p_image_file),
            #SEGMENT (image_file_id.p_image_file), #OFFSET (image_file_id.p_current_eoi),
            { Size } osv$page_size, { next } 0, image_file_id.p_current_block_seq);
      NEXT image_file_id.p_current_block_header IN image_file_id.p_current_block_seq;
      dfp$initialize_block_header (operation, image_file_id.p_current_block_header^);
      p_last_block^.next_block_header_offset := #OFFSET (image_file_id.p_current_block_header);

      image_file_id.p_current_eoi := #ADDRESS (#RING (image_file_id.p_image_file),
            #SEGMENT (image_file_id.p_image_file), { Offset } #OFFSET (image_file_id.p_current_eoi) +
            osv$page_size);
      image_file_id.p_image_header^.current_eoi := #OFFSET (image_file_id.p_current_eoi);
    IFEND;

  PROCEND get_image_file;
?? TITLE := 'Client: increase_preallocated_size ', EJECT ??

  PROCEDURE increase_preallocated_size
    (    mainframe_id: pmt$binary_mainframe_id;
         requested_preallocated_size: ost$segment_length;
     VAR status: ost$status);

    VAR
      image_file_id: dft$image_file_id,
      local_status: ost$status;

    get_image_file (mainframe_id, dfc$read_image_file, image_file_id, status);
    IF status.normal THEN
      IF requested_preallocated_size > image_file_id.allocated_size THEN

{ need to increase the size of the file

        change_overflow_allowed (image_file_id.local_file_name, TRUE, local_status);
        mmp$os_preallocate_file_space (image_file_id.p_image_file, requested_preallocated_size,
             { wait secs } 60, status);
        IF status.normal THEN
          mmp$set_segment_length (image_file_id.p_image_file, { ring } 2, requested_preallocated_size,
                status);
        IFEND;
        IF NOT status.normal THEN
          display_integer (' Unable to preallocate server image space: ', requested_preallocated_size);
          log_display_integer ($pmt$ascii_logset [pmc$system_log],
                ' Unable to preallocate server image space: ', requested_preallocated_size);
          display_status (status);
          log_display_status ($pmt$ascii_logset [pmc$system_log], { format } TRUE, status);
        IFEND;
        change_overflow_allowed (image_file_id.local_file_name, FALSE, local_status);
      IFEND;
      return_image_file (image_file_id, local_status);
    IFEND;
  PROCEND increase_preallocated_size;
?? TITLE := 'Client: initialize_image_file ', EJECT ??

  PROCEDURE initialize_image_file
    (    server_mainframe_id: pmt$binary_mainframe_id;
         preallocation_size: ost$segment_length;
     VAR p_image_file: ^SEQ ( * ));

    VAR
      p_server_image_header: ^dft$image_header,
      status: ost$status;

    NEXT p_server_image_header IN p_image_file;
    p_server_image_header^.server_mainframe_id := server_mainframe_id;
    pmp$convert_binary_mainframe_id (server_mainframe_id, p_server_image_header^.server_mainframe_name,
          status);
    pmp$get_mainframe_id (p_server_image_header^.client_mainframe_name, status);
    p_server_image_header^.page_size := osv$page_size;

{ The segment length is used to determine the starting point to write
{ the first block header at.

    RESET p_image_file;
    p_server_image_header^.current_eoi := osv$page_size;
    p_server_image_header^.requested_preallocation_size := preallocation_size;
    p_server_image_header^.file_update_flag := dfc$image_file_writing;
    p_server_image_header^.version := dfc$current_image_file_version;

  PROCEND initialize_image_file;
?? TITLE := ' locate_last_block ', EJECT ??

{ If there is only one block this procedure returns NIL for
{ p_next_to_last_block.

  PROCEDURE locate_last_block
    (    image_file_id: dft$image_file_id;
     VAR p_next_to_last_block: ^dft$image_block_header;
     VAR p_block_header: ^dft$image_block_header);

    p_block_header := image_file_id.p_current_block_header;
    p_next_to_last_block := NIL;
    IF p_block_header = NIL THEN
      RETURN;
    IFEND;

  /while_still_blocks/
    WHILE p_block_header^.next_block_header_offset <> 0 DO
      p_next_to_last_block := p_block_header;
      p_block_header := #ADDRESS (#RING (p_block_header), #SEGMENT (p_block_header),
            p_block_header^.next_block_header_offset);
    WHILEND /while_still_blocks/;

  PROCEND locate_last_block;
?? TITLE := ' open_file_as_image', EJECT ??

{  This procedure is provided testing so that an image_file from a different
{ system or a dump (copy_memory)  may be displayed using the dfp$display_image_file
{ procedure.

  PROCEDURE open_file_as_image
    (    local_file_name: amt$local_file_name;
     VAR image_file_id: dft$image_file_id;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      segment_pointer: amt$segment_pointer;

    image_file_id.local_file_name := local_file_name;
    fsp$open_file (local_file_name, amc$segment, NIL, NIL, NIL, NIL, NIL, image_file_id.file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (image_file_id.file_id, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      fsp$close_file (image_file_id.file_id, local_status);
      RETURN;
    IFEND;
    image_file_id.p_image_file := segment_pointer.sequence_pointer;
    NEXT image_file_id.p_image_header IN image_file_id.p_image_file;
    i#build_adaptable_seq_pointer (#RING (image_file_id.p_image_file), #SEGMENT (image_file_id.p_image_file),
          image_file_id.p_image_header^.page_size, { Size } image_file_id.p_image_header^.page_size,
          { next } 0, image_file_id.p_current_block_seq);
    NEXT image_file_id.p_current_block_header IN image_file_id.p_current_block_seq;
    image_file_id.client := TRUE;
    image_file_id.operation := dfc$read_image_file;
  PROCEND open_file_as_image;
?? TITLE := 'Server: recover_served_file', EJECT ??

{  This server side procedure takes the eoi, and pages for a file and
{  writes them to the disk file.
{  Unlike normal recovery we will allow extending the users permanent file.
{  should the sft be locked - -even WHILE allocating??
{  We need TO  ALLOCATE because file may have been trimmed by recovery.
{  This does not yet deal with file damage.  Is it required?
{  The caller of this procedure assumes that the image file will be
{  be positioned after the last page for the file even if status is abnormal.
{

  PROCEDURE recover_served_file
    (    file_header: dft$image_file_header;
     VAR server_state: dft$server_state;
     VAR image_file_id: dft$image_file_id;
     VAR block_advanced: boolean;
     VAR pages_recovered: 0 .. osc$max_page_frames;
     VAR status: ost$status);

    VAR
      dfd_p: ^dmt$disk_file_descriptor,
      fde_found: boolean,
      file_entry_index: gft$file_descriptor_index,
      gfn_name: ost$name,
      local_status: ost$status,
      p_fde: gft$file_desc_entry_p,
      sfid: gft$system_file_identifier;

    status.normal := TRUE;
    block_advanced := FALSE;
    pages_recovered := 0;

    #SPOIL (server_state);
    IF server_state <> dfc$recovering THEN
      osp$set_status_condition (dfe$server_has_terminated, status);
      RETURN;
    IFEND;
    dmp$search_fdt_by_gfn (gfc$tr_system, file_header.global_file_name, file_entry_index, fde_found);
    IF fde_found THEN
      sfid.residence := gfc$tr_system;
      sfid.file_entry_index := file_entry_index;
      dmp$generate_gfn_hash (file_header.global_file_name, sfid.file_hash);
      gfp$get_fde_p (sfid, p_fde);
      dmp$get_disk_file_descriptor_p (p_fde, dfd_p);
    IFEND;

    IF (NOT file_header.file_completed) OR (NOT fde_found) OR (dfd_p^.purged) OR
          (p_fde^.attached_in_write_count = 0) THEN
      skip_pages_for_file (file_header, image_file_id, block_advanced);
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unknown_file, ' Not recoverable on server',
            status);
      IF dfv$file_server_debug_enabled THEN
        display (' Could not recover file ');
        display_boolean ('file_header.file_completed ', file_header.file_completed);
        display_boolean (' fde_found  ', fde_found);
        IF fde_found THEN
          display_boolean (' purged ', dfd_p^.purged);
          display_integer (' attached_in_write_count ', p_fde^.attached_in_write_count);
        IFEND;
      IFEND;
      RETURN;
    IFEND;

    IF (file_header.page_count > 0) THEN
      update_served_file_image (sfid, file_header, server_state, image_file_id, block_advanced,
            pages_recovered, status);
    IFEND;

    IF status.normal AND (file_header.eoi_byte_address <> p_fde^.eoi_byte_address) THEN
      IF dfv$file_server_debug_enabled THEN
        display_integer (' Setting eoi (current)', p_fde^.eoi_byte_address);
      IFEND;
      #SPOIL (server_state);
      IF server_state <> dfc$recovering THEN
        osp$set_status_condition (dfe$server_has_terminated, status);
        RETURN;
      IFEND;
      dmp$set_eoi (sfid, file_header.eoi_byte_address, status);
    IFEND;

  PROCEND recover_served_file;
?? TITLE := 'Client: recover_server_files', EJECT ??

{ Copy all pages for a particular server to the server image file.

  PROCEDURE recover_server_files
    (    server_mainframe_id: pmt$binary_mainframe_id;
         server_mainframe: pmt$mainframe_id;
         total_image_page_count: 0 .. osc$max_page_frames;
         old_image_pointers: dmt$old_image_pointers;
     VAR image_file_id: dft$image_file_id;
     VAR status: ost$status);

    VAR
      entry_index: gft$file_descriptor_index,
      image_segment_number: ost$segment,
      local_status: ost$status,
      msg_string: string (75),
      msg_string_length: integer,
      p_old_fde: gft$file_desc_entry_p,
      p_server_descriptor: dft$server_descriptor_p,
      pages_saved_for_file: 0 .. osc$max_page_frames,
      scan_control: gft$scan_all_fdes_state,
      server_files_not_recovered: gft$file_descriptor_index,
      server_files_recovered: gft$file_descriptor_index,
      server_pages_recovered: 0 .. osc$max_page_frames,
      sfid: gft$system_file_identifier;

    status.normal := TRUE;
    server_files_recovered := 0;
    server_files_not_recovered := 0;
    server_pages_recovered := 0;
    image_segment_number := old_image_pointers.old_wired_segment;

    gfp$scan_all_fdes_in_image (image_segment_number, scan_control, p_old_fde);

    WHILE p_old_fde <> NIL DO

    /recover_server_file_block/
      BEGIN

{ It is not necessary to lock the FDE in the image file: nobody else is using it at this point anyway.

        IF p_old_fde^.media <> gfc$fm_served_file THEN
          EXIT /recover_server_file_block/;
        IFEND;

        IF p_old_fde^.attached_in_write_count = 0 THEN
          EXIT /recover_server_file_block/;
        IFEND;

        IF p_old_fde^.eoi_byte_address = dfc$partially_rebuilt_fde_eoi THEN
          EXIT /recover_server_file_block/;
        IFEND;

        dfp$get_served_file_desc_p (p_old_fde, p_server_descriptor);
        IF p_server_descriptor^.header.server_mainframe_id <> server_mainframe_id THEN
          EXIT /recover_server_file_block/;
        IFEND;

        IF p_server_descriptor^.header.purged THEN
          EXIT /recover_server_file_block/;
        IFEND;

        IF p_server_descriptor^.header.file_state = dfc$terminated THEN
          EXIT /recover_server_file_block/;
        IFEND;

        save_server_file_image (p_old_fde, total_image_page_count, image_file_id, pages_saved_for_file,
              status);
        IF NOT status.normal THEN
          display_status (status);
          IF status.condition = dfe$no_space_for_server_pages THEN
            RETURN;
          ELSE
            server_files_not_recovered := server_files_not_recovered + 1;
            status.normal := TRUE;
            EXIT /recover_server_file_block/;
          IFEND;
        IFEND;

        server_files_recovered := server_files_recovered + 1;
        server_pages_recovered := server_pages_recovered + pages_saved_for_file;
      END /recover_server_file_block/;

      gfp$scan_all_fdes_in_image (0 {forces continuation of scan}, scan_control, p_old_fde);
    WHILEND;

    STRINGREP (msg_string, msg_string_length, ' Server ', server_mainframe, ' ', server_files_recovered,
          ' file(s) recovered');
    log_display ($pmt$ascii_logset [pmc$system_log], msg_string (1, msg_string_length));
    display (msg_string (1, msg_string_length));

    STRINGREP (msg_string, msg_string_length, ' Server ', server_mainframe, ' ', server_pages_recovered,
          ' page(s) recovered');
    log_display ($pmt$ascii_logset [pmc$system_log], msg_string (1, msg_string_length));
    display (msg_string (1, msg_string_length));

    STRINGREP (msg_string, msg_string_length, ' Server ', server_mainframe, ' ', server_files_not_recovered,
          ' file(s) not recovered');
    log_display ($pmt$ascii_logset [pmc$system_log], msg_string (1, msg_string_length));
    display (msg_string (1, msg_string_length));

    STRINGREP (msg_string, msg_string_length, ' Server ', server_mainframe, ' image size ',
          #OFFSET (image_file_id.p_current_eoi), ' bytes');
    log_display ($pmt$ascii_logset [pmc$system_log], msg_string (1, msg_string_length));
    display (msg_string (1, msg_string_length));
  PROCEND recover_server_files;
?? TITLE := 'Client: repair_image_file', EJECT ??

{ This  handles a failure when writing the server image file.

  PROCEDURE repair_image_file
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR image_file_id: dft$image_file_id;
     VAR status: ost$status);

    VAR
      p_last_block_header: ^dft$image_block_header,
      p_next_to_last_block: ^dft$image_block_header;

    status.normal := TRUE;
    IF image_file_id.p_image_header^.version <> dfc$current_image_file_version THEN
      display (' No recovery of server image possible. Unexpected image version:');
      log_display ($pmt$ascii_logset [pmc$system_log],
            ' No recovery of server image possible. Unexpected image version:');
      display (image_file_id.p_image_header^.version);
      log_display ($pmt$ascii_logset [pmc$system_log], image_file_id.p_image_header^.version);
      initialize_image_file (server_mainframe_id, { Preallocation } 0, image_file_id.p_image_file);
      RETURN;
    IFEND;

    IF image_file_id.p_image_header^.file_update_flag = dfc$image_file_valid THEN

{ Everything is fine.

    ELSEIF image_file_id.p_image_header^.file_update_flag = dfc$image_file_writing THEN
      display (' Recovery of server image file required.');
      log_display ($pmt$ascii_logset [pmc$system_log], ' Recovering of server image file required.');
      locate_last_block (image_file_id, p_next_to_last_block, p_last_block_header);
      display (' --- last block header ');
      display_block_header (p_last_block_header);
      display (' ---next to last block header ');
      display_block_header (p_next_to_last_block);
      IF p_last_block_header^.block_header_string <> dfc$block_header_string THEN
        display (' Previous failure - left unexpected image block string.');
        log_display ($pmt$ascii_logset [pmc$system_log],
              ' Previous failure - left unexpected image block string.');
        display (p_last_block_header^.block_header_string);
        log_display ($pmt$ascii_logset [pmc$system_log], p_last_block_header^.block_header_string);
        IF p_next_to_last_block = NIL THEN
          initialize_image_file (server_mainframe_id, { Preallocation } 0, image_file_id.p_image_file);
        ELSE
          p_next_to_last_block^.next_block_header_offset := 0;
          image_file_id.p_image_header^.current_eoi := #OFFSET (p_last_block_header);
          image_file_id.p_current_eoi := #ADDRESS (#RING (image_file_id.p_image_file),
                #SEGMENT (image_file_id.p_image_file), image_file_id.p_image_header^.current_eoi);
        IFEND;
      ELSE { Block header should be consistant
        CASE p_last_block_header^.page_source OF
        = dfc$image_source_deadstart =
          display (' Previous failure during continuation deadstart.');
          log_display ($pmt$ascii_logset [pmc$system_log], ' Previous failure during continuation deadstart.')
                ;

{       The failure occurred during continuation deadstart.
{       Al the pages will still be in the image.
{       Re-use the block.

          IF p_next_to_last_block = NIL THEN
            initialize_image_file (server_mainframe_id, { Preallocation } 0, image_file_id.p_image_file);
          ELSE
            p_next_to_last_block^.next_block_header_offset := 0;
            image_file_id.p_image_header^.current_eoi := #OFFSET (p_last_block_header);
            image_file_id.p_current_eoi := #ADDRESS (#RING (image_file_id.p_image_file),
                  #SEGMENT (image_file_id.p_image_file), image_file_id.p_image_header^.current_eoi);
          IFEND;

        = dfc$image_source_timeout =
          display (' Previous failure during timeout processing.');
          log_display ($pmt$ascii_logset [pmc$system_log], ' previous failure during timeout processing');

{ The server side flush process knows how to handle incomplete files so no need
{ to do anything.

        ELSE
          display (' Previous failure - left unexpected image block.');
          log_display ($pmt$ascii_logset [pmc$system_log], ' Previous failure - left unexpected image block.')
                ;
          IF p_next_to_last_block = NIL THEN
            initialize_image_file (server_mainframe_id, { Preallocation } 0, image_file_id.p_image_file);
          ELSE
            p_next_to_last_block^.next_block_header_offset := 0;
            image_file_id.p_image_header^.current_eoi := #OFFSET (p_last_block_header);
            image_file_id.p_current_eoi := #ADDRESS (#RING (image_file_id.p_image_file),
                  #SEGMENT (image_file_id.p_image_file), image_file_id.p_image_header^.current_eoi);
          IFEND;
        CASEND;
      IFEND;
    ELSE
      display (' No recovery of server image possible. Image file damaged');
      log_display ($pmt$ascii_logset [pmc$system_log],
            ' No recovery of server image possible. Image file damaged');
      display (image_file_id.p_image_header^.file_update_flag);
      initialize_image_file (server_mainframe_id, { Preallocation } 0, image_file_id.p_image_file);
    IFEND;
  PROCEND repair_image_file;
?? TITLE := 'Client: return_image_file', EJECT ??

  PROCEDURE return_image_file
    (VAR image_file_id: dft$image_file_id;
     VAR status: ost$status);

    image_file_id.p_image_header^.file_update_flag := dfc$image_file_valid;
    amp$close (image_file_id.file_id, status);
    amp$return (image_file_id.local_file_name, status);

  PROCEND return_image_file;

?? TITLE := 'Client: save_server_file_image', EJECT ??

  PROCEDURE save_server_file_image
    (    p_old_fde: gft$file_desc_entry_p;
         total_image_page_count: 0 .. osc$max_page_frames;
     VAR image_file_id: dft$image_file_id;
     VAR page_count: 0 .. osc$max_page_frames;
     VAR status: ost$status);

    VAR
      allocated_length: amt$file_byte_address,
      descriptor_list_index: 0 .. 7ffffffff(16),
      gfn_name: ost$name,
      image_page_description_p: ^mmt$image_page_description,
      message: string (80),
      message_length: integer,
      p_file_header: ^dft$image_file_header,
      p_page_header: ^dft$image_page_header;


    page_count := 0;
    NEXT p_file_header IN image_file_id.p_current_block_seq;
    IF p_file_header = NIL THEN
      dfp$get_next_image_block (image_file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      NEXT p_file_header IN image_file_id.p_current_block_seq;
    IFEND;

    p_file_header^.file_completed := FALSE;
    dfp$uncomplement_gfn (p_old_fde^.global_file_name, p_file_header^.global_file_name);
    p_file_header^.eoi_byte_address := p_old_fde^.eoi_byte_address;
    p_file_header^.page_count := 0;
    p_file_header^.highest_file_offset := 0;
    image_file_id.p_current_block_header^.file_count := image_file_id.p_current_block_header^.file_count + 1;
    status.normal := TRUE;

    IF (p_old_fde^.asti = 0) THEN
{ Still need to send eoi over despite this.
      p_file_header^.file_completed := TRUE;
      RETURN;
    IFEND;

    PUSH image_page_description_p: [1 .. total_image_page_count];
    mmp$fetch_pvas_of_image_pages (p_old_fde, image_page_description_p, status);
    IF NOT status.normal OR (image_page_description_p^.valid_desc_count = 0) THEN
      p_file_header^.file_completed := TRUE;
      RETURN;
    IFEND;

  /copy_all_pages/
    FOR descriptor_list_index := 1 TO image_page_description_p^.valid_desc_count DO

      NEXT p_page_header IN image_file_id.p_current_block_seq;
      IF p_page_header = NIL THEN
        dfp$get_next_image_block (image_file_id, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        NEXT p_page_header IN image_file_id.p_current_block_seq;
      IFEND;

      dfp$expand_image_file (image_file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      syp$hang_if_system_jrt_set (dfc$tjr_halt_save_server_image);

      i#move (image_page_description_p^.page_desc [descriptor_list_index].image_pva,
            image_file_id.p_current_eoi, image_page_description_p^. PAGESIZE);
      p_page_header^.image_offset := #OFFSET (image_file_id.p_current_eoi);
      p_page_header^.file_offset := image_page_description_p^.page_desc [descriptor_list_index].file_offset;
      image_file_id.p_current_block_header^.page_count := image_file_id.p_current_block_header^.page_count +
            1;
      p_file_header^.page_count := p_file_header^.page_count + 1;
      IF p_page_header^.file_offset > p_file_header^.highest_file_offset THEN
        p_file_header^.highest_file_offset := p_page_header^.file_offset;
      IFEND;
      image_file_id.p_current_eoi := #ADDRESS (#RING (image_file_id.p_current_eoi),
            #SEGMENT (image_file_id.p_current_eoi), #OFFSET (image_file_id.p_current_eoi) +
            image_page_description_p^. PAGESIZE);
      image_file_id.p_image_header^.current_eoi := #OFFSET (image_file_id.p_current_eoi);
      page_count := page_count + 1;
    FOREND /copy_all_pages/;

    p_file_header^.file_completed := TRUE;
  PROCEND save_server_file_image;
?? TITLE := ' skip_pages_for_file ', EJECT ??

  PROCEDURE skip_pages_for_file
    (    file_header: dft$image_file_header;
     VAR image_file_id: dft$image_file_id;
     VAR block_advanced: boolean);

    VAR
      p_page_header: ^dft$image_page_header,
      page: 0 .. osc$max_page_frames;

    block_advanced := FALSE;

  /for_all_pages_of_file/
    FOR page := 1 TO file_header.page_count DO
      NEXT p_page_header IN image_file_id.p_current_block_seq;
      IF p_page_header = NIL THEN
        block_advanced := TRUE;
        advance_to_next_block (image_file_id);
        NEXT p_page_header IN image_file_id.p_current_block_seq;
      IFEND;
    FOREND /for_all_pages_of_file/;

  PROCEND skip_pages_for_file;
?? TITLE := 'Client: terminate_unrecovered_files', EJECT ??

  PROCEDURE terminate_unrecovered_files
    (    server_mainframe: pmt$mainframe_id;
     VAR p_receive_data: dft$p_receive_data);

    VAR
      list_size: integer,
      msg_string: string (80),
      msg_string_length: integer,
      number_not_terminated: ost$non_negative_integers,
      number_terminated: ost$non_negative_integers,
      p_gfn_list: ^array [1 .. * ] of dmt$global_file_name;

    IF p_receive_data <> NIL THEN
      list_size := #SIZE (p_receive_data^) DIV #SIZE (dmt$global_file_name);
      NEXT p_gfn_list: [1 .. list_size] IN p_receive_data;
      dmp$terminate_server_file_list (p_gfn_list^, number_terminated, number_not_terminated);
      STRINGREP (msg_string, msg_string_length, ' Server ', server_mainframe, ' ', number_terminated,
            ' file(s) terminated');
      log_display ($pmt$ascii_logset [pmc$system_log], msg_string (1, msg_string_length));
      display (msg_string (1, msg_string_length));
      IF number_not_terminated > 0 THEN
        STRINGREP (msg_string, msg_string_length, ' Server ', server_mainframe, ' ', number_not_terminated,
              ' file(s) not found to terminate');
        log_display ($pmt$ascii_logset [pmc$system_log], msg_string (1, msg_string_length));
        display (msg_string (1, msg_string_length));
      IFEND;
    IFEND;
  PROCEND terminate_unrecovered_files;
?? TITLE := 'Server: update_served_file_image', EJECT ??

{  The caller of this assumes that the image file is positioned AFTER the
{ last page for the file even is status is abnormal.

  PROCEDURE update_served_file_image
    (    sfid: gft$system_file_identifier;
         file_header: dft$image_file_header;
     VAR server_state: dft$server_state;
     VAR image_file_id: dft$image_file_id;
     VAR block_advanced: boolean;
     VAR pages_recovered: 0 .. osc$max_page_frames;
     VAR status: ost$status);

?? NEWTITLE := 'abort_handler', EJECT ??

{
{  This procedure is intended to catch aborts in writing to the users
{ permanent file.  Possible conditions include write errors or an
{ unavailable volume.
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      display (' --- update_served_file_image abort_handler ');
      CASE condition.selector OF
      = mmc$segment_access_condition =
        osp$set_status_from_condition (dfc$file_server_id, condition, save_area, status, handler_status);
        display_status (status);
        EXIT update_served_file_image;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$get_condition_status (condition_information, status);
          display_status (status);
          EXIT update_served_file_image;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE ??
?? SKIP := 6 ??

    VAR
      cell_pointer: mmt$segment_pointer,
      free_pages_status: ost$status,
      local_status: ost$status,
      p_data: ^cell,
      p_file: ^cell,
      p_page_header: ^dft$image_page_header,
      page: 0 .. osc$max_page_frames;

    osp$establish_condition_handler (^abort_handler, FALSE);

    allocate_file_space (sfid, file_header, server_state, status);
    IF NOT status.normal THEN
      skip_pages_for_file (file_header, image_file_id, block_advanced);
      RETURN;
    IFEND;

    cell_pointer.kind := mmc$cell_pointer;
    dmp$open_file (sfid, osc$tsrv_ring, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential,
          cell_pointer, status);
    IF NOT status.normal THEN
      skip_pages_for_file (file_header, image_file_id, block_advanced);
      RETURN;
    IFEND;

    p_file := cell_pointer.cell_pointer;

  /write_all_pages_of_file/
    FOR page := 1 TO file_header.page_count DO
      #SPOIL (server_state);
      IF server_state <> dfc$recovering THEN
        osp$set_status_condition (dfe$server_has_terminated, status);
        RETURN;
      IFEND;
      NEXT p_page_header IN image_file_id.p_current_block_seq;
      IF p_page_header = NIL THEN
        IF dfv$file_server_debug_enabled THEN
          display (' --- Pages for a file crossing block boundary ');
        IFEND;
        block_advanced := TRUE;
        advance_to_next_block (image_file_id);
        NEXT p_page_header IN image_file_id.p_current_block_seq;
      IFEND;
      p_data := #ADDRESS (#RING (image_file_id.p_current_block_header),
            #SEGMENT (image_file_id.p_current_block_header), p_page_header^.image_offset);
      p_file := #ADDRESS (#RING (p_file), #SEGMENT (p_file), p_page_header^.file_offset);
      IF dfv$file_server_debug_enabled THEN
        display_pva (' Source ', p_data);
        display_pva (' Destination ', p_file);
        display_integer (' page size ', image_file_id.p_image_header^.page_size);
      IFEND;
      i#move (p_data, p_file, image_file_id.p_image_header^.page_size);
    FOREND /write_all_pages_of_file/;

    pages_recovered := file_header.page_count;

    IF file_header.page_count > 0 THEN
{
{ Write out and free ALL pages which were updated from the image file.  Use the largest size possible, in case
{ there has been some streaming of pages.  (
{
      mmp$write_modified_pages (cell_pointer.cell_pointer, 7fffffff(16), osc$wait, status);
      mmp$free_pages (cell_pointer.cell_pointer, 7fffffff(16), {not used:} osc$nowait, free_pages_status);
      IF status.normal AND NOT free_pages_status.normal THEN
        status := free_pages_status;
      IFEND;
    IFEND;

    dmp$close_file (p_file, local_status);
  PROCEND update_served_file_image;
?? OLDTITLE ??
MODEND dfm$manage_image;

*DECK DECK=DFM$MANAGE_SEGMENT_STATE EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := ' NOS/VE File Server: Client: Manage segment state', EJECT ??
MODULE dfm$manage_segment_state;

{
{  This module contains code used by the monitor.
{  This contains the processes involoved with setting the access state for
{  a server file.   This code is executing during initial detection of the
{  server that timed out, and also as a result of delayed swap in work.

?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dft$mainframe_set
*copyc dft$server_descriptor
*copyc gft$system_file_identifier
*copyc ost$execution_control_block
*copyc tmt$fnx_search_type
?? POP ??
*copyc dfi$monitor_display
*copyc dfp$locate_server_translation
*copyc dfp$get_served_file_desc_p
*copyc gfp$mtr_get_fde_p
*copyc jsp$set_delayed_swapin_work_mtr
*copyc mmp$purge_all_page_seg_map
*copyc mmp$get_max_sdt_sdtx_pointer
*copyc tmp$find_next_xcb

*copyc dfv$file_server_debug_enabled
*copyc jmv$null_ijl_ordinal

{ dfv$gary is used as a test vehicle to control
{ whether the ASID in the SDTX should be cleared when the
{ inhibit_access is set.
{ For as yet unknown reason NOT clearing this causes a different
{ path to be executed.
{ The default value is to NOT clear this since comvert_pva will
{ stick a value back in.

 VAR
  dfv$gary : [XDCL, #GATE] boolean := TRUE;

?? TITLE := '  [XDCL] dfp$clear_task_inhibit_access ', EJECT ??
{
{   This procedure clearing the inhibit_access in the
{ access_state of the sdtx for all tasks in the job.
{

  PROCEDURE [XDCL] dfp$clear_task_inhibit_access
    (    search: tmt$fnx_search_type;
         ijle_p: ^jmt$initiated_job_list_entry;
         ijlo: jmt$ijl_ordinal;
         clear_inhibit_access_work: dft$mainframe_set);

    VAR
      fde_p: gft$file_desc_entry_p,
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      segment_number: ost$segment,
      server_mainframe: boolean,
      server_translation_ordinal: 1 .. dfc$max_number_of_mainframes,
      terminated_file: boolean,
      xcb_p: ^ost$execution_control_block,
      xcb_state: tmt$find_next_xcb_state;

    tmp$find_next_xcb (search, ijle_p, ijlo, xcb_state, xcb_p);

  /for_all_tasks/
    WHILE xcb_p <> NIL DO

      mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);

    /for_all_segments/
      FOR segment_number := 0 TO xcb_p^.xp.segment_table_length DO
        IF (sdt_p^.st [segment_number].ste.vl = osc$vl_invalid_entry) OR
              (sdtx_p^.sdtx_table [segment_number].sfid.residence <> gfc$tr_system) THEN
          CYCLE /for_all_segments/;
        IFEND;

        gfp$mtr_get_fde_p (sdtx_p^.sdtx_table [segment_number].sfid, NIL, fde_p);
        IF fde_p^.media <> gfc$fm_served_file THEN
          CYCLE /for_all_segments/;
        IFEND;

        IF sdtx_p^.sdtx_table [segment_number].access_state <> mmc$sas_inhibit_access THEN
          CYCLE /for_all_segments/;
        IFEND;

        get_file_location (fde_p, server_mainframe, server_translation_ordinal, terminated_file);
        IF server_mainframe THEN
          IF terminated_file THEN

{ This should not happen, but just in case clean up the SDTX.

            sdtx_p^.sdtx_table [segment_number].access_state := mmc$sas_terminate_access;
          ELSEIF (server_translation_ordinal IN clear_inhibit_access_work) THEN
            sdtx_p^.sdtx_table [segment_number].access_state := mmc$sas_allow_access;
          IFEND;
        IFEND;
      FOREND /for_all_segments/;
      tmp$find_next_xcb (tmc$fnx_continue, NIL, jmv$null_ijl_ordinal, xcb_state, xcb_p);
    WHILEND /for_all_tasks/;

  PROCEND dfp$clear_task_inhibit_access;
?? TITLE := '  [XDCL] dfp$set_task_segment_state ', EJECT ??
*copyc dfh$set_task_segment_state
{ NOTE: It is not of any use to clear the asid in the sdtx here.
{       convert_pva will store the asid back in.
{
  PROCEDURE [XDCL] dfp$set_task_segment_state
    (    search: tmt$fnx_search_type;
         ijle_p: ^jmt$initiated_job_list_entry;
         ijlo: jmt$ijl_ordinal;
         inhibit_access_work: dft$mainframe_set;
         terminate_access_work: dft$mainframe_set);

    VAR
      delayed_swapin_work_record: jmt$delayed_swapin_work_record,
      fde_p: gft$file_desc_entry_p,
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      segment_number: ost$segment,
      server_mainframe: boolean,
      server_translation_ordinal: 1 .. dfc$max_number_of_mainframes,
      terminated_file: boolean,
      xcb_p: ^ost$execution_control_block,
      xcb_state: tmt$find_next_xcb_state;

    tmp$find_next_xcb (search, ijle_p, ijlo, xcb_state, xcb_p);

  /for_all_tasks/
    WHILE xcb_p <> NIL DO

      mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);

    /for_all_segments/
      FOR segment_number := 0 TO xcb_p^.xp.segment_table_length DO
        IF (sdt_p^.st [segment_number].ste.vl = osc$vl_invalid_entry) OR
              (sdtx_p^.sdtx_table [segment_number].access_state = mmc$sas_terminate_access) OR
              (sdtx_p^.sdtx_table [segment_number].sfid.residence <> gfc$tr_system) THEN
          CYCLE /for_all_segments/;
        IFEND;

        gfp$mtr_get_fde_p (sdtx_p^.sdtx_table [segment_number].sfid, NIL, fde_p);
        IF fde_p^.media <> gfc$fm_served_file THEN
          CYCLE /for_all_segments/;
        IFEND;

        get_file_location (fde_p, server_mainframe, server_translation_ordinal, terminated_file);
        IF server_mainframe THEN
          IF server_translation_ordinal IN inhibit_access_work THEN
            IF NOT dfv$gary THEN
              sdt_p^.st [segment_number].ste.asid := 0;
            IFEND;
            sdtx_p^.sdtx_table [segment_number].access_state := mmc$sas_inhibit_access;
          IFEND;
          IF (server_translation_ordinal IN terminate_access_work) OR terminated_file THEN
            IF NOT dfv$gary THEN
              sdt_p^.st [segment_number].ste.asid := 0;
            IFEND;
            sdtx_p^.sdtx_table [segment_number].access_state := mmc$sas_terminate_access;
          IFEND;
        IFEND;
      FOREND /for_all_segments/;
      tmp$find_next_xcb (tmc$fnx_continue, NIL, jmv$null_ijl_ordinal, xcb_state, xcb_p);
    WHILEND /for_all_tasks/;

    IF search = tmc$fnx_system THEN
      delayed_swapin_work_record.delayed_swapin_work :=
            $jmt$delayed_swapin_work [jmc$dsw_update_server_files];
      delayed_swapin_work_record.terminate_access_work := terminate_access_work;
      delayed_swapin_work_record.inhibit_access_work := inhibit_access_work;
      jsp$set_delayed_swapin_work_mtr (delayed_swapin_work_record);
    IFEND;

   IF NOT dfv$gary THEN
     { Only if the asid is cleared is this required.
     mmp$purge_all_page_seg_map;
   IFEND;

  PROCEND dfp$set_task_segment_state;
?? TITLE := '  [XDCL] dfp$verify_segments_recovered ', EJECT ??
{
{   This procedure is run at the end of server job recovery to verify that all
{ files were recovered.  Any file not recovered will be marked as terminated.
{
  PROCEDURE [XDCL] dfp$verify_segments_recovered
    (    search: tmt$fnx_search_type;
         ijle_p: ^jmt$initiated_job_list_entry;
         ijlo: jmt$ijl_ordinal;
         recovered_work: dft$mainframe_set);

    VAR
      fde_p: gft$file_desc_entry_p,
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      segment_number: ost$segment,
      server_mainframe: boolean,
      server_translation_ordinal: 1 .. dfc$max_number_of_mainframes,
      terminated_file: boolean,
      xcb_p: ^ost$execution_control_block,
      xcb_state: tmt$find_next_xcb_state;

    tmp$find_next_xcb (search, ijle_p, ijlo, xcb_state, xcb_p);

  /for_all_tasks/
    WHILE xcb_p <> NIL DO

      mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);

    /for_all_segments/
      FOR segment_number := 0 TO xcb_p^.xp.segment_table_length DO
        IF (sdt_p^.st [segment_number].ste.vl = osc$vl_invalid_entry) OR
              (sdtx_p^.sdtx_table [segment_number].access_state <> mmc$sas_inhibit_access) OR
              (sdtx_p^.sdtx_table [segment_number].sfid.residence <> gfc$tr_system) THEN
          CYCLE /for_all_segments/;
        IFEND;

        gfp$mtr_get_fde_p (sdtx_p^.sdtx_table [segment_number].sfid, NIL, fde_p);
        IF fde_p^.media <> gfc$fm_served_file THEN
          CYCLE /for_all_segments/;
        IFEND;

        get_file_location (fde_p, server_mainframe, server_translation_ordinal, terminated_file);
        IF server_mainframe AND ((server_translation_ordinal IN recovered_work) OR terminated_file) THEN
          IF dfv$file_server_debug_enabled THEN
            display_integer_monitor (' Terminated unrecovered segment ', segment_number);
          IFEND;
          sdtx_p^.sdtx_table [segment_number].access_state := mmc$sas_terminate_access;
        IFEND;
      FOREND /for_all_segments/;
      tmp$find_next_xcb (tmc$fnx_continue, NIL, ijlo, xcb_state, xcb_p);
    WHILEND /for_all_tasks/;

  PROCEND dfp$verify_segments_recovered;
?? TITLE := '  [INLINE] get_file_location ', EJECT ??

  PROCEDURE [INLINE] get_file_location
    (    fde_p: gft$file_desc_entry_p;
     VAR server_mainframe: boolean;
     VAR server_translation_ordinal: 1 .. dfc$max_number_of_mainframes;
     VAR terminated_file: boolean);

    VAR
      server_descriptor_p: dft$server_descriptor_p;

    dfp$get_served_file_desc_p (fde_p, server_descriptor_p);
    dfp$locate_server_translation (server_descriptor_p^.header.server_mainframe_id,
          server_translation_ordinal, server_mainframe);
    terminated_file := server_descriptor_p^.header.file_state = dfc$terminated;

  PROCEND get_file_location;
?? OLDTITLE, OLDTITLE ??
MODEND dfm$manage_segment_state;
*DECK DECK=DFM$MANAGE_SERVER_CONNECTION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: Client: Asynchronous Connection Manager', EJECT ??
MODULE dfm$manage_server_connection;

{==============================================================================
{
{  This module is an asynchronous task running on the Client and managing the
{  connection with the DF Server mainframe. This includes reacting to the
{  operator's commands:
{     Activate_Server
{     Deactivate_Server
{     Define_Served_Family
{     Terminate_Server
{
{  as well as sending periodic polls to the Server, processing its poll
{  replies, and timing out the user requests.
{
{
{  The operator requests come to this task indirectly: the various action
{  signals are set in the CPU_Queue header (Partner_Status record) by the
{  command processors and this task acts upon them.
{  One of the signals (Deactivate_Server) may come from the Server as a
{  result of a subcommand by the operator of the Server mainframe.
{  dfm$manage_server_connection will treat it as if it came from the
{  native operator.
{
{  Abnormal conditions will cause dfm$manage_server_connection to abort
{  the connection with the Server and to terminate or timeout itself.
{  Such conditions
{  include: garbled poll replies from the Server, repeated time-outs of
{  of the same request (either user or poll), and negative reply to the
{  attempt to verify Server Queue definition. A negative reply to
{  Verify_Family request, however, does not however cause an abort. The
{  Family will remain inaccessible to the users in this case.
{
{  Additionally this procedure detects timeout and termination detected
{  from monitor mode.
{==============================================================================

?? NEWTITLE := '    Global Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$scan_parameter_list
*copyc dfc$poll_constants
*copyc dfc$test_jr_constants
*copyc dfd$driver_queue_types
*copyc dfd$request_package
*copyc dfe$error_condition_codes
*copyc dfi$display
*copyc dfi$log_display
*copyc dfp$attach_application_library
*copyc dfp$change_family_server_state
*copyc dfp$change_family_verification
*copyc dfp$change_job_leveler_state
*copyc dfp$crack_mainframe_id
*copyc dfp$delete_family_if_last
*copyc dfp$execute_state_change_task
*copyc dfp$find_mainframe_id
*copyc dfp$format_task_name
*copyc dfp$format_verify_family
*copyc dfp$free_image_file
*copyc dfp$get_highest_sf_lifetime
*copyc dfp$get_queue_directory_index
*copyc dfp$queue_task_request
*copyc dfp$load_pp_if_first
*copyc dfp$register_served_families
*copyc dfp$reset_mainframe_tables
*copyc dfp$return_application_library
*copyc dfp$term_requests_to_server
*copyc dfp$timeout_requests_to_server
*copyc dfp$timeout_server_files
*copyc dfp$unload_pp_if_last
*copyc dfp$verify_system_administrator
*copyc dfp$await_all_queue_entrys_free
*copyc dfp$word_boundary
*copyc dft$command_buffer
*copyc dft$cpu_queue
*copyc dft$display_identifier
*copyc dft$entry_type
*copyc dft$family_list
*copyc dft$poll_family_list
*copyc dft$poll_header
*copyc dft$poll_message
*copyc dft$poll_queue_information
*copyc dft$procedure_address_ordinal
*copyc dft$queue_index
*copyc dft$queue_interface_directory
*copyc dft$rb_file_server_request
*copyc dfv$display_poll
*copyc dfv$file_server_debug_enabled
*copyc dfv$poll_type_string
*copyc dfv$send_command_flags
*copyc dfv$job_recovery_enabled
*copyc i#call_monitor
*copyc i#current_sequence_position
*copyc jmp$ready_job_leveler_task
*copyc ofd$type_definition
*copyc ose$system_task_exceptions
*copyc osp$append_status_parameter
*copyc osp$deactivate_system_task
*copyc osp$format_message
*copyc osp$get_cause_of_idle
*copyc osp$set_status_abnormal
*copyc osp$set_system_task_restart
*copyc osp$system_error
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc osv$task_shared_heap
*copyc pmd$system_log_interface
*copyc pmp$compute_time_dif_in_seconds
*copyc pmp$exit
*copyc pmp$execute
*copyc pmp$get_compact_date_time
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_mainframe_id
*copyc pmp$get_time
*copyc pmp$wait
*copyc pmt$binary_mainframe_id
*copyc pmt$mainframe_id
*copyc pmt$program_description
*copyc syp$hang_if_system_jrt_set
*copyc syp$invoke_system_debugger
?? POP ??

  CONST
    get_remote_app_start_proc = 'DFP$REQUEST_REMOTE_APP_INFO',
    idle_task_start_proc = 'DFP$IDLE_REQUESTS_TO_SERVER',
    recovery_task_start_proc = 'DFP$RECOVER_REQUESTS_TO_SERVER',
    verify_jobs_task_start_proc = 'DFP$VERIFY_CLIENT_JOBS';

  VAR
    dfv$p_get_app_info_status: [XDCL, oss$task_shared] ^pmt$task_status := NIL,
    dfv$p_idle_task_status: [XDCL, oss$task_shared] ^pmt$task_status := NIL,
    dfv$p_recovery_task_status: [XDCL, oss$task_shared] ^pmt$task_status := NIL,
    dfv$p_verify_jobs_task_status: [XDCL, oss$task_shared] ^pmt$task_status := NIL;

  VAR
    transaction_state_string: [READ, oss$job_paged_literal] array
          [dfc$null_state .. dfc$server_waiting_request] of string (26) := [
          { } 'null_state',
          { } 'queue_entry_available',
          { } 'queue_entry_assigned',
          { } 'request_queued',
          { } 'request_sent',
          { } 'server_must_read_page_data',
          { } 'server_received_request',
          { } 'server_sent_response',
          { } 'client_must_read_page_data',
          { } 'response_received',
          { } 'media_error',
          { } 'message_content_error',
          { } 'server_waiting_request'];

*copyc osv$os_defaults
*copyc osv$page_size

?? TITLE := '    dfp$manage_server_connection', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$manage_server_connection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{     pdt manage_server_con_pdt (
{         mainframe_name: name pmc$mainframe_id_size = $required
{         status)

?? PUSH (LISTEXT := ON) ??

    VAR
      manage_server_con_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^manage_server_con_pdt_names, ^manage_server_con_pdt_params];

    VAR
      manage_server_con_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of
            clt$parameter_name_descriptor := [['MAINFRAME_NAME', 1], ['STATUS', 2]];

    VAR
      manage_server_con_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ MAINFRAME_NAME

      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$name_value, pmc$mainframe_id_size, pmc$mainframe_id_size]],

{ STATUS

      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id,
      message_length: integer,
      start_message: string (80),
      task_name: ost$name;

    dfp$verify_system_administrator ('MANAGE_SERVER_CONNECTION', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, manage_server_con_pdt, status);
    IF NOT status.normal THEN
      send_status_to_operator (status);
      RETURN;
    IFEND;
    dfp$crack_mainframe_id ('MAINFRAME_NAME', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      send_status_to_operator (status);
      RETURN;
    IFEND;

    dfp$format_task_name (mainframe_name, task_name);
    osp$set_system_task_restart (task_name, { restart } FALSE, status);

    STRINGREP (start_message, message_length, ' Task ', task_name, ' running.');
    display (start_message (1, message_length));
    log_display ($pmt$ascii_logset[pmc$system_log], start_message (1,message_length));
    dfp$determine_server_status (mainframe_name, status);

  PROCEND dfp$manage_server_connection;

?? TITLE := '    dfp$determine_server_status', EJECT ??

  PROCEDURE dfp$determine_server_status
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

     CONST
       seconds_per_hour = 3600;

    VAR
      all_queue_entries_free: boolean,
      family_container: SEQ (REP dfc$max_family_parameters of dft$family_verification),
      mainframe_found: boolean,
      mainframe_id: pmt$binary_mainframe_id,
      message_length: integer,
      operator_message: string (79),
      max_verify_jobs_count_down: 0 .. seconds_per_hour,
      number_of_families: 0 .. dfc$max_family_parameters,
      p_cpu_queue: ^dft$cpu_queue,
      p_family_list: ^dft$poll_family_list,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: ^dft$queue_interface_table,
      poll_header: dft$poll_header,
      queue_directory_index: dft$queue_directory_index,
      queue_index: dft$queue_index,
      reply_received: boolean,
      server_name: pmt$mainframe_id,
      server_to_client: boolean,
      time_after_wait: integer,
      time_before_wait: integer,
      verify_jobs_count_down: 0 .. seconds_per_hour,
      wait_time: integer;

    server_to_client := FALSE;
    dfp$find_mainframe_id (mainframe_name, server_to_client, mainframe_found, p_queue_interface_table,
          p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, mainframe_name, status);
      system_error ('INCORRECT SERVER MAINFRAME_ID IN ASYNCH TASK', ^status);
      pmp$exit (status);
    IFEND;
    pmp$get_executing_task_gtid (p_cpu_queue^.queue_entries [dfc$poll_queue_index].global_task_id);
    pmp$get_mainframe_id (poll_header.mainframe_name, status);
    server_name := mainframe_name;
    mainframe_id := p_cpu_queue^.queue_header.destination_mainframe_id;
    dfp$get_queue_directory_index (p_queue_interface_table, queue_directory_index);
    wait_time := p_cpu_queue^.queue_header.timeout_interval DIV 1000;
    max_verify_jobs_count_down := (seconds_per_hour * 1000) DIV wait_time;
    verify_jobs_count_down := 1; {Allow first poll to complete
    dfp$attach_application_library (p_cpu_queue);

  /poll_loop/
    WHILE TRUE DO
      #SPOIL (p_cpu_queue^.queue_header.partner_status);
      syp$hang_if_system_jrt_set (dfc$tjr_determine_server_status);

      IF p_cpu_queue^.queue_header.partner_status.terminate_partner THEN
        terminate_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
              { restart } FALSE);
      ELSEIF p_cpu_queue^.queue_header.partner_status.timeout_partner THEN

{ Monitor has indicated a destination mainframe down and
{ is using this flag to indicate to timeout.

        timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name, { RESTART}
             FALSE);
      ELSE
        CASE p_cpu_queue^.queue_header.partner_status.server_state OF

        = dfc$inactive =
          IF p_cpu_queue^.queue_header.partner_status.verify_queue THEN
            pmp$get_executing_task_gtid (p_cpu_queue^.queue_entries [dfc$poll_queue_index].
                  global_task_id);
            poll_header.poll_type := dfc$verify_queue;
            send_verify_queue (p_cpu_queue, queue_index, p_queue_interface_table, poll_header,
                  p_q_interface_directory_entry, server_name, family_container, number_of_families);
          IFEND;

        = dfc$terminated, dfc$awaiting_recovery =
          IF p_cpu_queue^.queue_header.partner_status.verify_queue THEN
            poll_header.poll_type := dfc$verify_queue;
            send_verify_queue (p_cpu_queue, queue_index, p_queue_interface_table, poll_header,
                  p_q_interface_directory_entry, server_name, family_container, number_of_families);
          ELSE
            system_error ('SERVER STATE = TERM/AREC , NO VERIFY_QUEUE, AND ASYNCH RUNNING', NIL);
            timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name, FALSE);
          IFEND;

        = dfc$recovering =
          IF p_cpu_queue^.queue_header.partner_status.recovery_complete THEN
            poll_header.poll_type := dfc$recovery_complete;
          ELSE
            poll_header.poll_type := dfc$normal_poll;
          IFEND;
          issue_server_poll (p_cpu_queue, queue_index, p_queue_interface_table, poll_header,
                {p_poll_family_list=} NIL, {p_poll_queue_information=} NIL);

        = dfc$deactivated =
          IF p_cpu_queue^.queue_header.partner_status.deactivate_complete THEN
            dfp$await_all_queue_entrys_free (p_cpu_queue, { Maximum wait }
                15000 { 15 seconds }, all_queue_entries_free);
            IF NOT all_queue_entries_free THEN
              STRINGREP (operator_message, message_length, ' Server ', mainframe_name,
               ' would not turn Inactive due to outstanding requests. Force timeout.');
              display (operator_message (1, message_length));
              log_display ($pmt$ascii_logset[pmc$system_log],
                    operator_message (1,message_length));
              timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, mainframe_name,
                    { restart } FALSE);
              { There is no return from timeout_task
            IFEND;
            poll_header.poll_type := dfc$deactivate_complete;
            issue_server_poll (p_cpu_queue, queue_index, p_queue_interface_table, poll_header,
                  {p_poll_family_list=} NIL, {p_poll_queue_information=} NIL);
            STRINGREP (operator_message, message_length, ' Server ', mainframe_name, ' turned Inactive.');
            display (operator_message (1, message_length));
            log_display ($pmt$ascii_logset[pmc$system_log],
                  operator_message (1,message_length));
            p_cpu_queue^.queue_header.partner_status.deactivate_complete := FALSE;
            p_cpu_queue^.queue_header.partner_status.server_state := dfc$inactive;
            verify_jobs_count_down := 1; {Allow first poll to complete
            dfp$change_family_server_state (dfc$inactive, mainframe_id);
            dfp$unload_pp_if_last (^dfv$p_queue_interface_directory^ [queue_directory_index], queue_index,
                  status);
            IF NOT status.normal THEN
              send_status_to_operator (status);
              timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, mainframe_name,
                    { restart } FALSE);
            IFEND;
            dfp$execute_state_change_task (mainframe_name, { partner_is_server } TRUE, dfc$deactivated,
                  dfc$inactive, osc$wait, status);
          IFEND;

        = dfc$active =
          p_family_list := NIL;
          number_of_families := 0;
          IF p_cpu_queue^.queue_header.partner_status.verify_family AND
                (p_cpu_queue^.queue_header.number_of_monitor_queue_entries = 0) THEN
            p_cpu_queue^.queue_header.partner_status.verify_family := FALSE;
          IFEND;
          IF p_cpu_queue^.queue_header.partner_status.send_deactivate_partner THEN
            poll_header.poll_type := dfc$deactivate_server;

          ELSEIF p_cpu_queue^.queue_header.partner_status.verify_family THEN
            poll_header.poll_type := dfc$verify_served_family;
            dfp$format_verify_family (p_cpu_queue^.queue_header.destination_mainframe_id, family_container,
                  number_of_families, p_family_list);


          ELSE {normal poll}
            IF verify_jobs_count_down = 0 THEN
              verify_jobs_count_down := max_verify_jobs_count_down;
              IF (dfv$p_verify_jobs_task_status = NIL) OR
                    dfv$p_verify_jobs_task_status^.complete THEN
                execute_verify_jobs_task (mainframe_name, status);
                IF NOT status.normal THEN
                  send_status_to_operator (status);
                  timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, mainframe_name,
                        { restart } FALSE);
                IFEND;
              IFEND;
            ELSE
              verify_jobs_count_down := verify_jobs_count_down - 1;
            IFEND;
            IF dfv$p_get_app_info_status = NIL THEN
              dfp$execute_get_app_info (mainframe_name, status);
              IF NOT status.normal THEN
                send_status_to_operator (status);
                log_display_status ($pmt$ascii_logset [pmc$job_log, pmc$system_log], FALSE, status);
                status.normal := TRUE;
              IFEND;
            IFEND;
            poll_header.poll_type := dfc$normal_poll;
          IFEND;

          issue_server_poll (p_cpu_queue, queue_index, p_queue_interface_table, poll_header, p_family_list,
                {p_poll_queue_information=} NIL);
          IF poll_header.poll_type = dfc$deactivate_server THEN
            p_cpu_queue^.queue_header.partner_status.send_deactivate_partner := FALSE;
            p_cpu_queue^.queue_header.partner_status.server_state := dfc$deactivated;
            dfp$change_family_server_state (dfc$deactivated, mainframe_id);
            execute_idle_task (mainframe_name, status);
            { State change procedure called within idle task.
            IF NOT status.normal THEN
              send_status_to_operator (status);
              timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, mainframe_name,
                    { restart } FALSE);
            IFEND;
          IFEND;
        ELSE
          system_error ('BAD SERVER STATE IN ASYNCH TASK -TERMINATING', NIL);
          { The state of the server is confused so it's best to terminate and start over.
          terminate_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                { restart } FALSE);
        CASEND;
      IFEND;

{ Note:
{   Process_poll_reply may have changed the state since the initial check above.

      #SPOIL (p_cpu_queue^.queue_header.partner_status.server_state);

      CASE p_cpu_queue^.queue_header.partner_status.server_state OF
      = dfc$active, dfc$deactivated, dfc$recovering =

        reply_received := FALSE;

      /wait_for_reply/
        REPEAT
          time_before_wait := #FREE_RUNNING_CLOCK (0);
          pmp$wait (wait_time, wait_time);
          determine_wakeup_cause (p_cpu_queue, queue_index, p_queue_interface_table, time_before_wait,
                server_name, reply_received);
          time_out_requests (p_cpu_queue, queue_index, p_queue_interface_table, server_name);
        UNTIL reply_received;

      = dfc$inactive =

        IF p_cpu_queue^.queue_header.partner_status.verify_queue THEN
          determine_wakeup_cause (p_cpu_queue, queue_index, p_queue_interface_table, time_before_wait,
                server_name, reply_received);
        ELSE
          time_before_wait := #FREE_RUNNING_CLOCK (0);
          pmp$wait (wait_time, wait_time);
        IFEND;

      = dfc$terminated, dfc$awaiting_recovery =
        time_before_wait := #FREE_RUNNING_CLOCK (0);
        determine_wakeup_cause (p_cpu_queue, queue_index, p_queue_interface_table, time_before_wait,
              server_name, reply_received);

      ELSE
        system_error ('BAD SERVER STATE IN ASYNCH TASK -TERMINATING', NIL);
        { The state of the server is confused so it's best to terminate and start over.
        terminate_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
               { restart } FALSE);
      CASEND;

    WHILEND /poll_loop/;

  PROCEND dfp$determine_server_status;

?? TITLE := '      build_queue_info_record ', EJECT ??

  PROCEDURE build_queue_info_record
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table;
     VAR queue_information: dft$poll_queue_information);

    VAR
      family_found: boolean,
      p_driver_header: ^dft$driver_queue_header,
      server_birthdate: integer,
      server_lifetime: dft$server_lifetime,
      server_state: dft$server_state,
      status: ost$status;

    status.normal := TRUE;
    queue_information.status.normal := TRUE;

{   ---------------------------------
{   queue_information from cpu_table.
{   ---------------------------------

    queue_information.destination_mainframe_name := p_cpu_queue^.queue_header.destination_mainframe_name;
    queue_information.number_of_monitor_queue_entries := p_cpu_queue^.queue_header.
          number_of_monitor_queue_entries;
    queue_information.number_of_task_queue_entries := p_cpu_queue^.queue_header.number_of_task_queue_entries;
    queue_information.timeout_interval := p_cpu_queue^.queue_header.timeout_interval;
    queue_information.maximum_timeout_count := p_cpu_queue^.queue_header.maximum_request_timeout_count;
    queue_information.maximum_retransmission_count := p_cpu_queue^.queue_header.maximum_retransmission_count;

{   ---------------------------------------------
{   queue_information from queue_interface_table.
{   ---------------------------------------------

    queue_information.esm_base_addresses := p_queue_interface_table^.esm_base_addresses;

{   -------------------------------------------
{   queue_information from driver_queue_header.
{   -------------------------------------------

    p_driver_header := ^p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue^.queue_header;
    queue_information.driver_number_of_queue_entries := p_driver_header^.number_of_queue_entries;
    queue_information.driver_source_id_number := p_driver_header^.connection_descriptor.source.id_number;
    queue_information.driver_source_queue_index := p_driver_header^.connection_descriptor.source.queue_index;
    queue_information.driver_destination_id_number := p_driver_header^.connection_descriptor.destination.
          id_number;
    queue_information.driver_destination_queue_index := p_driver_header^.connection_descriptor.destination.
          queue_index;

{   ---------------------
{   System Information.
{   ---------------------

    queue_information.client_page_size := osv$page_size;
    queue_information.client_os_name := osv$os_defaults_os_name;

    queue_information.server_state := p_cpu_queue^.queue_header.partner_status.server_state;

    CASE p_cpu_queue^.queue_header.partner_status.server_state OF
    = dfc$terminated, dfc$awaiting_recovery =
      dfp$get_highest_sf_lifetime (p_cpu_queue^.queue_header.destination_mainframe_id, family_found,
            server_state, server_lifetime, server_birthdate);
      IF NOT family_found THEN
        server_lifetime := p_cpu_queue^.queue_header.server_lifetime;
        server_birthdate := p_cpu_queue^.queue_header.server_birthdate;
      IFEND;
      IF p_cpu_queue^.queue_header.partner_status.server_state = dfc$awaiting_recovery THEN
        queue_information.previous_server_lifetime := server_lifetime;
        queue_information.previous_server_birthdate := server_birthdate;
      IFEND;

{ Now assign a new lifetime and birthdate.

      queue_information.server_lifetime := server_lifetime + 1;
      queue_information.server_birthdate := #FREE_RUNNING_CLOCK (0);
    = dfc$inactive =
      queue_information.server_lifetime := p_cpu_queue^.queue_header.server_lifetime;
      queue_information.server_birthdate := p_cpu_queue^.queue_header.server_birthdate;
      queue_information.previous_server_lifetime := queue_information.server_lifetime;
      queue_information.previous_server_birthdate := queue_information.server_birthdate;

    ELSE
      system_error ('ERROR - WRONG SERVER STATE IN QUEUE VERIFICATION', NIL);
      pmp$exit (status);
    CASEND;

  PROCEND build_queue_info_record;
?? TITLE := '    deactivate_system_task ', EJECT ??

  PROCEDURE deactivate_system_task
    (    server_name: pmt$mainframe_id);

    VAR
      local_status: ost$status,
      task_name: ost$name;

    dfp$format_task_name (server_name, task_name);
    osp$deactivate_system_task (task_name, local_status);
    IF NOT local_status.normal THEN
      IF local_status.condition = ose$system_task_not_active THEN
        system_error ('SYSTEM TASK NOT enabled AND DF POLLING_TASK running.', NIL);
      ELSE
        system_error ('DEACTIVATE_SYSTEM_TASK RETURNED ABNORMAL STATUS.', ^local_status);
      IFEND;
    IFEND;

{   -----------------------------------------------------------------------
{   Deactivate_system_task procedure does not terminate a task immediately.
{   Need to give it time to do its thing.
{   -----------------------------------------------------------------------

  /wait_till_termination/
    WHILE TRUE DO
      pmp$wait (1000, 1000);
    WHILEND /wait_till_termination/;
  PROCEND deactivate_system_task;
?? TITLE := '    determine_wakeup_cause', EJECT ??

  PROCEDURE determine_wakeup_cause
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table;
         time_before_wait: integer;
         server_name: pmt$mainframe_id;
     VAR reply_received: boolean);

    VAR
      message_length: integer,
      operator_message: string (79),
      p_buffer_parameters: ^dft$poll_message,
      p_driver_flags: ^dft$queue_entry_flags,
      p_receive_buffer: dft$p_command_buffer,
      remaining_wait_time: integer,
      status: ost$status,
      time_after_wait: integer,
      wait_time: integer;

    status.normal := TRUE;
    reply_received := FALSE;
    p_driver_flags := ^p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue^.queue_entries [dfc$poll_queue_index].flags;
    p_receive_buffer := p_cpu_queue^.queue_entries [dfc$poll_queue_index].p_receive_buffer;
    wait_time := p_cpu_queue^.queue_header.timeout_interval DIV 1000;
    RESET p_receive_buffer;
    NEXT p_buffer_parameters IN p_receive_buffer;

{----------------------------------------------------------------------
{   This procedure will loop here until the wait_time expires.
{   IF during this time:
{      driver_flags.subsystem_action = TRUE AND
{      transaction count in the CPU Queue Entry = transaction count
{                                                 in the Receive Buffer
{   THEN the poll reply has arrived and will be processed.
{
{   If both conditions are not met then the wait time will be exhausted
{   with no other processing done here.
{----------------------------------------------------------------------

    REPEAT
      #SPOIL (p_cpu_queue^.queue_header.partner_status);
      #SPOIL (p_driver_flags^);

      IF p_cpu_queue^.queue_header.partner_status.terminate_partner THEN
        terminate_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
             { restart } FALSE);
      IFEND;

      IF p_cpu_queue^.queue_header.partner_status.timeout_partner THEN
        timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
             { restart } FALSE);
      IFEND;

      IF NOT reply_received THEN
        IF p_driver_flags^.subsystem_action THEN
          IF p_driver_flags^.driver_error_alert THEN
            system_error ('DRIVER ERROR FLAG SET -TIMING OUT', NIL);
            { The task should never see driver_error_alert, but still recovery is likely.
            timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                    { restart } FALSE);
          ELSEIF (p_buffer_parameters^.buffer_header.transaction_count = p_cpu_queue^.
                queue_entries [dfc$poll_queue_index].transaction_count) THEN
            process_poll_reply (p_cpu_queue, queue_index, p_queue_interface_table, server_name);
            reply_received := TRUE;
          ELSEIF (p_buffer_parameters^.buffer_header.transaction_count > p_cpu_queue^.
                queue_entries [dfc$poll_queue_index].transaction_count) THEN
            STRINGREP (operator_message, message_length, ' Server ', server_name,
                  ' has mismatched transaction count .');
            display (operator_message (1, message_length));
            log_display ($pmt$ascii_logset[pmc$system_log], operator_message (1,message_length));
            STRINGREP (operator_message, message_length, ' From server ',
                  p_buffer_parameters^.buffer_header.transaction_count,
                  ' Client ', p_cpu_queue^. queue_entries [dfc$poll_queue_index].transaction_count);
            display (operator_message (1, message_length));
            log_display ($pmt$ascii_logset[pmc$system_log], operator_message (1,message_length));
            timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                    { restart } TRUE);
          IFEND;
        IFEND;
      IFEND;

      time_after_wait := #FREE_RUNNING_CLOCK (0);
      remaining_wait_time := wait_time - ((time_after_wait - time_before_wait) DIV 1000);
      IF (remaining_wait_time > 0) THEN
        pmp$wait (remaining_wait_time, remaining_wait_time);
      IFEND;

    UNTIL (remaining_wait_time <= 0);

  PROCEND determine_wakeup_cause;

?? TITLE := '[XDCL] dfp$execute_get_app_info', EJECT ??

{ PURPOSE:
{   The purpose of this request is to execute a task which will request and
{   process information from the server mainframe concerning application
{   information.

  PROCEDURE [XDCL] dfp$execute_get_app_info
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      p_parameter_sequence: ^pmt$program_parameters,
      p_parameter_string: ^ost$string,
      p_program_attributes: ^pmt$program_attributes,
      p_program_description: ^pmt$program_description,
      taskid: pmt$task_id;

    PUSH p_program_description: [[REP 1 OF pmt$program_attributes]];
    RESET p_program_description;
    NEXT p_program_attributes IN p_program_description;
    p_program_attributes^.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$load_map_options_specified, pmc$term_error_level_specified];
    p_program_attributes^.starting_procedure := get_remote_app_start_proc;
    p_program_attributes^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    p_program_attributes^.termination_error_level := pmc$warning_load_errors;

    PUSH p_parameter_sequence: [[REP 1 OF ost$string]];
    RESET p_parameter_sequence;
    NEXT p_parameter_string IN p_parameter_sequence;
    p_parameter_string^.size := #SIZE (mainframe_name);
    p_parameter_string^.value := mainframe_name;

    IF dfv$p_get_app_info_status = NIL THEN
      ALLOCATE dfv$p_get_app_info_status IN osv$task_shared_heap^;
    IFEND;

    IF dfv$file_server_debug_enabled THEN
      display (' Starting get_app_info task ');
    IFEND;

    pmp$execute (p_program_description^, p_parameter_sequence^, osc$nowait, taskid,
          dfv$p_get_app_info_status^, status);

  PROCEND dfp$execute_get_app_info;

?? TITLE := '    execute_idle_task', EJECT ??

  PROCEDURE execute_idle_task
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      p_parameter_sequence: ^pmt$program_parameters,
      p_parameter_string: ^ost$string,
      p_program_attributes: ^pmt$program_attributes,
      p_program_description: ^pmt$program_description,
      taskid: pmt$task_id;

    PUSH p_program_description: [[REP 1 OF pmt$program_attributes]];
    RESET p_program_description;
    NEXT p_program_attributes IN p_program_description;
    p_program_attributes^.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$load_map_options_specified, pmc$term_error_level_specified];
    p_program_attributes^.starting_procedure := idle_task_start_proc;
    p_program_attributes^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    p_program_attributes^.termination_error_level := pmc$warning_load_errors;

    PUSH p_parameter_sequence: [[REP 1 OF ost$string]];
    RESET p_parameter_sequence;
    NEXT p_parameter_string IN p_parameter_sequence;
    p_parameter_string^.size := #SIZE (mainframe_name);
    p_parameter_string^.value := mainframe_name;

    IF dfv$p_idle_task_status = NIL THEN
      ALLOCATE dfv$p_idle_task_status IN osv$task_shared_heap^;
    IFEND;

    pmp$execute (p_program_description^, p_parameter_sequence^, osc$nowait, taskid, dfv$p_idle_task_status^,
          status);
  PROCEND execute_idle_task;
?? TITLE := '    execute_recovery_task', EJECT ??

  PROCEDURE execute_recovery_task
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      p_parameter_sequence: ^pmt$program_parameters,
      p_parameter_string: ^ost$string,
      p_program_attributes: ^pmt$program_attributes,
      p_program_description: ^pmt$program_description,
      taskid: pmt$task_id;

    PUSH p_program_description: [[REP 1 OF pmt$program_attributes]];
    RESET p_program_description;
    NEXT p_program_attributes IN p_program_description;
    p_program_attributes^.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$load_map_options_specified, pmc$term_error_level_specified];
    p_program_attributes^.starting_procedure := recovery_task_start_proc;
    p_program_attributes^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    p_program_attributes^.termination_error_level := pmc$warning_load_errors;

    PUSH p_parameter_sequence: [[REP 1 OF ost$string]];
    RESET p_parameter_sequence;
    NEXT p_parameter_string IN p_parameter_sequence;
    p_parameter_string^.size := #SIZE (mainframe_name);
    p_parameter_string^.value := mainframe_name;

    IF dfv$p_recovery_task_status = NIL THEN
      ALLOCATE dfv$p_recovery_task_status IN osv$task_shared_heap^;
    IFEND;
    IF dfv$file_server_debug_enabled THEN
      display (' Starting recovery task ');
    IFEND;
    log_display ($pmt$ascii_logset[pmc$system_log], ' Start recovery task ');
    pmp$execute (p_program_description^, p_parameter_sequence^, osc$nowait, taskid,
          dfv$p_recovery_task_status^, status);
  PROCEND execute_recovery_task;

?? TITLE := '    execute_verify_jobs_task', EJECT ??

  PROCEDURE execute_verify_jobs_task
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      p_parameter_sequence: ^pmt$program_parameters,
      p_parameter_string: ^ost$string,
      p_program_attributes: ^pmt$program_attributes,
      p_program_description: ^pmt$program_description,
      taskid: pmt$task_id;

    PUSH p_program_description: [[REP 1 OF pmt$program_attributes]];
    RESET p_program_description;
    NEXT p_program_attributes IN p_program_description;
    p_program_attributes^.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$load_map_options_specified, pmc$term_error_level_specified];
    p_program_attributes^.starting_procedure := verify_jobs_task_start_proc;
    p_program_attributes^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    p_program_attributes^.termination_error_level := pmc$warning_load_errors;

    PUSH p_parameter_sequence: [[REP 1 OF ost$string]];
    RESET p_parameter_sequence;
    NEXT p_parameter_string IN p_parameter_sequence;
    p_parameter_string^.size := #SIZE (mainframe_name);
    p_parameter_string^.value := mainframe_name;

    IF dfv$p_verify_jobs_task_status = NIL THEN
      ALLOCATE dfv$p_verify_jobs_task_status IN osv$task_shared_heap^;
    IFEND;

    IF dfv$file_server_debug_enabled THEN
      display (' Starting verify_jobs task ');
    IFEND;

    pmp$execute (p_program_description^, p_parameter_sequence^, osc$nowait, taskid,
          dfv$p_verify_jobs_task_status^, status);

  PROCEND execute_verify_jobs_task;

?? TITLE := '    [INLINE] find_next_active_entry', EJECT ??

  PROCEDURE [INLINE] find_next_active_entry
    (    starting_position: integer;
         number_of_characters: integer;
         entry_assignment_string: string ( * <= dfc$queue_assignment_strng_size);
     VAR entry_assignment: integer);

{=================================================================================
{
{    This procedure scans the input string for a next active entry (one whose
{    value is dfc$assigned_entry_char), and if such entry is found in the entry
{    assignment string, it returns its index value.
{    The string will only be scanned from the starting position for number_of_characters.
{    If no active entry is found, zero is returned in the index.
{
{=================================================================================

    TYPE
      char_set = set of char;

    VAR
      entry_found: boolean,
      find_char_set: char_set;

    find_char_set := $char_set [dfc$assigned_entry_char];

    #SCAN (find_char_set, entry_assignment_string (starting_position, number_of_characters), entry_assignment,
          entry_found);
    IF entry_found THEN
      entry_assignment := starting_position + entry_assignment - 1;
    ELSE
      entry_assignment := 0;
    IFEND;
  PROCEND find_next_active_entry;
?? TITLE := '    issue_server_poll', EJECT ??

  PROCEDURE issue_server_poll
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table;
         poll_header: dft$poll_header;
         p_family_list: ^dft$poll_family_list;
         p_queue_information: ^dft$poll_queue_information);

    VAR
      actual_length: integer,
      p_driver_entry: ^dft$driver_queue_entry,
      p_number_of_families: ^0 .. dfc$max_family_parameters,
      p_poll_family_list: ^dft$poll_family_list,
      p_poll_queue_information: ^dft$poll_queue_information,
      p_send_buffer: dft$p_command_buffer,
      p_send_parameters: ^dft$poll_message,
      status: ost$status;

    p_send_buffer := p_cpu_queue^.queue_entries [dfc$poll_queue_index].p_send_buffer;
    p_driver_entry := ^p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue^.queue_entries [dfc$poll_queue_index];

    IF p_driver_entry^.flags.driver_action THEN
      RETURN;

    ELSE
      p_cpu_queue^.queue_entries [dfc$poll_queue_index].transaction_count := p_cpu_queue^.
            queue_entries [dfc$poll_queue_index].transaction_count + 1;
      RESET p_send_buffer;
      NEXT p_send_parameters IN p_send_buffer;
      p_send_parameters^.buffer_header.version := dfc$poll_task_version;
      p_send_parameters^.buffer_header.transaction_count :=
            p_cpu_queue^.queue_entries [dfc$poll_queue_index].transaction_count;
      p_send_parameters^.buffer_header.remote_processor := dfc$poll_task;
      p_send_parameters^.buffer_header.data_length_sent := 0;
      p_send_parameters^.poll_header := poll_header;
      p_send_parameters^.buffer_header.retransmission_count := 0;

      p_cpu_queue^.queue_entries [dfc$poll_queue_index].retransmission_count := 0;
      CASE poll_header.poll_type OF
      = dfc$normal_poll, dfc$deactivate_server, dfc$deactivate_complete, dfc$recovery_complete =

{       These poll types only require poll_header.

      = dfc$verify_served_family, dfc$verify_queue =
        NEXT p_number_of_families IN p_send_buffer;
        IF (p_family_list = NIL) THEN
          p_number_of_families^ := 0;
        ELSE
          p_number_of_families^ := UPPERBOUND (p_family_list^.families);
          NEXT p_poll_family_list: [1 .. UPPERBOUND (p_family_list^.families)] IN p_send_buffer;
          p_poll_family_list^ := p_family_list^;
        IFEND;

        IF (poll_header.poll_type = dfc$verify_queue) THEN
          IF (p_queue_information = NIL) THEN
            system_error ('INTERNAL ERROR - NO QUEUE INFO LIST.-TIMEOUT', NIL);
            { Some error occurred, but it might cleanup on next activation.
            timeout_task (p_cpu_queue, queue_index, p_queue_interface_table,
                  p_cpu_queue^.queue_header.destination_mainframe_name,
                  { restart } FALSE);

          ELSE
            NEXT p_poll_queue_information IN p_send_buffer;
            p_poll_queue_information^ := p_queue_information^;
          IFEND;
        IFEND;

      ELSE
        system_error ('INTERNAL ERROR - INCORRECT POLL TYPE.-TIMOUT.', NIL);
        timeout_task (p_cpu_queue, queue_index, p_queue_interface_table,
              p_cpu_queue^.queue_header.destination_mainframe_name,
              { restart } FALSE);
      CASEND;

      actual_length := dfp$word_boundary (i#current_sequence_position (p_send_buffer));
      p_send_parameters^.buffer_header.buffer_length_sent := actual_length;
      p_driver_entry^.flags := dfv$send_command_flags;
      p_driver_entry^.send_buffer_descriptor.actual_length := actual_length;
      IF dfv$display_poll THEN
        display (dfv$poll_type_string [poll_header.poll_type]);
      IFEND;
      dfp$queue_task_request (p_queue_interface_table, queue_index, dfc$poll_queue_index);
    IFEND;

  PROCEND issue_server_poll;

?? TITLE := '    process_family_verification', EJECT ??

  PROCEDURE process_family_verification
    (    number_of_families: 0 .. dfc$max_family_parameters;
         p_received_families: ^dft$poll_family_list;
         server_lifetime: dft$server_lifetime;
         server_birthdate: integer;
         server_state: dft$server_state;
         p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index);

    VAR
      family_access: dft$family_access,
      family_index: 1 .. dfc$max_family_parameters,
      family_list: array [1 .. 1] of ost$name,
      message_length: integer,
      operator_message: string (ofc$max_send_message),
      server_mainframe_id: pmt$binary_mainframe_id,
      status: ost$status,
      verification_changed: boolean;


    server_mainframe_id := p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
          p_cpu_queue^.queue_header.destination_mainframe_id;

  /process_each_family/
    FOR family_index := number_of_families DOWNTO 1 DO
      family_access := p_received_families^.families [family_index].family_access;
      IF p_received_families^.families [family_index].valid THEN
        dfp$change_family_verification (p_received_families^.families [family_index].family,
              server_mainframe_id, family_access, {verified=} TRUE, server_lifetime, server_birthdate,
              server_state, verification_changed, status);
        IF (NOT status.normal) AND (status.condition = dfe$family_not_found) THEN

{ The family came from a change_client_access command on the server.

          status.normal := TRUE;
          family_list [1] := p_received_families^.families [family_index].family;
          dfp$register_served_families (family_list, family_access, {client_definition =} FALSE,
                p_queue_interface_table, queue_index, status);
          IF status.normal THEN
            dfp$change_family_verification (p_received_families^.families [family_index].family,
                  server_mainframe_id, family_access, {verified=} TRUE, server_lifetime, server_birthdate,
                  server_state, verification_changed, status);
          ELSE
            STRINGREP (operator_message, message_length, ' Server Family ', p_received_families^.
                  families [family_index].family, ' NOT available.');
            log_display ($pmt$ascii_logset[pmc$system_log], operator_message (1,message_length));
            display (operator_message (1, message_length));
            send_status_to_operator (status);
          IFEND;
        IFEND;
        IF status.normal AND verification_changed THEN
          STRINGREP (operator_message, message_length, ' Served Family ', p_received_families^.
                families [family_index].family, ' available.');
          log_display ($pmt$ascii_logset[pmc$system_log], operator_message (1,message_length));
          display (operator_message (1, message_length));
        IFEND;

      ELSE
        STRINGREP (operator_message, message_length, ' Served Family ', p_received_families^.
              families [family_index].family, ' NOT available.');
        log_display ($pmt$ascii_logset[pmc$system_log], operator_message (1,message_length));
        display (operator_message (1, message_length));
        dfp$change_family_verification (p_received_families^.families [family_index].family,
              server_mainframe_id, family_access, {verified=} FALSE, server_lifetime,
              server_birthdate, server_state, verification_changed, status);
        dfp$delete_family_if_last (p_received_families^.families [family_index].family);
      IFEND;
    FOREND /process_each_family/;
  PROCEND process_family_verification;

?? TITLE := '    process_poll_reply', EJECT ??

  PROCEDURE process_poll_reply
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table;
         server_name: pmt$mainframe_id);

    VAR
      client_date_time: ost$date_time,
      ignore_task_executing: boolean,
      message_length: integer,
      old_state: dft$server_state,
      operator_message: string (180),
      p_buffer_parameters: ^dft$poll_message,
      p_number_of_families: ^0 .. dfc$max_family_parameters,
      p_poll_header: ^dft$poll_header,
      p_queue_information: ^dft$poll_queue_information,
      p_receive_buffer: dft$p_command_buffer,
      p_received_families: ^dft$poll_family_list,
      seconds_time_dif: integer,
      status: ost$status,
      time_dif_direction: string (6);

    CONST
      acceptable_time_dif = 5;

    status.normal := TRUE;
    p_receive_buffer := p_cpu_queue^.queue_entries [dfc$poll_queue_index].p_receive_buffer;
    RESET p_receive_buffer;
    NEXT p_buffer_parameters IN p_receive_buffer;
    IF p_buffer_parameters^.poll_header.poll_type = dfc$verify_queue_reply THEN
      pmp$get_compact_date_time (client_date_time, status);
    IFEND;

{----------------------------
{   Verify Buffer Header
{----------------------------

    IF ((p_buffer_parameters^.buffer_header.version = dfc$poll_task_version) AND
          (p_buffer_parameters^.buffer_header.remote_processor = dfc$poll_task) AND
          (p_buffer_parameters^.buffer_header.data_length_sent = 0)) THEN
      p_poll_header := ^p_buffer_parameters^.poll_header;
      IF NOT (p_poll_header^.mainframe_name = p_cpu_queue^.queue_header.destination_mainframe_name) THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$incorrect_server_mainframe,
              p_cpu_queue^.queue_header.destination_mainframe_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_poll_header^.mainframe_name, status);
        send_status_to_operator (status);
        { It won't get any better by attempting to recover.
        terminate_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
               { restart } FALSE);
      IFEND;
      IF (p_buffer_parameters^.buffer_header.transaction_count <> p_cpu_queue^.
          queue_entries [dfc$poll_queue_index].transaction_count) THEN
        STRINGREP (operator_message, message_length, ' Server ', server_name,
              ' Transaction mismatch - timing out.');
        log_display ($pmt$ascii_logset[pmc$system_log], operator_message (1,message_length));
        display (operator_message (1, message_length));
        timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                { restart } FALSE);
      IFEND;
    ELSE
      system_error ('INCORRECT BUFFER HEADER RECEIVED FROM SERVER-TIMEOUT', NIL);
      timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
              { restart } FALSE);
    IFEND;

{-----------------------------------------------------------
{   Correct Poll Reply type is dependent on the Server State
{-----------------------------------------------------------
   old_state := p_cpu_queue^.queue_header.partner_status.server_state;

    CASE p_cpu_queue^.queue_header.partner_status.server_state OF

    = dfc$active =

      CASE p_poll_header^.poll_type OF
      = dfc$poll_reply =

{       No need to process the normal poll reply.

      = dfc$verify_family_reply =
        IF p_cpu_queue^.queue_header.partner_status.verify_family THEN
          p_cpu_queue^.queue_header.partner_status.verify_family := FALSE;
          NEXT p_number_of_families IN p_receive_buffer;
          IF (p_number_of_families^ > 0) THEN
            NEXT p_received_families: [1 .. p_number_of_families^] IN p_receive_buffer;
          IFEND;
          IF p_cpu_queue^.queue_header.number_of_monitor_queue_entries > 0 THEN
            process_family_verification (p_number_of_families^, p_received_families,
                  p_cpu_queue^.queue_header.server_lifetime, p_cpu_queue^.queue_header.server_birthdate,
                  dfc$active, p_queue_interface_table, queue_index);
            dfp$change_job_leveler_state;
          IFEND;
        ELSE
          system_error ('INCORRECT POLL REPLY RECEIVED FROM SERVER-TIMING OUT', NIL);
          timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                    { restart } FALSE);
        IFEND;

      = dfc$deactivate_server =
        STRINGREP (operator_message, message_length, ' Server ', server_name, ' deactivating.');
        log_display ($pmt$ascii_logset[pmc$system_log], operator_message (1,message_length));
        display (operator_message (1, message_length));
        p_cpu_queue^.queue_header.partner_status.send_deactivate_partner := TRUE;

      = dfc$req_verify_served_family =
        p_cpu_queue^.queue_header.partner_status.verify_family :=
              p_cpu_queue^.queue_header.number_of_monitor_queue_entries > 0;

      ELSE
        system_error ('INCORRECT POLL REPLY RECEIVED FROM SERVER-TIMING OUT', NIL);
        timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                    { restart } FALSE);
      CASEND;

    = dfc$deactivated =
      IF p_poll_header^.poll_type = dfc$deactivate_reply THEN

{       No need to process deactivate_reply.

      ELSE
        system_error ('INCORRECT POLL REPLY RECEIVED FROM SERVER-TIMING OUT', NIL);
        timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                { restart } FALSE);
      IFEND;

    = dfc$inactive, dfc$terminated, dfc$awaiting_recovery =
      IF p_poll_header^.poll_type = dfc$verify_queue_reply THEN
        p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
        NEXT p_number_of_families IN p_receive_buffer;
        IF (p_number_of_families^ = 0) THEN
          p_received_families := NIL;
        ELSE
          NEXT p_received_families: [1 .. p_number_of_families^] IN p_receive_buffer;
        IFEND;
        NEXT p_queue_information IN p_receive_buffer;

{       -------------------------------------------------------------------
{       If Server accepted queue_verification_message, Server State will be
{       set to dfc$active or dfc$recovering and the accepted families will become available
{       for user processing. If load leveling is not disabled then the job
{       leveler task will be readied.
{       If Server rejected the message then with one exception, the Server
{       State will be set to dfc$terminated and this task will terminate.
{       The one exception occurs under following conditions: the current
{       Server State = dfc$terminated AND the error condition indicates
{       Lifetime/Birthdate conflict. In this case, verify_queue will remain
{       set to TRUE and, as a result, another dfc$verify_queue message will
{       be sent to Server.
{       -------------------------------------------------------------------

        IF p_queue_information^.status.normal OR (p_queue_information^.status.condition =
              dfe$os_name_conflict) THEN
          IF NOT p_queue_information^.status.normal THEN
            send_status_to_operator (p_queue_information^.status);
          IFEND;
          p_cpu_queue^.queue_header.partner_status.send_deactivate_partner := FALSE;
          p_cpu_queue^.queue_header.server_lifetime := p_queue_information^.server_lifetime;
          p_cpu_queue^.queue_header.server_birthdate := p_queue_information^.server_birthdate;
          IF (p_number_of_families^ > 0) AND (p_cpu_queue^.queue_header.number_of_monitor_queue_entries > 0)
                THEN
            process_family_verification (p_number_of_families^, p_received_families,
                  p_cpu_queue^.queue_header.server_lifetime, p_cpu_queue^.queue_header.server_birthdate,
                  dfc$active, p_queue_interface_table, queue_index);
          IFEND;
          IF (p_cpu_queue^.queue_header.partner_status.server_state = dfc$awaiting_recovery) THEN
            p_cpu_queue^.queue_header.partner_status.recovery_complete := FALSE;
            p_cpu_queue^.queue_header.partner_status.server_state := dfc$recovering;
            dfp$change_family_server_state (dfc$recovering, p_cpu_queue^.queue_header.
                  destination_mainframe_id);
            { State change procedures are called from within the recovery task.
            execute_recovery_task (p_cpu_queue^.queue_header.destination_mainframe_name, status);
          ELSE { Coming active after termination or inactive
            p_cpu_queue^.queue_header.partner_status.send_deactivate_partner := FALSE;
            p_cpu_queue^.queue_header.partner_status.job_reconcilliation_completed := FALSE;
            p_cpu_queue^.queue_header.partner_status.server_state := dfc$active;
            dfp$change_family_server_state (dfc$active, p_cpu_queue^.queue_header.destination_mainframe_id);
            IF p_cpu_queue^.queue_header.leveler_status.leveler_state <> jmc$jl_leveler_disabled THEN
              jmp$ready_job_leveler_task (ignore_task_executing);
            IFEND;
            dfp$execute_state_change_task (p_cpu_queue^.queue_header.destination_mainframe_name,
                   { partner_is_server } TRUE, old_state, dfc$active, osc$nowait, status);
          IFEND;

{         Compare Server system time with Client system time, and WARN operator
{         of difference. Changes made to served catalogs/files with utilities
{         such as Edit_Catalog may not be recognized if the Server's system
{         time is not the same as the Client's system time.
          pmp$compute_time_dif_in_seconds (p_queue_information^.server_date_time, client_date_time,
               seconds_time_dif, status);
          IF seconds_time_dif < 0 THEN
{           The Servers system time is ahead of the Clients system time.
{           (This case seems to cause no problem for Edit_Catalog.)
            seconds_time_dif := (seconds_time_dif) * (-1);
            time_dif_direction := 'faster';
          ELSE
            time_dif_direction := 'slower';
          IFEND;
          IF seconds_time_dif >= acceptable_time_dif THEN
            STRINGREP (operator_message, message_length, 'WARNING - Server ', server_name,
                ' system time is', seconds_time_dif, ' seconds ', time_dif_direction, ' than client. ',
                'Use CHANGE_TIME command to make Client system time same as Server time.');
            display (operator_message (1, message_length));
            log_display ($pmt$ascii_logset[pmc$system_log], operator_message (1,message_length));
          IFEND;

        ELSEIF (p_queue_information^.status.condition = dfe$client_lifetime_error) OR
               (p_queue_information^.status.condition = dfe$force_client_termination) THEN
          send_status_to_operator (p_queue_information^.status);
          IF (p_cpu_queue^.queue_header.partner_status.server_state = dfc$terminated) THEN
           { Wait for the server to re-activate and retry again.
            p_cpu_queue^.queue_header.partner_status.verify_queue := TRUE;
          ELSE
            terminate_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                  { restart } TRUE);
          IFEND;
        ELSEIF (p_queue_information^.status.condition = dfe$force_server_recovery) OR
          (p_queue_information^.status.condition = dfe$force_server_termination) THEN

          { Wait for the server to re-activate and retry again.
          send_status_to_operator (p_queue_information^.status);
          p_cpu_queue^.queue_header.partner_status.verify_queue := TRUE;
        ELSEIF p_queue_information^.status.condition = dfe$force_client_recovery THEN
          send_status_to_operator (p_queue_information^.status);
          p_cpu_queue^.queue_header.partner_status.verify_queue := TRUE;
          p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
          timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                    { restart } TRUE);
        ELSE
          STRINGREP (operator_message, message_length, ' Server ', server_name,
                ' rejected queue verification.');
          log_display ($pmt$ascii_logset[pmc$system_log], operator_message (1,message_length));
          display (operator_message (1, message_length));
          STRINGREP (operator_message, message_length, ' Server ', server_name, ' returned following error:');
          log_display ($pmt$ascii_logset[pmc$system_log], operator_message (1,message_length));
          display (operator_message (1, message_length));
          status := p_queue_information^.status;
          send_status_to_operator (status);
          timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                  { restart } FALSE);
        IFEND;

      ELSE
        system_error ('INCORRECT POLL REPLY RECEIVED FROM SERVER-TIMING OUT', NIL);
        timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                    { restart } FALSE);
      IFEND;

    = dfc$recovering =
      CASE p_poll_header^.poll_type OF
      = dfc$poll_reply =

{ Do nothing this is normal

      = dfc$recovery_complete_reply =
        STRINGREP (operator_message, message_length, ' Server ', server_name, ' recovery complete');
        display (operator_message (1, message_length));
        log_display ($pmt$ascii_logset[pmc$system_log], operator_message (1,message_length));
        p_cpu_queue^.queue_header.partner_status.send_deactivate_partner := FALSE;
        p_cpu_queue^.queue_header.partner_status.verify_family := TRUE;
        p_cpu_queue^.queue_header.partner_status.job_reconcilliation_completed := TRUE;
        p_cpu_queue^.queue_header.partner_status.server_state := dfc$active;
        IF p_cpu_queue^.queue_header.partner_status.send_deactivate_partner THEN
          { Probably not supported
          STRINGREP (operator_message, message_length, ' Server ', server_name, ' begining deactivation');
          display (operator_message (1, message_length));
          log_display ($pmt$ascii_logset[pmc$system_log], operator_message (1,message_length));
          dfp$change_family_server_state (dfc$deactivated, p_cpu_queue^.queue_header.
                destination_mainframe_id);
        ELSE
          dfp$change_family_server_state (dfc$active, p_cpu_queue^.queue_header.destination_mainframe_id);
        IFEND;
        dfp$execute_state_change_task (p_cpu_queue^.queue_header.destination_mainframe_name,
                { partner_is_server } TRUE, dfc$recovering, dfc$active, osc$nowait, status);
      ELSE
        system_error ('INCORRECT POLL REPLY RECEIVED FROM RECOVERING- TIMING OUT  ', NIL);
        timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                    { restart } FALSE);
      CASEND;

    ELSE
      system_error ('INCORRECT SERVER STATE IN PROCESS_POLL_REPLY-TERMINATING.', NIL);
      { The state is probably confused enough that recovery should not be tried.
      terminate_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                    { restart } FALSE);
    CASEND;

  PROCEND process_poll_reply;
?? TITLE := '    restart_system_task ', eject ??
  PROCEDURE restart_system_task
    (    p_cpu_queue: ^dft$cpu_queue;
         mainframe_name: pmt$mainframe_id);

    VAR
      message: string (80),
      message_length: integer,
      status: ost$status,
      task_name: ost$name;

    dfp$reset_mainframe_tables (mainframe_name, {server_to_client } FALSE, status);
    IF NOT status.normal THEN
      display_status (status);
    IFEND;
    p_cpu_queue^.queue_header.partner_status.verify_queue := TRUE;

    dfp$format_task_name (mainframe_name, task_name);
    STRINGREP (message, message_length, ' Task ', task_name, ' restarting.');
    display (message (1, message_length));
    log_display ($pmt$ascii_logset[pmc$system_log], message (1,message_length));
    osp$set_system_task_restart (task_name, { restart } TRUE, status);
    IF status.normal THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$restart_server_task, mainframe_name, status);
      pmp$exit (status);
    ELSE
      display (' Unable to automatically restart system task');
      log_display ($pmt$ascii_logset[pmc$system_log],
            ' Unable to automatically restart system task');
      display_status (status);
      log_display_status ($pmt$ascii_logset[pmc$system_log], TRUE,
          status);
      display (' ACTIVATE_SERVER command required');
      deactivate_system_task (mainframe_name);
    IFEND;
  PROCEND restart_system_task;
?? TITLE := '      send_status_to_operator ', EJECT ??

  PROCEDURE send_status_to_operator
    (    status: ost$status);

    VAR
      ignore_status: ost$status,
      line_count: ost$status_message_line_count,
      message: ost$status_message,
      p_line_count: ^ost$status_message_line_count,
      p_line_size: ^ost$status_message_line_size,
      p_message: ^ost$status_message,
      p_message_line: ^string ( * );

    p_message := ^message;
    osp$format_message (status, osc$full_message_level, ofc$max_display_message, p_message^, ignore_status);

    RESET p_message;
    NEXT p_line_count IN p_message;
    IF p_line_count^ > 0 THEN

    /display_each_line/
      FOR line_count := 1 TO (p_line_count^) DO
        NEXT p_line_size IN p_message;
        NEXT p_message_line: [p_line_size^] IN p_message;
        display (p_message_line^);
        log_display ($pmt$ascii_logset[pmc$system_log], p_message_line^);
      FOREND /display_each_line/;
    IFEND;
  PROCEND send_status_to_operator;

?? TITLE := '      send_verify_queue ', EJECT ??

  PROCEDURE send_verify_queue
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table;
         poll_header: dft$poll_header;
         p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
         server_name: pmt$mainframe_id;
     VAR family_container: SEQ (REP dfc$max_family_parameters of dft$family_verification);
     VAR number_of_families: 0 .. dfc$max_family_parameters);

    VAR
      p_family_list: ^dft$poll_family_list,
      p_driver_flags: ^dft$queue_entry_flags,
      p_driver_queue: ^dft$driver_queue,
      queue_info_record: dft$poll_queue_information,
      status: ost$status,
      wait_time: integer;

{-------------------------------------
{   Bring up PP if necessary.
{-------------------------------------

    p_driver_queue := p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue;
    wait_time := p_cpu_queue^.queue_header.timeout_interval DIV 1000;
    status.normal := TRUE;

    dfp$load_pp_if_first (p_q_interface_directory_entry, queue_index, status);
    IF NOT status.normal THEN
      p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
      send_status_to_operator (status);
      { Perhaps not enough pp's are available.
      timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                    { restart } FALSE);
    IFEND;

{--------------------------------------
{   Format and send the verify message.
{--------------------------------------

    build_queue_info_record (p_cpu_queue, queue_index, p_queue_interface_table, queue_info_record);
    number_of_families := 0;
    p_family_list := NIL;
    IF p_cpu_queue^.queue_header.number_of_monitor_queue_entries > 0 THEN
      dfp$format_verify_family (p_cpu_queue^.queue_header.destination_mainframe_id, family_container,
            number_of_families, p_family_list);
    IFEND;
    issue_server_poll (p_cpu_queue, queue_index, p_queue_interface_table, poll_header, p_family_list,
          ^queue_info_record);

{------------------------------------
{   Wait for the reply to come back.
{------------------------------------

    p_driver_flags := ^p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue^.queue_entries [dfc$poll_queue_index].flags;

  /wait_for_reply/
    REPEAT
      #SPOIL (p_cpu_queue^.queue_header.partner_status);
      #SPOIL (p_driver_flags^.subsystem_action);

      IF (p_cpu_queue^.queue_header.partner_status.terminate_partner) OR
         ((p_cpu_queue^.queue_header.partner_status.server_state = dfc$terminated) AND
           (NOT p_cpu_queue^.queue_header.partner_status.verify_queue)) THEN
        terminate_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                    { restart } FALSE);
      ELSEIF p_cpu_queue^.queue_header.partner_status.timeout_partner THEN
        timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                    { restart } FALSE);
      IFEND;
      pmp$wait (wait_time, wait_time);
      time_out_requests (p_cpu_queue, queue_index, p_queue_interface_table, server_name);
    UNTIL p_driver_flags^.subsystem_action;

  PROCEND send_verify_queue;

?? TITLE := '    system_error  ', EJECT ??

  PROCEDURE system_error
    (    text: string ( * );
         p_status: ^ost$status);

    VAR
      local_status: ost$status;

    display (' File server - server system task- system error:');
    log_display ($pmt$ascii_logset[pmc$system_log],
         ' File server - server system task- system error:');
    display (text);
    log_display ($pmt$ascii_logset[pmc$system_log], text);
    IF p_status <> NIL THEN
      display_status (p_status^);
      log_display_status ($pmt$ascii_logset[pmc$system_log], {format} TRUE,
            p_status^);
    IFEND;
    local_status.normal := TRUE;
    IF dfv$file_server_debug_enabled THEN
      syp$invoke_system_debugger (text, 0, local_status);
    IFEND;
  PROCEND system_error;
?? TITLE := '    terminate_task', EJECT ??

  PROCEDURE terminate_task
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table;
         server_name: pmt$mainframe_id;
         restart: boolean);

    VAR
      leveler_complete: boolean,
      previous_state: dft$server_state,
      queue_directory_index: dft$queue_directory_index,
      status: ost$status;

    status.normal := TRUE;
    previous_state :=p_cpu_queue^.queue_header.partner_status.server_state;
    p_cpu_queue^.queue_header.partner_status.server_state := dfc$terminated;
    dfp$change_family_server_state (dfc$terminated, p_cpu_queue^.queue_header.destination_mainframe_id);
    dfp$term_requests_to_server (server_name, dfv$p_idle_task_status, status);
    IF NOT status.normal THEN
      send_status_to_operator (status);
    IFEND;

    IF p_cpu_queue^.queue_header.leveler_status.leveler_state = jmc$jl_leveler_enabled THEN
      dfp$wait_until_leveler_complete (p_cpu_queue, leveler_complete);
    IFEND;

    IF dfv$p_get_app_info_status <> NIL THEN
      FREE dfv$p_get_app_info_status IN osv$task_shared_heap^;
      dfv$p_get_app_info_status := NIL;
    IFEND;

{   ------------------------------------
{   Cleanup Partner_Status in CPU_Queue.
{   ------------------------------------

    p_cpu_queue^.queue_header.partner_status.terminate_partner := FALSE;
    p_cpu_queue^.queue_header.partner_status.timeout_partner := FALSE;
    p_cpu_queue^.queue_header.partner_status.deactivate_complete := FALSE;
    p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;

{   ---------------
{   Bring down PP.
{   ---------------

    p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue^.
          queue_header.flags.idle := TRUE;
    dfp$get_queue_directory_index (p_queue_interface_table, queue_directory_index);
    dfp$unload_pp_if_last (^dfv$p_queue_interface_directory^ [queue_directory_index], queue_index, status);
    IF NOT status.normal THEN
      send_status_to_operator (status);
    IFEND;

    dfp$free_image_file (p_cpu_queue^.queue_header.destination_mainframe_id,
          status);

    dfp$execute_state_change_task (server_name,
         { partner_is_server } TRUE, previous_state, dfc$terminated, osc$wait, status);

    dfp$return_application_library (p_cpu_queue);

    IF restart THEN
      restart_system_task (p_cpu_queue, server_name);
    ELSE
      deactivate_system_task (server_name);
    IFEND;

  PROCEND terminate_task;
?? TITLE := '    timeout_task', EJECT ??

  PROCEDURE timeout_task
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: ^dft$queue_interface_table;
         server_name: pmt$mainframe_id;
         restart: boolean);

    VAR
      idle_code: syt$180_idle_code,
      leveler_complete: boolean,
      previous_state: dft$server_state,
      queue_directory_index: dft$queue_directory_index,
      status: ost$status;

    status.normal := TRUE;
    IF dfv$file_server_debug_enabled THEN
      display ('  Timing out task ');
    IFEND;
    IF (NOT dfv$job_recovery_enabled) OR
       (p_cpu_queue^.queue_header.partner_status.server_state = dfc$terminated) THEN
      IF (NOT dfv$job_recovery_enabled) THEN
        log_display ($pmt$ascii_logset[pmc$system_log],
              '  FILE_SERVER_RECOVERY_ENABLED = 0');
      IFEND;
      terminate_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
            restart);
      RETURN;
    IFEND;
    p_cpu_queue^.queue_header.partner_status.timeout_partner := FALSE;
    p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
    osp$get_cause_of_idle (idle_code);
    previous_state := p_cpu_queue^.queue_header.partner_status.server_state;
    { Note: IF the previous_state is inactive
    { This should only happen as a result of a TERMINATE_SYSTEM command.
    { (idle_code = syc$ic_system_terminated) or as a result of a
    { 'TIMEOUT_SERVER' commands when inactive.
    { If the previous state was inactive there is no need to
    { save image file pages.
    p_cpu_queue^.queue_header.partner_status.server_state := dfc$awaiting_recovery;
    p_cpu_queue^.queue_header.partner_status.server_pages_saved := (previous_state = dfc$inactive);
    dfp$change_family_server_state (dfc$awaiting_recovery,
          p_cpu_queue^.queue_header.destination_mainframe_id);

    IF (previous_state <> dfc$inactive) THEN
      IF dfv$file_server_debug_enabled THEN
        display ('  Process queued entries ');
      IFEND;

      dfp$timeout_requests_to_server (server_name, status);
      IF NOT status.normal THEN
        send_status_to_operator (status);
      IFEND;
    IFEND;

    IF (previous_state = dfc$recovering) THEN
      { All of the files should already be awaiting_recovery. Allow the
      { recovery task to complete.
      pmp$wait (1000, 1000);
    ELSE
      dfp$timeout_server_files (p_cpu_queue^.queue_header.destination_mainframe_id, status);
      IF NOT status.normal THEN
        send_status_to_operator (status);
      IFEND;
    IFEND;
    p_cpu_queue^.queue_header.partner_status.server_pages_saved := (status.normal) OR
       (status.condition <> dfe$no_space_for_server_pages);

    IF p_cpu_queue^.queue_header.leveler_status.leveler_state = jmc$jl_leveler_enabled THEN
      dfp$wait_until_leveler_complete (p_cpu_queue, leveler_complete);
    IFEND;

{   ------------------------------------
{   Cleanup Partner_Status in CPU_Queue.
{   ------------------------------------

    p_cpu_queue^.queue_header.partner_status.terminate_partner := FALSE;
    p_cpu_queue^.queue_header.partner_status.timeout_partner := FALSE;
    p_cpu_queue^.queue_header.partner_status.deactivate_complete := FALSE;
    p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;

{   ---------------
{   Bring down PP.
{   ---------------

    p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue^.
          queue_header.flags.idle := TRUE;
    dfp$get_queue_directory_index (p_queue_interface_table, queue_directory_index);
    dfp$unload_pp_if_last (^dfv$p_queue_interface_directory^ [queue_directory_index], queue_index, status);
    IF NOT status.normal THEN
      send_status_to_operator (status);
    IFEND;

    dfp$execute_state_change_task (server_name, { partner_is_server } TRUE, previous_state,
         dfc$awaiting_recovery, osc$wait, status);

    IF restart AND (idle_code <> syc$ic_system_terminated) THEN
      restart_system_task (p_cpu_queue, server_name);
    ELSE
      deactivate_system_task (server_name);
      IF dfv$file_server_debug_enabled THEN
        display ('  Timeout complete ');
      IFEND;
    IFEND;
  PROCEND timeout_task;

?? TITLE := '    time_out_requests', EJECT ??

  PROCEDURE time_out_requests
    (    p_cpu_queue: ^dft$cpu_queue;
         queue_index: dft$queue_index;
         p_queue_interface_table: dft$p_queue_interface_table;
         server_name: pmt$mainframe_id);

    VAR
      current_time: integer,
      display_size: integer,
      display_string: string (80),
      elapsed_time: integer,
      entry_index: dft$queue_entry_index,
      found_entry: integer,
      local_status: ost$status,
      number_of_characters: integer,
      previous_time: integer,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_entry: ^dft$driver_queue_entry,
      p_send_buffer: dft$p_command_buffer,
      p_send_parameters: ^dft$buffer_header,
      request_block: dft$rb_file_server_request,
      starting_position: integer,
      status: ost$status,
      time: ost$time;

    number_of_characters := dfc$queue_assignment_strng_size;
    starting_position := 1;

  /process_all_active_requests/
    REPEAT
      #SPOIL (p_cpu_queue^.queue_header.queue_entry_assignment_table);

      find_next_active_entry (starting_position, number_of_characters,
            p_cpu_queue^.queue_header.queue_entry_assignment_table, found_entry);

      IF (found_entry > 0) THEN
        entry_index := found_entry;
        starting_position := found_entry + 1;
        number_of_characters := dfc$queue_assignment_strng_size - entry_index;

        p_driver_entry := ^p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
              p_driver_queue^.queue_entries [entry_index];
        p_cpu_queue_entry := ^p_cpu_queue^.queue_entries [entry_index];

        CASE p_cpu_queue_entry^.transaction_state OF
        = dfc$request_queued, dfc$request_sent, dfc$server_must_read_page_data, dfc$server_received_request,
          dfc$server_sent_response, dfc$media_error, dfc$message_content_error, dfc$server_waiting_request =
          IF p_cpu_queue_entry^.last_time_progress_checked = 0 THEN

{ last_time_progress_checked is zeroed each time a non-inquiry request is queued.
{ request_start_time is established each time a non-inquiry request is queued.

            previous_time := p_cpu_queue_entry^.request_start_time;
          ELSE
            previous_time := p_cpu_queue_entry^.last_time_progress_checked;
          IFEND;
          current_time := #FREE_RUNNING_CLOCK (0);
          elapsed_time := current_time - previous_time;

          IF (elapsed_time >= p_cpu_queue^.queue_header.timeout_interval) THEN
            IF ((p_cpu_queue^.queue_header.partner_status.server_state = dfc$terminated) OR
                  (p_cpu_queue^.queue_header.partner_status.server_state = dfc$inactive) OR
                  (p_cpu_queue^.queue_header.partner_status.server_state = dfc$awaiting_recovery)) AND
                  (entry_index = dfc$poll_queue_index) THEN
              p_cpu_queue_entry^.retransmission_count := 0;

            ELSE
              IF dfv$file_server_debug_enabled THEN
                pmp$get_time (osc$hms_time, time, status);
                STRINGREP (display_string, display_size, time.hms, ' TimeOut Q', queue_index, ' Qe',
                      entry_index, ' Tr#', p_cpu_queue_entry^.transaction_count, ' Retr#',
                      p_cpu_queue_entry^.retransmission_count, ' tc#',
                      p_cpu_queue_entry^.request_timeout_count, ' ',
                      transaction_state_string [p_cpu_queue_entry^.transaction_state]);
                display (display_string (1, display_size));
              IFEND;
            IFEND;
            IF p_cpu_queue_entry^.retransmission_count >= p_cpu_queue^.queue_header.
                  maximum_retransmission_count THEN
              display_integer (' Retransmission count exceeded, Count =',
                    p_cpu_queue_entry^.retransmission_count);
             log_display_integer ($pmt$ascii_logset[pmc$system_log],
                   ' Retransmission count exceeded, Count =',
                    p_cpu_queue_entry^.retransmission_count);
              STRINGREP (display_string, display_size, ' Timing out server ',
                    p_cpu_queue^.queue_header.destination_mainframe_name);
              log_display ($pmt$ascii_logset[pmc$system_log], display_string (1, display_size));
              display (display_string (1, display_size));
              timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                    { restart } FALSE);
            ELSE
              p_cpu_queue_entry^.last_time_progress_checked := current_time;

{ Check on transaction state of timed out request.

              request_block.reqcode := syc$rc_file_server_request;
              request_block.status.normal := TRUE;
              request_block.request := dfc$fsr_request_timeout;
              request_block.p_queue_interface_table := p_queue_interface_table;
              request_block.queue_index := queue_index;
              request_block.queue_entry_index := entry_index;
              i#call_monitor (#LOC (request_block), #SIZE (request_block));
            IFEND;

{ Provide a 'deadman' timeout to detect that no reponse has
{ been received in the maximum time.
{ This is the only code on the Client side which is responsible for
{ detecting a broken connection to the Server side. The transaction
{ state can advance beyond dfc$request_sent only if the link between
{ Client and Server is functioning.

            IF (entry_index = dfc$poll_queue_index) AND ((p_cpu_queue_entry^.transaction_state =
                  dfc$request_queued) OR (p_cpu_queue_entry^.transaction_state = dfc$request_sent)) AND
                  ((p_cpu_queue^.queue_header.partner_status.server_state = dfc$active) OR
                  (p_cpu_queue^.queue_header.partner_status.server_state = dfc$deactivated) OR
                  (p_cpu_queue^.queue_header.partner_status.server_state = dfc$recovering)) AND
                  ((current_time - p_cpu_queue_entry^.request_start_time) >=
                  (p_cpu_queue^.queue_header.timeout_interval * p_cpu_queue^.queue_header.
                  maximum_request_timeout_count * p_cpu_queue^.queue_header.maximum_retransmission_count))
                  THEN
              display (' Server Poll Message TIMED OUT ');
              log_display ($pmt$ascii_logset[pmc$system_log],
                    ' Server Poll Message TIMED OUT ');
              STRINGREP (display_string, display_size, ' Timing out server ',
                    p_cpu_queue^.queue_header.destination_mainframe_name);
              display (display_string (1, display_size));
              log_display ($pmt$ascii_logset[pmc$system_log], display_string (1, display_size));
              timeout_task (p_cpu_queue, queue_index, p_queue_interface_table, server_name,
                    { restart } FALSE);
            IFEND;
          IFEND;
        ELSE { Ignore all other transaction states. }
        CASEND;
      IFEND;

    UNTIL ((found_entry = 0) OR (entry_index = 1 + p_cpu_queue^.queue_header.number_of_monitor_queue_entries +
          p_cpu_queue^.queue_header.number_of_task_queue_entries));

  PROCEND time_out_requests;

?? TITLE := '    [XDCL] dfp$wait_until_leveler_complete', EJECT ??

  PROCEDURE [XDCL] dfp$wait_until_leveler_complete
    (    p_cpu_queue: ^dft$cpu_queue;
     VAR leveler_complete: boolean);

    VAR
      task_executing: boolean,
      waits: 0 .. 20;

    jmp$ready_job_leveler_task (task_executing);
    IF NOT task_executing THEN
      leveler_complete := TRUE;
      RETURN;
    IFEND;

    IF dfv$file_server_debug_enabled THEN
      display (' Waiting for job leveler to complete');
    IFEND;

    waits := 0;

  /wait_for_job_leveler/
    WHILE NOT p_cpu_queue^.queue_header.leveler_status.cleanup_completed DO
      waits := waits + 1;
      jmp$ready_job_leveler_task (task_executing);
      IF task_executing THEN
        pmp$wait (15000, 15000);
      ELSE
        EXIT /wait_for_job_leveler/;
      IFEND;
      IF waits >= 20 THEN
        EXIT /wait_for_job_leveler/;
      IFEND;
      #SPOIL (p_cpu_queue^.queue_header.leveler_status);
    WHILEND /wait_for_job_leveler/;

    IF waits < 20 THEN
       leveler_complete := TRUE;
       IF dfv$file_server_debug_enabled THEN
         display (' Job leveler has completed.');
       IFEND;
    ELSE
      leveler_complete := FALSE;
      display (' Deadman time out waiting for job leveler to complete.');
      log_display ($pmt$ascii_logset[pmc$system_log],
         ' Deadman time out waiting for job leveler to complete.');
    IFEND;

  PROCEND dfp$wait_until_leveler_complete;

MODEND dfm$manage_server_connection;

*DECK DECK=DFM$MANFS_PROGRAM_DESCRIPTOR EXPAND=TRUE
create_program_description name=(manage_file_server, manfs),..
      library=:$system.$system.file_server.osf$manage_file_server,..
      starting_procedure=dfp$manage_file_server, ..
      load_map=$null, load_map_option=none,..
      termination_error_level=warning, debug_mode=off
*DECK DECK=DFM$MANFS_TASK_SERVICES_PD EXPAND=TRUE
create_program_description name=(manage_file_server, manfs),..
      library=osf$task_services_library , ..
      starting_procedure=dfp$manage_file_server, ..
      load_map=$null, load_map_option=none,..
      termination_error_level=warning, debug_mode=off
*DECK DECK=DFM$MAXIMIZE_TRANSACTION_RATE EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE dfm$maximize_transaction_rate;

{ PURPOSE:
{    The purpose of this module is to attempt to maximize the transaction
{    rate between client and server mainframes. It is intended for use by
{    project members to determine the effect of modifications or different
{    configurations upon the transaction rate displayed by the VED FS
{    operator command.
{
{ NOTES:
{
{    The file is written and then read the specified number_of_passes times.
{
{    Maximization is sought by reading from the server directly into memory.
{
{    It is expected that this program will be driven by a command sequence
{    such as:
{
{         FOR i = 1 TO 16 DO
{           JOB sm='?'
{             create_variable ign kind=status
{             setcl a=$system.osf$builtin_library status=ign
{             setpa al=cyf$run_time_library status=ign
{             dfp$ptu $fname(':testing.$system.test_'//'?$STRREP(i)?')
{           JOBEND
{         FOREND
{


?? NEWTITLE := '    Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc amp$fetch_access_information
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc amp$return
*copyc amp$set_segment_position
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc fsp$close_file
*copyc fsp$open_file
*copyc i#current_sequence_position
*copyc i#ptr
*copyc mmp$free_pages
*copyc mmp$set_access_selections
*copyc mmp$write_modified_pages
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter


  CONST
    clc$input_buffer_size = 8192;

  TYPE
    clt$get_control_record = record
      access_level: amt$access_level,
      file_id: amt$file_identifier,
      sequence_pointer: ^SEQ ( * ),
      sequence_size: amt$file_byte_address,
      bytes_remaining: amt$file_byte_address,
      file_position: amt$file_position,
      buffer_first_byte_address: integer,
      buffer_last_byte_address: integer,
    recend;

?? TITLE := '    open_it', EJECT ??

  PROCEDURE open_it
    (    local_file_name: amt$local_file_name;
         command_name: string ( * <= osc$max_name_size);
         read_not_write: boolean;
     VAR file_open: boolean;
     VAR file_position: amt$file_position;
     VAR get_control: clt$get_control_record;
     VAR status: ost$status);

{ NOTES:
{    1. This procedure originated from the SCL clp$dump_file_command, so
{       it may be a bit more restrictive than required here. The original
{       code was copied then somewhat modified so any errors are of a local
{       origin.

    VAR
      file_attachment: array [1 .. 3] of fst$attachment_option,
      device_assigned: boolean,
      fetch_access_selections: array [1 .. 2] of amt$access_info,
      attribute_override: array [1 .. 3] of fst$file_cycle_attribute,
      file_organization_selector: [STATIC, READ, oss$job_paged_literal] array [boolean] of
            amt$file_organization := [amc$sequential, amc$byte_addressable],
      ignore_status: ost$status,
      segment_pointer: amt$segment_pointer;

    file_attachment [1].selector := fsc$access_and_share_modes;
    file_attachment [1].access_modes.selector := fsc$specific_access_modes;
    file_attachment [1].share_modes.selector := fsc$specific_share_modes;
    file_attachment [2].selector := fsc$open_share_modes;
    IF read_not_write THEN
      file_attachment [1].access_modes.value := $fst$file_access_options [fsc$read];
      file_attachment [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
      file_attachment [2].open_share_modes := $fst$file_access_options [fsc$read, fsc$execute];
    ELSE
      file_attachment [1].access_modes.value := $fst$file_access_options [fsc$read, fsc$append, fsc$shorten];
      file_attachment [1].share_modes.value := $fst$file_access_options [];
      file_attachment [2].open_share_modes := $fst$file_access_options [fsc$read, fsc$execute];
    IFEND;
    file_attachment [3].selector := fsc$create_file;
    file_attachment [3].create_file := TRUE;

    attribute_override [1].selector := fsc$block_type;
    attribute_override [1].block_type := amc$system_specified;
    attribute_override [2].selector := fsc$record_type;
    attribute_override [2].record_type := amc$undefined;
    attribute_override [3].selector := fsc$file_organization;
    attribute_override [3].file_organization := amc$sequential;
    get_control.access_level := amc$segment;

    fsp$open_file (local_file_name, get_control.access_level, ^file_attachment, NIL, NIL, NIL,
          ^attribute_override, get_control.file_id, status);
    IF NOT status.normal AND (read_not_write) THEN
      IF status.condition = ame$new_file_requires_append THEN
        osp$set_status_abnormal ('CL', cle$file_never_opened, local_file_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, command_name, status);
      IFEND;
      RETURN;
    IFEND;
    file_open := TRUE;

    fetch_access_selections [1].key := amc$file_position;
    fetch_access_selections [2].key := amc$eoi_byte_address;
    amp$fetch_access_information (get_control.file_id, fetch_access_selections, status);
    IF NOT status.normal THEN
      fsp$close_file (get_control.file_id, ignore_status);
      file_open := FALSE;
      RETURN;
    IFEND;
    IF fetch_access_selections [1].item_returned THEN
      file_position := fetch_access_selections [1].file_position;
    ELSE
      file_position := amc$boi;
    IFEND;
    amp$get_segment_pointer (get_control.file_id, amc$sequence_pointer, segment_pointer, status);
    IF status.normal THEN
      get_control.sequence_pointer := segment_pointer.sequence_pointer;
      get_control.bytes_remaining := fetch_access_selections [2].eoi_byte_address -
            i#current_sequence_position (get_control.sequence_pointer);
    ELSEIF status.condition = ame$read_of_empty_segment THEN
      status.normal := TRUE;
      get_control.sequence_pointer := NIL;
      get_control.bytes_remaining := 0;
    ELSE
      fsp$close_file (get_control.file_id, ignore_status);
      file_open := FALSE;
      RETURN;
    IFEND;


    get_control.file_position := file_position;

  PROCEND open_it;

?? TITLE := '    close_for_get', EJECT ??

  PROCEDURE close_for_get
    (VAR get_control: clt$get_control_record;
     VAR status: ost$status);

    VAR
      segment_pointer: amt$segment_pointer;

    IF (get_control.access_level = amc$segment) AND (get_control.sequence_pointer <> NIL) THEN
      segment_pointer.kind := amc$sequence_pointer;
      segment_pointer.sequence_pointer := get_control.sequence_pointer;
      amp$set_segment_position (get_control.file_id, segment_pointer, status);
    IFEND;

    fsp$close_file (get_control.file_id, status);

  PROCEND close_for_get;
?? OLDTITLE ??
?? TITLE := '    [INLINE] min ', EJECT ??

  FUNCTION [INLINE] min
    (    number_one: integer;
         number_two: integer): integer;

    IF number_one < number_two THEN
      min := number_one;
    ELSE
      min := number_two;
    IFEND;
  FUNCEND min;

?? TITLE := '  Maximize transaction rate', EJECT ??

  PROGRAM dfp$mtr
    (    ppp: clt$parameter_list;
     VAR status: ost$status);

{ pdt mtr_pdt (
{ file_name,fn,f: file = $required
{ size, s: integer = 409600
{ mode, m: key normal, n, sequential, s = n
{ number_of_passes, nop, number, n: integer = 1000
{ status)

?? PUSH (LISTEXT := ON) ??

  VAR
    mtr_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^mtr_pdt_names, ^mtr_pdt_params];

  VAR
    mtr_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 12] of
      clt$parameter_name_descriptor := [['FILE_NAME', 1], ['FN', 1], ['F', 1], ['SIZE', 2], ['S', 2], ['MODE'
      , 3], ['M', 3], ['NUMBER_OF_PASSES', 4], ['NOP', 4], ['NUMBER', 4], ['N', 4], ['STATUS', 5]];

  VAR
    mtr_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of clt$parameter_descriptor := [

{ FILE_NAME FN F }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ SIZE S }
    [[clc$optional_with_default, ^mtr_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, clc$min_integer, clc$max_integer]],

{ MODE M }
    [[clc$optional_with_default, ^mtr_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [^mtr_pdt_kv3,
      clc$keyword_value]],

{ NUMBER_OF_PASSES NOP NUMBER N }
    [[clc$optional_with_default, ^mtr_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, clc$min_integer, clc$max_integer]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    mtr_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := ['NORMAL','N',
      'SEQUENTIAL','S'];

  VAR
    mtr_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (6) := '409600';

  VAR
    mtr_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := 'n';

  VAR
    mtr_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := '1000';

?? POP ??

    VAR
      ap: ^array [ * ] of char,
      byte_size: amt$file_byte_address,
      byte_address_specified: boolean,
      c: char,
      command_name: ost$name,
      count: integer,
      eoi: amt$file_byte_address,
      file_id: amt$file_identifier,
      file_open: boolean,
      file_position: amt$file_position,
      get_control: clt$get_control_record,
      local_file_name: amt$local_file_name,
      mode_name: ost$name,
      number_of_passes: integer,
      read_count: amt$file_byte_address,
      seqp: ^SEQ ( * ),
      specified_size: amt$file_byte_address,
      value: clt$value,
      write_count: amt$file_byte_address;

    clp$scan_parameter_list (ppp, mtr_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('FILE_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    local_file_name := value.file.local_file_name;

    clp$get_value ('SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    specified_size := value.int.value;

    clp$get_value ('MODE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    mode_name := value.name.value;

    clp$get_value ('NUMBER_OF_PASSES', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    number_of_passes := value.int.value;

    byte_size := 4096;

    open_it (local_file_name, 'MAX_TRANS_RATE', FALSE, file_open, file_position,
          get_control, status);
    IF (NOT status.normal) OR (NOT file_open) THEN
      RETURN;
    IFEND;

    file_id := get_control.file_id;
    seqp := get_control.sequence_pointer;
    eoi := specified_size;

    RESET seqp;
    write_count := 0;

    WHILE write_count < eoi DO
      IF (write_count + byte_size <= eoi) THEN
        NEXT ap: [1 .. byte_size] IN seqp;
      ELSE
        NEXT ap: [1 .. (eoi - write_count)] IN seqp
      IFEND;
      IF ap <> NIL THEN
        ap^ [1] := mode_name (1);
      IFEND;
      write_count := write_count + byte_size;
    WHILEND;

    RESET seqp;
    mmp$write_modified_pages (seqp, eoi, osc$wait, status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF status.normal THEN
      close_for_get (get_control, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    {  Open for write to free pages.
    open_it (local_file_name, 'PTU', FALSE, file_open, file_position, get_control, status);
    IF (NOT status.normal) OR (NOT file_open) THEN
      RETURN;
    IFEND;

    file_id := get_control.file_id;
    seqp := get_control.sequence_pointer;
    eoi := get_control.bytes_remaining;

    IF (mode_name (1) = 'S') THEN
      mmp$set_access_selections (seqp, mmc$as_sequential, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    FOR count := 1 TO number_of_passes DO

      RESET seqp;
      read_count := 0;

      WHILE read_count < eoi DO
        IF (read_count + byte_size <= eoi) THEN
          NEXT ap: [1 .. byte_size] IN seqp;
        ELSE
          NEXT ap: [1 .. (eoi - read_count)] IN seqp
        IFEND;
        IF ap <> NIL THEN
          c := ap^ [1];
        IFEND;
        read_count := read_count + 4096;
      WHILEND;

      RESET seqp;
      mmp$free_pages (seqp, eoi, osc$wait, status);

      IF NOT status.normal THEN
        RETURN;
      IFEND;

    FOREND;
    close_for_get (get_control, status);

  PROCEND dfp$mtr;

MODEND dfm$maximize_transaction_rate;

*DECK DECK=DFM$MOCK_DRIVER EXPAND=TRUE
?? RIGHT := 110 ??
MODULE dfm$mock_driver;
{
{ This module contains code to simulate the file server driver.
{ This allows some testing of file server code in either a closed
{ shop environment, or in a hands on environment for which there is no
{ physical connection.
{ Currently the only data that may be moved must be in the server
{ wired segment and established by remote procedure call.
{
?? PUSH (LISTEXT := ON) ??
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc dfc$poll_constants
*copyc dfd$request_package
*copyc dfp$determine_client_status
*copyc dfi$display
*copyc dfe$error_condition_codes
*copyc dfp$fetch_qit
*copyc dfp$fetch_queue_entry
*copyc dfp$process_task_request
*copyc dfp$record_transaction_data
*copyc dfp$set_driver_active
*copyc dfp$verify_system_administrator
*copyc dfs$server_wired
*copyc dft$assign_queue_entry_status
*copyc dfv$server_wired_heap
*copyc osp$set_status_abnormal
*copyc ost$caller_identifier
*copyc osv$page_size
*copyc pmp$ready_task
*copyc pmp$long_term_wait
?? POP ??

  VAR
    dfv$p_mock_held_over_data_ptrs:  ^array [1 .. * ] of ^ SEQ
           (REP dfc$max_data_record_bytes OF cell) :=    NIL;

?? EJECT ??
{
{  This command provides a means of executing the test driver from
{  a job. Repeated calls must be made to this to continue driving
{  requests. For example:
{   TASK,DRIVER
{       exet sp=dfp$initiate_test_driver  p=' mock_driver,true, 2000'
{   TASKEND

  PROCEDURE [XDCL, #GATE] dfp$initiate_test_driver
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);



{ pdt initiate_test_driver (driver_name, dn: name = $required
{  continue, c: boolean = false
{  wait_time, wt: integer 0 .. 4000000 = 2000
{  status)

?? PUSH (LISTEXT := ON) ??

  VAR
    initiate_test_driver: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^initiate_test_driver_names, ^initiate_test_driver_params];

  VAR
    initiate_test_driver_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
      clt$parameter_name_descriptor := [['DRIVER_NAME', 1], ['DN', 1], ['CONTINUE', 2], ['C', 2], ['WAIT_TIME'
      , 3], ['WT', 3], ['STATUS', 4]];

  VAR
    initiate_test_driver_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
      clt$parameter_descriptor := [

{ DRIVER_NAME DN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ CONTINUE C }
    [[clc$optional_with_default, ^initiate_test_driver_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$boolean_value]],

{ WAIT_TIME WT }
    [[clc$optional_with_default, ^initiate_test_driver_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 4000000]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    initiate_test_driver_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';

  VAR
    initiate_test_driver_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := '2000';

?? POP ??

    VAR
      continue: boolean,
      driver_name: ost$name,
      p_queue_interface_table: dft$p_queue_interface_table,
      wait_time: integer,
      value: clt$value;

    dfp$verify_system_administrator ('INITIATE_TEST_DRIVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, initiate_test_driver, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DRIVER_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    driver_name := value.name.value;
    dfp$fetch_qit (driver_name, p_queue_interface_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('CONTINUE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    continue := value.bool.value;
    IF continue THEN
      clp$get_value ('WAIT_TIME', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      wait_time := value.int.value;
    IFEND;


    dfp$set_driver_active (driver_name, TRUE, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    REPEAT
      dfp$test_driver (p_queue_interface_table);
      IF continue THEN
        pmp$long_term_wait (wait_time, wait_time);
      IFEND;
    UNTIL NOT continue;
  PROCEND dfp$initiate_test_driver;
?? EJECT ??
{ Move the entries from the request buffer to the destination queue.
{ If the destination queue is the server then process the request.

  PROCEDURE [XDCL] dfp$test_driver (p_queue_interface_table:
   dft$p_queue_interface_table);


    VAR
      p_request_buffer: ^dft$request_buffer_directory,
      request_buffer_index: 1 .. dfc$max_request_buffer_entries,
      status: ost$status;


    IF p_queue_interface_table <> NIL THEN
      p_request_buffer := ^p_queue_interface_table^.request_buffer_directory;

    /process_all_requests/
      WHILE p_request_buffer^.inn <> p_request_buffer^.out DO
        #SPOIL (p_request_buffer^.out, p_request_buffer^.inn);
        request_buffer_index := (p_request_buffer^.out + 8) DIV 8;
        IF p_request_buffer^.out = p_request_buffer^.limit THEN
          p_request_buffer^.out := 0;
        ELSE
          p_request_buffer^.out := (p_request_buffer^.out + 8);
        IFEND;
        #SPOIL (p_request_buffer^.out, p_request_buffer^.inn);
        process_request (p_queue_interface_table,
              request_buffer_index, p_request_buffer^.p_request_buffer^.
              request_buffer_entries [request_buffer_index]);
        #SPOIL (p_request_buffer^.out, p_request_buffer^.inn);
      WHILEND /process_all_requests/;
    IFEND;
  PROCEND dfp$test_driver;
?? EJECT ??

  PROCEDURE process_request
    (    p_queue_interface_table: dft$p_queue_interface_table;
         request_buffer_index: 1 .. dfc$max_request_buffer_entries;
     VAR request_buffer_entry: dft$request_buffer_entry);

    VAR
      caller_id: ost$caller_identifier,
      destination_queue_index: dft$queue_index,
      display_length: integer,
      display_string: string (80),
      held_over_data: dft$queue_entry_index,
      mainframe_name: pmt$mainframe_id,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_destination_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_destination_drivr_queue_entry: ^dft$driver_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_driver_queue_header: ^dft$driver_queue_header,
      queue_entry_index: dft$queue_entry_index,
      queue_index: dft$queue_index,
      send_command: boolean,
      server_to_client: boolean,
      status: ost$status;

    #CALLER_ID (caller_id);
    IF request_buffer_entry.queue_index = 0 THEN
      RETURN;
    IFEND;
    display_integer ('* Mock Driver - request buffer index ', request_buffer_index);
    queue_index := request_buffer_entry.queue_index;
    queue_entry_index := request_buffer_entry.queue_entry_index;
    request_buffer_entry.queue_index := 0;

    p_driver_queue_header := ^p_queue_interface_table^.queue_directory.
          driver_queue_pva_directory [queue_index].p_driver_queue^.queue_header;

    { Initialize held over data area.
    IF dfv$p_mock_held_over_data_ptrs = NIL THEN
      ALLOCATE dfv$p_mock_held_over_data_ptrs: [1 .. p_driver_queue_header^.number_of_queue_entries] IN
            dfv$server_wired_heap^;
      FOR held_over_data := 1 TO UPPERBOUND (dfv$p_mock_held_over_data_ptrs^) DO
        dfv$p_mock_held_over_data_ptrs^ [held_over_data] := NIL;
      FOREND;
    IFEND;

    { Get the source queue entry pointers
    dfp$fetch_queue_entry (p_queue_interface_table, queue_index, queue_entry_index, p_driver_queue_entry,
          p_cpu_queue_entry);

    { Get the destination values
    destination_queue_index := p_driver_queue_header^.connection_descriptor.destination.queue_index;
    STRINGREP (display_string, display_length, '  Source queue ', queue_index, ' - Entry ', queue_entry_index,
          ' >-> Destination queue ', destination_queue_index);
    display (display_string (1, display_length));

    dfp$fetch_queue_entry (p_queue_interface_table, destination_queue_index, queue_entry_index,
          p_destination_drivr_queue_entry, p_destination_cpu_queue_entry);

    server_to_client := p_driver_queue_header^.connection_descriptor.source.flags.server_to_client;
    dfp$record_transaction_data (p_destination_drivr_queue_entry^, p_destination_cpu_queue_entry^,
          p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [destination_queue_index].
          p_cpu_queue^.queue_header.transaction_data);
    IF NOT (p_driver_queue_entry^.flags.send_command OR p_driver_queue_entry^.flags.send_data OR
          p_driver_queue_entry^.flags.send_ready_for_data) THEN
      display (' -- ERROR----- REQUEST QUEUED BUT NO FLAGS SET ');
      p_destination_drivr_queue_entry^.flags.subsystem_action := TRUE;
    IFEND;

    send_command := p_driver_queue_entry^.flags.send_command;
    IF p_driver_queue_entry^.flags.send_command THEN
      IF server_to_client THEN
        { Leave the flags alone on the server.
        display_integer ('  Client <--< Server (bytes)', p_driver_queue_entry^.send_buffer_descriptor.
              actual_length);
      ELSE
        p_driver_queue_entry^.flags.buffer_sent := TRUE;
        display_integer ('  Client >--> Server (bytes) ', p_driver_queue_entry^.send_buffer_descriptor.
              actual_length);
      IFEND;
      i#move (p_cpu_queue_entry^.p_send_buffer, p_destination_cpu_queue_entry^.p_receive_buffer,
            p_driver_queue_entry^.send_buffer_descriptor.actual_length);
      p_driver_queue_entry^.flags.send_command := FALSE;
      p_destination_drivr_queue_entry^.flags.buffer_received := TRUE;
    IFEND;
    IF p_driver_queue_entry^.flags.send_data THEN
      IF server_to_client THEN
        display ('  Sending data CLIENT <--< SERVER ');
      ELSE
        display ('  Sending data CLIENT >--> SERVER ');
      IFEND;
      IF p_destination_drivr_queue_entry^.data_descriptor.actual_length = 0 THEN
        display_integer ('  Destination not ready- data i#move to hold over area ',
              (p_driver_queue_entry^.data_descriptor.actual_length DIV 8) * osv$page_size);
        ALLOCATE dfv$p_mock_held_over_data_ptrs^ [queue_entry_index] IN dfv$server_wired_heap^;
        i#move (p_cpu_queue_entry^.p_send_data, dfv$p_mock_held_over_data_ptrs^ [queue_entry_index],
              (p_driver_queue_entry^.data_descriptor.actual_length DIV 8) * osv$page_size);
      ELSE
          display_integer ('  i#move ',
                (p_driver_queue_entry^.data_descriptor.actual_length DIV 8) * osv$page_size);
          i#move (p_cpu_queue_entry^.p_send_data, p_destination_cpu_queue_entry^.p_receive_data,
                (p_driver_queue_entry^.data_descriptor.actual_length DIV 8) * osv$page_size);
          p_destination_drivr_queue_entry^.flags.data_received := TRUE;
      IFEND;
      p_driver_queue_entry^.flags.send_data := FALSE;
      IF server_to_client THEN
        display ('  setting subsystem action on SERVER ');
        p_driver_queue_entry^.flags.subsystem_action := TRUE;
      IFEND;
    IFEND;
    IF p_driver_queue_entry^.flags.send_ready_for_data THEN
      IF server_to_client THEN
        display ('  SERVER ready for data from client');
      ELSE
        display ('  CLIENT ready for data from SERVER ');
      IFEND;
      display_integer ('  i#move from hold over area', (p_driver_queue_entry^.data_descriptor.
            actual_length DIV 8) * osv$page_size);
      i#move (dfv$p_mock_held_over_data_ptrs^ [queue_entry_index], p_cpu_queue_entry^.p_receive_data,
            (p_driver_queue_entry^.data_descriptor.actual_length DIV 8) * osv$page_size);
      FREE dfv$p_mock_held_over_data_ptrs^ [queue_entry_index] IN dfv$server_wired_heap^;
      p_driver_queue_entry^.flags.subsystem_action := TRUE;
      p_driver_queue_entry^.flags.send_ready_for_data := FALSE;
      p_destination_drivr_queue_entry^.flags.ready_for_data_received := TRUE;
    IFEND;
    p_driver_queue_entry^.flags.driver_action := FALSE;
    p_destination_drivr_queue_entry^.flags.subsystem_action := TRUE;

    IF caller_id.ring = 3 THEN
      { The mock driver is running in a hands on environment actually activate
      { the task.
      display_integer ('  readying task.index ', p_destination_cpu_queue_entry^.global_task_id.index);
      pmp$ready_task (p_destination_cpu_queue_entry^.global_task_id, status);
      IF NOT status.normal THEN
        display (' ---- error from pmp$ready_task ---');
        display_status (status);
      IFEND;
    ELSE { stubs environment
      IF NOT server_to_client THEN
        IF send_command THEN
          display ('  Calling dfp$process_task_request on SERVER ');
          IF queue_entry_index = dfc$poll_queue_index THEN
            display ('     Poll task request.');
            mainframe_name := p_queue_interface_table^.queue_directory.
                 cpu_queue_pva_directory [destination_queue_index].p_cpu_queue^.queue_header.
                 destination_mainframe_name;
            dfp$determine_client_status (mainframe_name, status);
          ELSE
            display ('     User request.');
            dfp$process_task_request (p_queue_interface_table, destination_queue_index, queue_entry_index,
                  p_destination_drivr_queue_entry, p_destination_cpu_queue_entry, status);
            display ('  Server request returned ');
          IFEND;
          IF NOT status.normal THEN
            display (' ---- ERROR from dfp$process_task_request ---');
            display_status (status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND process_request;

MODEND dfm$mock_driver;
*DECK DECK=DFM$MONITOR_INFO_COLLECTION EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE dfm$monitor_info_collection;
{ Purpose:
{    This module contains the variables and procedures to manage data collection
{   from within the monitor.
?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_wired
?? POP ??
?? TITLE := '    Global Variables', EJECT ??

  VAR
    dfv$file_server_info_enabled: [XDCL, #GATE, oss$mainframe_wired] boolean := FALSE;

MODEND dfm$monitor_info_collection;
*DECK DECK=DFM$MONITOR_PROCESS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := ' NOS/VE File Server : monitor_process', EJECT ??
MODULE dfm$monitor_process;
{
{  This module contains code used by the monitor.
{  Also included in this module, are variables that must be available to
{  monitor.
{
?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc dfd$driver_queue_types
*copyc dfp$clear_task_inhibit_access
*copyc dfp$process_server_response_a
*copyc dfp$set_task_segment_state
*copyc dfs$server_wired
*copyc dft$client_job_id
*copyc dft$defined_server_translation
*copyc dft$esm_definition_table
*copyc dft$mainframe_task_status
*copyc dft$poll_header
*copyc dft$queue_interface_directory
*copyc dft$rb_file_server_request
*copyc dfp$process_request_timeout
*copyc dfp$verify_segments_recovered
*copyc jmv$ijl_p
*copyc jmv$null_ijl_ordinal
*copyc jmp$get_ijle_p
*copyc mmp$restart_server_request
*copyc mtp$error_stop
*copyc oss$mainframe_wired_literal
*copyc ost$cpu_state_table
*copyc ost$heap
*copyc ost$signature_lock
*copyc tmp$check_taskid
*copyc pmt$task_status
?? POP ??
?? TITLE := '     Global Variables', EJECT ??

  VAR
    dfv$job_recovery_enabled: [XDCL, #GATE, dfs$server_wired] boolean := TRUE,
    dfv$rebuild_client_tasks_stat_p: [XDCL, #GATE, dfs$server_wired] ^array [ * ] of
         dft$mainframe_task_status := NIL,
    dfv$family_access_enabled: [XDCL, #GATE, dfs$server_wired] boolean := TRUE;

*copyc dfc$queue_request_constants

{ This variable defines the amount of time a request can "block" the request buffer before task services
{ queueing is suspended and the "blocking" mainframe is timed out.  It is initialized to the constant
{ computed above.
  VAR
    dfv$task_queue_timeout_interval: [XDCL, #GATE, dfs$server_wired] integer := dfc$maximum_delay_time;

  VAR
    dfv$file_server_debug_enabled : [XDCL, #GATE, dfs$server_wired] boolean := FALSE;

  VAR
    dfv$defined_server_translation: [XDCL, #GATE, dfs$server_wired]
          dft$defined_server_translation :=
          [REP dfc$max_number_of_mainframes of [osc$cyber_180_model_unknown, 0]];

  VAR
    { This is an integer to allow use with sym$system_constant_manager.
    { The true value range is 1 .. dfc$max_job_list_p_array_size
    dfv$maximum_client_job_lists: [XDCL, #GATE, dfs$server_wired] integer := 12;

  VAR
    dfv$monitor_io_start_time: [XDCL, dfs$server_wired] integer;

  VAR
    dfv$p_queue_interface_directory: [XDCL, #GATE, dfs$server_wired]
         dft$p_queue_interface_directory := NIL;

  VAR
    { This lock is to insure that two queues are not being initialized
    {simultaneously.
    dfv$queue_initialization_lock: [XDCL, #GATE, dfs$server_wired] ost$signature_lock := [0];

  VAR
    { This lock is to insure that application is not being added and deleted
    {simultaneously.
    dfv$application_info_lock: [XDCL, #GATE, dfs$server_wired] ost$signature_lock := [0];

  VAR
    { This lock is used to prevent the display manager from attempting to
    { display a mainframe file being created.
    dfv$client_mainframe_file_lock: [XDCL, #GATE, dfs$server_wired] ost$signature_lock := [0];


  VAR
    dfv$server_wired_heap: [XDCL, #GATE, dfs$server_wired] ^ost$heap;

  VAR
    dfv$test_retransmission_count: [XDCL, #GATE, dfs$server_wired] 0 .. 0ffff(16) := 0,
    dfv$test_retransmit_retransmit: [XDCL, #GATE, dfs$server_wired] 0 .. 0ff(16) := 0,
    dfv$trace_count : [XDCL, #GATE, dfs$server_wired] integer := 0;


  VAR
   { This variable allows testing of all of the permanent file requests
   { without the memory manager code.
    dfv$use_server_io: [XDCL, #GATE, dfs$server_wired] boolean := TRUE;

  VAR
    dfv$p_esm_definition_table: [XDCL, #GATE, dfs$server_wired]
         ^dft$esm_definition_table_entry := NIL;

  VAR
    dfv$false_queue_entry_flags: [XDCL, #GATE, READ, oss$mainframe_wired_literal] dft$queue_entry_flags :=
          [FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
          FALSE, FALSE];

  VAR
    dfv$active_queue_entry_flags: [XDCL, #GATE, READ, oss$mainframe_wired_literal] dft$queue_entry_flags :=
          [TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
          FALSE, FALSE];
  VAR
    dfv$send_command_flags: [XDCL, #GATE, READ, oss$mainframe_wired_literal] dft$queue_entry_flags :=
          [TRUE, TRUE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
          FALSE, FALSE];

  VAR
    dfv$send_command_and_data_flags: [XDCL, #GATE, READ, oss$mainframe_wired_literal] dft$queue_entry_flags :=
          [TRUE, TRUE, FALSE, FALSE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
          FALSE, FALSE];

  VAR
    dfv$send_ready_for_data_flags: [XDCL, #GATE, READ, oss$mainframe_wired_literal] dft$queue_entry_flags :=
          [TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
          FALSE, FALSE];

  VAR
    dfv$null_request_buffer_entry: [XDCL, #GATE, READ, oss$mainframe_wired_literal]
          dft$request_buffer_entry :=
          [[FALSE, FALSE, 0], 0, [[0, 0], dfc$null_state], 0, 0];
  VAR
    dfv$server_state_string: [XDCL, READ, #GATE, oss$mainframe_wired_literal] array
          [dfc$active .. dfc$deleted] of string (17) := ['ACTIVE', 'DEACTIVATED', 'INACTIVE',
          'AWAITING_RECOVERY', 'RECOVERING', 'TERMINATED', 'DELETED'];



  VAR
    dfv$display_poll : [XDCL, #GATE, dfs$server_wired] boolean := FALSE,
    dfv$poll_type_string: [XDCL, READ, #GATE, oss$mainframe_wired_literal] array
          [dfc$normal_poll .. dfc$recovery_complete_reply] of string (24) := ['normal_poll',
          'verify_served_family', 'verify_queue', 'deactivate_complete', 'recovery_complete',
          'deactivate_server', 'poll_reply', 'verify_family_reply', 'verify_queue_reply',
          'deactivate_reply', 'req_verify_served_family', 'recovery_complete_reply'];


?? TITLE := '  [XDCL] dfp$mtr_file_server_request ', EJECT ??
   PROCEDURE [XDCL] dfp$mtr_file_server_request (
     VAR rb: dft$rb_file_server_request;
         cst_p: ^ost$cpu_state_table);


  VAR
    ijle_p: ^jmt$initiated_job_list_entry;

   rb.status.normal := TRUE;
   CASE rb.request OF
   = dfc$fsr_restart_server_request =
    mmp$restart_server_request (rb.p_cpu_queue_entry, rb.remote_request);

   = dfc$fsr_term_client_tasks =
     IF rb.cpu_queue_entry_p^.processor_type = dfc$task_services THEN
       tmp$check_taskid (rb.cpu_queue_entry_p^.global_task_id, tmc$opt_return, rb.status);
     IFEND;
     IF rb.status.normal THEN
       dfp$process_server_response_a (^rb.one_word_response, rb.queue_interface_table_p, rb.status);
     IFEND;

   = dfc$fsr_request_timeout =
     dfp$process_request_timeout (rb.p_queue_interface_table, rb.queue_index, rb.queue_entry_index);
   = dfc$fsr_set_task_segment_state =
     dfp$set_task_segment_state (tmc$fnx_system, {ijle_p} NIL, jmv$null_ijl_ordinal,
        rb.inhibit_access_work, rb.terminate_access_work);
   = dfc$fsr_set_job_segment_state =
     jmp$get_ijle_p (rb.ijl_ordinal, ijle_p);
     dfp$set_task_segment_state (tmc$fnx_job, ijle_p, rb.ijl_ordinal, rb.job_inhibit_access_work,
        rb.job_terminate_access_work);
   = dfc$fsr_verify_sdtx_recovery =
     jmp$get_ijle_p (rb.recovered_job_ijl_ordinal, ijle_p);
     dfp$verify_segments_recovered (tmc$fnx_job, ijle_p, rb.recovered_job_ijl_ordinal,
        rb.recovered_mainframe);
   = dfc$fsr_clear_inhibit_access =
     jmp$get_ijle_p (rb.clear_ijl_ordinal, ijle_p);
     dfp$clear_task_inhibit_access (tmc$fnx_job, ijle_p, rb.clear_ijl_ordinal, rb.clear_inhibit_work);
   ELSE
     mtp$error_stop ('UNKNOWN SERVER MTR REQUEST');
   CASEND;
  PROCEND dfp$mtr_file_server_request;
MODEND dfm$monitor_process;
*DECK DECK=DFM$MONITOR_STUB EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: Monitor_stub', EJECT ??
MODULE dfm$monitor_stub;
{  This module provides a stub to allow the same code to be linked into
{  monitor, task services, and a stub environment
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
?? POP ??

  PROCEDURE [XDCL] dfp$test_driver (p_queue_interface_table:
   dft$p_queue_interface_table);

  PROCEND dfp$test_driver;
MODEND dfm$monitor_stub;
*DECK DECK=DFM$MTR_SERVED_FAMILY_MANAGER EXPAND=TRUE
*copyc osd$default_pragmats
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: Client: mtr_served_family_manager ', EJECT ??
MODULE dfm$mtr_served_family_manager;
{
{  This module provides for storing the pointer to the server family table
{  root, so that is is available both to monitor and task services.
{

?? NEWTITLE := '    Global Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfs$server_wired
?? POP ??
*copyc dft$served_family_table
*copyc dft$read_write_lock
*copyc dft$served_family_table_index
?? TITLE := '    Global Variables ', EJECT ??

  VAR
    dfv$served_family_table_root: [XDCL, #GATE, dfs$server_wired]
          dft$served_family_table_root := [FALSE, 0, NIL];
  VAR
    { This is an integer to allow use with sym$system_constant_manager
    { The true value range is dft$family_pointer_index
    dfv$number_served_family_lists: [XDCL, #GATE, dfs$server_wired] integer := 3,
    dfv$served_family_table_lock: [XDCL, #GATE, dfs$server_wired] dft$read_write_lock := [0, 0, 0, [0]];

MODEND dfm$mtr_served_family_manager;

*DECK DECK=DFM$OPERATOR_DISPLAYS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File Server : VED FS Display', EJECT ??
MODULE dfm$operator_displays;

{   PURPOSE:
{     This module contains procedures that drive the file server displays.
{     This provides common interfaces for displaying both to the operator
{     console and to a file.
{   NOTE:
{
{ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
{     Test Tool decks TTM#CHECK_FILE_SERVER_STATE and TTM$UNDO_SERVER are VERY
{     dependent upon the format of the generated display. Any change to this
{     deck may cause one or more of the DF System Tests to fail. BEFORE
{     TRANSMITTING ANY CHANGE TO THIS DECK, RUN ALL OF THE DF SYSTEM TESTS !
{ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfi$display
*copyc dft$display_identifier
*copyc ofd$type_definition
*copyc ofe$error_codes
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc ost$status
*copyc ost$string
*copyc pmt$condition
*copyc pmt$condition_information
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$new_display_page
*copyc clp$put_display
*copyc dfp$display_client_mainframes
*copyc dfp$display_queues
*copyc dfp$display_served_family_table
*copyc dfv$file_server_debug_enabled
*copyc dpp$clear_window
*copyc dpp$put_next_line
*copyc ofp$build_system_line
*copyc ofp$open_display
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$get_cause_of_idle
*copyc pmp$continue_to_cause

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] dfp$file_server_display ', EJECT ??

  PROCEDURE [XDCL] dfp$file_server_display
    (    wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure provides clean-up processing when a task abort occurs.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF wid = 0 THEN
        clp$close_display (display_identifier.display_control, ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    VAR
      display_identifier: dft$display_identifier,
      idle_code: syt$180_idle_code,
      display_line: string (80),
      ignore_status: ost$status,
      message_written: boolean,
      nothing_to_display: [READ, oss$job_paged_literal] string (56) :=
            '                        *** No File Server Defined. ***',
      title: [READ, oss$job_paged_literal] string (19) :=
            'File Server Display';

    status.normal := TRUE;
    message_written := FALSE;
    IF wid = 0 THEN
      osp$establish_condition_handler (^abort_handler, TRUE);
      display_identifier.display_type := dfc$listing_display;
    ELSE
      display_identifier.display_type := dfc$console_display;
      display_identifier.wid := wid;
    IFEND;

    IF initial_call THEN
      ofp$open_display (file_name, wid, dpc$wc_sharing, dpc$wk_table, title,
          display_identifier.display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF wid <> 0 THEN
      dpp$clear_window (wid, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$display_queues (display_identifier, message_written, ignore_status);

    IF message_written THEN
      dfp$display (' ', display_identifier, status);
    IFEND;

    dfp$display_served_family_table (display_identifier, message_written, ignore_status);

    IF message_written THEN
      dfp$display (' ', display_identifier, status);
    IFEND;

    IF dfv$file_server_debug_enabled THEN
      osp$get_cause_of_idle (idle_code);
      IF (idle_code = syc$ic_system_terminated) THEN
        dfp$display (' ', display_identifier, status);
        dfp$display (' CLIENT MAINFRAME DISPLAY DISABLED DURING TERMINATE_SYSTEM ',
            display_identifier, status);
      ELSE
        dfp$display_client_mainframes (display_identifier, message_written, ignore_status);
      IFEND;
    IFEND;

    IF NOT message_written THEN
      dfp$display (' ', display_identifier, status);
      dfp$display (nothing_to_display, display_identifier, status);
    IFEND;

    IF wid = 0 THEN
      clp$close_display (display_identifier.display_control, ignore_status);
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND dfp$file_server_display;
?? TITLE := '[XDCL] dfp$display ', EJECT ??

  PROCEDURE [XDCL] dfp$display
    (    s: string ( * <= 125);
     VAR display_identifier: dft$display_identifier;
     VAR status: ost$status);

    status.normal := TRUE;
    CASE display_identifier.display_type OF
    = dfc$console_display =
      dpp$put_next_line (display_identifier.wid, s, status);
    = dfc$listing_display =
      clp$put_display (display_identifier.display_control, s, clc$trim, status);
    = dfc$trace_display =
      display (s);
    ELSE
    CASEND;

  PROCEND dfp$display;
?? OLDTITLE ??
?? OLDTITLE ??
MODEND dfm$operator_displays;
*DECK DECK=DFM$PERFORMANCE_TEST_UTILITY EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE dfm$performance_test_utility;

{ PURPOSE:
{    The purpose of this module is to provide timing statistics for io
{    operations (read, write) upon a file of a specified size and using
{    a selected io mode (normal, sequential, advised).
{
{    Although this module was written to generate timings for operations upon
{    served files, the specified file need not be a served file.

?? NEWTITLE := '    Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc amp$fetch_access_information
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$put_next
*copyc amp$return
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc dfi$display
*copyc i#current_sequence_position
*copyc i#ptr
*copyc mmp$advise_in
*copyc mmp$advise_out
*copyc mmp$advise_out_in
*copyc mmp$free_pages
*copyc mmp$write_modified_pages
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
*copyc pfp$attach
*copyc pmp$get_legible_date_time
*copyc pmp$get_task_cp_time

*copyc dfi$fsp_open_close

?? OLDTITLE ??
?? TITLE := '    [INLINE] min ', EJECT ??

  FUNCTION [INLINE] min
    (    number_one: integer;
         number_two: integer): integer;

    IF number_one < number_two THEN
      min := number_one;
    ELSE
      min := number_two;
    IFEND;
  FUNCEND min;

?? TITLE := '  performance test utility', EJECT ??

  PROGRAM dfp$ptu
    (    ppp: clt$parameter_list;
     VAR status: ost$status);


{ pdt ptu_pdt (
{ file_name,fn,f: file = $required
{ io_operation,io: key read,r ,write, w = read
{ mode,m: key normal, n, sequential, s, advise, a = n
{ size, s: integer
{ retry_count,rc, number, n: integer = 1
{ bite_size,bs: integer = 4096
{ advise_look_ahead, ala: integer = 3
{ advise_size, as : integer = 14000(16)
{ minimum_advise_size, mas: integer = 4000(16)
{ write_modified_pages, wmp: boolean = TRUE
{ free_pages, fp: boolean = TRUE
{ report_file_name, rfn: file = $user.ptu_report
{ open: key fsp$open_file, amp$open = fsp$open_file
{ status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    ptu_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^ptu_pdt_names, ^ptu_pdt_params];

  VAR
    ptu_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 29] of
  clt$parameter_name_descriptor := [['FILE_NAME', 1], ['FN', 1], ['F', 1], ['IO_OPERATION', 2], ['IO', 2], [
  'MODE', 3], ['M', 3], ['SIZE', 4], ['S', 4], ['RETRY_COUNT', 5], ['RC', 5], ['NUMBER', 5], ['N', 5], [
  'BITE_SIZE', 6], ['BS', 6], ['ADVISE_LOOK_AHEAD', 7], ['ALA', 7], ['ADVISE_SIZE', 8], ['AS', 8], [
  'MINIMUM_ADVISE_SIZE', 9], ['MAS', 9], ['WRITE_MODIFIED_PAGES', 10], ['WMP', 10], ['FREE_PAGES', 11], ['FP'
  , 11], ['REPORT_FILE_NAME', 12], ['RFN', 12], ['OPEN', 13], ['STATUS', 14]];

  VAR
    ptu_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 14] of clt$parameter_descriptor := [

{ FILE_NAME FN F }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ IO_OPERATION IO }
    [[clc$optional_with_default, ^ptu_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [^ptu_pdt_kv2,
  clc$keyword_value]],

{ MODE M }
    [[clc$optional_with_default, ^ptu_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [^ptu_pdt_kv3,
  clc$keyword_value]],

{ SIZE S }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, clc$min_integer,
  clc$max_integer]],

{ RETRY_COUNT RC NUMBER N }
    [[clc$optional_with_default, ^ptu_pdt_dv5], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, clc$min_integer, clc$max_integer]],

{ BITE_SIZE BS }
    [[clc$optional_with_default, ^ptu_pdt_dv6], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, clc$min_integer, clc$max_integer]],

{ ADVISE_LOOK_AHEAD ALA }
    [[clc$optional_with_default, ^ptu_pdt_dv7], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, clc$min_integer, clc$max_integer]],

{ ADVISE_SIZE AS }
    [[clc$optional_with_default, ^ptu_pdt_dv8], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, clc$min_integer, clc$max_integer]],

{ MINIMUM_ADVISE_SIZE MAS }
    [[clc$optional_with_default, ^ptu_pdt_dv9], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, clc$min_integer, clc$max_integer]],

{ WRITE_MODIFIED_PAGES WMP }
    [[clc$optional_with_default, ^ptu_pdt_dv10], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ FREE_PAGES FP }
    [[clc$optional_with_default, ^ptu_pdt_dv11], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ REPORT_FILE_NAME RFN }
    [[clc$optional_with_default, ^ptu_pdt_dv12], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value
  ]],

{ OPEN }
    [[clc$optional_with_default, ^ptu_pdt_dv13], 1, 1, 1, 1, clc$value_range_not_allowed, [^ptu_pdt_kv13,
  clc$keyword_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    ptu_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := ['READ','R','WRITE',
  'W'];

  VAR
    ptu_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of ost$name := ['NORMAL','N',
  'SEQUENTIAL','S','ADVISE','A'];

  VAR
    ptu_pdt_kv13: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := ['FSP$OPEN_FILE',
  'AMP$OPEN'];

  VAR
    ptu_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'read';

  VAR
    ptu_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := 'n';

  VAR
    ptu_pdt_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '1';

  VAR
    ptu_pdt_dv6: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := '4096';

  VAR
    ptu_pdt_dv7: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '3';

  VAR
    ptu_pdt_dv8: [STATIC, READ, cls$pdt_names_and_defaults] string (9) := '14000(16)';

  VAR
    ptu_pdt_dv9: [STATIC, READ, cls$pdt_names_and_defaults] string (8) := '4000(16)';

  VAR
    ptu_pdt_dv10: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'TRUE';

  VAR
    ptu_pdt_dv11: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'TRUE';

  VAR
    ptu_pdt_dv12: [STATIC, READ, cls$pdt_names_and_defaults] string (16) := '$user.ptu_report';

  VAR
    ptu_pdt_dv13: [STATIC, READ, cls$pdt_names_and_defaults] string (13) := 'fsp$open_file';

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      advise_inc: amt$file_byte_address,
      advise_look_ahead: integer,
      advise_size: amt$working_storage_length,
      ap: ^array [ * ] of char,
      buffer_required: boolean,
      byte_size: amt$file_byte_address,
      byte_address_specified: boolean,
      c: char,
      command_name: ost$name,
      count: integer,
      cp_time_begin: pmt$task_cp_time,
      cp_time_end: pmt$task_cp_time,
      cp_time_elapsed: pmt$task_cp_time,
      display_file_id: amt$file_identifier,
      display_file_name: amt$local_file_name,
      elapsed_time: integer,
      eoi: amt$file_byte_address,
      fetch_access_selections: array [1 .. 1] of amt$access_info,
      file_id: amt$file_identifier,
      file_position: amt$file_position,
      free_pages: boolean,
      local_file_name: amt$local_file_name,
      minimum_advise_size: amt$working_storage_length,
      mode_name: ost$name,
      p_times: ^array [ * ] of record
        task: integer,
        monitor: integer,
      recend,
      read_count: amt$file_byte_address,
      read_not_write: boolean,
      retry_count: integer,
      report_file_name: amt$local_file_name,
      segment_pointer: amt$segment_pointer,
      seqp: ^SEQ ( * ),
      specified_size: amt$file_byte_address,
      start_time: integer,
      total_monitor: integer,
      total_task: integer,
      use_fsp$open_file: boolean,
      value: clt$value,
      write_modified_pages: boolean;

    clp$scan_parameter_list (ppp, ptu_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('FILE_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    local_file_name := value.file.local_file_name;

    clp$get_value ('IO_OPERATION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    read_not_write := value.name.value (1) = 'R';

    clp$get_value ('MODE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    mode_name := value.name.value;

    clp$get_value ('BITE_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    byte_size := value.int.value;

    clp$get_value ('SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind = clc$integer_value THEN
      specified_size := value.int.value;
    ELSEIF NOT read_not_write THEN
      osp$set_status_abnormal ('DF', 999, ' SIZE must specified for WRITE.', status);
      RETURN;
    IFEND;
    clp$get_value ('RETRY_COUNT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    retry_count := value.int.value;

    clp$get_value ('ADVISE_LOOK_AHEAD', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    advise_look_ahead := value.int.value;

    clp$get_value ('ADVISE_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    advise_size := value.int.value;

    clp$get_value ('MINIMUM_ADVISE_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    minimum_advise_size := value.int.value;

    clp$get_value ('REPORT_FILE_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    report_file_name := value.file.local_file_name;

    clp$get_value ('WRITE_MODIFIED_PAGES', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    write_modified_pages := value.bool.value;

    clp$get_value ('FREE_PAGES', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    free_pages := value.bool.value;

    clp$get_value ('OPEN', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    use_fsp$open_file := value.name.value (1) = 'F';

    PUSH p_times: [1 .. retry_count];


    elapsed_time := 0;
    FOR count := 1 TO retry_count DO

      IF use_fsp$open_file THEN
        IF (mode_name = 'S') OR (mode_name = 'SEQUENTIAL') THEN
          dfp$fsp_open (local_file_name,  amc$segment, read_not_write, {open_for_attach} TRUE,
                {seq_and_free_behind} TRUE , 'PTU',  file_id, seqp, eoi, status);
        ELSE
          dfp$fsp_open (local_file_name,  amc$segment, read_not_write, {open_for_attach} FALSE,
                {seq_and_free_behind} FALSE, 'PTU',  file_id, seqp, eoi, status);
        IFEND;
      ELSE
        amp$open (local_file_name, amc$segment, NIL, file_id, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        amp$get_segment_pointer (file_id, amc$sequence_pointer, segment_pointer, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        seqp := segment_pointer.sequence_pointer;
        fetch_access_selections [1].key := amc$eoi_byte_address;
        amp$fetch_access_information (file_id, fetch_access_selections, status);
        IF NOT status.normal THEN
          RETURN;
         IFEND;
        eoi := fetch_access_selections [1].eoi_byte_address;
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT read_not_write THEN
        eoi := specified_size;
      IFEND;

      RESET seqp;
      read_count := 0;

      start_time := #free_running_clock (0);
      pmp$get_task_cp_time (cp_time_begin, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (mode_name (1) = 'A') THEN
        advised_io (seqp, byte_size, eoi, minimum_advise_size, advise_size, advise_look_ahead,
             read_not_write, status);
      ELSE
        WHILE read_count < eoi DO
          IF (read_count + byte_size <= eoi) THEN
            NEXT ap: [1 .. byte_size] IN seqp;
          ELSE
            NEXT ap: [1 .. (eoi - read_count)] IN seqp
          IFEND;
          IF ap <> NIL THEN
            IF read_not_write THEN
              c := ap^ [1];
            ELSE
              ap^ [1] := mode_name (1);
            IFEND;
          IFEND;
          read_count := read_count + 4096;
        WHILEND;
      IFEND;

      IF (NOT read_not_write) AND write_modified_pages THEN
        RESET seqp;
        mmp$write_modified_pages (seqp,eoi, osc$wait, status);
      IFEND;

      pmp$get_task_cp_time (cp_time_end, status);
      elapsed_time := elapsed_time + #free_running_clock (0) - start_time;

      IF (NOT read_not_write) AND free_pages THEN
        RESET seqp;
        mmp$free_pages (seqp, eoi, osc$wait, status);
      IFEND;

      IF status.normal THEN
        dfp$fsp_close (file_id, seqp, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF status.normal THEN
        cp_time_elapsed.task_time := cp_time_end.task_time - cp_time_begin.task_time;
        cp_time_elapsed.monitor_time := cp_time_end.monitor_time - cp_time_begin.monitor_time;
{       display_integer (' TASK elapsed time = ', cp_time_elapsed.task_time);
{       display_integer (' MONITOR elapsed time = ', cp_time_elapsed.monitor_time);
      IFEND;

      IF NOT status.normal THEN
        RETURN;
      IFEND;

      p_times^ [count].task := cp_time_elapsed.task_time;
      p_times^ [count].monitor := cp_time_elapsed.monitor_time;


    FOREND;

    IF retry_count > 1 THEN
      total_monitor := 0;
      total_task := 0;
      {Throw away first sample
      FOR count := 2 TO retry_count DO
        total_monitor := total_monitor + p_times^ [count].monitor;
        total_task := total_task + p_times^ [count].task;
      FOREND;

      cp_time_elapsed.monitor_time := total_monitor DIV (retry_count - 1);
      cp_time_elapsed.task_time := total_task DIV (retry_count - 1);

      display_integer ('   Average task time = ',
           cp_time_elapsed.task_time);
      display_integer ('   Average monitor time = ',
           cp_time_elapsed.monitor_time);
    IFEND;

    report (local_file_name, retry_count, eoi, read_not_write, mode_name,
         elapsed_time div retry_count, cp_time_elapsed, advise_size,
         advise_look_ahead, minimum_advise_size, report_file_name, status);

  PROCEND dfp$ptu;

?? TITLE := '    advised_io', EJECT ??

  PROCEDURE advised_io
    (VAR seqp: ^SEQ ( * );
         byte_size: amt$file_byte_address;
         wsl: amt$working_storage_length;
         minimum_size_to_advise: amt$working_storage_length;
         advise_size: amt$working_storage_length;
         advise_look_ahead: integer;
         read_not_write: boolean;
     VAR status: ost$status);

    VAR
      advise_in_length: integer,
      advise_in_wsa: ^cell,
      ap: ^array [ * ] of char,
      c: char,
      ignored_status: ost$status,
      incr: amt$file_byte_address,
      move_wsa: ^cell,
      move_wsl: integer,
      next_move_wsa: ^cell,
      next_move_wsl: integer,
      remains: integer,
      total_advised_in: integer,
      total_wsl_moved: integer,
      wsa: ^cell;

    wsa := seqp;
    total_wsl_moved := 0;
    IF wsl <= advise_size THEN
      move_wsl := wsl;
    ELSE
      move_wsl := advise_size;
    IFEND;
    move_wsa := wsa;

    { compute initial advise in amount
    advise_in_length := min ((wsl - total_wsl_moved), (advise_size * advise_look_ahead));
    advise_in_wsa := wsa;
    IF read_not_write THEN
      mmp$advise_in (advise_in_wsa, advise_in_length, status);
      IF NOT status.normal THEN
        {?     display_status (status);
        RETURN;
      IFEND;
    IFEND;
    total_advised_in := advise_in_length;

    next_move_wsl := move_wsl;
    REPEAT
      remains := move_wsl;
      WHILE remains > 0 DO
        IF move_wsl >= byte_size THEN
          incr := byte_size;
        ELSE
          incr := move_wsl;
        IFEND;
        NEXT ap: [1 .. incr] IN seqp;
        IF ap <> NIL THEN
          IF read_not_write THEN
            c := ap^ [1];
          ELSE
            ap^ [1] := 'A'
          IFEND;
        IFEND;
        remains := remains - incr;
      WHILEND;

      total_wsl_moved := total_wsl_moved + move_wsl;
      next_move_wsa := i#ptr (total_wsl_moved, wsa);
      IF (total_wsl_moved + next_move_wsl) >= wsl THEN
        next_move_wsl := wsl - total_wsl_moved;
      IFEND;
      advise_in_wsa := i#ptr (total_advised_in, wsa);
      advise_in_length := min ((wsl - total_advised_in), advise_size);
 {    display_integer (' mmp$advise_out_in   out:', move_wsl);
 {    display_integer ('     in: ', advise_in_length);
      IF read_not_write THEN
        mmp$advise_out_in (move_wsa, move_wsl, advise_in_wsa, advise_in_length, status);
      ELSE
        mmp$advise_out (move_wsa, move_wsl, status);
      IFEND;
      IF NOT status.normal THEN
        display_status (status);
        RETURN;
      IFEND;
      total_advised_in := total_advised_in + advise_in_length;
      move_wsa := next_move_wsa;
      move_wsl := next_move_wsl;
    UNTIL (total_wsl_moved >= wsl);

  PROCEND advised_io;

?? TITLE := '    report', EJECT ??

  PROCEDURE report
      (    lfn: amt$local_file_name;
           count: integer;
           file_size: amt$file_byte_address;
           read_not_write: boolean;
           mode_name: ost$name;
           wall_elapsed_time: integer;
           cp_elapsed_time: pmt$task_cp_time;
           advise_size: amt$working_storage_length;
           advise_look_ahead: integer;
           minimum_advise_size: amt$working_storage_length;
           report_file_name: amt$local_file_name;
       VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      date_string: ost$date,
      eoi: amt$file_byte_address,
      file_id: amt$file_identifier,
      ignore_status: ost$status,
      io_string: string (5),
      line: string (100),
      line_size: integer,
      mode_string: string (6),
      real_monitor: real,
      real_task: real,
      real_wall: real,
      seqp: ^SEQ ( * ),
      time_string: ost$time;

   CONST
     real_mics_to_seconds = 1.0e6;


    pmp$get_legible_date_time (osc$mdy_date, date_string, osc$hms_time, time_string,
      status);

    dfp$fsp_open (report_file_name, amc$record, {read_not_write} FALSE,
          {open_for_attach} TRUE, {seq_and_free_behind} FALSE,   'PTU', file_id, seqp, eoi, status);
    IF not status.normal THEN
      RETURN;
    IFEND;

    line := '';
    amp$put_next (file_id, ^line, 2, byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    stringrep (line, line_size, ' ptu#date=''', date_string.mdy,
               ''';ptu#time=''', time_string.hms, '''');
    amp$put_next (file_id, ^line, line_size, byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF read_not_write THEN
      io_string := 'READ';
    ELSE
      io_string := 'WRITE';
    IFEND;
    CASE mode_name (1) OF
    = 'A' =
      mode_string := 'ADVISE';
    = 'N' =
      mode_string := 'NORMAL';
    = 'S' =
      mode_string := 'SEQUEN';
    ELSE
      mode_string := '??????';
    CASEND;

    stringrep (line, line_size, ' ptu#file_size=', file_size,
       ';ptu#io_access=''', io_string,
       ''';ptu#mode=''', mode_string, ''';ptu#retry_count=',count);
    amp$put_next (file_id, ^line, line_size, byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

     real_wall := $real(wall_elapsed_time) / real_mics_to_seconds;
     real_monitor := $real(cp_elapsed_time.monitor_time) / real_mics_to_seconds;
     real_task := $real(cp_elapsed_time.task_time) / real_mics_to_seconds;
    stringrep (line, line_size, '  ptu#elapsed_time=''',
      real_wall:9:3, ''';ptu#mon_time=''', real_monitor:9:3,
      ''';ptu#task_time=''', real_task:9:3, '''');
    amp$put_next (file_id, ^line, line_size, byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF mode_name (1) = 'A' THEN
     {output advise parameters
    IFEND;

     dfp$fsp_close ( file_id, seqp, status);

  PROCEND report;

MODEND dfm$performance_test_utility;
*DECK DECK=DFM$PP_MANAGEMENT_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File Server: pp_management_commands', EJECT ??
MODULE dfm$pp_management_commands;
{
{  This module contains procedures which process file server PP management
{  commands for the FILE_SERVER_TEST_UTILITY.
{
?? NEWTITLE := '    Global Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dft$pp_element_reservations
*copyc dft$queue_interface_directory
?? POP ??
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc dfe$error_condition_codes
*copyc dfp$activate_pp
*copyc dfp$change_pp
*copyc dfp$idle_pp
*copyc dfp$load_pp
*copyc dfp$resume_pp
*copyc dfp$set_esm_divisions
*copyc dfp$unload_pp
*copyc dfv$p_queue_interface_directory
*copyc osp$set_status_abnormal
?? TITLE := '    Inline Procedures ', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfi$display
?? POP ??
?? TITLE := ' [XDCL] dfp$activate_pp_command ', EJECT ??
{ The purpose of this routine is to process the file server ACTIVATE_PP command.

  PROCEDURE [XDCL] dfp$activate_pp_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   pdt activate_pp (element_name, en: name = $required
{   use_dma, ud: boolean = true
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      activate_pp: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^activate_pp_names, ^activate_pp_params];

    VAR
      activate_pp_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
            clt$parameter_name_descriptor := [['ELEMENT_NAME', 1], ['EN', 1], ['USE_DMA', 2], ['UD', 2],
            ['STATUS', 3]];

    VAR
      activate_pp_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ ELEMENT_NAME EN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ USE_DMA UD }
      [[clc$optional_with_default, ^activate_pp_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$boolean_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      activate_pp_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

?? POP ??

    VAR
      element: clt$value,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      use_dma: clt$value;

    clp$scan_parameter_list (parameter_list, activate_pp, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('ELEMENT_NAME', 1, 1, clc$low, element, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_value ('USE_DMA', 1, 1, clc$low, use_dma, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    locate_q_directory_entry (element.name.value, p_q_interface_directory_entry, status);
    IF status.normal THEN
      dfp$activate_pp (p_q_interface_directory_entry, use_dma.bool.value, status)
    IFEND;
  PROCEND dfp$activate_pp_command;

?? TITLE := ' [XDCL] dfp$change_pp_command ', EJECT ??
{ The purpose of this routine is to process the file server CHANGE_PP command.

  PROCEDURE [XDCL] dfp$change_pp_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{    pdt change_pp (old_name, on: name = $required
{     new_name, nn: name = $required
{     pp_task, ppt: key send, receive, both = both
{     status)

?? PUSH (LISTEXT := ON) ??

    VAR
      change_pp: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^change_pp_names, ^change_pp_params];

    VAR
      change_pp_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
            clt$parameter_name_descriptor := [['OLD_NAME', 1], ['ON', 1], ['NEW_NAME', 2], ['NN', 2],
            ['PP_TASK', 3], ['PPT', 3], ['STATUS', 4]];

    VAR
      change_pp_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor := [

{ OLD_NAME ON }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ NEW_NAME NN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ PP_TASK PPT }
      [[clc$optional_with_default, ^change_pp_dv3], 1, 1, 1, 1, clc$value_range_not_allowed,
            [^change_pp_kv3, clc$keyword_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      change_pp_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of ost$name := ['SEND',
            'RECEIVE', 'BOTH'];

    VAR
      change_pp_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'both';

?? POP ??


    VAR
      new_name: clt$value,
      old_name: clt$value,
      pp_task: clt$value,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry;

    clp$scan_parameter_list (parameter_list, change_pp, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('OLD_NAME', 1, 1, clc$low, old_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_value ('NEW_NAME', 1, 1, clc$low, new_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    locate_q_directory_entry (old_name.name.value, p_q_interface_directory_entry, status);
    IF status.normal THEN
      clp$get_value ('PP_TASK', 1, 1, clc$low, pp_task, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      dfp$change_pp (p_q_interface_directory_entry, new_name.name.value, pp_task.name.value, status);
    IFEND;
  PROCEND dfp$change_pp_command;

?? TITLE := ' [XDCL] dfp$idle_pp_command ', EJECT ??
{ The purpose of this routine is to process the file server IDLE_PP command.

  PROCEDURE [XDCL] dfp$idle_pp_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);



{  pdt idle_pp (element_name, en: name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      idle_pp: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^idle_pp_names, ^idle_pp_params];

    VAR
      idle_pp_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['ELEMENT_NAME', 1], ['EN', 1], ['STATUS', 2]];

    VAR
      idle_pp_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ ELEMENT_NAME EN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??


    VAR
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, idle_pp, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('ELEMENT_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    locate_q_directory_entry (value.name.value, p_q_interface_directory_entry, status);
    IF status.normal THEN
      dfp$idle_pp (p_q_interface_directory_entry, status);
    IFEND;
  PROCEND dfp$idle_pp_command;

?? TITLE := ' [XDCL] dfp$load_pp_command ', EJECT ??
{ The purpose of this routine is to process the file server LOAD_PP command.

  PROCEDURE [XDCL] dfp$load_pp_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{  pdt load_pp (element_name, en: name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      load_pp: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^load_pp_names, ^load_pp_params];

    VAR
      load_pp_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['ELEMENT_NAME', 1], ['EN', 1], ['STATUS', 2]];

    VAR
      load_pp_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ ELEMENT_NAME EN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??


    VAR
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, load_pp, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('ELEMENT_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    locate_q_directory_entry (value.name.value, p_q_interface_directory_entry, status);
    IF status.normal THEN
      dfp$load_pp (p_q_interface_directory_entry, status);
    IFEND;
  PROCEND dfp$load_pp_command;

?? TITLE := ' [XDCL] dfp$resume_pp_command ', EJECT ??
{ The purpose of this routine is to process the file server RESUME_PP command.

  PROCEDURE [XDCL] dfp$resume_pp_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{  pdt resume_pp (element_name, en: name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      resume_pp: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^resume_pp_names, ^resume_pp_params];

    VAR
      resume_pp_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['ELEMENT_NAME', 1], ['EN', 1], ['STATUS', 2]];

    VAR
      resume_pp_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ ELEMENT_NAME EN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??


    VAR
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, resume_pp, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('ELEMENT_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    locate_q_directory_entry (value.name.value, p_q_interface_directory_entry, status);
    IF status.normal THEN
      dfp$resume_pp (p_q_interface_directory_entry, status);
    IFEND;
  PROCEND dfp$resume_pp_command;

?? TITLE := ' [XDCL] dfp$set_esm_divisions_command ', EJECT ??
{ The purpose of this routine is to process the file server SET_ESM_DIVISIONS command.

  PROCEDURE [XDCL] dfp$set_esm_divisions_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt set_esm_divisions (element_name, en: name = $required
{                        number_of_divisions, nod: integer 1 .. 8 = $required
{                        status)

?? PUSH (LISTEXT := ON) ??

    VAR
      set_esm_divisions: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^set_esm_divisions_names, ^set_esm_divisions_params];

    VAR
      set_esm_divisions_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
            clt$parameter_name_descriptor := [['ELEMENT_NAME', 1], ['EN', 1], ['NUMBER_OF_DIVISIONS', 2],
            ['NOD', 2], ['STATUS', 3]];

    VAR
      set_esm_divisions_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
            clt$parameter_descriptor := [

{ ELEMENT_NAME EN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ NUMBER_OF_DIVISIONS NOD }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 1, 8]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??


    VAR
      element: clt$value,
      divisions: clt$value,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry;

    clp$scan_parameter_list (parameter_list, set_esm_divisions, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('ELEMENT_NAME', 1, 1, clc$low, element, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    locate_q_directory_entry (element.name.value, p_q_interface_directory_entry, status);
    IF status.normal THEN
      clp$get_value ('NUMBER_OF_DIVISIONS', 1, 1, clc$low, divisions, status);
      IF status.normal THEN
        dfp$set_esm_divisions (p_q_interface_directory_entry, divisions.int.value, status);
      IFEND;
    IFEND;
  PROCEND dfp$set_esm_divisions_command;

?? TITLE := ' [XDCL] dfp$unload_pp_command ', EJECT ??
{
{ The purpose of this routine is to process the file server UNLOAD_PP command.

  PROCEDURE [XDCL] dfp$unload_pp_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{  pdt unload_pp (element_name, en: name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      unload_pp: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^unload_pp_names, ^unload_pp_params];

    VAR
      unload_pp_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['ELEMENT_NAME', 1], ['EN', 1], ['STATUS', 2]];

    VAR
      unload_pp_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ ELEMENT_NAME EN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??


    VAR
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, unload_pp, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('ELEMENT_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    locate_q_directory_entry (value.name.value, p_q_interface_directory_entry, status);
    IF status.normal THEN
      dfp$unload_pp (p_q_interface_directory_entry, status);
    IFEND;
  PROCEND dfp$unload_pp_command;

?? TITLE := ' [XDCL] dfp$set_driver_active ', EJECT ??
{ This procedure is left over from the PROTOTYPE, and is moved from
{ dfm$queue_initialization to this module. This process remains to
{ provide continuity. It has not been determined as yet if this process
{ will be required in the new order.

  PROCEDURE [XDCL] dfp$set_driver_active
    (    driver_name: ost$name;
         driver_active: boolean;
     VAR status: ost$status);

    VAR
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      queue_directory_index: dft$queue_directory_index;

    locate_q_directory_entry (driver_name, p_q_interface_directory_entry, status);
    IF status.normal THEN
      p_q_interface_directory_entry^.driver_active := driver_active;
    IFEND;
  PROCEND dfp$set_driver_active;

?? TITLE := ' [XDCL] dfp$store_p_qit ', EJECT ??
{ This procedure is left over from the PROTOTYPE, and is moved from
{ dfm$queue_initialization to this module. This process remains to
{ provide continuity. It will be eliminated in the new order.
{
{ The purpose of this routine is to store the queue interface table pointer
{ into the unit interface table in one step.  This should be done after
{ all mainframes are registred, and after the PP driver is loaded.
{ This allows all mainframes to be configured before pp looks at requests.
{ MODIFIED TO CALL ACTIVATE_PP.

  PROCEDURE [XDCL] dfp$store_p_qit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{  pdt store_p_qit (element_name, en: name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      store_p_qit: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^store_p_qit_names, ^store_p_qit_params];

    VAR
      store_p_qit_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['ELEMENT_NAME', 1], ['EN', 1], ['STATUS', 2]];

    VAR
      store_p_qit_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ ELEMENT_NAME EN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, store_p_qit, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('ELEMENT_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    locate_q_directory_entry (value.name.value, p_q_interface_directory_entry, status);
    IF status.normal THEN
      dfp$activate_pp (p_q_interface_directory_entry, TRUE {use_dma if present} , status);
    IFEND;
  PROCEND dfp$store_p_qit;

?? TITLE := ' locate_q_directory_entry ', EJECT ??

  PROCEDURE locate_q_directory_entry
    (    element_name: cmt$element_name;
     VAR p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
     VAR status: ost$status);


    VAR
      found: boolean,
      index: dft$queue_directory_index;

    { Given the element name of either the send or receive ESM element name,
    { this process will locate the queue directory entry for the file server
    { connection and return a pointer to it.

    found := FALSE;
    p_q_interface_directory_entry := NIL;

    IF dfv$p_queue_interface_directory <> NIL THEN

    /locate_entry/
      FOR index := 1 TO UPPERBOUND (dfv$p_queue_interface_directory^) DO
        IF dfv$p_queue_interface_directory^ [index].driver_name = element_name THEN
          found := TRUE;
          EXIT /locate_entry/;
        IFEND;
      FOREND /locate_entry/;
    IFEND;
    IF found THEN
      status.normal := TRUE;
      p_q_interface_directory_entry := ^dfv$p_queue_interface_directory^ [index];
    ELSE
      osp$set_status_abnormal (dfc$file_server_id, dfe$unknown_driver, element_name, status);
    IFEND;
  PROCEND locate_q_directory_entry;

MODEND dfm$pp_management_commands;
*DECK DECK=DFM$PRESERVED_FAMILY_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: Client: preserved_family_manager', EJECT ??
MODULE dfm$preserved_family_manager;

{
{   The purpose of this module is to manage the 'preserved family table'.
{ The preserved family table is a disk copy of the the served family table,
{ that is used to recover the served family table on a recovery of the client
{ mainframe.
{   The served family is copied to the preserved family table at idle system
{ and terminate system time, and whenever the state changes in the served family
{ table.
{   The preserved family table is a permanent file that resides under
{ the $SYSTEM master catalog. The file is a segment access file.
{ If the preserved family table needs to be read or written prior to the
{ point of commitment then pfp$restricted_attach is used to attach it.
{

?? PUSH (LISTEXT := ON) ??
*copyc amp$close
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$return
*copyc dsp$system_committed
*copyc mmp$lock_segment
*copyc mmp$unlock_segment
*copyc pfp$attach
*copyc pfp$define
*copyc pfp$restricted_attach
*copyc dfi$display
*copyc dfi$log_display
*copyc dfp$clear_read_lock
*copyc dfp$set_read_lock
*copyc dfp$store_served_family_entry
*copyc dfp$verify_system_administrator
*copyc dft$served_family_table
*copyc dfv$file_server_debug_enabled
*copyc dfv$served_family_table_lock
*copyc dfv$served_family_table_root
*copyc dfv$server_state_string
*copyc pfp$purge
*copyc syp$hang_if_system_jrt_set
?? POP ??

  TYPE
    dft$preserved_family_header = record
      version: ost$name,
      valid_flag: string (5),
      number_of_families: 0 .. (dfc$max_family_ptr_array_size * dfc$served_family_list_size),
    recend,

    dft$served_family_array = array [1 .. * ] of dft$served_family_table_entry;

  CONST
    dfc$preserved_family_valid = 'VALID',
    dfc$preserved_family_updating = 'BADPF',
    dfc$preserved_family_version = ' PRESERVED_FAMILY_TABLE';

  CONST
    dfc$preserved_family_table_name = 'DFF$PRESERVED_FAMILY_TABLE     ';

?? TITLE := ' [XDCL] dfp$flush_served_family_table', EJECT ??

{
{   The purpose of this procedure is to a copy the served family
{ table that resides in the server wired segment to the disk permanent
{ file.
{

  PROCEDURE [XDCL] dfp$flush_served_family_table
    (VAR status: ost$status);

    VAR
      cycle_selector: pft$cycle_selector,
      family_list_index: dft$served_family_list_index,
      cycle_number: pft$cycle_number,
      file_id: amt$file_identifier,
      local_status: ost$status,
      log_string: string (80),
      log_string_length: integer,
      preserved_family_table_path: array [1 .. 3] of pft$name,
      p_header: ^dft$preserved_family_header,
      p_seq: ^SEQ ( * ),
      p_served_family_table_entry: ^dft$served_family_table_entry,
      pointers_index: dft$family_pointer_index,
      segment_pointer: amt$segment_pointer;

    IF dfv$file_server_debug_enabled THEN
      display (' Saving served family table ');
    IFEND;
    preserved_family_table_path [1] := ' ';
    preserved_family_table_path [2] := ' ';
    preserved_family_table_path [3] := dfc$preserved_family_table_name;
    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := 1;
    IF dsp$system_committed () THEN
      pfp$attach (dfc$preserved_family_table_name, preserved_family_table_path, cycle_selector,
            osc$null_name, -$pft$usage_selections [], $pft$share_selections [pfc$read], pfc$wait, status);
    ELSE
      pfp$restricted_attach (dfc$preserved_family_table_name, preserved_family_table_path, cycle_selector,
            osc$null_name, -$pft$usage_selections [], $pft$share_selections [pfc$read], cycle_number, status);
    IFEND;
    IF NOT status.normal AND (status.condition = pfe$unknown_permanent_file) AND dsp$system_committed () THEN
      pfp$define (dfc$preserved_family_table_name, preserved_family_table_path, cycle_selector, osc$null_name,
            pfc$maximum_retention, pfc$log, status);
    IFEND;
    IF NOT status.normal THEN
      display_status (status);
      RETURN;
    IFEND;

    amp$open (dfc$preserved_family_table_name, amc$segment, NIL, file_id, status);
    IF NOT status.normal THEN
      display_status (status);
      amp$return (dfc$preserved_family_table_name, local_status);
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_id, amc$sequence_pointer, segment_pointer, status);
    IF status.normal THEN
      mmp$lock_segment (segment_pointer.sequence_pointer, mmc$lus_lock_for_write,
           osc$wait, status);
    IFEND;
    IF NOT status.normal THEN
      display_status (status);
      amp$close (file_id, local_status);
      amp$return (dfc$preserved_family_table_name, local_status);
      RETURN;
    IFEND;

    p_seq := segment_pointer.sequence_pointer;
    NEXT p_header IN p_seq;
    p_header^.version := dfc$preserved_family_version;
    p_header^.valid_flag := dfc$preserved_family_updating;
    p_header^.number_of_families := 0;

    dfp$set_read_lock (dfv$served_family_table_lock);
    IF dfv$served_family_table_root.valid THEN

    /for_all_lists/
      FOR pointers_index := 1 TO dfv$served_family_table_root.number_of_active_pointers DO

      /search_family_list/
        FOR family_list_index := 1 TO dfv$served_family_table_root.
              p_family_list_pointer_array^ [pointers_index].highest_valid_entry DO
          NEXT p_served_family_table_entry IN p_seq;
          syp$hang_if_system_jrt_set (dfc$tjr_flush_served_family);

          p_served_family_table_entry^ := dfv$served_family_table_root.
                p_family_list_pointer_array^ [pointers_index].p_served_family_list^ [family_list_index];
          STRINGREP (log_string, log_string_length, ' Preserve family ',
                p_served_family_table_entry^.family_name (1, 16),
                dfv$server_state_string [p_served_family_table_entry^.server_state], ' Life/Birth',
                p_served_family_table_entry^.server_lifetime, p_served_family_table_entry^.server_birthdate);
          log_display ($pmt$ascii_logset [pmc$system_log], log_string (1, log_string_length));
          IF dfv$file_server_debug_enabled THEN
            display (log_string (1, log_string_length));
          IFEND;
          p_header^.number_of_families := p_header^.number_of_families + 1;
        FOREND /search_family_list/;
      FOREND /for_all_lists/;
    IFEND;

    p_header^.valid_flag := dfc$preserved_family_valid;
    dfp$clear_read_lock (dfv$served_family_table_lock);
    IF dfv$file_server_debug_enabled THEN
      display_integer (' Server families preserved: ', p_header^.number_of_families);
    IFEND;
    log_display_integer ($pmt$ascii_logset [pmc$system_log], ' Server families preserved: ',
          p_header^.number_of_families);

    mmp$unlock_segment (p_seq, mmc$lus_write, osc$nowait, status);
    amp$close (file_id, status);
    amp$return (dfc$preserved_family_table_name, status);
  PROCEND dfp$flush_served_family_table;
?? TITLE := ' [XDCL] dfp$purge_preserved_family_file', EJECT ??

{
{   This procedure removes the current preserved family table.  If this
{ is called after the point of commitment the preserved family table
{ is merely deleted.  If this is called before the point of commitment
{ the count of the number of families is set to zero.
{

  PROCEDURE [XDCL] dfp$purge_preserved_family_file
    (VAR status: ost$status);

    VAR
      cycle_number: pft$cycle_number,
      cycle_selector: pft$cycle_selector,
      file_id: amt$file_identifier,
      local_status: ost$status,
      p_header: ^dft$preserved_family_header,
      p_seq: ^SEQ ( * ),
      preserved_family_table_path: array [1 .. 3] of pft$name,
      segment_pointer: amt$segment_pointer;

    preserved_family_table_path [1] := '';
    preserved_family_table_path [2] := '';
    preserved_family_table_path [3] := dfc$preserved_family_table_name;
    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := 1;
    IF dsp$system_committed () THEN
      pfp$purge (preserved_family_table_path, cycle_selector, osc$null_name, status);
    ELSE
      pfp$restricted_attach (dfc$preserved_family_table_name, preserved_family_table_path, cycle_selector,
            osc$null_name, -$pft$usage_selections [], $pft$share_selections [pfc$read], cycle_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$open (dfc$preserved_family_table_name, amc$segment, NIL, file_id, status);
      IF NOT status.normal THEN
        amp$return (dfc$preserved_family_table_name, local_status);
        RETURN;
      IFEND;

      amp$get_segment_pointer (file_id, amc$sequence_pointer, segment_pointer, status);
      IF NOT status.normal THEN
        amp$close (file_id, local_status);
        amp$return (dfc$preserved_family_table_name, local_status);
        RETURN;
      IFEND;
      p_seq := segment_pointer.sequence_pointer;
      NEXT p_header IN p_seq;
      p_header^.version := dfc$preserved_family_version;
      p_header^.number_of_families := 0;
      p_header^.valid_flag := dfc$preserved_family_valid;
      amp$close (file_id, status);
      amp$return (dfc$preserved_family_table_name, status);
    IFEND;
  PROCEND dfp$purge_preserved_family_file;
?? TITLE := ' dfp$rebuild_served_family_table', EJECT ??

{
{   This procedure copies the preserved family back to the
{ server wired segment.
{ After rebuild the same served family table index must be used.
{ Families in the terminated or deleted state are left in that state.
{ Families in any other state will be placed in the awaiting recovery state.
{

  PROCEDURE [XDCL] dfp$rebuild_served_family_table
    (VAR status: ost$status);

    VAR
      cycle_selector: pft$cycle_selector,
      preserved_family_table_path: array [1 .. 3] of pft$name,
      family: 0 .. (dfc$max_family_ptr_array_size * dfc$served_family_list_size),
      file_id: amt$file_identifier,
      local_status: ost$status,
      cycle_number: pft$cycle_number,
      log_string: string (80),
      log_string_length: integer,
      p_header: ^dft$preserved_family_header,
      p_seq: ^SEQ ( * ),
      p_served_family_table_entries: ^dft$served_family_array,
      p_served_family_table_entry: ^dft$served_family_table_entry,
      segment_pointer: amt$segment_pointer,
      served_family_table_index: dft$served_family_table_index;

    IF dfv$file_server_debug_enabled THEN
      display (' Rebuilding served family table ');
    IFEND;

    preserved_family_table_path [1] := ' ';
    preserved_family_table_path [2] := ' ';
    preserved_family_table_path [3] := dfc$preserved_family_table_name;
    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := 1;
    IF dsp$system_committed () THEN
      pfp$attach (dfc$preserved_family_table_name, preserved_family_table_path, cycle_selector,
            osc$null_name, -$pft$usage_selections [], $pft$share_selections [pfc$read], pfc$wait, status);
    ELSE
      pfp$restricted_attach (dfc$preserved_family_table_name, preserved_family_table_path, cycle_selector,
            osc$null_name, -$pft$usage_selections [], $pft$share_selections [pfc$read], cycle_number, status);
    IFEND;
    IF (NOT status.normal) THEN
      IF status.condition = pfe$unknown_permanent_file THEN

{ No served family to recover

        IF dfv$file_server_debug_enabled THEN
          display (' Unknown preserved family table');
        IFEND;
        status.normal := TRUE;
      ELSE
        log_display_status ($pmt$ascii_logset [pmc$system_log], TRUE, status);
      IFEND;
      RETURN;
    IFEND;

    amp$open (dfc$preserved_family_table_name, amc$segment, NIL, file_id, status);
    IF NOT status.normal THEN
      display_status (status);
      log_display_status ($pmt$ascii_logset [pmc$system_log], TRUE, status);
      amp$return (dfc$preserved_family_table_name, local_status);
      RETURN;
    IFEND;
    amp$get_segment_pointer (file_id, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      display_status (status);
      amp$close (file_id, local_status);
      amp$return (dfc$preserved_family_table_name, local_status);
      RETURN;
    IFEND;
    p_seq := segment_pointer.sequence_pointer;
    NEXT p_header IN p_seq;
    IF (p_header^.version <> dfc$preserved_family_version) OR
          (p_header^.valid_flag <> dfc$preserved_family_valid) THEN
      IF dfv$file_server_debug_enabled THEN
        display (' Unrecognized preserved family table');
        display (p_header^.version);
        log_display ($pmt$ascii_logset [pmc$system_log], p_header^.version);
        display (p_header^.valid_flag);
        log_display ($pmt$ascii_logset [pmc$system_log], p_header^.valid_flag);
      IFEND;
      log_display ($pmt$ascii_logset [pmc$system_log], ' Unrecognized preserved family table');
      amp$close (file_id, status);
      amp$return (dfc$preserved_family_table_name, local_status);
      dfp$purge_preserved_family_file (local_status);
      RETURN;
    IFEND;
    IF p_header^.number_of_families > 0 THEN
      NEXT p_served_family_table_entries: [1 .. p_header^.number_of_families] IN p_seq;
      FOR family := 1 TO p_header^.number_of_families DO
        dfp$store_served_family_entry (p_served_family_table_entries^ [family], served_family_table_index,
              status);
        IF NOT status.normal THEN
          display (' Error in dfp$store_served_family_entry ');
          log_display_status ($pmt$ascii_logset [pmc$system_log], TRUE, status);
          display_status (status);
          amp$close (file_id, local_status);
          amp$return (dfc$preserved_family_table_name, local_status);
          RETURN;
        IFEND;
        p_served_family_table_entry := ^dfv$served_family_table_root.
              p_family_list_pointer_array^ [served_family_table_index.pointers_index].
              p_served_family_list^ [served_family_table_index.family_list_index];
        CASE p_served_family_table_entry^.server_state OF
        = dfc$deleted, dfc$terminated =

{ Leave these families alone

        ELSE { inactive, awaiting_recovery, active, deactivating, recovering
          p_served_family_table_entry^.server_state := dfc$awaiting_recovery;
        CASEND;

{ p_queue_interface_table and queue_index should not be referenced
{ make the dump obvious.

        p_served_family_table_entry^.active_since_deadstart := FALSE;
        p_served_family_table_entry^.p_queue_interface_table := NIL;
        p_served_family_table_entry^.queue_index := UPPERVALUE (dft$queue_index);
        STRINGREP (log_string, log_string_length, ' Rebuild family ',
              p_served_family_table_entry^.family_name (1, 20),
              dfv$server_state_string [p_served_family_table_entry^.server_state], ' Life/Birth',
              p_served_family_table_entry^.server_lifetime, p_served_family_table_entry^.server_birthdate);
        log_display ($pmt$ascii_logset [pmc$system_log], log_string (1, log_string_length));
        IF dfv$file_server_debug_enabled THEN
          display (log_string (1, log_string_length));
        IFEND;
      FOREND
    IFEND;
    IF dfv$file_server_debug_enabled THEN
      display_integer (' Server families rebuilt: ', p_header^.number_of_families);
    IFEND;
    log_display_integer ($pmt$ascii_logset [pmc$system_log], ' Server families rebuilt: ',
          p_header^.number_of_families);
    amp$close (file_id, status);
    amp$return (dfc$preserved_family_table_name, status);

  PROCEND dfp$rebuild_served_family_table;


MODEND dfm$preserved_family_manager;



*DECK DECK=DFM$PRINTER EXPAND=TRUE
*DECK DECK=DFM$PROCESS_SERVER_RESPONSE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: process_server_response ', EJECT ??
MODULE dfm$process_server_response;
{
{  This module contains the file server PP resquest response handlers.
{
?? NEWTITLE := '    Global Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc dfc$client_pause_break
*copyc dfc$client_terminate_break
*copyc dfc$esm_driver_error_codes
*copyc dfc$poll_constants
*copyc dfc$test_jr_constants
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc dfk$keypoints
*copyc dfd$request_package
*copyc dfs$server_wired
*copyc dft$page_io_request
*copyc dft$page_io_response
*copyc dft$cpu_queue
*copyc dft$esm_log_data
*copyc dft$fs_error_log_response
*copyc dft$fs_pp_response
*copyc dft$inquiry_message
*copyc dft$one_word_response_handler
*copyc dft$server_descriptor
*copyc dft$transaction_state
*copyc dmt$disk_file_descriptor
*copyc ioe$st_errors
*copyc iot$disk_request
*copyc iot$pp_interface_table
*copyc pmt$condition_name
*copyc syt$monitor_status
*copyc tmc$signal_identifiers
*copyc dfp$convert_p_io_request_to_qit
*copyc dfp$fetch_queue_entry
*copyc dfp$queue_inquiry_request
*copyc dfp$queue_request
*copyc dfi$monitor_display
*copyc dfp$get_served_file_desc_p
*copyc dmp$get_disk_file_descriptor_p
*copyc dpp$display_error
*copyc dsp$report_system_message
*copyc gfp$mtr_get_fde_p
*copyc mme$condition_codes
*copyc mmp$mtr_process_io_completion
*copyc mmp$mtr_process_server_complete
*copyc mmp$unlock_rma_list
*copyc mtp$cst_p
*copyc mtp$error_stop
*copyc oss$mainframe_wired
*copyc tmp$check_taskid
*copyc tmp$send_signal
*copyc tmp$set_task_ready
*copyc i#test_set_bit
?? POP ??
?? TITLE := '   INLINE IN DECKS ', EJECT ??
*copyc dfp$convert_list_pointer
*copyc dfp$determine_action_for_server
*copyc dfp$form_inquiry_tracer
*copyc dfp$record_transaction_data
*copyc dfp$release_queue_entry
*copyc syp$mtr_hang_if_system_jrt_set
?? TITLE := '    Global Variables ', EJECT ??
*copyc dfv$file_server_debug_enabled
*copyc jmv$ijl_p

{ The following variables provide for testing of File Server retransmission.
{ Value must be set via the Core Debugger.
{   dfv$force_retran_interval     - Time interval in minutes between simulation
{                                   of ESM I/O errors. This value must be non-zero
{                                   to enable testing.
{   dfv$force_retran_qe_type      - This value specifies the type of queue entry
{                                   for which failures will be forced.
{                                     0 = EITHER_QE, Task or Monitor queue entry type.
{                                     1 = TASK_QE, Task queue entry type only.
{                                     2 = MONITOR_QE, Monitor queue entry type only.
{   dfv$force_retran_failure_side - This value specifies the side on which failures
{                                   failures will be forced. Code must be enabled on
{                                   on side failure is to occur.
{                                     0 = FAIL_EITHER client or server side (loop back).
{                                     1 = FAIL_CLIENT side only.
{                                     2 = FAIL_SERVER side only.
{   dfv$force_retran_failure_item - This value specifies the message element on
{                                   which the simulated error is to occur.
{                                     0 = HEADER_ERR, driver's message header which
{                                         allows identification of the queue and
{                                         queue entry to which the message belongs.
{                                     1 = BUFFER_ERR, the Command or Response portion
{                                         of the file server transaction.
{                                     2 = DATA_ERR, the file page data portion of
{                                         the file server transaction.
{
{ To set values for the force retransmission variables enter :
{   1. at critical window      -    SYSDEBUG 0
{   2. in core debugger window -    CM variable_name value number_of_bytes
{      where variable_name   = one of the force retransmission variable names.
{            value           = 0 thru 2.
{            number_of_bytes = 1 (all are one byte fields).
{   3. in core debugger window -    RUN
{
{ The variable dfv$previous_force_retran_time is used in code to determine
{ elapsed time since the previous forced retransmission. In the code which
{ uses this value, if it is found to be zero it is set to the current time,
{ otherwise it is set to the current time each time a retransmission is forced.

  VAR
    dfv$previous_force_retran_time: [XDCL,#GATE, dfs$server_wired] integer := 0,
    dfv$force_retran_interval: [XDCL, #GATE, dfs$server_wired] 0 .. 0ff(16) := 0,
    dfv$force_retran_qe_type: [XDCL, #GATE, dfs$server_wired]
        (dfc$either_qe, dfc$task_qe, dfc$monitor_qe) := dfc$monitor_qe,
    dfv$force_retran_failure_side: [XDCL, #GATE, dfs$server_wired]
        (dfc$fail_either, dfc$fail_client, dfc$fail_server) := dfc$fail_either,
    dfv$force_retran_failure_item: [XDCL, #GATE, dfs$server_wired]
        (dfc$header_err, dfc$buffer_err, dfc$data_err) := dfc$header_err;


  VAR
    dfv$null_global_task_id: [XDCL, #GATE] ost$global_task_id := [0, 0];

  VAR
    dfv$one_word_response_handler: [XDCL, STATIC, #GATE, OSS$MAINFRAME_WIRED]
          dft$one_word_response_handler := ^dfp$process_server_response;

  VAR
    dfv$process_multiword_response: [XDCL, STATIC, #GATE, OSS$MAINFRAME_WIRED]
          iot$response_processor := ^dfp$process_multiword_response;

?? TITLE := '    [XDCL] dfp$process_server_response', EJECT ??
  PROCEDURE [XDCL] dfp$process_server_response
    (    one_word_response_p: ^dft$fs_pp_response;
         pp_number: 1 .. ioc$pp_count;
     VAR status: syt$monitor_status);

    {
    {  This procedure executes in the Monitor and is called to process responses
    {  from the File Server's PP driver.
    {
    {  It consists of the interface between iop$process_io_completions and
    {  dfp$process_server_response_a. The latter procedure was generated in
    {  order that server termination could have an entry point which did not
    {  depend upon the value of the logical unit in the one word response.

    VAR
      p_queue_interface_table: dft$p_queue_interface_table;

    IF cmv$logical_unit_table^ [one_word_response_p^.logical_unit].unit_interface_table = NIL THEN

{ We've encountered an artifact of a server pp response which is no longer valid.  Simply return.

      RETURN;
    IFEND;

    dfp$convert_p_io_request_to_qit (
        cmv$logical_unit_table^ [one_word_response_p^.logical_unit].
        unit_interface_table^.next_request, p_queue_interface_table);
    dfp$process_server_response_a (one_word_response_p, p_queue_interface_table, status);

  PROCEND dfp$process_server_response;

?? TITLE := '    [XDCL] dfp$process_server_response_a', EJECT ??
  PROCEDURE [XDCL] dfp$process_server_response_a
    (    one_word_response_p: ^dft$fs_pp_response;
         p_queue_interface_table: dft$p_queue_interface_table;
     VAR status: syt$monitor_status);

    {  This procedure is a continuation of dfp$process_server_response as well as
    {  being an entry point when the queue interface table is known but the logical
    {  unit number may not be.
    {
    {  The response_flags portion of the fs_pp_response are as follows -
    {
    {   SPECIAL_RESPONSE - This flag is detected by iom$process_io_completions
    {          which calls the response processor specified in the logical unit
    {          table. File Server that procedure is dfp$process_server_response.
    {
    {   ONE_WORD_RESPONSE - This flag indicates that the response is eight bytes
    {          in length (one CM word). These responses are processed in this
    {          procedure.
    {
    {   ERROR_RESPONSE - The response is due to an abnormal condition detected
    {          by the File Server's PP driver on processing a noninquiry message
    {          request. The response_parameter field of the one_word_response
    {          contains the condition code.
    {
    {   INQUIRY_RESPONSE - The response is due to an inquiry_message request.
    {          The response_parameter field of the one_word_response contains
    {          the inquiry_message.
    {
    {   TERMINATION_PSEUDO_RESPONSE - Indicates dfp$process_server_response_a has
    {          been called directly as part of termination processing. The response
    {          is not contained in the PP response buffer and does not contain a
    {          valid logical unit number.

    TYPE
      dft$connection_side = (server_side, client_side, unknown_side);

    VAR
      action_for_server: dft$action_for_server,
      connection_side: dft$connection_side,
      cst_p: ^ost$cpu_state_table,
      current_time: integer,
      dfd_p: ^dmt$disk_file_descriptor,
      elapsed_time: integer,
      io_error: iot$io_error,
      io_status: syt$monitor_status,
      io_type: iot$io_function,
      local_priority: jmt$dispatching_priority,
      local_task_id: ost$global_task_id,
      m_status: syt$monitor_status,
      normal: boolean,
      p_buffer_header: ^dft$buffer_header,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_fde: gft$file_desc_entry_p,
      p_fs_pp_response: ^dft$fs_pp_response,
      p_page_io_response: ^dft$page_io_response,
      p_page_io_request: ^dft$page_io_request,
      p_rma_list: ^mmt$rma_list,
      p_server_descriptor: dft$server_descriptor_p,
      p_status_response: ^dft$status_response,
      queue_entry_index: dft$queue_entry_index,
      queue_index: dft$queue_index,
      queue_release_status: dft$release_queue_entry_status,
      remote_request: dft$remote_request;

    #KEYPOINT (osk$entry, osk$m * one_word_response_p^.logical_unit,
          dfk$process_server_response);

    status.normal := TRUE;

    queue_index := one_word_response_p^.queue_index;
    queue_entry_index := one_word_response_p^.queue_entry_index;

    IF (queue_entry_index <> 0) AND (queue_index <> 0) THEN
      { one word PP response is associated with a known queue entry.
      dfp$fetch_queue_entry (p_queue_interface_table, queue_index,
          queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry);

      IF (p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue^.queue_header.flags.idle) AND
         (NOT one_word_response_p^.response_flags.termination_pseudo_response) THEN
        { QUEUE IS IDLE, IGNORE PP RESPONSES.
        p_driver_queue_entry^.flags.process_response := FALSE;
        IF dfv$file_server_debug_enabled THEN
          dpp$display_error ('DF - INFORMATIVE, PRO_S_R - QUEUE IS IDLE, IGNORE PP RESPONSE.');
        IFEND;
        RETURN;
      IFEND;

      IF p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
           p_driver_queue^.queue_header.connection_descriptor.source.flags.server_to_client THEN
        connection_side := server_side;
      ELSE
        connection_side := client_side;
      IFEND;
    ELSE
      connection_side := unknown_side;
    IFEND;


{   This code provided for testing File Server Retransmission logic.
{   The variable dfv$force_retran_interval must be set non-zero via the
{   Core Debugger to enable execution of this test code.

    IF dfv$force_retran_interval > 0 THEN
      IF dfv$previous_force_retran_time = 0 THEN
        dfv$previous_force_retran_time := #FREE_RUNNING_CLOCK (0);
      ELSE
        current_time := #FREE_RUNNING_CLOCK (0);
        elapsed_time := current_time - dfv$previous_force_retran_time;
        IF (elapsed_time >= dfv$force_retran_interval * 60000000)
           AND (NOT one_word_response_p^.response_flags.error_response) THEN
          IF ((connection_side = client_side) AND (dfv$force_retran_failure_side = dfc$fail_client))
             OR ((connection_side = server_side) AND (dfv$force_retran_failure_side = dfc$fail_server))
             OR ((connection_side <> unknown_side) AND (dfv$force_retran_failure_side = dfc$fail_either)) THEN

            IF ((p_cpu_queue_entry^.processor_type = dfc$task_services) AND
                   (dfv$force_retran_qe_type = dfc$task_qe))
               OR ((p_cpu_queue_entry^.processor_type = dfc$monitor) AND
                   (dfv$force_retran_qe_type = dfc$monitor_qe))
               OR (dfv$force_retran_qe_type = dfc$either_qe) THEN

              CASE dfv$force_retran_failure_item OF
              = DFC$HEADER_ERR =
                IF ((p_driver_queue_entry^.flags.buffer_received) AND
                    (NOT p_driver_queue_entry^.flags.data_received))
                   OR one_word_response_p^.response_flags.inquiry_response THEN

                  IF one_word_response_p^.response_flags.inquiry_response THEN
                    dpp$display_error ('DF - TST RETRAN, PRETEND DRIVER FAILED ON INQUIRY MESSAGE.');
                  ELSE
                    p_driver_queue_entry^.held_over_esm_division_number := 0;
                    p_driver_queue_entry^.held_over_cm_word_count := 0;
                    p_driver_queue_entry^.flags.buffer_received := FALSE;
                    p_driver_queue_entry^.flags.process_response := FALSE;
                    dpp$display_error ('DF - TST RETRAN, PRETEND DRIVER FAILED ON HEADER.');
                  IFEND;
                  display_integer_monitor ('       QUEUE INDEX = ', queue_index);
                  display_integer_monitor ('       QUEUE ENTRY = ', queue_entry_index);
                  one_word_response_p^.response_flags.error_response := TRUE;
                  one_word_response_p^.response_parameter.error_condition := dfc$esm_double_bit_parity_error;
                  connection_side := unknown_side;
                  dfv$previous_force_retran_time := #FREE_RUNNING_CLOCK (0);
                IFEND;

              = DFC$BUFFER_ERR =
                IF (p_driver_queue_entry^.flags.buffer_received) AND
                   (NOT p_driver_queue_entry^.flags.data_received) THEN
                  dpp$display_error ('DF - TST RETRAN, PRETEND DRIVER FAILED ON BUFFER.');
                  display_integer_monitor ('       QUEUE INDEX = ', queue_index);
                  display_integer_monitor ('       QUEUE ENTRY = ', queue_entry_index);
                  p_driver_queue_entry^.flags.driver_error_alert := TRUE;
                  p_driver_queue_entry^.flags.buffer_received := FALSE;
                  p_driver_queue_entry^.held_over_esm_division_number := 0;
                  p_driver_queue_entry^.held_over_cm_word_count := 0;
                  one_word_response_p^.response_flags.error_response := TRUE;
                  one_word_response_p^.response_parameter.error_condition := dfc$esm_double_bit_parity_error;
                  p_driver_queue_entry^.error_condition := dfc$esm_double_bit_parity_error;
                  dfv$previous_force_retran_time := #FREE_RUNNING_CLOCK (0);
                IFEND;

              = DFC$DATA_ERR =
                IF p_driver_queue_entry^.flags.data_received THEN
                  dpp$display_error ('DF - TST RETRAN, PRETEND DRIVER FAILED ON DATA.');
                  display_integer_monitor ('       QUEUE INDEX = ', queue_index);
                  display_integer_monitor ('       QUEUE ENTRY = ', queue_entry_index);
                  p_driver_queue_entry^.flags.driver_error_alert := TRUE;
                  p_driver_queue_entry^.flags.data_received := FALSE;
                  p_driver_queue_entry^.held_over_esm_division_number := 0;
                  p_driver_queue_entry^.held_over_cm_word_count := 0;
                  one_word_response_p^.response_flags.error_response := TRUE;
                  one_word_response_p^.response_parameter.error_condition := dfc$esm_double_bit_parity_error;
                  p_driver_queue_entry^.error_condition := dfc$esm_double_bit_parity_error;
                  dfv$previous_force_retran_time := #FREE_RUNNING_CLOCK (0);
                IFEND;

              ELSE
                ;
              CASEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND; { End Of Retransmission Test Code.}


    IF one_word_response_p^.response_flags.error_response THEN
      IF dfv$file_server_debug_enabled THEN
        display_integer_monitor ('DF - INFORMATIVE, PRO_S_R - ERROR CONDITION ', $integer (
          one_word_response_p^.response_parameter.error_condition));
        IF one_word_response_p^.response_flags.inquiry_response THEN
          dpp$display_error ('DF - IGNORE ERROR ON INQUIRY MESSAGE');
        IFEND;
        display_integer_monitor ('DF - QUEUE INDEX', queue_index);
        display_integer_monitor ('DF - QUEUE ENTRY INDEX ' , queue_entry_index);
      IFEND;
      CASE one_word_response_p^.response_parameter.error_condition OF
      = dfc$invalid_command_code, dfc$invalid_length_in_command, dfc$invalid_address_in_command,
        dfc$invalid_length_in_ind_list, dfc$invalid_address_in_ind_list, dfc$reserved_field_not_zero,
        dfc$pit_lockword_error, dfc$no_held_info_in_queue_entry, dfc$invalid_queue_index,
        dfc$invalid_queue_entry_index, dfc$insufficient_length_spec,
        dfc$esm_address_overflow, dfc$invalid_driver_queue_rma,
        dfc$unused_reserved_46, dfc$unused_reserved_47, dfc$unused_reserved_48, dfc$unused_reserved_49 =
        { Interface Error Condition.
        display_integer_monitor (' Server interface error ', $INTEGER
               (one_word_response_p^.response_parameter.error_condition));
        IF dfv$file_server_debug_enabled THEN
          IF one_word_response_p^.response_flags.inquiry_response THEN
            RETURN;
          IFEND;
          mtp$error_stop ('DF - PRO_S_R, FILE SERVER DRIVER INTERFACE ERROR DETECTED');
        IFEND;
        IF connection_side = unknown_side THEN
          dpp$display_error (' File Server Interface Error detected on unknown connection.');
          RETURN;
        IFEND;
        IF (p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
              p_cpu_queue^.queue_header.partner_status.server_state = dfc$active) THEN
          p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
                p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
          dpp$display_error (' Timing Out File Server because Interface Error Condition');
        IFEND;
        RETURN;

      = dfc$function_timeout, dfc$iou_channel_parity_error, dfc$esm_channel_parity_error,
        dfc$esm_double_bit_parity_error, dfc$esm_address_parity_error, dfc$esm_flag_operation_abort,
        dfc$adp_uncorrected_cm_error, dfc$adp_cm_reject, dfc$adp_invalid_cm_response,
        dfc$adp_cm_response_parity_err, dfc$adp_cmi_read_parity_err, dfc$adp_clock_fault,
        dfc$adp_input_buffer_overflow, dfc$adp_input_data_parity_error, dfc$adp_12_16_conversion_error,
        dfc$adp_jy_data_parity_error, dfc$adp_kx_pp_data_parity_error, dfc$adp_kz_board_detected_error,
        dfc$adp_jy_board_detected_error, dfc$adp_kx_board_detected_error,
        dfc$channel_inactive_error, dfc$dma_xfer_halted_early,
        dfc$destination_machine_down, dfc$inactive_queue_entry, dfc$driver_action_flag_not_set,
        dfc$lsp_deadman_timeout,
        dfc$unused_reserved_25, dfc$unused_reserved_26,
        dfc$unused_reserved_27, dfc$unused_reserved_28, dfc$unused_reserved_29,
        dfc$queue_idle =
        IF dfv$file_server_debug_enabled THEN
          CASE one_word_response_p^.response_parameter.error_condition OF
          = dfc$destination_machine_down, dfc$inactive_queue_entry,
            dfc$driver_action_flag_not_set, dfc$queue_idle =
            dpp$display_error ('DF - INFORMATIVE, PRO_S_R - FILE_SERVER INACTIVE INTERFACE DETECTED');
          ELSE
            dpp$display_error ('DF - INFORMATIVE, PRO_S_R - FILE SERVER MEDIA ERROR DETECTED.');
          CASEND;
        IFEND;

        { Determine action to be taken after error.
        { No driver queue flags set by driver for inquiry messages.
        IF one_word_response_p^.response_flags.inquiry_response THEN
          IF one_word_response_p^.response_parameter.error_condition =
             dfc$destination_machine_down THEN
            IF (p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
                p_cpu_queue^.queue_header.partner_status.server_state = dfc$active) THEN
              p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
                  p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
              dpp$display_error (' Timeout File Server because destination mainframe down');
            IFEND;
          IFEND;
{         With the exception of dfc$destination_machine_down,
{         No action taken on failures detected while processing inquiries.
          RETURN;
        IFEND;

        CASE one_word_response_p^.response_parameter.error_condition OF
        = dfc$destination_machine_down =
          IF (p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
                p_cpu_queue^.queue_header.partner_status.server_state = dfc$active) THEN
            p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
                  p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
            dpp$display_error (' Timeout File Server because destination mainframe down');
          IFEND;
{         Continue processing at CLIENT_SIDE/SERVER_SIDE case.

        = dfc$inactive_queue_entry, dfc$queue_idle, dfc$driver_action_flag_not_set =
{         Driver does not update queue_entry on these errors.
          RETURN;
        ELSE
        CASEND;

        CASE connection_side OF
        = CLIENT_SIDE =
          p_driver_queue_entry^.flags.process_response := FALSE;
          p_cpu_queue_entry^.transaction_state := dfc$media_error;
          CASE one_word_response_p^.response_parameter.error_condition OF
          = dfc$destination_machine_down =
            { Allow request timeout process to detect media error state and
            { attempt retransmission. Retransmission count will be reset for
            { initial POLL message so client waits for server to become active.
            RETURN;
          ELSE
            { Attempt immediate retransmission.
            dfp$retransmit_request (p_queue_interface_table, queue_index,
                queue_entry_index, p_cpu_queue_entry, p_driver_queue_entry);
            RETURN;
          CASEND;
        = SERVER_SIDE =
          p_cpu_queue_entry^.transaction_state := dfc$media_error;
          { Check if data pages to release.
          IF p_driver_queue_entry^.data_descriptor.actual_length = 0 THEN
            p_driver_queue_entry^.flags.process_response := FALSE;
            RETURN;
          { ELSE must do complete request processing to release pages.
          IFEND;
        = UNKNOWN_SIDE =
          IF dfv$file_server_debug_enabled THEN
            CASE one_word_response_p^.response_parameter.error_condition OF
            = dfc$inactive_queue_entry, dfc$queue_idle, dfc$driver_action_flag_not_set =
              dpp$display_error ('DF - INFORMATIVE, PRO_S_R - QI=0, FS INACTIVE INTERFACE DETECTED');
            ELSE
              dpp$display_error ('DF - INFORMATIVE, PRO_S_R - QI=0, FS MEDIA ERROR DETECTED.');
            CASEND;
          IFEND;
          RETURN;
        ELSE
          ;
        CASEND;
      ELSE { Case error condition unknown.
        IF dfv$file_server_debug_enabled THEN
          dpp$display_error ('DF - INFORMATIVE, PRO_S_R - UNDETERMINED FS DRIVER ERROR REPORTED');
        IFEND;
        RETURN;
      CASEND;

    ELSE { Not error response.
      CASE connection_side OF
      = UNKNOWN_SIDE =
        IF dfv$file_server_debug_enabled THEN
          dpp$display_error ('DF - INFORMATIVE, PRO_S_R - INVALID RESPONSE, QI/QEI ZERO WITHOUT ERROR');
        IFEND;
        RETURN;
      ELSE
        ;
      CASEND;
      IF one_word_response_p^.response_flags.inquiry_response THEN
        p_fs_pp_response := one_word_response_p;
        process_inquiry_message (p_fs_pp_response, p_queue_interface_table, queue_index,
             queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry, status);
        { No driver queue flags set by driver for inquiry messages.
        RETURN;
      IFEND;

      { Determine Transaction State.
      CASE connection_side OF
      = SERVER_SIDE =
        IF ((p_driver_queue_entry^.flags.buffer_received) AND
           (p_driver_queue_entry^.held_over_cm_word_count <> 0)) THEN
          p_cpu_queue_entry^.transaction_state := dfc$server_must_read_page_data;
        ELSEIF p_driver_queue_entry^.flags.buffer_sent THEN
          { PP sent response to indicate locked pages for data may be released.
          p_cpu_queue_entry^.transaction_state := dfc$server_waiting_request;
        ELSE
          { All request information has been received on server side.
          p_cpu_queue_entry^.transaction_state := dfc$server_received_request;
        IFEND;
      = CLIENT_SIDE =
        IF ((p_driver_queue_entry^.flags.buffer_received) AND
           (p_driver_queue_entry^.held_over_cm_word_count <> 0)) THEN
          p_cpu_queue_entry^.transaction_state := dfc$client_must_read_page_data;
        ELSE
          { All response information has been received on client side.
          p_cpu_queue_entry^.transaction_state := dfc$response_received;
          p_cpu_queue_entry^.retransmission_count := 0;
        IFEND;
      CASEND;
    IFEND;

    dfp$record_transaction_data (p_driver_queue_entry^, p_cpu_queue_entry^,
         p_queue_interface_table^.queue_directory.
         cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header.
         transaction_data);


    CASE p_cpu_queue_entry^.processor_type OF

    = dfc$task_services =

      tmp$check_taskid (p_cpu_queue_entry^.global_task_id, tmc$opt_return, status);
      IF NOT status.normal THEN
        status.normal := TRUE;
        IF dfv$file_server_debug_enabled THEN
          dpp$display_error ('DF - INFORMATIVE, PRO_S_R - TASK NO LONGER ACTIVE');
          display_integer_monitor ('DF - INVALID TASK ID, INDEX = ', $integer (
                p_cpu_queue_entry^.global_task_id.index));
          display_integer_monitor ('DF - INVALID TASK ID, SEQNO = ', $integer (
                p_cpu_queue_entry^.global_task_id.seqno));
          display_integer_monitor ('DF - QUEUE INDEX', queue_index);
          display_integer_monitor ('DF - QUEUE ENTRY INDEX ' , queue_entry_index);
        IFEND;
        RETURN;
      IFEND;

{ Keep the window as small as possible between the setting of subsystem action and the ready task, so that
{ with dual processors the other processor is not likely to release the queue entry before being readied.  A
{ local variable is used for global_task_id, because if the queue entry is released the
{ p_cpu_queue_entry^.global_task_id is cleared, but the task id is still likely to be valid, since the task is
{ still probably running.  The current window is if the second processor sees the subsystem action, releases
{ the queue entry, and the task terminates before the ready task occurs here.

      mtp$cst_p (cst_p);
      local_priority := cst_p^.dispatching_priority;
      local_task_id := p_cpu_queue_entry^.global_task_id;
      p_driver_queue_entry^.flags.process_response := FALSE;
      p_driver_queue_entry^.flags.subsystem_action := TRUE;
      tmp$set_task_ready (local_task_id, local_priority {readying_task_priority},
           tmc$rc_ready_conditional);

    = dfc$monitor =
      p_driver_queue_entry^.flags.subsystem_action := TRUE;
      p_driver_queue_entry^.flags.process_response := FALSE;

      CASE connection_side OF
      = SERVER_SIDE =
        { SERVER SIDE - PROCESS REQUEST (2.1.2.1) }

        { Determine cause of response.
        dfp$determine_action_for_server (p_cpu_queue_entry, p_driver_queue_entry, action_for_server);

        RESET p_cpu_queue_entry^.p_receive_buffer;
        NEXT p_buffer_header IN p_cpu_queue_entry^.p_receive_buffer;

        CASE action_for_server OF

        = dfc$new_request, dfc$retransmitted_request =
          { Server must execute new request from client.
          { Retransmitted request treated same as new request.

          IF p_cpu_queue_entry^.p_server_iocb^.server_state <> mmc$ss_waiting THEN
            dpp$display_error ('DF - INFORMATIVE, SERVER STATE INVALID FOR NEW REQUEST');
            display_integer_monitor ('DF - QUEUE INDEX', queue_index);
            display_integer_monitor ('DF - QUEUE ENTRY INDEX ' , queue_entry_index);
            display_integer_monitor ('DF - SERVER STATE ',
                  $INTEGER (p_cpu_queue_entry^.p_server_iocb^.server_state));
            IF dfv$file_server_debug_enabled THEN
              dpp$display_error (' NEED DUMP OF BOTH CLIENT AND SERVER.');
              mtp$error_stop ('DF - PRO_S_R, SERVER STATE INVALID FOR NEW REQUEST.');
            { else - continue normally.
            IFEND;
          IFEND;

          { Move request parameters to server IOCB.
          NEXT p_page_io_request IN p_cpu_queue_entry^.p_receive_buffer;
          p_cpu_queue_entry^.p_server_iocb^.global_file_name :=
               p_page_io_request^.global_file_name;
          p_cpu_queue_entry^.p_server_iocb^.sfid :=
               p_page_io_request^.remote_sfid;
          p_cpu_queue_entry^.p_server_iocb^.offset :=
               p_page_io_request^.segment_offset;
          p_cpu_queue_entry^.p_server_iocb^.length :=
               p_page_io_request^.segment_length;
          p_cpu_queue_entry^.p_server_iocb^.eoi :=
               p_page_io_request^.eoi_byte_address;

          { Initialize remainder of server IOCB.
          p_cpu_queue_entry^.p_server_iocb^.server_state := mmc$ss_waiting;
 { * ? *  p_cpu_queue_entry^.p_server_iocb^.sub_reqcode := ;
          p_cpu_queue_entry^.p_server_iocb^.condition :=
               dfc$null_server_condition;
          p_cpu_queue_entry^.p_server_iocb^.io_already_active := FALSE;
          p_cpu_queue_entry^.p_server_iocb^.active_io_count := 0;
          p_cpu_queue_entry^.p_server_iocb^.reissue_request := FALSE;
          p_cpu_queue_entry^.p_server_iocb^.restart_count := 0;

          { Convert remote_processor to new ordinal type.
          CASE p_buffer_header^.remote_processor OF
          = dfc$write_pages =
            remote_request := dfc$write_for_client;
            { initial process: read_from_client }
            p_cpu_queue_entry^.io_id.io_function := ioc$read_from_client;
            { final process: write_for_server }

          = dfc$read_pages =
            remote_request := dfc$read_for_client;
            { initial process: read_for_server }
            p_cpu_queue_entry^.io_id.io_function := ioc$read_for_server;
            { final process: write_to_client }

          = dfc$allocate =
            remote_request := dfc$allocate_space_for_client;
            { initial process = final process: allocate }
            p_cpu_queue_entry^.io_id.io_function := ioc$allocate;

          ELSE
            dpp$display_error ('DF - INFORMATIVE, UNKNOWN REMOTE_PROCESSOR ON SERVER');
            display_integer_monitor ('DF - QUEUE INDEX', queue_index);
            display_integer_monitor ('DF - QUEUE ENTRY INDEX ' , queue_entry_index);
            IF dfv$file_server_debug_enabled THEN
              dpp$display_error (' NEED DUMP OF BOTH CLIENT AND SERVER.');
              mtp$error_stop ('DF - PRO_S_R, UNKNOWN REMOTE_PROCESSOR ON SERVER');
            ELSE
              p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
                    p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
              dpp$display_error (' Timing Out File Server because processor unknown.');
              RETURN;
            IFEND;
          CASEND;

          io_status.normal := TRUE;
          io_status.condition := 0;

          syp$mtr_hang_if_system_jrt_set (dfc$tjr_prosr_new_request);
          mmp$mtr_process_server_complete (remote_request,
             p_cpu_queue_entry^.io_id, p_cpu_queue_entry^.p_server_iocb,
             io_status);

        = dfc$complete_request, dfc$complete_request_on_error =
          { Server must complete processing of request.
          { With or without driver error condition -
          { Response and page data has been sent to client, prompt for data request completed,
          { or driver detected error while processing a request which involved page data.
          { In either case pages will be released.

          io_status.normal := TRUE;
          io_status.condition := 0;
          IF (p_cpu_queue_entry^.data_pages_locked) AND
             (p_driver_queue_entry^.data_descriptor.actual_length <> 0) THEN
            IF one_word_response_p^.response_parameter.error_condition = 0 THEN
              io_error := ioc$no_error;
            ELSEIF one_word_response_p^.response_parameter.error_condition =
                  dfc$destination_machine_down THEN
              io_error := ioc$media_error;
              io_status.normal := FALSE;
              io_status.condition := dfe$server_has_terminated;
            ELSE
              io_error := ioc$media_error;
              io_status.normal := FALSE;
              io_status.condition := ioc$disk_media_error;
            IFEND;

            dfp$convert_list_pointer (p_cpu_queue_entry^.p_data_rma_list, p_rma_list);

            mmp$unlock_rma_list (p_cpu_queue_entry^.io_type, p_rma_list,
                p_driver_queue_entry^.data_descriptor.actual_length DIV 8,
                p_cpu_queue_entry^.io_id, {MF_JOB_FILE} FALSE, io_error, m_status);

            IF NOT m_status.normal THEN
              dpp$display_error ('DF - INFORMATIVE, ABNORMAL STATUS FROM UNLOCK_RMA_LIST');
              display_integer_monitor ('DF - QUEUE INDEX', queue_index);
              display_integer_monitor ('DF - QUEUE ENTRY INDEX ' , queue_entry_index);
              IF dfv$file_server_debug_enabled THEN
                dpp$display_error (' NEED DUMP OF BOTH CLIENT AND SERVER.');
                mtp$error_stop ('DF - PRO_S_R, ABNORMAL STATUS FROM UNLOCK_RMA_LIST');
              ELSE
                p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
                      p_cpu_queue^.queue_header.partner_status.terminate_partner := TRUE;
                dpp$display_error (' Terminating File Server because abnormal unlock status.');
                RETURN;
              IFEND;
            IFEND;

            p_driver_queue_entry^.data_descriptor.actual_length := 0;
            p_cpu_queue_entry^.data_pages_locked := FALSE;

          IFEND;

          remote_request := dfc$completing_previous_request;

          syp$mtr_hang_if_system_jrt_set (dfc$tjr_prosr_complete_request);
          mmp$mtr_process_server_complete (remote_request,
             p_cpu_queue_entry^.io_id, p_cpu_queue_entry^.p_server_iocb,
             io_status);

          { Get pointer to FDE.
          gfp$mtr_get_fde_p (p_cpu_queue_entry^.sfid, NIL, p_fde);
          dmp$get_disk_file_descriptor_p (p_fde, dfd_p);

          { Decrement read/write count in the disk_file_descriptor.
          dfd_p^.read_write_count := dfd_p^.read_write_count - 1;

        = dfc$transaction_out_of_sequence =
          dpp$display_error ('DF - INFORMATIVE, TRANSACTION OUT OF SEQUENCE');
          display_integer_monitor ('DF - QUEUE INDEX', queue_index);
          display_integer_monitor ('DF - QUEUE ENTRY INDEX ' , queue_entry_index);
          IF dfv$file_server_debug_enabled THEN
            dpp$display_error (' NEED DUMP OF BOTH CLIENT AND SERVER.');
            mtp$error_stop ('DF - PRO_S_R, TRANSACTION OUT OF SEQUENCE');
          ELSE
            p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
                  p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
            dpp$display_error (' Timing out File Server because transaction out of sequence.');
            RETURN;
          IFEND;

        ELSE
          dpp$display_error ('DF - INVALID CASE FOR PROCESSING STATE');
          display_integer_monitor ('DF - QUEUE INDEX', queue_index);
          display_integer_monitor ('DF - QUEUE ENTRY INDEX ' , queue_entry_index);
          IF dfv$file_server_debug_enabled THEN
            dpp$display_error (' NEED DUMP OF BOTH CLIENT AND SERVER.');
            mtp$error_stop ('DF - PRO_S_R, INVALID CASE FOR PROCESSING STATE');
          ELSE
            p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
                  p_cpu_queue^.queue_header.partner_status.terminate_partner := TRUE;
            dpp$display_error (' Terminating File Server because case invalid for state.');
            RETURN;
          IFEND;
        CASEND; {action_for_server}


      = CLIENT_SIDE =
        { CLIENT SIDE - PROCESS RESPONSE (2.1.2.2) }

        RESET p_cpu_queue_entry^.p_receive_buffer;
        NEXT p_status_response IN p_cpu_queue_entry^.p_receive_buffer;

        io_status := p_status_response^.status;

        { Convert remote_processor to io_type.
        CASE p_status_response^.buffer_header.remote_processor OF
        = dfc$read_pages =
          io_type := ioc$read_page;

        = dfc$write_pages =
          io_type := ioc$write_page;

        = dfc$allocate =
          io_type := ioc$allocate;

        ELSE
          dpp$display_error ('DF - INFORMATIVE, UNKNOWN REMOTE_PROCESSOR ON CLIENT.');
          display_integer_monitor ('DF - QUEUE INDEX', queue_index);
          display_integer_monitor ('DF - QUEUE ENTRY INDEX ' , queue_entry_index);
          IF dfv$file_server_debug_enabled THEN
            dpp$display_error (' NEED DUMP OF BOTH CLIENT AND SERVER.');
            mtp$error_stop ('DF - PRO_S_R, UNKNOWN REMOTE_PROCESSOR ON CLIENT');
          ELSE
            p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
                  p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
            dpp$display_error (' Timing Out File Server because unknown client process.');
            RETURN;
          IFEND;

        CASEND; {remote_processor}

        IF (p_cpu_queue_entry^.data_pages_locked) AND
           (p_driver_queue_entry^.data_descriptor.actual_length <> 0) THEN

          IF io_status.normal THEN
            io_error := ioc$no_error;
          ELSE
            IF io_type = ioc$allocate THEN
{             We are not concerned with the io_status.condition; we just need to know the allocate failed.
              io_error := ioc$server_allocation_error;
            ELSE
              CASE io_status.condition OF
                = dfe$server_has_terminated =
                  io_error := ioc$server_has_terminated;
                = mme$volume_unavailable, dfe$server_not_active =
                  io_error := ioc$unrecovered_error_unit_down;
                = dfe$sfid_gfn_mismatch, ioe$unrecovered_disk_error =
                  io_error := ioc$unrecovered_error;
                = ioc$disk_media_error =
                  io_error := ioc$media_error;
              ELSE
{ ??????
              CASEND;
            IFEND;
          IFEND;

          dfp$convert_list_pointer (p_cpu_queue_entry^.p_data_rma_list, p_rma_list);

          mmp$unlock_rma_list (io_type, p_rma_list,
              p_driver_queue_entry^.data_descriptor.actual_length DIV 8,
              p_cpu_queue_entry^.io_id, {MF_JOB_FILE} FALSE, io_error, m_status);

          IF NOT m_status.normal THEN
            dpp$display_error ('DF - INFORMATIVE, ABNORMAL STATUS FROM UNLOCK_RMA_LIST');
            display_integer_monitor ('DF - QUEUE INDEX', queue_index);
            display_integer_monitor ('DF - QUEUE ENTRY INDEX ' , queue_entry_index);
            IF dfv$file_server_debug_enabled THEN
              dpp$display_error (' NEED DUMP OF BOTH CLIENT AND SERVER.');
              mtp$error_stop ('DF - PRO_S_R, ABNORMAL STATUS FROM UNLOCK_RMA_LIST');
            ELSE
              p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
                    p_cpu_queue^.queue_header.partner_status.terminate_partner := TRUE;
              dpp$display_error (' Terminating File Server because abnormal unlock status.');
              RETURN;
            IFEND;
          IFEND;

          p_driver_queue_entry^.data_descriptor.actual_length := 0;
          p_cpu_queue_entry^.data_pages_locked := FALSE;

        IFEND;

        IF p_cpu_queue_entry^.io_id.specified THEN
          mmp$mtr_process_io_completion (p_cpu_queue_entry^.io_id, io_type,
              io_status);
        IFEND;

        { Get pointer to FDE.
        gfp$mtr_get_fde_p (p_cpu_queue_entry^.sfid, NIL, p_fde);
        dfp$get_served_file_desc_p (p_fde, p_server_descriptor);

        { Decrement read/write count in the server_descriptor.
        p_server_descriptor^.header.read_write_count := p_server_descriptor^.header.read_write_count - 1;

        NEXT p_page_io_response IN p_cpu_queue_entry^.p_receive_buffer;

        IF p_page_io_response^.total_allocated_length >
            p_server_descriptor^.header.total_allocated_length THEN

          p_server_descriptor^.header.total_allocated_length :=
              p_page_io_response^.total_allocated_length;

        IFEND;

        IF io_error = ioc$server_allocation_error THEN
{
{ If the current total_allocated_length is less than the requested segment_length, set up a record which
{ lets job-mode restart the allocation with the correct data.  Otherwise, another request for allocation
{ has already completed for a greater segment_length than this request.  Always take the save the largest
{ request that is pending.
{
          IF p_page_io_response^.segment_length - p_server_descriptor^.header.total_allocated_length > 0 THEN
            p_server_descriptor^.header.allocation_info.allocation_needed_on_server := TRUE;
            IF p_page_io_response^.segment_length - p_server_descriptor^.header.total_allocated_length >
                  p_server_descriptor^.header.allocation_info.bytes_to_allocate THEN
              p_server_descriptor^.header.allocation_info.bytes_to_allocate := p_page_io_response^.
                    segment_length - p_server_descriptor^.header.total_allocated_length;
            IFEND;
          IFEND;
        IFEND;

        dfp$release_queue_entry (p_queue_interface_table, queue_index,
            queue_entry_index, queue_release_status);

        IF queue_release_status <> dfc$rqes_entry_released THEN
          dpp$display_error ('DF - INFORMATIVE, UNABLE TO RELEASE QUEUE ENTRY');
          display_integer_monitor ('DF - QUEUE INDEX', queue_index);
          display_integer_monitor ('DF - QUEUE ENTRY INDEX ' , queue_entry_index);
          IF dfv$file_server_debug_enabled THEN
            dpp$display_error (' NEED DUMP OF BOTH CLIENT AND SERVER.');
            mtp$error_stop ('DF - PRO_S_R, UNABLE TO RELEASE QUEUE ENTRY');
          ELSE
            p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
                  p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
            dpp$display_error (' Timing Out File Server queue entry release failed.');
            RETURN;
          IFEND;
        IFEND;

      ELSE
      CASEND; {connection_side}

    ELSE
      dpp$display_error ('DF - INFORMATIVE, INVALID CPU QUEUE PROCESSOR TYPE');
      display_integer_monitor ('DF - QUEUE INDEX', queue_index);
      display_integer_monitor ('DF - QUEUE ENTRY INDEX ' , queue_entry_index);
      IF dfv$file_server_debug_enabled THEN
        dpp$display_error (' NEED DUMP OF BOTH CLIENT AND SERVER.');
        mtp$error_stop ('DF - PRO_S_R, INVALID CPU QUEUE PROCESSOR TYPE');
      ELSE
        p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
              p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
        dpp$display_error (' Timing Out File Server invalid cpu queue processor type.');
        RETURN;
      IFEND;
    CASEND;  {cpu_queue_entry.processor_type}

  #KEYPOINT (osk$exit, osk$m * queue_entry_index,
          dfk$process_server_response);

  PROCEND dfp$process_server_response_a;

?? TITLE := '    [XDCL] dfp$process_multiword_response', EJECT ??
  PROCEDURE [XDCL] dfp$process_multiword_response
    (    pp_response_p: ^iot$pp_response;
         detailed_status_p: ^iot$detailed_status;
         pp_number: 1 .. ioc$pp_count;
     var status: syt$monitor_status);

    {
    {  This process executes in the Monitor and is called by
    {  IOP$Process_IO_Completions to process multi word PP
    {  responses from the File Server's PP driver.
    {

    VAR
      completed_request_p: ^iot$disk_request,
      count: integer,
      previously_set: boolean,
      pp_interface_table_p: ^iot$pp_interface_table,
      time: integer,
      timeout: integer;


    status.normal := TRUE;

    completed_request_p := pp_response_p^.request^.device_request_p;

    CASE pp_response_p^.response_code.primary_response OF
    = ioc$normal_response =


{  Interlock the pp_interface_table.

      time := #free_running_clock (0);
      timeout := time + 2000000;
      count := 0;

      REPEAT
        i#test_set_bit (^pp_interface_table_p^, ioc$pp_interface_table_lock_bit, previously_set);
        count := count + 1;
        IF count >= 100 THEN
          time := #free_running_clock (0);
          count := 0;
        IFEND;
      UNTIL (NOT previously_set) OR (time > timeout);

      CASE completed_request_p^.request.command[1].command_code OF
      = ioc$cc_idle =
        IF NOT previously_set THEN
          pp_interface_table_p^.idle_status := TRUE;
        IFEND;

      = ioc$cc_resume =
        IF NOT previously_set THEN
          pp_interface_table_p^.idle_status := FALSE;
        IFEND;

      ELSE
      CASEND;

      IF NOT previously_set THEN
        pp_interface_table_p^.lock := FALSE;
      ELSE
        status.normal := FALSE;
        status.condition := ioc$pp_interlock_set;
      IFEND;

    = ioc$unsolicited_response =

      IF dfv$file_server_debug_enabled THEN
        mtp$error_stop ('dfp$process_multiword_response - unexpected response.');
      IFEND;

    = ioc$abnormal_response =

      IF dfv$file_server_debug_enabled THEN
        mtp$error_stop ('dfp$process_multiword_response - abnormal response.');
      IFEND;

    = ioc$intermediate_response =

    ELSE
    CASEND;

  PROCEND dfp$process_multiword_response;
?? TITLE := '    [XDCL] dfp$process_error_log_response', EJECT ??
  PROCEDURE [XDCL] dfp$process_error_log_response
    (    p_fs_pp_response: ^dft$fs_pp_response;
         p_fs_error_log_response: ^dft$fs_error_log_response;
         pp_number: 1 .. ioc$pp_count;
     VAR status: syt$monitor_status);

    {
    {  This processes constructs a sequence containing ESM log data and calls
    {  dsp$report_system_message which copies the data to a circular buffer.
    {
    {  At a later time the OS will call dfp$log_esm_data which will construct
    {  a sequence of "counter" fields which will be written to the engineering
    {  log by procedure sfp$emit_statistic .
    {

    VAR
      channel: cmt$physical_channel,
      esm_log_seq: SEQ (REP 1 OF dft$esm_log_data),
      iou_number: dst$iou_number,
      logical_unit: iot$logical_unit,
      msg: string (dfc$symptom_message_length),
      msg1: string (40),
      msg_level: dst$system_message_levels,
      msg_recorded: boolean,
      msg_type: dst$system_logging_types,
      p_esm_log_data: ^dft$esm_log_data,
      seq_p: ^SEQ ( * ),
      ud: integer;


    status.normal := TRUE;
    IF NOT cmv$logical_pp_table_p^ [pp_number].flags.configured THEN
      RETURN;
    IFEND;

    logical_unit := p_fs_pp_response^.logical_unit;

  /find_ud/
    BEGIN
      FOR ud := LOWERBOUND (cmv$logical_pp_table_p^ [pp_number].pp_info.
            pp_interface_table_p^.unit_descriptors) TO
            UPPERBOUND (cmv$logical_pp_table_p^ [pp_number].pp_info.
            pp_interface_table_p^.unit_descriptors) DO
        IF cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p^.
              unit_descriptors [ud].logical_unit = logical_unit THEN
          EXIT /find_ud/;
        IFEND;
      FOREND;
    END /find_ud/;

    logical_unit := cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p^.
          unit_descriptors [ud].logical_unit;
    channel.number := cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p^.
          unit_descriptors [ud].physical_path.channel_number;
    channel.concurrent := cmv$logical_pp_table_p^ [pp_number].pp_info.channel_interlock_p^.
          channel_characteristics [channel.number].concurrent_channel;
    iou_number := cmv$logical_pp_table_p^ [pp_number].pp_info.channel.iou_number;

    IF channel.concurrent THEN
      IF cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p^.
            unit_descriptors [ud].physical_path.port = 0 THEN
        channel.port := cmc$port_a;
      ELSE
        channel.port := cmc$port_b;
      IFEND;
    ELSE
      channel.port := cmc$unspecified_port;
    IFEND;

{ Put esm_log_data into sequence.

    seq_p := ^esm_log_seq;
    RESET seq_p;
    NEXT p_esm_log_data IN seq_p;
    RESET seq_p;

    p_esm_log_data^.error_log_response := p_fs_error_log_response^;
    p_esm_log_data^.logical_unit := logical_unit;

    p_esm_log_data^.iou_number := iou_number;
    p_esm_log_data^.pp_number := pp_number;

    p_esm_log_data^.channel := channel;

{ Determine symptom message.

    CASE p_fs_error_log_response^.error_condition OF
    = dfc$function_timeout =
      p_esm_log_data^.symptom_message := 'ERR=VP73000001, CHANNEL FUNCTION TIMEOUT';
    = dfc$iou_channel_parity_error =
      p_esm_log_data^.symptom_message := 'ERR=VP73000002, IOU CHANNEL PARITY ERROR';
    = dfc$esm_channel_parity_error =
      p_esm_log_data^.symptom_message := 'ERR=VP73000003, ESM CHANNEL PARITY ERROR';
    = dfc$esm_double_bit_parity_error =
      p_esm_log_data^.symptom_message := 'ERR=VP73000004, ESM DOUBLE BIT PARITY ERROR';
    = dfc$esm_address_parity_error =
      p_esm_log_data^.symptom_message := 'ERR=VP73000005, ESM ADDRESS PARITY ERROR';
    = dfc$esm_flag_operation_abort =
      p_esm_log_data^.symptom_message := 'ERR=VP73000006, ESM FLAG OPERATION ABORT';
    = dfc$adp_uncorrected_cm_error =
      p_esm_log_data^.symptom_message := 'ERR=VP73000007, ADAPTER UNCORRECTED CM ERROR';
    = dfc$adp_cm_reject =
      p_esm_log_data^.symptom_message := 'ERR=VP73000008, ADAPTER CM REJECT';
    = dfc$adp_invalid_cm_response =
      p_esm_log_data^.symptom_message := 'ERR=VP73000009, ADAPTER INVALID CM RESPONSE';
    = dfc$adp_cm_response_parity_err =
      p_esm_log_data^.symptom_message := 'ERR=VP73000010, ADAPTER CM RESPONSE PARITY ERROR';
    = dfc$adp_cmi_read_parity_err =
      p_esm_log_data^.symptom_message := 'ERR=VP73000011, ADAPTER CMI READ PARITY ERROR';
    = dfc$adp_clock_fault =
      p_esm_log_data^.symptom_message := 'ERR=VP73000012, ADAPTER CLOCK FAULT';
    = dfc$adp_input_buffer_overflow =
      p_esm_log_data^.symptom_message := 'ERR=VP73000013, ADAPTER INPUT BUFFER OVERFLOW';
    = dfc$adp_input_data_parity_error =
      p_esm_log_data^.symptom_message := 'ERR=VP73000014, ADAPTER INPUT DATA PARITY ERROR';
    = dfc$adp_12_16_conversion_error =
      p_esm_log_data^.symptom_message := 'ERR=VP73000015, ADAPTER 12/16 CONVERTION ERROR';
    = dfc$adp_jy_data_parity_error =
      p_esm_log_data^.symptom_message := 'ERR=VP73000016, ADAPTER JY DATA PARITY ERROR';
    = dfc$adp_kx_pp_data_parity_error =
      p_esm_log_data^.symptom_message := 'ERR=VP73000017, ADAPTER BAS (KX PP DATA) PARITY ERROR';
    = dfc$adp_kz_board_detected_error =
      p_esm_log_data^.symptom_message := 'ERR=VP73000018, ADAPTER KZ BOARD DETECTED ERROR';
    = dfc$adp_jy_board_detected_error =
      p_esm_log_data^.symptom_message := 'ERR=VP73000019, ADAPTER JY BOARD DETECTED ERROR';
    = dfc$adp_kx_board_detected_error =
      p_esm_log_data^.symptom_message := 'ERR=VP73000020, ADAPTER KX BOARD DETECTED ERROR';
    = dfc$esm_address_overflow =
      p_esm_log_data^.symptom_message := 'ERR=VP73000021, ESM ADDRESS OVERFLOW';
    = dfc$channel_inactive_error =
      p_esm_log_data^.symptom_message := 'ERR=VP73000022, CHANNEL INACTIVE ERROR';
    = dfc$dma_xfer_halted_early =
      p_esm_log_data^.symptom_message := 'ERR=VP73000023, ADAPTER TRANSFER HALTED EARLY';
    = dfc$lsp_deadman_timeout =
      p_esm_log_data^.symptom_message := 'ERR=VP73000024, LOW SPEED PORT DEADMAN TIMEOUT';
    = dfc$unused_reserved_25 =
      p_esm_log_data^.symptom_message := 'ERR=VP73000025, UNDEFINED ERROR CONDITION';
    = dfc$unused_reserved_26 =
      p_esm_log_data^.symptom_message := 'ERR=VP73000026, UNDEFINED ERROR CONDITION';
    = dfc$unused_reserved_27 =
      p_esm_log_data^.symptom_message := 'ERR=VP73000027, UNDEFINED ERROR CONDITION';
    = dfc$unused_reserved_28 =
      p_esm_log_data^.symptom_message := 'ERR=VP73000028, UNDEFINED ERROR CONDITION';
    = dfc$unused_reserved_29 =
      p_esm_log_data^.symptom_message := 'ERR=VP73000029, UNDEFINED ERROR CONDITION';

    ELSE
      p_esm_log_data^.symptom_message := 'ERR=VP7300GT29, UNDEFINED ERROR CONDITION';
    CASEND;

    IF p_fs_error_log_response^.flags.unrecovered_error THEN
      msg_level := dsc$unrecovered_error;
    ELSE
      msg_level := dsc$recovered_error;
    IFEND;

    msg_type := dsc$fs_stornet_errors;
    dsp$report_system_message (seq_p, msg_type, msg_level, msg_recorded);

    IF dfv$file_server_debug_enabled THEN
{                       1         2         3
{              123456789012345678901234567890
      msg1 := 'IOU   CHnn  -             ';
      ascii_decimal (^msg1 (4, *), 1, iou_number);
      ascii_decimal (^msg1 (9, *), 2, channel.number);

      IF channel.concurrent THEN
        msg1 (6,1) := 'C';       { CIO Channel }
        IF channel.port = cmc$port_a THEN
          msg1 (11,1) := 'A';      { Change to CIO channel PORT A }
        ELSE {port b
          msg1 (11,1) := 'B';      { Change to CIO channel PORT B }
        IFEND;
      ELSE
        ;                          { No change for NIO channel }
      IFEND;

      CASE msg_level OF
      = dsc$unrecovered_error =
        msg1 (15, 11) := 'UNRECOVERED';
      ELSE
        msg1 (15, 11) := 'RECOVERED  ';
      CASEND;

      dpp$display_error (msg1);
      dpp$display_error (p_esm_log_data^.symptom_message);
      display_error_log_response (p_fs_pp_response, p_fs_error_log_response, channel.number, iou_number);
    IFEND;

  PROCEND dfp$process_error_log_response;
?? TITLE := '    process_inquiry_message', EJECT ??

  PROCEDURE process_inquiry_message (
         p_fs_pp_response: ^dft$fs_pp_response;
         p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
     VAR status: syt$monitor_status);

{ This procedure processes inquiry messages. The inquiry tracer portion of the
{ inquiry message must match the last digits of the transaction sequence number
{ and the retransmission count in the cpu queue entry or the inquiry message
{ is ignored unless all of the following conditions are true -
{          1. The inquiry message is received on server side,
{          2. Server's queue entry transaction state is dfc$media_error or
{             or dfc$server_waiting_request.
{          3. The inquiry message transaction digit is one greater than
{             the last transaction count digit in the queue entry.
{        For this case an inquiry response will be returned to the client.
{
{ If the inquiry message is received for the server a transaction state and
{ the inquiry tracer is returned to the client in an inquiry message (response).
{ The transaction state to be returned to the client is not necessarily that
{ which resides in the server's cpu queue entry. The transaction state of
{ dfc$server_sent_response never resides in the server's cpu queue entry but
{ is determined by this procedure.
{ If the inquiry message is received for the client it is a response to an
{ inquiry message sent earlier by the the client. The transaction state in the
{ cpu queue entry will be changed to a more current state if this procedure
{ determines that the inquiry response is appropriate.


    VAR
      local_tracer: dft$inquiry_tracer,
      inquiry_message: dft$inquiry_message,
      ignore_queue_request_status: dft$queue_request_status,
      p_condition: ^pmt$condition_name,
      signal: pmt$signal;

    status.normal := TRUE;

    IF p_fs_pp_response^.response_parameter.inquiry_message.
        transaction_state = dfc$terminate_break_signal THEN
      signal.identifier := pmc$multi_task_condition;
      p_condition := #LOC(signal.contents);
      p_condition^ := dfc$client_terminate_break;
      tmp$send_signal (p_cpu_queue_entry^.global_task_id, signal, status);
      IF NOT status.normal THEN
        dpp$display_error ('DF - Bad status trying to send terminate_break signal');
        status.normal := TRUE;
      IFEND;
      RETURN;
    IFEND;

    IF p_fs_pp_response^.response_parameter.inquiry_message.
        transaction_state = dfc$pause_break_signal THEN
      signal.identifier := pmc$multi_task_condition;
      p_condition := #LOC(signal.contents);
      p_condition^ := dfc$client_pause_break;
      tmp$send_signal (p_cpu_queue_entry^.global_task_id, signal, status);
      IF NOT status.normal THEN
        dpp$display_error ('DF - Bad status trying to send pause_break signal');
        status.normal := TRUE;
      IFEND;
      RETURN;
    IFEND;

    dfp$form_inquiry_tracer (p_cpu_queue_entry^.transaction_count,
        p_cpu_queue_entry^.retransmission_count, local_tracer);

    IF p_fs_pp_response^.response_parameter.inquiry_message.inquiry_tracer = local_tracer THEN

      IF p_queue_interface_table^.queue_directory.driver_queue_pva_directory[queue_index].
         p_driver_queue^.queue_header.connection_descriptor.source.flags.server_to_client THEN
        { SERVER SIDE - PROCESS INQUIRY MESSAGE }

          CASE p_cpu_queue_entry^.transaction_state OF
          = dfc$server_waiting_request =
            IF p_driver_queue_entry^.flags.driver_action THEN
              { Server has processed the request and queued the response, however the
              { the response has not been sent by the driver yet.
              { The request response should reach client before this inquiry
              { response, so the inquiry response will not be sent.
              RETURN;
            ELSE
              { Server processed the request and the response has been sent by the driver.
              { Send Inquiry response so that if Client side PP driver could'nt
              { read the header portion of the request response to identify the QE
              { the request can be timed out and retransmitted.
              inquiry_message.transaction_state := dfc$server_sent_response;
            IFEND;

          = dfc$server_must_read_page_data, dfc$server_received_request,
            dfc$message_content_error, dfc$media_error =
            inquiry_message.transaction_state := p_cpu_queue_entry^.transaction_state;
          ELSE
            ;
          CASEND;
          inquiry_message.inquiry_tracer := local_tracer;
          { Answer inquiry message.
          dfp$queue_inquiry_request (p_queue_interface_table, queue_index, queue_entry_index,
              inquiry_message, ignore_queue_request_status);

      ELSE
        { CLIENT SIDE - PROCESS INQUIRY RESPONSE }

        CASE p_cpu_queue_entry^.transaction_state OF
        = dfc$request_sent, dfc$server_waiting_request, dfc$server_sent_response,
          dfc$server_must_read_page_data, dfc$server_received_request =
          { These transaction state indicate Client is waiting for a request response.
          { Set Client's latest transaction state to that in inquiry response.
          p_cpu_queue_entry^.transaction_state := p_fs_pp_response^.response_parameter.
               inquiry_message.transaction_state;

          { Now check the transaction_state received by the Client.
          CASE p_fs_pp_response^.response_parameter.inquiry_message.transaction_state OF
          = dfc$server_waiting_request, dfc$server_sent_response =
            { Increment timeout_count each time client receives this inquiry response
            { so that incase Client or Server side driver fails reading header portion of
            { the message the request will be timed out and retransmitted.
            p_cpu_queue_entry^.request_timeout_count :=  p_cpu_queue_entry^.request_timeout_count + 1;
          = dfc$server_must_read_page_data, dfc$server_received_request =
            { Re-set timeout_count each time client receives this inquiry response.
            { As long as inquiry response indicate this state the connection is
            { still alive, Server is just slow in processing request.
            p_cpu_queue_entry^.request_timeout_count := 0;
          ELSE
          ;
          CASEND;

        ELSE { ignore inquiry response for all other client state cases }
          ;
        CASEND;

      IFEND;
    ELSE { No match on inquiry tracer.
      { Increment local_tracer.transaction_digit by one and compare.
      dfp$form_inquiry_tracer (p_cpu_queue_entry^.transaction_count + 1,
          p_cpu_queue_entry^.retransmission_count, local_tracer);
      IF (p_queue_interface_table^.queue_directory.driver_queue_pva_directory[queue_index].
          p_driver_queue^.queue_header.connection_descriptor.source.flags.server_to_client)
         AND (p_fs_pp_response^.response_parameter.inquiry_message.inquiry_tracer.
              transaction_digit = local_tracer.transaction_digit) THEN
        CASE p_cpu_queue_entry^.transaction_state OF
        = dfc$media_error, dfc$message_content_error, dfc$server_waiting_request =
        { Server side, inquiry for transaction which is one greater than the
        { last transaction processed by the server.
        { If transaction_state is dfc$media_error, assume that a failure
        { occured while reading 'command buffer' portion of the request so that
        { transaction_count was not incremented.
        { If transaction_state is dfc$server_waiting_request, assume that
        { a failure occured while reading the 'header" portion of the request
        { so that the queue entry could not be identified and updated to
        { the transaction_state of dfc$media_error.

          inquiry_message.inquiry_tracer := p_fs_pp_response^.response_parameter.
               inquiry_message.inquiry_tracer;
          inquiry_message.transaction_state := p_cpu_queue_entry^.transaction_state;
          { Answer inquiry message.
          dfp$queue_inquiry_request (p_queue_interface_table, queue_index, queue_entry_index,
              inquiry_message, ignore_queue_request_status);

        = dfc$server_received_request, dfc$server_must_read_page_data =
          IF NOT p_driver_queue_entry^.flags.subsystem_action THEN

{           This is the case when the PP response is processed in dfp$process_server_response,
{           the transaction_state has been set, the subsystem_action flag has been set,
{           but the queue_entry has been cleared prior to the tmp$set_task_ready call.

            IF dfv$file_server_debug_enabled THEN
              dpp$display_error ('DF - INFORMATIVE, SERVER SIDE MISSED TASK READY.');
              display_integer_monitor ('DF - QUEUE INDEX', queue_index);
              display_integer_monitor ('DF - QUEUE ENTRY INDEX ' , queue_entry_index);
            IFEND;
            p_driver_queue_entry^.flags.subsystem_action := TRUE;
          IFEND;
        ELSE
        ;
        CASEND;
      ELSE { Still no match on Inquiry Tracer.
        IF (p_queue_interface_table^.queue_directory.driver_queue_pva_directory[queue_index].
            p_driver_queue^.queue_header.connection_descriptor.source.flags.server_to_client)
           AND (queue_entry_index = dfc$poll_queue_index) THEN
{         Server Side, inquiry is for POLLER.
          CASE p_queue_interface_table^.queue_directory.cpu_queue_pva_directory[queue_index].
            p_cpu_queue^.queue_header.partner_status.server_state OF
          = dfc$inactive, dfc$terminated, dfc$awaiting_recovery =
            IF p_queue_interface_table^.queue_directory.cpu_queue_pva_directory[queue_index].
               p_cpu_queue^.queue_header.partner_status.verify_queue THEN

{             The operator on the client machine typed ACTS before the operator
{             on the server machine typed ACTC so that the POLLER's
{             "verify_queue" message was never delivered to the server.
{             {sequence example: 1. deactivate_server 2. terminate_server
{                                3. activate_server   4. activate_client }
{             If the server side was never terminated (TERC) the transaction
{             sequence count is not re-set. Force response to inquiry messages
{             so that timeout and retransmission will occur.

              inquiry_message.inquiry_tracer := p_fs_pp_response^.response_parameter.
                   inquiry_message.inquiry_tracer;
              inquiry_message.transaction_state := p_cpu_queue_entry^.transaction_state;
              { Answer inquiry message.
              dfp$queue_inquiry_request (p_queue_interface_table, queue_index, queue_entry_index,
                  inquiry_message, ignore_queue_request_status);
            IFEND;
          ELSE
            ;
          CASEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND process_inquiry_message;

?? TITLE := '    [XDCL] dfp$process_request_timeout', EJECT ??
  PROCEDURE [XDCL] dfp$process_request_timeout
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index);

{ This procedure processes request timeouts for the client.
{ Depending on the timeout count and the current transaction state
{ either an inquiry will be sent to the server, or the request will
{ be retransmitted.
{ The request_timeout_count is incremented in procedure Process_Inquiry_Response
{ so that request retransmission due to timeout is only attempted when the
{ the connection is not broken (inquiries getting through).
{ The "deadman timeout" on POLL requests in dfm$manage_server_connection
{ process Time_Out_Requests will detect a broken connection.

    VAR
      local_tracer: dft$inquiry_tracer,
      ignore_queue_request_status: dft$queue_request_status,
      inquiry_message: dft$inquiry_message,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry;

    dfp$fetch_queue_entry (p_queue_interface_table, queue_index,
         queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry);

    CASE p_cpu_queue_entry^.transaction_state OF
    = dfc$request_queued =
      { Check if transaction state can be upgraded to request_sent.
      IF (NOT p_driver_queue_entry^.flags.driver_action) AND
         (NOT p_driver_queue_entry^.flags.subsystem_action) AND
         (NOT p_driver_queue_entry^.flags.process_response) THEN
        p_cpu_queue_entry^.transaction_state := dfc$request_sent;
        RETURN;
      IFEND;
    = dfc$media_error, dfc$message_content_error =
      { Transaction state dfc$media_error is set on error response for client, or on an
      { inquiry message response from the server with a server transaction state of
      { dfc$media_error. This transaction state means the PP driver detected hardware
      { failure.
      { Transaction state dfc$message_content_error is set on an inquiry message
      { response from the server. This transaction state means the server task
      { detected some error or inconsistency in the the content of the command buffer
      { received from the client (possibly due to an undetected hardware error).
      { Attempt to queue the request for retransmission.
      dfp$retransmit_request (p_queue_interface_table, queue_index,
          queue_entry_index, p_cpu_queue_entry, p_driver_queue_entry);
      RETURN;

    ELSE
      ;
    CASEND;

    IF p_cpu_queue_entry^.request_timeout_count <= p_queue_interface_table^.queue_directory.
       cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header.
       maximum_request_timeout_count THEN

      CASE p_cpu_queue_entry^.transaction_state OF
      = dfc$request_sent, dfc$server_sent_response, dfc$server_waiting_request,
        dfc$server_must_read_page_data, dfc$server_received_request =
        dfp$form_inquiry_tracer (p_cpu_queue_entry^.transaction_count,
            p_cpu_queue_entry^.retransmission_count, local_tracer);
        inquiry_message.inquiry_tracer := local_tracer;
        inquiry_message.transaction_state := p_cpu_queue_entry^.transaction_state;
        dfp$queue_inquiry_request (p_queue_interface_table, queue_index, queue_entry_index,
            inquiry_message, ignore_queue_request_status);
      ELSE
        { Do Nothing.
      CASEND;

    ELSE { Maximum Timeouts.
      dfp$retransmit_request (p_queue_interface_table, queue_index,
          queue_entry_index, p_cpu_queue_entry, p_driver_queue_entry);
    IFEND;

  PROCEND dfp$process_request_timeout;

?? TITLE := '    [XDCL] dfp$retransmit_request', EJECT ??
  PROCEDURE [XDCL] dfp$retransmit_request
    (    p_queue_interface_table: ^dft$queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry);

{ This procedure is called to retransmit a request on behalf of the client.
{ The request timeout count is reset to zero, and the retransmission count
{ is incremented both in the cpu_queue_entry and in the request buffer header.
{ If the retransmitted request cannot be the queue entry's values which were
{ changed are restored to there previous value.

    VAR
      driver_queue_flags: dft$queue_entry_flags,
      m_status: syt$monitor_status,
      p_buffer_header: ^dft$buffer_header,
      p_command_buffer: dft$p_command_buffer,
      qr_status: dft$queue_request_status;

    IF p_cpu_queue_entry^.retransmission_count < p_queue_interface_table^.queue_directory.
       cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header.
       maximum_retransmission_count THEN

      p_command_buffer := p_cpu_queue_entry^.p_send_buffer;
      RESET p_command_buffer;
      NEXT p_buffer_header IN p_command_buffer;

      p_cpu_queue_entry^.retransmission_count := p_cpu_queue_entry^.retransmission_count + 1;
      p_buffer_header^.retransmission_count := p_cpu_queue_entry^.retransmission_count;
      driver_queue_flags := p_driver_queue_entry^.flags;
      p_driver_queue_entry^.flags := p_cpu_queue_entry^.copied_queue_entry_flags;

      dfp$queue_request (p_queue_interface_table, queue_index, queue_entry_index, qr_status);
      IF qr_status <> dfc$qrs_entry_queued THEN
        { Attempt to restore values changed for retransmission.
        { Backoff retransmission count. Transaction state remains as it was.
        { dfp$process_request_timeout will call this process on next timeout.

        IF dfv$file_server_debug_enabled THEN
          dpp$display_error ('DF - UNABLE TO QUEUE RETRANSMITTED REQUEST FOR -');
          display_integer_monitor ('     Queue Index ', queue_index);
          display_integer_monitor ('     Queue Entry ', queue_entry_index);
          display_integer_monitor ('     Transaction No. ', p_cpu_queue_entry^.transaction_count);
          display_integer_monitor ('     Retransmission No. ', p_cpu_queue_entry^.retransmission_count);
        IFEND;

        p_cpu_queue_entry^.retransmission_count := p_cpu_queue_entry^.retransmission_count - 1;
        p_buffer_header^.retransmission_count := p_cpu_queue_entry^.retransmission_count;
        p_driver_queue_entry^.flags := driver_queue_flags;

      ELSE
        IF dfv$file_server_debug_enabled THEN
          dpp$display_error ('DF - RETRANSMITTED REQUEST FOR -');
          display_integer_monitor ('     Queue Index ', queue_index);
          display_integer_monitor ('     Queue Entry ', queue_entry_index);
          display_integer_monitor ('     Transaction No. ', p_cpu_queue_entry^.transaction_count);
          display_integer_monitor ('     Retransmission No. ', p_cpu_queue_entry^.retransmission_count);
        IFEND;
      IFEND;

    IFEND;

  PROCEND dfp$retransmit_request;
?? TITLE := '    ascii_decimal', EJECT ??
  PROCEDURE ascii_decimal (msg: ^string ( * );
        number_of_characters: 1 .. 4;
        word: 0 .. 0ffff(16));

    VAR
      i: integer,
      k: integer,
      divisor: [STATIC] array [1 .. 4] of integer := [1, 10, 100, 1000];


    k := 1;
    FOR i := number_of_characters DOWNTO 1 DO
      msg^ (i) := CHR (((word DIV divisor [k]) MOD 10) + ORD ('0'));
      k := k + 1;
    FOREND;
  PROCEND ascii_decimal;
?? TITLE := '    display_error_log_response', EJECT ??
  PROCEDURE display_error_log_response
    (    p_fs_pp_response: ^dft$fs_pp_response;
         p_fs_error_log_response: ^dft$fs_error_log_response;
         channel_number: 0 .. 0ff(16);
         iou_number: dst$iou_number);

{
{   This procedure intended for debug use.
{   The queue_entry_index and queue_index may not be valid depending on
{   depending on when the driver detected the error.

    VAR
      queue_entry_index: INTEGER,
      queue_index: INTEGER;


    queue_index := p_fs_pp_response^.queue_index;
    queue_entry_index := p_fs_pp_response^.queue_entry_index;

    dpp$display_error ('DF - ERROR LOG RESPONSE PROCESSOR - ');
    display_integer_monitor ('  QUEUE INDEX', queue_index);
    display_integer_monitor ('  QUEUE ENTRY INDEX ' , queue_entry_index);
    IF p_fs_error_log_response^.flags.unrecovered_error THEN
      dpp$display_error ('    UNRECOVERED ERROR ');
    ELSE
      dpp$display_error ('    RECOVERED ERROR ');
    IFEND;
    display_integer_monitor ('    ERROR CONDITION = ', p_fs_error_log_response^.error_condition);
    display_integer_monitor ('    IOU = ', iou_number);
    display_integer_monitor ('    CHANNEL = ', channel_number);
    display_integer_monitor ('    RETRY COUNT = ', p_fs_error_log_response^.retry_count);
    display_integer_monitor ('    LAST CH FUNCTION = ', p_fs_error_log_response^.last_ch_function);
    display_integer_monitor ('    ESM LSP FUNCTION = ', p_fs_error_log_response^.esm_lsp_function);
    display_integer_monitor ('    ESM LSP STATUS = ', p_fs_error_log_response^.esm_lsp_status);
    display_integer_monitor ('    ESM ADDRESS = ', p_fs_error_log_response^.esm_address);
    display_integer_monitor ('    RESIDUAL BYTE COUNT = ', p_fs_error_log_response^.residual_byte_count);
    display_integer_monitor ('    TRANSFER BYTE COUNT = ', p_fs_error_log_response^.transfer_byte_count);
    IF p_fs_error_log_response^.flags.C170_dma_adapter AND
       p_fs_error_log_response^.flags.executing_adapter_io THEN
      display_integer_monitor ('    ADAPTER CONTROL REGISTER = ',
            p_fs_error_log_response^.adapter_control_register);
      display_integer_monitor ('    ADAPTER ERROR STATUS = ',
            p_fs_error_log_response^.adapter_error_status);
      display_integer_monitor ('    ADAPTER OP STATUS REGISTER = ',
            p_fs_error_log_response^.adapter_op_status_register);
      IF p_fs_error_log_response^.flags.adapter_t_register_loaded THEN
        display_integer_monitor ('    ADAPTER T REG BYTE COUNT = ',
              p_fs_error_log_response^.adapter_t_register.byte_count);
        display_integer_monitor ('    ADAPTER T REG CM ADDRESS = ',
              p_fs_error_log_response^.adapter_t_register.cm_address);
        display_integer_monitor ('    INITIAL ADAPTER T REG BYTE COUNT = ',
              p_fs_error_log_response^.initial_adapter_t_register.byte_count);
        display_integer_monitor ('    INITIAL ADAPTER T REG CM ADDRESS = ',
              p_fs_error_log_response^.initial_adapter_t_register.cm_address);
      ELSE
        dpp$display_error ('    ERROR PRIOR TO FIRST T REG LOAD.');
      IFEND;
    ELSE
      dpp$display_error ('    ERROR DURING NON ADAPTER IO.');
    IFEND;

  PROCEND display_error_log_response;
MODEND dfm$process_server_response;
*DECK DECK=DFM$QUEUE_ENTRY_CONTROL EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE FIle Server: queue_entry_control', EJECT ??
MODULE dfm$queue_entry_control;
{
{  This module contains code to control the assignment and releasing of
{  queue entries. Also included is code to queue a request.
{  This module resides both in monitor and task services.
{
?? NEWTITLE := '    Global Declarations', EJECT ??
*copyc dfc$poll_constants
*copyc dft$request_buffer
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfk$keypoints
*copyc dft$assign_queue_entry_status
*copyc dft$cpu_queue
*copyc dft$inquiry_message
*copyc dft$queue_index
*copyc dft$queue_request_status
*copyc dft$release_queue_entry_status
*copyc dft$transaction_state
*copyc dfv$false_queue_entry_flags
*copyc dfv$file_server_debug_enabled
*copyc dfv$null_global_task_id
*copyc dfv$null_request_buffer_entry
*copyc i#program_error
*copyc osd$virtual_address
*copyc osv$external_interrupt_selector
*copyc osp$fetch_locked_variable
*copyc pmp$zero_out_table
?? POP ??
?? TITLE := ' Key INLINE procedures ', EJECT ??
*copyc dfp$assign_entry
*copyc dfp$free_entry_assignment
*copyc dfp$test_driver
?? TITLE := ' Global Declarations ', EJECT ??

  VAR
    dmv$external_interrupt_selector: [XREF] 0 .. 0ff(16);


?? TITLE := ' [XDCL] dfp$assign_queue_entry ', EJECT ??
*copyc dfh$assign_queue_entry

  PROCEDURE [XDCL] dfp$assign_queue_entry
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_type: dft$queue_entry_type;
     VAR queue_entry_index: dft$queue_entry_index;
     VAR assign_status: dft$assign_queue_entry_status);

{ NOTE: It is assummed that prior to the execution of this procedure
{       osp$begin_system_activity will have been executed.

    VAR
      entry_found: integer,
      p_cpu_queue: ^dft$cpu_queue;

    p_cpu_queue := p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
        p_cpu_queue;
    #KEYPOINT (osk$entry, osk$m * queue_index, dfk$assign_queue_entry);
    { Trap code
    IF dfv$file_server_debug_enabled THEN
      IF (p_queue_interface_table = NIL) OR (queue_index > p_queue_interface_table^.queue_directory.
            number_of_queues) THEN
        i#program_error;
        RETURN;
      IFEND;
    IFEND; { End of Trap code.

   IF (p_cpu_queue^.queue_header.partner_status.server_state = dfc$terminated) OR
      (p_cpu_queue^.queue_header.partner_status.server_state = dfc$inactive) OR
     (p_cpu_queue^.queue_header.partner_status.server_state = dfc$awaiting_recovery) THEN
   { It is assumed that the poller does not assign its queue entry index via here
      assign_status := dfc$aqes_server_terminated;
      #KEYPOINT (osk$exit, 0, dfk$assign_queue_entry);
      RETURN;
   IFEND;

    assign_status := dfc$aqes_no_available_entries;
    IF queue_entry_type = dfc$monitor THEN
      dfp$assign_entry ({starting_position = } dfc$poll_queue_index + 1,
            p_cpu_queue^.queue_header.number_of_monitor_queue_entries,
            p_cpu_queue^.
            queue_header.queue_entry_assignment_table, entry_found);
    ELSE { task services }
      dfp$assign_entry ({starting_position = }
      (p_cpu_queue^.
            queue_header.number_of_monitor_queue_entries + dfc$poll_queue_index + 1),
            p_cpu_queue^.
            queue_header.number_of_task_queue_entries,
            p_cpu_queue^.queue_header.queue_entry_assignment_table,
            entry_found);
    IFEND;
    IF entry_found > 0 THEN
      queue_entry_index := entry_found;

      { Trap code
      IF dfv$file_server_debug_enabled THEN
        IF (p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
            p_driver_queue^.queue_entries [queue_entry_index].flags.driver_action) THEN
          i#program_error;
        IFEND;
        IF p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
           p_driver_queue^.queue_entries [queue_entry_index].flags.active_entry THEN
          i#program_error;
        IFEND;
      IFEND; { End of Trap code.

      assign_status := dfc$aqes_entry_assigned;
      p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue^.
            queue_entries [queue_entry_index].flags.active_entry := TRUE;
{     Only client side tasks use dfp$assign_queue_entry to get a queue entry.
      p_cpu_queue^.
            queue_entries [queue_entry_index].transaction_state := dfc$queue_entry_assigned;
    IFEND;
    #KEYPOINT (osk$exit, osk$m * queue_entry_index, dfk$assign_queue_entry);
  PROCEND dfp$assign_queue_entry;
?? TITLE := ' [XDCL] dfp$queue_inquiry_request ', EJECT ??
*copyc dfh$queue_inquiry_request

  PROCEDURE [XDCL] dfp$queue_inquiry_request
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         inquiry_message: dft$inquiry_message;
     VAR queue_request_status: dft$queue_request_status);

{ The Inquiry request provides a means by which the file server may correspond
{ between client and server side in regard to the status of a task. The driver
{ processes inquiry requests without regard to the driver queue entry.

    VAR
      request_buffer_entry: dft$request_buffer_entry;


    #KEYPOINT (osk$entry, osk$m * queue_entry_index, dfk$queue_inquiry_request);
    { Trap code
    IF dfv$file_server_debug_enabled THEN
      IF (p_queue_interface_table = NIL) OR (queue_index > p_queue_interface_table^.queue_directory.
          number_of_queues) THEN
        i#program_error;
      IFEND;
      IF (queue_entry_index <= 0) OR (queue_entry_index > p_queue_interface_table^.queue_directory.
          driver_queue_pva_directory [queue_index].p_driver_queue^.queue_header.number_of_queue_entries) THEN
        i#program_error;
      IFEND;
      IF NOT p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
         p_driver_queue^.queue_entries [queue_entry_index].flags.active_entry THEN
        i#program_error;
      IFEND;
    IFEND; { End of Trap code.

    request_buffer_entry := dfv$null_request_buffer_entry;
    request_buffer_entry.flags.inquiry := TRUE;
    request_buffer_entry.inquiry_message := inquiry_message;
    request_buffer_entry.queue_index := queue_index;
    request_buffer_entry.queue_entry_index := queue_entry_index;
    store_request_buffer_entry ( p_queue_interface_table, queue_index, queue_entry_index,
         request_buffer_entry, TRUE {INQUIRY}, queue_request_status);
    { Queueing Inquiry request does not affect transaction state.

    CASE queue_request_status OF
    = dfc$qrs_entry_queued =
      #KEYPOINT (osk$exit, osk$m * queue_entry_index, dfk$queue_inquiry_request);

    ELSE
      #KEYPOINT (osk$exit, 0, dfk$queue_inquiry_request);
    CASEND;


  PROCEND dfp$queue_inquiry_request;
?? TITLE := ' [XDCL] dfp$queue_request ', EJECT ??
*copyc dfh$queue_request

  PROCEDURE [XDCL] dfp$queue_request
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
     VAR queue_request_status: dft$queue_request_status);

    VAR
      copied_queue_entry_flags: dft$queue_entry_flags,
      request_buffer_entry: dft$request_buffer_entry;


    #KEYPOINT (osk$entry, osk$m * queue_entry_index, dfk$queue_request);
    { Trap code
    IF dfv$file_server_debug_enabled THEN
      IF (p_queue_interface_table = NIL) OR (queue_index > p_queue_interface_table^.queue_directory.
          number_of_queues) THEN
        i#program_error;
      IFEND;
      IF (queue_entry_index <= 0) OR (queue_entry_index > p_queue_interface_table^.queue_directory.
          driver_queue_pva_directory [queue_index].p_driver_queue^.queue_header.number_of_queue_entries) THEN
        i#program_error;
      IFEND;
      IF NOT p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
         p_driver_queue^.queue_entries [queue_entry_index].flags.active_entry THEN
        i#program_error;
      IFEND;
      IF (NOT p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue^.queue_header.connection_descriptor.source.flags.server_to_client) AND
          (p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].p_cpu_queue^.
          queue_header.queue_entry_assignment_table (queue_entry_index) = dfc$free_entry_char) THEN
        { Client to Server queue, and entry free.
        i#program_error;
      IFEND;
      IF (NOT p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue^.queue_entries [queue_entry_index].flags.driver_action) THEN
        i#program_error;
      IFEND;
      IF p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
         p_driver_queue^.queue_entries [queue_entry_index].flags.send_ready_for_data THEN
        IF (p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
           p_driver_queue^.queue_entries [queue_entry_index].flags.send_command)
           OR (p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
           p_driver_queue^.queue_entries [queue_entry_index].flags.send_data) THEN
          i#program_error;
        IFEND;
      IFEND;
    IFEND; { End of Trap code.

    IF dmv$external_interrupt_selector = 1 THEN
      p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue^.
            queue_header.interrupt.interrupt.value := TRUE;
      p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue^.
            queue_header.interrupt.interrupt.port_number := osv$external_interrupt_selector;
    ELSE
      p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue^.
            queue_header.interrupt.interrupt.value := FALSE;
    IFEND;
    copied_queue_entry_flags := p_queue_interface_table^.queue_directory.
          driver_queue_pva_directory [queue_index].p_driver_queue^.
          queue_entries [queue_entry_index].flags;
    request_buffer_entry := dfv$null_request_buffer_entry;
    request_buffer_entry.queue_index := queue_index;
    request_buffer_entry.queue_entry_index := queue_entry_index;
    store_request_buffer_entry ( p_queue_interface_table, queue_index, queue_entry_index,
         request_buffer_entry, FALSE {NOT INQUIRY}, queue_request_status);

    IF (copied_queue_entry_flags.send_command) AND (queue_request_status = dfc$qrs_entry_queued) THEN
      { Save request/response driver queue entry command flags in cpu queue entry.
      p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].p_cpu_queue^.
            queue_entries [queue_entry_index].copied_queue_entry_flags := copied_queue_entry_flags;

      IF  p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
            p_driver_queue^.queue_header.connection_descriptor.source.flags.server_to_client THEN
        { SERVER SENDING TO CLIENT.
        { RESPONSE TO CLIENT - save response command flags, and reset server transaction state.
        p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].p_cpu_queue^.
              queue_entries [queue_entry_index].transaction_state := dfc$server_waiting_request;
      ELSE
        { CLIENT SENDING TO SERVER.
        { INITIAL SEND REQUEST - save flags for possible retransmission, and advance state.
        p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].p_cpu_queue^.
              queue_entries [queue_entry_index].transaction_state := dfc$request_queued;
      IFEND;
    IFEND;

    CASE queue_request_status OF
    = dfc$qrs_entry_queued =
      #KEYPOINT (osk$exit, osk$m * queue_entry_index, dfk$queue_request);

    ELSE
      #KEYPOINT (osk$exit, 0, dfk$queue_request);
    CASEND;

  PROCEND dfp$queue_request;
?? TITLE := '  [XDCL] dfp$release_queue_entry ', EJECT ??
*copyc dfh$release_queue_entry

  PROCEDURE [XDCL] dfp$release_queue_entry
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
     VAR release_status: dft$release_queue_entry_status);


    #KEYPOINT (osk$entry, osk$m * queue_index, dfk$release_queue_entry);
    { Trap code
    IF dfv$file_server_debug_enabled THEN
      IF queue_index > p_queue_interface_table^.queue_directory.number_of_queues THEN
        i#program_error;
      IFEND;
      IF queue_entry_index > p_queue_interface_table^.queue_directory.
         driver_queue_pva_directory [queue_index].p_driver_queue^.queue_header.number_of_queue_entries THEN
        i#program_error;
      IFEND;
      IF p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].p_cpu_queue^.
          queue_header.queue_entry_assignment_table (queue_entry_index) = dfc$free_entry_char THEN
        i#program_error;
      IFEND;
      IF (p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue^.
          queue_entries [queue_entry_index].flags.driver_action) THEN
        i#program_error;
      IFEND;
      IF p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
         p_driver_queue^.queue_entries [queue_entry_index].held_over_esm_division_number <> 0 THEN
        i#program_error;
      IFEND;
    IFEND; { End of Trap code.

    p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue^.
          queue_entries [queue_entry_index].flags := dfv$false_queue_entry_flags;
    p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue^.
          queue_entries [queue_entry_index].error_condition := 0;
    p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue^.
          queue_entries [queue_entry_index].held_over_cm_word_count := 0;
    p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue^.
          queue_entries [queue_entry_index].held_over_esm_division_number := 0;
    p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue^.
          queue_entries [queue_entry_index].data_descriptor.actual_length := 0;
    p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].p_cpu_queue^.
          queue_entries [queue_entry_index].transaction_state := dfc$queue_entry_available;
    p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].p_cpu_queue^.
          queue_entries [queue_entry_index].request_timeout_count := 0;
    p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].p_cpu_queue^.
          queue_entries [queue_entry_index].retransmission_count := 0;
    p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].p_cpu_queue^.
          queue_entries [queue_entry_index].global_task_id := dfv$null_global_task_id;


    release_status := dfc$rqes_entry_released;
    dfp$free_entry_assignment (queue_entry_index, p_queue_interface_table^.queue_directory.
          cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header.queue_entry_assignment_table);
    #KEYPOINT (osk$exit, osk$m * queue_entry_index, dfk$release_queue_entry);
  PROCEND dfp$release_queue_entry;
?? TITLE := ' STORE_REQUEST_BUFFER_ENTRY [INLINE] ', EJECT ??

  PROCEDURE [INLINE] store_request_buffer_entry
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         request_buffer_entry: dft$request_buffer_entry;
         inquiry: boolean;
     VAR queue_request_status: dft$queue_request_status);
{
{  This process makes the request visable to the driver by obtaining an entry
{ in the request_buffer and storing the request pointers into the entry.
{ Since more than one copy of this program is executing the request_buffer
{ in_offset must be locked when incremented.  Note that the request_buffer is
{ a circular buffer with IN , OUT, and LIMIT offsets.  This process updates the
{ IN offset to point to the next available entry if an entry is assigned.
{ The file server driver updates the OUT offset when an entry is processed.

    VAR
      actual: integer,
      initial_in: integer,
      new_in: integer,
      out: integer,
      p_cpu_queue: ^dft$cpu_queue,
      request_buffer_entry_index: 1 .. dfc$max_request_buffer_entries,
      result: 0 .. 2;

    CONST
      swap_successful = 0,
      swap_failed = 2;

    p_cpu_queue := p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
        p_cpu_queue;
    IF ((p_cpu_queue^.queue_header.partner_status.server_state = dfc$terminated) OR
       (p_cpu_queue^.queue_header.partner_status.server_state = dfc$inactive) OR
       (p_cpu_queue^.queue_header.partner_status.server_state = dfc$awaiting_recovery)) AND
         (NOT p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
         p_driver_queue^.queue_header.connection_descriptor.source.flags.server_to_client)
         AND (queue_entry_index <> dfc$poll_queue_index) THEN   {not poller
      queue_request_status := dfc$qrs_server_terminated;
      RETURN;
    IFEND;

    result := swap_failed;

  /get_request_buffer_entry/
    REPEAT
      osp$fetch_locked_variable (p_queue_interface_table^.request_buffer_directory.inn, initial_in);
      new_in := initial_in + 8;
      #SPOIL (p_queue_interface_table^.request_buffer_directory.limit);
      IF new_in >= p_queue_interface_table^.request_buffer_directory.limit THEN
        new_in := 0;
      IFEND;
      #SPOIL (p_queue_interface_table^.request_buffer_directory.out);
      IF new_in = p_queue_interface_table^.request_buffer_directory.out THEN
        queue_request_status := dfc$qrs_request_buffer_full;
        RETURN;
      ELSE
        IF NOT inquiry THEN
          p_cpu_queue^.queue_entries [queue_entry_index].request_start_time := #FREE_RUNNING_CLOCK (0);
          p_cpu_queue^.queue_entries [queue_entry_index].last_time_progress_checked := 0;
          p_cpu_queue^.queue_entries [queue_entry_index].request_timeout_count := 0;
        IFEND;
        request_buffer_entry_index := (initial_in DIV 8) + 1;
        #COMPARE_SWAP (p_queue_interface_table^.request_buffer_directory.inn, initial_in, new_in, actual,
              result);
      IFEND;
    UNTIL result = swap_successful;

    { The request buffer entry must be initialized with ONE assignment
    { since the PP is expecting a consistent entry.
    { Note: The interval between the compare_swap and the assignement should
    {   be as small as possible since the request buffer is frozen till the
    {   entry is queued.
    p_queue_interface_table^.request_buffer_directory.p_request_buffer^.
          request_buffer_entries [request_buffer_entry_index] := request_buffer_entry;
    #SPOIL (p_queue_interface_table^.request_buffer_directory.p_request_buffer^.
          request_buffer_entries [request_buffer_entry_index]);
    queue_request_status := dfc$qrs_entry_queued;
    IF (#RING (p_queue_interface_table) = osc$user_ring) AND
          (p_cpu_queue^.queue_header.connection_type = dfc$mock_connection) THEN
      dfp$test_driver (p_queue_interface_table);
    IFEND;

  PROCEND store_request_buffer_entry;

MODEND dfm$queue_entry_control;
*DECK DECK=DFM$QUEUE_INITIALIZATION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File Server: queue_initialization ' ??
MODULE dfm$queue_initialization;

{ PURPOSE:
{   The purpose of this module is to allow for creation and initialization of the queue interface directory,
{   queue interface table, driver queues, and cpu queues.  All tables allocated are  allocated in the server
{   wired segment.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfc$loopback_server_mainframe
*copyc dfc$poll_constants
*copyc dfd$driver_queue_types
*copyc dfd$request_package
*copyc dfe$error_condition_codes
*copyc dfi$display
*copyc dfi$log_display
*copyc dfs$server_wired
*copyc dft$allocated_rpc_data
*copyc dft$command_buffer
*copyc dft$connection_parameters
*copyc dft$cpu_queue
*copyc dft$display_identifier
*copyc dft$page_io_request
*copyc dft$page_io_response
*copyc dft$partner_mainframe_list
*copyc dft$partner_queue_list
*copyc dft$queue_interface_directory
*copyc dpt$window_id
*copyc jmt$active_job_list
*copyc jmt$jl_job_leveler_status
*copyc oss$job_paged_literal
*copyc ost$signature_lock_status
*copyc pmt$mainframe_id
*copyc syt$180_idle_code
?? POP ??
*copyc clp$get_value
*copyc clp$scan_argument_list
*copyc clp$scan_parameter_list
*copyc cmp$store_file_server_info
*copyc dfp$change_family_server_state
*copyc dfp$display
*copyc dfp$free_image_file
*copyc dfp$get_client_mf_file_info
*copyc dfp$get_highest_sf_lifetime
*copyc dfp$get_queue_directory_index
*copyc dfp$verify_element_name
*copyc dfp$word_boundary
*copyc i#real_memory_address
*copyc jmp$called_by_job_leveler
*copyc jmp$convert_date_time_to_clock
*copyc jmp$verify_job_leveler
*copyc osp$append_status_integer
*copyc osp$clear_job_signature_lock
*copyc osp$convert_to_real_model_num
*copyc osp$fetch_locked_variable
*copyc osp$initialize_signature_lock
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osp$test_sig_lock
*copyc osp$verify_system_privilege
*copyc pmp$convert_binary_mainframe_id
*copyc pmp$convert_mainframe_to_binary
*copyc pmp$get_compact_date_time
*copyc pmp$wait
*copyc pmp$zero_out_table
?? EJECT ??
*copyc dfv$file_server_debug_enabled
*copyc dfv$one_word_response_handler
*copyc dfv$p_queue_interface_directory
*copyc dfv$queue_initialization_lock
*copyc dfv$server_wired_heap
*copyc dmv$null_sfid
*copyc osv$page_size
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    v$assigned_to_m: [READ, oss$job_paged_literal] string (256) :=
          '???????????????????????????????? ????????????????????????????????M??????????????P?????' CAT
          '???????????abcdefghijklmnopqrstuvwxyz??????????????????????????????????????????????????' CAT
          '???????????????????????????????????????????????????????????????????????????????????',

    v$assigned_to_t: [READ, oss$job_paged_literal] string (256) :=
          '???????????????????????????????? ????????????????????????????????T??????????????P?????' CAT
          '???????????abcdefghijklmnopqrstuvwxyz??????????????????????????????????????????????????' CAT
          '???????????????????????????????????????????????????????????????????????????????????',

    v$connection_names: [READ, oss$job_paged_literal] ARRAY [dft$connection_types] OF string (7) :=
          ['STORNET', 'CDCNET', 'MOCK'],
    v$io_string: [READ, oss$job_paged_literal] ARRAY [dft$monitor_io_types] OF string (8) :=
          ['IO', 'ALLOCATE'];
?? OLDTITLE ??
?? NEWTITLE := 'dfp$count_mainframes_per_esm', EJECT ??

{ PURPOSE:
{   This procedure scans the queue_interface_directory entries looking for and counting mainframes configured
{   with the element_name provided by the input parameter.

  PROCEDURE [XDCL] dfp$count_mainframes_per_esm
    (    element_name: cmt$element_name;
     VAR mainframe_count: 0 .. dfc$max_number_of_mainframes);

    VAR
      queue_directory_index: dft$queue_directory_index;

    mainframe_count := 0;

    IF dfv$p_queue_interface_directory <> NIL THEN
      FOR queue_directory_index := 1 TO UPPERBOUND (dfv$p_queue_interface_directory^) DO
        IF dfv$p_queue_interface_directory^ [queue_directory_index].element_name = element_name THEN
          mainframe_count := mainframe_count + 1;
        IFEND;
      FOREND;
    IFEND;

  PROCEND dfp$count_mainframes_per_esm;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$create_queue', EJECT ??
*copy dfh$create_queue

  PROCEDURE [XDCL] dfp$create_queue
    (    connection_parameters: dft$connection_parameters;
         destination_mainframe_name: pmt$mainframe_id;
         destination_mainframe_id: pmt$binary_mainframe_id;
         server_to_client: boolean;
     VAR queue_interface_table_p: dft$p_queue_interface_table;
     VAR status: ost$status);

    VAR
      cpu_queue_p: ^dft$cpu_queue,
      driver_queue_p: ^dft$driver_queue,
      ignore_status: ost$status,
      mandated_queue_index: dft$queue_index,
      rma: integer,
      same_definition_mainframe_count: 0 .. dfc$max_number_of_mainframes - 1;

    status.normal := TRUE;

    { Verify that the element has STORNET identification.

    IF connection_parameters.connection_type = dfc$esm_connection THEN
      dfp$verify_element_name (connection_parameters.esm_parameters.element_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    get_same_df_mainframe_count (connection_parameters.driver_name, server_to_client,
          same_definition_mainframe_count);
    IF same_definition_mainframe_count = (dfc$max_number_of_mainframes - 1) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$too_many_servers_or_clients,
            destination_mainframe_name, status);
      RETURN;
    IFEND;

    dfp$fetch_qit (connection_parameters.driver_name, queue_interface_table_p, ignore_status);

    osp$set_job_signature_lock (dfv$queue_initialization_lock);

   /lock_set/
    BEGIN
      IF server_to_client THEN
        mandated_queue_index := connection_parameters.server_queue_index;
      ELSE
        mandated_queue_index := connection_parameters.client_queue_index;
      IFEND;

      IF queue_interface_table_p = NIL THEN
        create_queue_interface_table (connection_parameters, queue_interface_table_p);
        record_queue_interface (connection_parameters.driver_name, queue_interface_table_p,
              connection_parameters);
      ELSE

        { Queue interface table already exists.

        IF (queue_interface_table_p^.queue_directory.
              driver_queue_rma_directory [mandated_queue_index].driver_queue_rma > 0) OR
              (queue_interface_table_p^.queue_directory.
              cpu_queue_pva_directory [mandated_queue_index].p_cpu_queue <> NIL) THEN
          IF server_to_client THEN
            osp$set_status_abnormal (dfc$file_server_id, dfe$id_number_in_use, 'client', status);
          ELSE
            osp$set_status_abnormal (dfc$file_server_id, dfe$id_number_in_use, 'server', status);
          IFEND;
          EXIT /lock_set/;
        IFEND;
      IFEND;

      create_driver_queue (connection_parameters, server_to_client, driver_queue_p);

      create_cpu_queue (connection_parameters, destination_mainframe_name, destination_mainframe_id,
            queue_interface_table_p^.maximum_data_bytes, cpu_queue_p);

      initialize_queue_entries (server_to_client, queue_interface_table_p, mandated_queue_index,
            connection_parameters.number_of_monitor_queue_entries,
            connection_parameters.number_of_task_queue_entries,
            cpu_queue_p^.queue_header.p_allocated_data_rma_list,
            driver_queue_p^.queue_entries, cpu_queue_p^.queue_entries);

      i#real_memory_address (driver_queue_p, rma);
      queue_interface_table_p^.queue_directory.
            driver_queue_rma_directory [mandated_queue_index].driver_queue_rma := rma;
      queue_interface_table_p^.queue_directory.
            driver_queue_pva_directory [mandated_queue_index].p_driver_queue := driver_queue_p;
      queue_interface_table_p^.queue_directory.
            cpu_queue_pva_directory [mandated_queue_index].p_cpu_queue := cpu_queue_p;
      #SPOIL (queue_interface_table_p^.queue_directory);

      IF queue_interface_table_p^.queue_directory.number_of_queues < mandated_queue_index THEN
        queue_interface_table_p^.queue_directory.number_of_queues := mandated_queue_index;
      IFEND;
    END /lock_set/;

    osp$clear_job_signature_lock (dfv$queue_initialization_lock);

  PROCEND dfp$create_queue;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$display_queues ', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display the remote queues at the local operator display.
{
{ Notes:
{   Upon entry to this procedure the 'message_written' parameter has been set to FALSE by the calling
{   procedure.  It is set to TRUE if a line is displayed by this procedure.

  PROCEDURE [XDCL] dfp$display_queues
    (VAR display_identifier {input, output} : dft$display_identifier;
     VAR message_written: boolean;
     VAR status: ost$status);

    VAR
      assignment_string: string(dfc$queue_assignment_strng_size),
      base_micros: jmt$clock_time,
      buffer_rate: real,
      current_date_time: ost$date_time,
      current_micros: jmt$clock_time,
      data_rate: real,
      destination_client_or_server: string (3),
      display_string: string (80),
      elapsed_seconds: real,
      io_type: dft$monitor_io_types,
      inn: integer,
      leader: string (4),
      length: integer,
      length_in_entries: integer,
      limit: integer,
      lock_status: ost$signature_lock_status,
      out: integer,
      p_cpu_queue_header: ^dft$cpu_queue_header,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
      queue_interface: dft$queue_directory_index,
      state_flag: string (17),
      transaction_rate: real,
      total_buffer_length_sent: integer,
      total_data_pages_sent: integer,
      total_transaction_count: integer,
      wait_flag: string (12);

    osp$test_sig_lock (dfv$queue_initialization_lock, lock_status);
    IF lock_status <> osc$sls_not_locked THEN
      status.normal := TRUE;
      dfp$display (' Queues being defined ', display_identifier, status);
      RETURN;
    IFEND;

    IF dfv$p_queue_interface_directory <> NIL THEN

    /for_all_queue_interfaces_tables/
      FOR queue_interface := 1 TO UPPERBOUND (dfv$p_queue_interface_directory^) DO
        STRINGREP (display_string, length, ' -- element name ',
              dfv$p_queue_interface_directory^ [queue_interface].element_name, ' connection ',
              v$connection_names [dfv$p_queue_interface_directory^ [queue_interface].connection_type],
              '  chan ', dfv$p_queue_interface_directory^ [queue_interface].send_channel.channel_name (1, 6));
        dfp$display (display_string (1, length), display_identifier, status);
        p_queue_interface_table := dfv$p_queue_interface_directory^ [queue_interface].p_queue_interface_table;
        IF p_queue_interface_table <> NIL THEN

          IF dfv$file_server_debug_enabled THEN
            osp$fetch_locked_variable (p_queue_interface_table^.request_buffer_directory.inn, inn);
            out := p_queue_interface_table^.request_buffer_directory.out;
            limit := p_queue_interface_table^.request_buffer_directory.limit;
            IF inn >= out THEN
              length_in_entries := (inn - out) DIV 8;
            ELSE
              length_in_entries := (limit - out + inn) DIV 8;
            IFEND;
            STRINGREP (display_string, length, ' -- Inn: ', inn: 5, '    Out: ', out: 5, '    Limit ',
                  limit: 5, '     Entries in use: ', length_in_entries: 5);
            dfp$display (display_string (1, length), display_identifier, status);
          IFEND;

          dfp$display (' ----DESTINATION MAINFRAME-----TRANSACTIONS-------BUFFER DATA------PAGE DATA--',
                display_identifier, status);
          message_written := TRUE;

        /for_all_queues/
          FOR queue_index := 1 TO UPPERBOUND (p_queue_interface_table^.queue_directory.
                cpu_queue_pva_directory) DO
            IF p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].p_cpu_queue <>
                  NIL THEN
              p_cpu_queue_header := ^p_queue_interface_table^.queue_directory.
                    cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header;
              pmp$get_compact_date_time (current_date_time, status);
              jmp$convert_date_time_to_clock (current_date_time, current_micros);
              jmp$convert_date_time_to_clock (p_cpu_queue_header^.transaction_data.transaction_start_time,
                    base_micros);
              elapsed_seconds := ($REAL (current_micros) - $REAL (base_micros)) / 1000000.0;
              osp$fetch_locked_variable (p_cpu_queue_header^.transaction_data.total_transaction_count,
                    total_transaction_count);
              osp$fetch_locked_variable (p_cpu_queue_header^.transaction_data.total_buffer_length_sent,
                    total_buffer_length_sent);
              osp$fetch_locked_variable (p_cpu_queue_header^.transaction_data.total_data_pages_sent,
                    total_data_pages_sent);
              IF p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
                    p_driver_queue^.queue_header.connection_descriptor.destination.flags.server_to_client THEN
                destination_client_or_server := ' S ';
              ELSE
                destination_client_or_server := ' C ';
              IFEND;
              leader := ' ';
              IF dfv$file_server_debug_enabled THEN
                STRINGREP (leader, length, queue_index);
              IFEND;
              STRINGREP (display_string, length, leader, p_cpu_queue_header^.destination_mainframe_name,
                    '    ', destination_client_or_server, total_transaction_count: 10, '     ',
                    total_buffer_length_sent: 14, '     ', total_data_pages_sent: 10);
              dfp$display (display_string (1, length), display_identifier, status);

              transaction_rate := $REAL (total_transaction_count) / elapsed_seconds;
              buffer_rate := $REAL (total_buffer_length_sent) / elapsed_seconds;
              data_rate := $REAL (total_data_pages_sent) / elapsed_seconds;

              wait_flag := ' ';
              IF p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
                    p_driver_queue^.queue_header.connection_descriptor.destination.flags.server_to_client THEN
                {Will be overwritten if terminated.
                IF p_cpu_queue_header^.leveler_status.leveler_state = jmc$jl_leveler_enabled THEN
                  wait_flag := ' LEVELING ON';
                ELSEIF p_cpu_queue_header^.leveler_status.leveler_state = jmc$jl_server_profile_mismatch THEN
                  wait_flag := ' PROFILE MISM';
                IFEND;
              IFEND;

              IF (((p_cpu_queue_header^.partner_status.server_state = dfc$terminated) OR
                    (p_cpu_queue_header^.partner_status.server_state = dfc$inactive) OR
                    (p_cpu_queue_header^.partner_status.server_state = dfc$awaiting_recovery)) AND
                    p_cpu_queue_header^.partner_status.verify_queue) THEN
                wait_flag := ' ACTIVATING ';
              IFEND;
              CASE p_cpu_queue_header^.partner_status.server_state OF
              = dfc$terminated=
                state_flag := '  TERMINATED ';
                IF p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
                      p_driver_queue^.queue_header.connection_descriptor.destination.flags.
                      server_to_client THEN
                  IF NOT p_cpu_queue_header^.partner_status.verify_queue THEN
                    IF p_cpu_queue_header^.partner_status.users_wait_on_terminated_server THEN
                      wait_flag := '  WAIT';
                    ELSE
                      wait_flag := '  NO WAIT';
                    IFEND;
                  IFEND;
                IFEND;
              = dfc$awaiting_recovery =
                state_flag := 'AWAITING_RECOVERY';
                IF p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
                      p_driver_queue^.queue_header.connection_descriptor.destination.flags.
                      server_to_client THEN
                  IF NOT p_cpu_queue_header^.partner_status.verify_queue THEN
                    IF NOT p_cpu_queue_header^.partner_status.server_pages_saved THEN
                      wait_flag := ' UNSAFE_DATA';
                    IFEND;
                  IFEND;
                IFEND;
              = dfc$recovering =
                state_flag := '  RECOVERING ';
              = dfc$inactive =
                state_flag := '  INACTIVE   ';
              = dfc$active =
                state_flag := '  ACTIVE     ';
              = dfc$deactivated =
                state_flag := '  DEACTIVATED';
              ELSE
                state_flag := 'UNKNOWN STATE';
              CASEND;

              STRINGREP (display_string, length, '  ', state_flag, wait_flag, transaction_rate: 9: 2,
                    '         ', buffer_rate: 10: 2, '     ', data_rate: 10: 2);
              dfp$display (display_string (1, length), display_identifier, status);
              IF dfv$file_server_debug_enabled THEN
                IF p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
                      p_driver_queue^.queue_header.connection_descriptor.destination.flags.
                      server_to_client THEN
                  { Client to server connection
                  assignment_string := p_cpu_queue_header^.queue_entry_assignment_table;
                  #translate (v$assigned_to_m, assignment_string (2, p_cpu_queue_header^.
                      number_of_monitor_queue_entries),
                      assignment_string (2, p_cpu_queue_header^.
                      number_of_monitor_queue_entries));
                  #translate (v$assigned_to_t, assignment_string (2 + p_cpu_queue_header^.
                      number_of_monitor_queue_entries, p_cpu_queue_header^.number_of_task_queue_entries),
                      assignment_string (2 + p_cpu_queue_header^.
                      number_of_monitor_queue_entries, p_cpu_queue_header^.number_of_task_queue_entries));
                  display_string := assignment_string;
                  dfp$display (display_string, display_identifier, status);
                  display_string := assignment_string (81, *);
                  IF display_string (1) <> dfc$pad_entry_char THEN
                    dfp$display (display_string, display_identifier, status);
                  IFEND;
                ELSE
                  { Server to client connection

                /display_io_rate/
                  FOR io_type := dfc$monitor_io TO dfc$monitor_allocate DO
                    total_transaction_count := p_cpu_queue_header^.monitor_io [io_type].number_of_requests;
                    current_micros := p_cpu_queue_header^.monitor_io [io_type].total_request_time;
                    transaction_rate := $REAL (total_transaction_count) / elapsed_seconds;
                    IF total_transaction_count > 0 THEN
                      data_rate := $REAL (current_micros) / $REAL (total_transaction_count);
                    ELSE
                      data_rate := $REAL (0);
                    IFEND;
                    STRINGREP (display_string, length, '        ', v$io_string [io_type], ' #',
                          total_transaction_count: 10, '   #/sec ', transaction_rate: 8: 2, '   Ave Time',
                          data_rate: 9: 2);
                    dfp$display (display_string (1, length), display_identifier, status);
                  FOREND /display_io_rate/;
                IFEND;
              IFEND;
            IFEND;
          FOREND /for_all_queues/;
        IFEND;
      FOREND /for_all_queue_interfaces_tables/;
    IFEND;

  PROCEND dfp$display_queues;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$fetch_qit  ', EJECT ??

  PROCEDURE [XDCL] dfp$fetch_qit
    (    driver_name: ost$name;
     VAR queue_interface_table_p: dft$p_queue_interface_table;
     VAR status: ost$status);

    VAR
      index: dft$queue_directory_index;

    status.normal := TRUE;
    queue_interface_table_p := NIL;

    IF dfv$p_queue_interface_directory <> NIL THEN
      FOR index := 1 TO UPPERBOUND (dfv$p_queue_interface_directory^) DO
        IF dfv$p_queue_interface_directory^ [index].driver_name = driver_name THEN
          queue_interface_table_p := dfv$p_queue_interface_directory^ [index].p_queue_interface_table;
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    osp$set_status_abnormal (dfc$file_server_id, dfe$unknown_driver, driver_name, status);

  PROCEND dfp$fetch_qit;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$find_mainframe_id', EJECT ??
*copy dfh$find_mainframe_id

  PROCEDURE [XDCL, #GATE] dfp$find_mainframe_id
    (    mainframe_id: pmt$mainframe_id;
         server_to_client: boolean;
     VAR mainframe_found: boolean;
     VAR queue_interface_table_p: ^dft$queue_interface_table;
     VAR cpu_queue_p: ^dft$cpu_queue;
     VAR queue_index: dft$queue_index;
     VAR q_interface_directory_entry_p: ^dft$q_interface_directory_entry);

    VAR
      driver_queue_p: ^dft$driver_queue,
      qit_p: ^dft$queue_interface_table,
      queue_directory_index: dft$queue_directory_index;

    mainframe_found := FALSE;
    osp$verify_system_privilege;

    IF dfv$p_queue_interface_directory = NIL THEN
      RETURN;
    IFEND;

    FOR queue_directory_index := 1 TO UPPERBOUND (dfv$p_queue_interface_directory^) DO
      qit_p := dfv$p_queue_interface_directory^ [queue_directory_index].p_queue_interface_table;
      IF qit_p <> NIL THEN
        FOR queue_index := 1 TO qit_p^.queue_directory.number_of_queues DO
          cpu_queue_p := qit_p^.queue_directory.cpu_queue_pva_directory [queue_index].p_cpu_queue;
          IF cpu_queue_p <> NIL THEN
            driver_queue_p := qit_p^.queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue;
            IF (mainframe_id = cpu_queue_p^.queue_header.destination_mainframe_name) AND
                  (server_to_client =
                  driver_queue_p^.queue_header.connection_descriptor.source.flags.server_to_client) THEN
              mainframe_found := TRUE;
              queue_interface_table_p := qit_p;
              q_interface_directory_entry_p := ^dfv$p_queue_interface_directory^ [queue_directory_index];
              RETURN;
            IFEND;
          IFEND;
        FOREND;
      IFEND;
    FOREND;

  PROCEND dfp$find_mainframe_id;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$get_mainframe_list', EJECT ??
*copy dfh$get_mainframe_list

{ NOTE:
{   This procedure returns the REAL processor model number.

  PROCEDURE [XDCL, #GATE] dfp$get_mainframe_list
    (    partners_are_servers: boolean;
     VAR partner_mainframes: dft$partner_mainframe_list;
     VAR partner_count: dft$partner_mainframe_count);

    VAR
      p_cpu_queue_header: ^dft$cpu_queue_header,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_directory_index: dft$queue_directory_index,
      queue_index: dft$queue_index;

    partner_count := 0;
    IF dfv$p_queue_interface_directory = NIL THEN
      RETURN;
    IFEND;

  /search_que_interf_directory/
    FOR queue_directory_index := 1 TO UPPERBOUND (dfv$p_queue_interface_directory^) DO
      p_queue_interface_table := dfv$p_queue_interface_directory^ [queue_directory_index].
            p_queue_interface_table;
      IF p_queue_interface_table <> NIL THEN

      /search_queues/
        FOR queue_index := 1 TO UPPERBOUND (p_queue_interface_table^.queue_directory.
              driver_queue_pva_directory) DO
          IF p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
                p_driver_queue <> NIL THEN
            IF p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
                  p_driver_queue^.queue_header.connection_descriptor.destination.flags.server_to_client =
                  partners_are_servers THEN
              p_cpu_queue_header := ^p_queue_interface_table^.queue_directory.
                    cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header;
              partner_count := partner_count + 1;
              IF (UPPERBOUND (partner_mainframes) >= partner_count) THEN
                partner_mainframes [partner_count].mainframe_id :=
                      p_cpu_queue_header^.destination_mainframe_id;
                osp$convert_to_real_model_num (p_cpu_queue_header^.destination_mainframe_id.model_number,
                      partner_mainframes [partner_count].mainframe_id.model_number);
                partner_mainframes [partner_count].partner_state :=
                      p_cpu_queue_header^.partner_status.server_state;
                partner_mainframes [partner_count].mainframe_name :=
                      p_cpu_queue_header^.destination_mainframe_name;
              IFEND;
            IFEND;
          IFEND;
        FOREND /search_queues/;
      IFEND;
    FOREND /search_que_interf_directory/;
  PROCEND dfp$get_mainframe_list;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$get_mainframe_status', EJECT ??
*copyc dfh$get_mainframe_status

  PROCEDURE [XDCL, #GATE] dfp$get_mainframe_status
    (    partner_mainframe_id: pmt$mainframe_id;
         partner_is_server: boolean;
     VAR server_state: dft$server_state;
     VAR status: ost$status);

    VAR
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index;

    dfp$find_mainframe_id (partner_mainframe_id, NOT partner_is_server, mainframe_found,
          p_queue_interface_table, p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF mainframe_found THEN
      server_state := p_cpu_queue^.queue_header.partner_status.server_state;
      status.normal := TRUE;
    ELSE
      IF partner_is_server THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, partner_mainframe_id, status);
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, partner_mainframe_id, status);
      IFEND;
    IFEND;

  PROCEND dfp$get_mainframe_status;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$get_partner_mainframes', EJECT ??
*copy dfh$get_partner_mainframes

  PROCEDURE [XDCL, #GATE] dfp$get_partner_mainframes
    (    partners_are_servers: boolean;
         p_partner_mainframes { output } : ^dft$partner_mainframe_list;
     VAR partner_count: dft$partner_mainframe_count);

    VAR
      called_by_leveler: boolean,
      p_cpu_queue_header: ^dft$cpu_queue_header,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_directory_index: dft$queue_directory_index,
      queue_index: dft$queue_index;

    partner_count := 0;
    called_by_leveler := jmp$called_by_job_leveler ();
    IF NOT called_by_leveler THEN
      osp$verify_system_privilege;
    IFEND;

    IF dfv$p_queue_interface_directory = NIL THEN
      RETURN;
    IFEND;

  /search_que_interf_directory/
    FOR queue_directory_index := 1 TO UPPERBOUND (dfv$p_queue_interface_directory^) DO
      p_queue_interface_table := dfv$p_queue_interface_directory^ [queue_directory_index].
            p_queue_interface_table;
      IF p_queue_interface_table <> NIL THEN

      /search_queues/
        FOR queue_index := 1 TO UPPERBOUND (p_queue_interface_table^.queue_directory.
              driver_queue_pva_directory) DO
          IF p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
                p_driver_queue <> NIL THEN
            IF p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
                  p_driver_queue^.queue_header.connection_descriptor.destination.flags.server_to_client =
                  partners_are_servers THEN
              p_cpu_queue_header := ^p_queue_interface_table^.queue_directory.
                    cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header;
              IF p_cpu_queue_header^.destination_mainframe_name = dfc$loopback_server_mainframe THEN
                CYCLE /search_queues/;
              IFEND;
              IF called_by_leveler THEN
                IF partners_are_servers AND
                  (p_cpu_queue_header^.partner_status.server_state = dfc$active) AND
                  (NOT p_cpu_queue_header^.partner_status.job_reconcilliation_completed) THEN
                  { Dont tell the leveler about this server till job reconcilliation completed
                   CYCLE /search_queues/;
                IFEND;
                p_cpu_queue_header^.leveler_status.cleanup_completed := FALSE;
                {This is done to prevent going to an inactive state while job leveler is still procesing.
              IFEND;
              partner_count := partner_count + 1;
              IF (p_partner_mainframes <> NIL) AND (UPPERBOUND (p_partner_mainframes^) >= partner_count) THEN
                p_partner_mainframes^ [partner_count].mainframe_id :=
                      p_cpu_queue_header^.destination_mainframe_id;
                p_partner_mainframes^ [partner_count].partner_state :=
                      p_cpu_queue_header^.partner_status.server_state;
                p_partner_mainframes^ [partner_count].mainframe_name :=
                      p_cpu_queue_header^.destination_mainframe_name;
              IFEND;
            IFEND;
          IFEND;
        FOREND /search_queues/;
      IFEND;
    FOREND /search_que_interf_directory/;
  PROCEND dfp$get_partner_mainframes;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$get_partner_queues', EJECT ??
*copyc dfh$get_partner_queues
  PROCEDURE [XDCL, #GATE] dfp$get_partner_queues
    (    p_partner_queue_list { output } : ^dft$partner_queue_list;
     VAR partner_queue_count: dft$partner_queue_count);

    VAR
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_directory_index: dft$queue_directory_index,
      queue_index: dft$queue_index;

    osp$verify_system_privilege;
    partner_queue_count := 0;

    IF dfv$p_queue_interface_directory = NIL THEN
      RETURN;
    IFEND;

  /search_que_interf_directory/
    FOR queue_directory_index := 1 TO UPPERBOUND (dfv$p_queue_interface_directory^) DO
      p_queue_interface_table := dfv$p_queue_interface_directory^ [queue_directory_index].
            p_queue_interface_table;
      IF p_queue_interface_table <> NIL THEN

      /search_queues/
        FOR queue_index := 1 TO UPPERBOUND (p_queue_interface_table^.queue_directory.
              driver_queue_pva_directory) DO
          IF p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
                p_driver_queue <> NIL THEN
            partner_queue_count := partner_queue_count + 1;
            IF (p_partner_queue_list <> NIL) AND
               (UPPERBOUND (p_partner_queue_list^) >= partner_queue_count) THEN
              p_partner_queue_list^ [partner_queue_count].p_driver_queue := p_queue_interface_table^
                    .queue_directory.driver_queue_pva_directory [queue_index].p_driver_queue;
              p_partner_queue_list^ [partner_queue_count].p_cpu_queue := p_queue_interface_table^
                    .queue_directory.cpu_queue_pva_directory [queue_index].p_cpu_queue;
            IFEND;
          IFEND;
        FOREND /search_queues/;
      IFEND;
    FOREND /search_que_interf_directory/;
  PROCEND dfp$get_partner_queues;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$prepare_for_idle_system', EJECT ??
{
{   The purpose of this procedure is to gracefully bring the file server
{ down in preparation for a terminate_system.
{ An attempt is made to deactivate any active connections, and failing that,
{ they are forced to awaiting recovery.
{ Any connection that is 'activating' is forced back to its previous state.
{ If a client-to-server connection was awaiting_recovery but pages were
{ not able to be saved then the connection is terminated, since the pages
{ would not be available following the continuation deadstart.

  PROCEDURE [XDCL, #GATE] dfp$prepare_for_idle_system
    (    idle_code: syt$180_idle_code;
     VAR status: ost$status);

    CONST
      one_second_in_microseconds = 1000000,
      one_second_in_milliseconds = 1000;

    VAR
      active_partner_count: dft$partner_queue_count,
      display_string: string (80),
      display_length: integer,
      endtime: integer,
      index: dft$partner_queue_count,
      p_partner_queues: ^dft$partner_queue_list,
      partner_queue_count: dft$partner_queue_count,
      timeout_partner: boolean;

    status.normal := TRUE;
    osp$verify_system_privilege;

    PUSH p_partner_queues: [1 .. dfc$maximum_partner_queues];
    dfp$get_partner_queues (p_partner_queues, partner_queue_count);

    IF partner_queue_count > 0 THEN
      CASE idle_code OF
      = syc$ic_idle_command, syc$ic_system_terminated =
        timeout_partner := FALSE;
        endtime := #FREE_RUNNING_CLOCK (0) + (80 * one_second_in_microseconds);
      ELSE
{       = (syc$ic_hardware_idle,) syc$ic_long_power =
{         OR System idling due to fatal software error.
{         This procedure is not called for idle_code of syc$ic_hardware_idle.
        timeout_partner := TRUE;
        endtime := #FREE_RUNNING_CLOCK (0) + (40 * one_second_in_microseconds);
      CASEND;

    /await_inactive/
      REPEAT
        active_partner_count := 0;

      /deactivate_partners/
        FOR index := 1 TO partner_queue_count DO
          #SPOIL (p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status);
          CASE p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.server_state OF
          = dfc$active =
            active_partner_count := active_partner_count + 1;
            IF timeout_partner THEN
{             Drive queue to state of dfc$terminated or dfc$awaiting_recovery.
              p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
            ELSE
{             Same as DEACTIVATE_CLIENT or DEACTIVATE_SERVER command processing.
{             Drive queue to state of dfc$inactive.
              p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.send_deactivate_partner :=
                    TRUE;
            IFEND;

          = dfc$deactivated =
{           The queue is in a transition state on its way to dfc$inactive.
{           Wait for this queue to reach state of dfc$inactive.
            active_partner_count := active_partner_count + 1;

          = dfc$recovering =
{           The queue is in a transition state on its way to dfc$active.
{           Wait for this queue to reach state of dfc$active.
            active_partner_count := active_partner_count + 1;

          = dfc$terminated =
            { Don't wait for the server to become active.
            IF p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.verify_queue THEN
              p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.terminate_partner := TRUE;
              p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
              active_partner_count := active_partner_count + 1;
            IFEND;

          = dfc$inactive =
            IF p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.verify_queue THEN
{             The queue is in a transition state on its way to dfc$active.
{             Drive queue to state of dfc$terminated or dfc$awaiting_recovery.
{             It's better to not let the server go active, so that IO will
{             not be performed on any files.
              p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
              p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
              active_partner_count := active_partner_count + 1;
            IFEND;

          = dfc$awaiting_recovery =
            IF p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.verify_queue THEN
              p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
              p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
              active_partner_count := active_partner_count + 1;
            ELSEIF (NOT p_partner_queues^ [index].p_driver_queue^.queue_header.connection_descriptor.
                  source.flags.server_to_client) AND (NOT p_partner_queues^ [index].p_cpu_queue^.
                  queue_header.partner_status.server_pages_saved) AND
                  (idle_code = syc$ic_system_terminated) THEN
               dfp$free_image_file (p_partner_queues^ [index].p_cpu_queue^.queue_header.
                     destination_mainframe_id, status);
               p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.server_state :=
                     dfc$terminated;
               #SPOIL (p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status);
               dfp$change_family_server_state (dfc$terminated, p_partner_queues^ [index].
                    p_cpu_queue^.queue_header.destination_mainframe_id);
               STRINGREP (display_string, display_length, ' Terminating server ',
                    p_partner_queues^ [index].p_cpu_queue^.queue_header.destination_mainframe_name,
                    ' due to unsaved pages');
               clp$put_job_command_response (display_string (1, display_length), status);
               log_display ($pmt$ascii_logset [pmc$system_log], display_string (1, display_length));
            IFEND;

          ELSE { dfc$deleted }
            ;
          CASEND;
        FOREND /deactivate_partners/;
        IF active_partner_count > 0 THEN
          pmp$wait (10 * one_second_in_milliseconds, 10 * one_second_in_milliseconds);
        IFEND;
      UNTIL (#FREE_RUNNING_CLOCK (0) > endtime) OR (active_partner_count = 0);

      IF active_partner_count > 0 THEN
{       This situation is most likely to occur when deactivating partners
{       as a result of the IDLE_SYSTEM command.
        STRINGREP (display_string, display_length, active_partner_count,
          ' file server partner(s) not Inactive, force timeout.');
        clp$put_job_command_response (display_string (1, display_length), status);
        log_display ($pmt$ascii_logset [pmc$system_log], display_string (1, display_length));
        endtime := #FREE_RUNNING_CLOCK (0) + (20 * one_second_in_microseconds);

      /await_timeout/
        REPEAT
          active_partner_count := 0;

        /timeout_partners/
          FOR index := 1 TO partner_queue_count DO
            #SPOIL (p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status);
            CASE p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.server_state OF
            = dfc$active =
{             Not likely to be in this state, just covering all bases.
{             Drive queue to state of dfc$terminated or dfc$awaiting_recovery.
              STRINGREP (display_string, display_length, ' Active partner ',
                    p_partner_queues^ [index].p_cpu_queue^.queue_header.destination_mainframe_name,
                    ' forced to awaiting recovery ');
              clp$put_job_command_response (display_string (1, display_length), status);
              log_display ($pmt$ascii_logset [pmc$system_log], display_string (1, display_length));
              p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
              active_partner_count := active_partner_count + 1;

            = dfc$deactivated =
{             Most likely to be in this state with deactivation taking too long.
{             The queue is in a transition state on its way to dfc$inactive.
{             Drive queue to state of dfc$terminated or dfc$awaiting_recovery.
              STRINGREP (display_string, display_length, ' Deactivating partner ',
                    p_partner_queues^ [index].p_cpu_queue^.queue_header.destination_mainframe_name,
                    ' forced to awaiting recovery ');
              clp$put_job_command_response (display_string (1, display_length), status);
              log_display ($pmt$ascii_logset [pmc$system_log], display_string (1, display_length));
              p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
              active_partner_count := active_partner_count + 1;

            = dfc$recovering =
{             The queue is in a transition state on its way to dfc$active.
{             Drive queue to state of dfc$terminated or dfc$awaiting_recovery.
              STRINGREP (display_string, display_length, ' Recovering partner ',
                    p_partner_queues^ [index].p_cpu_queue^.queue_header.destination_mainframe_name,
                    ' forced to awaiting recovery ');
              clp$put_job_command_response (display_string (1, display_length), status);
              log_display ($pmt$ascii_logset [pmc$system_log], display_string (1, display_length));
              p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
              active_partner_count := active_partner_count + 1;

            = dfc$inactive, dfc$terminated, dfc$awaiting_recovery =
              IF p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.verify_queue THEN
{               The queue is in a transition state on its way to dfc$active.
{               Drive queue to state of dfc$terminated or dfc$awaiting_recovery.
                STRINGREP (display_string, display_length, ' Activating partner ',
                      p_partner_queues^ [index].p_cpu_queue^.queue_header.destination_mainframe_name,
                      ' forced to awaiting recovery ');
                clp$put_job_command_response (display_string (1, display_length), status);
                log_display ($pmt$ascii_logset [pmc$system_log], display_string (1, display_length));
                p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
                p_partner_queues^ [index].p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
                active_partner_count := active_partner_count + 1;
              IFEND;
            ELSE { dfc$deleted }
              ;
            CASEND;
          FOREND /timeout_partners/;
          IF active_partner_count > 0 THEN
            pmp$wait (5 * one_second_in_milliseconds, 5 * one_second_in_milliseconds);
          IFEND;
        UNTIL (#FREE_RUNNING_CLOCK (0) > endtime) OR (active_partner_count = 0);

        IF active_partner_count > 0 THEN
          STRINGREP (display_string, display_length, active_partner_count,
              ' file server partner(s) not Inactive, continute termination');
          clp$put_job_command_response (display_string (1, display_length), status);
          log_display ($pmt$ascii_logset [pmc$system_log], display_string (1, display_length));
        ELSE
          clp$put_job_command_response ('  All file server partners forced Inactive or Awaiting Recovery.',
                status);
          log_display ($pmt$ascii_logset [pmc$system_log],
                '  All file server partners forced Inactive or Awaiting Recovery.');
        IFEND;
      ELSE
        log_display ($pmt$ascii_logset [pmc$system_log],
              '  All file server partners Inactive or Awaiting Recovery.');
        clp$put_job_command_response ('  All file server partners Inactive or Awaiting Recovery.', status);
      IFEND;
    IFEND;

  PROCEND dfp$prepare_for_idle_system;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$store_leveler_status', EJECT ??
*copy dfh$store_leveler_status

  PROCEDURE [XDCL, #GATE] dfp$store_leveler_status
    (    server_mainframe_id: pmt$binary_mainframe_id;
         leveler_status: jmt$jl_job_leveler_status;
     VAR status: ost$status);

    VAR
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_q_interface_table: ^dft$queue_interface_table,
      queue_directory_index: dft$queue_directory_index,
      queue_index: dft$queue_index,
      server_name: pmt$mainframe_id;

    status.normal := TRUE;
    jmp$verify_job_leveler;

    pmp$convert_binary_mainframe_id (server_mainframe_id, server_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$find_mainframe_id (server_name, {host_is_server_to_client=} FALSE, mainframe_found,
          p_q_interface_table, p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF mainframe_found THEN
      p_cpu_queue^.queue_header.leveler_status := leveler_status;
    ELSE
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, server_name, status);
    IFEND;

  PROCEND dfp$store_leveler_status;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$$client_state', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$$client_state
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      deck_adt: [STATIC, READ, cls$adt] array [1 .. 1] of clt$argument_descriptor :=
            [[[clc$required], [NIL, clc$name_value, 1, osc$max_name_size]]];

    VAR
      avt: array [1 .. 1] of clt$value,
      host_is_server_to_client: boolean,
      mainframe_name: pmt$mainframe_id;

    clp$scan_argument_list (function_name, argument_list, ^deck_adt, ^avt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    host_is_server_to_client := TRUE;

    mainframe_name := avt [1].name.value;

    get_partner_state (mainframe_name, host_is_server_to_client, value);

  PROCEND dfp$$client_state;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$$server_state', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$$server_state
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      deck_adt: [STATIC, READ, cls$adt] array [1 .. 1] of clt$argument_descriptor :=
            [[[clc$required], [NIL, clc$name_value, 1, osc$max_name_size]]];

    VAR
      avt: array [1 .. 1] of clt$value,
      host_is_server_to_client: boolean,
      mainframe_name: pmt$mainframe_id;

    clp$scan_argument_list (function_name, argument_list, ^deck_adt, ^avt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    host_is_server_to_client := FALSE;

    mainframe_name := avt [1].name.value;

    get_partner_state (mainframe_name, host_is_server_to_client, value);

  PROCEND dfp$$server_state;
?? OLDTITLE ??
?? NEWTITLE := 'build_qe_p_data_rma_list', EJECT ??

  PROCEDURE [INLINE] build_qe_p_data_rma_list
    (    pva: ^cell;
         number_of_rma_list_entries: 1 .. dfc$max_rma_list_entries;
     VAR p_data_rma_list: dft$p_data_rma_list);

    VAR
      p_sequence_record: ^RECORD
        sequence: SEQ (REP 7fffffff(16) OF CELL),
      RECEND,
      p_sequence: ^SEQ (REP 7fffffff(16) OF CELL);

    p_sequence_record := pva;
    p_sequence := ^p_sequence_record^.sequence;
    RESET p_sequence;
    NEXT p_data_rma_list :[1 .. number_of_rma_list_entries] IN p_sequence;

  PROCEND build_qe_p_data_rma_list;
?? OLDTITLE ??
?? NEWTITLE := 'create_cpu_queue ', EJECT ??

  PROCEDURE create_cpu_queue
    (    connection_parameters: dft$connection_parameters;
         destination_mainframe_name: pmt$mainframe_id;
         destination_mainframe_id: pmt$binary_mainframe_id;
         maximum_data_bytes: dfc$min_data_record_bytes .. dfc$max_data_record_bytes;
     VAR cpu_queue_p: ^dft$cpu_queue);

    VAR
      extra_character: 3 .. dfc$queue_assignment_strng_size,
      local_status: ost$status,
      rma_list_index: 1 .. dfc$max_rma_list_entries * dfc$max_queue_entries;

    { Add 1 to the number of queue entries to account for the Poll Task.

    ALLOCATE cpu_queue_p: [1 .. (connection_parameters.number_of_monitor_queue_entries +
          connection_parameters.number_of_task_queue_entries + 1)] IN dfv$server_wired_heap^;
    IF cpu_queue_p = NIL THEN
      osp$system_error (' NIL cpu_queue_p', NIL);
    IFEND;

    { Allocated space for all queue entry's data RMA lists (except for POLL task entry).

    ALLOCATE cpu_queue_p^.queue_header.p_allocated_data_rma_list:[1 ..
          ((maximum_data_bytes DIV osv$page_size) * (connection_parameters.number_of_monitor_queue_entries +
          connection_parameters.number_of_task_queue_entries))] IN dfv$server_wired_heap^;
    IF cpu_queue_p^.queue_header.p_allocated_data_rma_list = NIL THEN
      osp$system_error (' NIL allocated_data_rma_list_p', NIL);
    IFEND;

    FOR rma_list_index := LOWERBOUND (cpu_queue_p^.queue_header.p_allocated_data_rma_list^.rma_list) TO
          UPPERBOUND (cpu_queue_p^.queue_header.p_allocated_data_rma_list^.rma_list) DO
      cpu_queue_p^.queue_header.p_allocated_data_rma_list^.rma_list [rma_list_index].fill := 0;
      cpu_queue_p^.queue_header.p_allocated_data_rma_list^.rma_list [rma_list_index].length := 0;
      cpu_queue_p^.queue_header.p_allocated_data_rma_list^.rma_list [rma_list_index].rma := 0;
    FOREND;

    { Initialize queue header.

    cpu_queue_p^.queue_header.number_of_monitor_queue_entries :=
          connection_parameters.number_of_monitor_queue_entries;
    cpu_queue_p^.queue_header.number_of_task_queue_entries :=
          connection_parameters.number_of_task_queue_entries;

    { This assumes free is the blank.

    cpu_queue_p^.queue_header.queue_entry_assignment_table := '';

    FOR extra_character := (connection_parameters.number_of_monitor_queue_entries +
          connection_parameters.number_of_task_queue_entries + 2) TO
          #SIZE (cpu_queue_p^.queue_header.queue_entry_assignment_table) DO
      cpu_queue_p^.queue_header.queue_entry_assignment_table (extra_character) := dfc$pad_entry_char;
    FOREND;

    { Assign 1st entry to the Poll Task.

    cpu_queue_p^.queue_header.queue_entry_assignment_table (1, 1) := dfc$assigned_entry_char;

    cpu_queue_p^.queue_header.connection_type := connection_parameters.connection_type;
    cpu_queue_p^.queue_header.timeout_interval :=
          connection_parameters.client_to_server.timeout_interval * 1000000;
    cpu_queue_p^.queue_header.maximum_request_timeout_count :=
          connection_parameters.client_to_server.maximum_request_timeout_count;
    cpu_queue_p^.queue_header.maximum_retransmission_count :=
          connection_parameters.client_to_server.maximum_retransmission_count;
    cpu_queue_p^.queue_header.destination_mainframe_id := destination_mainframe_id;
    cpu_queue_p^.queue_header.destination_mainframe_name := destination_mainframe_name;
    cpu_queue_p^.queue_header.leveler_status.leveler_state := jmc$jl_leveler_disabled;
    cpu_queue_p^.queue_header.leveler_status.cleanup_completed := TRUE;
    cpu_queue_p^.queue_header.server_lifetime := 0;
    cpu_queue_p^.queue_header.server_birthdate := 0;
    cpu_queue_p^.queue_header.partner_status.terminate_partner := FALSE;
    cpu_queue_p^.queue_header.partner_status.timeout_partner := FALSE;
    cpu_queue_p^.queue_header.partner_status.users_wait_on_terminated_server :=
          connection_parameters.client_to_server.users_wait_on_terminated;
    cpu_queue_p^.queue_header.partner_status.deactivate_complete := FALSE;
    cpu_queue_p^.queue_header.partner_status.server_state := dfc$terminated;
    cpu_queue_p^.queue_header.partner_status.verify_queue := FALSE;
    pmp$get_compact_date_time (cpu_queue_p^.queue_header.transaction_data.transaction_start_time,
          local_status);
    cpu_queue_p^.queue_header.transaction_data.total_transaction_count := 0;
    cpu_queue_p^.queue_header.transaction_data.total_buffer_length_sent := 0;
    cpu_queue_p^.queue_header.transaction_data.total_data_pages_sent := 0;
    cpu_queue_p^.queue_header.transaction_data.total_buffer_length_received := 0;
    cpu_queue_p^.queue_header.transaction_data.total_data_pages_received := 0;
    cpu_queue_p^.queue_header.p_host_application_info := NIL;
    cpu_queue_p^.queue_header.p_remote_application_info := NIL;
    cpu_queue_p^.queue_header.p_application_rpc_list := NIL;

  PROCEND create_cpu_queue;
?? OLDTITLE ??
?? NEWTITLE := 'create_driver_queue ', EJECT ??

  PROCEDURE create_driver_queue
    (    connection_parameters: dft$connection_parameters;
         server_to_client: boolean;
     VAR driver_queue_p: ^dft$driver_queue);

    { Add 1 to the number of queue entries to account for the Poll Task.

    ALLOCATE driver_queue_p: [1 .. (connection_parameters.number_of_monitor_queue_entries +
          connection_parameters.number_of_task_queue_entries + 1)] IN dfv$server_wired_heap^;
    IF driver_queue_p = NIL THEN
      osp$system_error ('NIL driver_queue_p', NIL);
    IFEND;
    pmp$zero_out_table (driver_queue_p, #SIZE (driver_queue_p^));

    { Initialize queue header

    driver_queue_p^.queue_header.flags.idle := TRUE;

    { Add 1 to total number of queue entries to account for the Poll Task.

    driver_queue_p^.queue_header.number_of_queue_entries :=
          connection_parameters.number_of_monitor_queue_entries +
          connection_parameters.number_of_task_queue_entries + 1;
    driver_queue_p^.queue_header.connection_descriptor.source.flags.server_to_client := server_to_client;
    IF server_to_client THEN
      driver_queue_p^.queue_header.connection_descriptor.source.queue_index :=
            connection_parameters.server_queue_index;
      driver_queue_p^.queue_header.connection_descriptor.destination.queue_index :=
            connection_parameters.client_queue_index;
    ELSE {client to server queue}
      driver_queue_p^.queue_header.connection_descriptor.source.queue_index :=
            connection_parameters.client_queue_index;
      driver_queue_p^.queue_header.connection_descriptor.destination.queue_index :=
            connection_parameters.server_queue_index;
    IFEND;

    driver_queue_p^.queue_header.connection_descriptor.destination.flags.server_to_client :=
          NOT server_to_client;
    IF connection_parameters.connection_type = dfc$esm_connection THEN
      driver_queue_p^.queue_header.connection_descriptor.source.id_number :=
            connection_parameters.esm_parameters.source_id_number;
      driver_queue_p^.queue_header.connection_descriptor.destination.id_number :=
            connection_parameters.esm_parameters.destination_id_number;
    IFEND;

  PROCEND create_driver_queue;
?? OLDTITLE ??
?? NEWTITLE := 'create_queue_interface_table ', EJECT ??

  PROCEDURE create_queue_interface_table
    (    connection_parameters: dft$connection_parameters;
     VAR queue_interface_table_p: dft$p_queue_interface_table);

    VAR
      number_request_buffer_entries: 1 .. dfc$max_request_buffer_entries,
      queue: dft$queue_index,
      request_buffer_p: ^dft$request_buffer,
      rma: integer;

    ALLOCATE queue_interface_table_p IN dfv$server_wired_heap^;
    IF queue_interface_table_p = NIL THEN
      osp$system_error ('NIL queue_interface_table_p ', NIL);
    IFEND;
    pmp$zero_out_table (queue_interface_table_p, #SIZE (queue_interface_table_p^));

    pmp$zero_out_table (^queue_interface_table_p^.request_buffer_directory,
          #SIZE (queue_interface_table_p^.request_buffer_directory));
    ALLOCATE request_buffer_p IN dfv$server_wired_heap^;
    IF request_buffer_p = NIL THEN
      osp$system_error (' NIL request_buffer_p', NIL);
    IFEND;
    pmp$zero_out_table (request_buffer_p, #SIZE (request_buffer_p^));

    queue_interface_table_p^.request_buffer_directory.limit := #SIZE (request_buffer_p^);
    queue_interface_table_p^.request_buffer_directory.inn := 0;
    queue_interface_table_p^.request_buffer_directory.out := 0;
    i#real_memory_address (request_buffer_p, rma);
    queue_interface_table_p^.request_buffer_directory.request_buffer_rma := rma;
    queue_interface_table_p^.request_buffer_directory.p_request_buffer := request_buffer_p;

    IF connection_parameters.connection_type = dfc$esm_connection THEN
      queue_interface_table_p^.esm_base_addresses := connection_parameters.esm_parameters.esm_base_addresses;
      queue_interface_table_p^.queue_directory.source_id_number :=
            connection_parameters.esm_parameters.source_id_number;
    IFEND;

    queue_interface_table_p^.maximum_data_bytes :=
          connection_parameters.client_to_server.maximum_data_bytes;

    { Set up empty queue directory.

    queue_interface_table_p^.queue_directory.number_of_queues := 0;

    FOR queue := 1 TO UPPERBOUND (queue_interface_table_p^.queue_directory.driver_queue_pva_directory) DO
      queue_interface_table_p^.queue_directory.driver_queue_pva_directory [queue].p_driver_queue := NIL;
      queue_interface_table_p^.queue_directory.cpu_queue_pva_directory [queue].p_cpu_queue := NIL;
      queue_interface_table_p^.queue_directory.driver_queue_rma_directory [queue].driver_queue_rma := 0;
    FOREND;

  PROCEND create_queue_interface_table;
?? OLDTITLE ??
?? NEWTITLE := 'get_partner_state', EJECT ??

  PROCEDURE get_partner_state
    (    mainframe_name: pmt$mainframe_id;
         host_is_server_to_client: boolean;
     VAR value: clt$value);

    VAR
      ignore_status: ost$status,
      mainframe_found: boolean,
      mainframe_id: pmt$binary_mainframe_id,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_exists: boolean,
      queue_index: dft$queue_index,
      server_birthdate: integer,
      server_lifetime: dft$lifetime,
      server_state: dft$server_state;

    dfp$find_mainframe_id (mainframe_name, host_is_server_to_client, mainframe_found, p_queue_interface_table,
          p_cpu_queue, queue_index, p_q_interface_directory_entry);

    value.descriptor := 'STRING';
    value.kind := clc$string_value;
    queue_exists := mainframe_found;
    IF mainframe_found THEN
      server_state := p_cpu_queue^.queue_header.partner_status.server_state;
    ELSE { No queues exist
      pmp$convert_mainframe_to_binary (mainframe_name, mainframe_id, ignore_status);
      IF host_is_server_to_client THEN
        dfp$get_client_mf_file_info (mainframe_id, mainframe_found, server_state, server_lifetime,
              server_birthdate);
      ELSE
        dfp$get_highest_sf_lifetime (mainframe_id, mainframe_found, server_state, server_lifetime,
              server_birthdate);
      IFEND;
    IFEND;

    IF NOT mainframe_found OR (server_state = dfc$deleted) THEN
      { Server state of deleted is set to deleted for test compatability.
      value.str.size := 7;
      value.str.value := 'UNKNOWN';
    ELSE
      CASE server_state OF
      = dfc$active =
        value.str.size := 6;
        value.str.value := 'ACTIVE';
      = dfc$deactivated =
        value.str.size := 11;
        value.str.value := 'DEACTIVATED';
      = dfc$inactive =
        value.str.size := 8;
        value.str.value := 'INACTIVE';
      = dfc$terminated =
        IF queue_exists AND p_cpu_queue^.queue_header.partner_status.verify_queue THEN
          value.str.size := 10;
          value.str.value := 'ACTIVATING';
        ELSE
          value.str.size := 10;
          value.str.value := 'TERMINATED';
        IFEND;
      = dfc$recovering =
        value.str.size := 10;
        value.str.value := 'RECOVERING';
      = dfc$awaiting_recovery =
        IF queue_exists AND p_cpu_queue^.queue_header.partner_status.verify_queue THEN
          value.str.size := 10;
          value.str.value := 'ACTIVATING';
        ELSE
          value.str.size := 17;
          value.str.value := 'AWAITING_RECOVERY';
        IFEND;
      ELSE
        value.str.size := 7;
        value.str.value := 'UNKNOWN';
      CASEND;
    IFEND;

  PROCEND get_partner_state;
?? OLDTITLE ??
?? NEWTITLE := 'get_same_df_mainframe_count', EJECT ??

{ PURPOSE:
{   This procedure scans the queue_interface_table entries counting mainframes configured with the same
{   element_name and the same source mainframe as the two input parameters.

  PROCEDURE get_same_df_mainframe_count
    (    element_name: cmt$element_name;
         server_to_client: boolean;
     VAR same_destination_mainframes: 0 .. dfc$max_number_of_mainframes - 1);

    VAR
      driver_queue_p: ^dft$driver_queue,
      index: dft$queue_index,
      q_interface_directory_entry_p: ^dft$q_interface_directory_entry,
      qit_p: ^dft$queue_interface_table,
      queue_directory_index: dft$queue_directory_index;

    same_destination_mainframes := 0;

    IF dfv$p_queue_interface_directory = NIL THEN
      RETURN;
    IFEND;

    FOR queue_directory_index := 1 TO UPPERBOUND (dfv$p_queue_interface_directory^) DO
      IF dfv$p_queue_interface_directory^ [queue_directory_index].driver_name = element_name THEN
        qit_p := dfv$p_queue_interface_directory^ [queue_directory_index].p_queue_interface_table;
        IF qit_p <> NIL THEN
          FOR index := 1 TO qit_p^.queue_directory.number_of_queues DO
            IF qit_p^.queue_directory.cpu_queue_pva_directory [index].p_cpu_queue <> NIL THEN
              driver_queue_p := qit_p^.queue_directory.driver_queue_pva_directory [index].p_driver_queue;
              IF server_to_client =
                    driver_queue_p^.queue_header.connection_descriptor.source.flags.server_to_client THEN
                same_destination_mainframes := same_destination_mainframes + 1;
              IFEND;
            IFEND;
          FOREND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND get_same_df_mainframe_count;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_monitor_cpu_q_entry ', EJECT ??

  PROCEDURE initialize_monitor_cpu_q_entry
    (    server_to_client: boolean;
         p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
     VAR cpu_queue_entry: dft$cpu_queue_entry);

    CONST
      null_ajl_ordinal = jmc$max_ajl_ord;

    VAR
      directory_index: dft$queue_directory_index;

    IF server_to_client THEN
      { Set up the io id so that monitor only need full in io function.
      cpu_queue_entry.io_id.specified := TRUE;
      cpu_queue_entry.io_id.io_function := ioc$read_for_server;
      dfp$get_queue_directory_index (p_queue_interface_table, directory_index);
      cpu_queue_entry.io_id.queue_entry_location.directory_index := directory_index;
      cpu_queue_entry.io_id.queue_entry_location.queue_index := queue_index;
      cpu_queue_entry.io_id.queue_entry_location.queue_entry_index := queue_entry_index;
      { Initialize all fields to null values.
      cpu_queue_entry.ajlo := null_ajl_ordinal;
      cpu_queue_entry.io_type := ioc$read_for_server;
      cpu_queue_entry.sfid := dmv$null_sfid;
      ALLOCATE cpu_queue_entry.p_server_iocb IN dfv$server_wired_heap^;
      IF cpu_queue_entry.p_server_iocb = NIL THEN
        osp$system_error (' p_server_iocb = NIL', NIL);
      IFEND;
      pmp$zero_out_table (cpu_queue_entry.p_server_iocb, #SIZE (cpu_queue_entry.p_server_iocb^));
      cpu_queue_entry.p_server_iocb^.server_state := mmc$ss_waiting;
      cpu_queue_entry.p_server_iocb^.sfid := dmv$null_sfid;
      cpu_queue_entry.p_server_iocb^.offset := 0;
      cpu_queue_entry.p_server_iocb^.length := 0;
      cpu_queue_entry.p_server_iocb^.eoi := 0;
      cpu_queue_entry.p_server_iocb^.sub_reqcode := mmc$iorc_await_io_completion;
      cpu_queue_entry.p_server_iocb^.condition := dfc$null_server_condition;
      cpu_queue_entry.p_server_iocb^.io_already_active := FALSE;
      cpu_queue_entry.p_server_iocb^.active_io_count := 0;
      cpu_queue_entry.p_server_iocb^.reissue_request := FALSE;
    ELSE { Client mainframe
      cpu_queue_entry.io_id.specified := FALSE;
      cpu_queue_entry.io_id.io_function := ioc$no_io;
      cpu_queue_entry.ajlo := null_ajl_ordinal;
      cpu_queue_entry.io_type := ioc$keypoint_io;
      cpu_queue_entry.sfid := dmv$null_sfid;
      cpu_queue_entry.p_server_iocb := NIL;
    IFEND;

  PROCEND initialize_monitor_cpu_q_entry;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_queue_entries ', EJECT ??

  PROCEDURE initialize_queue_entries
    (    server_to_client: boolean;
         p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         number_of_monitor_queue_entries: 0 .. dfc$max_queue_entries;
         number_of_task_queue_entries: dft$queue_entry_index;
         p_allocated_data_rma_list: dft$p_allocated_data_rma_list;
     VAR driver_queue_entries: dft$driver_queue_entries;
     VAR cpu_queue_entries: dft$cpu_queue_entries);

    VAR
      number_of_rma_list_entries: 1 .. dfc$max_rma_list_entries,
      p_allocated_command_buffer: dft$p_allocated_command_buffer,
      p_allocated_rpc_data_area: ^dft$allocated_rpc_data_area,
      p_allocated_monitor_buffer: dft$p_allocated_monitor_buffer,
      pva: ^cell,
      queue_entry_index: dft$queue_entry_index,
      rma: integer;

    pmp$zero_out_table (^driver_queue_entries, #SIZE (driver_queue_entries));

    pmp$zero_out_table (^cpu_queue_entries, #SIZE (cpu_queue_entries));

    number_of_rma_list_entries := p_queue_interface_table^.maximum_data_bytes DIV osv$page_size;

  /initialize_each_entry/
    FOR queue_entry_index := 1 TO UPPERBOUND (driver_queue_entries) DO
      IF queue_entry_index = dfc$poll_queue_index THEN
        cpu_queue_entries [queue_entry_index].processor_type := dfc$task_services;
        driver_queue_entries [queue_entry_index].flags.active_entry := TRUE;
      ELSEIF queue_entry_index <= number_of_monitor_queue_entries + 1 THEN
        cpu_queue_entries [queue_entry_index].processor_type := dfc$monitor;
      ELSE
        cpu_queue_entries [queue_entry_index].processor_type := dfc$task_services;
      IFEND;
      cpu_queue_entries [queue_entry_index].transaction_count := 0;
      cpu_queue_entries [queue_entry_index].transaction_state := dfc$queue_entry_available;
      cpu_queue_entries [queue_entry_index].request_timeout_count := 0;
      cpu_queue_entries [queue_entry_index].retransmission_count := 0;

      { Initialize send buffer
      IF (cpu_queue_entries [queue_entry_index].processor_type = dfc$monitor) THEN
        IF server_to_client THEN
          ALLOCATE p_allocated_monitor_buffer: [[REP 1 OF dft$buffer_header, REP 1 OF syt$monitor_status,
                REP 1 OF dft$page_io_response]] IN dfv$server_wired_heap^;
        ELSE {Client side.
          ALLOCATE p_allocated_monitor_buffer: [[REP 1 OF dft$buffer_header, REP 1 OF syt$monitor_status,
                REP 1 OF dft$page_io_request]] IN dfv$server_wired_heap^;
        IFEND;
        IF (p_allocated_monitor_buffer = NIL) THEN
          osp$system_error (' NIL p_allocated_monitor_buffer', NIL);
        ELSE
          cpu_queue_entries [queue_entry_index].p_send_buffer := ^p_allocated_monitor_buffer^.buffer;
        IFEND;
      ELSE {Task Services task.
        ALLOCATE p_allocated_command_buffer: [[REP dfc$command_buffer_size OF cell]] IN
              dfv$server_wired_heap^;
        IF (p_allocated_command_buffer = NIL) THEN
          osp$system_error (' NIL p_allocated_command_buffer', NIL);
        ELSE
          cpu_queue_entries [queue_entry_index].p_send_buffer := ^p_allocated_command_buffer^.buffer;
        IFEND;
      IFEND;
      RESET cpu_queue_entries [queue_entry_index].p_send_buffer;

      { Touch the page to assure it is created in real memory.
      IF (cpu_queue_entries [queue_entry_index].processor_type = dfc$monitor) THEN
        pmp$zero_out_table (p_allocated_monitor_buffer, #SIZE (p_allocated_monitor_buffer^));
      ELSE {Task Services task.
        pmp$zero_out_table (p_allocated_command_buffer, #SIZE (p_allocated_command_buffer^));
      IFEND;

      i#real_memory_address (cpu_queue_entries [queue_entry_index].p_send_buffer, rma);
      driver_queue_entries [queue_entry_index].send_buffer_descriptor.address := rma;
      driver_queue_entries [queue_entry_index].send_buffer_descriptor.indirect_address := FALSE;
      driver_queue_entries [queue_entry_index].send_buffer_descriptor.actual_length := 0;

      { Initialize receive buffer
      { Note actual length initialized differently than send buffer.
      IF (cpu_queue_entries [queue_entry_index].processor_type = dfc$monitor) THEN
        IF server_to_client THEN
          ALLOCATE p_allocated_monitor_buffer: [[REP 1 OF dft$buffer_header, REP 1 OF syt$monitor_status,
                REP 1 OF dft$page_io_request]] IN dfv$server_wired_heap^;
        ELSE {Client side.
          ALLOCATE p_allocated_monitor_buffer: [[REP 1 OF dft$buffer_header, REP 1 OF syt$monitor_status,
                REP 1 OF dft$page_io_response]] IN dfv$server_wired_heap^;
        IFEND;
        IF (p_allocated_monitor_buffer = NIL) THEN
          osp$system_error (' NIL p_allocated_monitor_buffer', NIL);
        ELSE
          cpu_queue_entries [queue_entry_index].p_receive_buffer := ^p_allocated_monitor_buffer^.buffer;
        IFEND;
      ELSE {Task Services task.
        ALLOCATE p_allocated_command_buffer: [[REP dfc$command_buffer_size OF cell]] IN
              dfv$server_wired_heap^;
        IF (p_allocated_command_buffer = NIL) THEN
          osp$system_error (' NIL p_allocated_command_buffer', NIL);
        ELSE
          cpu_queue_entries [queue_entry_index].p_receive_buffer := ^p_allocated_command_buffer^.buffer;
        IFEND;
      IFEND;

      { Touch the page to assure it is created in real memory.
      IF (cpu_queue_entries [queue_entry_index].processor_type = dfc$monitor) THEN
        pmp$zero_out_table (p_allocated_monitor_buffer, #SIZE (p_allocated_monitor_buffer^));
      ELSE {Task Services task.
        pmp$zero_out_table (p_allocated_command_buffer, #SIZE (p_allocated_command_buffer^));
      IFEND;

      i#real_memory_address (cpu_queue_entries [queue_entry_index].p_receive_buffer, rma);
      driver_queue_entries [queue_entry_index].receive_buffer_descriptor.address := rma;
      driver_queue_entries [queue_entry_index].receive_buffer_descriptor.indirect_address := FALSE;
      IF (cpu_queue_entries [queue_entry_index].processor_type = dfc$monitor) THEN
        driver_queue_entries [queue_entry_index].receive_buffer_descriptor.actual_length :=
              dfp$word_boundary (#SIZE (p_allocated_monitor_buffer^));
      ELSE {Task Services task.
        driver_queue_entries [queue_entry_index].receive_buffer_descriptor.actual_length :=
              #SIZE (p_allocated_command_buffer^);
      IFEND;

{     Initialize pointer to queue entry's data RMA list.
      IF queue_entry_index = dfc$poll_queue_index THEN
        cpu_queue_entries [queue_entry_index].p_data_rma_list := NIL;
        driver_queue_entries [queue_entry_index].data_descriptor.indirect_address := FALSE;
        driver_queue_entries [queue_entry_index].data_descriptor.actual_length := 0;
        driver_queue_entries [queue_entry_index].data_descriptor.address := 0;
      ELSE
{       This code requires that dfc$poll_queue_index be equal to 1.
        pva := ^p_allocated_data_rma_list^.rma_list[((queue_entry_index -2) * number_of_rma_list_entries) +1];
        build_qe_p_data_rma_list (pva, number_of_rma_list_entries,
             cpu_queue_entries [queue_entry_index].p_data_rma_list);

        i#real_memory_address (cpu_queue_entries [queue_entry_index].p_data_rma_list, rma);
        driver_queue_entries [queue_entry_index].data_descriptor.address := rma;
        driver_queue_entries [queue_entry_index].data_descriptor.indirect_address := TRUE;
        { Actual length of zero is used to indicate not ready for data
        driver_queue_entries [queue_entry_index].data_descriptor.actual_length := 0;
      IFEND;


      IF cpu_queue_entries [queue_entry_index].processor_type = dfc$monitor THEN
        initialize_monitor_cpu_q_entry (server_to_client, p_queue_interface_table, queue_index,
              queue_entry_index, cpu_queue_entries [queue_entry_index]);
      ELSEIF queue_entry_index <> dfc$poll_queue_index THEN
        cpu_queue_entries [queue_entry_index].server_to_client := server_to_client;
        IF server_to_client THEN
          cpu_queue_entries [queue_entry_index].p_last_wired_data := NIL;
          cpu_queue_entries [queue_entry_index].last_wired_length := 0;
        IFEND;
        ALLOCATE p_allocated_rpc_data_area IN dfv$server_wired_heap^;
        IF p_allocated_rpc_data_area = NIL THEN
          osp$system_error ('NIL p_send_data ', NIL);
        IFEND;
        cpu_queue_entries [queue_entry_index].p_send_data := ^p_allocated_rpc_data_area^.data;
        ALLOCATE p_allocated_rpc_data_area IN dfv$server_wired_heap^;
        IF p_allocated_rpc_data_area = NIL THEN
          osp$system_error ('NIL p_receive_data ', NIL);
        IFEND;
        cpu_queue_entries [queue_entry_index].p_receive_data := ^p_allocated_rpc_data_area^.data;

      IFEND;

    FOREND /initialize_each_entry/;

  PROCEND initialize_queue_entries;
?? OLDTITLE ??
?? NEWTITLE := 'record_queue_interface ', EJECT ??

{ PURPOSE:
{   The purpose of this routine is to store the queue interface table pointer into the queue interface
{   directory.

  PROCEDURE record_queue_interface
    (    driver_name: ost$name;
         queue_interface_table_p: dft$p_queue_interface_table;
         connection_parameters: dft$connection_parameters);

    VAR
      ignore_status: ost$status,
      index: dft$queue_directory_index,
      old_directory_p: dft$p_queue_interface_directory;

    IF dfv$p_queue_interface_directory = NIL THEN
      ALLOCATE dfv$p_queue_interface_directory: [1 .. 1] IN dfv$server_wired_heap^;
      IF dfv$p_queue_interface_directory = NIL THEN
        osp$system_error (' NIL dfv$p_queue_interface_directory', NIL);
      IFEND;
    ELSE
      old_directory_p := dfv$p_queue_interface_directory;
      ALLOCATE dfv$p_queue_interface_directory: [1 .. (UPPERBOUND (old_directory_p^) + 1)] IN
            dfv$server_wired_heap^;
      IF dfv$p_queue_interface_directory = NIL THEN
        osp$system_error (' NIL dfv$p_queue_interface_directory', NIL);
      IFEND;

      FOR index := 1 TO UPPERBOUND (old_directory_p^) DO
        dfv$p_queue_interface_directory^ [index] := old_directory_p^ [index];
      FOREND;

      FREE old_directory_p IN dfv$server_wired_heap^;
    IFEND;

    index := UPPERBOUND (dfv$p_queue_interface_directory^);
    dfv$p_queue_interface_directory^ [index].driver_name := driver_name;
    dfv$p_queue_interface_directory^ [index].p_queue_interface_table := queue_interface_table_p;
    dfv$p_queue_interface_directory^ [index].driver_active := FALSE;
    dfv$p_queue_interface_directory^ [index].connection_type := connection_parameters.connection_type;
    IF connection_parameters.connection_type = dfc$esm_connection THEN
      osp$initialize_signature_lock (dfv$p_queue_interface_directory^ [index].load_unload_pp_lock,
            ignore_status);
      dfv$p_queue_interface_directory^ [index].element_name :=
            connection_parameters.esm_parameters.element_name;
      dfv$p_queue_interface_directory^ [index].send_channel :=
            connection_parameters.esm_parameters.send_channel;
      dfv$p_queue_interface_directory^ [index].receive_channel :=
            connection_parameters.esm_parameters.receive_channel;
      dfv$p_queue_interface_directory^ [index].use_dma := connection_parameters.esm_parameters.dma_available;
      dfv$p_queue_interface_directory^ [index].send_pp.pp_status.activated := FALSE;
      dfv$p_queue_interface_directory^ [index].send_pp.pp_status.loaded := FALSE;
      dfv$p_queue_interface_directory^ [index].send_pp.pp_status.idled := TRUE;
      dfv$p_queue_interface_directory^ [index].send_pp.p_element_reservations := NIL;
      dfv$p_queue_interface_directory^ [index].receive_pp.pp_status.activated := FALSE;
      dfv$p_queue_interface_directory^ [index].receive_pp.pp_status.loaded := FALSE;
      dfv$p_queue_interface_directory^ [index].receive_pp.pp_status.idled := TRUE;
      dfv$p_queue_interface_directory^ [index].receive_pp.p_element_reservations := NIL;
    IFEND;

  PROCEND record_queue_interface;
?? OLDTITLE ??
MODEND dfm$queue_initialization;
*DECK DECK=DFM$R3_MANAGE_FILE_SERVER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: Client/Server: r3_manage_file_server', EJECT ??
MODULE dfm$r3_manage_file_server;

{
{  This module processes the Manage_File_Server commands.
{

?? NEWTITLE := '    Global Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??

*copyc amp$close
*copyc amp$open
*copyc amp$put_next
*copyc amp$return
*copyc amt$file_identifier
*copyc amt$page_width
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$scan_command_file
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc dfi$display
*copyc dfp$change_family_server_state
*copyc dfp$crack_mainframe_id
*copyc dfp$delete_tables_of_partner
*copyc dfp$discard_client_jobs
*copyc dfp$display_client_mainframes
*copyc dfp$find_mainframe_id
*copyc dfp$format_task_name
*copyc dfp$free_image_file
*copyc dfp$get_client_mf_job_name
*copyc dfp$get_client_mf_file_info
*copyc dfp$get_highest_sf_lifetime
*copyc dfp$locate_esm_definition
*copyc dfp$purge_client_mainframe_file
*copyc dfp$purge_image_file
*copyc dfp$r2_check_job_recovery
*copyc dfp$reset_mainframe_tables
*copyc dfp$return_esm_base_addresses
*copyc dfp$return_esm_definition
*copyc dfp$set_terminated_access_state
*copyc dfp$terminate_server_files
*copyc dfp$timeout_server_files
*copyc dfp$verify_system_administrator
*copyc dft$client_mainframe_file
*copyc dft$cpu_queue
*copyc dft$display_identifier
*copyc dft$family_list
*copyc dft$queue_index
*copyc dft$queue_interface_directory
*copyc dft$served_family_table_index
*copyc dft$served_family_table
*copyc dfv$file_server_debug_enabled
*copyc dfv$server_state_string
*copyc jme$queued_file_conditions
*copyc jmp$job_exists
*copyc osp$activate_system_task
*copyc osp$active_system_task_r1
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal
*copyc ost$caller_identifier
*copyc ost$string
*copyc osp$verify_system_privilege
*copyc pmp$convert_mainframe_to_binary
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pmp$get_date_time_at_timestamp
*copyc pmp$get_unique_name
*copyc pmt$binary_mainframe_id
*copyc pmt$mainframe_id
?? POP ??


  TYPE
    outline_string_type = record
      size: 0 .. 110,
      value: string (110),
    recend;

?? TITLE := '    dfp$activate_client', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$activate_client
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      client_mainframe_job_name: jmt$user_supplied_name,
      job_exists: boolean,
      job_status: ost$status,
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
      server_to_client: boolean;

    dfp$verify_system_administrator ('ACTIVATE_CLIENT', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server_to_client := TRUE;
    dfp$find_mainframe_id (mainframe_name, server_to_client, mainframe_found, p_queue_interface_table,
          p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, mainframe_name, status);
      RETURN;
    IFEND;

    CASE p_cpu_queue^.queue_header.partner_status.server_state OF
    = dfc$terminated, dfc$awaiting_recovery =
      dfp$get_client_mf_job_name (mainframe_name, client_mainframe_job_name);
      jmp$job_exists (client_mainframe_job_name, $jmt$job_state_set [jmc$initiated_job, jmc$queued_job],
            job_exists, job_status);
      job_exists := (job_status.normal AND job_exists) OR
            (NOT job_status.normal AND (job_status.condition = jme$duplicate_name));
      IF job_exists THEN
        IF p_cpu_queue^.queue_header.partner_status.verify_queue THEN
          { The client is already activating.
          {  If the client job is not active and we are at verify_queue
          { perhaps the job aborted, we allow activation to retry.
          osp$set_status_abnormal (dfc$file_server_id, dfe$client_is_activating, mainframe_name, status);
         ELSE
          { The client is not active, but the old client mainframe job is
          { still around.  It is dangerous to proceed since that job may be
          { looking at the queues that would be reset here.
          osp$set_status_abnormal (dfc$file_server_id, dfe$client_active,
                client_mainframe_job_name, status);
        IFEND;
        RETURN;
      IFEND;

      dfp$reset_mainframe_tables (mainframe_name, server_to_client, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      p_cpu_queue^.queue_header.partner_status.verify_queue := TRUE;

{     ---------------------------
{     Start Client Job Right Here
{     ---------------------------

      dfp$submit_client_mainframe_job (mainframe_name, status);
      IF NOT status.normal THEN
        display ('UNABLE TO SUBMIT CLIENT JOB');
        RETURN;
      IFEND;

    = dfc$inactive =
      IF p_cpu_queue^.queue_header.partner_status.verify_queue THEN
        { The client is already activating.
          osp$set_status_abnormal (dfc$file_server_id, dfe$client_is_activating, mainframe_name, status);
      ELSE
        { Reset the poller's queue entry - so that if the other side is awaiting_recovery
        { transaction counts will match.
        p_cpu_queue^.queue_entries [dfc$poll_queue_index].transaction_count := 0;
        p_cpu_queue^.queue_entries [dfc$poll_queue_index].retransmission_count := 0;
        p_cpu_queue^.queue_header.partner_status.verify_queue := TRUE;
      IFEND;

    = dfc$active =
      osp$set_status_abnormal (dfc$file_server_id, dfe$client_active, mainframe_name, status);

    = dfc$deactivated =
      osp$set_status_abnormal (dfc$file_server_id, dfe$client_deactivated, mainframe_name, status);

    = dfc$recovering =
      osp$set_status_abnormal (dfc$file_server_id, dfe$client_is_activating, mainframe_name, status);

    ELSE
      display (' SYSTEM ERROR - SERVER STATE CODE IN ERROR');
    CASEND;

  PROCEND dfp$activate_client;

?? TITLE := '    dfp$activate_server', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$activate_server
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
      server_to_client: boolean,
      task_name: ost$name;

    dfp$verify_system_administrator ('ACTIVATE_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server_to_client := FALSE;
    dfp$find_mainframe_id (mainframe_name, server_to_client, mainframe_found, p_queue_interface_table,
          p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, mainframe_name, status);
      RETURN;
    IFEND;

    CASE p_cpu_queue^.queue_header.partner_status.server_state OF
    = dfc$terminated, dfc$awaiting_recovery =
      dfp$format_task_name (mainframe_name, task_name);
      IF osp$active_system_task_r1 (task_name) THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$server_active, task_name, status);
        RETURN;
      IFEND;

      dfp$reset_mainframe_tables (mainframe_name, server_to_client, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      p_cpu_queue^.queue_header.partner_status.verify_queue := TRUE;

{     ----------------------------------
{     Start Asynchronous Task Right Here
{     ----------------------------------

      osp$activate_system_task (task_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    = dfc$inactive =
      IF p_cpu_queue^.queue_header.partner_status.verify_queue THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$server_active, mainframe_name, status);
       ELSE
        { Reset the poller's queue entry so that if the other side is awaiting_recovery
        { transaction counts will match.
        p_cpu_queue^.queue_entries [dfc$poll_queue_index].transaction_count := 0;
        p_cpu_queue^.queue_entries [dfc$poll_queue_index].retransmission_count := 0;
        p_cpu_queue^.queue_header.partner_status.verify_queue := TRUE;
      IFEND;

    = dfc$active, dfc$recovering =
      osp$set_status_abnormal (dfc$file_server_id, dfe$server_active, mainframe_name, status);

    = dfc$deactivated =
      osp$set_status_abnormal (dfc$file_server_id, dfe$server_deactivated, mainframe_name, status);

    ELSE
      display (' SYSTEM ERROR - SERVER STATE CODE IN ERROR');
    CASEND;

  PROCEND dfp$activate_server;
?? TITLE := '  dfp$check_job_recovery  ', EJECT ??
*copyc dfh$check_job_recovery
  PROCEDURE [XDCL, #GATE] dfp$check_job_recovery (VAR recovery_occurred: boolean);

    osp$verify_system_privilege;
    dfp$r2_check_job_recovery (recovery_occurred);

  PROCEND dfp$check_job_recovery;
?? TITLE := '    dfp$deactivate_client', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$deactivate_client
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
      server_to_client: boolean;

    dfp$verify_system_administrator ('DEACTIVATE_CLIENT', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server_to_client := TRUE;
    dfp$find_mainframe_id (mainframe_name, server_to_client, mainframe_found, p_queue_interface_table,
          p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, mainframe_name, status);
      RETURN;
    IFEND;

    CASE p_cpu_queue^.queue_header.partner_status.server_state OF
    = dfc$active =
      p_cpu_queue^.queue_header.partner_status.send_deactivate_partner := TRUE;
    ELSE
      osp$set_status_abnormal (dfc$file_server_id, dfe$client_not_active, mainframe_name, status);
    CASEND;

  PROCEND dfp$deactivate_client;

?? TITLE := '    dfp$deactivate_server', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$deactivate_server
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
      server_to_client: boolean;

    dfp$verify_system_administrator ('DEACTIVATE_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server_to_client := FALSE;
    dfp$find_mainframe_id (mainframe_name, server_to_client, mainframe_found, p_queue_interface_table,
          p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, mainframe_name, status);
      RETURN;
    IFEND;

    CASE p_cpu_queue^.queue_header.partner_status.server_state OF
    = dfc$active =
      p_cpu_queue^.queue_header.partner_status.send_deactivate_partner := TRUE;
    ELSE
      osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_active, mainframe_name, status);
    CASEND;

  PROCEND dfp$deactivate_server;

?? TITLE := '    dfp$delete_client', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$delete_client
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      client_mainframe_job_name: jmt$user_supplied_name,
      job_exists: boolean,
      job_status: ost$status,
      mainframe_found: boolean,
      mainframe_id: pmt$binary_mainframe_id,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
      server_birthdate: integer,
      server_lifetime: dft$lifetime,
      server_state: dft$server_state,
      server_to_client: boolean;

    dfp$verify_system_administrator ('DELETE_CLIENT', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server_to_client := TRUE;
    dfp$find_mainframe_id (mainframe_name, server_to_client, mainframe_found, p_queue_interface_table,
          p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF mainframe_found THEN
      IF (p_cpu_queue^.queue_header.partner_status.server_state IN $dft$server_states
            [dfc$terminated, dfc$awaiting_recovery]) AND
            NOT p_cpu_queue^.queue_header.partner_status.verify_queue THEN
        dfp$get_client_mf_job_name (mainframe_name, client_mainframe_job_name);
        jmp$job_exists (client_mainframe_job_name, $jmt$job_state_set [jmc$initiated_job, jmc$queued_job],
              job_exists, job_status);
        job_exists := (job_status.normal AND job_exists) OR
              (NOT job_status.normal AND (job_status.condition = jme$duplicate_name));
        IF job_exists THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$client_not_deleteable,
                client_mainframe_job_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, ' Client job still running ', status);
        ELSE
          dfp$delete_tables_of_partner (mainframe_name, server_to_client, status);
        IFEND;
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$client_not_deleteable, mainframe_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              ' The client must be in the awaiting_recovery or terminated state.', status);
      IFEND;
    ELSE { No queue exists }
      pmp$convert_mainframe_to_binary (mainframe_name, mainframe_id, status);
      dfp$get_client_mf_file_info (mainframe_id, mainframe_found, server_state, server_lifetime,
            server_birthdate);
      IF mainframe_found THEN
        IF (server_state = dfc$terminated) OR (server_state = dfc$deleted) THEN
          dfp$purge_client_mainframe_file (mainframe_name, status);
        ELSE
          osp$set_status_abnormal (dfc$file_server_id, dfe$client_not_deleteable, mainframe_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
              ' The client must be in the terminated state.', status);
        IFEND;
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, mainframe_name, status);
      IFEND;
    IFEND;

  PROCEND dfp$delete_client;

?? TITLE := '    dfp$delete_server', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$delete_server
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      mainframe_found: boolean,
      mainframe_id: pmt$binary_mainframe_id,
      p_cpu_queue: ^dft$cpu_queue,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      queue_index: dft$queue_index,
      server_birthdate: integer,
      server_lifetime: dft$lifetime,
      server_state: dft$server_state,
      server_to_client: boolean,
      task_name: ost$name;

    dfp$verify_system_administrator ('DELETE_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server_to_client := FALSE;
    dfp$find_mainframe_id (mainframe_name, server_to_client, mainframe_found, p_queue_interface_table,
          p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF mainframe_found THEN
      IF (p_cpu_queue^.queue_header.partner_status.server_state IN $dft$server_states
            [dfc$terminated, dfc$awaiting_recovery]) AND
            NOT p_cpu_queue^.queue_header.partner_status.verify_queue THEN
        dfp$format_task_name (mainframe_name, task_name);
        IF osp$active_system_task_r1 (task_name) THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_deleteable, task_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
              ' The file server system task is still running.', status);
        ELSE
          dfp$delete_tables_of_partner (mainframe_name, server_to_client, status);
        IFEND;
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_deleteable, mainframe_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
            ' The server must be in the terminated or awaiting_recovery state.', status);
      IFEND;
    ELSE
      pmp$convert_mainframe_to_binary (mainframe_name, mainframe_id, status);
      dfp$get_highest_sf_lifetime (mainframe_id, mainframe_found, server_state, server_lifetime,
            server_birthdate);
      IF mainframe_found AND (server_state <> dfc$deleted) THEN
        IF server_state = dfc$terminated THEN
          dfp$change_family_server_state (dfc$deleted, mainframe_id);
          dfp$purge_image_file (mainframe_id, local_status);
        ELSE
          osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_deleteable, mainframe_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            ' The server must be terminated.', status);
        IFEND;
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, mainframe_name, status);
      IFEND;
    IFEND;

  PROCEND dfp$delete_server;

?? TITLE := '    dfp$display_client', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$display_client
    (    mainframe_name: pmt$mainframe_id;
         output_file_fid: amt$file_identifier;
         page_width: amt$page_width;
     VAR status: ost$status);

    VAR
      display_client: boolean,
      mainframe_found: boolean,
      mainframe_id: pmt$binary_mainframe_id,
      server_birthdate: integer,
      server_lifetime: dft$lifetime,
      server_state: dft$server_state;

    dfp$verify_system_administrator ('DISPLAY_CLIENT', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_client := TRUE;
    display_client_or_server (mainframe_name, display_client, output_file_fid, page_width, status);
    IF NOT status.normal AND (status.condition = dfe$mainframe_not_client) THEN
      pmp$convert_mainframe_to_binary (mainframe_name, mainframe_id, status);
      dfp$get_client_mf_file_info (mainframe_id, mainframe_found, server_state, server_lifetime,
            server_birthdate);
      IF mainframe_found THEN
        display_short_client_or_server (mainframe_name, display_client, server_state, server_lifetime,
              server_birthdate, output_file_fid, page_width, status);
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, mainframe_name, status);
      IFEND;
    IFEND;
  PROCEND dfp$display_client;

?? TITLE := '    dfp$client_mainframes_display', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$client_mainframes_display
    (    file_name: amt$local_file_name;
     VAR status: ost$status);

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure provides clean-up processing when a task abort occurs.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      #SPOIL (output_open);
      IF output_open THEN
        #SPOIL (display_identifier.display_control);
        clp$close_display (display_identifier.display_control, ignore_status);
        status.normal := TRUE;
        output_open := FALSE;
      IFEND;

    PROCEND abort_handler;

*copyc clp$new_page_procedure

?? OLDTITLE ??
?? NEWTITLE := '    print_subtitle', EJECT ??

    PROCEDURE print_subtitle
      (    header: string (50);
       VAR status: ost$status);

      clp$put_partial_display (display_identifier.display_control, header, clc$trim, amc$continue, status);

    PROCEND print_subtitle;

?? OLDTITLE ??
?? NEWTITLE := '    put_subtitle', EJECT ??

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

      print_subtitle (header, status);

    PROCEND put_subtitle;

?? OLDTITLE, EJECT ??

*copyc clv$display_variables

    CONST
      command_name = 'DISPLAY_CLIENT_MAINFRAMES';

    VAR
      caller_id: ost$caller_identifier,
      default_ring_attributes: amt$ring_attributes,
      display_identifier: dft$display_identifier,
      display_line: string (80),
      header: string (50),
      ignore_status: ost$status,
      message_written: boolean,
      nothing_to_display: [READ, oss$job_paged_literal] string (56) :=
            '                        *** No File Server Defined. ***',
      output_open: boolean;


    status.normal := TRUE;
    header := 'CLIENT MAINFRAME(S)';
    output_open := FALSE;
    #SPOIL (output_open);
    message_written := FALSE;

    osp$establish_condition_handler (^abort_handler, TRUE);

    display_identifier.display_type := dfc$listing_display;
    #CALLER_ID (caller_id);
    default_ring_attributes.r1 := caller_id.ring;
    default_ring_attributes.r2 := caller_id.ring;
    default_ring_attributes.r3 := caller_id.ring;

    clp$open_display_reference (file_name, ^clp$new_page_procedure, fsc$list, default_ring_attributes,
          display_identifier.display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    #SPOIL (output_open);
    output_open := TRUE;
    #SPOIL (output_open);

    clv$titles_built := FALSE;
    clv$command_name := command_name;

    dfp$display_client_mainframes (display_identifier, message_written, ignore_status);

    IF NOT message_written THEN
      clp$put_display (display_identifier.display_control, nothing_to_display, clc$trim, ignore_status);
    IFEND;

    clp$close_display (display_identifier.display_control, ignore_status);
    output_open := FALSE;
    #SPOIL (output_open);
    osp$disestablish_cond_handler;

  PROCEND dfp$client_mainframes_display;

?? TITLE := '    dfp$display_server', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$display_server
    (    mainframe_name: pmt$mainframe_id;
         output_file_fid: amt$file_identifier;
         page_width: amt$page_width;
     VAR status: ost$status);

    VAR
      mainframe_id: pmt$binary_mainframe_id,
      server_found: boolean,
      server_state: dft$server_state,
      server_birthdate: integer,
      server_lifetime: dft$lifetime;

    dfp$verify_system_administrator ('DISPLAY_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_client_or_server (mainframe_name, FALSE, output_file_fid, page_width, status);
    IF NOT status.normal AND (status.condition = dfe$mainframe_not_server) THEN
      pmp$convert_mainframe_to_binary (mainframe_name, mainframe_id, status);
      dfp$get_highest_sf_lifetime (mainframe_id, server_found, server_state, server_lifetime,
            server_birthdate);
      IF server_found THEN
        display_short_client_or_server (mainframe_name, {display_client = } FALSE, server_state,
              server_lifetime, server_birthdate, output_file_fid, page_width, status);
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, mainframe_name, status);
      IFEND;
    IFEND;

  PROCEND dfp$display_server;

?? TITLE := '  dfp$display_stornet_connection ', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$display_stornet_connection
    (    element_name: cmt$element_name;
         output_file_fid: amt$file_identifier;
         page_width: amt$page_width;
     VAR status: ost$status);

    VAR
      esm_base_addresses: dft$esm_base_addresses,
      esm_definition: cmt$esm_definition,
      low_speed_port_present: boolean,
      outline: outline_string_type,
      p_esm_def_table_entry: ^dft$esm_definition_table_entry,
      port_index: integer,
      side_door_port_present: boolean,
      stornet_element: cmt$element_descriptor;

    dfp$verify_system_administrator ('DISPLAY_STORNET_CONNECTION', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    stornet_element.element_type := cmc$communications_element;
    stornet_element.peripheral_descriptor.use_logical_identification := TRUE;
    stornet_element.peripheral_descriptor.element_name := element_name;

    dfp$return_esm_definition (stornet_element, esm_definition, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$return_esm_base_addresses (element_name, esm_base_addresses, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dfp$locate_esm_definition (element_name, p_esm_def_table_entry);

    start_line ('   STORNET_element:....', outline);
    add_to_line (output_file_fid, page_width, esm_definition.element_name, outline);
    flush_line (output_file_fid, outline);
    start_line ('       Product_ID:.......................', outline);
    add_to_line (output_file_fid, page_width, esm_definition.product_id.product_number, outline);
    add_to_line (output_file_fid, page_width, esm_definition.product_id.underscore, outline);
    add_to_line (output_file_fid, page_width, esm_definition.product_id.model_number, outline);
    flush_line (output_file_fid, outline);
    start_line ('       Serial_Number.....................', outline);
    add_to_line (output_file_fid, page_width, esm_definition.serial_number, outline);
    flush_line (output_file_fid, outline);
    start_line ('       Driver_Name.......................', outline);
    add_to_line (output_file_fid, page_width, esm_definition.peripheral_driver_name, outline);
    flush_line (output_file_fid, outline);
    start_line ('       Memory_size.......................', outline);
    add_integer_to_line (output_file_fid, page_width, esm_definition.memory_size, outline);
    add_to_line (output_file_fid, page_width, ' =', outline);
    add_hex_to_line (output_file_fid, page_width, esm_definition.memory_size, TRUE, outline);
    flush_line (output_file_fid, outline);

    start_line ('       Number of Mainframes..............', outline);
    add_integer_to_line (output_file_fid, page_width, esm_base_addresses.number_of_mainframes, outline);
    flush_line (output_file_fid, outline);
    start_line ('       Divisions per Mainframe...........', outline);
    add_integer_to_line (output_file_fid, page_width, esm_base_addresses.divisions_per_mainframe, outline);
    flush_line (output_file_fid, outline);
    start_line ('           Division Size.................', outline);
    add_hex_to_line (output_file_fid, page_width, esm_base_addresses.esm_division_size *
          dfc$esm_memory_base_shift, TRUE, outline);
    flush_line (output_file_fid, outline);

    start_line ('       Data Transfer Size................', outline);
    add_integer_to_line (output_file_fid, page_width, p_esm_def_table_entry^.maximum_data_bytes, outline);
    flush_line (output_file_fid, outline);

    start_line ('       Flag Base.........................', outline);
    add_integer_to_line (output_file_fid, page_width, esm_base_addresses.esm_flag_base, outline);
    add_to_line (output_file_fid, page_width, ' =', outline);
    add_hex_to_line (output_file_fid, page_width, esm_base_addresses.esm_flag_base, TRUE, outline);
    flush_line (output_file_fid, outline);

    start_line ('       Memory Base.......................', outline);
    add_integer_to_line (output_file_fid, page_width, esm_base_addresses.esm_memory_base *
          dfc$esm_memory_base_shift, outline);
    add_to_line (output_file_fid, page_width, ' =', outline);
    add_hex_to_line (output_file_fid, page_width, esm_base_addresses.esm_memory_base *
          dfc$esm_memory_base_shift, TRUE, outline);
    flush_line (output_file_fid, outline);

    low_speed_port_present := FALSE;
    start_line ('       Low_speed_ports:', outline);
    flush_line (output_file_fid, outline);
    FOR port_index := 1 TO cmc$max_low_speed_port_number DO
      IF esm_definition.low_speed_port [port_index].configured THEN
        low_speed_port_present := TRUE;
        start_line ('         Entry ', outline);
        add_integer_to_line (output_file_fid, page_width, port_index, outline);
        flush_line (output_file_fid, outline);
        start_line ('           Channel.........', outline);
        add_to_line (output_file_fid, page_width, esm_definition.low_speed_port [port_index].element_name,
              outline);
        flush_line (output_file_fid, outline);
        start_line ('           Mainframe.......', outline);
        add_to_line (output_file_fid, page_width, esm_definition.low_speed_port [port_index].
              mainframe_ownership, outline);
        flush_line (output_file_fid, outline);
        start_line ('           IOU.............', outline);
        add_to_line (output_file_fid, page_width, esm_definition.low_speed_port [port_index].iou, outline);
        flush_line (output_file_fid, outline);
      IFEND;
    FOREND;
    IF NOT low_speed_port_present THEN
      start_line ('         NO LOW SPEED PORTS PRESENT!', outline);
      flush_line (output_file_fid, outline);
    IFEND;

    side_door_port_present := FALSE;
    start_line ('       Side_door_ports:', outline);
    flush_line (output_file_fid, outline);
    FOR port_index := 1 TO cmc$max_side_door_port_number DO
      IF esm_definition.side_door_port [port_index].configured THEN
        side_door_port_present := TRUE;
        start_line ('         Entry ', outline);
        add_integer_to_line (output_file_fid, page_width, port_index, outline);
        flush_line (output_file_fid, outline);
        start_line ('           Channel.........', outline);
        add_to_line (output_file_fid, page_width, esm_definition.side_door_port [port_index].element_name,
              outline);
        flush_line (output_file_fid, outline);
        start_line ('           Mainframe.......', outline);
        add_to_line (output_file_fid, page_width, esm_definition.side_door_port [port_index].
              mainframe_ownership, outline);
        flush_line (output_file_fid, outline);
        start_line ('           IOU.............', outline);
        add_to_line (output_file_fid, page_width, esm_definition.side_door_port [port_index].iou, outline);
        flush_line (output_file_fid, outline);
      IFEND;
    FOREND;
    IF NOT side_door_port_present THEN
      start_line ('         NO SIDE DOOR PORTS PRESENT!', outline);
      flush_line (output_file_fid, outline);
    IFEND;

    start_line ('       Maintenance', outline);
    flush_line (output_file_fid, outline);
    start_line ('         Buffer_Location...', outline);
    add_integer_to_line (output_file_fid, page_width, esm_definition.maintenance_buffer_location.
          first_word_address, outline);
    flush_line (output_file_fid, outline);
    start_line ('         Buffer_Size.......', outline);
    add_integer_to_line (output_file_fid, page_width, esm_definition.maintenance_buffer_location.length,
          outline);
    flush_line (output_file_fid, outline);

  PROCEND dfp$display_stornet_connection;

?? TITLE := '    [XDCL] dfp$submit_client_mainframe_job', EJECT ??

  PROCEDURE [XDCL] dfp$submit_client_mainframe_job
    (    client_mainframe: pmt$mainframe_id;
     VAR status: ost$status);

    PROCEDURE put
      (    line: string ( * <= 128));

      VAR
        byte_address: amt$file_byte_address,
        local_status: ost$status;

      amp$put_next (submit_file_id, ^line, STRLENGTH (line), byte_address, status);
      IF NOT status.normal THEN
        amp$close (submit_file_id, local_status);
        amp$return (submit_file, local_status);
        EXIT dfp$submit_client_mainframe_job;
        RETURN;
      IFEND;
    PROCEND put;

    VAR
      client_mainframe_job_name: jmt$user_supplied_name,
      line_length: integer,
      local_status: ost$status,
      output_line: string (128),
      submit_file: amt$local_file_name,
      submit_file_id: amt$file_identifier;

    dfp$get_client_mf_job_name (client_mainframe, client_mainframe_job_name);
    pmp$get_unique_name (submit_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (submit_file, amc$record, NIL, submit_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Build command file containing JOB/JOBEND

    STRINGREP (output_line, line_length, 'JOB JOB_CLASS=SYSTEM USER_JOB_NAME=', client_mainframe_job_name,
          ' ..');
    put (output_line (1, line_length));
    put ('    JOB_ABORT_DISPOSITION=TERMINATE   JOB_RECOVERY_DISPOSITION=TERMINATE');
    put (' ');

    put (' VAR');
    put ('   ignore_status: status');
    put ('   log_file: file = :$system.$system.$df_job_logs//$job(user_job_name)//$job(system_job_name)');
    put ('   task_status: status');
    put (' VAREND');
    put (' ');

    put (' create_catalog $up($up(log_file)) status=ignore_status');
    put (' create_catalog $up(log_file) status=ignore_status');
    put (' ');

    put (' display_message ..');
    put ('       '' *** Permanent File_Server Client_Job JOB_LOG will be written to ''//..');
    put ('$string(log_file)//'' ***'' to=job');
    IF dfv$file_server_debug_enabled THEN
      put (' send_operator_message ..');
      put ('       '' *** Permanent File_Server Client_Job JOB_LOG will be written to ''//..');
      put ('$string(log_file)//'' ***''');
    IFEND;
    put (' terminate_output name=output ');
    put (' ');

    put (' WHEN ANY_FAULT DO ');
    put ('   when_status = $previous_status ');
    put ('   display_value when_status output=:$local.$job_log ');
    put ('   display_value when_status output=:$local.$response ');
    put ('   send_operator_message ..');
    put ('   '' CLIENT JOB ABORTING - SEE JOB LOG ''//$condition_name(when_status.condition) ');
    put ('   display_log display_option=all output=log_file.$next');
    put ('  WHENEND');
    put (' ');

    put (' system_operator_utility capability=system_operation ');
    put ('   change_priority job_name=$job(system_job_name) dispatching_priority=p9 ');
    put (' quit ');
    put (' ');

    STRINGREP (output_line, line_length, ' EXECUTE_TASK SP=DFP$MANAGE_CLIENT_CONNECTION P=''',
          client_mainframe, ''' status=task_status');
    put (output_line (1, line_length));
    put (' IF NOT task_status.normal THEN');
    put ('   display_value '' WARNING: Abnormal status returned from Manage Client Connection task:'' ..');
    put ('         output=:$local.$job_log');
    put ('   display_value task_status ..');
    put ('         output=:$local.$job_log');
    put (' IFEND');
    put (' ');

    put (' " ************************************************************ " ');
    STRINGREP (output_line, line_length, ' " *** ', client_mainframe_job_name,
          ' job terminating.     *** " ');
    put (output_line (1, line_length));
    put (' " *** Final commands will be as follows:                   *** " ');
    put (' " *** DISPLAY_LOG display_option=all output=log_file.$next *** " ');
    put (' " *** LOGOUT                                               *** " ');
    put (' " ************************************************************ " ');
    put (' ');

    put (' DISPLAY_LOG display_option=all output=log_file.$next');
    put (' ');

    put ('JOBEND');

    amp$close (submit_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_command_file (submit_file, osc$null_name, '', status);

    amp$return (submit_file, local_status);
  PROCEND dfp$submit_client_mainframe_job;

?? TITLE := '    dfp$terminate_client', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$terminate_client
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      mainframe_found: boolean,
      mainframe_id: pmt$binary_mainframe_id,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
      server_birthdate: integer,
      server_lifetime: dft$lifetime,
      server_state: dft$server_state,
      server_to_client: boolean;

    dfp$verify_system_administrator ('TERMINATE_CLIENT', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server_to_client := TRUE;
    dfp$find_mainframe_id (mainframe_name, server_to_client, mainframe_found, p_queue_interface_table,
          p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF mainframe_found THEN
      { This code should verify that the client job exists, if it does not
      { then the work should be done right here.

      CASE p_cpu_queue^.queue_header.partner_status.server_state OF
      = dfc$terminated =
        IF NOT p_cpu_queue^.queue_header.partner_status.verify_queue THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$client_already_terminated, mainframe_name, status);
          RETURN;
        IFEND;
        p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
        p_cpu_queue^.queue_header.partner_status.terminate_partner := TRUE;

      = dfc$inactive =
        p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
        p_cpu_queue^.queue_header.partner_status.terminate_partner := TRUE;

      = dfc$recovering, dfc$deactivated, dfc$active =
        p_cpu_queue^.queue_header.partner_status.terminate_partner := TRUE;

      = dfc$awaiting_recovery =
        IF p_cpu_queue^.queue_header.partner_status.verify_queue THEN

{ The client mainframe job exists let it do the work.

          p_cpu_queue^.queue_header.partner_status.terminate_partner := TRUE;
          p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
        ELSE
          p_cpu_queue^.queue_header.partner_status.server_state := dfc$terminated;
          p_cpu_queue^.queue_header.partner_status.terminate_partner := FALSE;
          p_cpu_queue^.queue_header.partner_status.deactivate_complete := FALSE;

{ Store state into client mainframe file

          dfp$discard_client_jobs (mainframe_name, dfc$terminated, status);
        IFEND;
      ELSE
      CASEND;
    ELSE { No queue exists
      pmp$convert_mainframe_to_binary (mainframe_name, mainframe_id, status);
      dfp$get_client_mf_file_info (mainframe_id, mainframe_found, server_state, server_lifetime,
            server_birthdate);
      IF mainframe_found THEN

{ Store state into client mainframe file

        IF server_state = dfc$terminated THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$client_already_terminated, mainframe_name, status);
        ELSE
          dfp$discard_client_jobs (mainframe_name, dfc$terminated, status);
        IFEND;
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, mainframe_name, status);
      IFEND;
    IFEND;

  PROCEND dfp$terminate_client;

?? TITLE := '    dfp$terminate_server', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$terminate_server
    (    mainframe_name: pmt$mainframe_id;
         users_wait_on_term_specified: boolean;
         users_wait_on_terminated: boolean;
     VAR status: ost$status);

    VAR
      highest_server_lifetime: dft$server_lifetime,
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
      server_to_client: boolean,
      server_birthdate: integer,
      server_lifetime: dft$lifetime,
      server_state: dft$server_state;

    dfp$verify_system_administrator ('TERMINATE_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server_to_client := FALSE;
    pmp$convert_mainframe_to_binary (mainframe_name, mainframe_id, status);
    dfp$find_mainframe_id (mainframe_name, server_to_client, mainframe_found, p_queue_interface_table,
          p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF mainframe_found THEN

{ Queues exists

      IF users_wait_on_term_specified THEN
        p_cpu_queue^.queue_header.partner_status.users_wait_on_terminated_server := users_wait_on_terminated;
      IFEND;
      CASE p_cpu_queue^.queue_header.partner_status.server_state OF
      = dfc$terminated =
        IF p_cpu_queue^.queue_header.partner_status.verify_queue THEN

{ A poll task exists, let it do the termination.

          p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
          p_cpu_queue^.queue_header.partner_status.terminate_partner := TRUE;
        ELSE

{ There is nothing to terminate. Allow the command anyway to allow
{ changing the users_wait_on_terminated parameter.

        IFEND;
      = dfc$inactive =
        p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
        p_cpu_queue^.queue_header.partner_status.terminate_partner := TRUE;
      = dfc$active, dfc$recovering, dfc$deactivated =

{ A poll task exists, let it do the termination

        p_cpu_queue^.queue_header.partner_status.terminate_partner := TRUE;
      = dfc$awaiting_recovery =
        IF p_cpu_queue^.queue_header.partner_status.verify_queue THEN

{ A poll task exists, let it do the termination.

          p_cpu_queue^.queue_header.partner_status.terminate_partner := TRUE;
          p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
        ELSE

{ There is no poll task or it has not responded to a previous termination
{  but still termination is required.
{ The PP should already be unloaded and all requests should have been
{ terminated from the queues.

          p_cpu_queue^.queue_header.partner_status.terminate_partner := FALSE;
          p_cpu_queue^.queue_header.partner_status.deactivate_complete := FALSE;
          p_cpu_queue^.queue_header.partner_status.server_state := dfc$terminated;
          dfp$change_family_server_state (dfc$terminated, mainframe_id);
          dfp$free_image_file (mainframe_id, status);
          dfp$set_terminated_access_state (mainframe_id);
          dfp$terminate_server_files (mainframe_id, status);
        IFEND;
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, mainframe_name, status);
      CASEND;
    ELSE

{ Check served family table

      dfp$get_highest_sf_lifetime (mainframe_id, mainframe_found, server_state, server_lifetime,
            server_birthdate);
      IF mainframe_found AND (server_state <> dfc$deleted) THEN
        dfp$free_image_file (mainframe_id, status);
        dfp$change_family_server_state (dfc$terminated, mainframe_id);
      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, mainframe_name, status);
      IFEND;
    IFEND;

  PROCEND dfp$terminate_server;
?? TITLE := '    dfp$timeout_client', EJECT ??
{
{   This procedure is provided for testing.
{ This forces a timeout of the server-to-client connection.
{ This is done by setting the timeout_partner boolean in the cpu queue header.
{

  PROCEDURE [XDCL, #GATE] dfp$timeout_client
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      mainframe_found: boolean,
      mainframe_id: pmt$binary_mainframe_id,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index;

    dfp$verify_system_administrator ('TIMEOUT_CLIENT', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$find_mainframe_id (mainframe_name, { server_to_client } TRUE, mainframe_found,
          p_queue_interface_table, p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF mainframe_found THEN

      CASE p_cpu_queue^.queue_header.partner_status.server_state OF
      = dfc$awaiting_recovery, dfc$terminated =
        IF NOT p_cpu_queue^.queue_header.partner_status.verify_queue THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$client_not_active, mainframe_name, status);
          RETURN;
        IFEND;
        p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
        p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
     = dfc$inactive =
        p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
        p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;

      = dfc$recovering, dfc$deactivated, dfc$active =
        p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;

      ELSE
      CASEND;
    ELSE { No queue exists
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, mainframe_name, status);
    IFEND;

  PROCEND dfp$timeout_client;
?? TITLE := '    dfp$timeout_server', EJECT ??
{
{   This procedure is provided for testing.
{ This forces a timeout of the client-to-server connection.
{ This is done by setting the timeout_partner boolean in the cpu queue header.
{ If the server is awaiting recovery but not all pages have been saved then
{ another attempt is made to save the pages.
{

  PROCEDURE [XDCL, #GATE] dfp$timeout_server
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      mainframe_found: boolean,
      mainframe_id: pmt$binary_mainframe_id,
      p_cpu_queue: ^dft$cpu_queue,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index;

    dfp$verify_system_administrator ('TIMEOUT_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$find_mainframe_id (mainframe_name, { server_to_client } FALSE, mainframe_found,
          p_queue_interface_table, p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF mainframe_found THEN

      CASE p_cpu_queue^.queue_header.partner_status.server_state OF
      = dfc$terminated, dfc$inactive, dfc$awaiting_recovery =
        IF p_cpu_queue^.queue_header.partner_status.verify_queue THEN
          p_cpu_queue^.queue_header.partner_status.verify_queue := FALSE;
          p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
        ELSEIF (p_cpu_queue^.queue_header.partner_status.server_state = dfc$awaiting_recovery) AND
           (NOT p_cpu_queue^.queue_header.partner_status.server_pages_saved) THEN
           pmp$convert_mainframe_to_binary (mainframe_name, mainframe_id, status);
           display (' Timeout server files');
           dfp$timeout_server_files (mainframe_id, status);
           p_cpu_queue^.queue_header.partner_status.server_pages_saved := status.normal;
        ELSEIF (p_cpu_queue^.queue_header.partner_status.server_state = dfc$inactive) THEN
          p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;
        ELSE
          osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_active, mainframe_name, status);
          RETURN;
        IFEND;

      = dfc$recovering, dfc$deactivated, dfc$active =
        p_cpu_queue^.queue_header.partner_status.timeout_partner := TRUE;

      ELSE
      CASEND;
    ELSE { No queue exists
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, mainframe_name, status);
    IFEND;

  PROCEND dfp$timeout_server;

?? TITLE := '  display_client_or_server', EJECT ??

  PROCEDURE display_client_or_server
    (    mainframe_name: pmt$mainframe_id;
         display_client: boolean;
         output_file_fid: amt$file_identifier;
         page_width: amt$page_width;
     VAR status: ost$status);

    CONST
      client = 'CLIENT',
      server = 'SERVER';

    VAR
      activation_date_time: ost$date_time,
      activation_date: ost$date,
      activation_time: ost$time,
      display_object: string (6),
      display_timeout_interval: integer,
      mainframe_found: boolean,
      outline: outline_string_type,
      p_cpu_queue: ^dft$cpu_queue,
      p_driver_queue_header: ^dft$driver_queue_header,
      p_esm_base_addresses: ^dft$esm_base_addresses,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_queue_interface_table: ^dft$queue_interface_table,
      queue_index: dft$queue_index,
      server_to_client: boolean;

    IF display_client THEN
      server_to_client := TRUE;
      dfp$find_mainframe_id (mainframe_name, server_to_client, mainframe_found, p_queue_interface_table,
            p_cpu_queue, queue_index, p_q_interface_directory_entry);
      IF NOT mainframe_found THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, mainframe_name, status);
        RETURN;
      IFEND;
      display_object := client;

    ELSE
      server_to_client := FALSE;
      dfp$find_mainframe_id (mainframe_name, server_to_client, mainframe_found, p_queue_interface_table,
            p_cpu_queue, queue_index, p_q_interface_directory_entry);
      IF NOT mainframe_found THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, mainframe_name, status);
        RETURN;
      IFEND;
      display_object := server;
    IFEND;

    p_esm_base_addresses := ^p_queue_interface_table^.esm_base_addresses;
    p_driver_queue_header := ^p_queue_interface_table^.queue_directory.
          driver_queue_pva_directory [queue_index].p_driver_queue^.queue_header;
    start_line (' --FILE SERVER Mainframe ', outline);
    add_to_line (output_file_fid, page_width, mainframe_name, outline);
    add_to_line (output_file_fid, page_width, ' Configuration Display--', outline);
    flush_line (output_file_fid, outline);

    start_line ('       Mainframe is.....................', outline);
    add_to_line (output_file_fid, page_width, display_object, outline);
    flush_line (output_file_fid, outline);

    IF NOT display_client THEN
      start_line ('       Leveler Status...................', outline);
      CASE p_cpu_queue^.queue_header.leveler_status.leveler_state OF
      = jmc$jl_leveler_enabled =
        add_to_line (output_file_fid, page_width, 'ENABLED', outline);
      = jmc$jl_leveler_disabled =
        add_to_line (output_file_fid, page_width, 'DISABLED', outline);
      = jmc$jl_server_profile_mismatch =
        add_to_line (output_file_fid, page_width, 'PROFILE MISMATCH', outline);
      ELSE
        add_to_line (output_file_fid, page_width, 'UNKNOWN', outline);
      CASEND;
      flush_line (output_file_fid, outline);
    IFEND;

    start_line ('       Server State.....................', outline);
    add_to_line (output_file_fid, page_width, dfv$server_state_string
        [p_cpu_queue^.queue_header.partner_status.server_state], outline);
    CASE p_cpu_queue^.queue_header.partner_status.server_state OF
    = dfc$awaiting_recovery, dfc$inactive, dfc$terminated =
      IF p_cpu_queue^.queue_header.partner_status.verify_queue THEN
        add_to_line (output_file_fid, page_width, ' ACTIVATING ', outline);
      IFEND;
      IF (display_object = server) AND
          (p_cpu_queue^.queue_header.partner_status.server_state = dfc$awaiting_recovery)
          AND (NOT p_cpu_queue^.queue_header.partner_status.server_pages_saved) THEN
        add_to_line (output_file_fid, page_width, ' Pages NOT saved ', outline);
      IFEND;
      IF (p_cpu_queue^.queue_header.partner_status.server_state = dfc$terminated) AND
         (display_object = server) THEN
        IF p_cpu_queue^.queue_header.partner_status.users_wait_on_terminated_server THEN
          add_to_line (output_file_fid, page_width, '    Users wait on terminated ', outline);
        ELSE
          add_to_line (output_file_fid, page_width, '    Users DO NOT wait on terminated ', outline);
        IFEND;
      IFEND;
    ELSE
    CASEND;
    flush_line (output_file_fid, outline);

    start_line ('       Server Lifetime..................', outline);
    add_integer_to_line (output_file_fid, page_width, p_cpu_queue^.queue_header.server_lifetime, outline);
    flush_line (output_file_fid, outline);
    start_line ('       Server Birthdate.................', outline);
    add_integer_to_line (output_file_fid, page_width, p_cpu_queue^.queue_header.server_birthdate, outline);
    IF (display_object = server) AND
       (p_cpu_queue^.queue_header.server_birthdate <> 0) THEN
       add_to_line (output_file_fid, page_width, '  ', outline);
       pmp$get_date_time_at_timestamp (p_cpu_queue^.queue_header.server_birthdate,
            pmc$use_system_local_time, activation_date_time,  status);
       pmp$format_compact_date (activation_date_time, osc$month_date,
           activation_date, status);
       add_to_line (output_file_fid, page_width, activation_date.month, outline);
       pmp$format_compact_time (activation_date_time, osc$ampm_time, activation_time, status);
       add_to_line (output_file_fid, page_width, activation_time.ampm, outline);
    IFEND;
    flush_line (output_file_fid, outline);

    IF dfv$file_server_debug_enabled THEN
      start_line ('       Own Queue Index..................', outline);
      add_integer_to_line (output_file_fid, page_width, queue_index, outline);
      flush_line (output_file_fid, outline);
      start_line ('       ', outline);
      add_to_line (output_file_fid, page_width, display_object, outline);
      add_to_line (output_file_fid, page_width, ' Queue Index...............', outline);
      add_integer_to_line (output_file_fid, page_width, p_driver_queue_header^.connection_descriptor.
            destination.queue_index, outline);
      flush_line (output_file_fid, outline);
    IFEND;

    start_line ('       Number of Monitor Queue Entries..', outline);
    add_integer_to_line (output_file_fid, page_width, p_cpu_queue^.queue_header.
          number_of_monitor_queue_entries, outline);
    flush_line (output_file_fid, outline);
    start_line ('       Number of Task Queue Entries.....', outline);
    add_integer_to_line (output_file_fid, page_width, p_cpu_queue^.queue_header.number_of_task_queue_entries,
          outline);
    flush_line (output_file_fid, outline);

    start_line ('       Connection Type..................', outline);
    CASE p_cpu_queue^.queue_header.connection_type OF
    = dfc$cdcnet_connection =
      add_to_line (output_file_fid, page_width, 'CDCNET', outline);
      flush_line (output_file_fid, outline);
    = dfc$mock_connection =
      add_to_line (output_file_fid, page_width, 'MOCK', outline);
      flush_line (output_file_fid, outline);
    = dfc$esm_connection =
      add_to_line (output_file_fid, page_width, 'STORNET', outline);
      flush_line (output_file_fid, outline);

      start_line ('       Own Send Element Name............', outline);
      add_to_line (output_file_fid, page_width, p_q_interface_directory_entry^.element_name, outline);
      flush_line (output_file_fid, outline);
      start_line ('       Own ID/', outline);
      add_to_line (output_file_fid, page_width, display_object, outline);
      add_to_line (output_file_fid, page_width, ' ID Number..........', outline);
      add_integer_to_line (output_file_fid, page_width, p_driver_queue_header^.connection_descriptor.source.
            id_number, outline);
      add_to_line (output_file_fid, page_width, '/', outline);
      add_integer_to_line (output_file_fid, page_width, p_driver_queue_header^.connection_descriptor.
            destination.id_number, outline);
      flush_line (output_file_fid, outline);
      start_line ('       Send_Channel Name................', outline);
      add_to_line (output_file_fid, page_width, p_q_interface_directory_entry^.send_channel.channel_name,
            outline);
      flush_line (output_file_fid, outline);
      start_line ('       Send_Channel IOU.................', outline);
      add_to_line (output_file_fid, page_width, p_q_interface_directory_entry^.send_channel.iou_name,
            outline);
      flush_line (output_file_fid, outline);
      start_line ('       Receive_Channel Name.............', outline);
      add_to_line (output_file_fid, page_width, p_q_interface_directory_entry^.receive_channel.channel_name,
            outline);
      flush_line (output_file_fid, outline);
      start_line ('       Receive_Channel IOU..............', outline);
      add_to_line (output_file_fid, page_width, p_q_interface_directory_entry^.receive_channel.iou_name,
            outline);
      flush_line (output_file_fid, outline);
      start_line ('       DMA On Send/Receive Channel......', outline);
      add_boolean_to_line (output_file_fid, page_width, p_queue_interface_table^.queue_directory.dma_adapter.
            use_on_send_channel, {input/output} outline);
      add_to_line (output_file_fid, page_width, '/', outline);
      add_boolean_to_line (output_file_fid, page_width, p_queue_interface_table^.queue_directory.dma_adapter.
            use_on_recv_channel, {input/output} outline);
      flush_line (output_file_fid, outline);

    ELSE
      ;
    CASEND;
    display_timeout_interval := (p_cpu_queue^.queue_header.timeout_interval DIV 1000000);
    start_line ('       Timeout Interval.................', outline);
    add_integer_to_line (output_file_fid, page_width, display_timeout_interval, outline);
    add_to_line (output_file_fid, page_width, ' seconds', outline);
    flush_line (output_file_fid, outline);
    start_line ('       Maximum Request Timeout Count....', outline);
    add_integer_to_line (output_file_fid, page_width, p_cpu_queue^.queue_header.maximum_request_timeout_count,
          outline);
    flush_line (output_file_fid, outline);
    start_line ('       Maximum Retransmission Count.....', outline);
    add_integer_to_line (output_file_fid, page_width, p_cpu_queue^.queue_header.maximum_retransmission_count,
          outline);
    flush_line (output_file_fid, outline);

  PROCEND display_client_or_server;
?? TITLE := '  display_short_client_or_server', EJECT ??

  PROCEDURE display_short_client_or_server
    (    mainframe_name: pmt$mainframe_id;
         display_client: boolean;
         server_state: dft$server_state;
         server_lifetime: dft$lifetime;
         server_birthdate: integer;
         output_file_fid: amt$file_identifier;
         page_width: amt$page_width;
     VAR status: ost$status);

    CONST
      client = 'CLIENT',
      server = 'SERVER';

    VAR
      display_object: string (6),
      display_timeout_interval: integer,
      outline: outline_string_type;

    IF display_client THEN
      display_object := client;

    ELSE
      display_object := server;
    IFEND;

    start_line (' --FILE SERVER Mainframe ', outline);
    add_to_line (output_file_fid, page_width, mainframe_name, outline);
    flush_line (output_file_fid, outline);

    start_line ('       Mainframe is.....................', outline);
    add_to_line (output_file_fid, page_width, display_object, outline);
    flush_line (output_file_fid, outline);

    start_line ('       Server State.....................', outline);
    add_to_line (output_file_fid, page_width, dfv$server_state_string [server_state],
         outline);
    flush_line (output_file_fid, outline);

    start_line ('       Server Lifetime..................', outline);
    add_integer_to_line (output_file_fid, page_width, server_lifetime, outline);
    flush_line (output_file_fid, outline);

    start_line ('       Server Birthdate ................', outline);
    add_integer_to_line (output_file_fid, page_width, server_birthdate, outline);
    flush_line (output_file_fid, outline);

    start_line ('       AWAITING QUEUE DEFINITION .......', outline);
    flush_line (output_file_fid, outline);

  PROCEND display_short_client_or_server;

?? TITLE := '  add_boolean_to_line', EJECT ??

  PROCEDURE [INLINE] add_boolean_to_line
    (    output_file_fid: amt$file_identifier;
         page_width: amt$page_width;
         bool: boolean;
     VAR {input/output} outline: outline_string_type);

    IF bool THEN
      add_to_line (output_file_fid, page_width, 'TRUE', outline);
    ELSE
      add_to_line (output_file_fid, page_width, 'FALSE', outline);
    IFEND;
  PROCEND add_boolean_to_line;

?? SKIP := 4 ??
?? TITLE := '  add_hex_to_line' ??

  PROCEDURE [INLINE] add_hex_to_line
    (    output_file_fid: amt$file_identifier;
         page_width: amt$page_width;
         int: integer;
         add_radix: boolean;
     VAR outline: outline_string_type);

    VAR
      ignore_status: ost$status,
      int_string: ost$string;

    clp$convert_integer_to_string (int, 16, FALSE, int_string, ignore_status);
    add_to_line (output_file_fid, page_width, int_string.value (1, int_string.size), outline);
    IF add_radix THEN
      add_to_line (output_file_fid, page_width, '(16)', outline);
    IFEND;
  PROCEND add_hex_to_line;

?? SKIP := 4 ??
?? TITLE := '  add_integer_to_line' ??

  PROCEDURE [INLINE] add_integer_to_line
    (    output_file_fid: amt$file_identifier;
         page_width: amt$page_width;
         int: integer;
     VAR outline: outline_string_type);

    VAR
      ignore_status: ost$status,
      int_string: ost$string;

    clp$convert_integer_to_string (int, 10, FALSE, int_string, ignore_status);
    add_to_line (output_file_fid, page_width, int_string.value (1, int_string.size), outline);
  PROCEND add_integer_to_line;

?? TITLE := '  add_to_line', EJECT ??

  PROCEDURE add_to_line
    (    output_file_fid: amt$file_identifier;
         page_width: amt$page_width;
         str: string ( * );
     VAR outline: outline_string_type);

    VAR
      size: 0 .. osc$max_string_size + 1;

    size := STRLENGTH (str);
    IF (outline.size + size) <= page_width THEN
      outline.value (outline.size + 1, size) := str;
      outline.size := outline.size + size;
      RETURN;
    IFEND;

    flush_line (output_file_fid, outline);
    start_line ('      ', outline);
    outline.value (outline.size + 1, size) := str;
    outline.size := outline.size + size;

  PROCEND add_to_line;

?? TITLE := '  flush_line ', EJECT ??

  PROCEDURE [INLINE] flush_line
    (    output_file_fid: amt$file_identifier;
     VAR outline: outline_string_type);

    IF outline.size > 0 THEN
      put_line (output_file_fid, outline);
    IFEND;

  PROCEND flush_line;

?? SKIP := 4 ??
?? TITLE := '  put_line' ??

  PROCEDURE put_line
    (    output_file_fid: amt$file_identifier;
     VAR outline: outline_string_type);

    VAR
      status: ost$status,
      ignore_byte_address: amt$file_byte_address;

    amp$put_next (output_file_fid, ^outline.value, outline.size, ignore_byte_address, status);
    IF NOT status.normal THEN

{???????????????????

    IFEND;
    outline.size := 0;
    outline.value := '';

  PROCEND put_line;

?? SKIP := 4 ??
?? TITLE := '  start_line' ??

  PROCEDURE [INLINE] start_line
    (    str: string ( * );
     VAR outline: outline_string_type);

    outline.value := str;
    outline.size := STRLENGTH (str);

  PROCEND start_line;

MODEND dfm$r3_manage_file_server;
*DECK DECK=DFM$RAMBO2 EXPAND=TRUE
PROCEDURE  rambo2 (
  number_of_jobs, noj   : integer = 20
  number_of_passes, nop : integer = 20
  family, f             : name = testing
  user, u               : name = $system
  shared, s             : boolean = false
  status)

  path = ':' // $string(family) // '.' //$string(user) // '.test_'
  shared_access = $string(shared)
  IF shared THEN
   open_mode = 'amp$open'
  ELSE
   open_mode = 'fsp$open_file'
  IFEND

  FOR i = 1 TO number_of_jobs DO
    job_number_string = $strrep(i)
    file_string = path // job_number_string
    JOB sm='?'   jn =$name('RAMBO'//$strrep(i))
      system_operator_utility
      crev ign k=status
      crev unq k=string v=$unique
      copf $system.osf$builtin_library $local.built  status=ign
      setcl a=$local.built status=ign
      setcl a=$user.dfcc.object.maintenance.osf$builtin_library status=ign
      FOR j1 = 1 TO ?$strrep(number_of_passes)? DO
        delf ?file_string? status=ign
        IF ?shared_access? THEN
          create_file ?file_string?
          detach_file ?file_string?
          attach_file ?file_string? am=all sm=all
        IFEND
        dfp$ptu ?file_string? w m=n rfn=$fname(unq) s=?job_number_string?*100000  open=?open_mode?
        dfp$ptu ?file_string? r m=n rfn=$fname(unq) open=?open_mode?
        dfp$ptu ?file_string? w m=s rfn=$fname(unq) s=?job_number_string?*100000  open=?open_mode?
        dfp$ptu ?file_string? r m=s rfn=$fname(unq) open=?open_mode?
      FOREND
      quit " sou "
    JOBEND
  FOREND

PROCEND rambo2
*DECK DECK=DFM$RAMBO4 EXPAND=TRUE
PROCEDURE dfm$rambo4, rambo4 (
  number_of_jobs, noj: integer = 20
  repeat_count, rc: integer = 20
  family, f: name = testing
  application, a: name = doit_app
  send_size, sz: integer = 200
  receive_size, rs: integer = 2000
  use_data_area, uda: key
      (send, s)
      (receive, r)
      (both, b)
      (none, n)
    keyend = both
  remote_procedure_name, rpn, rn: program_name = dfp$server_test_app_support
  library, l: file = $system.osf$builtin_library
  status)

  FOR i = 1 TO number_of_jobs DO
    JOB sm='?' jn=$name('RAMBOIV'//$strrep(i))
      crev ign k=status
      crev unq k=string v=$unique
      exet sp=dfp$client_test_app_support library=?library? ..
            p='family_name=?family? send_size=?send_size? receive_size=?receive_size? ..
            use_data_area=?use_data_area? remote_procedure_name=?remote_procedure_name? ..
            application_name=?application? repeat_count=?repeat_count?'
    JOBEND
  FOREND

PROCEND dfm$rambo4
*DECK DECK=DFM$RAMBO5 EXPAND=TRUE
PROCEDURE dfm$rambo5, rambo5 (
  number_of_jobs, noj: integer = 20
  repeat_count, rc: integer = 20
  family, f: name = testing
  application, a: name = doit_app
  send_size, sz: integer = 200
  receive_size, rs: integer = 2000
  use_data_area, uda: key
      (send, s)
      (receive, r)
      (both, b)
      (none, n)
    keyend = both
  remote_procedure_name, rpn, rn: program_name = dfp$server_test_app_support
  library, l: file
  status)

  FOR i = 1 TO number_of_jobs DO
    JOB sm='?' jn=$name('RAMBOv'//$strrep(i))
      crev ign k=status
      crev unq k=string v=$unique
      exet sp=dfp$client_test_app_sup_r3 ..
            p='family_name=?family? send_size=?send_size? receive_size=?receive_size? ..
            use_data_area=?use_data_area? remote_procedure_name=?remote_procedure_name? ..
            application_name=?application? repeat_count=?repeat_count?'
    JOBEND
  FOREND

PROCEND dfm$rambo5
*DECK DECK=DFM$RECIT EXPAND=TRUE
PROC dfm$recit, recit (served_family, sf:  name= testing
 pf_number, pn: integer 0 .. 1000000 = 2
 establish_condition_handler, ech: boolean = true
 save_print, sp: boolean = false
 status)

 " This is just like the confidence test but uses record by record
 " copy - so that verificationof eoi may be performed
 " Each copy_file between record types must do record by record get/put

  family = $string($value(served_family))
  handler = $strrep($value(establish_condition_handler))
  save_output = $strrep($value(save_print))
  FOR i = 1 to $value(pf_number) DO
    JOB jn =$name('RECTEST'//$strrep(i))   sm ='?'
       IF ?handler? THEN
         WHEN any_fault do
           reqoa ' RECTEST?$strrep(i)? failed  '//$condition_name(osv$status.condition)
           display_value osv$status
           logout
         WHENEND
       IFEND

      " Clean up - just in case
      " Enter system_operator_utility to get system privilege
      system_operator_utility
      crev ignore status
      delete_file  $fname(':?family?.$system.urec?$strrep(i)?') status=ignore
      delete_file  $fname(':?family?.$system.vrec?$strrep(i)?') status=ignore

      " test allocate
      " $system.scu.bound_product starts out as u record
      set_file_attributes $fname(':?family?.$system.vrec?$strrep(i)?') rt=v
      copy_file $system.scu.bound_product ..
         $fname(':?family?.$system.vrec?$strrep(i)?')
      " test write
      copy_file $system.scu.bound_product ..
         $fname(':?family?.$system.vrec?$strrep(i)?')
      " test permanent files
      crefp $fname(':?family?.$system.vrec?$strrep(i)?') g=public
      disce $fname(':?family?.$system.vrec?$strrep(i)?') do=c
      " test read - write
      set_file_attributes $fname(':?family?.$system.urec?$strrep(i)?') rt=u
      copy_file $fname(':?family?.$system.vrec?$strrep(i)?')  ..
           $fname(':?family?.$system.urec?$strrep(i)?')
      disce $fname(':?family?.$system.urec?$strrep(i)?') do=c
      compare_file $system.scu.bound_product ..
           $fname(':?family?.$system.urec?$strrep(i)?')
      delete_file  $fname(':?family?.$system.vrec?$strrep(i)?')
      delete_file  $fname(':?family?.$system.urec?$strrep(i)?')
      quit " system_operator_utility "
       IF NOT ?save_output? THEN
         terp output
      IFEND
    JOBEND
  FOREND

PROCEND dfm$recit

*DECK DECK=DFM$RECOVERY_CONTROL EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := ' NOS/VE File Server: recovery_control ', EJECT ??
MODULE dfm$recovery_control;

{
{  This module contains those processes responsible for controlling the
{ sequence of events on a continuation deadstart so that file server recovery
{ will occur correctly.
{ The sequence on continuation deadstart is as follows:
{        phase2_normal - osm$Job_template_initialization
{          recover_mainframe
{             dmp$recover_mainframe - dmm$recover_mainframe
{             DFP$RECOVER_SERVER_MAINFRAMES
{               dfp$rebuild_served_family_table
{               for all servers in served family table
{                  dfp$save_server_image
{                    for all of this servers files in old system file table
{                      copy pages from the old image to the server image file
{          * POINT of commitment
{          DFP$RECOVER_CLIENT_MAINFRAMES
{            dfp$rebuild_client_mainframes
{              for all client mainframes
{                for all client jobs using this server
{                  re-attach all permanent files
{            dfp$flush_served_family_table
{
{ NOTE:
{    dfv$family_access_enabled is used to prevent permanent file access
{    to the served family till later in deadstart.  This is really a
{    minor kludge so that in loopback the process that determines
{    valid families will work despite this rebuilt process.
{    This is set to FALSE in dfp$recover_server_mainframes
{    This is set to TRUE in dfp$recover_client_mainframes.

?? PUSH (LISTEXT := ON) ??
*copyc clp$operator_intervention
*copyc dfc$esm_allocation_constants
*copyc dfe$error_condition_codes
*copyc dfi$display
*copyc dfi$log_display
*copyc dfp$change_family_server_state
*copyc dfp$delete_client_mainframes
*copyc dfp$flush_served_family_table
*copyc dfp$free_image_file
*copyc dfp$get_server_mainframe_list
*copyc dfp$purge_all_image_files
*copyc dfp$purge_preserved_family_file
*copyc dfp$rebuild_client_mainframes
*copyc dfp$rebuild_served_family_table
*copyc dfp$save_server_image
*copyc dfv$family_access_enabled
*copyc dfv$job_recovery_enabled
*copyc osv$emergency_intervention
*copyc pmp$convert_binary_mainframe_id
*copyc pmp$execute
*copyc syv$job_recovery_option
?? POP ??

?? NEWTITLE := '  Client: [XDCL] dfp$recover_server_mainframes ', EJECT ??

{
{   This procedure is responsible for saving the pages for all server mainframes
{ This procedure executes before the point of commitment.
{ The served family table is rebuilt first in order to obtain a list of server
{ mainframes and also so that if saving of the server pages does not work, the
{ served family table is used to mark the server as terminated to prevent
{ subsequent recovery.
{

  PROCEDURE [XDCL] dfp$recover_server_mainframes
    (VAR status: ost$status);

    VAR
      mainframe_name: pmt$mainframe_id,
      p_server_mainframes: ^dft$partner_mainframe_list,
      server: dft$partner_mainframe_count,
      server_count: dft$partner_mainframe_count;

    IF osv$emergency_intervention THEN
      display (' Emergency intervention in dfp$recover_server_mainframes ');
      clp$operator_intervention (status);
    IFEND;

    IF dfv$job_recovery_enabled AND (syv$job_recovery_option = syc$jre_enabled) THEN
      log_display ($pmt$ascii_logset [pmc$system_log], 'Recover server mainframes ');

      dfp$rebuild_served_family_table (status);

      dfv$family_access_enabled := FALSE;
      IF NOT status.normal THEN
        display (' Unable to rebuild served families ');
        log_display ($pmt$ascii_logset [pmc$system_log], ' Unable to rebuild served families ');
        display_status (status);
        log_display_status ($pmt$ascii_logset [pmc$system_log], TRUE, status);
        RETURN;
      IFEND;

      PUSH p_server_mainframes: [1 .. dfc$max_number_of_mainframes];
      dfp$get_server_mainframe_list ($dft$server_states [dfc$active, dfc$inactive, dfc$awaiting_recovery,
            dfc$deactivated, dfc$recovering], p_server_mainframes^, server_count);

    /save_servers_image/
      FOR server := 1 TO server_count DO
        pmp$convert_binary_mainframe_id (p_server_mainframes^ [server].mainframe_id, mainframe_name, status);
        dfp$save_server_image (mainframe_name, status);
        IF NOT status.normal THEN
          display (mainframe_name);
          log_display ($pmt$ascii_logset [pmc$system_log], mainframe_name);
          display_status (status);
          log_display_status ($pmt$ascii_logset [pmc$system_log], TRUE, status);
          IF status.condition = dfe$no_space_for_server_pages THEN
            display (' Insufficient mass storage space for server pages ');
            log_display ($pmt$ascii_logset [pmc$system_log],
                  ' Insufficient mass storage space for server pages ');
          IFEND;
          dfp$change_family_server_state (dfc$terminated, p_server_mainframes^ [server].mainframe_id);
          dfp$free_image_file (p_server_mainframes^ [server].mainframe_id, status);
        IFEND;
      FOREND /save_servers_image/;

      log_display ($pmt$ascii_logset [pmc$system_log], 'Recover server mainframes complete');
    ELSE
      display (' File server recovery disabled ');
      log_display ($pmt$ascii_logset [pmc$system_log], ' File server recovery disabled ');
    IFEND;

  PROCEND dfp$recover_server_mainframes;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL] dfp$recover_client_mainframes ', EJECT ??

{
{    This procedure is primarily involved with recovery of the client mainframes.
{  This means that all of the client mainframe files are rebuilt and the
{  permanent files are re-attached on behalf of each user job on the client.
{  This process may only be called after the point of commitment, because
{  catalogs are updated.
{    This procedure is also involved with completing any process involved
{  with recovering server mainframes. This involves flushing any changes
{  to the served family table that were made prior to the point of
{  commitment by the process dfp$recover_server_mainframes.
{    If recovery is disabled then the server image files, the client mainframe
{  files and the preserved family table are all deleted.
{

  PROCEDURE [XDCL] dfp$recover_client_mainframes
    (VAR status: ost$status);

    IF osv$emergency_intervention THEN
      display (' Emergency intervention in recover_client_mainframes ');
      clp$operator_intervention (status);
    IFEND;

    IF dfv$job_recovery_enabled AND (syv$job_recovery_option = syc$jre_enabled) THEN
      dfp$rebuild_client_mainframes;
      dfp$flush_served_family_table (status);
    ELSE
      dfp$purge_all_image_files;
      dfp$delete_client_mainframes;
      dfp$purge_preserved_family_file (status);
    IFEND;
    status.normal := TRUE;
    dfv$family_access_enabled := TRUE;

  PROCEND dfp$recover_client_mainframes;
?? OLDTITLE, OLDTITLE ??
MODEND dfm$recovery_control;

*DECK DECK=DFM$RECOVERY_SERVICES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File Server: Recovery Services' ??
MODULE dfm$recovery_services;
?? NEWTITLE := '  Global Declarations Reference by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfc$partially_rebuilt_fde_eoi
*copyc dfc$test_jr_constants
*copyc dfe$mm_recovery_errors
*copyc dft$image_file_id
*copyc dft$server_lifetime
*copyc dft$served_family_table_index
*copyc dft$server_state
*copyc dft$server_descriptor
*copyc gfc$constants
*copyc gft$file_descriptor_entry
*copyc gft$system_file_identifier
*copyc mmt$rb_ring1_server_seg_request
*copyc osd$integer_limits
*copyc ost$status
?? POP ??
*copyc dfi$core_log_display
*copyc dfp$expand_image_file
*copyc dfp$fetch_served_family_info
*copyc dfp$fetch_server_state
*copyc dfp$get_next_image_block
*copyc dfp$get_served_file_desc_p
*copyc dfp$uncomplement_gfn
*copyc dpp$put_critical_message
*copyc gfp$get_fde_p
*copyc gfp$lock_fde
*copyc gfp$scan_all_fdes
*copyc gfp$unlock_fde_p
*copyc i#call_monitor
*copyc mmp$mm_move_mod_server_page
*copyc mme$condition_codes
*copyc osp$convert_to_real_model_num
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osv$page_size
*copyc pmp$delay
*copyc syp$core_hang_if_system_jrt_set
*copyc dfv$file_server_debug_enabled
*copyc syv$debug_job_recovery
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL, #GATE] dfp$deactivate_server_files', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$deactivate_server_files
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

    CONST
      one_second = 1000;

    VAR
      family_server_state: dft$server_state,
      files_attempted: ost$non_negative_integers,
      file_count: ost$non_negative_integers,
      files_not_deactivated: ost$non_negative_integers,
      ignore_status: ost$status,
      p_fde: gft$file_desc_entry_p,
      pages_not_deleted: integer,
      pass_number: 0 .. 5,
      real_model_number: ost$processor_model_number,
      scan_control: gft$scan_all_fdes_state,
      server_descriptor_p: dft$server_descriptor_p,
      sfid: gft$system_file_identifier,
      st: string (100),
      stl: integer;


    pass_number := 0;

    REPEAT {until_all_deactivated}
      file_count := 0;
      files_attempted := 0;
      files_not_deactivated := 0;
      sfid.residence := gfc$tr_system;

      gfp$scan_all_fdes (gfc$tr_system, scan_control, p_fde);
      WHILE p_fde <> NIL DO

      /deactivate_server_file_block/
        BEGIN

          IF p_fde^.media <> gfc$fm_served_file THEN
            EXIT /deactivate_server_file_block/;
          IFEND;

          gfp$lock_fde (p_fde);

          dfp$get_served_file_desc_p (p_fde, server_descriptor_p);
          IF server_descriptor_p^.header.purged THEN
            gfp$unlock_fde_p (p_fde);
            EXIT /deactivate_server_file_block/;
          IFEND;

          IF p_fde^.media <> gfc$fm_served_file THEN
            gfp$unlock_fde_p (p_fde);
            EXIT /deactivate_server_file_block/;
          IFEND;

          dfp$get_served_file_desc_p (p_fde, server_descriptor_p);
          IF server_descriptor_p^.header.server_mainframe_id <> server_mainframe_id THEN
            gfp$unlock_fde_p (p_fde);
            EXIT /deactivate_server_file_block/;
          IFEND;

          IF (server_descriptor_p^.header.file_state = dfc$awaiting_recovery) OR
             (server_descriptor_p^.header.file_state = dfc$terminated) THEN
            gfp$unlock_fde_p (p_fde);
            EXIT /deactivate_server_file_block/;
          IFEND;

          dfp$fetch_server_state (server_descriptor_p, family_server_state);
          CASE family_server_state OF
          = dfc$terminated, dfc$deleted =

{ Family left over from a previous lifetime.

            gfp$unlock_fde_p (p_fde);
            EXIT /deactivate_server_file_block/;
          = dfc$deactivated =

{ Normal case.

          ELSE
            osp$convert_to_real_model_num (server_mainframe_id.model_number, real_model_number);
            STRINGREP (st, stl, 'Model', real_model_number, ', S/N', server_mainframe_id.serial_number: 16);
            osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated, st (1, stl), status);
            gfp$unlock_fde_p (p_fde);
            RETURN;
          CASEND;

          file_count := file_count + 1;

{ Now see if there are pages to deal with

          IF p_fde^.asti = 0 THEN
            gfp$unlock_fde_p (p_fde);
            EXIT /deactivate_server_file_block/;
          IFEND;

          IF p_fde^.attach_count = 0 THEN
            gfp$unlock_fde_p (p_fde);
            EXIT /deactivate_server_file_block/;
          IFEND;

          sfid.file_hash := p_fde^.file_hash;
          sfid.file_entry_index := (#OFFSET (p_fde) - gfc$fde_table_base) DIV gfc$fde_size;

{ The FDE is left locked during the monitor request (located in the procedure below) to prevent asynchronous
{ detachment/deletion of a server file during deactivation.  Monitor mode locks a different lock during its
{ processing.  The job mode lock will be cleared upon return to this procedure.

          files_attempted := files_attempted + 1;
          deact_term_server_file (sfid, mmc$ssr1_flush_delete_seg_sfid, pages_not_deleted, status);
          gfp$unlock_fde_p (p_fde);
          IF NOT status.normal THEN
            IF dfv$file_server_debug_enabled THEN
              STRINGREP (st, stl, ' File not deactivated: SFID = ', sfid.file_entry_index:#(16),
                    '(16), Pages = ', pages_not_deleted);
              core_log_display (st (1, stl));
              dpp$put_critical_message (st (1, stl), ignore_status);
            IFEND;
            IF status.condition = dfe$server_pages_not_deleted THEN
              files_not_deactivated := files_not_deactivated + 1;
              status.normal := TRUE;
            ELSE
              RETURN;
            IFEND;
          IFEND;
        END /deactivate_server_file_block/;

        gfp$scan_all_fdes (gfc$tr_null_residence, scan_control, p_fde);
      WHILEND;

{!    The following four lines should be moved out of the REPEAT/UNTIL when debugging is complete.

      STRINGREP (st, stl, file_count, ' Server_File(s) found - Attempted deactivation on ', files_attempted);
      dpp$put_critical_message (st (1, stl), ignore_status);
      core_log_display (st (1, stl));
      STRINGREP (st, stl, files_not_deactivated, ' Server_File(s) NOT deactivated');
      dpp$put_critical_message (st (1, stl), ignore_status);
      core_log_display (st (1, stl));

      pass_number := pass_number + 1;
      IF files_not_deactivated <> 0 THEN
        pmp$delay (10 * one_second, ignore_status);
      IFEND;

    UNTIL (files_not_deactivated = 0) OR (pass_number = 5);

    IF files_not_deactivated <> 0 THEN
      STRINGREP (st, stl, files_not_deactivated);
      osp$set_status_abnormal (dfc$file_server_id, dfe$server_file_not_deactivated, st (1, stl), status);
      RETURN;
    IFEND;

  PROCEND dfp$deactivate_server_files;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL, #GATE] dfp$terminate_server_files', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$terminate_server_files
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

    VAR
      family_server_state: dft$server_state,
      files_attempted: ost$non_negative_integers,
      file_count: ost$non_negative_integers,
      files_not_terminated: ost$non_negative_integers,
      ignore_status: ost$status,
      pages_not_deleted: integer,
      p_fde: gft$file_desc_entry_p,
      real_model_number: ost$processor_model_number,
      scan_control: gft$scan_all_fdes_state,
      server_descriptor_p: dft$server_descriptor_p,
      sfid: gft$system_file_identifier,
      st: string (100),
      stl: integer;


    REPEAT {until_all_terminated}
      files_attempted := 0;
      file_count := 0;
      files_not_terminated := 0;
      sfid.residence := gfc$tr_system;

      gfp$scan_all_fdes (gfc$tr_system, scan_control, p_fde);
      WHILE p_fde <> NIL DO

      /terminate_server_file_block/
        BEGIN

          IF p_fde^.media <> gfc$fm_served_file THEN
            EXIT /terminate_server_file_block/;
          IFEND;

          gfp$lock_fde (p_fde);

          dfp$get_served_file_desc_p (p_fde, server_descriptor_p);
          IF server_descriptor_p^.header.purged THEN
            gfp$unlock_fde_p (p_fde);
            EXIT /terminate_server_file_block/;
          IFEND;

          IF p_fde^.media <> gfc$fm_served_file THEN
            gfp$unlock_fde_p (p_fde);
            EXIT /terminate_server_file_block/;
          IFEND;

          IF server_descriptor_p^.header.server_mainframe_id <> server_mainframe_id THEN
            gfp$unlock_fde_p (p_fde);
            EXIT /terminate_server_file_block/;
          IFEND;

          dfp$fetch_server_state (server_descriptor_p, family_server_state);
          IF (family_server_state <> dfc$terminated) AND (family_server_state <> dfc$deleted) THEN
            osp$convert_to_real_model_num (server_mainframe_id.model_number, real_model_number);
            STRINGREP (st, stl, 'Model', real_model_number, ', S/N', server_mainframe_id.serial_number: 16);
            gfp$unlock_fde_p (p_fde);
            osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated, st (1, stl), status);
            osp$system_error ('Unexpected status: family_server_state <> dfc$terminated/awar', ^status);
          IFEND;

          server_descriptor_p^.header.file_state := dfc$terminated;
          file_count := file_count + 1;

{ Now check the state of the pages.

          IF p_fde^.asti = 0 THEN
            gfp$unlock_fde_p (p_fde);
            EXIT /terminate_server_file_block/;
          IFEND;

          IF p_fde^.attach_count = 0 THEN
            gfp$unlock_fde_p (p_fde);
            EXIT /terminate_server_file_block/;
          IFEND;

          sfid.file_hash := p_fde^.file_hash;
          sfid.file_entry_index := (#OFFSET (p_fde) - gfc$fde_table_base) DIV gfc$fde_size;

{ The FDE is left locked during the monitor request (located in the procedure below) to prevent asynchronous
{ detachment/deletion of a server file during termination.  Monitor mode locks a different lock during its
{ processing.  The job mode lock will be cleared upon return to this procedure.

          files_attempted := files_attempted + 1;
          deact_term_server_file (sfid, mmc$ssr1_free_delete_seg_sfid, pages_not_deleted, status);
          gfp$unlock_fde_p (p_fde);
          IF NOT status.normal THEN
            IF dfv$file_server_debug_enabled THEN
              STRINGREP (st, stl, ' File not terminated: SFID = ', sfid.file_entry_index:#(16),
                    '(16), Pages = ', pages_not_deleted);
              core_log_display (st (1, stl));
              dpp$put_critical_message (st (1, stl), ignore_status);
            IFEND;
            IF status.condition = dfe$server_pages_not_deleted THEN
              files_not_terminated := files_not_terminated + 1;
              status.normal := TRUE;
            ELSE
              RETURN;
            IFEND;
          IFEND;
        END /terminate_server_file_block/;

        gfp$scan_all_fdes (gfc$tr_null_residence, scan_control, p_fde);
      WHILEND;

{!    The following four lines should be moved out of the REPEAT/UNTIL when debugging is complete.

      STRINGREP (st, stl, file_count, ' Server_File(s) found - Attempted termination on ', files_attempted);
      dpp$put_critical_message (st (1, stl), ignore_status);
      core_log_display (st (1, stl));
      STRINGREP (st, stl, files_not_terminated, ' Server_File(s) NOT terminated');
      dpp$put_critical_message (st (1, stl), ignore_status);
      core_log_display (st (1, stl));

    UNTIL files_not_terminated = 0;

  PROCEND dfp$terminate_server_files;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL, #GATE] dfp$r1_timeout_server_files', EJECT ??
{
{   The purpose of this procedure is to 'timeout' server files for
{ a particular server.  This involves marking all the files as awaiting
{ recovery, saving all modified shared pages for the files, and removing
{ all read shared pages for the files.
{ The should closely follow the code in dfm$Manage_image with respect to
{ writing the server image file.

  PROCEDURE [XDCL, #GATE] dfp$r1_timeout_server_files
    (    server_mainframe_id: pmt$binary_mainframe_id;
         p_server_state : ^dft$server_state;
     VAR image_file_id: dft$image_file_id;
     VAR status: ost$status);

    VAR
      family_server_state: dft$server_state,
      file_count: ost$non_negative_integers,
      file_page_count: integer,
      ignore_status: ost$status,
      p_fde: gft$file_desc_entry_p,
      scan_control: gft$scan_all_fdes_state,
      server_descriptor_p: dft$server_descriptor_p,
      sfid: gft$system_file_identifier,
      space_available_for_image: boolean,
      space_available_status: ost$status,
      st: string (100),
      stl: integer,
      total_page_count: integer,
      total_pages_removed: integer;

    file_count := 0;
    total_page_count := 0;
    total_pages_removed :=  0;
    space_available_for_image := TRUE;
    sfid.residence := gfc$tr_system;

    gfp$scan_all_fdes (gfc$tr_system, scan_control, p_fde);
    WHILE p_fde <> NIL DO

    /timeout_server_file_block/
      BEGIN
        IF p_fde^.media <> gfc$fm_served_file THEN
          EXIT /timeout_server_file_block/;
        IFEND;

        IF p_server_state^ <> dfc$awaiting_recovery THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated, '', status);

{ State change has occurred to go to terminated. Get out of here.

          RETURN;
        IFEND;

        gfp$lock_fde (p_fde);

        dfp$get_served_file_desc_p (p_fde, server_descriptor_p);
        IF server_descriptor_p^.header.purged THEN
          gfp$unlock_fde_p (p_fde);
          EXIT /timeout_server_file_block/;
        IFEND;

        IF p_fde^.media <> gfc$fm_served_file THEN
          gfp$unlock_fde_p (p_fde);
          EXIT /timeout_server_file_block/;
        IFEND;

        IF server_descriptor_p^.header.server_mainframe_id <> server_mainframe_id THEN
          gfp$unlock_fde_p (p_fde);
          EXIT /timeout_server_file_block/;
        IFEND;

        dfp$fetch_server_state (server_descriptor_p, family_server_state);
        CASE family_server_state OF
        = dfc$terminated, dfc$deleted =

{ Family left over from a previous lifetime.

          gfp$unlock_fde_p (p_fde);
          EXIT /timeout_server_file_block/;
        = dfc$awaiting_recovery =
          ELSE
          gfp$unlock_fde_p (p_fde);
          osp$system_error ('Unexpected status: family_server_state <> awaiting_recovery', NIL);
          RETURN;
        CASEND;

        IF server_descriptor_p^.header.file_state = dfc$terminated THEN
          gfp$unlock_fde_p (p_fde);
          EXIT /timeout_server_file_block/;
        IFEND;

        file_count := file_count + 1;
        sfid.file_hash := p_fde^.file_hash;
        sfid.file_entry_index := (#OFFSET (p_fde) - gfc$fde_table_base) DIV gfc$fde_size;
        IF dfv$file_server_debug_enabled THEN
          STRINGREP (st, stl, ' File ', file_count, ' awaiting recovery - SFID = ',
                sfid.file_entry_index:#(16), '(16)');
          core_log_display (st (1, stl));
          dpp$put_critical_message (st (1, stl), ignore_status);
        IFEND;

        server_descriptor_p^.header.file_state := dfc$awaiting_recovery;
        IF p_fde^.attach_count = 0 THEN
          gfp$unlock_fde_p (p_fde);
          EXIT /timeout_server_file_block/;
        IFEND;

        IF p_fde^.eoi_byte_address = dfc$partially_rebuilt_fde_eoi THEN
          gfp$unlock_fde_p (p_fde);
          EXIT /timeout_server_file_block/;
        IFEND;

        IF p_fde^.attached_in_write_count = 0 THEN
          IF p_fde^.asti <> 0 THEN
            remove_server_file_pages (sfid, p_fde);
          IFEND;
          gfp$unlock_fde_p (p_fde);
          EXIT /timeout_server_file_block/;
        IFEND;

        IF space_available_for_image THEN
          save_server_file_pages (sfid, p_fde, p_server_state, image_file_id, file_page_count, status);
          IF status.normal THEN
            total_page_count := total_page_count + file_page_count;
          ELSEIF (status.condition = dfe$no_space_for_server_pages) THEN
            space_available_for_image := FALSE;
            space_available_status := status;
          IFEND;
        IFEND;

        gfp$unlock_fde_p (p_fde);
      END /timeout_server_file_block/;

      gfp$scan_all_fdes (gfc$tr_null_residence, scan_control, p_fde);
    WHILEND;

    STRINGREP (st, stl, file_count, ' Server_File(s) set to Awaiting_Recovery');
    dpp$put_critical_message (st (1, stl), ignore_status);
    core_log_display (st (1, stl));

    STRINGREP (st, stl, total_page_count, ' Server Page(s) saved ');
    dpp$put_critical_message (st (1, stl), ignore_status);
    core_log_display (st (1, stl));

    STRINGREP (st, stl, ' Server image size: ', #OFFSET(image_file_id.
         p_current_eoi):#(16), '(16) bytes');
    dpp$put_critical_message (st (1, stl), ignore_status);
    core_log_display (st (1, stl));

    IF NOT space_available_for_image THEN
      status := space_available_status;
    IFEND;
  PROCEND dfp$r1_timeout_server_files;
?? OLDTITLE ??
?? NEWTITLE := '  deact_term_server_file', EJECT ??

  PROCEDURE deact_term_server_file
    (    system_file_id: gft$system_file_identifier;
         request: mmt$server_segment_request;
     VAR pages_not_deleted: integer;
     VAR status: ost$status);

    VAR
      rb_ring1_server_seg_request: mmt$rb_ring1_server_seg_request;


    status.normal := TRUE;
    pages_not_deleted := 0;
    rb_ring1_server_seg_request.reqcode := syc$rc_ring1_server_seg_request;
    rb_ring1_server_seg_request.request := request;
    rb_ring1_server_seg_request.sfid := system_file_id;
    rb_ring1_server_seg_request.pages_not_deleted := 0;

    i#call_monitor (#LOC (rb_ring1_server_seg_request), #SIZE (rb_ring1_server_seg_request));

    IF rb_ring1_server_seg_request.pages_not_deleted <> 0 THEN
      pages_not_deleted := rb_ring1_server_seg_request.pages_not_deleted;
      osp$set_status_abnormal (dfc$file_server_id, dfe$server_pages_not_deleted, '', status);
    IFEND;

  PROCEND deact_term_server_file;
?? EJECT ??
{
{   This procedure is used during timeout processing to remove pages for files that
{ are merely being read. The mmp$mm_move_mod_server_page interface will
{ remove all pages that are being read even if there are no modified pages.

  PROCEDURE remove_server_file_pages
    (    sfid: gft$system_file_identifier;
         p_fde: gft$file_desc_entry_p);

    VAR
      byte_offset: ost$segment_offset,
      p_dummy_page: ^array [1 .. * ] of char,
      ignore_status: ost$status,
      image_offset: ost$segment_offset,
      st: string (100),
      status: ost$status,
      stl: integer;

    status.normal := TRUE;

    IF p_fde^.asti = 0 THEN
      RETURN;
    IFEND;

{ The following lines of code are (kind of) scary.  If the system is screwed up and we actually end up moving
{ a modified page, rather than removing the unmodified pages, we could really mess up the ring 1 stack.
{ It's happened.
{ Really.

    PUSH p_dummy_page: [1 .. osv$page_size];
    p_dummy_page^ [1] := 'a';

  /remove_all_pages/
    WHILE TRUE DO
      mmp$mm_move_mod_server_page (sfid, p_dummy_page, byte_offset, status);
      IF status.normal THEN
        IF dfv$file_server_debug_enabled THEN
          STRINGREP (st, stl, 'UNEXPECTED NORMAL STATUS: SFID = ', sfid.file_entry_index:#(16), '(16)');
          core_log_display (st (1, stl));
          dpp$put_critical_message (st (1, stl), ignore_status);
        IFEND;
        osp$system_error ('Unexpected status: file not attached in write and server page moved', NIL);
      ELSEIF status.condition = mme$no_pages_found_for_move THEN

{ Normal, expected status for this call.

        status.normal := TRUE;
        RETURN;
      ELSEIF status.condition = mme$io_active_on_move_page THEN
        IF dfv$file_server_debug_enabled THEN
          STRINGREP (st, stl, 'IO ACTIVE: SFID = ', sfid.file_entry_index:#(16), '(16)');
          core_log_display (st (1, stl));
          dpp$put_critical_message (st (1, stl), ignore_status);
        IFEND;
        pmp$delay (10000, ignore_status);
      ELSEIF status.condition = mme$page_table_full THEN
        IF dfv$file_server_debug_enabled THEN
          STRINGREP (st, stl, 'Page table full: SFID = ', sfid.file_entry_index:#(16), '(16)');
          core_log_display (st (1, stl));
          dpp$put_critical_message (st (1, stl), ignore_status);
        IFEND;
        pmp$delay (10000, ignore_status);
      ELSE
        STRINGREP (st, stl, 'Unexpected error: SFID = ', sfid.file_entry_index:#(16),
              '(16), status.condition = ', status.condition:#(16), '(16)');
        core_log_display (st (1, stl));
        dpp$put_critical_message (st (1, stl), ignore_status);
        osp$system_error ('Unexpected status: remove_server_file_pages', NIL);
        RETURN;
      IFEND;
    WHILEND /remove_all_pages/;

  PROCEND remove_server_file_pages;
?? EJECT ??
{  This procedure follows the same basic algorithm as in dfm$manage_image.
{  This procedure assumes the system file table has been locked prior to this
{   call.
{  This procedure saves all pages for the file into the server image file.
{  Even if there are not pages the eoi for the file needs to be sent to the
{  server to be updated over there.

  PROCEDURE save_server_file_pages
    (    sfid: gft$system_file_identifier;
         p_fde: gft$file_desc_entry_p;
         p_server_state: ^dft$server_state;
     VAR image_file_id: dft$image_file_id;
     VAR page_count: integer;
     VAR status: ost$status);

    VAR
      byte_offset: ost$segment_offset,
      ignore_status: ost$status,
      image_offset: ost$segment_offset,
      p_page_header: ^dft$image_page_header,
      p_file_header: ^dft$image_file_header,
      st: string (100),
      stl: integer;

    page_count := 0;
    NEXT p_file_header IN image_file_id.p_current_block_seq;
    IF p_file_header = NIL THEN
      dfp$get_next_image_block (image_file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      NEXT p_file_header IN image_file_id.p_current_block_seq;
    IFEND;

    p_file_header^.file_completed := FALSE;
    dfp$uncomplement_gfn (p_fde^.global_file_name, p_file_header^.global_file_name);
    p_file_header^.eoi_byte_address := p_fde^.eoi_byte_address;
    p_file_header^.page_count := 0;
    p_file_header^.highest_file_offset := 0;
    image_file_id.p_current_block_header^.file_count := image_file_id.p_current_block_header^.file_count + 1;
    status.normal := TRUE;
    IF dfv$file_server_debug_enabled THEN
      STRINGREP (st, stl, 'SFID = ', sfid.file_entry_index:#(16), '(16), ',
            p_fde^.global_file_name.hour, ':', p_fde^.global_file_name.minute, ':',
            p_fde^.global_file_name.second,
            ', Seq# = ', p_fde^.global_file_name.sequence_number);
      core_log_display (st (1, stl));
      dpp$put_critical_message (st (1, stl), ignore_status);
    IFEND;

    IF p_fde^.asti = 0 THEN
      p_file_header^.file_completed := TRUE;
      RETURN;
    IFEND;

   syp$core_hang_if_system_jrt_set (dfc$tjr_halt_save_server_image);

  /copy_all_pages/
    WHILE TRUE DO
      IF p_server_state^ <> dfc$awaiting_recovery THEN
        { State change has occurred to go to terminated. Get out of here.
         osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated, '', status);
         RETURN;
      IFEND;
      dfp$expand_image_file (image_file_id, status);
      IF NOT status.normal THEN
        IF (status.condition = dfe$no_space_for_server_pages) THEN
         { If we mark this file as not complete it will be terminated on the
         {    the next activation from the awaiting recovery state.
         {    Even despite this error the files pages are still in memory.
         { If terminate_system occurs all files for the server will be terminated if we
         {    were not not able to save pages.
         { If the client crashes the pages are still in memory and will be recovered
         {    at that time is there is sufficient disk space on the client.
           p_file_header^.file_completed := TRUE;
        IFEND;
        RETURN;
      IFEND;
      mmp$mm_move_mod_server_page (sfid, image_file_id.p_current_eoi, byte_offset,
            status);
      IF status.normal THEN
        image_offset := #OFFSET (image_file_id.p_current_eoi);
        image_file_id.p_current_eoi := #ADDRESS (#RING (image_file_id.p_current_eoi),
              #SEGMENT (image_file_id.p_current_eoi), #OFFSET (image_file_id.p_current_eoi) + osv$page_size);
        image_file_id.p_image_header^.current_eoi := #OFFSET (image_file_id.p_current_eoi);
        NEXT p_page_header IN image_file_id.p_current_block_seq;
        IF p_page_header = NIL THEN
         dfp$get_next_image_block (image_file_id, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          NEXT p_page_header IN image_file_id.p_current_block_seq;
        IFEND;
        p_page_header^.file_offset := byte_offset;
        p_page_header^.image_offset := image_offset;
        image_file_id.p_current_block_header^.page_count :=
              image_file_id.p_current_block_header^.page_count + 1;
        page_count := page_count + 1;
        p_file_header^.page_count := p_file_header^.page_count + 1;
        IF byte_offset > p_file_header^.highest_file_offset THEN
          p_file_header^.highest_file_offset := byte_offset;
        IFEND;
        IF dfv$file_server_debug_enabled THEN
          STRINGREP (st, stl, 'SFID', sfid.file_entry_index:#(16), '(16): pg #',
                p_file_header^.page_count, ', offset', byte_offset:#(16), '(16), image', image_offset:#(16),
                '(16)');
          core_log_display (st (1, stl));
          dpp$put_critical_message (st (1, stl), ignore_status);
        IFEND;
        CYCLE /copy_all_pages/;
      ELSEIF status.condition = mme$io_active_on_move_page THEN
        IF dfv$file_server_debug_enabled THEN
          STRINGREP (st, stl, 'IO ACTIVE: SFID = ', sfid.file_entry_index:#(16), '(16)');
          core_log_display (st (1, stl));
          dpp$put_critical_message (st (1, stl), ignore_status);
        IFEND;
        pmp$delay (10000, ignore_status);
        CYCLE /copy_all_pages/;
      ELSEIF status.condition = mme$page_table_full THEN
        IF dfv$file_server_debug_enabled THEN
          STRINGREP (st, stl, 'Page table full: SFID = ', sfid.file_entry_index:#(16), '(16)');
          core_log_display (st (1, stl));
          dpp$put_critical_message (st (1, stl), ignore_status);
        IFEND;
        pmp$delay (10000, ignore_status);
        CYCLE /copy_all_pages/;
      ELSEIF status.condition = mme$no_pages_found_for_move THEN
        IF dfv$file_server_debug_enabled THEN
          STRINGREP (st, stl, 'File Complete: SFID = ', sfid.file_entry_index:#(16), '(16), Highest offset: ',
               p_file_header^.highest_file_offset);
          core_log_display (st (1, stl));
          dpp$put_critical_message (st (1, stl), ignore_status);
        IFEND;
        status.normal := TRUE;
        EXIT /copy_all_pages/;
      ELSE
        STRINGREP (st, stl, 'Unexpected error: SFID = ', sfid.file_entry_index:#(16),
              '(16), status.condition = ', status.condition:#(16), '(16)');
        core_log_display (st (1, stl));
        dpp$put_critical_message (st (1, stl), ignore_status);
        RETURN;
      IFEND;
    WHILEND /copy_all_pages/;

    p_file_header^.file_completed := TRUE;
  PROCEND save_server_file_pages;
?? OLDTITLE, OLDTITLE ??
MODEND dfm$recovery_services;
*DECK DECK=DFM$RECOVER_REQUESTS_TO_SERVER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: Client', EJECT ??
MODULE dfm$recover_requests_to_server;

{ PURPOSE:
{   The purpose of this module is to recover all requests to the server
{   present on the client mainframe.  This occurs when the server is
{   being recovered.
{
{ NOTES:
{   This procedure will execute as a separate task
{   and the possibility exists that server termination may be started
{   while this task is executing .

?? NEWTITLE := '    Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfc$loopback_server_mainframe
*copyc dfc$poll_constants
*copyc dfe$error_condition_codes
*copyc dft$cpu_queue
*copyc dft$entry_type
*copyc ost$status
?? POP ??
*copyc clp$operator_intervention
*copyc clp$scan_parameter_list
*copyc dfi$display
*copyc dfi$log_display
*copyc dfp$crack_mainframe_id
*copyc dfp$execute_get_app_info
*copyc dfp$execute_state_change_task
*copyc dfp$find_mainframe_id
*copyc dfp$flush_image_file
*copyc dfp$free_image_file
*copyc dfp$verify_client_jobs_request
*copyc dfp$verify_system_administrator
*copyc dfv$recovery_task
*copyc dfv$file_server_debug_enabled
*copyc osp$set_status_abnormal
*copyc osv$emergency_intervention
*copyc pmp$long_term_wait
*copyc syp$hang_if_system_jrt_set

?? TITLE := '    [XDCL, #GATE] dfp$recover_requests_to_server', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$recover_requests_to_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt recover_task_pdt (
{   mainframe_name, mn : name pmc$mainframe_id_size = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      recover_task_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^recover_task_pdt_names, ^recover_task_pdt_params];

    VAR
      recover_task_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['MAINFRAME_NAME', 1], ['MN', 1], ['STATUS', 2]];

    VAR
      recover_task_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ MAINFRAME_NAME MN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$name_value, pmc$mainframe_id_size, pmc$mainframe_id_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      display_string: string (80),
      display_length: integer,
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_found: boolean,
      mainframe_name: pmt$mainframe_id,
      p_cpu_queue: ^dft$cpu_queue,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      queue_entry_index: dft$queue_entry_index,
      queue_index: dft$queue_index;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, recover_task_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$crack_mainframe_id ('MAINFRAME_NAME', mainframe_name, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$verify_system_administrator ('RECOVER_REQUESTS_TO_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$find_mainframe_id (mainframe_name, {server_to_client } FALSE, mainframe_found,
          p_queue_interface_table, p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, mainframe_name, status);
      RETURN;
    IFEND;
    dfv$recovery_task := TRUE;
    #SPOIL (p_cpu_queue^.queue_header.partner_status.server_state);
    IF p_cpu_queue^.queue_header.partner_status.server_state = dfc$recovering THEN
      IF osv$emergency_intervention THEN
        display (' Emergency intervention in Server recovery');
        clp$operator_intervention (status);
      IFEND;
      log_display ($pmt$ascii_logset [pmc$system_log], ' Sending server image ');
      dfp$flush_image_file (mainframe_id, mainframe_name, status);
      IF NOT status.normal THEN
        log_display_status ($pmt$ascii_logset [pmc$system_log], TRUE, status);
        display_status (status);
      IFEND;
      #SPOIL (p_cpu_queue^.queue_header.partner_status.server_state);
      IF p_cpu_queue^.queue_header.partner_status.server_state = dfc$recovering THEN
        dfp$free_image_file (mainframe_id, status);
        STRINGREP (display_string, display_length, ' ', mainframe_name, '  Verify client jobs ');
        display (display_string (1, display_length));
        log_display ($pmt$ascii_logset [pmc$system_log], display_string (1, display_length));
        dfp$verify_client_jobs_request (mainframe_name, status);
        IF NOT status.normal THEN
          display_status (status);
        IFEND;
        dfp$execute_get_app_info (mainframe_name, status);
        IF NOT status.normal THEN
          display_status (status);
        IFEND;
        syp$hang_if_system_jrt_set (dfc$tjr_recover_req_to_server);
        dfp$execute_state_change_task (mainframe_name, {Partner_is_server} TRUE,
              dfc$awaiting_recovery, dfc$recovering, osc$wait, status);
        p_cpu_queue^.queue_header.partner_status.recovery_complete := TRUE;
      ELSE
        STRINGREP (display_string, display_length, ' Server ', mainframe_name,
              '  state change during recovery ');
        display (display_string (1, display_length));
        log_display ($pmt$ascii_logset [pmc$system_log], display_string (1, display_length))
      IFEND;
      STRINGREP (display_string, display_length, ' ', mainframe_name, '  Recovery completed');
      display (display_string (1, display_length));
      log_display ($pmt$ascii_logset [pmc$system_log], display_string (1, display_length))
    ELSE
      STRINGREP (display_string, display_length, ' ', mainframe_name, '  Recovery task terminated');
      display (display_string (1, display_length));
      log_display ($pmt$ascii_logset [pmc$system_log], display_string (1, display_length))
    IFEND;
    dfv$recovery_task := FALSE;
  PROCEND dfp$recover_requests_to_server;

MODEND dfm$recover_requests_to_server;

*DECK DECK=DFM$REQUEST_REMOTE_APP_INFO EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server : Client : Request Remote Application Info', EJECT ??
MODULE dfm$request_remote_app_info;

{ PURPOSE:
{    The purpose of this module is to provide the procedures involved with
{    requesting and processing of remote application information from the server
{    mainframe. The main procedure is called as a result of the server/client
{    link reaching an active state.

?? NEWTITLE := ' Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dft$cpu_queue
*copyc dft$procedure_address_ordinal
*copyc dft$application_support_limits
?? POP ??
*copyc clp$evaluate_parameters
*copyc dfi$display
*copyc dfi$log_display
*copyc dfp$find_mainframe_id
*copyc dfp$send_remote_procedure_call
*copyc dfp$verify_system_administrator
*copyc dfv$file_server_debug_enabled
*copyc dfv$recovery_task
*copyc dfv$server_wired_heap
*copyc i#current_sequence_position
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc osp$system_error
*copyc pmp$get_mainframe_id
?? OLDTITLE ??
?? TITLE := '[XDCL, #GATE] dfp$request_remote_app_info', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$request_remote_app_info
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  procedure request_remote_pdt (
{   mainframe_id, mi: name pmc$mainframe_id_size = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 10, 8, 28, 15, 473],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['MAINFRAME_ID                   ',clc$nominal_entry, 1],
    ['MI                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [pmc$mainframe_id_size, pmc$mainframe_id_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$mainframe_id = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      mainframe_id: pmt$mainframe_id;

    status.normal := TRUE;
    dfp$verify_system_administrator (' DFP$REQUEST_REMOTE_APP_INFO', status);
    IF status.normal THEN

      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF status.normal THEN
        mainframe_id := pvt [p$mainframe_id].value^.name_value;
        dfv$recovery_task := TRUE;
        request_remote_app_info (mainframe_id, status);
        dfv$recovery_task := FALSE;
      IFEND;
    IFEND;

  PROCEND dfp$request_remote_app_info;

?? TITLE := ' request_remote_app_info ', EJECT ??

  PROCEDURE request_remote_app_info
    (    server_mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT request_remote_app_info;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      allowed_when_server_deactivated: boolean,
      application_index: dft$number_of_applications,
      host_mainframe_id: pmt$mainframe_id,
      ignore_p_q_interf_dir_entry: ^dft$q_interface_directory_entry,
      ignore_p_queue_interf_table: ^dft$queue_interface_table,
      ignore_queue_index: dft$queue_index,
      last_p_remote_app_info: ^dft$remote_application_info,
      local_status: ost$status,
      log_message: string (100),
      log_message_size: integer,
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_host_mainframe_id: ^pmt$mainframe_id,
      p_number_of_applications: ^dft$number_of_applications,
      p_proc_list: ^array [ * ] of dft$rpc_procedure_address_entry,
      p_rcv_remote_app_info: ^dft$remote_application_info,
      p_receive_buffer: dft$p_receive_parameters,
      p_receive_data: dft$p_receive_data,
      p_remote_app_info: ^dft$remote_application_info,
      p_send_buffer: dft$p_send_parameters,
      p_send_data: dft$p_send_data,
      p_total_proc_count: ^dft$total_number_of_app_procs,
      procedure_ordinal: dft$procedure_address_ordinal,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_buffer_size: dft$send_parameter_size,
      send_data_size: dft$send_data_size,
      server_location: dft$server_location;

    status.normal := TRUE;
    local_status.normal := TRUE;

    dfp$find_mainframe_id (server_mainframe_id, {host_is_server_to_client=} FALSE, mainframe_found,
          ignore_p_queue_interf_table, p_cpu_queue, ignore_queue_index, ignore_p_q_interf_dir_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, server_mainframe_id, status);
      RETURN;
    IFEND;


    IF p_cpu_queue^.queue_header.p_application_rpc_list <> NIL THEN
      FREE p_cpu_queue^.queue_header.p_application_rpc_list IN dfv$server_wired_heap^;
    IFEND;

    IF p_cpu_queue^.queue_header.p_remote_application_info <> NIL THEN
      FREE p_cpu_queue^.queue_header.p_remote_application_info IN dfv$server_wired_heap^;
    IFEND;

    server_location.server_location_selector := dfc$mainframe_id;
    server_location.server_mainframe := server_mainframe_id;
    allowed_when_server_deactivated := FALSE;

    procedure_ordinal := dfc$send_remote_app_info;
    pmp$get_mainframe_id (host_mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$begin_ch_remote_proc_call (server_location, allowed_when_server_deactivated, queue_entry_location,
          p_send_buffer, p_send_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /after_begin/
    BEGIN

      NEXT p_host_mainframe_id IN p_send_buffer;
      p_host_mainframe_id^ := host_mainframe_id;
      send_buffer_size := i#current_sequence_position (p_send_buffer);
      send_data_size := 0;
      dfp$send_remote_procedure_call (queue_entry_location, procedure_ordinal, send_buffer_size,
            send_data_size, p_receive_buffer, p_receive_data, status);
      IF NOT status.normal THEN
        IF ((status.condition <> dfe$server_request_terminated) AND
              (status.condition <> dfe$server_not_active) AND (status.condition <> dfe$server_has_terminated))
              THEN
          STRINGREP (log_message, log_message_size, ' ABNORMAL STATUS FROM dfp$request_remote_app_info');
          display (log_message (1, log_message_size));
          log_display ($pmt$ascii_logset [pmc$system_log], log_message (1, log_message_size));
          display_status (status);
          log_display_status ($pmt$ascii_logset [pmc$system_log], TRUE, status);
        IFEND;
        EXIT /after_begin/;
      IFEND;

{ Process receive data

      NEXT p_number_of_applications IN p_receive_data;
      NEXT p_total_proc_count IN p_receive_data;
      IF p_number_of_applications^ = 0 THEN
        EXIT /after_begin/;
      IFEND;

      last_p_remote_app_info := NIL;
      FOR application_index := 1 TO p_number_of_applications^ DO
        NEXT p_rcv_remote_app_info IN p_receive_data;
        ALLOCATE p_remote_app_info IN dfv$server_wired_heap^;
        IF p_remote_app_info = NIL THEN
          osp$system_error (' NIL p_remote_app_info', NIL);
        IFEND;
        p_remote_app_info^ := p_rcv_remote_app_info^;
        p_remote_app_info^.next_p_application_info := NIL;
        IF last_p_remote_app_info = NIL THEN
          p_cpu_queue^.queue_header.p_remote_application_info := p_remote_app_info;
        ELSE
          last_p_remote_app_info^.next_p_application_info := p_remote_app_info;
        IFEND;
        last_p_remote_app_info := p_remote_app_info;
      FOREND;

      ALLOCATE p_cpu_queue^.queue_header.p_application_rpc_list: [1 .. p_total_proc_count^] IN
            dfv$server_wired_heap^;
      IF p_cpu_queue^.queue_header.p_application_rpc_list = NIL THEN
        osp$system_error (' NIL p_application_rpc_list', NIL);
      IFEND;

      NEXT p_proc_list: [1 .. p_total_proc_count^] IN p_receive_data;

      p_cpu_queue^.queue_header.p_application_rpc_list^ := p_proc_list^;

      STRINGREP (log_message, log_message_size, ' Server ', server_mainframe_id,
            '    size of app info received = ', #SIZE (p_receive_data^));
      log_display ($pmt$ascii_logset [pmc$job_log, pmc$system_log], log_message (1, log_message_size));
      IF dfv$file_server_debug_enabled THEN
        display (log_message (1, log_message_size));
      IFEND;
    END /after_begin/;

    dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND request_remote_app_info;
MODEND dfm$request_remote_app_info;



*DECK DECK=DFM$RESET_MAINFRAME_TABLES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: Client/Server', EJECT ??
MODULE dfm$reset_mainframe_tables;

{ PURPOSE:
{   This module contains the code to reset tables associated
{   with a partner (server or client) mainframe when the partner is
{   re-activated.
{
{ NOTE:
{   It is assumed that the state of the partner is terminated and that there
{   is nothing which cannot be reset.

?? NEWTITLE := '    Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfc$poll_constants
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc dfi$display
*copyc dft$client_mainframe_file
*copyc dft$cpu_queue
*copyc dfv$false_queue_entry_flags
*copyc dfv$file_server_debug_enabled
*copyc dfv$null_global_task_id
*copyc dfv$p_queue_interface_directory
*copyc dfv$server_wired_heap
?? POP ??
*copyc dfp$build_client_mf_file_name
*copyc dfp$change_family_server_state
*copyc dfp$find_mainframe_id
*copyc osp$clear_locked_variable
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc oss$job_paged_literal
*copyc pfp$purge
*copyc pfp$purge_catalog
*copyc pmp$get_compact_date_time
*copyc pmp$zero_out_table


?? TITLE := '    [XDCL] dfp$reset_mainframe_tables', EJECT ??

  PROCEDURE [XDCL] dfp$reset_mainframe_tables
    (    mainframe_name: pmt$mainframe_id;
         host_is_server_to_client: boolean;
     VAR status: ost$status);

    VAR
      active_queue_entry: boolean,
      character_index: 1 .. dfc$queue_assignment_strng_size,
      client_mainframe: pmt$mainframe_id,
      client_mainframe_name: ost$name,
      cycle_selector: pft$cycle_selector,
      display_size: integer,
      display_string: string (80),
      ignore_status: ost$status,
      mainframe_found: boolean,
      p_catalog_path: ^pft$path,
      p_cpu_queue: ^dft$cpu_queue,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_cpu_queue_header: ^dft$cpu_queue_header,
      p_driver_queue: ^dft$driver_queue,
      p_mainframe_file_path: ^pft$path,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      q_d_index: dft$queue_directory_index,
      queue_index: dft$queue_index,
      queue_entry_index: dft$queue_entry_index,
      total_queue_entries: dft$queue_entry_index;

    status.normal := TRUE;
    dfp$find_mainframe_id (mainframe_name, host_is_server_to_client, mainframe_found,
          p_queue_interface_table, p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      osp$system_error (' UNKNOWN MAINFRAME - DFP$RESET_MAINFRAME_TABLES.', NIL);
    IFEND;
    IF dfv$file_server_debug_enabled THEN
      STRINGREP (display_string, display_size, 'dfp$reset_mainframe_tables ',
          mainframe_name, ' S->C ', host_is_server_to_client, ' Q', queue_index);
       display (display_string (1, display_size));
     IFEND;

    p_driver_queue := p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue;

    total_queue_entries := p_driver_queue^.queue_header.number_of_queue_entries;

    p_cpu_queue_header := ^p_cpu_queue^.queue_header;
    p_cpu_queue_header^.monitor_io [dfc$monitor_io].number_of_requests := 0;
    p_cpu_queue_header^.monitor_io [dfc$monitor_io].total_request_time := 0;
    p_cpu_queue_header^.monitor_io [dfc$monitor_io].max_request_time := 0;
    p_cpu_queue_header^.monitor_io [dfc$monitor_allocate].number_of_requests := 0;
    p_cpu_queue_header^.monitor_io [dfc$monitor_allocate].total_request_time := 0;
    p_cpu_queue_header^.monitor_io [dfc$monitor_allocate].max_request_time := 0;
    pmp$get_compact_date_time (p_cpu_queue_header^.transaction_data.
         transaction_start_time, ignore_status);
    osp$clear_locked_variable (p_cpu_queue_header^.transaction_data.total_transaction_count,
          { Best Guess = } 0);
    osp$clear_locked_variable (p_cpu_queue_header^.transaction_data.total_buffer_length_sent,
          { Best Guess = } 0);
    osp$clear_locked_variable (p_cpu_queue_header^.transaction_data.total_data_pages_sent,
          { Best Guess = } 0);
    osp$clear_locked_variable (p_cpu_queue_header^.transaction_data.total_buffer_length_received,
          { Best Guess = } 0);
    osp$clear_locked_variable (p_cpu_queue_header^.transaction_data.total_data_pages_received,
          { Best Guess = } 0);

    FOR character_index := 1 TO #SIZE (p_cpu_queue_header
          ^.queue_entry_assignment_table) DO
      IF character_index <= total_queue_entries THEN
        IF character_index = dfc$poll_queue_index THEN
          p_cpu_queue_header^.queue_entry_assignment_table (character_index) :=
                dfc$assigned_entry_char;
        ELSE
          p_cpu_queue_header^.queue_entry_assignment_table (character_index) :=
                dfc$free_entry_char;
        IFEND;
      ELSE
        p_cpu_queue_header^.queue_entry_assignment_table (character_index) :=
              dfc$pad_entry_char;
      IFEND;
    FOREND;

    FOR queue_entry_index := 1 to total_queue_entries DO
      p_cpu_queue_entry := ^p_cpu_queue^.queue_entries [queue_entry_index];
      p_cpu_queue_entry^.transaction_count := 0;
      p_cpu_queue_entry^.request_start_time := 0;
      p_cpu_queue_entry^.retransmission_count := 0;
      IF host_is_server_to_client THEN
        p_cpu_queue_entry^.transaction_state := dfc$server_waiting_request;
      ELSE
        p_cpu_queue_entry^.transaction_state := dfc$queue_entry_available;
      IFEND;
      p_cpu_queue_entry^.request_timeout_count := 0;
      p_cpu_queue_entry^.global_task_id := dfv$null_global_task_id;
      p_cpu_queue_entry^.data_pages_locked := FALSE;
      IF p_cpu_queue_entry^.processor_type = dfc$monitor THEN
        IF host_is_server_to_client THEN
          p_cpu_queue_entry^.p_server_iocb^.server_state := mmc$ss_waiting;
        ELSE
          p_cpu_queue_entry^.p_server_iocb := NIL;
        IFEND;
      IFEND;
      RESET p_cpu_queue_entry^.p_send_buffer;
      pmp$zero_out_table ( p_cpu_queue_entry^.p_send_buffer, #SIZE (
           p_cpu_queue_entry^.p_send_buffer^));
      RESET p_cpu_queue_entry^.p_receive_buffer;
      pmp$zero_out_table ( p_cpu_queue_entry^.p_receive_buffer, #SIZE (
           p_cpu_queue_entry^.p_receive_buffer^));

      p_driver_queue^.queue_entries [queue_entry_index].flags := dfv$false_queue_entry_flags;
      IF queue_entry_index = dfc$poll_queue_index THEN
        p_driver_queue^.queue_entries [queue_entry_index].flags.active_entry := TRUE;
      IFEND;
      p_driver_queue^.queue_entries [queue_entry_index].error_condition := 0;
      p_driver_queue^.queue_entries [queue_entry_index].held_over_cm_word_count := 0;
      p_driver_queue^.queue_entries [queue_entry_index].held_over_esm_division_number := 0;
      p_driver_queue^.queue_entries [queue_entry_index].data_descriptor.actual_length := 0;
      p_driver_queue^.queue_header.flags.idle := TRUE;
    FOREND;

    p_cpu_queue_entry := ^p_cpu_queue^.queue_entries [dfc$poll_queue_index];
    IF host_is_server_to_client THEN
{     Incase the Client Side has already sent the "verify_queue" POLL message
{     and 1. it is missed by the Server Side because activation of the PP driver
{     will clear the message in STORNET, or 2. in loopback, the PP driver dumped
{     the message because the Server Side queue entry was not active, set the
{     Server Side POLL queue entry's transaction_state to dfc$media_error.
{     If an "Inquiry_message" is received on the Server Side an "Inquiry_Response"
{     with a transaction_state of dfc$media_error will be returned to the Client.
{     When the Client Side recognizes the transaction_state of dfc$media_error
{     from the Server it will immediately retransmit the "verify_queue" POLL
{     message.
{     If/when the "verify_queue" POLL message is received on the Server Side,
{     the transaction_state will be changed to the appropriate state.
      p_cpu_queue_entry^.transaction_state := dfc$media_error;
    ELSE
{     This serves no purpose other than to accurately reflect the
{     transaction_state of the Client Side POLL queue entry.
      p_cpu_queue_entry^.transaction_state := dfc$queue_entry_assigned;
    IFEND;

  PROCEND dfp$reset_mainframe_tables;

MODEND dfm$reset_mainframe_tables;
*DECK DECK=DFM$RETURN_FAMILY_STATE EXPAND=TRUE
?? RIGHT := 110 ??
MODULE dfm$return_family_state;

{
{ This module provides a temporary place for the command
{ processor to return information about a family.  This
{ interface is a temporary interface provided for integration.
{ This also contains a simple interface to determine if a family
{ is a served family.

?? PUSH (LISTEXT := ON) ??
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc clp$validate_name
*copyc clp$write_variable
*copyc dfe$error_condition_codes
*copyc dfp$fetch_served_family_entry
*copyc dfp$find_mainframe_id
*copyc dfp$get_served_family_names
*copyc dfp$locate_every_served_family
*copyc dft$family_info_list
*copyc dft$family_info_record
*copyc osp$convert_to_real_model_num
*copyc osp$get_family_names
*copyc osp$get_set_name
*copyc osp$set_status_condition
*copyc pfe$error_condition_codes
*copyc pme$program_services_exceptions
*copyc pmp$convert_binary_mainframe_id
?? POP ??
?? EJECT ??
*copyc dfh$get_family_list
  PROCEDURE [XDCL, #GATE] dfp$get_family_list
    (VAR family_info_list: dft$family_info_list;
     VAR number_of_families: integer;
     VAR status: ost$status);

    VAR
      family: integer,
      family_end_index: pmt$family_name_count,
      list_full: boolean,
      local_family_count: pmt$family_name_count,
      p_family_list: ^pmt$family_name_list,
      server_family_count: pmt$family_name_count;

    PUSH p_family_list: [1 .. UPPERBOUND (family_info_list)];
    dfp$get_served_family_names (p_family_list^, server_family_count, status);
    list_full := NOT status.normal;
    number_of_families := server_family_count;
    family_end_index := number_of_families;
    IF number_of_families >= UPPERBOUND (family_info_list) THEN
      family_end_index := UPPERBOUND (family_info_list);
      list_full := TRUE;
    IFEND;

  /get_server_family_status/
    FOR family := 1 TO family_end_index DO
      dfp$get_family_status (p_family_list^ [family], family_info_list [family], status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND /get_server_family_status/;

    osp$get_family_names (p_family_list^, local_family_count, status);
    number_of_families := server_family_count + local_family_count;
    IF NOT list_full THEN
      family_end_index := number_of_families;
      IF number_of_families > UPPERBOUND (family_info_list) THEN
        family_end_index := UPPERBOUND (family_info_list);
        list_full := TRUE;
      IFEND;

    /get_local_family_status/
      FOR family := (server_family_count + 1) TO family_end_index DO
        dfp$get_family_status (p_family_list^ [family - server_family_count], family_info_list [family],
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND /get_local_family_status/;
    IFEND;

    IF list_full THEN
      osp$set_status_condition (pme$result_array_too_small, status);
    IFEND;
  PROCEND dfp$get_family_list;
?? EJECT ??
*copyc dfh$get_family_status

{ NOTE:
{   This procedure returns the REAL processor model number.

  PROCEDURE [XDCL, #GATE] dfp$get_family_status
    (    family_name: ost$family_name;
     VAR family_state: dft$family_info_record;
     VAR status: ost$status);

    VAR
      converted_family_name: ost$family_name,
      family_served: boolean,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_served_family_entry: ^dft$served_family_table_entry,
      queue_index: dft$queue_index,
      served_family_table_index: dft$served_family_table_index,
      server_mainframe_id: pmt$binary_mainframe_id,
      server_state: dft$server_state;

    status.normal := TRUE;
    clp$validate_name (family_name, converted_family_name, status.normal);
    IF NOT status.normal THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_family_name, family_name, status);
      RETURN;
    IFEND;
    family_state.family_name := converted_family_name;
    dfp$locate_every_served_family (converted_family_name, family_served, served_family_table_index,
          server_mainframe_id, p_queue_interface_table, queue_index, server_state);
    IF family_served THEN
      family_state.family_state := server_state;
      family_state.access_type := dfc$server_access;
      family_state.server_binary_mainframe_id := server_mainframe_id;
      osp$convert_to_real_model_num (server_mainframe_id.model_number,
            family_state.server_binary_mainframe_id.model_number);
      pmp$convert_binary_mainframe_id (server_mainframe_id, family_state.server_mainframe_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      dfp$fetch_served_family_entry (served_family_table_index, p_served_family_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      family_state.family_access := p_served_family_entry^.family_access;
    ELSE
      osp$get_set_name (converted_family_name, family_state.set_name, status);
      IF status.normal THEN
        family_state.access_type := dfc$set_access;
        family_state.family_state := dfc$active;
      IFEND;
    IFEND;
  PROCEND dfp$get_family_status;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$return_family_state
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{  pdt fetch_family_state (
{     family_name, fn: name = $required
{     family_state, fs: VAR of string = $required
{     status)

?? PUSH (LISTEXT := ON) ??

    VAR
      fetch_family_state: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^fetch_family_state_names, ^fetch_family_state_params];

    VAR
      fetch_family_state_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
            clt$parameter_name_descriptor := [['FAMILY_NAME', 1], ['FN', 1], ['FAMILY_STATE', 2], ['FS', 2],
            ['STATUS', 3]];

    VAR
      fetch_family_state_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
            clt$parameter_descriptor := [

{ FAMILY_NAME FN

      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ FAMILY_STATE FS

      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$string_value]],

{ STATUS

      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      family_info: dft$family_info_record,
      family_name: ost$name,
      family_state: ^record
        size: ost$string_size,
        value: string ( * ),
      recend,
      family_state_area: ^SEQ ( * ),
      family_state_variable: ^array [1 .. * ] of cell,
      server_state: dft$server_state,
      server_state_string: string (17),
      value: clt$value;

    clp$scan_parameter_list (parameter_list, fetch_family_state, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('FAMILY_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    family_name := value.name.value;

    clp$get_value ('FAMILY_STATE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$get_family_status (family_name, family_info, status);
    IF status.normal THEN
      CASE family_info.access_type OF
      = dfc$server_access =
        CASE family_info.family_state OF
        = dfc$active =
          server_state_string := 'SERVER_ACTIVE';
        = dfc$inactive, dfc$deactivated, dfc$awaiting_recovery, dfc$recovering =
          server_state_string := 'SERVER_INACTIVE';
        = dfc$terminated =
          server_state_string := 'SERVER_TERMINATED';
        ELSE
          server_state_string := 'UNKNOWN';
        CASEND;
      ELSE
        server_state_string := 'LOCAL';
      CASEND;
    ELSE { Unknown or deleted family
      status.normal := TRUE;
      server_state_string := 'UNKNOWN';
    IFEND;

    PUSH family_state_area: [[REP UPPERBOUND (value.var_ref.value.string_value^) OF cell]];
    RESET family_state_area;
    NEXT family_state: [value.var_ref.value.max_string_size] IN family_state_area;
    family_state^.size := 17;
    family_state^.value := server_state_string;
    RESET family_state_area;
    NEXT family_state_variable: [1 .. UPPERBOUND (value.var_ref.value.string_value^)] IN family_state_area;
    value.var_ref.value.string_value := family_state_variable;
    clp$write_variable (value.var_ref.reference.value (1, value.var_ref.reference.size), value.var_ref.value,
          status);

  PROCEND dfp$return_family_state;
MODEND dfm$return_family_state;
*DECK DECK=DFM$RPC_CLIENT_SEGMENT_TRANSPRT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server : rpc_client_segment_transprt', EJECT ??
MODULE dfm$rpc_client_segment_transprt;

{ Purpose: This module contains the file server interfaces for use with the
{          remote procedure call mechanism for transporting large amount
{          of data from the client to the server.
{
{ Notes:   Module dfm$rpc_segment_transport contains the code for
{          moving large amounts of data from the server to the client.
{
{ Design: 1.  On the client the user tells how much of a file to send to
{             to the server.
{         2.  On the server a transient segment is created.
{         3.  The client makes repeated calls to send the user file.
{             The data is transferred from the user file to
{             to the data area on the client.  On the server the data is
{             transfered from the wired area to the transient segment at the
{             desired offset.
{         4.  The user request on the server obtains a pointer to the
{             transient segment and uses the segment.  The user request
{             on the server deletes the transient segment.
{             This is why these requests can
{             currently only be associated with NON restartable requests.
{
?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfd$request_package
*copyc dfe$error_condition_codes
*copyc dfk$keypoints
*copyc dft$procedure_address_ordinal
*copyc dft$rpc_queue_entry_loc_int
*copyc dft$send_client_rpc_segment
*copyc dft$rpc_buffer_header
*copyc dft$rpc_parameters
*copyc oss$task_private
*copyc ost$status
?? POP ??
*copyc dfp$convert_queue_entry_loc
*copyc dfp$fetch_queue_entry
*copyc dfp$send_remote_procedure_call
*copyc dfp$validate_queue_entry_loc
*copyc i#build_adaptable_seq_pointer
*copyc i#move
*copyc mmp$create_segment
*copyc mmp$delete_segment
*copyc mmp$set_access_selections
*copyc osp$set_status_condition
*copyc osp$verify_system_privilege
?? TITLE := 'Global Declarations Declared by this Module', EJECT ??

  VAR
    dfv$p_client_rpc_segment: [XDCL, oss$task_private] ^SEQ ( * ) := NIL;

?? TITLE := ' Server: [XDCL, #GATE]  dfp$delete_client_rpc_segment', EJECT ??

*copyc dfh$delete_client_rpc_segment
  PROCEDURE [XDCL, #GATE] dfp$delete_client_rpc_segment;

    VAR
      segment_pointer: mmt$segment_pointer,
      status: ost$status;

    osp$verify_system_privilege;
    IF dfv$p_client_rpc_segment <> NIL THEN
      segment_pointer.kind := mmc$sequence_pointer;
      segment_pointer.seq_pointer := dfv$p_client_rpc_segment;
      mmp$delete_segment (segment_pointer, { Validation ring number = } 2, status);
      dfv$p_client_rpc_segment := NIL;
    IFEND;
  PROCEND dfp$delete_client_rpc_segment;

?? TITLE := '  Server: [XDCL, #GATE] dfp$receive_client_rpc_segment', EJECT ??

*copyc dfh$receive_client_rpc_segment

  PROCEDURE [XDCL, #GATE] dfp$receive_client_rpc_segment
    (VAR p_seq: ^SEQ ( * );
     VAR status: ost$status);

    #KEYPOINT (osk$entry, 0, dfk$receive_client_rpc_segment);
    osp$verify_system_privilege;
    p_seq := dfv$p_client_rpc_segment;
    status.normal := TRUE;
    IF dfv$p_client_rpc_segment = NIL THEN
      osp$set_status_condition (dfe$no_segment_reserved, status);
    IFEND;
    #KEYPOINT (osk$exit, 0, dfk$receive_client_rpc_segment);
  PROCEND dfp$receive_client_rpc_segment;

?? TITLE := '  Server: dfp$receive_part_client_segment', EJECT ??

{
{    This procedure is the server side of the dfp$send_client_rpc_segment
{ remote procedure call.  This procedure merely moves the requested data from
{ the server wired data area to the transient segment.  The user must call
{ dfp$receive_client_rpc_segment to obtain the pointer to the transient
{ segment.
{

  PROCEDURE [XDCL] dfp$receive_part_client_segment
    (VAR p_params_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_received_from_client {Input} : dft$p_receive_data;
     VAR p_params_to_send_to_client {^Output} : dft$p_send_parameters;
     VAR p_data_to_send_to_client {^Output} : dft$p_send_data;
     VAR params_size_to_send_to_client: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_input_parameters: ^dft$send_client_rpc_segment,
      ring_attribute: array [1 .. 1] of mmt$attribute_descriptor,
      segment_pointer: mmt$segment_pointer;

    status.normal := TRUE;
    params_size_to_send_to_client := 0;
    data_size_to_send_to_client := 0;
    NEXT p_input_parameters IN p_params_received_from_client;

    IF dfv$p_client_rpc_segment = NIL THEN
      ring_attribute [1].keyword := mmc$kw_ring_numbers;
      ring_attribute [1].r1 := 3;
      ring_attribute [1].r2 := 3;
      mmp$create_segment (^ring_attribute, mmc$sequence_pointer, { Ring} 2, segment_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      mmp$set_access_selections (segment_pointer.seq_pointer, mmc$as_sequential, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      i#build_adaptable_seq_pointer (#RING (segment_pointer.seq_pointer),
            #SEGMENT (segment_pointer.seq_pointer), { Offset } 0,
            (p_input_parameters^.starting_offset + p_input_parameters^.send_size), { Next } 0,
            dfv$p_client_rpc_segment);
    IFEND;

    IF (p_input_parameters^.starting_offset + p_input_parameters^.send_size) >
          #SIZE (dfv$p_client_rpc_segment^) THEN
      { The size of the sequence pointer contains the highest offset written.
      i#build_adaptable_seq_pointer (#RING (dfv$p_client_rpc_segment), #SEGMENT (dfv$p_client_rpc_segment),
            { Offset } 0, (p_input_parameters^.starting_offset + p_input_parameters^.send_size), { Next } 0,
            dfv$p_client_rpc_segment);
    IFEND;
    i#move (p_data_received_from_client, #ADDRESS (#RING (dfv$p_client_rpc_segment),
          #SEGMENT (dfv$p_client_rpc_segment), p_input_parameters^.starting_offset),
          p_input_parameters^.send_size);
  PROCEND dfp$receive_part_client_segment;

?? TITLE := '  Client: [XDCL, #GATE] dfp$send_client_rpc_segment ', EJECT ??

*copyc dfh$send_client_rpc_segment

  PROCEDURE [XDCL, #GATE] dfp$send_client_rpc_segment
    (    queue_entry_location: dft$rpc_queue_entry_location;
         p_client_segment: ^SEQ ( * );
         server_segment_offset: ost$segment_length;
         request_size: ost$segment_length;
     VAR status: ost$status);

    VAR
      current_server_offset: ost$segment_length,
      local_p_client_segment: ^SEQ ( * ),
      p_copy_data: ^SEQ ( * ),
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_buffer_header: ^dft$buffer_header,
      p_send_rpc_buffer_header: ^dft$rpc_buffer_header,
      p_server_parameters: ^dft$send_client_rpc_segment,
      queue_entry_loc_int: dft$rpc_queue_entry_loc_int,
      remaining_data: ost$segment_length;

    #KEYPOINT (osk$entry, 0, dfk$send_client_rpc_segment);
    osp$verify_system_privilege;

{ Obtain the pointers to the remote procedure call buffer areas.

    dfp$convert_qel_ext_to_int (queue_entry_location, queue_entry_loc_int);
    dfp$validate_queue_entry_loc (queue_entry_loc_int, 'DFP$SEND_CLIENT_RPC_SEGMENT',
          p_queue_interface_table, status);
    IF status.normal THEN
      local_p_client_segment := p_client_segment;
      dfp$fetch_queue_entry (p_queue_interface_table, queue_entry_loc_int.queue_index,
            queue_entry_loc_int.queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry);
      RESET p_cpu_queue_entry^.p_send_buffer;
      NEXT p_send_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
      NEXT p_send_rpc_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
      NEXT p_server_parameters IN p_cpu_queue_entry^.p_send_buffer;

      current_server_offset := server_segment_offset;
      remaining_data := request_size;

    /send_all_data/
      WHILE remaining_data > 0 DO
        p_server_parameters^.starting_offset := current_server_offset;
        IF remaining_data > dfc$maximum_user_data_area THEN
          p_server_parameters^.send_size := dfc$maximum_user_data_area;
        ELSE
          p_server_parameters^.send_size := remaining_data;
        IFEND;

       { Move the data from the user's segment to rpc data area.
        NEXT p_copy_data: [[REP p_server_parameters^.send_size OF cell]] IN local_p_client_segment;
        IF p_copy_data = NIL THEN
          osp$set_status_condition (dfe$info_full, status);
          EXIT /send_all_data/;
        IFEND;
        i#move (p_copy_data, p_cpu_queue_entry^.p_send_data, p_server_parameters^.send_size);

        dfp$send_remote_procedure_call (queue_entry_location, dfc$send_client_rpc_segment,
              #SIZE (p_server_parameters^), p_server_parameters^.send_size, p_receive_from_server_params,
              p_receive_data, status);
        IF NOT status.normal THEN
          EXIT /send_all_data/;
        IFEND;

        { Now compute the next area of the server segment.

        remaining_data := remaining_data - p_server_parameters^.send_size;
        current_server_offset := current_server_offset + p_server_parameters^.send_size;
      WHILEND /send_all_data/;
    IFEND;
    #KEYPOINT (osk$exit, 0, dfk$send_client_rpc_segment);
  PROCEND dfp$send_client_rpc_segment;

MODEND dfm$rpc_client_segment_transprt;

*DECK DECK=DFM$RPC_SEGMENT_TRANSPORT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server : rpc_segment_transport', EJECT ??
MODULE dfm$rpc_segment_transport;

{ Purpose: This module contains the file server interfaces for use with the
{          remote procedure call mechanism for transporting large amount
{          of data from the server to the client.
{
{ Design:
{         1.  On the server a transient segment is created.
{         2.  The client makes repeated calls to obtain the segment.
{             The data is transferred from the server wired data area
{             to the user's sequence.
{         3.  The server deletes the transient segment on the next
{              remote procedure call received.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfd$request_package
*copyc dfe$error_condition_codes
*copyc dfk$keypoints
*copyc dft$procedure_address_ordinal
*copyc dft$rpc_queue_entry_loc_int
*copyc dft$receive_server_rpc_segment
*copyc dft$rpc_buffer_header
*copyc dft$rpc_parameters
*copyc oss$task_private
*copyc ost$status
?? POP ??
*copyc dfp$convert_queue_entry_loc
*copyc dfp$fetch_queue_entry
*copyc dfp$send_remote_procedure_call
*copyc dfp$validate_queue_entry_loc
*copyc i#move
*copyc mmp$create_segment
*copyc mmp$delete_segment
*copyc mmp$set_access_selections
*copyc osp$set_status_condition
*copyc osp$verify_system_privilege
?? TITLE := 'Global Declarations Declared by this Module', EJECT ??

  VAR
    dfv$p_server_rpc_segment: [XDCL, oss$task_private] ^SEQ ( * ) := NIL;

?? TITLE := ' Server: [INLINE, XDCL]  dfp$delete_server_rpc_segment', EJECT ??

{   This procedure deleted the server rpc segment if one exists.
{ This allows freeing extra pages associated with the segment.

  PROCEDURE [INLINE, XDCL] dfp$delete_server_rpc_segment;

    VAR
      segment_pointer: mmt$segment_pointer,
      status: ost$status;

    IF dfv$p_server_rpc_segment <> NIL THEN
      segment_pointer.kind := mmc$sequence_pointer;
      segment_pointer.seq_pointer := dfv$p_server_rpc_segment;
      mmp$delete_segment (segment_pointer, { Validation ring number = } 2, status);
      dfv$p_server_rpc_segment := NIL;
    IFEND;
  PROCEND dfp$delete_server_rpc_segment;
?? TITLE := '  Client: [XDCL, #GATE] dfp$receive_server_rpc_segment ', EJECT ??

*copyc dfh$receive_server_rpc_segment

  PROCEDURE [XDCL, #GATE] dfp$receive_server_rpc_segment
    (    queue_entry_location: dft$rpc_queue_entry_location;
         server_segment_offset: ost$segment_length;
         request_size: ost$segment_length;
     VAR p_client_segment: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      current_server_offset: ost$segment_length,
      local_p_client_segment: ^SEQ ( * ),
      p_copy_data: dft$p_receive_data,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_buffer_header: ^dft$buffer_header,
      p_send_rpc_buffer_header: ^dft$rpc_buffer_header,
      p_server_parameters: ^dft$receive_server_rpc_segment,
      queue_entry_loc_int: dft$rpc_queue_entry_loc_int,
      remaining_data: ost$segment_length;

    #KEYPOINT (osk$entry, 0, dfk$receive_server_rpc_segment);
    osp$verify_system_privilege;

{ Obtain the pointers to the remote procedure call buffer areas.

    dfp$convert_qel_ext_to_int (queue_entry_location, queue_entry_loc_int);
    dfp$validate_queue_entry_loc (queue_entry_loc_int, 'DFP$RECEIVE_SERVER_RPC_SEGMENT',
          p_queue_interface_table, status);
    IF status.normal THEN
      local_p_client_segment := p_client_segment;
      dfp$fetch_queue_entry (p_queue_interface_table, queue_entry_loc_int.queue_index,
            queue_entry_loc_int.queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry);
      RESET p_cpu_queue_entry^.p_send_buffer;
      NEXT p_send_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
      NEXT p_send_rpc_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
      NEXT p_server_parameters IN p_cpu_queue_entry^.p_send_buffer;

      current_server_offset := server_segment_offset;
      remaining_data := request_size;

    /receive_all_data/
      WHILE remaining_data > 0 DO
        p_server_parameters^.starting_offset := current_server_offset;
        IF remaining_data > dfc$maximum_user_data_area THEN
          p_server_parameters^.receive_size := dfc$maximum_user_data_area;
        ELSE
          p_server_parameters^.receive_size := remaining_data;
        IFEND;
        dfp$send_remote_procedure_call (queue_entry_location, dfc$receive_server_rpc_segment,
              #SIZE (p_server_parameters^), { Send data size = } 0, p_receive_from_server_params,
              p_receive_data, status);
        IF NOT status.normal THEN
          EXIT /receive_all_data/;
        IFEND;

{ Move the data to the user's segment.

        NEXT p_copy_data: [[REP p_server_parameters^.receive_size OF cell]] IN local_p_client_segment;
        IF p_copy_data = NIL THEN
          osp$set_status_condition (dfe$info_full, status);
          EXIT /receive_all_data/;
        IFEND;
        p_copy_data^ := p_receive_data^;

{ Now compute the next area of the server segment.

        remaining_data := remaining_data - p_server_parameters^.receive_size;
        current_server_offset := current_server_offset + p_server_parameters^.receive_size;
      WHILEND /receive_all_data/;
    IFEND;
    IF status.normal THEN
      p_client_segment := local_p_client_segment;
    IFEND;
    #KEYPOINT (osk$exit, 0, dfk$receive_server_rpc_segment);
  PROCEND dfp$receive_server_rpc_segment;

?? TITLE := '  Server: [XDCL, #GATE] dfp$reserve_server_rpc_segment', EJECT ??

*copyc dfh$reserve_server_rpc_segment

  PROCEDURE [XDCL, #GATE] dfp$reserve_server_rpc_segment
    (VAR p_seq: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      ring_attribute: array [1 .. 1] of mmt$attribute_descriptor,
      segment_pointer: mmt$segment_pointer;

    #KEYPOINT (osk$entry, 0, dfk$reserve_server_rpc_segment);
    osp$verify_system_privilege;
    dfp$delete_server_rpc_segment;
    ring_attribute [1].keyword := mmc$kw_ring_numbers;
    ring_attribute [1].r1 := 3;
    ring_attribute [1].r2 := 3;
    mmp$create_segment (^ring_attribute, mmc$sequence_pointer, { Ring} 2, segment_pointer, status);
    IF status.normal THEN
      mmp$set_access_selections (segment_pointer.seq_pointer, mmc$as_sequential, status);
    IFEND;
    IF status.normal THEN
      dfv$p_server_rpc_segment := segment_pointer.seq_pointer;
      p_seq := dfv$p_server_rpc_segment;
    IFEND;

    #KEYPOINT (osk$exit, 0, dfk$reserve_server_rpc_segment);
  PROCEND dfp$reserve_server_rpc_segment;

?? TITLE := '  Server: dfp$send_server_rpc_segment ', EJECT ??

{
{   This procedure is the server side of the dfp$receive_server_rpc_segment
{ request.   This procedure merely removes the requested data to the server
{ wired data area.
{

  PROCEDURE [XDCL] dfp$send_server_rpc_segment
    (VAR p_params_received_from_client {Input}: dft$p_receive_parameters;
     VAR p_data_received_from_client {Input}: dft$p_receive_data;
     VAR p_params_to_send_to_client {^Output}: dft$p_send_parameters;
     VAR p_data_to_send_to_client {^Output}: dft$p_send_data;
     VAR params_size_to_send_to_client: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_input_parameters: ^dft$receive_server_rpc_segment;

    status.normal := TRUE;
    params_size_to_send_to_client := 0;
    data_size_to_send_to_client := 0;
    IF dfv$p_server_rpc_segment = NIL THEN
      osp$set_status_condition (dfe$no_segment_reserved, status);
      RETURN;
    IFEND;

    NEXT p_input_parameters IN p_params_received_from_client;

    i#move (#ADDRESS (#RING (dfv$p_server_rpc_segment), #SEGMENT (dfv$p_server_rpc_segment),
          p_input_parameters^.starting_offset), p_data_to_send_to_client, p_input_parameters^.receive_size);
    data_size_to_send_to_client := p_input_parameters^.receive_size;

  PROCEND dfp$send_server_rpc_segment;


MODEND dfm$rpc_segment_transport;
*DECK DECK=DFM$SERVED_FAMILY_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File Server: Client: served_family_manager' ??
MODULE dfm$served_family_manager;

{ PURPOSE:
{   This module manages connecting from the client to the server.  This involves executing a command on the
{   client that specifies the connection information.  This module also manages the served family table, which
{   is created as a result of the above command.  Interfaces are provided to obtain information about the
{   served families.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfc$iou_names
*copyc dfc$poll_constants
*copyc dfc$server_mainframes_catalog
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc dfk$keypoints
*copyc dfi$display
*copyc dfi$log_display
*copyc dfs$server_wired
*copyc dft$display_identifier
*copyc dft$family_list
*copyc dft$partner_mainframe_list
*copyc dft$cpu_queue
*copyc dft$poll_family_list
*copyc dft$queue_interface_directory
*copyc dft$read_write_lock
*copyc dft$served_family_table
*copyc dft$served_family_table_index
*copyc dpt$window_id
*copyc mmt$io_identifier
*copyc ose$system_task_exceptions
*copyc pme$program_services_exceptions
*copyc pmt$family_name_count
*copyc pmt$family_name_list
*copyc pmt$program_description
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$scan_argument_list
*copyc dfp$check_if_valid
*copyc dfp$clear_read_lock
*copyc dfp$clear_write_lock
*copyc dfp$crack_connection_parameters
*copyc dfp$create_image_file
*copyc dfp$create_queue
*copyc dfp$display
*copyc dfp$find_mainframe_id
*copyc dfp$flush_served_family_table
*copyc dfp$format_task_name
*copyc dfp$locate_esm_definition
*copyc dfp$new_crack_mainframe_id
*copyc dfp$record_server_translation
*copyc dfp$set_read_lock
*copyc dfp$set_write_lock
*copyc dfp$start_cdcnet_client
*copyc dfp$verify_stornet_channel
*copyc dfp$verify_system_administrator
*copyc jmp$activate_deferred_family
*copyc jmp$defer_deactivated_family
*copyc osp$activate_system_task
*copyc osp$append_status_integer
*copyc osp$deactivate_system_task
*copyc osp$decrement_locked_variable
*copyc osp$define_system_task
*copyc osp$get_set_name
*copyc osp$increment_locked_variable
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$verify_system_privilege
*copyc pfp$define_catalog
*copyc pmp$convert_binary_mainframe_id
?? EJECT ??
*copyc dfv$family_access_enabled
*copyc dfv$file_server_debug_enabled
*copyc dfv$number_served_family_lists
*copyc dfv$p_queue_interface_directory
*copyc dfv$served_family_table_lock
*copyc dfv$served_family_table_root
*copyc dfv$server_state_string
*copyc dfv$server_wired_heap
*copyc osv$system_family_name
*copyc osv$page_size
*copyc osv$upper_to_lower
?? TITLE := 'Global Variables Declared by This Module', EJECT ??

  CONST
    c$asynchronous_start_procedure = 'DFP$MANAGE_SERVER_CONNECTION';

?? TITLE := '[XDCL] dfp$change_family_server_state ', EJECT ??
  PROCEDURE [XDCL] dfp$change_family_server_state
    (    new_state: dft$server_state;
         mainframe_id: pmt$binary_mainframe_id);

    VAR
      family_list_index: dft$served_family_list_index,
      family_name_list: array [1 .. 1] OF ost$name,
      leveled_families_affected: boolean,
      log_string: string (80),
      log_string_length: integer,
      p_family_list: ^array [dft$served_family_list_index] of dft$served_family_table_entry,
      pointers_index: dft$family_pointer_index,
      previous_state: dft$server_state,
      server_mainframe_id: pmt$mainframe_id,
      status: ost$status;

{-------------------------------------------------------------------------
{   This procedure changes Server_State in the Served_Family_Table to one
{   requested by the input parameter. It selects the Family entries by
{   matching the the mainframe_id supplied by the input parameter with
{   one in the Served_Family_Table but rejects those entries whose
{   Server_State is DELETED. The DELETED state in the Served_Family_Table
{   may only be changed by Define_Server and Define_Served_Families
{   subcommands.
{-------------------------------------------------------------------------

    leveled_families_affected := FALSE;
    pmp$convert_binary_mainframe_id (mainframe_id, server_mainframe_id, status);
    STRINGREP (log_string, log_string_length, ' Server ', server_mainframe_id,
       ' ', dfv$server_state_string [new_state]);
    log_display ($pmt$ascii_logset [pmc$system_log], log_string (1, log_string_length));
    IF dfv$file_server_debug_enabled THEN
      display (log_string (1, log_string_length));
    IFEND;
    dfp$set_read_lock (dfv$served_family_table_lock);
    IF dfv$served_family_table_root.valid THEN

    /for_all_pointers/
      FOR pointers_index := 1 TO dfv$served_family_table_root.number_of_active_pointers DO
        p_family_list := dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
              p_served_family_list;

      /search_family_list/
        FOR family_list_index := 1 TO dfv$served_family_table_root.
              p_family_list_pointer_array^ [pointers_index].highest_valid_entry DO

          IF (p_family_list^ [family_list_index].server_mainframe_id = mainframe_id) AND
                (p_family_list^ [family_list_index].server_state <> dfc$deleted) THEN
            leveled_families_affected := leveled_families_affected OR (dfc$job_leveling_access IN
                  p_family_list^ [family_list_index].family_access);
            previous_state := p_family_list^ [family_list_index].server_state;
            p_family_list^ [family_list_index].server_state := new_state;
            CASE new_state OF
            = dfc$deleted =
              p_family_list^ [family_list_index].verified_by_server := FALSE;
              p_family_list^ [family_list_index].p_queue_interface_table := NIL;
            = dfc$active =
              p_family_list^ [family_list_index].active_since_deadstart := TRUE;
              IF (previous_state <> dfc$active) AND ((dfc$remote_login_access IN
                     p_family_list^ [family_list_index].family_access) OR
                     (dfc$job_leveling_access IN p_family_list^[family_list_index].
                     family_access)) THEN
                family_name_list [1] := p_family_list^ [family_list_index].family_name;
                jmp$activate_deferred_family (^family_name_list);
              IFEND;
            = dfc$inactive, dfc$awaiting_recovery =
              IF (previous_state <> new_state) THEN
                { Even if the current family_access does not allow login or leveling
                { there might be a job left over.
                family_name_list [1] := p_family_list^ [family_list_index].family_name;
                jmp$defer_deactivated_family (^family_name_list);
              IFEND;
            ELSE
            CASEND;
          IFEND;

        FOREND /search_family_list/;
      FOREND /for_all_pointers/;

    IFEND;
    dfp$clear_read_lock (dfv$served_family_table_lock);

    IF leveled_families_affected THEN
      dfp$change_job_leveler_state;
    IFEND;

    dfp$flush_served_family_table (status);
  PROCEND dfp$change_family_server_state;

?? TITLE := '[XDCL] dfp$change_family_verification ', EJECT ??

  PROCEDURE [XDCL] dfp$change_family_verification
    (    family_name: ost$name;
         mainframe_id: pmt$binary_mainframe_id;
         family_access: dft$family_access;
         verified_by_server: boolean;
         server_lifetime: dft$server_lifetime;
         server_birthdate: integer;
         current_server_state: dft$server_state;
     VAR verification_changed: boolean;
     VAR status: ost$status);

    VAR
      family_found: boolean,
      family_index: dft$served_family_table_index,
      family_name_list: array [1 .. 1] OF ost$name,
      ignore_verify: boolean,
      list_index: dft$served_family_list_index,
      log_string: string (80),
      log_string_length: integer,
      p_queue_interface_table: dft$p_queue_interface_table,
      pointers_index: dft$family_pointer_index,
      previous_server_state: dft$server_state,
      queue_index: dft$queue_index,
      server_mainframe_id: pmt$binary_mainframe_id;

    STRINGREP (log_string, log_string_length, ' Server ', family_name (1, 20),
        dfv$server_state_string [current_server_state],
       ' Life/birth', server_lifetime, server_birthdate);
    log_display ($pmt$ascii_logset [pmc$system_log], log_string (1, log_string_length));
    IF dfv$file_server_debug_enabled THEN
      display (log_string (1, log_string_length));
    IFEND;
    dfp$set_read_lock (dfv$served_family_table_lock);
    IF dfv$served_family_table_root.valid THEN
      locate_served_family (family_name, family_found, family_index, server_mainframe_id,
            p_queue_interface_table, queue_index, previous_server_state, ignore_verify);
      IF family_found AND (mainframe_id = server_mainframe_id) THEN
        pointers_index := family_index.pointers_index;
        list_index := family_index.family_list_index;
        verification_changed := (dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
              p_served_family_list^ [list_index].verified_by_server <> verified_by_server);
        dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
              p_served_family_list^ [list_index].family_access := family_access;
        dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
              p_served_family_list^ [list_index].verified_by_server := verified_by_server;
        dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
              p_served_family_list^ [list_index].server_lifetime := server_lifetime;
        dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
              p_served_family_list^ [list_index].server_birthdate := server_birthdate;
        IF (previous_server_state = dfc$deleted) AND verified_by_server THEN
          dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
                p_served_family_list^ [list_index].server_state := current_server_state;
          IF current_server_state = dfc$active THEN
            dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
                  p_served_family_list^ [list_index].active_since_deadstart := TRUE;
            IF (dfc$remote_login_access IN family_access) OR
                     (dfc$job_leveling_access IN family_access) THEN
             family_name_list [1] := family_name;
              jmp$activate_deferred_family (^family_name_list);
            IFEND;
          IFEND;
        IFEND;
        status.normal := TRUE;

      ELSE
        osp$set_status_abnormal (dfc$file_server_id, dfe$family_not_found, family_name, status);
      IFEND;
    ELSE
      osp$set_status_abnormal (dfc$file_server_id, dfe$family_not_found, family_name, status);
    IFEND;
    dfp$clear_read_lock (dfv$served_family_table_lock);
    IF status.normal THEN
      dfp$flush_served_family_table (status);
    IFEND;
  PROCEND dfp$change_family_verification;
?? TITLE := '[XDCL] dfp$change_job_leveler_state', EJECT ??

{ PURPOSE:
{   This procedure activates the job leveler task if there are any leveled
{   families and deactivates it when there are no leveled families.

  PROCEDURE [XDCL] dfp$change_job_leveler_state;

    VAR
      family_list_index: dft$served_family_list_index,
      job_leveler_file_list_p: ^llt$object_file_list,
      leveled_family_found: boolean,
      pointers_index: dft$family_pointer_index,
      program_attributes_p: ^llt$program_attributes,
      program_description_p: ^llt$program_description,
      family_list_p: ^array [dft$served_family_list_index] of dft$served_family_table_entry,
      spy_id: pmt$spy_identifier,
      status: ost$status,
      task_name: ost$name,
      task_params: string (1);

    dfp$set_read_lock (dfv$served_family_table_lock);
    leveled_family_found := FALSE;

    IF dfv$served_family_table_root.valid THEN

    /for_all_lists/
      FOR pointers_index := 1 TO dfv$served_family_table_root.number_of_active_pointers DO
        family_list_p := dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
              p_served_family_list;

      /search_family_list/
        FOR family_list_index := 1 TO dfv$served_family_table_root.
              p_family_list_pointer_array^ [pointers_index].highest_valid_entry DO

          IF (family_list_p^ [family_list_index].server_state = dfc$active) AND
                family_list_p^ [family_list_index].verified_by_server AND
                (dfc$job_leveling_access IN family_list_p^ [family_list_index].family_access) THEN
            leveled_family_found := TRUE;
            EXIT /for_all_lists/;
          IFEND;
        FOREND /search_family_list/;
      FOREND /for_all_lists/;
    IFEND;
    dfp$clear_read_lock (dfv$served_family_table_lock);

    task_name := 'JOB_LEVELER';
    IF leveled_family_found THEN
      osp$activate_system_task (task_name, status);
      IF NOT status.normal AND (status.condition = ose$system_task_not_defined) THEN
        spy_id := 0;
        PUSH program_description_p: [[REP (#size(llt$program_attributes) + #size(clt$path_name))
                OF CELL]];
        RESET program_description_p;
        NEXT program_attributes_p IN program_description_p;
        program_attributes_p^.contents := $pmt$prog_description_contents
              [pmc$starting_proc_specified, pmc$load_map_options_specified, pmc$term_error_level_specified,
               pmc$object_file_list_specified];
        program_attributes_p^.starting_procedure := 'JMP$JOB_LEVELER_TASK';
        program_attributes_p^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
        program_attributes_p^.termination_error_level := pmc$warning_load_errors;
        program_attributes_p^.number_of_object_files := 1;
        NEXT job_leveler_file_list_p: [1 .. 1] IN program_description_p;
        job_leveler_file_list_p^ [1] := ':$SYSTEM.$SYSTEM.FILE_SERVER.OSF$JOB_LEVELER_TASK';
        task_params := ' ';
        osp$define_system_task (task_name, {auto_restart=} TRUE,
              {deactivate_option=} osc$tt_terminate, {idle_option=} osc$tt_ignore_or_prohibited,
              {restart_after_idle=} TRUE, spy_id, {execution_ring=} osc$sj_ring_3, program_description_p,
              #SEQ (task_params), status);
        osp$activate_system_task (task_name, status);
      IFEND;
    ELSE
      osp$deactivate_system_task (task_name, status);
    IFEND;

  PROCEND dfp$change_job_leveler_state;
?? TITLE := '[XDCL] dfp$clear_family_queues ', EJECT ??
{
{   This procedure clears the p_queue_interface_table and queue_index in
{   the served family table. It selects the family entries by
{   matching the the mainframe_id supplied by the input parameter.
{   This is called when DELETE_SERVER is done on a family in the awaiting
{   recovery state. These fields are cleared since they are no longer
{   valid, and clearing them allows the remote procedure call mechanism
{   to proceed and avoid using them.
{
  PROCEDURE [XDCL] dfp$clear_family_queues
    (    mainframe_id: pmt$binary_mainframe_id);

    VAR
      family_list_index: dft$served_family_list_index,
      family_name_list: array [1 .. 1] of ost$name,
      log_string: string (80),
      log_string_length: integer,
      p_family_list: ^array [dft$served_family_list_index] of dft$served_family_table_entry,
      pointers_index: dft$family_pointer_index,
      server_mainframe_id: pmt$mainframe_id,
      status: ost$status;


    pmp$convert_binary_mainframe_id (mainframe_id, server_mainframe_id, status);
    STRINGREP (log_string, log_string_length, ' Server ', server_mainframe_id, ' deleting queues ');
    log_display ($pmt$ascii_logset [pmc$system_log], log_string (1, log_string_length));
    IF dfv$file_server_debug_enabled THEN
      display (log_string (1, log_string_length));
    IFEND;
    dfp$set_read_lock (dfv$served_family_table_lock);
    IF dfv$served_family_table_root.valid THEN

    /for_all_pointers/
      FOR pointers_index := 1 TO dfv$served_family_table_root.number_of_active_pointers DO
        p_family_list := dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
              p_served_family_list;

      /search_family_list/
        FOR family_list_index := 1 TO dfv$served_family_table_root.
              p_family_list_pointer_array^ [pointers_index].highest_valid_entry DO

          IF (p_family_list^ [family_list_index].server_mainframe_id = mainframe_id) AND
                (p_family_list^ [family_list_index].server_state = dfc$awaiting_recovery) THEN
            p_family_list^ [family_list_index].p_queue_interface_table := NIL;
            p_family_list^ [family_list_index].queue_index := UPPERVALUE (dft$queue_index);
          IFEND;

        FOREND /search_family_list/;
      FOREND /for_all_pointers/;

    IFEND;
    dfp$clear_read_lock (dfv$served_family_table_lock);

    dfp$flush_served_family_table (status);
  PROCEND dfp$clear_family_queues;

?? TITLE := '[XDCL, #GATE] dfp$define_served_families_cmnd ', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$define_served_families_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      family_access: dft$family_access,
      family_list_container: dft$family_list_container,
      ignore_p_directory_entry: ^dft$q_interface_directory_entry,
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_family_list: dft$p_family_list,
      p_queue_interface_table: ^dft$queue_interface_table,
      queue_index: dft$queue_index,
      server_mainframe_id: pmt$binary_mainframe_id,
      server_mainframe_name: pmt$mainframe_id,
      server_to_client: boolean;

    dfp$verify_system_administrator ('DEFINE_SERVED_FAMILY', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_define_family_command (parameter_list, family_list_container, p_family_list, server_mainframe_name,
          server_mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server_to_client := FALSE;
    dfp$find_mainframe_id (server_mainframe_name, server_to_client, mainframe_found, p_queue_interface_table,
          p_cpu_queue, queue_index, ignore_p_directory_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, server_mainframe_name, status);
      RETURN;
    IFEND;
    IF p_cpu_queue^.queue_header.number_of_monitor_queue_entries = 0 THEN
      osp$set_status_condition (dfe$no_families_when_zero_nomqe, status);
      RETURN;
    IFEND;

    verify_families_not_registered (p_family_list^, server_mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF ((p_cpu_queue^.queue_header.partner_status.server_state = dfc$terminated) OR
        (p_cpu_queue^.queue_header.partner_status.server_state = dfc$awaiting_recovery) OR
        (p_cpu_queue^.queue_header.partner_status.server_state = dfc$inactive)) AND
         p_cpu_queue^.queue_header.partner_status.verify_queue THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$server_is_activating, '', status);
      RETURN;
    IFEND;

    family_access := $dft$family_access [dfc$remote_file_access];
    dfp$register_served_families (p_family_list^, family_access, {client_definition=} TRUE,
          p_queue_interface_table, queue_index, status);

  PROCEND dfp$define_served_families_cmnd;

?? TITLE := '[XDCL, #GATE] dfp$define_server_command ', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$define_server_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      connection_parameters: dft$connection_parameters,
      family_access: dft$family_access,
      family_list_container: dft$family_list_container,
      family_list_p: dft$p_family_list,
      queue_interface_table_p: dft$p_queue_interface_table,
      served_family_birthdate: integer,
      served_family_found: boolean,
      served_family_lifetime: dft$server_lifetime,
      served_family_state: dft$server_state,
      server_mainframe_name: pmt$mainframe_id,
      server_mainframe_id: pmt$binary_mainframe_id,
      task_name: ost$name;

    status.normal := TRUE;
    dfp$verify_system_administrator ('DEFINE_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_define_server (parameter_list, family_list_container, family_list_p, server_mainframe_name,
          server_mainframe_id, connection_parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF connection_parameters.connection_type = dfc$esm_connection THEN
      dfp$check_if_valid (connection_parameters, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF family_list_p <> NIL THEN
      IF connection_parameters.number_of_monitor_queue_entries = 0 THEN
        osp$set_status_condition (dfe$no_families_when_zero_nomqe, status);
        RETURN;
      IFEND;
      verify_families_not_registered (family_list_p^, server_mainframe_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    process_new_mainframe (connection_parameters, server_mainframe_name, server_mainframe_id,
          queue_interface_table_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$get_highest_sf_lifetime (server_mainframe_id, served_family_found, served_family_state,
         served_family_lifetime, served_family_birthdate);
    IF served_family_found THEN
      IF served_family_state = dfc$awaiting_recovery THEN

        { Recover the lifetime and the birthdate from the served family table.

        queue_interface_table_p^.queue_directory.cpu_queue_pva_directory
              [connection_parameters.client_queue_index].p_cpu_queue^.queue_header.partner_status.
              server_state := dfc$awaiting_recovery;
        queue_interface_table_p^.queue_directory.cpu_queue_pva_directory
              [connection_parameters.client_queue_index].p_cpu_queue^.queue_header.partner_status.
              server_pages_saved := TRUE;
        queue_interface_table_p^.queue_directory.cpu_queue_pva_directory
              [connection_parameters.client_queue_index].p_cpu_queue^.queue_header.server_lifetime :=
              served_family_lifetime;
        queue_interface_table_p^.queue_directory.cpu_queue_pva_directory
              [connection_parameters.client_queue_index].p_cpu_queue^.queue_header.server_birthdate :=
              served_family_birthdate;
      IFEND;

      { No matter what make sure the correct queue info is stored.

      set_served_family_queue_info (server_mainframe_id, queue_interface_table_p,
             connection_parameters.client_queue_index);
    IFEND;

    { Check if Task_Name is already in the System_Task_Table.  If not, define the task, else do nothing -
    { it's been defined.

    dfp$format_task_name (server_mainframe_name, task_name);
    define_asynchronous_task (server_mainframe_name, status);
    IF NOT status.normal AND (status.condition <> ose$system_task_already_defined) THEN
      RETURN;
    ELSE
      status.normal := TRUE;
    IFEND;

    IF family_list_p <> NIL THEN
      family_access := $dft$family_access [dfc$remote_file_access];
      dfp$register_served_families (family_list_p^, family_access, {client_definition=} TRUE,
            queue_interface_table_p, connection_parameters.client_queue_index, status);
    IFEND;

  PROCEND dfp$define_server_command;

?? TITLE := '[XDCL] dfp$delete_family_if_last ', EJECT ??

{ This procedure only removes the family if there is no chance that it has been
{ referenced yet.

  PROCEDURE [XDCL] dfp$delete_family_if_last
    (    family_name: ost$family_name);

    VAR
      actual: integer,
      error: boolean,
      family_deleted: boolean,
      high_family_list_index: integer,
      high_pointer_index: integer,
      p_served_family_table_entry: ^dft$served_family_table_entry,
      status: ost$status;

    family_deleted := FALSE;
    dfp$set_write_lock (dfv$served_family_table_lock);
    IF dfv$served_family_table_root.valid THEN
      high_pointer_index := dfv$served_family_table_root.number_of_active_pointers;
      IF high_pointer_index > 0 THEN
        high_family_list_index := dfv$served_family_table_root.
              p_family_list_pointer_array^ [high_pointer_index].highest_valid_entry;
        IF (high_family_list_index > 0) THEN
          p_served_family_table_entry := ^dfv$served_family_table_root.
                p_family_list_pointer_array^ [high_pointer_index].
                p_served_family_list^ [high_family_list_index];
          IF (p_served_family_table_entry^.family_name = family_name) AND
               (NOT p_served_family_table_entry^.verified_by_server) AND
               (p_served_family_table_entry^.server_state IN $dft$server_states
               [dfc$terminated, dfc$deleted]) AND
               (p_served_family_table_entry^.server_lifetime = 1) THEN
            dfv$served_family_table_root.p_family_list_pointer_array^ [high_pointer_index].
                  p_served_family_list^ [high_family_list_index].family_name := osc$null_name;
            osp$decrement_locked_variable (dfv$served_family_table_root.
                  p_family_list_pointer_array^ [high_pointer_index].highest_valid_entry,
                  dfv$served_family_table_root.p_family_list_pointer_array^ [high_pointer_index].
                  highest_valid_entry, actual, error);
            family_deleted := TRUE;
            IF error THEN
              osp$system_error (' ERROR IN DELETING LAST FAMILY', NIL);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    dfp$clear_write_lock (dfv$served_family_table_lock);
    IF family_deleted THEN
      dfp$flush_served_family_table (status);
    IFEND;
  PROCEND dfp$delete_family_if_last;
?? TITLE := '[XDCL] dfp$display_served_family_table ', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display the server families at the
{   operator display.
{
{ Notes:
{   Upon entry to this procedure the 'message_written' parameter has been
{   set to FALSE by the calling procedure.  It is set to TRUE if a line
{   is displayed by this procedure.

  PROCEDURE [XDCL] dfp$display_served_family_table
    (VAR display_identifier: dft$display_identifier;
     VAR message_written {input, output} : boolean;
     VAR status: ost$status);

    VAR
      access_location: 1 .. 80,
      display_string: string (80),
      family_list_index: dft$served_family_list_index,
      pointers_index: dft$family_pointer_index,
      served_family_table_entry: dft$served_family_table_entry,
      server_mainframe_id: pmt$mainframe_id;

    dfp$set_read_lock (dfv$served_family_table_lock);

    IF dfv$served_family_table_root.valid THEN
      dfp$display (' ---SERVER FAMILY----------------ACCESS-----SERVER MAINFRAME---SERVER STATE----',
           display_identifier, status);
      IF NOT status.normal THEN
        dfp$clear_read_lock (dfv$served_family_table_lock);
        RETURN;
      IFEND;
      message_written := TRUE;

    /for_all_lists/
      FOR pointers_index := 1 TO dfv$served_family_table_root.number_of_active_pointers DO

      /search_family_list/
        FOR family_list_index := 1 TO dfv$served_family_table_root.
              p_family_list_pointer_array^ [pointers_index].highest_valid_entry DO
          served_family_table_entry := dfv$served_family_table_root.
                p_family_list_pointer_array^ [pointers_index].p_served_family_list^ [family_list_index];
          display_string := ' ';
          display_string (2, * ) := served_family_table_entry.family_name;

          IF (served_family_table_entry.server_state = dfc$active) AND
                served_family_table_entry.verified_by_server THEN
            access_location := 34;
            IF dfc$remote_file_access IN served_family_table_entry.family_access THEN
              display_string (access_location, *) := 'FILE';
            IFEND;
            IF dfc$remote_login_access IN served_family_table_entry.family_access THEN
              display_string (access_location, *) := 'LOGIN';
            IFEND;
            IF dfc$job_leveling_access IN served_family_table_entry.family_access THEN
              display_string (access_location, *) := 'LEVELED';
            IFEND;
          ELSE
            display_string (34, * ) := 'NONE';
          IFEND;

          pmp$convert_binary_mainframe_id (served_family_table_entry.server_mainframe_id, server_mainframe_id,
                status);
          IF NOT status.normal THEN
            EXIT /for_all_lists/;
          IFEND;
          display_string (45, * ) := server_mainframe_id;
          display_string (64, * ) := dfv$server_state_string [served_family_table_entry.server_state];

          dfp$display (display_string, display_identifier, status);
          IF NOT status.normal THEN
            EXIT /for_all_lists/;
          IFEND;
        FOREND /search_family_list/;
      FOREND /for_all_lists/;
    IFEND;
    dfp$clear_read_lock (dfv$served_family_table_lock);

  PROCEND dfp$display_served_family_table;

?? TITLE := '[XDCL] dfp$format_verify_family ', EJECT ??

  PROCEDURE [XDCL] dfp$format_verify_family
    (    mainframe_id: pmt$binary_mainframe_id;
     VAR family_container: SEQ (REP dfc$max_family_parameters of dft$family_verification);
     VAR number_of_families: 0 .. dfc$max_family_parameters;
     VAR p_family_list: ^dft$poll_family_list);

{   ---------------------------------------------------------------------
{   This procedure prepares a list of families to be sent to the Server
{   mainframe for verification. It does so by selecting families from
{   the Served_Family_Table whose entries match the mainframe_id supplied
{   by the input parameter.
{   Family entries whose Server_State is DELETED are not considered for
{   the selection.
{   ---------------------------------------------------------------------

    VAR
      family_list_index: dft$served_family_list_index,
      p_family_container: ^SEQ (REP dfc$max_family_parameters of dft$family_verification),
      p_family_record: ^dft$family_verification,
      pointers_index: dft$family_pointer_index;

    p_family_container := ^family_container;
    RESET p_family_container;
    number_of_families := 0;
    p_family_list := NIL;

    dfp$set_read_lock (dfv$served_family_table_lock);
    IF dfv$served_family_table_root.valid THEN

    /for_all_pointers/
      FOR pointers_index := 1 TO dfv$served_family_table_root.number_of_active_pointers DO

      /search_family_list/
        FOR family_list_index := 1 TO dfv$served_family_table_root.
              p_family_list_pointer_array^ [pointers_index].highest_valid_entry DO

          IF (dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
                p_served_family_list^ [family_list_index].server_mainframe_id = mainframe_id) THEN

            IF (dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
                 p_served_family_list^ [family_list_index].server_state <> dfc$deleted) THEN
              NEXT p_family_record IN p_family_container;
              p_family_record^.family := dfv$served_family_table_root.
                   p_family_list_pointer_array^ [pointers_index].p_served_family_list^ [family_list_index].
                   family_name;
              p_family_record^.family_access := dfv$served_family_table_root.
                   p_family_list_pointer_array^ [pointers_index].p_served_family_list^ [family_list_index].
                   family_access;
              p_family_record^.valid := FALSE;
              number_of_families := number_of_families + 1;
            IFEND;
          IFEND;
        FOREND /search_family_list/;
      FOREND /for_all_pointers/;

      IF number_of_families > 0 THEN
        RESET p_family_container;
        NEXT p_family_list: [1 .. number_of_families] IN p_family_container;
      IFEND;
    IFEND;
    dfp$clear_read_lock (dfv$served_family_table_lock);

  PROCEND dfp$format_verify_family;
?? TITLE := '[XDCL] dfp$get_family_access', EJECT ??
*copy dfh$get_family_access

  PROCEDURE [XDCL] dfp$get_family_access
    (    family: ost$family_name;
     VAR family_known: boolean;
     VAR family_access: dft$family_access;
     VAR server_state: dft$server_state;
     VAR leveler_status: jmt$jl_job_leveler_status);

    VAR
      family_found: boolean,
      ignored_set_name: stt$set_name,
      local_status: ost$status,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
      served_family_table_index: dft$served_family_table_index,
      server_mainframe_id: pmt$binary_mainframe_id,
      verified_by_server: boolean;

    osp$verify_system_privilege;
    dfp$set_read_lock (dfv$served_family_table_lock);

    locate_served_family (family, family_known, served_family_table_index,
          server_mainframe_id, p_queue_interface_table, queue_index,
          server_state, verified_by_server);

    IF (NOT family_known) OR (server_state = dfc$deleted) THEN
      dfp$clear_read_lock (dfv$served_family_table_lock);
      osp$get_set_name (family, ignored_set_name, local_status);
      family_known := local_status.normal;
      IF family_known {but only locally} THEN
        family_access := $dft$family_access [];
      IFEND;
      RETURN;
    IFEND;

    family_access := dfv$served_family_table_root.
          p_family_list_pointer_array^ [served_family_table_index.
          pointers_index].p_served_family_list^
          [served_family_table_index.family_list_index].family_access;
    server_state := dfv$served_family_table_root.
          p_family_list_pointer_array^ [served_family_table_index.
          pointers_index].p_served_family_list^
          [served_family_table_index.family_list_index].server_state;
    IF p_queue_interface_table = NIL THEN
      leveler_status.leveler_state := jmc$jl_leveler_disabled;
      leveler_status.cleanup_completed := FALSE;
    ELSE
      leveler_status := p_queue_interface_table^.queue_directory.
            cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header.
            leveler_status;
    IFEND;
    dfp$clear_read_lock (dfv$served_family_table_lock);

  PROCEND dfp$get_family_access;

?? TITLE := '[XDCL] dfp$get_highest_sf_lifetime ', EJECT ??
  PROCEDURE [XDCL] dfp$get_highest_sf_lifetime
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR server_found: boolean;
     VAR server_state: dft$server_state;
     VAR highest_server_lifetime: dft$server_lifetime;
     VAR server_birthdate: integer);

    VAR
      family_list_index: dft$served_family_list_index,
      pointers_index: dft$family_pointer_index;

{========================================================================
{   This procedure searches through all of the entries in the Served
{   Family Table for the given mainframe ID and returns the highest
{   value of the Server Lifetime found in the entries for that mainframe.
{   If the mainframe has no entries then Lifetime of zero is returned.
{========================================================================

    server_found := FALSE;
    highest_server_lifetime := 0;
    server_birthdate := 0;
    dfp$set_read_lock (dfv$served_family_table_lock);
    IF dfv$served_family_table_root.valid THEN

    /for_all_lists/
      FOR pointers_index := 1 TO dfv$served_family_table_root.number_of_active_pointers DO

      /search_family_list/
        FOR family_list_index := 1 TO dfv$served_family_table_root.
              p_family_list_pointer_array^ [pointers_index].highest_valid_entry DO
          { Assume no deletion
          IF (dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
                p_served_family_list^ [family_list_index].server_mainframe_id = server_mainframe_id) THEN
            server_found := TRUE;
            IF (dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
                p_served_family_list^ [family_list_index].server_lifetime > highest_server_lifetime) THEN
              highest_server_lifetime := dfv$served_family_table_root.p_family_list_pointer_array^
                   [pointers_index].p_served_family_list^ [family_list_index].server_lifetime;
              server_state := dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
                   p_served_family_list^ [family_list_index].server_state;
              server_birthdate :=  dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
                   p_served_family_list^ [family_list_index].server_birthdate;
            IFEND;
          IFEND;
        FOREND /search_family_list/;
      FOREND /for_all_lists/;
    IFEND;
    dfp$clear_read_lock (dfv$served_family_table_lock);
  PROCEND dfp$get_highest_sf_lifetime;
?? TITLE := '[XDCL, #GATE] dfp$get_served_family_names ', EJECT ??
*copyc dfh$get_served_family_names

  PROCEDURE [XDCL, #GATE] dfp$get_served_family_names
    (VAR family_names: pmt$family_name_list;
     VAR family_count: pmt$family_name_count;
     VAR status: ost$status);

    VAR
      family_list_index: dft$served_family_list_index,
      pointers_index: dft$family_pointer_index,
      served_family_table_entry: dft$served_family_table_entry;

    status.normal := TRUE;
    family_count := 0;
    dfp$set_read_lock (dfv$served_family_table_lock);

    IF dfv$served_family_table_root.valid THEN

    /for_all_lists/
      FOR pointers_index := 1 TO dfv$served_family_table_root.number_of_active_pointers DO

      /search_family_list/
        FOR family_list_index := 1 TO dfv$served_family_table_root.
              p_family_list_pointer_array^ [pointers_index].highest_valid_entry DO
          served_family_table_entry := dfv$served_family_table_root.
                p_family_list_pointer_array^ [pointers_index].p_served_family_list^ [family_list_index];
          IF served_family_table_entry.server_state <> dfc$deleted THEN
            family_count := family_count + 1;
            IF family_count > UPPERBOUND (family_names) THEN
              { Despite an error, continue counting the families.
              osp$set_status_abnormal (dfc$file_server_id, pme$result_array_too_small, '', status);
            ELSE
              family_names [family_count] := served_family_table_entry.family_name;
            IFEND;
          IFEND;
        FOREND /search_family_list/;
      FOREND /for_all_lists/;
    IFEND;
    dfp$clear_read_lock (dfv$served_family_table_lock);

  PROCEND dfp$get_served_family_names;
?? TITLE := ' [XDCL] dfp$get_server_mainframe_list', eject ??
{
{   This procedure return a list of server mainframes from the served family table.
{ If server count > Upperbound (p_server_mainframes^) then server_count may be
{ inaccurate. The requested_states parameter is used to specify that only
{ servers in the specified state be returned.
{
  PROCEDURE [XDCL] dfp$get_server_mainframe_list
    (    requested_states: dft$server_states;
     VAR server_mainframes: dft$partner_mainframe_list;
     VAR server_count: dft$partner_mainframe_count);


    FUNCTION min
      (    value_a: integer;
           value_b: integer): integer;

      IF value_a < value_b THEN
        min := value_a;
      ELSE
        min := value_b;
      IFEND;
    FUNCEND min;

    VAR
      family_list_index: dft$served_family_list_index,
      mainframe: dft$partner_mainframe_count,
      pointers_index: dft$family_pointer_index,
      served_family_table_entry: dft$served_family_table_entry;

    server_count := 0;
    dfp$set_read_lock (dfv$served_family_table_lock);

    IF dfv$served_family_table_root.valid THEN

    /for_all_lists/
      FOR pointers_index := 1 TO dfv$served_family_table_root.number_of_active_pointers DO

      /search_family_list/
        FOR family_list_index := 1 TO dfv$served_family_table_root.
              p_family_list_pointer_array^ [pointers_index].highest_valid_entry DO
          served_family_table_entry := dfv$served_family_table_root.
                p_family_list_pointer_array^ [pointers_index].p_served_family_list^ [family_list_index];

          IF served_family_table_entry.server_state IN requested_states THEN

          /search_for_duplicate_server/
            FOR mainframe := 1 TO min (server_count, UPPERBOUND (server_mainframes)) DO
              IF served_family_table_entry.server_mainframe_id = server_mainframes [mainframe].
                    mainframe_id THEN
                {Mainframe already recorded}
                CYCLE /search_family_list/
              IFEND;
            FOREND /search_for_duplicate_server/;
            server_count := server_count + 1;
            IF server_count <= UPPERBOUND (server_mainframes) THEN
              server_mainframes [server_count].mainframe_id := served_family_table_entry.server_mainframe_id;
              server_mainframes [server_count].partner_state := served_family_table_entry.server_state;
            IFEND;
          IFEND;
        FOREND /search_family_list/;
      FOREND /for_all_lists/;
    IFEND;
    dfp$clear_read_lock (dfv$served_family_table_lock);
  PROCEND dfp$get_server_mainframe_list;

?? TITLE := '[XDCL, #GATE] dfp$get_server_state_string ', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$get_server_state_string
    (    server_state: dft$server_state;
     VAR server_state_string: string (*) );

    osp$verify_system_privilege;
    server_state_string := dfv$server_state_string[server_state];

  PROCEND dfp$get_server_state_string;
?? TITLE := '[XDCL, #GATE] dfp$locate_every_served_family ', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$locate_every_served_family
    (    family: ost$family_name;
     VAR family_found: boolean;
     VAR served_family_table_index: dft$served_family_table_index;
     VAR server_mainframe_id: pmt$binary_mainframe_id;
     VAR p_queue_interface_table: dft$p_queue_interface_table;
     VAR queue_index: dft$queue_index;
     VAR server_state: dft$server_state);

    VAR
      verified_by_server: boolean;

    osp$verify_system_privilege;
    dfp$set_read_lock (dfv$served_family_table_lock);

    locate_served_family (family, family_found, served_family_table_index, server_mainframe_id,
          p_queue_interface_table, queue_index, server_state, verified_by_server);

    dfp$clear_read_lock (dfv$served_family_table_lock);

    IF family_found THEN
      family_found := dfv$family_access_enabled;
    IFEND;

  PROCEND dfp$locate_every_served_family;
?? TITLE := '[XDCL, #GATE] dfp$locate_served_family ', EJECT ??
*copyc dfh$locate_served_family

  PROCEDURE [XDCL, #GATE] dfp$locate_served_family
    (    family: ost$family_name;
     VAR family_found: boolean;
     VAR served_family_table_index: dft$served_family_table_index;
     VAR server_mainframe_id: pmt$binary_mainframe_id;
     VAR p_queue_interface_table: dft$p_queue_interface_table;
     VAR queue_index: dft$queue_index;
     VAR server_state: dft$server_state);

    VAR
      verified_by_server: boolean;

    #KEYPOINT (osk$entry, 0, dfk$locate_served_family);
    osp$verify_system_privilege;
    dfp$set_read_lock (dfv$served_family_table_lock);

    locate_served_family (family, family_found, served_family_table_index, server_mainframe_id,
          p_queue_interface_table, queue_index, server_state, verified_by_server);

    dfp$clear_read_lock (dfv$served_family_table_lock);
    IF family_found THEN
      #KEYPOINT (osk$exit, osk$m * served_family_table_index.pointers_index *
            served_family_table_index.family_list_index, dfk$locate_served_family);
      family_found := verified_by_server AND dfv$family_access_enabled;
    ELSE
      #KEYPOINT (osk$exit, 0, dfk$locate_served_family);
    IFEND;
  PROCEND dfp$locate_served_family;

?? TITLE := '[XDCL] dfp$register_served_families', EJECT ??
  PROCEDURE [XDCL] dfp$register_served_families
    (    family_list: dft$family_list;
         family_access: dft$family_access;
         client_definition: boolean;
         p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
     VAR status: ost$status);

    VAR
      connection_type: dft$connection_type,
      family: 1 .. dfc$max_family_parameters,
      family_found: boolean,
      family_name_list: array [1 .. 1] OF ost$name,
      found_server_mainframe_id: pmt$binary_mainframe_id,
      ignore_index: dft$queue_index,
      ignore_status: ost$status,
      p_cpu_queue_header: ^dft$cpu_queue_header,
      p_found_queue_interface_tbl: ^dft$queue_interface_table,
      previous_server_state: dft$server_state,
      served_family_indexes: dft$served_family_table_index,
      served_family_table_entry: dft$served_family_table_entry,
      server_mainframe_found: boolean,
      server_mainframe_id: pmt$binary_mainframe_id,
      verified_by_server: boolean;

    status.normal := TRUE;
    dfp$set_write_lock (dfv$served_family_table_lock);

    p_cpu_queue_header := ^p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
         p_cpu_queue^.queue_header;
    connection_type := p_cpu_queue_header^.connection_type;
    server_mainframe_id := p_cpu_queue_header^.destination_mainframe_id;

    /register_all_families/
      FOR family := LOWERBOUND (family_list) TO UPPERBOUND (family_list) DO
        locate_served_family (family_list [family], family_found, served_family_indexes,
              found_server_mainframe_id, p_found_queue_interface_tbl, ignore_index, previous_server_state,
              verified_by_server);
        IF family_found THEN
          IF server_mainframe_id = found_server_mainframe_id THEN
            initialize_served_family_entry (family_access, server_mainframe_id, connection_type,
                 p_queue_interface_table, queue_index, dfv$served_family_table_root.
                 p_family_list_pointer_array^
                 [served_family_indexes.pointers_index].p_served_family_list^ [served_family_indexes.
                 family_list_index]);
            IF (p_cpu_queue_header^.partner_status.server_state = dfc$active) AND
               (previous_server_state <> dfc$active) AND ((dfc$remote_login_access IN family_access) OR
               (dfc$job_leveling_access IN family_access)) THEN
              { What if it got queued up previously?
              family_name_list [1] := family_list [family];
              jmp$activate_deferred_family (^family_name_list);
            IFEND;
            IF (p_cpu_queue_header^.partner_status.server_state = dfc$inactive) OR
               (p_cpu_queue_header^.partner_status.server_state = dfc$awaiting_recovery) AND
               (previous_server_state <> p_cpu_queue_header^.partner_status.server_state) THEN
              { Even if the current family_access does not allow login or leveling
              { there might be a job left over.
              family_name_list [1] := family_list [family];
              jmp$defer_deactivated_family (^family_name_list);
            IFEND;

          ELSE  { The family has been registered to a different mainframe.
             IF verified_by_server AND (previous_server_state = dfc$active) THEN
               { Don't allow redirecting an active family to a different mainframe.
               { Note: Changes in the policy of when to allow redirecting a family
               {  should also be reflected in procedure verify_families_not_registered.
               osp$set_status_abnormal (dfc$file_server_id, dfe$family_already_defined,
                    family_list [family], status);
               EXIT /register_all_families/;
            IFEND;
            create_served_family_entry (family_list [family], family_access, server_mainframe_id,
                 connection_type, p_queue_interface_table, queue_index, status);
            IF NOT status.normal THEN
              EXIT /register_all_families/;
            IFEND;
            IF (p_cpu_queue_header^.partner_status.server_state = dfc$active) AND
               ((dfc$remote_login_access IN family_access) OR
                     (dfc$job_leveling_access IN family_access)) THEN
              family_name_list [1] := family_list [family];
              jmp$activate_deferred_family (^family_name_list);
            IFEND;
            set_moved_family_name (served_family_indexes);
          IFEND;

        ELSE  { Family not found
          create_served_family_entry (family_list [family], family_access, server_mainframe_id,
               connection_type, p_queue_interface_table, queue_index, status);
          IF NOT status.normal THEN
            EXIT /register_all_families/;
          IFEND;
          IF (p_cpu_queue_header^.partner_status.server_state = dfc$active)  AND
               ((dfc$remote_login_access IN family_access) OR
                     (dfc$job_leveling_access IN family_access)) THEN
            family_name_list [1] := family_list [family];
            jmp$activate_deferred_family (^family_name_list);
          IFEND;
        IFEND;
      FOREND /register_all_families/;

      IF status.normal AND (p_cpu_queue_header^.partner_status.server_state = dfc$active) AND
            client_definition THEN
        p_cpu_queue_header^.partner_status.verify_family := TRUE;
      IFEND;

    dfp$clear_write_lock (dfv$served_family_table_lock);

    dfp$flush_served_family_table (ignore_status);
  PROCEND dfp$register_served_families;
?? TITLE := '[XDCL] dfp$store_served_family_entry ', EJECT ??
  PROCEDURE [XDCL] dfp$store_served_family_entry
    (    served_family_table_entry: dft$served_family_table_entry;
     VAR served_family_table_index: dft$served_family_table_index;
     VAR status: ost$status);

    VAR
      actual: integer,
      free_entry_found: boolean,
      served_family_list_pointer: dft$served_family_list_pointer,
      table_full: boolean;

    status.normal := TRUE;

    IF NOT dfv$served_family_table_root.valid THEN
      create_family_table_root (dfv$served_family_table_root);
    IFEND;

    locate_free_entry (dfv$served_family_table_root, table_full, free_entry_found, served_family_table_index);

    IF table_full THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$maximum_families_configured,
            served_family_table_entry.family_name, status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            (dfc$served_family_list_size * dfv$number_served_family_lists), {Base =} 10,
            { Display base = } FALSE, status);
    ELSE
      IF NOT free_entry_found THEN
        create_family_list (served_family_list_pointer);
        update_pointer_array (served_family_list_pointer, dfv$served_family_table_root,
              served_family_table_index.pointers_index);
        served_family_table_index.family_list_index := LOWERBOUND (served_family_list_pointer.
              p_served_family_list^);
      IFEND;
      dfv$served_family_table_root.p_family_list_pointer_array^ [served_family_table_index.pointers_index].
            p_served_family_list^ [served_family_table_index.family_list_index] := served_family_table_entry;
      #SPOIL (dfv$served_family_table_root.p_family_list_pointer_array^
            [served_family_table_index.pointers_index].p_served_family_list^
            [served_family_table_index.family_list_index]);
      osp$increment_locked_variable (dfv$served_family_table_root.
            p_family_list_pointer_array^ [served_family_table_index.pointers_index].highest_valid_entry,
            dfv$served_family_table_root.p_family_list_pointer_array^
            [served_family_table_index.pointers_index].highest_valid_entry, actual);
    IFEND;
  PROCEND dfp$store_served_family_entry;
?? TITLE := '[XDCL, #GATE] dfp$$served_family_access', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to implement the command language
{   function $served_family_access.
{

  PROCEDURE [XDCL, #GATE] dfp$$served_family_access
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      client_adt: [STATIC, READ, cls$adt] array [1 .. 2] of clt$argument_descriptor :=
            [[[clc$required], [NIL, clc$name_value, 1, osc$max_name_size]],
            [[clc$required], [NIL, clc$name_value, 1, osc$max_name_size]]];

    VAR
      access_string: string (7),
      avt: array [1 .. 2] of clt$value,
      family_access: dft$family_access,
      family_known: boolean,
      family_name: ost$family_name,
      ignore_leveler_status: jmt$jl_job_leveler_status,
      ignore_server_state: dft$server_state,
      server_mainframe_name: pmt$mainframe_id;

    clp$scan_argument_list (function_name, argument_list, ^client_adt, ^avt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server_mainframe_name := avt [1].name.value;
    {NOTE: server_mainframe_name not currently used.

    family_name := avt [2].name.value;

    dfp$get_family_access (family_name, family_known, family_access, ignore_server_state,
          ignore_leveler_status);

    value.descriptor := 'STRING';
    value.kind := clc$string_value;

    IF NOT family_known THEN
      value.str.size := 7;
      value.str.value := 'UNKNOWN';
    ELSEIF family_access = $dft$family_access [] THEN
      value.str.size := 4;
      value.str.value := 'NONE';
    ELSEIF dfc$job_leveling_access IN family_access THEN
      value.str.size := 7;
      value.str.value := 'LEVELED';
    ELSEIF dfc$remote_login_access IN family_access THEN
      value.str.size := 5;
      value.str.value := 'LOGIN';
    ELSEIF dfc$remote_file_access IN family_access THEN
      value.str.size := 4;
      value.str.value := 'FILE';
    IFEND;

  PROCEND dfp$$served_family_access;

?? TITLE := 'crack_define_family_command ', EJECT ??
  PROCEDURE crack_define_family_command
    (    parameter_list: clt$parameter_list;
     VAR family_list_container: dft$family_list_container;
     VAR family_list_p: dft$p_family_list;
     VAR server_mainframe_name: pmt$mainframe_id;
     VAR server_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

{ PROCEDURE define_served_family, defsf (
{   server_mainframe_identifier, smi: name pmc$mainframe_id_size = $required
{   family, families, f: list 1 .. dfc$max_family_parameters of name = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 8, 30, 13, 1, 52, 677],
    clc$command, 6, 3, 2, 0, 0, 0, 3, ''], [
    ['F                              ',clc$abbreviation_entry, 2],
    ['FAMILIES                       ',clc$alias_entry, 2],
    ['FAMILY                         ',clc$nominal_entry, 2],
    ['SERVER_MAINFRAME_IDENTIFIER    ',clc$nominal_entry, 1],
    ['SMI                            ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [pmc$mainframe_id_size, pmc$mainframe_id_size]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [5, 1, dfc$max_family_parameters, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$server_mainframe_identifier = 1,
      p$family = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_family_list (pvt [p$family].value, family_list_container, family_list_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server_mainframe_name := pvt [p$server_mainframe_identifier].value^.name_value;
    dfp$new_crack_mainframe_id (server_mainframe_name, server_mainframe_id, status);

  PROCEND crack_define_family_command;

?? TITLE := 'crack_define_server ', EJECT ??
  PROCEDURE crack_define_server
    (    parameter_list: clt$parameter_list;
     VAR family_list_container: dft$family_list_container;
     VAR family_list_p: dft$p_family_list;
     VAR server_mainframe_name: pmt$mainframe_id;
     VAR server_mainframe_id: pmt$binary_mainframe_id;
     VAR connection_parameters: dft$connection_parameters;
     VAR status: ost$status);

{ PROCEDURE define_server, defs (
{   family, families, f: list 1 .. dfc$max_family_parameters of name
{   server_mainframe_identifier, smi: name pmc$mainframe_id_size = $required
{   client_id_number, cin, cidn: integer 1 .. dfc$max_number_of_mainframes  = $required
{   server_id_number, sin, sidn: integer 1 .. dfc$max_number_of_mainframes = $required
{   number_of_monitor_queue_entries, nomqe: integer 0 .. dfc$max_queue_entries-2 = 50
{   number_of_task_queue_entries, notqe: integer 1 .. dfc$max_queue_entries-2 = 4
{   connection_type, ct: any of key stornet keyend, name, anyend = stornet
{   element_name, en: name = $required
{   send_channel, sc: list 1 .. 2 of name = $required
{   receive_channel, rc: list 1 .. 2 of name
{   dma_available, da: boolean  = true
{   timeout_interval, ti: integer 1 .. dfc$maximum_timeout = 10
{   maximum_request_timeout_count, mrtc: integer 1 .. dfc$max_req_timeout_count_value = 5
{   maximum_retransmission_count, mrc: integer 1 .. dfc$max_retransmit_count_value = 5
{   users_wait_on_terminated, uwot: boolean = true
{   preallocate_image_size, pis: integer 0 .. osc$max_segment_length = 0
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 36] of clt$pdt_parameter_name,
      parameters: array [1 .. 17] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (2),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type7: 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$name_type_qualifier,
        recend,
        default_value: string (7),
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type11: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (2),
      recend,
      type13: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type14: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type15: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type17: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 8, 30, 12, 57, 47, 246],
    clc$command, 36, 17, 5, 0, 0, 0, 17, ''], [
    ['CIDN                           ',clc$abbreviation_entry, 3],
    ['CIN                            ',clc$alias_entry, 3],
    ['CLIENT_ID_NUMBER               ',clc$nominal_entry, 3],
    ['CONNECTION_TYPE                ',clc$nominal_entry, 7],
    ['CT                             ',clc$abbreviation_entry, 7],
    ['DA                             ',clc$abbreviation_entry, 11],
    ['DMA_AVAILABLE                  ',clc$nominal_entry, 11],
    ['ELEMENT_NAME                   ',clc$nominal_entry, 8],
    ['EN                             ',clc$abbreviation_entry, 8],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FAMILIES                       ',clc$alias_entry, 1],
    ['FAMILY                         ',clc$nominal_entry, 1],
    ['MAXIMUM_REQUEST_TIMEOUT_COUNT  ',clc$nominal_entry, 13],
    ['MAXIMUM_RETRANSMISSION_COUNT   ',clc$nominal_entry, 14],
    ['MRC                            ',clc$abbreviation_entry, 14],
    ['MRTC                           ',clc$abbreviation_entry, 13],
    ['NOMQE                          ',clc$abbreviation_entry, 5],
    ['NOTQE                          ',clc$abbreviation_entry, 6],
    ['NUMBER_OF_MONITOR_QUEUE_ENTRIES',clc$nominal_entry, 5],
    ['NUMBER_OF_TASK_QUEUE_ENTRIES   ',clc$nominal_entry, 6],
    ['PIS                            ',clc$abbreviation_entry, 16],
    ['PREALLOCATE_IMAGE_SIZE         ',clc$nominal_entry, 16],
    ['RC                             ',clc$abbreviation_entry, 10],
    ['RECEIVE_CHANNEL                ',clc$nominal_entry, 10],
    ['SC                             ',clc$abbreviation_entry, 9],
    ['SEND_CHANNEL                   ',clc$nominal_entry, 9],
    ['SERVER_ID_NUMBER               ',clc$nominal_entry, 4],
    ['SERVER_MAINFRAME_IDENTIFIER    ',clc$nominal_entry, 2],
    ['SIDN                           ',clc$abbreviation_entry, 4],
    ['SIN                            ',clc$alias_entry, 4],
    ['SMI                            ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 17],
    ['TI                             ',clc$abbreviation_entry, 12],
    ['TIMEOUT_INTERVAL               ',clc$nominal_entry, 12],
    ['USERS_WAIT_ON_TERMINATED       ',clc$nominal_entry, 15],
    ['UWOT                           ',clc$abbreviation_entry, 15]],
    [
{ PARAMETER 1
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [28, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 4
    [27, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 5
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 6
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 7
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 8
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 9
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$required_parameter,
  0, 0],
{ PARAMETER 10
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 11
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 12
    [34, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 13
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 14
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 15
    [35, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 16
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 17
    [32, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 1, dfc$max_family_parameters, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$name_type], [pmc$mainframe_id_size, pmc$mainframe_id_size]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, dfc$max_number_of_mainframes, 10]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [1, dfc$max_number_of_mainframes, 10]],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [0, dfc$max_queue_entries-2, 10],
    '50'],
{ PARAMETER 6
    [[1, 0, clc$integer_type], [1, dfc$max_queue_entries-2, 10],
    '4'],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['STORNET                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'stornet'],
{ PARAMETER 8
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 9
    [[1, 0, clc$list_type], [5, 1, 2, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 10
    [[1, 0, clc$list_type], [5, 1, 2, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 11
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 12
    [[1, 0, clc$integer_type], [1, dfc$maximum_timeout, 10],
    '10'],
{ PARAMETER 13
    [[1, 0, clc$integer_type], [1, dfc$max_req_timeout_count_value, 10],
    '5'],
{ PARAMETER 14
    [[1, 0, clc$integer_type], [1, dfc$max_retransmit_count_value, 10],
    '5'],
{ PARAMETER 15
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 16
    [[1, 0, clc$integer_type], [0, osc$max_segment_length, 10],
    '0'],
{ PARAMETER 17
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$family = 1,
      p$server_mainframe_identifier = 2,
      p$client_id_number = 3,
      p$server_id_number = 4,
      p$number_of_monitor_queue_entri = 5 {NUMBER_OF_MONITOR_QUEUE_ENTRIES} ,
      p$number_of_task_queue_entries = 6,
      p$connection_type = 7,
      p$element_name = 8,
      p$send_channel = 9,
      p$receive_channel = 10,
      p$dma_available = 11,
      p$timeout_interval = 12,
      p$maximum_request_timeout_count = 13,
      p$maximum_retransmission_count = 14,
      p$users_wait_on_terminated = 15,
      p$preallocate_image_size = 16,
      p$status = 17;

    VAR
      pvt: array [1 .. 17] of clt$parameter_value;

    VAR
      computed_queue_size: ost$non_negative_integers,
      data_value: clt$data_value,
      esm_table_entry_p: ^dft$esm_definition_table_entry;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_family_list (pvt [p$family].value, family_list_container, family_list_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server_mainframe_name := pvt [p$server_mainframe_identifier].value^.name_value;
    dfp$new_crack_mainframe_id (server_mainframe_name, server_mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    connection_parameters.server_queue_index := pvt [p$client_id_number].value^.integer_value.value;
    connection_parameters.client_queue_index :=
          pvt [p$server_id_number].value^.integer_value.value + dfc$max_number_of_mainframes;
    connection_parameters.number_of_monitor_queue_entries :=
          pvt [p$number_of_monitor_queue_entri].value^.integer_value.value;
    connection_parameters.number_of_task_queue_entries :=
          pvt [p$number_of_task_queue_entries].value^.integer_value.value;

    { Add 1 to the sum of queue entries to account for the Poll Task.

    computed_queue_size := ((connection_parameters.number_of_monitor_queue_entries +
          connection_parameters.number_of_task_queue_entries + 1) * #SIZE (dft$driver_queue_entry)) +
          #SIZE (dft$driver_queue_header);
    IF computed_queue_size > osv$page_size THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$too_many_queue_entries, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, computed_queue_size, 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, osv$page_size, 10, FALSE, status);
      RETURN;
    IFEND;

    connection_parameters.client_to_server.client_to_server := TRUE;
    connection_parameters.client_to_server.users_wait_on_terminated :=
          pvt [p$users_wait_on_terminated].value^.boolean_value.value;
    connection_parameters.client_to_server.preallocate_image_size :=
          pvt [p$preallocate_image_size].value^.integer_value.value;
    connection_parameters.client_to_server.timeout_interval :=
          pvt [p$timeout_interval].value^.integer_value.value;
    connection_parameters.client_to_server.maximum_request_timeout_count :=
          pvt [p$maximum_request_timeout_count].value^.integer_value.value;
    connection_parameters.client_to_server.maximum_retransmission_count :=
          pvt [p$maximum_retransmission_count].value^.integer_value.value;

    IF (pvt [p$connection_type].value^.kind = clc$keyword) AND
          (pvt [p$connection_type].value^.keyword_value = 'STORNET') THEN
      connection_parameters.connection_type := dfc$esm_connection;
      connection_parameters.esm_parameters.element_name := pvt [p$element_name].value^.name_value;

      data_value := pvt [p$send_channel].value^;
      connection_parameters.esm_parameters.send_channel.channel_name := data_value.element_value^.name_value;
      IF data_value.link = NIL THEN
        connection_parameters.esm_parameters.send_channel.iou_name := dfc$iou_name0;
      ELSE
        data_value := data_value.link^;
        IF (data_value.element_value^.name_value <> dfc$iou_name0) AND
              (data_value.element_value^.name_value <> dfc$iou_name1) THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$send_channel_invalid_iou,
                data_value.element_value^.name_value, status);
          RETURN;
        IFEND;
        connection_parameters.esm_parameters.send_channel.iou_name :=
              data_value.element_value^.name_value;
      IFEND;
      dfp$verify_stornet_channel (connection_parameters.esm_parameters.element_name,
            connection_parameters.esm_parameters.send_channel, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT pvt [p$receive_channel].specified THEN
        connection_parameters.esm_parameters.receive_channel :=
              connection_parameters.esm_parameters.send_channel;
      ELSE
        data_value := pvt [p$receive_channel].value^;
        connection_parameters.esm_parameters.receive_channel.channel_name :=
              data_value.element_value^.name_value;
        IF data_value.link = NIL THEN
          connection_parameters.esm_parameters.receive_channel.iou_name :=
                connection_parameters.esm_parameters.send_channel.iou_name;
        ELSE
          data_value := data_value.link^;
          IF (data_value.element_value^.name_value <> dfc$iou_name0) AND
                (data_value.element_value^.name_value <> dfc$iou_name1) THEN
            osp$set_status_abnormal (dfc$file_server_id, dfe$receive_channel_invalid_iou,
                  data_value.element_value^.name_value, status);
            RETURN;
          IFEND;
          connection_parameters.esm_parameters.receive_channel.iou_name :=
                data_value.element_value^.name_value;
        IFEND;
        dfp$verify_stornet_channel (connection_parameters.esm_parameters.element_name,
              connection_parameters.esm_parameters.receive_channel, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      connection_parameters.esm_parameters.source_id_number :=
            pvt [p$client_id_number].value^.integer_value.value;
      connection_parameters.esm_parameters.destination_id_number :=
            pvt [p$server_id_number].value^.integer_value.value;
      connection_parameters.esm_parameters.dma_available := pvt [p$dma_available].value^.boolean_value.value;

      dfp$locate_esm_definition (connection_parameters.esm_parameters.element_name, esm_table_entry_p);
      IF esm_table_entry_p = NIL THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$stornet_not_defined,
             connection_parameters.esm_parameters.element_name, status);
        RETURN;
      IFEND;
      connection_parameters.esm_parameters.esm_memory_size := esm_table_entry_p^.memory_size;
      connection_parameters.esm_parameters.esm_base_addresses := esm_table_entry_p^.esm_base_addresses;
      connection_parameters.client_to_server.maximum_data_bytes := esm_table_entry_p^.maximum_data_bytes;

      connection_parameters.driver_name := connection_parameters.esm_parameters.send_channel.channel_name;

      IF pvt [p$client_id_number].value^.integer_value.value >
            connection_parameters.esm_parameters.esm_base_addresses.number_of_mainframes THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$id_number_exceeds_nomf, 'Client', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              pvt [p$client_id_number].value^.integer_value.value, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              connection_parameters.esm_parameters.esm_base_addresses.number_of_mainframes, 10, FALSE,
              status);
        RETURN;
      IFEND;
      IF pvt [p$server_id_number].value^.integer_value.value >
            connection_parameters.esm_parameters.esm_base_addresses.number_of_mainframes THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$id_number_exceeds_nomf, 'Server', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              pvt [p$server_id_number].value^.integer_value.value, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              connection_parameters.esm_parameters.esm_base_addresses.number_of_mainframes, 10, FALSE,
              status);
        RETURN;
      IFEND;

    ELSEIF pvt [p$connection_type].value^.name_value = 'CDCNET' THEN
      connection_parameters.connection_type := dfc$cdcnet_connection;
      connection_parameters.driver_name := pvt [p$element_name].value^.name_value;
    ELSEIF pvt [p$connection_type].value^.name_value = 'MOCK' THEN
      connection_parameters.connection_type := dfc$mock_connection;
      connection_parameters.driver_name := pvt [p$element_name].value^.name_value;
    ELSE
      connection_parameters.driver_name := pvt [p$element_name].value^.name_value;
    IFEND;

  PROCEND crack_define_server;

?? TITLE := 'crack_family_list ', EJECT ??
  PROCEDURE crack_family_list
    (    family_value_list_p: ^clt$data_value;
     VAR family_list_container: dft$family_list_container;
     VAR family_list_p: dft$p_family_list;
     VAR status: ost$status);

    VAR
      family_list_container_p: ^dft$family_list_container,
      family_p: ^ost$name,
      family_value_p: ^clt$data_value,
      list_p: ^clt$data_value,
      number_of_families: integer;

    status.normal := TRUE;
    family_list_p := NIL;
    number_of_families := 0;
    family_list_container_p := ^family_list_container;
    RESET family_list_container_p;

    list_p := family_value_list_p;
    WHILE list_p <> NIL DO
      family_value_p := list_p^.element_value;
      list_p := list_p^.link;

      IF family_value_p^.name_value = osv$system_family_name THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$system_family_not_allowed,
              family_value_p^.name_value, status);
        RETURN;
      IFEND;

      NEXT family_p IN family_list_container_p;
      family_p^ := family_value_p^.name_value;
      number_of_families := number_of_families + 1;
    WHILEND;

    IF number_of_families > 0 THEN
      RESET family_list_container_p;
      NEXT family_list_p: [1 .. number_of_families] IN family_list_container_p;
    IFEND;

  PROCEND crack_family_list;

?? TITLE := 'create_family_list ', EJECT ??
  PROCEDURE create_family_list
    (VAR served_family_list_pointer: dft$served_family_list_pointer);

    VAR
      family: dft$served_family_list_index;

    served_family_list_pointer.highest_valid_entry := 0;
    ALLOCATE served_family_list_pointer.p_served_family_list IN dfv$server_wired_heap^;
    IF served_family_list_pointer.p_served_family_list = NIL THEN
      osp$system_error (' NIL FAMILY LIST POINTER ', NIL);
    IFEND;

  /blank_out_family_names/
    FOR family := LOWERBOUND (served_family_list_pointer.p_served_family_list^)
          TO UPPERBOUND (served_family_list_pointer.p_served_family_list^) DO
      served_family_list_pointer.p_served_family_list^ [family].family_name := ' ';
    FOREND /blank_out_family_names/;
  PROCEND create_family_list;
?? TITLE := 'create_family_table_root ', EJECT ??

  PROCEDURE create_family_table_root
    (VAR served_family_table_root: dft$served_family_table_root);

    VAR
      pointer_index: dft$family_pointer_index;

    ALLOCATE served_family_table_root.p_family_list_pointer_array: [1 .. dfv$number_served_family_lists] IN
          dfv$server_wired_heap^;
    IF served_family_table_root.p_family_list_pointer_array = NIL THEN
      osp$system_error (' NIL FAMILY TABLE ROOT', NIL);
    IFEND;

  /initialize_family_lists/
    FOR pointer_index := 1 TO dfv$number_served_family_lists DO
      served_family_table_root.p_family_list_pointer_array^ [pointer_index].highest_valid_entry := 0;
      served_family_table_root.p_family_list_pointer_array^ [pointer_index].p_served_family_list := NIL;
    FOREND /initialize_family_lists/;

    #SPOIL (served_family_table_root);
    served_family_table_root.number_of_active_pointers := 0;
    #SPOIL (served_family_table_root);
    served_family_table_root.valid := TRUE;
  PROCEND create_family_table_root;

?? TITLE := 'create_served_family_entry  ', EJECT ??
  PROCEDURE create_served_family_entry
    (    family_name: ost$family_name;
         family_access: dft$family_access;
         server_mainframe_id: pmt$binary_mainframe_id;
         connection_type: dft$connection_type;
         p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
     VAR status: ost$status);

    VAR
      p_cpu_queue_header: ^dft$cpu_queue_header,
      served_family_table_entry: dft$served_family_table_entry,
      served_family_table_index: dft$served_family_table_index;

    { Initialize entry before setting entry in use to assure consistant
    { structure.
    served_family_table_entry.family_name := family_name;
    initialize_served_family_entry (family_access, server_mainframe_id, connection_type,
         p_queue_interface_table, queue_index, served_family_table_entry);
    p_cpu_queue_header := ^p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
          p_cpu_queue^.queue_header;
    served_family_table_entry.server_lifetime := p_cpu_queue_header^.server_lifetime;
    served_family_table_entry.server_birthdate := p_cpu_queue_header^.server_birthdate;
    served_family_table_entry.active_since_deadstart :=
       (served_family_table_entry.server_state = dfc$active);
    status.normal := TRUE;

    dfp$store_served_family_entry (served_family_table_entry,
      served_family_table_index, status);
  PROCEND create_served_family_entry;

?? TITLE := 'define_asynchronous_task ', EJECT ??

  PROCEDURE define_asynchronous_task
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      program_attributes: llt$program_attributes,
      p_task_params: ^clt$parameter_list,
      parameter_string: ^clt$parameter_list_contents,
      spy_id: pmt$spy_identifier,
      string_length: integer,
      task_name: ost$name;

    dfp$format_task_name (mainframe_name, task_name);
    spy_id := 0;

    PUSH parameter_string: [STRLENGTH (mainframe_name)];
    parameter_string^.size := STRLENGTH (mainframe_name);
    parameter_string^.text := mainframe_name;
    p_task_params := #SEQ (parameter_string^);

    program_attributes.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$load_map_options_specified, pmc$term_error_level_specified];
    program_attributes.starting_procedure := c$asynchronous_start_procedure;
    program_attributes.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    program_attributes.termination_error_level := pmc$warning_load_errors;

    osp$define_system_task (task_name, {auto_restart=} FALSE,
          {deactivate_option=} osc$tt_terminate, {idle_option=} osc$tt_ignore_or_prohibited,
          {restart_after_idle=} TRUE, spy_id, {execution_ring=} osc$user_ring, #SEQ (program_attributes),
          p_task_params, status);

  PROCEND define_asynchronous_task;
?? TITLE := 'define_servers_catalog', EJECT ??
  PROCEDURE define_servers_catalog;

    VAR
      catalog_path: array [1 .. 3] of pft$name,
      status: ost$status;

    status.normal := TRUE;
    catalog_path [1] := ' ';
    catalog_path [2] := ' ';
    catalog_path [3] := dfc$server_mainframes_catalog;
    pfp$define_catalog (catalog_path, status);
    IF (NOT status.normal) AND (status.condition <> pfe$name_already_subcatalog) THEN
      RETURN;
    IFEND;
  PROCEND define_servers_catalog;
?? TITLE := 'initialize_served_family_entry', EJECT ??
{ Note: This routine must NOT set lifetinme or birthdate.

  PROCEDURE initialize_served_family_entry
    (    family_access: dft$family_access,
         server_mainframe_id: pmt$binary_mainframe_id;
         connection_type: dft$connection_type;
         p_queue_interface_table: ^dft$queue_interface_table;
         queue_index: dft$queue_index;
     VAR served_family_table_entry: dft$served_family_table_entry);

    VAR
      p_cpu_queue_header: ^dft$cpu_queue_header;

    served_family_table_entry.family_access := family_access;
    served_family_table_entry.server_mainframe_id := server_mainframe_id;
    served_family_table_entry.connection_type := connection_type;
    served_family_table_entry.p_queue_interface_table := p_queue_interface_table;
    served_family_table_entry.queue_index := queue_index;
    served_family_table_entry.verified_by_server := FALSE;
    p_cpu_queue_header := ^p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
          p_cpu_queue^.queue_header;
    served_family_table_entry.server_state := p_cpu_queue_header^.partner_status.server_state;
    IF served_family_table_entry.server_state = dfc$active THEN
      served_family_table_entry.active_since_deadstart := TRUE;
    IFEND;
  PROCEND initialize_served_family_entry;

?? TITLE := 'locate_free_entry ', EJECT ??
  PROCEDURE locate_free_entry
    (    served_family_table_root: dft$served_family_table_root;
     VAR table_full: boolean;
     VAR free_entry_found: boolean;
     VAR served_family_table_index: dft$served_family_table_index);

    VAR
      pointers_index: dft$family_pointer_index;

    table_full := FALSE;
    IF served_family_table_root.number_of_active_pointers = 0 THEN
      free_entry_found := FALSE;
    ELSE
      pointers_index := served_family_table_root.number_of_active_pointers;
      free_entry_found := served_family_table_root.p_family_list_pointer_array^ [pointers_index].
            highest_valid_entry < UPPERBOUND (served_family_table_root.
            p_family_list_pointer_array^ [pointers_index].p_served_family_list^);
    IFEND;
    IF free_entry_found THEN
      served_family_table_index.pointers_index := pointers_index;
      served_family_table_index.family_list_index := served_family_table_root.
            p_family_list_pointer_array^ [served_family_table_index.pointers_index].highest_valid_entry + 1;
      RETURN;
    IFEND;

    table_full := served_family_table_root.number_of_active_pointers =
          UPPERBOUND (served_family_table_root.p_family_list_pointer_array^);
  PROCEND locate_free_entry;
?? TITLE := 'locate_served_family ', EJECT ??

  PROCEDURE locate_served_family
    (    family: ost$family_name;
     VAR family_found: boolean;
     VAR served_family_table_index: dft$served_family_table_index;
     VAR server_mainframe_id: pmt$binary_mainframe_id;
     VAR p_queue_interface_table: dft$p_queue_interface_table;
     VAR queue_index: dft$queue_index;
     VAR server_state: dft$server_state;
     VAR verified_by_server: boolean);

    VAR
      family_list_index: dft$served_family_list_index,
      pointers_index: dft$family_pointer_index,
      served_family_table_entry: dft$served_family_table_entry;

    IF dfv$served_family_table_root.valid THEN

    /for_all_lists/
      FOR pointers_index := 1 TO dfv$served_family_table_root.number_of_active_pointers DO

      /search_family_list/
        FOR family_list_index := 1 TO dfv$served_family_table_root.
              p_family_list_pointer_array^ [pointers_index].highest_valid_entry DO
          { Assume no deletion
          IF (dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
                p_served_family_list^ [family_list_index].family_name = family) THEN
            family_found := TRUE;
            served_family_table_index.pointers_index := pointers_index;
            served_family_table_index.family_list_index := family_list_index;
            served_family_table_entry := dfv$served_family_table_root.
                  p_family_list_pointer_array^ [pointers_index].p_served_family_list^ [family_list_index];
            server_mainframe_id := served_family_table_entry.server_mainframe_id;
            p_queue_interface_table := served_family_table_entry.p_queue_interface_table;
            queue_index := served_family_table_entry.queue_index;
            server_state := served_family_table_entry.server_state;
            verified_by_server := served_family_table_entry.verified_by_server;
            RETURN;
          IFEND;
        FOREND /search_family_list/;
      FOREND /for_all_lists/;
    IFEND;
    family_found := FALSE;
  PROCEND locate_served_family;

?? TITLE := 'process_new_mainframe ', EJECT ??
  PROCEDURE process_new_mainframe
    (    connection_parameters: dft$connection_parameters;
         server_mainframe_name: pmt$mainframe_id;
         server_mainframe_id: pmt$binary_mainframe_id;
     VAR queue_interface_table_p: ^dft$queue_interface_table;
     VAR status: ost$status);

    VAR
      client_queue_index: dft$queue_index,
      cpu_queue_p: ^dft$cpu_queue,
      found_server_mainframe_id: pmt$binary_mainframe_id,
      ignore_directory_entry_p: ^dft$q_interface_directory_entry,
      image_file_exists: boolean,
      queue_index: dft$queue_index,
      served_family_table_index: dft$served_family_table_index,
      server_mainframe_found: boolean,
      server_to_client: boolean;

    status.normal := TRUE;
    server_to_client := FALSE;
    dfp$find_mainframe_id (server_mainframe_name, server_to_client, server_mainframe_found,
          queue_interface_table_p, cpu_queue_p, queue_index, ignore_directory_entry_p);
    IF server_mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$server_already_defined, server_mainframe_name, status);
      RETURN;
    IFEND;

    dfp$create_queue (connection_parameters, server_mainframe_name, server_mainframe_id, server_to_client,
          queue_interface_table_p, status);
    client_queue_index := connection_parameters.client_queue_index;
    IF status.normal THEN
      dfp$record_server_translation (server_mainframe_id);
      define_servers_catalog;
      dfp$create_image_file (server_mainframe_id,
            connection_parameters.client_to_server.preallocate_image_size, image_file_exists, status);
    IFEND;
    IF status.normal AND (connection_parameters.connection_type = dfc$cdcnet_connection) THEN
      dfp$start_cdcnet_client (queue_interface_table_p, connection_parameters.driver_name,
            server_mainframe_name, client_queue_index, status);
    IFEND;

  PROCEND process_new_mainframe;

?? TITLE := 'set_moved_family_name ', EJECT ??
{
{ This procedure sets the family name in the served family entry to a value that will
{ not be found by any of the search routines.  The family entry must remain valid
{ and cannot be re-used because we don't know if there are outstanding users of the
{ served_family_table_index, for example attached files.  We cannot reliably assign
{ a new lifetime because define_served_family may be done after the server is already
{ active.

  PROCEDURE set_moved_family_name
    (    served_family_table_index: dft$served_family_table_index);

    VAR
      p_served_family_entry: ^dft$served_family_table_entry;

    p_served_family_entry := ^dfv$served_family_table_root.
          p_family_list_pointer_array^ [served_family_table_index.pointers_index].
          p_served_family_list^ [served_family_table_index.family_list_index];

    #TRANSLATE (osv$upper_to_lower, p_served_family_entry^.family_name, p_served_family_entry^.family_name);

    p_served_family_entry^.family_name (osc$max_name_size) := '*';

  PROCEND set_moved_family_name;
?? TITLE := 'set_served_family_queue_info', EJECT ??

{   This procedure changes queue information in the Served_Family_Table to one
{   requested by the input parameters. It selects the Family entries by
{   matching the the mainframe_id supplied by the input parameter with
{   one in the Served_Family_Table.

  PROCEDURE set_served_family_queue_info
    (    mainframe_id: pmt$binary_mainframe_id;
         p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index);

    VAR
      family_list_index: dft$served_family_list_index,
      p_family_list: ^array [dft$served_family_list_index] of dft$served_family_table_entry,
      pointers_index: dft$family_pointer_index;

    dfp$set_read_lock (dfv$served_family_table_lock);
    IF dfv$served_family_table_root.valid THEN

    /for_all_pointers/
      FOR pointers_index := 1 TO dfv$served_family_table_root.number_of_active_pointers DO
        p_family_list := dfv$served_family_table_root.p_family_list_pointer_array^ [pointers_index].
              p_served_family_list;

      /search_family_list/
        FOR family_list_index := 1 TO dfv$served_family_table_root.
              p_family_list_pointer_array^ [pointers_index].highest_valid_entry DO

          IF (p_family_list^ [family_list_index].server_mainframe_id = mainframe_id) THEN
            p_family_list^ [family_list_index].p_queue_interface_table := p_queue_interface_table;
            p_family_list^ [family_list_index].queue_index := queue_index;
          IFEND;

        FOREND /search_family_list/;
      FOREND /for_all_pointers/;

    IFEND;
    dfp$clear_read_lock (dfv$served_family_table_lock);

  PROCEND set_served_family_queue_info;

?? TITLE := 'update_pointer_array ', EJECT ??
  PROCEDURE update_pointer_array
    (    served_family_list_pointer: dft$served_family_list_pointer;
     VAR served_family_table_root: {Input, Output} dft$served_family_table_root;
     VAR assigned_pointers_index: dft$family_pointer_index);

    VAR
      actual: integer;

    served_family_table_root.p_family_list_pointer_array^
          [served_family_table_root.number_of_active_pointers + 1] := served_family_list_pointer;
    #SPOIL (served_family_table_root.p_family_list_pointer_array^
          [served_family_table_root.number_of_active_pointers + 1]);
    osp$increment_locked_variable (served_family_table_root.number_of_active_pointers,
          served_family_table_root.number_of_active_pointers, actual);
    assigned_pointers_index := served_family_table_root.number_of_active_pointers;
  PROCEND update_pointer_array;

?? TITLE := 'verify_families_not_registered ', EJECT ??
  PROCEDURE verify_families_not_registered
    (    family_list: dft$family_list;
         requested_mainframe: pmt$binary_mainframe_id;
     VAR status: ost$status);

    VAR
      family: 1 .. dfc$max_family_parameters,
      family_found: boolean,
      ignore_indexes: dft$served_family_table_index,
      ignore_p_qit: ^dft$queue_interface_table,
      ignore_queue_index: dft$queue_index,
      ignore_verification: boolean,
      registered_mainframe: pmt$binary_mainframe_id,
      server_state: dft$server_state;

    status.normal := TRUE;
  /locate_each_family/
    FOR family := LOWERBOUND (family_list) TO UPPERBOUND (family_list) DO
      locate_served_family (family_list [family], family_found, ignore_indexes, registered_mainframe,
           ignore_p_qit, ignore_queue_index, server_state, ignore_verification);
      IF family_found AND ((server_state = dfc$active) OR ((requested_mainframe = registered_mainframe) AND
          ((server_state <> dfc$deleted) AND (server_state <> dfc$terminated) AND
          (server_state <> dfc$awaiting_recovery)))) THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$family_already_defined, family_list [family],
             status);
        EXIT /locate_each_family/;
      IFEND;
    FOREND /locate_each_family/;

  PROCEND verify_families_not_registered;
?? OLDTITLE ??
?? OLDTITLE ??
MODEND dfm$served_family_manager;
*DECK DECK=DFM$SERVER_REMOTE_PROCEDUR_CALL EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE File Server : Server :  Remote Procedure Call' ??
MODULE dfm$server_remote_procedur_call;
{
{  This module contains the server side of the remote procedure call
{  processing. The client initiates the request, and the server determines
{  what to do based on information passed to it, and the state recorded in the
{  cpu queue.
{  A few notes about the server side processing:
{  - The server always prompts for data.
{  - The server frees all receive data only after it has called the
{    user procedure.  The server frees send pages as it goes.  If a request
{    is not restartable the server leaves the last four pages of send data,
{    wired down until the next request.  These pages are used on retransmission.
{  - The server waits following a prompt for data.
{  - If the server detects a need to restart the request the status
{    dfe$restart_server_request or dfe$bad_client_job_id is returned to the client.
{  - If the incoming request is a permanent file call the clone tasks
{    environment is made to appear as if it is running on behalf of the
{    users job on the client.
{ -  In the effect of certain errors, the request will stop processing to
{    allow the timeout processing to timeout the request, and retransmit.
{
{  When adding procedures to the procedure list, it must be determined if the request
{  on the server may be re-issued in the event of a need for retransmission,
{  and if the request should run on behalf of the user making the request or
{  run on behalf of the system user.  The XREF to the remote procedure should
{  be added here, to the appropriate area.
{
?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc dfc$client_pause_break
*copyc dfc$client_terminate_break
*copyc dfc$remote_core_call
*copyc dfc$test_jr_constants
*copyc dfd$driver_queue_types
*copyc dfd$request_package
*copyc dfe$error_condition_codes
*copyc dfk$keypoints
*copyc dft$action_for_server
*copyc dft$cpu_queue
*copyc dft$procedure_address_ordinal
*copyc dft$procedure_address_range
*copyc dft$procedure_version
*copyc dft$rpc_buffer_header
*copyc dft$rpc_parameters
*copyc dft$rpc_procedure_address_list
*copyc dft$rpc_queue_entry_location
*copyc dft$server_location
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
?? EJECT ??
*copyc dfi$console_display
*copyc dfi$display
*copyc dfp$await_server_subsystem
*copyc dfp$clear_server_driver_flags
*copyc dfp$delete_server_rpc_segment
*copyc dfp$initialize_rma_list
*copyc dfp$page_count
*copyc dfp$pop_job_unrecoverable
*copyc dfp$push_job_unrecoverable
*copyc dfp$queue_server_task_request
*copyc dfp$set_client_job_environment
*copyc dfp$touch_pages
*copyc dfp$validate_client_job_id
*copyc dfp$word_boundary
*copyc dfv$file_server_debug_enabled
*copyc dfv$p_client_mainframe_file
*copyc dfv$p_proc_addresses
*copyc dfv$send_command_and_data_flags
*copyc dfv$send_command_flags
*copyc dfv$send_ready_for_data_flags
*copyc dfv$test_retransmission_count
*copyc dfv$test_retransmit_retransmit
*copyc i#current_sequence_position
*copyc mmp$free_pages
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$establish_condition_handler
*copyc osp$recoverable_system_error
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc osp$system_error
*copyc pfp$log_error
*copyc pfp$r2_df_server_get_obj_info
*copyc pfp$reset_task_environment
*copyc pmp$continue_to_cause
*copyc syp$hang_if_job_jrt_set
*copyc syp$invoke_system_debugger
?? TITLE := '  Global Declarations Declared by this module', EJECT ??
{
{   Currently the checksums are arbitrarily assigned.
{
?? FMT (FORMAT := OFF) ??
  VAR
    {debug_display, procedure_address, procedure_class, request_restartable
    {  job_recovery_location, recover_job_on_server_call, version, checksum
    dfv$procedure_address_list: [XDCL, READ, oss$job_paged_literal]
          dft$rpc_procedure_address_list := [
          {} ['', NIL, * , * , * , * , * , *, *, *, *, *],
          {} ['receive_test_rpc-restart', ^dfp$receive_test_rpc, dfc$task_services_call,
               dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 145788882, *, *, *,
               *],
          {} ['receive_test_rpc-unrestart', ^dfp$receive_test_rpc, dfc$task_services_call,
               dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 145788882, *, *,
                   *, *],
          {} ['receive_remote_command_line r', ^dfp$receive_remote_command_line,
               dfc$permanent_file_call, dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait,
               TRUE,  'AAAA', 143458882, *, *, *, *],
          {} ['receive_remote_command_line u', ^dfp$receive_remote_command_line,
               dfc$task_services_call, dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE,
              'AAAA', 777777772, *, *, *, *],
          {} ['receive_remote_message', ^dfp$receive_remote_message, dfc$task_services_call,
              dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 155555552, *, *, *, *],

         {} ['send_mmio_data', ^dfp$send_mmio_data, dfc$task_services_call, dfc$request_restartable,
              dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 1948683618228002372, *, *, *, *],
         {} [' perf test 1', NIL, * , * , * , * , * , *, *, *, *, *],
         {} [' perf test 2', NIL, * , * , * , * , * , *, *, *, *, *],

         {} ['dfp$send_server_rpc_segment', ^dfp$send_server_rpc_segment, dfc$task_services_call,
            dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 8073468973, *, *, *, *],

        {} ['dfp$delete_client_job', ^dfp$delete_client_job, dfc$permanent_file_call,
             dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 234567891, *, *, *,
             *],
        {} ['dfp$establish_client_job', ^dfp$establish_client_job, dfc$task_services_call,
            dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 8675309, *, *, *, *],

        {} [' Initiate job recovery', ^dfp$start_client_job_recovery, dfc$task_services_call,
             dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 234567891, *, *, *,
             *],
        {} [' complete_job_recovery', ^dfp$end_client_job_recovery, dfc$task_services_call,
              dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 234567891, *, *, *,
              *],
        {} [' relink file to client', ^pfp$relink_file_to_client, dfc$permanent_file_call,
             dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, FALSE,  'AAAA', 234567891, *, *, *,
             *],
        {} [' verify_jobs', NIL, * , * , * , * , * , *, *, *, *, *],
        {} [' flush image file', ^dfp$server_flush_image_file, dfc$task_services_call,
             dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, FALSE,  'AAAA', 278967891, *, *, *,
             *],
        {} [' get_client_job_list', ^dfp$get_client_job_list, dfc$task_services_call,
              dfc$request_restartable, dfc$job_rec_in_unavailable_wait, FALSE, 'AAAA', 234567891, *, *, *, *],
        {} [' remove_unknown_jobs', ^dfp$remove_unknown_jobs, dfc$task_services_call,
              dfc$request_restartable, dfc$job_rec_in_unavailable_wait, FALSE,  'AAAA', 234567891, *, *, *,
              *],
        {} [' Reserved job recovery 3', NIL, * , * , * , * , * , *, *, *, *, *],
        {} [' Reserved job recovery 4', NIL, * , * , * , * , * , *, *, *, *, *],
        {} [' Reserved job recovery 5', NIL, * , * , * , * , * , *, *, *, *, *],
        {} [' Reserved job recovery 6', NIL, * , * , * , * , * , *, *, *, *, *],
        {} [' Reserved job recovery 7', NIL, * , * , * , * , * , *, *, *, *, *],
        {} [' Reserved job recovery 8', NIL, * , * , * , * , * , *, *, *, *, *],
        {} [' Reserved job recovery 9', NIL, * , * , * , * , * , *, *, *, *, *],


        {} ['allocate_space', ^dmp$r1_df_server_allocate_space, dfc$system_core_call,
             dfc$request_restartable, dfc$job_rec_in_unavailable_wait,
             TRUE,  dfc$system_core_version, dfc$system_core_checksum, *, *, *, *],
        {} ['reallocate_space', ^dfp$reallocate_filespace_server, dfc$system_core_call,
            dfc$request_restartable, dfc$job_rec_in_unavailable_wait,
            TRUE,  dfc$system_core_version, dfc$system_core_checksum, *, *, *, *],

        {} ['get_server_fmd', ^dmp$server_get_fmd, dfc$task_services_call, dfc$request_not_restartable,
             dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 777777772, *, *, *, *],
        {} ['set_eoi', ^dmp$df_server_set_eoi, dfc$task_services_call,
            dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123456023, *, *, *, *],

        {} ['append_rem_media_vsn', ^pfp$r2_df_server_app_rem_me_vsn, dfc$permanent_file_call,
             dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450010, *, *, *,
             *],
        {} ['attach', ^pfp$r2_df_server_attach, dfc$permanent_file_call, dfc$request_not_restartable,
             dfc$job_rec_in_unavailable_wait, FALSE, 'AAAA', 123450011, *, *, *, *],
        {} ['attach_or_create', ^pfp$r2_df_server_attach_or_cref, dfc$permanent_file_call,
             dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, FALSE, 'AAAA', 123450012, *, *, *,
             *],
        {} ['change', ^pfp$r2_df_server_change, dfc$permanent_file_call,
             dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450013, *, *, *,
             *],
        {} ['change_cycle_damage', ^pfp$r2_df_server_change_cy_dam, dfc$permanent_file_call,
             dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450014, *, *, *, *],
        {} ['change_cycle_date_time', ^pfp$r2_df_server_change_cy_dt, dfc$permanent_file_call,
             dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450015, *, *, *, *],
        {} ['change_residence_to_releasable', ^pfp$r2_df_server_change_res_rel, dfc$permanent_file_call,
             dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450016, *, *, *, *],
        {} ['clear_cycle_attachmments', ^pfp$r2_df_server_clear_cy_att, dfc$permanent_file_call,
             dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450017, *, *, *, *],
        {} ['create_catalog', ^pfp$r2_df_server_define_catalog, dfc$permanent_file_call,
             dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450018, *, *, *,
             *],
        {} ['define', ^pfp$r2_df_server_define, dfc$permanent_file_call,
             dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, FALSE, 'AAAA', 123450019, *, *, *,
             *],
        {} ['define_data', ^pfp$r2_df_server_define_data, dfc$permanent_file_call,
             dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, FALSE, 'AAAA', 123450020, *, *, *,
             *],
        {} ['delete_catalog', ^pfp$r2_df_server_purge_catalog, dfc$permanent_file_call,
             dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450021, *, *, *,
             *],
        {} ['delete_permit', ^pfp$r2_df_server_delete_permit, dfc$permanent_file_call,
             dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450022, *, *, *,
             *],
        {} ['get_family_set ', ^pfp$r2_df_server_get_family_set, dfc$permanent_file_call,
             dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450023, *, *, *, *],
        {} ['get family item info ', ^pfp$r2_df_server_get_famit_info, dfc$permanent_file_call,
             dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450024, *, *, *, *],
        {} ['get_info', ^pfp$r2_df_server_get_info, dfc$permanent_file_call,
            dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450025, *, *, *, *],
        {} ['get_mcat_info', ^pfp$r2_df_server_get_mcat_info, dfc$permanent_file_call,
            dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450026, *, *, *, *],
        {} ['get object info ', ^pfp$r2_df_server_get_obj_info, dfc$permanent_file_call,
            dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450027, *, *, *, *],
        {} ['permit', ^pfp$r2_df_server_permit, dfc$permanent_file_call, dfc$request_restartable,
            dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450028, *, *, *, *],
        {} ['purge', ^pfp$r2_df_server_purge, dfc$permanent_file_call,
            dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450029, *, *, *,
            *],
        {} ['put_cycle_info', ^pfp$r2_df_server_put_cycle_info, dfc$permanent_file_call,
            dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450030, *, *, *,
            *],
        {} ['put_info', ^pfp$r2_df_server_put_item_info, dfc$permanent_file_call,
            dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450031,  *, *, *,
            *],
        {} ['replace_rem_media_fmd', ^pfp$r2_df_server_rep_rem_me_fmd, dfc$permanent_file_call,
            dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450032, *, *, *, *],
        {} ['resolve', ^pfp$r2_df_server_resolve, dfc$permanent_file_call,
            dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450033, *, *, *, *],
        {} ['return', ^pfp$r2_df_server_return, dfc$permanent_file_call,
            dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, FALSE, 'AAAA', 123450034, *, *, *,
            *],
        {} ['save_label', ^pfp$r2_df_server_save_label, dfc$permanent_file_call,
            dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450035, *, *, *,
            *],
        {} ['validate_password', ^pfp$r2_df_server_validate_pw, dfc$permanent_file_call,
            dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 123450036, *, *, *, *],
        {} ['get_vol_condition_list', ^pfp$r2_df_server_get_vol_cl, dfc$permanent_file_call,
             dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 010203043, *, *, *, *],
        {} ['change_file', ^pfp$r2_df_server_change_file, dfc$permanent_file_call,
             dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE, 'AAAA', 010203044, *, *, *,
             *],
        {} ['change login pw ', NIL, * , * , * , *, * , *,  *, *, *, *],
        {} ['prevalidate_job', ^avp$server_prevalidate_job, dfc$task_services_call,
          dfc$request_restartable, dfc$job_rec_started_by_caller, TRUE,  'AAAA', 123456789, *, *, *, *],
        {} ['get_val_info', ^avp$server_get_val_info, dfc$task_services_call,
          dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 123456789, *, *, *, *],

    { Site reserved
        {} [' Site 1', NIL, * , * , * , * , * , *, *, *, *, *],
        {} [' Site 2', NIL, * , * , * , * , * , *, *, *, *, *],
        {} [' Site 3', NIL, * , * , * , * , * , *, *, *, *, *],
        {} [' Site 4', NIL, * , * , * , * , * , *, *, *, *, *],
        {} [' Site 5', NIL, * , * , * , * , * , *, *, *, *, *],

    {Vxve reserved
        {} ['vxve 1  ', NIL, * , * , * , * , * , *, *, *, *, *],
        {} ['vxve 2 ', NIL, * , * , * , * , * , *, *, *, *, *],
        {} ['vxve 3', NIL, * , * , * , * , * , *, *, *, *, *],
        {} ['vxve 4', NIL, * , * , * , * , * , *, *, *, *, *],
        {} ['vxve 5', NIL, * , * , * , * , * , *, *, *, *, *],

        { Reserved for NOS/VE
        {} ['ready_universal_task ', ^osp$server_ready_task, dfc$task_services_call,
          dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 2074300008, *, *, *, *],
        {} ['change_job_validation_info ', ^dfp$change_client_job_validaton,
            dfc$permanent_file_call, dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE,
            'AAAA', 2078959908, *, *, *, *],
        {} ['send_client_rpc_segment ', ^dfp$receive_part_client_segment, dfc$task_services_call,
          dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 2074300008, *, *, *, *],
        {} ['send_remote_app_info', ^dfp$send_remote_app_info, dfc$task_services_call,
          dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 2074300008, *, *, *, *],
        {} ['OS 4 ', NIL, * , * , * , * , * , *, *, *, *, *],
        {} ['OS 5 ', NIL, * , * , * , * , * , *, *, *, *, *],

    { Reserved for nos/ve load leveling and queue file management
       {} [' Job_leveler_server  ', ^jmp$job_leveler_server, dfc$task_services_call,
          dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 42, *, *, *, *],
        {} [' Submit_job  ', ^jmp$server_submit_job, dfc$task_services_call,
        dfc$request_not_restartable, dfc$job_rec_started_by_caller, TRUE,  'AAAA', 42, *, *, *, *],
        {} [' JM_General_Purpose ', ^jmp$server_general_purpose_rpc, dfc$task_services_call,
        dfc$request_restartable, dfc$job_rec_started_by_caller, TRUE,  'AAAA', 42, *, *, *, *],
        {} [' Terminate_job  ', ^jmp$server_terminate_job, dfc$task_services_call,
        dfc$request_not_restartable, dfc$job_rec_started_by_caller, TRUE,  'AAAA', 42, *, *, *, *],
        {} [' Job_begin  ', ^jmp$server_job_begin, dfc$task_services_call,
        dfc$request_not_restartable, dfc$job_rec_started_by_caller, TRUE,  'AAAA', 42, *, *, *, *],
        {} [' Send_job_message  ', ^jmp$server_send_job_message, dfc$task_services_call,
        dfc$request_restartable, dfc$job_rec_started_by_caller, TRUE,  'AAAA', 42, *, *, *, *],
        {} [' LEVELER 7', NIL, * , * , * , * , * , *, *, *, *, *],
        {} [' LEVELER 8', NIL, * , * , * , * , * , *, *, *, *, *],
        {} [' LEVELER 9', NIL, * , * , * , * , * , *, *, *, *, *],
        {} [' LEVELER 10', NIL, * , * , * , * , * , *, *, *, *, *],

    { Reserved for archiving}
        {} ['delete_all_archive_entries', ^pfp$r2_df_server_del_all_arc_en, dfc$permanent_file_call,
        dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 2074300001, *, *, *, *],
        {} ['delete_archive_entry', ^pfp$r2_df_server_del_arch_entry, dfc$permanent_file_call,
        dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 2074300002, *, *, *, *],
        {} ['mark_release_candidate ', ^pfp$r2_df_server_mark_rel_cand, dfc$permanent_file_call,
        dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 2074300003, *, *, *, *],
        {} ['put_archive_entry ', ^pfp$r2_df_server_put_arch_entry, dfc$permanent_file_call,
        dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 2074300004, *, *, *, *],
        {} ['put_archive_info ', ^pfp$r2_df_server_put_arch_info, dfc$permanent_file_call,
        dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 2074300005, *, *, *, *],
        {} ['replace_archive_entry ', ^pfp$r2_df_server_release_data, dfc$permanent_file_call,
        dfc$request_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 2074300006, *, *, *, *],
        {} ['release_data ', ^pfp$r2_df_server_rep_arch_entry, dfc$permanent_file_call,
        dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait, TRUE,  'AAAA', 2074300007, *, *, *, *],
        {} ['save_released_file_label ', ^pfp$r2_df_server_save_rel_label,
        dfc$permanent_file_call, dfc$request_not_restartable, dfc$job_rec_in_unavailable_wait,
        TRUE,  'AAAA', 2074300009, *, *, *, *],

        {} ['Last job proceedure', NIL, * , * , * , * , * , *, *, *, *, *],

        {} ['Poll', NIL, * , * , * , * , * , *, *, *, *, *],

        {} ['monitor procedure', NIL, * , * , * , * , * , *, *, *, *, *],
        {} ['read pages', NIL, * , * , * , * , * , *, *, *, *, *],
        {} ['write pages', NIL, * , * , * , * , * , *, *, *, *, *],
        {} ['allocate', NIL, * , * , * , * , * , *, *, *, *, *],

        {} ['last procedure', NIL, * , * , * , * , * , *, *, *, * , *]];
?? FMT (FORMAT := ON) ??
?? PUSH (LISTEXT := ON) ??
  PROCEDURE [XREF] avp$server_prevalidate_job
    (VAR p_params_received_from_client: dft$p_receive_parameters;
     VAR p_data_received_from_client: dft$p_receive_data;
     VAR p_params_to_send_to_client: dft$p_send_parameters;
     VAR p_data_to_send_to_client: dft$p_send_data;
     VAR params_size_to_send_to_client: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] avp$server_get_val_info
    (VAR p_params_received_from_client: dft$p_receive_parameters;
     VAR p_data_received_from_client: dft$p_receive_data;
     VAR p_params_to_send_to_client: dft$p_send_parameters;
     VAR p_data_to_send_to_client: dft$p_send_data;
     VAR params_size_to_send_to_client: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$delete_client_job
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$establish_client_job
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$change_client_job_validaton
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$send_server_rpc_segment
    (VAR p_params_received_from_client: dft$p_receive_parameters;
     VAR p_data_received_from_client: dft$p_receive_data;
     VAR p_params_to_send_to_client: dft$p_send_parameters;
     VAR p_data_to_send_to_client: dft$p_send_data;
     VAR params_size_to_send_to_client: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$receive_part_client_segment
    (VAR p_params_received_from_client: dft$p_receive_parameters;
     VAR p_data_received_from_client: dft$p_receive_data;
     VAR p_params_to_send_to_client: dft$p_send_parameters;
     VAR p_data_to_send_to_client: dft$p_send_data;
     VAR params_size_to_send_to_client: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$receive_test_rpc
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$receive_remote_command_line
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$receive_remote_message
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$send_mmio_data
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$start_client_job_recovery
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$end_client_job_recovery
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$get_client_job_list
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$remove_unknown_jobs
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$server_flush_image_file
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dmp$df_server_set_eoi
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dmp$r1_df_server_allocate_space
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dfp$reallocate_filespace_server
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_app_rem_me_vsn
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_attach
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_attach_or_cref
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_change
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_change_cy_dam
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_change_cy_dt
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_change_file
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_change_res_rel
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_clear_cy_att
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_define
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_define_catalog
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_define_data
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_delete_permit
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_get_family_set
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_get_info
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_get_mcat_info
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_get_famit_info
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_get_vol_cl
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_permit
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_purge
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_purge_catalog
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_put_cycle_info
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_put_item_info
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_rep_rem_me_fmd
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_resolve
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_return
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_save_label
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$relink_file_to_client
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_validate_pw
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] dmp$server_get_fmd
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

{
{ RESERVED FOR SITE XREFS


{  END SITE XREFS
{

{
{ RESERVED FOR VXVE XREFS


{ END XXVE XREFS
{

{
{ RESERVED FOR VE XREFS


  PROCEDURE [XREF] osp$server_ready_task
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);


  PROCEDURE [XREF] dfp$send_remote_app_info
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

{END VE XREFS
{

{
{ RESERVED FOR VE LOAD LEVELING XREFS

*copyc jmp$job_leveler_server
*copyc jmp$server_general_purpose_rpc
*copyc jmp$server_job_begin
*copyc jmp$server_send_job_message
*copyc jmp$server_submit_job
*copyc jmp$server_terminate_job

{ END LOAD LEVELING XREFS
{

{ RESERVED FOR VE ARCHIVING


  PROCEDURE [XREF] pfp$r2_df_server_del_all_arc_en
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_del_arch_entry
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_mark_rel_cand
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_put_arch_entry
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_put_arch_info
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_release_data
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_rep_arch_entry
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

  PROCEDURE [XREF] pfp$r2_df_server_save_rel_label
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

{ END ARCHIVING XREFS
{
?? POP ??
?? TITLE := ' [XDCL] dfp$receive_remote_call ', EJECT ??
{
{   This procedure receives the remote request from the client.  This procedure
{ assumes that the caller (dfp$process_task_request) has determined the
{ action for the server, and has done the movement of retransmission count
{ from the receive buffer to the cpu queue.
{   This procedure acts differently whether this is a new transaction or a
{ retransmittal.  If this a new transaction this procedure determines whether
{ this is a new remote procedure call request, or an ongoing remote procedure
{ call request.  If the request is a retransmittal the procedure determines
{ the state of the request - whether the buffers or data may just be sent
{ back to the client or whether the client must restart the request.

  PROCEDURE [XDCL] dfp$receive_remote_call
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         action_for_server: dft$action_for_server;
     VAR status: ost$status);

    CASE action_for_server OF
    = dfc$new_request =
      { Free any pages saved from a previous request }
      IF p_cpu_queue_entry^.p_last_wired_data <> NIL THEN
        mmp$free_pages (p_cpu_queue_entry^.p_last_wired_data, p_cpu_queue_entry^.last_wired_length, osc$wait,
              status);
        p_cpu_queue_entry^.p_last_wired_data := NIL;
        p_cpu_queue_entry^.last_wired_length := 0;
      IFEND;

      receive_new_request (p_queue_interface_table, queue_index, queue_entry_index, p_driver_queue_entry,
            p_cpu_queue_entry, status);

    = dfc$retransmitted_request =
      IF dfv$file_server_debug_enabled THEN
        display_integer_to_console (' DF - SERVER- RECEIVE RETRANSMITTAL - QUEUE INDEX ', queue_index);
        display_integer_to_console (' DF - SERVER- QUEUE ENTRY INDEX', queue_entry_index);
        display_integer (' DF - SERVER- RECEIVE RETRANSMITTAL - QUEUE INDEX ', queue_index);
        display_integer (' DF - SERVER- QUEUE ENTRY INDEX', queue_entry_index);
      IFEND;
      receive_retransmittal (p_queue_interface_table, queue_index, queue_entry_index, p_cpu_queue_entry,
            p_driver_queue_entry, status);

    = dfc$complete_request_on_error, dfc$transaction_out_of_sequence =
      IF dfv$file_server_debug_enabled THEN
        display_to_console (' DF - SERVER  dfc$complete_request_on_error');
        display (' DF - SERVER  dfc$complete_request_on_error');
        {  Report error
        {       DO nothing - Let request time out
        {       Note: Complete request on error should not come through here
      IFEND;
    ELSE
      IF dfv$file_server_debug_enabled THEN
        display_to_console (' DF - SERVER unexpected action for server ');
        display (' DF - SERVER unexpected action for server ');
        osp$system_error (' DF - SERVER unexpected action ', NIL);
      IFEND;
    CASEND;
  PROCEND dfp$receive_remote_call;
?? TITLE := '  call_procedure ', EJECT ??
  PROCEDURE call_procedure
    (    current_rpc_entry: dft$rpc_procedure_address_entry;
     VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      IF (condition.selector = pmc$system_conditions) OR
            (condition.selector = mmc$segment_access_condition) THEN
        osp$set_status_from_condition (dfc$file_server_id, condition, p_sfsa, status,
              local_status);
        IF local_status.normal THEN
          pfp$log_error (status, - $pmt$ascii_logset [], pmc$msg_origin_system, TRUE);
        ELSE
          pfp$log_error (local_status, - $pmt$ascii_logset [], pmc$msg_origin_system, TRUE);
          status := local_status;
        IFEND;
        IF dfv$file_server_debug_enabled THEN
          syp$invoke_system_debugger ('', 0, local_status);
          display_trace_back;
        IFEND;
        EXIT call_procedure;
      ELSEIF (condition.selector = pmc$user_defined_condition) AND (
            condition.user_condition_name = dfc$client_terminate_break) THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$client_terminate_break,
              current_rpc_entry.debug_display, status);
        EXIT call_procedure;
      ELSEIF (condition.selector = pmc$user_defined_condition) AND (
            condition.user_condition_name = dfc$client_pause_break) THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$client_pause_break,
              current_rpc_entry.debug_display, status);
        EXIT call_procedure;
      ELSE
        {
        { Ignore the condition.
        {
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND condition_handler;


    osp$establish_condition_handler (^condition_handler, { block_exit = } FALSE);

    status.normal := TRUE;

    IF current_rpc_entry.procedure_address<> NIL THEN

      send_parameters_length := 0;
      data_size_to_send_to_client := 0;
      current_rpc_entry.procedure_address^
            (p_param_received_from_client, p_data_from_client, p_send_to_client_params, p_data_to_client,
            send_parameters_length, data_size_to_send_to_client, status);

      IF status.normal THEN
        IF (send_parameters_length > dfc$maximum_user_buffer_area) OR
              (send_parameters_length < 0) THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$out_of_range_value,
                'SEND_PARAMETERS_LENGTH', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'received from REMOTE_PROCEDURE', status);
          osp$append_status_integer (osc$status_parameter_delimiter, send_parameters_length,
                10, FALSE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, 0, 10, FALSE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, dfc$maximum_user_buffer_area,
                10, FALSE, status);
        IFEND;
        IF (data_size_to_send_to_client > dfc$maximum_user_data_area) OR
              (data_size_to_send_to_client < 0) THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$out_of_range_value,
                'DATA_SIZE_TO_SEND_TO_CLIENT', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'received from REMOTE_PROCEDURE', status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                data_size_to_send_to_client, 10, FALSE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, 0, 10, FALSE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, dfc$maximum_user_data_area,
                10, FALSE, status);
        IFEND;
      IFEND;

    ELSE
      osp$set_status_abnormal (dfc$file_server_id, dfe$remote_proc_load_failure,
            current_rpc_entry.debug_display, status);
    IFEND;
    IF dfv$file_server_debug_enabled AND (NOT status.normal) THEN
      display_integer (' Abnormal status condition ', status.condition);
    IFEND;
  PROCEND call_procedure;
?? TITLE := '  call_remote_procedure ', EJECT ??
{
{   This procedure makes the actual call to the users procedure.
{ Prior to making the call the receive parameters and receive data have
{ all been received, and this routine establishing the pointers to that
{ area for the user.  After calling the users procedure this routine
{ builds the appropriate status, and determines whether there is data
{ to be sent back to the server.  If data was sent over with the request
{ no data is returned to the server on this initial response.  If data
{ is returned to the server, the procedure waits until the data is moved.
{

  PROCEDURE call_remote_procedure
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         p_receive_buffer_header: ^dft$buffer_header;
         current_rpc_entry: dft$rpc_procedure_address_entry;
         p_receive_rpc_buffer_header: ^dft$rpc_buffer_header);

    VAR
      actual_length: integer,
      p_send_buffer_header: ^dft$buffer_header,
      p_send_mtr_status: ^syt$monitor_status,
      p_send_os_status: ^ost$status,
      p_send_rpc_buffer_header: ^dft$rpc_response_buffer_header,
      p_user_receive_data: dft$p_receive_data,
      p_user_receive_parameters: dft$p_receive_parameters,
      p_user_send_data: dft$p_send_data,
      p_user_send_parameters: dft$p_send_parameters,
      request_status: ost$status,
      send_data_length: dft$send_data_size,
      send_parameters_length: dft$send_parameter_size,
      status: ost$status,
      status_size: integer;

    { Establish pointers to user send and  receive buffer, and data.
    IF p_receive_rpc_buffer_header^.call_progress.user_buffer_length_sent > 0 THEN
      NEXT p_user_receive_parameters: [[REP p_receive_rpc_buffer_header^.call_progress.
            user_buffer_length_sent OF cell]] IN p_cpu_queue_entry^.p_receive_buffer;
      RESET p_user_receive_parameters;
    ELSE
      p_user_receive_parameters := NIL;
    IFEND;
    IF p_receive_rpc_buffer_header^.call_progress.user_data_length_sent > 0 THEN
      RESET p_cpu_queue_entry^.p_receive_data;
      NEXT p_user_receive_data: [[REP p_receive_rpc_buffer_header^.call_progress.user_data_length_sent OF
            cell]] IN p_cpu_queue_entry^.p_receive_data;
      RESET p_user_receive_data;
    ELSE
      p_user_receive_data := NIL;
    IFEND;
    RESET p_cpu_queue_entry^.p_send_buffer;
    NEXT p_send_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
    NEXT p_send_mtr_status IN p_cpu_queue_entry^.p_send_buffer;
    NEXT p_send_rpc_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
    NEXT p_user_send_parameters IN p_cpu_queue_entry^.p_send_buffer;
    RESET p_user_send_parameters;
    RESET p_cpu_queue_entry^.p_send_data;
    { Since the input parameters are VAR (for convenience of users doing NEXTS
    { a copy is made of the pointer.
    p_user_send_data := p_cpu_queue_entry^.p_send_data;

    { Call the procedure.
    p_cpu_queue_entry^.remote_procedure_called := TRUE;
    IF (current_rpc_entry.class
           = dfc$permanent_file_call) AND
           NOT current_rpc_entry.
            recover_job_on_server_call THEN
      dfp$push_job_unrecoverable (p_receive_rpc_buffer_header^.client_job_id);
    IFEND;

    call_procedure (current_rpc_entry, p_user_receive_parameters,
           p_user_receive_data, p_user_send_parameters,
          p_user_send_data, send_parameters_length, send_data_length, request_status);

    IF (current_rpc_entry.class
           = dfc$permanent_file_call) AND
           NOT current_rpc_entry.
          recover_job_on_server_call THEN
      dfp$pop_job_unrecoverable (p_receive_rpc_buffer_header^.client_job_id);
    IFEND;

    syp$hang_if_job_jrt_set (dfc$tjr_server_rpc_after_call);
    { Set the status in the send buffer.
    IF request_status.normal THEN
      status_size := 0;
      p_send_mtr_status^.normal := TRUE;
    ELSE
      p_send_mtr_status^.normal := FALSE;
      { IF status is abnormal should we also free the send data in case the
      { caller has touched the pages?
      status_size := #SIZE (ost$status);
      { No parameters or data is returned if status is abnormal .
      send_parameters_length := 0;
      send_data_length := 0;
      p_send_mtr_status^.condition := request_status.condition;
      RESET p_cpu_queue_entry^.p_send_buffer TO p_send_rpc_buffer_header;
      NEXT p_send_os_status IN p_cpu_queue_entry^.p_send_buffer;
      p_send_os_status^ := request_status;
      NEXT p_send_rpc_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
    IFEND;

    IF p_receive_rpc_buffer_header^.call_progress.user_data_length_sent > 0 THEN
      { We are done with the receive buffer.
      mmp$free_pages (p_cpu_queue_entry^.p_receive_data, p_receive_rpc_buffer_header^.call_progress.
            user_data_length_sent, osc$wait, status);
    IFEND;

    { Initialize send buffer header.
    p_send_buffer_header^.version := dfc$status_buffer_version;
    p_send_buffer_header^.transaction_count := p_cpu_queue_entry^.transaction_count;
    p_send_buffer_header^.retransmission_count := p_cpu_queue_entry^.retransmission_count;
    p_send_buffer_header^.remote_processor := p_receive_buffer_header^.remote_processor;

    { Determine size of send buffer and data length to send to client.
    IF send_data_length = 0 THEN
      { No data is being sent to the client
      p_send_buffer_header^.data_length_sent := 0;
      p_driver_queue_entry^.send_buffer_descriptor.actual_length :=
            dfp$word_boundary (#SIZE (dft$buffer_header) + #SIZE (syt$monitor_status) +
            #SIZE (dft$rpc_response_buffer_header) + status_size + send_parameters_length);
    ELSEIF p_cpu_queue_entry^.call_progress.total_data_received > 0 THEN
      { Data has both been received and is being sent.
      { Data is not send back with this request.
      { With retransmission if we update the rma list,
      { with the send area, And we get a retransmittal we are in trouble as
      { the rma points to the wrong data.
      p_send_buffer_header^.data_length_sent := 0;
      p_driver_queue_entry^.send_buffer_descriptor.actual_length :=
            dfp$word_boundary (#SIZE (dft$buffer_header) + #SIZE (syt$monitor_status) +
            #SIZE (dft$rpc_response_buffer_header));
    ELSE { Data to send AND no data has been received
      IF send_data_length > p_queue_interface_table^.maximum_data_bytes THEN
        { There is more data to send than can fit in a single request.
        {Only send parameters back with the final piece of data.
        p_send_buffer_header^.data_length_sent := p_queue_interface_table^.maximum_data_bytes;
        p_driver_queue_entry^.send_buffer_descriptor.actual_length :=
              dfp$word_boundary (#SIZE (dft$buffer_header) + #SIZE (syt$monitor_status) +
              #SIZE (dft$rpc_response_buffer_header));
        dfp$initialize_rma_list (p_cpu_queue_entry^.p_send_data, { Offset = } 0,
              p_queue_interface_table^.maximum_data_bytes, p_cpu_queue_entry^.p_data_rma_list,
              p_driver_queue_entry^.data_descriptor, status);
      ELSE { All data will fit in this single request.
        dfp$initialize_rma_list (p_cpu_queue_entry^.p_send_data, { Offset = } 0, send_data_length,
              p_cpu_queue_entry^.p_data_rma_list, p_driver_queue_entry^.data_descriptor, status);
        p_send_buffer_header^.data_length_sent := osv$page_size *
              (p_driver_queue_entry^.data_descriptor.actual_length DIV 8);
        p_driver_queue_entry^.send_buffer_descriptor.actual_length :=
              dfp$word_boundary (#SIZE (dft$buffer_header) + #SIZE (syt$monitor_status) +
              #SIZE (dft$rpc_response_buffer_header) + send_parameters_length);
      IFEND;
    IFEND;
    p_send_buffer_header^.buffer_length_sent := p_driver_queue_entry^.send_buffer_descriptor.actual_length;

    {  Update call progress
    p_cpu_queue_entry^.call_progress.total_data_sent := p_send_buffer_header^.data_length_sent;
    p_cpu_queue_entry^.call_progress.user_data_length_sent := send_data_length;
    p_cpu_queue_entry^.call_progress.user_buffer_length_sent := send_parameters_length;

    { Initialize sending remote procedure call buffer header.
    p_send_rpc_buffer_header^.call_progress := p_cpu_queue_entry^.call_progress;

    IF p_send_buffer_header^.data_length_sent > 0 THEN
      p_driver_queue_entry^.flags := dfv$send_command_and_data_flags;
    ELSE
      p_driver_queue_entry^.flags := dfv$send_command_flags;
    IFEND;
    IF time_to_test_retransmission (p_cpu_queue_entry) THEN
      force_retransmission ('CALL_REMOTE_PROCEDURE', p_cpu_queue_entry, p_driver_queue_entry);
      IF p_send_buffer_header^.data_length_sent > 0 THEN
        display_to_console ('force RETRANSMIT of DATA SENDING ');
        wakeup_after_sending_data (p_send_buffer_header, queue_index, queue_entry_index, p_driver_queue_entry,
             current_rpc_entry, p_cpu_queue_entry);
      IFEND;
    ELSE
      dfp$queue_server_task_request (p_queue_interface_table, queue_index, queue_entry_index);
      IF p_send_buffer_header^.data_length_sent > 0 THEN
        dfp$await_server_subsystem (p_queue_interface_table, queue_index, p_driver_queue_entry);
        wakeup_after_sending_data (p_send_buffer_header, queue_index, queue_entry_index, p_driver_queue_entry,
              current_rpc_entry, p_cpu_queue_entry);
      IFEND;
    IFEND;
  PROCEND call_remote_procedure;
?? TITLE := ' force_retransmission ', EJECT ??

  PROCEDURE force_retransmission
    (    message: string (*);
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry);

    p_cpu_queue_entry^.transaction_state := dfc$message_content_error;
    display_integer_to_console (' DF - SERVER - FORCING RETRANSMISSION : TRANSACTION ',
          p_cpu_queue_entry^.transaction_count);
    display_integer (' DF - SERVER - FORCING RETRANSMISSION : TRANSACTION ',
          p_cpu_queue_entry^.transaction_count);
    display_to_console (message);
    display (message);
    dfp$clear_server_driver_flags (p_driver_queue_entry);
  PROCEND force_retransmission;

?? TITLE := '  get_current_rpc_entry', EJECT ??

{ PURPOSE:
{   The purpose of this request is to validate the procedure ordinal and to
{   return the associated procedure address list entry.

  PROCEDURE get_current_rpc_entry
    (    procedure_ordinal: dft$procedure_address_ordinal;
         p_receive_rpc_buffer_header: ^dft$rpc_buffer_header;
         p_cpu_queue_header: ^dft$cpu_queue_header;
     VAR current_rpc_entry: dft$rpc_procedure_address_entry);

    VAR
      local_status: ost$status;

    IF (procedure_ordinal <= UPPERVALUE (dft$procedure_address_ordinal)) AND
          (procedure_ordinal >= LOWERVALUE (dft$procedure_address_ordinal)) THEN
      IF procedure_ordinal <= dfc$last_system_procedure THEN
        current_rpc_entry := dfv$procedure_address_list [procedure_ordinal];
      ELSE
        current_rpc_entry := p_cpu_queue_header^.p_application_rpc_list^
              [$INTEGER (procedure_ordinal) - $INTEGER (dfc$last_system_procedure)];
        current_rpc_entry.procedure_address := dfv$p_proc_addresses^
              [$INTEGER (procedure_ordinal) - $INTEGER (dfc$last_system_procedure)];
      IFEND;
      IF (current_rpc_entry.procedure_name_checksum <> p_receive_rpc_buffer_header^.
            procedure_name_checksum) OR (current_rpc_entry.procedure_version <>
            p_receive_rpc_buffer_header^.procedure_version) THEN
        osp$system_error ('DF - SERVER - PROCEDURE ADDRESS MISMATCH ', NIL);
      IFEND;
    ELSE
      osp$system_error ('DF - SERVER - PROCEDURE NOT LOCATED ', NIL);
    IFEND;

  PROCEND get_current_rpc_entry;
?? TITLE := ' initialize_new_call ', EJECT ??
{
{  This procedure initializes the cpu queue and valides the incoming
{ parameters on the initial transaction of a remote procedure call request.

  PROCEDURE initialize_new_call
    (    p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_receive_buffer_header: ^dft$buffer_header;
         p_receive_rpc_buffer_header: ^dft$rpc_buffer_header;
         current_rpc_entry: dft$rpc_procedure_address_entry;
     VAR valid_client_job_id: boolean);

    VAR
      page_count: ost$non_negative_integers,
      status: ost$status;

    p_cpu_queue_entry^.total_data_to_receive := p_receive_rpc_buffer_header^.call_progress.
          user_data_length_sent;
    p_cpu_queue_entry^.call_progress.transaction_per_rpc_request := 1;
    p_cpu_queue_entry^.call_progress.total_data_sent := 0;
    p_cpu_queue_entry^.call_progress.user_data_length_sent := 0;
    p_cpu_queue_entry^.call_progress.total_data_received := 0;
    p_cpu_queue_entry^.call_progress.user_buffer_length_sent := 0;
    p_cpu_queue_entry^.remote_procedure_called := FALSE;
    valid_client_job_id := TRUE;

    IF current_rpc_entry.class =
          dfc$permanent_file_call THEN
      { Make the task look like its running on behalf of the user job
      dfp$validate_client_job_id (p_receive_rpc_buffer_header^.client_job_id,
            p_receive_rpc_buffer_header^.system_supplied_job_name,
            dfv$p_client_mainframe_file^.mainframe_header.client_job_list_root, status);
      valid_client_job_id := status.normal;
      { Is there any problem if the task terminates with its permanent
      { files table pointing TO 'another' job
      IF valid_client_job_id THEN
        dfp$set_client_job_environment (p_receive_rpc_buffer_header^.client_job_id,
              p_receive_rpc_buffer_header^.system_administrator,
              p_receive_rpc_buffer_header^.family_administrator, status);
      IFEND;
    ELSE { Task services or system core
      { Set the task to point to its native tables.
      { All permanent file requests will be on behalf of the system job.
      pfp$reset_task_environment;
    IFEND;
    IF p_cpu_queue_entry^.total_data_to_receive > 0 THEN
      { There is data to receive from the client, get all the pages wired
      { down .
      dfp$touch_pages (p_cpu_queue_entry^.p_receive_data, p_cpu_queue_entry^.total_data_to_receive,
            page_count);
    IFEND;

    IF (p_receive_buffer_header^.remote_processor <> dfc$receive_server_rpc_segment) AND
       (p_receive_buffer_header^.remote_processor <> dfc$change_job_validation_info) AND
       (p_receive_buffer_header^.remote_processor <> dfc$establish_client_job) THEN
      dfp$delete_server_rpc_segment;
    IFEND;
  PROCEND initialize_new_call;
?? TITLE := ' receive_data ', EJECT ??

{ Still more data to receive, prompt for it.

  PROCEDURE receive_data
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         p_receive_buffer_header: ^dft$buffer_header;
         p_receive_rpc_buffer_header: ^dft$rpc_buffer_header;
     VAR driver_error_alert: boolean);

    VAR
      status: ost$status;


    driver_error_alert := FALSE;
    dfp$initialize_rma_list (p_cpu_queue_entry^.p_receive_data,
          {offset = } p_cpu_queue_entry^.call_progress.total_data_received,
          { Length = } p_receive_buffer_header^.data_length_sent, p_cpu_queue_entry^.p_data_rma_list,
          p_driver_queue_entry^.data_descriptor, status);

    p_driver_queue_entry^.flags := dfv$send_ready_for_data_flags;
    IF time_to_test_retransmission (p_cpu_queue_entry) THEN
      force_retransmission ('RECEIVE_DATA', p_cpu_queue_entry, p_driver_queue_entry);
      driver_error_alert := TRUE;
    ELSE
      dfp$queue_server_task_request (p_queue_interface_table, queue_index, queue_entry_index);
      dfp$await_server_subsystem (p_queue_interface_table, queue_index, p_driver_queue_entry);
      IF p_driver_queue_entry^.flags.driver_error_alert THEN
        { Allow the request to be retransmitted
        { No need to free pages, since retransmittal will re-send pages
        report_driver_error_alert (queue_index, queue_entry_index, p_driver_queue_entry);
        driver_error_alert := TRUE;
      ELSE
        {Update total data received
        p_cpu_queue_entry^.call_progress.total_data_received :=
              p_cpu_queue_entry^.call_progress.total_data_received +
              p_receive_buffer_header^.data_length_sent;
      IFEND;
    IFEND;
    dfp$clear_server_driver_flags (p_driver_queue_entry);
  PROCEND receive_data;
?? TITLE := ' receive_new_request', EJECT ??

{  This procedure determines the state of the newly received transaction, that
{ is, whether this is a brand new remote procedure call request or a request
{ in  progress (receiving more data, or sending more data).

  PROCEDURE receive_new_request
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
     VAR status: ost$status);

    VAR
      current_rpc_entry: dft$rpc_procedure_address_entry,
      driver_error_alert: boolean,
      p_receive_buffer_header: ^dft$buffer_header,
      p_receive_rpc_buffer_header: ^dft$rpc_buffer_header,
      prompt_for_data: boolean,
      valid_client_job_id: boolean;

    status.normal := TRUE;
    RESET p_cpu_queue_entry^.p_receive_buffer;
    NEXT p_receive_buffer_header IN p_cpu_queue_entry^.p_receive_buffer;
    NEXT p_receive_rpc_buffer_header IN p_cpu_queue_entry^.p_receive_buffer;
    get_current_rpc_entry (p_receive_buffer_header^.remote_processor,
          p_receive_rpc_buffer_header, ^p_queue_interface_table^.queue_directory
          .cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header,
          current_rpc_entry);
    IF p_receive_rpc_buffer_header^.call_progress.transaction_per_rpc_request = 1 THEN
      initialize_new_call (p_cpu_queue_entry, p_receive_buffer_header, p_receive_rpc_buffer_header,
            current_rpc_entry, valid_client_job_id);
      IF NOT valid_client_job_id THEN
        send_restart_request_status (p_queue_interface_table, queue_index, queue_entry_index,
              p_cpu_queue_entry, p_driver_queue_entry, p_receive_buffer_header,
              dfe$bad_client_job_id);
        RETURN;
      IFEND;
    ELSE
      validate_call_progress (p_cpu_queue_entry, p_receive_buffer_header, p_receive_rpc_buffer_header);
      p_cpu_queue_entry^.call_progress.transaction_per_rpc_request :=
            p_cpu_queue_entry^.call_progress.transaction_per_rpc_request + 1;
    IFEND;

{ Determine whether receiving, or sending more data, or ready to call
{ procedure.

    IF p_receive_buffer_header^.data_length_sent > 0 THEN
      prompt_for_data := FALSE;
      IF p_driver_queue_entry^.data_descriptor.actual_length <> 0 THEN

{ Design glitch (unless preallocated page data space is intended); rma_list is supposed to be initialized in
{ call to RECEIVE_DATA further down...

        IF dfv$file_server_debug_enabled THEN
          display_integer_to_console (' DF - SERVER- DRIVER Q ENTRY DD ACTUAL LENGTH <> 0, = ',
                p_driver_queue_entry^.data_descriptor.actual_length);
          display_integer (' DF - SERVER- DRIVER Q ENTRY DD ACTUAL LENGTH <> 0, = ',
                p_driver_queue_entry^.data_descriptor.actual_length);
        IFEND;

        IF p_driver_queue_entry^.flags.data_received THEN

{ Data was already delivered; don't prompt for data.

          IF dfv$file_server_debug_enabled THEN
            display_to_console (' DF - SERVER- DRIVER Q ENTRY DATA_RECEIVED = TRUE');
            display (' DF - SERVER- DRIVER Q ENTRY DATA_RECEIVED = TRUE');
          IFEND;

        ELSE {page buffer space already set up, but no data in STORNET}

{ Error: The data word_count sent was zero (0), or the driver's STORNET header info was bashed.

          IF dfv$file_server_debug_enabled THEN
            display_to_console (' DF - SERVER- DRIVER Q ENTRY DATA_RECEIVED = FALSE');
            display (' DF - SERVER- DRIVER Q ENTRY DATA_RECEIVED = FALSE');
          IFEND;
        IFEND;

        IF dfv$file_server_debug_enabled THEN
          display_integer_to_console (' DF - SERVER- DRIVER Q INDEX = ', queue_index);
          display_integer (' DF - SERVER- DRIVER Q INDEX = ', queue_index);
          display_integer_to_console (' DF - SERVER- DRIVER Q ENTRY INDEX = ', queue_entry_index);
          display_integer (' DF - SERVER- DRIVER Q ENTRY INDEX = ', queue_entry_index);
          display_to_console (' DF - SERVER- IGNORING PROMPT FOR DATA');
          display (' DF - SERVER- IGNORING PROMPT FOR DATA');
        IFEND;

      ELSE {indirect address list not set up yet}

{ This is the normal case.

        IF p_driver_queue_entry^.held_over_cm_word_count = 0 THEN

{ Error: The data word_count sent was zero (0), or the driver's STORNET header info was bashed.

          IF dfv$file_server_debug_enabled THEN
            display_to_console (' DF - SERVER- DRIVER Q ENTRY HELD_OVER_CM_WORD_COUNT = 0 ');
            display (' DF - SERVER- DRIVER Q ENTRY HELD_OVER_CM_WORD_COUNT = 0 ');
            display_integer_to_console (' DF - SERVER- DRIVER Q INDEX = ', queue_index);
            display_integer (' DF - SERVER- DRIVER Q INDEX = ', queue_index);
            display_integer_to_console (' DF - SERVER- DRIVER Q ENTRY INDEX = ', queue_entry_index);
            display_integer (' DF - SERVER- DRIVER Q ENTRY INDEX = ', queue_entry_index);
            display_to_console (' DF - SERVER- IGNORING PROMPT FOR DATA');
            display (' DF - SERVER- IGNORING PROMPT FOR DATA');
          IFEND;

        ELSE

{ OK to prompt for data

          prompt_for_data := TRUE;
        IFEND;
      IFEND;

      IF prompt_for_data THEN
        { Data really has been sent from the client to the server.
        receive_data (p_queue_interface_table, queue_index, queue_entry_index, p_cpu_queue_entry,
              p_driver_queue_entry, p_receive_buffer_header, p_receive_rpc_buffer_header,
              driver_error_alert);
        IF driver_error_alert THEN
          { Allow time out and retransmission
          { On the next retransmission, the retransmission code will treat this
          { like a request that was not previously seen, based upon the
          { transaction_per_rpc_request.
          { This works because no other fields have been changed up to this point.
           p_cpu_queue_entry^.call_progress.transaction_per_rpc_request :=
                p_cpu_queue_entry^.call_progress.transaction_per_rpc_request - 1;
          RETURN;
        IFEND;
        IF p_cpu_queue_entry^.call_progress.total_data_received >=
              p_cpu_queue_entry^.total_data_to_receive THEN
          { All data has been received;
          call_remote_procedure (p_queue_interface_table, queue_index, queue_entry_index, p_cpu_queue_entry,
                p_driver_queue_entry, p_receive_buffer_header, current_rpc_entry,
                p_receive_rpc_buffer_header);
        ELSE { More data to receive.
          send_normal_status (p_queue_interface_table, queue_index, queue_entry_index, p_cpu_queue_entry,
                p_driver_queue_entry, p_receive_buffer_header);
        IFEND;
      IFEND; {prompt for data}
    ELSEIF (p_cpu_queue_entry^.call_progress.user_data_length_sent >
          p_receive_rpc_buffer_header^.call_progress.total_data_received) THEN
      {Still more data to send to client
      send_data (p_queue_interface_table, queue_index, queue_entry_index, p_cpu_queue_entry,
            p_driver_queue_entry, p_receive_buffer_header, current_rpc_entry, p_receive_rpc_buffer_header);
    ELSE { Buffer only received
      call_remote_procedure (p_queue_interface_table, queue_index, queue_entry_index, p_cpu_queue_entry,
            p_driver_queue_entry, p_receive_buffer_header, current_rpc_entry, p_receive_rpc_buffer_header);
    IFEND;

  PROCEND receive_new_request;
?? TITLE := ' receive_retransmittal ', EJECT ??

{ The server has seen this request before but the client has not
{ received  a response.  Determine the state of the transaction, whether the
{ server is receiving data from the client, sending data to the client, or
{ if no data movement is involved the send buffer is merely sent back to the
{ client.  This also checks if the previous request errored when prompting for
{ data.

  PROCEDURE receive_retransmittal
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry;
     VAR status: ost$status);

    VAR
      current_rpc_entry: dft$rpc_procedure_address_entry,
      p_receive_buffer_header: ^dft$buffer_header,
      p_receive_rpc_buffer_header: ^dft$rpc_buffer_header;

    status.normal := TRUE;
    dfp$clear_server_driver_flags (p_driver_queue_entry);
    RESET p_cpu_queue_entry^.p_receive_buffer;
    NEXT p_receive_buffer_header IN p_cpu_queue_entry^.p_receive_buffer;
    NEXT p_receive_rpc_buffer_header IN p_cpu_queue_entry^.p_receive_buffer;
    get_current_rpc_entry (p_receive_buffer_header^.remote_processor,
          p_receive_rpc_buffer_header, ^p_queue_interface_table^.queue_directory
          .cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header,
          current_rpc_entry);

    { Determine if the error occurred prompting for data on the
    { previous request.  If so, nothing had been done on the previous request
    { so allow the request to be viewed as a new request.
    IF (p_receive_buffer_header^.data_length_sent > 0) AND
       ((p_receive_rpc_buffer_header^.call_progress.transaction_per_rpc_request = 1) OR
       (p_receive_rpc_buffer_header^.call_progress.transaction_per_rpc_request  =
        (p_cpu_queue_entry^.call_progress.transaction_per_rpc_request + 1))) THEN
      IF dfv$file_server_debug_enabled THEN
        display_integer_to_console (' RETRANS AFTER RECEIVE DATA PROMPT',
             p_receive_buffer_header^.data_length_sent);
      IFEND;
       receive_new_request (p_queue_interface_table, queue_index, queue_entry_index,
            p_driver_queue_entry, p_cpu_queue_entry, status);
       RETURN;
    IFEND;
    validate_progress_retransmittal (p_cpu_queue_entry, p_receive_buffer_header, p_receive_rpc_buffer_header);
    IF p_receive_buffer_header^.data_length_sent > 0 { From client} THEN
      { receiving data  from client
      IF dfv$file_server_debug_enabled THEN
        display_integer_to_console (' DF - SERVER- RECEIVE RETRANSMITTED DATA',
              p_receive_buffer_header^.data_length_sent);
        display_integer (' DF - SERVER- RECEIVE RETRANSMITTED DATA',
              p_receive_buffer_header^.data_length_sent);
      IFEND;
      receive_retransmitted_data (p_queue_interface_table, queue_index, queue_entry_index, p_cpu_queue_entry,
            p_driver_queue_entry, p_receive_buffer_header);
    ELSEIF (p_cpu_queue_entry^.call_progress.user_data_length_sent > 0) THEN
      { Sending_data - Server TO Client }
      { Because we first check that we are not receiving data, we know this is
      { not a remote procedure call request with data movement in both
      { directions.
      IF current_rpc_entry.request_restartable =
            dfc$request_restartable THEN
        IF dfv$file_server_debug_enabled THEN
          display_to_console (' DF - SERVER- REQUEST RESTARTABLE ');
          display (' DF - SERVER- REQUEST RESTARTABLE ');
        IFEND;
        send_restart_request_status (p_queue_interface_table, queue_index, queue_entry_index,
              p_cpu_queue_entry, p_driver_queue_entry, p_receive_buffer_header,
              dfe$restart_server_request);
      ELSE { Data has been saved.
        IF dfv$file_server_debug_enabled THEN
          display_to_console ('DF -  SERVER- RE_SEND_SAVED_DATA ');
          display ('DF -  SERVER- RE_SEND_SAVED_DATA ');
        IFEND;
        re_send_saved_data (p_queue_interface_table, queue_index, queue_entry_index, p_cpu_queue_entry,
              p_driver_queue_entry);
      IFEND;
    ELSE { No Data movement - buffer only }
      {Send response buffer back
      IF dfv$file_server_debug_enabled THEN
        display_to_console (' DF -SERVER-  RE_SEND_BUFFER ');
        display (' DF -SERVER-  RE_SEND_BUFFER ');
      IFEND;
      re_send_buffer (p_queue_interface_table, queue_index, queue_entry_index, p_cpu_queue_entry,
            p_driver_queue_entry);
    IFEND;

  PROCEND receive_retransmittal;
?? TITLE := ' receive_retransmitted_data ', EJECT ??
{
{  This procedure promtps for the data, and sends the response buffer
{  back to the client. Since we are receiving data, we know that we do not
{  need to send data back with this request.

  PROCEDURE receive_retransmitted_data
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         p_receive_buffer_header: ^dft$buffer_header);

    VAR
      p_re_received_data: ^cell,
      page_count: ost$non_negative_integers,
      status: ost$status;

    { Re-receive the transmitted data
    p_re_received_data := #ADDRESS (#RING (p_cpu_queue_entry^.p_receive_data),
          #SEGMENT (p_cpu_queue_entry^.p_receive_data), #OFFSET (p_cpu_queue_entry^.p_receive_data) +
          p_cpu_queue_entry^.call_progress.total_data_received - p_receive_buffer_header^.data_length_sent);
    IF p_cpu_queue_entry^.remote_procedure_called THEN
      { All data has been received already, and the data has already been
      { freed, force the pages to be wired down again.
      dfp$touch_pages (p_re_received_data, p_receive_buffer_header^.data_length_sent, page_count);
    IFEND;

    dfp$initialize_rma_list (p_re_received_data, { Offset = } 0, p_receive_buffer_header^.data_length_sent,
          p_cpu_queue_entry^.p_data_rma_list, p_driver_queue_entry^.data_descriptor, status);

    p_driver_queue_entry^.flags := dfv$send_ready_for_data_flags;
    IF time_to_test_retransmission (p_cpu_queue_entry) THEN
      force_retransmission ('RECEIVE_RETRANSMITTED_DATA', p_cpu_queue_entry, p_driver_queue_entry);
      RETURN;
    IFEND;
    dfp$queue_server_task_request (p_queue_interface_table, queue_index, queue_entry_index);
    dfp$await_server_subsystem (p_queue_interface_table, queue_index, p_driver_queue_entry);
    IF p_driver_queue_entry^.flags.driver_error_alert THEN
      { Allow the request to be retransmitted
      { No need to free pages, since retransmittal will re-send pages
      report_driver_error_alert (queue_index, queue_entry_index, p_driver_queue_entry);
      dfp$clear_server_driver_flags (p_driver_queue_entry);
    ELSE
      dfp$clear_server_driver_flags (p_driver_queue_entry);
      re_send_buffer (p_queue_interface_table, queue_index, queue_entry_index, p_cpu_queue_entry,
            p_driver_queue_entry);
    IFEND;
  PROCEND receive_retransmitted_data;
?? TITLE := ' report_driver_error_alert ', EJECT ??

  PROCEDURE report_driver_error_alert
    (    queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_driver_queue_entry: ^dft$driver_queue_entry);

    IF dfv$file_server_debug_enabled THEN
      display_integer_to_console (' DF - SERVER -DRIVER ERROR ', p_driver_queue_entry^.error_condition);
      display_integer_to_console (' DF - SERVER - QUEUE ', queue_index);
      display_integer_to_console (' DF - SERVER - QUEUE ENTRY', queue_entry_index);
      display_integer (' DF - SERVER -DRIVER ERROR ', p_driver_queue_entry^.error_condition);
      display_integer (' DF - SERVER - QUEUE ', queue_index);
      display_integer (' DF - SERVER - QUEUE ENTRY', queue_entry_index);
    IFEND;
  PROCEND report_driver_error_alert;
?? TITLE := ' re_send_buffer ', EJECT ??

  PROCEDURE re_send_buffer
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry);

    VAR
      p_send_buffer_header: ^dft$buffer_header;

    RESET p_cpu_queue_entry^.p_send_buffer;
    NEXT p_send_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
    p_send_buffer_header^.retransmission_count := p_cpu_queue_entry^.retransmission_count;
    { All other fields should remain valid from the previous request.

    p_driver_queue_entry^.flags := dfv$send_command_flags;
    IF time_to_test_retransmission (p_cpu_queue_entry) THEN
      force_retransmission ('RE_SEND_BUFFER',p_cpu_queue_entry, p_driver_queue_entry);
    ELSE
      dfp$queue_server_task_request (p_queue_interface_table, queue_index, queue_entry_index);
     IFEND;
  PROCEND re_send_buffer;
?? TITLE := ' re_send_saved_data', EJECT ??

{  The request is not restartable so data has been left wired.  Send back the
{  saved data area.

  PROCEDURE re_send_saved_data
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry);

    VAR
      p_send_buffer_header: ^dft$buffer_header,
      status: ost$status;

    RESET p_cpu_queue_entry^.p_send_buffer;
    NEXT p_send_buffer_header IN p_cpu_queue_entry^.p_send_buffer;

    dfp$initialize_rma_list (p_cpu_queue_entry^.p_last_wired_data, {offset = } 0,
          p_cpu_queue_entry^.last_wired_length, p_cpu_queue_entry^.p_data_rma_list,
          p_driver_queue_entry^.data_descriptor, status);
    IF NOT status.normal THEN
      osp$system_error ('DF - SERVER - DATA NOT WIRED ON RETRANSMITTAL', ^status);
    IFEND;

    p_send_buffer_header^.retransmission_count := p_cpu_queue_entry^.retransmission_count;
    p_driver_queue_entry^.flags := dfv$send_command_and_data_flags;
    IF time_to_test_retransmission (p_cpu_queue_entry) THEN
      force_retransmission ('RE_SEND_SAVED_DATA', p_cpu_queue_entry, p_driver_queue_entry);
      RETURN;
    IFEND;
    dfp$queue_server_task_request (p_queue_interface_table, queue_index, queue_entry_index);
    dfp$await_server_subsystem (p_queue_interface_table, queue_index, p_driver_queue_entry);
    IF p_driver_queue_entry^.flags.driver_error_alert THEN
      { Allow the request to be retransmitted
      { No need to free pages, since retransmittal will re-send pages
      report_driver_error_alert (queue_index, queue_entry_index, p_driver_queue_entry);
    IFEND;
    { Do nothing on wakeup - pages are already saved
    dfp$clear_server_driver_flags (p_driver_queue_entry);
  PROCEND re_send_saved_data;
?? TITLE := '  send_data ', EJECT ??

  PROCEDURE send_data
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         p_receive_buffer_header: ^dft$buffer_header;
         current_rpc_entry: dft$rpc_procedure_address_entry;
         p_receive_rpc_buffer_header: ^dft$rpc_buffer_header);

    VAR
      data_send_this_request: dft$send_data_size,
      data_size_left_to_send: dft$send_data_size,
      p_current_data: ^cell,
      p_mtr_status: ^syt$monitor_status,
      p_send_buffer_header: ^dft$buffer_header,
      p_send_rpc_buffer_header: ^dft$rpc_response_buffer_header,
      status: ost$status;

    RESET p_cpu_queue_entry^.p_send_buffer;
    NEXT p_send_buffer_header IN p_cpu_queue_entry^.p_send_buffer;

    { Compute remaining data left to sent.
    data_size_left_to_send := p_cpu_queue_entry^.call_progress.user_data_length_sent -
          p_cpu_queue_entry^.call_progress.total_data_sent;
    IF data_size_left_to_send > p_queue_interface_table^.maximum_data_bytes THEN
      { All the remaining  data won't fit in this request
      data_send_this_request := p_queue_interface_table^.maximum_data_bytes;
      p_send_buffer_header^.buffer_length_sent := dfp$word_boundary
            (#SIZE (dft$buffer_header) + #SIZE (syt$monitor_status) + #SIZE (dft$rpc_response_buffer_header));
    ELSE { Last send request
      { Only send all of the parameters over with the final piece of
      { data.  Note: The user parameters have already been nexted into
      { send buffer by the call_remote_procedure routine.
      data_send_this_request := data_size_left_to_send;
      p_send_buffer_header^.buffer_length_sent := dfp$word_boundary
            (#SIZE (dft$buffer_header) + #SIZE (syt$monitor_status) + #SIZE (dft$rpc_response_buffer_header) +
            p_cpu_queue_entry^.call_progress.user_buffer_length_sent);
    IFEND;
    dfp$initialize_rma_list (p_cpu_queue_entry^.p_send_data,
          {offset = } p_cpu_queue_entry^.call_progress.total_data_sent, { Length = } data_send_this_request,
          p_cpu_queue_entry^.p_data_rma_list, p_driver_queue_entry^.data_descriptor, status);

    { Initialize send buffer
    p_send_buffer_header^.version := dfc$status_buffer_version;
    p_send_buffer_header^.transaction_count := p_cpu_queue_entry^.transaction_count;
    p_send_buffer_header^.retransmission_count := p_cpu_queue_entry^.retransmission_count;
    p_send_buffer_header^.remote_processor := p_receive_buffer_header^.remote_processor;
    p_send_buffer_header^.data_length_sent := (p_driver_queue_entry^.data_descriptor.actual_length DIV 8) *
          osv$page_size;

    NEXT p_mtr_status IN p_cpu_queue_entry^.p_send_buffer;
    p_mtr_status^.normal := TRUE;

    p_cpu_queue_entry^.call_progress.total_data_sent := p_cpu_queue_entry^.call_progress.total_data_sent +
          p_send_buffer_header^.data_length_sent;
    { Initialize send remote procedure call
    NEXT p_send_rpc_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
    p_send_rpc_buffer_header^.call_progress := p_cpu_queue_entry^.call_progress;

    p_driver_queue_entry^.send_buffer_descriptor.actual_length := p_send_buffer_header^.buffer_length_sent;
    p_driver_queue_entry^.flags := dfv$send_command_and_data_flags;

    IF time_to_test_retransmission (p_cpu_queue_entry) THEN
      force_retransmission ('SEND_DATA', p_cpu_queue_entry, p_driver_queue_entry);
    ELSE
      dfp$queue_server_task_request (p_queue_interface_table, queue_index, queue_entry_index);
      dfp$await_server_subsystem (p_queue_interface_table, queue_index, p_driver_queue_entry);
    IFEND;
    wakeup_after_sending_data (p_send_buffer_header, queue_index, queue_entry_index, p_driver_queue_entry,
          current_rpc_entry, p_cpu_queue_entry);
  PROCEND send_data;
?? TITLE := '  send_normal_status ', EJECT ??

  PROCEDURE send_normal_status
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         p_receive_buffer_header: ^dft$buffer_header);

    VAR
      p_send_buffer_header: ^dft$buffer_header,
      p_send_mtr_status: ^syt$monitor_status,
      p_send_rpc_buffer_header: ^dft$rpc_response_buffer_header;

    RESET p_cpu_queue_entry^.p_send_buffer;
    NEXT p_send_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
    p_send_buffer_header^.version := dfc$status_buffer_version;
    p_send_buffer_header^.transaction_count := p_cpu_queue_entry^.transaction_count;
    p_send_buffer_header^.retransmission_count := p_cpu_queue_entry^.retransmission_count;
    p_send_buffer_header^.remote_processor := p_receive_buffer_header^.remote_processor;
    p_send_buffer_header^.buffer_length_sent := dfp$word_boundary
          (#SIZE (dft$buffer_header) + #SIZE (syt$monitor_status) + #SIZE (dft$rpc_response_buffer_header));
    p_send_buffer_header^.data_length_sent := 0;

    NEXT p_send_mtr_status IN p_cpu_queue_entry^.p_send_buffer;
    p_send_mtr_status^.normal := TRUE;

    NEXT p_send_rpc_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
    p_send_rpc_buffer_header^.call_progress := p_cpu_queue_entry^.call_progress;

    p_driver_queue_entry^.send_buffer_descriptor.actual_length := p_send_buffer_header^.buffer_length_sent;
    p_driver_queue_entry^.flags := dfv$send_command_flags;
    IF time_to_test_retransmission (p_cpu_queue_entry) THEN
      force_retransmission ('SEND_NORMAL_STATUS', p_cpu_queue_entry, p_driver_queue_entry);
    ELSE
      dfp$queue_server_task_request (p_queue_interface_table, queue_index, queue_entry_index);
    IFEND;
  PROCEND send_normal_status;
?? TITLE := ' send_restart_request_status ', EJECT ??

  PROCEDURE send_restart_request_status
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         p_receive_buffer_header: ^dft$buffer_header;
         status_condition: ost$status_condition_code);

    VAR
      free_status: ost$status,
      p_mtr_status: ^syt$monitor_status,
      p_send_buffer_header: ^dft$buffer_header,
      p_send_rpc_buffer_header: ^dft$rpc_response_buffer_header,
      p_status: ^ost$status;

    IF p_cpu_queue_entry^.call_progress.total_data_sent > 0 THEN
      mmp$free_pages (p_cpu_queue_entry^.p_send_data, p_cpu_queue_entry^.call_progress.total_data_sent,
            osc$wait, free_status);
    IFEND;

    RESET p_cpu_queue_entry^.p_send_buffer;

    { Initialize send buffer.
    NEXT p_send_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
    p_send_buffer_header^.version := dfc$status_buffer_version;
    p_send_buffer_header^.transaction_count := p_cpu_queue_entry^.transaction_count;
    p_send_buffer_header^.retransmission_count := p_cpu_queue_entry^.retransmission_count;
    p_send_buffer_header^.remote_processor := p_receive_buffer_header^.remote_processor;
    p_send_buffer_header^.buffer_length_sent := dfp$word_boundary
          (#SIZE (dft$buffer_header) + #SIZE (syt$monitor_status) + #SIZE (ost$status) +
          #SIZE (dft$rpc_response_buffer_header));
    p_send_buffer_header^.data_length_sent := 0;

    { Initialize status
    NEXT p_mtr_status IN p_cpu_queue_entry^.p_send_buffer;
    p_mtr_status^.normal := FALSE;
    p_mtr_status^.condition := status_condition;
    NEXT p_status IN p_cpu_queue_entry^.p_send_buffer;
    osp$set_status_abnormal (dfc$file_server_id, status_condition, '', p_status^);

{ Initialize remote procedure call header.
    NEXT p_send_rpc_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
    p_send_rpc_buffer_header^.call_progress.total_data_sent := 0;
    p_send_rpc_buffer_header^.call_progress.total_data_received := 0;
    p_send_rpc_buffer_header^.call_progress.transaction_per_rpc_request :=
          p_cpu_queue_entry^.call_progress.transaction_per_rpc_request;
    p_send_rpc_buffer_header^.call_progress.total_data_received := 0;
    p_send_rpc_buffer_header^.call_progress.user_buffer_length_sent := 0;
    p_send_rpc_buffer_header^.call_progress.user_data_length_sent := 0;

    p_driver_queue_entry^.send_buffer_descriptor.actual_length := p_send_buffer_header^.buffer_length_sent;
    p_driver_queue_entry^.flags := dfv$send_command_flags;
    IF time_to_test_retransmission (p_cpu_queue_entry) THEN
      force_retransmission ('SEND_RESTART_REQUEST_STATUS', p_cpu_queue_entry, p_driver_queue_entry);
      RETURN;
    IFEND;
    dfp$queue_server_task_request (p_queue_interface_table, queue_index, queue_entry_index);
  PROCEND send_restart_request_status;
?? TITLE := ' time_to_test_retransmission ', EJECT ??

{ This function is controlled by two variables that may be changed by use of
{ the system core debugger.
{ dfv$test_retransmission_count (2 bytes) controls how often (in terms of
{   transactions) a  retransmittal will be forced. The default is zero.
{ dfv$test_retransmit_retransmit (1 byte) controls whether to force retransmist
{   during replying to a retransmittal.  The value indicates how many times
{   the retransmittal will fail. The default is to have the retransmittals
{   succeed.

  FUNCTION [INLINE] time_to_test_retransmission
    (    p_cpu_queue_entry: ^dft$cpu_queue_entry): boolean;

    time_to_test_retransmission := (dfv$test_retransmission_count > 0) AND
          (((p_cpu_queue_entry^.transaction_count DIV dfv$test_retransmission_count) *
          dfv$test_retransmission_count) = p_cpu_queue_entry^.transaction_count) AND
          (p_cpu_queue_entry^.retransmission_count <= dfv$test_retransmit_retransmit);
  FUNCEND time_to_test_retransmission;

?? TITLE := ' validate_call_progress', EJECT ??

{  This procedure verifies the progress of an ongoing remote procedure
{  call request.

  PROCEDURE validate_call_progress
    (    p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_receive_buffer_header: ^dft$buffer_header;
         p_receive_rpc_buffer_header: ^dft$rpc_buffer_header);

    VAR
      status: ost$status;

    status.normal := TRUE;

    IF p_receive_rpc_buffer_header^.call_progress.transaction_per_rpc_request <>
          (p_cpu_queue_entry^.call_progress.transaction_per_rpc_request + 1) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$protocol_error_sequence, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            p_cpu_queue_entry^.call_progress.transaction_per_rpc_request, 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            p_receive_rpc_buffer_header^.call_progress.transaction_per_rpc_request, 10, FALSE, status);
      osp$system_error (' DF- SERVER- RPC TRANSACTION COUNT MISMATCH ', ^status);
    IFEND;
    IF p_receive_rpc_buffer_header^.call_progress.user_data_length_sent <>
          p_cpu_queue_entry^.total_data_to_receive THEN
      osp$system_error ('DF - SERVER  - DATA TO RECEIVE MISMATCH ', NIL);
    IFEND;
    IF (p_receive_buffer_header^.data_length_sent > 0) AND
          (p_receive_buffer_header^.data_length_sent + p_cpu_queue_entry^.call_progress.total_data_received <>
          p_receive_rpc_buffer_header^.call_progress.total_data_sent) THEN
      osp$system_error ('DF - SERVER  - DATA RECEIVED MISMATCH ', NIL);
    IFEND;
    IF p_receive_rpc_buffer_header^.call_progress.total_data_received <>
          p_cpu_queue_entry^.call_progress.total_data_sent THEN
      osp$system_error ('DF - SERVER  - DATA SENT MISMATCH ', NIL);
    IFEND;
  PROCEND validate_call_progress;

?? TITLE := ' validate_procedure_address ', EJECT ??

  PROCEDURE validate_procedure_address
    (    p_receive_buffer_header: ^dft$buffer_header;
         p_receive_rpc_buffer_header: ^dft$rpc_buffer_header);

    IF (p_receive_buffer_header^.remote_processor > UPPERVALUE (dft$procedure_address_ordinal)) OR
          {} (p_receive_buffer_header^.remote_processor < LOWERVALUE (dft$procedure_address_ordinal)) OR
          (dfv$procedure_address_list [p_receive_buffer_header^.remote_processor].procedure_name_checksum <>
          p_receive_rpc_buffer_header^.procedure_name_checksum) OR
          (dfv$procedure_address_list [p_receive_buffer_header^.remote_processor].procedure_version <>
          p_receive_rpc_buffer_header^.procedure_version) THEN

      osp$system_error ('DF - SERVER - PROCEDURE ADDRESS MISMATCH ', NIL);
    IFEND;
  PROCEND validate_procedure_address;
?? TITLE := ' validate_progress_retransmittal ', EJECT ??

  PROCEDURE validate_progress_retransmittal
    (    p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_receive_buffer_header: ^dft$buffer_header;
         p_receive_rpc_buffer_header: ^dft$rpc_buffer_header);

    VAR
      p_send_buffer_header: ^dft$buffer_header;

    IF p_receive_rpc_buffer_header^.call_progress.transaction_per_rpc_request <>
          p_cpu_queue_entry^.call_progress.transaction_per_rpc_request THEN
      osp$system_error ('DF - SERVER - TRANSACTION MISMATCH ON RETRANSMITAL', NIL);
    IFEND;
    IF p_receive_rpc_buffer_header^.call_progress.total_data_sent <>
          (p_cpu_queue_entry^.call_progress.total_data_received +
           p_receive_buffer_header^.data_length_sent) THEN
      osp$system_error ('DF - SERVER - DATA RECEIVED MISMATCH ON RETRANSMITAL', NIL);
    IFEND;
    IF p_receive_rpc_buffer_header^.call_progress.user_data_length_sent <>
          p_cpu_queue_entry^.total_data_to_receive THEN
      osp$system_error ('DF - SERVER - DATA TO RECEIVED MISMATCH ON RETRANSMITAL', NIL);
    IFEND;
    RESET p_cpu_queue_entry^.p_send_buffer;
    NEXT p_send_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
    IF p_receive_rpc_buffer_header^.call_progress.total_data_received <>
          (p_cpu_queue_entry^.call_progress.total_data_sent - p_send_buffer_header^.data_length_sent) THEN
      osp$system_error ('DF - SERVER - DATA SEND MISMATCH ON RETRANSMITAL', NIL);
    IFEND;

  PROCEND validate_progress_retransmittal;
?? TITLE := ' wakeup_after_sending_data ', EJECT ??
{
{  After sending data to the client, determine whether the data should be
{  saved or not.  If the request is restartable data is not saved.

  PROCEDURE wakeup_after_sending_data
    (    p_send_buffer_header: ^dft$buffer_header;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         current_rpc_entry: dft$rpc_procedure_address_entry;
         p_cpu_queue_entry: ^dft$cpu_queue_entry);

    VAR
      p_current_data: ^cell,
      status: ost$status;

    IF p_driver_queue_entry^.flags.driver_error_alert THEN
      report_driver_error_alert (queue_index, queue_entry_index, p_driver_queue_entry);
    ELSE
      p_current_data := #ADDRESS (#RING (p_cpu_queue_entry^.p_send_data),
            #SEGMENT (p_cpu_queue_entry^.p_send_data), #OFFSET (p_cpu_queue_entry^.p_send_data) +
            p_cpu_queue_entry^.call_progress.total_data_sent - p_send_buffer_header^.data_length_sent);
      IF current_rpc_entry.request_restartable =
            dfc$request_restartable THEN
        mmp$free_pages (p_current_data, p_send_buffer_header^.data_length_sent, osc$wait, status);
      ELSE
        p_cpu_queue_entry^.p_last_wired_data := p_current_data;
        p_cpu_queue_entry^.last_wired_length := p_send_buffer_header^.data_length_sent;
      IFEND;
    IFEND;
    dfp$clear_server_driver_flags (p_driver_queue_entry);

  PROCEND wakeup_after_sending_data;


MODEND dfm$server_remote_procedur_call;

*DECK DECK=DFM$SERVER_STUBS EXPAND=TRUE
*copyc osd$default_pragmats
?? RIGHT := 110 ??
MODULE dfm$server_stubs;
{
{  This module contains stubs of routines that are used by the file server
{  code.  These are provided only to allow a certain amount of checkout
{  in a closed shop environment.
{
?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc dfd$driver_queue_types
*copyc dfi$display
*copyc dfs$server_wired
*copyc dft$client_job_list
*copyc dft$cpu_queue
*copyc dft$one_word_response_handler
*copyc dft$queue_index
*copyc dft$remote_request
*copyc dmt$system_file_id
*copyc dpt$window_class
*copyc dpt$window_id
*copyc dpt$window_kind
*copyc iot$pp_number
*copyc iot$io_request
*copyc ofd$type_definition
*copyc oft$refreshing_displays
*copyc oft$system_line_info
*copyc osp$set_status_abnormal
*copyc oss$mainframe_wired_literal
*copyc ost$global_task_id
*copyc ost$heap
*copyc ost$page_size
*copyc ost$signature_lock
*copyc ost$status
*copyc ost$user_identification
*copyc ost$wait
*copyc std$set_name
?? POP ??
?? NEWTITLE := '   Global Variables', EJECT ??


  VAR
    osv$page_size: [XDCL] ost$page_size := 4096;

  VAR
    dfv$one_word_response_handler: [XDCL] dft$one_word_response_handler := NIL;

  VAR
    dmv$external_interrupt_selector: [XDCL] 0 .. 0ff(16) := 1;

  VAR
    osv$external_interrupt_selector: [XDCL] 0 .. 0ff(16) := 1;

  VAR
    dfv$null_global_task_id: [XDCL] ost$global_task_id := [1, 1];

  VAR
    dmv$null_sfid: [XDCL, STATIC, READ, #GATE, oss$mainframe_wired_literal] dmt$system_file_id :=
          [0, dmc$invalid_file_location, 0];

?? EJECT ??

  PROCEDURE [XDCL] ofp$send_to_operator
    (    operator_message: string ( * );
         operator_id: oft$operator_id;
         status: ost$status);

    display (operator_message);
  PROCEND ofp$send_to_operator;

?? SKIP := 5 ??

  PROCEDURE [XDCL] osp$begin_system_activity;

  PROCEND osp$begin_system_activity;

  PROCEDURE [XDCL] osp$begin_subsystem_activity;

  PROCEND osp$begin_subsystem_activity;


  PROCEDURE [XDCL] osp$end_subsystem_activity;

  PROCEND osp$end_subsystem_activity;

?? SKIP := 5 ??

  PROCEDURE [XDCL] osp$clear_job_signature_lock
    (VAR lock: ost$signature_lock);

    VAR
      status: ost$status;

    osp$clear_signature_lock (lock, status);

  PROCEND osp$clear_job_signature_lock;

?? SKIP := 5 ??

  PROCEDURE [XDCL] osp$clear_signature_lock
    (VAR lock: ost$signature_lock;
     VAR status: ost$status);

    status.normal := TRUE;
    IF lock.lock_id <> 12 THEN
      display (' lock not set ');
      osp$set_status_abnormal ('GS', 333000, 'LOCK NOT SET', status);
    IFEND;
    lock.lock_id := 0;
    {display (' osp$clear_signature_lock stub');
  PROCEND osp$clear_signature_lock;

?? SKIP := 5 ??

  PROCEDURE [XDCL] osp$end_system_activity;

  PROCEND osp$end_system_activity;

?? SKIP := 5 ??

  PROCEDURE [XDCL] osp$initialize_signature_lock
    (VAR lock: ost$signature_lock;
     VAR status: ost$status);

    status.normal := TRUE;
    lock.lock_id := 0;
    lock.lock_count := 0;
  PROCEND osp$initialize_signature_lock;

?? SKIP := 5 ??

  PROCEDURE [XDCL] osp$recoverable_system_error
    (    error_message: string ( * );
         p_status: ^ost$status);

    display (' osp$recoverable_system_error');
    display (error_message);
    IF p_status <> NIL THEN
      display_status (p_status^);
    IFEND;
  PROCEND osp$recoverable_system_error;

?? SKIP := 5 ??

  PROCEDURE [XDCL] osp$set_job_signature_lock
    (VAR lock: ost$signature_lock);

    VAR
      status: ost$status,
      wait: ost$wait;

    osp$set_signature_lock (lock, wait, status);

  PROCEND osp$set_job_signature_lock;

?? SKIP := 5 ??

  PROCEDURE [XDCL] osp$set_signature_lock
    (VAR lock: ost$signature_lock;
         wait: ost$wait;
     VAR status: ost$status);

    status.normal := TRUE;
    IF lock.lock_id <> 0 THEN
      display (' lock already set');
      osp$set_status_abnormal ('GS', 333000, ' lock already set', status);
    ELSE
      lock.lock_id := 12;
      lock.lock_count := lock.lock_count + 1;
    IFEND;
    {display (' osp$set_signature_lock stub');
  PROCEND osp$set_signature_lock;

?? SKIP := 5 ??

  PROCEDURE [XDCL] osp$system_error
    (    error_message: string ( * );
         status: ^ost$status);

    display ('osp$system_error');
    display (error_message);
    IF status <> NIL THEN
      display_status (status^);
    IFEND;
  PROCEND osp$system_error;

?? SKIP := 5 ??

  PROCEDURE [XDCL] pfp$process_job_end;

    display (' pfp$process_job_end ');
  PROCEND pfp$process_job_end;

?? SKIP := 5 ??

  PROCEDURE [XDCL] pfp$set_task_environment
    (    p_client_job_space: ^dft$client_job_space);

  PROCEND pfp$set_task_environment;
?? SKIP := 5 ??


  PROCEDURE [XDCL] pmp$long_term_wait
    (    requested_ms: 0 .. 0ffffffffffff(16);
         expected_ms: 0 .. 0ffffffffffff(16));

    display (' pmp$long_term_wait returning ');
  PROCEND pmp$long_term_wait;

?? SKIP := 5 ??

  PROCEDURE [XDCL] pmp$wait
    (    requested_ms: 0 .. 0ffffffffffff(16);
         expected_ms: 0 .. 0ffffffffffff(16));

  PROCEND pmp$wait;

?? SKIP := 5 ??

  PROCEDURE [XDCL, #GATE] cmp$get_next_request
    (    element_name: cmt$element_name;
     VAR next_request: ^iot$io_request;
     VAR status: ost$status);

  PROCEND cmp$get_next_request;
?? SKIP := 5 ??

  PROCEDURE [XDCL, #GATE] cmp$get_pp_number
    (    element_name: cmt$element_name;
     VAR pp_number: iot$pp_number;
     VAR status: ost$status);

    pp_number := 1;
    status.normal := TRUE;

  PROCEND cmp$get_pp_number;
?? SKIP := 5 ??

  PROCEDURE [XDCL, #GATE] dmp$mfh_for_sfid
    (    system_file_id: dmt$system_file_id;
     VAR status: ost$status);


  PROCEND dmp$mfh_for_sfid;
?? SKIP := 5 ??

  PROCEDURE [XDCL, #GATE] mmp$restart_server_request
    (    p_cpu_queue_entry: ^dft$cpu_queue_entry;
         remote_request: dft$remote_request);

  PROCEND mmp$restart_server_request;

?? SKIP := 5 ??

  PROCEDURE [XDCL, #GATE] mtp$error_stop
    (    text: string (*));

    display ('ERROR_STOP called with:');
    display (text);

  PROCEND mtp$error_stop;

?? SKIP := 5 ??

  PROCEDURE [XDCL, #GATE] cmp$store_file_server_info
    (    element_name: cmt$element_name;
         next_request: ^iot$io_request;
         one_word_response_allowed: boolean;
         one_word_response_processor: dft$one_word_response_handler;
     VAR status: ost$status);

  PROCEND cmp$store_file_server_info;
?? EJECT ??

  PROCEDURE [XDCL] stp$get_set_owner ALIAS 'STAIGOW'
    (    set_name: stt$set_name;
     VAR set_owner: ost$user_identification;
     VAR status: ost$status);

    status.normal := TRUE;
    set_owner.family := '$SYSTEM';
    set_owner.user := '$SYSTEM';
  PROCEND stp$get_set_owner;

?? EJECT ??
  { Operator display stubs

  VAR
    ofv$system_line_info: [XDCL] array [oft$refreshing_displays] of oft$system_line_info;


  PROCEDURE [XDCL] dpp$change_window
    (    window_id: dpt$window_id;
         class: dpt$window_class;
         kind: dpt$window_kind;
     VAR status: ost$status);

    osp$set_status_abnormal ('GS', 333000, 'NO CONSOLE DISPLAYS ', status);
  PROCEND dpp$change_window;

  PROCEDURE [XDCL] dpp$clear_window
    (    window_id: dpt$window_id;
     VAR status: ost$status);

    osp$set_status_abnormal ('GS', 333000, 'NO CONSOLE DISPLAYS ', status);
  PROCEND dpp$clear_window;

  PROCEDURE [XDCL] dpp$set_title
    (    window_id: dpt$window_id;
         title: string ( * );
     VAR status: ost$status);

    osp$set_status_abnormal ('GS', 333000, 'NO CONSOLE DISPLAYS ', status);
  PROCEND dpp$set_title;

  PROCEDURE [XDCL] dpp$put_next_line
    (    window_id: dpt$window_id;
         line: string ( * );
     VAR status: ost$status);

    osp$set_status_abnormal ('GS', 333000, 'NO CONSOLE DISPLAYS ', status);
  PROCEND dpp$put_next_line;

?? SKIP := 5 ??

  PROCEDURE [XDCL] xxp$idle_requests
    (    p_queue_interface_table: ^dft$queue_interface_table;
         queue_index: dft$queue_index);

    VAR
      p_cpu_queue: ^dft$cpu_queue;

    p_cpu_queue := p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
          p_cpu_queue;
    p_cpu_queue^.queue_header.partner_status.deactivate_complete := TRUE;

  PROCEND xxp$idle_requests;


MODEND dfm$server_stubs;
*DECK DECK=DFM$SET_SERVER_EOI EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: Client ', EJECT ??
MODULE dfm$set_server_eoi;

{ PURPOSE:
{   This client module serves to act as an interface between Memory Manager
{   and the server mainframe when setting EOI for a file on that mainframe.

?? NEWTITLE := '   Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfc$test_jr_constants
*copyc dfk$keypoints
*copyc dmt$keypoints
*copyc osk$keypoints
*copyc dfe$error_condition_codes
*copyc dmt$df_set_eoi
*copyc dft$server_descriptor
*copyc ost$status
?? POP ??
*copyc dfp$get_served_file_desc_p
*copyc dfp$send_remote_procedure_call
*copyc dfp$fetch_served_family_entry
*copyc gfp$get_fde_p
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc syp$hang_if_system_jrt_set
*copyc syp$pop_inhibit_job_recovery
*copyc syp$push_inhibit_job_recovery
?? TITLE := '    [XDCL, #GATE] dfp$set_server_eoi', EJECT ??
    { The setting of eoi on the server is just a curtesy the next page fault
    {    will move the eoi over.
    { The eoi has aready been set in the system file table on the client.

  PROCEDURE [XDCL, #GATE] dfp$set_server_eoi
    (    sfid: gft$system_file_identifier;
         segment_length: ost$segment_length;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT dfp$set_server_eoi;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      able_to_locate_fde: boolean,
      fde_p: gft$file_desc_entry_p,
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: ^dmt$df_set_eoi_inp,
      p_send_to_server_params: dft$p_send_parameters,
      p_served_family_entry: ^dft$served_family_table_entry,
      p_server_descriptor: dft$server_descriptor_p,
      queue_entry_location: dft$rpc_queue_entry_location,
      remote_sfid: gft$system_file_identifier,
      served_family_table_index: dft$served_family_table_index,
      server_location: dft$server_location;

    status.normal := TRUE;
    syp$push_inhibit_job_recovery;

    gfp$get_fde_p (sfid, fde_p);
    IF fde_p = NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated, ' Set eoi ', status);
    IFEND;

    IF status.normal THEN
      dfp$get_served_file_desc_p (fde_p, p_server_descriptor);
      served_family_table_index := p_server_descriptor^.header.served_family_table_index;
      remote_sfid := p_server_descriptor^.header.remote_sfid;

      dfp$fetch_served_family_entry (served_family_table_index, p_served_family_entry, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated, ' Set eoi ', status);
      IFEND;

      IF status.normal THEN
        IF (p_server_descriptor^.header.file_state = dfc$terminated) OR
              (p_served_family_entry^.server_state = dfc$terminated) THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated, ' Set eoi ', status);
        IFEND;

        IF status.normal THEN
          IF p_server_descriptor^.header.file_state = dfc$active THEN
            server_location.server_location_selector := dfc$served_family_table_index;
            server_location.served_family_table_index := served_family_table_index;

            dfp$begin_ch_remote_proc_call (server_location, {send_if_deactivated=} FALSE,
                  queue_entry_location, p_send_to_server_params, p_send_data, status);
            IF status.normal THEN
              syp$hang_if_system_jrt_set (dfc$tjr_server_set_eoi);
              NEXT p_send_parameters IN p_send_to_server_params;
              p_send_parameters^.sfid := remote_sfid;
              p_send_parameters^.segment_length := segment_length;

              dfp$send_remote_procedure_call (queue_entry_location, dfc$df_server_set_eoi,
                     #SIZE (p_send_parameters^), { Data to send =} 0, p_receive_from_server_params,
                     p_receive_data, status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
    syp$pop_inhibit_job_recovery;
    #KEYPOINT (osk$exit, 0, dmk$df_client_set_eoi);

  PROCEND dfp$set_server_eoi;

MODEND dfm$set_server_eoi;

*DECK DECK=DFM$SHAREIT EXPAND=TRUE
PROCEDURE dfm$shareit, shareit (
 writers, w: integer 0 .. 8 = 2
 readers, r: integer 0 .. 8 = 2
 total_minutes, tm: integer = 20
 wait_milliseconds, wm: integer =  50
 file_size, fs: integer = 204800
 establish_condition_handler, ech: boolean = true
 save_print, sp: boolean = false
 create_new_file, cnf: boolean = true
 family_name, fn: name = TESTING
 user, u: name = EVAL
 password, pw: (SECURE) name = EVALPW
 access_modes, access_mode, am: (BY_NAME) list of key all, (append, a), ..
        (execute, e), (modify, m), (read, r), (shorten, s), (write, w), ..
        keyend = all
 share_modes, share_mode, sm: (BY_NAME) list of key all, none, (append, a), ..
        (execute, e), (modify, m), (read, r), (shorten, s), (write, w), ..
        keyend = all
 status)

 " This test submits multiple jobs that share a permanent file.
" Each job writes a particular words of the file
" Jobs are also submitted that read the permanent file

  family_string = $string($value(family_name))
  user_string = $string($value(user))
  password_string = $string(password)
  handler = $strrep($value(establish_condition_handler))
  save_output = $strrep($value(save_print))
      crev ignore status
  page_count = file_size/4096
  IF create_new_file THEN
    delete_file $fname(':'//family_string//'.'//user_string//'.share.1') status=ignore
    create_file $fname(':'//family_string//'.'//user_string//'.share.1')
    detach_file $fname(':'//family_string//'.'//user_string//'.share.1')
  IFEND

  FOR i = 1 to writers DO
    colt $local.j1   until='      END_JOB' sm='?'
      LOGIN USER=?user_string? PASSWORD=?password_string? FN=?family_string?
       IF ?handler? THEN
         WHEN any_fault do
           reqoa ' WRITE?$strrep(i)? failed  '//$condition_name(osv$status.condition)
           display_value osv$status
           logout
         WHENEND
       IFEND

      attach_file $user.share.1 am=?$parameter(access_modes)? sm=?$parameter(share_modes)? lfn=share
      exet sp=dfp$test_file_sharing ..
  p='lfn=share, owr=?$strrep(i)?,tm=?$strrep(tm)?,wm=?$strrep(wm)?,pc=?$strrep(page_count)?'
       IF NOT ?save_output? THEN
         terp output
      IFEND
      LOGOUT
      END_JOB
    submit_job $local.j1 user_job_name=$name('WRITE'//$strrep(i))
  FOREND

  FOR i = 1 to readers DO
    colt $local.j1   until='      END_JOB' sm='?'
      LOGIN USER=?user_string? PASSWORD=?password_string? FN=?family_string?
       IF ?handler? THEN
         WHEN any_fault do
           reqoa ' READ?$strrep(i)? failed  '//$condition_name(osv$status.condition)
           display_value osv$status
           logout
         WHENEND
       IFEND

      attach_file $user.share.1 am=?$parameter(access_modes)? sm=?$parameter(share_modes)? lfn=share
      exet sp=dfp$test_file_reading ..
  p='lfn=share, owr=?$strrep(i)?,tm=?$strrep(tm)?,wm=?$strrep(wm)?,pc=?$strrep(page_count)?'
       IF NOT ?save_output? THEN
         terp output
      IFEND
      LOGOUT
      END_JOB
    submit_job $local.j1 user_job_name=$name('READ'//$strrep(i))
  FOREND

PROCEND dfm$shareit

*DECK DECK=DFM$SUBMIT_MAXTR_JOBS EXPAND=TRUE
PROC dfm$submit_maxtr_jobs, submtrj (
  jobs, j                          : integer 0..1000000 = 16
  size, s                          : integer = 409600
  mode, m                          : key normal, n, sequential, s = N
  number_of_passes, nop, number, n : integer = 1000
  file_name_seed, fns              : file = :testing.$system.test_
  allocation_size, as              : key #16K, #32K, #65K, #131K, #262K = #16K
  status                           : var of status = $optional
  )

  mode = $string($value(mode))
  size = $strrep($value(size))
  number_of_passes = $strrep($value(number_of_passes))
  file_name_seed = $string($value(file_name_seed))
  as_value = $string($value(allocation_size))
  IF as_value = '#16K' THEN
    alloc_size = '16384'
  ELSEIF as_value = '#32K' THEN
    alloc_size = '32768'
  ELSEIF as_value = '#65K' THEN
    alloc_size = '65536'
  ELSEIF as_value = '#131K' THEN
    alloc_size = '131072'
  ELSEIF as_value = '#262K' THEN
    alloc_size = '262144'
  IFEND

  FOR i = 1 TO $value(jobs) DO
     job jn=$name('MAXTR'//$strrep(i)) sm='?'
        create_variable ign kind=status
        system_operator_utility
        copf $system.osf$builtin_library $local.built  status=ign
        setcl a=$local.built status=ign
        setpa al=$local.cyf$run_time_library status=ign
        exet  sp=rmp$request_mass_storage_cmd ..
              p='F=?file_name_seed??$STRREP(i)?  ALLOCATION_SIZE=?alloc_size?'
        detf F=?file_name_seed??$STRREP(i)? status=ign
        dfp$mtr ?file_name_seed??$STRREP(i)? ..
           mode=?mode? size=?size? number_of_passes=?number_of_passes?
    jobend
  FOREND

PROCEND dfm$submit_maxtr_jobs
*DECK DECK=DFM$TERM_PROCESSING_ON_SERVER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: Server', EJECT ??
MODULE dfm$term_processing_on_server;

{
{ PURPOSE:
{   To terminate the activities on a server mainframe which are associated
{   with a terminated or timed out client mainframe.
{
{ NOTES:
{   1. The driver queue header IDLE will be set and a wait executed to ensure
{      that all PP activity has ceased.
{   2. The convention established by dfm$clone_task_process of using
{      number_of_monitor_queue_entries + 1 as the queue entry index for
{      the monitor clone task is followed here.

?? NEWTITLE := '    Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfc$esm_driver_error_codes
*copyc dfc$poll_constants
*copyc dfd$driver_queue_types
*copyc dfd$request_package
*copyc dfe$error_condition_codes
*copyc dfi$display
*copyc dfi$log_display
*copyc dft$client_mainframe_file
*copyc dft$cpu_queue
*copyc dft$entry_type
*copyc dft$rb_file_server_request
*copyc dfv$file_server_debug_enabled
*copyc dfv$p_clone_tasks_status
*copyc dfv$null_global_task_id
*copyc mmt$server_state
*copyc osc$server_state_change
*copyc ost$caller_identifier
*copyc pmt$task_status
*copyc pmp$wait
?? POP ??
*copyc dfp$find_mainframe_id
*copyc i#call_monitor
*copyc osp$set_status_abnormal
*copyc pmp$cause_condition_in_tasks
*copyc pmp$wait
*copyc pmp$ready_task
?? TITLE := '    [XDCL] dfp$term_processing_on_server', EJECT ??

  PROCEDURE [XDCL] dfp$term_processing_on_server
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      host_is_server_to_client: boolean,
      mainframe_found: boolean,
      number_of_monitor_queue_entries: 0 .. dfc$max_queue_entries,
      number_of_task_queue_entries: dft$queue_entry_index,
      p_cpu_queue: ^dft$cpu_queue,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue: ^dft$driver_queue,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      q_d_index: dft$queue_directory_index,
      queue_entry_index: dft$queue_entry_index,
      queue_index: dft$queue_index,
      request_block: dft$rb_file_server_request,
      response_buffer_entry: dft$fs_pp_response,
      task_still_active: boolean,
      total_queue_entries: dft$queue_entry_index;

    status.normal := TRUE;
    host_is_server_to_client := TRUE;
    dfp$find_mainframe_id (mainframe_name, host_is_server_to_client, mainframe_found, p_queue_interface_table,
          p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, mainframe_name, status);
      RETURN;
    IFEND;
    IF p_cpu_queue^.queue_header.p_remote_application_info <> NIL THEN
      { The application may be processing a remote procedure call
      log_display ($pmt$ascii_logset [pmc$job_log, pmc$system_log],
            ' Calling pmp$cause_condition_in_tasks for osc$server_state_change');
      pmp$cause_condition_in_tasks (osc$server_state_change);
    IFEND;

    number_of_monitor_queue_entries := p_cpu_queue^.queue_header.number_of_monitor_queue_entries;
    number_of_task_queue_entries := p_cpu_queue^.queue_header.number_of_task_queue_entries;
    p_driver_queue := p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue;
    total_queue_entries := p_driver_queue^.queue_header.number_of_queue_entries;

{ Idle PP driver

    p_driver_queue^.queue_header.flags.idle := TRUE;
    pmp$wait (2000, 2000);

{Terminate task clone tasks

    IF dfv$p_clone_tasks_status <> NIL THEN

    /check_task_queue_entries/
      FOR queue_entry_index := dfc$poll_queue_index + number_of_monitor_queue_entries +
            1 TO total_queue_entries DO
        p_cpu_queue_entry := ^p_cpu_queue^.queue_entries [queue_entry_index];
        IF (p_cpu_queue_entry^.global_task_id <> dfv$null_global_task_id) AND
              (NOT dfv$p_clone_tasks_status^ [queue_entry_index].complete) THEN
          p_driver_queue^.queue_entries [queue_entry_index].flags.subsystem_action := TRUE;
          pmp$ready_task (p_cpu_queue_entry^.global_task_id, status);
        IFEND;
        IF NOT status.normal THEN
          IF dfv$file_server_debug_enabled THEN
            display (' DFM$TERM_PROCESSING_ON_SERVER received abnormal status ' CAT 'from PMP$READY_TASK.');
            display_status (status);
          IFEND;
          status.normal := TRUE;
        IFEND;
      FOREND /check_task_queue_entries/;
    IFEND;

{ Terminate monitor task

    request_block.reqcode := syc$rc_file_server_request;
    request_block.request := dfc$fsr_term_client_tasks;
    request_block.queue_interface_table_p := p_queue_interface_table;
    response_buffer_entry.response_flags.special_response := TRUE;
    response_buffer_entry.response_flags.one_word_response := TRUE;
    response_buffer_entry.response_flags.error_response := TRUE;
    response_buffer_entry.response_parameter.error_condition := dfc$destination_machine_down;
    response_buffer_entry.response_flags.inquiry_response := FALSE;
    response_buffer_entry.response_flags.termination_pseudo_response := TRUE;
    response_buffer_entry.response_length := 8 {bytes = 1 word} ;
    response_buffer_entry.logical_unit := 0; {Not used by dfp$process_server_response_a
    response_buffer_entry.queue_index := queue_index;

  /check_monitor_queue_entries/
    FOR queue_entry_index := 1 TO total_queue_entries DO
      p_cpu_queue_entry := ^p_cpu_queue^.queue_entries [queue_entry_index];
      IF p_cpu_queue_entry^.processor_type <> dfc$monitor THEN
        CYCLE /check_monitor_queue_entries/;
      IFEND;

    /wait_till_io_complete/
      REPEAT
        pmp$wait (10, 10);
        #SPOIL (p_cpu_queue_entry^.p_server_iocb^.server_state);
        #SPOIL (p_cpu_queue_entry^.data_pages_locked);
      UNTIL (p_cpu_queue_entry^.p_server_iocb^.server_state = mmc$ss_waiting) OR
            p_cpu_queue_entry^.data_pages_locked;

      IF p_cpu_queue_entry^.data_pages_locked THEN
        response_buffer_entry.queue_entry_index := queue_entry_index;
        request_block.one_word_response := response_buffer_entry;
        request_block.cpu_queue_entry_p := p_cpu_queue_entry;
        request_block.status.normal := TRUE;
        p_driver_queue^.queue_entries [queue_entry_index].flags.active_entry := TRUE;
        p_driver_queue^.queue_entries [queue_entry_index].flags.driver_action := FALSE;
        p_driver_queue^.queue_entries [queue_entry_index].flags.subsystem_action := FALSE;
        p_driver_queue^.queue_entries [queue_entry_index].flags.buffer_received := TRUE;
        p_driver_queue^.queue_entries [queue_entry_index].flags.process_response := TRUE;
        i#call_monitor (#LOC (request_block), #SIZE (request_block));
      IFEND;

    /wait_till_not_waiting/
      WHILE (p_cpu_queue_entry^.p_server_iocb^.server_state <> mmc$ss_waiting) DO
        #SPOIL (p_cpu_queue_entry^.p_server_iocb^.server_state);
        pmp$wait (10, 10);
      WHILEND /wait_till_io_complete/;

    FOREND /check_monitor_queue_entries/;

{Wait until all tasks complete

    IF dfv$p_clone_tasks_status <> NIL THEN

    /wait_tasks_completion/
      REPEAT
        task_still_active := FALSE;

      /check_each_clone_task/
        FOR queue_entry_index := LOWERBOUND (dfv$p_clone_tasks_status^)
              TO UPPERBOUND (dfv$p_clone_tasks_status^) DO
          task_still_active := NOT dfv$p_clone_tasks_status^ [queue_entry_index].complete;
          IF task_still_active THEN
            IF p_cpu_queue^.queue_entries [queue_entry_index].global_task_id = dfv$null_global_task_id THEN
              task_still_active := FALSE;
            ELSE
              p_driver_queue^.queue_entries [queue_entry_index].flags.subsystem_action := TRUE;
              pmp$ready_task (p_cpu_queue^.queue_entries [queue_entry_index].global_task_id, status);
            IFEND;
            IF task_still_active THEN

{ Message to outside ?????

              pmp$wait (1000, 1000);
              EXIT /check_each_clone_task/;
            IFEND;
          IFEND;
          p_driver_queue^.queue_entries [queue_entry_index].flags.subsystem_action := FALSE;
          p_driver_queue^.queue_entries [queue_entry_index].error_condition := 0;
        FOREND /check_each_clone_task/;
      UNTIL NOT task_still_active; {/wait_tasks_completion/}

    IFEND;
    p_driver_queue^.queue_entries [dfc$poll_queue_index + 1].flags.subsystem_action := FALSE;

  PROCEND dfp$term_processing_on_server;
MODEND dfm$term_processing_on_server
*DECK DECK=DFM$TERM_REQUESTS_TO_SERVER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: Client', EJECT ??
MODULE dfm$term_requests_to_server;

{ PURPOSE:
{   The purpose of this module is to terminate the outstanding requests
{         for a server mainframe being terminated.
{

?? NEWTITLE := '   Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfc$poll_constants
*copyc dfd$driver_queue_types
*copyc dfd$request_package
*copyc dfe$error_condition_codes
*copyc dft$cpu_queue
*copyc dft$rb_file_server_request
*copyc iot$pp_interface_table
*copyc pmt$task_status
*copyc syt$monitor_status
?? POP ??
*copyc dfp$check_queue_entry_assigned
*copyc dfp$find_mainframe_id
*copyc dfp$free_entry_assignment
*copyc dfp$locate_server_translation
*copyc dfp$terminate_server_files
*copyc i#call_monitor
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$exit
*copyc pmp$wait
?? TITLE := ' [XDCL] dfp$set_terminated_access_state', EJECT ??
  PROCEDURE [XDCL] dfp$set_terminated_access_state
    (    server_mainframe_id: pmt$binary_mainframe_id);

    VAR
      mainframe_found: boolean,
      mainframe_ordinal: 1 .. dfc$max_number_of_mainframes,
      request_block: dft$rb_file_server_request;

    dfp$locate_server_translation (server_mainframe_id, mainframe_ordinal, mainframe_found);
    request_block.reqcode := syc$rc_file_server_request;
    request_block.request := dfc$fsr_set_task_segment_state;
    request_block.status.normal := TRUE;
    request_block.terminate_access_work := $dft$mainframe_set [mainframe_ordinal];
    request_block.inhibit_access_work := $dft$mainframe_set [];
    i#call_monitor (#LOC (request_block), #SIZE (request_block));

  PROCEND dfp$set_terminated_access_state;

?? TITLE := '    [XDCL] dfp$term_requests_to_server', EJECT ??

  PROCEDURE [XDCL] dfp$term_requests_to_server
    (    mainframe_name: pmt$mainframe_id;
         p_idle_task_status: ^pmt$task_status;
     VAR status: ost$status);

    VAR
      host_is_server_to_client: boolean,
      ignore_status: ost$status,
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue: ^dft$driver_queue,
      p_ost_status: ^ost$status,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_send_buffer_header: ^dft$buffer_header,
      p_status_response: ^dft$status_response,
      queue_entry_assigned: boolean,
      queue_index: dft$queue_index,
      q_d_index: dft$queue_directory_index,
      queue_entry_index: dft$queue_entry_index,
      request_block: dft$rb_file_server_request,
      response_buffer_entry: dft$fs_pp_response,
      total_queue_entries: dft$queue_entry_index;

    status.normal := TRUE;
    host_is_server_to_client := FALSE;
    dfp$find_mainframe_id (mainframe_name, host_is_server_to_client, mainframe_found,
          p_queue_interface_table, p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, mainframe_name, status);
      RETURN;
    IFEND;

    IF p_q_interface_directory_entry^.connection_type <> dfc$esm_connection THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$not_stornet_connection, mainframe_name, status);
      osp$system_error ('NON-STORNET CONNECTION - DFP$TERM_REQUESTS_TO_SERVER', ^status);
    IFEND;

    p_driver_queue := p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue;
    p_driver_queue^.queue_header.flags.idle := TRUE;
    pmp$wait (2000, 2000);

    total_queue_entries := p_driver_queue^.queue_header.number_of_queue_entries;

{Search queues for active entry and set bad status
    request_block.reqcode := syc$rc_file_server_request;
    request_block.request := dfc$fsr_term_client_tasks;
    request_block.queue_interface_table_p := p_queue_interface_table;
    response_buffer_entry.response_flags.special_response  := TRUE;
    response_buffer_entry.response_flags.one_word_response := TRUE;
    response_buffer_entry.response_flags.error_response := FALSE;
    response_buffer_entry.response_flags.inquiry_response := FALSE;
    response_buffer_entry.response_flags.termination_pseudo_response := TRUE;
    response_buffer_entry.response_length := 8 {bytes = 1 word};
    response_buffer_entry.logical_unit := 0; {Not used by dfp$process_server_response_a
    response_buffer_entry.queue_index := queue_index;

  /search_for_incomplete_actions/
    FOR queue_entry_index := dfc$poll_queue_index + 1 TO total_queue_entries DO
      dfp$check_queue_entry_assigned (queue_entry_index, p_cpu_queue^.queue_header.
            queue_entry_assignment_table, queue_entry_assigned);
      IF NOT queue_entry_assigned THEN
        CYCLE /search_for_incomplete_actions/;
      IFEND;
      p_cpu_queue_entry := ^p_cpu_queue^.queue_entries [queue_entry_index];
      response_buffer_entry.queue_entry_index := queue_entry_index;
      request_block.one_word_response := response_buffer_entry;
      RESET p_cpu_queue_entry^.p_receive_buffer;
      NEXT p_status_response IN p_cpu_queue_entry^.p_receive_buffer;
      p_status_response^.buffer_header.transaction_count := p_cpu_queue_entry^.transaction_count;
      RESET p_cpu_queue_entry^.p_send_buffer;
      NEXT p_send_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
      p_status_response^.buffer_header.version := dfc$status_buffer_version;
      p_status_response^.buffer_header.remote_processor := p_send_buffer_header^.remote_processor;
      {!! Assumming that the value returned is the same
      p_status_response^.status.normal := FALSE;
      p_status_response^.status.condition := dfe$server_has_terminated;
      IF p_cpu_queue_entry^.processor_type = dfc$task_services THEN
        NEXT p_ost_status IN p_cpu_queue_entry^.p_receive_buffer;
        osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated, mainframe_name,
              p_ost_status^);
      IFEND;
      request_block.cpu_queue_entry_p := p_cpu_queue_entry;
      request_block.status.normal := TRUE;
      p_driver_queue^.queue_entries [queue_entry_index].flags.active_entry := TRUE;
      p_driver_queue^.queue_entries [queue_entry_index].flags.driver_action := FALSE;
      p_driver_queue^.queue_entries [queue_entry_index].flags.subsystem_action := FALSE;
      p_driver_queue^.queue_entries [queue_entry_index].flags.buffer_received := TRUE;
      p_driver_queue^.queue_entries [queue_entry_index].flags.process_response := TRUE;

      i#call_monitor (#LOC (request_block), #SIZE (request_block));

      IF NOT request_block.status.normal THEN
        {  check if still assigned
        dfp$check_queue_entry_assigned (queue_entry_index, p_cpu_queue^.queue_header.
              queue_entry_assignment_table, queue_entry_assigned);
        IF queue_entry_assigned THEN
          dfp$free_entry_assignment (queue_entry_index,  p_cpu_queue^.queue_header.
                queue_entry_assignment_table);
        IFEND;
      IFEND;

    FOREND /search_for_incomplete_actions/;

{Wait for task performing idle processing - if any.
    IF p_idle_task_status <> NIL THEN
      REPEAT
        IF NOT p_idle_task_status^.complete THEN
          pmp$wait (2000, 2000);
        IFEND;
      UNTIL p_idle_task_status^.complete;
    IFEND;

    dfp$set_terminated_access_state (p_cpu_queue^.queue_header.destination_mainframe_id);

    dfp$terminate_server_files (p_cpu_queue^.queue_header.destination_mainframe_id, status);

  PROCEND dfp$term_requests_to_server;
MODEND dfm$term_requests_to_server;
*DECK DECK=DFM$TEST_APPLICATION_SUPPORT EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := ' NOS/VE File Server : Test Application Support', EJECT ??
MODULE dfm$test_application_support;

{ PURPOSE:
{   The purpose of this module is to supply test a client and a server procedure
{   to test the application support feature.
{ NOTES:
{   1. These are test procedures for local development testing only.
{   2. The server procedure is also called from dfp$client_test_app_sup_r3.

?? NEWTITLE := ' Global Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfc$client_pause_break
*copyc dfc$client_terminate_break
*copyc dfe$error_condition_codes
*copyc dft$rpc_parameters
*copyc dft$server_state
*copyc osc$server_state_change
*copyc pmt$mainframe_id
*copyc pmt$program_name
?? POP ??
*copyc clp$evaluate_parameters
*copyc dfi$display
*copyc dfp$call_remote_procedure
*copyc dfp$get_mainframe_status
*copyc osp$set_status_abnormal
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_mainframe_id
*copyc pmp$long_term_wait

  TYPE
    { NOTE: This type is also defined/used in dfm$test_app_sup_r3
    send_header_record = record
      client_send_buffer_size: integer,
      client_send_data_size: integer,
      client_receive_buffer_size: integer,
      client_receive_data_size: integer,
      server_delay_count: integer,
      client_send_first_char: char,
      client_mainframe_id: pmt$mainframe_id,
    recend;

?? TITLE := '  NOS/VE File Server : Client: [XDCL, #GATE] dfp$client_test_app_support ', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$client_test_app_support
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ procedure client       (
{   family_name, family, fn,f: name = testing
{   send_size, ss: integer = 200
{   receive_size, rs: integer = 2000
{     use_data_area, uda, ud: key
{       send, s
{       receive, r
{       both, b
{       none, n
{     keyend = both
{   remote_procedure_name: program_name = dfp$server_test_app_support
{   application_name, an: name = doit_app
{   allowed_when_server_deactivated, awsd: boolean = false
{   compute_checksum, cc: boolean = true
{   repeat_count, rc: integer = 1
{   server_delay_count, sdc: integer = 0 "seconds"
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 23] of clt$pdt_parameter_name,
      parameters: array [1 .. 11] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type5: record
        header: clt$type_specification_header,
        default_value: string (27),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (8),
      recend,
      type7: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type8: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (11),
      recend,
      type11: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 13, 12, 7, 4, 968],
    clc$command, 23, 11, 0, 0, 0, 0, 11, ''], [
    ['ALLOWED_WHEN_SERVER_DEACTIVATED',clc$nominal_entry, 7],
    ['AN                             ',clc$abbreviation_entry, 6],
    ['APPLICATION_NAME               ',clc$nominal_entry, 6],
    ['AWSD                           ',clc$abbreviation_entry, 7],
    ['CC                             ',clc$abbreviation_entry, 8],
    ['COMPUTE_CHECKSUM               ',clc$nominal_entry, 8],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FAMILY                         ',clc$alias_entry, 1],
    ['FAMILY_NAME                    ',clc$nominal_entry, 1],
    ['FN                             ',clc$alias_entry, 1],
    ['RC                             ',clc$abbreviation_entry, 9],
    ['RECEIVE_SIZE                   ',clc$nominal_entry, 3],
    ['REMOTE_PROCEDURE_NAME          ',clc$nominal_entry, 5],
    ['REPEAT_COUNT                   ',clc$nominal_entry, 9],
    ['RS                             ',clc$abbreviation_entry, 3],
    ['SDC                            ',clc$abbreviation_entry, 10],
    ['SEND_SIZE                      ',clc$nominal_entry, 2],
    ['SERVER_DELAY_COUNT             ',clc$nominal_entry, 10],
    ['SS                             ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 11],
    ['UD                             ',clc$abbreviation_entry, 4],
    ['UDA                            ',clc$alias_entry, 4],
    ['USE_DATA_AREA                  ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 5
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 27],
{ PARAMETER 6
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 7
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 8
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 9
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 10
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 11],
{ PARAMETER 11
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'testing'],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10],
    '200'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10],
    '2000'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [8], [
    ['B                              ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['BOTH                           ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['N                              ', clc$nominal_entry, clc$normal_usage_entry, 8],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['R                              ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['RECEIVE                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['S                              ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['SEND                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'both'],
{ PARAMETER 5
    [[1, 0, clc$program_name_type],
    'dfp$server_test_app_support'],
{ PARAMETER 6
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'doit_app'],
{ PARAMETER 7
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 8
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 9
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10],
    '1'],
{ PARAMETER 10
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10],
    '0 "seconds"'],
{ PARAMETER 11
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$family_name = 1,
      p$send_size = 2,
      p$receive_size = 3,
      p$use_data_area = 4,
      p$remote_procedure_name = 5,
      p$application_name = 6,
      p$allowed_when_server_deactivat = 7 {ALLOWED_WHEN_SERVER_DEACTIVATED} ,
      p$compute_checksum = 8,
      p$repeat_count = 9,
      p$server_delay_count = 10,
      p$status = 11;

    VAR
      pvt: array [1 .. 11] of clt$parameter_value;

    VAR
      application: ost$name,
      family: ost$name,
      first_char: char,
      i: integer,
      line: string (200),
      line_size: integer,
      local_status: ost$status,
      proc_name: pmt$program_name,
      repeat_count: integer,
      send_size: dft$send_data_size,
      server_location: dft$server_location,
      receive_size: dft$send_data_size,
      p_data: ^SEQ ( * ),
      p_receive_buffer: ^SEQ ( * ),
      p_receive_data: ^SEQ ( * ),
      p_receive_string: ^string ( * ),
      p_send_buffer: ^SEQ ( * ),
      p_send_data: ^SEQ ( * ),
      p_send_header: ^send_header_record,
      p_send_string: ^string ( * ),
      receive_buffer_size: dft$send_parameter_size,
      receive_data_size: 0 .. dfc$maximum_user_data_area,
      returned_buffer_size: 0 .. dfc$maximum_user_buffer_area,
      returned_data_size: 0 .. dfc$maximum_user_data_area,
      send_buffer_size: dft$send_parameter_size,
      send_data_size: dft$send_data_size,
      ud: char;

    status.normal := TRUE;
    local_status.normal := TRUE;

    { Crack parameters.

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    family := pvt [p$family_name].value^.name_value;
    server_location.server_location_selector := dfc$family_name;
    server_location.family_name := family;

    send_size := pvt [p$send_size].value^.integer_value.value;
    receive_size := pvt [p$receive_size].value^.integer_value.value;
    ud := pvt [p$use_data_area].value^.keyword_value (1);
    proc_name := pvt [p$remote_procedure_name].value^.name_value;
    application := pvt [p$application_name].value^.name_value;
    repeat_count := pvt [p$repeat_count].value^.integer_value.value;
    first_char := $CHAR (((send_size + receive_size) MOD 10) + 1);
    p_data := NIL;
    p_send_data := NIL;

    CASE ud OF
    = 'S' =
      PUSH p_send_buffer: [[REP #SIZE (send_header_record) OF cell]];
      RESET p_send_buffer;
      NEXT p_send_header IN p_send_buffer;
      p_send_header^.client_send_buffer_size := #SIZE (send_header_record);
      p_send_header^.client_send_data_size := send_size;
      p_send_header^.client_receive_buffer_size := receive_size;
      p_send_header^.client_receive_data_size := 0;
      PUSH p_send_data: [[REP send_size OF cell]];
      RESET p_send_data;
      PUSH p_receive_buffer: [[REP receive_size OF cell]];
      RESET p_receive_buffer;
      p_receive_data := NIL;
    = 'R' =
      PUSH p_send_buffer: [[REP (#SIZE (send_header_record) + send_size) OF cell]];
      RESET p_send_buffer;
      NEXT p_send_header IN p_send_buffer;
      p_send_header^.client_send_buffer_size := #SIZE (send_header_record) + send_size;
      p_send_header^.client_send_data_size := 0;
      p_send_header^.client_receive_buffer_size := 0;
      p_send_header^.client_receive_data_size := receive_size;
      NEXT p_data: [[REP send_size OF cell]] IN p_send_buffer;
      RESET p_send_buffer;
      PUSH p_receive_data: [[REP receive_size OF cell]];
      RESET p_receive_data;
      p_receive_buffer := NIL;
    = 'B' =
      PUSH p_send_buffer: [[REP #SIZE (send_header_record) OF cell]];
      RESET p_send_buffer;
      NEXT p_send_header IN p_send_buffer;
      p_send_header^.client_send_buffer_size := #SIZE (send_header_record);
      p_send_header^.client_send_data_size := send_size;
      p_send_header^.client_receive_buffer_size := 0;
      p_send_header^.client_receive_data_size := receive_size;
      PUSH p_send_data: [[REP send_size OF cell]];
      RESET p_send_buffer;
      PUSH p_receive_data: [[REP receive_size OF cell]];
      p_receive_buffer := NIL;
    = 'N' =
      PUSH p_send_buffer: [[REP (#SIZE (send_header_record) + send_size) OF cell]];
      RESET p_send_buffer;
      NEXT p_send_header IN p_send_buffer;
      p_send_header^.client_send_buffer_size := #SIZE (send_header_record) + send_size;
      p_send_header^.client_send_data_size := 0;
      p_send_header^.client_receive_buffer_size := receive_size;
      p_send_header^.client_receive_data_size := 0;
      NEXT p_data: [[REP send_size OF cell]] IN p_send_buffer;
      RESET p_send_buffer;
      PUSH p_receive_buffer: [[REP receive_size OF cell]];
      p_receive_data := NIL;
    CASEND;

    p_send_header^.client_send_first_char := first_char;
    p_send_header^.server_delay_count := pvt [p$server_delay_count].value^.integer_value.value;
    pmp$get_mainframe_id (p_send_header^.client_mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Turn off range checking to allow nexting huge string
?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??
    IF p_send_data <> NIL THEN
      RESET p_send_data;
      NEXT p_send_string: [send_size] IN p_send_data;
    ELSEIF p_data <> NIL THEN
      RESET p_data;
      NEXT p_send_string: [send_size] IN p_data;
    IFEND;
    fill_test_data (p_send_string, send_size, first_char);
{ Turn on range checking
?? POP ??

    STRINGREP (line, line_size, ' Sending RPC request. APPL=', application, ' PROC=', proc_name);
    display (line (1, line_size));

    FOR i := 1 TO repeat_count DO
      dfp$call_remote_procedure (server_location, application, proc_name, p_send_buffer, p_send_data,
            returned_buffer_size, p_receive_buffer, returned_data_size, p_receive_data, status);
      IF NOT status.normal THEN
        display (' ABNORMAL STATUS FROM dfp$call_remote_procedure');
        display_status (status);
        RETURN;
      ELSE
        IF i = repeat_count THEN
          display (' NORMAL status from RPC call.');
        IFEND;
      IFEND;
      { Process receive buffer

{ Turn off range checking to allow nexting huge string
?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??
      IF p_receive_data <> NIL THEN
        NEXT p_receive_string: [receive_size] IN p_receive_data;
      ELSE
        NEXT p_receive_string: [receive_size] IN p_receive_buffer;
      IFEND;
      read_test_data (p_receive_string, receive_size, first_char, status);
{ Turn on range checking
?? POP ??
      IF NOT status.normal THEN
        display (' Client -  data mismatch');
        display_status (status);
      IFEND;

    FOREND;
  PROCEND dfp$client_test_app_support;
?? TITLE := 'dfp$scp1', EJECT ??

{ PURPOSE:
{   Provide a generic state_change_procedure

  PROCEDURE [XDCL, #GATE] dfp$scp1
    (    mainframe_id: pmt$mainframe_id;
         partner_is_server: boolean;
         old_state: dft$server_state;
         new_state: dft$server_state;
     VAR status: ost$status);

    VAR
      line: string (120),
      line_size: integer,
      new_name: string (10),
      old_name: string (10);

    status.normal := TRUE;
    STRINGREP (line, line_size, ' DFP$SCP1 called. Mainframe:', mainframe_id);
    display (line (1, line_size));

    CASE old_state OF
    = dfc$terminated =
      old_name := 'terminated';
    = dfc$active =
      old_name := 'active';
    = dfc$inactive =
      old_name := 'inactive';
    = dfc$deactivated =
      old_name := 'deactivate';
    = dfc$awaiting_recovery =
      old_name := 'await_recv';
    = dfc$recovering =
      old_name := 'recovering';
    ELSE
      old_name := '!!??!!??!!??';
    CASEND;

    CASE new_state OF
    = dfc$terminated =
      new_name := 'terminated';
    = dfc$active =
      new_name := 'active';
    = dfc$inactive =
      new_name := 'inactive';
    = dfc$deactivated =
      new_name := 'deactivate';
{ Perform shut-down activities .....
    = dfc$awaiting_recovery =
      new_name := 'await_recv';
    = dfc$recovering =
      new_name := 'recovering';
    ELSE
      new_name := '!!??!!??!!??';
    CASEND;

    STRINGREP (line, line_size, ' Old state: ', old_name, '  New state: ', new_name);
    display (line (1, line_size));


  PROCEND dfp$scp1;
?? TITLE := 'dfp$server_test_app_support', EJECT ??

{ PURPOSE:
{   The purpose of this request is to receive and process data from the client.
{   This procedure is a test remote application procedure.
{ NOTES:
{   1. It is assumed that the test is interested in transferring data either
{      via the parameter/buffer area or the "data" area - not both.

  PROCEDURE [XDCL, #GATE] dfp$server_test_app_support
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      client_receive_size: dft$send_data_size,
      client_send_size: dft$send_data_size,
      condition_for_state: pmt$condition,
      condition_for_break: pmt$condition,
      condition_for_pause: pmt$condition,
      handler_descriptor_for_state: pmt$established_handler,
      handler_descriptor_for_break: pmt$established_handler,
      handler_descriptor_for_pause: pmt$established_handler,
      i: integer,
      line: string (110),
      line_size: integer,
      p_in: ^SEQ ( * ),
      p_buffer_out: ^SEQ ( * ),
      p_data_out: ^SEQ ( * ),
      p_out: ^SEQ ( * ),
      p_receive_string: ^string ( * ),
      p_send_header: ^send_header_record,
      p_send_string: ^string ( * ),
      pause_break_received: boolean,
      server_state_change: boolean,
      server_state: dft$server_state,
      terminate_break_received: boolean;

?? NEWTITLE := 'handle_condition_for_state', EJECT ??

{ PURPOSE:
{   To process user condition

    PROCEDURE handle_condition_for_state
      (    condition_for_state: pmt$condition;
           condition_descriptor_for_state: ^pmt$condition_information;
           save_area_for_state: ^ost$stack_frame_save_area;
       VAR handler_status_for_state: ost$status);


      display (' dfp$server_test_app_support STATE handler entered');

      IF condition_for_state.selector = pmc$user_defined_condition THEN
        IF condition_for_state.user_condition_name = osc$server_state_change THEN
          display (' Server state change condition');
          server_state_change := TRUE;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status_for_state);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status_for_state);
      IFEND;
    PROCEND handle_condition_for_state;

?? OLDTITLE ??

?? NEWTITLE := 'handle_condition_for_break', EJECT ??

{ PURPOSE:
{   To process user condition: TERMINATE

    PROCEDURE handle_condition_for_break
      (    condition_for_break: pmt$condition;
           condition_descriptor_for_break: ^pmt$condition_information;
           save_area_for_break: ^ost$stack_frame_save_area;
       VAR handler_status_for_break: ost$status);


      display (' dfp$server_test_app_support BREAK handler entered');

      IF condition_for_break.selector = pmc$user_defined_condition THEN
        IF condition_for_break.user_condition_name = dfc$client_terminate_break THEN
          display (' Terminate Break received.');
          terminate_break_received := TRUE;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status_for_break);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status_for_break);
      IFEND;
    PROCEND handle_condition_for_break;

?? OLDTITLE ??

?? NEWTITLE := 'handle_condition_for_pause', EJECT ??

{ PURPOSE:
{   To process user condition: PAUSE

    PROCEDURE handle_condition_for_pause
      (    condition_for_pause: pmt$condition;
           condition_descriptor_for_pause: ^pmt$condition_information;
           save_area_for_pause: ^ost$stack_frame_save_area;
       VAR handler_status_for_pause: ost$status);


      display (' dfp$server_test_app_support PAUSE handler entered');

      IF condition_for_pause.selector = pmc$user_defined_condition THEN
        IF condition_for_pause.user_condition_name = dfc$client_pause_break THEN
          display (' Pause Break received.');
          pause_break_received := TRUE;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status_for_pause);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status_for_pause);
      IFEND;
    PROCEND handle_condition_for_pause;

?? OLDTITLE ??

    display (' Entering dfp$server_test_app_support');

    status.normal := TRUE;
    server_state_change := FALSE;
    pause_break_received := FALSE;
    terminate_break_received := FALSE;

    send_parameters_length := 0;
    data_size_to_send_to_client := 0;
    condition_for_state.selector := pmc$user_defined_condition;
    condition_for_state.user_condition_name := osc$server_state_change;
    display (' Establishing STATE condition handler for user_defined_condition');
    pmp$establish_condition_handler (condition_for_state, ^handle_condition_for_state,
          ^handler_descriptor_for_state, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    condition_for_break.selector := pmc$user_defined_condition;
    condition_for_break.user_condition_name := dfc$client_terminate_break;
    display (' Establishing BREAK condition handler for user_defined_condition');
    pmp$establish_condition_handler (condition_for_break, ^handle_condition_for_break,
          ^handler_descriptor_for_break, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    condition_for_pause.selector := pmc$user_defined_condition;
    condition_for_pause.user_condition_name := dfc$client_pause_break;
    display (' Establishing PAUSE condition handler for user_defined_condition');
    pmp$establish_condition_handler (condition_for_pause, ^handle_condition_for_pause,
          ^handler_descriptor_for_pause, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT p_send_header IN p_param_received_from_client;

    display_integer (' Client_send_buffer_size: ', p_send_header^.client_send_buffer_size);
    display_integer (' Client_send_data_size: ', p_send_header^.client_send_data_size);
    display_integer (' Client_receive_buffer_size: ', p_send_header^.client_receive_buffer_size);
    display_integer (' Client_receive_data_size: ', p_send_header^.client_receive_data_size);
    STRINGREP (line, line_size, ' Client_send_first_char: ', p_send_header^.client_send_first_char);
    display (line (1, line_size));
    display_integer (' Server_delay_count: ', p_send_header^.server_delay_count);

    IF p_send_header^.client_send_buffer_size > #SIZE (send_header_record) THEN
      NEXT p_in: [[REP (p_send_header^.client_send_buffer_size - #SIZE (send_header_record)) OF cell]] IN
            p_param_received_from_client;
      client_send_size := p_send_header^.client_send_buffer_size - #SIZE (send_header_record);
    IFEND;

    IF p_send_header^.client_send_data_size > 0 THEN
      NEXT p_in: [[REP p_send_header^.client_send_data_size OF cell]] IN p_data_from_client;
      client_send_size := p_send_header^.client_send_data_size;
    IFEND;
    RESET p_in;

{ Turn off range checking to allow nexting huge string
?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??
    NEXT p_receive_string: [client_send_size] IN p_in;
    read_test_data (p_receive_string, client_send_size, p_send_header^.client_send_first_char, status);
{ Turn on range checking
?? POP ??
    IF NOT status.normal THEN
      display (' Server -  data mismatch');
      display_status (status);
      osp$set_status_abnormal (dfc$file_server_id, dfe$test_checksum_error, 'DATA MISMATCH', status);
      RETURN;
    IFEND;

    IF p_send_header^.client_receive_buffer_size > 0 THEN
      NEXT p_out: [[REP p_send_header^.client_receive_buffer_size OF cell]] IN p_send_to_client_params;
      send_parameters_length := p_send_header^.client_receive_buffer_size;
      client_receive_size := send_parameters_length;
    IFEND;

    IF p_send_header^.client_receive_data_size > 0 THEN
      NEXT p_out: [[REP p_send_header^.client_receive_data_size OF cell]] IN p_data_to_client;
      data_size_to_send_to_client := p_send_header^.client_receive_data_size;
      client_receive_size := data_size_to_send_to_client;
    IFEND;
    RESET p_out;

{ Turn off range checking to allow nexting huge string
?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??
    NEXT p_send_string: [client_receive_size] IN p_out;
    fill_test_data (p_send_string, client_receive_size, p_send_header^.client_send_first_char);
{ Turn on range checking
?? POP ??

  /simulate_activity/
    FOR i := 1 TO p_send_header^.server_delay_count DO
      pmp$long_term_wait (1000, 1000);
      #SPOIL (server_state_change, terminate_break_received, pause_break_received);
      IF server_state_change THEN
        dfp$get_mainframe_status (p_send_header^.client_mainframe_id, {partner_is_server} FALSE, server_state,
              status);
        IF status.normal THEN
          IF server_state = dfc$deactivated THEN
            display (' Server detected DEACTIVATED state');
            { Perform shut-down activities}
          IFEND;
        IFEND;
        osp$set_status_abnormal ('DF', 333, ' Server state has changed', status);
        RETURN;
      ELSEIF terminate_break_received THEN
        osp$set_status_abnormal ('DF', 333, ' Terminate break received', status);
        RETURN;
      ELSEIF pause_break_received THEN
        osp$set_status_abnormal ('DF', 333, ' Pause break received', status);
        RETURN;
      IFEND;
    FOREND /simulate_activity/;

  PROCEND dfp$server_test_app_support;
?? TITLE := '  fill_test_data', EJECT ??

?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??

  PROCEDURE fill_test_data
    (    p_string: ^string ( * );
         char_count: integer;
         first_char: char);

    VAR
      count: integer,
      fill_char: char;

    fill_char := first_char;

  /fill_data/
    FOR count := 1 TO char_count DO
      p_string^ (count) := fill_char;
      IF $INTEGER (fill_char) < 255 THEN
        fill_char := $CHAR ($INTEGER (fill_char) + 1);
      ELSE
        fill_char := $CHAR (0);
      IFEND;
    FOREND /fill_data/;

  PROCEND fill_test_data;
?? POP ??
?? TITLE := '  read_test_data', EJECT ??
?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??

  PROCEDURE read_test_data
    (    p_string: ^string ( * );
         char_count: integer;
         first_char: char;
     VAR status: ost$status);

    VAR
      count: integer,
      fill_char: char;

    status.normal := TRUE;
    fill_char := first_char;

  /check_data/
    FOR count := 1 TO char_count DO
      IF p_string^ (count) <> fill_char THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$test_checksum_error, 'DATA MISMATCH', status);
        RETURN;
      IFEND;
      IF $INTEGER (fill_char) < 255 THEN
        fill_char := $CHAR ($INTEGER (fill_char) + 1);
      ELSE
        fill_char := $CHAR (0);
      IFEND;
    FOREND /check_data/;

  PROCEND read_test_data;
?? POP ??
MODEND dfm$test_application_support;
*DECK DECK=DFM$TEST_APP_SUP_R3 EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := ' NOS/VE File Server : Test Application Support - Ring 3', EJECT ??
MODULE dfm$test_app_sup_r3;

{ PURPOSE:
{   The purpose of this module is to provide a ring 3 procedure which uses the
{   application support interface dfp$send_remote_app. It is for local testing
{   called by (RAMBO5) and may not be transmitted.

?? NEWTITLE := ' Global Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dfi$display
*copyc dft$server_state
*copyc dft$rpc_parameters
*copyc pmt$mainframe_id
*copyc pmt$program_name
?? POP ??
*copyc clp$evaluate_parameters
*copyc dfp$send_application_rpc
*copyc dfp$verify_system_administrator
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pmp$get_mainframe_id

  TYPE
    { NOTE: This type is also defined/used in dfm$test_application_support.
    send_header_record = record
      client_send_buffer_size: integer,
      client_send_data_size: integer,
      client_receive_buffer_size: integer,
      client_receive_data_size: integer,
      server_delay_count: integer,
      client_send_first_char: char,
      client_mainframe_id: pmt$mainframe_id,
    recend;

?? TITLE := '  NOS/VE File Server : Client: [XDCL, #GATE] dfp$client_test_app_sup_r3 ', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$client_test_app_sup_r3
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{         procedure client       (
{          family_name, family, fn,f: name = testing
{          send_size, ss: integer = 200
{          receive_size, rs: integer = 2000
{          use_data_area, uda, ud: key
{              send, s
{              receive, r
{              both, b
{              none, n
{              keyend = both
{          remote_procedure_name: program_name = dfp$server_test_app_support
{          application_name, an: name = doit_app
{          allowed_when_server_deactivated, awsd: boolean = false
{          compute_checksum, cc: boolean = true
{          repeat_count, rc: integer = 1
{          server_delay_count, sdc: integer = 0 "seconds"
{          status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 23] of clt$pdt_parameter_name,
      parameters: array [1 .. 11] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type5: record
        header: clt$type_specification_header,
        default_value: string (27),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (8),
      recend,
      type7: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type8: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (11),
      recend,
      type11: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 5, 15, 10, 50, 853],
    clc$command, 23, 11, 0, 0, 0, 0, 11, ''], [
    ['ALLOWED_WHEN_SERVER_DEACTIVATED',clc$nominal_entry, 7],
    ['AN                             ',clc$abbreviation_entry, 6],
    ['APPLICATION_NAME               ',clc$nominal_entry, 6],
    ['AWSD                           ',clc$abbreviation_entry, 7],
    ['CC                             ',clc$abbreviation_entry, 8],
    ['COMPUTE_CHECKSUM               ',clc$nominal_entry, 8],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FAMILY                         ',clc$alias_entry, 1],
    ['FAMILY_NAME                    ',clc$nominal_entry, 1],
    ['FN                             ',clc$alias_entry, 1],
    ['RC                             ',clc$abbreviation_entry, 9],
    ['RECEIVE_SIZE                   ',clc$nominal_entry, 3],
    ['REMOTE_PROCEDURE_NAME          ',clc$nominal_entry, 5],
    ['REPEAT_COUNT                   ',clc$nominal_entry, 9],
    ['RS                             ',clc$abbreviation_entry, 3],
    ['SDC                            ',clc$abbreviation_entry, 10],
    ['SEND_SIZE                      ',clc$nominal_entry, 2],
    ['SERVER_DELAY_COUNT             ',clc$nominal_entry, 10],
    ['SS                             ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 11],
    ['UD                             ',clc$abbreviation_entry, 4],
    ['UDA                            ',clc$alias_entry, 4],
    ['USE_DATA_AREA                  ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 5
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 27],
{ PARAMETER 6
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 7
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 8
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 9
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 10
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 11],
{ PARAMETER 11
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'testing'],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10],
    '200'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10],
    '2000'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [8], [
    ['B                              ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['BOTH                           ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['N                              ', clc$nominal_entry, clc$normal_usage_entry, 8],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['R                              ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['RECEIVE                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['S                              ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['SEND                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'both'],
{ PARAMETER 5
    [[1, 0, clc$program_name_type],
    'dfp$server_test_app_support'],
{ PARAMETER 6
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    'doit_app'],
{ PARAMETER 7
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 8
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 9
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10],
    '1'],
{ PARAMETER 10
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10],
    '0 "seconds"'],
{ PARAMETER 11
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$family_name = 1,
      p$send_size = 2,
      p$receive_size = 3,
      p$use_data_area = 4,
      p$remote_procedure_name = 5,
      p$application_name = 6,
      p$allowed_when_server_deactivat = 7 {ALLOWED_WHEN_SERVER_DEACTIVATED} ,
      p$compute_checksum = 8,
      p$repeat_count = 9,
      p$server_delay_count = 10,
      p$status = 11;

    VAR
      pvt: array [1 .. 11] of clt$parameter_value;

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT dfp$client_test_app_sup_r3;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      application: ost$name,
      allowed_when_server_deactivated: boolean,
      compute_checksum: boolean,
      family: ost$name,
      first_char: char,
      i: integer,
      line: string (200),
      line_size: integer,
      local_status: ost$status,
      proc_name: pmt$program_name,
      repeat_count: integer,
      send_size: dft$send_data_size,
      server_location: dft$server_location,
      receive_size: dft$send_data_size,
      p_data: ^SEQ ( * ),
      p_receive_buffer: ^SEQ ( * ),
      p_receive_data: ^SEQ ( * ),
      p_receive_string: ^string ( * ),
      p_send_buffer: dft$p_send_parameters,
      p_send_data: dft$p_send_data,
      p_send_header: ^send_header_record,
      p_send_string: ^string ( * ),
      queue_entry_location: dft$rpc_queue_entry_location,
      receive_buffer_size: dft$send_parameter_size,
      receive_data_size: 0 .. dfc$maximum_user_data_area,
      returned_buffer_size: 0 .. dfc$maximum_user_buffer_area,
      returned_data_size: 0 .. dfc$maximum_user_data_area,
      send_buffer_size: dft$send_parameter_size,
      send_data_size: dft$send_data_size,
      ud: char;

    status.normal := TRUE;
    local_status.normal := TRUE;

    dfp$verify_system_administrator ('DFP$CLIENT_TEST_APP_SUP_R3', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Crack parameters.

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    family := pvt [p$family_name].value^.name_value;
    allowed_when_server_deactivated := pvt [p$allowed_when_server_deactivat].value^.
          boolean_value.value;
    compute_checksum := pvt [p$compute_checksum].value^.boolean_value.value;
    server_location.server_location_selector := dfc$family_name;
    server_location.family_name := family;

    send_size := pvt [p$send_size].value^.integer_value.value;
    receive_size := pvt [p$receive_size].value^.integer_value.value;
    ud := pvt [p$use_data_area].value^.keyword_value (1);
    proc_name := pvt [p$remote_procedure_name].value^.name_value;
    application := pvt [p$application_name].value^.name_value;
    repeat_count := pvt [p$repeat_count].value^.integer_value.value;
    first_char := $CHAR (((send_size + receive_size) MOD 10) + 1);
    p_data := NIL;
    p_send_data := NIL;

    dfp$begin_ch_remote_proc_call (server_location, allowed_when_server_deactivated, queue_entry_location,
          p_send_buffer, p_send_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

   /begin_remote_proc_call/
    BEGIN

      NEXT p_send_header IN p_send_buffer;

    CASE ud OF
    = 'S' =
      p_send_header^.client_send_buffer_size := #SIZE (send_header_record);
      p_send_header^.client_send_data_size := send_size;
      p_send_header^.client_receive_buffer_size := receive_size;
      p_send_header^.client_receive_data_size := 0;
    = 'R' =
      p_send_header^.client_send_buffer_size := #SIZE (send_header_record) + send_size;
      p_send_header^.client_send_data_size := 0;
      p_send_header^.client_receive_buffer_size := 0;
      p_send_header^.client_receive_data_size := receive_size;
      NEXT p_data: [[REP send_size OF cell]] IN p_send_buffer;
    = 'B' =
      p_send_header^.client_send_buffer_size := #SIZE (send_header_record);
      p_send_header^.client_send_data_size := send_size;
      p_send_header^.client_receive_buffer_size := 0;
      p_send_header^.client_receive_data_size := receive_size;

    = 'N' =
      p_send_header^.client_send_buffer_size := #SIZE (send_header_record) + send_size;
      p_send_header^.client_send_data_size := 0;
      p_send_header^.client_receive_buffer_size := receive_size;
      p_send_header^.client_receive_data_size := 0;
      NEXT p_data: [[REP send_size OF cell]] IN p_send_buffer;
    ELSE
      display (' OPTION of use_data_area not implemented');
      EXIT /begin_remote_proc_call/;
    CASEND;

    p_send_header^.client_send_first_char := first_char;
    p_send_header^.server_delay_count := pvt [p$server_delay_count].value^.integer_value.
         value;
    pmp$get_mainframe_id (p_send_header^.client_mainframe_id, status);
    IF NOT status.normal THEN
      EXIT /begin_remote_proc_call/;
    IFEND;

{ Turn off range checking to allow nexting huge string
?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??
    IF p_send_data <> NIL THEN
      RESET p_send_data;
      NEXT p_send_string: [send_size] IN p_send_data;
    ELSEIF p_data <> NIL THEN
      RESET p_data;
      NEXT p_send_string: [send_size] IN p_data;
    IFEND;
    fill_test_data (p_send_string, send_size, first_char);
{ Turn on range checking
?? POP ??

    send_buffer_size := p_send_header^.client_send_buffer_size;
    send_data_size :=  p_send_header^.client_send_data_size;

    STRINGREP (line, line_size, ' Sending RPC request. APPL=', application, ' PROC=', proc_name);
    display (line (1, line_size));
/doit/
    FOR i := 1 TO repeat_count DO

      dfp$send_application_rpc (queue_entry_location, application, proc_name,
            send_buffer_size, send_data_size, p_receive_buffer, p_receive_data, status);

      IF NOT status.normal THEN
        display (' ABNORMAL STATUS FROM dfp$send_application_rpc');
        display_status (status);
        exit /doit/;
      ELSE
        IF i = repeat_count THEN
          display (' NORMAL status from RPC call.');
        IFEND;
      IFEND;
      { Process receive buffer

{ Turn off range checking to allow nexting huge string
?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??
      IF p_receive_data <> NIL THEN
        NEXT p_receive_string: [receive_size] IN p_receive_data;
      ELSE
        NEXT p_receive_string: [receive_size] IN p_receive_buffer;
      IFEND;
      read_test_data (p_receive_string, receive_size, first_char, status);
{ Turn on range checking
?? POP ??
      IF NOT status.normal THEN
        display (' Client -  data mismatch');
        display_status (status);
        EXIT /begin_remote_proc_call/;
      IFEND;

    FOREND /doit/;

    END /begin_remote_proc_call/;

    dfp$end_ch_remote_proc_call (queue_entry_location, local_status);

  PROCEND dfp$client_test_app_sup_r3;
?? TITLE := '  fill_test_data', EJECT ??

?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??

  PROCEDURE fill_test_data
    (    p_string: ^string ( * );
         char_count: integer;
         first_char: char);

    VAR
      count: integer,
      fill_char: char;

    fill_char := first_char;

  /fill_data/
    FOR count := 1 TO char_count DO
      p_string^ (count) := fill_char;
      IF $INTEGER (fill_char) < 255 THEN
        fill_char := $CHAR ($INTEGER (fill_char) + 1);
      ELSE
        fill_char := $CHAR (0);
      IFEND;
    FOREND /fill_data/;

  PROCEND fill_test_data;
?? POP ??
?? TITLE := '  read_test_data', EJECT ??
?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??

  PROCEDURE read_test_data
    (    p_string: ^string ( * );
         char_count: integer;
         first_char: char;
     VAR status: ost$status);

    VAR
      count: integer,
      fill_char: char;

    status.normal := TRUE;
    fill_char := first_char;

  /check_data/
    FOR count := 1 TO char_count DO
      IF p_string^ (count) <> fill_char THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$test_checksum_error, 'DATA MISMATCH', status);
        RETURN;
      IFEND;
      IF $INTEGER (fill_char) < 255 THEN
        fill_char := $CHAR ($INTEGER (fill_char) + 1);
      ELSE
        fill_char := $CHAR (0);
      IFEND;
    FOREND /check_data/;

  PROCEND read_test_data;
?? POP ??
MODEND dfm$test_app_sup_r3;



*DECK DECK=DFM$TEST_JOB_RECOVERY EXPAND=TRUE
?? RIGHT := 110 ??
MODULE dfm$test_job_recovery;

{
{   This module provides a simple job recovery test mechanism.
{

?? PUSH (LISTEXT := ON) ??
*copyc amp$get_segment_pointer
*copyc clp$evaluate_parameters
*copyc clt$parameter_list
*copyc dfi$display
*copyc dfe$error_condition_codes
*copyc fsp$open_file
*copyc i#program_error
*copyc pmp$wait
*copyc amp$open
*copyc osp$set_status_abnormal
?? POP ??

  CONST
    page_size_in_words = 4096 DIV 8;

?? TITLE := ' [XDCL, #GATE] dfp$test_job_recovery', EJECT ??

{  This is just a simple test of reading and writing a file.
{  The file may be specified as the output parameter.
{  The file is attached for exclusive access.

  PROCEDURE [XDCL, #GATE] dfp$test_job_recovery
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);



{  PROCEDURE test_job_recovery, tesjr  (
{    output, o: file = $user.dff$test_job_recovery.$next
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (33),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 26, 14, 59, 55, 313],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 33],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$user.dff$test_job_recovery.$next'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    CONST
      max_page_count = 50;

    VAR
      address: ^cell,
      file_content_array: ^array [1 .. 100000000] of integer,
      file_id: amt$file_identifier,
      message: string (110),
      message_length: integer,
      page_count: integer,
      pass: integer,
      segment_pointer: amt$segment_pointer,
      word_count: integer,
      word_value: integer;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$open_file (pvt [p$output].value^.file_value^, amc$segment, NIL, NIL, NIL, NIL, NIL, file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_id, amc$cell_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    file_content_array := segment_pointer.cell_pointer;

    pass := 0;
    word_value := 1;

  /forever/
    WHILE TRUE DO
      word_value := word_value + 1;
      pass := pass + 1;

    /write_all_pages/
      FOR page_count := 1 TO max_page_count DO

      /write_all_words_in_page/
        FOR word_count := 1 TO page_size_in_words DO
          file_content_array^ [((page_count - 1) * page_size_in_words) + word_count] := word_value;
        FOREND /write_all_words_in_page/;
      FOREND /write_all_pages/;

    /verify_all_pages/
      FOR page_count := 1 TO max_page_count DO

      /verify_all_words_in_page/
        FOR word_count := 1 TO page_size_in_words DO
          IF file_content_array^ [((page_count - 1) * page_size_in_words) + word_count] <> word_value THEN
            address := ^file_content_array^ [((page_count - 1) * page_size_in_words) + word_count];
            STRINGREP (message, message_length, ' Perm file test failure  - Page ', page_count, ' Word ',
                  word_count, 'address ', address,  ' Expected ', word_value, ' Actual ',
                  file_content_array^ [((page_count - 1) * page_size_in_words) + word_count], ' Pass ', pass);
            display (message (1, message_length));
            i#program_error;
            osp$set_status_abnormal (dfc$file_server_id, dfe$test_checksum_error, message (1, message_length),
                  status);
            RETURN;
          IFEND;
        FOREND /verify_all_words_in_page/;
      FOREND /verify_all_pages/;

    WHILEND /forever/;
  PROCEND dfp$test_job_recovery;
?? TITLE := ' [XDCL, #GATE] dfp$test_file_sharing', EJECT ??

{  This procedure provides a more complicated test of writing a permanent
{    file. A file is written and the read to verify its contents.
{  local_file_name:  This parameter specifies the file that is to be written.
{     This parameter may be used in conjunction with a previuous attach_file
{     or create_file paramter.  Note - amp$open is used so that the
{     job uses the access and share modes specified on an attach_file done
{     outside of this test.
{  offset_word_range:  This parameter determines what words of the file
{     the task is to write into. For example if offset_word_range=1 then
{     the task writes into the 1,9,17,... words.
{     If offset_word_range=1..4 then the tasks writes into the
{     1..4,9..12,17..20 words of the file.
{     This parameter is provided as a means of allowing multiple jobs to
{     write on the same file.
{ total_minutes:  This parameter determines how long the test will run for.
{ wait_millisecond:  This parameter determines how long the test will wait
{     between passes through the file.
{ page_count: This parameter indicates how big the file should be.

  PROCEDURE [XDCL, #GATE] dfp$test_file_sharing
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE test_file_sharing, tesfs  (
{   local_file_name, lfn: name = $required
{   offset_word_range, owr: range of  integer 1 .. 8  = 1.. 8
{   total_minutes, tm: integer 1 .. 1000 = 120
{   wait_milliseconds, wm: integer = 0
{   page_count, pc: integer 1 .. 1000000 = 50
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$range_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (5),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (2),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 1, 24, 13, 43, 23, 225],
    clc$command, 11, 6, 1, 0, 0, 0, 6, ''], [
    ['LFN                            ',clc$abbreviation_entry, 1],
    ['LOCAL_FILE_NAME                ',clc$nominal_entry, 1],
    ['OFFSET_WORD_RANGE              ',clc$nominal_entry, 2],
    ['OWR                            ',clc$abbreviation_entry, 2],
    ['PAGE_COUNT                     ',clc$nominal_entry, 5],
    ['PC                             ',clc$abbreviation_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 6],
    ['TM                             ',clc$abbreviation_entry, 3],
    ['TOTAL_MINUTES                  ',clc$nominal_entry, 3],
    ['WAIT_MILLISECONDS              ',clc$nominal_entry, 4],
    ['WM                             ',clc$abbreviation_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally]
,
    clc$pass_by_value, clc$immediate_evaluation,
clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally]
,
    clc$pass_by_value, clc$immediate_evaluation,
clc$standard_parameter_checking, 27,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally]
,
    clc$pass_by_value, clc$immediate_evaluation,
clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally]
,
    clc$pass_by_value, clc$immediate_evaluation,
clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally]
,
    clc$pass_by_value, clc$immediate_evaluation,
clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 6
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$range_type], [20],
      [[1, 0, clc$integer_type], [1, 8, 10]]
    ,
    '1.. 8'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, 1000, 10],
    '120'],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10],
    '0'],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [1, 1000000, 10],
    '50'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$local_file_name = 1,
      p$offset_word_range = 2,
      p$total_minutes = 3,
      p$wait_milliseconds = 4,
      p$page_count = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      address: ^cell,
      end_time: integer,
      file_content_array: ^array [1 .. 100000000] of integer,
      file_id: amt$file_identifier,
      high: integer,
      low: integer,
      max_page_count: integer,
      message: string (110),
      message_length: integer,
      page_count: integer,
      pass: integer,
      segment_pointer: amt$segment_pointer,
      time: integer,
      wait: integer,
      word_count: integer,
      word_value: integer;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (pvt [p$local_file_name].value^.name_value, amc$segment, NIL, file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_id, amc$cell_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    file_content_array := segment_pointer.cell_pointer;

    low := pvt [p$offset_word_range].value^.low_value^.integer_value.value;
    high := pvt [p$offset_word_range].value^.high_value^.integer_value.value;
    wait := pvt [p$wait_milliseconds].value^.integer_value.value;
    max_page_count := pvt [p$page_count].value^.integer_value.value;
    end_time := #FREE_RUNNING_CLOCK (0) + ({Minutes} pvt [p$total_minutes].value^.integer_value.value *
          {secs_per_min} 60 * {Microsends per second } 1000000);

    pass := 0;
    word_value := 1;
    time := #FREE_RUNNING_CLOCK (0);

  /till_end_time/
    WHILE (time < end_time) DO
      word_value := word_value + 1;
      pass := pass + 1;

    /write_all_pages/
      FOR page_count := 1 TO max_page_count DO

      /write_all_words_in_page/
        FOR word_count := 1 TO page_size_in_words DO
          IF ((((word_count MOD 8) >= low) AND ((word_count MOD 8) <= high))) OR
                (((word_count MOD 8) = 0) AND (high = 8)) THEN
            file_content_array^ [((page_count - 1) * page_size_in_words) + word_count] := word_value;
          IFEND;
        FOREND /write_all_words_in_page/;
      FOREND /write_all_pages/;

    /verify_all_pages/
      FOR page_count := 1 TO max_page_count DO

      /verify_all_words_in_page/
        FOR word_count := 1 TO page_size_in_words DO
          IF ((((word_count MOD 8) >= low) AND ((word_count MOD 8) <= high))) OR
                (((word_count MOD 8) = 0) AND (high = 8)) THEN
            IF file_content_array^ [((page_count - 1) * page_size_in_words) + word_count] <> word_value THEN
              address := ^file_content_array^ [((page_count - 1) * page_size_in_words) + word_count];
              STRINGREP (message, message_length, ' Perm file test failure  - Page ', page_count, ' Word ',
                    word_count, 'Address ', address,' Expected ', word_value, ' Actual ',
                    file_content_array^ [((page_count - 1) * page_size_in_words) + word_count], ' Pass ',
                    pass);
              display (message (1, message_length));
              i#program_error;
              osp$set_status_abnormal (dfc$file_server_id, dfe$test_checksum_error,
                    message (1, message_length), status);
              RETURN;
            IFEND;
          IFEND;
        FOREND /verify_all_words_in_page/;
      FOREND /verify_all_pages/;

      pmp$wait (wait, wait);
      time := #FREE_RUNNING_CLOCK (0);
    WHILEND /till_end_time/;
  PROCEND dfp$test_file_sharing;
?? TITLE := ' [XDCL, #GATE] dfp$test_file_reading', EJECT ??

{  This procedure reads a file written by dfp$test_file_sharing
{  For now no verification of what is being read is made.
{  Note for future enhancement:
{     How would the writing and reading jobs communicate?
{  local_file_name:  This parameter specifies the file that is to be read.
{     This parameter may be used in conjunction with a previuous attach_file
{     or create_file paramter.  Note - amp$open is used so that the
{     job uses the access and share modes specified on the attach_file.
{  offset_word_range:  This parameter determines what words of the file
{     the task is to read from. For example if offset_word_range=1 then
{     the task reads from the 1,9,17,... words.
{     If offset_word_range=1..4 then the tasks reads from into the
{     1..4,9..12,17..20 words of the file.
{ total_minutes:  This parameter determines how long the test will run for.
{ wait_millisecond:  This parameter determines how long the test will wait
{     between passes through the file.
{ page_count: This parameter indicates how big the file should be.

  PROCEDURE [XDCL, #GATE] dfp$test_file_reading
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE test_file_reading, tesfs  (
{   local_file_name, lfn: name = $required
{   offset_word_range, owr: range of  integer 1 .. 8  = 1.. 8
{   total_minutes, tm: integer 1 .. 1000 = 120
{   wait_milliseconds, wm: integer = 0
{   page_count, pc: integer 1 .. 1000000 = 50
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$range_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (5),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (2),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 1, 24, 13, 43, 23, 225],
    clc$command, 11, 6, 1, 0, 0, 0, 6, ''], [
    ['LFN                            ',clc$abbreviation_entry, 1],
    ['LOCAL_FILE_NAME                ',clc$nominal_entry, 1],
    ['OFFSET_WORD_RANGE              ',clc$nominal_entry, 2],
    ['OWR                            ',clc$abbreviation_entry, 2],
    ['PAGE_COUNT                     ',clc$nominal_entry, 5],
    ['PC                             ',clc$abbreviation_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 6],
    ['TM                             ',clc$abbreviation_entry, 3],
    ['TOTAL_MINUTES                  ',clc$nominal_entry, 3],
    ['WAIT_MILLISECONDS              ',clc$nominal_entry, 4],
    ['WM                             ',clc$abbreviation_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally]
,
    clc$pass_by_value, clc$immediate_evaluation,
clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally]
,
    clc$pass_by_value, clc$immediate_evaluation,
clc$standard_parameter_checking, 27,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally]
,
    clc$pass_by_value, clc$immediate_evaluation,
clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally]
,
    clc$pass_by_value, clc$immediate_evaluation,
clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally]
,
    clc$pass_by_value, clc$immediate_evaluation,
clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 6
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$range_type], [20],
      [[1, 0, clc$integer_type], [1, 8, 10]]
    ,
    '1.. 8'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, 1000, 10],
    '120'],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10],
    '0'],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [1, 1000000, 10],
    '50'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$local_file_name = 1,
      p$offset_word_range = 2,
      p$total_minutes = 3,
      p$wait_milliseconds = 4,
      p$page_count = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      end_time: integer,
      file_content_array: ^array [1 .. 100000000] of integer,
      file_id: amt$file_identifier,
      high: integer,
      low: integer,
      max_page_count: integer,
      page_count: integer,
      segment_pointer: amt$segment_pointer,
      time: integer,
      wait: integer,
      word_count: integer,
      word_value: integer;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (pvt [p$local_file_name].value^.name_value, amc$segment, NIL, file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_id, amc$cell_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    file_content_array := segment_pointer.cell_pointer;

    low := pvt [p$offset_word_range].value^.low_value^.integer_value.value;
    high := pvt [p$offset_word_range].value^.high_value^.integer_value.value;
    wait := pvt [p$wait_milliseconds].value^.integer_value.value;
    max_page_count := pvt [p$page_count].value^.integer_value.value;
    end_time := #FREE_RUNNING_CLOCK (0) + ({Minutes} pvt [p$total_minutes].value^.integer_value.value *
          {secs_per_min} 60 * {Microsends per second } 1000000);

    time := #FREE_RUNNING_CLOCK (0);

  /till_end_time/
    WHILE (time < end_time) DO

    /read_all_pages/
      FOR page_count := 1 TO max_page_count DO

      /read_all_words_in_page/
        FOR word_count := 1 TO page_size_in_words DO
          IF ((((word_count MOD 8) >= low) AND ((word_count MOD 8) <= high))) OR
                (((word_count MOD 8) = 0) AND (high = 8)) THEN
            word_value := file_content_array^ [((page_count - 1) * page_size_in_words) + word_count];
          IFEND;
        FOREND /read_all_words_in_page/;
      FOREND /read_all_pages/;

      pmp$wait (wait, wait);
      time := #FREE_RUNNING_CLOCK (0);
    WHILEND /till_end_time/;
  PROCEND dfp$test_file_reading;
MODEND dfm$test_job_recovery;
*DECK DECK=DFM$TEST_REMOTE_PROCEDURE_CALL EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server : Test Remote Procedure Call ', EJECT ??
MODULE dfm$test_remote_procedure_call;

{
{  Purpose:  This module contains code used to test the remote procedure call
{            interfaces.  The command test_remote_procedure_call is provided
{            to allow testing all remote procedure call options.

?? NEWTITLE := ' Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$get_value
*copyc clp$scan_command_line
*copyc clp$scan_parameter_list
*copyc dfd$driver_queue_types
*copyc dfd$request_package
*copyc dfe$error_condition_codes
*copyc dfi$display
*copyc dfp$delete_client_rpc_segment
*copyc dfp$receive_server_rpc_segment
*copyc dfp$reserve_server_rpc_segment
*copyc dfp$compute_checksum
*copyc dfp$crack_mainframe_id
*copyc dfp$get_test_queue_location
*copyc dfp$page_count
*copyc dfp$receive_client_rpc_segment
*copyc dfp$send_client_rpc_segment
*copyc dfp$send_remote_procedure_call
*copyc dfp$touch_pages
*copyc dft$procedure_address_ordinal
*copyc dft$rpc_buffer_header
*copyc dft$rpc_parameters
*copyc dpp$put_next_line
*copyc dpv$system_core_display
*copyc i#build_adaptable_seq_pointer
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc mmv$max_segment_length
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc osp$system_error
*copyc pmp$get_mainframe_id
*copyc pmp$log_ascii
*copyc pmp$zero_out_table
?? POP ??
*copyc dft$rpc_test_request_header

?? TITLE := '  Client: [XDCL] dfp$test_remote_procedure_call ', EJECT ??

  PROCEDURE [XDCL] dfp$test_remote_procedure_call
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt test_remote_rpc_call_pdt       (
{ queue_identifier, qid: name  = current
{ send_buffer_size, sbs: integer 0 .. dfc$maximum_test_request_buffer = 333
{ send_data_size, sds: integer 0 .. dfc$maximum_user_data_area = 0
{ receive_buffer_size, rbs: integer 0 .. dfc$maximum_test_request_buffer = 77
{ receive_data_size, rds: integer 0 .. dfc$maximum_user_data_area = 0
{ receive_segment_size, rss: integer 0 .. osc$max_segment_length = 0
{ receive_segment_offset, rso: integer 0 .. osc$max_segment_length = 0
{ send_segment_size, sss: integer 0 .. osc$max_segment_length = 0
{ send_segment_offset, sso: integer 0 .. osc$max_segment_length = 0
{ request_restartable, rr: boolean = true
{ allowed_when_server_deactivated, awsd: boolean = false
{ compute_checksum, cc: boolean = true
{ repeat_count, rc: integer 1 .. 10000000 = 1
{ status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    test_remote_rpc_call_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
  ^test_remote_rpc_call_pdt_names, ^test_remote_rpc_call_pdt_params];

  VAR
    test_remote_rpc_call_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 27] of
  clt$parameter_name_descriptor := [['QUEUE_IDENTIFIER', 1], ['QID', 1], ['SEND_BUFFER_SIZE', 2], ['SBS', 2],
  ['SEND_DATA_SIZE', 3], ['SDS', 3], ['RECEIVE_BUFFER_SIZE', 4], ['RBS', 4], ['RECEIVE_DATA_SIZE', 5], ['RDS'
  , 5], ['RECEIVE_SEGMENT_SIZE', 6], ['RSS', 6], ['RECEIVE_SEGMENT_OFFSET', 7], ['RSO', 7], [
  'SEND_SEGMENT_SIZE', 8], ['SSS', 8], ['SEND_SEGMENT_OFFSET', 9], ['SSO', 9], ['REQUEST_RESTARTABLE', 10], [
  'RR', 10], ['ALLOWED_WHEN_SERVER_DEACTIVATED', 11], ['AWSD', 11], ['COMPUTE_CHECKSUM', 12], ['CC', 12], [
  'REPEAT_COUNT', 13], ['RC', 13], ['STATUS', 14]];

  VAR
    test_remote_rpc_call_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 14] of
  clt$parameter_descriptor := [

{ QUEUE_IDENTIFIER QID }
    [[clc$optional_with_default, ^test_remote_rpc_call_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
  [NIL, clc$name_value, 1, osc$max_name_size]],

{ SEND_BUFFER_SIZE SBS }
    [[clc$optional_with_default, ^test_remote_rpc_call_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
  [NIL, clc$integer_value, 0, dfc$maximum_test_request_buffer]],

{ SEND_DATA_SIZE SDS }
    [[clc$optional_with_default, ^test_remote_rpc_call_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed,
  [NIL, clc$integer_value, 0, dfc$maximum_user_data_area]],

{ RECEIVE_BUFFER_SIZE RBS }
    [[clc$optional_with_default, ^test_remote_rpc_call_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed,
  [NIL, clc$integer_value, 0, dfc$maximum_test_request_buffer]],

{ RECEIVE_DATA_SIZE RDS }
    [[clc$optional_with_default, ^test_remote_rpc_call_pdt_dv5], 1, 1, 1, 1, clc$value_range_not_allowed,
  [NIL, clc$integer_value, 0, dfc$maximum_user_data_area]],

{ RECEIVE_SEGMENT_SIZE RSS }
    [[clc$optional_with_default, ^test_remote_rpc_call_pdt_dv6], 1, 1, 1, 1, clc$value_range_not_allowed,
  [NIL, clc$integer_value, 0, osc$max_segment_length]],

{ RECEIVE_SEGMENT_OFFSET RSO }
    [[clc$optional_with_default, ^test_remote_rpc_call_pdt_dv7], 1, 1, 1, 1, clc$value_range_not_allowed,
  [NIL, clc$integer_value, 0, osc$max_segment_length]],

{ SEND_SEGMENT_SIZE SSS }
    [[clc$optional_with_default, ^test_remote_rpc_call_pdt_dv8], 1, 1, 1, 1, clc$value_range_not_allowed,
  [NIL, clc$integer_value, 0, osc$max_segment_length]],

{ SEND_SEGMENT_OFFSET SSO }
    [[clc$optional_with_default, ^test_remote_rpc_call_pdt_dv9], 1, 1, 1, 1, clc$value_range_not_allowed,
  [NIL, clc$integer_value, 0, osc$max_segment_length]],

{ REQUEST_RESTARTABLE RR }
    [[clc$optional_with_default, ^test_remote_rpc_call_pdt_dv10], 1, 1, 1, 1, clc$value_range_not_allowed,
  [NIL, clc$boolean_value]],

{ ALLOWED_WHEN_SERVER_DEACTIVATED AWSD }
    [[clc$optional_with_default, ^test_remote_rpc_call_pdt_dv11], 1, 1, 1, 1, clc$value_range_not_allowed,
  [NIL, clc$boolean_value]],

{ COMPUTE_CHECKSUM CC }
    [[clc$optional_with_default, ^test_remote_rpc_call_pdt_dv12], 1, 1, 1, 1, clc$value_range_not_allowed,
  [NIL, clc$boolean_value]],

{ REPEAT_COUNT RC }
    [[clc$optional_with_default, ^test_remote_rpc_call_pdt_dv13], 1, 1, 1, 1, clc$value_range_not_allowed,
  [NIL, clc$integer_value, 1, 10000000]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    test_remote_rpc_call_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := 'current';

  VAR
    test_remote_rpc_call_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := '333';

  VAR
    test_remote_rpc_call_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    test_remote_rpc_call_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := '77';

  VAR
    test_remote_rpc_call_pdt_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    test_remote_rpc_call_pdt_dv6: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    test_remote_rpc_call_pdt_dv7: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    test_remote_rpc_call_pdt_dv8: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    test_remote_rpc_call_pdt_dv9: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    test_remote_rpc_call_pdt_dv10: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

  VAR
    test_remote_rpc_call_pdt_dv11: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';

  VAR
    test_remote_rpc_call_pdt_dv12: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

  VAR
    test_remote_rpc_call_pdt_dv13: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '1';

?? FMT (FORMAT := ON) ??
?? POP ??

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT dfp$test_remote_procedure_call;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      allowed_when_server_deactivated: boolean,
      begin_time: integer,
      checksum: integer,
      compute_checksum: boolean,
      end_time: integer,
      first_char: char,
      local_status: ost$status,
      p_queue_interface_table: ^dft$queue_interface_table,
      p_receive_buffer: dft$p_receive_parameters,
      p_receive_data: dft$p_receive_data,
      p_receive_string: ^string ( * ),
      p_send_buffer: dft$p_send_parameters,
      p_send_data: dft$p_send_data,
      p_send_string: ^string ( * ),
      p_test_request_header: ^dft$rpc_test_request_header,
      page_count: ost$non_negative_integers,
      p_receive_segment: ^SEQ ( * ),
      p_send_segment: ^SEQ ( * ),
      procedure_ordinal: dft$procedure_address_ordinal,
      queue_entry_location: dft$rpc_queue_entry_location,
      queue_index: dft$queue_index,
      receive_buffer_size: dft$send_parameter_size,
      receive_data_size: dft$send_data_size,
      receive_segment_size: ost$segment_length,
      receive_segment_offset: ost$segment_length,
      repeat_count: integer,
      request_restartable: boolean,
      segment_pointer: amt$segment_pointer,
      send_buffer_size: dft$send_parameter_size,
      send_count: integer,
      send_data_size: dft$send_data_size,
      send_end_time: integer,
      send_segment_checksum: integer,
      send_segment_size: ost$segment_length,
      send_segment_offset: ost$segment_length,
      send_segment_pointer: amt$segment_pointer,
      send_start_time: integer,
      server_location: dft$server_location,
      total_bytes_transferred: integer,
      value: clt$value;

{ Crack parameters.

    clp$scan_parameter_list (parameter_list, test_remote_rpc_call_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('QUEUE_IDENTIFIER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.name.value = 'CURRENT' THEN
      dfp$get_test_queue_location (p_queue_interface_table, queue_index);
      server_location.server_location_selector := dfc$mainframe_id;
      server_location.server_mainframe := p_queue_interface_table^.queue_directory.
            cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header.
            destination_mainframe_name;
{ ???
    ELSEIF value.name.value (1, 7) = '$SYSTEM' THEN

{ Assume its a mainframe name.

      server_location.server_location_selector := dfc$mainframe_id;
      server_location.server_mainframe := value.name.value (1, 17);
    ELSE { family name
      server_location.server_location_selector := dfc$family_name;
      server_location.family_name := value.name.value;
    IFEND;

    clp$get_value ('SEND_BUFFER_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    send_buffer_size := value.int.value;

    clp$get_value ('RECEIVE_BUFFER_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    receive_buffer_size := value.int.value;

    clp$get_value ('SEND_DATA_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    send_data_size := value.int.value;

    clp$get_value ('RECEIVE_DATA_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    receive_data_size := value.int.value;

    clp$get_value ('RECEIVE_SEGMENT_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    receive_segment_size := value.int.value;
    clp$get_value ('RECEIVE_SEGMENT_OFFSET', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    receive_segment_offset := value.int.value;
    IF receive_segment_size > 0 THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      i#build_adaptable_seq_pointer (#RING (segment_pointer.sequence_pointer),
            #SEGMENT (segment_pointer.sequence_pointer), receive_segment_offset,
            { Length } mmv$max_segment_length - receive_segment_offset, { Next } 0, p_receive_segment);
      RESET p_receive_segment;
    IFEND;

    clp$get_value ('SEND_SEGMENT_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    send_segment_size := value.int.value;
    clp$get_value ('SEND_SEGMENT_OFFSET', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    send_segment_offset := value.int.value;
    IF send_segment_size > 0 THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, send_segment_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      p_send_segment := send_segment_pointer.sequence_pointer;
      RESET p_send_segment;
    IFEND;

    clp$get_value ('REQUEST_RESTARTABLE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    request_restartable := value.bool.value;

    clp$get_value ('ALLOWED_WHEN_SERVER_DEACTIVATED', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    allowed_when_server_deactivated := value.bool.value;

    clp$get_value ('COMPUTE_CHECKSUM', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    compute_checksum := value.bool.value;
    IF compute_checksum THEN
      first_char := $CHAR (((send_buffer_size + send_data_size) MOD 10) + 1);
    ELSE
      first_char := $CHAR (0);
    IFEND;

    clp$get_value ('REPEAT_COUNT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    repeat_count := value.int.value;
    IF  (repeat_count > 1) AND (send_segment_size > 1) THEN
      osp$set_status_abnormal (dfc$file_server_id,  dfe$test_startup_error,
         ' send_segment_size > 1 not supported with repeat_count', status);
      RETURN;
    IFEND;

    begin_time := #FREE_RUNNING_CLOCK (0);
    dfp$begin_ch_remote_proc_call (server_location, allowed_when_server_deactivated, queue_entry_location,
          p_send_buffer, p_send_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Fill send segment

    send_segment_checksum := 0;
    IF send_segment_size > 0 THEN
      IF compute_checksum THEN
{ Turn off range checking to allow nexting huge string
?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??
        NEXT p_send_string: [send_segment_size] IN p_send_segment;
        fill_test_data (p_send_string, send_segment_size, first_char);
        dfp$compute_checksum (p_send_string, send_segment_size,
              send_segment_checksum);
{ Turn on range checking
?? POP ??
      ELSE
        dfp$touch_pages (p_send_segment, send_segment_size, page_count);
      IFEND;
      RESET p_send_segment;
      send_start_time := #FREE_RUNNING_CLOCK (0);
      dfp$send_client_rpc_segment (queue_entry_location, p_send_segment,
          send_segment_offset, send_segment_size, status);
      send_end_time := #FREE_RUNNING_CLOCK (0);
      IF NOT status.normal THEN
        display (' ABNORMAL STATUS FROM dfp$send_client_rpc_segment ');
        dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
        RETURN;
      IFEND;
      display_integer ('  Send_segment bytes per second = ', (1000000 * send_segment_size) DIV
          (send_end_time - send_start_time));
    IFEND;

    IF compute_checksum THEN
      pmp$zero_out_table (p_send_buffer, #SIZE (p_send_buffer^));
      pmp$zero_out_table (p_send_data, #SIZE (p_send_data^));
    IFEND;
    NEXT p_test_request_header IN p_send_buffer;
    p_test_request_header^.start_time := begin_time;
    p_test_request_header^.compute_checksum := compute_checksum;
    p_test_request_header^.send_buffer_size := send_buffer_size;
    p_test_request_header^.receive_buffer_size := receive_buffer_size;
    p_test_request_header^.send_buffer_starting_char := first_char;
    p_test_request_header^.send_data_size := send_data_size;
    p_test_request_header^.receive_data_size := receive_data_size;
    p_test_request_header^.receive_segment_size := receive_segment_size;
    p_test_request_header^.receive_segment_offset := receive_segment_offset;
    p_test_request_header^.segment_starting_char := first_char;
    p_test_request_header^.send_segment_size := send_segment_size;
    p_test_request_header^.send_segment_offset := send_segment_offset;
    p_test_request_header^.send_segment_starting_char := first_char;
    p_test_request_header^.send_segment_checksum := send_segment_checksum;
{ Fill test buffer

    IF send_buffer_size > 0 THEN
      NEXT p_send_string: [send_buffer_size] IN p_send_buffer;
      IF compute_checksum THEN
        fill_test_data (p_send_string, send_buffer_size, first_char);
        dfp$compute_checksum (p_send_string, send_buffer_size, p_test_request_header^.buffer_checksum);
      ELSE
        p_test_request_header^.buffer_checksum := 0;
      IFEND;
    IFEND;

{ Fill test data

    p_test_request_header^.data_starting_char := first_char;
    IF send_data_size > 0 THEN
      IF compute_checksum THEN
?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??
        NEXT p_send_string: [send_data_size] IN p_send_data;
        fill_test_data (p_send_string, send_data_size, first_char);
        dfp$compute_checksum (p_send_string, send_data_size, p_test_request_header^.data_checksum);
?? POP ??
      ELSE
        dfp$touch_pages (p_send_data, send_data_size, page_count);
        p_test_request_header^.data_checksum := 0;
      IFEND;
    IFEND;


    IF request_restartable THEN
      procedure_ordinal := dfc$rpc_restartable_test;
    ELSE
      procedure_ordinal := dfc$rpc_unrestartable_test;
    IFEND;

    send_start_time := #FREE_RUNNING_CLOCK (0);

{ Call the server

    FOR send_count := 1 TO repeat_count DO
      dfp$send_remote_procedure_call (queue_entry_location, procedure_ordinal, send_buffer_size +
            #SIZE (dft$rpc_test_request_header), send_data_size, p_receive_buffer, p_receive_data, status);
      IF NOT status.normal THEN
        display (' ABNORMAL STATUS FROM dfp$send_remote_procedure_call ');
        dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
        RETURN;
      IFEND;
    FOREND;
    send_end_time := #FREE_RUNNING_CLOCK (0);

{ Check receive buffer

    NEXT p_test_request_header IN p_receive_buffer;
    IF p_test_request_header^.start_time <> begin_time THEN
      display_integer ('CLIENT - TIME MISMATCH ', begin_time);
      display_integer ('CLIENT - RECEIVE TIME ', p_test_request_header^.start_time);
    IFEND;
    IF (receive_buffer_size > 0) THEN
      IF compute_checksum THEN
        NEXT p_receive_string: [receive_buffer_size] IN p_receive_buffer;
        dfp$compute_checksum (p_receive_string, receive_buffer_size, checksum);
        IF checksum <> p_test_request_header^.buffer_checksum THEN
          display ('CLIENT - RECEIVE BUFFER CHECKSUM MISMATCH ');
        IFEND;
        read_test_data (p_receive_string, receive_buffer_size,
              p_test_request_header^.send_buffer_starting_char, status);
        IF NOT status.normal THEN
          display ('CLIENT - RECEIVE BUFFER DATA MISMATCH ');
          display_status (status);
        IFEND;
      IFEND;
    IFEND;

{ Check receive data

    IF (receive_data_size > 0) THEN
      IF compute_checksum THEN
?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??
        NEXT p_receive_string: [receive_data_size] IN p_receive_data;
        dfp$compute_checksum (p_receive_string, receive_data_size, checksum);
        IF checksum <> p_test_request_header^.data_checksum THEN
          display ('CLIENT - DATA CHECKSUM MISMATCH ');
        IFEND;
        read_test_data (p_receive_string, receive_data_size, p_test_request_header^.data_starting_char,
              status);
        IF NOT status.normal THEN
          display ('CLIENT - DATA MISMATCH ');
          display_status (status);
        IFEND;
?? POP ??
      IFEND;
    IFEND;

{ Check receive segment

    IF (receive_segment_size > 0) THEN
      dfp$receive_server_rpc_segment (queue_entry_location, receive_segment_offset, receive_segment_size,
            p_receive_segment, status);
      IF NOT status.normal THEN
        display ('CLIENT - COULD NOT RECEIVE SEGMENT');
        display_status (status);
      IFEND;
      IF status.normal AND compute_checksum THEN
        RESET p_receive_segment;
?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??
        NEXT p_receive_string: [receive_segment_size] IN p_receive_segment;
        dfp$compute_checksum (p_receive_string, receive_segment_size, checksum);
        IF checksum <> p_test_request_header^.segment_checksum THEN
          display ('CLIENT - SEGMENT CHECKSUM MISMATCH ');
        IFEND;
        read_test_data (p_receive_string, receive_segment_size, p_test_request_header^.segment_starting_char,
              status);
        IF NOT status.normal THEN
          display ('CLIENT - SEGMENT MISMATCH ');
          display_status (status);
        IFEND;
      IFEND;
      mmp$delete_scratch_segment (segment_pointer, local_status);
?? POP ??
    IFEND;

    dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
    IF NOT local_status.normal THEN
      display (' dfp$end_ch_remote_proc_call');
      display_status (local_status);
    IFEND;
    end_time := #FREE_RUNNING_CLOCK (0);
    total_bytes_transferred := repeat_count * (send_buffer_size + receive_buffer_size + send_data_size +
          receive_data_size) + receive_segment_size;
    display_integer ('   Total user bytes transferred = ', total_bytes_transferred);
    display_integer ('   Bytes per second = ', (1000000 * total_bytes_transferred) DIV
          (send_end_time - send_start_time));
  PROCEND dfp$test_remote_procedure_call;
?? TITLE := ' Server : [XDCL] dfp$receive_test_rpc ', EJECT ??

{ This procedure is the server side of the procedure dfp$test_remote_procedure_call.
{ This verified the parameters if requests, and sends back any buffer, data, or segment
{ requested.

  PROCEDURE [XDCL] dfp$receive_test_rpc
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      checksum: integer,
      p_client_segment: ^SEQ ( * ),
      p_receive_segment: ^SEQ ( * ),
      p_receive_string: ^string ( * ),
      p_receive_test_rpc_header: ^dft$rpc_test_request_header,
      p_send_string: ^string ( * ),
      p_send_test_rpc_header: ^dft$rpc_test_request_header;

    status.normal := TRUE;
    NEXT p_receive_test_rpc_header IN p_param_received_from_client;

    IF p_receive_test_rpc_header^.compute_checksum THEN
      pmp$zero_out_table (p_send_to_client_params, #SIZE (p_send_to_client_params^));
      pmp$zero_out_table (p_data_to_client, #SIZE (p_data_to_client^));
    IFEND;

{ Verify receive buffer

    IF p_receive_test_rpc_header^.send_buffer_size > 0 THEN
      NEXT p_receive_string: [p_receive_test_rpc_header^.send_buffer_size] IN p_param_received_from_client;
      IF p_receive_test_rpc_header^.compute_checksum THEN
        dfp$compute_checksum (p_receive_string, p_receive_test_rpc_header^.send_buffer_size, checksum);
        IF checksum <> p_receive_test_rpc_header^.buffer_checksum THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$test_checksum_error,
                'SERVER - RECEIVE BUFFER CHECKSUM', status);
          RETURN;
        IFEND;
        read_test_data (p_receive_string, p_receive_test_rpc_header^.send_buffer_size,
              p_receive_test_rpc_header^.send_buffer_starting_char, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

{ Verify receive data

    IF p_receive_test_rpc_header^.send_data_size > 0 THEN
?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??
      NEXT p_receive_string: [p_receive_test_rpc_header^.send_data_size] IN p_data_from_client;
      IF p_receive_test_rpc_header^.compute_checksum THEN
        dfp$compute_checksum (p_receive_string, p_receive_test_rpc_header^.send_data_size, checksum);
        IF checksum <> p_receive_test_rpc_header^.data_checksum THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$test_checksum_error,
                'SERVER- RECEIVE DATA CHECKSUM', status);
          RETURN;
        IFEND;
        read_test_data (p_receive_string, p_receive_test_rpc_header^.send_data_size,
              p_receive_test_rpc_header^.data_starting_char, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
?? POP ??
    IFEND;

{ Verify segment sent from client

    IF p_receive_test_rpc_header^.send_segment_size > 0 THEN
      dfp$receive_client_rpc_segment (p_client_segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
{ Turn of range checking to allow working with data as huge string.
?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??
      IF p_receive_test_rpc_header^.send_segment_offset > 0 THEN
        { Advance the sequence so the data is received at the correct offset.
        NEXT p_receive_string: [p_receive_test_rpc_header^.send_segment_offset] IN p_client_segment;
      IFEND;
      NEXT p_receive_string: [p_receive_test_rpc_header^.send_segment_size] IN p_client_segment;
      IF p_receive_test_rpc_header^.compute_checksum THEN
        dfp$compute_checksum (p_receive_string, p_receive_test_rpc_header^.send_segment_size, checksum);
        IF checksum <> p_receive_test_rpc_header^.send_segment_checksum THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$test_checksum_error,
                'SERVER- SEND SEGMENT CHECKSUM', status);
          dfp$delete_client_rpc_segment;
          RETURN;
        IFEND;
        read_test_data (p_receive_string, p_receive_test_rpc_header^.send_segment_size,
              p_receive_test_rpc_header^.send_segment_starting_char, status);
        IF NOT status.normal THEN
          dfp$delete_client_rpc_segment;
          RETURN;
        IFEND;
      IFEND;
      dfp$delete_client_rpc_segment;
{ Turn on range checking.
?? POP ??
    IFEND;


{ Initialize send test header.

    NEXT p_send_test_rpc_header IN p_send_to_client_params;
    p_send_test_rpc_header^.start_time := p_receive_test_rpc_header^.start_time;
    p_send_test_rpc_header^.compute_checksum := p_receive_test_rpc_header^.compute_checksum;
    p_send_test_rpc_header^.send_buffer_size := p_receive_test_rpc_header^.receive_buffer_size;
    p_send_test_rpc_header^.receive_buffer_size := p_receive_test_rpc_header^.send_buffer_size;
    p_send_test_rpc_header^.send_buffer_starting_char := p_receive_test_rpc_header^.send_buffer_starting_char;
    p_send_test_rpc_header^.send_data_size := p_receive_test_rpc_header^.receive_data_size;
    p_send_test_rpc_header^.receive_data_size := p_receive_test_rpc_header^.send_data_size;
    p_send_test_rpc_header^.receive_segment_size := p_receive_test_rpc_header^.receive_segment_size;
    p_send_test_rpc_header^.receive_segment_offset := p_receive_test_rpc_header^.receive_segment_offset;
    p_send_test_rpc_header^.segment_starting_char := p_receive_test_rpc_header^.segment_starting_char;
    p_send_test_rpc_header^.segment_checksum := p_receive_test_rpc_header^.segment_checksum;

    send_parameters_length := p_receive_test_rpc_header^.receive_buffer_size +
          #SIZE (dft$rpc_test_request_header);

{ Generate send buffer

    IF p_receive_test_rpc_header^.receive_buffer_size > 0 THEN
      NEXT p_send_string: [p_receive_test_rpc_header^.receive_buffer_size] IN p_send_to_client_params;
      IF p_receive_test_rpc_header^.compute_checksum THEN
        fill_test_data (p_send_string, p_receive_test_rpc_header^.receive_buffer_size,
              p_send_test_rpc_header^.send_buffer_starting_char);
        dfp$compute_checksum (p_send_string, p_receive_test_rpc_header^.receive_buffer_size,
              p_send_test_rpc_header^.buffer_checksum);
      ELSE
        p_send_test_rpc_header^.buffer_checksum := 0;
      IFEND;
    IFEND;

{ Generate send data

    data_size_to_send_to_client := p_receive_test_rpc_header^.receive_data_size;
    p_send_test_rpc_header^.data_starting_char := p_receive_test_rpc_header^.data_starting_char;
    IF p_receive_test_rpc_header^.receive_data_size > 0 THEN
?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??
      NEXT p_send_string: [p_receive_test_rpc_header^.receive_data_size] IN p_data_to_client;
      IF p_receive_test_rpc_header^.compute_checksum THEN
        fill_test_data (p_send_string, p_receive_test_rpc_header^.receive_data_size,
              p_send_test_rpc_header^.data_starting_char);
        dfp$compute_checksum (p_send_string, p_receive_test_rpc_header^.receive_data_size,
              p_send_test_rpc_header^.data_checksum);
      ELSE
        p_send_string^ := '';
        p_send_test_rpc_header^.data_checksum := 0;
      IFEND;
?? POP ??
    IFEND;

{ Generate send segment

    IF p_receive_test_rpc_header^.receive_segment_size > 0 THEN
      dfp$reserve_server_rpc_segment (p_receive_segment, status);
      IF status.normal THEN
        IF p_receive_test_rpc_header^.receive_segment_offset > 0 THEN
          i#build_adaptable_seq_pointer (#RING (p_receive_segment), #SEGMENT (p_receive_segment),
                p_receive_test_rpc_header^.receive_segment_offset,
                { Length } mmv$max_segment_length - p_receive_test_rpc_header^.receive_segment_offset,
                { Next (relative to offset) } 0, p_receive_segment);
        IFEND;
?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??
        NEXT p_send_string: [p_receive_test_rpc_header^.receive_segment_size] IN p_receive_segment;
        IF p_receive_test_rpc_header^.compute_checksum THEN
          fill_test_data (p_send_string, p_receive_test_rpc_header^.receive_segment_size,
                p_send_test_rpc_header^.segment_starting_char);
          dfp$compute_checksum (p_send_string, p_receive_test_rpc_header^.receive_segment_size,
                p_send_test_rpc_header^.segment_checksum);
        ELSE

{ No need to touch the pages since they need not be wired

          p_send_test_rpc_header^.segment_checksum := 0;
        IFEND;
?? POP ??
      IFEND;
    IFEND;
  PROCEND dfp$receive_test_rpc;
?? TITLE := '   Client : [XDCL] dfp$send_remote_command_line ', EJECT ??

  PROCEDURE [XDCL] dfp$send_remote_command_line
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt send_rcl_pdt (server_mainframe_id, smid: name 17 = $required
{   statement_list, sl: string = $required
{   PRIVILEGE,p: key current_job, system_job = system_job
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      send_rcl_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^send_rcl_pdt_names, ^send_rcl_pdt_params];

    VAR
      send_rcl_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
            clt$parameter_name_descriptor := [['SERVER_MAINFRAME_ID', 1], ['SMID', 1], ['STATEMENT_LIST', 2],
            ['SL', 2], ['PRIVILEGE', 3], ['P', 3], ['STATUS', 4]];

    VAR
      send_rcl_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor := [

{ SERVER_MAINFRAME_ID SMID

      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 17, 17]],

{ STATEMENT_LIST SL

      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$string_value, 0, osc$max_string_size]],

{ PRIVILEGE P

      [[clc$optional_with_default, ^send_rcl_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed,
            [^send_rcl_pdt_kv3, clc$keyword_value]],

{ STATUS

      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      send_rcl_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of
            ost$name := ['CURRENT_JOB', 'SYSTEM_JOB'];

    VAR
      send_rcl_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (10) := 'system_job';

?? POP ??

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT dfp$send_remote_command_line;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      mainframe_id: pmt$binary_mainframe_id,
      p_receive_buffer: dft$p_receive_parameters,
      p_receive_data: dft$p_receive_data,
      p_send_buffer: dft$p_send_parameters,
      p_send_data: dft$p_send_data,
      p_send_string: ^string ( * ),
      procedure_ordinal: dft$procedure_address_ordinal,
      queue_entry_location: dft$rpc_queue_entry_location,
      server_location: dft$server_location,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, send_rcl_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    server_location.server_location_selector := dfc$mainframe_id;
    dfp$crack_mainframe_id ('SERVER_MAINFRAME_ID', server_location.server_mainframe, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('PRIVILEGE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.name.value = 'CURRENT_JOB' THEN
      procedure_ordinal := dfc$send_remote_cl_current;
    ELSE { SYSTEM_JOB
      procedure_ordinal := dfc$send_remote_cl_system;
    IFEND;

    clp$get_value ('STATEMENT_LIST', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$begin_ch_remote_proc_call (server_location, FALSE, queue_entry_location, p_send_buffer, p_send_data,
          status);
    IF status.normal THEN
      NEXT p_send_string: [value.str.size] IN p_send_buffer;
      p_send_string^ := value.str.value (1, value.str.size);

      dfp$send_remote_procedure_call (queue_entry_location, procedure_ordinal, #SIZE (p_send_string^), 0,
            p_receive_buffer, p_receive_data, status);
      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
    IFEND;
  PROCEND dfp$send_remote_command_line;
?? TITLE := ' Server : [XDCL] dfp$receive_remote_command_line ', EJECT ??

  PROCEDURE [XDCL] dfp$receive_remote_command_line
    (VAR p_param_received_from_client {input} : dft$p_receive_parameters;
     VAR p_data_from_client {input} : dft$p_receive_data;
     VAR p_send_to_client_params {^output} : dft$p_send_parameters;
     VAR p_data_to_client: dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_string: ^string ( * );

    send_parameters_length := 0;
    data_size_to_send_to_client := 0;

    NEXT p_string: [#SIZE (p_param_received_from_client^)] IN p_param_received_from_client;

    clp$scan_command_line (p_string^, status);
  PROCEND dfp$receive_remote_command_line;
?? TITLE := '  Client : [XDCL] dfp$send_remote_message ', EJECT ??

  PROCEDURE [XDCL] dfp$send_remote_message
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt send_remote_message_pdt (server_mainframe_id, smid: name 17 = $required
{  message, m : string = $required
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      send_remote_message_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^send_remote_message_pdt_names, ^send_remote_message_pdt_params];

    VAR
      send_remote_message_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
            clt$parameter_name_descriptor := [['SERVER_MAINFRAME_ID', 1], ['SMID', 1], ['MESSAGE', 2],
            ['M', 2], ['STATUS', 3]];

    VAR
      send_remote_message_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
            clt$parameter_descriptor := [

{ SERVER_MAINFRAME_ID SMID

      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 17, 17]],

{ MESSAGE M

      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$string_value, 0, osc$max_string_size]],

{ STATUS

      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT dfp$send_remote_message;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      client_mainframe: pmt$mainframe_id,
      local_status: ost$status,
      mainframe_id: pmt$binary_mainframe_id,
      p_receive_buffer: dft$p_receive_parameters,
      p_receive_data: dft$p_receive_data,
      p_send_buffer: dft$p_send_parameters,
      p_send_data: dft$p_send_data,
      p_send_string: ^string ( * ),
      queue_entry_location: dft$rpc_queue_entry_location,
      server_location: dft$server_location,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, send_remote_message_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    server_location.server_location_selector := dfc$mainframe_id;
    dfp$crack_mainframe_id ('SERVER_MAINFRAME_ID', server_location.server_mainframe, mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$begin_ch_remote_proc_call (server_location, FALSE, queue_entry_location, p_send_buffer, p_send_data,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('MESSAGE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      RETURN;
    IFEND;

    NEXT p_send_string: [#SIZE (server_location.server_mainframe) + 2] IN p_send_buffer;
    pmp$get_mainframe_id (client_mainframe, local_status);
    p_send_string^ := client_mainframe;
    NEXT p_send_string: [value.str.size] IN p_send_buffer;
    p_send_string^ := value.str.value (1, value.str.size);
    dfp$send_remote_procedure_call (queue_entry_location, dfc$send_remote_message, { Buffer Size}
          #SIZE (p_send_string^) + #SIZE (server_location.server_mainframe) + 2, { Data size} 0,
          p_receive_buffer, p_receive_data, status);
    dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
  PROCEND dfp$send_remote_message;
?? TITLE := ' Server : [XDCL] dfp$receive_remote_message ', EJECT ??

  PROCEDURE [XDCL] dfp$receive_remote_message
    (VAR p_param_received_from_client {input} : dft$p_receive_parameters;
     VAR p_data_from_client {input} : dft$p_receive_data;
     VAR p_send_to_client_params {^output} : dft$p_send_parameters;
     VAR p_data_to_client: dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_string: ^string ( * );

    send_parameters_length := 0;
    data_size_to_send_to_client := 0;

    NEXT p_string: [#SIZE (p_param_received_from_client^)] IN p_param_received_from_client;
    dpp$put_next_line (dpv$system_core_display, p_string^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$log_ascii (p_string^, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_program,
          status);

  PROCEND dfp$receive_remote_message;
?? TITLE := '  fill_test_data', EJECT ??

?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??

  PROCEDURE fill_test_data
    (    p_string: ^string ( * );
         char_count: integer;
         first_char: char);

    VAR
      count: integer,
      fill_char: char;

    fill_char := first_char;

  /fill_data/
    FOR count := 1 TO char_count DO
      p_string^ (count) := fill_char;
      IF $INTEGER (fill_char) < 255 THEN
        fill_char := $CHAR ($INTEGER (fill_char) + 1);
      ELSE
        fill_char := $CHAR (0);
      IFEND;
    FOREND /fill_data/;

  PROCEND fill_test_data;
?? POP ??
?? TITLE := '  read_test_data', EJECT ??
?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??

  PROCEDURE read_test_data
    (    p_string: ^string ( * );
         char_count: integer;
         first_char: char;
     VAR status: ost$status);

    VAR
      count: integer,
      fill_char: char;

    status.normal := TRUE;
    fill_char := first_char;

  /check_data/
    FOR count := 1 TO char_count DO
      IF p_string^ (count) <> fill_char THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$test_checksum_error, 'DATA MISMATCH', status);
        RETURN;
      IFEND;
      IF $INTEGER (fill_char) < 255 THEN
        fill_char := $CHAR ($INTEGER (fill_char) + 1);
      ELSE
        fill_char := $CHAR (0);
      IFEND;
    FOREND /check_data/;

  PROCEND read_test_data;
?? POP ??
MODEND dfm$test_remote_procedure_call;

*DECK DECK=DFM$TIMEOUT_REQUESTS_TO_SERVER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server: Client', EJECT ??
MODULE dfm$timeout_requests_to_server;

{ PURPOSE:
{   The purpose of this module is to process the outstanding requests
{         for a server mainframe being timed out.
{

?? NEWTITLE := '   Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfc$poll_constants
*copyc dfd$driver_queue_types
*copyc dfd$request_package
*copyc dfe$error_condition_codes
*copyc dfi$display
*copyc dfi$log_display
*copyc dft$cpu_queue
*copyc dft$page_io_request
*copyc dft$rb_file_server_request
*copyc dft$rpc_buffer_header
*copyc dfv$procedure_address_list
*copyc iot$pp_interface_table
*copyc pmt$task_status
*copyc syt$monitor_status
?? POP ??
*copyc dfp$check_queue_entry_assigned
*copyc dfp$find_mainframe_id
*copyc dfp$free_entry_assignment
*copyc dfp$locate_server_translation
*copyc dfv$file_server_debug_enabled
*copyc i#call_monitor
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$system_error
*copyc pmp$convert_binary_unique_name
*copyc pmp$wait
?? EJECT ??

?? TITLE := '    [XDCL] dfp$timeout_requests_to_server', EJECT ??

{
{   The purpose of this routine is to:
{  - Take care of queued requests:
{    Monitor requests are treated as an inactive server
{    Task requests are checked to determine if the server may have seen them
{      or if they are restartable requests.
{  - Change both active and swapped jobs so that they will wait for files
{      for this mainframe.
{  - Change the state of all server files to be awaiting recovery.
{

  PROCEDURE [XDCL] dfp$timeout_requests_to_server
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      gfn_name: ost$name,
      ignore_status: ost$status,
      mainframe_found: boolean,
      mainframe_ordinal: 1 .. dfc$max_number_of_mainframes,
      message: string (80),
      message_length: integer,
      p_cpu_queue: ^dft$cpu_queue,
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue: ^dft$driver_queue,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_ost_status: ^ost$status,
      p_page_io_request: ^dft$page_io_request,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_rpc_buffer_header: ^dft$rpc_buffer_header,
      p_send_buffer_header: ^dft$buffer_header,
      p_status_response: ^dft$status_response,
      queued_requests: 0 .. dfc$max_queue_entries,
      queue_entry_assigned: boolean,
      queue_index: dft$queue_index,
      q_d_index: dft$queue_directory_index,
      queue_entry_index: dft$queue_entry_index,
      request_block: dft$rb_file_server_request,
      request_status: ost$status,
      response_buffer_entry: dft$fs_pp_response,
      terminated_requests: 0 .. dfc$max_queue_entries,
      total_queue_entries: dft$queue_entry_index;

    status.normal := TRUE;
    queued_requests := 0;
    terminated_requests := 0;
    dfp$find_mainframe_id (mainframe_name, {host_is_server_to_client =} FALSE, mainframe_found,
          p_queue_interface_table, p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, mainframe_name, status);
      RETURN;
    IFEND;

    p_driver_queue := p_queue_interface_table^.queue_directory.driver_queue_pva_directory [queue_index].
          p_driver_queue;
    p_driver_queue^.queue_header.flags.idle := TRUE;
    pmp$wait (2000, 2000);

    total_queue_entries := p_driver_queue^.queue_header.number_of_queue_entries;

{Search queues for active entry and determine what to do.

    request_block.reqcode := syc$rc_file_server_request;
    request_block.request := dfc$fsr_term_client_tasks;
    request_block.queue_interface_table_p := p_queue_interface_table;
    response_buffer_entry.response_flags.special_response := TRUE;
    response_buffer_entry.response_flags.one_word_response := TRUE;
    response_buffer_entry.response_flags.error_response := FALSE;
    response_buffer_entry.response_flags.inquiry_response := FALSE;
    response_buffer_entry.response_flags.termination_pseudo_response := TRUE;
    response_buffer_entry.response_length := 8 {bytes = 1 word} ;
    response_buffer_entry.logical_unit := 0; {Not used by dfp$process_server_response_a
    response_buffer_entry.queue_index := queue_index;

  /search_for_incomplete_actions/
    FOR queue_entry_index := dfc$poll_queue_index + 1 TO total_queue_entries DO
      dfp$check_queue_entry_assigned (queue_entry_index, p_cpu_queue^.queue_header.
            queue_entry_assignment_table, queue_entry_assigned);
      IF NOT queue_entry_assigned THEN
        CYCLE /search_for_incomplete_actions/;
      IFEND;
      queued_requests := queued_requests + 1;
      p_driver_queue_entry := ^p_driver_queue^.queue_entries [queue_entry_index];
      p_cpu_queue_entry := ^p_cpu_queue^.queue_entries [queue_entry_index];
      RESET p_cpu_queue_entry^.p_send_buffer;
      NEXT p_send_buffer_header IN p_cpu_queue_entry^.p_send_buffer;

{ Determine what to do with the outstanding request

      IF p_cpu_queue_entry^.processor_type = dfc$task_services THEN
        NEXT p_rpc_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
        determine_queued_request_action (p_send_buffer_header^.remote_processor, p_rpc_buffer_header^,
              p_cpu_queue_entry, p_driver_queue_entry, mainframe_name, p_cpu_queue, request_status);
        IF request_status.normal THEN
          CYCLE /search_for_incomplete_actions/;
        IFEND;
      ELSE { For monitor entries force a wait
        osp$set_status_condition (dfe$server_not_active, request_status);
        IF dfv$file_server_debug_enabled THEN
          NEXT p_page_io_request IN p_cpu_queue_entry^.p_send_buffer;
          pmp$convert_binary_unique_name (p_page_io_request^.global_file_name, gfn_name, status);
          STRINGREP (message, message_length, ' qei', queue_entry_index,
            ' gfn', gfn_name, ' off', p_page_io_request^.segment_offset);
          display (message (1, message_length));
          log_display ($pmt$ascii_logset[pmc$system_log], message (1, message_length));
        IFEND;
      IFEND;
      response_buffer_entry.queue_entry_index := queue_entry_index;
      request_block.one_word_response := response_buffer_entry;
      RESET p_cpu_queue_entry^.p_receive_buffer;
      NEXT p_status_response IN p_cpu_queue_entry^.p_receive_buffer;
      p_status_response^.buffer_header.transaction_count := p_cpu_queue_entry^.transaction_count;
      p_status_response^.buffer_header.version := dfc$status_buffer_version;
      p_status_response^.buffer_header.remote_processor := p_send_buffer_header^.remote_processor;

{!! Assumming that the value returned is the same

      p_status_response^.status.normal := FALSE;
      p_status_response^.status.condition := request_status.condition;
      IF p_cpu_queue_entry^.processor_type = dfc$task_services THEN
        NEXT p_ost_status IN p_cpu_queue_entry^.p_receive_buffer;
        p_ost_status^ := request_status;
        IF request_status.condition = dfe$server_request_terminated THEN
          terminated_requests := terminated_requests + 1;
        IFEND;
      IFEND;
      request_block.cpu_queue_entry_p := p_cpu_queue_entry;
      request_block.status.normal := TRUE;
      p_driver_queue^.queue_entries [queue_entry_index].flags.active_entry := TRUE;
      p_driver_queue^.queue_entries [queue_entry_index].flags.driver_action := FALSE;
      p_driver_queue^.queue_entries [queue_entry_index].flags.subsystem_action := FALSE;
      p_driver_queue^.queue_entries [queue_entry_index].flags.buffer_received := TRUE;
      p_driver_queue^.queue_entries [queue_entry_index].flags.process_response := TRUE;

      i#call_monitor (#LOC (request_block), #SIZE (request_block));

      IF NOT request_block.status.normal THEN

{  check if still assigned

        dfp$check_queue_entry_assigned (queue_entry_index, p_cpu_queue^.queue_header.
              queue_entry_assignment_table, queue_entry_assigned);
        IF queue_entry_assigned THEN
          dfp$free_entry_assignment (queue_entry_index, p_cpu_queue^.queue_header.
                queue_entry_assignment_table);
        IFEND;
      IFEND;

    FOREND /search_for_incomplete_actions/;

    STRINGREP (message, message_length, 'Server ', mainframe_name, ' terminated', terminated_requests,
          ' of', queued_requests, ' queued requests');
    IF terminated_requests > 0 THEN
      display (message (1, message_length));
    IFEND;
    log_display ($pmt$ascii_logset[pmc$system_log], message (1, message_length));

    dfp$locate_server_translation (p_cpu_queue^.queue_header.destination_mainframe_id, mainframe_ordinal,
          mainframe_found);
    request_block.request := dfc$fsr_set_task_segment_state;
    request_block.inhibit_access_work := $dft$mainframe_set [mainframe_ordinal];
    request_block.terminate_access_work := $dft$mainframe_set [];
    i#call_monitor (#LOC (request_block), #SIZE (request_block));


  PROCEND dfp$timeout_requests_to_server;

?? EJECT ??

{
{   The procedure attempts to determines if it ok to send the request over
{ the server again.  If the request is restartable it is always ok, otherwise
{ it is only ok if we are SURE the server has not received the request.
{ The driver is assumed to be idled when this is called.

  PROCEDURE determine_queued_request_action
    (    remote_processor: dft$procedure_address_ordinal;
         rpc_buffer_header: dft$rpc_buffer_header;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         mainframe_name: pmt$mainframe_id;
         p_cpu_queue: ^dft$cpu_queue;
     VAR status: ost$status);

    VAR
      current_rpc_entry: dft$rpc_procedure_address_entry,
      display_string: string (80),
      length: integer;

    IF remote_processor <= dfc$last_system_procedure THEN
      current_rpc_entry := dfv$procedure_address_list [remote_processor];
    ELSE
      current_rpc_entry := p_cpu_queue^.queue_header.p_application_rpc_list^ [$integer (remote_processor) -
            $integer (dfc$last_system_procedure)];
    IFEND;
    IF current_rpc_entry.request_restartable = dfc$request_restartable THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_active, mainframe_name, status);
    ELSE { Determine transaction state}
      IF (p_cpu_queue_entry^.transaction_state IN $dft$transaction_state_set
            [dfc$null_state, dfc$queue_entry_available, dfc$queue_entry_assigned]) OR
            ((p_cpu_queue_entry^.transaction_state = dfc$request_queued) AND
            p_driver_queue_entry^.flags.driver_action) THEN

{ We are sure the request has not been sent yet.

        osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_active, mainframe_name, status);
      ELSEIF p_cpu_queue_entry^.transaction_state IN $dft$transaction_state_set [dfc$response_received] THEN

{ The task will get around to it soon enough.

        status.normal := TRUE;
      ELSE { The server may have received the request.
        osp$set_status_abnormal (dfc$file_server_id, dfe$server_request_terminated,
              current_rpc_entry.debug_display, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, mainframe_name, status);
        STRINGREP (display_string, length, ' Job ', rpc_buffer_header.system_supplied_job_name,
              ' terminated ', current_rpc_entry.debug_display);
        IF dfv$file_server_debug_enabled THEN
          display (display_string (1, length));
        IFEND;
        log_display ($pmt$ascii_logset[pmc$system_log], display_string (1, length));
      IFEND;
    IFEND;
  PROCEND determine_queued_request_action;
MODEND dfm$timeout_requests_to_server;
*DECK DECK=DFM$TRANSFER_MMIO_DATA EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := ' NOS/VE File Server : Transfer MM I/O Data ', EJECT ??
MODULE dfm$transfer_mmio_data;

{ PURPOSE:
{    The purpose of this module is to provide the procedures invloved with
{    the transfer of Memory Manager IO data from the server mainframe to the
{    client mainframe.
{
{ NOTES:
{    1.The client procedure - DFP$GET_MMIO_DATA - is called by the command
{      GENERATE_PTU_SUMMARY. The server (remote) procedure is DFP$SEND_MMIO_DATA.
{
{    2.Data is collected on the server side only if the executing modules of
{      IOM$PROCESS_IO_COMPLETIONS and MMM$FILE_SERVER_PROCESSOR had been
{      compiled with the statement DFV$PERF_TESTS=TRUE in the specified
{      selection_criteria file.


?? NEWTITLE := ' Global Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fetch_attributes
*copyc amp$put_next
*copyc amp$return
*copyc amv$nil_file_identifier
*copyc clp$get_value
*copyc clp$scan_command_line
*copyc clp$scan_parameter_list
*copyc dfd$driver_queue_types
*copyc dfd$request_package
*copyc dfe$error_condition_codes
*copyc dfi$display
*copyc dfi$fsp_open_close
*copyc dfp$crack_mainframe_id
*copyc dfp$find_mainframe_id
*copyc dfp$send_remote_procedure_call
*copyc dft$procedure_address_ordinal
*copyc dft$rpc_buffer_header
*copyc dft$rpc_parameters
*copyc dfv$trace_count
*copyc i#current_sequence_position
*copyc mmp$free_pages
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pfp$attach
*copyc pfp$begin_system_authority
*copyc pfp$end_system_authority
*copyc pmp$get_mainframe_id
*copyc pmp$zero_out_table
?? POP ??

{   Format of request sent from client

  TYPE
    dft$rpc_mmio_request_header = record
      client_mainframe: pmt$mainframe_id,
      free_pages: boolean,
      family: ost$name,
      user: ost$name,
      file: ost$name
    recend;

{   Format of data returned from server

  TYPE
    dft$rpc_mmio_data_header = record
      trace_count: integer,
      number_of_io_requests: integer,
      total_io_request_time: integer,
      max_io_request_time: integer,
      number_of_allocate_requests: integer,
      total_allocate_request_time: integer,
      max_allocate_request_time: integer,
    recend;

?? TITLE := '  NOS/VE File Server : Client: [XDCL, #GATE] dfp$get_mmio_data ', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$get_mmio_data
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt get_mmio_data_pdt       (
{ family, f: name = testing
{ mmio_file, mf: file = mmio_file
{ free_pages: boolean = TRUE
{ user: name
{ file: name
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      get_mmio_data_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^get_mmio_data_pdt_names, ^get_mmio_data_pdt_params];

    VAR
      get_mmio_data_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 8] of
            clt$parameter_name_descriptor := [['FAMILY', 1], ['F', 1], ['MMIO_FILE', 2], ['MF', 2],
            ['FREE_PAGES', 3], ['USER', 4], ['FILE', 5], ['STATUS', 6]];

    VAR
      get_mmio_data_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 6] of
            clt$parameter_descriptor := [

{ FAMILY F }
      [[clc$optional_with_default, ^get_mmio_data_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$name_value, 1, osc$max_name_size]],

{ MMIO_FILE MF }
      [[clc$optional_with_default, ^get_mmio_data_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$file_value]],

{ FREE_PAGES }
      [[clc$optional_with_default, ^get_mmio_data_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$boolean_value]],

{ USER }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ FILE }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      get_mmio_data_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := 'testing';

    VAR
      get_mmio_data_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (9) := 'mmio_file';

    VAR
      get_mmio_data_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'TRUE';

?? POP ??
?? NEWTITLE := 'clean_up', EJECT ??

    PROCEDURE clean_up;

      VAR
        ignore_status: ost$status;

      IF mmio_file_id <> amv$nil_file_identifier THEN
        dfp$fsp_close (mmio_file_id, seqp, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    CONST
      real_mics_to_seconds = 1.0e6;

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      IF use_abort_handler THEN
        clean_up;
      IFEND;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT dfp$get_mmio_data;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      allowed_when_server_deactivated: boolean,
      family: ost$name,
      file: ost$name,
      free_pages: boolean,
      ignore_byte_address: amt$file_byte_address,
      ignore_eoi: amt$file_byte_address,
      line: string (200),
      line_size: integer,
      local_status: ost$status,
      mmio_file_id: amt$file_identifier,
      mmio_file_name: amt$local_file_name,
      p_receive_buffer: dft$p_receive_parameters,
      p_receive_data: dft$p_receive_data,
      p_send_buffer: dft$p_send_parameters,
      p_send_data: dft$p_send_data,
      p_mmio_data_header: ^dft$rpc_mmio_data_header,
      p_mmio_request_header: ^dft$rpc_mmio_request_header,
      procedure_ordinal: dft$procedure_address_ordinal,
      queue_entry_location: dft$rpc_queue_entry_location,
      real_ave: real,
      real_max: real,
      receive_buffer_size: dft$send_parameter_size,
      receive_data_size: dft$send_data_size,
      request_restartable: boolean,
      send_buffer_size: dft$send_parameter_size,
      send_data_size: dft$send_data_size,
      seqp: ^SEQ ( * ),
      server_location: dft$server_location,
      start_time: integer,
      use_abort_handler: boolean,
      user: ost$name,
      value: clt$value;

    status.normal := TRUE;
    local_status.normal := TRUE;

    { Crack parameters.
    clp$scan_parameter_list (parameter_list, get_mmio_data_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('FAMILY', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    server_location.server_location_selector := dfc$family_name;
    server_location.family_name := value.name.value;
    family := value.name.value;

    clp$get_value ('MMIO_FILE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    mmio_file_name := value.file.local_file_name;

    clp$get_value ('FREE_PAGES', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    free_pages := value.bool.value;

    clp$get_value ('USER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      user := value.name.value;
    ELSE
      user := '';
    IFEND;

    clp$get_value ('FILE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      file := value.name.value;
    ELSE
      file := '';
    IFEND;

    use_abort_handler := FALSE;
    #SPOIL (use_abort_handler);
    request_restartable := TRUE;
    allowed_when_server_deactivated := FALSE;

    dfp$begin_ch_remote_proc_call (server_location, allowed_when_server_deactivated, queue_entry_location,
          p_send_buffer, p_send_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$zero_out_table (p_send_buffer, #SIZE (p_send_buffer^));
    NEXT p_mmio_request_header IN p_send_buffer;
    pmp$get_mainframe_id (p_mmio_request_header^.client_mainframe, status);
    IF NOT status.normal THEN
      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      RETURN;
    IFEND;

    p_mmio_request_header^.free_pages := free_pages;
    p_mmio_request_header^.family := family;
    p_mmio_request_header^.user := user;
    p_mmio_request_header^.file := file;

    procedure_ordinal := dfc$send_mmio_data;
    send_buffer_size := #SIZE (dft$rpc_mmio_request_header);
    send_data_size := 0;

    dfp$send_remote_procedure_call (queue_entry_location, procedure_ordinal, send_buffer_size, send_data_size,
          p_receive_buffer, p_receive_data, status);
    IF NOT status.normal THEN
      display (' ABNORMAL STATUS FROM dfp$get_mmio_data ');
      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      RETURN;
    IFEND;

    { Process receive buffer
    NEXT p_mmio_data_header IN p_receive_buffer;
    mmio_file_id := amv$nil_file_identifier;

  /process_mmio/
    BEGIN
      dfp$fsp_open (mmio_file_name, amc$record, {read_not_write} FALSE,
           {open_for_attach} FALSE, {seq_and_free_behind} FALSE, 'dfp$get_mmio_data',
           mmio_file_id, seqp, ignore_eoi, status);
      IF NOT status.normal THEN
        EXIT /process_mmio/;
      IFEND;
      use_abort_handler := TRUE;
      #SPOIL (use_abort_handler);

      IF p_mmio_data_header^.number_of_io_requests > 0 THEN
        real_ave := $REAL (p_mmio_data_header^.total_io_request_time) /
              $REAL (p_mmio_data_header^.number_of_io_requests);
        real_ave := real_ave / real_mics_to_seconds;
      ELSE
        real_ave := $REAL (0);
      IFEND;

      real_max := $REAL (p_mmio_data_header^.max_io_request_time) / real_mics_to_seconds;
      STRINGREP (line, line_size, ' ptu@mon_ave_io_time=''', real_ave: 9: 5, ''';ptu@mon_io_count=''',
            p_mmio_data_header^.number_of_io_requests, ''';ptu@mon_max_io_time=''', real_max: 9: 5, '''');
      amp$put_next (mmio_file_id, ^line, line_size, ignore_byte_address, status);
      IF NOT status.normal THEN
        EXIT /process_mmio/;
      IFEND;

      IF p_mmio_data_header^.number_of_allocate_requests > 0 THEN
        real_ave := $REAL (p_mmio_data_header^.total_allocate_request_time) /
              $REAL (p_mmio_data_header^.number_of_allocate_requests);
        real_ave := real_ave / real_mics_to_seconds;
      ELSE
        real_ave := $REAL (0);
      IFEND;

      real_max := $REAL (p_mmio_data_header^.max_allocate_request_time) / real_mics_to_seconds;
      STRINGREP (line, line_size, ' ptu@mon_ave_allocate_time=''', real_ave: 9: 5,
            ''';ptu@mon_allocate_count=''', p_mmio_data_header^.number_of_allocate_requests,
            ''';ptu@mon_max_allocate_time=''', real_max: 9: 5, '''');
      amp$put_next (mmio_file_id, ^line, line_size, ignore_byte_address, status);
      IF NOT status.normal THEN
        EXIT /process_mmio/;
      IFEND;

      STRINGREP (line, line_size, ' ptu@mon_trace_count=', p_mmio_data_header^.trace_count);
      amp$put_next (mmio_file_id, ^line, line_size, ignore_byte_address, status);
    END /process_mmio/;

    IF mmio_file_id <> amv$nil_file_identifier THEN
      dfp$fsp_close (mmio_file_id, seqp, status);
      use_abort_handler := FALSE;
      #SPOIL (use_abort_handler);
    IFEND;

    dfp$end_ch_remote_proc_call (queue_entry_location, local_status);

    IF status.normal THEN
      status := local_status;
    IFEND;

  PROCEND dfp$get_mmio_data;

?? TITLE := ' NOS/VE File Server : Server : [XDCL] dfp$send_mmio_data ', EJECT ??

  PROCEDURE [XDCL] dfp$send_mmio_data
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

       clean_up;

    PROCEND abort_handler;
?? TITLE := 'clean_up', EJECT ??

    PROCEDURE clean_up;

      VAR
        ignore_status: ost$status;

      IF file_id <> amv$nil_file_identifier THEN
        dfp$fsp_close (file_id, seqp, ignore_status);
      IFEND;
      pfp$end_system_authority;
    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    VAR
      client_mainframe: pmt$mainframe_id,
      cycle_selector: pft$cycle_selector,
      host_is_server_to_client: boolean,
      eoi: amt$file_byte_address,
      file_id: amt$file_identifier,
      file_position: amt$file_position,
      frep_line: string (250),
      frep_size: integer,
      local_status: ost$status,
      mainframe_found: boolean,
      password: pft$password,
      path: array [1 .. 3] of ost$name,
      p_cpu_queue: ^dft$cpu_queue,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      p_mmio_request_header: ^dft$rpc_mmio_request_header,
      p_send_mmio_data_header: ^dft$rpc_mmio_data_header,
      ptu_lfn: amt$local_file_name,
      queue_index: dft$queue_index,
      seqp: ^SEQ ( * ),
      share_selections: pft$share_selections,
      usage_selections: pft$usage_selections;

    status.normal := TRUE;

    pmp$zero_out_table (p_send_to_client_params, #SIZE (p_send_to_client_params^));
    pmp$zero_out_table (p_data_to_client, #SIZE (p_data_to_client^));
    NEXT p_mmio_request_header IN p_param_received_from_client;
    client_mainframe := p_mmio_request_header^.client_mainframe;
    host_is_server_to_client := TRUE;
    dfp$find_mainframe_id (client_mainframe, host_is_server_to_client, mainframe_found,
          p_queue_interface_table, p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_client, client_mainframe, status);
      RETURN;
    IFEND;


    NEXT p_send_mmio_data_header IN p_send_to_client_params;

    p_send_mmio_data_header^.trace_count := dfv$trace_count;
    p_send_mmio_data_header^.number_of_io_requests := p_cpu_queue^.queue_header.monitor_io [dfc$monitor_io].
          number_of_requests;
    p_send_mmio_data_header^.total_io_request_time := p_cpu_queue^.queue_header.monitor_io [dfc$monitor_io].
          total_request_time;
    p_send_mmio_data_header^.max_io_request_time := p_cpu_queue^.queue_header.monitor_io [dfc$monitor_io].
          max_request_time;
    p_send_mmio_data_header^.number_of_allocate_requests := p_cpu_queue^.queue_header.
          monitor_io [dfc$monitor_allocate].number_of_requests;
    p_send_mmio_data_header^.total_allocate_request_time := p_cpu_queue^.queue_header.
          monitor_io [dfc$monitor_allocate].total_request_time;
    p_send_mmio_data_header^.max_allocate_request_time := p_cpu_queue^.queue_header.
          monitor_io [dfc$monitor_allocate].max_request_time;

    send_parameters_length := #SIZE (dft$rpc_mmio_data_header);
    data_size_to_send_to_client := 0;

    p_cpu_queue^.queue_header.monitor_io [dfc$monitor_io].total_request_time := 0;
    p_cpu_queue^.queue_header.monitor_io [dfc$monitor_io].number_of_requests := 0;
    p_cpu_queue^.queue_header.monitor_io [dfc$monitor_io].max_request_time := 0;
    p_cpu_queue^.queue_header.monitor_io [dfc$monitor_allocate].total_request_time := 0;
    p_cpu_queue^.queue_header.monitor_io [dfc$monitor_allocate].number_of_requests := 0;
    p_cpu_queue^.queue_header.monitor_io [dfc$monitor_allocate].max_request_time := 0;
    dfv$trace_count := 0;

    IF p_mmio_request_header^.free_pages THEN
      ptu_lfn := 'frep_lfn';
      path [1] := p_mmio_request_header^.family;
      path [2] := p_mmio_request_header^.user;
      path [3] := p_mmio_request_header^.file;
      cycle_selector.cycle_option := pfc$highest_cycle;
      password := '';
      usage_selections := $pft$usage_selections [pfc$read, pfc$shorten, pfc$modify];
      share_selections := $pft$share_selections [];
      osp$establish_block_exit_hndlr (^abort_handler);
      pfp$begin_system_authority;
      pfp$attach (ptu_lfn, path, cycle_selector, password, usage_selections, share_selections, pfc$no_wait,
            status);

      file_id := amv$nil_file_identifier;

      IF status.normal THEN
        {  Open for write to free pages.
        dfp$fsp_open (ptu_lfn,  amc$segment, {read_not_write} FALSE, {open_for_attach} FALSE,
              {seq_and_free_behind} FALSE, 'dfp$get_mmio_data', file_id, seqp, eoi, status);
        IF NOT status.normal THEN
          amp$return (ptu_lfn, local_status);
          RETURN;
        IFEND;

        RESET seqp;
        mmp$free_pages (seqp, eoi, osc$wait, status);

        IF NOT status.normal THEN
          amp$return (ptu_lfn, local_status);
          RETURN;
        IFEND;

        dfp$fsp_close (file_id, seqp, status);

        amp$return (ptu_lfn, local_status);
        IF status.normal THEN
          status := local_status;
        IFEND;
      IFEND;
      pfp$end_system_authority;
      osp$disestablish_cond_handler;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND {free pages };

  PROCEND dfp$send_mmio_data;

MODEND dfm$transfer_mmio_data;

*DECK DECK=DFM$TRIAL_COMMANDS EXPAND=TRUE
*copyc osd$default_pragmats
?? NEWTITLE := ' NOS/VE File Server: Client: trial commands ', EJECT ??
MODULE dfm$trial_commands;
{
{  This module provides trial test commands for exercising the
{  file server code.  This is initiated from the driver_test_utility
{  subcommand SEND_TEST
{
?? NEWTITLE := '    Global Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc dfi$display
?? POP ??

?? TITLE := '    Global Variables ', EJECT ??
?? TITLE := '  [XDCL] DFP$SEND_TEST_COMMAND ', EJECT ??

  PROCEDURE [XDCL] dfp$send_test_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt try_family (family_name fn: name = nve
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      try_family: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^try_family_names, ^try_family_params];

    VAR
      try_family_names: [STATIC, READ, cls$pdt_names_and_defaults] array
            [1 .. 3] of clt$parameter_name_descriptor :=
            [['FAMILY_NAME', 1], ['FN', 1], ['STATUS', 2]];

    VAR
      try_family_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ FAMILY_NAME FN }
      [[clc$optional_with_default, ^try_family_dv1], 1, 1, 1, 1,
            clc$value_range_not_allowed, [NIL, clc$name_value, 1,
            osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed,
            clc$status_value]]];

    VAR
      try_family_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) :=
            'nve';

?? POP ??

    VAR
      family: ost$name,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, try_family, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('FAMILY_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    family := value.name.value;

    display (family);
    display (' This command does nothing ' );
  PROCEND dfp$send_test_command;
MODEND dfm$trial_commands;
*DECK DECK=DFM$VERIFY_CLIENT_JOBS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE File Server : Client : Verify Client Jobs', EJECT ??
MODULE dfm$verify_client_jobs;

{ PURPOSE:
{    The purpose of this module is to provide the procedures involved with
{    the verifying client jobs during file server job recovery. This module
{    includes a command processor and an "internal" procedure.

?? NEWTITLE := ' Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfc$loopback_server_mainframe
*copyc dfe$error_condition_codes
*copyc dft$procedure_address_ordinal
*copyc dft$rpc_served_job_list
?? POP ??
*copyc clp$scan_parameter_list
*copyc dfi$display
*copyc dfi$log_display
*copyc dfp$crack_mainframe_id
*copyc dfp$find_mainframe_id
*copyc dfp$send_remote_procedure_call
*copyc dfp$verify_system_administrator
*copyc dfv$file_server_debug_enabled
*copyc i#current_sequence_position
*copyc jmp$job_exists
*copyc jmp$reconcile_leveled_jobs
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pmp$convert_mainframe_to_binary
?? OLDTITLE ??
?? TITLE := '    [XDCL, #GATE] dfp$verify_client_jobs', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$verify_client_jobs
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  pdt verify_jobs_pdt     (
{   mainframe_id, mi: name pmc$mainframe_id_size = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    verify_jobs_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^verify_jobs_pdt_names,
  ^verify_jobs_pdt_params];

  VAR
    verify_jobs_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
  clt$parameter_name_descriptor := [['MAINFRAME_ID', 1], ['MI', 1], ['STATUS', 2]];

  VAR
    verify_jobs_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ MAINFRAME_ID MI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, pmc$mainframe_id_size,
  pmc$mainframe_id_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??


    VAR
      binary_mainframe_id: pmt$binary_mainframe_id,
      mainframe_id: pmt$mainframe_id;

    status.normal := TRUE;

    dfp$verify_system_administrator (' DFP$VERIFY_CLIENT_JOBS', status);
    IF status.normal THEN

      clp$scan_parameter_list (parameter_list, verify_jobs_pdt, status);
      IF status.normal THEN
        dfp$crack_mainframe_id ('MAINFRAME_ID', mainframe_id, binary_mainframe_id, status);
        IF status.normal THEN
          dfp$verify_client_jobs_request (mainframe_id, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND dfp$verify_client_jobs;

?? TITLE := '    [XDCL] dfp$verify_client_jobs_request', EJECT ??
*copyc dfh$verify_client_jobs_request

  PROCEDURE [XDCL] dfp$verify_client_jobs_request
    (    mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      binary_mainframe_id: pmt$binary_mainframe_id,
      display_string: string (80),
      display_length: integer,
      mainframe_found: boolean,
      p_cpu_queue: ^dft$cpu_queue,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_q_interface_directory_entry: ^dft$q_interface_directory_entry,
      queue_entry_index: dft$queue_entry_index,
      queue_index: dft$queue_index;

    status.normal := TRUE;

    dfp$find_mainframe_id (mainframe_id, {server_to_client } FALSE, mainframe_found, p_queue_interface_table,
          p_cpu_queue, queue_index, p_q_interface_directory_entry);
    IF NOT mainframe_found THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$mainframe_not_server, mainframe_id, status);
      RETURN;
    IFEND;

    IF (p_cpu_queue^.queue_header.partner_status.server_state = dfc$recovering) OR
          ((p_cpu_queue^.queue_header.partner_status.server_state = dfc$active) AND
          (NOT p_cpu_queue^.queue_header.partner_status.job_reconcilliation_completed)) THEN
      IF mainframe_id <> dfc$loopback_server_mainframe THEN
        STRINGREP (display_string, display_length, ' ', mainframe_id, ' Reconcile leveled jobs ');
        display (display_string (1, display_length));
        pmp$convert_mainframe_to_binary (mainframe_id, binary_mainframe_id, status);
        jmp$reconcile_leveled_jobs (binary_mainframe_id, status);
        IF NOT status.normal THEN
          display_status (status);
        IFEND;
      IFEND;
    IFEND;

    verify_client_jobs (mainframe_id, status);

    IF ((p_cpu_queue^.queue_header.partner_status.server_state = dfc$active) AND
          (NOT p_cpu_queue^.queue_header.partner_status.job_reconcilliation_completed)) THEN
      p_cpu_queue^.queue_header.partner_status.job_reconcilliation_completed := TRUE;
    IFEND;

  PROCEND dfp$verify_client_jobs_request;
?? TITLE := ' verify_client_jobs ', EJECT ??
  PROCEDURE verify_client_jobs
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT verify_client_jobs;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      allowed_when_server_deactivated: boolean,
      job: ost$non_negative_integers,
      job_exists: boolean,
      local_status: ost$status,
      log_message: string (100),
      log_message_size: integer,
      number_of_jobs_awaiting_rec: ost$non_negative_integers,
      number_of_jobs_on_server: ost$non_negative_integers,
      number_of_jobs_to_remove: ost$non_negative_integers,
      p_served_job_list_header: ^dft$rpc_served_job_list_header,
      p_served_job_list_data_out: ^dft$rpc_served_job_list_data,
      p_served_job_list_data: ^dft$rpc_served_job_list_data,
      p_receive_buffer: dft$p_receive_parameters,
      p_receive_data: dft$p_receive_data,
      p_send_buffer: dft$p_send_parameters,
      p_send_data: dft$p_send_data,
      procedure_ordinal: dft$procedure_address_ordinal,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_buffer_size: dft$send_parameter_size,
      send_data_size: dft$send_data_size,
      server_location: dft$server_location;

    status.normal := TRUE;
    local_status.normal := TRUE;
    number_of_jobs_on_server := 0;
    number_of_jobs_awaiting_rec := 0;
    number_of_jobs_to_remove := 0;

    server_location.server_location_selector := dfc$mainframe_id;
    server_location.server_mainframe := mainframe_name;
    allowed_when_server_deactivated := FALSE;

    dfp$begin_ch_remote_proc_call (server_location, allowed_when_server_deactivated, queue_entry_location,
          p_send_buffer, p_send_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /doit/
    BEGIN

      procedure_ordinal := dfc$get_client_job_list;
      send_buffer_size := 0;
      send_data_size := 0;

      dfp$send_remote_procedure_call (queue_entry_location, procedure_ordinal, send_buffer_size,
            send_data_size, p_receive_buffer, p_receive_data, status);
      IF NOT status.normal THEN
        IF ((status.condition <> dfe$server_request_terminated) AND
              (status.condition <> dfe$server_not_active) AND (status.condition <> dfe$server_has_terminated))
              THEN
          display (' ABNORMAL STATUS FROM dfp$get_client_job_list');
          display_status (status);
        IFEND;
        EXIT /doit/;
      IFEND;

      { Process receive data
      NEXT p_served_job_list_header IN p_receive_data;
      number_of_jobs_on_server := p_served_job_list_header^.number_of_jobs;
      number_of_jobs_awaiting_rec := p_served_job_list_header^.number_of_jobs_awaiting_rec;
      number_of_jobs_to_remove := 0;
      IF number_of_jobs_on_server = 0 THEN
        EXIT /doit/;
      IFEND;

      NEXT p_served_job_list_header IN p_send_data;
      p_served_job_list_header^.number_of_jobs := 0;
      p_served_job_list_header^.number_of_jobs_awaiting_rec := 0;

    /check_jobs/
      FOR job := 1 TO number_of_jobs_on_server DO
        NEXT p_served_job_list_data IN p_receive_data;
        jmp$job_exists (p_served_job_list_data^.system_supplied_job_name,
              $jmt$job_state_set [jmc$initiated_job, jmc$terminating_job], job_exists, status);
        IF NOT status.normal THEN
          display_status (status);
          EXIT /doit/;
        IFEND;

        IF NOT job_exists THEN
          IF dfv$file_server_debug_enabled THEN
            display (p_served_job_list_data^.system_supplied_job_name);
          IFEND;
          NEXT p_served_job_list_data_out IN p_send_data;
          p_served_job_list_data_out^.system_supplied_job_name :=
                p_served_job_list_data^.system_supplied_job_name;
          p_served_job_list_data_out^.client_job_id := p_served_job_list_data^.client_job_id;
          p_served_job_list_header^.number_of_jobs := p_served_job_list_header^.number_of_jobs + 1;
        IFEND;
      FOREND /check_jobs/;

      IF p_served_job_list_header^.number_of_jobs > 0 THEN
        number_of_jobs_to_remove := p_served_job_list_header^.number_of_jobs;
        procedure_ordinal := dfc$remove_unknown_jobs;
        send_data_size := i#current_sequence_position (p_send_data);
        send_buffer_size := 0;
        dfp$send_remote_procedure_call (queue_entry_location, procedure_ordinal, send_buffer_size,
              send_data_size, p_receive_buffer, p_receive_data, status);
        IF NOT status.normal THEN
          IF ((status.condition <> dfe$server_request_terminated) AND
                (status.condition <> dfe$server_not_active) AND
                (status.condition <> dfe$server_has_terminated)) THEN
            display (' ABNORMAL STATUS FROM dfp$verify_client_jobs_request');
            display_status (status);
          IFEND;
          EXIT /doit/;
        IFEND;
        IF dfv$file_server_debug_enabled THEN
          display_integer (' No. of client jobs to be removed from server: ',
                p_served_job_list_header^.number_of_jobs);
        IFEND;
      IFEND;

    END /doit/;

    dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

   STRINGREP (log_message, log_message_size, ' Server ', mainframe_name,
     ' Total_jobs:',  number_of_jobs_on_server,
     '   Awaiting_recovery:', number_of_jobs_awaiting_rec,
     '   Remove:', number_of_jobs_to_remove);
   log_display ($pmt$ascii_logset[pmc$system_log], log_message (1, log_message_size));
   IF dfv$file_server_debug_enabled THEN
     display (log_message (1, log_message_size));
   IFEND;
  PROCEND verify_client_jobs;
MODEND dfm$verify_client_jobs;



*DECK DECK=DFM$WAIT_FOR_UNAVAILABLE_SERVER EXPAND=TRUE
?? RIGHT := 110 ??
MODULE dfm$wait_for_unavailable_server;
 { call osp$wait_on_condition
MODEND dfm$wait_for_unavailable_server;
*DECK DECK=DFP$ACQUIRE_CLIENT_MF_FILE EXPAND=FALSE

  PROCEDURE [XREF] dfp$acquire_client_mf_file
    (    client_mainframe_name: pmt$mainframe_id;
         read_only: boolean;
     VAR lfn: ost$name;
     VAR client_segment_pointer: mmt$segment_pointer;
     VAR p_file: dft$p_mainframe_file;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$client_mainframe_file
*copyc mmt$attribute_keyword
*copyc ost$name
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=DFP$ACTIVATE_CLIENT EXPAND=FALSE

  PROCEDURE [XREF] dfp$activate_client
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

*copyc ost$status
*copyc pmt$mainframe_id
*DECK DECK=DFP$ACTIVATE_PP EXPAND=FALSE
  PROCEDURE [XREF] dfp$activate_pp
  (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
       use_dma_capability: boolean;
   VAR status: ost$status );

*copyc dft$queue_interface_directory
*copyc ost$status
*DECK DECK=DFP$ACTIVATE_SERVER EXPAND=FALSE
  PROCEDURE [XREF] dfp$activate_server
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

*copyc pmt$mainframe_id
*copyc ost$status
*DECK DECK=DFP$ACTIVE_QUEUE_EXISTS EXPAND=FALSE
{
{  This procedure determines whether an active queue exists in the
{  specified queue interface table.
{

  FUNCTION [INLINE] dfp$active_queue_exists
    (p_queue_interface_table: dft$p_queue_interface_table): boolean;

    VAR
      queue_index: dft$queue_index;

    dfp$active_queue_exists := FALSE;

  /check_for_active_queue/
    FOR queue_index := 1 TO p_queue_interface_table^.queue_directory.number_of_queues DO
      IF p_queue_interface_table^.queue_directory.driver_queue_rma_directory [queue_index].
        driver_queue_rma > 0 THEN
          IF NOT p_queue_interface_table^.queue_directory.driver_queue_pva_directory
               [queue_index].p_driver_queue^.queue_header.flags.idle THEN
            dfp$active_queue_exists := TRUE;
            RETURN;
         IFEND;
      IFEND;
    FOREND /check_for_active_queue/;

  FUNCEND dfp$active_queue_exists;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dft$queue_index
?? POP ??

*DECK DECK=DFP$ANY_ESM_DEFINED EXPAND=FALSE
  FUNCTION [XREF] dfp$any_esm_defined: boolean;

*DECK DECK=DFP$ANY_SDP_DEFINED EXPAND=FALSE
  PROCEDURE [XREF] dfp$any_sdp_defined
    (VAR any_sdp_defined: boolean);

*DECK DECK=DFP$ASSIGN_ENTRY EXPAND=FALSE
  PROCEDURE [INLINE] dfp$assign_entry (starting_position: integer;
        number_of_characters: integer;
    VAR entry_assignment_string {input, output} : string ( * <= dfc$queue_assignment_strng_size);
    VAR entry_assignment: integer);

{
{    This procedure scans the input string for a free entry (one whose value is
{ dfc$free_entry_char), and if a free entry is
{ found sets the found entry in the entry assignment string to be assigned
{ (dfc$assigned_entry_char).
{    The input string must be aligned 0 MOD 8, and the size must be an even number
{ of words. The string will only be scanned from the starting position
{ for number_of_characters.
{ If no free entry is found, zero is returned.
{
    TYPE
      char_set = set of char;

    CONST
      swap_successful = 0;

    VAR
      actual_word: string (8),
      char_index_in_word: integer,
      found_word: string (8),
      found_word_starting_char: integer,
      free_char_set: char_set,
      p_test: ^string (8),
      result: 0 .. 2,
      scan_found_free: boolean,
      swap_in_word: string (8),
      word_index: integer;

    free_char_set := $char_set [dfc$free_entry_char];

  /locate_entry/
    REPEAT
      #SPOIL (entry_assignment_string);
      #scan (free_char_set, entry_assignment_string (starting_position, number_of_characters),
            entry_assignment, scan_found_free);
      IF scan_found_free THEN
        entry_assignment := starting_position + entry_assignment - 1;
      ELSE
        entry_assignment := 0;
        RETURN;
      IFEND;
      found_word_starting_char := ((entry_assignment - 1) DIV 8) * 8 + 1;
      #SPOIL (entry_assignment_string);
      { Required due to cybil bug.
      p_test := ^entry_assignment_string (found_word_starting_char, 8);
      #SPOIL (p_test^);
      osp$fetch_locked_string (p_test^, found_word);
      swap_in_word := found_word;
      word_index := (entry_assignment MOD 8);
      IF word_index = 0 THEN
        word_index := 8;
      IFEND;
      found_word (word_index) := dfc$free_entry_char;
      swap_in_word (word_index) := dfc$assigned_entry_char;
      #SPOIL (entry_assignment_string);
      #SPOIL (p_test^);
      #compare_swap (p_test^, found_word, swap_in_word, actual_word, result);
      #SPOIL (p_test^);
      #SPOIL (entry_assignment_string);
    UNTIL result = swap_successful;
  PROCEND dfp$assign_entry;
?? PUSH (LISTEXT := ON) ??
*copyc dft$entry_type
*copyc dft$cpu_queue
*copyc osp$fetch_locked_string
?? POP ??


*DECK DECK=DFP$ASSIGN_QUEUE_ENTRY EXPAND=FALSE
  PROCEDURE [XREF] dfp$assign_queue_entry
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_type: dft$queue_entry_type;
     VAR queue_entry_index: dft$queue_entry_index;
     VAR assign_status: dft$assign_queue_entry_status);
?? PUSH (LISTEXT := ON) ??
*copyc dft$queue_entry_type
*copyc dfd$driver_queue_types
*copyc dft$queue_index
*copyc dft$assign_queue_entry_status
?? POP ??

*DECK DECK=DFP$ASSIGN_TASK_QUEUE_ENTRY EXPAND=FALSE
*DECK DECK=DFP$ASSIGN_TERMINATED_GFN EXPAND=FALSE
  PROCEDURE [INLINE] dfp$assign_terminated_gfn
    (    complemented_gfn: ost$binary_unique_name;
     VAR terminated_gfn: ost$binary_unique_name);

    terminated_gfn := complemented_gfn;
    terminated_gfn.serial_number := UPPERVALUE(terminated_gfn.serial_number);
    terminated_gfn.model_number := UPPERVALUE(terminated_gfn.model_number);
  PROCEND dfp$assign_terminated_gfn;
?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
?? POP ??

*DECK DECK=DFP$ATTACH_APPLICATION_LIBRARY EXPAND=FALSE
  PROCEDURE [XREF] dfp$attach_application_library
    (    p_cpu_queue: ^dft$cpu_queue);

?? PUSH (LISTEXT := ON) ??
*copyc dft$cpu_queue
?? POP ??
*DECK DECK=DFP$AWAIT_ALL_QUEUE_ENTRYS_FREE EXPAND=FALSE

  PROCEDURE [XREF] dfp$await_all_queue_entrys_free
    (    p_cpu_queue: ^dft$cpu_queue;
         maximum_time_milliseconds: 0 .. 0ffffffffffff(16);
     VAR all_queue_entries_free: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dft$cpu_queue
?? POP ??
*DECK DECK=DFP$AWAIT_CORE_SUBSYSTEM_ACTION EXPAND=FALSE

  PROCEDURE [INLINE] dfp$await_core_subsystem_action
    (    p_driver_queue_entry: ^dft$driver_queue_entry);

    VAR
      ignore_status: ost$status;

    REPEAT
      #SPOIL (p_driver_queue_entry^);
      pmp$cycle (ignore_status);
      #SPOIL (p_driver_queue_entry^);
    UNTIL p_driver_queue_entry^.flags.subsystem_action;

  PROCEND dfp$await_core_subsystem_action;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc pmp$cycle
*copyc ost$status
?? POP ??
*DECK DECK=DFP$AWAIT_SERVER_SUBSYSTEM EXPAND=FALSE

  PROCEDURE [INLINE] dfp$await_server_subsystem
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         p_driver_queue_entry: ^dft$driver_queue_entry);

    CONST
      { Time in milliseconds
      requested_time = 1000,
      expected_time = 100;

    VAR
      p_server_state: ^dft$server_state,
      status: ost$status;

    p_server_state := ^p_queue_interface_table^.queue_directory.
          cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header.
          partner_status.server_state;

    REPEAT
      #SPOIL (p_driver_queue_entry^);
      pmp$wait (requested_time, expected_time);
      #SPOIL (p_driver_queue_entry^);
      #SPOIL (p_server_state^);
    UNTIL (p_driver_queue_entry^.flags.subsystem_action) OR
          (p_server_state^ = dfc$terminated);

    IF (p_server_state^ = dfc$terminated) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_active, '',
            status);
      pmp$abort (status);
      RETURN;
    IFEND;

  PROCEND dfp$await_server_subsystem;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc dft$queue_index
*copyc pmp$abort
*copyc pmp$wait
*copyc osp$set_status_abnormal
?? POP ??
*DECK DECK=DFP$AWAIT_SUBSYSTEM_ACTION EXPAND=FALSE
  PROCEDURE [INLINE] dfp$await_subsystem_action
    (    p_driver_queue_entry: ^dft$driver_queue_entry);

    CONST
      { Time in milliseconds
      expected_time =  100;

    REPEAT
      #SPOIL (p_driver_queue_entry^);
      syp$wait (expected_time);
      #SPOIL (p_driver_queue_entry^);
    UNTIL p_driver_queue_entry^.flags.subsystem_action;

  PROCEND dfp$await_subsystem_action;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dft$queue_index
*copyc syp$wait
?? POP ??
*DECK DECK=DFP$BEGIN_CH_REMOTE_PROC_CALL EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc dfv$ch_queue_entry_location

{ PURPOSE:
{   This procedure is a cleanup routine to clear the assignment of a task services queue_entry if a task
{   aborts with a queue_entry assigned to it.  The queue_entry must be clear before the task can safely exit.
{   This procedure is called by the condition handler defined by the user, and which is contained in the
{   procedure which must handle unexpected conditions.

    PROCEDURE dfp$ch_cleanup;

      VAR
        ignore_status: ost$status;

{ If this task is terminating (or encountered something unexpected), release the queue_entry assignment if it
{ is assigned.

      IF dfv$ch_queue_entry_location <> 1 THEN
        dfp$end_remote_procedure_call (dfv$ch_queue_entry_location, ignore_status);
        dfv$ch_queue_entry_location := 1;
        #SPOIL (dfv$ch_queue_entry_location);
      IFEND;

    PROCEND dfp$ch_cleanup;
?? POP ??

    PROCEDURE [INLINE] dfp$begin_ch_remote_proc_call
      (    server_location: dft$server_location;
           allowed_when_server_deactivated: boolean;
       VAR queue_entry_location: dft$rpc_queue_entry_location;
       VAR p_send_to_server_params: dft$p_send_parameters;
       VAR p_send_data: dft$p_send_data;
       VAR status: ost$status);

{ NOTE: A condition handler with the name DFP$REMOTE_PROCEDURE_CALL_CH must be defined in the procedure which
{ declares this procedure (DFP$BEGIN_CH_REMOTE_PROC_CALL).  The condition handler must make a call to the
{ nested procedure DFP$CH_CLEANUP (declared as part of this common deck).  The following is an example of the
{ condition handler:
{
{   PROCEDURE dfp$remote_procedure_call_ch
{     (    condition: pmt$condition;
{          condition_descriptor: ^pmt$condition_information;
{          save_area: ^ost$stack_frame_save_area;
{      VAR handler_status: ost$status);
{
{     dfp$ch_cleanup;
{     EXIT <procedure declaring this condition handler>;
{
{   PROCEND dfp$remote_procedure_call_ch;

?? PUSH (LISTEXT := ON) ??

      status.normal := TRUE;
      dfv$ch_queue_entry_location := 1; {Real entry can never be 1, since it is reserved for the poll task}
      #SPOIL (dfv$ch_queue_entry_location);
      osp$establish_condition_handler (^dfp$remote_procedure_call_ch, TRUE);
      dfp$begin_remote_procedure_call (server_location, allowed_when_server_deactivated, queue_entry_location,
            p_send_to_server_params, p_send_data, status);
      IF NOT status.normal THEN
        osp$disestablish_cond_handler;
      ELSE
        #SPOIL (dfv$ch_queue_entry_location);
        dfv$ch_queue_entry_location := queue_entry_location;
        #SPOIL (dfv$ch_queue_entry_location);
      IFEND;

    PROCEND dfp$begin_ch_remote_proc_call;

*copyc dfp$begin_remote_procedure_call
*copyc dft$rpc_parameters
*copyc dft$rpc_queue_entry_location
*copyc dft$server_location
*copyc dft$server_location_selector
*copyc osp$establish_condition_handler
*copyc osp$disestablish_cond_handler
*copyc ost$status
?? POP ??
*DECK DECK=DFP$BEGIN_REMOTE_CORE_CALL EXPAND=FALSE

   PROCEDURE [XREF] dfp$begin_remote_core_call
    (    server_location: dft$served_family_table_index;
         allowed_when_server_deactivated: boolean;
     VAR queue_entry_location: dft$rpc_queue_entry_location;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dft$rpc_parameters
*copyc dft$rpc_queue_entry_location
*copyc dft$server_location
*copyc dft$server_location_selector
*copyc ost$status
?? POP ??

*DECK DECK=DFP$BEGIN_REMOTE_PROCEDURE_CALL EXPAND=FALSE
  PROCEDURE [XREF] dfp$begin_remote_procedure_call
    (    server_location: dft$server_location;
         allowed_when_server_deactivated: boolean;
     VAR queue_entry_location: dft$rpc_queue_entry_location;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR p_send_data: dft$p_send_data;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dft$rpc_parameters
*copyc dft$rpc_queue_entry_location
*copyc dft$server_location
*copyc dft$server_location_selector
*copyc ost$status
?? POP ??
*DECK DECK=DFP$BUILD_CLIENT_MF_FILE_NAME EXPAND=FALSE
 PROCEDURE [INLINE] dfp$build_client_mf_file_name (
    mainframe_id: pmt$mainframe_id;
   VAR client_mainframe_name : ost$name);

   var
    length: integer;

    client_mainframe_name := ' ';
    STRINGREP (client_mainframe_name, length, 'DFF$',  mainframe_id (9, *),
       '_MAINFRAME_FILE');

  PROCEND;
?? PUSH (LISTEXT := ON) ??
*copyc pmt$mainframe_id
*copyc ost$name
?? POP ??
*DECK DECK=DFP$BUILD_IMAGE_FILE_NAME EXPAND=FALSE
  PROCEDURE [INLINE] dfp$build_image_file_name
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR server_image_file_name: ost$name);

    VAR
      local_status: ost$status,
      mainframe_name: pmt$mainframe_id;

    pmp$convert_binary_mainframe_id (server_mainframe_id, mainframe_name,
          local_status);

    server_image_file_name :=
          'DFF$system_mmmm_ssss_IMAGE';
    server_image_file_name (4, pmc$mainframe_id_size) := mainframe_name;
  PROCEND dfp$build_image_file_name;
?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc pmp$convert_binary_mainframe_id
*copyc pmt$binary_mainframe_id
?? POP ??


*DECK DECK=DFP$CALL_REMOTE_PROCEDURE EXPAND=FALSE

  PROCEDURE [XREF] dfp$call_remote_procedure
    (    server_location: dft$server_location;
         application_name: ost$name;
         procedure_name: pmt$program_name;
         send_parameters: ^SEQ ( * ); {max size = dfc$maximum_user_buffer_area
         send_data: ^SEQ ( * ); {max size = dfc$maximum_user_data_area
     VAR receive_parameters_size: 0 .. dfc$maximum_user_buffer_area;
     VAR receive_parameters: ^SEQ ( * ); {max size = dfc$maximum_user_buffer_area
     VAR receive_data_size: 0 .. dfc$maximum_user_data_area;
     VAR receive_data: ^SEQ ( * ); {max_size = dfc$maximum_user_data_area
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dft$server_location
*copyc dft$rpc_parameters
*copyc ost$name
*copyc ost$status
*copyc pme$insufficient_privilege
*copyc pmt$program_name
?? POP ??
*DECK DECK=DFP$CHANGE_FAMILY_SERVER_STATE EXPAND=FALSE

  PROCEDURE [XREF] dfp$change_family_server_state
    (    new_state: dft$server_state;
         mainframe_id: pmt$binary_mainframe_id);

*copyc dft$server_state
*copyc pmt$binary_mainframe_id
*DECK DECK=DFP$CHANGE_FAMILY_VERIFICATION EXPAND=FALSE


  PROCEDURE [XREF] dfp$change_family_verification
    (    family: ost$name;
         mainframe_id: pmt$binary_mainframe_id;
         family_access: dft$family_access;
         verified_by_server: boolean;
         server_lifetime: dft$server_lifetime;
         server_birthdate: integer;
         current_server_state: dft$server_state;
     VAR verification_changed: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dft$family_access
*copyc dft$server_lifetime
*copyc dft$server_state
*copyc ost$name
*copyc ost$status
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=DFP$CHANGE_JOB_LEVELER_STATE EXPAND=FALSE

  PROCEDURE [XREF] dfp$change_job_leveler_state;
*DECK DECK=DFP$CHANGE_PP EXPAND=FALSE
  PROCEDURE [XREF] dfp$change_pp
    (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
         new_name: cmt$element_name;
         pp_task: ost$name;
     VAR status: ost$status );

*copyc cmt$element_name
*copyc dft$queue_interface_directory
*copyc ost$status
*DECK DECK=DFP$CHECK_IF_PP_ACTIVE EXPAND=FALSE
*DECK DECK=DFP$CHECK_IF_VALID EXPAND=FALSE

  PROCEDURE [XREF] dfp$check_if_valid
    (    connection_parameters: dft$connection_parameters;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$connection_parameters
*copyc ost$status
?? POP ??
*DECK DECK=DFP$CHECK_JOB_RECOVERY EXPAND=FALSE
  PROCEDURE [XREF] dfp$check_job_recovery
    (VAR recovery_occurred: boolean);


*DECK DECK=DFP$CHECK_JOB_SERVER EXPAND=FALSE
  PROCEDURE [XREF] dfp$check_job_server
    (    queue_entry_location: dft$rpc_queue_entry_location;
         queue_entry_loc_int: dft$rpc_queue_entry_loc_int;
         user_parameter_size: dft$send_parameter_size;
         job_recovery_request: boolean;
         force_job_reconnection: boolean;
     VAR client_job_id: dft$client_job_id;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_queue_entry_location
*copyc dft$rpc_queue_entry_loc_int
*copyc dft$rpc_parameters
*copyc dft$client_job_id
*copyc ost$status
?? POP ??
*DECK DECK=DFP$CHECK_QUEUE_ENTRY_ASSIGNED EXPAND=TRUE
{
{  This procedure determines the assignment status of the specified entry.
{

 PROCEDURE [INLINE] dfp$check_queue_entry_assigned
    (    entry_index: integer;
     VAR queue_assignment_string {input, output} : string ( * <=  dfc$queue_assignment_strng_size);
     VAR queue_entry_assigned: boolean);

    VAR
      actual_string: string (8),
      entry_word_starting_char: integer,
      word_index: integer;

    entry_word_starting_char := ((entry_index - 1) DIV 8) * 8 + 1;
    word_index := (entry_index MOD 8);
    IF word_index = 0 THEN
      word_index := 8;
    IFEND;

    osp$fetch_locked_string (queue_assignment_string (entry_word_starting_char, 8), actual_string);

    queue_entry_assigned := actual_string (word_index) = dfc$assigned_entry_char;

  PROCEND dfp$check_queue_entry_assigned;

?? PUSH (LISTEXT := ON) ??
*copyc dft$cpu_queue
*copyc dft$entry_type
*copyc osp$fetch_locked_string
?? POP ??
*DECK DECK=DFP$CHECK_SELF_SERVING_JOB EXPAND=FALSE
  PROCEDURE [INLINE] dfp$check_self_serving_job
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR self_serving: boolean);

?? PUSH (LISTEXT := ON) ??

 { This procedure checks that in loopback mode, if the
 { current job is the job with the clone tasks that are
 { servicing the specified  server_mainframe.  The caller
 { of this may desire to not treat the request as server
 { to avoid self serving clone tasks, which causes
 { deadlocks.

    VAR
      client_mainframe_job_name: jmt$user_supplied_name,
      current_job_user_supplied_name: jmt$user_supplied_name,
      current_mainframe_id: pmt$mainframe_id,
      current_system_supplied_name: jmt$system_supplied_name,
      status: ost$status;

    self_serving := FALSE;
    IF (server_mainframe_id.serial_number = dfc$loopback_server_serial) AND
       (server_mainframe_id.model_number = dfc$loopback_server_model) THEN
      { See if this job is the client mainframe job on the server.
      pmp$get_job_names (current_job_user_supplied_name,
            current_system_supplied_name, status);

      pmp$get_mainframe_id (current_mainframe_id, status);

      dfp$get_client_mf_job_name (current_mainframe_id,
            client_mainframe_job_name);

      self_serving := current_job_user_supplied_name =
            client_mainframe_job_name;
    IFEND;
  PROCEND dfp$check_self_serving_job;
*copyc dfc$loopback_server_constants
*copyc dfc$loopback_server_mainframe
*copyc pmp$get_job_names
*copyc pmt$binary_mainframe_id
*copyc pmp$get_mainframe_id
*copyc dfp$get_client_mf_job_name
?? POP ??


*DECK DECK=DFP$CLEAR_DRIVER_FLAGS EXPAND=FALSE
  PROCEDURE [INLINE] dfp$clear_driver_flags
    (    p_driver_queue_entry: ^dft$driver_queue_entry);

    p_driver_queue_entry^.flags := dfv$false_queue_entry_flags;
    p_driver_queue_entry^.error_condition := 0;
    p_driver_queue_entry^.data_descriptor.actual_length := 0;

  PROCEND dfp$clear_driver_flags;

?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfv$false_queue_entry_flags
?? POP ??
*DECK DECK=DFP$CLEAR_FAMILY_QUEUES EXPAND=FALSE

  PROCEDURE [XREF] dfp$clear_family_queues
    (    mainframe_id: pmt$binary_mainframe_id);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=DFP$CLEAR_INHIBIT_ACCESS_WORK EXPAND=FALSE

  PROCEDURE [XREF] dfp$clear_inhibit_access_work
    (    server_mainframe_id: pmt$binary_mainframe_id;
         clear_sdtx: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=DFP$CLEAR_READ_LOCK EXPAND=FALSE
  PROCEDURE [INLINE] dfp$clear_read_lock
    (VAR read_write_lock: {Input, Output} dft$read_write_lock);

    VAR
      already_zero: boolean,
      new_value: integer;

    osp$decrement_locked_variable (read_write_lock.reader_count,
          { Best guess = } 1, new_value, already_zero);
    IF already_zero THEN
      osp$system_error (' SERVER READ LOCK ALREADY ZERO ', NIL);
    IFEND;
    osp$end_system_activity;

  PROCEND dfp$clear_read_lock;
?? PUSH (LISTEXT := ON) ??
*copyc dft$read_write_lock
*copyc osp$decrement_locked_variable
*copyc osp$end_system_activity
*copyc osp$system_error
?? POP ??
*DECK DECK=DFP$CLEAR_SERVER_DRIVER_FLAGS EXPAND=FALSE

  PROCEDURE [INLINE] dfp$clear_server_driver_flags
    (    p_driver_queue_entry: ^dft$driver_queue_entry);

    p_driver_queue_entry^.error_condition := 0;
    p_driver_queue_entry^.data_descriptor.actual_length := 0;
    #spoil (p_driver_queue_entry^);
    p_driver_queue_entry^.flags := dfv$active_queue_entry_flags;
    #spoil (p_driver_queue_entry^);

  PROCEND dfp$clear_server_driver_flags;

?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfv$active_queue_entry_flags
?? POP ??
*DECK DECK=DFP$CLEAR_TASK_INHIBIT_ACCESS EXPAND=FALSE
  PROCEDURE [XREF] dfp$clear_task_inhibit_access
    (    search: tmt$fnx_search_type;
         ijle_p: ^jmt$initiated_job_list_entry;
         ijlo: jmt$ijl_ordinal;
         clear_inhibit_access_work: dft$mainframe_set);
?? PUSH (LISTEXT := ON) ??
*copyc tmt$fnx_search_type
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc dft$mainframe_set
?? POP ??
*DECK DECK=DFP$CLEAR_WRITE_LOCK EXPAND=FALSE
  PROCEDURE [INLINE] dfp$clear_write_lock
    (VAR read_write_lock: {Input, Output} dft$read_write_lock);

    VAR
      already_zero: boolean,
      new_value: integer,
      status: ost$status;

    osp$clear_signature_lock (read_write_lock.write_lock, status);
    IF NOT status.normal THEN
      osp$system_error (' ERROR CLEARING WRITE LOCK ', ^status);
    IFEND;
    osp$decrement_locked_variable (read_write_lock.writer_count,
           { Best guess = } 1, new_value, already_zero);
    IF already_zero THEN
      osp$system_error (' WRITE COUNT ALREADY ZERO', NIL);
    IFEND;
    osp$end_system_activity;
  PROCEND dfp$clear_write_lock;
?? PUSH (LISTEXT := ON) ??
*copyc dft$read_write_lock
*copyc osp$clear_signature_lock
*copyc osp$decrement_locked_variable
*copyc osp$end_system_activity
*copyc osp$system_error
?? POP ??
*DECK DECK=DFP$CLIENT_IO EXPAND=FALSE
{*copyc dfp$client_io

  PROCEDURE [XREF] dfp$client_io (
        server_iocb_p: ^mmt$server_iocb_entry;
        io_type: iot$io_function;
        io_id: mmt$io_identifier;
        buffer_descriptor: mmt$buffer_descriptor;
    VAR client_io_status: mmt$file_server_io_status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$io_function
*copyc mmt$buffer_descriptor
*copyc mmt$file_server_io_status
*copyc mmt$io_identifier
*copyc mmt$server_io_control_block
?? POP ??
*DECK DECK=DFP$CLIENT_MAINFRAMES_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] dfp$client_mainframes_display
    (    file_name: amt$local_file_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ost$status
?? POP ??
*DECK DECK=DFP$COMPLEMENT_GFN EXPAND=FALSE
  PROCEDURE [INLINE] dfp$complement_gfn
    (    gfn: ost$binary_unique_name;
     VAR complemented_gfn: ost$binary_unique_name);

    complemented_gfn := gfn;
    complemented_gfn.year := gfn.year + 15;
    IF gfn.sequence_number = UPPERVALUE (gfn.sequence_number) THEN
      complemented_gfn.sequence_number := LOWERVALUE (gfn.sequence_number);
    ELSE
      complemented_gfn.sequence_number := gfn.sequence_number + 1;
    IFEND;
  PROCEND dfp$complement_gfn;
?? PUSH (LISTEXT := ON) ??
*copyc osd$unique_name
?? POP ??
*DECK DECK=DFP$COMPUTE_CHECKSUM EXPAND=FALSE

  PROCEDURE [XREF] dfp$compute_checksum (checksum_location:
    pft$checksum_location;
    checksum_size: pft$checksum_size;
    VAR checksum: pft$checksum);
?? PUSH (LISTEXT := ON) ??
*copyc PFD$CATALOG
?? POP ??
*DECK DECK=DFP$CONVERT_LIST_POINTER EXPAND=FALSE
  PROCEDURE [INLINE] dfp$convert_list_pointer
    (    p_data_rma_list: dft$p_data_rma_list;
     VAR p_rma_list: ^mmt$rma_list);

    TYPE
      converter = record
        CASE (mm_rma_list, data_rma_list) OF
        = mm_rma_list =
          p_rma_list: ^mmt$rma_list,
        = data_rma_list =
          p_data_rma_list: dft$p_data_rma_list,
        CASEND,
      recend;

    VAR
      converter_variable: converter;

    converter_variable.p_data_rma_list := p_data_rma_list;
    p_rma_list := converter_variable.p_rma_list;

  PROCEND dfp$convert_list_pointer;

?? PUSH (LISTEXT := ON) ??
*copyc dft$cpu_queue
?? POP ??
*DECK DECK=DFP$CONVERT_P_IO_REQUEST_TO_QIT EXPAND=FALSE

  PROCEDURE [INLINE] dfp$convert_p_io_request_to_qit
    (    p_io_request: ^iot$io_request;
     VAR p_queue_interface_table: dft$p_queue_interface_table);

  { This procedure uses a variant record 'trick' to convert a variable of
  { type ^iot$io_request to one of type dft$p_queue_interface_table.

    TYPE
      converter = record
        case (io_request, queue_interface_table) of
        = io_request =
          p_io_request: ^iot$io_request,
        = queue_interface_table =
          p_queue_interface_table: dft$p_queue_interface_table,
        casend,
      recend;

    VAR
      converter_variable: converter;

    converter_variable.p_io_request := p_io_request;
    p_queue_interface_table := converter_variable.p_queue_interface_table;
  PROCEND dfp$convert_p_io_request_to_qit;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc iot$io_request
?? POP ??
*DECK DECK=DFP$CONVERT_P_QIT_TO_IO_REQUEST EXPAND=FALSE
  PROCEDURE [INLINE] dfp$convert_p_qit_to_io_request
    (    p_queue_interface_table: dft$p_queue_interface_table;
     VAR p_io_request: ^iot$io_request);

  { This procedure uses a variant record 'trick' to convert a variable of
  { type dft$p_queue_interface_table  to one of type ^iot$io_request.

    TYPE
      converter = record
        case (io_request, queue_interface_table) of
        = io_request =
          p_io_request: ^iot$io_request,
        = queue_interface_table =
          p_queue_interface_table: dft$p_queue_interface_table,
        casend,
      recend;

    VAR
      converter_variable: converter;

    converter_variable.p_queue_interface_table := p_queue_interface_table;
    p_io_request := converter_variable.p_io_request;
  PROCEND dfp$convert_p_qit_to_io_request;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc iot$io_request
?? POP ??
*DECK DECK=DFP$CONVERT_QUEUE_ENTRY_LOC EXPAND=FALSE

{ DECK dfp$convert_queue_entry_loc

  TYPE
    convert_rpc_q_e_l = record
      case (ext, int) of
      = ext =
        qext: dft$rpc_queue_entry_location,
      = int =
        qint: dft$rpc_queue_entry_loc_int
      casend,
    recend;

  PROCEDURE [INLINE] dfp$convert_qel_int_to_ext
    (    inp: dft$rpc_queue_entry_loc_int;
     VAR out: dft$rpc_queue_entry_location);

    VAR
      conv: convert_rpc_q_e_l;

    conv.qint := inp;
    out := conv.qext;

  PROCEND dfp$convert_qel_int_to_ext;

  PROCEDURE [INLINE] dfp$convert_qel_ext_to_int
    (    inp: dft$rpc_queue_entry_location;
     VAR out: dft$rpc_queue_entry_loc_int);

    VAR
      conv: convert_rpc_q_e_l;

    conv.qext := inp;
    out := conv.qint;

  PROCEND dfp$convert_qel_ext_to_int;

?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_queue_entry_location
*copyc dft$rpc_queue_entry_loc_int
?? POP ??

*DECK DECK=DFP$COUNT_MAINFRAMES_PER_ESM EXPAND=FALSE

  PROCEDURE [XREF] dfp$count_mainframes_per_esm
    (    element_name: cmt$element_name;
     VAR mainframe_count: 0 .. dfc$max_number_of_mainframes);

*copyc cmt$element_name
*copyc dfd$driver_queue_types
*DECK DECK=DFP$CRACK_CLIENT_MF_FILE_NAME EXPAND=FALSE
  PROCEDURE [INLINE] dfp$crack_client_mf_file_name (
      client_mainframe_pf_name: ost$name;
      VAR mainframe_id: pmt$mainframe_id);
  { This procedure is highly coupled with dfp$build_client_mf_file_name
    mainframe_id := '$SYSTEM_';
    mainframe_id (9, *) := client_mainframe_pf_name (5, 9);
  PROCEND;
?? PUSH (LISTEXT := ON) ??
*copyc pmt$mainframe_id
*copyc ost$name
?? POP ??
*DECK DECK=DFP$CRACK_CLIENT_MF_JOB_NAME EXPAND=FALSE
  PROCEDURE [INLINE] dfp$crack_client_mf_job_name
    (VAR client_mainframe: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      binary_mainframe_id: pmt$binary_mainframe_id,
      system_supplied_name: jmt$system_supplied_name,
      user_supplied_name: jmt$user_supplied_name;

    pmp$get_job_names (user_supplied_name, system_supplied_name, status);
    IF status.normal THEN
      IF (user_supplied_name (1, 4) = '$DF$') AND
        (user_supplied_name (21, 11) = '_CLIENT_JOB') THEN
         client_mainframe := user_supplied_name (4, 17);
         pmp$convert_mainframe_to_binary (client_mainframe, binary_mainframe_id,
               status);
         { Might return pme$invalid_mainframe_id
       ELSE
         osp$set_status_condition (pme$invalid_mainframe_id, status);
       IFEND;
    IFEND;
  PROCEND dfp$crack_client_mf_job_name;
?? PUSH (LISTEXT := ON) ??
*copyc osp$set_status_condition
*copyc pmp$convert_mainframe_to_binary
*copyc pmp$get_job_names
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=DFP$CRACK_CONNECTION_PARAMETERS EXPAND=FALSE
*DECK DECK=DFP$CRACK_MAINFRAME_ID EXPAND=FALSE

  PROCEDURE [XREF] dfp$crack_mainframe_id
    (    parameter_name: string ( * );
     VAR mainframe_id: pmt$mainframe_id;
     VAR binary_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

 ?? PUSH (LISTEXT := ON) ??
*copyc pmt$mainframe_id
*copyc pmt$binary_mainframe_id
*copyc ost$status
?? POP ??
*DECK DECK=DFP$CREATE_IMAGE_FILE EXPAND=FALSE
  PROCEDURE [XREF] dfp$create_image_file
    (    server_mainframe_id: pmt$binary_mainframe_id;
         preallocated_size: ost$segment_length;
     VAR image_file_already_exists: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=DFP$CREATE_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] dfp$create_queue
    (    connection_parameters: dft$connection_parameters;
         destination_mainframe_name: pmt$mainframe_id;
         destination_mainframe_id: pmt$binary_mainframe_id;
         server_to_client: boolean;
     VAR p_queue_interface_table: dft$p_queue_interface_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dft$connection_parameters
*copyc ost$status
*copyc pmt$binary_mainframe_id
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=DFP$CURRENT_RQ_BUFFER_OUT_INDEX EXPAND=FALSE

  FUNCTION [INLINE] dfp$current_rq_buffer_out_index
    (    p_queue_interface_table: dft$p_queue_interface_table): integer;

     dfp$current_rq_buffer_out_index := p_queue_interface_table^.request_buffer_directory.out;

   FUNCEND dfp$current_rq_buffer_out_index;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
?? POP ??
*DECK DECK=DFP$DEACTIVATE_CLIENT EXPAND=FALSE

  PROCEDURE [XREF] dfp$deactivate_client
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

*copyc ost$status
*copyc pmt$mainframe_id
*DECK DECK=DFP$DEACTIVATE_SERVER EXPAND=FALSE

  PROCEDURE [XREF] dfp$deactivate_server
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

*copyc pmt$mainframe_id
*copyc ost$status
*DECK DECK=DFP$DEACTIVATE_SERVER_FILES EXPAND=FALSE

  PROCEDURE [XREF] dfp$deactivate_server_files
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=DFP$DELETE_CLIENT EXPAND=FALSE

  PROCEDURE [XREF] dfp$delete_client
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

*copyc ost$status
*copyc pmt$mainframe_id
*DECK DECK=DFP$DELETE_CLIENT_MAINFRAMES EXPAND=FALSE
 PROCEDURE [XREF] dfp$delete_client_mainframes;
*DECK DECK=DFP$DELETE_CLIENT_RPC_SEGMENT EXPAND=FALSE
 PROCEDURE [XREF] dfp$delete_client_rpc_segment;
*DECK DECK=DFP$DELETE_FAMILY_IF_LAST EXPAND=FALSE
  PROCEDURE [XREF] dfp$delete_family_if_last
    (    family_name: ost$family_name);

*copyc ost$user_identification
*DECK DECK=DFP$DELETE_SERVER EXPAND=FALSE

  PROCEDURE [XREF] dfp$delete_server
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

*copyc pmt$mainframe_id
*copyc ost$status
*DECK DECK=DFP$DELETE_SERVER_RPC_SEGMENT EXPAND=FALSE

PROCEDURE [XREF] dfp$delete_server_rpc_segment;

*DECK DECK=DFP$DELETE_TABLES_OF_PARTNER EXPAND=FALSE
  PROCEDURE [XREF] dfp$delete_tables_of_partner
    (    mainframe_name: pmt$mainframe_id;
         host_is_server_to_client: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=DFP$DETERMINE_ACTION_FOR_SERVER EXPAND=FALSE
  PROCEDURE [INLINE] dfp$determine_action_for_server
    (    p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry;
     VAR action_for_server: dft$action_for_server);

{  This procedure enforces one aspect of File Server protocol. That aspect is
{  to determine what action is to be performed by the server side task who's
{  queue entry has been processed by the driver, and to update the queue
{  entry's transaction_count and retransmission_count fields as per protocol.
{
{  The driver, after completing I/O for a server to client queue type, will
{  determine if the server task must be activated to perform some action.
{  The driver will signal that the server task must be activated when it has
{  completed one of the following I/O operations for a server to client queue
{  entry -
{    a. received a command buffer (stored in queue entry's receive_buffer).
{    b. processed a send_ready_for_data command (receive to page data buffers).
{    c. processed a send_data command (sent from page data buffers).
{  The signal from the driver is in the form of a one word pp response, which
{  is detected by procedure iop$process_io_completions and processed by
{  dfp$process_server_response. The one word pp response consists of a queue
{  index and queue entry index which together identify the server side queue
{  entry in question.
{
{  By comparing the transaction_count and retransmission_count in the cpu queue
{  entry with those in the last received command header (in receive buffer) and
{  by testing the driver queue entry flag driver_error_alert, this procedure
{  determines what processing the server side task is expected to perform.
{
{      DFP$DETERMINE_ACTION_FOR_SERVER (P_CPU_QUEUE_ENTRY,
{           P_DRIVER_QUEUE_ENTRY,  ACTION_FOR_SERVER)
{
{  P_CPU_QUEUE_ENTRY: (input) Pointer to the cpu queue entry.
{
{  P_DRIVER_QUEUE_ENTRY: (input) Pointer to the driver queue entry.
{
{  ACTION_FOR_SERVER: (output) This parameter is an ordinal which indicates
{       the type of processing to be performed for the queue entry.
{     DFC$NEW_REQUEST - Begin new transaction, server must process new request.
{
{     DFC$RETRANSMITTED_REQUEST - Same request as in previous transaction,
{          Server must send the request response to client again.
{
{     DFC$COMPLETE_REQUEST - The driver has completed input or output of page
{          data. Server must take appropriate action on wired page buffers.
{
{     DFC$COMPLETE_REQUEST_ON_ERROR - The driver was unable to perform the
{          the command specified by the server and the command involved page
{          data. Server must take appropriate action on wired page buffers.
{
{     DFC$TRANSACTION_OUT_OF_SEQUENCE - The transaction_count in the received
{          buffer_header is less than or more than one greater than that in
{          the cpu queue entry.


    VAR
      p_buffer_header: ^dft$buffer_header;

    { Determine reason for pp response to server side.
    IF p_driver_queue_entry^.flags.driver_error_alert THEN
      { The driver encounted an error while reading page data (processing
      { send_ready_for_data),or while writing the server's response and page
      { data (send_command and send_data).
      { Server must complete processing of request.
      { Errors detected when page data is not involved are processed in
      { dfp$process_server_response.
      action_for_server := dfc$complete_request_on_error;
    ELSE
      RESET p_cpu_queue_entry^.p_receive_buffer;
      NEXT p_buffer_header IN p_cpu_queue_entry^.p_receive_buffer;

      IF p_cpu_queue_entry^.transaction_count =
            p_buffer_header^.transaction_count THEN
        { This is not a new transaction from the client.
        IF p_cpu_queue_entry^.retransmission_count =
              p_buffer_header^.retransmission_count THEN
          { The driver's response is to signal server to perform request
          { completion processing.
          { The driver has input page data (processed send_ready_for_data), or
          { has output response and page data (processed send_command and
          { send_data).
          { Server must complete processing of request.
          action_for_server := dfc$complete_request;
        ELSE
          { This is the same request received and processed earlier. The client
          { has retransmitted the request because it did not receive the
          { server's response.
          { The retransmission_count in the buffer_header is copied to cpu
          { queue.
          action_for_server := dfc$retransmitted_request;
          p_cpu_queue_entry^.retransmission_count :=
                p_buffer_header^.retransmission_count;
        IFEND;

      ELSEIF p_cpu_queue_entry^.transaction_count + 1 =
            p_buffer_header^.transaction_count THEN
        { The transaction_count received for this request is one greater than
        { that of the previous request.
        { This condition indicates the start of a new transaction.
        { Server must execute new request from client.
        { The cpu queue entry transaction_count is incremented by one.
        { The retransmission_count in the buffer_header is copied to cpu queue.
        action_for_server := dfc$new_request;
        p_cpu_queue_entry^.retransmission_count :=
              p_buffer_header^.retransmission_count;
        p_cpu_queue_entry^.transaction_count :=
              p_buffer_header^.transaction_count;
      ELSE
        { The transaction_count received for this request is less than or
        { greater than that expected. This is an abnormal condition.
        action_for_server := dfc$transaction_out_of_sequence;
      IFEND;
    IFEND;

  PROCEND dfp$determine_action_for_server;

?? PUSH (LISTEXT := ON) ??
*copyc dfd$request_package
*copyc dft$action_for_server
*copyc dft$cpu_queue
*copyc dfd$driver_queue_types
?? POP ??




*DECK DECK=DFP$DETERMINE_CLIENT_STATUS EXPAND=FALSE
  PROCEDURE [XREF] dfp$determine_client_status
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

*copyc ost$status
*copyc pmt$mainframe_id
*DECK DECK=DFP$DISCARD_CLIENT_JOBS EXPAND=FALSE

  PROCEDURE [XREF] dfp$discard_client_jobs
    (    mainframe_id: pmt$mainframe_id;
         new_state: dft$server_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$server_state
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=DFP$DISCARD_SERVER_PAGES EXPAND=FALSE

*DECK DECK=DFP$DISPLAY EXPAND=FALSE
  PROCEDURE [XREF] dfp$display
    (    s: string (* <= 125);
     VAR display_identifier: dft$display_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc dft$display_identifier
?? POP ??
*DECK DECK=DFP$DISPLAY_CLIENT EXPAND=FALSE

  PROCEDURE [XREF] dfp$display_client
    (    mainframe_name: pmt$mainframe_id;
         output_file_fid: amt$file_identifier;
         page_width: amt$page_width;
     VAR status: ost$status);

*copyc amt$file_identifier
*copyc amt$page_width
*copyc ost$status
*copyc pmt$mainframe_id
*DECK DECK=DFP$DISPLAY_CLIENT_JOBS EXPAND=FALSE
  PROCEDURE [XREF] dfp$display_client_jobs
    (    p_client_mainframe_file: dft$p_mainframe_file;
     VAR display_identifier: dft$display_identifier;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc dft$display_identifier
*copyc dft$client_mainframe_file
*copyc ost$status
?? POP ??
*DECK DECK=DFP$DISPLAY_CLIENT_MAINFRAMES EXPAND=FALSE
   PROCEDURE [XREF] dfp$display_client_mainframes
    (VAR display_identifier: dft$display_identifier;
     VAR message_written: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$display_identifier
*copyc ost$status
?? POP ??


*DECK DECK=DFP$DISPLAY_QUEUES EXPAND=FALSE
  PROCEDURE [XREF] dfp$display_queues
    (VAR display_identifier: dft$display_identifier;
     VAR message_written: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$display_identifier
*copyc ost$status
?? POP ??
*DECK DECK=DFP$DISPLAY_SERVED_FAMILY_TABLE EXPAND=FALSE
 PROCEDURE [XREF] DFP$DISPLAY_SERVED_FAMILY_TABLE
   (VAR display_identifier: dft$display_identifier;
    VAR message_written: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc dft$display_identifier
?? POP ??
*DECK DECK=DFP$DISPLAY_SERVER EXPAND=FALSE

  PROCEDURE [XREF] dfp$display_server
    (    mainframe_name: pmt$mainframe_id;
         output_file_fid: amt$file_identifier;
         page_width: amt$page_width;
     VAR status: ost$status);

*copyc amt$file_identifier
*copyc amt$page_width
*copyc pmt$mainframe_id
*copyc ost$status
*DECK DECK=DFP$DISPLAY_STORNET_CONNECTION EXPAND=FALSE
  PROCEDURE [XREF] dfp$display_stornet_connection
    (    element_name: cmt$element_name;
         output_file_fid: amt$file_identifier;
         page_width: amt$page_width;
     VAR status: ost$status);

*copyc amt$file_identifier
*copyc amt$page_width
*copyc cmt$element_name
*copyc ost$status
*DECK DECK=DFP$END_CH_REMOTE_PROC_CALL EXPAND=FALSE
*copyc dfv$ch_queue_entry_location

    PROCEDURE [INLINE] dfp$end_ch_remote_proc_call
      (    queue_entry_location: dft$rpc_queue_entry_location;
       VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
      status.normal := TRUE;
      dfp$end_remote_procedure_call (queue_entry_location, status);
      dfv$ch_queue_entry_location := 1;
      #SPOIL (dfv$ch_queue_entry_location);
      osp$disestablish_cond_handler;

    PROCEND dfp$end_ch_remote_proc_call;

*copyc dfp$end_remote_procedure_call
*copyc dft$rpc_queue_entry_location
*copyc osp$disestablish_cond_handler
*copyc ost$status
?? POP ??
*DECK DECK=DFP$END_REMOTE_CORE_CALL EXPAND=FALSE
   PROCEDURE [XREF] dfp$end_remote_core_call
    (    queue_entry_location: dft$rpc_queue_entry_location;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_queue_entry_location
*copyc ost$status
?? POP ??
*DECK DECK=DFP$END_REMOTE_PROCEDURE_CALL EXPAND=FALSE
  PROCEDURE [XREF] dfp$end_remote_procedure_call
    (    queue_entry_location: dft$rpc_queue_entry_location;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dft$rpc_queue_entry_location
*copyc ost$status
?? POP ??
*DECK DECK=DFP$ESTABLISH_CLONE_TASK_STABLE EXPAND=FALSE
  PROCEDURE [XREF] dfp$establish_clone_task_stable
    (    mainframe_name: pmt$mainframe_id;
         number_of_monitor_queue_entries: 0 .. dfc$max_queue_entries;
         number_of_task_queue_entries: dft$queue_entry_index;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc dft$queue_index
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=DFP$EXECUTE_GET_APP_INFO EXPAND=FALSE
  PROCEDURE [XREF] dfp$execute_get_app_info
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??

*DECK DECK=DFP$EXECUTE_STATE_CHANGE_TASK EXPAND=FALSE
  PROCEDURE [XREF] dfp$execute_state_change_task
    (    mainframe_name: pmt$mainframe_id;
         partner_is_server: boolean;
         old_state: dft$server_state;
         new_state: dft$server_state;
         wait: ost$wait;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$mainframe_id
*copyc dft$server_state
*copyc ost$wait
*copyc ost$status
?? POP ??
*DECK DECK=DFP$EXPAND_IMAGE_FILE EXPAND=FALSE
{
{  The purpose of this procedure is to preallocate additional space into
{ the server image file if the current highest written address (eoi) is
{ getting close to the current preallocaetd space.
{ If space cannot be obtained then an error condition of
{ dfe$no_space_for_server_pages is returned.
{ This procedure does not change the image file in any way.

  PROCEDURE [INLINE] dfp$expand_image_file
    (VAR image_file_id: dft$image_file_id;
     VAR status: ost$status);

    CONST
      dfc$preallocate_page_count = 20;

    status.normal := TRUE;
    IF image_file_id.allocated_size < (#OFFSET (image_file_id.p_current_eoi) +
          (2 * osv$page_size)) THEN
      mmp$os_preallocate_file_space (image_file_id.p_image_file,
            (#OFFSET (image_file_id.p_current_eoi) +
            (dfc$preallocate_page_count * osv$page_size)),  {wait secs} 60, status);
      IF status.normal THEN
        image_file_id.allocated_size := #OFFSET (image_file_id.p_current_eoi) +
              (dfc$preallocate_page_count * osv$page_size);
      ELSE
        osp$set_status_abnormal (dfc$file_server_id,
              dfe$no_space_for_server_pages, image_file_id.p_image_header^.
              server_mainframe_name, status);
        CASE image_file_id.operation OF
        = dfc$image_source_timeout =
          osp$append_status_parameter (osc$status_parameter_delimiter,
                ' Pages will remain in memory until server activation. IF ' CAT
                'a terminate_system occurs the server will be terminated.',
                status);
        = dfc$image_source_deadstart =
          osp$append_status_parameter (osc$status_parameter_delimiter,
                ' Recovery of the server will NOT be possible.', status);
        ELSE
        CASEND;
        RETURN;
      IFEND;
    IFEND;
  PROCEND dfp$expand_image_file;
?? PUSH (LISTEXT := ON) ??
*copyc dft$image_file_id
*copyc i#build_adaptable_seq_pointer
*copyc mmp$os_preallocate_file_space
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc dfe$error_condition_codes
*copyc ost$status
*copyc osv$page_size
?? POP ??
*DECK DECK=DFP$EXTRACT_CLIENT_JOB_ID EXPAND=FALSE
  PROCEDURE [INLINE] dfp$extract_client_job_id
    (    queue_entry_location: dft$rpc_queue_entry_location;
     VAR client_job_id: dft$client_job_id);

    VAR
      p_queue_interface_table: dft$p_queue_interface_table,
      p_rpc_buffer_header: ^dft$rpc_buffer_header,
      p_send_buffer: dft$p_command_buffer,
      p_send_buffer_header: ^dft$buffer_header,
      queue_entry_loc_int: dft$rpc_queue_entry_loc_int;

    dfp$convert_qel_ext_to_int (queue_entry_location, queue_entry_loc_int);
    dfp$get_qit_p_from_direct_index (queue_entry_loc_int.queue_directory_index,
          p_queue_interface_table);
    p_send_buffer := p_queue_interface_table^.queue_directory.
          cpu_queue_pva_directory [queue_entry_loc_int.queue_index].
          p_cpu_queue^.queue_entries [queue_entry_loc_int.queue_entry_index].
          p_send_buffer;

    RESET p_send_buffer;
    NEXT p_send_buffer_header IN p_send_buffer;
    NEXT p_rpc_buffer_header IN p_send_buffer;
    client_job_id := p_rpc_buffer_header^.client_job_id;
  PROCEND dfp$extract_client_job_id;

?? PUSH (LISTEXT := ON) ??
*copyc dfp$convert_queue_entry_loc
*copyc dfp$get_qit_p_from_direct_index
*copyc dft$cpu_queue
*copyc dft$rpc_queue_entry_location
*copyc dft$rpc_queue_entry_loc_int
*copyc dfd$driver_queue_types
*copyc dft$rpc_buffer_header
?? POP ??
*DECK DECK=DFP$EXTRACT_SEND_PARAMETERS EXPAND=FALSE
  PROCEDURE [INLINE] dfp$extract_send_parameters
    (    queue_entry_loc_int: dft$rpc_queue_entry_loc_int;
     VAR p_send_to_server_parameters: dft$p_send_parameters);

    VAR
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_send_buffer_header: ^dft$buffer_header,
      p_send_rpc_buffer_header: ^dft$rpc_buffer_header;

    dfp$get_qit_p_from_direct_index (queue_entry_loc_int.queue_directory_index,
          p_queue_interface_table);
    dfp$fetch_queue_entry (p_queue_interface_table,
          queue_entry_loc_int.queue_index, queue_entry_loc_int.
          queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry);
    RESET p_cpu_queue_entry^.p_send_buffer;
    NEXT p_send_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
    NEXT p_send_rpc_buffer_header IN p_cpu_queue_entry^.p_send_buffer;
    NEXT p_send_to_server_parameters IN p_cpu_queue_entry^.p_send_buffer;
    RESET p_send_to_server_parameters;
  PROCEND dfp$extract_send_parameters;
?? PUSH (LISTEXT := ON) ??
*copyc dfp$get_qit_p_from_direct_index
*copyc dfp$fetch_queue_entry
*copyc dfd$request_package
*copyc dft$rpc_buffer_header
*copyc dft$rpc_queue_entry_loc_int
?? POP ??
*DECK DECK=DFP$FETCH_ACCESS_WORK EXPAND=FALSE
  PROCEDURE [XREF] dfp$fetch_access_work
    (VAR inhibit_access_work: dft$mainframe_set;
     VAR terminate_access_work: dft$mainframe_set);
?? PUSH (LISTEXT := ON) ??
*copyc dft$mainframe_set
?? POP ??
*DECK DECK=DFP$FETCH_MULTI_PAGE_STATUS EXPAND=FALSE

  PROCEDURE [XREF] dfp$fetch_multi_page_status
     (    fde_p: gft$locked_file_desc_entry_p;
          offset: ost$segment_offset;
          length: ost$segment_length;
      VAR allocate_status: gft$page_status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$locked_file_desc_entry_p
*copyc gft$page_status
*copyc osd$virtual_address
?? POP ??
*DECK DECK=DFP$FETCH_PAGE_STATUS EXPAND=FALSE

  PROCEDURE [XREF] dfp$fetch_page_status
     (    fde_p: gft$locked_file_desc_entry_p;
          offset: ost$segment_offset;
      VAR allocate_status: gft$page_status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$locked_file_desc_entry_p
*copyc gft$page_status
*copyc osd$virtual_address
?? POP ??
*DECK DECK=DFP$FETCH_QIT EXPAND=FALSE
 PROCEDURE [XREF] dfp$fetch_qit
    (   driver_name: ost$name;
     VAR  p_queue_interface_table: dft$p_queue_interface_table;
     VAR status: ost$status);
*copyc ost$status
*copyc dfd$driver_queue_types

*DECK DECK=DFP$FETCH_QUEUE_ENTRY EXPAND=FALSE
  PROCEDURE [INLINE] dfp$fetch_queue_entry
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
     VAR p_driver_queue_entry: ^dft$driver_queue_entry;
     VAR p_cpu_queue_entry: ^dft$cpu_queue_entry);


    p_driver_queue_entry := ^p_queue_interface_table^.queue_directory.
          driver_queue_pva_directory [queue_index].p_driver_queue^.
          queue_entries [queue_entry_index];

    p_cpu_queue_entry := ^p_queue_interface_table^.queue_directory.
          cpu_queue_pva_directory [queue_index].
          p_cpu_queue^.queue_entries [queue_entry_index];
  PROCEND dfp$fetch_queue_entry;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dft$cpu_queue
*copyc dft$queue_index
?? POP ??
*DECK DECK=DFP$FETCH_SERVED_FAMILY_ENTRY EXPAND=FALSE
  PROCEDURE [INLINE] dfp$fetch_served_family_entry
    (    served_family_table_index: dft$served_family_table_index;
     VAR p_served_family_entry: ^dft$served_family_table_entry;
     VAR status: ost$status);

    VAR
      family: ost$family_name,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
      server_mainframe_id: pmt$binary_mainframe_id,
      valid_index: boolean;

    status.normal := TRUE;
    dfp$fetch_served_family_info (served_family_table_index, family,
          server_mainframe_id, p_queue_interface_table, queue_index,
          valid_index);
    IF NOT valid_index THEN
      dfp$set_invalid_family_index (served_family_table_index,
            ' dfp$fetch_served_family_entry ', status);
      RETURN;
    IFEND;

    p_served_family_entry := ^dfv$served_family_table_root.
          p_family_list_pointer_array^ [served_family_table_index.
          pointers_index].p_served_family_list^
          [served_family_table_index.family_list_index];
  PROCEND dfp$fetch_served_family_entry;

?? PUSH (LISTEXT := ON) ??
*copyc dfp$fetch_served_family_info
*copyc dfp$set_invalid_family_index
*copyc dft$served_family_table_index
*copyc dfv$served_family_table_root
*copyc ost$status
?? POP ??

*DECK DECK=DFP$FETCH_SERVED_FAMILY_INFO EXPAND=FALSE
  PROCEDURE [INLINE] dfp$fetch_served_family_info
    (    served_family_table_index: dft$served_family_table_index;
     VAR family: ost$family_name;
     VAR server_mainframe_id: pmt$binary_mainframe_id;
     VAR p_queue_interface_table: dft$p_queue_interface_table;
     VAR queue_index: dft$queue_index;
     VAR index_valid: boolean);

    VAR
      family_entry: dft$served_family_table_entry;

    index_valid := dfv$served_family_table_root.valid AND
          (dfv$served_family_table_root.number_of_active_pointers >=
          served_family_table_index.pointers_index) AND
          (dfv$served_family_table_root.p_family_list_pointer_array^ [
          served_family_table_index.pointers_index].highest_valid_entry >=
          served_family_table_index.family_list_index);
    IF index_valid THEN
      family_entry := dfv$served_family_table_root.
            p_family_list_pointer_array^ [served_family_table_index.
            pointers_index].p_served_family_list^
            [served_family_table_index.family_list_index];
      family := family_entry.family_name;
      server_mainframe_id := family_entry.server_mainframe_id;
      p_queue_interface_table := family_entry.p_queue_interface_table;
      queue_index := family_entry.queue_index;
    IFEND;
  PROCEND dfp$fetch_served_family_info;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dft$queue_index
*copyc dft$served_family_table
*copyc dft$served_family_table_index
*copyc dfv$served_family_table_root
*copyc dfv$served_family_table_root
*copyc ost$user_identification
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=DFP$FETCH_SERVED_FAMILY_STATE EXPAND=FALSE


  PROCEDURE [INLINE] dfp$fetch_served_family_state
    (    served_family_table_index:  dft$served_family_table_index;
     VAR server_state: dft$server_state);


      server_state := dfv$served_family_table_root.p_family_list_pointer_array^
            [served_family_table_index.pointers_index].p_served_family_list^
            [served_family_table_index.family_list_index].server_state;

  PROCEND dfp$fetch_served_family_state;

?? PUSH (LISTEXT := ON) ??
*copyc dft$server_state
*copyc dfv$served_family_table_root
?? POP ??






*DECK DECK=DFP$FETCH_SERVER_IOCB EXPAND=FALSE

  PROCEDURE [INLINE] dfp$fetch_server_iocb
    (    queue_entry_location: dft$queue_entry_location;
     VAR p_server_iocb: ^mmt$server_iocb_entry);

    VAR
      p_queue_interface_table: dft$p_queue_interface_table;

    dfp$get_qit_p_from_direct_index (queue_entry_location.directory_index, p_queue_interface_table);
    p_server_iocb := p_queue_interface_table^.queue_directory.
          cpu_queue_pva_directory [queue_entry_location.queue_index].
          p_cpu_queue^.queue_entries [queue_entry_location.queue_entry_index].
          p_server_iocb;

  PROCEND dfp$fetch_server_iocb;
?? PUSH (LISTEXT := ON) ??
*copyc dfp$get_qit_p_from_direct_index
*copyc dft$queue_entry_location
*copyc mmt$server_io_control_block
?? POP ??



*DECK DECK=DFP$FETCH_SERVER_STATE EXPAND=FALSE

  PROCEDURE [INLINE] dfp$fetch_server_state
    (    server_descriptor_p: dmt$p_server_descriptor;
     VAR server_state: dft$server_state);

    VAR
      index_valid: boolean,
      served_family_table_index:  dft$served_family_table_index,
      status: ost$status;


    status.normal := TRUE;
    served_family_table_index := server_descriptor_p^.header.served_family_table_index;

    index_valid := dfv$served_family_table_root.valid AND (dfv$served_family_table_root.
          number_of_active_pointers >= served_family_table_index.pointers_index) AND
          (dfv$served_family_table_root.p_family_list_pointer_array^
          [served_family_table_index.pointers_index].highest_valid_entry >= served_family_table_index.
          family_list_index);

    IF index_valid THEN
      server_state := dfv$served_family_table_root.p_family_list_pointer_array^
            [served_family_table_index.pointers_index].p_served_family_list^
            [served_family_table_index.family_list_index].server_state;
    ELSE
      osp$system_error ('Index not valid into served_family_table: DFP$FETCH_SERVER_STATE', ^status);
    IFEND;

  PROCEND dfp$fetch_server_state;

?? PUSH (LISTEXT := ON) ??
*copyc dft$server_state
*copyc dmt$server_descriptor
*copyc dfv$served_family_table_root
*copyc ost$status
*copyc osp$system_error
?? POP ??
*DECK DECK=DFP$FILE_SERVER_ALLOCATION EXPAND=FALSE

  PROCEDURE [XREF] dfp$file_server_allocation
    (    sfid: gft$system_file_identifier;
         segment_offset: ost$segment_offset;
         segment_length: ost$segment_length;
         io_id: mmt$io_identifier;
         buffer_descriptor: mmt$buffer_descriptor;
         file_limit: sft$file_space_limit_kind;
     VAR spio_status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc mmt$buffer_descriptor
*copyc mmt$io_identifier
*copyc osd$virtual_address
*copyc sft$file_space_limit_kind
*copyc syt$monitor_request_code
?? POP ??
*DECK DECK=DFP$FILE_SERVER_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] dfp$file_server_display
    (    window_id: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$name
*copyc ost$status
?? POP ??


*DECK DECK=DFP$FIND_EXTENDED_RPC_ORDINAL EXPAND=FALSE
  PROCEDURE [XREF] dfp$find_extended_rpc_ordinal
    (    application_name: ost$name;
         procedure_name: pmt$program_name;
         p_cpu_queue: ^dft$cpu_queue;
     VAR rpc_ordinal: dft$procedure_address_ordinal;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$cpu_queue
*copyc dft$procedure_address_ordinal
*copyc ost$name
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=DFP$FIND_MAINFRAME_ID EXPAND=FALSE

  PROCEDURE [XREF] dfp$find_mainframe_id
    (    mainframe_id: pmt$mainframe_id;
         server_to_client: boolean;
     VAR mainframe_found: boolean;
     VAR p_queue_interface_table: ^dft$queue_interface_table;
     VAR p_cpu_queue: ^dft$cpu_queue;
     VAR queue_index: dft$queue_index;
     VAR p_q_interface_directory_entry: ^dft$q_interface_directory_entry);

*copyc dfd$driver_queue_types
*copyc dft$cpu_queue
*copyc dft$queue_index
*copyc dft$queue_interface_directory
*copyc pmt$mainframe_id
*DECK DECK=DFP$FLUSH_IMAGE_FILE EXPAND=FALSE
  PROCEDURE [XREF] dfp$flush_image_file
    (    mainframe_id: pmt$binary_mainframe_id;
         mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
*copyc pmt$mainframe_id
*copyc ost$status
?? POP ??
*DECK DECK=DFP$FLUSH_SERVED_FAMILY_TABLE EXPAND=FALSE
  PROCEDURE [XREF] dfp$flush_served_family_table
    (VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DFP$FORMAT_TASK_NAME EXPAND=FALSE
  PROCEDURE [INLINE] dfp$format_task_name
    (    server_mainframe: pmt$mainframe_id;
     VAR server_mainframe_task_name: ost$name);

    VAR
      length: integer;

    STRINGREP (server_mainframe_task_name, length, 'DF', server_mainframe,
          '_SERVER_TASK');

  PROCEND dfp$format_task_name;
?? PUSH (LISTEXT := ON) ??
*copyc pmt$mainframe_id
*copyc ost$name
?? POP ??
*DECK DECK=DFP$FORMAT_VERIFY_FAMILY EXPAND=FALSE
  PROCEDURE [XREF] dfp$format_verify_family
    (    mainframe_id: pmt$binary_mainframe_id;
     VAR family_container: SEQ (REP dfc$max_family_parameters of
          dft$family_verification);
     VAR number_of_families: 0 .. dfc$max_family_parameters;
     VAR p_family_list: ^dft$poll_family_list);

*copyc dft$cpu_queue
*copyc dft$family_list
*copyc dft$poll_family_list
*DECK DECK=DFP$FORM_INQUIRY_TRACER EXPAND=FALSE

  PROCEDURE [INLINE] dfp$form_inquiry_tracer
    (    transaction_count: integer;
         retransmission_count: integer;
     VAR inquiry_tracer: dft$inquiry_tracer);

  { This procedure forms an "inquiry tracer" value from the least significant
  { hexidecimal digit of the specified transaction_count and retransmission_count.


    TYPE
      converter_record = record
        CASE boolean OF
        = TRUE =
          full_integer: integer,
        = FALSE =
          unpacked_integer: unpacked_value,
        CASEND,
      recend,

      unpacked_value = packed record
        fill: 0 .. 0fffffffffffffff(16),
        leftmost_hex_digit: 0 .. 0f(16),
      recend;

    VAR
      converter: converter_record;


      converter.full_integer := transaction_count;
      inquiry_tracer.transaction_digit:= converter.unpacked_integer.leftmost_hex_digit;
      converter.full_integer := retransmission_count;
      inquiry_tracer.retransmission_digit:= converter.unpacked_integer.leftmost_hex_digit;

  PROCEND dfp$form_inquiry_tracer;

?? PUSH (LISTEXT := ON) ??
*copyc dft$inquiry_message
?? POP ??
*DECK DECK=DFP$FREE_ENTRY_ASSIGNMENT EXPAND=FALSE
{
{  This procedure sets the specified entry_assignment character to free.
{

  PROCEDURE [INLINE] dfp$free_entry_assignment
    (    entry_assignment: integer;
     VAR queue_assignment_string {input, output} : string ( * <=  dfc$queue_assignment_strng_size));

    CONST
      swap_successful = 0;

    VAR
      actual_word: string (8),
      found_word: string (8),
      found_word_starting_char: integer,
      p_test: ^string (8),
      result: 0 .. 2,
      swap_in_word: string (8),
      word_index: integer;

    found_word_starting_char := ((entry_assignment - 1) DIV 8) * 8 + 1;
    word_index := (entry_assignment MOD 8);
    IF word_index = 0 THEN
      word_index := 8;
    IFEND;
    { p_test required due to cybil bug.
    #SPOIL (queue_assignment_string);
    p_test := ^queue_assignment_string (found_word_starting_char, 8);

  /clear_entry/
    REPEAT
      #SPOIL (p_test^);
      osp$fetch_locked_string (p_test^, found_word);
      swap_in_word := found_word;
      swap_in_word (word_index) := dfc$free_entry_char;
      #SPOIL (p_test^);
      #COMPARE_SWAP (p_test^, found_word, swap_in_word, actual_word, result);
      #SPOIL (p_test^);
    UNTIL result = swap_successful;
  PROCEND dfp$free_entry_assignment;
?? PUSH (LISTEXT := ON) ??
*copyc dft$entry_type
*copyc dft$cpu_queue
*copyc osp$fetch_locked_string
?? POP ??

*DECK DECK=DFP$FREE_IMAGE_FILE EXPAND=FALSE
 PROCEDURE [XREF] dfp$free_image_file
    (    mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
*copyc ost$status
?? POP ??
*DECK DECK=DFP$FREE_QUEUE_ENTRY EXPAND=FALSE
  PROCEDURE [INLINE] dfp$free_queue_entry
    (    queue_entry_location: dft$queue_entry_location);

    VAR
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_queue_interface_table: dft$p_queue_interface_table;

    dfp$get_qit_p_from_direct_index (queue_entry_location.directory_index, p_queue_interface_table);
    dfp$fetch_queue_entry (p_queue_interface_table, queue_entry_location.queue_index, queue_entry_location.
          queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry);

    { Clear all flags
    p_driver_queue_entry^.flags.subsystem_action := FALSE;
    p_driver_queue_entry^.flags.buffer_sent := FALSE;
    p_driver_queue_entry^.flags.data_sent := FALSE;
    p_driver_queue_entry^.flags.buffer_received := FALSE;
    p_driver_queue_entry^.flags.data_received := FALSE;
    p_driver_queue_entry^.flags.ready_for_data_sent := FALSE;
    p_driver_queue_entry^.flags.ready_for_data_received := FALSE;

  PROCEND dfp$free_queue_entry;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfp$fetch_queue_entry
*copyc dfp$get_qit_p_from_direct_index
?? POP ??

*DECK DECK=DFP$GET_APPLICATION_INFO EXPAND=FALSE

  PROCEDURE [XREF] dfp$get_application_info
    (    partner_mainframe_id: pmt$mainframe_id;
         partner_is_server: boolean;
         application_name: ost$name;
     VAR sequence_pointer: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc ost$name
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??

*DECK DECK=DFP$GET_CLIENT_MF_FILE_INFO EXPAND=FALSE

  PROCEDURE [XREF] dfp$get_client_mf_file_info
    (    client_mainframe_id: pmt$binary_mainframe_id;
     VAR client_found: boolean;
     VAR server_state: dft$server_state;
     VAR server_lifetime: dft$server_lifetime;
     VAR server_birthdate: integer);

?? PUSH (LISTEXT := ON) ??
*copyc dft$server_lifetime
*copyc dft$server_state
*copyc pmt$binary_mainframe_id
?? POP ??

*DECK DECK=DFP$GET_CLIENT_MF_JOB_NAME EXPAND=FALSE
  PROCEDURE [INLINE] dfp$get_client_mf_job_name
    (    client_mainframe: pmt$mainframe_id;
     VAR client_mainframe_job_name: jmt$user_supplied_name);

    VAR
      length: integer;

    STRINGREP (client_mainframe_job_name, length, '$DF', client_mainframe,
          '_CLIENT_JOB');

  PROCEND dfp$get_client_mf_job_name;
*copyc jmt$user_supplied_name
*copyc pmt$mainframe_id
*DECK DECK=DFP$GET_CURRENT_RQ_BUFFER_ENTRY EXPAND=FALSE

  PROCEDURE [INLINE] dfp$get_current_rq_buffer_entry
    (    p_queue_interface_table: dft$p_queue_interface_table;
         out: integer;
     VAR request_buffer_entry: dft$request_buffer_entry);

     request_buffer_entry := p_queue_interface_table^.request_buffer_directory.p_request_buffer^.
           request_buffer_entries [(out DIV 8) + 1];

   PROCEND dfp$get_current_rq_buffer_entry;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dft$request_buffer
?? POP ??
*DECK DECK=DFP$GET_FAMILY_ACCESS EXPAND=FALSE
  PROCEDURE [XREF] dfp$get_family_access
    (    family: ost$family_name;
     VAR family_known: boolean;
     VAR family_access: dft$family_access;
     VAR server_state: dft$server_state;
     VAR leveler_status: jmt$jl_job_leveler_status);

?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dft$family_access
*copyc dft$server_state
*copyc jmt$jl_job_leveler_status
*copyc ost$user_identification
?? POP ??
*DECK DECK=DFP$GET_FAMILY_LIST EXPAND=FALSE

  PROCEDURE [XREF] dfp$get_family_list
    (VAR family_info_list: dft$family_info_list;
     VAR number_of_families: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pme$program_services_exceptions
*copyc dft$family_info_list
*copyc ost$status
?? POP ??
*DECK DECK=DFP$GET_FAMILY_STATUS EXPAND=FALSE
  PROCEDURE [XREF] dfp$get_family_status
    (    family_name: ost$family_name;
     VAR family_state: dft$family_info_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$family_info_record
*copyc ost$status
*copyc ost$user_identification
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=DFP$GET_HIGHEST_SF_LIFETIME EXPAND=FALSE

  PROCEDURE [XREF] dfp$get_highest_sf_lifetime
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR server_found: boolean;
     VAR server_state: dft$server_state;
     VAR highest_server_lifetime: dft$server_lifetime;
     VAR server_birthdate: integer);

?? PUSH (LISTEXT := ON) ??
*copyc dft$server_lifetime
*copyc dft$server_state
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=DFP$GET_JOB_SERVER_STATE EXPAND=FALSE
  PROCEDURE [XREF] dfp$get_job_server_state
    (    mainframe_id: pmt$binary_mainframe_id;
     VAR server_found: boolean;
     VAR server_lifetime: dft$lifetime);
?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
*copyc dft$lifetime
?? POP ??
*DECK DECK=DFP$GET_MAINFRAME_LIST EXPAND=FALSE

  PROCEDURE [XREF] dfp$get_mainframe_list
    (    partners_are_servers: boolean;
     VAR partner_mainframes : dft$partner_mainframe_list;
     VAR partner_count: dft$partner_mainframe_count);

?? PUSH (LISTEXT := ON) ??
*copyc dft$partner_mainframe_list
?? POP ??
*DECK DECK=DFP$GET_MAINFRAME_STATUS EXPAND=FALSE

  PROCEDURE [XREF] dfp$get_mainframe_status
    (    partner_mainframe_id: pmt$mainframe_id;
         partner_is_server: boolean;
     VAR server_state: dft$server_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dft$server_state
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=DFP$GET_NEXT_IMAGE_BLOCK EXPAND=FALSE
{
{   This routine is used when writting the image file to add on another
{ image block on to the image file. The image file is expanded and
{ a new block header is added at the current eoi.  The previous block
{ header is used to point to the new block header.  The new block header
{ is initialized and the eoi of the image file is changed.

  PROCEDURE [INLINE] dfp$get_next_image_block
    (VAR image_file_id: dft$image_file_id;
     VAR status: ost$status);

    VAR
      p_previous_block: ^dft$image_block_header;

    dfp$expand_image_file (image_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    p_previous_block := image_file_id.p_current_block_header;
    i#build_adaptable_seq_pointer (#RING (image_file_id.p_current_eoi),
          #SEGMENT (image_file_id.p_current_eoi),
          #OFFSET (image_file_id.p_current_eoi), { Size } osv$page_size,
          { next } 0, image_file_id.p_current_block_seq);
    NEXT image_file_id.p_current_block_header IN
          image_file_id.p_current_block_seq;
    image_file_id.p_current_eoi := #ADDRESS (#RING (image_file_id.
          p_current_block_seq), #SEGMENT (image_file_id.p_current_block_seq),
          #OFFSET (image_file_id.p_current_eoi) + osv$page_size);
    dfp$initialize_block_header (image_file_id.operation,
          image_file_id.p_current_block_header^);
    p_previous_block^.next_block_header_offset :=
          #OFFSET (image_file_id.p_current_block_header);
    image_file_id.p_image_header^.current_eoi :=
          #OFFSET (image_file_id.p_current_eoi);

  PROCEND dfp$get_next_image_block;
?? PUSH (LISTEXT := ON) ??
*copyc dfp$expand_image_file
*copyc dfp$initialize_block_header
*copyc dft$image_file_id
*copyc i#build_adaptable_seq_pointer
*copyc ost$status
*copyc osv$page_size
?? POP ??
*DECK DECK=DFP$GET_PARTNER_MAINFRAMES EXPAND=FALSE
  PROCEDURE [XREF] dfp$get_partner_mainframes
    (    partners_are_servers: boolean;
         p_partner_mainframes { output } : ^dft$partner_mainframe_list;
     VAR partner_count: dft$partner_mainframe_count);

?? PUSH (LISTEXT := ON) ??
*copyc dft$partner_mainframe_list
?? POP ??
*DECK DECK=DFP$GET_PARTNER_QUEUES EXPAND=FALSE
  PROCEDURE [XREF] dfp$get_partner_queues
    (    p_partner_queues { output } : ^dft$partner_queue_list;
     VAR partner_queue_count: dft$partner_queue_count);

?? PUSH (LISTEXT := ON) ??
*copyc dft$partner_queue_list
?? POP ??

*DECK DECK=DFP$GET_P_QUEUE_INTERFACE_TABLE EXPAND=FALSE
  PROCEDURE [INLINE] dfp$get_p_queue_interface_table
    (    element_name: cmt$element_name;
     VAR p_queue_interface_table: dft$p_queue_interface_table;
     VAR status: ost$status);

    VAR
      next_request: ^iot$io_request;

    cmp$get_next_request (element_name, next_request, status);
    IF status.normal THEN
      dfp$convert_p_io_request_to_qit (next_request, p_queue_interface_table);
    IFEND;
  PROCEND dfp$get_p_queue_interface_table;
?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*COPYC cmp$get_next_request
*copyc dfp$convert_p_io_request_to_qit
?? POP ??
*DECK DECK=DFP$GET_QIT_P_FROM_DIRECT_INDEX EXPAND=FALSE

  PROCEDURE [INLINE] dfp$get_qit_p_from_direct_index
    (    directory_index: dft$queue_directory_index;
     VAR p_queue_interface_table: dft$p_queue_interface_table);

    p_queue_interface_table := dfv$p_queue_interface_directory^ [directory_index].p_queue_interface_table;

  PROCEND dfp$get_qit_p_from_direct_index;
?? PUSH (LISTEXT := ON) ??
*copyc dft$queue_interface_directory
*copyc dfv$p_queue_interface_directory
?? POP ??

*DECK DECK=DFP$GET_QUEUE_DIRECTORY_INDEX EXPAND=FALSE

  PROCEDURE [INLINE] dfp$get_queue_directory_index
    (    p_queue_interface_table: dft$p_queue_interface_table;
     VAR directory_index: dft$queue_directory_index);

    FOR directory_index := 1 TO UPPERBOUND (dfv$p_queue_interface_directory^) DO
      IF p_queue_interface_table = dfv$p_queue_interface_directory^ [directory_index].p_queue_interface_table
            THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND dfp$get_queue_directory_index;
?? PUSH (LISTEXT := ON) ??
*copyc dft$queue_interface_directory
*copyc dfv$p_queue_interface_directory
?? POP ??
*DECK DECK=DFP$GET_RPC_ATTACHED_FILES EXPAND=FALSE

  PROCEDURE [XREF] dfp$get_rpc_attached_files
    (    application_name: ost$name;
     VAR attached_file_pointers: array [1 .. * ] of ^cell;
     VAR attached_file_names: array [1 .. * ] of ost$string;
     VAR number_of_attached_files: dft$number_of_attached_files;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$application_support_limits
*copyc dft$app_support_limits_af
*copyc ost$name
*copyc ost$status
*copyc ost$string
?? POP ??

*DECK DECK=DFP$GET_SERVED_FAMILY_NAMES EXPAND=FALSE

  PROCEDURE [XREF] dfp$get_served_family_names (
    VAR family_names: pmt$family_name_list;
    VAR name_count: pmt$family_name_count;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$program_services_exceptions
*copyc pmt$family_name_count
*copyc pmt$family_name_list
?? POP ??

*DECK DECK=DFP$GET_SERVED_FILE_DESC_P EXPAND=FALSE

  PROCEDURE [INLINE] dfp$get_served_file_desc_p
    (    fde_p: gft$file_desc_entry_p;
     VAR sfd_p: dft$server_descriptor_p);

?? PUSH (LISTEXT := ON) ??

    VAR
      local_fde_p: ^gft$file_descriptor_entry,
      pva: gft$trick_pointer;

    IF fde_p^.media <> gfc$fm_served_file THEN
      i#program_error;
    IFEND;
    local_fde_p := fde_p;
    pva.p := local_fde_p;
    pva.pva.offset := local_fde_p^.served_file_descriptor_p;
    sfd_p := pva.p;

  PROCEND dfp$get_served_file_desc_p;
*copyc dmt$server_descriptor
*copyc gft$file_desc_entry_p
*copyc gft$file_descriptor_entry
*copyc gft$trick_pointer
*copyc i#program_error
?? POP ??
*DECK DECK=DFP$GET_SERVER_MAINFRAME_LIST EXPAND=FALSE

  PROCEDURE [XREF] dfp$get_server_mainframe_list
    (    requested_states: dft$server_states;
     VAR server_mainframes: dft$partner_mainframe_list;
     VAR server_count: dft$partner_mainframe_count);

?? PUSH (LISTEXT := ON) ??
*copyc dft$server_state
*copyc dft$partner_mainframe_list
?? POP ??
*DECK DECK=DFP$GET_SERVER_STATE_STRING EXPAND=FALSE

  PROCEDURE [XREF] dfp$get_server_state_string
    (    server_state: dft$server_state;
     VAR server_state_string: string(*) );

?? PUSH (LISTEXT := ON) ??
*copyc dft$server_state
?? POP ??

*DECK DECK=DFP$GET_SYSTEM_CORE_QUEUE_ENTRY EXPAND=FALSE


  PROCEDURE [INLINE] dfp$get_system_core_queue_entry
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
     VAR queue_entry_index: dft$queue_entry_index;
     VAR p_driver_queue_entry: ^dft$driver_queue_entry;
     VAR p_cpu_queue_entry: ^dft$cpu_queue_entry;
     VAR status: ost$status);

    VAR
      assign_status: dft$assign_queue_entry_status;

    status.normal := TRUE;
    REPEAT
      dfp$assign_queue_entry (p_queue_interface_table, queue_index,
            dfc$task_services, queue_entry_index, assign_status);
      IF assign_status = dfc$aqes_server_terminated THEN
        dfp$set_terminated_status (p_queue_interface_table, queue_index,
            status);
        RETURN;
      IFEND;
      IF assign_status = dfc$aqes_no_available_entries THEN
        pmp$delay (1000, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    UNTIL (assign_status <> dfc$aqes_no_available_entries);

    IF assign_status <> dfc$aqes_entry_assigned THEN
      IF assign_status = dfc$aqes_server_terminated THEN
        dfp$set_terminated_status (p_queue_interface_table, queue_index,
            status);
      ELSE
        osp$set_status_abnormal (dfc$file_server_id,
              dfe$unable_to_assign_q_entry, ' ', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (assign_status), 10, FALSE, status);
      IFEND;
      RETURN;
    IFEND;
    dfp$fetch_queue_entry (p_queue_interface_table, queue_index,
          queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry);
  PROCEND dfp$get_system_core_queue_entry;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc dfp$assign_queue_entry
*copyc dfp$fetch_queue_entry
*copyc dfp$set_terminated_status
*copyc osp$set_status_abnormal
*copyc osp$append_status_integer
*copyc ost$status
*copyc pmp$delay
?? POP ??

*DECK DECK=DFP$GET_TASK_QUEUE_ENTRY EXPAND=FALSE

  PROCEDURE [INLINE] dfp$get_task_queue_entry
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
     VAR queue_entry_index: dft$queue_entry_index;
     VAR p_driver_queue_entry: ^dft$driver_queue_entry;
     VAR p_cpu_queue_entry: ^dft$cpu_queue_entry;
     VAR status: ost$status);

    VAR
      assign_status: dft$assign_queue_entry_status;

    REPEAT
      dfp$assign_queue_entry (p_queue_interface_table, queue_index,
            dfc$task_services, queue_entry_index, assign_status);
      IF assign_status = dfc$aqes_server_terminated THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_active,
             '', status);
        RETURN;
      IFEND;
      IF assign_status = dfc$aqes_no_available_entries THEN
        syp$wait (1000);
      IFEND;
    UNTIL assign_status <> dfc$aqes_no_available_entries;

    IF assign_status <> dfc$aqes_entry_assigned THEN
      IF assign_status = dfc$aqes_server_terminated THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_active,
             '', status);
      ELSE
        osp$set_status_abnormal (dfc$file_server_id,
              dfe$unable_to_assign_q_entry, ' ',  status);
        osp$append_status_integer (osc$status_parameter_delimiter, $integer(assign_status),
              10, FALSE, status);
      IFEND;
      RETURN;
    IFEND;
    dfp$fetch_queue_entry (p_queue_interface_table, queue_index,
          queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry);
    status.normal := TRUE;
  PROCEND dfp$get_task_queue_entry;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc dfp$assign_queue_entry
*copyc dfp$fetch_queue_entry
*copyc osp$set_status_abnormal
*copyc osp$append_status_integer
*copyc ost$status
*copyc syp$wait
?? POP ??

*DECK DECK=DFP$GET_TEST_QUEUE_LOCATION EXPAND=FALSE
  PROCEDURE [XREF] dfp$get_test_queue_location
    (VAR queue_interface_table: ^dft$queue_interface_table;
     VAR queue_index: dft$queue_index);

?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
?? POP ??
*DECK DECK=DFP$IDLE_PP EXPAND=FALSE
  PROCEDURE [XREF] dfp$idle_pp
  (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
   VAR status: ost$status );

*copyc dft$queue_interface_directory
*copyc ost$status
*DECK DECK=DFP$IDLE_REQUESTS_TO_SERVER EXPAND=FALSE
  PROCEDURE [XREF] dfp$idle_requests_to_server
    (    queue_directory_index: dft$queue_directory_index;
         queue_index: dft$queue_index;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$queue_index
*copyc dft$queue_interface_directory
*copyc ost$status
?? POP ??
*DECK DECK=DFP$INCR_MONITOR_IO_STATS EXPAND=FALSE

    PROCEDURE [INLINE] dfp$incr_monitor_io_stats (
      queue_entry_location: dft$queue_entry_location);


      VAR
        current_time: integer,
        p_cpu_queue_entry: ^dft$cpu_queue_entry,
        p_queue_interface_table: dft$p_queue_interface_table;

      dfp$get_qit_p_from_direct_index (queue_entry_location.directory_index,
            p_queue_interface_table);
      p_cpu_queue_entry := ^p_queue_interface_table^.
            queue_directory.cpu_queue_pva_directory [queue_entry_location.
            queue_index].p_cpu_queue^.queue_entries [queue_entry_location.
            queue_entry_index];
      current_time := #free_running_clock (0);
      p_cpu_queue_entry^.current_request_time :=
            p_cpu_queue_entry^.current_request_time + current_time
            - dfv$monitor_io_start_time;
      dfv$monitor_io_start_time := current_time;

    PROCEND dfp$incr_monitor_io_stats;

?? PUSH (LISTEXT := ON) ??
*copyc dft$cpu_queue
*copyc dft$queue_entry_location
*copyc dfv$monitor_io_start_time
*copyc dfp$get_qit_p_from_direct_index
?? POP ??
*DECK DECK=DFP$INITIALIZE_BLOCK_HEADER EXPAND=FALSE

  PROCEDURE [INLINE] dfp$initialize_block_header
    (    operation: dft$image_source;
     VAR block_header: dft$image_block_header);

    block_header.file_count := 0;
    block_header.page_count := 0;
    block_header.next_block_header_offset := 0;
    block_header.page_source := operation;
    block_header.block_header_string := dfc$block_header_string;
  PROCEND dfp$initialize_block_header;
?? PUSH (LISTEXT := ON) ??
*copyc dft$image_file
?? POP ??
*DECK DECK=DFP$INITIALIZE_RMA_LIST EXPAND=TRUE
  PROCEDURE [INLINE] dfp$initialize_rma_list
    (    pva: ^cell;
         offset: ost$segment_length;
         length: ost$segment_length;
         p_data_rma_list: dft$p_data_rma_list;
     VAR data_descriptor: dft$data_descriptor;
     VAR status: ost$status);

    VAR
      p_page: ^cell,
      page: 0 .. dfc$max_rma_list_entries,
      page_count: 0 .. dfc$max_rma_list_entries,
      ring: ost$ring,
      rma: integer,
      segment: ost$segment,
      starting_offset: ost$segment_offset,
      touch_byte: cell;

    status.normal := TRUE;
    page_count := dfp$page_count (length);
    data_descriptor.indirect_address := TRUE;
    data_descriptor.actual_length := page_count * 8;
    ring := #RING (pva);
    segment:= #SEGMENT(pva);
    starting_offset := #OFFSET (pva);

  /initialize_rma_list_entry/
    FOR page := 1 TO page_count DO
      p_page := #ADDRESS (ring, segment, starting_offset + offset +
            ((page - 1) * osv$page_size));
      i#real_memory_address (p_page, rma);
      IF (rma = 80000000) OR (rma  <= 0) THEN
        { Touch the page to bring the page into memory.
        touch_byte := p_page^;
        i#real_memory_address (p_page, rma);
      IFEND;
      IF (rma = 80000000) OR (rma  <= 0) THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$data_length_error, '',
              status);
        RETURN;
      ELSE
        p_data_rma_list^ [page].rma := rma;
        p_data_rma_list^ [page].fill := 0;
        p_data_rma_list^ [page].length :=  osv$page_size;
      IFEND;
    FOREND /initialize_rma_list_entry/;
  PROCEND dfp$initialize_rma_list;
?? PUSH (LISTEXT := ON) ??
*copyc dfc$esm_allocation_constants
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc dfp$page_count
*copyc i#real_memory_address
*copyc osp$set_status_abnormal
*copyc ost$hardware_subranges
*copyc ost$status
*copyc osv$page_size
?? POP ??
*DECK DECK=DFP$INIT_MONITOR_IO_STATS EXPAND=FALSE


    PROCEDURE [INLINE] dfp$init_monitor_io_stats (
      queue_entry_location: dft$queue_entry_location;
      io_type: dft$monitor_io_types);

      VAR
        p_cpu_queue: ^dft$cpu_queue,
        p_queue_interface_table: dft$p_queue_interface_table;

      dfp$get_qit_p_from_direct_index (queue_entry_location.directory_index,
            p_queue_interface_table);
      p_cpu_queue := p_queue_interface_table^
            .queue_directory.cpu_queue_pva_directory
            [queue_entry_location.queue_index].p_cpu_queue;
      p_cpu_queue^.queue_header.monitor_io [io_type].number_of_requests :=
            p_cpu_queue^.queue_header.monitor_io [io_type].number_of_requests + 1;
      p_cpu_queue^.queue_entries [queue_entry_location.queue_entry_index].
            current_request_type := io_type;
      p_cpu_queue^.queue_entries [queue_entry_location.queue_entry_index].
            current_request_time := 0;

    PROCEND dfp$init_monitor_io_stats;

?? PUSH (LISTEXT := ON) ??
*copyc dft$cpu_queue
*copyc dft$queue_entry_location
?? POP ??
*copyc dfp$get_qit_p_from_direct_index
*DECK DECK=DFP$LOAD_APPLICATION_PROCEDURE EXPAND=FALSE

  PROCEDURE [INLINE] dfp$load_application_procedure
    (    procedure_name: pmt$program_name;
         library_lfn: amt$local_file_name;
     VAR loaded_address: pmt$loaded_address;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      call_bracket_ring: ost$valid_ring,
      loaded_ring: ost$valid_ring,
      reference_ring: ost$valid_ring;

    #CALLER_ID (caller_id);
    reference_ring := caller_id.ring; {?????

    pmp$load_module_from_library (procedure_name, reference_ring, pmc$procedure_address, library_lfn,
          loaded_ring, call_bracket_ring, loaded_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND dfp$load_application_procedure;

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dft$rpc_procedure_address_list
*copyc osd$virtual_address
*copyc ost$caller_identifier
*copyc pmp$load_module_from_library
*copyc pmt$loaded_address
*copyc pmt$program_name
?? POP ??
*DECK DECK=DFP$LOAD_PP EXPAND=FALSE
  PROCEDURE [XREF] dfp$load_pp
  (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
   VAR status: ost$status );

*copyc dft$queue_interface_directory
*copyc ost$status
*DECK DECK=DFP$LOAD_PP_IF_FIRST EXPAND=FALSE
  PROCEDURE [XREF] dfp$load_pp_if_first
    (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
         queue_index: dft$queue_index;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$queue_index
*copyc dft$queue_interface_directory
*copyc ost$status
?? POP ??
*DECK DECK=DFP$LOAD_STATE_CHANGE_PROCEDURE EXPAND=FALSE

  PROCEDURE [XREF] dfp$load_state_change_procedure
    (    p_cpu_queue: ^dft$cpu_queue;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$cpu_queue
*copyc ost$status
?? POP ??
*DECK DECK=DFP$LOCATE_ESM_DEFINITION EXPAND=FALSE
  PROCEDURE [XREF] dfp$locate_esm_definition
    (    element: cmt$element_name;
     VAR p_esm_def_table_entry: ^dft$esm_definition_table_entry);

*copyc cmt$element_name
*copyc dft$esm_definition_table

*DECK DECK=DFP$LOCATE_EVERY_SERVED_FAMILY EXPAND=FALSE

  PROCEDURE [XREF] dfp$locate_every_served_family
    (    family: ost$family_name;
     VAR family_found: boolean;
     VAR served_family_table_index: dft$served_family_table_index;
     VAR server_mainframe_id: pmt$binary_mainframe_id;
     VAR p_queue_interface_table: dft$p_queue_interface_table;
     VAR queue_index: dft$queue_index;
     VAR server_state: dft$server_state);

?? PUSH (LISTEXT := ON) ??
*copyc dft$served_family_table_index
*copyc pmt$binary_mainframe_id
*copyc dfd$driver_queue_types
*copyc dft$queue_index
*copyc dft$server_state
*copyc ost$user_identification
?? POP ??
*DECK DECK=DFP$LOCATE_SERVED_FAMILY EXPAND=FALSE
  PROCEDURE [XREF] dfp$locate_served_family
    (    family: ost$family_name;
     VAR family_found: boolean;
     VAR served_family_table_index: dft$served_family_table_index;
     VAR server_mainframe_id: pmt$binary_mainframe_id;
     VAR p_queue_interface_table: dft$p_queue_interface_table;
     VAR queue_index: dft$queue_index;
     VAR server_state: dft$server_state);
?? PUSH (LISTEXT := ON) ??
*copyc dft$served_family_table_index
*copyc pmt$binary_mainframe_id
*copyc dfd$driver_queue_types
*copyc dft$queue_index
*copyc dft$server_state
*copyc ost$user_identification
?? POP ??
*DECK DECK=DFP$LOCATE_SERVER_TRANSLATION EXPAND=FALSE

  PROCEDURE [INLINE] dfp$locate_server_translation
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR mainframe_id_ordinal: 1 .. dfc$max_number_of_mainframes;
     VAR server_found: boolean);

    server_found := FALSE;

  /search_translation_table/
    FOR mainframe_id_ordinal := 1 TO dfc$max_number_of_mainframes DO
      IF dfv$defined_server_translation [mainframe_id_ordinal] =
            server_mainframe_id THEN
        server_found := TRUE;
        RETURN;
      IFEND;
    FOREND /search_translation_table/;
  PROCEND dfp$locate_server_translation;
?? PUSH (LISTEXT := ON) ??
*copyc dfc$esm_allocation_constants
*copyc dfv$defined_server_translation
*copyc pmt$binary_mainframe_id
?? POP ??

*DECK DECK=DFP$LOG_ESM_DATA EXPAND=FALSE
 PROCEDURE [XREF] dfp$log_esm_data (datap: ^SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=DFP$LOG_SDP_DATA EXPAND=FALSE
  PROCEDURE [XREF] dfp$log_sdp_data
    (    reason: dft$sdp_logging_code;
         log_data_pointer: ^dft$sdp_communication_buffer;
         descriptive_data_descriptor: dft$descriptive_data_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$sdp_logging_code
*copyc dft$sdp_communication_buffer
*copyc dft$descriptive_data_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=DFP$LOG_SIDE_DOOR_PORT_STATUS EXPAND=FALSE

  PROCEDURE [XREF] dfp$log_side_door_port_status
    (    reason: dft$sdp_logging_code;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$sdp_logging_code
*copyc ost$status
?? POP ??
*DECK DECK=DFP$MANAGE_CLIENT_CONNECTION EXPAND=FALSE
  PROCEDURE [XREF] dfp$manage_client_connection
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

*copyc ost$status
*copyc pmt$mainframe_id

*DECK DECK=DFP$NEW_CRACK_MAINFRAME_ID EXPAND=TRUE

  PROCEDURE [XREF] dfp$new_crack_mainframe_id
    (    mainframe_id: pmt$mainframe_id;
     VAR binary_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

 ?? PUSH (LISTEXT := ON) ??
*copyc pmt$mainframe_id
*copyc pmt$binary_mainframe_id
*copyc ost$status
?? POP ??
*DECK DECK=DFP$PAGE_COUNT EXPAND=FALSE
  FUNCTION [INLINE] dfp$page_count
    (    bytes: ost$segment_length): ost$non_negative_integers;

    { This function returns rounds the number of bytes up to the
    { required number of pages

    dfp$page_count := (bytes DIV osv$page_size) +
          $INTEGER ((bytes MOD osv$page_size) > 0);

  FUNCEND dfp$page_count;

?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc osv$page_size
?? POP ??
*DECK DECK=DFP$POP_JOB_UNRECOVERABLE EXPAND=FALSE
  PROCEDURE [XREF] dfp$pop_job_unrecoverable
    (    client_job_id: dft$client_job_id);

?? PUSH (LISTEXT := ON) ??
*copyc dft$client_job_id
?? POP ??
*DECK DECK=DFP$PREPARE_FOR_IDLE_SYSTEM EXPAND=FALSE
  PROCEDURE [XREF] dfp$prepare_for_idle_system
    (    idle_code: syt$180_idle_code;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc syt$180_idle_code
?? POP ??

*DECK DECK=DFP$PROCESS_ERROR_LOG_RESPONSE EXPAND=FALSE
  PROCEDURE [XREF] dfp$process_error_log_response
    (    p_fs_pp_response: ^dft$fs_pp_response;
         p_fs_error_log_response: ^dft$fs_error_log_response;
         pp_number: 1 .. ioc$pp_count;
     VAR status: syt$monitor_status);

*copyc iot$pp_interface_table
*copyc dft$fs_pp_response
*copyc dft$fs_error_log_response
*copyc syt$monitor_status
*DECK DECK=DFP$PROCESS_JOB_END EXPAND=FALSE
 PROCEDURE [XREF] DFP$PROCESS_JOB_END;
*DECK DECK=DFP$PROCESS_MULTIWORD_RESPONSE EXPAND=FALSE
  PROCEDURE [XREF] dfp$process_multiword_response
    (    pp_response_p: ^iot$pp_response;
         detailed_status_p: ^iot$detailed_status;
         pp_number: 1 .. ioc$pp_count;
     VAR status: syt$monitor_status);
?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_response
*copyc iot$pp_interface_table
*copyc syt$monitor_status
?? POP ??

*DECK DECK=DFP$PROCESS_REQUEST_TIMEOUT EXPAND=FALSE
  PROCEDURE [XREF] dfp$process_request_timeout
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index);

?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dft$cpu_queue
*copyc dft$queue_index
?? POP ??
*DECK DECK=DFP$PROCESS_SERVER_RESPONSE EXPAND=FALSE
  PROCEDURE [XREF] dfp$process_server_response
    (    one_word_response_p: ^dft$fs_pp_response;
         pp_number: 1 .. ioc$pp_count;
     VAR status: syt$monitor_status);
?? PUSH (LISTEXT := ON) ??
*copyc dft$fs_pp_response
*copyc iot$pp_interface_table
*copyc syt$monitor_status
?? POP ??
*DECK DECK=DFP$PROCESS_SERVER_RESPONSE_A EXPAND=FALSE

  PROCEDURE [XREF] dfp$process_server_response_a
    (    one_word_response_p: ^dft$fs_pp_response;
         p_queue_interface_table: dft$p_queue_interface_table;
     VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dft$fs_pp_response
*copyc syt$monitor_status
?? POP ??
*DECK DECK=DFP$PROCESS_TASK_REQUEST EXPAND=FALSE
  PROCEDURE [XREF] dfp$process_task_request
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dft$cpu_queue
*copyc dft$queue_index
*copyc ost$status
?? POP ??
*DECK DECK=DFP$PURGE_ALL_IMAGE_FILES EXPAND=FALSE
  PROCEDURE [XREF] dfp$purge_all_image_files;
*DECK DECK=DFP$PURGE_CLIENT_MAINFRAME_FILE EXPAND=FALSE

  PROCEDURE [XREF] dfp$purge_client_mainframe_file
    (    mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$mainframe_id
*copyc ost$status
?? POP ??

*DECK DECK=DFP$PURGE_IMAGE_FILE EXPAND=FALSE
  PROCEDURE [XREF] dfp$purge_image_file
    (    mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
*copyc ost$status
?? POP ??
*DECK DECK=DFP$PURGE_PRESERVED_FAMILY_FILE EXPAND=FALSE
  PROCEDURE [XREF] dfp$purge_preserved_family_file
    (VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DFP$PUSH_JOB_UNRECOVERABLE EXPAND=FALSE
  PROCEDURE [XREF] dfp$push_job_unrecoverable
    (    client_job_id: dft$client_job_id);
?? PUSH (LISTEXT := ON) ??
*copyc dft$client_job_id
?? POP ??

*DECK DECK=DFP$QUEUE_CLIENT_CORE_REQUEST EXPAND=FALSE

  PROCEDURE [INLINE] dfp$queue_client_core_request
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
     VAR status: ost$status);

*copyc dfc$queue_request_constants

    VAR
      maximum_request_count: integer,
      message: string (40),
      new_out: integer,
      old_out: integer,
      queue_request_status: dft$queue_request_status,
      request_buffer_entry: dft$request_buffer_entry,
      request_buffer_queue_index: 0 .. 0FF(16),
      retry_count: integer;

{ Attempt to queue the request.  If it is queued, OK.  If it is not queued, keep trying until:
{   . it is queued
{   . request buffer full status has been seen too many times
{   . any other unexpected status
{ If it cannot be queued because of server terminated, set terminated status and return.
{ If it cannot be queued because of request buffer full, set timeout status and then
{   . if the blocking request buffer entry belongs to the same queue as the executor of this code, return to
{     process the timeout status.
{   . if the blocking request buffer entry belongs to some other queue, wait a bit for the timeout to process,
{     and then attempt the queue request again.

    maximum_request_count := dfv$task_queue_timeout_interval DIV dfc$request_delay;

  /queue_request/
    WHILE TRUE DO { attempt to queue the request
      old_out := -1;
      status.normal := TRUE;

      REPEAT
        osp$begin_subsystem_activity;
        dfp$queue_request (p_queue_interface_table, queue_index,
              queue_entry_index, queue_request_status);
        osp$end_subsystem_activity;
        IF queue_request_status = dfc$qrs_request_buffer_full THEN
          new_out := dfp$current_rq_buffer_out_index (p_queue_interface_table);
          IF new_out = old_out THEN
            retry_count := retry_count + 1;
          ELSE
            retry_count := 0;
            old_out := new_out;
          IFEND;
          pmp$delay (dfc$request_delay, status);
          IF NOT status.normal THEN
            osp$system_error (' pmp$delay ERROR', ^status);
          IFEND;
        IFEND;
      UNTIL (queue_request_status <> dfc$qrs_request_buffer_full) OR
            (retry_count > (maximum_request_count DIV 2)); { core calls shouldn't wait as long as others }

      IF queue_request_status = dfc$qrs_entry_queued THEN
        RETURN;
      IFEND;

      IF queue_request_status = dfc$qrs_server_terminated THEN
        dfp$set_terminated_status (p_queue_interface_table, queue_index, status);
        RETURN;
      ELSEIF (queue_request_status = dfc$qrs_request_buffer_full) AND
            (retry_count > (maximum_request_count DIV 2)) THEN
        dfp$get_current_rq_buffer_entry (p_queue_interface_table, old_out, request_buffer_entry);

{  If queue_index is 0, request buffer entry has been freed since we last looked.

        request_buffer_queue_index := request_buffer_entry.queue_index;
        IF request_buffer_queue_index = 0 THEN
          CYCLE /queue_request/;
        IFEND;

        IF dfv$file_server_debug_enabled THEN
          message := ' DF- Partner mainframe ';
          message (24, *) := p_queue_interface_table^.queue_directory.cpu_queue_pva_directory
                [request_buffer_queue_index].p_cpu_queue^.queue_header.destination_mainframe_name;
          display_to_console (message);
          core_log_display (message);
          display_integer_to_console (' DF- Timing out queue, QI = ', request_buffer_queue_index);
          core_log_display_integer (' DF- Timing out queue, QI = ', request_buffer_queue_index);
        IFEND;
        dfp$set_queue_timed_out (p_queue_interface_table, request_buffer_queue_index, status);
        IF queue_index = request_buffer_queue_index THEN
          RETURN; { to process own timeout }
        IFEND;
      ELSE
        core_log_display_integer (' DF- Unexpected queue request status: ', $integer (queue_request_status));
        core_log_display_integer ('     Queue index: ', $integer (queue_index));
        osp$system_error (' UNEXPECTED QUEUE REQUEST STATUS ', NIL);
      IFEND;
      IF dfv$file_server_debug_enabled THEN
        display_integer_to_console (' DF- Waiting for request_buffer entry timeout, QI = ',
              request_buffer_queue_index);
      IFEND;
      core_log_display_integer (' DF- Waiting for request_buffer entry timeout, QI = ',
            request_buffer_queue_index);
      pmp$delay (dfc$timeout_delay, status)
    WHILEND /queue_request/;

  PROCEND dfp$queue_client_core_request;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc dfi$console_display
*copyc dfi$core_log_display
*copyc dfp$current_rq_buffer_out_index
*copyc dfp$get_current_rq_buffer_entry
*copyc dfp$queue_request
*copyc dfp$set_queue_timed_out
*copyc dfp$set_terminated_status
*copyc dft$request_buffer
*copyc dfv$file_server_debug_enabled
*copyc dfv$task_queue_timeout_interval
*copyc osp$begin_subsystem_activity
*copyc osp$end_subsystem_activity
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$delay
?? POP ??

*DECK DECK=DFP$QUEUE_CLIENT_TASK_REQUEST EXPAND=FALSE

  PROCEDURE [INLINE] dfp$queue_client_task_request
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
     VAR status: ost$status);

*copyc dfc$queue_request_constants

    VAR
      maximum_request_count: integer,
      message: string (40),
      new_out: integer,
      old_out: integer,
      queue_request_status: dft$queue_request_status,
      request_buffer_entry: dft$request_buffer_entry,
      request_buffer_queue_index: 0 .. 0FF(16),
      retry_count: integer;

{ Attempt to queue the request.  If it is queued, OK.  If it is not queued, keep trying until:
{   . it is queued
{   . request buffer full status has been seen too many times
{   . any other unexpected status
{ If it cannot be queued because of server terminated, set terminated status and return.
{ If it cannot be queued because of request buffer full, set timeout status and then
{   . if the blocking request buffer entry belongs to the same queue as the executor of this code, return to
{     process the timeout status.
{   . if the blocking request buffer entry belongs to some other queue, wait a bit for the timeout to process,
{     and then attempt to queue the request again.

    maximum_request_count := dfv$task_queue_timeout_interval DIV dfc$request_delay;

  /queue_request/
    WHILE TRUE DO { attempt to queue the request
      old_out := -1;
      status.normal := TRUE;

      REPEAT
        osp$begin_system_activity;
        dfp$queue_request (p_queue_interface_table, queue_index, queue_entry_index, queue_request_status);
        osp$end_system_activity;
        IF queue_request_status = dfc$qrs_request_buffer_full THEN
          new_out := dfp$current_rq_buffer_out_index (p_queue_interface_table);
          IF new_out = old_out THEN
            retry_count := retry_count + 1;
          ELSE
            retry_count := 0;
            old_out := new_out;
          IFEND;
          syp$wait (dfc$request_delay);
        IFEND;
      UNTIL (queue_request_status <> dfc$qrs_request_buffer_full) OR (retry_count > maximum_request_count);

      IF queue_request_status = dfc$qrs_entry_queued THEN
        RETURN;
      IFEND;

      IF queue_request_status = dfc$qrs_server_terminated THEN
        dfp$set_terminated_status (p_queue_interface_table, queue_index, status);
        RETURN;
      ELSEIF (queue_request_status = dfc$qrs_request_buffer_full) AND
            (retry_count > maximum_request_count) THEN
        dfp$get_current_rq_buffer_entry (p_queue_interface_table, old_out, request_buffer_entry);

{  If queue_index is 0, request buffer entry has been freed since we last looked.

        request_buffer_queue_index := request_buffer_entry.queue_index;
        IF request_buffer_queue_index = 0 THEN
          CYCLE /queue_request/;
        IFEND;

        IF dfv$file_server_debug_enabled THEN
          message := ' DF- Partner mainframe ';
          message (24, *) := p_queue_interface_table^.queue_directory.cpu_queue_pva_directory
                [request_buffer_queue_index].p_cpu_queue^.queue_header.destination_mainframe_name;
          display_to_console (message);
          log_display ($pmt$ascii_logset [pmc$system_log, pmc$job_log], message);
          display_integer_to_console (' DF- Timing out queue, QI = ', request_buffer_queue_index);
          log_display_integer ($pmt$ascii_logset [pmc$system_log, pmc$job_log],
               ' DF- Timing out queue, QI = ', request_buffer_queue_index);
        IFEND;
        dfp$set_queue_timed_out (p_queue_interface_table, request_buffer_queue_index, status);
        IF queue_index = request_buffer_queue_index THEN
          RETURN; { to process own timeout }
        IFEND;
      ELSE
        log_display_integer ($pmt$ascii_logset [pmc$system_log, pmc$job_log],
             ' DF- Unexpected queue request status: ', $integer (queue_request_status));
        log_display_integer ($pmt$ascii_logset [pmc$system_log, pmc$job_log],
             '     Queue index: ', $integer (queue_index));
        osp$system_error (' UNEXPECTED QUEUE REQUEST STATUS ', NIL);
      IFEND;
      IF dfv$file_server_debug_enabled THEN
        display_to_console (' DF- Queue_Client_Task_Request:');
        display_integer_to_console (' DF- Waiting for request_buffer entry timeout, QI = ',
              request_buffer_queue_index);
      IFEND;
      log_display ($pmt$ascii_logset [pmc$system_log, pmc$job_log],
           ' DF- Queue_Client_Task_Request: ');
      log_display_integer ($pmt$ascii_logset [pmc$system_log, pmc$job_log],
           ' DF- Waiting for request_buffer entry timeout, QI = ', request_buffer_queue_index);
      syp$wait (dfc$timeout_delay);
    WHILEND /queue_request/;

  PROCEND dfp$queue_client_task_request;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc dfi$console_display
*copyc dfi$log_display
*copyc dfp$current_rq_buffer_out_index
*copyc dfp$get_current_rq_buffer_entry
*copyc dfp$queue_request
*copyc dfp$set_queue_timed_out
*copyc dfp$set_terminated_status
*copyc dft$request_buffer
*copyc dfv$file_server_debug_enabled
*copyc dfv$task_queue_timeout_interval
*copyc osp$begin_system_activity
*copyc osp$end_system_activity
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc syp$wait
?? POP ??
*DECK DECK=DFP$QUEUE_INQUIRY_REQUEST EXPAND=FALSE
    PROCEDURE [XREF] dfp$queue_inquiry_request
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         inquiry_message: dft$inquiry_message;
    VAR queue_request_status: dft$queue_request_status);

?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dft$inquiry_message
*copyc dft$queue_index
*copyc dft$queue_request_status
?? POP ??
*DECK DECK=DFP$QUEUE_REQUEST EXPAND=FALSE
    PROCEDURE [XREF] dfp$queue_request
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
    VAR queue_request_status: dft$queue_request_status);

?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dft$queue_index
*copyc dft$queue_request_status
?? POP ??
*DECK DECK=DFP$QUEUE_SERVER_TASK_REQUEST EXPAND=FALSE

  PROCEDURE [INLINE] dfp$queue_server_task_request
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index);

*copyc dfc$queue_request_constants

    VAR
      maximum_request_count: integer,
      message: string (40),
      new_out: integer,
      old_out: integer,
      queue_request_status: dft$queue_request_status,
      request_buffer_entry: dft$request_buffer_entry,
      request_buffer_queue_index: 0 .. 0FF(16),
      retry_count: integer,
      status: ost$status;

{ Attempt to queue the request.  If it is queued, OK.  If it is not queued, keep trying until:
{   . it is queued
{   . request buffer full status has been seen too many times
{   . any other unexpected status
{ If it cannot be queued because of server terminated, set terminated status and abort.
{ If it cannot be queued because of request buffer full, set timeout status and then
{   . if the blocking request buffer entry belongs to the same queue as the executor of this code, abort to
{     process the timeout status.
{   . if the blocking request buffer entry belongs to some other queue, wait a bit for the timeout to process,
{     and then attempt to queue the request again.

    maximum_request_count := dfv$task_queue_timeout_interval DIV dfc$request_delay;

  /queue_request/
    WHILE TRUE DO { attempt to queue the request
      old_out := -1;
      status.normal := TRUE;

      REPEAT
        osp$begin_subsystem_activity;
        dfp$queue_request (p_queue_interface_table, queue_index, queue_entry_index, queue_request_status);
        osp$end_subsystem_activity;
        IF queue_request_status = dfc$qrs_request_buffer_full THEN
          new_out := dfp$current_rq_buffer_out_index (p_queue_interface_table);
          IF new_out = old_out THEN
            retry_count := retry_count + 1;
          ELSE
            retry_count := 0;
            old_out := new_out;
          IFEND;
          pmp$wait (dfc$request_delay, dfc$request_delay);
        IFEND;
      UNTIL (queue_request_status <> dfc$qrs_request_buffer_full) OR (retry_count > maximum_request_count);

      IF queue_request_status = dfc$qrs_entry_queued THEN
        RETURN;
      IFEND;

      IF queue_request_status = dfc$qrs_server_terminated THEN
        osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_active,
                p_queue_interface_table^.queue_directory.cpu_queue_pva_directory [queue_index].
                p_cpu_queue^.queue_header.destination_mainframe_name, status);
        pmp$abort (status);
      ELSEIF (queue_request_status = dfc$qrs_request_buffer_full) AND
            (retry_count > maximum_request_count) THEN
        dfp$get_current_rq_buffer_entry (p_queue_interface_table, old_out, request_buffer_entry);

{  If queue_index is 0, request buffer entry has been freed since we last looked.

        request_buffer_queue_index := request_buffer_entry.queue_index;
        IF request_buffer_queue_index = 0 THEN
          CYCLE /queue_request/;
        IFEND;

        IF dfv$file_server_debug_enabled THEN
          message := ' DF- Partner mainframe ';
          message (24, *) := p_queue_interface_table^.queue_directory.cpu_queue_pva_directory
                [request_buffer_queue_index].p_cpu_queue^.queue_header.destination_mainframe_name;
          display_to_console (message);
          log_display ($pmt$ascii_logset [pmc$system_log, pmc$job_log], message);
          display_integer_to_console (' DF- Timing out queue, QI = ', request_buffer_queue_index);
          log_display_integer ($pmt$ascii_logset [pmc$system_log, pmc$job_log],
               ' DF- Timing out queue, QI = ', request_buffer_queue_index);
        IFEND;
        dfp$set_queue_timed_out (p_queue_interface_table, request_buffer_queue_index, status);
        IF queue_index = request_buffer_queue_index THEN
          pmp$abort (status); { process own timeout }
        IFEND;
      ELSE
        log_display_integer ($pmt$ascii_logset [pmc$system_log, pmc$job_log],
             ' DF- Unexpected queue request status: ', $integer (queue_request_status));
        log_display_integer ($pmt$ascii_logset [pmc$system_log, pmc$job_log],
             '     Queue index: ', $integer (queue_index));
        osp$system_error (' UNEXPECTED QUEUE REQUEST STATUS ', NIL);
      IFEND;
      IF dfv$file_server_debug_enabled THEN
        display_to_console (' DF- Queue_Server_Task_Request:');
        display_integer_to_console (' DF- Waiting for request_buffer entry timeout, QI = ',
              request_buffer_queue_index);
      IFEND;
      log_display ($pmt$ascii_logset [pmc$system_log, pmc$job_log], ' DF- Queue_Server_Task_Request: ');
      log_display_integer ($pmt$ascii_logset [pmc$system_log, pmc$job_log],
           ' DF- Waiting for request_buffer entry timeout, QI = ', request_buffer_queue_index);
      pmp$wait (dfc$timeout_delay, dfc$timeout_delay);
    WHILEND;

  PROCEND dfp$queue_server_task_request;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc dfi$console_display
*copyc dfi$log_display
*copyc dfp$current_rq_buffer_out_index
*copyc dfp$get_current_rq_buffer_entry
*copyc dfp$queue_request
*copyc dfp$set_queue_timed_out
*copyc dft$request_buffer
*copyc dfv$file_server_debug_enabled
*copyc dfv$task_queue_timeout_interval
*copyc osp$begin_subsystem_activity
*copyc osp$end_subsystem_activity
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$abort
*copyc pmp$wait
?? POP ??
*DECK DECK=DFP$QUEUE_TASK_REQUEST EXPAND=FALSE

  PROCEDURE [INLINE] dfp$queue_task_request
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index);

*copyc dfc$queue_request_constants

    VAR
      maximum_request_count: integer,
      message: string (40),
      new_out: integer,
      old_out: integer,
      queue_request_status: dft$queue_request_status,
      request_buffer_entry: dft$request_buffer_entry,
      request_buffer_queue_index: 0 .. 0FF(16),
      retry_count: integer,
      status: ost$status;

{ Attempt to queue the request.  If it is queued, OK.  If it is not queued, keep trying until:
{   . it is queued
{   . request buffer full status has been seen too many times
{   . any other unexpected status
{ If it cannot be queued because of request buffer full, set timeout status and then
{   . if the blocking request buffer entry belongs to the same queue as the executor of this code, return to
{     process the timeout status.
{   . if the blocking request buffer entry belongs to some other queue, wait a bit for the timeout to process,
{     and then attempt to queue the request again.

    maximum_request_count := dfv$task_queue_timeout_interval DIV dfc$request_delay;

  /queue_request/
    WHILE TRUE DO { attempt to queue the request
      old_out := -1;
      status.normal := TRUE;

      REPEAT
        osp$begin_system_activity;
        dfp$queue_request (p_queue_interface_table, queue_index, queue_entry_index, queue_request_status);
        osp$end_system_activity;
        IF queue_request_status = dfc$qrs_request_buffer_full THEN
          new_out := dfp$current_rq_buffer_out_index (p_queue_interface_table);
          IF new_out = old_out THEN
            retry_count := retry_count + 1;
          ELSE
            retry_count := 0;
            old_out := new_out;
          IFEND;
          pmp$wait (dfc$request_delay, dfc$request_delay);
        IFEND;
      UNTIL (queue_request_status <> dfc$qrs_request_buffer_full) OR (retry_count > maximum_request_count);

      IF queue_request_status = dfc$qrs_entry_queued THEN
        RETURN;
      IFEND;

      IF (queue_request_status = dfc$qrs_request_buffer_full) AND
            (retry_count > maximum_request_count) THEN
        dfp$get_current_rq_buffer_entry (p_queue_interface_table, old_out, request_buffer_entry);

{  If queue_index is 0, request buffer entry has been freed since we last looked.

        request_buffer_queue_index := request_buffer_entry.queue_index;
        IF request_buffer_queue_index = 0 THEN
          CYCLE /queue_request/;
        IFEND;

        IF dfv$file_server_debug_enabled THEN
          message := ' DF- Partner mainframe ';
          message (24, *) := p_queue_interface_table^.queue_directory.cpu_queue_pva_directory
                [request_buffer_queue_index].p_cpu_queue^.queue_header.destination_mainframe_name;
          display_to_console (message);
          log_display ($pmt$ascii_logset [pmc$system_log, pmc$job_log], message);
          display_integer_to_console (' DF- Timing out queue, QI = ', request_buffer_queue_index);
          log_display_integer ($pmt$ascii_logset [pmc$system_log, pmc$job_log],
               ' DF- Timing out queue, QI = ', request_buffer_queue_index);
        IFEND;
        dfp$set_queue_timed_out (p_queue_interface_table, request_buffer_queue_index, status);
        IF queue_index = request_buffer_queue_index THEN
          RETURN; { to process own timeout }
        IFEND;
      ELSE
        log_display_integer ($pmt$ascii_logset [pmc$system_log, pmc$job_log],
             ' DF- Unexpected queue request status: ', $integer (queue_request_status));
        log_display_integer ($pmt$ascii_logset [pmc$system_log, pmc$job_log],
             '     Queue index: ', $integer (queue_index));
        osp$system_error (' UNEXPECTED QUEUE REQUEST STATUS ', NIL);
      IFEND;
      IF dfv$file_server_debug_enabled THEN
        display_to_console (' DF- Queue_Task_Request:');
        display_integer_to_console (' DF- Waiting for request_buffer entry timeout, QI = ',
              request_buffer_queue_index);
      IFEND;
      log_display ($pmt$ascii_logset [pmc$system_log, pmc$job_log], ' DF- Queue_Task_Request: ');
      log_display_integer ($pmt$ascii_logset [pmc$system_log, pmc$job_log],
           ' DF- Waiting for request_buffer entry timeout, QI = ', request_buffer_queue_index);
      pmp$wait (dfc$timeout_delay, dfc$timeout_delay);
    WHILEND /queue_request/;

  PROCEND dfp$queue_task_request;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfi$console_display
*copyc dfi$log_display
*copyc dfp$current_rq_buffer_out_index
*copyc dfp$get_current_rq_buffer_entry
*copyc dfp$queue_request
*copyc dfp$set_queue_timed_out
*copyc dft$request_buffer
*copyc dfv$file_server_debug_enabled
*copyc dfv$task_queue_timeout_interval
*copyc osp$begin_system_activity
*copyc osp$end_system_activity
*copyc osp$system_error
*copyc pmp$wait
?? POP ??
*DECK DECK=DFP$R1_TIMEOUT_SERVER_FILES EXPAND=FALSE
  PROCEDURE [XREF] dfp$r1_timeout_server_files
    (    server_mainframe_id: pmt$binary_mainframe_id;
         p_server_state : ^dft$server_state;
     VAR image_file_id: dft$image_file_id;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
*copyc dft$image_file_id
*copyc dft$server_state
*copyc ost$status
?? POP ??
*DECK DECK=DFP$R2_CHECK_JOB_RECOVERY EXPAND=FALSE

PROCEDURE [XREF] dfp$r2_check_job_recovery (VAR recovery_occurred: boolean);
*DECK DECK=DFP$REBUILD_CLIENT_MAINFRAMES EXPAND=FALSE
 PROCEDURE [XREF] dfp$rebuild_client_mainframes;
*DECK DECK=DFP$REBUILD_SERVED_FAMILY_TABLE EXPAND=FALSE
  PROCEDURE [XREF] dfp$rebuild_served_family_table
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DFP$REBUILD_SET_TABLE_CLIENTS EXPAND=FALSE
  PROCEDURE [XREF] dfp$rebuild_set_table_clients
    (    family: ost$family_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=DFP$RECEIVE_CLIENT_RPC_SEGMENT EXPAND=FALSE
  PROCEDURE [XREF] dfp$receive_client_rpc_segment
    (VAR p_seq: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DFP$RECEIVE_REMOTE_CALL EXPAND=FALSE
  PROCEDURE [XREF] dfp$receive_remote_call
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
         p_driver_queue_entry: ^dft$driver_queue_entry;
         p_cpu_queue_entry: ^dft$cpu_queue_entry;
         action_for_server: dft$action_for_server;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dft$action_for_server
*copyc ost$status
?? POP ??
*DECK DECK=DFP$RECEIVE_SERVER_RPC_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] dfp$receive_server_rpc_segment
    (    queue_entry_location: dft$rpc_queue_entry_location;
         server_segment_offset: ost$segment_length;
         request_size: ost$segment_length;
     VAR p_client_segment: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_queue_entry_location
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=DFP$RECORD_SERVER_TRANSLATION EXPAND=FALSE
  PROCEDURE [INLINE] dfp$record_server_translation
    (    server_mainframe_id: pmt$binary_mainframe_id);

    VAR
      mainframe_id_ordinal: 1 .. dfc$max_number_of_mainframes,
      null_mainframe_id: pmt$binary_mainframe_id,
      server_found: boolean;

    dfp$locate_server_translation (server_mainframe_id, mainframe_id_ordinal,
          server_found);
    IF NOT server_found THEN
      { Search for a free slot and initialize it.
      null_mainframe_id.model_number := osc$cyber_180_model_unknown;
      null_mainframe_id.serial_number := 0;
      dfp$locate_server_translation (null_mainframe_id, mainframe_id_ordinal,
            server_found);
      IF server_found THEN
        dfv$defined_server_translation [mainframe_id_ordinal] :=
              server_mainframe_id;
      ELSE {  Too many mainframes
        i#program_error;
      IFEND;
    IFEND;
  PROCEND dfp$record_server_translation;
?? PUSH (LISTEXT := ON) ??
*copyc dfc$esm_allocation_constants
*copyc dfp$locate_server_translation
*copyc dfv$defined_server_translation
*copyc i#program_error
*copyc pmt$binary_mainframe_id
?? POP ??

*DECK DECK=DFP$RECORD_TRANSACTION_DATA EXPAND=FALSE
  PROCEDURE {INLINE} dfp$record_transaction_data
    (    driver_queue_entry: dft$driver_queue_entry;
         cpu_queue_entry: dft$cpu_queue_entry;
     VAR transaction_data: dft$transaction_data);

    VAR
      actual: integer,
      p_command_buffer: dft$p_command_buffer,
      p_buffer_header: ^dft$buffer_header;

   { The initial value is set arbitrarily, since the osp$add_to_locked_variable
   { will then pick up the correct value.  This avoids doing a call to
   { read the variable.

    IF (cpu_queue_entry.transaction_state = dfc$server_received_request) OR
       (cpu_queue_entry.transaction_state = dfc$response_received) THEN
      osp$add_to_locked_variable (transaction_data.total_transaction_count,
          { Initial guess = } 227, 1, actual);
    IFEND;

    IF driver_queue_entry.flags.buffer_sent THEN
      osp$add_to_locked_variable (
            transaction_data.total_buffer_length_sent, { Initial guess = } 227,
            driver_queue_entry.send_buffer_descriptor.actual_length, actual);
    IFEND;
    IF driver_queue_entry.flags.data_sent THEN
      osp$add_to_locked_variable (
            transaction_data.total_data_pages_sent, { Initial guess = } 227,
            (driver_queue_entry.data_descriptor.actual_length DIV 8), actual);
    IFEND;

    { IF driver_queue_entry.flags.buffer_received THEN
    {   p_command_buffer := cpu_queue_entry.p_receive_buffer;
    {   RESET p_command_buffer;
    {   NEXT p_buffer_header IN p_command_buffer;
    {   osp$add_to_locked_variable
    { (transaction_data.total_buffer_length_received, transaction_data.
    {         total_buffer_length_received,
    { p_buffer_header^.buffer_length_sent, actual);
    { IFEND;

    IF driver_queue_entry.flags.data_received THEN
      osp$add_to_locked_variable (
            transaction_data.total_data_pages_received, { Initial guess = } 227,
            (driver_queue_entry.data_descriptor.actual_length DIV 8), actual);

    IFEND;
  PROCEND dfp$record_transaction_data;
?? PUSH (LISTEXT := ON) ??
*copyc osp$add_to_locked_variable
*copyc osp$add_to_locked_variable
*copyc dfd$driver_queue_types
*copyc dfd$request_package
*copyc dft$cpu_queue
*copyc dft$transaction_state
?? POP ??




*DECK DECK=DFP$RECOVER_CLIENT_MAINFRAMES EXPAND=FALSE

  PROCEDURE [XREF] dfp$recover_client_mainframes
    (VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DFP$RECOVER_FILE_SERVER EXPAND=FALSE

  PROCEDURE [XREF] dfp$recover_file_server
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??


*DECK DECK=DFP$RECOVER_JOB EXPAND=FALSE
  PROCEDURE [XREF] dfp$recover_job
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=DFP$RECOVER_JOBS_SERVERS EXPAND=FALSE

  PROCEDURE [XREF] dfp$recover_jobs_servers (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DFP$RECOVER_SERVER_MAINFRAMES EXPAND=FALSE

  PROCEDURE [XREF] dfp$recover_server_mainframes
    (VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DFP$REGISTER_CLIENT_JOB EXPAND=FALSE

  PROCEDURE [XREF] dfp$register_client_job
    (    user_id: ost$user_identification;
         account_name: avt$account_name;
         project_name: avt$project_name;
         system_supplied_job_name: jmt$system_supplied_name;
         user_supplied_job_name: jmt$user_supplied_name;
         job_mode: jmt$job_mode;
         family_access_kind: dft$family_access_kinds;
         job_lifetime: dft$lifetime;
         p_client_mainframe_file: ^dft$client_mainframe_file;
     VAR client_job_id: dft$client_job_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avt$account_name
*copyc avt$project_name
*copyc dft$client_job_id
*copyc dft$client_mainframe_file
*copyc dft$lifetime
*copyc jmt$job_mode
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=DFP$REGISTER_SERVED_FAMILIES EXPAND=FALSE
  PROCEDURE [XREF] dfp$register_served_families
    (    family_list: dft$family_list;
         family_access: dft$family_access;
         client_definition: boolean;
         p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc dft$family_access
*copyc dft$family_list
*copyc dft$queue_index
*copyc ost$status
?? POP ??
*DECK DECK=DFP$RELEASE_QUEUE_ENTRY EXPAND=FALSE
   PROCEDURE [XREF] dfp$release_queue_entry
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
     VAR release_status: dft$release_queue_entry_status);
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dft$queue_index
*copyc dft$release_queue_entry_status
?? POP ??
*DECK DECK=DFP$RELEASE_SERVER_DESCRIPTOR EXPAND=FALSE

  PROCEDURE [INLINE] dfp$release_server_descriptor
    (    fde_p: gft$file_desc_entry_p);

    VAR
      server_descriptor_p: dft$server_descriptor_p;

    dfp$get_served_file_desc_p (fde_p, server_descriptor_p);
    IF server_descriptor_p <> NIL THEN
      FREE server_descriptor_p IN osv$mainframe_wired_heap^;
      fde_p^.served_file_descriptor_p := 0;
    IFEND;

  PROCEND dfp$release_server_descriptor;

?? PUSH (LISTEXT := ON) ??
*copyc gft$file_descriptor_entry
*copyc dfp$get_served_file_desc_p
*copyc osv$mainframe_wired_heap
?? POP ??
*DECK DECK=DFP$RELEASE_TASK_QUEUE_ENTRY EXPAND=FALSE
  PROCEDURE [INLINE] dfp$release_task_queue_entry
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
         queue_entry_index: dft$queue_entry_index;
     VAR status: ost$status);

    VAR
      release_status: dft$release_queue_entry_status;

    dfp$release_queue_entry (p_queue_interface_table, queue_index,
          queue_entry_index, release_status);
    IF release_status = dfc$rqes_entry_released THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (dfc$file_server_id, dfe$release_q_entry_error,
            '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $integer(release_status),
            10, FALSE, status);
    IFEND;

  PROCEND dfp$release_task_queue_entry;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc dft$queue_index
*copyc dfp$release_queue_entry
*copyc osp$append_status_integer
*copyc osp$set_status_abnormal
*copyc ost$status
?? POP ??

*DECK DECK=DFP$REMOVE_CLIENT_JOBS EXPAND=FALSE
  PROCEDURE [XREF] dfp$remove_client_jobs
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$mainframe_id
*copyc ost$status
?? POP ??
*DECK DECK=DFP$REPORT_DRIVER_ERROR_ALERT EXPAND=FALSE

  PROCEDURE [INLINE] dfp$report_driver_error_alert
    (    p_driver_queue_entry: ^dft$driver_queue_entry;
     VAR status: ost$status);

    osp$set_status_abnormal (dfc$file_server_id, dfe$driver_error_occurred, '',
          status);
    osp$append_status_integer (osc$status_parameter_delimiter,
          p_driver_queue_entry^.error_condition, 16, TRUE, status);
    osp$recoverable_system_error (' FILE SERVER DRIVER ERROR', ^status);

  PROCEND dfp$report_driver_error_alert;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc osp$append_status_integer
*copyc osp$recoverable_system_error
*copyc osp$set_status_abnormal
?? POP ??

*DECK DECK=DFP$RESERVE_SERVER_RPC_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] dfp$reserve_server_rpc_segment
    (VAR p_seq: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DFP$RESET_MAINFRAME_TABLES EXPAND=FALSE
  PROCEDURE [XREF] dfp$reset_mainframe_tables
    (    mainframe_name: pmt$mainframe_id;
         host_is_server_to_client: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=DFP$RESUME_PP EXPAND=FALSE
  PROCEDURE [XREF] dfp$resume_pp
  (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
   VAR status: ost$status );

*copyc dft$queue_interface_directory
*copyc ost$status
*DECK DECK=DFP$RETURN_APPLICATION_LIBRARY EXPAND=FALSE
  PROCEDURE [XREF] dfp$return_application_library
    (    p_cpu_queue: ^dft$cpu_queue);

?? PUSH (LISTEXT := ON) ??
*copyc dft$cpu_queue
?? POP ??
*DECK DECK=DFP$RETURN_ESMS_DEFINED EXPAND=FALSE

  PROCEDURE [XREF] dfp$return_esms_defined
    (VAR esms_defined: dft$esms_defined_count;
     VAR esm_name_array: dft$esms_defined);

?? PUSH (LISTEXT := ON) ??
*copyc dft$esms_defined
?? POP ??
*DECK DECK=DFP$RETURN_ESM_BASE_ADDRESSES EXPAND=FALSE

  PROCEDURE [XREF] dfp$return_esm_base_addresses
    (    element_name: cmt$element_name;
     VAR esm_base_addresses: dft$esm_base_addresses;
     VAR status: ost$status);

*copyc cmt$element_name
*copyc dfd$driver_queue_types
*copyc ost$status
*DECK DECK=DFP$RETURN_ESM_DEFINITION EXPAND=FALSE

  PROCEDURE [XREF] dfp$return_esm_definition
    (    element: cmt$element_descriptor;
     VAR definition: cmt$esm_definition;
     VAR status: ost$status);

*copyc cmt$element_descriptor
*copyc cmt$esm_definition
*copyc ost$status

*DECK DECK=DFP$RETURN_FAMILY_SERVED EXPAND=FALSE

  PROCEDURE [XREF] dfp$return_family_served
    (    family_name: ost$name;
     VAR family_served: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=DFP$SAVE_SERVER_IMAGE EXPAND=FALSE

  PROCEDURE [XREF] dfp$save_server_image
    (    mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=DFP$SEND_ALLOCATE_RESPONSE EXPAND=FALSE

  PROCEDURE [XREF] dfp$send_allocate_response
    (    p_server_iocb: ^mmt$server_iocb_entry;
         io_id: mmt$io_identifier;
     VAR cpio_status: mmt$file_server_io_status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$file_server_io_status
*copyc mmt$io_identifier
*copyc mmt$server_io_control_block
?? POP ??
*DECK DECK=DFP$SEND_APPLICATION_RPC EXPAND=FALSE

  PROCEDURE [XREF] dfp$send_application_rpc
    (    queue_entry_location: dft$rpc_queue_entry_location;
         application_name: ost$name;
         procedure_name: pmt$program_name;
         send_to_server_params_size: dft$send_parameter_size;
         data_size_to_send_to_server: dft$send_data_size;
     VAR p_receive_from_server_params: dft$p_receive_parameters;
     VAR p_receive_data: dft$p_receive_data;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dft$rpc_parameters
*copyc dft$rpc_queue_entry_location
*copyc dft$server_location
*copyc dft$server_location_selector
*copyc ost$name
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=DFP$SEND_CLIENT_RPC_SEGMENT EXPAND=FALSE
  PROCEDURE [XREF] dfp$send_client_rpc_segment
    (    queue_entry_location: dft$rpc_queue_entry_location;
         p_client_segment: ^SEQ ( * );
         server_segment_offset: ost$segment_length;
         request_size: ost$segment_length;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_queue_entry_location
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=DFP$SEND_MESSAGE_TO_OPERATOR EXPAND=FALSE

  PROCEDURE dfp$send_message_to_operator
    (    message: string ( * <= 125);
         server_to_client: boolean;
         mainframe_name: pmt$mainframe_id);

    PROCEDURE scan_backwards_for_non_blank
      (    line_image: string ( * <= 255);
       VAR non_blank_found: boolean;
       VAR character_position: integer;
       VAR character_found: char);

      non_blank_found := FALSE;

    /search_backwards/
      FOR character_position := STRLENGTH (line_image) DOWNTO 1 DO
        IF line_image (character_position) <> ' ' THEN
          non_blank_found := TRUE;
          character_found := line_image (character_position);
          RETURN;
        IFEND;
      FOREND /search_backwards/;
    PROCEND scan_backwards_for_non_blank;

    VAR
      destination_log: pmt$ascii_logset,
      ignore_boolean: boolean,
      ignore_character: char,
      ignore_status: ost$status,
      message_length: integer,
      operator_message: string (125);

    destination_log := $pmt$ascii_logset [pmc$system_log, pmc$job_log];
    IF server_to_client THEN
      STRINGREP (operator_message, message_length, ' Client ', mainframe_name,
            ':');
    ELSE
      STRINGREP (operator_message, message_length, ' Server ', mainframe_name,
            ':');
    IFEND;
    dpp$put_next_line (dpv$system_core_display,
          operator_message (1, message_length), ignore_status);
    pmp$log_ascii (operator_message (1, message_length), destination_log,
          pmc$msg_origin_system, ignore_status);
    scan_backwards_for_non_blank (message, ignore_boolean, message_length,
          ignore_character);
    dpp$put_next_line (dpv$system_core_display, message (1, message_length),
          ignore_status);
    pmp$log_ascii (message (1, message_length), destination_log,
          pmc$msg_origin_program, ignore_status);

  PROCEND dfp$send_message_to_operator;

?? PUSH (LISTEXT := ON) ??
*copyc dpp$put_next_line
*copyc dpv$system_core_display
*copyc pmp$log_ascii
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=DFP$SEND_REMOTE_CORE_CALL EXPAND=FALSE
  PROCEDURE [XREF] dfp$send_remote_core_call
    (    queue_entry_location: dft$rpc_queue_entry_location;
         procedure_ordinal: dft$procedure_address_ordinal;
         send_to_server_params_size: dft$send_parameter_size;
     VAR p_receive_from_server_params: dft$p_receive_parameters;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$procedure_address_ordinal
*copyc dft$rpc_parameters
*copyc dft$rpc_queue_entry_location
*copyc ost$status
?? POP ??
*DECK DECK=DFP$SEND_REMOTE_PROCEDURE_CALL EXPAND=FALSE

  PROCEDURE [XREF] dfp$send_remote_procedure_call
    (    queue_entry_location: dft$rpc_queue_entry_location;
         procedure_ordinal: dft$procedure_address_ordinal;
         send_to_server_params_size: dft$send_parameter_size;
         data_size_to_send_to_server: dft$send_data_size;
     VAR p_receive_from_server_params: dft$p_receive_parameters;
     VAR p_receive_data: dft$p_receive_data;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dft$procedure_address_ordinal
*copyc dft$rpc_parameters
*copyc dft$rpc_queue_entry_location
*copyc dft$server_location
*copyc dft$server_location_selector
*copyc ost$status
?? POP ??
*DECK DECK=DFP$SEND_WRITE_RESPONSE EXPAND=FALSE
      PROCEDURE [XREF] dfp$send_write_response
    (    p_server_iocb: ^mmt$server_iocb_entry;
         io_id: mmt$io_identifier;
     VAR cpio_status: mmt$file_server_io_status);
?? push (listext := on) ??
*copyc mmt$file_server_io_status
*copyc mmt$io_identifier
*copyc mmt$server_io_control_block
?? pop ??
*DECK DECK=DFP$SERVER_IO EXPAND=FALSE
{ Xref deck for dfp$server_io.

  PROCEDURE [XREF] dfp$server_io (
    fde_p: gft$locked_file_desc_entry_p;
    io_type: iot$io_function;
    segment_offset: ost$segment_offset;
    segment_length: ost$segment_length;
    io_id: mmt$io_identifier;
    buffer_descriptor: mmt$buffer_descriptor;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$IO_FUNCTION
*copyc gft$locked_file_desc_entry_p
*copyc OST$HARDWARE_SUBRANGES
*copyc MMT$BUFFER_DESCRIPTOR
*copyc IOT$IO_FUNCTION
*copyc OSD$VIRTUAL_ADDRESS
*copyc MMT$IO_IDENTIFIER
?? POP ??

*DECK DECK=DFP$SET_CLIENT_JOB_ENVIRONMENT EXPAND=FALSE
  PROCEDURE [XREF] dfp$set_client_job_environment
    (    client_job_id: dft$client_job_id;
         system_administrator: boolean;
         family_administrator: boolean;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc dft$client_job_id
*copyc ost$status
?? POP ??

*DECK DECK=DFP$SET_CLIENT_MF_FILE_INFO EXPAND=FALSE

  PROCEDURE [XREF] dfp$set_client_mf_file_info
    (    client_mainframe_id: pmt$binary_mainframe_id;
         server_state: dft$server_state;
         server_lifetime: dft$server_lifetime;
         server_birthdate: integer;
     VAR client_found: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dft$server_lifetime
*copyc dft$server_state
*copyc pmt$binary_mainframe_id
?? POP ??

*DECK DECK=DFP$SET_DRIVER_ACTIVE EXPAND=FALSE
  PROCEDURE [XREF] dfp$set_driver_active
    (    driver_name: ost$name;
         driver_active: boolean;
     VAR status: ost$status);
*copyc ost$name
*copyc ost$status
*DECK DECK=DFP$SET_ENTRY_ASSIGNMENT EXPAND=FALSE
  PROCEDURE [INLINE] dfp$set_entry_assignment
    (    entry_assignment: integer;
     VAR queue_assignment_string {input, output} : string ( * <= 255));

    CONST
      swap_successful = 0;

    VAR
      actual_word: string (8),
      char_index_in_word: integer,
      found_word: string (8),
      found_word_starting_char: integer,
      p_test: ^string (8),
      result: 0 .. 2,
      swap_in_word: string (8),
      word_index: integer;


  /swap_in_assignment/
    REPEAT
      found_word_starting_char := ((entry_assignment - 1) DIV 8) * 8 + 1;
      #SPOIL (queue_assignment_string);
      osp$fetch_locked_string (queue_assignment_string
            (found_word_starting_char, 8), found_word);
      #SPOIL (queue_assignment_string);
      swap_in_word := found_word;
      word_index := (entry_assignment MOD 8);
      IF word_index = 0 THEN
        word_index := 8;
      IFEND;
      found_word (word_index) := dfc$free_entry_char;
      swap_in_word (word_index) := dfc$assigned_entry_char;
      #SPOIL (queue_assignment_string);
      { Required due to cybil bug.
      p_test := ^queue_assignment_string (found_word_starting_char, 8);
      #COMPARE_SWAP (p_test^, found_word, swap_in_word, actual_word, result);
      #SPOIL (queue_assignment_string);
    UNTIL result = swap_successful;
  PROCEND dfp$set_entry_assignment;
?? PUSH (LISTEXT := ON) ??
*copyc dft$entry_type
*copyc osp$fetch_locked_string
?? POP ??
*DECK DECK=DFP$SET_ESM_DIVISIONS EXPAND=FALSE
  PROCEDURE [XREF] dfp$set_esm_divisions
  (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
       number_of_divisions: dft$divisions_per_mainframe;
   VAR status: ost$status );

*copyc dft$queue_interface_directory
*copyc ost$status
*DECK DECK=DFP$SET_INVALID_FAMILY_INDEX EXPAND=FALSE
  PROCEDURE [INLINE] dfp$set_invalid_family_index
    (    served_family_table_index: dft$served_family_table_index;
         request: string ( * <= 31);
     VAR status: ost$status);

    osp$set_status_abnormal (dfc$file_server_id, dfe$invalid_served_family_index, request, status);
    osp$append_status_integer (osc$status_parameter_delimiter, served_family_table_index.pointers_index, 10,
          FALSE, status);
    osp$append_status_integer (osc$status_parameter_delimiter, served_family_table_index.family_list_index,
          10, FALSE, status);
  PROCEND dfp$set_invalid_family_index;
?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc osp$set_status_abnormal
*copyc osp$append_status_integer
*copyc dft$served_family_table_index
?? POP ??
*DECK DECK=DFP$SET_JOB_VALIDATION_CHANGE EXPAND=FALSE
  PROCEDURE [XREF] dfp$set_job_validation_change;

*DECK DECK=DFP$SET_MESSAGE_CONTENT_ERROR EXPAND=FALSE
{
{  This procedure is provided for the SERVER side to force a retransmission
{ when the server detects command buffer data that appears to be bad, for
{ example as a result of an undetected hardware error, or as a result of
{ a software error.  The request is re-sent from the client side.
{ If too many (as determined by maximum_retransmission_count) of these occur
{ consecutively for a given queue entry the whole connection will be timed-out.
{
  PROCEDURE [INLINE] dfp$set_message_content_error
    (    p_cpu_queue_entry: ^dft$cpu_queue_entry;
         p_driver_queue_entry: ^dft$driver_queue_entry);

    log_display_integer ($pmt$ascii_logset [pmc$system_log, pmc$job_log],
          ' File Server - Message content error transaction:',
          p_cpu_queue_entry^.transaction_count);
    p_cpu_queue_entry^.transaction_state := dfc$message_content_error;
    dfp$clear_server_driver_flags (p_driver_queue_entry);
    IF dfv$file_server_debug_enabled THEN
      display_pva (' File server - message content error - cpu ',
            p_cpu_queue_entry);
      display_pva (' p_driver_queue ', p_driver_queue_entry);
      osp$system_error (' FILE SERVER MESSAGE CONTENT ERROR ', NIL);
    IFEND;

  PROCEND dfp$set_message_content_error;
?? PUSH (LISTEXT := ON) ??
*copyc dfi$display
*copyc dfp$clear_server_driver_flags
*copyc dfv$file_server_debug_enabled
*copyc dfi$log_display
*copyc osp$system_error
?? POP ??
*DECK DECK=DFP$SET_MONITOR_ENTRY_ALERT EXPAND=FALSE

  PROCEDURE [INLINE] dfp$set_monitor_entry_alert
    (    queue_entry_location: dft$queue_entry_location);

    VAR
      p_cpu_queue_entry: ^dft$cpu_queue_entry,
      p_cpu_queue_header: ^dft$cpu_queue_header,
      p_driver_queue_entry: ^dft$driver_queue_entry,
      p_queue_interface_table: dft$p_queue_interface_table,
      status: syt$monitor_status;

    dfp$get_qit_p_from_direct_index (queue_entry_location.directory_index, p_queue_interface_table);
    p_cpu_queue_header := ^p_queue_interface_table^.
          queue_directory.cpu_queue_pva_directory
          [queue_entry_location.queue_index].p_cpu_queue^.queue_header;
    dfp$set_entry_assignment (queue_entry_location.queue_entry_index,
          p_cpu_queue_header^.queue_entry_assignment_table);

    dfp$fetch_queue_entry (p_queue_interface_table, queue_entry_location.queue_index, queue_entry_location.
          queue_entry_index, p_driver_queue_entry, p_cpu_queue_entry);
    IF (p_cpu_queue_header^.partner_status.server_state = dfc$terminated) OR
      (p_cpu_queue_header^.partner_status.server_state = dfc$awaiting_recovery) THEN
      { In these states we do extra checking to make sure the monitor task
      { has not aborted or terminated.
      tmp$check_taskid (p_cpu_queue_entry^.global_task_id, tmc$opt_return, status);
      IF NOT status.normal THEN
        p_cpu_queue_entry^.p_server_iocb^.condition := dfc$server_terminated;
        p_cpu_queue_entry^.p_server_iocb^.server_state := mmc$ss_waiting;
        display_integer_monitor (' File Server Monitor Task Unavailable - Q ',
           queue_entry_location.queue_index);
        display_integer_monitor (' Queue entry ',
           queue_entry_location.queue_entry_index);
        RETURN;
      IFEND;
    IFEND;
    p_driver_queue_entry^.flags.subsystem_action := TRUE;
    tmp$set_task_ready (p_cpu_queue_entry^.global_task_id, 0 {readying_task_priority},
          tmc$rc_ready_conditional_wi);
  PROCEND dfp$set_monitor_entry_alert;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfi$monitor_display
*copyc dft$queue_entry_location
*copyc dfp$fetch_queue_entry
*copyc dfp$get_qit_p_from_direct_index
*copyc dfp$set_entry_assignment
*copyc mtp$error_stop
*copyc tmp$check_taskid
*copyc tmp$set_task_ready
?? POP ??

*DECK DECK=DFP$SET_QUEUE_TIMED_OUT EXPAND=FALSE

{ This procedure sets a particular queue's partner as "timed-out" and returns a status indicating the
{ corresponding server mainframe is not active.

  PROCEDURE [INLINE] dfp$set_queue_timed_out
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
     VAR status: ost$status);

    VAR
      p_cpu_queue_header: ^dft$cpu_queue_header,
      server_mainframe: pmt$mainframe_id;

    p_cpu_queue_header := ^p_queue_interface_table^.queue_directory.
          cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header;
    server_mainframe := p_cpu_queue_header^.destination_mainframe_name;
    p_cpu_queue_header^.partner_status.timeout_partner := TRUE;
    osp$set_status_abnormal (dfc$file_server_id, dfe$task_services_timeout, server_mainframe, status);

  PROCEND dfp$set_queue_timed_out;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc dft$cpu_queue
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=DFP$SET_READ_LOCK EXPAND=FALSE

  PROCEDURE [INLINE] dfp$set_read_lock
    (VAR read_write_lock:{Input, Output} dft$read_write_lock);

    VAR
      already_zero: boolean,
      ignored_status: ost$status,
      new_value: integer,
      temp_writer_count: integer,
      writer_count: integer;

  /increment_read_count/
    REPEAT
      osp$increment_locked_variable (
            read_write_lock.reader_count, { Best guess = } 0, new_value);
      osp$fetch_locked_variable (read_write_lock.writer_count, writer_count);
      IF writer_count > 0 THEN
        osp$increment_locked_variable (
              read_write_lock.reject_count, {Best guess = } 0, new_value);
        osp$decrement_locked_variable (read_write_lock.reader_count,
              { Best guess = } 1, new_value, already_zero);
        IF already_zero THEN
          osp$system_error (' READ LOCK ALREADY ZERO ', NIL);
        IFEND;

      /wait_for_writer_completion/
        REPEAT
          pmp$delay ({milliseconds} 2, ignored_status);
          osp$fetch_locked_variable (read_write_lock.writer_count,
                temp_writer_count);
        UNTIL (temp_writer_count = 0);
      IFEND;
    UNTIL (writer_count = 0);

    osp$begin_system_activity;
  PROCEND dfp$set_read_lock;
?? PUSH (LISTEXT := ON) ??
*copyc dft$read_write_lock
*copyc osp$begin_system_activity
*copyc osp$decrement_locked_variable
*copyc osp$fetch_locked_variable
*copyc osp$increment_locked_variable
*copyc osp$system_error
*copyc ost$status
*copyc pmp$delay
?? POP ??
*DECK DECK=DFP$SET_SERVER_EOI EXPAND=FALSE

  PROCEDURE [XREF] dfp$set_server_eoi
    (    sfid: gft$system_file_identifier;
         segment_length: ost$segment_length;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=DFP$SET_TASK_SEGMENT_STATE EXPAND=FALSE
  PROCEDURE [XREF] dfp$set_task_segment_state
    (    search: tmt$fnx_search_type;
         ijle_p: ^jmt$initiated_job_list_entry;
         ijlo: jmt$ijl_ordinal;
         inhibit_access_work: dft$mainframe_set;
         terminate_access_work: dft$mainframe_set);

?? PUSH (LISTEXT := ON) ??
*copyc dft$mainframe_set
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc tmt$fnx_search_type
?? POP ??
*DECK DECK=DFP$SET_TERMINATED_ACCESS_STATE EXPAND=FALSE
  PROCEDURE [XREF] dfp$set_terminated_access_state
    (    server_mainframe_id: pmt$binary_mainframe_id);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=DFP$SET_TERMINATED_MTR_STATUS EXPAND=FALSE

  PROCEDURE [INLINE] dfp$set_terminated_mtr_status
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
     VAR status: syt$monitor_status);

    VAR
      p_cpu_queue_header: ^dft$cpu_queue_header;

    p_cpu_queue_header := ^p_queue_interface_table^.queue_directory.
          cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header;
    status.normal := FALSE;
    IF (p_cpu_queue_header^.partner_status.server_state = dfc$terminated) THEN
      status.condition := dfe$server_has_terminated;
    ELSE
      { dfe$server_not_active,
      status.condition := ioe$unit_disabled;
    IFEND;

  PROCEND dfp$set_terminated_mtr_status;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc dft$cpu_queue
*copyc ioe$st_errors
*copyc syt$monitor_status
?? POP ??
*DECK DECK=DFP$SET_TERMINATED_STATUS EXPAND=FALSE
  PROCEDURE dfp$set_terminated_status
    (    p_queue_interface_table: dft$p_queue_interface_table;
         queue_index: dft$queue_index;
     VAR status: ost$status);

    VAR
      p_cpu_queue_header: ^dft$cpu_queue_header,
      server_mainframe: pmt$mainframe_id;

    p_cpu_queue_header := ^p_queue_interface_table^.queue_directory.
          cpu_queue_pva_directory [queue_index].p_cpu_queue^.queue_header;
    server_mainframe := p_cpu_queue_header^.destination_mainframe_name;
    IF (p_cpu_queue_header^.partner_status.server_state =
          dfc$terminated) AND (NOT p_cpu_queue_header^.partner_status.
          users_wait_on_terminated_server) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated,
            server_mainframe, status);
    ELSE
      osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_active,
          server_mainframe, status);
    IFEND;

  PROCEND dfp$set_terminated_status;
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dft$cpu_queue
*copyc dfe$error_condition_codes
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??













*DECK DECK=DFP$SET_WRITE_LOCK EXPAND=FALSE
  PROCEDURE [INLINE] dfp$set_write_lock
    (VAR read_write_lock: {Input, Output} dft$read_write_lock);

    VAR
      new_value: integer,
      reader_count: integer,
      reject_incremented: boolean,
      status: ost$status;

    reject_incremented := FALSE;
    osp$increment_locked_variable (
          read_write_lock.writer_count, { Best Guess = } 0, new_value);
    REPEAT
      osp$fetch_locked_variable (read_write_lock.reader_count, reader_count);
      IF reader_count > 0 THEN
        IF NOT reject_incremented THEN
          osp$increment_locked_variable (
                read_write_lock.reject_count, { Best Guess = } 0, new_value);
          reject_incremented := TRUE;
        IFEND;
        pmp$delay (2, status);
      IFEND;
    UNTIL (reader_count = 0);
    osp$set_signature_lock (read_write_lock.write_lock, osc$wait, status);
    IF NOT status.normal THEN
      osp$system_error ('ERROR SETTING WRITE LOCK', ^status);
    IFEND;
    osp$begin_system_activity;
  PROCEND dfp$set_write_lock;
?? PUSH (LISTEXT := ON) ??
*copyc dft$read_write_lock
*copyc osp$begin_system_activity
*copyc osp$decrement_locked_variable
*copyc osp$fetch_locked_variable
*copyc osp$increment_locked_variable
*copyc osp$set_signature_lock
*copyc osp$system_error
*copyc ost$status
*copyc pmp$delay
?? POP ??
*DECK DECK=DFP$START_CDCNET_CLIENT EXPAND=FALSE
  PROCEDURE [XREF] dfp$start_cdcnet_client
    (    p_queue_interface_table: dft$p_queue_interface_table;
         driver_name: ost$name;
         destination_mainframe: pmt$mainframe_id;
         queue_index: dft$queue_index;
     VAR status: ost$status);

*copyc dft$queue_index
*copyc pmt$mainframe_id
*copyc ost$status
*copyc dfd$driver_queue_types

*DECK DECK=DFP$START_CDCNET_SERVER EXPAND=FALSE
  PROCEDURE [XREF] dfp$start_cdcnet_server
    (    p_queue_interface_table: dft$p_queue_interface_table;
         driver_name: ost$name;
         destination_mainframe: pmt$mainframe_id;
         server_queue_index: dft$queue_index;
     VAR status: ost$status);

*copyc dft$queue_index
*copyc pmt$mainframe_id
*copyc ost$status
*copyc dfd$driver_queue_types

*DECK DECK=DFP$STORE_LEVELER_STATUS EXPAND=FALSE
  PROCEDURE [XREF] dfp$store_leveler_status
    (    server_mainframe_id: pmt$binary_mainframe_id;
         leveler_status: jmt$jl_job_leveler_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc jmt$jl_job_leveler_status
*copyc ost$status
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=DFP$STORE_SERVED_FAMILY_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] dfp$store_served_family_entry
    (    served_family_table_entry: dft$served_family_table_entry;
     VAR served_family_table_index: dft$served_family_table_index;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc dft$served_family_table
*copyc dft$served_family_table_index
*copyc ost$status
?? POP ??
*DECK DECK=DFP$SUBMIT_CLIENT_MAINFRAME_JOB EXPAND=FALSE
  PROCEDURE [XREF] dfp$submit_client_mainframe_job
    (    client_mainframe: pmt$mainframe_id;
     VAR status: ost$status);

*copyc ost$status
*copyc pmt$mainframe_id
*DECK DECK=DFP$TERMINATE_CLIENT EXPAND=FALSE

  PROCEDURE [XREF] dfp$terminate_client
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

*copyc ost$status
*copyc pmt$mainframe_id
*DECK DECK=DFP$TERMINATE_SERVER EXPAND=FALSE

  PROCEDURE [XREF] dfp$terminate_server
    (    mainframe_name: pmt$mainframe_id;
         users_wait_on_term_specified: boolean;
         users_wait_on_terminated: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$mainframe_id
*copyc ost$status
?? POP ??
*DECK DECK=DFP$TERMINATE_SERVER_FILES EXPAND=FALSE

  PROCEDURE [XREF] dfp$terminate_server_files
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=DFP$TERM_MONITOR_IO_STATS EXPAND=FALSE

    PROCEDURE [INLINE] dfp$term_monitor_io_stats (
         queue_entry_location: dft$queue_entry_location);

      VAR
        p_cpu_queue: ^dft$cpu_queue,
        p_queue_interface_table: dft$p_queue_interface_table,
        io_type: dft$monitor_io_types,
        request_time: integer;

      dfp$get_qit_p_from_direct_index (queue_entry_location.directory_index,
            p_queue_interface_table);
      p_cpu_queue := p_queue_interface_table^
            .queue_directory.cpu_queue_pva_directory
            [queue_entry_location.queue_index].p_cpu_queue;

      request_time :=
      p_cpu_queue^.queue_entries [queue_entry_location.queue_entry_index].
            current_request_time;
      io_type :=
      p_cpu_queue^.queue_entries [queue_entry_location.queue_entry_index].
            current_request_type;
      p_cpu_queue^.queue_header.monitor_io [io_type].total_request_time :=
            p_cpu_queue^.queue_header.monitor_io [io_type].total_request_time +
            request_time;
      IF request_time > p_cpu_queue^.queue_header.monitor_io [io_type].max_request_time THEN
        p_cpu_queue^.queue_header.monitor_io [io_type].max_request_time := request_time;
      IFEND;

    PROCEND dfp$term_monitor_io_stats;

?? PUSH (LISTEXT := ON) ??
*copyc dft$cpu_queue
*copyc dft$queue_entry_location
?? POP ??
*copyc dfp$get_qit_p_from_direct_index
*DECK DECK=DFP$TERM_PROCESSING_ON_SERVER EXPAND=FALSE
  PROCEDURE [XREF] dfp$term_processing_on_server
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$mainframe_id
*copyc ost$status
?? POP ??
*DECK DECK=DFP$TERM_REQUESTS_TO_SERVER EXPAND=FALSE
  PROCEDURE [XREF] dfp$term_requests_to_server
    (    mainframe_name: pmt$mainframe_id;
         p_idle_task_status: ^pmt$task_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$mainframe_id
*copyc pmt$task_status
?? POP ??
*DECK DECK=DFP$TEST_DRIVER EXPAND=TRUE


  PROCEDURE [XREF] dfp$test_driver (p_queue_interface_table:
   dft$p_queue_interface_table);

?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
?? POP ??
*DECK DECK=DFP$TIMEOUT_CLIENT EXPAND=FALSE
  PROCEDURE [XREF] dfp$timeout_client
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??

*DECK DECK=DFP$TIMEOUT_REQUESTS_ON_SERVER EXPAND=FALSE

  PROCEDURE [XREF] dfp$timeout_requests_on_server
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$mainframe_id
*copyc ost$status
?? POP ??
*DECK DECK=DFP$TIMEOUT_REQUESTS_TO_SERVER EXPAND=FALSE

  PROCEDURE [XREF] dfp$timeout_requests_to_server
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$mainframe_id
*copyc ost$status
?? POP ??
*DECK DECK=DFP$TIMEOUT_SERVER EXPAND=FALSE

  PROCEDURE [XREF] dfp$timeout_server
    (    mainframe_name: pmt$mainframe_id;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pmt$mainframe_id
*copyc ost$status
?? POP ??

*DECK DECK=DFP$TIMEOUT_SERVER_FILES EXPAND=FALSE

  PROCEDURE [XREF] dfp$timeout_server_files
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
*copyc ost$status
?? POP ??
*DECK DECK=DFP$TOUCH_PAGES EXPAND=FALSE

  PROCEDURE [INLINE] dfp$touch_pages
    (    p_data: ^cell;
         length: ost$segment_length;
     VAR page_count: ost$non_negative_integers);

    VAR
      one_byte: cell,
      pointer_to_touch_cell: ^cell,
      ring: ost$ring,
      segment: ost$segment,
      starting_offset: ost$segment_offset;

    { Touch the first byte
    ring := #RING (p_data);
    segment:= #SEGMENT(p_data);
    starting_offset := #OFFSET (p_data);
    one_byte := p_data^;

  /touch_each_page/
    FOR page_count := 1 TO dfp$page_count (length) DO
      pointer_to_touch_cell := #ADDRESS (ring, segment,
            (starting_offset + (page_count * osv$page_size) - 1));
      one_byte := pointer_to_touch_cell^;
    FOREND /touch_each_page/;
  PROCEND dfp$touch_pages;
?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc osv$page_size
?? POP ??
*copyc dfp$page_count
*DECK DECK=DFP$UNCOMPLEMENT_GFN EXPAND=FALSE
  PROCEDURE [INLINE] dfp$uncomplement_gfn
    (    gfn: ost$binary_unique_name;
     VAR uncomplemented_gfn: ost$binary_unique_name);

    uncomplemented_gfn := gfn;
    uncomplemented_gfn.year := gfn.year - 15;
    IF gfn.sequence_number = LOWERVALUE (gfn.sequence_number) THEN
      uncomplemented_gfn.sequence_number := UPPERVALUE (gfn.sequence_number);
    ELSE
      uncomplemented_gfn.sequence_number := gfn.sequence_number - 1;
    IFEND;
  PROCEND dfp$uncomplement_gfn;
?? PUSH (LISTEXT := ON) ??
*copyc osd$unique_name
?? POP ??
*DECK DECK=DFP$UNLOAD_PP EXPAND=FALSE
  PROCEDURE [XREF] dfp$unload_pp
  (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
   VAR status: ost$status );

*copyc dft$queue_interface_directory
*copyc ost$status
*DECK DECK=DFP$UNLOAD_PP_IF_LAST EXPAND=FALSE
  PROCEDURE [XREF] dfp$unload_pp_if_last
    (    p_q_interface_directory_entry: ^dft$q_interface_directory_entry;
         queue_index: dft$queue_index;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc dft$queue_index
*copyc dft$queue_interface_directory
*copyc ost$status
?? POP ??
*DECK DECK=DFP$VALIDATE_CLIENT_JOB_ID EXPAND=FALSE
   PROCEDURE [XREF] dfp$validate_client_job_id
    (    client_job_id: dft$client_job_id;
         system_supplied_job_name: jmt$system_supplied_name;
         client_job_list_root: dft$client_job_list_root;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc dft$client_job_id
*copyc jmt$system_supplied_name
*copyc dft$client_job_list
*copyc ost$status
?? POP ??
*DECK DECK=DFP$VALIDATE_QUEUE_ENTRY_LOC EXPAND=FALSE

  PROCEDURE [XREF] dfp$validate_queue_entry_loc
    (    queue_entry_loc_int: dft$rpc_queue_entry_loc_int;
         request: string ( * <= osc$max_name_size);
     VAR p_queue_interface_table: dft$p_queue_interface_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dft$rpc_queue_entry_loc_int
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=DFP$VALIDATE_RPC_STATUS EXPAND=FALSE

  PROCEDURE [INLINE] dfp$validate_rpc_status
    (    p_cpu_queue_entry: ^dft$cpu_queue_entry;
     VAR p_receive_rpc_buffer_header: ^dft$rpc_response_buffer_header;
     VAR status: ost$status);

    VAR
      p_status_response: ^dft$status_response,
      p_status: ^ost$status;

    RESET p_cpu_queue_entry^.p_receive_buffer;
    NEXT p_status_response IN p_cpu_queue_entry^.p_receive_buffer;
    IF p_status_response^.buffer_header.version <>
          dfc$status_buffer_version THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$protocol_error_version,
            p_status_response^.buffer_header.version, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            dfc$status_buffer_version, status);
      IF dfv$file_server_debug_enabled THEN
        osp$system_error (' DF - CLIENT PROTOCOL ERROR VERSION ',
              ^status);
      IFEND;
      RETURN;
    IFEND;

    IF p_status_response^.buffer_header.transaction_count <>
          p_cpu_queue_entry^.transaction_count THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$protocol_error_sequence,
            'CLIENT - transaction count', status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            p_cpu_queue_entry^.transaction_count, 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            p_status_response^.buffer_header.transaction_count, 10, FALSE,
            status);
      IF dfv$file_server_debug_enabled THEN
        osp$system_error (' DF - CLIENT PROTOCOL ERROR TRANS COUNT ',
              ^status);
      IFEND;
      RETURN;
    IFEND;

    IF p_status_response^.status.normal THEN
      status.normal := TRUE;
    ELSE
      NEXT p_status IN p_cpu_queue_entry^.p_receive_buffer;
      status := p_status^;
      IF NOT status.normal AND ((status.condition = dfe$restart_server_request) OR
            (status.condition = dfe$server_has_terminated) OR
            (status.condition = dfe$server_request_terminated) OR
            (status.condition = dfe$server_not_active)) THEN
        RETURN;
      IFEND;
    IFEND;

    NEXT p_receive_rpc_buffer_header IN p_cpu_queue_entry^.p_receive_buffer;
    IF p_receive_rpc_buffer_header^.call_progress.transaction_per_rpc_request <>
          p_cpu_queue_entry^.call_progress.transaction_per_rpc_request THEN
      { Protocol error takes precedence over the status from the user.
      osp$set_status_abnormal (dfc$file_server_id, dfe$protocol_error_sequence,
            'CLIENT - rpc transaction count', status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            p_cpu_queue_entry^.call_progress.transaction_per_rpc_request, 10,
            FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            p_receive_rpc_buffer_header^.call_progress.
            transaction_per_rpc_request, 10, FALSE, status);
      IF dfv$file_server_debug_enabled THEN
        osp$system_error (' DF - CLIENT PROTOCOL ERROR RPC COUNT',
              ^status);
      IFEND;
      RETURN;
    IFEND;
  PROCEND dfp$validate_rpc_status;
?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_buffer_header
*copyc dfd$driver_queue_types
*copyc dfe$error_condition_codes
*copyc dfv$file_server_debug_enabled
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$system_error
?? POP ??
*DECK DECK=DFP$VERIFY_ALL_SDTXS_RECOVERED EXPAND=FALSE
  PROCEDURE [XREF] dfp$verify_all_sdtxs_recovered
    (    server_mainframe_id: pmt$binary_mainframe_id);
?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=DFP$VERIFY_CLIENT_JOBS_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] dfp$verify_client_jobs_request
    (    mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=DFP$VERIFY_ELEMENT_NAME EXPAND=FALSE
  PROCEDURE [XREF] dfp$verify_element_name
  (    element_name: cmt$element_name;
   VAR status: ost$status );

*copyc cmt$element_name
*copyc ost$status

*DECK DECK=DFP$VERIFY_ESM_PRODUCT_ID EXPAND=FALSE

  PROCEDURE [XREF] dfp$verify_esm_product_id
    (    product_id: cmt$product_identification;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc cmt$product_identification
*copyc ost$status
?? POP ??
*DECK DECK=DFP$VERIFY_SEGMENTS_RECOVERED EXPAND=FALSE

  PROCEDURE [XREF] dfp$verify_segments_recovered
    (    search: tmt$fnx_search_type;
         ijle_p: ^jmt$initiated_job_list_entry;
         ijlo: jmt$ijl_ordinal;
         recovered_work: dft$mainframe_set);

?? PUSH (LISTEXT := ON) ??
*copyc tmt$fnx_search_type
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc dft$mainframe_set
?? POP ??
*DECK DECK=DFP$VERIFY_STORNET_CHANNEL EXPAND=FALSE
  PROCEDURE [XREF] dfp$verify_stornet_channel
    (    esm_element_name: cmt$element_name;
         channel: dft$channel_specification;
     VAR status: ost$status );

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc dft$channel_specification
*copyc ost$status
?? POP ??

*DECK DECK=DFP$VERIFY_SYSTEM_ADMINISTRATOR EXPAND=FALSE
   PROCEDURE [XREF] dfp$verify_system_administrator
    (    request_name: string ( * <= osc$max_name_size);
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=DFP$WAIT_UNTIL_LEVELER_COMPLETE EXPAND=FALSE
  PROCEDURE [XREF] dfp$wait_until_leveler_complete
    (    p_cpu_queue: ^dft$cpu_queue;
     VAR leveler_complete: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dft$cpu_queue
?? POP ??

*DECK DECK=DFP$WORD_BOUNDARY EXPAND=FALSE

  FUNCTION [INLINE] dfp$word_boundary
    (    byte: integer): integer;

    { This function returns rounds the byte address up to the next
    { highest word, if the byte is not on a word boundary.

    dfp$word_boundary := ((byte DIV 8) * 8) + ($INTEGER ((byte MOD 8) > 0) *
          8);

  FUNCEND dfp$word_boundary;
*DECK DECK=DFS$SERVER_WIRED EXPAND=FALSE

  SECTION
    dfs$server_wired: WRITE;

*DECK DECK=DFT$ACTION_FOR_SERVER EXPAND=FALSE
  TYPE
    dft$action_for_server = (dfc$new_request, dfc$retransmitted_request,
          dfc$complete_request, dfc$complete_request_on_error,
          dfc$transaction_out_of_sequence);


*DECK DECK=DFT$ALLOCATED_RPC_DATA EXPAND=FALSE

  TYPE
    dft$allocated_rpc_data_area = record
      data: ALIGNED [0 MOD 8192] SEQ (REP dfc$maximum_user_data_area OF cell),
    recend;

*copyc dft$rpc_parameters
*DECK DECK=DFT$ALLOCATE_SPACE_REQUEST EXPAND=FALSE
{ DECK: DFT$ALLOCATE_SPACE_REQUEST.
{ This deck describes the format of the record which follows the buffer header
{ record in the receive buffer. This buffer is received by the server as
{ a request for allocation.

   TYPE
     dft$allocate_space_request = dft$page_io_request;

?? PUSH (LISTEXT := ON) ??
*copyc dft$page_io_request
?? POP ??
*DECK DECK=DFT$ALLOCATE_SPACE_RESPONSE EXPAND=FALSE
{ DECK: DFT$ALLOCATE_SPACE_RESPONSE.
{ This deck describes the format of the record which follows the
{ status_response record in the receive buffer. This buffer is received by
{ by the client in response to allocate requests.

   TYPE
     dft$allocate_space_response = dft$page_io_response;

?? PUSH (LISTEXT := ON) ??
*copyc dft$page_io_response
?? POP ??
*DECK DECK=DFT$APPLICATION_RPC_ADD_LIST EXPAND=FALSE

  TYPE
    dft$application_rpc_add_list = array [1 .. *] of dft$rpc_procedure_address_entry;

*copyc dft$rpc_procedure_address_list
*DECK DECK=DFT$APPLICATION_SUPPORT_LIMITS EXPAND=FALSE

  CONST
    dfc$max_number_of_applications = 10,
    dfc$max_number_of_app_procs = 150,
    dfc$max_number_of_procs_per_app = 50;

  TYPE
    dft$number_of_applications = 0 .. dfc$max_number_of_applications,
    dft$number_of_procs_per_app = 0 .. dfc$max_number_of_procs_per_app,
    dft$total_number_of_app_procs = 0 .. dfc$max_number_of_app_procs;

*DECK DECK=DFT$APP_SUPPORT_LIMITS_AF EXPAND=FALSE

  CONST
    dfc$max_number_of_att_files = 63;

  TYPE
    dft$number_of_attached_files = 0 .. dfc$max_number_of_att_files;
*DECK DECK=DFT$ASSIGN_QUEUE_ENTRY_STATUS EXPAND=FALSE

  TYPE
     dft$assign_queue_entry_status = (dfc$aqes_entry_assigned,
        dfc$aqes_invalid_queue_index,  dfc$aqes_no_available_entries,
        dfc$aqes_server_terminated);
*DECK DECK=DFT$CHANGE_CLIENT_JOB_VALIDATON EXPAND=FALSE


  TYPE
    dft$change_client_job_valid_in = record
      account: avt$account_name,
      project: avt$project_name,
      client_job_id: dft$client_job_id,
      system_supplied_job_name: jmt$system_supplied_name,
    recend;


*copyc avt$account_name
*copyc avt$project_name
*copyc dft$client_job_id
*copyc jmt$system_supplied_name
*DECK DECK=DFT$CHANNEL_SPECIFICATION EXPAND=FALSE
{ DECK: DFT$CHANNEL_SPECIFICATION

  TYPE
    dft$channel_specification = record
      channel_name: cmt$element_name,
      iou_name: cmt$element_name,
    recend;

*copyc cmt$element_name
*DECK DECK=DFT$CLIENT_JOB_ID EXPAND=FALSE

  TYPE
    dft$client_job_id = record
      job_list_pointer_index: dft$job_list_ptr_array_index,
      job_list_index: dft$client_job_list_index,
    recend;

  CONST
    dfc$client_job_list_size = 40;

  TYPE
    dft$client_job_list_index = 1 .. dfc$client_job_list_size;

  CONST
    dfc$max_job_list_p_array_size = 0ff(16);

  TYPE
    dft$job_list_ptr_array_index = 1 .. dfc$max_job_list_p_array_size;

*DECK DECK=DFT$CLIENT_JOB_LIST EXPAND=FALSE
{ Deck:  DFT$CLIENT_JOB_LIST
  TYPE
    dft$client_job_list_root = record
      number_of_active_pointers: ALIGNED [0 MOD 8] integer,
      p_job_list_pointer_array: ^dft$job_list_pointer_array,
    recend;

  TYPE
    dft$job_list_pointer_array = array [1 .. * ] of
          dft$client_job_list_pointer,

    dft$client_job_list_pointer = record
      assignment: string (dfc$client_job_list_size),
      p_client_job_list: ^array [1 .. dfc$client_job_list_size] of
            dft$client_job_list_entry,
    recend,

    dft$client_job_list_entry = record
      system_supplied_job_name: jmt$system_supplied_name,
      user_supplied_job_name: jmt$user_supplied_name,
      job_mode: jmt$job_mode,
      job_lifetime: dft$lifetime,
      { recovering is used by the display code.
      recovering: boolean,
      { inhibit_job_recovery is used by the rebuild of the client mainframe file
      { to indicate whether the job should be recovered.
      inhibit_job_recovery: ALIGNED [0 MOD 8] integer,
      request_count: ALIGNED [0 MOD 8] integer,
      { The statistics here need more work as does the
      { storing of the clone task global task id in here.
      { Or should these be in the client job space ????
      {  active_clone_task_count: ALIGNED [0 MOD 8] integer,
      p_client_job_space: ^dft$client_job_space,
    recend,

    dft$client_job_space = record

      { Client job user identification
      family: ost$family_name,
      user: ost$user_name,
      account: avt$account_name,
      project: avt$project_name,
      family_access_kind: dft$family_access_kinds,

{     This may only be determined after the validation file is read.
{     permanent_file_size_limit: amt$file_limit,

      { Client job file tables
      queued_catalog_table_lock: ost$signature_lock,
      p_queued_catalog_table: pft$p_queued_catalog_table,
      p_newest_queued_catalog: pft$p_queued_catalog,
      p_attached_pf_table: pft$p_attached_pf_table,

      { Client job heap
      p_job_heap: ^ost$heap,
      job_heap: dft$job_heap,
    recend;

  TYPE
    dft$job_heap = record
      job_heap: ALIGNED [0 MOD 32] HEAP
            (REP dfc$client_job_heap_size of cell),
    recend;


  CONST
    { Should handle about 60 files attached
    dfc$client_job_heap_size = 32000;

{*copyc amt$file_limit
*copyc avt$account_name
*copyc avt$project_name
*copyc dft$family_access
*copyc dft$lifetime
*copyc jmt$job_mode
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc ost$heap
*copyc dft$client_job_id
*copyc ost$user_identification
*copyc pfd$attached_pf_table
*copyc pfd$queued_catalog_table

*DECK DECK=DFT$CLIENT_MAINFRAME_FILE EXPAND=FALSE
{ Deck:  DFT$CLIENT_MAINFRAME_FILE
  CONST
    dfc$current_mf_file_version = 'MAINFRAME_FILE_VERSION_002',
    dfc$client_mainframe_catalog = '$DF$CLIENT_MAINFRAMES',
    dfc$client_mainframe_segnum = 64(16),
    dfc$client_mainframe_segnum_b = 65(16);

  TYPE
    dft$client_mainframe_file = record
      mainframe_header: dft$mainframe_file_header,
      mainframe_heap: ALIGNED [0 MOD 32] ost$heap,
    recend,

    dft$p_mainframe_file = ^dft$client_mainframe_file,

    dft$mainframe_file_header = record
      file_update_flag: string (5),
      version: ost$name,
      client_mainframe_id: pmt$binary_mainframe_id,
      client_mainframe_name: pmt$mainframe_id,
      server_state: dft$server_state,
      server_lifetime: dft$server_lifetime,
      server_birthdate: integer,
      segment_number: ost$segment,
      client_job_list_lock: ost$signature_lock,
      client_job_list_root: dft$client_job_list_root,
    recend;

   CONST { expected values of file_update_flag in dft$mainframe_file_header
     dfc$client_file_valid = 'TRUE ',
     dfc$client_file_damaged = 'DAMAG';
?? PUSH (LISTEXT := ON) ??
*copyc dft$client_job_list
*copyc dft$server_lifetime
*copyc dft$server_state
*copyc osd$virtual_address
*copyc ost$heap
*copyc ost$name
*copyc ost$signature_lock
*copyc pmt$binary_mainframe_id
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=DFT$COMMAND_BUFFER EXPAND=FALSE
{ DECK: DFT$COMMAND_BUFFER

{ Command buffer for the Task_Services tasks is allocated with the
{ constant size of (dfc$command_record_bytes) 4096 bytes.

  TYPE
    dft$p_command_buffer = ^SEQ (*),
    dft$p_allocated_command_buffer = ^dft$allocated_command_buffer,
    dft$allocated_command_buffer = record
      buffer: ALIGNED [0 MOD 4096] SEQ (*),
    recend;

  CONST
    dfc$command_buffer_size = dfc$command_record_bytes;

{ Command buffers for the Monitor tasks are allocated with the actual sizes and
{ with the layouts as illustrated below.

{   monitor_send_buffer_on_client_OR_receive_buffer_on_server = record
{     buffer_header: dft$buffer_header,
{     status: syt$monitor_status,
{     io: dft$page_io_request,
{   recend,

{   monitor_receive_buffer_on_client_OR_send_buffer_on_server = record
{     buffer_header: dft$buffer_header,
{     status: syt$monitor_status,
{     io: dft$page_io_response,
{   recend;

  TYPE
    dft$p_allocated_monitor_buffer = ^dft$allocated_monitor_buffer,
    dft$allocated_monitor_buffer = record
      buffer: ALIGNED [0 MOD 128] SEQ (*),
    recend;


?? PUSH (LISTEXT := ON) ??
*copyc dfc$esm_allocation_constants
?? POP ??
*DECK DECK=DFT$CONNECTION_PARAMETERS EXPAND=FALSE

  TYPE
    dft$connection_parameters = RECORD
      client_queue_index: dft$queue_index,
      server_queue_index: dft$queue_index,
      number_of_monitor_queue_entries: 0 .. dfc$max_queue_entries,
      number_of_task_queue_entries: dft$queue_entry_index,
      driver_name: ost$name,
      client_to_server: dft$cp_client_to_server,
      CASE connection_type: dft$connection_type OF
      = dfc$esm_connection =
        esm_parameters: dft$cp_esm_parameters,
      CASEND,
    RECEND,

    dft$cp_client_to_server = RECORD
      client_to_server: boolean,
      users_wait_on_terminated: boolean,
      preallocate_image_size: ost$segment_length,
      timeout_interval: 1 .. dfc$maximum_timeout,
      maximum_request_timeout_count: 1 .. dfc$max_req_timeout_count_value,
      maximum_retransmission_count: 1 .. dfc$max_retransmit_count_value,
      maximum_data_bytes: dft$maximum_data_bytes,
    RECEND,

    dft$cp_esm_parameters = RECORD
      element_name: cmt$element_name,
      send_channel: dft$channel_specification,
      receive_channel: dft$channel_specification,
      source_id_number: dft$id_number,
      destination_id_number: dft$id_number,
      dma_available: boolean,
      esm_memory_size:  dfc$min_esm_memory_size .. dfc$max_esm_memory_size,
      esm_base_addresses: dft$esm_base_addresses,
    RECEND;

*copyc cmt$element_name
*copyc dfc$poll_constants
*copyc dfd$driver_queue_types
*copyc dft$channel_specification
*copyc dft$connection_type
*copyc osd$virtual_address
*DECK DECK=DFT$CONNECTION_TYPE EXPAND=FALSE
  TYPE
    dft$connection_types = dfc$esm_connection .. dfc$mock_connection;

  TYPE
    dft$connection_type = (dfc$esm_connection, dfc$cdcnet_connection,
          dfc$mock_connection);

*DECK DECK=DFT$CPU_QUEUE EXPAND=FALSE
{ DECK: DFT$CPU_QUEUE

  TYPE
    dft$cpu_queue = record
      queue_header: dft$cpu_queue_header,
      queue_entries: dft$cpu_queue_entries,
    recend,

    dft$cpu_queue_entries = array [1 .. * ] of dft$cpu_queue_entry;

  TYPE
    dft$cpu_queue_header = record
      number_of_monitor_queue_entries: 0 .. dfc$max_queue_entries,
      number_of_task_queue_entries: 1 .. dfc$max_queue_entries,
      queue_entry_assignment_table: ALIGNED [0 MOD
            8] string (dfc$queue_assignment_strng_size),
      connection_type: dft$connection_type,
      destination_mainframe_id: pmt$binary_mainframe_id,
      destination_mainframe_name: pmt$mainframe_id,
      leveler_status: jmt$jl_job_leveler_status,
      partner_status: dft$partner_status,
      server_lifetime: dft$server_lifetime,
{     Server_Birthdate is the value of the microsecond clock at the time of
{            Activate_Server command.
      server_birthdate: integer,
{     Timeout_Interval is specified in microseconds.
      timeout_interval: ost$non_negative_integers,
      maximum_request_timeout_count: 0 .. dfc$max_req_timeout_count_value,
      maximum_retransmission_count: 0 .. dfc$max_retransmit_count_value,
      monitor_io: ALIGNED [0 MOD 8] array [dfc$monitor_io .. dfc$monitor_allocate] of record
        number_of_requests: integer,
        total_request_time: integer,
        max_request_time: integer,
      recend,
      transaction_data: ALIGNED [0 MOD 8] dft$transaction_data,
      p_allocated_data_rma_list: dft$p_allocated_data_rma_list,
      p_host_application_info: ^dft$host_application_info,
      p_remote_application_info: ^dft$remote_application_info,
      p_application_rpc_list: ^dft$application_rpc_add_list,
    recend;

  TYPE
    dft$monitor_io_types = (dfc$monitor_io, dfc$monitor_allocate);

  TYPE
    dft$transaction_data = record
      transaction_start_time: ost$date_time,
      total_transaction_count: ALIGNED [0 MOD 8] integer,
      total_buffer_length_sent: ALIGNED [0 MOD 8] integer,
      total_data_pages_sent: ALIGNED [0 MOD 8] integer,
      total_buffer_length_received: ALIGNED [0 MOD 8] integer,
      total_data_pages_received: ALIGNED [0 MOD 8] integer,
    recend;

  CONST
    { Make sure the string is an even number of words to use with compare swap
    { Extra characters should be set to dfc$pad_entry_char
    dfc$queue_assignment_strng_size = ((dfc$max_queue_entries DIV 8) *
          8) + ($INTEGER ((dfc$max_queue_entries MOD 8) > 0) * 8);


  TYPE
    dft$cpu_queue_entry = record
      transaction_count: ALIGNED [0 MOD 8] integer,
{     request_start_time is the value of microsecond clock at the time the
{             request is first submitted.
      request_start_time: integer,
{     last_time_progress_checked is the value of microsecond clock at the
{     time the request progress was last checked at a timeout interval.
      last_time_progress_checked: integer,
      copied_queue_entry_flags: dft$queue_entry_flags,
      transaction_state: dft$transaction_state,
      request_timeout_count: 0 .. dfc$max_req_timeout_count_value,
      retransmission_count: 0 .. dfc$max_retransmit_count_value,
      global_task_id: ost$global_task_id,
      p_send_buffer: dft$p_command_buffer,
      p_receive_buffer: dft$p_command_buffer,
      { The data list must reside within a page }
      p_data_rma_list: dft$p_data_rma_list,
      data_pages_locked: boolean,
      case processor_type: dft$queue_entry_type of
      = dfc$monitor =
        io_id: mmt$io_identifier,
        ajlo: jmt$ajl_ordinal,
        io_type: iot$io_function,
        sfid: dmt$system_file_id,
        current_request_type: dft$monitor_io_types,
        current_request_time: integer,

        {pointer to server iocb present only on server side.
        p_server_iocb: ^mmt$server_iocb_entry,
      = dfc$task_services =
        { For remote_procedure_call usage only.
        p_send_data: dft$p_send_data,
        p_receive_data: dft$p_send_data,
        total_data_to_receive: dft$send_data_size,
        call_progress: dft$rpc_progress_record,
        case server_to_client: boolean of
        = TRUE =
          remote_procedure_called: boolean,
          p_last_wired_data: ^cell,
          last_wired_length: dft$send_data_size,
        = FALSE =
          maximum_data_sent: dft$send_data_size,
          maximum_data_received: dft$send_data_size,
        casend,
      casend,
    recend;


{ This is the TYPE for the pointer to the data RMA list entries for each queue
{ entry. This list of RMA's resides within the allocated_data_rma_list record.
  TYPE
    dft$p_data_rma_list = ^array [1 .. *] of mmt$rma_list_entry;

{ This is the TYPE for the pointer to the block of RMA list entries for a queue.
{ Space within this block will be devided among the queue's queue_entries.
{ Each queue_entry may be assigned from 4 to dfc$max_rma_list_entries depending
{ on the value of the maximum_data_bytes field of the queue_interface_table, for
{ a given queue_entry these rma_list_entries must not cross a page boundry.
{ Alignment is done to 8192 to assure that the rma list starts on a page
{ boundary, so that each piece of the rma list is contained within ONE page.
{ If file server is to support a page size of > 8192, this alignment may need
{ to change.

  TYPE
    dft$p_allocated_data_rma_list = ^dft$allocated_data_rma_list,
    dft$allocated_data_rma_list = record
      rma_list: ALIGNED [0 MOD 8192] array [1 .. *] of mmt$rma_list_entry,
    recend;



*copyc dfc$esm_allocation_constants
*copyc dfc$poll_constants
*copyc dfd$driver_queue_types
*copyc dft$application_rpc_add_list
*copyc dft$command_buffer
*copyc dft$connection_type
*copyc dft$host_application_info
*copyc dft$entry_type
*copyc dft$partner_status
*copyc dft$queue_entry_type
*copyc dft$queue_index
*copyc dft$remote_application_info
*copyc dft$rpc_parameters
*copyc dft$rpc_procedure_address_list
*copyc dft$rpc_progress_record
*copyc dft$server_lifetime
*copyc dft$server_state
*copyc dft$transaction_state
*copyc dmt$system_file_id
*copyc iot$io_function
*copyc jmt$ajl_ordinal
*copyc jmt$jl_job_leveler_status
*copyc mmt$io_identifier
*copyc mmt$rma_list
*copyc mmt$server_io_control_block
*copyc osd$integer_limits
*copyc ost$date_time
*copyc ost$global_task_id
*copyc pmt$binary_mainframe_id
*copyc pmt$mainframe_id
*copyc tmt$task_status
*DECK DECK=DFT$DEFINED_SERVER_TRANSLATION EXPAND=FALSE

  TYPE
    dft$defined_server_translation = array
          [1 .. dfc$max_number_of_mainframes] of pmt$binary_mainframe_id;


*copyc dfc$esm_allocation_constants
*copyc pmt$binary_mainframe_id

*DECK DECK=DFT$DELETE_CLIENT_JOB EXPAND=FALSE
  TYPE
   dft$delete_client_job_inp = record
     client_job_table_exists: boolean,
     client_job_id: dft$client_job_id,
     system_supplied_job_name: jmt$system_supplied_name,
     job_is_leveled: boolean,
     job_end_info: jmt$jl_server_job_end_info,
   recend;

*copyc dft$client_job_id
*copyc jmt$jl_server_job_end_info
*copyc jmt$system_supplied_name
*DECK DECK=DFT$DESCRIPTIVE_DATA_DESCRIPTOR EXPAND=FALSE
  TYPE
    dft$descriptive_data_descriptor = record
      mainframe: pmt$mainframe_id,
      iou: cmt$element_name,
      pp: cmt$element_name,
      ch: cmt$element_name,
      element: cmt$element_name,
      product_id: cmt$product_identification,
      symptom_code: integer,
    recend;

*copyc pmt$mainframe_id
*copyc cmt$element_name
*copyc cmt$product_identification
*DECK DECK=DFT$DISPLAY_IDENTIFIER EXPAND=FALSE

  TYPE
    dft$display_identifier = RECORD
      CASE display_type: dft$display_type OF
      = dfc$console_display =
        wid: dpt$window_id,
      = dfc$listing_display =
        display_control: clt$display_control,
      = dfc$trace_display =
        ,
      CASEND,
    RECEND;

  TYPE
    dft$display_type = (dfc$console_display, dfc$listing_display,
          dfc$trace_display);

*copyc clt$display_control
*copyc dpt$window_id
*DECK DECK=DFT$END_JOB_RECOVERY EXPAND=FALSE

  TYPE
    dft$end_job_recovery = record
      client_job_id: dft$client_job_id,
      server_lifetime: dft$lifetime,
    recend;

*copyc dft$client_job_id
*copyc dft$lifetime
*DECK DECK=DFT$ENTRY_TYPE EXPAND=FALSE

  TYPE
    dft$entry_type = (dfc$free_entry, dfc$valid_entry);

  CONST
    { The free char MUST be a blank to allow for rapid assignment
    dfc$free_entry_char = ' ',
    dfc$assigned_entry_char = 'A',
    dfc$pad_entry_char = 'P';
*DECK DECK=DFT$ESMS_DEFINED EXPAND=FALSE
  CONST
    dfc$max_esms_defined = 8;

  TYPE
    dft$esms_defined_count = 0 .. dfc$max_esms_defined,
    dft$esms_defined = array [1 .. * ] of cmt$element_name;

*copyc cmt$element_name
*DECK DECK=DFT$ESM_DEFINITION_TABLE EXPAND=FALSE
{ DECK: DFT$ESM_DEFINITION_TABLE

  TYPE
    dft$esm_definition_table = array [1 .. *] OF dft$esm_definition_table_entry;

  TYPE
    dft$esm_definition_table_entry = record
      element_name: cmt$element_name,
      memory_size: dfc$min_esm_memory_size ..  dfc$max_esm_memory_size,
      half_ecs_switch: boolean,
      p_side_door_ports: array [1 .. cmc$max_side_door_port_number] OF ^dft$channel_definition,
      esm_base_addresses: dft$esm_base_addresses,
      maximum_data_bytes: dft$maximum_data_bytes,
      maintenance_buffer_loc: cmt$esm_maintenance_buffer_loc,
      number_of_pps_using_esm: 0 .. 8,
      p_element_reservation: ^array [1 .. 1] of cmt$element_reservation,
      p_next_table_entry: ^dft$esm_definition_table_entry,
    recend;

  TYPE
    dft$esm_specifications = record
      element_name: cmt$element_name,
      memory_size: dfc$min_esm_memory_size ..  dfc$max_esm_memory_size,
      half_ecs_switch: boolean,
      side_door_ports: dft$side_door_ports,
      esm_base_addresses: dft$esm_base_addresses,
      maximum_data_bytes: dft$maximum_data_bytes,
      maintenance_buffer_loc: cmt$esm_maintenance_buffer_loc,
    recend,

    dft$side_door_ports = record
      number: 0 .. cmc$max_side_door_port_number,
      ports: array [1 .. cmc$max_side_door_port_number] OF dft$channel_definition,
    recend;

  TYPE
    dft$channel_definition = record
      channel_name: cmt$element_name,
      iou_name: cmt$element_name,
      mainframe_id: pmt$mainframe_id,
    recend;

  TYPE
    dft$maximum_data_bytes = dfc$min_data_record_bytes .. dfc$max_data_record_bytes;


*copyc cmt$element_name
*copyc cmt$element_reservation
*copyc cmt$esm_definition
*copyc dfc$esm_allocation_constants
*copyc dfd$driver_queue_types
*copyc pmt$mainframe_id

*DECK DECK=DFT$ESM_LOG_DATA EXPAND=FALSE
{ DECK: DFT$ESM_LOG_DATA

{ Type definition for sequence passed by dfp$process_error_log_response
{ to dsp$report_system_message. The process dfp$log_esm_data converts
{ this sequence into one of type dft$engineering_log_data which is passed
{ to process sfp$emit_statistic.

  TYPE
    dft$esm_log_data = record
      error_log_response: dft$fs_error_log_response,
      logical_unit: iot$logical_unit,
      iou_number: 0 .. 3,
      pp_number: 0 .. 0ff(16),
      channel: cmt$physical_channel,
      symptom_message: string (dfc$symptom_message_length),
    recend;


  CONST
    dfc$symptom_message_length = 56;

*copyc cmt$physical_channel
*copyc dft$fs_error_log_response
*copyc iot$logical_unit
*DECK DECK=DFT$ESTABLISH_CLIENT_JOB EXPAND=FALSE
{Deck:  DFT$ESTABLISH_CLIENT_JOB

  TYPE
   dft$establish_client_job_inp = record
     user_id: ost$user_identification,
     system_supplied_job_name: jmt$system_supplied_name,
     user_supplied_job_name: jmt$user_supplied_name,
     job_mode: jmt$job_mode,
     account: avt$account_name,
     project: avt$project_name,
     family_access_kind: dft$family_access_kinds,
     system_administrator: boolean,
     family_administrator: boolean,
     forced_reconnection: boolean,
     job_lifetime: dft$lifetime,
   recend,

   dft$establish_client_job_outp = record
     client_job_id: dft$client_job_id,
   recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc dft$client_job_id
*copyc dft$family_access
*copyc dft$lifetime
*copyc ost$user_identification
*copyc jmt$job_mode
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name

*DECK DECK=DFT$FAMILY_ACCESS EXPAND=FALSE
  TYPE
    dft$family_access_kinds = (dfc$remote_file_access, dfc$remote_login_access,
          dfc$job_leveling_access),
    dft$family_access = set of dft$family_access_kinds;

*DECK DECK=DFT$FAMILY_ACCESS_TYPE EXPAND=FALSE
  TYPE
    dft$family_access_type = (dfc$set_access, dfc$server_access);


*DECK DECK=DFT$FAMILY_INFO_LIST EXPAND=FALSE
 TYPE
    dft$family_info_list = array [1 .. * ] of dft$family_info_record;

*copyc dft$family_info_record
*DECK DECK=DFT$FAMILY_INFO_RECORD EXPAND=FALSE

  TYPE
    dft$family_info_record = record
      family_name: ost$family_name,
      family_state: dft$server_state,
      case access_type: dft$family_access_type of
      = dfc$set_access =
        set_name: ost$name,
      = dfc$server_access =
        server_mainframe_name: pmt$mainframe_id,
        server_binary_mainframe_id: pmt$binary_mainframe_id,
        family_access: dft$family_access,
      casend,
    recend;

*copyc dft$family_access
*copyc dft$family_access_type
*copyc dft$server_state
*copyc ost$name
*copyc ost$user_identification
*copyc pmt$binary_mainframe_id
*copyc pmt$mainframe_id

*DECK DECK=DFT$FAMILY_LIST EXPAND=FALSE

  TYPE
    dft$family_list_container = SEQ (REP dfc$max_family_parameters of
          ost$name);

  CONST
    dfc$max_family_parameters = dfc$maximum_family_lists *
       dfc$served_family_list_size;

  CONST
    { This constant currently exists because the send_buffer will only
    { fit a page worth of families.  This value must take into account the
    { value of dfc$served_family_list_size and dft$family_verification size.
    { This value is also used in SYM$SYSTEM_CONSTANT_MANAGER.
    { The proper value should probably be dfc$max_family_ptr_array_size.
    dfc$maximum_family_lists = 6;

  TYPE
    dft$p_family_list = ^dft$family_list,
    dft$family_list = array [1 .. * ] of ost$name;

?? push (LISTEXT := ON) ??
*copyc dft$served_family_table_index
*copyc ost$name
?? POP ??
*DECK DECK=DFT$FAMILY_TABLE_CLIENT_ENTRY EXPAND=FALSE
  TYPE
    dft$family_table_client_entry = record
      client_binary_id: pmt$binary_mainframe_id,
      family_access: dft$family_access,
      p_next_client: ^dft$family_table_client_entry,
    recend;

*copyc dft$family_access
*copyc dft$family_table_client_entry
*copyc pmt$binary_mainframe_id
*DECK DECK=DFT$FS_ERROR_LOG_RESPONSE EXPAND=FALSE
{ DECK: DFT$FS_ERROR_LOG_RESPONSE

  TYPE
    dft$fs_error_log_response = record
      flags: ALIGNED [0 MOD 8] dft$eng_response_flags,
      retry_count: 0 .. 0ff(16),
      error_condition: 0 .. 0ffff(16),
      last_ch_function: 0 .. 0ffff(16),
      esm_lsp_function: 0 .. 0ffff(16),

      esm_lsp_status: 0 .. 0ffff(16),
      fill1: 0 .. 0ff(16),
      esm_address: 0 .. 0ffffff(16),
      residual_byte_count: 0 .. 0ffff(16),

      transfer_byte_count: 0 .. 0ffff(16),
      adapter_t_register: dft$c170_dma_adapter_t_reg,

      adapter_function: 0 .. 0ffff(16),
      adapter_control_register: 0 .. 0ffff(16),
      adapter_error_status: 0 .. 0ffff(16),
      adapter_op_status_register: 0 .. 0ffff(16),

      fill2: 0 .. 0ffff(16),
      initial_adapter_t_register: dft$c170_dma_adapter_t_reg,
    recend,

    dft$eng_response_flags = packed record
      unrecovered_error: boolean,
      C170_dma_adapter: boolean,
      executing_adapter_io: boolean,
      adapter_t_register_loaded: boolean,
      unused5: boolean,
      unused6: boolean,
      unused7: boolean,
      unused8: boolean,
    recend,

    dft$c170_dma_adapter_t_reg = packed record
      byte_count: 0 .. 0ffff(16),
      cm_address: 0 .. 0ffffffff(16),
    recend;

*DECK DECK=DFT$FS_PP_RESPONSE EXPAND=FALSE
{ DECK: DFT$FS_PP_RESPONSE

   TYPE
    dft$fs_pp_response = record
      response_flags: ALIGNED [0 MOD 8] dft$response_flags,
      response_length: ALIGNED [1 MOD 8] 0 .. 0FF(16),
      response_parameter: ALIGNED [2 MOD 8] dft$response_parameter,
      logical_unit: ALIGNED [4 MOD 8] iot$logical_unit,
      queue_index: ALIGNED [6 MOD 8] 0 .. 0FF(16),
      queue_entry_index: ALIGNED [7 MOD 8] 0 .. 0FF(16),
    recend,

    dft$response_flags = packed record
      special_response: boolean,
      one_word_response: boolean,
      error_response: boolean,
      inquiry_response: boolean,
      termination_pseudo_response: boolean,
      error_log_response: boolean,
      fill: 0 .. 03(16),
    recend,

    dft$response_parameter = record
      CASE boolean OF
      = TRUE =
        inquiry_message: dft$inquiry_message,
      = FALSE =
        error_condition: 0 .. 0FFFF(16),
      CASEND,
    recend;

*copyc dft$inquiry_message
*copyc iot$logical_unit

*DECK DECK=DFT$HOST_APPLICATION_INFO EXPAND=FALSE
  TYPE
    dft$host_application_info = record
      application_name: ost$name,
      p_library_file_path: ^fst$file_reference,
      state_change_procedure_name: pmt$program_name,
      sequence_pointer: ^SEQ ( * ),
      p_attached_file_info: ^array [*] of ^fst$file_reference,
      attached_library_lfn: amt$local_file_name,
      {NOTE: attached_library_lfn is valid only while partner is active
      next_p_application_info: ^dft$host_application_info,
    recend;

*copyc amt$local_file_name
*copyc fst$file_reference
*copyc ost$name
*copyc ost$status
*copyc pmt$program_name
*DECK DECK=DFT$IMAGE_FILE EXPAND=FALSE
{ Deck:  DFT$IMAGE_FILE
{ This deck describes the file and types used to describe the
{ image file that is used to contain all server pages on the client
{ mainframe.
{ This image file resides on a disk file on the client mainframe
{ and is written:
{   - as a result of a continuation deadstart
{      All pages in the mainframe memory image that belong to the server are copied
{      from the mainframe memory image to the server image file.
{   - as a result of a timeout
{      All pages in the real memory that belong to the server are copied
{      and removed from real memory and written to the server image file.
{
{ The general format of this file is:
{    image header  (in the first page of the file)
{    Repeated until all pages saved
{      one page block sequence consisting of
{        block header
{        repeated for each file
{          file header
{          page headers for all pages of the file
{      Actual pages described in the page headers for this block
{
{ Current_eoi represents the length of the image file that has been written.
{   Because the file is preallocated this eoi is different (smaller) than the
{   eoi maintained by device manager.
{

  TYPE
    dft$image_header = record
      file_update_flag: string (5),
      version: ost$name,
      server_mainframe_id: pmt$binary_mainframe_id,
      server_mainframe_name: pmt$mainframe_id,
      client_mainframe_name: pmt$mainframe_id,
      current_eoi: ost$segment_offset,
      requested_preallocation_size: ost$segment_offset,
      page_size: ost$page_size,
    recend,

    dft$image_block_header = record
      block_header_string: string (5),
      file_count: gft$file_descriptor_index,
      page_count: 0 .. osc$max_page_frames,
      page_source: dft$image_source,
      next_block_header_offset: ost$segment_offset,
    recend,


    dft$image_file_operation = (dfc$read_image_file, dfc$reset_image_file,
          dfc$image_source_timeout, dfc$image_source_deadstart),

    dft$image_file_operations = set of dft$image_file_operation,

    dft$image_source = dfc$image_source_timeout .. dfc$image_source_deadstart,


   { The global_file_name is the uncomplemented global file name.
    dft$image_file_header = record
      file_completed: boolean,
      global_file_name: dmt$global_file_name,
      eoi_byte_address: amt$file_byte_address,
      highest_file_offset: ost$segment_offset,
      page_count: 0 .. osc$max_page_frames,
    recend,

    dft$image_page_header = record
      image_offset: ost$segment_offset,
      file_offset: ost$segment_offset,
    recend;

  CONST
    dfc$current_image_file_version = 'SERVER_IMAGE_FILE_VERSION_001  ',
    dfc$block_header_string = 'BLOCK',
    dfc$image_file_valid = 'VALID',
    dfc$image_file_damaged = 'DAMAG',
    dfc$image_file_writing = 'WRITN';

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmt$global_file_name
*copyc gft$system_file_identifier
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$page_size
*copyc ost$page_table
*copyc pmt$binary_mainframe_id
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=DFT$IMAGE_FILE_ID EXPAND=FALSE
{ Deck:  DFT$IMAGE_FILE_ID
{ This type describes the current image file position for this instance
{ of reference of the image file.

  TYPE
    dft$image_file_id = record
     { p_image_file points to the start of the file.
      p_image_file: ^SEQ ( * ),
      p_image_header: ^dft$image_header,
      operation: dft$image_file_operation,
      { p_current_block_header and p_current_block_seq are
      { initially NIL if reseting
      p_current_block_header: ^dft$image_block_header,
      p_current_block_seq: ^SEQ ( * {one client page} ),
      case client: boolean of
      = TRUE =
        local_file_name: amt$local_file_name,
        file_id: amt$file_identifier,
        p_current_eoi: ^cell,
        allocated_size: ost$segment_length,
      = FALSE { server } =
        { On the server mainframe the image is received from the client
        { into a scratch segment.
        ,
      casend,
    recend;

*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc dft$image_file
*copyc dft$image_file_id
*copyc osd$virtual_address
*DECK DECK=DFT$INQUIRY_MESSAGE EXPAND=FALSE
{ DECK: DFT$INQUIRY_MESSAGE

TYPE
  dft$inquiry_message = record
    inquiry_tracer: dft$inquiry_tracer,
    transaction_state: dft$transaction_state,
  recend,

  dft$inquiry_tracer = packed record
    transaction_digit: dft$transaction_digit,
    retransmission_digit: dft$retransmission_digit,
  recend,

  dft$transaction_digit = 0 .. 0f(16),
  dft$retransmission_digit = 0 .. 0f(16);

?? PUSH (LISTEXT := ON) ??
*copyc dft$transaction_state
?? POP ??
*DECK DECK=DFT$JOB_RECOVERY_LOCATION EXPAND=FALSE
{ Deck:  DFT$JOB_RECOVERY_LOCATION
{
{ Job recovery location is used on the client to determine
{ where the server job recovery should be performed.
{ dfc$job_rec_started_by_caller - it is the responsibility of the
{   caller of dfp$send_remote_procedure_call to start job recovery
{   by use of dfp$check_job_recovery.
{   The caller sees the status condition of dfe$job_needs_recovery
{ dfc$job_rec_in_unavailable_wait, - the caller of
{   dfp$send_remote_procedure_call calls osp$wait_on_condition and
{   server job recovery is performed there.
{   The caller sees the status condition of dfe$server_not_active
{ dfc$job_rec_immediately - the job recovery operation as performed
{   as a result of the dfp$send_remote_procedure_call request.  This
{   is only available for 'clean' requests, that is requests without
{   system or job locks set.
{   This option is currently untested.

  TYPE
    dft$job_recovery_location = (dfc$job_rec_started_by_caller,
          dfc$job_rec_in_unavailable_wait, dfc$job_rec_immediately);

*DECK DECK=DFT$JOB_SERVER_TABLE EXPAND=FALSE
{ Deck:  DFT$JOB_SERVER_TABLE

  TYPE
    dft$p_job_server_table = ^dft$job_server_table,
    dft$job_server_table = array [1 .. * ] of dft$job_server_table_entry;


  TYPE
    dft$job_server_table_entry = record
      server_mainframe: pmt$mainframe_id,
      server_mainframe_id: pmt$binary_mainframe_id,
      server_lifetime: dft$server_lifetime,
      client_job_id: dft$client_job_id,
      family_access_kind: dft$family_access_kinds,
      force_server_reconnection: boolean,
      change_validation_info: boolean,
    recend;

  CONST
    dfc$maximum_job_server_count = 0ff(16),
    dfc$job_server_expansion_count = 2;

  TYPE
    dft$job_server_count = 0 .. dfc$maximum_job_server_count,
    dft$job_server_table_index = 1 .. dfc$maximum_job_server_count;


*copyc dft$client_job_id
*copyc dft$entry_type
*copyc dft$family_access
*copyc dft$server_lifetime
*copyc pmt$binary_mainframe_id
*copyc pmt$mainframe_id
*DECK DECK=DFT$LIFETIME EXPAND=FALSE

  TYPE
    dft$lifetime = 0 .. dfc$maximum_lifetime;

  CONST
    dfc$maximum_lifetime = 0FFFF(16);
*DECK DECK=DFT$MAINFRAME_SET EXPAND=FALSE
{ Deck:  DFT$MAINFRAME_SET

  TYPE
    dft$mainframe_set = set of 1 .. dfc$max_number_of_mainframes;

*copyc dfc$esm_allocation_constants

*DECK DECK=DFT$MAINFRAME_TASK_STATUS EXPAND=FALSE
{ Deck:  DFT$MAINFRAME_TASK_STATUS
  TYPE
    dft$mainframe_task_status = record
      task_status: pmt$task_status,
      mainframe_id: pmt$mainframe_id,
    recend;

*copyc pmt$task_status
*copyc pmt$mainframe_id

*DECK DECK=DFT$MOVED_FS_RESPONSE_BUFFER EXPAND=FALSE
{ DECK: DFT$MOVED_FS_RESPONSE_BUFFER

   TYPE
     dft$moved_fs_response_buffer = record
       CASE word_move: boolean OF
       = TRUE =
         bytes: ALIGNED [0 MOD 8] ARRAY [0 .. dfc$max_fs_pp_response_length DIV 8] OF ost$byte,
       = FALSE =
         response: ALIGNED [0 MOD 8] dft$fs_error_log_response,
       CASEND,
     recend;

   CONST
     dfc$max_fs_pp_response_length = 6 * 8;

*copyc dft$fs_error_log_response
*copyc ost$byte
*DECK DECK=DFT$ONE_WORD_RESPONSE_HANDLER EXPAND=FALSE

  TYPE
    dft$one_word_response_handler = ^procedure (one_word_response_p: ^dft$fs_pp_response;
      pp_number: 1 .. ioc$pp_count;
      VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$fs_pp_response
*copyc IOT$PP_INTERFACE_TABLE
*copyc syt$monitor_status
?? POP ??

*DECK DECK=DFT$PAGE_IO_REQUEST EXPAND=FALSE
{ DECK: DFT$PAGE_IO_REQUEST.
{ This deck describes the format of the record which follows the buffer header
{ record in the receive buffer. This buffer is received by the server as
{ a request for page I/O.

  TYPE
    dft$page_io_request = record
      segment_offset: ost$segment_offset,
      segment_length: ost$segment_length,
      global_file_name: dmt$global_file_name,
      eoi_byte_address: amt$file_byte_address,
      remote_sfid: dmt$system_file_id,
    recend;

*copyc amt$file_byte_address
*copyc dmt$global_file_name
*copyc dmt$system_file_id
*copyc osd$virtual_address
*DECK DECK=DFT$PAGE_IO_RESPONSE EXPAND=FALSE
{ DECK: DFT$PAGE_IO_RESPONSE.
{ This deck describes the format of the record which follows the
{ status_response record in the receive buffer. This buffer is received by
{ by the client in response to page I/O requests.

  TYPE
    dft$page_io_response = record
      segment_offset: ost$segment_offset,
      segment_length: ost$segment_length,
      global_file_name: dmt$global_file_name,
      eoi_byte_address: amt$file_byte_address,
      total_allocated_length: amt$file_byte_address,
    recend;

*copyc amt$file_byte_address
*copyc dmt$global_file_name
*copyc osd$virtual_address


*DECK DECK=DFT$PARTNER_MAINFRAME_LIST EXPAND=FALSE
  CONST
    dfc$maximum_partner_mainframes = 256;

  TYPE
    dft$partner_mainframe_list = array [1 .. * ] of
          dft$partner_mainframe_entry,

    dft$partner_mainframe_count = 0 .. dfc$maximum_partner_mainframes,

    dft$partner_mainframe_entry = record
      mainframe_id: pmt$binary_mainframe_id,
      mainframe_name: pmt$mainframe_id,
      partner_state: dft$server_state,
    recend;

*copyc dft$server_state
*copyc pmt$mainframe_id
*copyc pmt$binary_mainframe_id
*DECK DECK=DFT$PARTNER_QUEUE_LIST EXPAND=FALSE
{ DECK: DFT$PARTNER_QUEUE_LIST
  CONST
    dfc$maximum_partner_queues = dfc$max_number_of_queues *
          dfc$maximum_queue_interfaces;

  TYPE
    dft$partner_queue_list = array [1 .. * ] of dft$partner_queue_entry,

    dft$partner_queue_count = 0 .. dfc$maximum_partner_queues,

    dft$partner_queue_entry = record
      p_driver_queue: ^dft$driver_queue,
      p_cpu_queue: ^dft$cpu_queue,
    recend;

*copyc dfd$driver_queue_types
*copyc dft$cpu_queue

*DECK DECK=DFT$PARTNER_STATUS EXPAND=FALSE
{ Deck:  DFT$PARTNER_STATUS

  TYPE
    dft$partner_status = record
      { Terminate_partner is used either as a result of an explicit termination
      { or as a result of a system error detected in monitor.
      terminate_partner: boolean,
      users_wait_on_terminated_server: boolean,
      { Timeout partner is used by monitor to indicate that the partner is
      { unavailable.  The state will be changed to terminated, or awaiting
      { recovery based upon the job recovery option.
      timeout_partner: boolean,
      case server_state: dft$server_state of
      = dfc$active =
{       Verify_Family and Send_Deactivate_Partner are set as a result of an
{       operator's command. Send_Deactivate_Partner actually causes the
{       Server_State to be changed from Active to Deactivated.
        verify_family: boolean,
        send_deactivate_partner: boolean,
        job_reconcilliation_completed: boolean,
      = dfc$inactive, dfc$terminated, dfc$awaiting_recovery =
{       When Verify_Queue = TRUE the Server_State is in transition from
{       Inactive or Terminated into Active or from
{       awaiting_recovery to recovering.
        verify_queue: boolean,
{       Server_pages_saved is only used on the CLIENT mainframe and only
{       if the awaiting_recovery state. This boolean indicates whether
{       all server pages have been saved to the image file.
        server_pages_saved: boolean,
      = dfc$deactivated =
{       Server_State = Deactivated is a transition state from Active into
{       Inactive. Deactivate_Complete must be TRUE before the Server_State
{       is actually changed to Inactive.
        deactivate_complete: boolean,
      = dfc$recovering =
{       Server_State = recovering is a transition state from awaiting_recovery
{       into Active.  Recovery_complete must be TRUE before the Server_State
{       is actually changed to active.
        recovery_complete: boolean,
      casend,
    recend;
*copyc dft$server_state
*DECK DECK=DFT$POLL_FAMILY_LIST EXPAND=FALSE
{ DECK: DFT$POLL_FAMILY_LIST

  TYPE
    dft$poll_family_list = record
      families: array [1 .. * ] of dft$family_verification,
    recend;

  TYPE
    dft$family_verification = record
      family: ost$name,
      valid: boolean,
      family_access: dft$family_access,
    recend;

*copyc dft$family_access
*copyc ost$name
*DECK DECK=DFT$POLL_HEADER EXPAND=FALSE
{ DECK: DFT$POLL_HEADER

  TYPE
    dft$poll_header = record
      mainframe_name: pmt$mainframe_id,
      poll_type: dft$poll_type,
    recend;

  TYPE
    dft$poll_type = (
{   Poll Types sent from Client to Server:
      dfc$normal_poll, dfc$verify_served_family, dfc$verify_queue,
      dfc$deactivate_complete, dfc$recovery_complete,

{   Poll Types sent from either mainframe:
      dfc$deactivate_server,

{   Poll Types sent from Server to Client:
      dfc$poll_reply, dfc$verify_family_reply, dfc$verify_queue_reply,
      dfc$deactivate_reply,
      dfc$req_verify_served_family, dfc$recovery_complete_reply);

{  The below table indicates for each poll type sent from client and
{  the possible expected responses from the server.
{       CLIENT                      SERVER
{    dfc$normal_poll               dfc$poll_reply
{                                  dfc$deactivate_server
{                                  dfc$req_verify_served_family
{    dfc$verify_served_family      dfc$verify_family_reply
{                                  dfc$deactivate_server
{    dfc$verify_queue              dfc$verify_queue_reply
{    dfc$deactivate_complete        -- no reply --
{    dfc$recovery_complete         dfc$recovery_complete_reply
{    dfc$deactivate_server         dfc$deactivate_reply

*copyc pmt$mainframe_id
*DECK DECK=DFT$POLL_MESSAGE EXPAND=FALSE

  TYPE
    dft$poll_message = record
      buffer_header: dft$buffer_header,
      poll_header: dft$poll_header,
    recend;

*copyc dfd$request_package
*copyc dft$poll_header
*DECK DECK=DFT$POLL_QUEUE_INFORMATION EXPAND=FALSE
{ DECK: DFT$POLL_QUEUE_INFORMATION

  TYPE
    dft$poll_queue_information = record
      status: ost$status,
      server_date_time: ost$date_time,

{ The following information is extracted from the Queue Interface Table.
      esm_base_addresses: dft$esm_base_addresses,

{ The following information is extracted from
{ the Driver Queue Directory and the Driver Connection Description.
      driver_number_of_queue_entries: 0 .. 0FFFF(16),
      driver_source_id_number: 0 .. 0FFFF(16),
      driver_source_queue_index: 0 .. 0FF(16),
      driver_destination_id_number: 0 .. 0FFFF(16),
      driver_destination_queue_index: 0 .. 0FF(16),

{ The following information is obtained from the system.
      client_page_size: ost$page_size,
      client_os_name: pmt$os_name,

{ The following information is extracted from CPU Queue Table entry.
      destination_mainframe_name: pmt$mainframe_id,
{ Server_lifetime/ Server_birthdate are the new information to be used, on
{ activation from terminated these are created.
      server_lifetime: dft$server_lifetime,
      server_birthdate: integer,
      number_of_monitor_queue_entries: 0 .. dfc$max_queue_entries,
      number_of_task_queue_entries: 1 .. dfc$max_queue_entries,
{     Timeout_Interval is in microseconds.
      timeout_interval: 1000000 .. (dfc$maximum_timeout*1000000),
      maximum_timeout_count: 1 .. dfc$max_req_timeout_count_value,
      maximum_retransmission_count: 1 .. dfc$max_retransmit_count_value,
      CASE server_state: dft$server_state OF
      = dfc$awaiting_recovery, dfc$inactive =
       previous_server_lifetime: dft$server_lifetime,
       previous_server_birthdate: integer,
      CASEND,
    recend;

*copyc dfc$poll_constants
*copyc dfd$driver_queue_types
*copyc dft$queue_index
*copyc dft$server_state
*copyc ost$date_time
*copyc ost$page_size
*copyc ost$status
*copyc pmt$mainframe_id
*copyc pmt$os_name
*DECK DECK=DFT$PP_COMMUNICATION EXPAND=FALSE
{ This deck describes the format of the communication buffer
{ entry that is used as a trace for the file server ESM driver.
{ This is only provided for documention purpuses, NO cpu program
{ inspects the communication buffer.

  TYPE
    dft$pp_communication = record
      sequence_number: 0 .. 0ffff(16),
      main_loop_address: 0 .. 0ffff(16),
      caller__address: 0 .. 0ffff(16),
      { a_register contains relevant data, for example q index, q entry index
      a_register: 0 .. 0ffff(16),
    recend;

*DECK DECK=DFT$PP_ELEMENT_RESERVATIONS EXPAND=FALSE
{ DECK DFT$PP_ELEMENT_RESERVATIONS }

  TYPE
    dft$pp_element_reservations = ARRAY [1 .. 2] OF cmt$element_reservation;

*copyc cmt$element_reservation
*DECK DECK=DFT$PROCEDURE_ADDRESS_ORDINAL EXPAND=FALSE

  TYPE
    dft$procedure_address_ordinal = (dfc$first_procedure,
          { Test procedures }
          dfc$rpc_restartable_test,
          dfc$rpc_unrestartable_test,
          dfc$send_remote_cl_current,
          dfc$send_remote_cl_system,
          dfc$send_remote_message,

          { Performance tools
          dfc$send_mmio_data,
          dfc$rpc_perf_test_1,
          dfc$rpc_perf_test_2,

          { Remote procedure call usage
          dfc$receive_server_rpc_segment,

          { Job initiation / deletion
          dfc$delete_client_job,
          dfc$establish_client_job,

          { File server recovery usage
          dfc$initiate_job_recovery,
          dfc$complete_job_recovery,
          dfc$relink_server_file,
          dfc$verify_jobs,
          dfc$flush_image_file,
          dfc$get_client_job_list,
          dfc$remove_unknown_jobs,
          dfc$rpc_reserved_job_recovery_3,
          dfc$rpc_reserved_job_recovery_4,
          dfc$rpc_reserved_job_recovery_5,
          dfc$rpc_reserved_job_recovery_6,
          dfc$rpc_reserved_job_recovery_7,
          dfc$rpc_reserved_job_recovery_8,
          dfc$rpc_reserved_job_recovery_9,

          { Memory manager - system core
          dfc$r1_df_server_allocate_space,
          dfc$r1_df_server_reallocate,

          { Device manager requests
          dfc$get_server_fmd,
          dfc$df_server_set_eoi,

          { Permanent File system requests
          dfc$r2_df_server_app_rem_me_vsn,
          dfc$r2_df_server_attach,
          dfc$r2_df_server_attach_or_cref,
          dfc$r2_df_server_change,
          dfc$r2_df_server_change_cy_dam,
          dfc$r2_df_server_change_cy_dt,
          dfc$r2_df_server_change_res_rel,
          dfc$r2_df_server_clear_cy_att,
          dfc$r2_df_server_create_catalog,
          dfc$r2_df_server_define,
          dfc$r2_df_server_define_data,
          dfc$r2_df_server_delete_catalog,
          dfc$r2_df_server_delete_permit,
          dfc$r2_df_server_get_family_set,
          dfc$r2_df_server_get_famit_info,
          dfc$r2_df_server_get_info,
          dfc$r2_df_server_get_mcat_info,
          dfc$r2_df_server_get_obj_info,
          dfc$r2_df_server_permit,
          dfc$r2_df_server_purge,
          dfc$r2_df_server_put_cycle_info,
          dfc$r2_df_server_put_info,
          dfc$r2_df_server_rep_rem_me_fmd,
          dfc$r2_df_server_resolve,
          dfc$r2_df_server_return,
          dfc$r2_df_server_save_label,
          dfc$r2_df_server_validate_pw,
          dfc$r2_df_server_get_vol_cond,
          dfc$r2_df_server_change_file,

          { AV procedures
          dfc$change_login_password,
          dfc$prevalidate_job,
          dfc$get_validation_info, { Occurs during login }


          { The reserved slots are provided for initial checkout of new
          { interfaces.  This is done to avoid recompilations and mod
          { conflicts.  Meaningful aliases may be used so that the reserved
          { name is not used.  For example:
          {
          {     dfc$rpc_send_vxve_mail = dfc$rpc_reserved_vxve_1

          { Reserved for site
          dfc$rpc_reserved_site_1,
          dfc$rpc_reserved_site_2,
          dfc$rpc_reserved_site_3,
          dfc$rpc_reserved_site_4,
          dfc$rpc_reserved_site_5,

          { Reserved for vx/ve
          dfc$rpc_reserved_vxve_1,
          dfc$rpc_reserved_vxve_2,
          dfc$rpc_reserved_vxve_3,
          dfc$rpc_reserved_vxve_4,
          dfc$rpc_reserved_vxve_5,

          { Reserved for NOS/VE
          dfc$r2_df_server_ready_univ_tsk,
          dfc$change_job_validation_info,
          dfc$rpc_reserved_2 {dfc$send_client_rpc_segment},
          dfc$send_remote_app_info,
          dfc$rpc_reserved_4,
          dfc$rpc_reserved_5,

      { Reserved for NOS/VE load leveling & queue file management

          dfc$rpc_jl_job_leveler_server,
          dfc$rpc_jl_submit_job,
          dfc$rpc_jl_general_purpose,
          dfc$rpc_jl_terminate_job,
          dfc$rpc_jl_job_begin,
          dfc$rpc_jl_send_job_message,
          dfc$rpc_jl_reserved_7,
          dfc$rpc_jl_reserved_8,
          dfc$rpc_jl_reserved_9,
          dfc$rpc_jl_reserved_10,

          { Reserved for NOS/VE archiving
          dfc$r2_df_server_del_all_arc_en,
          dfc$r2_df_server_del_arch_entry,
          dfc$r2_df_server_mark_rel_cand,
          dfc$r2_df_server_put_arch_entry,
          dfc$r2_df_server_put_arch_info,
          dfc$r2_df_server_release_data,
          dfc$r2_df_server_rep_arch_entry,
          dfc$r2_df_server_save_rel_label,

          dfc$last_job_procedure,

          dfc$poll_task,

          dfc$monitor_procedures,
          dfc$read_pages,
          dfc$write_pages,
          dfc$allocate,
          dfc$last_system_procedure,
          dfc$rpc_reserved_app_1,
          dfc$rpc_reserved_app_2,
          dfc$rpc_reserved_app_3,
          dfc$rpc_reserved_app_4,
          dfc$rpc_reserved_app_5,
          dfc$rpc_reserved_app_6,
          dfc$rpc_reserved_app_7,
          dfc$rpc_reserved_app_8,
          dfc$rpc_reserved_app_9,
          dfc$rpc_reserved_app_10,
          dfc$rpc_reserved_app_11,
          dfc$rpc_reserved_app_12,
          dfc$rpc_reserved_app_13,
          dfc$rpc_reserved_app_14,
          dfc$rpc_reserved_app_15,
          dfc$rpc_reserved_app_16,
          dfc$rpc_reserved_app_17,
          dfc$rpc_reserved_app_18,
          dfc$rpc_reserved_app_19,
          dfc$rpc_reserved_app_20,
          dfc$rpc_reserved_app_21,
          dfc$rpc_reserved_app_22,
          dfc$rpc_reserved_app_23,
          dfc$rpc_reserved_app_24,
          dfc$rpc_reserved_app_25,
          dfc$rpc_reserved_app_26,
          dfc$rpc_reserved_app_27,
          dfc$rpc_reserved_app_28,
          dfc$rpc_reserved_app_29,
          dfc$rpc_reserved_app_30,
          dfc$rpc_reserved_app_31,
          dfc$rpc_reserved_app_32,
          dfc$rpc_reserved_app_33,
          dfc$rpc_reserved_app_34,
          dfc$rpc_reserved_app_35,
          dfc$rpc_reserved_app_36,
          dfc$rpc_reserved_app_37,
          dfc$rpc_reserved_app_38,
          dfc$rpc_reserved_app_39,
          dfc$rpc_reserved_app_40,
          dfc$rpc_reserved_app_41,
          dfc$rpc_reserved_app_42,
          dfc$rpc_reserved_app_43,
          dfc$rpc_reserved_app_44,
          dfc$rpc_reserved_app_45,
          dfc$rpc_reserved_app_46,
          dfc$rpc_reserved_app_47,
          dfc$rpc_reserved_app_48,
          dfc$rpc_reserved_app_49,
          dfc$rpc_reserved_app_50,
          dfc$rpc_reserved_app_51,
          dfc$rpc_reserved_app_52,
          dfc$rpc_reserved_app_53,
          dfc$rpc_reserved_app_54,
          dfc$rpc_reserved_app_55,
          dfc$rpc_reserved_app_56,
          dfc$rpc_reserved_app_57,
          dfc$rpc_reserved_app_58,
          dfc$rpc_reserved_app_59,
          dfc$rpc_reserved_app_60,
          dfc$rpc_reserved_app_61,
          dfc$rpc_reserved_app_62,
          dfc$rpc_reserved_app_63,
          dfc$rpc_reserved_app_64,
          dfc$rpc_reserved_app_65,
          dfc$rpc_reserved_app_66,
          dfc$rpc_reserved_app_67,
          dfc$rpc_reserved_app_68,
          dfc$rpc_reserved_app_69,
          dfc$rpc_reserved_app_70,
          dfc$rpc_reserved_app_71,
          dfc$rpc_reserved_app_72,
          dfc$rpc_reserved_app_73,
          dfc$rpc_reserved_app_74,
          dfc$rpc_reserved_app_75,
          dfc$rpc_reserved_app_76,
          dfc$rpc_reserved_app_77,
          dfc$rpc_reserved_app_78,
          dfc$rpc_reserved_app_79,
          dfc$rpc_reserved_app_80,
          dfc$rpc_reserved_app_81,
          dfc$rpc_reserved_app_82,
          dfc$rpc_reserved_app_83,
          dfc$rpc_reserved_app_84,
          dfc$rpc_reserved_app_85,
          dfc$rpc_reserved_app_86,
          dfc$rpc_reserved_app_87,
          dfc$rpc_reserved_app_88,
          dfc$rpc_reserved_app_89,
          dfc$rpc_reserved_app_90,
          dfc$rpc_reserved_app_91,
          dfc$rpc_reserved_app_92,
          dfc$rpc_reserved_app_93,
          dfc$rpc_reserved_app_94,
          dfc$rpc_reserved_app_95,
          dfc$rpc_reserved_app_96,
          dfc$rpc_reserved_app_97,
          dfc$rpc_reserved_app_98,
          dfc$rpc_reserved_app_99,
          dfc$last_application_ordinal);

    TYPE
      dft$procedure_address_ordinals = set of dft$procedure_address_ordinal;

    CONST
     dfc$send_client_rpc_segment = dfc$rpc_reserved_2;
*DECK DECK=DFT$PROCEDURE_ADDRESS_RANGE EXPAND=FALSE
 TYPE
   dft$procedure_address_range =  dfc$first_procedure .. dfc$last_system_procedure;
?? PUSH (LISTEXT := ON) ??
*copyc dft$procedure_address_ordinal
?? POP ??
*DECK DECK=DFT$PROCEDURE_CLASS EXPAND=FALSE
 TYPE
    dft$procedure_class = (dfc$monitor_call, dfc$system_core_call, dfc$task_services_call,
      dfc$permanent_file_call, dfc$application_call);
*DECK DECK=DFT$PROCEDURE_VERSION EXPAND=FALSE

  TYPE
    dft$procedure_version = string (4);


*DECK DECK=DFT$P_STATE_CHANGE_PROCEDURE EXPAND=FALSE

  TYPE
    dft$p_state_change_procedure = ^procedure
           (    partner_mainframe: pmt$mainframe_id;
                partner_is_server: boolean;
                previous_state: dft$server_state;
                new_state: dft$server_state;
            VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$server_state
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=DFT$QUEUE_DIRECTORY_INDEX EXPAND=FALSE
{Deck:  DFT$QUEUE_DIRECTORY_INDEX
  CONST
   dfc$maximum_queue_interfaces = 16;

  TYPE
    dft$queue_directory_index = 1 .. dfc$maximum_queue_interfaces;

*DECK DECK=DFT$QUEUE_ENTRY_LOCATION EXPAND=FALSE
{ Xref deck - dft$queue_entry_location.

  TYPE
    dft$queue_entry_location = record
      directory_index: dft$queue_directory_index,
      queue_index: dft$queue_index,
      queue_entry_index: dft$queue_entry_index,
    recend;

?? PUSH (LISTEXT:=ON) ??
*copyc dft$queue_interface_directory
*copyc dft$queue_index
?? POP ??
*DECK DECK=DFT$QUEUE_ENTRY_TYPE EXPAND=FALSE
  TYPE
    dft$queue_entry_type = (dfc$monitor, dfc$task_services);

*DECK DECK=DFT$QUEUE_INDEX EXPAND=FALSE
{ DECK: DFT$QUEUE_INDEX

  CONST
    dfc$max_number_of_queues = 16,
    dfc$max_queue_entries = 127;


  TYPE
    dft$queue_index = 1 .. dfc$max_number_of_queues,
    dft$queue_entry_index = 1 .. dfc$max_queue_entries;


*DECK DECK=DFT$QUEUE_INTERFACE_DIRECTORY EXPAND=FALSE
{Deck: DFT$QUEUE_INTERFACE_DIRECTORY

  TYPE
    dft$p_queue_interface_directory = ^dft$queue_interface_directory,

    dft$queue_interface_directory = array [1 .. * ] of
          dft$q_interface_directory_entry,

    dft$q_interface_directory_entry = record
      driver_name: ost$name,   {send channel for esm, driver name for non-esm connections
      p_queue_interface_table: dft$p_queue_interface_table,
      use_dma: boolean,
      driver_active: boolean,
      case connection_type: dft$connection_type of
      = dfc$esm_connection =
        load_unload_pp_lock: ost$signature_lock,
        element_name: cmt$element_name,
        send_channel: dft$channel_specification,
        receive_channel: dft$channel_specification,
        send_pp: dft$esm_pp_information,
        receive_pp: dft$esm_pp_information,
      casend,
    recend,

    dft$esm_pp_information = record
      pp_status: dft$pp_status,
      channel_address: cmt$physical_equipment_number,
      dma_capability: boolean,
      p_element_reservations: ^dft$pp_element_reservations,
    recend,

    dft$pp_status = record
      activated: boolean,
      loaded: boolean,
      idled: boolean,
    recend;

*copyc cmt$element_name
*copyc cmt$physical_equipment_number
*copyc dfd$driver_queue_types
*copyc dft$channel_specification
*copyc dft$connection_type
*copyc dft$esm_definition_table
*copyc dft$pp_element_reservations
*copyc dft$queue_directory_index
*copyc ost$name
*copyc ost$signature_lock
*DECK DECK=DFT$QUEUE_REQUEST_STATUS EXPAND=FALSE

  TYPE
    dft$queue_request_status = (dfc$qrs_entry_queued,
        dfc$qrs_request_buffer_full, dfc$qrs_driver_idle,
         dfc$qrs_invalid_queue_index, dfc$qrs_invalid_entry_index,
         dfc$qrs_server_terminated);
*DECK DECK=DFT$RB_FILE_SERVER_REQUEST EXPAND=FALSE
    TYPE
    dft$rb_file_server_request = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      case request: (dfc$fsr_restart_server_request, dfc$fsr_request_timeout,
            dfc$fsr_term_client_tasks, dfc$fsr_set_task_segment_state,
            dfc$fsr_set_job_segment_state, dfc$fsr_verify_sdtx_recovery,
            dfc$fsr_clear_inhibit_access) OF
      = dfc$fsr_restart_server_request =
        p_cpu_queue_entry: ^dft$cpu_queue_entry,
        remote_request: dft$remote_request,

      = dfc$fsr_request_timeout =
        p_queue_interface_table: dft$p_queue_interface_table,
        queue_index: dft$queue_index,
        queue_entry_index: dft$queue_entry_index,

      = dfc$fsr_term_client_tasks =
        cpu_queue_entry_p: ^dft$cpu_queue_entry,
        one_word_response: dft$fs_pp_response,
        queue_interface_table_p: dft$p_queue_interface_table,

     = dfc$fsr_set_task_segment_state =
        inhibit_access_work: dft$mainframe_set,
        terminate_access_work: dft$mainframe_set,

     = dfc$fsr_set_job_segment_state =
        ijl_ordinal: jmt$ijl_ordinal,
        job_inhibit_access_work: dft$mainframe_set,
        job_terminate_access_work: dft$mainframe_set,

     = dfc$fsr_verify_sdtx_recovery =
        recovered_job_ijl_ordinal: jmt$ijl_ordinal,
        recovered_mainframe: dft$mainframe_set,

     = dfc$fsr_clear_inhibit_access =
        clear_ijl_ordinal: jmt$ijl_ordinal,
        clear_inhibit_work: dft$mainframe_set,
       casend,
      recend;
*copyc dfd$driver_queue_types
*copyc dft$cpu_queue
*copyc dft$fs_pp_response
*copyc dft$mainframe_set
*copyc dft$queue_index
*copyc dft$remote_request
*copyc iot$pp_interface_table
*copyc jmt$ijl_ordinal
*copyc syt$monitor_request_code
*DECK DECK=DFT$READ_WRITE_LOCK EXPAND=FALSE

  TYPE
    dft$read_write_lock = record
      reject_count: ALIGNED [0 MOD 8] integer,
      reader_count: ALIGNED [0 MOD 8] integer,
      writer_count: ALIGNED [0 MOD 8] integer,
      write_lock: ost$signature_lock,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??
*DECK DECK=DFT$RECEIVE_SERVER_RPC_SEGMENT EXPAND=FALSE

{ Deck: dft$receive_server_rpc_segment

  TYPE
    dft$receive_server_rpc_segment = record
      starting_offset: ost$segment_length,
      receive_size: dft$send_data_size,
    recend;

*copyc dft$rpc_parameters
*copyc osd$virtual_address
*DECK DECK=DFT$RELEASE_QUEUE_ENTRY_STATUS EXPAND=FALSE

  TYPE
    dft$release_queue_entry_status = (dfc$rqes_entry_released,
          dfc$rqes_invalid_queue_index, dfc$rqes_invalid_entry_index,
          dfc$rqes_entry_not_assigned);

*DECK DECK=DFT$REMOTE_APPLICATION_INFO EXPAND=FALSE

  TYPE
    dft$remote_application_info = record
      application_name: ost$name,
      first_procedure_rpc_ordinal: dft$procedure_address_ordinal,
      number_of_procedures: dft$number_of_procs_per_app,
      next_p_application_info: ^dft$remote_application_info,
   recend;


*copyc dft$application_support_limits
*copyc dft$procedure_address_ordinal
*copyc ost$name
*DECK DECK=DFT$REMOTE_REQUEST EXPAND=FALSE
{*copyc dft$remote_request

  TYPE
    dft$remote_request = (dfc$read_for_client, dfc$write_for_client, dfc$allocate_space_for_client,
          dfc$completing_previous_request);

*DECK DECK=DFT$REQUEST_BUFFER EXPAND=FALSE
{ DECK: DFT$REQUEST_BUFFER

{  INN, OUT,  and LIMIT values describe the byte offset from the
{  buffer start.  All three values are multiples of 8.
{  The following conventions apply to this circular request buffer.
{  * LIMIT = total bytes in the buffer
{  * INN + start is the next place for CPU to put entry
{  * OUT + start is the next place for the PP to take an entry
{  * IF INN = OUT THEN buffer is empty
{  * IF INN = OUT - 8 THEN  buffer is full
{  * first is the logical successor of first + LIMIT - 8


  TYPE
    dft$request_buffer_directory = record
      inn: ALIGNED [0 MOD 8] integer,
      out: ALIGNED [0 MOD 8] integer,
      limit: ALIGNED [0 MOD 8] integer,
      fill3: ALIGNED [0 MOD 8] 0 .. 0FFFFFFFF(16),
      request_buffer_rma: ALIGNED [4 MOD 8] ost$real_memory_address,
      fill4: ALIGNED [0 MOD 8] 0 .. 0FFFF(16),
      p_request_buffer: ALIGNED [2 MOD 8] ^dft$request_buffer,
    recend;

  TYPE
    dft$request_buffer = record
      {Driver'S WORK TO DO LIST}
      request_buffer_entries: ALIGNED [0 MOD 4096] dft$request_buffer_entries,
    recend,

    dft$request_buffer_entries = array [1 .. dfc$max_request_buffer_entries] of
          dft$request_buffer_entry;


  TYPE
    dft$request_buffer_entry = record
      flags: ALIGNED [0 MOD 8] dft$request_buffer_entry_flags,
      fill1: ALIGNED [2 MOD 8] 0 .. 0FFFF(16),
      inquiry_message: ALIGNED [4 MOD 8] dft$inquiry_message,
      queue_index: ALIGNED [6 MOD 8] 0 .. 0FF(16),
      queue_entry_index: ALIGNED [7 MOD 8] 0 .. 0FF(16),
    recend,

    dft$request_buffer_entry_flags = packed record
      previously_processed: boolean,
      inquiry: boolean,
      fill: 0 .. 3FFF(16),
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dft$inquiry_message
*copyc ost$hardware_subranges
?? POP ??


*DECK DECK=DFT$RPC_BUFFER_HEADER EXPAND=TRUE
{Deck:  DFT$RPC_BUFFER_HEADER

  { Send from CLIENT --->  SERVER
  TYPE
    dft$rpc_buffer_header = record
      system_supplied_job_name: jmt$system_supplied_name,
      procedure_version: dft$procedure_version,
      procedure_name_checksum: dft$checksum,
      call_progress: dft$rpc_progress_record,
      case procedure_class: dft$procedure_class of
      = dfc$permanent_file_call =
        client_job_id: dft$client_job_id,
        system_administrator: boolean,
        family_administrator: boolean,
      casend,
    recend;

  { Send to CLIENT <--- SERVER
  TYPE
    dft$rpc_response_buffer_header = record
      call_progress: dft$rpc_progress_record,
    recend;
*copyc dft$procedure_version
*copyc dfd$request_package
*copyc dft$client_job_id
*copyc dft$procedure_class
*copyc dft$rpc_progress_record
*copyc jmt$system_supplied_name

*DECK DECK=DFT$RPC_PARAMETERS EXPAND=FALSE
{ Deck:  DFT$RPC_PARAMETERS

  CONST
    dfc$maximum_user_buffer_area = 3600;

  CONST
    { 524,288 bytes = 128 pages = 32 trips of 4 pages each . Where page = 4096
    dfc$maximum_user_data_area = 524288;

  TYPE
    { This divides up the one page (assumed 4K for now) buffer into the server
    { header,  status : ost$status (when returning from server), and the users
    { parameter area.
    dft$send_parameter_size = 0 .. dfc$maximum_user_buffer_area,
    dft$p_send_parameters= ^SEQ (REP dfc$maximum_user_buffer_area OF cell),

    dft$send_data_size = 0 .. dfc$maximum_user_data_area,
    dft$p_send_data = ^SEQ (REP dfc$maximum_user_data_area OF cell),

    { This is the exact size of the area returned from the other side
    { This may be no greater than dfc$maximum_user_buffer_area
    dft$p_receive_parameters = ^SEQ ( * ),
    dft$p_receive_data = ^SEQ ( * );


*DECK DECK=DFT$RPC_PROCEDURE_ADDRESS_LIST EXPAND=FALSE
{Deck: DFT$RPC_PROCEDURE_ADDRESS_LIST

  TYPE
    dft$rpc_procedure_address_list = array [dft$procedure_address_range] of
          dft$rpc_procedure_address_entry,


    dft$rpc_procedure_address_entry = record
      debug_display: ost$name,
      procedure_address: dft$rpc_procedure_address,
      class: dft$procedure_class,
      request_restartable: dft$request_restartable,
      { Job recovery location is used on the client to determine
      { where the server job recovery should be performed.
      job_recovery_location: dft$job_recovery_location,

      { recover_job_on_server_call is used to determine what should be
      { done with client jobs when the server was actively processing a
      { remote procedure call at the time of the failure.  A value of
      { FALSE indicates the job is unrecoverable.
      recover_job_on_server_call: boolean,
      procedure_version: dft$procedure_version,
      procedure_name_checksum: dft$checksum,
      { The next three fields are meaningful only for the "extended" address
      { list for applications.
      application_index: dft$number_of_applications,
      application_ring: osc$tsrv_ring .. osc$max_ring,
      allow_terminate_break: boolean,
      allow_pause_break: boolean,
    recend,

    dft$rpc_procedure_address = ^procedure
           (VAR p_param_received_from_client {Input} :
                 dft$p_receive_parameters;
            VAR p_data_from_client {Input} : dft$p_receive_data;
            VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
            VAR p_data_to_client {^Output} : dft$p_send_data;
            VAR send_parameters_length: dft$send_parameter_size;
            VAR data_size_to_send_to_client: dft$send_data_size;
            VAR status: ost$status);

  TYPE
    dft$request_restartable = (dfc$request_restartable,
          dfc$request_not_restartable);

*copyc dfd$request_package
*copyc dft$application_support_limits
*copyc dft$job_recovery_location
*copyc dft$procedure_address_range
*copyc dft$procedure_class
*copyc dft$procedure_version
*copyc dft$rpc_parameters
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status

*DECK DECK=DFT$RPC_PROGRESS_RECORD EXPAND=FALSE
{Deck:  DFT$RPC_PROGRESS_RECORD

  TYPE
    dft$rpc_progress_record = record
      { Describe the current state of the request.
      transaction_per_rpc_request: 0 .. 0ffff(16),
      total_data_sent: dft$send_data_size,
      total_data_received: dft$send_data_size,

      { Describe the completed state of the request.
      { This is the exact number of bytes, ( not rounded to word or pages size)
      user_buffer_length_sent: dft$send_parameter_size,
      user_data_length_sent: dft$send_data_size,
    recend;


*copyc dft$rpc_parameters





*DECK DECK=DFT$RPC_QUEUE_ENTRY_LOCATION EXPAND=FALSE
{Deck:  DFT$RPC_QUEUE_ENTRY_LOCATION

  TYPE
    dft$rpc_queue_entry_location = integer;
*DECK DECK=DFT$RPC_QUEUE_ENTRY_LOC_INT EXPAND=FALSE
{Deck:  DFT$RPC_QUEUE_ENTRY_LOC_INT

  TYPE
    dft$rpc_queue_entry_loc_int = record
      server_mainframe_id: pmt$binary_mainframe_id,
      queue_directory_index: dft$queue_directory_index,
      queue_index: dft$queue_index,
      queue_entry_index: dft$queue_entry_index,
    recend;

*copyc dft$queue_directory_index
*copyc dft$queue_index
*copyc pmt$binary_mainframe_id
*DECK DECK=DFT$RPC_SERVED_JOB_LIST EXPAND=FALSE
{ Deck:  DFT$RPC_SERVED_JOB_LIST
{   Format of served job list sent from server, checked on client. then list
{   of jobs no longer existing returned to server.

  TYPE
    dft$rpc_served_job_list_header = record
      number_of_jobs: ost$non_negative_integers,
      { number_of_jobs_awaiting_rec is only meaningful from server to client.
      number_of_jobs_awaiting_rec: ost$non_negative_integers,
    recend;

  TYPE
    dft$rpc_served_job_list_data = record
      system_supplied_job_name: jmt$system_supplied_name,
      client_job_id: dft$client_job_id,
    recend;

*copyc dft$client_job_id
*copyc jmt$system_supplied_name
*copyc osd$integer_limits
*DECK DECK=DFT$RPC_TEST_REQUEST_HEADER EXPAND=FALSE
{ Deck:  DFT$RPC_TEST_REQUEST_HEADER
 CONST
   dfc$maximum_test_request_buffer = dfc$maximum_user_buffer_area -
      71 {#size(dft$rpc_test_request_header)};

 TYPE
    dft$rpc_test_request_header = record
      compute_checksum: boolean,
      start_time: integer,
      { Describe send buffer - from sender perspective
      send_buffer_size: dft$send_parameter_size,
      receive_buffer_size: dft$send_parameter_size,
      send_buffer_starting_char: char,
      buffer_checksum: dft$checksum,

      { Describe data - from sender perspective
      send_data_size: dft$send_data_size,
      receive_data_size: dft$send_data_size,
      data_starting_char: char,
      data_checksum: dft$checksum,

      { Describe server to client segment - from client's perspective
      receive_segment_size: ost$segment_length,
      receive_segment_offset: ost$segment_length,
      segment_starting_char: char,
      segment_checksum: dft$checksum,

     { Describe client to server segment - from client's perspective
      send_segment_size: ost$segment_length,
      send_segment_offset: ost$segment_length,
      send_segment_starting_char: char,
      send_segment_checksum: dft$checksum,
    recend;

*copyc dfd$request_package
*copyc dft$rpc_parameters
*copyc osd$virtual_address
*DECK DECK=DFT$SDP_COMMUNICATION_BUFFER EXPAND=FALSE
  TYPE
    word_zero_type = packed record
      cpu_status: 0 .. 0ffff(16),
      iou_type: 0 .. 0ffff(16),
      channel_number: 0 .. 0ffff(16),
      reserved: 0 .. 0ffff(16),
    recend;

  TYPE
    word_one_type = packed record
      ppu_status: 0 .. 0ffff(16),
      concurrent_pp: 0 .. 1(2),
      pp_number: 0 .. 7fff(16),
      iou_number: 0 .. 0ffff(16),
      concurrent_channel: 0 .. 1(2),
      channel_number: 0 .. 7fff(16),
    recend;

  TYPE
    dft$sdp_communication_buffer = packed record
      word_zero: word_zero_type,
      word_one: word_one_type,
      word_two: 0 .. 7fffffffffffffff(16),
      word_three: 0 .. 7fffffffffffffff(16),
      word_four: 0 .. 7fffffffffffffff(16),
      word_five: 0 .. 7fffffffffffffff(16),
      word_six: 0 .. 7fffffffffffffff(16),
      word_seven: 0 .. 7fffffffffffffff(16),
      word_eight: 0 .. 7fffffffffffffff(16),
      word_nine: 0 .. 7fffffffffffffff(16),
      word_ten: 0 .. 7fffffffffffffff(16),
      word_eleven: 0 .. 7fffffffffffffff(16),
      word_twelve: 0 .. 7fffffffffffffff(16),
      word_thirteen: 0 .. 7fffffffffffffff(16),
      word_fourteen: 0 .. 7fffffffffffffff(16),
      word_fifteen: 0 .. 7fffffffffffffff(16),
      word_sixteen: 0 .. 7fffffffffffffff(16),
      word_seventeen: 0 .. 7fffffffffffffff(16),
      word_eighteen: 0 .. 7fffffffffffffff(16),
    recend;

*DECK DECK=DFT$SDP_LOGGING_CODE EXPAND=FALSE
  TYPE
    dft$sdp_logging_code = (dfc$sdp_initialization, dfc$sdp_top_of_hour);

*DECK DECK=DFT$SEND_CLIENT_RPC_SEGMENT EXPAND=FALSE
{ Deck: dft$send_client_rpc_segment

  TYPE
    dft$send_client_rpc_segment = record
      starting_offset: ost$segment_length,
      send_size: dft$send_data_size,
    recend;

*copyc dft$rpc_parameters
*copyc osd$virtual_address

*DECK DECK=DFT$SERVED_FAMILY_TABLE EXPAND=FALSE
  TYPE
    dft$served_family_table_root = record
      valid: boolean,
      number_of_active_pointers: ALIGNED [0 MOD 8] integer,
      p_family_list_pointer_array: ^dft$served_family_list_pointers,
    recend,

    dft$served_family_list_pointers = array [1 .. * ] of
          dft$served_family_list_pointer,

    dft$served_family_list_pointer = record
      highest_valid_entry: ALIGNED [0 MOD 8] integer,
      p_served_family_list: ^array [dft$served_family_list_index] of
            dft$served_family_table_entry,
    recend;

  CONST
    dfc$served_family_string_size = dfc$served_family_list_size;

  TYPE
    dft$served_family_table_entry = record
      family_name: ost$family_name,
      verified_by_server: boolean,
      { The purpose of the active_since_deadstart field is to determine
      { whether a served family in the awaiting recovery can be recovered.
      active_since_deadstart: boolean,
      family_access: dft$family_access,
      server_mainframe_id: pmt$binary_mainframe_id,
      server_state: dft$server_state,
      server_lifetime: dft$server_lifetime,
      server_birthdate: integer,
      connection_type: dft$connection_type,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
    recend;

*copyc dfd$driver_queue_types
*copyc dft$connection_type
*copyc dft$entry_type
*copyc dft$family_access
*copyc dft$served_family_table_index
*copyc dft$server_lifetime
*copyc dft$server_state
*copyc ost$user_identification
*copyc pmt$binary_mainframe_id
*DECK DECK=DFT$SERVED_FAMILY_TABLE_INDEX EXPAND=FALSE

 TYPE
    dft$served_family_table_index = record
      pointers_index: dft$family_pointer_index,
      family_list_index: dft$served_family_list_index,
    recend;

  CONST
    dfc$served_family_list_size = 16;

  TYPE
    dft$served_family_list_index = 1 .. dfc$served_family_list_size;

  CONST
    dfc$max_family_ptr_array_size = 0ff(16);

  TYPE
    dft$family_pointer_index = 1 .. dfc$max_family_ptr_array_size;
*DECK DECK=DFT$SERVER_ALLOCATION_INFO EXPAND=FALSE

  TYPE
    dft$server_allocation_info = RECORD
      CASE allocation_needed_on_server: boolean OF
      = FALSE =
        invalid_data: 0 .. 3fffffffffff(16),
      = TRUE =
        bytes_to_allocate: amt$file_byte_address,
      CASEND,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
?? POP ??
*DECK DECK=DFT$SERVER_DESCRIPTOR EXPAND=FALSE

{ DECK: DFT$SERVER_DESCRIPTOR
{ This describes the data structure that is used on the client mainframe to
{ describe the server file.  This is used as the served file variant portion of
{ the MEDIA field in a File_Descriptor_Entry (FDE).

  TYPE
    dft$server_descriptor_p = ^dft$server_descriptor,

    dft$server_descriptor = record
      header: dft$server_descriptor_header,
    recend,

    dft$server_descriptor_header = record
      server_mainframe_id: pmt$binary_mainframe_id,
      served_family_table_index: dft$served_family_table_index,
      server_lifetime: dft$lifetime,
      read_write_count: 0 .. 0ffff(16),
      purged: boolean,
      highest_offset_allocated: amt$file_byte_address,
      bytes_per_allocation: 0 .. dmc$max_bytes_per_allocation,
      case file_state: dft$server_state of
      = dfc$active =
        { The file state is never really changed to dfc$inactive,
        { or dfc$deactivated despite the fact the queues are in that state.
        total_allocated_length: amt$file_byte_address,
        remote_sfid: gft$system_file_identifier,
        allow_other_mainframe_writer: boolean,
        allocation_info: dft$server_allocation_info,
        requested_transfer_size: dmt$transfer_size,
      = dfc$terminated, dfc$awaiting_recovery =
        { The information needs to be re-obtained from the server mainframe.
        { The file state is never changed to dfc$recovering, or
        { dfc$deleted
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc amt$file_limit
*copyc amt$preset_value
*copyc dft$lifetime
*copyc dft$served_family_table_index
*copyc dft$server_allocation_info
*copyc dft$server_state
*copyc dmt$allocation_size
*copyc dmt$minimum_allocation_unit
*copyc dmt$transfer_size
*copyc gft$system_file_identifier
*copyc ost$clear_file_space
*copyc pmt$binary_mainframe_id
?? POP ??

*DECK DECK=DFT$SERVER_FILE_OUTPUT EXPAND=FALSE

  TYPE
    dft$server_file_output = record
      bytes_per_allocation: dmt$bytes_per_allocation,
      eoi_byte_address: amt$file_byte_address,
      file_limit: amt$file_limit,
      preset_value: amt$preset_value,
      remote_sfid: gft$system_file_identifier,
      requested_transfer_size: dmt$transfer_size,
      shared_queue: mmt$shared_queue,
      total_allocated_length: amt$file_byte_address,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc amt$file_limit
*copyc amt$preset_value
*copyc dmt$allocation_size
*copyc dmt$transfer_size
*copyc gft$system_file_identifier
*copyc mmt$shared_queue
?? POP ??
*DECK DECK=DFT$SERVER_IOCB_ERROR_CONDITION EXPAND=FALSE
{*copyc dft$server_iocb_error_condition

?? FMT (FORMAT := OFF) ??
  TYPE
    dft$server_iocb_error_condition = (

{                                    } dfc$null_server_condition,

{ The following conditions are used to determine which request should be reissued.

{                                    } dfc$reissued_rq_no_memory,
{                                    } dfc$reissued_rq_low_on_memory,
{                                    } dfc$reissued_rq_pt_full,
{                                    } dfc$reissued_rq_io_temp_reject,
{                                    } dfc$reissu_rq_temp_rej_fde_lock,
{                                    } dfc$reissued_rq_temp_rej_q_full,
{                                    } dfc$reissued_rq_io_still_active,
{                                    } dfc$reissued_rq_task_queued,
{                                    } dfc$reissue_rq_client_locked_pg,

{ The following conditions are genuine SERVER errors.

{                                    } dfc$server_page_locked,
{                                    } dfc$server_read_beyond_eoi,
{                                    } dfc$server_beyond_file_limit,
{                                    } dfc$server_no_extend_permission,
{                                    } dfc$server_signal_select_on_pf,
{                                    } dfc$server_beyond_tape_window,
{                                    } dfc$server_io_already_active,
{                                    } dfc$server_io_not_active,
{                                    } dfc$server_pages_not_available,
{                                    } dfc$server_write_client_error,
{                                    } dfc$bad_sfid,
{                                    } dfc$server_terminated,
{                                    } dfc$volume_unavailable,

{ The following conditions correspond to I/O errors found in the deck IOE$ST_ERRORS,
{ and are converted with the following formula:
{       DFC$GENERIC_DF_ERROR = $INTEGER (IOC$GENERIC_DISK_ERROR) - $INTEGER (IOC$ST_ERRORS) +
{             $INTEGER (DFC$IO_TO_DF_ERROR_CONVERTER) - 1

{                                    } dfc$unrecovered_disk_error,
{                                    } dfc$pp_not_configured,
{                                    } dfc$pp_interlock_set,
{                                    } dfc$no_space_to_allocate,
{                                    } dfc$invalid_image_request,
{                                    } dfc$invalid_disk_type,
{                                    } dfc$disk_media_error,
{                                    } dfc$requests_full,
{                                    } dfc$unable_to_build_io_request,
{                                    } dfc$free_failure,
{                                    } dfc$address_error,
{                                    } dfc$unable_to_unlock_rma_list,
{                                    } dfc$unable_to_set_system_flag,
{                                    } dfc$allocation_failure,
{                                    } dfc$unable_to_queue_io_request,
{                                    } dfc$unable_to_destroy_io_req,
{                                    } dfc$io_completion_table_error,
{                                    } dfc$unsupported_monitor_request,
{                                    } dfc$request_id_mismatch,
{                                    } dfc$io_request_error,
{                                    } dfc$ssiot_recovery_required,
{                                    } dfc$unit_disabled,
{                                    } dfc$critical_device_disabled,
{                                    } dfc$no_idle_response);

?? FMT (FORMAT := ON) ??

  CONST
    dfc$io_to_df_error_converter = dfc$unrecovered_disk_error;

*DECK DECK=DFT$SERVER_LIFETIME EXPAND=FALSE
{ DECK: DFT$SERVER_LIFETIME

  TYPE
    dft$server_lifetime = dft$lifetime;

*copyc dft$lifetime
*DECK DECK=DFT$SERVER_LOCATION EXPAND=FALSE
{Deck:  DFT$SERVER_LOCATION
  TYPE
    dft$server_location = record
      case server_location_selector: dft$server_location_selector of
      = dfc$family_name =
        family_name: ost$family_name,
      = dfc$served_family_table_index =
        served_family_table_index: dft$served_family_table_index,
      = dfc$mainframe_id =
        server_mainframe: pmt$mainframe_id,
      casend,
    recend;

*copyc dft$server_location_selector
*copyc dft$served_family_table_index
*copyc ost$user_identification
*copyc pmt$mainframe_id

*DECK DECK=DFT$SERVER_LOCATION_SELECTOR EXPAND=FALSE
{Deck:  DFT$SERVER_LOCATION_SELECTOR
  TYPE
    dft$server_location_selector = (dfc$family_name,
          dfc$served_family_table_index, dfc$mainframe_id);



*DECK DECK=DFT$SERVER_STATE EXPAND=FALSE
{ DECK: DFT$SERVER_STATE

  TYPE
    dft$server_state = (dfc$active, dfc$deactivated, dfc$inactive,
          dfc$awaiting_recovery, dfc$recovering, dfc$terminated, dfc$deleted),

   dft$server_states = set of dft$server_state;
*DECK DECK=DFT$START_JOB_RECOVERY EXPAND=FALSE
{ Deck:  DFT$START_JOB_RECOVERY
  TYPE
    dft$start_job_recovery_in = record
      system_supplied_job_name: jmt$system_supplied_name,
    recend,

    dft$start_job_recovery_out = record
      client_job_id: dft$client_job_id,
    recend;

*copyc dft$client_job_id
*copyc jmt$system_supplied_name

*DECK DECK=DFT$TRANSACTION_STATE EXPAND=FALSE
{ DECK: DFT$TRANSACTION_STATE

{ Transaction State, maintained in the cpu queue entry, indicates what is known
{ about the progress of a file server request. Transaction state, request start
{ time, request timeout count, and retransmission count, are the parameters
{ which determine if the client side should attempt to "retransmit" a file
{ server request.
{ The transaction state values which may be present in the client side cpu
{ queue entry are:
{   dfc$null_state = queue allocated, not initialized.
{   dfc$queue_entry_available = queue entry is not assigned to a task.
{   dfc$queue_entry_assigned = queue entry assigned to a task.
{   dfc$request_queued = file server request queued for driver to process.
{   dfc$request_sent = driver has sent client's request to server side.
{   dfc$server_must_read_page_data = server has received command, not data yet.
{   dfc$server_received_request = server has received command and data if any.
{   dfc$server_sent_response = driver has sent server's response to client side.
{   dfc$client_must_read_page_data = client has received response, not data yet.
{   dfc$response_received = client has received response and data if any.
{   dfc$media_error = driver detected a failure in the connection between client
{      and server. The client must attempt to retransmit file server request.
{   dfc$message_content_error = server detected erronious data or some
{      inconsistency in the command message received from client. The client
{      must attempt to retransmit file server request.
{
{ The transaction state values which may be present in the server side cpu
{ queue entry are:
{   dfc$null_state = queue allocated, not initialized.
{   dfc$server_waiting_request = server completed a transaction, ready for next.
{   dfc$server_must_read_page_data = server has received command, not data yet.
{   dfc$server_received_request = server has received command and data if any.
{   dfc$media_error = driver detected a failure in the connection between client
{      and server. The client must attempt to retransmit file server request.
{   dfc$message_content_error = server detected erronious data or some
{      inconsistency in the command message received from client. The client
{      must attempt to retransmit file server request.

TYPE
  dft$transaction_state = (dfc$null_state, dfc$queue_entry_available,
       dfc$queue_entry_assigned, dfc$request_queued, dfc$request_sent,
       dfc$server_must_read_page_data, dfc$server_received_request,
       dfc$server_sent_response, dfc$client_must_read_page_data,
       dfc$response_received, dfc$media_error, dfc$message_content_error,
       dfc$server_waiting_request, dfc$terminate_break_signal,
       dfc$pause_break_signal),

  dft$transaction_state_set = set of dft$transaction_state;
*DECK DECK=DFV$ACTIVE_QUEUE_ENTRY_FLAGS EXPAND=FALSE
   VAR
     dfv$active_queue_entry_flags: [XREF] dft$queue_entry_flags;

*copyc dfd$driver_queue_types
*DECK DECK=DFV$APPLICATION_INFO_LOCK EXPAND=FALSE

  VAR
    { This lock is to insure application information is not added and deleted
    {simultaneously.
    dfv$application_info_lock: [XREF, dfs$server_wired] ost$signature_lock;
?? PUSH (LISTEXT := ON) ??
*copyc dfs$server_wired
*copyc ost$signature_lock
?? POP ??
*DECK DECK=DFV$CH_QUEUE_ENTRY_LOCATION EXPAND=FALSE

{ This variable is used in File Server task services condition handling.

  VAR
    dfv$ch_queue_entry_location: [STATIC] dft$rpc_queue_entry_location;

?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_queue_entry_location
?? POP ??
*DECK DECK=DFV$CLIENT_MAINFRAME_FILE_LOCK EXPAND=FALSE
  VAR
    { This lock os used to prevent the display manager from attempting to
    { display a mainframe file being created.
    dfv$client_mainframe_file_lock: [XREF] ost$signature_lock;

*copyc ost$signature_lock
*DECK DECK=DFV$DEFINED_SERVER_TRANSLATION EXPAND=FALSE
 VAR
    dfv$defined_server_translation: [XREF] dft$defined_server_translation;

*copyc dft$defined_server_translation
*DECK DECK=DFV$DISPLAY_POLL EXPAND=FALSE

  VAR
    dfv$display_poll : [XREF] boolean;
*DECK DECK=DFV$FALSE_QUEUE_ENTRY_FLAGS EXPAND=FALSE

  VAR
    dfv$false_queue_entry_flags: [XREF] dft$queue_entry_flags;


*copyc dfd$driver_queue_types
*DECK DECK=DFV$FAMILY_ACCESS_ENABLED EXPAND=FALSE
  VAR
    dfv$family_access_enabled: [XREF] boolean;

*DECK DECK=DFV$FILE_SERVER_DEBUG_ENABLED EXPAND=FALSE
  VAR
    dfv$file_server_debug_enabled: [XREF] boolean;

*DECK DECK=DFV$FILE_SERVER_INFO_ENABLED EXPAND=FALSE
  VAR
    dfv$file_server_info_enabled: [XREF] boolean;
*DECK DECK=DFV$JOB_RECOVERY_ENABLED EXPAND=FALSE

  VAR
    dfv$job_recovery_enabled: [XREF] boolean;
*DECK DECK=DFV$JOB_RECOVERY_RPC_REQUESTS EXPAND=FALSE

  VAR
    dfv$job_recovery_rpc_requests: [XREF]
          dft$procedure_address_ordinals;
*copyc dft$procedure_address_ordinal
*DECK DECK=DFV$MAXIMUM_CLIENT_JOB_LISTS EXPAND=FALSE

  VAR
    { This is an integer to allow use with sym$system_constant_manager.
    { The true value range is 1 .. dfc$max_job_list_p_array_size
    dfv$maximum_client_job_lists: [XREF] integer;
?? PUSH (LISTEXT := ON) ??
*copyc dfs$server_wired
*copyc dft$client_mainframe_file
*copyc dft$client_job_id
?? POP ??
*DECK DECK=DFV$MONITOR_IO_START_TIME EXPAND=FALSE
  VAR
    dfv$monitor_io_start_time: [XREF] integer;
*DECK DECK=DFV$NULL_GLOBAL_TASK_ID EXPAND=FALSE
  VAR
    dfv$null_global_task_id : [XREF] ost$global_task_id;
?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
?? POP ??
*DECK DECK=DFV$NULL_REQUEST_BUFFER_ENTRY EXPAND=FALSE

  VAR
    dfv$null_request_buffer_entry: [XREF]
          dft$request_buffer_entry;

*copyc dft$request_buffer
*DECK DECK=DFV$NUMBER_SERVED_FAMILY_LISTS EXPAND=FALSE

  VAR
    { This is an integer to allow use with sym$system_constant_manager
    { The true value range is dft$family_pointer_index
    dfv$number_served_family_lists: [XREF] integer;
?? PUSH (LISTEXT := ON) ??
*copyc dfs$server_wired
*copyc dft$served_family_table_index
?? POP ??
*DECK DECK=DFV$ONE_WORD_RESPONSE_HANDLER EXPAND=FALSE
  VAR
    dfv$one_word_response_handler: [XREF] dft$one_word_response_handler;

*copyc dft$one_word_response_handler
*DECK DECK=DFV$POLL_TYPE_STRING EXPAND=FALSE

  VAR
    dfv$poll_type_string: [XREF] array
          [dfc$normal_poll .. dfc$recovery_complete_reply] of string (24);

*copyc dft$poll_header

*DECK DECK=DFV$PROCEDURE_ADDRESS_LIST EXPAND=FALSE
  VAR
    dfv$procedure_address_list: [XREF]
          dft$rpc_procedure_address_list;

*copyc dft$rpc_procedure_address_list
*DECK DECK=DFV$PROCESS_MULTIWORD_RESPONSE EXPAND=FALSE
  VAR
    DFV$PROCESS_MULTIWORD_RESPONSE: [XREF] IOT$RESPONSE_PROCESSOR;
*copyc iot$io_request
*DECK DECK=DFV$P_CLIENT_MAINFRAME_FILE EXPAND=FALSE
  VAR
    dfv$p_client_mainframe_file: [XREF] ^dft$client_mainframe_file;
?? PUSH (LISTEXT := ON) ??
*copyc dft$client_mainframe_file
?? POP ??
*DECK DECK=DFV$P_CLONE_TASKS_STATUS EXPAND=FALSE
    VAR
      dfv$p_clone_tasks_status: [XREF] ^array [ * ] OF pmt$task_status;

*copyc pmt$task_status
*DECK DECK=DFV$P_ESM_DEFINITION_TABLE EXPAND=FALSE
{ DECK: DFV$P_ESM_DEFINITION_TABLE

  VAR
    dfv$p_esm_definition_table: [XREF, dfs$server_wired] ^dft$esm_definition_table_entry;

*copyc dfs$server_wired
*copyc dft$esm_definition_table
*DECK DECK=DFV$P_PROC_ADDRESSES EXPAND=FALSE

  VAR
    dfv$p_proc_addresses: [XREF] ^array [*] of dft$rpc_procedure_address;

?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_procedure_address_list
?? POP ??
*DECK DECK=DFV$P_QUEUE_INTERFACE_DIRECTORY EXPAND=FALSE
  VAR
    dfv$p_queue_interface_directory: [XREF] dft$p_queue_interface_directory;

*copyc dft$queue_interface_directory
*DECK DECK=DFV$P_QUEUE_INTERFACE_TABLE EXPAND=FALSE

  VAR
    { This variable is only of use  for the cdcnet or mock connections,
    {and for debugging with the esm connection.
    dfv$p_queue_interface_table: [XREF, dfs$server_wired] dft$p_queue_interface_table;
?? PUSH (LISTEXT := ON) ??
*copyc dfs$server_wired
*copyc dfd$driver_queue_types
?? POP ??
*DECK DECK=DFV$QUEUE_INITIALIZATION_LOCK EXPAND=FALSE

  VAR
    { This lock is to insure that two queues are not being initialized
    {simultaneously.
    dfv$queue_initialization_lock: [XREF, dfs$server_wired] ost$signature_lock;
?? PUSH (LISTEXT := ON) ??
*copyc dfs$server_wired
*copyc ost$signature_lock
?? POP ??
*DECK DECK=DFV$REBUILD_CLIENT_TASKS_STAT_P EXPAND=FALSE
  VAR
    dfv$rebuild_client_tasks_stat_p: [XREF] ^array [ * ] of
          dft$mainframe_task_status;

*copyc dft$mainframe_task_status

*DECK DECK=DFV$RECOVERY_TASK EXPAND=FALSE

 VAR
   dfv$recovery_task: [XREF] boolean;
*DECK DECK=DFV$RECOVER_ACTIVE_FAMILIES EXPAND=FALSE

  VAR
    dfv$recover_active_families: [XREF] boolean;
*DECK DECK=DFV$SEND_COMMAND_AND_DATA_FLAGS EXPAND=FALSE
  VAR
    dfv$send_command_and_data_flags: [XREF] dft$queue_entry_flags;

*copyc dfd$driver_queue_types

*DECK DECK=DFV$SEND_COMMAND_FLAGS EXPAND=FALSE

  VAR
    dfv$send_command_flags: [XREF] dft$queue_entry_flags;
*copyc dfd$driver_queue_types
*DECK DECK=DFV$SEND_READY_FOR_DATA_FLAGS EXPAND=FALSE
   VAR
    dfv$send_ready_for_data_flags: [XREF] dft$queue_entry_flags;
*copyc dfd$driver_queue_types
*DECK DECK=DFV$SERVED_FAMILY_TABLE_LOCK EXPAND=FALSE

  VAR
    dfv$served_family_table_lock: [XREF, dfs$server_wired] dft$read_write_lock;
?? PUSH (LISTEXT := ON) ??
*copyc dfs$server_wired
*copyc dft$read_write_lock
?? POP ??

*DECK DECK=DFV$SERVED_FAMILY_TABLE_ROOT EXPAND=FALSE
  VAR
    dfv$served_family_table_root: [XREF] dft$served_family_table_root;
?? PUSH (LISTEXT := ON) ??
*copyc dft$served_family_table
?? POP ??
*DECK DECK=DFV$SERVER_STATE_STRING EXPAND=FALSE
  VAR
    dfv$server_state_string: [XREF] array [dfc$active .. dfc$deleted] of
          string (17);
*copyc dft$server_state
*DECK DECK=DFV$SERVER_WIRED_HEAP EXPAND=FALSE

  VAR
    dfv$server_wired_heap: [XREF, dfs$server_wired] ^ost$heap;

?? PUSH (LISTEXT := ON) ??
*copyc dfs$server_wired
*copyc ost$heap
?? POP ??
*DECK DECK=DFV$TASK_QUEUE_TIMEOUT_INTERVAL EXPAND=FALSE

  VAR
    dfv$task_queue_timeout_interval: [XREF] integer;

*DECK DECK=DFV$TEST_RETRANSMISSION_COUNT EXPAND=FALSE

  VAR
    dfv$test_retransmission_count: [XREF]  0 .. 0ffff(16);
*DECK DECK=DFV$TEST_RETRANSMIT_RETRANSMIT EXPAND=FALSE

 VAR
   dfv$test_retransmit_retransmit: [XREF] 0 .. 0ff(16);
*DECK DECK=DFV$TRACE_COUNT EXPAND=FALSE
   VAR
    dfv$trace_count : [XREF] integer;
*DECK DECK=DFV$USE_SERVER_IO EXPAND=FALSE
  VAR
   { This variable allows testing of all of the permanent file requests
   { without the memory manager code.
   dfv$use_server_io: [XREF] boolean;
*DECK DECK=DMC$CTI_DEVICE_TYPE_NUMBERS EXPAND=FALSE

{ These constants define the device type numbers that CTI
{ uses to define the different device types.  These numbers
{ were taken from the document "CTI Support of NOS/VE Standalone
{ Deadstart" 85/9/5.  This document should be incorporated into
{ the "CTI Interface Specification" ARH2948.

  CONST
    dmc$844_single_density = 1,
    dmc$844_double_density = 2,
    dmc$885 = 3,
    dmc$fsc_3330_1 = 4,
    dmc$fsc_3330_2 = 5,
    dmc$fsc_3330_6 = 6,
    dmc$834_isd1 = 7,
    dmc$895 = 10(8),
    dmc$836_isd2 = 11(8),
    dmc$9836_s0 = 12(8),
    dmc$xmd3 = 13(8);
*DECK DECK=DMC$DEADSTART_FILE_ALLOC_SIZE EXPAND=FALSE

CONST
  dmc$deadstart_file_alloc_size = 16384;
*DECK DECK=DMC$DEFAULT_TRANSFER_SIZES EXPAND=FALSE
{
{ This deck contains the default transfer sizes to
{ be used per device to support STREAMING. The
{ definition used to obtain the values follows.
{ The default transfer size shall be a power of two
{ that defines enough bytes of data so that when
{ transferred at the cylinder transfer rate of the
{ device it will take about 5 milliseconds to transfer
{ the data. For the fastest disks, this interval is
{ reduced to four milliseconds.

CONST

  dmc$default_transfer_size_834 = 16384,
  dmc$default_transfer_size_836 = 16384,
  dmc$default_transfer_size_844 = 16384,
  dmc$default_transfer_size_885 = 16384,
  dmc$default_transfer_size_887 = 32768,
  dmc$default_transfer_size_895 = 16384,
  dmc$default_transfer_sz_5832_1 = 32768,
  dmc$default_transfer_sz_5832_2 = 32768,
{
{ Using the same one for the 5833_1 and 5833_1P, characteristics are the same
{
  dmc$default_transfer_sz_5833_1 = 16384,
  dmc$default_transfer_sz_5833_2 = 32768,
  dmc$default_transfer_sz_5833_3P = 32768,
  dmc$default_transfer_sz_5833_4 = 32768,
{
{ Using the same one for the 5838_1 and 5838_1P, characteristics are the same
{
  dmc$default_transfer_sz_5838_1 = 16384,
  dmc$default_transfer_sz_5838_2 = 32768,
  dmc$default_transfer_sz_5838_3P = 32768,
  dmc$default_transfer_sz_5838_4 = 32768,
{
{ Using the same one for the 47444_1 and 47444_1P, characteristics are the same
{
  dmc$default_transfr_sz_47444_1 = 16384,
  dmc$default_transfr_sz_47444_2 = 32768,
  dmc$default_transfr_sz_47444_3P = 32768,
  dmc$default_transfr_sz_47444_4 = 32768,

  dmc$default_transfer_size_9836 = 16384,
  dmc$default_transfer_size_9853 = 16384;


*DECK DECK=DMC$K_MULTIPLIER EXPAND=FALSE


  CONST
    dmc$K_multiplier = 1024;
*DECK DECK=DMC$MIN_ECC EXPAND=FALSE
*DECK DECK=DMD$NULL_GLOBAL_FILE_NAME EXPAND=FALSE

  VAR
    dmv$null_global_file_name: [STATIC, READ] ost$binary_unique_name := [0,
      osc$cyber_180_model_unknown, 1980, 1, 1, 0, 0, 0, 0, 0];

?? PUSH (LISTEXT := ON) ??
*copyc OSD$UNIQUE_NAME
?? POP ??
*DECK DECK=DME$TAPE_ERRORS EXPAND=FALSE
{dmdtem
{        tape errors and messages

*copyc dmt$error_condition_codes
*copyc rmc$condition_code_limits

{ DME$TAPE_ERRORS  :  ''RM'' 800 .. 899

?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := OFF) ??

     { dme$tape_errors }

  CONST
    dme$volume = rmc$min_ecc_resource_management + 800,
    {I mount tape +p on +p (mode = +p)}

    dme$switch_tape = rmc$min_ecc_resource_management + 801,
    {I new tape needed for vsn +p}

    dme$recovery_remount = rmc$min_ecc_resource_management + 802,
    {I Recovery remount of tape +p on +p (mode = +p)}

    dme$scratch = rmc$min_ecc_resource_management + 805,
    {I mount scratch tape on +p (mode = +p)}

    dme$ring = rmc$min_ecc_resource_management + 810,
    {I please put write ring in +p tape and ready unit}

    dme$ready = rmc$min_ecc_resource_management + 820,
    {I please ready +p}

    dme$configure = rmc$min_ecc_resource_management + 822,
    {I +p is not configured}

    dme$assign = rmc$min_ecc_resource_management + 824,
    {I +p is assigned}

    dme$reserve = rmc$min_ecc_resource_management + 826,
    {I +p is unavailable}

    dme$inoperable = rmc$min_ecc_resource_management + 828,
    {I +p is inoperable - please try another unit}

    dme$type = rmc$min_ecc_resource_management + 830,
    {I +p does not satisfy requirements}

    dme$no_vsn = rmc$min_ecc_resource_management + 832,
    {I +p external vsn unspecified}

    dme$vsn_online = rmc$min_ecc_resource_management + 836,
    {I +p already active}

    dme$assign_log = rmc$min_ecc_resource_management + 837,
    {I assign +p on +p}

    dme$unable_to_lock_tape_table   = rmc$min_ecc_resource_management + 840,
    {E Unable to obtain the lock for the +P1 tape table.

    dme$tape_unit_unassigned        = rmc$min_ecc_resource_management + 841,
    {E Tape unit +P1 is unassigned.}

    dme$no_vsn_selected             = rmc$min_ecc_resource_management + 842,
    {E +P1 no vsn selected in the RVL.}

    dme$improper_op_assign_state    = rmc$min_ecc_resource_management + 843,
    {E +P1 improper operator assignment in the RVL.}

    dme$improper_vsn_transition     = rmc$min_ecc_resource_management + 844,
    {E +P1 improper vsn transition in the RVL.}

    dme$tape_unit_undefined         = rmc$min_ecc_resource_management + 850,
    {E Tape unit +P1 is not defined.

    dme$termination_condition = rmc$min_ecc_resource_management + 851,
    {E terminate condition incurred}

    dme$active_tape_volume = rmc$min_ecc_resource_management + 852,
    {E Attempted to assign active tape volume.}

    dme$recorded_vsn_mismatch = rmc$min_ecc_resource_management + 854,
    {E Volume_id on the tape does not match the requested recorded_vsn.}

    dme$no_volume_mounted = rmc$min_ecc_resource_management + 855,
    {E Attempted to access a tape file that does not have a volume
    { currently mounted.}

    dme$tape_file_needs_job_rec = rmc$min_ecc_resource_management + 856,
    {E The tape file currently being accessed required job recovery
    { repositioning.}

    dme$unable_to_obtain_lun_lock = rmc$min_ecc_resource_management + 857,
    {E Unable to access tape unit for initialize_tape_volume, please
    { retry the operation at a later time.}

    dme$unit_type_not_configured = rmc$min_ecc_resource_management + 865,
    {E A tape unit that supports the requested density of +p is
    { not configured.}

    dme$unimp_tape_assignment = rmc$min_ecc_resource_management + 866,
    {E Unimplemented tape volume assignment - +p.}

    dme$invalid_tape_assignment = rmc$min_ecc_resource_management + 867,
    {E Invalid tape volume assignment - +p.}

    dme$density_not_supported = rmc$min_ecc_resource_management + 868,
    {E The requested tape density of +p is not supported.}

    dme$tape_not_assigned = rmc$min_ecc_resource_management + 870,
    {E No tape file is assigned on an attempt to +p.}

    dme$operator_reserve_stop = rmc$min_ecc_resource_management + 872,
    {E operator terminated tape reservation because +p.}

    dme$tape_unit_off = rmc$min_ecc_resource_management + 873,
    {E +p is unavailable (OFF)}

    dme$tape_unit_down = rmc$min_ecc_resource_management + 874,
    {E +p is unavailable (DOWN)}

    dme$tape_message_undefined = rmc$min_ecc_resource_management + 875,
    {E unknown tape internal message identifier }

    dme$request_reserve_mismatch = rmc$min_ecc_resource_management + 876,
    {E The requested tape density does not match the densities that
    { were explicitly reserved.}

    dme$request_exceeds_reserve = rmc$min_ecc_resource_management + 877,
    {E Tape usage exceeds tape reserve count.}

    dme$unit_assigned               = rmc$min_ecc_resource_management + 878,
    {E Element +P1 is assigned to job +P2.}

    dme$unit_reserved = rmc$min_ecc_resource_management + 879,
    {E +p is reserved to another job.}

    dme$array_size_mismatch = rmc$min_ecc_resource_management + 880,
    {W The TUSL has +P1 entries, while the input array can hold +P2 values.}

    dme$operator_stop = rmc$min_ecc_resource_management + 881,
    {E operator terminated tape assignment because +p.}

    dme$operator_reassign = rmc$min_ecc_resource_management + 882,
    {E operator reassign}

    dme$improper_integer = rmc$min_ecc_resource_management + 883,
    {E "+P" is not a properly formed integer}

    dme$invalid_menu_response = rmc$min_ecc_resource_management + 884,
    {E invalid response received from dmp$operator_action_menu}

    dme$mt7_class_not_supported = rmc$min_ecc_resource_management + 885,
    {E The requested tape class of RMC$MT7 is not supported.}

    dme$no_menu_choices_specified = rmc$min_ecc_resource_management + 886,
    {E no menu choices specified for dmp$operator_action_menu}

    dme$unable_to_log_reservation = rmc$min_ecc_resource_management + 887,
    {E unable_to_log_reservation in dmp$log_tape_reservation}

    dme$unable_to_log_release = rmc$min_ecc_resource_management + 888,
    {E unable to log release in dmp$log_tape_release}

    dme$not_enough_in_on_state = rmc$min_ecc_resource_management + 889,
    {E not enough tape units available in ON state}

    dme$tape_attach_limit_exceeded = rmc$min_ecc_resource_management + 890,
    {E Tape file attachment limit exceeded.}

    dme$multiple_reserve = rmc$min_ecc_resource_management + 891,
    {E Multiple reserve attempted.}

    dme$reserve_not_effected = rmc$min_ecc_resource_management + 892,
    {E reserve currently not effected}

    dme$tape_configuration_exceeded = rmc$min_ecc_resource_management + 893,
    {E Reserve request exceeds configured tape units.}

    dme$release_exceeds_reserve = rmc$min_ecc_resource_management + 894,
    {E Release request exceeds reserved tape units.}

    dme$release_active_tape = rmc$min_ecc_resource_management + 895,
    {E Attempted to release active tape.}

    dme$invalid_request_density = rmc$min_ecc_resource_management + 896,
    {E The requested tape density is not supported.}

    dme$invalid_resrel_count = rmc$min_ecc_resource_management + 897,
    {E invalid reserve or release count}

    dme$volume_list_exhausted = rmc$min_ecc_resource_management + 898,
    {E Tape volume request list exhausted.}

    dme$io_status_request_error = rmc$min_ecc_resource_management + 899;
    {E cannot acquire tape io status}

*DECK DECK=DMH$ADMINISTER_ALLOCATION_LOG EXPAND=FALSE
{}
{   This procedure is the primary entry point for the task,
{ "dmp$administer_allocation_log".
{}
{       DMP$ADMINISTER_ALLOCATION_LOG
{}
{ (no parameters)
{}
*DECK DECK=DMH$ADMINISTER_DEVICE_LOG EXPAND=FALSE
{}
{   This procedure is the primary entry point for the task,
{ "dmp$administer_device_log".
{}
{       DMP$ADMINISTER_DEVICE_LOG
{}
{ (no parameters)
{}
*DECK DECK=DMH$ALLOCATE_FILE_SPACE EXPAND=FALSE
{
{    This request will allocate space from a volume.  The volume from which
{  to allocate space is a parameter to the request.  The number of allocation
{  units to allocate and the requested allocation style are parameters to
{  the request.  As much space as can be obtained will be allocated from the
{  volume.  The actual number of allocation units obtained is returned as a
{  parameter.
{
{        DMP$ALLOCATE_FILE_SPACE (ALLOCATE_REQUEST_BLOCK)
{
{  ALLOCATE_REQUEST_BLOCK : (input/output)  This parameter specifies an allocate
{       request block.
{
*DECK DECK=DMH$ALLOCATE_FILE_SPACE_R1 EXPAND=FALSE
{}
{   This request will perform the file setup (volume assignment,
{ fmd creation, fat creation) necessary for file space to be allocated to a
{ file.  The actual allocation of the file space will be done in monitor mode.
{ The file descriptor for the file must have been created prior to issuing this
{ request.
{}
{       DMP$ALLOCATE_FILE_SPACE_R1 (SYSTEM_FILE_ID, BYTE_ADDRESS,
{         NUMBER_BYTES_TO_ALLOCATE, CHAPTER_NUMBER, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This parameter specifies the system file
{       identification of the file.
{}
{ BYTE_ADDRESS: (input) This parameter specifies the file address at which
{       allocation is to start.
{}
{ NUMBER_BYTES_TO_ALLOCATE: (input) This parameter specifies the amount of file
{       space to allocate.
{}
{ CHAPTER_NUMBER: (input) This parameter specifies the chapter in which to
{       allocate space.
{}
{ STATUS: (output) This parameter returns the request status.
{}
*DECK DECK=DMH$ATTACH_FILE EXPAND=FALSE
{ PURPOSE:
{       The purpose of this request is to create or locate the mainframe
{   file tables for a particular file.  If the mainframe file tables for the
{   file already exist, a usage count for the file will be incremented
{   and the system file id for the file will be returned.  If the file
{   tables do not exist, they will be built using the information
{   supplied with the attach request, the usage count will be incremented
{   and the system file id for the file will be returned.
{
{ NOTES:
{   Permanent_file recovery uses the RESTRICTED_ATTACH, EXIT_ON_UNKNOWN_FILE
{   and EXISTING_SFT_ENTRY parameters to prevent an overflowed file from
{   being attached with an incorrect stored_fmd and to insure the integrity
{   of files attached before the point_of_commitment.
{     If the PF catalog indicates a file is attached in write mode and no
{   entry for the file is found in the system_file_table there is a possibility
{   the file has overflowed and the PF catalog was not updated. In this
{   situation dmp$attach_file should exit before attaching the file with
{   a possibly incorect stored_fmd. Permanent_files will recognize this
{   condition, reconcile the fmd, and call dmp$attach_file with the updated
{   stored_fmd.
{     When a file is being attached before the point_of_commitment the PF
{   catalog cannot be modified. For all files attached before the point
{   of commitment a field in the fmd_header will be set to force PF to
{   update the stored_fmd in the catalog since there is no way to
{   determine if the file has overflowed.
{
{          DMP$ATTACH_FILE (GLOBAL_FILE_NAME, FILE_TYPE, STORED_FMD,
{                FILE_USAGE, FILE_SHARE_SELECTIONS, FILE_HISTORY, FILE_LIMIT,
{                LOCKED_FILE, RESTRICTED_ATTACH, EXIT_ON_UNKNOWN_FILE,
{                SERVER_FILE, SYSTEM_FILE_ID, EXISTING_SFT_ENTRY, STATUS);
{
{  GLOBAL_FILE_NAME:(input)  This parameter specifies the name of the file.
{
{  FILE_TYPE:(input)  This parameter specifies the type of file being
{                     attached.
{
{  STORED_FMD:(input)  This parameter specifies the stored mass
{                 storage file medium descriptor for the file.
{
{  FILE_USAGE:(input)  This parameter specifies how the file will be used.
{
{  FILE_SHARE_SELECTIONS:(input)  This parameter specifies the manner
{                                 in which other jobs may concurrently
{                                 access the file.
{
{  FILE_HISTORY:(input)  This parameter specifies a count of the previous
{                        usage of the file.
{  FILE_LIMIT:(input)  This parameter specifies the maximum length of the file.
{
{  LOCKED_FILE:(input)  This parameter specifies whether the file is to be
{                       attached in lock mode.
{
{  RESTRICTED_ATTACH: (input) This parameter specifies whether the file is
{       being attached prior to the point of commitment.
{
{  EXIT_ON_UNKNOWN_FILE: (input) This parameter specifies whether the file
{       should be attached if it it determined that the file is not currently
{       attached. For most situations this should be set to FALSE. During PF
{       recovery if PF expects the file to be attached it will set this
{       parameter to TRUE to prevent the file from being attached incorrectly.
{
{  SERVER_FILE: (input)  This parameter indicates that the file being attached
{       is on the server mainframe.
{
{  SYSTEM_FILE_ID:(output)  This parameter returns the system identification
{                           for the file.
{
{  EXISTING_SFT_ENTRY: (output)  This parameter returns an ordinal value
{          indicating the presence of an existing entry in the system file
{          table and the type of entry if one exists.)
{
{  STATUS:(output)  This parameter returns the request status.
{
*DECK DECK=DMH$BUILD_DEVICE_ADDRESS EXPAND=FALSE
{
{    The purpose of this request is to translate a file byte address into a
{  logical device address.
{
{       DMP$BUILD_DEVICE_ADDRESS (P_FDE, P_DFD, P_FMD, P_FAU, BYTE_ADDRESS,
{                                NUMBER_BYTES, DEVICE_ADDRESS, STATUS)
{
{ P_FDE:(input)  This parameter specifies a pointer to the file descriptor
{      entry for the file.
{
{ P_DFD:(input)  This parameter specifies a pointer to the disk file
{      descriptor entry for the file.
{
{ P_FMD:(input)  This parameter specifies a pointer to the file medium
{      descriptor entry for the file.
{
{ P_FAU:(input)  This parameter specifies a pointer to a file allocation
{      unit for the file.
{
{ BYTE_ADDRESS:(input)  This parameter specifies the byte address to be
{      translated.
{
{ NUMBER_BYTES:(input)  This parameter specifies the number of bytes
{      associated with this io transfer.
{
{ DEVICE_ADDRESS:(output)  This parameter returns the logical device address
{      associated with the file byte address.
{
{ STATUS:(output)  This parameter returns the request status.
{
*DECK DECK=DMH$CLOSE_FILE EXPAND=FALSE
{
{  The purpose of this request is to close a segment access file in use by device management.
{ The segment associated with the file (pva) is removed from the address space of the caller.
{ The backing store for the file is left intact.
{
{  dmp$close_file (pva, status)
{
{  pva: (input) This parameter specifies the pva associated with the file to be closed.
{
{  status: (output) This parameter returns the result of the request.
{
*DECK DECK=DMH$CLOSE_SEGMENT_ACCESS_FILE EXPAND=FALSE
*DECK DECK=DMH$CREATE_CLIENT_SFT EXPAND=FALSE
{
{    The purpose of this procedure is to create a system file table entry for a
{ file residing on the file server.  All file descriptor entry fields will be
{ initialized to values supplied from the file server.  No file medium
{ descriptor will be created, but a server descriptor will be created and
{ pointed to from the file descriptor entry.  The file type of the file will be
{ set to dmc$server_file.  The file descriptor entry may be completed if the
{ initial file descriptor entry was created by job recovery.
{
{       DMP$CREATE_CLIENT_SFT (GLOBAL_FILE_NAME, FILE_USAGE, SHARE_SELECTIONS,
{             OPERATION, DM_PARAMETERS, SERVED_FAMILY_TABLE_INDEX,
{             SERVER_MAINFRAME_ID, SYSTEM_FILE_ID, STATUS)
{
{   GLOBAL_FILE_NAME: (input)  This parameter specifies the global file name of
{         the file.
{
{   FILE_USAGE: (input)  This parameter specifies how this instance of attach
{         is using the file.
{
{   SHARE_SELECTIONS: (input)  This parameter specifies how this instance of
{         attach is sharing the file.
{
{   OPERATION: (input)  This parameter specifies what file operation is being
{         performed.
{         - dmc$begin_job_recovery - An initial system file id is
{           assigned and some of the file descriptor entry fields are completed.
{           The server descriptor file state is set to dfc$awaiting_recovery No
{           access is allowed to a file in this state.
{         - dmc$complete_job_recovery - The file descriptor entry is completly
{           rebuilt.  The server descriptor file state is advanced to dfc$active
{           and the file is now available for access.
{         - dmc$attach_or_create - The file is being attached.
{           The server descriptor file state is set to dfc$active.
{
{   DM_PARAMETERS: (input)  This parameter specifies the device management
{         information obtained from the server system file table.
{
{   SERVED_FAMILY_TABLE_INDEX:(input) This parameter specifies the index that
{         may be used to determine the file location.  This is built into the
{         server descriptor.
{
{   SERVER_MAINFRAME_ID:(input) This parameter specifies the binary mainframe
{          of the server mainframe.  This is built into the server descriptor.
{
{   SYSTEM_FILE_ID: (output)  This parameter returns the system file
{          identifier on the file on this the client mainframe.
{
{   STATUS : (output)  This parameter returns the request status.
{
*DECK DECK=DMH$CREATE_FILE_ENTRY EXPAND=FALSE
{
{    The purpose of this request is to create the file descriptors for a
{  particular file.  The file descriptors allow file operations to be performed
{  on the file.
{
{        DMP$CREATE_FILE_ENTRY(FILE_TYPE,FILE_USAGE,FILE_SHARE_SELECTIONS,
{                        FILE_SHARE_HISTORY,
{                        P_FILE_ATTRIBUTES,BYTE_ADDRESS,ASSIGN_VOLUME,
{                        GLOBAL_FILE_NAME,SYSTEM_FILE_ID,STATUS)
{
{  FILE_TYPE:(input)  This parameter specifies the type of file to be created.
{
{  FILE_USAGE:(input)  This parameter specifies how the file is to be used.
{
{  FILE_SHARE_SELECTIONS:(input)  This parameter specifies the manner in which
{                                 the file may be concurrently accessed by other
{                                 jobs.
{
{  FILE_SHARE_HISTORY:(input)  This parameter specifies a count of the
{                              number of times the file has been shared.
{                              This count is used in determining whether
{                              the file is to be global or local to the
{                              job.
{
{  P_FILE_ATTRIBUTES:(input)  This parameter specifies the attributes to be
{                             associated with the file.
{
{  BYTE_ADDRESS:(input)  This parameter causes file space preallocation to be
{                        performed up to and including this logical file address
{                        (byte_address).  A non-zero value will cause
{                        file space to be allocated.
{
{  ASSIGN_VOLUME:(input)  This parameter specifies whether a volume is to be
{                         assigned to the file.
{
{  GLOBAL_FILE_NAME:(output)  This parameter returns the system generated global
{                             file name associated with the file.
{
{  SYSTEM_FILE_ID:(output)  This parameter returns system file identification
{                           information that is used to reference the file.
{
{  STATUS:(output)  This parameter returns the request status.
{
*DECK DECK=DMH$CREATE_FILE_MEDIUM_DESCRIPT EXPAND=FALSE
*DECK DECK=DMH$CREATE_MF_ALLOCATION_TABLE EXPAND=FALSE
*DECK DECK=DMH$DEALLOCATE_FILE_SPACE EXPAND=FALSE
{}
{   The purpose of this request is to release allocated space from a file.
{}
{       DMP$DEALLOCATE_FILE_SPACE (DEALLOCATE_REQUEST_BLOCK)
{}
{  DEALLOCATE_REQUEST_BLOCK: (input/output) This parameter specifies a
{       deallocate request block.
{}
*DECK DECK=DMH$DELETE_FILE_DESCRIPTOR EXPAND=FALSE
{}
{   The purpose of this request is to deactivate a file in device management.
{ A file is deactivated only if it is not currently attached by another job.
{}
{       DMP$DELETE_FILE_DESCRIPTOR (SYSTEM_FILE_ID, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This is the principal file identifier used by
{       device management.
{}
{ STATUS: (output) This parameter indicates the status of the request.
{}
*DECK DECK=DMH$DESTROY_FILE EXPAND=FALSE
{
{    The purpose of this request is to destroy a file.  All table entries
{  associated with a file are purged.  Any mass storage space assigned to the
{  file is freed.
{
{       DMP$DESTROY_FILE(SYSTEM_FILE_ID,STATUS)
{
{  SYSTEM_FILE_ID:(input)  This parameter specifies the system identification
{                          of the file to be destroyed.
{
{  STATUS:(output)  This parameter returns the request status.
{
*DECK DECK=DMH$DESTROY_PERMANENT_FILE EXPAND=FALSE
{}
{   The purpose of this request is to destroy a permanent file, keyed by the
{ global file name and the stored file medium descriptor.
{}
{       DMP$DESTROY_PERMANENT_FILE (GLOBAL_FILE_NAME, STORED_FMD, STATUS)
{}
{ GLOBAL_FILE_NAME: (input) This is the unique internal name associated with
{       a file.
{}
{ STORED_FMD: (input) This parameter contains to the file medium
{       descriptor which is stored in the catalog associated with
{       the relevant permanent file.
{}
{ STATUS: (output) This parameter specifies the status of the request.
{}
*DECK DECK=DMH$DETACH_FILE EXPAND=FALSE
{}
{   The purpose of this request is to detach a file from a job.
{}
{       DMP$DETACH_FILE ( SYSTEM_FILE_ID, FILE_MODIFIED, FMD_MODIFIED, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This parameter is the principal file identifier
{       employed in device management requests.
{
{ FLUSH_PAGES: (input) Specifies whether or not to tell MM to flush pages.
{}
{ FILE_MODIFIED: (output) This parameter indicates whether or not a file has
{     been modified.
{}
{ FMD_MODIFIED: (output) This parameter indicates whether or not the
{       file medium descriptor has been altered.
{}
{ STATUS: (output) This parameter indicates the status of the request.
{}
*DECK DECK=DMH$DETACH_SERVER_FILE EXPAND=FALSE
{
{   The purpose of this request os to remove trace of the server file on the
{ client mainframe.  This involves initiating requests to flush pages, and
{ if this is the last usage, to delete the segment associated with the file
{ and to delete the entry from the file descriptor table (system file table).
{ This procedure contains components of dmp$detach_file (DMM$DETACH_FILE) and
{ dmp$delete_file_descriptor, and dmp$destroy_file (DMM$FILE_TABLE_MANAGER).
{
{   DMP$DETACH_SERVER_FILE (SYSTEM_FILE_ID, FLUSH_PAGES, UNCONDITIONAL_DETACH,
{      ATTACHED_FOR_WRITE, EOI_BYTE_ADDRESS, REMOTE_SFID,
{      STATUS)
{
{   SYSTEM_FILE_ID: (input) This parameter specifies the file to delete.
{      The file must be of file type dmc$server_file.
{
{   FLUSH_PAGES: (input) This parameter specifies whether pages for the file
{      should be written. If the file is attached for access_mode = none then
{      this parameter should be specifified as false.
{
{   UNCONDITIONAL_DETACH: (input) This parameter specifies whether the file
{      should be detached regardless of the state of the file as shown in the
{      server_descriptor.  This parameter is false during every call EXCEPT
{      during File Server Job Recovery.
{
{   ATTACHED_FOR_WRITE: (output) This parameter returns whether the file was
{      was attached for write mode by any job.
{
{   EOI_BYTE_ADDRESS: (output) This parameter returns  the eoi for the file.
{
{   REMOTE_SFID: (output) This parameter returns sfid of the file on the server
{      mainframe.
{
{   STATUS: (output) This parameter returns the request status.
{
*DECK DECK=DMH$DF_CLIENT_ALLOCATE_SPACE_R1 EXPAND=FALSE
{}
{   This request will perform the setup necessary for file space to be allocated on the server for a
{ client file.  The actual allocation of the file space will be done in monitor mode on the server.
{ The file descriptor for the file must have been created prior to issuing this request.
{}
{       DMP$DF_CLIENT_ALLOCATE_SPACE_R1 (FDE_P, SYSTEM_FILE_ID, STATUS)
{}
{ FDE_P: (input) This parameter specifies the pointer to the system file descriptor
{       entry of the file.
{}
{ SYSTEM_FILE_ID: (input) This parameter specifies the system file
{       identification of the file.
{}
{ STATUS: (output) This parameter returns the request status.
{}
*DECK DECK=DMH$FETCH_ASID EXPAND=FALSE
*DECK DECK=DMH$FETCH_CHAPTER_INFO EXPAND=FALSE
*DECK DECK=DMH$FETCH_SEGMENT_FILE_INFO EXPAND=FALSE
{}
{   This request provides an interface through which other areas of the system
{ can access certain information which is maintained in device management
{ tables.
{}
{       DMP$FETCH_SEGMENT_FILE_INFO (SYSTEM_FILE_ID, INFO, STATUS)
{}
{ SYSTEM_FILE_ID: This parameter is device management's principal identifier
{       of a file.
{}
{ INFO: This parameter is a record
{   ASID: This specifies the asid as found in the fde.
{   END_OF_CHAPTER: This is the byte address of the end of chapter.
{   PRESET_VALUE: This is the word with which a file is initialized.
{   CLEAR_SPACE: This field indicates whether freed space is to be cleared.
{   CHAPTER_LIMIT: This is the maximum allowable length of the chapter.
{   SEGMENT_QUEUE_STATUS: This defines which queue the file is assigned to.
{}
{ STATUS: This parameter indicates the status of the request.
{}
*DECK DECK=DMH$FETCH_SEGMENT_LIMIT EXPAND=FALSE
*DECK DECK=DMH$FETCH_SERVER_SFT_INFO EXPAND=TRUE
{     The purpose of this procedure is to obtain all the information
{ that is required on the client side of the file serverabout a served file.  This info
{ is obtained from the system file table, file medium descriptor, and
{ file allocation table for an attached file.  This information
{ will be sent to the client mainframe and will be used to construct a
{ system file table entry on the client mainframe.  All information returned
{ is in the format most readily usable to the file server processes.
{
{    DMP$FETCH_SERVER_SFT_INFO (SYSTEM_FILE_ID, INFO, P_SEND_BUFFER,
{           STATUS)
{
{   SYSTEM_FILE_ID: (input) This parameter specifies the system file identifier
{       of the attached file for which information is to obtained for.
{
{   INFO: (output) This parameter returns the information required about the
{       file.
{
{    P_SEND_BUFFER : (input) This parameter specifies a sequence in which the
{       subfile descriptors may be NEXTed into.  This sequence should NOT be
{       reset prior to the nexting.
{
{    STATUS: (output) This parameter returns the request status.
{
*DECK DECK=DMH$FETCH_TAPE_UNIT_COUNT EXPAND=FALSE
{
{   The purpose of this request is to return the number of
{ tape units on the system.
{
{       DMP$FETCH_TAPE_UNIT_COUNT (TAPE_UNIT_COUNT, STATUS)
{
{ TAPE_UNIT_COUNT: (output)  This parameter specifies the
{       number of tape units on the system.
{
{ STATUS: (output) This parameter specifies the request status.
*DECK DECK=DMH$FETCH_TAPE_UNIT_STATUS_INFO EXPAND=FALSE
{
{   The purpose of this request is to return the tape unit
{ status for each of the tape units present.  If the array
{ is not large enough, only information about the unit that
{ can fit in the array will be returned.  Use the
{ dmp$fetch_tape_unit_count interface to get the number of
{ tape units configured.
{
{       DMP$FETCH_TAPE_UNIT_STATUS_INFO
{         (TAPE_UNIT_STATUS_INFO, STATUS)
{
{ TAPE_UNIT_STATUS_INFO: (output)  This parameter specifies
{       the array to place the tape unit status information.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=DMH$FREE_SERVER_FILE_TABLES EXPAND=FALSE
{   The purpose of this procedure is to finish removing  traces of the server file on
{ the client mainframe.  Most of the work has already been done by dmp$detach_server_file.
{ However, the fde open count was not zero at that time so the fde could not be freed.
{ (There were instances of open for this segment that BAM did not known about - i.e.
{ LOADER files.)  Task termination is now in progress and the open count has gone to zero.
{ This procedure is only called by mmp$invalidate_segment.
{
{   DMP$FREE_SERVER_FILE_TABLES (SYSTEM_FILE_ID, STATUS);
{
{   SYSTEM_FILE_ID: (input) This parameter specifies the file to delete.
{
{   STATUS: (output) This parameter returns the request status.
{
*DECK DECK=DMH$GENERATE_UNIQUE_BINARY_NAM2 EXPAND=FALSE
*DECK DECK=DMH$GENERATE_UNIQUE_BINARY_NAME EXPAND=FALSE
*DECK DECK=DMH$GET_ACTIVE_VOL_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to retrieve information about a volume
{  in the active volume table.
{
{       DMP$GET_ACTIVE_VOL_ATTRIBUTES(REQUIRED_EXTERNAL_VSN,SEARCH_AVT_INDEX,
{                                    P_ASSIGNED_VOL_ATTRIBUTES,AVT_ENTRY_FOUND)
{
{  REQUIRED_EXTERNAL_VSN:(input)  This parameter specifies the external vsn
{                                 of the volume.
{
{  SEARCH_AVT_INDEX:(input)  This parameter specifies the active volume table
{                            index of the volume.
{
{  P_ASSIGNED_VOL_ATTRIBUTES:(input/output):  This parameter specifies the
{                                             volume attributes to be returned.
{                                             The attributes will be returned
{                                               in this parameter.
{
{  AVT_ENTRY_FOUND:(output)  This parameter specifies whether or not the volume
{                            was found in the active volume table.
{
*DECK DECK=DMH$GET_AVT_LOGGING_INFO EXPAND=FALSE
{
{    The purpose of this procedure is to provide information relative to the logging process
{   which can be obtained from the active volume table.
{
{     dmp$get_avt_logging_info (avt_index, info, valid_entry)
{
{ avt_index: (input) This parameter specifies the AVT entry for which information is requested.
{
{ info: (output) This parameter specifies the result of the request if the requested entry
{                was valid.
{
{ valid_entry: (output) This parameter specifies whether or not the requested entry was found.
{
*DECK DECK=DMH$GET_FDT_ROOT_POINTER EXPAND=FALSE
*DECK DECK=DMH$GET_FILE_ALLOCATION_TABLE EXPAND=FALSE
*DECK DECK=DMH$GET_FILE_DESCRIPTOR_ENTRY EXPAND=FALSE
*DECK DECK=DMH$GET_FILE_INFO EXPAND=FALSE
{}
{   The purpose of this request is to provide certain data which typically
{ reside in device management tables.
{}
{       DMP$GET_FILE_INFO (SYSTEM_FILE_ID, INFO, STATUS)
{}
{ SYSTEM_FILE_ID (input) This is the principal file identifier used by
{       device management.
{}
{ INFO (output) This parameter is a record.
{   EOI_BYTE_ADDRESS: This is the byte address of "end of information."
{   CLEAR SPACE: This field indicates whether freed space will be initialized
{       prior to use by another file.
{   DEVICE_CLASS: This field indicates the class of the device on
{       which the specified file resides.
{   END_OF_FILE: This is the byte address of "end of file."
{   FILE_LIMIT: This field indicates the upper limit of "end of file."
{}
{ STATUS: (output) This parameter indicates the status of the request.
{}
*DECK DECK=DMH$GET_INITIALIZED_ADDRESSES EXPAND=FALSE
{
{   The purpose of this procedure is to return a list containing the address
{   and length of each allocation_unit that has the dmc$fau_initialized flag
{   set.
{
{   DMP$GET_INITIALIZED_ADDRESSES (SFID, STARTING_BYTE_ADDRESS, ADDR_LIST,
{         NUMBER_OF_ADDRESSES,LIST_OVERFLOW,STATUS);
{
{   SFID (input): The system_file_identifier of the file for which a list
{         of all initialized allocation_units is required
{
{   STARTING_BYTE_ADDRESS (input): The offset within the file segment
{         from where the procedure is to start searching for initialized
{         allocation_units. Initially set to 0, thereafter updated by the
{         caller with the last entry of the array (addr+length) that was
{         returned with the previous call
{
{   ADDR_LIST (output): The array in which the address and length pairs
{         for each initialized allocation_unit are returned. If there are
{         more pairs than the size of the array allows, set the
{         list_overflow flag. If there are not enough to fill the array,
{         fill it with zeroes.
{
{   NUMBER_OF_ADDRESSES (output): The number of valid addresses that are
{         returned in the array.
{
{   LIST_OVERFLOW (output): A flag that indicates that this procedure
{         must be called again to obtain the rest of the initialized
{         allocation_units
{
{   STATUS (output): The result of this procedure: normal or not
{
{   NOTE:
{   Only initialized allocation_units are added to addr_list, because
{   allocation_units with flags: initialized_and_flawed or
{   initialization_in_prog are still in memory and would have been
{   detected by the request to Memory Manager before callin this
{   procedure.
{
*DECK DECK=DMH$GET_OUT_OF_SPACE_SETS EXPAND=FALSE
{
{   This request returns a list of mass storage Sets, indicating the classes
{ for each that are out of space.  Some classes are not constrained to a
{ particular Set (class "N" and "Q") while all others are.  A separate entry
{ with a Set name of osc$null_name is placed in the list to reflect the classes
{ that are not constrained to a particular Set.  If no classes are out of space
{ for a particular Set, the class field will be empty.
{
{      DMP$GET_OUT_OF_SPACE_SETS (OUT_OF_SPACE_SETS, SET_COUNT)
{
{ OUT_OF_SPACE_SETS:  (output) This parameter is an adaptable array which
{      returns a list of records giving the name of a mass storage Set and what
{      classes are out of space for that Set.  If the system has more Sets than
{      will fit in the array, information will be returned only for the number
{      that will fit.  Because of the special Set with osc$null_name, the
{      maximum number of Sets possible is one more than the maximum number of
{      volumes in the active volume table.
{
{ SET_COUNT: (output)  This parameter returns the actual number of Sets for
{      which information has been returned.
{
*DECK DECK=DMH$GET_STORED_FMD EXPAND=FALSE
{}
{   The purpose of this request is to construct a "stored" file medium
{ descriptor.
{}
{       DMP$GET_STORED_FMD (SYSTEM_FILE_ID, STORED_FMD, STATUS)
{}
{ SYSTEM_FILE_ID (input) This parameter is the principal file identifier
{       used in device management requests.
{}
{ STORED_FMD (input/output) This parameter is a cybil "sequence" in which
{       the stored fmd is constructed.
{}
{ STATUS: (output) This parameter indicates the status of the request.
{}
*DECK DECK=DMH$GET_STORED_FMD_SIZE EXPAND=FALSE
{}
{   The purpose of this request is to calculate the size of sequence
{ required to hold a stored fmd.
{}
{       DMP$GET_STORED_FMD_SIZE (SYSTEM_FILE_ID, SIZE_OF_STORED_FMD, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This parameter is the principal file identifier
{       used by device management.
{}
{ SIZE_OF_STORED_FMD: (output) This parameter indicates what size sequence
{       (in cells) should be allocated to contain the stored fmd for the file
{       referenced by the first parameter.
{}
{ STATUS: (output) This parameter indicates the status of the request.
{}
*DECK DECK=DMH$GET_SUBFILE_INDEX EXPAND=FALSE
*DECK DECK=DMH$GET_UNUSED_AVT_ENTRY EXPAND=FALSE
{
{   This request will attempt to locate and reserve an available active
{ volume table entry.  If an entry is reserved, it will be initialized
{ to a default entry value.  The result of the request is returned to
{ the caller.
{
{      DMP$GET_UNUSED_AVT_ENTRY (AVT_INDEX,ABLE_TO_GET_AVT_ENTRY)
{
{ AVT_INDEX: (input/output)  If this parameter is non-zero, the first
{      active volume table entry to be checked will be this entry.
{      If this entry does not satisfy the requirements, the entire active
{      volume tabel will be checked.  If this parameter is zero, the
{      entire active volume table will be checked.  If an active volume table
{      entry is found that satisfies the requirements, the index of the
{      entry will be returned in this parameter.
{
{ ABLE_TO_GET_AVT_ENTRY: (output)  This parameter returns the result of the
{      request.
{
*DECK DECK=DMH$INITIALIZE_MS_VOLUME EXPAND=FALSE
{
{    The purpose of this request is to initialize a mass storage volume
{  for subsequent use by NOSVE.  The initialization consists of the
{  creation of a volume label and the creation of volume tables used in
{  creating and accessing files on the volume.
{
{           DMP$INITIALIZE_MS_VOLUME(ACCESS_CODE,OWNER_ID,UNIT_TYPE,
{                                    P_PHYSICAL_ATTRIBUTES,
{                                    P_LOGICAL_ATTRIBUTES,
{                                    P_VOLUME_LABEL_ATTRIBUTES,
{                                    LOGICAL_UNIT_SPECIFICATION,
{                                    ALLOWED_TO_OVERWRITE_VOLUME,
{                                    STATUS)
{
{  ACCESS_CODE:(input)  This parameter specifies the access code required
{                       to initialize the volume.
{
{  OWNER_ID:(input)  This parameter specifies the volume owner id
{                    required in order to initialize the volume.
{
{  UNIT_TYPE:(input)  This parameter identifies the unit type.
{
{
{  P_PHYSICAL_ATTRIBUTES:(input)  This parameter specifies the physical
{                                 characteristics of the volume.
{
{  P_LOGICAL_ATTRIBUTES:(input)  This parameter specifies the logical
{                                characteristics to be associated with
{                                the volume.
{
{  P_VOLUME_LABLE_ATTRIBUTES:(input)  This parameter specifies the label
{                                    attributes that will be recorded in
{                                    the volume label.
{
{  LOGICAL_UNIT_NUMBER;(input)  This parameter specifies the
{                                      logical unit number of the volume
{                                      to be initialized.
{
{  ALLOWED_TO_OVERWRITE_VOLUME:(input)  This parameter specifies whether the
{                                       volume label can be overwritten if
{                                       any error occurs when validating an
{                                       existing label.
{
{  RETAIN_DEVICE_FLAWS:(input)  This parameter specifies whether or not to attempt to read
{                               the DAT from the device prior to initializing it in order to
{                               apply previously encountered flaws to the device's new DAT.
{                               This parameter also is involved in making the decision on
{                               whether or not to soft-sector an 895 device.
{
{  STATUS:(output)  This parameter returns the request status.
{
*DECK DECK=DMH$LOCATE_EXISTING_SFT_ENTRY EXPAND=FALSE
{
{ PURPOSE:
{   The purpose of this procedure is to search the system_file_table
{   for the global_file_name and return a value indicating the
{   presence of an existing system_file_table entry.
{
{       DMP$LOCATE_EXISTING_SFT_ENTRY (GLOBAL_FILE_NAME, FILE_KIND,
{             EXISTING_SFT_ENTRY, STATUS)
{
{   GLOBAL_FILE_NAME: (input) This parameter specifies the global_file_name
{         to locate in the system_file_table.
{
{   FILE_KIND: (input) This parameter specifies the kind of file.
{
{   EXISTING_SFT_ENTRY: (output) This parameter returns an ordinal value
{         indicating the presence of an entry in the system_file_table
{         for the file.
{
{   STATUS: (output) This parameter returns the request status.
{
*DECK DECK=DMH$LOCK_AVT_ENTRY EXPAND=FALSE
{
{   This request will attempt to lock a specified active volume table
{ entry.  The result of the lock attempt is returned.
{
{      DMP$LOCK_AVT_ENTRY (AVT_INDEX, ABLE_TO_LOCK_ENTRY)
{
{ AVT_INDEX: (input) This parameter specifies the active volume table
{      entry to lock.
{
{ ABLE_TO_LOCK_ENTRY: (output)  This parameter is used to return the
{      result of the lock attempt.
{
*DECK DECK=DMH$LOCK_FILE EXPAND=FALSE
*DECK DECK=DMH$MFH_FOR_SFID EXPAND=FALSE
*DECK DECK=DMH$MM_LOG_SFT_DELETE EXPAND=FALSE
{   The purpose of this procedure is to finish deactivating a file in device
{ management.  This is essentially the same as dmp$delete_file_descriptor except
{ for decrementing the dfd delete count.  Dmp$delete_file_descriptor was called, but
{ the fde open count was not zero at that time so the fde could not be freed.
{ (There were instances of open for this segment that BAM did not known about - i.e.
{ LOADER files.)  Task termination is now in progress and the open count has gone to
{ zero.  This procedure is only called by mmp$invalidate_segment.
{
{   DMP$MM_LOG_SFT_DELETE (SYSTEM_FILE_ID, STATUS);
{
{   SYSTEM_FILE_ID: (input) This parameter specifies the file to delete.
{
{   STATUS: (output) This parameter returns the request status.
{
*DECK DECK=DMH$MTR_ALLOCATE_FRONT_END EXPAND=FALSE
{}
{   The purpose of this procedure is to calculate the paramters required by the
{ allocator and insert them into the request block for the monitor mode
{ allocate request.  Alternatively, it can be used to update the level one FAT
{ pointer.  The update must be done in monitor mode to prevent the pointer from
{ being changed in job mode in one CPU while it is being used in monitor mode
{ in another CPU.
{}
{       DMP$MTR_ALLOCATE_FRONT_END ( ALLOCATE_REQUEST_BLOCK )
{}
{ ALLOCATE_REQUEST_BLOCK: (input/output) This parameter is the request block
{       for the allocate request.
{}
*DECK DECK=DMH$MTR_DEALLOCATE_FRONT_END EXPAND=FALSE
{}
{   The purpose of this procedure is to calculate parameters required by the
{ deallocator and insert them into the request block for the monitor mode
{ deallocate request.
{}
{       DMP$MTR_DEALLOCATE_FRONT_END ( DEALLOCATE_REQUEST_BLOCK )
{}
{ DEALLOCATE_REQUEST_BLOCK: (input/output) This parameter is the request block
{       for the deallocate request.
{}
*DECK DECK=DMH$MTR_FETCH_FILE_DESCRIPTOR EXPAND=FALSE
*DECK DECK=DMH$MTR_SET_STATUS_ABNORMAL EXPAND=FALSE
*DECK DECK=DMH$OPEN_DAT EXPAND=FALSE
{
{  The purpose of this request is to open a file and construct a
{ pointer to a device allocation table.
{
{  dmp$open_dat  (sfid, ring1, ring2, access_rights, access_selections,
{                 segment_pointer, status)
{
{  sfid: (input) Specifies the file identification for the file to
{                be opened.
{
{  ring1: (input) Specifies the first of two ring numbers to be used in
{                 creating the ring brackets of the file.
{
{  ring2: (input) The second of the two rings.
{
{  access_rights: (input) Specifies what kind of access to the file
{                         the caller requires.
{
{  access_selections: (input) Specifies how the caller wishes to access
{                             the file.
{
{  p_dat: (output) Contains the pointer to the dat.
{
{  status: (output) This parameter returns the result of the request.
{

*DECK DECK=DMH$OPEN_DFLT EXPAND=FALSE
{
{  The purpose of this request is to open a file and construct a
{ pointer to a device file list table.
{
{  dmp$open_dflt (sfid, ring1, ring2, access_rights, access_selections,
{                 segment_pointer, status)
{
{  sfid: (input) Specifies the file identification for the file to
{                be opened.
{
{  ring1: (input) Specifies the first of two ring numbers to be used in
{                 creating the ring brackets of the file.
{
{  ring2: (input) The second of the two rings.
{
{  access_rights: (input) Specifies what kind of access to the file
{                         the caller requires.
{
{  access_selections: (input) Specifies how the caller wishes to access
{                             the file.
{
{  p_dflt: (output) Contains the pointer to the dflt.
{
{  status: (output) This parameter returns the result of the request.
{

*DECK DECK=DMH$OPEN_DIRECTORY EXPAND=FALSE
{
{  The purpose of this request is to open a file and construct a
{ pointer to a volume directory.
{
{  dmp$open_directory (sfid, ring1, ring2, access_rights, access_selections,
{                 segment_pointer, status)
{
{  sfid: (input) Specifies the file identification for the file to
{                be opened.
{
{  ring1: (input) Specifies the first of two ring numbers to be used in
{                 creating the ring brackets of the file.
{
{  ring2: (input) The second of the two rings.
{
{  access_rights: (input) Specifies what kind of access to the file
{                         the caller requires.
{
{  access_selections: (input) Specifies how the caller wishes to access
{                             the file.
{
{  p_directory: (output) Contains the pointer to the directory.
{
{  status: (output) This parameter returns the result of the request.
{

*DECK DECK=DMH$OPEN_FILE EXPAND=FALSE
{
{  The purpose of this request is to open a file for segment
{ access.  The requestor's ring number must be <= osc$tsrv_ring.
{ The type of the pointer returned is specified by the caller.
{
{  dmp$open_file (sfid, ring1, ring2, access_rights, access_selections,
{                 segment_pointer, status)
{
{  sfid: (input) Specifies the file identification for the file to
{                be opened.
{
{  ring1: (input) Specifies the first of two ring numbers to be used in
{                 creating the ring brackets of the file.
{
{  ring2: (input) The second of the two rings.
{
{  access_rights: (input) Specifies what kind of access to the file
{                         the caller requires.
{
{  access_selections: (input) Specifies how the caller wishes to access
{                             the file.
{
{  segment_pointer: (input/output) Specifies the type of pointer to be
{                             constructed.  The pointer is returned in
{                             this parameter.
{
{  status: (output) This parameter returns the result of the request.
{

*DECK DECK=DMH$OPEN_LABEL EXPAND=FALSE
{
{  The purpose of this request is to open a file and construct a
{ pointer to a volume label.
{
{  dmp$open_label (sfid, ring1, ring2, access_rights, access_selections,
{                 segment_pointer, status)
{
{  sfid: (input) Specifies the file identification for the file to
{                be opened.
{
{  ring1: (input) Specifies the first of two ring numbers to be used in
{                 creating the ring brackets of the file.
{
{  ring2: (input) The second of the two rings.
{
{  access_rights: (input) Specifies what kind of access to the file
{                         the caller requires.
{
{  access_selections: (input) Specifies how the caller wishes to access
{                             the file.
{
{  p_label: (output) Contains the pointer to the label.
{
{  status: (output) This parameter returns the result of the request.
{

*DECK DECK=DMH$OPEN_LOGIN_TABLE EXPAND=FALSE
{
{  The purpose of this request is to open a file and construct a
{ pointer to a volume login table.
{
{  dmp$open_login_table (sfid, ring1, ring2, access_rights, access_selections,
{                 segment_pointer, status)
{
{  sfid: (input) Specifies the file identification for the file to
{                be opened.
{
{  ring1: (input) Specifies the first of two ring numbers to be used in
{                 creating the ring brackets of the file.
{
{  ring2: (input) The second of the two rings.
{
{  access_rights: (input) Specifies what kind of access to the file
{                         the caller requires.
{
{  access_selections: (input) Specifies how the caller wishes to access
{                             the file.
{
{  p_login_table: (output) Contains the pointer to the login table.
{
{  status: (output) This parameter returns the result of the request.
{

*DECK DECK=DMH$READ EXPAND=FALSE
{
{    The purpose of this request is to convert a logical file address
{  (byte address) to the corresponding logical device address for a read
{  operation.
{
{        PROCEDURE DMP$READ(P_FDE, BYTE_ADDRESS, LENGTH_IN_BYTES,
{                         DEVICE_ADDRESS,STATUS)
{
{ P_FDE:(input)  This parameter specifies a pointer to the file descriptor
{                entry for the file.
{
{ BYTE_ADDRESS:(input)  This parameter specifies the logical file address to be
{                       converted.
{
{ LENGTH_IN_BYTES:(input)  This parameter specifies the length of the read
{                          request.
{
{ DEVICE_ADDRESS:(output)  This parameter returns the logical device address
{                          that corresponds to the logical file address.
{
{ STATUS:(output)  This parameter returns the request status.
{
*DECK DECK=DMH$REASSIGN_FILE EXPAND=FALSE
{
{    The purpose of this request is to release space and volume
{  assignment for a file (all subfiles and fats are freed) and
{  assign a new volume and space for the file.
{
{       DMP$REASSIGN_FILE (SYSTEM_FILE_ID, BYTES_TO_ALLOCATE, STATUS)
{
{ SYSTEM_FILE_ID: (input)  This parameter specifies the system
{       file identification for the file.
{
{ BYTES_TO_ALLOCATE: (input)  This parameter specifies the amount
{       of file space to be allocated for the file.
{
{ STATUS: (output)  This parameter returns the request status.
{
*DECK DECK=DMH$RELEASE_AVT_ENTRY EXPAND=FALSE
{
{   This request will return an active volume table entry to the available
{ active volume queue.  The result of the request is returned to the caller.
{
{      DMP$RELEASE_AVT_ENTRY (AVT_INDEX,ABLE_TO_RELEASE_AVT_ENTRY)
{
{ AVT_INDEX: (input)  This parameter specifies the index of the active
{      volume table entry to be released.
{
{ ABLE_TO_RELEASE_AVT_ENTRY: (output)  This parameter returns the result
{      of the request.
{
*DECK DECK=DMH$RELEASE_FAT EXPAND=FALSE
*DECK DECK=DMH$RELEASE_FILE_MEDIUM_DESC EXPAND=FALSE
*DECK DECK=DMH$SAVE_ASID EXPAND=FALSE
*DECK DECK=DMH$SAVE_RECONCILE_LIST EXPAND=FALSE
{
{ PURPOSE:
{   The purpose of this procedure is to allocate space in the
{   mainframe_pageable heap and copy the sorted dfl (i.e. reconcile list)
{   created by DMP$BUILD_SORTED_DFL into this space. If a reconcile_list
{   already exists in the heap the space will be freed before creating
{   a new one.
{
{      DMP$SAVE_RECONCILE_LIST (RECONCILE_INFO)
{
{   RECONCILE_INFO: (input) This parameter specifies the reconcile_info to
{         store in the mainframe_pageable heap.
{
*DECK DECK=DMH$SEARCH_ACTIVE_VOLUME_TABLE EXPAND=FALSE
{
{      The purpose of this request is to locate a specified active volume
{ table entry.  The specification of the desired active volume table
{ entry is done using a search key.
{
{      DMP$SEARCH_ACTIVE_VOLUME_TABLE (SEARCH_KEY,AVT_INDEX,
{                                   ACTIVE_VOLUME_ENTRY_NOT_FOUND)
{
{ SEARCH_KEY:(input)  This parameter specifies the search criteria to be
{      used in locating the active volume table entry.  Current search
{      keys are: recorded vsn and logical unit number.
{
{ AVT_INDEX:(output)  This paraeter is used to return an index to the
{      active volume table entry if the search is successful.  IF the
{      search is not successful, the index of an available active volume
{      table entry is returned.
{
{ ACTIVE_VOLUME_ENTRY_NOT_FOUND:(output)  This parameter is used to
{      return the result of the request.
{
*DECK DECK=DMH$SEARCH_MAT_FOR_POSITION EXPAND=FALSE
*DECK DECK=DMH$SET_EOI EXPAND=FALSE
{}
{   The purpose of this procedure is to provide a means of storing
{ the eoi byte address in device management's tables.
{}
{       DMP$SET_EOI (SYSTEM_FILE_ID, EOI, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This is the principal file identifier used by device
{       management.
{}
{ EOI: (input) This is the end of information address which is to be stored in
{       the device management tables.
{}
{ STATUS: (output) This paramater specifies the status of the request.
{}
*DECK DECK=DMH$SET_FAU_STATE EXPAND=FALSE

{  The purpose of this routine is to set the FAU state back to invalid data.
{  For local files the state is immediately set to initialized on the first
{  write.  If the write fails and the job has been swapped, the FAU state
{  cannot be reset in dmp$transfer_unit_completed.  This routine is called
{  by Job Swapper when it has swapped the job back in.
{
{  DMP$SET_FAU_STATE (JOB_ID, SYSTEM_FILE_ID, BYTE_ADDRESS, STATUS)
{
{  JOB_ID: (input) This paramerter specifies the unique identification of the job.
{
{  SYSTEM_FILE_ID: (input) This parameter specifies the system file identification
{                  of the file.
{
{  BYTE_ADDRESS: (input) This parameter specifies the locgical file address of the
{                 write operation.
{
{  STATUS: (output) This parameter returns the request status.
{
*DECK DECK=DMH$SET_FILE_RESIDENCE EXPAND=FALSE
{
{    This request sets the computer system file residence for a particular file.
{
{       DMP$SET_FILE_RESIDENCE(FILE_TYPE,FILE_USAGE,FILE_SHARE_SELECTIONS,
{                              FILE_SHARE_HISTORY,FILE_TABLE_RESIDENCE,STATUS)
{
{  FILE_TYPE:(input)  This parameter specifies the type of file.
{
{  FILE_USAGE:(input)  This parametr specifies how the file is to be used.
{
{  FILE_SHARE_SELECTIONS:(input)  This parameter specifies how the file is to
{                                 shared.
{
{  FILE_SHARE_HISTORY:(input)  This parameter specifies any previous share
{                              information for the file.
{
{  FILE_TABLE_RESIDENCE:(output)  This parameter returns the computer system
{                                 file residence for the file.
{
{  STATUS:(output)  This parameter returns the request status.
{
*DECK DECK=DMH$SET_FILE_TABLE_LOCATOR EXPAND=FALSE
{
{    The purpose of this request is to determine the location of a computer
{  system file.
{
{        DMP$SET_FILE_TABLE_LOCATOR(FILE_RESIDENCE,FILE_LOCATOR,STATUS)
{
{  FILE_RESIDENCE:(input)  This parameter indicates the residence of the
{                          computer system file within the computer system.
{
{  FILE_LOCATOR:(output)  This parameter returns the location of the area
{                         corresponding to the computer system file residence.
{
{  STATUS:(output)  This parameter returns the request status.
{
*DECK DECK=DMH$STORE_ASID EXPAND=FALSE
*DECK DECK=DMH$STORE_SEGMENT_LIMIT EXPAND=FALSE
*DECK DECK=DMH$TRANSFER_UNIT_COMPLETED EXPAND=FALSE
{
{   The purpose of this request is to communicate the result of an io
{ operation to device management.
{
{      PROCEDURE DMP$TRANSFER_UNIT_COMPLETED(JOB_ID,SYSTEM_FILE_ID,BYTE_ADDRESS,
{                                  WRITE_TU_STATUS,AU_WAS_PREVIOUSLY_WRITTEN,
{                                  MEDIA_ERROR,CYLINDER,MAU_OFFSET_IN_CYLINDER,
{                                  STATUS)
{
{ JOB_ID:(input)  This parameter specifies the unique identification of the
{                 job performing the io on the file.
{
{ SYSTEM_FILE_ID:(input)  This parameter specifies the system file
{                         identification of the file.
{
{ BYTE_ADDRESS:(input)  This parameter specifies the logical file address of
{                       the write operation.
{
{ WRITE_TU_STATUS:(input)  This parameter specifies the result of the write
{                          operation.
{
{ AU_WAS_PREVIOUSLY_WRITTEN:(input)  This parameter indicates whether or
{     not the allocation unit has previously been written.
{
{ MEDIA_ERROR:(input)  This parameter specifies whether or not an error was
{     encountered while attempting to do iio on the allocation unit.
{
{ CYLINDER:(input)  This parameter specifies the cylinder where the io
{     operation started.
{
{ MAU_OFFSET_IN_CYLINDER:(input)  This parameter specifies the minimum allocation
{     unit offset, within the cylinder, where the io started.
{
{ STATUS:(output)  This parameter returns the request status.
{
*DECK DECK=DMH$TRANSFER_UNIT_WRITTEN EXPAND=FALSE
*DECK DECK=DMH$UNCONDITIONAL_GET_FDE EXPAND=FALSE
*DECK DECK=DMH$UNLOCK_AVT_ENTRY EXPAND=FALSE
{
{   This request will attempt to unlock a specified active volume table
{ entry.  The result of the unlock attempt is returned.
{
{      DMP$UNLOCK_AVT_ENTRY (AVT_INDEX, LOCK_CLEARED)
{
{ AVT_INDEX: (input) This parameter specifies the active volume table
{      entry to unlock.
{
{ LOCK_CLEARED: (output)  This parameter is used to return the
{      result of the unlock attempt.
{
*DECK DECK=DMH$UNLOCK_FILE EXPAND=FALSE
*DECK DECK=DMH$UPDATE_RECONCILE_LIST EXPAND=FALSE
{
{ PURPOSE:
{   The purpose of this procedure is to update the PURGE and RECONCILED fields
{   on an entry in the reconcile_list stored in the mainframe_pageable heap.
{
{     DMP$UPDATE_RECONCILE_LIST (SUBFILE_INDEX, PURGE_FILE, RECONCILED)
{
{ SUBFILE_INDEX: (input) This parameter specifies the index of the entry
{       in the sorted reconcile_list to modify.
{
{ PURGE_FILE: (input) This parameter specifies the new value for the
{          PURGE field of the reconcile_list entry.
{
{ RECONCILED: (input) This parameter specifies the new value for the
{          RECONCILED field of the reconcile_list entry.
{
*DECK DECK=DMH$UPDATE_TAPE_VSN_LIST EXPAND=FALSE

{
{ The purpose of this request is to change the volume serial number
{ on the current tape subfile if their currently is no active subfile,
{ and the tape_assignment_operations indicates an initial tape,
{ If the operations indicates advance, then it changes the volume serial
{ number of the next tape subfile.  If the operations indicates extend
{ and the volume list is exhausted, it appends another volume
{ on the end of the list.
{
{ This routine follows the same logic as does dmp$select_tape_subfile.
{
{     DMP$UPDATE_TAPE_VSN_LIST (SFID, VOLUME_DESCRIPTOR,
{       TAPE_ASSIGNMENT_OPERATION, STATUS)
{
{ SFID: This parameter specifies the system file identifier of the file
{       whoose vsn list you wish to change.
{
{ VOLUME_DESCRIPTOR: This parameter specifies the new description of the
{       volume.
{
{ TAPE_ASSIGNMENT_OPERATION: This parameter specifies what type of update
{       is allowed.
{
{ STATUS: This parameter specifies the request status.
{
*DECK DECK=DMH$VALIDATE_SFID EXPAND=FALSE
*DECK DECK=DMH$VOLUME_ONLINE EXPAND=FALSE
{
{    The purpose of this request is to inform device management
{  that a volume has become available to the system.  Device
{  management will initiate action to make the volume known to
{  the system, i.e., an entry will be made for the volume in
{  the active volume table.
{
{        DMP$VOLUME_ONLINE(LOGICAL_UNIT_NUMBER,P_PHYSICAL_ATTRIBUTES,
{                          STATUS)
{
{  LOGICAL_UNIT_NUMBER:(input)  This parameter specifies the logical
{                               unit number of the volume to be brought
{                               online.
{
{  P_PHYSICAL_ATTRIBUTES:(input)  This parameter specifies the physical
{                                    attributes of the volume.
{
{  STATUS:(output)  This parameter returns the request status.
{
*DECK DECK=DMH$WRITE EXPAND=FALSE
{
{    The purpose of this request is to convert a logical file address
{  (byte address) to the corresponding logical device address for a write
{  operation.  Space will be allocated up to and including the logical file
{  address if necessary.
{
{        DMP$WRITE(P_FDE, BYTE_ADDRESS, LENGTH, DEVICE_ADDRESS, STATUS)
{
{ P_FDE:(input)  This parameter specifies a pointer to the file descriptor
{                entry for the file.
{
{ BYTE_ADDRESS:(input)  This parameter specifies the logical file address for
{                       the write.
{
{ LENGTH: (input)    This parameter specifies the length to be written.
{
{ DEVICE_ADDRESS:(output)  This parameter returns the logical device address
{                          that corresponds to the logical file address
{                          (byte address).
{
{ STATUS:(output)  This parameter returns the request status.
{
*DECK DECK=DMK$TAPE_KEYPOINTS EXPAND=FALSE
{dmdtkey}
{        tape device manager keypoints

  CONST

    dmk$create_tape_file = dmk$tape_base,
    {E 'dmp$create_tape_file'}
    {X 'dmp$create_tape_file' 'status' I20}

    dmk$initialize_tape = dmk$tape_base + 1,
    {E 'dmp$initialize_tape'}
    {X 'dmp$initialize_tape' 'status' I20}

    dmk$create_tmd = dmk$tape_base + 2,
    {E 'dmp$create_tmd'}
    {X 'dmp$create_tmd' 'status' I20}

    dmk$allocate_tape_subfile = dmk$tape_base + 3,
    {E 'dmp$allocate_tape_subfile'}
    {X 'dmp$allocate_tape_subfile' 'status' I20}

    dmk$select_tape_subfile = dmk$tape_base + 4,
    {E 'dmp$select_tape_subfile'}
    {X 'dmp$select_tape_subfile' 'status' I20}

    dmk$deselect_tape_subfile = dmk$tape_base + 5,
    {E 'dmp$deselect_tape_subfile'}
    {X 'dmp$deselect_tape_subfile' 'status' I20}

    dmk$get_tmd_field = dmk$tape_base + 6,
    {E 'dmp$get_tmd_field'}
    {X 'dmp$get_tmd_field' 'status' I20}

    dmk$convert_sfid_to_lun = dmk$tape_base + 7,
    {E 'dmp$convert_sfid_to_lun'}
    {X 'dmp$convert_sfid_to_lun'}

    dmk$search_avt = dmk$tape_base + 8,
    {E 'dmp$search_avt'}
    {X 'dmp$search_avt'}

    dmk$create_tir = dmk$tape_base + 9,
    {E 'dmp$create_tir'}
    {X 'dmp$create_tir' 'status' I20}

    dmk$get_tape_medium_descriptor = dmk$tape_base + 10,
    {E 'dmp$get_tape_medium_descriptor'}
    {X 'dmp$get_tape_medium_descriptor' 'status' I20}

    dmk$create_tape_message = dmk$tape_base + 11,
    {E 'dmp$create_tape_message'}
    {X 'dmp$create_tape_message' 'status' I20}

    dmk$action_operator = dmk$tape_base + 12,
    {E 'dmp$action_operator'}
    {X 'dmp$action_operator' 'status' I20}

    dmk$crack_assign_reply = dmk$tape_base + 13,
    {E 'dmp$crack_assign_reply'}
    {X 'dmp$crack_assign_reply' 'status' I20}

    dmk$advance_tape_volume = dmk$tape_base + 14,
    {E 'dmp$advance_tape_volume'}
    {X 'dmp$advance_tape_volume' 'status' I20}

    dmk$close_tape_volume = dmk$tape_base + 15,
    {E 'dmp$close_tape_volume'}
    {X 'dmp$close_tape_volume' 'status' I20}

    dmk$get_tape_status = dmk$tape_base + 16,
    {E 'dmp$get_tape_status'}
    {X 'dmp$get_tape_status' 'status' I20}

    dmk$activate_tape = dmk$tape_base + 17,
    {E 'dmp$activate_tape'}
    {X 'dmp$activate_tape' 'status' I20}

    dmk$validate_external_vsn = dmk$tape_base + 18,
    {E 'dmp$validate_external_vsn'}
    {X 'dmp$validate_external_vsn' 'status' I20}

    dmk$select_tape = dmk$tape_base + 19,
    {E 'dmp$select_tape'}
    {X 'dmp$select_tape' 'status' I20}

    dmk$validate_assign_reply = dmk$tape_base + 20,
    {E 'dmp$validate_assign_reply'}
    {X 'dmp$validate_assign_reply' 'status' I20}

    dmk$assign_tape = dmk$tape_base + 21,
    {E 'dmp$assign_tape'}
    {X 'dmp$assign_tape' 'status' I20}

    dmk$create_tape_window = dmk$tape_base + 22,
    {E 'dmp$create_tape_window'}
    {X 'dmp$create_tape_window' 'status' I20}

    dmk$destroy_tape_window = dmk$tape_base + 23,
    {E 'dmp$destroy_tape_window' }
    {X 'dmp$destroy_tape_window' 'status' I20}

    dmk$destroy_tape_file = dmk$tape_base + 24,
    {E 'dmp$destroy_tape_file'}
    {X 'dmp$destroy_tape_file' 'status' I20}

    dmk$destroy_tmd = dmk$tape_base + 25,
    {E 'dmp$destroy_tmd' }
    {X 'dmp$destroy_tmd' 'status' I20}

    dmk$reserve_tape = dmk$tape_base + 26,
    {E 'dmp$reserve_tape' }
    {X 'dmp$reserve_tape' 'status' I20}

    dmk$release_tape = dmk$tape_base + 27,
    {E 'dmp$release_tape' }
    {X 'dmp$release_tape' 'status' I20}

    dmk$acquire_tape_resource = dmk$tape_base + 28,
    {E 'dmp$acquire_tape_resource' }
    {X 'dmp$acquire_tape_resource' 'status' I20}

    dmk$return_tape_resource = dmk$tape_base + 29,
    {E 'dmp$return_tape_resource' }
    {X 'dmp$return_tape_resource' 'status' I20}

    dmk$create_stt = dmk$tape_base + 30,
    {E 'dmp$create_stt' }
    {X 'dmp$create_stt' 'status' I20}

    dmk$swap_tape = dmk$tape_base + 31,
    {E 'dmp$swap_tape' }
    {X 'dmp$swap_tape' 'status' I20}

    dmk$tape_condition_handler = dmk$tape_base + 32,
    {E 'dmp$tape_condition_handler' }
    {X 'dmp$tape_condition_handler' 'status' i20}

    dmk$reset_tape_volume = dmk$tape_base + 33;
    {E 'dmp$reset_tape_volume' }
    {X 'dmp$reset_tape_volume' 'status' I20}

?? PUSH (LISTEXT := ON) ??
*copyc amk$base_keypoint_values
?? POP ??
*DECK DECK=DMM$ACCESS_ACTIVE_VOLUME_TABLE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOSVE device management' ??
?? NEWTITLE := 'Module Header' ??
MODULE dmm$access_active_volume_table;
*copy OSD$DEFAULT_PRAGMATS
{
{ PURPOSE:
{      This module contains the procedures used to access active volume
{  table entries.
{ DESIGN:
{      Contains procedures to lock, unlock, reserve, release, and locate
{  active volume table entries.
{
?? PUSH (LISTEXT := ON) ??
?? TITLE := '  Common Decks', EJECT ??
*copyc dmt$active_volume_table
*copyc dmt$active_volume_table_index
*copyc dmt$assigned_ms_vol_attributes
*copyc dmt$avt_search_key
*copyc dmt$error_condition_codes
*copyc dmt$file_table_lock
*copyc dmt$keypoint_calls
*copyc dmt$mainframe_allocation_table
*copyc dmt$mainframe_device_file_list
*copyc dmt$mat_converter
*copyc dmv$active_volume_table
*copyc dmv$null_vsn
*copyc osk$keypoints
*copyc osp$set_locked_variable
*copyc rmd$volume_declarations
*copyc rmt$device_class
?? POP ??
?? TITLE := '  Global Variables', EJECT ??
?? FMT (FORMAT := OFF) ??
  VAR
    default_avt_entry : [STATIC, READ] dmt$active_volume_table_entry :=
      {lock:=}                            [[ORD(dmc$locked)],
      {entry_available:=}                 FALSE,
      {logical_unit_number:=}             0,
      {padding:=}                         'AVTE',
      {allocation_allowed:=}              [FALSE,
      {space_low:=}                       FALSE,
      {space_gone:=}                      FALSE,
      {disk_table_status:=}               $dmt$ms_volume_table_status [],
      {class:=}                           $dmt$class[],
      {system_class_activity:=}           [0, 0, 0, 0, 0],
      {logged_in_for_recovery:=}          FALSE,
      {update_lock:=}                     [0],
      {logging_lock:=}                    [0],
      {internal_vsn:=}                    [0, osc$cyber_180_model_unknown, 1980, 1, 1, 0, 0, 0, 0, 0],
      {p_device_allocation_table:=}       [0, gfc$tr_null_residence, gfc$null_file_hash],
      {p_device_file_list_table:=}        [0, gfc$tr_null_residence, gfc$null_file_hash],
      {p_device_log:=}                    [0, gfc$tr_null_residence, gfc$null_file_hash],
      {p_directory:=}                     [0, gfc$tr_null_residence, gfc$null_file_hash],
      {p_login_table:=}                   [0, gfc$tr_null_residence, gfc$null_file_hash],
      {mainframe_assigned:=}              [0, 1],
      {p_mat:=}                           [NIL, 0, 0, 0],
      {p_mfl:=}                           [NIL, 0, 0, 0],
      {recorded_vsn:=}                    '      ',
      {set_name:=}                        osc$null_name,
      {status:=}                          $dmt$ms_volume_system_status [],
      {volume_owner:=}                    [osc$null_name, osc$null_name],
      {current_position_offset_in_log:=}  0,
      {allocated_log_size:=}              0,
      {device_log_entry_count:=}          0,
      {volume_unavailable:=}              FALSE,
      {volume_unavailable_msg:=}          FALSE,
      {logging_process_damaged:=}         FALSE]];
?? FMT (FORMAT := ON) ??
?? TITLE := '  dmp$lock_avt_entry', EJECT ??
*copy dmh$lock_avt_entry

  PROCEDURE [XDCL] dmp$lock_avt_entry (avt_index: dmt$active_volume_table_index;
    VAR able_to_lock_entry: boolean);

    VAR
      actual: integer;

    osp$set_locked_variable (dmv$p_active_volume_table^ [avt_index].lock.status, ORD
        (dmc$unlocked), ORD (dmc$locked), actual, able_to_lock_entry);

  PROCEND dmp$lock_avt_entry;
?? TITLE := '  dmp$unlock_avt_entry', EJECT ??
*copy dmh$unlock_avt_entry

  PROCEDURE [XDCL] dmp$unlock_avt_entry (avt_index: dmt$active_volume_table_index;
    VAR lock_cleared: boolean);

    VAR
      actual: integer;

    osp$set_locked_variable (dmv$p_active_volume_table^ [avt_index].lock.status, ORD
          (dmc$locked), ORD (dmc$unlocked), actual, lock_cleared);

  PROCEND dmp$unlock_avt_entry;
  ?? TITLE := '  dmp$get_rvsn_by_lun', EJECT ??

  PROCEDURE [XDCL] dmp$get_rvsn_by_lun (lun: iot$logical_unit;
    VAR rvsn: rmt$recorded_vsn;
    VAR entry_found: boolean);

    VAR
      avt_index: dmt$active_volume_table_index;

    entry_found := FALSE;
    FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^) TO
                     UPPERBOUND (dmv$p_active_volume_table^) DO
      IF (NOT dmv$p_active_volume_table^ [avt_index].entry_available) THEN
        IF dmv$p_active_volume_table^ [avt_index].logical_unit_number = lun THEN
          rvsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;
          entry_found := TRUE;
          RETURN;
        IFEND;
      IFEND;
    FOREND;
  PROCEND dmp$get_rvsn_by_lun;
?? TITLE := '  dmp$get_unused_avt_entry', EJECT ??
*copy dmh$get_unused_avt_entry

  PROCEDURE [XDCL] dmp$get_unused_avt_entry (VAR avt_index: dmt$active_volume_table_index;
    VAR able_to_get_avt_entry: boolean);

    VAR
      able_to_get_entry_lock: boolean,
      able_to_clear_entry_lock: boolean;

    able_to_get_avt_entry := FALSE;

    IF avt_index > 0 THEN
      dmp$lock_avt_entry (avt_index, able_to_get_entry_lock);
      IF able_to_get_entry_lock THEN
        IF dmv$p_active_volume_table^ [avt_index].entry_available THEN
          dmv$p_active_volume_table^ [avt_index].entry_available := FALSE;
          dmv$p_active_volume_table^ [avt_index] := default_avt_entry;
          able_to_get_avt_entry := TRUE;
        IFEND;
        dmp$unlock_avt_entry (avt_index, able_to_clear_entry_lock);
        IF NOT able_to_clear_entry_lock THEN
          able_to_get_avt_entry := FALSE;
          RETURN;
        IFEND;
        IF able_to_get_avt_entry THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND
          (dmv$p_active_volume_table^) DO
      dmp$lock_avt_entry (avt_index, able_to_get_entry_lock);
      IF able_to_get_entry_lock THEN
        IF dmv$p_active_volume_table^ [avt_index].entry_available THEN
          dmv$p_active_volume_table^ [avt_index].entry_available := FALSE;
          dmv$p_active_volume_table^ [avt_index] := default_avt_entry;
          able_to_get_avt_entry := TRUE;
        IFEND;
        dmp$unlock_avt_entry (avt_index, able_to_clear_entry_lock);
        IF NOT able_to_clear_entry_lock THEN
          able_to_get_avt_entry := FALSE;
          RETURN;
        IFEND;
        IF able_to_get_avt_entry THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND dmp$get_unused_avt_entry;
?? TITLE := '  dmp$release_avt_entry', EJECT ??
*copy dmh$release_avt_entry

  PROCEDURE [XDCL] dmp$release_avt_entry (avt_index: dmt$active_volume_table_index;
    VAR able_to_release_avt_entry: boolean);

    VAR
      able_to_lock_avt_entry: boolean,
      able_to_unlock_avt_entry: boolean;

    able_to_release_avt_entry := FALSE;

    IF (avt_index > 0) THEN
      dmp$lock_avt_entry (avt_index, able_to_lock_avt_entry);
      IF able_to_lock_avt_entry THEN
        IF NOT dmv$p_active_volume_table^ [avt_index].entry_available THEN
          dmv$p_active_volume_table^ [avt_index].entry_available := TRUE;
          dmp$unlock_avt_entry (avt_index, able_to_unlock_avt_entry);
          IF able_to_unlock_avt_entry THEN
            able_to_release_avt_entry := TRUE;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND dmp$release_avt_entry;
?? TITLE := '  dmp$search_active_volume_table', EJECT ??
*copy dmh$search_active_volume_table

  PROCEDURE [XDCL] dmp$search_active_volume_table (search_key: dmt$avt_search_key;
    VAR avt_index: dmt$active_volume_table_index;
    VAR active_volume_entry_not_found: boolean);

    VAR
      avt_entry_match_found: boolean,
      available_avt_entry_index: dmt$active_volume_table_index,
      search_index: dmt$active_volume_table_index;

    active_volume_entry_not_found := FALSE;
    avt_entry_match_found := FALSE;
    available_avt_entry_index := 0;

    IF dmv$p_active_volume_table = NIL THEN
      avt_index := 0;
      active_volume_entry_not_found := TRUE;
      RETURN;
    IFEND;

    FOR search_index := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND
          (dmv$p_active_volume_table^) DO
      IF NOT dmv$p_active_volume_table^ [search_index].entry_available THEN

        CASE search_key.value OF
        = dmc$search_avt_by_rec_vsn =
          avt_entry_match_found := (dmv$p_active_volume_table^
                [search_index].mass_storage.recorded_vsn = search_key.
                recorded_vsn);
        = dmc$search_avt_by_lun =
          avt_entry_match_found := (dmv$p_active_volume_table^ [search_index].logical_unit_number =
                                    search_key.logical_unit_number);

        ELSE
        CASEND;
        IF avt_entry_match_found THEN
          avt_index := search_index;
          RETURN;
        IFEND;
      IFEND;
      IF (available_avt_entry_index = 0) AND (dmv$p_active_volume_table^
            [search_index].entry_available) THEN
        available_avt_entry_index := search_index;
      IFEND;
    FOREND;

    avt_index := available_avt_entry_index;
    active_volume_entry_not_found := TRUE;

  PROCEND dmp$search_active_volume_table;
?? TITLE := '  dmp$get_active_vol_attributes', EJECT ??
*copy dmh$get_active_vol_attributes

  PROCEDURE [XDCL] dmp$get_active_vol_attributes (required_recorded_vsn: rmt$recorded_vsn;
        search_avt_index: dmt$active_volume_table_index;
    VAR p_assigned_vol_attributes: ^array [ * ] OF dmt$assigned_ms_vol_attribute;
    VAR avt_entry_found: boolean);

    VAR
      search_avt_key: dmt$avt_search_key,
      index: integer,
      search_of_avt_required: boolean,
      avt_entry_not_found: boolean,
      avt_index: dmt$active_volume_table_index;

    avt_entry_found := FALSE;
    search_of_avt_required := TRUE;
    avt_index := search_avt_index;

    IF search_avt_index > 0 THEN
      IF (dmv$p_active_volume_table^ [search_avt_index].mass_storage.
            recorded_vsn = required_recorded_vsn) OR (required_recorded_vsn =
            dmv$null_vsn) THEN
        search_of_avt_required := FALSE;
      IFEND;
    IFEND;

    IF search_of_avt_required THEN
      search_avt_key.value := dmc$search_avt_by_rec_vsn;
      search_avt_key.recorded_vsn := required_recorded_vsn;
      dmp$search_active_volume_table (search_avt_key, avt_index,
            avt_entry_not_found);
      IF avt_entry_not_found THEN
        RETURN;
      IFEND;
    IFEND;

    avt_entry_found := TRUE;

    FOR index := LOWERBOUND (p_assigned_vol_attributes^) TO UPPERBOUND
          (p_assigned_vol_attributes^) DO
      CASE p_assigned_vol_attributes^ [index].keyword OF

      = dmc$avt_index =
        p_assigned_vol_attributes^ [index].index := avt_index;

      = dmc$ms_allocation_allowed =
        p_assigned_vol_attributes^ [index].allocation_allowed :=
              dmv$p_active_volume_table^ [avt_index].mass_storage.
              allocation_allowed AND NOT
              dmv$p_active_volume_table^ [avt_index].mass_storage.
              volume_unavailable;

      = dmc$ms_current_log_position =
        p_assigned_vol_attributes^ [index].current_log_position :=
              dmv$p_active_volume_table^ [avt_index].mass_storage.
              current_position_offset_in_log;

      = dmc$ms_device_allocation_table =
        p_assigned_vol_attributes^ [index].p_dat := dmv$p_active_volume_table^
              [avt_index].mass_storage.p_device_allocation_table;

      = dmc$ms_device_log_entry_count =
        p_assigned_vol_attributes^ [index].device_log_entry_count :=
              dmv$p_active_volume_table^ [avt_index].mass_storage.
              device_log_entry_count;

      = dmc$ms_recorded_vsn =
        p_assigned_vol_attributes^ [index].recorded_vsn :=
              dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;

      = dmc$ms_internal_vsn =
        p_assigned_vol_attributes^ [index].internal_vsn :=
              dmv$p_active_volume_table^ [avt_index].mass_storage.internal_vsn;

      = dmc$ms_device_log =
        p_assigned_vol_attributes^ [index].p_dlog := dmv$p_active_volume_table^
              [avt_index].mass_storage.p_device_log;

      = dmc$ms_allocated_log_size =
        p_assigned_vol_attributes^ [index].allocated_log_size :=
              dmv$p_active_volume_table^ [avt_index].mass_storage.
              allocated_log_size;

      = dmc$ms_mainframe_assigned =
        p_assigned_vol_attributes^ [index].mainframe_assigned :=
              dmv$p_active_volume_table^ [avt_index].mass_storage.
              mainframe_assigned;

      = dmc$ms_device_file_list_table =
        p_assigned_vol_attributes^ [index].p_dflt := dmv$p_active_volume_table^
              [avt_index].mass_storage.p_device_file_list_table;

      = dmc$ms_volume_directory =
        p_assigned_vol_attributes^ [index].directory_sfid :=
              dmv$p_active_volume_table^ [avt_index].mass_storage.p_directory;

      = dmc$ms_volume_owner =
        p_assigned_vol_attributes^ [index].volume_owner :=
              dmv$p_active_volume_table^ [avt_index].mass_storage.volume_owner;

      = dmc$ms_volume_login_table =
        p_assigned_vol_attributes^ [index].p_vlgt := dmv$p_active_volume_table^
              [avt_index].mass_storage.p_login_table;

      = dmc$ms_volume_unavailable =
        p_assigned_vol_attributes^ [index].volume_unavailable := dmv$p_active_volume_table^
              [avt_index].mass_storage.volume_unavailable;

      ELSE
      CASEND;
    FOREND;

  PROCEND dmp$get_active_vol_attributes;
?? TITLE := '  dmp$get_mat_pointer', EJECT ??

  PROCEDURE [XDCL] dmp$get_mat_pointer (avt_index: dmt$active_volume_table_index;
    VAR p_mat: ^dmt$mainframe_allocation_table);

    VAR
      converter: dmt$mat_converter;

    converter.p_adaptable := dmv$p_active_volume_table^ [avt_index].mass_storage.p_mat;
    p_mat := converter.p_mat;
  PROCEND dmp$get_mat_pointer;
?? TITLE := '  dmp$get_mfl_pointer', EJECT ??

  PROCEDURE [XDCL] dmp$get_mfl_pointer (avt_index: dmt$active_volume_table_index;
    VAR p_mfl: ^dmt$ms_mf_device_file_list);

    TYPE
      converter_type = record
        case boolean of
        = FALSE =
          p_adaptable: cyt$adaptable_array_pointer,
        = TRUE =
          p_mfl: ^dmt$ms_mf_device_file_list,
        casend,
      recend;

    VAR
      converter: converter_type;

    converter.p_adaptable := dmv$p_active_volume_table^ [avt_index].mass_storage.p_mfl;
    p_mfl := converter.p_mfl;
  PROCEND dmp$get_mfl_pointer;

MODEND dmm$access_active_volume_table;
*DECK DECK=DMM$ACCESS_AVT_JOB_MODE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOSVE device management' ??
?? NEWTITLE := 'Module Header' ??
MODULE dmm$access_avt_job_mode;
{
{ PURPOSE:
{      This module contains the procedures used to access active volume
{  table entries in job mode.
{ DESIGN:
{      Contains procedures to obtain information from
{  active volume table entries.
{
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc dmp$lock_avt_entry
*copyc dmp$search_active_volume_table
*copyc dmp$unlock_avt_entry
*copyc DMT$ACTIVE_VOLUME_TABLE
*copyc dmt$active_volume_table_index
*copyc dmt$avt_logging_info
*copyc DMT$ERROR_CONDITION_CODES
*copyc osp$fatal_system_error
*copyc pmp$cycle
?? POP ??
*copy DMV$ACTIVE_VOLUME_TABLE
?? TITLE := '  dmp$change_set_name', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$change_set_name (vsn: rmt$recorded_vsn;
        new_set_name: stt$set_name;
    VAR status: ost$status);

    VAR
      avt_index: dmt$active_volume_table_index,
      avt_locked: boolean,
      avt_search_key: dmt$avt_search_key,
      avt_unlocked: boolean,
      local_status: ost$status,
      not_found: boolean;


    status.normal := TRUE;
    avt_search_key.value := dmc$search_avt_by_rec_vsn;
    avt_search_key.recorded_vsn := vsn;

    dmp$search_active_volume_table (avt_search_key, avt_index, not_found);

    IF not_found THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
            'Unable to locate AVT entry - dmp$change_set_name.', status);
      osp$append_status_parameter (' ', vsn, status);
      RETURN;
    IFEND;

    REPEAT
      dmp$lock_avt_entry (avt_index, avt_locked);
      IF NOT avt_locked THEN
        pmp$cycle (local_status);
      IFEND;
    UNTIL avt_locked;

    dmv$p_active_volume_table^ [avt_index].mass_storage.set_name := new_set_name;

    dmp$unlock_avt_entry (avt_index, avt_unlocked);
    IF NOT avt_unlocked THEN
      osp$fatal_system_error ('AVT lock failure - dmp$change_set_name.', NIL);
    IFEND;
  PROCEND dmp$change_set_name;
?? TITLE := '  dmp$get_avt_logging_info', EJECT ??
*copy dmh$get_avt_logging_info

  PROCEDURE [XDCL] dmp$get_avt_logging_info (avt_index: dmt$active_volume_table_index;
                                         VAR info: dmt$avt_logging_info;
                                         VAR valid_entry: boolean);

    valid_entry := valid_mass_storage_entry (avt_index);

    IF valid_entry THEN
      info.recorded_vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;
      info.device_log_sfid := dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log;
      info.dat_sfid := dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_allocation_table;
      info.dfl_sfid := dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_file_list_table;
      info.login_table_sfid := dmv$p_active_volume_table^ [avt_index].mass_storage.p_login_table;
      info.mainframe_assigned := dmv$p_active_volume_table^ [avt_index].mass_storage.mainframe_assigned;
      info.volume_unavailable := dmv$p_active_volume_table^ [avt_index].mass_storage.volume_unavailable;
      info.log_entry_count := dmv$p_active_volume_table^ [avt_index].mass_storage.device_log_entry_count;
      info.current_log_offset := dmv$p_active_volume_table^ [avt_index].mass_storage.
                                    current_position_offset_in_log;
      info.allocated_log_size := dmv$p_active_volume_table^ [avt_index].mass_storage.allocated_log_size;
      info.logging_process_damaged := dmv$p_active_volume_table^ [avt_index].mass_storage.
                                         logging_process_damaged;
    IFEND;

  PROCEND dmp$get_avt_logging_info;

?? TITLE := 'valid_mass_storage_entry', EJECT ??
  FUNCTION valid_mass_storage_entry (avt_index: dmt$active_volume_table_index): boolean;

    valid_mass_storage_entry :=
      (dmv$p_active_volume_table <> NIL) AND
      (avt_index >= LOWERBOUND (dmv$p_active_volume_table^)) AND
      (avt_index <= UPPERBOUND (dmv$p_active_volume_table^)) AND
      (NOT dmv$p_active_volume_table^ [avt_index].entry_available);

  FUNCEND valid_mass_storage_entry;

MODEND dmm$access_avt_job_mode;

*DECK DECK=DMM$ACCESS_VOLUME_DEVICE_FILES EXPAND=TRUE
?? RIGHT := 110 ??
*copy osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$access_volume_device_files ALIAS 'DMMDIS1';
?? TITLE := '  Common Decks', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmp$attach_device_file
*copyc dmp$close_file
*copyc dmp$get_active_vol_attributes
*copyc dmp$open_dat
*copyc dmp$open_dflt
*copyc dmp$open_directory
*copyc dmp$open_file
*copyc dmp$open_label
*copyc dmp$open_login_table
*copyc dmp$search_active_volume_table
*copyc dmt$assigned_ms_vol_attributes
*copyc dmt$error_condition_codes
*copyc dmt$ms_device_allocation_table
*copyc dmt$ms_device_file_list_entry
*copyc dmt$ms_volume_directory
*copyc dmt$ms_volume_label
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc rmd$volume_declarations
?? POP ??
?? TITLE := '  dmp$close_dat_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$close_dat_r3
    (    p_dat: ^dmt$ms_device_allocation_table;
     VAR status: ost$status);

    status.normal := TRUE;

    dmp$close_file (p_dat, status);
  PROCEND dmp$close_dat_r3;
?? TITLE := '  dmp$close_dfl_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$close_dfl_r3
    (    p_dfl: ^dmt$ms_device_file_list_table;
     VAR status: ost$status);

    status.normal := TRUE;

    dmp$close_file (p_dfl, status);
  PROCEND dmp$close_dfl_r3;
?? TITLE := '  dmp$close_directory_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$close_directory_r3
    (    p_directory: ^dmt$ms_volume_directory;
     VAR status: ost$status);

    status.normal := TRUE;

    dmp$close_file (p_directory, status);
  PROCEND dmp$close_directory_r3;
?? TITLE := ' dmp$close_label_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$close_label_r3
    (    p_label: ^dmt$ms_volume_label;
     VAR status: ost$status);

    status.normal := TRUE;

    dmp$close_file (p_label, status);

  PROCEND dmp$close_label_r3;
?? TITLE := ' dmp$close_log_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$close_log_r3
    (    p_log: ^SEQ ( * );
     VAR status: ost$status);

    status.normal := TRUE;

    dmp$close_file (p_log, status);
  PROCEND dmp$close_log_r3;
?? TITLE := '  dmp$close_login_table_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$close_login_table_r3
    (    p_login_table: ^dmt$ms_mainframe_login_table;
     VAR status: ost$status);

    status.normal := TRUE;

    dmp$close_file (p_login_table, status);
  PROCEND dmp$close_login_table_r3;
?? TITLE := '  dmp$open_dat_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$open_dat_r3
    (    recorded_vsn: rmt$recorded_vsn;
     VAR p_dat: ^dmt$ms_device_allocation_table;
     VAR status: ost$status);

    VAR
      dat_sfid: dmt$system_file_id;

    status.normal := TRUE;

    retrieve_file_sfid (recorded_vsn, dmc$ms_device_allocation_table, dat_sfid, status);
    IF status.normal THEN
      dmp$open_dat (dat_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_read,
         mmc$as_sequential, p_dat, status);
    IFEND;
  PROCEND dmp$open_dat_r3;
?? TITLE := '  dmp$open_dfl_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$open_dfl_r3
    (    recorded_vsn: rmt$recorded_vsn;
     VAR p_dfl: ^dmt$ms_device_file_list_table;
     VAR status: ost$status);

    VAR
      dfl_sfid: dmt$system_file_id;

    status.normal := TRUE;

    retrieve_file_sfid (recorded_vsn, dmc$ms_device_file_list_table, dfl_sfid, status);
    IF status.normal THEN
      dmp$open_dflt (dfl_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_read, mmc$as_sequential, p_dfl, status);
    IFEND;
  PROCEND dmp$open_dfl_r3;
?? TITLE := '  dmp$open_directory_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$open_directory_r3
    (    recorded_vsn: rmt$recorded_vsn;
     VAR p_directory: ^dmt$ms_volume_directory;
     VAR status: ost$status);

    VAR
      directory_sfid: dmt$system_file_id;

    status.normal := TRUE;

    retrieve_file_sfid (recorded_vsn, dmc$ms_volume_directory, directory_sfid, status);
    IF status.normal THEN
      dmp$open_directory (directory_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_read,
         mmc$as_sequential, p_directory, status);
    IFEND;
  PROCEND dmp$open_directory_r3;
?? TITLE := '  dmp$open_label_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$open_label_r3
    (    recorded_vsn: rmt$recorded_vsn;
     VAR p_label: ^dmt$ms_volume_label;
     VAR status: ost$status);

    VAR
      system_file_id: dmt$system_file_id,
      user_supplied_name: ost$name;

    status.normal := TRUE;

    validate_recorded_vsn (recorded_vsn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    user_supplied_name := osc$null_name;
    user_supplied_name (1, 5) := 'LABEL';
    user_supplied_name (6, rmc$recorded_vsn_size) := recorded_vsn;

    dmp$attach_device_file (recorded_vsn, user_supplied_name, system_file_id, status);
    IF status.normal THEN
      dmp$open_label (system_file_id, osc$os_ring_1, osc$tsrv_ring, mmc$sar_read,
         mmc$as_sequential, p_label, status);
    IFEND;

  PROCEND dmp$open_label_r3;
?? TITLE := '  dmp$open_log_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$open_log_r3
    (    recorded_vsn: rmt$recorded_vsn;
     VAR p_log: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      active: boolean,
      attributes: array [1 .. 2] of dmt$assigned_ms_vol_attribute,
      length: integer,
      p_attributes: ^array [*] of dmt$assigned_ms_vol_attribute,
      segment_pointer: mmt$segment_pointer,
      sfid: dmt$system_file_id;

    status.normal := TRUE;

    attributes [1].keyword := dmc$ms_device_log;
    attributes [2].keyword := dmc$ms_current_log_position;
    p_attributes := ^attributes;

    dmp$get_active_vol_attributes (recorded_vsn, 0 {avt_index}, p_attributes, active);

    IF active THEN
      sfid := attributes [1].p_dlog;
      length := attributes [2].current_log_position + 1;
      segment_pointer.kind := mmc$sequence_pointer;
      dmp$open_file (sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_read, mmc$as_sequential, segment_pointer,
            status);
      IF status.normal THEN
        RESET segment_pointer.seq_pointer;
        NEXT p_log: [[REP length of cell]] IN segment_pointer.seq_pointer;
      IFEND;
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
            'Unable to find recorded vsn in active_volume_table.', status);
    IFEND;
  PROCEND dmp$open_log_r3;
?? TITLE := '  dmp$open_login_table_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$open_login_table_r3
    (    recorded_vsn: rmt$recorded_vsn;
     VAR p_login_table: ^dmt$ms_mainframe_login_table;
     VAR status: ost$status);

    VAR
      login_table_sfid: dmt$system_file_id;

    status.normal := TRUE;

    retrieve_file_sfid (recorded_vsn, dmc$ms_volume_login_table, login_table_sfid, status);
    IF status.normal THEN
      dmp$open_login_table (login_table_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_read,
         mmc$as_sequential, p_login_table, status);
    IFEND;
  PROCEND dmp$open_login_table_r3;
?? TITLE := '  retrieve_file_sfid', EJECT ??

  PROCEDURE retrieve_file_sfid
    (    recorded_vsn: rmt$recorded_vsn;
         file_keyword: dmt$assigned_ms_volume_keywords;
     VAR file_sfid: dmt$system_file_id;
     VAR status: ost$status);

    VAR
      volume_active: boolean,
      p_active_vol_attributes: ^array [ * ] of dmt$assigned_ms_vol_attribute,
      avt_index: dmt$active_volume_table_index;

    status.normal := TRUE;

    PUSH p_active_vol_attributes: [1 .. 1];
    IF p_active_vol_attributes = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$push_fail, '', status);
      RETURN;
    IFEND;

    p_active_vol_attributes^ [1].keyword := file_keyword;
    avt_index := 0;

    dmp$get_active_vol_attributes (recorded_vsn, avt_index, p_active_vol_attributes, volume_active);
    IF NOT volume_active THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
        'unable to locate avt entry - DMMDIS1', status);
      RETURN;
    IFEND;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE file_keyword OF
    = dmc$ms_device_file_list_table =
      file_sfid := p_active_vol_attributes^ [1].p_dflt;
    = dmc$ms_volume_directory =
      file_sfid := p_active_vol_attributes^ [1].directory_sfid;
    = dmc$ms_device_allocation_table =
      file_sfid := p_active_vol_attributes^ [1].p_dat;
    = dmc$ms_volume_login_table =
      file_sfid := p_active_vol_attributes^ [1].p_vlgt;
    ELSE
      ;
    CASEND;

  PROCEND retrieve_file_sfid;

?? TITLE := '  validate_recorded_vsn', EJECT ??

  PROCEDURE validate_recorded_vsn
    (    recorded_vsn: rmt$recorded_vsn;
     VAR status: ost$status);

    VAR
      search_key: dmt$avt_search_key,
      avt_index: dmt$active_volume_table_index,
      entry_not_found: boolean;

{  the purpose of this procedure is to verify that a specified recorded vsn actually
{  exists on the system

    avt_index := 0;
    search_key.value := dmc$search_avt_by_rec_vsn;
    search_key.recorded_vsn := recorded_vsn;

    dmp$search_active_volume_table (search_key, avt_index, entry_not_found);

    IF entry_not_found THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
         'unable to find recorded vsn in active_volume_table', status);
    IFEND;

  PROCEND validate_recorded_vsn;
MODEND dmm$access_volume_device_files;
*DECK DECK=DMM$ACTIVATE_VOLUME EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??
MODULE dmm$activate_volume;

{ PURPOSE:
{  The purpose of this module is to complete the introduction of a device
{  to the system.  The mainframe is logged into the device, and space is
{  allocated to the mainframe for allocation.

?? PUSH (LISTEXT := ON) ??
?? TITLE := '  Common Decks', EJECT ??
*copyc dmp$add_class_to_volume
*copyc dmp$attach_device_file
*copyc dmp$clear_update_lock
*copyc dmp$close_file
*copyc dmp$create_device_file
*copyc dmp$create_file_entry
*copyc dmp$destroy_file
*copyc dmp$detach_device_file
*copyc dmp$evacuate_active_device_log
*copyc dmp$get_mat_pointer
*copyc dmp$initialize_device_log
*copyc dmp$lock_avt_entry
*copyc dmp$open_dat
*copyc dmp$open_dflt
*copyc dmp$open_login_table
*copyc dmp$process_sc_flaw_commands
*copyc dmp$search_active_volume_table
*copyc dmp$set_update_lock
*copyc dmp$unlock_avt_entry
*copyc dmp$volume_space_manager
*copyc dmt$active_volume_table_index
*copyc dmt$dat_return_option
*copyc dmt$device_file_list_index
*copyc dmt$device_log_entries
*copyc dmt$error_condition_codes
*copyc dmt$keypoint_calls
*copyc dmt$mat_change_request
*copyc dmt$mat_converter
*copyc dmt$ms_device_allocation_table
*copyc dmv$active_volume_table
*copyc dmv$idle_system
*copyc dmv$null_sfid
*copyc i#call_monitor
*copyc mme$condition_codes
*copyc mmp$write_modified_pages
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc osv$recover_system_set_phase
*copyc pmp$get_processor_attributes
*copyc pmp$zero_out_table
*copyc sft$file_space_limit_kind
*copyc stp$disk_volume_active
*copyc syp$continue_to_cause
*copyc syp$disestablish_cond_handler
*copyc syp$establish_condition_handler
*copyc syp$process_deadstart_status
*copyc syv$job_recovery_option
?? POP ??
?? TITLE := '  Global Definitions', EJECT ??

  VAR
    dmv$volume_class_kludge: [XREF] boolean,
    v$production_log_name: [STATIC, READ] ost$name := 'DMF$DEVICE_LOG',
    v$recovery_log_name: [STATIC, READ] ost$name := 'DMF$DUMMY_DEVICE_LOG';
?? TITLE := '  dmp$activate_volume', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$activate_volume (logical_unit_number: iot$logical_unit;
                                           VAR status: ost$status);

    VAR
      full_update: boolean,
      able: boolean,
      search_key: dmt$avt_search_key,
      avt_index: dmt$active_volume_table_index,
      avt_entry_not_found: boolean,
      recorded_vsn: rmt$recorded_vsn,
      internal_vsn: dmt$internal_vsn,
      set_name: stt$set_name;

    #INLINE ('keypoint', osk$entry, osk$m * logical_unit_number, dmk$activate_volume);

    status.normal := TRUE;

    search_key.value := dmc$search_avt_by_lun;
    search_key.logical_unit_number := logical_unit_number;

    dmp$search_active_volume_table (search_key, avt_index, avt_entry_not_found);
    IF avt_entry_not_found THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_not_online, 'dmp$activate_volume',
            status);
      RETURN;
    IFEND;

    dmp$lock_avt_entry (avt_index, able);
    IF able THEN
      dmp$process_sc_flaw_commands (avt_index,
         dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_allocation_table,
           dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn,  status);
      login_to_volume (avt_index, status);
      IF status.normal THEN
        recorded_vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;
        internal_vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.internal_vsn;
        dmv$p_active_volume_table^ [avt_index].mass_storage.disk_table_status := dmv$p_active_volume_table^
            [avt_index].mass_storage.disk_table_status + $dmt$ms_volume_table_status
            [dmc$dflt_update_required];
        dmv$p_active_volume_table^ [avt_index].mass_storage.status := dmv$p_active_volume_table^ [avt_index].
            mass_storage.status + $dmt$ms_volume_system_status [dmc$mainframe_mounted];
        dmv$p_active_volume_table^ [avt_index].mass_storage.status := dmv$p_active_volume_table^ [avt_index].
            mass_storage.status - $dmt$ms_volume_system_status [dmc$mainframe_dismounted];
        dmv$p_active_volume_table^ [avt_index].mass_storage.allocation_allowed := TRUE;
      IFEND;
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_lock_avt_entry,
        'unable to lock avt entry - dmp$activate_volume', status);
    IFEND;

    IF able THEN
      dmp$unlock_avt_entry (avt_index, able);
      IF (NOT able) AND status.normal THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_clear_avt_lock,
          'unable to unlock avt entry - dmp$activate_volume', status);
      IFEND;
    IFEND;

    IF status.normal THEN
      IF NOT dmv$p_active_volume_table^ [avt_index].mass_storage.logged_in_for_recovery THEN
        end_recovery_allocation (avt_index);
      IFEND;

      full_update := TRUE;
      dmp$volume_space_manager (avt_index, full_update, status);
    IFEND;

    #INLINE ('keypoint', osk$debug, osk$m * (256 * ORD (recorded_vsn (1, 1)) + ORD (recorded_vsn (2, 1))),
            dmk$activate_volume_for_sets);
    #INLINE ('keypoint', osk$data, 256 * 256 * 256 * ORD (recorded_vsn (3, 1)) + 256 * 256 * ORD
            (recorded_vsn (4, 1)) + 256 * ORD (recorded_vsn (5, 1)) + ORD (recorded_vsn (6, 1)), 0);

    IF status.normal THEN
      IF NOT dmv$idle_system THEN
        stp$disk_volume_active (recorded_vsn, internal_vsn, avt_index, set_name, status);
        dmv$p_active_volume_table^ [avt_index].mass_storage.set_name := set_name;
      IFEND;
    IFEND;

    #INLINE ('keypoint', osk$exit, 0, dmk$activate_volume);

    IF dmv$volume_class_kludge THEN
      dmp$add_class_to_volume (avt_index, -$dmt$class [], status);
    IFEND;

  PROCEND dmp$activate_volume;
?? TITLE := '  dmp$deactivate_volume', EJECT ??

  PROCEDURE [XDCL] dmp$deactivate_volume (avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      mat_converter: dmt$mat_converter,
      p_login_table: ^dmt$ms_mainframe_login_table,
      mainframe_assigned: dmt$mainframe_assigned,
      login_index: dmt$login_table_entry_index,
      recorded_vsn: rmt$recorded_vsn,
      close_status: ost$status;

    dmp$open_login_table (dmv$p_active_volume_table^ [avt_index].mass_storage.p_login_table,
          osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential, p_login_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mainframe_assigned := dmv$p_active_volume_table^ [avt_index].mass_storage.mainframe_assigned;
    login_index := mainframe_assigned.log_in_index;

    IF (p_login_table^.body [login_index].login_status = dmc$lt_mf_logged_in) AND (mainframe_assigned =
          p_login_table^.body [login_index].mainframe_assigned) THEN
      dmp$evacuate_active_device_log (avt_index, status);
    ELSE
      recorded_vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;
      osp$set_status_abnormal (dmc$device_manager_ident, dme$mainframe_not_logged_in, recorded_vsn, status);
    IFEND;

    IF status.normal THEN
      dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log := dmv$null_sfid;
      dmv$p_active_volume_table^ [avt_index].mass_storage.allocation_allowed := FALSE;

      p_login_table^.body [login_index].login_status := dmc$lt_entry_available;

      mmp$write_modified_pages (p_login_table, #SIZE (p_login_table^), osc$wait, status);
    IFEND;

    dmp$close_file (p_login_table, close_status);
    IF status.normal AND NOT close_status.normal THEN
      status := close_status;
    IFEND;

    IF status.normal THEN
      dmp$get_mat_pointer (avt_index, mat_converter.p_mat);
      dmp$return_mat_space (mat_converter.p_adaptable, mainframe_assigned, avt_index);
    IFEND;
  PROCEND dmp$deactivate_volume;
?? TITLE := '  dmp$logout_recovered_mainframe', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$logout_recovered_mainframe (avt_index: dmt$active_volume_table_index;
        lt_entry_index: dmt$login_table_entries;
    VAR status: ost$status);

    VAR
      p_login_table: ^dmt$ms_mainframe_login_table,
      local_status: ost$status;

    status.normal := TRUE;

    dmp$open_login_table (dmv$p_active_volume_table^ [avt_index].mass_storage.p_login_table,
       osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential, p_login_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    free_lt_entry (p_login_table, lt_entry_index, avt_index, status);

    dmp$close_file (p_login_table, local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND dmp$logout_recovered_mainframe;
?? TITLE := '  dmp$return_dat_entries', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$return_dat_entries (mainframe_assigned: dmt$mainframe_assigned;
        avt_index: dmt$active_volume_table_index;
        return_option: dmt$dat_return_option;
    VAR status: ost$status);

    VAR
      p_dat: ^dmt$ms_device_allocation_table,
      dau_index: dmt$dau_address,
      able: boolean,
      number_of_usable_daus: dmt$dau_address,
      mat_change_request: dmt$mat_change_request,
      close_status: ost$status;

?? SKIP := 3 ??
    PROCEDURE dat_condition_handler (mf: ost$monitor_fault;
                                     p_msa: ^ost$minimum_save_area;
                                 VAR continue: syt$continue_option);
      VAR
        str: string (70),
        strl: integer,
        rvsn: rmt$recorded_vsn,
        p_sac: ^mmt$segment_access_condition,
        p_scc: ^syt$system_core_condition;

      IF mf.identifier = mmc$segment_fault_processor_id THEN
        p_sac := #LOC(mf.contents);
        CASE p_sac^.identifier OF
        = mmc$sac_io_read_error =
          rvsn := dmv$p_active_volume_table^[avt_index].mass_storage.recorded_vsn;
          STRINGREP (str, strl, 'I/O error on system table -DAT- ', rvsn, ' - dmp$return_dat_entries');
          osp$set_status_abnormal ('MM', mme$io_read_error, str (1, strl), status);
          dmp$clear_update_lock (avt_index);
          dmp$close_file (p_dat, close_status);
          EXIT dmp$return_dat_entries;
        ELSE
        CASEND;
      ELSEIF mf.identifier = syc$system_core_condition THEN
        p_scc := #LOC(mf.system_core_condition);
        CASE p_scc^.condition OF
        = syc$user_defined_condition =
          IF p_scc^.user_defined_condition = syc$udc_volume_unavailable THEN
            rvsn := dmv$p_active_volume_table^[avt_index].mass_storage.recorded_vsn;
            STRINGREP (str, strl, 'Volume unavailable ', rvsn, ' - dmp$return_dat_entries');
            osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable,
                    str (1, strl), status);
            dmp$clear_update_lock (avt_index);
            dmp$close_file (p_dat, close_status);
            EXIT dmp$return_dat_entries;
          IFEND;
        ELSE
        CASEND;
      IFEND;

      syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);

    PROCEND dat_condition_handler;
?? SKIP := 3 ??

    status.normal := TRUE;

    dmp$open_dat (dmv$p_active_volume_table^ [avt_index].mass_storage.
          p_device_allocation_table, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend,
          mmc$as_sequential, p_dat, status);
    IF status.normal THEN
      dmp$set_update_lock (avt_index, TRUE, able);
      IF able THEN
        syp$establish_condition_handler (^dat_condition_handler);
        number_of_usable_daus := 0;

        FOR dau_index := 0 TO UPPERBOUND (p_dat^.body) DO
          CASE p_dat^.body [dau_index].dau_status OF
            = dmc$dau_usable =
              number_of_usable_daus := number_of_usable_daus + 1;
            = dmc$dau_assigned_to_mainframe =
              IF return_option = dmc$return_specific_entry THEN
                IF p_dat^.body [dau_index].mainframe_id = mainframe_assigned THEN
                  p_dat^.body [dau_index].dau_status := dmc$dau_usable;
                  number_of_usable_daus := number_of_usable_daus + 1;
                IFEND;
              ELSE
                {Return all EXCEPT mfid specified and the current mfid
                IF (p_dat^.body [dau_index].mainframe_id <> mainframe_assigned) AND
                    (p_dat^.body [dau_index].mainframe_id <> dmv$p_active_volume_table^
                     [avt_index].mass_storage.mainframe_assigned) THEN
                  p_dat^.body [dau_index].dau_status := dmc$dau_usable;
                  number_of_usable_daus := number_of_usable_daus + 1;
                IFEND;
              IFEND;
            = dmc$dau_ass_to_mf_swr_flawed =
              IF p_dat^.body [dau_index].mainframe_id = mainframe_assigned THEN
                p_dat^.body [dau_index].dau_status := dmc$dau_software_flawed;
              IFEND;
          ELSE
          CASEND;
        FOREND;

        p_dat^.header.available := number_of_usable_daus;

        { Tell monitor to update "available_dat_space" in the MAT.

        mat_change_request.request_code := syc$rc_apply_mat_changes;
        mat_change_request.avt_index := avt_index;
        mat_change_request.mat_change_type := dmc$add_mat_space;
        mat_change_request.mat_change_count := 0;
        mat_change_request.p_mat_changes := NIL;
        mat_change_request.available_dat_space := number_of_usable_daus;

        i#call_monitor (^mat_change_request, #SIZE (mat_change_request));

        syp$disestablish_cond_handler;

        dmp$clear_update_lock (avt_index);
        mmp$write_modified_pages (p_dat, #SIZE (p_dat^), osc$wait, status);
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_lock_dat,
          'unable to lock dat - dmp$return_dat_entries', status);
      IFEND;

      dmp$close_file (p_dat, close_status);
      IF status.normal AND (NOT close_status.normal) THEN
        status := close_status;
      IFEND;
    IFEND;

  PROCEND dmp$return_dat_entries;
?? TITLE := '  dmp$return_dfl_entries', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$return_dfl_entries (mainframe_assigned: dmt$mainframe_assigned;
        avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      p_dflt: ^dmt$ms_device_file_list_table,
      dfl_index: dmt$device_file_list_index,
      able: boolean,
      close_status: ost$status;

?? SKIP := 3 ??
    PROCEDURE dfl_condition_handler (mf: ost$monitor_fault;
                                     p_msa: ^ost$minimum_save_area;
                                 VAR continue: syt$continue_option);
      VAR
        str: string (70),
        strl: integer,
        rvsn: rmt$recorded_vsn,
        p_sac: ^mmt$segment_access_condition;

      IF mf.identifier = mmc$segment_fault_processor_id THEN
        p_sac := #LOC(mf.contents);
        CASE p_sac^.identifier OF
        = mmc$sac_io_read_error =
          rvsn := dmv$p_active_volume_table^[avt_index].mass_storage.recorded_vsn;
          STRINGREP (str, strl, 'I/O error on system table -DFL- ', rvsn, ' - dmp$return_dfl_entries');
          osp$set_status_abnormal ('MM', mme$io_read_error, str (1, strl), status);
          dmp$clear_update_lock (avt_index);
          dmp$close_file (p_dflt, close_status);
          EXIT dmp$return_dfl_entries;
        ELSE
        CASEND;
      IFEND;

      syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);

    PROCEND dfl_condition_handler;
?? SKIP := 3 ??

    status.normal := TRUE;

    dmp$open_dflt (dmv$p_active_volume_table^ [avt_index].mass_storage.
          p_device_file_list_table, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend,
          mmc$as_sequential, p_dflt, status);
    IF status.normal THEN
      dmp$set_update_lock (avt_index, TRUE, able);
      IF able THEN

        syp$establish_condition_handler (^dfl_condition_handler);

        FOR dfl_index := 1 TO UPPERBOUND (p_dflt^.entries) DO
          IF p_dflt^.entries [dfl_index].flags = dmc$dfle_assigned_to_mainframe THEN
            IF p_dflt^.entries [dfl_index].mainframe_assigned = mainframe_assigned THEN
              p_dflt^.entries [dfl_index].flags := dmc$dfle_available;
            IFEND;
          IFEND;
        FOREND;

        syp$disestablish_cond_handler;

        dmp$clear_update_lock (avt_index);
        mmp$write_modified_pages (p_dflt, #SIZE (p_dflt^), osc$wait, status);
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_lock_dflt,
          'unable to lock dflt - dmp$return_dfl_entries', status);
      IFEND;

      dmp$close_file (p_dflt, close_status);
      IF status.normal AND (NOT close_status.normal) THEN
        status := close_status;
      IFEND;
    IFEND;

  PROCEND dmp$return_dfl_entries;
?? TITLE := '  dmp$return_mat_space', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$return_mat_space (mat_pointer: cyt$adaptable_array_pointer;
        mainframe_assigned: dmt$mainframe_assigned;
        avt_index: dmt$active_volume_table_index);

    TYPE
      t$daus_converter = record
        case boolean of
        = FALSE =
          p_adaptable: cyt$adaptable_array_pointer,
        = TRUE =
          p_available_daus: ^dmt$available_daus,
        casend,
      recend;

    VAR
      segment: ost$segment,
      p_mat: ^dmt$mainframe_allocation_table,
      mat_converter: dmt$mat_converter,
      current_mat_pointer: cyt$adaptable_array_pointer,
      daus_converter: t$daus_converter,
      daus_pointer: cyt$adaptable_array_pointer,
      current_daus_pointer: cyt$adaptable_array_pointer,
      p_available_daus: ^dmt$available_daus,
      active_mat: boolean,
      good_mat: boolean,
      p_dat: ^dmt$ms_device_allocation_table,
      dau: dmt$dau_address,
      able: boolean,
      returned_daus: dmt$dau_address,
      mat_change_request: dmt$mat_change_request,
      allocation_style: dmt$allocation_styles,
      position: dmt$device_position,
      status: ost$status;

    segment := #segment (mat_pointer.pointer);
    mat_converter.p_adaptable := mat_pointer;
    mat_converter.p_adaptable.pointer := #address (1, segment, #offset (mat_converter.p_adaptable.pointer));
    p_mat := mat_converter.p_mat;

    daus_converter.p_available_daus := p_mat^.p_available_daus;
    daus_converter.p_adaptable.pointer := #address (1, segment, #offset (daus_converter.p_adaptable.pointer));
    daus_pointer := daus_converter.p_adaptable;
    p_available_daus := daus_converter.p_available_daus;

    dmp$get_mat_pointer (avt_index, mat_converter.p_mat);
    active_mat := (p_mat = mat_converter.p_mat);
    current_mat_pointer := mat_converter.p_adaptable;
    daus_converter.p_available_daus := mat_converter.p_mat^.p_available_daus;
    current_daus_pointer := daus_converter.p_adaptable;

    good_mat := (mat_pointer.array_size = current_mat_pointer.array_size) AND
                (mat_pointer.lower_bound = current_mat_pointer.lower_bound) AND
                (mat_pointer.element_size = current_mat_pointer.element_size) AND
                (daus_pointer.array_size = current_daus_pointer.array_size) AND
                (daus_pointer.lower_bound = current_daus_pointer.lower_bound) AND
                (daus_pointer.element_size = current_daus_pointer.element_size);

    IF NOT good_mat THEN
      RETURN;
    IFEND;

    dmp$open_dat (dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_allocation_table,
          osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential, p_dat, status);

    IF status.normal THEN
      dmp$set_update_lock (avt_index, TRUE, able);

      IF able THEN
        returned_daus := 0;
        FOR dau := LOWERBOUND (p_dat^.body) TO UPPERBOUND (p_dat^.body) DO
          IF p_available_daus^ [dau] THEN
            IF (p_dat^.body [dau].dau_status = dmc$dau_assigned_to_mainframe) THEN
              IF (p_dat^.body [dau].mainframe_id = mainframe_assigned) THEN
                p_dat^.body [dau].dau_status := dmc$dau_usable;
                returned_daus := returned_daus + 1;
              IFEND;
            ELSEIF (p_dat^.body [dau].dau_status = dmc$dau_ass_to_mf_swr_flawed) THEN
              IF (p_dat^.body [dau].mainframe_id = mainframe_assigned) THEN
                p_dat^.body [dau].dau_status := dmc$dau_software_flawed;
              IFEND;
            IFEND;
          IFEND;
        FOREND;

        p_dat^.header.available := p_dat^.header.available + returned_daus;

        IF active_mat THEN
          FOR allocation_style := LOWERVALUE (allocation_style) TO UPPERVALUE (allocation_style) DO
            p_mat^.available_allocation_units [allocation_style] := 0;
            p_mat^.allocation_chains [allocation_style] := dmc$nil_position_link;
          FOREND;

          p_mat^.available_dat_space := p_mat^.available_dat_space + p_mat^.available_space +
                p_mat^.leftover_space;
          p_mat^.available_space := 0;
          p_mat^.leftover_space := 0;

          FOR dau := LOWERBOUND (p_available_daus^) TO UPPERBOUND (p_available_daus^) DO
            p_available_daus^ [dau] := FALSE;
          FOREND;

          FOR position := LOWERBOUND (p_mat^.mat_entries) TO UPPERBOUND (p_mat^.mat_entries) DO
            p_mat^.mat_entries [position].available_allocation_units := 0;
            p_mat^.mat_entries [position].backward_link := dmc$nil_position_link;
            p_mat^.mat_entries [position].forward_link := dmc$nil_position_link;
          FOREND;
        ELSE

          { Tell monitor to update "available_dat_space" in the MAT.

          mat_change_request.request_code := syc$rc_apply_mat_changes;
          mat_change_request.avt_index := avt_index;
          mat_change_request.mat_change_type := dmc$add_mat_space;
          mat_change_request.mat_change_count := 0;
          mat_change_request.p_mat_changes := NIL;
          mat_change_request.available_dat_space := p_dat^.header.available;

          i#call_monitor (^mat_change_request, #SIZE (mat_change_request));
        IFEND;

        dmp$clear_update_lock (avt_index);

        mmp$write_modified_pages (p_dat, #SIZE (p_dat^), osc$wait, status);
      IFEND;

      dmp$close_file (p_dat, status);
    IFEND;
  PROCEND dmp$return_mat_space;
?? TITLE := '  dmp$search_login_table', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$search_login_table (p_login_table: ^dmt$ms_mainframe_login_table;
        login_entry_type: dmt$login_entry_type;
    VAR lt_entry_index: dmt$login_table_entries);

    VAR
      found: boolean,
      entry_index: dmt$login_table_entry_index;

    lt_entry_index := 0;

    IF (login_entry_type = dmc$free_login_entry) THEN
      FOR entry_index := 1 TO UPPERBOUND (p_login_table^.body) DO
        IF p_login_table^.body [entry_index].login_status = dmc$lt_entry_available THEN
          lt_entry_index := entry_index;
          RETURN;
        IFEND;
      FOREND;
    ELSE
      FOR entry_index := 1 TO UPPERBOUND (p_login_table^.body) DO
        IF (p_login_table^.body [entry_index].login_status <> dmc$lt_entry_available) THEN
          found := ((p_login_table^.body [entry_index].recovery_status = dmc$lt_recovering) AND
                (login_entry_type = dmc$recovery_login_entry)) OR
                ((p_login_table^.body [entry_index].recovery_status <> dmc$lt_recovering) AND
                (login_entry_type = dmc$production_login_entry));
          IF found THEN
            lt_entry_index := entry_index;
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND dmp$search_login_table;
?? TITLE := '  dmp$start_volume_production', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$start_volume_production (
        avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      production_log_name: ost$name,
      production_log_sfid: dmt$system_file_id,
      recovery_log_sfid: dmt$system_file_id,
      avt_locked: boolean,
      avt_unlocked: boolean,
      p_login_table: ^dmt$ms_mainframe_login_table,
      login_index: dmt$login_table_entry_index,
      local_status: ost$status;

    login_index := dmv$p_active_volume_table^ [avt_index].mass_storage.mainframe_assigned.log_in_index;

    dmp$open_login_table (dmv$p_active_volume_table^ [avt_index].mass_storage.p_login_table, osc$os_ring_1,
          osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential, p_login_table, status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (p_login_table^.body [login_index].recovery_status <> dmc$lt_recovering) THEN
      dmp$close_file (p_login_table, status);
      RETURN;
    IFEND;

    production_log_name := v$production_log_name;
    establish_device_log (avt_index, production_log_name, production_log_sfid, status);

    IF status.normal THEN
      dmp$evacuate_active_device_log (avt_index, status);
    IFEND;

    avt_locked := FALSE;
    IF status.normal THEN
      dmp$lock_avt_entry (avt_index, avt_locked);
      IF NOT avt_locked THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_lock_avt_entry,
              'Unable to lock AVT entry - dmp$start_volume_production.', status);
      IFEND;
    IFEND;

    IF status.normal THEN
      recovery_log_sfid := dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log;
      dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log := dmv$null_sfid;
      dmv$p_active_volume_table^ [avt_index].mass_storage.logged_in_for_recovery := FALSE;
      p_login_table^.body [login_index].device_log_name := production_log_name;
      p_login_table^.body [login_index].last_last_update_offset := 0;
      p_login_table^.body [login_index].last_update_offset := 0;
      p_login_table^.body [login_index].current_position_offset := 0;
      p_login_table^.body [login_index].recovery_status := dmc$lt_normal_status;
    IFEND;

    dmp$close_file (p_login_table, local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

    IF status.normal THEN
      dmp$initialize_device_log (production_log_sfid, avt_index, status);
    IFEND;

    IF avt_locked THEN
      dmp$unlock_avt_entry (avt_index, avt_unlocked);
      IF NOT avt_unlocked AND status.normal THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_clear_avt_lock,
              'Unable to clear AVT lock - dmp$start_volume_production.', status);
      IFEND;
    IFEND;

    IF status.normal THEN
      dmp$destroy_file (recovery_log_sfid, sfc$no_limit, status);
    IFEND;

    IF status.normal THEN
      end_recovery_allocation (avt_index);
    IFEND;
  PROCEND dmp$start_volume_production;
?? TITLE := '  dmp$volume_is_active', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$volume_is_active (logical_unit_number: iot$logical_unit;
                                            VAR volume_active: boolean);

    VAR
      search_avt_key: dmt$avt_search_key,
      avt_index: dmt$active_volume_table_index,
      volume_not_active: boolean;

    avt_index := 0;
    volume_active := FALSE;
    search_avt_key.value := dmc$search_avt_by_lun;
    search_avt_key.logical_unit_number := logical_unit_number;

    dmp$search_active_volume_table (search_avt_key, avt_index, volume_not_active);
    IF volume_not_active THEN
      RETURN;
    IFEND;

    volume_active := dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log <> dmv$null_sfid;

  PROCEND dmp$volume_is_active;
?? TITLE := '  end_recovery_allocation', EJECT ??

  PROCEDURE end_recovery_allocation (avt_index: dmt$active_volume_table_index);

    VAR
      p_mat: ^dmt$mainframe_allocation_table,
      mat_change_request: dmt$mat_change_request;

    dmp$get_mat_pointer (avt_index, p_mat);

    mat_change_request.request_code := syc$rc_apply_mat_changes;
    mat_change_request.avt_index := avt_index;
    mat_change_request.mat_change_type := dmc$change_dat_threshold;
    mat_change_request.dat_threshold := p_mat^.recovery_threshold;

    i#call_monitor (^mat_change_request, #SIZE (mat_change_request));
  PROCEND end_recovery_allocation;
?? TITLE := '  establish_device_log', EJECT ??

  PROCEDURE establish_device_log (
        avt_index: dmt$active_volume_table_index;
        device_log_name: ost$name;
    VAR device_log_sfid: dmt$system_file_id;
    VAR status: ost$status);

    VAR
      vsn: rmt$recorded_vsn,
      p_mat: ^dmt$mainframe_allocation_table,
      attributes: array [1 .. 1] of dmt$new_device_file_attribute,
      device_log_length: amt$file_byte_address;

    vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;

    dmp$attach_device_file (vsn, device_log_name, device_log_sfid, status);

    IF NOT status.normal AND (status.condition = dme$unknown_device_file) THEN
      dmp$get_mat_pointer (avt_index, p_mat);

      { The device log length must be enough to purge a file as big as the device
      { plus a little to spare. AND DO THIS * 3 FOR SAFETY AND FUTURE GROWTH

      device_log_length := (p_mat^.daus_per_position * p_mat^.positions_per_device *
            (#SIZE (dmt$dl_return_dau_block) + #SIZE (dmt$dl_release_dau_block) +
            4 {entry kind and check bytes})) * 3;

      attributes [1].keyword := dmc$file_limit;
      attributes [1].limit := UPPERVALUE (attributes [1].limit);
      dmp$create_device_file (device_log_name, vsn, ^attributes, device_log_length, device_log_sfid, status);
    IFEND;
  PROCEND establish_device_log;
?? TITLE := '  free_lt_entry', EJECT ??

  PROCEDURE free_lt_entry (p_login_table: ^dmt$ms_mainframe_login_table;
        lt_entry_index: dmt$login_table_entry_index;
        avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    status.normal := TRUE;

    p_login_table^.body [lt_entry_index].login_status := dmc$lt_entry_available;

    mmp$write_modified_pages (p_login_table, #SIZE (p_login_table^), osc$wait, status);

  PROCEND free_lt_entry;
?? TITLE := '  initialize_lt_entry', EJECT ??

  PROCEDURE initialize_lt_entry (p_login_table: ^dmt$ms_mainframe_login_table;
        lt_entry_index: dmt$login_table_entry_index;
        login_sequence: dmt$login_table_sequence;
        avt_index: dmt$active_volume_table_index;
        recovery_status: dmt$login_table_recovery_status;
    VAR status: ost$status);

    VAR
      processor_attributes: pmt$processor_attributes,
      device_log_name: ost$name,
      global_file_name: dmt$global_file_name,
      system_file_id: dmt$system_file_id;

    pmp$get_processor_attributes (processor_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    system_file_id := dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log;
    device_log_name := v$production_log_name;
    IF (system_file_id = dmv$null_sfid) THEN
      IF recovery_status = dmc$lt_recovering THEN
        device_log_name := v$recovery_log_name;
        dmp$create_file_entry (gfc$fk_global_unnamed, - $pft$usage_selections [],
             - $pft$share_selections [], dmc$minimum_file_share_his, NIL, 0, FALSE,
             global_file_name, system_file_id, status);
      ELSE
        establish_device_log (avt_index, device_log_name, system_file_id, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    p_login_table^.body [lt_entry_index].mainframe_assigned.log_in_sequence := login_sequence;
    p_login_table^.body [lt_entry_index].mainframe_assigned.log_in_index := lt_entry_index;
    p_login_table^.body [lt_entry_index].mainframe_identification := processor_attributes;
    p_login_table^.body [lt_entry_index].avt_index := avt_index;
    p_login_table^.body [lt_entry_index].device_log_name := device_log_name;
    p_login_table^.body [lt_entry_index].last_last_update_offset := 0;
    p_login_table^.body [lt_entry_index].last_update_offset := 0;
    p_login_table^.body [lt_entry_index].current_position_offset := 0;
    p_login_table^.body [lt_entry_index].recovery_status := recovery_status;
    p_login_table^.body [lt_entry_index].login_status := dmc$lt_mf_logged_in; {must be last}

    mmp$write_modified_pages (p_login_table, #SIZE (p_login_table^), osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmv$p_active_volume_table^ [avt_index].mass_storage.mainframe_assigned := p_login_table^.body
          [lt_entry_index].mainframe_assigned;

    dmv$p_active_volume_table^ [avt_index].mass_storage.logged_in_for_recovery := (recovery_status =
          dmc$lt_recovering);

    dmp$initialize_device_log (system_file_id, avt_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND initialize_lt_entry;
?? TITLE := '  login_to_volume', EJECT ??

  PROCEDURE login_to_volume (avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      p_login_table: ^dmt$ms_mainframe_login_table,
      login_type: dmt$login_table_recovery_status,
      login_sequence: dmt$login_table_sequence,
      login_index: dmt$login_table_entries,
      retained_mainframe: dmt$mainframe_assigned,
      vsn: rmt$recorded_vsn,
      local_status: ost$status;

   { Open login table.

    dmp$open_login_table (dmv$p_active_volume_table^ [avt_index].mass_storage.p_login_table,
          osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential, p_login_table, status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;
    login_sequence := dmv$p_active_volume_table^ [avt_index].mass_storage.mainframe_assigned.log_in_sequence;
    login_index := dmv$p_active_volume_table^ [avt_index].mass_storage.mainframe_assigned.log_in_index;

    IF (login_sequence <> 0) THEN
      login_type := dmc$lt_normal_status;
      IF (p_login_table^.body [login_index].login_status <> dmc$lt_entry_available) THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_already_active, vsn, status);
      IFEND;
    ELSE
      { Clean up after any failed recovery attempts.

      dmp$search_login_table (p_login_table, dmc$recovery_login_entry, login_index);

      IF (login_index <> 0) THEN
        dmp$return_dat_entries (p_login_table^.body [login_index].mainframe_assigned, avt_index,
          dmc$return_specific_entry, status);

        IF status.normal THEN
          dmp$return_dfl_entries (p_login_table^.body [login_index].mainframe_assigned, avt_index, status);
        IFEND;

        IF status.normal THEN
          free_lt_entry (p_login_table, login_index, avt_index, status);
        IFEND;
      IFEND;

      { Determine if recovery is required.

      IF status.normal THEN
        dmp$search_login_table (p_login_table, dmc$production_login_entry, login_index);

        IF (login_index <> 0) THEN {recovery required}
          login_type := dmc$lt_recovering;
          retained_mainframe := p_login_table^.body [login_index].mainframe_assigned;
          IF (p_login_table^.body [login_index].recovery_status = dmc$lt_normal_status) THEN
            p_login_table^.body [login_index].recovery_status := dmc$lt_being_recovered;
            mmp$write_modified_pages (p_login_table, #SIZE (p_login_table^), osc$wait, status);
          IFEND;
        ELSE {no recovery required}
          login_type := dmc$lt_normal_status;
          retained_mainframe := dmv$p_active_volume_table^ [avt_index].mass_storage.mainframe_assigned;

          { Return DFL entries from any previous idle_system.

          IF status.normal THEN
            return_all_dfl_entries (avt_index, status);
          IFEND;
        IFEND;

        { If no job recovery - return unused DAT entries.

        IF status.normal AND (syv$job_recovery_option <> syc$jre_enabled) THEN
          dmp$return_dat_entries (retained_mainframe, avt_index, dmc$return_all_except_entry, status);
        IFEND;
      IFEND;

      { Locate free login table entry.

      IF status.normal THEN
        dmp$search_login_table (p_login_table, dmc$free_login_entry, login_index);
        IF (login_index = 0) THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$login_table_full, vsn, status);
        ELSE
          p_login_table^.header.sequence := p_login_table^.header.sequence + 1;
          login_sequence := p_login_table^.header.sequence;
        IFEND;
      IFEND;
    IFEND;

    { Login to volume.

    IF status.normal THEN
      initialize_lt_entry (p_login_table, login_index, login_sequence, avt_index, login_type, status);
    IFEND;

    { Close login table.

    dmp$close_file (p_login_table, local_status);

    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND login_to_volume;
?? TITLE :='  return_all_dfl_entries', EJECT??

  PROCEDURE return_all_dfl_entries (avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      p_dflt: ^dmt$ms_device_file_list_table,
      dfl_index: dmt$device_file_list_index,
      able: boolean,
      close_status: ost$status;

?? SKIP := 3 ??
    PROCEDURE dfl_condition_handler (mf: ost$monitor_fault;
                                     p_msa: ^ost$minimum_save_area;
                                 VAR continue: syt$continue_option);
      VAR
        str: string (70),
        strl: integer,
        rvsn: rmt$recorded_vsn,
        p_sac: ^mmt$segment_access_condition;

      IF mf.identifier = mmc$segment_fault_processor_id THEN
        p_sac := #LOC(mf.contents);
        CASE p_sac^.identifier OF
        = mmc$sac_io_read_error =
          rvsn := dmv$p_active_volume_table^[avt_index].mass_storage.recorded_vsn;
          STRINGREP (str, strl, 'I/O error on system table -DFL- ', rvsn, ' - return_all_dfl_entries');
          osp$set_status_abnormal ('MM', mme$io_read_error, str (1, strl), status);
          dmp$clear_update_lock (avt_index);
          dmp$close_file (p_dflt, close_status);
          EXIT return_all_dfl_entries;
        ELSE
        CASEND;
      IFEND;

      syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);

    PROCEND dfl_condition_handler;
?? SKIP := 3 ??

    status.normal := TRUE;

    dmp$open_dflt (dmv$p_active_volume_table^ [avt_index].mass_storage.
          p_device_file_list_table, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend,
          mmc$as_sequential, p_dflt, status);
    IF status.normal THEN
      dmp$set_update_lock (avt_index, TRUE, able);
      IF able THEN

        syp$establish_condition_handler (^dfl_condition_handler);

        FOR dfl_index := 1 TO UPPERBOUND (p_dflt^.entries) DO
          IF p_dflt^.entries [dfl_index].flags = dmc$dfle_assigned_to_mainframe THEN

            {! Return all entries not belonging to the current deadstart !!!!!

            IF p_dflt^.entries [dfl_index].mainframe_assigned <>
                dmv$p_active_volume_table^ [avt_index].mass_storage.mainframe_assigned THEN
              p_dflt^.entries [dfl_index].flags := dmc$dfle_available;
            IFEND;
          IFEND;
        FOREND;

        syp$disestablish_cond_handler;

        dmp$clear_update_lock (avt_index);
        mmp$write_modified_pages (p_dflt, #SIZE (p_dflt^), osc$wait, status);
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_lock_dflt,
           'unable to lock dflt - return_all_dfl_entries', status);
      IFEND;

      dmp$close_file (p_dflt, close_status);
      IF status.normal AND (NOT close_status.normal) THEN
        status := close_status;
      IFEND;
    IFEND;

  PROCEND return_all_dfl_entries;

MODEND dmm$activate_volume;
*DECK DECK=DMM$ALLOCATE_AVT EXPAND=TRUE
??RIGHT := 110??
*copyc osd$default_pragmats
??NEWTITLE:='NOS/VE Device Management'??
??NEWTITLE :='  Module Header'??
MODULE dmm$allocate_avt;
{
{
{
{
{
??TITLE:='  Declarations',EJECT??
??PUSH (LISTEXT:=ON)??
*copyc dmt$error_condition_codes
*copyc dmt$file_table_lock
?? POP ??
??TITLE:='  XREF Variables', EJECT??
??PUSH(LISTEXT:=ON)??
*copyc dmv$active_volume_table
*copyc osv$mainframe_wired_heap
??POP??
??TITLE :='  XREF Procedures',EJECT??
?? PUSH (LISTEXT := ON) ??
*copyc dmp$unlock_avt_entry
*copyc dmp$lock_avt_entry
??POP??
??TITLE :='  [XDCL] dmp$allocate_avt', EJECT??

  PROCEDURE [XDCL] dmp$allocate_avt (avt_count: integer;
    VAR allocate_ok: boolean);

    VAR
      lock_ok,
      lock_clear: boolean,
      free_ptr,
      temp_avt_ptr: ^dmt$active_volume_table,
      avt_limit: integer,
      avt_index: integer;

    allocate_ok := FALSE;

  /main_program/
    BEGIN

      avt_limit := UPPERBOUND (dmv$p_active_volume_table^);

      IF avt_count > avt_limit THEN

        ALLOCATE temp_avt_ptr: [1 .. avt_count] IN osv$mainframe_wired_heap^;

        {lock avt entries}

        FOR avt_index := 1 TO avt_limit DO
          REPEAT
            dmp$lock_avt_entry (avt_index, lock_ok);
          UNTIL lock_ok;
        FOREND;

        { Copy current entries to new array. }

        FOR avt_index := 1 TO avt_limit DO
          temp_avt_ptr^ [avt_index] := dmv$p_active_volume_table^ [avt_index];
        FOREND;

        { Initialize new entries. }

        FOR avt_index := avt_limit + 1 TO avt_count DO
          temp_avt_ptr^ [avt_index].entry_available := TRUE;
          temp_avt_ptr^ [avt_index].lock.status := ORD (dmc$unlocked);
          temp_avt_ptr^ [avt_index].logical_unit_number := 0;
        FOREND;

        free_ptr := dmv$p_active_volume_table;
        dmv$p_active_volume_table := temp_avt_ptr;
        FREE free_ptr IN osv$mainframe_wired_heap^;

        allocate_ok := TRUE;

    {unlock avt entries}

       FOR avt_index := 1 TO avt_limit DO
         REPEAT
           dmp$unlock_avt_entry (avt_index, lock_clear);
         UNTIL lock_clear;
       FOREND;
     ELSE
       allocate_ok := TRUE; { No need to allocate since this is the case of one disk.
     IFEND;

END /main_program/;

  PROCEND dmp$allocate_avt;

MODEND dmm$allocate_avt;
*DECK DECK=DMM$ANALYZE_DEVICE_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Device Mangement' ??
MODULE dmm$analyze_device_file;
{
{ This module is a command processor which can view user files as device management
{ tables and display information from them.
{ Most of the code in this and associated modules was stolen from the existing
{ device management utility.
{
?? PUSH (LISTEXT := ON) ??
*copyc amp$get_segment_pointer
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$end_scan_command_file
*copyc clp$get_path_description
*copyc clp$get_value
*copyc clp$new_display_line
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$new_display_page
*copyc clp$open_display
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$put_display
*copyc clp$put_display
*copyc clp$put_display
*copyc clp$put_job_output
*copyc clp$put_partial_display
*copyc clp$scan_command_file
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc dmt$device_file_list_index
*copyc dmt$device_position
*copyc dmt$directory_index
*copyc dmt$minimum_allocation_unit
*copyc dmt$ms_device_allocation_table
*copyc dmt$ms_device_file_list_entry
*copyc dmt$ms_volume_directory
*copyc dmt$stored_ms_fmd_header
*copyc fsp$close_file
*copyc fsp$open_file
*copyc iot$disk_type_table
*copyc osp$set_status_abnormal
*copyc pmp$convert_binary_unique_name
?? POP ??
?? TITLE := '  Command Table', EJECT ??
{ table command_table t=c s=local
{ command (convert_cts_to_dau, concts       ) convert_cts_to_dau_command      cm=local
{ command (display_allocation_chain, disac  ) display_alloc_chain_command     cm=local
{ command (display_cylinders, discyl        ) display_cylinders_command       cm=local
{ command (display_dat, disdat              ) display_dat_command             cm=local
{ command (display_dat_header, disdath      ) display_dat_header_command      cm=local
{ command (display_dau_entry, disdaue       ) display_dau_entry_command       cm=local
{ command (display_device_type, disdt       ) display_device_type_command     cm=local
{ command (display_dfl, disdfl              ) display_dfl_command             cm=local
{ command (display_dfl_entry, disdfle       ) display_dfl_entry_command       cm=local
{ command (display_directory, disdir        ) display_directory_command       cm=local
{ command (display_directory_entry, disdire ) display_directory_entry_command cm=local
{ command (sum_allocated_space, sumas       ) sum_allocated_space_command     cm=local
{ command (quit                             ) quit_command                    cm=local

?? PUSH (LISTEXT := ON) ??

VAR
  command_table: [STATIC, READ] ^clt$command_table := ^command_table_entries,

  command_table_entries: [STATIC, READ] array [1 .. 25] of clt$command_table_entry := [
  {} ['CONCTS                         ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^convert_cts_to_dau_command],
  {} ['CONVERT_CTS_TO_DAU             ', clc$nominal_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^convert_cts_to_dau_command],
  {} ['DISAC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^display_alloc_chain_command],
  {} ['DISCYL                         ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^display_cylinders_command],
  {} ['DISDAT                         ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^display_dat_command],
  {} ['DISDATH                        ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^display_dat_header_command],
  {} ['DISDAUE                        ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^display_dau_entry_command],
  {} ['DISDFL                         ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^display_dfl_command],
  {} ['DISDFLE                        ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^display_dfl_entry_command],
  {} ['DISDIR                         ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^display_directory_command],
  {} ['DISDIRE                        ', clc$abbreviation_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^display_directory_entry_command],
  {} ['DISDT                          ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^display_device_type_command],
  {} ['DISPLAY_ALLOCATION_CHAIN       ', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^display_alloc_chain_command],
  {} ['DISPLAY_CYLINDERS              ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^display_cylinders_command],
  {} ['DISPLAY_DAT                    ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^display_dat_command],
  {} ['DISPLAY_DAT_HEADER             ', clc$nominal_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^display_dat_header_command],
  {} ['DISPLAY_DAU_ENTRY              ', clc$nominal_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^display_dau_entry_command],
  {} ['DISPLAY_DEVICE_TYPE            ', clc$nominal_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^display_device_type_command],
  {} ['DISPLAY_DFL                    ', clc$nominal_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^display_dfl_command],
  {} ['DISPLAY_DFL_ENTRY              ', clc$nominal_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^display_dfl_entry_command],
  {} ['DISPLAY_DIRECTORY              ', clc$nominal_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^display_directory_command],
  {} ['DISPLAY_DIRECTORY_ENTRY        ', clc$nominal_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^display_directory_entry_command],
  {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^quit_command],
  {} ['SUMAS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^sum_allocated_space_command],
  {} ['SUM_ALLOCATED_SPACE            ', clc$nominal_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^sum_allocated_space_command]];

?? POP ??

?? TITLE := '  Global Definitions', EJECT ??
  TYPE
    t$device_type = (c$844, c$885, c$834, c$836, c$9836, c$895, c$887, c$9853, c$5832, c$5832_2, c$5833,
          c$5833_2, c$5833_3, c$5833_4, c$5838, c$5838_2, c$5838_3, c$5838_4, c$47444, c$47444_2,
          c$47444_3, c$47444_4),

    t$physical_characteristics = record
      bytes_per_mau: dmt$bytes_per_mau,
      cylinders_per_device: dmt$device_position,
      maus_per_cylinder: dmt$maus_per_position,
      maus_per_dau: dmt$maus_per_dau,
      sectors_per_mau: iot$sectors_per_mau,
      sectors_per_track: iot$sectors_per_track,
    recend;

  VAR
    display_control: clt$display_control,
    utility_name: [READ] ost$name := 'analyze_device_file            ';

  VAR
    global_p_dat: ^dmt$ms_device_allocation_table := NIL,
    global_p_dfl: ^dmt$ms_device_file_list_table := NIL,
    global_p_directory: ^dmt$ms_volume_directory := NIL;

  VAR
    global_dat_path: clt$file_reference,
    global_dfl_path: clt$file_reference,
    global_directory_path: clt$file_reference;

  VAR
    global_dat_file_id: amt$file_identifier,
    global_dfl_file_id: amt$file_identifier,
    global_directory_file_id: amt$file_identifier;

  VAR
    device_type_string: [STATIC] array [t$device_type] of string (12) := ['844         ', '885         ',
          '834         ', '836         ', '9836        ', '895         ', '887 (HYDRA) ', '9853 (XMD3) ',
          '5832 (SSD)  ', '5832_2 (SSD)', '5833 (DAS)  ', '5833_2 (DAS)', '5833_3 (DAS)', '5833_4 (DAS)',
          '5838 (DAS)  ', '5838_2 (DAS)', '5838_3 (DAS)', '5838_4 (DAS)', '47444(DAS)  ', '47444_2(DAS)',
          '47444_3(DAS)', '47444_4(DAS)'];
  VAR
    physical_characteristics: [STATIC, READ] array [t$device_type] of t$physical_characteristics := [
          [2048,  823,  88, 2, 5, 24],    {844
          [2048,  843, 320, 2, 4, 32],    {885
          [2048,  817,  80, 8, 4, 32],    {834
          [2048,  701, 280, 8, 4, 47],    {836
          [2048,  703, 288, 8, 1, 12],    {9836
          [4096,  886, 148, 4, 1, 10],    {895
          [4096,  884, 152, 4, 1, 38],    {887
          [2048, 1412, 392, 8, 1, 21],    {9853
          [4096,  844,  48, 4, 1, 12],    {5832
          [4096,  835,  96, 4, 1, 24],    {5832_2
          [4096, 1629, 152, 4, 1, 22],    {5833
          [4096, 1629, 292, 4, 1, 42],    {5833_2
          [8192, 1629, 228, 2, 1, 33],    {5833_3
          [8192, 1629, 292, 2, 1, 42],    {5833_4
          [4096, 2620, 158, 4, 1, 18],    {5838
          [4096, 2620, 308, 4, 1, 35],    {5838_2
          [8192, 2620, 238, 2, 1, 27],    {5838_3
          [8192, 2620, 308, 2, 1, 35],    {5838_4
          [4096, 2290, 188, 4, 1, 13],    {47444
          [4096, 2290, 368, 4, 1, 25],    {47444_2
          [8192, 2290, 278, 2, 1, 19],    {47444_3
          [8192, 2290, 368, 2, 1, 25]     {47444_4
          ];
?? TITLE := '  dmp$analyze_device_file', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$analyze_device_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PDT adf_pdt (
{     input, i : FILE = $COMMAND
{     output, o : FILE = $OUTPUT
{     device_allocation_table, dat : FILE = $OPTIONAL
{     device_file_list, dfl : FILE = $OPTIONAL
{     directory, d : FILE = $OPTIONAL
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    adf_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^adf_pdt_names, ^adf_pdt_params];

  VAR
    adf_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 11] of
  clt$parameter_name_descriptor := [['INPUT', 1], ['I', 1], ['OUTPUT', 2], ['O', 2], [
  'DEVICE_ALLOCATION_TABLE', 3], ['DAT', 3], ['DEVICE_FILE_LIST', 4], ['DFL', 4], ['DIRECTORY', 5], ['D', 5],
  ['STATUS', 6]];

  VAR
    adf_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 6] of clt$parameter_descriptor := [

{ INPUT I }
    [[clc$optional_with_default, ^adf_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value
  ]],

{ OUTPUT O }
    [[clc$optional_with_default, ^adf_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value
  ]],

{ DEVICE_ALLOCATION_TABLE DAT }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ DEVICE_FILE_LIST DFL }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ DIRECTORY D }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    adf_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (8) := '$COMMAND';

  VAR
    adf_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      l: integer,
      str: string (80),
      command_file: clt$value,
      output_file: clt$value,
      ignore: ost$status,
      specified: boolean,
      file: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, adf_pdt, status);
    IF status.normal THEN
      clp$get_value ('INPUT', 1, 1, clc$low, command_file, status);
      IF status.normal THEN
        clp$get_value ('OUTPUT', 1, 1, clc$low, output_file, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      clp$test_parameter ('DEVICE_ALLOCATION_TABLE', specified, status);
      IF status.normal AND specified THEN
        clp$get_value ('DEVICE_ALLOCATION_TABLE', 1, 1, clc$low, file, status);
        IF status.normal THEN
          open_file_as_dat (file, status);
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      clp$test_parameter ('DEVICE_FILE_LIST', specified, status);
      IF status.normal AND specified THEN
        clp$get_value ('DEVICE_FILE_LIST', 1, 1, clc$low, file, status);
        IF status.normal THEN
          open_file_as_dfl (file, status);
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      clp$test_parameter ('DIRECTORY', specified, status);
      IF status.normal AND specified THEN
        clp$get_value ('DIRECTORY', 1, 1, clc$low, file, status);
        IF status.normal THEN
          open_file_as_directory (file, status);
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      clp$push_utility (utility_name, clc$global_command_search, command_table, NIL, status);
      IF status.normal THEN
        clp$open_display (output_file.file, NIL, display_control, status);
        IF status.normal THEN
          IF global_p_dat <> NIL THEN
            STRINGREP (str, l, ' Using ', global_dat_path.path_name (1, global_dat_path.path_name_size),
                      ' as DEVICE ALLOCATION TABLE');
            clp$put_display (display_control, str (1, l), clc$trim, status);
          IFEND;
          IF global_p_dfl <> NIL THEN
            STRINGREP (str, l, ' Using ', global_dfl_path.path_name (1, global_dfl_path.path_name_size),
                      ' as DEVICE FILE LIST');
            clp$put_display (display_control, str (1, l), clc$trim, status);
          IFEND;
          IF global_p_directory <> NIL THEN
            STRINGREP (str, l, ' Using ', global_directory_path.path_name (1,
                       global_directory_path.path_name_size), ' as DIRECTORY');
            clp$put_display (display_control, str (1, l), clc$trim, status);
          IFEND;
          clp$scan_command_file (command_file.file.local_file_name, utility_name, 'adf', status);
          clp$close_display (display_control, status);
        IFEND;
        clp$pop_utility (status);
      IFEND;
    IFEND;

    IF global_p_dat <> NIL THEN
      fsp$close_file (global_dat_file_id, ignore);
    IFEND;

    IF global_p_dfl <> NIL THEN
      fsp$close_file (global_dfl_file_id, ignore);
    IFEND;

    IF global_p_directory <> NIL THEN
      fsp$close_file (global_directory_file_id, ignore);
    IFEND;

  PROCEND dmp$analyze_device_file;
?? TITLE := '  convert_cts_to_dau', EJECT ??

  PROCEDURE convert_cts_to_dau
    (    cylinder: integer;
         track: integer;
         sector: integer;
         device_type: t$device_type;
     VAR dau_address: dmt$dau_address;
     VAR status: ost$status);

{   PURPOSE: convert cylinder/track/sector to dau address
{     this is essentially dmp$convert_to_dau_address from dmm$flaw_management

    VAR
      characteristics: t$physical_characteristics,
      sector_address: integer;

    status.normal := TRUE;
    get_device_characteristics (device_type, characteristics, status);

{ Check the parameters given in the flaw command to see if they are in the
{ physical range of the device.

    IF status.normal THEN
      IF cylinder >= characteristics.cylinders_per_device THEN
        osp$set_status_abnormal ('DM', 1, 'dme$cylinder_limit_exceeded convert_cts_to_dau', status);
      ELSEIF (track * characteristics.sectors_per_track DIV characteristics.sectors_per_mau >=
            characteristics.maus_per_cylinder) THEN
        osp$set_status_abnormal ('DM', 1, 'dme$track_limit_exceeded convert_cts_to_dau', status);
      ELSEIF (sector >= characteristics.sectors_per_track) THEN
        osp$set_status_abnormal ('DM', 1, 'dme$sector_limit_exceeded convert_cts_to_dau', status);
{          If the last track in a cylinder is selected, check to insure the space is used.
{          On some devices, the number of sectors per DAU does not come out evenly.  The
{          remaining sectors are not used as a DAU can not cross cylinder boundaries.
      ELSEIF ((track + 1) * characteristics.sectors_per_track DIV characteristics.sectors_per_mau >=
            characteristics.maus_per_cylinder) THEN
        IF (sector >= characteristics.sectors_per_track - (((track + 1) *
              characteristics.sectors_per_track) - (characteristics.sectors_per_mau *
              characteristics.maus_per_cylinder))) THEN
          osp$set_status_abnormal ('DM', 1, 'dme$unaddressable_sector convert_cts_to_dau', status);
        IFEND;
      IFEND;
    IFEND;

{ Since all parameters are in range, calculate the DAU address.

    IF status.normal THEN
      sector_address := cylinder * characteristics.sectors_per_mau * characteristics.maus_per_cylinder;
      sector_address := sector_address + (track * characteristics.sectors_per_track);
      sector_address := sector_address + sector;
      dau_address := sector_address DIV (characteristics.sectors_per_mau * characteristics.maus_per_dau);
    IFEND;

  PROCEND convert_cts_to_dau;
?? TITLE := '  convert_cts_to_dau_command', EJECT ??

  PROCEDURE convert_cts_to_dau_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PDT concts_pdt (
{     cylinder, c: integer 0..10000 = $required
{     track, t: integer 0..10000 = $required
{     sector, s : integer 0..10000 = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    concts_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^concts_pdt_names,
  ^concts_pdt_params];

  VAR
    concts_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
  clt$parameter_name_descriptor := [['CYLINDER', 1], ['C', 1], ['TRACK', 2], ['T', 2], ['SECTOR', 3], ['S', 3]
  , ['STATUS', 4]];

  VAR
    concts_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor := [

{ CYLINDER C }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 10000]],

{ TRACK T }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 10000]],

{ SECTOR S }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 10000]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      cylinder: clt$value,
      track: clt$value,
      sector: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, concts_pdt, status);
    IF status.normal THEN
      clp$get_value ('CYLINDER', 1, 1, clc$low, cylinder, status);
      IF status.normal THEN
        clp$get_value ('TRACK', 1, 1, clc$low, track, status);
        IF status.normal THEN
          clp$get_value ('SECTOR', 1, 1, clc$low, sector, status);
          IF status.normal THEN

            IF global_p_dat = NIL THEN
              osp$set_status_abnormal ('DM', 1, ' dat not open', status);
            IFEND;

          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      clp$new_display_line (display_control, 1, status);
      clp$put_display (display_control, 'CONVERT_CTS_TO_DAU', clc$trim, status);
      clp$new_display_line (display_control, 1, status);
      display_dau_from_cts (global_p_dat, cylinder.int.value, track.int.value, sector.int.value,
            display_control, status);
    IFEND;

  PROCEND convert_cts_to_dau_command;
?? TITLE := '  deter_style_assigned_to_pos', EJECT ??

  PROCEDURE deter_style_assigned_to_pos (position: dmt$device_position;
        daus_per_position: dmt$daus_per_position;
        p_dat: ^dmt$ms_device_allocation_table;
    VAR assigned_pos_alloc_style: dmt$allocation_styles;
    VAR allocation_style_available: boolean;
    VAR skip_position: boolean;
    VAR status: ost$status);

    VAR
      number_of_daus_in_au: dmt$daus_per_allocation,
      p_status: ^ost$status,
      dau_state: dmt$dau_status,
      position_dau_states: dmt$dau_states,
      dau_offset_within_position: dmt$daus_per_position,
      position_dau_address: dmt$dau_address,
      au_dau_address: dmt$dau_address;

    p_status := NIL;
    position_dau_address := position * daus_per_position;
    position_dau_states := $dmt$dau_states [];
    assigned_pos_alloc_style := dmc$acyl;
    allocation_style_available := FALSE;
    skip_position := FALSE;

  /determine_dau_states/
    FOR dau_offset_within_position := 0 TO daus_per_position - 1 DO

      dau_state := p_dat^.body [position_dau_address + dau_offset_within_position].dau_status;

      CASE dau_state OF
      = dmc$dau_usable, dmc$dau_hardware_flawed, dmc$dau_software_flawed =
        position_dau_states := position_dau_states + $dmt$dau_states [dau_state];
        CYCLE /determine_dau_states/;

      = dmc$dau_assigned_to_mainframe, dmc$dau_ass_to_mf_swr_flawed =
        position_dau_states := position_dau_states + $dmt$dau_states [dau_state];
        CYCLE /determine_dau_states/;

      = dmc$dau_assigned_to_file, dmc$dau_ass_to_file_swr_flawed =
        au_dau_address := position_dau_address + dau_offset_within_position;
        number_of_daus_in_au := 0;

        REPEAT
          number_of_daus_in_au := number_of_daus_in_au + 1;
          au_dau_address := au_dau_address + 1;
        UNTIL ((p_dat^.body [au_dau_address].dau_status <> dmc$dau_assigned_to_file) AND
              (p_dat^.body [au_dau_address].dau_status <> dmc$dau_ass_to_file_swr_flawed)) OR
              (p_dat^.body [au_dau_address].allocation_chain_position <> dmc$part_of_allocation_unit);

        FOR assigned_pos_alloc_style := LOWERVALUE (dmt$allocation_styles) TO UPPERVALUE
              (dmt$allocation_styles) DO
          IF p_dat^.header.daus_per_allocation_style [assigned_pos_alloc_style] = number_of_daus_in_au THEN
            allocation_style_available := (number_of_daus_in_au <> daus_per_position);
            RETURN;
          IFEND;
        FOREND;

        osp$set_status_abnormal ('DM', 1, 'could not determine allocation style - DMMSMAN', status);

      ELSE
        osp$set_status_abnormal ('DM', 1,  'invalid dau status - DMMSMAN', status);
      CASEND;

    FOREND /determine_dau_states/;

    IF ((dmc$dau_hardware_flawed IN position_dau_states) OR (dmc$dau_software_flawed IN position_dau_states)
          OR (dmc$dau_ass_to_mf_swr_flawed IN position_dau_states)) AND (dmc$dau_usable IN
          position_dau_states) THEN
      IF p_dat^.header.bytes_per_dau > 4096 THEN     {this is not an 885 or 844
        assigned_pos_alloc_style := dmc$a0;
      ELSE
        assigned_pos_alloc_style := dmc$default_allocation_style;
      IFEND;
      allocation_style_available := TRUE;
      RETURN;
    IFEND;

    IF $dmt$dau_states [dmc$dau_assigned_to_mainframe] = position_dau_states THEN
      allocation_style_available := FALSE;
      RETURN;
    IFEND;

    IF $dmt$dau_states [dmc$dau_usable] = position_dau_states THEN
      assigned_pos_alloc_style := dmc$acyl;
      allocation_style_available := TRUE;
      RETURN;
    IFEND;

    allocation_style_available := FALSE;

  PROCEND deter_style_assigned_to_pos;
?? TITLE := ' determine_device_type', EJECT ??

  PROCEDURE determine_device_type
    (    p_dat: ^dmt$ms_device_allocation_table;
     VAR device_type: t$device_type;
     VAR status: ost$status);

    VAR
      bytes_per_mau: dmt$bytes_per_mau,
      cylinders_per_device: dmt$device_position,
      maus_per_cylinder: dmt$maus_per_position,
      maus_per_dau: dmt$maus_per_dau;

    status.normal := TRUE;

    bytes_per_mau := p_dat^.header.bytes_per_mau;
    cylinders_per_device := p_dat^.header.positions_per_device;
    maus_per_cylinder := p_dat^.header.maus_per_dau * p_dat^.header.daus_per_position;
    maus_per_dau := p_dat^.header.maus_per_dau;

    FOR device_type := LOWERVALUE (device_type) TO UPPERVALUE (device_type) DO
      IF (bytes_per_mau = physical_characteristics [device_type].bytes_per_mau) AND
         (cylinders_per_device = physical_characteristics [device_type].cylinders_per_device) AND
         (maus_per_cylinder = physical_characteristics [device_type].maus_per_cylinder) AND
         (maus_per_dau = physical_characteristics [device_type].maus_per_dau) THEN
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal ('DM', 1, ' unknown device type', status);

  PROCEND determine_device_type;
?? TITLE := '  display_alloc_chain_command', EJECT ??

  PROCEDURE display_alloc_chain_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT dau_index_pdt (
{     dau_index, di: integer 0..1000000 = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    dau_index_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^dau_index_pdt_names,
  ^dau_index_pdt_params];

  VAR
    dau_index_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
  clt$parameter_name_descriptor := [['DAU_INDEX', 1], ['DI', 1], ['STATUS', 2]];

  VAR
    dau_index_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ DAU_INDEX DI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 1000000]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      dau: clt$value;

    clp$scan_parameter_list (parameter_list, dau_index_pdt, status);
    IF status.normal THEN
      clp$get_value ('DAU_INDEX', 1, 1, clc$low, dau, status);
      IF status.normal THEN

        IF global_p_dat = NIL THEN
          osp$set_status_abnormal ('DM', 1, ' dat not open', status);
        IFEND;

      IFEND;
    IFEND;

    IF status.normal THEN
      clp$new_display_line (display_control, 1, status);
      clp$put_display (display_control, 'DISPLAY_ALLOCATION_CHAIN', clc$trim, status);
      clp$new_display_line (display_control, 1, status);
      display_user_alloc_chain (global_p_dat, dau.int.value, display_control, status);
    IFEND;

  PROCEND display_alloc_chain_command;
?? TITLE := '  display_binary_unique_name', EJECT ??

  PROCEDURE display_binary_unique_name
    (VAR display_control: clt$display_control;
         binary_unique_name: ost$binary_unique_name;
     VAR status: ost$status);

    VAR
      unique_name: ost$name;

    status.normal := TRUE;
    pmp$convert_binary_unique_name (binary_unique_name, unique_name, status);
    IF status.normal THEN
      clp$put_partial_display (display_control, unique_name, clc$trim, amc$terminate, status);
    IFEND;

  PROCEND display_binary_unique_name;
?? TITLE := '  display_cylinders_command', EJECT ??

  PROCEDURE display_cylinders_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PDT display_cylinders_pdt (
{     display_option, do: KEY cylinder, cylinders, c, dau, daus, d = cylinder
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    display_cylinders_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
  ^display_cylinders_pdt_names, ^display_cylinders_pdt_params];

  VAR
    display_cylinders_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
  clt$parameter_name_descriptor := [['DISPLAY_OPTION', 1], ['DO', 1], ['STATUS', 2]];

  VAR
    display_cylinders_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
  clt$parameter_descriptor := [

{ DISPLAY_OPTION DO }
    [[clc$optional_with_default, ^display_cylinders_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [^
  display_cylinders_pdt_kv1, clc$keyword_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    display_cylinders_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of ost$name := [
  'CYLINDER','CYLINDERS','C','DAU','DAUS','D'];

  VAR
    display_cylinders_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (8) := 'cylinder';

?? FMT (FORMAT := ON) ??
?? POP ??

     VAR
       dov: clt$value;

    status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, display_cylinders_pdt, status);
    IF status.normal THEN
      IF global_p_dat = NIL THEN
        osp$set_status_abnormal ('DM', 1, ' dat not open', status);
      IFEND;
    IFEND;

    IF status.normal THEN
      clp$get_value ('DISPLAY_OPTION', 1, 1, clc$low, dov, status);
      IF status.normal THEN
        clp$new_display_page (display_control, status);
        clp$put_display (display_control, 'DISPLAY_CYLINDERS', clc$trim, status);
        clp$new_display_line (display_control, 1, status);
        IF (dov.name.value = 'CYLINDER') OR (dov.name.value = 'CYLINDERS') OR (dov.name.value = 'C') THEN
          display_user_cylinders (global_p_dat, global_dat_path.
            path_name (1, global_dat_path.path_name_size), display_control, status);
        ELSEIF (dov.name.value = 'DAU') OR (dov.name.value = 'DAUS') OR (dov.name.value = 'D') THEN
          display_user_device_type (global_p_dat, global_dat_path.
                path_name (1, global_dat_path.path_name_size), display_control, status);
          display_user_cylinders_daus (global_p_dat, display_control, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND display_cylinders_command;
?? TITLE := '  display_dat_command', EJECT ??

  PROCEDURE display_dat_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT status_pdt (status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    status_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^status_pdt_names,
  ^status_pdt_params];

  VAR
    status_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
  clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    status_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, status_pdt, status);
    IF status.normal THEN
      IF global_p_dat = NIL THEN
        osp$set_status_abnormal ('DM', 1, ' dat not open', status);
      IFEND;
    IFEND;

    IF status.normal THEN
      clp$new_display_page (display_control, status);
      clp$put_display (display_control, 'DISPLAY_DAT', clc$trim, status);
      clp$new_display_line (display_control, 1, status);
      display_user_dat (global_p_dat, global_dat_path.path_name (1, global_dat_path.path_name_size),
            display_control, status);
    IFEND;
  PROCEND display_dat_command;
?? TITLE := '  display_dat_entry', EJECT ??

  PROCEDURE display_dat_entry
    (VAR display_control: clt$display_control;
         dat_index: integer;
         p_dat_entry: ^dmt$ms_device_allocation_unit;
     VAR status: ost$status);

    VAR
      aux_integer_length: integer,
      dfl_index: dmt$device_file_list_index,
      display_string: string (80),
      file_string: string (63),
      flaw_string: string (7),
      integer_string: string (80),
      integer_length: integer,
      mat_flaw_string: string (27),
      mat_string: string (38);

    status.normal := TRUE;

    STRINGREP (integer_string, integer_length, dat_index);

    CASE p_dat_entry^.dau_status OF

    = dmc$dau_usable =
      display_string := '        Usable                                                                  ';

      display_string (1, integer_length) := integer_string;

    = dmc$dau_hardware_flawed =
      display_string := '        Hardware Flawed                                                         ';

      display_string (1, integer_length) := integer_string;

    = dmc$dau_software_flawed =
      display_string := '        Software Flawed                                                         ';

      display_string (1, integer_length) := integer_string;

    = dmc$dau_assigned_to_mainframe, dmc$dau_ass_to_mf_swr_flawed =
      IF p_dat_entry^.dau_status = dmc$dau_ass_to_mf_swr_flawed THEN
        mat_flaw_string := '                     Flawed';
      ELSE
        mat_flaw_string := '                           ';
      IFEND;

      mat_string (1, * ) := '        Mfid(login seq, login index) -';

      mat_string (1, integer_length) := integer_string;

      STRINGREP (display_string, integer_length, mat_string: 38,
            p_dat_entry^.mainframe_id.log_in_sequence: 10, p_dat_entry^.mainframe_id.log_in_index: 3,
            mat_flaw_string: 29);

    = dmc$dau_assigned_to_file, dmc$dau_ass_to_file_swr_flawed =
      IF p_dat_entry^.dau_status = dmc$dau_ass_to_file_swr_flawed THEN
        flaw_string := ' Flawed';
      ELSE
        flaw_string := '       ';
      IFEND;

      file_string (1, * ) := '        Hash-    Status-';

      file_string (1, integer_length) := integer_string;

      STRINGREP (integer_string, integer_length, p_dat_entry^.file_hash);
      file_string (14, integer_length) := integer_string;

      IF p_dat_entry^.data_status = dmc$dau_data_initialized THEN
        file_string (25, 8) := 'Init    ';
      ELSE
        file_string (25, 8) := 'Not Init';
      IFEND;

      CASE p_dat_entry^.allocation_chain_position OF

      = dmc$first_and_last_allocation =
        file_string (35, 28) := 'First+Last Alloc(Dfl Index)-';

        dfl_index := p_dat_entry^.high_dfl_index * dmc$dfl_index_converter + p_dat_entry^.low_dfl_index;
        STRINGREP (display_string, integer_length, file_string: 63, dfl_index: 8, flaw_string: 9);

      = dmc$first_allocation =
        file_string (35, 28) := 'First Alloc(Next Dau Adrs) -';
        STRINGREP (display_string, integer_length, file_string: 63,

        p_dat_entry^.next_allocation_unit_dau: 8, flaw_string: 9);

      = dmc$middle_allocation =
        file_string (35, 28) := 'Middle Alloc(Next Dau Adrs) -';
        STRINGREP (display_string, integer_length, file_string: 63, p_dat_entry^.next_allocation_unit_dau: 8,
              flaw_string: 9);

      = dmc$last_allocation =
        file_string (35, 28) := 'Last Allocation(Dfl Index) -';
        dfl_index := p_dat_entry^.high_dfl_index * dmc$dfl_index_converter + p_dat_entry^.low_dfl_index;
        STRINGREP (display_string, integer_length, file_string: 63, dfl_index: 8, flaw_string: 9);

      = dmc$part_of_allocation_unit =
        file_string (35, 28) := 'Part of Allocation Unit     ';
        STRINGREP (display_string, integer_length, file_string: 71, flaw_string: 9);

      CASEND;
    CASEND;

    clp$put_display (display_control, display_string, clc$trim, status);

  PROCEND display_dat_entry;
?? TITLE := '  display_dat_header', EJECT ??

  PROCEDURE display_dat_header
    (VAR display_control: clt$display_control;
         dat_header: dmt$ms_device_alloc_table_head;
     VAR status: ost$status);

    VAR
      aux_string,
      integer_string: ost$string;

    status.normal := TRUE;

    clp$new_display_line (display_control, 1, status);

    clp$put_display (display_control, 'Device Allocation Table Header', clc$trim, status);

    clp$put_partial_display (display_control, '  Bytes/Dau         - ', clc$no_trim, amc$start, status);

    clp$convert_integer_to_string (dat_header.bytes_per_dau, 10, FALSE, integer_string, status);

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);

    clp$put_partial_display (display_control, '  Bytes/Mau         - ', clc$no_trim, amc$start, status);

    clp$convert_integer_to_string (dat_header.bytes_per_mau, 10, FALSE, integer_string, status);

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);

    clp$put_partial_display (display_control, '  Daus/Position     - ', clc$no_trim, amc$start, status);

    clp$convert_integer_to_string (dat_header.daus_per_position, 10, FALSE, integer_string, status);

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);

    clp$put_partial_display (display_control, '  Maus/Dau          - ', clc$no_trim, amc$start, status);

    clp$convert_integer_to_string (dat_header.maus_per_dau, 10, FALSE, integer_string, status);

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);

    clp$put_partial_display (display_control, '  Number Of Entries - ', clc$no_trim, amc$start, status);

    clp$convert_integer_to_string (dat_header.number_of_entries, 10, FALSE, integer_string, status);

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);

    clp$put_partial_display (display_control, '  Positions/Device  - ', clc$no_trim, amc$start, status);

    clp$convert_integer_to_string (dat_header.positions_per_device, 10, FALSE, integer_string, status);

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);

    clp$put_partial_display (display_control, '  Version Number    - ', clc$no_trim, amc$start, status);

    CASE dat_header.version_number OF
    = dmc$dat_0_0 =
      clp$put_partial_display (display_control, 'dmc$dat_0_0', clc$trim, amc$terminate, status);

      clp$new_display_line (display_control, 1, status);

      clp$put_display (display_control, '    Daus/Allocation Style', clc$trim, status);

      clp$put_partial_display (display_control, '      A0   - ', clc$no_trim, amc$start, status);

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a0], 10, FALSE, ' ',
            integer_string.value (1, 6), status);

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);

      clp$put_partial_display (display_control, '      A1   - ', clc$no_trim, amc$start, status);

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a1], 10, FALSE, ' ',
            integer_string.value (1, 6), status);

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);

      clp$put_partial_display (display_control, '      A2   - ', clc$no_trim, amc$start, status);

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a2], 10, FALSE, ' ',
            integer_string.value (1, 6), status);

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);

      clp$put_partial_display (display_control, '      A3   - ', clc$no_trim, amc$start, status);

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a3], 10, FALSE, ' ',
            integer_string.value (1, 6), status);

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);

      clp$put_partial_display (display_control, '      A4   - ', clc$no_trim, amc$start, status);

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a4], 10, FALSE, ' ',
            integer_string.value (1, 6), status);

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);

      clp$put_partial_display (display_control, '      A5   - ', clc$no_trim, amc$start, status);

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a5], 10, FALSE, ' ',
            integer_string.value (1, 6), status);

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);

      clp$put_partial_display (display_control, '      A6   - ', clc$no_trim, amc$start, status);

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a6], 10, FALSE, ' ',
            integer_string.value (1, 6), status);

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);

      clp$put_partial_display (display_control, '      A7   - ', clc$no_trim, amc$start, status);

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a7], 10, FALSE, ' ',
            integer_string.value (1, 6), status);

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);

      clp$put_partial_display (display_control, '      A8   - ', clc$no_trim, amc$start, status);

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a8], 10, FALSE, ' ',
            integer_string.value (1, 6), status);

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);

      clp$put_partial_display (display_control, '      Acyl - ', clc$no_trim, amc$start, status);

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$acyl], 10, FALSE, ' ',
            integer_string.value (1, 6), status);

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);

      clp$new_display_line (display_control, 1, status);

      clp$put_partial_display (display_control, '    Daus available     - ', clc$no_trim, amc$start, status);

      clp$convert_integer_to_rjstring (dat_header.available, 10, FALSE, ' ', integer_string.value (1, 8),
            status);

      clp$put_partial_display (display_control, integer_string.value (1, 8), clc$no_trim, amc$terminate,
            status);

      clp$put_partial_display (display_control, '    Recovery threshold - ', clc$no_trim, amc$start, status);

      clp$convert_integer_to_rjstring (dat_header.recovery_threshold, 10, FALSE, ' ', integer_string.
            value (1, 8), status);

      clp$put_partial_display (display_control, integer_string.value (1, 8), clc$no_trim, amc$terminate,
            status);

      clp$put_partial_display (display_control, '    Warning threshold  - ', clc$no_trim, amc$start, status);

      clp$convert_integer_to_rjstring (dat_header.warning_threshold, 10, FALSE, ' ', integer_string.
            value (1, 8), status);

      clp$put_partial_display (display_control, integer_string.value (1, 8), clc$no_trim, amc$terminate,
            status);

    = dmc$dat_1_0 =
      clp$put_partial_display (display_control, 'dmc$dat_1_0', clc$trim, amc$terminate, status);
    CASEND;
  PROCEND display_dat_header;
?? TITLE := '  display_dat_header_command', EJECT ??

  PROCEDURE display_dat_header_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT status_pdt (status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    status_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^status_pdt_names,
  ^status_pdt_params];

  VAR
    status_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
  clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    status_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, status_pdt, status);
    IF status.normal THEN

      IF global_p_dat = NIL THEN
        osp$set_status_abnormal ('DM', 1, ' dat not open', status);
      IFEND;

    IFEND;

    IF status.normal THEN
      clp$new_display_line (display_control, 1, status);
      clp$put_display (display_control, 'DISPLAY_DAT_HEADER', clc$trim, status);
      display_user_dat_header (global_p_dat, global_dat_path.
            path_name (1, global_dat_path.path_name_size), display_control, status);
    IFEND;

  PROCEND display_dat_header_command;
?? TITLE := '  display_dau_entry_command', EJECT ??

  PROCEDURE display_dau_entry_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT dau_index_pdt (
{     dau_index, di: integer 0..1000000 = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    dau_index_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^dau_index_pdt_names,
  ^dau_index_pdt_params];

  VAR
    dau_index_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
  clt$parameter_name_descriptor := [['DAU_INDEX', 1], ['DI', 1], ['STATUS', 2]];

  VAR
    dau_index_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ DAU_INDEX DI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 1000000]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      dau: clt$value;

    clp$scan_parameter_list (parameter_list, dau_index_pdt, status);
    IF status.normal THEN
      clp$get_value ('DAU_INDEX', 1, 1, clc$low, dau, status);
      IF status.normal THEN

        IF global_p_dat = NIL THEN
          osp$set_status_abnormal ('DM', 1, ' dat not open', status);
        IFEND;

      IFEND;
    IFEND;

    IF status.normal THEN
      clp$new_display_line (display_control, 1, status);
      clp$put_display (display_control, 'DISPLAY_DAU_ENTRY', clc$trim, status);
      clp$new_display_line (display_control, 1, status);
      display_user_dat_entry (global_p_dat, dau.int.value, display_control, status);
    IFEND;

  PROCEND display_dau_entry_command;
?? TITLE := ' display_dau_from_cts', EJECT ??

  PROCEDURE display_dau_from_cts
    (    p_dat: ^dmt$ms_device_allocation_table;
         cylinder: integer;
         track: integer;
         sector: integer;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      dau: dmt$dau_address,
      device_type: t$device_type,
      str: string (80),
      l: integer;

    determine_device_type (p_dat, device_type, status);
    IF status.normal THEN
      convert_cts_to_dau (cylinder, track, sector, device_type, dau, status);
      IF status.normal THEN
        STRINGREP (str, l, ' For device type ', device_type_string [device_type], '  C', cylinder, '  T',
              track, '  S', sector, ' maps to dau address ', dau);
        clp$put_display (display_control, str (1, l), clc$trim, status);
      IFEND;
    IFEND;

  PROCEND display_dau_from_cts;
?? TITLE := '  display_device_type_command', EJECT ??

  PROCEDURE display_device_type_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT status_pdt (status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    status_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^status_pdt_names,
  ^status_pdt_params];

  VAR
    status_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
  clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    status_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, status_pdt, status);
    IF status.normal THEN
      IF global_p_dat = NIL THEN
        osp$set_status_abnormal ('DM', 1, ' dat not open', status);
      IFEND;
    IFEND;

    IF status.normal THEN
      clp$new_display_line (display_control, 1, status);
      clp$put_display (display_control, 'DISPLAY_DEVICE_TYPE', clc$trim, status);
      clp$new_display_line (display_control, 1, status);
      display_user_device_type (global_p_dat, global_dat_path.
            path_name (1, global_dat_path.path_name_size), display_control, status);
    IFEND;

  PROCEND display_device_type_command;
?? TITLE := '  display_dfl_command', EJECT ??

  PROCEDURE display_dfl_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT status_pdt (status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    status_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^status_pdt_names,
  ^status_pdt_params];

  VAR
    status_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
  clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    status_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, status_pdt, status);
    IF status.normal THEN

      IF global_p_dfl = NIL THEN
        osp$set_status_abnormal ('DM', 1, ' dfl not open', status);
      ELSE
        clp$new_display_page (display_control, status);
        clp$put_display (display_control, 'DISPLAY_DFL', clc$trim, status);
        display_user_dfl (global_p_dfl, global_dfl_path.path_name (1, global_dfl_path.path_name_size),
                              display_control, status);
      IFEND;

    IFEND;

  PROCEND display_dfl_command;
?? TITLE := '  display_dfl_entry', EJECT ??

  PROCEDURE display_dfl_entry
    (VAR display_control: clt$display_control;
         dfl_index: dmt$device_file_list_index;
         p_dfl_entry: ^dmt$ms_device_file_list_entry;
     VAR status: ost$status);

    VAR
      integer_string: string (osc$max_string_size),
      integer_length: integer,
      display_string: string (osc$max_string_size),
      aux_integer_length: integer,
      login_index: dmt$login_table_entry_index,
      first: boolean;

    status.normal := TRUE;

    STRINGREP (integer_string, integer_length, dfl_index);

    CASE p_dfl_entry^.flags OF
    = dmc$dfle_available =
      display_string := '       Dfle Available                                                ';
      display_string (1, integer_length) := integer_string;
    = dmc$dfle_assigned_to_mainframe =
      display_string := '       Mainframe Assigned(Login Seq, Login Index)-                     ';
      display_string (1, integer_length) := integer_string;
      STRINGREP (integer_string, integer_length, p_dfl_entry^.mainframe_assigned.log_in_sequence);
      display_string (51, integer_length) := integer_string;
      display_string (51 + integer_length, 2) := ', ';
      STRINGREP (integer_string, aux_integer_length, p_dfl_entry^.mainframe_assigned.log_in_index);
      display_string (51 + integer_length + 2, aux_integer_length) := integer_string;
    = dmc$dfle_assigned_to_file =
      display_string := '       File Type-             File Hash-     Fba-                       ';
      display_string (1, integer_length) := integer_string;
      CASE p_dfl_entry^.file_kind OF
      = gfc$fk_job_permanent_file =
        display_string (18, 12) := 'Permanent   ';
      = gfc$fk_device_file =
        display_string (18, 12) := 'Device      ';
      = gfc$fk_job_local_file =
        display_string (18, 12) := 'Temp Named  ';
      = gfc$fk_unnamed_file =
        display_string (18, 12) := 'Temp Unnamed';
      = gfc$fk_global_unnamed =
        display_string (18, 12) := 'Temp Global ';
      = gfc$fk_catalog =
        display_string (18, 12) := 'Catalog     ';
      ELSE
        ;
      CASEND;
      STRINGREP (integer_string, integer_length, p_dfl_entry^.file_hash);
      display_string (41, integer_length) := integer_string;
      STRINGREP (integer_string, integer_length, p_dfl_entry^.file_byte_address);
      display_string (49, integer_length) := integer_string;

      clp$put_display (display_control, display_string, clc$trim, status);

      clp$put_partial_display (display_control, '       GFN - ', clc$no_trim, amc$start, status);

      display_binary_unique_name (display_control, p_dfl_entry^.global_file_name, status);

      display_string := '       Daus/Alloc Unit-    Dau Chain Status-                           ';
      STRINGREP (integer_string, integer_length, p_dfl_entry^.daus_per_allocation_unit);
      display_string (24, integer_length) := integer_string;
      IF p_dfl_entry^.dau_chain_status = dmc$dau_chain_linked THEN
        display_string (45, 12) := 'Chain Linked';
      ELSE
        display_string (45, 16) := 'Chain Not Linked';
      IFEND;

      clp$put_display (display_control, display_string, clc$trim, status);

      display_string := '       First Dau Address-           Subfile Length-                    ';
      STRINGREP (integer_string, integer_length, p_dfl_entry^.first_dau_address);
      display_string (26, integer_length) := integer_string;
      STRINGREP (integer_string, integer_length, p_dfl_entry^.fmd_length);
      display_string (52, integer_length) := integer_string;

      clp$put_display (display_control, display_string, clc$trim, status);

      display_string := '       Logical Length-           End Of Information-                   ';
      STRINGREP (integer_string, integer_length, p_dfl_entry^.logical_length);
      display_string (23, integer_length) := integer_string;
      STRINGREP (integer_string, integer_length, p_dfl_entry^.end_of_information);
      display_string (53, integer_length) := integer_string;

      clp$put_display (display_control, display_string, clc$trim, status);

      display_string := '       End Of File-           Login Set-(                              ';
      STRINGREP (integer_string, integer_length, p_dfl_entry^.end_of_file);
      display_string (20, integer_length) := integer_string;
      first := TRUE;
      aux_integer_length := 43;
      FOR login_index := LOWERVALUE (dmt$login_table_entry_index)
            TO UPPERVALUE (dmt$login_table_entry_index) DO
        IF login_index IN p_dfl_entry^.login_set THEN
          IF NOT first THEN
            display_string (aux_integer_length, 2) := ', ';
            aux_integer_length := aux_integer_length + 2;
          IFEND;

          STRINGREP (integer_string, integer_length, login_index);
          display_string (aux_integer_length, integer_length) := integer_string;
          aux_integer_length := aux_integer_length + integer_length;
          first := FALSE;
        IFEND;
      FOREND;

      display_string (aux_integer_length, 1) := ')';

      clp$put_display (display_control, display_string, clc$trim, status);

      first := TRUE;
      display_string := '       Abnormalities: None.';
      aux_integer_length := 23;

      IF dmc$eoi_modified_by_recovery IN p_dfl_entry^.damage THEN
        first := FALSE;
        display_string (aux_integer_length, 25) := 'Eoi modified by recovery.';
        aux_integer_length := aux_integer_length + 24;
      IFEND;

      IF dmc$media_image_inconsistent IN p_dfl_entry^.damage THEN
        IF NOT first THEN
          display_string (aux_integer_length, 2) := ', ';
          aux_integer_length := aux_integer_length + 3;
        IFEND;
        first := FALSE;
        display_string (aux_integer_length, 19) := 'Media inconsistent.';
        aux_integer_length := aux_integer_length + 18;
      IFEND;

      IF dmc$allocation_chain_broken IN p_dfl_entry^.damage THEN
        IF NOT first THEN
          display_string (aux_integer_length, 2) := ', ';
          aux_integer_length := aux_integer_length + 3;
        IFEND;
        first := FALSE;
        display_string (aux_integer_length, 24) := 'Allocation chain broken.';
      IFEND;
    CASEND;

    clp$put_display (display_control, display_string, clc$trim, status);

    clp$new_display_line (display_control, 1, status);

  PROCEND display_dfl_entry;
?? TITLE := '  display_dfl_entry_command', EJECT ??

  PROCEDURE display_dfl_entry_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT disdfle_pdt (
{ index, i: integer 1..1000000 = $required
{ allocation_chain, ac: boolean = FALSE
{ status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    disdfle_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^disdfle_pdt_names,
  ^disdfle_pdt_params];

  VAR
    disdfle_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
  clt$parameter_name_descriptor := [['INDEX', 1], ['I', 1], ['ALLOCATION_CHAIN', 2], ['AC', 2], ['STATUS', 3]
  ];

  VAR
    disdfle_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ INDEX I }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 1, 1000000]],

{ ALLOCATION_CHAIN AC }
    [[clc$optional_with_default, ^disdfle_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    disdfle_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'FALSE';

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      allocation_chain_desired: boolean,
      dau: dmt$dau_address,
      dfl_index: dmt$device_file_list_index,
      specified: boolean,
      allocation_chain: clt$value,
      index: clt$value;

    status.normal := TRUE;
    allocation_chain_desired := FALSE;

    clp$scan_parameter_list (parameter_list, disdfle_pdt, status);
    IF status.normal THEN

      IF global_p_dfl = NIL THEN
        osp$set_status_abnormal ('DM', 1, ' dfl not open', status);
      IFEND;

      IF status.normal THEN
        clp$get_value ('INDEX', 1, 1, clc$low, index, status);
        IF status.normal THEN
          clp$test_parameter ('ALLOCATION_CHAIN', specified, status);
          IF status.normal AND specified THEN
            clp$get_value ('ALLOCATION_CHAIN', 1, 1, clc$low, allocation_chain, status);
            IF status.normal THEN
              allocation_chain_desired := allocation_chain.bool.value;
              IF allocation_chain_desired AND (global_p_dat = NIL) THEN
                osp$set_status_abnormal ('DM', 1, ' dat not open', status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      dfl_index := index.int.value;
      clp$new_display_line (display_control, 1, status);
      clp$put_display (display_control, 'DISPLAY_DFL_ENTRY', clc$trim, status);
      clp$new_display_line (display_control, 1, status);
      display_user_dfl_entry (global_p_dfl, dfl_index, display_control, status);
    IFEND;

    IF status.normal AND allocation_chain_desired THEN
      IF (global_p_dfl^.entries [dfl_index].flags = dmc$dfle_assigned_to_file) AND
            (global_p_dfl^.entries [dfl_index].dau_chain_status = dmc$dau_chain_linked) THEN
        dau := global_p_dfl^.entries [dfl_index].first_dau_address;
        clp$new_display_line (display_control, 1, status);
        clp$put_display (display_control, 'DISPLAY_ALLOCATION_CHAIN', clc$trim, status);
        clp$new_display_line (display_control, 1, status);
        display_user_alloc_chain (global_p_dat, dau, display_control, status);
      IFEND;
    IFEND;

  PROCEND display_dfl_entry_command;
?? TITLE := '  display_dfl_header', EJECT ??

  PROCEDURE display_dfl_header
    (VAR display_control: clt$display_control;
         p_dfl_header: ^dmt$ms_device_file_list_header;
     VAR status: ost$status);

    VAR
      aux_string,
      integer_string: ost$string;

    status.normal := TRUE;

    clp$new_display_line (display_control, 1, status);
    clp$put_partial_display (display_control, '  Number Of Entries - ', clc$no_trim, amc$start, status);
    clp$convert_integer_to_string (p_dfl_header^.number_of_entries, 10, FALSE, integer_string,
          status);
    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);

    clp$put_partial_display (display_control, '  Version Number    - ', clc$no_trim, amc$start, status);

    CASE p_dfl_header^.version_number OF
    = dmc$dflt_0_0 =
      aux_string.value := 'dmc$dflt_0_0';
      aux_string.size := 12;
    = dmc$dflt_1_0 =
      aux_string.value := 'dmc$dflt_1_0';
      aux_string.size := 12;
    ELSE
      ;
    CASEND;

    clp$put_partial_display (display_control, aux_string.value (1, aux_string.size), clc$trim, amc$terminate,
          status);

    clp$new_display_line (display_control, 1, status);

  PROCEND display_dfl_header;
?? TITLE := '  display_directory_entry', EJECT ??

  PROCEDURE display_directory_entry
    (VAR display_control: clt$display_control;
         directory_entry: dmt$ms_volume_directory_entry;
     VAR status: ost$status);

    VAR
      aux_string: ost$string;

    status.normal := TRUE;

    clp$put_partial_display (display_control, '  Entry Available    - ', clc$no_trim, amc$start, status);
    IF directory_entry.entry_available THEN
      aux_string.value := 'True';
      aux_string.size := 4;
    ELSE
      aux_string.value := 'False';
      aux_string.size := 5;
    IFEND;
    clp$put_partial_display (display_control, aux_string.value (1, aux_string.size), clc$no_trim,
          amc$terminate, status);

    IF NOT directory_entry.entry_available THEN
      clp$put_partial_display (display_control, '  User Supplied Name - ', clc$no_trim, amc$start, status);
      clp$put_partial_display (display_control, directory_entry.user_supplied_name, clc$trim, amc$terminate,
            status);

      clp$put_partial_display (display_control, '  Global File Name   - ', clc$no_trim, amc$start, status);

      display_binary_unique_name (display_control, directory_entry.global_file_name, status);

      display_stored_fmd (display_control, ^directory_entry.stored_df_fmd, status);
    IFEND;

  PROCEND display_directory_entry;
?? TITLE := '   display_directory_entry_command', EJECT ??

  PROCEDURE display_directory_entry_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PDT display_dir_pdt (
{   index,i:integer 1..100 = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    display_dir_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^display_dir_pdt_names,
  ^display_dir_pdt_params];

  VAR
    display_dir_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
  clt$parameter_name_descriptor := [['INDEX', 1], ['I', 1], ['STATUS', 2]];

  VAR
    display_dir_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ INDEX I }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 1, 100]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      index: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_dir_pdt, status);
    IF status.normal THEN

      IF global_p_directory = NIL THEN
        osp$set_status_abnormal ('DM', 1, ' directory not open', status);
      IFEND;

      IF status.normal THEN
        clp$get_value ('INDEX', 1, 1, clc$low, index, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      clp$new_display_line (display_control, 1, status);
      clp$put_display (display_control, 'DISPLAY_DIRECTORY_ENTRY', clc$trim, status);
      clp$new_display_line (display_control, 1, status);
      display_user_dir_entry (global_p_directory, index.int.value, display_control, status);
    IFEND;
  PROCEND display_directory_entry_command;
?? TITLE := '  display_directory_command', EJECT ??

  PROCEDURE display_directory_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT status_pdt (status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    status_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^status_pdt_names,
  ^status_pdt_params];

  VAR
    status_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
  clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    status_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, status_pdt, status);
    IF status.normal THEN
      IF global_p_directory = NIL THEN
        osp$set_status_abnormal ('DM', 1, ' directory not open', status);
      IFEND;
    IFEND;

    IF status.normal THEN
      clp$new_display_page (display_control, status);
      clp$put_display (display_control, 'DISPLAY_DIRECTORY', clc$trim, status);
      clp$new_display_line (display_control, 1, status);
      display_user_directory (global_p_directory, global_directory_path.
            path_name (1, global_directory_path.path_name_size), display_control, status);
    IFEND;
  PROCEND display_directory_command;
?? TITLE := '  display_line', EJECT ??

  PROCEDURE display_line
    (    output_line: string ( * );
         number: integer;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

{
{   The purpose of this procedure is to output a line with the number converted to a string
{ appended to the line.
{

    VAR
      integer_length: integer,
      integer_string: string (osc$max_string_size),
      line: string (osc$max_string_size);

    STRINGREP (integer_string, integer_length, number);
    line := output_line;
    line (STRLENGTH (output_line) + 1, integer_length) := integer_string;
    clp$put_display (display_control, line, clc$trim, status);

  PROCEND display_line;
?? TITLE := '  display_stored_fmd', EJECT ??

  PROCEDURE display_stored_fmd
    (VAR display_control: clt$display_control;
         p_stored_df_fmd: ^dmt$device_file_stored_fmd;
     VAR status: ost$status);

    VAR
      stored_df_fmd: ^dmt$device_file_stored_fmd,
      aux_string,
      integer_string: ost$string,
      fmd_version: ^dmt$stored_ms_version_number,
      stored_fmd_header: ^dmt$stored_ms_fmd_header,
      stored_fmd_subfile: ^dmt$stored_ms_fmd_subfile;

    status.normal := TRUE;
    stored_df_fmd := p_stored_df_fmd;

    RESET stored_df_fmd;
    NEXT fmd_version IN stored_df_fmd;
    IF fmd_version = NIL THEN
      osp$set_status_abnormal ('DM', 1, ' dme$invalid_fmd, No FMD version number.', status);
      RETURN;
    IFEND;

    NEXT stored_fmd_header: [fmd_version^] IN stored_df_fmd;
    IF stored_fmd_header = NIL THEN
      osp$set_status_abnormal ('DM', 1, ' dme$invalid_fmd, No FMD header.', status);
      RETURN;
    IFEND;

    clp$put_display (display_control, 'Stored Fmd Header', clc$trim, status);

    CASE fmd_version^ OF
    = 0 =
      clp$put_display (display_control, '  Version                   - 0', clc$trim, status);

      clp$put_partial_display (display_control, '  Clear Space               - ', clc$no_trim, amc$start,
            status);

      IF stored_fmd_header^.version_0_0.clear_space THEN
        aux_string.value := 'True';
        aux_string.size := 4;
      ELSE
        aux_string.value := 'False';
        aux_string.size := 5;
      IFEND;

      clp$put_partial_display (display_control, aux_string.value (1, aux_string.size), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, '  File Hash                 - ', clc$no_trim, amc$start,
            status);

      clp$convert_integer_to_string (stored_fmd_header^.version_0_0.file_hash, 10, FALSE, integer_string,
            status);

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, '  File Limit                - ', clc$no_trim, amc$start,
            status);

      clp$convert_integer_to_string (stored_fmd_header^.version_0_0.file_limit, 10, FALSE, integer_string,
            status);

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, '  File Type                 - ', clc$no_trim, amc$start,
            status);

      CASE stored_fmd_header^.version_0_0.file_kind OF
      = gfc$fk_job_permanent_file =
        aux_string.value := 'gfc$fk_job_permanent_file';
        aux_string.size := 25;
      = gfc$fk_device_file =
        aux_string.value := 'gfc$fk_device_file';
        aux_string.size := 18;
      = gfc$fk_job_local_file =
        aux_string.value := 'gfc$fk_job_local_file';
        aux_string.size := 21;
      = gfc$fk_unnamed_file =
        aux_string.value := 'gfc$fk_unnamed_file';
        aux_string.size := 19;
      = gfc$fk_catalog =
        aux_string.value := 'gfc$fk_catalog';
        aux_string.size := 14;
      ELSE
        ;
      CASEND;

      clp$put_partial_display (display_control, aux_string.value (1, aux_string.size), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, '  Locked File               - ', clc$no_trim, amc$start,
            status);

      clp$put_partial_display (display_control, '(', clc$trim, amc$continue, status);

      IF stored_fmd_header^.version_0_0.locked_file.required THEN
        clp$put_partial_display (display_control, 'True, ', clc$trim, amc$terminate, status);
      ELSE
        clp$put_partial_display (display_control, 'False)', clc$trim, amc$terminate, status);
      IFEND;

      clp$put_partial_display (display_control, '  Number Subfiles           - ', clc$no_trim, amc$start,
            status);

      clp$convert_integer_to_string (stored_fmd_header^.version_0_0.number_fmds, 10, FALSE, integer_string,
            status);

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, '  Overflow Allowed          - ', clc$no_trim, amc$start,
            status);

      IF stored_fmd_header^.version_0_0.overflow_allowed THEN
        aux_string.value := 'True';
        aux_string.size := 4;
      ELSE
        aux_string.value := 'False';
        aux_string.size := 5;
      IFEND;

      clp$put_partial_display (display_control, aux_string.value (1, aux_string.size), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, '  Preset Value              - ', clc$no_trim, amc$start,
            status);

      clp$convert_integer_to_string (stored_fmd_header^.version_0_0.preset_value, 10, FALSE, integer_string,
            status);

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, '  Requested Allocation Size - ', clc$no_trim, amc$start,
            status);

      clp$convert_integer_to_string (stored_fmd_header^.version_0_0.requested_allocation_size, 10, FALSE,
            integer_string, status);

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, '  Requested Class           - ', clc$no_trim, amc$start,
            status);

      aux_string.value (1) := stored_fmd_header^.version_0_0.requested_class;
      aux_string.size := 1;

      clp$put_partial_display (display_control, aux_string.value (1, aux_string.size), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, '  Requested Class Ordinal   - ', clc$no_trim, amc$start,
            status);

      clp$convert_integer_to_string (stored_fmd_header^.version_0_0.requested_class_ordinal, 10, FALSE,
            integer_string, status);

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, '  Requested Transfer Size   - ', clc$no_trim, amc$start,
            status);

      clp$convert_integer_to_string (stored_fmd_header^.version_0_0.requested_transfer_size, 10, FALSE,
            integer_string, status);

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, '  Requested Volume.Rec_Vsn  - ', clc$no_trim, amc$start,
            status);

      clp$put_partial_display (display_control, stored_fmd_header^.version_0_0.requested_volume.recorded_vsn,
            clc$trim, amc$terminate, status);

      clp$put_partial_display (display_control, '  Requested Volume.Set_Name - ', clc$no_trim, amc$start,
            status);

      clp$put_partial_display (display_control, stored_fmd_header^.version_0_0.requested_volume.setname,
            clc$trim, amc$terminate, status);

    = 1 =
      clp$put_partial_display (display_control, '  Version                  - 1', clc$trim, amc$terminate,
            status);

      clp$put_partial_display (display_control, '  Number Subfiles           - ', clc$no_trim, amc$start,
            status);

      clp$convert_integer_to_string (stored_fmd_header^.version_1_0.number_fmds, 10, FALSE, integer_string,
            status);

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);
    ELSE
      ;
    CASEND;

    NEXT stored_fmd_subfile: [fmd_version^] IN stored_df_fmd;
    IF stored_fmd_subfile = NIL THEN
      osp$set_status_abnormal ('DM', 1, ' dme$invalid_fmd, FMD too small to hold subfiles.', status);
      RETURN;
    IFEND;

    clp$put_display (display_control, 'Stored Fmd Subfile', clc$trim, status);

    CASE fmd_version^ OF
    = 0 =
      clp$put_partial_display (display_control, '  Version                   - 0', clc$trim, amc$terminate,
            status);

      clp$put_partial_display (display_control, '  Byte Address              - ', clc$no_trim, amc$start,
            status);

      clp$convert_integer_to_string (stored_fmd_subfile^.version_0_0.stored_byte_address *
            dmc$byte_address_converter, 10, FALSE, integer_string, status);

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, '  Device File List Index    - ', clc$no_trim, amc$start,
            status);

      clp$convert_integer_to_string (stored_fmd_subfile^.version_0_0.device_file_list_index, 10, FALSE,
            integer_string, status);

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, '  Interval Vsn              - ', clc$no_trim, amc$start,
            status);

      display_binary_unique_name (display_control, stored_fmd_subfile^.version_0_0.internal_vsn, status);

      clp$put_partial_display (display_control, '  Recorded Vsn              - ', clc$no_trim, amc$start,
            status);

      clp$put_partial_display (display_control, stored_fmd_subfile^.version_0_0.recorded_vsn, clc$trim,
            amc$terminate, status);

    = 1 =
      clp$put_display (display_control, '  Version                   - 1', clc$trim, status);

      clp$put_partial_display (display_control, '  Recorded Vsn              - ', clc$no_trim, amc$start,
            status);

      clp$put_partial_display (display_control, stored_fmd_subfile^.version_1_0.recorded_vsn, clc$trim,
            amc$terminate, status);
    ELSE
      ;
    CASEND;

  PROCEND display_stored_fmd;
?? TITLE := '  display_user_alloc_chain', EJECT ??

  PROCEDURE display_user_alloc_chain
    (    p_dat: ^dmt$ms_device_allocation_table;
         dau_index: dmt$dau_address;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      stop: boolean,
      part_dau: dmt$dau_address,
      dau: dmt$dau_address,
      end_of_chain: boolean;

    status.normal := TRUE;
    IF (dau_index < 0) OR (dau_index >= p_dat^.header.number_of_entries) THEN
      osp$set_status_abnormal ('DM', 1, ' dau index out of range for device type', status);
    ELSE
      end_of_chain := FALSE;
      dau := dau_index;

      WHILE NOT end_of_chain DO

        display_dat_entry (display_control, dau, ^p_dat^.body [dau], status);

        CASE p_dat^.body [dau].dau_status OF
        = dmc$dau_usable, dmc$dau_hardware_flawed, dmc$dau_software_flawed,
              dmc$dau_assigned_to_mainframe, dmc$dau_ass_to_mf_swr_flawed =
          end_of_chain := TRUE;
        = dmc$dau_assigned_to_file, dmc$dau_ass_to_file_swr_flawed =

          CASE p_dat^.body [dau].allocation_chain_position OF
          = dmc$first_and_last_allocation, dmc$last_allocation =
            end_of_chain := TRUE;
          = dmc$part_of_allocation_unit =
            clp$put_display (display_control, '      is part of an allocation unit which begins with dau :',
                             clc$trim, status);
            part_dau := dau;
            stop := FALSE;
            REPEAT
              part_dau := part_dau - 1;
              IF part_dau < 0 THEN       {  something wrong, we've run off the end without finding start
                stop := TRUE;
                end_of_chain := TRUE;
              ELSE
                CASE p_dat^.body [part_dau].dau_status OF
                = dmc$dau_assigned_to_file, dmc$dau_ass_to_file_swr_flawed =
                  CASE p_dat^.body [part_dau].allocation_chain_position OF
                  = dmc$part_of_allocation_unit =
                    { keep going
                  ELSE
                    stop := TRUE;
                    dau := part_dau;
                  CASEND;
                ELSE
                  stop := TRUE;
                  end_of_chain := TRUE;
                CASEND;
              IFEND;
            UNTIL stop;

          = dmc$first_allocation, dmc$middle_allocation =
            dau := p_dat^.body [dau].next_allocation_unit_dau;
          ELSE
            end_of_chain := TRUE;
          CASEND;

        ELSE
          end_of_chain := TRUE;
        CASEND;
      WHILEND;
    IFEND;

  PROCEND display_user_alloc_chain;
?? TITLE := '  display_user_cylinders', EJECT ??

  PROCEDURE display_user_cylinders
    (    p_dat: ^dmt$ms_device_allocation_table;
         path: string ( * );
     VAR display_control: clt$display_control;
     VAR status: ost$status);

{
{  This procedure produces a display of the current state of cylinder
{ allocation on a volume.
{  Information provided is:
{          . some header information (date, time, cylinders per device, etc.)
{          . one line for each cylinder on the device stating the number of
{ the cylinder, the
{              allocation style assigned to the cylinder, whether or not the
{ cylinder is
{              'full', and how the daus are assigned within the cylinder
{ (assigned to file or
{              assigned to mainframe, or flawed)
{          . some summary information indicating the total numbers of daus by
{ assignment, and
{              numbers of cylinders assigned to each allocation style
{

    VAR
      device_type: t$device_type,
      line: string (80),
      l: integer,
      dau_index: dmt$dau_address,
      num_usable: integer,
      num_assigned_file: integer,
      num_assigned_mf: integer,
      num_flawed: integer,
      total_usable: integer,
      total_assigned_file: integer,
      total_assigned_mf: integer,
      total_flawed: integer,
      style_index: dmt$allocation_styles,
      styles_per_device: array [dmt$allocation_styles] of integer,
      cylinder_dau_address: dmt$dau_address,
      cylinder_index: dmt$device_position,
      assigned_style: dmt$allocation_styles,
      skip_position,
      style_available: boolean;

    status.normal := TRUE;

    determine_device_type (p_dat, device_type, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR style_index := LOWERVALUE (dmt$allocation_styles)
          TO UPPERVALUE (dmt$allocation_styles) DO
      styles_per_device [style_index] := 0;
    FOREND;

    total_usable := 0;
    total_assigned_file := 0;
    total_assigned_mf := 0;
    total_flawed := 0;

    line (1, * ) := ' CYLINDERS: ';
    line (13, * ) := path;

    clp$new_display_page (display_control, status);
    clp$put_display (display_control, line, clc$trim, status);
    clp$new_display_line (display_control, 1, status);

    clp$put_partial_display (display_control, ' daus/cyl = ', clc$no_trim,
          amc$start, status);
    STRINGREP (line (1, 10), l, p_dat^.header.daus_per_position);
    clp$put_partial_display (display_control, line (1, l), clc$no_trim,
          amc$continue, status);
    clp$put_partial_display (display_control, '  cyl/device = ', clc$no_trim,
          amc$continue, status);
    STRINGREP (line (1, 10), l, p_dat^.header.positions_per_device);
    clp$put_partial_display (display_control, line (1, l), clc$trim,
          amc$terminate, status);
    clp$new_display_line (display_control, 1, status);

    line (1, * ) := ' CYLINDER ALLOCATION  DAUs  ASSGND ASSGND';
    clp$put_display (display_control, line, clc$trim, status);
    line (1, * ) := '  NUMBER    STYLE    USABLE  FILE    MF   FLAWED';
    clp$put_display (display_control, line, clc$trim, status);
    clp$new_display_line (display_control, 1, status);

{
{  For each cylinder, write a line describing the cylinder's style and how the
{ daus within the
{  cylinder are assigned.
{

  /display_cylinders/
    FOR cylinder_index := 0 TO p_dat^.header.positions_per_device - 1 DO
      line (1, * ) := ' ';
      STRINGREP (line (3, 5), l, cylinder_index);
      deter_style_assigned_to_pos (cylinder_index,
            p_dat^.header.daus_per_position, p_dat, assigned_style,
            style_available, skip_position, status);

      IF status.normal THEN
        IF NOT skip_position THEN
          CASE assigned_style OF
          = dmc$a0 =
            line (9, * ) := 'a0';
          = dmc$a1 =
            line (9, * ) := 'a1';
            line (12, * ) := '*';
          = dmc$a2 =
            line (9, * ) := 'a2';
            line (12, * ) := '**';
          = dmc$a3 =
            line (9, * ) := 'a3';
            line (12, * ) := '***';
          = dmc$a4 =
            line (9, * ) := 'a4';
            line (12, * ) := '****';
          = dmc$a5 =
            line (9, * ) := 'a5';
            line (12, * ) := '*****';
          = dmc$a6 =
            line (9, * ) := 'a6';
            line (12, * ) := '******';
          = dmc$a7 =
            line (9, * ) := 'a7';
            line (12, * ) := '*******';
          = dmc$a8 =
            line (9, * ) := 'a8';
            line (12, * ) := '********';
          = dmc$acyl =
            line (9, * ) := 'cy';
            line (12, * ) := '**********';
          ELSE
            line (12, * ) := 'NO STYLE';
          CASEND;

          styles_per_device [assigned_style] :=
                styles_per_device [assigned_style] + 1;

        ELSE {skip position}
          line (12, * ) := 'NO STYLE';
        IFEND;

        num_usable := 0;
        num_assigned_file := 0;
        num_assigned_mf := 0;
        num_flawed := 0;

        cylinder_dau_address := cylinder_index *
              p_dat^.header.daus_per_position;

        FOR dau_index := 0 TO p_dat^.header.daus_per_position - 1 DO
          CASE p_dat^.body [cylinder_dau_address + dau_index].dau_status OF
          = dmc$dau_usable =
            num_usable := num_usable + 1;
          = dmc$dau_assigned_to_file =
            num_assigned_file := num_assigned_file + 1;
          = dmc$dau_assigned_to_mainframe =
            num_assigned_mf := num_assigned_mf + 1;
          = dmc$dau_hardware_flawed, dmc$dau_software_flawed,
                dmc$dau_ass_to_mf_swr_flawed, dmc$dau_ass_to_file_swr_flawed =
            num_flawed := num_flawed + 1;
          ELSE
          CASEND;
        FOREND;

        total_usable := total_usable + num_usable;
        total_assigned_file := total_assigned_file + num_assigned_file;
        total_assigned_mf := total_assigned_mf + num_assigned_mf;
        total_flawed := total_flawed + num_flawed;

        STRINGREP (line (23, 6), l, num_usable);
        STRINGREP (line (30, 6), l, num_assigned_file);
        STRINGREP (line (37, 6), l, num_assigned_mf);
        STRINGREP (line (44, 6), l, num_flawed);

        IF NOT style_available THEN
          IF num_assigned_file = p_dat^.header.daus_per_position THEN
            line (50, * ) := 'FULL CYLINDER';
          ELSEIF num_assigned_mf = p_dat^.header.daus_per_position THEN
            line (50, * ) := 'FULL, ASSIGNED TO MAINFRAME';
          ELSEIF num_flawed = p_dat^.header.daus_per_position THEN
            line (50, * ) := 'FULL AND FLAWED';
          ELSE
            line (50, * ) := 'STYLE UNAVAILABLE';
          IFEND;
        IFEND;

      ELSE {bad status}
        line (12, * ) := status.text.value;
      IFEND;

      clp$put_display (display_control, line, clc$trim, status);

    FOREND /display_cylinders/;

{
{  Write summary (totals) information
{

    clp$new_display_line (display_control, 2, status);

    clp$put_display (display_control, '  TOTAL DAUS ON DEVICE :', clc$trim,
          status);
    clp$new_display_line (display_control, 1, status);
    line (1, * ) := ' ';
    STRINGREP (line, l, '   usable daus =', total_usable);
    clp$put_display (display_control, line, clc$trim, status);
    line (1, * ) := ' ';
    STRINGREP (line, l, '   daus assigned to file =', total_assigned_file);
    clp$put_display (display_control, line, clc$trim, status);
    line (1, * ) := ' ';
    STRINGREP (line, l, '   daus assigned to mainframe =', total_assigned_mf);
    clp$put_display (display_control, line, clc$trim, status);
    line (1, * ) := ' ';
    STRINGREP (line, l, '   flawed daus =', total_flawed);
    clp$put_display (display_control, line, clc$trim, status);

    clp$new_display_line (display_control, 1, status);
    clp$put_display (display_control, '  TOTAL CYLINDERS BY STYLE :', clc$trim,
          status);
    clp$new_display_line (display_control, 1, status);

    line (1, * ) := ' ';
    STRINGREP (line, l, '   a0=', styles_per_device [dmc$a0], ' a1=',
          styles_per_device [dmc$a1], ' a2=', styles_per_device [dmc$a2],
          ' a3=', styles_per_device [dmc$a3],
          ' a4=', styles_per_device [dmc$a4]);
    clp$put_display (display_control, line, clc$trim, status);

    line (1, * ) := ' ';
    STRINGREP (line, l, '   a5=', styles_per_device [dmc$a5], ' a6=',
          styles_per_device [dmc$a6], ' a7=', styles_per_device [dmc$a7],
          ' a8=', styles_per_device [dmc$a8],
          ' cyl=', styles_per_device [dmc$acyl]);
    clp$put_display (display_control, line, clc$trim, status);
    clp$new_display_line (display_control, 1, status);

    clp$put_display (display_control, ' END CYLINDERS', clc$trim, status);
    clp$new_display_line (display_control, 1, status);

  PROCEND display_user_cylinders;
?? TITLE := '  display_user_cylinders_daus', EJECT ??

  PROCEDURE display_user_cylinders_daus
    (    p_dat: ^dmt$ms_device_allocation_table;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    CONST
      columns = 'A123456789B123456789C123456789D123456789E123456789F123456789G123456789H123456789';

    VAR
      char_array: [STATIC] array [dmt$dau_status] of string (1) := [' ', 'h', 's', 'M', 'F', 'm', 'f'],
      device_type: t$device_type,
      step: 0 .. 4,
      line: string (80),
      l: integer,
      dau_index: dmt$dau_address,
      cylinder_dau_address: dmt$dau_address,
      cylinder_index: dmt$device_position;

    status.normal := TRUE;

    determine_device_type (p_dat, device_type, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    line (1, * ) := ' CYLINDERS: ';
    line (13, * ) := device_type_string [device_type];
    IF (device_type = c$844) OR (device_type = c$885) THEN
      line (25, * ) := ' in 16K allocation units.';
      step := 4;
    ELSE
      line (25, * ) := ' in 16K device allocation units.';
      step := 1;
    IFEND;
    clp$put_display (display_control, line, clc$trim, status);

    line (1, *) := ' KEY:  F = assigned to file  M = assigned to mainframe  <blank> = usable';
    clp$put_display (display_control, line, clc$trim, status);
    line (1, *) := '       s = software flawed   h = hardware flawed  f = assigned to file flawed';
    clp$put_display (display_control, line, clc$trim, status);
    line (1, *) := '       m = assigned to mainframe software flawed';
    clp$put_display (display_control, line, clc$trim, status);
    line (1, *) := ' NOTE: cannot distinguish between assigned to mainframe and';
    clp$put_display (display_control, line, clc$trim, status);
    line (1, *) := '       assigned to temporary file.';
    clp$put_display (display_control, line, clc$trim, status);

    clp$new_display_line (display_control, 1, status);
    clp$put_display (display_control, columns, clc$trim, status);

  /display_cylinders/
    FOR cylinder_index := 0 TO p_dat^.header.positions_per_device - 1 DO
      dau_index := 0;
      line (1, * ) := ' ';

      IF (cylinder_index MOD 25) = 0 THEN
        STRINGREP (line, l, ' next cylinder is number ', cylinder_index);
        clp$put_display (display_control, line, clc$trim,status);
        line (1, *) := ' ';
      IFEND;

      cylinder_dau_address := cylinder_index * p_dat^.header.daus_per_position;

      WHILE dau_index < p_dat^.header.daus_per_position DO
        IF (dau_index MOD step) = 0 THEN
          line ((dau_index DIV step) + 1, 1) :=
            char_array [p_dat^.body [cylinder_dau_address + dau_index].dau_status];
        IFEND;
        dau_index := dau_index + 1;
      WHILEND;

      clp$put_display (display_control, line, clc$trim, status);

    FOREND /display_cylinders/;

    clp$new_display_line (display_control, 1, status);

    clp$put_display (display_control, ' END CYLINDERS', clc$trim, status);
    clp$new_display_line (display_control, 1, status);

  PROCEND display_user_cylinders_daus;
?? TITLE := '  display_user_dat', EJECT ??

  PROCEDURE display_user_dat
    (    p_dat: ^dmt$ms_device_allocation_table;
         path: string (*);
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      p_dat_entry: ^dmt$ms_device_allocation_unit,
      previous_status: dmt$dau_status,
      previous_count: integer,
      integer_string: string (osc$max_string_size),
      integer_length: integer,
      duplicate_entry_string: string (32),
      dat_index: dmt$dau_address,
      title_string: string (80),
      mainframe_id: dmt$mainframe_assigned;

    status.normal := TRUE;

  /display_dat/
    BEGIN

      title_string (1, * ) := 'DEVICE ALLOCATION TABLE : ';
      title_string (27, *) := path;

      clp$put_display (display_control, title_string, clc$trim, status);

      display_dat_header (display_control, p_dat^.header, status);
      IF NOT status.normal THEN
        EXIT /display_dat/;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        EXIT /display_dat/;
      IFEND;

      clp$put_display (display_control, 'Device Allocation Table', clc$trim, status);

      IF p_dat^.body [0].dau_status = dmc$dau_usable THEN
        previous_status := dmc$dau_hardware_flawed;
      ELSE
        previous_status := dmc$dau_usable;
      IFEND;
      previous_count := 0;
      duplicate_entry_string := '              Duplicate Entry(s)';

    /display_dat_entries/
      FOR dat_index := 0 TO p_dat^.header.number_of_entries - 1 DO

        p_dat_entry := ^p_dat^.body [dat_index];

        CASE p_dat_entry^.dau_status OF
        = dmc$dau_usable =
          IF previous_status = dmc$dau_usable THEN
            previous_count := previous_count + 1;
            CYCLE /display_dat_entries/;
          IFEND;

          IF previous_count <> 0 THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
          IFEND;

          previous_status := dmc$dau_usable;
          previous_count := 0;
        = dmc$dau_hardware_flawed =
          IF previous_status = dmc$dau_hardware_flawed THEN
            previous_count := previous_count + 1;
            CYCLE /display_dat_entries/;
          IFEND;

          IF previous_count <> 0 THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
          IFEND;

          previous_status := dmc$dau_hardware_flawed;
          previous_count := 0;
        = dmc$dau_software_flawed =
          IF previous_status = dmc$dau_software_flawed THEN
            previous_count := previous_count + 1;
            CYCLE /display_dat_entries/;
          IFEND;

          IF previous_count <> 0 THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
          IFEND;

          previous_status := dmc$dau_software_flawed;
          previous_count := 0;
        = dmc$dau_assigned_to_mainframe =
          IF previous_status = dmc$dau_assigned_to_mainframe THEN
            IF mainframe_id = p_dat_entry^.mainframe_id THEN
              previous_count := previous_count + 1;
              CYCLE /display_dat_entries/;
            IFEND;
          IFEND;

          IF previous_count <> 0 THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
          IFEND;

          previous_status := dmc$dau_assigned_to_mainframe;
          previous_count := 0;
          mainframe_id := p_dat_entry^.mainframe_id;
        = dmc$dau_assigned_to_file =
          IF previous_count <> 0 THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
          IFEND;

          previous_status := dmc$dau_assigned_to_file;
          previous_count := 0;
        = dmc$dau_ass_to_mf_swr_flawed =
          IF previous_status = dmc$dau_ass_to_mf_swr_flawed THEN
            IF mainframe_id = p_dat_entry^.mainframe_id THEN
              previous_count := previous_count + 1;
              CYCLE /display_dat_entries/;
            IFEND;
          IFEND;

          IF previous_count <> 0 THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
          IFEND;

          previous_status := dmc$dau_ass_to_mf_swr_flawed;
          previous_count := 0;
          mainframe_id := p_dat_entry^.mainframe_id;
        = dmc$dau_ass_to_file_swr_flawed =
          IF previous_count <> 0 THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
          IFEND;

          previous_status := dmc$dau_ass_to_file_swr_flawed;
          previous_count := 0;

        CASEND;

        display_dat_entry (display_control, dat_index, p_dat_entry, status);
        IF NOT status.normal THEN
          EXIT /display_dat/;
        IFEND;
      FOREND /display_dat_entries/;

      IF previous_count <> 0 THEN
        STRINGREP (integer_string, integer_length, previous_count);
        duplicate_entry_string (8, 6) := '      ';
        duplicate_entry_string (8, integer_length) := integer_string;

        clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display_dat/;
        IFEND;
      IFEND;

    END /display_dat/;

  PROCEND display_user_dat;
?? TITLE := '  display_user_dat_entry', EJECT ??

  PROCEDURE display_user_dat_entry
    (    p_dat: ^dmt$ms_device_allocation_table;
         dau_index: dmt$dau_address;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    status.normal := TRUE;

    IF (dau_index < 0) OR (dau_index >= p_dat^.header.number_of_entries) THEN
      osp$set_status_abnormal ('DM', 1, ' dau index out of range for device', status);
    ELSE
      display_dat_entry (display_control, dau_index, ^p_dat^.body[dau_index], status);
    IFEND;

  PROCEND display_user_dat_entry;
?? TITLE := '  display_user_dat_header', EJECT ??

  PROCEDURE display_user_dat_header
    (    p_dat: ^dmt$ms_device_allocation_table;
         path: string ( * );
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      title_string: string (132);

    status.normal := TRUE;

    title_string (1, * ) := 'DEVICE ALLOCATION TABLE : ';
    title_string (27, * ) := path;
    clp$put_display (display_control, title_string, clc$trim, status);

    display_dat_header (display_control, p_dat^.header, status);

  PROCEND display_user_dat_header;
?? TITLE := ' display_user_device_type', EJECT ??

  PROCEDURE display_user_device_type
    (    p_dat: ^dmt$ms_device_allocation_table;
         path: string ( * );
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      str: string (80),
      l: integer,
      device_type: t$device_type;

    status.normal := TRUE;

    clp$put_display (display_control, path, clc$trim, status);

    determine_device_type (p_dat, device_type, status);

    IF status.normal THEN
      STRINGREP (str, l, ' Device type is ', device_type_string [device_type]);
      clp$put_display (display_control, str (1, l), clc$trim, status);
    ELSE
      clp$put_display (display_control, ' Device type is unknown ...', clc$trim, status);
    IFEND;

  PROCEND display_user_device_type;
?? TITLE := '  display_user_dfl', EJECT ??

  PROCEDURE display_user_dfl
    (    p_dfl: ^dmt$ms_device_file_list_table;
         path: string (*);
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
         summary_listing: boolean,
         full_listing: boolean,
         file_index: dmt$device_file_list_index,
      p_dfl_entry: ^dmt$ms_device_file_list_entry,
      previous_status: dmt$dfl_entry_flags,
      previous_count: integer,
      integer_string: string (osc$max_string_size),
      type_index: gft$file_kind,
      flag_index: dmt$dfl_entry_flags,
      integer_length: integer,
      duplicate_entry_string: string (32),
      summary_string: string (80),
      dfl_index: dmt$device_file_list_index,
      file_type_count: array [gft$file_kind] of integer,
      file_flag_count: array [dmt$dfl_entry_flags] of integer,
      mainframe_assigned: dmt$mainframe_assigned;

    status.normal := TRUE;
    full_listing := true;
    summary_listing := true;

  /display_device_file/
    BEGIN

      clp$new_display_page (display_control, status);
      summary_string (1, *) := 'DEVICE FILE LIST : ';
      summary_string (20, *) := path;
      clp$put_display (display_control, summary_string, clc$trim, status);

      display_dfl_header (display_control, ^p_dfl^.header, status);
      IF NOT status.normal THEN
        EXIT /display_device_file/;
      IFEND;

      IF p_dfl^.entries [1].flags = dmc$dfle_available THEN
        previous_status := dmc$dfle_assigned_to_mainframe;
      ELSE
        previous_status := dmc$dfle_available
      IFEND;
      previous_count := 0;
      duplicate_entry_string := '              Duplicate Entry(s)';

      FOR type_index := LOWERVALUE (gft$file_kind) TO UPPERVALUE (gft$file_kind) DO
        file_type_count [type_index] := 0;
      FOREND;

      FOR flag_index := LOWERVALUE (dmt$dfl_entry_flags) TO UPPERVALUE (dmt$dfl_entry_flags) DO
        file_flag_count [flag_index] := 0;
      FOREND;

    /display_dfl_entries/
      FOR dfl_index := 1 TO p_dfl^.header.number_of_entries DO

        p_dfl_entry := ^p_dfl^.entries [dfl_index];
        file_flag_count [p_dfl_entry^.flags] := file_flag_count [p_dfl_entry^.flags] + 1;

        CASE p_dfl_entry^.flags OF

        = dmc$dfle_available =

          IF previous_status = dmc$dfle_available THEN
            previous_count := previous_count + 1;
            IF (NOT full_listing) AND (file_index = dfl_index) THEN
              display_dfl_entry (display_control, dfl_index, p_dfl_entry, status);
              CYCLE /display_dfl_entries/;
            ELSE
              CYCLE /display_dfl_entries/;
            IFEND;
          IFEND;

          IF (previous_count <> 0) AND (full_listing) THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
            clp$new_display_line (display_control, 1, status);
          IFEND;

          previous_status := dmc$dfle_available;
          previous_count := 0;

        = dmc$dfle_assigned_to_mainframe =

          IF previous_status = dmc$dfle_assigned_to_mainframe THEN
            IF mainframe_assigned = p_dfl_entry^.mainframe_assigned THEN
              previous_count := previous_count + 1;
              IF (NOT full_listing) AND (file_index = dfl_index) THEN
                display_dfl_entry (display_control, dfl_index, p_dfl_entry, status);
                CYCLE /display_dfl_entries/;
              ELSE
                CYCLE /display_dfl_entries/;
              IFEND;
            IFEND;
          IFEND;

          IF (previous_count <> 0) AND (full_listing) THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
            clp$new_display_line (display_control, 1, status);
          IFEND;

          previous_status := dmc$dfle_assigned_to_mainframe;
          previous_count := 0;

          mainframe_assigned := p_dfl_entry^.mainframe_assigned;

        = dmc$dfle_assigned_to_file =

          IF (previous_count <> 0) AND (full_listing) THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
            clp$new_display_line (display_control, 1, status);
          IFEND;

          file_type_count [p_dfl_entry^.file_kind] := file_type_count [p_dfl_entry^.file_kind] + 1;
          previous_status := dmc$dfle_assigned_to_file;
          previous_count := 0;
        ELSE;
        CASEND;

        IF (NOT full_listing) AND (file_index = dfl_index) THEN
          display_dfl_entry (display_control, dfl_index, p_dfl_entry, status);
          IF NOT status.normal THEN
            EXIT /display_device_file/;
          IFEND;
        ELSEIF (full_listing) THEN
          display_dfl_entry (display_control, dfl_index, p_dfl_entry, status);
          IF NOT status.normal THEN
            EXIT /display_device_file/;
          IFEND;
        IFEND;

      FOREND /display_dfl_entries/;

      IF (previous_count <> 0) AND (full_listing) THEN
        STRINGREP (integer_string, integer_length, previous_count);
        duplicate_entry_string (8, 6) := '      ';
        duplicate_entry_string (8, integer_length) := integer_string;

        clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
      IFEND;

      IF summary_listing THEN

        clp$new_display_line (display_control, 1, status);
        clp$put_display (display_control, ' Summary:', clc$trim, status);
        clp$new_display_line (display_control, 1, status);

      /file_flag_summary/
        FOR flag_index := LOWERVALUE (dmt$dfl_entry_flags) TO UPPERVALUE (dmt$dfl_entry_flags) DO
          CASE flag_index OF
          = dmc$dfle_available =
            summary_string := '  Number of available entries             -       ';

          = dmc$dfle_assigned_to_mainframe =
            summary_string := '  Number of assigned to mainframe entries -       ';

          = dmc$dfle_assigned_to_file =
            summary_string := '  Number of assigned to file entries      -       ';
          ELSE;
          CASEND;

          STRINGREP (integer_string, integer_length, file_flag_count [flag_index]);
          summary_string (44, integer_length) := integer_string;
          clp$put_display (display_control, summary_string, clc$trim, status);
        FOREND /file_flag_summary/;

        summary_string := '     File Type -                   Number of Entries -             ';

      /assigned_file_summary/
        FOR type_index := LOWERVALUE (gft$file_kind) TO UPPERVALUE (gft$file_kind) DO
          summary_string (55, * ) := ' ';
          CASE type_index OF
          = gfc$fk_job_permanent_file =
            summary_string (18, 12) := 'Permanent   ';
          = gfc$fk_device_file =
            summary_string (18, 12) := 'Device      ';
          = gfc$fk_job_local_file =
            summary_string (18, 12) := 'Temp Named  ';
          = gfc$fk_unnamed_file =
            summary_string (18, 12) := 'Temp Unnamed';
          = gfc$fk_global_unnamed =
            summary_string (18, 12) := 'Temp Global ';
          = gfc$fk_catalog =
            summary_string (18, 12) := 'Catalog     ';
          ELSE;
          CASEND;

          STRINGREP (integer_string, integer_length, file_type_count [type_index]);
          summary_string (55, integer_length) := integer_string;
          clp$put_display (display_control, summary_string, clc$trim, status);
        FOREND /assigned_file_summary/;
      IFEND;

    END /display_device_file/;

  PROCEND display_user_dfl;
?? TITLE := ' display_user_dfl_entry', EJECT ??

  PROCEDURE display_user_dfl_entry
    (    p_dfl: ^dmt$ms_device_file_list_table;
         dfl_index: dmt$device_file_list_index;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    status.normal := TRUE;

    IF (dfl_index < 1) OR (dfl_index > p_dfl^.header.number_of_entries) THEN
      osp$set_status_abnormal ('DM', 1,
            ' dfl index out of range for device type', status);
    ELSE
      display_dfl_entry (display_control, dfl_index, ^p_dfl^.
            entries [dfl_index], status);
    IFEND;

  PROCEND display_user_dfl_entry;
?? TITLE := ' display_user_dir_entry', EJECT ??

  PROCEDURE display_user_dir_entry
    (    p_directory: ^dmt$ms_volume_directory;
         entry_index: dmt$directory_index;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    status.normal := TRUE;
    IF (entry_index < 1) OR (entry_index > p_directory^.header.number_of_entries) THEN
      osp$set_status_abnormal ('DM', 1, ' entry index out of range for device', status);
    ELSE
      display_directory_entry (display_control, p_directory^.entries [entry_index], status);
    IFEND;

  PROCEND display_user_dir_entry;
?? TITLE := '  display_user_directory', EJECT ??

  PROCEDURE display_user_directory
    (    p_directory: ^dmt$ms_volume_directory;
         path: string ( * );

     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      dir_entry: dmt$ms_volume_directory_entry,
      integer_string: ost$string,
      title_string: string (80),
      previous_count: integer,
      integer_length: integer,
      duplicate_entry_string: string (32),
      previous_status: boolean,
      directory_index: dmt$directory_index;

    status.normal := TRUE;

  /display_directory/
    BEGIN

      title_string (1, * ) := 'DIRECTORY : ';
      title_string (13, * ) := path;

      clp$put_display (display_control, title_string, clc$trim, status);

      clp$put_partial_display (display_control, '  Number Of Entries - ', clc$no_trim, amc$start, status);
      clp$convert_integer_to_string (p_directory^.header.number_of_entries, 10, FALSE, integer_string,
            status);
      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);

      previous_count := 0;
      previous_status := FALSE;
      duplicate_entry_string := '             Duplicate Entrie(s)';

    /display_directory_entries/
      FOR directory_index := 1 TO p_directory^.header.number_of_entries DO

        dir_entry := p_directory^.entries [directory_index];

        IF dir_entry.entry_available THEN
          IF previous_status = TRUE THEN
            ;
            previous_count := previous_count + 1;
            CYCLE /display_directory_entries/;
          IFEND;
          previous_status := TRUE;
        IFEND;

        IF previous_count <> 0 THEN
          STRINGREP (integer_string.value, integer_length, previous_count);
          duplicate_entry_string (8, 6) := '      ';
          duplicate_entry_string (8, integer_length) := integer_string.value;

          clp$new_display_line (display_control, 1, status);
          clp$put_display (display_control, duplicate_entry_string, clc$trim, status);

          previous_count := 0;
          previous_status := FALSE;
        IFEND;

        clp$convert_integer_to_string (directory_index, 10, FALSE, integer_string, status);
        clp$new_display_line (display_control, 1, status);
        clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
              amc$start, status);
        clp$put_partial_display (display_control, '. Directory Entry', clc$trim, amc$terminate, status);

        display_directory_entry (display_control, dir_entry, status);
        IF NOT status.normal THEN
          EXIT /display_directory_entries/;
        IFEND;
      FOREND /display_directory_entries/;

      IF previous_count <> 0 THEN
        STRINGREP (integer_string.value, integer_length, previous_count);
        duplicate_entry_string (8, 6) := '      ';
        duplicate_entry_string (8, integer_length) := integer_string.value;

        clp$new_display_line (display_control, 1, status);
        clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
      IFEND;
    END /display_directory/;

  PROCEND display_user_directory;
?? TITLE := '  get_device_characteristics', EJECT ??

  PROCEDURE get_device_characteristics
    (    device_type: t$device_type;
     VAR device_characteristics: t$physical_characteristics;
     VAR status: ost$status);

    status.normal := TRUE;

    IF (device_type < LOWERVALUE (t$device_type)) OR (device_type > UPPERVALUE (t$device_type)) THEN
      osp$set_status_abnormal ('DM', 1, ' unknown device type - get_device_characteristics', status);
    ELSE
      device_characteristics := physical_characteristics [device_type];
    IFEND;

  PROCEND get_device_characteristics;
?? TITLE := '  open', EJECT ??

  PROCEDURE open
    (    file: clt$value;
     VAR file_id: amt$file_identifier;
     VAR segp: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      ao: [STATIC] array [1 .. 2] of fst$attachment_option := [[fsc$create_file, FALSE],
            [fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$read]],
            [fsc$specific_share_modes, [fsc$read, fsc$execute]]]],
      ignore: ost$status;

    status.normal := TRUE;

    fsp$open_file (file.file.local_file_name, amc$segment, ^ao, NIL, NIL, NIL, NIL, file_id, status);
    IF status.normal THEN
      amp$get_segment_pointer (file_id, amc$sequence_pointer, segp, status);
      IF NOT status.normal THEN
        fsp$close_file (file_id, ignore);
      IFEND;
    IFEND;

  PROCEND open;
?? TITLE := '  open_file_as_dat', EJECT ??

  PROCEDURE open_file_as_dat
    (    file: clt$value;
     VAR status: ost$status);

    VAR
      container: clt$path_container,
      path: ^pft$path,
      selector: clt$cycle_selector,
      op: clt$open_position,
      segp: amt$segment_pointer,
      p_seq: ^SEQ ( * ),
      p_dat_header: ^dmt$ms_device_alloc_table_head,
      entries: dmt$dau_address;

    status.normal := TRUE;

    open (file, global_dat_file_id, segp, status);
    IF status.normal THEN
      p_seq := segp.sequence_pointer;
      RESET p_seq;
      NEXT p_dat_header IN p_seq;
      IF p_dat_header <> NIL THEN
        entries := p_dat_header^.number_of_entries;
        RESET p_seq;
        NEXT global_p_dat: [0 .. entries - 1] IN p_seq;
      IFEND;
      clp$get_path_description (file.file, global_dat_path, container, path, selector, op, status);
    IFEND;

  PROCEND open_file_as_dat;
?? TITLE := '  open_file_as_dfl', EJECT ??

  PROCEDURE open_file_as_dfl
    (    file: clt$value;
     VAR status: ost$status);

    VAR
      container: clt$path_container,
      path: ^pft$path,
      selector: clt$cycle_selector,
      op: clt$open_position,
      segp: amt$segment_pointer,
      p_seq: ^SEQ ( * ),
      p_dfl_header: ^dmt$ms_device_file_list_header,
      entries: dmt$device_file_list_index;

    status.normal := TRUE;

    open (file, global_dfl_file_id, segp, status);
    IF status.normal THEN
      p_seq := segp.sequence_pointer;
      RESET p_seq;
      NEXT p_dfl_header IN p_seq;
      IF p_dfl_header <> NIL THEN
        entries := p_dfl_header^.number_of_entries;
        RESET p_seq;
        NEXT global_p_dfl: [1 .. entries] IN p_seq;
      IFEND;
      clp$get_path_description (file.file, global_dfl_path, container, path, selector, op, status);
    IFEND;

  PROCEND open_file_as_dfl;
?? TITLE := '  open_file_as_directory', EJECT ??

  PROCEDURE open_file_as_directory
    (    file: clt$value;
     VAR status: ost$status);

    VAR
      container: clt$path_container,
      path: ^pft$path,
      selector: clt$cycle_selector,
      op: clt$open_position,
      segp: amt$segment_pointer,
      p_seq: ^SEQ ( * ),
      p_directory_header: ^dmt$ms_volume_directory_head,
      entries: dmt$directory_index;

    status.normal := TRUE;

    open (file, global_directory_file_id, segp, status);
    IF status.normal THEN
      p_seq := segp.sequence_pointer;
      RESET p_seq;
      NEXT p_directory_header IN p_seq;
      IF p_directory_header <> NIL THEN
        entries := p_directory_header^.number_of_entries;
        RESET p_seq;
        NEXT global_p_directory: [1 .. entries] IN p_seq;
      IFEND;
      clp$get_path_description (file.file, global_directory_path, container, path, selector, op, status);
    IFEND;

  PROCEND open_file_as_directory;
?? TITLE := '  quit_command', EJECT ??

  PROCEDURE quit_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT status_pdt (status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    status_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^status_pdt_names,
  ^status_pdt_params];

  VAR
    status_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
  clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    status_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, status_pdt, status);

    clp$end_scan_command_file (utility_name, status);

  PROCEND quit_command;
?? TITLE := '  sum_allocated_space_command', EJECT ??

  PROCEDURE sum_allocated_space_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT status_pdt (status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    status_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^status_pdt_names,
  ^status_pdt_params];

  VAR
    status_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
  clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    status_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      status2: ost$status;

    status2.normal := TRUE;
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, status_pdt, status);
    IF status.normal THEN
      clp$new_display_page (display_control, status);
      clp$put_display (display_control, 'SUM_ALLOCATED_SPACE', clc$trim, status);
      clp$new_display_line (display_control, 1, status);
      IF global_p_dfl = NIL THEN
        osp$set_status_abnormal ('DM', 1, ' dfl not open - info unavailable', status);
      ELSE
        sum_dfl_space (global_p_dfl, display_control, status);
      IFEND;
      status2 := status;
      clp$new_display_line (display_control, 1, status);
      IF global_p_dat = NIL THEN
        osp$set_status_abnormal ('DM', 1, ' dat not open - info unavailable', status);
      ELSE
        sum_dat_space (global_p_dat, display_control, status);
      IFEND;
    IFEND;
    IF status.normal AND (NOT status2.normal) THEN
      status := status2;
    IFEND;

  PROCEND sum_allocated_space_command;
?? TITLE := '  sum_dat_space', EJECT ??

  PROCEDURE sum_dat_space
    (    p_dat: ^dmt$ms_device_allocation_table;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      p_dat_entry: ^dmt$ms_device_allocation_unit,
      str: string (80),
      l: integer,
      device_type: t$device_type,
      total_bytes: integer,
      total_daus: integer,
      num_usable: integer,
      num_hardware_flawed: integer,
      num_software_flawed: integer,
      num_assigned_to_mainframe: integer,
      num_assigned_to_file: integer,
      num_ass_to_mf_swr_flawed: integer,
      num_ass_to_file_swr_flawed: integer,
      bytes_usable: integer,
      bytes_hardware_flawed: integer,
      bytes_software_flawed: integer,
      bytes_assigned_to_mainframe: integer,
      bytes_assigned_to_file: integer,
      bytes_ass_to_mf_swr_flawed: integer,
      bytes_ass_to_file_swr_flawed: integer,
      bytes_per_dau: dmt$dau_address,
      dat_index: dmt$dau_address;

    status.normal := TRUE;
    bytes_per_dau := p_dat^.header.bytes_per_dau;
    num_usable := 0;
    num_hardware_flawed := 0;
    num_software_flawed := 0;
    num_assigned_to_mainframe := 0;
    num_assigned_to_file := 0;
    num_ass_to_mf_swr_flawed := 0;
    num_ass_to_file_swr_flawed := 0;
    bytes_usable := 0;
    bytes_hardware_flawed := 0;
    bytes_software_flawed := 0;
    bytes_assigned_to_mainframe := 0;
    bytes_assigned_to_file := 0;
    bytes_ass_to_mf_swr_flawed := 0;
    bytes_ass_to_file_swr_flawed := 0;

    determine_device_type (p_dat, device_type, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    str (1, * ) := ' From device allocation table:';
    clp$put_display (display_control, str, clc$trim, status);

    FOR dat_index := 0 TO p_dat^.header.number_of_entries - 1 DO
      p_dat_entry := ^p_dat^.body [dat_index];
      CASE p_dat_entry^.dau_status OF
      = dmc$dau_usable =
        num_usable := num_usable + 1;
        bytes_usable := bytes_usable + bytes_per_dau;
      = dmc$dau_hardware_flawed =
        num_hardware_flawed := num_hardware_flawed + 1;
        bytes_hardware_flawed := bytes_hardware_flawed + bytes_per_dau;
      = dmc$dau_software_flawed =
        num_software_flawed := num_software_flawed + 1;
        bytes_software_flawed := bytes_software_flawed + bytes_per_dau;
      = dmc$dau_assigned_to_mainframe =
        num_assigned_to_mainframe := num_assigned_to_mainframe + 1;
        bytes_assigned_to_mainframe := bytes_assigned_to_mainframe + bytes_per_dau;
      = dmc$dau_assigned_to_file =
        num_assigned_to_file := num_assigned_to_file + 1;
        bytes_assigned_to_file := bytes_assigned_to_file + bytes_per_dau;
      = dmc$dau_ass_to_mf_swr_flawed =
        num_ass_to_mf_swr_flawed := num_ass_to_mf_swr_flawed + 1;
        bytes_ass_to_mf_swr_flawed := bytes_ass_to_mf_swr_flawed + bytes_per_dau;
      = dmc$dau_ass_to_file_swr_flawed =
        num_ass_to_file_swr_flawed := num_ass_to_file_swr_flawed + 1;
        bytes_ass_to_file_swr_flawed := bytes_ass_to_file_swr_flawed + bytes_per_dau;
      ELSE
      CASEND;
    FOREND;
    total_bytes := bytes_assigned_to_file + bytes_usable + bytes_hardware_flawed + bytes_software_flawed +
                   bytes_assigned_to_mainframe + bytes_ass_to_file_swr_flawed + bytes_ass_to_mf_swr_flawed;
    total_daus  := num_assigned_to_file + num_usable + num_hardware_flawed + num_software_flawed +
                   num_assigned_to_mainframe + num_ass_to_file_swr_flawed + num_ass_to_mf_swr_flawed;
    clp$put_display (display_control, '     # daus      bytes         assigned to', clc$trim, status);
    str (1, *) := ' ';
    stringrep (str (5, *), l, num_assigned_to_file);
    stringrep (str (17, *), l, bytes_assigned_to_file);
    str (32, *) := 'file';
    clp$put_display (display_control, str, clc$trim, status);
    str (1, *) := ' ';
    stringrep (str (5, *), l, num_ass_to_file_swr_flawed);
    stringrep (str (17, *), l, bytes_ass_to_file_swr_flawed);
    str (32, *) := 'file (flawed)';
    clp$put_display (display_control, str, clc$trim, status);
    str (1, *) := ' ';
    stringrep (str (5, *), l, num_assigned_to_mainframe);
    stringrep (str (17, *), l, bytes_assigned_to_mainframe);
    str (32, *) := 'mainframe table (MAT) or temp files';
    clp$put_display (display_control, str, clc$trim, status);
    str (1, *) := ' ';
    stringrep (str (5, *), l, num_ass_to_mf_swr_flawed);
    stringrep (str (17, *), l, bytes_ass_to_mf_swr_flawed);
    str (32, *) := 'mainframe table (MAT) or temp files (flawed)';
    clp$put_display (display_control, str, clc$trim, status);
    str (1, *) := ' ';
    stringrep (str (5, *), l, num_software_flawed);
    stringrep (str (17, *), l, bytes_software_flawed);
    str (32, *) := 'software flawed';
    clp$put_display (display_control, str, clc$trim, status);
    str (1, *) := ' ';
    stringrep (str (5, *), l, num_hardware_flawed);
    stringrep (str (17, *), l, bytes_hardware_flawed);
    str (32, *) := 'hardware flawed';
    clp$put_display (display_control, str, clc$trim, status);
    str (1, *) := ' ';
    stringrep (str (5, *), l, num_usable);
    stringrep (str (17, *), l, bytes_usable);
    str (32, *) := 'usable';
    clp$put_display (display_control, str, clc$trim, status);
    clp$put_display (display_control, '    ----------  ------------', clc$trim, status);
    str (1, *) := ' ';
    stringrep (str (5, *), l, total_daus);
    stringrep (str (17, *), l, total_bytes);
    clp$put_display (display_control, str, clc$trim, status);

  PROCEND sum_dat_space;
?? TITLE := '  sum_dfl_space', EJECT ??

  PROCEDURE sum_dfl_space
    (    p_dfl: ^dmt$ms_device_file_list_table;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      p_dfl_entry: ^dmt$ms_device_file_list_entry,
      l: integer,
      str: string (80),
      total_files: integer,
      total_bytes: integer,
      num_perm: integer,
      bytes_perm: integer,
      num_catalog: integer,
      bytes_catalog: integer,
      num_device: integer,
      bytes_device: integer,
      dfl_index: dmt$device_file_list_index;

    status.normal := TRUE;
    num_perm := 0;
    bytes_perm := 0;
    num_catalog := 0;
    bytes_catalog := 0;
    num_device := 0;
    bytes_device := 0;

    clp$put_display (display_control, ' From device file list:', clc$trim, status);

    FOR dfl_index := 1 TO p_dfl^.header.number_of_entries DO
      p_dfl_entry := ^p_dfl^.entries [dfl_index];
      CASE p_dfl_entry^.flags OF
      = dmc$dfle_available =
      = dmc$dfle_assigned_to_mainframe =
      = dmc$dfle_assigned_to_file =
        CASE p_dfl_entry^.file_kind OF
        = gfc$fk_job_permanent_file =
          num_perm := num_perm + 1;
          bytes_perm := bytes_perm + p_dfl_entry^.fmd_length;
        = gfc$fk_catalog =
          num_catalog := num_catalog + 1;
          bytes_catalog := bytes_catalog + p_dfl_entry^.fmd_length;
        = gfc$fk_device_file =
          num_device := num_device + 1;
          bytes_device := bytes_device + p_dfl_entry^.fmd_length;
        = gfc$fk_global_unnamed =
        = gfc$fk_job_local_file =
        = gfc$fk_unnamed_file =
        ELSE
        CASEND;
      ELSE;
      CASEND;
    FOREND;

    total_files := num_device + num_catalog + num_perm;
    total_bytes := bytes_device + bytes_catalog + bytes_perm;

    clp$put_display (display_control, '     # files   bytes         file type', clc$trim, status);
    str (1, *) := ' ';
    stringrep (str(5, *), l, num_device);
    stringrep (str(15, *), l, bytes_device);
    str (30, *) := 'device';
    clp$put_display (display_control, str, clc$trim, status);
    str (1, *) := ' ';
    stringrep (str(5, *), l, num_catalog);
    stringrep (str(15, *), l, bytes_catalog);
    str (30, *) := 'catalog';
    clp$put_display (display_control, str, clc$trim, status);
    str (1, *) := ' ';
    stringrep (str(5, *), l, num_perm);
    stringrep (str(15, *), l, bytes_perm);
    str (30, *) := 'permanent';
    clp$put_display (display_control, str, clc$trim, status);

    clp$put_display (display_control, '    -----     ------------', clc$trim, status);
    str (1, *) := ' ';
    stringrep (str(5, *), l, total_files);
    stringrep (str(15, *), l, total_bytes);
    clp$put_display (display_control, str, clc$trim, status);

  PROCEND sum_dfl_space;
MODEND dmm$analyze_device_file;
*DECK DECK=DMM$ATTACH_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
{
{
MODULE dmm$attach_file;
?? PUSH (LISTEXT := ON) ??
?? TITLE:= '  Common Decks', EJECT ??
*copyc amd$file_attributes
*copyc dmp$build_fmd_for_existing_file
*copyc dmp$build_faus_from_dfl_entry
*copyc dmp$clear_master_attach_lock
*copyc dmp$close_file
*copyc dmp$create_fd_entry
*copyc dmp$create_fmds
*copyc dmp$delete_file_descriptor
*copyc dmp$detach_device_file
*copyc dmp$detach_file
*copyc dmp$determine_queue_status
*copyc dmp$generate_gfn_hash
*copyc dmp$get_active_vol_attributes
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_fmd_by_index
*copyc dmp$get_fau_entry
*copyc dmp$open_directory
*copyc dmp$process_device_log_entry
*copyc dmp$reallocate_file_space
*copyc dmp$search_active_volume_table
*copyc dmp$search_avt_by_vsn
*copyc dmp$search_fdt_by_gfn
*copyc dmp$search_vol_directory_name
*copyc dmp$set_file_residence
*copyc dmp$set_file_table_locator
*copyc dmp$set_master_attach_lock
*copyc dmd$null_global_file_name
*copyc dmt$device_file_stored_fmd
*copyc dmt$disk_file_descriptor
*copyc dmt$error_condition_codes
*copyc dmt$existing_sft_entry
*copyc dmt$file_attributes
*copyc dmt$file_descriptor_entry
*copyc dmt$file_medium_descriptor
*copyc dmt$file_location
*copyc dmt$file_share_history
*copyc dmt$fmd_index
*copyc dmt$global_file_name
*copyc dmt$keypoint_calls
*copyc dmt$mainframe_allocation_table
*copyc dmt$ms_volume_directory
*copyc dmt$ms_volume_label
*copyc dmt$segment_file_information
*copyc dmt$stored_fmd
*copyc dmt$stored_ms_fmd_header
*copyc dmv$active_volume_table
*copyc dmv$idle_system
*copyc gfp$get_fde_p
*copyc gfp$get_locked_fde_p
*copyc gfp$unlock_fde_p
*copyc gft$system_file_identifier
*copyc jmv$jcb
*copyc mmc$null_shared_queue
*copyc mme$condition_codes
*copyc mmp$close_device_file
*copyc mmp$free_pages
*copyc mmp$issue_ring1_segment_request
*copyc mmp$open_file_by_sfid
*copyc mmp$write_modified_pages
*copyc mmt$active_segment_table
*copyc mmt$ast_index
*copyc mmt$page_frame_queue_id
*copyc mmt$rb_ring1_segment_request
*copyc mmv$ast_p
*copyc osk$keypoints
*copyc osp$append_status_parameter
*copyc osp$clear_mainframe_sig_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc oss$mainframe_pageable
*copyc ost$status
*copyc pfd$permanent_file_attributes
*copyc rmd$volume_declarations
*copyc syp$continue_to_cause
*copyc syp$disestablish_cond_handler
*copyc syp$establish_condition_handler
?? POP ??
?? TITLE := '  Global Definitions', EJECT ??
  VAR
    dmv$modify_options: [STATIC, READ] pft$usage_selections := $pft$usage_selections [pfc$shorten, pfc$append,
      pfc$modify];
?? TITLE := '  dmp$attach_file', EJECT ??
*copy dmh$attach_file

  PROCEDURE [XDCL, #GATE] dmp$attach_file (global_file_name: dmt$global_file_name;
        file_kind: gft$file_kind;
        stored_fmd: dmt$stored_fmd;
        file_usage: pft$usage_selections;
        file_share_selections: pft$share_selections;
        file_history: dmt$file_share_history;
        file_limit: amt$file_limit;
        restricted_attach: boolean;
        exit_on_unknown_file: boolean;
        server_file: boolean;
        shared_queue: mmt$page_frame_queue_id;
    VAR file_damaged: boolean;
    VAR system_file_id: gft$system_file_identifier;
    VAR existing_sft_entry: dmt$existing_sft_entry;
    VAR status: ost$status);

    TYPE
      t$subfile_list = array [1 .. *] of record
        avt_index: dmt$active_volume_table_index,
        dfl_index: dmt$device_file_list_index,
      recend;

    VAR
      aste_p: ^mmt$active_segment_table_entry,
      asti: mmt$ast_index,
      attach_status: ost$status,
      avt_index: dmt$active_volume_table_index,
      dfl_index: dmt$device_file_list_index,
      existing_sft_entry_found: boolean,
      fau_lower_bound: dmt$fau_entries,
      fmd_index: dmt$fmd_index,
      fmd_pointer: ost$relative_pointer,
      file_entry_index: gft$file_descriptor_index,
      file_flawed: boolean,
      file_locator: dmt$file_location,
      file_modified: boolean,
      file_table_residence: gft$table_residence,
      flush_status: ost$status,
      fmd_modified: boolean,
      found: boolean,
      ignore_file_info: dmt$file_information,
      internal_vsn: dmt$internal_vsn,
      log_entry: dmt$dl_entry,
      number_fmds: dmt$fmd_index,
      p_dfd: ^dmt$disk_file_descriptor,
      p_dflt: ^dmt$ms_device_file_list_table,
      p_fmd: ^dmt$file_medium_descriptor,
      p_fau: ^dmt$file_allocation_unit,
      p_file_attributes: ^array [1 .. * ] of dmt$file_attribute,
      p_fde: ^gft$file_descriptor_entry,
      p_fmd_seq: ^dmt$stored_fmd,
      p_fmd_version: ^dmt$stored_ms_version_number,
      p_stored_fmd_header: ^dmt$stored_ms_fmd_header,
      p_stored_ms_fmd_subfile: ^dmt$stored_ms_fmd_subfile,
      p_subfile_list: ^t$subfile_list,
      procedure_marker: (clean, master_attach_lock, fde_created, fde_locked, fde_locked_master_clear,
         dfd_built, fmds_built),
      queue_status: gft$queue_status,
      rb: mmt$rb_ring1_segment_request,
      recorded_vsn: rmt$recorded_vsn,
      seg: ost$segment,
      sfid_valid: boolean,
      subfile_count: dmt$fmd_index;

?? EJECT ??
    PROCEDURE stored_fmd_condition_handler (mf: ost$monitor_fault;
                                            p_msa: ^ost$minimum_save_area;
                                       VAR  continue: syt$continue_option);

      PROCEDURE cleanup;

        CASE procedure_marker OF
        = master_attach_lock =
          dmp$clear_master_attach_lock (system_file_id);
        = fde_created =
          {  'free' fde
          dmp$clear_master_attach_lock (system_file_id);
        = fde_locked =
          {  unlock fde
          {  'free' fde
          dmp$clear_master_attach_lock (system_file_id);
        = fde_locked_master_clear =
          {  unlock fde
          {  'free' fde
        = dfd_built =
          {  free dfd
          {  unlock fde
        = fmds_built =
          {  free fmd
          {  unlock fde
          {  'free' fde
        ELSE
        CASEND;
        IF procedure_marker >= fde_locked THEN
          IF existing_sft_entry = dmc$entry_not_found THEN
            p_fde^.global_file_name := dmv$null_global_file_name;
          IFEND;
        IFEND;

      PROCEND cleanup;

      VAR
        p_scc: ^syt$system_core_condition,
        p_sac: ^mmt$segment_access_condition,
        ignore: ost$status;

      IF mf.identifier = mmc$segment_fault_processor_id THEN
        p_sac := #LOC(mf.contents);
        CASE p_sac^.identifier OF
        = mmc$sac_io_read_error =
          osp$set_status_abnormal ('MM', mme$io_read_error,
             'io error accessing stored fmd - dmp$attach_file', status);
          cleanup;
          EXIT dmp$attach_file;
        ELSE
        CASEND;
      ELSEIF mf.identifier = syc$system_core_condition THEN
        p_scc := #LOC(mf.system_core_condition);
        CASE p_scc^.condition OF
        = syc$user_defined_condition =
          IF p_scc^.user_defined_condition = syc$udc_volume_unavailable THEN
            osp$set_status_abnormal ('MM', mme$volume_unavailable,
               'io error accessing stored fmd - dmp$attach_file', status);
            cleanup;
            EXIT dmp$attach_file;
          IFEND;
        ELSE
        CASEND;
      IFEND;

      syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);

    PROCEND stored_fmd_condition_handler;
?? SKIP := 3 ??

    IF dmv$idle_system THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
        'system is idle - dmp$attach_file', status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    procedure_marker := clean;
    #SPOIL(procedure_marker);
    existing_sft_entry_found := FALSE;
    existing_sft_entry := dmc$entry_not_found;
    #SPOIL (existing_sft_entry);

  /process_request/
    BEGIN
      dmp$set_file_residence (file_kind, file_table_residence, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      dmp$set_file_table_locator (file_table_residence, file_locator, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      p_fmd_seq := ^stored_fmd;
      system_file_id.residence := file_table_residence;

      dmp$determine_queue_status (file_kind, file_usage, file_share_selections, queue_status, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      dmp$generate_gfn_hash (global_file_name, system_file_id.file_hash);

      dmp$set_master_attach_lock (system_file_id);

      #SPOIL(procedure_marker);
      procedure_marker := master_attach_lock;
      #SPOIL(procedure_marker);

    /master_attach_lock_set/
      BEGIN

      /see_if_already_attached/
        BEGIN
          dmp$search_fdt_by_gfn (file_table_residence, global_file_name, system_file_id.file_entry_index,
                existing_sft_entry_found);
          IF NOT existing_sft_entry_found THEN
            EXIT /see_if_already_attached/;
          IFEND;

          gfp$get_locked_fde_p (system_file_id, p_fde);

          dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

        /sft_entry_locked/
          BEGIN

{ If this is the first non-restricted attach of a file that was previously
{ restricted attached, then clear the restricted attach field in the
{ file descriptor entry and return to the caller the fact that you
{ encountered a restricted attached file.

            IF p_dfd^.restricted_attach AND (NOT restricted_attach) THEN
              p_dfd^.restricted_attach := FALSE;
              existing_sft_entry := dmc$restricted_attach_entry;
              #SPOIL (existing_sft_entry);
              EXIT /sft_entry_locked/;
            IFEND;

            existing_sft_entry_found := (p_fde^.global_file_name = global_file_name)
                                AND (NOT p_dfd^.purged);
            IF existing_sft_entry_found THEN
{
{             verify that the number of fau entries agrees with the allocated_length
{

              number_fmds := p_dfd^.number_of_fmds;
              fau_lower_bound := 1;

              FOR fmd_index := 1 TO number_fmds DO

                dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);

                IF p_fmd = NIL THEN
                  osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
                     'NIL p_fmd - dmm$attach_file', status);
                  EXIT /sft_entry_locked/;
                IFEND;

                IF p_fmd^.volume_assigned AND dmv$p_active_volume_table^ [p_fmd^.avt_index].
                      mass_storage.volume_unavailable THEN
                  osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable,
                    dmv$p_active_volume_table^ [p_fmd^.avt_index].mass_storage.recorded_vsn, status);
                  EXIT /sft_entry_locked/;
                IFEND;

              FOREND;

              existing_sft_entry := dmc$normal_entry;
              #SPOIL (existing_sft_entry);

              IF p_fde^.attach_count = 0 THEN
                p_fde^.queue_status := queue_status;
                IF shared_queue <> mmc$null_shared_queue THEN
                  p_fde^.queue_ordinal := mmc$pq_shared_last_sys + shared_queue;
                ELSE
                  p_fde^.queue_ordinal := mmc$null_shared_queue;
                IFEND;
              IFEND;

              p_fde^.attach_count := p_fde^.attach_count + 1;

              IF (server_file) AND (p_fde^.attach_count > 1) THEN
                asti := p_fde^.asti;
                IF asti <> 0 THEN
                  aste_p := ^mmv$ast_p^ [asti];
                  IF (aste_p^.in_use) AND (aste_p^.sfid = system_file_id) AND
                        (aste_p^.queue_id = mmc$pq_job_working_set) THEN
                    rb.reqcode := syc$rc_ring1_segment_request;
                    rb.request := mmc$sr1_remove_job_shared_pages;
                    rb.system_file_id := system_file_id;
                    rb.server_file := TRUE;
                    rb.status.normal := TRUE;
                    mmp$issue_ring1_segment_request (rb);
                  IFEND;
                IFEND;
              IFEND;

              IF dmv$modify_options * file_usage <> $pft$usage_selections [] THEN
              /log_attach/
                BEGIN
                  p_fde^.attached_in_write_count := 1;
                  dmp$get_fmd_by_index (p_dfd, 1, p_fmd);
                  IF p_fmd = NIL THEN
                    osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
                       'No fmd for byte zero - dmp$attach_file.', status);
                    EXIT /log_attach/;
                  IFEND;
                  avt_index := p_fmd^.avt_index;
                  log_entry.kind := dmc$dl_attach_file;
                  log_entry.attach_file_block.global_file_name := global_file_name;
                  log_entry.attach_file_block.dfl_index := p_fmd^.dfl_index;
                  log_entry.attach_file_block.mainframe_assigned := dmv$p_active_volume_table^ [avt_index].
                        mass_storage.mainframe_assigned;
                  dmp$process_device_log_entry (avt_index, log_entry, status);

                END /log_attach/;
              IFEND;
            IFEND;

          END /sft_entry_locked/;
          file_damaged := p_dfd^.file_damaged;
          gfp$unlock_fde_p (p_fde);

          IF NOT status.normal THEN
            EXIT /master_attach_lock_set/;
          IFEND;

          IF existing_sft_entry_found THEN
            EXIT /master_attach_lock_set/;
          IFEND;

        END /see_if_already_attached/;

{  Exit without attaching the file when the EXIT_ON_UNKNOWN_FILE parameter is TRUE
{  and no entry was found in the system_file_table or the file was attached prior
{  to the point of commitment.

        IF exit_on_unknown_file AND ((existing_sft_entry = dmc$entry_not_found) OR
              (existing_sft_entry = dmc$restricted_attach_entry)) THEN
          EXIT /master_attach_lock_set/;
        IFEND;

{
{            create new file table entries
{
        RESET p_fmd_seq;
        NEXT p_fmd_version IN p_fmd_seq;
        IF p_fmd_version = NIL THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_fmd,
            'No FMD version number - dmp$attach_file.', status);
          EXIT /master_attach_lock_set/;
        IFEND;

        syp$establish_condition_handler (^stored_fmd_condition_handler);

        IF (p_fmd_version^ <> dmc$current_fmd_version) THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unsupported_fmd_version,
            'Unsupported FMD version number - dmp$attach_file.', status);
          EXIT /master_attach_lock_set/;
        IFEND;

        NEXT p_stored_fmd_header: [p_fmd_version^] IN p_fmd_seq;
        IF p_stored_fmd_header = NIL THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_fmd,
            'No FMD header - dmp$attach_file.', status);
          EXIT /master_attach_lock_set/;
        IFEND;

        PUSH p_file_attributes: [1 .. 14];

        p_file_attributes^ [1].keyword := dmc$file_hash;
        p_file_attributes^ [1].file_hash := p_stored_fmd_header^.version_0_0.file_hash;
        p_file_attributes^ [2].keyword := dmc$file_kind;
        p_file_attributes^ [2].file_kind := p_stored_fmd_header^.version_0_0.file_kind;
        p_file_attributes^ [3].keyword := dmc$preset_value;
        p_file_attributes^ [3].preset_value := p_stored_fmd_header^.version_0_0.preset_value;
        p_file_attributes^ [4].keyword := dmc$clear_space;
        p_file_attributes^ [4].required := p_stored_fmd_header^.version_0_0.clear_space;
        p_file_attributes^ [5].keyword := dmc$file_limit;
        p_file_attributes^ [5].limit := p_stored_fmd_header^.version_0_0.file_limit;
        p_file_attributes^ [6].keyword := dmc$global_file_name;
        p_file_attributes^ [6].global_file_name := global_file_name;
        p_file_attributes^ [7].keyword := dmc$overflow;
        p_file_attributes^ [7].overflow_allowed := p_stored_fmd_header^.version_0_0.overflow_allowed;
        p_file_attributes^ [8].keyword := dmc$requested_allocation_size;
        p_file_attributes^ [8].requested_allocation_size := p_stored_fmd_header^.version_0_0.
              requested_allocation_size;
        p_file_attributes^ [9].keyword := dmc$requested_transfer_size;
        p_file_attributes^ [9].requested_transfer_size := p_stored_fmd_header^.version_0_0.
              requested_transfer_size;
        p_file_attributes^ [10].keyword := dmc$requested_volume;
        p_file_attributes^ [10].requested_volume := p_stored_fmd_header^.version_0_0.requested_volume;
        p_file_attributes^ [11].keyword := dmc$class;
        p_file_attributes^ [11].class := p_stored_fmd_header^.version_0_0.requested_class;
        p_file_attributes^ [12].keyword := dmc$class_ordinal;
        p_file_attributes^ [12].ordinal := p_stored_fmd_header^.version_0_0.requested_class_ordinal;
        p_file_attributes^ [13].keyword := dmc$write_mode;
        p_file_attributes^ [13].attached_in_write_mode := ((dmv$modify_options * file_usage) <>
              $pft$usage_selections []);
        p_file_attributes^ [14].keyword := dmc$queue_status;
        p_file_attributes^ [14].queue_status := queue_status;

        number_fmds := p_stored_fmd_header^.version_0_0.number_fmds;

        IF number_fmds < 1 THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_fmd,
             'FMD count less than one - dmp$attach_file.', status);
          EXIT /master_attach_lock_set/;
        IFEND;

       {Verify all volumes are available

        PUSH p_subfile_list: [1 .. number_fmds];
        subfile_count := 0;

        FOR fmd_index := 1 TO number_fmds DO
          NEXT p_stored_ms_fmd_subfile: [p_fmd_version^] IN p_fmd_seq;
          IF p_stored_ms_fmd_subfile = NIL THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_fmd,
              'FMD too small to hold fmds - dmp$attach_file.', status);
            EXIT /master_attach_lock_set/;
          IFEND;
          recorded_vsn := p_stored_ms_fmd_subfile^.version_0_0.recorded_vsn;
          IF (recorded_vsn <> '      ') THEN
            dmp$search_avt_by_vsn (p_stored_ms_fmd_subfile^.version_0_0.internal_vsn, avt_index, found);

            IF NOT found OR (dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn <>
                  recorded_vsn) OR NOT (dmc$mainframe_mounted IN dmv$p_active_volume_table^ [avt_index].
                  mass_storage.status) THEN
              osp$set_status_abnormal (dmc$device_manager_ident, dme$some_volumes_not_online,
                recorded_vsn, status);
              EXIT /master_attach_lock_set/;
            ELSEIF (dmv$p_active_volume_table^ [avt_index].mass_storage.volume_unavailable) THEN
              osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable,
                recorded_vsn, status);
              EXIT /master_attach_lock_set/;
            IFEND;

            subfile_count := subfile_count + 1;
            p_subfile_list^ [subfile_count].avt_index := avt_index;
            p_subfile_list^ [subfile_count].dfl_index := p_stored_ms_fmd_subfile^.version_0_0.
                  device_file_list_index;
          IFEND;
        FOREND;

        IF (system_file_id.file_hash <> p_stored_fmd_header^.version_0_0.file_hash) THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$sfid_fmd_file_hash_mismatch,
            'GFN hash does not match stored_fmd - dmp$attach_file', status);
          EXIT /master_attach_lock_set/;
        IFEND;

        dmp$create_fd_entry (p_file_attributes, system_file_id, status);
        IF NOT status.normal THEN
          EXIT /master_attach_lock_set/;
        IFEND;

        #SPOIL(procedure_marker);
        procedure_marker := fde_created;
        #SPOIL(procedure_marker);

      /file_descriptor_created/
        BEGIN
          gfp$get_locked_fde_p (system_file_id, p_fde);

          #SPOIL(existing_sft_entry);
          #SPOIL(p_fde);
          #SPOIL(procedure_marker);
          procedure_marker := fde_locked;
          #SPOIL(procedure_marker);

        /file_descriptor_locked/
          BEGIN

{           set sft entry to purged to suppress recovery until attach is complete. }

            dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
            p_dfd^.purged := TRUE;

            dmp$clear_master_attach_lock (system_file_id);

            #SPOIL(procedure_marker);
            procedure_marker := fde_locked_master_clear;
            #SPOIL(procedure_marker);


{  If this is a restricted attach, set the field in the disk_file_descriptor
{  to true and set fmd_modified to true to force an update of the stored FMD
{  in the catalog.

            IF restricted_attach THEN
              p_dfd^.restricted_attach := TRUE;
              p_dfd^.fmd_modified := TRUE;
            IFEND;

            dmp$create_fmds (file_locator, p_dfd, subfile_count, status);
            IF NOT status.normal THEN
              EXIT /file_descriptor_locked/;
            IFEND;

            #SPOIL(procedure_marker);
            procedure_marker := fmds_built;
            #SPOIL(procedure_marker);

            FOR fmd_index := 1 TO subfile_count DO
              dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);
              p_fmd^.in_use := TRUE;
              p_fmd^.dfl_index := p_subfile_list^ [fmd_index].dfl_index;
              avt_index := p_subfile_list^ [fmd_index].avt_index;
              p_fmd^.avt_index := avt_index;
              p_fmd^.internal_vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.internal_vsn;
              p_fmd^.volume_assigned := TRUE;
            FOREND;

            syp$disestablish_cond_handler;

            dmp$build_fmd_for_existing_file (p_fde, p_dfd, system_file_id, file_damaged,
                    file_flawed, status);
            IF NOT status.normal THEN
              EXIT /file_descriptor_locked/;
            IFEND;

{ Set sft entry to NOT purged to enable recovery.                      }

            p_dfd^.purged := FALSE;

            IF p_fde^.attached_in_write_count > 0  THEN
              dmp$get_fmd_by_index (p_dfd, 1, p_fmd);
              IF (p_fmd = NIL) THEN
                osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
                  'No fmd for byte zero - dmp$attach_file.', status);
                EXIT /file_descriptor_locked/;
              IFEND;

              log_entry.kind := dmc$dl_attach_file;
              log_entry.attach_file_block.global_file_name := global_file_name;
              log_entry.attach_file_block.dfl_index := p_fmd^.dfl_index;
              log_entry.attach_file_block.mainframe_assigned := dmv$p_active_volume_table^ [p_fmd^.avt_index].
                    mass_storage.mainframe_assigned;
              dmp$process_device_log_entry (p_fmd^.avt_index, log_entry, status);
              IF NOT status.normal THEN
                EXIT /file_descriptor_locked/;
              IFEND;
            IFEND;

            IF shared_queue <> mmc$null_shared_queue THEN
              p_fde^.queue_ordinal := mmc$pq_shared_last_sys + shared_queue;
            ELSE
              p_fde^.queue_ordinal := mmc$null_shared_queue;
            IFEND;

            gfp$unlock_fde_p (p_fde);

            IF file_flawed THEN
              dmp$reallocate_file_space (system_file_id, TRUE, status);

{ Open a segment for the file, so that the page can be written to the new allocation unit.
{ Any pages modified by the reallocate MUST be flushed to disk.  The write must be done now;
{ if the file is being attached for read only, pages will not be written when the file is detached.

              mmp$open_file_by_sfid (system_file_id, 1, 1, mmc$as_random,
                    mmc$sar_write_extend, seg, flush_status);
              IF flush_status.normal THEN
                mmp$write_modified_pages (#ADDRESS (1, seg, 0), 7ffffff0(16), osc$wait, flush_status);
                IF NOT flush_status.normal THEN
                  mmp$free_pages (#ADDRESS (1, seg, 0), 7ffffff0(16), osc$wait, flush_status);
                IFEND;
                mmp$close_device_file (seg, flush_status);
              IFEND;

              IF NOT status.normal THEN
                status.normal := TRUE;   { Allow a file with un-recovered read error to be attached. }
              IFEND;
            IFEND;

            EXIT /process_request/;           { <-------------------<<< NORMAL EXIT <---------------<<< }

          END /file_descriptor_locked/;

          gfp$unlock_fde_p (p_fde);

        END /file_descriptor_created/;

        {Attach has failed.
        {Attempt detach of file.  Note that this may log a detach log entry for a
        {file that never had an attach log entry issued for it - logger allows this.
        {Must clear purged flag to avoid destroying the file.
        {Must go thru detach to increment delete_count and decrement attach_count.

        IF existing_sft_entry = dmc$entry_not_found THEN
          {fde was being created by this attach
          {No human yet born understands how to cleanup in all of these cases
          p_fde^.global_file_name := dmv$null_global_file_name;
        ELSE
          p_dfd^.purged := FALSE;
          dmp$detach_file (system_file_id, {access_allowed} FALSE, {flush_pages} FALSE, file_modified,
                fmd_modified, ignore_file_info, attach_status);
          IF attach_status.normal THEN
            dmp$delete_file_descriptor (system_file_id, attach_status);
          IFEND;
        IFEND;

        EXIT /process_request/;

      END /master_attach_lock_set/;

      dmp$clear_master_attach_lock (system_file_id);

    END /process_request/;

  PROCEND dmp$attach_file;
?? TITLE := '  dmp$attach_device_file', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$attach_device_file (recorded_vsn: rmt$recorded_vsn;
        user_supplied_df_name: ost$name;
    VAR system_file_id: dmt$system_file_id;
    VAR status: ost$status);

    VAR
      avt_index: dmt$active_volume_table_index,
      p_active_vol_attributes: ^array [ * ] of dmt$assigned_ms_vol_attribute,
      volume_active: boolean;

    IF dmv$idle_system THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
        'system is idle - dmp$attach_device_file', status);
      RETURN;
    IFEND;

    status.normal := TRUE;

  /process_request/
    BEGIN
      {
      { issue mount request
      {
      PUSH p_active_vol_attributes: [1 .. 4];

      avt_index := 0;
      p_active_vol_attributes^ [1].keyword := dmc$ms_volume_directory;
      p_active_vol_attributes^ [2].keyword := dmc$ms_device_file_list_table;
      p_active_vol_attributes^ [3].keyword := dmc$ms_device_allocation_table;
      p_active_vol_attributes^ [4].keyword := dmc$avt_index;

      dmp$get_active_vol_attributes (recorded_vsn, avt_index, p_active_vol_attributes, volume_active);
      IF NOT volume_active THEN
        {
        { issue mount request
        {
        osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found, 'volume not in avt',
              status);
        EXIT /process_request/;
      IFEND;

      avt_index := p_active_vol_attributes^ [4].index;

      dmp$attach_volume_device_file (user_supplied_df_name, p_active_vol_attributes^ [1].directory_sfid,
            p_active_vol_attributes^ [2].p_dflt, p_active_vol_attributes^ [3].p_dat, avt_index,
            system_file_id, status);

    END /process_request/;

  PROCEND dmp$attach_device_file;
?? TITLE := '  dmp$attach_volume_device_file', EJECT ??

  PROCEDURE [XDCL] dmp$attach_volume_device_file (user_supplied_name: ost$name;
        directory_sfid: dmt$system_file_id;
        dflt_sfid: dmt$system_file_id;
        dat_sfid: dmt$system_file_id;
        avt_index: dmt$active_volume_table_index;
    VAR system_file_id: dmt$system_file_id;
    VAR status: ost$status);

    VAR
      attach_status: ost$status,
      dfl_index: dmt$device_file_list_index,
      directory_index: dmt$directory_index,
      entry_found: boolean,
      file_already_attached: boolean,
      file_damaged: boolean,
      file_flawed: boolean,
      file_modified: boolean,
      fmd_modified: boolean,
      global_file_name: dmt$global_file_name,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fmd: ^dmt$file_medium_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      p_directory: ^dmt$ms_volume_directory,
      p_fmd_version: ^dmt$stored_ms_version_number,
      p_stored_fmd: ^dmt$device_file_stored_fmd,
      p_stored_fmd_header: ^dmt$stored_ms_fmd_header,
      p_stored_fmd_subfile: ^dmt$stored_ms_fmd_subfile,
      stored_df_fmd: dmt$device_file_stored_fmd;

    status.normal := TRUE;

  /process_request/
    BEGIN
      directory_index := 0;
      dmp$search_vol_directory_name (user_supplied_name, directory_sfid, directory_index, entry_found,
            status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;
      IF NOT entry_found THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unknown_device_file,
          'Unknown device_file - dmp$attach_volume_device_file.', status);
        osp$append_status_parameter (' ', user_supplied_name, status);
        EXIT /process_request/;
      IFEND;

      dmp$open_directory (directory_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_read,
         mmc$as_sequential, p_directory, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      stored_df_fmd := p_directory^.entries [directory_index].stored_df_fmd;
      global_file_name := p_directory^.entries [directory_index].global_file_name;

      dmp$close_file (p_directory, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      p_stored_fmd := ^stored_df_fmd;
      RESET p_stored_fmd;

      NEXT p_fmd_version IN p_stored_fmd;
      IF p_fmd_version = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_fmd,
          'No FMD version number - dmp$attach_volume_device_file.', status);
        osp$append_status_parameter (' ', user_supplied_name, status);
        EXIT /process_request/;
      IFEND;

      IF (p_fmd_version^ <> dmc$current_fmd_version) THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unsupported_fmd_version,
          'Unsupported FMD version number - dmp$attach_volume_device_file.', status);
        osp$append_status_parameter (' ', user_supplied_name, status);
        EXIT /process_request/;
      IFEND;

      NEXT p_stored_fmd_header: [dmc$current_fmd_version] IN p_stored_fmd;
      IF p_stored_fmd_header = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_fmd,
          'No FMD header - dmp$attach_volume_device_file.', status);
        osp$append_status_parameter (' ', user_supplied_name, status);
        EXIT /process_request/;
      IFEND;

      NEXT p_stored_fmd_subfile: [dmc$current_fmd_version] IN p_stored_fmd;
      IF p_stored_fmd_subfile = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_fmd,
          'FMD too small to hold subfiles - dmp$attach_volume_device_file.', status);
        osp$append_status_parameter (' ', user_supplied_name, status);
        EXIT /process_request/;
      IFEND;

      { In systems with two byte DFL indexes (1.5.2 and earlier) the byte_address field of
      { the stored FMD subfile was not initialized properly for the label (i.e. it contains
      { stack garbage).  Since systems with three byte DFL indexes use the low byte of the
      { old byte_address field as the high byte of the DFL index, an invalid DFL index might
      { be used for the label unless it is fixed here.

      IF (directory_index = dmc$label_directory_index) THEN
        p_stored_fmd_subfile^.version_0_0.stored_byte_address := 0;
        p_stored_fmd_subfile^.version_0_0.device_file_list_index := dmc$label_dfl_index;
      IFEND;

      dfl_index := p_stored_fmd_subfile^.version_0_0.device_file_list_index;

      dmp$attach_device_file_by_fmd (global_file_name, stored_df_fmd, file_already_attached, system_file_id,
            status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      IF file_already_attached THEN
        EXIT /process_request/;
      IFEND;

    /file_attached/
      BEGIN
        gfp$get_locked_fde_p (system_file_id, p_fde);

        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

        dmp$build_fmd_for_existing_file (p_fde, p_dfd, system_file_id, file_damaged, file_flawed, status);

        gfp$unlock_fde_p (p_fde);

        IF status.normal THEN
          EXIT /process_request/;
        IFEND;

      END /file_attached/;
      dmp$detach_device_file (system_file_id, file_modified, fmd_modified, attach_status);

    END /process_request/;

  PROCEND dmp$attach_volume_device_file;
?? TITLE := '  dmp$attach_device_file_by_fmd', EJECT ??

  PROCEDURE [XDCL] dmp$attach_device_file_by_fmd (global_file_name: dmt$global_file_name;
        stored_ms_device_file_fmd: dmt$device_file_stored_fmd;
    VAR file_already_attached: boolean;
    VAR system_file_id: dmt$system_file_id;
    VAR status: ost$status);

    VAR
      attach_status: ost$status,
      dfl_index: dmt$device_file_list_index,
      file_locator: dmt$file_location,
      file_modified: boolean,
      file_kind: gft$file_kind,
      file_usage: pft$usage_selections,
      file_share_history: dmt$file_share_history,
      file_share_selections: pft$share_selections,
      fmd_modified: boolean,
      fmd_pointer: ost$relative_pointer,
      internal_vsn: dmt$internal_vsn,
      p_dfd: ^dmt$disk_file_descriptor,
      p_file_attributes: ^array [1 .. * ] of dmt$file_attribute,
      p_fde: ^gft$file_descriptor_entry,
      p_fmd: ^dmt$file_medium_descriptor,
      p_fmd_version: ^dmt$stored_ms_version_number,
      p_stored_fmd: ^dmt$device_file_stored_fmd,
      p_stored_fmd_header: ^dmt$stored_ms_fmd_header,
      p_stored_fmd_subfile: ^dmt$stored_ms_fmd_subfile;

    status.normal := TRUE;

  /process_request/
    BEGIN
      file_already_attached := FALSE;

      p_stored_fmd := ^stored_ms_device_file_fmd;
      RESET p_stored_fmd;

      NEXT p_fmd_version IN p_stored_fmd;
      IF p_fmd_version = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
          'no stored fmd version number - DMMATCH', status);
        EXIT /process_request/;
      IFEND;

      NEXT p_stored_fmd_header: [0] IN p_stored_fmd;
      IF p_stored_fmd_header = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
          'unable to get fmd header - DMMATCH', status);
        EXIT /process_request/;
      IFEND;

      file_kind := gfc$fk_device_file;
      file_usage := $pft$usage_selections [pfc$read];
      file_share_selections := $pft$share_selections [];
      file_share_history := dmc$minimum_file_share_his;
      dmp$set_file_residence (file_kind, system_file_id.residence, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      dmp$set_file_table_locator (system_file_id.residence, file_locator, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      dmp$generate_gfn_hash (global_file_name, system_file_id.file_hash);

    /validate_sfid/
      BEGIN
        IF system_file_id.file_hash <> p_stored_fmd_header^.version_0_0.file_hash THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$inconsistent_hash_and_gfn,
            'file hash global file name mismatch - DMMATCH', status);
          EXIT /process_request/;
        IFEND;
      END /validate_sfid/;

      dmp$set_master_attach_lock (system_file_id);

    /master_attach_lock_set/
      BEGIN

      /locate_fde/
        BEGIN
          dmp$search_fdt_by_gfn (system_file_id.residence, global_file_name, system_file_id.
                file_entry_index, file_already_attached);
          IF NOT file_already_attached THEN
            EXIT /locate_fde/;
          IFEND;

        /existing_fde_found/
          BEGIN
            gfp$get_locked_fde_p (system_file_id, p_fde);
            dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

            file_already_attached := (p_fde^.global_file_name = global_file_name)
                             AND (NOT p_dfd^.purged);
            IF file_already_attached THEN
              p_fde^.attach_count := p_fde^.attach_count + 1;
            IFEND;

          END /existing_fde_found/;
          gfp$unlock_fde_p (p_fde);

        END /locate_fde/;

        IF file_already_attached THEN
          EXIT /master_attach_lock_set/;
        IFEND;

        NEXT p_stored_fmd_subfile: [0] IN p_stored_fmd;
        IF p_stored_fmd_subfile = NIL THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
            'unable to get stored fmd subfiles', status);
          EXIT /master_attach_lock_set/;
        IFEND;

{
{            create new file table entries
{
        CASE p_fmd_version^ OF
        = 0 =
          PUSH p_file_attributes: [1 .. 12];

          p_file_attributes^ [1].keyword := dmc$file_hash;
          p_file_attributes^ [1].file_hash := p_stored_fmd_header^.version_0_0.file_hash;
          p_file_attributes^ [2].keyword := dmc$file_kind;
          p_file_attributes^ [2].file_kind := p_stored_fmd_header^.version_0_0.file_kind;
          p_file_attributes^ [3].keyword := dmc$preset_value;
          p_file_attributes^ [3].preset_value := p_stored_fmd_header^.version_0_0.preset_value;
          p_file_attributes^ [4].keyword := dmc$clear_space;
          p_file_attributes^ [4].required := p_stored_fmd_header^.version_0_0.clear_space;
          p_file_attributes^ [5].keyword := dmc$file_limit;
          p_file_attributes^ [5].limit := p_stored_fmd_header^.version_0_0.file_limit;
          p_file_attributes^ [6].keyword := dmc$global_file_name;
          p_file_attributes^ [6].global_file_name := global_file_name;
          p_file_attributes^ [7].keyword := dmc$overflow;
          p_file_attributes^ [7].overflow_allowed := p_stored_fmd_header^.version_0_0.overflow_allowed;
          p_file_attributes^ [8].keyword := dmc$requested_allocation_size;
          p_file_attributes^ [8].requested_allocation_size := p_stored_fmd_header^.version_0_0.
                requested_allocation_size;
          p_file_attributes^ [9].keyword := dmc$requested_transfer_size;
          p_file_attributes^ [9].requested_transfer_size := p_stored_fmd_header^.version_0_0.
                requested_transfer_size;
          p_file_attributes^ [10].keyword := dmc$requested_volume;
          p_file_attributes^ [10].requested_volume := p_stored_fmd_header^.version_0_0.requested_volume;
          p_file_attributes^ [11].keyword := dmc$class;
          p_file_attributes^ [11].class := p_stored_fmd_header^.version_0_0.requested_class;
          p_file_attributes^ [12].keyword := dmc$class_ordinal;
          p_file_attributes^ [12].ordinal := p_stored_fmd_header^.version_0_0.requested_class_ordinal;
          dfl_index := p_stored_fmd_subfile^.version_0_0.device_file_list_index;
          internal_vsn := p_stored_fmd_subfile^.version_0_0.internal_vsn;
        ELSE
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
            'bad fmd version number - DMMATCH', status);
          EXIT /master_attach_lock_set/;
        CASEND;

        dmp$create_fd_entry (p_file_attributes, system_file_id, status);
        IF NOT status.normal THEN
          EXIT /master_attach_lock_set/;
        IFEND;

      /file_descriptor_created/
        BEGIN
          gfp$get_locked_fde_p (system_file_id, p_fde);
          IF p_fde = NIL THEN
            dmp$clear_master_attach_lock (system_file_id);
            EXIT /file_descriptor_created/;
          IFEND;

        /file_descriptor_locked/
          BEGIN

            dmp$clear_master_attach_lock (system_file_id);

            dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
            dmp$create_fmds (file_locator, p_dfd, 1, status);
            IF NOT status.normal THEN
              EXIT /file_descriptor_locked/;
            IFEND;

            dmp$get_fmd_by_index (p_dfd, 1, p_fmd);
            p_fmd^.in_use := TRUE;
            p_fmd^.dfl_index := dfl_index;
            p_fmd^.internal_vsn := internal_vsn;
            p_fmd^.volume_assigned := TRUE;

          END /file_descriptor_locked/;
          gfp$unlock_fde_p (p_fde);

          IF status.normal THEN
            EXIT /process_request/;
          IFEND;

        END /file_descriptor_created/;

        dmp$detach_device_file (system_file_id, file_modified, fmd_modified, attach_status);
        EXIT /process_request/;

      END /master_attach_lock_set/;

      dmp$clear_master_attach_lock (system_file_id);

    END /process_request/;

  PROCEND dmp$attach_device_file_by_fmd;

?? TITLE := '  dmp$attach_directory_from_label', EJECT ??

  PROCEDURE [XDCL] dmp$attach_directory_from_label (volume_label: dmt$ms_volume_label;
        dat_sfid: dmt$system_file_id;
    VAR directory_sfid: dmt$system_file_id;
    VAR status: ost$status);

    VAR
      able_to_locate_fde: boolean,
      allocated_length_in_bytes: amt$file_byte_address,
      attach_status: ost$status,
      avt_index: dmt$active_volume_table_index,
      avt_search_key: dmt$avt_search_key,
      daus_per_allocation_unit: dmt$daus_per_allocation,
      directory_stored_df_fmd: dmt$device_file_stored_fmd,
      eof_byte_address: amt$file_byte_address,
      eoi_byte_address: amt$file_byte_address,
      file_already_attached: boolean,
      file_flawed: boolean,
      file_modified: boolean,
      fmd_modified: boolean,
      global_file_name: dmt$global_file_name,
      p_directory_fmd_header: ^dmt$stored_ms_fmd_header,
      p_directory_fmd_subfile: ^dmt$stored_ms_fmd_subfile,
      p_directory_fmd_version: ^dmt$stored_ms_version_number,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      p_fmd: ^dmt$file_medium_descriptor,
      p_mat: ^dmt$mainframe_allocation_table,
      p_stored_directory_fmd: ^dmt$device_file_stored_fmd,
      p_volume_label: ^dmt$ms_volume_label,
      p_volume_label_header: ^dmt$volume_label_header,
      p_volume_label_0_0: ^dmt$ms_label_0_0,
      stored_directory_dfl_entry: dmt$ms_device_file_list_entry,
      volume_not_active: boolean;

    status.normal := TRUE;

  /process_request/
    BEGIN
      p_mat := NIL;
      allocated_length_in_bytes := 0;
      p_volume_label := ^volume_label;

      RESET p_volume_label;

      NEXT p_volume_label_header IN p_volume_label;
      IF p_volume_label_header = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
          'p_volume_label_header = NIL -DMMATCH', status);
        EXIT /process_request/;
      IFEND;

      avt_search_key.value := dmc$search_avt_by_rec_vsn;
      avt_search_key.recorded_vsn := p_volume_label_header^.recorded_vsn;

      dmp$search_active_volume_table (avt_search_key, avt_index, volume_not_active);
      IF volume_not_active THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found, 'volume not in avt',
              status);
        EXIT /process_request/;
      IFEND;

      CASE p_volume_label_header^.version_number OF
      = dmc$ms_label_0_0 =
        NEXT p_volume_label_0_0 IN p_volume_label;
        IF p_volume_label_0_0 = NIL THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
            'p_volume_label_0_0 = NIL - DMMATCH', status);
          EXIT /process_request/;
        IFEND;
        stored_directory_dfl_entry := p_volume_label_0_0^.directory_dfl_entry;
        directory_stored_df_fmd := p_volume_label_0_0^.directory_fmd;
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
          'label version not supported', status);
        EXIT /process_request/;
      CASEND;

      daus_per_allocation_unit := stored_directory_dfl_entry.daus_per_allocation_unit;
      global_file_name := stored_directory_dfl_entry.global_file_name;
      allocated_length_in_bytes := stored_directory_dfl_entry.fmd_length;
      eof_byte_address := stored_directory_dfl_entry.end_of_file;
      eoi_byte_address := stored_directory_dfl_entry.end_of_information;

      PUSH p_stored_directory_fmd;

      RESET p_stored_directory_fmd;

      p_stored_directory_fmd^ := directory_stored_df_fmd;

      RESET p_stored_directory_fmd;

      NEXT p_directory_fmd_version IN p_stored_directory_fmd;

      NEXT p_directory_fmd_header: [0] IN p_stored_directory_fmd;

      NEXT p_directory_fmd_subfile: [0] IN p_stored_directory_fmd;

      CASE p_directory_fmd_version^ OF
      = 0 =
        p_directory_fmd_subfile^.version_0_0.device_file_list_index := dmc$directory_dfl_index;
        p_directory_fmd_subfile^.version_0_0.internal_vsn := p_volume_label_header^.internal_vsn;
        p_directory_fmd_subfile^.version_0_0.recorded_vsn := p_volume_label_header^.recorded_vsn;
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
          'unsupported fmd version', status);
        EXIT /process_request/;
      CASEND;

      dmp$attach_device_file_by_fmd (global_file_name, p_stored_directory_fmd^, file_already_attached,
            directory_sfid, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;
      IF file_already_attached THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$duplicate_device_file_gfn,
          'directory df gfn already used', status);
        EXIT /process_request/;
      IFEND;

    /directory_attached/
      BEGIN
        gfp$get_fde_p (directory_sfid, p_fde);
        p_fde^.eoi_byte_address := eoi_byte_address;
        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
        dmp$get_fmd_by_index (p_dfd, 1, p_fmd);
        p_fmd^.avt_index := avt_index;
        dmp$build_faus_from_dfl_entry (dat_sfid, stored_directory_dfl_entry, p_fmd,
                 p_dfd, p_mat, directory_sfid, 1, file_flawed, status);
        IF NOT status.normal THEN
          EXIT /directory_attached/;
        IFEND;

        EXIT /process_request/;

      END /directory_attached/;

      dmp$detach_device_file (directory_sfid, file_modified, fmd_modified, attach_status);

    END /process_request/;

  PROCEND dmp$attach_directory_from_label;
?? TITLE := '  dmp$attach_dat_from_label', EJECT ??

  PROCEDURE [XDCL] dmp$attach_dat_from_label (volume_label: dmt$ms_volume_label;
                                              avt_index: dmt$active_volume_table_index;
                                          VAR dat_sfid: dmt$system_file_id;
                                          VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copy DMP$STORE_EXISTING_DF_FAT
?? POP ??

    VAR
      able_to_locate_fde: boolean,
      allocated_length_in_bytes: amt$file_byte_address,
      attach_status: ost$status,
      dat_global_file_name: dmt$global_file_name,
      dat_stored_df_fmd: dmt$device_file_stored_fmd,
      eof_byte_address: amt$file_byte_address,
      eoi_byte_address: amt$file_byte_address,
      file_already_attached: boolean,
      file_modified: boolean,
      fmd_modified: boolean,
      number_faus: dmt$fau_entries,
      p_device_allocation_table_fat: ^dmt$stored_ms_device_file_fat,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      p_fmd: ^dmt$file_medium_descriptor,
      p_volume_label: ^dmt$ms_volume_label,
      p_volume_label_header: ^dmt$volume_label_header,
      p_volume_label_0_0: ^dmt$ms_label_0_0,
      p_stored_df_fat_header: ^dmt$stored_df_fat_header,
      stored_dat_dfl_entry: dmt$ms_device_file_list_entry;

    status.normal := TRUE;

  /process_request/
    BEGIN
      p_volume_label := ^volume_label;

      RESET p_volume_label;

      NEXT p_volume_label_header IN p_volume_label;
      IF p_volume_label_header = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
          'p_volume_label_header = NIL -DMMATCH', status);
        EXIT /process_request/;
      IFEND;

      CASE p_volume_label_header^.version_number OF
      = dmc$ms_label_0_0 =
        NEXT p_volume_label_0_0 IN p_volume_label;
        IF p_volume_label_0_0 = NIL THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
            'p_volume_label_0_0 = NIL - DMMATCH', status);
          EXIT /process_request/;
        IFEND;
        dat_stored_df_fmd := p_volume_label_0_0^.device_allocation_table_fmd;
        stored_dat_dfl_entry := p_volume_label_0_0^.dat_dfl_entry;
        dat_global_file_name := stored_dat_dfl_entry.global_file_name;
        allocated_length_in_bytes := stored_dat_dfl_entry.fmd_length;
        eof_byte_address := stored_dat_dfl_entry.end_of_file;
        eoi_byte_address := stored_dat_dfl_entry.end_of_information;
        NEXT p_stored_df_fat_header IN p_volume_label;
        IF p_stored_df_fat_header = NIL THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
            'p_stored_df_fat_header = NIL - DMMATCH', status);
          EXIT /process_request/;
        IFEND;
        number_faus := p_stored_df_fat_header^.number_faus;
        RESET p_volume_label TO p_stored_df_fat_header;
        NEXT p_device_allocation_table_fat: [1 .. number_faus] IN p_volume_label;
        IF p_device_allocation_table_fat = NIL THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
            'p_device_allocation_table_fat = NIL - DMMATCH', status);
          EXIT /process_request/;
        IFEND;
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
          'unsupported label version number', status);
        EXIT /process_request/;
      CASEND;

      dmp$attach_device_file_by_fmd (dat_global_file_name, dat_stored_df_fmd, file_already_attached, dat_sfid,
            status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;
      IF file_already_attached THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$duplicate_device_file_gfn,
          'dat df gfn already used', status);
        EXIT /process_request/;
      IFEND;

    /dat_attached/
      BEGIN
        gfp$get_fde_p (dat_sfid, p_fde);
        p_fde^.eoi_byte_address := eoi_byte_address;
        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
        dmp$get_fmd_by_index (p_dfd, 1, p_fmd);
        p_fmd^.avt_index := avt_index;

        dmp$store_existing_df_fat (dat_sfid, p_device_allocation_table_fat, status);
        IF status.normal THEN
          EXIT /process_request/;
        IFEND;

      END /dat_attached/;
      dmp$detach_device_file (dat_sfid, file_modified, fmd_modified, attach_status);

    END /process_request/;

  PROCEND dmp$attach_dat_from_label;
?? TITLE := '  dmp$attach_dflt_from_label', EJECT ??

  PROCEDURE [XDCL] dmp$attach_dflt_from_label (volume_label: dmt$ms_volume_label;
        dat_sfid: dmt$system_file_id;
    VAR dflt_sfid: dmt$system_file_id;
    VAR status: ost$status);

    VAR
      able_to_locate_fde: boolean,
      allocated_length_in_bytes: amt$file_byte_address,
      attach_status: ost$status,
      avt_index: dmt$active_volume_table_index,
      avt_search_key: dmt$avt_search_key,
      file_already_attached: boolean,
      file_flawed: boolean,
      daus_per_allocation_unit: dmt$daus_per_allocation,
      dflt_stored_df_fmd: dmt$device_file_stored_fmd,
      dflt_global_file_name: dmt$global_file_name,
      eof_byte_address: amt$file_byte_address,
      eoi_byte_address: amt$file_byte_address,
      file_modified: boolean,
      fmd_modified: boolean,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      p_fmd: ^dmt$file_medium_descriptor,
      p_mat: ^dmt$mainframe_allocation_table,
      p_stored_dfl_fmd_version: ^dmt$stored_ms_version_number,
      p_stored_dfl_fmd: ^dmt$device_file_stored_fmd,
      p_stored_dfl_fmd_header: ^dmt$stored_ms_fmd_header,
      p_stored_dfl_fmd_subfile: ^dmt$stored_ms_fmd_subfile,
      p_volume_label: ^dmt$ms_volume_label,
      p_volume_label_header: ^dmt$volume_label_header,
      p_volume_label_0_0: ^dmt$ms_label_0_0,
      stored_dfl_dfl_entry: dmt$ms_device_file_list_entry,
      volume_not_active: boolean;

    status.normal := TRUE;

  /process_request/
    BEGIN
      p_mat := NIL;
      allocated_length_in_bytes := 0;

      p_volume_label := ^volume_label;

      RESET p_volume_label;

      NEXT p_volume_label_header IN p_volume_label;
      IF p_volume_label_header = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
          'p_volume_label_header = NIL -DMMATCH', status);
        EXIT /process_request/;
      IFEND;

      avt_search_key.value := dmc$search_avt_by_rec_vsn;
      avt_search_key.recorded_vsn := p_volume_label_header^.recorded_vsn;

      dmp$search_active_volume_table (avt_search_key, avt_index, volume_not_active);
      IF volume_not_active THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found, 'volume not in avt',
              status);
        EXIT /process_request/;
      IFEND;

      CASE p_volume_label_header^.version_number OF
      = dmc$ms_label_0_0 =
        NEXT p_volume_label_0_0 IN p_volume_label;
        IF p_volume_label_0_0 = NIL THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
            'p_volume_label_0_0 = NIL - DMMATCH', status);
          EXIT /process_request/;
        IFEND;
        dflt_stored_df_fmd := p_volume_label_0_0^.device_file_list_fmd;
        stored_dfl_dfl_entry := p_volume_label_0_0^.device_file_list_dfl_entry;
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
          'unsupported label version number', status);
        EXIT /process_request/;
      CASEND;

      PUSH p_stored_dfl_fmd;

      daus_per_allocation_unit := stored_dfl_dfl_entry.daus_per_allocation_unit;
      dflt_global_file_name := stored_dfl_dfl_entry.global_file_name;
      allocated_length_in_bytes := stored_dfl_dfl_entry.fmd_length;
      eof_byte_address := stored_dfl_dfl_entry.end_of_file;
      eoi_byte_address := stored_dfl_dfl_entry.end_of_information;

      RESET p_stored_dfl_fmd;

      p_stored_dfl_fmd^ := dflt_stored_df_fmd;
      RESET p_stored_dfl_fmd;

      NEXT p_stored_dfl_fmd_version IN p_stored_dfl_fmd;

      NEXT p_stored_dfl_fmd_header: [0] IN p_stored_dfl_fmd;

      NEXT p_stored_dfl_fmd_subfile: [0] IN p_stored_dfl_fmd;

      CASE p_stored_dfl_fmd_version^ OF
      = 0 =
        p_stored_dfl_fmd_subfile^.version_0_0.device_file_list_index := dmc$device_file_list_dfl_index;
        p_stored_dfl_fmd_subfile^.version_0_0.internal_vsn := p_volume_label_header^.internal_vsn;
        p_stored_dfl_fmd_subfile^.version_0_0.recorded_vsn := p_volume_label_header^.recorded_vsn;
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
          'unsupported fmd version', status);
        EXIT /process_request/;
      CASEND;

      dmp$attach_device_file_by_fmd (dflt_global_file_name, dflt_stored_df_fmd, file_already_attached,
            dflt_sfid, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;
      IF file_already_attached THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$duplicate_device_file_gfn,
          'dflt df gfn already used', status);
        EXIT /process_request/;
      IFEND;

    /dflt_attached/
      BEGIN
        gfp$get_fde_p (dflt_sfid, p_fde);
        p_fde^.eoi_byte_address := eoi_byte_address;
        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
        dmp$get_fmd_by_index (p_dfd, 1, p_fmd);
        p_fmd^.avt_index := avt_index;

        dmp$build_faus_from_dfl_entry (dat_sfid, stored_dfl_dfl_entry, p_fmd,
                 p_dfd, p_mat, dflt_sfid, 1, file_flawed, status);
        IF NOT status.normal THEN
          EXIT /dflt_attached/;
        IFEND;
        EXIT /process_request/;

      END /dflt_attached/;

      dmp$detach_device_file (dflt_sfid, file_modified, fmd_modified, attach_status);

    END /process_request/;

  PROCEND dmp$attach_dflt_from_label;
MODEND dmm$attach_file;
*DECK DECK=DMM$AVT_CLASS_COUNTS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE dmm$avt_class_counts;

?? PUSH (LISTEXT := ON) ??
*copyc dmv$active_volume_table
*copyc dmp$attach_device_file
*copyc dmp$close_file
*copyc dmp$detach_device_file
*copyc dmt$error_condition_codes
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_fmd_by_index
*copyc dmp$lock_avt_entry
*copyc dmp$unlock_avt_entry
*copyc dmp$open_label
*copyc dmv$system_class
*copyc gfp$get_fde_p
*copyc mmp$write_modified_pages
*copyc osp$set_status_abnormal
*copyc pmp$delay
?? POP ??


PROCEDURE [XDCL] dmp$increment_class_activity (
      sfid: gft$system_file_identifier;
  VAR status: ost$status);

  VAR
    fde: gft$file_desc_entry_p,
    pdfd: ^dmt$disk_file_descriptor,
    p_fmd: ^dmt$file_medium_descriptor,
    able_to_lock: boolean,
    able_to_clear: boolean,
    avt_index: dmt$active_volume_table_index,
    system_class: dmt$system_class,
    class: dmt$class_member;

    status.normal := TRUE;
    gfp$get_fde_p (sfid, fde);
    IF fde^.media <> gfc$fm_mass_storage_file THEN
      RETURN;
    IFEND;
    dmp$get_disk_file_descriptor_p (fde, pdfd);
    dmp$get_fmd_by_index (pdfd, 1, p_fmd);
    avt_index := p_fmd^.avt_index;
    class := pdfd^.requested_class;
    IF (class IN dmv$system_class) THEN
       system_class := dmv$system_class_conversion [class];
       dmp$lock_avt_entry (avt_index, able_to_lock);
       IF NOT able_to_lock THEN
         REPEAT
           pmp$delay (2000,status);
           dmp$lock_avt_entry (avt_index, able_to_lock);
         UNTIL able_to_lock;
       IFEND;
       dmv$p_active_volume_table^ [avt_index].mass_storage.system_class_activity [system_class] :=
         dmv$p_active_volume_table^ [avt_index].mass_storage.system_class_activity [system_class] + 1;
       dmp$unlock_avt_entry (avt_index, able_to_clear);
       IF NOT able_to_clear THEN
         osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_clear_avt_lock,
          'Unable to clear avt entry lock - dmp$increment_class_activity', status);
       IFEND;
     IFEND;
  PROCEND dmp$increment_class_activity;
?? EJECT ??

  PROCEDURE [XDCL] dmp$decrement_class_activity (
        sfid: gft$system_file_identifier;
    VAR status: ost$status);

  VAR
    fde: gft$file_desc_entry_p,
    pdfd: ^dmt$disk_file_descriptor,
    p_fmd: ^dmt$file_medium_descriptor,
    able_to_lock: boolean,
    able_to_clear: boolean,
    avt_index: dmt$active_volume_table_index,
    system_class: dmt$system_class,
    class: dmt$class_member;


    status.normal := TRUE;
    gfp$get_fde_p (sfid, fde);
    dmp$get_disk_file_descriptor_p (fde, pdfd);
    dmp$get_fmd_by_index (pdfd, 1, p_fmd);

    avt_index := p_fmd^.avt_index;
{
{   Check for valid avt_index before using to lock entry, if invalid will cycle loop below and hang
{   the system. The avt_index will be 0 (invalid) if the file has not been assigned to a volume.
{
    IF (avt_index >= LOWERBOUND(dmv$p_active_volume_table^)) AND
      (avt_index <= UPPERBOUND(dmv$p_active_volume_table^)) THEN
      class := pdfd^.requested_class;
      IF (class IN dmv$system_class) THEN
        system_class := dmv$system_class_conversion [class];
        dmp$lock_avt_entry (avt_index, able_to_lock);
        IF NOT able_to_lock THEN
          REPEAT
            pmp$delay (2000,status);
            dmp$lock_avt_entry (avt_index, able_to_lock);
          UNTIL able_to_lock;
        IFEND;

        IF dmv$p_active_volume_table^ [avt_index].mass_storage.system_class_activity [system_class] > 0 THEN
          dmv$p_active_volume_table^ [avt_index].mass_storage.system_class_activity [system_class] :=
            dmv$p_active_volume_table^ [avt_index].mass_storage.system_class_activity [system_class] - 1;
        IFEND;

        dmp$unlock_avt_entry (avt_index, able_to_clear);
        IF NOT able_to_clear THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_clear_avt_lock,
            'Unable to clear avt entry lock - dmp$decrement_class_activity', status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND dmp$decrement_class_activity;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$add_class_to_volume (
        avt_index: dmt$active_volume_table_index;
        class: dmt$class;
    VAR status: ost$status);

    VAR
      able_to_lock: boolean,
      able_to_clear: boolean;


    dmp$lock_avt_entry (avt_index, able_to_lock);
    IF NOT able_to_lock THEN
      REPEAT
        pmp$delay (2000, status);
        dmp$lock_avt_entry (avt_index, able_to_lock);
      UNTIL able_to_lock;
    IFEND;
    update_label (
      class, dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn, status);
    IF status.normal THEN
      dmv$p_active_volume_table^ [avt_index].mass_storage.class := class;
    IFEND;
    dmp$unlock_avt_entry (avt_index, able_to_clear);
    IF NOT able_to_clear THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_clear_avt_lock,
        'unable to release avt entry lock - DMMAVTCC', status);
    IFEND;
  PROCEND dmp$add_class_to_volume;
?? EJECT ??

  PROCEDURE update_label (class: dmt$class;
        rvsn: rmt$recorded_vsn;
    VAR status: ost$status);

    VAR
      ignore: boolean,
      ost: ost$status,
      p_label: ^dmt$ms_volume_label,
      p_hdr: ^dmt$volume_label_header,
      p_body: ^dmt$ms_label_0_0,
      system_file_id: gft$system_file_identifier,
      user_supplied_name: ost$name;

    status.normal := TRUE;
    user_supplied_name := osc$null_name;
    user_supplied_name (1, 5) := 'LABEL';
    user_supplied_name (6, rmc$recorded_vsn_size) := rvsn;

    dmp$attach_device_file (rvsn, user_supplied_name,
          system_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dmp$open_label (system_file_id, osc$os_ring_1, osc$tsrv_ring,
          mmc$sar_modify, mmc$as_random, p_label, status);
    IF NOT status.normal THEN
      dmp$detach_device_file (system_file_id, ignore, ignore, ost);
      RETURN;
    IFEND;

    RESET p_label;
    NEXT p_hdr IN p_label;
    NEXT p_body IN p_label;
    p_body^.class := class;

    mmp$write_modified_pages (p_hdr, #SIZE (p_hdr^), osc$wait, status);
    dmp$close_file (p_label, ost);
    dmp$detach_device_file (system_file_id, ignore, ignore, ost);

  PROCEND update_label;
MODEND dmm$avt_class_counts;
*DECK DECK=DMM$BUILD_DEVICE_ADDRESS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$build_device_address;

{ PURPOSE:
{   The purpose of this module is to provide physical IO with information
{   pertaining to files on disk.
{ DESIGN:
{   All address translation is performed here. In addition physical IO
{   is informed whether a write is a write/initialize.

?? PUSH (LISTEXT := ON) ??
?? TITLE := '  Common Decks', EJECT ??
*copyc amt$file_byte_address
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_fau_entry_and_fmd
*copyc dmp$get_fmd_by_index
*copyc dmp$get_mat_pointer
*copyc dmp$preset_conversion
*copyc dmt$active_volume_table
*copyc dmt$allocation_size
*copyc dmt$disk_file_descriptor
*copyc dmt$error_condition_codes
*copyc dmt$file_allocation_descriptor
*copyc dmt$file_attributes
*copyc dmt$file_descriptor_entry
*copyc dmt$file_table_lock
*copyc dmt$keypoint_calls
*copyc dmt$minimum_allocation_unit
*copyc dmt$monitor_request_blocks
*copyc dmt$ms_logical_device_address
*copyc dmv$active_volume_table
*copyc dmv$allocation_log
*copyc gft$locked_file_desc_entry_p
*copyc gft$system_file_identifier
*copyc iot$logical_unit
*copyc iot$io_function
*copyc jmt$ijl_ordinal
*copyc jmv$system_ijl_ordinal
*copyc mtc$job_fixed_segment
*copyc mtp$error_stop
*copyc mtp$set_status_abnormal
*copyc osk$keypoints
*copyc osp$fetch_locked_variable
*copyc oss$mainframe_wired
*copyc ost$hardware_subranges
*copyc osv$page_size
*copyc pmt$initialization_value
*copyc syt$monitor_request_code
*copyc syv$test_jr_system
?? POP ??
?? TITLE := '  XDCL Variables', EJECT ??

  VAR
    dmv$last_fde_rejected: [XDCL, STATIC, oss$mainframe_wired] gft$locked_file_desc_entry_p,
    dmv$transient_errors: [XDCL, STATIC, oss$mainframe_wired] integer := 0,
    dmv$job_mode_fix_reqs: [XDCL, STATIC, oss$mainframe_wired] integer := 0;
?? TITLE := '  dmp$build_device_address', EJECT ??
*copy dmh$build_device_address

  PROCEDURE  dmp$build_device_address
    (    p_fde: gft$locked_file_desc_entry_p;
         p_dfd: ^dmt$disk_file_descriptor;
         p_fmd: ^dmt$file_medium_descriptor;
         p_fau: ^dmt$file_allocation_unit;
         preset_value: pmt$initialization_value;
         byte_address: amt$file_byte_address;
         number_bytes: amt$file_byte_address;
     VAR device_address: dmt$ms_logical_device_address;
     VAR status: syt$monitor_status);

    VAR
      allocation_unit_mau_address: dmt$mau_address,
      allocation_unit_write_status: boolean,
      byte_offset_within_au: dmt$byte_offset_within_au,
      bytes_per_allocation: dmt$bytes_per_allocation,
      bytes_per_mau: dmt$bytes_per_mau,
      mau_offset_within_au: dmt$mau_offset_within_au,
      maus_per_allocation: dmt$maus_per_allocation,
      maus_per_dau: dmt$maus_per_dau,
      maus_per_position: dmt$maus_per_position,
      maus_per_transfer_unit: dmt$maus_per_transfer,
      last_mau_offset_within_au: dmt$mau_offset_within_au,
      logical_unit_number: iot$logical_unit,
      transfer_length: dmt$maus_per_transfer,
      transfer_length_in_maus: dmt$maus_per_transfer,
      transfer_mau_address: dmt$mau_address,
      transfer_mau_offset: dmt$mau_offset_within_tu;

    status.normal := TRUE;

  /process_request/
    BEGIN
      logical_unit_number := dmv$p_active_volume_table^ [p_fmd^.avt_index].logical_unit_number;
      maus_per_dau := p_fmd^.maus_per_dau;
      maus_per_position := p_fmd^.daus_per_cylinder * maus_per_dau;
      bytes_per_allocation := p_dfd^.bytes_per_allocation;
      maus_per_transfer_unit := p_fmd^.maus_per_transfer_unit;
      bytes_per_mau := p_fmd^.bytes_per_mau;
      maus_per_allocation := bytes_per_allocation DIV bytes_per_mau;

      IF p_fau^.state = dmc$fau_initialization_in_prog THEN
        mtp$set_status_abnormal (dmc$device_manager_ident, dme$transient_error, status);
        dmv$transient_errors := dmv$transient_errors + 1;
        dmv$last_fde_rejected := p_fde;
        EXIT /process_request/;
      IFEND;

      byte_offset_within_au := byte_address MOD bytes_per_allocation;
      mau_offset_within_au := byte_offset_within_au DIV bytes_per_mau;
      last_mau_offset_within_au := (byte_offset_within_au + number_bytes - 1 + bytes_per_mau - 1) DIV
            bytes_per_mau;
      transfer_length_in_maus := last_mau_offset_within_au - mau_offset_within_au;

      IF transfer_length_in_maus > maus_per_allocation THEN
        transfer_length_in_maus := maus_per_allocation;
      IFEND;

      allocation_unit_mau_address := p_fau^.dau_address * maus_per_dau;

      IF device_address.write_translation AND ((p_fau^.state = dmc$fau_invalid_data) OR
          (p_fau^.state = dmc$fau_invalid_and_flawed)) THEN
        transfer_mau_address := allocation_unit_mau_address;
        transfer_mau_offset := mau_offset_within_au;
        allocation_unit_write_status := FALSE;
      ELSE
        transfer_mau_address := (mau_offset_within_au DIV maus_per_transfer_unit) * maus_per_transfer_unit +
              allocation_unit_mau_address;
        transfer_mau_offset := mau_offset_within_au MOD maus_per_transfer_unit;
        allocation_unit_write_status := TRUE;
      IFEND;

      device_address.logical_unit_number := logical_unit_number;
      device_address.allocation_unit_mau_address := transfer_mau_address;
      device_address.transfer_length := transfer_length_in_maus;
      device_address.transfer_mau_offset := transfer_mau_offset;
      device_address.maus_per_position := maus_per_position;
      IF device_address.write_translation THEN
        device_address.au_was_previously_written := allocation_unit_write_status;
        device_address.maus_per_allocation_unit := maus_per_allocation;
        device_address.preset_value := dmp$preset_conversion (preset_value);
      IFEND;

    END /process_request/;

  PROCEND dmp$build_device_address;
?? TITLE := '  dmp$write', EJECT ??
*copy dmh$write

  PROCEDURE [XDCL] dmp$write
    (    p_fde: gft$locked_file_desc_entry_p;
         byte_address: amt$file_byte_address;
         length: amt$file_byte_address;
         io_function: iot$io_function;
     VAR device_address: dmt$ms_logical_device_address;
     VAR status: syt$monitor_status);

    VAR
      allocate_request_block: dmt$monitor_rb_allocate_space,
      dmv$allocation_log_rejects: [XDCL] integer := 0,
      logging_required_for_file: boolean,
      new_fmd_length: ost$byte_count,
      number: integer,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fmd: ^dmt$file_medium_descriptor,
      p_fau: ^dmt$file_allocation_unit,
      syv$allow_jr_test: [XREF] boolean,
      transfer_size: ost$byte_count;

    status.normal := TRUE;

  /process_request/
    BEGIN

      device_address.write_translation := TRUE;

      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

      dmp$get_fau_entry_and_fmd (p_dfd, byte_address, p_fau, p_fmd);
      IF (p_fau = NIL) OR (p_fmd = NIL) OR (p_fau^.state = dmc$fau_free) THEN
        mtp$set_status_abnormal (dmc$device_manager_ident, dme$job_mode_allocate_required, status);
        RETURN;
      IFEND;

      IF dmv$p_active_volume_table^ [p_fmd^.avt_index].mass_storage.volume_unavailable THEN
        mtp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable, status);
        EXIT /process_request/;
      IFEND;

      dmp$build_device_address (p_fde, p_dfd, p_fmd, p_fau, p_fde^.preset_value, byte_address, length,
            device_address, status);

      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      transfer_size := length DIV p_fmd^.bytes_per_mau;

      IF (transfer_size > device_address.transfer_length) OR (length MOD p_fmd^.bytes_per_mau <> 0) OR
            (length = 0) THEN
        mtp$error_stop ('bad length in write request (dmp$write)');
      IFEND;

      {Commit allocation log entry for initialize if required and available
      IF NOT device_address.au_was_previously_written THEN
        logging_required_for_file := (p_fde^.file_kind <= gfc$fk_last_permanent_file);
        IF logging_required_for_file THEN
          osp$fetch_locked_variable (dmv$allocation_log.number, number);
          IF (number + dmv$allocation_log.committed_initialize_count) >=
              dmc$max_allocation_log_entries THEN
            dmv$allocation_log_rejects := dmv$allocation_log_rejects + 1;
            dmv$last_fde_rejected := p_fde;
            mtp$set_status_abnormal (dmc$device_manager_ident, dme$transient_error, status);
            EXIT /process_request/;
          ELSE
            dmv$allocation_log.committed_initialize_count :=
              dmv$allocation_log.committed_initialize_count + 1;
          IFEND;
        IFEND;
      IFEND;

      IF (p_fau^.state = dmc$fau_invalid_data) OR
            (p_fau^.state = dmc$fau_invalid_and_flawed) THEN
        IF (#segment (p_fde) > 1) AND
              ((io_function = ioc$write_page) OR (io_function = ioc$write_locked_page)) THEN
          p_fau^.state := dmc$fau_initialized;
        ELSE
          p_fau^.state := dmc$fau_initialization_in_prog;
        IFEND;
      IFEND;

      IF (#segment (p_fde) = 1) OR
            ((io_function <> ioc$write_page) AND (io_function <> ioc$write_locked_page)) THEN
        p_dfd^.read_write_count := p_dfd^.read_write_count + 1;
      IFEND;
      IF syv$allow_jr_test THEN
        IF syc$tjr_crash_in_dmwrite IN syv$test_jr_system THEN
          IF (#segment (p_fde) > mtc$job_fixed_segment) THEN
            mtp$error_stop ('JOB RECOVERY TEST');
          IFEND;
        IFEND;
      IFEND;
    END /process_request/;

  PROCEND dmp$write;
?? TITLE := '  dmp$read', EJECT ??
*copy dmh$read

  PROCEDURE [XDCL] dmp$read
    (    p_fde: gft$locked_file_desc_entry_p;
         byte_address: amt$file_byte_address;
         length_in_bytes: amt$file_byte_address;
     VAR device_address: dmt$ms_logical_device_address;
     VAR status: syt$monitor_status);

    VAR
      p_dfd: ^dmt$disk_file_descriptor,
      p_fau: ^dmt$file_allocation_unit,
      p_fmd: ^dmt$file_medium_descriptor,
      read_status: syt$monitor_status,
      syv$allow_jr_test: [XREF] boolean;

    status.normal := TRUE;

    device_address.write_translation := FALSE;

    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

    dmp$get_fau_entry_and_fmd (p_dfd, byte_address, p_fau, p_fmd);
    IF (p_fau = NIL) OR (p_fmd = NIL) OR (p_fau^.state = dmc$fau_free) THEN
      mtp$error_stop (' attempt to read unallocated area - dmp$read');
    IFEND;

    IF dmv$p_active_volume_table^ [p_fmd^.avt_index].mass_storage.volume_unavailable THEN
      mtp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable, status);
      RETURN;
    IFEND;

    dmp$build_device_address (p_fde, p_dfd, p_fmd, p_fau, p_fde^.preset_value, byte_address, length_in_bytes,
          device_address, status);
    IF status.normal THEN
      p_dfd^.read_write_count := p_dfd^.read_write_count + 1;
      IF syv$allow_jr_test THEN
        IF syc$tjr_crash_in_dmread IN syv$test_jr_system THEN
          IF (#segment (p_fde) > 14(16)) THEN
            mtp$error_stop ('JOB RECOVERY TEST');
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND dmp$read;

MODEND dmm$build_device_address;
*DECK DECK=DMM$CREATE_NEW_FILE EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$create_new_file;
?? PUSH (LISTEXT := ON) ??
?? TITLE := '  Common Decks', EJECT ??
*copyc amt$file_byte_address
*copyc dmp$allocate_file_space_r1
*copyc dmp$clear_master_attach_lock
*copyc dmp$close_file
*copyc dmp$create_fmds
*copyc dmp$create_fd_entry
*copyc dmp$create_disk_file_descriptor
*copyc dmp$destroy_file
*copyc dmp$evacuate_active_device_log
*copyc dmp$generate_gfn_hash
*copyc dmp$get_active_vol_attributes
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_stored_fmd
*copyc dmp$open_directory
*copyc dmp$reserve_fmd
*copyc dmp$search_vol_directory_name
*copyc dmp$set_file_residence
*copyc dmp$set_file_table_locator
*copyc dmp$set_master_attach_lock
*copyc dmp$unconditional_get_dfd_p
*copyc dmt$allocation_size
*copyc dmt$chapter_number
*copyc dmt$error_condition_codes
*copyc dmt$file_attributes
*copyc dmt$file_location
*copyc dmt$file_share_history
*copyc dmt$global_file_name
*copyc dmt$keypoint_calls
*copyc dmt$new_device_file_attribute
*copyc dmt$new_file_attribute
*copyc dmt$system_file_id
*copyc dmv$null_sfid
*copyc gfp$get_locked_fde_p
*copyc gfp$lock_fde
*copyc gfp$unlock_fde_p
*copyc gft$table_residence
*copyc mmp$write_modified_pages
*copyc mmv$shared_pages_in_jws
*copyc osk$keypoints
*copyc osp$generate_unique_binary_name
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc ost$wait
*copyc osv$deadstart_phase
*copyc pfd$permanent_file_attributes
*copyc sft$file_space_limit_kind
*copyc syv$job_initialization_complete
?? POP ??
?? TITLE := '  dmp$create_device_file', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$create_device_file (user_supplied_name: ost$name;
        recorded_vsn: rmt$recorded_vsn;
        p_file_attributes: ^array [1 .. * ] OF dmt$new_device_file_attribute;
        byte_address: amt$file_byte_address;
    VAR system_file_id: gft$system_file_identifier;
    VAR status: ost$status);

    VAR
      p_file_descriptor_entry: ^gft$file_descriptor_entry,
      p_attributes: ^array [ * ] of dmt$assigned_ms_vol_attribute,
      avt_index: dmt$active_volume_table_index,
      directory_sfid: gft$system_file_identifier,
      volume_active: boolean,
      logging_active: boolean,
      directory_index: dmt$directory_index,
      entry_found: boolean,
      global_file_name: dmt$global_file_name,
      local_status: ost$status;

    status.normal := TRUE;

  /create_device_file/
    BEGIN

      PUSH p_attributes: [1 .. 3];

      avt_index := 0;
      p_attributes^ [1].keyword := dmc$ms_volume_directory;
      p_attributes^ [2].keyword := dmc$avt_index;
      p_attributes^ [3].keyword := dmc$ms_device_log;

      dmp$get_active_vol_attributes (recorded_vsn, avt_index, p_attributes, volume_active);
      IF NOT volume_active THEN
{       issue mount request
        osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found, 'dmp$create_device_file',
              status);
        EXIT /create_device_file/;
      IFEND;

      directory_sfid := p_attributes^ [1].directory_sfid;
      avt_index := p_attributes^ [2].index;
      logging_active := p_attributes^ [3].p_dlog <> dmv$null_sfid;

      directory_index := 0;
      dmp$search_vol_directory_name (user_supplied_name, directory_sfid, directory_index, entry_found,
            status);
      IF NOT status.normal THEN
        EXIT /create_device_file/;
      IFEND;

      IF entry_found THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$device_file_already_exists,
          'FILE ALREADY EXISTS', status);
        EXIT /create_device_file/;
      IFEND;

      create_volume_device_file (byte_address, p_file_attributes, recorded_vsn, system_file_id,
            global_file_name, status);

      IF status.normal THEN
        IF logging_active AND (osv$deadstart_phase <> osc$recovery_deadstart) THEN
          dmp$evacuate_active_device_log (avt_index, status);
        IFEND;

        IF status.normal THEN
          create_directory_entry (directory_sfid, user_supplied_name, global_file_name, system_file_id,
                status);
        IFEND;

        IF NOT status.normal THEN
          dmp$destroy_file (system_file_id, sfc$no_limit, local_status);
        IFEND;
      IFEND;

    END /create_device_file/;

  PROCEND dmp$create_device_file;
?? TITLE := '  dmp$create_file_entry', EJECT ??
*copy dmh$create_file_entry

  PROCEDURE [XDCL, #GATE] dmp$create_file_entry (file_kind: gft$file_kind;
        file_usage: pft$usage_selections;
        file_share_selections: pft$share_selections;
        file_share_history: dmt$file_share_history;
        p_file_attributes: ^array [ * ] OF dmt$new_file_attribute;
        byte_address: amt$file_byte_address;
        assign_volume: boolean;
    VAR global_file_name: dmt$global_file_name;
    VAR system_file_id: gft$system_file_identifier;
    VAR status: ost$status);

    VAR
      able_to_reserve_fmd: boolean,
      allocate_byte_address: amt$file_byte_address,
      attachable_type_of_file: boolean,
      bytes_to_allocate: amt$file_byte_address,
      chapter_number: dmt$chapter_number,
      dfd_pointer: ost$relative_pointer,
      file_locator: dmt$file_location,
      file_table_residence: gft$table_residence,
      fmd_index: dmt$fmd_index,
      file_name: dmt$global_file_name,
      file_hash: dmt$file_hash,
      file_space_limit: sft$file_space_limit_kind,
      index: integer,
      local_status: ost$status,
      lower: integer,
      p_dfd: ^dmt$disk_file_descriptor,
      p_file_descriptor_entry: ^gft$file_descriptor_entry,
      p_file_entry_attributes: ^array [ * ] of dmt$file_attribute,
      queue_status: gft$queue_status,
      upper: integer;

    status.normal := TRUE;
    file_space_limit := sfc$no_limit;

  /process_request/
    BEGIN
      chapter_number := 0;
      allocate_byte_address := 0;
      bytes_to_allocate := byte_address;

      osp$generate_unique_binary_name (file_name, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      global_file_name := file_name;

      dmp$set_file_residence (file_kind, file_table_residence, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      system_file_id.residence := file_table_residence;

      IF (NOT syv$job_initialization_complete) AND (file_table_residence =
          gfc$tr_job) THEN
        {Local files created early must have same hash
        global_file_name.sequence_number := 0;
      IFEND;

      dmp$generate_gfn_hash (global_file_name, file_hash);
{
{             set system file id
{
      system_file_id.file_hash := file_hash;
{
{             establish computer system residence
{
{
{             establish computer system location
{
      dmp$set_file_table_locator (file_table_residence, file_locator, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

{
{                   determine the file's queue status
{
      dmp$determine_queue_status (file_kind, file_usage, file_share_selections, queue_status, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      attachable_type_of_file := (file_kind = gfc$fk_job_permanent_file) OR
           (file_kind = gfc$fk_device_file) OR (file_kind = gfc$fk_catalog);

      IF p_file_attributes = NIL THEN
        lower := 1;
        upper := 5;
        index := 0;
      ELSE
        lower := LOWERBOUND (p_file_attributes^);
        upper := UPPERBOUND (p_file_attributes^) + 6;
      IFEND;

      PUSH p_file_entry_attributes: [lower .. upper];

      IF p_file_attributes <> NIL THEN
        p_file_entry_attributes^ [upper].keyword := dmc$setname;
        p_file_entry_attributes^ [upper].setname := ' ';

        FOR index := LOWERBOUND (p_file_attributes^) TO UPPERBOUND (p_file_attributes^) DO
          IF (p_file_attributes^ [index].keyword < LOWERVALUE (dmt$file_attribute_keywords)) OR
                (p_file_attributes^ [index].keyword > UPPERVALUE (dmt$file_attribute_keywords)) THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$unrecognizable_case_select,
                  'Bad case selector - dmp$create_file_entry.', status);
            EXIT /process_request/;
          IFEND;
          CASE p_file_attributes^ [index].keyword OF
          = dmc$class =
            p_file_entry_attributes^ [index].keyword := p_file_attributes^ [index].keyword;
            p_file_entry_attributes^ [index].class := p_file_attributes^ [index].class;
          = dmc$class_ordinal =
            p_file_entry_attributes^ [index].keyword := p_file_attributes^ [index].keyword;
            p_file_entry_attributes^ [index].ordinal := p_file_attributes^ [index].ordinal;
          = dmc$clear_space =
            p_file_entry_attributes^ [index].keyword := p_file_attributes^ [index].keyword;
            p_file_entry_attributes^ [index].required := p_file_attributes^ [index].required;
          = dmc$file_limit =
            p_file_entry_attributes^ [index].keyword := p_file_attributes^ [index].keyword;
            p_file_entry_attributes^ [index].limit := p_file_attributes^ [index].limit;
          = dmc$locked_file =
            p_file_entry_attributes^ [index].keyword := p_file_attributes^ [index].keyword;
            p_file_entry_attributes^ [index].file_lock := p_file_attributes^ [index].file_lock;
          = dmc$master_volume_required =
            p_file_entry_attributes^ [index].keyword := p_file_attributes^ [index].keyword;
            p_file_entry_attributes^ [index].master_volume_required := p_file_attributes^ [index].
                  master_volume_required;
          = dmc$overflow =
            p_file_entry_attributes^ [index].keyword := p_file_attributes^ [index].keyword;
            p_file_entry_attributes^ [index].overflow_allowed := p_file_attributes^ [index].overflow_allowed;
          = dmc$owner =
            p_file_entry_attributes^ [index].keyword := p_file_attributes^ [index].keyword;
            p_file_entry_attributes^ [index].file_space_limit := p_file_attributes^ [index].file_space_limit;
            file_space_limit := p_file_attributes^ [index].file_space_limit;
          = dmc$preset_value =
            p_file_entry_attributes^ [index].keyword := p_file_attributes^ [index].keyword;
            p_file_entry_attributes^ [index].preset_value := p_file_attributes^ [index].preset_value;
          = dmc$requested_allocation_size =
            p_file_entry_attributes^ [index].keyword := p_file_attributes^ [index].keyword;
            p_file_entry_attributes^ [index].requested_allocation_size := p_file_attributes^ [index].
                  requested_allocation_size;
          = dmc$requested_transfer_size =
            p_file_entry_attributes^ [index].keyword := p_file_attributes^ [index].keyword;
            p_file_entry_attributes^ [index].requested_transfer_size := p_file_attributes^ [index].
                  requested_transfer_size;
          = dmc$requested_volume =
            p_file_entry_attributes^ [index].keyword := p_file_attributes^ [index].keyword;
            p_file_entry_attributes^ [index].requested_volume := p_file_attributes^ [index].requested_volume;
            p_file_entry_attributes^ [upper].setname := p_file_attributes^ [index].requested_volume.setname;
          = dmc$chapter_length =
            p_file_entry_attributes^ [index].keyword := p_file_attributes^ [index].keyword;
            p_file_entry_attributes^ [index].chapter_length := p_file_attributes^ [index].chapter_length;
          ELSE
            ;
          CASEND;
        FOREND;
      IFEND;

      index := index + 1;
      p_file_entry_attributes^ [index].keyword := dmc$global_file_name;
      p_file_entry_attributes^ [index].global_file_name := global_file_name;
      index := index + 1;
      p_file_entry_attributes^ [index].keyword := dmc$file_kind;
      p_file_entry_attributes^ [index].file_kind := file_kind;
      index := index + 1;
      p_file_entry_attributes^ [index].keyword := dmc$file_hash;
      p_file_entry_attributes^ [index].file_hash := file_hash;
      index := index + 1;
      p_file_entry_attributes^ [index].keyword := dmc$write_mode;
      p_file_entry_attributes^ [index].attached_in_write_mode := attachable_type_of_file;
      index := index + 1;
      p_file_entry_attributes^ [index].keyword := dmc$queue_status;
      p_file_entry_attributes^ [index].queue_status := queue_status;

      IF attachable_type_of_file THEN
        dmp$set_master_attach_lock (system_file_id);
      IFEND;

      dmp$create_fd_entry (p_file_entry_attributes, system_file_id, status);

      IF attachable_type_of_file THEN
        dmp$clear_master_attach_lock (system_file_id);
      IFEND;
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      gfp$get_locked_fde_p (system_file_id, p_file_descriptor_entry);
      IF p_file_descriptor_entry = NIL THEN
        EXIT /process_request/;
      IFEND;

      dmp$get_disk_file_descriptor_p (p_file_descriptor_entry, p_dfd);

      dmp$create_fmds (file_locator, p_dfd, 1, status);

      dmp$reserve_fmd (p_dfd, fmd_index, able_to_reserve_fmd);
      IF NOT able_to_reserve_fmd THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_overflow,
          'unable to reserve fmd entry', status);
        gfp$unlock_fde_p (p_file_descriptor_entry);
        EXIT /process_request/;
      IFEND;

      p_dfd^.current_fmd_index := fmd_index;

      gfp$unlock_fde_p (p_file_descriptor_entry);

      IF (assign_volume) OR (byte_address > 0) OR (file_kind = gfc$fk_device_file) THEN
        dmp$allocate_file_space_r1 (system_file_id, allocate_byte_address, bytes_to_allocate, chapter_number,
              osc$nowait, file_space_limit, status);
        IF NOT status.normal THEN
          dmp$destroy_file (system_file_id, file_space_limit, local_status);
          system_file_id :=  dmv$null_sfid;
        IFEND;
      IFEND;

    END /process_request/;

  PROCEND dmp$create_file_entry;

?? TITLE := '  dmp$create_disk_file', EJECT ??

  PROCEDURE [XDCL] dmp$create_disk_file (p_fde: gft$file_desc_entry_p;
        p_file_attributes: ^array [ * ] OF dmt$file_attribute;
        allocation_length: amt$file_byte_address;
        system_file_id: gft$system_file_identifier;
    VAR status: ost$status);

    VAR
      able_to_reserve_fmd: boolean,
      allocate_byte_address: amt$file_byte_address,
      dfd_pointer: ost$relative_pointer,
      file_locator: dmt$file_location,
      file_space_limit: sft$file_space_limit_kind,
      fmd_index: dmt$fmd_index,
      index: integer,
      p_dfd: ^dmt$disk_file_descriptor,
      p_file_entry_attributes: ^array [ * ] of dmt$file_attribute;

    status.normal := TRUE;
    file_space_limit := sfc$no_limit;

  /process_request/
    BEGIN

      dmp$set_file_table_locator (system_file_id.residence, file_locator, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      gfp$lock_fde (p_fde);

      dmp$create_disk_file_descriptor (p_fde^.file_kind, file_locator, p_file_attributes,
            dfd_pointer);

      p_fde^.disk_file_descriptor_p := dfd_pointer;

      dmp$unconditional_get_dfd_p (p_fde, p_dfd);
      dmp$create_fmds (file_locator, p_dfd, 1, status);

      dmp$reserve_fmd (p_dfd, fmd_index, able_to_reserve_fmd);
      IF NOT able_to_reserve_fmd THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_overflow,
          'unable to reserve fmd entry - dmp$create_disk_file', status);
        gfp$unlock_fde_p (p_fde);
        EXIT /process_request/;
      IFEND;
      p_dfd^.current_fmd_index := fmd_index;
      p_fde^.media := gfc$fm_mass_storage_file;

      gfp$unlock_fde_p (p_fde);

    END /process_request/;

  PROCEND dmp$create_disk_file;

?? TITLE := '  dmp$determine_queue_status', EJECT ??

  PROCEDURE [XDCL] dmp$determine_queue_status (file_kind: gft$file_kind;
        file_usage: pft$usage_selections;
        file_share_selections: pft$share_selections;
    VAR queue_status: gft$queue_status;
    VAR status: ost$status);

    VAR
      sharing_permitted: boolean,
      usage_has_write: boolean,
      other_writers_permitted: boolean,
      modify_options: pft$usage_selections;

    status.normal := TRUE;
    modify_options := $pft$usage_selections [pfc$shorten, pfc$append, pfc$modify];
{
{ Determine the queue_status of the file based on the file_type and the usage
{ and share selections under which the file is being attached.
{
    CASE file_kind OF

    = gfc$fk_job_local_file, gfc$fk_unnamed_file =
      queue_status := gfc$qs_job_working_set;

    = gfc$fk_device_file, gfc$fk_catalog, gfc$fk_global_unnamed =
      queue_status := gfc$qs_global_shared;

    = gfc$fk_job_permanent_file =
      sharing_permitted := file_share_selections <> $pft$share_selections [];
      usage_has_write := (modify_options * file_usage) <> $pft$usage_selections [];
      other_writers_permitted := (modify_options * file_share_selections) <> $pft$share_selections [];

      IF NOT mmv$shared_pages_in_jws THEN
        queue_status := gfc$qs_global_shared;
      ELSE
        IF NOT sharing_permitted THEN
          queue_status := gfc$qs_job_working_set;
        ELSEIF (sharing_permitted) AND (NOT usage_has_write) AND (NOT other_writers_permitted) THEN
          queue_status := gfc$qs_job_shared;
        ELSE
          queue_status := gfc$qs_global_shared;
        IFEND;
      IFEND;
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unrecognizable_case_select,
          'Invalid file type - dmp$determine_queue_status.', status);
    CASEND;
  PROCEND dmp$determine_queue_status;
?? TITLE := '  create_directory_entry', EJECT ??

  PROCEDURE create_directory_entry (directory_sfid: gft$system_file_identifier;
        user_supplied_name: ost$name;
        global_file_name: dmt$global_file_name;
        system_file_id: gft$system_file_identifier;
    VAR status: ost$status);

    VAR
      p_directory: ^dmt$ms_volume_directory,
      available_directory_index: dmt$directory_index,
      directory_index: dmt$directory_index;

    status.normal := TRUE;

    dmp$open_directory (directory_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend,
       mmc$as_sequential, p_directory, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /create_entry/
    BEGIN

      available_directory_index := 0;

    /find_available_entry/
      FOR directory_index := 1 TO p_directory^.header.number_of_entries DO
        IF p_directory^.entries [directory_index].entry_available THEN
          available_directory_index := directory_index;
          EXIT /find_available_entry/;
        IFEND;
      FOREND /find_available_entry/;

      IF available_directory_index = 0 THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$directory_full, '', status);
        EXIT /create_entry/;
      IFEND;

      p_directory^.entries [available_directory_index].user_supplied_name := user_supplied_name;
      p_directory^.entries [available_directory_index].global_file_name := global_file_name;

      dmp$get_stored_fmd (system_file_id, p_directory^.entries [available_directory_index].stored_df_fmd,
            status);
      IF status.normal THEN
        p_directory^.entries [directory_index].entry_available := FALSE;
        mmp$write_modified_pages (p_directory, #SIZE (p_directory^), osc$wait, status);
      IFEND;

    END /create_entry/;

    dmp$close_file (p_directory, status);

  PROCEND create_directory_entry;
?? TITLE := '  create_volume_device_file', EJECT ??

  PROCEDURE create_volume_device_file (byte_address: amt$file_byte_address;
        p_file_attributes: ^array [1 .. * ] OF dmt$new_device_file_attribute;
        recorded_vsn: rmt$recorded_vsn;
    VAR system_file_id: gft$system_file_identifier;
    VAR global_file_name: dmt$global_file_name;
    VAR status: ost$status);

    CONST
      assign_volume = TRUE;

    VAR
      file_usage: pft$usage_selections,
      file_share_selections: pft$share_selections,
      file_share_history: dmt$file_share_history,
      limit: amt$file_limit,
      requested_volume: dmt$requested_volume,
      local_file_attributes: ^array [1 .. * ] of dmt$new_file_attribute,
      attribute_index: integer;

    file_usage := $pft$usage_selections [pfc$read];
    file_share_selections := $pft$share_selections [];
    file_share_history := dmc$minimum_file_share_his;
    limit := byte_address;
    requested_volume.recorded_vsn := recorded_vsn;
    requested_volume.setname := ' ';

    PUSH local_file_attributes: [1 .. UPPERBOUND (p_file_attributes^) + 2];

    attribute_index := 0;

    IF p_file_attributes <> NIL THEN
      FOR attribute_index := 1 TO UPPERBOUND (p_file_attributes^) DO
        local_file_attributes^ [attribute_index].keyword := p_file_attributes^ [attribute_index].keyword;
        CASE p_file_attributes^ [attribute_index].keyword OF
        = dmc$clear_space =
          local_file_attributes^ [attribute_index].required := p_file_attributes^ [attribute_index].required;
        = dmc$file_limit =
          local_file_attributes^ [attribute_index].limit := p_file_attributes^ [attribute_index].limit;
          limit := p_file_attributes^ [attribute_index].limit;
        = dmc$preset_value =
          local_file_attributes^ [attribute_index].preset_value := p_file_attributes^ [attribute_index].
                preset_value;
        = dmc$requested_allocation_size =
          local_file_attributes^ [attribute_index].requested_allocation_size := p_file_attributes^
                [attribute_index].requested_allocation_size;
        = dmc$requested_transfer_size =
          local_file_attributes^ [attribute_index].requested_transfer_size := p_file_attributes^
                [attribute_index].requested_transfer_size;
        CASEND;
      FOREND;
    IFEND;

    local_file_attributes^ [attribute_index + 1].keyword := dmc$requested_volume;
    local_file_attributes^ [attribute_index + 1].requested_volume := requested_volume;
    local_file_attributes^ [attribute_index + 2].keyword := dmc$file_limit;
    local_file_attributes^ [attribute_index + 2].limit := limit;

    dmp$create_file_entry (gfc$fk_device_file, file_usage, file_share_selections, file_share_history,
          local_file_attributes, byte_address, assign_volume, global_file_name, system_file_id, status);

  PROCEND create_volume_device_file;
MODEND dmm$create_new_file;
*DECK DECK=DMM$CREATE_TAPE_FILE EXPAND=TRUE
?? RIGHT := 110 ??
MODULE dmm$create_tape_file;
?? NEWTITLE := 'Global variables declared by this module', EJECT ??

  CONST
    default_terminate_reason = 'the requested tape volume is not available',
    one_second = 1000 {milliseconds} ,
    four_seconds = 4 * one_second;

  VAR
    dmv$tape_job_lun_table_p: [XDCL, oss$job_pageable] ^dmt$tape_job_lun_table := NIL;

?? OLDTITLE ??
?? NEWTITLE := 'Global Variables Referenced by This Module', EJECT ??
*copyc dmv$initialize_tape_volume
*copyc fmv$default_detachment_options
*copyc rmv$job_tape_table_lock
*copyc rmv$job_tape_table_p
*copyc rmv$requested_volume_attributes
*copyc iov$number_of_tape_units
*copyc iov$tusl_p
*copyc oss$job_pageable
*copyc oss$job_paged_literal
*copyc osv$job_pageable_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
{
{ Type definitions.
{
*copyc amt$label_type
*copyc avc$system_defined_limit_names
*copyc cld$value
*copyc clt$when_conditions
*copyc cyd$run_time_error_condition
*copyc ame$tape_program_actions
*copyc dme$tape_errors
*copyc dmt$file_type
*copyc dmt$job_tape_table
*copyc dmt$message_element
*copyc dmt$tape_job_lun_table
*copyc fmt$detachment_options
*copyc fmt$removable_media_req_info
*copyc gft$system_file_identifier
*copyc ife$error_codes
*copyc ioe$tape_io_conditions
*copyc iot$io_id
*copyc iot$tape_io_status
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc ofe$error_codes
*copyc osk$common_keypoint_definitions
*copyc osk$keypoint_class_codes
*copyc ost$name
*copyc ost$wait
*copyc pfd$permanent_file_attributes
*copyc pmd$system_log_interface
*copyc pmt$established_handler
*copyc rmc$robotic_write_disabled
*copyc rmd$tape_declarations
*copyc rme$condition_codes
?? POP ??
*copyc avp$security_option_active
*copyc clp$trimmed_string_size
*copyc cmp$get_element_name_via_lun
*copyc rmp$set_explicit_reserve
*copyc dmp$validate_tape_density
*copyc ifp$invoke_pause_utility
*copyc iop$access_tusl_entry
*copyc iop$delete_rvl_entry
*copyc iop$initialize_tape_ud
*copyc iop$rewind_tape
*copyc iop$tape_initialize_unit
*copyc iop$tape_request_status
*copyc iop$unload_tape
*copyc jmp$system_job
*copyc ofp$clear_operator_message
*copyc ofp$format_operator_menu
*copyc osp$append_status_parameter
*copyc osp$begin_subsystem_activity
*copyc osp$clear_job_signature_lock
*copyc osp$clear_wait_message
*copyc osp$copy_local_status_to_status
*copyc osp$disestablish_cond_handler
*copyc osp$end_subsystem_activity
*copyc osp$establish_condition_handler
*copyc osp$generate_log_message
*copyc osp$get_current_display_message
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$set_job_signature_lock
*copyc osp$test_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$translate_bytes
*copyc pmp$continue_to_cause
*copyc pmp$get_executing_task_gtid
*copyc pmp$long_term_wait
*copyc pmp$wait
*copyc rmp$activate_volume
*copyc rmp$clear_implicit_reserve
*copyc rmp$deactivate_volume
*copyc rmp$emit_operator_message
*copyc rmp$extend_volume_list
*copyc rmp$log_debug_message
*copyc rmp$log_debug_status
*copyc rmp$set_implicit_reserve
*copyc rmv$densities
*copyc rmv$write_ring
*copyc sfp$emit_audit_statistic
?? OLDTITLE ??
?? NEWTITLE := 'dmp$advance_tape_volume', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$advance_tape_volume
    (    sfid: gft$system_file_identifier;
         extend: boolean;
         label_type: amt$label_type;
         access_mode: pft$usage_selections;
     VAR status: ost$status);

*copy rmi$block_exit_handler
?? EJECT ??

    VAR
      ignore_status: ost$status,
      ioid: iot$io_id,
      iostatus: iot$tape_io_status,
      last_choice_element: cmt$element_name,
      local_status: ost$status,
      lun_table_entry: ^dmt$tape_lun_table_entry;

    rmp$log_debug_message (' Entering dmp$advance_tape_volume');
    status.normal := TRUE;

    osp$establish_condition_handler (^rmp$block_exit_handler, {handle block exit} TRUE);
    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (rmv$job_tape_table_lock);

    lun_table_entry := ^dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index];

{ Verify that volume list extension is allowed
{ (extend is true only when writing and the volume list is exhausted).

    IF (extend AND lun_table_entry^.volume_overflow_allowed) OR
          ((NOT extend) AND (lun_table_entry^.current_vsn_index < lun_table_entry^.number_of_vsns)) THEN
      IF (lun_table_entry^.current_vsn_index = lun_table_entry^.number_of_vsns) THEN
        rmp$log_debug_message (' Extending volume list');
        rmp$extend_volume_list (lun_table_entry, status);
      IFEND;
      IF status.normal THEN
        lun_table_entry^.current_vsn_index := lun_table_entry^.current_vsn_index + 1;
      IFEND;
    ELSE
      osp$set_status_condition (dme$volume_list_exhausted, status);
    IFEND;

    osp$clear_job_signature_lock (rmv$job_tape_table_lock);
    osp$end_subsystem_activity;
    osp$disestablish_cond_handler;

    IF status.normal THEN
{ Activate subsequent volume.
      last_choice_element := osc$null_name;
      REPEAT
        rmp$activate_volume (sfid, {acceptable_states} $cmt$element_states [cmc$on], last_choice_element,
              {Required_element} osc$null_name, status);
        IF status.normal THEN
          initialize_unit (sfid, label_type, access_mode, {recovery_remount} FALSE, last_choice_element,
                status);
        IFEND;
      UNTIL status.normal OR (status.condition <> dme$operator_reassign);
    IFEND;
    rmp$log_debug_message (' Exiting dmp$advance_tape_volume');

    IF NOT status.normal THEN
      rmp$clear_implicit_reserve (lun_table_entry^.density, ignore_status);
    IFEND;

  PROCEND dmp$advance_tape_volume;
?? OLDTITLE ??
?? NEWTITLE := 'dmp$assign_tape_volume', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$assign_tape_volume
    (    sfid: gft$system_file_identifier;
         path_handle_name: fst$path_handle_name;
         label_type: amt$label_type;
         access_mode: pft$usage_selections;
     VAR status: ost$status);

?? NEWTITLE := '  assign_tape_volume_handler', EJECT ??

    PROCEDURE assign_tape_volume_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status,
        local_status: ost$status,
        lock_status: ost$signature_lock_status;

      CASE condition.selector OF
      = pmc$block_exit_processing =
        osp$test_signature_lock (rmv$job_tape_table_lock, lock_status, local_status);
        IF local_status.normal THEN
          IF lock_status = osc$sls_locked_by_current_task THEN
            osp$clear_job_signature_lock (rmv$job_tape_table_lock);
            osp$end_subsystem_activity;
          IFEND;
          IF implicit_reserve_set THEN
            rmp$clear_implicit_reserve (density, ignore_status);
          IFEND;
        IFEND;
      = ifc$interactive_condition =
        CASE condition.interactive_condition OF
        = ifc$pause_break, ifc$job_reconnect =
          ifp$invoke_pause_utility (ignore_status);
        = ifc$terminate_break =
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
                ignore_status);
          EXIT dmp$assign_tape_volume;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;

    PROCEND assign_tape_volume_handler;

?? OLDTITLE ??
?? NEWTITLE := '  establish_reservation', EJECT ??

    PROCEDURE establish_reservation
      (    sfid: gft$system_file_identifier;
           density: rmt$density;
       VAR implicit_reserve_set: boolean;
       VAR status: ost$status);

      VAR
        counter: rmt$supported_tape_densities,
        reservation: rmt$tape_reservation;

      IF (rmv$job_tape_table_p = NIL) THEN
        rmp$set_implicit_reserve (sfid, density, status);
        implicit_reserve_set := status.normal;
      ELSE
        implicit_reserve_set := FALSE;
        osp$begin_subsystem_activity;
        osp$set_job_signature_lock (rmv$job_tape_table_lock);
        IF rmv$job_tape_table_p^.job_recovery_active THEN
          { must regain explicit reserve
          FOR counter := rmc$800 TO rmc$maximum_density DO
            reservation [counter] := rmv$job_tape_table_p^.reserved_unit_count [counter];
          FOREND;
          osp$clear_job_signature_lock (rmv$job_tape_table_lock);
          osp$end_subsystem_activity;
          rmp$set_explicit_reserve (reservation, status);
          osp$begin_subsystem_activity;
          osp$set_job_signature_lock (rmv$job_tape_table_lock);
          rmv$job_tape_table_p^.job_recovery_active := FALSE;
        IFEND;
        IF status.normal THEN
          IF NOT rmv$job_tape_table_p^.explicit_reservation THEN
            osp$set_status_condition (dme$request_exceeds_reserve, status);
          ELSE
            IF (rmv$job_tape_table_p^.reserved_unit_count [density] -
                  rmv$job_tape_table_p^.assigned_unit_count [density] <= 0) THEN
              FOR counter := rmc$800 TO rmc$maximum_density DO
                IF (rmv$job_tape_table_p^.reserved_unit_count [counter] > 0) AND
                      (rmv$job_tape_table_p^.reserved_unit_count [counter] -
                      rmv$job_tape_table_p^.assigned_unit_count [counter] > 0) THEN
                  osp$set_status_condition (dme$request_reserve_mismatch, status);
                IFEND;
              FOREND;
              IF status.normal THEN
                osp$set_status_condition (dme$request_exceeds_reserve, status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
        osp$clear_job_signature_lock (rmv$job_tape_table_lock);
        osp$end_subsystem_activity;
      IFEND;

    PROCEND establish_reservation;
?? OLDTITLE ??
?? EJECT ??

    VAR
      debug_message_logged: boolean,
      density: rmt$density,
      ignore_status: ost$status,
      implicit_reserve_set: boolean,
      last_choice_element: cmt$element_name,
      lun_table_entry: ^dmt$tape_lun_table_entry;

    rmp$log_debug_message (' Entering dmp$assign_tape_volume');
    status.normal := TRUE;
    implicit_reserve_set := FALSE;
    #SPOIL (implicit_reserve_set);

    osp$establish_condition_handler (^assign_tape_volume_handler, {handle block exit} TRUE);
    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (rmv$job_tape_table_lock);

    lun_table_entry := ^dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index];

    IF lun_table_entry^.lun = 0 THEN
      lun_table_entry^.label_type := label_type;
      CASE label_type OF
      = amc$labelled =
        rmp$log_debug_message (' Label Type is LABELED');
      = amc$unlabelled =
        rmp$log_debug_message (' Label Type is UNLABELED');
      = amc$non_standard_labelled =
        rmp$log_debug_message (' Label Type is NON_STANDARD_LABELED');
      ELSE
      CASEND;
      density := lun_table_entry^.density;
      #SPOIL (density);

      debug_message_logged := FALSE;
      REPEAT
        IF NOT debug_message_logged THEN
          rmp$log_debug_message (' Calling dmp$validate_tape_density');
        IFEND;
        dmp$validate_tape_density (density, status);
        IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Waiting for tape table lock');
            debug_message_logged := TRUE;
          IFEND;
          osp$clear_job_signature_lock (rmv$job_tape_table_lock);
          osp$end_subsystem_activity;
          pmp$long_term_wait (one_second, one_second);
          osp$begin_subsystem_activity;
          osp$set_job_signature_lock (rmv$job_tape_table_lock);
        IFEND;
      UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
    ELSE
      osp$set_status_condition (dme$active_tape_volume, status);
    IFEND;
    osp$clear_job_signature_lock (rmv$job_tape_table_lock);
    osp$end_subsystem_activity;

    IF status.normal AND (NOT dmv$initialize_tape_volume.in_progress) THEN
      establish_reservation (sfid, density, implicit_reserve_set, status);
      #SPOIL (implicit_reserve_set);
    IFEND;
    IF status.normal THEN
{ Select initial volume for processing.

      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (rmv$job_tape_table_lock);

      lun_table_entry^.current_vsn_index := 1;

      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;

      last_choice_element := osc$null_name;
      REPEAT
        rmp$activate_volume (sfid, {acceptable_states} $cmt$element_states [cmc$on], last_choice_element,
              {Required_element} osc$null_name, status);
        IF status.normal THEN
          initialize_unit (sfid, label_type, access_mode, {recovery_remount} FALSE, last_choice_element,
                status);
        IFEND;
      UNTIL status.normal OR (status.condition <> dme$operator_reassign);
    IFEND;

    IF (NOT status.normal) AND implicit_reserve_set THEN
      rmp$clear_implicit_reserve (density, ignore_status);
    IFEND;

    osp$disestablish_cond_handler;
    rmp$log_debug_message (' Exiting dmp$assign_tape_volume');

  PROCEND dmp$assign_tape_volume;
?? OLDTITLE ??
?? NEWTITLE := 'dmp$close_current_tape_volume', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$close_current_tape_volume
    (    sfid: gft$system_file_identifier;
         detachment_options: fmt$detachment_options;
     VAR status: ost$status);

*copy rmi$block_exit_handler
?? EJECT ??

    VAR
      ignore_iostatus: iot$tape_io_status,
      ioid: iot$io_id,
      local_status: ost$status,
      lun_active: boolean;

    rmp$log_debug_message (' Entering dmp$close_current_tape_volume');
    status.normal := TRUE;

    osp$establish_condition_handler (^rmp$block_exit_handler, {handle block exit} TRUE);
    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (rmv$job_tape_table_lock);

    IF (dmv$tape_job_lun_table_p = NIL) OR (NOT dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].
          slot_in_use) THEN
      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;
      osp$disestablish_cond_handler;
    ELSE
      lun_active := dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].lun <> 0;
      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;
      osp$disestablish_cond_handler;
      IF lun_active THEN
        iop$unload_tape (sfid, detachment_options, ioid, status);
        IF status.normal THEN
          get_tape_status (sfid, ioid, ignore_iostatus, status);
        IFEND;

        rmp$deactivate_volume (sfid, {delete_request_from_vsn_queue} TRUE, local_status);
        osp$copy_local_status_to_status (local_status, status);
      IFEND;
    IFEND;
    rmp$log_debug_message (' Exiting dmp$close_current_tape_volume');

  PROCEND dmp$close_current_tape_volume;
?? OLDTITLE ??
?? NEWTITLE := 'dmp$close_tape_volume', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$close_tape_volume
    (    sfid: gft$system_file_identifier;
         detachment_options: fmt$detachment_options;
     VAR status: ost$status);

*copy rmi$block_exit_handler

?? OLDTITLE ??
?? NEWTITLE := '  close_tape_volume_handler  ', EJECT ??

    PROCEDURE close_tape_volume_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status,
        local_status: ost$status,
        lock_status: ost$signature_lock_status;

      CASE condition.selector OF
      = pmc$block_exit_processing =
        osp$test_signature_lock (rmv$job_tape_table_lock, lock_status,
              local_status);
        IF local_status.normal AND (lock_status = osc$sls_locked_by_current_task)
              THEN
          osp$clear_job_signature_lock (rmv$job_tape_table_lock);
          osp$end_subsystem_activity;
        IFEND;
      = ifc$interactive_condition =
        CASE condition.interactive_condition OF
        = ifc$pause_break, ifc$job_reconnect =
          ifp$invoke_pause_utility (ignore_status);
        = ifc$terminate_break =
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
                ignore_status);
          EXIT dmp$close_tape_volume;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;

    PROCEND close_tape_volume_handler;

    VAR
      clear_implicit_reserve: boolean,
      debug_message_logged: boolean,
      density: rmt$density,
      ioid: iot$io_id,
      ignore_iostatus: iot$tape_io_status,
      job_recovery_active: boolean,
      local_status: ost$status,
      lun_active: boolean,
      lun_table_entry: ^dmt$tape_lun_table_entry,
      reservation: rmt$tape_reservation;

    local_status.normal := TRUE;
    status.normal := TRUE;

    rmp$log_debug_message (' Entering dmp$close_tape_volume');
    osp$establish_condition_handler (^close_tape_volume_handler, {handle block exit} TRUE);
    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (rmv$job_tape_table_lock);

    IF (dmv$tape_job_lun_table_p = NIL) OR (NOT dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].
          slot_in_use) THEN
      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;
      osp$disestablish_cond_handler;
    ELSE
      density := dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].density;
      clear_implicit_reserve := (NOT dmv$initialize_tape_volume.in_progress) AND
            (rmv$job_tape_table_p <> NIL) AND (NOT rmv$job_tape_table_p^.explicit_reservation) AND
            (rmv$job_tape_table_p^.reserved_unit_count [density] > 0);
      job_recovery_active := dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].job_recovery_active;
      lun_active := dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].lun <> 0;
      lun_table_entry := ^dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index];

      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;

      IF lun_active THEN
        rmp$log_debug_message (' Calling iop$unload_tape');
        iop$unload_tape (sfid, detachment_options, ioid, status);
        IF status.normal THEN
          get_tape_status (sfid, ioid, ignore_iostatus, status);
          rmp$log_debug_message (' Exiting get_tape_status for iop$unload_tape');
        IFEND;
        IF dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].
              robotic_mount_info.volume_robotically_mounted THEN
          IF detachment_options.device_class = rmc$magnetic_tape_device THEN
            dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].
                  robotic_mount_info.volume_robotically_mounted := detachment_options.physical_unload;
          IFEND;
        IFEND;
        rmp$log_debug_message (' Calling rmp$deactivate_volume');
        rmp$deactivate_volume (sfid, {delete_request_from_vsn_queue} TRUE, local_status);
        osp$copy_local_status_to_status (local_status, status);
      ELSEIF job_recovery_active THEN
        osp$begin_subsystem_activity;
        osp$set_job_signature_lock (rmv$job_tape_table_lock);
        rmv$job_tape_table_p^.assigned_unit_count [density] :=
              rmv$job_tape_table_p^.assigned_unit_count [density] - 1;
        osp$clear_job_signature_lock (rmv$job_tape_table_lock);
        osp$end_subsystem_activity;
      IFEND;

{ Release unit reserve

      IF clear_implicit_reserve THEN
        rmp$clear_implicit_reserve (density, local_status);
        osp$copy_local_status_to_status (local_status, status);
      IFEND;

{ Free dmv$tape_job_lun_table if this is the only tape file assigned.
{ If there are more tapes assigned to the job, decrement the count of tapes
{ assigned.

      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (rmv$job_tape_table_lock);

      dmv$tape_job_lun_table_p^.count := dmv$tape_job_lun_table_p^.count - 1;
      lun_table_entry^.lun := 0;
      lun_table_entry^.slot_in_use := FALSE;
      FREE lun_table_entry^.volume_list IN osv$job_pageable_heap^;
      IF dmv$tape_job_lun_table_p^.count = 0 THEN
        FREE dmv$tape_job_lun_table_p^.tape_file IN osv$job_pageable_heap^;
        FREE dmv$tape_job_lun_table_p IN osv$job_pageable_heap^;
      IFEND;

      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;
      osp$disestablish_cond_handler;
    IFEND;
{ Remove any traces of the rvl entry.

    debug_message_logged := FALSE;
    REPEAT
      IF NOT debug_message_logged THEN
        rmp$log_debug_message (' Calling iop$delete_rvl_entry');
      IFEND;
      iop$delete_rvl_entry (sfid, local_status);
      IF NOT local_status.normal AND (local_status.condition = dme$unable_to_lock_tape_table) THEN
        IF NOT debug_message_logged THEN
          rmp$log_debug_message (' Waiting for tape table lock');
          debug_message_logged := TRUE;
        IFEND;
        pmp$long_term_wait (one_second, one_second);
      IFEND;
    UNTIL local_status.normal OR (local_status.condition <> dme$unable_to_lock_tape_table);
    rmp$log_debug_message (' Exiting dmp$close_tape_volume');
    rmp$log_debug_status (local_status);

  PROCEND dmp$close_tape_volume;
?? OLDTITLE ??
?? NEWTITLE := 'dmp$create_tape_file_sfid', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$create_tape_file_sfid
    (    p_removable_media_req_info: {input} ^fmt$removable_media_req_info;
         p_volume_list: {input} ^rmt$volume_list;
     VAR sfid: gft$system_file_identifier;
     VAR status: ost$status);

*copy rmi$block_exit_handler
?? EJECT ??

    VAR
      found: boolean,
      lun_table_index: integer;

    rmp$log_debug_message (' Entering dmp$create_tape_file_sfid');
    status.normal := TRUE;

    osp$establish_condition_handler (^rmp$block_exit_handler, {handle block exit} TRUE);
    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (rmv$job_tape_table_lock);

    IF dmv$tape_job_lun_table_p = NIL THEN
      ALLOCATE dmv$tape_job_lun_table_p IN osv$job_pageable_heap^;
      ALLOCATE dmv$tape_job_lun_table_p^.tape_file: [1 .. (iov$number_of_tape_units +
            dmc$extra_lun_table_entries)] IN osv$job_pageable_heap^;
      FOR lun_table_index := 1 TO UPPERBOUND (dmv$tape_job_lun_table_p^.tape_file^) DO
        dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].slot_in_use := FALSE;
      FOREND;
      dmv$tape_job_lun_table_p^.count := 0;
    IFEND;

    found := FALSE;

  /search_for_empty_slot/
    FOR lun_table_index := 1 TO UPPERBOUND (dmv$tape_job_lun_table_p^.tape_file^) DO
      IF NOT dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].slot_in_use THEN
        found := TRUE;
        EXIT /search_for_empty_slot/;
      IFEND;
    FOREND /search_for_empty_slot/;

    IF NOT found THEN
      osp$set_status_condition (dme$tape_attach_limit_exceeded, status);
    IFEND;

    IF status.normal THEN
      dmv$tape_job_lun_table_p^.count := dmv$tape_job_lun_table_p^.count + 1;
      dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].slot_in_use := TRUE;
      dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].lun := 0;
      dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].label_type := amc$labeled;
      dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].density := p_removable_media_req_info^.density;
      dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].requested_volume_attributes :=
            rmv$requested_volume_attributes;
      dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].requested_volume_attributes.
            removable_media_group := p_removable_media_req_info^.removable_media_group;
      dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].source_pool := osc$null_name;
      dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].source_pool_location := osc$null_name;
      dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].robotic_mount_info.volume_robotically_mounted :=
            FALSE;
      dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].volume_overflow_allowed :=
            p_removable_media_req_info^.volume_overflow_allowed;
      dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].write_ring :=
            p_removable_media_req_info^.write_ring;
      dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].current_vsn_index := 1;
      dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].number_of_vsns := UPPERBOUND (p_volume_list^);
      ALLOCATE dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].volume_list:
            [1 .. UPPERBOUND (p_volume_list^)] IN osv$job_pageable_heap^;
      dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].volume_list^ := p_volume_list^;
      dmv$tape_job_lun_table_p^.tape_file^ [lun_table_index].job_recovery_active := FALSE;
      sfid.file_entry_index := lun_table_index;
      sfid.residence := gfc$tr_job;
      sfid.file_hash := 0;
    IFEND;

    osp$clear_job_signature_lock (rmv$job_tape_table_lock);
    osp$end_subsystem_activity;
    osp$disestablish_cond_handler;
    rmp$log_debug_message (' Exiting dmp$create_tape_file_sfid');

  PROCEND dmp$create_tape_file_sfid;
?? OLDTITLE ??
?? NEWTITLE := 'dmp$reset_tape_volume', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$reset_tape_volume
    (    sfid: gft$system_file_identifier;
         label_type: amt$label_type;
         access_mode: pft$usage_selections;
     VAR status: ost$status);

*copy rmi$block_exit_handler
?? EJECT ??

    VAR
      ioid: iot$io_id,
      iostatus: iot$tape_io_status,
      last_choice_element: cmt$element_name,
      local_status: ost$status,
      lun_table_entry: ^dmt$tape_lun_table_entry;

  /main_program/
    BEGIN

      rmp$log_debug_message (' Entering dmp$reset_tape_volume');
      status.normal := TRUE;

      osp$establish_condition_handler (^rmp$block_exit_handler, {handle block exit} TRUE);
      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (rmv$job_tape_table_lock);

      lun_table_entry := ^dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index];

{
{        select initial volume for activation
{
      lun_table_entry^.current_vsn_index := 1;

      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;
      last_choice_element := osc$null_name;
      REPEAT
        rmp$activate_volume (sfid, {acceptable_states} $cmt$element_states [cmc$on], last_choice_element,
              {Required_element} osc$null_name, status);
        IF status.normal THEN
          initialize_unit (sfid, label_type, access_mode, {recovery_remount} FALSE, last_choice_element,
                status);
        IFEND;
      UNTIL status.normal OR (status.condition <> dme$operator_reassign);

    END /main_program/;
    osp$disestablish_cond_handler;
    rmp$log_debug_message (' Exiting dmp$reset_tape_volume');

  PROCEND dmp$reset_tape_volume;
?? OLDTITLE ??
?? NEWTITLE := 'dmp$unload_remount_tape_volume', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$unload_remount_tape_volume
    (    sfid: gft$system_file_identifier;
         access_mode: pft$usage_selections;
         recovery_remount: boolean;
     VAR status: ost$status);

*copy rmi$block_exit_handler
?? EJECT ??

    VAR
      density: rmt$supported_tape_densities,
      detachment_options: fmt$detachment_options,
      ioid: iot$io_id,
      ignore_iostatus: iot$tape_io_status,
      job_recovery_active: boolean,
      label_type: amt$label_type,
      last_choice_element: cmt$element_name,
      local_status: ost$status,
      lun_active: boolean,
      lun_table_entry: ^dmt$tape_lun_table_entry,
      reservation: rmt$tape_reservation;

    rmp$log_debug_message (' Entering dmp$unload_remount_tape_volume');
    status.normal := TRUE;

    osp$establish_condition_handler (^rmp$block_exit_handler, {handle block exit} TRUE);
    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (rmv$job_tape_table_lock);

    lun_active := dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].lun <> 0;
    lun_table_entry := ^dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index];
    label_type := lun_table_entry^.label_type;

    job_recovery_active := rmv$job_tape_table_p^.job_recovery_active;
    IF job_recovery_active THEN
      { Must reclaim explicit reserves
      FOR density := rmc$800 TO rmc$maximum_density DO
        reservation [density] := rmv$job_tape_table_p^.reserved_unit_count [density];
      FOREND;
    IFEND;
    osp$clear_job_signature_lock (rmv$job_tape_table_lock);
    osp$end_subsystem_activity;

{ Deactivate currently active volume.

    IF lun_active THEN
      detachment_options := fmv$default_detachment_options;
      detachment_options.device_class := rmc$magnetic_tape_device;
      detachment_options.physical_unload := TRUE;

      iop$unload_tape (sfid, detachment_options, ioid, status);
      IF status.normal THEN
        get_tape_status (sfid, ioid, ignore_iostatus, status);
      IFEND;

      rmp$deactivate_volume (sfid, {delete_request_from_vsn_queue} FALSE, local_status);
      osp$copy_local_status_to_status (local_status, status);
    ELSEIF job_recovery_active THEN
      rmp$set_explicit_reserve (reservation, status);

      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (rmv$job_tape_table_lock);

      rmv$job_tape_table_p^.job_recovery_active := FALSE;

      IF status.normal THEN
        density := lun_table_entry^.density;
        rmv$job_tape_table_p^.assigned_unit_count [density] :=
              rmv$job_tape_table_p^.assigned_unit_count [density] - 1;
        lun_table_entry^.job_recovery_active := FALSE;
      IFEND;

      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;
    IFEND;

    IF status.normal THEN
      last_choice_element := osc$null_name;
      REPEAT
        rmp$activate_volume (sfid, {acceptable_states} $cmt$element_states [cmc$on], last_choice_element,
              {Required_element} osc$null_name, status);
        IF status.normal THEN
          initialize_unit (sfid, label_type, access_mode, recovery_remount, last_choice_element, status);
        IFEND;
      UNTIL status.normal OR (status.condition <> dme$operator_reassign);
    IFEND;

    osp$disestablish_cond_handler;
    rmp$log_debug_message (' Exiting dmp$unload_remount_tape_volume');

  PROCEND dmp$unload_remount_tape_volume;
?? OLDTITLE ??
?? NEWTITLE := 'get_tape_status', EJECT ??

  PROCEDURE get_tape_status
    (    sfid: gft$system_file_identifier;
         ioid: iot$io_id;
     VAR iostatus: iot$tape_io_status;
     VAR status: ost$status);

    status.normal := TRUE;
    iostatus.io_complete := FALSE;

    iop$tape_request_status (sfid, ioid, {wait=} TRUE, iostatus, status);

  PROCEND get_tape_status;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_unit', EJECT ??

  PROCEDURE initialize_unit
    (    sfid: gft$system_file_identifier;
         label_type: amt$label_type;
         access_mode: pft$usage_selections;
         recovery_remount: boolean;
     VAR last_choice_element: cmt$element_name;
     VAR status: ost$status);

    VAR
      message_parameters: array [1 .. 4] of ^ost$message_parameter,
      original_message: oft$display_message;

?? NEWTITLE := '  abnormal_cleanup', EJECT ??

    PROCEDURE abnormal_cleanup
      (    retain_volume_and_reservation: boolean);

      VAR
        delete_request_from_vsn_queue: boolean,
        detachment_options: fmt$detachment_options,
        ignore_status: ost$status,
        ignore_iostatus: iot$tape_io_status,
        ioid: iot$io_id,
        local_status: ost$status,
        wait_message_displayed: boolean;

      rmp$log_debug_message (' Calling iop$unload_tape from initialize_unit');

      detachment_options := fmv$default_detachment_options;
      detachment_options.device_class := rmc$magnetic_tape_device;
      detachment_options.physical_unload := TRUE;

      iop$unload_tape (sfid, detachment_options, ioid, local_status);
      IF local_status.normal THEN
        get_tape_status (sfid, ioid, ignore_iostatus, ignore_status);
        rmp$log_debug_status (ignore_status);
      IFEND;

      delete_request_from_vsn_queue := NOT retain_volume_and_reservation;
      rmp$log_debug_message (' Calling rmp$deactivate_volume from initialize_unit');
      rmp$deactivate_volume (sfid, delete_request_from_vsn_queue, ignore_status);

      IF (NOT retain_volume_and_reservation) AND (NOT dmv$initialize_tape_volume.in_progress) AND
            (NOT rmv$job_tape_table_p^.explicit_reservation) THEN
        rmp$log_debug_message (' Calling rmp$clear_implicit_reserve from initialize_unit');
        rmp$clear_implicit_reserve (dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].density,
              ignore_status);
      IFEND;

      ofp$clear_operator_message (ofc$removable_media_operator, ignore_status);
      wait_message_displayed := TRUE;
      osp$clear_wait_message (original_message, wait_message_displayed);
    PROCEND abnormal_cleanup;

?? OLDTITLE ??
?? NEWTITLE := '  check_for_operator_reassign', EJECT ??

    PROCEDURE check_for_operator_reassign
      (    tusl_ordinal: iot$tusl_ordinal;
           log_debug_message: boolean;
       VAR status: ost$status);

      VAR
        tusl_entry_access: iot$tusl_entry_access;

      REPEAT
        IF log_debug_message THEN
          rmp$log_debug_message (' Calling iop$access_tusl_entry');
        IFEND;
        tusl_entry_access.operation := ioc$fetch_operator_reassign;
        iop$access_tusl_entry (tusl_ordinal, tusl_entry_access, status);
        IF NOT status.normal THEN
          IF status.condition = dme$unable_to_lock_tape_table THEN
            IF log_debug_message THEN
              rmp$log_debug_message (' Waiting for tape table lock');
            IFEND;
            osp$establish_condition_handler (^initialize_unit_lock_handler, {handle block exit} FALSE);
            pmp$long_term_wait (one_second, one_second);
            osp$disestablish_cond_handler;
          ELSE
            RETURN;
          IFEND;
        IFEND;
      UNTIL status.normal;

      IF tusl_entry_access.fetch_operator_reassign THEN
        osp$set_status_condition (dme$operator_reassign, status);
      IFEND;

    PROCEND check_for_operator_reassign;

?? OLDTITLE ??
?? NEWTITLE := '  disable_operator_reassign', EJECT ??

    PROCEDURE disable_operator_reassign
      (    tusl_ordinal: iot$tusl_ordinal);

      VAR
        local_status: ost$status,
        tusl_entry_access: iot$tusl_entry_access;

      ofp$clear_operator_message (ofc$removable_media_operator, ignore_status);

      debug_message_logged := FALSE;
      REPEAT
        IF NOT debug_message_logged THEN
          rmp$log_debug_message (' Calling iop$access_tusl_entry');
        IFEND;
        tusl_entry_access.operation := ioc$disable_operator_reassign;
        iop$access_tusl_entry (tusl_ordinal, tusl_entry_access, local_status);
        IF NOT local_status.normal THEN
          IF local_status.condition = dme$unable_to_lock_tape_table THEN
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Waiting for tape table lock');
              debug_message_logged := TRUE;
            IFEND;
            osp$establish_condition_handler (^initialize_unit_lock_handler, {handle block exit} FALSE);
            pmp$long_term_wait (one_second, one_second);
            osp$disestablish_cond_handler;
          ELSE
            RETURN;
          IFEND;
        IFEND;
      UNTIL local_status.normal;

    PROCEND disable_operator_reassign;

?? OLDTITLE ??
?? NEWTITLE := '  dismount_volume', EJECT ??

    PROCEDURE dismount_volume
      (    initialization_record: dmt$tape_initialization_record;
           sfid: gft$system_file_identifier;
       VAR status: ost$status);

      VAR
        detachment_options: fmt$detachment_options,
        ioid: iot$io_id;

      detachment_options := fmv$default_detachment_options;
      detachment_options.device_class := rmc$magnetic_tape_device;
      detachment_options.physical_unload := TRUE;

      iop$unload_tape (sfid, detachment_options, ioid, status);
      IF status.normal THEN
        get_tape_status (sfid, ioid, iostatus, status);
        IF status.normal THEN
          iop$initialize_tape_ud (initialization_record, {multiple_requests_possible} TRUE, status);
        IFEND;
      IFEND;
    PROCEND dismount_volume;
?? OLDTITLE ??
?? NEWTITLE := '  emit_job_log_message', EJECT ??

    PROCEDURE emit_job_log_message
      (    sfid: gft$system_file_identifier;
           element_name: cmt$element_name;
           recovery_remount: boolean;
           requested_ring: rmt$write_ring);

      VAR
        ignore_status: ost$status,
        logset: pmt$ascii_logset,
        log_message_status: ost$status;

      IF NOT recovery_remount THEN
        osp$set_status_condition (dme$volume, log_message_status);
      ELSE
        osp$set_status_condition (dme$recovery_remount, log_message_status);
      IFEND;
      osp$append_status_parameter (osc$status_parameter_delimiter, dmv$tape_job_lun_table_p^.
            tape_file^ [sfid.file_entry_index].volume_list^ [dmv$tape_job_lun_table_p^.
            tape_file^ [sfid.file_entry_index].current_vsn_index].external_vsn, log_message_status);
      osp$append_status_parameter (osc$status_parameter_delimiter, element_name, log_message_status);
      IF (requested_ring = rmc$write_ring) THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'write', log_message_status);
      ELSE
        osp$append_status_parameter (osc$status_parameter_delimiter, 'read', log_message_status);
      IFEND;

      logset := $pmt$ascii_logset [pmc$job_log];
      osp$generate_log_message (logset, log_message_status, ignore_status);
    PROCEND emit_job_log_message;
?? OLDTITLE ??
?? NEWTITLE := '  emit_security_statistic', EJECT ??

    PROCEDURE emit_security_statistic
      (    element_name: cmt$element_name);

      VAR
        audit_information: sft$audit_information;

      IF avp$security_option_active (avc$vso_security_audit) THEN
        audit_information.audited_operation := sfc$ao_fs_magnetic_tape_mount;
        audit_information.mount_magnetic_tape.external_vsn_p := ^dmv$tape_job_lun_table_p^.
              tape_file^ [sfid.file_entry_index].volume_list^ [dmv$tape_job_lun_table_p^.
              tape_file^ [sfid.file_entry_index].current_vsn_index].external_vsn;
        audit_information.mount_magnetic_tape.recorded_vsn_p := ^dmv$tape_job_lun_table_p^.
              tape_file^ [sfid.file_entry_index].volume_list^ [dmv$tape_job_lun_table_p^.
              tape_file^ [sfid.file_entry_index].current_vsn_index].recorded_vsn;
        audit_information.mount_magnetic_tape.write_ring := (requested_ring = rmc$write_ring);
        audit_information.mount_magnetic_tape.element_name_p := ^element_name;
        sfp$emit_audit_statistic (audit_information, status);
      IFEND;

    PROCEND emit_security_statistic;
?? OLDTITLE ??
?? NEWTITLE := '  enable_operator_reassign', EJECT ??

    PROCEDURE enable_operator_reassign
      (    tusl_ordinal: iot$tusl_ordinal);

      VAR
        local_status: ost$status,
        tusl_entry_access: iot$tusl_entry_access;

      debug_message_logged := FALSE;
      REPEAT
        IF NOT debug_message_logged THEN
          rmp$log_debug_message (' Calling iop$access_tusl_entry');
        IFEND;
        tusl_entry_access.operation := ioc$enable_operator_reassign;
        iop$access_tusl_entry (tusl_ordinal, tusl_entry_access, local_status);
        IF NOT local_status.normal THEN
          IF local_status.condition = dme$unable_to_lock_tape_table THEN
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Waiting for tape table lock');
              debug_message_logged := TRUE;
            IFEND;
            osp$establish_condition_handler (^initialize_unit_lock_handler, {handle block exit} FALSE);
            pmp$long_term_wait (one_second, one_second);
            osp$disestablish_cond_handler;
          ELSE
            RETURN;
          IFEND;
        IFEND;
      UNTIL local_status.normal;

    PROCEND enable_operator_reassign;

?? OLDTITLE ??
?? NEWTITLE := '  ensure_unit_operational', EJECT ??

    PROCEDURE ensure_unit_operational
      (    sfid: gft$system_file_identifier;
           message_parameters: array [1 .. * ] of ^ost$message_parameter;
           tusl_ordinal: iot$tusl_ordinal;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status,
        ioid: iot$io_id,
        iostatus: iot$tape_io_status,
        log_debug_message: boolean,
        message_name: clt$parameter_name;

      enable_operator_reassign (tusl_ordinal);

      message_name := 'UNIT_NOT_OPERATIONAL';
      rmp$emit_operator_message (message_name, ^message_parameters, {acknowledgement_allowed} FALSE,
            ignore_status);

      log_debug_message := TRUE;
    /not_ready/
      REPEAT
        iop$tape_initialize_unit (sfid, ioid, status);
        IF status.normal THEN
          get_tape_status (sfid, ioid, iostatus, status);
          IF status.normal THEN
            IF NOT iostatus.normal_completion THEN
              pmp$long_term_wait (four_seconds, four_seconds);
              check_for_operator_reassign (tusl_ordinal, log_debug_message, status);
              log_debug_message := FALSE;
            IFEND;
          IFEND;
        IFEND;
      UNTIL NOT status.normal OR (iostatus.normal_completion AND iostatus.unit_ready);

      disable_operator_reassign (tusl_ordinal);

    PROCEND ensure_unit_operational;
?? OLDTITLE ??
?? NEWTITLE := '  ensure_unit_ready', EJECT ??

    PROCEDURE ensure_unit_ready
      (    sfid: gft$system_file_identifier;
           message_parameters: array [1 .. * ] of ^ost$message_parameter;
           tusl_ordinal: iot$tusl_ordinal;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status,
        ioid: iot$io_id,
        iostatus: iot$tape_io_status,
        log_debug_message: boolean,
        message_name: clt$parameter_name;

      enable_operator_reassign (tusl_ordinal);

      message_name := 'UNIT_NOT_READY';
      rmp$emit_operator_message (message_name, ^message_parameters, {acknowledgement_allowed} FALSE,
            ignore_status);

      log_debug_message := TRUE;
    /not_ready/
      REPEAT
        iop$tape_initialize_unit (sfid, ioid, status);
        IF status.normal THEN
          get_tape_status (sfid, ioid, iostatus, status);
          IF status.normal THEN
            IF iostatus.normal_completion AND NOT iostatus.unit_ready THEN
              pmp$long_term_wait (one_second, one_second);
              check_for_operator_reassign (tusl_ordinal, log_debug_message, status);
              log_debug_message := FALSE;
            IFEND;
          IFEND;
        IFEND;
      UNTIL NOT status.normal OR (iostatus.normal_completion AND iostatus.unit_ready);

      disable_operator_reassign (tusl_ordinal);

    PROCEND ensure_unit_ready;
?? OLDTITLE ??
?? NEWTITLE := '  ensure_unit_write_enabled', EJECT ??

    PROCEDURE ensure_unit_write_enabled
      (    sfid: gft$system_file_identifier;
           message_parameters: array [1 .. * ] of ^ost$message_parameter;
           tusl_ordinal: iot$tusl_ordinal;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status,
        ioid: iot$io_id,
        iostatus: iot$tape_io_status,
        log_debug_message: boolean,
        message_name: clt$parameter_name;

      enable_operator_reassign (tusl_ordinal);

      message_name := 'UNIT_NOT_WRITE_ENABLED';
      rmp$emit_operator_message (message_name, ^message_parameters, {acknowledgement_allowed} FALSE,
            ignore_status);

      dismount_volume (initialization_record, sfid, status);
      IF status.normal THEN

        log_debug_message := TRUE;
      /mandate_ring/
        REPEAT
          iop$tape_initialize_unit (sfid, ioid, status);
          IF status.normal THEN
            get_tape_status (sfid, ioid, iostatus, status);
            IF status.normal AND iostatus.normal_completion THEN
              IF iostatus.unit_ready THEN
                IF iostatus.unit_busy THEN
                  pmp$long_term_wait (one_second, one_second);
                  check_for_operator_reassign (tusl_ordinal, log_debug_message, status);
                  log_debug_message := FALSE;
                ELSEIF NOT iostatus.write_ring THEN
                  dismount_volume (initialization_record, sfid, status);
                IFEND;
              ELSE {not ready}
                pmp$long_term_wait (one_second, one_second);
                check_for_operator_reassign (tusl_ordinal, log_debug_message, status);
                log_debug_message := FALSE;
              IFEND;
            ELSE {unit not operational}
              pmp$long_term_wait (four_seconds, four_seconds);
              check_for_operator_reassign (tusl_ordinal, log_debug_message, status);
              log_debug_message := FALSE;
            IFEND;
          IFEND;
        UNTIL NOT status.normal OR (iostatus.normal_completion AND (NOT iostatus.unit_busy) AND
              iostatus.unit_ready AND iostatus.write_ring);

      IFEND;
      disable_operator_reassign (tusl_ordinal);

    PROCEND ensure_unit_write_enabled;

?? OLDTITLE ??
?? NEWTITLE := '  initialize_unit_handler', EJECT ??

    PROCEDURE initialize_unit_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status,
        ioid: iot$io_id,
        local_status: ost$status;

      CASE condition.selector OF
      = pmc$block_exit_processing =
        abnormal_cleanup ({retain_volume_and_reservation} FALSE);
      = ifc$interactive_condition =
        CASE condition.interactive_condition OF
        = ifc$pause_break, ifc$job_reconnect =
          ifp$invoke_pause_utility (ignore_status);
        = ifc$terminate_break =
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
                ignore_status);
          EXIT initialize_unit;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$job_recovery_condition_name THEN
          dmp$unload_remount_tape_volume (sfid, access_mode, {recovery_remount} FALSE, ignore_status);
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          EXIT initialize_unit;
        IFEND;
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;

    PROCEND initialize_unit_handler;

?? OLDTITLE ??
?? NEWTITLE := '  initialize_unit_lock_handler  ', EJECT ??

    PROCEDURE initialize_unit_lock_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      CASE condition.selector OF
      = ifc$interactive_condition =
        CASE condition.interactive_condition OF
        = ifc$pause_break, ifc$job_reconnect =
          ifp$invoke_pause_utility (ignore_status);
        = ifc$terminate_break =
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
                ignore_status);
          EXIT initialize_unit;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;

    PROCEND initialize_unit_lock_handler;

?? OLDTITLE ??

*copy rmi$block_exit_handler
?? NEWTITLE := '  robotic_write_disabled_menu', EJECT ??

    PROCEDURE robotic_write_disabled_menu
      (    message_parameters: array [1 .. * ] of ^ost$message_parameter;
       VAR status: ost$status);

      CONST
        default_terminate_reason = 'the operator refused to write-enable a robotic volume',
        number_of_choices = 2;

      VAR
        parameter_names: ^ost$parameter_help_names,
        response_string: ost$string,
        response: oft$number_of_choices,
        string_size: ost$name_size,
        terminate_reason: string (osc$max_string_size);

      PUSH parameter_names: [1 .. number_of_choices];
      parameter_names^ [1] := 'ALLOW_WRITE_ACCESS';
      parameter_names^ [2] := 'TERMINATE_REQUEST';

      ofp$format_operator_menu (rmc$robotic_write_disabled, parameter_names, ^message_parameters,
            number_of_choices, ofc$removable_media_operator, response, response_string, status);
      IF status.normal THEN
        CASE response OF
        = 1 = { remount the volume and retry }
          osp$set_status_condition (dme$operator_reassign, status);
        = 2 = { terminate the assignment. }
          IF response_string.size > 0 THEN
            terminate_reason := response_string.value (1, response_string.size);
          ELSE
            terminate_reason := default_terminate_reason;
          IFEND;
          osp$set_status_abnormal (rmc$resource_management_id, dme$operator_stop, terminate_reason, status);
        ELSE
        CASEND;
      IFEND;

    PROCEND robotic_write_disabled_menu;
?? OLDTITLE ??
?? EJECT ??

    VAR
      debug_message_logged: boolean,
      element_name: cmt$element_name,
      ignore_status: ost$status,
      initialization_record: dmt$tape_initialization_record,
      ioid: iot$io_id,
      iostatus: iot$tape_io_status,
      local_status: ost$status,
      lun: iot$logical_unit,
      requested_evsn: rmt$external_vsn,
      requested_ring: rmt$write_ring,
      requested_rvsn: rmt$recorded_vsn,
      tusl_entry_access: iot$tusl_entry_access,
      tusl_ordinal: iot$tusl_ordinal,
      volume_robotically_mounted: boolean;

    rmp$log_debug_message (' Entering Initialize_unit');
    status.normal := TRUE;

    last_choice_element := osc$null_name;

    osp$get_current_display_message (original_message);

  /table_locked/
    BEGIN

      osp$establish_condition_handler (^rmp$block_exit_handler, {handle_block_exit} TRUE);
      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (rmv$job_tape_table_lock);

      IF dmv$tape_job_lun_table_p <> NIL THEN
        lun := dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].lun;

        cmp$get_element_name_via_lun (lun, element_name, status);
        IF status.normal THEN

{ Scan the tusl for the element being processed.

        /scan_tusl/
          BEGIN
            FOR tusl_ordinal := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
              IF (iov$tusl_p^ [tusl_ordinal].element_name = element_name) THEN
                EXIT /scan_tusl/;
              IFEND;
            FOREND;

            osp$set_status_abnormal (rmc$resource_management_id, rme$undefined_element_name, element_name,
                  status);
            EXIT /table_locked/;
          END /scan_tusl/;


          requested_evsn := dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].
                volume_list^ [dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].current_vsn_index].
                external_vsn;

          requested_ring := dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].write_ring;

          requested_rvsn := dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].
                volume_list^ [dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].current_vsn_index].
                recorded_vsn;

          volume_robotically_mounted := dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].
                robotic_mount_info.volume_robotically_mounted;

{ Create initialization record.

          initialization_record.logical_unit_number := lun;
          initialization_record.density := dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].
                density;

{ Initialize unit descriptor.

          iop$initialize_tape_ud (initialization_record, {multiple_requests_possible} TRUE, status);
        IFEND;
      IFEND;
    END /table_locked/;
    osp$clear_job_signature_lock (rmv$job_tape_table_lock);
    osp$end_subsystem_activity;
    osp$disestablish_cond_handler;

    IF status.normal THEN
      message_parameters [1] := ^element_name;
      message_parameters [2] := ^requested_evsn;
      message_parameters [3] := ^rmv$densities [initialization_record.density];
      message_parameters [4] := ^rmv$write_ring [requested_ring];
    ELSE
      RETURN;
    IFEND;

    osp$establish_condition_handler (^initialize_unit_handler, TRUE);

  /ensure_accessible_unit/
    REPEAT
      iop$tape_initialize_unit (sfid, ioid, status);
      IF status.normal THEN
        get_tape_status (sfid, ioid, iostatus, status);
        IF status.normal THEN
          IF iostatus.normal_completion THEN
            IF iostatus.unit_ready THEN
              IF iostatus.unit_busy THEN
                pmp$long_term_wait (one_second, one_second);
              ELSE
                IF (requested_ring = rmc$write_ring) AND NOT iostatus.write_ring THEN
                  IF volume_robotically_mounted THEN
                    rmp$log_debug_message (' Initialize unit found robotic unit not write enabled');
                    osp$set_status_condition (rme$robotic_write_disabled, status);
                  ELSE
                    ensure_unit_write_enabled (sfid, message_parameters, tusl_ordinal, status);
                  IFEND;
                IFEND;
                IF status.normal THEN

                /store_tape_characteristics/
                  BEGIN
                    debug_message_logged := FALSE;
                    REPEAT
                      IF NOT debug_message_logged THEN
                        rmp$log_debug_message (' Calling iop$access_tusl_entry');
                      IFEND;
                      tusl_entry_access.operation := ioc$store_tape_characteristics;
                      tusl_entry_access.store_write_ring := iostatus.write_ring;
                      tusl_entry_access.store_density :=
                            dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].density;
                      iop$access_tusl_entry (tusl_ordinal, tusl_entry_access, local_status);
                      IF NOT local_status.normal THEN
                        IF local_status.condition = dme$unable_to_lock_tape_table THEN
                          IF NOT debug_message_logged THEN
                            rmp$log_debug_message (' Waiting for tape table lock');
                            debug_message_logged := TRUE;
                          IFEND;
                          pmp$long_term_wait (one_second, one_second);
                        ELSE
                          EXIT /store_tape_characteristics/;
                        IFEND;
                      IFEND;
                    UNTIL local_status.normal;
                  END /store_tape_characteristics/;

                  emit_job_log_message (sfid, element_name, recovery_remount, requested_ring);
                  EXIT /ensure_accessible_unit/;
                IFEND;
              IFEND;
            ELSE {unit not ready}
              IF volume_robotically_mounted THEN
                rmp$log_debug_message (' Initialize unit found robotic unit not ready');
                osp$set_status_condition (dme$operator_reassign, status);
                last_choice_element := element_name;
              ELSE
                ensure_unit_ready (sfid, message_parameters, tusl_ordinal, status);
              IFEND;
            IFEND;
          ELSE {unit inoperable}
            IF volume_robotically_mounted THEN
              rmp$log_debug_message (' Initialize unit found robotic unit not operational');
              osp$set_status_condition (dme$operator_reassign, status);
              last_choice_element := element_name;
            ELSE
              ensure_unit_operational (sfid, message_parameters, tusl_ordinal, status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    UNTIL NOT status.normal;

    osp$disestablish_cond_handler;

    emit_security_statistic (element_name);

    IF (NOT status.normal) THEN
      CASE status.condition OF
      = ame$improper_file_label_type =
        IF dmv$initialize_tape_volume.in_progress THEN
          rmp$log_debug_message ('Ignoring ame$improper_file_label_type due to INITV');
          rmp$log_debug_status (status);
          status.normal := TRUE;
        ELSE
          abnormal_cleanup ({retain_volume_and_reservation} FALSE);
        IFEND;
      = dme$operator_reassign =
        abnormal_cleanup ({retain_volume_and_reservation} TRUE);
      = rme$robotic_write_disabled =
        abnormal_cleanup ({retain_volume_and_reservation} TRUE);
        {Allow operator the choice of ejecting cartridge & write-enabling it.}
        robotic_write_disabled_menu (message_parameters, status);
      ELSE
        abnormal_cleanup ({retain_volume_and_reservation} FALSE);
      CASEND;
    IFEND;
    rmp$log_debug_message (' Exiting Initialize_unit');
    rmp$log_debug_status (status);

  PROCEND initialize_unit;
?? OLDTITLE ??

MODEND dmm$create_tape_file;
*DECK DECK=DMM$DEBUG_COMMAND_PROCESSING EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$debug_command_processing;
?? PUSH (LISTEXT := ON) ??
?? TITLE := '  Common Decks', EJECT ??
*copyc dmt$debug_actions
*copyc dmv$debug_options
*copyc osp$clear_signature_lock
*copyc osp$set_signature_lock
*copyc osp$set_status_abnormal
*copyc oss$mainframe_pageable
*copyc oss$mainframe_paged_literal
*copyc ost$signature_lock
*copyc ost$status
*copyc ost$wait
*copyc sye$command_processor_errors
?? POP ??
?? TITLE := '  Global Variables', EJECT ??

    VAR
      dmv$store_debug_lock: [STATIC, oss$mainframe_pageable] ost$signature_lock := [0];

    VAR
      debug_command_options: [READ, oss$mainframe_paged_literal]
              array [1..3] OF record
                                command_name: string(31),
                                debug_ordinal: dmt$debug_codes,
                              recend :=
               [['DEBUG_DAT_CHANGES', dmc$debug_dat_changes],
                ['DEBUG_DFL_CHANGES', dmc$debug_dfl_changes],
                ['DEBUG_DEVICE_MANAGER', dmc$debug_device_manager]];
?? TITLE := '  dmp$fetch_debug_option', EJECT ??

PROCEDURE [XDCL] dmp$fetch_debug_option_value (name: string(*);
     VAR value: integer;
     VAR status: ost$status);

    VAR
      debug_set_member: dmt$debug_codes;

    status.normal := TRUE;

   process_command (name, debug_set_member, status);
   IF status.normal THEN
    IF debug_set_member IN dmv$debug_options THEN
       value := ORD(TRUE);
    ELSE
       value := ORD (FALSE);
    IFEND;
   IFEND;

PROCEND dmp$fetch_debug_option_value;
?? TITLE := '  dmp$store_debug_option_value', EJECT ??

PROCEDURE [XDCL] dmp$store_debug_option_value (name: string(*);
        value: integer;
    VAR status: ost$status);

   VAR
     debug_set_member: dmt$debug_codes,
     lock_status: ost$status;

    status.normal := TRUE;

    osp$set_signature_lock (dmv$store_debug_lock, osc$wait, lock_status);

    process_command (name, debug_set_member, status);
    IF status.normal THEN
      IF value = ORD(FALSE) THEN
         dmv$debug_options := dmv$debug_options -
              $dmt$debug_actions[debug_set_member];
      ELSE
         dmv$debug_options := dmv$debug_options +
              $dmt$debug_actions[debug_set_member];
       IFEND;
   IFEND;

    osp$clear_signature_lock (dmv$store_debug_lock, lock_status);

PROCEND dmp$store_debug_option_value;
?? TITLE := '  process_command', EJECT ??

PROCEDURE process_command (name: string(*);
        VAR debug_set_member: dmt$debug_codes;
        VAR status: ost$status);

    VAR
      valid_command_option: boolean,
      upper_case_name: string (31),
      error_string: string (55),
      string_index: integer,
      command_options_index: integer;

    status.normal := TRUE;

     valid_command_option := FALSE;
     upper_case_name := name;

    FOR string_index := 1 TO STRLENGTH (upper_case_name) DO
      IF (upper_case_name (string_index) >= 'a') AND (upper_case_name (string_index) <= 'z') THEN
        upper_case_name (string_index) := CHR (ORD (upper_case_name (string_index)) - ORD ('a') + ORD ('A'));
      IFEND;
    FOREND;

    /scan_command_table/
         FOR command_options_index := 1 TO UPPERBOUND(debug_command_options) DO
            valid_command_option := (upper_case_name = debug_command_options
                         [command_options_index].command_name);
            IF valid_command_option THEN
                EXIT /scan_command_table/;
            IFEND;
           FOREND /scan_command_table/;

         IF NOT valid_command_option THEN
            error_string := 'Unknown parameter name: ';
            error_string(25, *) := upper_case_name;
            osp$set_status_abnormal ('SY', sye$unknown_parameter_name, error_string, status);
            RETURN;
         IFEND;

         debug_set_member := debug_command_options[command_options_index].
                               debug_ordinal;

PROCEND process_command;

MODEND dmm$debug_command_processing;
*DECK DECK=DMM$DESTROY_PERMANENT_FILE EXPAND=TRUE
?? RIGHT := 110 ??
*copy osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$destroy_permanent_file;
?? PUSH (LISTEXT := ON) ??
?? TITLE := '  Common Decks', EJECT ??
*copyc amt$file_byte_address
*copyc dmp$clear_master_attach_lock
*copyc dmp$close_file
*copyc dmp$decrement_class_activity
*copyc dmp$generate_gfn_hash
*copyc dmp$get_active_vol_attributes
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$open_directory
*copyc dmp$process_device_log_entry
*copyc dmp$search_active_volume_table
*copyc dmp$search_avt_by_vsn
*copyc dmp$search_fdt_by_gfn
*copyc dmp$search_vol_directory_name
*copyc dmp$set_master_attach_lock
*copyc dmt$device_file_list_index
*copyc dmt$device_file_stored_fmd
*copyc dmt$disk_file_descriptor
*copyc dmt$error_condition_codes
*copyc dmt$global_file_name
*copyc dmt$keypoint_calls
*copyc dmt$stored_fmd
*copyc dmt$stored_ms_fmd_header
*copyc dmt$system_file_id
*copyc gfp$get_locked_fde_p
*copyc gfp$unlock_fde_p
*copyc gft$locked_file_desc_entry_p
*copyc mmp$write_modified_pages
*copyc osk$keypoints
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc rmd$volume_declarations
?? POP ??
?? TITLE := '  dmp$destroy_permanent_file', EJECT ??
*copyc dmh$destroy_permanent_file

  PROCEDURE [XDCL, #GATE] dmp$destroy_permanent_file (global_file_name: dmt$global_file_name;
        stored_fmd: dmt$stored_fmd;
    VAR status: ost$status);


    VAR
      p_stored_fmd_version: ^dmt$stored_ms_version_number,
      p_stored_fmd_header: ^dmt$stored_ms_fmd_header,
      p_stored_fmd_subfile: ^dmt$stored_ms_fmd_subfile,
      log_entry: dmt$dl_entry,
      i: integer,
      avt_index: dmt$active_volume_table_index,
      file_tables_in_mainframe: boolean,
      active_volume_entry_found: boolean,
      volume_offline_count: integer,
      recorded_vsn: rmt$recorded_vsn,
      p_fmd_seq: ^dmt$stored_fmd;

    #INLINE ('keypoint', osk$entry, 0, dmk$destroy_permanent_file);
    #INLINE ('keypoint', osk$data, global_file_name.sequence_number, 0);

    status.normal := TRUE;
    volume_offline_count := 0;

  /process_request/
    BEGIN
      inhibit_recovery (global_file_name, file_tables_in_mainframe, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      IF file_tables_in_mainframe THEN
        EXIT /process_request/;
      IFEND;

      p_fmd_seq := ^stored_fmd;
      RESET p_fmd_seq;

      NEXT p_stored_fmd_version IN p_fmd_seq;

      NEXT p_stored_fmd_header: [p_stored_fmd_version^] IN p_fmd_seq;
      IF p_stored_fmd_header = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_fmd,
          'No fmd header - dmp$destroy_permanent_file.', status);
        EXIT /process_request/;
      IFEND;

      CASE p_stored_fmd_version^ OF
      = 0 =
        IF p_stored_fmd_header^.version_0_0.number_fmds = 0 THEN
          RETURN;
        IFEND;
        log_entry.kind := dmc$dl_purge_file;
        log_entry.purge_file_block.global_file_name := global_file_name;

        FOR i := 1 TO p_stored_fmd_header^.version_0_0.number_fmds DO
          NEXT p_stored_fmd_subfile: [p_stored_fmd_version^] IN p_fmd_seq;
          IF p_stored_fmd_subfile = NIL THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_fmd,
              'FMD too small to hold subfiles - dmp$destroy_permanent_file.', status);
            EXIT /process_request/;
          IFEND;
          dmp$search_avt_by_vsn (p_stored_fmd_subfile^.version_0_0.internal_vsn, avt_index,
              active_volume_entry_found);
          IF NOT active_volume_entry_found THEN
            volume_offline_count := volume_offline_count + 1;
            recorded_vsn := p_stored_fmd_subfile^.version_0_0.recorded_vsn;
          ELSE
            log_entry.purge_file_block.file_byte_address := p_stored_fmd_subfile^.version_0_0.
                  stored_byte_address * dmc$byte_address_converter;
            log_entry.purge_file_block.dfl_index := p_stored_fmd_subfile^.version_0_0.device_file_list_index;
            dmp$process_device_log_entry (avt_index, log_entry, status);
            IF NOT status.normal THEN
              EXIT /process_request/;
            IFEND;
          IFEND;
        FOREND;
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unsupported_fmd_version,
          'Unsupported FMD version number - dmp$destroy_permanent_file.', status);
      CASEND;

    END /process_request/;

    IF (status.normal) AND (volume_offline_count <> 0) THEN
      osp$set_status_abnormal (dmc$device_manager_ident,
            dme$some_volumes_not_online, recorded_vsn, status);
    IFEND;

    #INLINE ('keypoint', osk$exit, 0,
          dmk$destroy_permanent_file);

  PROCEND dmp$destroy_permanent_file;
?? TITLE := '  dmp$destroy_device_file', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$destroy_device_file (recorded_vsn: rmt$recorded_vsn;
        user_supplied_name: ost$name;
    VAR status: ost$status);

    VAR
      close_status: ost$status,
      p_active_vol_attributes: ^array [ * ] of dmt$assigned_ms_vol_attribute,
      avt_index: dmt$active_volume_table_index,
      volume_active: boolean,
      directory_sfid: dmt$system_file_id,
      directory_index: dmt$directory_index,
      p_directory: ^dmt$ms_volume_directory,
      entry_found: boolean,
      stored_df_fmd: dmt$device_file_stored_fmd,
      global_file_name: dmt$global_file_name;

    status.normal := TRUE;

  /process_request/
    BEGIN
      PUSH p_active_vol_attributes: [1 .. 1];
      p_active_vol_attributes^ [1].keyword := dmc$ms_volume_directory;

      avt_index := 0;

      dmp$get_active_vol_attributes (recorded_vsn, avt_index, p_active_vol_attributes, volume_active);
      IF NOT volume_active THEN
        {
        { issue mount request
        {
        osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
              'Volume not in AVT - dmp$destroy_device_file.', status);
        osp$append_status_parameter (' ', recorded_vsn, status);
        EXIT /process_request/;
      IFEND;

      directory_sfid := p_active_vol_attributes^ [1].directory_sfid;

      directory_index := 0;
      dmp$search_vol_directory_name (user_supplied_name, directory_sfid, directory_index, entry_found,
            status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      IF NOT entry_found THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unknown_device_file,
              'Unknown device file name - dmp$destroy_device_file.', status);
        osp$append_status_parameter (' ', user_supplied_name, status);
        EXIT /process_request/;
      IFEND;

      dmp$open_directory (directory_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend,
         mmc$as_sequential, p_directory, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      stored_df_fmd := p_directory^.entries [directory_index].stored_df_fmd;
      global_file_name := p_directory^.entries [directory_index].global_file_name;

      dmp$destroy_permanent_file (global_file_name, stored_df_fmd, status);
      IF status.normal THEN
        p_directory^.entries [directory_index].entry_available := TRUE;
        mmp$write_modified_pages (p_directory, #SIZE (p_directory^), osc$wait, status);
      IFEND;

      dmp$close_file (p_directory, close_status);
      IF NOT close_status.normal THEN
        IF status.normal THEN
          status := close_status;
        IFEND;
      IFEND;

    END /process_request/;

  PROCEND dmp$destroy_device_file;
?? TITLE := '  dmp$destroy_sub_file', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$destroy_sub_file (global_file_name: dmt$global_file_name;
        recorded_vsn: rmt$recorded_vsn;
        dfl_index: dmt$device_file_list_index;
        byte_address: amt$file_byte_address;
    VAR status: ost$status);

    VAR
      log_entry: dmt$dl_entry,
      search_key: dmt$avt_search_key,
      avt_index: dmt$active_volume_table_index,
      file_tables_in_mainframe: boolean,
      avt_entry_not_found: boolean;

    status.normal := TRUE;

    log_entry.kind := dmc$dl_purge_file;
    log_entry.purge_file_block.global_file_name := global_file_name;
    log_entry.purge_file_block.dfl_index := dfl_index;
    log_entry.purge_file_block.file_byte_address := byte_address;

    search_key.value := dmc$search_avt_by_rec_vsn;
    search_key.recorded_vsn := recorded_vsn;

    dmp$search_active_volume_table (search_key, avt_index, avt_entry_not_found);
    IF avt_entry_not_found THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
        'Volume not mounted - dmp$destroy_sub_file.', status);
      osp$append_status_parameter (' ', recorded_vsn, status);
      RETURN;
    IFEND;

    inhibit_recovery (global_file_name, file_tables_in_mainframe, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT file_tables_in_mainframe THEN
      dmp$process_device_log_entry (avt_index, log_entry, status);
    IFEND;

  PROCEND dmp$destroy_sub_file;
?? TITLE := '  inhibit_recovery', EJECT ??

  PROCEDURE inhibit_recovery (global_file_name: dmt$global_file_name;
    VAR existing_entry_found: boolean;
    VAR status: ost$status);

    VAR
      sfid: gft$system_file_identifier,
      file_hash: dmt$file_hash,
      p_fde: gft$locked_file_desc_entry_p,
      p_dfd: ^dmt$disk_file_descriptor,
      master_attach_lock_set: boolean,
      local_status: ost$status;

    status.normal := TRUE;

    { Build SFID.

    dmp$generate_gfn_hash (global_file_name, file_hash);
    sfid.file_hash := file_hash;
    sfid.residence := gfc$tr_system;

    { Set master attach lock.

    dmp$set_master_attach_lock (sfid);

    { Find, lock and set the purge flag for any existing SFT entry.

    dmp$search_fdt_by_gfn (sfid.residence, global_file_name, sfid.file_entry_index,
         existing_entry_found);
    IF existing_entry_found THEN
      gfp$get_locked_fde_p (sfid, p_fde);
      existing_entry_found := (p_fde^.global_file_name = global_file_name);
      IF existing_entry_found THEN
        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
        p_dfd^.purged := TRUE;
        dmp$decrement_class_activity (sfid, status);
      IFEND;
      gfp$unlock_fde_p (p_fde);
    IFEND;

    { Clear master attach lock.

    dmp$clear_master_attach_lock (sfid);

  PROCEND inhibit_recovery;

MODEND dmm$destroy_permanent_file;
*DECK DECK=DMM$DEVICE_FILE_DISPLAY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Device Mangement' ??
?? NEWTITLE := '  Declarations' ??
MODULE dmm$device_file_display;
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc fst$attachment_options
*copyc rmd$volume_declarations
?? TITLE := '  XREF Procedures', EJECT ??
*copyc clp$evaluate_parameters
*copyc clp$get_path_description
*copy clp$scan_parameter_list
*copy clp$get_value
*copy clp$push_utility
*copy clp$scan_command_file
*copy clp$pop_utility
*copy clp$open_display
*copy clp$close_display
*copy clp$end_scan_command_file
*copyc dmp$change_file_damage_r3
*copyc dmp$copy_dat
*copyc dmp$copy_dfl
*copyc dmp$copy_directory
*copyc dmp$copy_label
*copyc dmp$copy_log
*copyc dmp$copy_login_table
*copyc dmp$display_device_space
*copy dmp$display_label
*copy dmp$display_device_file
*copy dmp$display_directory
*copy dmp$display_dat
*copy dmp$display_device_log
*copy dmp$display_login_table
*copyc dmp$display_cylinders
*copyc dmp$utility_flush_logs_r3
*copyc dmp$reassign_file_r3
*copyc fsp$open_file
*copyc fsp$close_file
*copyc amp$get_segment_pointer
*copyc dmp$display_file_tables
*copyc osp$set_status_abnormal
*copyc clp$new_display_page
*copyc clp$put_partial_display
*copyc clp$new_display_line
*copyc mmp$get_allocated_addresses
?? POP ??
?? TITLE := '  Global Variables', EJECT ??

  VAR
    display_control: clt$display_control,
    utility_name: [READ] ost$name := 'Display_device_file            ',
    command_file,
    output_file: clt$value;

?? TITLE := '  display_device_file', EJECT ??

  PROCEDURE [XDCL, #GATE] display_device_file (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT display_device_file_pdt (
{   input, i : FILE = $COMMAND
{   output, o : FILE = $OUTPUT
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_device_file_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^display_device_file_pdt_names, ^display_device_file_pdt_params];

    VAR
      display_device_file_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
        clt$parameter_name_descriptor := [['INPUT', 1], ['I', 1], ['OUTPUT', 2], ['O', 2], ['STATUS', 3]];

    VAR
      display_device_file_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
        clt$parameter_descriptor := [

{ INPUT I }
      [[clc$optional_with_default, ^display_device_file_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
        [NIL, clc$file_value]],

{ OUTPUT O }
      [[clc$optional_with_default, ^display_device_file_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
        [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      display_device_file_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (8) := '$COMMAND';

    VAR
      display_device_file_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??

{ table display_command_list t=c s=local
{ command (change_file_damage        ) change_file_damage_processor     cm=local
{ command (copy_device_file          ) copy_device_file_processor       cm=local
{ command (display_cylinders         ) display_cylinders_processor      cm=local
{ command (display_label             ) display_label_processor          cm=local
{ command (display_device_file_list  ) display_dfl_processor            cm=local
{ command (display_directory         ) display_directory_processor      cm=local
{ command (display_dat               ) display_dat_processor            cm=local
{ command (display_device_log        ) display_device_log_processor     cm=local
{ command (display_file_tables       ) display_file_tables_processor    cm=local
{ command (display_allocated_addresses) display_allocated_addrs_proc    cm=local
{ command (display_login_table       ) display_login_table_processor    cm=local
{ command (display_device_space      ) display_device_space_processor   cm=local
{ command (flush_device_logs         ) flush_device_logs_processor      cm=local
{ command (quit                      ) quit_processor                   cm=local
{ command (reassign_file             ) reassign_file_processor          cm=local

?? PUSH (LISTEXT := ON) ??

VAR
  display_command_list: [STATIC, READ] ^clt$command_table := ^display_command_list_entries,

  display_command_list_entries: [STATIC, READ] array [1 .. 15] of clt$command_table_entry := [
  {} ['CHANGE_FILE_DAMAGE             ', clc$nominal_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^change_file_damage_processor],
  {} ['COPY_DEVICE_FILE               ', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^copy_device_file_processor],
  {} ['DISPLAY_ALLOCATED_ADDRESSES    ', clc$nominal_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^display_allocated_addrs_proc],
  {} ['DISPLAY_CYLINDERS              ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^display_cylinders_processor],
  {} ['DISPLAY_DAT                    ', clc$nominal_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^display_dat_processor],
  {} ['DISPLAY_DEVICE_FILE_LIST       ', clc$nominal_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^display_dfl_processor],
  {} ['DISPLAY_DEVICE_LOG             ', clc$nominal_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^display_device_log_processor],
  {} ['DISPLAY_DEVICE_SPACE           ', clc$nominal_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^display_device_space_processor],
  {} ['DISPLAY_DIRECTORY              ', clc$nominal_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^display_directory_processor],
  {} ['DISPLAY_FILE_TABLES            ', clc$nominal_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^display_file_tables_processor],
  {} ['DISPLAY_LABEL                  ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^display_label_processor],
  {} ['DISPLAY_LOGIN_TABLE            ', clc$nominal_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^display_login_table_processor],
  {} ['FLUSH_DEVICE_LOGS              ', clc$nominal_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^flush_device_logs_processor],
  {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 14,
        clc$automatically_log, clc$linked_call, ^quit_processor],
  {} ['REASSIGN_FILE                  ', clc$nominal_entry, clc$normal_usage_entry, 15,
        clc$automatically_log, clc$linked_call, ^reassign_file_processor]];

?? POP ??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_device_file_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$push_utility (utility_name, clc$global_command_search, display_command_list, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('INPUT', 1, 1, clc$low, command_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$open_display (output_file.file, NIL, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_command_file (command_file.file.local_file_name, utility_name, 'DM', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$close_display (display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$pop_utility (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_device_file;
?? TITLE := '  change_file_damage_processor', EJECT ??

  PROCEDURE change_file_damage_processor (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT change_file_damage_pdt (
{    file, f: file = $required
{    damage, d: boolean = $required
{    damage_detection_enabled, dde: boolean = $required
{    dfl_damage, dd: boolean = $required
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    change_file_damage_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
  ^change_file_damage_pdt_names, ^change_file_damage_pdt_params];

  VAR
    change_file_damage_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 9] of
  clt$parameter_name_descriptor := [['FILE', 1], ['F', 1], ['DAMAGE', 2], ['D', 2], [
  'DAMAGE_DETECTION_ENABLED', 3], ['DDE', 3], ['DFL_DAMAGE', 4], ['DD', 4], ['STATUS', 5]];

  VAR
    change_file_damage_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of
  clt$parameter_descriptor := [

{ FILE F }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ DAMAGE D }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ DAMAGE_DETECTION_ENABLED DDE }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ DFL_DAMAGE DD }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      damage: clt$value,
      damage_detection: clt$value,
      dfl_damage: clt$value,
      fid: amt$file_identifier,
      ignore_status: ost$status,
      p_attachment_options: ^fst$attachment_options,
      segp: amt$segment_pointer,
      value: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, change_file_damage_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('FILE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DAMAGE', 1, 1, clc$low, damage, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DAMAGE_DETECTION_ENABLED', 1, 1, clc$low, damage_detection, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DFL_DAMAGE', 1, 1, clc$low, dfl_damage, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_attachment_options: [1 .. 1];
    p_attachment_options^ [1].selector := fsc$access_and_share_modes;
    p_attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
    p_attachment_options^ [1].access_modes.value := $fst$file_access_options
          [fsc$read];
    p_attachment_options^ [1].share_modes.selector := fsc$specific_share_modes;
    p_attachment_options^ [1].share_modes.value := $fst$file_access_options
          [fsc$read, fsc$shorten, fsc$append, fsc$modify, fsc$execute];

    fsp$open_file (value.file.local_file_name, amc$segment, p_attachment_options, NIL, NIL, NIL, NIL, fid,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (fid, amc$cell_pointer, segp, status);
    IF NOT status.normal THEN
      fsp$close_file (fid, ignore_status);
      RETURN;
    IFEND;

    dmp$change_file_damage_r3 (segp.cell_pointer, damage.bool.value, damage_detection.bool.value,
       dfl_damage.bool.value, ignore_status);
    fsp$close_file (fid, ignore_status);

  PROCEND change_file_damage_processor;
?? TITLE := '  copy_device_file_processor', EJECT ??

  PROCEDURE copy_device_file_processor (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE copy_device_file (
{   device_file, df: key
{       (device_allocation_table, dat)
{       (device_file_list, dfl)
{       (directory, dir)
{       (login_table, login, lt)
{       (label, lab)
{       (device_log, log, dl)
{     keyend = $required
{   recorded_vsn, rvsn, vsn: name 1..6 = $required
{   output_file, file, of, f: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 14] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 11, 15, 9, 37, 42, 133],
    clc$command, 10, 4, 3, 0, 0, 0, 4, ''], [
    ['DEVICE_FILE                    ',clc$nominal_entry, 1],
    ['DF                             ',clc$abbreviation_entry, 1],
    ['F                              ',clc$abbreviation_entry, 3],
    ['FILE                           ',clc$alias_entry, 3],
    ['OF                             ',clc$alias_entry, 3],
    ['OUTPUT_FILE                    ',clc$nominal_entry, 3],
    ['RECORDED_VSN                   ',clc$nominal_entry, 2],
    ['RVSN                           ',clc$alias_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['VSN                            ',clc$abbreviation_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 525,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [14], [
    ['DAT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['DEVICE_ALLOCATION_TABLE        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['DEVICE_FILE_LIST               ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['DEVICE_LOG                     ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['DFL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['DIR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['DIRECTORY                      ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['DL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['LAB                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['LABEL                          ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['LOG                            ', clc$alias_entry, clc$normal_usage_entry, 6],
    ['LOGIN                          ', clc$alias_entry, clc$normal_usage_entry, 4],
    ['LOGIN_TABLE                    ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['LT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4]]
    ],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, 6]],
{ PARAMETER 3
    [[1, 0, clc$file_type]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$device_file = 1,
      p$recorded_vsn = 2,
      p$output_file = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      fid: amt$file_identifier,
      segp: amt$segment_pointer,
      ignore: ost$status,
      file_open: boolean,
      vsn: rmt$recorded_vsn;

    status.normal := TRUE;
    file_open := FALSE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);

    IF status.normal THEN
      fsp$open_file (pvt [p$output_file].value^.file_value^, amc$segment, NIL, NIL, NIL, NIL, NIL, fid,
            status);
      file_open := status.normal;
      IF file_open THEN
        amp$get_segment_pointer (fid, amc$cell_pointer, segp, status);
      IFEND;
      IF status.normal THEN
        vsn := pvt [p$recorded_vsn].value^.name_value (1, rmc$recorded_vsn_size);
        IF (pvt [p$device_file].value^.keyword_value = 'DEVICE_ALLOCATION_TABLE') THEN
          dmp$copy_dat (vsn, segp.cell_pointer, status);
        ELSEIF (pvt [p$device_file].value^.keyword_value = 'DEVICE_FILE_LIST') THEN
          dmp$copy_dfl (vsn, segp.cell_pointer, status);
        ELSEIF (pvt [p$device_file].value^.keyword_value = 'DIRECTORY') THEN
          dmp$copy_directory (vsn, segp.cell_pointer, status);
        ELSEIF (pvt [p$device_file].value^.keyword_value = 'LOGIN_TABLE') THEN
          dmp$copy_login_table (vsn, segp.cell_pointer, status);
        ELSEIF (pvt [p$device_file].value^.keyword_value = 'LABEL') THEN
          dmp$copy_label (vsn, segp.cell_pointer, status);
        ELSEIF (pvt [p$device_file].value^.keyword_value = 'DEVICE_LOG') THEN
          dmp$copy_log (vsn, segp.cell_pointer, status);
        ELSE
          osp$set_status_abnormal ('dm', 1, 'sorry, not implemented', status);
        IFEND;
      IFEND;
    IFEND;

    IF file_open THEN
      fsp$close_file (fid, ignore);
    IFEND;

  PROCEND copy_device_file_processor;

?? TITLE := '  display_cylinders_processor', EJECT ??

  PROCEDURE display_cylinders_processor (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ pdt display_cylinders_pdt (
{  recorded_vsn, recv, vsn: name
{  status )

?? PUSH (LISTEXT := ON) ??

    VAR
      display_cylinders_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^display_cylinders_pdt_names, ^display_cylinders_pdt_params];

    VAR
      display_cylinders_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
        clt$parameter_name_descriptor := [['RECORDED_VSN', 1], ['RECV', 1], ['VSN', 1], ['STATUS', 2]];

    VAR
      display_cylinders_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
        clt$parameter_descriptor := [

{ RECORDED_VSN RECV VSN }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      recorded_vsn: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_cylinders_pdt, status);
    IF status.normal THEN
      clp$get_value ('RECORDED_VSN', 1, 1, clc$low, recorded_vsn, status);
      IF status.normal THEN
        dmp$display_cylinders (display_control, recorded_vsn.name.value (1, rmc$recorded_vsn_size), status);
      IFEND;
    IFEND;

  PROCEND display_cylinders_processor;

?? TITLE := '  display_label', EJECT ??

  PROCEDURE display_label_processor (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT display_label_pdt (
{   recorded_vsn, r_v : NAME
{   status)

?? PUSH (LISTEXT := ON) ??
{ STATUS }

    VAR
      display_label_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^display_label_pdt_names,
        ^display_label_pdt_params];

    VAR
      display_label_pdt_names: [STATIC, READ, cls$pdt] array [1 .. 3] of clt$parameter_name_descriptor :=
        [['RECORDED_VSN', 1], ['R_V', 1], ['STATUS', 2]];

    VAR
      display_label_pdt_params: [STATIC, READ, cls$pdt] array [1 .. 2] of clt$parameter_descriptor := [

{ RECORDED_VSN R_V } [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
      osc$max_name_size]],

{ STATUS } [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      recorded_vsn: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_label_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('RECORDED_VSN', 1, 1, clc$low, recorded_vsn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$display_label (display_control, recorded_vsn.name.value (1, rmc$recorded_vsn_size), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_label_processor;
?? TITLE := '  display_dfl_processor', EJECT ??

  PROCEDURE display_dfl_processor (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT display_list_pdt (
{   recorded_vsn, r_v: name = $optional
{   display_option, do: integer LOWERVALUE(dmt$device_file_list_index)..
{     ..UPPERVALUE(dmt$device_file_list_index) or key full, f, summary, s = full
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    display_list_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^display_list_pdt_names,
  ^display_list_pdt_params];

  VAR
    display_list_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
  clt$parameter_name_descriptor := [['RECORDED_VSN', 1], ['R_V', 1], ['DISPLAY_OPTION', 2], ['DO', 2], [
  'STATUS', 3]];

  VAR
    display_list_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor
  := [

{ RECORDED_VSN R_V }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ DISPLAY_OPTION DO }
    [[clc$optional_with_default, ^display_list_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [^
  display_list_pdt_kv2, clc$integer_value, LOWERVALUE(dmt$device_file_list_index),
  UPPERVALUE(dmt$device_file_list_index)]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    display_list_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := ['FULL','F'
  ,'SUMMARY','S'];

  VAR
    display_list_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'full';

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      summary_listing: boolean,
      full_listing:boolean,
      file_index:dmt$device_file_list_index,
      display_option: clt$value,
      recorded_vsn: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_list_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('RECORDED_VSN', 1, 1, clc$low, recorded_vsn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DISPLAY_OPTION', 1, 1, clc$low, display_option, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE display_option.kind OF

    = clc$integer_value =

      file_index := display_option.int.value;
      summary_listing := false;
      full_listing := false;

    = clc$name_value =

      file_index := 0;
      IF (display_option.name.value = 'SUMMARY') OR (display_option.name.value = 'S') THEN
        summary_listing := true;
        full_listing := false;
      ELSE
        summary_listing := true;
        full_listing := true;
      IFEND
    ELSE
      status.normal := false;
      return;
    CASEND;

    dmp$display_device_file (
      display_control,
      recorded_vsn.name.value (1, rmc$recorded_vsn_size),
      summary_listing,
      full_listing,
      file_index,
      status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_dfl_processor;
?? TITLE := '  display_directory', EJECT ??

  PROCEDURE display_directory_processor (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{ PDT display_directory_pdt (
{   recorded_vsn, r_v : NAME
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_directory_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^display_directory_pdt_names, ^display_directory_pdt_params];

    VAR
      display_directory_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['RECORDED_VSN', 1], ['R_V', 1], ['STATUS', 2]];

    VAR
      display_directory_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
        clt$parameter_descriptor := [

{ RECORDED_VSN R_V }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      recorded_vsn: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_directory_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('RECORDED_VSN', 1, 1, clc$low, recorded_vsn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$display_directory (display_control, recorded_vsn.name.value (1, rmc$recorded_vsn_size), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_directory_processor;
?? TITLE := '  display_dat', EJECT ??

  PROCEDURE display_dat_processor (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT display_dat_pdt (
{   recorded_vsn, r_v : NAME
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_dat_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^display_dat_pdt_names,
        ^display_dat_pdt_params];

    VAR
      display_dat_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['RECORDED_VSN', 1], ['R_V', 1], ['STATUS', 2]];

    VAR
      display_dat_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor :=
        [

{ RECORDED_VSN R_V }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      recorded_vsn: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_dat_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('RECORDED_VSN', 1, 1, clc$low, recorded_vsn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$display_dat (display_control, recorded_vsn.name.value (1, rmc$recorded_vsn_size), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_dat_processor;
?? TITLE := '  display_device_log', EJECT ??

  PROCEDURE display_device_log_processor (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT display_device_log_pdt (
{   recorded_vsn, r_v : NAME
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_device_log_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^display_device_log_pdt_names, ^display_device_log_pdt_params];

    VAR
      display_device_log_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['RECORDED_VSN', 1], ['R_V', 1], ['STATUS', 2]];

    VAR
      display_device_log_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
        clt$parameter_descriptor := [

{ RECORDED_VSN R_V }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      recorded_vsn: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_device_log_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('RECORDED_VSN', 1, 1, clc$low, recorded_vsn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$display_device_log (display_control, recorded_vsn.name.value (1, rmc$recorded_vsn_size), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_device_log_processor;
?? TITLE := '  display_device_space_processor', EJECT ??

  PROCEDURE display_device_space_processor (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT display_dat_pdt (
{   recorded_vsn, r_v : NAME
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_dat_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^display_dat_pdt_names,
        ^display_dat_pdt_params];

    VAR
      display_dat_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['RECORDED_VSN', 1], ['R_V', 1], ['STATUS', 2]];

    VAR
      display_dat_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor :=
        [

{ RECORDED_VSN R_V }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      recorded_vsn: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_dat_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('RECORDED_VSN', 1, 1, clc$low, recorded_vsn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$display_device_space (display_control, recorded_vsn.name.value (1, rmc$recorded_vsn_size), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_device_space_processor;
?? TITLE := '  display_file_tables', EJECT ??

  PROCEDURE display_file_tables_processor (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{  PDT display_file_tables_pdt (
{    file, f: file = $required
{    display_option, do: key full, f, summary, s = full
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    display_file_tables_pdt: [STATIC, READ, cls$pdt]
  clt$parameter_descriptor_table := [^display_file_tables_pdt_names,
  ^display_file_tables_pdt_params];

  VAR
    display_file_tables_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults]
  array [1 .. 5] of clt$parameter_name_descriptor := [['FILE', 1], ['F', 1], [
  'DISPLAY_OPTION', 2], ['DO', 2], ['STATUS', 3]];

  VAR
    display_file_tables_pdt_params: [STATIC, READ, cls$pdt_parameters] array [
  1 .. 3] of clt$parameter_descriptor := [

{ FILE F }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$file_value]],

{ DISPLAY_OPTION DO }
    [[clc$optional_with_default, ^display_file_tables_pdt_dv2], 1, 1, 1, 1,
  clc$value_range_not_allowed, [^display_file_tables_pdt_kv2, clc$keyword_value
  ]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

  VAR
    display_file_tables_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults]
  array [1 .. 4] of ost$name := ['FULL','F','SUMMARY','S'];

  VAR
    display_file_tables_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults
  ] string (4) := 'full';

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      cycle_selector: clt$cycle_selector,
      display_option: clt$value,
      fid: amt$file_identifier,
      file_reference: clt$file_reference,
      full_listing: boolean,
      ignore_status: ost$status,
      open_position: clt$open_position,
      p_attachment_options: ^fst$attachment_options,
      path: ^pft$path,
      path_container: clt$path_container,
      segp: amt$segment_pointer,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, display_file_tables_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('FILE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_attachment_options: [1 .. 1];
    p_attachment_options^ [1].selector := fsc$access_and_share_modes;
    p_attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
    p_attachment_options^ [1].access_modes.value := $fst$file_access_options [fsc$read];
    p_attachment_options^ [1].share_modes.selector := fsc$specific_share_modes;
    p_attachment_options^ [1].share_modes.value :=
          $fst$file_access_options [fsc$read, fsc$shorten, fsc$append, fsc$modify, fsc$execute];

    fsp$open_file (value.file.local_file_name, amc$segment, p_attachment_options, NIL, NIL, NIL, NIL, fid,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (fid, amc$cell_pointer, segp, status);
    IF NOT status.normal THEN
      fsp$close_file (fid, ignore_status);
      RETURN;
    IFEND;

    clp$get_path_description (value.file, file_reference, path_container, path, cycle_selector, open_position,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DISPLAY_OPTION', 1, 1, clc$low, display_option, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    full_listing := (display_option.name.value = 'FULL') OR (display_option.name.value = 'F');

    dmp$display_file_tables (file_reference.path_name (1, file_reference.path_name_size),
          full_listing, segp.cell_pointer, display_control, status);

    fsp$close_file (fid, ignore_status);

  PROCEND display_file_tables_processor;
?? TITLE := '  display_login_table', EJECT ??

  PROCEDURE display_login_table_processor (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT display_login_table_pdt (
{   recorded_vsn, r_v : NAME
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_login_table_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^display_login_table_pdt_names, ^display_login_table_pdt_params];

    VAR
      display_login_table_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['RECORDED_VSN', 1], ['R_V', 1], ['STATUS', 2]];

    VAR
      display_login_table_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
        clt$parameter_descriptor := [

{ RECORDED_VSN R_V }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      recorded_vsn: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_login_table_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('RECORDED_VSN', 1, 1, clc$low, recorded_vsn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$display_login_table (display_control, recorded_vsn.name.value (1, rmc$recorded_vsn_size), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_login_table_processor;
?? TITLE := '  flush_device_logs_processor', EJECT ??

  PROCEDURE flush_device_logs_processor (parameter_list: clt$parameter_list;
                                     VAR status: ost$status);

{ PDT flush_device_logs_pdt (
{    status)

?? PUSH (LISTEXT := ON) ??

  VAR
    flush_device_logs_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^flush_device_logs_pdt_names, ^flush_device_logs_pdt_params];

  VAR
    flush_device_logs_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
      clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    flush_device_logs_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
      clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, flush_device_logs_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$utility_flush_logs_r3;

  PROCEND flush_device_logs_processor;
?? TITLE := '  quit_processor', EJECT ??

  PROCEDURE quit_processor (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT quit_pdt (
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      quit_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^quit_pdt_names, ^quit_pdt_params];

    VAR
      quit_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
        clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      quit_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, quit_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_scan_command_file (utility_name, status);

  PROCEND quit_processor;
?? TITLE := '  reassign_file', EJECT ??

  PROCEDURE reassign_file_processor (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{  PDT reassign_file_pdt (
{    file, f: file = $required
{    status)

?? PUSH (LISTEXT := ON) ??

  VAR
    reassign_file_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^reassign_file_pdt_names, ^reassign_file_pdt_params];

  VAR
    reassign_file_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['FILE', 1], ['F', 1], ['STATUS', 2]];

  VAR
    reassign_file_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
      clt$parameter_descriptor := [

{ FILE F }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      fid: amt$file_identifier,
      ignore_status: ost$status,
      p_attachment_options: ^fst$attachment_options,
      segp: amt$segment_pointer,
      value: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, reassign_file_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('FILE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_attachment_options: [1 .. 1];
    p_attachment_options^ [1].selector := fsc$access_and_share_modes;
    p_attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
    p_attachment_options^ [1].access_modes.value := $fst$file_access_options [fsc$read];
    p_attachment_options^ [1].share_modes.selector := fsc$specific_share_modes;
    p_attachment_options^ [1].share_modes.value :=
          $fst$file_access_options [fsc$read, fsc$shorten, fsc$append, fsc$modify, fsc$execute];

    fsp$open_file (value.file.local_file_name, amc$segment, p_attachment_options, NIL, NIL, NIL, NIL, fid,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (fid, amc$cell_pointer, segp, status);
    IF NOT status.normal THEN
      fsp$close_file (fid, ignore_status);
      RETURN;
    IFEND;

    dmp$reassign_file_r3 (segp.cell_pointer, status);

    fsp$close_file (fid, ignore_status);

  PROCEND reassign_file_processor;
?? TITLE := '  display_allocated_addresses', EJECT ??

  PROCEDURE display_allocated_addrs_proc (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{  PDT display_alloc_addr_pdt (
{    file, f: file = $required
{    status)

?? PUSH (LISTEXT := ON) ??

  VAR
    display_alloc_addr_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^display_alloc_addr_pdt_names, ^display_alloc_addr_pdt_params];

  VAR
    display_alloc_addr_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['FILE', 1], ['F', 1], ['STATUS', 2]];

  VAR
    display_alloc_addr_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
      clt$parameter_descriptor := [

{ FILE F }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      addr_list: ^array [ * ] of dmt$addr_length_pair,
      addr_returned: integer,
      byte_address: ost$segment_offset,
      cycle_selector: clt$cycle_selector,
      fid: amt$file_identifier,
      file_reference: clt$file_reference,
      i: integer,
      ignore_status: ost$status,
      l: integer,
      line: string (132),
      list_overflow: boolean,
      open_position: clt$open_position,
      p_attachment_options: ^fst$attachment_options,
      path: ^pft$path,
      path_container: clt$path_container,
      segp: amt$segment_pointer,
      value: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_alloc_addr_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('FILE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_attachment_options: [1 .. 1];
    p_attachment_options^ [1].selector := fsc$access_and_share_modes;
    p_attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
    p_attachment_options^ [1].access_modes.value := $fst$file_access_options [fsc$read];
    p_attachment_options^ [1].share_modes.selector := fsc$specific_share_modes;
    p_attachment_options^ [1].share_modes.value :=
          $fst$file_access_options [fsc$read, fsc$shorten, fsc$append, fsc$modify, fsc$execute];

    fsp$open_file (value.file.local_file_name, amc$segment, p_attachment_options, NIL, NIL, NIL, NIL, fid,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    amp$get_segment_pointer (fid, amc$cell_pointer, segp, status);
    IF NOT status.normal THEN
      fsp$close_file (fid, ignore_status);
      RETURN;
    IFEND;

    byte_address := 0;
    PUSH addr_list: [1 .. 5];

    clp$get_path_description (value.file, file_reference,
      path_container, path, cycle_selector, open_position, status);
    clp$new_display_page (display_control, status);
    STRINGREP (line, l, ' Allocated Addresses: ', file_reference.path_name (1,
      file_reference.path_name_size));
    clp$put_partial_display (display_control, line (1, l), clc$trim,
          amc$terminate, status);

    clp$new_display_line (display_control, 3, status);

    REPEAT
      mmp$get_allocated_addresses (segp.cell_pointer, byte_address, addr_list^,
        addr_returned, list_overflow, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      FOR i := 1 TO addr_returned DO
        clp$put_partial_display (display_control, ' byte_address = ', clc$no_trim,
              amc$start, status);
        STRINGREP (line, l, addr_list^ [i].addr: #(16), '(16) ',
              ' length = ', addr_list^ [i].length: #(16), '(16) ');
        clp$put_partial_display (display_control, line (1, l), clc$trim,
              amc$terminate, status);
      FOREND;
      byte_address := addr_list^ [addr_returned].addr + addr_list^ [addr_returned].length;
    UNTIL NOT list_overflow;

    fsp$close_file (fid, ignore_status);

  PROCEND display_allocated_addrs_proc;

MODEND dmm$device_file_display;

*DECK DECK=DMM$DEVICE_FLAW_MANAGEMENT EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$device_flaw_management;

{
{  PURPOSE:
{
{    This module contains the code which is responsible for the definition,
{    display, and removal of software flaws on the devices maintained by
{    device management.
{
{  DESIGN:
{
{    The commands for flawing are entered in LCU and after processing in
{    this module, the correct device log is updated by the logger.
{
?? PUSH (LISTEXT := ON) ??
?? TITLE := 'XREF procedures', EJECT ??
*copyc dmp$close_dat_r3
*copyc dmp$convert_to_dau_address
*copyc dmp$get_logical_unit_number
*copyc dmp$get_physical_attributes
*copyc dmp$open_dat_r3
*copyc dmp$process_manual_flaw
*copyc dmp$store_sc_flaw_command
*copyc cmp$pc_get_logical_unit
*copyc dsp$log_system_message
*copyc osp$set_status_abnormal
?? TITLE := 'Global type declarations', EJECT ??
*copyc cml$ms_media_flaw_change
*copyc cmt$element_definition
*copyc cmt$product_identification
*copyc dmt$device_allocation_unit
*copyc dmt$error_condition_codes
*copyc dmt$log_flaw_init_data
*copyc dmt$flaw_dau_definition
*copyc dmt$flaw_duplication
*copyc dmt$physical_device_attributes
*copyc dmt$sc_flaw_command
*copyc iot$cylinder
*copyc iot$logical_unit
*copyc ost$status
*copyc rmt$recorded_vsn
?? POP ??
?? TITLE := '  dmp$define_remove_ms_flaw', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$define_remove_ms_flaw (recorded_vsn: rmt$recorded_vsn;
        p_phys_adrs: ^dmt$physical_flaw_address;
        trk_specified: boolean;
        sec_specified: boolean;
        operation_code: dmt$flaw_operation_code;
        initiator_code: dmt$flaw_initiator_code;
    VAR status: ost$status);

{   PURPOSE:
{     This procedure is the 'executive procedure' called by LCU whenever a flaw
{     is to be defined or removed.  It will call all other procedures needed to
{     execute the command, and will control the operation.

    VAR
      dau_address: dmt$dau_address,
      end_dau_address: dmt$dau_address,
      flaw_logging_data: dmt$log_flaw_init_data,
      ignore_status: ost$status,
      p_dat: ^dmt$ms_device_allocation_table,
      p_dat_entry: ^dmt$ms_device_allocation_unit,
      p_log_data: ^SEQ (*),
      p_sc_flaw: ^dmt$sc_flaw_command,
      previous_status: dmt$dau_status;

    dmp$convert_to_dau_address (recorded_vsn, p_phys_adrs, trk_specified, sec_specified, dau_address,
       end_dau_address, status);
    IF status.normal THEN

  { Save information to be used when statistics are transmitted.

      flaw_logging_data.recorded_vsn := recorded_vsn;
      flaw_logging_data.first_dau := dau_address;
      flaw_logging_data.last_dau := end_dau_address;
      flaw_logging_data.operation_code := operation_code;
      flaw_logging_data.initiator_code := initiator_code;

  { If only one DAU is to be altered, then check the DAU's status before changing.
  { Return status if the change can not be performed.

      IF dau_address = end_dau_address THEN
        dmp$open_dat_r3 (recorded_vsn, p_dat, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        p_dat_entry := ^p_dat^.body [dau_address];
        previous_status := p_dat_entry^.dau_status;

        dmp$close_dat_r3 (p_dat, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF operation_code = dmc$oc_flaw_define THEN
          IF (previous_status = dmc$dau_software_flawed) OR (previous_status = dmc$dau_ass_to_mf_swr_flawed)
                 OR (previous_status = dmc$dau_ass_to_file_swr_flawed) OR
                 (previous_status = dmc$dau_hardware_flawed) THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$address_already_flawed,
               'dmp$define_remove_ms_flaw', status);
            RETURN;
          IFEND;
        ELSEIF operation_code = dmc$oc_flaw_remove THEN
          IF ((previous_status <> dmc$dau_software_flawed)
                 AND (previous_status <> dmc$dau_ass_to_mf_swr_flawed)
                 AND (previous_status <> dmc$dau_ass_to_file_swr_flawed)) THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$address_not_sw_flawed,
               'dmp$define_remove_ms_flaw', status);
            RETURN;
          IFEND;
        IFEND;
      IFEND;

  { Call the logger procedure to change the DAU status to flawed.

      dmp$process_manual_flaw (recorded_vsn, dau_address, end_dau_address, operation_code, status);
      IF status.normal THEN

  { Issue statistics about flaw to the engineering log.

        p_log_data := #SEQ (flaw_logging_data);
        dsp$log_system_message (cml$ms_media_flaw_change, p_log_data, ignore_status);
      IFEND;
    IFEND;

    IF NOT status.normal THEN

      CASE status.condition OF

        = dme$logging_unavailable, dme$recorded_vsn_not_in_lun =
          IF (operation_code = dmc$oc_flaw_define) AND (initiator_code = dmc$ic_operator_initiated) THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$flawing_deferred,
               'dmp$define_remove_ms_flaw', status);
            PUSH p_sc_flaw;
            p_sc_flaw^.rvsn := recorded_vsn;
            p_sc_flaw^.phys_adrs.cylinder := p_phys_adrs^.cylinder;
            p_sc_flaw^.phys_adrs.track := p_phys_adrs^.track;
            p_sc_flaw^.phys_adrs.sector := p_phys_adrs^.sector;
            p_sc_flaw^.trk_specified := trk_specified;
            p_sc_flaw^.sec_specified := sec_specified;
            p_sc_flaw^.flaw_processed := FALSE;
            dmp$store_sc_flaw_command (p_sc_flaw);
          IFEND;

      ELSE
      CASEND;
    IFEND;

  PROCEND dmp$define_remove_ms_flaw;
?? TITLE := '  dmp$identify_flawed_daus', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$identify_flawed_daus (recorded_vsn: rmt$recorded_vsn;
        p_flaw_dau_definition: ^array [1 .. *] of dmt$flaw_dau_definition;
        p_flaw_duplication: ^array [1 .. *] of dmt$flaw_duplication;
    VAR big_enough_array: boolean;
    VAR status: ost$status);

{   PURPOSE:
{     This procedure will open and scan the DAT.  It will collect information in
{     an array about all DAU's that have a current flaw status.  An entry will
{     contain the first to last DAU if a consecutive number of DAUs are flawed.
{     However, if a consecutive number of DAUs are flawed with hardware and
{     software status, only the range of DAUs with hardware or software status
{     will be included in each entry.  It is the 'executive' procedure called
{     by the LCU command display_ms_flaw.

    VAR
      dat_index: dmt$dau_address,
      daus_per_cyl: integer,
      i: integer,
      p_dat: ^dmt$ms_device_allocation_table,
      p_dat_entry: ^dmt$ms_device_allocation_unit,
      p_physical_attributes: ^dmt$physical_device_attributes,
      previous_status: dmt$dau_status,
      sector_offset_within_cylinder: integer;

    big_enough_array := FALSE;
    i := LOWERBOUND (p_flaw_dau_definition^) - 1;
    previous_status := dmc$dau_usable;

    PUSH p_physical_attributes: [1 .. 4];
    p_physical_attributes^[1].keyword := dmc$maus_per_cylinder;
    p_physical_attributes^[2].keyword := dmc$sectors_per_mau;
    p_physical_attributes^[3].keyword := dmc$sectors_per_track;
    p_physical_attributes^[4].keyword := dmc$maus_per_dau;

    get_device_information (recorded_vsn, p_physical_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    daus_per_cyl := p_physical_attributes^[1].maus_per_cylinder DIV
       p_physical_attributes^[4].maus_per_dau;

    dmp$open_dat_r3 (recorded_vsn, p_dat, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    /locate_flawed_daus/
      FOR dat_index := 0 TO p_dat^.header.number_of_entries - 1 DO

        p_dat_entry := ^p_dat^.body [dat_index];

        CASE p_dat_entry^.dau_status OF

        = dmc$dau_software_flawed, dmc$dau_ass_to_mf_swr_flawed,
               dmc$dau_ass_to_file_swr_flawed =

          IF (previous_status = dmc$dau_software_flawed) OR (previous_status = dmc$dau_ass_to_mf_swr_flawed)
               OR (previous_status = dmc$dau_ass_to_file_swr_flawed) THEN

{ Set only last sector addresses.

            p_flaw_dau_definition^[i].last_dau := dat_index;
            p_flaw_dau_definition^[i].last.cylinder := dat_index DIV daus_per_cyl;
            sector_offset_within_cylinder := ((dat_index MOD daus_per_cyl) *
               p_physical_attributes^[2].sectors_per_mau * p_physical_attributes^[4].maus_per_dau) +
                  (p_physical_attributes^[4].maus_per_dau * p_physical_attributes^[2].sectors_per_mau) - 1;
            p_flaw_dau_definition^[i].last.track := sector_offset_within_cylinder DIV
               p_physical_attributes^[3].sectors_per_track;
            p_flaw_dau_definition^[i].last.sector := sector_offset_within_cylinder MOD
               p_physical_attributes^[3].sectors_per_track;
          ELSE

{ If the arrary is not big enough for all flaws, exit after closing the DAT with boolean value in
{ big_enough_array equal to false.

            i := i + 1;
            IF i > UPPERBOUND (p_flaw_dau_definition^) THEN
              dmp$close_dat_r3 (p_dat, status);
                RETURN;
            IFEND;

{ Set both first and last sector addresses and flaw type.

            p_flaw_dau_definition^[i].entry_initialized := TRUE;
            p_flaw_dau_definition^[i].first_dau := dat_index;
            p_flaw_dau_definition^[i].first.cylinder := dat_index DIV daus_per_cyl;
            sector_offset_within_cylinder := (dat_index MOD daus_per_cyl)
               * p_physical_attributes^[2].sectors_per_mau * p_physical_attributes^[4].maus_per_dau;
            p_flaw_dau_definition^[i].first.track := sector_offset_within_cylinder DIV
               p_physical_attributes^[3].sectors_per_track;
            p_flaw_dau_definition^[i].first.sector := sector_offset_within_cylinder MOD
               p_physical_attributes^[3].sectors_per_track;

            p_flaw_dau_definition^[i].last_dau := dat_index;
            p_flaw_dau_definition^[i].last.cylinder := dat_index DIV daus_per_cyl;
            sector_offset_within_cylinder := ((dat_index MOD daus_per_cyl)
               * p_physical_attributes^[2].sectors_per_mau * p_physical_attributes^[4].maus_per_dau) +
                   (p_physical_attributes^[4].maus_per_dau * p_physical_attributes^[2].sectors_per_mau) - 1;
            p_flaw_dau_definition^[i].last.track := sector_offset_within_cylinder DIV
               p_physical_attributes^[3].sectors_per_track;
            p_flaw_dau_definition^[i].last.sector := sector_offset_within_cylinder MOD
               p_physical_attributes^[3].sectors_per_track;
            p_flaw_dau_definition^[i].reserved := (p_dat_entry^.dau_status = dmc$dau_hardware_flawed)
          IFEND;
        = dmc$dau_hardware_flawed =
          IF previous_status = p_dat_entry^.dau_status THEN

{ Set only last sector addresses.

            p_flaw_dau_definition^[i].last_dau := dat_index;
            p_flaw_dau_definition^[i].last.cylinder := dat_index DIV daus_per_cyl;
            sector_offset_within_cylinder := ((dat_index MOD daus_per_cyl) *
               p_physical_attributes^[2].sectors_per_mau * p_physical_attributes^[4].maus_per_dau) +
                   (p_physical_attributes^[4].maus_per_dau * p_physical_attributes^[2].sectors_per_mau) - 1;
            p_flaw_dau_definition^[i].last.track := sector_offset_within_cylinder DIV
               p_physical_attributes^[3].sectors_per_track;
            p_flaw_dau_definition^[i].last.sector := sector_offset_within_cylinder MOD
               p_physical_attributes^[3].sectors_per_track;
          ELSE

{ If the arrary is not big enough for all flaws, exit after closing the DAT with boolean value in
{ big_enough_array equal to false.

            i := i + 1;
            IF i > UPPERBOUND (p_flaw_dau_definition^) THEN
              dmp$close_dat_r3 (p_dat, status);
              RETURN;
            IFEND;

{ Set both first and last sector addresses and flaw type.

            p_flaw_dau_definition^[i].entry_initialized := TRUE;
            p_flaw_dau_definition^[i].first_dau := dat_index;
            p_flaw_dau_definition^[i].first.cylinder := dat_index DIV daus_per_cyl;
            sector_offset_within_cylinder := (dat_index MOD daus_per_cyl)
               * p_physical_attributes^[2].sectors_per_mau * p_physical_attributes^[4].maus_per_dau;
            p_flaw_dau_definition^[i].first.track := sector_offset_within_cylinder DIV
               p_physical_attributes^[3].sectors_per_track;
            p_flaw_dau_definition^[i].first.sector := sector_offset_within_cylinder MOD
               p_physical_attributes^[3].sectors_per_track;

            p_flaw_dau_definition^[i].last_dau := dat_index;
            p_flaw_dau_definition^[i].last.cylinder := dat_index DIV daus_per_cyl;
            sector_offset_within_cylinder := ((dat_index MOD daus_per_cyl)
               * p_physical_attributes^[2].sectors_per_mau * p_physical_attributes^[4].maus_per_dau) +
                  (p_physical_attributes^[4].maus_per_dau * p_physical_attributes^[2].sectors_per_mau) - 1;
            p_flaw_dau_definition^[i].last.track := sector_offset_within_cylinder DIV
               p_physical_attributes^[3].sectors_per_track;
            p_flaw_dau_definition^[i].last.sector := sector_offset_within_cylinder MOD
               p_physical_attributes^[3].sectors_per_track;
            p_flaw_dau_definition^[i].reserved := (p_dat_entry^.dau_status = dmc$dau_hardware_flawed)
          IFEND;
        ELSE
        CASEND;
        previous_status := p_dat_entry^.dau_status;
      FOREND /locate_flawed_daus/;

      dmp$close_dat_r3 (p_dat, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Call procedure to create an array of LCU flaw commands needed to duplicate the flaws found.

      duplicate_flaw_commands (p_flaw_dau_definition, p_flaw_duplication, p_physical_attributes,
         big_enough_array, status)

  PROCEND dmp$identify_flawed_daus;
?? TITLE := ' duplicate_flaw_commands', EJECT ??
  PROCEDURE duplicate_flaw_commands (p_flaw_dau_definition: ^array [1 .. *] of dmt$flaw_dau_definition;
        p_flaw_duplication: ^array [1 .. *] of dmt$flaw_duplication;
        p_physical_attributes: ^dmt$physical_device_attributes;
    VAR big_enough_array: boolean;
    VAR status: ost$status);

{   PURPOSE:
{     This procedure, given an array of the DAU's that are flawed on a device,
{     will generate the define_ms_flaw commands needed by LCU to duplicate all
{     of the flaws if the device has been initialized.

    VAR
      daus_per_cyl: integer,
      first_dau: integer,
      i: integer,
      j: integer,
      last_dau: integer,
      phys_adrs: dmt$physical_flaw_address,
      sector_offset_within_cylinder: integer;

    big_enough_array := FALSE;
    j := LOWERBOUND (p_flaw_duplication^) - 1;

    daus_per_cyl := p_physical_attributes^[1].maus_per_cylinder DIV p_physical_attributes^[4].maus_per_dau;

    /small_array_exit/
    BEGIN

      /duplicate_flaws/
      FOR i := LOWERBOUND (p_flaw_dau_definition^) TO UPPERBOUND (p_flaw_dau_definition^) DO

        IF p_flaw_dau_definition^[i].entry_initialized = FALSE THEN
          EXIT /duplicate_flaws/;
        IFEND;

{ Skip all reserved flaws which are hardware, cip, and maintenance reserved space.

        IF p_flaw_dau_definition^[i].reserved = TRUE THEN
          CYCLE /duplicate_flaws/;
        IFEND;

        first_dau := (p_flaw_dau_definition^[i].first_dau);
        last_dau := (p_flaw_dau_definition^[i].last_dau);
        phys_adrs.cylinder := p_flaw_dau_definition^[i].first_dau DIV daus_per_cyl;
        sector_offset_within_cylinder := (first_dau MOD daus_per_cyl)
           * p_physical_attributes^[2].sectors_per_mau * p_physical_attributes^[4].maus_per_dau;
        phys_adrs.track := sector_offset_within_cylinder DIV p_physical_attributes^[3].sectors_per_track;
        phys_adrs.sector := sector_offset_within_cylinder MOD p_physical_attributes^[3].sectors_per_track;

        /build_flaws_for_entry/
        WHILE first_dau <= last_dau DO

{ Check if a sector flaw.

          /sector_flaw/
          WHILE (phys_adrs.sector <> 0) OR (phys_adrs.track <> 0) OR
                ((last_dau - first_dau + 1 ) < (daus_per_cyl)) DO

            j := j + 1;
            IF j > UPPERBOUND (p_flaw_duplication^) THEN
              EXIT /small_array_exit/;
            IFEND;

            p_flaw_duplication^[j].entry_initialized := TRUE;
            p_flaw_duplication^[j].cylinder := phys_adrs.cylinder;
            p_flaw_duplication^[j].track := phys_adrs.track;
            p_flaw_duplication^[j].track_specified := TRUE;
            p_flaw_duplication^[j].sector := phys_adrs.sector;
            p_flaw_duplication^[j].sector_specified := TRUE;

            first_dau := first_dau + 1;

            IF first_dau > last_dau THEN
              EXIT /build_flaws_for_entry/;
            IFEND;

            phys_adrs.cylinder := first_dau DIV daus_per_cyl;
            sector_offset_within_cylinder := (first_dau MOD daus_per_cyl)
                 * p_physical_attributes^[2].sectors_per_mau * p_physical_attributes^[4].maus_per_dau;
            phys_adrs.track := sector_offset_within_cylinder DIV p_physical_attributes^[3].sectors_per_track;
            phys_adrs.sector := sector_offset_within_cylinder MOD p_physical_attributes^[3].sectors_per_track;

          WHILEND /sector_flaw/;

{ Check if cylinder flaw.

          /cylinder_flaw/
          WHILE (last_dau - first_dau + 1 >= daus_per_cyl) DO

            j := j + 1;
            IF j > UPPERBOUND (p_flaw_duplication^) THEN
              EXIT /small_array_exit/;
            IFEND;

            p_flaw_duplication^[j].entry_initialized := TRUE;
            p_flaw_duplication^[j].cylinder := phys_adrs.cylinder;
            p_flaw_duplication^[j].track_specified := FALSE;
            p_flaw_duplication^[j].sector_specified := FALSE;

            first_dau := first_dau + daus_per_cyl;

            IF first_dau > last_dau THEN
              EXIT /build_flaws_for_entry/;
            IFEND;

            phys_adrs.cylinder := first_dau DIV daus_per_cyl;
            sector_offset_within_cylinder := (first_dau MOD daus_per_cyl)
               * p_physical_attributes^[2].sectors_per_mau * p_physical_attributes^[4].maus_per_dau;
            phys_adrs.track := sector_offset_within_cylinder DIV p_physical_attributes^[3].sectors_per_track;
            phys_adrs.sector := sector_offset_within_cylinder MOD p_physical_attributes^[3].sectors_per_track;

          WHILEND /cylinder_flaw/;

        WHILEND /build_flaws_for_entry/;

      FOREND /duplicate_flaws/;

      big_enough_array := TRUE;

    END /small_array_exit/;

  PROCEND duplicate_flaw_commands;

?? TITLE := '  get_device_information', EJECT ??
  PROCEDURE get_device_information (recorded_vsn: rmt$recorded_vsn;
    VAR p_physical_attributes: ^dmt$physical_device_attributes;
    VAR status: ost$status);

{   PURPOSE:
{     This procedure is called to get the physical attributes of the device ident-
{     ified by the volume's recorded_vsn needed to make calculations for a flaw
{     operation.

    VAR
      element_def: ^cmt$element_definition,
      lun: iot$logical_unit,
      product_id: cmt$product_identification;

    dmp$get_logical_unit_number (recorded_vsn, lun, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH element_def;

    cmp$pc_get_logical_unit (lun, element_def, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    product_id := element_def^.product_id;

    dmp$get_physical_attributes (product_id, p_physical_attributes, status);
  PROCEND get_device_information;
MODEND dmm$device_flaw_management;


*DECK DECK=DMM$DEVICE_MANAGER_SETUP EXPAND=TRUE
?? RIGHT := 110 ??
*copy OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header', EJECT ??
MODULE dmm$device_manager_setup;

{ PURPOSE:
{  The purpose of this module is to provide access to the system device.
{  The system device is always brought online, but will be initialized
{  during an installation deadstart.

?? PUSH (LISTEXT := ON) ??
?? TITLE := '  Common Decks', EJECT ??
*copyc cml$ms_volume_initialization
*copyc cmp$get_element_name_via_lun
*copyc cmp$get_unit_type
*copyc cmp$pc_get_logical_unit
*copyc cmt$logical_unit_attributes
*copyc cmt$product_identification
*copyc dmp$get_logical_attributes
*copyc dmp$get_physical_attributes
*copyc dmp$initialize_ms_volume
*copyc dmp$search_active_volume_table
*copyc dmp$volume_online
*copyc dmt$error_condition_codes
*copyc dmt$file_table_lock
*copyc dmt$keypoint_calls
*copyc dmt$logical_device_attributes
*copyc dmt$physical_device_attributes
*copyc dmv$active_volume_table
*copyc dsp$log_sys_msg_help
*copyc dst$log_ms_volume_init
*copyc iot$logical_unit
*copyc osc$processor_defined_registers
*copyc osk$keypoints
*copyc osp$set_status_abnormal
*copyc oss$job_fixed
*copyc oss$mainframe_wired
*copyc ost$hardware_subranges
*copyc ost$heap
*copyc ost$page_size
*copyc ost$status
*copyc osv$deadstart_phase
*copyc osv$mainframe_wired_heap
*copyc rmd$volume_declarations
?? POP ??
?? TITLE := '  Global Definitions', EJECT ??

  VAR
    dmv$retain_system_device_flaws: [STATIC, XDCL, #GATE] boolean := TRUE,

    dmv$system_device_lun: [STATIC, XDCL, #GATE] iot$logical_unit := 6,

    dmv$system_device_product_id: [STATIC, XDCL, #GATE] cmt$product_identification := ['  885', '$', '41'],

    dmv$system_device_recorded_vsn: [STATIC, XDCL, #GATE] rmt$recorded_vsn := 'VSN006';
?? TITLE := '  dmp$system_initialization', EJECT ??

  PROCEDURE [XDCL] dmp$system_initialization (VAR status: ost$status);

    VAR
      unit_type: cmt$unit_type,
      io_type: iot$unit_type,
      unit_class: cmt$unit_class,
      found: boolean,
      init_status_info: dmt$initialize_status_info,
      p_physical_attributes: ^dmt$physical_device_attributes,
      p_logical_attributes: ^dmt$logical_device_attributes,
      p_label_attributes: ^dmt$volume_label_attributes,
      access_code: ost$name,
      owner_id: ost$user_identification,
      search_key: dmt$avt_search_key,
      avt_index: dmt$active_volume_table_index,
      avt_entry_not_found: boolean;

    #INLINE ('keypoint', osk$entry, 0, dmk$system_initialization);

    status.normal := TRUE;

  /system_initialization/
    BEGIN
      ALLOCATE dmv$p_active_volume_table: [1 .. 1] IN osv$mainframe_wired_heap^;
      dmv$p_active_volume_table^ [1].entry_available := TRUE;
      dmv$p_active_volume_table^ [1].lock.status := ORD (dmc$unlocked);
      dmv$p_active_volume_table^ [1].logical_unit_number := 0;

      PUSH p_physical_attributes: [1 .. 7];
      p_physical_attributes^ [1].keyword := dmc$bytes_per_mau;
      p_physical_attributes^ [2].keyword := dmc$cylinders_per_device;
      p_physical_attributes^ [3].keyword := dmc$maus_per_cylinder;
      p_physical_attributes^ [4].keyword := dmc$maus_per_dau;
      p_physical_attributes^ [5].keyword := dmc$sectors_per_mau;
      p_physical_attributes^ [6].keyword := dmc$sectors_per_track;
      p_physical_attributes^ [7].keyword := dmc$flaw_map_locations;

      dmp$get_physical_attributes (dmv$system_device_product_id, p_physical_attributes, status);
      IF NOT status.normal THEN
        EXIT /system_initialization/;
      IFEND;

      IF (osv$deadstart_phase = osc$installation_deadstart) THEN

        PUSH p_label_attributes: [1 .. 3];
        p_label_attributes^ [1].keyword := dmc$label_access_code;
        p_label_attributes^ [1].access_code := dmc$default_vol_access_code;
        p_label_attributes^ [2].keyword := dmc$label_expiration_days;
        p_label_attributes^ [2].expiration_days := dmc$max_expiration_days;
        p_label_attributes^ [3].keyword := dmc$label_recorded_vsn;
        p_label_attributes^ [3].recorded_vsn := dmv$system_device_recorded_vsn;

        PUSH p_logical_attributes: [1 .. 3];
        p_logical_attributes^ [1].keyword := dmc$volume_dfl_entries;
        p_logical_attributes^ [2].keyword := dmc$volume_directory_entries;
        p_logical_attributes^ [3].keyword := dmc$logical_flaws;

        dmp$get_logical_attributes (dmv$system_device_product_id, p_logical_attributes, status);
        IF NOT status.normal THEN
          EXIT /system_initialization/;
        IFEND;

        cmp$get_unit_type (dmv$system_device_product_id, unit_type, io_type, unit_class, found);
        IF NOT found THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$reject_r1,
                'Unknown system device product identifier - dmp$system_initialization.', status);
          EXIT /system_initialization/;
        IFEND;

        access_code := dmc$default_vol_access_code;
        owner_id.family := '$SYSTEM';
        owner_id.user := '$SYSTEM';

        dmp$initialize_ms_volume (access_code, owner_id, unit_type, p_physical_attributes,
            p_logical_attributes, p_label_attributes, dmv$system_device_lun, TRUE,
            dmv$retain_system_device_flaws, init_status_info, status);
        IF NOT status.normal THEN
          EXIT /system_initialization/;
        IFEND;
      IFEND;

      dmp$volume_online (dmv$system_device_lun, p_physical_attributes, status);
      IF NOT status.normal THEN
        EXIT /system_initialization/;
      IFEND;

      search_key.value := dmc$search_avt_by_lun;
      search_key.logical_unit_number := dmv$system_device_lun;

      dmp$search_active_volume_table (search_key, avt_index, avt_entry_not_found);
      IF avt_entry_not_found THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_not_online, 'dmp$system_initialization',
              status);
        EXIT /system_initialization/;
      IFEND;

      dmv$system_device_recorded_vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;

      IF (osv$deadstart_phase = osc$installation_deadstart) THEN
        log_system_device_init;
      IFEND;

    END /system_initialization/;

    #INLINE ('keypoint', osk$exit, 0, dmk$system_initialization);

  PROCEND dmp$system_initialization;
?? TITLE := '  log_system_device_init', EJECT ??

  PROCEDURE log_system_device_init;

    VAR
      element_def: ^cmt$element_definition,
      logging_data: dst$log_ms_volume_init,
      logging_data_p: ^SEQ(*),
      status: ost$status;

    cmp$get_element_name_via_lun (dmv$system_device_lun, logging_data.element_name, status);
    IF status.normal THEN
      cmp$pc_get_logical_unit (dmv$system_device_lun, element_def, status);
    IFEND;

    IF status.normal THEN
      logging_data.recorded_vsn := dmv$system_device_recorded_vsn;
      IF element_def^.element_type = cmc$storage_device_element THEN
        logging_data.physical_unit_number := element_def^.storage_device.physical_unit_number;
      IFEND;
      logging_data_p := #SEQ(logging_data);
      dsp$log_sys_msg_help (cml$ms_volume_initialization, logging_data_p);
    IFEND;

  PROCEND log_system_device_init;


MODEND dmm$device_manager_setup;
*DECK DECK=DMM$DF_CLIENT_REQUESTS EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
MODULE dmm$df_client_requests;
?? TITLE := ' NOS/VE File Server: Client: df_client_requests ', EJECT ??
{  This module contains the device manager code to support the client side of the
{  file server.
{  This includes creating the system file table entry on the client for the server file.
{
?? NEWTITLE := '  Global Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
*copyc dfc$partially_rebuilt_fde_eoi
*copyc dfe$error_condition_codes
*copyc dft$served_family_table
*copyc dft$server_descriptor
*copyc dmt$create_client_sft_operation
*copyc dmt$disk_file_descriptor
*copyc dmt$error_condition_codes
*copyc dmt$file_attributes
*copyc dmt$file_location
*copyc dmt$file_share_history
*copyc dmt$global_file_name
*copyc dmt$keypoint_calls
*copyc dmt$segment_file_information
*copyc dft$server_file_output
*copyc gft$file_desc_entry_p
*copyc gft$system_file_identifier
*copyc mmc$null_shared_queue
*copyc mmt$rb_ring1_segment_request
*copyc osd$integer_limits
*copyc osk$keypoints
*copyc oss$mainframe_pageable
*copyc oss$mainframe_paged_literal
*copyc ost$status
*copyc pfd$permanent_file_attributes
*copyc rmd$volume_declarations
?? TITLE := '  XREF/INLINE Procedures', EJECT ??
*copyc dfp$assign_terminated_gfn
*copyc dfp$fetch_served_family_entry
*copyc dfp$get_served_file_desc_p
*copyc dmp$allocate_file_space_r1
*copyc dmp$clear_master_attach_lock
*copyc dmp$create_fd_entry
*copyc dmp$determine_queue_status
*copyc dmp$generate_gfn_hash
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$search_fdt_by_gfn
*copyc dmp$set_file_residence
*copyc dmp$set_file_table_locator
*copyc dmp$set_master_attach_lock
*copyc dpp$put_critical_message
*copyc gfp$get_locked_fde_p
*copyc gfp$unlock_fde_p
*copyc i#call_monitor
*copyc i#current_sequence_position
*copyc mmp$preset_conversion
*copyc mmp$issue_ring1_segment_request
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc pmp$cycle
*copyc pmp$delay
*copyc pmp$get_executing_task_gtid
*copyc syp$set_status_from_mtr_status
?? POP ??
?? TITLE := '  Global Variables ', EJECT ??
*copyc dfv$file_server_debug_enabled
*copyc dfv$served_family_table_root

*copyc dmv$idle_system
*copyc osv$page_size
*copyc osv$mainframe_wired_heap

  VAR
    dmv$modify_options: [STATIC, READ, oss$mainframe_paged_literal] pft$usage_selections :=
          $pft$usage_selections [pfc$shorten, pfc$append, pfc$modify];

?? TITLE := ' [XDCL, #GATE] dmp$create_client_sft ', EJECT ??
*copyc dmh$create_client_sft
  PROCEDURE [XDCL, #GATE] dmp$create_client_sft
    (    global_file_name: dmt$global_file_name;
         file_usage: pft$usage_selections;
         file_share_selections: pft$share_selections;
         operation: dmt$create_client_sft_operation;
         dm_parameters: dft$server_file_output;
         served_family_table_index: dft$served_family_table_index;
         server_mainframe_id: pmt$binary_mainframe_id;
     VAR system_file_id: gft$system_file_identifier;
     VAR status: ost$status);

    VAR
      dfd_p: ^dmt$disk_file_descriptor,
      existing_fde_entry_found: boolean,
      file_attributes_p: ^array [1 .. * ] of dmt$file_attribute,
      file_descriptor_entry_p: gft$file_desc_entry_p,
      file_locator: dmt$file_location,
      file_table_residence: gft$table_residence,
      local_status: ost$status,
      queue_status: gft$queue_status,
      rb: mmt$rb_ring1_segment_request,
      served_family_table_entry_p: ^dft$served_family_table_entry,
      server_descriptor_p: dft$server_descriptor_p,
      server_descriptor_r_pointer: ost$relative_pointer,
      transfer_unit_size: amt$file_byte_address;

    #KEYPOINT (osk$entry, 0, dmk$create_client_sft);
    #KEYPOINT (osk$data, global_file_name.sequence_number, 0);

    IF dmv$idle_system THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
            'system is idle - dmp$create_client_sft ', status);
      #KEYPOINT (osk$exit, 0, dmk$create_client_sft);
      RETURN;
    IFEND;

    status.normal := TRUE;

  /process_request/
    BEGIN
      file_table_residence := gfc$tr_system;
      dmp$set_file_table_locator (file_table_residence, file_locator, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;
      system_file_id.residence := file_table_residence;

      dmp$determine_queue_status (gfc$fk_job_permanent_file, file_usage, file_share_selections,
            queue_status, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      dmp$generate_gfn_hash (global_file_name, system_file_id.file_hash);

      dmp$set_master_attach_lock (system_file_id);

    /master_attach_lock_set/
      BEGIN

        dmp$search_fdt_by_gfn (file_table_residence, global_file_name, system_file_id.file_entry_index,
              existing_fde_entry_found);
        IF existing_fde_entry_found THEN
          gfp$get_locked_fde_p (system_file_id, file_descriptor_entry_p);

        /sft_entry_locked/
          BEGIN
            IF file_descriptor_entry_p^.global_file_name = global_file_name THEN
              IF file_descriptor_entry_p^.media <> gfc$fm_served_file THEN
                existing_fde_entry_found := FALSE;
                osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
                      'expecting SERVER FILE in dmp$create_client_sft ', status);
                EXIT /sft_entry_locked/;
              IFEND;

              dfp$get_served_file_desc_p (file_descriptor_entry_p, server_descriptor_p);
              IF server_descriptor_p^.header.purged THEN
                existing_fde_entry_found := FALSE;
                osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
                      'SERVER FILE purged/exists in dmp$create_client_sft ', status);
                EXIT /sft_entry_locked/;
              IFEND;

              existing_fde_entry_found := TRUE;
              dfp$fetch_served_family_entry (served_family_table_index,
                   served_family_table_entry_p, status);
              IF NOT status.normal THEN
                EXIT /sft_entry_locked/;
              IFEND;

              CASE server_descriptor_p^.header.file_state OF
              = dfc$terminated =
                { The lifetime has changed since the original attach,
                {  because the server has terminated and become re-active.
                { Change the global_file_name of this entry to an arbirtary
                { value, and create a new sft entry under the correct
                { global file name and lifetime.
                { This assumes that all old references
                { are done via sfid and not global file name.
                { Advance usage count so that this old system file table entry
                { is not removed.  This covers end cases in return.
                { The only negative impact is the pages for this file will
                { never be deleted by return.
                file_descriptor_entry_p^.attach_count := file_descriptor_entry_p^.attach_count + 10;
                IF operation = dmc$complete_job_recovery THEN
                    osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
                      ' Terminated server file - Recovery not possible ', status);
                   EXIT /sft_entry_locked/;
                IFEND;
                dfp$assign_terminated_gfn (
                    file_descriptor_entry_p^.global_file_name,
                    file_descriptor_entry_p^.global_file_name);
                existing_fde_entry_found := FALSE;
                EXIT /sft_entry_locked/;

              = dfc$awaiting_recovery =
                { Despite the fact that the system file table entry was found
                { it is probably not initialized. Complete initialization of
                { the entry, and advance the state to active.
                IF (operation = dmc$complete_job_recovery) OR
                  (operation = dmc$attach_or_create)  THEN
                  { Complete initialization of the file descriptor entry.
                  mmp$preset_conversion (dm_parameters.preset_value, file_descriptor_entry_p^.preset_value);
                  file_descriptor_entry_p^.file_limit := dm_parameters.file_limit;
                  IF file_descriptor_entry_p^.eoi_byte_address = dfc$partially_rebuilt_fde_eoi THEN
                    { Kludge value specified in pfm$r2_df_client_requests
                    file_descriptor_entry_p^.eoi_byte_address := dm_parameters.eoi_byte_address;
                  IFEND;
                  server_descriptor_p^.header.bytes_per_allocation := dm_parameters.bytes_per_allocation;
                  file_descriptor_entry_p^.queue_status := queue_status;

                 { Complete initialization of the server descriptor
                  server_descriptor_p^.header.server_lifetime :=
                      served_family_table_entry_p^.server_lifetime;
                  server_descriptor_p^.header.file_state := dfc$active;
                  server_descriptor_p^.header.total_allocated_length := dm_parameters.total_allocated_length;
                  server_descriptor_p^.header.remote_sfid := dm_parameters.remote_sfid;
                  {  server_descriptor_p^.header.allowed_other_mainframe_writer :=
                  {        dm_parameters.allowed_other_mainframe_writer;
                  server_descriptor_p^.header.allocation_info.allocation_needed_on_server := FALSE;
                  server_descriptor_p^.header.allocation_info.invalid_data := 0;
                  server_descriptor_p^.header.requested_transfer_size :=
                       dm_parameters.requested_transfer_size;
                  server_descriptor_p^.header.read_write_count := 0;
{?}               server_descriptor_p^.header.highest_offset_allocated := dm_parameters.
                       total_allocated_length;

{ Complete adjustment of the file descriptor entry for this served file

                  IF served_family_table_entry_p^.p_queue_interface_table^.maximum_data_bytes <
                        file_descriptor_entry_p^.allocation_unit_size THEN
                    file_descriptor_entry_p^.allocation_unit_size := served_family_table_entry_p^.
                          p_queue_interface_table^.maximum_data_bytes;
                  IFEND;
                IFEND;
              ELSE
                { Active.
              CASEND;

              IF server_descriptor_p^.header.remote_sfid <> dm_parameters.remote_sfid THEN
                { The client and server mainframes got out of sync.
                { This could happen as a result of a terminated server file
                { because the usage count on the client is updated, but the count
                { on the server was not, and in fact the file on the server may have
                { been removed from the system file table and re-attached.
                server_descriptor_p^.header.remote_sfid := dm_parameters.remote_sfid;
              IFEND;
              IF file_descriptor_entry_p^.attach_count = 0 THEN
                file_descriptor_entry_p^.queue_status := queue_status;
                IF dm_parameters.shared_queue <> mmc$null_shared_queue THEN
                  file_descriptor_entry_p^.queue_ordinal :=
                        mmc$pq_shared_last_sys + dm_parameters.shared_queue;
                ELSE
                  file_descriptor_entry_p^.queue_ordinal := mmc$null_shared_queue;
                IFEND;
              IFEND;
              IF (operation <> dmc$complete_job_recovery) OR
                   (file_descriptor_entry_p^.attach_count = 0) THEN
                 file_descriptor_entry_p^.attach_count := file_descriptor_entry_p^.attach_count + 1;
              IFEND;
              IF (file_descriptor_entry_p^.queue_status = gfc$qs_job_shared) AND
                    (file_descriptor_entry_p^.attach_count = 2) THEN
                rb.reqcode := syc$rc_ring1_segment_request;
                rb.request := mmc$sr1_remove_job_shared_pages;
                rb.system_file_id := system_file_id;
                rb.server_file := TRUE;
                rb.status.normal := TRUE;
                mmp$issue_ring1_segment_request (rb);
              IFEND;
              IF operation <> dmc$begin_job_recovery THEN
                IF ((dmv$modify_options * file_usage) <> $pft$usage_selections []) THEN
                  file_descriptor_entry_p^.attached_in_write_count := file_descriptor_entry_p^.
                        attached_in_write_count + 1;
                IFEND;
              IFEND;
            ELSE
              existing_fde_entry_found := FALSE;
            IFEND;

          END /sft_entry_locked/;
          gfp$unlock_fde_p (file_descriptor_entry_p);

          IF NOT status.normal THEN
            EXIT /master_attach_lock_set/;
          IFEND;

        IFEND;

        IF NOT existing_fde_entry_found THEN
           IF operation = dmc$complete_job_recovery THEN
              osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
                    'Expecting file to already exist when completing job recovery ' CAT
                    ' in dmp$create_client_sft ', status);
            EXIT /master_attach_lock_set/;
          IFEND;

{         create new file table entries
          PUSH file_attributes_p: [1 .. 10];
          file_attributes_p^ [1].keyword := dmc$file_hash;
          file_attributes_p^ [1].file_hash := system_file_id.file_hash;
          file_attributes_p^ [2].keyword := dmc$file_kind;
          file_attributes_p^ [2].file_kind := gfc$fk_job_permanent_file;
          file_attributes_p^ [3].keyword := dmc$preset_value;
          file_attributes_p^ [3].preset_value := dm_parameters.preset_value;
          file_attributes_p^ [4].keyword := dmc$clear_space;
{!}       file_attributes_p^ [4].required := FALSE;
          file_attributes_p^ [5].keyword := dmc$file_limit;
          file_attributes_p^ [5].limit := dm_parameters.file_limit;
          file_attributes_p^ [6].keyword := dmc$global_file_name;
          file_attributes_p^ [6].global_file_name := global_file_name;
          file_attributes_p^ [7].keyword := dmc$locked_file;
          file_attributes_p^ [7].file_lock.required := FALSE;
          file_attributes_p^ [7].file_lock.read_lock_count := 0;
          file_attributes_p^ [7].file_lock.write_lock := dmc$no_write_lock;
          file_attributes_p^ [8].keyword := dmc$write_mode;
          file_attributes_p^ [8].attached_in_write_mode := ((dmv$modify_options * file_usage) <>
                $pft$usage_selections []);
          file_attributes_p^ [9].keyword := dmc$queue_status;
          file_attributes_p^ [9].queue_status := queue_status;
          file_attributes_p^ [10].keyword := dmc$eoi_byte_address;
          file_attributes_p^ [10].eoi_address := dm_parameters.eoi_byte_address;

          dmp$create_fd_entry (file_attributes_p, system_file_id, status);
          IF NOT status.normal THEN
            EXIT /master_attach_lock_set/;
          IFEND;

        /file_descriptor_created/
          BEGIN
            gfp$get_locked_fde_p (system_file_id, file_descriptor_entry_p);

            file_descriptor_entry_p^.attach_count := 1;
            IF dm_parameters.shared_queue <> mmc$null_shared_queue THEN
              file_descriptor_entry_p^.queue_ordinal := mmc$pq_shared_last_sys + dm_parameters.shared_queue;
            ELSE
              file_descriptor_entry_p^.queue_ordinal := mmc$null_shared_queue;
            IFEND;

            dmp$clear_master_attach_lock (system_file_id);

            build_server_descriptor (operation,
                  dm_parameters, served_family_table_index, server_mainframe_id,
                  dfv$served_family_table_root.p_family_list_pointer_array^ [
                  served_family_table_index.pointers_index].p_served_family_list^ [
                  served_family_table_index.family_list_index].server_lifetime,
                  server_descriptor_r_pointer);

            dmp$get_disk_file_descriptor_p (file_descriptor_entry_p, dfd_p);
            file_descriptor_entry_p^.served_file_descriptor_p := server_descriptor_r_pointer;
            file_descriptor_entry_p^.media := gfc$fm_served_file;
            dmp$set_file_table_locator (system_file_id.residence, file_locator, status);
            FREE dfd_p IN file_locator^;
            dfp$get_served_file_desc_p (file_descriptor_entry_p, server_descriptor_p);
            server_descriptor_p^.header.bytes_per_allocation := dm_parameters.bytes_per_allocation;

{ Complete adjustment of the file descriptor entry for this served file IF the server is active.

            IF dfv$served_family_table_root.p_family_list_pointer_array^ [
                  served_family_table_index.pointers_index].p_served_family_list^ [
                  served_family_table_index.family_list_index].server_state = dfc$active THEN
              transfer_unit_size := dfv$served_family_table_root.p_family_list_pointer_array^ [
                    served_family_table_index.pointers_index].p_served_family_list^ [
                    served_family_table_index.family_list_index].p_queue_interface_table^.maximum_data_bytes;
              IF transfer_unit_size < file_descriptor_entry_p^.allocation_unit_size THEN
                file_descriptor_entry_p^.allocation_unit_size := transfer_unit_size;
              IFEND;
            IFEND;
            gfp$unlock_fde_p (file_descriptor_entry_p);
            EXIT /process_request/; { <-------------------<<< NORMAL EXIT <---------------<<< }

          END /file_descriptor_created/;

        IFEND;

      END /master_attach_lock_set/;

      dmp$clear_master_attach_lock (system_file_id);

    END /process_request/;
    #KEYPOINT (osk$exit, 0, dmk$create_client_sft);


  PROCEND dmp$create_client_sft;

?? TITLE := ' [XDCL, #GATE] dmp$fixup_client_file_length ', EJECT ??
{
{   The purpose of this routine is to fixup a file on the client following
{ a failure of the server mainframe.  This means that the eoi is updated
{ on the client with any pages written on the client but that did not make
{ it to the server.  Any pages on the client not yet on the server are
{ allocated.
  PROCEDURE [XDCL, #GATE] dmp$fixup_client_file_length
    (    sfid: gft$system_file_identifier;
     VAR status: ost$status);

    VAR
      bytes_to_allocate: amt$file_byte_address,
      current_allocated_length: amt$file_byte_address,
      fde_p: gft$file_desc_entry_p,
      message: string (80),
      message_length: integer,
      next_page: amt$file_byte_address,
      server_descriptor_p: dft$server_descriptor_p,
      rb: mmt$rb_ring1_segment_request;

    gfp$get_locked_fde_p (sfid, fde_p);
    IF fde_p^.attached_in_write_count = 0 THEN
      gfp$unlock_fde_p (fde_p);
      RETURN;
    IFEND;
    dfp$get_served_file_desc_p (fde_p, server_descriptor_p);

    rb.status.normal := TRUE;
    rb.reqcode := syc$rc_ring1_segment_request;
    rb.request := mmc$sr1_get_highest_offset;
    rb.file_sfid := sfid;
    i#call_monitor (#LOC (rb), #SIZE (rb));
    syp$set_status_from_mtr_status (rb.status, status);
    IF NOT status.normal THEN
      gfp$unlock_fde_p (fde_p);
      RETURN;
    IFEND;

    current_allocated_length := server_descriptor_p^.header.total_allocated_length;
    IF dfv$file_server_debug_enabled THEN
      STRINGREP (message, message_length, 'SFID', sfid.file_entry_index:#(16), '(16): eoi',
            fde_p^.eoi_byte_address:#(16), '(16), high', rb.highest_offset:#(16), '(16), length',
            current_allocated_length:#(16), '(16)');
      dpp$put_critical_message (message (1, message_length), status);
    IFEND;

    next_page := rb.highest_offset + osv$page_size;
    IF (rb.highest_offset >= fde_p^.eoi_byte_address) THEN
      fde_p^.eoi_byte_address := next_page;
    IFEND;

    gfp$unlock_fde_p (fde_p);

  /allocate_required_bytes/
    WHILE (next_page > current_allocated_length) DO
      bytes_to_allocate := next_page - current_allocated_length;
      IF dfv$file_server_debug_enabled THEN
        STRINGREP (message, message_length, ' Fixup allocate cal, bytes ', sfid.file_entry_index,
              current_allocated_length, bytes_to_allocate);
        dpp$put_critical_message (message (1, message_length), status);
      IFEND;
      dmp$allocate_file_space_r1 (sfid, current_allocated_length, bytes_to_allocate, { chapter_number } 0,
            osc$wait, sfc$no_limit, status);
      #SPOIL (server_descriptor_p^.header.total_allocated_length);
      current_allocated_length := server_descriptor_p^.header.total_allocated_length;
      IF (next_page > current_allocated_length) THEN
        pmp$delay (1000, status);
      IFEND;
    WHILEND /allocate_required_bytes/;

  PROCEND dmp$fixup_client_file_length;

?? TITLE := ' [XDCL, #GATE] dmp$replace_client_sft ', EJECT ??
{
{   The purpose of this routine is to replace the old client SFT entry
{ with a new client SFT entry when the data for an attached served file
{ has been recreated as the result of an exception condition.

  PROCEDURE [XDCL, #GATE] dmp$replace_client_sft
    (    old_global_file_name: dmt$global_file_name;
         new_global_file_name: dmt$global_file_name;
         new_remote_sfid: gft$system_file_identifier;
     VAR new_client_sfid: gft$system_file_identifier;
     VAR status: ost$status);

    VAR
      file_attributes_p: ^array [1 .. * ] of dmt$file_attribute,
      file_locator: dmt$file_location,
      new_fde_p: gft$file_desc_entry_p,
      new_server_descriptor_p: dft$server_descriptor_p,
      old_client_sfid: gft$system_file_identifier,
      old_fde_entry_found: boolean,
      old_fde_p: gft$file_desc_entry_p;

    dmp$set_file_table_locator (gfc$tr_system, file_locator, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    old_client_sfid.residence := gfc$tr_system;
    dmp$generate_gfn_hash (old_global_file_name, old_client_sfid.file_hash);

    dmp$search_fdt_by_gfn (gfc$tr_system, old_global_file_name, old_client_sfid.file_entry_index,
          old_fde_entry_found);
    IF NOT old_fde_entry_found THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
            'expecting client file to exist in dmp$replace_client_sft', status);
      RETURN;
    IFEND;

    gfp$get_locked_fde_p (old_client_sfid, old_fde_p);
  /old_fde_locked/
    BEGIN
      IF old_fde_p^.media <> gfc$fm_served_file THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
              'expecting SERVER FILE in dmp$replace_client_sft', status);
        EXIT /old_fde_locked/;
      IFEND;
      new_client_sfid.residence := gfc$tr_system;
      dmp$generate_gfn_hash (new_global_file_name, new_client_sfid.file_hash);

      dmp$set_master_attach_lock (new_client_sfid);
    /master_attach_lock_set/
      BEGIN
        PUSH file_attributes_p: [1 .. 9];
        file_attributes_p^ [1].keyword := dmc$file_hash;
        file_attributes_p^ [1].file_hash := new_client_sfid.file_hash;
        file_attributes_p^ [2].keyword := dmc$file_kind;
        file_attributes_p^ [2].file_kind := gfc$fk_job_permanent_file;
        file_attributes_p^ [3].keyword := dmc$clear_space;
        file_attributes_p^ [3].required := FALSE;
        file_attributes_p^ [4].keyword := dmc$file_limit;
        file_attributes_p^ [4].limit := old_fde_p^.file_limit;
        file_attributes_p^ [5].keyword := dmc$global_file_name;
        file_attributes_p^ [5].global_file_name := new_global_file_name;
        file_attributes_p^ [6].keyword := dmc$locked_file;
        file_attributes_p^ [6].file_lock.required := FALSE;
        file_attributes_p^ [6].file_lock.read_lock_count := 0;
        file_attributes_p^ [6].file_lock.write_lock := dmc$no_write_lock;
        file_attributes_p^ [7].keyword := dmc$write_mode;
        file_attributes_p^ [7].attached_in_write_mode := TRUE;
        file_attributes_p^ [8].keyword := dmc$queue_status;
        file_attributes_p^ [8].queue_status := old_fde_p^.queue_status;
        file_attributes_p^ [9].keyword := dmc$eoi_byte_address;
        file_attributes_p^ [9].eoi_address := old_fde_p^.eoi_byte_address;

        dmp$create_fd_entry (file_attributes_p, new_client_sfid, status);
        IF NOT status.normal THEN
          EXIT /master_attach_lock_set/;
        IFEND;

        gfp$get_locked_fde_p (new_client_sfid, new_fde_p);

        new_fde_p^.job_lock := old_fde_p^.job_lock;
        new_fde_p^.monitor_lock := old_fde_p^.monitor_lock;
        new_fde_p^.flags := old_fde_p^.flags;
        new_fde_p^.attach_count := old_fde_p^.attach_count;
        new_fde_p^.open_count := old_fde_p^.open_count;
        new_fde_p^.segment_lock := old_fde_p^.segment_lock;
        new_fde_p^.asti := old_fde_p^.asti;
        new_fde_p^.eoi_state := old_fde_p^.eoi_state;
        new_fde_p^.allocation_unit_size := old_fde_p^.allocation_unit_size;
        new_fde_p^.transfer_unit_size := old_fde_p^.transfer_unit_size;
        new_fde_p^.queue_ordinal := old_fde_p^.queue_ordinal;
        new_fde_p^.preset_value := old_fde_p^.preset_value;
        new_fde_p^.time_last_modified := old_fde_p^.time_last_modified;
        new_fde_p^.last_segment_number := old_fde_p^.last_segment_number;
        new_fde_p^.global_task_id := old_fde_p^.global_task_id;
        new_fde_p^.stack_for_ring := old_fde_p^.stack_for_ring;
        new_fde_p^.media := old_fde_p^.media;
        new_fde_p^.served_file_descriptor_p := old_fde_p^.served_file_descriptor_p;

        dfp$get_served_file_desc_p (new_fde_p, new_server_descriptor_p);
        new_server_descriptor_p^.header.remote_sfid := new_remote_sfid;

        gfp$unlock_fde_p (new_fde_p);

      END /master_attach_lock_set/;
      dmp$clear_master_attach_lock (new_client_sfid);

    END /old_fde_locked/;
    gfp$unlock_fde_p (old_fde_p);

  PROCEND dmp$replace_client_sft;

?? TITLE := ' [XDCL, #GATE] dmp$set_file_state ', EJECT ??
{ Warning.
{ This only sets the state to terminated if there is only one user.
{  This procedure executes on the client mainframe and is used to mark
{  a server file as terminated.

  PROCEDURE [XDCL, #GATE] dmp$set_file_state
    (    global_file_name: dmt$global_file_name;
         file_state: dft$server_state;
     VAR status: ost$status);

    VAR
      existing_fde_entry_found: boolean,
      file_descriptor_entry_p: gft$file_desc_entry_p,
      file_locator: dmt$file_location,
      file_table_residence: gft$table_residence,
      local_status: ost$status,
      server_descriptor_p: dft$server_descriptor_p,
      system_file_id: gft$system_file_identifier;

    status.normal := TRUE;
    file_table_residence := gfc$tr_system;
    dmp$set_file_table_locator (file_table_residence, file_locator, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    system_file_id.residence := file_table_residence;

    dmp$generate_gfn_hash (global_file_name, system_file_id.file_hash);

    dmp$search_fdt_by_gfn (file_table_residence, global_file_name, system_file_id.file_entry_index,
          existing_fde_entry_found);
    IF existing_fde_entry_found THEN
      gfp$get_locked_fde_p (system_file_id, file_descriptor_entry_p);

      IF file_descriptor_entry_p^.global_file_name = global_file_name THEN
        IF file_descriptor_entry_p^.media = gfc$fm_served_file THEN
          dfp$get_served_file_desc_p (file_descriptor_entry_p, server_descriptor_p);
          IF NOT server_descriptor_p^.header.purged THEN
            IF (file_state = dfc$terminated) THEN
              IF (file_descriptor_entry_p^.attach_count <= 1) THEN

{ We do not want to change the state to terminated if there are other users of the file.  Depend upon the job
{ setting the sdtx access state to terminate access, and also to set the lifetime in the
{ attached_permanent_file_id to indicate that the file is terminated.

                server_descriptor_p^.header.file_state := file_state;
              IFEND;

{ Advance usage count so that this old system file table entry is not removed.  This covers end cases in
{ RETURN.

              file_descriptor_entry_p^.attach_count := file_descriptor_entry_p^.attach_count + 10;
            ELSE { State other than terminated
              server_descriptor_p^.header.file_state := file_state;
            IFEND;
          ELSE
            osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
                  'SERVER FILE purged/exists in dmp$set_file_state ', status);
          IFEND;
        ELSE
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_file,
                'expecting SERVER FILE in dmp$set_file_state ', status);
        IFEND;
      IFEND;
      gfp$unlock_fde_p (file_descriptor_entry_p);
    IFEND;

  PROCEND dmp$set_file_state;
?? TITLE := ' [XDCL, #GATE] dmp$terminate_server_file_list ', EJECT ??
{
{  This  client procedure marks a list of server files as terminated.
{ This procedure returns a count of the number of files found that were
{ terminated as well as a count of the number of files that could not be
{ terminated.
{ There should be no pages to remove when this request is called.
{
  PROCEDURE [XDCL, #GATE] dmp$terminate_server_file_list
    (    global_file_name_list: array [1 .. * ] of dmt$global_file_name;
     VAR files_terminated: ost$non_negative_integers;
     VAR files_not_terminated: ost$non_negative_integers);

    VAR
      existing_fde_entry_found: boolean,
      file: gft$file_descriptor_index,
      p_file_descriptor_entry: gft$file_desc_entry_p,
      p_server_descriptor: dmt$p_server_descriptor,
      status: ost$status,
      system_file_id: gft$system_file_identifier;

    status.normal := TRUE;
    files_terminated := 0;
    files_not_terminated := 0;
    system_file_id.residence := gfc$tr_system;

  /terminate_all_files/
    FOR file := 1 TO UPPERBOUND (global_file_name_list) DO

      dmp$generate_gfn_hash (global_file_name_list [file], system_file_id.file_hash);

      dmp$search_fdt_by_gfn (gfc$tr_system, global_file_name_list [file],
            system_file_id.file_entry_index, existing_fde_entry_found);
      IF existing_fde_entry_found THEN
        gfp$get_locked_fde_p (system_file_id, p_file_descriptor_entry);
        IF (p_file_descriptor_entry^.global_file_name =
              global_file_name_list [file]) AND (p_file_descriptor_entry^.media = gfc$fm_served_file) THEN
          dfp$get_served_file_desc_p (p_file_descriptor_entry, p_server_descriptor);
          IF NOT p_server_descriptor^.header.purged THEN
            p_server_descriptor^.header.file_state := dfc$terminated;
            files_terminated := files_terminated + 1;
          ELSE
            files_not_terminated := files_not_terminated + 1;
          IFEND;
        ELSE
          files_not_terminated := files_not_terminated + 1;
        IFEND;
        gfp$unlock_fde_p (p_file_descriptor_entry);
      ELSE
        files_not_terminated := files_not_terminated + 1;
      IFEND;
    FOREND /terminate_all_files/;
  PROCEND dmp$terminate_server_file_list;
?? TITLE := ' [INLINE] build_server_descriptor ', EJECT ??

  PROCEDURE [INLINE] build_server_descriptor
    (    operation: dmt$create_client_sft_operation;
         dm_parameters: dft$server_file_output;
         served_family_table_index: dft$served_family_table_index;
         server_mainframe_id: pmt$binary_mainframe_id;
         server_lifetime: dft$server_lifetime;
     VAR server_descriptor_r_pointer: ost$relative_pointer);

    VAR
      server_descriptor_p: dft$server_descriptor_p;

    ALLOCATE server_descriptor_p IN osv$mainframe_wired_heap^;
    IF operation = dmc$begin_job_recovery THEN
      server_descriptor_p^.header.file_state := dfc$awaiting_recovery;
    ELSE
      server_descriptor_p^.header.file_state := dfc$active;
      server_descriptor_p^.header.total_allocated_length := dm_parameters.total_allocated_length;
      server_descriptor_p^.header.remote_sfid := dm_parameters.remote_sfid;
      {  server_descriptor_p^.header.allowed_other_mainframe_writer :=
      {        dm_parameters.allowed_other_mainframe_writer;
      server_descriptor_p^.header.allocation_info.allocation_needed_on_server := FALSE;
      server_descriptor_p^.header.allocation_info.invalid_data := 0;
      server_descriptor_p^.header.requested_transfer_size := dm_parameters.requested_transfer_size;
    IFEND;
    server_descriptor_p^.header.read_write_count := 0;
    server_descriptor_p^.header.purged := FALSE;
{?} server_descriptor_p^.header.highest_offset_allocated := dm_parameters.total_allocated_length;
    server_descriptor_p^.header.server_mainframe_id := server_mainframe_id;
    server_descriptor_p^.header.server_lifetime := server_lifetime;
    server_descriptor_p^.header.served_family_table_index := served_family_table_index;

    server_descriptor_r_pointer := #OFFSET (server_descriptor_p);

  PROCEND build_server_descriptor;
?? TITLE := ' remove_file_pages ', EJECT ??
  PROCEDURE remove_files_pages
    (    system_file_id: dmt$system_file_id;
     VAR status: ost$status);

    VAR
      p_rb_ring1_segment_request: ^mmt$rb_ring1_segment_request;

    PUSH p_rb_ring1_segment_request;
    p_rb_ring1_segment_request^.reqcode := syc$rc_ring1_segment_request;
    p_rb_ring1_segment_request^.sfid := system_file_id;
    p_rb_ring1_segment_request^.wait_for_io_complete := FALSE;
    p_rb_ring1_segment_request^.status.normal := TRUE;
    p_rb_ring1_segment_request^.request := mmc$sr1_delete_job_seg_by_sfid;
    mmp$issue_ring1_segment_request (p_rb_ring1_segment_request^);
    syp$set_status_from_mtr_status (p_rb_ring1_segment_request^.status, status);
  PROCEND remove_files_pages;
?? OLDTITLE, OLDTITLE ??
MODEND dmm$df_client_requests;
*DECK DECK=DMM$DF_SERVER_REQUESTS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? TITLE := 'NOS/VE File Server: Server: df_server_requests ', EJECT ??
MODULE dmm$df_server_requests;
{
{  This module contains the device manager code to support the server side of the
{  file server.
{  All that is required on the server side is code required to extract
{  information from the system file table which is needed on the client mainframe.
{  The system file table on the server is build through the normal attach
{  process and contains no indication that the file is being used by a
{  client mainframe.
{
?? NEWTITLE := '  Global Declarations ', EJECT ??
*copyc dmp$allocate_file_space_r1
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$preset_conversion
*copyc dmp$reallocate_file_space
*copyc dmp$validate_sfid_with_gfn
*copyc gfp$get_eoi_from_fde
*copyc gfp$verify_get_fde_p
*copyc syp$core_hang_if_system_jrt_set
*copyc syp$set_status_from_mtr_status
?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_parameters
*copyc dft$server_file_output
*copyc dmt$df_allocate_file_space
*copyc dmt$df_reallocate_file_space
*copyc dmt$df_set_eoi
*copyc dmt$error_condition_codes
*copyc dmt$keypoints
*copyc dmt$system_file_id
*copyc gft$file_desc_entry_p
*copyc gft$system_file_identifier
*copyc i#call_monitor
*copyc jmt$active_job_list
*copyc mmt$rb_set_get_segment_length
*copyc ost$status
*copyc pft$server_file_output
*copyc sft$file_space_limit_kind
?? POP ??
?? TITLE := '  [XDCL, #GATE]  dmp$r1_df_server_allocate_space', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$r1_df_server_allocate_space
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    CONST
      null_ajl_ordinal = jmc$max_ajl_ord;

    VAR
      dfd_p: ^dmt$disk_file_descriptor,
      fde_p: gft$file_desc_entry_p,
      p_input_parameters: ^dmt$df_allocate_file_space_inp,
      p_output_parameters: ^dmt$df_allocate_file_space_inp,
      sfid_valid: boolean;

    send_parameters_size := 0;
    send_data_size := 0;
    NEXT p_input_parameters IN p_param_received_from_client;

    gfp$verify_get_fde_p (p_input_parameters^.sfid, fde_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$allocate_file_space_r1 (p_input_parameters^.sfid, p_input_parameters^.byte_offset,
          p_input_parameters^.bytes_to_allocate, 0, osc$nowait, sfc$no_limit, status);
    syp$core_hang_if_system_jrt_set (dfc$tjr_server_allocate_space);
    RESET p_send_to_client_params;
    NEXT p_output_parameters IN p_send_to_client_params;
    send_parameters_size := #SIZE (p_output_parameters^);

    p_output_parameters^.byte_offset := p_input_parameters^.byte_offset;
    p_output_parameters^.bytes_to_allocate := p_input_parameters^.bytes_to_allocate;
    IF status.normal THEN
      dmp$get_disk_file_descriptor_p (fde_p, dfd_p);
      p_output_parameters^.total_allocated_length := dfd_p^.highest_offset_allocated;
    IFEND;

  PROCEND dmp$r1_df_server_allocate_space;

?? TITLE := '  [XDCL, #GATE]  dfp$reallocate_filespace_server', EJECT ??

  PROCEDURE [XDCL, #GATE] dfp$reallocate_filespace_server
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_input_parameters: ^dmt$df_reallocate_filespace_inp;

    send_parameters_size := 0;
    send_data_size := 0;
    NEXT p_input_parameters IN p_param_received_from_client;
    dmp$validate_sfid_with_gfn (p_input_parameters^.sfid, p_input_parameters^.global_file_name, status);
    IF status.normal THEN
      dmp$reallocate_file_space (p_input_parameters^.sfid, TRUE, status);
    IFEND;
    syp$core_hang_if_system_jrt_set (dfc$tjr_server_reallocate_space);

  PROCEND dfp$reallocate_filespace_server;

?? TITLE := '  [XDCL, #GATE]  dmp$df_server_set_eoi', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$df_server_set_eoi
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_input_parameters: ^dmt$df_set_eoi_inp,
      request_block: mmt$rb_set_get_segment_length;

    send_parameters_size := 0;
    send_data_size := 0;
    NEXT p_input_parameters IN p_param_received_from_client;
    gfp$verify_get_fde_p (p_input_parameters^.sfid, request_block.fde_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    request_block.request_code := syc$rc_set_get_segment_length;
    request_block.subfunction_code := mmc$sf_set_segment_length_fde_p;
    request_block.segment_length := p_input_parameters^.segment_length;

    i#call_monitor (#LOC (request_block), #SIZE (request_block));

    syp$core_hang_if_system_jrt_set (dfc$tjr_server_set_eoi);

  PROCEND dmp$df_server_set_eoi;

?? TITLE := '  [XDCL, #GATE] dmp$fetch_server_sft_info ', EJECT ??
*copyc dmh$fetch_server_sft_info

  PROCEDURE [XDCL, #GATE] dmp$fetch_server_sft_info
    (    system_file_id: gft$system_file_identifier;
     VAR info: dft$server_file_output;
     VAR p_file_server_buffers: pft$p_file_server_buffers;
     VAR status: ost$status);

    VAR
      dfd_p: ^dmt$disk_file_descriptor,
      fde_p: gft$file_desc_entry_p,
      sfid_valid: boolean;

    gfp$verify_get_fde_p (system_file_id, fde_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dmp$get_disk_file_descriptor_p (fde_p, dfd_p);

    info.bytes_per_allocation:= dfd_p^.bytes_per_allocation;
    info.eoi_byte_address := gfp$get_eoi_from_fde (fde_p);
    info.file_limit := fde_p^.file_limit;
    info.preset_value := dmp$preset_conversion (fde_p^.preset_value);
    info.remote_sfid := system_file_id;
    info.requested_transfer_size := dfd_p^.requested_transfer_size;

    IF fde_p^.queue_ordinal > mmc$pq_shared_last_sys THEN
      info.shared_queue := fde_p^.queue_ordinal - mmc$pq_shared_last_sys;
    ELSE
      info.shared_queue := mmc$null_shared_queue;
    IFEND;

    info.total_allocated_length := dfd_p^.highest_offset_allocated;

  PROCEND dmp$fetch_server_sft_info;
?? OLDTITLE, OLDTITLE ??
MODEND dmm$df_server_requests;
*DECK DECK=DMM$DISPLAY_DEVICE_FILES_R3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Device Management' ??
MODULE dmm$display_device_files_r3;

{
{ PURPOSE:
{
{  The purpose of this module is to display information from tables contained
{  in device management owned device files.  This includes the Device
{  Allocation Table (DAT), Device File List (DFL), Volume Directory, Volume
{  Label, Device Log, and Login Table.


?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc dmt$device_file_list_index
*copyc dmt$device_file_stored_fmd
*copyc dmt$directory_index
*copyc dmt$disk_file_descriptor
*copyc dmt$error_condition_codes
*copyc dmt$file_allocation_table
*copyc dmt$file_medium_descriptor
*copyc dmt$ms_device_allocation_table
*copyc dmt$ms_device_file_list_entry
*copyc dmt$ms_volume_directory
*copyc dmt$ms_volume_label
*copyc dmt$stored_ms_fmd_header
*copyc gft$file_desc_entry_p
*copyc osd$integer_limits
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
?? EJECT ??
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc dmp$analyze_dat_position
*copyc dmp$change_dfl_damage
*copyc dmp$change_sft_damage_detection
*copyc dmp$change_sft_file_damaged
*copyc dmp$close_dat_r3
*copyc dmp$close_dfl_r3
*copyc dmp$close_directory_r3
*copyc dmp$close_label_r3
*copyc dmp$close_log_r3
*copyc dmp$close_login_table_r3
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_fmd_by_index
*copyc dmp$open_dat_r3
*copyc dmp$open_dfl_r3
*copyc dmp$open_directory_r3
*copyc dmp$open_label_r3
*copyc dmp$open_log_r3
*copyc dmp$open_login_table_r3
*copyc dmp$utility_flush_logs
*copyc dmp$reassign_file
*copyc gfp$get_fde_p
*copyc i#move
*copyc mmp$get_sdtx_entry_p
*copyc mmp$get_segment_length
*copyc mmp$mfh_for_segment_manager
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pmp$convert_binary_unique_name
*copyc pmp$find_executing_task_xcb
*copyc pmp$get_legible_date_time
?? POP ??

    CONST
      contiguous_dau_range_array_size = 7;

    TYPE
      contiguous_dau_info = record
        low: integer,
        high: integer,
        occurrences: integer,
        total_daus: integer,
      recend;

?? TITLE := '  dmp$change_file_damage_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$change_file_damage_r3
    (    p: ^cell;
         damage: boolean;
         damage_detection: boolean;
         dfl_damage: boolean;
     VAR status: ost$status);

     VAR
       p_dfd: ^dmt$disk_file_descriptor,
       p_fde: gft$file_desc_entry_p,
       p_fmd: ^dmt$file_medium_descriptor,
       sdtxe_p: ^mmt$segment_descriptor_extended,
       system_file_id: gft$system_file_identifier,
       xcb_p: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb_p);
    sdtxe_p := mmp$get_sdtx_entry_p (xcb_p, #SEGMENT(p));
    system_file_id := sdtxe_p^.sfid;

    gfp$get_fde_p (system_file_id, p_fde);
    IF p_fde = NIL THEN
      RETURN;
    IFEND;
    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
    dmp$get_fmd_by_index (p_dfd, 1, p_fmd);
    IF (p_fmd <> NIL) AND (p_fmd^.in_use) THEN
      dmp$change_sft_file_damaged (system_file_id, damage, p_fde^.global_file_name, status);
      dmp$change_sft_damage_detection (system_file_id, damage_detection, p_fde^.global_file_name, status);
      IF dfl_damage THEN
        dmp$change_dfl_damage (p_fmd^.avt_index, $dmt$file_damage [dmc$media_image_inconsistent],
              $dmt$file_damage [], p_fmd^.dfl_index, TRUE, p_fde^.global_file_name, status);
      ELSE
        dmp$change_dfl_damage (p_fmd^.avt_index, $dmt$file_damage [],
              $dmt$file_damage [dmc$media_image_inconsistent], p_fmd^.dfl_index, FALSE,
              p_fde^.global_file_name, status);
      IFEND;
    IFEND;

  PROCEND dmp$change_file_damage_r3;
?? TITLE := '  dmp$copy_dat', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$copy_dat
    (    recorded_vsn: rmt$recorded_vsn;
         p_output_file: ^cell;
     VAR status: ost$status);

    VAR
      p_dat: ^dmt$ms_device_allocation_table;

    PROCEDURE dat_handler
     (    condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      osp$set_status_from_condition (dmc$device_manager_ident, condition, save_area, status, handler_status);

      IF NOT handler_status.normal THEN
        status := handler_status;
      IFEND;

      dmp$close_dat_r3 (p_dat, local_status);

      EXIT dmp$copy_dat;

    PROCEND dat_handler;


    dmp$open_dat_r3 (recorded_vsn, p_dat, status);

    IF status.normal THEN
      osp$establish_condition_handler (^dat_handler, FALSE);
      i#move (p_dat, p_output_file, #SIZE (p_dat^));
      dmp$close_dat_r3 (p_dat, status)
    IFEND;
  PROCEND dmp$copy_dat;

?? TITLE := '  dmp$copy_dfl', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$copy_dfl
    (    recorded_vsn: rmt$recorded_vsn;
         p_output_file: ^cell;
     VAR status: ost$status);

    VAR
      p_dfl: ^dmt$ms_device_file_list_table;

    PROCEDURE dfl_handler
     (    condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      osp$set_status_from_condition (dmc$device_manager_ident, condition, save_area, status, handler_status);

      IF NOT handler_status.normal THEN
        status := handler_status;
      IFEND;

      dmp$close_dfl_r3 (p_dfl, local_status);

      EXIT dmp$copy_dfl;

    PROCEND dfl_handler;


    dmp$open_dfl_r3 (recorded_vsn, p_dfl, status);

    IF status.normal THEN
      osp$establish_condition_handler (^dfl_handler, FALSE);
      i#move (p_dfl, p_output_file, #SIZE (p_dfl^));
      dmp$close_dfl_r3 (p_dfl, status);
    IFEND;
  PROCEND dmp$copy_dfl;

?? TITLE := '  dmp$copy_directory', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$copy_directory
    (    recorded_vsn: rmt$recorded_vsn;
         p_output_file: ^cell;
     VAR status: ost$status);

    VAR
      p_dir: ^dmt$ms_volume_directory;

    PROCEDURE directory_handler
     (    condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      osp$set_status_from_condition (dmc$device_manager_ident, condition, save_area, status, handler_status);

      IF NOT handler_status.normal THEN
        status := handler_status;
      IFEND;

      dmp$close_directory_r3 (p_dir, local_status);

      EXIT dmp$copy_directory;

    PROCEND directory_handler;


    dmp$open_directory_r3 (recorded_vsn, p_dir, status);

    IF status.normal THEN
      osp$establish_condition_handler (^directory_handler, FALSE);
      i#move (p_dir, p_output_file, #SIZE (p_dir^));
      dmp$close_directory_r3 (p_dir, status);
    IFEND;
  PROCEND dmp$copy_directory;
?? TITLE := '  dmp$copy_label', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$copy_label
    (    recorded_vsn: rmt$recorded_vsn;
         p_output_file: ^cell;
     VAR status: ost$status);

    VAR
      length: ost$segment_length,
      local_status: ost$status,
      p_label: ^dmt$ms_volume_label;

    PROCEDURE label_handler
     (    condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      osp$set_status_from_condition (dmc$device_manager_ident, condition, save_area, status, handler_status);

      IF NOT handler_status.normal THEN
        status := handler_status;
      IFEND;

      dmp$close_label_r3 (p_label, local_status);

      EXIT dmp$copy_label;

    PROCEND label_handler;


    dmp$open_label_r3 (recorded_vsn, p_label, status);

    IF status.normal THEN
      mmp$get_segment_length (p_label, #RING (p_label), length, status);

      IF status.normal THEN
        osp$establish_condition_handler (^label_handler, FALSE);
        i#move (p_label, p_output_file, length);
        dmp$close_label_r3 (p_label, status);
      ELSE
        dmp$close_label_r3 (p_label, local_status);
      IFEND;
    IFEND;
  PROCEND dmp$copy_label;
?? TITLE := '  dmp$copy_log', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$copy_log
    (    recorded_vsn: rmt$recorded_vsn;
         p_output_file: ^cell;
     VAR status: ost$status);

    VAR
      p_log: ^SEQ ( * );

    PROCEDURE log_handler
     (    condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      osp$set_status_from_condition (dmc$device_manager_ident, condition, save_area, status, handler_status);

      IF NOT handler_status.normal THEN
        status := handler_status;
      IFEND;

      dmp$close_log_r3 (p_log, local_status);

      EXIT dmp$copy_log;

    PROCEND log_handler;


    dmp$open_log_r3 (recorded_vsn, p_log, status);

    IF status.normal THEN
      osp$establish_condition_handler (^log_handler, FALSE);
      i#move (p_log, p_output_file, #SIZE (p_log^));
      dmp$close_log_r3 (p_log, status);
    IFEND;
  PROCEND dmp$copy_log;
?? TITLE := '  dmp$copy_login_table', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$copy_login_table
    (    recorded_vsn: rmt$recorded_vsn;
         p_output_file: ^cell;
     VAR status: ost$status);

    VAR
      p_login_table: ^dmt$ms_mainframe_login_table;

    PROCEDURE login_table_handler
     (    condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      osp$set_status_from_condition (dmc$device_manager_ident, condition, save_area, status, handler_status);

      IF NOT handler_status.normal THEN
        status := handler_status;
      IFEND;

      dmp$close_login_table_r3 (p_login_table, local_status);

      EXIT dmp$copy_login_table;

    PROCEND login_table_handler;


    dmp$open_login_table_r3 (recorded_vsn, p_login_table, status);

    IF status.normal THEN
      osp$establish_condition_handler (^login_table_handler, FALSE);
      i#move (p_login_table, p_output_file, #SIZE (p_login_table^));
      dmp$close_login_table_r3 (p_login_table, status);
    IFEND;
  PROCEND dmp$copy_login_table;
?? TITLE := '  dmp$utility_flush_logs_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$utility_flush_logs_r3;

    dmp$utility_flush_logs;

  PROCEND dmp$utility_flush_logs_r3;
?? TITLE := '  display_fat', EJECT ??

  PROCEDURE display_fat (VAR display_control: clt$display_control;
        stored_fat: dmt$stored_ms_device_file_fat;
    VAR status: ost$status);

    VAR
      au_index: dmt$dau_address,
      aux_string,
      integer_string: ost$string;

    status.normal := TRUE;

    clp$put_display (display_control, 'Stored Device File Fat Header', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE stored_fat.header.allocation_style OF
    = dmc$a0 =
      aux_string.value := 'dmc$a0';
      aux_string.size := 6;
    = dmc$a1 =
      aux_string.value := 'dmc$a1';
      aux_string.size := 6;
    = dmc$a2 =
      aux_string.value := 'dmc$a2';
      aux_string.size := 6;
    = dmc$a3 =
      aux_string.value := 'dmc$a3';
      aux_string.size := 6;
    = dmc$a4 =
      aux_string.value := 'dmc$a4';
      aux_string.size := 6;
    = dmc$a5 =
      aux_string.value := 'dmc$a5';
      aux_string.size := 6;
    = dmc$a6 =
      aux_string.value := 'dmc$a6';
      aux_string.size := 6;
    = dmc$a7 =
      aux_string.value := 'dmc$a7';
      aux_string.size := 6;
    = dmc$a8 =
      aux_string.value := 'dmc$a8';
      aux_string.size := 6;
    = dmc$acyl =
      aux_string.value := 'dmc$acyl';
      aux_string.size := 8;
    CASEND;

    clp$put_partial_display (display_control, '  Allocation Style     - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, aux_string.value (1, aux_string.size), clc$trim, amc$terminate,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Byte Address         - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (stored_fat.header.byte_address, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Bytes/Allocation     - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (stored_fat.header.bytes_per_allocation, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Bytes/Mau            - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (stored_fat.header.bytes_per_mau, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Clear Space          - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF stored_fat.header.clear_space THEN
      aux_string.value := 'True';
      aux_string.size := 4;
    ELSE
      aux_string.value := 'False';
      aux_string.size := 5;
    IFEND;

    clp$put_partial_display (display_control, aux_string.value (1, aux_string.size), clc$trim, amc$terminate,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Daus/Allocation Unit - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (stored_fat.header.daus_per_allocation_unit, 10, FALSE, integer_string,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Daus/Cylinder        - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (stored_fat.header.daus_per_cylinder, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Daus/Transfer Unit   - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (stored_fat.header.daus_per_transfer_unit, 10, FALSE, integer_string,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Global File Name     - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_binary_unique_name (display_control, stored_fat.header.global_file_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Maus/Allocation Unit - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (stored_fat.header.maus_per_allocation_unit, 10, FALSE, integer_string,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Maus/Dau             - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (stored_fat.header.maus_per_dau, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Maus/Transfer Unit   - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (stored_fat.header.maus_per_transfer_unit, 10, FALSE, integer_string,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Preset Value         - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (stored_fat.header.preset_value, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Number Faus          - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (stored_fat.header.number_faus, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, 'File Allocation Units', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR au_index := 1 TO stored_fat.header.number_faus DO
      clp$put_partial_display (display_control, '  Dau Address - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_string (stored_fat.file_allocation_units [au_index].dau_address, 10, FALSE,
            integer_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  State       - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE stored_fat.file_allocation_units [au_index].state OF
      = dmc$fau_free =
        aux_string.value := 'dmc$fau_free';
        aux_string.size := 12;
      = dmc$fau_invalid_data =
        aux_string.value := 'dmc$fau_invalid_data';
        aux_string.size := 20;
      = dmc$fau_invalid_and_flawed =
        aux_string.value := 'dmc$fau_invalid_and_flawed';
        aux_string.size := 26;
      = dmc$fau_initialized =
        aux_string.value := 'dmc$fau_initialized';
        aux_string.size := 19;
      = dmc$fau_initialized_and_flawed =
        aux_string.value := 'dmc$fau_initialized_and_flawed';
        aux_string.size := 30;
      = dmc$fau_initialization_in_prog =
        aux_string.value := 'dmc$fau_initialization_in_prog';
        aux_string.size := 30;
      ELSE
        ;
      CASEND;

      clp$put_partial_display (display_control, aux_string.value (1, aux_string.size), clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Status      - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE stored_fat.file_allocation_units [au_index].status OF
      = dmc$add_to_chain =
        aux_string.value := 'dmc$add_to_chain';
        aux_string.size := 16;
      = dmc$delete_from_chain =
        aux_string.value := 'dmc$delete_from_chain';
        aux_string.size := 21;
      = dmc$no_change_required =
        aux_string.value := 'dmc$no_change_required';
        aux_string.size := 22;
      ELSE
        ;
      CASEND;

      clp$put_partial_display (display_control, aux_string.value (1, aux_string.size), clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND display_fat;
?? TITLE := '  display_stored_fmd', EJECT ??

  PROCEDURE display_stored_fmd (VAR display_control: clt$display_control;
        p_stored_df_fmd: ^dmt$device_file_stored_fmd;
    VAR status: ost$status);

    VAR
      stored_df_fmd: ^dmt$device_file_stored_fmd,
      aux_string,
      integer_string: ost$string,
      fmd_version: ^dmt$stored_ms_version_number,
      stored_fmd_header: ^dmt$stored_ms_fmd_header,
      stored_fmd_subfile: ^dmt$stored_ms_fmd_subfile;

    status.normal := TRUE;
    stored_df_fmd := p_stored_df_fmd;

    RESET stored_df_fmd;
    NEXT fmd_version IN stored_df_fmd;
    IF fmd_version = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_fmd, 'No FMD version number.', status);
      RETURN;
    IFEND;

    NEXT stored_fmd_header: [fmd_version^] IN stored_df_fmd;
    IF stored_fmd_header = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_fmd, 'No FMD header.', status);
      RETURN;
    IFEND;

    clp$put_display (display_control, 'Stored Fmd Header', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE fmd_version^ OF
    = 0 =
      clp$put_display (display_control, '  Version                   - 0', clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Clear Space               - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF stored_fmd_header^.version_0_0.clear_space THEN
        aux_string.value := 'True';
        aux_string.size := 4;
      ELSE
        aux_string.value := 'False';
        aux_string.size := 5;
      IFEND;

      clp$put_partial_display (display_control, aux_string.value (1, aux_string.size), clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  File Hash                 - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_string (stored_fmd_header^.version_0_0.file_hash, 10, FALSE, integer_string,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  File Limit                - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_string (stored_fmd_header^.version_0_0.file_limit, 10, FALSE, integer_string,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  File Type                 - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE stored_fmd_header^.version_0_0.file_kind OF
      = gfc$fk_job_permanent_file =
        aux_string.value := 'gfc$fk_job_permanent_file';
        aux_string.size := 25;
      = gfc$fk_device_file =
        aux_string.value := 'gfc$fk_device_file';
        aux_string.size := 18;
      = gfc$fk_job_local_file =
        aux_string.value := 'gfc$fk_job_local_file';
        aux_string.size := 21;
      = gfc$fk_unnamed_file =
        aux_string.value := 'gfc$fk_unnamed_file';
        aux_string.size := 19;
      = gfc$fk_catalog =
        aux_string.value := 'gfc$fk_catalog';
        aux_string.size := 14;
      ELSE
        ;
      CASEND;

      clp$put_partial_display (display_control, aux_string.value (1, aux_string.size), clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Locked File               - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '(', clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF stored_fmd_header^.version_0_0.locked_file.required THEN
        clp$put_partial_display (display_control, 'True, ', clc$trim, amc$terminate, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        clp$put_partial_display (display_control, 'False)', clc$trim, amc$terminate, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      clp$put_partial_display (display_control, '  Number Subfiles           - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_string (stored_fmd_header^.version_0_0.number_fmds, 10, FALSE,
            integer_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Overflow Allowed          - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF stored_fmd_header^.version_0_0.overflow_allowed THEN
        aux_string.value := 'True';
        aux_string.size := 4;
      ELSE
        aux_string.value := 'False';
        aux_string.size := 5;
      IFEND;

      clp$put_partial_display (display_control, aux_string.value (1, aux_string.size), clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Preset Value              - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_string (stored_fmd_header^.version_0_0.preset_value, 10, FALSE, integer_string,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Requested Allocation Size - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_string (stored_fmd_header^.version_0_0.requested_allocation_size, 10, FALSE,
            integer_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Requested Class           - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      aux_string.value (1) := stored_fmd_header^.version_0_0.requested_class;
      aux_string.size := 1;

      clp$put_partial_display (display_control, aux_string.value (1, aux_string.size), clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Requested Class Ordinal   - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_string (stored_fmd_header^.version_0_0.requested_class_ordinal, 10, FALSE,
            integer_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Requested Transfer Size   - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_string (stored_fmd_header^.version_0_0.requested_transfer_size, 10, FALSE,
            integer_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Requested Volume.Rec_Vsn  - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, stored_fmd_header^.version_0_0.requested_volume.recorded_vsn,
            clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Requested Volume.Set_Name - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, stored_fmd_header^.version_0_0.requested_volume.setname,
            clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    = 1 =
      clp$put_partial_display (display_control, '  Version                  - 1', clc$trim, amc$terminate,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Number Subfiles           - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_string (stored_fmd_header^.version_1_0.number_fmds, 10, FALSE,
            integer_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      ;
    CASEND;

    NEXT stored_fmd_subfile: [fmd_version^] IN stored_df_fmd;
    IF stored_fmd_subfile = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_fmd, 'FMD too small to hold subfiles.',
            status);
      RETURN;
    IFEND;

    clp$put_display (display_control, 'Stored Fmd Subfile', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE fmd_version^ OF
    = 0 =
      clp$put_partial_display (display_control, '  Version                   - 0', clc$trim, amc$terminate,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Byte Address              - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_string (stored_fmd_subfile^.version_0_0.stored_byte_address *
            dmc$byte_address_converter, 10, FALSE, integer_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Device File List Index    - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_string (stored_fmd_subfile^.version_0_0.device_file_list_index, 10, FALSE,
            integer_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Interval Vsn              - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_binary_unique_name (display_control, stored_fmd_subfile^.version_0_0.internal_vsn, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Recorded Vsn              - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, stored_fmd_subfile^.version_0_0.recorded_vsn, clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    = 1 =
      clp$put_display (display_control, '  Version                   - 1', clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Recorded Vsn              - ', clc$no_trim, amc$start,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, stored_fmd_subfile^.version_1_0.recorded_vsn, clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      ;
    CASEND;

  PROCEND display_stored_fmd;
?? TITLE := '  display_binary_unique_name', EJECT ??

  PROCEDURE display_binary_unique_name (VAR display_control: clt$display_control;
        binary_unique_name: ost$binary_unique_name;
    VAR status: ost$status);

    VAR
      unique_name: ost$name;

    status.normal := TRUE;
    pmp$convert_binary_unique_name (binary_unique_name, unique_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, unique_name, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_binary_unique_name;

?? TITLE := '  display_date', EJECT ??

  PROCEDURE display_date (VAR display_control: clt$display_control;
        date: dmt$date;
    VAR status: ost$status);

    VAR
      integer_string: ost$string;

    status.normal := TRUE;

    clp$convert_integer_to_string (date.year, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '/', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (date.month, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '/', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (date.day, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_date;


?? TITLE := '  display_directory_header', EJECT ??

  PROCEDURE display_directory_header (VAR display_control: clt$display_control;
        directory_header: dmt$ms_volume_directory_head;
        recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

    VAR
      date: ost$date,
      time: ost$time,
      title_string: string (80),
      integer_string: ost$string;

    status.normal := TRUE;

    pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    title_string (1, * ) := 'DIRECTORY : ';
    title_string (13, rmc$recorded_vsn_size) := recorded_vsn;
    title_string (20, 8) := date.mdy;
    title_string (29, 8) := time.hms;

    clp$new_display_page (display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, title_string, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Number Of Entries - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (directory_header.number_of_entries, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_directory_header;

?? TITLE := '  display_directory_entry', EJECT ??

  PROCEDURE display_directory_entry (VAR display_control: clt$display_control;
        directory_entry: dmt$ms_volume_directory_entry;
    VAR status: ost$status);

    VAR
      aux_string: ost$string;

    status.normal := TRUE;

    clp$put_partial_display (display_control, '  Entry Available    - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF directory_entry.entry_available THEN
      aux_string.value := 'True';
      aux_string.size := 4;
    ELSE
      aux_string.value := 'False';
      aux_string.size := 5;
    IFEND;

    clp$put_partial_display (display_control, aux_string.value (1, aux_string.size), clc$no_trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT directory_entry.entry_available THEN
      clp$put_partial_display (display_control, '  User Supplied Name - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, directory_entry.user_supplied_name, clc$trim, amc$terminate,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '  Global File Name   - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_binary_unique_name (display_control, directory_entry.global_file_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_stored_fmd (display_control, ^directory_entry.stored_df_fmd, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND display_directory_entry;

?? TITLE := '  accumulate_dat_info', EJECT ??

  PROCEDURE accumulate_dat_info (
        recorded_vsn: rmt$recorded_vsn;
    VAR display_control: clt$display_control;
    VAR dau_status_counts: array [dmt$dau_status] of integer;
    VAR contiguous_dau_counts: array [1 .. contiguous_dau_range_array_size] of contiguous_dau_info;
    VAR contiguous_dau_max: integer;
    VAR total_available_daus: integer;
    VAR status: ost$status);

    VAR
      contiguous_count: integer,
      contiguous_index: integer,
      dat_index: dmt$dau_address,
      date: ost$date,
      dau_status: dmt$dau_status,
      mainframe_id: dmt$mainframe_assigned,
      p_dat: ^dmt$ms_device_allocation_table,
      p_dat_entry: ^dmt$ms_device_allocation_unit,
      time: ost$time,
      title_string: string (80);

    status.normal := TRUE;

    dmp$open_dat_r3 (recorded_vsn, p_dat, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    contiguous_count := 0;
    contiguous_dau_max := 0;
    total_available_daus := 0;

  /accumulate_dat/
    BEGIN

      pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, status);
      IF NOT status.normal THEN
        EXIT /accumulate_dat/;
      IFEND;

      title_string (1, * ) := 'DEVICE SPACE : ';
      title_string (16, rmc$recorded_vsn_size) := recorded_vsn;
      title_string (23, 8) := date.mdy;
      title_string (32, 8) := time.hms;

      clp$new_display_page (display_control, status);
      IF NOT status.normal THEN
        EXIT /accumulate_dat/;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        EXIT /accumulate_dat/;
      IFEND;

      clp$put_display (display_control, title_string, clc$trim, status);
      IF NOT status.normal THEN
        EXIT /accumulate_dat/;
      IFEND;

      display_dat_header (display_control, p_dat^.header, status);
      IF NOT status.normal THEN
          EXIT /accumulate_dat/;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_display (display_control, 'Device Allocation Table', clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    /scan_dat_entries/
      FOR dat_index := 0 TO p_dat^.header.number_of_entries - 1 DO

        p_dat_entry := ^p_dat^.body [dat_index];
        dau_status := p_dat_entry^.dau_status;

        dau_status_counts [dau_status] := dau_status_counts [dau_status] + 1;

        IF (dau_status = dmc$dau_usable) OR (dau_status = dmc$dau_assigned_to_mainframe) THEN
          contiguous_count := contiguous_count + 1;
          total_available_daus := total_available_daus + 1;
        ELSE
          IF contiguous_count > 0 THEN
          /update_contiguous_dau_counts/
            FOR contiguous_index := LOWERBOUND(contiguous_dau_counts) TO UPPERBOUND(contiguous_dau_counts) DO
              IF (contiguous_count >= contiguous_dau_counts [contiguous_index].low) AND
                    (contiguous_count <= contiguous_dau_counts [contiguous_index].high) THEN
                contiguous_dau_counts [contiguous_index].occurrences :=
                      contiguous_dau_counts [contiguous_index].occurrences + 1;
                contiguous_dau_counts [contiguous_index].total_daus :=
                      contiguous_dau_counts [contiguous_index].total_daus + contiguous_count;
                IF contiguous_count > contiguous_dau_max THEN
                  contiguous_dau_max := contiguous_count;
                IFEND;
                EXIT /update_contiguous_dau_counts/;
              IFEND
            FOREND /update_contiguous_dau_counts/;
            contiguous_count := 0;
          IFEND;
        IFEND;

      FOREND /scan_dat_entries/;
    END /accumulate_dat/;

    dmp$close_dat_r3 (p_dat, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND accumulate_dat_info;

?? TITLE := '  accumulate_device_file_space', EJECT ??

  PROCEDURE accumulate_device_file_space (recorded_vsn: rmt$recorded_vsn;
    VAR display_control: clt$display_control;
    VAR dfle_flag_counts: array [dmt$dfl_entry_flags] of integer;
    VAR assigned_dfle_file_counts: array [gft$file_kind] of integer;
    VAR status: ost$status);

{
{   The purpose of this procedure is to accumulate counts concerning device file allocation.
{

    VAR
      dfl_index: dmt$device_file_list_index,
      p_device_file: ^dmt$ms_device_file_list_table,
      dfle_flag: dmt$dfl_entry_flags,
      file_kind: gft$file_kind,
      p_dfl_entry: ^dmt$ms_device_file_list_entry;

    status.normal := TRUE;
    dmp$open_dfl_r3 (recorded_vsn, p_device_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /display_device_file_totals/
    BEGIN

      display_device_file_header (display_control, ^p_device_file^.header, recorded_vsn, status);
      IF NOT status.normal THEN
        EXIT /display_device_file_totals/;
      IFEND;

    /accumulate_dfl_entries/
      FOR dfl_index := 1 TO p_device_file^.header.number_of_entries DO

        p_dfl_entry := ^p_device_file^.entries [dfl_index];
        dfle_flag := p_dfl_entry^.flags;

        dfle_flag_counts [dfle_flag] := dfle_flag_counts [dfle_flag] + 1;
        IF dfle_flag = dmc$dfle_assigned_to_file THEN
          file_kind := p_dfl_entry^.file_kind;
          assigned_dfle_file_counts [file_kind] := assigned_dfle_file_counts [file_kind] + 1;
        IFEND;

      FOREND /accumulate_dfl_entries/;
    END /display_device_file_totals/;

    dmp$close_dfl_r3 (p_device_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
  PROCEND accumulate_device_file_space;

?? TITLE := '  display_line', EJECT ??

  PROCEDURE display_line (output_line: string ( * );
        number: integer;
    VAR display_control: clt$display_control;
    VAR status: ost$status);

{
{   The purpose of this procedure is to output a line with the number converted to a string
{ appended to the line.
{

    VAR
      integer_length: integer,
      integer_string: string (osc$max_string_size),
      line: string (osc$max_string_size);


    STRINGREP (integer_string, integer_length, number);
    line := output_line;
    line (STRLENGTH (output_line) + 1, integer_length) := integer_string;
    clp$put_display (display_control, line, clc$trim, status);

  PROCEND display_line;

?? TITLE := '  display_device_file_header', EJECT ??

  PROCEDURE display_device_file_header (VAR display_control: clt$display_control;
        p_device_file_header: ^dmt$ms_device_file_list_header;
        recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

    VAR
      date: ost$date,
      time: ost$time,
      title_string: string (80),
      aux_string,
      integer_string: ost$string;

    status.normal := TRUE;

    pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    title_string (1, * ) := 'DEVICE FILE LIST : ';
    title_string (20, rmc$recorded_vsn_size) := recorded_vsn;
    title_string (27, 8) := date.mdy;
    title_string (36, 8) := time.hms;

    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, title_string, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Number Of Entries - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (p_device_file_header^.number_of_entries, 10, FALSE, integer_string,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Version Number    - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE p_device_file_header^.version_number OF
    = dmc$dflt_0_0 =
      aux_string.value := 'dmc$dflt_0_0';
      aux_string.size := 12;
    = dmc$dflt_1_0 =
      aux_string.value := 'dmc$dflt_1_0';
      aux_string.size := 12;
    ELSE
      ;
    CASEND;

    clp$put_partial_display (display_control, aux_string.value (1, aux_string.size), clc$trim, amc$terminate,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_device_file_header;
?? TITLE := '  display_dfl_entry', EJECT ??

  PROCEDURE display_dfl_entry (VAR display_control: clt$display_control;
        dfl_index: dmt$device_file_list_index;
        p_dfl_entry: ^dmt$ms_device_file_list_entry;
    VAR status: ost$status);

    VAR
      integer_string: string (osc$max_string_size),
      integer_length: integer,
      display_string: string (osc$max_string_size),
      aux_integer_length: integer,
      login_index: dmt$login_table_entry_index,
      first: boolean;

    status.normal := TRUE;

    STRINGREP (integer_string, integer_length, dfl_index);

    CASE p_dfl_entry^.flags OF
    = dmc$dfle_available =
      display_string := '       Dfle Available                                                ';
      display_string (1, integer_length) := integer_string;
    = dmc$dfle_assigned_to_mainframe =
      display_string := '       Mainframe Assigned(Login Seq, Login Index)-                     ';
      display_string (1, integer_length) := integer_string;
      STRINGREP (integer_string, integer_length, p_dfl_entry^.mainframe_assigned.log_in_sequence);
      display_string (51, integer_length) := integer_string;
      display_string (51 + integer_length, 2) := ', ';
      STRINGREP (integer_string, aux_integer_length, p_dfl_entry^.mainframe_assigned.log_in_index);
      display_string (51 + integer_length + 2, aux_integer_length) := integer_string;
    = dmc$dfle_assigned_to_file =
      display_string := '       File Type-             File Hash-     Fba-                       ';
      display_string (1, integer_length) := integer_string;
      CASE p_dfl_entry^.file_kind OF
      = gfc$fk_job_permanent_file =
        display_string (18, 12) := 'Permanent   ';
      = gfc$fk_device_file =
        display_string (18, 12) := 'Device      ';
      = gfc$fk_job_local_file =
        display_string (18, 12) := 'Temp Named  ';
      = gfc$fk_unnamed_file =
        display_string (18, 12) := 'Temp Unnamed';
      = gfc$fk_global_unnamed =
        display_string (18, 12) := 'Temp Global ';
      = gfc$fk_catalog =
        display_string (18, 12) := 'Catalog     ';
      ELSE
        ;
      CASEND;
      STRINGREP (integer_string, integer_length, p_dfl_entry^.file_hash);
      display_string (41, integer_length) := integer_string;
      STRINGREP (integer_string, integer_length, p_dfl_entry^.file_byte_address);
      display_string (49, integer_length) := integer_string;

      clp$put_display (display_control, display_string, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '       GFN - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_binary_unique_name (display_control, p_dfl_entry^.global_file_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_string := '       Daus/Alloc Unit-    Dau Chain Status-                           ';
      STRINGREP (integer_string, integer_length, p_dfl_entry^.daus_per_allocation_unit);
      display_string (24, integer_length) := integer_string;
      IF p_dfl_entry^.dau_chain_status = dmc$dau_chain_linked THEN
        display_string (45, 12) := 'Chain Linked';
      ELSE
        display_string (45, 16) := 'Chain Not Linked';
      IFEND;

      clp$put_display (display_control, display_string, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_string := '       First Dau Address-           Subfile Length-                    ';
      STRINGREP (integer_string, integer_length, p_dfl_entry^.first_dau_address);
      display_string (26, integer_length) := integer_string;
      STRINGREP (integer_string, integer_length, p_dfl_entry^.fmd_length);
      display_string (52, integer_length) := integer_string;

      clp$put_display (display_control, display_string, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_string := '       Logical Length-           End Of Information-                   ';
      STRINGREP (integer_string, integer_length, p_dfl_entry^.logical_length);
      display_string (23, integer_length) := integer_string;
      STRINGREP (integer_string, integer_length, p_dfl_entry^.end_of_information);
      display_string (53, integer_length) := integer_string;

      clp$put_display (display_control, display_string, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_string := '       End Of File-           Login Set-(                              ';
      STRINGREP (integer_string, integer_length, p_dfl_entry^.end_of_file);
      display_string (20, integer_length) := integer_string;
      first := TRUE;
      aux_integer_length := 43;
      FOR login_index := LOWERVALUE (dmt$login_table_entry_index) TO UPPERVALUE (dmt$login_table_entry_index)
            DO
        IF login_index IN p_dfl_entry^.login_set THEN
          IF NOT first THEN
            display_string (aux_integer_length, 2) := ', ';
            aux_integer_length := aux_integer_length + 2;
          IFEND;

          STRINGREP (integer_string, integer_length, login_index);
          display_string (aux_integer_length, integer_length) := integer_string;
          aux_integer_length := aux_integer_length + integer_length;
          first := FALSE;
        IFEND;
      FOREND;

      display_string (aux_integer_length, 1) := ')';

      clp$put_display (display_control, display_string, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      first := TRUE;
      display_string := '       Abnormalities: None.';
      aux_integer_length := 23;

      IF dmc$eoi_modified_by_recovery IN p_dfl_entry^.damage THEN
        first := FALSE;
        display_string (aux_integer_length, 25) := 'Eoi modified by recovery.';
        aux_integer_length := aux_integer_length + 24;
      IFEND;

      IF dmc$media_image_inconsistent IN p_dfl_entry^.damage THEN
        IF NOT first THEN
          display_string (aux_integer_length, 2) := ', ';
          aux_integer_length := aux_integer_length + 3;
        IFEND;
        first := FALSE;
        display_string (aux_integer_length, 19) := 'Media inconsistent.';
        aux_integer_length := aux_integer_length + 18;
      IFEND;

      IF dmc$allocation_chain_broken IN p_dfl_entry^.damage THEN
        IF NOT first THEN
          display_string (aux_integer_length, 2) := ', ';
          aux_integer_length := aux_integer_length + 3;
        IFEND;
        first := FALSE;
        display_string (aux_integer_length, 24) := 'Allocation chain broken.';
      IFEND;
    CASEND;

      clp$put_display (display_control, display_string, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

  PROCEND display_dfl_entry;
?? TITLE := '  display_label_header', EJECT ??

  PROCEDURE display_label_header (VAR display_control: clt$display_control;
        p_label_header: ^dmt$volume_label_header;
    VAR status: ost$status);

    VAR
      date: ost$date,
      time: ost$time,
      title_string: string (80),
      integer_string,
      aux_string: ost$string;

    status.normal := TRUE;

    pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    title_string (1, * ) := 'LABEL : ';
    title_string (9, rmc$recorded_vsn_size) := p_label_header^.recorded_vsn;
    title_string (16, 8) := date.mdy;
    title_string (25, 8) := time.hms;

    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$new_display_page (display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, title_string, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, 'Label Header', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Recorded Vsn     - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, p_label_header^.recorded_vsn, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Internal Vsn     - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_binary_unique_name (display_control, p_label_header^.internal_vsn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Creation Date    - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_date (display_control, p_label_header^.creation_date, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Expiration Date  - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_date (display_control, p_label_header^.expiration_date, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Label Type       - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, p_label_header^.label_type, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Version Number   - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE p_label_header^.version_number OF
    = dmc$ms_label_0_0 =
      aux_string.value := 'ms_label_0_0';
      aux_string.size := 12;
    = dmc$ms_label_1_0 =
      aux_string.value := 'ms_label_1_0';
      aux_string.size := 12;
    ELSE
      aux_string.value := 'invalid label';
      aux_string.size := 13;
    CASEND;

    clp$put_partial_display (display_control, aux_string.value (1, aux_string.size), clc$trim, amc$terminate,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Cylinders/Device - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (p_label_header^.positions_per_device, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Bytes/Dau        - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (p_label_header^.bytes_per_dau, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Bytes/Mau        - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (p_label_header^.bytes_per_mau, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_label_header;
?? TITLE := '  display_label_0_0', EJECT ??

  PROCEDURE display_label_0_0 (VAR display_control: clt$display_control;
        p_label_0_0: ^dmt$ms_label_0_0;
    VAR status: ost$status);

    VAR
      display_string: string (osc$max_string_size);

    status.normal := TRUE;
    display_string (1, * ) := ' ';

    clp$put_display (display_control, 'Label_0_0', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Access Code - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, p_label_0_0^.access_code, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Owner Id    - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_string (1, osc$max_name_size) := p_label_0_0^.owner_id.user;
    display_string (2 + osc$max_name_size, osc$max_name_size) := p_label_0_0^.owner_id.family;

    clp$put_partial_display (display_control, display_string (1, 2 * osc$max_name_size + 1), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, '               Dat Dfl Entry', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_dfl_entry (display_control, dmc$dat_dfl_index, ^p_label_0_0^.dat_dfl_entry, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

?? NOCOMPILE ??
    clp$put_display (display_control, '         Device Allocation Table Fmd', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_stored_fmd (display_control, ^p_label_0_0^.device_allocation_table_fmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
?? COMPILE ??

    clp$put_display (display_control, '         Device File List Dfl Entry', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_dfl_entry (display_control, dmc$device_file_list_dfl_index, ^p_label_0_0^.
          device_file_list_dfl_entry, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

?? NOCOMPILE ??
    clp$put_display (display_control, '            Device File List Fmd', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_stored_fmd (display_control, ^p_label_0_0^.device_file_list_fmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
?? COMPILE ??

    clp$put_display (display_control, '             Directory Dfl Entry', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_dfl_entry (display_control, dmc$directory_dfl_index, ^p_label_0_0^.directory_dfl_entry, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

?? NOCOMPILE ??
    clp$put_display (display_control, '               Directory Fmd', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_stored_fmd (display_control, ^p_label_0_0^.directory_fmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
?? COMPILE ??

  PROCEND display_label_0_0;

?? TITLE := '  display_dat_header', EJECT ??

  PROCEDURE display_dat_header (VAR display_control: clt$display_control;
        dat_header: dmt$ms_device_alloc_table_head;
    VAR status: ost$status);

    VAR
      aux_string,
      integer_string: ost$string;

    status.normal := TRUE;

    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, 'Device Allocation Table Header', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Bytes/Dau         - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (dat_header.bytes_per_dau, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Bytes/Mau         - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (dat_header.bytes_per_mau, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Daus/Position     - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (dat_header.daus_per_position, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Maus/Dau          - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (dat_header.maus_per_dau, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Number Of Entries - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (dat_header.number_of_entries, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Positions/Device  - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (dat_header.positions_per_device, 10, FALSE, integer_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
          amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, '  Version Number    - ', clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE dat_header.version_number OF
    = dmc$dat_0_0 =
      clp$put_partial_display (display_control, 'dmc$dat_0_0', clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_display (display_control, '    Daus/Allocation Style', clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '      A0   - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a0], 10, FALSE, ' ',
            integer_string.value (1, 6), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '      A1   - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a1], 10, FALSE, ' ',
            integer_string.value (1, 6), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '      A2   - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a2], 10, FALSE, ' ',
            integer_string.value (1, 6), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '      A3   - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a3], 10, FALSE, ' ',
            integer_string.value (1, 6), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '      A4   - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a4], 10, FALSE, ' ',
            integer_string.value (1, 6), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '      A5   - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a5], 10, FALSE, ' ',
            integer_string.value (1, 6), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '      A6   - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a6], 10, FALSE, ' ',
            integer_string.value (1, 6), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '      A7   - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a7], 10, FALSE, ' ',
            integer_string.value (1, 6), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '      A8   - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$a8], 10, FALSE, ' ',
            integer_string.value (1, 6), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '      Acyl - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_rjstring (dat_header.daus_per_allocation_style [dmc$acyl], 10, FALSE, ' ',
            integer_string.value (1, 6), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, 6), clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '    Daus available     - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_rjstring (dat_header.available, 10, FALSE, ' ', integer_string.value (1, 8),
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, 8), clc$no_trim, amc$terminate,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '    Recovery threshold - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_rjstring (dat_header.recovery_threshold, 10, FALSE, ' ', integer_string.value (1,
            8), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, 8), clc$no_trim, amc$terminate,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, '    Warning threshold  - ', clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_rjstring (dat_header.warning_threshold, 10, FALSE, ' ', integer_string.value (1,
            8), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, integer_string.value (1, 8), clc$no_trim, amc$terminate,
            status);

    = dmc$dat_1_0 =
      clp$put_partial_display (display_control, 'dmc$dat_1_0', clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    CASEND;

  PROCEND display_dat_header;
?? TITLE := '  display_dat_entry', EJECT ??

  PROCEDURE display_dat_entry (VAR display_control: clt$display_control;
        dat_index: integer;
        p_dat_entry: ^dmt$ms_device_allocation_unit;
    VAR status: ost$status);

    VAR
       aux_integer_length: integer,
       dfl_index: dmt$device_file_list_index,
       display_string: string (80),
       file_string: string (63),
       flaw_string: string (7),

       integer_string: string (80),

      integer_length: integer,
       mat_flaw_string: string (27),
       mat_string: string (38);


    status.normal := TRUE;

    STRINGREP (integer_string, integer_length, dat_index);

    CASE p_dat_entry^.dau_status OF

    = dmc$dau_usable =
       display_string := '        Usable                                                                  ';

      display_string (1, integer_length) := integer_string;

    = dmc$dau_hardware_flawed =
       display_string := '        Hardware Flawed                                                         ';

      display_string (1, integer_length) := integer_string;

    = dmc$dau_software_flawed =
       display_string := '        Software Flawed                                                         ';

      display_string (1, integer_length) := integer_string;

     = dmc$dau_assigned_to_mainframe, dmc$dau_ass_to_mf_swr_flawed =
       IF p_dat_entry^.dau_status = dmc$dau_ass_to_mf_swr_flawed THEN
         mat_flaw_string := '                     Flawed';
       ELSE
         mat_flaw_string := '                           ';
       IFEND;

       mat_string (1,*) := '        Mfid(login seq, login index) -';

       mat_string (1, integer_length) := integer_string;

       STRINGREP (display_string, integer_length, mat_string: 38,
          p_dat_entry^.mainframe_id.log_in_sequence: 10,
          p_dat_entry^.mainframe_id.log_in_index: 3, mat_flaw_string: 29);


     = dmc$dau_assigned_to_file, dmc$dau_ass_to_file_swr_flawed =
       IF p_dat_entry^.dau_status = dmc$dau_ass_to_file_swr_flawed THEN
         flaw_string := ' Flawed';
       ELSE
         flaw_string := '       ';
       IFEND;

       file_string (1,*) := '        Hash-    Status-';

       file_string (1, integer_length) := integer_string;

      STRINGREP (integer_string, integer_length, p_dat_entry^.file_hash);
       file_string (14, integer_length) := integer_string;

      IF p_dat_entry^.data_status = dmc$dau_data_initialized THEN
         file_string (25, 8) := 'Init    ';

      ELSE
         file_string (25, 8) := 'Not Init';

      IFEND;

      CASE p_dat_entry^.allocation_chain_position OF

      = dmc$first_and_last_allocation =
         file_string (35, 28) := 'First+Last Alloc(Dfl Index)-';

         dfl_index := p_dat_entry^.high_dfl_index * dmc$dfl_index_converter + p_dat_entry^.low_dfl_index;
         STRINGREP (display_string, integer_length, file_string: 63, dfl_index: 8, flaw_string: 9);


      = dmc$first_allocation =
         file_string (35, 28) := 'First Alloc(Next Dau Adrs) -';
         STRINGREP (display_string, integer_length, file_string: 63,

            p_dat_entry^.next_allocation_unit_dau: 8, flaw_string: 9);


      = dmc$middle_allocation =
         file_string (35, 28) := 'Middle Alloc(Next Dau Adrs) -';
         STRINGREP (display_string, integer_length, file_string: 63,
            p_dat_entry^.next_allocation_unit_dau: 8, flaw_string: 9);


      = dmc$last_allocation =
         file_string (35, 28) := 'Last Allocation(Dfl Index) -';

         dfl_index := p_dat_entry^.high_dfl_index * dmc$dfl_index_converter + p_dat_entry^.low_dfl_index;
         STRINGREP (display_string, integer_length, file_string: 63, dfl_index: 8, flaw_string: 9);


      = dmc$part_of_allocation_unit =
         file_string (35, 28) := 'Part of Allocation Unit     ';
         STRINGREP (display_string, integer_length, file_string: 71,
            flaw_string: 9);

      CASEND;

    CASEND;

    clp$put_display (display_control, display_string, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_dat_entry;
?? TITLE := '  dmp$display_label', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$display_label (VAR display_control: clt$display_control;
        recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

    VAR
      p_label: ^dmt$ms_volume_label,
      p_label_header: ^dmt$volume_label_header,
      p_ms_label_0_0: ^dmt$ms_label_0_0,
      p_dat_fat: ^dmt$stored_ms_device_file_fat,
      bytes_per_au: amt$file_byte_address,
      number_of_aus: dmt$dau_address;

    status.normal := TRUE;

    dmp$open_label_r3 (recorded_vsn, p_label, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /display_label/
    BEGIN

      RESET p_label;
      NEXT p_label_header IN p_label;
      IF p_label_header = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$no_contig_space_for_file, '', status);
        EXIT /display_label/;
      IFEND;

      display_label_header (display_control, p_label_header, status);
      IF NOT status.normal THEN
        EXIT /display_label/;
      IFEND;

      number_of_aus := 0;

      CASE p_label_header^.version_number OF

      = dmc$ms_label_0_0 =
        NEXT p_ms_label_0_0 IN p_label;
        IF p_ms_label_0_0 = NIL THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$no_contig_space_for_file, '', status);
          EXIT /display_label/;
        IFEND;

        display_label_0_0 (display_control, p_ms_label_0_0, status);
        IF NOT status.normal THEN
          EXIT /display_label/;
        IFEND;

        bytes_per_au := p_label_header^.bytes_per_dau * p_ms_label_0_0^.dat_dfl_entry.
              daus_per_allocation_unit;
        number_of_aus := (p_ms_label_0_0^.dat_dfl_entry.fmd_length + bytes_per_au - 1) DIV bytes_per_au;

      = dmc$ms_label_1_0 =
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unsupported_label_version,
          'unsupported label version - DMMDIS3', status);
        EXIT /display_label/;
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unsupported_label_version,
          'unsupported label version - DMMDIS3', status);
        EXIT /display_label/;
      CASEND;

      NEXT p_dat_fat: [1 .. number_of_aus] IN p_label;
      IF p_dat_fat = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$no_contig_space_for_file, '', status);
        EXIT /display_label/;
      IFEND;

      display_fat (display_control, p_dat_fat^, status);
      IF NOT status.normal THEN
        EXIT /display_label/;
      IFEND;

    END /display_label/;

    dmp$close_label_r3 (p_label, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND dmp$display_label;
?? TITLE := '  dmp$display_device_file', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$display_device_file (VAR display_control: clt$display_control;
        recorded_vsn: rmt$recorded_vsn;
        summary_listing: boolean;
        full_listing: boolean;
        file_index: dmt$device_file_list_index;
    VAR status: ost$status);

    VAR
      p_device_file: ^dmt$ms_device_file_list_table,
      p_dfl_entry: ^dmt$ms_device_file_list_entry,
      previous_status: dmt$dfl_entry_flags,
      previous_count: integer,
      integer_string: string (osc$max_string_size),
      type_index: gft$file_kind,
      flag_index: dmt$dfl_entry_flags,
      integer_length: integer,
      duplicate_entry_string: string (32),
      summary_string: string (80),
      dfl_index: dmt$device_file_list_index,
      file_kind_count: array [gft$file_kind] of integer,
      file_flag_count: array [dmt$dfl_entry_flags] of integer,
      mainframe_assigned: dmt$mainframe_assigned;

    status.normal := TRUE;

    dmp$open_dfl_r3 (recorded_vsn, p_device_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /display_device_file/
    BEGIN

      clp$new_display_page (display_control, status);

      display_device_file_header (display_control, ^p_device_file^.header, recorded_vsn, status);
      IF NOT status.normal THEN
        EXIT /display_device_file/;
      IFEND;

      IF p_device_file^.entries [1].flags = dmc$dfle_available THEN
        previous_status := dmc$dfle_assigned_to_mainframe;
      ELSE
        previous_status := dmc$dfle_available
      IFEND;
      previous_count := 0;
      duplicate_entry_string := '              Duplicate Entry(s)';

      FOR type_index := LOWERVALUE (gft$file_kind) TO UPPERVALUE (gft$file_kind) DO
        file_kind_count [type_index] := 0;
      FOREND;

      FOR flag_index := LOWERVALUE (dmt$dfl_entry_flags) TO UPPERVALUE (dmt$dfl_entry_flags) DO
        file_flag_count [flag_index] := 0;
      FOREND;

    /display_dfl_entries/
      FOR dfl_index := 1 TO p_device_file^.header.number_of_entries DO

        p_dfl_entry := ^p_device_file^.entries [dfl_index];
        file_flag_count [p_dfl_entry^.flags] := file_flag_count [p_dfl_entry^.flags] + 1;

        CASE p_dfl_entry^.flags OF

        = dmc$dfle_available =

          IF previous_status = dmc$dfle_available THEN
            previous_count := previous_count + 1;
            IF (NOT full_listing) AND (file_index = dfl_index) THEN
              display_dfl_entry (display_control, dfl_index, p_dfl_entry, status);
              CYCLE /display_dfl_entries/;
            ELSE
              CYCLE /display_dfl_entries/;
            IFEND;
          IFEND;

          IF (previous_count <> 0) AND (full_listing) THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
            clp$new_display_line (display_control, 1, status);
          IFEND;

          previous_status := dmc$dfle_available;
          previous_count := 0;

        = dmc$dfle_assigned_to_mainframe =

          IF previous_status = dmc$dfle_assigned_to_mainframe THEN
            IF mainframe_assigned = p_dfl_entry^.mainframe_assigned THEN
              previous_count := previous_count + 1;
              IF (NOT full_listing) AND (file_index = dfl_index) THEN
                display_dfl_entry (display_control, dfl_index, p_dfl_entry, status);
                CYCLE /display_dfl_entries/;
              ELSE
                CYCLE /display_dfl_entries/;
              IFEND;
            IFEND;
          IFEND;

          IF (previous_count <> 0) AND (full_listing) THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
            clp$new_display_line (display_control, 1, status);
          IFEND;

          previous_status := dmc$dfle_assigned_to_mainframe;
          previous_count := 0;

          mainframe_assigned := p_dfl_entry^.mainframe_assigned;

        = dmc$dfle_assigned_to_file =

          IF (previous_count <> 0) AND (full_listing) THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
            clp$new_display_line (display_control, 1, status);
          IFEND;

          file_kind_count[p_dfl_entry^.file_kind] := file_kind_count[p_dfl_entry^.file_kind] + 1;
          previous_status := dmc$dfle_assigned_to_file;
          previous_count := 0;
        ELSE;
        CASEND;

        IF (NOT full_listing) AND (file_index = dfl_index) THEN
          display_dfl_entry (display_control, dfl_index, p_dfl_entry, status);
          IF NOT status.normal THEN
            EXIT /display_device_file/;
          IFEND;
        ELSEIF (full_listing) THEN
          display_dfl_entry (display_control, dfl_index, p_dfl_entry, status);
          IF NOT status.normal THEN
            EXIT /display_device_file/;
          IFEND;
        IFEND;

      FOREND /display_dfl_entries/;

      IF (previous_count <> 0) AND (full_listing) THEN
        STRINGREP (integer_string, integer_length, previous_count);
        duplicate_entry_string (8, 6) := '      ';
        duplicate_entry_string (8, integer_length) := integer_string;

        clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
      IFEND;

      IF summary_listing THEN

        clp$new_display_line (display_control, 1, status);
        clp$put_display (display_control, ' Summary:', clc$trim, status);
        clp$new_display_line (display_control, 1, status);

      /file_flag_summary/
        FOR flag_index := LOWERVALUE (dmt$dfl_entry_flags) TO UPPERVALUE (dmt$dfl_entry_flags) DO
          CASE flag_index OF
          = dmc$dfle_available =
            summary_string := '  Number of available entries             -       ';

          = dmc$dfle_assigned_to_mainframe =
            summary_string := '  Number of assigned to mainframe entries -       ';

          = dmc$dfle_assigned_to_file =
            summary_string := '  Number of assigned to file entries      -       ';
          ELSE;
          CASEND;

          STRINGREP (integer_string, integer_length, file_flag_count[flag_index]);
          summary_string (44, integer_length) := integer_string;
          clp$put_display (display_control, summary_string, clc$trim, status);
        FOREND /file_flag_summary/;

        summary_string := '     File Type -                   Number of Entries -             ';

      /assigned_file_summary/
        FOR type_index := LOWERVALUE (gft$file_kind) TO UPPERVALUE (gft$file_kind) DO
          summary_string (55,*) := ' ';
          CASE type_index OF
          = gfc$fk_job_permanent_file =
            summary_string (18, 12) := 'Permanent   ';
          = gfc$fk_device_file =
            summary_string (18, 12) := 'Device      ';
          = gfc$fk_job_local_file =
            summary_string (18, 12) := 'Temp Named  ';
          = gfc$fk_unnamed_file =
            summary_string (18, 12) := 'Temp Unnamed';
          = gfc$fk_global_unnamed =
            summary_string (18, 12) := 'Temp Global ';
          = gfc$fk_catalog =
            summary_string (18, 12) := 'Catalog     ';
          ELSE;
          CASEND;

        STRINGREP (integer_string, integer_length, file_kind_count [type_index]);
        summary_string (55, integer_length) := integer_string;
        clp$put_display (display_control, summary_string, clc$trim, status);
        FOREND /assigned_file_summary/;
      IFEND;

    END /display_device_file/;

    dmp$close_dfl_r3 (p_device_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND dmp$display_device_file;
?? TITLE := '  dmp$display_device_space', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$display_device_space (VAR display_control: clt$display_control;
        recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

    VAR
      initial_contiguous_dau_counts: [XDCL, oss$job_paged_literal, READ]
            array [1 .. contiguous_dau_range_array_size] of contiguous_dau_info :=
            [[1, 4, 0, 0],
            [5, 9, 0, 0],
            [10, 24, 0, 0],
            [25, 49, 0, 0],
            [50, 99, 0, 0],
            [100, 999, 0, 0],
            [1000, osc$max_integer, 0, 0]];

    VAR
      assigned_dfle_file_counts: array [gft$file_kind] of integer,
      available_percentage: real,
      contiguous_dau_counts: array [1 .. contiguous_dau_range_array_size] of contiguous_dau_info,
      contiguous_dau_max: integer,
      contiguous_index: integer,
      dau_status: dmt$dau_status,
      dau_status_counts: array [dmt$dau_status] of integer,
      dfle_flag: dmt$dfl_entry_flags,
      dfle_flag_counts: array [dmt$dfl_entry_flags] of integer,
      file_kind: gft$file_kind,
      line: string (osc$max_string_size),
      line_length: integer,
      total_available_daus: integer;

{  Initialize all counts to zero.

    FOR file_kind := LOWERVALUE (gft$file_kind) TO UPPERVALUE (gft$file_kind) DO
      assigned_dfle_file_counts [file_kind] := 0;
    FOREND;

    FOR dau_status := LOWERVALUE (dmt$dau_status) TO UPPERVALUE (dmt$dau_status) DO
      dau_status_counts [dau_status] := 0;
    FOREND;

    FOR dfle_flag := LOWERVALUE (dmt$dfl_entry_flags) TO UPPERVALUE (dmt$dfl_entry_flags) DO
      dfle_flag_counts [dfle_flag] := 0;
    FOREND;

    contiguous_dau_counts := initial_contiguous_dau_counts;

{  Accumulate and display DAT totals for device.

    accumulate_dat_info (recorded_vsn, display_control, dau_status_counts, contiguous_dau_counts,
          contiguous_dau_max, total_available_daus, status);
    IF status.normal = FALSE THEN
      RETURN;
    IFEND;

    display_line ('  Usable DAT entries - ', dau_status_counts [dmc$dau_usable], display_control, status);
    display_line ('  DAT entries assigned to files - ', dau_status_counts [dmc$dau_assigned_to_file],
          display_control, status);
    display_line ('  DAT entries assigned to mainframe - ', dau_status_counts [dmc$dau_assigned_to_mainframe],
          display_control, status);
    display_line ('  Hardware flawed DAT entries - ', dau_status_counts [dmc$dau_hardware_flawed],
          display_control, status);
    display_line ('  Software flawed DAT entries - ', dau_status_counts [dmc$dau_software_flawed],
          display_control, status);
    display_line ('  Assigned to mf - software flawed - ', dau_status_counts [dmc$dau_ass_to_mf_swr_flawed],
          display_control, status);
    display_line ('  Assigned to file - software flawed - ', dau_status_counts
          [dmc$dau_ass_to_file_swr_flawed], display_control, status);

    clp$new_display_line (display_control, 1, status);
    STRINGREP (line, line_length, 'Distribution of Contiguous Available Allocation Units (DAUs)');
    clp$put_partial_display (display_control, line (1, line_length), clc$trim, amc$terminate, status);
    clp$new_display_line (display_control, 1, status);
    STRINGREP (line, line_length, '     Range     Occurrences   Total DAUs   % of Available DAUs');
    clp$put_partial_display (display_control, line (1, line_length), clc$trim, amc$terminate, status);
    clp$new_display_line (display_control, 1, status);

    FOR contiguous_index := LOWERBOUND(contiguous_dau_counts) TO UPPERBOUND(contiguous_dau_counts) DO
      IF contiguous_index < UPPERBOUND(contiguous_dau_counts) THEN
        available_percentage := $REAL(contiguous_dau_counts [contiguous_index].total_daus * 100) /
              $REAL(total_available_daus);
        STRINGREP (line, line_length, ' ', contiguous_dau_counts [contiguous_index].low:4, ' ..',
              contiguous_dau_counts [contiguous_index].high:4,
              contiguous_dau_counts [contiguous_index].occurrences:10,
              contiguous_dau_counts [contiguous_index].total_daus:13,
              available_percentage:16:1, '%');
        clp$put_partial_display (display_control, line (1, line_length), clc$trim, amc$terminate, status);
      ELSE
        available_percentage := $REAL(contiguous_dau_counts [contiguous_index].total_daus * 100) /
              $REAL(total_available_daus);
        STRINGREP (line, line_length, '    >', contiguous_dau_counts [contiguous_index].low:7,
              contiguous_dau_counts [contiguous_index].occurrences:10,
              contiguous_dau_counts [contiguous_index].total_daus:13,
              available_percentage:16:1, '%');
        clp$put_partial_display (display_control, line (1, line_length), clc$trim, amc$terminate, status);
      IFEND;
    FOREND;

    clp$new_display_line (display_control, 1, status);
    STRINGREP (line, line_length, '  Total Available DAUs - ', total_available_daus);
    clp$put_partial_display (display_control, line (1, line_length), clc$trim, amc$terminate, status);

    clp$new_display_line (display_control, 1, status);
    STRINGREP (line, line_length, '  Maximum Contigous DAUs - ', contiguous_dau_max);
    clp$put_partial_display (display_control, line (1, line_length), clc$trim, amc$terminate, status);

{  Accumulate and display information about device files on the device.

    accumulate_device_file_space (recorded_vsn, display_control, dfle_flag_counts,
          assigned_dfle_file_counts, status);
    IF status.normal = FALSE THEN
      RETURN;
    IFEND;

    display_line ('  Device file available - ', dfle_flag_counts [dmc$dfle_available], display_control,
          status);
    display_line ('  Device file assigned to mainframe - ', dfle_flag_counts [dmc$dfle_assigned_to_mainframe],
          display_control, status);
    display_line ('  Device file assigned to files - ', dfle_flag_counts [dmc$dfle_assigned_to_file],
          display_control, status);
    display_line ('      Temporary named files - ', assigned_dfle_file_counts [gfc$fk_job_local_file],
          display_control, status);
    display_line ('      Temporary unnamed files - ', assigned_dfle_file_counts [gfc$fk_job_local_file],
          display_control, status);
    display_line ('      Temporary_global files - ',
          assigned_dfle_file_counts [gfc$fk_global_unnamed],
          display_control, status);
    display_line ('      Permanent files - ',
          assigned_dfle_file_counts [gfc$fk_job_permanent_file], display_control,
          status);
    display_line ('      Device files - ', assigned_dfle_file_counts [gfc$fk_device_file],
          display_control, status);
    display_line ('      Catalogs - ', assigned_dfle_file_counts [gfc$fk_catalog],
          display_control, status);

  PROCEND dmp$display_device_space;
?? TITLE := '  dmp$display_directory', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$display_directory (VAR display_control: clt$display_control;
        recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

    VAR
      dir_entry: dmt$ms_volume_directory_entry,
      p_directory: ^dmt$ms_volume_directory,
      integer_string: ost$string,
      previous_count: integer,
      integer_length: integer,
      duplicate_entry_string: string (32),
      previous_status: boolean,
      directory_index: dmt$directory_index;

    status.normal := TRUE;

    dmp$open_directory_r3 (recorded_vsn, p_directory, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /display_directory/
    BEGIN

      display_directory_header (display_control, p_directory^.header, recorded_vsn, status);
      IF NOT status.normal THEN
        EXIT /display_directory/;
      IFEND;

      previous_count := 0;
      previous_status := FALSE;
      duplicate_entry_string := '             Duplicate Entrie(s)';

    /display_directory_entries/
      FOR directory_index := 1 TO p_directory^.header.number_of_entries DO

        dir_entry := p_directory^.entries [directory_index];

        IF dir_entry.entry_available THEN
          IF previous_status = TRUE THEN;
            previous_count := previous_count + 1;
            CYCLE /display_directory_entries/;
          IFEND;
          previous_status := TRUE;
        IFEND;

        IF previous_count <> 0 THEN
          STRINGREP (integer_string.value, integer_length, previous_count);
          duplicate_entry_string (8,6) := '      ';
          duplicate_entry_string(8,integer_length) := integer_string.value;

          clp$new_display_line (display_control, 1, status);
          clp$put_display(display_control, duplicate_entry_string, clc$trim, status);

          previous_count := 0;
          previous_status := FALSE;
        IFEND;

        clp$convert_integer_to_string (directory_index, 10, FALSE, integer_string, status);
        clp$new_display_line (display_control, 1, status);
        clp$put_partial_display (display_control, integer_string.value (1, integer_string.size), clc$trim,
              amc$start, status);
        clp$put_partial_display (display_control, '. Directory Entry', clc$trim, amc$terminate, status);

        display_directory_entry (display_control, dir_entry, status);
        IF NOT status.normal THEN
          EXIT /display_directory_entries/;
        IFEND;
      FOREND /display_directory_entries/;

      IF previous_count <> 0 THEN
        STRINGREP (integer_string.value, integer_length, previous_count);
        duplicate_entry_string (8,6) := '      ';
        duplicate_entry_string(8,integer_length) := integer_string.value;

        clp$new_display_line (display_control, 1, status);
        clp$put_display(display_control, duplicate_entry_string, clc$trim, status);
      IFEND;
    END /display_directory/;

    dmp$close_directory_r3 (p_directory, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND dmp$display_directory;
?? TITLE := '  dmp$display_dat', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$display_dat (VAR display_control: clt$display_control;
        recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

    VAR
      p_dat: ^dmt$ms_device_allocation_table,
      p_dat_entry: ^dmt$ms_device_allocation_unit,
      previous_status: dmt$dau_status,
      previous_count: integer,
      integer_string: string (osc$max_string_size),
      integer_length: integer,
      duplicate_entry_string: string (32),
      dat_index: dmt$dau_address,
      date: ost$date,
      time: ost$time,
      title_string: string (80),
      mainframe_id: dmt$mainframe_assigned;

    status.normal := TRUE;

    dmp$open_dat_r3 (recorded_vsn, p_dat, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /display_dat/
    BEGIN

      clp$new_display_page (display_control, status);
      IF NOT status.normal THEN
        EXIT /display_dat/;
      IFEND;

      pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, status);
      IF NOT status.normal THEN
        EXIT /display_dat/;
      IFEND;

      title_string (1, * ) := 'DEVICE ALLOCATION TABLE : ';
      title_string (27, rmc$recorded_vsn_size) := recorded_vsn;
      title_string (34, 8) := date.mdy;
      title_string (41, 8) := time.hms;

      clp$put_display (display_control, title_string, clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_dat/;
      IFEND;

      display_dat_header (display_control, p_dat^.header, status);
      IF NOT status.normal THEN
        EXIT /display_dat/;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        EXIT /display_dat/;
      IFEND;

      clp$put_display (display_control, 'Device Allocation Table', clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF p_dat^.body [0].dau_status = dmc$dau_usable THEN
        previous_status := dmc$dau_hardware_flawed;
      ELSE
        previous_status := dmc$dau_usable;
      IFEND;
      previous_count := 0;
      duplicate_entry_string := '              Duplicate Entry(s)';

    /display_dat_entries/
      FOR dat_index := 0 TO p_dat^.header.number_of_entries - 1 DO

        p_dat_entry := ^p_dat^.body [dat_index];

        CASE p_dat_entry^.dau_status OF
        = dmc$dau_usable =
          IF previous_status = dmc$dau_usable THEN
            previous_count := previous_count + 1;
            CYCLE /display_dat_entries/;
          IFEND;

          IF previous_count <> 0 THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
            IF NOT status.normal THEN
              EXIT /display_dat/;
            IFEND;
          IFEND;

          previous_status := dmc$dau_usable;
          previous_count := 0;
        = dmc$dau_hardware_flawed =
          IF previous_status = dmc$dau_hardware_flawed THEN
            previous_count := previous_count + 1;
            CYCLE /display_dat_entries/;
          IFEND;

          IF previous_count <> 0 THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
            IF NOT status.normal THEN
              EXIT /display_dat/;
            IFEND;
          IFEND;

          previous_status := dmc$dau_hardware_flawed;
          previous_count := 0;
        = dmc$dau_software_flawed =
          IF previous_status = dmc$dau_software_flawed THEN
            previous_count := previous_count + 1;
            CYCLE /display_dat_entries/;
          IFEND;

          IF previous_count <> 0 THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
            IF NOT status.normal THEN
              EXIT /display_dat/;
            IFEND;
          IFEND;

          previous_status := dmc$dau_software_flawed;
          previous_count := 0;
        = dmc$dau_assigned_to_mainframe =
          IF previous_status = dmc$dau_assigned_to_mainframe THEN
            IF mainframe_id = p_dat_entry^.mainframe_id THEN
              previous_count := previous_count + 1;
              CYCLE /display_dat_entries/;
            IFEND;
          IFEND;

          IF previous_count <> 0 THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
            IF NOT status.normal THEN
              EXIT /display_dat/;
            IFEND;
          IFEND;

          previous_status := dmc$dau_assigned_to_mainframe;
          previous_count := 0;
          mainframe_id := p_dat_entry^.mainframe_id;
        = dmc$dau_assigned_to_file =
          IF previous_count <> 0 THEN
            STRINGREP (integer_string, integer_length, previous_count);
            duplicate_entry_string (8, 6) := '      ';
            duplicate_entry_string (8, integer_length) := integer_string;

            clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
            IF NOT status.normal THEN
              EXIT /display_dat/;
            IFEND;
          IFEND;

          previous_status := dmc$dau_assigned_to_file;
          previous_count := 0;
         = dmc$dau_ass_to_mf_swr_flawed =
           IF previous_status = dmc$dau_ass_to_mf_swr_flawed THEN
             IF mainframe_id = p_dat_entry^.mainframe_id THEN
               previous_count := previous_count + 1;
               CYCLE /display_dat_entries/;
             IFEND;
           IFEND;

           IF previous_count <> 0 THEN
             STRINGREP (integer_string, integer_length, previous_count);
             duplicate_entry_string (8, 6) := '      ';
             duplicate_entry_string (8, integer_length) := integer_string;

             clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
             IF NOT status.normal THEN
               EXIT /display_dat/;
             IFEND;
           IFEND;

           previous_status := dmc$dau_ass_to_mf_swr_flawed;
           previous_count := 0;
           mainframe_id := p_dat_entry^.mainframe_id;
         = dmc$dau_ass_to_file_swr_flawed =
           IF previous_count <> 0 THEN
             STRINGREP (integer_string, integer_length, previous_count);
             duplicate_entry_string (8, 6) := '      ';
             duplicate_entry_string (8, integer_length) := integer_string;

             clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
             IF NOT status.normal THEN
               EXIT /display_dat/;
             IFEND;
           IFEND;

           previous_status := dmc$dau_ass_to_file_swr_flawed;
           previous_count := 0;

        CASEND;

        display_dat_entry (display_control, dat_index, p_dat_entry, status);
        IF NOT status.normal THEN
          EXIT /display_dat/;
        IFEND;
      FOREND /display_dat_entries/;

      IF previous_count <> 0 THEN
        STRINGREP (integer_string, integer_length, previous_count);
        duplicate_entry_string (8, 6) := '      ';
        duplicate_entry_string (8, integer_length) := integer_string;

        clp$put_display (display_control, duplicate_entry_string, clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display_dat/;
        IFEND;
      IFEND;

    END /display_dat/;

    dmp$close_dat_r3 (p_dat, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND dmp$display_dat;
?? TITLE := '  dmp$display_device_log', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$display_device_log (VAR display_control: clt$display_control;
        recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND dmp$display_device_log;
?? TITLE := '  dmp$display_login_table', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$display_login_table (VAR display_control: clt$display_control;
        recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND dmp$display_login_table;

?? TITLE := '  [XDCL, #GATE] dmp$display_cylinders', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$display_cylinders (VAR display_control: clt$display_control;
        recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

{
{  This procedure produces a display of the current state of cylinder allocation on a volume.
{  Information provided is:
{          . some header information (date, time, cylinders per device, etc.)
{          . one line for each cylinder on the device stating the number of the cylinder, the
{              allocation style assigned to the cylinder, whether or not the cylinder is
{              'full', and how the daus are assigned within the cylinder (assigned to file or
{              assigned to mainframe, or flawed)
{          . some summary information indicating the total numbers of daus by assignment, and
{              numbers of cylinders assigned to each allocation style
{

    VAR
      p_dat: ^dmt$ms_device_allocation_table,
      line: string (80),
      l: integer,
      dau_status_counts: dmt$dau_status_counts,
      num_usable: integer,
      num_assigned_file: integer,
      num_assigned_mf: integer,
      num_flawed: integer,
      total_usable: integer,
      total_assigned_file: integer,
      total_assigned_mf: integer,
      total_flawed: integer,
      style_index: dmt$allocation_styles,
      styles_per_device: array [dmt$allocation_styles] of integer,
      date: ost$date,
      time: ost$time,
      cylinder_index: dmt$device_position,
      assigned_style: dmt$allocation_styles;

    status.normal := TRUE;

    FOR style_index := LOWERVALUE (dmt$allocation_styles) TO UPPERVALUE (dmt$allocation_styles) DO
      styles_per_device [style_index] := 0;
    FOREND;

    total_usable := 0;
    total_assigned_file := 0;
    total_assigned_mf := 0;
    total_flawed := 0;

    pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    line (1, * ) := ' CYLINDERS: ';
    line (13, rmc$recorded_vsn_size) := recorded_vsn;
    line (21, 8) := date.mdy;
    line (30, 8) := time.hms;

    clp$new_display_page (display_control, status);
    clp$new_display_line (display_control, 1, status);
    clp$put_display (display_control, line, clc$trim, status);
    clp$new_display_line (display_control, 1, status);

    dmp$open_dat_r3 (recorded_vsn, p_dat, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, ' daus/cyl = ', clc$no_trim, amc$start, status);
    STRINGREP (line (1, 10), l, p_dat^.header.daus_per_position);
    clp$put_partial_display (display_control, line (1, l), clc$no_trim, amc$continue, status);
    clp$put_partial_display (display_control, '  cyl/device = ', clc$no_trim, amc$continue, status);
    STRINGREP (line (1, 10), l, p_dat^.header.positions_per_device);
    clp$put_partial_display (display_control, line (1, l), clc$trim, amc$terminate, status);
    clp$new_display_line (display_control, 1, status);

    line (1, * ) := ' CYLINDER ALLOCATION  DAUs  ASSGND ASSGND';
    clp$put_display (display_control, line, clc$trim, status);
    line (1, * ) := '  NUMBER    STYLE    USABLE  FILE    MF   FLAWED';
    clp$put_display (display_control, line, clc$trim, status);
    clp$new_display_line (display_control, 1, status);

{
{  For each cylinder, write a line describing the cylinder's style and how the daus within the
{  cylinder are assigned.
{

  /display_cylinders/
    FOR cylinder_index := 0 TO p_dat^.header.positions_per_device - 1 DO
      line (1, * ) := ' ';
      STRINGREP (line (3, 5), l, cylinder_index);
      dmp$analyze_dat_position (p_dat, cylinder_index, assigned_style, dau_status_counts);

      CASE assigned_style OF
      = dmc$a0 =
        line (9, * ) := 'a0';
      = dmc$a1 =
        line (9, * ) := 'a1';
        line (12, * ) := '*';
      = dmc$a2 =
        line (9, * ) := 'a2';
        line (12, * ) := '**';
      = dmc$a3 =
        line (9, * ) := 'a3';
        line (12, * ) := '***';
      = dmc$a4 =
        line (9, * ) := 'a4';
        line (12, * ) := '****';
      = dmc$a5 =
        line (9, * ) := 'a5';
        line (12, * ) := '*****';
      = dmc$a6 =
        line (9, * ) := 'a6';
        line (12, * ) := '******';
      = dmc$a7 =
        line (9, * ) := 'a7';
        line (12, * ) := '*******';
      = dmc$a8 =
        line (9, * ) := 'a8';
        line (12, * ) := '********';
      = dmc$acyl =
        line (9, * ) := 'cy';
        line (12, * ) := '**********';
      ELSE
        line (12, * ) := 'NO STYLE';
      CASEND;

      styles_per_device [assigned_style] := styles_per_device [assigned_style] + 1;

      num_usable := dau_status_counts [dmc$dau_usable];
      num_assigned_file := dau_status_counts [dmc$dau_assigned_to_file];
      num_assigned_mf := dau_status_counts [dmc$dau_assigned_to_mainframe];
      num_flawed := dau_status_counts [dmc$dau_hardware_flawed] +
                    dau_status_counts [dmc$dau_software_flawed] +
                    dau_status_counts [dmc$dau_ass_to_mf_swr_flawed] +
                    dau_status_counts [dmc$dau_ass_to_file_swr_flawed];

      total_usable := total_usable + num_usable;
      total_assigned_file := total_assigned_file + num_assigned_file;
      total_assigned_mf := total_assigned_mf + num_assigned_mf;
      total_flawed := total_flawed + num_flawed;

      STRINGREP (line (23, 6), l, num_usable);
      STRINGREP (line (30, 6), l, num_assigned_file);
      STRINGREP (line (37, 6), l, num_assigned_mf);
      STRINGREP (line (44, 6), l, num_flawed);

      IF (num_assigned_file = p_dat^.header.daus_per_position) THEN
        line (50, * ) := 'FULL, ASSIGNED TO FILES';
      ELSEIF (num_assigned_mf = p_dat^.header.daus_per_position) THEN
        line (50, * ) := 'FULL, ASSIGNED TO MAINFRAME';
      ELSEIF (num_flawed = p_dat^.header.daus_per_position) THEN
        line (50, * ) := 'FULL, FLAWED';
      ELSEIF (num_usable = 0) THEN
        line (50, * ) := 'FULL, MIXED';
      IFEND;

      clp$put_display (display_control, line, clc$trim, status);

    FOREND /display_cylinders/;

{
{  Write summary (totals) information
{

    clp$new_display_line (display_control, 2, status);

    clp$put_display (display_control, '  TOTAL DAUS ON DEVICE :', clc$trim, status);
    clp$new_display_line (display_control, 1, status);
    line (1, * ) := ' ';
    STRINGREP (line, l, '   usable daus =', total_usable);
    clp$put_display (display_control, line, clc$trim, status);
    line (1, * ) := ' ';
    STRINGREP (line, l, '   daus assigned to file =', total_assigned_file);
    clp$put_display (display_control, line, clc$trim, status);
    line (1, * ) := ' ';
    STRINGREP (line, l, '   daus assigned to mainframe =', total_assigned_mf);
    clp$put_display (display_control, line, clc$trim, status);
    line (1, * ) := ' ';
    STRINGREP (line, l, '   flawed daus =', total_flawed);
    clp$put_display (display_control, line, clc$trim, status);

    clp$new_display_line (display_control, 1, status);
    clp$put_display (display_control, '  TOTAL CYLINDERS BY STYLE :', clc$trim, status);
    clp$new_display_line (display_control, 1, status);

    line (1, * ) := ' ';
    STRINGREP (line, l, '   a0=', styles_per_device [dmc$a0], ' a1=', styles_per_device [dmc$a1], ' a2=',
          styles_per_device [dmc$a2], ' a3=', styles_per_device [dmc$a3], ' a4=', styles_per_device [dmc$a4]);
    clp$put_display (display_control, line, clc$trim, status);

    line (1, * ) := ' ';
    STRINGREP (line, l, '   a5=', styles_per_device [dmc$a5], ' a6=', styles_per_device [dmc$a6], ' a7=',
          styles_per_device [dmc$a7], ' a8=', styles_per_device [dmc$a8], ' cyl=', styles_per_device
          [dmc$acyl]);
    clp$put_display (display_control, line, clc$trim, status);
    clp$new_display_line (display_control, 1, status);

    clp$put_display (display_control, ' END CYLINDERS', clc$trim, status);
    clp$new_display_line (display_control, 1, status);

    dmp$close_dat_r3 (p_dat, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND dmp$display_cylinders;
?? TITLE := '  dmp$reassign_file_r3', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$reassign_file_r3
    (    ptr: ^cell;
     VAR status: ost$status);

    VAR
      p_fde: gft$file_desc_entry_p,
      sdtxe_p: ^mmt$segment_descriptor_extended,
      system_file_id: gft$system_file_identifier,
      xcb_p: ^ost$execution_control_block;


    pmp$find_executing_task_xcb (xcb_p);
    sdtxe_p := mmp$get_sdtx_entry_p (xcb_p, #SEGMENT(ptr));
    system_file_id := sdtxe_p^.sfid;
    gfp$get_fde_p (system_file_id, p_fde);
    IF p_fde <> NIL THEN
      dmp$reassign_file (system_file_id, p_fde^.eoi_byte_address, status);
    IFEND;

  PROCEND dmp$reassign_file_r3;

MODEND dmm$display_device_files_r3;
*DECK DECK=DMM$DISPLAY_FILE_TABLES EXPAND=TRUE
MODULE dmm$display_file_tables;
?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_fmd_by_index
*copyc dmp$get_fau_entry
*copyc dmt$disk_file_descriptor
*copyc dmt$file_medium_descriptor
*copyc gfp$get_fde_p
*copyc gft$file_desc_entry_p
*copyc gft$file_kind
*copyc gft$file_media
*copyc gft$table_residence
*copyc gft$queue_status
*copyc clp$put_partial_display
*copyc clp$put_display
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc mmp$get_sdtx_entry_p
*copyc pmp$find_executing_task_xcb
*copyc pmp$get_legible_date_time
*copyc cmv$logical_unit_table
*copyc dmv$active_volume_table
*copyc iot$disk_type_table
*copyc pmp$convert_binary_unique_name
*copyc oss$job_paged_literal

  VAR
    iov$disk_type_table: [XREF] array [1 .. ioc$disk_type_count] of
          iot$disk_type_table;

?? POP ??

  VAR
    file_kind: [STATIC, READ, oss$job_paged_literal] array [gft$file_kind] of string (32) :=
          ['gfc$fk_job_permanent_file', 'gfc$fk_device_file', 'gfc$fk_save_2',
           'gfc$fk_save_3', 'gfc$fk_catalog', 'gfc$fk_job_local_file', 'gfc$fk_unnamed_file',
           'gfc$fk_global_unnamed', 'gfc$fk_monitor_only_unnamed'],

    media: [STATIC, READ, oss$job_paged_literal] array [gft$file_media] of string (32) :=
          ['gfc$fm_transient_segment', 'gfc$fm_mass_storage_file', 'gfc$fm_served_file'],

    csr: [STATIC, READ, oss$job_paged_literal] array [gft$table_residence] of string (32) :=
          ['gfc$tr_null_residence', 'gfc$tr_system',
          'gfc$tr_job', 'gfc$tr_system_wait_recovery'];


  PROCEDURE [XDCL, #GATE] dmp$display_file_tables
    (    path: string (*);
         full_listing: boolean;
         p: ^cell;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

?? EJECT ??

    PROCEDURE display_fde;

      VAR
        queue_status: [STATIC, READ, oss$job_paged_literal] array [gft$queue_status] of string (32) :=
              ['gfc$qs_global_shared', 'gfc$qs_job_shared', 'gfc$qs_job_working_set'],
        line: string (132),
        l: integer;

      clp$new_display_line (display_control, 1, status);
      STRINGREP (line, l, ' File Descriptor Entry ', path, ' Sfid ', sfid: #(16));
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$new_display_line (display_control, 1, status);

      clp$put_partial_display (display_control, ' job_lock = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, 'locked = ', p_fde^.monitor_lock.locked: #(16),
            ' lock_id = ', p_fde^.monitor_lock.id, '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' eoi_modified flag = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, p_fde^.flags.eoi_modified);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' wire_eoi_page flag = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, p_fde^.flags.wire_eoi_page);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' active_shadow_file flag = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, p_fde^.flags.active_shadow_file);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' global_file_name = ',
            clc$no_trim, amc$start, status);
      display_binary_unique_name (p_fde^.global_file_name);
      clp$put_partial_display (display_control, ' file_hash_thread = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fde^.file_hash_thread);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' attached_in_write_count = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fde^.attached_in_write_count);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' attach_count = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, p_fde^.attach_count);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' open_count = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, p_fde^.open_count);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' file_kind = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, file_kind [p_fde^.file_kind]);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' file_hash = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, p_fde^.file_hash);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' locked_for_read = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, p_fde^.segment_lock.locked_for_read: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' locked_for_write = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, p_fde^.segment_lock.locked_for_write: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' task_queue:  ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, ' head = ', p_fde^.segment_lock.task_queue.head: #(16), '(16) ',
            '  tail = ', p_fde^.segment_lock.task_queue.tail: #(16), '(16)');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' asti = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, p_fde^.asti: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' eoi_byte_address = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fde^.eoi_byte_address: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' eoi_state = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fde^.eoi_state);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' allocation_unit_size = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fde^.allocation_unit_size);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' transfer_unit_size = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fde^.transfer_unit_size);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' file_limit = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, p_fde^.file_limit: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' queue_status = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, queue_status [p_fde^.queue_status]);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' preset_value = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fde^.preset_value: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' time_last_modified = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fde^.time_last_modified: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' last_segment_number = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fde^.last_segment_number: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' global_task_id:  ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, ' index = ', p_fde^.global_task_id.index: #(16), '(16) ',
            ' seqno = ', p_fde^.global_task_id.seqno: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' stack_for_ring = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fde^.stack_for_ring: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' media = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, media [p_fde^.media]);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      CASE p_fde^.media OF
      = gfc$fm_mass_storage_file =
        clp$put_partial_display (display_control, ' disk_file_descriptor_p = ',
              clc$no_trim, amc$start, status);
        STRINGREP (line, l, p_fde^.disk_file_descriptor_p: #(16), '(16) ');
        clp$put_partial_display (display_control, line (1, l), clc$trim,
              amc$terminate, status);
      = gfc$fm_served_file =
        clp$put_partial_display (display_control, ' served_file_descriptor_p = ',
              clc$no_trim, amc$start, status);
        STRINGREP (line, l, p_fde^.served_file_descriptor_p: #(16), '(16) ');
        clp$put_partial_display (display_control, line (1, l), clc$trim,
              amc$terminate, status);
      ELSE
      CASEND;

    PROCEND display_fde;
?? EJECT ??

    PROCEDURE display_fmd;

      VAR
        allocation_style: [STATIC, READ, oss$job_paged_literal] array [dmt$allocation_styles] of string
              (10) := ['dmc$a0', 'dmc$a1', 'dmc$a2', 'dmc$a3', 'dmc$a4',
              'dmc$a5', 'dmc$a6', 'dmc$a7', 'dmc$a8', 'dmc$acyl'],
        l: integer,
        line: string (132);

      clp$new_display_line (display_control, 1, status);
      STRINGREP (line, l, ' File Medium Descriptor ', path, ' Sfid ', sfid: #(16));
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$new_display_line (display_control, 1, status);

      clp$put_partial_display (display_control, ' system_file_id = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, p_fmd^.system_file_id.file_entry_index: #(16), '(16) ',
            p_fmd^.system_file_id.residence: #(16), '(16) ',
            p_fmd^.system_file_id.file_hash: #(16), '(16) ', ' ( ',
            csr [p_fmd^.system_file_id.residence],
            ' ) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' avt_index = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, p_fmd^.avt_index);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' device_file_list_index = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fmd^.dfl_index);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' delete_logging_count = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fmd^.delete_logging_count);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' volume assigned = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fmd^.volume_assigned);
      clp$put_partial_display (display_control, '', clc$trim, amc$terminate,
            status);
      clp$put_partial_display (display_control, ' fmd_allocated_length = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fmd^.fmd_allocated_length: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' bytes_per_mau = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fmd^.bytes_per_mau: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' daus_per_cylinder = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fmd^.daus_per_cylinder: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' daus_per_allocation_unit = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fmd^.daus_per_allocation_unit: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' internal_vsn = ',
            clc$no_trim, amc$start, status);
      display_binary_unique_name (p_fmd^.internal_vsn);
      clp$put_partial_display (display_control, ' maus_per_dau = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fmd^.maus_per_dau: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' maus_per_transfer_unit = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fmd^.maus_per_transfer_unit: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' p_next_fmd = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fmd^.p_next_fmd);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$put_partial_display (display_control, ' allocation_style = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, allocation_style [p_fmd^.allocation_style]);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      logical_unit := dmv$p_active_volume_table^ [p_fmd^.avt_index].
            logical_unit_number;

    PROCEND display_fmd;
?? EJECT ??

    PROCEDURE display_fau_entry;

      VAR
        index,
        cylinder,
        track,
        sector,
        sector_offset_within_cylinder,
        mau,
        maus_per_position: integer,
        line: string (132),
        fau_sts: [STATIC, READ, oss$job_paged_literal] array [dmt$fau_states] of string (32) :=
              ['dmc$fau_free', 'dmc$fau_invalid_data',
              'dmc$fau_invalid_and_flawed', 'dmc$fau_initialized',
              'dmc$fau_initialized_and_flawed',
              'dmc$fau_initialization_in_prog'],
        l: integer;

      IF p_fau_entry^.state = dmc$fau_free THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, ' address = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_fau_entry^.dau_address);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$continue, status);
      clp$put_partial_display (display_control, ' state = ', clc$no_trim,
            amc$continue, status);
      clp$put_partial_display (display_control, fau_sts [p_fau_entry^.state],
            clc$trim, amc$continue, status);
      clp$put_partial_display (display_control, ' fmd = ',
            clc$no_trim, amc$continue, status);
      STRINGREP (line, l, p_fau_entry^.fmd_index);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$continue, status);
      clp$put_partial_display (display_control, ' offset = ',
            clc$no_trim, amc$continue, status);
      STRINGREP (line, l, (level_1_index * p_dfd^.bytes_per_level_2) +
          (level_2_index * p_dfd^.bytes_per_allocation): #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$continue, status);

      mau := p_fau_entry^.dau_address * p_fmd^.maus_per_dau;
      maus_per_position := p_fmd^.daus_per_cylinder * p_fmd^.maus_per_dau;

      index := cmv$logical_unit_table^ [logical_unit].unit_interface_table^.
            unit_type - 100(16) + 1;
      cylinder := mau DIV maus_per_position;
      sector_offset_within_cylinder := (mau - (cylinder * maus_per_position)) *
            iov$disk_type_table [index].sectors_per_mau;

      track := sector_offset_within_cylinder DIV
            iov$disk_type_table [index].sectors_per_track;
      sector := sector_offset_within_cylinder -
            (track * iov$disk_type_table [index].sectors_per_track);

{Check for errors in disk address.

      IF sector >= iov$disk_type_table [index].sectors_per_track THEN
        sector := -1;
      IFEND;
      IF track >= iov$disk_type_table [index].tracks_per_cylinder THEN
        track := -1;
      IFEND;
      IF cylinder >= iov$disk_type_table [index].cylinders_per_unit THEN
        cylinder := -1;
      IFEND;

      STRINGREP (line, l, ' C = ', cylinder, ' T = ', track, ' S = ',
            sector);

      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);


    PROCEND display_fau_entry;
?? EJECT ??

    PROCEDURE display_dfd;

      VAR
        line: string (132),
        l: integer;

      clp$new_display_line (display_control, 1, status);
      STRINGREP (line, l, ' Disk File Descriptor ', path, ' Sfid ', sfid: #(16));
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
      clp$new_display_line (display_control, 1, status);

      clp$put_partial_display (display_control, ' read_write_count = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.read_write_count);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' delete_count = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.delete_count);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' purged = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, p_dfd^.purged);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' restricted_attach = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.restricted_attach);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' bytes_per_allocation = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.bytes_per_allocation: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' file_allocation_table = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.file_allocation_table);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' fat_upper_bound = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.fat_upper_bound);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' current_fmd_index = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.current_fmd_index);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' highest_offset_allocated = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.highest_offset_allocated: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' bytes_per_level_2 = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.bytes_per_level_2: #(16), '(16) ');
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' file_damaged = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.file_damaged);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' damaged_detection_enabled = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.damaged_detection_enabled);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' dfd_modified = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.dfd_modified);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' overflow_allowed = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.overflow_allowed);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control,
            ' requested_allocation_size = ', clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.requested_allocation_size);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' requested_class = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.requested_class);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' requested_class_ordinal = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.requested_class_ordinal);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' requested_transfer_size = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.requested_transfer_size);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' requested_volume = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.requested_volume.recorded_vsn,
            p_dfd^.requested_volume.setname);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' number_of_fmds = ',
            clc$no_trim, amc$start, status);
      STRINGREP (line, l, p_dfd^.number_of_fmds);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' p_fmd = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, p_dfd^.p_fmd);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);

      clp$put_partial_display (display_control, ' fmd_modified = ', clc$no_trim,
            amc$start, status);
      STRINGREP (line, l, p_dfd^.fmd_modified);
      clp$put_partial_display (display_control, line (1, l), clc$trim,
            amc$terminate, status);
    PROCEND display_dfd;
?? EJECT ??

    PROCEDURE display_binary_unique_name
      (    binary_unique_name: ost$binary_unique_name);

      VAR
        status: ost$status,
        unique_name: ost$name;

      pmp$convert_binary_unique_name (binary_unique_name, unique_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, unique_name, clc$trim,
            amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND display_binary_unique_name;
?? EJECT ??

    VAR
      dau_discontinuities: integer,
      dau_discontinuities_percentage: real,
      dau_total: integer,
      daus_per_allocation_unit: dmt$daus_per_allocation,
      fmd_number: dmt$fmd_index,
      illegal_mainframe_job_file: boolean,
      level_1_index: dmt$level_1_index,
      level_2_index: dmt$level_2_index,
      line: string (132),
      line_length: integer,
      logical_unit: iot$logical_unit,
      number_of_bytes_to_allocate: amt$file_byte_address,
      number_of_fmds: dmt$fmd_index,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fau_entry: ^dmt$file_allocation_unit,
      p_fde: gft$file_desc_entry_p,
      p_fmd: ^dmt$file_medium_descriptor,
      p_level_2: ^dmt$level_2_table,
      previous_dau: dmt$dau_address,
      sdtxe_p: ^mmt$segment_descriptor_extended,
      sfid: 0 .. 0ffffffff(16),
      str: string (132),
      system_file_id: dmt$system_file_id,
      xcb_p: ^ost$execution_control_block;

    clp$new_display_page (display_control, status);

    pmp$find_executing_task_xcb (xcb_p);
    sdtxe_p := mmp$get_sdtx_entry_p (xcb_p, #SEGMENT(p));
    system_file_id := sdtxe_p^.sfid;

    #unchecked_conversion (system_file_id, sfid);

    gfp$get_fde_p (system_file_id, p_fde);
    display_fde;

    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
    IF p_dfd <> NIL THEN
      display_dfd;
      number_of_fmds := p_dfd^.number_of_fmds;
      FOR fmd_number := 1 TO number_of_fmds DO
        dmp$get_fmd_by_index (p_dfd, fmd_number, p_fmd);
        IF (p_fmd <> NIL) AND (p_fmd^.in_use) THEN
          IF fmd_number = 1 THEN
            daus_per_allocation_unit := p_fmd^.daus_per_allocation_unit;
          IFEND;
          display_fmd;
        IFEND;
      FOREND;
      IF full_listing THEN
        clp$new_display_line (display_control, 1, status);
        clp$put_partial_display (display_control, ' File Allocation Units', clc$trim,
              amc$terminate, status);
        clp$new_display_line (display_control, 1, status);
      IFEND;
      dau_total := 0;
      dau_discontinuities := 0;
      IF p_dfd^.file_allocation_table <> NIL THEN
        FOR level_1_index := 0 TO p_dfd^.fat_upper_bound DO
          dmp$get_level_2_ptr (^p_dfd^.file_allocation_table^ [level_1_index], p_level_2);
          IF p_level_2 <> NIL THEN
            FOR level_2_index := 0 TO (p_dfd^.bytes_per_level_2 DIV p_dfd^.bytes_per_allocation - 1) DO
              p_fau_entry := ^p_level_2^ [level_2_index];
              IF p_fau_entry^.state <> dmc$fau_free THEN
                dau_total := dau_total + 1;
              IFEND;
              IF (level_2_index > 0) AND (p_fau_entry^.state <> dmc$fau_free) AND
                    (p_fau_entry^.dau_address <> (previous_dau + daus_per_allocation_unit)) THEN
                dau_discontinuities := dau_discontinuities + 1;
              IFEND;
              previous_dau := p_fau_entry^.dau_address;
              IF full_listing THEN
                display_fau_entry;
              IFEND;
            FOREND;
          IFEND;
        FOREND;
      IFEND;

      clp$new_display_line (display_control, 1, status);
      clp$put_partial_display (display_control, ' Fragmentation Statistics', clc$trim,
            amc$terminate, status);
      clp$new_display_line (display_control, 1, status);
      STRINGREP (line, line_length, '   Allocation Unit (DAU) Total = ', dau_total);
      clp$put_partial_display (display_control, line (1, line_length), clc$trim, amc$terminate, status);
      STRINGREP (line, line_length, '   Allocation Unit (DAU) Discontinuities = ', dau_discontinuities);
      clp$put_partial_display (display_control, line (1, line_length), clc$trim, amc$terminate, status);
      dau_discontinuities_percentage := $REAL(dau_discontinuities * 100) / $REAL(dau_total);
      STRINGREP (line, line_length, '   Percentage of Discontinuities = ', dau_discontinuities_percentage:6:1,
            '%');
      clp$put_partial_display (display_control, line (1, line_length), clc$trim, amc$terminate, status);
    IFEND;
  PROCEND dmp$display_file_tables;
MODEND dmm$display_file_tables



*DECK DECK=DMM$DISPLAY_MASS_STORAGE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Device Management : VED MS Display' ??

MODULE dmm$display_mass_storage;
{
{  This module is placed on the following library
{   OSF$JOB_TEMPLATE_223

{
{ PURPOSE:
{  This module contains the ring 3 procedure that executes the
{  DISPLAY_MASS_STORAGE Operator Facility Command.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc dmt$active_volume_table_index
*copyc dmt$error_condition_codes
*copyc dmt$out_of_space_sets
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc ost$status
*copyc ost$string
?? POP ??
*copyc amp$put_next
*copyc clp$put_display
*copyc clp$new_display_line
*copyc clp$open_display_file
*copyc clp$close_display
*copyc dpp$put_next_line
*copyc dpp$clear_window
*copyc dmp$get_allocation_info
*copyc ofp$open_display
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc dmv$active_volume_table
?? TITLE := '[XDCL, #GATE] dmp$display_mass_storage', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$display_mass_storage
    (    wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'abort_handler', EJECT ??
    PROCEDURE abort_handler (condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      IF wid = 0 THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??
    VAR
      allocation_info: dmt$allocation_info,
      avt_index: dmt$active_volume_table_index,
      class: dmt$class_member,
      class_index: integer,
      classes: dmt$class,
      dmv$q_devices_added: [XREF] integer,
      display_control: clt$display_control,
      display_line: string (80),
      ignore_status: ost$status,
      index: integer,
      integer_string: string (16),
      line: string (132),
      line_length: integer,
      name_length: integer,
      p_out_of_space_sets: ^dmt$out_of_space_sets,
      set_count: integer,
      set_name: stt$set_name,
      string_length: integer,
      vsn: rmt$recorded_vsn,
      title: [READ, oss$job_paged_literal] string (80) :=
            ' Index  VSN    MAT Space    Status     Alloc  DAT Space    Transfer Count       ';

    status.normal := TRUE;

    IF wid=0 THEN
      osp$establish_block_exit_hndlr (^abort_handler);
    IFEND;

    IF initial_call OR (wid = 0) THEN
      ofp$open_display (file_name, wid, dpc$wc_sharing, dpc$wk_table, title, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    line_length := 80;
    IF (wid = 0) THEN
      IF (display_control.page_width > line_length) THEN
        IF (display_control.page_width > STRLENGTH (line)) THEN
          line_length := STRLENGTH (line);
        ELSE
          line_length := display_control.page_width;
        IFEND;
      IFEND;
    IFEND;

  /display_open/
    BEGIN

      IF wid=0 THEN
        display_line := '  ';
        clp$put_display (display_control, display_line, clc$trim, status);
      ELSE
        dpp$clear_window (wid, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      PUSH p_out_of_space_sets: [1 .. UPPERBOUND (dmv$p_active_volume_table^) + 1];
      dmp$get_out_of_space_sets (p_out_of_space_sets^, set_count);

      FOR index := 1 TO set_count DO
        set_name := p_out_of_space_sets^ [index].set_name;
        classes := p_out_of_space_sets^ [index].classes;
        IF (classes <> $dmt$class []) THEN
          IF (set_name = osc$null_name) THEN
            STRINGREP (line, string_length, ' Classes out of space:');
          ELSE
            name_length := STRLENGTH (set_name);
            WHILE (name_length > 0) AND (set_name (name_length) = ' ') DO
              name_length := name_length - 1;
            WHILEND;
            STRINGREP (line, string_length, ' ', set_name (1, name_length), ' classes out of space:');
          IFEND;
          class_index := string_length + 1;

          FOR class := LOWERVALUE (dmt$class_member) TO UPPERVALUE (dmt$class_member) DO
            IF class IN classes THEN
              IF (class_index >= line_length) THEN
                IF wid = 0 THEN
                  clp$put_display (display_control, line (1, class_index - 1), clc$trim, status);
                ELSE
                  dpp$put_next_line (wid, line (1, class_index - 1), status);
                IFEND;
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                line (1, string_length) := ' ';
                class_index := string_length + 1;
              IFEND;
              line (class_index, 1) := ' ';
              line (class_index + 1, 1) := $CHAR ($INTEGER (class));
              class_index := class_index + 2;
            IFEND;
          FOREND;

          IF wid = 0 THEN
            clp$put_display (display_control, line (1, class_index - 1), clc$trim, status);
          ELSE
            dpp$put_next_line (wid, line (1, class_index - 1), status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND;

      IF dmv$q_devices_added <> 0 THEN
        display_line := '  ';
        STRINGREP (display_line, string_length, ' Class Q devices automatically added: ',
          dmv$q_devices_added);
        IF wid = 0 THEN
          clp$put_display (display_control, display_line, clc$trim, status);
        ELSE
          dpp$put_next_line (wid, display_line, status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    /display_volume/
      FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND (dmv$p_active_volume_table^) DO

        IF dmv$p_active_volume_table^ [avt_index].entry_available THEN
          CYCLE /display_volume/;
        IFEND;

        vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;

        display_line (1, * ) := ' ';
        STRINGREP (integer_string, string_length, avt_index);
        display_line (2, string_length) := integer_string;
        display_line (2 + string_length, 1) := '.';
        display_line (8, 6) := vsn;

        IF NOT dmv$p_active_volume_table^ [avt_index].mass_storage.volume_unavailable THEN

          dmp$get_allocation_info (vsn, allocation_info, status);
          IF status.normal THEN

            STRINGREP (integer_string, string_length, allocation_info.available_mat_space);
            display_line (16, string_length) := integer_string;

            IF allocation_info.no_space THEN
              display_line (28, 8) := 'no space';
            ELSEIF allocation_info.no_file_entries THEN
              display_line (28, 8) := 'no files';
            ELSEIF allocation_info.space_low THEN
              display_line (28, 9) := 'space low';
            ELSEIF allocation_info.file_entries_low THEN
              display_line (28, 9) := 'files low';
            ELSE
              display_line (28, 6) := 'normal';
            IFEND;

            IF allocation_info.allocation_allowed THEN
              display_line (40, 4) := 'true';
            ELSE
              display_line (40, 5) := 'false';
            IFEND;

            STRINGREP (integer_string, string_length, allocation_info.available_dat_space);
            display_line (47, string_length) := integer_string;

            STRINGREP (integer_string, string_length, allocation_info.device_log_count);
            display_line (62, string_length) := integer_string;

          ELSE {probably an io error reading the DAT}
            display_line (16, *) := 'No available information';
          IFEND;
        ELSE
          IF NOT dmv$p_active_volume_table^ [avt_index].mass_storage.logging_process_damaged THEN
            display_line (16, *) := 'Volume is not available';
          ELSE
            display_line (16, *) := 'Volume is not available - logging process damaged';
          IFEND;
        IFEND;

        IF wid = 0 THEN
          clp$put_display (display_control, display_line, clc$trim, status);
        ELSE
          dpp$put_next_line (wid, display_line, status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      FOREND /display_volume/;

    END /display_open/;

    IF wid = 0 THEN
      clp$close_display (display_control, status);
      osp$disestablish_cond_handler;
    IFEND;


  PROCEND dmp$display_mass_storage;
?? TITLE := '[XDCL, #GATE] dmp$get_out_of_space_sets', EJECT ??
*copy dmh$get_out_of_space_sets

  PROCEDURE [XDCL, #GATE] dmp$get_out_of_space_sets (VAR out_of_space_sets: dmt$out_of_space_sets;
    VAR set_count: integer);

    VAR
      avt_index: dmt$active_volume_table_index,
      classes: dmt$class,
      defined_system_classes: dmt$class,
      maximum_set_count: integer,
      non_system_classes: dmt$class,
      not_out: boolean,
      not_out_system_classes: dmt$class,
      p_defined_classes: ^array [1 .. *] of dmt$class,
      p_not_out_classes: ^array [1 .. *] of dmt$class,
      set_index: integer,
      set_name: stt$set_name,
      system_classes: dmt$class;

    maximum_set_count := UPPERBOUND (dmv$p_active_volume_table^) + 1;
    IF (maximum_set_count > UPPERBOUND (out_of_space_sets)) THEN
      maximum_set_count := UPPERBOUND (out_of_space_sets);
    IFEND;
    PUSH p_defined_classes: [1 .. maximum_set_count];
    PUSH p_not_out_classes: [1 .. maximum_set_count];
    set_count := 1;
    defined_system_classes := $dmt$class [];
    not_out_system_classes := $dmt$class [];

    FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND (dmv$p_active_volume_table^) DO
      IF NOT dmv$p_active_volume_table^ [avt_index].entry_available THEN
        classes := dmv$p_active_volume_table^ [avt_index].mass_storage.class;
        set_name := dmv$p_active_volume_table^ [avt_index].mass_storage.set_name;
        out_of_space_sets [1].set_name := set_name;
        set_index := set_count;
        WHILE (out_of_space_sets [set_index].set_name <> set_name) DO
          set_index := set_index - 1;
        WHILEND;

        IF (set_index = 1) THEN {set not in table}
          IF (set_count < maximum_set_count) AND (set_name <> osc$null_name) THEN
            set_count := set_count + 1;
            set_index := set_count;
            out_of_space_sets [set_index].set_name := set_name;
          IFEND;
          p_defined_classes^ [set_index] := $dmt$class [];
          p_not_out_classes^ [set_index] := $dmt$class [];
        IFEND;

        defined_system_classes := defined_system_classes + classes;
        p_defined_classes^ [set_index] := p_defined_classes^ [set_index] + classes;

        not_out := NOT dmv$p_active_volume_table^ [avt_index].mass_storage.space_gone AND
                   dmv$p_active_volume_table^ [avt_index].mass_storage.allocation_allowed AND
                   NOT dmv$p_active_volume_table^ [avt_index].mass_storage.volume_unavailable;
        IF not_out THEN
          not_out_system_classes := not_out_system_classes + classes;
          p_not_out_classes^ [set_index] := p_not_out_classes^ [set_index] + classes;
        IFEND;
      IFEND;
    FOREND;

    system_classes := $dmt$class ['N', 'Q'];
    non_system_classes := - system_classes;

    out_of_space_sets [1].set_name := osc$null_name;
    out_of_space_sets [1].classes := (defined_system_classes - not_out_system_classes) * system_classes;

    FOR set_index := 2 TO set_count DO
      out_of_space_sets [set_index].classes :=
            (p_defined_classes^ [set_index] - p_not_out_classes^ [set_index]) * non_system_classes;
    FOREND;
  PROCEND dmp$get_out_of_space_sets;
?? OLDTITLE ??
MODEND dmm$display_mass_storage;
*DECK DECK=DMM$DISPLAY_MASS_STORE_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Device Management : Display_Mass_Store Command' ??
MODULE dmm$display_mass_store_command;

{ PURPOSE:
{  This module contains the run anywhere procedure that executes the DISPLAY_MASS_STORAGE command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
?? POP ??
*copyc clp$evaluate_parameters
*copyc jmp$system_job
*copyc ofp$execute_display_task
  CONST
    ms_display = 'MS_DISPLAY                     ';

?? TITLE := 'dmp$display_mass_store_command', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$display_mass_store_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_mass_store, disms (
{   output, o: file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 12, 1, 13, 2, 22, 297],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Process the OUTPUT parameter in such a way that DISPLAY_A is treated as a normal file name if this is
    { not the system job. If the OUTPUT parameter is not specified, then send the display data to DISPLAY_A
    { if this is the system job and to $OUTPUT otherwise.

    IF pvt [p$output].specified THEN
      ofp$execute_display_task (pvt [p$output].value^.file_value^, ms_display, status);
    ELSE
      IF jmp$system_job () THEN
        ofp$execute_display_task ('$LOCAL.DISPLAY_A', ms_display, status);
      ELSE
        ofp$execute_display_task ('$OUTPUT', ms_display, status);
      IFEND;
    IFEND;

  PROCEND dmp$display_mass_store_command;
MODEND dmm$display_mass_store_command;
*DECK DECK=DMM$FETCH_PAGE_STATUS EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE : Device Management - dmm$fetch_page_status' ??
MODULE dmm$fetch_page_status;

{ PURPOSE:
{   This module contain the following procedures:
{
{      dmp$fetch_page_status - used by memory manager to determine whether a
{           page is on disk or is a new page to be created.
{      dmp$fetch_multi_page_status - used by memory  manager to check
{           page status on a range of pages.
{

?? PUSH (LISTEXT := ON) ??
*copyc dmt$file_allocation_status
*copyc dmt$file_descriptor_entry
*copyc dmv$active_volume_table
*copyc gft$page_status
?? POP ??
?? NEWTITLE := '  XREF Procedures', EJECT ??
*copyc dmp$allocate_file_space
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_fau_entry
*copyc dmp$get_fmd_by_index
*copyc mtp$error_stop
?? OLDTITLE, NEWTITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc sft$file_space_limit_kind
?? POP ??


{ The following variable contains the number of unavailable volumes. If no volumes
{ are unavailable, then some checks can be skipped.

  VAR
    dmv$number_unavailable_volumes: [XDCL, #GATE] dmt$active_volume_table_index := 0;

?? OLDTITLE ??
?? NEWTITLE := '  [XDCL] dmp$fetch_page_status', EJECT ??
{
{ PURPOSE:
{    This procedure is used by memory manager to determine the residency of a page.
{    If the page is on disk, MM will issue IO requests to read the page; if the page
{    is not on disk, before creating a new page, MM must ensure that the page
{    can be written to disk. This requires space to be allocated.
{
{    If the space resides on a down-volume or if the space cannot be allocated, an
{    error is returned
{


  PROCEDURE [XDCL] dmp$fetch_page_status
    (    fde_p: gft$locked_file_desc_entry_p;
         offset: ost$segment_offset; {will be on page boundary}
         enforce_limits: sft$file_space_limit_kind;
         allow_allocation: boolean;
     VAR page_status: gft$page_status);



    VAR
      allocate_status: dmt$file_allocation_status,
      dfd_p: ^dmt$disk_file_descriptor,
      fau_entry_p: ^dmt$file_allocation_unit,
      fmd_p: ^dmt$file_medium_descriptor,
      overflow: boolean,
      units_obtained: amt$file_byte_address;


{ Get pointers to tables. If no FAT entry is assigned, reject and fix it in job mode.

    dmp$get_disk_file_descriptor_p (fde_p, dfd_p);
    dmp$get_fau_entry (dfd_p, offset, fau_entry_p);
    IF fau_entry_p = NIL THEN
      page_status := gfc$ps_job_mode_work_required;
      RETURN;
    IFEND;


{ If no volumes are unavailable, the check of the FMD can be skipped. Otherwise, look at
{ the FMD/AVT and determine if the page resides on an unavailable volume.

    IF (dmv$number_unavailable_volumes > 0) AND (fau_entry_p^.state > dmc$fau_free) THEN
      dmp$get_fmd_by_index (dfd_p, fau_entry_p^.fmd_index, fmd_p);
      IF dmv$p_active_volume_table^ [fmd_p^.avt_index].mass_storage.volume_unavailable THEN
        page_status := gfc$ps_volume_unavailable;
        RETURN;
      IFEND;
    IFEND;


{ Determine page status from the FAU status. If no space assigned and the caller wants allocation,
{ call the allocator to assign space.

    CASE fau_entry_p^.state OF
    = dmc$fau_invalid_data, dmc$fau_invalid_and_flawed, dmc$fau_initialization_in_prog =
      page_status := gfc$ps_page_doesnt_exist;

    = dmc$fau_initialized, dmc$fau_initialized_and_flawed =
      IF offset < fde_p^.eoi_byte_address THEN
        page_status := gfc$ps_page_on_disk;
      ELSE
        page_status := gfc$ps_page_doesnt_exist;
      IFEND;

    = dmc$fau_free =
      page_status := gfc$ps_page_doesnt_exist;
      IF allow_allocation THEN
        dmp$allocate_file_space (fde_p, offset, 1, enforce_limits, units_obtained, overflow, allocate_status);

        CASE allocate_status OF
        = dmc$fas_file_allocated =
        = dmc$fas_temp_reject =
          page_status := gfc$ps_temp_reject;
        = dmc$fas_account_limit_exceeded =
          page_status := gfc$ps_account_limit_exceeded;
        = dmc$fas_job_mode_work_required =
          page_status := gfc$ps_job_mode_work_required;
        ELSE
          mtp$error_stop ('bad allocate status');
        CASEND;
      IFEND;

    ELSE
      mtp$error_stop ('bad fau status - dmp$fetch_page_status');
    CASEND;

  PROCEND dmp$fetch_page_status;

?? OLDTITLE ??
?? NEWTITLE := '  [XDCL] dmp$fetch_multi_page_status', EJECT ??
{
{ PURPOSE:
{    This procedure verifies that a range of pages resides on accessible volumes.
{    Space is assigned if it is not already assigned.
{    If the space is on a down-volume or if space cannot be assigned, a reject is returned.
{
{    This request is similar to DMP$FETCH_PAGE_STATUS except that it does not return
{    information about whether pages are on disk.
{
{   !NOTE - performance of this request can be improved if necessary.
{

  PROCEDURE [XDCL] dmp$fetch_multi_page_status
    (    fde_p: gft$locked_file_desc_entry_p;
         offset: ost$segment_offset; {will be on page boundary}
         length: ost$segment_length; {will be multiple of page size
         enforce_limits: sft$file_space_limit_kind;
     VAR reject_offset: ost$segment_offset;
     VAR page_status: gft$page_status);

    VAR
      allocation_unit_size: integer,
      current_offset: integer,
      last_offset: integer;

    allocation_unit_size := fde_p^.allocation_unit_size;
    current_offset := (offset DIV allocation_unit_size) * allocation_unit_size;
    last_offset := ((offset + length - 1) DIV allocation_unit_size) * allocation_unit_size;

    REPEAT
      dmp$fetch_page_status (fde_p, current_offset, enforce_limits, TRUE, page_status);
      IF (page_status <> gfc$ps_page_doesnt_exist) AND (page_status <> gfc$ps_page_on_disk) THEN
        reject_offset := current_offset;
        RETURN;
      IFEND;
      current_offset := current_offset + allocation_unit_size;
    UNTIL current_offset > last_offset;

  PROCEND dmp$fetch_multi_page_status;

?? OLDTITLE ??
MODEND dmm$fetch_page_status;
*DECK DECK=DMM$FILE_ACCESS_ROUTINES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$file_access_routines;
{
{   PURPOSE:
{      This module contains procedures used to access device management
{    tables.
{   DESIGN:
{      The device management tables are accessed as segment access files.
{
?? OLDTITLE ??
?? NEWTITLE := '  Declarations' ??
?? PUSH (LISTEXT := ON) ??
*copyc dmt$ms_device_allocation_table
*copyc dmt$ms_device_file_list_entry
*copyc dmt$error_condition_codes
*copyc dmt$ms_volume_label
*copyc dmt$ms_volume_directory
*copyc dmt$ms_login_table
*copyc mme$condition_codes
*copyc dmp$open_file
*copyc osp$set_status_abnormal
*copyc syp$continue_to_cause
*copyc syp$disestablish_cond_handler
*copyc syp$establish_condition_handler
?? POP ??
?? TITLE := '  dmp$open_dflt', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copy dmh$open_dflt
?? POP ??
  PROCEDURE [XDCL, #GATE] dmp$open_dflt (dflt_sfid: dmt$system_file_id;
                                         ring1: ost$valid_ring;
                                         ring2: ost$valid_ring;
                                         access_rights: mmt$segment_access_rights;
                                         access_selections: mmt$access_selections;
                                     VAR p_dflt: ^dmt$ms_device_file_list_table;
                                     VAR status: ost$status);

?? SKIP := 1 ??
    PROCEDURE handler (mf: ost$monitor_fault;
                       p_msa: ^ost$minimum_save_area;
                   VAR continue: syt$continue_option);
      VAR
        p_scc: ^syt$system_core_condition,
        p_sac: ^mmt$segment_access_condition;

      IF mf.identifier = mmc$segment_fault_processor_id THEN
        p_sac := #LOC(mf.contents);
        CASE p_sac^.identifier OF
        = mmc$sac_io_read_error =
          osp$set_status_abnormal ('MM', mme$io_read_error,
             'io error opening DFLT - dmp$open_dflt', status);
          EXIT dmp$open_dflt;
        ELSE
        CASEND;

      ELSEIF mf.identifier = syc$system_core_condition THEN
        p_scc := #LOC(mf.system_core_condition);
        CASE p_scc^.condition OF
        = syc$user_defined_condition =
          IF p_scc^.user_defined_condition = syc$udc_volume_unavailable THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable,
                'volume unavailable in dmp$open_dflt', status);
            EXIT dmp$open_dflt;
          IFEND;
        ELSE
        CASEND;
      IFEND;

      syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);

    PROCEND handler;
?? SKIP := 1 ??

    VAR
      segment_pointer: mmt$segment_pointer,
      p_dflt_seq: ^SEQ ( * ),
      p_dflt_header: ^dmt$ms_device_file_list_header,
      number_dflt_entries: dmt$device_file_list_index;

    status.normal := TRUE;

    p_dflt := NIL;
    segment_pointer.kind := mmc$sequence_pointer;

    dmp$open_file (dflt_sfid, ring1, ring2, access_rights, access_selections,
          segment_pointer, status);
    IF status.normal THEN

      p_dflt_seq := segment_pointer.seq_pointer;
      RESET p_dflt_seq;

      NEXT p_dflt_header IN p_dflt_seq;
      IF p_dflt_header = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$open_dflt_failure,
          'NEXT nil during open of dfl header - dmp$open_dflt', status);
      IFEND;

      IF status.normal THEN

        syp$establish_condition_handler (^handler);
        number_dflt_entries := p_dflt_header^.number_of_entries;
        syp$disestablish_cond_handler;

        RESET p_dflt_seq;

        NEXT p_dflt: [1 .. number_dflt_entries] IN p_dflt_seq;
        IF p_dflt = NIL THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$open_dflt_failure,
            'NEXT nil during open of dflt - dmp$open_dflt', status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND dmp$open_dflt;
?? TITLE := '  dmp$open_dat', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copy dmh$open_dat
?? POP ??
  PROCEDURE [XDCL, #GATE] dmp$open_dat (dat_sfid: dmt$system_file_id;
                                        ring1: ost$valid_ring;
                                        ring2: ost$valid_ring;
                                        access_rights: mmt$segment_access_rights;
                                        access_selections: mmt$access_selections;
                                    VAR p_dat: ^dmt$ms_device_allocation_table;
                                    VAR status: ost$status);

?? SKIP := 1 ??
    PROCEDURE handler (mf: ost$monitor_fault;
                       p_msa: ^ost$minimum_save_area;
                   VAR continue: syt$continue_option);
      VAR
        p_scc: ^syt$system_core_condition,
        p_sac: ^mmt$segment_access_condition;

      IF mf.identifier = mmc$segment_fault_processor_id THEN
        p_sac := #LOC(mf.contents);
        CASE p_sac^.identifier OF
        = mmc$sac_io_read_error =
          osp$set_status_abnormal ('MM', mme$io_read_error,
             'io error opening DAT - dmp$open_dat', status);
          EXIT dmp$open_dat;
        ELSE
        CASEND;

      ELSEIF mf.identifier = syc$system_core_condition THEN
        p_scc := #LOC(mf.system_core_condition);
        CASE p_scc^.condition OF
        = syc$user_defined_condition =
          IF p_scc^.user_defined_condition = syc$udc_volume_unavailable THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable,
                'volume unavailable in dmp$open_dat', status);
            EXIT dmp$open_dat;
          IFEND;
        ELSE
        CASEND;
      IFEND;

      syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);

    PROCEND handler;
?? SKIP := 1 ??

    VAR
      segment_pointer: mmt$segment_pointer,
      p_dat_seq: ^SEQ ( * ),
      p_dat_header: ^dmt$ms_device_alloc_table_head,
      number_dat_entries: dmt$dau_address;

    status.normal := TRUE;

    p_dat := NIL;
    segment_pointer.kind := mmc$sequence_pointer;

    dmp$open_file (dat_sfid, ring1, ring2, access_rights, access_selections,
        segment_pointer, status);
    IF status.normal THEN

      p_dat_seq := segment_pointer.seq_pointer;
      RESET p_dat_seq;

      NEXT p_dat_header IN p_dat_seq;
      IF p_dat_header = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$open_dat_failure,
          'NEXT nil during open of dat header - dmp$open_dat', status);
      IFEND;

      IF status.normal THEN

        syp$establish_condition_handler (^handler);
        number_dat_entries := p_dat_header^.number_of_entries;
        syp$disestablish_cond_handler;

        RESET p_dat_seq;

        NEXT p_dat: [0 .. number_dat_entries - 1] IN p_dat_seq;
        IF p_dat = NIL THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$open_dat_failure,
            'NEXT nil during open of dat - dmp$open_dat', status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND dmp$open_dat;
?? TITLE := '  dmp$open_directory', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copy dmh$open_directory
?? POP ??
  PROCEDURE [XDCL, #GATE] dmp$open_directory (directory_sfid: dmt$system_file_id;
                                              ring1: ost$valid_ring;
                                              ring2: ost$valid_ring;
                                              access_rights: mmt$segment_access_rights;
                                              access_selections: mmt$access_selections;
                                          VAR p_directory: ^dmt$ms_volume_directory;
                                          VAR status: ost$status);

?? SKIP := 1 ??
    PROCEDURE handler (mf: ost$monitor_fault;
                       p_msa: ^ost$minimum_save_area;
                   VAR continue: syt$continue_option);
      VAR
        p_scc: ^syt$system_core_condition,
        p_sac: ^mmt$segment_access_condition;

      IF mf.identifier = mmc$segment_fault_processor_id THEN
        p_sac := #LOC(mf.contents);
        CASE p_sac^.identifier OF
        = mmc$sac_io_read_error =
          osp$set_status_abnormal ('MM', mme$io_read_error,
             'io error opening DIRECTORY - dmp$open_directory', status);
          EXIT dmp$open_directory;
        ELSE
        CASEND;

      ELSEIF mf.identifier = syc$system_core_condition THEN
        p_scc := #LOC(mf.system_core_condition);
        CASE p_scc^.condition OF
        = syc$user_defined_condition =
          IF p_scc^.user_defined_condition = syc$udc_volume_unavailable THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable,
                'volume unavailable in dmp$open_directory', status);
            EXIT dmp$open_directory;
          IFEND;
        ELSE
        CASEND;
      IFEND;

      syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);

    PROCEND handler;
?? SKIP := 1 ??

    VAR
      segment_pointer: mmt$segment_pointer,
      p_directory_seq: ^SEQ ( * ),
      number_directory_entries: dmt$directory_index,
      p_directory_header: ^dmt$ms_volume_directory_head;

    status.normal := TRUE;

    segment_pointer.kind := mmc$sequence_pointer;

    dmp$open_file (directory_sfid, ring1, ring2, access_rights, access_selections,
          segment_pointer, status);

    IF status.normal THEN

      p_directory_seq := segment_pointer.seq_pointer;
      RESET p_directory_seq;

      NEXT p_directory_header IN p_directory_seq;
      IF p_directory_header = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$open_directory_failure,
          'NEXT nil during open of directory header - dmp$open_directory', status);
      IFEND;

      IF status.normal THEN

        syp$establish_condition_handler (^handler);
        number_directory_entries := p_directory_header^.number_of_entries;
        syp$disestablish_cond_handler;

        RESET p_directory_seq;

        NEXT p_directory: [1 .. number_directory_entries] IN p_directory_seq;
        IF p_directory = NIL THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$open_directory_failure,
            'NEXT nil during open of directory - dmp$open_directory', status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND dmp$open_directory;
?? TITLE := '  dmp$open_login_table', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copy dmh$open_login_table
?? POP ??
  PROCEDURE [XDCL, #GATE] dmp$open_login_table (sfid: dmt$system_file_id;
                                                ring1: ost$valid_ring;
                                                ring2: ost$valid_ring;
                                                access_rights: mmt$segment_access_rights;
                                                access_selections: mmt$access_selections;
                                            VAR p_login_table: ^dmt$ms_mainframe_login_table;
                                            VAR status: ost$status);

?? SKIP := 1 ??
    PROCEDURE handler (mf: ost$monitor_fault;
                       p_msa: ^ost$minimum_save_area;
                   VAR continue: syt$continue_option);
      VAR
        p_scc: ^syt$system_core_condition,
        p_sac: ^mmt$segment_access_condition;

      IF mf.identifier = mmc$segment_fault_processor_id THEN
        p_sac := #LOC(mf.contents);
        CASE p_sac^.identifier OF
        = mmc$sac_io_read_error =
          osp$set_status_abnormal ('MM', mme$io_read_error,
             'io error opening LOGIN TABLE - dmp$open_login_table', status);
          EXIT dmp$open_login_table;
        ELSE
        CASEND;

      ELSEIF mf.identifier = syc$system_core_condition THEN
        p_scc := #LOC(mf.system_core_condition);
        CASE p_scc^.condition OF
        = syc$user_defined_condition =
          IF p_scc^.user_defined_condition = syc$udc_volume_unavailable THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable,
                'volume unavailable in dmp$open_login_table', status);
            EXIT dmp$open_login_table;
          IFEND;
        ELSE
        CASEND;
      IFEND;

      syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);

    PROCEND handler;
?? SKIP := 1 ??

    VAR
      segment_pointer: mmt$segment_pointer,
      p_login_table_seq: ^SEQ ( * ),
      upper_bound: dmt$login_table_entry_index,
      lower_bound: dmt$login_table_entry_index,
      p_login_table_header: ^dmt$ms_mf_login_table_header;

    status.normal := TRUE;

    segment_pointer.kind := mmc$sequence_pointer;

    dmp$open_file (sfid, ring1, ring2, access_rights, access_selections,
          segment_pointer, status);
    IF status.normal THEN

      p_login_table_seq := segment_pointer.seq_pointer;
      RESET p_login_table_seq;

      NEXT p_login_table_header IN p_login_table_seq;
      IF p_login_table_header = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$open_login_table_failure,
          'NEXT nil during open of login_table header - dmp$open_login_table', status);
      IFEND;

      IF status.normal THEN

        syp$establish_condition_handler (^handler);
        lower_bound := p_login_table_header^.lower_bound;
        upper_bound := p_login_table_header^.upper_bound;
        syp$disestablish_cond_handler;

        RESET p_login_table_seq;

        NEXT p_login_table: [lower_bound .. upper_bound] IN p_login_table_seq;
        IF p_login_table = NIL THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$open_login_table_failure,
            'NEXT nil during open of login_table - dmp$open_login_table', status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND dmp$open_login_table;
?? TITLE := '  dmp$open_label', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copy dmh$open_label
?? POP ??
  PROCEDURE [XDCL, #GATE] dmp$open_label (label_sfid: dmt$system_file_id;
                                          ring1: ost$valid_ring;
                                          ring2: ost$valid_ring;
                                          access_rights: mmt$segment_access_rights;
                                          access_selections: mmt$access_selections;
                                      VAR p_label: ^dmt$ms_volume_label;
                                      VAR status: ost$status);

?? SKIP := 1 ??
    PROCEDURE handler (mf: ost$monitor_fault;
                       p_msa: ^ost$minimum_save_area;
                   VAR continue: syt$continue_option);
      VAR
        p_scc: ^syt$system_core_condition,
        p_sac: ^mmt$segment_access_condition;

      IF mf.identifier = mmc$segment_fault_processor_id THEN
        p_sac := #LOC(mf.contents);
        CASE p_sac^.identifier OF
        = mmc$sac_io_read_error =
          osp$set_status_abnormal ('MM', mme$io_read_error,
             'io error opening LABEL- dmp$open_label', status);
          EXIT dmp$open_label;
        ELSE
        CASEND;

      ELSEIF mf.identifier = syc$system_core_condition THEN
        p_scc := #LOC(mf.system_core_condition);
        CASE p_scc^.condition OF
        = syc$user_defined_condition =
          IF p_scc^.user_defined_condition = syc$udc_volume_unavailable THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable,
                'volume unavailable in dmp$open_label', status);
            EXIT dmp$open_label;
          IFEND;
        ELSE
        CASEND;
      IFEND;

      syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);

    PROCEND handler;
?? SKIP := 1 ??

    VAR
      segment_pointer: mmt$segment_pointer,
      p_label_seq: ^dmt$ms_volume_label,
      p_label_header: ^dmt$volume_label_header,
      p_label_0_0: ^dmt$ms_label_0_0,
      bytes_per_au: amt$file_byte_address,
      number_of_aus: dmt$dau_address,
      p_dat_fat: ^dmt$stored_ms_device_file_fat;

    status.normal := TRUE;

    segment_pointer.kind := mmc$sequence_pointer;

    dmp$open_file (label_sfid, ring1, ring2, access_rights, access_selections,
          segment_pointer, status);
    IF status.normal THEN
      p_label_seq := segment_pointer.seq_pointer;
      RESET p_label_seq;

      NEXT p_label_header IN p_label_seq;
      IF p_label_header = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$open_label_failure,
          'NEXT nil during open of label header - dmp$open_label', status);
      IFEND;

      IF status.normal THEN

        syp$establish_condition_handler (^handler);
        CASE p_label_header^.version_number OF

        = dmc$ms_label_0_0 =
          NEXT p_label_0_0 IN p_label_seq;
          IF p_label_0_0 = NIL THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$open_label_failure,
              'NEXT nil during open of label - dmp$open_label', status);
          IFEND;

          bytes_per_au := p_label_header^.bytes_per_dau * p_label_0_0^.dat_dfl_entry.daus_per_allocation_unit;
          number_of_aus := (p_label_0_0^.dat_dfl_entry.fmd_length + bytes_per_au - 1) DIV bytes_per_au;

        ELSE
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unsupported_label_version,
            'unsupported label version number - dmp$open_label', status);
        CASEND;
        syp$disestablish_cond_handler;

        IF status.normal THEN
          NEXT p_dat_fat: [1 .. number_of_aus] IN p_label_seq;
          IF p_dat_fat = NIL THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$open_label_failure,
              'unable to locate dat fat in label - dmp$open_label', status);
          ELSE
            RESET p_label_seq;
            p_label := p_label_seq;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND dmp$open_label;

MODEND dmm$file_access_routines;
*DECK DECK=DMM$FILE_TABLE_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$file_table_manager;

{
{ PURPOSE:
{
{  The purpose of this module is to manage the system and job file tables from
{  job mode.  This includes creation of the file table, creation and deletion
{  of entries in the table, fetching and updating information stored in the
{  table and locking and unlocking entries in the table.

?? TITLE := '  Common Decks', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dfp$get_served_file_desc_p
*copyc dfp$release_server_descriptor
*copyc dmd$null_global_file_name
*copyc dmp$allocate_file_space_r1
*copyc dmp$change_dfl_damage
*copyc dmp$deallocate_file_space_r1
*copyc dmp$decrement_class_activity
*copyc dmp$free_fmds
*copyc dmp$generate_gfn_hash
*copyc dmp$get_active_vol_attributes
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_fmd_by_index
*copyc dmp$get_level_2_ptr
*copyc dmp$process_device_log_entry
*copyc dmp$search_avt_by_vsn
*copyc dmt$active_volume_table_index
*copyc dmt$assigned_ms_vol_attributes
*copyc dmt$disk_file_descriptor
*copyc dmt$device_log_entries
*copyc dmt$error_condition_codes
*copyc dmt$existing_sft_entry
*copyc dmt$fmd_index
*copyc dmt$file_attributes
*copyc dmt$file_information
*copyc dmt$file_location
*copyc dmt$file_share_history
*copyc dmt$keypoint_calls
*copyc dmt$segment_file_information
*copyc gft$system_file_identifier
*copyc dmv$active_volume_table
*copyc dmv$null_sfid
*copyc dmv$trim_files
*copyc gfp$assign_fde
*copyc gfp$free_fde
*copyc gfp$get_eoi_from_fde
*copyc gfp$get_fde_p
*copyc gfp$get_locked_fde_p
*copyc gfp$get_sfid_from_fde_p
*copyc gfp$lock_fde
*copyc gfp$unlock_fde_p
*copyc gfp$verify_get_fde_p
*copyc gft$locked_file_desc_entry_p
*copyc i#call_monitor
*copyc jmv$jcb
*copyc mmc$null_shared_queue
*copyc mmp$close_device_file
*copyc mmp$open_file_by_sfid
*copyc mmp$preset_conversion
*copyc mmp$issue_ring1_segment_request
*copyc mmt$rb_set_get_segment_length
*copyc osd$virtual_address
*copyc osk$keypoints
*copyc osp$append_status_parameter
*copyc osp$clear_mainframe_sig_lock
*copyc osp$fatal_system_error
*copyc osp$initialize_sig_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$test_set_main_sig_lock
*copyc osp$test_sig_lock
*copyc osp$unpack_status_identifier
*copyc oss$job_fixed
*copyc oss$mainframe_pageable
*copyc ost$caller_identifier
*copyc ost$processor_model_number
*copyc ost$status
*copyc ost$wait
*copyc osv$deadstart_phase
*copyc osv$job_fixed_heap
*copyc osv$mainframe_wired_heap
*copyc osv$page_size
*copyc pfd$permanent_file_attributes
*copyc pmp$get_system_time
*copyc pmp$cycle
*copyc pmp$delay
*copyc sfp$accumulate_file_space
*copyc syp$set_status_from_mtr_status
?? POP ??
?? TITLE := '  Global Variables', EJECT ??
?? FMT (FORMAT := OFF, keyw := upper, ident := lower) ??

  VAR
    default_disk_file_descriptor: [STATIC,READ] dmt$disk_file_descriptor :=
      {read_write_count:=}           [0,
      {delete_count:=}                0,
      {purged:=}                      FALSE,
      {restricted_attach:=}           FALSE,
      {bytes_per_allocation:=}        0,
      {file_allocation_table:=}       NIL,
      {fat_upper_bound:=}             0,
      {current_fad_index:=}           0,
      {highest_offset_allocated:=}    0,
      {bytes_per_level_2:=}           0,
      {dfd_modified:=}                FALSE,
      {overflow_allowed:=}            TRUE,
      {requested_allocation_size:=}   dmc$unspecified_allocation_size,
      {requested_class:=}             dmc$default_class,
      {requested_class_ordinal:=}     dmc$default_class_ordinal,
      {requested_transfer_size:=}     dmc$unspecified_transfer_size,
      {requested_volume:=}            ['    ','    '],
      {number_of_fads:=}              0,
      {p_fmd:=}                       NIL,
      {file_damaged:=}                FALSE,
      {damaged_detection_enabled:=}   FALSE,
      {fmd_modified:=}                FALSE];
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??

  VAR
    file_hash_threads: [STATIC, oss$mainframe_pageable] dmt$active_file_hash_threads :=
        [REP dmc$max_file_hash + 1 of NIL];

  VAR
    master_attach_lock: [STATIC, oss$mainframe_pageable] dmt$active_fde_lock;

  VAR
    dmv$last_file_reassigned: [XDCL, STATIC, oss$mainframe_pageable] gft$system_file_identifier;

?? TITLE := '  dmp$change_file_damaged', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$change_file_damaged (sfid: gft$system_file_identifier;
        file_damaged: boolean;
        global_file_name: dmt$global_file_name;
    VAR status: ost$status);

    VAR
      p_dfd: ^dmt$disk_file_descriptor,
      p_fmd: ^dmt$file_medium_descriptor,
      p_fde: ^gft$file_descriptor_entry;

    status.normal := TRUE;

    gfp$get_locked_fde_p (sfid, p_fde);
    IF p_fde = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
            'Bad SFID - dmp$change_file_damaged.', status);
      RETURN;
    IFEND;

    IF p_fde^.global_file_name = global_file_name THEN
      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
      p_dfd^.file_damaged := file_damaged;
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
        'GFN or SFID is incorrect - dmp$change_file_damaged.', status);
    IFEND;

    IF status.normal THEN
      dmp$get_fmd_by_index (p_dfd, 1, p_fmd);

      IF (file_damaged = TRUE) THEN
        dmp$change_dfl_damage (p_fmd^.avt_index, $dmt$file_damage[dmc$media_image_inconsistent],
          $dmt$file_damage[], p_fmd^.dfl_index, {flush_device_log =} TRUE, p_fde^.global_file_name, status);
      ELSE
        dmp$change_dfl_damage (p_fmd^.avt_index, $dmt$file_damage[],
          $dmt$file_damage[dmc$media_image_inconsistent], p_fmd^.dfl_index, {flush_device_log =} FALSE,
          p_fde^.global_file_name, status);
      IFEND;
    IFEND;

    gfp$unlock_fde_p (p_fde);

  PROCEND dmp$change_file_damaged;
?? TITLE := '  dmp$change_sft_damage_detection', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$change_sft_damage_detection (sfid: gft$system_file_identifier;
        damage_detection: boolean;
        global_file_name: dmt$global_file_name;
    VAR status: ost$status);

    VAR
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry;

    gfp$get_locked_fde_p (sfid, p_fde);
    IF p_fde = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
            'Bad SFID - dmp$change_sft_damage_detection.', status);
    ELSE
      IF p_fde^.global_file_name = global_file_name THEN
        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
        p_dfd^.damaged_detection_enabled := damage_detection;
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
          'GFN or SFID is incorrect - dmp$change_sft_damage_detection.', status);
      IFEND;
      gfp$unlock_fde_p (p_fde);
    IFEND;

  PROCEND dmp$change_sft_damage_detection;
?? TITLE := '  dmp$change_sft_file_damaged', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$change_sft_file_damaged (sfid: gft$system_file_identifier;
        file_damaged: boolean;
        global_file_name: dmt$global_file_name;
    VAR status: ost$status);

    VAR
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry;

    gfp$get_locked_fde_p (sfid, p_fde);
    IF p_fde = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
            'Bad SFID - dmp$change_sft_file_damaged.', status);
    ELSE
      IF p_fde^.global_file_name = global_file_name THEN
        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
        p_dfd^.file_damaged := file_damaged;
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
          'GFN or SFID is incorrect - dmp$change_sft_file_damaged.', status);
      IFEND;
      gfp$unlock_fde_p (p_fde);
    IFEND;

  PROCEND dmp$change_sft_file_damaged;
?? TITLE := '  dmp$clear_master_attach_lock', EJECT ??

  PROCEDURE [XDCL] dmp$clear_master_attach_lock (system_file_id: gft$system_file_identifier);

    osp$clear_mainframe_sig_lock (master_attach_lock [system_file_id.file_hash]);

  PROCEND dmp$clear_master_attach_lock;

?? TITLE := '  dmp$close_file', EJECT ??
*copy dmh$close_file

  PROCEDURE [XDCL, #GATE] dmp$close_file (pva: ^cell;
    VAR status: ost$status);

    status.normal := TRUE;

    mmp$close_device_file (#segment (pva), status);

  PROCEND dmp$close_file;
?? TITLE := '  dmp$complete_sft_delete', EJECT ??

  PROCEDURE [XDCL] dmp$complete_sft_delete (sfid: gft$system_file_identifier;
        fmd_index: dmt$fmd_index;
    VAR status: ost$status);

    VAR
      inactive_file: boolean,
      index: dmt$fmd_index,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      p_fmd: ^dmt$file_medium_descriptor;

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (master_attach_lock [sfid.file_hash]);

    gfp$get_locked_fde_p (sfid, p_fde);
    IF p_fde = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
            'Bad SFID - dmp$complete_sft_delete.', status);
    ELSE
      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
      dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);
      p_fmd^.delete_logging_count := p_fmd^.delete_logging_count - 1;

      inactive_file := (p_fde^.open_count = 0) AND (p_fde^.attach_count = 0) AND
            (p_dfd^.delete_count = 0);
      FOR index := 1 TO p_dfd^.number_of_fmds DO
        dmp$get_fmd_by_index (p_dfd, index, p_fmd);
        inactive_file := inactive_file AND (p_fmd^.delete_logging_count = 0);
      FOREND;

      gfp$unlock_fde_p (p_fde);

      IF inactive_file THEN
        free_file_tables (sfid, status);
      IFEND;
    IFEND;

    osp$clear_mainframe_sig_lock (master_attach_lock [sfid.file_hash]);

  PROCEND dmp$complete_sft_delete;
?? TITLE := '  dmp$create_disk_file_descriptor', EJECT ??

  PROCEDURE [XDCL] dmp$create_disk_file_descriptor (file_kind: gft$file_kind;
        file_locator: dmt$file_location;
        p_file_attributes: ^array [1 .. * ] OF dmt$file_attribute;
    VAR p_disk_file_descriptor: ost$relative_pointer);

    VAR
      allocation_size_specified: boolean,
      keyword_index: integer,
      p_dfd: ^dmt$disk_file_descriptor,
      requested_allocation_size: dmt$allocation_size,
      requested_transfer_size: dmt$transfer_size,
      transfer_size_specified: boolean;

    allocation_size_specified := FALSE;
    transfer_size_specified := FALSE;
    p_disk_file_descriptor := -1;

    ALLOCATE p_dfd IN file_locator^;
    p_disk_file_descriptor := #offset(p_dfd);

    p_dfd^ := default_disk_file_descriptor;

    FOR keyword_index := LOWERBOUND (p_file_attributes^) TO UPPERBOUND (p_file_attributes^) DO
      CASE p_file_attributes^ [keyword_index].keyword OF
      = dmc$class =
        p_dfd^.requested_class := p_file_attributes^ [keyword_index].class;
      = dmc$class_ordinal =
        p_dfd^.requested_class_ordinal := p_file_attributes^ [keyword_index].ordinal;
      = dmc$overflow =
        p_dfd^.overflow_allowed := p_file_attributes^ [keyword_index].overflow_allowed;
      = dmc$requested_allocation_size =
        requested_allocation_size := p_file_attributes^ [keyword_index].requested_allocation_size;
        IF requested_allocation_size > dmc$max_bytes_per_allocation THEN
          requested_allocation_size := dmc$max_bytes_per_allocation;
        IFEND;
        allocation_size_specified := TRUE;
        p_dfd^.requested_allocation_size := requested_allocation_size;
      = dmc$requested_transfer_size =
        transfer_size_specified := TRUE;
        p_dfd^.requested_transfer_size := p_file_attributes^ [keyword_index].
              requested_transfer_size;
      = dmc$requested_volume =
        p_dfd^.requested_volume := p_file_attributes^ [keyword_index].requested_volume;
      ELSE
      CASEND;
    FOREND;

    IF NOT allocation_size_specified THEN
      IF ((file_kind = gfc$fk_catalog) OR (file_kind = gfc$fk_device_file)) THEN
        p_dfd^.requested_allocation_size := dmc$default_req_alloc_size;
      ELSE
        p_dfd^.requested_allocation_size := dmc$unspecified_allocation_size;
      IFEND;
    IFEND;

    IF NOT transfer_size_specified THEN
      IF ((file_kind = gfc$fk_catalog) OR (file_kind = gfc$fk_device_file)) THEN
        p_dfd^.requested_transfer_size := dmc$default_req_transfer_size;
      ELSE
        p_dfd^.requested_transfer_size := dmc$unspecified_transfer_size;
      IFEND;
    IFEND;

    {   Inhibit overflow for catalog and device files.

    IF ((file_kind = gfc$fk_catalog) OR (file_kind = gfc$fk_device_file)) THEN
      p_dfd^.overflow_allowed := FALSE;
    IFEND;

  PROCEND dmp$create_disk_file_descriptor;

?? TITLE := '  dmp$create_fd_entry', EJECT ??

  PROCEDURE [XDCL] dmp$create_fd_entry (p_file_attributes: ^array [1 .. * ] OF dmt$file_attribute;
    VAR system_file_id: gft$system_file_identifier;
    VAR status: ost$status);

    VAR
      dfd_pointer: ost$relative_pointer,
      file_entry_index: gft$file_descriptor_index,
      file_kind: gft$file_kind,
      file_locator: dmt$file_location,
      ignore_segment_number: ost$segment,
      keyword_index: integer,
      p_dfd: ^dmt$disk_file_descriptor,
      p_file_descriptor_entry: ^gft$file_descriptor_entry,
      preset_value: pmt$initialization_value,
      queue_status_was_specified: boolean;

    status.normal := TRUE;
    queue_status_was_specified := FALSE;
    file_entry_index := 0;

    gfp$assign_fde (system_file_id.residence, ignore_segment_number, system_file_id,
          p_file_descriptor_entry);

    /create_file_descriptor/
      BEGIN
        dmp$set_file_table_locator (system_file_id.residence, file_locator, status);
        IF NOT status.normal THEN
          EXIT /create_file_descriptor/;
        IFEND;

        gfp$get_locked_fde_p (system_file_id, p_file_descriptor_entry);
        IF p_file_descriptor_entry = NIL THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
                'Bad SFID - dmp$create_fd_entry', status);
          EXIT /create_file_descriptor/;
        IFEND;

      /fde_locked/
        BEGIN
{
{               set supplied values in file descriptor
{
          FOR keyword_index := LOWERBOUND (p_file_attributes^) TO UPPERBOUND (p_file_attributes^) DO
            IF (p_file_attributes^ [keyword_index].keyword < LOWERVALUE (p_file_attributes^ [keyword_index].
                  keyword)) OR (p_file_attributes^ [keyword_index].keyword > UPPERVALUE (p_file_attributes^
                  [keyword_index].keyword)) THEN
              osp$set_status_abnormal (dmc$device_manager_ident, dme$unrecognizable_case_select,
                'Bad case selector, p_file_attributes - dmp$create_fd_entry.', status);
              EXIT /fde_locked/;
            IFEND;
            CASE p_file_attributes^ [keyword_index].keyword OF
            = dmc$eoi_byte_address =
              p_file_descriptor_entry^.eoi_byte_address := p_file_attributes^ [keyword_index].eoi_address;
            = dmc$file_hash =
              p_file_descriptor_entry^.file_hash := p_file_attributes^ [keyword_index].file_hash;
              system_file_id.file_hash := p_file_attributes^ [keyword_index].file_hash;
            = dmc$file_limit =
              p_file_descriptor_entry^.file_limit := p_file_attributes^ [keyword_index].limit;
            = dmc$file_kind =
              p_file_descriptor_entry^.file_kind :=  p_file_attributes^ [keyword_index].file_kind;
            = dmc$global_file_name =
              p_file_descriptor_entry^.global_file_name := p_file_attributes^ [keyword_index].
                    global_file_name;
            = dmc$preset_value =
              mmp$preset_conversion (p_file_attributes^ [keyword_index].preset_value, preset_value);
              p_file_descriptor_entry^.preset_value := preset_value;
            = dmc$write_mode =
              IF p_file_attributes^ [keyword_index].attached_in_write_mode THEN
                p_file_descriptor_entry^.attached_in_write_count := 1;
              ELSE
                p_file_descriptor_entry^.attached_in_write_count := 0;
              IFEND;
            = dmc$queue_status =
              queue_status_was_specified := TRUE;
              p_file_descriptor_entry^.queue_status := p_file_attributes^ [keyword_index].queue_status;
            ELSE
            CASEND;
          FOREND;

          IF (NOT queue_status_was_specified) AND
                ((p_file_descriptor_entry^.file_kind = gfc$fk_job_local_file)
                 OR (p_file_descriptor_entry^.file_kind = gfc$fk_unnamed_file)) THEN
            p_file_descriptor_entry^.queue_status := gfc$qs_job_working_set;
          IFEND;

          IF p_file_descriptor_entry^.file_kind = gfc$fk_device_file THEN
            p_file_descriptor_entry^.queue_status := gfc$qs_global_shared;
          IFEND;

          dmp$create_disk_file_descriptor (p_file_descriptor_entry^.file_kind, file_locator,
                 p_file_attributes, dfd_pointer);

          p_file_descriptor_entry^.media := gfc$fm_mass_storage_file;
          p_file_descriptor_entry^.disk_file_descriptor_p := dfd_pointer;
          p_file_descriptor_entry^.attach_count := p_file_descriptor_entry^.attach_count + 1;

          dmp$get_disk_file_descriptor_p (p_file_descriptor_entry, p_dfd);
          IF (p_dfd^.requested_transfer_size <> dmc$unspecified_transfer_size) THEN
            p_file_descriptor_entry^.transfer_unit_size := p_dfd^.requested_transfer_size;
          IFEND;
        END /fde_locked/;

        gfp$unlock_fde_p (p_file_descriptor_entry);

        IF status.normal THEN
          IF (p_file_descriptor_entry^.file_kind <= gfc$fk_last_permanent_file) OR
               (p_file_descriptor_entry^.media = gfc$fm_served_file) THEN
            p_file_descriptor_entry^.file_hash_thread := file_hash_threads [system_file_id.file_hash];
            file_hash_threads [system_file_id.file_hash] := p_file_descriptor_entry;
          IFEND;
        IFEND;
      END /create_file_descriptor/;

  PROCEND dmp$create_fd_entry;

?? TITLE := '  dmp$delete_disk_file_descriptor', EJECT ??

  PROCEDURE [XDCL] dmp$delete_disk_file_descriptor (system_file_id: gft$system_file_identifier;
        p_fde: gft$locked_file_desc_entry_p;
        dfd_locator: dmt$file_location;
    VAR status: ost$status);

    VAR
      fmd_index: dmt$fmd_index,
      fmds_released: boolean,
      level_1_index: dmt$level_1_index,
      number_of_fmds: dmt$fmd_index,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fmd: ^dmt$file_medium_descriptor,
      p_level_2: ^dmt$level_2_table;

    status.normal := TRUE;

    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

    number_of_fmds:= p_dfd^.number_of_fmds;

    IF p_dfd^.file_allocation_table <> NIL THEN
      dmp$deallocate_file_space_r1 (system_file_id, 0, amc$file_byte_limit, p_fde, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF p_dfd^.file_allocation_table <> NIL THEN
      FOR level_1_index := p_dfd^.fat_upper_bound DOWNTO 0 DO
        dmp$get_level_2_ptr (^p_dfd^.file_allocation_table^ [level_1_index],
          p_level_2);
        IF p_level_2 <> NIL THEN
          FREE p_level_2 IN dfd_locator^;
        IFEND;
      FOREND;
      FREE p_dfd^.file_allocation_table IN dfd_locator^;
    IFEND;
    p_dfd^.fat_upper_bound := 0;

    dmp$free_fmds (p_dfd, dfd_locator, number_of_fmds, fmds_released);
    IF NOT fmds_released THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_free_fads,
        'Unable to free FMDS - dmp$delete_disk_file_descriptor.', status);
    ELSE
      FREE p_dfd IN dfd_locator^;
    IFEND;

  PROCEND dmp$delete_disk_file_descriptor;

?? TITLE := '  dmp$delete_file_descriptor', EJECT ??
*copy dmh$delete_file_descriptor

  PROCEDURE [XDCL, #GATE] dmp$delete_file_descriptor (sfid: gft$system_file_identifier;
    VAR status: ost$status);

    VAR
      inactive_file: boolean,
      logging_performed: boolean,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry;

    status.normal := TRUE;

    { Set the Master Attach lock.

    osp$set_mainframe_sig_lock (master_attach_lock [sfid.file_hash]);

    { Lock the FDE entry.

    gfp$get_locked_fde_p (sfid, p_fde);
    IF p_fde = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
            'Bad SFID - dmp$delete_file_descriptor.', status);
    ELSE
      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
      p_dfd^.delete_count := p_dfd^.delete_count - 1;
      inactive_file := (p_fde^.open_count = 0) AND (p_fde^.attach_count = 0) AND
            (p_dfd^.delete_count = 0);

    { If the file is inactive (not attached and the last delete is being
    { processed) then log the delete to the device log.

      IF inactive_file THEN
        log_sft_delete (sfid, p_fde, logging_performed, status);
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$file_descriptor_not_deleted,
          'File descriptor not deleted - dmp$delete_file_descriptor.', status);
      IFEND;
      gfp$unlock_fde_p (p_fde);
    IFEND;


    { If logging was not performed to delete the file, delete it now.

    IF status.normal AND NOT logging_performed THEN
      free_file_tables (sfid, status);
    IFEND;

    osp$clear_mainframe_sig_lock (master_attach_lock [sfid.file_hash]);

  PROCEND dmp$delete_file_descriptor;

?? TITLE := '  dmp$destroy_file', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copy dmh$destroy_file
?? POP ??

  PROCEDURE [XDCL, #GATE] dmp$destroy_file (VAR system_file_id: gft$system_file_identifier;
        file_space_limit: sft$file_space_limit_kind;
    VAR status: ost$status);

    VAR
      fde_lock_set: boolean,
      file_locator: dmt$file_location,
      length: 8 .. 120,
      p_fde: ^gft$file_descriptor_entry,
      p_dfd: ^dmt$disk_file_descriptor,
      p_rb_ring1_segment_request: ^mmt$rb_ring1_segment_request,
      outstanding_io_on_file: boolean,
      total_allocated_length: amt$file_byte_address;

    status.normal := TRUE;
    fde_lock_set := FALSE;

  /process_request/
    BEGIN
      file_locator := NIL;

      dmp$set_file_table_locator (system_file_id.residence, file_locator, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      gfp$get_locked_fde_p (system_file_id, p_fde);
      IF p_fde = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$illegal_file_index_in_sfid,
          'Unable to locate FDE - dmp$destroy_file.', status);
        EXIT /process_request/;
      IFEND;

      fde_lock_set := TRUE;

      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

      IF p_dfd = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_not_created_for_file,
          'No FMD for file - dmp$destroy_file.', status);
        EXIT /process_request/;
      IFEND;

      IF (p_fde^.file_kind <= gfc$fk_last_permanent_file) THEN
        p_dfd^.purged := TRUE;

        IF (p_fde^.attach_count > 0) THEN
          p_fde^.attach_count := p_fde^.attach_count - 1;
        IFEND;

        IF (p_fde^.attach_count <> 0) OR (p_fde^.open_count <> 0) OR (p_dfd^.delete_count <> 0) THEN
          EXIT /process_request/ { file still in use };
        IFEND;

        p_dfd^.delete_count := 1;
        gfp$unlock_fde_p (p_fde);
        fde_lock_set := FALSE;

        dmp$delete_file_descriptor (system_file_id, status);
        EXIT /process_request/;
      IFEND;

      IF p_fde^.asti <> 0 THEN
        PUSH p_rb_ring1_segment_request;
        p_rb_ring1_segment_request^.reqcode := syc$rc_ring1_segment_request;
        p_rb_ring1_segment_request^.status.normal := TRUE;
        p_rb_ring1_segment_request^.request := mmc$sr1_delete_seg_sfid;
        p_rb_ring1_segment_request^.sfid := system_file_id;
        length := #SIZE (p_rb_ring1_segment_request^);

        mmp$issue_ring1_segment_request (p_rb_ring1_segment_request^);
        syp$set_status_from_mtr_status (p_rb_ring1_segment_request^.status,
              status);
        IF NOT status.normal THEN
          EXIT /process_request/;
        IFEND;
      IFEND;

      REPEAT
        outstanding_io_on_file := (p_dfd^.read_write_count > 0);
        IF outstanding_io_on_file THEN
          pmp$delay (50, status);
        IFEND;
      UNTIL NOT outstanding_io_on_file;

      p_dfd^.purged := TRUE;

      dmp$get_total_allocated_length (p_fde, total_allocated_length);

      dmp$decrement_class_activity (system_file_id, status);
      dmp$delete_disk_file_descriptor (system_file_id, p_fde, file_locator, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      p_fde^.global_file_name := dmv$null_global_file_name;

      gfp$unlock_fde_p (p_fde);
      fde_lock_set := FALSE;
      gfp$free_fde (p_fde, system_file_id);

      IF file_space_limit <> sfc$no_limit THEN
        sfp$accumulate_file_space (file_space_limit, -total_allocated_length);
      IFEND;

    END /process_request/;

    IF fde_lock_set THEN
      gfp$unlock_fde_p (p_fde);
    IFEND;

  PROCEND dmp$destroy_file;

?? TITLE := '  dmp$detach_device_file', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$detach_device_file (system_file_id: gft$system_file_identifier;
    VAR file_modified: boolean;
    VAR fmd_modified: boolean;
    VAR status: ost$status);

    VAR
      ignore_file_info: dmt$file_information;

    status.normal := TRUE;

    dmp$detach_file (system_file_id, {access_allowed} TRUE, {flush_pages} TRUE, file_modified, fmd_modified,
          ignore_file_info, status);
    IF status.normal THEN
      dmp$delete_file_descriptor (system_file_id, status);
      IF NOT status.normal THEN
        IF status.condition = dme$file_descriptor_not_deleted THEN
          status.condition := 0;
          status.normal := TRUE;
        IFEND;
      IFEND;
    IFEND;

  PROCEND dmp$detach_device_file;

?? TITLE := '  dmp$detach_file', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmh$detach_file
?? POP ??
  PROCEDURE [XDCL, #GATE] dmp$detach_file (system_file_id: gft$system_file_identifier;
                                           access_allowed: boolean;
                                           flush_pages: boolean;
                                       VAR file_modified: boolean;
                                       VAR fmd_modified: boolean;
                                       VAR file_info: dmt$file_information;
                                       VAR status: ost$status);

    VAR
      avt_entry_found: boolean,
      avt_index: dmt$active_volume_table_index,
      detach_allowed: ost$status,
      dmv$await_io_completion: [STATIC, XDCL] boolean := FALSE,
      entry_to_be_processed: boolean,
      fmd_number: dmt$fmd_index,
      identifier: ost$status_identifier,
      length: 8 .. 120,
      log_entry: dmt$dl_entry,
      new_total_allocated_length: amt$file_byte_address,
      number_of_fmds: dmt$fmd_index,
      old_total_allocated_length: amt$file_byte_address,
      p_active_vol_attributes: ^array [ * ] of dmt$assigned_ms_vol_attribute,
      p_fmd: ^dmt$file_medium_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      p_dfd: ^dmt$disk_file_descriptor,
      p_rb_ring1_segment_request: ^mmt$rb_ring1_segment_request,
      recorded_vsn: rmt$recorded_vsn,
      trim_status: ost$status,
      trimmed_length: amt$file_byte_address,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    trim_status.normal := TRUE;
    detach_allowed.normal := TRUE;
    old_total_allocated_length := 0;
    new_total_allocated_length := 0;
    trimmed_length := 0;
    file_modified := FALSE;     {This parameter was never seriously used, it should be deleted}

  /process_request/
    BEGIN
      gfp$get_fde_p (system_file_id, p_fde);
      IF p_fde = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
              'Bad SFID - dmp$detach_file.', status);
        EXIT /process_request/;
      IFEND;

      IF access_allowed THEN
        IF (flush_pages) AND (p_fde^.queue_status <> gfc$qs_job_shared) AND (p_fde^.asti <> 0) THEN
          {
          { Flush pages when pages are in the jobs working set or in the global
          { shared queue (i.e. file attached in write mode).
          {

          PUSH p_rb_ring1_segment_request;
          p_rb_ring1_segment_request^.reqcode := syc$rc_ring1_segment_request;
          p_rb_ring1_segment_request^.request := mmc$sr1_detach_file;
          p_rb_ring1_segment_request^.sfid := system_file_id;
          p_rb_ring1_segment_request^.wait_for_io_complete := TRUE;
          p_rb_ring1_segment_request^.status.normal := TRUE;

          mmp$issue_ring1_segment_request (p_rb_ring1_segment_request^);
          IF NOT p_rb_ring1_segment_request^.status.normal THEN
            osp$unpack_status_identifier (p_rb_ring1_segment_request^.status.condition, identifier);
            osp$set_status_abnormal (identifier, p_rb_ring1_segment_request^.status.condition,
                  'Bad status from monitor - dmp$detach_file.', status);
            detach_allowed := status;
          IFEND;
        ELSEIF (p_fde^.queue_status <> gfc$qs_global_shared) THEN
          {
          { In cases where flushing is not requested and the pages are in the
          { working set the pages must be removed from the working set.
          {
          PUSH p_rb_ring1_segment_request;
          p_rb_ring1_segment_request^.reqcode := syc$rc_ring1_segment_request;
          p_rb_ring1_segment_request^.request := mmc$sr1_remove_detached_pages;
          p_rb_ring1_segment_request^.sfid := system_file_id;
          p_rb_ring1_segment_request^.status.normal := TRUE;

          mmp$issue_ring1_segment_request (p_rb_ring1_segment_request^);

        IFEND;
      IFEND;

      gfp$lock_fde (p_fde);

    /file_descriptor_locked/
      BEGIN
        dmp$get_total_allocated_length (p_fde, old_total_allocated_length);

        p_fde^.attach_count := p_fde^.attach_count - 1;
        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
        p_dfd^.delete_count := p_dfd^.delete_count + 1;
        file_modified := p_fde^.flags.eoi_modified;

        dmp$get_fmd_by_index (p_dfd, 1, p_fmd);

        avt_index := p_fmd^.avt_index;
        recorded_vsn :=  dmv$p_active_volume_table^ [p_fmd^.avt_index].mass_storage.recorded_vsn;

        IF (p_fde^.attached_in_write_count > 0) AND (p_fde^.attach_count = 0) THEN
          PUSH p_active_vol_attributes: [1 .. 1];

          p_active_vol_attributes^ [1].keyword := dmc$ms_mainframe_assigned;

          dmp$get_active_vol_attributes (recorded_vsn, avt_index, p_active_vol_attributes, avt_entry_found);
          IF NOT avt_entry_found THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
                  'Unable to locate AVT entry - dmp$detach_file.', status);
            osp$append_status_parameter (' ', recorded_vsn, status);
            EXIT /file_descriptor_locked/;
          IFEND;

          IF detach_allowed.normal THEN
            log_entry.kind := dmc$dl_detach_file;
            log_entry.attach_file_block.global_file_name := p_fde^.global_file_name;
            log_entry.attach_file_block.dfl_index := p_fmd^.dfl_index;
            log_entry.attach_file_block.mainframe_assigned := p_active_vol_attributes^ [1].mainframe_assigned;

            dmp$process_device_log_entry (avt_index, log_entry, status);
            IF NOT status.normal THEN
              EXIT /file_descriptor_locked/;
            IFEND;

            IF p_dfd^.damaged_detection_enabled THEN
              p_dfd^.damaged_detection_enabled := FALSE;
              IF NOT p_dfd^.file_damaged THEN
                log_entry.kind := dmc$dl_file_damaged;
                log_entry.file_damaged_block.global_file_name := p_fde^.global_file_name;
                log_entry.file_damaged_block.dfl_index := p_fmd^.dfl_index;
                log_entry.file_damaged_block.add_damage := $dmt$file_damage [];
                log_entry.file_damaged_block.remove_damage := $dmt$file_damage [dmc$media_image_inconsistent];

                dmp$process_device_log_entry (avt_index, log_entry, status);
                IF NOT status.normal THEN
                  EXIT /file_descriptor_locked/;
                IFEND;
              IFEND;
            IFEND;
          ELSE

            {The pages could not be flushed to disk.  Issue the remove_job_shared_pages request
            {to move all pages to a global shared queue.  Pages CANNOT be left in a JWS after a file
            {has been detached.  Pass in segment number 0; this will prevent the monitor code from
            {trying to store the ASID in the job's segment table.

            p_rb_ring1_segment_request^.reqcode := syc$rc_ring1_segment_request;
            p_rb_ring1_segment_request^.request := mmc$sr1_remove_job_shared_pages;
            p_rb_ring1_segment_request^.sfid := system_file_id;
            p_rb_ring1_segment_request^.segment_number := 0;
            p_rb_ring1_segment_request^.server_file := FALSE;
            p_rb_ring1_segment_request^.status.normal := TRUE;

            mmp$issue_ring1_segment_request (p_rb_ring1_segment_request^);

            {FDE will never be deleted, so the queue status will never be updated
            {by attach, so we must keep the queue status as global!
            {The monitor request has changed AST queued_id to global shared.
            p_fde^.queue_status := gfc$qs_global_shared;

            {Usage count must stay non zero to prevent the fde from being deleted
            p_fde^.attach_count := 1;

          IFEND;
        IFEND;

        IF dmv$trim_files AND (p_fde^.attach_count = 0) THEN
          IF p_fde^.eoi_byte_address = 0 THEN     { save 1 fmd for perm files
            dmp$trim_file (system_file_id, p_fde^.eoi_byte_address + 1, trim_status);
          ELSE
            dmp$trim_file (system_file_id, p_fde^.eoi_byte_address, trim_status);
          IFEND;
          IF NOT trim_status.normal THEN
            CASE trim_status.condition OF
            = dme$io_active, dme$untrimmable_file_type, dme$outstanding_log_entries =
              { these errors are non-destructive, and we've only missed a bit of deallocation
              trim_status.normal := TRUE;
            ELSE
            CASEND;
          IFEND;
        IFEND;

        fmd_modified := p_dfd^.fmd_modified;
        p_dfd^.fmd_modified := FALSE;

        IF (p_dfd^.dfd_modified) OR (p_fde^.flags.eoi_modified) THEN
          update_dfl_file_length (p_fde, p_dfd, status);
        IFEND;

        dmp$get_total_allocated_length (p_fde, new_total_allocated_length);

        file_info.eoi_byte_address := gfp$get_eoi_from_fde (p_fde);
        IF p_fde^.queue_ordinal > mmc$pq_shared_last_sys THEN
          file_info.shared_queue := p_fde^.queue_ordinal - mmc$pq_shared_last_sys;
        ELSE
          file_info.shared_queue := mmc$null_shared_queue;
        IFEND;
        file_info.file_kind := p_fde^.file_kind;
        file_info.time_last_modified := p_fde^.time_last_modified;
        file_info.total_allocated_length := new_total_allocated_length;
        file_info.trimmed_length := old_total_allocated_length - new_total_allocated_length;

      END /file_descriptor_locked/;

      gfp$unlock_fde_p (p_fde);

    END /process_request/;

    IF status.normal THEN
      IF NOT detach_allowed.normal THEN
        status := detach_allowed;
      ELSEIF NOT trim_status.normal THEN
        status := trim_status;
      IFEND;
    IFEND;

  PROCEND dmp$detach_file;

?? TITLE := '  dmp$detach_server_file ', EJECT ??

*copyc dmv$await_io_completion
*copyc dmp$release_server_descriptor
*copyc dmh$detach_server_file

  PROCEDURE [XDCL, #GATE] dmp$detach_server_file
    (    system_file_id: gft$system_file_identifier;
         flush_pages: boolean;
         unconditional_detach: boolean;
     VAR attached_for_write: boolean;
     VAR eoi_byte_address: amt$file_byte_address;
     VAR remote_sfid: gft$system_file_identifier;
     VAR status: ost$status);

    VAR
      flush_status: ost$status,
      lock_status: ost$status,
      p_fde: ^gft$file_descriptor_entry,
      p_server_descriptor: ^dmt$server_descriptor,
      rb_ring1_segment_request: mmt$rb_ring1_segment_request,
      terminated_server: boolean,
      wait_on_io: boolean;

    #KEYPOINT (osk$entry, osk$m * system_file_id.file_entry_index, dmk$detach_server_file);
    status.normal := TRUE;
    flush_status.normal := TRUE;
    terminated_server := FALSE;
    gfp$get_fde_p (system_file_id, p_fde);
    IF p_fde = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
            'bad sfid in dmp$detach_server_file ', status);
      #KEYPOINT (osk$exit, 0, dmk$detach_server_file);
      RETURN;
    IFEND;

    IF p_fde^.media <> gfc$fm_served_file THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$expecting_server_file,
            'bad file type dmp$detach_server_file ', status);
      #KEYPOINT (osk$exit, 0, dmk$detach_server_file);
      RETURN;
    IFEND;

    IF flush_pages AND (p_fde^.asti <> 0) THEN
      wait_on_io := dmv$await_io_completion OR ((p_fde^.attach_count = 1) AND
                        (p_fde^.attached_in_write_count > 0));
      rb_ring1_segment_request.reqcode := syc$rc_ring1_segment_request;
      rb_ring1_segment_request.sfid := system_file_id;
      rb_ring1_segment_request.wait_for_io_complete := wait_on_io;
      rb_ring1_segment_request.status.normal := TRUE;
      rb_ring1_segment_request.request := mmc$sr1_detach_file;
      mmp$issue_ring1_segment_request (rb_ring1_segment_request);
      syp$set_status_from_mtr_status (rb_ring1_segment_request.status, status);
      IF NOT status.normal THEN
        IF status.condition = dfe$server_has_terminated THEN
          terminated_server := TRUE;
          status.normal := TRUE;
        ELSE {any other condition}
          flush_status := status;
        IFEND;
      IFEND;
    IFEND;

{ Update FDE entry.

    osp$set_mainframe_sig_lock (master_attach_lock [system_file_id.file_hash]);

  /master_attach_lock_set/
    BEGIN

      gfp$lock_fde (p_fde);

    /fde_locked/
      BEGIN
        IF NOT flush_status.normal AND (p_fde^.attach_count = 1) THEN

{ The pages could not be flushed to disk.  Issue the remove_job_shared_pages request
{ to move all pages to a global shared queue.  Pages CANNOT be left in a JWS after a file
{ has been detached.  Pass in segment number 0; this will prevent the monitor code from
{ trying to store the ASID in the job's segment table.

          rb_ring1_segment_request.reqcode := syc$rc_ring1_segment_request;
          rb_ring1_segment_request.request := mmc$sr1_remove_job_shared_pages;
          rb_ring1_segment_request.sfid := system_file_id;
          rb_ring1_segment_request.segment_number := 0;
          rb_ring1_segment_request.server_file := TRUE;
          rb_ring1_segment_request.status.normal := TRUE;

          mmp$issue_ring1_segment_request (rb_ring1_segment_request);

{ FDE will never be deleted, so the queue status will never be updated
{ by attach, so we must keep the queue status as global!
{ The monitor request has changed AST queued_id to global shared.

          p_fde^.queue_status := gfc$qs_global_shared;
          EXIT /fde_locked/;
        IFEND;

        dfp$get_served_file_desc_p (p_fde, p_server_descriptor);
        IF (p_server_descriptor^.header.file_state = dfc$awaiting_recovery) AND NOT unconditional_detach THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_active,
                ' file awaiting recovery ', status);
          EXIT /fde_locked/;
        IFEND;

        attached_for_write := (p_fde^.attached_in_write_count > 0);
        eoi_byte_address := gfp$get_eoi_from_fde (p_fde);
        remote_sfid := p_server_descriptor^.header.remote_sfid;
        p_fde^.attach_count := p_fde^.attach_count - 1;

{ Like dmp$delete_file_descriptor, except
{  1. No file medium descriptor, or logging
{  2. Does not return abnormal status if file still active.
{  3. Makes fde available, rather than making it inactive.

        IF (p_fde^.open_count = 0) AND (p_fde^.attach_count = 0) THEN
          WHILE (p_server_descriptor^.header.read_write_count <> 0) DO

{ Outstanding I/O on file.  READ_WRITE_COUNT is incremented in monitor when making a server request on the
{ client, and is decremented in monitor when completing a server request on the client.

            pmp$delay (1000, status);
          WHILEND;

{ The file is now inactive.  Issue request to free pages and delete the ASID associated with the file.

          IF p_fde^.asti <> 0 THEN
            rb_ring1_segment_request.reqcode := syc$rc_ring1_segment_request;
            rb_ring1_segment_request.status.normal := TRUE;
            rb_ring1_segment_request.request := mmc$sr1_delete_seg_sfid;
            rb_ring1_segment_request.sfid := system_file_id;
            mmp$issue_ring1_segment_request (rb_ring1_segment_request);
            syp$set_status_from_mtr_status (rb_ring1_segment_request.status, status);
          IFEND;

{ Remove the system file table entry.

          IF status.normal THEN
            remove_fde_active_thread (system_file_id, p_fde, status);
            p_server_descriptor^.header.purged := TRUE;
            dfp$release_server_descriptor (p_fde);
            p_fde^.global_file_name := dmv$null_global_file_name;
            gfp$unlock_fde_p (p_fde);
            gfp$free_fde (p_fde, system_file_id);
            EXIT /master_attach_lock_set/;
          IFEND;
        IFEND;
      END /fde_locked/;

      gfp$unlock_fde_p (p_fde);

    END /master_attach_lock_set/;

    osp$clear_mainframe_sig_lock (master_attach_lock [system_file_id.file_hash]);

    IF status.normal AND terminated_server THEN
      { File manager will remove the file table entry despite this status.
      osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated,
        '', status);
    IFEND;
    #KEYPOINT (osk$exit, 0, dmk$detach_server_file);

  PROCEND dmp$detach_server_file;

?? TITLE := '  dmp$enable_damage_detection', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$enable_damage_detection (sfid: gft$system_file_identifier;
        global_file_name: dmt$global_file_name;
    VAR status: ost$status);

    VAR
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      p_fmd: ^dmt$file_medium_descriptor;

    status.normal := TRUE;

    gfp$get_locked_fde_p (sfid, p_fde);
    IF p_fde = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
            'Bad SFID - dmp$enable_damage_detection.', status);
    ELSE
      IF p_fde^.global_file_name = global_file_name THEN
        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
        p_dfd^.damaged_detection_enabled := TRUE;
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
          'GFN or SFID is incorrect - dmp$change_file_damaged.', status);
      IFEND;

      IF status.normal THEN
        dmp$get_fmd_by_index (p_dfd, 1, p_fmd);

        dmp$change_dfl_damage (p_fmd^.avt_index, $dmt$file_damage [dmc$media_image_inconsistent],
          $dmt$file_damage[], p_fmd^.dfl_index, TRUE {flush_device_log =},
          p_fde^.global_file_name, status);
      IFEND;
      gfp$unlock_fde_p (p_fde);
    IFEND;

  PROCEND dmp$enable_damage_detection;
?? TITLE := '  dmp$fetch_eoi', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$fetch_eoi (system_file_id: gft$system_file_identifier;
    VAR eoi: amt$file_byte_address;
    VAR status: ost$status);

    VAR
      p_fde: ^gft$file_descriptor_entry;

    gfp$verify_get_fde_p (system_file_id, p_fde, status);
    IF status.normal THEN
      eoi := gfp$get_eoi_from_fde (p_fde);
    IFEND;

  PROCEND dmp$fetch_eoi;
?? TITLE := '  dmp$fetch_segment_file_info', EJECT ??
*copy dmh$fetch_segment_file_info

  PROCEDURE [XDCL, #GATE] dmp$fetch_segment_file_info (system_file_id: gft$system_file_identifier;
        chapter_number: dmt$chapter_number;
    VAR info: dmt$segment_file_info;
    VAR status: ost$status);

{
{  This procedure is currently used only by one PF procedure to obtain
{  usage count. This interface should be eliminated as a cleanup activity.
{  (11/89)
{

    VAR
      p_fde: ^gft$file_descriptor_entry,
      p_dfd: ^dmt$disk_file_descriptor,
      p_server_descriptor: ^dmt$server_descriptor;

    status.normal := TRUE;

    gfp$get_locked_fde_p (system_file_id, p_fde);

    info.chapter_limit := p_fde^.file_limit;
    IF info.chapter_limit > osc$maximum_offset THEN
      info.chapter_limit := osc$maximum_offset;
    IFEND;
    info.usage_count := p_fde^.attach_count;
    info.transfer_size := p_fde^.transfer_unit_size;
    info.allocation_size := p_fde^.allocation_unit_size;

    gfp$unlock_fde_p (p_fde);

  PROCEND dmp$fetch_segment_file_info;

?? TITLE := '  dmp$file_on_down_volume', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$file_on_down_volume
    (    system_file_id: gft$system_file_identifier;
     VAR file_on_down_volume: boolean);

    VAR
      fmd_index: dmt$fmd_index,
      number_of_fmds: dmt$fmd_index,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      p_fmd: ^dmt$file_medium_descriptor;

    file_on_down_volume := FALSE;

    gfp$get_fde_p (system_file_id, p_fde);
    IF p_fde <> NIL THEN
      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
      number_of_fmds := p_dfd^.number_of_fmds;
      FOR fmd_index := 1 TO number_of_fmds DO
        dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);
        IF p_fmd^.in_use AND p_fmd^.volume_assigned THEN
          IF dmv$p_active_volume_table^[p_fmd^.avt_index].mass_storage.volume_unavailable THEN
            file_on_down_volume := TRUE;
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;

  PROCEND dmp$file_on_down_volume;
?? TITLE := '  dmp$fixup_fmd_allocated_length', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$fixup_fmd_allocated_length (system_file_id: gft$system_file_identifier;
        fmd_index: dmt$fmd_index;
        allocated_length: amt$file_byte_address;
    VAR status: ost$status);

{
{  Used only during recovery, so a lock is not set.
{

    VAR
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      p_fmd: ^dmt$file_medium_descriptor;

    status.normal := TRUE;

    gfp$get_fde_p (system_file_id, p_fde);

    IF p_fde <> NIL THEN
      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
      p_dfd^.dfd_modified := TRUE;

      dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);
      p_fmd^.fmd_allocated_length := allocated_length;
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
        'Bad SFID - dmp$fixup_fmd_allocated_length.', status);
    IFEND;
  PROCEND dmp$fixup_fmd_allocated_length;

?? TITLE := '  dmp$free_server_file_tables', EJECT ??

*copy dmh$free_server_file_tables

  PROCEDURE [XDCL, #GATE] dmp$free_server_file_tables
    (    system_file_id: gft$system_file_identifier;
     VAR status: ost$status);

    VAR
      p_fde: ^gft$file_descriptor_entry,
      p_server_descriptor: ^dmt$server_descriptor,
      rb_ring1_segment_request: mmt$rb_ring1_segment_request;

    osp$set_mainframe_sig_lock (master_attach_lock [system_file_id.file_hash]);

  /master_attach_lock_set/
    BEGIN

      gfp$get_locked_fde_p (system_file_id, p_fde);
      IF p_fde = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
              'bad sfid in dmp$free_server_file_tables', status);
        EXIT /master_attach_lock_set/;
      IFEND;

    /fde_locked/
      BEGIN
        dfp$get_served_file_desc_p (p_fde, p_server_descriptor);
        IF p_server_descriptor^.header.file_state = dfc$awaiting_recovery THEN
          osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_active,
                ' file awaiting recovery ', status);
          EXIT /fde_locked/;
        IFEND;

        IF (p_fde^.open_count = 0) AND (p_fde^.attach_count = 0) THEN
          WHILE (p_server_descriptor^.header.read_write_count <> 0) DO

{ Outstanding I/O on file.  READ_WRITE_COUNT is incremented in monitor when making a server request on the
{ client, and is decremented in monitor when completing a server request on the client.

            pmp$delay (1000, status);
          WHILEND;

          IF p_fde^.asti <> 0 THEN
            rb_ring1_segment_request.reqcode := syc$rc_ring1_segment_request;
            rb_ring1_segment_request.status.normal := TRUE;
            rb_ring1_segment_request.request := mmc$sr1_delete_seg_sfid;
            rb_ring1_segment_request.sfid := system_file_id;
            mmp$issue_ring1_segment_request (rb_ring1_segment_request);
            syp$set_status_from_mtr_status (rb_ring1_segment_request.status, status);
          IFEND;

          { Remove the system file table entry.
          IF status.normal THEN
            remove_fde_active_thread (system_file_id, p_fde, status);
            p_server_descriptor^.header.purged := TRUE;
            dfp$release_server_descriptor (p_fde);
            p_fde^.global_file_name := dmv$null_global_file_name;
            gfp$unlock_fde_p (p_fde);
            gfp$free_fde (p_fde, system_file_id);
            EXIT /master_attach_lock_set/;
          IFEND;
        IFEND;
      END /fde_locked/;

      gfp$unlock_fde_p (p_fde);

    END /master_attach_lock_set/;

    osp$clear_mainframe_sig_lock (master_attach_lock [system_file_id.file_hash]);

  PROCEND dmp$free_server_file_tables;

?? TITLE := '  dmp$get_total_allocated_length', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$get_total_allocated_length
    (    p_fde: gft$locked_file_desc_entry_p;
     VAR total_allocated_length: amt$file_byte_address);

    VAR
      fmd_index: dmt$fmd_index,
      number_of_fmds: dmt$fmd_index,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fmd: ^dmt$file_medium_descriptor,
      p_server_descriptor: dmt$p_server_descriptor;

    total_allocated_length := 0;

    IF p_fde^.media = gfc$fm_served_file THEN
      dfp$get_served_file_desc_p (p_fde, p_server_descriptor);
      total_allocated_length := p_server_descriptor^.header.total_allocated_length;
    ELSE
      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
      number_of_fmds := p_dfd^.number_of_fmds;
      FOR fmd_index := 1 TO number_of_fmds DO
        dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);
        total_allocated_length := total_allocated_length + p_fmd^.fmd_allocated_length;
      FOREND;
    IFEND;

  PROCEND dmp$get_total_allocated_length;

?? TITLE := '  dmp$locate_existing_sft_entry', EJECT ??
*copy dmh$locate_existing_sft_entry

  PROCEDURE [XDCL, #GATE] dmp$locate_existing_sft_entry
    (    global_file_name: dmt$global_file_name;
         file_kind: gft$file_kind;
     VAR existing_sft_entry: dmt$existing_sft_entry;
     VAR file_info: dmt$file_information;
     VAR status: ost$status);

    VAR
      file_found: boolean,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      sfid: gft$system_file_identifier;

    existing_sft_entry := dmc$entry_not_found;
    dmp$generate_gfn_hash (global_file_name, sfid.file_hash);

    osp$set_mainframe_sig_lock (master_attach_lock [sfid.file_hash]);

    dmp$set_file_residence (file_kind, sfid.residence, status);

    IF  status.normal THEN
      dmp$search_fdt_by_gfn (sfid.residence, global_file_name, sfid.file_entry_index, file_found);

      IF file_found THEN
        gfp$get_locked_fde_p (sfid, p_fde);

        IF (p_fde <> NIL) THEN
          dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
          file_found := (p_dfd <> NIL) AND NOT p_dfd^.purged AND (p_fde^.attach_count <> 0);

          IF file_found THEN
            IF p_dfd^.restricted_attach THEN
              existing_sft_entry := dmc$restricted_attach_entry;
            ELSE
              existing_sft_entry := dmc$normal_entry;
            IFEND;

            file_info.eoi_byte_address := gfp$get_eoi_from_fde (p_fde);
            IF p_fde^.queue_ordinal > mmc$pq_shared_last_sys THEN
              file_info.shared_queue := p_fde^.queue_ordinal - mmc$pq_shared_last_sys;
            ELSE
              file_info.shared_queue := mmc$null_shared_queue;
            IFEND;
            file_info.file_kind := p_fde^.file_kind;
            file_info.time_last_modified := p_fde^.time_last_modified;
            dmp$get_total_allocated_length (p_fde, file_info.total_allocated_length);
            file_info.trimmed_length := 0;
          IFEND;
          gfp$unlock_fde_p (p_fde);
        IFEND;
      IFEND;
    IFEND;

    osp$clear_mainframe_sig_lock (master_attach_lock [sfid.file_hash]);
  PROCEND dmp$locate_existing_sft_entry;

?? TITLE := '  dmp$mm_log_sft_delete', EJECT ??

*copy dmh$mm_log_sft_delete

  PROCEDURE [XDCL, #GATE] dmp$mm_log_sft_delete (sfid: gft$system_file_identifier;
    VAR status: ost$status);

    VAR
      inactive_file: boolean,
      logging_performed: boolean,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry;

    status.normal := TRUE;

    { Set the Master Attach lock.

    osp$set_mainframe_sig_lock (master_attach_lock [sfid.file_hash]);

    { Lock the FDE entry.

    gfp$get_locked_fde_p (sfid, p_fde);
    IF p_fde = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
            'Bad SFID - dmp$delete_file_descriptor.', status);
    ELSE
      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
      inactive_file := (p_fde^.open_count = 0) AND (p_fde^.attach_count = 0) AND
            (p_dfd^.delete_count = 0);

    { If the file is inactive (not attached and the last delete is being
    { processed) then log the delete to the device log.

      IF inactive_file THEN
        log_sft_delete (sfid, p_fde, logging_performed, status);
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$file_descriptor_not_deleted,
          'File descriptor not deleted - dmp$delete_file_descriptor.', status);
      IFEND;
      gfp$unlock_fde_p (p_fde);
    IFEND;


    { If logging was not performed to delete the file, delete it now.

    IF status.normal AND NOT logging_performed THEN
      free_file_tables (sfid, status);
    IFEND;

    osp$clear_mainframe_sig_lock (master_attach_lock [sfid.file_hash]);

  PROCEND dmp$mm_log_sft_delete;

?? TITLE := '  dmp$open_file', EJECT ??
*copy dmh$open_file

  PROCEDURE [XDCL, #GATE] dmp$open_file (sfid: gft$system_file_identifier;
        ring1: ost$valid_ring;
        ring2: ost$valid_ring;
        access_rights: mmt$segment_access_rights;
        access_selections: mmt$access_selections;
    VAR pointer: mmt$segment_pointer;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      entry_to_be_processed: boolean,
      fmd_index: dmt$fmd_index,
      heap_pointer: ^ost$adaptable_heap_pointer,
      number_of_fmds: dmt$fmd_index,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      p_fmd: ^dmt$file_medium_descriptor,
      p_segment_pva: ^cell,
      segment_number: ost$segment,
      seq_pointer: ^ost$sequence_pointer;

    #caller_id (caller_id);

    status.normal := TRUE;

    IF caller_id.ring > osc$tsrv_ring THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$illegal_caller,
        'Ring number of caller > osc$tsrv_ring - dmp$open_file.', status);
      RETURN;
    IFEND;

    gfp$get_fde_p (sfid, p_fde);
    IF p_fde = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
            'Bad SFID - dmp$open_file.', status);
    ELSE
      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
      number_of_fmds := p_dfd^.number_of_fmds;
      FOR fmd_index := 1 TO number_of_fmds DO
        dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);
        entry_to_be_processed := p_fmd^.in_use AND p_fmd^.volume_assigned;
        IF entry_to_be_processed THEN
          IF dmv$p_active_volume_table^ [p_fmd^.avt_index].mass_storage.volume_unavailable THEN
            osp$set_status_abnormal (dmc$device_manager_ident,dme$volume_unavailable,
                  'volume unavailable - dmp$open_file', status);
            RETURN;
          IFEND;
        IFEND;
      FOREND;

      mmp$open_file_by_sfid (sfid, ring1, ring2, access_selections, access_rights,
            segment_number, status);
      IF status.normal THEN
        p_segment_pva := #address (caller_id.ring, segment_number, 0);

        CASE pointer.kind OF
        = mmc$cell_pointer =
          pointer.cell_pointer := p_segment_pva;
        = mmc$sequence_pointer =
          seq_pointer := #LOC (pointer.seq_pointer);
          seq_pointer^.pva := p_segment_pva;
          IF p_fde^.file_limit <= osc$maximum_offset THEN
            seq_pointer^.length := p_fde^.file_limit;
          ELSE
            seq_pointer^.length := osc$maximum_offset;
          IFEND;
          seq_pointer^.nextt := 0;
        = mmc$heap_pointer =
          heap_pointer := #LOC (pointer.heap_pointer);
          heap_pointer^.length := p_fde^.file_limit;
        ELSE

        CASEND;
      IFEND;
    IFEND;

  PROCEND dmp$open_file;

?? TITLE := '  dmp$reassign_file', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copy dmh$reassign_file
?? POP ??

  PROCEDURE [XDCL, #GATE] dmp$reassign_file (system_file_id: gft$system_file_identifier;
                                             bytes_to_allocate: amt$file_byte_address;
                                         VAR status: ost$status);

    VAR
      p_fde: ^gft$file_descriptor_entry;

    gfp$get_locked_fde_p (system_file_id, p_fde);
    IF p_fde = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
            'Bad SFID  - dmp$reassign_file.', status);
      RETURN;
    IFEND;

    dmp$trim_file (system_file_id, 0, status);
    IF status.normal THEN
      p_fde^.eoi_byte_address := 0;
      dmp$allocate_file_space_r1 (system_file_id, 0, bytes_to_allocate, 0, osc$nowait, sfc$no_limit,
            status);
      dmv$last_file_reassigned := system_file_id;
    IFEND;

    gfp$unlock_fde_p (p_fde);

  PROCEND dmp$reassign_file;

?? TITLE := '  dmp$search_fdt_by_gfn', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$search_fdt_by_gfn
    (    file_table_residence: gft$table_residence;
         global_file_name: dmt$global_file_name;
     VAR file_entry_index: gft$file_descriptor_index;
     VAR existing_fde_found: boolean);

    VAR
      file_hash: dmt$file_hash,
      p_fde: ^gft$file_descriptor_entry,
      system_file_id: gft$system_file_identifier;

    dmp$generate_gfn_hash (global_file_name, file_hash);

    existing_fde_found := FALSE;
    p_fde := file_hash_threads [file_hash];

    WHILE p_fde <> NIL DO
      IF (p_fde^.global_file_name = global_file_name) THEN
        existing_fde_found := TRUE;
        gfp$get_sfid_from_fde_p (p_fde, system_file_id);
        file_entry_index := system_file_id.file_entry_index;
        RETURN;
      IFEND;
      p_fde := p_fde^.file_hash_thread;
    WHILEND;

  PROCEND dmp$search_fdt_by_gfn;

?? TITLE := '  dmp$set_eoi', EJECT ??
*copy dmh$set_eoi

  PROCEDURE [XDCL, #GATE] dmp$set_eoi (system_file_id: gft$system_file_identifier;
        eoi: amt$file_byte_address;
    VAR status: ost$status);

    VAR
      request_block: mmt$rb_set_get_segment_length,
      p_fde: ^gft$file_descriptor_entry;

    gfp$verify_get_fde_p (system_file_id, p_fde, status);

    IF status.normal THEN
      request_block.request_code := syc$rc_set_get_segment_length;
      request_block.subfunction_code := mmc$sf_set_segment_length_fde_p;
      request_block.segment_length := eoi;
      request_block.fde_p := p_fde;
      i#call_monitor (#LOC (request_block), #SIZE (request_block));
    IFEND;

  PROCEND dmp$set_eoi;

?? TITLE := '  dmp$set_file_limit', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$set_file_limit (sfid: gft$system_file_identifier;
        limit: 0 .. amc$file_byte_limit;
    VAR status: ost$status);

    VAR
      p_fde: ^gft$file_descriptor_entry;

    status.normal := TRUE;

    gfp$get_locked_fde_p (sfid, p_fde);
    IF p_fde = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
            'Bad SFID - dmp$set_file_limit.', status);
    ELSE
      p_fde^.file_limit := limit;
      gfp$unlock_fde_p (p_fde);
    IFEND;

  PROCEND dmp$set_file_limit;
?? TITLE := '  dmp$set_file_residence', EJECT ??
*copy dmh$set_file_residence

  PROCEDURE [XDCL] dmp$set_file_residence (file_kind: gft$file_kind;
    VAR file_table_residence: gft$table_residence;
    VAR status: ost$status);

    status.normal := TRUE;

    file_table_residence := gfc$tr_null_residence;

{
{              set file residence
{
    CASE file_kind OF
    = gfc$fk_device_file =
      file_table_residence := gfc$tr_system;
    = gfc$fk_catalog =
      file_table_residence := gfc$tr_system;
    = gfc$fk_global_unnamed =
      file_table_residence := gfc$tr_system;
    = gfc$fk_job_local_file =
      file_table_residence := gfc$tr_job;
    = gfc$fk_unnamed_file =
      file_table_residence := gfc$tr_job;
    = gfc$fk_job_permanent_file =
      file_table_residence := gfc$tr_system;
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unrecognizable_file_type,
        'File type not defined.', status);
    CASEND;

  PROCEND dmp$set_file_residence;
?? TITLE := '  dmp$set_file_table_locator', EJECT ??
*copy dmh$set_file_table_locator

  PROCEDURE [XDCL] dmp$set_file_table_locator (file_residence: gft$table_residence;
    VAR file_locator: dmt$file_location;
    VAR status: ost$status);

    status.normal := TRUE;
    file_locator := NIL;
{
{              set file locator
{
    CASE file_residence OF
    = gfc$tr_system =
      file_locator := osv$mainframe_wired_heap;
    = gfc$tr_job =
      file_locator := osv$job_fixed_heap;
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unrecognizable_file_res,
        'File residence not defined for file type.', status);
    CASEND;
  PROCEND dmp$set_file_table_locator;

?? TITLE := '  dmp$set_master_attach_lock', EJECT ??

  PROCEDURE [XDCL] dmp$set_master_attach_lock (system_file_id: gft$system_file_identifier);

    osp$set_mainframe_sig_lock (master_attach_lock [system_file_id.file_hash]);

  PROCEND dmp$set_master_attach_lock;

?? TITLE := '  dmp$trim_file', EJECT ??
  PROCEDURE [XDCL] dmp$trim_file (sfid: gft$system_file_identifier;
                                  byte_address: amt$file_byte_address;
                              VAR status: ost$status);

{ This procedure will trim, or deallocate, file space assigned to a file beyond the allocation unit which
{ contains the input parameter byte_address.
{ The general algorithm is:
{  1. determine whether or not the file is an acceptable candidate for trimming.
{  2. log fad purges for fads beyond the one which contains byte_address, and free the memory
{     tables which represent those fads.
{  3. "free" all file allocation units in memory tables which are beyond the FAU containing byte_address,
{     and call monitor to log an entry to the allocation log which will (when processed) cause the
{     DAT to be updated to reflect memory tables.

    TYPE
      untrimmed_reasons = (no_fde, purged, io_active, wrong_type, no_fmd, no_fads, log_entries_pending);

    VAR
      last_sfid_trimmed: [STATIC] gft$system_file_identifier,
      total_files_trimmed: [STATIC] integer := 0,
      total_files_untrimmed: [STATIC] integer := 0,
      untrimmed_files: [STATIC] array [untrimmed_reasons] of integer := [0, 0, 0, 0, 0, 0, 0];

    VAR
      fde_locked: boolean,
      fmd_index: dmt$fmd_index,
      file_locator: dmt$file_location,
      file_was_trimmed: boolean,
      first_byte_address: amt$file_byte_address,
      new_allocated_length: amt$file_byte_address,
      number_of_fmds: dmt$fmd_index,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      p_first_fau: ^dmt$file_allocation_unit,
      p_fmd: ^dmt$file_medium_descriptor,
      p_previous_fmd: ^dmt$file_medium_descriptor,
      trimming_appropriate: boolean;

    status.normal := TRUE;
    file_was_trimmed := FALSE;
    trimming_appropriate := TRUE;
    fde_locked := FALSE;

    { Determine whether or not the file is a candidate for trimming

    gfp$get_fde_p (sfid, p_fde);
    IF p_fde <> NIL THEN
      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
      IF p_dfd^.purged THEN
        trimming_appropriate := FALSE;
        untrimmed_files [purged] := untrimmed_files [purged] + 1;
      ELSEIF p_dfd^.read_write_count <> 0 THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$io_active,
          'Cannot trim when I/O outstanding - dmp$trim_file.', status);
        untrimmed_files [io_active] := untrimmed_files [io_active] + 1;
      ELSEIF (p_fde^.file_kind <> gfc$fk_job_permanent_file) AND (p_fde^.file_kind <> gfc$fk_catalog) THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$untrimmable_file_type,
          'Can only trim permanent or catalog files - dmp$trim_file.', status);
        untrimmed_files [wrong_type] := untrimmed_files [wrong_type] + 1;
      IFEND;
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
            'Cannot get file descriptor - dmp$trim_file.', status);
      untrimmed_files [no_fde] := untrimmed_files [no_fde] + 1;
    IFEND;

    IF status.normal and trimming_appropriate THEN
      dmp$set_file_table_locator (sfid.residence, file_locator, status);
    IFEND;

    IF status.normal and trimming_appropriate THEN
      gfp$get_locked_fde_p (sfid, p_fde);
      IF p_fde <> NIL THEN
        fde_locked := TRUE;
        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
      IFEND;
    IFEND;

    IF status.normal and trimming_appropriate THEN
      number_of_fmds := p_dfd^.number_of_fmds;
      IF number_of_fmds <= 0 THEN
        trimming_appropriate := FALSE;
        untrimmed_files [no_fads] := untrimmed_files [no_fads] + 1;
      IFEND;
    IFEND;

    IF status.normal and trimming_appropriate THEN

      {  must reject the request if delete_logging_count <> 0, as (if not) the logger will
      {  soon reference fmds to determine if it's OK to delete file tables for the file

      FOR fmd_index := 1 TO number_of_fmds DO
        dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);
        IF p_fmd^.in_use AND (p_fmd^.delete_logging_count <> 0) THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$outstanding_log_entries,
             'cannot trim with pending log entries - dmp$trim_file', status);
          untrimmed_files [log_entries_pending] := untrimmed_files [log_entries_pending] + 1;
        IFEND;
      FOREND;
    IFEND;

    { Determine whether or not there are any "excess" fmds.  If so, log a purge for each of them
    { and clean up memory tables.

    IF status.normal and trimming_appropriate THEN
      IF byte_address < p_dfd^.highest_offset_allocated THEN
        dmp$deallocate_file_space_r1 (sfid, byte_address, amc$file_byte_limit, p_fde, status);

        IF status.normal THEN
          calculate_allocated_length (p_dfd, fmd_index, new_allocated_length);
          p_dfd^.highest_offset_allocated := new_allocated_length;
          p_dfd^.current_fmd_index := fmd_index;

          fmd_index := number_of_fmds;
          dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);
          WHILE (p_fmd <> NIL) AND (p_fmd^.fmd_allocated_length =0) DO
            dmp$get_fmd_by_index (p_dfd, fmd_index - 1, p_previous_fmd);
            log_fmd_purge (p_fde^.global_file_name, p_fmd, status);

            IF p_previous_fmd <> NIL THEN
              p_previous_fmd^.p_next_fmd := NIL;
            ELSE  { this was the first fmd, so
              p_dfd^.p_fmd := NIL;
            IFEND;

            FREE p_fmd IN file_locator^;
            p_dfd^.number_of_fmds := p_dfd^.number_of_fmds - 1;
            p_dfd^.dfd_modified := TRUE;
            p_dfd^.fmd_modified := TRUE;

            p_fmd := p_previous_fmd;
            fmd_index := fmd_index - 1;
          WHILEND;
          file_was_trimmed := TRUE;
          IF (p_dfd^.dfd_modified) OR (p_fde^.flags.eoi_modified) THEN
            update_dfl_file_length (p_fde, p_dfd, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    { All done.  Clean up and exit.

    IF fde_locked THEN
      gfp$unlock_fde_p (p_fde);
    IFEND;

    IF file_was_trimmed THEN
      last_sfid_trimmed := sfid;
      total_files_trimmed := total_files_trimmed + 1;
    ELSE
      total_files_untrimmed := total_files_untrimmed + 1;
    IFEND;

  PROCEND dmp$trim_file;
?? TITLE := '  calculate_allocated_length', EJECT ??

  PROCEDURE calculate_allocated_length (p_dfd: ^dmt$disk_file_descriptor;
                       VAR fmd_index: dmt$fmd_index;
                       VAR new_allocated_length: amt$file_byte_address);

    VAR
      level_1_index: dmt$level_1_index,
      level_2_start,
      level_2_index: dmt$level_2_index,
      p_level_2: ^dmt$level_2_table;

    new_allocated_length := 0;
    fmd_index := 0;
    level_2_start := p_dfd^.bytes_per_level_2 DIV p_dfd^.bytes_per_allocation - 1;

    IF p_dfd^.file_allocation_table <> NIL THEN
    /find_eof/
      FOR level_1_index := p_dfd^.fat_upper_bound DOWNTO 0 DO
        dmp$get_level_2_ptr (^p_dfd^.file_allocation_table^ [level_1_index],
          p_level_2);
        IF p_level_2 <> NIL THEN
          FOR level_2_index := level_2_start DOWNTO 0 DO
            IF p_level_2^ [level_2_index].state > dmc$fau_free THEN
              new_allocated_length := (level_1_index * p_dfd^.bytes_per_level_2) +
                  (level_2_index * p_dfd^.bytes_per_allocation) + p_dfd^.bytes_per_allocation;
              fmd_index := p_level_2^ [level_2_index].fmd_index;
              EXIT /find_eof/;
            IFEND;
          FOREND;
        IFEND;
      FOREND /find_eof/;
    IFEND;

  PROCEND calculate_allocated_length;
?? TITLE := '  free_file_tables', EJECT ??

  PROCEDURE free_file_tables (system_file_id: gft$system_file_identifier;
    VAR status: ost$status);

    VAR
      able_to_release_fmd: boolean,
      avt_index: dmt$active_volume_table_index,
      file_locator: dmt$file_location,
      fmd_index: dmt$fmd_index,
      length: 8 .. 120,
      log_entry_to_purge_file: boolean,
      number_of_fmds: dmt$fmd_index,
      outstanding_io_on_file: boolean,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      p_fmd: ^dmt$file_medium_descriptor,
      p_rb_ring1_segment_request: ^mmt$rb_ring1_segment_request;

    status.normal := TRUE;

  /main_program/
    BEGIN
      dmp$set_file_table_locator (system_file_id.residence, file_locator, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      gfp$get_locked_fde_p (system_file_id, p_fde);
      IF p_fde = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
              'Bad SFID - free_file_tables.', status);
        EXIT /main_program/;
      IFEND;

    /fde_locked/
      BEGIN
        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
        IF p_dfd = NIL THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_not_created_for_file,
            'Nil FMD pointer - free_file_tables.', status);
          EXIT /fde_locked/;
        IFEND;

        log_entry_to_purge_file := p_dfd^.purged AND (p_fde^.file_kind <= gfc$fk_last_permanent_file);

        REPEAT
          outstanding_io_on_file := (p_dfd^.read_write_count <> 0);
          IF outstanding_io_on_file THEN
            pmp$delay (1000, status);
          IFEND;
        UNTIL NOT outstanding_io_on_file;

        remove_fde_active_thread (system_file_id, p_fde, status);
        number_of_fmds := p_dfd^.number_of_fmds;
        p_dfd^.purged := TRUE;

        IF log_entry_to_purge_file THEN
          FOR fmd_index := 1 TO number_of_fmds DO
            dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);
            log_fmd_purge (p_fde^.global_file_name, p_fmd, status);
            IF NOT status.normal THEN
              EXIT /fde_locked/;
            IFEND;
          FOREND;
        IFEND;

        IF p_fde^.asti <> 0 THEN
          PUSH p_rb_ring1_segment_request;
          p_rb_ring1_segment_request^.reqcode := syc$rc_ring1_segment_request;
          p_rb_ring1_segment_request^.status.normal := TRUE;
          p_rb_ring1_segment_request^.request := mmc$sr1_delete_seg_sfid;
          p_rb_ring1_segment_request^.sfid := system_file_id;

          mmp$issue_ring1_segment_request (p_rb_ring1_segment_request^);
          syp$set_status_from_mtr_status (p_rb_ring1_segment_request^.status,
                status);
          IF NOT status.normal THEN
            EXIT /fde_locked/;
          IFEND;
        IFEND;

        dmp$delete_disk_file_descriptor (system_file_id, p_fde, file_locator, status);
        IF status.normal THEN
          p_fde^.global_file_name := dmv$null_global_file_name;
          gfp$unlock_fde_p (p_fde);
          gfp$free_fde (p_fde,system_file_id);
          EXIT /main_program/;
        IFEND;

      END /fde_locked/;

      gfp$unlock_fde_p (p_fde);

    END /main_program/;

  PROCEND free_file_tables;

?? TITLE := '  log_fmd_purge ', EJECT ??
  PROCEDURE log_fmd_purge (global_file_name: dmt$global_file_name;
                               p_fmd: ^dmt$file_medium_descriptor;
                           VAR status: ost$status);

    VAR
      avt_index: dmt$active_volume_table_index,
      log_entry: dmt$dl_entry,
      volume_found: boolean;

    status.normal := TRUE;

    IF p_fmd <> NIL THEN
      IF p_fmd^.in_use AND p_fmd^.volume_assigned THEN

        dmp$search_avt_by_vsn (p_fmd^.internal_vsn, avt_index, volume_found);

        IF volume_found THEN
          log_entry.kind := dmc$dl_purge_file;
          log_entry.purge_file_block.global_file_name := global_file_name;
          log_entry.purge_file_block.file_byte_address := 0;
          log_entry.purge_file_block.dfl_index := p_fmd^.dfl_index;
          avt_index := p_fmd^.avt_index;

          dmp$process_device_log_entry (avt_index, log_entry, status);

        IFEND;
      IFEND;
    IFEND;

  PROCEND log_fmd_purge;

?? TITLE := '  log_sft_delete', EJECT ??
  PROCEDURE log_sft_delete (sfid: gft$system_file_identifier;
        p_fde: ^gft$file_descriptor_entry;
    VAR logging_performed: boolean;
    VAR status: ost$status);

    VAR
      avt_index: dmt$active_volume_table_index,
      fmd_index: dmt$fmd_index,
      logging_active: boolean,
      log_entry: dmt$dl_entry,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fmd: ^dmt$file_medium_descriptor;

    status.normal := TRUE;
    logging_performed := FALSE;

    { Issue a dmc$dl_first_sft_delete log entry for each fad residing
    { on a volume for which logging is active.  If an error is encountered
    { while processing the log entry for a fad, no additional fads
    { are processed.  The delete_logging_count for the fad encountering
    { the error will prevent the file from being deleted, avoiding the
    { danger of the file being re-attached while there is outstanding log
    { activity.

    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
    log_entry.kind := dmc$dl_first_sft_delete;
    log_entry.sft_delete_block.global_file_name := p_fde^.global_file_name;
    log_entry.sft_delete_block.sfid := sfid;

    FOR fmd_index := 1 TO p_dfd^.number_of_fmds DO
      dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);
      IF p_fmd^.in_use AND p_fmd^.volume_assigned THEN
        avt_index := p_fmd^.avt_index;
        logging_active := NOT dmv$p_active_volume_table^ [avt_index].mass_storage.logged_in_for_recovery AND
              (dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log <> dmv$null_sfid);
        IF logging_active THEN
          logging_performed := TRUE;
          p_fmd^.delete_logging_count := p_fmd^.delete_logging_count + 1;
          log_entry.sft_delete_block.dfl_index := p_fmd^.dfl_index;
          log_entry.sft_delete_block.fmd_index := fmd_index;
          dmp$process_device_log_entry (avt_index, log_entry, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND log_sft_delete;

?? TITLE := '  remove_fde_active_thread', EJECT ??

  PROCEDURE remove_fde_active_thread (system_file_id: gft$system_file_identifier;
        p_fde: gft$file_desc_entry_p;
    VAR status: ost$status);

    VAR
      p_previous_fde: gft$file_desc_entry_p,
      entry_found: boolean,
      file_hash: dmt$file_hash;

    status.normal := TRUE;

    entry_found := FALSE;
    file_hash := system_file_id.file_hash;

    IF file_hash_threads [file_hash] = p_fde THEN
      file_hash_threads [file_hash] := p_fde^.file_hash_thread;
      p_fde^.file_hash_thread := NIL;
      RETURN;
    IFEND;

    p_previous_fde := file_hash_threads [file_hash];

  /search_for_entry/
    WHILE (p_previous_fde <> NIL) DO
      IF p_previous_fde^.file_hash_thread = p_fde THEN
        p_previous_fde^.file_hash_thread := p_fde^.file_hash_thread;
        entry_found := TRUE;
        EXIT /search_for_entry/;
      ELSE
        p_previous_fde := p_previous_fde^.file_hash_thread;
      IFEND;
    WHILEND /search_for_entry/;

    IF NOT entry_found THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fde_queuing_error,
        'Trying to remove FDE not in active queue - remove_fde_active_thread.', status);
      RETURN;
    IFEND;

    p_fde^.file_hash_thread := NIL;

  PROCEND remove_fde_active_thread;

?? TITLE := '  update_dfl_file_length', EJECT ??

  PROCEDURE update_dfl_file_length (p_fde: ^gft$file_descriptor_entry;
                                    p_dfd: ^dmt$disk_file_descriptor;
                                VAR status: ost$status);

    VAR
      avt_index: dmt$active_volume_table_index,
      entry_to_be_processed: boolean,
      fmd_number: dmt$fmd_index,
      log_entry: dmt$dl_entry,
      p_fmd: ^dmt$file_medium_descriptor,
      number_of_fmds: dmt$fmd_index;

    status.normal := TRUE;
    dmp$get_fmd_by_index (p_dfd, 1, p_fmd);

    IF p_fmd = NIL THEN
      RETURN;
    IFEND;
    avt_index := p_fmd^.avt_index;

    log_entry.kind := dmc$dl_update_file_length;
    log_entry.file_length_block.global_file_name := p_fde^.global_file_name;
    log_entry.file_length_block.dfl_index := p_fmd^.dfl_index;
    log_entry.file_length_block.eof_specified := TRUE;
    log_entry.file_length_block.eof := (p_fde^.eoi_byte_address +
        p_dfd^.bytes_per_allocation - 1) DIV p_dfd^.bytes_per_allocation *
        p_dfd^.bytes_per_allocation;
    log_entry.file_length_block.eoi_specified := TRUE;
    log_entry.file_length_block.eoi := gfp$get_eoi_from_fde (p_fde);

    dmp$process_device_log_entry (avt_index, log_entry, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    number_of_fmds := p_dfd^.number_of_fmds;

    log_entry.kind := dmc$dl_update_fmd_length;
    log_entry.fmd_length_block.global_file_name := p_fde^.global_file_name;
    log_entry.fmd_length_block.fmd_length_specified := TRUE;
    log_entry.fmd_length_block.logical_length_specified := TRUE;

    FOR fmd_number := 1 TO number_of_fmds DO
      dmp$get_fmd_by_index (p_dfd, fmd_number, p_fmd);
      entry_to_be_processed := p_fmd^.in_use AND p_fmd^.volume_assigned;

      IF entry_to_be_processed THEN
        avt_index := p_fmd^.avt_index;
        log_entry.fmd_length_block.dfl_index := p_fmd^.dfl_index;
        log_entry.fmd_length_block.fmd_length := p_fmd^.fmd_allocated_length;
        log_entry.fmd_length_block.logical_length := p_fmd^.fmd_allocated_length;

        dmp$process_device_log_entry (avt_index, log_entry, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    p_dfd^.dfd_modified := FALSE;
    p_fde^.flags.eoi_modified := FALSE;

  PROCEND update_dfl_file_length;
?? OLDTITLE ??
MODEND dmm$file_table_manager;
*DECK DECK=DMM$FLAW_MANAGEMENT EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$flaw_management;

{
{  PURPOSE:
{
{    This module contains the code which is needed in ring one to assist in
{    the management of flaws on devices maintained by device management.
{
?? PUSH (LISTEXT := ON) ??
?? TITLE := 'XREF procedures', EJECT ??
*copyc dmp$clear_update_lock
*copyc dmp$close_file
*copyc dmp$get_logical_unit_number
*copyc dmp$get_physical_attributes
*copyc dmp$open_dat
*copyc dmp$search_active_volume_table
*copyc dmp$set_update_lock
*copyc cmp$pc_get_logical_unit
*copyc dsp$log_sys_msg_help
*copyc osp$set_status_abnormal
?? TITLE := 'Global type declarations', EJECT ??
*copyc cml$ms_media_flaw_change
*copyc cmt$element_definition
*copyc cmt$product_identification
*copyc dmt$active_volume_table_index
*copyc dmt$avt_search_key
*copyc dmt$device_allocation_unit
*copyc dmt$error_condition_codes
*copyc dmt$flaw_dau_definition
*copyc dmt$flaw_duplication
*copyc dmt$log_flaw_init_data
*copyc dmt$ms_device_allocation_table
*copyc dmt$sc_flaw_command
*copyc dmt$system_file_id
*copyc dmt$physical_device_attributes
*copyc dmv$p_sc_flaw_commands
*copyc iot$cylinder
*copyc iot$logical_unit
*copyc ost$status
*copyc osv$mainframe_pageable_heap
*copyc rmt$recorded_vsn
?? TITLE := 'Global variable declarations', EJECT ??
*copyc dmv$active_volume_table
*copyc dmv$null_sfid
?? POP ??
?? TITLE := '  dmp$construct_sc_dau_list', EJECT ??
  PROCEDURE [XDCL] dmp$construct_sc_dau_list (
        rvsn: rmt$recorded_vsn;
        scan_only: boolean;
    VAR p_sc_dau_list: ^array [1 .. *] of dmt$log_flaw_init_data;
    VAR applicable_flaw_count: integer;
    VAR status: ost$status);

{   PURPOSE:
{     This procedure will compare each entry in the array of system core flaw commands
{     with the rvsn given in it's paramater.  If there is an entry with the same rvsn,
{     the physical address will be converted to a range of dau addresses and added to
{     p_sc_dau_list array.  If the input parameter scan_only is true, nothing else will
{     be done.  If false, each matching entry in dmv$p_sc_flaw_commands will be marked as
{     processed.  If all entries in the array are set in the dat, a FREE command will be
{     issued for the pointer.

    VAR
      dau_adrs: dmt$dau_address,
      end_dau_adrs: dmt$dau_address,
      index: integer,
      p_phys_adrs: ^dmt$physical_flaw_address,
      release_sc_flaw_commands: boolean,
      sec_specified: boolean,
      trk_specified: boolean;


    applicable_flaw_count := 0;
    status.normal := TRUE;

    IF dmv$p_sc_flaw_commands = NIL THEN
      RETURN;
    IFEND;

    release_sc_flaw_commands := NOT scan_only;

    FOR index := LOWERBOUND (dmv$p_sc_flaw_commands^) TO UPPERBOUND (dmv$p_sc_flaw_commands^) DO
      IF (dmv$p_sc_flaw_commands^ [index].rvsn = rvsn) AND
            (dmv$p_sc_flaw_commands^ [index].flaw_processed = FALSE) THEN
        IF NOT scan_only THEN
          dmv$p_sc_flaw_commands^ [index].flaw_processed := TRUE;
        IFEND;

        p_phys_adrs := ^dmv$p_sc_flaw_commands^ [index].phys_adrs;
        sec_specified := dmv$p_sc_flaw_commands^ [index].sec_specified;
        trk_specified := dmv$p_sc_flaw_commands^ [index].trk_specified;
        dmp$convert_to_dau_address (rvsn, p_phys_adrs, trk_specified, sec_specified,
            dau_adrs, end_dau_adrs, status);
        IF status.normal THEN
          applicable_flaw_count := applicable_flaw_count + 1;
          p_sc_dau_list^ [applicable_flaw_count].recorded_vsn := rvsn;
          p_sc_dau_list^ [applicable_flaw_count].first_dau := dau_adrs;
          p_sc_dau_list^ [applicable_flaw_count].last_dau := end_dau_adrs;
          p_sc_dau_list^ [applicable_flaw_count].operation_code := dmc$oc_flaw_define;
          p_sc_dau_list^ [applicable_flaw_count].initiator_code := dmc$ic_operator_initiated;
        IFEND;
      IFEND;
    FOREND;

    FOR index := LOWERBOUND (dmv$p_sc_flaw_commands^) TO UPPERBOUND (dmv$p_sc_flaw_commands^) DO
      IF dmv$p_sc_flaw_commands^ [index].flaw_processed = FALSE THEN
        release_sc_flaw_commands := FALSE;
      IFEND;
    FOREND;

    IF release_sc_flaw_commands THEN
      FREE dmv$p_sc_flaw_commands in osv$mainframe_pageable_heap^;
    IFEND;

  PROCEND dmp$construct_sc_dau_list;
?? TITLE := '  dmp$convert_to_dau_address', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$convert_to_dau_address (recorded_vsn: rmt$recorded_vsn;
        p_phys_adrs: ^dmt$physical_flaw_address;
        trk_specified: boolean;
        sec_specified: boolean;
    VAR dau_address: dmt$dau_address;
    VAR end_dau_address: dmt$dau_address;
    VAR status: ost$status);

{   PURPOSE:
{     This procedure will convert the LCU cylinder, track, and sector operator entry
{     into a range of DAU addresses.

    VAR
      element_def: ^cmt$element_definition,
      end_sector_address: integer,
      lun: iot$logical_unit,
      p_physical_attributes: ^dmt$physical_device_attributes,
      product_id: cmt$product_identification,
      sector_address: integer,
      unused_sector_count: integer;

    end_sector_address := 0;
    status.normal := TRUE;

    dmp$get_logical_unit_number (recorded_vsn, lun, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH element_def;

    cmp$pc_get_logical_unit (lun, element_def, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    product_id := element_def^.product_id;

    PUSH p_physical_attributes: [1 .. 5];
    p_physical_attributes^[1].keyword := dmc$maus_per_cylinder;
    p_physical_attributes^[2].keyword := dmc$sectors_per_mau;
    p_physical_attributes^[3].keyword := dmc$sectors_per_track;
    p_physical_attributes^[4].keyword := dmc$maus_per_dau;
    p_physical_attributes^[5].keyword := dmc$cylinders_per_device;

    dmp$get_physical_attributes (product_id, p_physical_attributes, status);

{ Check the parameters given in the flaw command to see if they are in the physical range
{ of the device.

    IF p_phys_adrs^.cylinder >= p_physical_attributes^[5].cylinders_per_device THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$cylinder_limit_exceeded,
        'dmp$convert_to_dau_address', status);
      RETURN;
    ELSEIF trk_specified AND
        (p_phys_adrs^.track * p_physical_attributes^[3].sectors_per_track DIV
            p_physical_attributes^[2].sectors_per_mau >= p_physical_attributes^[1].maus_per_cylinder) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$track_limit_exceeded,
        'dmp$convert_to_dau_address', status);
      RETURN;
    ELSEIF sec_specified AND (p_phys_adrs^.sector >= p_physical_attributes^[3].sectors_per_track) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$sector_limit_exceeded,
        'dmp$convert_to_dau_address', status);
      RETURN;

{ If the last track in a cylinder is selected, check to insure the space is used.
{ On some devices, the number of sectors per DAU does not come out evenly.  The
{ remaining sectors are not used as a DAU can not cross cylinder boundaries.

    ELSEIF sec_specified AND ((p_phys_adrs^.track + 1) * p_physical_attributes^[3].sectors_per_track DIV
            p_physical_attributes^[2].sectors_per_mau >= p_physical_attributes^[1].maus_per_cylinder) THEN

      IF (p_phys_adrs^.sector >= p_physical_attributes^[3].sectors_per_track - (((p_phys_adrs^.track + 1) *
          p_physical_attributes^[3].sectors_per_track) - (p_physical_attributes^[2].sectors_per_mau *
               p_physical_attributes^[1].maus_per_cylinder))) THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unaddressable_sector,
            'dmp$convert_to_dau_address', status);
        RETURN;
      IFEND;

    IFEND;

{ If the last track on a cylinder is to be flawed, save the number of un-used sectors in the cylinder, if any,
{ so the number of sectors to be flawed can be adjusted later.

    IF ((p_phys_adrs^.track + 1) * p_physical_attributes^[3].sectors_per_track DIV
            p_physical_attributes^[2].sectors_per_mau >= p_physical_attributes^[1].maus_per_cylinder) THEN
      unused_sector_count := (((p_phys_adrs^.track + 1) * p_physical_attributes^[3].sectors_per_track) -
         (p_physical_attributes^[2].sectors_per_mau * p_physical_attributes^[1].maus_per_cylinder));
    ELSE
      unused_sector_count := 0;
    IFEND;

{ Since all parameters are in range, calculate the DAUs to be flawed.

    sector_address := p_phys_adrs^.cylinder * p_physical_attributes^[2].sectors_per_mau *
       p_physical_attributes^[1].maus_per_cylinder;
    IF trk_specified THEN
      sector_address := sector_address + (p_phys_adrs^.track * p_physical_attributes^[3].sectors_per_track);
      IF sec_specified THEN
        sector_address := sector_address + p_phys_adrs^.sector;
      ELSE
        end_sector_address := sector_address + (p_physical_attributes^[3].sectors_per_track) - 1 -
           unused_sector_count;
      IFEND;
    ELSE
      end_sector_address := sector_address + (p_physical_attributes^[2].sectors_per_mau *
         p_physical_attributes^[1].maus_per_cylinder) - 1;
    IFEND;

    dau_address := sector_address DIV (p_physical_attributes^[2].sectors_per_mau *
       p_physical_attributes^[4].maus_per_dau);

    IF end_sector_address = 0 THEN
      end_dau_address := dau_address;
    ELSE
      end_dau_address := end_sector_address DIV (p_physical_attributes^[2].sectors_per_mau *
         p_physical_attributes^[4].maus_per_dau);
    IFEND;
  PROCEND dmp$convert_to_dau_address;
?? TITLE := '  dmp$process_sc_flaw_commands', EJECT ??
  PROCEDURE [XDCL] dmp$process_sc_flaw_commands (avt_index: dmt$active_volume_table_index;
        dat_sfid: dmt$system_file_id;
        recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

{   PURPOSE:
{     This procedure will call a procedure to construct the flaw list, set the update lock,
{     open the dat, and call a procedure to process the flaws.  The lock will then be removed
{     and the DAT closed.

    VAR
      able_to_set_lock: boolean,
      applicable_flaw_count: integer,
      p_dat: ^dmt$ms_device_allocation_table,
      p_sc_dau_list: ^array [1 .. *] of dmt$log_flaw_init_data;

    status.normal := TRUE;
    applicable_flaw_count := 0;

    IF dmv$p_sc_flaw_commands <> NIL THEN
      PUSH p_sc_dau_list: [1 .. UPPERBOUND (dmv$p_sc_flaw_commands^)];
      dmp$construct_sc_dau_list (recorded_vsn, FALSE, p_sc_dau_list, applicable_flaw_count, status);
    ELSE
      RETURN;
    IFEND;

    IF applicable_flaw_count <> 0 THEN
      dmp$open_dat (dat_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend,
           mmc$as_sequential, p_dat, status);
      IF status.normal THEN
        dmp$set_update_lock (avt_index, TRUE, able_to_set_lock);
        IF able_to_set_lock THEN
          dmp$record_sc_flaw (applicable_flaw_count, p_dat, p_sc_dau_list);
          dmp$clear_update_lock (avt_index);
        IFEND;
        dmp$close_file (p_dat, status);
      IFEND;
    IFEND;
  PROCEND dmp$process_sc_flaw_commands;
?? TITLE := '  dmp$record_sc_flaw', EJECT ??
  PROCEDURE [XDCL] dmp$record_sc_flaw (applicable_flaw_count: integer;
        p_dat: ^dmt$ms_device_allocation_table;
        p_sc_dau_list: ^array [1 .. *] of dmt$log_flaw_init_data);

{   PURPOSE:
{     This procedure will change the DAU status in the DAT to reflect flaws
{     and issue a flaw statistic reporting the change to the engineering log.

    VAR
      dau_index: integer,
      index: integer,
      first_dau: dmt$dau_address,
      last_dau: dmt$dau_address,
      flaw_logging_data: dmt$log_flaw_init_data,
      p_dat_entry: ^dmt$ms_device_allocation_unit,
      p_log_data: ^SEQ (*),
      previous_status: dmt$dau_status;

    /process_flaw_list/
    FOR index := LOWERBOUND (p_sc_dau_list^) TO applicable_flaw_count DO

      first_dau := p_sc_dau_list^ [index].first_dau;
      last_dau := p_sc_dau_list^ [index].last_dau;
      p_dat_entry := ^p_dat^.body [first_dau];
      previous_status := p_dat_entry^.dau_status;

{ If only one DAU is to be altered, then check the DAU's status before changing.

      IF first_dau = last_dau THEN
        IF (previous_status = dmc$dau_software_flawed) OR (previous_status = dmc$dau_ass_to_mf_swr_flawed)
               OR (previous_status = dmc$dau_ass_to_file_swr_flawed) OR
               (previous_status = dmc$dau_hardware_flawed) THEN
          CYCLE /process_flaw_list/; {Do not issue statistic to the engineering log}
        IFEND;
      IFEND;

{ Change the DAU status to flawed.

      FOR dau_index := first_dau TO last_dau DO

        p_dat_entry := ^p_dat^.body [dau_index];
        CASE p_dat_entry^.dau_status OF

        = dmc$dau_usable =
          p_dat_entry^.dau_status := dmc$dau_software_flawed;
          p_dat^.header.available := p_dat^.header.available - 1;

        = dmc$dau_assigned_to_mainframe =
          p_dat_entry^.dau_status := dmc$dau_ass_to_mf_swr_flawed;

        = dmc$dau_assigned_to_file =
          p_dat_entry^.dau_status := dmc$dau_ass_to_file_swr_flawed;

        = dmc$dau_hardware_flawed, dmc$dau_software_flawed, dmc$dau_ass_to_mf_swr_flawed,
            dmc$dau_ass_to_file_swr_flawed =

        ELSE
          ;
        CASEND;
      FOREND;

{ Issue statistics about flaw to the engineering log.

      p_log_data := #SEQ (p_sc_dau_list^ [index]);
      dsp$log_sys_msg_help (cml$ms_media_flaw_change, p_log_data);
    FOREND /process_flaw_list/;

  PROCEND dmp$record_sc_flaw;
?? TITLE := '  dmp$store_sc_flaw_command', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$store_sc_flaw_command (
        p_sc_flaw: ^dmt$sc_flaw_command);

{   PURPOSE:
{     This procedure will add the new system core flaw command to the existing array
{     of commands, if one is present, or create an array of one entry if it has not
{     yet been created.

    VAR
      flaw_index: integer,
      free_ptr: ^array [1 .. *] of dmt$sc_flaw_command,
      new_count: integer,
      p_new_sc_flaws: ^array [1 .. *] of dmt$sc_flaw_command,
      present_count: integer;

    IF dmv$p_sc_flaw_commands <> NIL THEN
      present_count := UPPERBOUND (dmv$p_sc_flaw_commands^);
      new_count := present_count + 1;

      ALLOCATE p_new_sc_flaws: [1 .. new_count] IN osv$mainframe_pageable_heap^;

      FOR flaw_index := 1 TO present_count DO
        p_new_sc_flaws^ [flaw_index] := dmv$p_sc_flaw_commands^ [flaw_index];
      FOREND;

      p_new_sc_flaws^ [new_count] := p_sc_flaw^;

      free_ptr := dmv$p_sc_flaw_commands;
      dmv$p_sc_flaw_commands := p_new_sc_flaws;
      FREE free_ptr IN osv$mainframe_pageable_heap^;
    ELSE
      ALLOCATE dmv$p_sc_flaw_commands: [1 .. 1] IN osv$mainframe_pageable_heap^;

      dmv$p_sc_flaw_commands^ [1] := p_sc_flaw^;
    IFEND;
  PROCEND dmp$store_sc_flaw_command;
MODEND dmm$flaw_management;
*DECK DECK=DMM$FMD_MANAGER EXPAND=TRUE

?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$fmd_manager;

{
{ PURPOSE:
{
{  The purpose of this module is to manage the File Medium Descriptor for
{  files described in the system and job file tables.  This includes creation
{  and deletion of the FMD and the updating of information stored in the FMD.
?? TITLE := '  Common Decks', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmp$close_file
*copyc dmp$generate_gfn_hash
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_active_vol_attributes
*copyc dmp$get_fmd_by_index
*copyc dmp$get_fau_entry_and_fmd
*copyc dmp$get_level_2_ptr
*copyc dmp$get_mat_pointer
*copyc dmp$get_next_fmd_fau
*copyc dmp$get_previous_fau_entry
*copyc dmp$open_dat
*copyc dmp$open_dflt
*copyc dmp$preset_conversion
*copyc dmp$process_device_log_entry
*copyc dmp$search_avt_by_vsn
*copyc dmp$search_fdt_by_gfn
*copyc dmp$set_file_table_locator
*copyc dmt$allocation_size
*copyc dmt$assigned_ms_vol_attributes
*copyc dmt$error_condition_codes
*copyc dmt$file_medium_descriptor
*copyc dmt$file_allocation_table
*copyc dmt$file_location
*copyc dmt$keypoint_calls
*copyc dmt$mainframe_allocation_table
*copyc dmt$monitor_request_blocks
*copyc dmt$ms_device_allocation_table
*copyc dmt$ms_device_file_list_entry
*copyc dmt$fmd_index
*copyc dmt$stored_fmd
*copyc dmt$stored_fmd_size
*copyc dmt$stored_ms_fmd_header
*copyc dmv$active_volume_table
*copyc dmv$default_fau_entry
*copyc dmv$null_vsn
*copyc dpp$put_critical_message
*copyc gfp$get_fde_p
*copyc gfp$get_locked_fde_p
*copyc gfp$unlock_fde_p
*copyc i#call_monitor
*copyc i#move
*copyc osp$append_status_parameter
*copyc osp$fatal_system_error
*copyc mme$condition_codes
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc osv$deadstart_phase
*copyc osv$mainframe_wired_heap
*copyc osv$job_fixed_heap
*copyc pmp$convert_binary_unique_name
*copyc pmp$cycle
*copyc pmp$zero_out_table
*copyc syp$continue_to_cause
*copyc syp$disestablish_cond_handler
*copyc syp$establish_condition_handler
?? POP ??
?? FMT (FORMAT := OFF, keyw := upper, ident := lower) ??
  VAR
    default_fmd: [STATIC, READ] dmt$file_medium_descriptor :=
      {in_use:=}                         [FALSE,
      {system_file_id:=}                 [0, gfc$tr_null_residence, gfc$null_file_hash],
      {avt_index:=}                      0,
      {device_file_list_index:=}         0,
      {delete_logging_count:=}           0,
      {volume_assigned:=}                FALSE,
      {fmd_allocated_length:=}           0,
      {bytes_per_mau:=}                  dmc$min_bytes_per_mau,
      {daus_per_cylinder:=}              dmc$min_daus_position,
      {daus_per_allocation_unit:=}       dmc$min_daus_allocation,
      {internal_vsn:=}                   [0,osc$cyber_180_model_unknown,1988,1,1,
                                          0,0,0,0,0],
      {maus_per_dau:=}                   dmc$min_maus_per_dau,
      {maus_per_transfer_unit:=}         dmc$min_maus_per_transfer,
      {p_next_fmd:=}                     NIL,
      {allocation_style:=}               dmc$a0];

?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
{
{   The purpose of this routine is to change whether overflow is allowed
{ for an attached file.  The file must be attached and a permanent file.
{ This will have the effect of causing the catalog to be updated on the
{ next detach of the file.
{
  PROCEDURE [XDCL, #GATE] dmp$change_overflow_allowed
    (    global_file_name: dmt$global_file_name;
         overflow_allowed: boolean;
     VAR status: ost$status);

    VAR
      existing_fde_entry_found: boolean,
      file_entry_index: gft$file_descriptor_index,
      local_status: ost$status,
      p_fde: gft$file_desc_entry_p,
      p_dfd: ^dmt$disk_file_descriptor,
      system_file_id: gft$system_file_identifier;

    status.normal := TRUE;
    system_file_id.residence := gfc$tr_system;

    dmp$generate_gfn_hash (global_file_name, system_file_id.file_hash);

    dmp$search_fdt_by_gfn (gfc$tr_system, global_file_name, system_file_id.file_entry_index,
          existing_fde_entry_found);
    IF NOT existing_fde_entry_found THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
            ' Unable to change overflow allowed ', status);
    IFEND;

    gfp$get_locked_fde_p (system_file_id, p_fde);

  /fde_locked/
    BEGIN
      existing_fde_entry_found := p_fde^.global_file_name = global_file_name;
      IF NOT existing_fde_entry_found THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
              ' Unable to change overlow allowed - fde wrong state ', status);
        EXIT /fde_locked/;
      IFEND;

      IF p_fde^.media = gfc$fm_served_file THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unexpected_server_file,
              'Server file encountered - dmp$change_overflow_allowed.', status);
        EXIT /fde_locked/;
      IFEND;

      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
      IF p_dfd^.purged THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
              'DFD purged - dmp$change_overflow_allowed.', status);
      ELSE
        p_dfd^.overflow_allowed := overflow_allowed;
        p_dfd^.fmd_modified := TRUE;
      IFEND;
    END /fde_locked/;

    gfp$unlock_fde_p (p_fde);

  PROCEND dmp$change_overflow_allowed;
?? TITLE := '  dmp$build_fmd_for_existing_file', EJECT ??
  PROCEDURE [XDCL] dmp$build_fmd_for_existing_file
    (    p_fde: gft$file_desc_entry_p;
         p_dfd: ^dmt$disk_file_descriptor;
         system_file_id: gft$system_file_identifier;
     VAR file_damaged: boolean;
     VAR file_flawed: boolean;
     VAR status: ost$status);

    VAR
      avt_index: dmt$active_volume_table_index,
      dat_sfid: gft$system_file_identifier,
      dfl_entry: dmt$ms_device_file_list_entry,
      dfl_gfn_string: ost$name,
      dflt_sfid: gft$system_file_identifier,
      fmd_count: dmt$fmd_index,
      fmd_index: dmt$fmd_index,
      found: boolean,
      gfn_string: ost$name,
      initialized_length: integer,
      length: integer,
      log_entry: dmt$dl_entry,
      msg: string (osc$max_string_size),
      p_dflt: ^dmt$ms_device_file_list_table,
      p_fmd: ^dmt$file_medium_descriptor,
      p_mat: ^dmt$mainframe_allocation_table,
      level_1_start,
      level_1_index: dmt$level_1_index,
      level_2_start,
      level_2_index: dmt$level_2_index,
      p_level_2: ^dmt$level_2_table,
      subfile_flawed: boolean,
      vsn: rmt$recorded_vsn;

?? EJECT ??
    PROCEDURE dfl_condition_handler (mf: ost$monitor_fault;
                                     p_msa: ^ost$minimum_save_area;
                                 VAR continue: syt$continue_option);
      VAR
        p_scc: ^syt$system_core_condition,
        p_sac: ^mmt$segment_access_condition;

      IF mf.identifier = mmc$segment_fault_processor_id THEN
        p_sac := #LOC(mf.contents);
        CASE p_sac^.identifier OF
        = mmc$sac_io_read_error =
          osp$set_status_abnormal ('MM', mme$io_read_error,
             'io error referencing DFL - dmp$build_fad_for_existing_file', status);
          EXIT dmp$build_fmd_for_existing_file;
        ELSE
        CASEND;
      ELSEIF mf.identifier = syc$system_core_condition THEN
        p_scc := #LOC(mf.system_core_condition);
        CASE p_scc^.condition OF
        = syc$user_defined_condition =
          IF p_scc^.user_defined_condition = syc$udc_volume_unavailable THEN
            osp$set_status_abnormal ('MM', mme$volume_unavailable,
             'io error referencing DFL - dmp$build_fmd_for_existing_file', status);
            EXIT dmp$build_fmd_for_existing_file;
          IFEND;
        ELSE
        CASEND;
      IFEND;

      syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);

    PROCEND dfl_condition_handler;
?? SKIP := 3 ??

    status.normal := TRUE;
    file_flawed := FALSE;
    fmd_count := p_dfd^.number_of_fmds;

  /process_request/
    FOR fmd_index := 1 TO fmd_count DO
      dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);

      dmp$search_avt_by_vsn (p_fmd^.internal_vsn, avt_index, found);
      IF NOT found THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
              'Volume not in AVT - dmp$build_fmd_for_existing_file.', status);
        EXIT /process_request/;
      IFEND;

      dflt_sfid := dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_file_list_table;
      dat_sfid := dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_allocation_table;

      dmp$get_mat_pointer (avt_index, p_mat);

      syp$establish_condition_handler (^dfl_condition_handler);

      dmp$open_dflt (dflt_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_read, mmc$as_sequential, p_dflt,
            status);
      IF status.normal THEN
        dfl_entry := p_dflt^.entries [p_fmd^.dfl_index];
        dmp$close_file (p_dflt, status);
      IFEND;

      syp$disestablish_cond_handler;

      IF status.normal THEN
        IF (dfl_entry.flags <> dmc$dfle_assigned_to_file) OR
              (p_fde^.global_file_name <> dfl_entry.global_file_name) THEN
          pmp$convert_binary_unique_name (p_fde^.global_file_name, gfn_string, status);
          vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;
          IF (dfl_entry.flags <> dmc$dfle_assigned_to_file) THEN
            STRINGREP (msg, length, 'Invalid subfile (DFL not file), gfn = ', gfn_string, ', subfile =',
                  fmd_index, ', vsn = ', vsn, ', dfl =', p_fmd^.dfl_index,
                  ' - dmp$build_fmd_for_existing_file.')
          ELSE
            pmp$convert_binary_unique_name (dfl_entry.global_file_name, dfl_gfn_string, status);
            STRINGREP (msg, length, 'Invalid subfile (wrong GFN), gfn = ', gfn_string, ', subfile =',
                  fmd_index, ', vsn = ', vsn, ', dfl =', p_fmd^.dfl_index, ', dfl_gfn = ',
                  dfl_gfn_string, ' - dmp$build_fmd_for_existing_file.');
          IFEND;
          osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_subfile, msg (1, length), status);
        IFEND;
      IFEND;

      IF status.normal THEN
        p_fmd^.avt_index := avt_index;

        IF fmd_index = 1 THEN {???? OK ????}
          {Pick up from first subfile
          p_fde^.eoi_byte_address := dfl_entry.end_of_information;
          file_damaged := (dmc$media_image_inconsistent IN dfl_entry.damage);
          p_dfd^.file_damaged := file_damaged;
        IFEND;

        dmp$build_faus_from_dfl_entry (dat_sfid, dfl_entry, p_fmd, p_dfd, p_mat, system_file_id, fmd_index,
                subfile_flawed, status);
        file_flawed := file_flawed OR subfile_flawed;
      IFEND;

      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;
    FOREND /process_request/;

    IF status.normal AND (p_fde^.eoi_byte_address = amc$file_byte_limit) THEN

{      This file was attached in write mode during a recovery without image.
{      The eoi and eof must be updated to reflect the reality of ALL fmds.

      level_1_start := p_dfd^.fat_upper_bound;
      level_2_start := p_dfd^.bytes_per_level_2 DIV p_dfd^.bytes_per_allocation - 1;
      initialized_length := 0;

      IF p_dfd^.file_allocation_table <> NIL THEN
      /find_eoi/
        FOR level_1_index := level_1_start DOWNTO 0 DO
          dmp$get_level_2_ptr (^p_dfd^.file_allocation_table^ [level_1_index],
            p_level_2);
          IF p_level_2 <> NIL THEN
            FOR level_2_index := level_2_start DOWNTO 0 DO
              IF (p_level_2^ [level_2_index].state = dmc$fau_initialized) OR
                       (p_level_2^ [level_2_index].state = dmc$fau_initialized_and_flawed) THEN
                initialized_length := (level_1_index * p_dfd^.bytes_per_level_2) +
                    (level_2_index * p_dfd^.bytes_per_allocation) + p_dfd^.bytes_per_allocation;
                EXIT /find_eoi/;
              IFEND;
            FOREND;
          IFEND;
        FOREND /find_eoi/;
      IFEND;

      p_fde^.eoi_byte_address := initialized_length;

      dmp$get_fmd_by_index (p_dfd, 1, p_fmd);

      log_entry.kind := dmc$dl_update_file_length;
      log_entry.file_length_block.global_file_name := p_fde^.global_file_name;
      log_entry.file_length_block.dfl_index := p_fmd^.dfl_index;

      log_entry.file_length_block.eof_specified := TRUE;
      log_entry.file_length_block.eof := initialized_length;

      log_entry.file_length_block.eoi_specified := TRUE;
      log_entry.file_length_block.eoi := initialized_length;

      dmp$process_device_log_entry (p_fmd^.avt_index, log_entry, status);
    IFEND;

  PROCEND dmp$build_fmd_for_existing_file;
?? TITLE := '  dmp$build_faus_from_dfl_entry', EJECT ??
  PROCEDURE [XDCL] dmp$build_faus_from_dfl_entry
    (    dat_sfid: gft$system_file_identifier;
         dfl_entry: dmt$ms_device_file_list_entry;
         p_fmd: ^dmt$file_medium_descriptor;
         p_dfd: ^dmt$disk_file_descriptor;
         p_mat: ^dmt$mainframe_allocation_table;
         system_file_id: gft$system_file_identifier;
         fmd_index: dmt$fmd_index;
     VAR file_flawed: boolean;
     VAR status: ost$status);

    VAR
      allocation_style: dmt$allocation_styles,
      allocation_style_found: boolean,
      bytes_per_allocation: dmt$bytes_per_allocation,
      close_status: ost$status,
      dau_address: dmt$dau_address,
      dau_byte_address: amt$file_byte_address,
      dau_entry: dmt$ms_device_allocation_unit,
      end_of_allocation_chain: boolean,
      gfn_string: ost$name,
      length: integer,
      msg: string (osc$max_string_size),
      p_fde: gft$file_desc_entry_p,
      p_dat: ^dmt$ms_device_allocation_table,
      p_fau_entry: ^dmt$file_allocation_unit,
      p_str: ^string (* <= osc$max_string_size),
      vsn: rmt$recorded_vsn;

?? EJECT ??
    PROCEDURE dat_condition_handler (mf: ost$monitor_fault;
                                     p_msa: ^ost$minimum_save_area;
                                 VAR continue: syt$continue_option);
      VAR
        p_scc: ^syt$system_core_condition,
        p_sac: ^mmt$segment_access_condition;

      IF mf.identifier = mmc$segment_fault_processor_id THEN
        p_sac := #LOC(mf.contents);
        CASE p_sac^.identifier OF
        = mmc$sac_io_read_error =
          osp$set_status_abnormal ('MM', mme$io_read_error,
             'io error encountered on DAT - dmp$build_faus_from_dfl_entry', status);
          EXIT dmp$build_faus_from_dfl_entry;
        ELSE
        CASEND;
      ELSEIF mf.identifier = syc$system_core_condition THEN
        p_scc := #LOC(mf.system_core_condition);
        CASE p_scc^.condition OF
        = syc$user_defined_condition =
          IF p_scc^.user_defined_condition = syc$udc_volume_unavailable THEN
            osp$set_status_abnormal ('MM', mme$volume_unavailable,
             'io error encountered on DAT - dmp$build_faus_from_dfl_entry', status);
            EXIT dmp$build_faus_from_dfl_entry;
          IFEND;
        ELSE
        CASEND;
      IFEND;

      syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);

    PROCEND dat_condition_handler;
?? SKIP := 3 ??

    status.normal := TRUE;
    file_flawed := FALSE;

  /process_request/
    BEGIN

      gfp$get_fde_p (system_file_id, p_fde);
      IF p_fde = NIL THEN
        STRINGREP (msg, length, 'SFID ', system_file_id.file_entry_index: #(16),
                     system_file_id.residence: #(16), system_file_id.file_hash: #(16),
                     '(16) contains bad file residence or file index - dmp$build_faus_from_dfl_entry.');
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde, msg (1, length), status);
        RETURN;
      IFEND;

      syp$establish_condition_handler (^dat_condition_handler);

      dmp$open_dat (dat_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_read, mmc$as_sequential, p_dat, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

    /dat_open/
      BEGIN
        bytes_per_allocation := dfl_entry.daus_per_allocation_unit * p_dat^.header.bytes_per_dau;

          p_fmd^.bytes_per_mau := p_dat^.header.bytes_per_mau;
          p_fmd^.daus_per_allocation_unit := dfl_entry.daus_per_allocation_unit;
          p_fmd^.daus_per_cylinder := p_dat^.header.daus_per_position;
          p_fmd^.maus_per_dau := p_dat^.header.maus_per_dau;
          p_fmd^.system_file_id := system_file_id;

        /determine_allocation_style/
          FOR allocation_style := LOWERVALUE (dmt$allocation_styles) TO UPPERVALUE (dmt$allocation_styles) DO
            CASE p_dat^.header.version_number OF
            = dmc$dat_0_0 =
              allocation_style_found := (p_fmd^.daus_per_allocation_unit = p_dat^.header.
                    daus_per_allocation_style [allocation_style]);
            ELSE
              allocation_style_found := FALSE;
              EXIT /determine_allocation_style/;
            CASEND;
            IF allocation_style_found THEN
              EXIT /determine_allocation_style/;
            IFEND;
          FOREND /determine_allocation_style/;

          IF NOT allocation_style_found THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$no_allocation_style_found,
              'File allocation style not found in DAT header - dmp$build_faus_from_dfl_entry.', status);
            EXIT /dat_open/;
          IFEND;
          p_fmd^.allocation_style := allocation_style;

          IF p_dfd^.bytes_per_allocation = 0 THEN
            {Allow any allocation size (including cylinder) to allow upward compatability
            {from r131.  Will only be able to overflow to devices that support the same
            {allocation size.
            p_dfd^.bytes_per_allocation := bytes_per_allocation;
            p_fde^.allocation_unit_size := bytes_per_allocation;
            {Force level 2 tables to be "full"
            p_dfd^.bytes_per_level_2 := bytes_per_allocation * (dmc$bytes_per_level_2 DIV
                16384);
          ELSEIF p_dfd^.bytes_per_allocation <> bytes_per_allocation THEN
            {Cannot support existing file with subfiles of different allocation sizes
            STRINGREP (msg, length, 'Existing file, SFID ', system_file_id.file_entry_index: #(16),
                system_file_id.residence: #(16), system_file_id.file_hash: #(16),
                '(16), contains subfiles of different allocation sizes - dmp$build_faus_from_dfl_entry.');
            osp$set_status_abnormal (dmc$device_manager_ident, dme$allocation_mismatch,
                  msg (1, length), status);
            EXIT /dat_open/;
          IFEND;
          p_fmd^.maus_per_transfer_unit := p_dfd^.bytes_per_allocation DIV p_dat^.header.bytes_per_mau;

        p_fmd^.fmd_allocated_length := 0;
        dau_byte_address := dfl_entry.file_byte_address;

        IF (dfl_entry.dau_chain_status = dmc$dau_chain_linked) THEN
          dau_address := dfl_entry.first_dau_address;
          end_of_allocation_chain := FALSE;

        /build_aus_from_dat/
          REPEAT
            dau_entry := p_dat^.body [dau_address];
            IF ((dau_entry.dau_status <> dmc$dau_ass_to_file_swr_flawed) AND (dau_entry.dau_status <>
                  dmc$dau_assigned_to_file)) OR (dau_entry.file_hash <> dfl_entry.file_hash) THEN
              pmp$convert_binary_unique_name (p_fde^.global_file_name, gfn_string, status);
              vsn := dmv$p_active_volume_table^ [p_fmd^.avt_index].mass_storage.recorded_vsn;
              PUSH p_str: [2 * #SIZE (dau_entry)];
              convert_to_hex (#LOC (dau_entry), p_str^);
              STRINGREP (msg, length, 'DAT chain broken, gfn = ', gfn_string, ', subfile =', fmd_index,
                    ', vsn = ', vsn, ', dfl =', p_fmd^.dfl_index, ', offset =', p_fmd^.fmd_allocated_length,
                    ', dau =', dau_address, ', dau_entry = ', p_str^, ' - dmp$build_faus_from_dfl_entry.');
              osp$set_status_abnormal (dmc$device_manager_ident, dme$allocation_chain_broken,
                    msg (1, length), status);
              EXIT /dat_open/;
            IFEND;

            dmp$get_fau_entry (p_dfd, dau_byte_address, p_fau_entry);
            IF p_fau_entry = NIL THEN
              dmp$create_fau_entry (p_dfd, dau_byte_address, bytes_per_allocation);
              dmp$get_fau_entry (p_dfd, dau_byte_address, p_fau_entry);
            IFEND;

            IF (p_fau_entry = NIL) THEN
              pmp$convert_binary_unique_name (p_fde^.global_file_name, gfn_string, status);
              vsn := dmv$p_active_volume_table^ [p_fmd^.avt_index].mass_storage.recorded_vsn;
              STRINGREP (msg, length, 'Can''t create FAU entry, gfn = ', gfn_string,
                  ', subfile =', fmd_index, ', vsn = ', vsn, ', dfl =', p_fmd^.dfl_index,
                  ', byte =', dau_byte_address, ' - dmp$build_faus_from_dfl_entry.');
              osp$set_status_abnormal (dmc$device_manager_ident, dme$allocation_chain_broken,
                    msg (1, length), status);
              EXIT /dat_open/;
            IFEND;

            IF (p_fau_entry^.state <> dmc$fau_free) THEN
              pmp$convert_binary_unique_name (p_fde^.global_file_name, gfn_string, status);
              vsn := dmv$p_active_volume_table^ [p_fmd^.avt_index].mass_storage.recorded_vsn;
              STRINGREP (msg, length, 'Duplicate DAT offset, gfn = ', gfn_string,
                  ', subfile =', fmd_index, ', vsn = ', vsn, ', dfl =', p_fmd^.dfl_index,
                  ', byte =', dau_byte_address, ' - dmp$build_faus_from_dfl_entry.');
              osp$set_status_abnormal (dmc$device_manager_ident, dme$allocation_chain_broken,
                    msg (1, length), status);
              EXIT /dat_open/;
            IFEND;

              p_fau_entry^.dau_address := dau_address;
              p_fau_entry^.fmd_index := fmd_index;
              IF dau_entry.dau_status = dmc$dau_assigned_to_file THEN
                IF dau_entry.data_status = dmc$dau_data_initialized THEN
                  p_fau_entry^.state := dmc$fau_initialized;
                ELSE
                  p_fau_entry^.state := dmc$fau_invalid_data;
                IFEND;
              ELSE
                IF dau_entry.data_status = dmc$dau_data_initialized THEN
                  p_fau_entry^.state := dmc$fau_initialized_and_flawed;
                ELSE
                  p_fau_entry^.state := dmc$fau_invalid_and_flawed;
                IFEND;
                file_flawed := TRUE;
              IFEND;

            CASE dau_entry.allocation_chain_position OF
            = dmc$first_allocation, dmc$middle_allocation =
              IF (dau_entry.next_allocation_unit_dau < p_dat^.header.number_of_entries) THEN
                dau_address := dau_entry.next_allocation_unit_dau;
              ELSE
                pmp$convert_binary_unique_name (p_fde^.global_file_name, gfn_string, status);
                vsn := dmv$p_active_volume_table^ [p_fmd^.avt_index].mass_storage.recorded_vsn;
                PUSH p_str: [2 * #SIZE (dau_entry)];
                convert_to_hex (#LOC (dau_entry), p_str^);
                STRINGREP (msg, length, 'DAT chain broken, gfn = ', gfn_string, ', subfile =', fmd_index,
                      ', vsn = ', vsn, ', dfl =', p_fmd^.dfl_index, ', offset =', p_fmd^.fmd_allocated_length,
                      ', dau =', dau_address, ', dau_entry = ', p_str^, ' - dmp$build_faus_from_dfl_entry.');
                osp$set_status_abnormal (dmc$device_manager_ident, dme$allocation_chain_broken,
                      msg (1, length), status);
                EXIT /dat_open/;
              IFEND;
            ELSE
              end_of_allocation_chain := TRUE;
            CASEND;

            p_fmd^.fmd_allocated_length := p_fmd^.fmd_allocated_length + bytes_per_allocation;
            dau_byte_address := dau_byte_address + bytes_per_allocation;
          UNTIL end_of_allocation_chain;
        IFEND;

        IF (dau_byte_address >= p_dfd^.highest_offset_allocated) THEN
          p_dfd^.highest_offset_allocated := dau_byte_address;
          p_dfd^.current_fmd_index := fmd_index;
        IFEND;

        IF (p_fmd^.fmd_allocated_length <> dfl_entry.fmd_length) THEN
          p_dfd^.dfd_modified := TRUE;
          IF (p_fmd^.fmd_allocated_length < dfl_entry.fmd_length) AND
                (osv$deadstart_phase <> osc$recovery_deadstart) THEN
            pmp$convert_binary_unique_name (p_fde^.global_file_name, gfn_string, status);
            vsn := dmv$p_active_volume_table^ [p_fmd^.avt_index].mass_storage.recorded_vsn;
            STRINGREP (msg, length, 'DAT chain length (', p_fmd^.fmd_allocated_length,
                  ') less than DFL length (', dfl_entry.fmd_length, '), gfn = ', gfn_string,
                  ', subfile =', fmd_index, ', vsn = ', vsn, ', dfl =', p_fmd^.dfl_index,
                  ' - dmp$build_faus_from_dfl_entry.');
            osp$set_status_abnormal (dmc$device_manager_ident, dme$incorrect_num_alloc_units,
                  msg (1, length), status);
          IFEND;
        IFEND;
      END /dat_open/;

      dmp$close_file (p_dat, close_status);
      IF NOT close_status.normal THEN
        IF status.normal THEN
          status := close_status;
        IFEND;
      IFEND;

      syp$disestablish_cond_handler;

    END /process_request/;

  PROCEND dmp$build_faus_from_dfl_entry;
?? TITLE := '  dmp$build_stored_fmd', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$build_stored_fmd (p_fde: gft$file_desc_entry_p;
    VAR p_stored_fmd: ^dmt$stored_fmd;
    VAR status: ost$status);

    VAR
      avt_index: dmt$active_volume_table_index,
      byte_address: amt$file_byte_address,
      fmd_count: dmt$fmd_index,
      fmd_index: dmt$fmd_index,
      found: boolean,
      p_fmd: ^dmt$file_medium_descriptor,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fmd_header: ^dmt$stored_ms_fmd_header,
      p_fmd_version: ^dmt$stored_ms_version_number,
      p_stored_subfile: ^dmt$stored_ms_fmd_subfile;

    status.normal := TRUE;
    RESET p_stored_fmd;

    NEXT p_fmd_version IN p_stored_fmd;
    IF (p_fmd_version = NIL) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
        'FMD too small - dmp$build_stored_fmd.', status);
      RETURN;
    IFEND;

    p_fmd_version^ := dmc$current_fmd_version;

    NEXT p_fmd_header: [dmc$current_fmd_version] IN p_stored_fmd;
    IF (p_fmd_header = NIL) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
        'FMD too small - dmp$build_stored_fmd.', status);
      RETURN;
    IFEND;

    IF (p_fde^.media = gfc$fm_served_file) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unexpected_server_file,
        'Unexpected Server File - dmp$build_stored_fmd.', status);
      RETURN;
    IFEND;

    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
    IF (p_dfd = NIL) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_not_created_for_file,
        'No DFD for file - dmp$build_stored_fmd.', status);
      RETURN;
    IFEND;

{
{ CLEAR_SPACE and LOCKED_FILE have been removed from the tables, the following
{ references have been left to maintain compatibility.
{
    p_fmd_header^.version_0_0.clear_space := TRUE;
    p_fmd_header^.version_0_0.file_hash := p_fde^.file_hash;
    p_fmd_header^.version_0_0.file_limit := p_fde^.file_limit;
    p_fmd_header^.version_0_0.file_kind := p_fde^.file_kind;
    p_fmd_header^.version_0_0.locked_file.required := FALSE;
    p_fmd_header^.version_0_0.number_fmds := 0;
    p_fmd_header^.version_0_0.overflow_allowed := p_dfd^.overflow_allowed;
    p_fmd_header^.version_0_0.preset_value := dmp$preset_conversion (p_fde^.preset_value);
    p_fmd_header^.version_0_0.requested_allocation_size := p_dfd^.requested_allocation_size;
    p_fmd_header^.version_0_0.requested_class := p_dfd^.requested_class;
    p_fmd_header^.version_0_0.requested_class_ordinal := p_dfd^.requested_class_ordinal;
    p_fmd_header^.version_0_0.requested_transfer_size := p_dfd^.requested_transfer_size;
    p_fmd_header^.version_0_0.requested_volume := p_dfd^.requested_volume;

    {Sparse allocation requires that the fmds be returned in order from
    {1 to max so that the first fmd will be the first fmd on the next attach.

    {Manufacture correct byte address for backward compatibility

    byte_address := 0;
    fmd_count := 0;
    FOR fmd_index := 1 TO p_dfd^.number_of_fmds DO
      dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);
      IF p_fmd^.in_use AND p_fmd^.volume_assigned THEN
        dmp$search_avt_by_vsn (p_fmd^.internal_vsn, avt_index, found);
        IF found THEN
          NEXT p_stored_subfile: [dmc$current_fmd_version] IN p_stored_fmd;
          IF (p_stored_subfile = NIL) THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
              'FMD too small - dmp$build_stored_fmd.', status);
            RETURN;
          IFEND;

          p_stored_subfile^.version_0_0.stored_byte_address := byte_address DIV dmc$byte_address_converter;
          p_stored_subfile^.version_0_0.device_file_list_index := p_fmd^.dfl_index;
          p_stored_subfile^.version_0_0.internal_vsn := p_fmd^.internal_vsn;
          p_stored_subfile^.version_0_0.recorded_vsn := dmv$p_active_volume_table^ [avt_index].
                mass_storage.recorded_vsn;
          fmd_count := fmd_count + 1;
        IFEND;
        byte_address := byte_address + p_fmd^.fmd_allocated_length;
      IFEND;
    FOREND;

    p_fmd_header^.version_0_0.number_fmds := fmd_count;

  PROCEND dmp$build_stored_fmd;
?? TITLE := '  dmp$create_fmds', EJECT ??
  PROCEDURE [XDCL] dmp$create_fmds
    (    file_locator: dmt$file_location;
         p_dfd: ^dmt$disk_file_descriptor;
         number_fmds: dmt$fmd_index;
     VAR status: ost$status);

    VAR
      fmd_index: dmt$fmd_index,
      p_previous_fmd: ^dmt$file_medium_descriptor,
      p_fmd: ^dmt$file_medium_descriptor;

    status.normal := TRUE;
    p_previous_fmd := NIL;

    /allocate_fmd_loop/
      FOR fmd_index := 1 TO number_fmds DO

        ALLOCATE p_fmd IN file_locator^;

        IF p_previous_fmd <> NIL THEN
          p_previous_fmd^.p_next_fmd := p_fmd;
        ELSE
          p_dfd^.p_fmd := p_fmd;
        IFEND;

        p_previous_fmd := p_fmd;
        p_fmd^ := default_fmd;

      FOREND /allocate_fmd_loop/;

      p_dfd^.number_of_fmds := number_fmds;

  PROCEND dmp$create_fmds;
?? TITLE := '  dmp$free_fmds', EJECT ??
  PROCEDURE [XDCL] dmp$free_fmds
    (    p_dfd: ^dmt$disk_file_descriptor;
         fmd_locator: dmt$file_location;
         number_of_fmds: dmt$fmd_index;
     VAR fmds_released: boolean);

    VAR
      fmd_index: dmt$fmd_index,
      p_fmd: ^dmt$file_medium_descriptor,
      p_next_fmd: ^dmt$file_medium_descriptor;

    fmd_index := 0;

    dmp$get_fmd_by_index (p_dfd, 1, p_fmd);
    IF p_fmd <> NIL THEN
      REPEAT
        p_next_fmd := p_fmd^.p_next_fmd;
        FREE p_fmd IN fmd_locator^;
        p_fmd := p_next_fmd;
        fmd_index := fmd_index + 1;
      UNTIL (p_fmd = NIL) OR (fmd_index >= number_of_fmds);
    IFEND;

    IF (p_fmd = NIL) AND (fmd_index = number_of_fmds) THEN
      p_dfd^.number_of_fmds := 0;
    IFEND;

    fmds_released := (p_fmd = NIL);

  PROCEND dmp$free_fmds;
?? TITLE := '  dmp$get_stored_fmd', EJECT ??
*copy dmh$get_stored_fmd

  PROCEDURE [XDCL, #GATE] dmp$get_stored_fmd
    (    system_file_id: gft$system_file_identifier;
     VAR stored_fmd: dmt$stored_fmd;
     VAR status: ost$status);

    VAR
      p_fde: ^gft$file_descriptor_entry,
      p_stored_fmd: ^dmt$stored_fmd;

    status.normal := TRUE;
    gfp$get_locked_fde_p (system_file_id, p_fde);

    IF (p_fde = NIL) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
            'Bad SFID - dmp$get_stored_fmd.', status);
    ELSE
      p_stored_fmd := ^stored_fmd;
      dmp$build_stored_fmd (p_fde, p_stored_fmd, status);
      gfp$unlock_fde_p (p_fde);
    IFEND;
  PROCEND dmp$get_stored_fmd;
?? TITLE := '  dmp$get_stored_fmd_size', EJECT ??
*copy dmh$get_stored_fmd_size

  PROCEDURE [XDCL, #GATE] dmp$get_stored_fmd_size
    (    system_file_id: gft$system_file_identifier;
     VAR size_of_stored_fmd: dmt$stored_fmd_size;
     VAR status: ost$status);

    VAR
      fmd_index: dmt$fmd_index,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      p_fmd: ^dmt$file_medium_descriptor;

    status.normal := TRUE;
    size_of_stored_fmd := #SIZE (dmt$stored_ms_version_number) + #SIZE (dmt$stored_ms_fmd_header);

    gfp$get_locked_fde_p (system_file_id, p_fde);

    IF (p_fde = NIL) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
            'Bad SFID - dmp$get_stored_fmd_size.', status);
    ELSE
      IF (p_fde^.media = gfc$fm_served_file) THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unexpected_server_file,
              'Unexpected Server File - dmp$get_stored_fmd_size.', status);
      ELSE
        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
        IF (p_dfd = NIL) THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_not_created_for_file,
                'No DFD for file - dmp$get_stored_fmd_size.', status);
        ELSE
          FOR fmd_index := 1 TO p_dfd^.number_of_fmds DO
            dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);
            IF p_fmd^.in_use AND p_fmd^.volume_assigned THEN
              size_of_stored_fmd := size_of_stored_fmd + #SIZE (dmt$stored_ms_fmd_subfile);
            IFEND;
          FOREND;
        IFEND;
      IFEND;

      gfp$unlock_fde_p (p_fde);
    IFEND;
  PROCEND dmp$get_stored_fmd_size;
?? TITLE := '  dmp$increase_fmd_count', EJECT ??
  PROCEDURE [XDCL] dmp$increase_fmd_count
    (    system_file_id: gft$system_file_identifier;
         p_dfd: ^dmt$disk_file_descriptor;
     VAR status: ost$status);

    VAR
      fmd_count: dmt$fmd_index,
      fmd_locator: dmt$file_location,
      p_fmd: ^dmt$file_medium_descriptor,
      p_last_fmd: ^dmt$file_medium_descriptor;

    status.normal := TRUE;

  /process_request/
      BEGIN
        dmp$set_file_table_locator (system_file_id.residence, fmd_locator, status);
        IF NOT status.normal THEN
          EXIT /process_request/;
        IFEND;

      fmd_count := p_dfd^.number_of_fmds;
      IF (fmd_count >= UPPERVALUE (fmd_count)) THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_overflow,
          'Maximum fmd count exceeded - dmp$increase_fmd_count.', status);
        EXIT /process_request/;
      IFEND;

      ALLOCATE p_fmd IN fmd_locator^;

      p_fmd^ := default_fmd;

      IF (fmd_count = 0) THEN
        p_dfd^.p_fmd := p_fmd;
      ELSE
        dmp$get_fmd_by_index (p_dfd, fmd_count, p_last_fmd);
        p_last_fmd^.p_next_fmd := p_fmd;
      IFEND;
      p_dfd^.number_of_fmds := fmd_count + 1;

    END /process_request/;

  PROCEND dmp$increase_fmd_count;
?? TITLE := '  dmp$create_fau_entry', EJECT ??
{   The purpose of this routine is to create FAU entries for the range of byte addresses
{ specified.  This routine limits the level one FAT to dmc$level_1_table_size and therefore
{ limits the maximum byte address.  The level one FAT size has been chosen to support the
{ maximum hardware segment size.  If a caller exceeds the maximum size, it may well hang
{ trying to access/create an FAU entry beyond what this routine will create.

  PROCEDURE [XDCL] dmp$create_fau_entry
    (    p_dfd: ^dmt$disk_file_descriptor;
         byte_address: amt$file_byte_address;
         requested_allocation: amt$file_byte_address);

    VAR
      entry_size: integer,
      first: integer,
      index: dmt$level_1_index,
      last: integer,
      level_2: ^dmt$level_2_adapt,
      level_2_upper: dmt$level_2_index,
      locator: dmt$file_location,
      new_level_1: ^dmt$level_1_adapt,
      new_size: integer,
      old_level_1: ^dmt$level_1_table,
      old_size: integer,
      request: dmt$monitor_rb_allocate_space;

    {This procedure assumes that the fde is locked

    IF #segment (p_dfd) = osc$segnum_mainframe_wired THEN
      locator := osv$mainframe_wired_heap;
    ELSE
      locator := osv$job_fixed_heap;
    IFEND;

    { Allocate level one table space.

    first := byte_address DIV p_dfd^.bytes_per_level_2;
    last := (byte_address + requested_allocation - 1) DIV p_dfd^.bytes_per_level_2;

    { The heap manager allocates memory in multiples of 32 bytes and uses 16 bytes for heap
    { linkage.  In order to make maximum use of the memory allocated, the following code
    { determines the largest level one size that will fit in the same memory block required
    { to hold enough level one entries for the highest address being allocated.

    entry_size := #SIZE (amt$file_byte_address);
    new_size := (((last + 1) * entry_size + 16 {linkage} + 31 {round}) DIV 32 * 32 - 16) DIV entry_size;

    IF (new_size > dmc$level_1_table_size) THEN
      new_size := dmc$level_1_table_size;
    IFEND;

    old_size := p_dfd^.fat_upper_bound + 1;
    old_level_1 := p_dfd^.file_allocation_table;

    IF (old_level_1 = NIL) OR (new_size > old_size) THEN
      ALLOCATE new_level_1: [0 .. (new_size - 1)] IN locator^;
      pmp$zero_out_table (new_level_1, #SIZE (new_level_1^));

      { If an old level 1 pointer exists, it is necessary to update to the new
      { pointer in monitor mode to prevent the update from occurring while
      { another CPU is using the old pointer in monitor mode.  If the old level
      { 1 pointer does not exist, it should be safe and faster to update it
      { directly.

      IF (old_level_1 = NIL) THEN
        p_dfd^.file_allocation_table := #LOC (new_level_1^);
        p_dfd^.fat_upper_bound := new_size - 1;
      ELSE
        i#move (old_level_1, new_level_1, old_size * entry_size);

        request.request_code := syc$rc_allocate_front_end;
        request.update_fat_pointer := TRUE;
        request.p_dfd := p_dfd;
        request.p_fat := #LOC (new_level_1^);
        request.fat_upper_bound := new_size - 1;
        i#call_monitor (#LOC (request), #SIZE (request));

        FREE old_level_1 IN locator^;
      IFEND;
    IFEND;

    { Allocate level two tables.

    IF (last > p_dfd^.fat_upper_bound) THEN
      last := p_dfd^.fat_upper_bound;
    IFEND;

    level_2_upper := (p_dfd^.bytes_per_level_2 DIV p_dfd^.bytes_per_allocation) - 1;

    FOR index := first TO last DO
      IF (p_dfd^.file_allocation_table^ [index] = 0) THEN
        ALLOCATE level_2: [0 .. level_2_upper] IN locator^;

        { The value of dmc$fau_free must be zero.

        pmp$zero_out_table (level_2, #SIZE (level_2^));
        p_dfd^.file_allocation_table^ [index] := #OFFSET (level_2);
      IFEND;
    FOREND;
  PROCEND dmp$create_fau_entry;
?? TITLE := '  dmp$r2_increase_fau_count', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$r2_increase_fau_count
    (    system_file_id: gft$system_file_identifier;
         number_faus_needed: dmt$fau_entries;
         byte_address: amt$file_byte_address;
     VAR status: ost$status);

    VAR
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: gft$file_desc_entry_p;

    status.normal := TRUE;

    gfp$get_fde_p (system_file_id, p_fde);
    IF p_fde = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
        'Bad SFID - dmp$r2_increase_fau_count.', status);
      RETURN;
    IFEND;

    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
    dmp$create_fau_entry (p_dfd, byte_address, number_faus_needed * p_dfd^.bytes_per_allocation);

  PROCEND dmp$r2_increase_fau_count;
?? TITLE := '  dmp$deallocate_file_space_r1', EJECT ??
  PROCEDURE [XDCL] dmp$deallocate_file_space_r1
    (    system_file_id: gft$system_file_identifier;
         release_byte_address: amt$file_byte_address;
         bytes_to_release: integer;
         p_fde: gft$file_desc_entry_p;
     VAR status: ost$status);

    VAR
       dmv$mau_release_failure: [XREF] boolean,
       dmv$failing_mau: [XREF] dmt$dau_address,
       dmv$failing_mau_count: [XREF] integer;

    VAR
      able_to_release_faus: boolean,
      bytes_per_allocation: amt$file_byte_address,
      fmd_count: dmt$fmd_index,
      fau_index: dmt$fau_entries,
      ignore_status: ost$status,
      local_file: boolean,
      log_entry: dmt$dl_entry,
      level_1_index: dmt$level_1_index,
      level_1_start: dmt$level_1_index,
      level_2_index: dmt$level_2_index,
      level_2_start: dmt$level_2_index,
      message: string(64),
      message_length: integer,
      monitor_request_block: dmt$monitor_rb_deallocate_space,
      number_of_faus: dmt$fau_entries,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fau_entry: ^dmt$file_allocation_unit,
      p_fmd: ^dmt$file_medium_descriptor,
      p_level_2: ^dmt$level_2_table,
      p_previous_fau_entry: ^dmt$file_allocation_unit,
      space_released: boolean,
      temp_bytes_to_release: integer,
      temp_release_address: amt$file_byte_address;

    status.normal := TRUE;

    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

    bytes_per_allocation := p_dfd^.bytes_per_allocation;
    {Round up to next AU
    temp_release_address := ((release_byte_address + bytes_per_allocation - 1)
        DIV bytes_per_allocation) * bytes_per_allocation;
    {Round down to next AU
    temp_bytes_to_release := bytes_to_release - (temp_release_address - release_byte_address);
    temp_bytes_to_release := temp_bytes_to_release DIV bytes_per_allocation * bytes_per_allocation;
    IF temp_bytes_to_release < 0 THEN
      RETURN;
    IFEND;

    local_file := system_file_id.residence = gfc$tr_job;

    IF local_file THEN
      monitor_request_block.request_code := syc$rc_deallocate_front_end;
      monitor_request_block.system_file_id := system_file_id;
      monitor_request_block.status.normal := TRUE;
      monitor_request_block.monitor_request := dmc$deallocate_space;
      monitor_request_block.release_byte_address := temp_release_address;
      monitor_request_block.bytes_to_release := temp_bytes_to_release;
      monitor_request_block.able_to_release_all_space := TRUE;
      i#call_monitor (#LOC (monitor_request_block), #SIZE (monitor_request_block));

      IF dmv$mau_release_failure THEN
      message (1, *) := ' ';

      message_length := 0;
      message := 'RELEASE ALLOCATION UNIT ERROR ON MAU ';

      REPEAT
       message_length := message_length + 1;
      UNTIL message (message_length, 1) = ' ';

      STRINGREP (message, message_length, dmv$failing_mau);
      dpp$put_critical_message (message, ignore_status);
      IFEND;

    ELSE {Not a local file - issue trim function

      {Must issue a trim file for each fmd
      {Can have partial or complete allocation in each fmd
      {Note that trim releases space to end of fmd (not sparse deallocate)

      space_released := FALSE;
      FOR fmd_count := 1 TO p_dfd^.number_of_fmds DO
        {p_fau_entry is the first fau to free
        dmp$get_fau_entry_and_fmd (p_dfd, temp_release_address, p_fau_entry, p_fmd);
        IF (p_fau_entry = NIL) OR (p_fmd = NIL) OR (p_fau_entry^.fmd_index <> fmd_count) THEN
          {If temp_release_address does not point to an AU belonging to this fmd
          {  get the next higher (byte address) AU for this fmd
          dmp$get_next_fmd_fau (p_dfd, temp_release_address, fmd_count, p_fau_entry);
        IFEND;
        IF (p_fau_entry <> NIL) AND (p_fau_entry^.state <> dmc$fau_free) THEN
          {p_previous_fau is the new last fau for the fmd
          dmp$get_previous_fau_entry (p_dfd, temp_release_address, fmd_count, p_previous_fau_entry);
          IF (p_previous_fau_entry <> NIL) AND (p_previous_fau_entry^.state <> dmc$fau_free) THEN
            {Fmd partial trim - see else below
            dmp$get_fmd_by_index (p_dfd, fmd_count, p_fmd);
            monitor_request_block.request_code := syc$rc_deallocate_front_end;
            monitor_request_block.system_file_id := system_file_id;
            monitor_request_block.status.normal := TRUE;
            monitor_request_block.monitor_request := dmc$trim_file_space;
            monitor_request_block.avt_index := p_fmd^.avt_index;
            monitor_request_block.global_file_name := p_fde^.global_file_name;
            monitor_request_block.dfl_index := p_fmd^.dfl_index;
            monitor_request_block.dau_address := p_previous_fau_entry^.dau_address;
            monitor_request_block.dau_of_fragment := p_fau_entry^.dau_address;
            REPEAT
              i#call_monitor (#LOC (monitor_request_block), #SIZE (monitor_request_block));
              IF NOT monitor_request_block.status.normal THEN  { allocation log was full, cycle and try again
                pmp$cycle (ignore_status);
              IFEND;
            UNTIL status.normal;

                   IF dmv$mau_release_failure THEN

                    message (1, *) := ' ';
                    message_length := 0;
                    message := 'RELEASE ALLOCATION UNIT ERROR ON MAU ';

                      REPEAT
                         message_length := message_length + 1;
                      UNTIL message (message_length, 1) = ' ';

                    STRINGREP (message, message_length, dmv$failing_mau);
                    dpp$put_critical_message (message, ignore_status);

                 IFEND;

          ELSE
            {Want to trim entire fmd (fmd allocated length will be zero)
            {Rely on caller to purge fmd
            {This code currently only invoked by trim
          IFEND;
          space_released := TRUE;
        ELSE
          {Nothing to trim at temp_release_address or above for this fmd
        IFEND;
      FOREND;

      {Update file allocation table to reflect trim

      IF space_released THEN
        p_dfd^.dfd_modified := TRUE;
        level_1_start := temp_release_address DIV p_dfd^.bytes_per_level_2;
        level_2_start := temp_release_address MOD p_dfd^.bytes_per_level_2 DIV bytes_per_allocation;
        IF p_dfd^.file_allocation_table <> NIL THEN
          FOR level_1_index := level_1_start TO p_dfd^.fat_upper_bound DO
            dmp$get_level_2_ptr (^p_dfd^.file_allocation_table^ [level_1_index],
              p_level_2);
            IF p_level_2 <> NIL THEN
              FOR level_2_index := level_2_start TO
                  (p_dfd^.bytes_per_level_2 DIV bytes_per_allocation - 1) DO
                IF p_level_2^ [level_2_index].state <> dmc$fau_free THEN
                  dmp$get_fmd_by_index (p_dfd, p_level_2^ [level_2_index].fmd_index, p_fmd);
                  p_level_2^ [level_2_index].state := dmc$fau_free;
                  p_fmd^.fmd_allocated_length := p_fmd^.fmd_allocated_length -
                      p_dfd^.bytes_per_allocation;
                IFEND;
              FOREND;
            IFEND;
            level_2_start := 0;
          FOREND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND dmp$deallocate_file_space_r1;
?? TITLE := '  dmp$reserve_fmd', EJECT ??
  PROCEDURE [XDCL] dmp$reserve_fmd
    (    p_dfd: ^dmt$disk_file_descriptor;
     VAR fmd_index: dmt$fmd_index;
     VAR able_to_reserve_fmd: boolean);

    VAR
      number_of_fmds: dmt$fmd_index,
      p_fmd: ^dmt$file_medium_descriptor;

    able_to_reserve_fmd := FALSE;

    number_of_fmds := 0;
    IF p_dfd <> NIL THEN
      number_of_fmds := p_dfd^.number_of_fmds;
    IFEND;

    IF number_of_fmds > 0 THEN

      FOR fmd_index := 1 TO number_of_fmds DO
        dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);
        IF p_fmd <> NIL THEN
          IF NOT p_fmd^.in_use THEN
            p_fmd^.in_use := TRUE;
            able_to_reserve_fmd := TRUE;
            RETURN;
          IFEND;
        IFEND;
      FOREND;

    IFEND;

  PROCEND dmp$reserve_fmd;
?? TITLE := '  dmp$store_existing_df_fat', EJECT ??
  PROCEDURE [XDCL] dmp$store_existing_df_fat
    (    system_file_id: gft$system_file_identifier;
         p_existing_fat: ^dmt$stored_ms_device_file_fat;
     VAR status: ost$status);

    VAR
      bytes_per_allocation: amt$file_byte_address,
      byte_address: amt$file_byte_address,
      existing_fau_index: dmt$fau_entries,
      fau_index: dmt$fau_entries,
      number_fau_entries: dmt$fau_entries,
      p_fmd: ^dmt$file_medium_descriptor,
      p_fau_entry: ^dmt$file_allocation_unit,
      p_fde: gft$file_desc_entry_p,
      p_dfd: ^dmt$disk_file_descriptor;

    status.normal := TRUE;

  /process_request/
    BEGIN
      gfp$get_fde_p (system_file_id, p_fde);
      IF p_fde = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
          'Bad SFID file residence or file index.', status);
        EXIT /process_request/;
      IFEND;

      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

      {Only 1 fmd for device files
      dmp$get_fmd_by_index (p_dfd, 1, p_fmd);

      number_fau_entries := p_existing_fat^.header.number_faus;

      p_fmd^.allocation_style := p_existing_fat^.header.allocation_style;
      p_fmd^.bytes_per_mau := p_existing_fat^.header.bytes_per_mau;
      p_fmd^.daus_per_allocation_unit := p_existing_fat^.header.daus_per_allocation_unit;
      p_fmd^.daus_per_cylinder := p_existing_fat^.header.daus_per_cylinder;
      p_fmd^.maus_per_dau := p_existing_fat^.header.maus_per_dau;
      p_fmd^.maus_per_transfer_unit := p_existing_fat^.header.maus_per_transfer_unit;
      p_fmd^.system_file_id := system_file_id;

      bytes_per_allocation := p_fmd^.daus_per_allocation_unit * p_fmd^.maus_per_dau *
        p_fmd^.bytes_per_mau;
      p_dfd^.bytes_per_allocation := bytes_per_allocation;
      p_fde^.allocation_unit_size := bytes_per_allocation;
      p_dfd^.current_fmd_index := 1;
      IF (dmc$bytes_per_level_2 MOD p_dfd^.bytes_per_allocation) <> 0 THEN
        {Round up to next allocation unit
        p_dfd^.bytes_per_level_2 := (dmc$bytes_per_level_2 + p_dfd^.bytes_per_allocation - 1)
            DIV p_dfd^.bytes_per_allocation * p_dfd^.bytes_per_allocation;
      ELSE
        p_dfd^.bytes_per_level_2 := dmc$bytes_per_level_2;
      IFEND;

      dmp$create_fau_entry (p_dfd, 0, bytes_per_allocation * number_fau_entries);

      existing_fau_index := LOWERBOUND (p_existing_fat^.file_allocation_units);

      {Assume sequential allocation
      byte_address := 0;
      FOR fau_index := 1 TO number_fau_entries DO
        dmp$get_fau_entry (p_dfd, byte_address, p_fau_entry);
        p_fau_entry^.dau_address := p_existing_fat^.file_allocation_units [existing_fau_index].dau_address;
        p_fau_entry^.state := p_existing_fat^.file_allocation_units [existing_fau_index].state;
        p_fau_entry^.fmd_index := 1;
        existing_fau_index := existing_fau_index + 1;
        byte_address := byte_address + bytes_per_allocation;
      FOREND;
      p_dfd^.highest_offset_allocated := byte_address;
      p_fmd^.fmd_allocated_length := byte_address;
      p_fmd^.volume_assigned := TRUE;

    END /process_request/;

  PROCEND dmp$store_existing_df_fat;
?? TITLE := '  dmp$store_valid_class_in_fmd', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$store_valid_class_in_fmd
    (    system_file_id: gft$system_file_identifier;
         class: dmt$class_member;
     VAR status: ost$status);

    VAR
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry;

    status.normal := TRUE;
    gfp$get_locked_fde_p (system_file_id, p_fde);
    IF p_fde = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
            'Bad SFID - dmp$store_valid_class_in_fmd.', status);
      RETURN;
    IFEND;

    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
    IF p_dfd = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_not_created_for_file,
            'No DFD for file - dmp$store_valid_class_in_fmd.', status);
      gfp$unlock_fde_p (p_fde);
      RETURN;
    IFEND;

    p_dfd^.requested_class := class;

    gfp$unlock_fde_p (p_fde);
  PROCEND dmp$store_valid_class_in_fmd;

?? TITLE := '  convert_to_hex', EJECT ??

  PROCEDURE convert_to_hex
    (    p_cell: ^cell;
     VAR str: string (* <= osc$max_string_size));

    VAR
      digit: 0 .. 15,
      index: 1 .. osc$max_string_size,
      p_digits: ^packed array [1 .. osc$max_string_size] of 0 .. 15;

    p_digits := p_cell;

    FOR index := 1 TO STRLENGTH (str) DO
      digit := p_digits^ [index];
      IF (digit < 10) THEN
        str (index, 1) := $char ($integer ('0') + digit);
      ELSE
        str (index, 1) := $char ($integer ('A') - 10 + digit);
      IFEND;
    FOREND;
  PROCEND convert_to_hex;
MODEND dmm$fmd_manager;
*DECK DECK=DMM$GET_DEVICE_ATTRIBUTES EXPAND=TRUE

?? RIGHT := 110 ??
*copy OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$get_device_attributes;

{ PURPOSE:
{  The purpose of this module is to maintain all physical and logical attributes
{  relating to mass storage devices.  This module executes in Ring 1.
{ DESIGN:
{  Device attributes are determined by the product and model number fields of the
{  product identification.  New device types may be added with new conditionals.

?? PUSH (LISTEXT := ON) ??
?? TITLE := '  Common Decks', EJECT ??
*copyc cmt$product_identification
*copyc dmc$default_transfer_sizes
*copyc dmt$error_condition_codes
*copyc dmt$logical_device_attributes
*copyc dmt$ms_flaw_list
*copyc dmt$ms_flaw_list
*copyc dmt$ms_physical_characteristics
*copyc dmt$ms_volume_directory
*copyc dmt$physical_device_attributes
*copyc dsp$retrieve_mf_element_entry
*copyc osp$set_status_abnormal
*copyc ost$status
?? POP ??
?? TITLE := '  dmp$get_physical_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$get_physical_attributes (product_identification: cmt$product_identification;
    VAR p_physical_attributes: ^dmt$physical_device_attributes;
    VAR status: ost$status);

    VAR
      element_entry: dst$mf_element_table_entry,
      error_msg: string(60),
      index: integer,
      length: integer;

    status.normal := TRUE;
    error_msg (1,*) := ' ';
    IF p_physical_attributes = NIL THEN
      RETURN;
    IFEND;
{
{  844
{
    IF product_identification.product_number = '  $844' THEN
      IF product_identification.model_number (1, 1) = '4' THEN

        FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
          CASE p_physical_attributes^ [index].keyword OF

          = dmc$bytes_per_mau =
            p_physical_attributes^ [index].bytes_per_mau := 2048;

          = dmc$cylinders_per_device =
            p_physical_attributes^ [index].cylinders_per_device := 823;

          = dmc$flaw_map_locations =
            p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := TRUE;
            p_physical_attributes^ [index].flaw_locations [1].mau_address := (88 * 822) + (24 DIV 5) * 0;
            { (88 * 822) + (24 DIV 5) * 0 = (maus_per_cylinder * cylinder address)
            { + (sectors_per_track DIV sectors_per_mau) * track
            p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := (60 * 8) * 2;
            { (60 * 8) * 2 = (CM words * bytes_per_CM_word) * sector

          = dmc$maus_per_cylinder =
            p_physical_attributes^ [index].maus_per_cylinder := 88;

          = dmc$maus_per_dau =
            p_physical_attributes^ [index].maus_per_dau := 2;

          = dmc$sectors_per_mau =
            p_physical_attributes^ [index].sectors_per_mau := 5;

          = dmc$sectors_per_track =
            p_physical_attributes^ [index].sectors_per_track := 24;
          CASEND;
        FOREND;
      ELSE
        STRINGREP (error_msg, length, product_identification.product_number,
          product_identification.underscore, product_identification.model_number,
          '-unsupported model number (physical)');
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unsupported_model_number,
          error_msg, status);
      IFEND;
{
{  885
{
    ELSEIF product_identification.product_number = '  $885' THEN
      IF product_identification.model_number (1, 1) = '1' THEN

        FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
          CASE p_physical_attributes^ [index].keyword OF

          = dmc$bytes_per_mau =
            p_physical_attributes^ [index].bytes_per_mau := 2048;

          = dmc$cylinders_per_device =
            p_physical_attributes^ [index].cylinders_per_device := 843;

          = dmc$flaw_map_locations =
            p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := TRUE;
            p_physical_attributes^ [index].flaw_locations [1].mau_address := (320 * 841) + (32 DIV 4) * 1;
            { (320 * 841) + (32 DIV 4) * 1 = (maus_per_cylinder * cylinder address)
            { + (sectors_per_track DIV sectors_per_mau) * track
            p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := (60 * 8) * 1;
            { (60 * 8) * 0 = (CM words * bytes_per_(CM_word) * sector

          = dmc$maus_per_cylinder =
            p_physical_attributes^ [index].maus_per_cylinder := 320;

          = dmc$maus_per_dau =
            p_physical_attributes^ [index].maus_per_dau := 2;

          = dmc$sectors_per_mau =
            p_physical_attributes^ [index].sectors_per_mau := 4;

          = dmc$sectors_per_track =
            p_physical_attributes^ [index].sectors_per_track := 32;
          CASEND;
        FOREND;

      ELSEIF product_identification.model_number (1, 1) = '4' THEN
        FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
          CASE p_physical_attributes^ [index].keyword OF

          = dmc$bytes_per_mau =
            p_physical_attributes^ [index].bytes_per_mau := 2048;

          = dmc$cylinders_per_device =
            p_physical_attributes^ [index].cylinders_per_device := 843;

          = dmc$flaw_map_locations =
            p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := TRUE;
            p_physical_attributes^ [index].flaw_locations [1].mau_address := (320 * 841) + (32 DIV 1) * 1;
            { (320 * 841) + (32 DIV 1) * 1 = (maus_per_cylinder * cylinder address)
            { + (sectors_per_track DIV sectors_per_mau) * track
            p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := (60 * 8) * 1;
            { (60 * 8) * 0 = (CM words * bytes_per_(CM_word) * sector

          = dmc$maus_per_cylinder =
            p_physical_attributes^ [index].maus_per_cylinder := 320;

          = dmc$maus_per_dau =
            p_physical_attributes^ [index].maus_per_dau := 2;

          = dmc$sectors_per_mau =
            p_physical_attributes^ [index].sectors_per_mau := 1;

          = dmc$sectors_per_track =
            p_physical_attributes^ [index].sectors_per_track := 32;
          CASEND;
        FOREND;
      ELSE
        STRINGREP (error_msg, length, product_identification.product_number,
          product_identification.underscore, product_identification.model_number,
          '-unsupported model number (physical2)');
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unsupported_model_number,
          error_msg, status);
      IFEND;
{
{  ISD-I
{
    ELSEIF product_identification.product_number = '  $834' THEN

        FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
          CASE p_physical_attributes^ [index].keyword OF

          = dmc$bytes_per_mau =
            p_physical_attributes^ [index].bytes_per_mau := 2048;

          = dmc$cylinders_per_device =
            p_physical_attributes^ [index].cylinders_per_device := 817;

          = dmc$flaw_map_locations =
            p_physical_attributes^ [index].flaw_locations [1].
                  device_flaws_specified := FALSE;
            p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
            p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

          = dmc$maus_per_cylinder =
            p_physical_attributes^ [index].maus_per_cylinder := 80;

          = dmc$maus_per_dau =
            p_physical_attributes^ [index].maus_per_dau := 8;

          = dmc$sectors_per_mau =
            p_physical_attributes^ [index].sectors_per_mau := 4;

          = dmc$sectors_per_track =
            p_physical_attributes^ [index].sectors_per_track := 32;
          CASEND;
        FOREND;
{
{  ISD-II
{
    ELSEIF product_identification.product_number = '  $836' THEN

        FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
          CASE p_physical_attributes^ [index].keyword OF

          = dmc$bytes_per_mau =
            p_physical_attributes^ [index].bytes_per_mau := 2048;

          = dmc$cylinders_per_device =
            p_physical_attributes^ [index].cylinders_per_device := 701;

          = dmc$flaw_map_locations =
            p_physical_attributes^ [index].flaw_locations [1].
                  device_flaws_specified := FALSE;
            p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
            p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

          = dmc$maus_per_cylinder =
            p_physical_attributes^ [index].maus_per_cylinder := 280;

          = dmc$maus_per_dau =
            p_physical_attributes^ [index].maus_per_dau := 8;

          = dmc$sectors_per_mau =
            p_physical_attributes^ [index].sectors_per_mau := 4;

          = dmc$sectors_per_track =
            p_physical_attributes^ [index].sectors_per_track := 47;
          CASEND;
        FOREND;
{
{  CM3/ISD-II
{
    ELSEIF product_identification.product_number = ' $9836' THEN

        dsp$retrieve_mf_element_entry (0, dsc$dftb_eid_cpu0_element, element_entry, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
          CASE p_physical_attributes^ [index].keyword OF

          = dmc$bytes_per_mau =
            p_physical_attributes^ [index].bytes_per_mau := 2048;

          = dmc$cylinders_per_device =
{
{           Check for special model of 930 which limits usable disk space
{
            IF (element_entry.model_number = osc$cyber_180_model_930a) OR
               (element_entry.model_number = osc$cyber_180_model_932a) THEN
              p_physical_attributes^ [index].cylinders_per_device := 509;
            ELSE
              p_physical_attributes^ [index].cylinders_per_device := 703;
            IFEND;

          = dmc$flaw_map_locations =
            p_physical_attributes^ [index].flaw_locations [1].
                  device_flaws_specified := FALSE;
            p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
            p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

          = dmc$maus_per_cylinder =
            p_physical_attributes^ [index].maus_per_cylinder := 288;

          = dmc$maus_per_dau =
            p_physical_attributes^ [index].maus_per_dau := 8;

          = dmc$sectors_per_mau =
            p_physical_attributes^ [index].sectors_per_mau := 1;

          = dmc$sectors_per_track =
            p_physical_attributes^ [index].sectors_per_track := 12;
          CASEND;
        FOREND;
{
{  $FA7B5_A / 9853_x
{
    ELSEIF product_identification.product_number = ' $9853' THEN

        FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
          CASE p_physical_attributes^ [index].keyword OF

          = dmc$bytes_per_mau =
            p_physical_attributes^ [index].bytes_per_mau := 2048;

          = dmc$cylinders_per_device =
              p_physical_attributes^ [index].cylinders_per_device := 1412;

          = dmc$flaw_map_locations =
            p_physical_attributes^ [index].flaw_locations [1].
                  device_flaws_specified := FALSE;
            p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
            p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

          = dmc$maus_per_cylinder =
            p_physical_attributes^ [index].maus_per_cylinder := 392;

          = dmc$maus_per_dau =
            p_physical_attributes^ [index].maus_per_dau := 8;

          = dmc$sectors_per_mau =
            p_physical_attributes^ [index].sectors_per_mau := 1;

          = dmc$sectors_per_track =
            p_physical_attributes^ [index].sectors_per_track := 21;
          CASEND;
        FOREND;
{
{  895  (33800)
{
    ELSEIF product_identification.product_number = '  $895' THEN

      FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF

        = dmc$bytes_per_mau =
          p_physical_attributes^ [index].bytes_per_mau := 4096;

        = dmc$cylinders_per_device =
          p_physical_attributes^ [index].cylinders_per_device := 886;

        = dmc$flaw_map_locations =
          p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := FALSE;

          {NOTE:-- A FLAW MAP EXISTS ON THE 895, BUT VE IS NOT USING IT.

          p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
          { (148 * 885) + (18 DIV 1) * 0 = (maus_per_cylinder * cylinder address)
          { + (sectors_per_track DIV sectors_per_mau) * track

          p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;
          { (60 * 8) * 0 = (CM words * bytes_per_(CM_word) * sector

        = dmc$maus_per_cylinder =
          p_physical_attributes^ [index].maus_per_cylinder := 148;

        = dmc$maus_per_dau =
          p_physical_attributes^ [index].maus_per_dau := 4;

        = dmc$sectors_per_mau =
          p_physical_attributes^ [index].sectors_per_mau := 1;

        = dmc$sectors_per_track =
          p_physical_attributes^ [index].sectors_per_track := 10;
        CASEND;
      FOREND;
{
{  HYDRA
{
    ELSEIF product_identification.product_number = '  $887' THEN

      FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF

        = dmc$bytes_per_mau =
          p_physical_attributes^ [index].bytes_per_mau := 4096;

        = dmc$cylinders_per_device =
          p_physical_attributes^ [index].cylinders_per_device := 884;

        = dmc$flaw_map_locations =
          p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := FALSE;
          p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
          p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

        = dmc$maus_per_cylinder =
          p_physical_attributes^ [index].maus_per_cylinder := 152;

        = dmc$maus_per_dau =
          p_physical_attributes^ [index].maus_per_dau := 4;

        = dmc$sectors_per_mau =
          p_physical_attributes^ [index].sectors_per_mau := 1;

        = dmc$sectors_per_track =
          p_physical_attributes^ [index].sectors_per_track := 38;
        CASEND;
      FOREND;
{
{   SSD Serial
{
    ELSEIF (product_identification.product_number = ' $5832') AND
           (product_identification.model_number (1, 1) = '1') THEN

      FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF

        = dmc$bytes_per_mau =
          p_physical_attributes^ [index].bytes_per_mau := 4096;

        = dmc$cylinders_per_device =
          p_physical_attributes^ [index].cylinders_per_device := 844;

        = dmc$flaw_map_locations =
          p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := FALSE;
          p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
          p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

        = dmc$maus_per_cylinder =
          p_physical_attributes^ [index].maus_per_cylinder := 48;

        = dmc$maus_per_dau =
          p_physical_attributes^ [index].maus_per_dau := 4;

        = dmc$sectors_per_mau =
          p_physical_attributes^ [index].sectors_per_mau := 1;

        = dmc$sectors_per_track =
          p_physical_attributes^ [index].sectors_per_track := 12;
        CASEND;
      FOREND;
{
{  SSD Parallel
{
    ELSEIF (product_identification.product_number = ' $5832') AND
           (product_identification.model_number (1, 1) = '2') THEN

      FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF

        = dmc$bytes_per_mau =
          p_physical_attributes^ [index].bytes_per_mau := 4096;

        = dmc$cylinders_per_device =
          p_physical_attributes^ [index].cylinders_per_device := 835;

        = dmc$flaw_map_locations =
          p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := FALSE;
          p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
          p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

        = dmc$maus_per_cylinder =
          p_physical_attributes^ [index].maus_per_cylinder := 96;

        = dmc$maus_per_dau =
          p_physical_attributes^ [index].maus_per_dau := 4;

        = dmc$sectors_per_mau =
          p_physical_attributes^ [index].sectors_per_mau := 1;

        = dmc$sectors_per_track =
          p_physical_attributes^ [index].sectors_per_track := 24;
        CASEND;
      FOREND;
{
{  1X SABRE 2HP / 1XP SABRE 2HP
{
    ELSEIF (product_identification.product_number = ' $5833') AND
           ((product_identification.model_number (1, 1) = '1') OR
            (product_identification.model_number (1, 2) = '1P')) THEN

      FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF

        = dmc$bytes_per_mau =
          p_physical_attributes^ [index].bytes_per_mau := 4096;

        = dmc$cylinders_per_device =
          p_physical_attributes^ [index].cylinders_per_device := 1629;

        = dmc$flaw_map_locations =
          p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := FALSE;
          p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
          p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

        = dmc$maus_per_cylinder =
          p_physical_attributes^ [index].maus_per_cylinder := 152;

        = dmc$maus_per_dau =
          p_physical_attributes^ [index].maus_per_dau := 4;

        = dmc$sectors_per_mau =
          p_physical_attributes^ [index].sectors_per_mau := 1;

        = dmc$sectors_per_track =
          p_physical_attributes^ [index].sectors_per_track := 22;
        CASEND;
      FOREND;
{
{  2X SABRE 2HP
{
    ELSEIF (product_identification.product_number = ' $5833') AND
           (product_identification.model_number (1, 1) = '2') THEN

      FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF

        = dmc$bytes_per_mau =
          p_physical_attributes^ [index].bytes_per_mau := 4096;

        = dmc$cylinders_per_device =
          p_physical_attributes^ [index].cylinders_per_device := 1629;

        = dmc$flaw_map_locations =
          p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := FALSE;
          p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
          p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

        = dmc$maus_per_cylinder =
          p_physical_attributes^ [index].maus_per_cylinder := 292;

        = dmc$maus_per_dau =
          p_physical_attributes^ [index].maus_per_dau := 4;

        = dmc$sectors_per_mau =
          p_physical_attributes^ [index].sectors_per_mau := 1;

        = dmc$sectors_per_track =
          p_physical_attributes^ [index].sectors_per_track := 42;
        CASEND;
      FOREND;
{
{  3X SABRE 2HP
{
    ELSEIF (product_identification.product_number = ' $5833') AND
           (product_identification.model_number (1, 1) = '3') THEN

      FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF

        = dmc$bytes_per_mau =
          p_physical_attributes^ [index].bytes_per_mau := 8192;

        = dmc$cylinders_per_device =
          p_physical_attributes^ [index].cylinders_per_device := 1629;

        = dmc$flaw_map_locations =
          p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := FALSE;
          p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
          p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

        = dmc$maus_per_cylinder =
          p_physical_attributes^ [index].maus_per_cylinder := 228;

        = dmc$maus_per_dau =
          p_physical_attributes^ [index].maus_per_dau := 2;

        = dmc$sectors_per_mau =
          p_physical_attributes^ [index].sectors_per_mau := 1;

        = dmc$sectors_per_track =
          p_physical_attributes^ [index].sectors_per_track := 33;
        CASEND;
      FOREND;
{
{  4X SABRE 2HP
{
    ELSEIF (product_identification.product_number = ' $5833') AND
           (product_identification.model_number (1, 1) = '4') THEN

      FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF

        = dmc$bytes_per_mau =
          p_physical_attributes^ [index].bytes_per_mau := 8192;

        = dmc$cylinders_per_device =
          p_physical_attributes^ [index].cylinders_per_device := 1629;

        = dmc$flaw_map_locations =
          p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := FALSE;
          p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
          p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

        = dmc$maus_per_cylinder =
          p_physical_attributes^ [index].maus_per_cylinder := 292;

        = dmc$maus_per_dau =
          p_physical_attributes^ [index].maus_per_dau := 2;

        = dmc$sectors_per_mau =
          p_physical_attributes^ [index].sectors_per_mau := 1;

        = dmc$sectors_per_track =
          p_physical_attributes^ [index].sectors_per_track := 42;
        CASEND;
      FOREND;
{
{  1X ELITE 2 / 1XP ELITE 2
{
    ELSEIF (product_identification.product_number = ' $5838') AND
           ((product_identification.model_number (1, 1) = '1') OR
            (product_identification.model_number (1, 2) = '1P')) THEN

      FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF

        = dmc$bytes_per_mau =
          p_physical_attributes^ [index].bytes_per_mau := 4096;

        = dmc$cylinders_per_device =
          p_physical_attributes^ [index].cylinders_per_device := 2620;

        = dmc$flaw_map_locations =
          p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := FALSE;
          p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
          p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

        = dmc$maus_per_cylinder =
          p_physical_attributes^ [index].maus_per_cylinder := 156;

        = dmc$maus_per_dau =
          p_physical_attributes^ [index].maus_per_dau := 4;

        = dmc$sectors_per_mau =
          p_physical_attributes^ [index].sectors_per_mau := 1;

        = dmc$sectors_per_track =
          p_physical_attributes^ [index].sectors_per_track := 18;
        CASEND;
      FOREND;
{
{  2X ELITE 2
{
    ELSEIF (product_identification.product_number = ' $5838') AND
           (product_identification.model_number (1, 1) = '2') THEN

      FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF

        = dmc$bytes_per_mau =
          p_physical_attributes^ [index].bytes_per_mau := 4096;

        = dmc$cylinders_per_device =
          p_physical_attributes^ [index].cylinders_per_device := 2620;

        = dmc$flaw_map_locations =
          p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := FALSE;
          p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
          p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

        = dmc$maus_per_cylinder =
          p_physical_attributes^ [index].maus_per_cylinder := 308;

        = dmc$maus_per_dau =
          p_physical_attributes^ [index].maus_per_dau := 4;

        = dmc$sectors_per_mau =
          p_physical_attributes^ [index].sectors_per_mau := 1;

        = dmc$sectors_per_track =
          p_physical_attributes^ [index].sectors_per_track := 35;
        CASEND;
      FOREND;
{
{  3X ELITE 2
{
    ELSEIF (product_identification.product_number = ' $5838') AND
           (product_identification.model_number (1, 1) = '3') THEN

      FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF

        = dmc$bytes_per_mau =
          p_physical_attributes^ [index].bytes_per_mau := 8192;

        = dmc$cylinders_per_device =
          p_physical_attributes^ [index].cylinders_per_device := 2620;

        = dmc$flaw_map_locations =
          p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := FALSE;
          p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
          p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

        = dmc$maus_per_cylinder =
          p_physical_attributes^ [index].maus_per_cylinder := 238;

        = dmc$maus_per_dau =
          p_physical_attributes^ [index].maus_per_dau := 2;

        = dmc$sectors_per_mau =
          p_physical_attributes^ [index].sectors_per_mau := 1;

        = dmc$sectors_per_track =
          p_physical_attributes^ [index].sectors_per_track := 27;
        CASEND;
      FOREND;
{
{  4X ELITE 2
{
    ELSEIF (product_identification.product_number = ' $5838') AND
           (product_identification.model_number (1, 1) = '4') THEN

      FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF

        = dmc$bytes_per_mau =
          p_physical_attributes^ [index].bytes_per_mau := 8192;

        = dmc$cylinders_per_device =
          p_physical_attributes^ [index].cylinders_per_device := 2620;

        = dmc$flaw_map_locations =
          p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := FALSE;
          p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
          p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

        = dmc$maus_per_cylinder =
          p_physical_attributes^ [index].maus_per_cylinder := 310;

        = dmc$maus_per_dau =
          p_physical_attributes^ [index].maus_per_dau := 2;

        = dmc$sectors_per_mau =
          p_physical_attributes^ [index].sectors_per_mau := 1;

        = dmc$sectors_per_track =
          p_physical_attributes^ [index].sectors_per_track := 35;
        CASEND;
      FOREND;
{
{  1X IBM 3.5 / 1XP IBM 3.5
{
    ELSEIF (product_identification.product_number = '$47444') AND
           ((product_identification.model_number (1, 1) = '1') OR
            (product_identification.model_number (1, 2) = '1P')) THEN

      FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF

        = dmc$bytes_per_mau =
          p_physical_attributes^ [index].bytes_per_mau := 4096;

        = dmc$cylinders_per_device =
          p_physical_attributes^ [index].cylinders_per_device := 2290;

        = dmc$flaw_map_locations =
          p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := FALSE;
          p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
          p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

        = dmc$maus_per_cylinder =
          p_physical_attributes^ [index].maus_per_cylinder := 188;

        = dmc$maus_per_dau =
          p_physical_attributes^ [index].maus_per_dau := 4;

        = dmc$sectors_per_mau =
          p_physical_attributes^ [index].sectors_per_mau := 1;

        = dmc$sectors_per_track =
          p_physical_attributes^ [index].sectors_per_track := 13;
        CASEND;
      FOREND;
{
{  2X IBM 3.5
{
    ELSEIF (product_identification.product_number = '$47444') AND
           (product_identification.model_number (1, 1) = '2') THEN

      FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF

        = dmc$bytes_per_mau =
          p_physical_attributes^ [index].bytes_per_mau := 4096;

        = dmc$cylinders_per_device =
          p_physical_attributes^ [index].cylinders_per_device := 2290;

        = dmc$flaw_map_locations =
          p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := FALSE;
          p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
          p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

        = dmc$maus_per_cylinder =
          p_physical_attributes^ [index].maus_per_cylinder := 368;

        = dmc$maus_per_dau =
          p_physical_attributes^ [index].maus_per_dau := 4;

        = dmc$sectors_per_mau =
          p_physical_attributes^ [index].sectors_per_mau := 1;

        = dmc$sectors_per_track =
          p_physical_attributes^ [index].sectors_per_track := 25;
        CASEND;
      FOREND;
{
{  3X IBM 3.5
{
    ELSEIF (product_identification.product_number = '$47444') AND
           (product_identification.model_number (1, 1) = '3') THEN

      FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF

        = dmc$bytes_per_mau =
          p_physical_attributes^ [index].bytes_per_mau := 8192;

        = dmc$cylinders_per_device =
          p_physical_attributes^ [index].cylinders_per_device := 2290;

        = dmc$flaw_map_locations =
          p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := FALSE;
          p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
          p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

        = dmc$maus_per_cylinder =
          p_physical_attributes^ [index].maus_per_cylinder := 278;

        = dmc$maus_per_dau =
          p_physical_attributes^ [index].maus_per_dau := 2;

        = dmc$sectors_per_mau =
          p_physical_attributes^ [index].sectors_per_mau := 1;

        = dmc$sectors_per_track =
          p_physical_attributes^ [index].sectors_per_track := 19;
        CASEND;
      FOREND;
{
{  4X IBM 3.5
{
    ELSEIF (product_identification.product_number = '$47444') AND
           (product_identification.model_number (1, 1) = '4') THEN

      FOR index := 1 TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF

        = dmc$bytes_per_mau =
          p_physical_attributes^ [index].bytes_per_mau := 8192;

        = dmc$cylinders_per_device =
          p_physical_attributes^ [index].cylinders_per_device := 2290;

        = dmc$flaw_map_locations =
          p_physical_attributes^ [index].flaw_locations [1].device_flaws_specified := FALSE;
          p_physical_attributes^ [index].flaw_locations [1].mau_address := 0;
          p_physical_attributes^ [index].flaw_locations [1].mau_byte_offset := 0;

        = dmc$maus_per_cylinder =
          p_physical_attributes^ [index].maus_per_cylinder := 368;

        = dmc$maus_per_dau =
          p_physical_attributes^ [index].maus_per_dau := 2;

        = dmc$sectors_per_mau =
          p_physical_attributes^ [index].sectors_per_mau := 1;

        = dmc$sectors_per_track =
          p_physical_attributes^ [index].sectors_per_track := 25;
        CASEND;
      FOREND;

    ELSE
      STRINGREP (error_msg, length, product_identification.product_number,
        product_identification.underscore, product_identification.model_number,
        '-unsupported product number (physical)');
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unsupported_product_number,
        error_msg, status);
    IFEND;

  PROCEND dmp$get_physical_attributes;
?? TITLE := '  dmp$get_logical_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$get_logical_attributes (product_identification: cmt$product_identification;
    VAR p_logical_attributes: ^dmt$logical_device_attributes;
    VAR status: ost$status);

    VAR
      element_entry: dst$mf_element_table_entry,
      error_msg: string(60),
      index: integer,
      length: integer;

    status.normal := TRUE;
    error_msg (1,*) := ' ';
    IF p_logical_attributes = NIL THEN
      RETURN;
    IFEND;
{
{ 844
{
    IF product_identification.product_number = '  $844' THEN
      IF product_identification.model_number (1, 1) = '4' THEN

        FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
          CASE p_logical_attributes^ [index].keyword OF

          = dmc$logical_flaws =
            p_logical_attributes^ [index].number_of_flaw_entries := 3;
            { cylinder 820.
            p_logical_attributes^ [index].flaw_locations [1].dau_address := 36080;
            p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 44;
            { cylinder 821
            p_logical_attributes^ [index].flaw_locations [2].dau_address := 36124;
            p_logical_attributes^ [index].flaw_locations [2].number_flawed_daus := 44;
            { cylinder 822
            p_logical_attributes^ [index].flaw_locations [3].dau_address := 36168;
            p_logical_attributes^ [index].flaw_locations [3].number_flawed_daus := 44;

          = dmc$volume_dfl_entries =
{
{           determine the number of dfl entries on a given device thusly:
{             (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
            p_logical_attributes^ [index].number_dfl_entries := 9258;

          = dmc$volume_directory_entries =
            p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

          = dmc$volume_default_transfer_sz =
            p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_size_844;

          = dmc$cylinder_allocation_size =
            p_logical_attributes^ [index].bytes_per_cylinder := 180224;

          ELSE

          CASEND;
        FOREND;

      ELSE
        STRINGREP (error_msg, length, product_identification.product_number,
          product_identification.underscore, product_identification.model_number,
          '-unsupported model number (logical)');
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unsupported_model_number,
          error_msg, status);
      IFEND;
{
{  885
{
    ELSEIF product_identification.product_number = '  $885' THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 2;
          { cylinder 841
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 134560;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 160;
          { cylinder 842
          p_logical_attributes^ [index].flaw_locations [2].dau_address := 134720;
          p_logical_attributes^ [index].flaw_locations [2].number_flawed_daus := 160;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 33720;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_size_885;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 655360;

        ELSE

        CASEND;
      FOREND;
{
{  ISD-I
{
    ELSEIF product_identification.product_number = '  $834' THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
            p_logical_attributes^ [index].number_of_flaw_entries := 2;

            { cylinder 815
            p_logical_attributes^ [index].flaw_locations [1].dau_address := 8150;
            p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 10;

            { cylinder 816.
            p_logical_attributes^ [index].flaw_locations [2].dau_address := 8160;
            p_logical_attributes^ [index].flaw_locations [2].number_flawed_daus := 10;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 8170;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_size_834;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 163840;

        ELSE

        CASEND;
      FOREND;
{
{  ISD-II
{
    ELSEIF product_identification.product_number = '  $836' THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 2;

          { cylinder 699
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 24465;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 35;

          { cylinder 700
          p_logical_attributes^ [index].flaw_locations [2].dau_address := 24500;
          p_logical_attributes^ [index].flaw_locations [2].number_flawed_daus := 35;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 24535;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_size_836;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 573440;

        ELSE

        CASEND;
      FOREND;
{
{  CM3/ISD-II
{
    ELSEIF product_identification.product_number = ' $9836' THEN

      dsp$retrieve_mf_element_entry (0, dsc$dftb_eid_cpu0_element, element_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 3;
{
{         The special models of 930s limit usable disk space to 509 cylinders,
{         in dmm$initialize_volume, build_device_allocation_table has a check
{         for cylinders_per_device and will ignore anything outside that range.
{         So the following was left alone, depending on that check.
{
          { cylinder 700
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 25200;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 36;

          { cylinder 701
          p_logical_attributes^ [index].flaw_locations [2].dau_address := 25236;
          p_logical_attributes^ [index].flaw_locations [2].number_flawed_daus := 36;

          { cylinder 702
          p_logical_attributes^ [index].flaw_locations [3].dau_address := 25272;
          p_logical_attributes^ [index].flaw_locations [3].number_flawed_daus := 36;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
{
{         Check for special model of 930 which limits usable disk space
{
          IF (element_entry.model_number = osc$cyber_180_model_930a) OR
             (element_entry.model_number = osc$cyber_180_model_932a) THEN
            p_logical_attributes^ [index].number_dfl_entries := 18324;
          ELSE
            p_logical_attributes^ [index].number_dfl_entries := 25308;
          IFEND;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_size_9836;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 589824;

        ELSE

        CASEND;
      FOREND;
{
{  $FA7B5_A / 9853_x
{
    ELSEIF product_identification.product_number = ' $9853' THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 3;

          { cylinder 1409
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 69041;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 49;

          { cylinder 1410
          p_logical_attributes^ [index].flaw_locations [2].dau_address := 69090;
          p_logical_attributes^ [index].flaw_locations [2].number_flawed_daus := 49;

          { cylinder 1411
          p_logical_attributes^ [index].flaw_locations [3].dau_address := 69139;
          p_logical_attributes^ [index].flaw_locations [3].number_flawed_daus := 49;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
{               DO NOT BREAK FILE COMPATABILITY!  KEEP THIS FIELD AT A MAX OF 2 BYTES

          p_logical_attributes^ [index].number_dfl_entries := 65535;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_size_9853;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 802816;

        ELSE

        CASEND;
      FOREND;
{
{  895  (33800)
{
    ELSEIF product_identification.product_number = '  $895' THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 3;

          { cylinder 883.
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 32671;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 37;

          { cylinder 884.
          p_logical_attributes^ [index].flaw_locations [2].dau_address := 32708;
          p_logical_attributes^ [index].flaw_locations [2].number_flawed_daus := 37;

          { cylinder 885.
          p_logical_attributes^ [index].flaw_locations [3].dau_address := 32745;
          p_logical_attributes^ [index].flaw_locations [3].number_flawed_daus := 37;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 32782;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_size_895;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 606208;

        ELSE

        CASEND;
      FOREND;
{
{  HYDRA
{
    ELSEIF product_identification.product_number = '  $887' THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 3;

          { cylinder 881.
          p_logical_attributes^ [index].flaw_locations [2].dau_address := 33478;
          p_logical_attributes^ [index].flaw_locations [2].number_flawed_daus := 38;

          { cylinder 882.
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 33516;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 38;

          { cylinder 883.
          p_logical_attributes^ [index].flaw_locations [3].dau_address := 33554;
          p_logical_attributes^ [index].flaw_locations [3].number_flawed_daus := 38;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 33592;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_size_887;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 622592;

        ELSE

        CASEND;
      FOREND;
{
{  SSD Serial
{
      ELSEIF (product_identification.product_number = ' $5832') AND
             (product_identification.model_number (1, 1) = '1') THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 1;

          { cylinder 843
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 10127;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 1;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 10128;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_sz_5832_1;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 196608;

        ELSE

        CASEND;
      FOREND;
{
{  SSD Parallel
{
      ELSEIF (product_identification.product_number = ' $5832') AND
             (product_identification.model_number (1, 1) = '2') THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 1;

          { cylinder 834
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 20039;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 1;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 20040;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_sz_5832_2;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 393216;

        ELSE

        CASEND;
      FOREND;
{
{  1X SABRE 2HP / 1XP SABRE 2HP
{
      ELSEIF (product_identification.product_number = ' $5833') AND
             ((product_identification.model_number (1, 1) = '1') OR
              (product_identification.model_number (1, 2) = '1P')) THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 2;

          { cylinder 1627
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 61826;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 38;
          { cylinder 1628
          p_logical_attributes^ [index].flaw_locations [2].dau_address := 61864;
          p_logical_attributes^ [index].flaw_locations [2].number_flawed_daus := 38;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 61902;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_sz_5833_1;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 622592;

        ELSE

        CASEND;
      FOREND;
{
{  2X SABRE 2HP
{
      ELSEIF (product_identification.product_number = ' $5833') AND
             (product_identification.model_number (1, 1) = '2') THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 1;

          { cylinder 1628
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 118844;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 73;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 118917;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_sz_5833_2;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 1196032;

        ELSE

        CASEND;
      FOREND;
{
{  3X SABRE 2HP
{
      ELSEIF (product_identification.product_number = ' $5833') AND
             (product_identification.model_number (1, 1) = '3') THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 1;

          { cylinder 1628
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 185592;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 114;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 185706;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_sz_5833_3P;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 1867776;

        ELSE

        CASEND;
      FOREND;
{
{  4X SABRE 2HP
{
      ELSEIF (product_identification.product_number = ' $5833') AND
             (product_identification.model_number (1, 1) = '4') THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 1;

          { cylinder 1628
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 237688;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 146;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 237834;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_sz_5833_4;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 2392064;

        ELSE

        CASEND;
      FOREND;
{
{  1X ELITE 2 / 1XP ELITE 2
{
      ELSEIF (product_identification.product_number = ' $5838') AND
             ((product_identification.model_number (1, 1) = '1') OR
              (product_identification.model_number (1, 2) = '1P')) THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 1;

          { cylinder 2619
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 102141;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 39;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 102180;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_sz_5838_1;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 647168;

        ELSE

        CASEND;
      FOREND;
{
{  2X ELITE 2
{
      ELSEIF (product_identification.product_number = ' $5838') AND
             (product_identification.model_number (1, 1) = '2') THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 1;

          { cylinder 2619
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 201663;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 77;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 201740;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_sz_5838_2;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 1273856;

        ELSE

        CASEND;
      FOREND;
{
{  3X ELITE 2
{
      ELSEIF (product_identification.product_number = ' $5838') AND
             (product_identification.model_number (1, 1) = '3') THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 1;

          { cylinder 2619
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 311661;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 119;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 311780;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_sz_5838_3P;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 1957888;

        ELSE

        CASEND;
      FOREND;
{
{  4X ELITE 2
{
      ELSEIF (product_identification.product_number = ' $5838') AND
             (product_identification.model_number (1, 1) = '4') THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 1;

          { cylinder 2619
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 405945;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 155;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 406100;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfer_sz_5838_4;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 2547712;

        ELSE

        CASEND;
      FOREND;
{
{  1X IBM 3.5 / 1XP IBM 3.5
{
      ELSEIF (product_identification.product_number = '$47444') AND
             ((product_identification.model_number (1, 1) = '1') OR
              (product_identification.model_number (1, 2) = '1P')) THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 1;

          { cylinder 2289
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 107583;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 47;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 107630;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfr_sz_47444_1;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 770048;

        ELSE

        CASEND;
      FOREND;
{
{  2X IBM 3.5
{
      ELSEIF (product_identification.product_number = '$47444') AND
             (product_identification.model_number (1, 1) = '2') THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 1;

          { cylinder 2289
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 210588;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 92;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 210680;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfr_sz_47444_2;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 1507328;

        ELSE

        CASEND;
      FOREND;
{
{  3X IBM 3.5
{
      ELSEIF (product_identification.product_number = '$47444') AND
             (product_identification.model_number (1, 1) = '3') THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 1;

          { cylinder 2289
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 318171;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 139;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 318310;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfr_sz_47444_3P;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 2277376;

        ELSE

        CASEND;
      FOREND;
{
{  4X IBM 3.5
{
      ELSEIF (product_identification.product_number = '$47444') AND
             (product_identification.model_number (1, 1) = '4') THEN

      FOR index := 1 TO UPPERBOUND (p_logical_attributes^) DO
        CASE p_logical_attributes^ [index].keyword OF

        = dmc$logical_flaws =
          p_logical_attributes^ [index].number_of_flaw_entries := 1;

          { cylinder 2289
          p_logical_attributes^ [index].flaw_locations [1].dau_address := 421176;
          p_logical_attributes^ [index].flaw_locations [1].number_flawed_daus := 184;

        = dmc$volume_dfl_entries =
{
{             determine the number of dfl entries on a given device thusly:
{               (daus per spindle) DIV (# of consecutive daus in a 16K allocation style)
{
          p_logical_attributes^ [index].number_dfl_entries := 421360;

        = dmc$volume_directory_entries =
          p_logical_attributes^ [index].number_directory_entries := dmc$default_vol_dir_entries;

        = dmc$volume_default_transfer_sz =
          p_logical_attributes^ [index].volume_default_transfer_size := dmc$default_transfr_sz_47444_4;

        = dmc$cylinder_allocation_size =
          p_logical_attributes^ [index].bytes_per_cylinder := 3014656;

        ELSE

        CASEND;
      FOREND;

    ELSE
      STRINGREP (error_msg, length, product_identification.product_number,
        product_identification.underscore, product_identification.model_number,
        '-unsupported product number (logical)');
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unsupported_product_number,
        error_msg, status);
    IFEND;

  PROCEND dmp$get_logical_attributes;

MODEND dmm$get_device_attributes;

*DECK DECK=DMM$GET_FILE_INFO EXPAND=TRUE
?? RIGHT := 110 ??
MODULE dmm$get_file_info;
*copyc dmh$get_file_info
?? PUSH (LISTEXT := ON) ??
*copyc dmp$get_total_allocated_length
*copyc gfp$get_eoi_from_fde
*copyc gfp$verify_get_locked_fde_p
*copyc gfp$unlock_fde_p
*copyc gft$file_descriptor_entry
*copyc gft$system_file_identifier
*copyc dmt$file_information
*copyc mmc$null_shared_queue
*copyc ost$status
?? POP ??

  PROCEDURE [XDCL, #GATE] dmp$get_file_info
    (    system_file_id: gft$system_file_identifier;
     VAR file_info: dmt$file_information;
     VAR status: ost$status);

    VAR
      p_fde: gft$locked_file_desc_entry_p;

    gfp$verify_get_locked_fde_p (system_file_id, p_fde, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$get_total_allocated_length (p_fde, file_info.total_allocated_length);
    file_info.eoi_byte_address := gfp$get_eoi_from_fde (p_fde);
    file_info.file_kind := p_fde^.file_kind;
    IF p_fde^.queue_ordinal > mmc$pq_shared_last_sys THEN
      file_info.shared_queue := p_fde^.queue_ordinal - mmc$pq_shared_last_sys;
    ELSE
      file_info.shared_queue := mmc$null_shared_queue;
    IFEND;
    file_info.time_last_modified := p_fde^.time_last_modified;
    file_info.trimmed_length := 0;
    gfp$unlock_fde_p (p_fde);

  PROCEND dmp$get_file_info;

MODEND dmm$get_file_info;
*DECK DECK=DMM$GET_INITIALIZED_ADDRESSES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$get_initialized_addresses;
?? PUSH (LISTEXT := ON) ??
?? TITLE := '  Common Decks', EJECT ??
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_level_2_ptr
*copyc dmt$addr_length_pair
*copyc dmt$error_condition_codes
*copyc dmt$file_allocation_descriptor
*copyc dmt$keypoint_calls
*copyc dmt$disk_file_descriptor
*copyc dmt$system_file_id
*copyc gfp$get_locked_fde_p
*copyc gfp$unlock_fde_p
*copyc gft$locked_file_desc_entry_p
*copyc osd$virtual_address
*copyc osk$keypoints
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc ost$wait
?? POP ??
?? TITLE := '  dmp$get_initialized_addresses', EJECT ??
*copyc dmh$get_initialized_addresses

  PROCEDURE [XDCL, #GATE] dmp$get_initialized_addresses
    (    sfid: gft$system_file_identifier;
         starting_byte_address: ost$segment_offset;
     VAR addr_list: array [ * ] of dmt$addr_length_pair;
     VAR number_of_addresses: integer;
     VAR list_overflow: boolean;
     VAR status: ost$status);

    VAR
      bytes_per_allocation: dmt$bytes_per_allocation,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: gft$locked_file_desc_entry_p,
      previous_offset: integer,
      level_1_index: dmt$level_1_index,
      level_1_start: dmt$level_1_index,
      level_2_index: dmt$level_2_index,
      level_2_start: dmt$level_2_index,
      list_index: integer,
      offset: integer,
      p_level_2: ^dmt$level_2_table;

    #INLINE ('keypoint', osk$entry, osk$m * sfid.file_entry_index, dmk$get_initialized_addresses);

    number_of_addresses := 0;
    list_overflow := FALSE;
    status.normal := TRUE;
    previous_offset := -1;

{
{ initialize local variables
{

    list_index := LOWERBOUND (addr_list) - 1;

{ Lock the file descriptor entry.

    gfp$get_locked_fde_p (sfid, p_fde);
    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

  /file_descriptor_locked/
    BEGIN
      IF p_dfd^.file_allocation_table <> NIL THEN
        bytes_per_allocation := p_dfd^.bytes_per_allocation;
        level_1_start := starting_byte_address DIV p_dfd^.bytes_per_level_2;
        level_2_start := starting_byte_address MOD p_dfd^.bytes_per_level_2 DIV bytes_per_allocation;
        FOR level_1_index := level_1_start TO p_dfd^.fat_upper_bound DO
          dmp$get_level_2_ptr (^p_dfd^.file_allocation_table^ [level_1_index], p_level_2);
          IF p_level_2 <> NIL THEN
            FOR level_2_index := level_2_start TO (p_dfd^.bytes_per_level_2 DIV bytes_per_allocation - 1) DO
              IF (p_level_2^ [level_2_index].state = dmc$fau_initialized) OR
                    (p_level_2^ [level_2_index].state = dmc$fau_initialized_and_flawed) THEN
                offset := (level_1_index * p_dfd^.bytes_per_level_2) +
                    (level_2_index * bytes_per_allocation);

                IF offset >= p_fde^.eoi_byte_address THEN
                  {Stop at current eoi
                  EXIT /file_descriptor_locked/;
                IFEND;

                IF offset <> (previous_offset + bytes_per_allocation) THEN
                  list_index := list_index + 1;
                  IF list_index > UPPERBOUND (addr_list) THEN
                    list_overflow := TRUE;
                    EXIT /file_descriptor_locked/;
                  ELSE
                    number_of_addresses := number_of_addresses + 1;
                    addr_list [list_index].addr := offset;
                    addr_list [list_index].length := bytes_per_allocation;
                  IFEND;
                ELSE
                  addr_list [list_index].length := addr_list [list_index].length + bytes_per_allocation;
                IFEND;
                previous_offset := offset;
              IFEND;
            FOREND;
          IFEND;
          level_2_start := 0;
        FOREND;
      IFEND;

    END /file_descriptor_locked/;

    gfp$unlock_fde_p (p_fde);

    #INLINE ('keypoint', osk$exit, osk$m * (1 - $INTEGER (status.normal)), dmk$get_initialized_addresses);

  PROCEND dmp$get_initialized_addresses;
MODEND dmm$get_initialized_addresses;
*DECK DECK=DMM$GET_LOGICAL_UNIT_NUMBER EXPAND=TRUE

?? RIGHT := 110 ??
*copy OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE Device Management' ??
MODULE dmm$get_logical_unit_number ALIAS 'DMMGLUN';
?? NEWTITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc DMT$ERROR_CONDITION_CODES
*copyc IOT$LOGICAL_UNIT
*copyc RMD$VOLUME_DECLARATIONS
?? POP ??
?? TITLE := '  XREF Procedures', EJECT ??
*copy OSP$SET_STATUS_ABNORMAL
*copy DMP$SEARCH_ACTIVE_VOLUME_TABLE
?? TITLE := '  Static Variables', EJECT ??
*copy DMV$ACTIVE_VOLUME_TABLE
?? TITLE := '  dmp$get_logical_unit_number', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$get_logical_unit_number (recorded_vsn: rmt$recorded_vsn;
    VAR logical_unit_number: iot$logical_unit;
    VAR status: ost$status);

    VAR
      search_key: dmt$avt_search_key,
      avt_index: dmt$active_volume_table_index,
      active_volume_entry_not_found: boolean;




    status.normal := TRUE;

    search_key.value := dmc$search_avt_by_rec_vsn;
    search_key.recorded_vsn := recorded_vsn;

    dmp$search_active_volume_table (search_key, avt_index, active_volume_entry_not_found);
    IF active_volume_entry_not_found THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$recorded_vsn_not_in_lun,
        'dmp$get_logical_unit_number', status);
    ELSE
      logical_unit_number := dmv$p_active_volume_table^ [avt_index].logical_unit_number;
    IFEND;

  PROCEND dmp$get_logical_unit_number;

MODEND dmm$get_logical_unit_number;
*DECK DECK=DMM$GET_SERVER_FMD EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Device Manager: Get server fmd ' ??
MODULE dmm$get_server_fmd;

{ PURPOSE:
{   This client module serves to act as an interface between File Manager
{   and the server mainframe when getting FMD for a file on that mainframe.

?? NEWTITLE := '   Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dft$server_descriptor
*copyc dmt$error_condition_codes
*copyc dmt$stored_fmd
*copyc dmt$stored_fmd_size
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*copyc dfp$fetch_served_family_info
*copyc dfp$send_remote_procedure_call
*copyc dfp$set_invalid_family_index
*copyc dfv$served_family_table_root
*copyc dfp$get_served_file_desc_p
*copyc dmp$get_stored_fmd
*copyc dmp$get_stored_fmd_size
*copyc gfp$get_fde_p
*copyc i#move
*copyc jmp$system_job
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osv$initial_exception_context
?? TITLE := '  Client: [XDCL, #GATE] dmp$get_server_fmd', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$get_server_fmd
    (    sfid: gft$system_file_identifier;
     VAR stored_fmd: dmt$stored_fmd;
     VAR stored_fmd_size: dmt$stored_fmd_size;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT dmp$get_server_fmd;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      context: ^ost$ecp_exception_context,
      family: ost$family_name,
      local_status: ost$status,
      p_fde: gft$file_desc_entry_p,
      p_queue_interface_table: dft$p_queue_interface_table,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_remote_sfid: ^gft$system_file_identifier,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      p_served_family_entry: ^dft$served_family_table_entry,
      p_server_descriptor: dft$server_descriptor_p,
      queue_entry_location: dft$rpc_queue_entry_location,
      queue_index: dft$queue_index,
      remote_sfid: gft$system_file_identifier,
      served_family_table_index: dft$served_family_table_index,
      server_location: dft$server_location,
      server_mainframe_id: pmt$binary_mainframe_id,
      valid_index: boolean,
      valid_sfid: boolean;

    status.normal := TRUE;
    context := NIL;
    gfp$get_fde_p (sfid, p_fde);
    IF p_fde = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$illegal_use_of_sfid,
            ' invalid sfid - dmp$get_server_fmd.', status);
      RETURN;
    IFEND;
    dfp$get_served_file_desc_p (p_fde, p_server_descriptor);

    REPEAT
      IF (p_server_descriptor^.header.file_state = dfc$awaiting_recovery) THEN
        { the remote sfid is not usable
        #SPOIL (p_server_descriptor^.header.file_state);
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
        IFEND;
        osp$set_status_condition (dfe$server_not_active, context^.condition_status);
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    IF (p_server_descriptor^.header.file_state = dfc$terminated) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated, '', status);
      RETURN;
    IFEND;

    served_family_table_index := p_server_descriptor^.header.served_family_table_index;
    remote_sfid := p_server_descriptor^.header.remote_sfid;

    dfp$fetch_served_family_info (served_family_table_index, family, server_mainframe_id,
          p_queue_interface_table, queue_index, valid_index);
    IF NOT valid_index THEN
      dfp$set_invalid_family_index (served_family_table_index, ' invalid index dfp$set_seg_eoi ', status);
      RETURN;
    IFEND;

    p_served_family_entry := ^dfv$served_family_table_root.
          p_family_list_pointer_array^ [p_server_descriptor^.header.served_family_table_index.pointers_index].
          p_served_family_list^ [p_server_descriptor^.header.served_family_table_index.family_list_index];

    IF (p_server_descriptor^.header.server_lifetime <> p_served_family_entry^.server_lifetime) OR
          (p_server_descriptor^.header.file_state = dfc$terminated) THEN
      osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated, '', status);
      RETURN;
    IFEND;
    server_location.server_location_selector := dfc$served_family_table_index;
    server_location.served_family_table_index := served_family_table_index;

  /wait_for_active/
    REPEAT
      dfp$begin_ch_remote_proc_call (server_location, {send_if_deactivated=} FALSE, queue_entry_location,
            p_send_parameters, p_send_data, status);
      IF NOT  status.normal THEN
        #SPOIL (p_served_family_entry^.server_state);
        CASE p_served_family_entry^.server_state OF
        = dfc$active =
          CYCLE /wait_for_active/;
        = dfc$terminated =
          osp$set_status_condition (dfe$server_has_terminated, status);
        = dfc$deactivated, dfc$inactive, dfc$awaiting_recovery =
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        ELSE
        CASEND;

      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    NEXT p_remote_sfid IN p_send_parameters;
    p_remote_sfid^ := remote_sfid;

    dfp$send_remote_procedure_call (queue_entry_location, dfc$get_server_fmd, #SIZE (p_remote_sfid^), 0,
          p_receive_parameters, p_receive_data, status);

    IF status.normal THEN
      IF p_receive_data = NIL THEN
        stored_fmd_size := #SIZE (p_receive_parameters^);
        IF #SIZE (stored_fmd) < stored_fmd_size THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
                'FMD too small - dmp$get_server_fmd.', status);
        ELSE
          i#move (p_receive_parameters, ^stored_fmd, stored_fmd_size);
        IFEND;
      ELSE { Fmd to big to fit in buffer, must be in data.
        stored_fmd_size := #SIZE (p_receive_data^);
        IF #SIZE (stored_fmd) < stored_fmd_size THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
                'FMD too small - dmp$get_server_fmd.', status);
        ELSE
          i#move (p_receive_data, ^stored_fmd, stored_fmd_size);
        IFEND;
      IFEND;
    IFEND;
    dfp$end_ch_remote_proc_call (queue_entry_location, local_status);

  PROCEND dmp$get_server_fmd;
?? TITLE := '  Server: [XDCL, #GATE] dmp$server_get_fmd  ', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$server_get_fmd
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      fmd_size: dmt$stored_fmd_size,
      p_fmd: ^dmt$stored_fmd,
      p_sfid: ^gft$system_file_identifier;

    NEXT p_sfid IN p_param_received_from_client;
    dmp$get_stored_fmd_size (p_sfid^, fmd_size, status);
    IF status.normal THEN
      IF fmd_size <= #SIZE (p_send_to_client_params^) THEN
        NEXT p_fmd: [[REP fmd_size OF cell]] IN p_send_to_client_params;
        data_size_to_send_to_client := 0;
        send_parameters_length := fmd_size;
      ELSEIF fmd_size <= #SIZE (p_data_to_client^) THEN
        send_parameters_length := 0;
        data_size_to_send_to_client := fmd_size;
        NEXT p_fmd: [[REP fmd_size OF cell]] IN p_data_to_client;
      ELSE { Give up if its bigger than the data area.
          osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
           'FMD too small - dmp$server_get_fmd.', status);
        RETURN;
      IFEND;
      dmp$get_stored_fmd (p_sfid^, p_fmd^, status);
    IFEND;
  PROCEND dmp$server_get_fmd;
?? OLDTITLE, OLDTITLE ??
MODEND dmm$get_server_fmd;
*DECK DECK=DMM$IDLE_SYSTEM EXPAND=TRUE
?? RIGHT := 110 ??
MODULE dmm$idle_system;
*copyc dmp$activate_volume
*copyc dmv$active_volume_table
*copyc dmp$change_dfl_damage
*copyc dmp$deactivate_volume
*copyc dmp$evacuate_active_device_log
*copyc dmp$get_avt_logging_info
*copyc dmp$get_fmd_by_index
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_active_vol_attributes
*copyc dmp$process_device_log_entry
*copyc dmp$split_allocation_log
*copyc dmt$error_condition_codes
*copyc dmv$minimum_log_count
*copyc dpp$put_critical_message
*copyc gfv$null_sfid
*copyc gfp$get_sfid_from_fde_p
*copyc gfp$lock_fde
*copyc gfp$scan_all_fdes
*copyc gfp$unlock_fde_p
*copyc i#call_monitor
*copyc jmv$system_ijl_ordinal
*copyc mmp$issue_ring1_segment_request
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osv$mainframe_pageable_heap
*copyc pmp$delay
*copyc tmp$ready_system_task1
*copyc tmt$rb_update_job_task_enviro
*copyc syp$enable_job_recovery
*copyc syp$disable_job_recovery

  VAR
    dmv$idle_system: [XDCL] boolean := FALSE,
    idle_info: ^array [ * ] of record
      active: boolean,
      dat,
      login,
      dfl,
      dlog,
      dir: dmt$system_file_id,
    recend := NIL;

  {The purpose of this request is to idle the device management
  {area of the system so that
  {the next system deadstart may    be a continuation rather than
  {a recovery deadstart.

  PROCEDURE [XDCL, #GATE] dmp$idle_system;

    CONST
      ten_milliseconds = 10;

    VAR
      able: boolean,
      avt_index: dmt$active_volume_table_index,
      change_sys_tasks_request_block: tmt$rb_update_job_task_enviro,
      file_count: integer,
      ignore_status: ost$status,
      info: dmt$avt_logging_info,
      p_fde: gft$file_desc_entry_p,
      server_file_count: integer,
      scan_control: gft$scan_all_fdes_state,
      status: ost$status,
      st: string (100),
      stl: integer;

    file_count := 0;
    server_file_count := 0;

    gfp$scan_all_fdes (gfc$tr_system, scan_control, p_fde);

    WHILE p_fde <> NIL DO
      /recover_files/
      BEGIN

      IF p_fde^.file_kind = gfc$fk_device_file THEN
        EXIT /recover_files/;
      IFEND;


      IF p_fde^.attached_in_write_count < 1 THEN
        EXIT /recover_files/;
      IFEND;

      IF p_fde^.media = gfc$fm_served_file THEN
        server_file_count := server_file_count + 1;
        idle_server_file (p_fde, status);
      ELSEIF p_fde^.media = gfc$fm_mass_storage_file THEN
        file_count := file_count + 1;
        idle_file (p_fde, status);
      IFEND;
      IF NOT status.normal THEN
        STRINGREP (st, stl, 'Job recovery disabled; cannot idle file due to: ',
              status.condition);
        dpp$put_critical_message (st (1, stl), status);
        syp$disable_job_recovery;
      IFEND;
      END /recover_files/;
      gfp$scan_all_fdes (gfc$tr_null_residence, scan_control, p_fde);
    WHILEND;

    STRINGREP (st, stl, file_count, ' File(s) idled');
    dpp$put_critical_message (st (1, stl), status);
    STRINGREP (st, stl, server_file_count, ' Server File(s) idled');
    dpp$put_critical_message (st (1, stl), status);

    {Flush device logs
    {Ensure all entries are moved to the device logs.  dmp$evacuate_active_device_log will
    {not do this for down devices.

    dmp$split_allocation_log (FALSE, status);

    FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND
          (dmv$p_active_volume_table^) DO
      IF NOT dmv$p_active_volume_table^ [avt_index].entry_available THEN
          IF dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log <>
              gfv$null_sfid THEN
            STRINGREP (st, stl, 'Flushing volume: ', dmv$p_active_volume_table^
                [avt_index].mass_storage.recorded_vsn);
            dpp$put_critical_message (st (1, stl), status);

            dmp$evacuate_active_device_log (avt_index, status);
            IF NOT status.normal THEN
              STRINGREP (st, stl, 'Cannot flush volume due to: ', status.
                  condition);
              dpp$put_critical_message (st (1, stl), ignore_status);
            IFEND;
            dmp$get_avt_logging_info (avt_index, info, able);
            IF (NOT status.normal) OR ((info.log_entry_count > dmv$minimum_log_count) AND
               (dmv$p_active_volume_table^ [avt_index].mass_storage.volume_unavailable)) THEN
              STRINGREP (st, stl, 'Log entry count = ', info.log_entry_count);
              dpp$put_critical_message (st (1, stl), ignore_status);
              syp$disable_job_recovery;
              dpp$put_critical_message ('Job recovery disabled', status);
            IFEND;

          IFEND;
      IFEND;
    FOREND;

{ Call monitor to idle the Device_Management system tasks.

    REPEAT
      change_sys_tasks_request_block.reqcode := syc$rc_update_job_task_enviro;
      change_sys_tasks_request_block.status.normal := TRUE;
      change_sys_tasks_request_block.subcode := tmc$ujte_idle_dm_sys_tasks;
      i#call_monitor (#LOC (change_sys_tasks_request_block), #SIZE (change_sys_tasks_request_block));
      IF NOT change_sys_tasks_request_block.status.normal THEN
        pmp$delay (ten_milliseconds, ignore_status);
      IFEND;
    UNTIL change_sys_tasks_request_block.status.normal;

    IF idle_info = NIL THEN
      ALLOCATE idle_info: [LOWERBOUND (dmv$p_active_volume_table^) ..
            UPPERBOUND (dmv$p_active_volume_table^)] IN
            osv$mainframe_pageable_heap^;
    IFEND;

    FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND
          (dmv$p_active_volume_table^) DO
      idle_info^ [avt_index].active := FALSE;
      IF NOT dmv$p_active_volume_table^ [avt_index].entry_available THEN
          STRINGREP (st, stl, 'Idling volume: ', dmv$p_active_volume_table^
                [avt_index].mass_storage.recorded_vsn);
          dpp$put_critical_message (st (1, stl), status);

          idle_info^ [avt_index].active := TRUE;
          idle_info^ [avt_index].dat := dmv$p_active_volume_table^ [avt_index].
                mass_storage.p_device_allocation_table;
          idle_info^ [avt_index].dfl := dmv$p_active_volume_table^ [avt_index].
                mass_storage.p_device_file_list_table;
          idle_info^ [avt_index].dir := dmv$p_active_volume_table^ [avt_index].
                mass_storage.p_directory;
          idle_info^ [avt_index].login := dmv$p_active_volume_table^
                [avt_index].mass_storage.p_login_table;
          idle_info^ [avt_index].dlog := dmv$p_active_volume_table^
                [avt_index].mass_storage.p_device_log;

          IF dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log
                <> gfv$null_sfid THEN
            IF NOT dmv$p_active_volume_table^ [avt_index].mass_storage.volume_unavailable THEN
              dmp$deactivate_volume (avt_index, status);
              IF NOT status.normal THEN
                STRINGREP (st, stl, 'Cannot idle volume due to: ', status.
                      condition);
                dpp$put_critical_message (st (1, stl), status);
                osp$system_error ('Cannot idle', ^status);
              IFEND;
            ELSE
              dpp$put_critical_message ('Cannot idle a down volume', status);
            IFEND;
          IFEND;

          dmv$p_active_volume_table^ [avt_index].mass_storage.
                p_device_allocation_table := gfv$null_sfid;
          dmv$p_active_volume_table^ [avt_index].mass_storage.
                p_device_file_list_table := gfv$null_sfid;
          dmv$p_active_volume_table^ [avt_index].mass_storage.p_directory :=
                gfv$null_sfid;
          dmv$p_active_volume_table^ [avt_index].mass_storage.p_login_table :=
                gfv$null_sfid;
      IFEND;
    FOREND;

    dmv$idle_system := TRUE;

  PROCEND dmp$idle_system;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$resume_system;

    VAR
      able: boolean,
      avt_index: dmt$active_volume_table_index,
      change_sys_tasks_request_block: tmt$rb_update_job_task_enviro,
      file_count: integer,
      p_fde: gft$file_desc_entry_p,
      scan_control: gft$scan_all_fdes_state,
      st: string (100),
      status: ost$status,
      stl: integer;

    FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND
          (dmv$p_active_volume_table^) DO
      IF NOT dmv$p_active_volume_table^ [avt_index].entry_available THEN
          dmv$p_active_volume_table^ [avt_index].mass_storage.
                p_device_allocation_table := idle_info^ [avt_index].dat;
          dmv$p_active_volume_table^ [avt_index].mass_storage.
                p_device_file_list_table := idle_info^ [avt_index].dfl;
          dmv$p_active_volume_table^ [avt_index].mass_storage.p_directory :=
                idle_info^ [avt_index].dir;
          dmv$p_active_volume_table^ [avt_index].mass_storage.p_login_table :=
                idle_info^ [avt_index].login;
          dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log :=
                idle_info^ [avt_index].dlog;

          IF dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log <>
              gfv$null_sfid THEN

            STRINGREP (st, stl, 'Resuming volume: ', dmv$p_active_volume_table^
                [avt_index].mass_storage.recorded_vsn);
            dpp$put_critical_message (st (1, stl), status);

            IF NOT dmv$p_active_volume_table^ [avt_index].mass_storage.volume_unavailable THEN
              dmp$activate_volume (dmv$p_active_volume_table^ [avt_index].
                  logical_unit_number, status);
              IF NOT status.normal THEN
                STRINGREP (st, stl, 'Cannot resume volume due to: ', status.
                    condition);
                dpp$put_critical_message (st (1, stl), status);
                osp$system_error ('Cannot resume', ^status);
              IFEND;
            ELSE
              dpp$put_critical_message ('Job recovery enabled', status);
              syp$enable_job_recovery;
            IFEND;

          IFEND;
      IFEND;
    FOREND;

{ Call monitor to restart the Device_Management system tasks.

    change_sys_tasks_request_block.reqcode := syc$rc_update_job_task_enviro;
    change_sys_tasks_request_block.status.normal := TRUE;
    change_sys_tasks_request_block.subcode := tmc$ujte_restart_dm_systasks;
    i#call_monitor (#LOC (change_sys_tasks_request_block), #SIZE (change_sys_tasks_request_block));

    file_count := 0;

    gfp$scan_all_fdes (gfc$tr_system, scan_control, p_fde);

    WHILE p_fde <> NIL DO
      /recover_files/
      BEGIN

      IF (p_fde^.file_kind = gfc$fk_device_file) THEN
        EXIT /recover_files/;
      IFEND;

      IF (p_fde^.media <> gfc$fm_mass_storage_file) THEN
        EXIT /recover_files/;
      IFEND;

      IF p_fde^.attached_in_write_count < 1 THEN
        EXIT /recover_files/;
      IFEND;

      file_count := file_count + 1;
      resume_file (p_fde, status);
      IF NOT status.normal THEN
        STRINGREP (st, stl, 'Cannot resume file due to: ', status.
              condition);
        dpp$put_critical_message (st (1, stl), status);
      IFEND;
      END /recover_files/;
      gfp$scan_all_fdes (gfc$tr_null_residence, scan_control, p_fde);
    WHILEND;

    STRINGREP (st, stl, file_count, ' File(s) resumed');
    dpp$put_critical_message (st (1, stl), status);

    dmv$idle_system := FALSE;

  PROCEND dmp$resume_system;
?? EJECT ??

  {This procedure was adapted from dmp$detach_file.  The operati
  {ons performed must allow
  {the next system deadstart to be a continuation deadstart rath
  {er than a recovery deadstart.
  {The operations must be *reversible* by dmp$resume_system (e.g
  {. without a deadstart)

  PROCEDURE idle_file
    (    p_fde: gft$file_desc_entry_p;
     VAR status: ost$status);

    VAR
      avt_entry_found: boolean,
      avt_index: dmt$active_volume_table_index,
      fmd_index: dmt$fmd_index,
      entry_to_be_processed: boolean,
      length: 8 .. 120,
      lock_status: ost$status,
      log_entry: dmt$dl_entry,
      number_of_fmds: dmt$fmd_index,
      p_active_vol_attributes: ^array [ * ] of dmt$assigned_ms_vol_attribute,
      p_fmd: ^dmt$file_medium_descriptor,
      p_dfd: ^dmt$disk_file_descriptor,
      p_rb_ring1_segment_request: ^mmt$rb_ring1_segment_request,
      recorded_vsn: rmt$recorded_vsn,
      sfid: gft$system_file_identifier;

    status.normal := TRUE;

    gfp$lock_fde (p_fde);


  /file_descriptor_locked/
    BEGIN
      gfp$get_sfid_from_fde_p (p_fde, sfid);
      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

      IF NOT p_dfd^.p_fmd^.volume_assigned OR p_dfd^.purged THEN
        EXIT /file_descriptor_locked/;
      IFEND;

      PUSH p_rb_ring1_segment_request;

      p_rb_ring1_segment_request^.reqcode := syc$rc_ring1_segment_request;
      p_rb_ring1_segment_request^.request := mmc$sr1_detach_file;
      p_rb_ring1_segment_request^.sfid := sfid;
      p_rb_ring1_segment_request^.wait_for_io_complete := TRUE;
      p_rb_ring1_segment_request^.status.normal := TRUE;

      mmp$issue_ring1_segment_request (p_rb_ring1_segment_request^);
      IF NOT p_rb_ring1_segment_request^.status.normal THEN
        osp$set_status_abnormal (dmc$device_manager_ident,
              p_rb_ring1_segment_request^.status.condition, '', status);
        EXIT /file_descriptor_locked/;
      IFEND;


        avt_index := p_dfd^.p_fmd^.avt_index;
        recorded_vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;

        IF p_fde^.attached_in_write_count > 0 THEN
          PUSH p_active_vol_attributes: [1 .. 1];

          p_active_vol_attributes^ [1].keyword := dmc$ms_mainframe_assigned;

          dmp$get_active_vol_attributes (recorded_vsn, avt_index,
                p_active_vol_attributes, avt_entry_found);
          IF NOT avt_entry_found THEN
            osp$set_status_abnormal (dmc$device_manager_ident,
                  dme$avt_entry_not_found,
              'unable to locate avt entry - idle_system', status);
            EXIT /file_descriptor_locked/;
          IFEND;

          log_entry.kind := dmc$dl_detach_file;
          log_entry.attach_file_block.global_file_name := p_fde^.global_file_name;
          log_entry.attach_file_block.dfl_index := p_dfd^.p_fmd^.dfl_index;
          log_entry.attach_file_block.mainframe_assigned := p_active_vol_attributes^ [1].mainframe_assigned;

          dmp$process_device_log_entry (avt_index, log_entry, status);
          IF NOT status.normal THEN
            EXIT /file_descriptor_locked/;
          IFEND;
        IFEND;

        IF p_dfd^.damaged_detection_enabled AND NOT p_dfd^.file_damaged THEN
          IF (p_fde^.queue_status = gfc$qs_global_shared) OR
             (p_fde^.queue_status = gfc$qs_job_working_set) THEN
            log_entry.kind := dmc$dl_file_damaged;
            log_entry.file_damaged_block.global_file_name := p_fde^.global_file_name;
            log_entry.file_damaged_block.dfl_index := p_dfd^.p_fmd^.dfl_index;
            log_entry.file_damaged_block.add_damage := $dmt$file_damage [];
            log_entry.file_damaged_block.remove_damage := $dmt$file_damage [dmc$media_image_inconsistent];
          IFEND;
          dmp$process_device_log_entry (avt_index, log_entry, status);
          IF NOT status.normal THEN
            EXIT /file_descriptor_locked/;
          IFEND;
        IFEND;

        IF (p_dfd^.dfd_modified OR p_fde^.flags.eoi_modified) THEN
          log_entry.kind := dmc$dl_update_file_length;
          log_entry.file_length_block.global_file_name := p_fde^.global_file_name;
          log_entry.file_length_block.dfl_index := p_dfd^.p_fmd^.dfl_index;

          log_entry.file_length_block.eof_specified := TRUE;
          log_entry.file_length_block.eof := (p_fde^.eoi_byte_address +
              p_dfd^.bytes_per_allocation - 1) DIV p_dfd^.bytes_per_allocation *
              p_dfd^.bytes_per_allocation;

          log_entry.file_length_block.eoi_specified := TRUE;
          log_entry.file_length_block.eoi := p_fde^.eoi_byte_address;

          dmp$process_device_log_entry (avt_index, log_entry, status);
          IF NOT status.normal THEN
            EXIT /file_descriptor_locked/;
          IFEND;

          number_of_fmds := p_dfd^.number_of_fmds;

          log_entry.kind := dmc$dl_update_fmd_length;
          log_entry.fmd_length_block.global_file_name := p_fde^.global_file_name;
          log_entry.fmd_length_block.fmd_length_specified := TRUE;
          log_entry.fmd_length_block.logical_length_specified := TRUE;

          FOR fmd_index := 1 TO number_of_fmds DO
            dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);
            entry_to_be_processed := (p_fmd^.in_use) AND
              p_fmd^.volume_assigned;

            IF entry_to_be_processed THEN
              avt_index := p_fmd^.avt_index;
              log_entry.fmd_length_block.dfl_index := p_fmd^.dfl_index;
              log_entry.fmd_length_block.fmd_length := p_fmd^.fmd_allocated_length;
              log_entry.fmd_length_block.logical_length := p_fmd^.fmd_allocated_length;

              dmp$process_device_log_entry (avt_index, log_entry, status);
              IF NOT status.normal THEN
                EXIT /file_descriptor_locked/;
              IFEND;

            IFEND;
          FOREND;
        IFEND;

      END /file_descriptor_locked/;

      gfp$unlock_fde_p (p_fde);


  PROCEND idle_file;
?? EJECT ??

{ This procedure was adapted from IDLE_FILE (above).

  PROCEDURE idle_server_file
    (    p_fde: gft$file_desc_entry_p;
     VAR status: ost$status);

    VAR
      p_rb_ring1_segment_request: ^mmt$rb_ring1_segment_request,
      sfid: gft$system_file_identifier;


    status.normal := TRUE;
    gfp$get_sfid_from_fde_p (p_fde, sfid);

    PUSH p_rb_ring1_segment_request;
    p_rb_ring1_segment_request^.reqcode := syc$rc_ring1_segment_request;
    p_rb_ring1_segment_request^.sfid := sfid;
    p_rb_ring1_segment_request^.wait_for_io_complete := TRUE;
    p_rb_ring1_segment_request^.status.normal := TRUE;
    p_rb_ring1_segment_request^.request := mmc$sr1_detach_file;
    mmp$issue_ring1_segment_request (p_rb_ring1_segment_request^);
    IF NOT p_rb_ring1_segment_request^.status.normal THEN
      osp$set_status_abnormal (dmc$device_manager_ident, p_rb_ring1_segment_request^.status.condition,
            '', status);
    IFEND;
  PROCEND idle_server_file;
  ?? EJECT ??

  PROCEDURE resume_file
    (    p_fde: gft$file_desc_entry_p;
     VAR status: ost$status);

    VAR
      avt_entry_found: boolean,
      avt_index: dmt$active_volume_table_index,
      lock_status: ost$status,
      log_entry: dmt$dl_entry,
      p_active_vol_attributes: ^array [ * ] of dmt$assigned_ms_vol_attribute,
      p_dfd: ^dmt$disk_file_descriptor,
      recorded_vsn: rmt$recorded_vsn;

    status.normal := TRUE;

      gfp$lock_fde (p_fde);

    /file_descriptor_locked/
      BEGIN
        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

        IF (NOT p_dfd^.p_fmd^.volume_assigned) OR p_dfd^.purged THEN
          EXIT /file_descriptor_locked/;
        IFEND;

        avt_index := p_dfd^.p_fmd^.avt_index;
        recorded_vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;

        IF p_fde^.attached_in_write_count > 0 THEN
          PUSH p_active_vol_attributes: [1 .. 1];

          p_active_vol_attributes^ [1].keyword := dmc$ms_mainframe_assigned;

          dmp$get_active_vol_attributes (recorded_vsn, avt_index,
                p_active_vol_attributes, avt_entry_found);
          IF NOT avt_entry_found THEN
            osp$set_status_abnormal (dmc$device_manager_ident,
                  dme$avt_entry_not_found,
              'unable to locate avt entry - resume_system', status);
            EXIT /file_descriptor_locked/;
          IFEND;

          log_entry.kind := dmc$dl_attach_file;
          log_entry.attach_file_block.global_file_name := p_fde^.global_file_name;
          log_entry.attach_file_block.dfl_index := p_dfd^.p_fmd^.dfl_index;
          log_entry.attach_file_block.mainframe_assigned :=p_active_vol_attributes^ [1].mainframe_assigned;

          dmp$process_device_log_entry (avt_index, log_entry, status);
          IF NOT status.normal THEN
            EXIT /file_descriptor_locked/;
          IFEND;

          IF p_dfd^.damaged_detection_enabled AND NOT p_dfd^.file_damaged THEN
            dmp$change_dfl_damage (avt_index, $dmt$file_damage [dmc$media_image_inconsistent],
              $dmt$file_damage [], p_dfd^.p_fmd^.dfl_index,{flush_device_log} TRUE,
              p_fde^.global_file_name, status);
          IFEND;
        IFEND;

      END /file_descriptor_locked/;

      gfp$unlock_fde_p (p_fde);

  PROCEND resume_file;
MODEND dmm$idle_system;

*DECK DECK=DMM$INITIALIZE_TAPE_R3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INITIALIZE_TAPE_VOLUME Ring 3.', ??
MODULE dmm$initialize_tape_r3;

{ PURPOSE:
{   This module contains interface to manipulate task private
{   data structures during tape label initialization.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??

*copyc cmp$get_element_name_via_lun
*copyc cmp$get_logical_unit_number
*copyc fmp$obtain_element_name
*copyc jmp$system_job
*copyc osp$set_status_abnormal
*copyc dmt$initv_saved_info

  VAR
    dmv$initialize_tape_volume: [XDCL, #GATE, STATIC, oss$task_private] dmt$initialize_tape_volume :=
      [FALSE];

  VAR
    dmv$initv_saved_info: [XDCL, #GATE, oss$task_private] ^dmt$initv_saved_info := NIL;

?? PUSH (LISTEXT := ON) ??
*copyc cme$logical_configuration_utl
*copyc cme$logical_configuration_mgr
*copyc cmv$logical_unit_table
*copyc dmt$initialize_tape_volume
*copyc oss$task_private
*copyc osv$task_private_heap
*copyc rmt$density
?? POP ??

?? OLDTITLE ??
?? NEWTITLE := '  dmp$obtain_assigned_element', EJECT ??

{ PURPOSE:
{   This procedure obtains the element name of the tape associated
{   with the tape file.

  PROCEDURE [XDCL, #GATE] dmp$obtain_assigned_element
    (    local_file_name: amt$local_file_name;
     VAR assigned_element: cmt$element_name;
     VAR status: ost$status);

    VAR
      name: cmt$element_name;

    fmp$obtain_element_name (local_file_name, name, status);
    IF status.normal THEN
      assigned_element := name;
    IFEND;

  PROCEND dmp$obtain_assigned_element;

?? OLDTITLE ??
?? NEWTITLE := '  dmp$save_tape_initv_vol_info', EJECT ??

{ PURPOSE:
{   This procedure saves various info related to a volume, for an instance
{   of initialize_tape_volume.

  PROCEDURE [XDCL, #GATE] dmp$save_tape_initv_vol_info
    (    volume_info: dmt$initv_saved_info);

    IF dmv$initv_saved_info = NIL THEN
      ALLOCATE dmv$initv_saved_info IN osv$task_private_heap^;
    IFEND;

    dmv$initv_saved_info^ := volume_info;

    IF volume_info.owner_id = '              ' THEN
      dmv$initv_saved_info^.owner_id (1, 14) := 'NONE          ';
    IFEND;

  PROCEND dmp$save_tape_initv_vol_info;

?? OLDTITLE ??
?? NEWTITLE := '  dmp$setup_tape_init_in_progress', EJECT ??

{ PURPOSE:
{   This procedure sets up a task private flag to indicates
{   whether or not initialize_tape_volume is in progress and
{   what logical unit is being used.

  PROCEDURE [XDCL, #GATE] dmp$setup_tape_init_in_progress
    (    in_progress: boolean;
         element_name: cmt$element_name;
         logical_unit: iot$logical_unit);


    IF NOT in_progress AND (dmv$initv_saved_info <> NIL) THEN
      FREE dmv$initv_saved_info IN osv$task_private_heap^;
    IFEND;

    dmv$initialize_tape_volume.in_progress := in_progress;
    dmv$initialize_tape_volume.element_name := element_name;
    dmv$initialize_tape_volume.logical_unit := logical_unit;

  PROCEND dmp$setup_tape_init_in_progress;

?? OLDTITLE ??
?? NEWTITLE := '   dmp$validate_tape_element', EJECT ??

{ PURPOSE:
{   This procedures validates the proper density of the tape
{   unit being chosen for initialize_tape_volume.

  PROCEDURE [XDCL, #GATE] dmp$validate_tape_element
    (    lun: iot$logical_unit;
         tape_density: rmt$density;
     VAR status: ost$status);

    VAR
      element_name: cmt$element_name,
      local_status: ost$status,
      density_valid: boolean,
      unit_type: iot$unit_type;

    status.normal := TRUE;
    element_name := '';

    get_unit_type_via_lun (lun, unit_type, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    density_valid := FALSE;

    IF (unit_type = ioc$dt_mt679_2) OR (unit_type = ioc$dt_mt679_3) OR (unit_type = ioc$dt_mt679_4) THEN
      IF (tape_density = rmc$800) OR (tape_density = rmc$1600) THEN
        density_valid := TRUE;
      IFEND;
    ELSEIF (unit_type = ioc$dt_mt5682_1x) THEN
      IF (tape_density = rmc$38000) THEN
        density_valid := TRUE;
      IFEND;
    ELSE
      IF (tape_density = rmc$1600) OR (tape_density = rmc$6250) THEN
        density_valid := TRUE;
      IFEND;
    IFEND;

    IF NOT density_valid THEN
      cmp$get_element_name_via_lun (lun, element_name, local_status);
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_unit_density_mismatch, element_name,
            status);
    IFEND;

  PROCEND dmp$validate_tape_element;

?? OLDTITLE ??
?? NEWTITLE := '   get_unit_type_via_lun', EJECT ??

{ PURPOSE:
{   This procedure returns the unit type given the logical unit.


  PROCEDURE get_unit_type_via_lun
    (    lun: iot$logical_unit;
     VAR unit_type: iot$unit_type;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      element_name: cmt$element_name,
      tape_unit: boolean;

    status.normal := TRUE;
    element_name := '';

    unit_type := cmv$logical_unit_table^ [lun].unit_interface_table^.unit_type;

    tape_unit := (unit_type <= ioc$highest_tape_unit);

    IF NOT tape_unit THEN
      cmp$get_element_name_via_lun (lun, element_name, local_status);
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcu_illegal_tape_unit_name, element_name,
            status);
    IFEND;

  PROCEND get_unit_type_via_lun;

MODEND dmm$initialize_tape_r3;
*DECK DECK=DMM$INITIALIZE_TAPE_VOL EXPAND=TRUE
*DECK DECK=DMM$INITIALIZE_VOLUME EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOSVE Device Management' ??
MODULE dmm$initialize_volume;
?? PUSH (LISTEXT := ON) ??
?? NEWTITLE := '  Common Decks', EJECT ??
*copyc amt$file_byte_address
*copyc cme$manage_interface_tables
*copyc cmp$get_mass_storage_info
*copyc cmp$lock_lun_entry
*copyc cmv$post_deadstart
*copyc cmp$unlock_lun_entry
*copyc cmt$unit_type
*copyc cmt$logical_unit_attributes
*copyc dmc$cti_device_type_numbers
*copyc dmp$attach_dat_from_label
*copyc dmp$attach_device_file_by_fmd
*copyc dmp$bring_volume_online
*copyc dmp$clear_update_lock
*copyc dmp$close_file
*copyc dmp$construct_sc_dau_list
*copyc dmp$create_fau_entry
*copyc dmp$detach_device_file
*copyc dmp$generate_gfn_hash
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_fmd_by_index
*copyc dmp$get_fau_entry
*copyc dmp$get_number_of_faus
*copyc dmp$locate_volume_label
*copyc dmp$open_file
*copyc dmp$record_sc_flaw
*copyc dmp$set_update_lock
*copyc dmp$take_volume_offline
*copyc gfp$get_fde_p
*copyc dmt$allocation_size
*copyc dmt$chapter_number
*copyc dmt$date
*copyc dmt$device_allocation_unit
*copyc dmt$device_file_list_index
*copyc dmt$device_file_stored_fmd
*copyc dmt$error_condition_codes
*copyc dmt$file_allocation_table
*copyc dmt$file_medium_descriptor
*copyc dmt$global_file_name
*copyc dmt$initialize_status_info
*copyc dmt$log_flaw_init_data
*copyc dmt$logical_device_attributes
*copyc dmt$logical_unit_specification
*copyc dmt$minimum_allocation_unit
*copyc dmt$ms_device_allocation_table
*copyc dmt$ms_device_file_list_entry
*copyc dmt$ms_flaw_list
*copyc dmt$ms_logical_device_address
*copyc dmt$ms_login_table
*copyc dmt$ms_physical_characteristics
*copyc dmt$ms_volume_directory
*copyc dmt$ms_volume_label
*copyc dmt$physical_device_attributes
*copyc dmt$stored_ms_fmd_header
*copyc dmt$time
*copyc dmt$volume_label_attributes
*copyc dmv$active_volume_table
*copyc dmv$p_sc_flaw_commands
*copyc dsp$access_deadstart_sector
*copyc dst$deadstart_sector
*copyc dsv$mainframe_type
*copyc gft$file_desc_entry_p
*copyc gft$system_file_identifier
*copyc i#call_monitor
*copyc iop$mass_storage_io
*copyc iop$initialize_sectors
*copyc iot$io_function
*copyc iot$logical_unit
*copyc mmp$free_pages
*copyc mmp$write_modified_pages
*copyc osd$virtual_address
*copyc osp$initialize_sig_lock
*copyc osp$generate_unique_binary_name
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osp$unpack_status_condition
*copyc ost$name
*copyc ost$status
*copyc ost$user_identification
*copyc osv$mainframe_wired_heap
*copyc osv$page_size
*copyc pmp$get_system_time
*copyc pmp$zero_out_table
*copyc pmt$system_time
*copyc rmd$volume_declarations
*copyc syp$continue_to_cause
*copyc syp$disestablish_cond_handler
*copyc syp$display_deadstart_message
*copyc syp$establish_condition_handler
*copyc syp$trace_deadstart_message
?? POP ??
?? TITLE := '  Static and Global Variables', EJECT ??
*copyc dmv$active_volume_table

  TYPE
    cylinder_range_type = record
      lowest_cylinder: dmt$device_position,
      highest_cylinder: dmt$device_position,
    recend,

    flawed_dau = record
      dau_address: dmt$dau_address,
      kind_of_flaw: dmt$dau_status,
    recend,

    dau_mapping = set of dmt$daus_per_position,

    dmt$hps_unit_type = cmc$ms5832_1 .. cmc$ms47444_4,
    dmt$hps_unit_types = set of dmt$hps_unit_type;


  VAR
    dat_user_supplied_name: [STATIC] ost$name := 'DAT',
    dat_global_file_name: dmt$global_file_name,
    dat_dfle: dmt$ms_device_file_list_entry,
    dat_stored_df_fmd: dmt$device_file_stored_fmd,

    dflt_user_supplied_name: [STATIC] ost$name := 'DFLT',
    dflt_global_file_name: dmt$global_file_name,
    dflt_stored_df_fmd: dmt$device_file_stored_fmd,
    dflt_dfle: dmt$ms_device_file_list_entry,

    login_table_user_supplied_name: [STATIC] ost$name := 'LOGIN_TABLE',
    login_table_global_file_name: dmt$global_file_name,
    login_table_stored_df_fmd: dmt$device_file_stored_fmd,

    directory_dfle: dmt$ms_device_file_list_entry,
    directory_stored_df_fmd: dmt$device_file_stored_fmd,

    bytes_per_mau: [STATIC] dmt$bytes_per_mau,
    cylinders_per_device: [STATIC] dmt$device_position,
    daus_per_cylinder: [STATIC] dmt$daus_per_position,
    daus_per_device: [STATIC] dmt$dau_address,
    daus_per_allocation_style: [STATIC] array [dmt$allocation_styles] of dmt$daus_per_position,
    cm3_unit_type: [STATIC] set of cmt$unit_type := [cmc$msfsd2_s0, cmc$msxmd_3],
    hps_unit_type: [STATIC] dmt$hps_unit_types := -$dmt$hps_unit_types[],
    maus_per_cylinder: [STATIC] dmt$maus_per_position,
    maus_per_dau: [STATIC] dmt$maus_per_dau,
    p_usable_daus: ^array [0 .. *] of dau_mapping,
    p_existing_flaws: [STATIC] ^array [*] of flawed_dau := NIL,
    recorded_vsn: rmt$recorded_vsn,
    sectors_per_track: [STATIC] iot$sectors_per_track,
    sectors_per_mau: [STATIC] iot$sectors_per_mau;

?? TITLE := 'dmp$initialize_ms_volume', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copy dmh$initialize_ms_volume
?? POP ??
  PROCEDURE [XDCL, #GATE] dmp$initialize_ms_volume (access_code: ost$name;
        owner_id: ost$user_identification;
        unit_type: cmt$unit_type;
        p_physical_attributes: ^dmt$physical_device_attributes;
        p_logical_attributes: ^dmt$logical_device_attributes;
        p_volume_label_attributes: ^dmt$volume_label_attributes;
        logical_unit_number: iot$logical_unit;
        allowed_to_overwrite_volume: boolean;
        retain_device_flaws: boolean;
    VAR initialize_status_info: dmt$initialize_status_info;
    VAR status: ost$status);

    VAR
      able: boolean,
      able_to_retain_flaws: boolean,
      applicable_flaw_count: integer,
      avt_index: dmt$active_volume_table_index,
      index: integer,
      initialize_status: ost$status,
      label_found: boolean,
      p_label_header: ^dmt$volume_label_header,
      p_sc_dau_list: ^array [1 .. *] of dmt$log_flaw_init_data,
      p_volume_label: ^dmt$ms_volume_label;

    status.normal := TRUE;
    recorded_vsn := '  ';
    initialize_status_info.recorded_vsn := ' ';
    cylinders_per_device := dmc$min_device_position;
    maus_per_cylinder := dmc$min_maus_position;
    bytes_per_mau := dmc$max_bytes_per_mau;
    maus_per_dau := dmc$min_maus_per_dau;
    sectors_per_track := dmc$default_sectors_per_track;
    sectors_per_mau := dmc$default_sectors_per_mau;

    IF p_physical_attributes <> NIL THEN
      FOR index := LOWERBOUND (p_physical_attributes^) TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF
        = dmc$bytes_per_mau =
          bytes_per_mau := p_physical_attributes^ [index].bytes_per_mau;
        = dmc$cylinders_per_device =
          cylinders_per_device := p_physical_attributes^ [index].cylinders_per_device;
        = dmc$maus_per_cylinder =
          maus_per_cylinder := p_physical_attributes^ [index].maus_per_cylinder;
        = dmc$maus_per_dau =
          maus_per_dau := p_physical_attributes^ [index].maus_per_dau;
        = dmc$sectors_per_track =
          sectors_per_track := p_physical_attributes^ [index].sectors_per_track;
        = dmc$sectors_per_mau =
          sectors_per_mau := p_physical_attributes^ [index].sectors_per_mau;
        ELSE
        CASEND;
      FOREND;
    IFEND;
{
{         logically lock the logical unit table
{
    cmp$lock_lun_entry (logical_unit_number, able);
    IF NOT able THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_lock_lun_entry,
        'unable to lock lun entry - dmp$initialize_ms_volume', status);
      RETURN;
    IFEND;

  /logical_unit_entry_locked/
    BEGIN
      avt_index := 0;
      dmp$bring_volume_online (logical_unit_number, avt_index, status);
      IF NOT status.normal THEN
        EXIT /logical_unit_entry_locked/;
      IFEND;

      PUSH p_volume_label: [[REP dmc$max_volume_label_size OF cell]];
      RESET p_volume_label;

      dmp$locate_volume_label (logical_unit_number, p_physical_attributes, p_volume_label^, label_found);
      IF label_found THEN
        RESET p_volume_label;
        NEXT p_label_header IN p_volume_label;
      IFEND;

    /volume_online/
      BEGIN
        IF NOT allowed_to_overwrite_volume THEN
          IF label_found THEN
            RESET p_volume_label;
            validate_volume_label (access_code, owner_id, p_volume_label^, initialize_status_info, status);
            IF NOT status.normal THEN
              EXIT /volume_online/;
            IFEND;
          IFEND;
        IFEND;

        able_to_retain_flaws := TRUE;
        IF retain_device_flaws AND label_found THEN
          dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn := p_label_header^.recorded_vsn;
          remember_device_flaws (p_volume_label^, cylinders_per_device, avt_index, p_existing_flaws,
                                 able_to_retain_flaws);
          dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn := '      ';
          IF (NOT able_to_retain_flaws) AND (NOT cmv$post_deadstart) THEN
            syp$trace_deadstart_message ('...device initialization continuing');
          IFEND;
        ELSEIF retain_device_flaws AND (NOT label_found) AND (NOT cmv$post_deadstart) THEN
          syp$trace_deadstart_message ('unable to retain device flaws (cannot find volume label)');
          syp$trace_deadstart_message ('...device initialization continuing');
        IFEND;

        IF (unit_type = cmc$ms895_2) AND
           ((NOT able_to_retain_flaws) OR (NOT label_found) OR (NOT retain_device_flaws)) THEN
          soft_sector_895 (logical_unit_number, cylinders_per_device, status);
          IF NOT status.normal THEN
            EXIT /volume_online/;
          IFEND;
        IFEND;

        IF unit_type IN cm3_unit_type THEN
          format_cm3_device (logical_unit_number, retain_device_flaws, status);
          IF NOT status.normal THEN
            EXIT /volume_online/;
          IFEND;
        IFEND;

        IF unit_type IN hps_unit_type THEN
          soft_sector_583x (logical_unit_number, retain_device_flaws, status);
          IF NOT status.normal THEN
            EXIT /volume_online/;
          IFEND;
        IFEND;

        create_new_volume_label (p_volume_label_attributes, p_physical_attributes, p_logical_attributes,
              logical_unit_number, avt_index, status);

{ The following call to dmp$construct_sc_dau_list is here to mark the flaw commands as processed.  IF the
{ status returned by create_new_volume_label is not normal, there is a possiblility for the operator to
{ enter the initialize command again and the flaw commands would be lost if they were marked as processed
{ before this check.

        IF status.normal THEN
          IF dmv$p_sc_flaw_commands <> NIL THEN
            PUSH p_sc_dau_list: [1 .. UPPERBOUND (dmv$p_sc_flaw_commands^)];
            dmp$construct_sc_dau_list (dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn,
                FALSE, p_sc_dau_list, applicable_flaw_count, status);
          IFEND;
        IFEND;

      END /volume_online/;

      dmp$take_volume_offline (logical_unit_number, initialize_status);
      IF NOT initialize_status.normal AND status.normal THEN
        status := initialize_status;
      IFEND;

    END /logical_unit_entry_locked/;

    cmp$unlock_lun_entry (logical_unit_number, able);
    IF (NOT able) AND status.normal THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_release_lun_lock,
        'unable to release lun lock - dmp$initialize_ms_volume', status);
    IFEND;
  PROCEND dmp$initialize_ms_volume;
  ?? TITLE := 'dmp$process_force_format', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$process_force_format (logical_unit_number: iot$logical_unit;
        force_format: boolean;
    VAR status: ost$status);

  VAR
    able: boolean;

{ Logically lock the logical unit table.
    cmp$lock_lun_entry (logical_unit_number, able);
    IF NOT able THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_lock_lun_entry,
            'unable to lock lun entry - dmp$format_reinstated_parity_unit', status);
      RETURN;
    IFEND;
    send_force_format_command (logical_unit_number, force_format, status);
{ Unlock the logical unit table.
    cmp$unlock_lun_entry (logical_unit_number, able);
    IF (NOT able) AND status.normal THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_release_lun_lock,
        'unable to release lun lock - dmp$format_reinstated_parity_unit', status);
      RETURN;
    IFEND;
  PROCEND dmp$process_force_format;
  ?? TITLE := 'soft_sector_895', EJECT ??

  PROCEDURE soft_sector_895 (logical_unit_number: iot$logical_unit;
                             cylinders_per_device: dmt$device_position;
                         VAR status: ost$status);

  VAR
    cip_found: boolean,
    cip_cylinder: dmt$device_position,
    cylinders_to_initialize: ^array [ * ] of iot$cylinders_to_initialize;

    status.normal := TRUE;

    IF NOT cmv$post_deadstart THEN
      syp$trace_deadstart_message ('soft-sectoring volume');
    IFEND;
    find_cip_cylinder (logical_unit_number, cip_cylinder, cip_found);

    PUSH cylinders_to_initialize: [1..1];
    cylinders_to_initialize^ [1].start_cylinder := 0;
    IF cip_found THEN { format up to but not including first CIP cylinder }
      cylinders_to_initialize^ [1].end_cylinder := cip_cylinder - 1;
    ELSE
      cylinders_to_initialize^ [1].end_cylinder := cylinders_per_device - 4;
      {Do not format cylinders 883 - 885.}
    IFEND;

    iop$initialize_sectors (logical_unit_number, cylinders_to_initialize^, status);
    IF status.normal AND (NOT cmv$post_deadstart) THEN
      syp$trace_deadstart_message ('soft-sectoring of volume complete');
    IFEND;
  PROCEND soft_sector_895;
  ?? TITLE := 'format_cm3_device', EJECT ??

  PROCEDURE format_cm3_device (logical_unit_number: iot$logical_unit;
                              retain_device_flaws: boolean;
                          VAR status: ost$status);

  VAR
    cylinders_to_initialize: array [1..1] of iot$cylinders_to_initialize;

    status.normal := TRUE;

    IF NOT cmv$post_deadstart THEN
      syp$trace_deadstart_message ('checking format of volume');
    IFEND;

{
{ Formatting of the device is dependent on the value of retain_device_flaws.
{ If retain_device_flaws is true, a value of 0 is passed to IO and it will
{ decide whether formatting is necessary or not; if false, a value of 1 is
{ passed to IO, a value > than 0 will cause IO to unconditionally format
{ the device.
{

    IF retain_device_flaws THEN
      cylinders_to_initialize [1].start_cylinder := 0;
    ELSE
      cylinders_to_initialize [1].start_cylinder := 1;
    IFEND;

    iop$initialize_sectors (logical_unit_number, cylinders_to_initialize, status);
    IF status.normal AND (NOT cmv$post_deadstart) THEN
      syp$trace_deadstart_message ('volume formatted');
    IFEND;
  PROCEND format_cm3_device;
  ?? TITLE := 'soft_sector_583x', EJECT ??

  PROCEDURE soft_sector_583x (logical_unit_number: iot$logical_unit;
                              retain_device_flaws: boolean;
                          VAR status: ost$status);

{
{ The 5832, 5833, and 5838 (SSD, SABRE, ELITE 2, and IBM35 ) devices do not support CIP
{

  VAR
    cylinders_to_initialize: array [1..1] of iot$cylinders_to_initialize;

    status.normal := TRUE;

    IF NOT cmv$post_deadstart THEN
      syp$trace_deadstart_message ('checking format of volume');
    IFEND;

{
{ Formatting of the device is dependent on the value of retain_device_flaws.
{ If retain_device_flaws is true, a value of 0 is passed to IO and it will
{ decide whether formatting is necessary or not; if false, a value of 1 is
{ passed to IO, a value > than 0 will cause IO to unconditionally format
{ the device.
{

    IF retain_device_flaws THEN
      cylinders_to_initialize [1].start_cylinder := 0;
    ELSE
      cylinders_to_initialize [1].start_cylinder := 1;
    IFEND;

    iop$initialize_sectors (logical_unit_number, cylinders_to_initialize, status);
    IF status.normal AND (NOT cmv$post_deadstart) THEN
      syp$trace_deadstart_message ('volume formatted');
    IFEND;
  PROCEND soft_sector_583x;
  ?? TITLE := 'send_force_format_command', EJECT ??

  PROCEDURE send_force_format_command (logical_unit_number: iot$logical_unit;
                              force_format: boolean;
                          VAR status: ost$status);

  VAR
    cylinders_to_initialize: array [1..1] of iot$cylinders_to_initialize;

    status.normal := TRUE;

{
{ This procedure uses the iop$initialize_sectors command to inform the
{ io driver to set or clear the 'force_format' bit located in the unit
{ interface table. A value of 2 will cause the driver to clear the bit
{ and a value of 3 will cause the driver to set the bit. Values of 0 and
{ 1 are reserved for use by the 'soft_sector_583x' procedure.
{

    IF force_format THEN
      cylinders_to_initialize [1].start_cylinder := 3; {set force_format bit}
    ELSE
      cylinders_to_initialize [1].start_cylinder := 2; {clear force_format bit}
    IFEND;

    iop$initialize_sectors (logical_unit_number, cylinders_to_initialize, status);

  PROCEND send_force_format_command;
  ?? TITLE := 'dmp$process_das_restore', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$process_das_restore (logical_unit_number: iot$logical_unit;
    VAR status: ost$status);

  VAR
    able: boolean;

{ Logically lock the logical unit table.
    cmp$lock_lun_entry (logical_unit_number, able);
    IF NOT able THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_lock_lun_entry,
            'unable to lock lun entry - dmp$format_reinstated_parity_unit', status);
      RETURN;
    IFEND;
    send_das_restore_command (logical_unit_number, status);
{ Unlock the logical unit table.
    cmp$unlock_lun_entry (logical_unit_number, able);
    IF (NOT able) AND status.normal THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_release_lun_lock,
        'unable to release lun lock - dmp$format_reinstated_parity_unit', status);
      RETURN;
    IFEND;
  PROCEND dmp$process_das_restore;
  ?? TITLE := 'send_das_restore_command', EJECT ??

  PROCEDURE send_das_restore_command (logical_unit_number: iot$logical_unit;
                          VAR status: ost$status);

  VAR
    cylinders_to_initialize: array [1..1] of iot$cylinders_to_initialize;

    status.normal := TRUE;

{
{ This procedure uses the iop$initialize_sectors command to inform the
{ io driver to run the confidence test on the specified unit. This is
{ used to provide a means of manually starting a resore operation on the
{ ibm 3.5" das drive because this drive type does not notify the driver
{ when it is powered up. A value of 5 is sent to enable running ct.
{

    cylinders_to_initialize [1].start_cylinder := 5; {run confidence test}

    iop$initialize_sectors (logical_unit_number, cylinders_to_initialize, status);

  PROCEND send_das_restore_command;
  ?? TITLE := 'validate_volume_label', EJECT ??

  PROCEDURE validate_volume_label (access_code: ost$name;
        owner_id: ost$user_identification;
        volume_label: dmt$ms_volume_label;
    VAR initialize_status_info: dmt$initialize_status_info;
    VAR status: ost$status);

    status.normal := TRUE;

    verify_label_expiration_date (volume_label, initialize_status_info, status);
    IF status.normal THEN
      verify_volume_access_code (access_code, volume_label, initialize_status_info, status);
      IF status.normal THEN
        verify_volume_owner (owner_id, volume_label, initialize_status_info, status);
      IFEND;
    IFEND;
  PROCEND validate_volume_label;
  ?? TITLE := 'verify_label_expiration_date', EJECT ??

  PROCEDURE verify_label_expiration_date (volume_label: dmt$ms_volume_label;
    VAR initialize_status_info: dmt$initialize_status_info;
    VAR status: ost$status);

    VAR
      p_volume_label: ^dmt$ms_volume_label,
      p_volume_label_header: ^dmt$volume_label_header,
      current_date: pmt$system_time,
      label_expiration_date: dmt$date;

    status.normal := TRUE;

    p_volume_label := ^volume_label;

    RESET p_volume_label;
    NEXT p_volume_label_header IN p_volume_label;

    label_expiration_date := p_volume_label_header^.expiration_date;

    pmp$get_system_time (current_date, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF current_date.year > label_expiration_date.year THEN
      RETURN;
    IFEND;

    IF current_date.year = label_expiration_date.year THEN
      IF current_date.month > label_expiration_date.month THEN
        RETURN;
      IFEND;
      IF current_date.month = label_expiration_date.month THEN
        IF current_date.day > label_expiration_date.day THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    osp$set_status_abnormal (dmc$device_manager_ident, dme$vol_label_date_not_expired,
      'volume label not expired - verify_label_expiration_date', status);

    initialize_status_info.recorded_vsn := p_volume_label_header^.recorded_vsn;
    initialize_status_info.key := dme$vol_label_date_not_expired;
    initialize_status_info.label_expiration_date := label_expiration_date;

  PROCEND verify_label_expiration_date;
  ?? TITLE := 'verify_volume_access_code', EJECT ??

  PROCEDURE verify_volume_access_code (user_access_code: ost$name;
        volume_label: dmt$ms_volume_label;
    VAR initialize_status_info: dmt$initialize_status_info;
    VAR status: ost$status);

    VAR
      p_volume_label: ^dmt$ms_volume_label,
      p_volume_label_header: ^dmt$volume_label_header,
      p_volume_label_0_0: ^dmt$ms_label_0_0,
      volume_label_access_code: ost$name;

    status.normal := TRUE;

    p_volume_label := ^volume_label;

    RESET p_volume_label;
    NEXT p_volume_label_header IN p_volume_label;

    CASE p_volume_label_header^.version_number OF
    = dmc$ms_label_0_0 =
      NEXT p_volume_label_0_0 IN p_volume_label;
      volume_label_access_code := p_volume_label_0_0^.access_code;
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unsupported_label_version,
        'label version number not supported - verify_volume_access_code', status);

      initialize_status_info.recorded_vsn := p_volume_label_header^.recorded_vsn;
      initialize_status_info.key := dme$unsupported_label_version;

      RETURN;
    CASEND;

    IF user_access_code <> volume_label_access_code THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_volume_access_code,
        'invalid volume access code - verify_volume_access_code', status);

      initialize_status_info.recorded_vsn := p_volume_label_header^.recorded_vsn;
      initialize_status_info.key := dme$invalid_volume_access_code;
      initialize_status_info.access_code := volume_label_access_code;

    IFEND;

  PROCEND verify_volume_access_code;
  ?? TITLE := 'verify_volume_owner', EJECT ??

  PROCEDURE verify_volume_owner (requesting_owner_id: ost$user_identification;
        volume_label: dmt$ms_volume_label;
    VAR initialize_status_info: dmt$initialize_status_info;
    VAR status: ost$status);

    VAR
      p_volume_label: ^dmt$ms_volume_label,
      p_volume_label_header: ^dmt$volume_label_header,
      p_volume_label_0_0: ^dmt$ms_label_0_0,
      label_owner_id: ost$user_identification;

    status.normal := TRUE;

    p_volume_label := ^volume_label;

    RESET p_volume_label;
    NEXT p_volume_label_header IN p_volume_label;

    CASE p_volume_label_header^.version_number OF
    = dmc$ms_label_0_0 =
      NEXT p_volume_label_0_0 IN p_volume_label;
      label_owner_id := p_volume_label_0_0^.owner_id;
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unsupported_label_version,
        'label version not supported - verify_volume_owner', status);

      initialize_status_info.recorded_vsn := p_volume_label_header^.recorded_vsn;
      initialize_status_info.key := dme$unsupported_label_version;

      RETURN;
    CASEND;

    IF label_owner_id <> requesting_owner_id THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_vol_owner_specified,
        'illegal volume owner id - verify_volume_owner', status);

      initialize_status_info.recorded_vsn := p_volume_label_header^.recorded_vsn;
      initialize_status_info.key := dme$invalid_vol_owner_specified;
      initialize_status_info.label_owner_id := label_owner_id;

    IFEND;
  PROCEND verify_volume_owner;
  ?? TITLE := 'create_new_volume_label', EJECT ??

  PROCEDURE create_new_volume_label (p_volume_label_attributes: ^dmt$volume_label_attributes;
        p_physical_attributes: ^dmt$physical_device_attributes;
        p_logical_attributes: ^dmt$logical_device_attributes;
        logical_unit_number: iot$logical_unit;
        avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      access_code: ost$name,
      current_date: pmt$system_time,
      dat_sfid: gft$system_file_identifier,
      daus_per_alloc: dmt$dau_address,
      default_owner_id: [STATIC] ost$user_identification := ['$SYSTEM', '$SYSTEM'],
      dfl_sfid: gft$system_file_identifier,
      directory_sfid: gft$system_file_identifier,
      expiration_days: dmt$label_expiration_days,
      expiration_years: 0 .. 4095,
      expiration_months: 0 .. 12,
      file_already_attached: boolean,
      index: integer,
      internal_vsn: dmt$internal_vsn,
      label_allocation_size: dmt$bytes_per_allocation,
      label_body_0_0: dmt$ms_label_0_0,
      label_cylinder_range: cylinder_range_type,
      label_dfle: dmt$ms_device_file_list_entry,
      label_file_hash: dmt$file_hash,
      label_global_file_name: dmt$global_file_name,
      label_sfid: dmt$system_file_id,
      label_size: amt$file_byte_address,
      label_stored_df_fmd: dmt$device_file_stored_fmd,
      label_transfer_size: dmt$transfer_size,
      label_user_supplied_name: [STATIC] ost$name := 'LABEL',
      label_version_number: dmt$ms_label_version_number,
      local_status: ost$status,
      number_of_faus: dmt$fau_entries,
      owner_id: ost$user_identification,
      p_dat: ^dmt$ms_device_allocation_table,
      p_dat_fmd: ^dmt$file_medium_descriptor,
      p_device_allocation_table_fat: ^dmt$stored_ms_device_file_fat,
      p_dfd: ^dmt$disk_file_descriptor,
      p_dfl: ^dmt$ms_device_file_list_table,
      p_directory: ^dmt$ms_volume_directory,
      p_fau_entry: ^dmt$file_allocation_unit,
      p_fde: gft$file_desc_entry_p,
      p_file_attributes: ^array [ * ] of dmt$file_attribute,
      p_fmd_attributes: ^array [1 .. * ] of dmt$fmd_attribute,
      p_label_body_0_0: ^dmt$ms_label_0_0,
      p_label_fmd: ^dmt$file_medium_descriptor,
      p_label_header: ^dmt$volume_label_header,
      p_stored_df_fat: ^dmt$stored_ms_device_file_fat,
      p_volume_label: ^dmt$ms_volume_label,
      recorded_vsn: rmt$recorded_vsn,
      variant_size: amt$file_byte_address,
      volume_label_header: dmt$volume_label_header;

    status.normal := TRUE;

  /build_label/
    BEGIN
      access_code := dmc$default_vol_access_code;
      owner_id := default_owner_id;
      expiration_years := dmc$default_vol_exp_years;
      expiration_months := dmc$default_vol_exp_months;
      expiration_days := dmc$default_vol_exp_days;
      recorded_vsn := '    ';
      label_version_number := dmc$ms_label_0_0;
      label_cylinder_range.lowest_cylinder := 0;
      label_cylinder_range.highest_cylinder := 0;
      label_allocation_size := dmc$default_label_alloc_size;
      label_transfer_size := dmc$default_label_transfer_size;

      IF p_volume_label_attributes <> NIL THEN
        FOR index := LOWERBOUND (p_volume_label_attributes^) TO UPPERBOUND (p_volume_label_attributes^) DO
          CASE p_volume_label_attributes^ [index].keyword OF
          = dmc$label_access_code =
            access_code := p_volume_label_attributes^ [index].access_code;
          = dmc$label_expiration_days =
            expiration_days := p_volume_label_attributes^ [index].expiration_days;
          = dmc$label_owner_id =
            owner_id := p_volume_label_attributes^ [index].owner_id;
          = dmc$label_recorded_vsn =
            recorded_vsn := p_volume_label_attributes^ [index].recorded_vsn;
          ELSE
          CASEND;
        FOREND;
      IFEND;

      preset_cylinder_0 (logical_unit_number, maus_per_cylinder);

      label_user_supplied_name (6, rmc$recorded_vsn_size) := recorded_vsn;

      volume_label_header.version_number := label_version_number;

      volume_label_header.label_type := 'nosve   ';

      pmp$get_system_time (current_date, status);
      IF NOT status.normal THEN
        EXIT /build_label/;
      IFEND;

      volume_label_header.creation_date.year := current_date.year;
      volume_label_header.creation_date.month := current_date.month;
      volume_label_header.creation_date.day := current_date.day;

      expiration_years := expiration_days DIV 365;
      expiration_days := expiration_days - (expiration_years * 365);
      expiration_months := expiration_days DIV 30;
      expiration_days := expiration_days - (expiration_months * 30);
      volume_label_header.expiration_date.year := current_date.year + expiration_years;
      volume_label_header.expiration_date.month := expiration_months;
      volume_label_header.expiration_date.day := expiration_days;

      volume_label_header.bytes_per_dau := maus_per_dau * bytes_per_mau;
      volume_label_header.bytes_per_mau := bytes_per_mau;
      volume_label_header.positions_per_device := cylinders_per_device;
      volume_label_header.recorded_vsn := recorded_vsn;

      osp$generate_unique_binary_name (internal_vsn, status);
      IF NOT status.normal THEN
        EXIT /build_label/;
      IFEND;
      volume_label_header.internal_vsn := internal_vsn;

{         Initialize deadstart files to empty
      volume_label_header.primary_deadstart_file := 0;
      volume_label_header.secondary_deadstart_file := 0;
      volume_label_header.image_file := 0;
      volume_label_header.spare_file := 0;

      CASE label_version_number OF
      = dmc$ms_label_0_0 =
        variant_size := #SIZE (label_body_0_0);
        label_body_0_0.access_code := access_code;
        label_body_0_0.owner_id := owner_id;
        label_body_0_0.class := -$dmt$class [];

      /build_vol_device_files/
        BEGIN
{
{               create device allocation table
{
          PUSH p_usable_daus: [0 .. cylinders_per_device - 1];
          build_device_allocation_table (logical_unit_number, avt_index, recorded_vsn, internal_vsn,
                dmc$dat_0_0, p_logical_attributes, p_physical_attributes, dat_sfid, p_dat, status);
          IF NOT status.normal THEN
            EXIT /build_label/;
          IFEND;

        /dat_created/
          BEGIN
            label_body_0_0.device_allocation_table_fmd := dat_stored_df_fmd;
            label_body_0_0.dat_dfl_entry := dat_dfle;
{
{             create device file list table
{
            build_device_file_list (avt_index, recorded_vsn, internal_vsn, dmc$dflt_0_0,
                  p_logical_attributes, p_dat, dfl_sfid, p_dfl, status);
            IF NOT status.normal THEN
              EXIT /dat_created/;
            IFEND;

          /dfl_created/
            BEGIN
              label_body_0_0.device_file_list_fmd := dflt_stored_df_fmd;
              label_body_0_0.device_file_list_dfl_entry := dflt_dfle;
              {
              { create login table
              {
              build_login_table (avt_index, recorded_vsn, internal_vsn, p_dat, p_dfl, status);
              IF NOT status.normal THEN
                EXIT /dfl_created/;
              IFEND;

            /login_table_created/
              BEGIN
{
{             create volume directory
{
                build_volume_directory (avt_index, recorded_vsn, internal_vsn, p_logical_attributes,
                      p_dat, p_dfl, directory_sfid, p_directory, status);
                IF NOT status.normal THEN
                  EXIT /login_table_created/;
                IFEND;

              /directory_created/
                BEGIN
                  label_body_0_0.directory_fmd := directory_stored_df_fmd;
                  label_body_0_0.directory_dfl_entry := directory_dfle;
{
{             create stored device file fats
{
                  gfp$get_fde_p (dat_sfid, p_fde);
                  dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
                  dmp$get_number_of_faus (p_dfd, number_of_faus);
                  PUSH p_device_allocation_table_fat: [1 .. number_of_faus];
                  variant_size := variant_size + #SIZE (p_device_allocation_table_fat^);
                  dmp$get_fmd_by_index (p_dfd, 1, p_dat_fmd);
                  build_stored_df_fat (p_fde, p_dfd, p_dat_fmd,  p_device_allocation_table_fat, status);

                  IF status.normal THEN {leave files attached}
                    EXIT /build_vol_device_files/;
                  IFEND;

                END /directory_created/;
                detach_file (p_directory, directory_sfid, local_status);

              END /login_table_created/;

            END /dfl_created/;
            detach_file (p_dfl, dfl_sfid, local_status);

          END /dat_created/;
          detach_file (p_dat, dat_sfid, local_status);

          EXIT /build_label/;
        END /build_vol_device_files/;
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unsupported_label_version,
          'label version not supported - DMMIVOL', status);
        EXIT /build_label/;
      CASEND;

    /volume_device_files_created/
      BEGIN
        label_size := #SIZE (dmt$volume_label_header) + variant_size;

        PUSH p_volume_label: [[REP label_size OF cell]];
        RESET p_volume_label;

        NEXT p_label_header IN p_volume_label;

        p_label_header^ := volume_label_header;

        CASE label_version_number OF
        = dmc$ms_label_0_0 =
          NEXT p_label_body_0_0 IN p_volume_label;
          p_label_body_0_0^ := label_body_0_0;
          NEXT p_stored_df_fat: [1 .. UPPERBOUND (p_device_allocation_table_fat^.file_allocation_units)] IN
                p_volume_label;
          p_stored_df_fat^ := p_device_allocation_table_fat^;
        CASEND;

        label_global_file_name := internal_vsn;

        dmp$generate_gfn_hash (label_global_file_name, label_file_hash);

        PUSH p_file_attributes: [1 .. 12];

        p_file_attributes^ [1].keyword := dmc$file_kind;
        p_file_attributes^ [1].file_kind := gfc$fk_device_file;
        p_file_attributes^ [2].keyword := dmc$overflow;
        p_file_attributes^ [2].overflow_allowed := FALSE;
        p_file_attributes^ [3].keyword := dmc$requested_allocation_size;
        p_file_attributes^ [3].requested_allocation_size := label_allocation_size;
        p_file_attributes^ [4].keyword := dmc$requested_transfer_size;
        p_file_attributes^ [4].requested_transfer_size := label_transfer_size;
        p_file_attributes^ [5].keyword := dmc$requested_volume;
        p_file_attributes^ [5].requested_volume.recorded_vsn := recorded_vsn;
        p_file_attributes^ [5].requested_volume.setname := '    ';
        p_file_attributes^ [6].keyword := dmc$clear_space;
        p_file_attributes^ [6].required := TRUE;
        p_file_attributes^ [7].keyword := dmc$preset_value;
        p_file_attributes^ [7].preset_value := 0;
        p_file_attributes^ [8].keyword := dmc$locked_file;
        p_file_attributes^ [8].file_lock.required := FALSE;
        p_file_attributes^ [9].keyword := dmc$file_limit;
        p_file_attributes^ [9].limit := ((label_size + label_allocation_size - 1) DIV label_allocation_size) *
              label_allocation_size;
        p_file_attributes^ [10].keyword := dmc$file_hash;
        p_file_attributes^ [10].file_hash := label_file_hash;
        p_file_attributes^ [11].keyword := dmc$class;
        p_file_attributes^ [11].class := dmc$default_class;
        p_file_attributes^ [12].keyword := dmc$class_ordinal;
        p_file_attributes^ [12].ordinal := dmc$default_class_ordinal;

        build_stored_df_fmd_header (p_file_attributes, label_stored_df_fmd, status);
        IF NOT status.normal THEN
          EXIT /volume_device_files_created/;
        IFEND;

        PUSH p_fmd_attributes: [1 .. 3];

        p_fmd_attributes^ [1].keyword := dmc$recorded_vsn;
        p_fmd_attributes^ [1].recorded_vsn := recorded_vsn;
        p_fmd_attributes^ [2].keyword := dmc$internal_vsn;
        p_fmd_attributes^ [2].internal_vsn := internal_vsn;
        p_fmd_attributes^ [3].keyword := dmc$device_file_list_index;
        p_fmd_attributes^ [3].device_file_list_index := dmc$label_dfl_index;

        build_stored_df_fmd_subfile (p_fmd_attributes, label_stored_df_fmd, status);
        IF NOT status.normal THEN
          EXIT /volume_device_files_created/;
        IFEND;

        dmp$attach_device_file_by_fmd (label_global_file_name, label_stored_df_fmd, file_already_attached,
              label_sfid, status);
        IF NOT status.normal THEN
          EXIT /volume_device_files_created/;
        IFEND;
        IF file_already_attached THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$duplicate_device_file_gfn,
            'label gfn already attached', status);
          EXIT /volume_device_files_created/;
        IFEND;

        gfp$get_fde_p (label_sfid, p_fde);
        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
        dmp$get_fmd_by_index (p_dfd, 1, p_label_fmd);

        p_label_fmd^.fmd_allocated_length := ((label_size + label_allocation_size) DIV
              label_allocation_size) * label_allocation_size;
        p_label_fmd^.avt_index := avt_index;

        daus_per_alloc := dmc$default_label_alloc_size DIV bytes_per_mau DIV maus_per_dau;

      /allocate_label_and_write_it/
        WHILE TRUE DO

          build_faus (label_cylinder_range, label_size, label_allocation_size, label_transfer_size,
                label_sfid, status);
          dmp$get_fau_entry (p_dfd, 0, p_fau_entry);
          IF NOT status.normal OR ((p_fau_entry^.dau_address DIV daus_per_alloc) > dmc$max_label_aus) THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$no_contig_space_for_label,
              'no contiguous daus for label', status);
            EXIT /volume_device_files_created/;
          IFEND;

          write_label_to_disk (logical_unit_number, p_label_fmd, p_dfd, p_fau_entry, p_volume_label,
             label_size, status);
          IF status.normal THEN
            EXIT /allocate_label_and_write_it/;
          IFEND;

          free_faus_flaw_daus (p_dat, p_dfd);

        WHILEND /allocate_label_and_write_it/;

        {
        { update dat to reflect allocation of label daus
        {
        update_dat_entries (p_dat, dmc$label_dfl_index, p_dfd, avt_index);

        {
        { create label dfle
        {

        label_dfle.pad := 0;
        label_dfle.flags := dmc$dfle_assigned_to_file;
        label_dfle.daus_per_allocation_unit := p_label_fmd^.daus_per_allocation_unit;
        label_dfle.dau_chain_status := dmc$dau_chain_linked;
        label_dfle.end_of_file := ((label_size + osv$page_size - 1) DIV osv$page_size) * osv$page_size;
        label_dfle.end_of_information := ((label_size + osv$page_size - 1) DIV osv$page_size) * osv$page_size;
        label_dfle.file_byte_address := 0;
        label_dfle.file_hash := label_sfid.file_hash;
        label_dfle.file_kind := gfc$fk_device_file;
        label_dfle.first_dau_address := p_fau_entry^.dau_address;
        label_dfle.global_file_name := label_global_file_name;
        label_dfle.logical_length := ((label_size + osv$page_size - 1) DIV osv$page_size) * osv$page_size;
        label_dfle.fmd_length := ((label_size + label_allocation_size - 1) DIV label_allocation_size) *
              label_allocation_size;
        label_dfle.login_set := $dmt$dfl_login_set [];

{         update dfl to reflect label dfle.

        p_dfl^.entries [dmc$label_dfl_index] := label_dfle;

{         create directory entry for label

        p_directory^.entries [dmc$label_directory_index].global_file_name := label_global_file_name;
        p_directory^.entries [dmc$label_directory_index].user_supplied_name := label_user_supplied_name;
        p_directory^.entries [dmc$label_directory_index].stored_df_fmd := label_stored_df_fmd;

      END /volume_device_files_created/;

      detach_file (p_directory, directory_sfid, local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;

      detach_file (p_dfl, dfl_sfid, local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;

      detach_file (p_dat, dat_sfid, local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;

      detach_file ({p_file =} NIL, label_sfid, local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;

    END /build_label/;

  PROCEND create_new_volume_label;
  ?? TITLE := 'build_device_allocation_table', EJECT ??
  PROCEDURE build_device_allocation_table (logical_unit_number: iot$logical_unit;
        avt_index: dmt$active_volume_table_index;
        recorded_vsn: rmt$recorded_vsn;
        internal_vsn: dmt$internal_vsn;
        dat_version_number: dmt$ms_dat_version_number;
        p_logical_attributes: ^dmt$logical_device_attributes;
        p_physical_attributes: ^dmt$physical_device_attributes;
    VAR dat_sfid: gft$system_file_identifier;
    VAR p_dat: ^dmt$ms_device_allocation_table;
    VAR status: ost$status);

    VAR
      able: boolean,
      allocation_size: dmt$allocation_size,
      allocation_style: dmt$allocation_styles,
      applicable_flaw_count: integer,
      bytes_per_dau: dmt$bytes_per_dau,
      cylinder: dmt$device_position,
      dat_cylinder_range: cylinder_range_type,
      dat_file_hash: dmt$file_hash,
      dat_length_in_bytes: amt$file_byte_address,
      dau_index: dmt$dau_address,
      daus_per_allocation_unit: dmt$daus_per_allocation,
      device_flaws_specified: boolean,
      file_already_attached: boolean,
      flaw_index: integer,
      index: integer,
      local_status: ost$status,
      logical_flaws: array [1 .. dmc$max_logical_flaws] of dmt$flaw_list_entry,
      logical_flaws_specified: boolean,
      number_of_logical_flaws: dmt$dau_address,
      p_device_flaw_list: ^dmt$ms_flaw_list,
      p_ds_sector_flaw_list: ^dmt$ms_flaw_list,
      p_dat_fmd: ^dmt$file_medium_descriptor,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: gft$file_desc_entry_p,
      p_fau_entry: ^dmt$file_allocation_unit,
      p_sc_dau_list: ^array [1 .. *] of dmt$log_flaw_init_data,
      p_dat_seq: ^SEQ ( * ),
      p_flaw_locations: ^array [1 .. * ] of dmt$flaw_map_address,
      powers_of_two: 1 .. 1024,
      p_file_attributes: ^array [ * ] of dmt$file_attribute,
      p_fmd_attributes: ^array [1 .. * ] of dmt$fmd_attribute,
      segment_pointer: mmt$segment_pointer,
      transfer_size: dmt$transfer_size,
      unusable_daus: dmt$dau_address;

    status.normal := TRUE;
    allocation_size := 0;
    transfer_size := 0;
    p_dat := NIL;

  /build_dat/
    BEGIN
      applicable_flaw_count := 0;
      number_of_logical_flaws := 0;
      dat_user_supplied_name (4, rmc$recorded_vsn_size) := recorded_vsn;

      osp$generate_unique_binary_name (dat_global_file_name, status);
      IF NOT status.normal THEN
        EXIT /build_dat/;
      IFEND;

      dmp$generate_gfn_hash (dat_global_file_name, dat_file_hash);

      daus_per_cylinder := maus_per_cylinder DIV maus_per_dau;
      bytes_per_dau := maus_per_dau * bytes_per_mau;
      daus_per_device := daus_per_cylinder * cylinders_per_device;
      dat_length_in_bytes := daus_per_device * #SIZE (dmt$ms_device_allocation_unit) + #SIZE
            (dmt$ms_device_alloc_table_head);
      device_flaws_specified := FALSE;
      logical_flaws_specified := FALSE;

      IF p_physical_attributes <> NIL THEN
        FOR index := LOWERBOUND (p_physical_attributes^) TO UPPERBOUND (p_physical_attributes^) DO
          CASE p_physical_attributes^ [index].keyword OF
          = dmc$flaw_map_locations =
            PUSH p_flaw_locations: [1 .. UPPERBOUND (p_physical_attributes^ [index].flaw_locations)];
            p_flaw_locations^ := p_physical_attributes^ [index].flaw_locations;
            device_flaws_specified := p_flaw_locations^ [1].device_flaws_specified;
          ELSE
          CASEND;
        FOREND;
      IFEND;

      {
      { create allocation map for the device
      {
      FOR cylinder := 0 TO cylinders_per_device - 1 DO
        p_usable_daus^ [cylinder] := - $dau_mapping [];
        FOR dau_index := daus_per_cylinder TO dmc$max_daus_position DO
          p_usable_daus^ [cylinder] := p_usable_daus^ [cylinder] - $dau_mapping [dau_index];
        FOREND;
      FOREND;

      {
      { compute allocation style dau values
      {
      powers_of_two := 1;

      FOR allocation_style := LOWERVALUE (dmt$allocation_styles) TO UPPERVALUE (dmt$allocation_styles) DO
        IF daus_per_cylinder > powers_of_two THEN
          daus_per_allocation_style [allocation_style] := powers_of_two;
        ELSE
          daus_per_allocation_style [allocation_style] := daus_per_cylinder;
        IFEND;
        powers_of_two := powers_of_two * 2;
      FOREND;

      IF p_logical_attributes <> NIL THEN
        FOR index := LOWERBOUND (p_logical_attributes^) TO UPPERBOUND (p_logical_attributes^) DO
          CASE p_logical_attributes^ [index].keyword OF
          = dmc$logical_flaws =
            number_of_logical_flaws := p_logical_attributes^ [index].number_of_flaw_entries;
            logical_flaws := p_logical_attributes^ [index].flaw_locations;
            logical_flaws_specified := (number_of_logical_flaws > 0);
          = dmc$volume_default_alloc_sz =
            allocation_size := p_logical_attributes^ [index].volume_default_allocation_size;
          = dmc$volume_default_transfer_sz =
            transfer_size := p_logical_attributes^ [index].volume_default_transfer_size;
          ELSE
          CASEND;
        FOREND;
      IFEND;

      {
      { build the stored device file fmd
      {
      PUSH p_file_attributes: [1 .. 12];
      p_file_attributes^ [1].keyword := dmc$file_kind;
      p_file_attributes^ [1].file_kind := gfc$fk_device_file;
      p_file_attributes^ [2].keyword := dmc$overflow;
      p_file_attributes^ [2].overflow_allowed := FALSE;
      p_file_attributes^ [3].keyword := dmc$requested_allocation_size;
      p_file_attributes^ [3].requested_allocation_size := dmc$dat_allocation_size;
      p_file_attributes^ [4].keyword := dmc$requested_transfer_size;
      p_file_attributes^ [4].requested_transfer_size := dmc$dat_transfer_size;
      p_file_attributes^ [5].keyword := dmc$requested_volume;
      p_file_attributes^ [5].requested_volume.recorded_vsn := recorded_vsn;
      p_file_attributes^ [5].requested_volume.setname := '    ';
      p_file_attributes^ [6].keyword := dmc$clear_space;
      p_file_attributes^ [6].required := TRUE;
      p_file_attributes^ [7].keyword := dmc$preset_value;
      p_file_attributes^ [7].preset_value := 0;
      p_file_attributes^ [8].keyword := dmc$locked_file;
      p_file_attributes^ [8].file_lock.required := FALSE;
      p_file_attributes^ [9].keyword := dmc$file_limit;
      p_file_attributes^ [9].limit := ((dat_length_in_bytes + dmc$dat_allocation_size - 1) DIV
            dmc$dat_allocation_size) * dmc$dat_allocation_size;
      p_file_attributes^ [10].keyword := dmc$file_hash;
      p_file_attributes^ [10].file_hash := dat_file_hash;
      p_file_attributes^ [11].keyword := dmc$class;
      p_file_attributes^ [11].class := dmc$default_class;
      p_file_attributes^ [12].keyword := dmc$class_ordinal;
      p_file_attributes^ [12].ordinal := dmc$default_class_ordinal;

      build_stored_df_fmd_header (p_file_attributes, dat_stored_df_fmd, status);
      IF NOT status.normal THEN
        EXIT /build_dat/;
      IFEND;

      PUSH p_fmd_attributes: [1 .. 3];

      p_fmd_attributes^ [1].keyword := dmc$recorded_vsn;
      p_fmd_attributes^ [1].recorded_vsn := recorded_vsn;
      p_fmd_attributes^ [2].keyword := dmc$internal_vsn;
      p_fmd_attributes^ [2].internal_vsn := internal_vsn;
      p_fmd_attributes^ [3].keyword := dmc$device_file_list_index;
      p_fmd_attributes^ [3].device_file_list_index := dmc$dat_dfl_index;

      build_stored_df_fmd_subfile (p_fmd_attributes, dat_stored_df_fmd, status);
      IF NOT status.normal THEN
        EXIT /build_dat/;
      IFEND;

      {
      { attach the device allocation table
      {
      dmp$attach_device_file_by_fmd (dat_global_file_name, dat_stored_df_fmd, file_already_attached, dat_sfid,
            status);
      IF NOT status.normal THEN
        EXIT /build_dat/;
      IFEND;

      IF file_already_attached THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$duplicate_device_file_gfn,
          'dat gfn already attached', status);
        EXIT /build_dat/;
      IFEND;

      gfp$get_fde_p (dat_sfid, p_fde);
      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
      dmp$get_fmd_by_index (p_dfd, 1, p_dat_fmd);

      p_dat_fmd^.fmd_allocated_length := ((dat_length_in_bytes + dmc$dat_allocation_size - 1) DIV
            dmc$dat_allocation_size) * dmc$dat_allocation_size;
      p_dat_fmd^.avt_index := avt_index;

    /dat_file_attached/
      BEGIN

        unusable_daus := 0;
        get_deadstart_sector_flaws (logical_unit_number, p_ds_sector_flaw_list);
        IF (p_ds_sector_flaw_list <> NIL) THEN
          FOR flaw_index := 1 TO UPPERBOUND (p_ds_sector_flaw_list^) DO
            dau_index := p_ds_sector_flaw_list^ [flaw_index].dau_address;

            FOR index := 1 TO p_ds_sector_flaw_list^ [flaw_index].number_flawed_daus DO
              cylinder := dau_index DIV daus_per_cylinder;
              IF cylinder < cylinders_per_device THEN
                IF (dau_index MOD daus_per_cylinder) IN p_usable_daus^ [cylinder] THEN
                  p_usable_daus^ [cylinder] := p_usable_daus^ [cylinder] - $dau_mapping
                      [dau_index MOD daus_per_cylinder];
                  unusable_daus := unusable_daus + 1;
                IFEND;
              IFEND;
              dau_index := dau_index + 1;
            FOREND;
          FOREND;
        IFEND;

        IF device_flaws_specified THEN
          get_device_flaws (logical_unit_number, p_flaw_locations^, p_device_flaw_list, status);
          IF NOT status.normal THEN
            EXIT /dat_file_attached/;
          IFEND;
          device_flaws_specified := (p_device_flaw_list <> NIL);
        IFEND;
        IF device_flaws_specified THEN
          FOR flaw_index := 1 TO UPPERBOUND (p_device_flaw_list^) DO
            dau_index := p_device_flaw_list^ [flaw_index].dau_address;

            FOR index := 1 TO p_device_flaw_list^ [flaw_index].number_flawed_daus DO
              cylinder := dau_index DIV daus_per_cylinder;
              IF cylinder < cylinders_per_device THEN
                IF (dau_index MOD daus_per_cylinder) IN p_usable_daus^ [cylinder] THEN
                  p_usable_daus^ [cylinder] := p_usable_daus^ [cylinder] - $dau_mapping
                      [dau_index MOD daus_per_cylinder];
                  unusable_daus := unusable_daus + 1;
                IFEND;
              IFEND;
              dau_index := dau_index + 1;
            FOREND;
          FOREND;
        IFEND;

        IF logical_flaws_specified THEN
          FOR flaw_index := 1 TO number_of_logical_flaws DO
            dau_index := logical_flaws [flaw_index].dau_address;

            FOR index := 1 TO logical_flaws [flaw_index].number_flawed_daus DO
              cylinder := dau_index DIV daus_per_cylinder;
              IF cylinder < cylinders_per_device THEN
                IF (dau_index MOD daus_per_cylinder) IN p_usable_daus^ [cylinder] THEN
                  p_usable_daus^ [cylinder] := p_usable_daus^ [cylinder] - $dau_mapping
                      [dau_index MOD daus_per_cylinder];
                  unusable_daus := unusable_daus + 1;
                IFEND;
              IFEND;
              dau_index := dau_index + 1;
            FOREND;
          FOREND;
        IFEND;

        IF (p_existing_flaws <> NIL) THEN
          FOR flaw_index := LOWERBOUND(p_existing_flaws^) TO UPPERBOUND(p_existing_flaws^) DO
            dau_index := p_existing_flaws^[flaw_index].dau_address;
            cylinder := dau_index DIV daus_per_cylinder;
            IF cylinder < cylinders_per_device THEN
              IF (dau_index MOD daus_per_cylinder) IN p_usable_daus^ [cylinder] THEN
                p_usable_daus^ [cylinder] := p_usable_daus^ [cylinder] - $dau_mapping
                    [dau_index MOD daus_per_cylinder];
                unusable_daus := unusable_daus + 1;
              IFEND;
            IFEND;
          FOREND;
        IFEND;

{ Procedure dmp$convert_to_dau_address called by dmp$construct_sc_dau_list needs the RVSN to
{ be set in the active_volume_table before it is executed.

        dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn := recorded_vsn;

{ Create an array of system core flaws that pertain to this device and clear the correct bit in the bit map.
{ NOTE: The number of available DAUs will be adjusted in dmp$record_sc_flaw called later.
{       Also, the system core flaws will not be marked as processed until normal status is received at the
{       completion of creating the label.  Otherwise, if another iniatialize command is entered for the same
{       device after a failed attempt, all flaws would be lost.

        IF dmv$p_sc_flaw_commands <> NIL THEN
          PUSH p_sc_dau_list: [1 .. UPPERBOUND (dmv$p_sc_flaw_commands^)];
          dmp$construct_sc_dau_list (recorded_vsn, TRUE, p_sc_dau_list, applicable_flaw_count, status);

          FOR index := 1 TO applicable_flaw_count DO
            cylinder := p_sc_dau_list^ [index].first_dau DIV daus_per_cylinder;
            IF cylinder < cylinders_per_device THEN

              FOR dau_index := p_sc_dau_list^ [index].first_dau TO p_sc_dau_list^ [index].last_dau DO
                IF (dau_index MOD daus_per_cylinder) IN p_usable_daus^ [cylinder] THEN
                  p_usable_daus^ [cylinder] := p_usable_daus^ [cylinder] - $dau_mapping
                    [dau_index MOD daus_per_cylinder];
                IFEND;
              FOREND;

            IFEND;
          FOREND;

        IFEND;

        dat_cylinder_range.lowest_cylinder := 1;
        dat_cylinder_range.highest_cylinder := cylinders_per_device - 1;

        build_faus (dat_cylinder_range, dat_length_in_bytes, dmc$dat_allocation_size, dmc$dat_transfer_size,
              dat_sfid, status);
        IF NOT status.normal THEN
          EXIT /dat_file_attached/;
        IFEND;

        daus_per_allocation_unit := p_dat_fmd^.daus_per_allocation_unit;
        segment_pointer.kind := mmc$sequence_pointer;

        dmp$open_file (dat_sfid, osc$os_ring_1, osc$os_ring_1, mmc$sar_write_extend,
           mmc$as_sequential, segment_pointer, status);
        IF NOT status.normal THEN
          EXIT /dat_file_attached/;
        IFEND;

        p_dat_seq := segment_pointer.seq_pointer;
        RESET p_dat_seq;
        NEXT p_dat: [dmc$min_dau_address .. dmc$min_dau_address + daus_per_device - 1] IN p_dat_seq;
{
{       build device allocation table header
{
        dmp$set_update_lock (avt_index, {wait =} TRUE, able);

        /dat_locked/
          BEGIN
            p_dat^.header.default_transfer_size := transfer_size;
            p_dat^.header.default_allocation_size := allocation_size;
            p_dat^.header.bytes_per_dau := bytes_per_dau;
            p_dat^.header.bytes_per_mau := bytes_per_mau;
            p_dat^.header.daus_per_position := daus_per_cylinder;
            p_dat^.header.maus_per_dau := maus_per_dau;
            p_dat^.header.number_of_entries := daus_per_device;
            p_dat^.header.positions_per_device := cylinders_per_device;
            p_dat^.header.version_number := dat_version_number;
            CASE dat_version_number OF
            = dmc$dat_0_0 =
              p_dat^.header.daus_per_allocation_style := daus_per_allocation_style;
              p_dat^.header.available := daus_per_device - unusable_daus;

              { Recovery threshold = 2% of device to the nearest 100 DAU's }

              p_dat^.header.recovery_threshold := ((daus_per_device + 2500) DIV 5000) * 100;

              { Warning threshold = 10% of device to the nearest 100 DAU's }

              p_dat^.header.warning_threshold := ((daus_per_device + 500) DIV 1000) * 100;

              p_dat^.header.pad1 [1] := 0;
              p_dat^.header.pad1 [2] := 0;      { this used to be "commitment level"
              p_dat^.header.pad1 [3] := 0;
              p_dat^.header.pad1 [4] := 0;
              p_dat^.header.pad1 [5] := 0;

{                   build device allocation table body

              FOR dau_index := dmc$min_dau_address TO dmc$min_dau_address + daus_per_device - 1 DO
                p_dat^.body [dau_index].dau_status := dmc$dau_usable;
              FOREND;

{                  flaw dat entries that are in the device flaw list

              IF device_flaws_specified THEN
                FOR flaw_index := 1 TO UPPERBOUND (p_device_flaw_list^) DO
                  dau_index := p_device_flaw_list^ [flaw_index].dau_address;

                  FOR index := 1 TO p_device_flaw_list^ [flaw_index].number_flawed_daus DO
                    IF dau_index < daus_per_device THEN
                      p_dat^.body [dau_index].dau_status := dmc$dau_hardware_flawed;
                    IFEND;
                    dau_index := dau_index + 1;
                  FOREND;
                FOREND;

                FREE p_device_flaw_list IN osv$mainframe_wired_heap^;
              IFEND;

{                 flaw entries in deadstart sector

              IF (p_ds_sector_flaw_list <> NIL) THEN
                FOR flaw_index := 1 TO UPPERBOUND (p_ds_sector_flaw_list^) DO
                  dau_index := p_ds_sector_flaw_list^ [flaw_index].dau_address;

                  FOR index := 1 TO p_ds_sector_flaw_list^ [flaw_index].number_flawed_daus DO
                    IF dau_index < daus_per_device THEN
                      IF (p_dat^.body [dau_index].dau_status = dmc$dau_usable) THEN
                         p_dat^.body [dau_index].dau_status := dmc$dau_hardware_flawed;
                      IFEND;
                    IFEND;
                    dau_index := dau_index + 1;
                  FOREND;
                FOREND;

                FREE p_ds_sector_flaw_list IN osv$mainframe_wired_heap^;
              IFEND;

{                 flaw logical flaws

              IF logical_flaws_specified THEN
                FOR flaw_index := 1 TO number_of_logical_flaws DO
                  dau_index := logical_flaws [flaw_index].dau_address;

                  FOR index := 1 TO logical_flaws [flaw_index].number_flawed_daus DO
                    IF dau_index < daus_per_device THEN
                      IF (p_dat^.body [dau_index].dau_status = dmc$dau_usable) THEN
                        p_dat^.body [dau_index].dau_status := dmc$dau_hardware_flawed;
                      IFEND;
                    IFEND;
                    dau_index := dau_index + 1;
                  FOREND;
                FOREND;
              IFEND;

{               retain flaws from previous production run on this device ******************************** }

              IF (p_existing_flaws <> NIL) THEN
                FOR index := LOWERBOUND (p_existing_flaws^) TO UPPERBOUND (p_existing_flaws^) DO
                  dau_index := p_existing_flaws^ [index].dau_address;
                  IF (p_dat^.body [dau_index].dau_status = dmc$dau_usable) THEN
                    CASE p_existing_flaws^ [index].kind_of_flaw OF

                    = dmc$dau_hardware_flawed, dmc$dau_software_flawed =
                      p_dat^.body [dau_index].dau_status := p_existing_flaws^ [index].kind_of_flaw;

                    = dmc$dau_ass_to_mf_swr_flawed, dmc$dau_ass_to_file_swr_flawed =
                      p_dat^.body [dau_index].dau_status := dmc$dau_software_flawed;

                    ELSE
                    CASEND;
                  IFEND;
                FOREND;

                FREE p_existing_flaws IN osv$mainframe_wired_heap^;
              IFEND;

{ Flaw DAUs selected by the system core flaw commands.

              IF applicable_flaw_count <> 0 THEN
                dmp$record_sc_flaw (applicable_flaw_count, p_dat, p_sc_dau_list);
              IFEND;

            ELSE
              osp$set_status_abnormal (dmc$device_manager_ident, dme$unsupported_dat_version,
                'unsupported dat version number', status);
            CASEND;
          END /dat_locked/;

          dmp$clear_update_lock (avt_index);

{
{       set dat entries,which are used to describe the dat, to reflect
{       allocated status
{
        update_dat_entries (p_dat, dmc$dat_dfl_index, p_dfd, avt_index);

      /build_device_file_list_entry/
        BEGIN
          dmp$get_fau_entry (p_dfd, 0, p_fau_entry);
          dat_dfle.pad := 0;
          dat_dfle.flags := dmc$dfle_assigned_to_file;
          dat_dfle.dau_chain_status := dmc$dau_chain_linked;
          dat_dfle.daus_per_allocation_unit := daus_per_allocation_unit;
          dat_dfle.end_of_file := ((dat_length_in_bytes + osv$page_size - 1) DIV osv$page_size) *
                osv$page_size;
          dat_dfle.end_of_information := ((dat_length_in_bytes + osv$page_size - 1) DIV osv$page_size) *
                osv$page_size;
          dat_dfle.file_byte_address := 0;
          dat_dfle.file_hash := dat_sfid.file_hash;
          dat_dfle.file_kind := gfc$fk_device_file;
          dat_dfle.first_dau_address := p_fau_entry^.dau_address;
          dat_dfle.global_file_name := dat_global_file_name;
          dat_dfle.logical_length := ((dat_length_in_bytes + osv$page_size - 1) DIV osv$page_size) *
                osv$page_size;
          dat_dfle.fmd_length := ((dat_length_in_bytes + dmc$dat_allocation_size - 1) DIV
                dmc$dat_allocation_size) * dmc$dat_allocation_size;
          dat_dfle.login_set := $dmt$dfl_login_set [];

        END /build_device_file_list_entry/;

      END /dat_file_attached/;
      IF NOT status.normal THEN
        detach_file (p_dat, dat_sfid, local_status);
      IFEND;

    END /build_dat/;

  PROCEND build_device_allocation_table;
  ?? TITLE := 'build_faus', EJECT ??
  PROCEDURE build_faus (cylinder_range: cylinder_range_type;
        length_in_bytes: amt$file_byte_address;
        allocation_size: dmt$bytes_per_allocation;
        transfer_size: dmt$transfer_size;
        sfid: gft$system_file_identifier;
    VAR status: ost$status);

    VAR
      able_to_allocate_aus: boolean,
      allocation_style: dmt$allocation_styles,
      allocation_style_found: boolean,
      allocation_unit_dau_address: dmt$dau_address,
      byte_address: amt$file_byte_address,
      bytes_per_dau: dmt$bytes_per_dau,
      daus_per_allocation_unit: dmt$daus_per_allocation,
      fau_index: dmt$fau_entries,
      length_in_daus: dmt$dau_address,
      maus_per_allocation_unit: dmt$maus_per_allocation,
      maus_per_transfer_unit: dmt$maus_per_transfer,
      next_au_index_in_cylinder: dmt$daus_per_position,
      number_faus: dmt$fau_entries,
      p_fau: ^dmt$file_allocation_unit,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: gft$file_desc_entry_p,
      p_fmd: ^dmt$file_medium_descriptor;

    status.normal := TRUE;

    bytes_per_dau := bytes_per_mau * maus_per_dau;
    maus_per_allocation_unit := (allocation_size + bytes_per_mau - 1) DIV bytes_per_mau;
    daus_per_allocation_unit := (maus_per_allocation_unit + maus_per_dau - 1) DIV maus_per_dau;
    maus_per_transfer_unit := (transfer_size + bytes_per_mau - 1) DIV bytes_per_mau;

  /compute_allocation_style/
    FOR allocation_style := dmc$a0 TO dmc$acyl DO
      allocation_style_found := (daus_per_allocation_style [allocation_style] = daus_per_allocation_unit);
      IF allocation_style_found THEN
        EXIT /compute_allocation_style/;
      IFEND;
    FOREND /compute_allocation_style/;

    IF NOT allocation_style_found THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$no_allocation_style_found,
        'unable to compute allocation style', status);
      RETURN;
    IFEND;

    length_in_daus := (length_in_bytes + bytes_per_dau - 1) DIV bytes_per_dau;
    number_faus := (length_in_daus + daus_per_allocation_unit - 1) DIV daus_per_allocation_unit;

    gfp$get_fde_p (sfid, p_fde);
    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
    dmp$get_fmd_by_index (p_dfd, 1, p_fmd);

    p_fmd^.bytes_per_mau := bytes_per_mau;
    p_fmd^.daus_per_allocation_unit := daus_per_allocation_unit;
    p_fmd^.daus_per_cylinder := daus_per_cylinder;
    p_fmd^.maus_per_dau := maus_per_dau;
    p_fmd^.allocation_style := allocation_style;
    p_fmd^.maus_per_transfer_unit := maus_per_transfer_unit;
    p_dfd^.bytes_per_allocation := maus_per_dau * bytes_per_mau * daus_per_allocation_unit;
    p_fde^.allocation_unit_size := maus_per_dau * bytes_per_mau * daus_per_allocation_unit;

    IF (dmc$bytes_per_level_2 MOD p_dfd^.bytes_per_allocation) <> 0 THEN
      {Round up to next allocation unit
      p_dfd^.bytes_per_level_2 := (dmc$bytes_per_level_2 + p_dfd^.bytes_per_allocation - 1)
          DIV p_dfd^.bytes_per_allocation * p_dfd^.bytes_per_allocation;
    ELSE
      p_dfd^.bytes_per_level_2 := dmc$bytes_per_level_2;
    IFEND;
    p_fmd^.system_file_id := sfid;
    p_dfd^.current_fmd_index := 1;

    allocation_unit_dau_address := cylinder_range.lowest_cylinder * daus_per_cylinder;

    dmp$create_fau_entry (p_dfd, 0, number_faus * p_dfd^.bytes_per_allocation);

  /allocate_space/
    BEGIN
      get_consecutive_alloc_units (number_faus, daus_per_allocation_unit, cylinder_range,
            allocation_unit_dau_address, able_to_allocate_aus);
      IF able_to_allocate_aus THEN
        byte_address := 0;
        FOR fau_index := 1 TO number_faus DO
          dmp$get_fau_entry (p_dfd, byte_address, p_fau);
          p_fau^.dau_address := allocation_unit_dau_address;
          p_fau^.state := dmc$fau_invalid_data;
          p_fau^.fmd_index := 1;
          next_au_index_in_cylinder := ((allocation_unit_dau_address + daus_per_allocation_unit) -
                ((allocation_unit_dau_address + daus_per_allocation_unit) DIV daus_per_cylinder) *
                daus_per_cylinder) DIV daus_per_allocation_unit;
          IF next_au_index_in_cylinder <= ((daus_per_cylinder DIV daus_per_allocation_unit) - 1) THEN
            allocation_unit_dau_address := allocation_unit_dau_address + daus_per_allocation_unit;
          ELSE
            allocation_unit_dau_address := ((allocation_unit_dau_address DIV daus_per_cylinder) + 1) *
                  daus_per_cylinder;
          IFEND;
          byte_address := byte_address + p_dfd^.bytes_per_allocation;
        FOREND;
      IFEND;

    END /allocate_space/;
    IF NOT able_to_allocate_aus THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_allocate_aus,
        'unable to allocate consecutive aus - DMMIVOL', status);
      RETURN;
    IFEND;

   p_fmd^.volume_assigned := TRUE;
   p_dfd^.highest_offset_allocated := byte_address;

  PROCEND build_faus;
?? TITLE := 'free_faus_flaw_daus', EJECT ??
  PROCEDURE free_faus_flaw_daus (
        p_dat: ^dmt$ms_device_allocation_table;
        p_dfd: ^dmt$disk_file_descriptor);

    VAR
      byte_address: amt$file_byte_address,
      fau_index: dmt$fau_entries,
      number_of_faus: dmt$fau_entries,
      p_fau_entry: ^dmt$file_allocation_unit;

    dmp$get_number_of_faus (p_dfd, number_of_faus);

    byte_address := 0;
    FOR fau_index := 1 TO number_of_faus DO
      dmp$get_fau_entry (p_dfd, byte_address, p_fau_entry);
      IF (p_fau_entry^.state <> dmc$fau_free) THEN
        p_dat^.body [p_fau_entry^.dau_address].dau_status := dmc$dau_software_flawed;
        p_fau_entry^.state := dmc$fau_free;
      IFEND;
      byte_address := byte_address + p_dfd^.bytes_per_allocation;
    FOREND;
  PROCEND free_faus_flaw_daus;
  ?? TITLE := 'get_consecutive_alloc_units', EJECT ??
  PROCEDURE get_consecutive_alloc_units (number_of_consecutive_aus: dmt$fau_entries;
        daus_per_allocation_unit: dmt$daus_per_allocation;
        cylinder_range: cylinder_range_type;
    VAR allocation_unit_address: dmt$dau_address;
    VAR able_to_allocate_aus: boolean);

    VAR
      cylinder: dmt$device_position,
      au_address: 0 .. dmc$max_daus_position + dmc$max_daus_allocation,
      last_au_address_in_cylinder: dmt$daus_per_position,
      consecutive_aus: dmt$dau_address,
      consecutive_au_address: dmt$dau_address,
      dau_index: dmt$daus_per_position,
      consecutive_au_found: boolean;

    able_to_allocate_aus := FALSE;
    consecutive_aus := number_of_consecutive_aus;
    consecutive_au_address := allocation_unit_address;
    last_au_address_in_cylinder := ((daus_per_cylinder DIV daus_per_allocation_unit) - 1) *
          daus_per_allocation_unit;

    REPEAT
      cylinder := consecutive_au_address DIV daus_per_cylinder;
      au_address := ((consecutive_au_address - (cylinder * daus_per_cylinder)) DIV
            daus_per_allocation_unit) * daus_per_allocation_unit;

    /consecutive_au_loop/
      WHILE au_address <= last_au_address_in_cylinder DO

      /consecutive_dau_loop/
        FOR dau_index := 0 TO daus_per_allocation_unit - 1 DO
          consecutive_au_found := (au_address + dau_index) IN p_usable_daus^ [cylinder];
          IF NOT consecutive_au_found THEN
            EXIT /consecutive_au_loop/;
          IFEND;
        FOREND /consecutive_dau_loop/;
        consecutive_aus := consecutive_aus - 1;
        IF consecutive_aus <= 0 THEN
          EXIT /consecutive_au_loop/;
        IFEND;
        au_address := au_address + daus_per_allocation_unit;
      WHILEND /consecutive_au_loop/;
      IF consecutive_aus <= 0 THEN
        cylinder := allocation_unit_address DIV daus_per_cylinder;
        au_address := ((allocation_unit_address - (cylinder * daus_per_cylinder)) DIV
              daus_per_allocation_unit) * daus_per_allocation_unit;
        consecutive_aus := 1;
        WHILE consecutive_aus <= number_of_consecutive_aus DO
          consecutive_aus := consecutive_aus + 1;
          FOR dau_index := 0 TO daus_per_allocation_unit - 1 DO
            p_usable_daus^ [cylinder] := p_usable_daus^ [cylinder] - $dau_mapping [au_address
                  + dau_index];
          FOREND;
          IF (au_address + daus_per_allocation_unit) <= last_au_address_in_cylinder THEN
            au_address := au_address + daus_per_allocation_unit;
          ELSE
            cylinder := cylinder + 1;
            au_address := 0;
          IFEND;
        WHILEND;
        able_to_allocate_aus := TRUE;
        RETURN;
      IFEND;
      IF consecutive_au_found THEN
        consecutive_au_address := (cylinder + 1) * daus_per_cylinder;
      ELSE
        consecutive_aus := number_of_consecutive_aus;
        IF au_address < last_au_address_in_cylinder THEN
          consecutive_au_address := (au_address + daus_per_allocation_unit) + (daus_per_cylinder *
                cylinder);
        ELSE
          consecutive_au_address := (cylinder + 1) * daus_per_cylinder;
        IFEND;
        allocation_unit_address := consecutive_au_address;
      IFEND;
    UNTIL (consecutive_au_address > (cylinder_range.highest_cylinder * daus_per_cylinder +
          last_au_address_in_cylinder));

  PROCEND get_consecutive_alloc_units;
  ?? TITLE := 'build_device_file_list', EJECT ??
  PROCEDURE build_device_file_list (avt_index: dmt$active_volume_table_index;
        recorded_vsn: rmt$recorded_vsn;
        internal_vsn: dmt$internal_vsn;
        dflt_version_number: dmt$ms_dflt_version_number;
        p_logical_attributes: ^dmt$logical_device_attributes;
        p_dat: ^dmt$ms_device_allocation_table;
    VAR dfl_sfid: gft$system_file_identifier;
    VAR p_dfl: ^dmt$ms_device_file_list_table;
    VAR status: ost$status);

    VAR
      able: boolean,
      dfl_length_in_bytes: amt$file_byte_address,
      dflt_file_hash: dmt$file_hash,
      dflt_cylinder_range: cylinder_range_type,
      entry_index: dmt$device_file_list_index,
      file_already_attached: boolean,
      index: integer,
      local_status: ost$status,
      number_dfl_entries: dmt$device_file_list_index,
      p_dfd: ^dmt$disk_file_descriptor,
      p_dflt_fmd: ^dmt$file_medium_descriptor,
      p_dflt_seq: ^SEQ ( * ),
      p_fmd_attributes: ^array [1 .. * ] of dmt$fmd_attribute,
      p_fau_entry: ^dmt$file_allocation_unit,
      p_fde: gft$file_desc_entry_p,
      p_file_attributes: ^array [1 .. * ] of dmt$file_attribute,
      segment_pointer: mmt$segment_pointer;

    status.normal := TRUE;
    p_dfl := NIL;

  /build_dfl/
    BEGIN
      dflt_user_supplied_name (5, rmc$recorded_vsn_size) := recorded_vsn;

      osp$generate_unique_binary_name (dflt_global_file_name, status);
      IF NOT status.normal THEN
        EXIT /build_dfl/;
      IFEND;

      dmp$generate_gfn_hash (dflt_global_file_name, dflt_file_hash);

      number_dfl_entries := dmc$default_volume_dfl_entries;
      dflt_cylinder_range.lowest_cylinder := 1;
      dflt_cylinder_range.highest_cylinder := cylinders_per_device - 1;

      IF p_logical_attributes <> NIL THEN
        FOR index := LOWERBOUND (p_logical_attributes^) TO UPPERBOUND (p_logical_attributes^) DO
          CASE p_logical_attributes^ [index].keyword OF
          = dmc$volume_dfl_entries =
            number_dfl_entries := p_logical_attributes^ [index].number_dfl_entries;
          ELSE
          CASEND;
        FOREND;
      IFEND;

      dfl_length_in_bytes := number_dfl_entries * #SIZE (dmt$ms_device_file_list_entry) + #SIZE
            (dmt$ms_device_file_list_header);

      PUSH p_file_attributes: [1 .. 12];
      p_file_attributes^ [1].keyword := dmc$file_kind;
      p_file_attributes^ [1].file_kind := gfc$fk_device_file;
      p_file_attributes^ [2].keyword := dmc$overflow;
      p_file_attributes^ [2].overflow_allowed := FALSE;
      p_file_attributes^ [3].keyword := dmc$requested_allocation_size;
      p_file_attributes^ [3].requested_allocation_size := dmc$dfl_allocation_size;
      p_file_attributes^ [4].keyword := dmc$requested_transfer_size;
      p_file_attributes^ [4].requested_transfer_size := dmc$dfl_transfer_size;
      p_file_attributes^ [5].keyword := dmc$requested_volume;
      p_file_attributes^ [5].requested_volume.recorded_vsn := recorded_vsn;
      p_file_attributes^ [5].requested_volume.setname := '    ';
      p_file_attributes^ [6].keyword := dmc$clear_space;
      p_file_attributes^ [6].required := TRUE;
      p_file_attributes^ [7].keyword := dmc$preset_value;
      p_file_attributes^ [7].preset_value := 0;
      p_file_attributes^ [8].keyword := dmc$locked_file;
      p_file_attributes^ [8].file_lock.required := FALSE;
      p_file_attributes^ [9].keyword := dmc$file_limit;
      p_file_attributes^ [9].limit := (dfl_length_in_bytes + dmc$dfl_allocation_size - 1) DIV
            dmc$dfl_allocation_size * dmc$dfl_allocation_size;
      p_file_attributes^ [10].keyword := dmc$file_hash;
      p_file_attributes^ [10].file_hash := dflt_file_hash;
      p_file_attributes^ [11].keyword := dmc$class;
      p_file_attributes^ [11].class := dmc$default_class;
      p_file_attributes^ [12].keyword := dmc$class_ordinal;
      p_file_attributes^ [12].ordinal := dmc$default_class_ordinal;

      build_stored_df_fmd_header (p_file_attributes, dflt_stored_df_fmd, status);
      IF NOT status.normal THEN
        EXIT /build_dfl/;
      IFEND;

      PUSH p_fmd_attributes: [1 .. 3];

      p_fmd_attributes^ [1].keyword := dmc$recorded_vsn;
      p_fmd_attributes^ [1].recorded_vsn := recorded_vsn;
      p_fmd_attributes^ [2].keyword := dmc$internal_vsn;
      p_fmd_attributes^ [2].internal_vsn := internal_vsn;
      p_fmd_attributes^ [3].keyword := dmc$device_file_list_index;
      p_fmd_attributes^ [3].device_file_list_index := dmc$device_file_list_dfl_index;

      build_stored_df_fmd_subfile (p_fmd_attributes, dflt_stored_df_fmd, status);
      IF NOT status.normal THEN
        EXIT /build_dfl/;
      IFEND;

      {
      { attach device file list table
      {
      dmp$attach_device_file_by_fmd (dflt_global_file_name, dflt_stored_df_fmd, file_already_attached,
            dfl_sfid, status);
      IF NOT status.normal THEN
        EXIT /build_dfl/;
      IFEND;

      IF file_already_attached THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$duplicate_device_file_gfn,
          'dfl gfn already attached', status);
        EXIT /build_dfl/;
      IFEND;

      gfp$get_fde_p (dfl_sfid, p_fde);
      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
      dmp$get_fmd_by_index (p_dfd, 1, p_dflt_fmd);

      p_dflt_fmd^.fmd_allocated_length := ((dfl_length_in_bytes + dmc$dfl_allocation_size - 1) DIV
            dmc$dfl_allocation_size) * dmc$dfl_allocation_size;
      p_dflt_fmd^.avt_index := avt_index;

    /dfl_file_attached/
      BEGIN
        build_faus (dflt_cylinder_range, dfl_length_in_bytes, dmc$dfl_allocation_size, dmc$dfl_transfer_size,
              dfl_sfid, status);
        IF NOT status.normal THEN
          EXIT /dfl_file_attached/;
        IFEND;

      /build_device_file_list_entry/
        BEGIN
          dmp$get_fau_entry (p_dfd, 0, p_fau_entry);
          dflt_dfle.pad := 0;
          dflt_dfle.flags := dmc$dfle_assigned_to_file;
          dflt_dfle.dau_chain_status := dmc$dau_chain_linked;
          dflt_dfle.daus_per_allocation_unit := p_dflt_fmd^.daus_per_allocation_unit;
          dflt_dfle.end_of_file := ((dfl_length_in_bytes + osv$page_size - 1) DIV osv$page_size) *
                osv$page_size;
          dflt_dfle.end_of_information := ((dfl_length_in_bytes + osv$page_size - 1) DIV osv$page_size) *
                osv$page_size;
          dflt_dfle.file_byte_address := 0;
          dflt_dfle.file_hash := dfl_sfid.file_hash;
          dflt_dfle.file_kind := gfc$fk_device_file;
          dflt_dfle.first_dau_address := p_fau_entry^.dau_address;
          dflt_dfle.global_file_name := dflt_global_file_name;
          dflt_dfle.logical_length := ((dfl_length_in_bytes + osv$page_size - 1) DIV osv$page_size) *
                osv$page_size;
          dflt_dfle.fmd_length := ((dfl_length_in_bytes + dmc$dfl_allocation_size - 1) DIV
                dmc$dfl_allocation_size) * dmc$dfl_allocation_size;
          dflt_dfle.login_set := $dmt$dfl_login_set [];
        END /build_device_file_list_entry/;

        segment_pointer.kind := mmc$sequence_pointer;
        dmp$open_file (dfl_sfid, osc$os_ring_1, osc$os_ring_1, mmc$sar_write_extend,
           mmc$as_sequential, segment_pointer, status);
        IF NOT status.normal THEN
          EXIT /dfl_file_attached/;
        IFEND;

        p_dflt_seq := segment_pointer.seq_pointer;
        RESET p_dflt_seq;
        NEXT p_dfl: [1 .. number_dfl_entries] IN p_dflt_seq;

        {
        { build device file list header
        {

        dmp$set_update_lock (avt_index, {wait =} TRUE, able);

        /dflt_locked/
          BEGIN
            p_dfl^.header.version_number := dflt_version_number;
            p_dfl^.header.number_of_entries := number_dfl_entries;
            CASE dflt_version_number OF
            = dmc$dflt_0_0 =
              {
              { build device file list entries
              {
              FOR entry_index := 1 TO number_dfl_entries DO
                p_dfl^.entries [entry_index].pad := 0;
                p_dfl^.entries [entry_index].flags := dmc$dfle_available;
              FOREND;
              {
              { build device file list dfle
              {
              p_dfl^.entries [dmc$device_file_list_dfl_index] := dflt_dfle;
              {
              { build device allocation table dfle
              {
              p_dfl^.entries [dmc$dat_dfl_index] := dat_dfle;
            ELSE
              osp$set_status_abnormal (dmc$device_manager_ident, dme$unsupported_dflt_version,
                'unsupported dflt version number', status);
            CASEND;
          END /dflt_locked/;
          {
          { unlock device file list table
          {
          dmp$clear_update_lock (avt_index);

        {
        { update dat entries to reflect dflt file allocation units
        {
        update_dat_entries (p_dat, dmc$device_file_list_dfl_index, p_dfd, avt_index);

      END /dfl_file_attached/;
      IF NOT status.normal THEN
        detach_file (p_dfl, dfl_sfid, local_status);
      IFEND;

    END /build_dfl/;

  PROCEND build_device_file_list;
  ?? TITLE := 'build_volume_directory', EJECT ??

  PROCEDURE build_volume_directory (avt_index: dmt$active_volume_table_index;
        recorded_vsn: rmt$recorded_vsn;
        internal_vsn: dmt$internal_vsn;
        p_logical_attributes: ^dmt$logical_device_attributes;
        p_dat: ^dmt$ms_device_allocation_table;
        p_dfl: ^dmt$ms_device_file_list_table;
    VAR directory_sfid: gft$system_file_identifier;
    VAR p_directory: ^dmt$ms_volume_directory;
    VAR status: ost$status);

    VAR
      able: boolean,
      directory_cylinder_range: cylinder_range_type,
      directory_file_hash: dmt$file_hash,
      directory_global_file_name: dmt$global_file_name,
      directory_index: dmt$directory_index,
      directory_length_in_bytes: amt$file_byte_address,
      directory_user_supplied_name: [STATIC] ost$name := 'DIRECTORY',
      index: integer,
      file_already_attached: boolean,
      local_status: ost$status,
      number_directory_entries: dmt$directory_index,
      p_dfd: ^dmt$disk_file_descriptor,
      p_directory_fmd: ^dmt$file_medium_descriptor,
      p_directory_seq: ^SEQ ( * ),
      p_fmd_attributes: ^array [1 .. * ] of dmt$fmd_attribute,
      p_fau_entry: ^dmt$file_allocation_unit,
      p_fde: gft$file_desc_entry_p,
      p_file_attributes: ^array [1 .. * ] of dmt$file_attribute,
      segment_pointer: mmt$segment_pointer;

    status.normal := TRUE;
    p_directory := NIL;

  /build_directory/
    BEGIN
      directory_user_supplied_name (10, rmc$recorded_vsn_size) := recorded_vsn;

      osp$generate_unique_binary_name (directory_global_file_name, status);
      IF NOT status.normal THEN
        EXIT /build_directory/;
      IFEND;

      dmp$generate_gfn_hash (directory_global_file_name, directory_file_hash);

      number_directory_entries := dmc$default_vol_dir_entries;
      directory_cylinder_range.lowest_cylinder := 1;
      directory_cylinder_range.highest_cylinder := cylinders_per_device - 1;

      IF p_logical_attributes <> NIL THEN
        FOR index := LOWERBOUND (p_logical_attributes^) TO UPPERBOUND (p_logical_attributes^) DO
          CASE p_logical_attributes^ [index].keyword OF
          = dmc$volume_directory_entries =
            number_directory_entries := p_logical_attributes^ [index].number_directory_entries;
          ELSE
          CASEND;
        FOREND;
      IFEND;

      PUSH p_file_attributes: [1 .. 12];
      p_file_attributes^ [1].keyword := dmc$file_kind;
      p_file_attributes^ [1].file_kind := gfc$fk_device_file;
      p_file_attributes^ [2].keyword := dmc$overflow;
      p_file_attributes^ [2].overflow_allowed := FALSE;
      p_file_attributes^ [3].keyword := dmc$requested_allocation_size;
      p_file_attributes^ [3].requested_allocation_size := dmc$directory_allocation_size;
      p_file_attributes^ [4].keyword := dmc$requested_transfer_size;
      p_file_attributes^ [4].requested_transfer_size := dmc$directory_transfer_size;
      p_file_attributes^ [5].keyword := dmc$requested_volume;
      p_file_attributes^ [5].requested_volume.recorded_vsn := recorded_vsn;
      p_file_attributes^ [5].requested_volume.setname := '    ';
      p_file_attributes^ [6].keyword := dmc$clear_space;
      p_file_attributes^ [6].required := TRUE;
      p_file_attributes^ [7].keyword := dmc$preset_value;
      p_file_attributes^ [7].preset_value := 0;
      p_file_attributes^ [8].keyword := dmc$locked_file;
      p_file_attributes^ [8].file_lock.required := FALSE;
      p_file_attributes^ [9].keyword := dmc$file_limit;
      p_file_attributes^ [9].limit := dmc$max_directory_length_bytes;
      p_file_attributes^ [10].keyword := dmc$file_hash;
      p_file_attributes^ [10].file_hash := directory_file_hash;
      p_file_attributes^ [11].keyword := dmc$class;
      p_file_attributes^ [11].class := dmc$default_class;
      p_file_attributes^ [12].keyword := dmc$class_ordinal;
      p_file_attributes^ [12].ordinal := dmc$default_class_ordinal;

      build_stored_df_fmd_header (p_file_attributes, directory_stored_df_fmd, status);
      IF NOT status.normal THEN
        EXIT /build_directory/;
      IFEND;

      PUSH p_fmd_attributes: [1 .. 3];

      directory_length_in_bytes := #SIZE (dmt$ms_volume_directory_head) + number_directory_entries * #SIZE
            (dmt$ms_volume_directory_entry);

      IF directory_length_in_bytes > dmc$max_directory_length_bytes THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$max_dir_length_exceeded,
          'directory byte length > max', status);
        EXIT /build_directory/;
      IFEND;

      p_fmd_attributes^ [1].keyword := dmc$recorded_vsn;
      p_fmd_attributes^ [1].recorded_vsn := recorded_vsn;
      p_fmd_attributes^ [2].keyword := dmc$internal_vsn;
      p_fmd_attributes^ [2].internal_vsn := internal_vsn;
      p_fmd_attributes^ [3].keyword := dmc$device_file_list_index;
      p_fmd_attributes^ [3].device_file_list_index := dmc$directory_dfl_index;

      build_stored_df_fmd_subfile (p_fmd_attributes, directory_stored_df_fmd, status);
      IF NOT status.normal THEN
        EXIT /build_directory/;
      IFEND;

      dmp$attach_device_file_by_fmd (directory_global_file_name, directory_stored_df_fmd,
            file_already_attached, directory_sfid, status);
      IF NOT status.normal THEN
        EXIT /build_directory/;
      IFEND;

      IF file_already_attached THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$duplicate_device_file_gfn,
          'directory gfn already attached', status);
        EXIT /build_directory/;
      IFEND;

      gfp$get_fde_p (directory_sfid, p_fde);
      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
      dmp$get_fmd_by_index (p_dfd, 1, p_directory_fmd);

      p_directory_fmd^.fmd_allocated_length := ((directory_length_in_bytes +
            dmc$directory_allocation_size - 1)
            DIV dmc$directory_allocation_size) * dmc$directory_allocation_size;
      p_directory_fmd^.avt_index := avt_index;

    /directory_file_attached/
      BEGIN
        build_faus (directory_cylinder_range, directory_length_in_bytes, dmc$directory_allocation_size,
              dmc$directory_transfer_size, directory_sfid, status);
        IF NOT status.normal THEN
          EXIT /directory_file_attached/;
        IFEND;

      /build_device_file_list_entry/
        BEGIN
          dmp$get_fau_entry (p_dfd, 0, p_fau_entry);
          directory_dfle.pad := 0;
          directory_dfle.flags := dmc$dfle_assigned_to_file;
          directory_dfle.dau_chain_status := dmc$dau_chain_linked;
          directory_dfle.daus_per_allocation_unit := p_directory_fmd^.daus_per_allocation_unit;
          directory_dfle.end_of_file := ((directory_length_in_bytes + osv$page_size - 1) DIV osv$page_size) *
                osv$page_size;
          directory_dfle.end_of_information := ((directory_length_in_bytes + osv$page_size - 1) DIV
                osv$page_size) * osv$page_size;
          directory_dfle.file_byte_address := 0;
          directory_dfle.file_hash := directory_sfid.file_hash;
          directory_dfle.file_kind := gfc$fk_device_file;
          directory_dfle.first_dau_address := p_fau_entry^.dau_address;
          directory_dfle.global_file_name := directory_global_file_name;
          directory_dfle.logical_length := ((directory_length_in_bytes + osv$page_size - 1) DIV osv$page_size)
                * osv$page_size;
          directory_dfle.fmd_length := ((directory_length_in_bytes + dmc$directory_allocation_size - 1)
                DIV dmc$directory_allocation_size) * dmc$directory_allocation_size;
          directory_dfle.login_set := $dmt$dfl_login_set [];
        END /build_device_file_list_entry/;
        {
        { put device file list entry into dfl.
        {

        p_dfl^.entries [dmc$directory_dfl_index] := directory_dfle;

        segment_pointer.kind := mmc$sequence_pointer;
        dmp$open_file (directory_sfid, osc$os_ring_1, osc$os_ring_1, mmc$sar_write_extend,
           mmc$as_sequential, segment_pointer, status);
        IF NOT status.normal THEN
          EXIT /directory_file_attached/;
        IFEND;

        p_directory_seq := segment_pointer.seq_pointer;
        RESET p_directory_seq;
        NEXT p_directory: [1 .. number_directory_entries] IN p_directory_seq;

        {
        { build directory
        {

        dmp$set_update_lock (avt_index, {wait =} TRUE, able);

        /directory_locked/
          BEGIN
            p_directory^.header.number_of_entries := number_directory_entries;
            FOR directory_index := 1 TO number_directory_entries DO
              p_directory^.entries [directory_index].entry_available := TRUE;
              p_directory^.entries [directory_index].user_supplied_name := osc$null_name;
            FOREND;
            {
            { create entry for dat
            {
            p_directory^.entries [dmc$dat_directory_index].entry_available := FALSE;
            p_directory^.entries [dmc$dat_directory_index].global_file_name := dat_global_file_name;
            p_directory^.entries [dmc$dat_directory_index].user_supplied_name := dat_user_supplied_name;
            p_directory^.entries [dmc$dat_directory_index].stored_df_fmd := dat_stored_df_fmd;
            {
            { create entry for dflt
            {
            p_directory^.entries [dmc$dflt_directory_index].entry_available := FALSE;
            p_directory^.entries [dmc$dflt_directory_index].global_file_name := dflt_global_file_name;
            p_directory^.entries [dmc$dflt_directory_index].user_supplied_name := dflt_user_supplied_name;
            p_directory^.entries [dmc$dflt_directory_index].stored_df_fmd := dflt_stored_df_fmd;
            {
            { create entry for login table
            {
            p_directory^.entries [dmc$login_table_dfl_index].entry_available := FALSE;
            p_directory^.entries [dmc$login_table_dfl_index].global_file_name := login_table_global_file_name;
            p_directory^.entries [dmc$login_table_dfl_index].user_supplied_name :=
                  login_table_user_supplied_name;
            p_directory^.entries [dmc$login_table_dfl_index].stored_df_fmd := login_table_stored_df_fmd;
            {
            { create entry for directory
            {
            p_directory^.entries [dmc$directory_directory_index].entry_available := FALSE;
            p_directory^.entries [dmc$directory_directory_index].global_file_name :=
                  directory_global_file_name;
            p_directory^.entries [dmc$directory_directory_index].user_supplied_name :=
                  directory_user_supplied_name;
            p_directory^.entries [dmc$directory_directory_index].stored_df_fmd := directory_stored_df_fmd;
            {
            { reserve entry for label
            {
            p_directory^.entries [dmc$label_directory_index].entry_available := FALSE;
          END /directory_locked/;

         dmp$clear_update_lock (avt_index);

        {
        { update dat to reflect directory file allocation units
        {
        update_dat_entries (p_dat, dmc$directory_dfl_index, p_dfd, avt_index);

      END /directory_file_attached/;
      IF NOT status.normal THEN
        detach_file (p_directory, directory_sfid, local_status);
      IFEND;

    END /build_directory/;

  PROCEND build_volume_directory;
  ?? TITLE := 'build_login_table', EJECT ??

  PROCEDURE build_login_table (avt_index: dmt$active_volume_table_index;
        recorded_vsn: rmt$recorded_vsn;
        internal_vsn: dmt$internal_vsn;
        p_dat: ^dmt$ms_device_allocation_table;
        p_dfl: ^dmt$ms_device_file_list_table;
    VAR status: ost$status);

    VAR
      able: boolean,
      file_already_attached: boolean,
      highest_login_table_index: dmt$login_table_entry_index,
      local_status: ost$status,
      login_cylinder_range: cylinder_range_type,
      login_table_dfle: dmt$ms_device_file_list_entry,
      login_table_file_hash: dmt$file_hash,
      login_table_index: dmt$login_table_entry_index,
      login_table_length_in_bytes: amt$file_byte_address,
      login_table_sfid: dmt$system_file_id,
      lowest_login_table_index: dmt$login_table_entry_index,
      number_login_table_entries: dmt$login_table_entries,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fmd_attributes: ^array [1 .. * ] of dmt$fmd_attribute,
      p_fau_entry: ^dmt$file_allocation_unit,
      p_fde: gft$file_desc_entry_p,
      p_file_attributes: ^array [1 .. * ] of dmt$file_attribute,
      p_login_table: ^dmt$ms_mainframe_login_table,
      p_login_table_fmd: ^dmt$file_medium_descriptor,
      p_login_table_seq: ^SEQ ( * ),
      segment_pointer: mmt$segment_pointer;

    status.normal := TRUE;
    p_login_table := NIL;

  /create_login_table/
    BEGIN
      login_table_user_supplied_name (12, rmc$recorded_vsn_size) := recorded_vsn;

      osp$generate_unique_binary_name (login_table_global_file_name, status);
      IF NOT status.normal THEN
        EXIT /create_login_table/;
      IFEND;

      dmp$generate_gfn_hash (login_table_global_file_name, login_table_file_hash);

      number_login_table_entries := dmc$default_login_table_entries;
      login_cylinder_range.lowest_cylinder := 1;
      login_cylinder_range.highest_cylinder := cylinders_per_device - 1;

      PUSH p_file_attributes: [1 .. 12];

      p_file_attributes^ [1].keyword := dmc$file_kind;
      p_file_attributes^ [1].file_kind := gfc$fk_device_file;
      p_file_attributes^ [2].keyword := dmc$overflow;
      p_file_attributes^ [2].overflow_allowed := FALSE;
      p_file_attributes^ [3].keyword := dmc$requested_allocation_size;
      p_file_attributes^ [3].requested_allocation_size := dmc$login_table_allocation_size;
      p_file_attributes^ [4].keyword := dmc$requested_transfer_size;
      p_file_attributes^ [4].requested_transfer_size := dmc$login_table_transfer_size;
      p_file_attributes^ [5].keyword := dmc$requested_volume;
      p_file_attributes^ [5].requested_volume.recorded_vsn := recorded_vsn;
      p_file_attributes^ [5].requested_volume.setname := '    ';
      p_file_attributes^ [6].keyword := dmc$clear_space;
      p_file_attributes^ [6].required := TRUE;
      p_file_attributes^ [7].keyword := dmc$preset_value;
      p_file_attributes^ [7].preset_value := 0;
      p_file_attributes^ [8].keyword := dmc$locked_file;
      p_file_attributes^ [8].file_lock.required := FALSE;
      p_file_attributes^ [9].keyword := dmc$file_limit;
      p_file_attributes^ [9].limit := dmc$max_login_table_lngth_bytes;
      p_file_attributes^ [10].keyword := dmc$file_hash;
      p_file_attributes^ [10].file_hash := login_table_file_hash;
      p_file_attributes^ [11].keyword := dmc$class;
      p_file_attributes^ [11].class := dmc$default_class;
      p_file_attributes^ [12].keyword := dmc$class_ordinal;
      p_file_attributes^ [12].ordinal := dmc$default_class_ordinal;

      build_stored_df_fmd_header (p_file_attributes, login_table_stored_df_fmd, status);
      IF NOT status.normal THEN
        EXIT /create_login_table/;
      IFEND;

      PUSH p_fmd_attributes: [1 .. 3];

      login_table_length_in_bytes := #SIZE (dmt$ms_mf_login_table_header) + number_login_table_entries * #SIZE
            (dmt$ms_mf_login_table_entry);

      p_fmd_attributes^ [1].keyword := dmc$recorded_vsn;
      p_fmd_attributes^ [1].recorded_vsn := recorded_vsn;
      p_fmd_attributes^ [2].keyword := dmc$internal_vsn;
      p_fmd_attributes^ [2].internal_vsn := internal_vsn;
      p_fmd_attributes^ [3].keyword := dmc$device_file_list_index;
      p_fmd_attributes^ [3].device_file_list_index := dmc$login_table_dfl_index;

      build_stored_df_fmd_subfile (p_fmd_attributes, login_table_stored_df_fmd, status);
      IF NOT status.normal THEN
        EXIT /create_login_table/;
      IFEND;

      dmp$attach_device_file_by_fmd (login_table_global_file_name, login_table_stored_df_fmd,
            file_already_attached, login_table_sfid, status);
      IF NOT status.normal THEN
        EXIT /create_login_table/;
      IFEND;

      IF file_already_attached THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$duplicate_device_file_gfn,
          'login table gfn already atttached', status);
        EXIT /create_login_table/;
      IFEND;

      gfp$get_fde_p (login_table_sfid, p_fde);
      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
      dmp$get_fmd_by_index (p_dfd, 1, p_login_table_fmd);

      p_login_table_fmd^.fmd_allocated_length := ((login_table_length_in_bytes +
            dmc$login_table_allocation_size - 1) DIV dmc$login_table_allocation_size) *
            dmc$login_table_allocation_size;
      p_login_table_fmd^.avt_index := avt_index;

    /login_table_attached/
      BEGIN
        build_faus (login_cylinder_range, login_table_length_in_bytes, dmc$login_table_allocation_size,
              dmc$login_table_transfer_size, login_table_sfid, status);
        IF NOT status.normal THEN
          EXIT /login_table_attached/;
        IFEND;

      /build_device_file_list_entry/
        BEGIN
          dmp$get_fau_entry (p_dfd, 0, p_fau_entry);
          login_table_dfle.pad := 0;
          login_table_dfle.flags := dmc$dfle_assigned_to_file;
          login_table_dfle.dau_chain_status := dmc$dau_chain_linked;
          login_table_dfle.daus_per_allocation_unit := p_login_table_fmd^.daus_per_allocation_unit;
          login_table_dfle.end_of_file := ((login_table_length_in_bytes + osv$page_size - 1) DIV
                osv$page_size) * osv$page_size;
          login_table_dfle.end_of_information := ((login_table_length_in_bytes + osv$page_size - 1) DIV
                osv$page_size) * osv$page_size;
          login_table_dfle.file_byte_address := 0;
          login_table_dfle.file_hash := login_table_sfid.file_hash;
          login_table_dfle.file_kind := gfc$fk_device_file;
          login_table_dfle.first_dau_address := p_fau_entry^.dau_address;
          login_table_dfle.global_file_name := login_table_global_file_name;
          login_table_dfle.logical_length := ((login_table_length_in_bytes + osv$page_size - 1) DIV
                osv$page_size) * osv$page_size;
          login_table_dfle.fmd_length := ((login_table_length_in_bytes + dmc$login_table_allocation_size -
                1) DIV dmc$login_table_allocation_size) * dmc$login_table_allocation_size;
          login_table_dfle.login_set := $dmt$dfl_login_set [];
        END /build_device_file_list_entry/;

        {
        { put device file list entry into dfl.
        {

        p_dfl^.entries [dmc$login_table_dfl_index] := login_table_dfle;

        lowest_login_table_index := LOWERVALUE (login_table_index);
        highest_login_table_index := lowest_login_table_index;
        WHILE number_login_table_entries > 1 DO
          highest_login_table_index := SUCC (highest_login_table_index);
          number_login_table_entries := number_login_table_entries - 1;
        WHILEND;

        segment_pointer.kind := mmc$sequence_pointer;
        dmp$open_file (login_table_sfid, osc$os_ring_1, osc$os_ring_1, mmc$sar_write_extend,
           mmc$as_sequential, segment_pointer, status);
        IF NOT status.normal THEN
          EXIT /login_table_attached/;
        IFEND;

        p_login_table_seq := segment_pointer.seq_pointer;
        RESET p_login_table_seq;
        NEXT p_login_table: [lowest_login_table_index .. highest_login_table_index] IN p_login_table_seq;

        dmp$set_update_lock (avt_index, {wait =} TRUE, able);

        /login_table_locked/
          BEGIN
            p_login_table^.header.lower_bound := lowest_login_table_index;
            p_login_table^.header.upper_bound := highest_login_table_index;
            p_login_table^.header.sequence := 0;
            {
            { initialize the login table entries.
            {
            FOR login_table_index := lowest_login_table_index TO highest_login_table_index DO
              p_login_table^.body [login_table_index].login_status := dmc$lt_entry_available;
            FOREND;
          END /login_table_locked/;

          dmp$clear_update_lock (avt_index);

        {
        { update dat to reflect login table allocation units
        {
        update_dat_entries (p_dat, dmc$login_table_dfl_index, p_dfd, avt_index);

      END /login_table_attached/;
      detach_file (p_login_table, login_table_sfid, local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;

    END /create_login_table/;

  PROCEND build_login_table;
?? TITLE := '  build_stored_df_fat', EJECT ??
  PROCEDURE build_stored_df_fat (p_fde: ^gft$file_descriptor_entry;
        p_dfd: ^dmt$disk_file_descriptor;
        p_fmd: ^dmt$file_medium_descriptor;
    VAR p_stored_fat: ^dmt$stored_ms_device_file_fat;
    VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      fau_index: dmt$fau_entries,
      flag_usage: pmt$initialization_value,
      p_fau_entry: ^dmt$file_allocation_unit;

    status.normal := TRUE;

    p_stored_fat^.header.allocation_style := p_fmd^.allocation_style;
    p_stored_fat^.header.byte_address := 0;
    p_stored_fat^.header.bytes_per_mau := p_fmd^.bytes_per_mau;
    p_stored_fat^.header.clear_space := TRUE;
    p_stored_fat^.header.daus_per_allocation_unit := p_fmd^.daus_per_allocation_unit;
    p_stored_fat^.header.daus_per_cylinder := p_fmd^.daus_per_cylinder;
    p_stored_fat^.header.daus_per_transfer_unit := dmc$min_daus_transfer;
    p_stored_fat^.header.global_file_name := p_fde^.global_file_name;
    p_stored_fat^.header.maus_per_allocation_unit := p_dfd^.bytes_per_allocation DIV p_fmd^.bytes_per_mau;
    p_stored_fat^.header.maus_per_dau := p_fmd^.maus_per_dau;
    p_stored_fat^.header.maus_per_transfer_unit := p_fmd^.maus_per_transfer_unit;
{ Flag_usage is used here only to make others aware that this value must not be changed in the future.
{ As the stored fat is wriiten to disk, changing its type will cause incompatibility with other disks
{ already initialized with previous versions.
    flag_usage := pmc$initialize_to_zero;
    p_stored_fat^.header.preset_value := 0;

    {Assume sequential allocation

    byte_address := 0;
    fau_index := LOWERBOUND (p_stored_fat^.file_allocation_units);
    p_stored_fat^.header.number_faus := 0;

    WHILE byte_address < p_fmd^.fmd_allocated_length DO
      dmp$get_fau_entry (p_dfd, byte_address, p_fau_entry);
      p_stored_fat^.file_allocation_units [fau_index].dau_address := p_fau_entry^.dau_address;
      p_stored_fat^.file_allocation_units [fau_index].state := dmc$fau_initialized;
      p_stored_fat^.file_allocation_units [fau_index].status := dmc$no_change_required;
      p_stored_fat^.header.number_faus := p_stored_fat^.header.number_faus + 1;
      byte_address := byte_address + p_dfd^.bytes_per_allocation;
      fau_index := fau_index + 1;
    WHILEND;
  PROCEND build_stored_df_fat;
?? TITLE := '  build_stored_df_fmd_header', EJECT ??
  PROCEDURE build_stored_df_fmd_header (p_file_attributes: ^array [ * ] OF dmt$file_attribute;
    VAR df_fmd: dmt$device_file_stored_fmd;
    VAR status: ost$status);

    VAR
      p_df_fmd: ^dmt$device_file_stored_fmd,
      header_index: integer,
      p_stored_fmd_version_number: ^dmt$stored_ms_version_number,
      p_df_fmd_header: ^dmt$stored_ms_fmd_header,
      keyword: dmt$file_attribute_keywords;

    status.normal := TRUE;
    status.condition := 0;

    p_df_fmd := ^df_fmd;

    RESET p_df_fmd;

    NEXT p_stored_fmd_version_number IN p_df_fmd;
    IF p_stored_fmd_version_number = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
        'FMD too small - dmp$build_stored_df_fmd_header.', status);
      RETURN;
    IFEND;

    p_stored_fmd_version_number^ := dmc$current_fmd_version;

    NEXT p_df_fmd_header: [dmc$current_fmd_version] IN p_df_fmd;
    IF p_df_fmd_header = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
        'FMD too small - dmp$build_stored_df_fmd_header.', status);
      RETURN;
    IFEND;

    p_df_fmd_header^.version_0_0.number_fmds := 1;

    FOR header_index := LOWERBOUND (p_file_attributes^) TO UPPERBOUND (p_file_attributes^) DO
      keyword := p_file_attributes^ [header_index].keyword;
      CASE keyword OF
      = dmc$clear_space =
        p_df_fmd_header^.version_0_0.clear_space := p_file_attributes^ [header_index].required;
      = dmc$file_hash =
        p_df_fmd_header^.version_0_0.file_hash := p_file_attributes^ [header_index].file_hash;
      = dmc$file_limit =
        p_df_fmd_header^.version_0_0.file_limit := p_file_attributes^ [header_index].limit;
      = dmc$file_kind =
        p_df_fmd_header^.version_0_0.file_kind := p_file_attributes^ [header_index].file_kind;
      = dmc$locked_file =
        p_df_fmd_header^.version_0_0.locked_file := p_file_attributes^ [header_index].file_lock;
      = dmc$overflow =
        p_df_fmd_header^.version_0_0.overflow_allowed := p_file_attributes^ [header_index].overflow_allowed;
      = dmc$preset_value =
        p_df_fmd_header^.version_0_0.preset_value := p_file_attributes^ [header_index].preset_value;
      = dmc$requested_allocation_size =
        p_df_fmd_header^.version_0_0.requested_allocation_size := p_file_attributes^ [header_index].
              requested_allocation_size;
      = dmc$class =
        p_df_fmd_header^.version_0_0.requested_class := p_file_attributes^ [header_index].class;
      = dmc$class_ordinal =
        p_df_fmd_header^.version_0_0.requested_class_ordinal := p_file_attributes^ [header_index].ordinal;
      = dmc$requested_transfer_size =
        p_df_fmd_header^.version_0_0.requested_transfer_size := p_file_attributes^ [header_index].
              requested_transfer_size;
      = dmc$requested_volume =
        p_df_fmd_header^.version_0_0.requested_volume := p_file_attributes^ [header_index].requested_volume;
      ELSE
      CASEND;
    FOREND;

  PROCEND build_stored_df_fmd_header;
?? TITLE := '  build_stored_df_fmd_subfile', EJECT ??
  PROCEDURE build_stored_df_fmd_subfile (p_fmd_attributes: ^array [1 .. * ] OF
      dmt$fmd_attribute;
    VAR df_fmd: dmt$device_file_stored_fmd;
    VAR status: ost$status);

    VAR
      p_stored_fmd_version_number: ^dmt$stored_ms_version_number,
      p_df_fmd_header: ^dmt$stored_ms_fmd_header,
      p_df_fmd: ^dmt$device_file_stored_fmd,
      p_df_fmd_subfile: ^dmt$stored_ms_fmd_subfile,
      keyword: dmt$file_attribute_keywords,
      attribute_index: integer;

    status.normal := TRUE;
    status.condition := 0;

    p_df_fmd := ^df_fmd;

    RESET p_df_fmd;

    NEXT p_stored_fmd_version_number IN p_df_fmd;
    IF p_stored_fmd_version_number = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
        'FMD too small - dmp$build_stored_df_fmd_subfile.', status);
      RETURN;
    IFEND;

    NEXT p_df_fmd_header: [dmc$current_fmd_version] IN p_df_fmd;
    IF p_df_fmd_header = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
        'FMD too small - dmp$build_stored_df_fmd_subfile.', status);
      RETURN;
    IFEND;

    NEXT p_df_fmd_subfile: [dmc$current_fmd_version] IN p_df_fmd;
    IF p_df_fmd_subfile = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
        'FMD too small - dmp$build_stored_df_fmd_subfile.', status);
      RETURN;
    IFEND;

    p_df_fmd_subfile^.version_0_0.stored_byte_address := 0;

    FOR attribute_index := LOWERBOUND (p_fmd_attributes^) TO UPPERBOUND (p_fmd_attributes^) DO
      keyword := p_fmd_attributes^ [attribute_index].keyword;
      CASE keyword OF
      = dmc$device_file_list_index =
        p_df_fmd_subfile^.version_0_0.device_file_list_index := p_fmd_attributes^ [attribute_index].
              device_file_list_index;
      = dmc$internal_vsn =
        p_df_fmd_subfile^.version_0_0.internal_vsn := p_fmd_attributes^ [attribute_index].internal_vsn;
      = dmc$recorded_vsn =
        p_df_fmd_subfile^.version_0_0.recorded_vsn := p_fmd_attributes^ [attribute_index].recorded_vsn;
      ELSE
      CASEND;
    FOREND;

  PROCEND build_stored_df_fmd_subfile;
?? TITLE := ' detach_file', EJECT ??

{   The purpose of this procedure is to optionally (p_file <> NIL) write
{ modified pages to disk and close the file and then to detach the file.  If
{ modified pages can't be written to disk, they are removed from memory.  This
{ is done to bypass the fault tolerant feature of dmp$detach_file which keeps a
{ file table entry around for any file whose pages can't be written to disk.
{ Since the initialize volume process always deletes the AVT entry after it
{ completes, bad things will happen later if a file table entry is kept around
{ pointing to an AVT entry that is not.  Memory Manager periodically tries to
{ flush modified pages to disk which will cause access to the file table entry
{ left pointing to the unused (or possibly reused) AVT entry.

  PROCEDURE detach_file (
        p_file: ^cell;
        sfid: gft$system_file_identifier;
    VAR status: ost$status);

    VAR
      file_modified: boolean,
      fmd_modified: boolean,
      local_status: ost$status;

    status.normal := TRUE;

    IF (p_file <> NIL) THEN
      mmp$write_modified_pages (p_file, UPPERVALUE (ost$byte_count), osc$wait, status);

      IF NOT status.normal THEN
        mmp$free_pages (p_file, UPPERVALUE (ost$byte_count), osc$wait, local_status);
      IFEND;

      dmp$close_file (p_file, local_status);

      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;
    IFEND;

    dmp$detach_device_file (sfid, file_modified, fmd_modified, local_status);

    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND detach_file;
  ?? TITLE := 'get_device_flaws', EJECT ??
  PROCEDURE get_device_flaws (logical_unit_number: iot$logical_unit;
        flaw_map_locations: array [1 .. * ] OF dmt$flaw_map_address;
    VAR p_device_flaw_list: ^dmt$ms_flaw_list;
    VAR status: ost$status);

    VAR
      flaw_map_location_index: integer,
      flaw_map_address: dmt$flaw_map_address,
      p_flawed_daus: ^array [1 .. 120] of dmt$flaw_list_entry,
      flawed_daus_index: 0 .. 120,
      starting_flawed_dau_address: dmt$dau_address,
      number_consecutive_flawed_daus: dmt$dau_address,
      number_consecutive_flawed_maus: dmt$mau_address,
      number_consecutive_flawed_sect: integer,
      flawed_mau_address: dmt$mau_address,
      flawed_sector_address: integer,
      mau_address: dmt$mau_address,
      mau_byte_offset: dmt$bytes_per_mau,
      p_bytes: ^array [1 .. * ] of cell,
      p_flaw_map: ^array [1 .. * ] of dmt$flaw_map_entry,
      read_length_in_bytes: ost$byte_count,
      flaw_map_index: 1 .. 120,
      termination_flaw_map_entry: [STATIC] dmt$flaw_map_entry := [FALSE, FALSE, 0, 0, 0],
      flaw_map_entry: dmt$flaw_map_entry,
      p_buffer: ^SEQ ( * ),
      device_address: dmt$ms_logical_device_address,
      number_flaw_map_entries: integer,
      read_status: ost$status,
      p_completion_status: ^iot$completion_status;

    status.normal := TRUE;

    p_device_flaw_list := NIL;

    PUSH p_flawed_daus;

    flawed_daus_index := 0;

    PUSH p_buffer: [[REP bytes_per_mau OF cell]];
    RESET p_buffer;

    device_address.maus_per_position := maus_per_cylinder;
    device_address.logical_unit_number := logical_unit_number;
    device_address.transfer_length := 1;
    device_address.transfer_mau_offset := 0;
    device_address.write_translation := FALSE;
    read_length_in_bytes := bytes_per_mau;

  /flaw_map_addresses/
    FOR flaw_map_location_index := 1 TO UPPERBOUND (flaw_map_locations) DO
      flaw_map_address := flaw_map_locations [flaw_map_location_index];
      mau_address := flaw_map_address.mau_address;
      mau_byte_offset := flaw_map_address.mau_byte_offset;

    /flaw_map_processing/
      BEGIN
        device_address.allocation_unit_mau_address := mau_address;
        iop$mass_storage_io (#LOC (p_buffer^), read_length_in_bytes, ioc$read_uft, device_address,
              TRUE, p_completion_status, read_status);
        IF NOT read_status.normal THEN
          status := read_status;
          EXIT /flaw_map_processing/;
        IFEND;
        NEXT p_bytes: [1 .. mau_byte_offset] IN p_buffer;
        IF p_bytes = NIL THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$flaw_map_positioning_error,
            'p_bytes = NIL - DMMIVOL', status);
          RETURN;
        IFEND;
        number_flaw_map_entries := (read_length_in_bytes - mau_byte_offset) DIV #SIZE (dmt$flaw_map_entry);
        IF number_flaw_map_entries > 120 THEN
          number_flaw_map_entries := 120;
        IFEND;
        NEXT p_flaw_map: [1 .. number_flaw_map_entries] IN p_buffer;
        IF p_flaw_map = NIL THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_process_flaw_map,
            'p_flaw_map = NIL - DMMIVOL', status);
          RETURN;
        IFEND;

      /process_flaw_map_entries/
        FOR flaw_map_index := 1 TO number_flaw_map_entries DO
          flaw_map_entry := p_flaw_map^ [flaw_map_index];
          IF flaw_map_entry = termination_flaw_map_entry THEN
            EXIT /process_flaw_map_entries/;
          IFEND;
          flawed_daus_index := flawed_daus_index + 1;
          {
          { compute dau address
          {
          starting_flawed_dau_address := flaw_map_entry.cylinder * daus_per_cylinder;
          flawed_sector_address := flaw_map_entry.track * sectors_per_track;
          number_consecutive_flawed_sect := 1;
          IF flaw_map_entry.sector_flaw_entry THEN
            IF flaw_map_entry.sector = 0 THEN
              number_consecutive_flawed_sect := sectors_per_track;
            ELSE
              flawed_sector_address := flawed_sector_address + flaw_map_entry.sector;
            IFEND;
          IFEND;
          flawed_mau_address := flawed_sector_address DIV sectors_per_mau;
          number_consecutive_flawed_maus := (number_consecutive_flawed_sect + sectors_per_mau - 1) DIV
                sectors_per_mau;
          starting_flawed_dau_address := starting_flawed_dau_address + (flawed_mau_address DIV maus_per_dau);
          number_consecutive_flawed_daus := (number_consecutive_flawed_maus + maus_per_dau - 1) DIV
                maus_per_dau;
          p_flawed_daus^ [flawed_daus_index].dau_address := starting_flawed_dau_address;
          p_flawed_daus^ [flawed_daus_index].number_flawed_daus := number_consecutive_flawed_daus;
        FOREND /process_flaw_map_entries/;
      END /flaw_map_processing/;
    FOREND /flaw_map_addresses/;
    IF flawed_daus_index > 0 THEN
      ALLOCATE p_device_flaw_list: [1 .. flawed_daus_index] IN osv$mainframe_wired_heap^;
      p_device_flaw_list^ := p_flawed_daus^;
    IFEND;
  PROCEND get_device_flaws;
?? TITLE := ' find_cip_cylinder', EJECT ??

{  PURPOSE:
{    This procedure determines whether a cip exists on the given device.

  PROCEDURE find_cip_cylinder
    (    logical_unit_number: iot$logical_unit;
     VAR cip_cylinder: dmt$device_position;
     VAR cip_found: boolean);

    VAR
      ds_sector: dst$deadstart_sector,
      ds_sector_device_path: dst$ds_sector_device_path,
      ds_sector_seq_p: ^SEQ (*),
      identifier: ost$status_identifier,
      msi: cmt$mass_storage_information,
      number: ost$status_condition_number,
      status: ost$status,
      str: string (100),
      str_size: integer;

    cip_found := FALSE;
    status.normal := TRUE;

    CASE dsv$mainframe_type OF
    = dsc$mt_962_972_mainframe, dsc$mt_992_mainframe, dsc$mt_2000_mainframe =
      RETURN;
    ELSE
    CASEND;

    { Retrieve the mass storage information for the given device.
    cmp$get_mass_storage_info (logical_unit_number, msi, status);

    IF NOT status.normal THEN
      IF (NOT cmv$post_deadstart) THEN
        IF status.condition = cme$it_not_cip_device THEN
          syp$trace_deadstart_message ('device does not support cip');
        ELSEIF (status.condition = cme$it_no_cip_access) OR
             (status.condition = cme$it_unusable_cip_access) THEN
          syp$trace_deadstart_message ('device as configured does not support cip');
        ELSE
          syp$trace_deadstart_message ('unable to retrieve mass storage info');
          osp$unpack_status_condition (status.condition, identifier, number);
          STRINGREP (str, str_size, 'status condition = ', identifier, number,
              ' status text = ', status.text.value (1, status.text.size));
          syp$trace_deadstart_message (str (1, str_size));
        IFEND;
      IFEND;
      RETURN;
    IFEND;

    ds_sector_device_path.iou_number := msi.iou_number;
    ds_sector_device_path.channel_number := msi.channel.number;
    ds_sector_device_path.unit_number := msi.unit_number;
    ds_sector_device_path.access_type := dsc$read_ds_sector;
    ds_sector_device_path.maus_per_cylinder := maus_per_cylinder;
    ds_sector_device_path.logical_unit_number := logical_unit_number;
    ds_sector_device_path.deadstart_sector_mau := (cylinders_per_device - 1) * maus_per_cylinder;

    { Retrieve the correct device path number and the disk type
    { for the given device.

    CASE msi.unit_type OF
    = cmc$ms844_4x =
      ds_sector_device_path.device_type := dmc$844_double_density;
      ds_sector_device_path.disk_type := dsc$small_sector_disk;
    = cmc$ms885_1x =
      ds_sector_device_path.device_type := dmc$885;
      ds_sector_device_path.disk_type := dsc$small_sector_disk;
    = cmc$ms885_4x =
      ds_sector_device_path.device_type := dmc$885;
      ds_sector_device_path.disk_type := dsc$small_sector_disk;
    = cmc$ms834_2 =
      ds_sector_device_path.device_type := dmc$834_isd1;
      ds_sector_device_path.unit_number := msi.control_module * 8 + msi.unit_number;
      ds_sector_device_path.disk_type := dsc$small_sector_disk;
    = cmc$ms895_2 =
      ds_sector_device_path.device_type := dmc$895;
      ds_sector_device_path.disk_type := dsc$small_sector_disk;
      IF (msi.storage_director_address > 1) OR
           (msi.head_of_string_controller > 1) THEN
        IF NOT cmv$post_deadstart THEN
          syp$trace_deadstart_message ('device does not support cip');
        IFEND;
        RETURN;
      IFEND;
      ds_sector_device_path.unit_number := (msi.storage_director_address * 100000(2))
            + (msi.head_of_string_controller * 10000(2))
            + ds_sector_device_path.unit_number;
    = cmc$msfsd_2 =
      ds_sector_device_path.device_type := dmc$836_isd2;
      ds_sector_device_path.unit_number := msi.control_module * 8 + msi.unit_number;
      ds_sector_device_path.disk_type := dsc$small_sector_disk;
    = cmc$msxmd_3 =
      ds_sector_device_path.device_type := dmc$xmd3;
      ds_sector_device_path.unit_number := msi.control_module * 8 + msi.unit_number;

{ Large sector disk indicates that the NOS/VE driver will determine
{ presence of CIP. For small sector disk, go through DFT and 2AP.

      ds_sector_device_path.disk_type := dsc$large_sector_disk;
    = cmc$msfsd2_s0 =
      ds_sector_device_path.device_type := dmc$9836_s0;
      ds_sector_device_path.disk_type := dsc$large_sector_disk;
    ELSE
      IF NOT cmv$post_deadstart THEN
        syp$trace_deadstart_message ('device does not support cip');
      IFEND;
      RETURN;
    CASEND;

    STRINGREP (str, str_size, 'attempting to read cip on device_type:',
          ds_sector_device_path.device_type, ' iou:',
          ds_sector_device_path.iou_number, ' channel:',
          ds_sector_device_path.channel_number, ' unit:',
          ds_sector_device_path.unit_number);
    IF NOT cmv$post_deadstart THEN
      syp$trace_deadstart_message (str (1, str_size));
    IFEND;
    {Read the deadstart sector on the given device.

    ds_sector_seq_p := #SEQ (ds_sector);
    RESET ds_sector_seq_p;
    dsp$access_deadstart_sector (ds_sector_device_path, ds_sector_seq_p, status);
    IF NOT status.normal THEN
      IF NOT cmv$post_deadstart THEN
        syp$display_deadstart_message
            ('WARNING -- Error attempting to access the deadstart sector');
      IFEND;
      RETURN;
    IFEND;

    { Determine if the deadstart sector is present on
    { this device.  If the deadstart sector is not present
    { then CIP is not installed on the device.

    IF (ds_sector.v1 <> dsc$special_cti_constant_1) OR
          (ds_sector.v2 <> dsc$special_cti_constant_2) OR
          (ds_sector.v4 <> dsc$special_cti_ipl_constant) THEN
      IF NOT cmv$post_deadstart THEN
        syp$trace_deadstart_message ('cip is not present on device');
      IFEND;
      RETURN;
    IFEND;

    { If the following addresses have a zero for the cylinder
    { value then the CIP installed is not a valid CIP.  The
    { following addresses must be checked in the following order.

    cip_cylinder := 0;
    IF ds_sector.msl <> 0 THEN
      cip_cylinder := ds_sector.msl;
    ELSEIF ds_sector.hvs_address.cylinder <> 0 THEN
      cip_cylinder := ds_sector.hvs_address.cylinder;
    ELSEIF ds_sector.cda_address.cylinder <> 0 THEN
      cip_cylinder := ds_sector.cda_address.cylinder;
    IFEND;

    IF cip_cylinder <> 0 THEN
      cip_found := TRUE;
    ELSE
      IF NOT cmv$post_deadstart THEN
        syp$trace_deadstart_message ('cip is not present on device');
      IFEND;
    IFEND;

  PROCEND find_cip_cylinder;
?? TITLE := 'get_deadstart_sector_flaws', EJECT ??
  PROCEDURE get_deadstart_sector_flaws (logical_unit_number: iot$logical_unit;
                                    VAR p_ds_sector_flaw_list: ^dmt$ms_flaw_list);

    VAR
      cip_found: boolean,
      msg: string (60),
      l: integer,
      starting_cylinder: dmt$device_position;

    p_ds_sector_flaw_list := NIL;

    find_cip_cylinder (logical_unit_number, starting_cylinder, cip_found);

    IF cip_found THEN
      ALLOCATE p_ds_sector_flaw_list: [1 .. 1] IN osv$mainframe_wired_heap^;
      p_ds_sector_flaw_list^ [1].dau_address := starting_cylinder *
            daus_per_cylinder;
      p_ds_sector_flaw_list^ [1].number_flawed_daus := daus_per_cylinder *
            (cylinders_per_device - starting_cylinder);
      IF NOT cmv$post_deadstart THEN
        STRINGREP (msg, l, 'cip present on device at cylinder ', starting_cylinder);
        syp$trace_deadstart_message (msg(1,l));
      IFEND;
    IFEND;

  PROCEND get_deadstart_sector_flaws;
?? TITLE := 'update_dat_entries', EJECT ??

  PROCEDURE update_dat_entries (
        p_dat: ^dmt$ms_device_allocation_table;
        dfl_index: dmt$device_file_list_index;
        p_dfd: ^dmt$disk_file_descriptor;
        avt_index: dmt$active_volume_table_index);

    VAR
      able: boolean,
      allocation_chain_position: dmt$allocation_chain_position,
      allocation_unit_dau_address: dmt$dau_address,
      byte_address: amt$file_byte_address,
      dau_index: dmt$dau_address,
      daus_per_allocation_unit: dmt$daus_per_allocation,
      fau_lower_bound: dmt$fau_entries,
      fau_upper_bound: dmt$fau_entries,
      fau_index: dmt$fau_entries,
      next_allocation_unit_dau: dmt$dau_address,
      p_fmd: ^dmt$file_medium_descriptor,
      p_fau_entry: ^dmt$file_allocation_unit;

    dmp$get_fmd_by_index (p_dfd, 1, p_fmd);
    daus_per_allocation_unit := p_fmd^.daus_per_allocation_unit;
    dmp$get_number_of_faus (p_dfd, fau_upper_bound);
    fau_lower_bound := 1;

    dmp$set_update_lock (avt_index, {wait =} TRUE, able);

    p_dat^.header.available := p_dat^.header.available -
          ((fau_upper_bound - fau_lower_bound + 1) * daus_per_allocation_unit);

    IF fau_upper_bound = fau_lower_bound THEN
      allocation_chain_position := dmc$first_and_last_allocation;
    ELSE
      allocation_chain_position := dmc$last_allocation;
    IFEND;
    next_allocation_unit_dau := 0;
    fau_index := fau_upper_bound;
    byte_address := p_dfd^.highest_offset_allocated;

    IF (byte_address DIV p_dfd^.bytes_per_allocation) <> (fau_upper_bound - fau_lower_bound + 1) THEN
      osp$system_error (' Initialize allocation failure', NIL);
    IFEND;

    REPEAT
      byte_address := byte_address - p_dfd^.bytes_per_allocation;
      dmp$get_fau_entry (p_dfd, byte_address, p_fau_entry);
      allocation_unit_dau_address := p_fau_entry^.dau_address;
      dau_index := allocation_unit_dau_address;
      IF p_fau_entry^.state = dmc$fau_free THEN
        osp$system_error (' Initialize allocation failure', #LOC (p_fau_entry));
      IFEND;

      REPEAT
        p_dat^.body [dau_index].dau_status := dmc$dau_assigned_to_file;
        p_dat^.body [dau_index].file_hash := p_fmd^.system_file_id.file_hash;
        p_dat^.body [dau_index].data_status := dmc$dau_data_initialized;
        p_dat^.body [dau_index].allocation_chain_position := allocation_chain_position;
        CASE allocation_chain_position OF
        = dmc$first_and_last_allocation, dmc$last_allocation =
          p_dat^.body [dau_index].high_dfl_index := dfl_index DIV dmc$dfl_index_converter;
          p_dat^.body [dau_index].low_dfl_index := dfl_index MOD dmc$dfl_index_converter;
        = dmc$first_allocation, dmc$middle_allocation =
          p_dat^.body [dau_index].next_allocation_unit_dau := next_allocation_unit_dau;
        ELSE
        CASEND;
        dau_index := dau_index + 1;
        allocation_chain_position := dmc$part_of_allocation_unit;
      UNTIL (dau_index >= (allocation_unit_dau_address + daus_per_allocation_unit));

      fau_index := fau_index - 1;
      IF fau_index = fau_lower_bound THEN
        allocation_chain_position := dmc$first_allocation;
      ELSE
        allocation_chain_position := dmc$middle_allocation;
      IFEND;
      next_allocation_unit_dau := allocation_unit_dau_address;
    UNTIL (fau_index < fau_lower_bound);

    dmp$clear_update_lock (avt_index);
  PROCEND update_dat_entries;
  ?? TITLE := 'preset_cylinder_0', EJECT ??
  PROCEDURE preset_cylinder_0 (logical_unit_number: iot$logical_unit;
                                maus_per_cylinder: dmt$maus_per_position);
    VAR
      status: ost$status,
      buffer: integer,
      device_address: dmt$ms_logical_device_address,
      p_completion_status: ^iot$completion_status;

    buffer := 0;
    device_address.preset_value := 0;
    device_address.transfer_mau_offset := 0;
    device_address.write_translation := TRUE;
    device_address.allocation_unit_mau_address := 0;
    device_address.au_was_previously_written := FALSE;
    device_address.maus_per_position := maus_per_cylinder;
    device_address.logical_unit_number := logical_unit_number;
    device_address.transfer_length := maus_per_cylinder;
    device_address.maus_per_allocation_unit := maus_per_cylinder;

    iop$mass_storage_io (#LOC (buffer), 0, ioc$write_mass_storage, device_address, TRUE,
          p_completion_status, status);
  PROCEND preset_cylinder_0;
  ?? TITLE := 'write_label_to_disk', EJECT ??
  PROCEDURE write_label_to_disk (logical_unit_number: iot$logical_unit;
        p_fmd: ^dmt$file_medium_descriptor;
        p_dfd: ^dmt$disk_file_descriptor;
        p_fau_entry: ^dmt$file_allocation_unit;
        p_p_data_buffer: ^SEQ ( * );
        number_bytes_to_write: amt$file_byte_address;
    VAR status: ost$status);

    VAR
      device_address: dmt$ms_logical_device_address,
      flag_usage: pmt$initialization_value,
      p_buffer: ^array [1 .. * ] of cell,
      p_completion_status: ^iot$completion_status,
      p_data_buffer: ^SEQ ( * ),
      p_read_buffer: ^SEQ ( * );

    status.normal := TRUE;
    IF number_bytes_to_write > p_dfd^.bytes_per_allocation THEN
      osp$system_error ('volume label size > allocation unit', #LOC(number_bytes_to_write));
    IFEND;

    p_data_buffer := p_p_data_buffer;
    RESET p_data_buffer;
    NEXT p_buffer: [1 .. number_bytes_to_write] IN p_data_buffer;

    PUSH p_read_buffer: [[REP p_dfd^.bytes_per_allocation OF cell]];
    pmp$zero_out_table (#LOC (p_read_buffer^), #SIZE (p_read_buffer^));

    device_address.maus_per_position := maus_per_cylinder;
    device_address.logical_unit_number := logical_unit_number;
    device_address.transfer_length := p_fmd^.maus_per_transfer_unit;
    device_address.transfer_mau_offset := 0;
    device_address.write_translation := TRUE;
    device_address.au_was_previously_written := FALSE;
    device_address.maus_per_allocation_unit := p_fmd^.daus_per_allocation_unit * p_fmd^.maus_per_dau;
{ Flag_usage is used here only to make others aware that this value must not be changed in the future.
{ As the stored fat is wriiten to disk, changing its type will cause incompatibility with other disks
{ already initialized with previous versions.
    flag_usage := pmc$initialize_to_zero;
    device_address.preset_value := 0;
    device_address.allocation_unit_mau_address := p_fau_entry^.dau_address * p_fmd^.maus_per_dau;

    iop$mass_storage_io (#LOC (p_buffer^), number_bytes_to_write, ioc$write_mass_storage, device_address,
          TRUE, p_completion_status, status);
    IF status.normal THEN   { attempt read of allocation unit
      p_fau_entry^.state := dmc$fau_initialized;
      device_address.write_translation := FALSE;
      iop$mass_storage_io (#LOC(p_read_buffer^), p_dfd^.bytes_per_allocation, ioc$read_mass_storage,
            device_address, TRUE, p_completion_status, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_read_verify_data,
          'unable to read verify data - write_label_to_disk', status);
      IFEND;
    IFEND;
  PROCEND write_label_to_disk;
?? TITLE := 'remember_device_flaws', EJECT ??

  PROCEDURE remember_device_flaws (volume_label: dmt$ms_volume_label;
                                   cylinders_per_device: dmt$device_position;
                                   avt_index: dmt$active_volume_table_index;
                               VAR p_existing_flaws: ^array [*] of flawed_dau;
                               VAR able_to_retain_flaws: boolean);

    VAR
      dat_attached: boolean,
      dat_open: boolean,
      status: ost$status,
      dat_sfid: dmt$system_file_id,
      segment_pointer: mmt$segment_pointer,
      p_dat_seq: ^ SEQ (*),
      p_dat: ^dmt$ms_device_allocation_table,
      p_dat_header: ^dmt$ms_device_alloc_table_head,
      number_of_daus: dmt$dau_address,
      number_of_flaws: dmt$dau_address,
      flaw_index: dmt$dau_address,
      index: dmt$dau_address,
      file_modified: boolean,
      fmd_modified: boolean;

?? SKIP := 3 ??
  PROCEDURE dat_condition_handler (mf: ost$monitor_fault;
                                   p_msa: ^ost$minimum_save_area;
                               VAR continue: syt$continue_option);

    VAR
      p_sac: ^mmt$segment_access_condition;

    IF mf.identifier = mmc$segment_fault_processor_id THEN
      p_sac := #LOC(mf.contents);
      CASE p_sac^.identifier OF
      = mmc$sac_io_read_error =
        IF NOT cmv$post_deadstart THEN
          syp$trace_deadstart_message ('unable to retain device flaws (I/O error on old DAT)');
        IFEND;
        IF p_existing_flaws <> NIL THEN
          FREE p_existing_flaws IN osv$mainframe_wired_heap^;
        IFEND;
        able_to_retain_flaws := FALSE;
        EXIT remember_device_flaws;
      ELSE
      CASEND;
    IFEND;

    syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);

  PROCEND dat_condition_handler;
?? SKIP := 3 ??

    dat_attached := FALSE;
    dat_open := FALSE;
    number_of_flaws := 0;
    able_to_retain_flaws := FALSE;
    segment_pointer.kind := mmc$sequence_pointer;

    dmp$attach_dat_from_label (volume_label, avt_index, dat_sfid, status);
    IF status.normal THEN
      dat_attached := TRUE;
      dmp$open_file (dat_sfid, osc$os_ring_1, osc$os_ring_1, mmc$sar_read, mmc$as_sequential,
            segment_pointer, status);
      IF status.normal THEN
       p_dat_seq := segment_pointer.seq_pointer;
       dat_open := TRUE;
      ELSE
        IF NOT cmv$post_deadstart THEN
          syp$trace_deadstart_message ('unable to retain device flaws (cannot open old DAT)');
        IFEND;
      IFEND;
    ELSE
      IF NOT cmv$post_deadstart THEN
        syp$trace_deadstart_message ('unable to retain device flaws (cannot attach old DAT)');
      IFEND;
    IFEND;

    IF status.normal THEN
      syp$establish_condition_handler (^dat_condition_handler);
      RESET p_dat_seq;
      NEXT p_dat_header IN p_dat_seq;

      IF p_dat_header = NIL THEN
        IF NOT cmv$post_deadstart THEN
          syp$trace_deadstart_message ('unable to retain device flaws (received NIL pointer)');
        IFEND;
      ELSEIF p_dat_header^.positions_per_device <> cylinders_per_device THEN
        IF NOT cmv$post_deadstart THEN
          syp$trace_deadstart_message ('unable to retain device flaws (# of cylinders mismatch)');
        IFEND;
      ELSE  {  this is likely the old DAT

        CASE p_dat_header^.version_number OF
        = dmc$dat_0_0 =

          number_of_daus := p_dat_header^.positions_per_device * p_dat_header^.daus_per_position;
          RESET p_dat_seq;
          NEXT p_dat: [dmc$min_dau_address .. number_of_daus - 1] IN p_dat_seq;
          IF p_dat <> NIL THEN
          /count_flaws_validate_dau_status/
            FOR index := LOWERBOUND (p_dat^.body) TO UPPERBOUND (p_dat^.body) DO
              CASE p_dat^.body [index].dau_status OF
              = dmc$dau_hardware_flawed, dmc$dau_software_flawed, dmc$dau_ass_to_mf_swr_flawed,
                  dmc$dau_ass_to_file_swr_flawed =
                number_of_flaws := number_of_flaws + 1;
              = dmc$dau_usable, dmc$dau_assigned_to_mainframe, dmc$dau_assigned_to_file =
                ;
              ELSE {  we've run into a dau status that is out of bounds
                IF NOT cmv$post_deadstart THEN
                  syp$trace_deadstart_message ('unable to retain device flaws (old DAT is damaged)');
                IFEND;
                number_of_flaws := 0;
                EXIT /count_flaws_validate_dau_status/;
              CASEND;
            FOREND /count_flaws_validate_dau_status/;

            IF number_of_flaws > 0 THEN
              ALLOCATE p_existing_flaws: [1 .. number_of_flaws] in osv$mainframe_wired_heap^;

              flaw_index := 1;
              FOR index := LOWERBOUND (p_dat^.body) TO UPPERBOUND (p_dat^.body) DO
                CASE p_dat^.body [index].dau_status OF
                = dmc$dau_hardware_flawed, dmc$dau_software_flawed, dmc$dau_ass_to_mf_swr_flawed,
                    dmc$dau_ass_to_file_swr_flawed =

                  p_existing_flaws^[flaw_index].dau_address := index;
                  p_existing_flaws^[flaw_index].kind_of_flaw := p_dat^.body [index].dau_status;
                  flaw_index := flaw_index + 1;

                ELSE
                CASEND;
              FOREND;
            IFEND;
          ELSE
            IF NOT cmv$post_deadstart THEN
              syp$trace_deadstart_message ('unable to retain device flaws (NIL pointer returned)');
            IFEND;
          IFEND;
        ELSE
          IF NOT cmv$post_deadstart THEN
            syp$trace_deadstart_message ('unable to retain device flaws (invalid DAT version number)');
          IFEND;
        CASEND;
      IFEND;

      syp$disestablish_cond_handler;
    IFEND;

    IF p_existing_flaws <> NIL THEN
      able_to_retain_flaws := TRUE;
    IFEND;

    IF dat_open THEN
      dmp$close_file (p_dat_seq, status);
    IFEND;
    IF dat_attached THEN
      dmp$detach_device_file (dat_sfid, file_modified, fmd_modified, status);
    IFEND;

  PROCEND remember_device_flaws;

MODEND dmm$initialize_volume;
*DECK DECK=DMM$JOB_ALLOCATOR EXPAND=TRUE
?? RIGHT := 110 ??
*copy osd$default_pragmats
?? NEWTITLE := 'NOSVE Device Management' ??
MODULE dmm$job_allocator;
?? PUSH (LISTEXT := ON) ??
?? TITLE := '  Common Decks', EJECT ??
*copyc amd$file_attributes
*copyc amt$file_byte_address
*copyc cyd$cybil_structure_definitions
*copyc dfp$begin_remote_core_call
*copyc dfp$end_remote_core_call
*copyc dfp$get_served_file_desc_p
*copyc dfp$send_remote_core_call
*copyc dfp$uncomplement_gfn
*copyc dmc$default_transfer_sizes
*copyc dmp$add_class_to_volume
*copyc dmp$analyze_dat_position
*copyc dmp$build_fmd_for_existing_file
*copyc dmp$clear_update_lock
*copyc dmp$close_file
*copyc dmp$create_fmds
*copyc dmp$create_fau_entry
*copyc dmp$fetch_eoi
*copyc dmp$get_active_vol_attributes
*copyc dmp$get_fau_entry
*copyc dmp$get_fmd_by_index
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_level_2_ptr
*copyc dmp$get_mat_pointer
*copyc dmp$get_total_allocated_length
*copyc dmp$get_unused_mfl_entry
*copyc dmp$increase_fmd_count
*copyc dmp$lock_avt_entry
*copyc dmp$open_dat
*copyc dmp$open_dflt
*copyc dmp$process_device_log_entry
*copyc dmp$reserve_fmd
*copyc dmp$search_active_volume_table
*copyc dmp$set_eoi
*copyc dmp$set_file_table_locator
*copyc dmp$set_update_lock
*copyc dmp$split_allocation_log
*copyc dmp$unlock_avt_entry
*copyc dmt$active_volume_table_index
*copyc dmt$allocation_size
*copyc dmt$assigned_ms_vol_attributes
*copyc dmt$chapter_number
*copyc dmt$device_allocation_unit
*copyc dmt$device_file_list_index
*copyc dmt$df_allocate_file_space
*copyc dmt$df_reallocate_file_space
*copyc dmt$error_condition_codes
*copyc dmt$file_allocation_descriptor
*copyc dmt$file_attributes
*copyc dmt$file_medium_descriptor
*copyc dmt$file_share_history
*copyc dmt$internal_vsn
*copyc dmt$mainframe_allocation_table
*copyc dmt$mat_converter
*copyc dmt$monitor_request_blocks
*copyc dmt$monitor_requests
*copyc dmt$ms_device_allocation_table
*copyc dmt$ms_device_file_list_entry
*copyc dmt$overflow_allowed
*copyc dmt$segment_file_information
*copyc dmt$server_file_output
*copyc dmv$active_volume_table
*copyc dmv$idle_system
*copyc dmv$internal_tasks_initiated
*copyc dmv$null_sfid
*copyc dmv$permanent_file_overflow
*copyc dmv$system_class
*copyc dmv$system_device_information
*copyc dmv$temporary_file_overflow
*copyc dmv$volume_selector
*copyc gfp$get_locked_fde_p
*copyc gfp$unlock_fde_p
*copyc i#call_monitor
*copyc i#move
*copyc iop$mass_storage_io
*copyc mme$condition_codes
*copyc mmp$close_device_file
*copyc mmp$fetch_offset_mod_pages_r1
*copyc mmp$open_file_by_sfid
*copyc mmp$write_modified_pages
*copyc mmt$segment_descriptor_table_ex
*copyc mmv$max_pages_no_file
*copyc osp$append_status_parameter
*copyc osp$clear_mainframe_sig_lock
*copyc osp$fatal_system_error
*copyc osp$initialize_sig_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osp$test_set_main_sig_lock
*copyc osp$unpack_status_identifier
*copyc oss$mainframe_paged_literal
*copyc ost$signature_lock
*copyc ost$status
*copyc ost$wait
*copyc osv$mainframe_wired_heap
*copyc osv$page_size
*copyc pmp$cycle
*copyc pmp$delay
*copyc pmp$get_executing_task_gtid
*copyc pmp$zero_out_table
*copyc rmc$mass_storage_class
*copyc rmd$volume_declarations
*copyc sfp$accumulate_file_space
*copyc syc$monitor_request_codes
*copyc syp$establish_condition_handler
*copyc syp$disestablish_cond_handler
*copyc syp$continue_to_cause
*copyc syt$monitor_status
?? POP ??
?? TITLE := '  Global Declarations', EJECT ??
  TYPE
    t$allocation_list = array [1 .. *] of dmt$dau_address,

    t$volume_selector = record
      class: dmt$class_member,
      class_ordinal: dmt$class_ordinal,
      recorded_vsn: rmt$recorded_vsn,
      set_name: stt$set_name,
      force_allocation_size: boolean,
      allocation_size: dmt$allocation_size,
    recend;

  VAR
    allocator_delay_time: [XDCL] integer := 5000;

  VAR
    dmv$q_devices_added: [XDCL, #GATE] integer := 0,
    dmv$q_add_lock: [XDCL, #GATE] ost$signature_lock,
    dmv$quick_deadstart: [XDCL] boolean := FALSE;

  VAR
    dmv$deadstart_disk_space: [XDCL] integer := 9175040 {Bytes};

  VAR
    dmv$maximum_allocation_size: [XDCL] integer := 256 * 1024;
?? TITLE := '  dmp$dat_purge_file', EJECT ??

  PROCEDURE [XDCL] dmp$dat_purge_file (gfn: dmt$global_file_name;
        dfl_index: dmt$device_file_list_index;
        avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      able: boolean,
      dat_chain: boolean,
      dat_sfid: gft$system_file_identifier,
      daus_per_allocation: dmt$daus_per_allocation,
      dfl_sfid: gft$system_file_identifier,
      file_found: boolean,
      file_hash: dmt$file_hash,
      first_dau: dmt$dau_address,
      local_status: ost$status,
      p_dfl: ^dmt$ms_device_file_list_table;

    dat_sfid := dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_allocation_table;
    dfl_sfid := dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_file_list_table;

    dmp$open_dflt (dfl_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend,
          mmc$as_sequential, p_dfl, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$set_update_lock (avt_index, TRUE, able);

    file_found := (p_dfl^.entries [dfl_index].flags = dmc$dfle_assigned_to_file) AND
          (p_dfl^.entries [dfl_index].global_file_name = gfn);

    IF file_found THEN
      dat_chain := (p_dfl^.entries [dfl_index].dau_chain_status = dmc$dau_chain_linked);
      first_dau := p_dfl^.entries [dfl_index].first_dau_address;
      daus_per_allocation := p_dfl^.entries [dfl_index].daus_per_allocation_unit;
      file_hash := p_dfl^.entries [dfl_index].file_hash;
      p_dfl^.entries [dfl_index].flags := dmc$dfle_available;

      mmp$write_modified_pages (p_dfl, #SIZE (p_dfl^), osc$wait, local_status);
      dat_chain := dat_chain AND local_status.normal;
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unknown_file, '', status);
      dat_chain := FALSE;
    IFEND;

    dmp$clear_update_lock (avt_index);

    dmp$close_file (p_dfl, local_status);

    IF dat_chain THEN
      dat_deallocate (dat_sfid, file_hash, daus_per_allocation, first_dau, avt_index, local_status);
    IFEND;
  PROCEND dmp$dat_purge_file;
?? TITLE := '  dmp$df_client_allocate_space_r1', EJECT ??
*copyc dmh$df_client_allocate_space_r1
  PROCEDURE [XDCL] dmp$df_client_allocate_space_r1
    (    fde_p: ^gft$file_descriptor_entry;
         system_file_id: gft$system_file_identifier;
         initial_byte_address: amt$file_byte_address;
         requested_bytes_to_allocate: amt$file_byte_address;
         file_space_limit: sft$file_space_limit_kind;
    VAR status: ost$status);

    VAR
      byte_offset: amt$file_byte_address,
      bytes_to_allocate: amt$file_byte_address,
      ignore_status: ost$status,
      local_fde_p: ^gft$file_descriptor_entry,
      local_status: ost$status,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_receive_parameters: ^dmt$df_allocate_file_space_inp,
      p_send_parameters: ^dmt$df_allocate_file_space_inp,
      p_send_to_server_params: dft$p_send_parameters,
      p_server_descriptor: dmt$p_server_descriptor,
      queue_entry_location: dft$rpc_queue_entry_location,
      remote_sfid: gft$system_file_identifier,
      served_family_table_index: dft$served_family_table_index,
      wait: [STATIC, READ, oss$mainframe_paged_literal] ost$wait := osc$wait;

    status.normal := TRUE;
    dfp$get_served_file_desc_p (fde_p, p_server_descriptor);
    IF (p_server_descriptor^.header.file_state = dfc$awaiting_recovery) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dfe$server_not_active, '',
           status);
      gfp$unlock_fde_p (fde_p);
      RETURN;
    ELSEIF (p_server_descriptor^.header.file_state = dfc$terminated) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dfe$server_has_terminated, '',
         status);
      gfp$unlock_fde_p (fde_p);
      RETURN;
    IFEND;
    served_family_table_index := p_server_descriptor^.header.served_family_table_index;
    remote_sfid := p_server_descriptor^.header.remote_sfid;
    byte_offset := p_server_descriptor^.header.total_allocated_length;
    IF p_server_descriptor^.header.allocation_info.allocation_needed_on_server THEN
      bytes_to_allocate := p_server_descriptor^.header.allocation_info.bytes_to_allocate;

    ELSEIF (initial_byte_address + requested_bytes_to_allocate) >
            p_server_descriptor^.header.total_allocated_length THEN
      byte_offset := initial_byte_address;
      bytes_to_allocate := requested_bytes_to_allocate;

    ELSE
{
{ This instance of an allocation has already been processed by another request.
{
      gfp$unlock_fde_p (fde_p);
      RETURN;
    IFEND;

    gfp$unlock_fde_p (fde_p);

    dfp$begin_remote_core_call (served_family_table_index, { Allowed when deactive } TRUE,
          queue_entry_location, p_send_to_server_params, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.sfid := remote_sfid;
    p_send_parameters^.byte_offset := byte_offset;
    p_send_parameters^.bytes_to_allocate := bytes_to_allocate;
    p_send_parameters^.total_allocated_length := byte_offset;

    dfp$send_remote_core_call (queue_entry_location, dfc$r1_df_server_allocate_space,
          #SIZE (p_send_parameters^), p_receive_from_server_params, status);

    IF status.normal THEN
      gfp$get_locked_fde_p (system_file_id, local_fde_p);

      RESET p_receive_from_server_params;
      NEXT p_receive_parameters IN p_receive_from_server_params;
      IF p_server_descriptor^.header.total_allocated_length < p_receive_parameters^.total_allocated_length
            THEN
        IF file_space_limit <> sfc$no_limit THEN
          sfp$accumulate_file_space (file_space_limit, p_receive_parameters^.total_allocated_length -
                 p_server_descriptor^.header.total_allocated_length);
        IFEND;
        p_server_descriptor^.header.total_allocated_length := p_receive_parameters^.total_allocated_length;
      IFEND;
      p_server_descriptor^.header.allocation_info.allocation_needed_on_server := FALSE;
      p_server_descriptor^.header.allocation_info.invalid_data := 0;
      gfp$unlock_fde_p (local_fde_p);
    IFEND;

    dfp$end_remote_core_call (queue_entry_location, local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND dmp$df_client_allocate_space_r1;
?? TITLE := '  dmp$allocate_file_space_r1', EJECT ??
*copy dmh$allocate_file_space_r1

  PROCEDURE [XDCL, #GATE] dmp$allocate_file_space_r1 (system_file_id: gft$system_file_identifier;
        initial_byte_address: amt$file_byte_address;
        bytes_to_allocate: amt$file_byte_address;
        chapter_number: dmt$chapter_number;     {*** CAN THIS GO? ***}
        wait_option: ost$wait;
        file_space_limit: sft$file_space_limit_kind;
    VAR status: ost$status);

    VAR
      able_to_reserve_fmd: boolean,
      allocation_end: amt$file_byte_address,
      allow_overflow: boolean,
      avt_index: dmt$active_volume_table_index,
      byte_address: amt$file_byte_address,
      bytes_per_allocation: dmt$bytes_per_allocation,
      bytes_per_position: dmt$bytes_per_allocation,
      dmv$pf_sparse: [XREF] boolean,
      fmd_index: dmt$fmd_index,
      file_allows_overflow: boolean,
      fmd_locator: dmt$file_location,
      dfd_pointer: ost$relative_pointer,
      internal_vsn: dmt$internal_vsn,
      local_status: ost$status,
      maximum_size: amt$file_byte_address,
      monitor_request_block: dmt$monitor_rb_allocate_space,
      overflow: boolean,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fau: ^dmt$file_allocation_unit,
      p_fde: ^gft$file_descriptor_entry,
      p_file_attributes: ^array [ * ] of dmt$file_attribute,
      p_fmd: ^dmt$file_medium_descriptor,
      p_mat: ^dmt$mainframe_allocation_table,
      p_volume_attributes: ^array [ * ] of dmt$assigned_ms_vol_attribute,
      requested_allocation: amt$file_byte_address,
      requested_allocation_end: amt$file_byte_address,
      temporary_file: boolean,
      volume_found: boolean,
      vsn: rmt$recorded_vsn,
      wait: [STATIC, READ] ost$wait := osc$wait;

    IF dmv$idle_system THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_alloc_all_space,
        'cannot allocate due to idle system - dmp$allocate_file_space_r1', status);
      RETURN;
    IFEND;

    status.normal := TRUE;

    p_file_attributes := NIL;
    byte_address := initial_byte_address;
    IF bytes_to_allocate > 0 THEN
      requested_allocation := bytes_to_allocate;
    ELSE
      {If you dislike this code, then you take it out.
      {Go ahead - take it out.
      {Make my day.
      requested_allocation := 1;
    IFEND;
    requested_allocation_end := byte_address + requested_allocation;

  /process_request/
    BEGIN
      gfp$get_locked_fde_p (system_file_id, p_fde);
      IF p_fde = NIL THEN
        EXIT /process_request/;
      IFEND;

    /file_descriptor_locked/
      BEGIN
        IF p_fde^.media = gfc$fm_served_file THEN
          dmp$df_client_allocate_space_r1 (p_fde, system_file_id,
             initial_byte_address, requested_allocation, file_space_limit, status);
{         File_Descriptor_Entry (FDE) lock has been cleared by the callee.
          EXIT /process_request/;
        IFEND;

        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
        IF p_dfd = NIL THEN
            EXIT /file_descriptor_locked/;
        IFEND;

{  *** STILL NEED TO BE ABLE TO ADD SUBFILES, FOR REASSIGN_FILE ***

        dmp$get_fmd_by_index (p_dfd, p_dfd^.current_fmd_index, p_fmd);
        IF p_fmd = NIL THEN
          dmp$increase_fmd_count (system_file_id, p_dfd, status);
          IF NOT status.normal THEN
            EXIT /file_descriptor_locked/;
          IFEND;
          dmp$reserve_fmd (p_dfd, fmd_index, able_to_reserve_fmd);
          IF NOT able_to_reserve_fmd THEN
            osp$fatal_system_error ('Unable to reserve a FMD - dmp$allocate_file_space_r1', NIL);
          IFEND;
          p_dfd^.current_fmd_index := fmd_index;
        IFEND;

        file_allows_overflow := p_dfd^.overflow_allowed;
        temporary_file := p_fde^.file_kind >= gfc$fk_first_temporary_file;

        monitor_request_block.request_code := syc$rc_allocate_front_end;
        monitor_request_block.system_file_id := system_file_id;
        monitor_request_block.update_fat_pointer := FALSE;

        PUSH p_volume_attributes: [1 .. 1];

      /allocate_loop/
        WHILE TRUE DO
          dmp$get_fmd_by_index (p_dfd, p_dfd^.current_fmd_index, p_fmd);
{
{             check to see if a volume must be assigned to the fmd
{
          IF NOT p_fmd^.volume_assigned THEN
            IF (p_fde^.file_kind = gfc$fk_device_file) THEN
              avt_index := 0;
              vsn := p_dfd^.requested_volume.recorded_vsn;
              p_volume_attributes^ [1].keyword := dmc$ms_device_log;
              dmp$get_active_vol_attributes (vsn, avt_index, p_volume_attributes, volume_found);
              IF volume_found AND (p_volume_attributes^ [1].p_dlog = dmv$null_sfid) THEN
                unlogged_assign_volume (system_file_id, p_fde, p_dfd, p_fmd, requested_allocation,
                       vsn, status);
                EXIT /file_descriptor_locked/;
              IFEND;
            IFEND;

            assign_volume (system_file_id, p_fde, p_dfd, p_fmd, status);
            IF NOT status.normal THEN
              EXIT /file_descriptor_locked/;
            IFEND;
          IFEND;

          IF dmv$p_active_volume_table^ [p_fmd^.avt_index].mass_storage.volume_unavailable THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_alloc_all_space,
              'volume unavailable - dmp$allocate_file_space_r1', status);
            EXIT /file_descriptor_locked/;
          IFEND;

          {The following must be done AFTER a volume is assigned
          { so that p_fde^.bytes_per_allocation has been set.

          bytes_per_allocation := p_dfd^.bytes_per_allocation;
          byte_address := byte_address DIV bytes_per_allocation * bytes_per_allocation;
          allocation_end := (requested_allocation_end + bytes_per_allocation - 1) DIV
                bytes_per_allocation * bytes_per_allocation;

          { Force sequential allocation for permanent files.

          IF (p_fde^.file_kind <= gfc$fk_last_permanent_file) AND NOT dmv$pf_sparse THEN
            IF byte_address > p_dfd^.highest_offset_allocated THEN
              byte_address := p_dfd^.highest_offset_allocated;
            IFEND;
          IFEND;

          IF p_dfd^.requested_allocation_size > p_dfd^.bytes_per_allocation THEN

            {Assume cylinder allocation
            {Get as many allocation units of the correct style as needed/possible
            {Desire is that they will reside on the same cylinder

            dmp$get_mat_pointer (p_fmd^.avt_index, p_mat);
            bytes_per_position := (p_mat^.daus_per_position * p_mat^.bytes_per_dau) DIV bytes_per_allocation *
                bytes_per_allocation;
            byte_address := byte_address DIV bytes_per_position * bytes_per_position;
            maximum_size := dmc$level_1_table_size * p_dfd^.bytes_per_level_2;

            IF (allocation_end < maximum_size) THEN
              allocation_end := (allocation_end + bytes_per_position - 1) DIV bytes_per_position *
                    bytes_per_position;
              IF (allocation_end > maximum_size) THEN
                allocation_end := maximum_size;
              IFEND;
            IFEND;
          IFEND;

          requested_allocation := allocation_end - byte_address;

          dmp$create_fau_entry (p_dfd, byte_address, requested_allocation);

          monitor_request_block.requested_allocation := requested_allocation;
          monitor_request_block.allocate_byte_address := byte_address;
          monitor_request_block.file_space_limit := file_space_limit;

          i#call_monitor (#LOC (monitor_request_block), #SIZE (monitor_request_block));

          byte_address := byte_address + monitor_request_block.allocation_units_obtained *
               bytes_per_allocation;

          IF (monitor_request_block.status = dmc$fas_file_allocated) OR
             (monitor_request_block.status = dmc$fas_account_limit_exceeded) OR
             (byte_address >= allocation_end) THEN
            status.normal := TRUE;
            EXIT /allocate_loop/;
          ELSE
            osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_alloc_all_space,
              '', status);
          IFEND;

          IF NOT dmv$vol_space_manage_initiated THEN
            EXIT /allocate_loop/;
          IFEND;

          { If some space was obtained and volume overflow was not indicated,
          { try again after calling pmp$cycle to allow other Device Manager
          { tasks to run.  The allocation may have been incomplete because the
          { allocation log was full.  If so, the allocation log splitting task
          { will have run and additional allocation will be obtained on the
          { next try.

          IF (monitor_request_block.allocation_units_obtained > 0) AND NOT
                monitor_request_block.overflow_indicator THEN
            pmp$cycle (local_status);
            CYCLE /allocate_loop/;
          IFEND;

{
{          Unable to allocate all space from the assigned volume's mainframe
{          allocation table.  This situation can occur for one of two reasons :
{             1.  The mainframe has run out of space and must get more space
{                 from the volume,
{             2.  The mainframe has run out of space and cannot get more space
{                  because the volume is out of space (overflow situation).
{
{           IF an overflow situation exists and the file is allowed to overflow,
{           overflow processing proceeds.  IF an overflow situation exists and
{           the file is not allowed to overflow, the wait option is processed.
{

          IF temporary_file THEN
            allow_overflow := file_allows_overflow AND dmv$temporary_file_overflow;
          ELSE
            allow_overflow := file_allows_overflow AND dmv$permanent_file_overflow;
          IFEND;

          IF monitor_request_block.overflow_indicator AND allow_overflow THEN

            overflow_volume (system_file_id, p_fde, p_dfd, status);

            IF status.normal THEN
              CYCLE /allocate_loop/;
            IFEND;
          IFEND;

          IF (wait_option <> osc$wait) THEN
            EXIT /allocate_loop/;
          IFEND;

          gfp$unlock_fde_p (p_fde);

          pmp$delay (allocator_delay_time {milliseconds} , status);

          gfp$get_locked_fde_p (system_file_id, p_fde);
          IF p_fde = NIL THEN
            EXIT /process_request/;
          IFEND;

        WHILEND /allocate_loop/;

      END /file_descriptor_locked/;

      gfp$unlock_fde_p (p_fde);

    END /process_request/;

    IF NOT status.normal THEN
      IF (status.condition = dme$fmd_overflow) THEN        {max fmds has been reached...}
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_alloc_all_space,
              status.text.value, status);
      IFEND;
    IFEND;
  PROCEND dmp$allocate_file_space_r1;
?? TITLE := '  dmp$create_mat', EJECT ??
{
{    The purpose of this request is to create a mainframe allocation table
{  (MAT) for a mass storage volume.
{
{        DMP$CREATE_MAT (AVT_INDEX, DAT_SFID, P_MAT, STATUS)
{
{  AVT_INDEX: (input)  This parameter specifies the active volume table index
{                      assigned to the mass storage volume.
{
{  DAT_SFID: (input)  This parameter specifies the SFID of the DAT for the
{                     mass storage volume.
{
{  P_MAT: (output)  This parameter returns a generic adaptable array pointer
{                   to the mainframe allocation table created for the mass
{                   storage volume.
{
{  STATUS: (output)  This parameter returns the request status.
{

  PROCEDURE [XDCL] dmp$create_mat (
        avt_index: dmt$active_volume_table_index;
        dat_sfid: dmt$system_file_id;
    VAR p_mat: cyt$adaptable_array_pointer;
    VAR status: ost$status);

    VAR
      able: boolean,
      converter: dmt$mat_converter,
      p_dat: ^dmt$ms_device_allocation_table;

    dmp$open_dat (dat_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential, p_dat,
          status);

    IF status.normal THEN
      dmp$set_update_lock (avt_index, {wait =} TRUE, able);

      create_mat (p_dat, avt_index, converter.p_mat);

      p_mat := converter.p_adaptable;

      dmp$clear_update_lock (avt_index);

      dmp$close_file (p_dat, status);
    IFEND;
  PROCEND dmp$create_mat;
?? TITLE := '  dmp$delete_mat', EJECT ??
{
{   The purpose of this request is to delete a mainframe allocation table (MAT)
{ and its suborinate tables. The MAT pointer is checked for NIL on input and
{ set to NIL on output.
{
{       DMP$DELETE_MAT (P_MAT)
{
{ P_MAT: (input, output)  This parameter is a generic adaptable array pointer
{                         identifying the MAT to be deleted. If it is NIL, no
{                         operation is performed.  This parameter is set to
{                         NIL on output.
{

  PROCEDURE [XDCL] dmp$delete_mat (
    VAR p_mat {input, output} : cyt$adaptable_array_pointer);

    VAR
      converter: dmt$mat_converter;

    converter.p_adaptable := p_mat;
    IF (converter.p_mat <> NIL) THEN
      IF (converter.p_mat^.p_available_daus <> NIL) THEN
        FREE converter.p_mat^.p_available_daus IN osv$mainframe_wired_heap^;
      IFEND;
      FREE converter.p_mat IN osv$mainframe_wired_heap^;
      p_mat := converter.p_adaptable;
    IFEND;
  PROCEND dmp$delete_mat;
?? TITLE := '  assign_volume', EJECT ??

  PROCEDURE assign_volume (system_file_id: gft$system_file_identifier;
        p_fde: ^gft$file_descriptor_entry;
        p_dfd: ^dmt$disk_file_descriptor;
        p_fmd: ^dmt$file_medium_descriptor;
    VAR status: ost$status);

    VAR
      allocation_style: dmt$allocation_styles,
      avt_index: dmt$active_volume_table_index,
      bytes_per_allocation_unit: dmt$bytes_per_allocation,
      byte_address: amt$file_byte_address,
      dfl_index: dmt$device_file_list_index,
      exact_style: boolean,
      file_kind: gft$file_kind,
      p_mat: ^dmt$mainframe_allocation_table,
      log_entry: dmt$dl_entry,
      requested_bytes_per_allocation: dmt$allocation_size,
      requested_daus_per_transfer: dmt$daus_per_transfer,
      transfer_style: dmt$allocation_styles,
      volume_selector: t$volume_selector;

    status.normal := TRUE;

    dfl_index := 0;

  /assign_volume_to_file/
    BEGIN
      file_kind := p_fde^.file_kind;

      {The following limits the maximum allocation size.  This is done in an attempt
      {to allow most devices to be candidates for creation of overflow of large
      {allocation size files.  Only 844 and 834 devices are excluded from use by
      {the default maximum of 256K.  The default allocation size of 16384 works
      {on all devices.  A file can overflow only to devices that allow the same
      {allocation size.  Depending on the value of dmv$maximum_allocation_size
      {there can be some wasted space at the end of a cylinder.  There is no waste
      {with 16384 allocation.  Unless dmv$maximum_allocation_size is changed it is
      {no longer possible to use all of a cylinder (e.g. not waste space).  However,
      {if it is changed to allow full cylinder allocation, then the devices that can
      {be used for overflow are restricted.

      IF p_dfd^.bytes_per_allocation = 0 THEN
        {Limit file creation allocations to a setsa controlled value
        IF p_dfd^.requested_allocation_size > dmv$maximum_allocation_size THEN
          requested_bytes_per_allocation := dmv$maximum_allocation_size;
        ELSE
          requested_bytes_per_allocation := p_dfd^.requested_allocation_size;
        IFEND;
      ELSE
        {Limit file overflow allocation to equal current allocation
        requested_bytes_per_allocation := p_dfd^.bytes_per_allocation;
      IFEND;

{
{              build volume selector
{

      volume_selector.class := p_dfd^.requested_class;
      volume_selector.class_ordinal := p_dfd^.requested_class_ordinal;

      volume_selector.recorded_vsn := p_dfd^.requested_volume.recorded_vsn;
      volume_selector.set_name := p_dfd^.requested_volume.setname;

      volume_selector.force_allocation_size := (p_dfd^.bytes_per_allocation <> 0);
      volume_selector.allocation_size := requested_bytes_per_allocation;

      {If all volumes that support the current size of a file are out of space, then
      {the allocate will hang waiting for space.  Cannot overflow to different allocation
      {size.

      select_volume (volume_selector, avt_index, status);
      IF status.normal = FALSE THEN
        EXIT /assign_volume_to_file/;
      IFEND;

      dmp$get_mat_pointer (avt_index, p_mat);

{
{            reserve device file list entry, if necessary.
{
      IF (file_kind <= gfc$fk_last_permanent_file) THEN
        dmp$get_unused_mfl_entry (avt_index, dfl_index, status);
        IF NOT status.normal THEN
          EXIT /assign_volume_to_file/;
        IFEND;
      IFEND;

      p_fmd^.dfl_index := dfl_index;
      p_fmd^.internal_vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.internal_vsn;
      p_fmd^.avt_index := avt_index;
      p_dfd^.dfd_modified := TRUE;
      p_dfd^.fmd_modified := TRUE;

      determine_allocation_style (p_mat, requested_bytes_per_allocation, allocation_style, exact_style);

      bytes_per_allocation_unit := p_mat^.daus_per_allocation_unit [allocation_style] * p_mat^.bytes_per_dau;

      p_dfd^.bytes_per_allocation := bytes_per_allocation_unit;

      {Force level 2 tables to be "full"
      p_dfd^.bytes_per_level_2 := bytes_per_allocation_unit * (dmc$bytes_per_level_2 DIV
          16384);

      IF (p_dfd^.requested_transfer_size = dmc$unspecified_transfer_size) THEN
        p_dfd^.requested_transfer_size := p_mat^.default_transfer_size;
      IFEND;

      IF (file_kind <= gfc$fk_last_permanent_file) THEN
        dmp$get_total_allocated_length (p_fde, byte_address);
        log_entry.kind := dmc$dl_create;
        log_entry.create_block.global_file_name := p_fde^.global_file_name;
        log_entry.create_block.dfl_index := dfl_index;
        log_entry.create_block.mainframe_assigned := dmv$p_active_volume_table^ [avt_index].mass_storage.
              mainframe_assigned;
        log_entry.create_block.daus_per_allocation := p_mat^.daus_per_allocation_unit
              [allocation_style];
        log_entry.create_block.file_kind := p_fde^.file_kind;
        log_entry.create_block.fmd_byte_address := byte_address;
        dmp$process_device_log_entry (avt_index, log_entry, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      p_fmd^.system_file_id := system_file_id;
      p_fmd^.bytes_per_mau := p_mat^.bytes_per_mau;
      p_fmd^.daus_per_cylinder := p_mat^.daus_per_position;
      p_fmd^.maus_per_dau := p_mat^.maus_per_dau;
      p_fmd^.daus_per_allocation_unit := (p_dfd^.bytes_per_allocation  DIV  p_fmd^.bytes_per_mau)
             DIV p_fmd^.maus_per_dau;
      p_fmd^.allocation_style := allocation_style;
      requested_daus_per_transfer := requested_bytes_per_allocation DIV
            (p_fmd^.bytes_per_mau * p_fmd^.maus_per_dau);

    /transfer_style_search/
      FOR transfer_style := dmc$a0 TO allocation_style DO
        IF requested_daus_per_transfer < p_mat^.daus_per_allocation_unit [transfer_style] THEN
          EXIT /transfer_style_search/;
        IFEND;
      FOREND /transfer_style_search/;

      p_fmd^.maus_per_transfer_unit := p_mat^.daus_per_allocation_unit [transfer_style] *
            p_fmd^.maus_per_dau;

      p_fmd^.volume_assigned := TRUE;
      p_fde^.allocation_unit_size := p_dfd^.bytes_per_allocation;
      p_fde^.transfer_unit_size := p_dfd^.requested_transfer_size;

    END /assign_volume_to_file/;

  PROCEND assign_volume;
?? TITLE := '  create_dfl_entry', EJECT ??

  PROCEDURE create_dfl_entry (first_dau_address: dmt$dau_address;
        dflt_sfid: gft$system_file_identifier;
        global_file_name: ost$binary_unique_name,
        file_hash: dmt$file_hash;
        allocated_length: amt$file_byte_address;
        daus_per_allocation: dmt$daus_per_allocation;
        avt_index: dmt$active_volume_table_index;
    VAR dfl_index: dmt$device_file_list_index;
    VAR status: ost$status);

    VAR
      p_dflt: ^dmt$ms_device_file_list_table,
      available_dfl_entry_index: dmt$device_file_list_index,
      able_to_set_lock: boolean,
      close_status: ost$status;

    status.normal := TRUE;

    dmp$open_dflt (dflt_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend,
       mmc$as_sequential, p_dflt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /dflt_open/
    BEGIN
      dmp$set_update_lock (avt_index, TRUE, able_to_set_lock);
      IF NOT able_to_set_lock THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_lock_dflt,
          'unable to lock dflt - DMMFCRT', status);
        EXIT /dflt_open/;
      IFEND;

    /dflt_locked/
      BEGIN
        available_dfl_entry_index := 0;

      /find_available_dfl_entry/
        FOR dfl_index := 1 TO UPPERBOUND (p_dflt^.entries) DO
          IF p_dflt^.entries [dfl_index].flags = dmc$dfle_available THEN
            available_dfl_entry_index := dfl_index;
            EXIT /find_available_dfl_entry/;
          IFEND;
        FOREND /find_available_dfl_entry/;

        dfl_index := available_dfl_entry_index;

        IF dfl_index = 0 THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$no_dfl_entries_available, '', status);
        ELSE
          p_dflt^.entries [dfl_index].flags := dmc$dfle_assigned_to_file;
          p_dflt^.entries [dfl_index].dau_chain_status := dmc$dau_chain_linked;
          p_dflt^.entries [dfl_index].file_byte_address := 0;
          p_dflt^.entries [dfl_index].file_hash := file_hash;
          p_dflt^.entries [dfl_index].file_kind := gfc$fk_device_file;
          p_dflt^.entries [dfl_index].global_file_name := global_file_name;
          p_dflt^.entries [dfl_index].end_of_information := allocated_length;
          p_dflt^.entries [dfl_index].end_of_file := allocated_length;
          p_dflt^.entries [dfl_index].login_set := $dmt$dfl_login_set [];
          p_dflt^.entries [dfl_index].first_dau_address := first_dau_address;
          p_dflt^.entries [dfl_index].daus_per_allocation_unit := daus_per_allocation;
          p_dflt^.entries [dfl_index].fmd_length := allocated_length;
          p_dflt^.entries [dfl_index].logical_length := allocated_length;
        IFEND;

      END /dflt_locked/;

      dmp$clear_update_lock (avt_index);
      mmp$write_modified_pages (p_dflt, #SIZE (p_dflt^), osc$wait, status);

    END /dflt_open/;

    dmp$close_file (p_dflt, close_status);
    IF NOT close_status.normal AND status.normal THEN
      status := close_status;
    IFEND;

  PROCEND create_dfl_entry;
?? TITLE := '  create_mat', EJECT ??

  PROCEDURE create_mat (p_dat: ^dmt$ms_device_allocation_table;
        avt_index: dmt$active_volume_table_index;
    VAR p_mat: ^dmt$mainframe_allocation_table);

    VAR
      mat_entry: dmt$mat_entry,
      p_available_daus: ^dmt$available_daus,
      position: dmt$device_position,
      positions_per_device: dmt$device_position,
      daus_per_position: dmt$daus_per_position,
      daus_per_device: dmt$dau_address,
      minimum_threshold: dmt$dau_address,
      dau: dmt$dau_address,
      last_dau: dmt$dau_address,
      bytes_per_dau: dmt$bytes_per_dau,
      bytes_per_position: dmt$bytes_per_allocation,
      file_kind: gft$file_kind,
      dau_status_counts: dmt$dau_status_counts,
      allocation_style: dmt$allocation_styles;

    positions_per_device := p_dat^.header.positions_per_device;
    daus_per_position := p_dat^.header.daus_per_position;
    daus_per_device := positions_per_device * daus_per_position;
    bytes_per_dau := p_dat^.header.bytes_per_dau;

    ALLOCATE p_mat: [0 .. positions_per_device - 1] IN osv$mainframe_wired_heap^;

    p_mat^.avt_index := avt_index;
    p_mat^.bytes_per_dau := bytes_per_dau;
    p_mat^.bytes_per_mau := p_dat^.header.bytes_per_mau;
    p_mat^.maus_per_dau := p_dat^.header.maus_per_dau;
    p_mat^.daus_per_position := daus_per_position;
    p_mat^.positions_per_device := positions_per_device;
    p_mat^.starting_position_number := 0;
    p_mat^.starting_search_position := 0;
    p_mat^.daus_per_allocation_unit := p_dat^.header.daus_per_allocation_style;

    IF (p_dat^.header.default_allocation_size = dmc$unspecified_allocation_size) THEN {upgrade 1.3.1}
      p_mat^.default_allocation_size := dmc$default_req_alloc_size;
    ELSE
      p_mat^.default_allocation_size := p_dat^.header.default_allocation_size;
    IFEND;

    IF (p_dat^.header.default_transfer_size = dmc$unspecified_transfer_size) THEN {upgrade 1.3.1}
      IF p_dat^.header.positions_per_device = 884 THEN  {temporary kludge for HYDRA}
        p_mat^.default_transfer_size := dmc$default_transfer_size_887;
      ELSE
        p_mat^.default_transfer_size := dmc$default_req_transfer_size;
      IFEND;
    ELSE
      p_mat^.default_transfer_size := p_dat^.header.default_transfer_size;
    IFEND;

    FOR allocation_style := LOWERVALUE (allocation_style) TO UPPERVALUE (allocation_style) DO
      p_mat^.available_allocation_units [allocation_style] := 0;
      p_mat^.allocation_chains [allocation_style] := dmc$nil_position_link;
    FOREND;

    p_mat^.minimum_space := daus_per_device DIV 4;
    p_mat^.maximum_space := 3 * p_mat^.minimum_space;
    p_mat^.available_space := 0;
    p_mat^.leftover_space := 0;

    FOR file_kind := LOWERVALUE (file_kind) TO UPPERVALUE (file_kind) DO
      p_mat^.allocated_space [file_kind] := 0;
    FOREND;

    p_mat^.mat_too_full := FALSE;
    p_mat^.available_dat_space := p_dat^.header.available;
    p_mat^.dat_threshold := 0;
    p_mat^.recovery_threshold := p_dat^.header.recovery_threshold;
    p_mat^.warning_threshold := p_dat^.header.warning_threshold;

    { Make sure the MAT recovery threshold for the system device is enough
    { to support deadstart.

    IF (dmv$p_active_volume_table^ [avt_index].logical_unit_number = dmv$system_device_lun) THEN
      bytes_per_position := bytes_per_dau * daus_per_position;
      minimum_threshold := (dmv$deadstart_disk_space + bytes_per_position - 1) DIV bytes_per_position *
            daus_per_position;
      IF (p_mat^.recovery_threshold < minimum_threshold) THEN
        p_mat^.recovery_threshold := minimum_threshold;
      IFEND;
    IFEND;

    last_dau := daus_per_device - 1;
    ALLOCATE p_available_daus: [0 .. last_dau] IN osv$mainframe_wired_heap^;
    p_mat^.p_available_daus := p_available_daus;

    FOR dau := 0 TO last_dau DO
      p_available_daus^ [dau] := FALSE;
    FOREND;

    mat_entry.available_allocation_units := 0;
    mat_entry.backward_link := dmc$nil_position_link;
    mat_entry.forward_link := dmc$nil_position_link;

    FOR position := 0 TO positions_per_device - 1 DO
      dmp$analyze_dat_position (p_dat, position, mat_entry.allocation_style, dau_status_counts);
      p_mat^.mat_entries [position] := mat_entry;
    FOREND;
  PROCEND create_mat;
?? TITLE := '  dat_allocate', EJECT ??

  PROCEDURE dat_allocate (avt_index: dmt$active_volume_table_index;
        dat_sfid: gft$system_file_identifier;
        file_hash: dmt$file_hash;
        dfl_index: dmt$device_file_list_index;
        daus_per_allocation: dmt$daus_per_allocation;
        p_allocation_list: ^t$allocation_list;
    VAR status: ost$status);

    VAR
      able: boolean,
      allocation_chain_position: dmt$allocation_chain_position,
      close_status: ost$status,
      dau: dmt$dau_address,
      daus_allocated: dmt$dau_address,
      first_dau: dmt$dau_address,
      high_index: integer,
      index: integer,
      last_dau: dmt$dau_address,
      low_index: integer,
      next_dau: dmt$dau_address,
      p_dat: ^dmt$ms_device_allocation_table;

    dmp$open_dat (dat_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend,
       mmc$as_sequential, p_dat, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$set_update_lock (avt_index, {wait =} TRUE, able);

    low_index := LOWERBOUND (p_allocation_list^);
    high_index := UPPERBOUND (p_allocation_list^);
    next_dau := 0;

    FOR index := high_index DOWNTO low_index DO
      allocation_chain_position := dmc$middle_allocation;
      first_dau := p_allocation_list^ [index];
      FOR dau := first_dau TO first_dau + daus_per_allocation - 1 DO
        p_dat^.body [dau].dau_status := dmc$dau_assigned_to_file;
        p_dat^.body [dau].file_hash := file_hash;
        p_dat^.body [dau].data_status := dmc$dau_data_initialized;
        p_dat^.body [dau].allocation_chain_position := allocation_chain_position;
        IF (allocation_chain_position = dmc$middle_allocation) THEN
          p_dat^.body [dau].next_allocation_unit_dau := next_dau;
        IFEND;
        allocation_chain_position := dmc$part_of_allocation_unit;
      FOREND;
      next_dau := first_dau;
    FOREND;

    first_dau := p_allocation_list^ [low_index];
    last_dau := p_allocation_list^ [high_index];
    IF (first_dau = last_dau) THEN
      p_dat^.body [last_dau].allocation_chain_position := dmc$first_and_last_allocation;
    ELSE
      p_dat^.body [first_dau].allocation_chain_position := dmc$first_allocation;
      p_dat^.body [last_dau].allocation_chain_position := dmc$last_allocation;
    IFEND;
    p_dat^.body [last_dau].high_dfl_index := dfl_index DIV dmc$dfl_index_converter;
    p_dat^.body [last_dau].low_dfl_index := dfl_index MOD dmc$dfl_index_converter;

    daus_allocated := (high_index - low_index + 1) * daus_per_allocation;
    p_dat^.header.available := p_dat^.header.available - daus_allocated;

    dmp$clear_update_lock (avt_index);
    mmp$write_modified_pages (p_dat, #SIZE (p_dat^), osc$wait, status);

    dmp$close_file (p_dat, close_status);
    IF NOT close_status.normal AND status.normal THEN
      status := close_status;
    IFEND;

  PROCEND dat_allocate;
?? TITLE := '  dat_deallocate', EJECT ??

  PROCEDURE dat_deallocate (dat_sfid: gft$system_file_identifier;
        file_hash: dmt$file_hash;
        daus_per_allocation_unit: dmt$daus_per_allocation;
        first_dau_address: dmt$dau_address;
        avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      able: boolean,
      p_dat: ^dmt$ms_device_allocation_table,
      dau_offset: dmt$daus_per_allocation,
      dau_count: dmt$dau_address,
      deallocate_complete: boolean,
      local_status: ost$status,
      next_allocation_unit_dau: dmt$dau_address,
      current_allocation_unit_dau: dmt$dau_address,
      dau_index: dmt$dau_address;

    dmp$open_dat (dat_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend,
       mmc$as_sequential, p_dat, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$set_update_lock (avt_index, TRUE, able);

      /device_file_deallocate/
        BEGIN

          dau_count := 0;
          deallocate_complete := FALSE;
          next_allocation_unit_dau := first_dau_address;

          REPEAT

            current_allocation_unit_dau := next_allocation_unit_dau;

            FOR dau_offset := 1 TO daus_per_allocation_unit DO
              dau_index := current_allocation_unit_dau + dau_offset - 1;

              IF p_dat^.body [dau_index].dau_status <> dmc$dau_assigned_to_file THEN
                osp$set_status_abnormal (dmc$device_manager_ident, dme$allocation_chain_broken,
                  'dau not assigned to file - dat_deallocate', status);
                EXIT /device_file_deallocate/;
              IFEND;

              IF p_dat^.body [dau_index].file_hash <> file_hash THEN
                osp$set_status_abnormal (dmc$device_manager_ident, dme$allocation_chain_broken,
                  'dau/file hash mismatch - dat_deallocate', status);
                EXIT /device_file_deallocate/;
              IFEND;

              CASE p_dat^.body [dau_index].allocation_chain_position OF
              = dmc$first_and_last_allocation, dmc$last_allocation =
                IF dau_offset <> 1 THEN
                  osp$set_status_abnormal (dmc$device_manager_ident, dme$allocation_chain_broken,
                    '1st & last dau_offset <> 1 - dat_deallocate', status);
                  EXIT /device_file_deallocate/;
                IFEND;
                deallocate_complete := TRUE;
              = dmc$first_allocation, dmc$middle_allocation =
                IF dau_offset <> 1 THEN
                  osp$set_status_abnormal (dmc$device_manager_ident, dme$allocation_chain_broken,
                    '1st dau_offset <> 1 - dat_deallocate', status);
                  EXIT /device_file_deallocate/;
                IFEND;
                next_allocation_unit_dau := p_dat^.body [dau_index].next_allocation_unit_dau;
              = dmc$part_of_allocation_unit =
                ;
              CASEND;

              p_dat^.body [dau_index].dau_status := dmc$dau_usable;
              dau_count := dau_count + 1;

            FOREND;

          UNTIL deallocate_complete;

        END /device_file_deallocate/;

        p_dat^.header.available := p_dat^.header.available + dau_count;

    dmp$clear_update_lock (avt_index);

    mmp$write_modified_pages (p_dat, #SIZE (p_dat^), osc$wait, local_status);
    IF NOT local_status.normal AND status.normal THEN
      status := local_status;
    IFEND;

    dmp$close_file (p_dat, local_status);
    IF NOT local_status.normal AND status.normal THEN
      status := local_status;
    IFEND;
  PROCEND dat_deallocate;
?? TITLE := '  delete_dfl_entry', EJECT ??

  PROCEDURE delete_dfl_entry (dflt_sfid: gft$system_file_identifier;
        dfl_index: dmt$device_file_list_index;
        avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      able_to_set_lock: boolean,
      p_dflt: ^dmt$ms_device_file_list_table,
      close_status: ost$status;

    status.normal := TRUE;

    dmp$open_dflt (dflt_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend,
       mmc$as_sequential, p_dflt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /dflt_open/
    BEGIN
      dmp$set_update_lock (avt_index, TRUE, able_to_set_lock);
      IF NOT able_to_set_lock THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_lock_dflt,
          'unable to lock dflt - DMMFCRT', status);
        EXIT /dflt_open/;
      IFEND;

      p_dflt^.entries [dfl_index].flags := dmc$dfle_available;

      dmp$clear_update_lock (avt_index);
      mmp$write_modified_pages (p_dflt, #SIZE (p_dflt^), osc$wait, status);

    END /dflt_open/;
    dmp$close_file (p_dflt, close_status);
    IF NOT close_status.normal AND status.normal THEN
      status := close_status;
    IFEND;

  PROCEND delete_dfl_entry;
?? TITLE := '  determine_allocation_style', EJECT ??

  PROCEDURE [INLINE] determine_allocation_style (p_mat: ^dmt$mainframe_allocation_table;
        allocation_size: dmt$allocation_size;
    VAR allocation_style: dmt$allocation_styles;
    VAR exact_style: boolean);

    VAR
      bytes_per_allocation: dmt$allocation_size,
      bytes_per_dau: dmt$bytes_per_dau,
      daus_per_allocation: dmt$daus_per_allocation,
      style: dmt$allocation_styles;

    allocation_style := LOWERVALUE (style);
    bytes_per_dau := p_mat^.bytes_per_dau;

    IF (allocation_size = dmc$unspecified_allocation_size) THEN
      bytes_per_allocation := p_mat^.default_allocation_size;
    ELSE
      bytes_per_allocation := allocation_size;
    IFEND;

    IF (bytes_per_allocation < dmc$default_req_alloc_size) THEN
      bytes_per_allocation := dmc$default_req_alloc_size;
    IFEND;

    daus_per_allocation := (bytes_per_allocation + bytes_per_dau - 1) DIV bytes_per_dau;

    FOR style := LOWERVALUE (style) TO UPPERVALUE (style) DO
      IF (daus_per_allocation >= p_mat^.daus_per_allocation_unit [style]) THEN
        allocation_style := style;
      IFEND;
    FOREND;

    bytes_per_allocation := p_mat^.daus_per_allocation_unit [allocation_style] * bytes_per_dau;
    exact_style := (allocation_size = bytes_per_allocation);
  PROCEND determine_allocation_style;
?? TITLE := '  find_allocation', EJECT ??

  PROCEDURE find_allocation (dat_sfid: gft$system_file_identifier;
        p_mat: ^dmt$mainframe_allocation_table;
        allocation_style: dmt$allocation_styles;
        daus_per_allocation: dmt$daus_per_allocation;
        p_allocation_list: ^t$allocation_list;
    VAR status: ost$status);

    VAR
      allocation_found: boolean,
      assigned_style: dmt$allocation_styles,
      bytes_found: integer,
      bytes_needed: integer,
      bytes_per_allocation: dmt$allocation_size,
      dau: dmt$dau_address,
      dau_limit: dmt$dau_address,
      dau_status_counts: dmt$dau_status_counts,
      daus_per_position: dmt$daus_per_position,
      first_dau: dmt$dau_address,
      high_index: integer,
      index: integer,
      low_index: integer,
      msg: string (80),
      msgl: integer,
      next_dau: dmt$dau_address,
      p_dat: ^dmt$ms_device_allocation_table,
      position: dmt$device_position,
      position_dau_limit: dmt$dau_address,
      positions_per_device: dmt$device_position,
      verify_index: integer,
      vsn: rmt$recorded_vsn;

    dmp$open_dat (dat_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential, p_dat,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    low_index := LOWERBOUND (p_allocation_list^);
    index := low_index;
    verify_index := low_index;
    high_index := UPPERBOUND (p_allocation_list^);
    positions_per_device := p_mat^.positions_per_device;
    daus_per_position := p_mat^.daus_per_position;
    position_dau_limit := daus_per_position DIV daus_per_allocation * daus_per_allocation;
    position := 0;

    REPEAT
      dmp$analyze_dat_position (p_dat, position, assigned_style, dau_status_counts);

      IF (dau_status_counts [dmc$dau_usable] <> 0) AND
            ((assigned_style = allocation_style) OR (assigned_style = dmc$acyl)) THEN
        dau := position * daus_per_position;
        dau_limit := dau + position_dau_limit;

        REPEAT
          first_dau := dau;
          next_dau := first_dau + daus_per_allocation;

          REPEAT
            allocation_found := (p_dat^.body [dau].dau_status = dmc$dau_usable);
            dau := dau + 1;
          UNTIL NOT allocation_found OR (dau >= next_dau);

          IF allocation_found THEN
            p_allocation_list^ [index] := first_dau;
            index := index + 1;
            IF (index > high_index) THEN
              verify_allocation (p_mat, daus_per_allocation, p_allocation_list, verify_index, index);
              verify_index := index;
            IFEND;
          IFEND;

          dau := next_dau;
        UNTIL (dau >= dau_limit) OR (index > high_index);
      IFEND;

      position := position + 1;
    UNTIL (index > high_index) OR (position >= p_mat^.positions_per_device);

    dmp$close_file (p_dat, status);

    IF (index <= high_index) THEN
      vsn := dmv$p_active_volume_table^ [p_mat^.avt_index].mass_storage.recorded_vsn;
      bytes_per_allocation := p_mat^.bytes_per_dau * daus_per_allocation;
      bytes_needed := (high_index - low_index + 1) * bytes_per_allocation;
      bytes_found := (index - low_index) * bytes_per_allocation;
      STRINGREP (msg, msgl, 'Volume ', vsn, ' out of space (need', bytes_needed, ' bytes, found',
            bytes_found, ').');
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_alloc_all_space, msg (1, msgl),
            status);
    IFEND;
  PROCEND find_allocation;
?? TITLE := '  get_volume_list', EJECT ??

  PROCEDURE get_volume_list (volume_selector: t$volume_selector;
        p_volume_list: ^array [1 .. *] of dmt$active_volume_table_index;
    VAR volume_count: dmt$active_volume_table_index);

    VAR
      any_set: boolean,
      avt_index: dmt$active_volume_table_index,
      bytes: amt$file_byte_address,
      candidate: boolean,
      check_style: boolean,
      cylinders: dmt$dau_address,
      daus_per_unit: dmt$dau_address,
      exact_style: boolean,
      last_try: boolean,
      maximum_bytes: amt$file_byte_address,
      normal: boolean,
      p_avt: ^dmt$active_volume_table,
      p_mat: ^dmt$mainframe_allocation_table,
      set_name: stt$set_name,
      style: dmt$allocation_styles,
      units: dmt$dau_address,
      units_per_cylinder: dmt$dau_address;

    volume_count := 0;
    maximum_bytes := 1;
    set_name := volume_selector.set_name;
    any_set := (set_name = osc$null_name);
    last_try := TRUE;
    p_avt := dmv$p_active_volume_table;

    REPEAT
      last_try := NOT last_try;
      check_style := volume_selector.force_allocation_size OR last_try;
      FOR avt_index := LOWERBOUND (p_avt^) TO UPPERBOUND (p_avt^) DO
        candidate := NOT p_avt^ [avt_index].entry_available

              AND p_avt^ [avt_index].mass_storage.allocation_allowed
              AND NOT p_avt^ [avt_index].mass_storage.volume_unavailable

              AND (volume_selector.class IN p_avt^ [avt_index].mass_storage.class)

              AND (any_set OR (set_name = p_avt^ [avt_index].mass_storage.set_name));

        IF candidate THEN
          normal := NOT p_avt^ [avt_index].mass_storage.space_gone AND
                    NOT p_avt^ [avt_index].mass_storage.space_low;
          candidate := normal OR last_try;
        IFEND;

        IF candidate AND check_style THEN
          dmp$get_mat_pointer (avt_index, p_mat);
          determine_allocation_style (p_mat, volume_selector.allocation_size, style, exact_style);
          candidate := NOT volume_selector.force_allocation_size OR exact_style;
          IF candidate AND last_try THEN
            daus_per_unit := p_mat^.daus_per_allocation_unit [style];
            cylinders := p_mat^.available_allocation_units [dmc$acyl];
            units_per_cylinder := p_mat^.daus_per_position DIV daus_per_unit;
            units := p_mat^.available_allocation_units [style] + cylinders * units_per_cylinder;
            bytes := units * daus_per_unit * p_mat^.bytes_per_dau;
            candidate := (bytes >= maximum_bytes);
            IF (bytes > maximum_bytes) THEN
              maximum_bytes := bytes;
              volume_count := 0;
            IFEND;
          IFEND;
        IFEND;

        IF candidate THEN
          volume_count := volume_count + 1;
          p_volume_list^ [volume_count] := avt_index;
        IFEND;
      FOREND;
    UNTIL (volume_count > 0) OR last_try;
  PROCEND get_volume_list;
?? TITLE := '  overflow_volume', EJECT ??

  PROCEDURE overflow_volume (sfid: gft$system_file_identifier;
        p_fde: ^gft$file_descriptor_entry;
        p_dfd: ^dmt$disk_file_descriptor;
    VAR status: ost$status);

    VAR
      able_to_reserve_fmd: boolean,
      fmd_index: dmt$fmd_index,
      p_fmd: ^dmt$file_medium_descriptor;

    status.normal := TRUE;

  /process_request/
    BEGIN
      dmp$reserve_fmd (p_dfd, fmd_index, able_to_reserve_fmd);
      IF NOT able_to_reserve_fmd THEN
        dmp$increase_fmd_count (sfid, p_dfd, status);
        IF NOT status.normal THEN
          EXIT /process_request/;
        IFEND;
        dmp$reserve_fmd (p_dfd, fmd_index, able_to_reserve_fmd);
        IF NOT able_to_reserve_fmd THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_overflow,
            'Unable to obtain a free FMD - overflow_volume.', status);
          EXIT /process_request/;
        IFEND;
      IFEND;
      p_dfd^.current_fmd_index := fmd_index;

      p_dfd^.requested_volume.recorded_vsn := '      ';

      dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);

      assign_volume (sfid, p_fde, p_dfd, p_fmd, status);

    END /process_request/;

  PROCEND overflow_volume;
?? TITLE := '  select_best_volume', EJECT ??

  PROCEDURE select_best_volume (volume_selector: t$volume_selector;
    VAR avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      selector: t$volume_selector,
      volume_count: dmt$active_volume_table_index,
      p_volume_list: ^array [1 .. *] of dmt$active_volume_table_index,
      class_ordinal: dmt$class_ordinal,
      index: dmt$active_volume_table_index,
      system_class: dmt$system_class,
      able_to_lock: boolean,
      able_to_clear: boolean,
      class_count: 0 .. 0ffffffff(16),
      low_class_count: 0 .. 0ffffffff(16),
      selected_index: dmt$active_volume_table_index;

    status.normal := TRUE;
    class_ordinal := volume_selector.class_ordinal;

    PUSH p_volume_list: [1 .. UPPERBOUND (dmv$p_active_volume_table^)];

    get_volume_list (volume_selector, p_volume_list, volume_count);

    { The following block of code is part of the DISTRIBUTE FILES feature.  It
    { is an attempt to evenly distribute files on the volumes by selecting the
    { volume with the lowest system_class_activity.

    IF (volume_selector.class IN dmv$system_class) AND (class_ordinal = 0) AND (volume_count > 0) THEN
      system_class := dmv$system_class_conversion [volume_selector.class];
      low_class_count := UPPERVALUE (low_class_count);

      FOR index := LOWERBOUND (p_volume_list^) TO volume_count DO
        avt_index := p_volume_list^ [index];

        class_count := dmv$p_active_volume_table^ [avt_index].mass_storage.system_class_activity
              [system_class];
        IF (class_count <= low_class_count) THEN
          p_volume_list^ [1] := avt_index;
          low_class_count := class_count;
        IFEND;
      FOREND;

      volume_count := 1;
      avt_index := p_volume_list^ [volume_count];
      dmp$lock_avt_entry (avt_index, able_to_lock);
      IF NOT able_to_lock THEN
        REPEAT
          pmp$delay (2000, status);
          dmp$lock_avt_entry (avt_index, able_to_lock);
        UNTIL able_to_lock;
      IFEND;
      dmv$p_active_volume_table^ [avt_index].mass_storage.system_class_activity [system_class] :=
            dmv$p_active_volume_table^ [avt_index].mass_storage.system_class_activity [system_class] + 1;
      dmp$unlock_avt_entry (avt_index, able_to_clear);
      IF NOT able_to_clear THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_clear_avt_lock,
          'Unable to clear AVT lock - select_best_volume.', status);
      IFEND;
    IFEND;

    {Add a critical device if necessary

    IF (volume_count = 0) AND (volume_selector.class = rmc$msc_system_critical_files) THEN
      osp$test_set_main_sig_lock (dmv$q_add_lock, able_to_lock);
      IF able_to_lock THEN
        selector := volume_selector;
        selector.class := dmc$default_class;
        get_volume_list (selector, p_volume_list, volume_count);

        IF (volume_count > 0) THEN
          avt_index := p_volume_list^ [1];
          dmp$add_class_to_volume (avt_index, $dmt$class [rmc$msc_system_critical_files] +
              dmv$p_active_volume_table^ [avt_index].mass_storage.class, status);
          IF status.normal THEN
            dmv$q_devices_added := dmv$q_devices_added + 1;
            volume_count := 1;
          ELSE
            volume_count := 0;
          IFEND;
        IFEND;
        osp$clear_mainframe_sig_lock (dmv$q_add_lock);
      IFEND;
    IFEND;

    {select a volume from the volume list

    IF (volume_count > 0) THEN
      IF (class_ordinal = 0) THEN
        selected_index := (dmv$volume_selector MOD volume_count) + 1;
      ELSE
        selected_index := 1 + ((class_ordinal - 1) MOD volume_count);
      IFEND;

      avt_index := p_volume_list^ [selected_index];
      dmv$volume_selector := dmv$volume_selector + 1;
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_alloc_all_space,
        'No volume for file - select_best_volume.', status);
    IFEND;
  PROCEND select_best_volume;
?? TITLE := '  select_volume', EJECT ??

  PROCEDURE select_volume (volume_selector: t$volume_selector;
    VAR avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      avt_entry_found: boolean,
      external_setname: stt$set_name,
      recorded_vsn: rmt$recorded_vsn,
      setname_supplied: boolean,
      recorded_vsn_supplied: boolean,
      allocation_allowed: boolean,
      p_selected_vol_attributes: ^array [ * ] of dmt$assigned_ms_vol_attribute;

    status.normal := TRUE;

    avt_index := 0;

    external_setname := volume_selector.set_name;
    setname_supplied :=  (external_setname <> osc$null_name);

    recorded_vsn := volume_selector.recorded_vsn;
    recorded_vsn_supplied := (recorded_vsn <> '      ');

  /process_request/
    BEGIN
      IF recorded_vsn_supplied THEN
        PUSH p_selected_vol_attributes: [1 .. 3];
        p_selected_vol_attributes^ [1].keyword := dmc$ms_allocation_allowed;
        p_selected_vol_attributes^ [2].keyword := dmc$ms_volume_unavailable;
        p_selected_vol_attributes^ [3].keyword := dmc$avt_index;

        dmp$get_active_vol_attributes (recorded_vsn, avt_index, p_selected_vol_attributes, avt_entry_found);

        IF  avt_entry_found THEN
          avt_index := p_selected_vol_attributes^ [3].index;
        ELSE
          osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
                'AVT entry not found - select_volume.', status);
          osp$append_status_parameter (' ', recorded_vsn, status);
          EXIT /process_request/;
        IFEND;

        IF setname_supplied THEN
          IF (external_setname <> dmv$p_active_volume_table^ [avt_index].mass_storage.set_name) THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_alloc_all_space,
                  'Volume not part of set - select_volume.', status);
            osp$append_status_parameter (' ', recorded_vsn, status);
            osp$append_status_parameter (' ', external_setname, status);
            EXIT /process_request/;
          IFEND;
        IFEND;

        IF NOT (volume_selector.class IN dmv$p_active_volume_table^ [avt_index].mass_storage.class) THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$file_class_not_valid,
                'File class not valid on volume - select_volume.', status);
          osp$append_status_parameter (' ', recorded_vsn, status);
          EXIT /process_request/;
        IFEND;

{       check volume_unavailable before allocation_allowed
        IF p_selected_vol_attributes^ [2].volume_unavailable THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable,
           recorded_vsn, status);
          EXIT /process_request/;
        IFEND;

        allocation_allowed := p_selected_vol_attributes^ [1].allocation_allowed;
        IF NOT allocation_allowed THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_alloc_all_space,
                'Allocation not allowed on volume - select_volume.', status);
          osp$append_status_parameter (' ', recorded_vsn, status);
          EXIT /process_request/;
        IFEND;

      ELSE
        select_best_volume (volume_selector, avt_index, status);
      IFEND;
    END /process_request/;

  PROCEND select_volume;
?? TITLE := '  unlogged_assign_volume', EJECT ??

  PROCEDURE unlogged_assign_volume (sfid: gft$system_file_identifier;
        p_fde: ^gft$file_descriptor_entry;
        p_dfd: ^dmt$disk_file_descriptor;
        p_fmd: ^dmt$file_medium_descriptor;
        byte_address: amt$file_byte_address;
        vsn: rmt$recorded_vsn;
    VAR status: ost$status);

    VAR
      allocated_length: amt$file_byte_address,
      allocation_style: dmt$allocation_styles,
      avt_index: dmt$active_volume_table_index,
      bytes_per_allocation: dmt$allocation_size,
      bytes_per_dau: dmt$bytes_per_dau,
      dat_sfid: gft$system_file_identifier,
      daus_per_allocation: dmt$daus_per_allocation,
      dfl_index: dmt$device_file_list_index,
      dfl_sfid: gft$system_file_identifier,
      file_damaged: boolean,
      file_flawed: boolean,
      first_dau: dmt$dau_address,
      internal_vsn: dmt$internal_vsn,
      local_status: ost$status,
      number_of_aus: amt$file_byte_address,
      number_of_daus: amt$file_byte_address,
      p_allocation_list: ^t$allocation_list,
      p_attributes: ^array [ * ] of dmt$assigned_ms_vol_attribute,
      p_mat: ^dmt$mainframe_allocation_table,
      volume_found: boolean;

    status.normal := TRUE;

    PUSH p_attributes: [1 .. 4];
    p_attributes^ [1].keyword := dmc$avt_index;
    p_attributes^ [2].keyword := dmc$ms_internal_vsn;
    p_attributes^ [3].keyword := dmc$ms_device_allocation_table;
    p_attributes^ [4].keyword := dmc$ms_device_file_list_table;
    avt_index := 0;

    dmp$get_active_vol_attributes (vsn, avt_index, p_attributes, volume_found);

    IF NOT volume_found THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found, vsn, status);
      RETURN;
    IFEND;

    avt_index := p_attributes^ [1].index;
    internal_vsn := p_attributes^ [2].internal_vsn;
    dat_sfid := p_attributes^ [3].p_dat;
    dfl_sfid := p_attributes^ [4].p_dflt;

    dmp$get_mat_pointer (avt_index, p_mat);

  /update_lock/
    BEGIN

      bytes_per_allocation := p_dfd^.requested_allocation_size;
      bytes_per_dau := p_mat^.bytes_per_dau;
      number_of_daus := (bytes_per_allocation + bytes_per_dau - 1) DIV bytes_per_dau;

    /determine_allocation_style/
      FOR allocation_style := LOWERVALUE (dmt$allocation_styles) TO UPPERVALUE (dmt$allocation_styles) DO
        IF p_mat^.daus_per_allocation_unit [allocation_style] >= number_of_daus THEN
          EXIT /determine_allocation_style/;
        IFEND;
      FOREND /determine_allocation_style/;

      daus_per_allocation := p_mat^.daus_per_allocation_unit [allocation_style];
      bytes_per_allocation := bytes_per_dau * daus_per_allocation;
      number_of_aus := (byte_address + 1 + bytes_per_allocation - 1) DIV bytes_per_allocation;
      allocated_length := number_of_aus * bytes_per_allocation;

      PUSH p_allocation_list: [1 .. number_of_aus];
      find_allocation (dat_sfid, p_mat, allocation_style, daus_per_allocation, p_allocation_list, status);
      IF NOT status.normal THEN
        EXIT /update_lock/;
      IFEND;

      first_dau := p_allocation_list^ [1];
      create_dfl_entry (first_dau, dfl_sfid, p_fde^.global_file_name, sfid.file_hash, allocated_length,
            daus_per_allocation, avt_index, dfl_index, status);
      IF NOT status.normal THEN
        EXIT /update_lock/;
      IFEND;

    /dfl_created/
      BEGIN

        dat_allocate (avt_index, dat_sfid, sfid.file_hash, dfl_index, daus_per_allocation,
              p_allocation_list, status);
        IF NOT status.normal THEN
          EXIT /dfl_created/;
        IFEND;

      /allocate_file/
        BEGIN
          p_fmd^.internal_vsn := internal_vsn;
          p_fmd^.dfl_index := dfl_index;
          p_fmd^.volume_assigned := TRUE;

          dmp$build_fmd_for_existing_file (p_fde, p_dfd, sfid, file_damaged, file_flawed, status);
          IF status.normal THEN
            EXIT /update_lock/;
          IFEND;

        END /allocate_file/;

        dat_deallocate (dat_sfid, sfid.file_hash, daus_per_allocation, first_dau, avt_index, local_status);

      END /dfl_created/;

      delete_dfl_entry (dfl_sfid, dfl_index, avt_index, local_status);

    END /update_lock/;

  PROCEND unlogged_assign_volume;
?? TITLE := '  verify_allocation', EJECT ??

  PROCEDURE verify_allocation (p_mat: ^dmt$mainframe_allocation_table;
        daus_per_allocation: dmt$daus_per_allocation;
        p_allocation_list: ^t$allocation_list;
        start_index: integer;
    VAR new_index: integer);

    VAR
      dau_count: dmt$dau_address,
      daus_per_position: dmt$daus_per_position,
      first_dau: dmt$dau_address,
      index: integer,
      isolation_index: integer,
      last_index: integer,
      limit_dau: dmt$dau_address,
      next_dau: dmt$dau_address,
      next_index: integer,
      verified: boolean;

    daus_per_position := p_mat^.daus_per_position;
    index := start_index;
    new_index := start_index;
    isolation_index := start_index;
    last_index := UPPERBOUND (p_allocation_list^);

    WHILE (index <= last_index) DO
      first_dau := p_allocation_list^ [index];
      next_dau := first_dau;
      next_index := index;
      IF (index < isolation_index) THEN
        limit_dau := first_dau + daus_per_allocation;
      ELSE
        limit_dau := first_dau DIV daus_per_position * daus_per_position + daus_per_position;
      IFEND;
      REPEAT
        next_dau := next_dau + daus_per_allocation;
        next_index := next_index + 1;
      UNTIL (next_index > last_index) OR (next_dau <> p_allocation_list^ [next_index]) OR
            (next_dau >= limit_dau);
      dau_count := next_dau - first_dau;

      verify_device_space (p_mat, daus_per_allocation, dau_count, first_dau, verified);

      IF verified THEN
        IF (index = new_index) THEN
          index := next_index;
          new_index := next_index;
        ELSE
          REPEAT
            p_allocation_list^ [new_index] := p_allocation_list^ [index];
            index := index + 1;
            new_index := new_index + 1;
          UNTIL (index >= next_index);
        IFEND;
      ELSEIF (dau_count = daus_per_allocation) THEN
        index := next_index;
      ELSE
        isolation_index := next_index;
      IFEND;
    WHILEND;
  PROCEND verify_allocation;
?? TITLE := '  verify_device_space', EJECT ??

  PROCEDURE verify_device_space (p_mat: ^dmt$mainframe_allocation_table;
        daus_per_allocation_unit: dmt$daus_per_allocation;
        number_of_consecutive_daus: dmt$dau_address;
        first_dau_address: dmt$dau_address;
    VAR verified: boolean);


    VAR
      dau_index: dmt$dau_address,
      device_address: dmt$ms_logical_device_address,
      excess_verify_units: dmt$dau_address,
      p_completion_status: ^iot$completion_status,
      p_read_buffer: ^SEQ ( * ),
      status: ost$status,
      verify_units: dmt$dau_address;

    status.normal := TRUE;
    IF dmv$quick_deadstart THEN
      verified := TRUE;
      RETURN;
    IFEND;

    verify_units := number_of_consecutive_daus DIV daus_per_allocation_unit;
    verified := FALSE;

    device_address.maus_per_position := p_mat^.maus_per_dau * p_mat^.daus_per_position;
    device_address.logical_unit_number := dmv$p_active_volume_table^ [p_mat^.avt_index].
          logical_unit_number;
    device_address.transfer_length := p_mat^.maus_per_dau * daus_per_allocation_unit;
    device_address.transfer_mau_offset := 0;
    device_address.au_was_previously_written := FALSE;
    device_address.maus_per_allocation_unit := p_mat^.maus_per_dau * daus_per_allocation_unit;
    device_address.preset_value := 0;

    PUSH p_read_buffer: [[REP p_mat^.bytes_per_dau * 4 OF cell]];

    RESET p_read_buffer;
    pmp$zero_out_table (p_read_buffer, #SIZE (p_read_buffer^));

    device_address.write_translation := TRUE;

    FOR dau_index := 1 TO verify_units DO
      device_address.allocation_unit_mau_address := ((dau_index - 1) * daus_per_allocation_unit +
            first_dau_address) * p_mat^.maus_per_dau;

      iop$mass_storage_io (NIL, 0, ioc$write_mass_storage, device_address,
            TRUE, p_completion_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    FOREND;

{
{          read verify the allocation units.
{
    device_address.write_translation := FALSE;
    device_address.transfer_length := p_mat^.maus_per_dau * 4;
    device_address.maus_per_allocation_unit := p_mat^.maus_per_dau * 4;

    verify_units := number_of_consecutive_daus DIV 4;
    excess_verify_units := number_of_consecutive_daus MOD 4;

    FOR dau_index := 1 TO verify_units DO
      device_address.allocation_unit_mau_address := ((dau_index - 1) * 4 + first_dau_address) * p_mat^.
            maus_per_dau;

      iop$mass_storage_io (p_read_buffer, p_mat^.bytes_per_dau, ioc$read_mass_storage, device_address,
            TRUE, p_completion_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    IF excess_verify_units > 0 THEN
      device_address.maus_per_allocation_unit := p_mat^.maus_per_dau * excess_verify_units;
      device_address.allocation_unit_mau_address := (verify_units * 4 + first_dau_address) * p_mat^.
            maus_per_dau;
      device_address.transfer_length := p_mat^.maus_per_dau * excess_verify_units;

      iop$mass_storage_io (p_read_buffer, p_mat^.bytes_per_dau, ioc$read_mass_storage, device_address,
            TRUE, p_completion_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    verified := TRUE;

  PROCEND verify_device_space;
?? TITLE := '  dmp$reallocate_file_space', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$reallocate_file_space
    (    system_file_id: gft$system_file_identifier;
         copy_pages: boolean;
     VAR status: ost$status);

    VAR
      fau_entry: dmt$fau_entries,
      ignore_status: ost$status,
      identifier: ost$status_identifier,
      level_1_index: dmt$level_1_index,
      level_2_index: dmt$level_2_index,
      monitor_request_block: dmt$monitor_rb_reallocate_space,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fau: ^dmt$file_allocation_unit,
      p_fde: ^gft$file_descriptor_entry,
      p_fmd: ^dmt$file_medium_descriptor,
      p_level_2: ^dmt$level_2_table,
      p_previous_fau: ^dmt$file_allocation_unit;

?? EJECT ??
  PROCEDURE reallocate_fau;

    VAR
      after_eoi: amt$file_byte_address,
      before_eoi: amt$file_byte_address,
      fau_offset: integer,
      fau_size: integer,
      ignore_status: ost$status,
      seg: ost$segment,
      p_data: ^cell,
      p_save: ^array [1 .. * ] of cell;

    PROCEDURE ch
      (    mf: ost$monitor_fault;
           p_msa: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      VAR
        p_sac: ^mmt$segment_access_condition,
        ignore: ost$status;

      IF mf.identifier = mmc$segment_fault_processor_id THEN
        p_sac := #LOC (mf.contents);
        CASE p_sac^.identifier OF
        = mmc$sac_io_read_error =
          osp$set_status_abnormal ('MM', mme$io_read_error,
                'Cannot reallocate file space - dmp$reallocate_file_space', status);
        ELSE
          osp$set_status_abnormal ('MM', mme$io_read_error,
                'Cannot reallocate file space - dmp$reallocate_file_space', status);
        CASEND;
        mmp$close_device_file (seg, ignore_status);
        {dmp$reallocate_file_space expects fde to be locked
        gfp$get_locked_fde_p (system_file_id, p_fde);
        EXIT reallocate_fau;
      IFEND;

      syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);

    PROCEND ch;

    IF copy_pages THEN
      mmp$open_file_by_sfid (system_file_id, 1, 1, mmc$as_random,
            mmc$sar_write_extend, seg, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    fau_size := p_dfd^.bytes_per_allocation;
    fau_offset := (level_1_index * p_dfd^.bytes_per_level_2) + (level_2_index * fau_size);
    p_data := #ADDRESS (1, seg, fau_offset);
    PUSH p_save: [1 .. fau_size];

    monitor_request_block.request_code := syc$rc_reallocate_front_end;
    monitor_request_block.system_file_id := system_file_id;
    monitor_request_block.allocation_units_obtained := 0;
    monitor_request_block.reallocate_byte_address := fau_offset;
    monitor_request_block.copy_pages := copy_pages;

  /reallocate_loop/
    WHILE TRUE DO

      IF copy_pages THEN

      dmp$fetch_eoi (system_file_id, before_eoi, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

        gfp$unlock_fde_p (p_fde);

        syp$establish_condition_handler (^ch);

        {Touch pages -
        {This allows detection of any read i/o errors
        {MUST BE DONE WITH FDE UNLOCKED TO ALLOW PAGE FAULTS TO WORK!
        i#move (p_data, p_save, fau_size);

        IF p_dfd^.damaged_detection_enabled THEN
          mmp$write_modified_pages (p_data, fau_size, osc$wait, status);
        IFEND;

        syp$disestablish_cond_handler;

        gfp$get_locked_fde_p (system_file_id, p_fde);

      dmp$fetch_eoi (system_file_id, after_eoi, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF after_eoi > before_eoi THEN
        IF after_eoi = (fau_offset + fau_size) THEN
          {Reallocation changed eoi to end of the last AU
          dmp$set_eoi (system_file_id, before_eoi, status);
        IFEND;
      IFEND;

      IFEND;

      i#call_monitor (#LOC (monitor_request_block), #SIZE (monitor_request_block));

      IF NOT monitor_request_block.status.normal THEN
        osp$unpack_status_identifier (monitor_request_block.status. condition, identifier);
        osp$set_status_abnormal (identifier, monitor_request_block.status.condition,
              'Monitor reallocate reject - dmp$reallocate_file_space', status);

        { It's best not to hang in ring 1 waiting for disk space.  Until something better
        { can be done, just ignore disk full.

        IF (status.condition = dme$unable_to_alloc_all_space) THEN
          status.normal := TRUE;
        IFEND;
      ELSE
        status.normal := TRUE;
      IFEND;

      IF status.normal OR (status.condition <> mme$page_not_in_page_table) THEN
        EXIT /reallocate_loop/;
      IFEND;

      gfp$unlock_fde_p (p_fde);

      pmp$delay (allocator_delay_time {milliseconds} , status);

      gfp$get_locked_fde_p (system_file_id, p_fde);

    WHILEND /reallocate_loop/;

    IF copy_pages THEN

      mmp$close_device_file (seg, ignore_status);

      IF status.normal AND (NOT ignore_status.normal) THEN
        status := ignore_status;
      IFEND;

    IFEND;

  PROCEND reallocate_fau;
?? EJECT ??

    status.normal := TRUE;

    gfp$get_locked_fde_p (system_file_id, p_fde);
    IF p_fde <> NIL THEN

      IF p_fde^.media = gfc$fm_served_file THEN
        dmp$df_client_reallocate_space (p_fde, system_file_id, status);
{ File_Descriptor_Entry (FDE) lock has been cleared by the callee.
        RETURN;
      IFEND;

      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

      IF (p_dfd <> NIL) THEN
        FOR level_1_index := LOWERVALUE (level_1_index) TO p_dfd^.fat_upper_bound DO
          dmp$get_level_2_ptr (^p_dfd^.file_allocation_table^ [level_1_index], p_level_2);
          IF p_level_2 <> NIL THEN
            FOR level_2_index := LOWERVALUE (level_2_index) TO
              (p_dfd^.bytes_per_level_2 DIV p_dfd^.bytes_per_allocation - 1) DO
              IF (p_level_2^ [level_2_index].state = dmc$fau_invalid_and_flawed) OR
                 (p_level_2^ [level_2_index].state = dmc$fau_initialized_and_flawed) THEN
                reallocate_fau;
              IFEND;
            FOREND;
          IFEND;
        FOREND;

        IF p_dfd^.damaged_detection_enabled THEN
          dmp$split_allocation_log ({flush_device_log_pages} TRUE, ignore_status);
        IFEND;
      IFEND;

      gfp$unlock_fde_p (p_fde);
    ELSE {not found
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
            ' Invalid SFID - dmp$reallocate_file_space', status);
    IFEND;
  PROCEND dmp$reallocate_file_space;
?? TITLE := '  dmp$df_client_reallocate_space', EJECT ??
  PROCEDURE [XDCL] dmp$df_client_reallocate_space
    (    fde_p: ^gft$file_descriptor_entry;
         system_file_id: gft$system_file_identifier;
     VAR status: ost$status);

    VAR
      global_file_name: ost$binary_unique_name,
      local_status: ost$status,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_parameters: ^dmt$df_reallocate_filespace_inp,
      p_send_to_server_params: dft$p_send_parameters,
      p_server_descriptor: dmt$p_server_descriptor,
      queue_entry_location: dft$rpc_queue_entry_location,
      remote_sfid: gft$system_file_identifier,
      served_family_table_index: dft$served_family_table_index;

    status.normal := TRUE;
    global_file_name := fde_p^.global_file_name;
    dfp$get_served_file_desc_p (fde_p, p_server_descriptor);
    IF (p_server_descriptor^.header.file_state = dfc$awaiting_recovery) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dfe$server_not_active, '',
           status);
      gfp$unlock_fde_p (fde_p);
      RETURN;
    ELSEIF (p_server_descriptor^.header.file_state = dfc$terminated) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dfe$server_has_terminated, '',
         status);
      gfp$unlock_fde_p (fde_p);
      RETURN;
    IFEND;
    served_family_table_index := p_server_descriptor^.header.served_family_table_index;
    remote_sfid := p_server_descriptor^.header.remote_sfid;
    gfp$unlock_fde_p (fde_p);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dfp$begin_remote_core_call (served_family_table_index, { Allowed when deactive } TRUE,
          queue_entry_location, p_send_to_server_params, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.sfid := remote_sfid;
    dfp$uncomplement_gfn (global_file_name, p_send_parameters^.global_file_name);
    dfp$send_remote_core_call (queue_entry_location, dfc$r1_df_server_reallocate, #SIZE (p_send_parameters^),
          p_receive_from_server_params, status);

    dfp$end_remote_core_call (queue_entry_location, local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND dmp$df_client_reallocate_space;

?? TITLE := 'dmp$sparse_allocate', EJECT ??

  PROCEDURE [XDCL] dmp$sparse_allocate
    (    sfid: gft$system_file_identifier;
         offset_requiring_allocation: amt$file_byte_address;
         file_space_limit: sft$file_space_limit_kind;
     VAR status: ost$status);

    VAR
      pages: ^array [ * ] of ost$segment_offset,
      mmv$create_sparse: [XDCL] integer := 0,
      able: boolean,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      p_fmd: ^dmt$file_medium_descriptor,
      p_fau: ^dmt$file_allocation_unit,
      i,
      max_pages_no_file,
      number_of_pages: integer;

    gfp$get_fde_p (sfid, p_fde);
    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

    IF p_dfd^.file_allocation_table <> NIL THEN
{       mmc$assign_active_escaped is a flag indicating escaped allocation -
{       must process all modified pages
      IF offset_requiring_allocation < mmc$assign_active_null THEN
        dmp$allocate_file_space_r1 (sfid, offset_requiring_allocation, 1, 0, osc$nowait,
              file_space_limit, status);
        RETURN;
      IFEND;
    IFEND;

    number_of_pages := mmv$max_pages_no_file;
    IF number_of_pages < 0 THEN
      number_of_pages := - number_of_pages;
    IFEND;
    number_of_pages := number_of_pages + 50;

    REPEAT
      max_pages_no_file := number_of_pages;
      PUSH pages: [1 .. max_pages_no_file];
      mmp$fetch_offset_mod_pages_r1 (0 {segment_number}, sfid, TRUE {return_unallocated_offsets},
          pages, number_of_pages, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    UNTIL number_of_pages <= max_pages_no_file;

    IF number_of_pages = 0 THEN
      {If no modified pages and fat not assigned, must force allocation
      dmp$allocate_file_space_r1 (sfid, 0, 1, 0, osc$nowait,
            file_space_limit, status);
      RETURN;
    IFEND;

    mmv$create_sparse := mmv$create_sparse + 1;

    FOR i := 1 TO number_of_pages DO
      dmp$get_fau_entry (p_dfd, pages^ [i], p_fau);
      IF (p_fau = NIL) OR (p_fau^.state = dmc$fau_free) THEN
        dmp$allocate_file_space_r1 (sfid, pages^ [i], 1, 0, osc$nowait, file_space_limit, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND dmp$sparse_allocate;
MODEND dmm$job_allocator;

*DECK DECK=DMM$LOGGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$logger;

{
{  PURPOSE:
{
{    This module contains the code which is responsible for accumulating
{    and processing transactions against the volume resident tables
{    maintained by device management.
{
{  DESIGN:
{
{    The transactions against the volume files are accumulated in a
{    device log for the volume and then periodically processed.
{
?? PUSH (LISTEXT := ON) ??
*copyc mme$condition_codes
*copyc cmp$change_state_info_table
*copyc cmp$pc_get_logical_unit
*copyc cmt$request_block
*copyc cmv$logical_pp_table_p
*copyc cyd$cybil_structure_definitions
*copyc dmp$allocate_file_space_r1
*copyc dmp$close_file
*copyc dmp$complete_sft_delete
*copyc dmp$dat_purge_file
*copyc dmp$generate_gfn_hash
*copyc dmp$get_avt_logging_info
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_fau_entry
*copyc dmp$get_fmd_by_index
*copyc dmp$get_mat_pointer
*copyc dmp$locate_volume_label
*copyc dmp$lock_avt_entry
*copyc dmp$open_dat
*copyc dmp$open_dflt
*copyc dmp$open_file
*copyc dmp$open_login_table
*copyc dmp$search_active_volume_table
*copyc dmp$set_eoi
*copyc mmp$open_file_by_sfid
*copyc dmp$unlock_avt_entry
*copyc dmt$active_volume_table_index
*copyc dmt$allocation_log
*copyc dmt$assigned_ms_vol_attributes
*copyc dmt$avt_search_key
*copyc dmt$dat_change
*copyc dmt$device_log_entries
*copyc dmt$device_position
*copyc dmt$dfl_change
*copyc dmt$error_condition_codes
*copyc dmt$keypoint_calls
*copyc dmt$log_flaw_init_data
*copyc dmt$mainframe_assigned
*copyc dmt$mat_change_request
*copyc dmt$ms_device_allocation_table
*copyc dmt$ms_login_table
*copyc rmt$recorded_vsn
*copyc cmv$post_deadstart
*copyc dmv$active_volume_table
*copyc dmv$allocation_log
*copyc dmv$debug_options
*copyc dmv$idle_system
*copyc dmv$internal_task_exec_counts
*copyc dmv$internal_tasks_initiated
*copyc dmv$recycled_log
*copyc dmv$recycle_device_log
*copyc dmv$null_sfid
*copyc dmv$null_vsn
*copyc dpp$put_critical_message
*copyc gfp$get_fde_p
*copyc gfp$get_locked_fde_p
*copyc gfp$unlock_fde_p
*copyc i#call_monitor
*copyc i#move
*copyc jmc$special_dispatch_priorities
*copyc mmp$write_modified_pages
*copyc mmp$free_pages
*copyc osd$cybil_structure_definitions
*copyc osk$keypoints
*copyc osp$append_status_parameter
*copyc osp$begin_system_activity
*copyc osp$clear_mainframe_sig_lock
*copyc osp$end_system_activity
*copyc osp$fetch_locked_variable
*copyc osp$file_access_condition
*copyc osp$increment_locked_variable
*copyc osp$set_locked_variable
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$fatal_system_error
*copyc osp$test_set_main_sig_lock
*copyc oss$mainframe_paged_literal
*copyc ost$wait
*copyc osv$mainframe_pageable_heap
*copyc osv$mainframe_wired_heap
*copyc osv$recover_at_all_costs
*copyc pmp$delay
*copyc sft$file_space_limit_kind
*copyc syp$continue_to_cause
*copyc syp$disestablish_cond_handler
*copyc syp$establish_condition_handler
*copyc syt$system_core_condition
*copyc tmp$ready_system_task1
*copyc tmp$set_task_priority
?? POP ??
?? TITLE := '  Global Variables', EJECT ??

  VAR
    dmv$test_recovery: [STATIC, XDCL] boolean := FALSE,

    dmv$flush_dev_log_pages_count: [STATIC, XDCL, oss$mainframe_pageable] integer := 0,

    device_log_check_byte: [STATIC, READ, oss$mainframe_paged_literal] 0 .. 0ff(16) := 0a5(16),

    log_entry_data_size: [STATIC, READ, oss$mainframe_paged_literal] array [dmt$dl_entry_kind] of 0 .. 0ff(16)
      :=
{dmc$invalid_dl_entry           } [0,
{dmc$dl_allocate                } #SIZE (dmt$dl_allocate_block),
{dmc$dl_first_sft_delete        } #SIZE (dmt$dl_sft_delete_block),
{dmc$dl_second_sft_delete       } #SIZE (dmt$dl_sft_delete_block),
{dmc$dl_third_sft_delete        } #SIZE (dmt$dl_sft_delete_block),
{dmc$dl_create                  } #SIZE (dmt$dl_create_block),
{dmc$dl_return_dau              } #SIZE (dmt$dl_return_dau_block),
{dmc$dl_disk_tables_updated     } 0,
{dmc$dl_attach_file             } #SIZE (dmt$dl_attach_file_block),
{dmc$dl_detach_file             } #SIZE (dmt$dl_attach_file_block),
{dmc$dl_initialize              } #SIZE (dmt$dl_initialize_block),
{dmc$dl_last_update_entry       } 0,
{dmc$dl_purge_file              } #SIZE (dmt$dl_purge_file_block),
{dmc$dl_second_purge_file       } #SIZE (dmt$dl_purge_file_block),
{dmc$dl_release_dau             } #SIZE (dmt$dl_release_dau_block),
{dmc$dl_release_dfl             } #SIZE (dmt$dl_release_dfl_block),
{dmc$dl_return_dfl              } #SIZE (dmt$dl_return_dfl_block),
{dmc$dl_software_flawed         } #SIZE (dmt$dl_software_flaw_block),
{dmc$dl_start_update            } 0,
{dmc$dl_update_disk_tables      } 0,
{dmc$dl_update_file_length      } #SIZE (dmt$dl_file_length_block),
{dmc$dl_update_fmd_length       } #SIZE (dmt$dl_fmd_length_block),
{dmc$dl_file_damaged            } #SIZE (dmt$dl_file_damaged_block),
{dmc$dl_reallocate              } #SIZE (dmt$dl_reallocate_block),
{dmc$dl_trim_file               } #SIZE (dmt$dl_trim_file_block),
{dmc$dl_deallocate_file_fragment} #SIZE (dmt$dl_deallocate_fragment_blk),
{dmc$dl_continue_purge          } #SIZE (dmt$dl_release_dau_block),
{dmc$dl_sa_on_dl_entry          } 0,
{dmc$dl_sa_after_process_dl     } 0,
{dmc$dl_sa_bef_next_dfl_change  } 0,
{dmc$dl_sa_aft_next_dfl_change  } 0,
{dmc$dl_sa_bef_next_dat_change  } 0,
{dmc$dl_sa_aft_next_dat_change  } 0,
{dmc$dl_sa_bef_logging_dtu      } 0,
{dmc$dl_sa_bef_mf_table_update  } 0,
{dmc$dl_sa_aft_mf_table_update  } 0,
{dmc$dl_ra_on_dl_entry          } 0,
{dmc$dl_ra_after_process_dl     } 0,
{dmc$dl_ra_bef_next_dfl_change  } 0,
{dmc$dl_ra_aft_next_dfl_change  } 0,
{dmc$dl_ra_bef_next_dat_change  } 0,
{dmc$dl_ra_aft_next_dat_change  } 0,
{dmc$dl_ra_bef_logging_dtu      } 0,
{dmc$dl_recycle_dau             } #SIZE (dmt$dl_return_dau_block)];

?? EJECT ??

  VAR
    dmv$continue_purge_limit: [STATIC, XDCL, oss$mainframe_pageable] integer := 1500;

  VAR
    dmv$min_sorted_entries: [STATIC, XDCL, oss$mainframe_pageable] integer := 0ffffffffffff(16),
    dmv$max_sorted_entries: [STATIC, XDCL, oss$mainframe_pageable] integer := 0,
    dmv$running_total_entries: [STATIC, XDCL, oss$mainframe_pageable] integer := 0,
    dmv$running_total_sorts: [STATIC, XDCL, oss$mainframe_pageable] integer := 0,

    dmv$last_volume_downed_status: [STATIC, XDCL, oss$mainframe_pageable] ost$status := [TRUE],

    dmv$minimum_log_count: [STATIC, XDCL, oss$mainframe_pageable] integer := 2,

    dmv$skipped_evacuate,
    dmv$skipped_update: [STATIC, XDCL, oss$mainframe_pageable] integer := 0,
    dmv$running_total_iterations: [STATIC, XDCL, oss$mainframe_pageable] integer := 0,
    dmv$running_total_exchanges: [STATIC, XDCL, oss$mainframe_pageable] integer := 0;

  VAR
    dmv$dat_change_errors: [STATIC, XDCL, oss$mainframe_pageable] dmt$dat_change_errors := [0, *],
    dmv$dfl_change_errors: [STATIC, XDCL, oss$mainframe_pageable] dmt$dfl_change_errors := [0, *];

?? TITLE := '  dmp$change_dfl_damage', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$change_dfl_damage
    (   avt_index: dmt$active_volume_table_index;
        add_damage: dmt$file_damage;
        remove_damage: dmt$file_damage;
        dfl_index: dmt$device_file_list_index;
        flush_device_log: boolean;
        global_file_name: dmt$global_file_name;
    VAR status: ost$status);

    VAR
      avt_entry_found: boolean,
      device_log: dmt$device_log,
      log_entry: dmt$dl_entry,
      flush_status: ost$status,
      info: dmt$avt_logging_info;

    log_entry.kind := dmc$dl_file_damaged;
    log_entry.file_damaged_block.global_file_name := global_file_name;
    log_entry.file_damaged_block.dfl_index := dfl_index;
    log_entry.file_damaged_block.add_damage := add_damage;
    log_entry.file_damaged_block.remove_damage := remove_damage;

    dmp$process_device_log_entry (avt_index, log_entry, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF flush_device_log THEN
      dmp$get_avt_logging_info (avt_index, info, avt_entry_found);
      IF NOT avt_entry_found THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
          'unable to locate avt entry - dmp$change_dfl_damge', status);
        RETURN;
      IFEND;

      IF info.device_log_sfid = dmv$null_sfid THEN
       osp$set_status_abnormal (dmc$device_manager_ident, dme$logging_unavailable,
         'dmp$change_dfl_damge', status);
        RETURN;
      IFEND;

      open_device_log (info.device_log_sfid, TRUE, device_log, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Volume_down (status) will be returned if the volume is down and will be treated
{ as an exception condition by the higher level callers of the following
{ procedure.

      mmp$write_modified_pages (device_log, #SIZE(device_log^), osc$wait, flush_status);

      dmp$close_file (device_log, status);
      IF status.normal AND NOT flush_status.normal THEN
        status := flush_status;
      IFEND;
    IFEND;

  PROCEND dmp$change_dfl_damage;
?? TITLE := '  dmp$clear_update_lock', EJECT ??

  PROCEDURE [XDCL] dmp$clear_update_lock
    (    avt_index: dmt$active_volume_table_index);


    osp$clear_mainframe_sig_lock (dmv$p_active_volume_table^ [avt_index].mass_storage.update_lock);

  PROCEND dmp$clear_update_lock;
?? TITLE := '  dmp$dev_mgmt_table_update', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$dev_mgmt_table_update;

    VAR
      status: ost$status,
      ok: boolean,
      avt_index: dmt$active_volume_table_index;

    osp$begin_system_activity;

    dmv$process_device_log_count := (dmv$process_device_log_count + 1) MOD UPPERVALUE
          (dmv$process_device_log_count);

    FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND (dmv$p_active_volume_table^) DO

      IF NOT dmv$p_active_volume_table^ [avt_index].entry_available THEN

        IF dmc$mainframe_mounted IN dmv$p_active_volume_table^ [avt_index].mass_storage.status THEN
          dmp$verify_access (avt_index, ok);
          IF ok THEN

            update_volume_tables (avt_index, status);
            IF NOT status.normal THEN
              osp$fatal_system_error
                 ('unable to update tables from log - dmp$dev_mgmt_table_update', ^status);
            IFEND;

          ELSE
            dmv$skipped_update := dmv$skipped_update + 1;
          IFEND;
        IFEND;
      IFEND;

    FOREND;

    osp$end_system_activity;

  PROCEND dmp$dev_mgmt_table_update;
?? TITLE := '  dmp$enable_update', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$enable_update (avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      able_to_lock_avt_entry: boolean,
      able_to_unlock_avt_entry: boolean;

    status.normal := TRUE;

    IF NOT dmv$test_recovery THEN
      RETURN;
    IFEND;

    REPEAT
      dmp$lock_avt_entry (avt_index, able_to_lock_avt_entry);
      IF NOT able_to_lock_avt_entry THEN
        pmp$delay (500 {milliseconds} , status);
      IFEND;
    UNTIL able_to_lock_avt_entry;

    IF (NOT dmv$p_active_volume_table^ [avt_index].entry_available) THEN
      dmv$p_active_volume_table^ [avt_index].mass_storage.disk_table_status := dmv$p_active_volume_table^
            [avt_index].mass_storage.disk_table_status - $dmt$ms_volume_table_status
            [dmc$table_update_inhibited];
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
        'bad volume selected - DMMLOG', status);
    IFEND;

    dmp$unlock_avt_entry (avt_index, able_to_unlock_avt_entry);
    IF NOT able_to_unlock_avt_entry THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_clear_avt_lock,
        'unable to clear avt lock - DMMLOG', status);
    IFEND;

  PROCEND dmp$enable_update;
?? TITLE := '  dmp$evacuate_active_device_log', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$evacuate_active_device_log (avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      info: dmt$avt_logging_info,
      production_logging: boolean,
      current_position_in_log: integer,
      device_log: dmt$device_log,
      p_dat: ^dmt$ms_device_allocation_table,
      p_dflt: ^dmt$ms_device_file_list_table,
      aux_status: ost$status,
      ok: boolean,
      dummy_boolean: boolean;

    status.normal := TRUE;

    dmp$verify_access (avt_index, ok);
    IF NOT ok THEN
      dmv$skipped_evacuate := dmv$skipped_evacuate + 1;
      RETURN;
    IFEND;

    current_position_in_log := 0;

    dmp$split_allocation_log (FALSE, status);
    IF NOT status.normal THEN
      osp$fatal_system_error ('split al error', ^status);
    IFEND;

    osp$set_mainframe_sig_lock (dmv$p_active_volume_table^ [avt_index].mass_storage.update_lock);

  /tables_locked/
    BEGIN
      dmp$get_avt_logging_info (avt_index, info, dummy_boolean);

      open_device_log (info.device_log_sfid, FALSE, device_log, status);
      IF NOT status.normal THEN
        EXIT /tables_locked/;
      IFEND;

      dmp$open_dat (info.dat_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential,
            p_dat, status);
      IF NOT status.normal THEN
        EXIT /tables_locked/;
      IFEND;

      dmp$open_dflt (info.dfl_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential,
            p_dflt, status);
      IF NOT status.normal THEN
        EXIT /tables_locked/;
      IFEND;

      production_logging := TRUE;
      empty_device_log (info.login_table_sfid, device_log, info.mainframe_assigned, p_dat,
            p_dflt, avt_index, TRUE, production_logging, current_position_in_log, status);

      dmp$close_file (device_log, aux_status);
      IF NOT aux_status.normal AND status.normal THEN
        status := aux_status;
      IFEND;

      dmp$close_file (p_dat, aux_status);
      IF NOT aux_status.normal AND status.normal THEN
        status := aux_status;
      IFEND;

      dmp$close_file (p_dflt, aux_status);
      IF NOT aux_status.normal AND status.normal THEN
        status := aux_status;
      IFEND;

    END /tables_locked/;

    osp$clear_mainframe_sig_lock (dmv$p_active_volume_table^ [avt_index].mass_storage.update_lock);

  PROCEND dmp$evacuate_active_device_log;
?? TITLE := '  dmp$evacuate_old_device_log', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$evacuate_old_device_log (avt_index: dmt$active_volume_table_index;
        old_mainframe_assigned: dmt$mainframe_assigned;
        login_table_sfid: dmt$system_file_id;
        device_log_sfid: dmt$system_file_id;
        p_allocation_log_info: ^dmt$allocation_log_info;
    VAR status: ost$status);

    VAR
      recovery_logging: boolean,
      production_logging: boolean,
      old_log_position: integer,
      avt_index_found: boolean,
      p_dat: ^dmt$ms_device_allocation_table,
      p_dflt: ^dmt$ms_device_file_list_table,
      log_entry: dmt$dl_entry,
      device_log: [XDCL] dmt$device_log,
      p_login_table: [XDCL] ^dmt$ms_mainframe_login_table,
      p_dat_changes: ^dmt$dat_changes,
      p_dfl_changes: ^dmt$dfl_changes,
      number_dat_changes: integer,
      number_dfl_changes: integer,
      info: dmt$avt_logging_info,
      login_index: dmt$login_table_entry_index,
      recovery_dat_update_required: boolean,
      recovery_testing_aborts: dmt$dl_recovery_testing_aborts;

    status.normal := TRUE;

    recovery_testing_aborts := dmc$dl_no_abort;

    osp$set_mainframe_sig_lock (dmv$p_active_volume_table^ [avt_index].mass_storage.update_lock);

    dmp$get_avt_logging_info (avt_index, info, avt_index_found);

    dmp$open_dat (info.dat_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential,
          p_dat, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$open_dflt (info.dfl_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential,
          p_dflt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    open_device_log (device_log_sfid, FALSE, device_log, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$open_login_table (login_table_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend,
          mmc$as_sequential, p_login_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    login_index := old_mainframe_assigned.log_in_index;

    IF p_login_table^.body [login_index].recovery_status = dmc$lt_being_recovered THEN
      p_login_table^.body [login_index].recovery_status := dmc$lt_being_rec_log_complete;
      mmp$write_modified_pages (p_login_table, #SIZE (p_login_table^), osc$wait, status);
      IF NOT status.normal THEN
        IF osp$file_access_condition (status) THEN
          status.normal := TRUE;
        ELSE
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    find_place_in_log (old_mainframe_assigned, device_log, old_log_position, p_login_table,
          recovery_dat_update_required, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_allocation_log_info <> NIL THEN
      extract_log_entries_from_al (p_allocation_log_info, device_log, login_table_sfid, p_login_table,
            login_index, avt_index, old_log_position, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      mmp$write_modified_pages (device_log, #SIZE (device_log^), osc$wait, status);

      p_login_table^.body [login_index].recovery_status := dmc$lt_being_rec_alloc_complete;
      mmp$write_modified_pages (p_login_table, #SIZE (p_login_table^), osc$wait, status);
      IF NOT status.normal THEN
        IF osp$file_access_condition (status) THEN
          status.normal := TRUE;
        ELSE
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    dmp$close_file (p_login_table, status);
    recovery_logging := TRUE;
    production_logging := FALSE;

    IF recovery_dat_update_required THEN
      p_dat_changes := NIL;
      p_dfl_changes := NIL;
      number_dat_changes := 0;
      number_dfl_changes := 0;
      process_device_log (avt_index, old_mainframe_assigned, p_dat, p_dflt, login_table_sfid, device_log,
            production_logging, p_dat_changes, number_dat_changes, p_dfl_changes, number_dfl_changes,
            recovery_testing_aborts, old_log_position, status);
      IF NOT status.normal THEN
        osp$fatal_system_error ('recovery dat update died', ^status);
      IFEND;
      log_entry.kind := dmc$dl_update_disk_tables;
      insert_dl_entry (login_table_sfid, login_index, log_entry, device_log, old_log_position, status);
      process_dat_changes (p_dat, avt_index, number_dat_changes, recovery_logging, p_dat_changes, status);
      process_dfl_changes (p_dflt, avt_index, number_dfl_changes, recovery_logging, p_dfl_changes, status);
    IFEND;

    IF recovery_testing_aborts = dmc$dl_halt_before_logging_dtu THEN
      osp$fatal_system_error ('HALT FOR RECOVERY TEST', NIL);
    IFEND;

    log_entry.kind := dmc$dl_disk_tables_updated;
    insert_dl_entry (login_table_sfid, login_index, log_entry, device_log, old_log_position, status);

    empty_device_log (login_table_sfid, device_log, old_mainframe_assigned, p_dat, p_dflt, avt_index, FALSE,
          production_logging, old_log_position, status);

    dmp$close_file (device_log, status);

    dmp$close_file (p_dat, status);

    dmp$close_file (p_dflt, status);

    osp$clear_mainframe_sig_lock (dmv$p_active_volume_table^ [avt_index].mass_storage.update_lock);

  PROCEND dmp$evacuate_old_device_log;
?? TITLE := '  dmp$inhibit_update', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$inhibit_update (avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      able_to_lock_avt_entry: boolean,
      able_to_unlock_avt_entry: boolean;

    status.normal := TRUE;

    IF NOT dmv$test_recovery THEN
      RETURN;
    IFEND;

    REPEAT
      dmp$lock_avt_entry (avt_index, able_to_lock_avt_entry);
      IF NOT able_to_lock_avt_entry THEN
        pmp$delay (500 {milliseconds} , status);
      IFEND;
    UNTIL able_to_lock_avt_entry;

    IF (NOT dmv$p_active_volume_table^ [avt_index].entry_available) THEN
      dmv$p_active_volume_table^ [avt_index].mass_storage.disk_table_status := dmv$p_active_volume_table^
            [avt_index].mass_storage.disk_table_status + $dmt$ms_volume_table_status
            [dmc$table_update_inhibited];
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
        'bad volume selected - DMMLOG', status);
    IFEND;

    dmp$unlock_avt_entry (avt_index, able_to_unlock_avt_entry);
    IF NOT able_to_unlock_avt_entry THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_clear_avt_lock,
        'unable to clear avt lock - DMMLOG', status);
    IFEND;

  PROCEND dmp$inhibit_update;
?? TITLE := '  dmp$initialize_device_log', EJECT ??

  PROCEDURE [XDCL] dmp$initialize_device_log (device_log_sfid: dmt$system_file_id;
        avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      p_fde: ^gft$file_descriptor_entry,
      log_entry: dmt$dl_entry,
      device_log: dmt$device_log,
      aux_status: ost$status;

    status.normal := TRUE;

    dmv$p_active_volume_table^ [avt_index].mass_storage.current_position_offset_in_log := 0;
    dmv$p_active_volume_table^ [avt_index].mass_storage.allocated_log_size := 0;
    dmv$p_active_volume_table^ [avt_index].mass_storage.device_log_entry_count :=0;
    dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log := device_log_sfid;
    dmp$set_eoi (device_log_sfid, 0, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    gfp$get_locked_fde_p (device_log_sfid, p_fde);
    p_fde^.flags.wire_eoi_page := TRUE;
    gfp$unlock_fde_p (p_fde);

    open_device_log (device_log_sfid, FALSE, device_log, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    log_entry.kind := dmc$dl_last_update_entry;
    lock_log_and_insert_entry (log_entry, avt_index, device_log, status);

    log_entry.kind := dmc$dl_disk_tables_updated;
    lock_log_and_insert_entry (log_entry, avt_index, device_log, status);

    dmp$close_file (device_log, aux_status);
    IF status.normal AND NOT aux_status.normal THEN
      status := aux_status;
    IFEND;

  PROCEND dmp$initialize_device_log;
?? TITLE := '  dmp$process_device_log_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$process_device_log_entry (avt_index: dmt$active_volume_table_index,
        device_log_entry: dmt$dl_entry;
    VAR status: ost$status);

    VAR
      device_log: dmt$device_log,
      aux_status: ost$status,
      avt_entry_found: boolean,
      dfl_index: dmt$device_file_list_index,
      gfn: dmt$global_file_name,
      info: dmt$avt_logging_info;

    status.normal := TRUE;

      dmp$get_avt_logging_info (avt_index, info, avt_entry_found);
      IF NOT avt_entry_found THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
          'unable to locate avt entry - dmp$process_device_log_entry', status);
        RETURN;
      IFEND;

      IF info.device_log_sfid = dmv$null_sfid THEN
        IF (device_log_entry.kind = dmc$dl_purge_file) THEN
          gfn := device_log_entry.purge_file_block.global_file_name;
          dfl_index := device_log_entry.purge_file_block.dfl_index;
          dmp$dat_purge_file (gfn, dfl_index, avt_index, status);
        IFEND;
        RETURN;
      IFEND;

      open_device_log (info.device_log_sfid, TRUE, device_log, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT dmv$idle_system THEN
        preallocate_device_log (device_log, info.device_log_sfid, avt_index, status);
        IF NOT status.normal THEN
          IF osp$file_access_condition (status) THEN
            status.normal := TRUE;
          ELSE
            {   problem is likely transitory -- continue
          IFEND;
        IFEND;
      IFEND;

      lock_log_and_insert_entry (device_log_entry, avt_index, device_log, status);

      dmp$close_file (device_log, aux_status);
      IF (NOT aux_status.normal) AND status.normal THEN
        status := aux_status;
      IFEND;

  PROCEND dmp$process_device_log_entry;
 ?? TITLE := '  dmp$process_manual_flaw', EJECT ??
   PROCEDURE [XDCL, #GATE] dmp$process_manual_flaw (recorded_vsn: rmt$recorded_vsn;
         dau_address: dmt$dau_address;
         end_dau_address: dmt$dau_address;
         flaw_operation_code: dmt$flaw_operation_code;
     VAR status: ost$status);

     VAR
       avt_index: dmt$active_volume_table_index,
       dl_entry: dmt$dl_entry,
       entry_not_found: boolean,
       index: dmt$dau_address,
       search_avt_key: dmt$avt_search_key;

     dl_entry.kind := dmc$dl_software_flawed;

     IF (flaw_operation_code = dmc$oc_flaw_define) THEN
       dl_entry.software_flaw_block.flaw_option := dmc$add_flaw;
     ELSE
       dl_entry.software_flaw_block.flaw_option := dmc$remove_flaw;
     IFEND;

     search_avt_key.value := dmc$search_avt_by_rec_vsn;
     search_avt_key.recorded_vsn := recorded_vsn;
     dmp$search_active_volume_table (search_avt_key, avt_index, entry_not_found);
     IF entry_not_found THEN
       osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
         'dmp$process_manual_flaw', status);
       RETURN;
     IFEND;

     IF dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log = dmv$null_sfid THEN
       osp$set_status_abnormal (dmc$device_manager_ident, dme$logging_unavailable,
         'dmp$process_manual_flaw', status);
       RETURN;
     IFEND;

     FOR index := dau_address TO end_dau_address DO
       dl_entry.software_flaw_block.dau_address := index;
       dmp$process_device_log_entry (avt_index, dl_entry, status);
       IF NOT status.normal THEN
         RETURN;
       IFEND;
     FOREND;

     dmp$evacuate_active_device_log (avt_index, status);

   PROCEND dmp$process_manual_flaw;

?? TITLE := '  dmp$set_lower_priority', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$set_lower_priority (task: (split_al_task, administer_log_task,
    volume_space_management_task);
        taskid: ost$global_task_id);

    VAR
      status: ost$status;


    CASE task OF

    = split_al_task =
      tmp$set_task_priority (jmc$priority_split_alloc, 0, status);
      dmv$split_al_initiated := TRUE;

    = administer_log_task =
      tmp$set_task_priority (jmc$priority_administer_log, 0, status);
      dmv$administer_log_initiated := TRUE;

    = volume_space_management_task =
      tmp$set_task_priority (jmc$priority_volume_space_mgr, 0, status);
      dmv$vol_space_manage_initiated := TRUE;

    CASEND;

  PROCEND dmp$set_lower_priority;
?? TITLE := '  dmp$set_update_lock', EJECT ??

  PROCEDURE [XDCL] dmp$set_update_lock
    (    avt_index: dmt$active_volume_table_index;
         wait_for_lock: boolean;
     VAR able_to_set_lock: boolean);


    IF wait_for_lock THEN
      osp$set_mainframe_sig_lock (dmv$p_active_volume_table^ [avt_index].
            mass_storage.update_lock);
      able_to_set_lock := TRUE;
    ELSE
      osp$test_set_main_sig_lock (dmv$p_active_volume_table^ [avt_index].
            mass_storage.update_lock, able_to_set_lock);
    IFEND;

  PROCEND dmp$set_update_lock;
?? TITLE := '  dmp$split_allocation_log', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$split_allocation_log
    (    flush_device_log_pages: boolean;
     VAR status: ost$status);

    VAR
      split_lock: [STATIC] ost$signature_lock,
      info: dmt$avt_logging_info,
      device_log: dmt$device_log,
      device_log_sfid: dmt$system_file_id,
      avt_entry_found: boolean,
      lower_bound: dmt$active_volume_table_index,
      upper_bound: dmt$active_volume_table_index,
      volume_index: dmt$active_volume_table_index,
      p_volume_device_log_open: ^array [ * ] of boolean,
      p_volume_device_log_pva: ^array [ * ] of dmt$device_log,
      entries_in_log,
      last_entries_in_log,
      real_entries_in_log: integer,
      i: dmt$allocation_log_index,
      successful: boolean,
      dl_entry: dmt$dl_entry,
      local_status: ost$status,
      avt_index: dmt$active_volume_table_index;

    osp$begin_system_activity;

    status.normal := TRUE;

    dmv$split_allocation_log_count := (dmv$split_allocation_log_count + 1) MOD UPPERVALUE
          (dmv$split_allocation_log_count);

    device_log := NIL;
    entries_in_log := 0;
    real_entries_in_log := 0;
    last_entries_in_log := 0;

    upper_bound := UPPERBOUND (dmv$p_active_volume_table^);
    lower_bound := LOWERBOUND (dmv$p_active_volume_table^);

    PUSH p_volume_device_log_open: [lower_bound .. upper_bound];
    PUSH p_volume_device_log_pva: [lower_bound .. upper_bound];

    FOR volume_index := lower_bound TO upper_bound DO
      p_volume_device_log_open^ [volume_index] := FALSE;
      p_volume_device_log_pva^ [volume_index] := NIL;
    FOREND;

    osp$set_mainframe_sig_lock (split_lock);

  /split_lock_set/
    BEGIN

      osp$fetch_locked_variable (dmv$allocation_log.number, entries_in_log);

      WHILE entries_in_log <> 0 DO

        FOR i := 1 TO entries_in_log DO
          avt_index := dmv$allocation_log.entries [dmv$allocation_log.first].avt_index;
          IF NOT p_volume_device_log_open^ [avt_index] THEN
            dmp$get_avt_logging_info (avt_index, info, avt_entry_found);
            IF NOT avt_entry_found THEN
              osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
                'unable to locate avt entry - dmp$split_allocation_log', status);
              EXIT /split_lock_set/;
            IFEND;

            device_log_sfid := info.device_log_sfid;

            open_device_log (device_log_sfid, TRUE, device_log, status);
            IF NOT status.normal THEN
              EXIT /split_lock_set/;
            IFEND;

            p_volume_device_log_pva^ [avt_index] := device_log;
            p_volume_device_log_open^ [avt_index] := TRUE;
          ELSE
            device_log := p_volume_device_log_pva^ [avt_index];
          IFEND;

          CASE dmv$allocation_log.entries [dmv$allocation_log.first].kind OF

          = dmc$al_allocate =
            dl_entry.kind := dmc$dl_allocate;
            dl_entry.allocate_block := dmv$allocation_log.entries [dmv$allocation_log.first].allocate_block;

          = dmc$al_initialize =
            dl_entry.kind := dmc$dl_initialize;
            dl_entry.initialize_block := dmv$allocation_log.entries [dmv$allocation_log.first].
                  initialize_block;

          = dmc$al_return_dau =
            dl_entry.kind := dmc$dl_return_dau;
            dl_entry.return_dau_block := dmv$allocation_log.entries [dmv$allocation_log.first].
                  return_dau_block;

          = dmc$al_software_flawed =
            dl_entry.kind := dmc$dl_software_flawed;
            dl_entry.software_flaw_block := dmv$allocation_log.entries [dmv$allocation_log.first].
                  software_flaw_block;

          = dmc$al_reallocate =
            dl_entry.kind := dmc$dl_reallocate;
            dl_entry.reallocate_block := dmv$allocation_log.entries [dmv$allocation_log.first].
                  reallocate_block;

          = dmc$al_trim_file =
            dl_entry.kind := dmc$dl_trim_file;
            dl_entry.trim_file_block := dmv$allocation_log.entries [dmv$allocation_log.first].
                  trim_file_block;

          ELSE
            osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_device_log_kind,
              'bad entry in allocation_log - DMMLOG', status);
          CASEND;

          osp$fetch_locked_variable (dmv$allocation_log.number, real_entries_in_log);

          REPEAT
            entries_in_log := real_entries_in_log - 1;
            last_entries_in_log := real_entries_in_log;
            osp$set_locked_variable (dmv$allocation_log.number, last_entries_in_log, entries_in_log,
                  real_entries_in_log, successful);
          UNTIL successful;

          dmv$allocation_log.first := (dmv$allocation_log.first + 1) MOD dmc$max_allocation_log_entries;

          lock_log_and_insert_entry (dl_entry, avt_index, device_log, status);
          IF NOT status.normal THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_process_al_entry,
              'unable to process allocation log entry - DMMLOG', status);
            EXIT /split_lock_set/;
          IFEND;

          device_log := NIL;

        FOREND;

      WHILEND;

    END /split_lock_set/;

    osp$clear_mainframe_sig_lock (split_lock);

    FOR volume_index := lower_bound TO upper_bound DO
      IF p_volume_device_log_open^ [volume_index] THEN
        device_log := p_volume_device_log_pva^ [volume_index];
        IF flush_device_log_pages THEN
          mmp$write_modified_pages (device_log, #SIZE(device_log^), osc$wait, status);
          IF NOT status.normal THEN
            IF osp$file_access_condition (status) THEN
              status.normal := TRUE;
            IFEND;
          IFEND;
        IFEND;
        dmp$close_file (device_log, local_status);
        IF local_status.normal THEN
          p_volume_device_log_open^ [volume_index] := FALSE;
        IFEND;
        IF (NOT local_status.normal) AND status.normal THEN
          status := local_status;
        IFEND;
      IFEND;
    FOREND;

    IF flush_device_log_pages THEN
      dmv$flush_dev_log_pages_count := (dmv$flush_dev_log_pages_count + 1) MOD UPPERVALUE
           (dmv$flush_dev_log_pages_count);
    IFEND;

    osp$end_system_activity;

  PROCEND dmp$split_allocation_log;
?? EJECT, TITLE := 'dmp$utility_flush_logs' ??

  PROCEDURE [XDCL, #GATE] dmp$utility_flush_logs;

    VAR
      avt_index: dmt$active_volume_table_index,
      continue: boolean,
      count: 0..100,
      entries: boolean,
      info: dmt$avt_logging_info,
      valid_entry: boolean;

    continue := TRUE;
    count := 1;

    WHILE continue AND (count < 100) DO
      count := count + 1;
      continue := FALSE;

      dmp$dev_mgmt_table_update;

      FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^)
            TO UPPERBOUND (dmv$p_active_volume_table^) DO

        dmp$get_avt_logging_info (avt_index, info, valid_entry);
        IF valid_entry THEN
          entries := (NOT info.volume_unavailable) AND
                     (NOT info.logging_process_damaged) AND
                     (info.log_entry_count > dmv$minimum_log_count);
          IF entries THEN
            continue := TRUE;
          IFEND;
        IFEND;

      FOREND;
    WHILEND;

  PROCEND dmp$utility_flush_logs;
?? TITLE := '  dmp$verify_access', EJECT ??

  PROCEDURE [XDCL] dmp$verify_access
    (    avti: dmt$active_volume_table_index;
     VAR ok: boolean);

    VAR
      pmat: ^dmt$mainframe_allocation_table,
      pa: array [1 .. 3] of dmt$physical_device_attribute,
      label: ^dmt$ms_volume_label;


    ok := TRUE;

    dmp$get_mat_pointer (avti, pmat);
    pa [1].keyword := dmc$bytes_per_mau;
    pa [1].bytes_per_mau := pmat^.bytes_per_mau;
    pa [2].keyword := dmc$maus_per_cylinder;
    pa [2].maus_per_cylinder := pmat^.daus_per_position * pmat^.maus_per_dau;
    pa [3].keyword := dmc$maus_per_dau;
    pa [3].maus_per_dau := pmat^.maus_per_dau;

    PUSH label: [[REP dmc$max_volume_label_size OF cell]];

    dmp$locate_volume_label (dmv$p_active_volume_table^ [avti].
          logical_unit_number, ^pa, label^, ok);
    IF ok THEN
      IF dmv$p_active_volume_table^ [avti].mass_storage.volume_unavailable THEN
        ok := FALSE;
      IFEND;
    IFEND;
  PROCEND dmp$verify_access;
?? TITLE := '  change_mat', EJECT ??

  PROCEDURE change_mat (avt_index: dmt$active_volume_table_index;
        mat_change_count: dmt$mat_change_count;
        p_mat_changes: ^dmt$mat_changes;
        available_dat_space: dmt$dau_address);

    VAR
      mat_change_request: dmt$mat_change_request;

    mat_change_request.request_code := syc$rc_apply_mat_changes;
    mat_change_request.avt_index := avt_index;
    mat_change_request.mat_change_type := dmc$add_mat_space;
    mat_change_request.mat_change_count := mat_change_count;
    mat_change_request.p_mat_changes := p_mat_changes;
    mat_change_request.available_dat_space := available_dat_space;

    i#call_monitor (^mat_change_request, #size (mat_change_request));
  PROCEND change_mat;
?? TITLE := '  check_device_log', EJECT ??

  PROCEDURE check_device_log (p_login_table: ^dmt$ms_mainframe_login_table;
        login_index: dmt$login_table_entry_index;
        p_device_log: dmt$device_log;
    VAR no_more_stuff_in_log: boolean);

    VAR
      device_log: dmt$device_log,
      p_entry_kind: ^dmt$dl_entry_kind,
      p_check_byte: ^0 .. 0ff(16);

    no_more_stuff_in_log := FALSE;
    device_log := p_device_log;
    p_entry_kind := #address (#ring (device_log), #segment (device_log), p_login_table^.body [login_index].
          last_update_offset);

    RESET device_log TO p_entry_kind;

    NEXT p_entry_kind IN device_log;

    NEXT p_check_byte IN device_log;

    NEXT p_entry_kind IN device_log;
    IF p_entry_kind^ <> dmc$dl_update_disk_tables THEN
      RETURN;
    IFEND;

    NEXT p_check_byte IN device_log;

    NEXT p_entry_kind IN device_log;
    IF p_entry_kind^ <> dmc$dl_disk_tables_updated THEN
      RETURN;
    IFEND;

    no_more_stuff_in_log := TRUE;

  PROCEND check_device_log;
?? TITLE := '  do_dat_assign_dau', EJECT ??

  PROCEDURE do_dat_assign_dau (p_dat: ^dmt$ms_device_allocation_table;
        dat_change: dmt$dat_change;
        avt_index: dmt$active_volume_table_index;
        recovery_logging: boolean);

    VAR
      file_hash: dmt$file_hash,
      ok: boolean,
      flawed: boolean,
      first_dau: dmt$dau_address,
      last_dau: dmt$dau_address,
      dfl_index: dmt$device_file_list_index,
      mainframe: dmt$mainframe_assigned,
      dau_entry: dmt$ms_device_allocation_unit,
      dau: dmt$dau_address;

    dmp$generate_gfn_hash (dat_change.assign_dau_block.global_file_name, file_hash);
    first_dau := dat_change.dau_address;
    last_dau := first_dau + dat_change.assign_dau_block.daus_per_allocation - 1;
    dfl_index := dat_change.assign_dau_block.dfl_index;
    mainframe := dat_change.assign_dau_block.mainframe_assigned;

    { Validate DAT change.

    ok := (last_dau < p_dat^.header.number_of_entries);

    IF NOT ok THEN
      process_dat_change_error (avt_index, dat_change, 0, p_dat^.body [0], recovery_logging);
      RETURN;
    IFEND;

    FOR dau := first_dau TO last_dau DO
      dau_entry := p_dat^.body [dau];

      ok := valid_mainframe_dau (mainframe, dau_entry) OR recovery_logging AND
            valid_file_dau (dfl_index, file_hash, dau_entry);

      IF NOT ok THEN
        process_dat_change_error (avt_index, dat_change, dau, dau_entry, recovery_logging);
        RETURN;
      IFEND;
    FOREND;

    { Process DAT change.

    FOR dau := first_dau TO last_dau DO
      flawed := (p_dat^.body [dau].dau_status = dmc$dau_ass_to_file_swr_flawed) OR
            (p_dat^.body [dau].dau_status = dmc$dau_ass_to_mf_swr_flawed);

      IF flawed THEN
        p_dat^.body [dau].dau_status := dmc$dau_ass_to_file_swr_flawed;
      ELSE
        p_dat^.body [dau].dau_status := dmc$dau_assigned_to_file;
      IFEND;

      p_dat^.body [dau].file_hash := file_hash;
      p_dat^.body [dau].data_status := dmc$dau_data_not_initialized;

      IF (dau = first_dau) THEN
        IF dat_change.assign_dau_block.first_flag THEN
          p_dat^.body [dau].allocation_chain_position := dmc$first_and_last_allocation;
        ELSE
          p_dat^.body [dau].allocation_chain_position := dmc$last_allocation;
        IFEND;
        p_dat^.body [dau].high_dfl_index := dfl_index DIV dmc$dfl_index_converter;
        p_dat^.body [dau].low_dfl_index := dfl_index MOD dmc$dfl_index_converter
      ELSE
        p_dat^.body [dau].allocation_chain_position := dmc$part_of_allocation_unit;
      IFEND;
    FOREND;
  PROCEND do_dat_assign_dau;
?? TITLE := '  do_dat_reallocate_dau', EJECT ??

  PROCEDURE do_dat_reallocate_dau (p_dat: ^dmt$ms_device_allocation_table;
        dat_change: dmt$dat_change;
        avt_index: dmt$active_volume_table_index;
        recovery_logging: boolean);

    VAR
      file_hash: dmt$file_hash,
      ok: boolean,
      flawed: boolean,
      first_dau: dmt$dau_address,
      last_dau: dmt$dau_address,
      dfl_index: dmt$device_file_list_index,
      mainframe: dmt$mainframe_assigned,
      dau_entry: dmt$ms_device_allocation_unit,
      dau: dmt$dau_address;

    dmp$generate_gfn_hash (dat_change.reallocate_dau_block.global_file_name, file_hash);
    first_dau := dat_change.dau_address;
    last_dau := first_dau + dat_change.reallocate_dau_block.daus_per_allocation - 1;
    dfl_index := dat_change.reallocate_dau_block.dfl_index;
    mainframe := dat_change.reallocate_dau_block.mainframe_assigned;

    { Validate DAT change.

    ok := (last_dau < p_dat^.header.number_of_entries);

    IF NOT ok THEN
      process_dat_change_error (avt_index, dat_change, 0, p_dat^.body [0], recovery_logging);
      RETURN;
    IFEND;

    FOR dau := first_dau TO last_dau DO
      dau_entry := p_dat^.body [dau];

      ok := valid_mainframe_dau (mainframe, dau_entry) OR recovery_logging AND
            valid_file_dau (dfl_index, file_hash, dau_entry);

      IF NOT ok THEN
        process_dat_change_error (avt_index, dat_change, dau, dau_entry, recovery_logging);
        RETURN;
      IFEND;
    FOREND;

    IF (dat_change.reallocate_dau_block.allocation_chain_position <> dmc$first_allocation) AND
       (dat_change.reallocate_dau_block.allocation_chain_position <>
          dmc$first_and_last_allocation) THEN
      dau_entry := p_dat^.body [dat_change.reallocate_dau_block.previous_dau_address];
      ok := valid_mainframe_dau (mainframe, dau_entry) OR
            valid_file_dau (dfl_index, file_hash, dau_entry);
      IF NOT ok THEN
        process_dat_change_error (avt_index, dat_change, dau, dau_entry, recovery_logging);
        RETURN;
      IFEND;
    IFEND;

    IF (dat_change.reallocate_dau_block.allocation_chain_position = dmc$first_allocation) OR
       (dat_change.reallocate_dau_block.allocation_chain_position = dmc$middle_allocation) THEN
      dau_entry := p_dat^.body [dat_change.reallocate_dau_block.next_dau_address];
      ok := valid_mainframe_dau (mainframe, dau_entry) OR
            valid_file_dau (dfl_index, file_hash, dau_entry);
      IF NOT ok THEN
        process_dat_change_error (avt_index, dat_change, dau, dau_entry, recovery_logging);
        RETURN;
      IFEND;
    IFEND;

    { Process DAT change.

    FOR dau := first_dau TO last_dau DO
      flawed := (p_dat^.body [dau].dau_status = dmc$dau_ass_to_file_swr_flawed) OR
            (p_dat^.body [dau].dau_status = dmc$dau_ass_to_mf_swr_flawed);

      IF flawed THEN
        p_dat^.body [dau].dau_status := dmc$dau_ass_to_file_swr_flawed;
      ELSE
        p_dat^.body [dau].dau_status := dmc$dau_assigned_to_file;
      IFEND;

      p_dat^.body [dau].file_hash := file_hash;
      p_dat^.body [dau].data_status := dmc$dau_data_not_initialized;

      IF (dau = first_dau) THEN
        p_dat^.body [dau].allocation_chain_position :=
          dat_change.reallocate_dau_block.allocation_chain_position;

        CASE p_dat^.body [dau].allocation_chain_position OF
        = dmc$first_and_last_allocation, dmc$last_allocation =
          p_dat^.body [dau].high_dfl_index := dfl_index DIV dmc$dfl_index_converter;
          p_dat^.body [dau].low_dfl_index := dfl_index MOD dmc$dfl_index_converter;
        = dmc$first_allocation, dmc$middle_allocation =
          p_dat^.body [dau].next_allocation_unit_dau :=
            dat_change.reallocate_dau_block.next_dau_address;
        ELSE
        CASEND;
      ELSE
        p_dat^.body [dau].allocation_chain_position := dmc$part_of_allocation_unit;
      IFEND;
    FOREND;
  PROCEND do_dat_reallocate_dau;
?? TITLE := '  do_dat_delink_dau', EJECT ??

  PROCEDURE do_dat_delink_dau (p_dat: ^dmt$ms_device_allocation_table;
        dat_change: dmt$dat_change;
        avt_index: dmt$active_volume_table_index;
        recovery_logging: boolean);

    VAR
      file_hash: dmt$file_hash,
      dau_entry: dmt$ms_device_allocation_unit,
      dau: dmt$dau_address,
      position: dmt$allocation_chain_position,
      ok: boolean;

    dmp$generate_gfn_hash (dat_change.delink_dau_block.global_file_name, file_hash);

    dau := dat_change.dau_address;
    dau_entry := p_dat^.body [dau];

    { Validate DAT change.

    ok := valid_file_dau (dat_change.delink_dau_block.dfl_index, file_hash, dau_entry);

    IF ok THEN
      position := dau_entry.allocation_chain_position;
      ok := NOT (position = dmc$part_of_allocation_unit);
    IFEND;

    IF NOT ok THEN
      process_dat_change_error (avt_index, dat_change, dau, dau_entry, recovery_logging);
      RETURN;
    IFEND;

    { Process DAT change.

    CASE position OF
    = dmc$first_and_last_allocation, dmc$last_allocation =
      { hash and dfl are ok, as checked by valid_file_dau
      { is likely a repeat during 'recovery'

    = dmc$first_allocation =
      p_dat^.body [dau].allocation_chain_position := dmc$first_and_last_allocation;
      p_dat^.body [dau].high_dfl_index := dat_change.delink_dau_block.dfl_index DIV dmc$dfl_index_converter;
      p_dat^.body [dau].low_dfl_index := dat_change.delink_dau_block.dfl_index MOD dmc$dfl_index_converter;

    = dmc$middle_allocation =
      p_dat^.body [dau].allocation_chain_position := dmc$last_allocation;
      p_dat^.body [dau].high_dfl_index := dat_change.delink_dau_block.dfl_index DIV dmc$dfl_index_converter;
      p_dat^.body [dau].low_dfl_index := dat_change.delink_dau_block.dfl_index MOD dmc$dfl_index_converter;

    = dmc$part_of_allocation_unit =
      { Should NEVER happen - called process_dat_change_error above.
    ELSE
    CASEND;
  PROCEND do_dat_delink_dau;
?? TITLE := '  do_dat_initialize', EJECT ??

  PROCEDURE do_dat_initialize (p_dat: ^dmt$ms_device_allocation_table;
        dat_change: dmt$dat_change;
        avt_index: dmt$active_volume_table_index;
        recovery_logging: boolean);

    VAR
      ok: boolean,
      file_hash: dmt$file_hash,
      dau: dmt$dau_address,
      dau_entry: dmt$ms_device_allocation_unit;

    dmp$generate_gfn_hash (dat_change.initialize_block.global_file_name, file_hash);
    dau := dat_change.dau_address;
    dau_entry := p_dat^.body [dau];

    { Validate DAT change.

    ok := valid_file_dau (dat_change.initialize_block.dfl_index, file_hash, dau_entry) AND
          (dau_entry.allocation_chain_position <> dmc$part_of_allocation_unit);

    IF NOT ok THEN
      process_dat_change_error (avt_index, dat_change, dau, dau_entry, recovery_logging);
      RETURN;
    IFEND;

    { Process DAT change.

    p_dat^.body [dau].data_status := dmc$dau_data_initialized;
  PROCEND do_dat_initialize;
?? TITLE := '  do_dat_recycle_dau', EJECT ??

  PROCEDURE do_dat_recycle_dau (p_dat: ^dmt$ms_device_allocation_table;
        dat_change: dmt$dat_change;
        avt_index: dmt$active_volume_table_index;
        recovery_logging: boolean;
        p_mat_changes: ^dmt$mat_changes;
    VAR mat_change_count: dmt$mat_change_count {input/output});

    VAR
      ok: boolean,
      first_dau: dmt$dau_address,
      last_dau: dmt$dau_address,
      dau: dmt$dau_address,
      mainframe: dmt$mainframe_assigned,
      allocation_style: dmt$allocation_styles,
      daus_per_allocation: dmt$daus_per_allocation;

    IF recovery_logging THEN
      do_dat_return_dau (p_dat, dat_change, avt_index, recovery_logging);
      RETURN;
    IFEND;

    daus_per_allocation := dat_change.return_dau_block.daus_per_allocation;
    first_dau := dat_change.dau_address;
    last_dau := first_dau + daus_per_allocation - 1;
    mainframe := dat_change.return_dau_block.mainframe_assigned;

    { Validate DAT change.

    ok := (last_dau < p_dat^.header.number_of_entries);

    IF NOT ok THEN
      process_dat_change_error (avt_index, dat_change, 0, p_dat^.body [0], recovery_logging);
      RETURN;
    IFEND;

    FOR dau := first_dau TO last_dau DO
      ok := valid_mainframe_dau (mainframe, p_dat^.body [dau]);

      IF NOT ok THEN
        process_dat_change_error (avt_index, dat_change, dau, p_dat^.body [dau], recovery_logging);
        RETURN;
      IFEND;

      IF (p_dat^.body [dau].dau_status = dmc$dau_ass_to_mf_swr_flawed) THEN
        daus_per_allocation := 1;
      IFEND;
    FOREND;

    { Process DAT change.

    dau := first_dau;
    allocation_style := LOWERVALUE (allocation_style);

    WHILE (daus_per_allocation <> p_dat^.header.daus_per_allocation_style [allocation_style]) DO
      IF (allocation_style < UPPERVALUE (allocation_style)) THEN
        allocation_style := succ (allocation_style);
      ELSE
        process_dat_change_error (avt_index, dat_change, dau, p_dat^.body [dau], recovery_logging);
        RETURN;
      IFEND;
    WHILEND;

    REPEAT
      IF (p_dat^.body [dau].dau_status = dmc$dau_ass_to_mf_swr_flawed) THEN
        p_dat^.body [dau].dau_status := dmc$dau_software_flawed;
      ELSE
        mat_change_count := mat_change_count + 1;
        p_mat_changes^ [mat_change_count].style := allocation_style;
        p_mat_changes^ [mat_change_count].dau_address := dau;

        IF (mat_change_count = UPPERBOUND (p_mat_changes^)) THEN
          change_mat (avt_index, mat_change_count, p_mat_changes, p_dat^.header.available);
          mat_change_count := 0;
        IFEND;
      IFEND;
      dau := dau + daus_per_allocation;
    UNTIL (dau > last_dau);
  PROCEND do_dat_recycle_dau;
?? TITLE := '  do_dat_release_dau', EJECT ??

  PROCEDURE do_dat_release_dau (p_dat: ^dmt$ms_device_allocation_table;
        dat_change: dmt$dat_change;
        avt_index: dmt$active_volume_table_index;
        recovery_logging: boolean);

    VAR
      ok: boolean,
      file_hash: dmt$file_hash,
      first_dau: dmt$dau_address,
      last_dau: dmt$dau_address,
      dfl_index: dmt$device_file_list_index,
      mainframe: dmt$mainframe_assigned,
      dau_entry: dmt$ms_device_allocation_unit,
      dau: dmt$dau_address;

    dmp$generate_gfn_hash (dat_change.release_dau_block.global_file_name, file_hash);
    first_dau := dat_change.dau_address;
    last_dau := first_dau + dat_change.release_dau_block.daus_per_allocation - 1;
    dfl_index := dat_change.release_dau_block.dfl_index;
    mainframe := dat_change.release_dau_block.mainframe_assigned;

    { Validate DAT change.

    ok := (last_dau < p_dat^.header.number_of_entries);

    IF NOT ok THEN
      process_dat_change_error (avt_index, dat_change, 0, p_dat^.body [0], recovery_logging);
      RETURN;
    IFEND;

    FOR dau := first_dau TO last_dau DO
      dau_entry := p_dat^.body [dau];
      ok := valid_file_dau (dfl_index, file_hash, dau_entry) OR recovery_logging AND
            valid_mainframe_dau (mainframe, dau_entry);
      IF NOT ok THEN
        process_dat_change_error (avt_index, dat_change, dau, dau_entry, recovery_logging);
        RETURN;
      IFEND;
    FOREND;

    { Process DAT change.

    FOR dau := first_dau TO last_dau DO
      CASE p_dat^.body [dau].dau_status OF
      = dmc$dau_ass_to_file_swr_flawed =
        p_dat^.body [dau].dau_status := dmc$dau_ass_to_mf_swr_flawed;
        p_dat^.body [dau].mainframe_id := mainframe;
      = dmc$dau_assigned_to_file =
        p_dat^.body [dau].dau_status := dmc$dau_assigned_to_mainframe;
        p_dat^.body [dau].mainframe_id := mainframe;
      ELSE
      CASEND;
    FOREND;
  PROCEND do_dat_release_dau;
?? TITLE := '  do_dat_return_dau', EJECT ??

  PROCEDURE do_dat_return_dau (p_dat: ^dmt$ms_device_allocation_table;
        dat_change: dmt$dat_change;
        avt_index: dmt$active_volume_table_index;
        recovery_logging: boolean);

    VAR
      ok: boolean,
      first_dau: dmt$dau_address,
      last_dau: dmt$dau_address,
      mainframe: dmt$mainframe_assigned,
      daus_returned: dmt$dau_address,
      dau: dmt$dau_address;

    first_dau := dat_change.dau_address;
    last_dau := first_dau + dat_change.return_dau_block.daus_per_allocation - 1;
    mainframe := dat_change.return_dau_block.mainframe_assigned;

    { Validate DAT change.

    ok := (last_dau < p_dat^.header.number_of_entries);

    IF NOT ok THEN
      process_dat_change_error (avt_index, dat_change, 0, p_dat^.body [0], recovery_logging);
      RETURN;
    IFEND;

    FOR dau := first_dau TO last_dau DO
      ok := valid_mainframe_dau (mainframe, p_dat^.body [dau]) OR recovery_logging;

      IF NOT ok THEN
        process_dat_change_error (avt_index, dat_change, dau, p_dat^.body [dau], recovery_logging);
        RETURN;
      IFEND;
    FOREND;

    { Process DAT change.

    daus_returned := 0;
    FOR dau := first_dau TO last_dau DO
      IF valid_mainframe_dau (mainframe, p_dat^.body [dau]) THEN
        CASE p_dat^.body [dau].dau_status OF
        = dmc$dau_ass_to_mf_swr_flawed =
          p_dat^.body [dau].dau_status := dmc$dau_software_flawed;
        = dmc$dau_assigned_to_mainframe =
          p_dat^.body [dau].dau_status := dmc$dau_usable;
          daus_returned := daus_returned + 1;
        ELSE
          ;
        CASEND;
      IFEND;
    FOREND;

    p_dat^.header.available := p_dat^.header.available + daus_returned;
  PROCEND do_dat_return_dau;
?? TITLE := '  do_dat_software_flawed', EJECT ??

  PROCEDURE do_dat_software_flawed (p_dat: ^dmt$ms_device_allocation_table;
        dat_change: dmt$dat_change);

    VAR
      dau: dmt$dau_address;

    dau := dat_change.dau_address;

    IF (dat_change.software_flaw_block.flaw_option = dmc$add_flaw) THEN
      CASE p_dat^.body [dau].dau_status OF

      = dmc$dau_usable =
        p_dat^.body [dau].dau_status := dmc$dau_software_flawed;
        p_dat^.header.available := p_dat^.header.available - 1;

      = dmc$dau_assigned_to_mainframe =
        p_dat^.body [dau].dau_status := dmc$dau_ass_to_mf_swr_flawed;

      = dmc$dau_assigned_to_file =
        p_dat^.body [dau].dau_status := dmc$dau_ass_to_file_swr_flawed;

      ELSE
        ;
      CASEND;
    ELSE {remove flaw}
      CASE p_dat^.body [dau].dau_status OF

      = dmc$dau_software_flawed =
        p_dat^.body [dau].dau_status := dmc$dau_usable;
        p_dat^.header.available := p_dat^.header.available + 1;

      = dmc$dau_ass_to_mf_swr_flawed =
        p_dat^.body [dau].dau_status := dmc$dau_assigned_to_mainframe;

      = dmc$dau_ass_to_file_swr_flawed =
        p_dat^.body [dau].dau_status := dmc$dau_assigned_to_file;

      ELSE
        ;
      CASEND;
    IFEND;
  PROCEND do_dat_software_flawed;
?? TITLE := '  do_dat_update_dau', EJECT ??

  PROCEDURE do_dat_update_dau (p_dat: ^dmt$ms_device_allocation_table;
        dat_change: dmt$dat_change;
        avt_index: dmt$active_volume_table_index;
        recovery_logging: boolean);

    VAR
      file_hash: dmt$file_hash,
      dau_entry: dmt$ms_device_allocation_unit,
      dau: dmt$dau_address,
      next_dau: dmt$dau_address,
      position: dmt$allocation_chain_position,
      ok: boolean;

    dmp$generate_gfn_hash (dat_change.update_dau_block.global_file_name, file_hash);

    dau := dat_change.dau_address;
    next_dau := dat_change.update_dau_block.next_dau_address;
    dau_entry := p_dat^.body [dau];

    { Validate DAT change.

    ok := (next_dau < p_dat^.header.number_of_entries) AND
          valid_file_dau (dat_change.update_dau_block.dfl_index, file_hash, dau_entry);

    IF ok THEN
      position := dau_entry.allocation_chain_position;
      ok := NOT (position = dmc$part_of_allocation_unit);
    IFEND;

    IF NOT ok THEN
      process_dat_change_error (avt_index, dat_change, dau, dau_entry, recovery_logging);
      RETURN;
    IFEND;

    { Process DAT change.

    IF (position = dmc$first_and_last_allocation) THEN
      p_dat^.body [dau].allocation_chain_position := dmc$first_allocation;
    ELSEIF (position = dmc$last_allocation) THEN
      p_dat^.body [dau].allocation_chain_position := dmc$middle_allocation;
    IFEND;
    p_dat^.body [dau].next_allocation_unit_dau := next_dau;
  PROCEND do_dat_update_dau;
?? TITLE := '  do_dfl_attach_file', EJECT ??

  PROCEDURE do_dfl_attach_file (p_dfl: ^dmt$ms_device_file_list_table;
        dfl_change: dmt$dfl_change;
        avt_index: dmt$active_volume_table_index;
        recovery_logging: boolean);

    VAR
      ok: boolean,
      dfl_entry: dmt$ms_device_file_list_entry;

    dfl_entry := p_dfl^.entries [dfl_change.dfl_index];

    { Validate DFL change.

    ok := valid_file_dfl (dfl_change.attach_file_block.global_file_name, dfl_entry);

    IF NOT ok THEN
      process_dfl_change_error (avt_index, dfl_change, dfl_entry, recovery_logging);
      RETURN;
    IFEND;

    { Process DFL change.

    p_dfl^.entries [dfl_change.dfl_index].login_set := p_dfl^.entries [dfl_change.dfl_index].login_set +
          $dmt$dfl_login_set [dfl_change.attach_file_block.mainframe_assigned.log_in_index];
  PROCEND do_dfl_attach_file;
?? TITLE := '  do_dfl_create', EJECT ??

  PROCEDURE do_dfl_create (p_dfl: ^dmt$ms_device_file_list_table;
        dfl_change: dmt$dfl_change;
        avt_index: dmt$active_volume_table_index;
        recovery_logging: boolean);

    VAR
      ok: boolean,
      gfn: dmt$global_file_name,
      mainframe: dmt$mainframe_assigned,
      file_hash: dmt$file_hash,
      dfl_entry: dmt$ms_device_file_list_entry;

    dfl_entry := p_dfl^.entries [dfl_change.dfl_index];
    gfn := dfl_change.create_block.global_file_name;
    mainframe := dfl_change.create_block.mainframe_assigned;

    { Validate DFL change.

    ok := valid_mainframe_dfl (mainframe, dfl_entry) OR recovery_logging AND
          valid_file_dfl (gfn, dfl_entry);

    IF NOT ok THEN
      process_dfl_change_error (avt_index, dfl_change, dfl_entry, recovery_logging);
      RETURN;
    IFEND;

    { Process DFL change.

    dmp$generate_gfn_hash (gfn, file_hash);
    p_dfl^.entries [dfl_change.dfl_index].flags := dmc$dfle_assigned_to_file;
    p_dfl^.entries [dfl_change.dfl_index].global_file_name := gfn;
    p_dfl^.entries [dfl_change.dfl_index].daus_per_allocation_unit := dfl_change.create_block.
          daus_per_allocation;
    p_dfl^.entries [dfl_change.dfl_index].file_kind := dfl_change.create_block.file_kind;
    p_dfl^.entries [dfl_change.dfl_index].file_hash := file_hash;
    p_dfl^.entries [dfl_change.dfl_index].file_byte_address := dfl_change.create_block.
          fmd_byte_address;
    p_dfl^.entries [dfl_change.dfl_index].end_of_information := 0;
    p_dfl^.entries [dfl_change.dfl_index].end_of_file := 0;
    p_dfl^.entries [dfl_change.dfl_index].fmd_length := 0;
    p_dfl^.entries [dfl_change.dfl_index].logical_length := 0;
    p_dfl^.entries [dfl_change.dfl_index].dau_chain_status := dmc$dau_chain_not_linked;
    p_dfl^.entries [dfl_change.dfl_index].first_dau_address := 0;
    p_dfl^.entries [dfl_change.dfl_index].login_set := $dmt$dfl_login_set [mainframe.log_in_index];
    p_dfl^.entries [dfl_change.dfl_index].damage := $dmt$file_damage [];
  PROCEND do_dfl_create;
?? TITLE := '  do_dfl_detach_file', EJECT ??

  PROCEDURE do_dfl_detach_file (p_dfl: ^dmt$ms_device_file_list_table;
        dfl_change: dmt$dfl_change;
        avt_index: dmt$active_volume_table_index;
        recovery_logging: boolean);

    VAR
      ok: boolean,
      dfl_entry: dmt$ms_device_file_list_entry;

    dfl_entry := p_dfl^.entries [dfl_change.dfl_index];

    { Validate DFL change.

    ok := valid_file_dfl (dfl_change.attach_file_block.global_file_name, dfl_entry);

    IF NOT ok THEN
      process_dfl_change_error (avt_index, dfl_change, dfl_entry, recovery_logging);
      RETURN;
    IFEND;

    { Process DFL change.

    p_dfl^.entries [dfl_change.dfl_index].login_set := p_dfl^.entries [dfl_change.dfl_index].login_set -
          $dmt$dfl_login_set [dfl_change.attach_file_block.mainframe_assigned.log_in_index];
  PROCEND do_dfl_detach_file;
?? TITLE := '  do_dfl_file_damaged', EJECT ??

  PROCEDURE do_dfl_file_damaged (p_dfl: ^dmt$ms_device_file_list_table;
        dfl_change: dmt$dfl_change;
        avt_index: dmt$active_volume_table_index;
        recovery_logging: boolean);

    VAR
      ok: boolean,
      dfl_entry: dmt$ms_device_file_list_entry;

    dfl_entry := p_dfl^.entries [dfl_change.dfl_index];

    { Validate DFL change.

    ok := valid_file_dfl (dfl_change.file_damaged_block.global_file_name, dfl_entry);

    IF NOT ok THEN
      process_dfl_change_error (avt_index, dfl_change, dfl_entry, recovery_logging);
      RETURN;
    IFEND;

    { Process DFL change.

      p_dfl^.entries [dfl_change.dfl_index].damage := p_dfl^.entries [dfl_change.dfl_index].damage
            - dfl_change.file_damaged_block.remove_damage  + dfl_change.file_damaged_block.add_damage;

  PROCEND do_dfl_file_damaged;
?? TITLE := '  do_dfl_first_dau', EJECT ??

  PROCEDURE do_dfl_first_dau (p_dfl: ^dmt$ms_device_file_list_table;
        dfl_change: dmt$dfl_change;
        avt_index: dmt$active_volume_table_index;
        recovery_logging: boolean);

    VAR
      ok: boolean,
      dfl_entry: dmt$ms_device_file_list_entry;

    dfl_entry := p_dfl^.entries [dfl_change.dfl_index];

    { Validate DFL change.

    ok := valid_file_dfl (dfl_change.first_dau_block.global_file_name, dfl_entry);

    IF NOT ok THEN
      process_dfl_change_error (avt_index, dfl_change, dfl_entry, recovery_logging);
      RETURN;
    IFEND;

    { Process DFL change.

    p_dfl^.entries [dfl_change.dfl_index].dau_chain_status := dmc$dau_chain_linked;
    p_dfl^.entries [dfl_change.dfl_index].first_dau_address := dfl_change.first_dau_block.dau_address;
  PROCEND do_dfl_first_dau;
?? TITLE := '  do_dfl_release_dfl', EJECT ??

  PROCEDURE do_dfl_release_dfl (p_dfl: ^dmt$ms_device_file_list_table;
        dfl_change: dmt$dfl_change;
        avt_index: dmt$active_volume_table_index;
        recovery_logging: boolean);

    VAR
      ok: boolean,
      mainframe: dmt$mainframe_assigned,
      dfl_entry: dmt$ms_device_file_list_entry;

    dfl_entry := p_dfl^.entries [dfl_change.dfl_index];
    mainframe := dfl_change.release_dfl_block.mainframe_assigned;

    { Validate DFL change.

    ok := valid_file_dfl (dfl_change.release_dfl_block.global_file_name, dfl_entry) OR
          recovery_logging AND valid_mainframe_dfl (mainframe, dfl_entry);

    IF NOT ok THEN
      process_dfl_change_error (avt_index, dfl_change, dfl_entry, recovery_logging);
      RETURN;
    IFEND;

    { Process DFL change.

    p_dfl^.entries [dfl_change.dfl_index].flags := dmc$dfle_assigned_to_mainframe;
    p_dfl^.entries [dfl_change.dfl_index].mainframe_assigned := mainframe;
  PROCEND do_dfl_release_dfl;
?? TITLE := '  do_dfl_return_dfl', EJECT ??

  PROCEDURE do_dfl_return_dfl (p_dfl: ^dmt$ms_device_file_list_table;
        dfl_change: dmt$dfl_change;
        avt_index: dmt$active_volume_table_index;
        recovery_logging: boolean);

    VAR
      dfl_entry: dmt$ms_device_file_list_entry;

    dfl_entry := p_dfl^.entries [dfl_change.dfl_index];

    IF valid_mainframe_dfl (dfl_change.return_dfl_block.mainframe_assigned, dfl_entry) THEN
      p_dfl^.entries [dfl_change.dfl_index].flags := dmc$dfle_available;
    ELSEIF NOT recovery_logging THEN
      process_dfl_change_error (avt_index, dfl_change, dfl_entry, recovery_logging);
    IFEND;
  PROCEND do_dfl_return_dfl;
?? TITLE := '  do_dfl_update_file_length', EJECT ??

  PROCEDURE do_dfl_update_file_length (p_dfl: ^dmt$ms_device_file_list_table;
        dfl_change: dmt$dfl_change;
        avt_index: dmt$active_volume_table_index;
        recovery_logging: boolean);

    VAR
      ok: boolean,
      dfl_entry: dmt$ms_device_file_list_entry;

    dfl_entry := p_dfl^.entries [dfl_change.dfl_index];

    { Validate DFL change.

    ok := valid_file_dfl (dfl_change.file_length_block.global_file_name, dfl_entry);

    IF NOT ok THEN
      process_dfl_change_error (avt_index, dfl_change, dfl_entry, recovery_logging);
      RETURN;
    IFEND;

    { Process DFL change.

    IF dfl_change.file_length_block.eof_specified THEN
      p_dfl^.entries [dfl_change.dfl_index].end_of_file := dfl_change.file_length_block.eof;
    IFEND;

    IF dfl_change.file_length_block.eoi_specified THEN
      p_dfl^.entries [dfl_change.dfl_index].end_of_information := dfl_change.file_length_block.eoi;
    IFEND;
  PROCEND do_dfl_update_file_length;
?? TITLE := '  do_dfl_update_fmd_length', EJECT ??

  PROCEDURE do_dfl_update_fmd_length (p_dfl: ^dmt$ms_device_file_list_table;
        dfl_change: dmt$dfl_change;
        avt_index: dmt$active_volume_table_index;
        recovery_logging: boolean);

    VAR
      ok: boolean,
      dfl_entry: dmt$ms_device_file_list_entry;

    dfl_entry := p_dfl^.entries [dfl_change.dfl_index];

    { Validate DFL change.

    ok := valid_file_dfl (dfl_change.fmd_length_block.global_file_name, dfl_entry);

    IF NOT ok THEN
      process_dfl_change_error (avt_index, dfl_change, dfl_entry, recovery_logging);
      RETURN;
    IFEND;

    { Process DFL change.

    IF dfl_change.fmd_length_block.fmd_length_specified THEN
      p_dfl^.entries [dfl_change.dfl_index].fmd_length := dfl_change.fmd_length_block.
            fmd_length;
    IFEND;

    IF dfl_change.fmd_length_block.logical_length_specified THEN
      p_dfl^.entries [dfl_change.dfl_index].logical_length := dfl_change.fmd_length_block.
            logical_length;
    IFEND;
  PROCEND do_dfl_update_fmd_length;
?? TITLE := '  down_volume', EJECT ??
  PROCEDURE down_volume (avt_index: dmt$active_volume_table_index;
                         tell_cm: boolean;
                     VAR status: ost$status);

    VAR
      element: ^cmt$element_definition,
      first_unit: iot$logical_unit,
      found: boolean,
      ignore: ost$status,
      iou0: cmt$element_name,
      l: integer,
      lun: iot$logical_unit,
      msg: string (56),
      pp: integer,
      p_ppit: ^iot$pp_interface_table,
      request_block : cmt$request_block,
      unit_count: iot$logical_unit;

    status.normal := TRUE;

    lun := dmv$p_active_volume_table^ [avt_index].logical_unit_number;
    PUSH element;
    cmp$pc_get_logical_unit (lun, element, status);
    IF status.normal THEN
      found := FALSE;
    /search_pp_table/
      FOR pp := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
        IF NOT cmv$logical_pp_table_p^ [pp].flags.configured THEN
          CYCLE /search_pp_table/;
        IFEND;
        p_ppit := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;
        first_unit := p_ppit^.first_logical_unit;
        unit_count := p_ppit^.number_of_units;

        IF (lun >= first_unit) AND (lun <= (first_unit+unit_count-1)) THEN
          IF p_ppit^.unit_descriptors[lun].unit_interface_table <> NIL THEN
            found := TRUE;
            EXIT /search_pp_table/;
          IFEND;
        IFEND;
      FOREND /search_pp_table/;

      IF NOT found THEN
        RETURN;
      IFEND;

      request_block.request_code := syc$rc_config_mgmt_request;
      request_block.status.normal := TRUE;
      request_block.kind := cmc$rbk_change_state;
      request_block.iou := 0;
      request_block.element_name := element^.element_name;
      request_block.new_state := cmc$down;
      request_block.redundant_path_available := FALSE;
      request_block.update_controller_address := FALSE;
      request_block.redundant_path_pp_list_p := NIL;
      request_block.logical_unit_list_p := NIL;
      request_block.element_type := cmc$storage_device_element;
      request_block.unit_pp := pp;
      request_block.unit_channel := p_ppit^.unit_descriptors[lun].physical_path.channel_number;
      request_block.unit_controller := p_ppit^.unit_descriptors[lun].physical_path.controller_number;
      request_block.logical_unit := lun;



      i#call_monitor (#LOC (request_block) , #SIZE (request_block));

      IF NOT request_block.status.normal THEN                  { downing a volume twice is a no-op, so that
        status.normal := FALSE;                                { isn't the problem ...
        status.condition := request_block.status.condition;

      ELSE   { issue critical message

        IF tell_cm THEN             { alter memory tables to allow change_element_state on the volume
          iou0 := 'JUNK';           { cm doesn't use iou_name for mass storage devices
          cmp$change_state_info_table (element^.element_name, iou0, cmc$down, ignore);
        IFEND;
        STRINGREP (msg, l, 'VOLUME ', dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn,
                           ' DOWNED (',element^.element_name,')');
        dpp$put_critical_message (msg (1, l), ignore);
        { will not retain across DS as we cannot change the PCU in ring 1
        dpp$put_critical_message ('STATE CHANGE WILL NOT SURVIVE A DEADSTART', ignore);
        IF NOT tell_cm THEN
          dpp$put_critical_message ('YOU WILL BE UNABLE TO CHANGE_ELEMENT_STATE', ignore);
        IFEND;
      IFEND;
    IFEND;

  PROCEND down_volume;

?? TITLE := '  empty_device_log', EJECT ??

  PROCEDURE empty_device_log (login_table_sfid: dmt$system_file_id;
        p_device_log: dmt$device_log;
        mainframe_assigned: dmt$mainframe_assigned;
        p_dat: ^dmt$ms_device_allocation_table;
        p_dflt: ^dmt$ms_device_file_list_table;
        avt_index: dmt$active_volume_table_index;
        split_al: boolean;
        production_logging: boolean;
    VAR log_position: integer;
    VAR status: ost$status);

    VAR
      recovery_logging: boolean,
      device_log: dmt$device_log,
      p_login_table: ^dmt$ms_mainframe_login_table,
      p_dat_changes: ^dmt$dat_changes,
      p_dfl_changes: ^dmt$dfl_changes,
      number_dfl_changes: integer,
      number_dat_changes: integer,
      login_index: dmt$login_table_entry_index,
      no_more_stuff_in_log: boolean,
      log_entry: dmt$dl_entry,
      recovery_testing_aborts: dmt$dl_recovery_testing_aborts;

    status.normal := TRUE;
    recovery_logging := NOT production_logging;
    recovery_testing_aborts := dmc$dl_no_abort;

    login_index := mainframe_assigned.log_in_index;
    device_log := p_device_log;

    dmp$open_login_table (login_table_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend,
          mmc$as_sequential, p_login_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    REPEAT
      IF split_al THEN
        dmp$split_allocation_log (FALSE, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      p_dat_changes := NIL;
      p_dfl_changes := NIL;
      number_dat_changes := 0;
      number_dfl_changes := 0;

      log_entry.kind := dmc$dl_last_update_entry;
      IF production_logging THEN
        lock_log_and_insert_entry (log_entry, avt_index, device_log, status);
      ELSE
        insert_dl_entry (login_table_sfid, login_index, log_entry, device_log, log_position, status);
      IFEND;

      process_device_log (avt_index, mainframe_assigned, p_dat, p_dflt, login_table_sfid, device_log,
            production_logging, p_dat_changes, number_dat_changes, p_dfl_changes, number_dfl_changes,
            recovery_testing_aborts, log_position, status);

      log_entry.kind := dmc$dl_update_disk_tables;
      IF production_logging THEN
        lock_log_and_insert_entry (log_entry, avt_index, device_log, status);
      ELSE
        insert_dl_entry (login_table_sfid, login_index, log_entry, device_log, log_position, status);
      IFEND;

      process_dat_changes (p_dat, avt_index, number_dat_changes, recovery_logging, p_dat_changes, status);

      process_dfl_changes (p_dflt, avt_index, number_dfl_changes, recovery_logging, p_dfl_changes, status);

      IF recovery_testing_aborts = dmc$dl_halt_before_logging_dtu THEN
        osp$fatal_system_error ('HALT FOR RECOVERY TEST', NIL);
      IFEND;

      log_entry.kind := dmc$dl_disk_tables_updated;
      IF production_logging THEN
        lock_log_and_insert_entry (log_entry, avt_index, device_log, status);
      ELSE
        insert_dl_entry (login_table_sfid, login_index, log_entry, device_log, log_position, status);
      IFEND;

      check_device_log (p_login_table, login_index, device_log, no_more_stuff_in_log);

    UNTIL no_more_stuff_in_log;

    dmp$close_file (p_login_table, status);

  PROCEND empty_device_log;
?? TITLE := '  extract_log_entries_from_al', EJECT ??

  PROCEDURE extract_log_entries_from_al (p_aloc_log_info: ^dmt$allocation_log_info;
    VAR device_log: dmt$device_log;
        login_table_sfid: dmt$system_file_id;
        p_login_table: ^dmt$ms_mainframe_login_table;
        login_index: dmt$login_table_entry_index;
        avt_index: dmt$active_volume_table_index;
    VAR log_position: integer;
    VAR status: ost$status);

    VAR
      j,
      i: dmt$allocation_log_index,
      log_entry: dmt$dl_entry,
      al_entry: dmt$al_entry;

    status.normal := TRUE;

    j := p_aloc_log_info^.first;

    FOR i := 1 TO p_aloc_log_info^.number DO
      IF p_aloc_log_info^.entries [j].avt_index = p_login_table^.body [login_index].avt_index THEN
        al_entry := p_aloc_log_info^.entries [j];

        CASE al_entry.kind OF

        = dmc$al_allocate =
          log_entry.kind := dmc$dl_allocate;
          log_entry.allocate_block := p_aloc_log_info^.entries [j].allocate_block;

        = dmc$al_initialize =
          log_entry.kind := dmc$dl_initialize;
          log_entry.initialize_block := p_aloc_log_info^.entries [j].initialize_block;

        = dmc$al_return_dau =
          log_entry.kind := dmc$dl_return_dau;
          log_entry.return_dau_block := p_aloc_log_info^.entries [j].return_dau_block;

        = dmc$al_software_flawed =
          log_entry.kind := dmc$dl_software_flawed;
          log_entry.software_flaw_block := p_aloc_log_info^.entries [j].software_flaw_block;

        = dmc$al_reallocate =
          log_entry.kind := dmc$dl_reallocate;
          log_entry.reallocate_block := p_aloc_log_info^.entries [j].reallocate_block;

        = dmc$al_trim_file =
          log_entry.kind := dmc$dl_trim_file;
          log_entry.trim_file_block := p_aloc_log_info^.entries [j].trim_file_block;

        ELSE
          osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_device_log_entry,
            'bad entry in allocation log - DMMLOG', status);
          osp$fatal_system_error ('bad stuff in allocation log - DMMLOG', ^status);
        CASEND;

        insert_dl_entry (login_table_sfid, login_index, log_entry, device_log, log_position, status);
      IFEND;

      j := (j + 1) MOD dmc$max_allocation_log_entries;

    FOREND;
  PROCEND extract_log_entries_from_al;
?? TITLE := '  find_place_in_log', EJECT ??

  PROCEDURE find_place_in_log (old_mainframe_assigned: dmt$mainframe_assigned;
        p_device_log: dmt$device_log;
    VAR current_log_position: integer;
    VAR p_login_table: ^dmt$ms_mainframe_login_table;
    VAR recovery_dat_update_required: boolean;
    VAR status: ost$status);

    VAR
      device_log: dmt$device_log,
      last: integer,
      last_last: integer,
      p_entry_kind: ^dmt$dl_entry_kind,
      p_bytes: ^array [1 .. * ] of cell,
      p_check_byte: ^0 .. 0ff(16);

    status.normal := TRUE;

    last := p_login_table^.body [old_mainframe_assigned.log_in_index].last_update_offset;
    last_last := p_login_table^.body [old_mainframe_assigned.log_in_index].last_last_update_offset;
    device_log := p_device_log;
    p_entry_kind := #address (#ring (device_log), #segment (device_log), last);


    RESET device_log TO p_entry_kind;

    REPEAT
      NEXT p_entry_kind IN device_log;
      IF (log_entry_data_size [p_entry_kind^] > 0) THEN
        NEXT p_bytes: [1 .. log_entry_data_size [p_entry_kind^]] IN device_log;
      IFEND;
      NEXT p_check_byte IN device_log;
    UNTIL (p_entry_kind^ = dmc$invalid_dl_entry) OR (p_check_byte^ <> device_log_check_byte);

    current_log_position := #offset (p_entry_kind);

    p_entry_kind^ := dmc$invalid_dl_entry;
    p_entry_kind := #address (#ring (device_log), #segment (device_log), last);

    RESET device_log TO p_entry_kind;

    REPEAT
      NEXT p_entry_kind IN device_log;
      IF (log_entry_data_size [p_entry_kind^] > 0) THEN
        NEXT p_bytes: [1 .. log_entry_data_size [p_entry_kind^]] IN device_log;
      IFEND;
      NEXT p_check_byte IN device_log;
    UNTIL (p_entry_kind^ = dmc$dl_disk_tables_updated) OR (p_entry_kind^ = dmc$invalid_dl_entry) OR
          (p_check_byte^ <> device_log_check_byte);

    recovery_dat_update_required := (p_entry_kind^ <> dmc$dl_disk_tables_updated) AND (last <> last_last);

  PROCEND find_place_in_log;
?? TITLE := '  insert_dat_change', EJECT ??

  PROCEDURE insert_dat_change (dat_change: dmt$dat_change;
    VAR dat_change_abort: dmt$dat_change_abort;
    VAR p_dat_changes: ^dmt$dat_changes;
    VAR number_dat_changes: integer);

    VAR
      status: ost$status,
      temp_p_dat_changes: ^dmt$dat_changes,
      aux_dat_change: dmt$dat_change;

    IF dat_change_abort = dmc$dat_halt_before_change THEN
      dat_change_abort := dmc$dat_no_action;
      aux_dat_change.kind := dmc$dat_halt;
      aux_dat_change.dau_address := dat_change.dau_address;
      insert_dat_change (aux_dat_change, dat_change_abort, p_dat_changes, number_dat_changes);
    IFEND;

    IF p_dat_changes = NIL THEN
      ALLOCATE p_dat_changes: [1 .. 1000] IN osv$mainframe_pageable_heap^;
    IFEND;

    IF number_dat_changes = UPPERBOUND (p_dat_changes^) THEN
      ALLOCATE temp_p_dat_changes: [1 .. 2 * UPPERBOUND (p_dat_changes^)] IN osv$mainframe_pageable_heap^;
      i#move (p_dat_changes, temp_p_dat_changes, #SIZE (p_dat_changes^));
      FREE p_dat_changes IN osv$mainframe_pageable_heap^;
      p_dat_changes := temp_p_dat_changes;
    IFEND;

    number_dat_changes := number_dat_changes + 1;
    p_dat_changes^ [number_dat_changes] := dat_change;
    p_dat_changes^ [number_dat_changes].index := number_dat_changes;

    IF dat_change_abort = dmc$dat_halt_after_change THEN
      dat_change_abort := dmc$dat_no_action;
      aux_dat_change.kind := dmc$dat_halt;
      aux_dat_change.dau_address := dat_change.dau_address;
      insert_dat_change (aux_dat_change, dat_change_abort, p_dat_changes, number_dat_changes);
    IFEND;
  PROCEND insert_dat_change;
?? TITLE := '  insert_dfl_change', EJECT ??

  PROCEDURE insert_dfl_change (dfl_change: dmt$dfl_change;
    VAR dfl_change_abort: dmt$dfl_change_abort;
    VAR p_dfl_changes: ^dmt$dfl_changes;
    VAR number_dfl_changes: integer);

    VAR
      temp: integer,
      status: ost$status,
      lower: dmt$dfl_change_index,
      upper: dmt$dfl_change_index,
      guess: dmt$dfl_change_index,
      insertion_index: dmt$dfl_change_index,
      replacement_index: dmt$dfl_change_index,
      size: 0 .. 7fffffff(16),
      number_to_move: dmt$dfl_change_index,
      insertion_address: ^cell,
      replacement_address: ^cell,
      p_temp_buffer: ^dmt$dfl_changes,
      temp_p_dfl_changes: ^dmt$dfl_changes,
      aux_dfl_change: dmt$dfl_change;

    IF dfl_change_abort = dmc$dfl_halt_before_change THEN
      dfl_change_abort := dmc$dfl_no_action;
      aux_dfl_change.kind := dmc$dfl_halt;
      aux_dfl_change.dfl_index := dfl_change.dfl_index;
      insert_dfl_change (aux_dfl_change, dfl_change_abort, p_dfl_changes, number_dfl_changes);
    IFEND;

    IF p_dfl_changes = NIL THEN
      ALLOCATE p_dfl_changes: [1 .. 1000] IN osv$mainframe_pageable_heap^;
    IFEND;

    IF number_dfl_changes = UPPERBOUND (p_dfl_changes^) THEN
      ALLOCATE temp_p_dfl_changes: [1 .. 2 * UPPERBOUND (p_dfl_changes^)] IN osv$mainframe_pageable_heap^;
      i#move (p_dfl_changes, temp_p_dfl_changes, #SIZE (p_dfl_changes^));
      FREE p_dfl_changes IN osv$mainframe_pageable_heap^;
      p_dfl_changes := temp_p_dfl_changes;
    IFEND;

    p_dfl_changes := p_dfl_changes;
    lower := 0;
    upper := number_dfl_changes + 1;
    temp := lower + upper;
    guess := temp DIV 2;

    WHILE guess <> lower DO
      IF p_dfl_changes^ [guess].dfl_index <= dfl_change.dfl_index THEN
        lower := guess;
      ELSE
        upper := guess;
      IFEND;
      temp := lower + upper;
      guess := temp DIV 2;
    WHILEND;

    insertion_index := guess + 1;
    replacement_index := guess + 2;
    number_to_move := number_dfl_changes - insertion_index + 1;
    size := #SIZE (dmt$dfl_change) * number_to_move;

    IF size <> 0 THEN
      insertion_address := ^p_dfl_changes^ [insertion_index];
      replacement_address := ^p_dfl_changes^ [replacement_index];
      PUSH p_temp_buffer: [1 .. number_to_move];
      i#move (insertion_address, p_temp_buffer, size);
      i#move (p_temp_buffer, replacement_address, size);
    IFEND;

    p_dfl_changes^ [insertion_index] := dfl_change;
    number_dfl_changes := number_dfl_changes + 1;

    IF dfl_change_abort = dmc$dfl_halt_after_change THEN
      dfl_change_abort := dmc$dfl_no_action;
      aux_dfl_change.kind := dmc$dfl_halt;
      aux_dfl_change.dfl_index := dfl_change.dfl_index;
      insert_dfl_change (aux_dfl_change, dfl_change_abort, p_dfl_changes, number_dfl_changes);
    IFEND;
  PROCEND insert_dfl_change;
?? TITLE := '  insert_dl_entry', EJECT ??

  PROCEDURE insert_dl_entry (login_table_sfid: dmt$system_file_id;
        login_index: dmt$login_table_entry_index;
        device_log_entry: dmt$dl_entry;
        p_device_log: dmt$device_log;
    VAR current_log_position: integer; { this is an input output parameter }
    VAR status: ost$status);

    VAR
      device_log: dmt$device_log,
      dl_entry_kind: dmt$dl_entry_kind,
      p_login_table: ^dmt$ms_mainframe_login_table,
      p_create_block: ^dmt$dl_create_block,
      p_allocate_block: ^dmt$dl_allocate_block,
      p_deallocate_fragment_block: ^dmt$dl_deallocate_fragment_blk,
      p_trim_file_block: ^dmt$dl_trim_file_block,
      p_reallocate_block: ^dmt$dl_reallocate_block,
      p_sft_delete_block: ^dmt$dl_sft_delete_block,
      p_return_dau_block: ^dmt$dl_return_dau_block,
      p_attach_file_block: ^dmt$dl_attach_file_block,
      p_initialize_block: ^dmt$dl_initialize_block,
      p_purge_file_block: ^dmt$dl_purge_file_block,
      p_release_dau_block: ^dmt$dl_release_dau_block,
      p_release_dfl_block: ^dmt$dl_release_dfl_block,
      p_return_dfl_block: ^dmt$dl_return_dfl_block,
      p_software_flaw_block: ^dmt$dl_software_flaw_block,
      p_file_length_block: ^dmt$dl_file_length_block,
      p_fmd_length_block: ^dmt$dl_fmd_length_block,
      p_file_damaged_block: ^dmt$dl_file_damaged_block,
      p_entry_kind: ^dmt$dl_entry_kind,
      p_aux_entry_kind: ^dmt$dl_entry_kind,
      p_initial_entry_kind: ^dmt$dl_entry_kind,
      pva: ^cell,
      local_status: ost$status,
      p_check_byte: ^0 .. 0ff(16);

    status.normal := TRUE;

    dl_entry_kind := device_log_entry.kind;
    device_log := p_device_log;
    p_entry_kind := #address (#ring (device_log), #segment (device_log), current_log_position);

    RESET device_log TO p_entry_kind;

    NEXT p_entry_kind IN device_log;
    p_initial_entry_kind := p_entry_kind;

    CASE device_log_entry.kind OF

    = dmc$dl_allocate =
      NEXT p_allocate_block IN device_log;
      p_allocate_block^ := device_log_entry.allocate_block;

    = dmc$dl_deallocate_file_fragment =
      NEXT p_deallocate_fragment_block IN device_log;
      p_deallocate_fragment_block^ := device_log_entry.deallocate_file_fragment_block;

    = dmc$dl_trim_file =
      NEXT p_trim_file_block IN device_log;
      p_trim_file_block^ := device_log_entry.trim_file_block;

    = dmc$dl_reallocate =
      NEXT p_reallocate_block IN device_log;
      p_reallocate_block^ := device_log_entry.reallocate_block;

    = dmc$dl_create =
      NEXT p_create_block IN device_log;
      p_create_block^ := device_log_entry.create_block;

    = dmc$dl_return_dau, dmc$dl_recycle_dau =
      NEXT p_return_dau_block IN device_log;
      p_return_dau_block^ := device_log_entry.return_dau_block;

    = dmc$dl_attach_file, dmc$dl_detach_file =
      NEXT p_attach_file_block IN device_log;
      p_attach_file_block^ := device_log_entry.attach_file_block;

    = dmc$dl_initialize =
      NEXT p_initialize_block IN device_log;
      p_initialize_block^ := device_log_entry.initialize_block;

    = dmc$dl_purge_file =
      NEXT p_purge_file_block IN device_log;
      p_purge_file_block^ := device_log_entry.purge_file_block;

    = dmc$dl_second_purge_file =
      NEXT p_purge_file_block IN device_log;
      p_purge_file_block^ := device_log_entry.purge_file_block;

    = dmc$dl_release_dau, dmc$dl_continue_purge =
      NEXT p_release_dau_block IN device_log;
      p_release_dau_block^ := device_log_entry.release_dau_block;

    = dmc$dl_release_dfl =
      NEXT p_release_dfl_block IN device_log;
      p_release_dfl_block^ := device_log_entry.release_dfl_block;

    = dmc$dl_return_dfl =
      NEXT p_return_dfl_block IN device_log;
      p_return_dfl_block^ := device_log_entry.return_dfl_block;

    = dmc$dl_software_flawed =
      NEXT p_software_flaw_block IN device_log;
      p_software_flaw_block^ := device_log_entry.software_flaw_block;

    = dmc$dl_update_file_length =
      NEXT p_file_length_block IN device_log;
      p_file_length_block^ := device_log_entry.file_length_block;

    = dmc$dl_update_fmd_length =
      NEXT p_fmd_length_block IN device_log;
      p_fmd_length_block^ := device_log_entry.fmd_length_block;

    = dmc$dl_first_sft_delete, dmc$dl_second_sft_delete, dmc$dl_third_sft_delete =
      NEXT p_sft_delete_block IN device_log;
      p_sft_delete_block^ := device_log_entry.sft_delete_block;

    = dmc$dl_file_damaged =
      NEXT p_file_damaged_block IN device_log;
      p_file_damaged_block^ := device_log_entry.file_damaged_block;

    = dmc$dl_last_update_entry =
      dmp$open_login_table (login_table_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend,
            mmc$as_sequential, p_login_table, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

        NEXT p_check_byte IN device_log;
        p_check_byte^ := device_log_check_byte;
        NEXT p_aux_entry_kind IN device_log;
        p_aux_entry_kind^ := dmc$invalid_dl_entry;
        p_entry_kind^ := dmc$dl_last_update_entry;

        IF p_login_table^.body [login_index].recovery_status <> dmc$lt_recovering THEN
          mmp$write_modified_pages (device_log, #offset (p_aux_entry_kind) + 1, osc$wait, status);
          IF NOT status.normal THEN
            IF (p_login_table^.body [login_index].recovery_status = dmc$lt_normal_status) THEN
              IF osp$file_access_condition (status) THEN
                status.normal := TRUE;
              ELSE
                osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_flush_file,
                  'unable to flush device log - DMMLOG', status);
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        p_login_table^.body [login_index].last_last_update_offset := p_login_table^.body [login_index].
              last_update_offset;
        p_login_table^.body [login_index].last_update_offset := #offset (p_entry_kind);
        p_login_table^.body [login_index].current_position_offset := #offset (p_aux_entry_kind);

        mmp$write_modified_pages (p_login_table, #SIZE (p_login_table^), osc$wait, status);
        IF NOT status.normal THEN
          IF osp$file_access_condition (status) THEN
            status.normal := TRUE;
          ELSE
            osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_flush_file,
              'unable to flush login table - DMMLOG', status);
            RETURN;
          IFEND;
        IFEND;

      dmp$close_file (p_login_table, status);

      current_log_position := #offset (p_aux_entry_kind);

      RETURN;

    = dmc$dl_sa_on_dl_entry, dmc$dl_sa_after_process_dl, dmc$dl_sa_bef_next_dfl_change,
          dmc$dl_sa_aft_next_dfl_change, dmc$dl_sa_bef_next_dat_change, dmc$dl_sa_aft_next_dat_change,
            dmc$dl_sa_bef_logging_dtu, dmc$dl_sa_bef_mf_table_update, dmc$dl_sa_aft_mf_table_update,
            dmc$dl_ra_on_dl_entry, dmc$dl_ra_after_process_dl, dmc$dl_ra_bef_next_dfl_change,
            dmc$dl_ra_aft_next_dfl_change, dmc$dl_ra_bef_next_dat_change, dmc$dl_ra_aft_next_dat_change,
            dmc$dl_start_update, dmc$dl_disk_tables_updated,dmc$dl_ra_bef_logging_dtu,
            dmc$dl_update_disk_tables =

    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_device_log_kind,
        'bad device log entry kind - DMMLOG', status);
      RETURN;
    CASEND;

    NEXT p_check_byte IN device_log;
    p_check_byte^ := device_log_check_byte;

    NEXT p_entry_kind IN device_log;
    p_entry_kind^ := dmc$invalid_dl_entry;

{   We can not over-write the previous invalid entry located at p_initial_entry_kind }
{    until this entire entry has been completed.  Crashes have occured during this   }
{    time in which a page boundry has been crossed and the invalid entry was lost.   }

    p_initial_entry_kind^ := dl_entry_kind;

    current_log_position := #offset (p_entry_kind);

  PROCEND insert_dl_entry;
?? TITLE := '  lock_log_and_insert_entry', EJECT ??

  PROCEDURE lock_log_and_insert_entry (device_log_entry: dmt$dl_entry;
        avt_index: dmt$active_volume_table_index;
        p_device_log: dmt$device_log;
    VAR status: ost$status);

    VAR
      info: dmt$avt_logging_info,
      login_table_sfid: dmt$system_file_id,
      login_index: dmt$login_table_entry_index,
      current_log_position: integer,
      number_of_log_entries: integer,
      avt_entry_found: boolean;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (dmv$p_active_volume_table^ [avt_index].mass_storage.logging_lock);

    dmp$get_avt_logging_info (avt_index, info, avt_entry_found);
    IF avt_entry_found THEN

      current_log_position := info.current_log_offset;
      login_index := info.mainframe_assigned.log_in_index;
      login_table_sfid := info.login_table_sfid;
      number_of_log_entries := info.log_entry_count;

      IF dmv$administer_log_initiated AND (number_of_log_entries >= dmv$log_entries_max_thresehold) THEN
        tmp$ready_system_task (tmc$stid_administer_log, status);
      IFEND;

      insert_dl_entry (login_table_sfid, login_index, device_log_entry, p_device_log, current_log_position,
            status);
      IF status.normal THEN
        dmv$p_active_volume_table^ [avt_index].mass_storage.current_position_offset_in_log :=
              current_log_position;
        dmv$p_active_volume_table^ [avt_index].mass_storage.device_log_entry_count := (number_of_log_entries +
              1) MOD UPPERVALUE (dmv$p_active_volume_table^ [avt_index].mass_storage.device_log_entry_count);
      IFEND;
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
        'unable to locate avt entry - lock_log_and_insert_entry', status);
    IFEND;

    osp$clear_mainframe_sig_lock (dmv$p_active_volume_table^ [avt_index].mass_storage.logging_lock);

  PROCEND lock_log_and_insert_entry;
?? TITLE := '  open_device_log', EJECT ??

  PROCEDURE open_device_log (sfid: dmt$system_file_id;
        force_open: boolean;
    VAR device_log: dmt$device_log;
    VAR status: ost$status);

    VAR
      p_segment_pva: ^cell,
      seq_pointer: ^cyt$sequence_pointer,
      segment_number: ost$segment,
      p_fde: ^gft$file_descriptor_entry,
      able_to_locate_fde: boolean,
      segment_pointer: mmt$segment_pointer;

    status.normal := TRUE;

    segment_pointer.kind := mmc$sequence_pointer;

    dmp$open_file (sfid, osc$os_ring_1, osc$os_ring_1, mmc$sar_write_extend, mmc$as_sequential,
          segment_pointer, status);
    IF NOT status.normal THEN
      IF status.condition = dme$volume_unavailable THEN
        IF force_open THEN
          gfp$get_fde_p (sfid, p_fde);
          IF p_fde <> NIL THEN
            mmp$open_file_by_sfid (sfid, osc$os_ring_1, osc$os_ring_1,
                  mmc$as_sequential, mmc$sar_write_extend,
                  segment_number, status);
            IF status.normal THEN
              p_segment_pva := #address (1, segment_number, 0);
              seq_pointer := #LOC (segment_pointer.seq_pointer);
              seq_pointer^.pva := p_segment_pva;
              IF p_fde^.file_limit <= osc$maximum_offset THEN
                seq_pointer^.length := p_fde^.file_limit;
              ELSE
                seq_pointer^.length := osc$maximum_offset;
              IFEND;
              seq_pointer^.nextt := 0;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    IF status.normal THEN
      device_log := segment_pointer.seq_pointer;
    IFEND;

  PROCEND open_device_log;
?? TITLE := '  preallocate_device_log', EJECT ??

{    The purpose of this procedure is to keep the device log preallocated and preinitialized.  }
{  This is particularly  important in the event of a recovery  without image or a  retry of a  }
{  recovery  with image.   By allocating  the  device  log considerably  ahead of the current  }
{  position, and touching  each  uninitialized  allocation unit and then forcing a write, the  }
{  probability of being able to attach the  device log at recovery time,   solely from tables  }
{  that reside on the disk, is rendered  near certainty.   This is necessary when  recovering  }
{  without  an image and when reentering recovery.                                             }

  PROCEDURE preallocate_device_log (device_log: dmt$device_log;
        device_log_sfid: dmt$system_file_id;
        avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      avt_entry_found: boolean,
      byte_address: amt$file_byte_address,
      bytes_per_allocation: dmt$bytes_per_allocation,
      current_log_position_address: amt$file_byte_address,
      device_log_pva: ^integer,
      highest_allocated_log_address: amt$file_byte_address,
      info: dmt$avt_logging_info,
      length: integer,
      number_bytes_to_allocate: amt$file_byte_address,
      p_attributes: ^array [ * ] of dmt$assigned_ms_vol_attribute,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fau: ^dmt$file_allocation_unit,
      p_fde: ^gft$file_descriptor_entry,
      p_fmd: ^dmt$file_medium_descriptor,
      rounded_up_current_log_position: amt$file_byte_address;


    status.normal := TRUE;

    dmp$get_avt_logging_info (avt_index, info, avt_entry_found);
    IF NOT avt_entry_found THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
        'unable to locate avt entry - preallocate_device_log', status);
      RETURN;
    IFEND;
    highest_allocated_log_address := info.allocated_log_size;
    current_log_position_address := info.current_log_offset;

    number_bytes_to_allocate := 32768;
    rounded_up_current_log_position := ((current_log_position_address DIV number_bytes_to_allocate) + 1) *
          number_bytes_to_allocate;
    IF (number_bytes_to_allocate + rounded_up_current_log_position) > highest_allocated_log_address THEN
      gfp$get_fde_p (device_log_sfid, p_fde);
      IF p_fde = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
          'unable to locate device log fde', status);
        RETURN;
      IFEND;

      IF (p_fde^.file_kind <> gfc$fk_device_file) THEN
        RETURN;
      IFEND;

      dmp$allocate_file_space_r1 (device_log_sfid, highest_allocated_log_address, number_bytes_to_allocate, 0,
            osc$wait, sfc$no_limit, status);

      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
      osp$set_mainframe_sig_lock (dmv$p_active_volume_table^ [avt_index].mass_storage.logging_lock);

    /logging_lock_set/
      BEGIN

        dmp$get_avt_logging_info (avt_index, info, avt_entry_found);
        IF NOT avt_entry_found THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
            'unable to locate avt entry - preallocate_device_log', status);
          EXIT /logging_lock_set/;
        IFEND;
        current_log_position_address := info.current_log_offset;
        bytes_per_allocation := p_dfd^.bytes_per_allocation;

        byte_address := highest_allocated_log_address + bytes_per_allocation;
        WHILE byte_address < (highest_allocated_log_address + number_bytes_to_allocate) DO
          dmp$get_fau_entry (p_dfd, byte_address, p_fau);
          IF p_fau^.state = dmc$fau_invalid_data THEN
            device_log_pva := #address (#ring (device_log), #segment (device_log), byte_address);
            device_log_pva^ := 0;
          IFEND;
          byte_address := byte_address + bytes_per_allocation;
        WHILEND;

        {***  WHAT DOES IT MEAN IF P_FAU^.STATE = DMC$FAU_FREE? *** }

        dmp$get_fmd_by_index (p_dfd, p_fau^.fmd_index, p_fmd);
        dmv$p_active_volume_table^ [avt_index].mass_storage.allocated_log_size :=
            p_fmd^.fmd_allocated_length;

      END /logging_lock_set/;

      osp$clear_mainframe_sig_lock (dmv$p_active_volume_table^ [avt_index].mass_storage.logging_lock);

      mmp$write_modified_pages (device_log, p_fmd^.fmd_allocated_length + number_bytes_to_allocate,
              osc$nowait, status);
      IF osp$file_access_condition (status) THEN
        status.normal := TRUE;
      IFEND;

    IFEND;

  PROCEND preallocate_device_log;
?? TITLE := '  process_dat_change_error', EJECT ??

 PROCEDURE process_dat_change_error (avt_index: dmt$active_volume_table_index;
       dat_change: dmt$dat_change;
       dau_address: dmt$dau_address;
       dau_entry: dmt$ms_device_allocation_unit;
       recovery_logging: boolean);

   VAR
     error_count: integer,
     error_index: integer,
     list_lower: integer,
     list_length: integer,
     dat_change_error: dmt$dat_change_error;

   list_lower := LOWERBOUND (dmv$dat_change_errors.error_list);
   list_length := UPPERBOUND (dmv$dat_change_errors.error_list) - list_lower + 1;

   dat_change_error.avt_index := avt_index;
   dat_change_error.recovery_logging := recovery_logging;
   dat_change_error.dat_change := dat_change;
   dat_change_error.dau_address := dau_address;
   dat_change_error.dau_entry := dau_entry;
   dat_change_error.time := #free_running_clock (0);

   osp$increment_locked_variable (dmv$dat_change_errors.error_count, 0, error_count);
   error_index := ((error_count - 1) MOD list_length) + list_lower;
   dmv$dat_change_errors.error_list [error_index] := dat_change_error;

   IF (dmc$debug_dat_changes IN dmv$debug_options) THEN
     IF NOT (recovery_logging AND osv$recover_at_all_costs) THEN
       osp$fatal_system_error ('Invalid DAT change.', NIL);
     IFEND;
   IFEND;
 PROCEND process_dat_change_error;
?? TITLE := '  process_dat_changes', EJECT ??

  PROCEDURE process_dat_changes (p_dat: ^dmt$ms_device_allocation_table;
                                 avt_index: dmt$active_volume_table_index;
                                 number_dat_changes: integer;
                                 recovery_logging: boolean;
                             VAR p_dat_changes: ^dmt$dat_changes;
                             VAR status: ost$status);

?? SKIP := 1 ??
    PROCEDURE handler (mf: ost$monitor_fault;
                       p_msa: ^ost$minimum_save_area;
                   VAR continue: syt$continue_option);
      VAR
        p_scc: ^syt$system_core_condition,
        p_sac: ^mmt$segment_access_condition;

      IF mf.identifier = mmc$segment_fault_processor_id THEN
        p_sac := #LOC(mf.contents);
        CASE p_sac^.identifier OF
        = mmc$sac_io_read_error =
          osp$set_status_abnormal ('MM', mme$io_read_error,
             'io error - process_dat_changes', status);
          EXIT process_dat_changes;
        ELSE
        CASEND;

      ELSEIF mf.identifier = syc$system_core_condition THEN
        p_scc := #LOC(mf.system_core_condition);
        CASE p_scc^.condition OF
        = syc$user_defined_condition =
          IF p_scc^.user_defined_condition = syc$udc_volume_unavailable THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable,
                'volume unavailable in process_dat_changes', status);
            EXIT process_dat_changes;
          IFEND;
        ELSE
        CASEND;
      IFEND;

      syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);

    PROCEND handler;
?? SKIP := 1 ??

    VAR
      mat_change_count: dmt$mat_change_count,
      p_mat_changes: ^dmt$mat_changes,
      i: dmt$dat_change_index,
      dat_change: dmt$dat_change;

    status.normal := TRUE;

    IF (p_dat_changes = NIL) OR (number_dat_changes = 0) THEN
      RETURN;
    IFEND;

    sort_dat_changes (p_dat_changes, number_dat_changes);

    ALLOCATE p_mat_changes: [1 .. 100] IN osv$mainframe_wired_heap^;
    mat_change_count := 0;

    syp$establish_condition_handler (^handler);

  /process_the_changes/
    FOR i := 1 TO number_dat_changes DO

      dat_change := p_dat_changes^ [i];

      IF (dat_change.dau_address >= p_dat^.header.number_of_entries) THEN
        process_dat_change_error (avt_index, dat_change, 0, p_dat^.body [0], recovery_logging);
        CYCLE /process_the_changes/;
      IFEND;

      CASE dat_change.kind OF

      = dmc$dat_software_flawed =
        do_dat_software_flawed (p_dat, dat_change);

      = dmc$dat_initialize =
        do_dat_initialize (p_dat, dat_change, avt_index, recovery_logging);

      = dmc$dat_release_dau =
        do_dat_release_dau (p_dat, dat_change, avt_index, recovery_logging);

      = dmc$dat_return_dau =
        do_dat_return_dau (p_dat, dat_change, avt_index, recovery_logging);

      = dmc$dat_recycle_dau =
        do_dat_recycle_dau (p_dat, dat_change, avt_index, recovery_logging, p_mat_changes, mat_change_count);

      = dmc$dat_assign_dau =
        do_dat_assign_dau (p_dat, dat_change, avt_index, recovery_logging);

      = dmc$dat_update_dau =
        do_dat_update_dau (p_dat, dat_change, avt_index, recovery_logging);

      = dmc$dat_halt =
        osp$fatal_system_error ('HALT FOR RECOVERY TEST', NIL);

      = dmc$dat_reallocate_dau =
        do_dat_reallocate_dau (p_dat, dat_change, avt_index, recovery_logging);

      = dmc$dat_delink_dau =
        do_dat_delink_dau (p_dat, dat_change, avt_index, recovery_logging);

      ELSE
        osp$fatal_system_error ('Invalid DAT change.', NIL);
      CASEND;
    FOREND /process_the_changes/;

    syp$disestablish_cond_handler;

    change_mat (avt_index, mat_change_count, p_mat_changes, p_dat^.header.available);
    FREE p_mat_changes IN osv$mainframe_wired_heap^;

    mmp$write_modified_pages (p_dat, #SIZE (p_dat^), osc$wait, status);
    IF NOT status.normal THEN
      IF osp$file_access_condition (status) THEN
        status.normal := TRUE;
      IFEND;
    IFEND;

    IF p_dat_changes <> NIL THEN
      FREE p_dat_changes IN osv$mainframe_pageable_heap^;
    IFEND;

  PROCEND process_dat_changes;
?? TITLE := '  process_device_log', EJECT ??

  PROCEDURE process_device_log (avt_index: dmt$active_volume_table_index;
        mainframe_assigned: dmt$mainframe_assigned;
        p_dat: ^dmt$ms_device_allocation_table;
        p_dflt: ^dmt$ms_device_file_list_table;
        login_table_sfid: dmt$system_file_id;
        p_device_log: dmt$device_log;
        production_logging: boolean;
    VAR p_dat_changes: ^dmt$dat_changes;
    VAR number_dat_changes: integer;
    VAR p_dfl_changes: ^dmt$dfl_changes;
    VAR number_dfl_changes: integer;
    VAR recovery_testing_aborts: dmt$dl_recovery_testing_aborts;
    VAR current_position_in_log: integer;
    VAR status: ost$status);

    VAR
      dfl_index: dmt$device_file_list_index,
      gfn: dmt$global_file_name,
      p_login_table: ^dmt$ms_mainframe_login_table,
      device_log: dmt$device_log,
      p_create_block: ^dmt$dl_create_block,
      p_allocate_block: ^dmt$dl_allocate_block,
      p_deallocate_fragment_block: ^dmt$dl_deallocate_fragment_blk,
      p_trim_file_block: ^dmt$dl_trim_file_block,
      p_reallocate_block: ^dmt$dl_reallocate_block,
      p_sft_delete_block: ^dmt$dl_sft_delete_block,
      p_return_dau_block: ^dmt$dl_return_dau_block,
      p_attach_file_block: ^dmt$dl_attach_file_block,
      p_initialize_block: ^dmt$dl_initialize_block,
      p_purge_file_block: ^dmt$dl_purge_file_block,
      p_release_dau_block: ^dmt$dl_release_dau_block,
      p_release_dfl_block: ^dmt$dl_release_dfl_block,
      p_return_dfl_block: ^dmt$dl_return_dfl_block,
      p_software_flaw_block: ^dmt$dl_software_flaw_block,
      p_file_length_block: ^dmt$dl_file_length_block,
      p_fmd_length_block: ^dmt$dl_fmd_length_block,
      p_file_damaged_block: ^dmt$dl_file_damaged_block,
      p_entry_kind: ^dmt$dl_entry_kind,
      p_check_byte: ^0 .. 0ff(16),
      log_entry: dmt$dl_entry,
      release_dau_block: dmt$dl_release_dau_block,
      dat_change: dmt$dat_change,
      dfl_change: dmt$dfl_change,
      dau_address: dmt$dau_address,
      normal_exit: boolean,
      more_aus: boolean,
      offset: integer,
      login_index: dmt$login_table_entry_index,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      fde_found: boolean,
      dat_change_abort: dmt$dat_change_abort,
      dfl_change_abort: dmt$dfl_change_abort,
      msg: string (80),
      msg_length: integer,
      recorded_vsn: rmt$recorded_vsn,
      recovery: boolean,
      local_status: ost$status,
      halt_after_processing_dl: boolean;

    status.normal := TRUE;

    recorded_vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;
    msg (1, *) := ' ';
    dat_change_abort := dmc$dat_no_action;
    dfl_change_abort := dmc$dfl_no_action;
    recovery_testing_aborts := dmc$dl_no_abort;
    halt_after_processing_dl := FALSE;
    normal_exit := TRUE;
    device_log := p_device_log;
    login_index := mainframe_assigned.log_in_index;

    dmp$open_login_table (login_table_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_read, mmc$as_sequential,
          p_login_table, status);
    IF status.normal THEN
      offset := p_login_table^.body [login_index].last_last_update_offset;
      recovery := (p_login_table^.body [login_index].recovery_status <> dmc$lt_normal_status);
      dmp$close_file (p_login_table, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_entry_kind := #address (#RING (device_log), #SEGMENT (device_log), offset);

    RESET device_log TO p_entry_kind;

    NEXT p_entry_kind IN device_log;
    IF p_entry_kind^ = dmc$dl_last_update_entry THEN  {start at the first non-last_update_entry}
      NEXT p_check_byte IN device_log;
      IF p_check_byte^ <> device_log_check_byte THEN
        IF NOT production_logging AND osv$recover_at_all_costs THEN
          RETURN;
        IFEND;
        STRINGREP (msg, msg_length, recorded_vsn, ' log check byte missing');
        osp$fatal_system_error (msg, NIL);
      ELSE
        NEXT p_entry_kind IN device_log;
      IFEND;
    ELSE
      IF NOT production_logging AND osv$recover_at_all_costs THEN
        RETURN;
      IFEND;
      STRINGREP (msg, msg_length, recorded_vsn, ' log starts incorrectly');
      osp$fatal_system_error (msg, NIL);
    IFEND;

  /process_log/
    WHILE p_entry_kind^ <> dmc$dl_last_update_entry DO
      CASE p_entry_kind^ OF

      = dmc$dl_initialize =
        NEXT p_initialize_block IN device_log;
        dat_change.kind := dmc$dat_initialize;
        dat_change.initialize_block := p_initialize_block^;
        dat_change.dau_address := p_initialize_block^.dau_address;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ = device_log_check_byte THEN
          insert_dat_change (dat_change, dat_change_abort, p_dat_changes, number_dat_changes);
        ELSE
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;

      = dmc$dl_software_flawed =
        NEXT p_software_flaw_block IN device_log;
        dat_change.kind := dmc$dat_software_flawed;
        dat_change.software_flaw_block := p_software_flaw_block^;
        dat_change.dau_address := p_software_flaw_block^.dau_address;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ = device_log_check_byte THEN
          insert_dat_change (dat_change, dat_change_abort, p_dat_changes, number_dat_changes);
        ELSE
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;

      = dmc$dl_release_dau =
        NEXT p_release_dau_block IN device_log;
        dat_change.kind := dmc$dat_release_dau;
        dat_change.release_dau_block := p_release_dau_block^;
        dat_change.dau_address := p_release_dau_block^.dau_address;
        dat_change.release_dau_block.mainframe_assigned := mainframe_assigned;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ = device_log_check_byte THEN
          insert_dat_change (dat_change, dat_change_abort, p_dat_changes, number_dat_changes);
          log_entry.kind := dmc$dl_recycle_dau;
          log_entry.return_dau_block.mainframe_assigned := mainframe_assigned;
          log_entry.return_dau_block.dau_address := p_release_dau_block^.dau_address;
          log_entry.return_dau_block.daus_per_allocation := p_release_dau_block^.daus_per_allocation;
          IF production_logging THEN
            lock_log_and_insert_entry (log_entry, avt_index, device_log, status);
          ELSE
            insert_dl_entry (login_table_sfid, login_index, log_entry, device_log, current_position_in_log,
                  status);
          IFEND;
          IF NOT status.normal THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_process_dl_entry,
              'unable to process release dau log entry - DMMLOG', status);
            EXIT /process_log/;
          IFEND;
        ELSE
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;

      = dmc$dl_return_dau, dmc$dl_recycle_dau =
        NEXT p_return_dau_block IN device_log;
        IF (p_entry_kind^ = dmc$dl_recycle_dau) THEN
          dat_change.kind := dmc$dat_recycle_dau;
        ELSE
          dat_change.kind := dmc$dat_return_dau;
        IFEND;
        dat_change.return_dau_block := p_return_dau_block^;
        dat_change.dau_address := p_return_dau_block^.dau_address;
        dat_change.return_dau_block.mainframe_assigned := mainframe_assigned;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ = device_log_check_byte THEN
          insert_dat_change (dat_change, dat_change_abort, p_dat_changes, number_dat_changes);
        ELSE
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;

      = dmc$dl_allocate =
        NEXT p_allocate_block IN device_log;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;
        dat_change.kind := dmc$dat_assign_dau;
        dat_change.dau_address := p_allocate_block^.dau_address;
        dat_change.assign_dau_block.global_file_name := p_allocate_block^.global_file_name;
        dat_change.assign_dau_block.dfl_index := p_allocate_block^.dfl_index;
        dat_change.assign_dau_block.mainframe_assigned := mainframe_assigned;
        dat_change.assign_dau_block.daus_per_allocation := p_allocate_block^.daus_per_allocation;
        IF p_allocate_block^.allocate_flags = dmc$dl_first_allocation THEN
          dat_change.assign_dau_block.first_flag := TRUE;
          insert_dat_change (dat_change, dat_change_abort, p_dat_changes, number_dat_changes);

          dfl_change.kind := dmc$dfl_first_dau;
          dfl_change.dfl_index := p_allocate_block^.dfl_index;
          dfl_change.first_dau_block.global_file_name := p_allocate_block^.global_file_name;
          dfl_change.first_dau_block.dfl_index := p_allocate_block^.dfl_index;
          dfl_change.first_dau_block.dau_address := p_allocate_block^.dau_address;
          insert_dfl_change (dfl_change, dfl_change_abort, p_dfl_changes, number_dfl_changes);
        ELSE
          dat_change.assign_dau_block.first_flag := FALSE;
          insert_dat_change (dat_change, dat_change_abort, p_dat_changes, number_dat_changes);

          dat_change.kind := dmc$dat_update_dau;
          dat_change.dau_address := p_allocate_block^.previous_dau_address;
          dat_change.update_dau_block.global_file_name := p_allocate_block^.global_file_name;
          dat_change.update_dau_block.dfl_index := p_allocate_block^.dfl_index;
          dat_change.update_dau_block.next_dau_address := p_allocate_block^.dau_address;
          insert_dat_change (dat_change, dat_change_abort, p_dat_changes, number_dat_changes);
        IFEND;

      = dmc$dl_deallocate_file_fragment =
        NEXT p_deallocate_fragment_block IN device_log;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;
        release_dau_block.global_file_name := p_deallocate_fragment_block^.
               global_file_name;
        release_dau_block.dfl_index := p_deallocate_fragment_block^.dfl_index;
        release_dau_block.daus_per_allocation := p_dflt^.entries
               [p_deallocate_fragment_block^.dfl_index].daus_per_allocation_unit;
        release_dau_block.mainframe_assigned := mainframe_assigned;
        release_dau_block.dau_address := p_deallocate_fragment_block^.dau_address;

        release_file_daus (release_dau_block, production_logging, avt_index, device_log,
                login_table_sfid, p_dat, current_position_in_log, status);
        IF NOT status.normal THEN
          EXIT /process_log/;
        IFEND;

      = dmc$dl_trim_file =
        NEXT p_trim_file_block IN device_log;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;
        dat_change.kind := dmc$dat_delink_dau;
        dat_change.dau_address := p_trim_file_block^.dau_address;
        dat_change.delink_dau_block.global_file_name := p_trim_file_block^.global_file_name;
        dat_change.delink_dau_block.dfl_index := p_trim_file_block^.dfl_index;
        insert_dat_change (dat_change, dat_change_abort, p_dat_changes, number_dat_changes);

        log_entry.kind := dmc$dl_deallocate_file_fragment;
        log_entry.deallocate_file_fragment_block.global_file_name := p_trim_file_block^.global_file_name;
        log_entry.deallocate_file_fragment_block.dfl_index := p_trim_file_block^.dfl_index;
        log_entry.deallocate_file_fragment_block.dau_address := p_trim_file_block^.dau_of_fragment;
        IF production_logging THEN
          lock_log_and_insert_entry (log_entry, avt_index, device_log, status);
        ELSE
          insert_dl_entry (login_table_sfid, mainframe_assigned.log_in_index, log_entry, device_log,
                current_position_in_log, status);
        IFEND;
        IF NOT status.normal THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_process_dl_entry,
              'unable to process trim log entry - DMMLOG', status);
          EXIT /process_log/;
        IFEND;

      = dmc$dl_reallocate =
        NEXT p_reallocate_block IN device_log;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;
        dat_change.kind := dmc$dat_reallocate_dau;
        dat_change.dau_address := p_reallocate_block^.dau_address;
        dat_change.reallocate_dau_block := p_reallocate_block^;
        dat_change.reallocate_dau_block.mainframe_assigned := mainframe_assigned;
        insert_dat_change (dat_change, dat_change_abort, p_dat_changes, number_dat_changes);
        IF (p_reallocate_block^.allocation_chain_position = dmc$first_allocation) OR
            (p_reallocate_block^.allocation_chain_position = dmc$first_and_last_allocation) THEN
          dfl_change.kind := dmc$dfl_first_dau;
          dfl_change.dfl_index := p_reallocate_block^.dfl_index;
          dfl_change.first_dau_block.global_file_name := p_reallocate_block^.global_file_name;
          dfl_change.first_dau_block.dfl_index := p_reallocate_block^.dfl_index;
          dfl_change.first_dau_block.dau_address := p_reallocate_block^.dau_address;
          insert_dfl_change (dfl_change, dfl_change_abort, p_dfl_changes, number_dfl_changes);
        ELSE
          dat_change.kind := dmc$dat_update_dau;
          dat_change.dau_address := p_reallocate_block^.previous_dau_address;
          dat_change.update_dau_block.global_file_name := p_reallocate_block^.global_file_name;
          dat_change.update_dau_block.dfl_index := p_reallocate_block^.dfl_index;
          dat_change.update_dau_block.next_dau_address := p_reallocate_block^.dau_address;
          insert_dat_change (dat_change, dat_change_abort, p_dat_changes, number_dat_changes);
        IFEND;
        log_entry.kind := dmc$dl_release_dau;
        log_entry.release_dau_block.global_file_name := p_reallocate_block^.global_file_name;
        log_entry.release_dau_block.dfl_index := p_reallocate_block^.dfl_index;
        log_entry.release_dau_block.daus_per_allocation := p_reallocate_block^.daus_per_allocation;
        log_entry.release_dau_block.mainframe_assigned := mainframe_assigned;
        log_entry.release_dau_block.dau_address := p_reallocate_block^.old_dau_address;
        IF production_logging THEN
          lock_log_and_insert_entry (log_entry, avt_index, device_log, status);
        ELSE
          insert_dl_entry (login_table_sfid, login_index, log_entry, device_log, current_position_in_log,
                status);
        IFEND;
        IF NOT status.normal THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_process_dl_entry,
            'unable to process reallocate log entry - DMMLOG', status);
          EXIT /process_log/;
        IFEND;

      = dmc$dl_first_sft_delete =
        NEXT p_sft_delete_block IN device_log;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;
        IF production_logging THEN
          gfp$get_fde_p (p_sft_delete_block^.sfid, p_fde);
          IF p_fde <> NIL THEN
            dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
            IF (p_dfd^.read_write_count <> 0) THEN
              log_entry.kind := dmc$dl_first_sft_delete;
            ELSE
              log_entry.kind := dmc$dl_second_sft_delete;
            IFEND;
            log_entry.sft_delete_block := p_sft_delete_block^;
            lock_log_and_insert_entry (log_entry, avt_index, device_log, status);
          ELSE
            osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
              'Bad SFID - process_device_log.', status);
          IFEND;

          IF NOT status.normal THEN
            osp$fatal_system_error ('process_device_log failure.', ^status);
          IFEND;
        IFEND;

      = dmc$dl_second_sft_delete =
        NEXT p_sft_delete_block IN device_log;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;
        IF production_logging THEN
          log_entry.kind := dmc$dl_third_sft_delete;
          log_entry.sft_delete_block := p_sft_delete_block^;
          lock_log_and_insert_entry (log_entry, avt_index, device_log, status);

          IF NOT status.normal THEN
            osp$fatal_system_error ('process_device_log failure.', ^status);
          IFEND;
        IFEND;

      = dmc$dl_third_sft_delete =
        NEXT p_sft_delete_block IN device_log;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;
        IF production_logging THEN
          dmp$complete_sft_delete (p_sft_delete_block^.sfid, p_sft_delete_block^.fmd_index, status);

          IF NOT status.normal THEN
            osp$fatal_system_error ('process_device_log failure.', ^status);
          IFEND;
        IFEND;

      = dmc$dl_purge_file =
        NEXT p_purge_file_block IN device_log;
        log_entry.kind := dmc$dl_second_purge_file;
        log_entry.purge_file_block := p_purge_file_block^;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;
        IF production_logging THEN
          lock_log_and_insert_entry (log_entry, avt_index, device_log, status);
        ELSE
          insert_dl_entry (login_table_sfid, login_index, log_entry, device_log, current_position_in_log,
                status);
        IFEND;
        IF NOT status.normal THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_process_dl_entry,
            'unable to process purge log entry - DMMLOG', status);
          EXIT /process_log/;
        IFEND;

      = dmc$dl_second_purge_file =
        NEXT p_purge_file_block IN device_log;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;

        gfn := p_purge_file_block^.global_file_name;
        dfl_index := p_purge_file_block^.dfl_index;

        {The DFL entry must be validated to tolerate software or hardware corruption of
        {the log or the DFL.  In addition, the log entry may be invalid if bad parameters
        {are passed to dmp$destroy_permanent_file, since no validation is performed by it
        {before issuing a purge log entry.

        IF valid_dfl_index (dfl_index, p_dflt) AND valid_file_dfl (gfn, p_dflt^.entries [dfl_index]) THEN
          log_entry.kind := dmc$dl_release_dfl;
          log_entry.release_dfl_block.global_file_name := gfn;
          log_entry.release_dfl_block.dfl_index := dfl_index;
          log_entry.release_dfl_block.mainframe_assigned := mainframe_assigned;
          IF production_logging THEN
            lock_log_and_insert_entry (log_entry, avt_index, device_log, status);
          ELSE
            insert_dl_entry (login_table_sfid, login_index, log_entry, device_log, current_position_in_log,
                  status);
          IFEND;
          IF NOT status.normal THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_process_dl_entry,
              'unable to process 2nd purge log entry - DMMLOG', status);
            EXIT /process_log/;
          IFEND;

          IF (p_dflt^.entries [dfl_index].dau_chain_status = dmc$dau_chain_linked) THEN
            release_dau_block.global_file_name := gfn;
            release_dau_block.dfl_index := dfl_index;
            release_dau_block.daus_per_allocation := p_dflt^.entries [dfl_index].daus_per_allocation_unit;
            release_dau_block.mainframe_assigned := mainframe_assigned;
            release_dau_block.dau_address := p_dflt^.entries [dfl_index].first_dau_address;
            release_file_daus (release_dau_block, production_logging, avt_index, device_log,
                    login_table_sfid, p_dat, current_position_in_log, status);
            IF NOT status.normal THEN
              EXIT /process_log/;
            IFEND;
          IFEND;
        IFEND;

      = dmc$dl_continue_purge =
        NEXT p_release_dau_block IN device_log;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;

        release_file_daus (p_release_dau_block^, production_logging, avt_index, device_log,
                login_table_sfid, p_dat, current_position_in_log, status);
        IF NOT status.normal THEN
          EXIT /process_log/;
        IFEND;

      = dmc$dl_create =
        dfl_change.kind := dmc$dfl_create;
        NEXT p_create_block IN device_log;
        dfl_change.create_block := p_create_block^;
        dfl_change.dfl_index := p_create_block^.dfl_index;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ = device_log_check_byte THEN
          insert_dfl_change (dfl_change, dfl_change_abort, p_dfl_changes, number_dfl_changes);
        ELSE
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;

      = dmc$dl_return_dfl =
        NEXT p_return_dfl_block IN device_log;
        dfl_change.kind := dmc$dfl_return_dfl;
        dfl_change.dfl_index := p_return_dfl_block^.dfl_index;
        dfl_change.return_dfl_block := p_return_dfl_block^;
        dfl_change.return_dfl_block.mainframe_assigned := mainframe_assigned;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ = device_log_check_byte THEN
          insert_dfl_change (dfl_change, dfl_change_abort, p_dfl_changes, number_dfl_changes);
        ELSE
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;

      = dmc$dl_release_dfl =
        NEXT p_release_dfl_block IN device_log;
        dfl_change.kind := dmc$dfl_release_dfl;
        dfl_change.dfl_index := p_release_dfl_block^.dfl_index;
        dfl_change.release_dfl_block := p_release_dfl_block^;
        dfl_change.release_dfl_block.mainframe_assigned := mainframe_assigned;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ = device_log_check_byte THEN
          insert_dfl_change (dfl_change, dfl_change_abort, p_dfl_changes, number_dfl_changes);
          log_entry.kind := dmc$dl_return_dfl;
          log_entry.return_dfl_block.dfl_index := dfl_change.dfl_index;
          log_entry.return_dfl_block.mainframe_assigned := mainframe_assigned;
          IF production_logging THEN
            lock_log_and_insert_entry (log_entry, avt_index, device_log, status);
          ELSE
            insert_dl_entry (login_table_sfid, login_index, log_entry, device_log, current_position_in_log,
                  status);
          IFEND;
          IF NOT status.normal THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_process_dl_entry,
              'unable to process release dfl log entry - DMMLOG', status);
            EXIT /process_log/;
          IFEND;
        ELSE
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;

      = dmc$dl_attach_file, dmc$dl_detach_file =
        NEXT p_attach_file_block IN device_log;
        dfl_change.attach_file_block := p_attach_file_block^;
        IF (p_entry_kind^ = dmc$dl_attach_file) THEN
          dfl_change.kind := dmc$dfl_attach_file;
          dfl_change.attach_file_block.mainframe_assigned := mainframe_assigned;
        ELSE
          dfl_change.kind := dmc$dfl_detach_file;
        IFEND;
        dfl_change.dfl_index := p_attach_file_block^.dfl_index;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ = device_log_check_byte THEN
          insert_dfl_change (dfl_change, dfl_change_abort, p_dfl_changes, number_dfl_changes);
        ELSE
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;

      = dmc$dl_update_file_length =
        NEXT p_file_length_block IN device_log;
        dfl_change.kind := dmc$dfl_update_file_length;
        dfl_change.dfl_index := p_file_length_block^.dfl_index;
        dfl_change.file_length_block := p_file_length_block^;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ = device_log_check_byte THEN
          insert_dfl_change (dfl_change, dfl_change_abort, p_dfl_changes, number_dfl_changes);
        ELSE
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;

      = dmc$dl_update_fmd_length =
        NEXT p_fmd_length_block IN device_log;
        dfl_change.kind := dmc$dfl_update_fmd_length;
        dfl_change.dfl_index := p_fmd_length_block^.dfl_index;
        dfl_change.fmd_length_block := p_fmd_length_block^;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ = device_log_check_byte THEN
          insert_dfl_change (dfl_change, dfl_change_abort, p_dfl_changes, number_dfl_changes);
        ELSE
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;

      = dmc$dl_disk_tables_updated, dmc$dl_start_update, dmc$dl_update_disk_tables =
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
        IFEND;

      = dmc$dl_file_damaged =
        NEXT p_file_damaged_block IN device_log;
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/;
        IFEND;
        dfl_change.kind := dmc$dfl_file_damaged;
        dfl_change.dfl_index := p_file_damaged_block^.dfl_index;
        dfl_change.file_damaged_block := p_file_damaged_block^;
        insert_dfl_change (dfl_change, dfl_change_abort, p_dfl_changes, number_dfl_changes);

      = dmc$dl_sa_on_dl_entry =
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/
        IFEND;
        IF dmv$test_recovery AND NOT recovery THEN
          osp$fatal_system_error ('HALT FOR RECOVERY TEST', NIL);
        IFEND;

      = dmc$dl_sa_after_process_dl =
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/
        IFEND;
        IF dmv$test_recovery AND NOT recovery THEN
          halt_after_processing_dl := TRUE;
        IFEND;

      = dmc$dl_sa_bef_next_dfl_change =
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/
        IFEND;
        IF dmv$test_recovery AND NOT recovery THEN
          dfl_change_abort := dmc$dfl_halt_before_change;
        IFEND;

      = dmc$dl_sa_aft_next_dfl_change =
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/
        IFEND;
        IF dmv$test_recovery AND NOT recovery THEN
          dfl_change_abort := dmc$dfl_halt_after_change;
        IFEND;

      = dmc$dl_sa_bef_next_dat_change =
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/
        IFEND;
        IF dmv$test_recovery AND NOT recovery THEN
          dat_change_abort := dmc$dat_halt_before_change;
        IFEND;

      = dmc$dl_sa_aft_next_dat_change =
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/
        IFEND;
        IF dmv$test_recovery AND NOT recovery THEN
          dat_change_abort := dmc$dat_halt_after_change;
        IFEND;

      = dmc$dl_sa_bef_logging_dtu =
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/
        IFEND;
        IF dmv$test_recovery AND NOT recovery THEN
          recovery_testing_aborts := dmc$dl_halt_before_logging_dtu;
        IFEND;

      = dmc$dl_sa_bef_mf_table_update =
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/
        IFEND;
        IF dmv$test_recovery AND NOT recovery THEN
          recovery_testing_aborts := dmc$dl_halt_before_mf_table_upd;
        IFEND;

      = dmc$dl_sa_aft_mf_table_update =
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/
        IFEND;
        IF dmv$test_recovery AND NOT recovery THEN
          recovery_testing_aborts := dmc$dl_halt_after_mf_table_upd;
        IFEND;

      = dmc$dl_ra_on_dl_entry =
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/
        IFEND;
        IF dmv$test_recovery AND recovery THEN
          osp$fatal_system_error ('HALT FOR RECOVERY TEST', NIL);
        IFEND;

      = dmc$dl_ra_after_process_dl =
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/
        IFEND;
        IF dmv$test_recovery AND recovery THEN
          halt_after_processing_dl := TRUE;
        IFEND;

      = dmc$dl_ra_bef_next_dfl_change =
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/
        IFEND;
        IF dmv$test_recovery AND recovery THEN
          dfl_change_abort := dmc$dfl_halt_before_change;
        IFEND;

      = dmc$dl_ra_aft_next_dfl_change =
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/
        IFEND;
        IF dmv$test_recovery AND recovery THEN
          dfl_change_abort := dmc$dfl_halt_after_change;
        IFEND;

      = dmc$dl_ra_bef_next_dat_change =
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/
        IFEND;
        IF dmv$test_recovery AND recovery THEN
          dat_change_abort := dmc$dat_halt_before_change;
        IFEND;

      = dmc$dl_ra_aft_next_dat_change =
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/
        IFEND;
        IF dmv$test_recovery AND recovery THEN
          dat_change_abort := dmc$dat_halt_after_change;
        IFEND;

      = dmc$dl_ra_bef_logging_dtu =
        NEXT p_check_byte IN device_log;
        IF p_check_byte^ <> device_log_check_byte THEN
          normal_exit := FALSE;
          EXIT /process_log/
        IFEND;

        IF dmv$test_recovery AND recovery THEN
          recovery_testing_aborts := dmc$dl_halt_before_logging_dtu;
        IFEND;

      = dmc$invalid_dl_entry =
        normal_exit := FALSE;
        EXIT /process_log/;

      ELSE
        normal_exit := FALSE;
        EXIT /process_log/;

      CASEND;
      NEXT p_entry_kind IN device_log;

    WHILEND /process_log/;

    IF NOT normal_exit THEN
      IF (NOT production_logging AND osv$recover_at_all_costs) OR
            cmv$post_deadstart THEN
        RETURN;
      IFEND;
      STRINGREP (msg, msg_length, recorded_vsn, ' invalid log entry');
      osp$fatal_system_error (msg, NIL);
    IFEND;

    IF dmv$recycle_device_log AND normal_exit AND production_logging THEN
       recycle_device_log (avt_index, login_table_sfid, login_index, p_entry_kind, device_log, local_status);
      IF NOT local_status.normal THEN
        osp$fatal_system_error ('recycle device log failed - DMMLOG', ^local_status);
      IFEND;
    IFEND;

    IF halt_after_processing_dl THEN
      osp$fatal_system_error ('HALT FOR RECOVERY TEST', NIL);
    IFEND;

  PROCEND process_device_log;
?? TITLE := '  process_dfl_change_error', EJECT ??

 PROCEDURE process_dfl_change_error (avt_index: dmt$active_volume_table_index;
       dfl_change: dmt$dfl_change;
       dfl_entry: dmt$ms_device_file_list_entry;
       recovery_logging: boolean);

   VAR
     error_count: integer,
     error_index: integer,
     list_lower: integer,
     list_length: integer,
     dfl_change_error: dmt$dfl_change_error;

   list_lower := LOWERBOUND (dmv$dfl_change_errors.error_list);
   list_length := UPPERBOUND (dmv$dfl_change_errors.error_list) - list_lower + 1;

   dfl_change_error.avt_index := avt_index;
   dfl_change_error.recovery_logging := recovery_logging;
   dfl_change_error.dfl_change := dfl_change;
   dfl_change_error.dfl_entry := dfl_entry;
   dfl_change_error.time := #free_running_clock (0);

   osp$increment_locked_variable (dmv$dfl_change_errors.error_count, 0, error_count);
   error_index := ((error_count - 1) MOD list_length) + list_lower;
   dmv$dfl_change_errors.error_list [error_index] := dfl_change_error;

   IF (dmc$debug_dfl_changes IN dmv$debug_options) THEN
     IF NOT (recovery_logging AND osv$recover_at_all_costs) THEN
       osp$fatal_system_error ('Invalid DFL change.', NIL);
     IFEND;
   IFEND;
 PROCEND process_dfl_change_error;
?? TITLE := '  process_dfl_changes', EJECT ??

  PROCEDURE process_dfl_changes (p_dfl: ^dmt$ms_device_file_list_table;
                                 avt_index: dmt$active_volume_table_index;
                                 number_dfl_changes: integer;
                                 recovery_logging: boolean;
                             VAR p_dfl_changes: ^dmt$dfl_changes;
                             VAR status: ost$status);

?? SKIP := 1 ??
    PROCEDURE handler (mf: ost$monitor_fault;
                       p_msa: ^ost$minimum_save_area;
                   VAR continue: syt$continue_option);
      VAR
        p_scc: ^syt$system_core_condition,
        p_sac: ^mmt$segment_access_condition;

      IF mf.identifier = mmc$segment_fault_processor_id THEN
        p_sac := #LOC(mf.contents);
        CASE p_sac^.identifier OF
        = mmc$sac_io_read_error =
          osp$set_status_abnormal ('MM', mme$io_read_error,
             'io error - process_dfl_changes', status);
          EXIT process_dfl_changes;
        ELSE
        CASEND;

      ELSEIF mf.identifier = syc$system_core_condition THEN
        p_scc := #LOC(mf.system_core_condition);
        CASE p_scc^.condition OF
        = syc$user_defined_condition =
          IF p_scc^.user_defined_condition = syc$udc_volume_unavailable THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable,
                'volume unavailable in process_dfl_changes', status);
            EXIT process_dfl_changes;
          IFEND;
        ELSE
        CASEND;
      IFEND;

      syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);

    PROCEND handler;
?? SKIP := 1 ??

    VAR
      i: dmt$dfl_change_index,
      dfl_change: dmt$dfl_change;

    status.normal := TRUE;

    IF (p_dfl_changes = NIL) OR (number_dfl_changes = 0) THEN
      RETURN;
    IFEND;

    syp$establish_condition_handler (^handler);

  /process_the_changes/
    FOR i := 1 TO number_dfl_changes DO

      dfl_change := p_dfl_changes^ [i];

      IF (dfl_change.dfl_index < 1) OR (dfl_change.dfl_index > p_dfl^.header.number_of_entries) THEN
        process_dfl_change_error (avt_index, dfl_change, p_dfl^.entries [1], recovery_logging);
        CYCLE /process_the_changes/;
      IFEND;

      CASE dfl_change.kind OF

      = dmc$dfl_create =
        do_dfl_create (p_dfl, dfl_change, avt_index, recovery_logging);

      = dmc$dfl_return_dfl =
        do_dfl_return_dfl (p_dfl, dfl_change, avt_index, recovery_logging);

      = dmc$dfl_first_dau =
        do_dfl_first_dau (p_dfl, dfl_change, avt_index, recovery_logging);

      = dmc$dfl_release_dfl =
        do_dfl_release_dfl (p_dfl, dfl_change, avt_index, recovery_logging);

      = dmc$dfl_attach_file =
        do_dfl_attach_file (p_dfl, dfl_change, avt_index, recovery_logging);

      = dmc$dfl_detach_file =
        do_dfl_detach_file (p_dfl, dfl_change, avt_index, recovery_logging);

      = dmc$dfl_update_file_length =
        do_dfl_update_file_length (p_dfl, dfl_change, avt_index, recovery_logging);

      = dmc$dfl_update_fmd_length =
        do_dfl_update_fmd_length (p_dfl, dfl_change, avt_index, recovery_logging);

      = dmc$dfl_file_damaged =
        do_dfl_file_damaged (p_dfl, dfl_change, avt_index, recovery_logging);

      = dmc$dfl_halt =
        osp$fatal_system_error ('HALT FOR RECOVERY TEST', NIL);


      ELSE
        osp$fatal_system_error ('Invalid DFL change.', NIL);
      CASEND;

    FOREND /process_the_changes/;

    syp$disestablish_cond_handler;

    mmp$write_modified_pages (p_dfl, #SIZE (p_dfl^), osc$wait, status);
    IF NOT status.normal THEN
      IF osp$file_access_condition (status) THEN
        status.normal := TRUE;
      IFEND;
    IFEND;

    IF p_dfl_changes <> NIL THEN
      FREE p_dfl_changes IN osv$mainframe_pageable_heap^;
    IFEND;

  PROCEND process_dfl_changes;
?? TITLE := '   recycle_device_log', EJECT ??

  PROCEDURE recycle_device_log (avt_index: dmt$active_volume_table_index;
        login_table_sfid: dmt$system_file_id;
        log_in_index: dmt$login_table_entry_index;
        p_last_processed_entry: ^dmt$dl_entry_kind;
    VAR device_log: dmt$device_log;
    VAR status: ost$status);

    VAR
      production_log: boolean,
      login_table: ^dmt$ms_mainframe_login_table,
      current_position: integer,
      p_last_last: ^dmt$dl_entry_kind,
      move_length: integer,
      entry_kind: ^dmt$dl_entry_kind;

    status.normal := TRUE;
    dmp$open_login_table (login_table_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend,
          mmc$as_sequential, login_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (dmv$p_active_volume_table^ [avt_index].mass_storage.logging_lock);
    current_position := dmv$p_active_volume_table^ [avt_index].mass_storage.current_position_offset_in_log;

    p_last_last := #address (#ring(device_log), #segment(device_log),
                             login_table^.body [log_in_index].last_last_update_offset);

    IF #offset(p_last_last) > (current_position - #offset(p_last_last) + 3) THEN
      dmv$recycled_log := dmv$recycled_log + 1;
    ELSE
      dmv$skipped_recycle_of_log := dmv$skipped_recycle_of_log + 1;
      osp$clear_mainframe_sig_lock (dmv$p_active_volume_table^ [avt_index].mass_storage.logging_lock);
      dmp$close_file (login_table, status);
      RETURN;
    IFEND;

    move_length := current_position - #offset(p_last_last);
    i#move (p_last_last, device_log, move_length);

    entry_kind := #address (#ring (device_log), #segment (device_log), move_length);
    RESET device_log TO entry_kind;
    NEXT entry_kind IN device_log;
    entry_kind^ := dmc$invalid_dl_entry;

    production_log := (login_table^.body [log_in_index].recovery_status <> dmc$lt_recovering);
    IF production_log THEN
      mmp$write_modified_pages (device_log, move_length, osc$wait, status);
    IFEND;

    login_table^.body [log_in_index].last_last_update_offset := 0;
    login_table^.body [log_in_index].last_update_offset := #offset(p_last_processed_entry) -
                                                           #offset(p_last_last);
    mmp$write_modified_pages (login_table, #SIZE (login_table^), osc$wait, status);
    IF osp$file_access_condition (status) THEN
      status.normal := TRUE;
    IFEND;
    NEXT entry_kind IN device_log;
    dmp$set_eoi (dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log,
      #offset (entry_kind), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    mmp$free_pages (entry_kind, 7fffffff(16), osc$wait, status);

    dmv$p_active_volume_table^ [avt_index].mass_storage.current_position_offset_in_log := move_length;
    osp$clear_mainframe_sig_lock (dmv$p_active_volume_table^ [avt_index].mass_storage.logging_lock);
    dmp$close_file (login_table, status);

  PROCEND  recycle_device_log;

?? EJECT, TITLE := 'release_file_daus' ??
{  This procedure releases DAUs (logs a dmc$dl_release_dau) sequentially by DAU linkage until the
{ number of log entries generated is equal to a pre-defined constant.  It then logs (if need be)
{ a purge 'continuation' which will be processed in the next logger cycle.
{
{  This effectively causes large files (as defined by the constant) to have their file space returned
{ incrementally and giving the logger a breather occassionally when asked to purge a large subfile.
{ This code will 1) reduce the amount of space required by the device log, 2) lessen the 'console
{ freeze' problem when the logger is sorting a large number of DAT changes, and 3) cause more time
{ (logger cycles) to be required in order to reclaim disk space.
{
{  Validation is performed on each DAU of the allocation chain to protect against damage to the
{ file system.  If invalid information is found, the condition is logged as a DAT Change Error.
{ The index field of the DAT Change Error is set to its maximum value to distinguish the error
{ from a normal DAT Change Error.

  PROCEDURE release_file_daus
    (    release_dau_block: dmt$dl_release_dau_block; {MUST BE complete release_dau entry
         production_logging: boolean;
         avt_index: dmt$active_volume_table_index;
         device_log: dmt$device_log;
         login_table_sfid: dmt$system_file_id;
         p_dat: ^dmt$ms_device_allocation_table;
     VAR current_position_in_log: integer;
     VAR status: ost$status);

?? SKIP := 1 ??
    PROCEDURE handler (mf: ost$monitor_fault;
                       p_msa: ^ost$minimum_save_area;
                   VAR continue: syt$continue_option);
      VAR
        p_scc: ^syt$system_core_condition,
        p_sac: ^mmt$segment_access_condition;

      IF mf.identifier = mmc$segment_fault_processor_id THEN
        p_sac := #LOC(mf.contents);
        CASE p_sac^.identifier OF
        = mmc$sac_io_read_error =
          osp$set_status_abnormal ('MM', mme$io_read_error,
             'io error - release_file_daus', status);
          EXIT release_file_daus;
        ELSE
        CASEND;

      ELSEIF mf.identifier = syc$system_core_condition THEN
        p_scc := #LOC(mf.system_core_condition);
        CASE p_scc^.condition OF
        = syc$user_defined_condition =
          IF p_scc^.user_defined_condition = syc$udc_volume_unavailable THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable,
                'volume unavailable in release_file_daus', status);
            EXIT release_file_daus;
          IFEND;
        ELSE
        CASEND;
      IFEND;

      syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);

    PROCEND handler;
?? SKIP := 1 ??

    VAR
      count: integer,
      dat_change: dmt$dat_change,
      dau: dmt$dau_address,
      dau_count: dmt$dau_address,
      dau_entry: dmt$ms_device_allocation_unit,
      daus_per_allocation: dmt$daus_per_allocation,
      dfl_index: dmt$device_file_list_index,
      file_hash: dmt$file_hash,
      first_dau: dmt$dau_address,
      last_dau: dmt$dau_address,
      log_entry: dmt$dl_entry,
      login_index: dmt$login_table_entry_index,
      more_aus: boolean,
      ok: boolean;

    status.normal := TRUE;

    count := 0;
    more_aus := TRUE;
    log_entry.kind := dmc$dl_release_dau;
    log_entry.release_dau_block := release_dau_block;
    daus_per_allocation := release_dau_block.daus_per_allocation;
    login_index := release_dau_block.mainframe_assigned.log_in_index;
    dfl_index := release_dau_block.dfl_index;

    dmp$generate_gfn_hash (release_dau_block.global_file_name, file_hash);

    syp$establish_condition_handler (^handler);

    dau_count := p_dat^.header.number_of_entries;

    { validate DAU address.

    IF ((release_dau_block.dau_address + daus_per_allocation) > dau_count) THEN
      dat_change.dau_address := release_dau_block.dau_address;
      dat_change.index := UPPERVALUE (dat_change.index);
      dat_change.kind := dmc$dat_release_dau;
      dat_change.release_dau_block := release_dau_block;
      process_dat_change_error (avt_index, dat_change, 0, p_dat^.body [0], NOT production_logging);
      more_aus := FALSE;
    IFEND;

    WHILE more_aus DO

      { Validate allocation unit.

      first_dau := log_entry.release_dau_block.dau_address;
      last_dau := first_dau + daus_per_allocation - 1;

    /validate_allocation_unit/
      FOR dau := first_dau TO last_dau DO
        dau_entry := p_dat^.body [dau];
        ok := valid_file_dau (dfl_index, file_hash, dau_entry);
        IF NOT ok THEN
          dat_change.dau_address := first_dau;
          dat_change.index := UPPERVALUE (dat_change.index);
          dat_change.kind := dmc$dat_release_dau;
          dat_change.release_dau_block := log_entry.release_dau_block;
          process_dat_change_error (avt_index, dat_change, dau, dau_entry, NOT production_logging);
          more_aus := FALSE;
          EXIT /validate_allocation_unit/;
        IFEND;
      FOREND /validate_allocation_unit/;

      { Create log entry to release allocation unit.

      IF ok THEN
        IF production_logging THEN
          lock_log_and_insert_entry (log_entry, avt_index, device_log, status);
        ELSE
          insert_dl_entry (login_table_sfid, login_index, log_entry, device_log, current_position_in_log,
                status);
        IFEND;
        IF NOT status.normal THEN
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'Unable to process release_dau log entry - release_file_daus.', status);
          ok := FALSE;
        IFEND;
      IFEND;

      { Determine next allocation unit.

      dau_entry := p_dat^.body [first_dau];
      more_aus := ok AND ((dau_entry.allocation_chain_position = dmc$first_allocation) OR
                  (dau_entry.allocation_chain_position = dmc$middle_allocation));

      IF more_aus THEN
        IF ((dau_entry.next_allocation_unit_dau + daus_per_allocation) > dau_count) THEN
          more_aus := FALSE;
          dat_change.dau_address := first_dau;
          dat_change.index := UPPERVALUE (dat_change.index);
          dat_change.kind := dmc$dat_release_dau;
          dat_change.release_dau_block := log_entry.release_dau_block;
          process_dat_change_error (avt_index, dat_change, first_dau, dau_entry, NOT production_logging);
        ELSE
          log_entry.release_dau_block.dau_address := dau_entry.next_allocation_unit_dau;
          count := count + 1;
          IF (count >= dmv$continue_purge_limit) THEN
            more_aus := FALSE;

            { Create log entry to continue purge.

            log_entry.kind := dmc$dl_continue_purge;
            IF production_logging THEN
              lock_log_and_insert_entry (log_entry, avt_index, device_log, status);
            ELSE
              insert_dl_entry (login_table_sfid, login_index, log_entry, device_log,
                    current_position_in_log, status);
            IFEND;
            IF NOT status.normal THEN
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    'Continue purge failure - release_file_daus.', status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    WHILEND;

    syp$disestablish_cond_handler;

  PROCEND release_file_daus;
?? TITLE := '  sort_dat_changes', EJECT ??

  PROCEDURE sort_dat_changes (p_dat_changes: ^dmt$dat_changes;
        dat_change_count: integer);

    VAR
      gap: integer,
      start: integer,
      current: integer,
      dat_change: dmt$dat_change;

    dmv$running_total_sorts := dmv$running_total_sorts + 1;
    dmv$running_total_entries := dmv$running_total_entries + dat_change_count;

    IF (dat_change_count > dmv$max_sorted_entries) THEN
      dmv$max_sorted_entries := dat_change_count;
    IFEND;

    IF (dat_change_count < dmv$min_sorted_entries) THEN
      dmv$min_sorted_entries := dat_change_count;
    IFEND;

    { Use shell sort technique. }

    gap := dat_change_count;
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := 1 TO dat_change_count - gap DO
        current := start;

        { WHILE (current > 0) AND (key [current] > key [current + gap]) DO

        WHILE (current > 0) AND ((p_dat_changes^ [current].dau_address > p_dat_changes^ [current + gap].
              dau_address) OR ((p_dat_changes^ [current].dau_address = p_dat_changes^ [current + gap].
              dau_address) AND (p_dat_changes^ [current].index > p_dat_changes^ [current + gap].index))) DO
          dmv$running_total_iterations := dmv$running_total_iterations + 1;
          dat_change := p_dat_changes^ [current];
          p_dat_changes^ [current] := p_dat_changes^ [current + gap];
          p_dat_changes^ [current + gap] := dat_change;
          current := current - gap;
        WHILEND;
      FOREND;
    WHILEND;

  PROCEND sort_dat_changes;
?? TITLE := '  update_volume_tables', EJECT ??
  PROCEDURE update_volume_tables (avt_index: dmt$active_volume_table_index;
                              VAR status: ost$status);

    VAR
      info: dmt$avt_logging_info,
      recovery_logging: boolean,
      current_log_position: integer,
      p_dat: ^dmt$ms_device_allocation_table,
      p_dfl: ^dmt$ms_device_file_list_table,
      able: boolean,
      log_entry: dmt$dl_entry,
      device_log: dmt$device_log,
      p_dat_changes: ^dmt$dat_changes,
      p_dfl_changes: ^dmt$dfl_changes,
      number_dat_changes: integer,
      number_dfl_changes: integer,
      avt_entry_found: boolean,
      local_status: ost$status,
      recovery_testing_aborts: dmt$dl_recovery_testing_aborts;

    status.normal := TRUE;
    p_dat_changes := NIL;
    p_dfl_changes := NIL;
    number_dfl_changes := 0;
    number_dat_changes := 0;
    current_log_position := 0;

    IF dmv$test_recovery AND (dmc$table_update_inhibited IN dmv$p_active_volume_table^ [avt_index].
          mass_storage.disk_table_status) THEN
      RETURN;
    IFEND;

{     split of the allocation log is ok even if the volume is unavailable (or logging_process_damaged)
{     as modified pages are not written out

    dmp$split_allocation_log (FALSE, status);
    IF NOT status.normal THEN
      osp$fatal_system_error ('split allocation log failure - update_volume_tables', ^status);
    IFEND;

    dmp$get_avt_logging_info (avt_index, info, avt_entry_found);
    IF NOT avt_entry_found THEN
      osp$fatal_system_error ('avt entry not found - update_volume_tables', NIL);
    IFEND;

    IF info.log_entry_count <= dmv$minimum_log_count THEN
      RETURN;
    IFEND;

    IF info.logging_process_damaged THEN  {is never cleared except by deadstart
      down_volume (avt_index, FALSE, status);
      IF NOT status.normal THEN
        osp$fatal_system_error ('unable to down volume (1) - update_volume_tables', ^status);
      IFEND;
      RETURN;
    IFEND;

    dmp$open_dat (info.dat_sfid,
          osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential, p_dat, status);
    IF NOT status.normal THEN
      IF osp$file_access_condition (status) THEN
        status.normal := TRUE;
        RETURN;
      ELSEIF status.condition = mme$io_read_error THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'open_dat failure', status);
        dmv$last_volume_downed_status := status;
        down_volume (avt_index, TRUE, status);
        IF NOT status.normal THEN
          osp$fatal_system_error ('unable to down volume (2) - update_volume_tables', ^status);
        IFEND;
        RETURN;
      ELSE
        osp$fatal_system_error ('unable to open dat - update_volume_tables', ^status);
      IFEND;
    IFEND;

    dmp$open_dflt (info.dfl_sfid,
          osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential, p_dfl, status);
    IF NOT status.normal THEN
      dmp$close_file (p_dat, local_status);
      IF osp$file_access_condition (status) THEN
        status.normal := TRUE;
        RETURN;
      ELSEIF status.condition = mme$io_read_error THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'open_dflt failure', status);
        dmv$last_volume_downed_status := status;
        down_volume (avt_index, TRUE, status);
        IF NOT status.normal THEN
          osp$fatal_system_error ('unable to down volume (3) - update_volume_tables', ^status);
        IFEND;
        RETURN;
      ELSE
        osp$fatal_system_error ('unable to open dflt - update_volume_tables', ^status);
      IFEND;
    IFEND;

    dmp$set_update_lock (avt_index, FALSE, able);
    IF able THEN

      open_device_log (info.device_log_sfid, FALSE, device_log, status);
      IF status.normal THEN
        log_entry.kind := dmc$dl_start_update;
        lock_log_and_insert_entry (log_entry, avt_index, device_log, status);
        IF NOT status.normal THEN
          osp$fatal_system_error ('bad status inserting log entry (s) - update_volume_tables', ^status);
        IFEND;

        log_entry.kind := dmc$dl_last_update_entry;
        lock_log_and_insert_entry (log_entry, avt_index, device_log, status);
        IF status.normal THEN

          osp$set_mainframe_sig_lock (dmv$p_active_volume_table^ [avt_index].mass_storage.logging_lock);
          dmv$p_active_volume_table^ [avt_index].mass_storage.device_log_entry_count := 0;
          osp$clear_mainframe_sig_lock (dmv$p_active_volume_table^ [avt_index].mass_storage.logging_lock);

          process_device_log (avt_index, info.mainframe_assigned, p_dat, p_dfl, info.login_table_sfid,
                device_log, TRUE, p_dat_changes, number_dat_changes, p_dfl_changes,
                number_dfl_changes, recovery_testing_aborts, current_log_position, status);
          IF status.normal THEN

            log_entry.kind := dmc$dl_update_disk_tables;
            lock_log_and_insert_entry (log_entry, avt_index, device_log, status);
            IF NOT status.normal THEN
              osp$fatal_system_error ('table update failure (U) - update_volume_tables', ^status);
            IFEND;

            recovery_logging := FALSE;

            process_dat_changes (p_dat, avt_index, number_dat_changes, recovery_logging,
                                 p_dat_changes, status);
            IF NOT status.normal THEN
              IF (status.condition = mme$io_read_error) OR (status.condition = mme$io_write_error) THEN
                osp$append_status_parameter (osc$status_parameter_delimiter, 'process_dat failure', status);
                dmv$last_volume_downed_status := status;
                down_volume (avt_index, FALSE, local_status);
                IF NOT local_status.normal THEN
                  osp$fatal_system_error ('unable to down volume (4) - update_volume_tables', ^local_status);
                IFEND;
              ELSEIF osp$file_access_condition (status) THEN
                {  fall through
              ELSE
                osp$fatal_system_error ('process_dat_changes failure - update_volume_tables', ^status);
              IFEND;
              dmv$p_active_volume_table^ [avt_index].mass_storage.logging_process_damaged := TRUE;
            IFEND;

            IF status.normal THEN
              process_dfl_changes (p_dfl, avt_index, number_dfl_changes, recovery_logging,
                                   p_dfl_changes, status);
              IF NOT status.normal THEN
                IF (status.condition = mme$io_read_error) OR (status.condition = mme$io_write_error) THEN
                  osp$append_status_parameter(osc$status_parameter_delimiter, 'process_dflt failure', status);
                  dmv$last_volume_downed_status := status;
                  down_volume (avt_index, FALSE, local_status);
                  IF NOT local_status.normal THEN
                    osp$fatal_system_error ('unable to down volume (5) update_volume_tables', ^local_status);
                  IFEND;
                ELSEIF osp$file_access_condition (status) THEN
                  {  fall through
                ELSE
                  osp$fatal_system_error ('process_dfl_changes failure - update_volume_tables', ^status);
                IFEND;
                dmv$p_active_volume_table^ [avt_index].mass_storage.logging_process_damaged := TRUE;
              IFEND;
            IFEND;

            IF recovery_testing_aborts = dmc$dl_halt_before_logging_dtu THEN
              osp$fatal_system_error ('HALT FOR RECOVERY TEST', NIL);
            IFEND;

            IF status.normal THEN
              log_entry.kind := dmc$dl_disk_tables_updated;
              lock_log_and_insert_entry (log_entry, avt_index, device_log, status);
              IF NOT status.normal THEN
                osp$fatal_system_error ('bad status inserting log entry (ud) - update_volume_tables',
                                        ^status);
              IFEND;
            IFEND;

            status.normal := TRUE;

          ELSEIF (status.condition = mme$io_read_error) OR (status.condition = mme$io_write_error) THEN
            osp$append_status_parameter (osc$status_parameter_delimiter, 'process_device_log failure',
                  status);
            dmv$last_volume_downed_status := status;
            down_volume (avt_index, FALSE, local_status);
            IF NOT local_status.normal THEN
              osp$fatal_system_error ('unable to down volume (6) - update_volume_tables', ^local_status);
            IFEND;
            dmv$p_active_volume_table^ [avt_index].mass_storage.logging_process_damaged := TRUE;
            status.normal := TRUE;
          ELSEIF status.condition = dme$volume_unavailable THEN
            dmv$p_active_volume_table^ [avt_index].mass_storage.logging_process_damaged := TRUE;
            status.normal := TRUE;
          ELSE  { process_device_log failure
            osp$fatal_system_error ('process log failure - update_volume_tables', ^status);
          IFEND;

        ELSE    { couldn't insert last_update_entry - unsure if login table written, so damage=yes

          osp$append_status_parameter (osc$status_parameter_delimiter, 'last insertion failure', status);
          dmv$last_volume_downed_status := status;
          down_volume (avt_index, FALSE, local_status);
          IF NOT local_status.normal THEN
            osp$fatal_system_error ('unable to down volume (7) - update_volume_tables', ^local_status);
          IFEND;
          dmv$p_active_volume_table^ [avt_index].mass_storage.logging_process_damaged := TRUE;
          status.normal := TRUE;
        IFEND;

        dmp$close_file (device_log, local_status);

      ELSEIF status.condition = dme$volume_unavailable THEN   { couldn't open device_log
        status.normal := TRUE;
      IFEND;

      dmp$clear_update_lock (avt_index);
    IFEND;

    dmp$close_file (p_dfl, local_status);
    dmp$close_file (p_dat, local_status);

  PROCEND update_volume_tables;
?? TITLE := '  valid_dfl_index', EJECT ??

  FUNCTION [INLINE] valid_dfl_index (dfl_index: dmt$device_file_list_index;
        p_dfl: ^dmt$ms_device_file_list_table): boolean;

    valid_dfl_index := (dfl_index >= LOWERBOUND (p_dfl^.entries)) AND
                       (dfl_index <= UPPERBOUND (p_dfl^.entries));

  FUNCEND valid_dfl_index;
?? TITLE := '  valid_file_dau', EJECT ??

  FUNCTION [INLINE] valid_file_dau (dfl_index: dmt$device_file_list_index;
        file_hash: dmt$file_hash;
        dau_entry: dmt$ms_device_allocation_unit): boolean;

    VAR
      ok: boolean,
      dfl_known: boolean;

    ok := ((dau_entry.dau_status = dmc$dau_assigned_to_file) OR
          (dau_entry.dau_status = dmc$dau_ass_to_file_swr_flawed)) AND
          (dau_entry.file_hash = file_hash);

    IF ok THEN
      dfl_known := (dau_entry.allocation_chain_position = dmc$last_allocation) OR
            (dau_entry.allocation_chain_position = dmc$first_and_last_allocation);
      ok := NOT dfl_known OR (dfl_index =
            (dau_entry.high_dfl_index * dmc$dfl_index_converter + dau_entry.low_dfl_index));
    IFEND;

    valid_file_dau := ok;
  FUNCEND valid_file_dau;
?? TITLE := '  valid_file_dfl', EJECT ??

  FUNCTION [INLINE] valid_file_dfl (gfn: dmt$global_file_name;
        dfl_entry: dmt$ms_device_file_list_entry): boolean;

    valid_file_dfl := (dfl_entry.flags = dmc$dfle_assigned_to_file) AND
          (dfl_entry.global_file_name = gfn);

  FUNCEND valid_file_dfl;
?? TITLE := '  valid_mainframe_dau', EJECT ??

  FUNCTION [INLINE] valid_mainframe_dau (mainframe: dmt$mainframe_assigned;
        dau_entry: dmt$ms_device_allocation_unit): boolean;

    valid_mainframe_dau := ((dau_entry.dau_status = dmc$dau_assigned_to_mainframe) OR
          (dau_entry.dau_status = dmc$dau_ass_to_mf_swr_flawed)) AND
          (dau_entry.mainframe_id = mainframe);

  FUNCEND valid_mainframe_dau;
?? TITLE := '  valid_mainframe_dfl', EJECT ??

  FUNCTION [INLINE] valid_mainframe_dfl (mainframe: dmt$mainframe_assigned;
        dfl_entry: dmt$ms_device_file_list_entry): boolean;

    valid_mainframe_dfl := (dfl_entry.flags = dmc$dfle_assigned_to_mainframe) AND
          (dfl_entry.mainframe_assigned = mainframe);

  FUNCEND valid_mainframe_dfl;

MODEND dmm$logger;

*DECK DECK=DMM$LOG_TESTING_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$log_testing_commands ALIAS 'DMMLTST';
{ PURPOSE:
{
{
{ DESIGN:
{
{

?? PUSH (LISTEXT := ON) ??
?? TITLE := '  Declarations', EJECT ??
*copyc DMT$ERROR_CONDITION_CODES
*copyc DMT$DEVICE_LOG_ENTRIES
*copyc DMT$SYSTEM_FILE_ID
*copyc RMD$VOLUME_DECLARATIONS
*copyc OST$STATUS
?? POP ??
?? TITLE := '  XREF Procedures', EJECT ??
*copyc DMP$SEARCH_ACTIVE_VOLUME_TABLE
*copyc DMP$PROCESS_DEVICE_LOG_ENTRY
*copyc OSP$SET_STATUS_ABNORMAL
?? TITLE := '  XREF Variables', EJECT ??
*copyc DMV$NULL_SFID

  VAR
    dmv$system_abort_log_entries: array [dmt$system_abort_log_positions] of dmt$system_log_aborts :=
      [$dmt$system_log_aborts [dmc$dl_sa_on_dl_entry, dmc$dl_sa_after_process_dl], $dmt$system_log_aborts
      [dmc$dl_sa_bef_next_dfl_change, dmc$dl_sa_aft_next_dfl_change, dmc$dl_sa_bef_next_dat_change,
      dmc$dl_sa_aft_next_dat_change, dmc$dl_sa_bef_logging_dtu], $dmt$system_log_aborts
      [dmc$dl_sa_bef_mf_table_update, dmc$dl_sa_aft_mf_table_update], $dmt$system_log_aborts []],
    dmv$recovery_abort_log_entries: ARRAY [dmt$recovry_abort_log_positions] of dmt$recovery_log_aborts :=
      [$dmt$recovery_log_aborts [dmc$dl_ra_on_dl_entry, dmc$dl_ra_after_process_dl], $dmt$recovery_log_aborts
      [dmc$dl_ra_bef_next_dfl_change, dmc$dl_ra_aft_next_dfl_change, dmc$dl_ra_bef_next_dat_change,
      dmc$dl_ra_aft_next_dat_change, dmc$dl_ra_bef_logging_dtu], $dmt$recovery_log_aborts [],
      $dmt$recovery_log_aborts []];

?? TITLE := '  dmp$create_volume_log_entry', EJECT ??

  PROCEDURE [XDCL] dmp$create_volume_log_entry ALIAS 'dmxcvle' (log_entry_type: dmt$dl_entry_kind;
        sfid: dmt$system_file_id;
    VAR log_entry: dmt$dl_entry;
    VAR status: ost$status);

    status.normal := TRUE;

    log_entry.kind := dmc$invalid_dl_entry;

    IF (sfid <> dmv$null_sfid) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_device_log_kind,
        'sfid processing unsupported - DMMLTST', status);
      RETURN;
    IFEND;

    CASE log_entry_type OF

    = dmc$dl_sa_on_dl_entry =
      log_entry.kind := log_entry_type;

    = dmc$dl_sa_after_process_dl =
      log_entry.kind := log_entry_type;

    = dmc$dl_sa_bef_next_dfl_change =
      log_entry.kind := log_entry_type;

    = dmc$dl_sa_aft_next_dfl_change =
      log_entry.kind := log_entry_type;

    = dmc$dl_sa_bef_next_dat_change =
      log_entry.kind := log_entry_type;

    = dmc$dl_sa_aft_next_dat_change =
      log_entry.kind := log_entry_type;

    = dmc$dl_sa_bef_logging_dtu =
      log_entry.kind := log_entry_type;

    = dmc$dl_sa_bef_mf_table_update =
      log_entry.kind := log_entry_type;

    = dmc$dl_sa_aft_mf_table_update =
      log_entry.kind := log_entry_type;

    = dmc$dl_ra_on_dl_entry =
      log_entry.kind := log_entry_type;

    = dmc$dl_ra_after_process_dl =
      log_entry.kind := log_entry_type;

    = dmc$dl_ra_bef_next_dfl_change =
      log_entry.kind := log_entry_type;

    = dmc$dl_ra_aft_next_dfl_change =
      log_entry.kind := log_entry_type;

    = dmc$dl_ra_bef_next_dat_change =
      log_entry.kind := log_entry_type;

    = dmc$dl_ra_aft_next_dat_change =
      log_entry.kind := log_entry_type;

    = dmc$dl_ra_bef_logging_dtu =
      log_entry.kind := log_entry_type;

    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_device_log_kind,
        'illegal log entry type - DMMLTST', status);
      RETURN;

    CASEND;
  PROCEND dmp$create_volume_log_entry;
?? TITLE := '  dmp$insert_volume_log_entry', EJECT ??

  PROCEDURE [XDCL] dmp$insert_volume_log_entry ALIAS 'dmxivle' (recorded_vsn: rmt$recorded_vsn;
        log_entry: dmt$dl_entry;
    VAR status: ost$status);

    VAR
      search_key: dmt$avt_search_key,
      avt_index: dmt$active_volume_table_index,
      vsn_not_active: boolean;

    search_key.value := dmc$search_avt_by_rec_vsn;
    search_key.recorded_vsn := recorded_vsn;

    dmp$search_active_volume_table (search_key, avt_index, vsn_not_active);
    IF vsn_not_active THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_avt_entry,
        'vsn not active _ DMMLTST', status);
      RETURN;
    IFEND;
    dmp$process_device_log_entry (avt_index, log_entry, status);

  PROCEND dmp$insert_volume_log_entry;
?? TITLE := '  dmp$get_logging_abort_positions', EJECT ??

  PROCEDURE [XDCL] dmp$get_logging_abort_positions ALIAS 'dmxglap' (abort_type: dmt$abort_log_types;
    VAR number_of_abort_positions: integer;
    VAR abort_positions: array [ * ] OF dmt$abort_log_positions;
    VAR status: ost$status);

    VAR
      index: integer,
      system_position_abort: dmt$system_abort_log_positions,
      recovery_position_abort: dmt$recovry_abort_log_positions;

    status.normal := TRUE;

    CASE abort_type OF

    = dmc$system_abort =
      system_position_abort := LOWERVALUE (dmt$system_abort_log_positions);

    /get_system_abort_positions/
      FOR index := LOWERBOUND (abort_positions) TO UPPERBOUND (abort_positions) DO
        abort_positions [index] := system_position_abort;
        IF (UPPERVALUE (dmt$system_abort_log_positions) = system_position_abort) THEN
          EXIT /get_system_abort_positions/;
        IFEND;
        system_position_abort := SUCC (system_position_abort);
      FOREND /get_system_abort_positions/;

      number_of_abort_positions := (ORD (UPPERVALUE (dmt$system_abort_log_positions)) - ORD (LOWERVALUE
            (dmt$system_abort_log_positions))) + 1;

    = dmc$recovery_abort =

      recovery_position_abort := LOWERVALUE (dmt$recovry_abort_log_positions);

    /get_recovery_abort_positions/
      FOR index := LOWERBOUND (abort_positions) TO UPPERBOUND (abort_positions) DO
        abort_positions [index] := recovery_position_abort;
        IF (UPPERVALUE (dmt$recovry_abort_log_positions) = recovery_position_abort) THEN
          EXIT /get_recovery_abort_positions/;
        IFEND;
        recovery_position_abort := SUCC (recovery_position_abort);
      FOREND /get_recovery_abort_positions/;

      number_of_abort_positions := (ORD (UPPERVALUE (dmt$recovry_abort_log_positions)) - ORD (LOWERVALUE
            (dmt$recovry_abort_log_positions))) + 1;

    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_device_log_kind,
        'unsupported log abort type - DMMLTST', status);
      RETURN;
    CASEND;

  PROCEND dmp$get_logging_abort_positions;
?? TITLE := '  dmp$get_logging_abort_entries', EJECT ??

  PROCEDURE [XDCL] dmp$get_logging_abort_entries ALIAS 'dmxglae' (abort_location: dmt$log_abort;
    VAR number_of_abort_log_entries: integer;
    VAR abort_log_entries: array [ * ] OF dmt$dl_entry_kind;
    VAR status: ost$status);

    VAR
      abort_type: dmt$abort_log_types,
      abort_position: dmt$abort_log_positions,
      abort_dl_entry: dmt$dl_entry_kind,
      index: integer;

    status.normal := TRUE;

    number_of_abort_log_entries := 0;

    CASE abort_location.abort OF

    = dmc$system_abort =
      abort_type := abort_location.abort;

    = dmc$recovery_abort =
      abort_type := abort_location.abort;

    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_device_log_kind,
        'unsupported log abort type - DMMLTST', status);
      RETURN;
    CASEND;

    index := LOWERBOUND (abort_log_entries);

    CASE abort_type OF

    = dmc$system_abort =
      abort_position := abort_location.system_abort_position;
      FOR abort_dl_entry := LOWERVALUE (dmt$system_abort_log_entries) TO UPPERVALUE
            (dmt$system_abort_log_entries) DO
        IF (abort_dl_entry IN dmv$system_abort_log_entries [abort_position]) THEN
          number_of_abort_log_entries := number_of_abort_log_entries + 1;
          IF (index <= UPPERBOUND (abort_log_entries)) THEN
            abort_log_entries [index] := abort_dl_entry;
            index := index + 1;
          IFEND;
        IFEND;
      FOREND;

    = dmc$recovery_abort =
      FOR abort_dl_entry := LOWERVALUE (dmt$recovery_abort_log_entries) TO UPPERVALUE
            (dmt$recovery_abort_log_entries) DO
        IF (abort_dl_entry IN dmv$recovery_abort_log_entries [abort_position]) THEN
          number_of_abort_log_entries := number_of_abort_log_entries + 1;
          IF (index <= UPPERBOUND (abort_log_entries)) THEN
            abort_log_entries [index] := abort_dl_entry;
            index := index + 1;
          IFEND;
        IFEND;
      FOREND;

    CASEND;

  PROCEND dmp$get_logging_abort_entries;

MODEND dmm$log_testing_commands;
*DECK DECK=DMM$MAINFRAME_FILE_LIST_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$mainframe_file_list_manager;

{ PURPOSE:
{
{   The purpose of this module is to manage access to the mainframe file list
{ (MFL).  This includes creating the MFL, deleting it and assigning entires
{ from it.
{
{ DESIGN:
{
{   The MFL consists of an array of word aligned integers.  Each entry contains
{ a Device File List (DFL) index that is available to be assigned, or zero if
{ the MFL entry is empty.  Compare swap locking is used to take available DFL
{ indicies from the table and replace them with the zero flag.  When the table
{ is empty, it is filled by the space management task.
?? PUSH (LISTEXT := ON) ??
?? TITLE := '  Common Decks', EJECT ??
*copyc cyd$cybil_structure_definitions
*copyc dmp$get_mfl_pointer
*copyc dmp$lock_avt_entry
*copyc dmp$unlock_avt_entry
*copyc dmt$active_volume_table_index
*copyc dmt$device_file_list_index
*copyc dmt$error_condition_codes
*copyc dmt$mainframe_device_file_list
*copyc dmv$active_volume_table
*copyc osp$fetch_locked_variable
*copyc osp$set_locked_variable
*copyc osp$system_error
*copyc ost$status
*copyc osv$mainframe_pageable_heap
*copyc osv$mainframe_wired_heap
*copyc pmp$delay
*copyc tmp$ready_system_task1
?? POP ??
?? TITLE := '  Global Definitions', EJECT ??
    TYPE
      converter_type = record
        case boolean of
        = FALSE =
          p_adaptable: cyt$adaptable_array_pointer,
        = TRUE =
          p_mfl: ^dmt$ms_mf_device_file_list,
        casend,
      recend;
?? TITLE := '  dmp$create_mfl', EJECT ??

  PROCEDURE [XDCL] dmp$create_mfl (
    VAR p_mfl: cyt$adaptable_array_pointer);

    VAR
      converter: converter_type,
      index: dmt$ms_mf_device_file_list_ord;

    ALLOCATE converter.p_mfl: [1 .. dmc$cm_dflt_entries] IN osv$mainframe_pageable_heap^;

    FOR index := 1 TO UPPERBOUND (converter.p_mfl^) DO
      converter.p_mfl^ [index].ordinal := 0;
    FOREND;

    p_mfl := converter.p_adaptable;
  PROCEND dmp$create_mfl;
?? TITLE := '  dmp$delete_mfl', EJECT ??

  PROCEDURE [XDCL] dmp$delete_mfl (
    VAR p_mfl {input, output} : cyt$adaptable_array_pointer);

    VAR
      converter: converter_type;

    converter.p_adaptable := p_mfl;
    IF (converter.p_mfl <> NIL) THEN
      FREE converter.p_mfl IN osv$mainframe_pageable_heap^;
      p_mfl := converter.p_adaptable;
    IFEND;
  PROCEND dmp$delete_mfl;
?? TITLE := '  dmp$get_unused_mfl_entry', EJECT ??

  PROCEDURE [XDCL] dmp$get_unused_mfl_entry (avt_index: dmt$active_volume_table_index;
    VAR dfl_ordinal: dmt$device_file_list_index;
    VAR status: ost$status);

    VAR
      mf_file_list_index: dmt$ms_mf_device_file_list_ord,
      current_value: integer,
      actual: integer,
      successful: boolean,
      dflt_table_status: dmt$ms_volume_table_status,
      able_to_lock_avt_entry: boolean,
      able_to_unlock_avt_entry: boolean,
      p_mfl: ^dmt$ms_mf_device_file_list;

    status.normal := TRUE;

    dmp$get_mfl_pointer (avt_index, p_mfl);
    IF p_mfl = NIL THEN
      osp$system_error ('NIL pointer to mfl - dmp$get_unused_mfl_entry', NIL);
    IFEND;

    WHILE TRUE DO

      FOR mf_file_list_index := 1 TO UPPERBOUND (p_mfl^) DO

        osp$fetch_locked_variable (p_mfl^ [mf_file_list_index].ordinal, current_value);

        IF current_value <> 0 THEN
          osp$set_locked_variable (p_mfl^ [mf_file_list_index].ordinal, current_value, 0, actual,
              successful);
          IF successful THEN
            dfl_ordinal := current_value;
            RETURN;
          IFEND;
        IFEND;

      FOREND;

      dflt_table_status := $dmt$ms_volume_table_status [dmc$dflt_update_required];

      dmp$lock_avt_entry (avt_index, able_to_lock_avt_entry);
      IF able_to_lock_avt_entry THEN
        dmv$p_active_volume_table^ [avt_index].mass_storage.disk_table_status := dmv$p_active_volume_table^
              [avt_index].mass_storage.disk_table_status + dflt_table_status;
        dmp$unlock_avt_entry (avt_index, able_to_unlock_avt_entry);
        IF NOT able_to_unlock_avt_entry THEN
          osp$system_error ('unable to unlock avt entry - dmp$get_unused_mfl_entry', NIL);
        IFEND;

        tmp$ready_system_task (tmc$stid_volume_space_managemnt, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      pmp$delay (4000, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    WHILEND;

  PROCEND dmp$get_unused_mfl_entry;

MODEND dmm$mainframe_file_list_manager;
*DECK DECK=DMM$MONITOR_ALLOCATOR EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$monitor_allocator;

{
{ PURPOSE:
{
{   This module is responsible for allocating backing store to a segment.
{
{ DESIGN:
{
{   Available space from the volume is maintained in the mainframe
{   allocation table and is assigned, as necessary, to NOS/VE segments.
?? TITLE := '  Common Decks', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmp$get_active_vol_attributes
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_fau_entry
*copyc dmp$get_fmd_by_index
*copyc dmp$get_mat_pointer
*copyc dmp$get_previous_fau_entry
*copyc dmp$get_level_1_ptr
*copyc dmp$get_level_2_ptr
*copyc dmp$get_next_fmd_fau
*copyc dmt$active_volume_table
*copyc dmt$allocation_log
*copyc dmt$allocation_size
*copyc dmt$assigned_ms_vol_attributes
*copyc dmt$device_allocation_unit
*copyc dmt$device_position
*copyc dmt$error_condition_codes
*copyc dmt$file_allocation_descriptor
*copyc dmt$file_allocation_status
*copyc dmt$file_descriptor_entry
*copyc dmt$internal_vsn
*copyc dmt$keypoint_calls
*copyc dmt$mainframe_allocation_table
*copyc dmt$mat_change_request
*copyc dmt$monitor_request_blocks
*copyc dmv$active_volume_table
*copyc dmv$null_vsn
*copyc gft$locked_file_desc_entry_p
*copyc jmt$ijl_ordinal
*copyc mmp$modify_pages
*copyc mtp$cst_p
*copyc mtp$error_stop
*copyc mtp$set_status_abnormal
*copyc osp$fetch_locked_variable
*copyc osp$increment_locked_variable
*copyc oss$mainframe_wired
*copyc oss$mainframe_wired_literal
*copyc rmd$volume_declarations
*copyc sfp$mtr_accumulate_file_space
*copyc syt$monitor_request_code
*copyc tmp$monitor_ready_system_task
*copyc tmt$task_status
?? POP ??
?? FMT (FORMAT := OFF, keyw := upper, ident := lower) ??
  VAR
    dmv$default_fau_entry: [XDCL, #GATE, STATIC, READ,
           oss$mainframe_wired_literal] dmt$file_allocation_unit :=
      {dau_address:=}         [0,
      {state:=}               dmc$fau_free,
      {fad_index:=}           0];

?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
?? TITLE := '  XDCL Variables', EJECT ??

  VAR
    dmv$permanent_file_overflow: [XDCL, #GATE, STATIC, oss$mainframe_wired] boolean := TRUE,

    dmv$temporary_file_overflow: [XDCL, #GATE, STATIC, oss$mainframe_wired] boolean := TRUE;

  VAR
    dmv$allocation_log: [XDCL, STATIC, #GATE, oss$mainframe_wired]
      dmt$allocation_log_info,

    dmv$split_al_initiated: [XDCL, STATIC, #GATE, oss$mainframe_wired] boolean
      := FALSE,

    dmv$administer_log_initiated: [XDCL, STATIC, #GATE, oss$mainframe_wired]
      boolean := FALSE,

    dmv$vol_space_manage_initiated: [XDCL, STATIC, #GATE, oss$mainframe_wired]
      boolean := FALSE;

  VAR
    dmv$volume_selector: [XDCL, STATIC, #GATE, oss$mainframe_wired] integer := 0;

  VAR
    dmv$pf_sparse: [XDCL, #GATE] boolean := FALSE;

  VAR
    dmv$require_cylinders: [XDCL, #GATE] boolean := TRUE,
    dmv$failing_mau_count: [XDCL, #GATE, STATIC, oss$mainframe_wired] integer := 0,
    dmv$mau_release_failure: [XDCL, #GATE, STATIC, oss$mainframe_wired] boolean := FALSE,
    dmv$failing_mau: [XDCL, #GATE, STATIC, oss$mainframe_wired] dmt$dau_address;



?? TITLE := '  dmp$allocate_file_space', EJECT ??
*copy dmh$allocate_file_space

  PROCEDURE [XDCL] dmp$allocate_file_space (p_fde: gft$locked_file_desc_entry_p;
        initial_byte_address: amt$file_byte_address;
        bytes_to_allocate: amt$file_byte_address;
        file_space_limit: sft$file_space_limit_kind;
    VAR allocation_units_obtained: amt$file_byte_address;
    VAR overflow: boolean;
    VAR file_allocation_status: dmt$file_allocation_status);

    VAR
      allocate_byte_address: amt$file_byte_address,
      end_of_allocation: amt$file_byte_address,
      p_dfd: ^dmt$disk_file_descriptor,
      p_previous_fau_entry: ^dmt$file_allocation_unit,
      able_to_log: boolean,
      allocation_allowed: boolean,
      allocation_style: dmt$allocation_styles,
      allocation_unit_found: boolean,
      al_entry: dmt$al_entry,
      avt_index: dmt$active_volume_table_index,
      bytes_per_allocation: dmt$bytes_per_allocation,
      bytes_per_position: dmt$bytes_per_allocation,
      current_fmd_index: dmt$fmd_index,
      dat_empty: boolean,
      dau_address: dmt$dau_address,
      daus_per_allocation_unit: dmt$daus_per_position,
      file_kind: gft$file_kind,
      incomplete_allocation: boolean,
      logging_required_for_file_type: boolean,
      p_existing_fmd: ^dmt$file_medium_descriptor,
      p_mat: ^dmt$mainframe_allocation_table,
      p_fau_entry: ^dmt$file_allocation_unit,
      previous_dau_address: dmt$dau_address,
      space_limit_exceeded: boolean;

    overflow := FALSE;
    allocation_units_obtained := 0;
    allocate_byte_address := initial_byte_address;
    end_of_allocation := allocate_byte_address + bytes_to_allocate;
    file_allocation_status := dmc$fas_file_allocated;

    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
    current_fmd_index := p_dfd^.current_fmd_index;
    dmp$get_fmd_by_index (p_dfd, current_fmd_index, p_existing_fmd);
    IF NOT p_existing_fmd^.volume_assigned THEN
      file_allocation_status := dmc$fas_job_mode_work_required;
      RETURN;
    IFEND;

    file_kind := p_fde^.file_kind;
    avt_index := p_existing_fmd^.avt_index;
    logging_required_for_file_type := (file_kind <= gfc$fk_last_permanent_file);

  /process_request/
    BEGIN

      allocation_allowed := dmv$p_active_volume_table^ [avt_index].mass_storage.allocation_allowed
              AND NOT dmv$p_active_volume_table^ [avt_index].mass_storage.volume_unavailable;

      IF NOT allocation_allowed THEN
        file_allocation_status := dmc$fas_job_mode_work_required;
        overflow := TRUE;
        EXIT /process_request/;
      IFEND;

      dmp$get_mat_pointer (avt_index, p_mat);

      allocation_style := p_existing_fmd^.allocation_style;
      daus_per_allocation_unit := p_mat^.daus_per_allocation_unit [allocation_style];
      bytes_per_allocation := p_mat^.bytes_per_dau * daus_per_allocation_unit;
      allocate_byte_address := allocate_byte_address DIV bytes_per_allocation *
        bytes_per_allocation;

      IF initial_byte_address > p_dfd^.highest_offset_allocated THEN
        IF (p_fde^.file_kind <= gfc$fk_last_permanent_file)
            AND (NOT dmv$pf_sparse) THEN
          allocate_byte_address := p_dfd^.highest_offset_allocated;
        IFEND;
      IFEND;

      { allocate space

      allocation_unit_found := allocation_allowed;
      able_to_log := TRUE;
      al_entry.kind := dmc$al_allocate;
      al_entry.avt_index := avt_index;
      al_entry.allocate_block.global_file_name := p_fde^.global_file_name;
      al_entry.allocate_block.dfl_index := p_existing_fmd^.dfl_index;
      al_entry.allocate_block.daus_per_allocation := daus_per_allocation_unit;


      IF p_dfd^.requested_allocation_size > p_dfd^.bytes_per_allocation THEN
        {Assume cylinder allocation
        {Get as many allocation units of the correct style as needed/possible
        {May run out of table space in the middle
        {Desire is that they will reside on the same cylinder
        bytes_per_position := (p_mat^.daus_per_position * p_mat^.bytes_per_dau) DIV bytes_per_allocation *
            bytes_per_allocation;
        allocate_byte_address := allocate_byte_address DIV bytes_per_position * bytes_per_position;
      IFEND;

    /allocate_space/
        WHILE (allocate_byte_address < end_of_allocation) AND allocation_unit_found AND
            able_to_log DO
          dmp$get_fau_entry (p_dfd, allocate_byte_address, p_fau_entry);
          IF p_fau_entry = NIL THEN
            {Ran out of table space in the middle!
            file_allocation_status := dmc$fas_job_mode_work_required;
            EXIT /allocate_space/;
          IFEND;
          IF p_fau_entry^.state <> dmc$fau_free THEN
            allocate_byte_address := allocate_byte_address + bytes_per_allocation;
            CYCLE /allocate_space/;
          IFEND;
          {The following must be inside the loop to find the previous dau for sparse allocates
          dmp$get_previous_fau_entry (p_dfd, allocate_byte_address, current_fmd_index,
                p_previous_fau_entry);
          IF p_previous_fau_entry <> NIL THEN
            previous_dau_address := p_previous_fau_entry^.dau_address;
          ELSE
            previous_dau_address := 0;
          IFEND;

        assign_allocation_unit (p_mat, allocation_style, previous_dau_address, dau_address,
              allocation_unit_found);
        IF allocation_unit_found THEN
          IF logging_required_for_file_type THEN
            al_entry.allocate_block.dau_address := dau_address;
            IF (previous_dau_address = 0) THEN
              al_entry.allocate_block.allocate_flags := dmc$dl_first_allocation;
            ELSE
              al_entry.allocate_block.allocate_flags := dmc$dl_continued_allocation;
            IFEND;
            al_entry.allocate_block.previous_dau_address := previous_dau_address;
            dmp$mtr_log (al_entry, able_to_log);
            IF NOT able_to_log THEN
              release_allocation_unit (p_mat, allocation_style, dau_address);
              EXIT /allocate_space/;
            IFEND;
          IFEND;
          p_fau_entry^.dau_address := dau_address;
          p_fau_entry^.state := dmc$fau_invalid_data;
          allocation_units_obtained := allocation_units_obtained + 1;
          p_dfd^.dfd_modified := TRUE;
          p_fau_entry^.fmd_index := current_fmd_index;
          allocate_byte_address := allocate_byte_address + bytes_per_allocation;
        IFEND;
      WHILEND /allocate_space/;

      { Support for Dynamic File Space Limits

      IF file_space_limit <> sfc$no_limit THEN
        sfp$mtr_accumulate_file_space (file_space_limit,
               allocation_units_obtained * bytes_per_allocation, space_limit_exceeded);
        IF space_limit_exceeded THEN
          file_allocation_status := dmc$fas_account_limit_exceeded;
        IFEND;
      IFEND;

      { Update fmd allocated length

      p_existing_fmd^.fmd_allocated_length := p_existing_fmd^.fmd_allocated_length +
        allocation_units_obtained * bytes_per_allocation;

      { Update dfd highest_offset_allocated
      {Note: Used for sequential allocation only

{
{  IS THIS RIGHT?   DID WE POSSIBLY NOT ALLOCATE ANY SPACE?
{
      IF allocate_byte_address > p_dfd^.highest_offset_allocated THEN
        p_dfd^.highest_offset_allocated := allocate_byte_address;
      IFEND;

      p_mat^.allocated_space [file_kind] := (p_mat^.allocated_space [file_kind] +
            (daus_per_allocation_unit * allocation_units_obtained)) MOD (dmc$max_dau_address + 1);

      incomplete_allocation := (allocate_byte_address < end_of_allocation);

      IF incomplete_allocation AND (file_allocation_status = dmc$fas_file_allocated) THEN

        dat_empty := p_mat^.available_dat_space <= p_mat^.dat_threshold;
        overflow := dat_empty AND able_to_log;

        IF overflow THEN
          file_allocation_status := dmc$fas_job_mode_work_required;
        ELSE
          file_allocation_status := dmc$fas_temp_reject;
        IFEND;

      IFEND;

      update_volume_status (p_mat);

    END /process_request/;
  PROCEND dmp$allocate_file_space;
?? TITLE := '  dmp$apply_mat_changes', EJECT ??

  PROCEDURE [XDCL] dmp$apply_mat_changes (VAR mat_change_request: dmt$mat_change_request);

    VAR
      p_mat: ^dmt$mainframe_allocation_table,
      p_mat_changes: ^dmt$mat_changes,
      mat_change_type: dmt$mat_change_type,
      mat_change_count: dmt$mat_change_count;

    dmp$get_mat_pointer (mat_change_request.avt_index, p_mat);
    mat_change_type := mat_change_request.mat_change_type;

    CASE mat_change_type OF

    = dmc$change_dat_threshold =
      p_mat^.dat_threshold := mat_change_request.dat_threshold DIV p_mat^.daus_per_position *
            p_mat^.daus_per_position;

    = dmc$add_mat_space, dmc$remove_mat_space =
      p_mat_changes := mat_change_request.p_mat_changes;
      p_mat^.available_dat_space := mat_change_request.available_dat_space;

      IF (mat_change_type = dmc$add_mat_space) THEN
        mat_change_count := mat_change_request.mat_change_count;
        add_mat_space (p_mat, p_mat_changes, mat_change_count);
      ELSE
        remove_mat_space (p_mat, p_mat_changes, mat_change_count);
        mat_change_request.mat_change_count := mat_change_count;
      IFEND;
    ELSE
      mtp$error_stop ('Invalid MAT change type.');
    CASEND;

    update_volume_status (p_mat);
  PROCEND dmp$apply_mat_changes;
?? TITLE := '  dmp$deallocate_file_space', EJECT ??
*copy dmh$deallocate_file_space

  PROCEDURE [XDCL] dmp$deallocate_file_space (p_fde: gft$locked_file_desc_entry_p;
        initial_release_byte_address: amt$file_byte_address;
        initial_bytes_to_release: integer);

    VAR
      avt_index: dmt$active_volume_table_index,
      bytes_per_allocation: dmt$bytes_per_allocation,
      bytes_per_level_2: amt$file_byte_address,
      bytes_to_release: integer,
      final_release_address: amt$file_byte_address,
      fmd_index: dmt$fmd_index,
      level_1_end: dmt$level_1_index,
      level_1_index: dmt$level_1_index,
      level_1_start: dmt$level_1_index,
      level_2_end: dmt$level_2_index,
      level_2_index: dmt$level_2_index,
      level_2_start: dmt$level_2_index,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fmd: ^dmt$file_medium_descriptor,
      p_level_1: ^dmt$level_1_table,
      p_level_2: ^dmt$level_2_table,
      p_mat: ^dmt$mainframe_allocation_table,
      release_byte_address: amt$file_byte_address;

    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
    bytes_per_allocation := p_dfd^.bytes_per_allocation;
    bytes_per_level_2 := p_dfd^.bytes_per_level_2;

    {Round up to next AU
    release_byte_address := ((initial_release_byte_address + bytes_per_allocation -
        1) DIV bytes_per_allocation) * bytes_per_allocation;

    {Round down to next AU
    bytes_to_release := initial_bytes_to_release - (release_byte_address - initial_release_byte_address);
    bytes_to_release := bytes_to_release DIV bytes_per_allocation * bytes_per_allocation;
    IF bytes_to_release <= 0 THEN
      RETURN;
    IFEND;

    final_release_address := release_byte_address + bytes_to_release - 1;
    IF (final_release_address >= p_dfd^.highest_offset_allocated) THEN
      final_release_address := p_dfd^.highest_offset_allocated - 1;
    IFEND;

    level_1_start := release_byte_address DIV bytes_per_level_2;
    level_1_end := final_release_address DIV bytes_per_level_2;

    level_2_start := release_byte_address MOD bytes_per_level_2 DIV bytes_per_allocation;
    level_2_end := bytes_per_level_2 DIV bytes_per_allocation - 1;

    fmd_index := 0;
    p_mat := NIL;

    dmp$get_level_1_ptr (p_dfd, p_level_1);
    IF p_level_1 <> NIL THEN
      FOR level_1_index := level_1_start TO level_1_end DO
        IF (level_1_index = level_1_end) THEN
          level_2_end := final_release_address MOD bytes_per_level_2 DIV bytes_per_allocation;
        IFEND;
        dmp$get_level_2_ptr (^p_level_1^ [level_1_index], p_level_2);
        IF p_level_2 <> NIL THEN
          FOR level_2_index := level_2_start TO level_2_end DO
            IF (p_level_2^ [level_2_index].state <> dmc$fau_free) THEN
              IF p_level_2^ [level_2_index].fmd_index <> fmd_index THEN
                IF p_mat <> NIL THEN
                  update_volume_status (p_mat);
                IFEND;
                fmd_index := p_level_2^ [level_2_index].fmd_index;
                dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);
                avt_index := p_fmd^.avt_index;
                dmp$get_mat_pointer (avt_index, p_mat);
              IFEND;
              release_allocation_unit (p_mat, p_fmd^.allocation_style, p_level_2^ [level_2_index].
                    dau_address);
              p_level_2^ [level_2_index].state := dmc$fau_free;
              p_fmd^.fmd_allocated_length := p_fmd^.fmd_allocated_length - bytes_per_allocation;
            IFEND;
          FOREND;
        IFEND;
        level_2_start := 0;
      FOREND;

      p_dfd^.dfd_modified := TRUE;
      IF p_mat <> NIL THEN
        update_volume_status (p_mat);
      IFEND;
    IFEND;

    {Note: p_dfd^.highest_offset_allocated no longer correct!
    {Depend on dmp$trim_file to correct it.

  PROCEND dmp$deallocate_file_space;
?? TITLE := '  [XDCL] dmp$mtr_log', EJECT ??
  PROCEDURE [XDCL] dmp$mtr_log (entry: dmt$al_entry;
    VAR able_to_log: boolean);

    VAR
      current_value: integer,
      final_value: integer,
      local_status: syt$monitor_status;

  /main_program/
    BEGIN
      able_to_log := TRUE;

      osp$fetch_locked_variable (dmv$allocation_log.number, current_value);

      IF current_value = dmc$max_allocation_log_entries THEN
        able_to_log := FALSE;
        EXIT /main_program/;
      IFEND;

      IF (entry.kind = dmc$al_allocate) AND (current_value >=
            dmc$al_reject_alloc_threshold) THEN
        able_to_log := FALSE;
        EXIT /main_program/;
      IFEND;

      CASE entry.kind OF
      = dmc$al_allocate, dmc$al_initialize, dmc$al_return_dau, dmc$al_software_flawed,
          dmc$al_reallocate, dmc$al_trim_file =
        dmv$allocation_log.entries [dmv$allocation_log.last] := entry;
        dmv$allocation_log.last := (dmv$allocation_log.last + 1) MOD
              dmc$max_allocation_log_entries;

        osp$increment_locked_variable (dmv$allocation_log.number, current_value, final_value);

        IF final_value >= dmc$al_trigger_update_threshold THEN
          IF dmv$split_al_initiated THEN
            tmp$monitor_ready_system_task (tmc$stid_dm_split_al, local_status);
          IFEND;
        IFEND;
      ELSE
        mtp$error_stop ('Invalid allocation log entry.');
      CASEND;

    END /main_program/;
  PROCEND dmp$mtr_log;
?? TITLE := '  add_mat_space', EJECT ??

  PROCEDURE add_mat_space (p_mat: ^dmt$mainframe_allocation_table;
        p_mat_changes: ^dmt$mat_changes;
        mat_change_count: dmt$mat_change_count);

    VAR
      allocation_style: dmt$allocation_styles,
      dau_address: dmt$dau_address,
      change_count: dmt$mat_change_count,
      change_index: dmt$mat_change_count;

    change_count := mat_change_count;
    IF (p_mat_changes = NIL) THEN
      change_count := 0;
    ELSEIF (change_count > UPPERBOUND (p_mat_changes^)) THEN
      change_count := UPPERBOUND (p_mat_changes^);
    IFEND;

    FOR change_index := 1 TO change_count DO
      allocation_style := p_mat_changes^ [change_index].style;
      dau_address := p_mat_changes^ [change_index].dau_address;
      release_allocation_unit (p_mat, allocation_style, dau_address);
    FOREND;
  PROCEND add_mat_space;
?? TITLE := '  assign_allocation_unit', EJECT ??

  PROCEDURE assign_allocation_unit (p_mat: ^dmt$mainframe_allocation_table;
        allocation_style: dmt$allocation_styles;
        previous_dau: dmt$dau_address;
    VAR assigned_dau: dmt$dau_address;
    VAR allocation_unit_found: boolean);

    VAR
      position: dmt$position_link,
      previous_position: dmt$device_position;

    previous_position := previous_dau DIV p_mat^.daus_per_position;

    allocation_unit_found := (p_mat^.mat_entries [previous_position].allocation_style = allocation_style)
          AND (p_mat^.mat_entries [previous_position].available_allocation_units > 0);

    IF allocation_unit_found THEN
      assign_from_position (p_mat, previous_position, assigned_dau);
    ELSE
      find_closest_position (p_mat, allocation_style, previous_position, position);
      allocation_unit_found := (position <> dmc$nil_position_link);
      IF allocation_unit_found THEN
        assign_from_position (p_mat, position, assigned_dau);
      ELSE
        create_allocation_style (p_mat, allocation_style, previous_position, position);
        allocation_unit_found := (position <> dmc$nil_position_link);
        IF allocation_unit_found THEN
          assign_from_position (p_mat, position, assigned_dau);
        IFEND;
      IFEND;
    IFEND;
  PROCEND assign_allocation_unit;
?? TITLE := '  assign_from_position', EJECT ??

  PROCEDURE assign_from_position (p_mat: ^dmt$mainframe_allocation_table;
        position: dmt$device_position;
    VAR dau_address: dmt$dau_address);

    VAR
      allocation_style: dmt$allocation_styles,
      daus_per_position: dmt$daus_per_position,
      daus_per_allocation_unit: dmt$daus_per_position,
      p_position_entry: ^dmt$mat_entry,
      dau: dmt$dau_address,
      next_allocation_unit_dau: dmt$dau_address,
      next_position_dau: dmt$dau_address;

    daus_per_position := p_mat^.daus_per_position;
    p_position_entry := ^p_mat^.mat_entries [position];
    allocation_style := p_position_entry^.allocation_style;
    daus_per_allocation_unit := p_mat^.daus_per_allocation_unit [allocation_style];
    dau := position * daus_per_position;
    next_position_dau := dau + daus_per_position;

    REPEAT
      next_allocation_unit_dau := dau + daus_per_allocation_unit;
      IF p_mat^.p_available_daus^ [dau] THEN
        dau_address := dau;
        REPEAT
          dau := dau + 1;
        UNTIL (dau = next_allocation_unit_dau) OR NOT p_mat^.p_available_daus^ [dau];

        IF (dau = next_allocation_unit_dau) THEN
          FOR dau := dau_address TO (next_allocation_unit_dau - 1) DO
            p_mat^.p_available_daus^ [dau] := FALSE;
          FOREND;
          p_mat^.available_space := p_mat^.available_space - daus_per_allocation_unit;
          p_mat^.available_allocation_units [allocation_style] := p_mat^.available_allocation_units
                [allocation_style] - 1;
          p_position_entry^.available_allocation_units := p_position_entry^.available_allocation_units - 1;
          IF (p_position_entry^.available_allocation_units = 0) THEN
            delink_position (p_mat, position);
          IFEND;
          RETURN;
        IFEND;
      IFEND;
      dau := next_allocation_unit_dau;
    UNTIL (dau >= next_position_dau);

    mtp$error_stop ('Unable to assign from position.');
  PROCEND assign_from_position;
?? TITLE := '  create_allocation_style', EJECT ??

  PROCEDURE create_allocation_style (p_mat: ^dmt$mainframe_allocation_table;
        allocation_style: dmt$allocation_styles;
        previous_position: dmt$device_position;
    VAR position: dmt$position_link);

    VAR
      leftover_space: dmt$dau_address,
      daus_per_position: dmt$daus_per_position,
      daus_per_allocation_unit: dmt$daus_per_position,
      allocation_units_per_position: dmt$daus_per_position;

    find_closest_position (p_mat, dmc$acyl, previous_position, position);

    IF (position <> dmc$nil_position_link) THEN
      p_mat^.available_allocation_units [dmc$acyl] := p_mat^.available_allocation_units
            [dmc$acyl] - 1;
      delink_position (p_mat, position);

      daus_per_position := p_mat^.daus_per_position;
      daus_per_allocation_unit := p_mat^.daus_per_allocation_unit [allocation_style];
      allocation_units_per_position := daus_per_position DIV daus_per_allocation_unit;

      leftover_space := daus_per_position MOD daus_per_allocation_unit;
      p_mat^.leftover_space := p_mat^.leftover_space + leftover_space;
      p_mat^.available_space := p_mat^.available_space - leftover_space;

      p_mat^.available_allocation_units [allocation_style] := p_mat^.
            available_allocation_units [allocation_style] + allocation_units_per_position;
      p_mat^.mat_entries [position].allocation_style := allocation_style;
      p_mat^.mat_entries [position].available_allocation_units := allocation_units_per_position;
      link_position (p_mat, position);
    IFEND;
  PROCEND create_allocation_style;
?? TITLE := '  delink_position', EJECT ??

  PROCEDURE delink_position (p_mat: ^dmt$mainframe_allocation_table;
        position: dmt$device_position);

    VAR
      allocation_style: dmt$allocation_styles,
      previous_position: dmt$position_link,
      next_position: dmt$position_link,
      p_position_entry: ^dmt$mat_entry;

    p_position_entry := ^p_mat^.mat_entries [position];
    allocation_style := p_position_entry^.allocation_style;
    next_position := p_position_entry^.forward_link;
    previous_position := p_position_entry^.backward_link;

    p_position_entry^.backward_link := dmc$nil_position_link;
    p_position_entry^.forward_link := dmc$nil_position_link;

    IF (previous_position = dmc$nil_position_link) THEN
      p_mat^.allocation_chains [allocation_style] := next_position;
    ELSE
      p_mat^.mat_entries [previous_position].forward_link := next_position;
    IFEND;

    IF (next_position <> dmc$nil_position_link) THEN
      p_mat^.mat_entries [next_position].backward_link := previous_position;
    IFEND;
  PROCEND delink_position;
?? TITLE := '  find_adjacent_positions', EJECT ??

  PROCEDURE find_adjacent_positions (p_mat: ^dmt$mainframe_allocation_table;
        allocation_style: dmt$allocation_styles;
        position: dmt$device_position;
    VAR previous_position: dmt$position_link;
    VAR next_position: dmt$position_link);

    previous_position := dmc$nil_position_link;
    next_position := p_mat^.allocation_chains [allocation_style];

    WHILE (next_position <> dmc$nil_position_link) AND (next_position < position) DO
      previous_position := next_position;
      next_position := p_mat^.mat_entries [previous_position].forward_link;
    WHILEND;
  PROCEND find_adjacent_positions;
?? TITLE := '  find_closest_position', EJECT ??

  PROCEDURE find_closest_position (p_mat: ^dmt$mainframe_allocation_table;
        allocation_style: dmt$allocation_styles;
        position: dmt$device_position;
    VAR closest_position: dmt$position_link);

    VAR
      use_next: boolean,
      previous_position: dmt$position_link,
      next_position: dmt$position_link;

    find_adjacent_positions (p_mat, allocation_style, position, previous_position, next_position);

    use_next := (previous_position = dmc$nil_position_link) OR (next_position <> dmc$nil_position_link) AND
          ((position - previous_position) > (next_position - position));

    IF use_next THEN
      closest_position := next_position;
    ELSE
      closest_position := previous_position;
    IFEND;
  PROCEND find_closest_position;
?? TITLE := '  find_furthest_position', EJECT ??

  PROCEDURE find_furthest_position (p_mat: ^dmt$mainframe_allocation_table;
        allocation_style: dmt$allocation_styles;
        position: dmt$device_position;
    VAR furthest_position: dmt$position_link);

    VAR
      next_position: dmt$position_link,
      last_position: dmt$position_link;

    furthest_position := p_mat^.allocation_chains [allocation_style];

    IF (furthest_position <> dmc$nil_position_link) THEN
      next_position := furthest_position;

      REPEAT
        last_position := next_position;
        next_position := p_mat^.mat_entries [last_position].forward_link;
      UNTIL (next_position = dmc$nil_position_link);

      IF ((position - furthest_position) <= (last_position - position)) THEN
        furthest_position := last_position;
      IFEND;
    IFEND;
  PROCEND find_furthest_position;
?? TITLE := '  link_position', EJECT ??

  PROCEDURE link_position (p_mat: ^dmt$mainframe_allocation_table;
        position: dmt$device_position);

    VAR
      allocation_style: dmt$allocation_styles,
      p_position_entry: ^dmt$mat_entry,
      previous_position: dmt$position_link,
      next_position: dmt$position_link;

    p_position_entry := ^p_mat^.mat_entries [position];
    allocation_style := p_position_entry^.allocation_style;

    find_adjacent_positions (p_mat, allocation_style, position, previous_position, next_position);

    IF (previous_position = dmc$nil_position_link) THEN
      p_mat^.allocation_chains [allocation_style] := position;
    ELSE
      p_mat^.mat_entries [previous_position].forward_link := position;
    IFEND;

    IF (next_position <> dmc$nil_position_link) THEN
      p_mat^.mat_entries [next_position].backward_link := position;
    IFEND;

    p_position_entry^.forward_link := next_position;
    p_position_entry^.backward_link := previous_position;
  PROCEND link_position;
?? TITLE := '  release_allocation_unit', EJECT ??

  PROCEDURE release_allocation_unit (p_mat: ^dmt$mainframe_allocation_table;
        released_style: dmt$allocation_styles;
        dau_address: dmt$dau_address);

    VAR
      position: dmt$device_position,
      p_position_entry: ^dmt$mat_entry,
      dau: dmt$dau_address,
      next_allocation_unit_dau: dmt$dau_address,
      position_dau: dmt$dau_address,
      next_position_dau: dmt$dau_address,
      leftover_space: dmt$daus_per_position,
      daus_per_position: dmt$daus_per_position,
      daus_per_allocation: dmt$daus_per_position,
      daus_released: dmt$daus_per_position,
      style: dmt$allocation_styles,
      additional_allocation_units: dmt$daus_per_position,
      allocation_units_per_position: dmt$daus_per_position;

    dmv$mau_release_failure := FALSE;

    daus_released := p_mat^.daus_per_allocation_unit [released_style];
    daus_per_position := p_mat^.daus_per_position;
    position := dau_address DIV daus_per_position;
    p_position_entry := ^p_mat^.mat_entries [position];
    style := p_position_entry^.allocation_style;
    daus_per_allocation := p_mat^.daus_per_allocation_unit [style];
    allocation_units_per_position := daus_per_position DIV daus_per_allocation;

    { Set DAU's available.

    FOR dau := dau_address TO (dau_address + daus_released - 1) DO
      IF p_mat^.p_available_daus^ [dau] THEN
{       mtp$error_stop ('Releasing available allocation unit.');

{ No longer consider this a system fatal error. Log the occurrance in the
{ critical window for now and continue. Since the entry is already released
{ no real harm can occur, I hope.

        dmv$mau_release_failure := TRUE;
        dmv$failing_mau := dau;
        dmv$failing_mau_count := dmv$failing_mau_count + 1;
        RETURN;
      IFEND;
      p_mat^.p_available_daus^ [dau] := TRUE;
    FOREND;

    p_mat^.available_space := p_mat^.available_space + daus_released;

    { Put allocation unit(s) back in MAT.

    IF (released_style = style) THEN
      additional_allocation_units := 1;
    ELSE
      additional_allocation_units := daus_released DIV daus_per_allocation;
      leftover_space := daus_released MOD daus_per_allocation;
      p_mat^.leftover_space := p_mat^.leftover_space + leftover_space;
      p_mat^.available_space := p_mat^.available_space - leftover_space;
      IF (additional_allocation_units = 0) THEN
        position_dau := position * daus_per_position;
        next_position_dau := position_dau + daus_per_position;
        dau := position_dau + (dau_address - position_dau) DIV daus_per_allocation *
              daus_per_allocation;
        next_allocation_unit_dau := dau + daus_per_allocation;
        IF (next_allocation_unit_dau <= next_position_dau) THEN
          WHILE (dau < next_allocation_unit_dau) AND p_mat^.p_available_daus^ [dau] DO
            dau := dau + 1;
          WHILEND;
          IF (dau = next_allocation_unit_dau) THEN
            p_mat^.leftover_space := p_mat^.leftover_space - daus_per_allocation;
            p_mat^.available_space := p_mat^.available_space  + daus_per_allocation;
            additional_allocation_units := 1;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    p_mat^.available_allocation_units [style] := p_mat^.available_allocation_units [style] +
          additional_allocation_units;
    p_position_entry^.available_allocation_units := p_position_entry^.available_allocation_units +
          additional_allocation_units;

    { Convert unused position back to cylinder allocation style.

    IF (p_position_entry^.available_allocation_units = allocation_units_per_position) THEN
      position_dau := position * daus_per_position;
      next_position_dau := position_dau + daus_per_position;
      dau := position_dau + daus_per_allocation * allocation_units_per_position;
      leftover_space := next_position_dau - dau;

      WHILE (dau < next_position_dau) AND p_mat^.p_available_daus^ [dau] DO
        dau := dau + 1;
      WHILEND;

      IF (dau = next_position_dau) THEN {Leftover DAU's are in the MAT}
        IF (p_position_entry^.available_allocation_units > additional_allocation_units) THEN
          delink_position (p_mat, position);
        IFEND;

        p_mat^.available_allocation_units [style] := p_mat^.available_allocation_units [style] -
              allocation_units_per_position;

        p_mat^.leftover_space := p_mat^.leftover_space - leftover_space;
        p_mat^.available_space := p_mat^.available_space + leftover_space;

        p_position_entry^.allocation_style := dmc$acyl;
        p_position_entry^.available_allocation_units := 1;
        p_mat^.available_allocation_units [dmc$acyl] := p_mat^.available_allocation_units
              [dmc$acyl] + 1;
        additional_allocation_units := 1;
      IFEND;
    IFEND;

    { Link position into allocation chain.

    IF (p_position_entry^.available_allocation_units = additional_allocation_units) AND
            (additional_allocation_units > 0) THEN
      link_position (p_mat, position);
    IFEND;
  PROCEND release_allocation_unit;
?? TITLE := '  remove_mat_space', EJECT ??

  PROCEDURE remove_mat_space (p_mat: ^dmt$mainframe_allocation_table;
        p_mat_changes: ^dmt$mat_changes;
    VAR mat_change_count: dmt$mat_change_count);

    VAR
      daus_per_position: dmt$daus_per_position,
      available_positions: dmt$device_position,
      mat_excess: integer,
      mat_position_excess: dmt$device_position,
      dat_shortage: integer,
      dat_position_shortage: dmt$device_position,
      position: dmt$position_link,
      previous_position: dmt$device_position,
      dau: dmt$dau_address,
      first_dau: dmt$dau_address,
      change_index: dmt$mat_change_count;

    daus_per_position := p_mat^.daus_per_position;
    available_positions := p_mat^.available_allocation_units [dmc$acyl];

    { Compute the number of positions by which the MAT is too full.
    { The MAT must have more than one free cylinder to be considered too full.

    mat_excess := p_mat^.available_space - p_mat^.maximum_space;
    IF (mat_excess <= 0) OR (available_positions <= 1) THEN
      mat_position_excess := 0;
    ELSE
      mat_position_excess := (mat_excess + daus_per_position - 1) DIV daus_per_position;
      IF (mat_position_excess > (available_positions - 1)) THEN
        mat_position_excess := available_positions - 1;
      IFEND;
    IFEND;

    { Compute the number of positions by which the DAT is too empty.
    { The DAT must be a full cylinder below the threshold before it is
    { considerd to be too empty.

    dat_shortage := p_mat^.dat_threshold - p_mat^.available_dat_space;
    IF (dat_shortage <= 0) THEN
      dat_position_shortage := 0;
    ELSE
      dat_position_shortage := dat_shortage DIV daus_per_position;
      IF (dat_position_shortage > available_positions) THEN
        dat_position_shortage := available_positions;
      IFEND;
    IFEND;

    { The position count to be returned to the DAT is the greater of the
    { number of positions by which the MAT is too full and the number of
    { positions by which the DAT is too empty.  This is constrained by
    { the number of changes that will fit in the MAT change list.

    IF (mat_position_excess >= dat_position_shortage) THEN
      mat_change_count := mat_position_excess;
    ELSE
      mat_change_count := dat_position_shortage;
    IFEND;

    IF (p_mat_changes = NIL) THEN
      mat_change_count := 0;
    ELSEIF (mat_change_count > UPPERBOUND (p_mat_changes^)) THEN
      mat_change_count := UPPERBOUND (p_mat_changes^);
    IFEND;

    { Remove positions from the MAT and record them in the MAT change list.

    previous_position := 0;

    FOR change_index := 1 TO mat_change_count DO
      find_furthest_position (p_mat, dmc$acyl, previous_position, position);
      delink_position (p_mat, position);

      first_dau := position * daus_per_position;
      FOR dau := first_dau TO (first_dau + daus_per_position - 1) DO
        p_mat^.p_available_daus^ [dau] := FALSE;
      FOREND;

      p_mat^.mat_entries [position].available_allocation_units := 0;
      p_mat^.available_allocation_units [dmc$acyl] := p_mat^.available_allocation_units [dmc$acyl] - 1;
      p_mat^.available_space := p_mat^.available_space - daus_per_position;

      p_mat_changes^ [change_index].style := dmc$acyl;
      p_mat_changes^ [change_index].dau_address := first_dau;
    FOREND;
  PROCEND remove_mat_space;
?? TITLE := '  update_volume_status', EJECT ??

  PROCEDURE update_volume_status (p_mat: ^dmt$mainframe_allocation_table);

    VAR
      avt_index: dmt$active_volume_table_index,
      available_space: dmt$dau_address,
      usable_mat_space: dmt$dau_address,
      available_cylinders: dmt$device_position,
      dat_shortage: integer,
      space_low: boolean,
      space_was_low: boolean,
      space_gone: boolean,
      space_was_gone: boolean,
      status_change: boolean,
      free_cylinders: boolean,
      multiple_free_cylinders: boolean,
      mat_low: boolean,
      fill_mat: boolean,
      empty_mat: boolean,
      dat_low: boolean,
      fill_dat: boolean,
      ready_space_manager: boolean,
      status: syt$monitor_status;

    avt_index := p_mat^.avt_index;

    available_cylinders := p_mat^.available_allocation_units [dmc$acyl];
    free_cylinders := available_cylinders > 0;
    multiple_free_cylinders := available_cylinders > 1;

    dat_shortage := p_mat^.dat_threshold - p_mat^.available_dat_space;
    dat_low := dat_shortage >= 0;
    fill_dat := (dat_shortage > p_mat^.daus_per_position) AND free_cylinders;

    usable_mat_space := p_mat^.available_space;
    mat_low := (usable_mat_space < p_mat^.minimum_space) OR NOT free_cylinders;
    fill_mat := mat_low AND NOT dat_low;
    empty_mat := (usable_mat_space > p_mat^.maximum_space) AND multiple_free_cylinders;

    p_mat^.mat_too_full := empty_mat OR fill_dat;

    available_space := p_mat^.available_space + p_mat^.available_dat_space;
    space_low := available_space <= p_mat^.warning_threshold;
    space_was_low := dmv$p_active_volume_table^ [avt_index].mass_storage.space_low;
    dmv$p_active_volume_table^ [avt_index].mass_storage.space_low := space_low;

{   IF dmv$require_cylinders THEN
    space_gone := NOT free_cylinders AND dat_low;
      space_gone := NOT free_cylinders AND dat_low;
{   ELSE
{     space_gone :=  dat_low;
{   IFEND;
    space_was_gone := dmv$p_active_volume_table^ [avt_index].mass_storage.space_gone;
    dmv$p_active_volume_table^ [avt_index].mass_storage.space_gone := space_gone;

    status_change := (space_low <> space_was_low) OR (space_gone <> space_was_gone);
    ready_space_manager := fill_mat OR fill_dat OR empty_mat OR status_change;

    IF ready_space_manager AND dmv$vol_space_manage_initiated THEN
      tmp$monitor_ready_system_task (tmc$stid_volume_space_managemnt, status);
    IFEND;
  PROCEND update_volume_status;
?? TITLE := '  dmp$mtr_reallocate_file_space', EJECT ??

  PROCEDURE [XDCL] dmp$mtr_reallocate_file_space (VAR reallocate_request_block:
    dmt$monitor_rb_reallocate_space);

    VAR
      able_to_log: boolean,
      al_entry: dmt$al_entry,
      allocation_allowed: boolean,
      allocation_style: dmt$allocation_styles,
      allocation_unit_found: boolean,
      allocation_units_obtained: integer,
      avt_entry_found: boolean,
      avt_index: dmt$active_volume_table_index,
      bytes_per_allocation: dmt$bytes_per_allocation,
      dau_address: dmt$dau_address,
      daus_per_allocation_unit: dmt$daus_per_position,
      device_file_list_index: dmt$device_file_list_index,
      global_file_name: dmt$global_file_name,
      incomplete_allocation: boolean,
      length: integer,
      logging_required_for_file_type: boolean,
      p_attributes: ^array [ * ] of dmt$assigned_ms_vol_attribute,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fau_entry: ^dmt$file_allocation_unit,
      p_fde: ^gft$file_descriptor_entry,
      p_mat: ^dmt$mainframe_allocation_table,
      p_next_fau: ^dmt$file_allocation_unit,
      p_existing_fmd: ^dmt$file_medium_descriptor,
      p_previous_fau_entry: ^dmt$file_allocation_unit,
      previous_dau_address: dmt$dau_address,
      reallocate_byte_address: amt$file_byte_address,
      dmv$reallocations: [XDCL] integer := 0;

    reallocate_request_block.status.normal := TRUE;

    p_fde := reallocate_request_block.p_fde;
    reallocate_request_block.allocation_units_obtained := 0;
    reallocate_byte_address := reallocate_request_block.reallocate_byte_address;
    global_file_name := reallocate_request_block.global_file_name;
    logging_required_for_file_type := (p_fde^.file_kind <= gfc$fk_last_permanent_file);
    allocation_units_obtained := 0;
    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
    dmp$get_fau_entry (p_dfd, reallocate_byte_address, p_fau_entry);
    IF p_fau_entry = NIL THEN
      mtp$set_status_abnormal (dmc$device_manager_ident, dme$file_alloc_descrip_overflow,
            reallocate_request_block.status);
      mtp$error_stop ('FAD overflow - dmp$reallocate_file_space.');
    IFEND;
    dmp$get_fmd_by_index (p_dfd, p_fau_entry^.fmd_index, p_existing_fmd);
    allocation_style := p_existing_fmd^.allocation_style;
    device_file_list_index := p_existing_fmd^.dfl_index;
    avt_index := p_existing_fmd^.avt_index;

  /process_request/
    BEGIN

      { get assigned volume information

      PUSH p_attributes: [1 .. 1];
      p_attributes^ [1].keyword := dmc$ms_allocation_allowed;

      dmp$get_active_vol_attributes (dmv$null_vsn, avt_index, p_attributes, avt_entry_found);
      IF NOT avt_entry_found THEN
        mtp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
              reallocate_request_block.status);
        EXIT /process_request/;
      IFEND;

      allocation_allowed := p_attributes^ [1].allocation_allowed;
      dmp$get_mat_pointer (avt_index, p_mat);

      IF (p_mat = NIL) THEN
        mtp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_alloc_all_space,
              reallocate_request_block.status);
        EXIT /process_request/;
      IFEND;

      daus_per_allocation_unit := p_mat^.daus_per_allocation_unit [allocation_style];
      bytes_per_allocation := p_mat^.bytes_per_dau * daus_per_allocation_unit;

      incomplete_allocation := TRUE;

      IF allocation_allowed THEN

        IF (p_fau_entry^.state <> dmc$fau_invalid_and_flawed) AND
          (p_fau_entry^.state <> dmc$fau_initialized_and_flawed) THEN
          {return with normal status - no reallocation is required
          EXIT /process_request/;
        IFEND;

        IF reallocate_request_block.copy_pages THEN
          length := p_fde^.eoi_byte_address - reallocate_byte_address;
          IF (length > bytes_per_allocation) THEN
            length := bytes_per_allocation;
          IFEND;
        ELSE
          length := 0;
        IFEND;

        IF (length > 0) THEN
          mmp$modify_pages (p_fde, reallocate_byte_address, length, FALSE, reallocate_request_block.status);

          IF NOT reallocate_request_block.status.normal THEN
            EXIT /process_request/;
          IFEND;
        IFEND;

        { allocate space

        al_entry.kind := dmc$al_reallocate;
        al_entry.avt_index := avt_index;
        al_entry.reallocate_block.global_file_name := global_file_name;
        al_entry.reallocate_block.dfl_index := device_file_list_index;
        al_entry.reallocate_block.daus_per_allocation := daus_per_allocation_unit;
        al_entry.reallocate_block.old_dau_address := p_fau_entry^.dau_address;

        dmp$get_previous_fau_entry (p_dfd, reallocate_byte_address, p_fau_entry^.fmd_index,
            p_previous_fau_entry);
        IF p_previous_fau_entry <> NIL THEN
          previous_dau_address := p_previous_fau_entry^.dau_address;
        ELSE
          previous_dau_address := 0;
        IFEND;

        dmp$get_next_fmd_fau (p_dfd, reallocate_byte_address, p_fau_entry^.fmd_index,
            p_next_fau);
        IF (p_next_fau = NIL) OR (p_next_fau^.state = dmc$fau_free) THEN
          IF previous_dau_address = 0 THEN
            al_entry.reallocate_block.allocation_chain_position :=
              dmc$first_and_last_allocation;
          ELSE
            al_entry.reallocate_block.allocation_chain_position := dmc$last_allocation;
          IFEND;
          al_entry.reallocate_block.next_dau_address := 0;
        ELSE
          IF previous_dau_address = 0 THEN
            al_entry.reallocate_block.allocation_chain_position := dmc$first_allocation;
          ELSE
            al_entry.reallocate_block.allocation_chain_position := dmc$middle_allocation;
          IFEND;
          al_entry.reallocate_block.next_dau_address := p_next_fau^.dau_address;
        IFEND;

        assign_allocation_unit (p_mat, allocation_style, previous_dau_address, dau_address,
              allocation_unit_found);
        IF allocation_unit_found THEN
          IF logging_required_for_file_type THEN
            al_entry.reallocate_block.dau_address := dau_address;
            al_entry.reallocate_block.previous_dau_address := previous_dau_address;
            dmp$mtr_log (al_entry, able_to_log);
            IF NOT able_to_log THEN
              release_allocation_unit (p_mat, allocation_style, dau_address);
              mtp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_alloc_all_space,
                    reallocate_request_block.status);
              EXIT /process_request/;
            IFEND;
          IFEND;
          dmv$reallocations := dmv$reallocations + 1;
          p_fau_entry^.dau_address := dau_address;
          p_fau_entry^.state := dmc$fau_invalid_data;
          allocation_units_obtained := allocation_units_obtained + 1;

          IF (length > 0) THEN
            mmp$modify_pages (p_fde, reallocate_byte_address, length, TRUE, reallocate_request_block.status);
          IFEND;
        IFEND;

        { update the request block parameters.

        reallocate_request_block.allocation_units_obtained := allocation_units_obtained;

        { update mat information.

        p_mat^.allocated_space [p_fde^.file_kind] := (p_mat^.allocated_space [p_fde^.file_kind] +
              (daus_per_allocation_unit * allocation_units_obtained)) MOD (dmc$max_dau_address + 1);

        incomplete_allocation := (allocation_units_obtained = 0);
      IFEND;

      IF incomplete_allocation THEN

        { set status to indicate unable to allocate all space
        { from the mat.

        mtp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_alloc_all_space,
              reallocate_request_block.status);
      IFEND;

      update_volume_status (p_mat);

    END /process_request/;

  PROCEND dmp$mtr_reallocate_file_space;
MODEND dmm$monitor_allocator;
*DECK DECK=DMM$MONITOR_UTILITIES EXPAND=TRUE
?? RIGHT := 110 ??
*copy osd$default_pragmats
?? NEWTITLE := 'NOSVE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$monitor_utilities;
?? TITLE := '  Common Decks', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table
*copyc dmt$debug_actions
*copyc dmt$sc_flaw_command
*copyc gfc$constants
*copyc gft$system_file_identifier
*copyc oss$mainframe_wired
*copyc rmd$volume_declarations
*copyc rmc$mass_storage_class
?? POP ??
?? TITLE := '  XDCL Variables', EJECT ??

  VAR
    dmv$p_active_volume_table: [XDCL, STATIC, #GATE, oss$mainframe_wired] ^dmt$active_volume_table := NIL;


  VAR
    dmv$debug_options: [XDCL, STATIC, #GATE, oss$mainframe_wired] dmt$debug_actions := [];


  VAR
    dmv$split_allocation_log_delay: [XDCL, STATIC, #GATE, oss$mainframe_wired] 0 .. 0ffffffffffff(16) :=
      0ffffffffffff(16),

    dmv$process_device_log_delay: [XDCL, STATIC, #GATE, oss$mainframe_wired] 0 .. 0ffffffffffff(16) :=
      07530(16),

    dmv$manage_volume_space_delay: [XDCL, STATIC, #GATE, oss$mainframe_wired] 0 .. 0ffffffffffff(16) :=
      0ffffffffffff(16),

    dmv$volume_table_space_delay: [XDCL, STATIC, #GATE, oss$mainframe_wired] 0 .. 0ffffffffffff(16) :=
      0ffffffffffff(16);


  VAR
    dmv$split_allocation_log_count: [XDCL, STATIC, #GATE, oss$mainframe_wired] integer := 0,

    dmv$process_device_log_count: [XDCL, STATIC, #GATE, oss$mainframe_wired] integer := 0,

    dmv$log_entries_max_thresehold: [XDCL, STATIC, #GATE, oss$mainframe_wired] integer := 750,

    dmv$mainframe_recovered: [XDCL, STATIC, #GATE, oss$mainframe_wired] boolean := FALSE,

    dmv$manage_volume_space_count: [XDCL, STATIC, #GATE, oss$mainframe_wired] integer := 0;


  VAR
{ The following 3 constants are used for dump analysis purposes ONLY.
    gfv$fde_control_table_base : [XDCL, STATIC, READ, #GATE, oss$mainframe_wired] integer :=
         gfc$fde_control_table_base,
    gfv$fde_table_base : [XDCL, STATIC, READ, #GATE, oss$mainframe_wired] integer := gfc$fde_table_base,
    gfv$fde_size : [XDCL, STATIC, READ, #GATE, oss$mainframe_wired] integer := gfc$fde_size,

    gfv$null_sfid: [XDCL, STATIC, READ, #GATE, oss$mainframe_wired] gft$system_file_identifier :=
      [0, gfc$tr_null_residence, gfc$null_file_hash],

    dmv$null_sfid: [XDCL, STATIC, READ, #GATE, oss$mainframe_wired] gft$system_file_identifier :=
      [0, gfc$tr_null_residence, gfc$null_file_hash];

  VAR
    dmv$recycle_device_log: [STATIC, XDCL, #GATE, oss$mainframe_wired] boolean := TRUE,

    dmv$recycled_log: [STATIC, XDCL, #GATE, oss$mainframe_wired] integer := 0,
    dmv$skipped_recycle_of_log: [STATIC, XDCL, #GATE, oss$mainframe_wired] integer := 0,

    dmv$null_vsn: [XDCL, STATIC, READ, #GATE, oss$mainframe_wired] rmt$recorded_vsn := '';

  VAR
    dmv$external_interrupt_selector: [XDCL, #GATE] 0 .. 0ff(16) := 1,

    dmv$system_class: [XDCL, #GATE] dmt$class := $dmt$class [
      rmc$msc_system_swap_files, rmc$msc_user_temporary_files,
      rmc$msc_system_critical_files],

    dmv$system_class_conversion : [XDCL, #GATE] array [dmt$class_member] of
      dmt$system_class := [*, *, dmc$swap_files, REP 10 OF *, dmc$temporary_files, *, *,
        dmc$critical_files, REP 9 OF *];

  VAR
    dmv$p_sc_flaw_commands: [XDCL, STATIC, #GATE, oss$mainframe_wired] ^array [1 .. *] of
       dmt$sc_flaw_command := NIL;

MODEND dmm$monitor_utilities;
*DECK DECK=DMM$MTR_FRONT_ENDS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOSVE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$mtr_front_ends;

{ PURPOSE:
{   This module prepares the request block parameters for the
{   DM monitor requests.
{ DESIGN:
{   The request block parameters are prepared using the supplied system file
{   id and inserted into the request block.
?? PUSH (LISTEXT := ON) ??
?? TITLE := '  Common Decks', EJECT ??
*copyc dmp$allocate_file_space
*copyc dmp$deallocate_file_space
*copyc dmp$mtr_reallocate_file_space
*copyc dmp$get_fmd_by_index
*copyc dmp$mtr_log
*copyc dmt$allocation_log
*copyc dmt$error_condition_codes
*copyc dmt$file_medium_descriptor
*copyc dmt$file_table_lock
*copyc dmt$monitor_request_blocks
*copyc gfp$mtr_get_locked_fde_p
*copyc gft$file_descriptor_entry
*copyc mmv$last_segment_accessed
*copyc mtc$job_fixed_segment
*copyc mtp$cst_p
*copyc mtp$error_stop
*copyc mtp$set_status_abnormal
*copyc ost$heap
*copyc syt$monitor_request_code
*copyc syt$monitor_status
?? POP ??
?? TITLE := '  dmp$mtr_allocate_front_end', EJECT ??
*copy dmh$mtr_allocate_front_end

  PROCEDURE [XDCL] dmp$mtr_allocate_front_end (
    VAR allocate_request_block: dmt$monitor_rb_allocate_space;
        p_cst: ^ost$cpu_state_table);


    VAR
      allocate_byte_address: amt$file_byte_address,
      allocation_units_obtained: amt$file_byte_address,
      file_space_limit: sft$file_space_limit_kind,
      overflow_indicator: boolean,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: gft$locked_file_desc_entry_p,
      requested_allocation: amt$file_byte_address,
      status: dmt$file_allocation_status,
      system_file_id: gft$system_file_identifier;

    IF allocate_request_block.update_fat_pointer THEN
      p_dfd := allocate_request_block.p_dfd;
      IF (#SEGMENT (p_dfd) <> osc$segnum_mainframe_wired) THEN
        p_dfd := #ADDRESS (1, p_cst^.ijle_p^.ajl_ordinal + mtc$job_fixed_segment, #OFFSET (p_dfd));
      IFEND;
      p_dfd^.file_allocation_table := allocate_request_block.p_fat;
      p_dfd^.fat_upper_bound := allocate_request_block.fat_upper_bound;
    ELSE
      mmv$last_segment_accessed := 0; {for file limits}
      system_file_id := allocate_request_block.system_file_id;

{
{               locate file descriptor
{
      gfp$mtr_get_locked_fde_p (system_file_id, p_cst^.ijle_p, p_fde);

      allocate_byte_address := allocate_request_block.allocate_byte_address;
      requested_allocation := allocate_request_block.requested_allocation;
      file_space_limit := allocate_request_block.file_space_limit;

      dmp$allocate_file_space (p_fde, allocate_byte_address, requested_allocation,
          file_space_limit, allocation_units_obtained, overflow_indicator, status);

      allocate_request_block.allocation_units_obtained := allocation_units_obtained;
      allocate_request_block.overflow_indicator := overflow_indicator;
      allocate_request_block.status := status;
    IFEND;
  PROCEND dmp$mtr_allocate_front_end;
?? TITLE := '  dmp$mtr_deallocate_front_end', EJECT ??
*copy dmh$mtr_deallocate_front_end

  PROCEDURE [XDCL] dmp$mtr_deallocate_front_end (
    VAR deallocate_request_block: dmt$monitor_rb_deallocate_space;
        p_cst: ^ost$cpu_state_table);

    VAR
      able: boolean,
      al_entry: dmt$al_entry,
      p_fde: gft$locked_file_desc_entry_p,
      system_file_id: gft$system_file_identifier;

    deallocate_request_block.status.normal := TRUE;
    system_file_id := deallocate_request_block.system_file_id;

    gfp$mtr_get_locked_fde_p (system_file_id, p_cst^.ijle_p, p_fde);

    IF deallocate_request_block.status.normal THEN
      CASE deallocate_request_block.monitor_request OF
      = dmc$deallocate_space =
        dmp$deallocate_file_space (p_fde, deallocate_request_block.release_byte_address,
             deallocate_request_block.bytes_to_release);
      = dmc$trim_file_space =
        al_entry.kind := dmc$al_trim_file;
        al_entry.avt_index := deallocate_request_block.avt_index;
        al_entry.trim_file_block.global_file_name := deallocate_request_block.global_file_name;
        al_entry.trim_file_block.dfl_index := deallocate_request_block.dfl_index;
        al_entry.trim_file_block.dau_address := deallocate_request_block.dau_address;
        al_entry.trim_file_block.dau_of_fragment := deallocate_request_block.dau_of_fragment;

        dmp$mtr_log (al_entry, able);
        IF NOT able THEN
          mtp$set_status_abnormal (dmc$device_manager_ident, dme$transient_error,
             deallocate_request_block.status);
        IFEND;

      ELSE
        mtp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_monitor_call,
           deallocate_request_block.status);
      CASEND;
    IFEND;

  PROCEND dmp$mtr_deallocate_front_end;
?? TITLE := '  dmp$mtr_reallocate_front_end', EJECT ??

  PROCEDURE [XDCL] dmp$mtr_reallocate_front_end (
    VAR reallocate_request_block: dmt$monitor_rb_reallocate_space;
        p_cst: ^ost$cpu_state_table);

    VAR
      p_fde: gft$locked_file_desc_entry_p,
      system_file_id: gft$system_file_identifier;

    reallocate_request_block.status.normal := TRUE;

  /process_request/
    BEGIN
      system_file_id := reallocate_request_block.system_file_id;

{
{               locate file descriptor
{
      gfp$mtr_get_locked_fde_p (system_file_id, p_cst^.ijle_p, p_fde);

      reallocate_request_block.p_fde := p_fde;
      reallocate_request_block.global_file_name := p_fde^.global_file_name;

      dmp$mtr_reallocate_file_space (reallocate_request_block);

    END /process_request/;
  PROCEND dmp$mtr_reallocate_front_end;

MODEND dmm$mtr_front_ends;
*DECK DECK=DMM$MTR_RECOVER_JOB_DM_TABLES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'dmm$mtr_recover_job_dm_tables' ??
MODULE dmm$mtr_recover_job_dm_tables;

?? PUSH (LISTEXT := ON) ??
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_fmd_by_index
*copyc dmv$active_volume_table
*copyc gfp$mtr_scan_all_fdes
*copyc jmt$job_control_block
*copyc mmv$ast_p
*copyc mtp$error_stop
?? POP ??

  VAR
    syv$job_recovery_fde_fixup: [XDCL] integer := 0;

?? TITLE := '  dmp$recover_job_dm_tables', EJECT ??

  PROCEDURE [XDCL] dmp$recover_job_dm_tables
    (    ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      fmd_number: dmt$fmd_index,
      number_of_fmds: dmt$fmd_index,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      p_fmd: ^dmt$file_medium_descriptor,
      scan_control: gft$scan_all_fdes_state;

    gfp$mtr_scan_all_fdes (gfc$tr_job, ijle_p, scan_control, p_fde);

    WHILE p_fde <> NIL DO

      IF p_fde^.media = gfc$fm_mass_storage_file THEN
        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
        IF p_dfd^.read_write_count <> 0 THEN
          p_dfd^.read_write_count := 0;
          syv$job_recovery_fde_fixup := syv$job_recovery_fde_fixup + 1;
        IFEND;

        number_of_fmds := p_dfd^.number_of_fmds;
        FOR fmd_number := 1 TO number_of_fmds DO
          dmp$get_fmd_by_index (p_dfd, fmd_number, p_fmd);
          IF (p_fmd <> NIL) AND (p_fmd^.in_use) AND (p_fmd^.volume_assigned) THEN
            find_volume (p_fmd^.internal_vsn, p_fmd^.avt_index);
          IFEND;
        FOREND;
      IFEND;

{  The following check is required in the event that job recovery is being attempted
{  on a system which has less memory than the previous deadstart. If this segment had
{  an  AST entry which is greater than the current AST length, a new entry must be made.
{  An asti of zero is stored in the FDE.

      IF (p_fde^.asti > UPPERBOUND (mmv$ast_p^)) THEN
        p_fde^.asti := 0;
      IFEND;

      p_fde^.segment_lock.locked_for_read := 0;
      p_fde^.segment_lock.locked_for_write := FALSE;
      p_fde^.segment_lock.task_queue.head := 0;
      p_fde^.segment_lock.task_queue.tail := 0;

      gfp$mtr_scan_all_fdes (gfc$tr_null_residence, ijle_p, scan_control, p_fde);
    WHILEND;

  PROCEND dmp$recover_job_dm_tables;

?? TITLE := '  find_volume', EJECT ??

  PROCEDURE find_volume
    (    internal_vsn: dmt$internal_vsn;
     VAR avt_index: dmt$active_volume_table_index);

    VAR
      avti: dmt$active_volume_table_index;

    FOR avti := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND (dmv$p_active_volume_table^) DO
      IF NOT dmv$p_active_volume_table^ [avti].entry_available THEN
        IF dmv$p_active_volume_table^ [avti].mass_storage.internal_vsn =
             internal_vsn THEN
          avt_index := avti;
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    mtp$error_stop ('Cannot find volume for recovering job');

  PROCEND find_volume;
MODEND dmm$mtr_recover_job_dm_tables;
*DECK DECK=DMM$RECONCILE_FMD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$reconcile_fmd;

{
{ PURPOSE:
{
{  The purpose of this module is to perform the Device Management functions
{  necessary to reconcile the files known to Permanent File Manager with
{  those known to Device Manager.
{
{ DESIGN:
{
{  Permanent File Manager performs the reconciliation process as follows.
{
{    1. Builds a list of all files known to Device Manager
{       (dmp$build_sorted_dfl).
{
{    2. Reports files found in permanent file catalogs (dmp$reconcile_fmd),
{       deleting any not known to Device Manager and updating the FMD for
{       those requiring it (dmp$get_reconciled_fmd).
{
{    3. Deletes any files in the Device Management list that have not been
{       reconciled (dmp$device_file_list_update).  Some files may be marked
{       for deletion when they are reconciled (e.g. catalogs).
{
?? TITLE := '  Common Decks', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$put_job_output
*copyc dmp$close_dfl_r3
*copyc dmp$destroy_sub_file
*copyc dmp$dev_mgmt_table_update
*copyc dmp$open_dfl_r3
*copyc dmp$save_reconcile_list
*copyc dmp$search_avt_by_vsn
*copyc dmp$update_reconcile_list
*copyc dmt$error_condition_codes
*copyc dmt$global_file_name
*copyc dmt$reconcile_locator
*copyc dmt$reconcile_info
*copyc dmt$stored_fmd
*copyc dmt$stored_fmd_size
*copyc dmt$stored_ms_fmd_header
*copyc dmt$fmd_index
*copyc dmv$active_volume_table
*copyc dmv$reconciliation_lock
*copyc dmv$reconcile_locator
*copyc mmp$delete_scratch_segment
*copyc mmp$create_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$clear_job_signature_lock
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc ost$name
*copyc ost$status
*copyc ost$string
*copyc pfp$log_ascii
*copyc pfp$log_error
*copyc pmp$convert_binary_unique_name
*copyc pmp$get_legible_date_time
*copyc pmp$get_microsecond_clock
*copyc rmc$mass_storage_class
*copyc std$set_name
*copyc ste$error_condition_codes
*copyc stp$get_volumes_in_set
*copyc stp$search_ast_by_internal_vsn
?? POP ??
?? TITLE := '  Global Declarations', EJECT ??

  TYPE
    dmt$compare_status = (less, equal, greater),
    switch_values = (switch_sides, switch_areas, switch_compare);

?? TITLE := '  dmp$add_to_sorted_dfl', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$add_to_sorted_dfl (lun: iot$logical_unit;
    VAR status: ost$status);

    VAR
      avt_index: dmt$active_volume_table_index,
      close_status: ost$status,
      dfl_index: dmt$device_file_list_index,
      dfl_entry: dmt$ms_device_file_list_entry,
      last_avt_index: dmt$active_volume_table_index,
      p_dfl: ^dmt$ms_device_file_list_table,
      p_sequence: ^SEQ ( * ),
      p_old_reconcile_info,
      p_reconcile_info: ^dmt$reconcile_info,
      added_fmd_count,
      fmd_count: dmt$reconcile_index,
      reconcile_entry: dmt$reconcile_entry,
      p_reconcile_entry: ^dmt$reconcile_entry,
      segment_length: ost$segment_length,
      segment_pointer: amt$segment_pointer,
      vsn: rmt$recorded_vsn;

    status.normal := TRUE;

    avt_index := LOWERBOUND (dmv$p_active_volume_table^);
    last_avt_index := UPPERBOUND (dmv$p_active_volume_table^);

    WHILE (avt_index <= last_avt_index) AND
          (dmv$p_active_volume_table^ [avt_index].entry_available OR
          (dmv$p_active_volume_table^ [avt_index].logical_unit_number <> lun)) DO
       avt_index := avt_index + 1;
    WHILEND;

    IF (avt_index > last_avt_index) THEN {not found}
      RETURN;
    IFEND;

    osp$set_job_signature_lock (dmv$reconciliation_lock);
    dmp$dev_mgmt_table_update;
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, segment_pointer, status);
    IF NOT status.normal THEN
      osp$clear_job_signature_lock (dmv$reconciliation_lock);
      RETURN;
    IFEND;
    p_sequence := segment_pointer.sequence_pointer;

    RESET p_sequence;
    NEXT p_reconcile_info IN p_sequence;

    IF dmv$reconcile_locator <> NIL THEN
      {Copy existing reconcile list to new list
      p_old_reconcile_info := dmv$reconcile_locator;
      fmd_count := UPPERBOUND (p_old_reconcile_info^.p_sorted_reconcile_list^) -
          LOWERBOUND (p_old_reconcile_info^.p_sorted_reconcile_list^) + 1;
      NEXT p_reconcile_info^.p_sorted_reconcile_list: [1 .. fmd_count] IN p_sequence;
      p_reconcile_info^.p_sorted_reconcile_list^ := p_old_reconcile_info^.p_sorted_reconcile_list^;
    ELSE
      fmd_count := 0;
    IFEND;

    vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;

    dmp$open_dfl_r3 (vsn, p_dfl, status);
    IF NOT status.normal THEN
      mmp$delete_scratch_segment (segment_pointer, close_status);
      osp$clear_job_signature_lock (dmv$reconciliation_lock);
      RETURN;
    IFEND;

    added_fmd_count := 0;
  /dfl_open/
    FOR dfl_index := 1 TO UPPERBOUND (p_dfl^.entries) DO
      dfl_entry := p_dfl^.entries [dfl_index];
      IF (dfl_entry.flags = dmc$dfle_assigned_to_file) AND
            ((dfl_entry.file_kind = gfc$fk_job_permanent_file) OR
            (dfl_entry.file_kind = gfc$fk_catalog)) THEN
        reconcile_entry.global_file_name := dfl_entry.global_file_name;
        reconcile_entry.byte_address := dfl_entry.file_byte_address;
        reconcile_entry.avt_index := avt_index;
        reconcile_entry.dfl_index := dfl_index;
        reconcile_entry.reconciled := FALSE;
        reconcile_entry.purge := TRUE;
        NEXT p_reconcile_entry IN p_sequence;
        p_reconcile_entry^ := reconcile_entry;
        fmd_count := fmd_count + 1;
        added_fmd_count := added_fmd_count + 1;
      IFEND;
    FOREND /dfl_open/;

    dmp$close_dfl_r3 (p_dfl, status);
    IF NOT status.normal THEN
      mmp$delete_scratch_segment (segment_pointer, close_status);
      osp$clear_job_signature_lock (dmv$reconciliation_lock);
      RETURN;
    IFEND;

    IF added_fmd_count = 0 THEN
      mmp$delete_scratch_segment (segment_pointer, close_status);
      osp$clear_job_signature_lock (dmv$reconciliation_lock);
      RETURN;
    IFEND;

    {Sort the reconcile_list.
    RESET p_sequence;
    NEXT p_reconcile_info IN p_sequence;
    NEXT p_reconcile_info^.p_sorted_reconcile_list: [1 .. fmd_count] IN p_sequence;
    heap_sort (p_reconcile_info^.p_sorted_reconcile_list);
    {Copy the reconcile_list to mainframe_pageable.
    dmp$save_reconcile_list (p_reconcile_info^);
    mmp$delete_scratch_segment (segment_pointer, close_status);

    osp$clear_job_signature_lock (dmv$reconciliation_lock);

  PROCEND dmp$add_to_sorted_dfl;
?? TITLE := '  dmp$build_sorted_dfl', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$build_sorted_dfl (set_name: stt$set_name;
    VAR reconcile_locator: dmt$reconcile_locator;
    VAR status: ost$status);

    CONST
      five_minutes = 1000000 * 60 * 5;

    VAR
      avt_index: dmt$active_volume_table_index,
      base: integer,
      clock: integer,
      close_status: ost$status,
      date: ost$date,
      dfl_index: dmt$device_file_list_index,
      dfl_entry: dmt$ms_device_file_list_entry,
      l: integer,
      local_stat: ost$status,
      msg: string (70),
      p_dfl: ^dmt$ms_device_file_list_table,
      p_sequence: ^SEQ ( * ),
      p_reconcile_info: ^dmt$reconcile_info,
      fmd_count: dmt$reconcile_index,
      reconcile_entry: dmt$reconcile_entry,
      p_reconcile_entry: ^dmt$reconcile_entry,
      segment_length: ost$segment_length,
      segment_pointer: amt$segment_pointer,
      time: ost$time,
      vsn: rmt$recorded_vsn;

    osp$set_job_signature_lock (dmv$reconciliation_lock);
    dmp$dev_mgmt_table_update;
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, segment_pointer, status);
    IF NOT status.normal THEN
      osp$clear_job_signature_lock (dmv$reconciliation_lock);
      RETURN;
    IFEND;
    p_sequence := segment_pointer.sequence_pointer;

    RESET p_sequence;
    NEXT p_reconcile_info IN p_sequence;
    p_reconcile_info^.p_sorted_reconcile_list := NIL;

    {Add an entry to the reconcile list for every dfl entry on every active mass storage device.

    base := 0;
    msg (1, *) := ' ';
    fmd_count := 0;
    FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND (dmv$p_active_volume_table^) DO
      IF NOT dmv$p_active_volume_table^ [avt_index].entry_available AND
            NOT dmv$p_active_volume_table^ [avt_index].mass_storage.volume_unavailable AND
            (dmv$p_active_volume_table^ [avt_index].mass_storage.set_name <> osc$null_name) THEN

        vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;

        pmp$get_microsecond_clock (clock, local_stat);
        IF local_stat.normal AND (clock > (base + five_minutes)) THEN
          base := clock;
          pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, local_stat);
          IF local_stat.normal THEN
            STRINGREP (msg, l, '...scanning ', vsn, ' ', date.mdy, ' ', time.hms);
            clp$put_job_output (msg (1, l), local_stat);
            msg (1,*) := ' ';
          IFEND;
        IFEND;

        dmp$open_dfl_r3 (vsn, p_dfl, status);
        IF NOT status.normal THEN
          mmp$delete_scratch_segment (segment_pointer, close_status);
          osp$clear_job_signature_lock (dmv$reconciliation_lock);
          RETURN;
        IFEND;

        FOR dfl_index := 1 TO UPPERBOUND (p_dfl^.entries) DO
          dfl_entry := p_dfl^.entries [dfl_index];

          IF (dfl_entry.flags = dmc$dfle_assigned_to_file) AND
                ((dfl_entry.file_kind = gfc$fk_job_permanent_file) OR
                (dfl_entry.file_kind = gfc$fk_catalog)) THEN
            reconcile_entry.global_file_name := dfl_entry.global_file_name;
            reconcile_entry.byte_address := dfl_entry.file_byte_address;
            reconcile_entry.avt_index := avt_index;
            reconcile_entry.dfl_index := dfl_index;
            reconcile_entry.reconciled := FALSE;
            reconcile_entry.purge := TRUE;

            NEXT p_reconcile_entry IN p_sequence;
            p_reconcile_entry^ := reconcile_entry;
            fmd_count := fmd_count + 1;
          IFEND;
        FOREND;

        dmp$close_dfl_r3 (p_dfl, status);
        IF NOT status.normal THEN
          mmp$delete_scratch_segment (segment_pointer, close_status);
          osp$clear_job_signature_lock (dmv$reconciliation_lock);
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    {Sort the reconcile_list.

    IF fmd_count > 0 THEN
      RESET p_sequence;
      NEXT p_reconcile_info IN p_sequence;
      NEXT p_reconcile_info^.p_sorted_reconcile_list : [1 .. fmd_count] IN p_sequence;
      heap_sort (p_reconcile_info^.p_sorted_reconcile_list);

      {Copy the reconcile_list to mainframe_pageable.

      dmp$save_reconcile_list (p_reconcile_info^);
    IFEND;

    mmp$delete_scratch_segment (segment_pointer, close_status);
    osp$clear_job_signature_lock (dmv$reconciliation_lock);

  PROCEND dmp$build_sorted_dfl;
?? TITLE := '  dmp$device_file_list_update', EJECT ??

  PROCEDURE [XDCL] dmp$device_file_list_update
   (    set_name: stt$set_name;
    VAR status: ost$status);

    CONST
      critical_message = TRUE,
      message_origin = pmc$msg_origin_recovery;

    VAR
      avt_index: dmt$active_volume_table_index,
      gfn: dmt$global_file_name,
      vsn: rmt$recorded_vsn,
      dfl_index: dmt$device_file_list_index,
      byte_address: amt$file_byte_address,
      local_status: ost$status,
      p_reconcile_info: ^dmt$reconcile_info,
      p_reconcile_list: dmt$p_reconcile_list,
      reconcile_entry: dmt$reconcile_entry,
      index: dmt$reconcile_index;

    osp$set_job_signature_lock (dmv$reconciliation_lock);
    status.normal := TRUE;
    IF dmv$reconcile_locator = NIL THEN
      osp$clear_job_signature_lock (dmv$reconciliation_lock);
      RETURN;
    IFEND;
    p_reconcile_info := dmv$reconcile_locator;
    p_reconcile_list := p_reconcile_info^.p_sorted_reconcile_list;

    FOR index := 1 TO UPPERBOUND (p_reconcile_list^) DO
      reconcile_entry := p_reconcile_list^ [index];
      avt_index := reconcile_entry.avt_index;

      IF reconcile_entry.purge AND
            (dmv$p_active_volume_table^ [avt_index].mass_storage.set_name = set_name) THEN
        gfn := reconcile_entry.global_file_name;
        vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;
        dfl_index := reconcile_entry.dfl_index;
        byte_address := reconcile_entry.byte_address;

        dmp$destroy_sub_file (gfn, vsn, dfl_index, byte_address, local_status);
        IF NOT local_status.normal THEN
          status := local_status;
          pfp$log_error (status, - $pmt$ascii_logset [], message_origin, critical_message);
        IFEND;

        IF NOT reconcile_entry.reconciled THEN
          {Just ignore
        IFEND;
      IFEND;
    FOREND;

    IF NOT status.normal THEN
      pfp$log_ascii ('Previous error(s) from dmp$destroy_sub_file.', - $pmt$ascii_logset [], message_origin,
            critical_message, local_status);
    IFEND;
    osp$clear_job_signature_lock (dmv$reconciliation_lock);
  PROCEND dmp$device_file_list_update;
?? TITLE := '  dmp$get_reconciled_fmd', EJECT ??

  PROCEDURE [XDCL] dmp$get_reconciled_fmd (reconcile_locator: dmt$reconcile_locator;
        gfn: dmt$global_file_name;
        old_fmd: dmt$stored_fmd;
    VAR new_fmd: dmt$stored_fmd;
    VAR status: ost$status);

    VAR
      p_reconcile_info: ^dmt$reconcile_info,
      p_reconcile_list: dmt$p_reconcile_list,
      first_fmd_index: dmt$reconcile_index,
      fmd_count: dmt$reconcile_index;

    osp$set_job_signature_lock (dmv$reconciliation_lock);
    p_reconcile_info := dmv$reconcile_locator;
    p_reconcile_list := p_reconcile_info^.p_sorted_reconcile_list;

    find_file (gfn, p_reconcile_list, first_fmd_index, fmd_count, status);
    IF status.normal THEN
      build_new_fmd (old_fmd, gfn, p_reconcile_list, first_fmd_index, fmd_count, new_fmd, status);
    IFEND;
    osp$clear_job_signature_lock (dmv$reconciliation_lock);
  PROCEND dmp$get_reconciled_fmd;
?? TITLE := '  dmp$reconcile_fmd', EJECT ??

  PROCEDURE [XDCL] dmp$reconcile_fmd (reconcile_locator: dmt$reconcile_locator;
        gfn: dmt$global_file_name;
        fmd: dmt$stored_fmd;
        purge_file: boolean;
    VAR device_class: dmt$class;
    VAR new_fmd_size: dmt$stored_fmd_size;
    VAR resides_on_set_master: boolean;
    VAR status: ost$status);

    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index,
      avt_index: dmt$active_volume_table_index,
      first_fmd_index: dmt$reconcile_index,
      fmd_byte_address: amt$file_byte_address,
      fmd_count: dmt$reconcile_index,
      fmd_dfl_index: dmt$device_file_list_index,
      fmd_fmd_count: dmt$reconcile_index,
      fmd_fmd_index: dmt$fmd_index,
      fmd_index: dmt$reconcile_index,
      fmd_internal_vsn: dmt$internal_vsn,
      fmd_ok: boolean,
      fmd_recorded_vsn: rmt$recorded_vsn,
      fmds_not_reconciled: integer,
      fmds_with_vol_unavailable: integer,
      fmds_with_volume_missing: integer,
      found: boolean,
      internal_vsn_name: ost$name,
      kludge: ^dmt$stored_ms_fmd_header,
      master_info: stt$volume_info,
      member_count: stt$number_of_members,
      member_list: ^stt$volume_list,
      p_fmd_header: ^dmt$stored_ms_fmd_header,
      p_fmd_subfile: ^dmt$stored_ms_fmd_subfile,
      p_fmd_subfile_list: ^dmt$stored_fmd,
      p_reconcile_info: ^dmt$reconcile_info,
      p_reconcile_list: dmt$p_reconcile_list,
      reconcile_entry: dmt$reconcile_entry,
      recorded_vsn: rmt$recorded_vsn;

    osp$set_job_signature_lock (dmv$reconciliation_lock);
    IF dmv$reconcile_locator = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unknown_file, 'Unknown file.', status);
      osp$clear_job_signature_lock (dmv$reconciliation_lock);
      RETURN;
    IFEND;
    p_reconcile_info := dmv$reconcile_locator;
    p_reconcile_list := p_reconcile_info^.p_sorted_reconcile_list;
    fmds_with_volume_missing := 0;
    fmds_with_vol_unavailable := 0;
    fmds_not_reconciled := 0;
    device_class := - $dmt$class [];

    validate_fmd (^fmd, gfn, p_fmd_header, p_fmd_subfile_list, status);
    IF status.normal THEN
      find_file (gfn, p_reconcile_list, first_fmd_index, fmd_count, status);
    IFEND;

    IF (NOT status.normal) AND (status.condition = dme$unknown_file) THEN
      NEXT p_fmd_subfile: [dmc$current_fmd_version] IN p_fmd_subfile_list;
      dmp$search_avt_by_vsn (p_fmd_subfile^.version_0_0.internal_vsn, avt_index, found);
      IF NOT found THEN
        { NONE of the fmds are present.
        osp$set_status_abnormal (dmc$device_manager_ident, dme$some_volumes_not_online,
              p_fmd_subfile^.version_0_0.recorded_vsn, status);
      ELSEIF dmv$p_active_volume_table^ [avt_index].mass_storage.volume_unavailable THEN
        { The first fmd resides on an unavailable volume.
        osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable,
              p_fmd_subfile^.version_0_0.recorded_vsn, status);
      ELSE
        stp$search_ast_by_internal_vsn (p_fmd_subfile^.version_0_0.internal_vsn, ast_entry, ast_index, found);
        IF NOT found THEN
          pmp$convert_binary_unique_name (p_fmd_subfile^.version_0_0.internal_vsn, internal_vsn_name, status);
          osp$set_status_abnormal (stc$set_management_id, ste$vol_not_found, internal_vsn_name, status);
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      FOR fmd_index := first_fmd_index TO first_fmd_index + fmd_count - 1 DO
        dmp$update_reconcile_list (fmd_index, purge_file, {reconcile =} TRUE);
      FOREND;
      PUSH member_list: [1 .. 1];
      {Just need master recorded vsn
      stp$get_volumes_in_set (p_fmd_header^.version_0_0.requested_volume.setname,
          master_info, member_list^, member_count, status);
      IF NOT status.normal THEN
        osp$clear_job_signature_lock (dmv$reconciliation_lock);
        RETURN;
      IFEND;

      PUSH p_fmd_subfile: [dmc$current_fmd_version];
      PUSH kludge: [dmc$current_fmd_version];
      new_fmd_size := #SIZE (dmt$stored_ms_version_number) + #SIZE (kludge^) + (#SIZE (p_fmd_subfile^) *
            fmd_count);
      fmd_fmd_count := p_fmd_header^.version_0_0.number_fmds;

      resides_on_set_master := FALSE;

      /reconcile_fmds/
        FOR fmd_fmd_index := 1 TO fmd_fmd_count DO
          NEXT p_fmd_subfile: [dmc$current_fmd_version] IN p_fmd_subfile_list;

          fmd_byte_address := p_fmd_subfile^.version_0_0.stored_byte_address * dmc$byte_address_converter;
          fmd_dfl_index := p_fmd_subfile^.version_0_0.device_file_list_index;
          fmd_internal_vsn := p_fmd_subfile^.version_0_0.internal_vsn;
          fmd_recorded_vsn := p_fmd_subfile^.version_0_0.recorded_vsn;
          resides_on_set_master := (fmd_recorded_vsn = master_info.recorded_vsn) OR
                resides_on_set_master;

          FOR fmd_index := first_fmd_index TO first_fmd_index + fmd_count - 1 DO
            reconcile_entry := p_reconcile_list^ [fmd_index];
            avt_index := reconcile_entry.avt_index;
            fmd_ok := (fmd_byte_address = reconcile_entry.byte_address) AND
                  (fmd_dfl_index = reconcile_entry.dfl_index) AND
                  (fmd_internal_vsn = dmv$p_active_volume_table^ [avt_index].mass_storage.internal_vsn) AND
                  (fmd_recorded_vsn = dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn);
            IF fmd_ok THEN
              {Return only the classes common to all subfile volumes
              device_class := dmv$p_active_volume_table^ [avt_index].mass_storage.class * device_class;
              CYCLE /reconcile_fmds/;
            IFEND;
          FOREND;
          {Subfile not found - check for missing volume
          dmp$search_avt_by_vsn (fmd_internal_vsn, avt_index, found);
          IF NOT found THEN
             fmds_with_volume_missing := fmds_with_volume_missing + 1;
            recorded_vsn := fmd_recorded_vsn;
          ELSEIF dmv$p_active_volume_table^ [avt_index].mass_storage.volume_unavailable THEN
            fmds_with_vol_unavailable := fmds_with_vol_unavailable + 1;
            recorded_vsn := fmd_recorded_vsn;
          ELSE
            fmds_not_reconciled := fmds_not_reconciled + 1;
          IFEND;
        FOREND /reconcile_fmds/;

      IF fmds_with_volume_missing > 0 THEN
        {This takes priority - none of the fmds will be purged, so they
        {can all be reconciled at a later time.
        osp$set_status_abnormal (dmc$device_manager_ident, dme$some_volumes_not_online,
              recorded_vsn, status);
      ELSEIF fmds_with_vol_unavailable > 0 THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable,
              recorded_vsn, status);
      ELSEIF (fmds_not_reconciled > 0) OR
             (fmd_count <> fmd_fmd_count) THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$update_fmd,
              'Update fmds in FMD.', status);
      IFEND;
    IFEND;
    osp$clear_job_signature_lock (dmv$reconciliation_lock);
  PROCEND dmp$reconcile_fmd;
?? TITLE := '   adjust', EJECT ??

  PROCEDURE [INLINE] adjust
    (      sort_list: dmt$p_reconcile_list;
           i: integer;
           n: 0 .. 0ffffffffffffff(16));

    VAR
      j,
      k: 0 .. 0ffffffffffffff(16),
      r: dmt$reconcile_entry,
      done: boolean;

    done := FALSE;
    r := sort_list^ [i];
    j := 2 * i;

    WHILE ((j <= n) AND NOT done) DO
      IF j < n THEN
        IF less_than (^sort_list^ [j], ^sort_list^ [j + 1]) THEN
          j := j+ 1;
        IFEND;
      IFEND;
      IF less_than (^r, ^sort_list^ [j]) THEN
        sort_list^ [j DIV 2] := sort_list^ [j];
        j := 2 * j;
      ELSE
        done := TRUE;
      IFEND;
    WHILEND;
    sort_list^ [j DIV 2] := r;
  PROCEND adjust;
?? TITLE := '  build_new_fmd', EJECT ??

  PROCEDURE build_new_fmd (old_fmd: dmt$stored_fmd;
        gfn: dmt$global_file_name;
        p_reconcile_list: dmt$p_reconcile_list;
        first_fmd_index: dmt$reconcile_index;
        fmd_count: dmt$reconcile_index;
    VAR new_fmd: dmt$stored_fmd;
    VAR status: ost$status);

    VAR
      avt_index: dmt$active_volume_table_index,
      p_new_fmd: ^dmt$stored_fmd,
      p_new_version: ^dmt$stored_ms_version_number,
      p_new_header: ^dmt$stored_ms_fmd_header,
      p_new_subfile: ^dmt$stored_ms_fmd_subfile,
      p_old_subfile_list: ^dmt$stored_fmd,
      p_old_header: ^dmt$stored_ms_fmd_header,
      fmd_index: dmt$reconcile_index;

    validate_fmd (^old_fmd, gfn, p_old_header, p_old_subfile_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_new_fmd := ^new_fmd;
    RESET p_new_fmd;
    NEXT p_new_version IN p_new_fmd;
    IF p_new_version = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small, 'FMD too small.', status);
      RETURN;
    IFEND;

    p_new_version^ := dmc$current_fmd_version;
    NEXT p_new_header: [dmc$current_fmd_version] IN p_new_fmd;
    IF p_new_header = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small, 'FMD too small.', status);
      RETURN;
    IFEND;

    p_new_header^.version_0_0 := p_old_header^.version_0_0;
    p_new_header^.version_0_0.number_fmds := fmd_count;

    FOR fmd_index := first_fmd_index TO first_fmd_index + fmd_count - 1 DO
      NEXT p_new_subfile: [dmc$current_fmd_version] IN p_new_fmd;
      IF p_new_subfile = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small, 'FMD too small.', status);
        RETURN;
      IFEND;

      avt_index := p_reconcile_list^ [fmd_index].avt_index;

      p_new_subfile^.version_0_0.stored_byte_address := p_reconcile_list^ [fmd_index].byte_address DIV
            dmc$byte_address_converter;
      p_new_subfile^.version_0_0.device_file_list_index := p_reconcile_list^ [fmd_index].dfl_index;
      p_new_subfile^.version_0_0.internal_vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.
            internal_vsn;
      p_new_subfile^.version_0_0.recorded_vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.
            recorded_vsn;
    FOREND;
  PROCEND build_new_fmd;
?? TITLE := '  compare_names', EJECT ??

  PROCEDURE [INLINE] compare_names
    (    name_one: ^dmt$global_file_name;
         name_two: ^dmt$global_file_name;
     VAR compare_status: dmt$compare_status);

    IF (name_one^.sequence_number < name_two^.sequence_number) THEN
      compare_status := less;
    ELSEIF (name_one^.sequence_number > name_two^.sequence_number) THEN
      compare_status := greater;
    ELSEIF (name_one^.second < name_two^.second) THEN
        compare_status := less;
    ELSEIF (name_one^.second > name_two^.second) THEN
        compare_status := greater;
    ELSEIF (name_one^.minute < name_two^.minute) THEN
      compare_status := less;
    ELSEIF (name_one^.minute > name_two^.minute) THEN
      compare_status := greater;
    ELSEIF (name_one^.hour < name_two^.hour) THEN
      compare_status := less;
    ELSEIF (name_one^.hour > name_two^.hour) THEN
      compare_status := greater;
    ELSEIF (name_one^.day < name_two^.day) THEN
      compare_status := less;
    ELSEIF (name_one^.day > name_two^.day) THEN
      compare_status := greater;
    ELSEIF (name_one^.month < name_two^.month) THEN
      compare_status := less;
    ELSEIF (name_one^.month > name_two^.month) THEN
      compare_status := greater;
    ELSEIF (name_one^.year < name_two^.year) THEN
      compare_status := less;
    ELSEIF (name_one^.year > name_two^.year) THEN
      compare_status := greater;
    ELSEIF (name_one^.model_number < name_two^.model_number) THEN
      compare_status := less;
    ELSEIF (name_one^.model_number > name_two^.model_number) THEN
      compare_status := greater;
    ELSEIF (name_one^.serial_number < name_two^.serial_number) THEN
      compare_status := less;
    ELSEIF (name_one^.serial_number > name_two^.serial_number) THEN
      compare_status := greater;
    ELSE
      compare_status := equal;
    IFEND;

  PROCEND compare_names;
?? TITLE := '  convert_gfn_to_string', EJECT ??

  PROCEDURE convert_gfn (gfn: ost$binary_unique_name;
    VAR gfn_string: ost$name);

    VAR
      local_status: ost$status;

    pmp$convert_binary_unique_name (gfn, gfn_string, local_status);

  PROCEND convert_gfn;
?? TITLE := '  find_file', EJECT ??

  PROCEDURE find_file (gfn: dmt$global_file_name;
        p_sorted_reconcile_list: dmt$p_reconcile_list;
    VAR first_fmd_index: dmt$reconcile_index;
    VAR fmd_count: dmt$reconcile_index;
    VAR status: ost$status);

    VAR
      key_greater: boolean,
      key_equal: boolean,
      list_length: dmt$reconcile_index,
      index: dmt$reconcile_index,
      lower_index: dmt$reconcile_index,
      upper_index: dmt$reconcile_index,
      gfn_string: ost$name;

    VAR
      compare_status: dmt$compare_status;

    status.normal := TRUE;
    list_length := UPPERBOUND (p_sorted_reconcile_list^);
    lower_index := 1;
    upper_index := list_length;

  /search_list/
    WHILE lower_index <= upper_index DO
      index := (lower_index + upper_index) DIV 2;
      compare_names (^gfn, ^p_sorted_reconcile_list^ [index].global_file_name, compare_status);
      IF compare_status = greater THEN
        lower_index := index + 1;
      ELSEIF compare_status = equal THEN
        EXIT /search_list/;
      ELSE
        upper_index := index - 1;
      IFEND;
    WHILEND /search_list/;

    IF compare_status = equal THEN
      fmd_count := 1;
      upper_index := index + 1;
      WHILE (upper_index <= list_length) AND (gfn = p_sorted_reconcile_list^ [upper_index].global_file_name)
            DO
        upper_index := upper_index + 1;
        fmd_count := fmd_count + 1;
      WHILEND;

      lower_index := index - 1;
      WHILE (lower_index > 0) AND (gfn = p_sorted_reconcile_list^ [lower_index].global_file_name) DO
        lower_index := lower_index - 1;
        fmd_count := fmd_count + 1;
      WHILEND;
      first_fmd_index := lower_index + 1;
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unknown_file, 'Unknown file.', status);
      convert_gfn (gfn, gfn_string);
      osp$append_status_parameter (' ', gfn_string, status);
    IFEND;
  PROCEND find_file;
?? TITLE := 'HEAP_SORT', EJECT ??

  PROCEDURE heap_sort
    (VAR input_vector {input, output} : dmt$p_reconcile_list);

    CONST
      five_minutes = 1000000 * 60 * 5;

    VAR
      base: integer,
      clock: integer,
      date: ost$date,
      i: integer,
      l: integer,
      last_index: 0 .. 0ffffffffffffff(16),
      msg: string (70),
      status: ost$status,
      temp_record: dmt$reconcile_entry,
      time: ost$time;

{ The following sort algorithm is a heap sort. It is a non-recursive sort algorithm.
{ There are two phases to the algorithm. The first phase converts the list to be sorted
{ into a binary tree representation. The second and main sorting phase of the algorithm
{ iterates through the unsorted portion of the list. The procedure ADJUST is called
{ (number of elements to sort - 1) times during this phase. Each call to the ADJUST
{ procedure scans the right and left subtrees searching for the highest key value.
{ The highest key value becomes the root of the tree. The root of the tree is returned
{ to the main sort procedure in position one of the input/output sorted list. The root is
{ then moved into the position one greater than the current size of the tree (unsorted portion of
{ the list). Each call to the ADJUST procedure is made with a tree with one less node than the
{ previous call.

    base := 0;
    msg (1, *) := ' ';
    last_index := UPPERBOUND (input_vector^);

    FOR i := (last_index DIV 2) DOWNTO 1 DO
      adjust (input_vector, i, last_index);
      pmp$get_microsecond_clock (clock, status);
      IF status.normal AND (clock > (base + five_minutes)) THEN
        base := clock;
        pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, status);
        IF status.normal THEN
          STRINGREP (msg, l, '... sorting ', date.mdy, ' ', time.hms);
          clp$put_job_output (msg (1, l), status);
          msg (1,*) := ' ';
        IFEND;
      IFEND;
    FOREND;

    FOR i := (last_index - 1) DOWNTO 1 DO
      temp_record := input_vector^ [i + 1];
      input_vector^ [i + 1] := input_vector^ [1];
      input_vector^ [1] := temp_record;
      adjust (input_vector, 1, i);
      pmp$get_microsecond_clock (clock, status);
      IF status.normal AND (clock > (base + five_minutes)) THEN
        base := clock;
        pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, status);
        IF status.normal THEN
          STRINGREP (msg, l, '... sorting ', date.mdy, ' ', time.hms);
          clp$put_job_output (msg (1, l), status);
          msg (1,*) := ' ';
        IFEND;
      IFEND;
    FOREND;

  PROCEND heap_sort;
?? TITLE := '  less_than', EJECT ??

  FUNCTION [INLINE, UNSAFE] less_than
    (    entry_one: ^dmt$reconcile_entry;
         entry_two: ^dmt$reconcile_entry): boolean;

    VAR
      compare_status: dmt$compare_status;

    compare_names (^entry_one^.global_file_name, ^entry_two^.global_file_name, compare_status);
    IF compare_status = less THEN
      less_than := TRUE;
    ELSEIF compare_status = greater THEN
      less_than := FALSE;
    ELSE
      less_than := (entry_one^.byte_address < entry_two^.byte_address);
    IFEND;

  FUNCEND less_than;

?? TITLE := '  validate_fmd', EJECT ??

  PROCEDURE validate_fmd (p_stored_fmd: ^dmt$stored_fmd;
        gfn: dmt$global_file_name;
    VAR p_fmd_header: ^dmt$stored_ms_fmd_header;
    VAR p_subfile_list: ^dmt$stored_fmd;
    VAR status: ost$status);

    VAR
      p_fmd: ^dmt$stored_fmd,
      p_version: ^dmt$stored_ms_version_number,
      fmd_count: dmt$fmd_index,
      fmd_index: dmt$fmd_index,
      p_subfile: ^dmt$stored_ms_fmd_subfile,
      gfn_string: ost$name;

    status.normal := TRUE;
    p_fmd := p_stored_fmd;
    RESET p_fmd;

    NEXT p_version IN p_fmd;
    IF (p_version = NIL) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_fmd, 'No FMD version number.', status);
      convert_gfn (gfn, gfn_string);
      osp$append_status_parameter (' ', gfn_string, status);
      RETURN;
    IFEND;

    IF (p_version^ <> dmc$current_fmd_version) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unsupported_fmd_version,
        'Unsupported FMD version number.', status);
      convert_gfn (gfn, gfn_string);
      osp$append_status_parameter (' ', gfn_string, status);
      RETURN;
    IFEND;

    NEXT p_fmd_header: [dmc$current_fmd_version] IN p_fmd;
    IF (p_fmd_header = NIL) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_fmd, 'No FMD header.', status);
      convert_gfn (gfn, gfn_string);
      osp$append_status_parameter (' ', gfn_string, status);
      RETURN;
    IFEND;

    fmd_count := p_fmd_header^.version_0_0.number_fmds;
    IF (fmd_count < 1) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_fmd, 'FMD fmd count less than one.',
            status);
      convert_gfn (gfn, gfn_string);
      osp$append_status_parameter (' ', gfn_string, status);
      RETURN;
    IFEND;

    p_subfile_list := p_fmd;

    FOR fmd_index := 1 TO fmd_count DO
      NEXT p_subfile: [dmc$current_fmd_version] IN p_fmd;
      IF (p_subfile = NIL) THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$invalid_fmd, 'FMD too small to hold fmds.',
              status);
        convert_gfn (gfn, gfn_string);
        osp$append_status_parameter (' ', gfn_string, status);
        RETURN;
      IFEND;
    FOREND;
  PROCEND validate_fmd;


MODEND dmm$reconcile_fmd;
*DECK DECK=DMM$RECOVER_FILE EXPAND=TRUE
?? RIGHT := 110 ??
*copy osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??

MODULE dmm$recover_file;

{
{ PURPOSE:
{  The purpose of this module is to recover the contents of a file, and
{  update Device Management structures to reflect the state of the recovered
{  file.
{ DESIGN:
{  A file is recovered by the following transitions:
{    1)  The file is attached causing a file table entry and other substructures
{        to be created.  These tables reflect the current state of the file
{        as it is known on the mass storage devices.
{    2)  The file table entry is retrieved.
{    3)  The file table entry and its substructures are updated to reflect the
{        more current information residing in the old memory image file table
{        entry.
{    4)  The file is opened.
{    5)  Pages belonging to the file in the old memory image are copied to the
{        file.
{    6)  The file is closed.
{    7)  The file table entry lock is cleared.
{    8)  The file is detached.  Detaching a file causes device tables to be
{        updated from the file table entry and its substructures.
{
?? NEWTITLE := '  Declarations' ??
?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
*copyc amt$file_limit
*copyc dmp$allocate_file_space_r1
*copyc dmp$attach_device_file
*copyc dmp$attach_file
*copyc dmp$build_stored_fmd
*copyc dmp$change_dfl_damage
*copyc dmp$close_file
*copyc dmp$delete_file_descriptor
*copyc dmp$detach_device_file
*copyc dmp$detach_file
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_fmd_by_index
*copyc dmp$get_total_allocated_length
*copyc dmp$open_directory
*copyc dmp$open_file
*copyc dmp$open_login_table
*copyc dmp$process_device_log_entry
*copyc dmp$search_avt_by_vsn
*copyc dmp$search_login_table
*copyc dmp$set_eoi
*copyc dmt$device_log_entries
*copyc dmt$directory_index
*copyc dmt$error_condition_codes
*copyc dmt$file_medium_descriptor
*copyc dmt$file_share_history
*copyc dmt$fmd_index
*copyc dmt$global_file_name
*copyc dmt$ms_device_allocation_table
*copyc dmt$ms_volume_directory
*copyc dmt$sparse_allocation
*copyc dmt$stored_fmd
*copyc dmt$stored_fmd_size
*copyc dmt$stored_ms_fmd_header
*copyc dmv$active_volume_table
*copyc gfp$get_fde_p
*copyc gft$file_desc_entry_p
*copyc gft$system_file_identifier
*copyc i#move
*copyc i#ptr
*copyc lgp$add_entry_to_system_log
*copyc mmp$fetch_image_page_count
*copyc mmp$fetch_pvas_of_image_pages
*copyc mmt$image_page_description
*copyc osp$get_status_condition_string
*copyc osp$set_status_abnormal
*copyc ost$name
*copyc ost$status
?? POP ??
?? TITLE := '  dmp$recover_file', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$recover_file
    (   p_old_fde: gft$file_desc_entry_p;
    VAR status: ost$status);

    VAR
      file_entry_index: gft$file_descriptor_index,
      file_modified: boolean,
      fmd_modified: boolean,
      ignore_file_info: dmt$file_information,
      ijl_ordinal: jmt$ijl_ordinal,
      local_status: ost$status,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: gft$file_desc_entry_p,
      p_file: ^cell,
      p_fmd: ^dmt$file_medium_descriptor,
      remove_dfl_damage: boolean,
      system_file_id: gft$system_file_identifier;

    status.normal := TRUE;

{ !!!I believe the following calculation is OK--if the size or table base has changed the
{ system will not be recovering.

    file_entry_index := ((#OFFSET (p_old_fde)) - gfc$fde_table_base) DIV gfc$fde_size;

  /recover_file/
    BEGIN

      CASE p_old_fde^.file_kind OF

      = gfc$fk_job_permanent_file, gfc$fk_catalog =
        attach_pf_for_recovery (p_old_fde, file_entry_index, system_file_id, status);

      = gfc$fk_device_file =
        attach_df_for_recovery (p_old_fde, file_entry_index, system_file_id, status);
      ELSE
        EXIT /recover_file/;
      CASEND;

      IF NOT status.normal THEN
        EXIT /recover_file/;
      IFEND;

      gfp$get_fde_p (system_file_id, p_fde);
      IF p_fde <> NIL THEN
        fixup_file_descriptor_entry (system_file_id, p_old_fde, p_fde, status);
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_fde,
              'Bad SFID - dmp$recover_file.', status);
      IFEND;

      IF status.normal THEN
        open_file_for_recovery (system_file_id, p_file, status);

        IF status.normal THEN
          update_file_image (system_file_id, p_old_fde, p_fde, p_file, status);

          dmp$close_file (p_file, local_status);
          IF (NOT local_status.normal) AND status.normal THEN
            status := local_status;
          IFEND;
        IFEND;
      IFEND;

      CASE p_old_fde^.file_kind OF

      = gfc$fk_job_permanent_file, gfc$fk_catalog =
        dmp$detach_file (system_file_id, {access_allowed} TRUE, {flush_pages} TRUE, file_modified,
              fmd_modified, ignore_file_info, local_status);
        IF local_status.normal THEN
          dmp$get_disk_file_descriptor_p (p_old_fde, p_dfd);
          IF p_dfd^.damaged_detection_enabled AND NOT p_dfd^.file_damaged AND
              (status.normal = TRUE) THEN
            remove_dfl_damage := p_old_fde^.queue_status = gfc$qs_global_shared;
            IF remove_dfl_damage THEN
              IF p_dfd <> NIL THEN
                dmp$get_fmd_by_index (p_dfd, 1, p_fmd);
                IF (p_fmd <> NIL) AND p_fmd^.in_use AND p_fmd^.volume_assigned THEN
                  dmp$change_dfl_damage (p_fmd^.avt_index, $dmt$file_damage [],
                     $dmt$file_damage [dmc$media_image_inconsistent], p_fmd^.dfl_index, FALSE,
                     p_fde^.global_file_name, local_status);
                IFEND;
              IFEND;
            IFEND;
          IFEND;
          dmp$delete_file_descriptor (system_file_id, local_status);
        IFEND;

      = gfc$fk_device_file =
        dmp$detach_device_file (system_file_id, file_modified, fmd_modified, local_status);
      ELSE
        EXIT /recover_file/;
      CASEND;

      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;

      IF status.normal THEN
        detach_old_file (p_old_fde, status);
      IFEND;
    END /recover_file/;
  PROCEND dmp$recover_file;
?? TITLE := '  attach_df_for_recovery', EJECT ??

  PROCEDURE attach_df_for_recovery
    (    p_old_fde: gft$file_desc_entry_p;
         file_entry_index: gft$file_descriptor_index;
     VAR system_file_id: gft$system_file_identifier;
     VAR status: ost$status);

    VAR
      avt_entry_found: boolean,
      avt_index: dmt$active_volume_table_index,
      close_status: ost$status,
      directory_entry_index: dmt$directory_index,
      directory_index: dmt$directory_index,
      directory_sfid: gft$system_file_identifier,
      fmd_index: dmt$fmd_index,
      p_old_dfd: ^dmt$disk_file_descriptor,
      p_directory: ^dmt$ms_volume_directory,
      p_fmd: ^dmt$file_medium_descriptor,
      global_file_name: dmt$global_file_name,
      user_supplied_name: ost$name,
      volume_assigned: boolean;

    status.normal := TRUE;

    dmp$get_disk_file_descriptor_p (p_old_fde, p_old_dfd);

    fmd_index := 1;

    IF p_old_dfd <> NIL THEN
      dmp$get_fmd_by_index (p_old_dfd, fmd_index, p_fmd);
      volume_assigned := p_fmd^.in_use AND p_fmd^.volume_assigned;
    IFEND;

    IF (p_old_dfd = NIL) OR NOT volume_assigned THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$rf_no_vol_assigned_to_file, 'dmp$recover_file',
            status);
      RETURN;
    IFEND;

    dmp$search_avt_by_vsn (p_fmd^.internal_vsn, avt_index, avt_entry_found);
    IF NOT avt_entry_found THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_not_online, 'dmp$recover_file', status);
      RETURN;
    IFEND;

    directory_sfid := dmv$p_active_volume_table^ [avt_index].mass_storage.p_directory;

    dmp$open_directory (directory_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_read,
       mmc$as_sequential, p_directory, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /directory_open/
    BEGIN

      global_file_name := p_old_fde^.global_file_name;
      directory_entry_index := 0;

    /search_directory/
      FOR directory_index := 1 TO UPPERBOUND (p_directory^.entries) DO
        IF NOT p_directory^.entries [directory_index].entry_available THEN
          IF p_directory^.entries [directory_index].global_file_name = global_file_name THEN
            directory_entry_index := directory_index;
            EXIT /search_directory/;
          IFEND;
        IFEND;
      FOREND /search_directory/;

      IF directory_entry_index = 0 THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unknown_device_file, 'dmp$recover_file',
              status);
        EXIT /directory_open/;
      IFEND;

      user_supplied_name := p_directory^.entries [directory_entry_index].user_supplied_name;

      dmp$attach_device_file (dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn,
            user_supplied_name, system_file_id, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_for_rec,
          'unable to attach file for rec - DMMRECF', status);
        EXIT /directory_open/;
      IFEND;

    END /directory_open/;

    dmp$close_file (p_directory, close_status);
    IF status.normal THEN
      status := close_status;
    IFEND;

  PROCEND attach_df_for_recovery;
?? TITLE := '  attach_pf_for_recovery', EJECT ??
  PROCEDURE attach_pf_for_recovery
    (    p_old_fde: gft$file_desc_entry_p,
         file_entry_index: gft$file_descriptor_index;
     VAR system_file_id: gft$system_file_identifier;
     VAR status: ost$status);

    VAR
      avt_index: dmt$active_volume_table_index,
      existing_sft_entry: dmt$existing_sft_entry,
      fmd_index: dmt$fmd_index,
      file_damaged: boolean,
      file_share_selections: pft$share_selections,
      file_share_history: dmt$file_share_history,
      file_usage: pft$usage_selections,
      found: boolean,
      ignore_status: ost$status,
      length: integer,
      log_status: ost$status,
      log_time: ost$time,
      message: ost$string,
      number_of_fmds: dmt$fmd_index,
      old_system_file_id: gft$system_file_identifier,
      p_old_dfd: ^dmt$disk_file_descriptor,
      p_fmd: ^dmt$file_medium_descriptor,
      p_stored_fmd: ^dmt$stored_fmd,
      shared_queue: mmt$page_frame_queue_id,
      size_of_stored_fmd: dmt$stored_fmd_size,
      volume_assigned: boolean;

    status.normal := TRUE;

    dmp$get_disk_file_descriptor_p (p_old_fde, p_old_dfd);

    volume_assigned := FALSE;

    IF p_old_dfd <> NIL THEN
      number_of_fmds := p_old_dfd^.number_of_fmds;

      FOR fmd_index := 1 TO number_of_fmds DO
        dmp$get_fmd_by_index (p_old_dfd, fmd_index, p_fmd);
        IF p_fmd^.in_use AND p_fmd^.volume_assigned THEN
          volume_assigned := TRUE;
          dmp$search_avt_by_vsn (p_fmd^.internal_vsn, avt_index, found);
          IF NOT found THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_not_online,
                  'volume not online - DMMRECF', status);
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;

    IF (p_old_dfd = NIL) OR (NOT volume_assigned) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$rf_no_vol_assigned_to_file, 'dmp$recover_file',
            status);
      RETURN;
    IFEND;

    old_system_file_id.file_hash := p_old_fde^.file_hash;
    old_system_file_id.file_entry_index := file_entry_index;
    old_system_file_id.residence := gfc$tr_system;

    size_of_stored_fmd := #SIZE (dmt$stored_ms_version_number) + #SIZE (dmt$stored_ms_fmd_header) +
          number_of_fmds * #SIZE (dmt$stored_ms_fmd_subfile);

    PUSH p_stored_fmd: [[REP size_of_stored_fmd OF cell]];

    dmp$build_stored_fmd (p_old_fde, p_stored_fmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET p_stored_fmd;

    file_usage := $pft$usage_selections [pfc$read, pfc$modify, pfc$append, pfc$shorten];
    file_share_selections := $pft$share_selections [];
    file_share_history := dmc$minimum_file_share_his;

    IF p_old_fde^.queue_ordinal > mmc$pq_shared_last_sys THEN
      shared_queue := p_old_fde^.queue_ordinal - mmc$pq_shared_last_sys;
    ELSE
      shared_queue := mmc$null_shared_queue;
    IFEND;

    dmp$attach_file (p_old_fde^.global_file_name, p_old_fde^.file_kind, p_stored_fmd^, file_usage,
          file_share_selections, file_share_history, p_old_fde^.file_limit, {restricted_attach} FALSE,
          {exit_on_unknown_file} FALSE, {server_file} FALSE, shared_queue, file_damaged,
          system_file_id, existing_sft_entry, status);
    IF NOT status.normal THEN
      lgp$add_entry_to_system_log (pmc$msg_origin_recovery, 'DM - ABNORMAL ATTACH DURING RECOVERY',
        log_time, log_status);
      osp$get_status_condition_string (status.condition, message, ignore_status);
      lgp$add_entry_to_system_log (pmc$msg_origin_recovery, message.value (1, message.size), log_time,
        log_status);
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_attach_for_rec,
        'unable to attach file for rec - DMMRECF', status);
      RETURN;
    IFEND;

  PROCEND attach_pf_for_recovery;
?? TITLE := '  detach_old_file', EJECT ??
  PROCEDURE detach_old_file
    (    p_fde: gft$file_desc_entry_p;
     VAR status: ost$status);

    VAR
      avt_index: dmt$active_volume_table_index,
      log_entry: dmt$dl_entry,
      mainframe_assigned: dmt$mainframe_assigned,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fmd: ^dmt$file_medium_descriptor;

    status.normal := TRUE;

    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

    dmp$get_fmd_by_index (p_dfd, 1, p_fmd);

    IF (p_fmd <> NIL) THEN
      avt_index := p_fmd^.avt_index;

      IF dmv$p_active_volume_table^ [avt_index].mass_storage.logged_in_for_recovery THEN
        get_mainframe_assigned (avt_index, mainframe_assigned, status);

        IF status.normal THEN
          log_entry.kind := dmc$dl_detach_file;
          log_entry.attach_file_block.global_file_name := p_fde^.global_file_name;
          log_entry.attach_file_block.dfl_index := p_fmd^.dfl_index;
          log_entry.attach_file_block.mainframe_assigned := mainframe_assigned;

          dmp$process_device_log_entry (avt_index, log_entry, status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND detach_old_file;
?? TITLE := '  fixup_file_descriptor_entry', EJECT ??
  PROCEDURE fixup_file_descriptor_entry (system_file_id: gft$system_file_identifier;
        p_old_fde: gft$file_desc_entry_p;
        p_fde: gft$file_desc_entry_p;
    VAR status: ost$status);


    status.normal := TRUE;

    IF p_old_fde^.file_kind <> p_fde^.file_kind THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$rf_fde_file_type, '', status);
      RETURN;
    IFEND;

    IF p_old_fde^.global_file_name <> p_fde^.global_file_name THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$rf_fde_gfn, '', status);
      RETURN;
    IFEND;

    IF p_old_fde^.preset_value <> p_fde^.preset_value THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$rf_fde_preset, '', status);
      RETURN;
    IFEND;

    IF p_old_fde^.eoi_byte_address <> p_fde^.eoi_byte_address THEN
      dmp$set_eoi (system_file_id, p_old_fde^.eoi_byte_address, status);
    IFEND;
  PROCEND fixup_file_descriptor_entry;
?? TITLE := '  get_mainframe_assigned', EJECT ??
  PROCEDURE get_mainframe_assigned (avt_index: dmt$active_volume_table_index;
    VAR mainframe_assigned: dmt$mainframe_assigned;
    VAR status: ost$status);

    VAR
      p_login_table: ^dmt$ms_mainframe_login_table,
      lt_entry_index: dmt$login_table_entries,
      close_status: ost$status;


    status.normal := TRUE;

    dmp$open_login_table (dmv$p_active_volume_table^ [avt_index].mass_storage.p_login_table,
       osc$os_ring_1, osc$tsrv_ring, mmc$sar_read, mmc$as_sequential, p_login_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /login_table_open/
    BEGIN

      dmp$search_login_table (p_login_table, dmc$production_login_entry, lt_entry_index);

      IF lt_entry_index = 0 THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$mainframe_not_logged_in, 'dmp$recover_file',
              status);
        EXIT /login_table_open/;
      IFEND;

      mainframe_assigned := p_login_table^.body [lt_entry_index].mainframe_assigned;

    END /login_table_open/;

    dmp$close_file (p_login_table, close_status);
    IF status.normal THEN
      status := close_status;
    IFEND;

  PROCEND get_mainframe_assigned;
?? TITLE := '  open_file_for_recovery', EJECT ??
  PROCEDURE open_file_for_recovery (system_file_id: gft$system_file_identifier;
    VAR p_file: ^cell;
    VAR status: ost$status);

    VAR
      cell_pointer: mmt$segment_pointer;

    status.normal := TRUE;
    cell_pointer.kind := mmc$cell_pointer;

    dmp$open_file (system_file_id, osc$tsrv_ring, osc$tsrv_ring, mmc$sar_write_extend,
       mmc$as_sequential, cell_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_file := cell_pointer.cell_pointer;

  PROCEND open_file_for_recovery;
?? TITLE := '  update_file_image', EJECT ??
  PROCEDURE update_file_image (system_file_id: gft$system_file_identifier;
        p_old_fde: gft$file_desc_entry_p;
        p_fde: gft$file_desc_entry_p;
        p_file: ^cell;
    VAR status: ost$status);

    VAR
      allocated_length: amt$file_byte_address,
      descriptor_list_index: 0 .. 7ffffffff(16),
      highest_file_offset: ost$segment_offset,
      image_page_count: 0 .. osc$max_page_frames,
      image_page_description_p: ^mmt$image_page_description,
      old_sfid: gft$system_file_identifier;

    status.normal := TRUE;
    IF p_old_fde^.asti = 0 THEN
      RETURN;
    IFEND;

    mmp$fetch_image_page_count (image_page_count);
    IF image_page_count = 0 THEN
      RETURN;
    IFEND;

    PUSH image_page_description_p: [1 .. image_page_count];
    IF image_page_description_p = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$push_fail, 'dmp$recover_file', status);
      RETURN;
    IFEND;

    mmp$fetch_pvas_of_image_pages (p_old_fde, image_page_description_p, status);
    IF NOT status.normal OR (image_page_description_p^.valid_desc_count = 0) THEN
      RETURN;
    IFEND;

    highest_file_offset := 0;

    FOR descriptor_list_index := 1 TO image_page_description_p^.valid_desc_count DO
      IF image_page_description_p^.page_desc [descriptor_list_index].file_offset > highest_file_offset THEN
        highest_file_offset := image_page_description_p^.page_desc [descriptor_list_index].file_offset;
      IFEND;
    FOREND;

    dmp$get_total_allocated_length (p_fde, allocated_length);

    IF allocated_length < (highest_file_offset + image_page_description_p^.pagesize) THEN
      dmp$allocate_file_space_r1 (system_file_id, highest_file_offset, image_page_description_p^.pagesize, 0,
            osc$nowait, sfc$no_limit, status);
      dmp$get_total_allocated_length (p_fde, allocated_length);
    IFEND;

    FOR descriptor_list_index := 1 TO image_page_description_p^.valid_desc_count DO
      IF image_page_description_p^.page_desc [descriptor_list_index].file_offset +
            image_page_description_p^.pagesize <= allocated_length THEN
        i#move (image_page_description_p^.page_desc [descriptor_list_index].image_pva,
              i#ptr (image_page_description_p^.page_desc [descriptor_list_index].file_offset, p_file),
              image_page_description_p^.pagesize);
      IFEND;
    FOREND;

  PROCEND update_file_image;
MODEND dmm$recover_file;
*DECK DECK=DMM$RECOVER_JOB_TEMP_FILE_SPACE EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE: Device Management - Recover Job Temporary File Space' ??
MODULE dmm$recover_job_temp_file_space;
?? NEWTITLE := '  External declarations referenced in this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmp$clear_update_lock
*copyc dmp$close_file
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_fmd_by_index
*copyc dmp$get_level_1_ptr
*copyc dmp$get_level_2_ptr
*copyc dmp$open_dat
*copyc dmp$return_dat_entries
*copyc dmp$set_update_lock
*copyc dmp$volume_space_manager
*copyc dmt$error_condition_codes
*copyc dmv$active_volume_table
*copyc gfp$scan_all_fdes
*copyc gfp$scan_all_fdes_in_image
*copyc gft$file_desc_entry_p
*copyc i#build_adaptable_array_ptr
*copyc lgp$add_entry_to_system_log
*copyc mme$condition_codes
*copyc osd$virtual_address
*copyc osp$fatal_system_error
*copyc osp$set_status_abnormal
*copyc pmp$cycle
*copyc syp$disestablish_cond_handler
*copyc syp$establish_condition_handler
?? POP ??
?? TITLE := '  Global Declarations declared in this module', EJECT ??

  TYPE
    t$dat_pointers = array [ * ] of ^dmt$ms_device_allocation_table,

    t$fmd_info = array [ * ] of record
      daus_per_allocation: dmt$daus_per_allocation,
      new_mainframe_id: dmt$mainframe_assigned,
      p_dat: ^dmt$ms_device_allocation_table,
    recend;
?? TITLE := '  dmp$recover_job_temp_file_space', EJECT ??

  PROCEDURE [XDCL] dmp$recover_job_temp_file_space
    (VAR status: ost$status);

    VAR
      avt_index: dmt$active_volume_table_index,
      p_dat_pointers: ^t$dat_pointers,
      p_fde: gft$file_desc_entry_p,
      scan_control: gft$scan_all_fdes_state;

    status.normal := TRUE;

    PUSH p_dat_pointers: [LOWERBOUND (dmv$p_active_volume_table^) ..
          UPPERBOUND (dmv$p_active_volume_table^)];
    FOR avt_index := LOWERBOUND (p_dat_pointers^) TO UPPERBOUND (p_dat_pointers^) DO
      p_dat_pointers^ [avt_index] := NIL;
    FOREND;

    gfp$scan_all_fdes (gfc$tr_job, scan_control, p_fde);
    WHILE status.normal AND (p_fde <> NIL) DO
      IF (p_fde^.media = gfc$fm_mass_storage_file) THEN
        recover_job_file (p_fde, p_dat_pointers^, status);
      IFEND;
      gfp$scan_all_fdes (gfc$tr_null_residence, scan_control, p_fde);
    WHILEND;

    close_all_dats (p_dat_pointers^);
  PROCEND dmp$recover_job_temp_file_space;
?? TITLE := '  dmp$return_temp_file_space', EJECT ??

  PROCEDURE [XDCL] dmp$return_temp_file_space;

    VAR
      avt_index: dmt$active_volume_table_index,
      full_update: boolean,
      mainframe_assigned: dmt$mainframe_assigned,
      rvsn: rmt$recorded_vsn,
      status: ost$status,
      str: string (70),
      strl: integer,
      ignore_status: ost$status;

    full_update := TRUE;

  /avt_loop/
    FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND (dmv$p_active_volume_table^) DO
      IF NOT dmv$p_active_volume_table^ [avt_index].entry_available AND NOT dmv$p_active_volume_table^
            [avt_index].mass_storage.volume_unavailable AND (dmv$p_active_volume_table^ [avt_index].
            mass_storage.mainframe_assigned.log_in_sequence <> 0) THEN
        REPEAT
          mainframe_assigned := dmv$p_active_volume_table^ [avt_index].mass_storage.mainframe_assigned;
          dmp$return_dat_entries (mainframe_assigned, avt_index, dmc$return_all_except_entry, status);
          IF NOT status.normal THEN
            IF (status.condition = dme$unable_to_lock_dat) THEN
              pmp$cycle (ignore_status);
            ELSEIF status.condition = mme$io_read_error THEN
              rvsn := dmv$p_active_volume_table^[avt_index].mass_storage.recorded_vsn;
              STRINGREP (str, strl, 'Unable to return temp file space on ', rvsn, ' - I/O read error');
              log (str);
              CYCLE /avt_loop/;
            ELSEIF status.condition = dme$volume_unavailable THEN
              rvsn := dmv$p_active_volume_table^[avt_index].mass_storage.recorded_vsn;
              STRINGREP (str, strl, 'Unable to return temp file space on ', rvsn, ' - volume unavailable');
              log (str);
              CYCLE /avt_loop/;
            ELSE
              osp$fatal_system_error ('Bad status in dmp$return_temp_file_space.', ^status);
            IFEND;
          IFEND;
        UNTIL status.normal;

        {Bring partial cylinders (created in the DAT by returning old
        {temporary space) back into the MAT.

        REPEAT
          dmp$volume_space_manager (avt_index, full_update, status);
          IF NOT status.normal THEN
            IF (status.condition = dme$unable_to_lock_dat) OR
               (status.condition = dme$unable_to_lock_dflt) OR
               (status.condition = dme$unable_to_lock_avt_entry) THEN
              pmp$cycle (ignore_status);
            ELSE
              osp$fatal_system_error ('Bad status in dmp$return_temp_file_space.', ^status);
            IFEND;
          IFEND;
        UNTIL status.normal;
      IFEND;
    FOREND /avt_loop/;
  PROCEND dmp$return_temp_file_space;
?? TITLE := '  dmp$verify_job_volumes', EJECT ??

  PROCEDURE [XDCL] dmp$verify_job_volumes
    (    job_fixed_segment: ost$segment;
     VAR volume_missing: boolean;
     VAR unrecoverable_file: boolean);

    VAR
      avt_index: dmt$active_volume_table_index,
      p_dat_pointers: ^t$dat_pointers,
      p_fde: gft$file_desc_entry_p,
      scan_control: gft$scan_all_fdes_state;

    volume_missing := FALSE;
    unrecoverable_file := FALSE;

    PUSH p_dat_pointers: [LOWERBOUND (dmv$p_active_volume_table^) ..
          UPPERBOUND (dmv$p_active_volume_table^)];
    FOR avt_index := LOWERBOUND (p_dat_pointers^) TO UPPERBOUND (p_dat_pointers^) DO
      p_dat_pointers^ [avt_index] := NIL;
    FOREND;

    gfp$scan_all_fdes_in_image (job_fixed_segment, scan_control, p_fde);
    WHILE (p_fde <> NIL) AND NOT volume_missing AND NOT unrecoverable_file DO
      IF p_fde^.media = gfc$fm_mass_storage_file THEN
        validate_job_file (p_fde, p_dat_pointers^, volume_missing, unrecoverable_file);
      IFEND;
      gfp$scan_all_fdes (gfc$tr_null_residence, scan_control, p_fde);
    WHILEND;

    close_all_dats (p_dat_pointers^);
  PROCEND dmp$verify_job_volumes;
?? TITLE := '  close_all_dats', EJECT ??

  PROCEDURE close_all_dats
    (    dat_pointers: t$dat_pointers);

    VAR
      index: integer,
      status: ost$status;

    FOR index := LOWERBOUND (dat_pointers) TO UPPERBOUND (dat_pointers) DO
      IF (dat_pointers [index] <> NIL) THEN
        dmp$close_file (dat_pointers [index], status);
        IF NOT status.normal THEN
          IF (status.condition <> mme$io_read_error) AND (status.condition <> dme$volume_unavailable) THEN
            osp$fatal_system_error ('Close DAT failed - close_all_dats.', ^status);
          IFEND;
        IFEND;
      IFEND;
    FOREND;
  PROCEND close_all_dats;
?? TITLE := '  get_avt_index', EJECT ??

  PROCEDURE get_avt_index
    (    internal_vsn: dmt$internal_vsn;
     VAR avt_index: dmt$active_volume_table_index);

    FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND (dmv$p_active_volume_table^) DO
      IF NOT dmv$p_active_volume_table^ [avt_index].entry_available AND NOT
            dmv$p_active_volume_table^ [avt_index].mass_storage.volume_unavailable AND
            (dmv$p_active_volume_table^ [avt_index].mass_storage.internal_vsn = internal_vsn) THEN
        RETURN;
      IFEND;
    FOREND;
    avt_index := 0;
  PROCEND get_avt_index;
?? TITLE := '  get_dat_pointer', EJECT ??

  PROCEDURE get_dat_pointer
    (    avt_index: dmt$active_volume_table_index;
     VAR dat_pointers: {input/output} t$dat_pointers;
     VAR p_dat: ^dmt$ms_device_allocation_table;
     VAR status: ost$status);

    status.normal := TRUE;
    p_dat := dat_pointers [avt_index];

    IF (p_dat = NIL) THEN
      dmp$open_dat (dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_allocation_table,
            osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential, p_dat, status);
      IF NOT status.normal THEN
        p_dat := NIL;
        IF (status.condition <> mme$io_read_error) AND (status.condition <> dme$volume_unavailable) THEN
          osp$fatal_system_error ('Open DAT failed - get_dat_pointer.', ^status);
        IFEND;
      IFEND;
      dat_pointers [avt_index] := p_dat;
    IFEND;
  PROCEND get_dat_pointer;
?? TITLE := '  log', EJECT ??

  PROCEDURE log
    (    text: string ( * ));

    VAR
      log_time: ost$time,
      status: ost$status;

    lgp$add_entry_to_system_log (pmc$msg_origin_system, text, log_time, status);
  PROCEND log;
?? TITLE := '  recover_allocation_unit', EJECT ??

  PROCEDURE recover_allocation_unit
    (    avt_index: dmt$active_volume_table_index;
         p_dat: ^dmt$ms_device_allocation_table;
         first_dau: dmt$dau_address;
         daus_per_allocation: dmt$daus_per_allocation;
         new_mainframe_id: dmt$mainframe_assigned);


    PROCEDURE unlock_handler
      (    mf: ost$monitor_fault;
           psa: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      dmp$clear_update_lock (avt_index);
      continue := syc$condition_ignored;
    PROCEND unlock_handler;


    VAR
      able: boolean,
      dau: dmt$dau_address;

    dmp$set_update_lock (avt_index, TRUE, able);

    syp$establish_condition_handler (^unlock_handler);

    IF valid_allocation_unit (p_dat, first_dau, daus_per_allocation, new_mainframe_id) THEN
      FOR dau := first_dau TO (first_dau + daus_per_allocation - 1) DO
        p_dat^.body [dau].mainframe_id := new_mainframe_id;
      FOREND;
    ELSE
      osp$fatal_system_error ('Bad allocation unit - recover_allocation_unit', NIL);
    IFEND;

    syp$disestablish_cond_handler;

    dmp$clear_update_lock (avt_index);
  PROCEND recover_allocation_unit;
?? TITLE := '  recover_job_file', EJECT ??

  PROCEDURE recover_job_file
    (    p_fde: gft$file_desc_entry_p;
     VAR dat_pointers: {input/output} t$dat_pointers;
     VAR status: ost$status);

    VAR
      avt_index: dmt$active_volume_table_index,
      bytes_per_allocation: dmt$bytes_per_allocation,
      dau: dmt$dau_address,
      daus_per_allocation: dmt$daus_per_allocation,
      fmd_count: dmt$fmd_index,
      fmd_index: dmt$fmd_index,
      level_1_index: dmt$level_1_index,
      level_2_index: dmt$level_2_index,
      new_mainframe_id: dmt$mainframe_assigned,
      p_dat: ^dmt$ms_device_allocation_table,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fmd: ^dmt$file_medium_descriptor,
      p_fmd_info: ^t$fmd_info,
      p_level_1: ^dmt$level_1_table,
      p_level_2: ^dmt$level_2_table;

    status.normal := TRUE;
    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

    IF (p_dfd = NIL) OR (p_dfd^.number_of_fmds = 0) THEN
      RETURN;
    IFEND;

    fmd_count := p_dfd^.number_of_fmds;
    PUSH p_fmd_info: [1 .. fmd_count];

    FOR fmd_index := 1 TO fmd_count DO
      dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);
      IF (p_fmd <> NIL) AND p_fmd^.in_use AND p_fmd^.volume_assigned THEN
        get_avt_index (p_fmd^.internal_vsn, avt_index);
        IF (avt_index = 0) THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable,
                'Volume unavailable - recover_job_file.', status);
          RETURN;
        IFEND;
        p_fmd_info^ [fmd_index].daus_per_allocation := p_fmd^.daus_per_allocation_unit;
        p_fmd_info^ [fmd_index].new_mainframe_id := dmv$p_active_volume_table^ [avt_index].
              mass_storage.mainframe_assigned;
        get_dat_pointer (avt_index, dat_pointers, p_fmd_info^ [fmd_index].p_dat, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        p_fmd^.avt_index := avt_index;
      ELSE
        p_fmd_info^ [fmd_index].daus_per_allocation := 1;
        p_fmd_info^ [fmd_index].new_mainframe_id.log_in_sequence := 0;
        p_fmd_info^ [fmd_index].new_mainframe_id.log_in_index := 1;
        p_fmd_info^ [fmd_index].p_dat := NIL;
      IFEND;
    FOREND;

    bytes_per_allocation := p_dfd^.bytes_per_allocation;
    dmp$get_level_1_ptr (p_dfd, p_level_1);
    IF p_level_1 <> NIL THEN
      FOR level_1_index := 0 TO p_dfd^.fat_upper_bound DO
        dmp$get_level_2_ptr (^p_level_1^ [level_1_index], p_level_2);
        IF p_level_2 <> NIL THEN
          FOR level_2_index := 0 TO (p_dfd^.bytes_per_level_2 DIV bytes_per_allocation) - 1 DO
            IF (p_level_2^ [level_2_index].state <> dmc$fau_free) THEN
              fmd_index := p_level_2^ [level_2_index].fmd_index;
              dau := p_level_2^ [level_2_index].dau_address;
              IF (fmd_index = 0) OR (fmd_index > fmd_count) THEN
                osp$fatal_system_error ('Bad FAT entry - recover_job_file', NIL);
                RETURN;
              IFEND;
              daus_per_allocation := p_fmd_info^ [fmd_index].daus_per_allocation;
              new_mainframe_id := p_fmd_info^ [fmd_index].new_mainframe_id;
              p_dat := p_fmd_info^ [fmd_index].p_dat;
              recover_allocation_unit (avt_index, p_dat, dau, daus_per_allocation, new_mainframe_id);
            IFEND;
          FOREND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND recover_job_file;
?? TITLE := '  valid_allocation_unit', EJECT ??

  FUNCTION valid_allocation_unit
    (    p_dat: ^dmt$ms_device_allocation_table;
         first_dau: dmt$dau_address;
         daus_per_allocation: dmt$daus_per_allocation;
         new_mainframe_id: dmt$mainframe_assigned): boolean;

    VAR
      dau: dmt$dau_address,
      last_dau: dmt$dau_address,
      state: dmt$dau_status;

    valid_allocation_unit := FALSE;
    last_dau := first_dau + daus_per_allocation - 1;

    IF (p_dat = NIL) OR (last_dau >= p_dat^.header.number_of_entries) THEN
      RETURN;
    IFEND;

    FOR dau := first_dau TO last_dau DO
      state := p_dat^.body [dau].dau_status;
      IF ((state <> dmc$dau_assigned_to_mainframe) AND (state <> dmc$dau_ass_to_mf_swr_flawed)) OR
            (p_dat^.body [dau].mainframe_id = new_mainframe_id) THEN
        RETURN;
      IFEND;
    FOREND;

    valid_allocation_unit := TRUE;
  FUNCEND valid_allocation_unit;
?? TITLE := '  validate_job_file', EJECT ??

  PROCEDURE validate_job_file
    (    p_fde: gft$file_desc_entry_p;
     VAR dat_pointers: {input/output} t$dat_pointers;
     VAR volume_missing: boolean;
     VAR unrecoverable_file: boolean);

    VAR
      avt_index: dmt$active_volume_table_index,
      bytes_per_allocation: dmt$bytes_per_allocation,
      dau: dmt$dau_address,
      daus_per_allocation: dmt$daus_per_allocation,
      fmd_count: dmt$fmd_index,
      fmd_index: dmt$fmd_index,
      level_1_index: dmt$level_1_index,
      level_2_index: dmt$level_2_index,
      new_mainframe_id: dmt$mainframe_assigned,
      p_dat: ^dmt$ms_device_allocation_table,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fmd: ^dmt$file_medium_descriptor,
      p_fmd_info: ^t$fmd_info,
      p_level_1: ^dmt$level_1_table,
      p_level_2: ^dmt$level_2_table,
      status: ost$status;

    volume_missing := FALSE;
    unrecoverable_file := FALSE;

    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

    IF (p_dfd = NIL) OR (p_dfd^.number_of_fmds = 0) THEN
      RETURN;
    IFEND;

    fmd_count := p_dfd^.number_of_fmds;
    PUSH p_fmd_info: [1 .. fmd_count];

    FOR fmd_index := 1 TO fmd_count DO
      dmp$get_fmd_by_index (p_dfd, fmd_index, p_fmd);
      IF (p_fmd <> NIL) AND p_fmd^.in_use AND p_fmd^.volume_assigned THEN
        get_avt_index (p_fmd^.internal_vsn, avt_index);
        IF (avt_index = 0) THEN
          volume_missing := TRUE;
          RETURN;
        IFEND;
        p_fmd_info^ [fmd_index].daus_per_allocation := p_fmd^.daus_per_allocation_unit;
        p_fmd_info^ [fmd_index].new_mainframe_id := dmv$p_active_volume_table^ [avt_index].
              mass_storage.mainframe_assigned;
        get_dat_pointer (avt_index, dat_pointers, p_fmd_info^ [fmd_index].p_dat, status);
        IF NOT status.normal THEN
          volume_missing := TRUE;
          RETURN;
        IFEND;
      ELSE
        p_fmd_info^ [fmd_index].daus_per_allocation := 1;
        p_fmd_info^ [fmd_index].new_mainframe_id.log_in_sequence := 0;
        p_fmd_info^ [fmd_index].new_mainframe_id.log_in_index := 1;
        p_fmd_info^ [fmd_index].p_dat := NIL;
      IFEND;
    FOREND;

    bytes_per_allocation := p_dfd^.bytes_per_allocation;
    dmp$get_level_1_ptr (p_dfd, p_level_1);
    IF p_level_1 <> NIL THEN
      FOR level_1_index := 0 TO p_dfd^.fat_upper_bound DO
        dmp$get_level_2_ptr (^p_level_1^ [level_1_index], p_level_2);
        IF p_level_2 <> NIL THEN
          FOR level_2_index := 0 TO (p_dfd^.bytes_per_level_2 DIV bytes_per_allocation) - 1 DO
            IF (p_level_2^ [level_2_index].state <> dmc$fau_free) THEN
              fmd_index := p_level_2^ [level_2_index].fmd_index;
              dau := p_level_2^ [level_2_index].dau_address;
              IF (fmd_index = 0) OR (fmd_index > fmd_count) THEN
                unrecoverable_file := TRUE;
                RETURN;
              IFEND;
              daus_per_allocation := p_fmd_info^ [fmd_index].daus_per_allocation;
              new_mainframe_id := p_fmd_info^ [fmd_index].new_mainframe_id;
              p_dat := p_fmd_info^ [fmd_index].p_dat;
              IF NOT valid_allocation_unit (p_dat, dau, daus_per_allocation, new_mainframe_id) THEN
                unrecoverable_file := TRUE;
                RETURN;
              IFEND;
            IFEND;
          FOREND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND validate_job_file;
?? OLDTITLE, OLDTITLE ??
MODEND dmm$recover_job_temp_file_space;
*DECK DECK=DMM$RECOVER_MAINFRAME EXPAND=TRUE
?? RIGHT := 110 ??
*copy osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??
MODULE dmm$recover_mainframe;

{ PURPOSE:
{
{   The purpose of this module is to activate and recover mass storage volumes.
{
{ DESIGN:
{
{   When a volume is activated, it is logged in for recovery or production
{   based on whether recovery is required.  Procedure dmp$recover_mainframe
{   recovers all volumes in the active volume table that are logged in for
{   recovery.  Once recovery is complete, the volume's login type is switched
{   from recovery to production.  During deadstart, an image will be used if
{   it is available.
{
{   Procedure dmp$get_volume_active brings a volume online, activates it and
{   recovers it by calling dmp$recover_mainframe if dmp$recover_mainframe has
{   been called before.  The first call to dmp$recover_mainframe occurs during
{   deadstart after the initial configuration is activated.  Thus, all volumes
{   that are activated initially during deadstart are all recovered as a
{   group.  Subsequently recovery of of a volume occurs as it is activated.

?? PUSH (LISTEXT := ON) ??
?? NEWTITLE := '  Common Decks', EJECT ??
*copyc clp$put_job_output
*copyc cmp$search_active_volume_table
*copyc dmp$activate_volume
*copyc dmp$add_to_sorted_dfl
*copyc dmp$attach_device_file
*copyc dmp$close_file
*copyc dmp$detach_device_file
*copyc dmp$evacuate_active_device_log
*copyc dmp$evacuate_old_device_log
*copyc dmp$fixup_fmd_allocated_length
*copyc dmp$get_fau_entry
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_level_1_ptr
*copyc dmp$get_level_2_ptr
*copyc dmp$get_physical_attributes
*copyc dmp$open_dflt
*copyc dmp$open_directory
*copyc dmp$open_login_table
*copyc dmp$recover_file
*copyc dmp$recover_volume
*copyc dmp$return_mat_space
*copyc dmp$retrieve_allocation_info
*copyc dmp$return_dat_entries
*copyc dmp$return_dfl_entries
*copyc dmp$search_login_table
*copyc dmp$search_vol_directory_name
*copyc dmp$set_eoi
*copyc dmp$start_volume_production
*copyc dmp$take_volume_offline
*copyc dmp$volume_online
*copyc dmt$error_condition_codes
*copyc dmt$old_image_pointers
*copyc dmv$active_volume_table
*copyc dmv$allocation_log
*copyc dmv$mainframe_recovered
*copyc dmv$null_sfid
*copyc dmv$system_device_information
*copyc dsp$fetch_list_block
*copyc dsp$get_nve_image_description
*copyc dsp$store_list_block
*copyc dsv$actual_deadstart_phase
*copyc gfp$get_fde_p
*copyc gfp$scan_all_fdes_in_image
*copyc gft$scan_all_fdes_state
*copyc i#build_adaptable_array_ptr
*copyc i#build_adaptable_seq_pointer
*copyc osp$get_status_condition_string
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc osv$deadstart_phase
*copyc pmp$log_ascii
*copyc syp$set_mainframe_recovered
*copyc syv$job_recovery_option
?? POP ??

?? TITLE := '  dmp$get_old_image_pointers', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$get_old_image_pointers
    (VAR old_image_pointers: dmt$old_image_pointers;
     VAR image_available: boolean);

    VAR
      descriptor: dst$nve_image_descriptor,
      old_wired_segment: ost$segment,
      p_image_pointers: ^dmt$old_image_pointers,
      p_list_block: ^SEQ ( * ),
      paa: ^^cell;

    image_available := FALSE;
    old_image_pointers.old_image_status := dmc$old_image_not_available;
    old_image_pointers.old_allocation_log_info := NIL;
    old_image_pointers.p_avt_pointer := NIL;
    old_image_pointers.old_wired_segment := 0;
    dsp$get_nve_image_description (descriptor);

    IF (descriptor.rcv_mainframe_wired_segment <> NIL) AND (osv$deadstart_phase = osc$recovery_deadstart) THEN
      dsp$fetch_list_block (dsc$device_management, p_list_block);
      IF (p_list_block <> NIL) AND (#SIZE (p_list_block^) = #SIZE (old_image_pointers)) THEN
        old_wired_segment := #SEGMENT (descriptor.rcv_mainframe_wired_segment);
        i#build_adaptable_seq_pointer (1, old_wired_segment, #OFFSET (p_list_block), #SIZE (p_list_block^), 0,
              p_list_block);
        RESET p_list_block;
        NEXT p_image_pointers IN p_list_block;
        old_image_pointers := p_image_pointers^;
        old_image_pointers.old_wired_segment := old_wired_segment;
        old_image_pointers.old_allocation_log_info := #ADDRESS (1, old_wired_segment,
              #OFFSET (old_image_pointers.old_allocation_log_info));
        old_image_pointers.p_avt_pointer := #ADDRESS (1, old_wired_segment,
              #OFFSET (old_image_pointers.p_avt_pointer));
        image_available :=
          old_image_pointers.old_image_status = dmc$old_image_available;
      IFEND;
    IFEND;

  PROCEND dmp$get_old_image_pointers;
?? TITLE := '  dmp$get_volume_active', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$get_volume_active (lun: iot$logical_unit;
        pid: cmt$product_identification;
    VAR status: ost$status);

    VAR
      avt_entry_not_found: boolean,
      ignore_status: ost$status,
      message: string (20),
      p_physical_attributes: ^dmt$physical_device_attributes,
      recorded_vsn: rmt$recorded_vsn,
      search_key: dmt$avt_search_key;

    status.normal := TRUE;

    IF lun = dmv$system_device_lun THEN
      RETURN;
    IFEND;

    PUSH p_physical_attributes: [1 .. 7];
    p_physical_attributes^ [1].keyword := dmc$bytes_per_mau;
    p_physical_attributes^ [2].keyword := dmc$cylinders_per_device;
    p_physical_attributes^ [3].keyword := dmc$maus_per_cylinder;
    p_physical_attributes^ [4].keyword := dmc$maus_per_dau;
    p_physical_attributes^ [5].keyword := dmc$sectors_per_mau;
    p_physical_attributes^ [6].keyword := dmc$sectors_per_track;
    p_physical_attributes^ [7].keyword := dmc$flaw_map_locations;

    dmp$get_physical_attributes (pid, p_physical_attributes, status);
    IF status.normal THEN
      dmp$volume_online (lun, p_physical_attributes, status);
      IF status.normal THEN
        search_key.value := dmc$search_avt_by_lun;
        search_key.logical_unit_number := lun;
        cmp$search_active_volume_table (search_key, recorded_vsn, avt_entry_not_found);
        IF NOT avt_entry_not_found THEN
          message := ' ACTIVATING ';
          message (13, *) := recorded_vsn;
          clp$put_job_output (message, ignore_status);
        IFEND;
        dmp$activate_volume (lun, status);
        IF NOT status.normal THEN
          dmp$take_volume_offline (lun, ignore_status);
        IFEND;
      IFEND;
    IFEND;

    { If mainframe recovery has already occurred, it must be repeated as each
    { volume is activated so that recovery of the volume can take place.

    IF status.normal AND dmv$mainframe_recovered THEN
      dmp$recover_mainframe (status);
      IF status.normal THEN
        dmp$add_to_sorted_dfl (lun, status);
      IFEND;
    IFEND;
  PROCEND dmp$get_volume_active;
?? TITLE := '  dmp$issue_message_to_ascii_log', EJECT ??

  PROCEDURE [XDCL] dmp$issue_message_to_ascii_log (msg_string: pmt$log_msg_text;
    VAR status: ost$status);

    status.normal := TRUE;

    pmp$log_ascii (msg_string, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_recovery,
          status);

  PROCEND dmp$issue_message_to_ascii_log;
?? TITLE := '  dmp$log_abnormal_status', EJECT ??

  PROCEDURE [XDCL] dmp$log_abnormal_status (VAR status: ost$status);

    VAR
      condition_string: ost$string,
      ignore_status: ost$status,
      error_condition_length: integer,
      current_string_position: integer,
      local_status: ost$status,
      msg_string: string (100);

    current_string_position := 1;
    osp$get_status_condition_string (status.condition, condition_string, ignore_status);
    msg_string (current_string_position, *) := condition_string.value (1, condition_string.size);
    current_string_position := current_string_position + condition_string.size + 1;
    msg_string (current_string_position, status.text.size) := status.text.value;
    current_string_position := current_string_position + status.text.size + 1;

    dmp$issue_message_to_ascii_log (msg_string, local_status);

  PROCEND dmp$log_abnormal_status;
?? TITLE := '  dmp$recover_mainframe', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$recover_mainframe (VAR status: ost$status);

    VAR
      image_available: boolean,
      msg_string: string (40),
      old_image_pointers: ^dmt$old_image_pointers;

    status.normal := TRUE;

    PUSH old_image_pointers;

    IF dsv$actual_deadstart_phase = osc$recovery_deadstart THEN
      msg_string := '  Recovering without an image file';
    ELSE
      msg_string := '  Recovery not necessary';
    IFEND;

    dmp$get_old_image_pointers (old_image_pointers^, image_available);
    IF image_available THEN
      msg_string := '  Recovering with an image file';
    IFEND;

    pmp$log_ascii (msg_string, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_recovery,
          status);

    clp$put_job_output (msg_string, status);

    return_old_mat_space (old_image_pointers^);

    recover_logs (old_image_pointers^, status);

    IF status.normal THEN
      recover_files (old_image_pointers^, status);
    IFEND;

    IF status.normal THEN
      recover_volumes (status);
    IFEND;

    IF status.normal THEN
      start_volume_production (status);
    IFEND;

    syp$set_mainframe_recovered (TRUE);

    IF NOT status.normal THEN
      dmp$log_abnormal_status (status);
    IFEND;
  PROCEND dmp$recover_mainframe;
?? TITLE := '  dmp$save_recovery_info', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$save_recovery_info;

    VAR
      old_image_pointers: dmt$old_image_pointers;

    old_image_pointers.old_image_status := dmc$old_image_available;
    old_image_pointers.old_allocation_log_info := ^dmv$allocation_log;
    old_image_pointers.p_avt_pointer := ^dmv$p_active_volume_table;
    dsp$store_list_block (dsc$device_management, #SEQ (old_image_pointers));
  PROCEND dmp$save_recovery_info;
?? TITLE := '  get_recovery_id', EJECT ??

  PROCEDURE get_recovery_id (avt_index: dmt$active_volume_table_index;
    VAR mainframe_assigned: dmt$mainframe_assigned);

    VAR
      p_login_table: ^dmt$ms_mainframe_login_table,
      login_index: dmt$login_table_entries,
      status: ost$status;

    mainframe_assigned.log_in_sequence := 0;
    mainframe_assigned.log_in_index := 1;

    dmp$open_login_table (dmv$p_active_volume_table^ [avt_index].mass_storage.p_login_table,
       osc$os_ring_1, osc$tsrv_ring, mmc$sar_read, mmc$as_sequential, p_login_table, status);

    IF status.normal THEN
      dmp$search_login_table (p_login_table, dmc$production_login_entry, login_index);

      IF (login_index <> 0) THEN
        mainframe_assigned := p_login_table^.body [login_index].mainframe_assigned;
      IFEND;

      dmp$close_file (p_login_table, status);
    IFEND;
  PROCEND get_recovery_id;
?? TITLE := '  locate_avt_entry', EJECT ??

  PROCEDURE locate_avt_entry (p_avt: ^dmt$active_volume_table;
        internal_vsn: dmt$internal_vsn;
    VAR avt_index: dmt$active_volume_table_index);

    VAR
      index: dmt$active_volume_table_index;

    FOR index := LOWERBOUND (p_avt^) TO UPPERBOUND (p_avt^) DO
      IF NOT p_avt^ [index].entry_available THEN
        IF p_avt^ [index].mass_storage.internal_vsn = internal_vsn THEN
          avt_index := index;
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    avt_index := 0;
  PROCEND locate_avt_entry;
?? TITLE := '  locate_next_volume', EJECT ??

  PROCEDURE locate_next_volume (VAR avt_index: dmt$active_volume_table_index);

    WHILE (avt_index < UPPERBOUND (dmv$p_active_volume_table^)) DO
      avt_index := avt_index + 1;

      IF NOT dmv$p_active_volume_table^ [avt_index].entry_available AND
            dmv$p_active_volume_table^ [avt_index].mass_storage.logged_in_for_recovery THEN
        RETURN;
      IFEND;
    WHILEND;

    avt_index := 0;
  PROCEND locate_next_volume;
?? TITLE := '  recover_files', EJECT ??

  PROCEDURE recover_files (old_image_pointers: dmt$old_image_pointers;
    VAR status: ost$status);

    VAR
      avt_index: dmt$active_volume_table_index,
      permanent_files_recovered: integer,
      permanent_files_not_recovered: integer,
      dfd_p: ^dmt$disk_file_descriptor,
      local_status: ost$status,
      msg_string: string (40),
      image_segment: ost$segment,
      scan_control: gft$scan_all_fdes_state,
      msg_string_length: integer,
      fde_p: gft$file_desc_entry_p;

    status.normal := TRUE;
    permanent_files_recovered := 0;
    permanent_files_not_recovered := 0;

    IF old_image_pointers.old_image_status = dmc$old_image_available THEN

      image_segment := old_image_pointers.old_wired_segment;
      gfp$scan_all_fdes_in_image (image_segment, scan_control, fde_p);
      WHILE fde_p <> NIL DO
        /recover_file/
        BEGIN

        IF fde_p^.media <> gfc$fm_mass_storage_file THEN
          EXIT /recover_file/;
        IFEND;

        IF (fde_p^.file_kind <> gfc$fk_job_permanent_file) AND
            (fde_p^.file_kind <> gfc$fk_catalog) THEN
          EXIT /recover_file/;
        IFEND;

        IF fde_p^.attached_in_write_count < 1 THEN
          EXIT /recover_file/;
        IFEND;

        dmp$get_disk_file_descriptor_p (fde_p, dfd_p);
        IF dfd_p^.purged THEN
          EXIT /recover_file/;
        IFEND;

        dmp$recover_file (fde_p, status);
        IF NOT status.normal THEN
          dmp$log_abnormal_status (status);
          CASE status.condition OF
          = dme$unable_to_attach_for_rec =
            permanent_files_not_recovered := permanent_files_not_recovered + 1;
            status.normal := TRUE;
            EXIT /recover_file/;
          = dme$rf_no_vol_assigned_to_file =
            status.normal := TRUE;
            EXIT /recover_file/;
          ELSE
            status.normal := TRUE;
            EXIT /recover_file/;
          CASEND;
        IFEND;

        permanent_files_recovered := permanent_files_recovered + 1;
        END /recover_file/;
        gfp$scan_all_fdes_in_image (0 {segment_number}, scan_control, fde_p);
      WHILEND;

      STRINGREP (msg_string, msg_string_length, permanent_files_recovered);
      msg_string (msg_string_length + 1, 28) := ' PERMANENT FILE(S) RECOVERED';

      dmp$issue_message_to_ascii_log (msg_string (1, 28 + msg_string_length), local_status);

      STRINGREP (msg_string, msg_string_length, permanent_files_not_recovered);
      msg_string (msg_string_length + 1, 32) := ' PERMANENT FILE(S) NOT RECOVERED';

      dmp$issue_message_to_ascii_log (msg_string (1, 32 + msg_string_length), local_status);

      { Flush device logs for all volumes not being recovered.  This is done to make sure that
      { any files that were attached for recovery get their file table entries deleted before they
      { can interfere with the automatic reconciliation that takes place later between Permanent
      { File Manager and Device Manager. Volumes being recovered shouldn't be done here because
      { they will be flushed as part of their recovery process.

      FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND (dmv$p_active_volume_table^) DO
        IF NOT dmv$p_active_volume_table^ [avt_index].entry_available AND NOT
              dmv$p_active_volume_table^ [avt_index].mass_storage.logged_in_for_recovery AND
              (dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log <> dmv$null_sfid) THEN
          dmp$evacuate_active_device_log (avt_index, local_status);
        IFEND;
      FOREND;
    IFEND;

  PROCEND recover_files;
?? TITLE := '  recover_log', EJECT ??

  PROCEDURE recover_log (old_image_pointers: dmt$old_image_pointers;
        avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      p_login_table: ^dmt$ms_mainframe_login_table,
      lt_entry_index: dmt$login_table_entries,
      close_status: ost$status;

    status.normal := TRUE;

    dmp$open_login_table (dmv$p_active_volume_table^ [avt_index].mass_storage.p_login_table,
       osc$os_ring_1, osc$tsrv_ring, mmc$sar_read, mmc$as_sequential, p_login_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /login_table_open/
    BEGIN

      dmp$search_login_table (p_login_table, dmc$production_login_entry, lt_entry_index);

      IF (lt_entry_index = 0) OR (lt_entry_index = dmv$p_active_volume_table^ [avt_index].mass_storage.
            mainframe_assigned.log_in_index) THEN
        EXIT /login_table_open/;
      IFEND;

      IF old_image_pointers.old_image_status = dmc$old_image_available THEN
        recover_log_with_image (old_image_pointers, p_login_table^.body [lt_entry_index].device_log_name,
              avt_index, p_login_table, lt_entry_index, status);
        IF NOT status.normal THEN
          EXIT /login_table_open/;
        IFEND;
      ELSE
        recover_log_without_image (p_login_table^.body [lt_entry_index].device_log_name, avt_index,
              p_login_table, lt_entry_index, status);
        IF NOT status.normal THEN
          EXIT /login_table_open/;
        IFEND;
      IFEND;

      IF syv$job_recovery_option <> syc$jre_enabled THEN
        dmp$return_dat_entries (dmv$p_active_volume_table^ [avt_index].mass_storage.mainframe_assigned,
              avt_index, dmc$return_all_except_entry, status);
        IF NOT status.normal THEN
          EXIT /login_table_open/;
        IFEND;
      IFEND;

      dmp$return_dfl_entries (p_login_table^.body [lt_entry_index].mainframe_assigned, avt_index, status);
      IF NOT status.normal THEN
        EXIT /login_table_open/;
      IFEND;

    END /login_table_open/;

    dmp$close_file (p_login_table, close_status);
    IF status.normal THEN
      status := close_status;
    IFEND;

  PROCEND recover_log;
?? TITLE := '  recover_log_with_image', EJECT ??

  PROCEDURE recover_log_with_image (old_image_pointers: dmt$old_image_pointers;
        old_device_log_name: ost$name;
        avt_index: dmt$active_volume_table_index;
        p_login_table: ^dmt$ms_mainframe_login_table;
        lt_entry_index: dmt$login_table_entries;
    VAR status: ost$status);

    VAR
      old_log_index: dmt$directory_index,
      old_log_found: boolean,
      p_directory: ^dmt$ms_volume_directory,
      old_log_global_file_name: dmt$global_file_name,
      image_segment: ost$segment,
      old_device_log_sfid: gft$system_file_identifier,
      old_allocation_log: ^dmt$allocation_log_info,
      scan_control: gft$scan_all_fdes_state,
      file_modified: boolean,
      fmd_modified: boolean,
      fde_p: gft$file_desc_entry_p,
      local_status: ost$status;

    status.normal := TRUE;
    old_log_index := 0;
    old_log_found := FALSE;

    dmp$search_vol_directory_name (old_device_log_name, dmv$p_active_volume_table^ [avt_index].mass_storage.
          p_directory, old_log_index, old_log_found, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT old_log_found THEN
      {! Allow recovery of this volume
      {! if it is being added to the mainframe during this deadstart
      dmp$issue_message_to_ascii_log ('OLD LOG NOT FOUND IN DIRECTORY', status);
      RETURN;
    IFEND;

    dmp$open_directory (dmv$p_active_volume_table^ [avt_index].mass_storage.p_directory,
       osc$os_ring_1, osc$tsrv_ring, mmc$sar_read, mmc$as_sequential, p_directory, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    old_log_global_file_name := p_directory^.entries [old_log_index].global_file_name;

    dmp$close_file (p_directory, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    old_log_found := FALSE;
    image_segment := old_image_pointers.old_wired_segment;

    gfp$scan_all_fdes_in_image (image_segment, scan_control, fde_p);

  /search_for_old_log/
    WHILE fde_p <> NIL DO
      IF fde_p^.global_file_name = old_log_global_file_name THEN
        old_log_found := TRUE;
        EXIT /search_for_old_log/;
      IFEND;
      gfp$scan_all_fdes_in_image ( 0, scan_control, fde_p);
    WHILEND /search_for_old_log/;

    IF NOT old_log_found THEN
      {! Allow recovery of this volume
      {! if it is being added to the mainframe during this deadstart
      dmp$issue_message_to_ascii_log ('OLD LOG NOT FOUND IN MEMORY IMAGE', status);
      {! Recover log as if no image present to clean up old log
      recover_log_without_image (old_device_log_name, avt_index, p_login_table, lt_entry_index, status);
      RETURN;
    IFEND;

    IF p_login_table^.body [lt_entry_index].recovery_status = dmc$lt_being_recovered THEN
      dmp$recover_file (fde_p, status);
      IF NOT status.normal THEN
        CASE status.condition OF
        = dme$rf_no_vol_assigned_to_file =
          status.normal := TRUE;
        = dme$volume_not_online =
          status.normal := TRUE;
        = dme$unknown_device_file =
          status.normal := TRUE;
        = dme$unable_to_attach_for_rec =
          status.normal := TRUE;
        ELSE
          RETURN;
        CASEND;
      IFEND;

      dmp$evacuate_active_device_log (avt_index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    IFEND;

    dmp$attach_device_file (dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn, p_login_table^.
          body [lt_entry_index].device_log_name, old_device_log_sfid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_login_table^.body [lt_entry_index].recovery_status = dmc$lt_being_rec_alloc_complete THEN
      old_allocation_log := NIL;
    ELSE
      old_allocation_log := old_image_pointers.old_allocation_log_info;
    IFEND;

  /old_log_attached/
    BEGIN
      update_eoi (old_device_log_sfid, status);

      IF NOT status.normal THEN
        EXIT /old_log_attached/;
      IFEND;

      dmp$evacuate_old_device_log (avt_index, p_login_table^.body [lt_entry_index].mainframe_assigned,
            dmv$p_active_volume_table^ [avt_index].mass_storage.p_login_table, old_device_log_sfid,
            old_allocation_log, status);
      IF NOT status.normal THEN
        EXIT /old_log_attached/;
      IFEND;

    END /old_log_attached/;
    dmp$detach_device_file (old_device_log_sfid, file_modified, fmd_modified, local_status);
    IF (NOT local_status.normal) AND status.normal THEN
      status := local_status;
    IFEND;


  PROCEND recover_log_with_image;
?? TITLE := '  recover_log_without_image', EJECT ??

  PROCEDURE recover_log_without_image (old_device_log_name: ost$name;
        avt_index: dmt$active_volume_table_index;
        p_login_table: ^dmt$ms_mainframe_login_table;
        lt_entry_index: dmt$login_table_entries;
    VAR status: ost$status);

    VAR
      allocated_length: amt$file_byte_address,
      close_status: ost$status,
      detach_status: ost$status,
      dfl_index: dmt$device_file_list_index,
      file_modified: boolean,
      fmd_modified: boolean,
      initialized_length: amt$file_byte_address,
      old_device_log_sfid: gft$system_file_identifier,
      old_log_index: dmt$directory_index,
      old_log_found: boolean,
      p_dflt: ^dmt$ms_device_file_list_table,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry;

    old_log_index := 0;
    old_log_found := FALSE;

    dmp$search_vol_directory_name (old_device_log_name, dmv$p_active_volume_table^ [avt_index].mass_storage.
          p_directory, old_log_index, old_log_found, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT old_log_found THEN
      {! Allow recovery of this volume
      {! if it is being added to the mainframe during this deadstart
      dmp$issue_message_to_ascii_log ('OLD LOG NOT FOUND IN DIRECTORY', status);
      RETURN;
    IFEND;

    dmp$attach_device_file (dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn,
          old_device_log_name, old_device_log_sfid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /old_log_attached/
    BEGIN
      update_eoi (old_device_log_sfid, status);

      IF NOT status.normal THEN
        EXIT /old_log_attached/;
      IFEND;

      dmp$evacuate_old_device_log (avt_index, p_login_table^.body [lt_entry_index].mainframe_assigned,
            dmv$p_active_volume_table^ [avt_index].mass_storage.p_login_table, old_device_log_sfid, NIL,
            status);

      IF NOT status.normal THEN
        EXIT /old_log_attached/;
      IFEND;

  {   Go back through dat and reflect possible length changes caused by transactions
  {   against old log just processed from old log.

      gfp$get_fde_p (old_device_log_sfid, p_fde);

      dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
      dfl_index := p_dfd^.p_fmd^.dfl_index;

      dmp$open_dflt (dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_file_list_table,
            osc$os_ring_1, osc$tsrv_ring, mmc$sar_read, mmc$as_sequential, p_dflt, status);
      IF NOT status.normal THEN
        EXIT /old_log_attached/;
      IFEND;

    /dflt_open/
      BEGIN
        dmp$retrieve_allocation_info (^p_dflt^.entries [dfl_index], avt_index, allocated_length,
              initialized_length, status);
        IF NOT status.normal THEN
          EXIT /dflt_open/;
        IFEND;

        dmp$fixup_fmd_allocated_length (old_device_log_sfid, 1, allocated_length, status);
        IF NOT status.normal THEN
          EXIT /dflt_open/;
        IFEND;

        dmp$set_eoi (old_device_log_sfid, initialized_length, status);
      END /dflt_open/;

      dmp$close_file (p_dflt, close_status);

      IF NOT close_status.normal AND status.normal THEN
        status := close_status;
      IFEND;
    END /old_log_attached/;

    dmp$detach_device_file (old_device_log_sfid, file_modified, fmd_modified, detach_status);

    IF NOT detach_status.normal AND status.normal THEN
      status := detach_status;
    IFEND;
  PROCEND recover_log_without_image;
?? TITLE := '  recover_logs', EJECT ??

  PROCEDURE recover_logs (old_image_pointers: dmt$old_image_pointers;
    VAR status: ost$status);

    VAR
      all_logs_recovered: boolean,
      recorded_vsn: rmt$recorded_vsn,
      local_status: ost$status,
      msg_string: string (50),
      avt_index: dmt$active_volume_table_index;

    status.normal := TRUE;
    all_logs_recovered := TRUE;

    avt_index := 0;
    REPEAT
      locate_next_volume (avt_index);

      IF (avt_index <> 0) THEN
        recorded_vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;

        msg_string (1, 20) := ' RECOVERING LOG FOR ';
        msg_string (21, * ) := recorded_vsn;

        dmp$issue_message_to_ascii_log (msg_string, local_status);
        clp$put_job_output (msg_string, local_status);

        recover_log (old_image_pointers, avt_index, status);
        IF NOT status.normal THEN
          dmp$log_abnormal_status (status);
          msg_string (1, 28) := '  UNABLE TO RECOVER LOG FOR ';
          msg_string (29, * ) := recorded_vsn;
          clp$put_job_output (msg_string, local_status);
        ELSE
          msg_string (1, 19) := ' RECOVERED LOG FOR ';
          msg_string (20, * ) := recorded_vsn;
          clp$put_job_output (msg_string, local_status);
        IFEND;

        dmp$issue_message_to_ascii_log (msg_string, local_status);

        all_logs_recovered := all_logs_recovered AND status.normal;
      IFEND;
    UNTIL (avt_index = 0);

    IF NOT all_logs_recovered THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_recover_all_logs,
        'Unable to recover all logs.', status);
    IFEND;
  PROCEND recover_logs;
?? TITLE := '  recover_volumes', EJECT ??

  PROCEDURE recover_volumes (VAR status: ost$status);

    VAR
      all_volumes_recovered: boolean,
      recorded_vsn: rmt$recorded_vsn,
      local_status: ost$status,
      msg_string: string (40),
      avt_index: dmt$active_volume_table_index;

    status.normal := TRUE;
    all_volumes_recovered := TRUE;

    avt_index := 0;
    REPEAT
      locate_next_volume (avt_index);

      IF (avt_index <> 0) THEN
        recorded_vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;

        msg_string (1, 11) := 'RECOVERING ';
        msg_string (12, * ) := recorded_vsn;

        dmp$issue_message_to_ascii_log (msg_string, local_status);

        dmp$recover_volume (avt_index, status);
        IF NOT status.normal THEN
          dmp$log_abnormal_status (status);
          msg_string (1, 20) := '  UNABLE TO RECOVER ';
          msg_string (21, * ) := recorded_vsn;
          clp$put_job_output (msg_string, local_status);
        ELSE
          msg_string (1, * ) := 'RECOVERED ';
          msg_string (11, * ) := recorded_vsn;
        IFEND;

        dmp$issue_message_to_ascii_log (msg_string, local_status);

        all_volumes_recovered := all_volumes_recovered AND status.normal;
      IFEND;
    UNTIL (avt_index = 0);

    IF NOT all_volumes_recovered THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_recover_all_vols,
        'Unable to recover all volumes.', status);
    IFEND;
  PROCEND recover_volumes;
?? TITLE := '  return_old_mat_space', EJECT ??

  PROCEDURE return_old_mat_space (old_image_pointers: dmt$old_image_pointers);

    VAR
      p_old_avt: ^dmt$active_volume_table,
      old_wired_segment: ost$segment,
      paa: ^^cell,
      internal_vsn: dmt$internal_vsn,
      mainframe_assigned: dmt$mainframe_assigned,
      p_old_mat: cyt$adaptable_array_pointer,
      old_avt_index: dmt$active_volume_table_index,
      avt_index: dmt$active_volume_table_index;

    IF (old_image_pointers.old_image_status <> dmc$old_image_available) THEN
      RETURN;
    IFEND;

    p_old_avt := old_image_pointers.p_avt_pointer^;
    old_wired_segment := #segment (old_image_pointers.p_avt_pointer);
    paa := #LOC (p_old_avt);
    i#build_adaptable_array_ptr (1, old_wired_segment, #offset (p_old_avt), #SIZE (p_old_avt^),
          LOWERBOUND (p_old_avt^), #SIZE (p_old_avt^ [1]), #LOC (paa^));

    avt_index := 0;
    REPEAT
      locate_next_volume (avt_index);

      IF (avt_index <> 0) THEN
        internal_vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.internal_vsn;
        locate_avt_entry (p_old_avt, internal_vsn, old_avt_index);

        IF (old_avt_index <> 0) THEN
          get_recovery_id (avt_index, mainframe_assigned);
          IF (mainframe_assigned = p_old_avt^ [old_avt_index].mass_storage.mainframe_assigned) THEN
            p_old_mat := p_old_avt^ [old_avt_index].mass_storage.p_mat;
            p_old_mat.pointer := #address (1, old_wired_segment, #offset (p_old_mat.pointer));
            dmp$return_mat_space (p_old_mat, mainframe_assigned, avt_index);
          IFEND;
        IFEND;
      IFEND;
    UNTIL (avt_index = 0);
  PROCEND return_old_mat_space;
?? TITLE := '  start_volume_production', EJECT ??

  PROCEDURE start_volume_production (VAR status: ost$status);

    VAR
      production_started: boolean,
      avt_index: dmt$active_volume_table_index,
      vsn: rmt$recorded_vsn,
      msg_string: string (50),
      local_status: ost$status;

    status.normal := TRUE;
    production_started := TRUE;

    avt_index := 0;
    REPEAT
      locate_next_volume (avt_index);

      IF (avt_index <> 0) THEN
        vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;

        msg_string (1, 32) := '  Starting production on volume ';
        msg_string (33, * ) := vsn;
        dmp$issue_message_to_ascii_log (msg_string, local_status);

        dmp$start_volume_production (avt_index, status);

        IF NOT status.normal THEN
          dmp$log_abnormal_status (status);
          msg_string (1, 39) := '  Unable to start production on volume ';
          msg_string (40, * ) := vsn;
          clp$put_job_output (msg_string, local_status);
        ELSE
          msg_string (1, 31) := '  Production started on volume ';
          msg_string (32, * ) := vsn;
        IFEND;

        dmp$issue_message_to_ascii_log (msg_string, local_status);
        production_started := production_started AND status.normal;
      IFEND;
    UNTIL (avt_index = 0);

    IF NOT production_started THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_recover_all_vols,
        'Unable to start production on all volumes.', status);
    IFEND;
  PROCEND start_volume_production;
?? TITLE := '  update_eoi', EJECT ??

  PROCEDURE update_eoi (sfid: dmt$system_file_id;
    VAR status: ost$status);

    VAR
      allocated_length: amt$file_byte_address,
      bytes_per_allocation: amt$file_byte_address,
      fau_state: dmt$fau_states,
      initialized_length: amt$file_byte_address,
      level_1_index: dmt$level_1_index,
      level_2_index: dmt$level_2_index,
      offset: amt$file_byte_address,
      p_dfd: ^dmt$disk_file_descriptor,
      p_fde: ^gft$file_descriptor_entry,
      p_level_1: ^dmt$level_1_table,
      p_level_2: ^dmt$level_2_table;

    gfp$get_fde_p (sfid, p_fde);

{!!!!!   Are all callers of this assigned a volume????

    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);
    bytes_per_allocation := p_dfd^.bytes_per_allocation;
    allocated_length := 0;
    initialized_length := 0;
    offset := 0;

    dmp$get_level_1_ptr (p_dfd, p_level_1);
    IF p_level_1 <> NIL THEN
      FOR level_1_index := 0 TO p_dfd^.fat_upper_bound DO
        dmp$get_level_2_ptr (^p_level_1^ [level_1_index], p_level_2);
        IF p_level_2 <> NIL THEN
          FOR level_2_index := 0 TO (p_dfd^.bytes_per_level_2 DIV bytes_per_allocation) - 1 DO
            offset := offset + bytes_per_allocation;
            fau_state := p_level_2^ [level_2_index].state;
            IF (fau_state <> dmc$fau_free) THEN
              allocated_length := allocated_length + bytes_per_allocation;
              IF (fau_state = dmc$fau_initialized) OR (fau_state = dmc$fau_initialized_and_flawed) THEN
                initialized_length := offset;
              IFEND;
            IFEND;
          FOREND;
        ELSE;
         offset := offset + p_dfd^.bytes_per_level_2;
        IFEND;
      FOREND;
    IFEND;

    dmp$fixup_fmd_allocated_length (sfid, 1, allocated_length, status);

    IF status.normal THEN
      dmp$set_eoi (sfid, initialized_length, status);
    IFEND;
  PROCEND update_eoi;
MODEND dmm$recover_mainframe;
*DECK DECK=DMM$RECOVER_VOLUME EXPAND=TRUE

?? RIGHT := 110 ??
*copy OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE Device Management' ??
MODULE dmm$recover_volume;

{ PURPOSE:
{  The purpose of this module is to recover a mass storage volume.
{  Recovering a volume involves cleaning up any permanent files
{  left attached in write mode after the normal file recovery
{  process (if normal file recovery took place), and verifying the
{  integrity of any device files.  Last of all the mainframe being
{  recovered is logged out of the volume.

?? PUSH (LISTEXT := ON) ??
?? NEWTITLE := '  Declarations' ??
*copyc dmt$active_volume_table_index
*copyc dmt$device_file_list_index
*copyc dmt$error_condition_codes
*copyc dmt$file_descriptor_entry
*copyc dmt$keypoint_calls
*copyc dmt$ms_device_allocation_table
*copyc dmt$ms_device_file_list_entry
*copyc mme$condition_codes
*copyc OST$STATUS
?? POP ??
?? TITLE := '  XREF Procedures', EJECT ??
*copyc clp$put_job_output
*copyc dmp$close_file
*copyc dmp$destroy_device_file
*copyc dmp$evacuate_active_device_log
*copyc dmp$issue_message_to_ascii_log
*copyc dmp$logout_recovered_mainframe
*copyc dmp$log_abnormal_status
*copyc dmp$open_dat
*copyc dmp$open_dflt
*copyc dmp$open_directory
*copyc dmp$open_login_table
*copyc dmp$process_device_log_entry
*copyc dmp$search_vol_directory_name
*copyc dmp$search_login_table
*copyc mmp$write_modified_pages
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal
*copyc pmp$continue_to_cause
*copyc pmp$convert_binary_unique_name
?? TITLE := '  XREF Variables', EJECT ??
*copyc DMV$ACTIVE_VOLUME_TABLE
?? TITLE := '  dmp$recover_volume', EJECT ??

  PROCEDURE [XDCL] dmp$recover_volume (avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      p_login_table: ^dmt$ms_mainframe_login_table,
      lt_entry_index: dmt$login_table_entries,
      close_status: ost$status;

    status.normal := TRUE;

  /process_request/
    BEGIN
      dmp$open_login_table (dmv$p_active_volume_table^ [avt_index].mass_storage.p_login_table,
         osc$os_ring_1, osc$tsrv_ring, mmc$sar_read, mmc$as_sequential, p_login_table, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

    /login_table_open/
      BEGIN

        dmp$search_login_table (p_login_table, dmc$production_login_entry, lt_entry_index);

        IF (lt_entry_index = 0) OR (lt_entry_index = dmv$p_active_volume_table^ [avt_index].mass_storage.
              mainframe_assigned.log_in_index) THEN
          EXIT /login_table_open/;
        IFEND;

        dmp$evacuate_active_device_log (avt_index, status);
        IF NOT status.normal THEN
          EXIT /login_table_open/;
        IFEND;

        cleanup_volume_files (avt_index, p_login_table^.body [lt_entry_index].mainframe_assigned, status);
        IF NOT status.normal THEN
          EXIT /login_table_open/;
        IFEND;

        logout_mf_being_recovered (p_login_table, avt_index, lt_entry_index, status);
        IF NOT status.normal THEN
          EXIT /login_table_open/;
        IFEND;

      END /login_table_open/;

      dmp$close_file (p_login_table, close_status);
      IF NOT close_status.normal AND status.normal THEN
        status := close_status;
      IFEND;

    END /process_request/;

  PROCEND dmp$recover_volume;
?? TITLE := '  cleanup_volume_files', EJECT ??

  PROCEDURE cleanup_volume_files (avt_index: dmt$active_volume_table_index;
        mainframe_assigned: dmt$mainframe_assigned;
    VAR status: ost$status);

    VAR
      character_string_length: integer,
      close_status: ost$status,
      current_msg_position: integer,
      dfl_index: dmt$device_file_list_index,
      ignore_status: ost$status,
      msg_string: string (70),
      p_dflt: ^dmt$ms_device_file_list_table,
      rvsn: rmt$recorded_vsn;


     PROCEDURE dfl_condition_handler (condition: pmt$condition;
                                      condition_descriptor: ^pmt$condition_information;
                                      save_area: ^ost$stack_frame_save_area;
                                  VAR status: ost$status);

       VAR
         error_message: string (140),
         ignore_status: ost$status,
         message_length: integer,
         message_line1: string (70),
         message_line2: string (70),
         p_sac: ^mmt$segment_access_condition;

       IF condition.selector = mmc$segment_access_condition THEN
         CASE condition.segment_access_condition.identifier OF
         = mmc$sac_io_read_error =
           STRINGREP (message_line1, message_length, ' *** IO ERROR ON SYSTEM FILE TABLE - DFL - FOR ',
                 dmv$p_active_volume_table^[avt_index].mass_storage.recorded_vsn);
           clp$put_job_output (message_line1(1, message_length), ignore_status);
           STRINGREP (message_line2, message_length, ' DFL_INDEX= ', dfl_index,
                 ' - cleanup_volume_files ***');
           clp$put_job_output (message_line2(1, message_length), ignore_status);
           STRINGREP (error_message, message_length, message_line1, message_line2);
           osp$set_status_abnormal ('MM', mme$io_read_error, error_message(1, message_length), status);
           dmp$log_abnormal_status (status);
           dmp$close_file (p_dflt, ignore_status);
           status.normal := TRUE;
           EXIT cleanup_volume_files;
         ELSE
         CASEND;
       IFEND;

       pmp$continue_to_cause (pmc$execute_standard_procedure, status);

     PROCEND dfl_condition_handler;

?? TITLE := '  cleanup_volume_files', EJECT ??

    status.normal := TRUE;

    dmp$open_dflt (dmv$p_active_volume_table^ [avt_index].mass_storage.
          p_device_file_list_table, osc$os_ring_1, osc$tsrv_ring, mmc$sar_read, mmc$as_sequential,
          p_dflt, status);
    IF NOT status.normal THEN
      dmp$log_abnormal_status (status);
      osp$set_status_abnormal (dmc$device_manager_ident, dme$open_dflt_failure,
        'unable to open device file list - cleanup_volume_files', status);
      RETURN;
    IFEND;

  /dflt_open/
    BEGIN

      osp$establish_condition_handler (^dfl_condition_handler, FALSE);
      current_msg_position := 1;
      msg_string (current_msg_position, * ) := ' VSN - ';
      current_msg_position := current_msg_position + 7;
      msg_string (current_msg_position, * ) := dmv$p_active_volume_table^ [avt_index].mass_storage.
            recorded_vsn;
      current_msg_position := current_msg_position + STRLENGTH (dmv$p_active_volume_table^ [avt_index].
            mass_storage.recorded_vsn) + 1;
      msg_string (current_msg_position, * ) := 'UNABLE TO CLEANUP DEVICE FILE INDEX - ';
      current_msg_position := current_msg_position + 38 + 1;
      FOR dfl_index := 1 TO UPPERBOUND (p_dflt^.entries) DO
        IF p_dflt^.entries [dfl_index].flags = dmc$dfle_assigned_to_file THEN
          STRINGREP (msg_string (current_msg_position, * ), character_string_length, dfl_index);
          CASE p_dflt^.entries [dfl_index].file_kind OF
          = gfc$fk_device_file =
            cleanup_device_file (avt_index, ^p_dflt^.entries [dfl_index], dfl_index, status);
            IF NOT status.normal THEN
              dmp$log_abnormal_status (status);
              osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_cleanup_file,
                'unable to cleanup device file - cleanup_volume_files', status);
              dmp$issue_message_to_ascii_log (msg_string, close_status);
              EXIT /dflt_open/;
            IFEND;
          = gfc$fk_job_permanent_file, gfc$fk_catalog =
            IF mainframe_assigned.log_in_index IN p_dflt^.entries [dfl_index].login_set THEN
              cleanup_permanent_file (avt_index, ^p_dflt^.entries [dfl_index], dfl_index,
                    mainframe_assigned, status);
              IF NOT status.normal THEN
                dmp$log_abnormal_status (status);
                status.normal := TRUE;
                dmp$issue_message_to_ascii_log (msg_string, ignore_status);
              IFEND;
            IFEND;
          ELSE
            osp$set_status_abnormal (dmc$device_manager_ident, dme$unrecognizable_file_type,
              'dmp$recover_volume', status);
            EXIT /dflt_open/;
          CASEND;
        IFEND;
      FOREND;

    END /dflt_open/;

    osp$disestablish_cond_handler;
    dmp$close_file (p_dflt, close_status);
    IF NOT close_status.normal AND status.normal THEN
      status := close_status;
    IFEND;

  PROCEND cleanup_volume_files;
?? TITLE := '  cleanup_device_file', EJECT ??

  PROCEDURE cleanup_device_file (avt_index: dmt$active_volume_table_index;
        p_dfl_entry: ^dmt$ms_device_file_list_entry;
        dfl_index: dmt$device_file_list_index;
    VAR status: ost$status);

    VAR
      log_entry: dmt$dl_entry,
      p_directory: ^dmt$ms_volume_directory,
      directory_entry_index: dmt$directory_index,
      directory_index: dmt$directory_index,
      close_status: ost$status;

    status.normal := TRUE;

    dmp$open_directory (dmv$p_active_volume_table^ [avt_index].mass_storage.p_directory,
       osc$os_ring_1, osc$tsrv_ring, mmc$sar_read, mmc$as_sequential, p_directory, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

      directory_entry_index := 0;

    /search_directory/
      FOR directory_index := 1 TO UPPERBOUND (p_directory^.entries) DO
        IF NOT p_directory^.entries [directory_index].entry_available THEN
          IF p_dfl_entry^.global_file_name = p_directory^.entries [directory_index].global_file_name THEN
            directory_entry_index := directory_index;
            EXIT /search_directory/;
          IFEND;
        IFEND;
      FOREND /search_directory/;

      IF directory_entry_index = 0 THEN
        log_entry.kind := dmc$dl_purge_file;
        log_entry.purge_file_block.global_file_name := p_dfl_entry^.global_file_name;
        log_entry.purge_file_block.dfl_index := dfl_index;
        log_entry.purge_file_block.file_byte_address := p_dfl_entry^.file_byte_address;

        dmp$process_device_log_entry (avt_index, log_entry, status);
      IFEND;

    dmp$close_file (p_directory, close_status);
    IF NOT close_status.normal AND status.normal THEN
      status := close_status;
    IFEND;

  PROCEND cleanup_device_file;
?? TITLE := '  cleanup_permanent_file', EJECT ??

  PROCEDURE cleanup_permanent_file (avt_index: dmt$active_volume_table_index;
        p_dfl_entry: ^dmt$ms_device_file_list_entry;
        dfl_index: dmt$device_file_list_index;
        mainframe_assigned: dmt$mainframe_assigned;
    VAR status: ost$status);

    VAR
      allocated_length: amt$file_byte_address,
      ignore_status: ost$status,
      initialized_length: amt$file_byte_address,
      log_entry: dmt$dl_entry,
      msg_string: string(75),
      msg_string_length: integer,
      unique_name: ost$name;

    status.normal := TRUE;

    dmp$retrieve_allocation_info (p_dfl_entry, avt_index, allocated_length, initialized_length, status);
    IF status.normal THEN

      log_entry.kind := dmc$dl_update_file_length;
      log_entry.file_length_block.global_file_name := p_dfl_entry^.global_file_name;
      log_entry.file_length_block.dfl_index := dfl_index;

      log_entry.file_length_block.eof_specified := TRUE;
      log_entry.file_length_block.eof := initialized_length;

      {amc$file_byte_limit is used to flag this file as having gone
      {through a recovery without image while attached in write mode.
      {dmp$build_fat_for_existing_file will detect this and fixup both
      {eof and eoi to reflect the maximum initialized length for all subfiles.

      log_entry.file_length_block.eoi_specified := TRUE;
      log_entry.file_length_block.eoi := amc$file_byte_limit;

      dmp$process_device_log_entry (avt_index, log_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      log_entry.kind := dmc$dl_update_fmd_length;
      log_entry.fmd_length_block.global_file_name := p_dfl_entry^.global_file_name;
      log_entry.fmd_length_block.dfl_index := dfl_index;

      log_entry.fmd_length_block.fmd_length_specified := TRUE;
      log_entry.fmd_length_block.fmd_length := allocated_length;

      log_entry.fmd_length_block.logical_length_specified := TRUE;
      log_entry.fmd_length_block.logical_length := initialized_length;

      dmp$process_device_log_entry (avt_index, log_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    ELSE

      dmp$log_abnormal_status (status);
      pmp$convert_binary_unique_name (p_dfl_entry^.global_file_name, unique_name, ignore_status);
      STRINGREP (msg_string, msg_string_length, ' VSN - ', dmv$p_active_volume_table^[avt_index].
            mass_storage.recorded_vsn, ' DFL INDEX - ', dfl_index, ' GFN - ', unique_name);
      dmp$issue_message_to_ascii_log (msg_string (1, msg_string_length), ignore_status);

      log_entry.kind := dmc$dl_file_damaged;
      log_entry.file_damaged_block.global_file_name := p_dfl_entry^.global_file_name;
      log_entry.file_damaged_block.dfl_index := dfl_index;
      log_entry.file_damaged_block.add_damage := $dmt$file_damage[dmc$allocation_chain_broken];
      log_entry.file_damaged_block.remove_damage := $dmt$file_damage[];

      dmp$process_device_log_entry (avt_index, log_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    log_entry.kind := dmc$dl_detach_file;
    log_entry.attach_file_block.global_file_name := p_dfl_entry^.global_file_name;
    log_entry.attach_file_block.dfl_index := dfl_index;
    log_entry.attach_file_block.mainframe_assigned := mainframe_assigned;

    dmp$process_device_log_entry (avt_index, log_entry, status);

  PROCEND cleanup_permanent_file;
?? TITLE := '  logout_mf_being_recovered', EJECT ??

  PROCEDURE logout_mf_being_recovered (p_login_table: ^dmt$ms_mainframe_login_table;
        avt_index: dmt$active_volume_table_index;
        lt_entry_index: dmt$login_table_entries;
    VAR status: ost$status);

    VAR
      mainframe_assigned: dmt$mainframe_assigned;

    status.normal := TRUE;

    mainframe_assigned := p_login_table^.body [lt_entry_index].mainframe_assigned;

    dmp$logout_recovered_mainframe (avt_index, lt_entry_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$evacuate_active_device_log (avt_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND logout_mf_being_recovered;
?? TITLE := '  dmp$retrieve_allocation_info', EJECT ??

  PROCEDURE [XDCL] dmp$retrieve_allocation_info (p_dfl_entry: ^dmt$ms_device_file_list_entry;
        avt_index: dmt$active_volume_table_index;
    VAR allocated_length: amt$file_byte_address;
    VAR initialized_length: amt$file_byte_address;
    VAR status: ost$status);

    VAR
      bytes_per_au: amt$file_byte_address,
      p_dat: ^dmt$ms_device_allocation_table,
      current_allocation_unit_dau: dmt$dau_address,
      close_status: ost$status;

    status.normal := TRUE;

    allocated_length := 0;
    initialized_length := 0;

    IF p_dfl_entry^.dau_chain_status = dmc$dau_chain_not_linked THEN
      RETURN;
    IFEND;

    dmp$open_dat (dmv$p_active_volume_table^ [avt_index].mass_storage.
          p_device_allocation_table, osc$os_ring_1, osc$tsrv_ring, mmc$sar_read, mmc$as_sequential,
          p_dat, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_allocation_unit_dau := p_dfl_entry^.first_dau_address;
    bytes_per_au := p_dfl_entry^.daus_per_allocation_unit * p_dat^.header.bytes_per_dau;

  /dat_open/
    WHILE TRUE DO

      IF (p_dat^.body [current_allocation_unit_dau].dau_status <> dmc$dau_assigned_to_file) AND
         (p_dat^.body [current_allocation_unit_dau].dau_status <> dmc$dau_ass_to_file_swr_flawed) THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$premature_end_of_dat_chain,
          'dmp$retrieve_allocation_info - dau not assigned file', status);
        EXIT /dat_open/;
      IFEND;

      IF p_dat^.body [current_allocation_unit_dau].file_hash <> p_dfl_entry^.file_hash THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$crossed_allocation,
          'dmp$retrieve_allocation_info - dau/dfl disagree on file hash', status);
        EXIT /dat_open/;
      IFEND;

      allocated_length := allocated_length + bytes_per_au;

      IF p_dat^.body [current_allocation_unit_dau].data_status = dmc$dau_data_initialized THEN
        initialized_length := allocated_length;
      IFEND;

      IF (p_dat^.body [current_allocation_unit_dau].allocation_chain_position = dmc$first_and_last_allocation)
            OR (p_dat^.body [current_allocation_unit_dau].allocation_chain_position = dmc$last_allocation)
            THEN
        EXIT /dat_open/;
      IFEND;

      current_allocation_unit_dau := p_dat^.body [current_allocation_unit_dau].next_allocation_unit_dau;

    WHILEND /dat_open/;

    dmp$close_file (p_dat, close_status);
    IF NOT close_status.normal AND status.normal THEN
      status := close_status;
    IFEND;

  PROCEND dmp$retrieve_allocation_info;

MODEND dmm$recover_volume;
*DECK DECK=DMM$RUN_ASYNCHRONOUS_TASKS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE : device management' ??
?? NEWTITLE := '  module header', EJECT ??
MODULE dmm$run_asynchronous_tasks;

{  PURPOSE:
{    This module exists to provide entry points for asynchronous DM
{    tasks.
{  DESIGN:
{    Entry points are declared.  The tasks which they define spend
{    most of their time asleep in this module.  When there is work to do
{    a call is made down to ring 1.
?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc ost$heap
*copyc ost$status
*copyc dmt$active_volume_table_index
  ?? POP ??
?? OLDTITLE ??
?? NEWTITLE := '  XREF Procedures', EJECT ??
*copyc dmp$get_out_of_space_sets
*copyc pmp$get_executing_task_gtid
*copyc pmp$find_executing_task_xcb
*copyc mmp$assign_mass_storage
*copyc mmp$enable_transient_segments
*copyc pmp$wait
*copyc dmp$dev_mgmt_table_update
*copyc dmp$management_of_volume_space
*copyc tmp$save_system_task_id
*copyc dmp$set_lower_priority
*copyc syp$cleanup_heap_pages
*copyc dmp$split_allocation_log
*copyc ofp$execute_display_task
?? OLDTITLE ??
?? NEWTITLE := '  XREF Variables', EJECT ??
*copyc gfv$null_sfid
*copyc jmv$executing_within_system_job
*copyc dmv$internal_task_delay_values
*copyc dmv$active_volume_table
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL] dmp$administer_allocation_log', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$administer_allocation_log ALIAS 'dmxaalg';

*copyc dmh$administer_allocation_log

    VAR
      taskid: ost$global_task_id,
      time_delay: 0 .. 0ffffffffffff(16),
      status: ost$status;

    IF NOT jmv$executing_within_system_job THEN
      RETURN;
    IFEND;

    pmp$get_executing_task_gtid (taskid);

    dmp$set_lower_priority (split_al_task, taskid);

    tmp$save_system_task_id (tmc$stid_dm_split_al, TRUE, status);

    WHILE TRUE DO
      time_delay := dmv$split_allocation_log_delay;
      pmp$wait (time_delay, time_delay);
      dmp$split_allocation_log (FALSE, status);
    WHILEND;

  PROCEND dmp$administer_allocation_log;

?? OLDTITLE ??
?? NEWTITLE := '  [XDCL, #GATE] dmp$administer_device_log', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$administer_device_log ALIAS 'dmxadlg';

*copyc dmh$administer_device_log

    VAR
      taskid: ost$global_task_id,
      time_delay: 0 .. 0ffffffffffff(16),
      status: ost$status,
      xcb_p: ^ost$execution_control_block;

    IF NOT jmv$executing_within_system_job THEN
      RETURN;
    IFEND;

{ The following calls to assign space to the stack segments are
{ required to prevent page faulting for the stacks. Please do not
{ modify or delete these calls.

    pmp$find_executing_task_xcb (xcb_p);

    mmp$assign_mass_storage (xcb_p^.xp.tos_registers [3].pva.seg, gfv$null_sfid, 4096, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$assign_mass_storage (xcb_p^.xp.tos_registers [2].pva.seg, gfv$null_sfid, 4096, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$assign_mass_storage (xcb_p^.xp.tos_registers [1].pva.seg, gfv$null_sfid, 4096, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_executing_task_gtid (taskid);

    dmp$set_lower_priority (administer_log_task, taskid);

    tmp$save_system_task_id (tmc$stid_administer_log, TRUE, status);

    WHILE TRUE DO
      time_delay := dmv$process_device_log_delay;
      pmp$wait (time_delay, time_delay);
      dmp$dev_mgmt_table_update;

      syp$cleanup_heap_pages;
    WHILEND;

  PROCEND dmp$administer_device_log;

?? OLDTITLE ??
  ?? NEWTITLE := '[XDCL, #GATE] dmp$volume_space_management', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$volume_space_management;

    VAR
      new_classes: dmt$class,
      new_classes_out: boolean,
      new_count: integer,
      new_index: integer,
      old_count: integer,
      old_index: integer,
      p_old: ^dmt$out_of_space_sets,
      p_new: ^dmt$out_of_space_sets,
      p_save: ^dmt$out_of_space_sets,
      set_name: stt$set_name,
      taskid: ost$global_task_id,
      time_delay: 0 .. 0ffffffffffff(16),
      previous_added: integer,
      dmv$q_devices_added: [XREF] integer,
      status: ost$status,
      xcb_p: ^ost$execution_control_block;

    IF NOT jmv$executing_within_system_job THEN
      RETURN;
    IFEND;

    mmp$enable_transient_segments;

{ The following calls to assign space to the stack segments are
{ required to prevent page faulting for the stacks. Please do not
{ modify or delete these calls.

    pmp$find_executing_task_xcb (xcb_p);

    mmp$assign_mass_storage (xcb_p^.xp.tos_registers [3].pva.seg, gfv$null_sfid, 4096, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$assign_mass_storage (xcb_p^.xp.tos_registers [2].pva.seg, gfv$null_sfid, 4096, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$assign_mass_storage (xcb_p^.xp.tos_registers [1].pva.seg, gfv$null_sfid, 4096, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$assign_mass_storage (osc$segnum_task_private_heap, gfv$null_sfid, 50000, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_executing_task_gtid (taskid);

    dmp$set_lower_priority (volume_space_management_task, taskid);

    tmp$save_system_task_id (tmc$stid_volume_space_managemnt, TRUE, status);

    PUSH p_old: [1 .. UPPERBOUND (dmv$p_active_volume_table^) + 1];
    PUSH p_new: [1 .. UPPERBOUND (dmv$p_active_volume_table^) + 1];
    old_count := 0;
    previous_added := 0;

    WHILE TRUE DO
      dmp$management_of_volume_space;

      dmp$get_out_of_space_sets (p_new^, new_count);

      new_classes_out := FALSE;
      FOR new_index := 1 TO new_count DO
        new_classes := p_new^ [new_index].classes;
        IF (new_classes <> $dmt$class []) THEN
          set_name := p_new^ [new_index].set_name;
          old_index := new_index;
          IF (old_index > old_count) OR (set_name <> p_old^ [old_index].set_name) THEN
            old_index := 1;
            WHILE (old_index <= old_count) AND (set_name <> p_old^ [old_index].set_name) DO
              old_index := old_index + 1;
            WHILEND;
          IFEND;
          IF (old_index > old_count) OR ((new_classes - p_old^ [old_index].classes) <> $dmt$class []) THEN
            new_classes_out := TRUE;
          IFEND;
        IFEND;
      FOREND;

      p_save := p_old;
      p_old := p_new;
      p_new := p_save;
      old_count := new_count;

      IF new_classes_out OR (dmv$q_devices_added <> previous_added) THEN
        previous_added := dmv$q_devices_added;
        ofp$execute_display_task ('$LOCAL.DISPLAY_B', 'MASS_STORAGE                   ', status);
      IFEND;

      time_delay := dmv$volume_table_space_delay;
      pmp$wait (time_delay, time_delay);
    WHILEND;

  PROCEND dmp$volume_space_management;

MODEND dmm$run_asynchronous_tasks;
*DECK DECK=DMM$SAVE_RECONCILE_LIST EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$save_reconcile_list;

{
{ PURPOSE:
{
{  The purpose of this module is to create and maintain a list of all files known to
{  Device Manager at deadstart time. This is used to reconcile the files known to Permanent
{  File Manager with those known to Device Manager. The routines in this module are
{  only those required to run in ring 1 to have access to mainframe pageable.
{

?? TITLE := '  Common Decks', EJECT ??
*copyc dmt$reconcile_info
*copyc dmt$reconcile_locator
*copyc osd$virtual_address
*copyc ost$status
*copyc osv$mainframe_pageable_heap
*copyc oss$network_paged
*copyc ost$signature_lock
*copyc dmp$allocate_file_space_r1
*copyc gfp$get_segment_sfid
*copyc pmp$delay
*copyc pmp$get_microsecond_clock
*copyc syp$display_deadstart_message

?? TITLE := '  Global Declarations', EJECT ??

  VAR
    dmv$reconciliation_lock: [XDCL, #GATE, oss$network_paged] ost$signature_lock := [0],
    dmv$reconcile_locator: [XDCL, #GATE, oss$mainframe_pageable] dmt$reconcile_locator := NIL;

?? TITLE := '  dmp$save_reconcile_list', EJECT ??
*copyc dmh$save_reconcile_list

  PROCEDURE [XDCL, #GATE] dmp$save_reconcile_list
    (    reconcile_info: dmt$reconcile_info);

    CONST
      five_minutes = 1000000 * 60 * 5;

    VAR
      base: integer,
      clock: integer,
      local_stat: ost$status,
      p_reconcile_info: ^dmt$reconcile_info,
      p_sequence: ^SEQ ( * ),
      seq_size: ost$segment_length,
      status: ost$status,
      sfid: dmt$system_file_id,
      p_subfile_list: dmt$p_reconcile_list;

    IF dmv$reconcile_locator <> NIL THEN
      FREE dmv$reconcile_locator IN osv$mainframe_pageable_heap^;
    IFEND;

    seq_size := #size(reconcile_info) + #size(reconcile_info.p_sorted_reconcile_list^);
    ALLOCATE p_sequence: [[REP seq_size of cell ]] IN osv$mainframe_pageable_heap^;
    {Table can be huge - could fill up memory with unwritable modified pages if not allocated
    gfp$get_segment_sfid (#LOC (p_sequence^), sfid, status);
    IF status.normal THEN
      pmp$get_microsecond_clock (base, local_stat);
      REPEAT
        pmp$get_microsecond_clock (clock, local_stat);
        dmp$allocate_file_space_r1 (sfid, #offset (p_sequence), seq_size, 0,
            osc$nowait, sfc$no_limit, status);
        IF NOT status.normal THEN
          pmp$delay (5000, local_stat);
        IFEND;
      UNTIL status.normal OR (clock > (base + five_minutes));
      IF NOT status.normal THEN
        syp$display_deadstart_message ('!! SYSTEM HUNG ATTEMPTING TO ALLOCATE');
        syp$display_deadstart_message ('!! MAINFRAME PAGEABLE SEGMENT........');
        syp$display_deadstart_message ('!! REDEADSTART WITHOUT JOB RECOVERY..');
        REPEAT
          pmp$delay (5000, local_stat);
        UNTIL FALSE;
      IFEND;
    IFEND;
    dmv$reconcile_locator := p_sequence;
    RESET p_sequence;
    NEXT p_reconcile_info IN p_sequence;
    NEXT p_subfile_list: [1 .. UPPERBOUND (reconcile_info.p_sorted_reconcile_list^)] IN p_sequence;

    p_reconcile_info^ := reconcile_info;
    p_reconcile_info^.p_sorted_reconcile_list := p_subfile_list;

    p_subfile_list^ := reconcile_info.p_sorted_reconcile_list^;
  PROCEND dmp$save_reconcile_list;

?? TITLE := '  dmp$update_reconcile_list', EJECT ??
*copyc dmh$update_reconcile_list

  PROCEDURE [XDCL, #GATE] dmp$update_reconcile_list
    (    subfile_index: dmt$reconcile_index;
         purge_file: boolean;
         reconciled: boolean);
    VAR
      p_reconcile_info: ^dmt$reconcile_info;

    p_reconcile_info := dmv$reconcile_locator;
    p_reconcile_info^.p_sorted_reconcile_list^[subfile_index].purge := purge_file;
    p_reconcile_info^.p_sorted_reconcile_list^[subfile_index].reconciled := reconciled;
  PROCEND dmp$update_reconcile_list;

MODEND dmm$save_reconcile_list;

*DECK DECK=DMM$SEARCH_FOR_MS_LABEL EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Declarations' ??
?? RIGHT := 110 ??
MODULE dmm$search_for_ms_label;
{
{
{
*copy osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc dmt$device_allocation_unit
*copyc dmt$error_condition_codes
*copyc dmt$keypoint_calls
*copyc dmt$ms_logical_device_address
*copyc dmt$minimum_allocation_unit
*copyc dmt$ms_volume_label
*copyc dmt$physical_device_attributes
*copyc iot$io_function
*copyc iot$logical_unit
*copyc ost$status
  ?? POP ??
*copy iop$mass_storage_io
*copy pmp$zero_out_table
  ?? TITLE := 'dmp$locate_volume_label', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$locate_volume_label (logical_unit_number: iot$logical_unit;
        p_physical_attributes: ^dmt$physical_device_attributes;
    VAR ms_volume_label: dmt$ms_volume_label;
    VAR able_to_locate_vol_label: boolean);


    VAR
      index: integer,
      maus_per_cylinder: dmt$maus_per_position,
      maus_per_label: dmt$mau_address,
      bytes_per_mau: dmt$bytes_per_mau,
      maus_per_dau: dmt$maus_per_dau,
      p_volume_label: ^dmt$ms_volume_label,
      p_label_header: ^dmt$volume_label_header,
      p_label_body: ^dmt$ms_label_0_0,
      p_label_buffer: ^SEQ ( * ),
      p_ms_label: ^dmt$ms_volume_label,
      buffer_length_in_maus: dmt$maus_per_dau,
      label_size_in_bytes: ost$byte_count,
      device_address: dmt$ms_logical_device_address,
      status: ost$status,
      p_completion_status: ^iot$completion_status;

    #INLINE ('keypoint', osk$entry, 0, dmk$locate_vol_label);
    able_to_locate_vol_label := FALSE;

    p_volume_label := ^ms_volume_label;
    RESET p_volume_label;

    maus_per_cylinder := dmc$min_maus_position;
    bytes_per_mau := dmc$max_bytes_per_mau;
    maus_per_dau := dmc$min_maus_per_dau;

    IF p_physical_attributes <> NIL THEN
      FOR index := LOWERBOUND (p_physical_attributes^) TO UPPERBOUND (p_physical_attributes^) DO
        CASE p_physical_attributes^ [index].keyword OF
        = dmc$bytes_per_mau =
          bytes_per_mau := p_physical_attributes^ [index].bytes_per_mau;
        = dmc$maus_per_cylinder =
          maus_per_cylinder := p_physical_attributes^ [index].maus_per_cylinder;
        = dmc$maus_per_dau =
          maus_per_dau := p_physical_attributes^ [index].maus_per_dau;
        ELSE
        CASEND;
      FOREND;
    IFEND;

    maus_per_label := dmc$default_label_alloc_size DIV bytes_per_mau;

    label_size_in_bytes := #SIZE (dmt$volume_label_header);
    IF label_size_in_bytes <= #SIZE (ms_volume_label) THEN
      label_size_in_bytes := #SIZE (ms_volume_label);
    IFEND;

    IF ((label_size_in_bytes + bytes_per_mau - 1) DIV bytes_per_mau) < dmc$min_maus_per_dau THEN
      buffer_length_in_maus := dmc$min_maus_per_dau;
    ELSE
      buffer_length_in_maus := (label_size_in_bytes + bytes_per_mau - 1) DIV bytes_per_mau;
    IFEND;

    PUSH p_label_buffer: [[REP (buffer_length_in_maus * bytes_per_mau) OF cell]];
    RESET p_label_buffer;
    NEXT p_label_header IN p_label_buffer;

    device_address.allocation_unit_mau_address := 0;
    device_address.maus_per_position := maus_per_cylinder;
    device_address.logical_unit_number := logical_unit_number;
    device_address.transfer_length := buffer_length_in_maus;
    device_address.transfer_mau_offset := 0;
    device_address.write_translation := FALSE;
    pmp$zero_out_table (#LOC (p_label_buffer^), #SIZE (p_label_buffer^));

  /search_for_label_header/
    REPEAT
      iop$mass_storage_io (#LOC (p_label_buffer^), label_size_in_bytes, ioc$read_mass_storage, device_address,
            TRUE, p_completion_status, status);
      device_address.allocation_unit_mau_address := device_address.allocation_unit_mau_address +
           maus_per_label;
      able_to_locate_vol_label := status.normal AND (p_label_header^.label_type = 'nosve   ');
    UNTIL able_to_locate_vol_label OR (device_address.allocation_unit_mau_address >
          maus_per_label * dmc$max_label_aus);

    IF able_to_locate_vol_label THEN
      RESET p_label_buffer;
      NEXT p_ms_label: [[REP #SIZE (ms_volume_label) OF cell]] IN p_label_buffer;
      RESET p_ms_label;
      p_volume_label^ := p_ms_label^;
      #INLINE ('keypoint', osk$exit, 0, dmk$locate_vol_label);
    ELSE
      #INLINE ('keypoint', osk$exit, osk$m * 1, dmk$locate_vol_label);
    IFEND;

  PROCEND dmp$locate_volume_label;

MODEND dmm$search_for_ms_label;
*DECK DECK=DMM$SEARCH_VOLUME_DIRECTORY EXPAND=TRUE
??RIGHT:= 110??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??
??NEWTITLE := '  Module Header' ??
MODULE dmm$search_volume_directory ALIAS 'DMMSDIR';
{
{
{
{
{
??TITLE := '  Declarations', EJECT??
?? PUSH (LISTEXT := ON) ??
*copyc GFT$SYSTEM_FILE_IDENTIFIER
*copyc DMT$MS_VOLUME_DIRECTORY
*copyc OST$NAME
*copyc OST$STATUS
  ?? POP ??
  ?? TITLE := 'dmp$search_vol_directory_name', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$search_vol_directory_name ALIAS 'dmxsdrn' (search_name:
    ost$name;
        directory_sfid: gft$system_file_identifier;
    VAR directory_index: dmt$directory_index;
    VAR name_found_in_directory: boolean;
    VAR status: ost$status);
*copy dmp$open_directory
*copy dmp$close_file

    VAR
      p_directory: ^dmt$ms_volume_directory,
      index: dmt$directory_index,
      number_directory_entries: dmt$directory_index;

    status.normal := TRUE;
    name_found_in_directory := FALSE;
    directory_index := 0;

    dmp$open_directory (directory_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_read,
       mmc$as_sequential, p_directory, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /directory_open/
    BEGIN
      number_directory_entries := p_directory^.header.number_of_entries;

    /directory_search/
      FOR index := 1 TO number_directory_entries DO
        IF p_directory^.entries [index].entry_available THEN
          IF directory_index = 0 THEN
            directory_index := index;
          IFEND;
          CYCLE /directory_search/;
        IFEND;
        name_found_in_directory := (p_directory^.entries [index].
              user_supplied_name = search_name);
        IF name_found_in_directory THEN
          directory_index := index;
          EXIT /directory_search/;
        IFEND;
      FOREND /directory_search/;

    END /directory_open/;
    dmp$close_file (p_directory, status);

  PROCEND dmp$search_vol_directory_name;

MODEND dmm$search_volume_directory;
*DECK DECK=DMM$SPACE_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
*copy osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??
MODULE dmm$space_manager;
?? NEWTITLE := '  Common Decks' ??
?? PUSH (LISTEXT := ON) ??
*copyc dmp$clear_update_lock
*copyc dmp$close_file
*copyc dmp$get_active_vol_attributes
*copyc dmp$get_mat_pointer
*copyc dmp$get_mfl_pointer
*copyc dmp$get_physical_attributes
*copyc dmp$lock_avt_entry
*copyc dmp$open_dat
*copyc dmp$open_dflt
*copyc dmp$search_active_volume_table
*copyc dmp$set_update_lock
*copyc dmp$unlock_avt_entry
*copyc dmp$verify_access
*copyc dmt$active_volume_table_index
*copyc dmt$allocation_info
*copyc dmt$allocation_size
*copyc dmt$device_allocation_unit
*copyc dmt$device_file_list_index
*copyc dmt$device_log_entries
*copyc dmt$device_position
*copyc dmt$error_condition_codes
*copyc dmt$mainframe_allocation_table
*copyc dmt$mainframe_device_file_list
*copyc dmt$mat_change_request
*copyc dmt$ms_device_allocation_table
*copyc dmv$active_volume_table
*copyc dmv$internal_task_delay_values
*copyc dmv$internal_task_exec_counts
*copyc dpp$put_critical_message
*copyc i#call_monitor
*copyc i#move
*copyc mmp$write_modified_pages
*copyc osp$begin_system_activity
*copyc osp$end_system_activity
*copyc osp$fetch_locked_variable
*copyc osp$file_access_condition
*copyc osp$set_locked_variable
*copyc osp$set_status_abnormal
*copyc osp$fatal_system_error
*copyc osv$mainframe_wired_heap
*copyc pmp$cycle
*copyc pmp$get_legible_date_time
*copyc pmp$zero_out_table
*copyc syp$continue_to_cause
*copyc syp$disestablish_cond_handler
*copyc syp$establish_condition_handler
*copyc syv$job_recovery_option
?? POP ??
?? TITLE := '  Global Variables', EJECT ??

  VAR dmv$space_messages_to_console: [XREF] boolean;

?? TITLE := '  dmp$analyze_dat_position', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$analyze_dat_position (p_dat: ^dmt$ms_device_allocation_table;
        position: dmt$device_position;
    VAR allocation_style: dmt$allocation_styles;
    VAR dau_status_counts: dmt$dau_status_counts);

    VAR
      daus_per_allocation: dmt$daus_per_allocation,
      daus_per_position: dmt$daus_per_position,
      first_dau: dmt$dau_address,
      dau: dmt$dau_address,
      dau_status: dmt$dau_status,
      flawed_daus: dmt$dau_address;

?? SKIP := 1 ??
    PROCEDURE handler (mf: ost$monitor_fault;
                       p_msa: ^ost$minimum_save_area;
                   VAR continue: syt$continue_option);
      VAR
        process_condition: boolean,
        p_scc: ^syt$system_core_condition,
        p_sac: ^mmt$segment_access_condition;

      process_condition := FALSE;
      IF mf.identifier = mmc$segment_fault_processor_id THEN
        p_sac := #LOC(mf.contents);
        process_condition := p_sac^.identifier = mmc$sac_io_read_error

      ELSEIF mf.identifier = syc$system_core_condition THEN
        p_scc := #LOC(mf.system_core_condition);
        process_condition := (p_scc^.condition = syc$user_defined_condition) AND
                             (p_scc^.user_defined_condition = syc$udc_volume_unavailable)
      IFEND;

      IF process_condition THEN
        FOR dau_status := LOWERVALUE (dau_status) TO UPPERVALUE (dau_status) DO
          dau_status_counts [dau_status] := 0;
        FOREND;
        allocation_style := UPPERVALUE (allocation_style);
        EXIT dmp$analyze_dat_position;
      ELSE
        syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);
      IFEND;

    PROCEND handler;
?? SKIP := 1 ??

    syp$establish_condition_handler (^handler);

    daus_per_allocation := 0;
    daus_per_position := p_dat^.header.daus_per_position;
    first_dau := position * daus_per_position;

    FOR dau_status := LOWERVALUE (dau_status) TO UPPERVALUE (dau_status) DO
      dau_status_counts [dau_status] := 0;
    FOREND;

    FOR dau := first_dau TO (first_dau + daus_per_position - 1) DO
      dau_status := p_dat^.body [dau].dau_status;
      IF (dau_status <= UPPERVALUE (dau_status)) THEN
        dau_status_counts [dau_status] := dau_status_counts [dau_status] + 1;
      IFEND;

      IF (dau_status = dmc$dau_assigned_to_file) OR (dau_status = dmc$dau_ass_to_file_swr_flawed) THEN
        IF (p_dat^.body [dau].allocation_chain_position = dmc$part_of_allocation_unit) THEN
          daus_per_allocation := daus_per_allocation + 1;
        ELSE
          daus_per_allocation := 1;
        IFEND;
      IFEND;
    FOREND;

    flawed_daus := dau_status_counts [dmc$dau_hardware_flawed] +
                   dau_status_counts [dmc$dau_software_flawed] +
                   dau_status_counts [dmc$dau_ass_to_mf_swr_flawed] +
                   dau_status_counts [dmc$dau_ass_to_file_swr_flawed];

    IF (daus_per_allocation = 0) OR (flawed_daus <> 0) THEN
      IF (dau_status_counts [dmc$dau_usable] = daus_per_position) THEN
        daus_per_allocation := daus_per_position;
      ELSE
        daus_per_allocation := dmc$default_req_alloc_size DIV p_dat^.header.bytes_per_dau;
      IFEND;
    IFEND;

    allocation_style := UPPERVALUE (allocation_style);
    WHILE (daus_per_allocation <> p_dat^.header.daus_per_allocation_style [allocation_style]) AND
          (allocation_style > LOWERVALUE (allocation_style)) DO
      allocation_style := pred (allocation_style);
    WHILEND;
    syp$disestablish_cond_handler;

  PROCEND dmp$analyze_dat_position;
?? TITLE := '  dmp$calculate_device_capacity', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$calculate_device_capacity (product_id: cmt$product_identification;
                                                     VAR capacity: integer;
                                                     VAR status: ost$status);

  VAR
    p_attributes: ^dmt$physical_device_attributes;

  status.normal := TRUE;
  capacity := 0;

  PUSH p_attributes: [1..3];
  p_attributes^ [1].keyword := dmc$bytes_per_mau;
  p_attributes^ [2].keyword := dmc$cylinders_per_device;
  p_attributes^ [3].keyword := dmc$maus_per_cylinder;

  dmp$get_physical_attributes (product_id, p_attributes, status);
  IF status.normal THEN
    capacity := p_attributes^ [1].bytes_per_mau *
                p_attributes^ [2].cylinders_per_device *
                p_attributes^ [3].maus_per_cylinder;
  IFEND;

PROCEND dmp$calculate_device_capacity;

?? TITLE := '  dmp$calculate_remaining_space', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$calculate_remaining_space (logical_unit_number: iot$logical_unit;
                                                     VAR remaining_bytes: integer;
                                                     VAR status: ost$status);

    VAR
      info: dmt$allocation_info,
      vsn: rmt$recorded_vsn,
      avt_index: dmt$active_volume_table_index,
      search_key: dmt$avt_search_key,
      volume_not_active: boolean;

    status.normal := TRUE;
    remaining_bytes := 0;
    search_key.value := dmc$search_avt_by_lun;
    search_key.logical_unit_number := logical_unit_number;

    dmp$search_active_volume_table (search_key, avt_index, volume_not_active);
    IF volume_not_active THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_not_online,
            'specified logical unit number is not active device - dmp$calculate_remaining_space',status);
      RETURN;
    IFEND;

    vsn := dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn;

    dmp$get_allocation_info (vsn, info, status);
    IF status.normal THEN
      remaining_bytes := (info.available_mat_space + info.available_dat_space) * info.bytes_per_dau;
    IFEND;

  PROCEND dmp$calculate_remaining_space;
?? TITLE := '  decrease_mat_space', EJECT ??

  PROCEDURE decrease_mat_space (p_mat: ^dmt$mainframe_allocation_table;
        p_dat: ^dmt$ms_device_allocation_table);

    VAR
      p_mat_changes: ^dmt$mat_changes,
      mat_change_count: dmt$mat_change_count,
      mat_change_index: dmt$mat_change_count,
      mat_change_request: dmt$mat_change_request,
      daus_per_allocation_unit: dmt$daus_per_position,
      daus_returned: dmt$daus_per_position,
      dau: dmt$dau_address,
      style: dmt$allocation_styles,
      dat_size: 0 .. 07fffffff(16),
      status: ost$status;

    ALLOCATE p_mat_changes: [1 .. 100] IN osv$mainframe_wired_heap^;

    dat_size := #OFFSET (#LOC (p_dat^.body)) + #SIZE (p_dat^.body);
    mat_change_request.request_code := syc$rc_apply_mat_changes;
    mat_change_request.avt_index := p_mat^.avt_index;
    mat_change_request.mat_change_type := dmc$remove_mat_space;
    mat_change_request.p_mat_changes := p_mat_changes;

    REPEAT
      mat_change_request.available_dat_space := p_dat^.header.available;
      i#call_monitor (^mat_change_request, #SIZE (mat_change_request));

      mat_change_count := mat_change_request.mat_change_count;
      FOR mat_change_index := 1 TO mat_change_count DO
        style := p_mat_changes^ [mat_change_index].style;
        dau := p_mat_changes^ [mat_change_index].dau_address;
        daus_per_allocation_unit := p_mat^.daus_per_allocation_unit [style];
        daus_returned := daus_per_allocation_unit;

        FOR dau := dau TO (dau + daus_per_allocation_unit - 1) DO
          IF (p_dat^.body [dau].dau_status = dmc$dau_ass_to_mf_swr_flawed) THEN
            p_dat^.body [dau].dau_status := dmc$dau_software_flawed;
            daus_returned := daus_returned - 1;
          ELSE
            p_dat^.body [dau].dau_status := dmc$dau_usable;
          IFEND;
        FOREND;

        p_dat^.header.available := p_dat^.header.available + daus_returned;
      FOREND;

      IF (mat_change_count <> 0) THEN
        mmp$write_modified_pages (p_dat, dat_size, osc$wait, status);
        IF NOT status.normal THEN
          IF osp$file_access_condition (status) THEN
            status.normal := TRUE;
          ELSE
            osp$fatal_system_error ('Unable to flush DAT.', ^status);
          IFEND;
        IFEND;
      IFEND;
    UNTIL (mat_change_count = 0);

    FREE p_mat_changes IN osv$mainframe_wired_heap^;
  PROCEND decrease_mat_space;
?? TITLE := '  determine_mat_changes', EJECT ??

  PROCEDURE determine_mat_changes (p_mat: ^dmt$mainframe_allocation_table;
    VAR additional_space: dmt$dau_address);

    VAR
      usable_space: dmt$dau_address,
      target_space: dmt$dau_address,
      usable_dat_space: integer,
      daus_per_position: dmt$daus_per_position,
      no_free_cylinders: boolean,
      allocation_allowed: boolean;

    usable_space := p_mat^.available_space;

    IF (usable_space < p_mat^.minimum_space) THEN
      target_space := (p_mat^.maximum_space + p_mat^.minimum_space) DIV 2;
      additional_space := target_space - usable_space;
    ELSE
      additional_space := 0;
    IFEND;

    { Get at least a cylinder of space if there are no free cylinders currently
    { in the MAT.

    no_free_cylinders := p_mat^.available_allocation_units [dmc$acyl] = 0;

    IF no_free_cylinders THEN
      daus_per_position := p_mat^.daus_per_position;
      IF (additional_space < daus_per_position) THEN
        additional_space := daus_per_position;
      IFEND;
    IFEND;

    { Fill MAT only until the DAT reaches the DAT threshold.

    usable_dat_space := p_mat^.available_dat_space - p_mat^.dat_threshold;
    IF (additional_space > usable_dat_space) THEN
      IF (usable_dat_space > 0) THEN
        additional_space := usable_dat_space;
      ELSE
        additional_space := 0;
      IFEND;
    IFEND;

    { Get no space if allocation is inhibited.

    allocation_allowed := dmv$p_active_volume_table^ [p_mat^.avt_index].mass_storage.allocation_allowed;
    IF NOT allocation_allowed THEN
      additional_space := 0;
    IFEND;

  PROCEND determine_mat_changes;
?? TITLE := '  display_informative_message', EJECT ??

  PROCEDURE display_informative_message (volume_out_count: integer;
        volume_low_count: integer);

    VAR
        date: ost$date,
        integer_length: integer,
        integer_string: string (6),
        message_length: integer,
        message: string (80),
        status: ost$status,
        time: ost$time;

    IF NOT dmv$space_messages_to_console THEN
      RETURN;
    IFEND;

    IF (volume_out_count = 0) AND (volume_low_count = 0) THEN
        message := ' 0 VOLUMES LOW, 0 VOLUMES OUT'
    ELSE
      message (1, * ) := ' ';
      message_length := 1;
      IF (volume_low_count <> 0) THEN
        STRINGREP (integer_string, integer_length, volume_low_count);
        message (message_length,integer_length) := integer_string;
        message_length := message_length + integer_length;
        message (message_length,12) := ' VOLUMES LOW';
        message_length := message_length + 12;
      IFEND;

      IF (volume_out_count <> 0) THEN
        IF (volume_low_count <> 0) THEN
          message (message_length,1) := ',';
          message_length := message_length + 1;
        IFEND;
        STRINGREP (integer_string, integer_length, volume_out_count);
        message (message_length,integer_length) := integer_string;
        message_length := message_length + integer_length;
        message (message_length,12) := ' VOLUMES OUT';
      IFEND;
    IFEND;

    { add date to end of message.

    pmp$get_legible_date_time  (osc$mdy_date, date, osc$hms_time, time,
         {ignore} status);
    message(40, 8) := date.mdy;
    dpp$put_critical_message(message, status);

  PROCEND display_informative_message;
?? TITLE := '  increase_mat_space', EJECT ??

  PROCEDURE increase_mat_space (p_mat: ^dmt$mainframe_allocation_table;
        p_dat: ^dmt$ms_device_allocation_table;
        space_required: dmt$dau_address;
        skip_cylinders: boolean);

    VAR
      p_mat_changes: ^dmt$mat_changes,
      mat_change_count: dmt$mat_change_count,
      mat_change: dmt$mat_change,
      mainframe_assigned: dmt$mainframe_assigned,
      space_obtained: dmt$dau_address,
      cylinder_end_space: dmt$dau_address,
      dau_status_counts: dmt$dau_status_counts,
      avt_index: dmt$active_volume_table_index,
      allocation_unit_found: boolean,
      all_positions_searched: boolean,
      p_daus: ^array [ * ] of dmt$ms_device_allocation_unit,
      position: dmt$device_position,
      daus_per_position: dmt$daus_per_position,
      dau: dmt$dau_address,
      first_dau: dmt$dau_address,
      next_dau: dmt$dau_address,
      dau_limit: dmt$dau_address,
      allocation_style: dmt$allocation_styles,
      maximum_position: dmt$device_position,
      starting_position_number: dmt$device_position,
      starting_search_position: dmt$device_position,
      size: 0 .. 7fffffff(16),
      daus_per_allocation_unit: dmt$daus_per_position,
      status: ost$status;

    p_daus := ^p_dat^.body;
    size := #OFFSET (#LOC (p_daus^)) + #SIZE (p_daus^);

    ALLOCATE p_mat_changes: [1 .. 100] IN osv$mainframe_wired_heap^;

    mat_change_count := 0;
    avt_index := p_mat^.avt_index;
    mainframe_assigned := dmv$p_active_volume_table^ [avt_index].mass_storage.mainframe_assigned;

    maximum_position := p_mat^.positions_per_device - 1;
    starting_position_number := p_mat^.starting_position_number;
    starting_search_position := p_mat^.starting_search_position;
    position := starting_search_position;
    daus_per_position := p_mat^.daus_per_position;

    space_obtained := 0;
    all_positions_searched := FALSE;

  /search_all_positions/
    WHILE (space_obtained < space_required) AND NOT all_positions_searched DO
      dmp$analyze_dat_position (p_dat, position, allocation_style, dau_status_counts);
      IF (allocation_style = dmc$acyl) AND skip_cylinders THEN
        cylinder_end_space := space_obtained;
      ELSE
        cylinder_end_space := space_obtained + dau_status_counts [dmc$dau_usable];
      IFEND;

      { The "search_position" loop takes all the space from a cylinder.  This
      { may result in overfilling the MAT by up to one cylinder minus one dau.
      { The overfilling is allowed to avoid fragmentation that would result
      { from moving partial cylinders to the MAT.

    /search_position/
      WHILE (space_obtained < cylinder_end_space) DO
        mat_change.style := allocation_style;
        daus_per_allocation_unit := p_mat^.daus_per_allocation_unit [allocation_style];
        dau := position * daus_per_position;
        dau_limit := dau + daus_per_position DIV daus_per_allocation_unit * daus_per_allocation_unit;

      /find_allocation_unit/
        WHILE (dau < dau_limit) DO
          first_dau := dau;
          next_dau := first_dau + daus_per_allocation_unit;

          REPEAT
            allocation_unit_found := (p_daus^ [dau].dau_status = dmc$dau_usable);
            dau := dau + 1;
          UNTIL NOT allocation_unit_found OR (dau = next_dau);

          IF allocation_unit_found THEN
            FOR dau := first_dau TO (next_dau - 1) DO
              p_daus^ [dau].dau_status := dmc$dau_assigned_to_mainframe;
              p_daus^ [dau].mainframe_id := mainframe_assigned;
            FOREND;

            mat_change.dau_address := first_dau;
            IF (mat_change_count = UPPERBOUND (p_mat_changes^)) THEN
              mmp$write_modified_pages (p_dat, size, osc$wait, status);
              IF NOT status.normal THEN
                IF osp$file_access_condition (status) THEN
                  status.normal := TRUE;
                ELSE
                  osp$fatal_system_error ('Unable to flush DAT', ^status);
                IFEND;
              IFEND;
              process_mat_changes (p_mat, mat_change_count, p_mat_changes, p_dat^.header.available);
              mat_change_count := 0;
            IFEND;
            accumulate_mat_change (mat_change, p_mat_changes, mat_change_count);

            space_obtained := space_obtained + daus_per_allocation_unit;
            p_dat^.header.available := p_dat^.header.available - daus_per_allocation_unit;
          IFEND;

          dau := next_dau;
        WHILEND /find_allocation_unit/;

        allocation_style := LOWERVALUE (allocation_style);

      WHILEND /search_position/;

      IF (position < maximum_position) THEN
        position := position + 1;
      ELSE
        position := starting_position_number;
      IFEND;

      all_positions_searched := (position = starting_search_position);
    WHILEND /search_all_positions/;

    mmp$write_modified_pages (p_dat, size, osc$wait, status);
    IF NOT status.normal THEN
      IF osp$file_access_condition (status) THEN
        status.normal := TRUE;
      ELSE
        osp$fatal_system_error ('Unable to flush DAT', ^status);
      IFEND;
    IFEND;

    process_mat_changes (p_mat, mat_change_count, p_mat_changes, p_dat^.header.available);

    FREE p_mat_changes IN osv$mainframe_wired_heap^;

    p_mat^.starting_search_position := position;

  PROCEND increase_mat_space;
?? TITLE := '  get_dflt_space', EJECT ??

  PROCEDURE get_dflt_space (p_dflt: ^dmt$ms_device_file_list_table;
        avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      current_value: integer,
      mainframe_assigned: dmt$mainframe_assigned,
      mflt_changes: ^array [1 .. * ] of dmt$ms_mf_file_list_entry,
      number_mflt_changes: integer,
      mflt_change: dmt$device_file_list_index,
      volume_dfl_index: dmt$device_file_list_index,
      mfl_index: dmt$ms_mf_device_file_list_ord,
      size: 0 .. 7fffffff(16),
      p_mfl: ^dmt$ms_mf_device_file_list;

    status.normal := TRUE;

    PUSH mflt_changes: [1 .. 100];

    number_mflt_changes := 0;
    mainframe_assigned := dmv$p_active_volume_table^ [avt_index].mass_storage.mainframe_assigned;

    dmp$get_mfl_pointer (avt_index, p_mfl);
    IF p_mfl = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$nil_mflt_pointer, 'p_mfl = NIL.', status);
      RETURN;
    IFEND;

    size := #SIZE (dmt$ms_device_file_list_header) + (UPPERBOUND (p_dflt^.entries) - LOWERBOUND (p_dflt^.
          entries) + 1) * #SIZE (dmt$ms_device_file_list_entry);

    volume_dfl_index := 1;

  /fill_mf_file_list/
    FOR mfl_index := 1 TO UPPERBOUND (p_mfl^) DO

      osp$fetch_locked_variable (p_mfl^ [mfl_index].ordinal, current_value);

      IF current_value = 0 THEN

        WHILE p_dflt^.entries [volume_dfl_index].flags <> dmc$dfle_available DO
          IF volume_dfl_index + 1 > UPPERBOUND (p_dflt^.entries) THEN
            EXIT /fill_mf_file_list/;
          IFEND;
          volume_dfl_index := volume_dfl_index + 1;
        WHILEND;

        p_dflt^.entries [volume_dfl_index].flags := dmc$dfle_assigned_to_mainframe;
        p_dflt^.entries [volume_dfl_index].mainframe_assigned := mainframe_assigned;
        mflt_change := volume_dfl_index;

        IF (number_mflt_changes = UPPERBOUND (mflt_changes^)) THEN

          mmp$write_modified_pages (p_dflt, size, osc$wait, status);
          IF NOT status.normal THEN
            IF osp$file_access_condition (status) THEN
              status.normal := TRUE;
            ELSE
              RETURN;
            IFEND;
          IFEND;

          apply_changes_to_mfl (mflt_changes, number_mflt_changes, avt_index, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          number_mflt_changes := 0;
        IFEND;

        accumulate_mflt_change (mflt_change, mflt_changes, number_mflt_changes);

        volume_dfl_index := volume_dfl_index + 1;
        IF volume_dfl_index > UPPERBOUND (p_dflt^.entries) THEN
          EXIT /fill_mf_file_list/;
        IFEND;

      IFEND;
    FOREND /fill_mf_file_list/;

    IF number_mflt_changes > 0 THEN

      mmp$write_modified_pages (p_dflt, size, osc$wait, status);
      IF NOT status.normal THEN
        IF osp$file_access_condition (status) THEN
          status.normal := TRUE;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      apply_changes_to_mfl (mflt_changes, number_mflt_changes, avt_index, status);
    IFEND;

  PROCEND get_dflt_space;
?? TITLE := '  accumulate_mat_change', EJECT ??

  PROCEDURE accumulate_mat_change (mat_change: dmt$mat_change;
        p_mat_changes: ^dmt$mat_changes;
    VAR mat_change_count: dmt$mat_change_count);

    VAR
      lower,
      upper,
      mid: dmt$mat_change_count,
      insertion_index,
      replacement_index: dmt$mat_change_count,
      number_to_move: dmt$mat_change_count,
      size: 0 .. 7fffffff(16),
      insertion_address,
      replacement_address: ^cell,
      temp: integer,
      temp_buffer: ^dmt$mat_changes;



    lower := 0;
    upper := mat_change_count + 1;
    temp := lower + upper;
    mid := temp DIV 2;

    WHILE mid <> lower DO
      IF (p_mat_changes^ [mid].dau_address <= mat_change.dau_address) THEN
        lower := mid;
      ELSE
        upper := mid;
      IFEND;
      temp := lower + upper;
      mid := temp DIV 2;
    WHILEND;

    insertion_index := mid + 1;
    replacement_index := mid + 2;
    number_to_move := mat_change_count - insertion_index + 1;
    size := #SIZE (dmt$mat_change) * number_to_move;

    IF size <> 0 THEN
      insertion_address := ^p_mat_changes^ [insertion_index];
      replacement_address := ^p_mat_changes^ [replacement_index];
      PUSH temp_buffer: [1 .. number_to_move];
      i#move (insertion_address, temp_buffer, size);
      i#move (temp_buffer, replacement_address, size);
    IFEND;

    p_mat_changes^ [insertion_index] := mat_change;
    mat_change_count := mat_change_count + 1;

  PROCEND accumulate_mat_change;

?? TITLE := '  process_mat_changes', EJECT ??

  PROCEDURE process_mat_changes (p_mat: ^dmt$mainframe_allocation_table;
        mat_change_count: dmt$mat_change_count;
        p_mat_changes: ^dmt$mat_changes;
        available_dat_space: dmt$dau_address);

    VAR
      mat_change_request: dmt$mat_change_request,
      current_position: dmt$device_position,
      next_position: dmt$device_position,
      i: dmt$mat_change_count,
      this_position_checked: boolean,
      status: ost$status;

    IF mat_change_count = 0 THEN
      RETURN;
    IFEND;


    this_position_checked := FALSE;
    current_position := p_mat_changes^ [1].dau_address DIV p_mat^.daus_per_position;

    FOR i := 1 TO mat_change_count DO
      next_position := p_mat_changes^ [i].dau_address DIV p_mat^.daus_per_position;
      IF next_position <> current_position THEN
        current_position := next_position;
        this_position_checked := FALSE;
      IFEND;
      IF NOT this_position_checked THEN
        IF (current_position > p_mat^.positions_per_device) OR (current_position < 0) THEN
          osp$fatal_system_error ('unable to locate position in mat - DMMSMAN', ^status);
        IFEND;
        this_position_checked := TRUE;
      IFEND;
    FOREND;

    mat_change_request.request_code := syc$rc_apply_mat_changes;
    mat_change_request.avt_index := p_mat^.avt_index;
    mat_change_request.mat_change_type := dmc$add_mat_space;
    mat_change_request.mat_change_count := mat_change_count;
    mat_change_request.p_mat_changes := p_mat_changes;
    mat_change_request.available_dat_space := available_dat_space;

    i#call_monitor (^mat_change_request, #SIZE (mat_change_request));

  PROCEND process_mat_changes;
?? TITLE := '  apply_changes_to_mfl', EJECT ??

  PROCEDURE apply_changes_to_mfl (p_new_mfl_entries: ^array [1 .. * ] OF dmt$ms_mf_file_list_entry;
        number_mfl_changes: integer;
        avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      mfl_change_index: dmt$ms_mf_device_file_list_ord,
      mf_file_list_index: dmt$ms_mf_device_file_list_ord,
      actual: integer,
      successful: boolean,
      p_mfl: ^dmt$ms_mf_device_file_list;

    status.normal := TRUE;

    dmp$get_mfl_pointer (avt_index, p_mfl);
    IF p_mfl = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$nil_mflt_pointer, 'p_mfl = NIL.', status);
      RETURN;
    IFEND;

    mf_file_list_index := 0;

    FOR mfl_change_index := 1 TO number_mfl_changes DO

    /insert_entry/
      WHILE TRUE DO
        mf_file_list_index := mf_file_list_index + 1;
        IF mf_file_list_index > UPPERBOUND (p_mfl^) THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$overflow_of_mflt,
                'MFL is full - apply_changes_to_mfl.', status);
          RETURN;
        IFEND;
        osp$set_locked_variable (p_mfl^ [mf_file_list_index].ordinal, 0,
            p_new_mfl_entries^ [mfl_change_index].ordinal, actual, successful);
        IF successful THEN
          EXIT /insert_entry/;
        IFEND;
      WHILEND /insert_entry/;

    FOREND;

  PROCEND apply_changes_to_mfl;
?? TITLE := '  accumulate_mflt_change', EJECT ??

  PROCEDURE accumulate_mflt_change (mflt_change: dmt$device_file_list_index;
    VAR mflt_changes: ^array [1 .. * ] OF dmt$ms_mf_file_list_entry;
    VAR number_mflt_changes: integer);

    VAR
      lower,
      upper,
      mid: integer,
      insertion_index,
      replacement_index: integer,
      number_to_move: integer,
      size: 0 .. 7fffffff(16),
      insertion_address,
      replacement_address: ^cell,
      temp: integer,
      temp_buffer: ^array [1 .. * ] of dmt$ms_mf_file_list_entry;



    lower := 0;
    upper := number_mflt_changes + 1;
    temp := lower + upper;
    mid := temp DIV 2;

    WHILE mid <> lower DO
      IF mflt_changes^ [mid].ordinal <= mflt_change THEN
        lower := mid;
      ELSE
        upper := mid;
      IFEND;
      temp := lower + upper;
      mid := temp DIV 2;
    WHILEND;

    insertion_index := mid + 1;
    replacement_index := mid + 2;
    number_to_move := number_mflt_changes - insertion_index + 1;
    size := #SIZE (dmt$ms_mf_file_list_entry) * number_to_move;

    IF size <> 0 THEN
      insertion_address := ^mflt_changes^ [insertion_index];
      replacement_address := ^mflt_changes^ [replacement_index];
      PUSH temp_buffer: [1 .. number_to_move];
      i#move (insertion_address, temp_buffer, size);
      i#move (temp_buffer, replacement_address, size);
    IFEND;

    mflt_changes^ [insertion_index].ordinal := mflt_change;
    number_mflt_changes := number_mflt_changes + 1;

  PROCEND accumulate_mflt_change;
?? TITLE := '  dmp$get_allocation_info', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$get_allocation_info (vsn: rmt$recorded_vsn;
    VAR allocation_info: dmt$allocation_info;
    VAR status: ost$status);

    VAR
      avt_index: dmt$active_volume_table_index,
      p_attributes: ^array [ * ] of dmt$assigned_ms_vol_attribute,
      volume_found: boolean,
      disk_table_status: dmt$ms_volume_table_status,
      p_mat: ^dmt$mainframe_allocation_table;

    status.normal := TRUE;

    PUSH p_attributes: [1 .. 3];
    p_attributes^ [1].keyword := dmc$avt_index;
    p_attributes^ [2].keyword := dmc$ms_allocation_allowed;
    p_attributes^ [3].keyword := dmc$ms_device_log_entry_count;
    avt_index := 0;
    dmp$get_active_vol_attributes (vsn, avt_index, p_attributes, volume_found);

    IF NOT volume_found THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_not_online, vsn, status);
    ELSE
      avt_index := p_attributes^ [1].index;
      allocation_info.allocation_allowed := p_attributes^ [2].allocation_allowed;
      allocation_info.device_log_count := p_attributes^ [3].device_log_entry_count;
      allocation_info.no_space := dmv$p_active_volume_table^ [avt_index].mass_storage.space_gone;
      allocation_info.space_low := dmv$p_active_volume_table^ [avt_index].mass_storage.space_low;
      disk_table_status := dmv$p_active_volume_table^ [avt_index].mass_storage.disk_table_status;
      allocation_info.no_file_entries := dmc$no_available_dflt_entries IN disk_table_status;
      allocation_info.file_entries_low := dmc$volume_low_on_dfl_entries IN disk_table_status;
      dmp$get_mat_pointer (avt_index, p_mat);
      IF p_mat <> NIL THEN
        allocation_info.available_mat_space := p_mat^.available_space;
        allocation_info.available_dat_space := p_mat^.available_dat_space;
        allocation_info.bytes_per_dau := p_mat^.bytes_per_dau;
      ELSE
        allocation_info.available_mat_space := 0;
        allocation_info.available_dat_space := 0;
        allocation_info.bytes_per_dau := 0;
      IFEND;
    IFEND;
  PROCEND dmp$get_allocation_info;
?? TITLE := '  dmp$volume_space_manager', EJECT ??

  PROCEDURE [XDCL] dmp$volume_space_manager (avt_index: dmt$active_volume_table_index;
        full_update: boolean;
    VAR status: ost$status);

    VAR
      disk_table_status: dmt$ms_volume_table_status,
      space_required: dmt$dau_address,
      skip_cylinders: boolean,
      process_cylinders: boolean,
      no_available_dflt_space: boolean,
      able_to_lock_avt_entry: boolean,
      able_to_unlock_avt_entry: boolean,
      p_mat: ^dmt$mainframe_allocation_table,
      p_dat: ^dmt$ms_device_allocation_table,
      able_to_set_lock: boolean,
      dflt_update_required: boolean,
      dflt_space_low: boolean,
      cycle_status: ost$status,
      dflt: ^dmt$ms_device_file_list_table,
      ok: boolean,
      another_dflt_update_required: boolean;

    status.normal := TRUE;
    dflt_space_low := FALSE;

    dmp$verify_access (avt_index, ok);
    IF NOT ok THEN
      RETURN;
    IFEND;

    dmp$lock_avt_entry (avt_index, able_to_lock_avt_entry);
    IF NOT able_to_lock_avt_entry THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_lock_avt_entry,
        'unable to lock avt entry - DMMSMAN', status);
      RETURN;
    IFEND;

    disk_table_status := dmv$p_active_volume_table^ [avt_index].mass_storage.disk_table_status;

    dmv$p_active_volume_table^ [avt_index].mass_storage.disk_table_status := disk_table_status +
          $dmt$ms_volume_table_status [dmc$table_update_in_progress];

    dmp$unlock_avt_entry (avt_index, able_to_unlock_avt_entry);
    IF NOT able_to_unlock_avt_entry THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_clear_avt_lock,
        'unable to unlock avt entry - DMMSMAN', status);
      RETURN;
    IFEND;

    IF (dmc$table_update_in_progress IN disk_table_status) THEN
      RETURN;
    IFEND;

    dflt_update_required := (dmc$dflt_update_required IN disk_table_status);
    no_available_dflt_space := (dmc$no_available_dflt_entries IN disk_table_status);
    another_dflt_update_required := dflt_update_required;

    dmp$get_mat_pointer (avt_index, p_mat);
    determine_mat_changes (p_mat, space_required);

    IF (space_required > 0) OR p_mat^.mat_too_full OR full_update THEN

      dmp$open_dat (dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_allocation_table,
            osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential, p_dat, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$open_dat_failure,
          'unable to open dat - DMMSMAN', status);
        RETURN;
      IFEND;

    /dat_open/
      BEGIN

        dmp$set_update_lock (avt_index, FALSE, able_to_set_lock);
        IF NOT able_to_set_lock THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_lock_dat,
            'unable to lock dat - DMMSMAN', status);
          EXIT /dat_open/;
        IFEND;

        skip_cylinders := TRUE;
        process_cylinders := NOT skip_cylinders;

        IF full_update THEN
          space_required := UPPERVALUE (space_required);
          increase_mat_space (p_mat, p_dat, space_required, skip_cylinders);
          determine_mat_changes (p_mat, space_required);
        IFEND;

        IF (space_required > 0) THEN
         increase_mat_space (p_mat, p_dat, space_required, process_cylinders);
        IFEND;

        IF p_mat^.mat_too_full THEN
          decrease_mat_space (p_mat, p_dat);
        IFEND;

        dmp$clear_update_lock (avt_index);
      END /dat_open/;

      dmp$close_file (p_dat, status);
      IF NOT status.normal THEN
        osp$fatal_system_error ('unable to close dat - DMMSMAN', ^status);
      IFEND;
    IFEND;


    IF dflt_update_required THEN

      dmp$open_dflt (dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_file_list_table,
            osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential, dflt, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$open_dflt_failure,
          'unable to open dflt - DMMSMAN', status);
        RETURN;
      IFEND;

    /dflt_open/
      BEGIN

        dmp$set_update_lock (avt_index, FALSE, able_to_set_lock);
        IF NOT able_to_set_lock THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_lock_dflt,
            'unable to lock dflt - DMMSMAN', status);
          EXIT /dflt_open/;
        IFEND;

        get_dflt_space (dflt, avt_index, status);
        IF NOT status.normal THEN
          osp$fatal_system_error ('bad status updating dflt - DMMSMAN', ^status);
        IFEND;

        another_dflt_update_required := FALSE;
        dflt_space_low := FALSE;

        dmp$clear_update_lock (avt_index);
      END /dflt_open/;

      dmp$close_file (dflt, status);
      IF NOT status.normal THEN
        osp$fatal_system_error ('unable to close dflt', ^status);
      IFEND;
    IFEND;

{
{     At this point, we MUST get the avt lock in order to clear the 'update_in_progress' bit in the disk
{     table status.  If we do not clear this bit space manager will never run on this volume again.
{     This is possible if monitor in the other CPU has locked the avt in order to set the
{     update_required bits.
{
    REPEAT
      dmp$lock_avt_entry (avt_index, able_to_lock_avt_entry);
      IF NOT able_to_lock_avt_entry THEN
        pmp$cycle (cycle_status);
      IFEND;
    UNTIL able_to_lock_avt_entry;

    dmv$p_active_volume_table^ [avt_index].mass_storage.disk_table_status := dmv$p_active_volume_table^
          [avt_index].mass_storage.disk_table_status - $dmt$ms_volume_table_status
          [dmc$table_update_in_progress];

    IF another_dflt_update_required THEN
      dmv$p_active_volume_table^ [avt_index].mass_storage.disk_table_status := dmv$p_active_volume_table^
            [avt_index].mass_storage.disk_table_status + $dmt$ms_volume_table_status
            [dmc$dflt_update_required];
    ELSE
      dmv$p_active_volume_table^ [avt_index].mass_storage.disk_table_status := dmv$p_active_volume_table^
            [avt_index].mass_storage.disk_table_status - $dmt$ms_volume_table_status
            [dmc$dflt_update_required];
    IFEND;


    IF no_available_dflt_space THEN
      dmv$p_active_volume_table^ [avt_index].mass_storage.disk_table_status := dmv$p_active_volume_table^
            [avt_index].mass_storage.disk_table_status + $dmt$ms_volume_table_status
            [dmc$no_available_dflt_entries];
    ELSE
      dmv$p_active_volume_table^ [avt_index].mass_storage.disk_table_status := dmv$p_active_volume_table^
            [avt_index].mass_storage.disk_table_status - $dmt$ms_volume_table_status
            [dmc$no_available_dflt_entries];
    IFEND;


    IF dflt_space_low THEN
      dmv$p_active_volume_table^ [avt_index].mass_storage.disk_table_status := dmv$p_active_volume_table^
            [avt_index].mass_storage.disk_table_status + $dmt$ms_volume_table_status
            [dmc$volume_low_on_dfl_entries];
    ELSE
      dmv$p_active_volume_table^ [avt_index].mass_storage.disk_table_status := dmv$p_active_volume_table^
            [avt_index].mass_storage.disk_table_status - $dmt$ms_volume_table_status
            [dmc$volume_low_on_dfl_entries];
    IFEND;

    dmp$unlock_avt_entry (avt_index, able_to_unlock_avt_entry);
    IF NOT able_to_unlock_avt_entry THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_clear_avt_lock,
        'unable to unlock avt entry - DMMSMAN', status);
    IFEND;

  PROCEND dmp$volume_space_manager;
?? TITLE := '  dmp$management_of_volume_space', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$management_of_volume_space;

    VAR
      avt_index: dmt$active_volume_table_index,
      status: ost$status,
      previous_volumes_low: [STATIC] integer := 0,
      previous_volumes_out: [STATIC] integer := 0,
      volumes_low: integer,
      volumes_out: integer,
      full_update: boolean,
      partial_update: boolean,
      space_low: boolean,
      space_gone: boolean;

    osp$begin_system_activity;

    dmv$manage_volume_space_count := (dmv$manage_volume_space_count + 1) MOD UPPERVALUE
          (dmv$manage_volume_space_count);

    volumes_low := 0;
    volumes_out := 0;

    full_update := TRUE;
    partial_update := NOT full_update;

    FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND (dmv$p_active_volume_table^) DO

      IF NOT dmv$p_active_volume_table^ [avt_index].entry_available AND (dmc$mainframe_mounted IN
            dmv$p_active_volume_table^ [avt_index].mass_storage.status) THEN

        dmp$volume_space_manager (avt_index, partial_update, status);

        IF NOT status.normal THEN
          CASE status.condition OF
          = dme$unable_to_lock_dat, dme$unable_to_lock_dflt, dme$unable_to_lock_avt_entry =
            status.normal := TRUE;
          ELSE
            osp$fatal_system_error ('Bad status from dmp$volume_space_manager.', ^status);
          CASEND;
        IFEND;

        space_low :=  dmv$p_active_volume_table^ [avt_index].mass_storage.space_low;
        space_gone :=  dmv$p_active_volume_table^ [avt_index].mass_storage.space_gone;

        IF space_gone THEN
          volumes_out := volumes_out + 1;
        ELSEIF space_low THEN
          volumes_low := volumes_low + 1;
        IFEND;
      IFEND;
    FOREND;

    IF (volumes_low <> previous_volumes_low) OR (volumes_out <> previous_volumes_out) THEN
      previous_volumes_low := volumes_low;
      previous_volumes_out := volumes_out;
      display_informative_message (volumes_out, volumes_low);
    IFEND;

    dmv$volume_table_space_delay := dmv$manage_volume_space_delay;

    osp$end_system_activity;

  PROCEND dmp$management_of_volume_space;

MODEND dmm$space_manager;
*DECK DECK=DMM$TAPE_DISPLAYS_23D EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Device Management : VED TR and TS Displays' ??
MODULE dmm$tape_displays_23d;

{   PURPOSE:
{     This module contains procedures that drive the tape displays.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc clt$display_control
*copyc dme$tape_errors
*copyc dmt$tape_unit_status_info
*copyc ioe$tape_io_conditions
*copyc iot$rvl_entry_information
*copyc iot$tape_unit_status_entry
*copyc iot$tape_characteristics
*copyc iot$tape_unit_status_list
*copyc jmt$system_supplied_name
*copyc ofd$type_definition
*copyc ofe$error_codes
*copyc oft$display_procedure
*copyc oft$refreshing_displays
*copyc osd$integer_limits
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc ost$status
*copyc ost$string
*copyc rmd$volume_declarations
*copyc tmt$system_task_id
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copy  clp$new_display_line
*copy  clp$put_display
*copyc cmp$get_element_name_via_lun
*copyc dpp$clear_window
*copyc dpp$put_next_line
*copyc iop$get_tape_mount_information
*copyc iop$tape_scanner
*copyc iov$tape_scan_frequency
*copyc ofp$build_system_line
*copyc ofp$open_display
*copyc osp$append_status_integer
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc tmp$ready_system_task1
*copyc cmv$logical_unit_table
*copyc dmv$p_tape_reservations
*copyc dpv$display_delay
*copyc iov$tusl_p
*copyc oss$task_shared
*copyc osv$mainframe_pageable_heap
*copyc osv$task_shared_heap

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    dmv$time_of_last_tape_scan_call: integer := 0;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] dmp$tape_status_display', EJECT ??
  PROCEDURE [XDCL] dmp$tape_status_display
    (    wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);
?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure provides clean-up processing when a task abort occurs.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF wid = 0 THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      current_time: integer,
      display_control: clt$display_control,
      job_name: jmt$system_supplied_name,
      i: integer,
      ignore_status: ost$status,
      s: string (80),
      tape_available: boolean,
      no_tapes_available_line: [READ, oss$job_paged_literal] string (57) :=
            '                        *** No tapes units available. ***',
      title: [READ, oss$job_paged_literal] string (80) :=
{                     1         2         3         4         5         6         7         8
{            12345678901234567890123456789012345678901234567890123456789012345678901234567890
            ' Element  RVSN   EVSN  Ring Dens Lab C System_Job_name      Unit_Status         ';

    status.normal := TRUE;

    IF wid = 0 THEN
      osp$establish_block_exit_hndlr (^abort_handler);
    IFEND;
    IF initial_call THEN
      ofp$open_display (file_name, wid, dpc$wc_sharing, dpc$wk_table, title, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      tmp$ready_system_task (tmc$stid_tape_scanner, status);
      dmv$time_of_last_tape_scan_call := #FREE_RUNNING_CLOCK (0);
    ELSE
      current_time := #FREE_RUNNING_CLOCK (0);
      IF current_time > (dmv$time_of_last_tape_scan_call + (iov$tape_scan_frequency * 1000000)) THEN
        tmp$ready_system_task (tmc$stid_tape_scanner, status);
        dmv$time_of_last_tape_scan_call := current_time;
      IFEND;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF wid <> 0 THEN
      dpp$clear_window (wid, status);
    ELSE
      s := '  ';
      clp$put_display (display_control, s, clc$trim, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    tape_available := FALSE;

  /scan_tusl/
    FOR i := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
      IF iov$tusl_p^ [i].tape_unit_state <> cmc$on THEN
        CYCLE /scan_tusl/;
      IFEND;
      tape_available := TRUE;
      s := '  ';
      s (2, 7) := iov$tusl_p^ [i].element_name;

      s (40, jmc$system_supplied_name_size) := iov$tusl_p^ [i].ssn;
      s (17, rmc$external_vsn_size) := iov$tusl_p^ [i].evsn;
      s (10, rmc$external_vsn_size) := iov$tusl_p^ [i].rvsn;
      IF iov$tusl_p^ [i].unit_ready THEN
        IF NOT iov$tusl_p^ [i].read_error THEN
          s (61, 5) := 'Ready';
        ELSE
          s (61, 16) := 'Ready/Read Error';
        IFEND;
        IF iov$tusl_p^ [i].detected_tape_characteristics.write_ring THEN
          s (24, 2) := 'In';
        ELSE
          s (24, 3) := 'Out';
        IFEND;
        CASE iov$tusl_p^ [i].detected_tape_characteristics.density OF
        = rmc$800 =
          s (29, 3) := '800';
        = rmc$1600 =
          s (29, 4) := '1600';
        = rmc$6250 =
          s (29, 4) := '6250';
        = rmc$38000 =
          s (28, 5) := '38000';
        ELSE
        CASEND;
        IF (iov$tusl_p^ [i].detected_tape_characteristics.label_type = amc$unlabelled) THEN
          s (34, 2) := 'No';
          s (38, 1) := ' ';
        ELSE
          s (34, 3) := 'Yes';
          IF (iov$tusl_p^ [i].detected_tape_characteristics.character_set = amc$ebcdic) THEN
            s (38, 1) := 'E';
          ELSE
            s (38, 1) := 'A';
          IFEND;
        IFEND;
      ELSE
        s (61, 9) := 'Not ready';
      IFEND;

      IF wid <> 0 THEN
        dpp$put_next_line (wid, s, status);
      ELSE
        clp$put_display (display_control, s, clc$trim, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    FOREND /scan_tusl/;

    IF NOT tape_available THEN
      s := ' ';
      IF wid <> 0 THEN
        dpp$put_next_line (wid, s, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        dpp$put_next_line (wid, no_tapes_available_line, status);
      ELSE
        clp$put_display (display_control, s, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_display (display_control, no_tapes_available_line, clc$trim, status);
      IFEND;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF wid <> 0 THEN
      IF dpv$display_delay <= 10000 THEN
        current_time := #FREE_RUNNING_CLOCK (0);
        IF (current_time + (dpv$display_delay * 1000)) >
              (dmv$time_of_last_tape_scan_call + (iov$tape_scan_frequency * 1000000)) THEN
          tmp$ready_system_task (tmc$stid_tape_scanner, status);
          dmv$time_of_last_tape_scan_call := current_time;
        IFEND;
      IFEND;
    ELSE
      clp$close_display (display_control, status);
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND dmp$tape_status_display;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] dmp$tape_reservations_display', EJECT ??

  PROCEDURE [XDCL] dmp$tape_reservations_display
    (    wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);
?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure provides clean-up processing when a task abort occurs.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF wid = 0 THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    VAR
      display_control: clt$display_control,
      ignore_status: ost$status,
      index: integer,
      unit_type: rmt$supported_tape_densities,
      number_of_units: array [rmt$supported_tape_densities] of ost$string,
      s: string (80),
      tape_reserved: boolean,
      no_tapes_reserved_line: [READ, oss$job_paged_literal] string (61) :=
            '                    *** No tape reservations outstanding. ***',
      title: [READ, oss$job_paged_literal] string (80) :=
            ' System_Supplied_Name  Mt9$800  Mt9$1600  Mt9$6250  Mt18$38000 <- Units_Reserved';

    status.normal := TRUE;

    IF wid = 0 THEN
      osp$establish_block_exit_hndlr (^abort_handler);
    IFEND;
    IF initial_call THEN
      ofp$open_display (file_name, wid, dpc$wc_sharing, dpc$wk_table, title, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF wid <> 0 THEN
      dpp$clear_window (wid, status);
    ELSE
      s := '  ';
      clp$put_display (display_control, s, clc$trim, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    tape_reserved := FALSE;

    IF dmv$p_tape_reservations <> NIL THEN
    /scan_table/
      FOR index := LOWERBOUND (dmv$p_tape_reservations^) TO UPPERBOUND (dmv$p_tape_reservations^) DO
        s := '  ';

        IF (NOT dmv$p_tape_reservations^ [index].available) THEN
          s (2, jmc$system_supplied_name_size) := dmv$p_tape_reservations^ [index].jsn;

          FOR unit_type := rmc$800 TO rmc$maximum_density DO
            IF (dmv$p_tape_reservations^ [index].unit_type [unit_type] > 0) THEN
              tape_reserved := TRUE;
              clp$convert_integer_to_string (dmv$p_tape_reservations^ [index].unit_type [unit_type], 10,
                    FALSE, number_of_units [unit_type], ignore_status);
            ELSE
              number_of_units [unit_type].value := '  ';
            IFEND;
          FOREND;

          s (26, 2) := number_of_units [rmc$800].value (1, 2);
          s (36, 2) := number_of_units [rmc$1600].value (1, 2);
          s (46, 2) := number_of_units [rmc$6250].value (1, 2);
          s (57, 2) := number_of_units [rmc$38000].value (1, 2);

          IF wid <> 0 THEN
            dpp$put_next_line (wid, s, status);
          ELSE
            clp$put_display (display_control, s, clc$trim, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        IFEND;
      FOREND /scan_table/;
    IFEND;

    IF NOT tape_reserved THEN
      s := ' ';
      IF wid <> 0 THEN
        dpp$put_next_line (wid, s, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        dpp$put_next_line (wid, no_tapes_reserved_line, status);
      ELSE
        clp$put_display (display_control, s, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_display (display_control, no_tapes_reserved_line, clc$trim, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF wid = 0 THEN
      clp$close_display (display_control, status);
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND dmp$tape_reservations_display;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] iop$tape_scanner_ep', EJECT ??
  PROCEDURE [XDCL, #GATE] iop$tape_scanner_ep;

    iop$tape_scanner;

  PROCEND iop$tape_scanner_ep;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] dmp$fetch_tape_unit_count', EJECT ??

*copy dmh$fetch_tape_unit_count

  PROCEDURE [XDCL, #GATE] dmp$fetch_tape_unit_count
    (VAR tape_unit_count: ost$non_negative_integers;
     VAR status: ost$status);

    status.normal := TRUE;

    tape_unit_count := UPPERBOUND (iov$tusl_p^);

  PROCEND dmp$fetch_tape_unit_count;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] dmp$fetch_tape_unit_status_info', EJECT ??

*copy dmh$fetch_tape_unit_status_info

  PROCEDURE [XDCL, #GATE] dmp$fetch_tape_unit_status_info
    (VAR tape_unit_status_info: array [1 .. * ] of dmt$tape_unit_status_info;
     VAR status: ost$status);

    VAR
      current_time: integer,
      i: integer,
      upper_limit: integer;

    status.normal := TRUE;

    current_time := #FREE_RUNNING_CLOCK (0);
    IF (dmv$time_of_last_tape_scan_call = 0) OR
          (current_time > (dmv$time_of_last_tape_scan_call +
          iov$tape_scan_frequency * 1000000)) THEN
      tmp$ready_system_task (tmc$stid_tape_scanner, status);
      dmv$time_of_last_tape_scan_call := current_time;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF UPPERBOUND (tape_unit_status_info) < UPPERBOUND (iov$tusl_p^) THEN
      upper_limit := UPPERBOUND (tape_unit_status_info);
      osp$set_status_abnormal (rmc$resource_management_id, dme$array_size_mismatch,
            '', status);
      osp$append_status_integer (' ', UPPERBOUND (iov$tusl_p^), 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            UPPERBOUND (tape_unit_status_info), 10, FALSE, status);
    ELSEIF UPPERBOUND (tape_unit_status_info) > UPPERBOUND (iov$tusl_p^) THEN
      upper_limit := UPPERBOUND (iov$tusl_p^);
      osp$set_status_abnormal (rmc$resource_management_id, dme$array_size_mismatch,
            '', status);
      osp$append_status_integer (' ', UPPERBOUND (iov$tusl_p^), 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            UPPERBOUND (tape_unit_status_info), 10, FALSE, status);
    ELSE
      upper_limit := UPPERBOUND (iov$tusl_p^);
    IFEND;

    FOR i := 1 TO upper_limit DO
      tape_unit_status_info [i].element_name := iov$tusl_p^ [i].element_name;
      tape_unit_status_info [i].unit_type := iov$tusl_p^ [i].unit_type;
      tape_unit_status_info [i].element_state := iov$tusl_p^ [i].tape_unit_state;
      CASE tape_unit_status_info [i].element_state OF

      = cmc$on =
        tape_unit_status_info [i].detected_tape_characteristics :=
              iov$tusl_p^ [i].detected_tape_characteristics;
        tape_unit_status_info [i].recorded_vsn := iov$tusl_p^ [i].rvsn;
        tape_unit_status_info [i].assigned := NOT (ioc$not_assigned =
            iov$tusl_p^ [i].assignment_state);
        CASE tape_unit_status_info [i].assigned OF

        = FALSE =
          tape_unit_status_info [i].read_error := iov$tusl_p^ [i].read_error;
          tape_unit_status_info [i].unit_ready := iov$tusl_p^ [i].unit_ready;

        = TRUE =
          tape_unit_status_info [i].external_vsn := iov$tusl_p^ [i].evsn;
          tape_unit_status_info [i].path_handle_name :=
                iov$tusl_p^ [i].path_handle_name;
          tape_unit_status_info [i].system_supplied_name := iov$tusl_p^ [i].ssn;
        CASEND;
      = cmc$off, cmc$down =
      CASEND;
    FOREND;

  PROCEND dmp$fetch_tape_unit_status_info;
?? OLDTITLE ??
MODEND dmm$tape_displays_23d;
*DECK DECK=DMM$TAPE_RESERVATION_113 EXPAND=TRUE
MODULE dmm$tape_reservation_113;
*copyc osd$default_pragmats
?? PUSH (LIST := ON) ??
?? NEWTITLE := 'Resource Management: Perform mainframe tape unit scheduling',
      EJECT ??
?? NEWTITLE := 'Global variables declared by this module', EJECT ??
{ System tape table pointer.

  VAR
    dmv$p_system_tape_table: [XDCL, #GATE, STATIC,
          oss$mainframe_pageable] ^dmt$system_tape_table := NIL;

{ System tape table lock.

  VAR
    dmv$system_tape_table_lock: [XDCL, STATIC, oss$mainframe_pageable]
          ost$signature_lock := [0];

{  There is no signature lock for dmv$p_tape_reservations^ table because
{  it is always accessed at the same time as dmv$p_system_tape_table^ in
{  which case dmv$system_tape_table_lock must be set.

  VAR
    dmv$p_tape_reservations: [XDCL, #GATE, STATIC,
          oss$mainframe_pageable] ^dmt$tape_reservations := NIL;

?? OLDTITLE ??
?? NEWTITLE := 'Global variables referenced by this module', EJECT ??
*copyc cmv$logical_unit_table
*copyc iov$number_of_tape_units
*copyc iov$tusl_lock
*copyc iov$tusl_p
*copyc osv$mainframe_pageable_heap
*copyc oss$mainframe_pageable
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc rmc$highest_unit_type
*copyc rmt$tape_unit_types
?? OLDTITLE ??
?? NEWTITLE := 'External procedures referenced by this module', EJECT ??
*copyc cmp$get_element_name_via_lun
*copyc iop$ready_waiting_tape_tasks
*copyc osp$append_status_parameter
*copyc osp$clear_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$test_set_main_sig_lock
*copyc osp$test_sig_lock
*copyc pmp$get_job_names
?? PUSH (LIST := OFF) ??
*copyc dmt$system_tape_table
*copyc dme$tape_errors
*copyc dmt$tape_reservations
*copyc iot$no_of_tape_units
*copyc ost$signature_lock
*copyc rmc$maximum_density
*copyc rmt$tape_class
*copyc rmt$tape_reservation
?? POP ??

?? OLDTITLE ??
?? NEWTITLE := 'clear_mainframe_sig_lock', EJECT ??

  PROCEDURE clear_mainframe_sig_lock
    (VAR lock: ost$signature_lock);

    VAR
      lock_status: ost$signature_lock_status,
      locked: boolean;

      osp$test_sig_lock (lock, lock_status);
      IF lock_status = osc$sls_locked_by_current_task THEN
        osp$clear_mainframe_sig_lock  (lock);
      IFEND;

  PROCEND clear_mainframe_sig_lock;

?? OLDTITLE ??
?? NEWTITLE := 'set_mainframe_sig_lock', EJECT ??

  PROCEDURE set_mainframe_sig_lock
    (    lock_string: string ( * <= osc$max_string_size);
     VAR lock: ost$signature_lock;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      lock_status: ost$signature_lock_status,
      locked: boolean;

      status.normal := TRUE;

      osp$test_sig_lock (lock, lock_status);
      IF lock_status = osc$sls_locked_by_current_task THEN
        osp$clear_mainframe_sig_lock (lock);
      ELSEIF lock_status = osc$sls_locked_by_another_task THEN
        osp$set_status_abnormal (rmc$resource_management_id, dme$unable_to_lock_tape_table, lock_string,
              status);
      IFEND;

      IF status.normal THEN
        osp$test_set_main_sig_lock (lock, locked);
        IF NOT locked THEN
          osp$set_status_abnormal (rmc$resource_management_id, dme$unable_to_lock_tape_table, lock_string,
                status);
        IFEND;
      IFEND;

  PROCEND set_mainframe_sig_lock;

?? OLDTITLE ??
?? NEWTITLE := 'dmp$acquire_tape_resources', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$acquire_tape_resource
    (    reservation: rmt$tape_reservation;
     VAR reserve_complete: boolean;
     VAR status: ost$status);

    VAR
      density: rmt$density,
      stt: ^dmt$system_tape_table,
      units_needed: integer,
      ut: rmt$tape_unit_types;

    reserve_complete := FALSE;

    set_mainframe_sig_lock ('DMV$SYSTEM_TAPE_TABLE_LOCK', dmv$system_tape_table_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /acquire_tape_resource/
    BEGIN
      IF (dmv$p_system_tape_table = NIL) THEN
        dmp$create_stt (status);
        IF NOT status.normal THEN
          EXIT /acquire_tape_resource/;
        IFEND;
      IFEND;

{ Create local copy of the system_tape_table.

      PUSH stt;
      stt^ := dmv$p_system_tape_table^;

{ Determine if configuration limits exceeded.

      IF (reservation [rmc$800] > stt^ [rmc$hd_pe].defined_tape) OR
            (reservation [rmc$1600] > (stt^ [rmc$hd_pe].defined_tape + stt^ [rmc$pe_ge].defined_tape)) OR
            (reservation [rmc$6250] > stt^ [rmc$pe_ge].defined_tape) OR
            (reservation [rmc$38000] > stt^ [rmc$cartridge].defined_tape) OR
            ((reservation [rmc$800] + reservation [rmc$1600] + reservation [rmc$6250]) >
            (stt^ [rmc$hd_pe].defined_tape + stt^ [rmc$pe_ge].defined_tape)) THEN
        osp$set_status_abnormal (rmc$resource_management_id, dme$tape_configuration_exceeded, '', status);
        EXIT /acquire_tape_resource/;
      ELSEIF (reservation [rmc$800] > stt^ [rmc$hd_pe].number_on) OR
            (reservation [rmc$1600] > (stt^ [rmc$hd_pe].number_on + stt^ [rmc$pe_ge].number_on)) OR
            (reservation [rmc$6250] > stt^ [rmc$pe_ge].number_on) OR
            (reservation [rmc$38000] > stt^ [rmc$cartridge].number_on) OR
            ((reservation [rmc$800] + reservation [rmc$1600] + reservation [rmc$6250]) >
            (stt^ [rmc$hd_pe].number_on + stt^ [rmc$pe_ge].number_on)) THEN
        osp$set_status_abnormal (rmc$resource_management_id, dme$not_enough_in_on_state, '', status);
        EXIT /acquire_tape_resource/;
      IFEND;

      FOR density := rmc$800 TO rmc$maximum_density DO
        IF reservation [density] > 0 THEN
          CASE density OF

          = rmc$800 =
            IF reservation [density] <= (stt^ [rmc$hd_pe].number_on - stt^ [rmc$hd_pe].
                  lower_density_reserved - stt^ [rmc$hd_pe].higher_density_reserved) THEN
              { reserve possible
              stt^ [rmc$hd_pe].lower_density_reserved :=
                    stt^ [rmc$hd_pe].lower_density_reserved + reservation [density];
            ELSE { determine if 1600 reserves can be moved to other unit type
              IF stt^ [rmc$hd_pe].higher_density_reserved = 0 THEN
                EXIT /acquire_tape_resource/;
              ELSE
                units_needed := reservation [density] - (stt^ [rmc$hd_pe].number_on -
                      stt^ [rmc$hd_pe].lower_density_reserved - stt^ [rmc$hd_pe].higher_density_reserved);
                IF units_needed <= stt^ [rmc$pe_ge].number_on - stt^ [rmc$pe_ge].lower_density_reserved -
                      stt^ [rmc$pe_ge].higher_density_reserved THEN
                  stt^ [rmc$hd_pe].higher_density_reserved :=
                        stt^ [rmc$hd_pe].higher_density_reserved - units_needed;
                  stt^ [rmc$pe_ge].lower_density_reserved :=
                        stt^ [rmc$pe_ge].lower_density_reserved + units_needed;
                  stt^ [rmc$hd_pe].lower_density_reserved :=
                        stt^ [rmc$hd_pe].lower_density_reserved + reservation [density];
                ELSE
                  EXIT /acquire_tape_resource/;
                IFEND;
              IFEND;
            IFEND;

          = rmc$1600 =
            IF reservation [density] <= (stt^ [rmc$hd_pe].number_on - stt^ [rmc$hd_pe].
                  lower_density_reserved - stt^ [rmc$hd_pe].higher_density_reserved) +
                  (stt^ [rmc$pe_ge].number_on - stt^ [rmc$pe_ge].lower_density_reserved -
                  stt^ [rmc$pe_ge].higher_density_reserved) THEN { reserve possible
              IF reservation [density] <= (stt^ [rmc$hd_pe].number_on -
                    stt^ [rmc$hd_pe].lower_density_reserved - stt^ [rmc$hd_pe].higher_density_reserved) THEN
                stt^ [rmc$hd_pe].higher_density_reserved :=
                      stt^ [rmc$hd_pe].higher_density_reserved + reservation [density];
              ELSE
                units_needed := reservation [density] - (stt^ [rmc$hd_pe].number_on -
                      stt^ [rmc$hd_pe].lower_density_reserved - stt^ [rmc$hd_pe].higher_density_reserved);
                stt^ [rmc$hd_pe].higher_density_reserved :=
                      stt^ [rmc$hd_pe].higher_density_reserved + reservation [density] - units_needed;
                stt^ [rmc$pe_ge].lower_density_reserved :=
                      stt^ [rmc$pe_ge].lower_density_reserved + units_needed;
              IFEND;
            ELSE
              EXIT /acquire_tape_resource/;
            IFEND;

          = rmc$6250 =
            IF reservation [density] <= (stt^ [rmc$pe_ge].number_on -
                  stt^ [rmc$pe_ge].lower_density_reserved - stt^ [rmc$pe_ge].higher_density_reserved) THEN
              stt^ [rmc$pe_ge].higher_density_reserved :=
                    stt^ [rmc$pe_ge].higher_density_reserved + reservation [density];
            ELSE { determine if 1600 reserves can be moved to other unit type
              IF stt^ [rmc$pe_ge].lower_density_reserved = 0 THEN
                { none to move, reserve cannot be done
                EXIT /acquire_tape_resource/;
              ELSE
                units_needed := reservation [density] - (stt^ [rmc$pe_ge].number_on -
                      stt^ [rmc$pe_ge].lower_density_reserved - stt^ [rmc$pe_ge].higher_density_reserved);
                IF units_needed <= stt^ [rmc$hd_pe].number_on - stt^ [rmc$hd_pe].lower_density_reserved -
                      stt^ [rmc$hd_pe].higher_density_reserved THEN
                  stt^ [rmc$pe_ge].lower_density_reserved :=
                        stt^ [rmc$pe_ge].lower_density_reserved - units_needed;
                  stt^ [rmc$hd_pe].higher_density_reserved :=
                        stt^ [rmc$hd_pe].higher_density_reserved + units_needed;
                  stt^ [rmc$pe_ge].higher_density_reserved :=
                        stt^ [rmc$pe_ge].higher_density_reserved + reservation [density];
                ELSE
                  EXIT /acquire_tape_resource/;
                IFEND;
              IFEND;
            IFEND;

          = rmc$38000 =
            IF reservation [density] <= (stt^ [rmc$cartridge].number_on -
                  stt^ [rmc$cartridge].lower_density_reserved) THEN
              stt^ [rmc$cartridge].lower_density_reserved :=
                    stt^ [rmc$cartridge].lower_density_reserved + reservation [density];
            ELSE
              EXIT /acquire_tape_resource/;
            IFEND;
          ELSE
          CASEND;
        IFEND;
      FOREND;

{ Log the reservations for the VED TAPE_RESERVATION display.

      FOR density := rmc$800 TO rmc$maximum_density DO
        IF reservation [density] > 0 THEN
          dmp$log_tape_reservation (density, reservation [density], status);
          IF NOT status.normal THEN
            EXIT /acquire_tape_resource/;
          IFEND;
        IFEND;
      FOREND;

{ Update real system_tape table from local copy and clear table lock.

      reserve_complete := TRUE;
      dmv$p_system_tape_table^ := stt^;
    END /acquire_tape_resource/;

    clear_mainframe_sig_lock (dmv$system_tape_table_lock);

  PROCEND dmp$acquire_tape_resource;

?? OLDTITLE ??
?? NEWTITLE := 'dmp$convert_unit_type', EJECT ??

  PROCEDURE dmp$convert_unit_type
    (    io_unit_type: iot$unit_type;
     VAR dm_unit_type: rmt$tape_unit_types);

    CASE io_unit_type OF
    = ioc$dt_mt679_2, ioc$dt_mt679_3, ioc$dt_mt679_4 =
      dm_unit_type := rmc$hd_pe;

    = ioc$dt_mt679_5, ioc$dt_mt679_6, ioc$dt_mt679_7, ioc$dt_mt639_1,
          ioc$dt_mt698_3x =
      dm_unit_type := rmc$pe_ge;

    = ioc$dt_mt5682_1x =
      dm_unit_type := rmc$cartridge;
    ELSE
    CASEND;

  PROCEND dmp$convert_unit_type;

?? OLDTITLE ??
?? NEWTITLE := 'dmp$create_stt', EJECT ??

  PROCEDURE [XDCL] dmp$create_stt
    (VAR status: ost$status);

    VAR
      dt: rmt$tape_unit_types,
      ut: iot$logical_unit;

    status.normal := TRUE;

    ALLOCATE dmv$p_system_tape_table IN osv$mainframe_pageable_heap^;

{ Initialize system tape table.

    FOR dt := rmc$hd_pe TO rmc$highest_unit_type DO
      dmv$p_system_tape_table^ [dt].defined_tape := 0;
      dmv$p_system_tape_table^ [dt].number_on := 0;
      dmv$p_system_tape_table^ [dt].lower_density_reserved := 0;
      dmv$p_system_tape_table^ [dt].higher_density_reserved := 0;
    FOREND;

{ Count the number of tape units configured and ON.

    FOR ut := LOWERBOUND (cmv$logical_unit_table^) TO UPPERBOUND (cmv$logical_unit_table^) DO
      IF ((cmv$logical_unit_table^ [ut].unit_interface_table <> NIL) AND
            ((cmv$logical_unit_table^ [ut].unit_interface_table^.unit_type >= ioc$dt_mt679_5) AND
            (cmv$logical_unit_table^ [ut].unit_interface_table^.unit_type <= ioc$highest_tape_unit))) THEN
        dmp$convert_unit_type (cmv$logical_unit_table^ [ut].unit_interface_table^.unit_type, dt);
        dmv$p_system_tape_table^ [dt].defined_tape := dmv$p_system_tape_table^ [dt].defined_tape + 1;
        IF cmv$logical_unit_table^ [ut].configured THEN
          IF cmv$logical_unit_table^ [ut].status.assignable_device AND
                (cmv$logical_unit_table^ [ut].element_capability <> $cmt$element_capabilities []) AND
                (cmv$logical_unit_table^ [ut].element_capability <>
                $cmt$element_capabilities [cmc$concurrent_maintenance, cmc$dedicated_maintenance]) THEN
            dmv$p_system_tape_table^ [dt].number_on := dmv$p_system_tape_table^ [dt].number_on + 1;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND dmp$create_stt;

?? OLDTITLE ??
?? NEWTITLE := 'dmp$log_tape_release', EJECT ??

  PROCEDURE dmp$log_tape_release
    (    density: rmt$supported_tape_densities;
         release_count: integer;
     VAR status: ost$status);

    VAR
      found: boolean,
      jsn: jmt$system_supplied_name,
      qrn: jmt$user_supplied_name,
      reserved: integer,
      unit: integer;

    pmp$get_job_names (qrn, jsn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (dmv$p_tape_reservations = NIL) THEN
      osp$set_status_abnormal (rmc$resource_management_id, dme$reserve_not_effected, '', status);
      RETURN;
    IFEND;

    found := FALSE;

  /main/
    FOR unit := LOWERBOUND (dmv$p_tape_reservations^) TO UPPERBOUND (dmv$p_tape_reservations^) DO
      IF NOT dmv$p_tape_reservations^ [unit].available AND
            (dmv$p_tape_reservations^ [unit].jsn = jsn) THEN
        dmv$p_tape_reservations^ [unit].unit_type [density] :=
              dmv$p_tape_reservations^ [unit].unit_type [density] - release_count;
        found := TRUE;
        EXIT /main/;
      IFEND;
    FOREND /main/;

    IF NOT found THEN
      osp$set_status_abnormal (rmc$resource_management_id, dme$unable_to_log_release, '', status);
      RETURN;
    IFEND;

    reserved := dmv$p_tape_reservations^ [unit].unit_type [rmc$800] +
          dmv$p_tape_reservations^ [unit].unit_type [rmc$1600] +
          dmv$p_tape_reservations^ [unit].unit_type [rmc$6250] +
          dmv$p_tape_reservations^ [unit].unit_type [rmc$38000];

    IF (reserved < 1) THEN
      dmv$p_tape_reservations^ [unit].available := TRUE;
    IFEND;

  PROCEND dmp$log_tape_release;

?? OLDTITLE ??
?? NEWTITLE := 'dmp$log_tape_reservation', EJECT ??

  PROCEDURE dmp$log_tape_reservation
    (    density: rmt$supported_tape_densities;
         reserve_count: integer;
     VAR status: ost$status);

    VAR
      found: boolean,
      jsn: jmt$system_supplied_name,
      qrn: jmt$user_supplied_name,
      reserved: integer,
      unit: integer;

    pmp$get_job_names (qrn, jsn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (dmv$p_tape_reservations = NIL) THEN

      ALLOCATE dmv$p_tape_reservations: [1 .. iov$number_of_tape_units + 1] IN
            osv$mainframe_pageable_heap^;

      FOR unit := LOWERBOUND (dmv$p_tape_reservations^) TO UPPERBOUND (dmv$p_tape_reservations^) DO
        dmv$p_tape_reservations^ [unit].available := TRUE;
        dmv$p_tape_reservations^ [unit].jsn := jmc$full_system_supplied_name;
        dmv$p_tape_reservations^ [unit].unit_type [rmc$800] := 0;
        dmv$p_tape_reservations^ [unit].unit_type [rmc$1600] := 0;
        dmv$p_tape_reservations^ [unit].unit_type [rmc$6250] := 0;
        dmv$p_tape_reservations^ [unit].unit_type [rmc$38000] := 0;
      FOREND;
    IFEND;

    found := FALSE;

{ See if an entry already exists for this job.

  /main/
    BEGIN
      FOR unit := LOWERBOUND (dmv$p_tape_reservations^) TO UPPERBOUND (dmv$p_tape_reservations^) DO
        IF (NOT dmv$p_tape_reservations^ [unit].available) AND
              (dmv$p_tape_reservations^ [unit].jsn = jsn) THEN
          dmv$p_tape_reservations^ [unit].unit_type [density] :=
                dmv$p_tape_reservations^ [unit].unit_type [density] + reserve_count;
          found := TRUE;
          EXIT /main/;
        IFEND;
      FOREND;

      FOR unit := LOWERBOUND (dmv$p_tape_reservations^) TO UPPERBOUND (dmv$p_tape_reservations^) DO
        IF dmv$p_tape_reservations^ [unit].available THEN
          dmv$p_tape_reservations^ [unit].available := FALSE;
          dmv$p_tape_reservations^ [unit].jsn := jsn;
          dmv$p_tape_reservations^ [unit].unit_type [density] := reserve_count;
          found := TRUE;
          EXIT /main/;
        IFEND;
      FOREND;
    END /main/;

    IF NOT found THEN
      osp$set_status_abnormal (rmc$resource_management_id, dme$unable_to_log_reservation, '', status);
      RETURN;
    IFEND;

  PROCEND dmp$log_tape_reservation;

?? OLDTITLE ??
?? NEWTITLE := 'dmp$return_tape_resource', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$return_tape_resource
    (    reservation: rmt$tape_reservation;
     VAR status: ost$status);

    VAR
      density: rmt$density,
      extra_units: integer;

    IF (dmv$p_system_tape_table = NIL) THEN
      osp$set_status_abnormal (rmc$resource_management_id, dme$reserve_not_effected, '', status);
      RETURN;
    IFEND;

    set_mainframe_sig_lock ('DMV$SYSTEM_TAPE_TABLE_LOCK', dmv$system_tape_table_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /return_tape_resource/
    BEGIN

{ Remove reservations from the VED TAPE_RESERVATIONS display.

      FOR density := rmc$800 TO rmc$maximum_density DO
        IF reservation [density] > 0 THEN
          dmp$log_tape_release (density, reservation [density], status);
          IF NOT status.normal THEN
            EXIT /return_tape_resource/;
          IFEND;
        IFEND;
      FOREND;

      FOR density := rmc$800 TO rmc$maximum_density DO
        IF (reservation [density] > 0) THEN

          CASE density OF
          = rmc$800 =
            dmv$p_system_tape_table^ [rmc$hd_pe].lower_density_reserved :=
                  dmv$p_system_tape_table^ [rmc$hd_pe].lower_density_reserved - reservation [density];

          = rmc$1600 =
            IF reservation [density] <= dmv$p_system_tape_table^ [rmc$hd_pe].higher_density_reserved THEN
              dmv$p_system_tape_table^ [rmc$hd_pe].higher_density_reserved :=
                    dmv$p_system_tape_table^ [rmc$hd_pe].higher_density_reserved - reservation [density];
            ELSE
              extra_units := reservation [density] - dmv$p_system_tape_table^ [rmc$hd_pe].
                    higher_density_reserved;
              dmv$p_system_tape_table^ [rmc$hd_pe].higher_density_reserved := 0;
              dmv$p_system_tape_table^ [rmc$pe_ge].lower_density_reserved :=
                    dmv$p_system_tape_table^ [rmc$pe_ge].lower_density_reserved - extra_units;
            IFEND;

          = rmc$6250 =
            dmv$p_system_tape_table^ [rmc$pe_ge].higher_density_reserved :=
                  dmv$p_system_tape_table^ [rmc$pe_ge].higher_density_reserved - reservation [density];

          = rmc$38000 =
            dmv$p_system_tape_table^ [rmc$cartridge].lower_density_reserved :=
                  dmv$p_system_tape_table^ [rmc$cartridge].lower_density_reserved - reservation [density];

          ELSE
          CASEND;
        IFEND;
      FOREND;
    END /return_tape_resource/;

    clear_mainframe_sig_lock (dmv$system_tape_table_lock);

  PROCEND dmp$return_tape_resource;

?? OLDTITLE ??
?? NEWTITLE := 'dmp$update_stt', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$update_stt
    (    lun: iot$logical_unit;
         old_state: cmt$element_state;
         new_state: cmt$element_state;
     VAR status: ost$status);

    VAR
      dt: rmt$tape_unit_types,
      element_name: ost$name,
      i: iot$no_of_tape_units;

    PROCEDURE update_the_tusl_entry
      (VAR status: ost$status);

      cmp$get_element_name_via_lun (lun, element_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    /update_tusl_entry/
      FOR i := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
        IF iov$tusl_p^ [i].element_name = element_name THEN
          set_mainframe_sig_lock ('IOV$TUSL_LOCK', iov$tusl_lock, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          set_mainframe_sig_lock ('TUSL_ENTRY_LOCK', iov$tusl_p^ [i].lock, status);
          IF NOT status.normal THEN
            clear_mainframe_sig_lock (iov$tusl_lock);
            RETURN;
          IFEND;

          iov$tusl_p^ [i].tape_unit_state := new_state;
          IF new_state <> cmc$on THEN
            iov$tusl_p^ [i].evsn := rmc$unspecified_vsn;
            iov$tusl_p^ [i].rvsn := rmc$unspecified_vsn;
            iov$tusl_p^ [i].ssn := jmc$blank_system_supplied_name;
            iov$tusl_p^ [i].assignment_state := ioc$not_assigned;
            iov$tusl_p^ [i].unit_ready := FALSE;
            iov$tusl_p^ [i].read_error := FALSE;
            iov$tusl_p^ [i].detected_tape_characteristics.label_type := amc$labelled;
            iov$tusl_p^ [i].detected_tape_characteristics.character_set := amc$ascii;
            iov$tusl_p^ [i].detected_tape_characteristics.write_ring := FALSE;
            iov$tusl_p^ [i].detected_tape_characteristics.density := rmc$200;
          ELSE
            iop$ready_waiting_tape_tasks (iov$tusl_p^ [i].unit_type);
          IFEND;

          clear_mainframe_sig_lock (iov$tusl_p^ [i].lock);
          clear_mainframe_sig_lock (iov$tusl_lock);
          EXIT /update_tusl_entry/;
        IFEND;
      FOREND /update_tusl_entry/;

    PROCEND update_the_tusl_entry;

    set_mainframe_sig_lock ('DMV$SYSTEM_TAPE_TABLE_LOCK', dmv$system_tape_table_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /update_stt/
    BEGIN
      IF (dmv$p_system_tape_table = NIL) THEN
        dmp$create_stt (status);
        update_the_tusl_entry(status);
        EXIT /update_stt/;
      ELSE
        IF old_state = new_state THEN
          EXIT /update_stt/;
        IFEND;

        update_the_tusl_entry(status);
        dmp$convert_unit_type (cmv$logical_unit_table^ [lun].unit_interface_table^.unit_type, dt);
        IF ((old_state = cmc$off) OR (old_state = cmc$down)) AND (new_state = cmc$on) THEN
          dmv$p_system_tape_table^ [dt].number_on := dmv$p_system_tape_table^ [dt].number_on + 1;
        ELSEIF old_state = cmc$on THEN
          dmv$p_system_tape_table^ [dt].number_on := dmv$p_system_tape_table^ [dt].number_on - 1;
        IFEND;
      IFEND;
    END /update_stt/;

    clear_mainframe_sig_lock (dmv$system_tape_table_lock);

  PROCEND dmp$update_stt;

?? OLDTITLE ??
?? NEWTITLE := 'dmp$validate_tape_density', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$validate_tape_density
    (    density: rmt$density;
     VAR status: ost$status);

    set_mainframe_sig_lock ('DMV$SYSTEM_TAPE_TABLE_LOCK', dmv$system_tape_table_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /validate_tape_density/
    BEGIN

      IF (dmv$p_system_tape_table = NIL) THEN
        dmp$create_stt (status);
        IF NOT status.normal THEN
          EXIT /validate_tape_density/;
        IFEND;
      IFEND;

      CASE density OF

      = rmc$200 =
        osp$set_status_abnormal (rmc$resource_management_id, dme$density_not_supported, '200', status);

      = rmc$556 =
        osp$set_status_abnormal (rmc$resource_management_id, dme$density_not_supported, '556', status);

      = rmc$800 =
        IF dmv$p_system_tape_table^ [rmc$hd_pe].defined_tape = 0 THEN
          osp$set_status_abnormal (rmc$resource_management_id, dme$unit_type_not_configured, '800', status);
        IFEND;

      = rmc$1600 =
        IF (dmv$p_system_tape_table^ [rmc$hd_pe].defined_tape +
              dmv$p_system_tape_table^ [rmc$pe_ge].defined_tape = 0) THEN
          osp$set_status_abnormal (rmc$resource_management_id, dme$unit_type_not_configured, '1600', status);
        IFEND;

      = rmc$6250 =
        IF dmv$p_system_tape_table^ [rmc$pe_ge].defined_tape = 0 THEN
          osp$set_status_abnormal (rmc$resource_management_id, dme$unit_type_not_configured, '6250', status);
        IFEND;

      = rmc$38000 =
        IF dmv$p_system_tape_table^ [rmc$cartridge].defined_tape = 0 THEN
          osp$set_status_abnormal (rmc$resource_management_id, dme$unit_type_not_configured, '38000', status);
        IFEND;

      ELSE
      CASEND;

    END /validate_tape_density/;

    clear_mainframe_sig_lock (dmv$system_tape_table_lock);

  PROCEND dmp$validate_tape_density;
?? OLDTITLE ??

MODEND dmm$tape_reservation_113;

*DECK DECK=DMM$TRANSFER_UNIT_COMPLETED EXPAND=TRUE
?? RIGHT := 110 ??
*copy osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Module Header' ??
MODULE dmm$transfer_unit_completed;
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc cml$ms_media_flaw_change
*copyc osk$keypoints
*copyc dmt$active_volume_table_index
*copyc dmt$keypoint_calls
*copyc dmt$device_allocation_unit
*copyc dmt$file_attributes
*copyc dmt$log_flaw_init_data
*copyc dmt$file_allocation_descriptor
*copyc dmt$file_medium_descriptor
*copyc dmt$file_table_lock
*copyc dmt$error_condition_codes
*copyc dmt$ms_logical_device_address
*copyc dmt$assigned_ms_vol_attributes
*copyc dst$system_message_types
*copyc gft$system_file_identifier
*copyc gft$locked_file_desc_entry_p
*copyc jmt$ajl_ordinal
*copyc jmt$ijl_ordinal
*copyc syt$monitor_request_code
*copyc iot$cylinder
*copyc iot$io_function
*copyc dmt$minimum_allocation_unit
?? POP ??
*copy dmp$get_active_vol_attributes
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_fau_entry
*copyc dmp$get_fmd_by_index
*copy dmp$mtr_log
*copy dsp$report_system_message
*copyc gfp$mtr_get_locked_fde_p
*copyc jmp$get_ijle_p
*copyc jmp$lock_ajl
*copyc jmp$unlock_ajl
*copyc mtp$error_stop
*copyc tmp$clear_lock
*copyc tmp$get_xcb_access_status
*copyc tmp$set_lock
?? EJECT ??
?? TITLE := '  XREF Variables', EJECT ??
*copyc dmv$allocation_log
*copy dmv$null_vsn
*copy dmv$null_sfid
*copyc jmv$ijl_p
*copyc tmv$ptl_lock
?? TITLE := '  [XDCL] dmp$transfer_unit_complete', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copy dmh$transfer_unit_completed
?? POP ??

  PROCEDURE [XDCL] dmp$transfer_unit_completed (job_id: jmt$ijl_ordinal;
        system_file_id: gft$system_file_identifier;
        byte_address: amt$file_byte_address;
        write_tu_status: dmt$write_tu_status;
        au_was_previously_written: boolean;
        media_error: boolean;
        cylinder: iot$cylinder;
        mau_offset_in_cylinder: dmt$maus_per_position;
        io_function: iot$io_function;
    VAR status: syt$monitor_status);

    VAR
      able_to_log: boolean,
      ajlo: jmt$ajl_ordinal,
      al_entry: dmt$al_entry,
      avt_entry_found: boolean,
      avt_index: dmt$active_volume_table_index,
      dau: dmt$dau_address,
      p_dfd: ^dmt$disk_file_descriptor,
      fau_state: dmt$fau_states,
      p_fde: gft$locked_file_desc_entry_p,
      flaw_logging_data: dmt$monitor_flaw_init_data,
      p_fmd: ^dmt$file_medium_descriptor,
      ijle_p: ^jmt$initiated_job_list_entry,
      inhibit_access: boolean,
      lock_status: dmt$lock_status,
      logging_active_for_volume: boolean,
      logging_required_for_file: boolean,
      message_recorded: boolean,
      p_active_vol_attributes: ^array [ * ] of dmt$assigned_ms_vol_attribute,
      p_fau: ^dmt$file_allocation_unit,
      p_flaw_logging_data: ^SEQ (*),
      recorded_vsn: rmt$recorded_vsn,
      sfid_valid: boolean,
      termination_status: syt$monitor_status;

    #INLINE ('keypoint', osk$entry, osk$m * system_file_id.file_entry_index, dmk$transfer_unit_written);

    status.normal := TRUE;

  /process_request/
    BEGIN
      jmp$get_ijle_p (job_id, ijle_p);

      { No processing is necessary for local file writes unless there was an
      { error and write_tu_status = dmc$tu_not_written.

      IF (system_file_id.residence = gfc$tr_job) AND
            ((io_function = ioc$write_page) OR (io_function = ioc$write_locked_page)) THEN

        { Since ijle_p^.inhibit_swap_count is not updated for local file writes, the job
        { may have terminated and the IJL block released.  Or since p_fde.read_write_count
        { is not updated, the file may have been deleted.  The caller of this routine has
        { set write_tu_status to dmc$tu_written if this is the case.

        IF (write_tu_status = dmc$tu_written) THEN
          RETURN;
        IFEND;

        { If the job is swapped to a point that we can no longer access the file tables,
        { we will wait until the job swaps back in to process the error.

        tmp$set_lock (tmv$ptl_lock);
        tmp$get_xcb_access_status (ijle_p, job_id, inhibit_access);
        tmp$clear_lock (tmv$ptl_lock);
        IF inhibit_access THEN
          RETURN;
        IFEND;

{ Locate the file descriptor.
{ The ajl ordinal in the ijle is used to locate the file descriptor of a local file.
{ Tmp$get_xcb_access_status has assigned an ajl or incremented the ajl in_use count
{ if the I/O was for a local file.  The ajl must be unlocked when processing is completed.

        gfp$mtr_get_locked_fde_p (system_file_id, ijle_p, p_fde);
        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

      ELSE

        IF (system_file_id.residence = gfc$tr_job) THEN
          jmp$lock_ajl (ijle_p, job_id, ajlo);
        IFEND;

{ Locate the file descriptor.
{ The ajl ordinal in the ijle is used to locate the file descriptor of a local file.
{ Jmp$lock_ajl has assigned an ajl or incremented the ajl in_use count if the I/O was for a
{ local file.  The ajl must be unlocked when processing is completed.

        gfp$mtr_get_locked_fde_p (system_file_id, ijle_p, p_fde);
        dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

        p_dfd^.read_write_count := p_dfd^.read_write_count - 1;

      IFEND;


      IF NOT au_was_previously_written OR media_error THEN

        dmp$get_fau_entry (p_dfd, byte_address, p_fau);
        dmp$get_fmd_by_index (p_dfd, p_fau^.fmd_index, p_fmd);

        avt_index := p_fmd^.avt_index;

        PUSH p_active_vol_attributes: [1 .. 2];
        p_active_vol_attributes^ [1].keyword := dmc$ms_device_log;
        p_active_vol_attributes^ [2].keyword := dmc$ms_recorded_vsn;

        dmp$get_active_vol_attributes (dmv$null_vsn, avt_index, p_active_vol_attributes, avt_entry_found);
        IF NOT avt_entry_found THEN
          mtp$error_stop ('unable to locate avt entry - DMP$TRANSFER_UNIT_COMPLETED');
        IFEND;

        logging_active_for_volume := (p_active_vol_attributes^ [1].p_dlog <> dmv$null_sfid);
        logging_required_for_file := (p_fde^.file_kind <= gfc$fk_last_permanent_file);

        IF NOT au_was_previously_written THEN
          IF write_tu_status = dmc$tu_written THEN
            fau_state := dmc$fau_initialized;
          ELSE
            fau_state := dmc$fau_invalid_data;
          IFEND;

          IF (( system_file_id.residence <> gfc$tr_job) OR
                ((io_function <> ioc$write_page) AND (io_function <> ioc$write_locked_page))) AND
                (p_fau^.state <> dmc$fau_initialization_in_prog) THEN
            mtp$error_stop ('fau already initialized - DMP$TRANSFER_UNIT_COMPLETED');
          IFEND;

          p_fau^.state := fau_state;
          IF fau_state = dmc$fau_initialized THEN
            IF logging_active_for_volume AND logging_required_for_file THEN
              al_entry.avt_index := avt_index;
              al_entry.kind := dmc$al_initialize;
              al_entry.initialize_block.global_file_name := p_fde^.global_file_name;
              al_entry.initialize_block.dfl_index := p_fmd^.dfl_index;
              al_entry.initialize_block.dau_address := p_fau^.dau_address;
              dmp$mtr_log (al_entry, able_to_log);
              IF NOT able_to_log THEN
                mtp$error_stop ('incomplete initialization - DMP$TRANSFER_UNIT_COMPLETED');
              IFEND;
            IFEND;
          IFEND;

          IF logging_required_for_file THEN
            dmv$allocation_log.committed_initialize_count :=
              dmv$allocation_log.committed_initialize_count - 1;
          IFEND;

        IFEND;

        IF media_error THEN
          IF ((p_fau^.state = dmc$fau_invalid_data) OR (p_fau^.state = dmc$fau_initialized)) AND
                logging_active_for_volume THEN

            dau := (cylinder * p_fmd^.daus_per_cylinder) + (mau_offset_in_cylinder DIV p_fmd^.maus_per_dau);

            IF (dau < p_fau^.dau_address) OR
                  (dau >= (p_fau^.dau_address + p_fmd^.daus_per_allocation_unit)) THEN
              mtp$error_stop ('Invalid DAU flaw address.');
            IFEND;

            al_entry.avt_index := avt_index;
            al_entry.kind := dmc$al_software_flawed;
            al_entry.software_flaw_block.dau_address := dau;
            al_entry.software_flaw_block.flaw_option := dmc$add_flaw;

            dmp$mtr_log (al_entry, able_to_log);
            IF NOT able_to_log THEN
              mtp$error_stop ('DM unable to log flaw - DMP$TRANSFER_UNIT_COMPLETED');
            IFEND;

            flaw_logging_data.message_type := cml$ms_media_flaw_change;
            flaw_logging_data.flaw_data.recorded_vsn := p_active_vol_attributes^ [2].recorded_vsn;
            flaw_logging_data.flaw_data.first_dau := dau;
            flaw_logging_data.flaw_data.last_dau := dau;
            flaw_logging_data.flaw_data.operation_code := dmc$oc_flaw_define;
            flaw_logging_data.flaw_data.initiator_code := dmc$ic_system_initiated;
            p_flaw_logging_data := #SEQ (flaw_logging_data);
            dsp$report_system_message (p_flaw_logging_data, dsc$general_system_message,
                  dsc$informative_message, message_recorded);
          IFEND;

          CASE p_fau^.state OF
          = dmc$fau_invalid_and_flawed, dmc$fau_initialized_and_flawed =
          = dmc$fau_initialized =
            p_fau^.state := dmc$fau_initialized_and_flawed;
          = dmc$fau_invalid_data =
            p_fau^.state := dmc$fau_invalid_and_flawed;
          ELSE
            mtp$error_stop ('probably a transfer flaw problem - DMP$TRANSFER_UNIT_COMPLETED');
          CASEND;
        IFEND;

      IFEND;

    END /process_request/;

{ Decrement the ajl in use count for local files.

    IF (system_file_id.residence = gfc$tr_job) THEN
      jmp$unlock_ajl (ijle_p);
    IFEND;

    #INLINE ('keypoint', osk$exit, 0, dmk$transfer_unit_written);

  PROCEND dmp$transfer_unit_completed;

?? TITLE := '  [XDCL] dmp$set_fau_state', EJECT ??
*copyc dmh$set_fau_state

  PROCEDURE [XDCL] dmp$set_fau_state
    (    p_fde: gft$locked_file_desc_entry_p;
         byte_address: amt$file_byte_address;
     VAR status: syt$monitor_status);

    VAR
      p_dfd: ^dmt$disk_file_descriptor,
      lock_status: dmt$lock_status,
      p_fau: ^dmt$file_allocation_unit;

    status.normal := TRUE;

    dmp$get_disk_file_descriptor_p (p_fde, p_dfd);

    dmp$get_fau_entry (p_dfd, byte_address, p_fau);

    p_fau^.state := dmc$fau_invalid_data;

    PROCEND dmp$set_fau_state;

MODEND dmm$transfer_unit_completed;
*DECK DECK=DMM$VALIDATE_SFID_WITH_GFN EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??
MODULE dmm$validate_sfid_with_gfn;

{ PURPOSE:
{   The purpose of this module is to provide a mechanism for validating the
{   system_file_id prior to its usage.  It is used primarily on File_Server
{   files.
{ DESIGN:
{   The system_file_id and global_file_name are checked and status is returned.

?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dmt$global_file_name
*copyc dmt$system_file_id
*copyc gft$locked_file_desc_entry_p
*copyc oss$mainframe_paged_literal
*copyc ost$binary_unique_name
*copyc ost$name
*copyc ost$status
*copyc ost$string
*copyc ost$wait
*copyc pmt$processor_serial_number
?? POP ??
?? TITLE := '  External Procedures', EJECT ??
*copyc gfp$get_locked_fde_p
*copyc gfp$unlock_fde_p
*copyc osp$set_status_abnormal
?? TITLE := '  [XDCL, #GATE] dmp$validate_sfid_with_gfn', EJECT ??

{ Purpose:
{   This procedure takes an SFID and compares the Global_File_Name found in the associated
{   File_Descriptor_Entry with the Global_File_Name sent in as a parameter.  If the Global_File_Names match
{   a normal status is returned; if the Global_File_Names do not match, an abnormal status is returned.  The
{   text field of the abnormal status will contain the SFID in question and the Global_File_Names which do
{   not match.

  PROCEDURE [XDCL, #GATE] dmp$validate_sfid_with_gfn
    (    system_file_id: dmt$system_file_id;
         global_file_name: dmt$global_file_name;
     VAR status: ost$status);


    TYPE
      sfid_converter = RECORD
        CASE boolean OF
        = FALSE =
          fill: 0..0ffffffff(16),
          sfid: dmt$system_file_id,
        = TRUE =
          converted_sfid: integer,
        CASEND,
      RECEND;

    VAR
      converted_fde_gfn: ost$name,
      converted_params_gfn: ost$name,
      ignore_status: ost$status,
      p_fde: gft$locked_file_desc_entry_p,
      sfid_conv: sfid_converter,
      str: string (256),
      strlen: integer,
      wait: [STATIC, READ] ost$wait := osc$wait;


    status.normal := TRUE;
    gfp$get_locked_fde_p (system_file_id, p_fde);

    IF p_fde^.global_file_name <> global_file_name THEN
      sfid_conv.fill := 0;
      sfid_conv.sfid := system_file_id;
      convert_binary_unique_name (p_fde^.global_file_name, converted_fde_gfn);
      convert_binary_unique_name (global_file_name, converted_params_gfn);
      STRINGREP (str, strlen, 'REMOTE_SFID = ', sfid_conv.converted_sfid:#(16), '(16), GFN (FDE) = ',
            converted_fde_gfn, ', GFN (params) = ', converted_params_gfn, '; DMP$VALIDATE_SFID_WITH_GFN');
      osp$set_status_abnormal (dfc$file_server_id, dfe$sfid_gfn_mismatch, str, status);
    IFEND;

    gfp$unlock_fde_p (p_fde);

  PROCEND dmp$validate_sfid_with_gfn;
?? TITLE := '    Global Declarations For This Module', EJECT ??

  TYPE
    pmt_unique_name = record
      case boolean of
      = TRUE =
        value: ost$name,
      = FALSE =
        dollar_sign: string (1),
        sequence_number: string (7),
        processor_model_number: string (2),
        s: string (1),
        processor_serial_number: string (pmc$processor_serial_num_size),
        d: string (1),
        year: string (4),
        month: string (2),
        day: string (2),
        t: string (1),
        hour: string (2),
        minute: string (2),
        second: string (2),
      casend,
    recend,

    pmt_conversion_mask = record
      case boolean of
      = TRUE =
        integer_value: ost$processor_serial_number,
      = FALSE =
        bcd_value: packed array [1 .. pmc$processor_serial_num_size] of 0 .. 0f(16),
      casend,
    recend;

  VAR
  unique_name_mask: [STATIC, READ, oss$mainframe_paged_literal] string (256) := $CHAR (00) CAT $CHAR (01) CAT
          $CHAR (02) CAT $CHAR (03) CAT $CHAR (04) CAT $CHAR (05) CAT $CHAR (06) CAT $CHAR (07) CAT
          $CHAR (08) CAT $CHAR (09) CAT $CHAR (10) CAT $CHAR (11) CAT $CHAR (12) CAT $CHAR (13) CAT
          $CHAR (14) CAT $CHAR (15) CAT $CHAR (16) CAT $CHAR (17) CAT $CHAR (18) CAT $CHAR (19) CAT
          $CHAR (20) CAT $CHAR (21) CAT $CHAR (22) CAT $CHAR (23) CAT $CHAR (24) CAT $CHAR (25) CAT
          $CHAR (26) CAT $CHAR (27) CAT $CHAR (28) CAT $CHAR (29) CAT $CHAR (30) CAT $CHAR (31) CAT
          ' !"#$%&''()*+,-./9999999999:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_@ABCDEFGHIJKLMNOPQRSTUVWXYZ{|}^'
          CAT $CHAR (127) CAT $CHAR (128) CAT $CHAR (129) CAT $CHAR (130) CAT $CHAR (131) CAT $CHAR (132) CAT
          $CHAR (133) CAT $CHAR (134) CAT $CHAR (135) CAT $CHAR (136) CAT $CHAR (137) CAT $CHAR (138) CAT
          $CHAR (139) CAT $CHAR (140) CAT $CHAR (141) CAT $CHAR (142) CAT $CHAR (143) CAT $CHAR (144) CAT
          $CHAR (145) CAT $CHAR (146) CAT $CHAR (147) CAT $CHAR (148) CAT $CHAR (149) CAT $CHAR (150) CAT
          $CHAR (151) CAT $CHAR (152) CAT $CHAR (153) CAT $CHAR (154) CAT $CHAR (155) CAT $CHAR (156) CAT
          $CHAR (157) CAT $CHAR (158) CAT $CHAR (159) CAT $CHAR (160) CAT $CHAR (161) CAT $CHAR (162) CAT
          $CHAR (163) CAT $CHAR (164) CAT $CHAR (165) CAT $CHAR (166) CAT $CHAR (167) CAT $CHAR (168) CAT
          $CHAR (169) CAT $CHAR (170) CAT $CHAR (171) CAT $CHAR (172) CAT $CHAR (173) CAT $CHAR (174) CAT
          $CHAR (175) CAT $CHAR (176) CAT $CHAR (177) CAT $CHAR (178) CAT $CHAR (179) CAT $CHAR (180) CAT
          $CHAR (181) CAT $CHAR (182) CAT $CHAR (183) CAT $CHAR (184) CAT $CHAR (185) CAT $CHAR (186) CAT
          $CHAR (187) CAT $CHAR (188) CAT $CHAR (189) CAT $CHAR (190) CAT $CHAR (191) CAT $CHAR (192) CAT
          $CHAR (193) CAT $CHAR (194) CAT $CHAR (195) CAT $CHAR (196) CAT $CHAR (197) CAT $CHAR (198) CAT
          $CHAR (199) CAT $CHAR (200) CAT $CHAR (201) CAT $CHAR (202) CAT $CHAR (203) CAT $CHAR (204) CAT
          $CHAR (205) CAT $CHAR (206) CAT $CHAR (207) CAT $CHAR (208) CAT $CHAR (209) CAT $CHAR (210) CAT
          $CHAR (211) CAT $CHAR (212) CAT $CHAR (213) CAT $CHAR (214) CAT $CHAR (215) CAT $CHAR (216) CAT
          $CHAR (217) CAT $CHAR (218) CAT $CHAR (219) CAT $CHAR (220) CAT $CHAR (221) CAT $CHAR (222) CAT
          $CHAR (223) CAT $CHAR (224) CAT $CHAR (225) CAT $CHAR (226) CAT $CHAR (227) CAT $CHAR (228) CAT
          $CHAR (229) CAT $CHAR (230) CAT $CHAR (231) CAT $CHAR (232) CAT $CHAR (233) CAT $CHAR (234) CAT
          $CHAR (235) CAT $CHAR (236) CAT $CHAR (237) CAT $CHAR (238) CAT $CHAR (239) CAT $CHAR (240) CAT
          $CHAR (241) CAT $CHAR (242) CAT $CHAR (243) CAT $CHAR (244) CAT $CHAR (245) CAT $CHAR (246) CAT
          $CHAR (247) CAT $CHAR (248) CAT $CHAR (249) CAT $CHAR (250) CAT $CHAR (251) CAT $CHAR (252) CAT
          $CHAR (253) CAT $CHAR (254) CAT $CHAR (255),

    digits: [STATIC, READ, oss$mainframe_paged_literal] array [0 .. 15] of char := ['0', '1', '2', '3', '4',
          '5','6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'];

?? TITLE := '    CONVERT_BINARY_UNIQUE_NAME', EJECT ??
  PROCEDURE [INLINE] convert_binary_unique_name
    (    binary_name: ost$binary_unique_name;
     VAR name: ost$name);


    VAR
      number: integer,
      index: ost$string_index,
      converter: pmt_conversion_mask,
      generated_name: pmt_unique_name;


    generated_name.dollar_sign := '$';

    number := binary_name.sequence_number;
    FOR index := STRLENGTH (generated_name.sequence_number) DOWNTO 1 DO
      generated_name.sequence_number (index) := digits [number MOD 10];
      number := number DIV 10;
    FOREND;

    generated_name.processor_model_number (1) := digits [binary_name.model_number DIV 16];
    generated_name.processor_model_number (2) := digits [binary_name.model_number MOD 16];

    generated_name.s := 'S';

    converter.integer_value := binary_name.serial_number;
    FOR index := 1 TO pmc$processor_serial_num_size DO
      generated_name.processor_serial_number (index) := digits [converter.bcd_value [index]];
    FOREND;

    generated_name.d := 'D';

    number := binary_name.year;
    FOR index := STRLENGTH (generated_name.year) DOWNTO 1 DO
      generated_name.year (index) := digits [number MOD 10];
      number := number DIV 10;
    FOREND;

    generated_name.month (1) := digits [binary_name.month DIV 10];
    generated_name.month (2) := digits [binary_name.month MOD 10];

    generated_name.day (1) := digits [binary_name.day DIV 10];
    generated_name.day (2) := digits [binary_name.day MOD 10];

    generated_name.t := 'T';

    generated_name.hour (1) := digits [binary_name.hour DIV 10];
    generated_name.hour (2) := digits [binary_name.hour MOD 10];

    generated_name.minute (1) := digits [binary_name.minute DIV 10];
    generated_name.minute (2) := digits [binary_name.minute MOD 10];

    generated_name.second (1) := digits [binary_name.second DIV 10];
    generated_name.second (2) := digits [binary_name.second MOD 10];

    name := generated_name.value;

  PROCEND convert_binary_unique_name;
MODEND dmm$validate_sfid_with_gfn;
*DECK DECK=DMM$VOLUME_ATTRIBUTE_MANAGER EXPAND=TRUE

?? RIGHT := 110 ??
?? NEWTITLE := 'NOSVE Device Management' ??
MODULE dmm$volume_attribute_manager;
?? PUSH (LISTEXT := ON) ??
?? TITLE := '  XREF Decks' , EJECT ??
*copyc dmp$clear_update_lock
*copyc dmp$close_file
*copyc dmp$get_mat_pointer
*copyc dmp$lock_avt_entry
*copyc dmp$open_dat
*copyc dmp$search_active_volume_table
*copyc dmp$set_update_lock
*copyc dmp$unlock_avt_entry
*copyc dmp$verify_access
*copyc dmt$error_condition_codes
*copyc dmt$ms_active_vol_table_entry
*copyc dmt$volume_attributes
*copyc dmt$volume_attribute_info
*copyc dmv$active_volume_table
*copyc mmp$write_modified_pages
*copyc osp$fatal_system_error
*copyc osp$set_status_abnormal
?? POP ??

?? TITLE := '  dmp$change_volume_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$change_volume_attributes (logical_unit_number: iot$logical_unit;
        p_volume_attributes: ^dmt$volume_attributes;
    VAR status: ost$status);

    VAR
      able_to_lock_avt_entry: boolean,
      able_to_set_lock: boolean,
      able_to_unlock_avt_entry: boolean,
      avt_entry_not_found: boolean,
      avt_index: dmt$active_volume_table_index,
      cylinder_size: dmt$allocation_size,
      disk_table_status: dmt$ms_volume_table_status,
      index: integer,
      ok: boolean,
      p_dat: ^dmt$ms_device_allocation_table,
      p_mat: ^dmt$mainframe_allocation_table,
      search_avt_key: dmt$avt_search_key,
      volume_accessible: boolean;

    status.normal := TRUE;

    search_avt_key.value := dmc$search_avt_by_lun;
    search_avt_key.logical_unit_number := logical_unit_number;
    dmp$search_active_volume_table (search_avt_key, avt_index, avt_entry_not_found);
    IF avt_entry_not_found THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
          'Avt entry not found for logical unit', status);
      RETURN;
    IFEND;

    dmp$verify_access (avt_index, volume_accessible);
    IF NOT volume_accessible THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_unavailable,
          'Cannot access volume', status);
    IFEND;

    dmp$get_mat_pointer (avt_index, p_mat);

    dmp$open_dat (dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_allocation_table,
          osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_sequential, p_dat, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$open_dat_failure,
        'unable to open dat - dmp$change_volume_attributes', status);
      RETURN;
    IFEND;

    /dat_open/
      BEGIN

        dmp$set_update_lock (avt_index, FALSE, able_to_set_lock);
        IF NOT able_to_set_lock THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_lock_dat,
            'unable to lock dat - dmp$change_volume_attributes', status);
          EXIT /dat_open/;
        IFEND;

        IF p_volume_attributes <> NIL THEN
          FOR index := LOWERBOUND (p_volume_attributes^) TO UPPERBOUND (p_volume_attributes^) DO
            CASE p_volume_attributes^ [index].keyword OF
            = dmc$vol_default_allocation_size =
              IF p_volume_attributes^ [index].default_allocation_size <> 0 THEN
                IF p_volume_attributes^ [index].default_allocation_size = dmc$max_bytes_per_allocation THEN
                  cylinder_size := p_mat^.bytes_per_dau * p_mat^.daus_per_position;
                  p_dat^.header.default_allocation_size := cylinder_size;
                  p_mat^.default_allocation_size := cylinder_size;
                ELSE
                  p_dat^.header.default_allocation_size := p_volume_attributes^ [index].
                            default_allocation_size;
                  p_mat^.default_allocation_size := p_volume_attributes^ [index].default_allocation_size;
                IFEND;
              IFEND;
            = dmc$vol_default_transfer_size =
              IF p_volume_attributes^ [index].default_transfer_size <> 0 THEN
                IF p_volume_attributes^ [index].default_transfer_size = dmc$max_transfer_size THEN
                  cylinder_size := p_mat^.bytes_per_dau * p_mat^.daus_per_position;
                  p_dat^.header.default_transfer_size := cylinder_size;
                  p_mat^.default_transfer_size := cylinder_size;
                ELSE
                  p_dat^.header.default_transfer_size := p_volume_attributes^ [index].default_transfer_size;
                  p_mat^.default_transfer_size := p_volume_attributes^ [index].default_transfer_size;
                IFEND;
              IFEND;
            ELSE
            CASEND;
          FOREND;
        IFEND;

        mmp$write_modified_pages (p_dat, #size (p_dat^), osc$wait, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_change_vol_attr,
            'Unable to change volume attribute(s) - dmp$change_volume_attributes', status);
        IFEND;

        dmp$clear_update_lock (avt_index);
      END /dat_open/;

      dmp$close_file (p_dat, status);
      IF NOT status.normal THEN
        osp$fatal_system_error ('Unable to close DAT - dmp$change_volume_attributes', ^status);  {Necessary?
      IFEND;

  PROCEND dmp$change_volume_attributes;
?? TITLE := '  dmp$get_volume_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$get_volume_attributes (logical_unit_number: iot$logical_unit;
    VAR volume_attribute_info: dmt$volume_attribute_info;
    VAR status: ost$status);

    VAR
      avt_entry_not_found: boolean,
      avt_index: dmt$active_volume_table_index,
      p_mat: ^dmt$mainframe_allocation_table,
      search_avt_key: dmt$avt_search_key;

    status.normal := TRUE;

    search_avt_key.value := dmc$search_avt_by_lun;
    search_avt_key.logical_unit_number := logical_unit_number;
    dmp$search_active_volume_table (search_avt_key, avt_index, avt_entry_not_found);
    IF avt_entry_not_found THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
          'Avt entry not found for logical unit', status);
      RETURN;
    IFEND;

    dmp$get_mat_pointer (avt_index, p_mat);

    IF (p_mat = NIL) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$avt_entry_not_found,
          'Avt entry not found for logical unit', status);
      RETURN;
    IFEND;

    volume_attribute_info.default_allocation_size := p_mat^.default_allocation_size;
    volume_attribute_info.default_transfer_size := p_mat^.default_transfer_size;

  PROCEND dmp$get_volume_attributes;

MODEND dmm$volume_attribute_manager;
*DECK DECK=DMM$VOLUME_ONLINE EXPAND=TRUE
?? RIGHT := 110 ??
*copy osd$default_pragmats
?? NEWTITLE := 'NOS/VE Device Management' ??
?? NEWTITLE := '  Declarations' ??
MODULE dmm$volume_online;

{ PURPOSE:
{  The purpose of this module is to bring a volume online/offline.  A
{  volume is brought offline by removing it from the Active Volume Table.  A
{  volume is brought online by registering it in the Active Volume Table.
{  Two versions of volume online exist.  One to introduce the volume
{  to a mainframe, and allow the mainframe to log in to the volume, the
{  other is to allow the volume to be initialized.  The volumes must be
{  brought offline using corresponding requests.  This module executes
{  in ring 1.

?? PUSH (LISTEXT := ON) ??
?? TITLE := '  Common Decks', EJECT ??
*copyc dmp$attach_dat_from_label
*copyc dmp$attach_dflt_from_label
*copyc dmp$attach_directory_from_label
*copyc dmp$attach_volume_device_file
*copyc dmp$create_mat
*copyc dmp$create_mfl
*copyc dmp$delete_mat
*copyc dmp$delete_mfl
*copyc dmp$destroy_file
*copyc dmp$detach_device_file
*copyc dmp$get_unused_avt_entry
*copyc dmp$locate_volume_label
*copyc dmp$lock_avt_entry
*copyc dmp$search_active_volume_table
*copyc dmp$unlock_avt_entry
*copyc dmt$active_volume_table_index
*copyc dmt$error_condition_codes
*copyc dmt$ms_labels
*copyc dmt$ms_volume_label
*copyc dmt$physical_device_attributes
*copyc dmv$active_volume_table
*copyc dmv$debug_options
*copyc dmv$null_sfid
*copyc dpp$put_critical_message
*copyc lgp$add_entry_to_system_log
*copyc osp$fatal_system_error
*copyc osp$initialize_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$unpack_status_condition
*copyc ost$status
*copyc ost$wait
*copyc rmd$volume_declarations
*copyc stt$set_ordinal
?? POP ??
?? TITLE := '  dmp$volume_online', EJECT ??
*copy dmh$volume_online

  PROCEDURE [XDCL, #GATE] dmp$volume_online (logical_unit_number: iot$logical_unit;
        p_physical_attributes: ^dmt$physical_device_attributes;
    VAR status: ost$status);

    VAR
      able_to_locate_vol_label: boolean,
      able_to_lock_avt_entry: boolean,
      avt_entry_found: boolean,
      avt_index: dmt$active_volume_table_index,
      avt_lock_cleared: boolean,
      online: boolean,
      p_volume_label: ^dmt$ms_volume_label,
      p_volume_label_header: ^dmt$volume_label_header,
      search_avt_key: dmt$avt_search_key,
      volume_not_active: boolean;

    status.normal := TRUE;

    dmp$volume_is_online (logical_unit_number, online);
    IF online THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_already_online,
        'Volume already online - dmp$volume_online', status);
      RETURN;
    IFEND;

  /volume_online/
    BEGIN

      PUSH p_volume_label: [[REP dmc$max_volume_label_size OF cell]];
      RESET p_volume_label;

      dmp$locate_volume_label (logical_unit_number, p_physical_attributes, p_volume_label^,
            able_to_locate_vol_label);
      IF NOT able_to_locate_vol_label THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_label,
          'Unable to find label - dmp$volume_online', status);
        EXIT /volume_online/;
      IFEND;

      RESET p_volume_label;

      NEXT p_volume_label_header IN p_volume_label;

      search_avt_key.value := dmc$search_avt_by_rec_vsn;
      search_avt_key.recorded_vsn := p_volume_label_header^.recorded_vsn;

      dmp$search_active_volume_table (search_avt_key, avt_index, volume_not_active);
      IF volume_not_active THEN
        dmp$get_unused_avt_entry (avt_index, avt_entry_found);
        IF avt_entry_found THEN
          dmp$lock_avt_entry (avt_index, able_to_lock_avt_entry);
          IF NOT able_to_lock_avt_entry THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_lock_avt_entry,
              'Unable to lock AVT entry - dmp$volume_online', status);
            EXIT /volume_online/;
          IFEND;

        /avt_entry_locked/
          BEGIN
            create_new_ms_avt_entry (p_volume_label^, logical_unit_number, avt_index, status);
          END /avt_entry_locked/;

          dmp$unlock_avt_entry (avt_index, avt_lock_cleared);
          IF NOT avt_lock_cleared AND status.normal THEN
            osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_clear_avt_lock,
              'Unable to release AVT entry lock - dmp$volume_online', status);
          IFEND;
        ELSE
          osp$set_status_abnormal (dmc$device_manager_ident, dme$no_free_avt_entry,
            'Unable to get free AVT entry - dmp$volume_online', status);
        IFEND;
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_already_active,
          'Volume already in AVT - dmp$volume_online', status);
      IFEND;

    END /volume_online/;

  PROCEND dmp$volume_online;
?? TITLE := '  create_new_ms_avt_entry', EJECT ??

  PROCEDURE create_new_ms_avt_entry (volume_label: dmt$ms_volume_label;
        logical_unit_number: iot$logical_unit;
        avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      dmv$volume_class_kludge: [XREF] boolean,
      identifier: ost$status_identifier,
      number: ost$status_condition_number,
      s: string (60),
      l: integer,
      log_status: ost$status,
      logtime: ost$time,
      file_modified: boolean,
      fmd_modified: boolean,
      p_volume_label: ^dmt$ms_volume_label,
      p_volume_label_header: ^dmt$volume_label_header,
      p_volume_label_0_0: ^dmt$ms_label_0_0,
      dat_sfid: dmt$system_file_id,
      dfl_sfid: dmt$system_file_id,
      p_mat: cyt$adaptable_array_pointer,
      login_table_sfid: dmt$system_file_id,
      login_table_name: ost$name,
      create_status: ost$status;

    status.normal := TRUE;
    s (1, * ) := ' ';

    p_volume_label := ^volume_label;
    RESET p_volume_label;

    NEXT p_volume_label_header IN p_volume_label;
    NEXT p_volume_label_0_0 IN p_volume_label;

    dmv$p_active_volume_table^ [avt_index].logical_unit_number := logical_unit_number;

    IF (avt_index = 1) {system device} THEN
      {Allocation is done on the system device before it is activated.  This bad
      {practice should be eliminated if we can ever figure out how.
      dmv$p_active_volume_table^ [avt_index].mass_storage.allocation_allowed := TRUE;
    ELSE
      {Wait for volume activation to allow allocation on other devices.
      dmv$p_active_volume_table^ [avt_index].mass_storage.allocation_allowed := FALSE;
    IFEND;

    dmv$p_active_volume_table^ [avt_index].mass_storage.space_low := FALSE;
    dmv$p_active_volume_table^ [avt_index].mass_storage.space_gone := FALSE;
    dmv$p_active_volume_table^ [avt_index].mass_storage.disk_table_status := $dmt$ms_volume_table_status [];
    dmv$p_active_volume_table^ [avt_index].mass_storage.class :=
      p_volume_label_0_0^.class;
    IF dmv$volume_class_kludge THEN
      dmv$p_active_volume_table^ [avt_index].mass_storage.class := -$dmt$class [];
    IFEND;
    dmv$p_active_volume_table^ [avt_index].mass_storage.logged_in_for_recovery := FALSE;
    dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn := p_volume_label_header^.recorded_vsn;
    dmv$p_active_volume_table^ [avt_index].mass_storage.internal_vsn := p_volume_label_header^.internal_vsn;
    dmv$p_active_volume_table^ [avt_index].mass_storage.volume_owner := p_volume_label_0_0^.owner_id;
    dmv$p_active_volume_table^ [avt_index].mass_storage.current_position_offset_in_log := 0;

    osp$initialize_sig_lock (dmv$p_active_volume_table^ [avt_index].mass_storage.update_lock);

    osp$initialize_sig_lock (dmv$p_active_volume_table^ [avt_index].mass_storage.logging_lock);

    dmv$p_active_volume_table^ [avt_index].mass_storage.set_name := osc$null_name;
    dmv$p_active_volume_table^ [avt_index].mass_storage.status := $dmt$ms_volume_system_status
          [dmc$system_dismounted, dmc$mainframe_dismounted];

    attach_device_files (avt_index, volume_label, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /device_files_attached/
    BEGIN
      dat_sfid := dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_allocation_table;
      dfl_sfid := dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_file_list_table;

      dmp$create_mfl (dmv$p_active_volume_table^ [avt_index].mass_storage.p_mfl);

      dmp$create_mat (avt_index, dat_sfid, p_mat, status);
      IF NOT status.normal THEN
        EXIT /device_files_attached/;
      IFEND;

      dmv$p_active_volume_table^ [avt_index].mass_storage.p_mat := p_mat;

      dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log := dmv$null_sfid;

      login_table_name := 'LOGIN_TABLE';
      login_table_name (12, rmc$recorded_vsn_size) := dmv$p_active_volume_table^ [avt_index].mass_storage.
            recorded_vsn;

      dmp$attach_volume_device_file (login_table_name, dmv$p_active_volume_table^ [avt_index].mass_storage.
            p_directory, dfl_sfid, dat_sfid, avt_index, login_table_sfid, status);
      IF NOT status.normal THEN
        EXIT /device_files_attached/;
      IFEND;

      dmv$p_active_volume_table^ [avt_index].mass_storage.p_login_table := login_table_sfid;

      dmv$p_active_volume_table^ [avt_index].mass_storage.status := dmv$p_active_volume_table^ [avt_index].
            mass_storage.status + $dmt$ms_volume_system_status [dmc$system_mounted];
      dmv$p_active_volume_table^ [avt_index].mass_storage.status := dmv$p_active_volume_table^ [avt_index].
            mass_storage.status - $dmt$ms_volume_system_status [dmc$system_dismounted];

      RETURN;

      dmp$detach_device_file (login_table_sfid, file_modified, fmd_modified, create_status);

      dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log := dmv$null_sfid;

    END /device_files_attached/;

    dmp$detach_device_file (dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_allocation_table,
          file_modified, fmd_modified, create_status);

    dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_allocation_table := dmv$null_sfid;

    dmp$detach_device_file (dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_file_list_table,
          file_modified, fmd_modified, create_status);

    dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_file_list_table := dmv$null_sfid;

    dmp$detach_device_file (dmv$p_active_volume_table^ [avt_index].mass_storage.p_directory, file_modified,
          fmd_modified, create_status);

    dmv$p_active_volume_table^ [avt_index].mass_storage.p_directory := dmv$null_sfid;

  PROCEND create_new_ms_avt_entry;
?? TITLE := '  attach_device_files', EJECT ??

  PROCEDURE attach_device_files (avt_index: dmt$active_volume_table_index;
        volume_label: dmt$ms_volume_label;
    VAR status: ost$status);

    VAR
      identifier: ost$status_identifier,
      number: ost$status_condition_number,
      s: string (60),
      l: integer,
      log_status: ost$status,
      logtime: ost$time,
      file_modified: boolean,
      fmd_modified: boolean,
      directory_sfid: dmt$system_file_id,
      dat_sfid: dmt$system_file_id,
      dflt_sfid: dmt$system_file_id,
      attach_status: ost$status;

    status.normal := TRUE;
    s (1, * ) := ' ';

    dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_allocation_table := dmv$null_sfid;

    dmp$attach_dat_from_label (volume_label, avt_index, dat_sfid, status);
    IF NOT status.normal THEN
      osp$unpack_status_condition (status.condition, identifier, number);
      STRINGREP (s, l, ' DM: CANT ATTACH DAT AVT ', avt_index, ' ',
            identifier, number);
      dpp$put_critical_message (s, log_status);
      dpp$put_critical_message (status.text.value (1, status.text.size), log_status);
      lgp$add_entry_to_system_log (pmc$msg_origin_system, s, logtime, log_status);
      lgp$add_entry_to_system_log (pmc$msg_origin_system, status.text.value (1, status.text.size), logtime,
            log_status);
      RETURN;
    IFEND;

    dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_allocation_table := dat_sfid;

  /dat_attached/
    BEGIN

      dmv$p_active_volume_table^ [avt_index].mass_storage.p_directory := dmv$null_sfid;

      dmp$attach_directory_from_label (volume_label, dat_sfid, directory_sfid, status);
      IF NOT status.normal THEN
        osp$unpack_status_condition (status.condition, identifier, number);
        STRINGREP (s, l, ' DM: CANT ATTACH DIRECTORY  AVT ', avt_index, ' ',
              identifier, number);
        dpp$put_critical_message (s, log_status);
        dpp$put_critical_message (status.text.value (1, status.text.size), log_status);
        lgp$add_entry_to_system_log (pmc$msg_origin_system, s, logtime, log_status);
        lgp$add_entry_to_system_log (pmc$msg_origin_system, status.text.value (1, status.text.size), logtime,
              log_status);
        EXIT /dat_attached/;
      IFEND;

      dmv$p_active_volume_table^ [avt_index].mass_storage.p_directory := directory_sfid;

    /directory_attached/
      BEGIN

        dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_file_list_table := dmv$null_sfid;

        dmp$attach_dflt_from_label (volume_label, dat_sfid, dflt_sfid, status);
        IF NOT status.normal THEN
          osp$unpack_status_condition (status.condition, identifier, number);
          STRINGREP (s, l, ' DM: CANT ATTACH DFLT AVT ', avt_index, ' ',
                identifier, number);
          dpp$put_critical_message (s, log_status);
          dpp$put_critical_message (status.text.value (1, status.text.size), log_status);
          lgp$add_entry_to_system_log (pmc$msg_origin_system, s, logtime, log_status);
          lgp$add_entry_to_system_log (pmc$msg_origin_system, status.text.value (1, status.text.size),
                logtime, log_status);
          EXIT /directory_attached/;
        IFEND;

        dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_file_list_table := dflt_sfid;

        RETURN;
      END /directory_attached/;

      dmp$detach_device_file (directory_sfid, file_modified, fmd_modified, attach_status);

      dmv$p_active_volume_table^ [avt_index].mass_storage.p_directory := dmv$null_sfid;

    END /dat_attached/;

    dmp$detach_device_file (dat_sfid, file_modified, fmd_modified, attach_status);

    dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_allocation_table := dmv$null_sfid;

  PROCEND attach_device_files;
?? TITLE := '  detach_device_files', EJECT ??
{
{   The purpose of this request is to detach any of the volume device files
{ that are still attached.  Any bad status from the detach is ignored, unless
{ debug_device_manager is turned on.

  PROCEDURE detach_device_files (
        avt_index: dmt$active_volume_table_index);

    VAR
      file_modified: boolean,
      fmd_modified: boolean,
      sfid: dmt$system_file_id,
      status: ost$status;

    { Detach or destroy device log. }

    sfid := dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log;
    IF (sfid <> dmv$null_sfid) THEN
      IF dmv$p_active_volume_table^ [avt_index].mass_storage.logged_in_for_recovery THEN
        dmp$destroy_file (sfid, sfc$no_limit, status);
      ELSE
        dmp$detach_device_file (sfid, file_modified, fmd_modified, status);
      IFEND;
      IF status.normal THEN
        dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_log := dmv$null_sfid;
      ELSEIF (dmc$debug_device_manager IN dmv$debug_options) THEN
        osp$fatal_system_error ('Detach or destroy device log failed - detach_device_files', ^status);
      IFEND;
    IFEND;

    { Detach login table. }

    sfid := dmv$p_active_volume_table^ [avt_index].mass_storage.p_login_table;
    IF (sfid <> dmv$null_sfid) THEN
      dmp$detach_device_file (sfid, file_modified, fmd_modified, status);
      IF status.normal THEN
        dmv$p_active_volume_table^ [avt_index].mass_storage.p_login_table := dmv$null_sfid;
      ELSEIF (dmc$debug_device_manager IN dmv$debug_options) THEN
        osp$fatal_system_error ('Detach login table failed - detach_device_files', ^status);
      IFEND;
    IFEND;

    { Detach DFL. }

    sfid := dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_file_list_table;
    IF (sfid <> dmv$null_sfid) THEN
      dmp$detach_device_file (sfid, file_modified, fmd_modified, status);
      IF status.normal THEN
        dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_file_list_table := dmv$null_sfid;
      ELSEIF (dmc$debug_device_manager IN dmv$debug_options) THEN
        osp$fatal_system_error ('Detach DFL failed - detach_device_files', ^status);
      IFEND;
    IFEND;

    { Detach directory. }

    sfid := dmv$p_active_volume_table^ [avt_index].mass_storage.p_directory;
    IF (sfid <> dmv$null_sfid) THEN
      dmp$detach_device_file (sfid, file_modified, fmd_modified, status);
      IF status.normal THEN
        dmv$p_active_volume_table^ [avt_index].mass_storage.p_directory := dmv$null_sfid;
      ELSEIF (dmc$debug_device_manager IN dmv$debug_options) THEN
        osp$fatal_system_error ('Detach directory failed - detach_device_files', ^status);
      IFEND;
    IFEND;

    { Detach DAT. }

    sfid := dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_allocation_table;
    IF (sfid <> dmv$null_sfid) THEN
      dmp$detach_device_file (sfid, file_modified, fmd_modified, status);
      IF status.normal THEN
        dmv$p_active_volume_table^ [avt_index].mass_storage.p_device_allocation_table := dmv$null_sfid;
      ELSEIF (dmc$debug_device_manager IN dmv$debug_options) THEN
        osp$fatal_system_error ('Detach DAT failed - detach_device_files', ^status);
      IFEND;
    IFEND;
  PROCEND detach_device_files;
?? TITLE := '  dmp$bring_volume_online', EJECT ??

  PROCEDURE [XDCL] dmp$bring_volume_online (logical_unit_number: iot$logical_unit;
    VAR avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

    VAR
      avt_entry_found: boolean,
      able_to_lock_avt_entry: boolean,
      avt_lock_cleared: boolean,
      search_avt_key: dmt$avt_search_key,
      volume_not_active: boolean;

    status.normal := TRUE;

    search_avt_key.value := dmc$search_avt_by_lun;
    search_avt_key.logical_unit_number := logical_unit_number;

    dmp$search_active_volume_table (search_avt_key, avt_index, volume_not_active);
    IF volume_not_active THEN
      dmp$get_unused_avt_entry (avt_index, avt_entry_found);
      IF avt_entry_found THEN
        dmp$lock_avt_entry (avt_index, able_to_lock_avt_entry);
        IF NOT able_to_lock_avt_entry THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_lock_avt_entry,
            'unable to lock avt entry - DMMVONL', status);
          RETURN;
        IFEND;

      /avt_entry_locked/
        BEGIN
          dmv$p_active_volume_table^ [avt_index].logical_unit_number := logical_unit_number;
        END /avt_entry_locked/;

        dmp$unlock_avt_entry (avt_index, avt_lock_cleared);
        IF NOT avt_lock_cleared AND status.normal THEN
          osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_clear_avt_lock,
            'unable to release avt entry lock - DMMVONL', status);
        IFEND;
      ELSE
        osp$set_status_abnormal (dmc$device_manager_ident, dme$no_free_avt_entry,
          'unable to get free avt entry - DMMVONL', status);
      IFEND;
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_already_online,
        'volume already online - DMMVONL', status);
    IFEND;
  PROCEND dmp$bring_volume_online;
?? TITLE := '  [XDCL] dmp$take_volume_offline', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$take_volume_offline (
        logical_unit_number: iot$logical_unit;
    VAR status: ost$status);

    VAR
      avt_entry_found: boolean,
      able_to_lock_avt_entry: boolean,
      avt_lock_cleared: boolean,
      search_avt_key: dmt$avt_search_key,
      avt_index: dmt$active_volume_table_index,
      volume_not_active: boolean;

    status.normal := TRUE;

    search_avt_key.value := dmc$search_avt_by_lun;
    search_avt_key.logical_unit_number := logical_unit_number;

    dmp$search_active_volume_table (search_avt_key, avt_index, volume_not_active);
    IF NOT volume_not_active THEN
      dmp$lock_avt_entry (avt_index, able_to_lock_avt_entry);
      IF NOT able_to_lock_avt_entry THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_lock_avt_entry,
          'unable to lock avt entry - DMMVONL', status);
        RETURN;
      IFEND;

    /avt_entry_locked/
      BEGIN
        detach_device_files (avt_index);
        dmp$delete_mat (dmv$p_active_volume_table^ [avt_index].mass_storage.p_mat);
        dmp$delete_mfl (dmv$p_active_volume_table^ [avt_index].mass_storage.p_mfl);
        dmv$p_active_volume_table^ [avt_index].entry_available := TRUE;
        dmv$p_active_volume_table^ [avt_index].logical_unit_number := 0;
      END /avt_entry_locked/;

      dmp$unlock_avt_entry (avt_index, avt_lock_cleared);
      IF NOT avt_lock_cleared AND status.normal THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_clear_avt_lock,
          'unable to release avt entry lock - DMMVONL', status);
      IFEND;
    ELSE
      osp$set_status_abnormal (dmc$device_manager_ident, dme$unable_to_locate_avt_entry,
        'unable to find avt entry by lun - DMMVONL', status);
    IFEND;
  PROCEND dmp$take_volume_offline;

?? TITLE := '  dmp$volume_is_online', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$volume_is_online (logical_unit_number: iot$logical_unit;
                                            VAR volume_online: boolean);

    VAR
      search_avt_key: dmt$avt_search_key,
      avt_index: dmt$active_volume_table_index,
      volume_not_active: boolean;

    avt_index := 0;
    volume_online := FALSE;
    search_avt_key.value := dmc$search_avt_by_lun;
    search_avt_key.logical_unit_number := logical_unit_number;

    dmp$search_active_volume_table (search_avt_key, avt_index, volume_not_active);
    IF volume_not_active THEN
      RETURN;
    IFEND;

    volume_online := TRUE;

  PROCEND dmp$volume_is_online;
MODEND dmm$volume_online;
*DECK DECK=DMM$VOLUME_UP_DOWN EXPAND=TRUE
MODULE dmm$volume_up_down;
?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc dmp$search_active_volume_table
*copyc dmv$active_volume_table
*copyc dmv$number_unavailable_volumes
*copyc mtp$step_unstep_system
*copyc rmc$mass_storage_class
*copyc iot$logical_unit
*copyc jmp$resurrect_dead_jobs
*copyc mmp$volume_available
?? POP ??

?? EJECT ??
  PROCEDURE [XDCL] dmp$volume_up
    (    lun: iot$logical_unit);

    VAR
      avti: dmt$active_volume_table_index,
      search: dmt$avt_search_key,
      not_found: boolean;

    search.value := dmc$search_avt_by_lun;
    search.logical_unit_number := lun;
    dmp$search_active_volume_table (search, avti, not_found);

    IF not_found THEN
      RETURN;
    IFEND;

    jmp$resurrect_dead_jobs;
    mmp$volume_available;

    IF dmv$p_active_volume_table^ [avti].mass_storage.volume_unavailable = FALSE THEN
      {Ignore request - already up
      RETURN;
    IFEND;

    dmv$number_unavailable_volumes := dmv$number_unavailable_volumes - 1;
    dmv$p_active_volume_table^ [avti].mass_storage.volume_unavailable := FALSE;
    dmv$p_active_volume_table^ [avti].mass_storage.allocation_allowed :=
      dmv$p_active_volume_table^ [avti].mass_storage.previous_allocation_allowed;

  PROCEND dmp$volume_up;

?? EJECT ??
  PROCEDURE [XDCL] dmp$volume_down
    (    lun: iot$logical_unit;
         VAR critical: boolean);

    VAR
      avti: dmt$active_volume_table_index,
      class: dmt$class,
      search: dmt$avt_search_key,
      st: string (72),
      system_set: boolean,
      not_found: boolean;

    critical := FALSE;

    search.value := dmc$search_avt_by_lun;
    search.logical_unit_number := lun;
    dmp$search_active_volume_table (search, avti, not_found);

    IF not_found THEN
      RETURN;
    IFEND;

    {Step if critical device down; allow unstep

    system_set := dmv$p_active_volume_table^ [avti].mass_storage.set_name =
                    dmv$p_active_volume_table^ [1].mass_storage.set_name;
    class := dmv$p_active_volume_table^ [avti].mass_storage.class;

    IF (rmc$msc_system_critical_files IN class) OR ((rmc$msc_system_catalogs IN class) AND system_set) THEN
      st := 'ERR=VEOS9300-A critical device has gone down: ';
      st (47, *) := dmv$p_active_volume_table^ [avti].mass_storage.recorded_vsn;
      mtp$step_unstep_system (syc$ic_disk_error, st);
      critical := TRUE;
      RETURN;
    IFEND;

    IF dmv$p_active_volume_table^ [avti].mass_storage.volume_unavailable = TRUE THEN
      {Ignore request - already down
      RETURN;
    IFEND;

    dmv$number_unavailable_volumes := dmv$number_unavailable_volumes + 1;
    dmv$p_active_volume_table^ [avti].mass_storage.volume_unavailable := TRUE;
    dmv$p_active_volume_table^ [avti].mass_storage.previous_allocation_allowed :=
      dmv$p_active_volume_table^ [avti].mass_storage.allocation_allowed;
    dmv$p_active_volume_table^ [avti].mass_storage.allocation_allowed := FALSE;

  PROCEND dmp$volume_down;

?? EJECT ??
  PROCEDURE [XDCL] dmp$get_recorded_vsn
    (    lun: iot$logical_unit;
         VAR recorded_vsn: rmt$recorded_vsn);

    VAR
      avti: dmt$active_volume_table_index,
      search: dmt$avt_search_key,
      not_found: boolean;

    search.value := dmc$search_avt_by_lun;
    search.logical_unit_number := lun;
    dmp$search_active_volume_table (search, avti, not_found);

    IF not_found THEN
      recorded_vsn := '******';
      RETURN;
    IFEND;

    recorded_vsn := dmv$p_active_volume_table^ [avti].mass_storage.recorded_vsn;

  PROCEND dmp$get_recorded_vsn;
MODEND dmm$volume_up_down
*DECK DECK=DMP$ACQUIRE_TAPE_RESOURCE EXPAND=FALSE

  PROCEDURE [XREF] dmp$acquire_tape_resource
    (    reservation: rmt$tape_reservation;
     VAR reserve_complete: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$tape_reservation
?? POP ??
*DECK DECK=DMP$ACTIVATE_VOLUME EXPAND=FALSE

  PROCEDURE [XREF] dmp$activate_volume ALIAS 'dmxavol' (logical_unit_number:
    iot$logical_unit;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$ADD_CLASS_TO_VOLUME EXPAND=FALSE

  PROCEDURE [XREF] dmp$add_class_to_volume (
        avt_index: dmt$active_volume_table_index;
        class: dmt$class;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc dmt$class
*copyc ost$status
?? POP ??
*DECK DECK=DMP$ADD_TO_SORTED_DFL EXPAND=FALSE
  PROCEDURE [XREF] dmp$add_to_sorted_dfl (lun: iot$logical_unit;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc ost$status
?? POP ??
*DECK DECK=DMP$ADMINISTER_ALLOCATION_LOG EXPAND=FALSE
*DECK DECK=DMP$ADMINISTER_DEVICE_LOG EXPAND=FALSE
*DECK DECK=DMP$ADVANCE_TAPE_VOLUME EXPAND=FALSE

  PROCEDURE [XREF] dmp$advance_tape_volume
    (    sfid: gft$system_file_identifier;
         extend: boolean;
         label_type: amt$label_type;
         access_mode: pft$usage_selections;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$label_type
*copyc gft$system_file_identifier
*copyc OST$STATUS
*copyc pfd$permanent_file_attributes
?? POP ??
*DECK DECK=DMP$ALLOCATE_AVT EXPAND=FALSE

  PROCEDURE [XREF] dmp$allocate_avt (avt_count: integer;
    VAR allocate_ok: boolean);

*DECK DECK=DMP$ALLOCATE_FILE_SPACE EXPAND=FALSE

  PROCEDURE [XREF] dmp$allocate_file_space
    (    p_fde: gft$locked_file_desc_entry_p;
         initial_byte_address: amt$file_byte_address;
         bytes_to_allocate: amt$file_byte_address;
         file_space_limit: sft$file_space_limit_kind;
     VAR allocation_units_obtained: amt$file_byte_address;
     VAR overflow_indicator: boolean;
     VAR file_allocation_status: dmt$file_allocation_status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmt$file_allocation_status
*copyc gft$locked_file_desc_entry_p
*copyc sft$file_space_limit_kind
?? POP ??
*DECK DECK=DMP$ALLOCATE_FILE_SPACE_R1 EXPAND=FALSE

  PROCEDURE [XREF] dmp$allocate_file_space_r1 ALIAS 'dmxaspa' (system_file_id:
    dmt$system_file_id;
        byte_address: amt$file_byte_address;
        number_bytes_to_allocate: amt$file_byte_address;
        chapter_number: dmt$chapter_number;
        wait_option: ost$wait;
        file_space_limit: sft$file_space_limit_kind;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc DMT$CHAPTER_NUMBER
*copyc DMT$SYSTEM_FILE_ID
*copyc OST$WAIT
*copyc OST$STATUS
*copyc SFT$FILE_SPACE_LIMIT_KIND
  ?? POP ??
*DECK DECK=DMP$ANALYZE_DAT_POSITION EXPAND=FALSE
  PROCEDURE [XREF] dmp$analyze_dat_position (
        p_dat: ^dmt$ms_device_allocation_table;
        position: dmt$device_position;
    VAR allocation_style: dmt$allocation_styles;
    VAR dau_status_counts: dmt$dau_status_counts);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$ms_device_allocation_table
*copyc dmt$device_position
*copyc dmt$allocation_size
?? POP ??
*DECK DECK=DMP$ASSIGN_TAPE_VOLUME EXPAND=FALSE

  PROCEDURE [XREF] dmp$assign_tape_volume (
        system_file_id: gft$system_file_identifier;
        path_handle_name: fst$path_handle_name;
        label_type: amt$label_type;
        access_mode: pft$usage_selections;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$label_type
*copyc fst$path_handle_name
*copyc gft$system_file_identifier
*copyc ost$status
*copyc pfd$permanent_file_attributes
?? POP ??
*DECK DECK=DMP$ATTACH_DAT_FROM_LABEL EXPAND=FALSE

  PROCEDURE [XREF] dmp$attach_dat_from_label (volume_label: dmt$ms_volume_label;
                                              avt_index: dmt$active_volume_table_index;
                                          VAR dat_sfid: dmt$system_file_id;
                                          VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc DMT$MS_VOLUME_LABEL
*copyc DMT$SYSTEM_FILE_ID
*copyc OST$STATUS
  ?? POP ??
*DECK DECK=DMP$ATTACH_DEVICE_FILE EXPAND=FALSE

  PROCEDURE [XREF] dmp$attach_device_file ALIAS 'dmxatdf' (recorded_vsn:
    rmt$recorded_vsn;
    user_supplied_df_name: ost$name;
    VAR system_file_id: dmt$system_file_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc OST$NAME
*copyc DMT$SYSTEM_FILE_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$ATTACH_DEVICE_FILE_BY_FMD EXPAND=FALSE

  PROCEDURE [XREF] dmp$attach_device_file_by_fmd
    (global_file_name: dmt$global_file_name;
    device_file_stored_fmd: dmt$device_file_stored_fmd;
    VAR file_already_attached: boolean;
    VAR system_file_id: dmt$system_file_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$device_file_stored_fmd
*copyc dmt$global_file_name
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??
*DECK DECK=DMP$ATTACH_DFLT_FROM_LABEL EXPAND=FALSE

  PROCEDURE [XREF] dmp$attach_dflt_from_label ALIAS 'dmxadfl' (volume_label:
    dmt$ms_volume_label;
    dat_sfid: dmt$system_file_id;
    VAR dflt_sfid: dmt$system_file_id;
    VAR statsus: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc DMT$MS_VOLUME_LABEL
*copyc DMT$SYSTEM_FILE_ID
*copyc OST$STATUS
  ?? POP ??
*DECK DECK=DMP$ATTACH_DIRECTORY_FROM_LABEL EXPAND=FALSE
      PROCEDURE [XREF] dmp$attach_directory_from_label ALIAS 'dmxadil' (
             volume_label:dmt$ms_volume_label;
             dat_sfid:dmt$system_file_id;
             VAR directory_sfid:dmt$system_file_id;
             VAR status:ost$status);
      ??PUSH(list:=off)??
*copyc DMT$MS_VOLUME_LABEL
*copyc DMT$SYSTEM_FILE_ID
*copyc OST$STATUS
      ??POP??
*DECK DECK=DMP$ATTACH_FILE EXPAND=FALSE

  PROCEDURE [XREF] dmp$attach_file
    (    global_file_name: dmt$global_file_name;
         file_kind: gft$file_kind;
         stored_fmd: dmt$stored_fmd;
         file_usage: pft$usage_selections;
         file_share_selections: pft$share_selections;
         file_history: dmt$file_share_history;
         file_limit: amt$file_limit;
         restricted_attach: boolean;
         exit_on_unknown_file: boolean;
         server_file: boolean;
         shared_queue: mmt$shared_queue;
     VAR file_damaged: boolean;
     VAR system_file_id: gft$system_file_identifier;
     VAR existing_sft_entry: dmt$existing_sft_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
*copyc dmt$existing_sft_entry
*copyc dmt$file_share_history
*copyc dmt$global_file_name
*copyc dmt$stored_fmd
*copyc gft$file_kind
*copyc gft$system_file_identifier
*copyc mmt$shared_queue
*copyc ost$status
*copyc pfd$permanent_file_attributes
?? POP ??
*DECK DECK=DMP$ATTACH_VOLUME_DEVICE_FILE EXPAND=FALSE
 PROCEDURE [XREF] dmp$attach_volume_device_file (user_supplied_name: ost$name;
        directory_sfid: dmt$system_file_id;
        dflt_sfid: dmt$system_file_id;
        dat_sfid: dmt$system_file_id;
        avt_index: dmt$active_volume_table_index;
    VAR system_file_id: dmt$system_file_id;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc dmt$active_volume_table_index
*copyc ost$name
*copyc ost$status
  ?? POP ??
*DECK DECK=DMP$BRING_VOLUME_ONLINE EXPAND=FALSE
 PROCEDURE [XREF] dmp$bring_volume_online (logical_unit_number:
  iot$logical_unit;
    VAR avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc dmt$active_volume_table_index
*copyc ost$status
  ?? POP ??
*DECK DECK=DMP$BUILD_DEVICE_ADDRESS EXPAND=FALSE
*DECK DECK=DMP$BUILD_FAUS_FROM_DFL_ENTRY EXPAND=FALSE
  PROCEDURE [XREF] dmp$build_faus_from_dfl_entry
    (    dat_sfid: gft$system_file_identifier;
         dfl_entry: dmt$ms_device_file_list_entry;
         p_fmd: ^dmt$file_medium_descriptor;
         p_dfd: ^dmt$disk_file_descriptor;
         p_mat: ^dmt$mainframe_allocation_table;
         system_file_id: gft$system_file_identifier;
         fmd_index: dmt$fmd_index;
     VAR file_flawed: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$disk_file_descriptor
*copyc dmt$file_medium_descriptor
*copyc dmt$mainframe_allocation_table
*copyc dmt$ms_device_file_list_entry
*copyc gft$system_file_identifier
*copyc ost$status
  ?? POP ??
*DECK DECK=DMP$BUILD_FMD_FOR_EXISTING_FILE EXPAND=FALSE

  PROCEDURE [XREF] dmp$build_fmd_for_existing_file
    (    p_fde: gft$file_desc_entry_p;
         p_dfd: ^dmt$disk_file_descriptor;
         system_file_id: gft$system_file_identifier;
     VAR file_damaged: boolean;
     VAR file_flawed: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$disk_file_descriptor
*copyc gft$file_desc_entry_p
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=DMP$BUILD_SORTED_DFL EXPAND=FALSE

  PROCEDURE [XREF] dmp$build_sorted_dfl {DMXBSD} ALIAS 'dmxbsd' (set_name:
    stt$set_name;
    VAR reconcile_locator: dmt$reconcile_locator;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc STD$SET_NAME
*copyc DMT$RECONCILE_LOCATOR
*copyc OST$STATUS
*copyc DMT$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=DMP$BUILD_STORED_FMD EXPAND=FALSE
  PROCEDURE [XREF] dmp$build_stored_fmd
    (    p_fde: gft$file_desc_entry_p;
     VAR p_stored_fmd: ^dmt$stored_fmd;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$stored_fmd
*copyc gft$file_desc_entry_p
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CALCULATE_DEVICE_CAPACITY EXPAND=FALSE

  PROCEDURE [XREF] dmp$calculate_device_capacity (product_id: cmt$product_identification;
                                              VAR capacity: integer;
                                              VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc cmt$product_identification
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CALCULATE_REMAINING_SPACE EXPAND=FALSE

  PROCEDURE [XREF] dmp$calculate_remaining_space (logical_unit_number: iot$logical_unit;
                                                     VAR remaining_bytes: integer;
                                                     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CHANGE_DFL_DAMAGE EXPAND=FALSE
  PROCEDURE [XREF] dmp$change_dfl_damage
    (    avt_index: dmt$active_volume_table_index;
         add_damage: dmt$file_damage;
         remove_damage: dmt$file_damage;
         dfl_index: dmt$device_file_list_index;
         flush_device_log: boolean;
         global_file_name: dmt$global_file_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc dmt$device_file_list_index
*copyc dmt$file_damage
*copyc dmt$global_file_name
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CHANGE_FILE_DAMAGED EXPAND=FALSE
  PROCEDURE [XREF] dmp$change_file_damaged
    (    sfid: dmt$system_file_id;
         file_damaged: boolean;
         global_file_name: dmt$global_file_name;
     VAR status: ost$status);
*copyc dmt$global_file_name
*copyc dmt$system_file_id
*DECK DECK=DMP$CHANGE_FILE_DAMAGE_R3 EXPAND=FALSE
  PROCEDURE [XREF] dmp$change_file_damage_r3
    (    p: ^cell;
         damage: boolean;
         damage_detection_enabled: boolean;
         dfl_damage: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CHANGE_OVERFLOW_ALLOWED EXPAND=FALSE
  PROCEDURE [XREF] dmp$change_overflow_allowed
    (    global_file_name: dmt$global_file_name;
         overflow_allowed: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$global_file_name
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CHANGE_SET_NAME EXPAND=FALSE
  PROCEDURE [XREF] dmp$change_set_name (recorded_vsn: rmt$recorded_vsn;
        new_set_name: stt$set_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmd$volume_declarations
*copyc std$set_name
?? POP ??

*DECK DECK=DMP$CHANGE_SFT_DAMAGE_DETECTION EXPAND=FALSE
  PROCEDURE [XREF] dmp$change_sft_damage_detection
    (    sfid: dmt$system_file_id;
         damage_detection: boolean;
         global_file_name: dmt$global_file_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$global_file_name
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??



*DECK DECK=DMP$CHANGE_SFT_FILE_DAMAGED EXPAND=FALSE
  PROCEDURE [XREF] dmp$change_sft_file_damaged
    (    sfid: dmt$system_file_id;
         file_damaged: boolean;
         global_file_name: dmt$global_file_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$global_file_name
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??



*DECK DECK=DMP$CHANGE_VOLUME_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] dmp$change_volume_attributes (logical_unit_number: iot$logical_unit;
        p_volume_attributes: ^dmt$volume_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$volume_attributes
*copyc iot$logical_unit
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CLEAR_DAT_LOCK EXPAND=FALSE
*DECK DECK=DMP$CLEAR_DFLT_LOCK EXPAND=FALSE
*DECK DECK=DMP$CLEAR_DIRECTORY_LOCK EXPAND=FALSE
*DECK DECK=DMP$CLEAR_LOGIN_TABLE_LOCK EXPAND=FALSE
*DECK DECK=DMP$CLEAR_MASTER_ATTACH_LOCK EXPAND=FALSE

      PROCEDURE [XREF] dmp$clear_master_attach_lock (
           system_file_id: gft$system_file_identifier);

?? PUSH(LIST:=OFF) ??
*copyc gft$system_file_identifier
?? POP ??
*DECK DECK=DMP$CLEAR_MENU_LOCK EXPAND=FALSE
*DECK DECK=DMP$CLEAR_MF_LOGIN_TABLE_LOCK EXPAND=FALSE
*DECK DECK=DMP$CLEAR_UPDATE_LOCK EXPAND=FALSE
  PROCEDURE [XREF] dmp$clear_update_lock
    (    avt_index: dmt$active_volume_table_index);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
?? POP ??
*DECK DECK=DMP$CLEAR_VOLUME_TABLE_LOCKS EXPAND=FALSE
*DECK DECK=DMP$CLOSE_CURRENT_TAPE_VOLUME EXPAND=FALSE

  PROCEDURE [XREF] dmp$close_current_tape_volume
    (    sfid: gft$system_file_identifier;
         detachment_options: fmt$detachment_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$detachment_options
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CLOSE_DAT_R3 EXPAND=FALSE
  PROCEDURE [XREF] dmp$close_dat_r3
    (    p_dat: ^dmt$ms_device_allocation_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$ms_device_allocation_table
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CLOSE_DEVICE_FILE_R3 EXPAND=FALSE
*DECK DECK=DMP$CLOSE_DFL_R3 EXPAND=FALSE
  PROCEDURE [XREF] dmp$close_dfl_r3
    (p_dfl: ^dmt$ms_device_file_list_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$ms_device_file_list_entry
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CLOSE_DIRECTORY_R3 EXPAND=FALSE
  PROCEDURE [XREF] dmp$close_directory_r3
    (    p_directory: ^dmt$ms_volume_directory;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$ms_volume_directory
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CLOSE_FILE EXPAND=FALSE
  PROCEDURE [XREF] dmp$close_file (pva: ^cell;
    VAR status: ost$status);

*copyc ost$status
*DECK DECK=DMP$CLOSE_FILE_FOR_RECOVERY EXPAND=FALSE
*DECK DECK=DMP$CLOSE_LABEL_R3 EXPAND=FALSE
  PROCEDURE [XREF] dmp$close_label_r3
    (    p_label: ^dmt$ms_volume_label;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$ms_volume_label
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CLOSE_LOGIN_TABLE_R3 EXPAND=FALSE
  PROCEDURE [XREF] dmp$close_login_table_r3
    (    p_login_table: ^dmt$ms_mainframe_login_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$ms_login_table
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CLOSE_LOG_R3 EXPAND=FALSE
  PROCEDURE [XREF] dmp$close_log_r3
    (    p_log: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CLOSE_SEGMENT_ACCESS_FILE EXPAND=FALSE
*DECK DECK=DMP$CLOSE_TAPE_VOLUME EXPAND=FALSE

  PROCEDURE [XREF] dmp$close_tape_volume
    (    sfid: dmt$system_file_id;
         detachment_options: fmt$detachment_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc fmt$detachment_options
*copyc ost$status
?? POP ??
*DECK DECK=DMP$COMPLETE_SFT_DELETE EXPAND=FALSE
  PROCEDURE [XREF] dmp$complete_sft_delete (sfid: dmt$system_file_id;
        fmd_index: dmt$fmd_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$fmd_index
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??
*DECK DECK=DMP$COMPLETE_TAPE_VOLUME_INIT EXPAND=FALSE

  PROCEDURE [XREF] dmp$complete_tape_volume_init (
        new_volume_init_info: rmt$tape_volume_init_info;
    VAR operator_allowed_init: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc rmt$tape_volume_init_info
*copyc ost$status
?? POP ??

*DECK DECK=DMP$CONSTRUCT_SC_DAU_LIST EXPAND=FALSE
  PROCEDURE [XREF] dmp$construct_sc_dau_list (rvsn: rmt$recorded_vsn;
         scan_only: boolean;
     VAR p_sc_dau_list: ^array [1 .. *] of dmt$log_flaw_init_data;
     VAR applicable_flaw_count: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$log_flaw_init_data
*copyc ost$status
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=DMP$CONVERT_SFID_TO_LUN EXPAND=FALSE
{dmxcsl}
{        convert sfid to lun xref

  PROCEDURE [XREF] dmp$convert_sfid_to_lun ALIAS 'dmxcsl'
    (    sfid: gft$system_file_identifier;
     VAR lun: iot$logical_unit;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc IOT$LOGICAL_UNIT
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$CONVERT_TO_DAU_ADDRESS EXPAND=FALSE
  PROCEDURE [XREF] dmp$convert_to_dau_address (recorded_vsn: rmt$recorded_vsn;
        p_phys_adrs: ^dmt$physical_flaw_address;
        trk_specified: boolean;
        sec_specified: boolean;
    VAR dau_address: dmt$dau_address;
    VAR end_dau_address: dmt$dau_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$device_allocation_unit
*copyc dmt$physical_flaw_address
*copyc ost$status
*copyc rmt$recorded_vsn
?? POP ??


*DECK DECK=DMP$COPY_DAT EXPAND=FALSE

  PROCEDURE [XREF] dmp$copy_dat (recorded_vsn: rmt$recorded_vsn;
                                 p_output_file: ^cell;
                             VAR status: ost$status);
*copyc rmt$recorded_vsn
*copyc ost$status
*DECK DECK=DMP$COPY_DFL EXPAND=FALSE

  PROCEDURE [XREF] dmp$copy_dfl (recorded_vsn: rmt$recorded_vsn;
                                 output_file: ^cell;
                             VAR status: ost$status);
*copyc rmt$recorded_vsn
*copyc ost$status
*DECK DECK=DMP$COPY_DIRECTORY EXPAND=FALSE

  PROCEDURE [XREF] dmp$copy_directory (recorded_vsn: rmt$recorded_vsn;
                                       p_output_file: ^cell;
                                   VAR status: ost$status);
*copyc rmt$recorded_vsn
*copyc ost$status
*DECK DECK=DMP$COPY_LABEL EXPAND=FALSE
  PROCEDURE [XREF] dmp$copy_label
    (    recorded_vsn: rmt$recorded_vsn;
         p_output_file: ^cell;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=DMP$COPY_LOG EXPAND=FALSE
  PROCEDURE [XREF] dmp$copy_log
    (    recorded_vsn: rmt$recorded_vsn;
         p_output_file: ^cell;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=DMP$COPY_LOGIN_TABLE EXPAND=FALSE
  PROCEDURE [XREF] dmp$copy_login_table
    (    recorded_vsn: rmt$recorded_vsn;
         p_output_file: ^cell;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=DMP$CREATE_CLIENT_SFT EXPAND=FALSE

  PROCEDURE [XREF] dmp$create_client_sft (
       global_file_name: dmt$global_file_name;
       usage_selections: pft$usage_selections;
       share_selections: pft$share_selections;
       operation: dmt$create_client_sft_operation;
       dm_parameters: dft$server_file_output;
       served_family_table_index: dft$served_family_table_index;
       server_mainframe_id: pmt$binary_mainframe_id;
    VAR sfid: gft$system_file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$served_family_table_index
*copyc dft$server_file_output
*copyc dmt$create_client_sft_operation
*copyc dmt$global_file_name
*copyc gft$system_file_identifier
*copyc ost$status
*copyc pfd$permanent_file_attributes
*copyc pmt$binary_mainframe_id
?? POP ??

*DECK DECK=DMP$CREATE_DEVICE_FILE EXPAND=FALSE

  PROCEDURE [XREF] dmp$create_device_file ALIAS 'dmxdcrt' (user_specified_name:
    ost$name;
    recorded_vsn: rmt$recorded_vsn;
    p_file_attributes: ^array [1 .. * ] OF dmt$new_device_file_attribute;
    byte_address: amt$file_byte_address;
    VAR system_file_id: dmt$system_file_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$NAME
*copyc RMD$VOLUME_DECLARATIONS
*copyc DMT$NEW_DEVICE_FILE_ATTRIBUTE
*copyc AMT$FILE_BYTE_ADDRESS
*copyc DMT$SYSTEM_FILE_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$CREATE_DISK_FILE EXPAND=FALSE

  PROCEDURE [XREF] dmp$create_disk_file
    (    fde_p: gft$file_desc_entry_p;
         file_attributes_p: ^array [ * ] of dmt$file_attribute;
         allocation_length: amt$file_byte_address;
         sfid: gft$system_file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON ) ??
*copyc amt$file_byte_address
*copyc dmt$file_attributes
*copyc gft$file_desc_entry_p
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CREATE_DISK_FILE_DESCRIPTOR EXPAND=FALSE
  PROCEDURE [XREF] dmp$create_disk_file_descriptor
    (    file_kind: gft$file_kind;
         file_locator: dmt$file_location;
         p_file_attributes: ^array [1 .. * ] OF dmt$file_attribute;
     VAR dfd_pointer: ost$relative_pointer);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$file_attributes
*copyc dmt$file_location
*copyc gft$file_kind
*copyc osd$virtual_address
?? POP ??
*DECK DECK=DMP$CREATE_FAU_ENTRY EXPAND=FALSE
PROCEDURE [XREF] dmp$create_fau_entry
  (    p_dfd: ^dmt$disk_file_descriptor;
       byte_address: amt$file_byte_address;
       requested_allocation: amt$file_byte_address);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$disk_file_descriptor
*copyc amt$file_byte_address
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CREATE_FD_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] dmp$create_fd_entry ALIAS 'dmxcfd' (p_file_attributes:
    ^array [1 .. * ] OF dmt$file_attribute;
    VAR system_file_id: gft$system_file_identifier;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc dmt$file_attributes
*copyc gft$system_file_identifier
*copyc ost$status
  ?? POP ??
*DECK DECK=DMP$CREATE_FILE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] dmp$create_file_entry (
    file_kind: gft$file_kind;
    file_usage: pft$usage_selections;
    file_share_selections: pft$share_selections;
    file_share_history: dmt$file_share_history;
    p_file_attribute: ^array [ * ] OF dmt$new_file_attribute;
    byte_address: amt$file_byte_address;
    assign_volume: boolean;
    VAR global_file_name: dmt$global_file_name;
    VAR system_file_id: dmt$system_file_id;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc DMT$FILE_SHARE_HISTORY
*copyc DMT$NEW_FILE_ATTRIBUTE
*copyc DMT$GLOBAL_FILE_NAME
*copyc DMT$SYSTEM_FILE_ID
*copyc gft$file_kind
*copyc OST$STATUS
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
  ?? POP ??
*DECK DECK=DMP$CREATE_FILE_MEDIUM_DESCRIPT EXPAND=FALSE
*DECK DECK=DMP$CREATE_FMDS EXPAND=FALSE

 PROCEDURE [XREF] dmp$create_fmds
   (    file_locator: dmt$file_location;
        p_dfd: ^dmt$disk_file_descriptor;
        number_fmds: dmt$fmd_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$file_location
*copyc dmt$disk_file_descriptor
*copyc dmt$subfile_index
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CREATE_MAT EXPAND=FALSE
  PROCEDURE [XREF] dmp$create_mat (
        avt_index: dmt$active_volume_table_index;
        dat_sfid: dmt$system_file_id;
    VAR p_mat: cyt$adaptable_array_pointer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cyd$cybil_structure_definitions
*copyc dmt$active_volume_table_index
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??
*DECK DECK=DMP$CREATE_MFL EXPAND=FALSE
  PROCEDURE [XREF] dmp$create_mfl (
    VAR p_mfl: cyt$adaptable_array_pointer);

?? PUSH (LISTEXT := ON) ??
*copyc cyd$cybil_structure_definitions
?? POP ??
*DECK DECK=DMP$CREATE_MF_ALLOCATION_TABLE EXPAND=FALSE
*DECK DECK=DMP$CREATE_STT EXPAND=FALSE
*DECK DECK=DMP$CREATE_TAPE_FILE_SFID EXPAND=FALSE

  PROCEDURE [XREF] dmp$create_tape_file_sfid
    (    p_removable_media_req_info: {input} ^fmt$removable_media_req_info;
         p_volume_list: {input} ^rmt$volume_list;
     VAR sfid: gft$system_file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$removable_media_req_info
*copyc gft$system_file_identifier
*copyc ost$status
*copyc rmt$volume_list
?? POP ??
*DECK DECK=DMP$CREATE_VOLUME_LOG_ENTRY EXPAND=FALSE
*DECK DECK=DMP$CREATE_VOLUME_MFL EXPAND=FALSE
*DECK DECK=DMP$DAT_PURGE_FILE EXPAND=FALSE
  PROCEDURE [XREF] dmp$dat_purge_file (gfn: dmt$global_file_name;
        dfl_index: dmt$device_file_list_index;
        avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc dmt$device_file_list_index
*copyc dmt$global_file_name
*copyc ost$status
?? POP ??
*DECK DECK=DMP$DEACTIVATE_VOLUME EXPAND=FALSE
 PROCEDURE [XREF] dmp$deactivate_volume (avt_index:
  dmt$active_volume_table_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc ost$status
?? POP ??
*DECK DECK=DMP$DEALLOCATE_FILE_SPACE EXPAND=FALSE

  PROCEDURE [XREF] dmp$deallocate_file_space (
    p_fde: gft$locked_file_desc_entry_p;
    initial_release_byte_address: amt$file_byte_address;
    initial_bytes_to_release: integer);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc gft$locked_file_desc_entry_p
?? POP ??
*DECK DECK=DMP$DEALLOCATE_FILE_SPACE_R1 EXPAND=TRUE
  PROCEDURE [XREF] dmp$deallocate_file_space_r1
    (    system_file_id: gft$system_file_identifier;
         release_byte_address: amt$file_byte_address;
         bytes_to_release: integer;
         p_fde: gft$file_desc_entry_p;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc gft$file_desc_entry_p
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=DMP$DECREMENT_CLASS_ACTIVITY EXPAND=FALSE

  PROCEDURE [XREF] dmp$decrement_class_activity (
        sfid: dmt$system_file_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??
*DECK DECK=DMP$DEFINE_REMOVE_MS_FLAW EXPAND=FALSE
  PROCEDURE [XREF] dmp$define_remove_ms_flaw (rvsn: rmt$recorded_vsn;
        p_phys_adrs: ^dmt$physical_flaw_address;
        trk_specified: boolean;
        sec_specified: boolean;
        operation_code: dmt$flaw_operation_code;
        initiator_code: dmt$flaw_initiator_code;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$flaw_dau_definition
*copyc dmt$physical_flaw_address
*copyc iot$cylinder
*copyc ost$status
*copyc rmt$recorded_vsn
?? POP ??


*DECK DECK=DMP$DELETE_DISK_FILE_DESCRIPTOR EXPAND=FALSE
*DECK DECK=DMP$DELETE_FILE_DESCRIPTOR EXPAND=FALSE

  PROCEDURE [XREF] dmp$delete_file_descriptor ALIAS 'dmxdfd' (system_file_id:
    dmt$system_file_id;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$DELETE_MAT EXPAND=FALSE
  PROCEDURE [XREF] dmp$delete_mat (
    VAR p_mat {input, output} : cyt$adaptable_array_pointer);

?? PUSH (LISTEXT := ON) ??
*copyc cyd$cybil_structure_definitions
?? POP ??
*DECK DECK=DMP$DELETE_MFL EXPAND=FALSE
  PROCEDURE [XREF] dmp$delete_mfl (
    VAR p_mfl {input, output} : cyt$adaptable_array_pointer);

?? PUSH (LISTEXT := ON) ??
*copyc cyd$cybil_structure_definitions
?? POP ??
*DECK DECK=DMP$DESTROY_DEVICE_FILE EXPAND=FALSE

  PROCEDURE [XREF] dmp$destroy_device_file ALIAS 'dmxdedf' (recorded_vsn:
    rmt$recorded_vsn;
    user_supplied_name: ost$name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc OST$NAME
*copyc OST$STATUS
*copyc DMT$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=DMP$DESTROY_FILE EXPAND=FALSE

  PROCEDURE [XREF] dmp$destroy_file ALIAS 'dmxfdes' (VAR system_file_id:
    dmt$system_file_id;
        file_space_limit: sft$file_space_limit_kind;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc OST$STATUS
*copyc SFT$FILE_SPACE_LIMIT_KIND
  ?? POP ??
*DECK DECK=DMP$DESTROY_PERMANENT_FILE EXPAND=FALSE

  PROCEDURE [XREF] dmp$destroy_permanent_file ALIAS 'dmxdepf'
    (global_file_name: dmt$global_file_name;
    stored_fmd: dmt$stored_fmd;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$STORED_FMD
*copyc DMT$GLOBAL_FILE_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$DESTROY_SUB_FILE EXPAND=FALSE
 PROCEDURE [XREF] dmp$destroy_sub_file (global_file_name: dmt$global_file_name;
        recorded_vsn: rmt$recorded_vsn;
        dfl_index: dmt$device_file_list_index;
        byte_address: amt$file_byte_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmt$device_file_list_index
*copyc dmt$global_file_name
*copyc ost$status
*copyc rmd$volume_declarations
?? POP ??
*DECK DECK=DMP$DESTROY_VOLUME_MFL EXPAND=FALSE
*DECK DECK=DMP$DETACH_DEVICE_FILE EXPAND=FALSE
 PROCEDURE [XREF] dmp$detach_device_file (system_file_id: dmt$system_file_id;
    VAR file_modified: boolean;
    VAR fmd_modified: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??
*DECK DECK=DMP$DETACH_FILE EXPAND=FALSE
 PROCEDURE [XREF] dmp$detach_file (system_file_id: dmt$system_file_id;
        access_allowed: boolean;
        flush_pages: boolean;
    VAR file_modified: boolean;
    VAR fmd_modified: boolean;
    VAR file_info: dmt$file_information;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$file_information
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??
*DECK DECK=DMP$DETACH_SERVER_FILE EXPAND=FALSE
  PROCEDURE [XREF] dmp$detach_server_file
     (   system_file_id: dmt$system_file_id;
         flush_pages: boolean;
         unconditional_detach: boolean;
     VAR attached_for_write: boolean;
     VAR eoi_byte_address: amt$file_byte_address;
     VAR remote_sfid: dmt$system_file_id;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??
*DECK DECK=DMP$DETERMINE_QUEUE_STATUS EXPAND=FALSE

 PROCEDURE [XREF] dmp$determine_queue_status
   (    file_kind: gft$file_kind;
        file_usage: pft$usage_selections;
        file_share_selections: pft$share_selections;
    VAR queue_status: gft$queue_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc gft$file_kind
*copyc gft$queue_status
*copyc ost$status
*copyc pfd$permanent_file_attributes
?? POP ??
*DECK DECK=DMP$DEVICE_FILE_LIST_UPDATE EXPAND=FALSE

  PROCEDURE [XREF] dmp$device_file_list_update
    (    set_name: stt$set_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$error_condition_codes
*copyc ost$status
*copyc std$set_name
?? POP ??
*DECK DECK=DMP$DEV_MGMT_TABLE_UPDATE EXPAND=FALSE
  PROCEDURE [XREF] dmp$dev_mgmt_table_update;
*DECK DECK=DMP$DF_CLIENT_SET_EOI EXPAND=FALSE
*DECK DECK=DMP$DISABLE_VOLUME_UPDATE EXPAND=FALSE
*DECK DECK=DMP$DISPLAY_CYLINDERS EXPAND=FALSE
  PROCEDURE [XREF] dmp$display_cylinders (VAR display_control: clt$display_control;
        recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc rmd$volume_declarations
*copyc ost$status
?? POP ??
*DECK DECK=DMP$DISPLAY_DAT EXPAND=FALSE

  PROCEDURE [XREF] dmp$display_dat (VAR display_control: clt$display_control;
    recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc CLT$DISPLAY_CONTROL
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$DISPLAY_DEVICE_FILE EXPAND=FALSE

  PROCEDURE [XREF] dmp$display_device_file (VAR display_control: clt$display_control;
    recorded_vsn: rmt$recorded_vsn;
    summary_listing: boolean;
    full_listing: boolean;
    file_index: dmt$device_file_list_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc CLT$DISPLAY_CONTROL
*copyc OST$STATUS
*copyc DMT$DEVICE_FILE_LIST_INDEX
?? POP ??
*DECK DECK=DMP$DISPLAY_DEVICE_LOG EXPAND=FALSE

  PROCEDURE [XREF] dmp$display_device_log (VAR display_control: clt$display_control;
    recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc CLT$DISPLAY_CONTROL
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$DISPLAY_DEVICE_SPACE EXPAND=FALSE

  PROCEDURE [XREF] dmp$display_device_space (VAR display_control: clt$display_control;
    recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc CLT$DISPLAY_CONTROL
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$DISPLAY_DIRECTORY EXPAND=FALSE

  PROCEDURE [XREF] dmp$display_directory (VAR display_control: clt$display_control;
    recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc CLT$DISPLAY_CONTROL
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$DISPLAY_FILE_TABLES EXPAND=FALSE

  PROCEDURE [XREF] dmp$display_file_tables
    (    path: string (*);
         full_listing: boolean;
         p: ^cell;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=DMP$DISPLAY_LABEL EXPAND=FALSE

  PROCEDURE [XREF] dmp$display_label (VAR display_control: clt$display_control;
    recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc CLT$DISPLAY_CONTROL
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$DISPLAY_LOGIN_TABLE EXPAND=FALSE

  PROCEDURE [XREF] dmp$display_login_table (VAR display_control: clt$display_control;
    recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc CLT$DISPLAY_CONTROL
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$DISPLAY_MASS_STORAGE EXPAND=FALSE

  PROCEDURE [XREF] dmp$display_mass_storage
    (    window_id: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=DMP$DMPFILI EXPAND=FALSE
*DECK DECK=DMP$ENABLE_DAMAGE_DETECTION EXPAND=FALSE
  PROCEDURE [XREF] dmp$enable_damage_detection
    (    sfid: dmt$system_file_id;
         global_file_name: dmt$global_file_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$global_file_name
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??



*DECK DECK=DMP$ENABLE_UPDATE EXPAND=FALSE
*DECK DECK=DMP$ENABLE_VOLUME_UPDATE EXPAND=FALSE
*DECK DECK=DMP$EVACUATE_ACTIVE_DEVICE_LOG EXPAND=FALSE
 PROCEDURE [XREF] dmp$evacuate_active_device_log (avt_index:
  dmt$active_volume_table_index;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc ost$status
?? POP ??
*DECK DECK=DMP$EVACUATE_OLD_DEVICE_LOG EXPAND=FALSE
 PROCEDURE [XREF] dmp$evacuate_old_device_log (avt_index:
  dmt$active_volume_table_index;
        old_mainframe_assigned: dmt$mainframe_assigned;
        login_table_sfid: dmt$system_file_id;
        device_log_sfid: dmt$system_file_id;
        p_allocation_log_info: ^dmt$allocation_log_info;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc dmt$system_file_id
*copyc dmt$mainframe_assigned
*copyc dmt$allocation_log
*copyc ost$status
?? POP ??
*DECK DECK=DMP$EVICT EXPAND=FALSE
*DECK DECK=DMP$FETCH_DEBUG_OPTION_VALUE EXPAND=FALSE

      PROCEDURE [XREF] dmp$fetch_debug_option_value (name: string(*);
             VAR value: integer;
             VAR status: ost$status);

??PUSH (LISTEXT:= ON)??
*copyc ost$status
??POP??
*DECK DECK=DMP$FETCH_EOI EXPAND=FALSE
PROCEDURE [XREF] dmp$fetch_eoi ALIAS 'dmxfeoi' (system_file_id:
   dmt$system_file_id;
   VAR eoi:amt$file_byte_address;
   VAR status:ost$status);
??PUSH(list:=off)??
*copyc DMT$SYSTEM_FILE_ID
*copyc AMT$FILE_BYTE_ADDRESS
*copyc OST$STATUS
??POP??
*DECK DECK=DMP$FETCH_MULTI_PAGE_STATUS EXPAND=FALSE

  PROCEDURE [XREF] dmp$fetch_multi_page_status
     (    fde_p: gft$locked_file_desc_entry_p;
          offset: ost$segment_offset;
          length: ost$segment_length;
          enforce_limits: sft$file_space_limit_kind;
      VAR reject_offset: ost$segment_offset;
      VAR allocate_status: gft$page_status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$locked_file_desc_entry_p
*copyc gft$page_status
*copyc osd$virtual_address
*copyc sft$file_space_limit_kind
?? POP ??
*DECK DECK=DMP$FETCH_PAGE_STATUS EXPAND=FALSE

  PROCEDURE [XREF] dmp$fetch_page_status
     (    fde_p: gft$locked_file_desc_entry_p;
          offset: ost$segment_offset;
          enforce_limits: sft$file_space_limit_kind;
          allow_allocation: boolean;
      VAR allocate_status: gft$page_status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$locked_file_desc_entry_p
*copyc gft$page_status
*copyc osd$virtual_address
*copyc sft$file_space_limit_kind
?? POP ??
*DECK DECK=DMP$FETCH_SEGMENT_FILE_INFO EXPAND=FALSE

  PROCEDURE [XREF] dmp$fetch_segment_file_info ALIAS 'fsginfo'
    (    system_file_id: gft$system_file_identifier;
         chapter: dmt$chapter_number;
     VAR info: dmt$segment_file_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$chapter_number
*copyc dmt$segment_file_information
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=DMP$FETCH_SERVER_SFT_INFO EXPAND=FALSE

  PROCEDURE [XREF] dmp$fetch_server_sft_info
    (    system_file_id: gft$system_file_identifier;
     VAR dm_parameters: dft$server_file_output;
     VAR p_file_server_buffers: pft$p_file_server_buffers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$server_file_output
*copyc gft$system_file_identifier
*copyc ost$status
*copyc pft$server_file_output
?? POP ??

*DECK DECK=DMP$FETCH_TAPE_UNIT_COUNT EXPAND=FALSE

  PROCEDURE [XREF] dmp$fetch_tape_unit_count
    (VAR tape_unit_count: ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
*copyc ost$status
?? POP ??

*DECK DECK=DMP$FETCH_TAPE_UNIT_STATUS_INFO EXPAND=FALSE

  PROCEDURE [XREF] dmp$fetch_tape_unit_status_info
    (VAR tape_unit_status_info: array [1 .. * ] of dmt$tape_unit_status_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$tape_unit_status_info
*copyc ost$status
?? POP ??

*DECK DECK=DMP$FILE_ON_DOWN_VOLUME EXPAND=FALSE
  PROCEDURE [XREF] dmp$file_on_down_volume
    (    system_file_id: gft$system_file_identifier;
     VAR file_on_down_volume: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
?? POP ??
*DECK DECK=DMP$FIND_CIP_CYLINDER EXPAND=FALSE
*DECK DECK=DMP$FIXUP_CLIENT_FILE_LENGTH EXPAND=FALSE

  PROCEDURE [XREF] dmp$fixup_client_file_length
    (    sfid: gft$system_file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=DMP$FIXUP_FILE_ALLOCATION_UNIT EXPAND=FALSE
*DECK DECK=DMP$FIXUP_FILE_EOI EXPAND=FALSE
*DECK DECK=DMP$FIXUP_FMD_ALLOCATED_LENGTH EXPAND=FALSE

  PROCEDURE [XREF] dmp$fixup_fmd_allocated_length
    (    system_file_id: gft$system_file_identifier;
         fmd_index: dmt$fmd_index;
         allocated_length: amt$file_byte_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmt$fmd_index
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=DMP$FREE_FMDS EXPAND=FALSE

  PROCEDURE [XREF] dmp$free_fmds
    (    p_dfd: ^dmt$disk_file_descriptor;
         fmd_locator: dmt$file_location;
         number_of_fmds: dmt$fmd_index;
     VAR fmds_released: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$fmd_index
*copyc dmt$disk_file_descriptor
*copyc dmt$file_location
?? POP ??
*DECK DECK=DMP$FREE_SERVER_FILE_TABLES EXPAND=FALSE

  PROCEDURE [XREF] dmp$free_server_file_tables
    (    system_file_id: gft$system_file_identifier;
     VAR status: ost$status);

?? PUSH( LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=DMP$GENERATE_GFN_HASH EXPAND=FALSE
?? RIGHT := 110 ??
*copyc OSD$DEFAULT_PRAGMATS
?? PUSH (LISTEXT := ON) ??
*copyc DMT$GLOBAL_FILE_NAME
*copyc DMT$FILE_HASH
  ?? POP ??

  PROCEDURE [inline] dmp$generate_gfn_hash ALIAS 'dmxfhsh' (global_file_name: dmt$global_file_name;
    VAR file_hash: dmt$file_hash);
??PUSH(LISTEXT:=ON)??
    file_hash := global_file_name.sequence_number MOD 99;
  PROCEND dmp$generate_gfn_hash;
?? POP ??
*DECK DECK=DMP$GET_ACTIVE_VOL_ATTRIBUTES EXPAND=FALSE
 PROCEDURE [XREF] dmp$get_active_vol_attributes (required_recorded_vsn:
  rmt$recorded_vsn;
        search_avt_index: dmt$active_volume_table_index;
    VAR p_assigned_vol_attributes: ^array [ * ] OF
      dmt$assigned_ms_vol_attribute;
    VAR avt_entry_found: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc rmd$volume_declarations
*copyc dmt$active_volume_table_index
*copyc dmt$assigned_ms_vol_attributes
?? POP ??
*DECK DECK=DMP$GET_ALLOCATION_INFO EXPAND=FALSE
 PROCEDURE [XREF] dmp$get_allocation_info (vsn: rmt$recorded_vsn;
    VAR allocation_info: dmt$allocation_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc rmd$volume_declarations
*copyc dmt$allocation_info
*copyc ost$status
?? POP ??
*DECK DECK=DMP$GET_AVT_LOGGING_INFO EXPAND=FALSE

  PROCEDURE [XREF] dmp$get_avt_logging_info (avt_index: dmt$active_volume_table_index;
                                         VAR info: dmt$avt_logging_info;
                                         VAR valid_entry: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc dmt$avt_logging_info
*copyc dmt$active_volume_table_index
?? POP ??
*DECK DECK=DMP$GET_DISK_FILE_DESCRIPTOR_P EXPAND=FALSE

  PROCEDURE [INLINE] dmp$get_disk_file_descriptor_p (fde_p: gft$file_desc_entry_p;
    VAR dfd_p: ^dmt$disk_file_descriptor);

?? PUSH (LISTEXT := ON) ??

    VAR
      local_fde_p: ^gft$file_descriptor_entry,
      pva: gft$trick_pointer;

    IF fde_p^.media <> gfc$fm_mass_storage_file THEN
      i#program_error;
    IFEND;
    local_fde_p := fde_p;
    pva.p := local_fde_p;
    pva.pva.offset := local_fde_p^.disk_file_descriptor_p;
    dfd_p := pva.p;

  PROCEND;
*copyc dmt$file_descriptor_entry
*copyc gft$file_desc_entry_p
*copyc gft$file_descriptor_entry
*copyc gft$trick_pointer
*copyc i#program_error
?? POP ??
*DECK DECK=DMP$GET_FAU_ENTRY EXPAND=FALSE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc dmt$disk_file_descriptor
*copyc dmt$sparse_allocation
*copyc dmp$get_level_2_ptr
?? POP ??

  PROCEDURE [INLINE] dmp$get_fau_entry (p_dfd: ^dmt$disk_file_descriptor;
        byte_address: amt$file_byte_address;
    VAR p_fau_entry: ^dmt$file_allocation_unit);

?? PUSH (LISTEXT := ON) ??

    VAR
      level_1_index: dmt$level_1_index,
      level_2_index: dmt$level_2_index,
      p_level1: ^dmt$level_1_table,
      p_level2: ^dmt$level_2_table;


    p_fau_entry := NIL;

    {Note:
    {If p_fau_entry is returned NIL then table space is not allocated

    IF p_dfd^.file_allocation_table <> NIL THEN
      level_1_index := byte_address DIV p_dfd^.bytes_per_level_2;
      IF level_1_index <= p_dfd^.fat_upper_bound THEN
        p_level1 := #address (1, #segment (p_dfd), #offset (p_dfd^.file_allocation_table));
        dmp$get_level_2_ptr (^p_level1^ [level_1_index], p_level2);
        IF p_level2 <> NIL THEN
          level_2_index := (byte_address MOD p_dfd^.bytes_per_level_2) DIV p_dfd^.bytes_per_allocation;
          p_fau_entry := ^p_level2^ [level_2_index];
        IFEND;
      IFEND;
    IFEND;

    PROCEND dmp$get_fau_entry;
?? POP ??
*DECK DECK=DMP$GET_FAU_ENTRY_AND_FMD EXPAND=FALSE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc dmp$get_fmd_by_index
*copyc dmt$file_allocation_descriptor
*copyc dmt$sparse_allocation
*copyc dmp$get_level_2_ptr
?? POP ??

  PROCEDURE [INLINE] dmp$get_fau_entry_and_fmd (p_dfd: ^dmt$disk_file_descriptor;
        byte_address: amt$file_byte_address;
    VAR p_fau_entry: ^dmt$file_allocation_unit;
    VAR p_fmd: ^dmt$file_medium_descriptor);

?? PUSH (LISTEXT := ON) ??

    VAR
      level_1_index: dmt$level_1_index,
      level_2_index: dmt$level_2_index,
      p_level1: ^dmt$level_1_table,
      p_level2: ^dmt$level_2_table;

    p_fmd := NIL;
    p_fau_entry := NIL;

    {Note:
    {If p_fau is returned NIL then table space is not allocated
    {If p_fmd is returned NIL then disk space is not allocated

    IF p_dfd^.file_allocation_table <> NIL THEN
      level_1_index := byte_address DIV p_dfd^.bytes_per_level_2;
      IF level_1_index <= p_dfd^.fat_upper_bound THEN
        p_level1 := #address (1, #segment (p_dfd), #offset (p_dfd^.file_allocation_table));
        dmp$get_level_2_ptr (^p_level1^ [level_1_index], p_level2);
        IF p_level2 <> NIL THEN
          level_2_index := (byte_address MOD p_dfd^.bytes_per_level_2) DIV p_dfd^.bytes_per_allocation;
          p_fau_entry := ^p_level2^ [level_2_index];
          IF p_fau_entry^.state > dmc$fau_free THEN
            dmp$get_fmd_by_index (p_dfd, p_fau_entry^.fmd_index, p_fmd);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    PROCEND dmp$get_fau_entry_and_fmd;
?? POP ??
*DECK DECK=DMP$GET_FDE_AVAILABLE_THREAD EXPAND=FALSE
*DECK DECK=DMP$GET_FDT_ROOT_POINTER EXPAND=FALSE
*DECK DECK=DMP$GET_FILE_INFO EXPAND=FALSE

  PROCEDURE [XREF] dmp$get_file_info
    (    system_file_id: gft$system_file_identifier;
     VAR info: dmt$file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$file_information
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=DMP$GET_FMD_BY_INDEX EXPAND=FALSE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc dmt$disk_file_descriptor
*copyc dmt$file_medium_descriptor
*copyc dmt$fmd_index
?? POP ??

  PROCEDURE [INLINE] dmp$get_fmd_by_index (p_dfd: ^dmt$disk_file_descriptor;
        fmd_number: dmt$fmd_index;
    VAR p_fmd: ^dmt$file_medium_descriptor);

?? PUSH (LISTEXT := ON) ??

    VAR
      fmd_index: dmt$fmd_index;

    p_fmd := NIL;

{ Return NIL if the fmd_index is less than one.

   IF fmd_number >= 1 THEN
    IF p_dfd^.p_fmd <> NIL THEN
      p_fmd := #address (#ring (p_dfd), #segment (p_dfd), #offset (p_dfd^.p_fmd));
    IFEND;
    fmd_index := 1;

    WHILE (fmd_index < fmd_number) AND (p_fmd <> NIL) DO
      p_fmd := p_fmd^.p_next_fmd;
      IF p_fmd <> NIL THEN
        {
        { insure that the segment number in p_fmd is the same as
        { the segment number in p_dfd.
        {
        p_fmd := #address (#ring (p_dfd), #segment (p_dfd), #offset (p_fmd));
      IFEND;
      fmd_index := fmd_index + 1;
    WHILEND;
   IFEND;

  PROCEND dmp$get_fmd_by_index;
?? POP ??
*DECK DECK=DMP$GET_INITIALIZED_ADDRESSES EXPAND=FALSE

 PROCEDURE [XREF] dmp$get_initialized_addresses (sfid: dmt$system_file_id;
       starting_byte_address: ost$segment_offset;
   VAR addr_list: array [ * ] of dmt$addr_length_pair;
   VAR addr_returned: integer;
   VAR list_overflow: boolean;
   VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc osd$virtual_address
*copyc dmt$addr_length_pair
?? POP ??
*DECK DECK=DMP$GET_LEVEL_1_PTR EXPAND=FALSE
PROCEDURE [INLINE] dmp$get_level_1_ptr (p_dfd: ^dmt$disk_file_descriptor;
    VAR ptr_level_1: ^dmt$level_1_table);
?? PUSH (LISTEXT := ON) ??

  IF p_dfd^.file_allocation_table <> NIL THEN
    ptr_level_1 := #address (1, #segment (p_dfd), #offset (p_dfd^.file_allocation_table));
  ELSE
    ptr_level_1 := NIL;
  IFEND;

PROCEND dmp$get_level_1_ptr;
*copyc dmt$disk_file_descriptor
*copyc dmt$sparse_allocation
?? POP ??
*DECK DECK=DMP$GET_LEVEL_2_PTR EXPAND=FALSE
PROCEDURE [INLINE] dmp$get_level_2_ptr (p_offset: ^amt$file_byte_address;
    VAR ptr_level_2: ^dmt$level_2_table);
?? PUSH (LISTEXT := ON) ??

  IF p_offset^ <> 0 THEN
    ptr_level_2 := #address (1, #segment (p_offset), p_offset^);
  ELSE
    ptr_level_2 := NIL;
  IFEND;

PROCEND dmp$get_level_2_ptr;
*copyc amt$file_byte_address
*copyc dmt$sparse_allocation
?? POP ??
*DECK DECK=DMP$GET_LOGGING_ABORT_ENTRIES EXPAND=FALSE
*DECK DECK=DMP$GET_LOGGING_ABORT_POSITIONS EXPAND=FALSE
*DECK DECK=DMP$GET_LOGICAL_ATTRIBUTES EXPAND=FALSE
  PROCEDURE [XREF] dmp$get_logical_attributes (product_identification:
    cmt$product_identification;
    VAR p_logical_attributes: ^dmt$logical_device_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$product_identification
*copyc dmt$logical_device_attributes
*copyc ost$status
?? POP ??
*DECK DECK=DMP$GET_LOGICAL_UNIT_NUMBER EXPAND=FALSE

  PROCEDURE [XREF] dmp$get_logical_unit_number (recorded_vsn: rmt$recorded_vsn;
    VAR logical_unit_number: iot$logical_unit;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc IOT$LOGICAL_UNIT
*copyc OST$STATUS
*copyc DMT$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=DMP$GET_MAT_POINTER EXPAND=FALSE
 PROCEDURE [XREF] dmp$get_mat_pointer (avt_index: dmt$active_volume_table_index;
    VAR p_mat: ^dmt$mainframe_allocation_table);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc dmt$mainframe_allocation_table
?? POP ??
*DECK DECK=DMP$GET_MFL_POINTER EXPAND=FALSE
 PROCEDURE [XREF] dmp$get_mfl_pointer (avt_index: dmt$active_volume_table_index;
    VAR p_mfl: ^dmt$ms_mf_device_file_list);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc dmt$mainframe_device_file_list
?? POP ??

*DECK DECK=DMP$GET_NEXT_FAU_ENTRY EXPAND=FALSE
*DECK DECK=DMP$GET_NEXT_FMD_FAU EXPAND=TRUE
  PROCEDURE [INLINE] dmp$get_next_fmd_fau (p_dfd: ^dmt$disk_file_descriptor;
      byte_address: integer;
      fmd_index: dmt$fmd_index;
      VAR p_next_fau_entry: ^dmt$file_allocation_unit);
?? PUSH (LISTEXT := ON) ??

    VAR
      level_1_start: integer,
      level_1_index: dmt$level_1_index,
      level_2_start: integer,
      level_2_index: dmt$level_2_index,
      p_level_1: ^dmt$level_1_table,
      p_level_2: ^dmt$level_2_table;

    IF byte_address >= 0 THEN
      level_1_start := byte_address DIV p_dfd^.bytes_per_level_2;
      level_2_start := ((byte_address MOD p_dfd^.bytes_per_level_2) DIV p_dfd^.bytes_per_allocation) + 1;
      IF level_2_start > (p_dfd^.bytes_per_level_2 DIV p_dfd^.bytes_per_allocation - 1) THEN
        level_1_start := level_1_start + 1;
        level_2_start := 0;
        IF level_1_start > p_dfd^.fat_upper_bound THEN
          p_next_fau_entry := NIL;
        IFEND;
      IFEND;
    ELSE
      {Negative byte address means find FIRST AU.
      level_1_start := 0;
      level_2_start := 0;
    IFEND;

    dmp$get_level_1_ptr (p_dfd, p_level_1);
    IF p_level_1 <> NIL THEN
      FOR level_1_index := level_1_start TO p_dfd^.fat_upper_bound DO
        dmp$get_level_2_ptr (^p_level_1^ [level_1_index], p_level_2);
        IF p_level_2 <> NIL THEN
          FOR level_2_index := level_2_start TO
              (p_dfd^.bytes_per_level_2 DIV p_dfd^.bytes_per_allocation - 1) DO
            IF p_level_2^ [level_2_index].state <> dmc$fau_free THEN
              IF p_level_2^ [level_2_index].fmd_index = fmd_index THEN
                {Return next allocated AU
                p_next_fau_entry := ^p_level_2^ [level_2_index];
                RETURN;
              IFEND;
            IFEND;
          FOREND;
        IFEND;
        level_2_start := 0;
      FOREND;
    IFEND;

    p_next_fau_entry := NIL;

  PROCEND dmp$get_next_fmd_fau;
*copyc dmp$get_level_1_ptr
*copyc dmp$get_level_2_ptr
*copyc dmp$get_fau_entry
*copyc amt$file_byte_address
?? POP ??
*DECK DECK=DMP$GET_NUMBER_OF_FAUS EXPAND=FALSE
  PROCEDURE [INLINE] dmp$get_number_of_faus (p_dfd: ^dmt$disk_file_descriptor;
      VAR number_of_faus: dmt$fau_entries);
?? PUSH (LISTEXT := ON) ??

    VAR
      level_1_start,
      level_1_index: dmt$level_1_index,
      level_2_start,
      level_2_index: dmt$level_2_index,
      p_fmd: ^dmt$file_medium_descriptor,
      p_fau: ^dmt$file_allocation_unit,
      p_level_1: ^dmt$level_1_table,
      p_level_2: ^dmt$level_2_table;

    {Find highest offset allocated, return fau index that it represents

    dmp$get_level_1_ptr (p_dfd, p_level_1);
    IF p_level_1 <> NIL THEN
      level_1_start := p_dfd^.fat_upper_bound;
      level_2_start := p_dfd^.bytes_per_level_2 DIV p_dfd^.bytes_per_allocation - 1;
      FOR level_1_index := level_1_start DOWNTO 0 DO
        dmp$get_level_2_ptr (^p_level_1^ [level_1_index], p_level_2);
        IF p_level_2 <> NIL THEN
          FOR level_2_index := level_2_start DOWNTO 0 DO
            IF p_level_2^ [level_2_index].state <> dmc$fau_free THEN
              number_of_faus := (level_1_index * (p_dfd^.bytes_per_level_2 DIV p_dfd^.bytes_per_allocation))
                  + level_2_index + 1;
              RETURN;
            IFEND;
          FOREND;
        IFEND;
      FOREND;
    ELSE
      number_of_faus := 0;
    IFEND;

  PROCEND dmp$get_number_of_faus;
*copyc dmp$get_level_1_ptr
*copyc dmp$get_level_2_ptr
?? POP ??
*DECK DECK=DMP$GET_NUMBER_OF_FMD_SUBFILES EXPAND=FALSE
*DECK DECK=DMP$GET_OLD_IMAGE_POINTERS EXPAND=FALSE

  PROCEDURE [XREF] dmp$get_old_image_pointers
    (VAR old_image_pointers: dmt$old_image_pointers;
     VAR image_available: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$old_image_pointers
?? POP ??
*DECK DECK=DMP$GET_OUT_OF_SPACE_SETS EXPAND=FALSE
  PROCEDURE [XREF] dmp$get_out_of_space_sets (VAR out_of_space_sets: dmt$out_of_space_sets;
    VAR set_count: integer);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$out_of_space_sets
?? POP ??
*DECK DECK=DMP$GET_PHYSICAL_ATTRIBUTES EXPAND=FALSE
  PROCEDURE [XREF] dmp$get_physical_attributes (product_identification:
    cmt$product_identification;
    VAR p_physical_attributes: ^dmt$physical_device_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$product_identification
*copyc dmt$physical_device_attributes
*copyc ost$status
?? POP ??
*DECK DECK=DMP$GET_PREVIOUS_FAU_ENTRY EXPAND=FALSE
  PROCEDURE [INLINE] dmp$get_previous_fau_entry (p_dfd: ^dmt$disk_file_descriptor;
      byte_address: amt$file_byte_address;
      fmd_index: dmt$fmd_index;
      VAR p_previous_fau_entry: ^dmt$file_allocation_unit);
?? PUSH (LISTEXT := ON) ??

    VAR
      level_1_start: integer,
      level_1_index: dmt$level_1_index,
      level_2_start: integer,
      level_2_index: dmt$level_2_index,
      p_level_1: ^dmt$level_1_table,
      p_level_2: ^dmt$level_2_table;

    level_1_start := byte_address DIV p_dfd^.bytes_per_level_2;
    level_2_start := ((byte_address MOD p_dfd^.bytes_per_level_2) DIV p_dfd^.bytes_per_allocation) - 1;
    IF level_2_start < 0 THEN
      level_1_start := level_1_start - 1;
      IF level_1_start < 0 THEN
        p_previous_fau_entry := NIL;
        RETURN;
      IFEND;
      level_2_start := p_dfd^.bytes_per_level_2 DIV p_dfd^.bytes_per_allocation - 1;
    IFEND;

    dmp$get_level_1_ptr (p_dfd, p_level_1);
    FOR level_1_index := level_1_start DOWNTO 0 DO
      dmp$get_level_2_ptr (^p_level_1^ [level_1_index], p_level_2);
      IF p_level_2 <> NIL THEN
        FOR level_2_index := level_2_start DOWNTO 0 DO
          IF p_level_2^ [level_2_index].state <> dmc$fau_free THEN
            IF p_level_2^ [level_2_index].fmd_index = fmd_index THEN
              p_previous_fau_entry := ^p_level_2^ [level_2_index];
              RETURN;
            IFEND;
          IFEND;
        FOREND;
      IFEND;
      level_2_start := p_dfd^.bytes_per_level_2 DIV p_dfd^.bytes_per_allocation - 1;
    FOREND;

    p_previous_fau_entry := NIL;

  PROCEND dmp$get_previous_fau_entry;
*copyc dmp$get_level_1_ptr
*copyc dmp$get_level_2_ptr
*copyc dmp$get_fau_entry
?? POP ??
*DECK DECK=DMP$GET_RECONCILED_FMD EXPAND=FALSE
 PROCEDURE [XREF] dmp$get_reconciled_fmd (reconcile_locator:
  dmt$reconcile_locator;
        global_file_name: dmt$global_file_name;
        old_stored_fmd: dmt$stored_fmd;
    VAR new_stored_fmd: dmt$stored_fmd;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$error_condition_codes
*copyc dmt$global_file_name
*copyc dmt$reconcile_locator
*copyc dmt$stored_fmd
*copyc ost$status
?? POP ??
*DECK DECK=DMP$GET_RECORDED_VSN EXPAND=FALSE
  PROCEDURE [XREF] dmp$get_recorded_vsn
    (    lun: iot$logical_unit;
         VAR recorded_vsn: rmt$recorded_vsn);
?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=DMP$GET_RVSN_BY_LUN EXPAND=FALSE

  PROCEDURE [XREF] dmp$get_rvsn_by_lun (lun: iot$logical_unit;
    VAR rvsn: rmt$recorded_vsn;
    VAR entry_found: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=DMP$GET_SERVER_DESCRIPTOR EXPAND=FALSE
*DECK DECK=DMP$GET_SERVER_FMD EXPAND=FALSE

  PROCEDURE [XREF] dmp$get_server_fmd
    (    sfid: gft$system_file_identifier;
     VAR stored_fmd: dmt$stored_fmd;
     VAR stored_fmd_size: dmt$stored_fmd_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$stored_fmd
*copyc dmt$stored_fmd_size
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=DMP$GET_STORED_FMD EXPAND=FALSE
 PROCEDURE [XREF] dmp$get_stored_fmd (system_file_id: dmt$system_file_id;
    VAR stored_fmd: dmt$stored_fmd;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc dmt$stored_fmd
*copyc ost$status
?? POP ??
*DECK DECK=DMP$GET_STORED_FMD_HEADER_INFO EXPAND=FALSE

  PROCEDURE [INLINE] dmp$get_stored_fmd_header_info
    (    p_fmd: {input} ^dmt$stored_fmd;
     VAR fmd_header_info: pft$fmd_header;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      p_fmd_header: ^dmt$stored_ms_fmd_header,
      p_fmd_version: ^dmt$stored_ms_version_number,
      p_stored_fmd: ^dmt$stored_fmd;

    status.normal := TRUE;

    p_stored_fmd := p_fmd;
    RESET p_stored_fmd;

    NEXT p_fmd_version IN p_stored_fmd;
    IF p_fmd_version = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
            'FMD too small 1 - dmp$get_stored_fmd_header_info.', status);
      RETURN;
    IFEND;

    NEXT p_fmd_header: [dmc$current_fmd_version] IN p_stored_fmd;
    IF p_fmd_header = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
            'FMD too small 2 - dmp$get_stored_fmd_header_info.', status);
      RETURN;
    IFEND;

    fmd_header_info.clear_space := p_fmd_header^.version_0_0.clear_space;
    fmd_header_info.file_limit := p_fmd_header^.version_0_0.file_limit;
    fmd_header_info.number_of_subfiles :=
          p_fmd_header^.version_0_0.number_fmds;
    fmd_header_info.overflow_allowed := p_fmd_header^.version_0_0.
          overflow_allowed;
    fmd_header_info.preset_value := p_fmd_header^.version_0_0.preset_value;
    fmd_header_info.requested_allocation_size :=
          p_fmd_header^.version_0_0.requested_allocation_size;
    fmd_header_info.requested_class := p_fmd_header^.version_0_0.
          requested_class;
    fmd_header_info.requested_class_ordinal :=
          p_fmd_header^.version_0_0.requested_class_ordinal;
    fmd_header_info.requested_transfer_size :=
          p_fmd_header^.version_0_0.requested_transfer_size;
    fmd_header_info.requested_volume := p_fmd_header^.version_0_0.
          requested_volume;

  PROCEND dmp$get_stored_fmd_header_info;

*copyc dmt$error_condition_codes
*copyc dmt$stored_fmd
*copyc dmt$stored_ms_fmd_header
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc pft$fmd_header
?? POP ??
*DECK DECK=DMP$GET_STORED_FMD_SIZE EXPAND=FALSE
 PROCEDURE [XREF] dmp$get_stored_fmd_size (system_file_id: dmt$system_file_id;
    VAR size_of_stored_fmd: dmt$stored_fmd_size;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc dmt$stored_fmd_size
*copyc ost$status
?? POP ??
*DECK DECK=DMP$GET_STORED_FMD_SUBFILE_LIST EXPAND=FALSE

  PROCEDURE dmp$get_stored_fmd_subfile_list
    (    p_fmd: {input} ^dmt$stored_fmd;
         total_allocated_length: amt$file_byte_address;
     VAR p_subfile_list: {input/output} ^pft$subfile_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      i: dmt$subfile_index,
      p_fmd_header: ^dmt$stored_ms_fmd_header,
      p_fmd_version: ^dmt$stored_ms_version_number,
      p_stored_fmd: ^dmt$stored_fmd,
      p_stored_subfile: ^dmt$stored_ms_fmd_subfile;

    status.normal := TRUE;

    p_stored_fmd := p_fmd;
    RESET p_stored_fmd;

    NEXT p_fmd_version IN p_stored_fmd;
    IF p_fmd_version = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
            'FMD too small 1 - dmp$get_stored_fmd_subfile_list.', status);
      RETURN;
    IFEND;

    NEXT p_fmd_header: [dmc$current_fmd_version] IN p_stored_fmd;
    IF p_fmd_header = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
            'FMD too small 2 - dmp$get_stored_fmd_subfile_list.', status);
      RETURN;
    IFEND;

    IF (p_subfile_list = NIL) OR (UPPERBOUND (p_subfile_list^) < p_fmd_header^.version_0_0.number_fmds) THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$volume_list_too_small,
            'The supplied subfile list is NIL or' CAT ' too small - dmp$get_stored_fmd_subfile_list.',
            status);
      RETURN;
    IFEND;

    FOR i := 1 TO p_fmd_header^.version_0_0.number_fmds DO
      NEXT p_stored_subfile: [dmc$current_fmd_version] IN p_stored_fmd;
      IF p_stored_subfile = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
              'FMD too small 3 - dmp$get_stored_fmd_subfile_list.', status);
        RETURN;
      IFEND;

      p_subfile_list^ [i].recorded_vsn := p_stored_subfile^.version_0_0.recorded_vsn;
      p_subfile_list^ [i].byte_address := p_stored_subfile^.version_0_0.stored_byte_address *
            dmc$byte_address_converter;
    FOREND;

    IF p_fmd_header^.version_0_0.number_fmds = 1 THEN
      p_subfile_list^ [1].allocated_length := total_allocated_length;
      RETURN;
    IFEND;

    FOR i := 2 TO p_fmd_header^.version_0_0.number_fmds DO
      p_subfile_list^ [i - 1].allocated_length := p_subfile_list^ [i].
            byte_address - p_subfile_list^ [i - 1].byte_address;
    FOREND;
    p_subfile_list^ [p_fmd_header^.version_0_0.number_fmds].allocated_length :=
          total_allocated_length - p_subfile_list^ [p_fmd_header^.version_0_0.number_fmds].byte_address;

  PROCEND dmp$get_stored_fmd_subfile_list;

*copyc dmt$error_condition_codes
*copyc dmt$stored_fmd
*copyc dmt$stored_ms_fmd_header
*copyc dmt$subfile_index
*copyc ost$status
*copyc pft$subfile_list
?? POP ??
*DECK DECK=DMP$GET_STORED_FMD_VOLUME_LIST EXPAND=FALSE

  PROCEDURE dmp$get_stored_fmd_volume_list
    (    p_fmd: {input} ^dmt$stored_fmd;
     VAR p_volume_list: {input/output} ^pft$volume_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      p_fmd_header: ^dmt$stored_ms_fmd_header,
      p_fmd_version: ^dmt$stored_ms_version_number,
      p_stored_fmd: ^dmt$stored_fmd,
      p_stored_subfile: ^dmt$stored_ms_fmd_subfile,
      subfile_count: dmt$subfile_index;

    status.normal := TRUE;

    p_stored_fmd := p_fmd;
    RESET p_stored_fmd;

    NEXT p_fmd_version IN p_stored_fmd;
    IF p_fmd_version = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
            'FMD too small 1 - dmp$get_stored_fmd_volume_list.', status);
      RETURN;
    IFEND;

    NEXT p_fmd_header: [dmc$current_fmd_version] IN p_stored_fmd;
    IF p_fmd_header = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
            'FMD too small 2 - dmp$get_stored_fmd_volume_list.', status);
      RETURN;
    IFEND;

    IF (p_volume_list = NIL) OR (UPPERBOUND (p_volume_list^) <
          p_fmd_header^.version_0_0.number_fmds) THEN
      osp$set_status_abnormal (dmc$device_manager_ident,
            dme$volume_list_too_small, 'The supplied volume list is NIL or' CAT
            ' too small - dmp$get_stored_fmd_volume_list.', status);
      RETURN;
    IFEND;

    FOR subfile_count := 1 TO p_fmd_header^.version_0_0.number_fmds DO
      NEXT p_stored_subfile: [dmc$current_fmd_version] IN p_stored_fmd;
      IF p_stored_subfile = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
              'FMD too small 3 - dmp$get_stored_fmd_volume_list.', status);
        RETURN;
      IFEND;

      p_volume_list^ [subfile_count] := p_stored_subfile^.version_0_0.
            recorded_vsn;
    FOREND;
  PROCEND dmp$get_stored_fmd_volume_list;

*copyc dmt$error_condition_codes
*copyc dmt$stored_fmd
*copyc dmt$stored_ms_fmd_header
*copyc dmt$subfile_index
*copyc ost$status
*copyc pft$volume_list
?? POP ??
*DECK DECK=DMP$GET_TAPE_VOLUME_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] dmp$get_tape_volume_information (
        sfid: gft$system_file_identifier;
    VAR number_of_volumes: amt$volume_number;
    VAR current_volume_number: amt$volume_number;
    VAR current_vsns: rmt$volume_descriptor;
    VAR density: rmt$density;
    VAR write_ring: rmt$write_ring;
    VAR requested_volume_attributes: iot$requested_volume_attributes;
    VAR volume_overflow_allowed: boolean;
    VAR label_type: amt$label_type;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$label_type
*copyc amt$volume_number
*copyc gft$system_file_identifier
*copyc iot$requested_volume_attributes
*copyc ost$status
*copyc rmt$density
*copyc rmt$tape_class
*copyc rmt$volume_descriptor
*copyc rmt$write_ring
?? POP ??
*DECK DECK=DMP$GET_TAPE_VOLUME_LIST EXPAND=FALSE

  PROCEDURE [XREF] dmp$get_tape_volume_list
    (    sfid: gft$system_file_identifier;
         volume_list: ^rmt$volume_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc ost$status
*copyc rmt$volume_list
?? POP ??
*DECK DECK=DMP$GET_TOTAL_ALLOCATED_LENGTH EXPAND=FALSE


    PROCEDURE [XREF] dmp$get_total_allocated_length
      (    fde_p: gft$locked_file_desc_entry_p;
       VAR allocated_length: amt$file_byte_address);


?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc gft$locked_file_desc_entry_p
?? POP ??
*DECK DECK=DMP$GET_UNIQUE_FMD_VOLUME_LIST EXPAND=FALSE

  PROCEDURE dmp$get_unique_fmd_volume_list
    (    p_fmd: {input} ^dmt$stored_fmd;
     VAR p_unique_volume_list: {input/output} ^pft$unique_volume_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      p_fmd_header: ^dmt$stored_ms_fmd_header,
      p_fmd_version: ^dmt$stored_ms_version_number,
      p_stored_fmd: ^dmt$stored_fmd,
      p_stored_subfile: ^dmt$stored_ms_fmd_subfile,
      subfile_count: dmt$subfile_index;

    status.normal := TRUE;

    p_stored_fmd := p_fmd;
    RESET p_stored_fmd;

    NEXT p_fmd_version IN p_stored_fmd;
    IF p_fmd_version = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
            'FMD too small 1 - dmp$get_stored_fmd_volume_list.', status);
      RETURN;
    IFEND;

    NEXT p_fmd_header: [dmc$current_fmd_version] IN p_stored_fmd;
    IF p_fmd_header = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
            'FMD too small 2 - dmp$get_stored_fmd_volume_list.', status);
      RETURN;
    IFEND;

    IF (p_unique_volume_list = NIL) OR
          (UPPERBOUND (p_unique_volume_list^) < p_fmd_header^.version_0_0.number_fmds) THEN
      osp$set_status_abnormal (dmc$device_manager_ident,
            dme$volume_list_too_small, 'The supplied volume list is NIL or' CAT
            ' too small - dmp$get_stored_fmd_volume_list.', status);
      RETURN;
    IFEND;

    FOR subfile_count := 1 TO p_fmd_header^.version_0_0.number_fmds DO
      NEXT p_stored_subfile: [dmc$current_fmd_version] IN p_stored_fmd;
      IF p_stored_subfile = NIL THEN
        osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
              'FMD too small 3 - dmp$get_stored_fmd_volume_list.', status);
        RETURN;
      IFEND;
      p_unique_volume_list^ [subfile_count].internal_vsn := p_stored_subfile^.version_0_0.internal_vsn;
      p_unique_volume_list^ [subfile_count].recorded_vsn := p_stored_subfile^.version_0_0.recorded_vsn;
    FOREND;
  PROCEND dmp$get_unique_fmd_volume_list;

*copyc dmt$error_condition_codes
*copyc dmt$stored_fmd
*copyc dmt$stored_ms_fmd_header
*copyc dmt$subfile_index
*copyc ost$status
*copyc pft$unique_volume_list
?? POP ??
*DECK DECK=DMP$GET_UNUSED_AVT_ENTRY EXPAND=FALSE
 PROCEDURE [XREF] dmp$get_unused_avt_entry (VAR avt_index:
  dmt$active_volume_table_index;
    VAR able_to_get_avt_entry: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
?? POP ??
*DECK DECK=DMP$GET_UNUSED_MFL_ENTRY EXPAND=FALSE
 PROCEDURE [XREF] dmp$get_unused_mfl_entry (avt_index:
  dmt$active_volume_table_index;
    VAR dfl_index: dmt$device_file_list_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$device_file_list_index
*copyc dmt$active_volume_table_index
*copyc ost$status
?? POP ??
*DECK DECK=DMP$GET_VOLUMES_ACTIVE EXPAND=FALSE

{ COMMON DECK DMXGVA }

  PROCEDURE [XREF] dmp$get_volume_active (lun: iot$logical_unit;
        pid: cmt$product_identification;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc CMT$PRODUCT_IDENTIFICATION
*copyc IOT$LOGICAL_UNIT
?? POP ??
*DECK DECK=DMP$GET_VOLUME_ATTRIBUTES EXPAND=TRUE
  PROCEDURE [XREF] dmp$get_volume_attributes (logical_unit_number: iot$logical_unit;
    VAR volume_attribute_info: dmt$volume_attribute_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$volume_attribute_info
*copyc iot$logical_unit
*copyc ost$status
?? POP ??
*DECK DECK=DMP$IDENTIFY_FLAWED_DAUS EXPAND=FALSE
  PROCEDURE [XREF] dmp$identify_flawed_daus (recorded_vsn: rmt$recorded_vsn;
        p_flaw_dau_definition: ^array [1 .. *] of dmt$flaw_dau_definition;
        p_flaw_duplication: ^array [1 .. *] of dmt$flaw_duplication;
    VAR big_enough_array: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc rmt$recorded_vsn
*copyc dmt$flaw_dau_definition
*copyc dmt$flaw_duplication
*copyc ost$status
?? POP ??


*DECK DECK=DMP$IDLE_SYSTEM EXPAND=FALSE

  PROCEDURE [XREF] dmp$idle_system;
*DECK DECK=DMP$INCREASE_FAU_COUNT EXPAND=FALSE
*DECK DECK=DMP$INCREASE_FMD_COUNT EXPAND=FALSE

  PROCEDURE [XREF] dmp$increase_fmd_count
    (    system_file_id: gft$system_file_identifier;
         p_dfd: ^dmt$disk_file_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$disk_file_descriptor
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=DMP$INCREMENT_CLASS_ACTIVITY EXPAND=FALSE

  PROCEDURE [XREF] dmp$increment_class_activity (
        sfid: dmt$system_file_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??
*DECK DECK=DMP$INHIBIT_UPDATE EXPAND=FALSE
*DECK DECK=DMP$INITIALIZE_DEVICE_LOG EXPAND=FALSE

  PROCEDURE [XREF] dmp$initialize_device_log (device_log_sfid: dmt$system_file_id;
        avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$DEVICE_LOG_ENTRIES
*copyc DMT$SYSTEM_FILE_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$INITIALIZE_MS_VOLUME EXPAND=FALSE
  PROCEDURE [XREF] dmp$initialize_ms_volume (access_code: ost$name;
        owner_id: ost$user_identification;
        unit_type: cmt$unit_type;
        p_physical_attributes: ^dmt$physical_device_attributes;
        p_logical_attributes: ^dmt$logical_device_attributes;
        p_volume_label_attributes: ^dmt$volume_label_attributes;
        logical_unit_number: iot$logical_unit;
        allowed_to_overwrite_volume: boolean;
        retain_device_flaws: boolean;
    VAR initialize_status_info: dmt$initialize_status_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$unit_type
*copyc dmt$initialize_status_info
*copyc dmt$logical_device_attributes
*copyc iot$logical_unit
*copyc dmt$physical_device_attributes
*copyc dmt$volume_label_attributes
*copyc ost$name
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=DMP$INITIALIZE_TAPE_VOLUME EXPAND=FALSE

  PROCEDURE [XREF] dmp$initialize_tape_volume
    (    element_name: cmt$element_name;
         external_vsn: rmt$external_vsn;
         recorded_vsn: rmt$recorded_vsn;
         density: rmt$density;
         owner_identifier: string (14);
         volume_accessibility_code: string (1);
         file_accessibility_code: string (1);
         character_set: amt$internal_code;
         label_standard_version: string (1);
     VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc amt$internal_code
*copyc cmt$element_name
*copyc rmd$volume_declarations
*copyc rmt$density
*copyc ost$status
?? POP ??
*DECK DECK=DMP$ISSUE_MESSAGE_TO_ASCII_LOG EXPAND=FALSE

    PROCEDURE [XREF] dmp$issue_message_to_ascii_log ALIAS 'dmxisml' (
         msg$string: pmt$log_msg_text;
         VAR status:ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMD$SYSTEM_LOG_INTERFACE
*copyc OST$STATUS
   ??POP??
*DECK DECK=DMP$ISSUE_MONITOR_CALL EXPAND=FALSE
*DECK DECK=DMP$JOB_TAPE_TABLE_RECOVERY EXPAND=FALSE
*DECK DECK=DMP$LOCATE_EXISTING_SFT_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] dmp$locate_existing_sft_entry
    (    global_file_name: dmt$global_file_name;
         file_kind: gft$file_kind;
     VAR existing_sft_entry: dmt$existing_sft_entry;
     VAR file_info: dmt$file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$existing_sft_entry
*copyc dmt$global_file_name
*copyc dmt$file_information
*copyc gft$file_kind
*copyc ost$status
?? POP ??
*DECK DECK=DMP$LOCATE_VOLUME_LABEL EXPAND=FALSE
  PROCEDURE [XREF] dmp$locate_volume_label (logical_unit_number:
    iot$logical_unit;
        p_physical_attributes: ^dmt$physical_device_attributes;
    VAR ms_volume_label: dmt$ms_volume_label;
    VAR able_to_locate_vol_label: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$ms_volume_label
*copyc dmt$physical_device_attributes
*copyc iot$logical_unit
?? POP ??
*DECK DECK=DMP$LOCK_AVT_ENTRY EXPAND=FALSE
 PROCEDURE [XREF] dmp$lock_avt_entry (avt_index: dmt$active_volume_table_index;
    VAR able_to_lock_avt_entry: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
?? POP ??
*DECK DECK=DMP$LOGOUT_RECOVERED_MAINFRAME EXPAND=FALSE
 PROCEDURE [XREF] dmp$logout_recovered_mainframe (avt_index:
  dmt$active_volume_table_index;
        lt_entry_index: dmt$login_table_entries;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc dmt$mainframe_assigned
*copyc ost$status
?? POP ??
*DECK DECK=DMP$LOG_ABNORMAL_STATUS EXPAND=FALSE

   PROCEDURE [XREF] dmp$log_abnormal_status ALIAS 'dmxlabs' (
     VAR status:ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
   ??POP??
*DECK DECK=DMP$MANAGEMENT_OF_VOLUME_SPACE EXPAND=FALSE
     PROCEDURE [XREF] dmp$management_of_volume_space ALIAS 'dmxmvsp';
?? PUSH (LISTEXT := ON) ??
?? POP ??
*DECK DECK=DMP$MFH_FOR_SFID EXPAND=FALSE
*DECK DECK=DMP$MM_LOG_SFT_DELETE EXPAND=FALSE

  PROCEDURE [XREF] dmp$mm_log_sft_delete
    (    system_file_id: gft$system_file_identifier;
     VAR status: ost$status);

?? PUSH( LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=DMP$MTR_ALLOCATE_FRONT_END EXPAND=FALSE
*DECK DECK=DMP$MTR_DEALLOCATE_FRONT_END EXPAND=FALSE
*DECK DECK=DMP$MTR_FETCH_FILE_DESCRIPTOR EXPAND=FALSE
*DECK DECK=DMP$MTR_LOG EXPAND=FALSE

  PROCEDURE [XREF] dmp$mtr_log (entry: dmt$al_entry;
    VAR able_to_log: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc DMT$ALLOCATION_LOG
?? POP ??
*DECK DECK=DMP$MTR_REALLOCATE_FILE_SPACE EXPAND=FALSE
  PROCEDURE [XREF] dmp$mtr_reallocate_file_space (VAR reallocate_request_block:
    dmt$monitor_rb_reallocate_space);
?? PUSH (LISTEXT := ON) ??
*copyc dmt$monitor_request_blocks
?? POP ??
*DECK DECK=DMP$MTR_VALIDATE_SFID EXPAND=FALSE
*DECK DECK=DMP$OBTAIN_ASSIGNED_ELEMENT EXPAND=FALSE

  PROCEDURE [XREF] dmp$obtain_assigned_element
    (    local_file_name: amt$local_file_name;
     VAR assigned_element: cmt$element_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=DMP$OPEN_DAT EXPAND=FALSE
  PROCEDURE [XREF] dmp$open_dat (dat_sfid: dmt$system_file_id;
         ring1: ost$valid_ring;
         ring2: ost$valid_ring;
         access_rights: mmt$segment_access_rights;
         access_selections: mmt$access_selections;
     VAR p_dat: ^dmt$ms_device_allocation_table;
     VAR status: ost$status);

*copyc dmt$system_file_id
*copyc osd$virtual_address
*copyc mmt$segment_access_rights
*copyc mmt$access_selections
*copyc ost$status
*copyc dmt$ms_device_allocation_table
*DECK DECK=DMP$OPEN_DAT_R3 EXPAND=FALSE

  PROCEDURE [XREF] dmp$open_dat_r3 (recorded_vsn: rmt$recorded_vsn;
    VAR p_dat: ^dmt$ms_device_allocation_table;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc DMT$MS_DEVICE_ALLOCATION_TABLE
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$OPEN_DEVICE_FILE_R3 EXPAND=FALSE
*DECK DECK=DMP$OPEN_DFLT EXPAND=FALSE
  PROCEDURE [XREF] dmp$open_dflt (dflt_sfid: dmt$system_file_id;
         ring1: ost$valid_ring;
         ring2: ost$valid_ring;
         access_rights: mmt$segment_access_rights;
         access_selections: mmt$access_selections;
     VAR p_dflt: ^dmt$ms_device_file_list_table;
     VAR status: ost$status);

*copyc dmt$system_file_id
*copyc osd$virtual_address
*copyc mmt$segment_access_rights
*copyc mmt$access_selections
*copyc ost$status
*copyc dmt$ms_device_file_list_entry
*DECK DECK=DMP$OPEN_DFL_R3 EXPAND=FALSE
  PROCEDURE [XREF] dmp$open_dfl_r3
    (    recorded_vsn: rmt$recorded_vsn;
     VAR p_dfl: ^dmt$ms_device_file_list_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$ms_device_file_list_entry
*copyc rmd$volume_declarations
*copyc ost$status
?? POP ??
*DECK DECK=DMP$OPEN_DIRECTORY EXPAND=FALSE
  PROCEDURE [XREF] dmp$open_directory (directory_sfid: dmt$system_file_id;
         ring1: ost$valid_ring;
         ring2: ost$valid_ring;
         access_rights: mmt$segment_access_rights;
         access_selections: mmt$access_selections;
     VAR p_directory: ^dmt$ms_volume_directory;
     VAR status: ost$status);

*copyc dmt$system_file_id
*copyc osd$virtual_address
*copyc mmt$segment_access_rights
*copyc mmt$access_selections
*copyc ost$status
*copyc dmt$ms_volume_directory
*DECK DECK=DMP$OPEN_DIRECTORY_R3 EXPAND=FALSE

  PROCEDURE [XREF] dmp$open_directory_r3 (recorded_vsn: rmt$recorded_vsn;
    VAR p_directory: ^dmt$ms_volume_directory;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc DMT$MS_VOLUME_DIRECTORY
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$OPEN_FILE EXPAND=FALSE
  PROCEDURE [XREF] dmp$open_file (sfid: gft$system_file_identifier;
         ring1: ost$valid_ring;
         ring2: ost$valid_ring;
         access_rights: mmt$segment_access_rights;
         access_selections: mmt$access_selections;
     VAR segment_pointer: mmt$segment_pointer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc osd$virtual_address
*copyc mmt$segment_access_rights
*copyc mmt$access_selections
*copyc ost$status
*copyc mmt$attribute_keyword
?? POP ??
*DECK DECK=DMP$OPEN_FILE_FOR_RECOVERY EXPAND=FALSE
*DECK DECK=DMP$OPEN_LABEL EXPAND=FALSE

  PROCEDURE [XREF] dmp$open_label
    (    label_sfid: dmt$system_file_id;
         ring1: ost$valid_ring;
         ring2: ost$valid_ring;
         access_rights: mmt$segment_access_rights;
         access_selections: mmt$access_selections;
     VAR p_label: ^dmt$ms_volume_label;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$ms_volume_label
*copyc dmt$system_file_id
*copyc mmt$segment_access_rights
*copyc mmt$access_selections
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=DMP$OPEN_LABEL_R3 EXPAND=FALSE

  PROCEDURE [XREF] dmp$open_label_r3 (recorded_vsn: rmt$recorded_vsn;
    VAR p_label: ^dmt$ms_volume_label;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc DMT$MS_VOLUME_LABEL
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$OPEN_LOGIN_TABLE EXPAND=FALSE
  PROCEDURE [XREF] dmp$open_login_table (sfid: dmt$system_file_id;
         ring1: ost$valid_ring;
         ring2: ost$valid_ring;
         access_rights: mmt$segment_access_rights;
         access_selections: mmt$access_selections;
     VAR p_login_table: ^dmt$ms_mainframe_login_table;
     VAR status: ost$status);

*copyc dmt$system_file_id
*copyc osd$virtual_address
*copyc mmt$segment_access_rights
*copyc mmt$access_selections
*copyc ost$status
*copyc dmt$ms_login_table

*DECK DECK=DMP$OPEN_LOGIN_TABLE_R3 EXPAND=FALSE
  PROCEDURE [XREF] dmp$open_login_table_r3
    (    recorded_vsn: rmt$recorded_vsn;
     VAR p_login_table: ^dmt$ms_mainframe_login_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$ms_login_table
*copyc ost$status
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=DMP$OPEN_LOG_R3 EXPAND=FALSE
  PROCEDURE [XREF] dmp$open_log_r3
    (    recorded_vsn: rmt$recorded_vsn;
     VAR p_log: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=DMP$PRESET_CONVERSION EXPAND=FALSE

  FUNCTION [INLINE] dmp$preset_conversion
    (    preset_value_ord: pmt$initialization_value): integer;

?? PUSH (LISTEXT := ON) ??

   dmp$preset_conversion := mmv$preset_conversion_table [preset_value_ord];

 FUNCEND dmp$preset_conversion;

*copyc mmv$preset_conversion_table
*copyc pmt$initialization_value
?? POP ??
*DECK DECK=DMP$PROCESS_DAS_RESTORE EXPAND=FALSE
  PROCEDURE [XREF] dmp$process_das_restore (logical_unit_number: iot$logical_unit;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc ost$status
?? POP ??
*DECK DECK=DMP$PROCESS_DEVICE_LOG_ENTRY EXPAND=FALSE
 PROCEDURE [XREF] dmp$process_device_log_entry (avt_index:
  dmt$active_volume_table_index,
        device_log_entry: dmt$dl_entry;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$device_log_entries
*copyc dmt$active_volume_table_index
*copyc ost$status
?? POP ??
*DECK DECK=DMP$PROCESS_FORCE_FORMAT EXPAND=FALSE
  PROCEDURE [XREF] dmp$process_force_format (logical_unit_number: iot$logical_unit;
        force_format: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc ost$status
?? POP ??
*DECK DECK=DMP$PROCESS_MANUAL_FLAW EXPAND=FALSE
  PROCEDURE [XREF] dmp$process_manual_flaw (recorded_vsn: rmt$recorded_vsn;
        dau_address: dmt$dau_address;
        end_dau_address: dmt$dau_address;
        flaw_operation_code: dmt$flaw_operation_code;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$device_allocation_unit
*copyc dmt$log_flaw_init_data
*copyc ost$status
*copyc rmt$recorded_vsn
?? POP ??



*DECK DECK=DMP$PROCESS_SC_FLAW_COMMANDS EXPAND=FALSE
  PROCEDURE [XREF] dmp$process_sc_flaw_commands (avt_index: dmt$active_volume_table_index;
        dat_sfid: dmt$system_file_id;
        recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc rmt$recorded_vsn
*copyc ost$status
?? POP ??

*DECK DECK=DMP$PUT_STORED_FMD_HEADER_INFO EXPAND=FALSE

  PROCEDURE dmp$put_stored_fmd_header_info
    (    fmd_header_info: pft$fmd_header;
         p_fmd: {i/o} ^dmt$stored_fmd;
     VAR status: ost$status);


    VAR
      p_fmd_header: ^dmt$stored_ms_fmd_header,
      p_fmd_version: ^dmt$stored_ms_version_number,
      p_stored_fmd: ^dmt$stored_fmd;

    status.normal := TRUE;

    p_stored_fmd := p_fmd;
    RESET p_stored_fmd;

    NEXT p_fmd_version IN p_stored_fmd;
    IF p_fmd_version = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
            'FMD too small 1 - dmp$put_stored_fmd_header_info.', status);
      RETURN;
    IFEND;

    NEXT p_fmd_header: [dmc$current_fmd_version] IN p_stored_fmd;
    IF p_fmd_header = NIL THEN
      osp$set_status_abnormal (dmc$device_manager_ident, dme$fmd_too_small,
            'FMD too small 2 - dmp$put_stored_fmd_header_info.', status);
      RETURN;
    IFEND;

    p_fmd_header^.version_0_0.clear_space := fmd_header_info.clear_space;
    p_fmd_header^.version_0_0.file_limit := fmd_header_info.file_limit;
    p_fmd_header^.version_0_0.overflow_allowed := fmd_header_info.overflow_allowed;
    p_fmd_header^.version_0_0.preset_value := fmd_header_info.preset_value;
    p_fmd_header^.version_0_0.requested_allocation_size := fmd_header_info.requested_allocation_size;
    p_fmd_header^.version_0_0.requested_class := fmd_header_info.requested_class;
    p_fmd_header^.version_0_0.requested_class_ordinal := fmd_header_info.requested_class_ordinal;
    p_fmd_header^.version_0_0.requested_transfer_size := fmd_header_info.requested_transfer_size;
    p_fmd_header^.version_0_0.requested_volume := fmd_header_info.requested_volume;

  PROCEND dmp$put_stored_fmd_header_info;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$error_condition_codes
*copyc dmt$stored_fmd
*copyc dmt$stored_ms_fmd_header
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc pft$fmd_header
?? POP ??
*DECK DECK=DMP$R2_INCREASE_FAU_COUNT EXPAND=FALSE
 PROCEDURE [XREF] dmp$r2_increase_fau_count
   (    system_file_id: gft$system_file_identifier;
        number_allocation_units_needed: dmt$fau_entries;
        byte_address: amt$file_byte_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$file_allocation_descriptor
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??

*DECK DECK=DMP$READ EXPAND=FALSE

  PROCEDURE [XREF] dmp$read ALIAS 'dmxread'
    (    fde_p: gft$locked_file_desc_entry_p;
         byte_address: amt$file_byte_address;
         length: amt$file_byte_address;
     VAR device_address: dmt$ms_logical_device_address;
     VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmt$ms_logical_device_address
*copyc gft$locked_file_desc_entry_p
*copyc syt$monitor_request_code
?? POP ??
*DECK DECK=DMP$REALLOCATE_FILE_SPACE EXPAND=FALSE
PROCEDURE [XREF] dmp$reallocate_file_space (sfid: dmt$system_file_id;
        copy_pages: boolean;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??
*DECK DECK=DMP$REASSIGN_FILE EXPAND=FALSE
  PROCEDURE [XREF] dmp$reassign_file
    (    system_file_id: dmt$system_file_id;
         bytes_to_allocate: amt$file_byte_address;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??
*DECK DECK=DMP$REASSIGN_FILE_R3 EXPAND=FALSE

  PROCEDURE [XREF] dmp$reassign_file_r3 (ptr: ^cell;
                           VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DMP$RECONCILE_FMD EXPAND=FALSE
 PROCEDURE [XREF] dmp$reconcile_fmd (reconcile_locator: dmt$reconcile_locator;
        global_file_name: dmt$global_file_name;
        stored_fmd: dmt$stored_fmd;
        purge_file: boolean;
    VAR device_class: dmt$class;
    VAR stored_fmd_size: dmt$stored_fmd_size;
    VAR resides_on_system_device: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$error_condition_codes
*copyc dmt$global_file_name
*copyc dmt$reconcile_locator
*copyc dmt$stored_fmd
*copyc dmt$stored_fmd_size
*copyc dmt$class
*copyc ost$status
?? POP ??
*DECK DECK=DMP$RECORD_SC_FLAW EXPAND=FALSE
  PROCEDURE [XREF] dmp$record_sc_flaw (applicable_flaw_count: integer;
        p_dat: ^dmt$ms_device_allocation_table;
        p_sc_dau_list: ^array [1 .. *] of dmt$log_flaw_init_data);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$log_flaw_init_data
*copyc dmt$ms_device_allocation_table
?? POP ??


*DECK DECK=DMP$RECOVER_FILE EXPAND=FALSE

  PROCEDURE [XREF] dmp$recover_file
    (    p_old_fde: gft$file_desc_entry_p;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$file_desc_entry_p
*copyc ost$status
?? POP ??
*DECK DECK=DMP$RECOVER_JOB_DM_TABLES EXPAND=FALSE

  PROCEDURE [XREF] dmp$recover_job_dm_tables
    (    ijle_p: ^jmt$initiated_job_list_entry);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=DMP$RECOVER_JOB_TEMP_FILE_SPACE EXPAND=FALSE
  PROCEDURE [XREF] dmp$recover_job_temp_file_space (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DMP$RECOVER_MAINFRAME EXPAND=FALSE

  PROCEDURE [XREF] dmp$recover_mainframe (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$RECOVER_VOLUME EXPAND=FALSE
 PROCEDURE [XREF] dmp$recover_volume (avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc ost$status
?? POP ??
*DECK DECK=DMP$RELEASE_AVT_ENTRY EXPAND=FALSE
*DECK DECK=DMP$RELEASE_FILE_MEDIUM_DESC EXPAND=FALSE
*DECK DECK=DMP$RELEASE_SERVER_DESCRIPTOR EXPAND=FALSE

{ The deck/procedure dmp$release_server_descriptor has been deleted as a part of the feature NEW_MM_DM_TYPES.
{ Use the deck/procedure dfp$release_server_descriptor instead.

*DECK DECK=DMP$RELEASE_TAPE EXPAND=FALSE
*DECK DECK=DMP$REPLACE_CLIENT_SFT EXPAND=FALSE

  PROCEDURE [XREF] dmp$replace_client_sft
    (    old_global_file_name: dmt$global_file_name;
         new_global_file_name: dmt$global_file_name;
         new_remote_sfid: gft$system_file_identifier;
     VAR new_client_sfid: gft$system_file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$global_file_name
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=DMP$REPLACE_TAPE_VSN_LIST EXPAND=FALSE

  PROCEDURE [XREF] dmp$replace_tape_vsn_list
    (    sfid: gft$system_file_identifier;
         p_volume_list: {input} ^rmt$volume_list;
         volume_overflow_allowed: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc rmt$volume_list
*copyc ost$status
?? POP ??
*DECK DECK=DMP$RESERVE_FMD EXPAND=FALSE

  PROCEDURE [XREF] dmp$reserve_fmd
    (    p_dfd: ^dmt$disk_file_descriptor;
     VAR fmd_index: dmt$fmd_index;
     VAR able_to_reserve_fmd: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$disk_file_descriptor
*copyc dmt$fmd_index
?? POP ??
*DECK DECK=DMP$RESERVE_TAPE EXPAND=FALSE
*DECK DECK=DMP$RESET_TAPE_VOLUME EXPAND=TRUE

  PROCEDURE [XREF] dmp$reset_tape_volume
    (    sfid: gft$system_file_identifier;
         label_type: amt$label_type;
         access_mode: pft$usage_selections;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$label_type
*copyc gft$system_file_identifier
*copyc ost$status
*copyc pfd$permanent_file_attributes
?? POP ??
*DECK DECK=DMP$RESUME_SYSTEM EXPAND=FALSE

  PROCEDURE [XREF] dmp$resume_system;
*DECK DECK=DMP$RETRIEVE_ALLOCATION_INFO EXPAND=FALSE
 PROCEDURE [XREF] dmp$retrieve_allocation_info (p_dfl_entry:
    ^dmt$ms_device_file_list_entry;
        avt_index: dmt$active_volume_table_index;
    VAR allocated_length: amt$file_byte_address;
    VAR initialized_length: amt$file_byte_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$ms_device_file_list_entry
*copyc dmt$active_volume_table_index
*copyc amt$file_byte_address
*copyc ost$status
?? POP ??
*DECK DECK=DMP$RETURN_DAT_ENTRIES EXPAND=FALSE
 PROCEDURE [XREF] dmp$return_dat_entries (mainframe_assigned:
  dmt$mainframe_assigned;
        avt_index: dmt$active_volume_table_index;
    return_option: dmt$dat_return_option;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$mainframe_assigned
*copyc dmt$active_volume_table_index
*copyc dmt$dat_return_option
*copyc ost$status
?? POP ??
*DECK DECK=DMP$RETURN_DFL_ENTRIES EXPAND=FALSE
 PROCEDURE [XREF] dmp$return_dfl_entries (mainframe_assigned:
  dmt$mainframe_assigned;
        avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$mainframe_assigned
*copyc dmt$active_volume_table_index
*copyc ost$status
?? POP ??
*DECK DECK=DMP$RETURN_MAT_SPACE EXPAND=FALSE
  PROCEDURE [XREF] dmp$return_mat_space (p_old_mat: cyt$adaptable_array_pointer;
        mainframe_assigned: dmt$mainframe_assigned;
        avt_index: dmt$active_volume_table_index);

?? PUSH (LISTEXT := ON) ??
*copyc cyd$cybil_structure_definitions
*copyc dmt$active_volume_table_index
*copyc dmt$mainframe_assigned
?? POP ??
*DECK DECK=DMP$RETURN_TAPE_RESOURCE EXPAND=FALSE

  PROCEDURE [XREF] dmp$return_tape_resource
    (    reservation: rmt$tape_reservation;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$tape_reservation
?? POP ??
*DECK DECK=DMP$RETURN_TEMP_FILE_SPACE EXPAND=FALSE
  PROCEDURE [XREF] dmp$return_temp_file_space;
*DECK DECK=DMP$SAVE_RECONCILE_LIST EXPAND=FALSE

  PROCEDURE [XREF] dmp$save_reconcile_list (
        reconcile_info: dmt$reconcile_info);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$reconcile_info
?? POP ??
*DECK DECK=DMP$SAVE_RECOVERY_INFO EXPAND=FALSE
  PROCEDURE [XREF] dmp$save_recovery_info;
*DECK DECK=DMP$SAVE_TAPE_INITV_VOL_INFO EXPAND=FALSE
  PROCEDURE [XREF] dmp$save_tape_initv_vol_info
    (    volume_info: dmt$initv_saved_info);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$initv_saved_info
?? POP ??

*DECK DECK=DMP$SEARCH_ACTIVE_VOLUME_TABLE EXPAND=FALSE
 PROCEDURE [XREF] dmp$search_active_volume_table (search_key:
  dmt$avt_search_key;
    VAR avt_index: dmt$active_volume_table_index;
    VAR active_volume_entry_not_found: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$avt_search_key
*copyc dmt$active_volume_table_index
?? POP ??
*DECK DECK=DMP$SEARCH_AVT_BY_VSN EXPAND=FALSE
 PROCEDURE [INLINE] dmp$search_avt_by_vsn (ivsn: dmt$internal_vsn;
    VAR avt_index: dmt$active_volume_table_index;
    VAR found: boolean);
?? PUSH (LISTEXT := ON) ??

    VAR
      search_index: dmt$active_volume_table_index;

    avt_index := 0;
    found := FALSE;

    FOR search_index := LOWERBOUND (dmv$p_active_volume_table^) TO UPPERBOUND
          (dmv$p_active_volume_table^) DO
      IF NOT dmv$p_active_volume_table^ [search_index].entry_available THEN
        IF dmv$p_active_volume_table^ [search_index].mass_storage.internal_vsn = ivsn THEN
          found := TRUE;
          avt_index := search_index;
          RETURN;
        IFEND;
      IFEND;
    FOREND;

 PROCEND dmp$search_avt_by_vsn;
*copyc dmt$internal_vsn
*copyc dmv$active_volume_table
*copyc dmt$active_volume_table_index
?? POP ??
*DECK DECK=DMP$SEARCH_FDT_BY_GFN EXPAND=FALSE

  PROCEDURE [XREF] dmp$search_fdt_by_gfn ALIAS 'dmxsfdt' (file_table_residence:
    gft$table_residence;
    global_file_name: dmt$global_file_name;
    VAR file_entry_index: gft$file_descriptor_index;
    VAR existing_fde_found: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc dmt$global_file_name
*copyc gft$system_file_identifier
  ?? POP ??
*DECK DECK=DMP$SEARCH_LOGIN_TABLE EXPAND=FALSE
  PROCEDURE [XREF] dmp$search_login_table (p_login_table:
    ^dmt$ms_mainframe_login_table;
        login_entry_type: dmt$login_entry_type;
    VAR lt_entry_index: dmt$login_table_entries);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$MS_LOGIN_TABLE
?? POP ??
*DECK DECK=DMP$SEARCH_VOL_DIRECTORY_NAME EXPAND=FALSE
 PROCEDURE [XREF] dmp$search_vol_directory_name (search_name: ost$name;
        directory_sfid: dmt$system_file_id;
    VAR directory_index: dmt$directory_index;
    VAR name_found_in_directory: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc dmt$system_file_id
*copyc dmt$directory_index
*copyc ost$status
?? POP ??
*DECK DECK=DMP$SETUP_TAPE_INIT_IN_PROGRESS EXPAND=FALSE

  PROCEDURE [XREF] dmp$setup_tape_init_in_progress
    (    in_progress: boolean;
         element_name: cmt$element_name;
         logical_unit: iot$logical_unit);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc iot$logical_unit
?? POP ??
*DECK DECK=DMP$SET_EOI EXPAND=FALSE

  PROCEDURE [XREF] dmp$set_eoi ALIAS 'dmxseoi' (system_file_id:
    dmt$system_file_id;
    eoi: amt$file_byte_address;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc DMT$SYSTEM_FILE_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$SET_FAU_STATE EXPAND=FALSE

  PROCEDURE [XREF] dmp$set_fau_state
    (    fde_p: gft$locked_file_desc_entry_p;
         byte_address: amt$file_byte_address;
     VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc gft$locked_file_desc_entry_p
*copyc syt$monitor_request_code
?? POP ??
*DECK DECK=DMP$SET_FILE_LIMIT EXPAND=FALSE

  PROCEDURE [XREF] dmp$set_file_limit (sfid: dmt$system_file_id;
    limit: 0 .. amc$file_byte_limit;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc AMT$FILE_BYTE_ADDRESS
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$SET_FILE_RESIDENCE EXPAND=FALSE

  PROCEDURE [XREF] dmp$set_file_residence
   (    file_kind: gft$file_kind;
    VAR file_table_residence: gft$table_residence;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc gft$file_kind
*copyc gft$table_residence
*copyc ost$status
?? POP ??
*DECK DECK=DMP$SET_FILE_STATE EXPAND=FALSE

  PROCEDURE [XREF] dmp$set_file_state
    (    global_file_name: dmt$global_file_name;
         file_state: dft$server_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$server_state
*copyc ost$status
?? POP ??
*DECK DECK=DMP$SET_FILE_TABLE_LOCATOR EXPAND=FALSE

  PROCEDURE [XREF] dmp$set_file_table_locator
    (file_table_residence: gft$table_residence;
    VAR file_locator: dmt$file_location;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc dmt$file_location
*copyc gft$system_file_identifier
*copyc ost$status
  ?? POP ??
*DECK DECK=DMP$SET_LOWER_PRIORITY EXPAND=FALSE

  PROCEDURE [XREF] dmp$set_lower_priority (task: (split_al_task,
    administer_log_task, volume_space_management_task);
        taskid: ost$global_task_id);
?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
?? POP ??
*DECK DECK=DMP$SET_MASTER_ATTACH_LOCK EXPAND=FALSE

      PROCEDURE [XREF] dmp$set_master_attach_lock (
         system_file_id: gft$system_file_identifier);

?? PUSH(LIST:=ON) ??
*copyc gft$system_file_identifier
??POP??
*DECK DECK=DMP$SET_MENU_LOCK EXPAND=FALSE
*DECK DECK=DMP$SET_MF_LOGIN_TABLE_LOCK EXPAND=FALSE
*DECK DECK=DMP$SET_UPDATE_LOCK EXPAND=FALSE
  PROCEDURE [XREF] dmp$set_update_lock
    (    avt_index: dmt$active_volume_table_index;
         wait_for_lock: boolean;
     VAR able_to_set_lock: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
?? POP ??
*DECK DECK=DMP$SPARSE_ALLOCATE EXPAND=FALSE
  PROCEDURE [XREF] dmp$sparse_allocate
    (    sfid: gft$system_file_identifier;
         offset_requiring_allocation: amt$file_byte_address;
         file_space_limit: sft$file_space_limit_kind;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc gft$system_file_identifier
*copyc sft$file_space_limit_kind
*copyc ost$status
?? POP ??
*DECK DECK=DMP$SPLIT_ALLOCATION_LOG EXPAND=FALSE
  PROCEDURE [XREF] dmp$split_allocation_log
    (    flush_device_log_pages: boolean;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$START_VOLUME_PRODUCTION EXPAND=FALSE
  PROCEDURE [XREF] dmp$start_volume_production (avt_index: dmt$active_volume_table_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc ost$status
?? POP ??
*DECK DECK=DMP$STORE_DEBUG_OPTION_VALUE EXPAND=FALSE

    PROCEDURE [XREF] dmp$store_debug_option_value (name: string (*);
               value: integer;
           VAR status: ost$status);

??PUSH (LISTEXT:= ON)??
*copyc ost$status
??POP??
*DECK DECK=DMP$STORE_EXISTING_DF_FAT EXPAND=FALSE
   PROCEDURE [XREF] dmp$store_existing_df_fat ALIAS 'dmxstfa'
     (    system_file_id: gft$system_file_identifier;
          p_existing_fat: ^dmt$stored_ms_device_file_fat;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$file_allocation_table
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=DMP$STORE_SC_FLAW_COMMAND EXPAND=FALSE
  PROCEDURE [XREF] dmp$store_sc_flaw_command
        (p_sc_flaw: ^dmt$sc_flaw_command);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$sc_flaw_command
?? POP ??
*DECK DECK=DMP$STORE_VALID_CLASS_IN_FMD EXPAND=FALSE
  PROCEDURE [XREF] dmp$store_valid_class_in_fmd
    (    system_file_id: gft$system_file_identifier;
         class: dmt$class_member;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$class
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=DMP$SYSTEM_INITIALIZATION EXPAND=FALSE

  PROCEDURE [XREF] dmp$system_initialization (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$TAKE_VOLUME_OFFLINE EXPAND=FALSE

  PROCEDURE [XREF] dmp$take_volume_offline ALIAS 'dmxtofl'
    (logical_unit_number: iot$logical_unit;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
*copyc OST$STATUS
  ?? POP ??
*DECK DECK=DMP$TAPE_RESERVATIONS_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] dmp$tape_reservations_display
    (    window_id: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=DMP$TAPE_STATUS_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] dmp$tape_status_display
    (    window_id: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=DMP$TERMINATE_SERVER_FILE_LIST EXPAND=FALSE

  PROCEDURE [XREF] dmp$terminate_server_file_list
    (    global_file_name_list: array [1 .. * ] of dmt$global_file_name;
     VAR files_terminated: ost$non_negative_integers;
     VAR files_not_terminated: ost$non_negative_integers);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$global_file_name
*copyc osd$integer_limits
?? POP ??
*DECK DECK=DMP$TRANSFER_UNIT_COMPLETED EXPAND=FALSE

  PROCEDURE [XREF] dmp$transfer_unit_completed ALIAS 'dmxtuc' (job_id:
    jmt$ijl_ordinal;
        system_file_id: dmt$system_file_id;
        byte_address: amt$file_byte_address;
        write_tu_status: dmt$write_tu_status;
        au_was_previously_written: boolean;
        media_error: boolean;
        cylinder: iot$cylinder;
        mau_offset_in_cylinder: dmt$maus_per_position;
        io_function: iot$io_function;
    VAR status: syt$monitor_status);
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc DMT$SYSTEM_FILE_ID
*copyc SYT$MONITOR_REQUEST_CODE
*copyc JMT$IJL_ORDINAL
*copyc DMT$MS_LOGICAL_DEVICE_ADDRESS
*copyc IOT$CYLINDER
*copyc DMT$MINIMUM_ALLOCATION_UNIT
*copyc iot$io_function
  ?? POP ??
*DECK DECK=DMP$TRANSFER_UNIT_WRITTEN EXPAND=FALSE
*DECK DECK=DMP$TRIM_FILE EXPAND=FALSE

  PROCEDURE [XREF] dmp$trim_file (sfid: dmt$system_file_id;
                                  byte_address: amt$file_byte_address;
                              VAR status: ost$status);
??push (listext := on) ??
*copyc dmt$system_file_id
*copyc amt$file_byte_address
*copyc ost$status
?? pop ??
*DECK DECK=DMP$UNCONDITIONAL_GET_DFD_P EXPAND=FALSE
  PROCEDURE [INLINE] dmp$unconditional_get_dfd_p (fde_p: gft$file_desc_entry_p;
    VAR dfd_p: ^dmt$disk_file_descriptor);

?? PUSH (LISTEXT := ON) ??

    VAR
      local_fde_p: ^gft$file_descriptor_entry,
      pva: gft$trick_pointer;

{
{ The fde is not being checked for media = mass storage file.
{

    local_fde_p := fde_p;
    pva.p := local_fde_p;
    pva.pva.offset := local_fde_p^.disk_file_descriptor_p;
    dfd_p := pva.p;

  PROCEND;
*copyc dmt$disk_file_descriptor
*copyc gft$file_descriptor_entry
*copyc gft$file_desc_entry_p
*copyc gft$trick_pointer
?? POP ??
*DECK DECK=DMP$UNCONDITIONAL_GET_FDE EXPAND=FALSE
*DECK DECK=DMP$UNLOAD_REMOUNT_TAPE_VOLUME EXPAND=FALSE

{        unload_remount_tape_volume xref

  PROCEDURE [XREF] dmp$unload_remount_tape_volume (
        sfid: gft$system_file_identifier;
        access_mode: pft$usage_selections;
        recovery_remount: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc ost$status
*copyc pfd$permanent_file_attributes
?? POP ??
*DECK DECK=DMP$UNLOCK_AVT_ENTRY EXPAND=FALSE
 PROCEDURE [XREF] dmp$unlock_avt_entry (avt_index:
  dmt$active_volume_table_index;
    VAR lock_cleared: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
?? POP ??
*DECK DECK=DMP$UPDATE_RECONCILE_LIST EXPAND=FALSE

  PROCEDURE [XREF] dmp$update_reconcile_list
    (    subfile_index: dmt$reconcile_index;
         purge_file: boolean;
         reconciled: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$reconcile_info
?? POP ??
*DECK DECK=DMP$UPDATE_STT EXPAND=FALSE
{        update system tape table xref

  PROCEDURE [XREF] dmp$update_stt (lun:
    iot$logical_unit;
    old_state: cmt$element_state;
    new_state : cmt$element_state;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
*copyc CMT$ELEMENT_STATE
*copyc OST$STATUS
?? POP ??
*DECK DECK=DMP$UPDATE_TAPE_VSN_LIST EXPAND=FALSE

  PROCEDURE [XREF] dmp$update_tape_vsn_list
    (    sfid: gft$system_file_identifier;
         file: fst$path_handle_name;
         volume_descriptor: rmt$volume_descriptor;
         requested_volume_attributes: iot$requested_volume_attributes;
         source_pool: ost$name;
         source_pool_location: ost$name;
         tape_assignment_operation: dmt$tape_assignment_operation;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$tape_assignment_operation
*copyc fst$path_handle_name
*copyc gft$system_file_identifier
*copyc iot$requested_volume_attributes
*copyc ost$name
*copyc ost$status
*copyc rmt$volume_descriptor
?? POP ??
*DECK DECK=DMP$UPDATE_VOLUME_TABLES EXPAND=FALSE
*DECK DECK=DMP$UTILITY_FLUSH_LOGS EXPAND=FALSE

  PROCEDURE [XREF] dmp$utility_flush_logs;
*DECK DECK=DMP$UTILITY_FLUSH_LOGS_R3 EXPAND=FALSE

  PROCEDURE [XREF] dmp$utility_flush_logs_r3;
*DECK DECK=DMP$VALIDATE_CLASS_AND_DENSITY EXPAND=FALSE
*DECK DECK=DMP$VALIDATE_SFID EXPAND=FALSE
*DECK DECK=DMP$VALIDATE_SFID_WITH_GFN EXPAND=FALSE

  PROCEDURE [XREF] dmp$validate_sfid_with_gfn
    (    system_file_id: dmt$system_file_id;
         global_file_name: dmt$global_file_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$global_file_name
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??

*DECK DECK=DMP$VALIDATE_TAPE_DENSITY EXPAND=FALSE

  PROCEDURE [XREF] dmp$validate_tape_density (
        density: rmt$density;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$density
?? POP ??
*DECK DECK=DMP$VALIDATE_TAPE_ELEMENT EXPAND=FALSE

  PROCEDURE [XREF] dmp$validate_tape_element
    (    lun: iot$logical_unit;
         tape_density: rmt$density;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc ost$status
*copyc rmt$density
?? POP ??
*DECK DECK=DMP$VERIFY_ACCESS EXPAND=FALSE
  PROCEDURE [XREF] dmp$verify_access
    (    avti: dmt$active_volume_table_index;
     VAR ok: boolean);
*DECK DECK=DMP$VERIFY_JOB_VOLUMES EXPAND=FALSE

  PROCEDURE [XREF] dmp$verify_job_volumes
    (    job_fixed_segment: ost$segment;
     VAR volume_missing: boolean;
     VAR unrecoverable_file: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
?? POP ??
*DECK DECK=DMP$VOLUME_DOWN EXPAND=FALSE
PROCEDURE [XREF] dmp$volume_down (lun: iot$logical_unit;
                                  VAR critical: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
?? POP ??
*DECK DECK=DMP$VOLUME_IS_ACTIVE EXPAND=FALSE

  PROCEDURE [XREF] dmp$volume_is_active (logical_unit_number: iot$logical_unit;
                                     VAR volume_active: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
?? POP ??
*DECK DECK=DMP$VOLUME_IS_ONLINE EXPAND=FALSE

  PROCEDURE [XREF] dmp$volume_is_online (logical_unit_number: iot$logical_unit;
                                     VAR volume_active: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
?? POP ??
*DECK DECK=DMP$VOLUME_ONLINE EXPAND=FALSE
  PROCEDURE [XREF] dmp$volume_online (logical_unit_number: iot$logical_unit;
        p_physical_attributes:^dmt$physical_device_attributes;
    VAR status:ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$physical_device_attributes
*copyc iot$logical_unit
*copyc ost$status
?? POP ??
*DECK DECK=DMP$VOLUME_SPACE_MANAGER EXPAND=FALSE
  PROCEDURE [XREF] dmp$volume_space_manager (
        avt_index: dmt$active_volume_table_index;
        full_update: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc ost$status
?? POP ??
*DECK DECK=DMP$VOLUME_UP EXPAND=FALSE
PROCEDURE [XREF] dmp$volume_up (lun: iot$logical_unit);
?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
?? POP ??
*DECK DECK=DMP$WRITE EXPAND=FALSE

  PROCEDURE [XREF] dmp$write ALIAS 'dmxwrit'
    (    fde_p: gft$locked_file_desc_entry_p;
         byte_address: amt$file_byte_address;
         length: amt$file_byte_address;
         io_function: iot$io_function;
     VAR device_address: dmt$ms_logical_device_address;
     VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc iot$io_function
*copyc dmt$ms_logical_device_address
*copyc syt$monitor_request_code
?? POP ??
*DECK DECK=DMT$ACTIVE_VOLUME_TABLE EXPAND=FALSE
{
{ dmt$active_volume_table
{

  TYPE
    dmt$active_volume_table = array [1 .. * ] of dmt$active_volume_table_entry,

    dmt$active_volume_table_entry = record
      lock: dmt$avt_lock,
      entry_available: boolean,
      logical_unit_number: iot$logical_unit,
      padding: string (4),
      mass_storage: dmt$ms_active_vol_table_entry,
    recend,

{
{ the avt lock, as described below and used in mainframe tables, must ONLY
{ be referenced using either #compare_swap or the osp$ procedures which
{ are used to reference 'locked variables'.  this is critical to
{ dual processor
{

    dmt$avt_lock = record
      status: ALIGNED [0 MOD 8] ost$compare_swap_lock,
    recend;

*copyc DMT$MS_ACTIVE_VOL_TABLE_ENTRY
*copyc IOT$LOGICAL_UNIT
*copyc ost$signature_lock
*copyc RMT$DEVICE_CLASS

*DECK DECK=DMT$ACTIVE_VOLUME_TABLE_INDEX EXPAND=FALSE
{
{ dmt$active_volume_table_index
{

  TYPE
    dmt$active_volume_table_index = 0 .. ioc$max_unit_number;

*copyc iot$logical_unit
*DECK DECK=DMT$ADDR_LENGTH_PAIR EXPAND=FALSE

TYPE
 dmt$addr_length_pair = record
   addr: ost$segment_offset,
   length: ost$segment_length,
 recend;

*copyc osd$virtual_address
*DECK DECK=DMT$ALLOCATION_CHAIN_POSITION EXPAND=FALSE
{
{ dmt$allocation_chain_position
{

  TYPE
    dmt$allocation_chain_position = (dmc$first_and_last_allocation,
      dmc$first_allocation, dmc$middle_allocation, dmc$last_allocation,
      dmc$part_of_allocation_unit);

*DECK DECK=DMT$ALLOCATION_INFO EXPAND=FALSE
{
{ dmt$allocation_info
{

  TYPE
    dmt$allocation_info = record
      available_mat_space: integer,
      available_dat_space: integer,
      bytes_per_dau: integer,
      allocation_allowed: boolean,
      no_space: boolean,
      space_low: boolean,
      no_file_entries: boolean,
      file_entries_low: boolean,
      device_log_count: integer,
    recend;
*DECK DECK=DMT$ALLOCATION_LOG EXPAND=FALSE
{
{ dmt$allocation_log
{

  TYPE
    dmt$al_entry_kind = (dmc$al_allocate, dmc$al_initialize, dmc$al_return_dau,
          dmc$al_software_flawed, dmc$al_reallocate, dmc$al_trim_file),

    dmt$al_entry = record
      avt_index: dmt$active_volume_table_index,
      case kind: dmt$al_entry_kind of

      = dmc$al_allocate =
        allocate_block: dmt$dl_allocate_block,

      = dmc$al_initialize =
        initialize_block: dmt$dl_initialize_block,

      = dmc$al_return_dau =
        return_dau_block: dmt$dl_return_dau_block,

      = dmc$al_software_flawed =
        software_flaw_block: dmt$dl_software_flaw_block,

      = dmc$al_reallocate =
        reallocate_block: dmt$dl_reallocate_block,

      = dmc$al_trim_file =
        trim_file_block: dmt$dl_trim_file_block,

      casend,
    recend;

  TYPE
    dmt$allocation_log = array [0 .. dmc$max_allocation_log_index] of
      dmt$al_entry,

    dmt$allocation_log_index = 0 .. dmc$max_allocation_log_index,

{
{ the field in dmt$allocation_log_info named 'number' must ONLY be
{ referenced using #compare_swap or the osp$ procedures which deal
{ with 'locked variables' when this type is used for a system table
{ (as with dmv$allocation_log).  this is critical to dual processor.
{

    dmt$allocation_log_info = record
      number: ALIGNED [0 MOD 8] integer,
      committed_initialize_count: integer,
      first: dmt$allocation_log_index,
      last: dmt$allocation_log_index,
      entries: dmt$allocation_log,
    recend;

  CONST
    dmc$max_allocation_log_index = 3125,

    dmc$max_allocation_log_entries = dmc$max_allocation_log_index + 1,

    dmc$al_trigger_update_threshold = 1600,

    dmc$al_entries_saved_for_inits = 800,

    dmc$al_reject_alloc_threshold = dmc$max_allocation_log_entries -
      dmc$al_entries_saved_for_inits;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc dmt$device_log_entries
?? POP ??
*DECK DECK=DMT$ALLOCATION_SIZE EXPAND=FALSE
{
{                common deck dmdaloc
{

  TYPE
    dmt$allocation_size = 0 .. dmc$max_bytes_per_allocation,
    dmt$bytes_per_allocation = dmc$min_bytes_per_allocation ..
      dmc$max_bytes_per_allocation,
    dmt$byte_offset_within_au = 0 .. dmc$max_bytes_per_allocation;

  CONST
    dmc$min_bytes_per_allocation = 4096,
    dmc$max_bytes_per_allocation = 0ffffff(16),
    dmc$maximum_page_size = 16384;

  TYPE
    dmt$allocation_styles = (dmc$a0, dmc$a1, dmc$a2, dmc$a3, dmc$a4, dmc$a5,
      dmc$a6, dmc$a7, dmc$a8, dmc$acyl);

  CONST
    dmc$default_allocation_style = dmc$a2,
    dmc$default_req_alloc_size = 16384,   {delete this ?}
    dmc$unspecified_allocation_size = 0;
*DECK DECK=DMT$ASSIGNED_MS_VOL_ATTRIBUTES EXPAND=FALSE
{
{ dmt$assigned_ms_vol_attributes
{

  TYPE
    dmt$assigned_ms_volume_keywords = (dmc$avt_index,
      dmc$ms_device_allocation_table, dmc$ms_recorded_vsn, dmc$ms_device_log,
      dmc$ms_internal_vsn, dmc$ms_mainframe_assigned,
      dmc$ms_volume_directory, dmc$ms_volume_owner,
      dmc$ms_device_file_list_table,
      dmc$ms_volume_login_table, dmc$ms_allocation_allowed,
      dmc$ms_current_log_position, dmc$ms_allocated_log_size,
      dmc$ms_device_log_entry_count, dmc$ms_volume_unavailable),

    dmt$assigned_ms_vol_attribute = record
      case keyword: dmt$assigned_ms_volume_keywords of

      = dmc$avt_index =
        index: dmt$active_volume_table_index,

      = dmc$ms_allocation_allowed =
        allocation_allowed: boolean,

      = dmc$ms_current_log_position =
        current_log_position: integer,

      = dmc$ms_device_allocation_table =
        p_dat: dmt$system_file_id,

      = dmc$ms_device_log_entry_count =
        device_log_entry_count: integer,

      = dmc$ms_recorded_vsn =
        recorded_vsn: rmt$recorded_vsn,

      = dmc$ms_internal_vsn =
        internal_vsn: dmt$internal_vsn,

      = dmc$ms_device_log =
        p_dlog: dmt$system_file_id,

      = dmc$ms_allocated_log_size =
        allocated_log_size: amt$file_byte_address,

      = dmc$ms_mainframe_assigned =
        mainframe_assigned: dmt$mainframe_assigned,

      = dmc$ms_volume_directory =
        directory_sfid: dmt$system_file_id,

      = dmc$ms_volume_owner =
        volume_owner: ost$user_identification,

      = dmc$ms_device_file_list_table =
        p_dflt: dmt$system_file_id,

      = dmc$ms_volume_login_table =
        p_vlgt: dmt$system_file_id,

      = dmc$ms_volume_unavailable =
        volume_unavailable: boolean,

      casend,
    recend;

*copyc AMT$FILE_BYTE_ADDRESS
*copyc dmt$active_volume_table_index
*copyc DMT$INTERNAL_VSN
*copyc DMT$MAINFRAME_ASSIGNED
*copyc DMT$SYSTEM_FILE_ID
*copyc ost$user_identification
*copyc RMD$VOLUME_DECLARATIONS
*DECK DECK=DMT$AVT_LOGGING_INFO EXPAND=FALSE

  TYPE
    dmt$avt_logging_info = RECORD
      recorded_vsn: rmt$recorded_vsn,
      device_log_sfid: dmt$system_file_id,
      dat_sfid: dmt$system_file_id,
      dfl_sfid: dmt$system_file_id,
      login_table_sfid: dmt$system_file_id,
      mainframe_assigned: dmt$mainframe_assigned,
      volume_unavailable: boolean,
      log_entry_count: integer,
      current_log_offset: amt$file_byte_address,
      allocated_log_size: amt$file_byte_address,
      logging_process_damaged: boolean,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmt$mainframe_assigned
*copyc dmt$system_file_id
*copyc rmd$volume_declarations
?? POP ??
*DECK DECK=DMT$AVT_SEARCH_KEY EXPAND=FALSE
{
{ dmt$avt_search_key
{

  TYPE
    dmt$avt_search_key = record
      case value: dmt$avt_search_keys of
      = dmc$search_avt_by_lun =
        logical_unit_number: iot$logical_unit,
      = dmc$search_avt_by_rec_vsn =
        recorded_vsn: rmt$recorded_vsn,
      casend,
    recend,

    dmt$avt_search_keys = (dmc$search_avt_by_lun, dmc$search_avt_by_rec_vsn);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc rmd$volume_declarations
?? POP ??
*DECK DECK=DMT$CHAPTER_INFO EXPAND=FALSE

{ Common deck DMT$CHAPTER_INFO
{ Define record used for returning info for the dmp$fetch_chapter_info request.

  TYPE
    dmt$chapter_info = RECORD
      page_status: dmt$page_status,
      preset_value: amt$preset_value,
      tu_chapter_offset: ost$segment_offset,
      tu_length: ost$segment_length,
      bytes_per_allocation: 0 .. dmc$max_bytes_per_allocation,
    RECEND,

    dmt$read_or_write = (dmc$read, dmc$write),
    dmt$flag_requirements = (dmc$no_flag, dmc$global_flag, dmc$local_flag),

    dmt$page_status = (dmc$page_not_on_disk, dmc$page_on_disk,
      dmc$page_beyond_file_limit, dmc$page_space_not_allocated,
      dmc$file_not_assigned,
      dmc$page_location_indeterminate, dmc$initialization_in_prog,
      dmc$sft_locked, dmc$file_write_lock_set,
      dmc$volume_unavailable, dmc$page_not_on_server, dmc$page_on_server,
      dmc$allocate_required_on_server, dmc$file_server_terminated);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$PRESET_VALUE
*copyc DMT$ALLOCATION_SIZE
*copyc OSD$VIRTUAL_ADDRESS
?? POP ??
*DECK DECK=DMT$CHAPTER_NUMBER EXPAND=FALSE
{
{                common deck dmdchap
{
{Define chapter number.

  TYPE
    dmt$chapter_number = 0 .. 2047;
*DECK DECK=DMT$CLASS EXPAND=FALSE
{
{              common deck dmdclas
{

  TYPE
    dmt$class = set of dmt$class_member,
    dmt$class_member = 'A' .. 'Z',
    dmt$system_class = (dmc$swap_files, dmc$critical_files,
        dmc$temporary_files, dmc$system_class_spare_1, dmc$system_class_spare_2);

  TYPE
    dmt$class_ordinal = 0 .. dmc$max_class_ordinal;

  CONST
    dmc$max_class_ordinal = 63,
    dmc$default_class = rmc$unspecified_file_class,
    dmc$swap_file_class = 'C',
    dmc$transient_segment_class = 'B',
    dmc$default_class_ordinal = 0;

*copyc rmc$unspecified_file_class

*DECK DECK=DMT$CREATE_CLIENT_SFT_OPERATION EXPAND=FALSE

  TYPE
    dmt$create_client_sft_operation = (dmc$begin_job_recovery,
          dmc$complete_job_recovery, dmc$attach_or_create);


*DECK DECK=DMT$DATE EXPAND=FALSE
{
{                common deck dmddate
{

  TYPE
    dmt$date = record
      year: 0 .. 4095,
      month: 1 .. 12,
      day: 1 .. 31,
    recend;
*DECK DECK=DMT$DAT_CHANGE EXPAND=FALSE
{
{ dmt$dat_change
{

  TYPE
    dmt$dat_change = record
      dau_address: dmt$dau_address,
      index: 1 .. 0ffffff(16),
      case kind: dmt$dat_change_kind of

      = dmc$dat_initialize =
        initialize_block: dmt$dl_initialize_block,

      = dmc$dat_software_flawed =
        software_flaw_block: dmt$dl_software_flaw_block,

      = dmc$dat_release_dau =
        release_dau_block: dmt$dl_release_dau_block,

      = dmc$dat_return_dau, dmc$dat_recycle_dau =
        return_dau_block: dmt$dl_return_dau_block,

      = dmc$dat_assign_dau =
        assign_dau_block: dmt$dat_assign_dau_block,

      = dmc$dat_update_dau =
        update_dau_block: dmt$dat_update_dau_block,

      = dmc$dat_reallocate_dau =
        reallocate_dau_block: dmt$dl_reallocate_block,

      = dmc$dat_delink_dau =
        delink_dau_block: dmt$dat_delink_dau,

      casend,
    recend,

    dmt$dat_changes = array [1 .. *] of dmt$dat_change,

    dmt$dat_change_kind = (dmc$dat_initialize, dmc$dat_software_flawed,
      dmc$dat_release_dau, dmc$dat_return_dau, dmc$dat_assign_dau,
      dmc$dat_update_dau, dmc$dat_reallocate_dau, dmc$dat_delink_dau,
      dmc$dat_halt, dmc$dat_recycle_dau),

    dmt$dat_change_abort = (dmc$dat_no_action, dmc$dat_halt_before_change,
      dmc$dat_halt_after_change),

    dmt$dat_assign_dau_block = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,
      mainframe_assigned: dmt$mainframe_assigned,
      first_flag: boolean,
      daus_per_allocation: dmt$daus_per_allocation,
    recend,

    dmt$dat_delink_dau = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,
    recend,

    dmt$dat_update_dau_block = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,
      next_dau_address: dmt$dau_address,
    recend,

    dmt$dat_change_index = 0 .. 7fffffff(16);

  TYPE
    dmt$dat_change_errors = record
      error_count: ALIGNED [0 MOD 8] integer {compare swap},
      error_list: array [1 .. 32] of dmt$dat_change_error,
    recend,

    dmt$dat_change_error = record
      time: integer,
      avt_index: dmt$active_volume_table_index,
      recovery_logging: boolean,
      dat_change: dmt$dat_change,
      dau_address: dmt$dau_address,
      dau_entry: dmt$ms_device_allocation_unit,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc dmt$device_allocation_unit
*copyc dmt$device_file_list_index
*copyc dmt$device_log_entries
*copyc dmt$mainframe_assigned
*copyc dmt$ms_device_allocation_table
?? POP ??
*DECK DECK=DMT$DAT_RETURN_OPTION EXPAND=FALSE

  TYPE
    dmt$dat_return_option = (dmc$return_specific_entry, dmc$return_all_except_entry);
*DECK DECK=DMT$DEADSTART_LABEL_FILES EXPAND=FALSE

  TYPE
    dmt$deadstart_label_files = (dmc$dlf_primary_entry, dmc$dlf_secondary_entry,
          dmc$dlf_image_entry, dmc$dlf_spare_entry);
*DECK DECK=DMT$DEBUG_ACTIONS EXPAND=FALSE
{
{ dmt$debug_actions
{

  TYPE
    dmt$debug_actions = set of dmt$debug_codes,

    dmt$debug_codes = (dmc$debug_dat_changes, dmc$debug_dfl_changes,
          dmc$debug_device_manager);
*DECK DECK=DMT$DEVICE_ALLOCATION_UNIT EXPAND=FALSE
{
{                    common deck dmddau
{

  TYPE
    dmt$bytes_per_dau = dmc$min_bytes_per_dau .. dmc$max_bytes_per_dau,
    dmt$daus_per_allocation = 0 .. dmc$max_daus_allocation,
    dmt$daus_per_position = 0 .. dmc$max_daus_position,
    dmt$daus_per_transfer = 0 .. dmc$max_daus_transfer,
    dmt$dau_address = dmc$min_dau_address .. dmc$max_dau_address;

  CONST
    dmc$min_bytes_per_dau = 1,
    dmc$max_bytes_per_dau = 16384,
    dmc$min_dau_address = 0,
    dmc$max_dau_address = 425940,
    dmc$min_daus_allocation = 1,
    dmc$max_daus_allocation = 200,
    dmc$min_daus_position = 1,
    dmc$max_daus_position = 200,
    dmc$min_daus_transfer = 1,
    dmc$max_daus_transfer = 200,
    dmc$min_dau_size = 1,
    dmc$max_dau_size = 16384;
*DECK DECK=DMT$DEVICE_FILE_LIST_INDEX EXPAND=FALSE
{
{ dmt$device_file_list_index
{

  TYPE
    dmt$device_file_list_index = 0 .. dmc$max_device_file_list_index,
    dmt$old_dfl_index = 0 .. 0ffff(16);

  CONST
    dmc$max_device_file_list_index = 0ffffff(16);

*DECK DECK=DMT$DEVICE_FILE_STORED_FMD EXPAND=FALSE
{
{ dmt$device_file_stored_fmd
{

  { dmt$device_file_stored_fmd must be large enough to hold a stored
  { FMD for one subfile.

  TYPE
    dmt$device_file_stored_fmd = SEQ (REP 100 of CELL);
*DECK DECK=DMT$DEVICE_LOG_ENTRIES EXPAND=FALSE
{
{ dmt$device_log_entries
{

  TYPE
    dmt$dl_entry_kind = (dmc$invalid_dl_entry, dmc$dl_allocate,
      dmc$dl_first_sft_delete, dmc$dl_second_sft_delete,
      dmc$dl_third_sft_delete, dmc$dl_create, dmc$dl_return_dau,
      dmc$dl_disk_tables_updated, dmc$dl_attach_file, dmc$dl_detach_file,
      dmc$dl_initialize, dmc$dl_last_update_entry, dmc$dl_purge_file,
      dmc$dl_second_purge_file, dmc$dl_release_dau, dmc$dl_release_dfl,
      dmc$dl_return_dfl, dmc$dl_software_flawed, dmc$dl_start_update,
      dmc$dl_update_disk_tables, dmc$dl_update_file_length,
      dmc$dl_update_fmd_length, dmc$dl_file_damaged, dmc$dl_reallocate,
      dmc$dl_trim_file, dmc$dl_deallocate_file_fragment, dmc$dl_continue_purge,
      dmc$dl_sa_on_dl_entry,
      dmc$dl_sa_after_process_dl, dmc$dl_sa_bef_next_dfl_change,
      dmc$dl_sa_aft_next_dfl_change, dmc$dl_sa_bef_next_dat_change,
      dmc$dl_sa_aft_next_dat_change, dmc$dl_sa_bef_logging_dtu,
      dmc$dl_sa_bef_mf_table_update, dmc$dl_sa_aft_mf_table_update,
      dmc$dl_ra_on_dl_entry, dmc$dl_ra_after_process_dl,
      dmc$dl_ra_bef_next_dfl_change, dmc$dl_ra_aft_next_dfl_change,
      dmc$dl_ra_bef_next_dat_change, dmc$dl_ra_aft_next_dat_change,
      dmc$dl_ra_bef_logging_dtu, dmc$dl_recycle_dau),

    dmt$dl_entry_kind_set = set of dmt$dl_entry_kind;

  TYPE
    dmt$abort_log_types = (dmc$system_abort, dmc$recovery_abort,
      dmc$logout_abort),

    dmt$abort_log_positions = (dmc$sa_processing_log,
      dmc$sa_updating_disk_tables, dmc$sa_updating_mat, dmc$sa_updating_mfl,
      dmc$ra_processing_log, dmc$ra_updating_disk_tables, dmc$ra_updating_mat,
      dmc$ra_updating_mfl),

    dmt$system_abort_log_positions = dmc$sa_processing_log ..
      dmc$sa_updating_mfl,

    dmt$recovry_abort_log_positions = dmc$ra_processing_log ..
      dmc$ra_updating_mfl,

    dmt$system_log_aborts = set of dmt$system_abort_log_entries,

    dmt$recovery_log_aborts = set of dmt$recovery_abort_log_entries,

    dmt$system_abort_log_entries = dmc$dl_sa_on_dl_entry ..
      dmc$dl_sa_aft_mf_table_update,

    dmt$recovery_abort_log_entries = dmc$dl_ra_on_dl_entry ..
      dmc$dl_ra_bef_logging_dtu,

    dmt$recovery_test_aborts = array [dmt$recovry_abort_log_positions] of
      dmt$recovery_abort_log_entries,

    dmt$system_test_aborts = array [dmt$system_abort_log_positions] of
      dmt$system_abort_log_entries,

    dmt$log_abort = record
      case abort: dmt$abort_log_types of
      = dmc$system_abort =
        system_abort_position: dmt$system_abort_log_positions,
      = dmc$recovery_abort =
        recovery_abort_position: dmt$recovry_abort_log_positions,
      casend,
    recend;

  TYPE
    dmt$dl_allocate_block = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,
      allocate_flags: dmt$dl_allocate_flags,
      dau_address: dmt$dau_address,
      previous_dau_address: dmt$dau_address,
      daus_per_allocation: dmt$daus_per_allocation,
    recend,

    dmt$dl_trim_file_block = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,
      dau_address: dmt$dau_address,
      dau_of_fragment: dmt$dau_address,
    recend,

    dmt$dl_deallocate_fragment_blk = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,
      dau_address: dmt$dau_address,
    recend,

    dmt$dl_reallocate_block = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,
      mainframe_assigned: dmt$mainframe_assigned,
      dau_address,
      old_dau_address,
      next_dau_address,
      previous_dau_address: dmt$dau_address,
      daus_per_allocation: dmt$daus_per_allocation,
      allocation_chain_position: dmt$allocation_chain_position,
    recend,

    dmt$dl_allocate_flags = (dmc$dl_first_allocation,
      dmc$dl_continued_allocation),

    dmt$dl_sft_delete_block = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,
      sfid: gft$system_file_identifier,
      fmd_index: dmt$fmd_index,
    recend,

    dmt$dl_create_block = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,
      daus_per_allocation: dmt$daus_per_allocation,
      file_kind: gft$file_kind,
      mainframe_assigned: dmt$mainframe_assigned,
      fmd_byte_address: amt$file_byte_address,
    recend,

    dmt$dl_return_dau_block = record
      mainframe_assigned: dmt$mainframe_assigned,
      dau_address: dmt$dau_address,
      daus_per_allocation: dmt$daus_per_allocation,
    recend,

    dmt$dl_attach_file_block = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,
      mainframe_assigned: dmt$mainframe_assigned,
    recend,

    dmt$dl_initialize_block = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,
      dau_address: dmt$dau_address,
    recend,

    dmt$dl_purge_file_block = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,
      file_byte_address: amt$file_byte_address,
    recend,

    dmt$dl_release_dau_block = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,
      dau_address: dmt$dau_address,
      daus_per_allocation: dmt$daus_per_allocation,
      mainframe_assigned: dmt$mainframe_assigned,
    recend,

    dmt$dl_release_dfl_block = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,
      mainframe_assigned: dmt$mainframe_assigned,
    recend,

    dmt$dl_return_dfl_block = record
      dfl_index: dmt$device_file_list_index,
      mainframe_assigned: dmt$mainframe_assigned,
    recend,

    dmt$dl_software_flaw_block = record
      dau_address: dmt$dau_address,
      flaw_option: dmt$flaw_option,
    recend,

    dmt$flaw_option = (dmc$remove_flaw, dmc$add_flaw),

    dmt$dl_file_length_block = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,

      eof_specified: boolean,
      eof: amt$file_byte_address,

      eoi_specified: boolean,
      eoi: amt$file_byte_address,
    recend,

    dmt$dl_fmd_length_block = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,

      fmd_length_specified: boolean,
      fmd_length: amt$file_byte_address,

      logical_length_specified: boolean,
      logical_length: amt$file_byte_address,
    recend,

    dmt$dl_file_damaged_block = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,
      add_damage: dmt$file_damage,
      remove_damage: dmt$file_damage,
    recend,

    dmt$log_in_sequence = integer,

    dmt$log_in_index = integer;

  TYPE
    dmt$dl_entry = record
      case kind: dmt$dl_entry_kind of

      = dmc$dl_allocate =
        allocate_block: dmt$dl_allocate_block,

      = dmc$dl_deallocate_file_fragment =
        deallocate_file_fragment_block: dmt$dl_deallocate_fragment_blk,

      = dmc$dl_trim_file =
        trim_file_block: dmt$dl_trim_file_block,

      = dmc$dl_reallocate =
        reallocate_block: dmt$dl_reallocate_block,

      = dmc$dl_first_sft_delete, dmc$dl_second_sft_delete,
        dmc$dl_third_sft_delete =
        sft_delete_block: dmt$dl_sft_delete_block,

      = dmc$dl_create =
        create_block: dmt$dl_create_block,

      = dmc$dl_return_dau, dmc$dl_recycle_dau =
        return_dau_block: dmt$dl_return_dau_block,

      = dmc$dl_attach_file, dmc$dl_detach_file =
        attach_file_block: dmt$dl_attach_file_block,

      = dmc$dl_initialize =
        initialize_block: dmt$dl_initialize_block,

      = dmc$dl_purge_file, dmc$dl_second_purge_file =
        purge_file_block: dmt$dl_purge_file_block,

      = dmc$dl_release_dau, dmc$dl_continue_purge =
        release_dau_block: dmt$dl_release_dau_block,

      = dmc$dl_release_dfl =
        release_dfl_block: dmt$dl_release_dfl_block,

      = dmc$dl_return_dfl =
        return_dfl_block: dmt$dl_return_dfl_block,

      = dmc$dl_software_flawed =
        software_flaw_block: dmt$dl_software_flaw_block,

      = dmc$dl_update_file_length =
        file_length_block: dmt$dl_file_length_block,

      = dmc$dl_update_fmd_length =
        fmd_length_block: dmt$dl_fmd_length_block,

      = dmc$dl_file_damaged =
        file_damaged_block: dmt$dl_file_damaged_block,

      casend,
    recend;

  TYPE
    dmt$device_log = ^SEQ ( * );

  TYPE
    dmt$dl_recovery_testing_aborts = (dmc$dl_no_abort,
      dmc$dl_halt_before_logging_dtu, dmc$dl_halt_before_mf_table_upd,
      dmc$dl_halt_after_mf_table_upd);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmt$allocation_chain_position
*copyc dmt$device_allocation_unit
*copyc dmt$device_file_list_index
*copyc dmt$fmd_index
*copyc dmt$file_damage
*copyc dmt$global_file_name
*copyc dmt$mainframe_assigned
*copyc gft$file_kind
*copyc gft$system_file_identifier
?? POP ??
*DECK DECK=DMT$DEVICE_POSITION EXPAND=FALSE
{
{ dmt$device_position
{

  TYPE
    dmt$device_position = dmc$min_device_position .. dmc$max_device_position,

    dmt$position_sum = 0 .. dmc$max_position_sum;

  CONST
    dmc$min_device_position = 0,

    dmc$max_device_position = 2620,

    dmc$max_position_sum = dmc$max_device_position * (dmc$max_device_position
          + 1) DIV 2;
*DECK DECK=DMT$DFL_CHANGE EXPAND=FALSE
{
{ dmt$dfl_change
{

  TYPE
    dmt$dfl_change = record
      dfl_index: dmt$device_file_list_index,
      case kind: dmt$dfl_change_kind of

      = dmc$dfl_create =
        create_block: dmt$dl_create_block,

      = dmc$dfl_return_dfl =
        return_dfl_block: dmt$dl_return_dfl_block,

      = dmc$dfl_first_dau =
        first_dau_block: dmt$dfl_first_dau_block,

      = dmc$dfl_release_dfl =
        release_dfl_block: dmt$dl_release_dfl_block,

      = dmc$dfl_attach_file, dmc$dfl_detach_file =
        attach_file_block: dmt$dl_attach_file_block,

      = dmc$dfl_update_file_length =
        file_length_block: dmt$dl_file_length_block,

      = dmc$dfl_update_fmd_length =
        fmd_length_block: dmt$dl_fmd_length_block,

      = dmc$dfl_file_damaged =
        file_damaged_block: dmt$dl_file_damaged_block,
      casend,
    recend,

    dmt$dfl_changes = array [1 .. *] of dmt$dfl_change,

    dmt$dfl_change_kind = (dmc$dfl_create, dmc$dfl_return_dfl,
      dmc$dfl_first_dau, dmc$dfl_release_dfl, dmc$dfl_attach_file,
      dmc$dfl_detach_file, dmc$dfl_update_file_length,
      dmc$dfl_update_fmd_length, dmc$dfl_file_damaged, dmc$dfl_halt),

    dmt$dfl_change_abort = (dmc$dfl_no_action, dmc$dfl_halt_before_change,
      dmc$dfl_halt_after_change),

    dmt$dfl_first_dau_block = record
      global_file_name: dmt$global_file_name,
      dfl_index: dmt$device_file_list_index,
      dau_address: dmt$dau_address,
    recend,

    dmt$dfl_change_index = 0 .. 7fffffff(16);

  TYPE
    dmt$dfl_change_errors = record
      error_count: ALIGNED [0 MOD 8] integer {compare swap},
      error_list: array [1 .. 32] of dmt$dfl_change_error,
    recend,

    dmt$dfl_change_error = record
      time: integer,
      avt_index: dmt$active_volume_table_index,
      recovery_logging: boolean,
      dfl_change: dmt$dfl_change,
      dfl_entry: dmt$ms_device_file_list_entry,
    recend;
?? PUSH (LISTEXT :=ON) ??
*copyc dmt$active_volume_table_index
*copyc dmt$device_allocation_unit
*copyc dmt$device_file_list_index
*copyc dmt$device_log_entries
*copyc dmt$ms_device_file_list_entry
?? POP ??
*DECK DECK=DMT$DF_ALLOCATE_FILE_SPACE EXPAND=FALSE

{ Parameters sent from CLIENT >--> SERVER for allocation in job_mode

  TYPE
    dmt$df_allocate_file_space_inp = record
      sfid: dmt$system_file_id,
      byte_offset: amt$file_byte_address,
      bytes_to_allocate: amt$file_byte_address,
      total_allocated_length: amt$file_byte_address,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmt$system_file_id
?? POP ??
*DECK DECK=DMT$DF_REALLOCATE_FILE_SPACE EXPAND=FALSE

{ Parameters sent from CLIENT >--> SERVER for reallocation in job_mode

  TYPE
    dmt$df_reallocate_filespace_inp = record
      sfid: dmt$system_file_id,
      global_file_name: dmt$global_file_name,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$global_file_name
*copyc dmt$system_file_id
?? POP ??
*DECK DECK=DMT$DF_SET_EOI EXPAND=FALSE

{ Parameters sent from CLIENT >--> SERVER

  TYPE
    dmt$df_set_eoi_inp = record
      sfid: dmt$system_file_id,
      segment_length: ost$segment_length,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc osd$virtual_address
?? POP ??
*DECK DECK=DMT$DIRECTORY_INDEX EXPAND=FALSE
{
{ dmt$directory_index
{

  TYPE
    dmt$directory_index = 0 .. 500;
*DECK DECK=DMT$DISK_FILE_DESCRIPTOR EXPAND=FALSE
{
{ dmt$disk_file_descriptor
{


  TYPE
    dmt$disk_file_descriptor = record
      read_write_count: 0 .. 0ffff(16),
      delete_count: dmt$delete_count,
      purged: boolean,
      restricted_attach: boolean,
      bytes_per_allocation: 0 .. dmc$max_bytes_per_allocation,
      file_allocation_table: ^dmt$level_1_table,
      fat_upper_bound: dmt$level_1_index,
      current_fmd_index: dmt$fmd_index,
      highest_offset_allocated: amt$file_byte_address,
      bytes_per_level_2: amt$file_byte_address,
      dfd_modified: boolean,
      overflow_allowed: boolean,
      requested_allocation_size: dmt$allocation_size,
      requested_class: dmt$class_member,
      requested_class_ordinal: dmt$class_ordinal,
      requested_transfer_size: dmt$transfer_size,
      requested_volume: dmt$requested_volume,
      number_of_fmds: dmt$fmd_index,
      p_fmd: ^dmt$file_medium_descriptor,
      file_damaged: boolean,
      damaged_detection_enabled: boolean,
      fmd_modified: boolean,
    recend;

  TYPE

    dmt$delete_count = 0 .. 0ffffff(16);

  TYPE
    dmt$file_hash_thread = ^gft$file_descriptor_entry,

    dmt$active_file_hash_threads = array [0 .. dmc$max_file_hash] of dmt$file_hash_thread,

    dmt$active_fde_lock = array [0 .. dmc$max_file_hash] of ost$signature_lock;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc amt$file_limit
*copyc amt$preset_value
*copyc dmt$file_attributes
*copyc dmt$global_file_name
*copyc dmt$locked_file
*copyc dmt$queue_status
*copyc dmt$sparse_allocation
*copyc dmt$system_file_id
*copyc dmt$usage_count
*copyc gft$file_descriptor_entry
*copyc jmt$ijl_ordinal
*copyc mmt$eoi_state
*copyc osd$virtual_address
*copyc ost$clear_file_space
*copyc ost$hardware_subranges
*copyc ost$signature_lock
?? POP ??
*DECK DECK=DMT$DISPLAY_PARAMETERS EXPAND=FALSE
*DECK DECK=DMT$ERROR_CODES EXPAND=FALSE
?? NEWTITLE := 'DMDECC  : Device Management     : ''OS'' 4000 .. 4999' ??
*copyc DMT$ERROR_CONDITION_CODES
*copyc DME$TAPE_ERRORS
?? OLDTITLE ??
*DECK DECK=DMT$ERROR_CONDITION_CODES EXPAND=FALSE
{
{                   common deck dmt$error_condition_codes
{
*copyc osc$base_exception

  CONST
    dmc$device_manager_ident = 'DM';

  CONST
    dmc$device_manager_error_code = osc$base_exception + 4000,
    dme$allocate_fail = dmc$device_manager_error_code + 1,
    {C +I +C +T }

    dme$unrecognizable_case_select = dmc$device_manager_error_code + 2,
    {C +I +C +T }

    dme$push_fail = dmc$device_manager_error_code + 3,
    {C +I +C +T }

    dme$sfid_fmd_file_hash_mismatch = dmc$device_manager_error_code + 4,
    {C +I +C +T }

    dme$vsn_not_part_of_set = dmc$device_manager_error_code + 5,
    {E +I +C +T }

    dme$no_volumes_in_set = dmc$device_manager_error_code + 6,
    {C +I +C +T }

    dme$bad_read_device_parameter = dmc$device_manager_error_code + 7,
    {C +I +C +T }

    dme$unrecognizable_file_type = dmc$device_manager_error_code + 8,
    {E +I +C +T }

    dme$fatal_file_descript_search = dmc$device_manager_error_code + 9,
    {C +I +C +T }

    dme$unrecognizable_file_res = dmc$device_manager_error_code + 10,
    {E +I +C +T }

    dme$illegal_file_index_in_sfid = dmc$device_manager_error_code + 11,
    {C +I +C +T }

    dme$unable_to_release_fmd = dmc$device_manager_error_code + 12,
    {C +I +C +T }

    dme$free_failure = dmc$device_manager_error_code + 13,
    {C +I +C +T }

    dme$aloc_unit_being_initialized = dmc$device_manager_error_code + 14,
    {C +I +C +T }

    dme$no_fmd_in_file_descriptor = dmc$device_manager_error_code + 15,
    {C +I +C +T }

    dme$fad_not_ready_to_access = dmc$device_manager_error_code + 16,
    {C +I +C +T }

    dme$fmd_contents_not_released = dmc$device_manager_error_code + 17,
    {C +I +C +T }

    dme$au_not_found_in_mat = dmc$device_manager_error_code + 18,
    {C +I +C +T }

    dme$file_alloc_descrip_overflow = dmc$device_manager_error_code + 19,
    {C +I +C +T }

    dme$fau_index_out_of_range = dmc$device_manager_error_code + 20,
    {C +I +C +T }

    dme$no_file_descriptor_assigned = dmc$device_manager_error_code + 21,
    {C +I +C +T }

    dme$fmd_not_created_for_file = dmc$device_manager_error_code + 22,
    {C +I +C +T }

    dme$file_allocation_overflow = dmc$device_manager_error_code + 23,
    {C +I +C +T }

    dme$faus_not_created = dmc$device_manager_error_code + 24,
    {C +I +C +T }

    dme$overflow_on_file_allocation = dmc$device_manager_error_code + 25,
    {C +I +C +T }

    dme$avt_entry_not_found = dmc$device_manager_error_code + 26,
    {F +I +C +T }

    dme$invalid_mat_device_type = dmc$device_manager_error_code + 27,
    {C +I +C +T }

    dme$subfile_not_ready_to_access = dmc$device_manager_error_code + 28,
    {C +I +C +T }

    dme$unable_to_create_fdt_entry = dmc$device_manager_error_code + 29,
    {C +I +C +T }

    dme$file_space_limit_exceeded = dmc$device_manager_error_code + 30,
    {C +I +C +T }

    dme$job_mode_allocate_required = dmc$device_manager_error_code + 31,
    {C +I +C +T }

    dme$invalid_sfid = dmc$device_manager_error_code + 32,
    {C +I +C +T }

    dme$invalid_subfile = dmc$device_manager_error_code + 33,
    {C +I +C +T }

    dme$max_fau_count_exceeded = dmc$device_manager_error_code + 34,
    {C +I +C +T }

    dme$invalid_monitor_call = dmc$device_manager_error_code + 35,
    {C +I +C +T }

    DME$UNUSED_5 = dmc$device_manager_error_code + 36,
    {C +I +C +T }

    dme$unable_to_get_fd_lock = dmc$device_manager_error_code + 37,
    {C +I +C +T }

    dme$unable_to_clear_fd_lock = dmc$device_manager_error_code + 38,
    {C +I +C +T }

    dme$unable_to_get_fmd_lock = dmc$device_manager_error_code + 39,
    {C +I +C +T }

    dme$unable_to_clear_fmd_lock = dmc$device_manager_error_code + 40,
    {C +I +C +T }

    dme$unable_to_change_vol_attr = dmc$device_manager_error_code + 41,
    {C +I +C +T }

    DME$UNUSED_14 = dmc$device_manager_error_code + 42,
    {C +I +C +T }

    dme$invalid_file_index_in_sfid = dmc$device_manager_error_code + 43,
    {C +I +C +T }

    dme$unknown_file = dmc$device_manager_error_code + 44,
    {C +I +C +T }

    dme$illegal_sfid_file_residence = dmc$device_manager_error_code + 47,
    {C +I +C +T }

    dme$no_fads = dmc$device_manager_error_code + 48,
    {C +I +C +T }

    dme$no_free_mf_dfl_entries = dmc$device_manager_error_code + 49,
    {C +I +C +T }

    dme$file_descriptor_not_deleted = dmc$device_manager_error_code + 50,
    {C +I +C +T }

    dme$volume_list_too_small = dmc$device_manager_error_code + 51,
    {E +I +C +T }

    dme$no_allocation_style_found = dmc$device_manager_error_code + 52,
    {C +I +C +T }

    dme$unsupported_label_version = dmc$device_manager_error_code + 53,
    {W +I +C +T }

    dme$volume_label_not_expired = dmc$device_manager_error_code + 54,
    {E +I +C +T }

    dme$invalid_volume_access_code = dmc$device_manager_error_code + 55,
    {E +I +C +T }

    dme$vol_label_date_not_expired = dmc$device_manager_error_code + 56,
    {I +I +C +T }

    dme$invalid_vol_owner_specified = dmc$device_manager_error_code + 57,
    {E +I +C +T }

    DME$UNUSED_7 = dmc$device_manager_error_code + 58,
    {C +I +C +T }

    DME$UNUSED_8 = dmc$device_manager_error_code + 59,
    {C +I +C +T }

    dme$duplicate_device_file_gfn = dmc$device_manager_error_code + 60,
    {C +I +C +T }

    dme$fmd_too_small = dmc$device_manager_error_code + 61,
    {C +I +C +T }

    dme$invalid_dat_alloc_style = dmc$device_manager_error_code + 62,
    {C +I +C +T }

    dme$allocation_chain_broken = dmc$device_manager_error_code + 63,
    {C +I +C +T }

    dme$unsupported_fmd_version = dmc$device_manager_error_code + 64,
    {C +I +C +T }

    dme$transient_error = dmc$device_manager_error_code + 65,
    {C +I +C +T }

    dme$job_mode_fix_required = dmc$device_manager_error_code + 66,
    {C +I +C +T }

    dme$unsupported_dat_version = dmc$device_manager_error_code + 67,
    {C +I +C +T }

    dme$unable_to_allocate_dat = dmc$device_manager_error_code + 68,
    {C +I +C +T }

    dme$unsupported_dflt_version = dmc$device_manager_error_code + 69,
    {C +I +C +T }

    dme$unable_to_allocate_dflt = dmc$device_manager_error_code + 70,
    {C +I +C +T }

    dme$unable_to_allocate_aus = dmc$device_manager_error_code + 71,
    {C +I +C +T }

    dme$unable_to_lock_lun_entry = dmc$device_manager_error_code + 72,
    {C +I +C +T }

    dme$unable_to_release_lun_lock = dmc$device_manager_error_code + 73,
    {C +I +C +T }

    dme$no_contig_space_for_label = dmc$device_manager_error_code + 74,
    {C +I +C +T }

    DME$UNUSED_9 = dmc$device_manager_error_code + 75,
    {C +I +C +T }

    dme$initialize_active_volume = dmc$device_manager_error_code + 76,
    {C +I +C +T }

    dme$illegal_use_of_sfid = dmc$device_manager_error_code + 77,
    {C +I +C +T }

    dme$recorded_vsn_not_in_lun = dmc$device_manager_error_code + 78,
    {C +I +C +T }

    dme$unable_to_locate_vol_label = dmc$device_manager_error_code + 79,
    {E +I +C +T }

    dme$unknown_device_file = dmc$device_manager_error_code + 80,
    {C +I +C +T }

    dme$open_dat_failure = dmc$device_manager_error_code + 82,
    {C +I +C +T }

    dme$open_dflt_failure = dmc$device_manager_error_code + 83,
    {C +I +C +T }

    dme$open_directory_failure = dmc$device_manager_error_code + 84,
    {C +I +C +T }

    dme$unable_to_locate_fde = dmc$device_manager_error_code + 85,
    {C +I +C +T }

    dme$overflow_of_mflt = dmc$device_manager_error_code + 86,
    {C +I +C +T }

    dme$nil_mflt_pointer = dmc$device_manager_error_code + 87,
    {C +I +C +T }

    dme$invalid_device_log_kind = dmc$device_manager_error_code + 88,
    {C +I +C +T }

    dme$invalid_device_log_entry = dmc$device_manager_error_code + 89,
    {C +I +C +T }

    dme$unable_to_clear_avt_lock = dmc$device_manager_error_code + 90,
    {C +I +C +T }

    dme$volume_already_active = dmc$device_manager_error_code + 91,
    {I +I +C +T }

    dme$no_free_avt_entry = dmc$device_manager_error_code + 92,
    {E +I +C +T }

    dme$open_login_table_failure = dmc$device_manager_error_code + 93,
    {C +I +C +T }

    dme$bad_dat_change_encountered = dmc$device_manager_error_code + 94,
    {C +I +C +T }

    dme$unable_to_locate_label = dmc$device_manager_error_code + 95,
    {E +I +C +T }

    dme$unable_to_lock_avt_entry = dmc$device_manager_error_code + 96,
    {C +I +C +T }

    dme$bad_dfl_change_encountered = dmc$device_manager_error_code + 97,
    {C +I +C +T }

    dme$fmd_dfl_hash_mismatch = dmc$device_manager_error_code + 99,
    {C +I +C +T }

    dme$login_table_full = dmc$device_manager_error_code + 100,
    {C +I +C +T }

    dme$device_file_already_exists = dmc$device_manager_error_code + 101,
    {C +I +C +T }

    dme$directory_full = dmc$device_manager_error_code + 102,
    {C +I +C +T }

    dme$no_dfl_entries_available = dmc$device_manager_error_code + 103,
    {C +I +C +T }

    dme$no_contig_space_for_file = dmc$device_manager_error_code + 104,
    {C +I +C +T }

    dme$no_volumes_avail_for_assign = dmc$device_manager_error_code + 105,
    {C +I +C +T }

    dme$no_space_in_dat = dmc$device_manager_error_code + 106,
    {C +I +C +T }

    dme$open_label_failure = dmc$device_manager_error_code + 107,
    {C +I +C +T }

    dme$unable_to_locate_avt_entry = dmc$device_manager_error_code + 108,
    {C +I +C +T }

    dme$unable_to_log = dmc$device_manager_error_code + 109,
    {C +I +C +T }

    dme$unsupported_product_number = dmc$device_manager_error_code + 110,
    {C +I +C +T }

    dme$unsupported_model_number = dmc$device_manager_error_code + 111,
    {C +I +C +T }

    dme$unable_to_lock_dat = dmc$device_manager_error_code + 112,
    {C +I +C +T }

    dme$unable_to_unlock_dat = dmc$device_manager_error_code + 113,
    {C +I +C +T }

    dme$unable_to_lock_dflt = dmc$device_manager_error_code + 114,
    {C +I +C +T }

    dme$unable_to_unlock_dflt = dmc$device_manager_error_code + 115,
    {C +I +C +T }

    dme$unable_to_lock_directory = dmc$device_manager_error_code + 116,
    {C +I +C +T }

    dme$unable_to_unlock_directory = dmc$device_manager_error_code + 117,
    {C +I +C +T }

    dme$unable_to_lock_login_table = dmc$device_manager_error_code + 118,
    {C +I +C +T }

    dme$unable_to_ulock_login_table = dmc$device_manager_error_code + 119,
    {C +I +C +T }

    dme$volume_not_online = dmc$device_manager_error_code + 120,
    {C +I +C +T }

    dme$volume_already_logged_in = dmc$device_manager_error_code + 121,
    {C +I +C +T }

    dme$set_avt_conflict = dmc$device_manager_error_code + 122,
    {C +I +C +T }

    dme$premature_end_of_dat_chain = dmc$device_manager_error_code + 123,
    {C +I +C +T }

    dme$crossed_allocation = dmc$device_manager_error_code + 124,
    {C +I +C +T }

    dme$first_dau_of_au_not_first = dmc$device_manager_error_code + 125,
    {C +I +C +T }

    dme$part_of_au_first_dau = dmc$device_manager_error_code + 126,
    {C +I +C +T }

    dme$rf_fde_file_type = dmc$device_manager_error_code + 127,
    {C +I +C +T }

    dme$rf_fde_gfn = dmc$device_manager_error_code + 128,
    {C +I +C +T }

    dme$rf_fde_preset = dmc$device_manager_error_code + 129,
    {C +I +C +T }

    dme$rf_fmd_hash = dmc$device_manager_error_code + 130,
    {C +I +C +T }

    dme$rf_fmd_type = dmc$device_manager_error_code + 131,
    {C +I +C +T }

    dme$rf_fad_byte_address = dmc$device_manager_error_code + 132,
    {C +I +C +T }

    dme$rf_fad_unique = dmc$device_manager_error_code + 133,
    {C +I +C +T }

    dme$rf_fad_dfl = dmc$device_manager_error_code + 134,
    {C +I +C +T }

    dme$rf_fau_hash = dmc$device_manager_error_code + 135,
    {C +I +C +T }

    dme$rf_fad_fau_size = dmc$device_manager_error_code + 136,
    {C +I +C +T }

    dme$logging_unavailable = dmc$device_manager_error_code + 137,
    {C +I +C +T }

    dme$fmd_overflow = dmc$device_manager_error_code + 138,
    {C +I +C +T }

    dme$unable_to_process_vol_label = dmc$device_manager_error_code + 139,
    {E +I +C +T }

    dme$unable_to_free_fads = dmc$device_manager_error_code + 140,
    {C +I +C +T }

    dme$illegal_caller = dmc$device_manager_error_code + 141,
    {C +I +C +T }

    dme$flaw_map_positioning_error = dmc$device_manager_error_code + 142,
    {C +I +C +T }

    dme$unable_to_process_flaw_map = dmc$device_manager_error_code + 143,
    {C +I +C +T }

    dme$rf_fau_lengths = dmc$device_manager_error_code + 144,
    {C +I +C +T }

    dme$rf_fau_not_assigned_to_mf = dmc$device_manager_error_code + 145,
    {C +I +C +T }

    dme$rf_fau_wrong_mf_assigned = dmc$device_manager_error_code + 146,
    {C +I +C +T }

    dme$reject_r1 = dmc$device_manager_error_code + 147,
    {C +I +C +T }

    dme$unable_to_read_verify_data = dmc$device_manager_error_code + 148,
    {C +I +C +T }

    dme$mainframe_not_logged_in = dmc$device_manager_error_code + 149,
    {C +I +C +T }

    dme$rf_no_vol_assigned_to_file = dmc$device_manager_error_code + 150,
    {C +I +C +T }

    dme$dau_chain_not_linked = dmc$device_manager_error_code + 151,
    {C +I +C +T }

    dme$max_dflt_length_exceeded = dmc$device_manager_error_code + 152,
    {C +I +C +T }

    dme$max_dir_length_exceeded = dmc$device_manager_error_code + 153,
    {C +I +C +T }

    dme$invalid_fmd = dmc$device_manager_error_code + 154,
    {C +I +C +T }

    dme$update_fmd = dmc$device_manager_error_code + 155,
    {C +I +C +T }

    dme$unable_to_release_all_space = dmc$device_manager_error_code + 157,
    {C +I +C +T }

    dme$volume_already_online = dmc$device_manager_error_code + 158,
    {I +I +C +T }

    dme$file_limit_less_then_eoi = dmc$device_manager_error_code + 159,
    {C +I +C +T }

    DME$UNUSED_10 = dmc$device_manager_error_code + 160,
    {C +I +C +T }

    DME$UNUSED_11 = dmc$device_manager_error_code + 161,
    {C +I +C +T }

    DME$UNUSED_12 = dmc$device_manager_error_code + 162,
    {C +I +C +T }

    DME$UNUSED_13 = dmc$device_manager_error_code + 163,
    {E +I +C +T }

    dme$untrimmable_file_type = dmc$device_manager_error_code + 164,
    {E +I +C +T }

    dme$inconsistent_hash_and_gfn = dmc$device_manager_error_code + 165,
    {C +I +C +T }

    dme$tape_fmd_not_destroyed = dmc$device_manager_error_code + 166,
    {C +I +C +T }

    dme$unable_to_use_label_df_info = dmc$device_manager_error_code + 167,
    {E +I +C +T }

    dme$unable_to_alloc_all_space = dmc$device_manager_error_code + 168,
    {C +I +C +T }

    dme$unable_to_attach_for_rec = dmc$device_manager_error_code + 169,
    {C +I +C +T }

    dme$unable_to_recover_log = dmc$device_manager_error_code + 170,
    {C +I +C +T }

    dme$bad_tape_window_address = dmc$device_manager_error_code + 171,
    {C +I +C +T }

    dme$alloc_not_allowed_on_vol = dmc$device_manager_error_code + 172,
    {C +I +C +T }

    dme$bad_tape_window_length = dmc$device_manager_error_code + 173,
    {C +I +C +T }

    dme$unable_to_attach_file = dmc$device_manager_error_code + 174,
    {C +I +C +T}

    dme$unable_to_recover_all_logs = dmc$device_manager_error_code + 175,
    {C +I +C +T}

    dme$unable_to_recover_all_vols = dmc$device_manager_error_code + 176,
    {C +I +C +T}

    dme$unable_to_recover_set = dmc$device_manager_error_code + 177,
    {C +I +C +T}

    dme$partially_recovered_set = dmc$device_manager_error_code + 178,
    {C +I +C +T}

    dme$partially_recovered_mf_sets = dmc$device_manager_error_code + 179,
    {C +I +C +T}

    dme$unable_to_cleanup_file = dmc$device_manager_error_code + 180,
    {C +I +C +T}

    dme$incorrect_num_alloc_units = dmc$device_manager_error_code + 181,
    {C +I +C +T}

    dme$unable_to_det_alloc_style = dmc$device_manager_error_code + 183,
    {C +I +C +T}

    dme$unable_to_return_avail_fde = dmc$device_manager_error_code + 184,
    {C +I +C +T}

    dme$fde_queuing_error = dmc$device_manager_error_code + 185,
    {C +I +C +T}

    dme$file_descriptor_not_in_use = dmc$device_manager_error_code + 186,
    {C +I +C +T}

    dme$number_of_fdes_disagree = dmc$device_manager_error_code + 187,
    {C +I +C +T}

    dme$unable_to_flush_file = dmc$device_manager_error_code + 188,
    {C +I +C +T}

    dme$unable_to_process_al_entry = dmc$device_manager_error_code + 189,
    {C +I +C +T}

     dme$unable_to_process_dl_entry = dmc$device_manager_error_code + 190,
     {C +I +C +T}

     dme$all_volumes_not_online = dmc$device_manager_error_code + 191,
     {C +I +C +T}

     dme$some_volumes_not_online = dmc$device_manager_error_code + 192,
     {C A requested volume +P1 is not online.}

     dme$class_valid_unable_to_alloc = dmc$device_manager_error_code + 193,
     {C +I +C +T}

     dme$file_class_not_valid = dmc$device_manager_error_code + 194,
     {C +I +C +T}

    { the following error conditions are detected
    {  in the module named dmm$deadstart_file_management

    dme$cant_attach_label_sysdev = dmc$device_manager_error_code + 195,
       {E Bad status trying to attach device label on system dev.}

    dme$cant_open_label_on_sysdev = dmc$device_manager_error_code + 196,
       {E Bad status trying to open device label on system dev.}

    dme$failure_attaching_dsfile  = dmc$device_manager_error_code + 197,
       {E Bad status attaching DM deadstart file in ring 1.}

    dme$cant_create_file_on_sysdev = dmc$device_manager_error_code + 198,
       {E Unable to create file on system device for dsfile.}

    dme$could_attach_cant_open = dmc$device_manager_error_code + 199,
       {E Unable to open dsfile on system device for upgrade.}

    dme$cant_extend_dsfile = dmc$device_manager_error_code + 200,
       {E Unable to extend dsfile on system device for upgrade.}

    dme$failure_attaching_maufile  = dmc$device_manager_error_code + 201,
       {E Bad status attaching DM mau file in ring 1.}

    dme$cant_extend_maufile = dmc$device_manager_error_code + 202,
       {E Unable to extend maufile on system device for upgrade.}

    dme$maulist_too_small =  dmc$device_manager_error_code + 203,
       {E Maulist too small to represent file in mau units.}

    dme$input_parameter_is_nil = dmc$device_manager_error_code + 204,
       {E Input parameter equal NIL is unacceptable.}

    dme$sfid_for_label_is_null = dmc$device_manager_error_code + 205,
       {E DM label file not open but must be to upgrade.}

    dme$no_dsfile_on_disk = dmc$device_manager_error_code + 206,
       {E Cannot COMNS when ESTDBS not executed.}

    dme$only_primary_dsfile_on_disk = dmc$device_manager_error_code + 207,
       {E COMNS is for ESTDBS invocations beyond first time.}

    dme$volume_unavailable = dmc$device_manager_error_code + 208,
       {E The requested volume +P1 is not available for use.}

    { The folliwing error conditions apply to the Distributed files code
    dme$expecting_server_file = dmc$device_manager_error_code + 209,
       {C +I +C +T}

    dme$invalid_family_index  = dmc$device_manager_error_code + 210,
       {C +I +C +T}

    dme$unexpected_server_file = dmc$device_manager_error_code + 309,
       {C +I +C +T}

   { The following error conditions apply to the Defect Management code

    dme$cylinder_limit_exceeded = dmc$device_manager_error_code + 211,
       {E Cylinder parameter too large - +P1.}

    dme$track_limit_exceeded = dmc$device_manager_error_code + 212,
       {E Track parameter too large - +P1.}

    dme$sector_limit_exceeded = dmc$device_manager_error_code + 213,
       {E Sector parameter too large - +P1.}

    dme$address_already_flawed = dmc$device_manager_error_code + 214,
       {W Address already flawed - +P1.}

    dme$unaddressable_sector = dmc$device_manager_error_code + 215,
       {E Un-addressable sector - +P1.}

    dme$address_not_sw_flawed = dmc$device_manager_error_code + 216,
       {W Address not software flawed - +P1.}

    dme$flawing_deferred = dmc$device_manager_error_code + 217,
       {W Flawing deferred - +P1.}

    dme$io_active = dmc$device_manager_error_code + 218,
       {C +I +C +T}

    dme$allocation_mismatch = dmc$device_manager_error_code + 220,
       {C +I +C +T}

    dme$outstanding_log_entries = dmc$device_manager_error_code + 219;
       {C +I +C +T}
*DECK DECK=DMT$EXISTING_SFT_ENTRY EXPAND=FALSE

  TYPE
    dmt$existing_sft_entry = (dmc$entry_not_found, dmc$normal_entry,
                            dmc$restricted_attach_entry);
*DECK DECK=DMT$FAD_INDEX EXPAND=FALSE
*copyc dmt$fmd_index
*DECK DECK=DMT$FILE_ALLOCATION_DESCRIPTOR EXPAND=FALSE
*copyc dmt$file_medium_descriptor
*copyc dmt$file_allocation_unit
*DECK DECK=DMT$FILE_ALLOCATION_STATUS EXPAND=FALSE

  TYPE
    dmt$file_allocation_status = (
        dmc$fas_account_limit_exceeded,
        dmc$fas_file_allocated,
        dmc$fas_job_mode_work_required,
        dmc$fas_temp_reject);
*DECK DECK=DMT$FILE_ALLOCATION_TABLE EXPAND=FALSE
{
{ dmt$file_allocation_table
{

  TYPE
    dmt$stored_ms_device_file_fat = record
      header: dmt$stored_df_fat_header,
      file_allocation_units: array [1 .. * ] of dmt$ms_file_allocation_unit,
    recend,
    dmt$stored_df_fat_header = record
      allocation_style: dmt$allocation_styles,
      byte_address: amt$file_byte_address,
      bytes_per_allocation: dmt$bytes_per_allocation,
      bytes_per_mau: dmt$bytes_per_mau,
      clear_space: ost$clear_file_space,
      daus_per_allocation_unit: dmt$daus_per_allocation,
      daus_per_cylinder: dmt$daus_per_position,
      daus_per_transfer_unit: dmt$daus_per_transfer,
      global_file_name: dmt$global_file_name,
      maus_per_allocation_unit: dmt$maus_per_allocation,
      maus_per_dau: dmt$maus_per_dau,
      maus_per_transfer_unit: dmt$maus_per_transfer,
      preset_value: amt$preset_value,
      number_faus: dmt$fau_entries,
    recend;

  TYPE
    dmt$ms_file_allocation_unit = record
      dau_address: dmt$dau_address,
      state: dmt$fau_states,
      status: dmt$fau_device_dau_chain_status,
    recend;

  TYPE
    dmt$fau_device_dau_chain_status = (dmc$add_to_chain, dmc$delete_from_chain,
      dmc$no_change_required);

*copyc amt$preset_value
*copyc amt$file_byte_address
*copyc dmt$allocation_size
*copyc dmt$active_volume_table_index
*copyc dmt$device_allocation_unit
*copyc dmt$global_file_name
*copyc dmt$file_allocation_descriptor
*copyc dmt$file_table_lock
*copyc dmt$minimum_allocation_unit
*copyc dmt$system_file_id
*copyc ost$clear_file_space
*DECK DECK=DMT$FILE_ALLOCATION_UNIT EXPAND=FALSE
{
{ dmt$file_allocation_unit
{

  TYPE
    dmt$file_allocation_units = record
      faus: array [ * ] of dmt$file_allocation_unit,
    recend,
    dmt$file_allocation_unit = record
      dau_address: dmt$dau_address,
      state: dmt$fau_states,
      fmd_index: dmt$fmd_index,
    recend;

  TYPE
    dmt$default_number_fau_entries = 1 .. dmc$default_number_fau_entries,
    dmt$fau_entries = 0 .. dmc$max_fau_entries,
    dmt$fau_states = (dmc$fau_free, dmc$fau_invalid_data,
      dmc$fau_invalid_and_flawed, dmc$fau_initialized,
      dmc$fau_initialized_and_flawed, dmc$fau_initialization_in_prog);

  CONST
    dmc$default_number_fau_entries = 39,
    dmc$max_fau_entries = 134880;

*copyc dmt$device_allocation_unit
*copyc dmt$fmd_index
*DECK DECK=DMT$FILE_ATTRIBUTES EXPAND=FALSE
{
{ dmt$file_attributes
{

  TYPE
    dmt$file_attribute = record
      case keyword: dmt$file_attribute_keywords of
      = dmc$allocated_length =
        allocated_length: amt$file_byte_address,
      = dmc$asid =
        asid: ost$asid,
      = dmc$byte_address =
        byte_address: amt$file_byte_address,
      = dmc$bytes_per_allocation =
        bytes_per_allocation: dmt$allocation_size,
      = dmc$class =
        class: dmt$class_member,
      = dmc$class_ordinal =
        ordinal: dmt$class_ordinal,
      = dmc$clear_space =
        required: ost$clear_file_space,
      = dmc$device_file_list_index =
        device_file_list_index: dmt$device_file_list_index,
      = dmc$eof_byte_address =
        eof_address: amt$file_byte_address,
      = dmc$eoi_byte_address =
        eoi_address: amt$file_byte_address,
      = dmc$file_hash =
        file_hash: dmt$file_hash,
      = dmc$file_limit =
        limit: amt$file_limit,
      = dmc$file_status =
        file_modified: boolean,
      = dmc$file_kind =
        file_kind: gft$file_kind,
      = dmc$global_file_name =
        global_file_name: dmt$global_file_name,
      = dmc$internal_vsn =
        internal_vsn: dmt$internal_vsn,
      = dmc$locked_file =
        file_lock: dmt$locked_file,
      = dmc$logical_length =
        logical_length: amt$file_byte_address,
      = dmc$master_volume_required =
        master_volume_required: boolean,
      = dmc$overflow =
        overflow_allowed: boolean,
      = dmc$owner =
        file_space_limit: sft$file_space_limit_kind,
      = dmc$preset_value =
        preset_value: amt$preset_value,
      = dmc$recorded_vsn =
        recorded_vsn: rmt$recorded_vsn,
      = dmc$requested_allocation_size =
        requested_allocation_size: dmt$allocation_size,
      = dmc$requested_transfer_size =
        requested_transfer_size: dmt$transfer_size,
      = dmc$requested_volume =
        requested_volume: dmt$requested_volume,
      = dmc$setname =
        setname: stt$set_name,
      = dmc$chapter_length =
        chapter_length: ost$segment_length,
      = dmc$write_mode =
        attached_in_write_mode: boolean,
      = dmc$queue_status =
        queue_status: gft$queue_status,
      casend,
    recend,
    dmt$file_attribute_keywords = (dmc$allocated_length, dmc$asid,
      dmc$byte_address, dmc$bytes_per_allocation, dmc$class, dmc$class_ordinal,
      dmc$clear_space, dmc$device_file_list_index, dmc$eof_byte_address,
      dmc$eoi_byte_address, dmc$file_hash, dmc$file_limit, dmc$file_status,
      dmc$file_kind, dmc$global_file_name, dmc$internal_vsn, dmc$locked_file,
      dmc$logical_length, dmc$master_volume_required, dmc$null_attribute, dmc$overflow,
      dmc$owner, dmc$preset_value, dmc$recorded_vsn, dmc$requested_allocation_size,
      dmc$requested_transfer_size, dmc$requested_volume, dmc$setname,
      dmc$chapter_length, dmc$write_mode, dmc$queue_status);

*copyc AMT$PRESET_VALUE
*copyc OSD$VIRTUAL_ADDRESS
*copyc AMD$FILE_ATTRIBUTES
*copyc AMT$FILE_BYTE_ADDRESS
*copyc DMT$ALLOCATION_SIZE
*copyc DMT$CLASS
*copyc dmt$device_file_list_index
*copyc DMT$FILE_HASH
*copyc DMT$GLOBAL_FILE_NAME
*copyc DMT$INTERNAL_VSN
*copyc DMT$LOCKED_FILE
*copyc DMT$REQUESTED_VOLUME_ATTRIBUTES
*copyc DMT$SEGMENT_FILE_INFORMATION
*copyc DMT$OVERFLOW_ALLOWED
*copyc DMT$TRANSFER_SIZE
*copyc gft$file_kind
*copyc GFT$QUEUE_STATUS
*copyc OST$HARDWARE_SUBRANGES
*copyc OST$CLEAR_FILE_SPACE
*copyc RMD$VOLUME_DECLARATIONS
*copyc SFT$FILE_SPACE_LIMIT_KIND
*copyc STD$SET_NAME
*DECK DECK=DMT$FILE_DAMAGE EXPAND=FALSE
{
{ dmt$file_damage
{

  TYPE
    dmt$file_damage = set of dmt$file_damage_types,

{   As of release 1.4.2, the code to set dmc$file_data_error has been removed.
{   The set memeber has been left here only to provide backward compatability
{   to previous builds that may have added this damage condition to a DFL entry.

    dmt$file_damage_types = (dmc$eoi_modified_by_recovery,
      dmc$allocation_chain_broken, dmc$media_image_inconsistent,
      dmc$file_damage_3,
      dmc$file_damage_4, dmc$file_damage_5, dmc$file_damage_6,
      dmc$file_damage_7, dmc$file_damage_8, dmc$file_damage_9,
      dmc$file_damage_10, dmc$file_damage_11, dmc$file_damage_12,
      dmc$file_damage_13, dmc$file_damage_14, dmc$file_damage_15);
*DECK DECK=DMT$FILE_DESCRIPTOR_ENTRY EXPAND=FALSE
*copyc dmt$disk_file_descriptor
*DECK DECK=DMT$FILE_HASH EXPAND=FALSE
{
{                 common deck dmdfhsh
{

  TYPE
    dmt$file_hash = 0 .. dmc$max_file_hash;

  CONST
    dmc$max_file_hash = 0ff(16);
*DECK DECK=DMT$FILE_INFORMATION EXPAND=FALSE

  TYPE
    dmt$file_information = record
      eoi_byte_address: amt$file_byte_address,
      file_kind: gft$file_kind,
      shared_queue: mmt$page_frame_queue_id,
      time_last_modified: ost$free_running_clock,
      total_allocated_length: amt$file_byte_address,
      trimmed_length: amt$file_byte_address,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc gft$file_kind
*copyc mmt$page_frame_queue_id
*copyc ost$free_running_clock
?? POP ??
*DECK DECK=DMT$FILE_LOCATION EXPAND=FALSE
{
{                   common deck dmdftbl
{

  TYPE
    dmt$file_location = ^ost$heap;

*copyc OST$HEAP
*DECK DECK=DMT$FILE_MEDIUM_DESCRIPTOR EXPAND=FALSE

{
{ dmt$file_medium_descriptor
{

  TYPE
    dmt$file_medium_descriptor = record
      in_use: boolean,
      system_file_id: dmt$system_file_id,
      avt_index: dmt$active_volume_table_index,
      dfl_index: dmt$device_file_list_index,
      delete_logging_count: dmt$delete_logging_count,
      volume_assigned: boolean,
      fmd_allocated_length: amt$file_byte_address,
      bytes_per_mau: dmt$bytes_per_mau,
      daus_per_cylinder: dmt$daus_per_position,
      daus_per_allocation_unit: dmt$daus_per_allocation,
      internal_vsn: dmt$internal_vsn,
      maus_per_dau: dmt$maus_per_dau,
      maus_per_transfer_unit: dmt$maus_per_transfer,
      p_next_fmd: ^dmt$file_medium_descriptor,
      allocation_style: dmt$allocation_styles,
    recend;

  TYPE
    dmt$delete_logging_count = 0 .. 0ffff(16);

  TYPE
    dmt$fmd_attributes = record
      fmd_index: dmt$fmd_index,
      attributes: array [1 .. * ] of dmt$fmd_attribute,
    recend;

  TYPE
    dmt$fmd_attribute = record
      case keyword: dmt$file_attribute_keywords of
      = dmc$allocated_length =
        fmd_allocated_length: amt$file_byte_address,
      = dmc$device_file_list_index =
        device_file_list_index: dmt$device_file_list_index,
      = dmc$internal_vsn =
        internal_vsn: dmt$internal_vsn,
      = dmc$recorded_vsn =
        recorded_vsn: rmt$recorded_vsn,
      casend,
    recend;

  CONST
    dmc$max_fmd_attribute = 7;

*copyc amt$file_byte_address
*copyc dmt$allocation_size
*copyc dmt$active_volume_table_index
*copyc dmt$device_allocation_unit
*copyc dmt$device_file_list_index
*copyc dmt$fad_index
*copyc dmt$file_attributes
*copyc dmt$global_file_name
*copyc dmt$internal_vsn
*copyc dmt$minimum_allocation_unit
*copyc dmt$subfile_index
*copyc dmt$system_file_id
*copyc rmd$volume_declarations
*DECK DECK=DMT$FILE_SHARE_HISTORY EXPAND=FALSE
{
{              common deck dmdfshs
{

  TYPE
    dmt$file_share_history = dmc$minimum_file_share_his ..
      dmc$maximum_file_share_his;

  CONST
    dmc$minimum_file_share_his = 0,
    dmc$maximum_file_share_his = 0ffff(16);
*DECK DECK=DMT$FILE_TABLE_LOCK EXPAND=FALSE
{
{                     common deck dmt$file_table_lock
{

  TYPE
    dmt$lock_status = (dmc$unlocked, dmc$locked,
      dmc$wait_for_exclusive_access);

  TYPE
    dmt$file_table_lock = record
      status: ALIGNED [0 MOD 8] ost$compare_swap_lock,
    recend;

*copyc ost$signature_lock
*DECK DECK=DMT$FILE_TABLE_PTR_CONVERSION EXPAND=FALSE
*DECK DECK=DMT$FILE_TYPE EXPAND=FALSE
{
{                  common deck dmdftyp
{

  TYPE
    dmt$file_type = (dmc$permanent, dmc$device, dmc$temp_named,
      dmc$temp_unnamed, dmc$catalog, dmc$temp_global, dmc$server_file),
    dmt$file_type_set = set of dmt$file_type,
    dmt$file_table_locations = (dmc$mainframe_job_file,
      dmc$mainframe_system_file, dmc$invalid_file_location,
      dmc$file_awaiting_recovery, dmc$file_location_a, dmc$file_location_b),
    dmt$valid_file_table_locations = dmc$mainframe_job_file ..
      dmc$mainframe_system_file;

  CONST
    dmc$default_file_type = dmc$temp_named;
*DECK DECK=DMT$FLAW_DAU_DEFINITION EXPAND=FALSE
{
{ dmt$flaw_dau_definition
{

  TYPE
    dmt$flaw_dau_definition = record
      entry_initialized: boolean,
      first_dau: dmt$dau_address,
      last_dau: dmt$dau_address,
      reserved: boolean,
      first: dmt$physical_flaw_address,
      last: dmt$physical_flaw_address,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$device_allocation_unit
*copyc dmt$physical_flaw_address
*copyc iot$cylinder
?? POP ??




*DECK DECK=DMT$FLAW_DUPLICATION EXPAND=FALSE
{
{ dmt$flaw_duplication
{

  TYPE
    dmt$flaw_duplication= record
      entry_initialized: boolean,
      cylinder: iot$cylinder,
      track_specified: boolean,
      track: iot$track,
      sector_specified: boolean,
      sector: iot$sector,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc iot$cylinder
?? POP ??

*DECK DECK=DMT$FMD_INDEX EXPAND=FALSE
{
{ dmt$fmd_index
{

  TYPE
    dmt$fmd_index = 0 .. 255;
*DECK DECK=DMT$GLOBAL_FILE_NAME EXPAND=FALSE

  TYPE
    dmt$global_file_name = ost$binary_unique_name;

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
?? POP ??
*DECK DECK=DMT$INITIALIZE_STATUS_INFO EXPAND=FALSE
{
{ dmt$initialize_status_info
{

  TYPE
    dmt$initialize_status_info = record
      recorded_vsn: rmt$recorded_vsn,
      case key: ost$status_condition of

      = dme$vol_label_date_not_expired =
        label_expiration_date: dmt$date,

      = dme$invalid_vol_owner_specified =
        label_owner_id: ost$user_identification,

      = dme$invalid_volume_access_code =
        access_code: ost$name,

      casend,
    recend;

*copyc OST$STATUS
*copyc RMD$VOLUME_DECLARATIONS
*copyc dmt$date
*copyc ost$user_identification
*copyc ost$name
*copyc DMT$ERROR_CONDITION_CODES
*DECK DECK=DMT$INITIALIZE_TAPE_VOLUME EXPAND=FALSE

  TYPE
    dmt$initialize_tape_volume = record
      case in_progress: boolean of
      = TRUE =
        element_name: cmt$element_name,
        logical_unit: iot$logical_unit,
      = FALSE =
        ,
      casend
    recend;

*copyc cmt$element_name
*copyc iot$logical_unit
*DECK DECK=DMT$INITV_SAVED_INFO EXPAND=FALSE
  TYPE
    dmt$initv_saved_info = RECORD
      assigned_element: cmt$element_name,
      labelled: boolean,
      read_error: boolean,
      expired_label: boolean,
      expiration_date: string (10),
      fid: amt$file_identifier,
      volume_id: string (6),
      owner_id: string (14),
      character_set: amt$internal_code,
      file_accessibility_code: string (1),
      label_standard_version: string (1),
      volume_accessibility_code: string (1),
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$internal_code
*copyc cmt$element_name
?? POP ??




*DECK DECK=DMT$INTERNAL_VSN EXPAND=FALSE
{
{                  common deck dmdivsn
{

  TYPE
    dmt$internal_vsn = ost$binary_unique_name;

*copyc ost$binary_unique_name
*DECK DECK=DMT$JOB_TAPE_TABLE EXPAND=FALSE
*DECK DECK=DMT$KEYPOINTS EXPAND=FALSE
{
{                              common deck dmdkey
{

  CONST

    dmk$sfid = dmk$base,
      {D  'sfid.file_entry_index' 'SFID    ' H16 }

    dmk$allocate_file_space = dmk$base + 1,
      {E  'dmp$allocate_file_space' 'FBA     ' I20 }
      {X  'dmp$allocate_file_space' 'STATCOND' I20 }

    dmk$allocate_file_space_r1 = dmk$base + 2,
      {E  'dmp$allocate_file_space_r1' 'SFID    ' H16 }
      {X  'dmp$allocate_file_space_r1' 'STATCOND' I20 }

    dmk$system_initialization = dmk$base + 3,
      {E  'dmp$system_initialization' }
      {X  'dmp$system_initialization' }

    dmk$assign_volume = dmk$base + 4,
      {E  'dmp$assign_volume' }
      {X  'dmp$assign_volume' 'STATCOND' I20 }

    dmk$assign_volume_to_file = dmk$base + 5,
      {E  'dmp$assign_volume_to_file' 'SFID    ' H16 }
      {X  'dmp$assign_volume_to_file' 'STATCOND' I20 }

    dmk$associate_volume_with_job = dmk$base + 6,
      {E  'dmp$associate_volume_with_job' }
      {X  'dmp$associate_volume_with_job' }

    dmk$attach_file = dmk$base + 7,
      {E  'dmp$attach_file' 'GFN     ' I52 }
      {X  'dmp$attach_file' 'STATCOND' I20 }

    dmk$build_fmd_header = dmk$base + 9,
      {E  'dmp$build_fmd_header' }
      {X  'dmp$build_fmd_header' 'STATCOND' I20 }

    dmk$build_fmd_subfile_descript = dmk$base + 10,
      {E  'dmp$build_fmd_subfile_descript' }
      {X  'dmp$build_fmd_subfile_descript' 'STATCOND' I20 }

    dmk$create_fd_entry = dmk$base + 11,
      {E  'dmp$create_fd_entry' }
      {X  'dmp$create_fd_entry' 'STATCOND' I20 }

    dmk$create_file_alloc_units = dmk$base + 12,
      {E  'dmp$create_file_alloc_units' 'SFID    ' H16 }
      {X  'dmp$create_file_alloc_units' 'STATCOND' I20 }

    dmk$create_file_entry = dmk$base + 13,
      {E  'dmp$create_file_entry' 'FTYPE   ' I8 }
      {X  'dmp$create_file_entry' 'STATCOND' I20 }

    dmk$create_file_medium_descript = dmk$base + 14,
      {E  'dmp$create_file_medium_descript' }
      {X  'dmp$create_file_medium_descript' 'STATCOND' I20 }

    dmk$create_mf_allocation_table = dmk$base + 15,
      {E  'dmp$create_mf_allocation_table' 'AVTI    ' I16 }
      {X  'dmp$create_mf_allocation_table' 'STATCOND' I20 }

    dmk$create_mf_device_file_table = dmk$base + 16,
      {E  'dmp$create_mf_device_file_table' 'AVTI    ' I16 }
      {X  'dmp$create_mf_device_file_table' 'STATCOND' I20 }

    dmk$deallocate_file_space = dmk$base + 17,
      {E  'dmp$deallocate_file_space' 'SFID    ' H16 }
      {X  'dmp$deallocate_file_space' 'STATCOND' I20 }

    dmk$delete_file_descriptor = dmk$base + 18,
      {E  'dmp$delete_file_descriptor' }
      {X  'dmp$delete_file_descriptor' }

    dmk$destroy_file = dmk$base + 19,
      {E  'dmp$destroy_file' 'SFID    ' H16 }
      {X  'dmp$destroy_file' 'STATCOND' I20 }

    dmk$destroy_permanent_file = dmk$base + 20,
      {E  'dmp$destroy_permanent_file' 'GFN     ' I52 }
      {X  'dmp$destroy_permanent_file' 'STATCOND' I20 }

    dmk$detach_file = dmk$base + 21,
      {E  'dmp$detach_file' 'SFID    ' I }
      {X  'dmp$detach_file' 'STATCOND' I }

    dmk$disassociate_vol_from_job = dmk$base + 22,
      {E  'dmp$disassociate_vol_from_job' }
      {X  'dmp$disassociate_vol_from_job' }

    dmk$fetch_asid = dmk$base + 23,
      {E  'dmp$fetch_asid' 'SFID    ' H16 }
      {X  'dmp$fetch_asid' 'ASID    ' H16 }

    dmk$fetch_segment_file_info = dmk$base + 25,
      {E  'dmp$fetch_segment_file_info' 'SFID    ' H16 }
      {X  'dmp$fetch_segment_file_info' 'STATCOND' I20 }

    dmk$generate_unique_binary_name = dmk$base + 26,
      {E  'dmp$generate_unique_binary_name' }
      {X  'dmp$generate_unique_binary_name' 'STATCOND' I20 }

    dmk$get_file_info = dmk$base + 28,
      {E  'dmp$get_file_info' 'SFID    ' H16 }
      {X  'dmp$get_file_info' 'STATCOND' I20 }

    dmk$get_unused_job_fd = dmk$base + 29,
      {E  'dmp$get_unused_job_fd' }
      {X  'dmp$get_unused_job_fd' }

    dmk$get_unused_file_descriptor = dmk$base + 30,
      {E  'dmp$get_unused_system_fd' }
      {X  'dmp$get_unused_system_fd' 'STATCOND' I20 }

    dmk$increase_fau_count = dmk$base + 31,
      {E  'dmp$increase_fau_count' 'NFAUSREQ ' I16 }
      {X  'dmp$increase_fau_count' 'STATCOND' I20 }

    dmk$lock_file = dmk$base + 32,
      {E  'dmp$lock_file' 'SFID    ' H16 }
      {X  'dmp$lock_file' 'STATCOND' I20 }

    dmk$read = dmk$base + 33,
      {E  'dmp$read' 'SFID    ' H16 }
      {X  'dmp$read' 'STATCOND' I20 }

    dmk$release_dfl_entry = dmk$base + 34,
      {E  'dmp$release_dfl_entry' }
      {X  'dmp$release_dfl_entry' }

    dmk$release_fau = dmk$base + 35,
      {E  'dmp$release_fau' 'SFID    ' H16 }
      {X  'dmp$release_fau' 'STATCOND' I20 }

    dmk$release_file_descriptor = dmk$base + 36,
      {E  'dmp$release_file_descriptor' }
      {X  'dmp$release_file_descriptor' }

    dmk$release_file_medium_desc = dmk$base + 37,
      {E  'dmp$release_file_medium_desc' 'SFID    ' H16 }
      {X  'dmp$release_file_medium_desc' 'STATCOND' I20 }

    dmk$reserve_mainframe_dfl_entry = dmk$base + 38,
      {E  'dmp$reserve_mainframe_dfl_entry' 'AVTI    ' I16 }
      {X  'dmp$reserve_mainframe_dfl_entry' 'STATCOND' I20 }

    dmk$search_active_volume_table = dmk$base + 39,
      {E  'dmp$search_active_volume_table' }
      {X  'dmp$search_active_volume_table' }

    dmk$get_stored_fmd = dmk$base + 40,
      {E  'dmp$get_stored_fmd' 'SFID    ' I }
      {X  'dmp$get_stored_fmd' 'STATCOND' I }

    dmk$search_mat_for_position = dmk$base + 41,
      {E  'dmp$search_mat_for_position' }
      {X  'dmp$search_mat_for_position' 'POSNF   ' I8 }

    dmk$store_asid = dmk$base + 42,
      {E  'dmp$store_asid' 'SFID    ' H16 }
      {X  'dmp$store_asid' 'ASID    ' H16 }

    dmk$update_existing_fmds = dmk$base + 43,
      {E  'dmp$update_existing_fmds' }
      {X  'dmp$update_existing_fmds' }

    dmk$transfer_unit_written = dmk$base + 44,
      {E  'dmp$transfer_unit_written' 'SFID    ' H16 }
      {X  'dmp$transfer_unit_written' 'STATCOND' I20 }

    dmk$update_volume_committment = dmk$base + 45,
      {E  'dmp$update_volume_committment' }
      {X  'dmp$update_volume_committment' }

    dmk$volume_online = dmk$base + 46,
      {E  'dmp$volume_online' 'LUN     ' I }
      {X  'dmp$volume_online' }

    dmk$write = dmk$base + 47,
      {E  'dmp$write' 'SFID    ' H16 }
      {X  'dmp$write' 'STATCOND' I20 }

    dmk$seq_num = dmk$base + 48,
      {D  'global_file_name.sequence_number' 'GFN     ' I52 }

    dmk$init_volume = dmk$base + 49,
      {E  'dmp$initialize_volume' 'NULL    ' I20 }
      {X  'dmp$initialize_volume' 'STATCOND' I20 }

    dmk$validate_lab = dmk$base + 50,
      {E  'dmp$validate_label' 'NULL    ' I16 }
      {X  'dmp$validate_label' 'STATCOND' I20 }

    dmk$create_label = dmk$base + 51,
      {E  'dmp$create_label' 'NULL    ' I16 }
      {X  'dmp$create_label' 'STATCOND' I20 }

    dmk$build_dat = dmk$base + 52,
      {E  'dmp$build_dat' 'NULL    ' I16 }
      {X  'dmp$build_dat' 'STATCOND' I20 }

    dmk$build_dflt = dmk$base + 53,
      {E  'dmp$build_dflt' 'NULL    ' I16 }
      {X  'dmp$build_dflt' 'STATCOND' I20 }

    dmk$build_dir = dmk$base + 54,
      {E  'dmp$build_volume_directory' 'NULL    ' I16 }
      {X  'dmp$build_volume_directory' 'STATCOND' I20 }

    dmk$build_login = dmk$base + 55,
      {E  'dmp$build_login_table' 'NULL    ' I16 }
      {X  'dmp$build_login_table' 'STATCOND' I20 }

    dmk$open_dflt = dmk$base + 56,
      {E  'dmp$open_dflt' 'SFID    ' H16 }
      {X  'dmp$open_dflt' 'STATCOND' I20 }

    dmk$open_dat = dmk$base + 57,
      {E  'dmp$open_dat' 'SFID    ' H16 }
      {X  'dmp$open_dat' 'STATCOND' I20 }

    dmk$open_dir = dmk$base + 58,
      {E  'dmp$open_volume_directory' 'SFID    ' H16 }
      {X  'dmp$open_volume_directory' 'STATCOND' I20 }

    dmk$open_login = dmk$base + 59,
      {E  'dmp$open_login_table' 'NULL    ' I16 }
      {X  'dmp$open_login_table' 'STATCOND' I20 }

    dmk$open_file_segment = dmk$base + 60,
      {E  'dmp$open_file_segment' 'SFID    ' H16 }
      {X  'dmp$open_file_segment' 'STATCOND' I20 }

    dmk$locate_vol_label = dmk$base + 61,
      {E  'dmp$locate_volume_label' 'NULL    ' I16 }
      {X  'dmp$locate_volume_label' 'STATCOND' I20 }

    dmk$close_seg_acc_file = dmk$base + 62,
      {E  'dmp$close_segment_access_file' 'NULL    ' I16 }
      {X  'dmp$close_segment_access_file' 'STATCOND' I20 }

    dmk$attach_directory_from_label = dmk$base + 63,
      {E  'dmp$attach_directory_from_label' 'NULL    ' I16 }
      {X  'dmp$attach_directory_from_label' 'STATCOND' I20 }

    dmk$attach_dat_from_label = dmk$base + 64,
      {E  'dmp$attach_dat_from_label' 'NULL    ' I16 }
      {X  'dmp$attach_dat_from_label' 'STATCOND' I20 }

    dmk$attach_dflt_from_label = dmk$base + 65,
      {E  'dmp$attach_dflt_from_label' 'NULL    ' I16 }
      {X  'dmp$attach_dflt_from_label' 'STATCOND' I20 }

    dmk$open_label = dmk$base + 66,
      {E  'dmp$open_label' 'SFID    ' H16 }
      {X  'dmp$open_label' 'STATCOND' I20 }

    dmk$attach_device_file = dmk$base + 67,
      {E  'dmp$attach_device_file' 'NULL    ' I16 }
      {X  'dmp$attach_device_file' 'STATCOND' I20 }

    dmk$attach_volume_device_file = dmk$base + 68,
      {E  'dmp$attach_volume_device_file' 'NULL    ' I16 }
      {X  'dmp$attach_volume_device_file' 'STATCOND' I20 }

    dmk$attach_device_file_by_fmd = dmk$base + 69,
      {E  'dmp$attach_device_file_by_fmd' 'NULL    ' I16 }
      {X  'dmp$attach_device_file_by_fmd' 'STATCOND' I20 }

    dmk$activate_volume_for_sets = dmk$base + 70,
      {D  'activate volume to sets' 'RECVSN  ' A48 }

    dmk$process_device_log_entry = dmk$base + 71,
      {E  'dmp$process_device_log_entry' 'AVT INDX' I8 }
      {X  'dmp$process_device_log_entry' 'STATCOND' I20}

    dmk$update_volume_tables = dmk$base + 72,
      {E 'dmp$update_volume_tables' 'AVT INDX' I8 }
      {X 'dmp$update_volume_tables' 'STATCOND' I20 }

    dmk$bring_volume_online = dmk$base + 73,
      {E  'dmp$bring_volume_online' 'LUN     ' I16 }
      {X  'dmp$bring_volume_online' 'STATCOND' I20 }

    dmk$take_volume_offline = dmk$base + 74,
      {E  'dmp$take_volume_offline' 'LUN     ' I16 }
      {X  'dmp$take_volume_offline' 'STATCOND' I20 }

    dmk$detach_device_file = dmk$base + 75,
      {E  'dmp$detach_device_file' 'SFID    ' H16 }
      {X  'dmp$detach_device_file' 'STATCOND' I20 }

    dmk$mdfl_entries = dmk$base + 76,
      {D  'number of cm dfl entries' 'CMDFLS  ' I16 }

    dmk$get_exclu_access_to_lgt = dmk$base + 77,
      {E  'dmp$get_exclu_access_to_login_tabl' 'NULL    ' I16 }
      {X  'dmp$get_exclu_access_to_login_table' 'STATCOND' I20 }

    dmk$write_data_to_disk = dmk$base + 78,
      {E  'dmp$write_data_to_disk' 'numbytes' I16 }
      {X  'dmp$write_data_to_disk' 'STATCOND' I20 }

    dmk$store_existing_df_fat = dmk$base + 79,
      {E  'dmp$store_existing_df_fat' 'SFID    ' H16 }
      {X  'dmp$store_existing_df_fat' 'STATCOND' I20 }

    dmk$build_faus_from_dfl_entry = dmk$base + 80,
      {E  'dmp$build_faus_from_dfl_entry' 'SFID    ' H16 }
      {X  'dmp$build_faus_from_dfl_entry' 'STATCOND' I20 }

    dmk$build_fmd_for_existing_file = dmk$base + 81,
      {E  'dmp$build_fmd_for_existing_file' 'SFID    ' H16 }
      {X  'dmp$build_fmd_for_existing_file' 'STATCOND' I20 }

    dmk$create_device_file = dmk$base + 82,
      {E  'dmp$create_device_file' 'SFID    ' H16 }
      {X  'dmp$create_device_file' 'STATCOND' I20 }

    dmk$allocation_overflow_volume = dmk$base + 83,
      {E  'dmp$allocation_overflow_volume' 'FILEINDX' I16 }
      {X  'dmp$allocation_overflow_volume' 'STATCOND' I20 }

    dmk$recover_mainframe = dmk$base + 84,
      {E  'dmp$recover_mainframe' 'NULL    ' I16 }
      {X  'dmp$recover_mainframe' 'STATCOND' I20 }

    dmk$recover_set = dmk$base + 85,
      {E  'dmp$recover_set' 'NULL    ' I16 }
      {X  'dmp$recover_set' 'STATCOND' I20 }

    dmk$recover_volume = dmk$base + 86,
      {E  'dmp$recover_volume' 'NULL    ' I16 }
      {X  'dmp$recover_volume' 'STATCOND' I20 }

    dmk$recover_file = dmk$base + 87,
      {E  'dmp$recover_file' 'NULL    ' I16 }
      {X  'dmp$recover_file' 'STATCOND' I20 }

    dmk$activate_volume = dmk$base + 88,
      {E  'dmp$activate_volume' 'LUN     ' I16 }
      {X  'dmp$activate_volume' 'STATCOND' I20 }

    dmk$store_avt_set_ordinal = dmk$base + 89,
      {E  'dmp$store_avt_set_ordinal' 'AVTINDEX' I16 }
      {X  'dmp$store_avt_set_ordinal' 'STATUS  ' I16 }

    dmk$open_file_for_segment_acces = dmk$base + 90,
      {E  'dmp$open_file_for_segment_acces' 'SFID    ' H16 }
      {X  'dmp$open_file_for_segment_acces' 'STATCOND' I20 }

     dmk$free_file_tables = dmk$base + 91,
      {E  'dmp$free_file_tables' 'SFID    ' H16 }
      {X  'dmp$free_file_tables' 'STATCOND' I20 }

    dmk$monitor_log = dmk$base + 92,
      {E 'dmp$monitor_log' 'KIND    ' I8 }
      {X 'dmp$monitor_log' 'ABLE    ' I8 }

    dmk$utility_monitor_request = dmk$base + 93,
      {E  'dmp$utility_monitor_request' 'KIND    ' I8 }
      {X  'dmp$utility_monitor_request' 'STATCOND' I20 }

    dmk$get_device_flaws = dmk$base + 94,
      {E  'get_device_flaws' 'LUN     ' I16 }
      {X  'get_device_flaws' 'STATCOND' I20 }

    dmk$deactivate_volume = dmk$base + 95,
      {E  'dmp$deactivate_volume' 'AVT INDX' I16 }
      {X  'dmp$deactivate_volume' 'STATCOND' I20 }

    dmk$set_eoi = dmk$base + 96,
      {E  'dmp$set_eoi' 'SFID    ' H16 }
      {X  'dmp$set_eoi' 'STATCOND' I20 }

    dmk$fetch_eoi = dmk$base + 97,
      {E 'dmp$fetch_eoi' 'SFID    ' H16 }
      {X 'dmp$fetch_eoi' 'STATCOND' I20 }

    dmk$unlock_file = dmk$base + 98,
      {E  'dmp$unlock_file' 'SFID    ' H16 }
      {X  'dmp$unlock_file' 'STATCOND' I20 }

    dmk$get_initialized_addresses = dmk$base + 99,
      {E  'dmp$get_initialized_addresses' 'FBA     ' I20 }
      {X  'dmp$get_initialized_addresses' 'STATCOND' I20 }

    dmk$create_client_sft = dmk$base + 100,
       {E ' dmp$create_client_sft ' 'GFN     ' I52 }
       {X ' dmp$create_client_sft ' }

    dmk$fetch_server_sft_info = dmk$base + 101,
       {E ' dmp$fetch_server_sft_info ' }
       {X ' dmp$fetch_server_sft_info ' }

    dmk$df_client_set_eoi = dmk$base + 102,
       {E ' dmp$df_client_set_eoi ' }
       {X ' dmp$df_client_set_eoi ' }

    dmk$detach_server_file = dmk$base + 103,
       {E ' dmp$detach_server_file ' }
       {X ' dmp$detach_server_file ' }

    dmk$create_fmds = dmk$base + 104;
       {E ' dmp$create_fmds ' }
       {X ' dmp$create_fmds ' }

?? PUSH (LISTEXT := ON) ??
*copyc DMK$TAPE_KEYPOINTS
*copyc AMK$BASE_KEYPOINT_VALUES
?? POP ??
*DECK DECK=DMT$KEYPOINT_CALLS EXPAND=FALSE
*copyc DMT$KEYPOINTS
*DECK DECK=DMT$LOCKED_FILE EXPAND=FALSE
{
{                           common deck dmdlofi
{

  TYPE
    dmt$access_kind = (dmc$read_access, dmc$write_access),
    dmt$lock_file_status = (dmc$file_locked_for_caller, dmc$file_already_busy),
dmt$write_lock = (dmc$no_write_lock,dmc$write_lock,dmc$write_flush_lock),
    dmt$locked_file = record
      case required: boolean of
      = TRUE =
        locks: dmt$access_kind,
        read_lock_count: 0 .. 0ff(16),
        write_lock: dmt$write_lock,
      = FALSE =
        ,
      casend,
    recend;
*DECK DECK=DMT$LOGICAL_DEVICE_ATTRIBUTES EXPAND=FALSE
{
{ dmt$logical_device_attributes
{

  TYPE
    dmt$logical_device_attributes = array [1 .. * ] of
      dmt$logical_device_attribute,

    dmt$logical_device_attribute = record
      case keyword: dmt$logical_device_keywords of

      = dmc$cylinder_allocation_size =
        bytes_per_cylinder: 0 .. dmc$max_bytes_per_allocation,

      = dmc$logical_flaws =
        flaw_locations: array [1 .. dmc$max_logical_flaws] of
          dmt$flaw_list_entry,
        number_of_flaw_entries: dmt$dau_address,

      = dmc$volume_default_alloc_sz =
        volume_default_allocation_size: dmt$allocation_size,

      = dmc$volume_default_transfer_sz =
        volume_default_transfer_size: dmt$transfer_size,

      = dmc$volume_dfl_entries =
        number_dfl_entries: dmt$device_file_list_index,

      = dmc$volume_directory_entries =
        number_directory_entries: dmt$directory_index,

      casend,
    recend,

    dmt$logical_device_keywords = (dmc$cylinder_allocation_size, dmc$logical_flaws,
      dmc$volume_default_alloc_sz, dmc$volume_default_transfer_sz, dmc$volume_dfl_entries,
      dmc$volume_directory_entries);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$allocation_size
*copyc dmt$device_allocation_unit
*copyc dmt$device_file_list_index
*copyc dmt$directory_index
*copyc dmt$ms_flaw_list
*copyc dmt$transfer_size
?? POP ??
*DECK DECK=DMT$LOGICAL_UNIT_SPECIFICATION EXPAND=FALSE
      {
      {           common deck dmdlun
      {
      TYPE
         dmt$logical_unit_specification = RECORD
                  CASE by_recorded_vsn:BOOLEAN OF
                      =TRUE=
                           recorded_vsn:rmt$recorded_vsn,
                      =FALSE=
                           logical_unit_number:iot$logical_unit,
                  CASEND,
                                          RECEND;
*copyc IOT$LOGICAL_UNIT
*copyc RMD$VOLUME_DECLARATIONS
*DECK DECK=DMT$LOG_FLAW_INIT_DATA EXPAND=FALSE
{
{ dmt$log_flaw_init_data
{

  TYPE
    dmt$log_flaw_init_data = record
      recorded_vsn: rmt$recorded_vsn,
      first_dau: dmt$dau_address,
      last_dau: dmt$dau_address,
      operation_code: dmt$flaw_operation_code,
      initiator_code: dmt$flaw_initiator_code,
    recend;

  TYPE
    dmt$monitor_flaw_init_data = record
      message_type: integer,
      flaw_data: dmt$log_flaw_init_data,
    recend;

  TYPE
    dmt$flaw_initiator_code = 1 .. 3;

  CONST
    dmc$ic_system_initiated = 1,
    dmc$ic_operator_initiated = 2,
    dmc$ic_ce_initiated = 3;

  TYPE
    dmt$flaw_operation_code = 1 .. 2;

  CONST
    dmc$oc_flaw_define = 1,
    dmc$oc_flaw_remove = 2;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$device_allocation_unit
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=DMT$MAINFRAME_ALLOCATION_TABLE EXPAND=FALSE
{
{ dmt$mainframe_allocation_table
{

  TYPE
    dmt$mainframe_allocation_table = record
      avt_index: dmt$active_volume_table_index,
      bytes_per_dau: dmt$bytes_per_dau,
      bytes_per_mau: dmt$bytes_per_mau,
      maus_per_dau: dmt$maus_per_dau,
      daus_per_position: dmt$daus_per_position,
      positions_per_device: dmt$device_position,
      default_allocation_size: dmt$allocation_size,
      default_transfer_size: dmt$transfer_size,
      starting_position_number: dmt$device_position,
      starting_search_position: dmt$device_position,
      daus_per_allocation_unit: array [dmt$allocation_styles] of
        dmt$daus_per_position,
      available_allocation_units: array [dmt$allocation_styles] of
        dmt$dau_address,
      allocation_chains: array [dmt$allocation_styles] of dmt$position_link,
      minimum_space: dmt$dau_address,
      maximum_space: dmt$dau_address,
      available_space: dmt$dau_address,
      leftover_space: dmt$dau_address,
      allocated_space: dmt$allocated_space,
      mat_too_full: boolean,
      available_dat_space: dmt$dau_address,
      dat_threshold: dmt$dau_address,
      recovery_threshold: dmt$dau_address,
      warning_threshold: dmt$dau_address,
      p_available_daus: ^dmt$available_daus,
      mat_entries: array [0 .. * ] of dmt$mat_entry,
    recend,

    dmt$position_link = 0 .. dmc$nil_position_link,

    dmt$available_daus = packed array [0 .. * ] of boolean,

    dmt$mat_entry = record
      allocation_style: dmt$allocation_styles,
      available_allocation_units: dmt$daus_per_position,
      backward_link: dmt$position_link,
      forward_link: dmt$position_link,
    recend,

    dmt$allocated_space = array [gft$file_kind] of dmt$dau_address;

  CONST
    dmc$nil_position_link = dmc$max_device_position + 1;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc dmt$allocation_size
*copyc dmt$device_allocation_unit
*copyc dmt$device_position
*copyc dmt$minimum_allocation_unit
*copyc dmt$transfer_size
*copyc gft$file_kind
?? POP ??
*DECK DECK=DMT$MAINFRAME_ASSIGNED EXPAND=FALSE
{
{ dmt$mainframe_assigned
{

  TYPE
    dmt$mainframe_assigned = record
      log_in_sequence: dmt$login_table_sequence,
      log_in_index: dmt$login_table_entry_index,
    recend,

    dmt$login_table_sequence = 0 .. 0ffffffff(16),

    dmt$login_table_entry_index = 1 .. dmc$max_login_table_entries,

    dmt$login_table_entries = 0 .. dmc$max_login_table_entries + 1;

  CONST
    dmc$max_login_table_entries = 20;

*DECK DECK=DMT$MAINFRAME_DEVICE_FILE_LIST EXPAND=FALSE
{
{ dmt$mainframe_device_file_list
{

{
{ the ordinal field of dmt$ms_mf_file_list_entry must ONLY be referenced
{ using #compare_swap or the osp$ procedures which deal with 'locked variables'
{ when the type is used in a system table (as in the MFL).  this is critical
{ to dual processor.
{

  TYPE
    dmt$ms_mf_file_list_entry = record
      ordinal: ALIGNED [0 MOD 8] integer,
    recend;

  TYPE
    dmt$ms_mf_device_file_list = array [1 .. * ] of dmt$ms_mf_file_list_entry,
    dmt$ms_mf_device_file_list_ord = 0 .. dmc$max_device_file_list_index + 1;

  CONST
    dmc$cm_dflt_entries = 500;

*copyc dmt$device_file_list_index
*DECK DECK=DMT$MASS_STORAGE_ERROR_CODES EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc DMT$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=DMT$MAT_CHANGE_REQUEST EXPAND=FALSE
{
{ dmt$mat_change_request
{

  TYPE
    dmt$mat_change_request = record
      request_code: syt$monitor_request_code,
      avt_index: dmt$active_volume_table_index,
      CASE mat_change_type: dmt$mat_change_type of

      = dmc$change_dat_threshold =
        dat_threshold: dmt$dau_address,

      = dmc$add_mat_space, dmc$remove_mat_space =
        mat_change_count: dmt$mat_change_count,
        p_mat_changes: ^dmt$mat_changes,
        available_dat_space: dmt$dau_address,
      CASEND,
    recend,

    dmt$mat_change_type = (dmc$change_dat_threshold, dmc$add_mat_space,
          dmc$remove_mat_space),

    dmt$mat_change_count = 0 .. 0ffff(16),

    dmt$mat_changes = array [1 .. * ] of dmt$mat_change,

    dmt$mat_change = record
      style: dmt$allocation_styles,
      dau_address: dmt$dau_address,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc dmt$allocation_size
*copyc dmt$device_allocation_unit
*copyc syc$monitor_request_codes
?? POP ??
*DECK DECK=DMT$MAT_CONVERTER EXPAND=FALSE
{
{ dmt$mat_converter
{

  TYPE
    dmt$mat_converter = record
      case boolean of
      = FALSE =
        p_adaptable: cyt$adaptable_array_pointer,
      = TRUE =
        p_mat: ^dmt$mainframe_allocation_table,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cyd$cybil_structure_definitions
*copyc dmt$mainframe_allocation_table
?? POP ??

*DECK DECK=DMT$MAU_LIST EXPAND=FALSE

  CONST
    dmc$max_mau_addresses = 10000;

  TYPE
    dmt$mau_list = RECORD
      header: dmt$mau_list_header,
      mau_addresses: ARRAY [1 .. dmc$max_mau_addresses] OF dmt$mau_address_entry,
    RECEND,

    dmt$mau_list_header = RECORD
      valid_data: integer,
      first_mau_of_maufile: dmt$mau_address_entry,
      dsfile_name: ost$name,
      maufile_name: ost$name,
      block_size: integer,
      total_mau_addresses: integer,
      next_mau_list_address: dmt$mau_address_entry,
    RECEND,

    dmt$mau_address_list = ARRAY [1 .. *] OF dmt$mau_address_entry,

    dmt$mau_count = 0 .. dmc$max_mau_addresses,

    dmt$mau_address_entry = integer;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=DMT$MESSAGE_ELEMENT EXPAND=FALSE
{dmdmid}
{        tape message identifier types

  TYPE
    dmt$message_id = (dmc$null, dmc$volume, dmc$scratch, dmc$ring, dmc$no_ring,
      dmc$ready, dmc$configure, dmc$assigned, dmc$reserved, dmc$inoperable,
      dmc$type, dmc$no_vsn, dmc$vsn_online),

    dmt$message_element = record
      element_name: ost$name,
      case mid: dmt$message_id of

      = dmc$null =
        ,

      = dmc$volume =
        external_vsn: rmt$external_vsn,
        ring: rmt$write_ring,

      = dmc$scratch =
        wrng: rmt$write_ring,

      = dmc$ring, dmc$no_ring, dmc$ready, dmc$configure, dmc$assigned,
        dmc$reserved, dmc$inoperable, dmc$type, dmc$no_vsn =
        ,

      = dmc$vsn_online =
        vsn: rmt$external_vsn,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc OST$NAME
*copyc RMD$TAPE_DECLARATIONS
?? POP ??
*DECK DECK=DMT$MINIMUM_ALLOCATION_UNIT EXPAND=FALSE
{
{  dmt$minimum_allocation_unit
{

  TYPE
    dmt$bytes_per_mau = 0 .. dmc$max_bytes_per_mau,
    dmt$maus_per_allocation = dmc$min_maus_per_allocation ..
      dmc$max_maus_per_allocation,
    dmt$mau_offset_within_au = 0 .. dmc$max_maus_per_allocation,
    dmt$maus_per_dau = dmc$min_maus_per_dau .. dmc$max_maus_per_dau,
    dmt$mau_offset_within_dau = 0 .. dmc$max_maus_per_dau,
    dmt$maus_per_transfer = dmc$min_maus_per_transfer ..
      dmc$max_maus_per_transfer,
    dmt$mau_offset_within_tu = 0 .. dmc$max_maus_per_transfer,
    dmt$maus_per_position = 0 .. dmc$max_maus_position,
    dmt$mau_address = dmc$min_mau_address .. dmc$max_mau_address;

  CONST
    dmc$min_bytes_per_mau = 1,
    dmc$max_bytes_per_mau = 8192,
    dmc$min_maus_per_allocation = 2,
    dmc$max_maus_per_allocation = 392,
    dmc$min_maus_per_dau = 2,
    dmc$max_maus_per_dau = 48,
    dmc$min_maus_per_transfer = 1,
    dmc$max_maus_per_transfer = 392,
    dmc$min_mau_address = 0,
    dmc$max_mau_address = dmc$max_dau_address * dmc$max_maus_per_dau,
    dmc$min_maus_position = 1,
    dmc$max_maus_position = dmc$max_daus_position * dmc$max_maus_per_dau;

*copyc DMT$DEVICE_ALLOCATION_UNIT
*DECK DECK=DMT$MONITOR_REQUESTS EXPAND=FALSE
{
{                    common deck dmdmrbs
{

  TYPE
    dmt$monitor_request_block = record
      system_file_id: dmt$system_file_id,
      file_kind: gft$file_kind,
      case request_code: dmt$monitor_request of
      = dmc$allocate_space =
        allocate_byte_address: amt$file_byte_address,
        number_allocation_units_needed: amt$file_byte_address,
        recorded_vsn: rmt$recorded_vsn,
        allocation_style: dmt$allocation_styles,
        {
        { output parameter
        {
        overflow_indicator: dmt$ms_overflow_indicator,
        previous_au_dau_address: amt$file_byte_address,
        allocation_units_obtained: amt$file_byte_address,
        file_space_limit: sft$file_space_limit_kind,
      = dmc$deallocate_space =
        release_byte_address: amt$file_byte_address,
        bytes_to_release: amt$file_byte_address,
        able_to_release_all_space: boolean,
      = dmc$trim_file_space =
        avt_index: dmt$active_volume_table_index,
        global_file_name: dmt$global_file_name,
        dfl_index: dmt$device_file_list_index,
        dau_address: dmt$dau_address,
        dau_of_fragment: dmt$dau_address,
      casend,
    recend;

  TYPE
    dmt$monitor_request = (dmc$allocate_space, dmc$deallocate_space,
       dmc$trim_file_space, dmc$req2, dmc$req3, dmc$req4, dmc$req5, dmc$req6);

*copyc AMT$FILE_BYTE_ADDRESS
*copyc DMT$ALLOCATION_SIZE
*copyc DMT$OVERFLOW_ALLOWED
*copyc DMT$SYSTEM_FILE_ID
*copyc gft$file_kind
*copyc RMD$VOLUME_DECLARATIONS
*copyc SFT$FILE_SPACE_LIMIT_KIND
*DECK DECK=DMT$MONITOR_REQUEST_BLOCKS EXPAND=FALSE
{
{ dmt$monitor_request_blocks
{

  TYPE
    dmt$monitor_rb_allocate_space = record
      request_code: syt$monitor_request_code,
      case update_fat_pointer: boolean of
      = FALSE =
        system_file_id: gft$system_file_identifier,
        allocate_byte_address: amt$file_byte_address,
        requested_allocation: amt$file_byte_address,
        file_space_limit: sft$file_space_limit_kind,
        {
        { output parameters
        {
        overflow_indicator: boolean,
        allocation_units_obtained: amt$file_byte_address,
        status: dmt$file_allocation_status,
      = TRUE =
        p_dfd: ^dmt$disk_file_descriptor,
        p_fat: ^dmt$level_1_table,
        fat_upper_bound: dmt$level_1_index,
      casend,
    recend;

  TYPE
    dmt$monitor_rb_deallocate_space = record
      request_code: syt$monitor_request_code,
      system_file_id: gft$system_file_identifier,
      status: syt$monitor_status,           { this field is an output parameter
      p_fde: gft$locked_file_desc_entry_p,
      case monitor_request: dmt$monitor_request of
      = dmc$trim_file_space =
        avt_index: dmt$active_volume_table_index,
        global_file_name: dmt$global_file_name,
        dfl_index: dmt$device_file_list_index,
        dau_address: dmt$dau_address,
        dau_of_fragment: dmt$dau_address,
      = dmc$deallocate_space =
        bytes_to_release: integer,
        release_byte_address: amt$file_byte_address,
        able_to_release_all_space: boolean, { this field is an output parameter
      casend,
    recend;

  TYPE
    dmt$monitor_rb_reallocate_space = record
      request_code: syt$monitor_request_code,
      p_fde: gft$locked_file_desc_entry_p,
      system_file_id: gft$system_file_identifier,
      reallocate_byte_address: amt$file_byte_address,
      global_file_name: dmt$global_file_name,
      copy_pages: boolean,
      {
      { output parameters
      {
      allocation_units_obtained: amt$file_byte_address,
      status: syt$monitor_status,
    recend;

*copyc amt$file_byte_address
*copyc dmt$allocation_size
*copyc dmt$device_file_list_index
*copyc dmt$file_allocation_status
*copyc dmt$monitor_requests
*copyc dmt$overflow_allowed
*copyc gft$locked_file_desc_entry_p
*copyc gft$system_file_identifier
*copyc jmt$ajl_ordinal
*copyc rmd$volume_declarations
*copyc sft$file_space_limit_kind
*copyc syc$monitor_request_codes
*copyc syt$monitor_request_code
*DECK DECK=DMT$MS_ACTIVE_VOL_TABLE_ENTRY EXPAND=FALSE
{
{ dmt$ms_active_vol_table_entry
{

  TYPE
    dmt$ms_active_vol_table_entry = record
      allocation_allowed: ALIGNED [0 MOD 8] boolean,
      space_low: boolean,
      space_gone: boolean,
      disk_table_status: dmt$ms_volume_table_status,
      class: dmt$class,
      system_class_activity: array [dmt$system_class] of 0 .. 0ffffffff(16),
      logged_in_for_recovery: boolean,
      update_lock: ost$signature_lock,
      logging_lock: ost$signature_lock,
      internal_vsn: dmt$internal_vsn,
      p_device_allocation_table: dmt$system_file_id,
      p_device_file_list_table: dmt$system_file_id,
      p_device_log: dmt$system_file_id,
      p_directory: dmt$system_file_id,
      p_login_table: dmt$system_file_id,
      mainframe_assigned: dmt$mainframe_assigned,
      p_mat: cyt$adaptable_array_pointer,
      p_mfl: cyt$adaptable_array_pointer,
      recorded_vsn: rmt$recorded_vsn,
      set_name: stt$set_name,
      status: dmt$ms_volume_system_status,
      volume_owner: ost$user_identification,
      current_position_offset_in_log: amt$file_byte_address,
      allocated_log_size: amt$file_byte_address,
      device_log_entry_count: integer,
      volume_unavailable: boolean,
      previous_allocation_allowed: boolean,
      logging_process_damaged: boolean,
    recend;

  TYPE
    dmt$ms_avt_status = (dmc$mainframe_mounted, dmc$mainframe_dismounted,
      dmc$system_mounted, dmc$system_dismounted),

    dmt$ms_volume_system_status = set of dmt$ms_avt_status;

  TYPE
    dmt$disk_table_status = (dmc$table_update_inhibited,
      dmc$table_update_in_progress, dmc$dflt_update_required,
      dmc$no_available_dflt_entries, dmc$volume_low_on_dfl_entries),

    dmt$ms_volume_table_status = set of dmt$disk_table_status;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc cyd$cybil_structure_definitions
*copyc dmt$class
*copyc dmt$internal_vsn
*copyc dmt$mainframe_assigned
*copyc dmt$system_file_id
*copyc ost$signature_lock
*copyc ost$user_identification
*copyc rmd$volume_declarations
*copyc std$set_name
?? POP ??





*DECK DECK=DMT$MS_DEVICE_ALLOCATION_TABLE EXPAND=FALSE
{
{ dmt$ms_device_allocation_table
{

  TYPE
    dmt$ms_device_allocation_unit = record
      case dau_status: dmt$dau_status of

      = dmc$dau_assigned_to_mainframe, dmc$dau_ass_to_mf_swr_flawed =
        mainframe_id: dmt$mainframe_assigned,

      = dmc$dau_assigned_to_file, dmc$dau_ass_to_file_swr_flawed =
        file_hash: dmt$file_hash,
        data_status: dmt$dau_data_status,
        case allocation_chain_position: dmt$allocation_chain_position of

        = dmc$first_and_last_allocation, dmc$last_allocation =
          low_dfl_index: dmt$old_dfl_index,
          pad: 0 .. 0ff(16),
          high_dfl_index: 0 .. 0ff(16),

        = dmc$first_allocation, dmc$middle_allocation =
          next_allocation_unit_dau: dmt$dau_address,
        casend,
      casend,
    recend;

  TYPE
    dmt$ms_device_alloc_table_head = record
      unused: array [0 .. 2] of 0 .. 0ffffffffffff(16),
      default_allocation_size: dmt$allocation_size,
      default_transfer_size: dmt$transfer_size,
      bytes_per_dau: dmt$bytes_per_dau,
      bytes_per_mau: dmt$bytes_per_mau,
      daus_per_position: dmt$daus_per_position,
      maus_per_dau: dmt$maus_per_dau,
      positions_per_device: dmt$device_position,
      number_of_entries: dmt$dau_address,
      case version_number: dmt$ms_dat_version_number of

      = dmc$dat_0_0 =
        pad1: array [1 .. 6] of 0 .. 0ffff(16),
        daus_per_allocation_style: array [dmt$allocation_styles] of
          dmt$daus_per_position,
        alloc_style_padding: array [1 .. 2] of dmt$daus_per_position,
        pad2: array [1 .. 9] of dmt$dau_address,
        available: dmt$dau_address,
        pad3: array [1 .. 10] of dmt$dau_address,
        recovery_threshold: dmt$dau_address,
        warning_threshold: dmt$dau_address,

      = dmc$dat_1_0 =
        largest_variant: SEQ (REP dmc$largest_dat_header_variant of cell),
      casend,
    recend;

  TYPE
    dmt$ms_device_allocation_table = record
      header: dmt$ms_device_alloc_table_head,
      body: ALIGNED [0 MOD 8] array [0 .. * ] of dmt$ms_device_allocation_unit,
    recend;

  TYPE
    dmt$dau_data_status = (dmc$dau_data_initialized,
      dmc$dau_data_not_initialized),

    dmt$ms_dat_version_number = (dmc$dat_0_0, dmc$dat_1_0),

    dmt$dau_status = (dmc$dau_usable, dmc$dau_hardware_flawed,
      dmc$dau_software_flawed, dmc$dau_assigned_to_mainframe,
      dmc$dau_assigned_to_file, dmc$dau_ass_to_mf_swr_flawed,
      dmc$dau_ass_to_file_swr_flawed),

    dmt$dau_states = set of dmt$dau_status;

  TYPE
    dmt$dat_lock = record
      status: ALIGNED [0 MOD 8] ost$compare_swap_lock,
    recend;

  TYPE
    dmt$dau_status_counts = array [dmt$dau_status] of dmt$dau_address;

  CONST
    dmc$largest_dat_header_variant = 2048, {bytes}

    dmc$dat_allocation_size = dmc$default_req_alloc_size,

    dmc$dat_transfer_size = dmc$default_transfer_size;

  { As a means of validating allocation chains, the last allocation unit DAU
  { of each file contains the DFL index for that file.  The DFL index is now
  { three bytes long but is stored in two pieces in order to provide file
  { compatibility with system levels having a two byte value.  The high order
  { piece is stored in a byte that has never been used by older systems, and
  { therefore is zero.
  {
  { The constant dmc$dfl_index_converter is used to convert back and forth
  { between the two versions of a DFL index.

  CONST
    dmc$dfl_index_converter = 10000(16);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$allocation_chain_position
*copyc dmt$allocation_size
*copyc dmt$device_allocation_unit
*copyc dmt$device_file_list_index
*copyc dmt$device_position
*copyc dmt$file_hash
*copyc dmt$mainframe_assigned
*copyc dmt$minimum_allocation_unit
*copyc dmt$transfer_size
*copyc ost$signature_lock
?? POP ??


*DECK DECK=DMT$MS_DEVICE_FILE_LIST_ENTRY EXPAND=FALSE
{
{ dmt$ms_device_file_list_entry
{

  TYPE
    dmt$ms_device_file_list_entry = record
      pad: 0 .. 0ffff(16),
      case flags: dmt$dfl_entry_flags of

      = dmc$dfle_assigned_to_file =
        dau_chain_status: dmt$dau_chain_status,
        daus_per_allocation_unit: dmt$daus_per_allocation,
        file_byte_address: amt$file_byte_address,
        file_hash: dmt$file_hash,
        file_kind: gft$file_kind,
        first_dau_address: dmt$dau_address,
        global_file_name: dmt$global_file_name,
        fmd_length: amt$file_byte_address,
        logical_length: amt$file_byte_address,
        end_of_information: amt$file_byte_address,
        end_of_file: amt$file_byte_address,
        login_set: dmt$dfl_login_set,
        damage: dmt$file_damage,

      = dmc$dfle_assigned_to_mainframe =
        mainframe_assigned: dmt$mainframe_assigned,
      casend,
    recend,

    dmt$ms_device_file_list_header = record
      unused: string (23),
      number_of_entries: dmt$device_file_list_index,
      version_number: dmt$ms_dflt_version_number,
    recend,

    dmt$dfl_login_set = set of dmt$login_table_entry_index;

  TYPE
    dmt$ms_device_file_list_table = record
      header: dmt$ms_device_file_list_header,
      entries: array [1 .. * ] of dmt$ms_device_file_list_entry,
    recend;

  CONST
    dmc$device_file_list_dfl_index = 1,

    dmc$dat_dfl_index = 2,

    dmc$directory_dfl_index = 3,

    dmc$label_dfl_index = 4,

    dmc$login_table_dfl_index = 5,

    dmc$min_volume_dfl_entries = 30,

    dmc$max_volume_dfl_entries = 65535,

    dmc$default_volume_dfl_entries = 3000,

    dmc$min_device_file_list_ord = 10;

  TYPE
    dmt$device_file_list_keywords = (dmc$dfle_byte_address,
      dmc$dfle_daus_per_allocation, dmc$dfle_file_hash, dmc$dfle_file_type,
      dmc$dfle_global_file_name);

  TYPE
    dmt$device_file_list_attribute = record
      case keyword: dmt$device_file_list_keywords of

      = dmc$dfle_byte_address =
        value: amt$file_byte_address,

      = dmc$dfle_daus_per_allocation =
        daus_per_allocation: dmt$daus_per_allocation,

      = dmc$dfle_file_hash =
        file_hash: dmt$file_hash,

      = dmc$dfle_global_file_name =
        gfn: dmt$global_file_name,

      = dmc$dfle_file_type =
        file_kind: gft$file_kind,
      casend,
    recend;

  TYPE
    dmt$ms_dflt_version_number = (dmc$dflt_0_0, dmc$dflt_1_0),

    dmt$dfl_entry_flags = (dmc$dfle_available, dmc$dfle_assigned_to_mainframe,
      dmc$dfle_assigned_to_file);

  TYPE
    dmt$dau_chain_status = (dmc$dau_chain_linked, dmc$dau_chain_not_linked);

  CONST
    dmc$dfl_allocation_size = dmc$default_req_alloc_size,

    dmc$dfl_transfer_size = dmc$default_transfer_size;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmt$allocation_size
*copyc dmt$device_allocation_unit
*copyc dmt$device_file_list_index
*copyc dmt$file_damage
*copyc dmt$file_hash
*copyc dmt$global_file_name
*copyc dmt$mainframe_assigned
*copyc dmt$transfer_size
*copyc gft$file_kind
?? POP ??
*DECK DECK=DMT$MS_FLAW_LIST EXPAND=FALSE
{
{            common deck dmdflaw
{

  TYPE
    dmt$ms_flaw_list = array [ * ] of dmt$flaw_list_entry,
    dmt$flaw_list_entry = RECORD
         dau_address:dmt$dau_address,
         number_flawed_daus:dmt$dau_address,
                          RECEND,
    dmt$flaw_map_address = record
      device_flaws_specified: boolean,
      mau_address: dmt$mau_address,
      mau_byte_offset: dmt$bytes_per_mau,
    recend,
    dmt$flaw_map_entry = packed record
      sector_flaw_entry: boolean,
      track_flaw_entry: boolean,
      cylinder: 0 .. 1023,
      track: 0 .. 63,
      sector: 0 .. 63,
    recend;

  CONST
    dmc$max_logical_flaws = 3,
    dmc$max_flaw_locations = 1;
?? PUSH (LISTEXT := ON) ??
*copyc DMT$MINIMUM_ALLOCATION_UNIT
*copyc DMT$DEVICE_POSITION
  ?? POP ??
*DECK DECK=DMT$MS_LABELS EXPAND=FALSE
{
{                  common deck dmdvlab
{

  TYPE
    dmt$ms_label_types = (dmc$nosve_label, dmc$nos_label, dmc$nosbe_label);
*DECK DECK=DMT$MS_LOGICAL_DEVICE_ADDRESS EXPAND=FALSE
{
{                    common deck dmdldad
{

  TYPE
    dmt$ms_logical_device_address = record
      allocation_unit_mau_address: dmt$mau_address,
      maus_per_position: dmt$maus_per_position,
      logical_unit_number: iot$logical_unit,
      transfer_length: dmt$maus_per_transfer,
      transfer_mau_offset: dmt$mau_offset_within_tu,
      CASE write_translation:BOOLEAN OF
           =TRUE=
              au_was_previously_written:BOOLEAN,
              maus_per_allocation_unit:dmt$maus_per_allocation,
              preset_value:amt$preset_value,
           =FALSE=
              ,
      CASEND,
    recend;

  TYPE
    dmt$write_tu_status = (dmc$tu_written, dmc$tu_not_written);

*copyc AMT$PRESET_VALUE
*copyc DMT$MINIMUM_ALLOCATION_UNIT
*copyc IOT$LOGICAL_UNIT
*DECK DECK=DMT$MS_LOGIN_TABLE EXPAND=FALSE
{
{ dmt$ms_login_table
{

  TYPE
    dmt$ms_mf_login_table_entry = record
      login_status: dmt$mf_login_table_entry_status,
      mainframe_identification: pmt$processor_attributes,
      avt_index: dmt$active_volume_table_index,
      mainframe_assigned: dmt$mainframe_assigned,
      device_log_name: ost$name,
      last_last_update_offset: integer,
      last_update_offset: integer,
      current_position_offset: integer,
      recovery_status: dmt$login_table_recovery_status,
    recend,

    dmt$mf_login_table_entries = array [1 .. * ] of
      dmt$ms_mf_login_table_entry;

  TYPE
    dmt$ms_mf_login_table_header = record
      unused: ALIGNED [0 MOD 8] array [0 .. 2] of integer,
      sequence: dmt$login_table_sequence,
      lower_bound: dmt$login_table_entry_index,
      upper_bound: dmt$login_table_entry_index,
    recend;

  TYPE
    dmt$ms_mainframe_login_table = record
      header: dmt$ms_mf_login_table_header,
      body: dmt$mf_login_table_entries,
    recend;

  TYPE
    dmt$mf_login_table_entry_status = (dmc$lt_entry_available,
      dmc$lt_alloc_assigned_to_mf, dmc$lt_mf_logged_in),

    dmt$login_table_recovery_status = (dmc$lt_normal_status, dmc$lt_recovering,
      dmc$lt_being_recovered, dmc$lt_being_rec_log_complete,
      dmc$lt_being_rec_alloc_complete),

    dmt$login_entry_type = (dmc$free_login_entry, dmc$production_login_entry,
          dmc$recovery_login_entry);

  CONST
    dmc$default_login_table_entries = 10,

    dmc$login_table_allocation_size = dmc$default_req_alloc_size,

    dmc$login_table_transfer_size = dmc$default_transfer_size,

    dmc$max_login_table_lngth_bytes = 5000;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc dmt$allocation_size
*copyc dmt$mainframe_assigned
*copyc dmt$transfer_size
*copyc ost$name
*copyc pmt$processor_attributes
?? POP ??
*DECK DECK=DMT$MS_PHYSICAL_CHARACTERISTICS EXPAND=FALSE
{
{             common deck dmdsect
{
   CONST
       dmc$default_sectors_per_track = 32,
       dmc$default_sectors_per_mau = 4;
*DECK DECK=DMT$MS_VOLUME_DIRECTORY EXPAND=FALSE
{
{ dmt$ms_volume_directory
{

  TYPE
    dmt$ms_volume_directory_entry = record
      entry_available: boolean,
      user_supplied_name: ost$name,
      global_file_name: dmt$global_file_name,
      stored_df_fmd: dmt$device_file_stored_fmd,
    recend,

    dmt$ms_volume_directory_entries = array [1 .. * ] of
      dmt$ms_volume_directory_entry,

    dmt$ms_volume_directory_head = record
      unused: ALIGNED [0 MOD 8] array [0 .. 2] of integer,
      number_of_entries: dmt$directory_index,
    recend,

    dmt$ms_volume_directory = record
      header: dmt$ms_volume_directory_head,
      entries: dmt$ms_volume_directory_entries,
    recend;

  CONST
    dmc$label_directory_index = 1,
    dmc$dat_directory_index = 2,
    dmc$dflt_directory_index = 3,
    dmc$directory_directory_index = 4,
    dmc$default_vol_dir_entries = 100,
    dmc$directory_allocation_size = dmc$default_req_alloc_size,
    dmc$directory_transfer_size = dmc$default_transfer_size,
    dmc$max_directory_length_bytes = 75000;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$allocation_size
*copyc dmt$device_file_stored_fmd
*copyc dmt$directory_index
*copyc dmt$global_file_name
*copyc dmt$transfer_size
*copyc ost$name
*copyc ost$signature_lock
?? POP ??
*DECK DECK=DMT$MS_VOLUME_LABEL EXPAND=FALSE
{
{ dmt$ms_volume_label
{

  TYPE
    dmt$ms_volume_label = SEQ ( * ),

    dmt$volume_label_header = record
      label_type: string (8),
      bytes_per_dau: dmt$bytes_per_dau,
      bytes_per_mau: dmt$bytes_per_mau,
      creation_date: dmt$date,
      expiration_date: dmt$date,
      internal_vsn: dmt$internal_vsn,
      positions_per_device: dmt$device_position,
      recorded_vsn: rmt$recorded_vsn,
      version_number: dmt$ms_label_version_number,
      primary_deadstart_file,
      secondary_deadstart_file,
      image_file,
      spare_file: integer,
    recend;

  TYPE
    dmt$ms_label_0_0 = record
      access_code: ost$name,
      dat_dfl_entry: dmt$ms_device_file_list_entry,
      device_allocation_table_fmd: dmt$device_file_stored_fmd,
      device_file_list_dfl_entry: dmt$ms_device_file_list_entry,
      device_file_list_fmd: dmt$device_file_stored_fmd,
      directory_dfl_entry: dmt$ms_device_file_list_entry,
      directory_fmd: dmt$device_file_stored_fmd,
      owner_id: ost$user_identification,
      class: dmt$class,
    recend;

  TYPE
    dmt$label_device_file_fats = SEQ ( * ),
    device_allocation_table_fat = dmt$stored_ms_device_file_fat;

  TYPE
    dmt$ms_label_version_number = (dmc$ms_label_0_0, dmc$ms_label_1_0);

  CONST
    dmc$max_label_aus = 2,

    dmc$max_volume_label_size = 2000,

    dmc$default_label_alloc_size = dmc$default_req_alloc_size,

    dmc$default_label_transfer_size = dmc$default_label_alloc_size;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$class
*copyc dmt$date
*copyc dmt$device_allocation_unit
*copyc dmt$device_file_stored_fmd
*copyc dmt$device_position
*copyc dmt$file_allocation_table
*copyc dmt$internal_vsn
*copyc dmt$minimum_allocation_unit
*copyc dmt$ms_device_file_list_entry
*copyc ost$name
*copyc ost$user_identification
*copyc rmd$volume_declarations
?? POP ??
*DECK DECK=DMT$NEW_DEVICE_FILE_ATTRIBUTE EXPAND=FALSE

  TYPE
    dmt$new_device_file_attribute = record
      case keyword: dmt$file_attribute_keywords of
      = dmc$clear_space =
        required: ost$clear_file_space,
      = dmc$file_limit =
        limit: amt$file_limit,
      = dmc$preset_value =
        preset_value: amt$preset_value,
      = dmc$requested_allocation_size =
        requested_allocation_size: dmt$allocation_size,
      = dmc$requested_transfer_size =
        requested_transfer_size: dmt$transfer_size,
      casend,
    recend;

*copyc OST$CLEAR_FILE_SPACE
*copyc AMD$FILE_ATTRIBUTES
*copyc AMT$PRESET_VALUE
*copyc DMT$FILE_ATTRIBUTES
*copyc DMT$ALLOCATION_SIZE
*copyc DMT$TRANSFER_SIZE
*DECK DECK=DMT$NEW_FILE_ATTRIBUTE EXPAND=FALSE
{
{                      common deck dmdnfil
{

  TYPE
    dmt$new_file_attribute = record
      case keyword: dmt$file_attribute_keywords of
      = dmc$class =
        class: dmt$class_member,
      = dmc$class_ordinal =
        ordinal: dmt$class_ordinal,
      = dmc$clear_space =
        required: ost$clear_file_space,
      = dmc$file_limit =
        limit: amt$file_limit,
      = dmc$locked_file =
        file_lock:dmt$locked_file,
      = dmc$master_volume_required =
        master_volume_required: boolean,
      = dmc$overflow =
        overflow_allowed: dmt$ms_overflow_allowed,
      = dmc$owner =
        file_space_limit: sft$file_space_limit_kind,
      = dmc$preset_value =
        preset_value: amt$preset_value,
      = dmc$requested_allocation_size =
        requested_allocation_size: dmt$allocation_size,
      = dmc$requested_transfer_size =
        requested_transfer_size: dmt$transfer_size,
      = dmc$requested_volume =
        requested_volume: dmt$requested_volume,
  =dmc$chapter_length=
    chapter_length: ost$segment_length,
      casend,
    recend;

*copyc AMT$PRESET_VALUE
*copyc OST$HARDWARE_SUBRANGES
*copyc AMD$FILE_ATTRIBUTES
*copyc DMT$ALLOCATION_SIZE
*copyc DMT$CLASS
*copyc DMT$FILE_ATTRIBUTES
*copyc DMT$LOCKED_FILE
*copyc DMT$OVERFLOW_ALLOWED
*copyc DMT$TRANSFER_SIZE
*copyc DMT$REQUESTED_VOLUME_ATTRIBUTES
*copyc OST$CLEAR_FILE_SPACE
*copyc RMD$VOLUME_DECLARATIONS
*DECK DECK=DMT$OLD_IMAGE_POINTERS EXPAND=FALSE

  TYPE
    dmt$old_image_status = (dmc$old_image_not_available,
      dmc$old_image_available);

  TYPE
    dmt$old_image_pointers = record
      old_image_status: dmt$old_image_status,
      old_wired_segment: ost$segment,
      old_allocation_log_info: ^dmt$allocation_log_info,
      p_avt_pointer: ^^dmt$active_volume_table,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table
*copyc dmt$allocation_log
*copyc dmt$file_descriptor_entry
*copyc osd$virtual_address
?? POP ??
*DECK DECK=DMT$OUT_OF_SPACE_SETS EXPAND=FALSE
{
{ dmt$out_of_space_sets
{

  TYPE
    dmt$out_of_space_sets = array [1 .. *] of dmt$out_of_space_set,

    dmt$out_of_space_set = record
      set_name: stt$set_name,
      classes: dmt$class,
    recend;
*DECK DECK=DMT$OVERFLOW_ALLOWED EXPAND=FALSE
{
{                 common deck dmdover
{

  TYPE
    dmt$ms_overflow_allowed = boolean,
    dmt$ms_overflow_indicator = record
      occured: boolean,
      byte_address: amt$file_byte_address,
    recend;

*copyc AMT$FILE_BYTE_ADDRESS
*DECK DECK=DMT$PHYSICAL_DEVICE_ATTRIBUTES EXPAND=FALSE
{
{ dmt$physical_device_attributes
{

  TYPE
    dmt$physical_device_attributes = array [1 .. * ] of
      dmt$physical_device_attribute,

    dmt$physical_device_attribute = record
      case keyword: dmt$physical_device_keywords of

      = dmc$bytes_per_mau =
        bytes_per_mau: dmt$bytes_per_mau,

      = dmc$cylinders_per_device =
        cylinders_per_device: dmt$device_position,

      = dmc$flaw_map_locations =
        flaw_locations: array [1 .. dmc$max_flaw_locations] of
          dmt$flaw_map_address,

      = dmc$maus_per_cylinder =
        maus_per_cylinder: dmt$maus_per_position,

      = dmc$maus_per_dau =
        maus_per_dau: dmt$maus_per_dau,

      = dmc$sectors_per_mau =
        sectors_per_mau: iot$sectors_per_mau,

      = dmc$sectors_per_track =
        sectors_per_track: iot$sectors_per_track,

      casend,
    recend,

    dmt$physical_device_keywords = (dmc$bytes_per_mau, dmc$cylinders_per_device,
      dmc$flaw_map_locations, dmc$maus_per_cylinder, dmc$maus_per_dau,
      dmc$sectors_per_mau, dmc$sectors_per_track);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$device_position
*copyc dmt$minimum_allocation_unit
*copyc dmt$ms_flaw_list
*copyc iot$disk_type_table
?? POP ??
*DECK DECK=DMT$PHYSICAL_FLAW_ADDRESS EXPAND=FALSE
{
{ dmt$physical_flaw_address
{

  TYPE
    dmt$physical_flaw_address = record
      cylinder: iot$cylinder,
      track: iot$track,
      sector: iot$sector,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc iot$cylinder
?? POP ??

*DECK DECK=DMT$QUEUE_STATUS EXPAND=FALSE
{
{ dmt$queue_status
{

  TYPE
    dmt$queue_status = (dmc$global_shared, dmc$job_shared, dmc$job_working_set);

*DECK DECK=DMT$RECONCILE_INFO EXPAND=FALSE
{
{ dmt$reconcile_info
{

  TYPE
    dmt$reconcile_info = record
      p_sorted_reconcile_list: dmt$p_reconcile_list,
    recend,

    dmt$p_reconcile_list = ^array [1 .. * ] of dmt$reconcile_entry,

    dmt$reconcile_entry = record
      global_file_name: dmt$global_file_name,
      byte_address: amt$file_byte_address,
      avt_index: dmt$active_volume_table_index,
      dfl_index: dmt$device_file_list_index,
      reconciled: boolean,
      purge: boolean,
    recend,

    dmt$reconcile_index = 0 .. 7fffffff(16);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmt$active_volume_table_index
*copyc dmt$device_file_list_index
*copyc dmt$global_file_name
*copyc dmt$internal_vsn
?? POP ??
*DECK DECK=DMT$RECONCILE_LOCATOR EXPAND=FALSE
{
{ dmt$reconcile_locator
{

  TYPE
    dmt$reconcile_locator = ^cell;
*DECK DECK=DMT$REQUESTED_VOLUME_ATTRIBUTES EXPAND=FALSE
{
{                common deck dmdreqv
{

  TYPE
    dmt$request_volume_attribute = record
      case keyword: dmt$file_attribute_keywords of
      = dmc$class =
        class: dmt$class_member,
      = dmc$class_ordinal =
        class_ordinal: dmt$class_ordinal,
      = dmc$recorded_vsn =
        recorded_vsn: rmt$recorded_vsn,
      = dmc$file_kind =
        file_kind: gft$file_kind,
      = dmc$master_volume_required =
        master_requested: boolean,
      = dmc$requested_allocation_size =
        requested_allocation_size: dmt$allocation_size,
    =dmc$setname=
       setname:stt$set_name,
      casend,
    recend,
    dmt$requested_volume = record
      recorded_vsn: rmt$recorded_vsn,
      setname: stt$set_name,
    recend;

*copyc DMT$ALLOCATION_SIZE
*copyc DMT$CLASS
*copyc DMT$FILE_ATTRIBUTES
*copyc gft$file_kind
*copyc RMD$VOLUME_DECLARATIONS
*copyc STD$SET_NAME
*DECK DECK=DMT$RESREL_TAPE_REQUEST EXPAND=FALSE
*DECK DECK=DMT$SC_FLAW_COMMAND EXPAND=FALSE
{
{ dmt$sc_flaw_command
{

  TYPE
    dmt$sc_flaw_command = record
      phys_adrs: dmt$physical_flaw_address,
      rvsn: rmt$recorded_vsn,
      trk_specified: boolean,
      sec_specified: boolean,
      flaw_processed: boolean,
    recend;
?? PUSH (LISTEXT := ON) ??
*copyc dmt$physical_flaw_address
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=DMT$SEGMENT_FILE_INFORMATION EXPAND=FALSE
{
{ dmt$segment_file_information
{

  TYPE
    dmt$segment_file_info = record
      asid: ost$asid,
      preset_value: amt$preset_value,
      clear_space: boolean,
      chapter_limit: amt$file_limit,
      segment_queue_status: dmt$queue_status,
      usage_count: dmt$usage_count,
      global_file_name: dmt$global_file_name,
      allocation_size: dmt$allocation_size,
      transfer_size: dmt$transfer_size,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_limit
*copyc amt$preset_value
*copyc dmt$allocation_size
*copyc dmt$global_file_name
*copyc dmt$queue_status
*copyc dmt$transfer_size
*copyc dmt$usage_count
*copyc osd$virtual_address
*copyc ost$hardware_subranges
?? POP ??

*DECK DECK=DMT$SERVER_ATTACH_OUTPUT EXPAND=FALSE
*DECK DECK=DMT$SERVER_DESCRIPTOR EXPAND=FALSE

{ DECK: DMT$SERVER_DESCRIPTOR
{ This deck is obsolete.  All references to it should be replaced with
{ references to DFT$SERVER_DESCRIPTOR.  To ease conversion, however, both names
{ will be supported for several releases.

  TYPE
    dmt$p_server_descriptor = dft$server_descriptor_p,

    dmt$server_descriptor = dft$server_descriptor,

    dmt$server_descriptor_header = dft$server_descriptor_header;

?? PUSH (LISTEXT := ON) ??
*copyc dft$server_descriptor
?? POP ??
*DECK DECK=DMT$SERVER_FILE_OUTPUT EXPAND=FALSE
{
{ DMT$SERVER_FILE_OUTPUT is an obsolete deck.  All references to it should be
{ replaced with references to DFT$SERVER_FILE_OUTPUT.  To ease conversion,
{ however, both names will be supported for several releases.

{ DECK: DMT$SERVER_FILE_OUTPUT

  TYPE
    dmt$server_file_output = dft$server_file_output;

?? PUSH (LISTEXT := ON) ??
*copyc dft$server_file_output
?? POP ??





*DECK DECK=DMT$SPARSE_ALLOCATION EXPAND=FALSE
  CONST

    {Increase this constant to decrease size of level 2 tables

    dmc$level_1_table_size = 4096,

    {Assume 2gb is maximum file size

    dmc$bytes_per_level_2 = 2147483648 DIV dmc$level_1_table_size;

  TYPE
    dmt$level_1_index = 0 .. dmc$level_1_table_size - 1,

    {Specified using minimum allocation size -
    {1 table entry per AU

    dmt$level_2_index = 0 .. dmc$bytes_per_level_2 DIV 16384,

    {A level 1 table consists of an array of offsets.  An offset
    {refers to either mainframe wired or job fixed, depending on
    {file residence.  A level 1 table is (kind of) adaptable, in that
    {the table will expand, not by using CYBIL adaptable pointers but
    {by using a pointer to fixed type (maximum size) and a current size
    {value both kept in the fde.

    dmt$level_1_table = array [dmt$level_1_index] of amt$file_byte_address,
    dmt$level_1_adapt = array [ * ] of amt$file_byte_address,

    {A level 2 table is also (kind of) adaptable, in that it appears
    {to be an array of a fixed size, but is in fact allocated
    {adaptably, based on the allocation size.  Each level 2 table
    {represents the same number of bytes, but it takes fewer table
    {entries for larger allocation sizes.
    {No bound information is required as each level 2 table is
    {initially allocated to it's maximum required size based on allocation size.

    dmt$level_2_table = array [dmt$level_2_index] of dmt$file_allocation_unit,
    dmt$level_2_adapt = array [ * ] of dmt$file_allocation_unit;
?? PUSH (LISTEXT := ON) ??
*copyc dmt$file_allocation_descriptor
*copyc amt$file_byte_address
?? POP ??
*DECK DECK=DMT$STORED_FMD EXPAND=FALSE
{
{                     common deck dmdsfm
{

  TYPE
    dmt$stored_fmd = SEQ ( * );
*DECK DECK=DMT$STORED_FMD_SIZE EXPAND=FALSE
{
{                 common deck dmdsfms
{

  TYPE
    dmt$stored_fmd_size = dmc$minimum_stored_fmd_size ..
      dmc$maximum_stored_fmd_size;

  CONST
    dmc$minimum_stored_fmd_size = 0,
    dmc$maximum_stored_fmd_size = 0ffff(16);
*DECK DECK=DMT$STORED_MS_FMD_HEADER EXPAND=FALSE
{
{ dmt$stored_ms_fmd_header
{

  CONST
    dmc$current_fmd_version = 0;

  TYPE
    dmt$stored_ms_fmd_header = bound record
      case fmd_version_number: dmt$stored_ms_version_number of
      = 0 =
        version_0_0: record
          clear_space: ost$clear_file_space,
          file_hash: dmt$file_hash,
          file_limit: amt$file_limit,
          file_kind: gft$file_kind,
          locked_file: dmt$locked_file,
          number_fmds: dmt$fmd_index,
          overflow_allowed: boolean,
          preset_value: amt$preset_value,
          requested_allocation_size: dmt$allocation_size,
          requested_class: dmt$class_member,
          requested_class_ordinal: dmt$class_ordinal,
          requested_transfer_size: dmt$transfer_size,
          requested_volume: dmt$requested_volume,
        recend,
      = 1 =
        version_1_0: record
          number_fmds: dmt$fmd_index,
        recend,
      casend,
    recend;

  TYPE
    dmt$stored_ms_fmd_subfile = bound record
      case fmd_version_number: dmt$stored_ms_version_number of
      = 0 =
        version_0_0: record
          stored_byte_address: dmt$stored_byte_address,
          device_file_list_index: dmt$device_file_list_index,
          internal_vsn: dmt$internal_vsn,
          recorded_vsn: rmt$recorded_vsn,
        recend,
      = 1 =
        version_1_0: record
          recorded_vsn: rmt$recorded_vsn,
        recend,
      casend,
    recend;

  TYPE
    dmt$stored_ms_version_number = 0 .. 255;

  { dmt$stored_byte_address is one byte shorter than amt$file_byte_address
  { to allow expansion of the dfl index while providing file compatibility.
  { Since stored FMDs always start on allocation unit boundaries (at least
  { 16384), the low byte is always zero and need not be stored.
  {
  { The constant dmc$byte_address_converter is used to convert back and
  { forth between the two versions of a file byte address.

  TYPE
    dmt$stored_byte_address = 0 .. 0ffffffffff(16);

  CONST
    dmc$byte_address_converter = 100(16);

*copyc amt$preset_value
*copyc amt$file_byte_address
*copyc amd$file_attributes
*copyc dmt$class
*copyc dmt$device_file_list_index
*copyc dmt$file_hash
*copyc dmt$global_file_name
*copyc dmt$internal_vsn
*copyc dmt$locked_file
*copyc dmt$overflow_allowed
*copyc dmt$requested_volume_attributes
*copyc dmt$fmd_index
*copyc dmt$transfer_size
*copyc gft$file_kind
*copyc ost$clear_file_space
*copyc rmd$volume_declarations

*DECK DECK=DMT$STORED_REM_MEDIA_GROUP EXPAND=FALSE

  TYPE
    dmt$stored_rem_media_group = ost$name;

*copyc ost$name
*DECK DECK=DMT$STORED_TAPE_CLASS EXPAND=FALSE
*DECK DECK=DMT$STORED_TAPE_DENSITY EXPAND=FALSE

  TYPE
    dmt$stored_tape_density = (dmc$stored_density_800, dmc$stored_density_1600,
          dmc$stored_density_6250, dmc$stored_density_38000);
*DECK DECK=DMT$STORED_TAPE_FMD EXPAND=FALSE

  TYPE
    dmt$stored_tape_fmd = SEQ ( * );

{ The stored tape fmd sequence contains the following information for
{ permanent tape files in the order listed below.
{
{   header - contains the tape attributes which are specified by the
{         REQUEST_MAGNETIC_TAPE command or the RMP$REQUEST_TAPE program
{         interface (dmt$stored_tape_fmd_header).
{
{   tape_volume_list - contains a list of 1 or more tape volumes assigned to
{         the permanent tape file (dmt$stored_tape_volume_list).  If no tape
{         volumes are assigned to the file cycle, the list will not be
{         included in the sequence and the volume_count item in the header
{         will be 0.
{
{   tape_manager_info - a sequence containing information about the
{         file cycle which is maintained by the Tape Management System
{         (dmt$stored_tape_manager_info).
{

*copyc dmt$stored_tape_fmd_header
*copyc dmt$stored_tape_manager_info
*copyc dmt$stored_tape_volume_list
*DECK DECK=DMT$STORED_TAPE_FMD_HEADER EXPAND=FALSE

  TYPE
    dmt$stored_tape_fmd_header = record
      case version: dmt$stored_tape_fmd_version of
      = dmc$stored_tape_fmd_version_1 =
        density: dmt$stored_tape_density,
        removable_media_group: dmt$stored_rem_media_group,
        volume_count: dmt$stored_tape_volume_count,
        volume_overflow_allowed: boolean,
        reserved_tape_fmd_header_space: array [1 .. 48] of boolean,
      casend,
    recend;

*copyc dmt$stored_rem_media_group
*copyc dmt$stored_tape_density
*copyc dmt$stored_tape_fmd_version
*copyc dmt$stored_tape_volume_count
*DECK DECK=DMT$STORED_TAPE_FMD_VERSION EXPAND=FALSE

  TYPE
    dmt$stored_tape_fmd_version = (dmc$stored_tape_fmd_version_1,
          dmc$stored_tape_fmd_version_2, dmc$stored_tape_fmd_version_3,
          dmc$stored_tape_fmd_version_4, dmc$stored_tape_fmd_version_5,
          dmc$stored_tape_fmd_version_6, dmc$stored_tape_fmd_version_7,
          dmc$stored_tape_fmd_version_8);

*DECK DECK=DMT$STORED_TAPE_GROUP EXPAND=FALSE
*DECK DECK=DMT$STORED_TAPE_MANAGER_INFO EXPAND=FALSE

  TYPE
    dmt$stored_tape_manager_info = SEQ ( * );

*DECK DECK=DMT$STORED_TAPE_VOLUME_COUNT EXPAND=FALSE

  TYPE
    dmt$stored_tape_volume_count = 0 .. amc$max_vol_number;

*copyc amc$max_vol_number
*DECK DECK=DMT$STORED_TAPE_VOLUME_LIST EXPAND=FALSE

  TYPE
    dmt$stored_tape_volume_list = array [1 .. * ] of rmt$volume_descriptor;

*copyc rmt$volume_descriptor
*DECK DECK=DMT$SUBFILE_INDEX EXPAND=FALSE
{
{ dmt$subfile_index
{

  TYPE
    dmt$subfile_index = 0 .. 255;

*DECK DECK=DMT$SYSTEM_FILE_ID EXPAND=FALSE
{
{  DMT$SYSTEM_FILE_ID is an obsolete deck. All references to  it should be replaced
{  with references to GFT$SYSTEM_FILE_IDENTIFIER. To ease conversion, however, both names
{  will be supported for several releases.

  TYPE
    dmt$system_file_id = gft$system_file_identifier;

*copyc gft$system_file_identifier
*DECK DECK=DMT$SYSTEM_TAPE_TABLE EXPAND=FALSE

{DECK: DMT$SYSTEM_TAPE_TABLE

  TYPE
    dmt$system_tape_table = array [rmt$tape_unit_types] of
          dmt$system_tape_table_entry;

  TYPE
    dmt$system_tape_table_entry = record
      defined_tape: iot$logical_unit,
      number_on: iot$logical_unit,
      lower_density_reserved: iot$logical_unit,
      higher_density_reserved: iot$logical_unit,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc rmt$tape_unit_types
*copyc iot$logical_unit
?? POP ??
*DECK DECK=DMT$TAPE_ASSIGNMENT_OPERATION EXPAND=FALSE
 TYPE
    dmt$tape_assignment_operation = (dmc$assign_initial_tape_volume, dmc$advance_to_next_tape_volume,
        dmc$extend_tape_volume_list, dmc$reset_tape_volume_list);
*DECK DECK=DMT$TAPE_INITIALIZATION_RECORD EXPAND=FALSE

{ DECK: DMT$TAPE_INITIALIZATION_RECORD

  TYPE
    dmt$tape_initialization_record = record
      logical_unit_number: iot$logical_unit,
      density: rmt$density,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
*copyc RMT$DENSITY
?? POP ??
*DECK DECK=DMT$TAPE_JOB_LUN_TABLE EXPAND=FALSE

{ DECK: DMT$TAPE_JOB_LUN_TABLE

  CONST
    dmc$extra_lun_table_entries = 10;

  TYPE
    dmt$tape_job_lun_table = RECORD
      count: integer,
      tape_file: ^ARRAY [1 .. *] OF dmt$tape_lun_table_entry,
    RECEND;

  TYPE
    dmt$tape_lun_table_entry = RECORD
      slot_in_use: boolean,
      current_vsn_index: amt$volume_number,
      density: rmt$density,
      job_recovery_active: boolean,
      label_type: amt$label_type,
      lun: iot$logical_unit,
      number_of_vsns: amt$volume_number,
      requested_volume_attributes: iot$requested_volume_attributes,
      robotic_mount_info: rmt$robotic_mount_information,
      source_pool: ost$name,
      source_pool_location: ost$name,
      volume_list: ^rmt$volume_list,
      volume_overflow_allowed: boolean,
      write_ring: rmt$write_ring,
    RECEND;

*copyc amt$label_type
*copyc amt$volume_number
*copyc iot$logical_unit
*copyc iot$no_of_tape_units
*copyc iot$requested_volume_attributes
*copyc ost$name
*copyc rmt$density
*copyc rmt$robotic_mount_information
*copyc rmt$tape_class
*copyc rmt$volume_list
*copyc rmt$write_ring
*DECK DECK=DMT$TAPE_RESERVATIONS EXPAND=FALSE

{ DECK: DMT$TAPE_RESERVATIONS

  TYPE
    dmt$tape_reservations = array [1 .. * ] of dmt$tape_reservation_entry,

    dmt$tape_reservation_entry = record
      available: boolean,
      jsn: jmt$system_supplied_name,
      unit_type: rmt$tape_reservation,
    recend;


?? PUSH (LIST := OFF) ??
*copyc jmt$system_supplied_name
*copyc rmt$tape_reservation
?? POP ??
*DECK DECK=DMT$TAPE_UNIT_STATUS_INFO EXPAND=FALSE

  TYPE
    dmt$tape_unit_status_info = record
      element_name: ost$name,
      unit_type: iot$unit_type,
      case element_state: cmt$element_state of
      = cmc$on =
        detected_tape_characteristics: iot$tape_characteristics,
        recorded_vsn: rmt$recorded_vsn,
        case assigned: boolean of
        = FALSE =
          read_error: boolean,
          unit_ready: boolean,
        = TRUE =
          external_vsn: rmt$external_vsn,
          path_handle_name: fst$path_handle_name,
          system_supplied_name: jmt$system_supplied_name,
        casend,
      = cmc$off, cmc$down =
        ,
      casend,
    recend;

*copyc cmt$element_state
*copyc fst$path_handle_name
*copyc iot$tape_characteristics
*copyc iot$unit_type
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc rmt$external_vsn
*copyc rmt$recorded_vsn

*DECK DECK=DMT$TIME EXPAND=FALSE
{
{               common deck dmdtime
{
      TYPE
         dmt$time = RECORD
              hour:0..23,
              minute:0..59,
              second:0..59,
                    RECEND;
*DECK DECK=DMT$TRANSFER_SIZE EXPAND=FALSE
{
{             common deck dmdtran
{

  TYPE
    dmt$transfer_size = 0 .. dmc$max_transfer_size;

  CONST
    dmc$default_transfer_size = 8192,               {is this old value still valid?
    dmc$default_req_transfer_size = 16384,
    dmc$max_transfer_size = 0ffffff(16),
    dmc$unspecified_transfer_size = 0;
*DECK DECK=DMT$USAGE_COUNT EXPAND=FALSE
{
{ dmt$usage_count
{

  TYPE
    dmt$usage_count = 0 .. 0ffff(16);
*DECK DECK=DMT$VOLUME_ATTRIBUTES EXPAND=FALSE
{
{  dmt$volume_attributes
{

   TYPE

     dmt$volume_attributes = array [1 .. *] of
       dmt$volume_attribute,

     dmt$volume_attribute = record
       case keyword: dmt$volume_attribute_keywords of
       = dmc$vol_default_allocation_size =
         default_allocation_size: dmt$allocation_size,
       = dmc$vol_default_transfer_size =
         default_transfer_size: dmt$transfer_size,
       casend,
     recend,

     dmt$volume_attribute_keywords = (dmc$vol_default_allocation_size, dmc$vol_default_transfer_size);

*copyc dmt$allocation_size
*copyc dmt$transfer_size
*DECK DECK=DMT$VOLUME_ATTRIBUTE_INFO EXPAND=FALSE
{
{  dmt$volume_attribute_info
{

   TYPE

     dmt$volume_attribute_info = record
       default_allocation_size: dmt$allocation_size,
       default_transfer_size: dmt$transfer_size,
     recend;

*copyc dmt$allocation_size
*copyc dmt$transfer_size
*DECK DECK=DMT$VOLUME_LABEL_ATTRIBUTES EXPAND=FALSE
{
{ dmt$volume_label_attributes
{

  TYPE
    dmt$volume_label_attributes = array [ * ] of dmt$volume_label_attribute,

    dmt$volume_label_attribute = record
      case keyword: dmt$volume_label_keywords of

      = dmc$label_access_code =
        access_code: ost$name,

      = dmc$label_expiration_days =
        expiration_days: dmt$label_expiration_days,

      = dmc$label_internal_vsn =
        internal_vsn: dmt$internal_vsn,

      = dmc$label_owner_id =
        owner_id: ost$user_identification,

      = dmc$label_recorded_vsn =
        recorded_vsn: rmt$recorded_vsn,

      casend,
    recend,

    dmt$volume_label_keywords = (dmc$label_access_code,
      dmc$label_expiration_days, dmc$label_internal_vsn, dmc$label_owner_id,
      dmc$label_recorded_vsn),

    dmt$label_expiration_days = dmc$min_expiration_days ..
      dmc$max_expiration_days;

  CONST
    dmc$default_vol_access_code = osc$null_name,

    dmc$min_expiration_days = 1,

    dmc$max_expiration_days = 99999,

    dmc$default_vol_exp_days = 100,

    dmc$default_vol_exp_years = 0,

    dmc$default_vol_exp_months = 0;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$internal_vsn
*copyc ost$name
*copyc ost$user_identification
*copyc rmd$volume_declarations
?? POP ??
*DECK DECK=DMV$ACTIVE_VOLUME_TABLE EXPAND=FALSE

  VAR
    dmv$p_active_volume_table: [XREF, oss$mainframe_wired] ^dmt$active_volume_table;

?? PUSH (LISTEXT := ON) ??
*copyc DMT$ACTIVE_VOLUME_TABLE
*copyc OSS$MAINFRAME_WIRED
  ?? POP ??
*DECK DECK=DMV$ALLOCATION_LOG EXPAND=FALSE
  VAR
    dmv$allocation_log: [XREF, STATIC, oss$mainframe_wired] dmt$allocation_log_info;
?? PUSH (LISTEXT := ON) ??
*copyc DMT$ALLOCATION_LOG
*copyc OSS$MAINFRAME_WIRED
?? POP ??
*DECK DECK=DMV$AWAIT_IO_COMPLETION EXPAND=FALSE
  VAR
    dmv$await_io_completion: [XREF] boolean;
*DECK DECK=DMV$DEBUG_OPTIONS EXPAND=FALSE
    VAR
    dmv$debug_options:[XREF, oss$mainframe_wired] dmt$debug_actions;
??PUSH(list:=off)??
*copyc DMT$DEBUG_ACTIONS
*copyc OSS$MAINFRAME_WIRED
??POP??
*DECK DECK=DMV$DEFAULT_FAU_ENTRY EXPAND=FALSE
       VAR
         dmv$default_fau_entry: [XREF, READ, oss$mainframe_wired_literal]
              dmt$file_allocation_unit;
??PUSH(LISTEXT:=OFF)??
*copyc dmt$file_allocation_descriptor
*copyc oss$mainframe_wired_literal
??POP??
*DECK DECK=DMV$IDLE_SYSTEM EXPAND=FALSE
VAR
  dmv$idle_system: [XREF] boolean;
*DECK DECK=DMV$INITIALIZE_TAPE_VOLUME EXPAND=FALSE

  VAR
    dmv$initialize_tape_volume: [XREF] dmt$initialize_tape_volume;

?? PUSH (LIST := OFF) ??
*copyc dmt$initialize_tape_volume
?? POP ??
*DECK DECK=DMV$INITV_SAVED_INFO EXPAND=FALSE

  VAR
    dmv$initv_saved_info: [XREF] ^dmt$initv_saved_info;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$initv_saved_info
?? POP ??
*DECK DECK=DMV$INTERNAL_TASKS_INITIATED EXPAND=FALSE

  VAR
    dmv$split_al_initiated: [XREF, STATIC, oss$mainframe_wired] boolean,
    dmv$administer_log_initiated: [XREF, STATIC, oss$mainframe_wired] boolean,
    dmv$vol_space_manage_initiated: [XREF, STATIC, oss$mainframe_wired] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc OSS$MAINFRAME_WIRED
?? POP ??
*DECK DECK=DMV$INTERNAL_TASK_DELAY_VALUES EXPAND=FALSE

  VAR
    dmv$split_allocation_log_delay: [XREF, oss$mainframe_wired] 0 ..
      0ffffffffffff(16),
    dmv$process_device_log_delay: [XREF, oss$mainframe_wired] 0 ..
      0ffffffffffff(16),
    dmv$manage_volume_space_delay: [XREF, oss$mainframe_wired] 0 ..
      0ffffffffffff(16),
    dmv$volume_table_space_delay: [XREF, oss$mainframe_wired] 0 ..
      0ffffffffffff(16);

?? PUSH (LISTEXT := ON) ??
*copyc OSS$MAINFRAME_WIRED
?? POP ??
*DECK DECK=DMV$INTERNAL_TASK_EXEC_COUNTS EXPAND=FALSE

  VAR
    dmv$split_allocation_log_count: [XREF, oss$mainframe_wired] integer,
    dmv$process_device_log_count: [XREF, oss$mainframe_wired] integer,
    dmv$log_entries_max_thresehold: [XREF, oss$mainframe_wired] integer,
    dmv$manage_volume_space_count: [XREF, oss$mainframe_wired] integer;

?? PUSH (LISTEXT := ON) ??
*copyc OSS$MAINFRAME_WIRED
?? POP ??
*DECK DECK=DMV$JOB_FILE_TABLE_ROOT EXPAND=FALSE
*DECK DECK=DMV$JOB_TAPE_TABLE_DEFAULT EXPAND=FALSE
*DECK DECK=DMV$JOB_TAPE_TABLE_LOCK EXPAND=FALSE
*DECK DECK=DMV$MAINFRAME_RECOVERED EXPAND=FALSE

  VAR
    dmv$mainframe_recovered: [XREF] boolean;
*DECK DECK=DMV$MINIMUM_LOG_COUNT EXPAND=FALSE
VAR
  dmv$minimum_log_count: [XREF] integer;
*DECK DECK=DMV$NULL_SFID EXPAND=FALSE

  VAR
    dmv$null_sfid: [XREF, READ, oss$mainframe_wired_literal] dmt$system_file_id;

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc OSS$MAINFRAME_WIRED_LITERAL
?? POP ??
*DECK DECK=DMV$NULL_VSN EXPAND=FALSE
      VAR
        dmv$null_vsn: [XREF, READ, oss$mainframe_wired_literal]
          rmt$recorded_vsn;
??PUSH(LISTEXT:=ON)??
*copyc RMD$VOLUME_DECLARATIONS
*copyc OSS$MAINFRAME_WIRED_LITERAL
??POP??
*DECK DECK=DMV$NUMBER_UNAVAILABLE_VOLUMES EXPAND=FALSE

{ This variable contains a count of the number of unavailable mass staorage
{ volumes.

  VAR
    dmv$number_unavailable_volumes: [XREF] dmt$active_volume_table_index;
*DECK DECK=DMV$OP_ACTION_MENU_LOCK EXPAND=FALSE
*DECK DECK=DMV$PERMANENT_FILE_OVERFLOW EXPAND=FALSE

  VAR
    dmv$permanent_file_overflow: [XREF] boolean;
*DECK DECK=DMV$P_JOB_FILE_TABLE_ROOT EXPAND=FALSE
*DECK DECK=DMV$P_SC_FLAW_COMMANDS EXPAND=FALSE

  VAR
    dmv$p_sc_flaw_commands: [XREF, oss$mainframe_wired]
      ^array [1 .. *] of dmt$sc_flaw_command;

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SC_FLAW_COMMAND
*copyc OSS$MAINFRAME_WIRED
?? POP ??
*DECK DECK=DMV$P_SYSTEM_TAPE_TABLE EXPAND=FALSE
  VAR
    dmv$p_system_tape_table: [XREF, oss$mainframe_pageable] ^dmt$system_tape_table;
*DECK DECK=DMV$P_TAPE_RESERVATIONS EXPAND=FALSE
  VAR
    dmv$p_tape_reservations: [XREF, oss$mainframe_pageable] ^dmt$tape_reservations;

?? PUSH (LIST := OFF) ??
*copyc oss$mainframe_pageable
*copyc dmt$tape_reservations
?? POP ??
*DECK DECK=DMV$RECONCILE_LOCATOR EXPAND=FALSE

  VAR
    dmv$reconcile_locator: [XREF] dmt$reconcile_locator;
*DECK DECK=DMV$RECONCILIATION_LOCK EXPAND=FALSE
VAR
  dmv$reconciliation_lock: [XREF] ost$signature_lock;
?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??
*DECK DECK=DMV$RECYCLED_LOG EXPAND=FALSE

  VAR
    dmv$recycled_log: [XREF] integer,
    dmv$skipped_recycle_of_log: [XREF] integer;
*DECK DECK=DMV$RECYCLE_DEVICE_LOG EXPAND=FALSE

  VAR
    dmv$recycle_device_log: [XREF] boolean;
*DECK DECK=DMV$SIZE_OF_FDT_ALLOCATION EXPAND=FALSE
*DECK DECK=DMV$SYSTEM_CLASS EXPAND=FALSE

  VAR
    dmv$system_class_conversion : [XREF] array [dmt$class_member] of
      dmt$system_class,
    dmv$system_class: [XREF] dmt$class;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$class
?? POP ??
*DECK DECK=DMV$SYSTEM_DEVICE_INFORMATION EXPAND=FALSE

  VAR
    dmv$retain_system_device_flaws: [XREF] boolean,
    dmv$system_device_lun: [XREF] iot$logical_unit,
    dmv$system_device_product_id: [XREF] cmt$product_identification,
    dmv$system_device_recorded_vsn: [XREF] rmt$recorded_vsn;

?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
*copyc CMT$PRODUCT_IDENTIFICATION
*copyc RMD$VOLUME_DECLARATIONS
?? POP ??
*DECK DECK=DMV$SYSTEM_TAPE_TABLE_LOCK EXPAND=FALSE

  VAR
    dmv$system_tape_table_lock: [XREF, oss$mainframe_pageable] ost$signature_lock;

*DECK DECK=DMV$TAPE_JOB_LUN_TABLE_P EXPAND=FALSE
  VAR
    dmv$tape_job_lun_table_p: [XREF, oss$job_pageable] ^dmt$tape_job_lun_table;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$tape_job_lun_table
*copyc oss$job_pageable
?? POP ??
*DECK DECK=DMV$TEMPORARY_FILE_OVERFLOW EXPAND=FALSE

  VAR
    dmv$temporary_file_overflow: [XREF] boolean;
*DECK DECK=DMV$TEST_RECOVERY EXPAND=FALSE

  VAR
    dmv$test_recovery: [XREF] boolean;
*DECK DECK=DMV$TRIM_FILES EXPAND=FALSE

  VAR
    dmv$trim_files: [XREF] boolean;
*DECK DECK=DMV$VOLUME_SELECTOR EXPAND=FALSE
  VAR
    dmv$volume_selector: [XREF] integer;
*DECK DECK=DPC$CONDITION_LIMITS EXPAND=FALSE

*copyc ofc$base_error

  CONST
    dpc$min_ecc = ofc$base_error + 5000,
    dpc$max_ecc = dpc$min_ecc + 4999;

  CONST
    dpc$display_processor_id = 'DP';
*DECK DECK=DPC$CONSOLE_ROW_SIZE EXPAND=FALSE

  { This constant describes the length, in characters, of a row on the system console.

  CONST
    dpc$console_row_size = 80;
*DECK DECK=DPC$NUMBER_OF_CONSOLE_ROWS EXPAND=FALSE

  { This constant describes the number of rows on the system console.

  CONST
    dpc$number_of_console_rows = 30;
*DECK DECK=DPC$NUMBER_OF_WINDOW_LINES EXPAND=FALSE

  { This constant describes the number of lines allowed in a window.

  CONST
    dpc$number_of_window_lines = dpc$number_of_console_rows;

*copyc dpc$number_of_console_rows
*DECK DECK=DPC$TOP_LINE_MESSAGE_SIZE EXPAND=FALSE

  CONST
    dpc$top_line_message_size = (dpc$console_row_size - 9);

*copyc dpc$console_row_size
*DECK DECK=DPE$ERROR_CODES EXPAND=FALSE
?? NEWTITLE := 'dpe$error_codes ------ ''DP'' 5001 .. 9999', EJECT ??
*copyc dpc$condition_limits
?? FMT (FORMAT := OFF) ??

  CONST

    dpe$window_not_found             = dpc$min_ecc + 1,
        {E Illegal window identifier}

    dpe$line_truncated               = dpc$min_ecc + 2,
        {E Line exceeds 80 characters, line truncated.}

    dpe$invalid_console_monitor_req  = dpc$min_ecc + 3,
        {E Invalid monitor request issued to system console monitor.}

    dpe$no_change_from_interactive   = dpc$min_ecc + 4,
        {E Cannot change the window kind from interactive.}

    dpe$window_not_table             = dpc$min_ecc + 5;
        {E Can only get starting line for windows that are tables.}

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=DPH$DISPLAY_ERROR EXPAND=FALSE
{  PURPOSE:
{    This procedure will write a message to the console's Critical Window.  The message is the string of text
{    provided as input to which will be prefixed the current time in the form of 'HH:MM:SS ' and the current
{    date in the form of 'MM/DD/YY'.
{
{  NOTES:
{    These comments are to document the various VEOSxxxx messages codes which are now being used in NOS/VE.
{    The comments are in two groups.  First, to explain some guidelines for the use of the message codes and
{    secondly to list the various messages.
{
{  Guidelines for use of VEOSxxxx codes:
{     1. A code in the form of VEOSxxxx should be used when writing messages to the top line and to the
{        critical window that need to be documented.  In general, if a message is expected to cause
{        someone to take action it should be documented.
{     2. If the message is reporting an unexpected error, the first 13 characters of the message should
{        be in the form of 'ERR=VEOSxxxx-'.
{     3. Messages should be displayed on the top line of the console ONLY if the system is down and operator
{        action is required.  All informative messages (even if reporting errors) should be in the
{        critical window.
{     4. Top line messages should identify the problem for an analyst.  Top line messages should always
{        be accompanied by a more descriptive message in the critical window that helps the operator determine
{        what action should be taken.
{     5. If identical messages are to be issued from different procedures or modules, unique VEOS codes must
{        be used by each so the VEOS code can be used to determine the exact source of the message.
{     6. The 4 digit(hex) numbers which make up the code should assign numbers based on:
{        a. 0000-0999 -- Somewhat generic operator action messages in critical window
{        b. 1000-1999 -- Fatal Software errors that should not happen, instant death
{        c. 2000-2999 -- Software errors which are usually not fatal but in this case it is fatal
{        d. 3000-3999 -- Idle-Resume messages
{        e. 4000-4999 -- Environment and Power messages
{        f. 5000-59FF -- Hardware Errors
{        g. 6000-6999 -- PP errors
{        h. 7000-7999 -- unused
{        i. 8000-89FF -- CYBER 170 errors (informative but may foretell problems)
{        j. 9000-9299 -- System Stepped - An unstep_system command should work ok from one of these steps
{        k. 9300-9999 -- System Stepped due to Breakpoint or a software error, unstep may or may not work
{



{
{  Following is a list of all VEOS codes.  All of these messages go to either the Top Line or to the Critical
{  Window.  The codes are listed on the left side and are in numerical order.  Since most of these messages
{  have an associated message which appears at the other location (top or critical) both the Top Line and
{  the Critical Window message(s) are defined for each VEOS code in the following format:
{
{    CODE          MODULE
{                 Top line msg:     <text of messages>
{                 Critical window:  HH:MM:SS <text of message>
{
{
{  VEOS0002    MTM$SYSTEM_CONTROL
{                 Top line msg:     various message codes and text
{                 Critical window:  HH:MM:SS VEOS0002- System TERMINATED via OPERATOR COMMAND
{
{  VEOS0003    MTM$SYSTEM_CONTROL
{                 Top line msg:     various message codes and text
{                 Critical window:  HH:MM:SS VEOS0003- System ABORTED due to HARDWARE FAILURE
{
{  VEOS0004    MTM$SYSTEM_CONTROL
{                 Top line msg:     various message codes and text
{                 Critical window:  HH:MM:SS VEOS0004- System ABORTED due to SOFTWARE FAILURE
{
{  VEOS0005    MTM$SYSTEM_CONTROL
{                 Top line msg:     various message codes and text
{                 Critical window:  HH:MM:SS VEOS0005- System IDLED due to LONG POWER WARNING
{
{  VEOS0006    MTM$SYSTEM_CONTROL
{                 Top line msg:     various message codes and text
{                 Critical window:  HH:MM:SS VEOS0006- System IDLED due to ENVIRONMENT WARNING
{
{  VEOS0007    MTM$SYSTEM_CONTROL
{                 Top line msg:     various message codes and text
{                 Critical window:  HH:MM:SS VEOS0007- System IDLED via OPERATOR COMMAND
{
{  VEOS0008    MTM$SYSTEM_CONTROL
{                 Top line msg:     various message codes and text
{                 Critical window:  HH:MM:SS VEOS0008- System STEPPED via OPERATOR COMMAND
{
{  VEOS0009    MTM$SYSTEM_CONTROL
{                 Top line msg:     various message codes and text
{                 Critical window:  HH:MM:SS VEOS0009- System STEPPED due to SHORT POWER WARNING
{
{  VEOS0010    MTM$SYSTEM_CONTROL
{                 Top line msg:     various message codes and text
{                 Critical window:  HH:MM:SS VEOS0010- System STEPPED due to DISK ERROR
{
{  VEOS0011    MTM$SYSTEM_CONTROL
{                 Top line msg:     various message codes and text
{                 Critical window:  HH:MM:SS VEOS0011- System STEPPED due to SOFTWARE SELECTED BREAKPOINT


{  VEOS1000    MTM$SYSTEM_CONTROL
{                 Top line msg:     ERR=VEOS1000- < text varies >
{                 Critical window:  HH:MM:SS VEOS0004- System ABORTED due to SOFTWARE FAILURE
{
{  VEOS1010    MTM$SYSTEM_CONTROL
{                 Top line msg:     ERR=VEOS1010- MONITOR MCR/UCR: PVA=r sss oooooooo  UCR=xxxx MCR=xxxx
{                 Critical window:  HH:MM:SS VEOS0004- System ABORTED due to SOFTWARE FAILURE
{
{  VEOS1100    TMM$MTR_FLAG_SIGNAL_FUNCTIONS
{                 Top line msg:     ERR=VEOS1100- < text varies >
{                 Critical window:  HH:MM:SS VEOS0004- System ABORTED due to SOFTWARE FAILURE
{
{  VEOS160C    DSM$RECOVERY_SERVICES_MTR
{                 Top line msg:     ERR=VEOS160C- PP LOAD ERROR
{                 Critical window:  HH:MM:SS VEOS0004- System ABORTED due to SOFTWARE FAILURE


{  VEOS2010    TMM$MTR_FLAG_SIGNAL_FUNCTIONS
{                 Top line msg:     ERR=VEOS2010- < text varies >
{                 Critical window:  HH:MM:SS VEOS0004- System ABORTED due to SOFTWARE FAILURE
{
{  VEOS2020    TMM$MTR_FLAG_SIGNAL_FUNCTIONS
{                 Top line msg:     ERR=VEOS2020- < text varies >
{                 Critical window:  HH:MM:SS Broken Task, System Error Count exceeds limit; Halting System
{                 Critical window:  HH:MM:SS VEOS0004- System ABORTED due to SOFTWARE FAILURE


{  VEOS3500    OSM$IDLE_RESUME_SYSTEM
{                 Top line msg:     VEOS3500- Termination is complete
{                 Critical window:  HH:MM:SS VEOS0002- System terminated via OPERATOR COMMAND
{
{  VEOS3503    OSM$IDLE_RESUME_SYSTEM
{                 Top line msg:     ERR=VEOS3503- SYSTEM IDLED
{                 Critical window:  HH:MM:SS VEOS0007- System IDLED via OPERATOR COMMAND
{
{  VEOS3599    OSM$IDLE_RESUME_SYSTEM
{                 Top line msg:     ERR=VEOS3599- Invalid IDLE CODE=  xx
{                 Critical window:  HH:MM:SS VEOS0004- System ABORTED due to SOFTWARE FAILURE
{


{  VEOS5000    MTM$PROCESSOR_CONFIGURATION_MGR
{                 Top line msg:     ERR=VEOS5000- < text varies >; CPU could not be deconfigured safely
{                 Critical window:  HH:MM:SS VEOS0003- System ABORTED due to HARDWARE FAILURE
{
{  VEOS5001    MTM$PROCESSOR_CONFIGURATION_MGR
{                 Top line msg:     ERR=VEOS5001- < text varies >; CPU could not be deconfigured safely
{                 Critical window:  HH:MM:SS VEOS0006- System IDLED due to HARDWARE IDLE CONDITION
{
{  VEOS520E    MTM$PROCESSOR_CONFIGURATION_MGR
{                 Top line msg:     ERR=VEOS520E- FATAL CPU ERROR: Detected Uncorrected Error (DUE)
{                 Critical window:  HH:MM:SS VEOS0003- System ABORTED due to HARDWARE FAILURE
{
{  VEOS5211    MTM$PROCESS_DUE_ERRORS
{                 Top line msg:     ERR=VEOS5211- FATAL MONITOR DUE
{                 Critical window:  HH:MM:SS VEOS0003- System ABORTED due to HARDWARE FAILURE


{  VEOS6000    DSM$DEADSTART_SERVICES_MONITOR       (informative message to critical window only)
{                 Top line msg:
{                 Critical window:  HH:MM:SS ERR=VEOS6000- xxx TIMED OUT


{  VEOS8000    MTM$SYSTEM_CONTROL
{                 Top line msg:     VEOS8000- 180 terminated by 170 via SCB request
{                 Critical window:  HH:MM:SS VEOS0002- System terminated via OPERATOR COMMAND
{
{  VEOS8004    MTM$SYSTEM_CONTROL      (informative message to critical window only)
{                 Top line msg:
{                 Critical window:  ERR=VEOS8004- C170 STATE OS IOU ERROR
{
{  VEOS8009    MTM$SYSTEM_CONTROL      (informative message to critical window only)
{                 Top line msg:
{                 Critical window:   ERR=VEOS8009- C170 STATE OS IOU ERROR
{
{  VEOS820F    MTM$SYSTEM_CONTROL      (informative message to critical window only)
{                 Top line msg:
{                 Critical window:    ERR=VEOS820F- FATAL C170 STATE UNCORRECTED CPU ERROR
{
{  VEOS8210    MTM$SYSTEM_CONTROL      (informative message to critical window only)
{                 Top line msg:
{                 Critical window:    ERR=VEOS8210- FATAL C170 STATE EXIT MODE HALT


{  VEOS9100    MTM$SYSTEM_CONTROL
{                 Top line msg:     VEOS9100- System STEPPED
{                 Critical window:  HH:MM:SS VEOS0008- System STEPPED via OPERATOR COMMAND
{
{  VEOS9300    DMM$VOLUME_UP_DOWN
{                 Top line msg:     ERR=VEOS9300- A critical disk has gone down: vsn
{                 Critical window:  HH:MM:SS VEOS0010- System stepped due to DISK ERROR
{
{  VEOS9301    MMM$PAGE_FAULT_PROCESSOR
{                 Top line msg:     ERR=VEOS9301- A critical system task has encountered an unavailable volume
{                 Critical window:  HH:MM:SS VEOS0010- System stepped due to DISK ERROR
{
{  VEOS9302    MTM$PROCESS_DUE_ERRORS
{                 Top line msg:     ERR=VEOS9302- DUE: Halt_On_Processor_Malf set
{                 Critical window:  HH:MM:SS VEOS0010- System stepped at SOFTWARE SELECTED BREAKPOINT
{
{  VEOS9910    TMM$MTR_FLAG_SIGNAL_FUNCTIONS
{                 Top line msg:     ERR=VEOS9910- < text varies >
{                 Critical window:  HH:MM:SS Task hung -  initiating software breakpoint
{                 Critical window:  HH:MM:SS VEOS0010- System stepped at SOFTWARE SELECTED BREAKPOINT
{
{  VEOS9920    TMM$MTR_FLAG_SIGNAL_FUNCTIONS
{                 Top line msg:     ERR=VEOS9920- < text varies >
{                 Critical window:  HH:MM:SS Software Err below Halt Ring, initiating SW Breakpoint
{                 Critical window:  HH:MM:SS VEOS0010- System stepped at SOFTWARE SELECTED BREAKPOINT
{
{  VEOS9999    MTM$SYSTEM_CONTROL
{                 Top line msg:     ERR=VEOS9999- < text varies >
{                 Critical window:  HH:MM:SS VEOS0010- System stepped at SOFTWARE SELECTED BREAKPOINT
{
*DECK DECK=DPM$PROCESS_MONITOR_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Process Monitor Commands' ??
MODULE dpm$process_monitor_command;

{ PURPOSE:
{   This module contains the procedures for the commands that are entered at the critical window.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dpc$console_row_size
*copyc dpt$console_parameter_block
*copyc dst$signal_contents
*copyc mtc$job_fixed_segment
*copyc osc$purge_map_and_cache
*copyc osd$virtual_address
*copyc ost$physical_channel_number
*copyc syc$monitor_segment_numbers
*copyc syt$debug_output_disposition
*copyc syt$dflt_debug_output_disposal
?? POP ??
*copyc dpp$display_error
*copyc dsp$mtr_get_ssr_data_seq_ptr
*copyc i#mtr_disable_traps
*copyc i#mtr_enable_traps
*copyc i#sync
*copyc i#test_set_bit
*copyc iop$down_disk_channel
*copyc iop$down_disk_controller
*copyc iop$down_disk_unit
*copyc jmp$find_jsn
*copyc jmp$get_ijle_p
*copyc jmp$resurrect_dead_jobs
*copyc mmp$volume_available
*copyc tmp$monitor_flag_job_tasks
*copyc tmp$monitor_ready_system_task
*copyc tmp$send_signal
*copyc tmp$set_monitor_flag
?? EJECT ??
*copyc avv$security_options
*copyc cmv$logical_pp_table_p
*copyc dmv$active_volume_table
*copyc dpv$critical_display_id
*copyc dpv$secure_input_line
*copyc dsv$mainframe_type
*copyc jmv$ajl_p
*copyc jmv$ijl_p
*copyc jmv$service_classes
*copyc jmv$system_ajl_ordinal
*copyc jmv$system_ijl_ordinal
*copyc mtv$monitor_segment_table
*copyc mtv$nst_p
*copyc mtv$scb
*copyc tmv$system_job_monitor_gtid
*copyc tmv$tables_initialized
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  TYPE
    t$base = (c$base_10, c$base_16),
    t$command = string (dpc$console_row_size),
    t$command_length = 0 .. dpc$console_row_size;
?? EJECT ??
  VAR
    syv$debug_output_disposition: [XDCL, #GATE] syt$debug_output_disposition := syc$dod_null,
    syv$dflt_debug_output_disposal: [XDCL, #GATE] syt$dflt_debug_output_disposal := [1, syc$dod_null],

    v$expecting_password: boolean := FALSE,
    v$lock_main_window: boolean := FALSE;
?? OLDTITLE ??
?? NEWTITLE := 'convert_channel_number', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to generate a complete channel descriptor given
{   the channel number and the pp number.

  PROCEDURE convert_channel_number
    (    pp: iot$pp_number;
         channel_number: ost$physical_channel_number;
     VAR physical_channel: cmt$physical_channel);

    physical_channel.number := channel_number;

    IF cmv$logical_pp_table_p^ [pp].pp_info.channel.channel_protocol = dsc$cpt_cio THEN
      physical_channel.concurrent := TRUE;
    ELSE
      physical_channel.concurrent := FALSE;
    IFEND;

    physical_channel.port := cmc$unspecified_port;

    IF physical_channel.concurrent AND
          ((cmv$logical_pp_table_p^ [pp].controller_info.controller_type = cmc$mscm3_ct) OR
          (cmv$logical_pp_table_p^ [pp].controller_info.controller_type = cmc$ms5831_x) OR
          (cmv$logical_pp_table_p^ [pp].controller_info.controller_type = cmc$mshydra_ct)) THEN
      IF cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.unit_descriptors
            [cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.first_logical_unit].
            physical_path.port = 1 THEN
        physical_channel.port := cmc$port_b;
      ELSE
        physical_channel.port := cmc$port_a;
      IFEND;
    IFEND;

  PROCEND convert_channel_number;
?? OLDTITLE ??
?? NEWTITLE := 'parse_number', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to parse the monitor command line for a number.

  PROCEDURE parse_number
    (    desired_base: t$base;
         data_line: t$command;
     VAR data_line_index {input, output} : t$command_length;
     VAR number: integer;
     VAR number_good: boolean);

    VAR
      base: 0 .. 16,
      character: char,
      character_index: t$command_length,
      delimiter: boolean;

    number_good := TRUE;
    number := 0;

    character_index := 0;
    delimiter := FALSE;
    IF desired_base = c$base_10 THEN
      base := 10;
    ELSE
      base := 16;
    IFEND;

    WHILE data_line_index <= STRLENGTH (data_line) DO
      character := data_line (data_line_index);
      CASE character OF
      = ' ' =
        IF character_index > 0 THEN
          RETURN;
        IFEND;

      = '0' .. '9' =
        character_index := character_index + 1;
        number := number * base + ORD (character) - ORD ('0');

      = 'A' .. 'F', 'a' .. 'f' =
        IF desired_base = c$base_10 THEN
          number_good := FALSE;
          RETURN;
        IFEND;
        IF character >= 'a' THEN
          character := CHR (ORD (character) - ORD ('a') + ORD ('A'));
        IFEND;
        character_index := character_index + 1;
        number := number * base + ORD (character) - ORD ('A') + 10;

      = 'G' .. 'Z', 'g' .. 'z', '#', '$', '_', '@' =
        number_good := FALSE;
        RETURN;

      ELSE
        IF delimiter OR (character_index > 0) THEN
          RETURN;
        IFEND;
        delimiter := TRUE;
      CASEND;

      IF data_line_index = dpc$console_row_size THEN
        RETURN;
      ELSE
        data_line_index := data_line_index + 1;
      IFEND;
    WHILEND;

  PROCEND parse_number;
?? OLDTITLE ??
?? NEWTITLE := 'parse_word', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to parse the monitor command line for a word parameter.

  PROCEDURE parse_word
    (    data_line: t$command;
     VAR data_line_index {input, output} : t$command_length;
     VAR word: t$command;
     VAR word_length: t$command_length;
     VAR word_good: boolean);

    VAR
      character: char,
      delimiter: boolean;

    word_good := TRUE;
    word := ' ';
    word_length := 0;

    delimiter := FALSE;

    WHILE data_line_index <= STRLENGTH (data_line) DO
      character := data_line (data_line_index);
      CASE character OF
      = ' ' =
        IF word_length > 0 THEN
          RETURN;
        IFEND;

      = '0' .. '9' =
        IF word_length = 0 THEN
          word_good := FALSE;
          RETURN;
        IFEND;
        word_length := word_length + 1;
        word (word_length) := character;

      = 'A' .. 'Z', 'a' .. 'z' =
        IF character >= 'a' THEN
          character := CHR (ORD (character) - ORD ('a') + ORD ('A'));
        IFEND;
        word_length := word_length + 1;
        word (word_length) := character;

      = '#', '$', '_', '@' =
        word_length := word_length + 1;
        word (word_length) := character;

      ELSE
        IF delimiter OR (word_length > 0) THEN
          RETURN;
        IFEND;
        delimiter := TRUE;
      CASEND;

      IF data_line_index = dpc$console_row_size THEN
        RETURN;
      ELSE
        data_line_index := data_line_index + 1;
      IFEND;
    WHILEND;

  PROCEND parse_word;
?? OLDTITLE ??
?? NEWTITLE := 'process_change_mdd_op_mode', EJECT ??

{ PURPOSE:
{   This procedure processes the 'CHANGE_MDD_OPERATING_MODE' command.  The format of
{   the command is as follows:
{     CHANGE_MDD_OPERATING_MODE ON/OFF PORT_NUMBER
{       on/off - specifies whether MDD is to be activated or deactivated.
{       port_number - specifies port number when activating MDD.  Default value is zero.

  PROCEDURE process_change_mdd_op_mode
    (    data_line: t$command;
     VAR data_line_index {input, output} : t$command_length);

    VAR
      activate_mdd: boolean,
      index: 1 .. 10,
      number: integer,
      parse_good: boolean,
      previously_set: boolean,
      sci_console_block_p: ^dpt$console_parameter_block,
      scipt_seq_p: ^SEQ ( * ),
      word: t$command,
      word_length: t$command_length;

    { Ensure that the command is valid on this mainframe.

    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      dpp$display_error ('*ERROR* MDD initiation not allowed on this mainframe.');
      RETURN;
    IFEND;

    { Get the ON or OFF status of the MDD operating mode.

    parse_word (data_line, data_line_index, word, word_length, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* First parameter is invalid, must be ON or OFF.');
      RETURN;
    IFEND;

    IF (word <> 'ON') AND (word <> 'OFF') THEN
      dpp$display_error ('*ERROR* Invalid MDD operating mode, must be ON or OFF.');
      RETURN;
    IFEND;

    activate_mdd := (word = 'ON');

    { Get the port number if specified.

    parse_number (c$base_10, data_line, data_line_index, number, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* Second parameter is invalid, must be a one or a zero.');
      RETURN;
    IFEND;

    IF number > 1 THEN
      dpp$display_error ('*ERROR* Invalid port number.');
      RETURN;
    IFEND;

    { Set the pointer to the SCI parameter table which is pointed to by word D7RS+2 in the EICB or it is the
    { SSR.  A bit in D7RS tells NOS/VE where the parameter table is located.

    IF mtv$nst_p^.d7rs2.scipt_in_the_ssr THEN
      dsp$mtr_get_ssr_data_seq_ptr (dsc$ssr_sci_parameter_table, scipt_seq_p);
      sci_console_block_p := #ADDRESS (1, #SEGMENT (scipt_seq_p), #OFFSET (scipt_seq_p));
    ELSE
      sci_console_block_p := #ADDRESS (1, syc$msn_cyber_170_cache_bypass, mtv$nst_p^.d7rs2.sci_table * 8);
    IFEND;

    { Interlock the SCI parameter table and update the new MDD status if the interlock was obtained.
    { The interlock bit must be cleared last so that SCI does not respond before NVE is finished.

    FOR index := 1 TO 10 DO
      i#test_set_bit (^sci_console_block_p^, dpc$sci_table_interlock_bit, previously_set);
      IF NOT previously_set THEN
        IF activate_mdd THEN
          sci_console_block_p^.mdd_console.console_active := TRUE;
          sci_console_block_p^.mdd_console.port_number := number;
          sci_console_block_p^.mdd_console.initiator := dpc$mdd_initiated_by_nosve;
        ELSE
          sci_console_block_p^.mdd_console.console_active := FALSE;
          sci_console_block_p^.mdd_console.port_number := 0;
          sci_console_block_p^.mdd_console.initiator := 0;
        IFEND;
        sci_console_block_p^.mdd_definition_changed := TRUE;
        sci_console_block_p^.interlocked := FALSE;
        RETURN;
      IFEND;
    FOREND;
    dpp$display_error ('*ERROR* SCI parameter table interlock unavailable.');

  PROCEND process_change_mdd_op_mode;

?? TITLE := ' process_disable_allocation', EJECT ??
{ PURPOSE:
{   This procedure processes the 'DISABLE_ALLOCATION' command.  The format of the command is as follows:
{     DISABLE_ALLOCATION PARAMETER1
{       PARAMETER1 is the AVT index.
{
{ NOTE:
{   This command is intended for testing purposes only.
{

  PROCEDURE process_disable_allocation
    (    data_line: t$command;
     VAR data_line_index {input, output} : t$command_length);

    VAR
      avti: integer,
      number: integer,
      parse_good: boolean;

    parse_number (c$base_10, data_line, data_line_index, number, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* First parameter is invalid.');
      RETURN;
    IFEND;

    IF (number > 0) AND (number <= UPPERBOUND (dmv$p_active_volume_table^)) THEN
      avti := number;
    ELSE
      dpp$display_error ('*ERROR* AVT index out of range.');
      RETURN;
    IFEND;


    IF dmv$p_active_volume_table^ [avti].entry_available THEN
      dpp$display_error ('*ERROR* Specified volume not active.');
    ELSE
      dmv$p_active_volume_table^ [avti].mass_storage.previous_allocation_allowed :=
            dmv$p_active_volume_table^ [avti].mass_storage.allocation_allowed;
      dmv$p_active_volume_table^ [avti].mass_storage.allocation_allowed := FALSE;
    IFEND;

  PROCEND process_disable_allocation;

?? OLDTITLE ??
?? NEWTITLE := 'process_dismow_enamow', EJECT ??

{ PURPOSE:
{   This procedure processes the 'DISABLE_MAIN_OPERATOR_WINDOW' command and the 'ENABLE_MAIN_OPERATOR_WINDOW'
{   command.  The format of the commands are as follows:
{     DISABLE_MAIN_OPERATOR_WINDOW
{       and
{     ENABLE_MAIN_OPERATOR_WINDOW
{   This procedure starts the command and the process_password procedure completes the command.  The command
{   is broken into two parts so that the password can be entered without being displayed on the window.

  PROCEDURE process_dismow_enamow
    (    lock_window: boolean);

    v$expecting_password := TRUE;
    v$lock_main_window := lock_window;
    dpp$display_error ('Enter the Operation Password:');
    dpv$secure_input_line.window_id := dpv$critical_display_id;
    dpv$secure_input_line.secure := TRUE;

  PROCEND process_dismow_enamow;

?? TITLE := ' process_down_channel', EJECT ??
{ PURPOSE:
{   This procedure processes the 'DOWN_CHANNEL' command.  The format of the command is as follows:
{     DOWN_CHANNEL PARAMETER1 PARAMETER2
{       PARAMETER1 is the logical PP number.
{       PARAMETER2 is the channel number.
{       PARAMETER3 is the port letter.
{
{ NOTE:
{   This command is intended for testing purposes only.
{

  PROCEDURE process_down_channel
    (    data_line: t$command;
     VAR data_line_index {input, output} : t$command_length);

    VAR
      channel: 0 .. 33(16),
      down_status: syt$monitor_status,
      number: integer,
      parse_good: boolean,
      physical_channel: cmt$physical_channel,
      port_str: t$command,
      port_str_length: t$command_length,
      pp: iot$pp_number;

    parse_number (c$base_10, data_line, data_line_index, number, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* First parameter is invalid.');
      RETURN;
    IFEND;

    IF (number > 0) AND (number <= UPPERVALUE (iot$pp_number)) THEN
      pp := number;
    ELSE
      dpp$display_error ('*ERROR* pp number out of range.');
      RETURN;
    IFEND;

    parse_number (c$base_10, data_line, data_line_index, number, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* Second parameter is invalid.');
      RETURN;
    IFEND;

    IF (number > 0) AND (number <= 33(8)) THEN
      channel := number;
    ELSE
      dpp$display_error ('*ERROR* Channel number out of range.');
      RETURN;
    IFEND;
    convert_channel_number (pp, channel, physical_channel);

    parse_word (data_line, data_line_index, port_str, port_str_length, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* Third parameter is invalid.');
      RETURN;
    IFEND;

    IF port_str_length = 1 THEN
      IF (port_str = 'a') OR (port_str = 'A') THEN
        physical_channel.port := cmc$port_a;
      ELSEIF (port_str = 'b') OR (port_str = 'B') THEN
        physical_channel.port := cmc$port_b;
      ELSE
        dpp$display_error ('*ERROR* Port letter invalid.');
        RETURN;
      IFEND;
    ELSEIF port_str_length > 1 THEN
      dpp$display_error ('*ERROR* Port letter larger than one character.');
      RETURN;
    IFEND;

    iop$down_disk_channel (pp, physical_channel, down_status);
    IF NOT down_status.normal THEN
      dpp$display_error ('*ERROR* Bad status from IOP$DOWN_DISK_CHANNEL.');
    IFEND;

  PROCEND process_down_channel;

?? TITLE := ' process_down_controller', EJECT ??
{ PURPOSE:
{   This procedure processes the 'DOWN_CONTROLLER' command.  The format of the command is as follows:
{     DOWN_CONTROLLER PARAMETER1 PARAMETER2 PARAMETER3
{       PARAMETER1 is the logical PP number.
{       PARAMETER2 is the channel number.
{       PARAMETER3 is the equipment number.
{
{ NOTE:
{   This command is intended for testing purposes only.
{

  PROCEDURE process_down_controller
    (    data_line: t$command;
     VAR data_line_index {input, output} : t$command_length);

    VAR
      channel: ost$physical_channel_number,
      equipment: cmt$physical_equipment_number,
      down_status: syt$monitor_status,
      logical_unit: iot$logical_unit,
      number: integer,
      parse_good: boolean,
      physical_channel: cmt$physical_channel,
      pp: iot$pp_number,
      unit: cmt$physical_unit_number;

    parse_number (c$base_10, data_line, data_line_index, number, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* First parameter is invalid.');
      RETURN;
    IFEND;

    IF (number > 0) AND (number <= UPPERVALUE (iot$pp_number)) THEN
      pp := number;
    ELSE
      dpp$display_error ('*ERROR* pp number out of range.');
      RETURN;
    IFEND;

    parse_number (c$base_10, data_line, data_line_index, number, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* Second parameter is invalid.');
      RETURN;
    IFEND;

    IF (number > 0) AND (number <= UPPERVALUE(ost$physical_channel_number)) THEN
      channel := number;
    ELSE
      dpp$display_error ('*ERROR* Channel number out of range.');
      RETURN;
    IFEND;
    convert_channel_number (pp, channel, physical_channel);

    parse_number (c$base_10, data_line, data_line_index, number, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* Third parameter is invalid.');
      RETURN;
    IFEND;

    IF (number >= 0) AND (number <= UPPERVALUE(cmt$physical_equipment_number)) THEN
      equipment := number;
    ELSE
      dpp$display_error ('*ERROR* Equipment number out of range.');
      RETURN;
    IFEND;

    iop$down_disk_controller (pp, physical_channel, equipment, down_status);
    IF NOT down_status.normal THEN
      dpp$display_error ('*ERROR* Bad status from IOP$DOWN_DISK_CONTROLLER.');
    IFEND;

  PROCEND process_down_controller;

?? TITLE := ' process_down_unit', EJECT ??
{ PURPOSE:
{   This procedure processes the 'DOWN_UNIT' command.  The format of the command is as follows:
{     DOWN_UNIT PARAMETER1 PARAMETER2
{       PARAMETER1 is the logical PP number.
{       PARAMETER2 is the channel number.
{       PARAMETER3 is the equipment number.
{       PARAMETER4 is the unit number.
{       PARAMETER5 is the logical_unit number.
{
{ NOTE:
{   This command is intended for testing purposes only.
{

  PROCEDURE process_down_unit
    (    data_line: t$command;
     VAR data_line_index {input, output} : t$command_length);

    VAR
      channel: ost$physical_channel_number,
      equipment: cmt$physical_equipment_number,
      down_status: syt$monitor_status,
      logical_unit: iot$logical_unit,
      number: integer,
      parse_good: boolean,
      physical_channel: cmt$physical_channel,
      pp: iot$pp_number,
      unit: cmt$physical_unit_number;

    parse_number (c$base_10, data_line, data_line_index, number, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* First parameter is invalid.');
      RETURN;
    IFEND;

    IF (number > 0) AND (number <= UPPERVALUE (iot$pp_number)) THEN
      pp := number;
    ELSE
      dpp$display_error ('*ERROR* pp number out of range.');
      RETURN;
    IFEND;

    parse_number (c$base_10, data_line, data_line_index, number, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* Second parameter is invalid.');
      RETURN;
    IFEND;

    IF (number > 0) AND (number <= UPPERVALUE(ost$physical_channel_number)) THEN
      channel := number;
    ELSE
      dpp$display_error ('*ERROR* Channel number out of range.');
      RETURN;
    IFEND;
    convert_channel_number (pp, channel, physical_channel);

    parse_number (c$base_10, data_line, data_line_index, number, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* Third parameter is invalid.');
      RETURN;
    IFEND;

    IF (number >= 0) AND (number <= UPPERVALUE(cmt$physical_equipment_number)) THEN
      equipment := number;
    ELSE
      dpp$display_error ('*ERROR* Equipment number out of range.');
      RETURN;
    IFEND;

    parse_number (c$base_10, data_line, data_line_index, number, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* Fourth parameter is invalid.');
      RETURN;
    IFEND;

    IF (number >= 0) AND (number <= UPPERVALUE(cmt$physical_unit_number)) THEN
      unit := number;
    ELSE
      dpp$display_error ('*ERROR* Unit number out of range.');
      RETURN;
    IFEND;

    parse_number (c$base_10, data_line, data_line_index, number, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* Fifth parameter is invalid.');
      RETURN;
    IFEND;

    IF (number >= 0) AND (number <= UPPERVALUE(iot$logical_unit)) THEN
      logical_unit := number;
    ELSE
      dpp$display_error ('*ERROR* Logical unit number out of range.');
      RETURN;
    IFEND;

    iop$down_disk_unit (pp, physical_channel, equipment, unit, logical_unit, down_status);
    IF NOT down_status.normal THEN
      dpp$display_error ('*ERROR* Bad status from IOP$DOWN_DISK_UNIT.');
    IFEND;

  PROCEND process_down_unit;

?? OLDTITLE ??
?? NEWTITLE := 'process_dumpjob', EJECT ??

{ PURPOSE:
{   This procedure processes the 'DUMPJOB' command.  The format of the command is as follows:
{     DUMPJOB PARAMETER1 PARAMETER2
{       PARAMETER1 is the system supplied name or an AJL ordinal.
{       PARAMETER2 is the disposition of the output produced by this command.  The valid values are
{         (retain r), (printer p), and (retain_and_print rap).  The default value will be 'retain_and_print'
{         unless otherwise changed by a Set_System_Attribute command.

  PROCEDURE process_dumpjob
    (    data_line: t$command;
     VAR data_line_index {input, output} : t$command_length);

    VAR
      cell_p: ^cell,
      ijle_p: ^jmt$initiated_job_list_entry,
      ijlo: jmt$ijl_ordinal,
      job_index: integer,
      number: integer,
      parse_good: boolean,
      save_data_line_index: t$command_length,
      test_ijl_p: ^jmt$initiated_job_list_entry,
      word: t$command,
      word_length: t$command_length;

    save_data_line_index := data_line_index;
    parse_number (c$base_10, data_line, data_line_index, number, parse_good);
    IF NOT parse_good THEN
      data_line_index := save_data_line_index;
      parse_word (data_line, data_line_index, word, word_length, parse_good);
      IF NOT parse_good THEN
        dpp$display_error ('*ERROR* First parameter is invalid.');
        RETURN;
      IFEND;
      jmp$find_jsn (word (1, word_length), ijle_p, ijlo);
      IF ijle_p = NIL THEN
        dpp$display_error ('*ERROR* The system supplied name was not found.');
        RETURN;
      IFEND;

    ELSE
      job_index := number;
      cell_p := ^mtv$monitor_segment_table;
      #purge_buffer (osc$pva_purge_segment_cache, cell_p);
      IF (job_index <= UPPERBOUND (jmv$ajl_p^)) AND (mtv$monitor_segment_table.st [mtc$job_fixed_segment +
            job_index].ste.vl >= osc$vl_regular_segment) THEN
        ijle_p := jmv$ajl_p^ [job_index].ijle_p;
      ELSE
        dpp$display_error ('*ERROR* Cannot dump specified job.');
        RETURN;
      IFEND;
    IFEND;

    jmp$get_ijle_p (jmv$system_ijl_ordinal, test_ijl_p);
    IF test_ijl_p = ijle_p THEN
      dpp$display_error ('*ERROR* Cannot DUMPJOB the system job.');
      RETURN;
    IFEND;

    { Display an informative message if the job is not swapped in.

    IF ijle_p^.entry_status >= jmc$ies_job_swapped THEN
      dpp$display_error (' Operator must SWAPIN job before DUMPJOB can proceed.');
    IFEND;

    IF jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.attributes.maximum_active_jobs = 0 THEN
      dpp$display_error (' MAXAJ for service class must be > 0 before DUMPJOB can proceed.');
    IFEND;

    parse_word (data_line, data_line_index, word, word_length, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* Second parameter is invalid.');
      RETURN;
    IFEND;

    IF word_length = 0 THEN
      IF syv$dflt_debug_output_disposal.disposal = syc$dod_null THEN
        syv$debug_output_disposition := syc$dod_save_and_print;
      ELSE
        syv$debug_output_disposition := syv$dflt_debug_output_disposal.disposal;
      IFEND;
    ELSEIF (word = 'RETAIN_AND_PRINT') OR (word = 'RAP') THEN
      syv$debug_output_disposition := syc$dod_save_and_print;
    ELSEIF (word = 'RETAIN') OR (word = 'R') THEN
      syv$debug_output_disposition := syc$dod_save_on_pf;
    ELSEIF (word = 'PRINTER') OR (word = 'P') THEN
      syv$debug_output_disposition := syc$dod_write_for_print;
    ELSEIF (word = 'CONSOLE') OR (word = 'C') THEN
      dpp$display_error ('*ERROR* Cannot DUMPJOB to the system console.');
      RETURN;
    ELSE
      dpp$display_error ('*ERROR* Second parameter is invalid.');
      RETURN;
    IFEND;

    tmp$monitor_flag_job_tasks (syc$mf_dump_job_environment, ijle_p);

  PROCEND process_dumpjob;

?? TITLE := ' process_enable_allocation', EJECT ??
{ PURPOSE:
{   This procedure processes the 'ENABLE_ALLOCATION' command.  The format of the command is as follows:
{     ENABLE_ALLOCATION PARAMETER1
{       PARAMETER1 is the AVT index.
{
{ NOTE:
{   This command is intended for testing purposes only.
{

  PROCEDURE process_enable_allocation
    (    data_line: t$command;
     VAR data_line_index {input, output} : t$command_length);

    VAR
      avti: integer,
      number: integer,
      parse_good: boolean;

    parse_number (c$base_10, data_line, data_line_index, number, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* First parameter is invalid.');
      RETURN;
    IFEND;

    IF (number > 0) AND (number <= UPPERBOUND (dmv$p_active_volume_table^)) THEN
      avti := number;
    ELSE
      dpp$display_error ('*ERROR* AVT index out of range.');
      RETURN;
    IFEND;

    IF dmv$p_active_volume_table^ [avti].entry_available THEN
      dpp$display_error ('*ERROR* Specified volume not active.');
    ELSE
      dmv$p_active_volume_table^ [avti].mass_storage.previous_allocation_allowed :=
            dmv$p_active_volume_table^ [avti].mass_storage.allocation_allowed;
      dmv$p_active_volume_table^ [avti].mass_storage.allocation_allowed := TRUE;
    IFEND;

  PROCEND process_enable_allocation;

?? OLDTITLE ??
?? NEWTITLE := 'process_idle_system', EJECT ??

{ PURPOSE:
{   This procedure processes the 'IDLE_SYSTEM' command.  The format of the command is as follows:
{     IDLE_SYSTEM

  PROCEDURE process_idle_system;

    VAR
      status: syt$monitor_status;

    IF mtv$scb.nos_180_status.system_status.idle_status_block.actual_status = mtc$running_system THEN
      IF mtv$scb.nos_180_status.system_status.step_status_block.actual_status = mtc$unstepped_system THEN
        mtv$scb.nos_180_status.system_status.idle_status_block.requested_status := mtc$idled_system;
        IF mtv$scb.nos_180_status.cause_of_idle = syc$ic_null THEN
          mtv$scb.nos_180_status.cause_of_idle := syc$ic_idle_command;
        IFEND;
        dpp$display_error ('Initiating IDLE_SYSTEM sequence.');
        tmp$monitor_ready_system_task (tmc$stid_job_monitor, status);
      ELSE
        dpp$display_error ('*ERROR* System already stepped.');
      IFEND;
    ELSE
      dpp$display_error ('*ERROR* System already idled.');
    IFEND;

  PROCEND process_idle_system;
?? OLDTITLE ??
?? NEWTITLE := 'process_password', EJECT ??

{ PURPOSE:
{   This procedure processes the password and finishes executing the disable_main_operator_window command and
{   the enable_main_operator_window command.

  PROCEDURE process_password
    (    password: string (7));

    VAR
      signal: dst$signal_contents,
      status: syt$monitor_status;

    v$expecting_password := FALSE;
    dpv$secure_input_line.secure := FALSE;
    signal.identifier := dsc$deadstart_signal;
    signal.contents.kind := dsc$signal_lock_unlock_window;
    signal.contents.luw_data.password := password;
    signal.contents.luw_data.lock_window := v$lock_main_window;
    tmp$send_signal (tmv$system_job_monitor_gtid, signal.signal, status);
    IF NOT status.normal THEN
      dpp$display_error ('Unable to enable the main operator window, problems sending signal.');
    IFEND;

  PROCEND process_password;
?? OLDTITLE ??
?? NEWTITLE := 'process_resume_system', EJECT ??

{ PURPOSE:
{   This procedure processes the 'RESUME_SYSTEM' command.  The format of the command is as follows:
{     RESUME_SYSTEM

  PROCEDURE process_resume_system;

    VAR
      scb_hardware_status: mtt$scb_trick_variant_record;

    IF mtv$scb.nos_180_status.system_status.idle_status_block.actual_status = mtc$idled_system THEN
      scb_hardware_status.hardware_status := mtv$scb.hardware_status;
      IF scb_hardware_status.errors_present = 0 THEN
        IF (mtv$scb.nos_180_status.idle_code = syc$ic_idle_command) OR

          { Code deactivated until we REALLY can do this.
          {   (mtv$scb.nos_180_status.idle_code = syc$ic_hardware_idle) OR

              (mtv$scb.nos_180_status.idle_code = syc$ic_long_power) THEN
          mtv$scb.nos_180_status.system_status.idle_status_block.requested_status := mtc$running_system;
          mtv$scb.nos_180_status.system_status.step_status_block.requested_status := mtc$unstepped_system;
        ELSE
          dpp$display_error ('*ERROR* System cannot be resumed via console command.');
        IFEND;
      ELSE
        dpp$display_error ('*ERROR* System cannot be resumed while hardware problems exist.');
      IFEND;
    ELSEIF mtv$scb.nos_180_status.system_status.step_status_block.actual_status = mtc$stepped_system THEN
      dpp$display_error ('*ERROR* System stepped. Only UNSTEP_SYSTEM can restart system.');
    ELSE
      dpp$display_error ('*ERROR* System already running.');
    IFEND;

  PROCEND process_resume_system;
?? OLDTITLE ??
?? NEWTITLE := 'process_step_system', EJECT ??

{ PURPOSE:
{   This procedure processes the 'STEP_SYSTEM' command.  The format of the command is as follows:
{     STEP_SYSTEM

  PROCEDURE process_step_system;

    IF mtv$scb.nos_180_status.system_status.step_status_block.actual_status = mtc$unstepped_system THEN
      mtv$scb.nos_180_status.system_status.step_status_block.requested_status := mtc$stepped_system;
    ELSE
      dpp$display_error ('*ERROR* System already stepped.');
    IFEND;

  PROCEND process_step_system;
?? OLDTITLE ??
?? NEWTITLE := 'process_sysdebug', EJECT ??

{ PURPOSE:
{   This procedure processes the 'SYSDEBUG' command.  The format of the command is as follows:
{     SYSDEBUG PARAMETER1 PARAMETER2
{       PARAMETER1 is the system supplied name or an AJL ordinal.
{       PARAMETER2 is the (optional) parameter specifying whether ALL tasks of the job should be debugged or
{         just the $JOBMNTR task should be debugged.  The default is $JOBMNTR.

  PROCEDURE process_sysdebug
    (    data_line: t$command;
     VAR data_line_index {input, output} : t$command_length);

    VAR
      all_tasks: boolean,
      ijle_p: ^jmt$initiated_job_list_entry,
      ijlo: jmt$ijl_ordinal,
      job_index: integer,
      job_monitor_id: ost$global_task_id,
      monitor_status: syt$monitor_status,
      parse_good: boolean,
      save_data_line_index: t$command_length,
      test_ijle_p: ^jmt$initiated_job_list_entry,
      use_computed_ijle_p: boolean,
      word: t$command,
      word_length: t$command_length;

    use_computed_ijle_p := FALSE;
    save_data_line_index := data_line_index;
    job_index := 0;

    parse_number (c$base_10, data_line, data_line_index, job_index, parse_good);
    IF NOT parse_good THEN
      data_line_index := save_data_line_index;
      parse_word (data_line, data_line_index, word, word_length, parse_good);
      IF NOT parse_good THEN
        dpp$display_error ('*ERROR* First parameter is invalid.');
        RETURN;
      IFEND;

      jmp$find_jsn (word (1, word_length), ijle_p, ijlo);
      IF ijle_p <> NIL THEN
        use_computed_ijle_p := TRUE;
      ELSE
        dpp$display_error ('*ERROR* The system supplied name was not found.');
        RETURN;
      IFEND;
    IFEND;

    parse_word (data_line, data_line_index, word, word_length, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* Second parameter is invalid.');
      RETURN;
    IFEND;

    IF (word_length = 0) OR (word = '$JOBMNTR') THEN
      all_tasks := FALSE;
    ELSEIF word = 'ALL' THEN
      all_tasks := TRUE;
    ELSE
      dpp$display_error ('*ERROR* Second parameter is invalid.');
      RETURN;
    IFEND;

    IF NOT use_computed_ijle_p THEN
      IF (job_index = jmv$system_ajl_ordinal) AND all_tasks THEN
        dpp$display_error ('*ERROR* Cannot debug all tasks in system job');
        RETURN;
      IFEND;
      IF (job_index <= UPPERBOUND (jmv$ajl_p^)) AND (jmv$ajl_p^ [job_index].in_use <> 0) THEN
        ijle_p := jmv$ajl_p^ [job_index].ijle_p;
      ELSE
        dpp$display_error ('*ERROR* Job not active');
        RETURN;
      IFEND;
    IFEND;

    { Display an informative message if the job is not swapped in.

    IF ijle_p^.entry_status = jmc$ies_operator_force_out THEN
      dpp$display_error (' Operator must SWAPIN job before SYSDEBUG can proceed.');
    IFEND;

    IF all_tasks THEN
      jmp$get_ijle_p (jmv$system_ijl_ordinal, test_ijle_p);
      IF test_ijle_p = ijle_p THEN
        dpp$display_error ('*ERROR* Cannot debug all tasks in the system job.');
        RETURN;
      IFEND;
      syv$debug_output_disposition := syc$dod_null;
      tmp$monitor_flag_job_tasks (syc$mf_invoke_sysdebug, ijle_p);
    ELSE
      job_monitor_id := ijle_p^.job_monitor_taskid;
      syv$debug_output_disposition := syc$dod_null;
      tmp$set_monitor_flag (job_monitor_id, syc$mf_invoke_sysdebug, monitor_status);
    IFEND;

  PROCEND process_sysdebug;
?? OLDTITLE ??
?? NEWTITLE := 'process_tdebug', EJECT ??

{ PURPOSE:
{   This procedure processes the 'TDEBUG' command.  The format of the command is as follows:
{     TDEBUG GLOBAL_TASK_ID

  PROCEDURE process_tdebug
    (    data_line: t$command;
     VAR data_line_index {input, output} : t$command_length);

    VAR
      global_task_id: ost$global_task_id,
      index: integer,
      monitor_status: syt$monitor_status,
      mult: integer,
      number: integer,
      parse_good: boolean;

    parse_number (c$base_16, data_line, data_line_index, number, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* First parameter is invalid.');
      RETURN;
    IFEND;

    mult := 1;
    FOR index := 1 TO #SIZE (global_task_id.seqno) DO
      mult := mult * 256;
    FOREND;

    IF (number DIV mult) > 65535 THEN
      dpp$display_error ('*ERROR* Invalid Task Id.');
      RETURN;
    IFEND;

    global_task_id.index := number DIV mult;
    IF (number MOD mult) <= UPPERVALUE (global_task_id.seqno) THEN
      global_task_id.seqno := number MOD mult;
      syv$debug_output_disposition := syc$dod_null;
      tmp$set_monitor_flag (global_task_id, syc$mf_invoke_sysdebug, monitor_status);
      IF NOT monitor_status.normal THEN
        dpp$display_error ('*ERROR* Invalid Task Id.');
      IFEND;
    IFEND;

  PROCEND process_tdebug;
?? OLDTITLE ??
?? NEWTITLE := 'process_unstep_system', EJECT ??

{ PURPOSE:
{   This procedure processes the 'UNSTEP_SYSTEM' command.  The format of the command is as follows:
{     UNSTEP_SYSTEM

  PROCEDURE process_unstep_system;

    VAR
      scb_hardware_status: mtt$scb_trick_variant_record;

    IF mtv$scb.nos_180_status.system_status.step_status_block.actual_status = mtc$stepped_system THEN
      IF mtv$scb.nos_180_status.system_status.idle_status_block.actual_status = mtc$running_system THEN
        scb_hardware_status.hardware_status := mtv$scb.hardware_status;
        IF scb_hardware_status.errors_present = 0 THEN
          IF (mtv$scb.nos_180_status.idle_code = syc$ic_step_command) OR
                (mtv$scb.nos_180_status.idle_code = syc$ic_short_power) OR
                (mtv$scb.nos_180_status.idle_code = syc$ic_disk_error) OR
                (mtv$scb.nos_180_status.idle_code = syc$ic_software_breakpoint) THEN
            mtv$scb.nos_180_status.system_status.step_status_block.requested_status := mtc$unstepped_system;
          ELSE
            dpp$display_error ('*ERROR* System cannot be unstepped via console command.');
          IFEND;
        ELSE
          dpp$display_error ('*ERROR* System cannot be unstepped while hardware problems exist.');
        IFEND;
      ELSEIF mtv$scb.nos_180_status.system_status.idle_status_block.requested_status = mtc$running_system THEN
        scb_hardware_status.hardware_status := mtv$scb.hardware_status;
        IF scb_hardware_status.errors_present = 0 THEN
          IF (mtv$scb.nos_180_status.idle_code = syc$ic_step_command) OR
                (mtv$scb.nos_180_status.idle_code = syc$ic_short_power) OR
                (mtv$scb.nos_180_status.idle_code = syc$ic_disk_error) OR
                (mtv$scb.nos_180_status.idle_code = syc$ic_software_breakpoint) THEN
            mtv$scb.nos_180_status.system_status.step_status_block.requested_status := mtc$unstepped_system;
          ELSE
            dpp$display_error ('*ERROR* System cannot be unstepped via console command.');
          IFEND;
        ELSE
          dpp$display_error ('*ERROR* System cannot be unstepped while hardware problems exist.');
        IFEND;
      ELSE
        dpp$display_error ('*ERROR* System idled. Only RESUME_SYSTEM can restart system.');
      IFEND;
    ELSE
      dpp$display_error ('*ERROR* System already unstepped.');
    IFEND;

  PROCEND process_unstep_system;
?? TITLE := 'process_sync', EJECT ??

{ PURPOSE:
{   This procedure processes the 'SYNC' command.  The format of the command is as follows:
{     SYNC PASSES TRAPS_ENABLED
{       passes - specifies the number of times the SYNC instruction will be called.  The default value is
{                zero.
{       traps_enabled - specifies whether traps are enabled or disabled during SYNC execution.  The default
{                       value is zero (disabled).

  PROCEDURE process_sync
    (    data_line: t$command;
     VAR data_line_index {input, output} : t$command_length);

    VAR
      index: integer,
      old_te: 0..3,
      passes: integer,
      parse_good: boolean,
      traps_enabled: integer;

    passes := 0;
    traps_enabled := 0;

    parse_number (c$base_16, data_line, data_line_index, passes, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* PASSES parameter is invalid.');
      RETURN;
    IFEND;

    IF passes <= 0 THEN
      RETURN;
    IFEND;

    parse_number (c$base_16, data_line, data_line_index, traps_enabled, parse_good);
    IF NOT parse_good THEN
      dpp$display_error ('*ERROR* TRAPS_ENABLED parameter is invalid.');
      RETURN;
    IFEND;

    IF (traps_enabled <> 0) AND (traps_enabled <> 1) THEN
      dpp$display_error ('*ERROR* Invalid Traps_Enabled value.');
      dpp$display_error ('*INFORMATIVE* 0 = traps disabled, 1 = traps enabled');
      RETURN;
    IFEND;

{ Traps are disabled by the caller of this procedure.  If traps are desired, enable/disable them.

    IF traps_enabled = 1 THEN
      i#mtr_enable_traps (old_te);
    IFEND;

    FOR index := 1 TO passes DO
      i#sync;
    FOREND;

    IF traps_enabled = 1 THEN
      i#mtr_disable_traps (old_te);
    IFEND;

  PROCEND process_sync;
?? OLDTITLE ??
?? NEWTITLE := 'dpp$process_monitor_command', EJECT ??

{ PURPOSE:
{   This procedure processes the monitor command and performs the appropriate action.

  PROCEDURE [XDCL] dpp$process_monitor_command
    (    input_line: string ( * ));

    VAR
      data_line: t$command,
      data_line_index: t$command_length,
      parse_good: boolean,
      word: t$command,
      word_length: t$command_length;

    IF NOT tmv$tables_initialized THEN
      dpp$display_error ('*ERROR* System not sufficiently initialized to accept commands');
      RETURN;
    IFEND;

    data_line := input_line;
    dpp$display_error (data_line (1, 71));
    data_line_index := 1;
    parse_word (data_line, data_line_index, word, word_length, parse_good);

    IF v$expecting_password THEN
      process_password (word (1, 7));
      RETURN;
    ELSEIF (word_length = 0) AND parse_good THEN
      RETURN;
    ELSEIF NOT parse_good THEN
      dpp$display_error ('*ERROR* Invalid monitor command');
      RETURN;
    IFEND;

    IF word = 'CHANGE_MDD_OPERATING_MODE' THEN
      IF avv$security_options [avc$vso_secure_analysis].active THEN
        dpp$display_error ('*ERROR* MDD call ignored, it was disabled at deadstart.');
      ELSE
        process_change_mdd_op_mode (data_line, data_line_index);
      IFEND;
    ELSEIF word = 'DISABLE_ALLOCATION' THEN
      process_disable_allocation (data_line, data_line_index);
    ELSEIF word = 'DISABLE_MAIN_OPERATOR_WINDOW' THEN
      process_dismow_enamow (TRUE);
    ELSEIF word = 'DOWN_CHANNEL' THEN
      process_down_channel (data_line, data_line_index);
    ELSEIF word = 'DOWN_CONTROLLER' THEN
      process_down_controller (data_line, data_line_index);
    ELSEIF word = 'DOWN_UNIT' THEN
      process_down_unit (data_line, data_line_index);
    ELSEIF word = 'DUMPJOB' THEN
      IF avv$security_options [avc$vso_secure_analysis].active THEN
        dpp$display_error ('*ERROR* DUMPJOB call ignored, it was disabled at deadstart.');
      ELSE
        process_dumpjob (data_line, data_line_index);
      IFEND;
    ELSEIF word = 'ENABLE_ALLOCATION' THEN
      process_enable_allocation (data_line, data_line_index);
    ELSEIF word = 'ENABLE_MAIN_OPERATOR_WINDOW' THEN
      process_dismow_enamow (FALSE);
    ELSEIF word = 'IDLE_SYSTEM' THEN
      process_idle_system;
    ELSEIF word = 'RESUME_SYSTEM' THEN
      process_resume_system;
    ELSEIF word = 'STEP_SYSTEM' THEN
      process_step_system;
    ELSEIF word = 'SYSDEBUG' THEN
      IF avv$security_options [avc$vso_secure_analysis].active THEN
        dpp$display_error ('*ERROR* SYSDEBUG call ignored, it was disabled at deadstart.');
      ELSE
        process_sysdebug (data_line, data_line_index);
      IFEND;
    ELSEIF word = 'TDEBUG' THEN
      IF avv$security_options [avc$vso_secure_analysis].active THEN
        dpp$display_error ('*ERROR* TDEBUG call ignored, it was disabled at deadstart.');
      ELSE
        process_tdebug (data_line, data_line_index);
      IFEND;
    ELSEIF word = 'UNSTEP_SYSTEM' THEN
      process_unstep_system;
    ELSEIF word = 'VOLUME_AVAILABLE' THEN      {This command is for development testing ONLY!!
      mmp$volume_available;
      jmp$resurrect_dead_jobs;
    ELSEIF word = 'SYNC' THEN
      process_sync (data_line, data_line_index);
    ELSE
      dpp$display_error ('*ERROR* Invalid monitor command.');
    IFEND;

  PROCEND dpp$process_monitor_command;
MODEND dpm$process_monitor_command;
*DECK DECK=DPM$SYSTEM_CONSOLE_INTERFACE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Display Processor : System Console Interface' ??
MODULE dpm$system_console_interface;

{ PURPOSE:
{   This module contains the lowest level job mode interfaces to display data on the system console.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dpe$error_codes
*copyc dpt$critical_window_date_time
*copyc dpt$number_of_window_lines
*copyc dpt$rb_display_request
*copyc dpt$window
*copyc ost$wait
?? POP ??
*copyc dsp$allocate_continuous_memory
*copyc i#call_monitor
*copyc lgp$add_entry_to_critical_log
*copyc osp$monitor_fault_to_status
*copyc osp$set_status_abnormal
*copyc pmp$delay
*copyc pmp$get_date
*copyc pmp$get_time
*copyc pmp$zero_out_table
*copyc syp$disestablish_cond_handler
*copyc syp$establish_condition_handler
?? EJECT ??
*copyc dpv$180_operator_action
*copyc dpv$critical_display_id
*copyc dpv$scd_block_p
*copyc dpv$top_window_p
*copyc mtv$nosve_control_status
*copyc osv$mainframe_wired_cb_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    dpv$system_core_display: [XDCL, #GATE] dpt$window_id,
    v$loop_count_of_20_reached: boolean := FALSE;
?? OLDTITLE ??
?? NEWTITLE := 'dpp$change_window', EJECT ??

{ PURPOSE;
{   This procedure allows the caller to change the window's kind and class.

  PROCEDURE [XDCL, #GATE] dpp$change_window
    (    window_id: dpt$window_id;
         class: dpt$window_class;
         kind: dpt$window_kind;
     VAR status: ost$status);

    VAR
      rb: dpt$rb_display_request,
      window_p: ^dpt$window;

    status.normal := TRUE;

    window_p := dpv$top_window_p;
    WHILE (window_p <> NIL) AND (window_p^.window_id <> window_id) DO
      window_p := window_p^.next_window_p;
    WHILEND;
    IF window_p = NIL THEN
      osp$set_status_abnormal (dpc$display_processor_id, dpe$window_not_found, '', status);
      RETURN;
    IFEND;

    { Cannot change the window kind from interactive.

    IF (window_p^.kind = dpc$wk_interactive) AND (kind <> dpc$wk_interactive) THEN
      osp$set_status_abnormal (dpc$display_processor_id, dpe$no_change_from_interactive, '', status);
      RETURN;
    IFEND;

    { Change the true class to reflect the changed class.

    window_p^.true_class := class;
    window_p^.table_starting_line_in_window := 1;
    window_p^.table_last_line_used_in_window := 1;

    { Check if no real change then return.

    IF (class = window_p^.class) AND (kind = window_p^.kind) THEN
      RETURN;
    IFEND;

    window_p^.class := class;

    IF kind <> window_p^.kind THEN
      window_p^.present_window_line_number := 0;
      window_p^.table_next_available_line := 1;
      window_p^.kind := kind;
      rb.action := dpc$da_clear_window;
    ELSE
      rb.action := dpc$da_change_window;
    IFEND;

    rb.reqcode := syc$rc_update_system_display;
    rb.window_p := window_p;
    i#call_monitor (#LOC (rb), #SIZE (rb));

  PROCEND dpp$change_window;
?? OLDTITLE ??
?? NEWTITLE := 'dpp$clear_window', EJECT ??

{ PURPOSE:
{   This procedure clears a window.  If the window is a table it clears the window lines that are not being
{   used (ie: it clears from the end of the table to the end of the window lines).  If the window is a log
{   or interactive window, it displays a window of blank lines.  It will wait for existing lines to be
{   displayed before overwriting them.

  PROCEDURE [XDCL, #GATE] dpp$clear_window
    (    window_id: dpt$window_id;
     VAR status: ost$status);

    VAR
      index: dpt$number_of_window_lines,
      rb: dpt$rb_display_request,
      starting_clear_line: integer,
      window_p: ^dpt$window;

    status.normal := TRUE;

    window_p := dpv$top_window_p;
    WHILE (window_p <> NIL) AND (window_p^.window_id <> window_id) DO
      window_p := window_p^.next_window_p;
    WHILEND;
    IF window_p = NIL THEN
      osp$set_status_abnormal (dpc$display_processor_id, dpe$window_not_found, '', status);
      RETURN;
    IFEND;

    rb.reqcode := syc$rc_update_system_display;
    rb.action := dpc$da_queue_line;
    rb.window_p := window_p;

    CASE window_p^.kind OF
    = dpc$wk_table =
      starting_clear_line := window_p^.table_next_available_line -
            window_p^.table_starting_line_in_window + 1;
      IF starting_clear_line < 1 THEN
        starting_clear_line := 1;
      IFEND;
      FOR index := starting_clear_line TO dpc$number_of_window_lines DO
        IF window_p^.lines [index].text_size <> 0 THEN
          window_p^.lines [index].text_size := 0;
          window_p^.lines [index].text := ' ';
          IF window_p^.lines [index].ending_console_row_number <> 0 THEN
            rb.line_p := ^window_p^.lines [index];
            i#call_monitor (#LOC (rb), #SIZE (rb));
          IFEND;
        IFEND;
      FOREND;
      window_p^.table_last_line_used_in_window := window_p^.table_next_available_line;
      window_p^.table_next_available_line := 1;

    ELSE {= dpc$wk_interactive, dpc$wk_log =}
      window_p^.present_window_line_number := 0;
      FOR index := 1 TO dpc$number_of_window_lines DO

        { Wait until the line has been displayed by SCD.

        WHILE (window_p^.lines [index].next_line_rma <> dpc$rma_scd_finished) DO
          pmp$delay (100, status);
        WHILEND;
        window_p^.lines [index].text_size := 0;
        window_p^.lines [index].text := ' ';
      FOREND;

      { Display a window of blank lines.

      FOR index := 1 TO window_p^.ending_console_row_number - window_p^.starting_console_row_number + 1 DO
        rb.line_p := ^window_p^.lines [index];
        i#call_monitor (#LOC (rb), #SIZE (rb));
      FOREND;

    CASEND;

  PROCEND dpp$clear_window;
?? OLDTITLE ??
?? NEWTITLE := 'dpp$close_window', EJECT ??

{ PURPOSE:
{   This procedure closes a window and removes it from the window linked list.

  PROCEDURE [XDCL, #GATE] dpp$close_window
    (VAR window_id: dpt$window_id;
     VAR status: ost$status);

    VAR
      rb: dpt$rb_display_request,
      window_p: ^dpt$window;

    status.normal := TRUE;

    window_p := dpv$top_window_p;
    WHILE (window_p <> NIL) AND (window_p^.window_id <> window_id) DO
      window_p := window_p^.next_window_p;
    WHILEND;
    IF window_p = NIL THEN
      osp$set_status_abnormal (dpc$display_processor_id, dpe$window_not_found, '', status);
      RETURN;
    IFEND;

    rb.reqcode := syc$rc_update_system_display;
    rb.action := dpc$da_delete_window;
    rb.window_p := window_p;
    i#call_monitor (#LOC (rb), #SIZE (rb));

    { Wait for monitor to delete the window.

    REPEAT
      pmp$delay (500, status);
    UNTIL window_p^.window_id = 0;

    FREE window_p IN osv$mainframe_wired_cb_heap^;
    window_id := 0;

  PROCEND dpp$close_window;
?? OLDTITLE ??
?? NEWTITLE := 'dpp$configure_system_console', EJECT ??

{ PURPOSE:
{   This procedure configures the system console.  It first allocates space for the SCD communication block
{   and then calls monitor to fill in appropriate information in the SCI parameter table.

  PROCEDURE [XDCL] dpp$configure_system_console;

    VAR
      dp_rb: dpt$rb_display_request,
      scd_seq_p: ^SEQ ( * );

    dsp$allocate_continuous_memory (osv$mainframe_wired_cb_heap, #SIZE (dpt$scd_communications_block),
          scd_seq_p);
    RESET scd_seq_p;
    NEXT dpv$scd_block_p IN scd_seq_p;
    pmp$zero_out_table (#LOC (dpv$scd_block_p^), #SIZE (dpv$scd_block_p^));

    dp_rb.reqcode := syc$rc_update_system_display;
    dp_rb.action := dpc$da_configure_console;
    i#call_monitor (#LOC (dp_rb), #SIZE (dp_rb));

  PROCEND dpp$configure_system_console;
?? OLDTITLE ??
?? NEWTITLE := 'dpp$get_number_lines_in_window', EJECT ??

{ PURPOSE:
{   This procedure retrieves the number of lines that are currently displayed on the console for the
{   specified window.

  PROCEDURE [XDCL, #GATE] dpp$get_number_lines_in_window
    (    window_id: dpt$window_id;
     VAR number_of_lines: dpt$number_of_window_lines;
     VAR status: ost$status);

    VAR
      window_p: ^dpt$window;

    status.normal := TRUE;
    number_of_lines := 0;

    window_p := dpv$top_window_p;
    WHILE (window_p <> NIL) AND (window_p^.window_id <> window_id) DO
      window_p := window_p^.next_window_p;
    WHILEND;
    IF window_p = NIL THEN
      osp$set_status_abnormal (dpc$display_processor_id, dpe$window_not_found, '', status);
      RETURN;
    IFEND;

    number_of_lines := window_p^.ending_console_row_number - window_p^.starting_console_row_number;

  PROCEND dpp$get_number_lines_in_window;
?? OLDTITLE ??
?? NEWTITLE := 'dpp$get_next_line', EJECT ??

{ PURPOSE:
{   This procedure retrieves a line of data from the system console.  One of the parameters is a wait
{   parameter.  If the procedure is called with the wait selected, the procedure will wait until a line
{   is received from the system console.

  PROCEDURE [XDCL, #GATE] dpp$get_next_line
    (    window_id: dpt$window_id;
         wait: ost$wait;
     VAR line: string ( * );
     VAR line_received: boolean);

    VAR
      ignore_status: ost$status,
      rb: dpt$rb_display_request,
      window_p: ^dpt$window;

    window_p := dpv$top_window_p;
    WHILE (window_p <> NIL) AND (window_p^.window_id <> window_id) DO
      window_p := window_p^.next_window_p;
    WHILEND;
    IF window_p = NIL THEN
      line_received := FALSE;
      RETURN;
    IFEND;

    IF window_p^.kind <> dpc$wk_interactive THEN
      line_received := FALSE;
      RETURN;
    IFEND;

    IF (wait = osc$nowait) AND (window_p^.input_line.text_kind <> dpc$tk_input_ready) THEN
      line_received := FALSE;
      RETURN;
    IFEND;

    { Wait for the input line.

    WHILE window_p^.input_line.text_kind <> dpc$tk_input_ready DO
      pmp$delay (500, ignore_status);
    WHILEND;

    { Retrieve the input line.

    line := window_p^.input_line.text (1, window_p^.input_line.text_size);
    line_received := TRUE;

    { Wait until the input_ready line has been processed and then change the line kind from input ready
    { to input.

    WHILE (window_p^.input_line.next_line_rma <> dpc$rma_scd_finished) DO
      pmp$delay (100, ignore_status);
    WHILEND;

    rb.reqcode := syc$rc_update_system_display;
    rb.action := dpc$da_queue_line;
    rb.window_p := window_p;
    rb.line_p := ^window_p^.input_line;
    rb.line_p^.text_kind := dpc$tk_input;
    rb.line_p^.text_size := 0;
    rb.line_p^.text := ' ';
    i#call_monitor (#LOC (rb), #SIZE (rb));

  PROCEND dpp$get_next_line;
?? OLDTITLE ??
?? NEWTITLE := 'dpp$get_starting_line', EJECT ??

{  PURPOSE:
{    This procedure returns the value of the starting line of the window.  The table's next available line is
{    changed to the starting line in the window so that new lines can be added to the window.  The last line
{    used in the window is set to the previous next available line of the window so the maximum number of data
{    is known.  This procedure can only be used with windows that are tables.

  PROCEDURE [XDCL, #GATE] dpp$get_starting_line
    (    window_id: dpt$window_id;
     VAR starting_line: integer;
     VAR status: ost$status);

    VAR
      window_p: ^dpt$window;

    status.normal := TRUE;

    window_p := dpv$top_window_p;
    WHILE (window_p <> NIL) AND (window_p^.window_id <> window_id) DO
      window_p := window_p^.next_window_p;
    WHILEND;
    IF window_p = NIL THEN
      osp$set_status_abnormal (dpc$display_processor_id, dpe$window_not_found, '', status);
      RETURN;
    IFEND;

    IF window_p^.kind <> dpc$wk_table THEN
      osp$set_status_abnormal (dpc$display_processor_id, dpe$window_not_table, '', status);
      RETURN;
    IFEND;

    starting_line := window_p^.table_starting_line_in_window;

    window_p^.table_last_line_used_in_window := window_p^.table_next_available_line;
    window_p^.table_next_available_line := starting_line;

  PROCEND dpp$get_starting_line;
?? OLDTITLE ??
?? NEWTITLE := 'dpp$open_window', EJECT ??

{ PURPOSE:
{   This procedure creates a window.

  PROCEDURE [XDCL, #GATE] dpp$open_window
    (    class: dpt$window_class;
         kind: dpt$window_kind;
         title: string ( * );
     VAR window_id: dpt$window_id;
     VAR status: ost$status);

    VAR
      index: dpt$number_of_window_lines,
      rb: dpt$rb_display_request,
      window_p: ^dpt$window;

    status.normal := TRUE;

    ALLOCATE window_p IN osv$mainframe_wired_cb_heap^;

    window_p^.next_window_p := NIL;
    window_p^.window_id := 0;

    window_p^.starting_console_row_number := 0;
    window_p^.ending_console_row_number := 0;
    window_p^.true_class := class;
    window_p^.class := class;
    window_p^.kind := kind;
    window_p^.table_starting_line_in_window := 1;
    window_p^.table_last_line_used_in_window := 1;
    window_p^.table_next_available_line := 1;
    window_p^.present_window_line_number := 0;

    window_p^.title.ending_console_row_number := 0;
    window_p^.title.text_size := 0;
    window_p^.title.text_kind := dpc$tk_title;
    window_p^.title.next_line_rma := dpc$rma_scd_finished;

    window_p^.input_line.ending_console_row_number := 0;
    window_p^.input_line.text_size := 0;
    window_p^.input_line.text_kind := dpc$tk_input;
    window_p^.input_line.next_line_rma := dpc$rma_scd_finished;

    FOR index := 1 TO dpc$number_of_window_lines DO
      window_p^.lines [index].starting_console_row_number := 0;
      window_p^.lines [index].ending_console_row_number := 0;
      window_p^.lines [index].text_size := 0;
      window_p^.lines [index].text_kind := dpc$tk_display;
      window_p^.lines [index].next_line_rma := dpc$rma_scd_finished;
    FOREND;

    rb.reqcode := syc$rc_update_system_display;
    rb.action := dpc$da_add_window;
    rb.window_p := window_p;
    i#call_monitor (#LOC (rb), #SIZE (rb));

    window_id := window_p^.window_id;
    dpp$set_title (window_id, title, status);

  PROCEND dpp$open_window;
?? OLDTITLE ??
?? NEWTITLE := 'dpp$put_critical_message', EJECT ??

{ PURPOSE:
{   This procedure writes the current time and the incoming string to the critical window
{   and to the critical window log.

  PROCEDURE [XDCL, #GATE] dpp$put_critical_message
    (    message: string ( * <= osc$max_string_size);
     VAR status: ost$status);

    VAR
      actual_line_size: 0 .. dpc$console_row_size,
      date: ost$date,
      date_time_string: dpt$critical_window_date_time,
      ignore_status: ost$status,
      message_line: string (dpc$console_row_size),
      line: string (osc$max_string_size),
      line_index: integer,
      line_size: 0 .. osc$max_string_size,
      time: ost$time;

?? OLDTITLE ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE: Intercept monitor errors and pass back to procedure who
{          called dpp$put_critical_message.

    PROCEDURE condition_handler
      (    monitor_fault: ost$monitor_fault;
           save_area: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$monitor_fault_to_status (monitor_fault, save_area, status);
      EXIT dpp$put_critical_message;

    PROCEND condition_handler;
?? OLDTITLE ??

    syp$establish_condition_handler (^condition_handler);
    status.normal := TRUE;
    time.time_format := osc$hms_time;
    pmp$get_time (time.time_format, time, status);
    date.date_format := osc$mdy_date;
    pmp$get_date (date.date_format, date, status);
    date_time_string.string_part := ' ';
    date_time_string.hms := time.hms;
    date_time_string.mdy := date.mdy;

    IF (#SIZE (message) = 0) OR (message = ' ') THEN
      line := ' ';
      line_size := 1;
    ELSE

     /trim_message/
      FOR line_index := #SIZE (message) DOWNTO 1 DO
        IF message (line_index) <> ' ' THEN
          line_size := line_index;
          line := message (1, line_size);
          EXIT /trim_message/;
        IFEND;
      FOREND /trim_message/;
    IFEND;

    line_index := 1;
    WHILE line_size > 0 DO
      IF line_size > dpc$critical_window_msg_size THEN
        actual_line_size := dpc$critical_window_msg_size;
        line_size := line_size - dpc$critical_window_msg_size;
      ELSE
        actual_line_size := line_size;
        line_size := 0;
      IFEND;
      message_line := ' ';
      message_line (1, dpc$date_time_size):= date_time_string.string_part;
      message_line ((dpc$date_time_size + 1), *):= line (line_index, actual_line_size);
      line_index := line_index + actual_line_size;
      dpp$put_next_line (dpv$critical_display_id, message_line, status);
      lgp$add_entry_to_critical_log (message_line, ignore_status);
    WHILEND;
    syp$disestablish_cond_handler;

  PROCEND dpp$put_critical_message;
?? OLDTITLE ??
?? NEWTITLE := 'dpp$put_next_line', EJECT ??

{ PURPOSE:
{   This procedure puts a line on the system console.

  PROCEDURE [XDCL, #GATE] dpp$put_next_line
    (    window_id: dpt$window_id;
         line: string ( * );
     VAR status: ost$status);

    VAR
      first: integer,
      line_length: integer,
      line_p: ^dpt$console_line,
      line_position: integer,
      loop_count: 0 .. 20,
      rb: dpt$rb_display_request,
      window_p: ^dpt$window;

    status.normal := TRUE;

    window_p := dpv$top_window_p;
    WHILE (window_p <> NIL) AND (window_p^.window_id <> window_id) DO
      window_p := window_p^.next_window_p;
    WHILEND;
    IF window_p = NIL THEN
      osp$set_status_abnormal (dpc$display_processor_id, dpe$window_not_found, '', status);
      RETURN;
    IFEND;

    first := 1;
    line_length := STRLENGTH (line);

    rb.reqcode := syc$rc_update_system_display;
    rb.action := dpc$da_queue_line;
    rb.window_p := window_p;

    WHILE line_length <> 0 DO
      CASE window_p^.kind OF
      = dpc$wk_table =
        IF line_length > dpc$console_row_size THEN
          line_length := dpc$console_row_size;
          osp$set_status_abnormal (dpc$display_processor_id, dpe$line_truncated, '', status);
        IFEND;
        window_p^.table_next_available_line := window_p^.table_next_available_line + 1;
        line_position := window_p^.table_next_available_line - window_p^.table_starting_line_in_window;
        IF (line_position < 1) OR (line_position > dpc$number_of_window_lines) THEN

          { The line does not fit in the actual window being viewed, skip the line.

          RETURN;
        IFEND;
        line_p := ^window_p^.lines [line_position];
        IF line_p^.text = line (1, line_length) THEN
          RETURN;
        IFEND;

      ELSE { = dpc$wk_interactive, dpc$wk_log = }
        window_p^.present_window_line_number := window_p^.present_window_line_number MOD
              dpc$number_of_window_lines + 1;
        line_p := ^window_p^.lines [window_p^.present_window_line_number];
        loop_count := 1;
        WHILE (line_p^.next_line_rma <> dpc$rma_scd_finished) DO
          pmp$delay (100, status);
          IF (line_p^.next_line_rma <> dpc$rma_scd_finished) AND
                ((mtv$nosve_control_status.idle_state <> mtc$system_not_idle) OR
                (mtv$nosve_control_status.step_state <> mtc$system_not_stepped)) THEN
            IF (loop_count = 20) OR v$loop_count_of_20_reached THEN
              v$loop_count_of_20_reached := TRUE;
              RETURN;
            ELSE
              loop_count := loop_count + 1;
            IFEND;
          IFEND;
        WHILEND;
        v$loop_count_of_20_reached := FALSE;
      CASEND;

      IF line_length > dpc$console_row_size THEN
        line_p^.text := line (first, dpc$console_row_size);
        line_p^.text_size := dpc$console_row_size;
        line_length := line_length - dpc$console_row_size;
        first := first + dpc$console_row_size;
      ELSE
        line_p^.text := line (first, line_length);
        line_p^.text_size := line_length;
        line_length := 0;
      IFEND;

      IF line_p^.ending_console_row_number <> 0 THEN
        rb.line_p := line_p;
        i#call_monitor (#LOC (rb), #SIZE (rb));
      IFEND;
    WHILEND;

  PROCEND dpp$put_next_line;
?? OLDTITLE ??
?? NEWTITLE := 'dpp$set_180_operator_action', EJECT ??

  PROCEDURE [XDCL, #GATE] dpp$set_180_operator_action
    (    actions_present: boolean);

    dpv$180_operator_action := actions_present;

  PROCEND dpp$set_180_operator_action;
?? OLDTITLE ??
?? NEWTITLE := 'dpp$set_title', EJECT ??

{ PURPOSE:
{   This procedure centers the incoming title on the desired window's title line.

  PROCEDURE [XDCL, #GATE] dpp$set_title
    (    window_id: dpt$window_id;
         title: string ( * );
     VAR status: ost$status);

    VAR
      centered_starting_point: integer,
      rb: dpt$rb_display_request,
      title_size: integer,
      window_p: ^dpt$window;

    status.normal := TRUE;

    window_p := dpv$top_window_p;
    WHILE (window_p <> NIL) AND (window_p^.window_id <> window_id) DO
      window_p := window_p^.next_window_p;
    WHILEND;
    IF window_p = NIL THEN
      osp$set_status_abnormal (dpc$display_processor_id, dpe$window_not_found, '', status);
      RETURN;
    IFEND;

    window_p^.title.text_size := dpc$console_row_size;
    window_p^.title.text_kind := dpc$tk_title;

    { Center the title on the title line.  If a title that is larger then 80 characters is sent to this
    { routine then the centered starting point will be negative.  In this case, the incoming title is
    { truncated to 80 characters and a warning message is returned to the caller.

    title_size := STRLENGTH (title);
    IF title_size > dpc$console_row_size THEN
      osp$set_status_abnormal (dpc$display_processor_id, dpe$line_truncated, '', status);
    IFEND;
    centered_starting_point := ((dpc$console_row_size - title_size) DIV 2) + 1;
    window_p^.title.text := ' ';
    IF centered_starting_point > 0 THEN
      window_p^.title.text (centered_starting_point, title_size) := title;
    ELSE
      window_p^.title.text := title;
    IFEND;

    rb.reqcode := syc$rc_update_system_display;
    rb.action := dpc$da_queue_line;
    rb.window_p := window_p;
    rb.line_p := ^window_p^.title;
    i#call_monitor (#LOC (rb), #SIZE (rb));

  PROCEND dpp$set_title;
MODEND dpm$system_console_interface;
*DECK DECK=DPM$SYSTEM_CONSOLE_MONITOR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Display Processor : System Console Monitor' ??
MODULE dpm$system_console_monitor;

{ PURPOSE:
{   This module contains the routines for driving the system console and processing system console monitor
{   requests.  This consists mainly of updating the screens and processing keyboard input.
{
{ NOTE:
{   Some of the routines in this module are called periodically from the monitor loop or to process an
{   external interrupt from the system console driver.  Because of this it is important that this code is as
{   efficient as possible.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dpc$console_row_size
*copyc dpc$top_line_message_size
*copyc dpe$error_codes
*copyc dpt$console_parameter_block
*copyc dpt$critical_messages
*copyc dpt$critical_window_date_time
*copyc dpt$lock_main_window
*copyc dpt$rb_display_request
*copyc dpt$scd_communications_block
*copyc dpt$secure_input_line
*copyc dpt$window
*copyc osc$processor_defined_registers
*copyc oss$mainframe_wired
*copyc oss$mainframe_wired_cb
*copyc syc$monitor_segment_numbers
?? POP ??
*copyc dpp$process_monitor_command
*copyc dsp$mtr_get_ssr_data_seq_ptr
*copyc i#mtr_disable_traps
*copyc i#real_memory_address
*copyc i#mtr_restore_traps
*copyc i#test_set_bit
*copyc mtp$error_stop
*copyc mtp$get_date_time_at_timestamp
*copyc mtp$set_status_abnormal
*copyc tmp$check_ptl_lock
*copyc tmp$set_system_flag
?? EJECT ??
*copyc dpv$scd_block_p
*copyc dpv$scd_time
*copyc mtv$idle_message_line
*copyc mtv$nst_p
*copyc mtv$scb
*copyc osv$external_interrupt_selector
*copyc tmv$ptl_lock
*copyc tmv$system_job_monitor_gtid
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    t$console_row_map = RECORD
      window_id: dpt$window_id,
      row_p: ^dpt$console_line,
    RECEND,

    t$console_row_mapping = ARRAY [1 .. dpc$number_of_console_rows] OF t$console_row_map,

    t$echo_input_line = RECORD
      row_number: ALIGNED [0 MOD 8] dpt$number_of_console_rows,
      column_number: 0 .. 132,
      text_size: dpt$console_row_size,
      unused: dpt$console_row_size,
      next_line_rma: ost$real_memory_address,
      text: string (dpc$console_row_size),
    RECEND;
?? EJECT ??
  VAR
    dpv$180_operator_action: [XDCL, #GATE] boolean := FALSE,
    dpv$critical_display_id: [XDCL, #GATE] dpt$window_id := 0,
    dpv$critical_messages: [XDCL, STATIC, #GATE, oss$mainframe_wired] dpt$critical_messages :=
           [REP 15 OF [0, '']],
    dpv$critical_msgs_need_logging: [XDCL, STATIC, #GATE, oss$mainframe_wired] boolean := FALSE,
    dpv$enable_console_bell: [XDCL, #GATE] boolean := TRUE,
    dpv$enable_stop_key: [XDCL, #GATE] boolean := FALSE,
    dpv$lock: [XDCL] integer := 0,
    dpv$lock_main_window: [XDCL, #GATE] dpt$lock_main_window := [FALSE, 0],
    dpv$secure_input_line: [XDCL, #GATE] dpt$secure_input_line := [FALSE, 0],
    dpv$top_window_p: [XDCL, #GATE] ^dpt$window := NIL,

    syv$db_page_wait_lines_instance: [XDCL, #GATE] integer := 0,
    syv$debugger_display_id: [XDCL, #GATE] dpt$window_id := 0,
    syv$terminate_sysdebug_output: [XDCL, #GATE] boolean := FALSE,

    v$console_row_mapping: t$console_row_mapping := [REP dpc$number_of_console_rows OF [0, NIL]],
    v$deleted_windows_p: ^dpt$window := NIL,
    v$echo_input_request: dpt$ve_data_for_scd := [dpc$scd_echo_input, FALSE, 0, 0, 0],
    v$echo_input_line: [STATIC, oss$mainframe_wired_cb] t$echo_input_line := [30, 1, 0, 0, 0, ' '],
    v$end_of_queue_p: ^dpt$console_line := NIL,
    v$end_pause: integer := 0,
    v$expanded_window_p: ^dpt$window := NIL,
    v$expansions: integer := 0,
    v$last_scd_rma: ost$real_memory_address := 0,
    v$next_window_ordinal: dpt$window_id := 1,
    v$previous_scd_data_id: 0 .. 255 := 0,
    v$re_map_windows: boolean := FALSE,
    v$scd_queue_p: ^dpt$console_line := NIL,
    v$screen_ready: boolean := FALSE,
    v$start_of_queue_p: ^dpt$console_line := NIL;

?? OLDTITLE ??
?? NEWTITLE := 'clean_up_display_queue', EJECT ??

{ PURPOSE:
{   This procedure scans the SCD display queue removing all lines from the display queue that SCD has
{   processed.

  PROCEDURE clean_up_display_queue;

    VAR
      rma: ost$real_memory_address;

    { Retrieve the real memory word address of the last line SCD processed.

    rma := dpv$scd_block_p^.scd.current_data_rma MOD 80000000(16);

    IF v$last_scd_rma = rma THEN
      RETURN;
    IFEND;

    { Remove display lines from the queue that SCD has processed.

    WHILE v$scd_queue_p^.next_line_rma <> rma DO
      v$scd_queue_p^.next_line_rma := dpc$rma_scd_finished;
      v$scd_queue_p := v$scd_queue_p^.next_line_p;
    WHILEND;

    { Remove the last line that SCD processed.

    v$scd_queue_p^.next_line_rma := dpc$rma_scd_finished;
    v$scd_queue_p := v$scd_queue_p^.next_line_p;

    { Save the last real memory word address if the queue was not empty.

    IF v$scd_queue_p <> NIL THEN
      v$last_scd_rma := rma;
    ELSE
      v$last_scd_rma := 0;
    IFEND;

  PROCEND clean_up_display_queue;
?? OLDTITLE ??
?? NEWTITLE := 'configure_console', EJECT ??

{  PURPOSE:
{    This procedure initializes the SCI parameter table so that NOS/VE and SCI can communicate.

  PROCEDURE configure_console;

    VAR
      console_block_p: ^dpt$console_parameter_block,
      rma: integer,
      scipt_seq_p: ^SEQ ( * );

    { The SCI parameter table is pointed to by word D7RS+2 in the EICB.

    { Set the pointer to the SCI parameter table which is pointed to by word D7RS+2 in the EICB or it is the
    { SSR.  A bit in D7RS tells NOS/VE where the parameter table is located.

    IF mtv$nst_p^.d7rs2.scipt_in_the_ssr THEN
      dsp$mtr_get_ssr_data_seq_ptr (dsc$ssr_sci_parameter_table, scipt_seq_p);
      console_block_p := #ADDRESS (1, #SEGMENT (scipt_seq_p), #OFFSET (scipt_seq_p));
    ELSE
      console_block_p := #ADDRESS (1, syc$msn_cyber_170_cache_bypass, mtv$nst_p^.d7rs2.sci_table * 8);
    IFEND;

    i#real_memory_address (^mtv$idle_message_line, rma);
    dpv$scd_block_p^.top_line_message_rma := rma DIV 8;

    i#real_memory_address (dpv$scd_block_p, rma);

    { Interlock the SCI parameter table.

    set_sci_interlock (console_block_p);
    console_block_p^.primary_ve_interface.ve_parameter_block := rma DIV 8;
    console_block_p^.primary_ve_interface.interrupt_selector := osv$external_interrupt_selector;
    console_block_p^.scd_console.nos_ve_active := TRUE;
    console_block_p^.scd_console.console_active := TRUE;
    console_block_p^.scd_definition_changed := TRUE;
    console_block_p^.interlocked := FALSE;

  PROCEND configure_console;
?? OLDTITLE ??
?? NEWTITLE := 'map_windows_onto_console', EJECT ??

{ PURPOSE:
{   This procedure maps the current open windows onto the system console screen.
{
{ DESIGN:
{   There are more lines in all of the windows than will probably fit on the screen.  The screen is painted
{   from the top window to the last window putting the defined number of lines in each window.  Pre-emptive
{   windows can reduce the number of lines in other display windows because as the name suggests they pre-empt
{   other windows.  Only one pre-emptive window is displayed.  The title line, from the other pre-emptive
{   windows, is the only line displayed from those windows.

  PROCEDURE map_windows_onto_console;

    VAR
      display_interactive_line: boolean,
      ending_console_row_number: dpt$number_of_console_rows,
      ending_row: dpt$number_of_console_rows,
      interactive_window_count: dpt$window_id,
      line_index: dpt$number_of_window_lines,
      lines_not_displayed: dpt$number_of_console_rows,
      next_available_row: dpt$number_of_console_rows,
      number_of_extra_rows: dpt$number_of_console_rows,
      number_of_required_rows: integer,
      pre_emptive_window_exists: boolean,
      row_index: dpt$number_of_console_rows,
      rows_available: boolean,
      rows_for_pre_empt: dpt$number_of_console_rows,
      rows_for_sharing_window: dpt$number_of_console_rows,
      rows_needed_for_expand: dpt$number_of_console_rows,
      sharing_window_count: dpt$window_id,
      starting_row: dpt$number_of_console_rows,
      temp_ending_row: integer,
      window_line_number: dpt$number_of_window_lines,
      window_p: ^dpt$window;

    { Abort any output that SCD is in the process of printing on the console.  Since the screen is about to
    { be repainted and the information is saved in the window descriptors, this output can be aborted.

    clean_up_display_queue;
    IF v$scd_queue_p <> NIL THEN
      dpv$scd_block_p^.ve.command := dpc$scd_abort_output;
    IFEND;
    v$last_scd_rma := 0;
    v$start_of_queue_p := NIL;
    v$end_of_queue_p := NIL;
    v$scd_queue_p := NIL;

    { Determine how many shared and interactive windows exist and determine if a pre-emptive window exists.

    pre_emptive_window_exists := FALSE;
    interactive_window_count := 0;
    sharing_window_count := 0;
    window_p := dpv$top_window_p;
    WHILE window_p <> NIL DO
      IF window_p^.class = dpc$wc_sharing THEN
        sharing_window_count := sharing_window_count + 1;
        IF window_p^.kind = dpc$wk_interactive THEN
          interactive_window_count := interactive_window_count + 1;
        IFEND;
      IFEND;
      pre_emptive_window_exists := pre_emptive_window_exists OR (window_p^.class = dpc$wc_pre_empt);
      window_p := window_p^.next_window_p;
    WHILEND;

    { Determine the number of extra rows available that will be spread among the 'shared' windows.

    number_of_required_rows := sharing_window_count + (interactive_window_count * 3) + 1;
    IF number_of_required_rows > dpc$number_of_console_rows THEN
      number_of_extra_rows := 0;
    ELSE
      number_of_extra_rows := dpc$number_of_console_rows - number_of_required_rows;
    IFEND;
    IF pre_emptive_window_exists THEN
      IF number_of_extra_rows = 0 THEN
        rows_for_pre_empt := 0;
      ELSE
        IF number_of_extra_rows < 10 THEN
          rows_for_pre_empt := number_of_extra_rows - 1;
          number_of_extra_rows := 0;
        ELSE
          rows_for_pre_empt := 9;
          number_of_extra_rows := number_of_extra_rows - 10;
        IFEND;
      IFEND;
    ELSE
      rows_for_pre_empt := 0;
    IFEND;

    { Determine how many rows are needed for the expanded window, if one exists.

    IF (v$expanded_window_p <> NIL) AND (v$expanded_window_p^.class = dpc$wc_sharing) THEN
      IF (v$expansions * 5) > number_of_extra_rows THEN
        rows_needed_for_expand := number_of_extra_rows;
      ELSE
        rows_needed_for_expand := v$expansions * 5;
      IFEND;
      number_of_extra_rows := number_of_extra_rows - rows_needed_for_expand;
    ELSE
      rows_needed_for_expand := 0;
      v$expansions := 0;
      v$expanded_window_p := NIL;
    IFEND;

    { Determine the number of rows each sharing window will receive.

    IF sharing_window_count > interactive_window_count THEN
      rows_for_sharing_window := number_of_extra_rows DIV (sharing_window_count - interactive_window_count);
    ELSE
      rows_for_sharing_window := 0;
    IFEND;

    { Allocate the console rows for each window and set up an array with the window identifier and row
    { pointer for each line.  As each line is added to the screen it is added to the queue that SCD will
    { display.

    window_p := dpv$top_window_p;
    v$console_row_mapping [1].window_id := window_p^.window_id;
    v$console_row_mapping [1].row_p := ^window_p^.title;
    next_available_row := 2;

  /main_loop/
    WHILE window_p <> NIL DO
      IF window_p^.class = dpc$wc_invisible THEN
        window_p^.starting_console_row_number := 0;
        window_p^.ending_console_row_number := 0;
        FOR line_index := 1 TO dpc$number_of_window_lines DO
          window_p^.lines [line_index].starting_console_row_number := 0;
          window_p^.lines [line_index].ending_console_row_number := 0;
          window_p^.lines [line_index].next_line_rma := dpc$rma_scd_finished;
        FOREND;
        window_p := window_p^.next_window_p;
        CYCLE /main_loop/;
      IFEND;

      rows_available := (next_available_row < dpc$number_of_console_rows);

      IF rows_available THEN

        { Determine the starting row and the ending row for the window.

        starting_row := next_available_row;
        display_interactive_line := TRUE;

        IF window_p^.class = dpc$wc_sharing THEN
          window_p^.title.text_kind := dpc$tk_title;
          IF window_p^.kind = dpc$wk_interactive THEN
            temp_ending_row := starting_row + 3;
          ELSE
            temp_ending_row := starting_row + rows_for_sharing_window;
          IFEND;
        ELSE { window_p^.class = dpc$wc_pre_empt }
          IF pre_emptive_window_exists THEN
            window_p^.title.text_kind := dpc$tk_flashing_title;
            temp_ending_row := starting_row + rows_for_pre_empt;
            pre_emptive_window_exists := FALSE;
          ELSE { Display only title line on subsequent preemptive windows. }
            window_p^.title.text_kind := dpc$tk_flashing_title;
            temp_ending_row := starting_row;
            display_interactive_line := FALSE;
          IFEND;
        IFEND;

        IF v$expanded_window_p = window_p THEN
          temp_ending_row := temp_ending_row + rows_needed_for_expand;
        IFEND;

        IF (window_p^.next_window_p = NIL) OR (temp_ending_row >= dpc$number_of_console_rows) THEN
          ending_row := dpc$number_of_console_rows;
          next_available_row := ending_row;
        ELSE
          ending_row := temp_ending_row;
          next_available_row := ending_row + 1;
        IFEND;

        { Associate the window id with each row for the window.

        FOR row_index := starting_row TO ending_row DO
          v$console_row_mapping [row_index].window_id := window_p^.window_id;
        FOREND;

        { Setup the title for the window.

        window_p^.title.starting_console_row_number := 0;
        window_p^.title.ending_console_row_number := starting_row;
        v$console_row_mapping [starting_row].row_p := ^window_p^.title;
        queue_line (window_p^.title);
        starting_row := starting_row + 1;

        { Set the input line as the last line in the interactive window.

        IF (window_p^.kind = dpc$wk_interactive) AND display_interactive_line THEN
          window_p^.input_line.starting_console_row_number := 0;
          window_p^.input_line.ending_console_row_number := ending_row;
          v$console_row_mapping [ending_row].row_p := ^window_p^.input_line;
          queue_line (window_p^.input_line);
          ending_row := ending_row - 1;
        IFEND;

        window_p^.starting_console_row_number := starting_row;
        window_p^.ending_console_row_number := ending_row;

        { If necessary, readjust the number of lines in a displayed page for the System Core Debugger.

        IF window_p^.window_id = syv$debugger_display_id THEN
          syv$db_page_wait_lines_instance := ending_row - starting_row;
        IFEND;

        { Set the number of lines in the window that are not being displayed.

        lines_not_displayed := starting_row - ending_row + dpc$number_of_console_rows - 1;

        IF (window_p^.kind = dpc$wk_table) OR (starting_row > ending_row) THEN
          ending_console_row_number := 0;
          window_line_number := 1;
        ELSE { Set the present window line to allow for scrolling. }
          ending_console_row_number := ending_row;
          window_line_number := (window_p^.present_window_line_number + lines_not_displayed) MOD
                dpc$number_of_window_lines + 1;
        IFEND;

        { Add lines to the current queue of lines being displayed.

        FOR row_index := starting_row TO ending_row DO
          window_p^.lines [window_line_number].starting_console_row_number := 0;
          window_p^.lines [window_line_number].ending_console_row_number := row_index;
          v$console_row_mapping [row_index].row_p := ^window_p^.lines [window_line_number];
          queue_line (window_p^.lines [window_line_number]);
          window_line_number := window_line_number MOD dpc$number_of_window_lines + 1;
        FOREND;

      ELSE
        lines_not_displayed := dpc$number_of_console_rows;
        ending_console_row_number := 0;
        window_line_number := 1;
      IFEND;

      { Reset lines in window that are not being displayed.

      FOR row_index := 1 TO lines_not_displayed DO
        window_p^.lines [window_line_number].starting_console_row_number := 0;
        window_p^.lines [window_line_number].ending_console_row_number := ending_console_row_number;
        window_p^.lines [window_line_number].next_line_rma := dpc$rma_scd_finished;
        window_line_number := window_line_number MOD dpc$number_of_window_lines + 1;
      FOREND;

      window_p := window_p^.next_window_p;
    WHILEND /main_loop/;

    { Remove the deleted windows from the active window queue.

    WHILE v$deleted_windows_p <> NIL DO
      window_p := v$deleted_windows_p;
      v$deleted_windows_p := window_p^.next_window_p;
      window_p^.window_id := 0;
    WHILEND;

    v$screen_ready := TRUE;

  PROCEND map_windows_onto_console;
?? OLDTITLE ??
?? NEWTITLE := 'move_window', EJECT ??

{ PURPOSE:
{   Move the specified window to the window following the top window.

  PROCEDURE move_window
    (VAR window_to_move_p: ^dpt$window);

    VAR
      search_window_p: ^dpt$window;

    IF dpv$top_window_p = window_to_move_p THEN
      RETURN;
    IFEND;

    search_window_p := dpv$top_window_p;
    WHILE search_window_p^.next_window_p <> window_to_move_p DO
      search_window_p := search_window_p^.next_window_p;
    WHILEND;

    search_window_p^.next_window_p := window_to_move_p^.next_window_p;
    window_to_move_p^.next_window_p := dpv$top_window_p^.next_window_p;
    dpv$top_window_p^.next_window_p := window_to_move_p;

  PROCEND move_window;
?? OLDTITLE ??
?? NEWTITLE := 'process_keyboard_input', EJECT ??

{ PURPOSE:
{   This procedure processes the keyboard input from SCD.

  PROCEDURE process_keyboard_input
    (    character: 0 .. 255;
     VAR character_processed: boolean);

    CONST

      { Codes:  00(16) - 1F(16) are ASCII control characters.

      c$acc_bell = 07(16),
      c$acc_cursor_left = 08(16),
      c$acc_tab = 09(16),
      c$acc_line_feed = 0A(16),
      c$acc_clear_eol = 0B(16),
      c$acc_clear_page = 0C(16),
      c$acc_carriage_return = 0D(16),
      c$acc_cursor_up = 17(16),
      c$acc_cursor_right = 18(16),
      c$acc_home = 19(16),
      c$acc_cursor_down = 1A(16),
      c$acc_erase = 1F(16),

      { Codes:  20(16) - 7f(16) are ASCII characters.

      { Codes:  80(16) - 0FF(16) are special Function keys.  All of the special functions key codes actually
      { contain several HEX codes.  The first code is always 1E(16).  Instead of having SCD send all of the
      { codes it sends only the last code with the leftmost bit set indicating that it is a multi code
      { function key.  Example:  Back Key = 1E(16) & 5F(16).  SCD sends 0DF(16).

      c$key_print = 082(16),
      c$key_down = 0A0(16),
      c$key_up = 0A4(16),
      c$key_fwd = 0A8(16),
      c$key_bkw = 0AC(16),
      c$key_stop = 0C9(16),
      c$key_back = 0DF(16),
      c$key_shifted_super = 0E9(16),
      c$key_f4 = 0F4(16),
      c$key_super = 0F9(16),
      c$key_sub = 0FA(16),

      c$cursor_bias = 31,
      c$scd_position_cursor = 2;

    VAR
      ignore_status: syt$monitor_status,
      line_p: ^dpt$console_line,
      lines_in_window: dpt$number_of_window_lines,
      next_console_row: dpt$number_of_console_rows,
      ptl_interlocked: boolean,
      save_next_console_row: dpt$number_of_console_rows,
      table_starting_line: integer,
      window_id: dpt$window_id,
      window_p: ^dpt$window;

    character_processed := TRUE;

    { Determine if the screen is ready for input, if not sound the bell.

    IF NOT v$screen_ready THEN
      v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$acc_bell);
      v$echo_input_line.text_size := v$echo_input_line.text_size + 1;
      RETURN;
    IFEND;

    { Retrieve the window id of the input line and retrieve the input line itself.

    window_id := v$console_row_mapping [v$echo_input_line.row_number].window_id;
    line_p := v$console_row_mapping [v$echo_input_line.row_number].row_p;

    { Inform SCD to hold the display until all input is received.

    IF NOT v$echo_input_request.hold_display_for_input THEN
      v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$scd_position_cursor);
      v$echo_input_line.text (v$echo_input_line.text_size + 2) :=
            $CHAR (v$echo_input_line.column_number + c$cursor_bias);
      v$echo_input_line.text (v$echo_input_line.text_size + 3) :=
            $CHAR (v$echo_input_line.row_number + c$cursor_bias);
      v$echo_input_line.text_size := v$echo_input_line.text_size + 3;
      v$echo_input_request.hold_display_for_input := TRUE;
    IFEND;

    { Process any ASCII keyboard input (ASCII characters) and echo back the character to the console.

    IF (character >= 20(16)) AND (character <= 7F(16)) THEN
      IF dpv$lock_main_window.lock AND (dpv$lock_main_window.window_id = window_id) THEN
        v$echo_input_request.hold_display_for_input := FALSE;
        RETURN;
      IFEND;
      IF (line_p^.text_kind <> dpc$tk_input) OR
            (v$echo_input_line.column_number >= (dpc$console_row_size - 1)) THEN
        v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$acc_bell);
      ELSE
        line_p^.text (v$echo_input_line.column_number) := $CHAR (character);
        IF line_p^.text_size < v$echo_input_line.column_number THEN
          line_p^.text_size := v$echo_input_line.column_number;
        IFEND;
        v$echo_input_line.column_number := v$echo_input_line.column_number + 1;
        IF dpv$secure_input_line.secure AND (dpv$secure_input_line.window_id = window_id) THEN
          v$echo_input_line.text (v$echo_input_line.text_size + 1) := ' ';
        ELSE
          v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (character);
        IFEND;
      IFEND;
      v$echo_input_line.text_size := v$echo_input_line.text_size + 1;
      RETURN;
    IFEND;

    { Find the window needed for the special function key.

    IF character > 80(16) THEN
      window_p := dpv$top_window_p;
      WHILE (window_p <> NIL) AND (window_p^.window_id <> window_id) DO
        window_p := window_p^.next_window_p;
      WHILEND;
      IF window_p = NIL THEN
        character_processed := FALSE;
        v$echo_input_request.hold_display_for_input := FALSE;
        RETURN;
      IFEND;
    IFEND;

    CASE character OF
    = c$acc_cursor_left =
      IF v$echo_input_line.column_number = 1 THEN
        v$echo_input_line.column_number := dpc$console_row_size;
        IF v$echo_input_line.row_number = 1 THEN
          v$echo_input_line.row_number := dpc$number_of_console_rows;
        ELSE
          v$echo_input_line.row_number := v$echo_input_line.row_number - 1;
        IFEND;
      ELSE
        v$echo_input_line.column_number := v$echo_input_line.column_number - 1;
      IFEND;
      v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$acc_cursor_left);
      v$echo_input_line.text_size := v$echo_input_line.text_size + 1;
      RETURN;

    = c$acc_tab =
      v$echo_input_line.column_number := 1;
      next_console_row := v$echo_input_line.row_number MOD dpc$number_of_console_rows + 1;
      save_next_console_row := next_console_row;
      window_id := v$console_row_mapping [next_console_row].window_id;
      REPEAT
        v$echo_input_line.row_number := next_console_row;
        next_console_row := next_console_row MOD dpc$number_of_console_rows + 1;
      UNTIL (v$console_row_mapping [next_console_row].window_id <> window_id) OR
            (next_console_row = save_next_console_row);
      v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$scd_position_cursor);
      v$echo_input_line.text (v$echo_input_line.text_size + 2) :=
            $CHAR (v$echo_input_line.column_number + c$cursor_bias);
      v$echo_input_line.text (v$echo_input_line.text_size + 3) :=
            $CHAR (v$echo_input_line.row_number + c$cursor_bias);
      v$echo_input_line.text_size := v$echo_input_line.text_size + 3;
      RETURN;

    = c$acc_clear_eol =
      IF (line_p^.text_kind = dpc$tk_input) OR (line_p^.text_kind = dpc$tk_input_ready) THEN
        line_p^.text_size := v$echo_input_line.column_number - 1;
        line_p^.text (v$echo_input_line.column_number, * ) := ' ';
        line_p^.text_kind := dpc$tk_input;
        v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$acc_clear_eol);
      ELSE
        v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$acc_bell);
      IFEND;
      v$echo_input_line.text_size := v$echo_input_line.text_size + 1;
      RETURN;

    = c$acc_clear_page =
      v$echo_input_line.text (1) := $CHAR (c$acc_clear_page);
      v$echo_input_line.text_size := 1;
      v$echo_input_request.hold_display_for_input := FALSE;
      v$re_map_windows := TRUE;
      RETURN;

    = c$acc_carriage_return =
      IF dpv$lock_main_window.lock AND (dpv$lock_main_window.window_id = window_id) THEN
        v$echo_input_request.hold_display_for_input := FALSE;
        RETURN;
      IFEND;
      v$echo_input_line.column_number := 1;
      IF line_p^.text_kind = dpc$tk_input THEN
        line_p^.text_kind := dpc$tk_input_ready;
        IF window_id = dpv$critical_display_id THEN
          dpp$process_monitor_command (line_p^.text (1, line_p^.text_size));
          line_p^.text_kind := dpc$tk_input;
          line_p^.text_size := 0;
          clean_up_display_queue;
          IF line_p^.next_line_rma = dpc$rma_scd_finished THEN
            queue_line (line_p^);
          IFEND;
        ELSE
          clean_up_display_queue;
          IF line_p^.next_line_rma = dpc$rma_scd_finished THEN
            IF NOT dpv$secure_input_line.secure OR (dpv$secure_input_line.window_id <> window_id) THEN
              queue_line (line_p^);
            IFEND;
          IFEND;
        IFEND;
      ELSE
        next_console_row := v$echo_input_line.row_number MOD dpc$number_of_console_rows + 1;
        v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$acc_carriage_return);
        v$echo_input_line.text_size := v$echo_input_line.text_size + 1;
        IF window_id = v$console_row_mapping [next_console_row].window_id THEN
          v$echo_input_line.row_number := next_console_row;
          v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$acc_line_feed);
          v$echo_input_line.text_size := v$echo_input_line.text_size + 1;
        IFEND;
      IFEND;
      v$echo_input_request.hold_display_for_input := FALSE;
      RETURN;

    = c$acc_cursor_up =
      IF v$echo_input_line.row_number = 1 THEN
        v$echo_input_line.row_number := dpc$number_of_console_rows;
      ELSE
        v$echo_input_line.row_number := v$echo_input_line.row_number - 1;
      IFEND;
      v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$acc_cursor_up);
      v$echo_input_line.text_size := v$echo_input_line.text_size + 1;
      RETURN;

    = c$acc_cursor_right =
      IF v$echo_input_line.column_number = dpc$console_row_size THEN
        v$echo_input_line.column_number := 1;
        v$echo_input_line.row_number := v$echo_input_line.row_number MOD dpc$number_of_console_rows + 1;
      ELSE
        v$echo_input_line.column_number := v$echo_input_line.column_number + 1;
      IFEND;
      v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$acc_cursor_right);
      v$echo_input_line.text_size := v$echo_input_line.text_size + 1;
      RETURN;

    = c$acc_home =
      v$echo_input_line.column_number := 1;
      v$echo_input_line.row_number := 1;
      v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$acc_home);
      v$echo_input_line.text_size := v$echo_input_line.text_size + 1;
      RETURN;

    = c$acc_cursor_down, c$acc_line_feed =
      v$echo_input_line.row_number := v$echo_input_line.row_number MOD dpc$number_of_console_rows + 1;
      v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (character);
      v$echo_input_line.text_size := v$echo_input_line.text_size + 1;
      RETURN;

    = c$acc_erase =
      IF (v$echo_input_line.column_number > 1) AND (line_p^.text_kind = dpc$tk_input) THEN
        v$echo_input_line.column_number := v$echo_input_line.column_number - 1;
        line_p^.text (v$echo_input_line.column_number) := ' ';
        IF line_p^.text_size < v$echo_input_line.column_number THEN
          line_p^.text_size := v$echo_input_line.column_number;
        IFEND;
        v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$acc_erase);
      ELSE
        v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$acc_bell);
      IFEND;
      v$echo_input_line.text_size := v$echo_input_line.text_size + 1;
      RETURN;

    = c$key_print =
      v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$scd_position_cursor);
      v$echo_input_line.text (v$echo_input_line.text_size + 2) := $CHAR (1 + c$cursor_bias);
      v$echo_input_line.text (v$echo_input_line.text_size + 3) := $CHAR (2 + c$cursor_bias);
      v$echo_input_line.text (v$echo_input_line.text_size + 4) := $CHAR (1e(16));
      v$echo_input_line.text (v$echo_input_line.text_size + 5) := $CHAR (2);
      v$echo_input_line.text_size := v$echo_input_line.text_size + 5;
      v$echo_input_request.hold_display_for_input := FALSE;
      RETURN;

    = c$key_down =
      IF window_p^.kind = dpc$wk_table THEN
        table_starting_line := window_p^.table_starting_line_in_window + v$echo_input_line.row_number -
              window_p^.ending_console_row_number;
        IF table_starting_line < 1 THEN
          table_starting_line := 1;
        ELSEIF table_starting_line > window_p^.table_last_line_used_in_window THEN
          table_starting_line := window_p^.table_last_line_used_in_window;
        IFEND;
        window_p^.table_starting_line_in_window := table_starting_line;
      ELSE
        v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$acc_bell);
        v$echo_input_line.text_size := v$echo_input_line.text_size + 1;
      IFEND;
      v$echo_input_request.hold_display_for_input := FALSE;
      RETURN;

    = c$key_up =
      IF window_p^.kind = dpc$wk_table THEN
        table_starting_line := window_p^.table_starting_line_in_window + v$echo_input_line.row_number -
              window_p^.starting_console_row_number;
        IF table_starting_line < 1 THEN
          table_starting_line := 1;
        ELSEIF table_starting_line > window_p^.table_last_line_used_in_window THEN
          table_starting_line := window_p^.table_last_line_used_in_window;
        IFEND;
        window_p^.table_starting_line_in_window := table_starting_line;
      ELSE
        v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$acc_bell);
        v$echo_input_line.text_size := v$echo_input_line.text_size + 1;
      IFEND;
      v$echo_input_request.hold_display_for_input := FALSE;
      RETURN;

    = c$key_fwd =
      IF window_p^.kind = dpc$wk_table THEN
        lines_in_window := window_p^.ending_console_row_number - window_p^.starting_console_row_number;
        table_starting_line := window_p^.table_starting_line_in_window + lines_in_window;
        IF table_starting_line > (window_p^.table_last_line_used_in_window - lines_in_window DIV 2) THEN
          table_starting_line := window_p^.table_last_line_used_in_window - lines_in_window DIV 2;
        IFEND;
        IF table_starting_line < 1 THEN
          table_starting_line := 1;
        ELSEIF table_starting_line > window_p^.table_last_line_used_in_window THEN
          table_starting_line := window_p^.table_last_line_used_in_window;
        IFEND;
        window_p^.table_starting_line_in_window := table_starting_line;
      ELSE
        v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$acc_bell);
        v$echo_input_line.text_size := v$echo_input_line.text_size + 1;
      IFEND;
      v$echo_input_request.hold_display_for_input := FALSE;
      RETURN;

    = c$key_bkw =
      IF window_p^.kind = dpc$wk_table THEN
        lines_in_window := window_p^.ending_console_row_number - window_p^.starting_console_row_number;
        table_starting_line := window_p^.table_starting_line_in_window - lines_in_window;
        IF table_starting_line < 1 THEN
          table_starting_line := 1;
        ELSEIF table_starting_line > window_p^.table_last_line_used_in_window THEN
          table_starting_line := window_p^.table_last_line_used_in_window;
        IFEND;
        window_p^.table_starting_line_in_window := table_starting_line;
      ELSE
        v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$acc_bell);
        v$echo_input_line.text_size := v$echo_input_line.text_size + 1;
      IFEND;
      v$echo_input_request.hold_display_for_input := FALSE;
      RETURN;

    = c$key_stop =
      IF dpv$enable_stop_key THEN

        { Set the system job monitor system flag to interrupt the current operator command.  The system
        { flag is not set if the dispatcher is in a state such that it can not set the system flag.

        IF window_id = syv$debugger_display_id THEN

          { Set a flag which is used by the debug procedure WRITE_OUTPUT_LINE.

          syv$terminate_sysdebug_output := TRUE;
        ELSE
          IF NOT dpv$lock_main_window.lock OR (dpv$lock_main_window.window_id <> window_id) THEN
            tmp$check_ptl_lock (ptl_interlocked);
            character_processed := NOT ptl_interlocked;
            IF NOT ptl_interlocked THEN
              tmp$set_system_flag (tmv$system_job_monitor_gtid, ofc$operator_break_flag, ignore_status);
            IFEND;
            IF NOT character_processed THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
      v$echo_input_request.hold_display_for_input := FALSE;
      RETURN;

    = c$key_back =
      window_p^.table_starting_line_in_window := 1;
      IF window_p = v$expanded_window_p THEN
        v$expanded_window_p := NIL;
        v$expansions := 0;
        v$re_map_windows := TRUE;
      IFEND;
      IF window_p^.true_class = dpc$wc_pre_empt THEN
        window_p^.class := dpc$wc_pre_empt;
        move_window (window_p);
        v$re_map_windows := TRUE;
      IFEND;
      v$echo_input_request.hold_display_for_input := FALSE;
      RETURN;

    = c$key_shifted_super =
      v$expanded_window_p := window_p;
      v$expansions := 6;
      window_p^.class := dpc$wc_sharing;
      v$re_map_windows := TRUE;
      v$echo_input_request.hold_display_for_input := FALSE;
      RETURN;

    = c$key_f4 =

      { If the F4 function key is typed, return the cursor to the input line of the main operator
      { display window, and simulate the typein of the following command:
      {       DISPLAY_OPERATOR_ACTION_STATUS WAIT=FALSE

      v$echo_input_line.column_number := 1;
      v$echo_input_line.row_number := dpc$number_of_console_rows;
      line_p := v$console_row_mapping [v$echo_input_line.row_number].row_p;
      line_p^.text_kind := dpc$tk_input_ready;
      line_p^.text := 'display_operator_action_status wait=false';
      line_p^.text_size := #SIZE (line_p^.text);
      clean_up_display_queue;
      IF line_p^.next_line_rma = dpc$rma_scd_finished THEN
        queue_line (line_p^);
      IFEND;
      v$echo_input_request.hold_display_for_input := FALSE;
      RETURN;

    = c$key_super =
      IF window_p = v$expanded_window_p THEN
        v$expansions := v$expansions + 1;
      ELSE
        v$expanded_window_p := window_p;
        IF window_p^.class = dpc$wc_pre_empt THEN
          v$expansions := 2;
        ELSE
          v$expansions := 1;
        IFEND;
      IFEND;
      window_p^.class := dpc$wc_sharing;
      v$re_map_windows := TRUE;
      v$echo_input_request.hold_display_for_input := FALSE;
      RETURN;

    = c$key_sub =
      window_p^.class := dpc$wc_sharing;
      IF window_p = v$expanded_window_p THEN
        v$expanded_window_p := NIL;
        v$expansions := 0;
      IFEND;
      v$re_map_windows := TRUE;
      v$echo_input_request.hold_display_for_input := FALSE;
      RETURN;

    ELSE { Unrecognized character, ring the bell.
      v$echo_input_line.text (v$echo_input_line.text_size + 1) := $CHAR (c$acc_bell);
      v$echo_input_line.text_size := v$echo_input_line.text_size + 1;
      RETURN;
    CASEND;

  PROCEND process_keyboard_input;
?? OLDTITLE ??
?? NEWTITLE := 'queue_line', EJECT ??

{ PURPOSE:
{   This procedure adds a line, to display, to the end of the current queue and updates the end of
{   queue pointers.

  PROCEDURE queue_line
    (VAR line: dpt$console_line);

    VAR
      rma: integer;

    line.next_line_p := NIL;
    line.next_line_rma := dpc$rma_end_of_list;

    IF v$start_of_queue_p = NIL THEN
      v$start_of_queue_p := ^line;
    ELSE
      v$end_of_queue_p^.next_line_p := ^line;
      i#real_memory_address (#LOC (line), rma);
      v$end_of_queue_p^.next_line_rma := rma DIV 8;
    IFEND;

    v$end_of_queue_p := ^line;

  PROCEND queue_line;
?? OLDTITLE ??
?? NEWTITLE := 'set_console_bell_status', EJECT ??

{ PURPOSE:
{   This procedure sets the console bell status in the SCI parameter table from the system attribute.

  PROCEDURE set_console_bell_status;

    VAR
      console_block_p: ^dpt$console_parameter_block,
      scipt_seq_p: ^SEQ ( * );

    { Set the pointer to the SCI parameter table which is pointed to by word D7RS+2 in the EICB or it is the
    { SSR.  A bit in D7RS tells NOS/VE where the parameter table is located.

    IF mtv$nst_p^.d7rs2.scipt_in_the_ssr THEN
      dsp$mtr_get_ssr_data_seq_ptr (dsc$ssr_sci_parameter_table, scipt_seq_p);
      console_block_p := #ADDRESS (1, #SEGMENT (scipt_seq_p), #OFFSET (scipt_seq_p));
    ELSE
      console_block_p := #ADDRESS (1, syc$msn_cyber_170_cache_bypass, mtv$nst_p^.d7rs2.sci_table * 8);
    IFEND;

    { Interlock the SCI parameter table and set the console bell status.

    set_sci_interlock (console_block_p);
    console_block_p^.scd_console.console_bell := dpv$enable_console_bell;
    console_block_p^.interlocked := FALSE;

  PROCEND set_console_bell_status;
?? OLDTITLE ??
?? NEWTITLE := 'set_sci_interlock', EJECT ??

{ PURPOSE:
{   This procedure sets the interlock to the SCI parameter table.  The caller is responsible for clearing
{   the interlock.

  PROCEDURE set_sci_interlock
    (VAR console_block_p: ^dpt$console_parameter_block);

    CONST
      c$fifteen_milleseconds = 15000;

    VAR
      endtime: ost$free_running_clock,
      previously_set: boolean;

    endtime := #FREE_RUNNING_CLOCK(0) + c$fifteen_milleseconds;
    REPEAT
      i#test_set_bit (^console_block_p^, dpc$sci_table_interlock_bit, previously_set);
      IF NOT previously_set THEN
        RETURN;
      IFEND;
    UNTIL #FREE_RUNNING_CLOCK(0) > endtime;
    mtp$error_stop ('*ERROR* SCI parameter table interlock unavailable.');

  PROCEND set_sci_interlock;
?? OLDTITLE ??
?? NEWTITLE := 'update_critical_messages', EJECT ??

{ PURPOSE:
{   This procedure updates the critical message variable so the message can be logged in the critical log.

  PROCEDURE update_critical_messages (
    message: string(*);
    size: integer);

    VAR
      msg_index: 1..16,
      prev_msg_index: 1..16;

    msg_index := 1;
    While (msg_index < 16) AND (dpv$critical_messages [msg_index].size <> 0) DO
      msg_index := msg_index + 1;
    WHILEND;
    IF msg_index < 16 THEN
      dpv$critical_messages [msg_index].value := message;
      dpv$critical_messages [msg_index].size := size;
    ELSE
      msg_index := 2;
      prev_msg_index := 1;
      WHILE msg_index < 16 DO
        dpv$critical_messages [prev_msg_index].value := dpv$critical_messages [msg_index].value;
        dpv$critical_messages [prev_msg_index].size := dpv$critical_messages [msg_index].size;
        msg_index := msg_index + 1;
        prev_msg_index := prev_msg_index + 1;
      WHILEND;
      dpv$critical_messages [15].value := message;
      dpv$critical_messages [15].size := size;
    IFEND;
    dpv$critical_msgs_need_logging := TRUE;
  PROCEND update_critical_messages;
?? OLDTITLE ??
?? NEWTITLE := 'dpp$change_sci_interrupt_port', EJECT ??

{  PURPOSE:
{    Set the new interrupt port into the SCI parameter table.

  PROCEDURE [XDCL] dpp$change_sci_interrupt_port;

    VAR
      console_block_p: ^dpt$console_parameter_block,
      scipt_seq_p: ^SEQ ( * );

    { Set the pointer to the SCI parameter table which is pointed to by word D7RS+2 in the EICB or it is the
    { SSR.  A bit in D7RS tells NOS/VE where the parameter table is located.

    IF mtv$nst_p^.d7rs2.scipt_in_the_ssr THEN
      dsp$mtr_get_ssr_data_seq_ptr (dsc$ssr_sci_parameter_table, scipt_seq_p);
      console_block_p := #ADDRESS (1, #SEGMENT (scipt_seq_p), #OFFSET (scipt_seq_p));
    ELSE
      console_block_p := #ADDRESS (1, syc$msn_cyber_170_cache_bypass, mtv$nst_p^.d7rs2.sci_table * 8);
    IFEND;

    { Change the interrupt port in the SCI parameter table.

    set_sci_interlock (console_block_p);
    console_block_p^.primary_ve_interface.interrupt_selector := osv$external_interrupt_selector;
    console_block_p^.interlocked := FALSE;

  PROCEND dpp$change_sci_interrupt_port;
?? OLDTITLE ??
?? NEWTITLE := 'dpp$display_error', EJECT ??

*copyc dph$display_error

  PROCEDURE [XDCL] dpp$display_error
    (    message: string ( * <= osc$max_string_size));

    VAR
      actual: integer,
      actual_line_size: 0 .. dpc$console_row_size,
      date_time: ost$date_time,
      date_time_string: dpt$critical_window_date_time,
      id: integer,
      line: string (osc$max_string_size),
      line_index: integer,
      line_p: ^dpt$console_line,
      line_size: 0 .. osc$max_string_size,
      result: 0 .. 2;

    IF dpv$secure_input_line.secure THEN
      RETURN;
    IFEND;

    { Retrieve the date/time to be issued with the message.  The date and time is prefixed to the incoming
    { string.  The time is displayed in the HH:MM:SS format and the date is displayed in the MM/DD/YY format.

    mtv$scb.critical_message_time_stamp := #FREE_RUNNING_CLOCK (0);
    mtp$get_date_time_at_timestamp (mtv$scb.critical_message_time_stamp, date_time);
    date_time_string.string_part := ' ';
    date_time_string.hour (2) := CHR ((date_time.hour MOD 10) + ORD ('0'));
    date_time_string.hour (1) := CHR ((date_time.hour DIV 10) + ORD ('0'));
    date_time_string.colon_1 := ':';
    date_time_string.minute (2) := CHR ((date_time.minute MOD 10) + ORD ('0'));
    date_time_string.minute (1) := CHR ((date_time.minute DIV 10) + ORD ('0'));
    date_time_string.colon_2 := ':';
    date_time_string.second (2) := CHR ((date_time.second MOD 10) + ORD ('0'));
    date_time_string.second (1) := CHR ((date_time.second DIV 10) + ORD ('0'));
    date_time_string.month (2) := CHR ((date_time.month MOD 10) + ORD ('0'));
    date_time_string.month (1) := CHR ((date_time.month DIV 10) + ORD ('0'));
    date_time_string.slash_1 := '/';
    date_time_string.day (2) := CHR ((date_time.day MOD 10) + ORD ('0'));
    date_time_string.day (1) := CHR ((date_time.day DIV 10) + ORD ('0'));
    date_time_string.slash_2 := '/';
    date_time_string.year (2) := CHR ((date_time.year MOD 10) + ORD ('0'));
    date_time_string.year (1) := CHR (((date_time.year MOD 100) DIV 10) + ORD ('0'));
    id := #READ_REGISTER (osc$pr_base_constant);
    actual := 0;
    REPEAT
      #COMPARE_SWAP (dpv$lock, 0, id, actual, result);
    UNTIL (result = 0) OR (actual = id);

    IF (#SIZE (message) = 0) OR (message = ' ') THEN
      line := ' ';
      line_size := 1;
    ELSE

     /trim_message/
      FOR line_index := #SIZE (message) DOWNTO 1 DO
        IF message (line_index) <> ' ' THEN
          line_size := line_index;
          line := message (1, line_size);
          EXIT /trim_message/;
        IFEND;
      FOREND /trim_message/;
    IFEND;

    line_index := 1;
    WHILE line_size > 0 DO
      IF line_size > dpc$critical_window_msg_size THEN
        actual_line_size := dpc$critical_window_msg_size;
        line_size := line_size - dpc$critical_window_msg_size;
      ELSE
        actual_line_size := line_size;
        line_size := 0;
      IFEND;

      dpv$top_window_p^.present_window_line_number :=
            dpv$top_window_p^.present_window_line_number MOD dpc$number_of_console_rows + 1;
      line_p := ^dpv$top_window_p^.lines [dpv$top_window_p^.present_window_line_number];
      line_p^.text := ' ';
      line_p^.text (1, dpc$date_time_size):= date_time_string.string_part;
      line_p^.text ((dpc$date_time_size + 1), *):= line (line_index, actual_line_size);
      line_index := line_index + actual_line_size;

      line_p^.text_size := dpc$date_time_size + actual_line_size;

      IF dpv$scd_block_p^.ve.command = dpc$scd_no_command THEN
        clean_up_display_queue;
      IFEND;

      IF line_p^.next_line_rma = dpc$rma_scd_finished THEN
        line_p^.starting_console_row_number := dpv$top_window_p^.starting_console_row_number;
        line_p^.ending_console_row_number := dpv$top_window_p^.ending_console_row_number;
        queue_line (line_p^);
        update_critical_messages (line_p^.text, line_p^.text_size);
      IFEND;
    WHILEND;

    IF result = 0 THEN
      REPEAT
        #COMPARE_SWAP (dpv$lock, id, 0, actual, result);
      UNTIL result < 2;
      dpp$process_scd_block;
    IFEND;

  PROCEND dpp$display_error;
?? OLDTITLE ??
?? NEWTITLE := 'dpp$display_request', EJECT ??

{ PURPOSE:
{   This procedure is the monitor procedure that is called from system core to request changes to
{   the displays.

  PROCEDURE [XDCL] dpp$display_request
    (VAR rb: dpt$rb_display_request);

    VAR
      actual: integer,
      id: integer,
      index: dpt$number_of_window_lines,
      result: 0 .. 2,
      search_window_p: ^dpt$window,
      work_to_be_done: boolean;

    rb.status.normal := TRUE;
    id := #READ_REGISTER (osc$pr_base_constant);
    REPEAT
      #COMPARE_SWAP (dpv$lock, 0, id, actual, result);
    UNTIL result = 0;
    work_to_be_done := FALSE;

    CASE rb.action OF
    = dpc$da_configure_console =
      configure_console;

    = dpc$da_queue_line =
      IF (rb.line_p^.ending_console_row_number <> 0) AND
            (rb.line_p^.next_line_rma = dpc$rma_scd_finished) THEN
        IF (rb.line_p^.text_kind = dpc$tk_display) AND (rb.window_p^.kind <> dpc$wk_table) THEN
          rb.line_p^.starting_console_row_number := rb.window_p^.starting_console_row_number;
          rb.line_p^.ending_console_row_number := rb.window_p^.ending_console_row_number;
        IFEND;
        queue_line (rb.line_p^);
        work_to_be_done := TRUE;
      IFEND;

    = dpc$da_add_window =
      rb.window_p^.window_id := v$next_window_ordinal;
      v$next_window_ordinal := v$next_window_ordinal + 1;
      IF dpv$top_window_p = NIL THEN
        rb.window_p^.next_window_p := NIL;
        dpv$top_window_p := rb.window_p;
      ELSE
        rb.window_p^.next_window_p := dpv$top_window_p^.next_window_p;
        dpv$top_window_p^.next_window_p := rb.window_p;
      IFEND;
      v$re_map_windows := TRUE;

    = dpc$da_delete_window =
      IF rb.window_p = dpv$top_window_p THEN
        dpv$top_window_p := rb.window_p^.next_window_p;
      ELSE
        search_window_p := dpv$top_window_p;
        WHILE search_window_p^.next_window_p <> rb.window_p DO
          search_window_p := search_window_p^.next_window_p;
        WHILEND;
        search_window_p^.next_window_p := rb.window_p^.next_window_p;
      IFEND;
      IF rb.window_p = v$expanded_window_p THEN
        v$expanded_window_p := NIL;
      IFEND;
      rb.window_p^.next_window_p := v$deleted_windows_p;
      v$deleted_windows_p := rb.window_p;
      v$re_map_windows := TRUE;

    = dpc$da_clear_window =
      FOR index := 1 TO dpc$number_of_window_lines DO
        rb.window_p^.lines [index].text := '  ';
        rb.window_p^.lines [index].text_size := 0;
      FOREND;
      v$re_map_windows := TRUE;

    = dpc$da_change_window =
      IF rb.window_p^.class = dpc$wc_pre_empt THEN
        move_window (rb.window_p);
      IFEND;
      v$re_map_windows := TRUE;

    = dpc$da_set_console_bell_status =
      set_console_bell_status;

    = dpc$da_check_scd_status =
      REPEAT

        { This code is only executed at the end of the BOOT, before transferring control to system core.

        { Wait for SCD to display all of the lines in the display queue.  It is very unlikely that this code
        { would ever have to wait.  This loop has been placed here in case something does happen to SCI and
        { it is unable to process its display queue.  If this case occurs, the system should not continue.
        { The first bit of the field is used by the interrupt handlers to call the display routines when
        { changes occur.  This bit may or may not be set so it is ignored here.

        #SPOIL (dpv$scd_block_p^.scd.current_data_rma);

      UNTIL (dpv$scd_block_p^.scd.current_data_rma MOD 80000000(16)) = 0;

    ELSE
      mtp$set_status_abnormal (dpc$display_processor_id, dpe$invalid_console_monitor_req, rb.status);
    CASEND;

    REPEAT
      #COMPARE_SWAP (dpv$lock, id, 0, actual, result);
    UNTIL result < 2;

    IF work_to_be_done OR v$re_map_windows THEN
      dpp$process_scd_block;
    IFEND;

  PROCEND dpp$display_request;
?? OLDTITLE ??
?? NEWTITLE := 'dpp$process_scd_block', EJECT ??

{ PURPOSE:
{   This procedure processes the system console driver (SCD) communication block.  This procedure is called
{   to process SCD external interrupts and on a periodic basis is called from the normal monitor loop.
{
{ NOTE:
{   This procedure can be called from the monitor interrupt handler which means that an interruptable monitor
{   process may have been interrupted.  Exercise caution when calling procedures outside of this module as
{   they may not be in a state to handle the request properly, this is especially true if the procedure
{   called is from the interrupted process.

  PROCEDURE [XDCL] dpp$process_scd_block;

    VAR
      actual: integer,
      id: integer,
      index: 1 .. 3,
      character_processed: boolean,
      old_traps: 0 .. 3,
      result: 0 .. 2,
      rma: integer,
      scd_data_for_ve: dpt$scd_data_for_ve,
      work_to_be_done: boolean;

    { Disable traps, this process can not be interrupted.

    i#mtr_disable_traps (old_traps);

    REPEAT
      id := #READ_REGISTER (osc$pr_base_constant);
      actual := 0;
      REPEAT
        #COMPARE_SWAP (dpv$lock, 0, id, actual, result);
      UNTIL result < 2;

      IF result = 1 THEN
        i#mtr_restore_traps (old_traps);
        RETURN;
      IFEND;

      work_to_be_done := FALSE;

      IF dpv$scd_block_p^.ve.command = dpc$scd_no_command THEN

        IF dpv$scd_block_p^.scd.id <> v$previous_scd_data_id THEN

          { Process the keyboard input from SCD.

          i#real_memory_address (#LOC (v$echo_input_line), rma);
          v$echo_input_request.console_data_rma := rma DIV 8;

          scd_data_for_ve := dpv$scd_block_p^.scd;
          v$echo_input_line.next_line_rma := dpc$rma_end_of_list;
          v$echo_input_line.text_size := 0;

        /process_console_input/
          FOR index := 1 TO 3 DO
            IF scd_data_for_ve.input_buffer [index] <> 0 THEN
              process_keyboard_input (scd_data_for_ve.input_buffer [index], character_processed);
              IF NOT character_processed THEN
                EXIT /process_console_input/;
              IFEND;
            IFEND;
          FOREND /process_console_input/;

          IF character_processed THEN

            { Save a copy of the processed data to keep track of what was processed this pass and check if
            { anything to process next pass.

            v$previous_scd_data_id := scd_data_for_ve.id;

            { Echo the processed characters to keyboard and set time for next periodic call.

            dpv$scd_block_p^.ve := v$echo_input_request;
            v$end_pause := #FREE_RUNNING_CLOCK (0) + 10 * 1000000;
          IFEND;

        ELSEIF v$echo_input_request.hold_display_for_input THEN
          IF v$end_pause < #FREE_RUNNING_CLOCK (0) THEN
            v$echo_input_request.hold_display_for_input := FALSE;
            dpv$scd_block_p^.ve.command := dpc$scd_resume_output;
          IFEND;

        ELSEIF v$re_map_windows THEN
          map_windows_onto_console;
          v$re_map_windows := FALSE;
          work_to_be_done := TRUE;

        ELSE
          clean_up_display_queue;
          IF (v$scd_queue_p = NIL) AND (v$start_of_queue_p <> NIL) THEN
            v$scd_queue_p := v$start_of_queue_p;
            v$start_of_queue_p := NIL;
            v$end_of_queue_p^.next_line_p := NIL;
            v$end_of_queue_p^.next_line_rma := dpc$rma_end_of_list;

            { Set the display queue information in the SCD communications block for the new queue.  The
            { command to SCD must be set after all other fields are set.

            i#real_memory_address (v$scd_queue_p, rma);
            dpv$scd_block_p^.ve.console_data_rma := rma DIV 8;
            v$last_scd_rma := rma DIV 8;
            #SPOIL (dpv$scd_block_p^.ve);
            dpv$scd_block_p^.ve.command := dpc$scd_begin_new_output_list;
            mtv$nst_p^.d8st.operator_action := dpv$180_operator_action;
          IFEND;
        IFEND;
      IFEND;

      IF v$echo_input_request.hold_display_for_input THEN
        dpv$scd_time := v$end_pause;
      ELSE
        dpv$scd_time := #FREE_RUNNING_CLOCK (0) + 5 * 1000000;
      IFEND;

      REPEAT
        #COMPARE_SWAP (dpv$lock, id, 0, actual, result);
      UNTIL result < 2;

    UNTIL NOT work_to_be_done;
    i#mtr_restore_traps (old_traps);

  PROCEND dpp$process_scd_block;
MODEND dpm$system_console_monitor;
*DECK DECK=DPP$CHANGE_SCI_INTERRUPT_PORT EXPAND=FALSE

  PROCEDURE [XREF] dpp$change_sci_interrupt_port;
*DECK DECK=DPP$CHANGE_WINDOW EXPAND=FALSE

  PROCEDURE [XREF] dpp$change_window
    (    window_id: dpt$window_id;
         class: dpt$window_class;
         kind: dpt$window_kind;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_class
*copyc dpt$window_id
*copyc dpt$window_kind
*copyc ost$status
?? POP ??
*DECK DECK=DPP$CLEAR_WINDOW EXPAND=FALSE

  PROCEDURE [XREF] dpp$clear_window
    (    window_id: dpt$window_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
*copyc ost$status
?? POP ??
*DECK DECK=DPP$CLOSE_WINDOW EXPAND=FALSE

  PROCEDURE [XREF] dpp$close_window
    (VAR window_id: dpt$window_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
*copyc ost$status
?? POP ??
*DECK DECK=DPP$CONFIGURE_SYSTEM_CONSOLE EXPAND=FALSE

  PROCEDURE [XREF] dpp$configure_system_console;
*DECK DECK=DPP$DISPLAY_ERROR EXPAND=FALSE

  PROCEDURE [XREF] dpp$display_error
    (    message: string ( * <= osc$max_string_size));

?? PUSH (LISTEXT := ON) ??
*copyc ost$string
?? POP ??
*DECK DECK=DPP$GET_NEXT_LINE EXPAND=FALSE

  PROCEDURE [XREF] dpp$get_next_line
    (    window_id: dpt$window_id;
         wait: ost$wait;
     VAR line: string ( * );
     VAR line_received: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
*copyc ost$wait
?? POP ??
*DECK DECK=DPP$GET_NUMBER_LINES_IN_WINDOW EXPAND=FALSE

  PROCEDURE [XREF] dpp$get_number_lines_in_window
    (    window_id: dpt$window_id;
     VAR number_of_lines: dpt$number_of_window_lines;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$number_of_window_lines
*copyc dpt$window_id
*copyc ost$status
?? POP ??
*DECK DECK=DPP$GET_STARTING_LINE EXPAND=FALSE

  PROCEDURE [XREF] dpp$get_starting_line
    (    window_id: dpt$window_id;
     VAR starting_line: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
*copyc ost$status
?? POP ??
*DECK DECK=DPP$OPEN_WINDOW EXPAND=FALSE

  PROCEDURE [XREF] dpp$open_window
    (    class: dpt$window_class;
         kind: dpt$window_kind;
         title: string ( * );
     VAR window_id: dpt$window_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_class
*copyc dpt$window_id
*copyc dpt$window_kind
*copyc ost$status
?? POP ??
*DECK DECK=DPP$PROCESS_MONITOR_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] dpp$process_monitor_command
    (    line: string ( * ));
*DECK DECK=DPP$PUT_CRITICAL_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] dpp$put_critical_message
    (    message: string ( * <= osc$max_string_size);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=DPP$PUT_NEXT_LINE EXPAND=FALSE

  PROCEDURE [XREF] dpp$put_next_line
    (    window_id: dpt$window_id;
         line: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
*copyc ost$status
?? POP ??
*DECK DECK=DPP$SET_180_OPERATOR_ACTION EXPAND=FALSE

  PROCEDURE [XREF] dpp$set_180_operator_action
    (    actions_present: boolean);
*DECK DECK=DPP$SET_TITLE EXPAND=FALSE

  PROCEDURE [XREF] dpp$set_title
    (    window_id: dpt$window_id;
         title: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
*copyc ost$status
?? POP ??
*DECK DECK=DPT$CONSOLE_LINE EXPAND=FALSE

  { The following constants are used in the next line RMA field.  If the next line RMA is a zero then it is
  { the end of the list.  If the next line RMA is a one then SCD is finished processing the entry.  Otherwise
  { the field contains an actual RMA to the next line of data.

  CONST
    dpc$rma_end_of_list = 0,
    dpc$rma_scd_finished = 1;

  TYPE
    dpt$console_line = RECORD
      starting_console_row_number: ALIGNED [0 MOD 8] dpt$number_of_console_rows,
      ending_console_row_number: dpt$number_of_console_rows,
      text_size: dpt$console_row_size,
      text_kind: dpt$text_kind,
      next_line_rma: ost$real_memory_address,
      text: string (dpc$console_row_size),
      next_line_p: ^dpt$console_line,
    RECEND;

*copyc dpt$console_row_size
*copyc dpt$number_of_console_rows
*copyc dpt$text_kind
*copyc ost$hardware_subranges
*DECK DECK=DPT$CONSOLE_PARAMETER_BLOCK EXPAND=FALSE

  { Type definitions for NOS/VE communications with SCD.

  CONST
    dpc$cdc_721 = 1,
    dpc$c170_controlware_required = 1,
    dpc$mdd_initiated_by_cti = 0,
    dpc$mdd_initiated_by_c170 = 1,
    dpc$mdd_initiated_by_nosve = 2,
    dpc$sci_table_interlock_bit = 19;

  { Define the SCD console parameter block.  The structure of this table is defined in the
  { "SCD/Display-Console Interface Specification" (ARH5783).

  TYPE
    dpt$console_parameter_block = PACKED RECORD
      reserved: 0 .. 0ffff(16),
      scd_definition_changed: boolean,
      mdd_definition_changed: boolean,
      block_length_changed: boolean,
      interlocked: boolean,
      reserved2: 0 .. 3,
      sci_pp_number: 0 .. 77(8),
      block_length: 0 .. 15,
      scd_console: dpt$console_definition,
      mdd_console: dpt$mdd_console_definition,
      primary_ve_interface: dpt$ve_interface,
      secondary_ve_interface: dpt$ve_interface,
    RECEND;

  TYPE
    dpt$console_definition = PACKED RECORD
      reserved: 0 .. 3,
      console_bell: boolean,
      port_assigned: boolean,
      console_active: boolean,
      nos_ve_active: boolean,
      nos_active: boolean,
      terminal_type: 0 .. 7,
      controlware_code: 0 .. 7,
      reserved2: boolean,
      port_number: 0 .. 3, { 1X(2) = output to both ports, input from X
    RECEND;

  TYPE
    dpt$mdd_console_definition = PACKED RECORD
      reserved: 0 .. 7,
      port_assigned: boolean,
      console_active: boolean,
      initiator: 0 .. 3, { CTI = 0, C170 = 1, NOS/VE = 2
      reserved2: boolean,
      port_number: 0 .. 3, { 1X(2) = output to both ports, input from X
      nos_output_channel_to_scd: 0 .. 77(8),
    RECEND;

  TYPE
    dpt$ve_interface = PACKED RECORD
      unused: 0 .. 0ffffff(16),
      interrupt_selector: 0 .. 0ff(16),
      ve_parameter_block: 0 .. 0ffffffff(16),
    RECEND;
*DECK DECK=DPT$CONSOLE_ROW_SIZE EXPAND=FALSE

  TYPE
    dpt$console_row_size = 0 .. dpc$console_row_size;

*copyc dpc$console_row_size
*DECK DECK=DPT$CRITICAL_MESSAGES EXPAND=FALSE

  TYPE
    dpt$critical_messages = array [1 .. 15] of ost$string;

*copyc ost$string
*DECK DECK=DPT$CRITICAL_WINDOW_DATE_TIME EXPAND=FALSE

  CONST
    dpc$critical_window_msg_size = dpc$console_row_size - dpc$date_time_size,
    dpc$date_time_size = 18;

  TYPE
    dpt$critical_window_date_time = RECORD
      CASE 0 .. 2 OF
      = 0 =
        string_part: string (dpc$date_time_size),
      = 1 =
        hms: ost$hms_time,
        space_1_a: string (1),
        mdy: ost$mdy_date,
        space_1_b: string (1),
      = 2 =
        hour: string (2),
        colon_1: string (1),
        minute: string (2),
        colon_2: string (1),
        second: string (2),
        space_2_a: string (1),
        month: string (2),
        slash_1: string (1),
        day: string (2),
        slash_2: string (1),
        year: string (2),
        space_2_b: string (1),
      CASEND,
    RECEND;

*copyc dpc$console_row_size
*copyc ost$date
*copyc ost$time
*DECK DECK=DPT$LOCK_MAIN_WINDOW EXPAND=FALSE

  TYPE
    dpt$lock_main_window = RECORD
      lock: boolean,
      window_id: dpt$window_id,
    RECEND;

*copyc dpt$window_id
*DECK DECK=DPT$NUMBER_OF_CONSOLE_ROWS EXPAND=FALSE

  TYPE
    dpt$number_of_console_rows = 0 .. dpc$number_of_console_rows;

*copyc dpc$number_of_console_rows
*DECK DECK=DPT$NUMBER_OF_WINDOW_LINES EXPAND=FALSE

  TYPE
    dpt$number_of_window_lines = 0 .. dpc$number_of_window_lines;

*copyc dpc$number_of_window_lines
*DECK DECK=DPT$RB_DISPLAY_REQUEST EXPAND=FALSE

  TYPE
    dpt$rb_display_request = RECORD
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      action: dpt$display_actions,
      window_p: ^dpt$window,
      line_p: ^dpt$console_line,
    RECEND,

    dpt$display_actions = (dpc$da_add_window, dpc$da_delete_window, dpc$da_queue_line, dpc$da_clear_window,
          dpc$da_change_window, dpc$da_set_console_bell_status, dpc$da_check_scd_status,
          dpc$da_configure_console);

*copyc dpt$window
*copyc syc$monitor_request_codes
*copyc syt$monitor_status
*DECK DECK=DPT$SCD_COMMUNICATIONS_BLOCK EXPAND=FALSE

  { This type declaration defines the structure used by the SCD mode of SCI and the CPU to communicate.
  { This structure must be allocated in a cache bypass memory segment.  All of the RMA fields in this
  { structure are real memory word addresses.

  CONST
    dpc$scd_no_command = 0,
    dpc$scd_abort_output = 1,
    dpc$scd_begin_new_output_list = 2,
    dpc$scd_echo_input = 3,
    dpc$scd_resume_output = 4;

  TYPE
    dpt$scd_communications_block = RECORD
      scd: dpt$scd_data_for_ve,
      ve: dpt$ve_data_for_scd,
      rfu: 0 .. 0ffffffff(16),
      top_line_message_rma: 0 .. 0ffffffff(16),
    RECEND,

    { The first word of the communications block is read by the CPU and written by SCD.  It contains an ID
    { field which SCD increments every time it writes to this word.  The CPU knows SCD has written to this
    { word when the ID changes.  It also contains a three character input buffer.  SCD sends up to three
    { characters of input data from the console to the CPU for processing.  Generally, SCD is much faster
    { then the operator entering input and only one character at a time is actually sent.  The word also
    { contains an RMA to the line that SCD is currently processing.

    dpt$scd_data_for_ve = RECORD
      id: 0 .. 255,
      input_buffer: ARRAY [1 .. 3] OF 0 .. 255,
      current_data_rma: ost$real_memory_address,
    RECEND,

    { This word is read and written by both the CPU and SCD.  This is where the CPU posts the queue of lines
    { to display to SCD.  SCD clears out the command field to indicate that the command is being processed.
    { It contains a command field where the CPU tells SCD what to do with the given data.  SCD clears this
    { field when it has processed the existing command.  The next part of the word contains a boolean that
    { tells SCD to wait until all of the input has been gathered.  The CPU will set this boolean to true when
    { it begins receiving input and then set it to false when all input has been received.  SCD will not do
    { anything with the data until the boolean is set to false.  The last part of the word contains an RMA to
    { the data SCD will display to the console.

    dpt$ve_data_for_scd = RECORD
      command: 0 .. 255,
      hold_display_for_input: boolean,
      unused_1: 0 .. 255,
      unused_2: 0 .. 255,
      console_data_rma: ost$real_memory_address,
    RECEND;

*copyc ost$hardware_subranges
*DECK DECK=DPT$SECURE_INPUT_LINE EXPAND=FALSE

  TYPE
    dpt$secure_input_line = RECORD
      secure: boolean,
      window_id: dpt$window_id,
    RECEND;

*copyc dpt$window_id
*DECK DECK=DPT$TEXT_KIND EXPAND=FALSE

  { This type declaration describes a key that is sent to SCD, mode of the SCI PP, from VE to tell SCD what
  { to do with the text VE is sending to SCD.
  {   0 = normal display.
  {   1 = Inverse video and underline.
  {   2 = Input line.  An '@' sign is placed on the line, by the PP, if the length = 0.
  {   3 = Blinking.
  {   4 = Blinking inverse video.  A bell is also sent to the console in this case.

  TYPE
    dpt$text_kind = (dpc$tk_display, dpc$tk_title, dpc$tk_input, dpc$tk_input_ready, dpc$tk_flashing_title);
*DECK DECK=DPT$TOP_LINE_MESSAGE EXPAND=FALSE

  TYPE
    dpt$top_line_message = string (dpc$top_line_message_size);

?? PUSH (LISTEXT := ON) ??
*copyc dpc$top_line_message_size
?? POP ??
*DECK DECK=DPT$WINDOW EXPAND=FALSE

  { This type declaration is used to describe a window on the system console.  Each window descriptor contains
  { a window id and a pointer to the next window descriptor.  All of the windows are linked together.  Two of
  { the descriptor's entries are used to contain the physical console row numbers at which the window starts
  { and ends.  The console can be preceived as an array of rows, the first row at the top of the console is
  { referred to as ROW 1 and the last row is referred to as ROW 30.  The starting_console_row_number contains
  { the row number at which the window starts and the ending_console_row_number contains the row number at
  { which the window ends.

  { Each window can have, at most, 30 lines associated with that window.  These lines are also numbered 1 to
  { 30.  The present_window_line_number contains the number that corresponds to the most recent window line
  { to receive data.  The next PUT will place the data in the present window line number plus one.  Table
  { windows do not use this field.

  { Table windows are used differently then the other window kinds.  They also contain 30 lines in the
  { descriptor but they usually have a 'file' of data associated with the table.  A procedure takes 30 lines
  { at a time from the file and places them in the window descriptor.  This allows for the UP, DOWN, FWD, BKW
  { function keys to be used to 'view' the whole file.  The user does not realize that the window only has 30
  { lines.  The table_starting_line_in_window contains the line of the file that will appear at the first
  { console row of the window.  The table_last_line_used_in_window contains the line of the file that was the
  { last window line to have received data.  The table_next_available_line is the next line of the file to be
  { used.

  TYPE
    dpt$window = RECORD
      next_window_p: ALIGNED [0 MOD 4096] ^dpt$window,
      window_id: dpt$window_id,
      starting_console_row_number: dpt$number_of_console_rows,
      ending_console_row_number: dpt$number_of_console_rows,
      true_class: dpt$window_class,
      class: dpt$window_class,
      kind: dpt$window_kind,
      table_starting_line_in_window: integer,
      table_last_line_used_in_window: integer,
      table_next_available_line: integer,
      present_window_line_number: dpt$number_of_window_lines,
      title: dpt$console_line,
      input_line: dpt$console_line,
      lines: ARRAY [1 .. dpc$number_of_window_lines] OF dpt$console_line,
    RECEND;

*copyc dpt$console_line
*copyc dpt$number_of_console_rows
*copyc dpt$number_of_window_lines
*copyc dpt$window_class
*copyc dpt$window_id
*copyc dpt$window_kind
*DECK DECK=DPT$WINDOW_CLASS EXPAND=FALSE

  { This type declaration defines the class of the window.  PRE_EMPT means that this type of window takes
  { precedence over other windows.  It will be about ten rows in size and the title line will blink.
  { INVISIBLE means that this window is not displayed on the console.  It is currently not being viewed yet
  { it still exists.  All other windows are defined as SHARING.  The rows allocated to these windows will
  { vary depending on the other type of windows.

  TYPE
    dpt$window_class = (dpc$wc_pre_empt, dpc$wc_sharing, dpc$wc_invisible);
*DECK DECK=DPT$WINDOW_ID EXPAND=FALSE

  TYPE
    dpt$window_id = 0 .. 0ffffffff(16);
*DECK DECK=DPT$WINDOW_KIND EXPAND=FALSE

  { This type declaration defines the kind of the window.  LOG is a scrolling window.  INTERACTIVE is a
  { scrolling window whose last line is an input line.  Interactive windows are at least three rows in size.
  { TABLE is a list of data that can be viewed with the help of the FWD, BKW, UP, DOWN function keys.  Tables
  { are typically larger then thiry lines.  Only thirty lines at a time can be stored in the window
  { descriptor.  The lines are replaced by the other lines when they are needed.

  TYPE
    dpt$window_kind = (dpc$wk_log, dpc$wk_table, dpc$wk_interactive);
*DECK DECK=DPV$180_OPERATOR_ACTION EXPAND=FALSE

  VAR
    dpv$180_operator_action: [XREF] boolean;
*DECK DECK=DPV$CRITICAL_DISPLAY_ID EXPAND=FALSE

  VAR
    dpv$critical_display_id: [XREF] dpt$window_id;

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
?? POP ??
*DECK DECK=DPV$CRITICAL_MESSAGES EXPAND=FALSE

  VAR
    dpv$critical_messages: [XREF] dpt$critical_messages;

*copyc dpt$critical_messages
*DECK DECK=DPV$CRITICAL_MSGS_NEED_LOGGING EXPAND=FALSE

  VAR
    dpv$critical_msgs_need_logging: [XREF] boolean;

*DECK DECK=DPV$DISPLAY_DELAY EXPAND=FALSE

  VAR
    dpv$display_delay: [XREF] integer;
*DECK DECK=DPV$ENABLE_CONSOLE_BELL EXPAND=FALSE

  VAR
    dpv$enable_console_bell: [XREF] boolean;

*DECK DECK=DPV$ENABLE_STOP_KEY EXPAND=FALSE

  VAR
    dpv$enable_stop_key: [XREF] boolean;
*DECK DECK=DPV$LOCK EXPAND=FALSE

  VAR
    dpv$lock: [XREF] integer;
*DECK DECK=DPV$LOCK_MAIN_WINDOW EXPAND=FALSE

  VAR
    dpv$lock_main_window: [XREF] dpt$lock_main_window;

?? PUSH (LISTEXT := ON) ??
*copyc dpt$lock_main_window
?? POP ??
*DECK DECK=DPV$SCD_BLOCK_P EXPAND=FALSE

  VAR
    dpv$scd_block_p: [XREF] ^dpt$scd_communications_block;

?? PUSH (LISTEXT := ON) ??
*copyc dpt$scd_communications_block
?? POP ??
*DECK DECK=DPV$SCD_TIME EXPAND=FALSE

  VAR
    dpv$scd_time: [XREF] integer;
*DECK DECK=DPV$SECURE_INPUT_LINE EXPAND=FALSE

  VAR
    dpv$secure_input_line: [XREF] dpt$secure_input_line;

?? PUSH (LISTEXT := ON) ??
*copyc dpt$secure_input_line
?? POP ??
*DECK DECK=DPV$SYSTEM_CORE_DISPLAY EXPAND=FALSE

  VAR
    dpv$system_core_display: [XREF] dpt$window_id;

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
?? POP ??
*DECK DECK=DPV$TOP_WINDOW_P EXPAND=FALSE

  VAR
    dpv$top_window_p: [XREF] ^dpt$window;

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window
?? POP ??
*DECK DECK=DSA$CHECK_IF_NOSBE EXPAND=TRUE
          IDENT  TESTNBE
          TITLE  DSA$CHECK IF NOSBE
*
* PROCEDURE [XREF] TESTNBE ( VAR NOSBE: BOOLEAN );
*
          ENTRY  TESTNBE,PAUSE,PAWS,GETWORD,MMOVE
          SYSCOM
          LIST   F
*copyc dsa$cybil_if_macros
TESTNBE   BSS    0
          IF     -DEF,RA.ORG,1
          SX6    B0          SET TO (FALSE) FOR NOS
          IF     DEF,RA.ORG,1
          MX6    1           SET TO (TRUE)  FOR NOS/BE
          SA6    X1          WRITE OUTPUT PARAMETER
          EQ     GETWRD1
*
* PROCEDURE [XREF] PAUSE (TIME: INTEGER);
* PAUSE - PAUSE (RECALL) FOR A SPECIFIED NUMBER OF RECALLS
*
PAUSE     BSS    0
PAWS      BSS    0
          RJ     =XPXSAVE
          SX0    X1-1
          EQ     PAUSE2
PAUSE1    SX0    X0-1
          RECALL
PAUSE2    PL     X0,PAUSE1
          EQ     =XZSMRRET
*
* PROCEDURE [XREF] GETWORD (ADDRESS: INTEGER; WORD: ^CELL);
*
GETWORD   BSS    0
          SA1    X1
          BX6    X1
          SA6    X2
GETWRD1   SHORTEX
*
* PROCEDURE [XREF] MMOVE (FROM: ^CELL; TO: ^CELL; LENGTH: INTEGER;)
*
MMOVE     RJ     =XPXSAVE
          SB3    X3-1
          EQ     MOVE2
MOVE1     SA4    X1+B3
          BX6    X4
          SA6    X2+B3
          SB3    B3-B1
MOVE2     PL     B3,MOVE1
          EQ     =XZSMRRET
          END
*DECK DECK=DSA$CPU_PP_COMMUNICATION_BLOCK EXPAND=FALSE
.................begin common deck DSA$CPU_PP_COMMUNICATION_BLOCK.....
.   WARNING! WARNING! WARNING! WARNING! WARNING! WARNING! WARNING!
. Any changes to this deck must have corresponding changes in the deck
. DST$CPU_PP_COMMUNICATION_BLOCK.
.
cpcbsize  equ    5*8         .Size of CPCB
.
.  Define byte offsets for the various fields in CPCB used in
.  ASSEMBLE.  For a complete definition of the data structure, see
.  the deck DST$CPU_PP_COMMUNICATION_BLOCK.
.
mon_time  equ    1*8         .Timestamp by CPU in MTR mode
.
.................end common deck DSA$CPU_PP_COMMUNICATION_BLOCK.......
*DECK DECK=DSA$CYBIL_IF_MACROS EXPAND=FALSE
          SPACE  2
          LIST   -L
* FOLLOWING MACROS (ENTR,DONE,SHORTEX) SUPPORT CYBIL/COMPASS INTERFACE.
          PURGMAC ENTR,DONE
          MACRO  ENTR,NAME,SFSIZE
          LOCAL  MORE
          IFC    EQ, SFSIZE  ,1
          ERR    STACKFRAME SIZE NEEDED.
 MORE     SB7    SFSIZE
          RJ     =XCIL#SPE
 NAME     SX0    B2          COPY POINTER TO CALLER'S STACK FRAME
          LX0    18D
          SB2    B2-SFSIZE   ADJUST STACK FRAME POINTER
          BX6    X7+X0       MERGE INTO LINKAGE WORD
          GE     B3,B2,MORE  CHECK IF ROOM IN STACK SEGMENT
          SA6    B2          SAVE LINKAGE WORD INTO STACK
          ENDM
 DONE     MACRO
          SA1    B2          LOAD LINKAGE WORD
          SB7    X1          GET RETURN ADDRESS
          LX1    42D
          SB2    X1          RESTORE CALLERS'S STACK POINTER
          LX1    18D
          JP     B7          RETURN
          ENDM
 SHORTEX  MACRO
          SX1    B2     SETUP
          LX1    18D         X1
          BX1    X7+X1         FOR CYBIL
          SB7    X7     AND
          JP     B7        RETURN
          ENDM
* FOLLOWING MACRO DEFINES A FIELD FOR THE *FMOVE* MACRO.
          MACRO   DEFFLD,NAME,A,B,C,D,E
          IFGT    A,-1,8
          IFGT    B,-1,7
          IFGT    C,-1,6
          IFGT    D,-1,5
          IFLT    E,B+2,4
          IFLT    E,D+2,3
          IFGT    E,0,2
          IFLT    D,60,1
          IFGT    B,59,2
          ERR     ERROR IN PARAMETERS
          SKIP    1
#_NAME    MICRO   1,, (A,B,C,D,E)
          ENDM
* FOLLOWING MACRO MOVES THE CONTENTS OF A CONTROLBLOCK FIELD.
FMOVE     MACRO   NAME,B
          LOCAL   MIC
MIC       MICRO   1,, "#_NAME"
          IFC     NE, B  ,1
MIC       MICRO   1,, "MIC",BACK
          CBFMOVE "MIC"
          ENDM
*       CBFMOVE - MACRO TO MOVE CONTROLBLOCK FIELDS.
*       INPUTS  -  B2     CONTAINS INPUT CB BASE ADDRESS.
*                  B3     CONTAINS OUTPUT CB BASE ADDRESS.
*       USES    -  A1,A2,A6, X1,X2,X6
*       PARAMETER - MICRO CONSISTING OF 5 SUBFIELDS, TO BE
*                   DEFINED BY A MICRO OF THE FORM:
*             #NAME  MICRO  1,,/(IW,IB,OW,OB,L)/
*                    IW/OW - INPUT/OUTPUT CB WORD OFFSET
*                    IB/OB - INPUT/OUTPUT FIELD LEFTMOST BIT NUMBER
*                    L     - FIELD LENGTH IN BITS
*
CBFMOVE MACRO NAME,KEY1,KEY2,KEY3
        LOCAL NOSWD,NOSBIT,NBEWD,NBEBIT,LEN,T
        LOCAL DIR,FILL,VALUE,SINGLE
DIR     MICRO 1,, F
FILL    SET   0
VALUE   SET   0
SINGLE  SET   0
CBACK   IFC   EQ, KEY1 BACK
DIR     MICRO 1,, BACK
        IFC   EQ, KEY2 ONE ,2
FILL    SET   1
        SKIP  3
        IFC   NE, KEY2 ZERO ,2
VALUE   SET   KEY2
        SKIP  2
SINGLE  SET   1
VALUE   SET   KEY3
CBACK   ELSE
        IFC   EQ, KEY1 ONE ,2
FILL    SET   1
        SKIP  3
        IFC   NE, KEY1 ZERO ,2
VALUE   SET   KEY1
        SKIP  2
SINGLE  SET   1
VALUE   SET   KEY2
CBACK   ENDIF
T       SET   0
        IRP   NAME
        IFEQ  T,0,1
NOSWD   MICRO 1,, NAME
        IFEQ  T,1,4
        IFC   EQ, "DIR" F ,1
NOSBIT  MICRO 1,, NAME
        IFC   EQ, "DIR" BACK ,1
NBEBIT  MICRO 1,, NAME
        IFEQ  T,2,1
NBEWD   MICRO 1,, NAME
        IFEQ  T,3,4
        IFC   EQ, "DIR" F ,1
NBEBIT  MICRO 1,, NAME
        IFC   EQ, "DIR" BACK ,1
NOSBIT  MICRO 1,, NAME
        IFEQ  T,4,1
LEN     MICRO 1,, NAME
T       SET   T+1
        IRP
        IFC   EQ, "NOSWD" 0 ,1
NOSWD   MICRO 1,, B0
        IFC   EQ, "NBEWD" 0 ,1
NBEWD   MICRO 1,, B0
        IFC   EQ, "NOSWD" 1 ,1
NOSWD   MICRO 1,, B1
        IFC   EQ, "NBEWD" 1 ,1
NBEWD   MICRO 1,, B1
        IFC   EQ, "DIR" BACK ,3
        SA2   B2+"NOSWD"
        IFEQ  SINGLE,0,1
        SA1   B3+"NBEWD"
        IFC   EQ, "DIR" F ,3
        SA2   B3+"NBEWD"
        IFEQ  SINGLE,0,1
        SA1   B2+"NOSWD"
        IFEQ  SINGLE+FILL,0,1
        IFNE  "LEN",60,1
        MX6   "LEN"
        IFNE  "NBEBIT",59,1
        LX6   "NBEBIT"+1
CFILL   IFEQ  SINGLE,0
        IFGT  "NOSBIT","NBEBIT",1
        LX1   "NBEBIT"+60-"NOSBIT"
        IFGT  "NBEBIT","NOSBIT",1
        LX1   "NBEBIT"-"NOSBIT"
        IFNE  "LEN",60,3
        BX1   X1*X6
        BX6   -X6*X2
        BX6   X6+X1
        IFEQ  "LEN",60,1
        BX6   X1
CFILL   ELSE
        IFEQ  FILL,0,2
        BX6   -X6*X2
        SKIP  1
        BX6   X6+X2
CFILL   ENDIF
        SA6   A2
        ENDM
          LIST   *
          SPACE  2
*DECK DECK=DSA$CYBIL_INTERFACE EXPAND=TRUE
          IDENT  DSACYIF
          TITLE  DSA$CYBIL INTERFACE - COMPASS INTERFACE TO CYBIL
          ENTRY  ZSMRENT,ZSMRRET,PARSV,PXSAVE,PXRSTR,PXREST
          SPACE  4,10
*     THE PURPOSE OF THIS MODULE IS TO PROVIDE A MEANS BY WHICH
* RELEVANT REGISTERS ASSOCIATED WITH A CYBIL ENVIRONMENT CAN BE
* PRESERVED DURING A NON-CYBIL PROCESSING INTERLUDE.
*
* STACKFRAME SET UP FOR LINKAGE WORD AND B3/B4/B5 SAVEAREA
*
 SFSIZE   EQU    4
          SPACE  2
 ZSMRENT  BSSZ   1
          EQ     START
 PXSAVE   EQU    ZSMRENT
*copyc dsa$cybil_if_macros
 START    ENTR   SFSIZE
          SX6    B2
          BX7    X1          SAVE X1
          SA1    SAVEM
          SB1    1
          PL     X1,ERR1     RECURSIVE CALL
          BX1    X7          RESTORE X1
          SA6    A1
          BX6    X1
          SA6    A6+B1
          BX6    X2
          SA6    A6+B1
          BX6    X3
          SA6    A6+B1
          BX6    X4
          SA6    A6+B1
          BX6    X5
          SA6    A6+B1
          SX6    B3
          SA6    B2+B1
          SX6    B4
          SA6    A6+B1
          SX6    B5
          SA6    A6+B1
          EQ     ZSMRENT
*
*     THE PURPOSE OF THIS A170 COMPASS ROUTINE IS TO RESTORE
* THOSE REGISTERS NEEDED TO CONTINUE IN THE CYBIL PROCESS STATE
* AFTER A NON-CYBIL PROCESSING INTERLUDE.
*
 PXRSTR   BSSZ   1
 PXREST   EQU    PXRSTR
 ZSMRRET  SA1    SAVEM
          SB1    1
          MI     X1,ERR2     IF PXRSTR WITHOUT PXSAVE
          MX6    30D
          BX6    X6+X1
          SA6    A1          MINUS MEANS NEXT CALL MUST BE PXSAVE
          SB2    X1
          SA1    B2+B1
          SB3    X1
          SA1    A1+B1
          SB4    X1
          SA1    A1+B1
          SB5    X1
          DONE
*
* SAVEM IS USED TO SAVE THE STACKFRAME ADDRESS (B2) AND TO CHECK
* IF NO CALLING SEQUENCE ERROR TO PXSAVE/PXRSTR IS MADE.
* PARSV IS USED TO SAVE 5 PARAMETERS FROM CYBIL.
*
 SAVEM    VFD    6/77B,54/0
 PARSV    BSS    5
*
*     NEXT FOLLOW ERROR MESSAGES CAUSED BY IMPROPER CALLING
*       SEQUENCES (FATAL ERRORS)
*
 ERR1     BSS    0
          MESSAGE  (=C* RECURSIVE PXSAVE.*),3,R
          EQ     ERR2A
 ERR2     BSS    0
          MESSAGE  (=C* SPURIOUS PXREST.*),3,R
 ERR2A    ABORT
         END
*DECK DECK=DSA$DEADSTART_OS_INTERFACE EXPAND=TRUE
          IDENT  DSADCAL
          SST
          SYSCOM B1
          LIST   F
          TITLE  DSA$DEADSTART OS INTERFACE (DSADCAL)
          SPACE 4,10
**        ENTRY POINTS.
*
          ENTRY  JCR
          ENTRY  EXITCD
          ENTRY  KINPB
          ENTRY  KDISPB
          ENTRY  KTITLE
          ENTRY  DISPLAY
          ENTRY  CALLSDA
          ENTRY  CALLVER
          ENTRY  JCRGET
          ENTRY  JCRSET
          ENTRY  WAKEUP
          ENTRY  GTDTTM
          ENTRY  GETVEST
          ENTRY  DSTCPU
          ENTRY  MINILNK
          ENTRY  SETEIAD
          ENTRY  GETEIAD
          ENTRY  ENDPRGR
          ENTRY  GETTIME
          SPACE  4,10
**        EXTERNAL DEFINITIONS.
*


          EXT    ZSMRENT
          EXT    ZSMRRET
          QUAL   VE
 OPL      XTEXT  COMSDST
          QUAL   *
          EJECT
*         DISPLAY - CALL K DISPLAY.
*
*         REQUEST DSD TO CALL K DISPLAY FOR DSC JOB. K DISPLAY
*         IS USED FOR COMMUNICATING WITH NOS/VE ENVIRONMENT FROM
*         NOS. THE DISPLAY AND INPUT BUFFER ARE UPDATED AND READ
*         RESPECTIVLY BY DSIR ROUTINES CALLED BY DSC.
*
*         ENTRY  - FROM ISWL PROCEDURE, USES ZSMRENT AND ZSMRRET
*                  ROUTINES TO SAVE AND RESTORE THE ISWL ENVIRONMENT.
*
*         EXIT   - K DISPLAY IS REQUESTED AS PER REQUEST DESCRIPTOR
*                  DSCKDSPL.
*
*         NOS/BE USES THE L DISPLAY INSTEAD OF THE K DISPLAY
*
*
*         MSG TEXT DURING DSTRT
*
 DSCKDSPL VFD    24/KINPB,18/0,18/KDISPBC
 NOSSYS1  IF     DEF,RA.ORG
*
*         CALL L DISPLAY FOR NOS/BE
 CALLL    VFD    12/KINPB,48/8RLDISPLAY
 LDISPL   DIS    ,*$ASSIGN L-DISPLAY*
*
*         CONSTANTS FOR NOS/BE L DISPLAY
*
 NLINE    EQU    23          NUMBER OF ACTIVE LINES IN BUFFER
 WCOUNT   EQU    7           WORD COUNT PER LINE
 CHSIZE   EQU    1           CHARACTER SIZE
 XCOORD   EQU    6000B       X-COORDINATE
 YSTART   EQU    7460B       Y-COORDINATE BEFORE FIRST LINE TO DISPLAY
 YDIST    EQU    10B         Y-DISTANCE PER LINE
 NOSSYS1  ENDIF
*
 DISPLAY  BSS    0
          RJ     ZSMRENT     SAVE ISWL ENVIRONMENT
 NOSSYS   IF     -DEF,RA.ORG
          CONSOLE DSCKDSPL
 NOSSYS   ELSE
*
*
*         SETUP CONTROL INFORMATION FOR NOS/BE L-DISPLAY OUTPUT BUFFER
*
          SB2    B0          LINE COUNT
          SB7    B0          WORD COUNT IN BUFFER
          SB3    NLINE       NUMBER OF LINES IN BUFFER
          SX2    WCOUNT      WORD COUNT IN LINE
          SB4    X2          NUMBER OF WORDS PER LINE
          R=     X5,CHSIZE   CHARACTER SIZE
          LX2    54
          LX5    48
          BX4    X2+X5
          MX0    36
          SX5    XCOORD      X-COORDINATE
          LX5    36
          BX4    X4+X5
          SX5    YSTART      Y-COORDINATE BEFORE FIRST LINE TO DISPLAY
          SX3    YDIST
 NBEDISP  IX7    X5-X3       CURRENT Y-COORDINATE
          BX5    X7
          LX7    24
          BX7    X4+X7       CONTROL INFO FOR CURRENT DISPLAY LINE
          SA2    KDISPB+B7   EXCHANGE INFO IN CURRENT LINE
          BX2    -X0*X2
          BX7    X2+X7
          SA7    A2
          SB2    B2+B1       UPDATE COUNTERS
          SB7    B7+B4
          LT     B2,B3,NBEDISP
          BX6    X6-X6
          SA6    KDISPBC
          SA1    CALLL       ACTIVATE L DISPLAY
          BX6    X1
          SA6    RA.CCD
          MESSAGE LDISPL,LOCAL,R
 NOSSYS   ENDIF
          JP     ZSMRRET     RESTORE ISWL ENVIRONMENT AND RETURN
*
*         K DISPLAY INPUT BUFFER.
*
 KINPB    BSS    0
          DATA   60H
          DATA   4C
*
*         DISPLAY BUFFER(S).
*
KDISPBC   VFD    18/140B,18/KTITLE,24/0 CONTROLWORD 64 CHARS/LINE CODED
KDISPB    BSS    0
LINES23   DUP    23
          VFD    24/4R    ,12/6000B,24/4R
          DATA   56C
LINES23   ENDD
          BSSZ   21*7
          CON    0
KTITLE    BSS    0
          DATA   16C
          EJECT
*         CALLSDA - CALL SYSTEM DEADSTART ASSIST.
*
*         ENTRY  - FROM ISWLCC PROCEDURE.
*                  HELPERPP - DSC JOB COMMUNICATION TABLE IS AT PPHELPT.
*
*         EXIT   - ZSMRRET ROUTINE IS USED TO RESTORE ISWLCC ENV.
*
 CALLSDA  BSS    0
          RJ     ZSMRENT     SAVE ISWLCC ENVIRONMENT
          BX5    X1
          SA3    X2          CLEAR COMPLETION BIT
          MX6    -12
          BX6    X6*X3
          SA6    A3
          LX5    6
          SYSTEM SDA,R,A3,X5
          JP     ZSMRRET     RESTORE ISWL ENVIRONMENT AND RETURN

 CSDAP    VFD    12/0,24/0,24/0
          SPACE  3,15
*         CALLVER - MAKE REQUEST TO VER.
*
*         ENTRY  - FROM CYBIL PROCEDURE.
*                  PARAM1 = REQUEST BLOCK.
*                  PARAM2 = REQUEST CODE.
*                  PARAM3 = WAIT FOR COMPLETION FLAG.
*
*         EXIT   - ZSMRRET ROUTINE USED TO RESTORE ENVIRONMENT.
*
CALLVER   BSS    0
          RJ     ZSMRENT     SAVE ISWL ENVIRONMENT
          SX5    3RVER
          LX2    18+6
          BX6    X1+X2
          ZR     X3,CALLVR1
          PX5
CALLVR1   LX5    42D
          BX6    X6+X5
          RJ     =XSYS=
          JP     ZSMRRET
          SPACE  3,15
*         JCRGET - GET JOB CONTROL REGISTERS INTO JCR WORD.
*
*         ENTRY  - FROM ISWLCC PROCEDURE.
*
*         EXIT   - R1,R2,R3 AND ERROR REGISTERS ARE SET INTO JCR.
*
 JCRGET   BSS    0
          RJ     ZSMRENT     SAVE ISWL ENVIRONMENT
          SA1    JCR
          MX6    59D
          BX6    X6*X1
          SA6    A1
          GETJCI JCR
          JP     ZSMRRET     RESTORE ISWL ENVIRONMENT AND RETURN

 JCR      BSSZ   2           RESERVE SPACE FOR THE JCR BLOCK
          SPACE  3,15
*         JCRSET - SET JOB CONTROL REGISTERS FROM JCR WORD.
*
*         ENTRY  - FROM ISLCC PROCEDURE.
*
*         EXIT   - R1,R2,R3 AND ERROR REGISTERS ARE SET FROM JCR.
*
 JCRSET   BSS    0
          RJ     ZSMRENT     SAVE ISWL ENVIRONMENT
          SA1    JCR
          MX6    59D
          BX6    X6*X1
          SA6    A1
          SETJCI JCR
          JP     ZSMRRET     RESTORE ISWL ENVIRONMENT AND RETURN
          SPACE  3,15
*         CYCLE  - PLACE JOB INTO PERIODIC RECALL.
*
*         REQUEST MONITOR TO PLACE JOB INTO PERIODIC
*         RECALL. USED TO CYCLE DSC.
*
*         ENTRY  - FROM ISWLCC PROCEDURE.
*
*         EXIT   - ZSMRRET ROUTINE IS USED TO RESTORE ISWLCC ENV.
*
WAKEUP    BSS    0
          RJ     ZSMRENT     SAVE ISWL ENVIRONMENT
          RECALL
          JP     ZSMRRET     RESTORE ISWL ENVIRONMENT
          SPACE  3,15
*         GTDTTM - GET DATE AND TIME FROM OS.
*
*         ENTRY  FROM CYBIL PROCEDURE.
*                PARAM1 = VARIABLE ADDRESS OF DATE.
*                PARAM2 = VARIABLE ADDRESS OF TIME.
*
*         EXIT   - ZSMRRET ROUTINE USED TO RESTORE ENVIRONMENT.
*
 GTDTTM   BSS    0
          RJ     ZSMRENT
          DATE   X1
          CLOCK  X2
          EQ     ZSMRRET
 OKEXIT   SPACE  3,15
*         OKEXIT - EXIT TO ZSMRRET AFTER SETTING EXITCD.
*
 OKEXIT   SX6    B1          ASSUME OK
          ZR     X0,OKE1     IF NO ERROR
          SX6    B0
 OKE1     SA6    EXITCD
          JP     ZSMRRET     RETURN TO CYBIL

 EXITCD   CON    1           SET EXIT CONDITION
 RT       SPACE  3,15
*         RT - DEFINE THE RT INSTRUCTION.
*
 RTX,X,Q  OPDEF  P1,P2,K
+         VFD    9/017B,3/P1,3/P2,15/K,30/0
          ENDM
 COMSCVS  SPACE  3,15
*copyc COMSCVS
 GETVEST  SPACE  3,15
*         GETVEST- GET THE STATUS OF NVE.
*
*         ENTRY  FROM CYBIL PROCEDURE.
*
*         EXIT   TO OKEXIT  TO RESTORE ENVIRONMENT.
*
 GETVEST  BSS    0
          RJ     ZSMRENT     SAVE ENVIRONMENT
          RT     X6,X0,2002B STATUS NVE
          SA6    X1          SAVE STATUS
          JP     OKEXIT      RETURN
 DSTCPU   SPACE  3,15
*         DSTCPU - DEADSTART CPU.
*
*         ENTRY  FROM CYBIL PROCEDURE.
*                PARAM1 = TYPE OF DEADSTART.
*
*         EXIT   TO OKEXIT  TO RESTORE ENVIRONMENT.
*
 DSTCPU   BSS    0
          RJ     ZSMRENT     SAVE ENVIRONMENT
          NZ     X1,DST1
          RT     X0,X0,CVSSCPU DEADSTART TO DUAL STATE
          JP     OKEXIT

 DST1     RT     X0,X0,CVSRVT  DEADSTART TO STANDALONE
          JP     OKEXIT
          SPACE  3,15
**        MINILNK - PROCESS CALLS TO THE MINILINK.
*
*         ENTRY  FROM CYBIL PROCEDURE.
*                PARAM1 = ADDRESS OF HEADER BLOCK.
*                PARAM2 = ADDRESS OF DATA BLOCK.
*
*         EXIT   CALL TO EI/TRAP HANDLER MADE.

 MINILNK  BSS    0
          RJ     ZSMRENT     SAVE ENVIRONMENT
          RT     X1,X2,CVSCPCM MAKE MINILINK REQUEST
          JP     OKEXIT      RETURN
 SETEIAD  SPACE  3,15
*         SETEIAD - SET EI PVA.
*
*         ENTRY  FROM CYBIL PROCEDURE.
*                PARAM1 = TYPE OF PVA TO SET IN EI.
*                PARAM2 = WORD ADDRESS TO SET IT TOO.
*
*         EXIT   TO OKEXIT  TO RETURN.
*
 SETEIAD  BSS    0
          RJ     ZSMRENT
          RT     X1,X2,CVSCPVA HAVE EI INITIALIZE PVA
          JP     OKEXIT
 GETEIAD  SPACE  3,15
**        GETEIAD - GET EI PVA VALUE.
*
*         ENTRY  FROM CYBIL PROCEDURE.
*                PARM1 = TYPE OF PVA TO GET FROM EI.
*                PARM2 = ADDRESS OF VARIABLE TO STORE.
*
*         EXIT   TO OKEXIT TO RETURN.

 GETEIAD  BSS    0
          RJ     ZSMRENT
          RT     X1,X6,CVSFPVA GET PVA VALUE FROM EI
          SA6    X2          SAVE PVA VALUE
          JP     OKEXIT
          SPACE  4
**        GETTIME - GET SECONDS SINCE DEADSTART
*
*         ENTRY  FROM CYBIL PROCEDURE.
*                PARM1 = ADDRESS TO STORE SECONDS SINCE DEADSTART.
*
*         EXIT   TO OKEXIT TO RETURN.

 GETTIME  BSS    0
          RJ     ZSMRENT     SAVE ENVIRONMENT
          SX4    X1
          RTIME  X4          GET SECONDS SINCE DEADSTART
          SA1    X4
 NOS      IF     -DEF,RA.ORG
          BX6    X1          ISOLATE SECONDS
          AX6    36
 NOS      ELSE
          MX2    -35
          BX6    -X2*X1      ISOLATE SECONDS*4096
          AX6    12
 NOS      ENDIF
          SA6    A1          RETURN SECONDS
          JP     ZSMRRET
          SPACE  3,15
*         ENDPRGR - TERMINATE CURRENT PROGRAM.
*
*         ENTRY - FROM CYBIL PROCEDURE, ITS ENVIRONMENT IS NOT SAVED.
*
*         EXIT  - TO MONITOR.
*
 ENDPRGR  BSS    0
          IF     DEF,RA.ORG,4
 OPL      XTEXT  SSYS
          SFCALL EXIT,R
          MX6    0
          SA6    RA.SSID
          ENDRUN
          IF     DEF,RA.ORG,2
 EXIT     CON    SF.EXIT
          CON    0
          END
*DECK DECK=DSA$DS_CONFIGURATION_TOKENS EXPAND=TRUE
          IDENT  CONFIG
          TITLE  DSA$DS CONFIGURATION TOKENS
          SPACE   1
*         NEXTDST - GET NEXT DEADSTART TAPE
*
*         THE NEXT DEADSTART TAPE IS REQUESTED.
*
*         ENTRY - FROM CYBIL, NO PARAMETERS.
*
*         EXIT - NEXT TAPE IS REQUESTED.
*
          ENTRY  NEXTDST
          SYSCOM B1
          LIST   F
 NEXTDST  BSS    0
          RJ     =XZSMRENT
          SKIP   RA.MTR
          ERR    SYSCOM WAS NOT CALLED
          IF     -DEF,RA.ORG,1
          FILINFO IFET       OBTAIN DENSITY INFORMATION
          RETURN FET,R
 NOSSYS   IF     -DEF,RA.ORG
          SA1    IFET+5      NEW DENSITY
          SA2    FET+8
          MX3    -3
          LX1    51-9
          LX3    51
          BX6    -X3*X1      ISOLATE DENSITY
          BX2    X3*X2       REMOVE OLD DENSITY INFORMATION
          BX6    X6+X2       UPDATE DENSITY
          SA6    A2          REPLACE FET WORD
          LABEL  FET
 NOSSYS   ELSE
          SA1    IFET
          MX6    42
          BX6    X6*X1
          SA6    A1          STORE TO IFET
          SA1    FLAGWORD
          BX6    X1
          SA6    A6+B1       STORE TO IFET+1
          SA1    FET9
          MX6    36
          BX6    X6*X1
          SA6    A6+B1       STORE TO IFET+2
          REQUEST IFET
 NOSSYS   ENDIF
          JP     =XZSMRRET
 BLENGTH  EQU    1001B
 FET      BSS    0
 NOSVETP  FILEB  BUFFER,BLENGTH,LBL
          ORG    FET+8
 FET8     VFD    6/4,3/5,3/0,12/10B,12/0,6/2,18/0
 FET9     VFD    36/0HNVETPX,24/0
          IF     -DEF,RA.ORG,1
          BSSZ   4

 IFET     VFD    42/0LNOSVETP,6/6,12/1
          BSSZ   2
          IF     -DEF,RA.ORG,2
          BSSZ   2
          VFD    54/0,6/2
          IF     DEF,RA.ORG,1
 FLAGWORD VFD    9/4,27/2,12/0,6/41B,6/3  DENSITY 1600 SI

 BUFFER   BSS    0
          BSS    BLENGTH
          END
*DECK DECK=DSA$FAKE_OS_INTERFACE EXPAND=TRUE
          IDENT  DSADCAL
          SST
          SYSCOM B1
          LIST   F
          TITLE  DSA$DEADSTART OS INTERFACE (DSADCAL)
          SPACE 4,10
**        ENTRY POINTS.
*
          ENTRY  DISPLAY
          ENTRY  KDISPB
          ENTRY  KTITLE
          ENTRY  GETMAB
          ENTRY  JCRGET
          ENTRY  JCRSET
          ENTRY  GTDTTM
          ENTRY  UPKDIS
          ENTRY  ENDPRGR
          ENTRY  KINPB
          ENTRY  GETTIME
          SPACE  4,10
**        EXTERNAL DEFINITIONS.
*


          EXT    ZSMRENT
          EXT    ZSMRRET
          EXT    JCR
          EXT    EXITCD
          EXT    CONFIGU
          QUAL   VE
 OPL      XTEXT  COMSDST
          QUAL   *
          EJECT
*         DISPLAY - CALL K DISPLAY.
*
*         REQUEST DSD TO CALL K DISPLAY FOR DSC JOB. K DISPLAY
*         IS USED FOR COMMUNICATING WITH NOS/VE ENVIRONMENT FROM
*         NOS. THE DISPLAY AND INPUT BUFFER ARE UPDATED AND READ
*         RESPECTIVLY BY DSIR ROUTINES CALLED BY DSC.
*
*         ENTRY  - FROM ISWL PROCEDURE, USES ZSMRENT AND ZSMRRET
*                  ROUTINES TO SAVE AND RESTORE THE ISWL ENVIRONMENT.
*
*         EXIT   - K DISPLAY IS REQUESTED AS PER REQUEST DESCRIPTOR
*                  DSCKDSPL.
*
*         NOS/BE USES THE L DISPLAY INSTEAD OF THE K DISPLAY
*
*
*         MSG TEXT DURING DSTRT
*
 DSCKDSPL VFD    24/KINPB,18/0,18/KDISPBC
 NOSSYS1  IF     DEF,RA.ORG
*
*         CALL L DISPLAY FOR NOS/BE
 CALLL    VFD    12/KINPB,48/8RLDISPLAY
 LDISPL   DIS    ,*$ASSIGN L-DISPLAY*
*
*         CONSTANTS FOR NOS/BE L DISPLAY
*
 NLINE    EQU    23          NUMBER OF ACTIVE LINES IN BUFFER
 WCOUNT   EQU    7           WORD COUNT PER LINE
 CHSIZE   EQU    1           CHARACTER SIZE
 XCOORD   EQU    6000B       X-COORDINATE
 YSTART   EQU    7460B       Y-COORDINATE BEFORE FIRST LINE TO DISPLAY
 YDIST    EQU    10B         Y-DISTANCE PER LINE
 NOSSYS1  ENDIF
*
 DISPLAY  BSS    0
          RJ     ZSMRENT     SAVE ISWL ENVIRONMENT
 NOSSYS   IF     -DEF,RA.ORG
 NOSSYS   ELSE
*
*
*         SETUP CONTROL INFORMATION FOR NOS/BE L-DISPLAY OUTPUT BUFFER
*
          SB2    B0          LINE COUNT
          SB7    B0          WORD COUNT IN BUFFER
          SB3    NLINE       NUMBER OF LINES IN BUFFER
          SX2    WCOUNT      WORD COUNT IN LINE
          SB4    X2          NUMBER OF WORDS PER LINE
          R=     X5,CHSIZE   CHARACTER SIZE
          LX2    54
          LX5    48
          BX4    X2+X5
          MX0    36
          SX5    XCOORD      X-COORDINATE
          LX5    36
          BX4    X4+X5
          SX5    YSTART      Y-COORDINATE BEFORE FIRST LINE TO DISPLAY
          SX3    YDIST
 NBEDISP  IX7    X5-X3       CURRENT Y-COORDINATE
          BX5    X7
          LX7    24
          BX7    X4+X7       CONTROL INFO FOR CURRENT DISPLAY LINE
          SA2    KDISPB+B7   EXCHANGE INFO IN CURRENT LINE
          BX2    -X0*X2
          BX7    X2+X7
          SA7    A2
          SB2    B2+B1       UPDATE COUNTERS
          SB7    B7+B4
          LT     B2,B3,NBEDISP
          BX6    X6-X6
          SA6    KDISPBC
          SA1    CALLL       ACTIVATE L DISPLAY
          BX6    X1
          SA6    RA.CCD
          MESSAGE LDISPL,LOCAL,R
 NOSSYS   ENDIF
          JP     ZSMRRET     RESTORE ISWL ENVIRONMENT AND RETURN
*
*         K DISPLAY INPUT BUFFER.
*
 KINPB    BSS    0
          DATA   60H
          DATA   4C
*
*         DISPLAY BUFFER(S).
*
KDISPBC   VFD    18/140B,18/KTITLE,24/0 CONTROLWORD 64 CHARS/LINE CODED
KDISPB    BSS    0
LINES23   DUP    23
          VFD    24/4R    ,12/6000B,24/4R
          DATA   56C
LINES23   ENDD
          BSSZ   21*7
          CON    0
KTITLE    BSS    0
          DATA   16C
          EJECT
*         CALLSDA - CALL SYSTEM DEADSTART ASSIST.
*
*         ENTRY  - FROM ISWLCC PROCEDURE.
*                  HELPERPP - DSC JOB COMMUNICATION TABLE IS AT PPHELPT.
*
*         EXIT   - ZSMRRET ROUTINE IS USED TO RESTORE ISWLCC ENV.
*
 CALLSDA  BSS    0
          RJ     ZSMRENT     SAVE ISWLCC ENVIRONMENT
          BX5    X1
          SA3    X2          CLEAR COMPLETION BIT
          MX6    -12
          BX6    X6*X3
          SA6    A3
          LX5    6
          SYSTEM SDA,R,A3,X5
          JP     ZSMRRET     RESTORE ISWL ENVIRONMENT AND RETURN

 CSDAP    VFD    12/0,24/0,24/0
          SPACE  3,15
*         GETMAB - GET MACHINE ATTRIBUTE BLOCK.
*
*         ENTRY  - FROM CYBIL PROCEDURE.
*                  PARM0 = ENTRY BLOCK.
*
*         EXIT   - ZSMRRET ROUTINE IS USED TO RESTORE CYBIL ENV.
 GETMAB   BSS    0
          RJ     ZSMRENT     SAVE ISWL ENVIRONMENT
          SX6    B1
          LX6    40D
          SA6    X1          LENGTH 20B
          CESAB  X1,1
          JP     ZSMRRET

 NOSSYS   IF     -DEF,RA.ORG
 OPL      XTEXT  COMCCVL
 NOSSYS   ENDIF

          SPACE  3,15
*         CALLVER - MAKE REQUEST TO VER.
*
*         ENTRY  - FROM CYBIL PROCEDURE.
*                  PARAM1 = REQUEST BLOCK.
*                  PARAM2 = REQUEST CODE.
*                  PARAM3 = WAIT FOR COMPLETION FLAG.
*
*         EXIT   - ZSMRRET ROUTINE USED TO RESTORE ENVIRONMENT.
*
CALLVER   BSS    0
          RJ     ZSMRENT     SAVE ISWL ENVIRONMENT
          SX5    3RVER
          LX2    18+6
          BX6    X1+X2
          ZR     X3,CALLVR1
          PX5
CALLVR1   LX5    42D
          BX6    X6+X5
          RJ     =XSYS=
          JP     ZSMRRET
          SPACE  3,15
*         JCRGET - GET JOB CONTROL REGISTERS INTO JCR WORD.
*
*         ENTRY  - FROM ISWLCC PROCEDURE.
*
*         EXIT   - R1,R2,R3 AND ERROR REGISTERS ARE SET INTO JCR.
*
 JCRGET   BSS    0
          RJ     ZSMRENT     SAVE ISWL ENVIRONMENT
          SA1    JCR
          MX6    59D
          BX6    X6*X1
          SA6    A1
          GETJCI JCR
          JP     ZSMRRET     RESTORE ISWL ENVIRONMENT AND RETURN
          SPACE  3,15
*         JCRSET - SET JOB CONTROL REGISTERS FROM JCR WORD.
*
*         ENTRY  - FROM ISLCC PROCEDURE.
*
*         EXIT   - R1,R2,R3 AND ERROR REGISTERS ARE SET FROM JCR.
*
 JCRSET   BSS    0
          RJ     ZSMRENT     SAVE ISWL ENVIRONMENT
          SA1    JCR
          MX6    59D
          BX6    X6*X1
          SA6    A1
          SETJCI JCR
          JP     ZSMRRET     RESTORE ISWL ENVIRONMENT AND RETURN
          SPACE  3,15
*         CYCLE  - PLACE JOB INTO PERIODIC RECALL.
*
*         REQUEST MONITOR TO PLACE JOB INTO PERIODIC
*         RECALL. USED TO CYCLE DSC.
*
*         ENTRY  - FROM ISWLCC PROCEDURE.
*
*         EXIT   - ZSMRRET ROUTINE IS USED TO RESTORE ISWLCC ENV.
*
WAKEUP    BSS    0
          RJ     ZSMRENT     SAVE ISWL ENVIRONMENT
          RECALL
          JP     ZSMRRET     RESTORE ISWL ENVIRONMENT
          SPACE  3,15
*         GTDTTM - GET DATE AND TIME FROM OS.
*
*         ENTRY  FROM CYBIL PROCEDURE.
*                PARAM1 = VARIABLE ADDRESS OF DATE.
*                PARAM2 = VARIABLE ADDRESS OF TIME.
*
*         EXIT   - ZSMRRET ROUTINE USED TO RESTORE ENVIRONMENT.
*
 GTDTTM   BSS    0
          RJ     ZSMRENT
          DATE   X1
          CLOCK  X2
          EQ     ZSMRRET
 OKEXIT   SPACE  3,15
*         OKEXIT - EXIT TO ZSMRRET AFTER SETTING EXITCD.
*
 OKEXIT   SX6    B1          ASSUME OK
          ZR     X0,OKE1     IF NO ERROR
          SX6    B0
 OKE1     SA6    EXITCD
          JP     ZSMRRET     RETURN TO CYBIL
 RT       SPACE  3,15
*         RT - DEFINE THE RT INSTRUCTION.
*
 RTX,X,Q  OPDEF  P1,P2,K
+         VFD    9/017B,3/P1,3/P2,15/K,30/0
          ENDM
 COMSCVS  SPACE  3,15
*copyc COMSCVS
 UPKDIS   SPACE  3,15
*         UPKDIS - UPDATE K DISPLAY IN NOS TRAP HANDLER.
*
*         ENTRY  FROM CYBIL PROCEDURE.
*
*         EXIT   TO OKEXIT  TO RESTORE ENVIRONMENT.
*
 UPKDIS   BSS    0
          RJ     ZSMRENT     SAVE ENVIRONMENT
          SA3    KDISPBC     CLEAR THE ALTERNATE SPACING BIT
          MX4    1
          LX4    47-59
          BX6    -X4*X3
          SA6    A3
          BX2    X1
          SX1    KINPB
          RT     X1,X2,CVSKDIS K-DISPLAY REQUEST TO OSANTH
          JP     OKEXIT      RETURN
 GETVEST  SPACE  3,15
*         GETVEST- GET THE STATUS OF NVE.
*
*         ENTRY  FROM CYBIL PROCEDURE.
*
*         EXIT   TO OKEXIT  TO RESTORE ENVIRONMENT.
*
 GETVEST  BSS    0
          RJ     ZSMRENT     SAVE ENVIRONMENT
          RT     X6,X0,2002B STATUS NVE
          SA6    X1          SAVE STATUS
          JP     OKEXIT      RETURN
 DSTCPU   SPACE  3,15
*         DSTCPU - DEADSTART CPU.
*
*         ENTRY  FROM CYBIL PROCEDURE.
*                PARAM1 = TYPE OF DEADSTART.
*
*         EXIT   TO OKEXIT  TO RESTORE ENVIRONMENT.
*
 DSTCPU   BSS    0
          RJ     ZSMRENT     SAVE ENVIRONMENT
          NZ     X1,DST1
          RT     X0,X0,CVSSCPU DEADSTART TO DUAL STATE
          JP     OKEXIT

 DST1     RT     X0,X0,CVSRVT  DEADSTART TO STANDALONE
          JP     OKEXIT
          SPACE  3,15
**        MINILNK - PROCESS CALLS TO THE MINILINK.
*
*         ENTRY  FROM CYBIL PROCEDURE.
*                PARAM1 = ADDRESS OF HEADER BLOCK.
*                PARAM2 = ADDRESS OF DATA BLOCK.
*
*         EXIT   CALL TO EI/TRAP HANDLER MADE.

 MINILNK  BSS    0
          RJ     ZSMRENT     SAVE ENVIRONMENT
          RT     X1,X2,CVSCPCM MAKE MINILINK REQUEST
          JP     OKEXIT      RETURN
 SETEIAD  SPACE  3,15
*         SETEIAD - SET EI PVA.
*
*         ENTRY  FROM CYBIL PROCEDURE.
*                PARAM1 = TYPE OF PVA TO SET IN EI.
*                PARAM2 = WORD ADDRESS TO SET IT TOO.
*
*         EXIT   TO OKEXIT  TO RETURN.
*
 SETEIAD  BSS    0
          RJ     ZSMRENT
          RT     X1,X2,CVSCPVA HAVE EI INITIALIZE PVA
          JP     OKEXIT
 GETEIAD  SPACE  3,15
**        GETEIAD - GET EI PVA VALUE.
*
*         ENTRY  FROM CYBIL PROCEDURE.
*                PARM1 = TYPE OF PVA TO GET FROM EI.
*                PARM2 = ADDRESS OF VARIABLE TO STORE.
*
*         EXIT   TO OKEXIT TO RETURN.

 GETEIAD  BSS    0
          RJ     ZSMRENT
          RT     X1,X6,CVSFPVA GET PVA VALUE FROM EI
          SA6    X2          SAVE PVA VALUE
          JP     OKEXIT
          SPACE  4
**        GETTIME - GET SECONDS SINCE DEADSTART
*
*         ENTRY  FROM CYBIL PROCEDURE.
*                PARM1 = ADDRESS TO STORE SECONDS SINCE DEADSTART.
*
*         EXIT   TO OKEXIT TO RETURN.

 GETTIME  BSS    0
          RJ     ZSMRENT     SAVE ENVIRONMENT
          SX4    X1
          RTIME  X4          GET SECONDS SINCE DEADSTART
          SA1    X4
 NOS      IF     -DEF,RA.ORG
          BX6    X1          ISOLATE SECONDS
          AX6    36
 NOS      ELSE
          MX2    -35
          BX6    -X2*X1      ISOLATE SECONDS*4096
          AX6    -12
 NOS      ENDIF
          SA6    A1          RETURN SECONDS
          JP     ZSMRRET
          SPACE  3,15
*         ENDPRGR - TERMINATE CURRENT PROGRAM.
*
*         ENTRY - FROM CYBIL PROCEDURE, ITS ENVIRONMENT IS NOT SAVED.
*
*         EXIT  - TO MONITOR.
*
 ENDPRGR  BSS    0
          IF     DEF,RA.ORG,4
 OPL      XTEXT  SSYS
          SFCALL EXIT,R
          MX6    0
          SA6    RA.SSID
          ENDRUN
          IF     DEF,RA.ORG,2
 EXIT     CON    SF.EXIT
          CON    0
          END
*DECK DECK=DSA$FETCH_BUFFER_CONTROLWARE EXPAND=TRUE
          IDENT  DSAFBCW
          SST
          SYSCOM B1
          LIST   F
          SPACE  4,10
          EXT    ZSMRRET,ZSMRENT,PARSV
          SPACE  4,10
          TITLE  DSA$FETCH~BUFFER~CONTROLWARE
**        LOADBC - FETCH BUFFER CONTROLWARE FROM NOS.
*
*         CALL
*           LOADBC (CHANNEL, ^BUFFER, ^BUFFER_LENGTH, ^STATUS);


          ENTRY  LOADBC
 LOADBC   BSS    0
          RJ     ZSMRENT     DECODE PARAMETERS
          SKIP   RA.MTR
          ERR    SYSCOM  NOT CALLED
          IF     DEF,RA.ORG,3
          MX7    0           LOADBC WAS CALLED BY CHANNEL NUMBER
          SA7    CALLFLG
          RJ     BCLOAD      READ CONTROLWARE FILE
          IF     -DEF,RA.ORG,3
          RJ     GCN         GET CONTROLWARE NAME
          NZ     B5,LBC1     IF NAME NOT FOUND
          RJ     RCF         READ CONTROLWARE FILE
          NZ     B5,LBC1     IF CONTROLWARE NOT FOUND
          SA1    CWI         GET CONTROLWARE INDEX
          SB2    X1
          SA1    CWNAME+B2   GET PACKING INFO
          SB2    X1
          RJ     RPC         RE-PACKAGE CONTROLWARE
 LBC1     SX6    B5
          SA1    STATUS
          SA6    X1          SAVE STATUS
          IF     -DEF,RA.ORG,1
          RETURN IN
          JP     ZSMRRET     RETURN TO CYBIL ROUTINE
 LOADBC   SPACE  4,10
**        FILE ENVIRONMENT TABLE.


 IN       BSS    0
 SYSTEM   RFILEB 0,5000,(FET=9)
 LOADBC   SPACE  4,10
**        CONTROL STORAGE CELLS.


 CHN      EQU    PARSV+0     CHANNEL NUMBER
 BUFA     EQU    PARSV+1     BUFFER ADDRESS
 BUFL     EQU    PARSV+2     BUFFER LENGTH
 STATUS   EQU    PARSV+3     STATUS
 CRN      CON    0           CONTROLWARE RECORD NAME LEFT JUSTIFIED
 CWI      CON    0           CONTROLWARE INDEX
 CWL      CON    0           CONTROLWARE LENGTH
 FWC      CON    0           FWA OF CONTROLWARE
 LWC      CON    0           LWA+1 OF CONTROLWARE
 RCF      SPACE  4,15


**        LOADBCN - FETCH BUFFER CONTROLWARE BY NAME FROM NOS.
*
*         CALL
*           LOADBCN (NAME, ^BUFFER, ^BUFFER_LENGTH, ^STATUS);


          ENTRY  LOADBCN
 LOADBCN  BSS    0
          RJ     ZSMRENT     DECODE PARAMETERS
          SA1    INDEX       GET CONTROLWARE INDEX
          SB2    X1
          SA1    B2+CWNAME   GET CORRESPONDING NAME
          MX7    42          MASK OUT NAME
          BX6    X1*X7
          SA6    CRN
          IF     DEF,RA.ORG,3
          SX7    B1          LOADBCN WAS CALLED BY NAME
          SA7    CALLFLG
          RJ     BCLOAD      READ CONTROLWARE FILE
          IF     -DEF,RA.ORG,1
          RJ     RCF         READ CONTROLWARE FILE
          NZ     B5,LBCN1    IF CONTROLWARE NOT FOUND
          SA1    INDEX
          SB2    X1
          SA1    B2+CWNAME   GET PACKING INFO
          SB2    X1
          RJ     RPC         RE-PACKAGE CONTROLWARE
 LBCN1    SX6    B5
          SA1    STATUS
          SA6    X1          SAVE STATUS
          IF     -DEF,RA.ORG,1
          RETURN IN
          JP     ZSMRRET     RETURN TO CYBIL ROUTINE
 LOADBC   SPACE  4,10
**        FILE ENVIRONMENT TABLE.


 LOADBCN  SPACE  4,10
**        CONTROL STORAGE CELLS.


 INDEX    EQU    PARSV+0     CONTROLWARE NAME
 CWNAME   BSS    0
          LOC    0
          CON    0
 ISD      VFD    42/0LISD,18/1
 CMD      VFD    42/0LCMD,18/0
 CM2      VFD    42/0LCM2,18/0
 MA464    VFD    42/0LMA464,18/1
 CW63X    VFD    42/0LCW63X,18/0
 BCS      VFD    42/0LBCS,18/1
 BCF      VFD    42/0LBCF,18/1
 FMD      VFD    42/0LFMD,18/1
 ADP      VFD    42/0LADP,18/1
 PHD      VFD    42/0LPHD,18/1
          LOC    *O

 CALLFLG  CON    0           =1 IF LOADBCN WAS CALLED BY NAME
*                            =0 IF LOADBC WAS CALLED BY CHANNEL NUMBER




 NOSSYS1  IF     -DEF,RA.ORG
 RCF      SPACE  4,15

**        RCF - READ CONTROLWARE FILE.
*
*         EXIT   (B5) = 0, IF VALID CONTROLWARE FILE READ.
*                (B5) .NE. 0, IF ERROR ENCOUNTERED.
*
*         USES   X - ALL.
*                A - 1, 2, 3, 6, 7.
*                B - 2, 3, 4, 5, 6.
*
*         MACROS ASSIGN, READ, REWIND, SKIPB, SKIPEI, STATUS.


 RCF      SUBR               ENTRY/EXIT

*         SET BUFFER POINTERS IN FET.

          SA2    BUFA        BUFFER ADDRESS
          SA3    A2+B1       BUFFER LENGTH
          SX6    X2
          SA1    IN+1        FIRST
          MX4    42
          SA3    X3
          BX7    X4*X1
          IX7    X2+X7
          SA6    A1+B1       STORE IN
          SA7    A1          STORE FIRST
          SA6    A6+B1       STORE OUT
          IX6    X6+X3
          SA6    A6+B1       STORE LIMIT

*         ASSIGN SYSTEM FILE.

          ASSIGN IN
          SKIPEI IN,R        POSITION TO EOI
          SKIPB  IN,2,R      POSITION TO BEGINNING OF DIRECTORY
          READ   IN,R        READ DIRECTORY
          SA1    X2+B1       FETCH BUFFER ADDRESS *FIRST*
          SA2    A1+B1       READ *IN* POINTER
          SB2    X1
          SA3    B2          LENGTH OF 7700 TABLE
          SB3    X2+         (B3) = LWA+1 OF DATA READ
          SA2    CRN
          LX3    24
          SB2    B2+X3       FIRST RECORD ON SYSTEM DIRECTORY
          MX7    42
 RCF1     SA1    B2+         READ DIRECTORY ENTRY
          LT     B2,B3,RCF2  IF NOT END OF DIRECTORY
          SB5    1           SET RESPONSE CODE
          EQ     RCFX        EXIT

 RCF2     BX3    X7*X1
          BX3    X3-X2
          NZ     X3,RCF3     IF CONTROLWARE NOT FOUND
          BX1    -X7*X1
          SX1    X1-10
          ZR     X1,RCF4     IF CONTROLWARE FOUND
 RCF3     SB2    B2+2
          EQ     RCF1        TEST IF NEXT ENTRY

 RCF4     SA1    A1+B1       SET RANDOM ADDRESS IN FET
          MX7    -29
          SA2    IN+6
          BX2    X7*X2
          BX6    -X7*X1
          BX6    X6+X2
          SA6    A2
          SA1    IN+2        RESET *IN* = *FIRST*
          SA2    IN+1
          MX7    -18
          BX2    -X7*X2
          BX1    X7*X1
          BX6    X1+X2
          SA6    A1

*         READ CONTROLWARE RECORD

          READ   IN,R        READ CONTROLWARE RECORD
          SA1    IN+2        READ *IN* POINTER
          SA2    A1+B1       READ *OUT* POINTER
          SB2    X2
          SA3    B2
          SB6    X1          SAVE *IN*
          MX0    12
          MX1    6           FORM 7700 MASK
          BX2    X0*X3
          SB5    2
          BX1    X1-X2
          NZ     X1,RCFX     IF NOT 7700 TABLE
          LX3    12
          BX2    X0*X3       LENGTH OF 7700 TABLE
          SB5    3
          LX2    12
          SB3    X2+B1
          SA2    B2+B3       READ EXPECTED 5200 TABLE
          SX3    5200B
          SX6    A2+B1       FWA OF CONTROLWARE
          SA6    FWC
          SB2    X6          *OUT* = FWA OF CONTROLWARE
          SX6    X2-1        SUBTRACT LENGTH OF 5200 TABLE
          SX7    A2
          IX7    X2+X7       ADD CONTROLWARE LENGTH
          SB4    X6
          BX2    X0*X2
          SA7    LWC         SAVE LWA+1 OF CONTROLWARE
          LX2    12
          BX2    X2-X3
          NZ     X2,RCFX     IF NOT 5200 TABLE
          SB6    B6-B2       *IN* - *OUT*
          SB6    B6-B4
          SB5    4
          NZ     B6,RCFX     IF CM WORD COUNT DOES NOT MATCH
          SB5    B0+
          SA6    CWL         SAVE CONTROLWARE LENGTH
          EQ     RCFX        EXIT
 NOSSYS1  ENDIF
 RPC      SPACE  4,10
**        RPC - REPACKAGE CONTROWARE.
*
*         ENTRY  (BUFA) = PLACE TO STORE CONTROLWARE.
*                (FWC) = FWA OF UNPACKED CONTROLWARE.
*                (CWL) = LENGTH OF CONTROLWARE IN WORDS.
*
*         EXIT   CONTROLWARE PACKED 8 IN 8.


 RPC      SUBR               ENTRY/EXIT
          NZ     B2,RPC2     IF REPACKAGING TO BE DONE
          SA1    CWL         GET CONTROLWARE LENGTH
          SA2    BUFL
          BX6    X1
          SA6    X2          RETURN LENGTH

          SB2    B0          PREPARE TO MOVE
          SA1    FWC         CONTROLWARE
          SA2    X1          TO BUFFER MINUS
          SA3    CWL         ITS HEADER
          SB3    X3
          SA3    BUFA
          SA1    X3
 RPC0     SA4    A2+B2       GET SOURCE
          BX6    X4
          SA6    A1+B2       REPLACE TO DESTINATION
          SB2    B2+1
          GT     B2,B3,RPCX  IF DONE
          EQ     RPC0

 RPC2     SA1    RPCA
          SA2    A1+B1
          BX6    X1
          BX7    X2
          SA6    GTN         PRESET GET NIBBLE
          SA7    A6+B1
          JP     GTN         ENTER CO-ROUTINES

 GTN      EQ     STN0        STORE NIBBLE
 STN      EQ     GTN0        GET NIBBLE
          EQ     GTN

 RPC1     SX2    0
          RJ     STN         STORE NIBBLE
          SB3    15
          LT     B5,B3,RPC1  WAIT UNTIL LAST WORD IS STORED
          SX6    B2
          SA1    BUFL
          SA6    X1          SAVE DATA LENGTH
          SB5    B0          EXIT WITHOUT ERROR
          EQ     RPCX        RETURN

 RPCA     EQ     STN0        INITIAL CO-ROUTINE ADDRESSES
          EQ     GTN0

*         CO-ROUTINE TO GET NIBBLES FROM UNPACKED CONTROLWARE.

 GTN0     SA2    FWC         START OF CONTROLWARE
          SA3    CWL         CONTROLWARE LENGTH IN WORDS
          SA2    X2-1
          SB3    X3
 GTN1     SB4    4           NUMBER OF 8 BIT BYTES IN WORD
          SA2    A2+B1
          SB3    B3-B1
          NG     B3,RPC1     IF END OF DATA
 GTN2     LX2    4
          RJ     STN         STORE NIBBLE
          LX2    4
          RJ     STN         STORE NIBBLE
          SB4    B4-B1
          LX2    4
          PL     B4,GTN2     IF MORE DATA IN WORD
          EQ     GTN1        FETCH NEXT WORD

*         CO-ROUTINE TO STORE NIBBLES INTO BUFFER.

 STN0     SA1    BUFA        ADDRESS OF BUFFER
          SB2    B0
          MX5    4
 STN1     SB5    15          NIBBLES IN PACKED WORD
          SX6    0
 STN2     RJ     GTN         GET NIBBLE
          BX7    X5*X2       ISOLATE NIBBLE
          BX6    X6+X7
          SB5    B5-B1
          LX6    4
          NZ     B5,STN2     IF MORE NIBBLES TO STORE
          SA6    X1+B2
          SB2    B2+B1
          EQ     STN1        CONTINUE
 GCN      SPACE  4,10
 NOSSYS2  IF     -DEF,RA.ORG
**        GCN - GET CONTROLWARE NAME.
*
*         EXIT   (B5) .NE. ZERO IF NAME NOT FOUND.
*                (B5) = 0 IF NAME OBTAINED.
*                (CRN) = CONTROLWARE RECORD NAME.
*
*         USES   X - 1, 2, 4, 5, 6, 7.
*                A - 1, 4, 5, 6, 7.
*                B - 2, 3, 4, 5, 7.
*
*         MACROS SYSTEM.


 GCN      SUBR               ENTRY/EXIT
          SA1    CBUF
          PL     X1,GCN5     IF TABLES ALREADY OBTAINED
          SYSTEM RSB,R,GCNC,0
          SA1    GCNB        GET FWA OF CHANNEL TABLES
          MX2    -18
          AX1    12
          SA4    GCNA
          BX3    -X2*X1
          SX3    X3+CTALL*2
          LX3    18          POSITION FWA OF CHANNEL TABLES
          BX6    X3+X4
          SA6    A4
          SYSTEM RSB,R,GCNA,0  READ CHANNEL TABLES
 GCN5     SA5    CHN         GET CHANNEL NUMBER
          SB2    B0
 GCN6     SX5    X5-5        DIVIDE BY 5 LOOP
          NG     X5,GCN7     IF DIVIDE COMPLETE
          SB2    B2+B1
          EQ     GCN6        CONTINUE DIVIDE

 GCN7     SB3    X5+6        SAVE BYTE INDEX FOR CONTROLWARE TABLE
          SA1    CBUF+B2
 GCN8     LX1    12
          SB3    B3-B1
          NZ     B3,GCN8     IF CHANNEL NOT IN CORRECT POSITION
          MX5    -4
          BX1    -X5*X1      GET CONTROLLER TYPE INDEX
          SB3    X1
          SA1    B3+GCND     GET CONTROLWORD RECORD NAME
          NZ     X1,GCN9     IF CONTROLWARE ON CHANNEL
          SB5    5
          EQ     GCNX        EXIT

GCN9      SB2    X1
          SX6    B2
          SA6    CWI         SAVE INDEX
          MX7    42          KEEP JUST NAME
          BX6    X1*X7
          SA6    CRN
          SB5    B0
 GCN11    EQ     GCNX        EXIT


 GCNA     VFD    12/0,12/CTALL,18/0,18/CBUF

 GCNB     CON    -1          TEMPORARY BUFFER
 GCNC     VFD    12/0,12/1,18/CHTP,18/GCNB
 NOSSYS2  ENDIF


**        TABLE OF CONTROLWARE TYPES.

 GCND     BSS    0
          LOC    0
          CON    0               0 - NO CONTROLWARE
          VFD    42/0LBCS,18/BCS 1 - HT (7054/7154/7152)
          VFD    42/0LBCF,18/BCF 2 - FT (7154/7152)
          VFD    42/0LFMD,18/FMD 3 - FMD (7155)
          VFD    42/0LADP,18/ADP 4 - FSC ADAPTER
          VFD    42/0LPHD,18/PHD 5 - DEMA/AFMD (7155-10)
          VFD    42/0L170,18/0   6 - CYBER 170 NAD
          CON    0               7 - UNUSED (NO CONTROLWARE)
          CON    0               10- UNUSED (NO CONTROLWARE)
          CON    0               11- UNUSED (NO CONTROLWARE)
          CON    0               12- UNUSED (NO CONTROLWARE)
          CON    0               13- UNUSED (NO CONTROLWARE)
          CON    0               14- UNUSED (NO CONTROLWARE)
          CON    0               15- UNUSED (NO CONTROLWARE)
          CON    0               16- UNUSED (NO CONTROLWARE)
          CON    0               17- UNUSED (NO CONTROLWARE)
          LOC    *O
 CBUF     CON    -1          CHANNEL TABLE BUFFER
          IF     -DEF,RA.ORG,1
          BSS    CTALL
 BCLOAD   TITLE  INTRODUCTION
 NOSSYS3  IF     DEF,RA.ORG
*****     BCLOAD - A CPU UTILITY PROGRAM TO BE USED TO DOWN LOAD
*                BINARY CONTROLWARE INTO A 7021, 7054, 7152, 7154,
*                7155, OR NETWORK ACCESS DEVICE (NAD) TYPE CONTROLLER.
*
*         AUTHOR - DIAGNOSTIC AND MAINTENANCE PROGRAMMING
*                  LARGE SYSTEMS DIAGNOSTICS
*                  CUSTOMER ENGINEERING DIVISION
*         MODIFIED BY NOS/BE DEVELOPMENT - 1980.
*         MODIFIED BY G.D. MELBY TO SUPPORT NAD CONTROLWARE LOADING -
*                MAY, 1981.
*         MODIFIED BY NOS/BE DEVELOPMENT TO SUPPORT NOS/BE DUAL STATE -
*                APRIL, 1984.
*
*                DESCRIPTION
*
*                -BCLOAD- IS A CENTRAL PROCESSOR PROGRAM WRITTEN IN THE
*                6000 COMPASS ASSEMBLY LANGUAGE.
*                FOR ALL TYPES OF CONTROLLERS DLL IS CALLED TO
*                FIND THE CONTROLER TYPE.
*
*                THIS VERSION IS STRONGLY SHORTENED AND MODIFIED TO
*                MEET THE REQUIREMENTS OF NOS/BE DUAL STATE.
*                IT READS CONTROLWARE INTO CM BUFFER AND DOES NOT
*                LOAD IT INTO THE CONTROLLER. ENGINEERING MODE IS
*                NOT NECESSARY.
*                THE CONTROLWARE WILL BE READ FROM FILE ZZZZZ04 INTO
*                CM BUFFER.
*
          SPACE  3
***              CONTROL POINT AND DAYFILE MESSAGES.
*
*                    - EQUIPMENT NOT FOUND IN THE EST.
*                         THE DEVICE SPECIFIED BY THE ADDRESS 30 CARD
*                         MUST HAVE AN EQUIPMENT STATUS TABLE ENTRY
*                         OR -BCLOAD- WILL ABORT.
*
*                    - FILE READ IS NOT O.S. CONTROLWARE.
*                         THE FILE READ DID NOT CONTAIN CONTROLWARE
*                         FOR AN OPERATING SYSTEM.
*
*                    - FILE READ IS NOT XXXX CONTROLWARE
*                         XXXX = 7021,7054,7154, OR 7155
*                         THE FILE READ DID NOT CONTAIN CONTROLWARE
*                         APPROPRIATE FOR THE CHANNEL SPECIFIED
*
 BCLOAD   TITLE  PARAMETER BUFFER DESCRIPTIONS
**
*         DESCRIPTION OF THE PARAMETER BUFFER AREA, PARS.
*
*                59      47      35      23   17   11   5    0
*                +-------+-------+-------+----+----+----+----+
*         PARS   *     DLL  *                  * PARS ADDRESS*   0
*                +--------------------------------------------
*         DLEA   *  * CH*                      * DLEA ADDRESS*   1
*                +-------------------------------------------+
*         DLEB   *                                 * ET    *C*   2
*                +--------------------------------------------
*
*         DESCRIPTION OF PARAMETER BUFFER AREA - PARS.
*
*         WORD 0 PARS
*                CONTAINS THE RA+1 REQUEST.  BYTES 0 AND 1 CONTAIN
*                THE PP PROGRAM NAME (DLL) LEFT JUSTIFIED. BYTES 3 AND
*                4 CONTAIN THE ADDRESS OF PARS RIGHT JUSTIFIED.
*         WORD 1 DLEA
*                CH=CHANNEL NUMBER IN BITS 48-53.  BYTES 3 AND 4 CONTAIN
*                THE ADDRESS OF DLEA.
*         WORD 2 DLEB
*                STATUS RESPONSE FROM DLL
*                OR
*                ET=EQUIPMENT TYPE REQUEST, IF BIT 11 SET.
*                   DLL RETURNS EQUIPMENT TYPE TO CALLING PROGRAM
*                   ONLY AND EXITS WITHOUT LOADING CONTROLWARE.
*                   SYSTEM ORIGIN OF CALLING PROGRAM OR ENGINEERING
*                   MODE IS NOT NECESSARY.
*                C =COMPLETE BIT (IF ETFLAG IS SET)
*
*         DESCRIPTION OF STATUS RESPONSES RETURNED TO BCLOAD BY DLL.
*
*         WORD DLEB:
*                BITS 36-47 CONTAIN A HARDWARE MNEMONIC (AY,AZ,AJ,MT OR
*                NT). BITS 23-25 CONTAIN THE CONTROLLER TYPE (1,2,3, OR
*                4). BIT 2 SET NONZERO IF CHANNEL NOT FOUND IN EST.
*                BIT 0 SET NONZERO WHEN DLL COMPLETED TASK.
*
*                   CONTROLLER TYPE (1, 2, 3, OR 4)
*                   1 - 7054, 2 - 7154, 3 - 7155, 4 - 7021.
          SPACE  3
 PARS     VFD    42/3LDLL,18/PARS
 DLEA     VFD    36/0,24/DLEB
 DLEB     VFD    60/0

 LDLPB    VFD    60/1000B          -LDL- PARAMETER BLOCK
 BCLOAD   TITLE  VALIDATE PARAMETER
 BCLOAD   SUBR
          SA1    CALLFLG
          NZ     X1,SYSLOAD      LOADBCN WAS CALLED BY NAME

*         VALIDATE CH PARAMETER

 REL1     SA1    CHN         GET CH PARAMETER (ORIGINAL BCLOAD EXPECTS
*                                CHANNEL NUMBER IN DISPLAY CODE LEFT
*                                JUSTIFIED. THIS MODIFIED CODE EXPECTS
*                                IT IN OCTAL RIGHT JUSTIFIED)
          ZR     X1,BADCARD  CH NOT SPECIFIED
          BX5    X1
          MI     X5,BADCARD  CH NOT NUMERIC
          SX4    X5-34B
          PL     X4,BADCARD  CH TOO LARGE
          SX3    X5-14B
          MI     X3,REL2     CH BETWEEN 0 AND 13
          SX4    X5-20B
          MI     X4,BADCARD  CH BETWEEN 14 AND 19,ERROR
 REL2     LX5    48          POSITION CH
          SA1    PARS+B1
          BX6    X5+X1       ADD IN CH
          SA6    A1          RESTORE

 BCLOAD   TITLE  CALL DLL
**        THE FOLLOWING ROUTINE WILL VALIDATE DLL ON NOS/BE.
*         DLL WILL BE CALLED TO CHECK THE EST FOR A DISK OR TAPE
*         CHANNEL AND/OR MAINTENANCE OPERATION.
*         BCLOAD WILL FORMAT THE CALL WORD *DLEA* AS FOLLOWS....
*
*         **CC,****,****,**AA,AAAA
*         CC IS A CHANNEL NUMBER  MNEMONIC, AND
*         AA,AAAA IS THE ADDRESS OF DLEB
*
*         BCLOAD SETS BIT 11 IN DLEB. THIS FLAGS THAT THE EQUIPMENT
*         TYPE SHOULD BE RETURNED ONLY AND THE BUFFER CONTROLWARE WILL
*         NOT BE LOADED INTO THE CONTROLLER.
*         IN CASE OF A NOS/VE TAPE UNIT THE CHANNEL # IS NOT IN THE
*         EST BUT IN THE URT, AND DLL SIGNALS -EQ NOT FOUND IN EST-.
*         THIS CONDITION IS RETURNED (WITHOUT ERROR) TO NOS/VE.
*         SIDE EFFECT: 66X UNITS CANNOT BE USED BY NOS/VE.
*
*         DLL WILL RETURN ITS PARAMETERS IN DLEB AS FOLLOWS....
*
*            2**0 SET   = DLL HAS COMPLETED EST SEARCH
*            2**1 CLEAR = EQUIPMENT FOUND IN EST
*            2**1 SET   = EQUIPMENT NOT FOUND IN EST
*            BITS 24-26 = CONTROLLER TYPE (1,2,3, OR 4)
*            BITS 36-47 = HARDWARE MNEMONIC


*CALLDLL  BSS    0                 ENTRY
          MX6    1                 SET ET BIT
          LX6    12
          SA6    DLEB
          SA3    PARS
          BX6    X3
          SYSTEM                   CALL DLL FOR VALIDATION
          RECALL DLEB
          SA1    DLEB
          LX1    58
          PL     X1,SYSLOAD        IF EQUIPMENT FOUND
          SB5    5
          EQ     LBC1
          SPACE  3
**        BADCARD - ISSUE PARAMETER ERROR MESSAGE AND ABORT

 BADCARD  MESSAGE LBKPAR,,R
          EQ     ABT
 BCLOAD   TITLE  CHECK CONTROLWARE SOURCE

**        SYSLOAD - READ THE SYSTEM FIRMWARE INTO CENTRAL AND CHECK.
*
 SYSLOAD  BSS    0
          CLOSE  ZZZZZ04,RETURN,RCL GET RID OF ANY EXISTING FILE
          SA1    LDLPB             LDL PARAMETER BLOCK
          MX0    59
          BX6    X0*X1             CLEAR COMPLETE BIT
          SA6    A1
          SYSTEM LDL,RCL,LDLPB     CALL LDL TO BUILD FNT FOR ZZZZZ04
          SA1    CALLFLG
          ZR     X1,SYSLD3         LOADBC WAS CALLED BY CHANNEL NUMBER
          SB4    4                 NUMBER OF NOS/BE CONTROLLER TYPES
          SA1    CRN               CONTROLWARE NAME
          MX0    18
          BX5    X0*X1
 SYSLD1   SX4    B4
          SA3    GCND+B4           CHECK CONTROLWARE NAME
          BX6    X0*X3
          IX7    X5-X6
          ZR     X7,SYSLD2         CONTROLLER TYPE FOUND
          SB4    B4-B1
          GT     B4,SYSLD1
          EQ     CKCWERR           CONTROLLER TYPE NOT FOUND
 SYSLD2   BX6    X4                SAVE CONTROLLER TYPE
          LX6    24
          SA6    DLEB
          EQ     SYSLD4
 SYSLD3   MX0    -3                LOADBC WAS CALLED BY CHANNEL NUMBER
          SA4    DLEB
          LX4    36
          BX4    -X0*X4            CONTROLLER TYPE
 SYSLD4   SX4    X4-1              OFFSET
          SA4    CONPART+X4
          MX0    18
          BX4    X0*X4             CONTROLWARE DECKNAME
*
 SYSLD5   SA1    ZZZZZ04
          RJ     SETFET            SET UP FET POINTERS
          READSKP ZZZZZ04,,RCL
          SX2    10B               CHECK FOR EOF
          BX1    X2*X1
          SB4    B0                ZERO INDEX INTO MESSAGE ARRAY.
          NZ     X1,CKCWERR        NOT FOUND
*
          SA2    BUFA              OVERLAY NAME
          SA2    X2
          MX0    18
          BX2    X0*X2
          BX2    X2-X4
          NZ     X2,SYSLD5         WRONG RECORD
*
*         CORRECT CONTROLWARE FOUND
*
          SX6    A2+B1             RESET ADDRESS OF BINARY
          BX1    X6
          SA6    FWC               TO SKIP OVERLAY NAME
          SA2    ZZZZZ04+2         LWA+1 (IN POINTER)
          BX7    X2                SAVE LWA+1
          SA7    LWC
          IX6    X2-X6
          SA6    CWL               SAVE LENGTH OF CONTROLWARE

          RJ     SAVEPN            SAVE PART AND VERSION NUMBERS
          SB4    X1
          SX4    B4-B1             CONTROLLER TYPE OFFSET
          SA4    CONPART+X4
          MX0    -21
          BX4    -X0*X4
          SA2    VERSION
          IX5    X2-X4
          SB5    B0
          ZR     X5,BCLOADX
 CKCWERR  SX4    B4
          LX4    2                 MULTIPLY BY 4 TO GET MESSAGE INDEX
          MESSAGE (X4+LEMSG),,R
 ABT      BSS    0
 OPL      XTEXT  SSYS
          SFCALL EXIT,R
          MX6    0
          SA6    RA.SSID
          ABORT
 EXIT     CON    SF.EXIT
          CON    0
*                MESSAGES AND CONTROLWARE IDENTIFICATION
 LEMSG    DIS    ,*FILE READ IS NOT O.S. CONTROLWARE.*
 NDMSG    DIS    ,*FILE READ IS NOT 7054 CONTROLWARE.*
 NFMSG    DIS    ,*FILE READ IS NOT 7154 CONTROLWARE.*
 NFMDMSG  DIS    ,*FILE READ IS NOT 7155 CONTROLWARE.*
 NTMSG    DIS    ,*FILE READ IS NOT 7021 CONTROLWARE.*
          IFEQ   *-NTMSG,4,4
          IFEQ   NTMSG-NFMDMSG,4,3
          IFEQ   NFMDMSG-NFMSG,4,2
          IFEQ   NFMSG-NDMSG,4,1
          IFNE   NDMSG-LEMSG,4,1
P         ERR    MESSAGE LENGTH OR SEQUENCE ERROR.

 CONPART  EQU    *                 CONTROLWARE DECKNAME AND NUMBER
 CON710A  VFD    18/3L0SY,42/1610012B     7054 CONTROLWARE
 CON401A  VFD    18/3L0SZ,42/1000032B     7154 CONTROLWARE
 CON721A  VFD    18/3L0SJ,42/1620032B     7155 CONTROLWARE
 CON434A  VFD    18/3L0MT,42/1030112B     7021 CONTROLWARE

 LBKPAR   DIS    ,* CHANNEL NUMBER  ERROR    *
*
          SPACE  4,8
          EJECT
**        SAVEPN SAVE CONTROLWARE VERSION AND PART NUMBER
*                THE LAST TWO WORDS OF THE CONTROLWARE BINARY CONTAIN
*                THE CONTROLWARE PART NUMBER AND VERSION NUMBER. THE
*                FORMAT OF THESE WORDS FOR THE 7021 AND 7X54 BINARY IS:
*
*                            59    47    35    23    11     0
*                            +-----+-----+-----+-----+------+
*                WORD 3145B  *     *     *     AAAAAA       *
*                            +------------------------------+
*                WORD 3146B  * BB  *    CCCC   *            *
*                            +------------------------------+
*
*                     AAAAAA = UPPER 36 BITS OF THE PART NUMBER
*                     BB = LOWER 12 BITS OF THE PART NUMBER
*                     CCCC = VERSION NUMBER
*                THE FORMAT FOR THE 7155 CONTROLWARE BINARY IS:
*
*                            59    47    35    23    11     0
*                            +-----+-----+-----+-----+------+
*                WORD 5513B  *                       *  XX  *
*                            +------------------------------+
*                WORD 5514B  *     YYYYYY      *     ZZZZ   *
*                            +-------------------------------
*
*                     XX = UPPER 12 BITS OF THE PART NUMBER
*                     YYYYYY = LOWER 36 BITS OF THE PART NUMBER
*                    ZZZZ = VERSION NUMBER
*
*         ENTRY  X1 = FIRST WORD ADDRESS OF CONTROLWARE BINARY
*
*         EXIT   X1 = CONTROLLER TYPE
*                EPN = PART NUMBER
*                VERSION = VERSION NUMBER
*
*         USES   X0,X1,X2,X3,X4,X5,X6
*                A1,A2,A3,A4,A6
*                B1,B4
*

 SAVEPN   SUBR
          SA4    CWL
          SB4    X4                CONTROLWARE LENGTH
          SB4    B4-B1             OFFSET FOR LAST WORD
          SA3    X1+B4             CONTROLWARE VERSION
          MX0    -3
          SA1    DLEB
          LX1    36
          BX1    -X0*X1            CONTROLLER TYPE
          SX5    X1-3              SET TO ZERO IF 7155
          ZR     X5,SAVEPN1        SKIP SHIFT IF 7155
          AX3    24D               RIGHT JUSTIFY VERSION NUMBER
 SAVEPN1  MX0    -21D              MASK OUT VERSION
          BX2    -X0*X3
          BX6    X2
          SA6    VERSION           SAVE
          AX3    24                SHIFT OFF VERSION
          SA2    A3-B1             CONTROLWARE LAST WORD - 1
          ZR     X5,SAVEPN3        JUMP IF 7155
*
*         A3 CONTAINS THE LAST BYTE OF THE PART NUMBER RIGHT JUSTIFIED.
*         A2 CONTAINS THE UPPER 3 BYTES OF THE PART NUMBER RIGHT
*         JUSTIFIED.
*
          LX2    24
          AX2    24                REMOVE UNUSED BITS
          LX2    12                UPPER BYTES
          IX2    X2+X3             ADD LOWER BYTE
          EQ     SAVEPN5
*
*         A3 CONTAINS THE LOWER 3 BYTES OF THE PART NUMBER RIGHT
*         JUSTIFIED.  A2 CONTAINS THE UPPER BYTE OF THE PART NUMBER
*         RIGHT JUSTIFIED.
*
 SAVEPN3  MX0    60-12
          BX2    -X0*X2            REMOVE UNUSED BITS
          LX2    36                SHIFT
          IX2    X2+X3             ADD LOWER BYTES
 SAVEPN5  BX6    X2
          SA6    EPN               SAVE PART NUMBER
          EQ     SAVEPN
          SPACE  4,10
**        SETFET SET UP IN AND OUT POINTER IN FET
*         ENTRY  A1 = FET ADDRESS
*                X1 = CONTENTS OF WORD 1 OF THE FET
*
*         USES   A1,A2,A3,A6,A7
*                X0,X2,X3,X6,X7
*                B1
*

 SETFET   SUBR
          SA2    BUFA
          SX6    X2          START OF BUFFER
          SA2    A1+B1             FIRST POINTER
          MX0    42
          BX7    X0*X2
          BX7    X7+X6
          SA7    A2                NEW 2ND WORD OF FET
          SA6    A7+B1             NEW IN POINTER
          SA6    A6+B1             NEW OUT POINTER
          SA3    BUFL
          SA2    A6+B1
          SA3    X3
          IX6    X6+X3
          BX7    X0*X2
          BX7    X7+X6
          SA7    A2                NEW LIMIT
          MX3    16
          LX3    18
          BX6    -X3*X1
          SA6    A1                CLEAR CODE AND STATUS
          EQ     SETFET

 ZZZZZ04  FILEB  BUFIN,90
 EPN      DATA   0           EQUIP + PART NUMBERS FROM CW BINARY
 VERSION  DATA   0                 CW BINARY VERSION
 BUFIN    EQU    *
 NOSSYS3  ENDIF
          END
*DECK DECK=DSA$HARDWARE_TABLE_DEFINITIONS EXPAND=FALSE
          CTEXT  DSA$HARDWARE TABLE DEFINITIONS.                        
          BASE   M                                                      
 DSAHTD   SPACE  4,10                                                   
***       DSA$HARDWARE TABLE DEFINITIONS.                               
*         G. J. FALCONER.    84/10/23.                                  
 DSAHTD   SPACE  4,10                                                   
**        DSA$HARDWARE TABLE DEFINITIONS.                               
*                                                                       
*         THIS COMMON DECK DEFINES THE VARIOUS MRT DESCRIPTORS USED BY  
*         NOS/VE ROUTINES.  THESE DESCRIPTORS RESIDE IN THE CIP AREA OF 
*         MEMORY AND CAN BE ACCESSED BY ROUTINES CONTAINED IN COMMON    
*         DECK *DSI$GET_HARDWARE_ELEMENT*.                              
*                                                                       
*         WITH THE EXCEPTION OF THE DESCRIPTOR ID-S, ALL EQUATES ARE PP 
*         WORD OFFSETS.                                                 
 IDS      SPACE  4,10                                                   
**        MRT ID CODES.                                                 
                                                                        
                                                                        
 IOUID    EQU    0           IOU DESCRIPTOR                             
 CMID     EQU    1           CENTRAL MEMORY DESCRIPTOR                  
 PROCID   EQU    2           PROCESSOR DESCRIPTOR                       
 PROCID1  EQU    2+10000     PROCESSOR 1 DESCRIPTOR                     
 MAINID   EQU    3           MAINFRAME DESCRIPTOR                       
*FLPPID   EQU    4           FLPP DESCRIPTOR (CYBER 176 ONLY)           
 DISCID   EQU    5           DISPLAY CONSOLE DESCRIPTOR                 
 GPDID    EQU    6           GLOBAL PROCESSOR DATA DESCRIPTOR           
 NULLID   EQU    7           NULL DESCRIPTOR (NOT PRESENT)              
 WCCID    EQU    10          WALL CLOCK CHIP DESCRIPTOR                 
 MDID     EQU    11          MODEL DEPENDENT DESCRIPTOR (S0/S0E ONLY)   
 PMID     EQU    12          PAGE MAP DESCRIPTOR (S0/S0E ONLY)          
 DFTID    EQU    13          DFT DESCRIPTOR                             
 HDR      SPACE  4,10                                                   
**        HDR - HEADER DATA COMMON TO ALL DESCRIPTORS.                  
                                                                        
                                                                        
 HDRSIZE  EQU    0           SIZE OF RECORD                             
 HDRID    EQU    0           ID OF RECORD                               
 HDRPC    EQU    4           PORT CODE                                  
 EID      SPACE  4,10                                                   
**        DEFINITION OF ELEMENT ID.                                     
                                                                        
                                                                        
 EN       EQU    0           ELEMENT NUMBER                             
 EM       EQU    1           MODEL NUMBER                               
 ESU      EQU    1           UPPER 4 BITS OF SERIAL NUMBER              
 ELL      EQU    2           LOWER 12 BITS OF SERIAL NUMBER             
 IOUID    SPACE  4,10                                                   
**        IOUID (00) - IOU DESCRIPTOR.                                  
                                                                        
                                                                        
 CIOHDR   EQU    0           SIZE OF RECORD                             
 CIOE     EQU    1           ELEMENT ID                                 
 CIOM     EQU    2           MODEL NUMBER                               
 CIOPC    EQU    4           PORT CODE                                  
 CIOPPM   EQU    5 - 6       PPS PHYSICALLY MISSING                     
 CIOPLM   EQU    7 - 10      PPS LOGICALLY MISSING                      
 CIOPSPD  EQU    11          PP SPEED                                   
 CIOCMIS  EQU    12 - 13     CHANNELS MISSING                           
 CIOCPM   EQU    14          CIOS PHYSICALLY MISSING                    
 CIOCLM   EQU    15          CIOS LOGICALLY MISSING                     
 CIOCCPM  EQU    16          CIO CHANNELS PHYSICALLY MISSING            
 CIOPDS   EQU    17 - 20     PP DOWN STATUS                             
 CIOCDS   EQU    21          CIO DOWN STATUS                            
 CIONCDS  EQU    22 - 35     NIO CHANNEL DOWN STATUS                    
 CIOCCDS  EQU    36 - 42     CIO CHANNEL DOWN STATUS                    
 CIOST    EQU    43          IOU OFF STATUS                             
 CIOLEN   EQU    44          IOU DESCRIPTOR LENGTH                      
 CMID     SPACE  4,10                                                   
**        CMID (01) - CENTRAL MEMORY DESCRIPTOR.                        
*                                                                       
*         NOTE - THIS DOES NOT MATCH LATEST CTI DOCUMENTATION.          
                                                                        
                                                                        
 CMIHDR   EQU    0           SIZE OF RECORD                             
 CMIE     EQU    1           ELEMENT ID                                 
 CMIPC    EQU    4           PORT CODE                                  
 CMIPMS   EQU    5 - 6       PHYSICAL MEMORY SIZE                       
 CMILMS   EQU    7 - 11      LOGICAL MEMORY SIZE                        
 CMISCDA  EQU    12 - 13     CIP DIRECTORY R-REGISTER VALUE             
 CMISCDO  EQU    14          CIP DIRECTORY OFFSET                       
 CMILEN   EQU    15          LENGTH OF CM DESCRIPTOR                    
 PROCID   SPACE  4,10                                                   
**        PROCID (02) - PROCESSOR DESCRIPTOR.                           
*                                                                       
*         NOTE - THIS DOES NOT MATCH LATEST CTI DOCUMENTATION.          
                                                                        
                                                                        
 CPRHDR   EQU    0           HEADER FOR PROCESSOR RECORD                
 CPRE     EQU    1           ELEMENT ID                                 
 CPRPC    EQU    4           PORT CODE                                  
 CPRDEGR  EQU    5           DEGRADATION FLAGS                          
 CPRPORT  EQU    6           PORT                                       
 CPRSTAT  EQU    7           STATUS OF PROCESSOR                        
 CPROPT   EQU    10          PROCESSOR OPTIONS                          
 CPRULOD  EQU    11          MICROCODE LOADED FLAG                      
 CPRUNAM  EQU    12 - 15     MICROCODE NAME                             
 CPRMLX1  EQU    2           MICROCODE LEVEL, OFFSET TO FIRST CHARACTER 
 CPRMLX2  EQU    3           MICROCODE LEVEL, OFFSET TO SECOND CHARACTER
 CPRUDAT  EQU    16 - 21     MICROCODE DATE                             
 CPRPTL   EQU    22          PAGE TABLE LENGTH                          
 CPRPS    EQU    23          PAGE SIZE                                  
 CPRLEN   EQU    24          PROCESSOR DESCRIPTOR LENGTH                
 PSS      SPACE  4,10                                                   
**        DEFINITION OF PROCESSOR STATUS.                               
                                                                        
                                                                        
 PSNOPMF  EQU    0           PMF NOT PRESENT                            
 PSNO180  EQU    0           C180 NOT SUPPORTED                         
 PSNO170  EQU    0           C170 NOT SUPPORTED                         
 PSCPOFF  EQU    0           PROCESSOR OFF                              
 DEG      SPACE  4,10                                                   
**        DEFINITION OF DEGRADATION FLAGS.                              
                                                                        
                                                                        
 DFPGMP0  EQU    0           PAGE MAP 0                                 
 DFPGMP1  EQU    0           PAGE MAP 1                                 
 DFPGMP2  EQU    0           PAGE MAP 2                                 
 DFPGMP3  EQU    0           PAGE MAP 3                                 
 DFSGMP0  EQU    0           SEGMENT MAP 0                              
 DFSGMP1  EQU    0           SEGMENT MAP 1                              
 DFCAST0  EQU    0           CACHE SET 0                                
 DFCAST1  EQU    0           CACHE SET 1                                
 DFCAST2  EQU    0           CACHE SET 2                                
 DFCAST3  EQU    0           CACHE SET 3                                
 MAINID   SPACE  4,10                                                   
**        MAINID (03) - MAINFRAME DESCRIPTOR.                           
                                                                        
                                                                        
 CMFHDR   EQU    0           SIZE OF MAINFRAME RECORD                   
 CMFMO    EQU    1           MAINFRAME OPTIONS                          
 CMFEIDT  EQU    5 - 7       EI DATE                                    
 CMFEILV  EQU    10          EI LEVEL                                   
 CMFLEN   EQU    11          MAINFRAME DESCRIPTOR LENGTH                
                                                                        
 MOP      SPACE  4,10                                                   
**        DEFINITION OF MAINFRAME OPTIONS.                              
                                                                        
                                                                        
 MONOCM   EQU    0           NO CM EXTENSION                            
 MONOCEM  EQU    1           NO CEM PEM                                 
 MOCP1OF  EQU    2           CPU1 OFF                                   
 MOCP0OF  EQU    2           CPU0 OFF                                   
 DISCID   SPACE  4,10                                                   
**        DISCID (05) - DISPLAY CONSOLE DESCRIPTOR.                     
*                                                                       
*         NOTE - THIS DOES NOT MATCH LATEST CTI DOCUMENTATION.          
                                                                        
                                                                        
 CDCHDR   EQU    0           HEADER FOR DISPLAY CONSOLE                 
 CDCDTYP  EQU    1           DISPLAY TYPE                               
 CDCPFLG  EQU    2           PORT FLAGS                                 
 CDCMDD   EQU    3           *MDD* PP                                   
 CDCSCD   EQU    3           *SCD* PP                                   
 CDCPTN   EQU    4           *MDD* PORT NUMBER                          
 CDCPCI   EQU    5           PC INDICATOR                               
 CDCLEN   EQU    6           CONSOLE DESCRIPTOR LENGTH                  
 GPDID    SPACE  4,10                                                   
**        GPDID (06) - GLOBAL PROCESSOR DATA DESCRIPTOR.                
*                                                                       
*         NOTE - THIS DOES NOT MATCH LATEST CTI DOCUMENTATION.          
                                                                        
                                                                        
 GPDHDR   EQU    0           HEADER                                     
 GPDLI    EQU    1           MICROCODE LONG INIT ADDRESS                
 GPDIDL   EQU    2           MICROCODE IDLE ADDRESS                     
 GPDMXO   EQU    3           HALF EXCHANGE OUT MPS                      
 GPDJXO   EQU    4           HALF EXCHANGE OUT JPS                      
 GPDMXI   EQU    5           HALF EXCHANGE IN MPS                       
 GPDJXI   EQU    6           HALF EXCHANGE IN JPS                       
 GPDPTE   EQU    7           NUMBER OF PAGE TABLE ENTRIES               
 GPDPTL   EQU    7           PAGE TABLE LENGTH, LENGTH IN *GPDLPTL* NOW 
 GPDPS    EQU    10          PAGE SIZE IN K BYTES                       
 GPDST    EQU    11          STATE FLAG (0=170, 1=180)                  
 GPDDST   EQU    12          CHANNEL AND DEADSTART TYPE                 
 GPDLEN   EQU    13          DESCRIPTOR LENGTH                          
 GPDOPF   EQU    14          OPERATOR PAUSE FLAG                        
 GPDLPTL  EQU    17          PAGE TABLE LENGTH                          
 WCCID    SPACE  4,10                                                   
**        WCCID (10) - WALL CLOCK CHIP DESCRIPTOR.                      
*                                                                       
*         NOTE - THIS DOES NOT MATCH LATEST CTI DOCUMENTATION.          
                                                                        
                                                                        
 WCCHDR   EQU    0           HEADER                                     
 WCCY     EQU    1           YEARS                                      
 WCCMO    EQU    2           MONTHS                                     
 WCCDY    EQU    3           DAYS                                       
 WCCHR    EQU    4           HOURS                                      
 WCCMI    EQU    5           MINUTES                                    
 WCCSE    EQU    6           SECONDS                                    
 WCCF1    EQU    7           FREE RUNNING CLOCK 0 .. 11                 
 WCCF2    EQU    10          FREE RUNNING CLOCK 12 .. 23                
 WCCF3    EQU    11          FREE RUNNING CLOCK 24 .. 35                
 WCCF4    EQU    12          FREE RUNNING CLOCK 36 .. 47                
 WCCF5    EQU    13          FREE RUNNING CLOCK 48 .. 59                
 WCCLEN   EQU    17          DESCRIPTOR LENGTH                          
 MDID     SPACE  4,10                                                   
**        MDID (11) - MODEL DEPENDENT DESCRIPTOR.                       
*                                                                       
*         NOTE - THIS DOES NOT MATCH LATEST CTI DOCUMENTATION.          
                                                                        
                                                                        
 MDDLEN   EQU    24          DESCRIPTOR LENGTH                          
 PMID     SPACE  4,10                                                   
**        PMID (12) - PAGE MAP DESCRIPTOR.                              
*                                                                       
*         NOTE - THIS DOES NOT MATCH LATEST CTI DOCUMENTATION.          
                                                                        
                                                                        
 PMPMC    EQU    1                                                      
 PMDLEN   EQU    2           DESCRIPTOR LENGTH                          
 DFTID    SPACE  4,10                                                   
**        DFTID (13) - DFT DESCRIPTOR.                                  
                                                                        
                                                                        
 DFTSZ    EQU    1 - 2       DFT BUFFER SIZE TO ALLOCATE                
 DOBIV    EQU    3           DFT/OS BUFFER INTERFACE VERSION LEVEL      
 CPUON    EQU    CPRSTAT+PSCPOFF                                        
 CMXLEN   SPACE  4,10                                                   
**        CALCULATE MAXIMUM DESCRIPTOR LENGTH IN CM WORDS.              
*                                                                       
*         THE CALCULATED LENGTH MUST BE A MULTIPLE OF FOUR SINCE        
*         CM WORDS ARE BEING READ.  IN ADDITION, AN ADDITIONAL          
*         FOUR BYTES HAVE TO BE ADDED SINCE THE MRT DOES NOT            
*         ALWAYS START ON A WORD BOUNDARY; THIS IMPLIES AN              
*         ADDITIONAL WORD HAS TO BE READ AND NOT ALL OF THIS            
*         WORD WILL BE READ INTO THE PRE-BUFFER HEADER WORDS.           
                                                                        
                                                                        
 CMXLEN   MAX    CMILEN,CIOLEN,CMFLEN,CPRLEN,CDCLEN,GPDLEN,WCCLEN,MDDLEN
,,PMDLEN                                                                
 CMXLEN   SET    CMXLEN+3    ROUND UP TO NEAREST CM WORD                
 CMXLEN   SET    CMXLEN/4*4  MAXIMUM DESCRIPTOR LENGTH IN WORDS         
 CMXLEN   SET    CMXLEN+4    MAXIMUM BUFFER LENGTH IN WORDS             
                                                                        
          BASE   *                                                      
          ENDX                                                          
*DECK DECK=DSA$IS_FILE_LOCAL EXPAND=TRUE
          IDENT  DSAIFL
          TITLE  DSA$IS FILE LOCAL
          ENTRY  ZUTPIFL
          SYSCOM B1
          LIST   F
          SPACE  4
***  ZUTPIFL - REPLACES NOS CALL TO LFM= TO DETERMINE
*              IF FILE IS LOCAL TO CONTROLPOINT.
*              THIS ROUTINE WILL WORK FOR BOTH NOS AND NOS/BE.
*
*   ENTRY CONDITIONS
*     B5   ADDRESS OF FILENAME
*     X1   ADDRESS OF BOOLEAN TO HOLD RESPONSE
*copyc dsa$cybil_if_macros
 ZUTPIFL  RJ     =XZSMRENT
          SX1    LOCFET      DELIVER DISPLAY CODE LFN TO...
          SX7    RET
          EQ     =XZUTPSFN   CONVERT ASCII 12 TO DISPLAY
 RET      SA1    LOCFET
          IF     DEF,RA.ORG,2
          SX6    5S12        PARAMETER BLOCK LENGTH
          SKIP   1
          SX6    1+5S12      PARAMETER BLOCK LENGTH + COMPLETE BIT
          LX1    18
          BX6    X6+X1
          SA6    A1
          MX6    0
          DUP    4,1
          SA6    A6+B1       CLEAR REST OF BLOCK
          FILINFO  LOCFET
          SA1    LOCFET+1    FETCH EQUIPMENT ASSIGNED WORD
          MX6    12D
          BX6    X6*X1       EQUIPMENT MNEMONIC OR ZERO
          SA1    =XPARSV
          ZR     X6,FALSE
          MX6    1
 FALSE    SA6    X1          STORE 2ND PARAMETER
          EQ     =XZSMRRET
 LOCFET   BSS    5
          END
*DECK DECK=DSA$PACK_60_TO_32 EXPAND=TRUE
          IDENT  DSA6032                                                 R123_OS        1
          TITLE  DSA$PACK 60 TO 32                                       R123_OS        2
          SPACE  4,10                                                    R123_OS        3
          EXT    PARSV,ZSMRRET,ZSMRENT                                   R123_OS        4
          SPACE  4,10                                                    R123_OS        5
*         P60TO32 - PACK 60 BIT WORDS INTO 32 BIT ARRAY WORDS.           R123_OS        6
*                                                                        R123_OS        7
*         BUFFER OF 60-BIT-PACKED-WORDS ARE UNPACKED INTO                R123_OS        8
*         AN ARRAY OF 32 BITS RIGHT JUSTIFIED IN 60-BIT-WORDS.           R123_OS        9
*                                                                        R123_OS       10
*         ENTRY  - FROM CYBIL CODE WITH PARAMETERS                       R123_OS       11
*                  P60P0 = NUMBER OF 60 BIT WORDS - MUST BE MOD 16(10)   R123_OS       12
*                  P60P1 = INPUT BUFFER ADDRESS,                         R123_OS       13
*                  P60P2 = OUTPUT ARRAY ADDRESS - 1.                     R123_OS       14
*                                                                        R123_OS       15
*         EXIT   - INPUT BUFFER REPACKED INTO OUTPUT ARRAY.              R123_OS       16
*                                                                        R123_OS       17
          ENTRY  P60TO32                                                 R123_OS       18
 P60P0    EQU    0           PARAMETER 0 ADDRESS IN PARSV AREA           R123_OS       19
 P60P1    EQU    1           DITTO FOR PARAMETER ONE                     R123_OS       20
 P60P2    EQU    2           DITTO FOR PARAMETER TWO                     R123_OS       21
*                                                                        R123_OS       22
 P60TO32  BSS    0                                                       R123_OS       23
          RJ     ZSMRENT     SAVE CYBIL ENVNMNT AND PARAMETERS           R123_OS       24
 P60.ENT  BSS    0           LOAD PARAMETERS                             R123_OS       25
          SA1    PARSV+P60P0                                             R123_OS       26
          SB2    X1          NUMBER OF WORDS                             R123_OS       27
          SA1    PARSV+P60P1                                             R123_OS       28
          SB3    X1          60-WORD BUFFER ADDRESS                      R123_OS       29
          SA1    PARSV+P60P2                                             R123_OS       30
          SB4    X1+1        32-BIT ARRAY ADDRESS                        R123_OS       31
          SB5    B0          ZERO INTO B5                                R123_OS       32
 P60.00   BSS    0                                                       R123_OS       33
          SA2    B3                                                      R123_OS       34
          SA3    B3+1                                                    R123_OS       35
          SA4    B3+2                                                    R123_OS       36
          SA5    B3+3        LOAD NEXT 4 BUFFER WRDS INTO X2 - X5        R123_OS       37
          MX0    -32                                                     R123_OS       38
*                                                                        R123_OS       39
          BX6    X2                                                      R123_OS       40
          AX6    28                                                      R123_OS       41
          BX6    -X0*X6                                                  R123_OS       42
          SA6    B4          SAVE W0,U32                                 R123_OS       43
*                                                                        R123_OS       44
          MX1    -28                                                     R123_OS       45
          BX2    -X1*X2                                                  R123_OS       46
          LX2    4                                                       R123_OS       47
          BX7    X3                                                      R123_OS       48
          AX7    56                                                      R123_OS       49
          MX1    -4                                                      R123_OS       50
          BX7    -X1*X7                                                  R123_OS       51
          BX7    X7+X2                                                   R123_OS       52
          SA7    B4+1        SAVE W0L28,W1U4                             R123_OS       53
*                                                                        R123_OS       54
          BX6    X3                                                      R123_OS       55
          AX6    24                                                      R123_OS       56
          BX6    -X0*X6                                                  R123_OS       57
          SA6    B4+2        SAVE W1M32                                  R123_OS       58
*                                                                        R123_OS       59
          MX1    -24                                                     R123_OS       60
          BX3    -X1*X3                                                  R123_OS       61
          LX3    8                                                       R123_OS       62
          BX7    X4                                                      R123_OS       63
          AX7    52                                                      R123_OS       64
          MX1    -8                                                      R123_OS       65
          BX7    -X1*X7                                                  R123_OS       66
          BX7    X7+X3                                                   R123_OS       67
          SA7    B4+3        SAVE W1L24,W2U8                             R123_OS       68
*                                                                        R123_OS       69
          BX6    X4                                                      R123_OS       70
          AX6    20                                                      R123_OS       71
          BX6    -X0*X6                                                  R123_OS       72
          SA6    B4+4        SAVE W2M32                                  R123_OS       73
*                                                                        R123_OS       74
          MX1    -20                                                     R123_OS       75
          BX4    -X1*X4                                                  R123_OS       76
          LX4    12                                                      R123_OS       77
          BX6    X5                                                      R123_OS       78
          AX6    48                                                      R123_OS       79
          MX1    -12                                                     R123_OS       80
          BX6    -X1*X6                                                  R123_OS       81
          BX6    X6+X4                                                   R123_OS       82
          SA6    B4+5        SAVE W2L20,W3U12                            R123_OS       83
*                                                                        R123_OS       84
          BX7    X5                                                      R123_OS       85
          AX7    16                                                      R123_OS       86
          BX7    -X0*X7                                                  R123_OS       87
          SA7    B4+6        SAVE W3M32                                  R123_OS       88
*                                                                        R123_OS       89
          MX1    -16                                                     R123_OS       90
          BX0    -X1*X5                                                  R123_OS       91
          LX0    16          POSITION W3L16                              R123_OS       92
*                                                                        R123_OS       93
          SA2    B3+4                                                    R123_OS       94
          SA3    B3+5                                                    R123_OS       95
          SA4    B3+6                                                    R123_OS       96
          SA5    B3+7        LOAD NEXT 4 BUFFER WORDS INTO X2 - X5       R123_OS       97
*                                                                        R123_OS       98
          BX6    X2                                                      R123_OS       99
          AX6    44                                                      R123_OS      100
          MX1    -16                                                     R123_OS      101
          BX6    -X1*X6                                                  R123_OS      102
          BX6    X6+X0                                                   R123_OS      103
          SA6    B4+7        SAVE W3L16,W4U16                            R123_OS      104
*                                                                        R123_OS      105
          MX0    -32                                                     R123_OS      106
          BX7    X2                                                      R123_OS      107
          AX7    12                                                      R123_OS      108
          BX7    -X0*X7                                                  R123_OS      109
          SA7    B4+8        SAVE W4M32                                  R123_OS      110
*                                                                        R123_OS      111
          MX1    -12                                                     R123_OS      112
          BX2    -X1*X2                                                  R123_OS      113
          LX2    20                                                      R123_OS      114
          BX7    X3                                                      R123_OS      115
          AX7    40                                                      R123_OS      116
          MX1    -20                                                     R123_OS      117
          BX7    -X1*X7                                                  R123_OS      118
          BX7    X7+X2                                                   R123_OS      119
          SA7    B4+9        SAVE W4L12,W5U20                            R123_OS      120
*                                                                        R123_OS      121
          BX6    X3                                                      R123_OS      122
          AX6    8                                                       R123_OS      123
          BX6    -X0*X6                                                  R123_OS      124
          SA6    B4+10D      SAVE W5M32                                  R123_OS      125
*                                                                        R123_OS      126
          MX1    -8                                                      R123_OS      127
          BX3    -X1*X3                                                  R123_OS      128
          LX3    24                                                      R123_OS      129
          BX7    X4                                                      R123_OS      130
          AX7    36                                                      R123_OS      131
          MX1    -24                                                     R123_OS      132
          BX7    -X1*X7                                                  R123_OS      133
          BX7    X7+X3                                                   R123_OS      134
          SA7    B4+11D      SAVE W5L8,W6U24                             R123_OS      135
*                                                                        R123_OS      136
          BX6    X4                                                      R123_OS      137
          AX6    4                                                       R123_OS      138
          BX6    -X0*X6                                                  R123_OS      139
          SA6    B4+12D      SAVE W6M32                                  R123_OS      140
*                                                                        R123_OS      141
          MX1    -4                                                      R123_OS      142
          BX4    -X1*X4                                                  R123_OS      143
          LX4    28                                                      R123_OS      144
          BX7    X5                                                      R123_OS      145
          AX7    32                                                      R123_OS      146
          MX1    -28                                                     R123_OS      147
          BX7    -X1*X7                                                  R123_OS      148
          BX7    X7+X4                                                   R123_OS      149
          SA7    B4+13D      SAVE W6L4,W7U28                             R123_OS      150
*                                                                        R123_OS      151
          BX6    X5                                                      R123_OS      152
          BX6    -X0*X6                                                  R123_OS      153
          SA6    B4+14D      SAVE W5L32                                  R123_OS      154
*                                                                        R123_OS      155
          SB4    B4+15D      STEP B4 TO NEXT ARRAY BLOCK                 R123_OS      156
          SB3    B3+8        STEP B3 TO NEXT BUFFER BLOCK                R123_OS      157
          SB2    B2-8        DECREMENT B2 BY BUFFER BLOCK COUNT          R123_OS      158
          NE     B0,B2,P60.00  MORE BUFFER WORDS TO UNPACK               R123_OS      159
 P60.EXI  BSS    0                                                       R123_OS      160
          JP     ZSMRRET     RESTORE ISWL ENVIRONMENT AND RETURN         R123_OS      161
                                                                         R123_OS      162
          END                                                            R123_OS      163
*DECK DECK=DSA$SMU_COMMUNICATION_BLOCK EXPAND=FALSE
          EJECT                                                          R152_OS        1
          TITLE  DSA$SMU COMMUNICATIONS BLOCK                            R152_OS        2
***       DSA$SMU COMMUNICATIONS BLOCK                                   R152_OS        3
*                                                                        R152_OS        4
*         PROVIDE THE CONSTANTS FOR USE OF THE SMU COMMUNICATIONS        R152_OS        5
*         BLOCK FOR USE BY NOS/VE PPS.                                   R152_OS        6
                                                                         R152_OS        7
                                                                         R152_OS        8
**        PP ADDRESS ARRAY DESCRIPTOR NUMBER.                            R152_OS        9
*                                                                        R152_OS       10
                                                                         R152_OS       11
                                                                         R152_OS       12
 SCPPD    EQU    128D        SMU COMMUNICATIONS BUFFER                   R152_OS       13
 ABPPD    EQU    131D        ASCII BUFFER                                R152_OS       14
          SPACE  4,10                                                    R152_OS       15
**        SYSTEM CONSOLE LINE DEFINITION.                                R152_OS       16
*                                                                        R152_OS       17
                                                                         R152_OS       18
                                                                         R152_OS       19
 CLLEN    EQU    80D/8D      CONSOLE LINE LENGTH IN WORDS                R152_OS       20
          SPACE  4,10                                                    R152_OS       21
**        DEFINITIONS OF WORDS IN THE SCB.                               R152_OS       22
*                                                                        R152_OS       23
                                                                         R152_OS       24
                                                                         R152_OS       25
 SCHST    EQU    0           HARDWARE STATUS WORD                        R152_OS       26
 SCNOS    EQU    1           NOS STATUS WORD                             R152_OS       27
 SCNVE    EQU    2           NOS/VE STATUS WORD                          R152_OS       28
 SCNSF    EQU    3           NOS SERVICE FLAG                            R152_OS       29
 SCSSF    EQU    4           SMU SERVICE FLAG                            R152_OS       30
 SCCMS    EQU    5           CRITICAL MESSAGE TIME STAMP                 R152_OS       31
 SCJPS    EQU    6           RMA OF FAILING JPS                          R152_OS       32
 SCREQ    EQU    7           SMU REQUEST BLOCK                           R152_OS       33
          SPACE  4,10                                                    R152_OS       34
**        DEFINITIONS FOR THE SMU REQUEST BLOCK.                         R152_OS       35
*                                                                        R152_OS       36
                                                                         R152_OS       37
                                                                         R152_OS       38
 SRNUL    EQU    0           NO REQUEST PRESENT                          R152_OS       39
 SRDUE    EQU    1           PROCESS UNCORRECTED MEMORY ERROR            R152_OS       40
 SRSMA    EQU    2           LOAD SMA                                    R152_OS       41
 SRMAX    EQU    3           MAXIMUM REQUEST + 1                         R152_OS       42
          SPACE  4,10                                                    R152_OS       43
**        DEFINITIONS OF THE ASCII BUFFER.                               R152_OS       44
*                                                                        R152_OS       45
                                                                         R152_OS       46
                                                                         R152_OS       47
 ABHDR    EQU    1           HEADER IS IN WORD 1                         R152_OS       48
 ABINP    EQU    2           INPUT BUFFER STARTS AT WORD 2               R152_OS       49
 ABOUT    EQU    ABINP+CLLEN OUTPUT BUFFER START                         R152_OS       50
          SPACE  4,10                                                    R152_OS       51
**        DEFINITIONS OF THE SMU META-STATES.                            R152_OS       52
*                                                                        R152_OS       53
                                                                         R152_OS       54
                                                                         R152_OS       55
 SSWDS    EQU    1           WAIT FOR DEADSTART                          R152_OS       56
 SSRUN    EQU    2           NORMAL OPERATING MODE                       R152_OS       57
 SSWIF    EQU    3           WRITE IMAGE FILE                            R152_OS       58
 SSRVT    EQU    4           REVERT TO STAND ALONE                       R152_OS       59
 SSIDL    EQU    5           SMU IDLE                                    R152_OS       60
*DECK DECK=DSA$VE_REQUESTS_TO_DFT EXPAND=FALSE
          CTEXT  DSA$VE REQUESTS TO DFT.                                                                                                                                                                                                        R123_OS        1
          SPACE  4,10                                                                                                                                                                                                                           DOH_221        1
***       CONSTANTS FOR DFT REQUESTS.                                                                                                                                                                                                           R123_OS        3
*                                                                                                                                                                                                                                               R123_OS        4
*         DEFINES CODES AND REQUEST FORMATS FOR REQUESTS TO DFT                                                                                                                                                                                 R123_OS        5
*         USED BY NOS/VE PP AND CPU.                                                                                                                                                                                                            R123_OS        6
          SPACE  4,10                                                                                                                                                                                                                           DOH_221        2
**        REQUESTS ARE OF THE FORM -                                                                                                                                                                                                            R123_OS        9
*                                                                                                                                                                                                                                               R123_OS       10
*         8/RC, 8/TASKID, 16/P0, 16/P1, 16/P2                                                                                                                                                                                                   DOH_221        3
*                                                                                                                                                                                                                                               DOH_75         5
*         RC = REPLY CODE RETURNED BY DFT.                                                                                                                                                                                                      DOH_75         6
                                                                                                                                                                                                                                                DOH_286        1
                                                                                                                                                                                                                                                DOH_286        2
 RCNE     EQU    1           NO ERRORS ENCOUNTERED                                                                                                                                                                                              DOH_286        3
 RCEE     EQU    2           ERROR ENCOUNTERED                                                                                                                                                                                                  DOH_286        4
 RCIC     EQU    3           INVALID CDA DATA READ                                                                                                                                                                                              DOH_286        5
 RCRR     EQU    4           REQUEST RETRYABLE (INCOMPLETE)                                                                                                                                                                                     DOH_286        6
 RCIV     EQU    5           RESERVED (MEANT INCORRECT VERSION PRIOR TO LVL727)                                                                                                                                                                 DOH_315        1
 RC2E     EQU    6           *2AP* ENCOUNTERED ERROR                                                                                                                                                                                            DOH_286        8
 RCVI     EQU    7           VERSION INCORRECT                                                                                                                                                                                                  DOH_315        2
 RCEN     EQU    0#8         HARDWARE ELEMENT NOT FOUND                                                                                                                                                                                         KAP_4024       1
 RCER     EQU    0#9         HARDWARE ELEMENT RESERVED                                                                                                                                                                                          KAP_4024       2
 RCEP     EQU    0#A         HARDWARE ELEMENT NOT POWERED UP                                                                                                                                                                                    KAP_4024       3
 RCIL     EQU    0#B         INSUFFICIENT LENGTH FOR REQUEST RESPONSE                                                                                                                                                                           KAP_4024       4
 RCNF     EQU    0#13        NO FLAW FREE MEMORY AVAILABLE                                                                                                                                                                                      GJF_8166       1
          SPACE  4,10                                                                                                                                                                                                                           DOH_221        5
**        HALT THE 170 PROCESSOR.                                                                                                                                                                                                               R123_OS       13
*                                                                                                                                                                                                                                               R123_OS       14
*         HALTS THE 170 PROCESSOR AND SAVES THE REGISTERS IN THE                                                                                                                                                                                R123_OS       15
*         SPECIFIED BUFFER.                                                                                                                                                                                                                     R123_OS       16
*                                                                                                                                                                                                                                               R123_OS       17
*         8/RC, 8/H1P, 48/POINTER TO REGISTER SAVE BUFFER                                                                                                                                                                                       DOH_221        6
*         16/10, 48/                                                                                                                                                                                                                            DOH_221        7
                                                                                                                                                                                                                                                R123_OS       19
                                                                                                                                                                                                                                                R123_OS       20
 H1P      EQU    1           HALT 170 PROCESSOR                                                                                                                                                                                                 R123_OS       21
          SPACE  4,10                                                                                                                                                                                                                           DOH_221        8
**        HALT ALL THE NOS VE PROCESSORS.                                                                                                                                                                                                       R123_OS       23
*                                                                                                                                                                                                                                               R123_OS       24
*         HALTS ALL OF THE PROCESSORS AND SAVES THE REGISTERS IN THE                                                                                                                                                                            R123_OS       25
*         SPECIFIED BUFFER.                                                                                                                                                                                                                     R123_OS       26
*                                                                                                                                                                                                                                               R123_OS       27
*         8/RC, 8/HVP, 48/POINTER TO REGISTER SAVE BUFFER                                                                                                                                                                                       DOH_221        9
                                                                                                                                                                                                                                                R123_OS       29
                                                                                                                                                                                                                                                R123_OS       30
 HVP      EQU    2           HALT VIRTUAL PROCESSORS                                                                                                                                                                                            R123_OS       31
          SPACE  4,10                                                                                                                                                                                                                           DOH_221       10
**        DEADSTART VIRTUAL PROCESSOR.                                                                                                                                                                                                          R123_OS       33
*                                                                                                                                                                                                                                               R123_OS       34
*         STARTS A SINGLE PROCESSOR RUNNING IN VIRTUAL STATE.                                                                                                                                                                                   R123_OS       35
*                                                                                                                                                                                                                                               R123_OS       36
*         8/RC, 8/DVP, 48/INITIAL REGISTER BUFFER                                                                                                                                                                                               DOH_221       11
*         16/CPU, 32/MPS, 16/                                                                                                                                                                                                                   DOH_221       12
                                                                                                                                                                                                                                                R123_OS       38
                                                                                                                                                                                                                                                R123_OS       39
 DVP      EQU    3           DEADSTART VIRTUAL PROCESSOR                                                                                                                                                                                        R123_OS       40
          SPACE  4,10                                                                                                                                                                                                                           DOH_221       13
**        STOP VIRTUAL PROCESSOR.                                                                                                                                                                                                               R123_OS       42
*                                                                                                                                                                                                                                               R123_OS       43
*         HALTS, HALF EXCHANGES OUT, AND DEACTIVATES THE MEMORY                                                                                                                                                                                 R123_OS       44
*         PORT FOR A VIRTUAL STATE PROCESSOR.                                                                                                                                                                                                   R123_OS       45
*                                                                                                                                                                                                                                               R123_OS       46
*         8/RC, 8/SVP, 48/POINTER TO REGISTER SAVE BUFFER                                                                                                                                                                                       DOH_221       14
*         16/CPU, 48/                                                                                                                                                                                                                           DOH_221       15
                                                                                                                                                                                                                                                R123_OS       48
                                                                                                                                                                                                                                                R123_OS       49
 SVP      EQU    4           STOP VIRTUAL PROCESSOR                                                                                                                                                                                             R123_OS       50
          SPACE  4,10                                                                                                                                                                                                                           DOH_221       16
**        LOAD DRIVER PP.                                                                                                                                                                                                                       R123_OS       52
*                                                                                                                                                                                                                                               R123_OS       53
*         LOADS THE SPECIFIED PP WITH THE SPECIFIED IMAGE FROM CENTRAL                                                                                                                                                                          R123_OS       54
*         MEMORY.                                                                                                                                                                                                                               R123_OS       55
*                                                                                                                                                                                                                                               R123_OS       56
*         8/RC, 8/LDP, 3/0, 1/NIO-CIO, 12/PP, 32/                                                                                                                                                                                               DOH_221       17
*         48/R REGISTER POINTER , 16/0                                                                                                                                                                                                          DOH_221       18
                                                                                                                                                                                                                                                R123_OS       59
                                                                                                                                                                                                                                                R123_OS       60
 LDP      EQU    5           LOAD DRIVER PP                                                                                                                                                                                                     R123_OS       61
          SPACE  4,10                                                                                                                                                                                                                           DOH_221       19
**        FETCH HARDWARE INFORMATION.                                                                                                                                                                                                           R123_OS       63
*                                                                                                                                                                                                                                               R123_OS       64
*         RETURNS THE INFORMATION FROM THE HARDWARE DESCRIPTOR TABLE                                                                                                                                                                            R123_OS       65
*         IN *2AP* FOR THE SPECIFIED ELEMENT.                                                                                                                                                                                                   DOH_221       20
*                                                                                                                                                                                                                                               R123_OS       67
*         8/RC, 8/FHI, 8/N, 8/K, 32/RMA                                                                                                                                                                                                         DOH_221       21
*                                                                                                                                                                                                                                               R123_OS       69
*         N = ORDINAL OF ELEMENT.                                                                                                                                                                                                               R123_OS       70
*         K = KIND OF ELEMENT (0 = IOU, 1 = MEM, 2 = CPU).                                                                                                                                                                                      DOH_221       22
                                                                                                                                                                                                                                                R123_OS       72
                                                                                                                                                                                                                                                R123_OS       73
 FHI      EQU    6           FETCH HARDWARE INFORMATION                                                                                                                                                                                         R123_OS       74
          SPACE  4,10                                                                                                                                                                                                                           DOH_221       23
**        CHANGE PROCESSOR REGISTER.                                                                                                                                                                                                            R123_OS       76
*                                                                                                                                                                                                                                               R123_OS       77
*         CHANGES MPS IN THE SPECIFIED PROCESSOR.                                                                                                                                                                                               R123_OS       78
*                                                                                                                                                                                                                                               R123_OS       79
*         8/RC, 8/CPR, 8/CPU, 8/0, 32/MPS                                                                                                                                                                                                       DOH_221       24
                                                                                                                                                                                                                                                R123_OS       81
                                                                                                                                                                                                                                                R123_OS       82
 CPR      EQU    7           CHANGE PROCESSOR REGISTER                                                                                                                                                                                          R123_OS       83
          SPACE  4,10                                                                                                                                                                                                                           DOH_221       25
**        FETCH DATA FROM COMMON DISK AREA.                                                                                                                                                                                                     R123_OS       85
*                                                                                                                                                                                                                                               R123_OS       86
*         READS THE NAMED OBJECT FROM THE COMMON DISK AREA TO MEMORY.                                                                                                                                                                           R123_OS       87
*                                                                                                                                                                                                                                               R123_OS       88
*         8/RC, 8/FCD, 48/R REGISTER POINTER                                                                                                                                                                                                    DOH_221       26
*         32/RECORD NAME, 32/                                                                                                                                                                                                                   DOH_221       27
*         48/R REGISTER POINTER POINTING TO LWA + 1, 16/                                                                                                                                                                                        DOH_221       28
                                                                                                                                                                                                                                                R123_OS       92
                                                                                                                                                                                                                                                R123_OS       93
 FCD      EQU    10          FETCH CDA DATA                                                                                                                                                                                                     R123_OS       94
          SPACE  4,10                                                                                                                                                                                                                           DOH_221       29
**        ACCESS THE DEADSTART SECTOR FROM SMALL SECTOR DISK.                                                                                                                                                                                   R123_OS       96
*                                                                                                                                                                                                                                               R123_OS       97
*         8/RC, 8/ADS, 48/R REGISTER POINTER                                                                                                                                                                                                    DOH_221       30
*         16/DT, 16/CH, 16/UN, 16/AF                                                                                                                                                                                                            DOH_221       31
*                                                                                                                                                                                                                                               R123_OS      100
*         DT = DISK TYPE.                                                                                                                                                                                                                       DOH_221       32
*         CH = CHANNEL NUMBER OF DISK CONTROLLER.                                                                                                                                                                                               DOH_221       33
*         UN = UNIT NUMBER.                                                                                                                                                                                                                     DOH_221       34
*         AF = ACCESS FLAG 1=WRITE 0=READ.                                                                                                                                                                                                      DOH_221       35
                                                                                                                                                                                                                                                DOH_221       36
                                                                                                                                                                                                                                                R123_OS      105
 ADS      EQU    11                                                                                                                                                                                                                             R123_OS      106
          SPACE  4,10                                                                                                                                                                                                                           DOH_221       37
**        READ/WRITE COMMON DISK AREA.                                                                                                                                                                                                          R123_OS      108
*                                                                                                                                                                                                                                               R123_OS      109
*         8/RC, 8/RWC,48/R REGISTER POINTER                                                                                                                                                                                                     DOH_221       38
*         16/V, 16/F, 16/PPR, 16/RWF                                                                                                                                                                                                            DOH_221       39
*         32/RECORD NAME, 16/LENGTH, 16/0                                                                                                                                                                                                       DOH_221       40
*                                                                                                                                                                                                                                               R123_OS      113
*         V = VALID DATA IN FILE (1=TRUE).                                                                                                                                                                                                      DOH_221       41
*         F = 12 OR 16 BIT FILE (0=12 BIT, 1=16 BIT).                                                                                                                                                                                           DOH_221       42
*         PPR = READ ENTIRE OR PARTIAL PROGRAM (0=ENTIRE, 1=PARTIAL).                                                                                                                                                                           DOH_221       43
*         RWF = READ OR WRITE TO BE PERFORMED (0=READ, 1=WRITE).                                                                                                                                                                                DOH_221       44
*         RECORD NAME NAME OF FILE TO ACCESS.                                                                                                                                                                                                   R123_OS      118
*         LENGTH = PP WORD COUNT.                                                                                                                                                                                                               DOH_221       45
                                                                                                                                                                                                                                                DOH_221       46
                                                                                                                                                                                                                                                R123_OS      120
 RWC      EQU    12                                                                                                                                                                                                                             R123_OS      121
          SPACE  4,10                                                                                                                                                                                                                           DOH_221       47
**        WRITE CLOCK INFO TO DISK AND THE HDT AND THE WALL CLOCK CHIP.                                                                                                                                                                         R123_OS      123
*                                                                                                                                                                                                                                               R123_OS      124
*         8/RC, 8/WCD, 8/YEARS, 8/MONTHS, 8/DAYS, 8/HOURS, 8/MINUTES, 8/0                                                                                                                                                                       DOH_221       48
*         16/FRC1, 16/FRC2, 16/FRC3, 16/FRC4                                                                                                                                                                                                    DOH_221       49
                                                                                                                                                                                                                                                DOH_221       50
                                                                                                                                                                                                                                                R123_OS      127
 WCD      EQU    13                                                                                                                                                                                                                             R123_OS      128
          SPACE  4,10                                                                                                                                                                                                                           DOH_221       51
**        START THE 170 PROCESSOR.                                                                                                                                                                                                              R123_OS      130
*                                                                                                                                                                                                                                               R123_OS      131
*         STARTS THE 170 PROCESSOR.                                                                                                                                                                                                             R123_OS      132
*                                                                                                                                                                                                                                               R123_OS      133
*         8/RC, 8/S1P, 48/POINTER TO REGISTER SAVE BUFFER                                                                                                                                                                                       DOH_221       52
*         16/10, 48/                                                                                                                                                                                                                            DOH_221       53
                                                                                                                                                                                                                                                R123_OS      135
                                                                                                                                                                                                                                                R123_OS      136
 S1P      EQU    14          START 170 PROCESSOR                                                                                                                                                                                                R123_OS      137
          SPACE  4,10                                                                                                                                                                                                                           DOH_221       54
**        PP UTILITY FUNCTIONS.  THE FUNCTIONS THAT THIS COVERS ARE:                                                                                                                                                                            R123_OS      139
*                . IDLE PP ONLY.                                                                                                                                                                                                                R123_OS      140
*                . IDLE PP AND DUMP PP REGISTERS.                                                                                                                                                                                               R123_OS      141
*                . IDLE PP, DUMP PP REGISTERS AND MEMORY.                                                                                                                                                                                       R123_OS      142
*                . DUMP PP REGISTERS WITHOUT IDLING PPU.                                                                                                                                                                                        R123_OS      143
*                                                                                                                                                                                                                                               R123_OS      144
*         FORMAT OF REQUEST DEFINED IN DECK                                                                                                                                                                                                     R123_OS      145
*         *DST$DFT_PP_UTILITY_FUNCTIONS*.                                                                                                                                                                                                       R123_OS      146
                                                                                                                                                                                                                                                DOH_221       55
                                                                                                                                                                                                                                                R123_OS      147
 PUF      EQU    15          PP UTILITY FUNCTIONS.                                                                                                                                                                                              R123_OS      148
          SPACE  4,10                                                                                                                                                                                                                           DOH_221       56
**        RESUME PP.                                                                                                                                                                                                                            R123_OS      150
*                                                                                                                                                                                                                                               R123_OS      151
*         RESUME PP AT A SPECIFIED ADDRESS.                                                                                                                                                                                                     R123_OS      152
*                                                                                                                                                                                                                                               R123_OS      153
*         8/RC, 8/REP, 3/0, 1/NIO-CIO, 12/PP NUMBER, 16/STARTING ADDRESS                                                                                                                                                                        DOH_221       57
                                                                                                                                                                                                                                                DOH_221       58
                                                                                                                                                                                                                                                R123_OS      155
 REP      EQU    16          RESUME PP                                                                                                                                                                                                          R123_OS      156
          SPACE  4,10                                                                                                                                                                                                                           DOH_221       59
**        UPDATE FREE RUNNING COUNTER.                                                                                                                                                                                                          R123_OS      158
*                                                                                                                                                                                                                                               R123_OS      159
*         8/RC, 8/UFC, 48/NEW FREE RUNNING COUNTER VALUE                                                                                                                                                                                        DOH_221       60
                                                                                                                                                                                                                                                DOH_221       61
                                                                                                                                                                                                                                                R123_OS      161
 UFC      EQU    17                                                                                                                                                                                                                             R123_OS      162
          SPACE  4,10                                                                                                                                                                                                                           DOH_221       62
**        SET DFT ERROR THRESHOLDS.                                                                                                                                                                                                             R123_OS      164
*                                                                                                                                                                                                                                               R123_OS      165
*         8/RC, 8/SDT, 13/0, 1/C, 1/U, 1/C, 8/ET, 8/EI, 8/CE, 8/UCE                                                                                                                                                                             DOH_221       63
                                                                                                                                                                                                                                                DOH_221       64
                                                                                                                                                                                                                                                R123_OS      167
 SDT      EQU    20                                                                                                                                                                                                                             R123_OS      168
 GCS      SPACE  4,10                                                                                                                                                                                                                           DOH_54         1
**        GET NIO CHANNEL STATUS.                                                                                                                                                                                                               DOH_54         2
*                                                                                                                                                                                                                                               DOH_54         3
*         8/RC, 8/GCS, 8/IOU NUMBER, 8/CH, 32/0                                                                                                                                                                                                 DOH_221       65
*         64/R REGISTER POINTER                                                                                                                                                                                                                 DOH_221       66
*                                                                                                                                                                                                                                               DOH_54         6
*         CH = NIO CHANNEL NUMBER.                                                                                                                                                                                                              DOH_221       67
                                                                                                                                                                                                                                                DOH_54         8
                                                                                                                                                                                                                                                DOH_54         9
 GCS      EQU    21                                                                                                                                                                                                                             DOH_54        10
 DVR      SPACE  4,10                                                                                                                                                                                                                           DOH_44         1
**        DEADSTART VIRTUAL PROCESSOR (REQUEST FORMAT REVISED FOR LEVEL 92).                                                                                                                                                                    DOH_221       68
*                                                                                                                                                                                                                                               DOH_44         3
*         STARTS A SINGLE PROCESSOR RUNNING IN VIRTUAL STATE.                                                                                                                                                                                   DOH_44         4
*                                                                                                                                                                                                                                               DOH_44         5
*         8/RC, 8/DVR, 16/CPU INDEX, 32/MPS                                                                                                                                                                                                     DOH_221       69
*         64/R-POINTER TO REGISTER LIST                                                                                                                                                                                                         DOH_221       70
                                                                                                                                                                                                                                                DOH_44         8
                                                                                                                                                                                                                                                DOH_44         9
 DVR      EQU    22          DEADSTART VIRTUAL PROCESSOR                                                                                                                                                                                        DOH_44        10
 CPO      SPACE  4,10                                                                                                                                                                                                                           DOH_44        11
**        CHANGE PROCESSOR REGISTER (REQUEST FORMAT REVISED FOR LEVEL 92).                                                                                                                                                                      DOH_221       71
*                                                                                                                                                                                                                                               DOH_44        13
*         CHANGES MPS IN THE SPECIFIED PROCESSOR.                                                                                                                                                                                               DOH_44        14
*                                                                                                                                                                                                                                               DOH_44        15
*         8/RC, 8/CPO, 16/CPU INDEX, 32/MPS                                                                                                                                                                                                     DOH_221       72
                                                                                                                                                                                                                                                DOH_44        17
                                                                                                                                                                                                                                                DOH_44        18
 CPO      EQU    23          CHANGE PROCESSOR REGISTER                                                                                                                                                                                          DOH_44        19
 ADR      SPACE  4,20                                                                                                                                                                                                                           DOH_240        2
**        ACCESS THE DEADSTART SECTOR FROM SMALL SECTOR DISK.                                                                                                                                                                                   DOH_221       73
*         (REQUEST FORMAT REVISED FOR LEVEL 92).                                                                                                                                                                                                DOH_221       74
*                                                                                                                                                                                                                                               DOH_44        22
*         8/RC, 8/ADR, 8/IOU NUMBER, 8/CH, 8/UN, 8/DT, 8/AF, 8/RFU                                                                                                                                                                              DOH_221       75
*         64/R-POINTER                                                                                                                                                                                                                          DOH_221       76
*         16/FN, 16/TES, 32/RFU                                                                                                                                                                                                                 DOH_240        3
*                                                                                                                                                                                                                                               DOH_44        25
*         DT = DISK TYPE.                                                                                                                                                                                                                       DOH_221       77
*         CH = CHANNEL NUMBER OF DISK CONTROLLER.                                                                                                                                                                                               DOH_221       78
*         UN = UNIT NUMBER.                                                                                                                                                                                                                     DOH_221       79
*         AF = ACCESS FLAG 1=WRITE 0=READ.                                                                                                                                                                                                      DOH_221       80
*         THE FOLLOWING TWO OUTPUT PARAMETERS ARE ONLY VALID WHEN (RC) = 6.                                                                                                                                                                     DOH_240        4
*         FN = *2AP* FUNCTION NUMBER FOR WHICH ERROR OCCURRED.                                                                                                                                                                                  DOH_240        5
*         TES= *2AP* ERROR STATUS.                                                                                                                                                                                                              DOH_240        6
                                                                                                                                                                                                                                                DOH_44        30
                                                                                                                                                                                                                                                DOH_44        31
 ADR      EQU    24                                                                                                                                                                                                                             DOH_44        32
 ACA      SPACE  4,20                                                                                                                                                                                                                           DOH_240        7
**        READ/WRITE COMMON DISK AREA (REQUEST FORMAT REVISED FOR LEVEL 92).                                                                                                                                                                    DOH_221       81
*                                                                                                                                                                                                                                               DOH_44        35
*         8/RC, 8/ACA, 32/CIP IMAGE NAME, 5/0, 1/V, 1/S, 1/P, 1/0, 1/W, 1/C, 5/0                                                                                                                                                                DOH_221       82
*         64/R-POINTER                                                                                                                                                                                                                          DOH_221       83
*         16/FN, 16/TES, 32/RFU                                                                                                                                                                                                                 DOH_240        8
*                                                                                                                                                                                                                                               DOH_44        38
*         V = VALID DATA IN FILE (1=TRUE).                                                                                                                                                                                                      DOH_221       84
*         S = 12 OR 16 BIT FILE (0=12 BIT, 1=16 BIT).                                                                                                                                                                                           DOH_221       85
*         P = READ ENTIRE OR PARTIAL PROGRAM (0=ENTIRE, 1=PARTIAL).                                                                                                                                                                             DOH_221       86
*         W = READ OR WRITE TO BE PERFORMED (0=READ, 1=WRITE).                                                                                                                                                                                  DOH_221       87
*         C = CEL SECTOR IF SET.                                                                                                                                                                                                                DOH_44        43
*         LENGTH = PP WORD COUNT.                                                                                                                                                                                                               DOH_221       88
*         THE FOLLOWING TWO OUTPUT PARAMETERS ARE ONLY VALID WHEN (RC) = 6.                                                                                                                                                                     DOH_240        9
*         FN = *2AP* FUNCTION NUMBER FOR WHICH ERROR OCCURRED.                                                                                                                                                                                  DOH_240       10
*         TES= *2AP* ERROR STATUS.                                                                                                                                                                                                              DOH_240       11
                                                                                                                                                                                                                                                DOH_44        45
                                                                                                                                                                                                                                                DOH_44        46
 ACA      EQU    25                                                                                                                                                                                                                             DOH_44        47
 PUR      SPACE  4,15                                                                                                                                                                                                                           DOH_221       89
**        PP UTILITY FUNCTIONS (REQUEST FORMAT REVISED FOR LEVEL 92).                                                                                                                                                                           DOH_221       90
*                                                                                                                                                                                                                                               DOH_44        50
*         8/RC, 8/PUR, 8/IOU NUMBER, 8/CIO, 8/PP NUMBER, 8/SUBFUNCTION, 8/ADDR, 8/                                                                                                                                                              DOH_221       91
*         64/R-POINTER                                                                                                                                                                                                                          DOH_221       92
*                                                                                                                                                                                                                                               DOH_44        53
*         SUBFUNCTIONS -                                                                                                                                                                                                                        DOH_44        54
*         1 - DUMP PP REGISTERS ONLY.                                                                                                                                                                                                           DOH_44        55
*         2 - IDLE PP ONLY.                                                                                                                                                                                                                     DOH_44        56
*         3 - IDLE PP AND DUMP PP REGISTERS AND MEMORY.                                                                                                                                                                                         DOH_44        57
*         4 - IDLE PP AND DUMP PP REGISTERS.                                                                                                                                                                                                    DOH_44        58
*         5 - LOAD PP.                                                                                                                                                                                                                          DOH_44        59
*         6 - RESUME PP.                                                                                                                                                                                                                        DOH_44        60
*         7 - CAPTURE PP R REGISTER.                                                                                                                                                                                                            GJF_8180       1
*         8 - MASTER CLEAR SPECIFIC CHANNEL.                                                                                                                                                                                                    GJF_8180       2
                                                                                                                                                                                                                                                DOH_53         2
                                                                                                                                                                                                                                                DOH_53         3
 PUR      EQU    26          PP UTILITY FUNCTIONS                                                                                                                                                                                               DOH_44        63
 GMR      SPACE  4,15                                                                                                                                                                                                                           DOH_306        1
**        GET MAINTENANCE REGISTER.                                                                                                                                                                                                             DOH_306        2
*                                                                                                                                                                                                                                               DOH_306        3
*         8/RC, 8/GMR, 8/IOU NUMBER, 8/, 16/MC-INFO, 16/REGISTER NUMBER                                                                                                                                                                         DOH_306        4
*         64/R-POINTER                                                                                                                                                                                                                          DOH_306        5
*                                                                                                                                                                                                                                               DOH_306        6
*         MC-INFO = 4/, 4/MAINTENANCE CH PORT, 4/, 4/MAINTENANCE CH TYPE CODE.                                                                                                                                                                  DOH_306        7
*         LENGTH OF R-POINTER MUST BE TWO OR GREATER.                                                                                                                                                                                           DOH_306        8
*                                                                                                                                                                                                                                               DOH_306        9
*         THE RESULTS OF READING THE SPECIFIED MAINTENANCE REGISTER ARE                                                                                                                                                                         DOH_306       10
*         RETURNED IN A TWO WORD BLOCK STARTING AT THE ADDRESS POINTED TO                                                                                                                                                                       DOH_306       11
*         BY THE R-POINTER.  THE RETURNED INFORMATION IS IN THE FOLLOWING                                                                                                                                                                       DOH_306       12
*         FORMAT -                                                                                                                                                                                                                              DOH_306       13
*         8/, 8/BYTE-0, 8/, 8/BYTE-1, 8/, 8/BYTE-2, 8/, 8/BYTE-3                                                                                                                                                                                DOH_306       14
*         8/, 8/BYTE-4, 8/, 8/BYTE-5, 8/, 8/BYTE-6, 8/, 8/BYTE-7                                                                                                                                                                                DOH_306       15
                                                                                                                                                                                                                                                DOH_306       16
                                                                                                                                                                                                                                                DOH_306       17
 GMR      EQU    27          GET MAINTENANCE REGISTER                                                                                                                                                                                           DOH_306       18
 LDS      SPACE  4,10                                                                                                                                                                                                                           DOH_53         4
**        LOAD DFT IN SECONDARY IOU.                                                                                                                                                                                                            DOH_53         5
*                                                                                                                                                                                                                                               DOH_53         6
*         8/RC, 8/LDS, 8/IOU NUMBER, 8/CIO, 8/PP NUMBER, 24/0                                                                                                                                                                                   DOH_221       93
                                                                                                                                                                                                                                                DOH_53         8
                                                                                                                                                                                                                                                DOH_53         9
 LDS      EQU    30          LOAD DFT IN SECONDARY IOU                                                                                                                                                                                          DOH_53        10
 IAP      SPACE  4,10                                                                                                                                                                                                                           DOH_52         1
**        IDLE ALL PP-S AND CH-S IN IOU.                                                                                                                                                                                                        DOH_59         1
*                                                                                                                                                                                                                                               DOH_52         3
*         8/RC, 8/IAP, 8/IOU NUMBER, 8/SUBFUNCTION, 32/0                                                                                                                                                                                        DOH_221       94
*                                                                                                                                                                                                                                               DOH_59         3
*         SUBFUNCTION -                                                                                                                                                                                                                         DOH_59         4
*         0 - IDLE ALL PP-S AND CH-S IN IOU EXCEPT DFT.                                                                                                                                                                                         DOH_59         5
*         1 - IDLE DFT IN THIS IOU.                                                                                                                                                                                                             DOH_59         6
                                                                                                                                                                                                                                                DOH_52         5
                                                                                                                                                                                                                                                DOH_52         6
 IAP      EQU    31          IDLE ALL PP-S AND CH-S                                                                                                                                                                                             DOH_52         7
 AHE      SPACE  4,20                                                                                                                                                                                                                           DOH_240       12
**        ACCESS HARDWARE INFORMATION.                                                                                                                                                                                                          DOH_59         8
*                                                                                                                                                                                                                                               DOH_59         9
*         READS OR WRITES THE INFORMATION IN THE HARDWARE DESCRIPTOR                                                                                                                                                                            DOH_59        10
*         TABLE IN *2AP* FOR THE SPECIFIED ELEMENT.                                                                                                                                                                                             DOH_221       95
*                                                                                                                                                                                                                                               DOH_59        12
*         8/RC, 8/RWH, 16/R, 16/N, 16/K                                                                                                                                                                                                         DOH_221       96
*         64/R-POINTER                                                                                                                                                                                                                          DOH_221       97
*         16/FN, 16/TES, 32/RFU                                                                                                                                                                                                                 DOH_240       13
*                                                                                                                                                                                                                                               DOH_59        15
*         R = 1 FOR READ, 0 FOR WRITE.                                                                                                                                                                                                          DOH_59        16
*         N = ORDINAL OF ELEMENT.                                                                                                                                                                                                               DOH_59        17
*         K = KIND OF ELEMENT (0 = IOU, 1 = MEM, 2 = CPU).                                                                                                                                                                                      DOH_221       98
*         THE FOLLOWING TWO OUTPUT PARAMETERS ARE ONLY VALID WHEN (RC) = 6.                                                                                                                                                                     DOH_240       14
*         FN = *2AP* FUNCTION NUMBER FOR WHICH ERROR OCCURRED.                                                                                                                                                                                  DOH_240       15
*         TES = *2AP* ERROR STATUS.                                                                                                                                                                                                             DOH_240       16
                                                                                                                                                                                                                                                DOH_59        19
                                                                                                                                                                                                                                                DOH_59        20
 AHE      EQU    32          FETCH HARDWARE INFORMATION                                                                                                                                                                                         DOH_59        21
 RPL      SPACE  4,20                                                                                                                                                                                                                           DOH_240       17
**        REQUEST PROGRAM LENGTH.                                                                                                                                                                                                               DOH_222        2
*                                                                                                                                                                                                                                               DOH_222        3
*         RPL RETURNS THE LENGTH (IN CM WORDS) OF THE INDICATED                                                                                                                                                                                 DOH_222        4
*         PROGRAM.  NOTE THAT THIS FUNCTION IS NOT TO BE USED                                                                                                                                                                                   DOH_222        5
*         FOR DATA ITEMS SUCH AS *VCU* AND *CEL*.  USE FUNCTION                                                                                                                                                                                 DOH_222        6
*         34(8) TO ACCESS LENGTHS OF ONE SECTOR DATA ITEMS.                                                                                                                                                                                     DOH_222        7
*                                                                                                                                                                                                                                               DOH_222        8
*         8/RC, 8/RPL, 32/CIP IMAGE NAME, 16/LENGTH                                                                                                                                                                                             DOH_222        9
*         16/FN, 16/TES, 32/RFU                                                                                                                                                                                                                 DOH_240       18
*                                                                                                                                                                                                                                               DOH_222       10
*         LENGTH = PROGRAM LENGTH IN CM WORDS.  THIS IS AN OUTPUT                                                                                                                                                                               DOH_222       11
*                  PARAMETER.                                                                                                                                                                                                                   DOH_222       12
*         THE FOLLOWING TWO OUTPUT PARAMETERS ARE ONLY VALID WHEN (RC) = 6.                                                                                                                                                                     DOH_240       19
*         FN = *2AP* FUNCTION NUMBER FOR WHICH ERROR OCCURRED.                                                                                                                                                                                  DOH_240       20
*         TES = *2AP* ERROR STATUS.                                                                                                                                                                                                             DOH_240       21
                                                                                                                                                                                                                                                DOH_222       13
                                                                                                                                                                                                                                                DOH_222       14
 RPL      EQU    33          REQUEST PROGRAM LENGTH                                                                                                                                                                                             DOH_222       15
 RDL      SPACE  4,20                                                                                                                                                                                                                           DOH_240       22
**        REQUEST DATA LENGTH.                                                                                                                                                                                                                  DOH_222       17
*                                                                                                                                                                                                                                               DOH_222       18
*         RDL RETURNS THE LENGTH (IN CM WORDS) OF THE INDICATED                                                                                                                                                                                 DOH_222       19
*         DATA ITEM.  NOTE THAT THIS FUNCTION IS NOT TO BE USED                                                                                                                                                                                 DOH_222       20
*         TO OBTAIN THE LENGTH OF PROGRAMS.  USE FUNCTION 33(8)                                                                                                                                                                                 DOH_222       21
*         TO ACCESS THE LENGTHS OF MULTISECTOR PROGRAMS.                                                                                                                                                                                        DOH_222       22
*                                                                                                                                                                                                                                               DOH_222       23
*         8/RC, 8/RDL, 32/CIP IMAGE NAME, 16/LENGTH                                                                                                                                                                                             DOH_222       24
*         16/FN, 16/TES, 32/RFU                                                                                                                                                                                                                 DOH_240       23
*                                                                                                                                                                                                                                               DOH_222       25
*         LENGTH = DATA LENGTH IN CM WORDS.  THIS IS AN OUTPUT                                                                                                                                                                                  DOH_222       26
*                  PARAMETER.                                                                                                                                                                                                                   DOH_222       27
*         THE FOLLOWING TWO OUTPUT PARAMETERS ARE ONLY VALID WHEN (RC) = 6.                                                                                                                                                                     DOH_240       24
*         FN = *2AP* FUNCTION NUMBER FOR WHICH ERROR OCCURRED.                                                                                                                                                                                  DOH_240       25
*         TES = *2AP* ERROR STATUS.                                                                                                                                                                                                             DOH_240       26
                                                                                                                                                                                                                                                DOH_222       28
                                                                                                                                                                                                                                                DOH_222       29
 RDL      EQU    34          REQUEST DATA LENGTH                                                                                                                                                                                                DOH_222       30
 MVP      SPACE  4,10                                                                                                                                                                                                                           KAP_84         1
**        MANAGE VIRTUAL PROCESSOR.                                                                                                                                                                                                             KAP_84         2
*                                                                                                                                                                                                                                               KAP_84         3
*         PERFORMS A SPECIFIED ACTION ON A SPECIFIED CPU.                                                                                                                                                                                       KAP_84         4
*                                                                                                                                                                                                                                               KAP_84         5
*         8/RC, 8/MVP, 8/CPU, 8/ACT, 32/0.                                                                                                                                                                                                      KAP_84         6
*                                                                                                                                                                                                                                               KAP_84         7
*         ACT = ACTION TO BE PERFORMED.                                                                                                                                                                                                         KAP_84         8
*           0 = START CPU.                                                                                                                                                                                                                      KAP_84         9
*           1 = HALT CPU.                                                                                                                                                                                                                       KAP_84        10
                                                                                                                                                                                                                                                DOH_222       31
                                                                                                                                                                                                                                                KAP_84        11
 MVP      EQU    35          MANAGE VIRTUAL PROCESSOR                                                                                                                                                                                           KAP_84        12
 CES      SPACE  4,10                                                                                                                                                                                                                           KAP_4024       5
**        CHANGE ELEMENT STATE.                                                                                                                                                                                                                 KAP_4024       6
*                                                                                                                                                                                                                                               KAP_4024       7
*         THIS REQUEST IS PROCESSED BY THE CYBER 2000 SERVICE PROCESSOR                                                                                                                                                                         KAP_4024       8
*         DFT ONLY.                                                                                                                                                                                                                             KAP_4024       9
                                                                                                                                                                                                                                                KAP_4024      10
 CES      EQU    36          CHANGE ELEMENT STATE                                                                                                                                                                                               KAP_4024      11
 GED      SPACE  4,25                                                                                                                                                                                                                           KAP_4024      12
**        GET ELEMENT DESCRIPTOR.                                                                                                                                                                                                               KAP_4024      13
*                                                                                                                                                                                                                                               KAP_4024      14
*         THIS REQUEST IS PROCESSED BY THE CYBER 2000 SERVICE PROCESSOR                                                                                                                                                                         KAP_4024      15
*         DFT ONLY.                                                                                                                                                                                                                             KAP_4024      16
*                                                                                                                                                                                                                                               KAP_4024      17
*         8/RC, 8/GED, 16/ELEMENT, 16/SUB-ELEMENT, 16/LENGTH.                                                                                                                                                                                   KAP_4024      18
*                                                                                                                                                                                                                                               KAP_4024      19
*         ELEMENT = ELEMENT IDENTIFIER.                                                                                                                                                                                                         KAP_4024      20
*           00 = CPU0.                                                                                                                                                                                                                          KAP_4024      21
*           10 = CPU1.                                                                                                                                                                                                                          KAP_4024      22
*           01 = CENTRAL MEMORY.                                                                                                                                                                                                                KAP_4024      23
*           02 = IOU0.                                                                                                                                                                                                                          KAP_4024      24
*           12 = IOU1.                                                                                                                                                                                                                          KAP_4024      25
*         SUB-ELEMENT = SUB-ELEMENT IDENTIFIER.                                                                                                                                                                                                 KAP_4024      26
*           IF ELEMENT = 01 (CENTRAL MEMORY) THEN                                                                                                                                                                                               KAP_4024      27
*               0     = CENTRAL MEMORY ELEMENT DESCRIPTOR.                                                                                                                                                                                      KAP_4024      28
*             100(16) = OS FLAW TABLE ELEMENT DESCRIPTOR.                                                                                                                                                                                       KAP_4024      29
*           IF ELEMENT = X2 (IOU ELEMENT) THEN                                                                                                                                                                                                  KAP_4024      30
*               0     = IOU ELEMENT DESCRIPTOR.                                                                                                                                                                                                 KAP_4024      31
*             100(16) = CHANNEL DESCRIPTOR.                                                                                                                                                                                                     KAP_4024      32
*             200(16) = PP DESCRIPTOR.                                                                                                                                                                                                          KAP_4024      33
*         LENGTH = LENGTH OF ELEMENT DESCRIPTOR IN CM WORDS.                                                                                                                                                                                    KAP_4024      34
                                                                                                                                                                                                                                                KAP_4024      35
                                                                                                                                                                                                                                                KAP_4024      36
 GED      EQU    37          GET ELEMENT DESCRIPTOR                                                                                                                                                                                             KAP_4024      37
 ASM      SPACE  4,15                                                                                                                                                                                                                           KAP_4024      38
**        ACCESS/CHANGE SECURED MODE.                                                                                                                                                                                                           KAP_4024      39
*                                                                                                                                                                                                                                               KAP_4024      40
*         THIS REQUEST IS PROCESSED BY THE CYBER 2000 SERVICE PROCESSOR                                                                                                                                                                         KAP_4024      41
*         DFT ONLY.                                                                                                                                                                                                                             KAP_4024      42
                                                                                                                                                                                                                                                KAP_4024      43
                                                                                                                                                                                                                                                KAP_4024      44
 ASM      EQU    40          ACCESS/CHANGE SECURED MODE                                                                                                                                                                                         KAP_4024      45
 CDT      SPACE  4,10                                                                                                                                                                                                                           KAP_4024      46
**        CHANGE DATE/TIME INFORMATION.                                                                                                                                                                                                         KAP_4024      47
*                                                                                                                                                                                                                                               KAP_4024      48
*         THIS REQUEST IS PROCESSED BY THE CYBER 2000 SERVICE PROCESSOR                                                                                                                                                                         KAP_4024      49
*         DFT ONLY.                                                                                                                                                                                                                             KAP_4024      50
                                                                                                                                                                                                                                                KAP_4024      51
                                                                                                                                                                                                                                                KAP_4024      52
 CDT      EQU    41          CHANGE DATE/TIME INFORMATION                                                                                                                                                                                       KAP_4024      53
 RDT      SPACE  4,10                                                                                                                                                                                                                           KAP_4024      54
**        READ DATE/TIME INFORMATION.                                                                                                                                                                                                           KAP_4024      55
*                                                                                                                                                                                                                                               KAP_4024      56
*         THIS REQUEST IS PROCESSED BY THE CYBER 2000 SERVICE PROCESSOR                                                                                                                                                                         KAP_4024      57
*         DFT ONLY.                                                                                                                                                                                                                             KAP_4024      58
                                                                                                                                                                                                                                                KAP_4024      59
                                                                                                                                                                                                                                                KAP_4024      60
 RDT      EQU    42          READ DATE/TIME INFORMATION                                                                                                                                                                                         GJF_8166       2
 GGM      SPACE  4,10                                                                                                                                                                                                                           GJF_8166       3
**        GET FLAW FREE MEMORY.                                                                                                                                                                                                                 GJF_8166       4
*                                                                                                                                                                                                                                               GJF_8166       5
*         THIS REQUEST IS PROCESSED BY THE CYBER 2000 SERVICE PROCESSOR                                                                                                                                                                         GJF_8166       6
*         DFT ONLY.                                                                                                                                                                                                                             GJF_8166       7
                                                                                                                                                                                                                                                KAP_4024      67
                                                                                                                                                                                                                                                KAP_4024      68
 GGM      EQU    43          GET FLAW FREE MEMORY.                                                                                                                                                                                              GJF_8166       8
 SSA      SPACE  4,10                                                                                                                                                                                                                           KAP_4024      70
**        SYSTEM STATE ALERT.                                                                                                                                                                                                                   KAP_4024      71
*                                                                                                                                                                                                                                               KAP_4024      72
*         THIS REQUEST IS PROCESSED BY THE CYBER 2000 SERVICE PROCESSOR                                                                                                                                                                         KAP_4024      73
*         DFT ONLY.                                                                                                                                                                                                                             KAP_4024      74
                                                                                                                                                                                                                                                KAP_4024      75
                                                                                                                                                                                                                                                KAP_4024      76
 SSA      EQU    44          SYSTEM STATE ALERT                                                                                                                                                                                                 KAP_4024      77
 RIS      SPACE  4,10                                                                                                                                                                                                                           GJF_8180       3
**        RETRIEVE IOU STATUS REGISTER.                                                                                                                                                                                                         GJF_8180       4
*                                                                                                                                                                                                                                               GJF_8180       5
*         THIS REQUEST WILL RETURN IOU REGISTER 40(16) TO THE REQUESTOR.                                                                                                                                                                        GJF_8180       6
                                                                                                                                                                                                                                                GJF_8180       7
*         8/RC, 8/TASKID, 8/IOU#, 40/RFU                                                                                                                                                                                                        GJF_8180       8
*         64/CONTENTS OF REGISTER 40(16).                                                                                                                                                                                                       GJF_8180       9
                                                                                                                                                                                                                                                GJF_8180      10
 RIS      EQU    45          RETURN IOU STATUS REGISTER                                                                                                                                                                                         GJF_8180      11
 RSP      SPACE  4,10                                                                                                                                                                                                                           GJF_8180      12
**        RELOAD SCI PP.                                                                                                                                                                                                                        GJF_8180      13
*                                                                                                                                                                                                                                               GJF_8180      14
*         THIS REQUEST WILL RELOAD THE SCI PP.  THE FORMAT IS:                                                                                                                                                                                  GJF_8180      15
                                                                                                                                                                                                                                                GJF_8180      16
*         8/RC, 8/TASKID, 8/IOU NUMBER, 8/CIO, 8/PP NUMBER, 24/RFU                                                                                                                                                                              GJF_8180      17
                                                                                                                                                                                                                                                GJF_8180      18
 RSP      EQU    46          RELOAD THE SCI PP REQUEST                                                                                                                                                                                          GJF_8180      19
                                                                                                                                                                                                                                                GJF_8180      20
                                                                                                                                                                                                                                                GJF_8180      21
*         FOLLOWING ARE 170 OPERATING SYSTEM REQUESTS TO DFT.                                                                                                                                                                                   DOH_221      100
          SPACE  4                                                                                                                                                                                                                              R123_OS      180
 UDT      EQU    1           UPDATE TIME                                                                                                                                                                                                        R123_OS      181
                                                                                                                                                                                                                                                R123_OS      182
 THR      EQU    2           UPDATE THRESHOLDS FOR DFT ERRORS                                                                                                                                                                                   R123_OS      183
                                                                                                                                                                                                                                                R123_OS      184
 UFV      EQU    3           UPDATE FREE RUNNING COUNTER                                                                                                                                                                                        R123_OS      185
          SPACE  4                                                                                                                                                                                                                              R123_OS      186
          ENDX                                                                                                                                                                                                                                  R123_OS      187
*DECK DECK=DSC$CONDITION_LIMITS EXPAND=FALSE

  CONST
    dsc$min_ecc = (($INTEGER ('D') * 100(16)) + $INTEGER ('S')) * 1000000(16),
    dsc$max_ecc = dsc$min_ecc + 9999;

  CONST
    dsc$display_processor_id = 'DS';

*DECK DECK=DSC$CONSTANT_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := '~~~~~   common deck DSC$CONSTANT_DEFINITIONS', EJECT ??
{*********************************************************

{  Dsc constant definitions, deck DSC$CONSTANT_DEFINITIONS

{*********************************************************

  CONST
    register_size = 8,
    large_jobs = 1001(16), {cio buffer size faster data transfer
    one_megabytes = 1048576,
    bytes_per_octal_1k_words = 512 * 8,
    dump_block_size = 512, {memory dump block size in words
    left_slot = 10000(16);

?? OLDTITLE ??
*DECK DECK=DSC$DFT_REQUEST_WAIT_TIMES EXPAND=FALSE
*DECK DECK=DSC$JOB_CONTROL_REGISTERS EXPAND=FALSE
?? NEWTITLE := '~~~~~   common deck DSC$JOB_CONTROL_REGISTERS', EJECT ??
{***************************************************************

{  Job control register definitions, deck DSC$JOB_CONTROL_REGISTERS.

{***************************************************************

  CONST

{  R2 register values.

    xecute_trmve = 0,
    xecute_runve = 1;

  TYPE
    sense_switch_set = set of (sw6, sw5, sw4, sw3, sw2, sw1),
    job_control_information = PACKED RECORD
      global_error_flag: 0 .. 77(8),
      global_r1: 0 .. 777777(8),
      reserved: 0 .. 7777(8),
      exit_mode: 0 .. 7777(8),
      sense_switches: sense_switch_set,
      zero: 0 .. 77(8),
      error_flag: 0 .. 77(8),
      r3: 0 .. 777777(8),
      r2: 0 .. 777777(8),
      r1: 0 .. 777777(8),
    RECEND;

  VAR
    jcr: [XREF] job_control_information;


  PROCEDURE [XREF] jcrset; {set job control registers

  PROCEDURE [XREF] jcrget; {get job control registers
?? OLDTITLE ??
*DECK DECK=DSC$LOG_DFT_FLAG_ID EXPAND=FALSE
*DECK DECK=DSC$MAX_DCFILE_LENGTH EXPAND=FALSE

  CONST
    dsc$max_dcfile_length = 4000;   { Byte size of the DCFILE.
*DECK DECK=DSC$MAX_NUMBER_OF_IOUS EXPAND=FALSE

  CONST
    dsc$max_number_of_ious = 2;
*DECK DECK=DSC$PP_MR_AND_TPM_CONSTANTS EXPAND=FALSE
          CTEXT  DSC$PP MR AND TPM CONSTANTS
          BASE   M
          SPACE  4,10
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4,10
***       DSC$PP MR AND TPM CONSTANTS
*         B. R. HANSON.      79/08/02.
          SPACE  4,10
*                DEFINES CYBER 180 MAINTENANCE REGISTER AND TWO-PORT
*         MULTIPLEXOR FUNCTIONS AND EQUIVALENCES.
          SPACE  4,10
****

*         CHANNEL DEFINITIONS.

 MR       EQU    17B         CYBER 180 MAINTENANCE CHANNEL
 MX       EQU    15B         TWO PORT MULTIPLEXOR CHANNEL

**        MAINTENANCE REGISTER EQUIVALENCES.

*         FUNCTIONS.

 MRHP     EQU    0#00        HALT PROCESSOR
 MRSP     EQU    0#10        START PROCESSOR
 MRRD     EQU    0#40        READ REGISTER
 MRWT     EQU    0#50        WRITE REGISTER
 MRMC     EQU    0#60        MASTER CLEAR
 MRCE     EQU    0#70        CLEAR FAULT STATUS REGISTER
 MREC     EQU    0#80        ECHO DATA
 MRSS     EQU    0#C0        REQUEST SUMMARY STATUS
 MRDC     EQU    0#AE0       DEACTIVATE MAINTENANCE CHANNEL CONTROL

*         MODEL INDEPENDENT REGISTER NUMBERS.

 SSMR     EQU    0#00        STATUS SUMMARY
 EIMR     EQU    0#10        ELEMENT ID
 OIMR     EQU    0#12        OPTIONS INSTALLED
 ECMR     EQU    0#20        ENVIRONMENT CONTROL
 DEMR     EQU    0#30        DEPENDENT ENVIRONMENT CONTROL

*         IOU REGISTERS.

 IFSM     EQU    0#18        FAULT STATUS MASK
 CIFSM    EQU    0#1C        FAULT STATUS MASK (CIO PPS)
 IOSB     EQU    0#21        OS BOUNDS
 CIOSB    EQU    0#25        OS BOUNDS (CIO PPS)
 ENIO     EQU    0#30        ENVIRONMENT CONTROL (NIO PPS)
 ECIO     EQU    0#34        ENVIRONMENT CONTROL (CIO PPS)
 ISTR     EQU    0#40        STATUS REGISTER
 SNIO     EQU    0#40        STATUS REGISTER (NIO PPS)
 SCIO     EQU    0#44        STATUS REGISTER (CIO PPS)
 IFS1     EQU    0#80        FAULT STATUS 1
 IFS2     EQU    0#81        FAULT STATUS 2
 CIFS1    EQU    0#84        FAULT STATUS 1 (CIO PPS)
 CIFS2    EQU    0#85        FAULT STATUS 2 (CIO PPS)
 ITMR     EQU    0#A0        TEST MODE REGISTER

*         S0/S0E IOU REGISTERS.

 S0IEC    EQU    0#20 - 0#24 ENVIRONMENT CONTROL REGISTERS (CLUSTER 0)
*S0IEC    EQU    0#30 - 0#34 ENVIRONMENT CONTROL REGISTERS (CLUSTER 2)
 S0IST    EQU    0#50 - 0#54 STATUS 1 REGISTERS (CLUSTER 0)
*S0IST    EQU    0#60 - 0#64 STATUS 1 REGISTERS (CLUSTER 2)
 S0IFS0   EQU    0#90 - 0#94 FAULT STATUS REGISTERS (CLUSTER 0)
 S0IBF0   EQU    0#9A        BUS ARBITER FAULT STATUS REGISTER (CLUSTER 0)
 S0IFS2   EQU    0#A0 - 0#A4 FAULT STATUS REGISTERS (CLUSTER 2)
 S0IBF2   EQU    0#AA        BUS ARBITER FAULT STATUS REGISTER (CLUSTER 2)
 S0ICF0   EQU    0#B0        CHANNEL FAULT STATUS REGISTER (CLUSTER 0)
 S0ICF2   EQU    0#B8        CHANNEL FAULT STATUS REGISTER (CLUSTER 2)

*         MEMORY REGISTERS.

 MBRG     EQU    0#21        MEMORY BOUNDS REGISTER
 MCEL     EQU    0#A0        CORRECTED ERROR LOG
 MUL1     EQU    0#A4        UNCORRECTED ERROR LOG 1
 MUL2     EQU    0#A8        UNCORRECTED ERROR LOG 2
 MFRC     EQU    0#B0        FREE RUNNING COUNTER

*         S0/S0E MEMORY REGISTERS.

 S0MBD    EQU    0#30 - 0#3F BANK DATA AND CONTROL
 S0MOI    EQU    0#58        MEMORY OPTIONS INSTALLED
 S0MBRG   EQU    0#60        MEMORY BOUNDS REGISTER
 S0MBA    EQU    0#90        CENTRAL MEMORY BUS ARBITRATOR
 S0MIB    EQU    0#91 - 0#95 INPUT BUFFER
 S0MUD    EQU    0#A0 - 0#AF UNCORRECTED BANK DATA AND CONTROL
 S0MCD    EQU    0#D0 - 0#DF CORRECTED BANK DATA AND CONTROL
 S0MBC    EQU    0#E0 - 0#EF CORRECTED BANK CONTROL

*         PROCESSOR REGISTERS.

 PPID     EQU    0#11        PROCESSOR ID
 PVCM     EQU    0#13        VIRTUAL MACHINE CAPABILITY LIST
 PMF1     EQU    0#21        PROCESSOR MONITORING FACILITY 1
 PMF2     EQU    0#22        PROCESSOR MINITORING FACILITY 2
 PCSA     EQU    0#31        CONTROL STORE ADDRESS
 PCSB     EQU    0#32        CONTROL STORE BREAKPOINT
 PPRG     EQU    0#40        PROGRAM ADDRESS REGISTER
 PMPS     EQU    0#41        MONITOR PROCESS STATE REGISTER
 PMCR     EQU    0#42        MONITOR STATE CONTROL REGISTER
 PUCR     EQU    0#43        USER STATE CONTROL REGISTER
 PUPR     EQU    0#44        UNTRANSLATABLE POINTER
 PSTL     EQU    0#45        SEGMENT TABLE LENGTH
 PSTA     EQU    0#46        SEGMENT TABLE ADDRESS
 PBCR     EQU    0#47        BASE ADDRESS REGISTER
 PPTA     EQU    0#48        PAGE TABLE ADDRESS
 PPTL     EQU    0#49        PAGE TABLE LENGTH
 PPSM     EQU    0#4A        PAGE SIZE MASK
 PMDF     EQU    0#50        MODEL DEPENDENT FLAGS
 PMDW     EQU    0#51        MODEL DEPENDENT WORD
 PMMR     EQU    0#60        MONITOR MASK
 PJPS     EQU    0#61        JOB PROCESS STATE REGISTER
 PSIT     EQU    0#62        SYSTEM INTERVAL TIMER
 PKBP     EQU    0#63        KEYPOINT BUFFER POINTER
 PPFS     EQU    0#80        PROCESSOR FAULT STATUS
 PCSP     EQU    0#81        CONTROL MEMORY PARITY
 PRCL     EQU    0#90        RETRY CORRECTED ERROR LOG
 PUCS     EQU    0#91        CONTROL STORE ERROR LOG
 PCCL     EQU    0#92        CACHE CORRECTED ERROR LOG
 PMCL     EQU    0#93        MAP CORRECTED ERROR LOG
 PPTM     EQU    0#A0        TEST MODE
 PTPE     EQU    0#C0        TRAP ENABLES
 PTRP     EQU    0#C4        TRAP POINTER
 PDLP     EQU    0#C5        DEBUG LIST POINTER
 PKPM     EQU    0#C6        KEYPOINT HASH
 PKPC     EQU    0#C7        KEYPOINT CODE
 PKCN     EQU    0#C8        KEYPOINT CLASS NUMBER
 PPIT     EQU    0#C9        PROCESSOR INTERVAL TIMER
 PCCF     EQU    0#E0        CRITICAL FRAME FLAG
 POCF     EQU    0#E2        ON CONDITION FLAG
 PDBI     EQU    0#E4        DEBUG INDEX
 PDBM     EQU    0#E5        DEBUG MASK
 PUSM     EQU    0#E6        USER MASK
 PRDM     EQU    0#FF        REGISTER FILE DUMP ADDRESS

*         S0/S0E PROCESSOR REGISTERS.

 SEPRPR   EQU    0#20        REGISTER FILE PFS AND RETRY (S0E ONLY)
 SEPCSC   EQU    0#25        CONTROL STORE CONTROL (S0E ONLY)
 S0PCSD   EQU    0#29        CONTROL STORE ADDRESS/SECDED DEC (S0 ONLY)
 S0PPRC   EQU    0#2C        PFS/RETRY CONTROL (S0 ONLY)
 SEPCSS   EQU    0#9B        CONTROL STORE SECDED (S0E ONLY)
 S0PCSS   EQU    0#9E        CONTROL STORE SECDED (S0 ONLY)
 S0PCSA   EQU    0#831       CONTROL STORE ADDRESS
 S0PPRG   EQU    0#840       PROGRAM ADDRESS REGISTER
 S0PMPS   EQU    0#841       MONITOR PROCESS STATE REGISTER
 S0PMCR   EQU    0#842       MONITOR STATE CONTROL REGISTER
 S0PUPR   EQU    0#844       UNTRANSLATABLE POINTER
 S0PPTA   EQU    0#848       PAGE TABLE ADDRESS
 S0PPTL   EQU    0#849       PAGE TABLE LENGTH
 S0PPSM   EQU    0#84A       PAGE SIZE MASK
 S0PJPS   EQU    0#861       JOB PROCESS STATE REGISTER
 S0PSIT   EQU    0#862       SYSTEM INTERVAL TIMER
 S0PUEL   EQU    0#880 - 0#881  PROCESSOR UNCORRECTED ERROR LOG (REGISTER PAIR)
 S0PFCL   EQU    0#890 - 0#891  PROCESSOR FIRST/CORRECTED ERROR LOG (REG. PAIR)

*         S0/S0E PAGE MAP REGISTERS.

 S0PPMC   EQU    0#26        PAGE MAP CONTROL REGISTER

*         STATUS SUMMARY BITS.

 SSLW     EQU    0           LONG WARNING (IOU, MEM, PROC)
 SSCE     EQU    1           CORRECTED ERROR (MEM, PROC)
 SSUE     EQU    2           UNCORRECTED ERROR (IOU, MEM, PROC)
 SSPH     EQU    3           PROCESSOR HALT (IOU, PROC)
 SSSS     EQU    4           STATUS SUMMARY (IOU)
 SSSW     EQU    4           SHORT WARNING (PROCESSOR)
 SSBA     EQU    6           BLOCKED CM ACCESS FROM IOU (I4C, I4_43, I4CE)
 SSMM     EQU    5           EXECUTIVE MONITOR MODE (PROCESSOR)
 SSPM     EQU    6           PAGE MAP ERROR (S0/S0E)

*         TWO PORT MUX FUNCTIONS.

 MXSS     EQU    0000        STATUS SUMMARY
 MXRD     EQU    0100        READ CHARACTER
 MXWT     EQU    0200        WRITE CHARACTERS
 MXSM     EQU    0300        SET TERMINAL OPERATION MODE
 MXDR     EQU    0400        SET/CLEAR DATA TERMINAL READY SIGNAL
 MXRTS    EQU    0500        SET/CLEAR REQUEST TO SEND SIGNAL
*         EQU    0600        (NOT USED)
 MXMC     EQU    0700        MASTER CLEAR
 MXPS     EQU    3300        READ PORT STATUS (S0/S0E)
 MXRW     EQU    1004        READ WALL CLOCK CHIP
 MXKS     EQU    1052        READ PACKET STATUS (NON-S0/SOE)
 MXCP     EQU    1055        CLEAR PACKETS
 MXDM     EQU    6000        DESELECT TERMINAL
 MXPT     EQU    7000        CONNECT TO PORT

*         TWO PORT MUX STATUS BITS.

 OBRB     EQU    4           OUTPUT BUFFER NOT FULL
 INRB     EQU    3           INPUT READY
 DCDB     EQU    2           DATA CARRIER DETECT
 DSRB     EQU    1           DATA SET READY
 RNGB     EQU    0           RING INDICATOR

*         TWO PORT MUX INPUT FLAGS.

 RDSR     EQU    13          DATA SET READY
 RDSC     EQU    12          DATA SET READY AND DATA CHARACTER DETECT
 ROVR     EQU    11          OVERRUN
 RFPE     EQU    10          FRAMING PARITY ERROR
*CHAR     EQU    0-7         DATA CHARACTER

*         TWO PORT MUX OPERATIONAL MODE EQUATES.

 SPTY     EQU    0020        NO PARITY
 SSTP     EQU    0010        SELECT ADDITIONAL STOP BIT
 S8BC     EQU    0006        SELECT 8 DATA BITS PER CHARACTER
 S7BC     EQU    0004        SELECT 7 DATA BITS PER CHARACTER
 S6BC     EQU    0002        SELECT 6 DATA BITS PER CHARACTER
 S5BC     EQU    0000        SELECT 5 DATA BITS PER CHARACTER
 SODD     EQU    0001        SELECT ODD PARITY

*         TWO PORT MUX PORT DEFINITIONS.

 SSCP     EQU    0000        STANDARD SYSTEM CONSOLE
 MTCP     EQU    0001        MAINTENANCE CONSOLE

*         TWO PORT MUX OPERATIONAL MODE SELECTIONS FOR VARIOUS TERMINALS.

 CDC752   EQU    SPTY+S7BC  7 BITS PER CHARACTER + EVEN PARITY

*         MCR BIT MASK DEFINITIONS.

 DUE      EQU    0#8000      DETECTED UNCORRECTED ERROR
*                0#4000      UNUSED BIT
 SHW      EQU    0#2000      SHORT WARNING
 ISE      EQU    0#1000      INSTRUCTION SPECIFICATION ERROR
 ASE      EQU    0#0800      ADDRESS SPEC ERROR
 EXR      EQU    0#0400      170 EXCHANGE REQUEST
 ACV      EQU    0#0200      ACCESS VIOLATION
 ESE      EQU    0#0100      ENVIRONMENTAL SPECIFICATION ERROR
 EXI      EQU    0#0080      EXTERNAL INTERRUPT
 PWF      EQU    0#0040      PAGE TABLE SEARCH WITHOUT FIND
 SYC      EQU    0#0020      SYSTEM CALL
 SIT      EQU    0#0010      SYSTEM INTERVAL TIMER
 ISR      EQU    0#0008      INVALID SEGMENT/RING NUMBER ZERO
 OUC      EQU    0#0004      OUTWARD CALL/INWARD RETURN
 SEL      EQU    0#0002      SOFT ERROR LOG
 TRE      EQU    0#0001      TRAP EXCEPTION
 NDUE     EQU    0#7FFF      NOT DUE
 NSEL     EQU    0#FFFD      NOT SOFT ERROR LOG

*         990 PFS REGISTER BIT MASK DEFINITIONS

 PFIT     EQU    0#400       ISSUE TIMEOUT BIT MASK
 PFPW     EQU    0#10        PARTIAL WRITE PE BIT MASK

****
          SPACE  4,10
          BASE   *
          ENDX
*DECK DECK=DSC$PREVIOUS_RECOVERY_TYPE EXPAND=FALSE

  CONST
    dsc$recovery_completed_normally = 'COMPLETE',
    dsc$recovery_with_image = 'IMAGE   ',
    dsc$recovery_without_image = 'NO_IMAGE';
*DECK DECK=DSC$RDF_CONSTANTS EXPAND=FALSE

  CONST
    dsc$rdf_directory_size = 1200,
    dsc$rdf_size = (64 * 1024);
*DECK DECK=DSC$RETRIEVE_SYSTEM_MESSAGE EXPAND=FALSE
*DECK DECK=DSC$SSR_ENTRY_CONSTANTS EXPAND=FALSE

{  This deck defines the system status record (SSR) entry constants.  These are the four character names that
{  identify each SSR entry.  The SSR is addressed by PP programs, Cyber 170 programs and NOS/VE system
{  programs.  Therefore, the format has not been rigorously defined with Cybil type definitions (it still
{  probably should be).  The SSR entry is always one 64 bit word, the left half of the word (32 bits) is the
{  four ascii characters identifying the entry, the right half of the word (32 bits) is either entry
{  information or the length in words (16 bits) and offset in words (16 bits) from the begining of the SSR
{  of a sequence containing the entry information.
{
{  NOTE:
{    There is a another deck, dsm$system_status_record, which defines the SSR contents.  When an entry
{    is added to this deck it must also be added to that deck.

  CONST

    { The SSRD entry defines the SSR directory.  It is in the sequence pointer format, the offset is relative
    { to this entry and the length is the length of the SSR directory.

    dsc$ssr_directory = 'SSRD',

    { The SSRS entry defines the total length of the SSR.  It is in the sequence pointer format.

    dsc$ssr_total_length = 'SSRS',

    dsc$ssr_deadstart_type = 'DTYP',
    dsc$ssr_run_sequencing = 'RUNS',
    dsc$ssr_deadstart_state = 'SDST',
    dsc$ssr_termination_status = 'BYVE',

    { The IMGS entry is used to make a decision on writing or not writing the image file.  This entry is in
    { the value format.  The values it has and their meaning are as follows:
    {      = 0 implies setup to write image file.
    {      = 1 implies write image file.
    {      = 2 implies image file write complete.
    {      = 3 implies that the SSR has been loaded from CIP and all values are the initial values.  Memory
    {          can not be used for recovery.

    dsc$ssr_image_state = 'IMGS',

    { The IMGL entry defines the length of the memory image.  This entry is in the value format.

    dsc$ssr_image_length = 'IMGL',

    { The IMGO entry defines the offset to the memory image in the recovery device file.  This entry is in
    { the value format.

    dsc$ssr_image_offset = 'IMGO',

    { The C80B entry defines the buffer for the 170 to 180 deadstart communication.  It is in the sequence
    { pointer format.

    dsc$ssr_c180_transfer_buffer = 'C80B',

    { The C70B entry defines the buffer for the 180 to 170 deadstart communication.  It is in the sequence
    { pointer format.

    dsc$ssr_c170_transfer_buffer = 'C70B',

    { The MEMB entry defines the buffer that contains the address of the contiguous memory locations
    { where the memory that VCB is loaded into is copied before VCB is loaded.  This memory is not
    { recovered so it can not contain information relevant to the recovery.  What is there is the
    { monitor segment and stacks and the job fixed segment of the system monitor job.  It is desirable
    { for the size of this area to be smaller than the parts that are loaded into it, if it is not
    { this memory is lost to the running system.  The address of the buffer is defined in 2 halfword
    { values, the left half is the beginning rma in r register format and the right half is the
    { the length in r register format.  The entry is in the sequence pointer format.

    dsc$ssr_boot_memory_bounds = 'MEMB',

    { The DPNL entry defines the buffer where the deadstart panel image is saved.  It is in the sequence
    { pointer format.

    dsc$ssr_deadstart_panel = 'DPNL',

    { The DFTB entry defines the buffer for passing NOS/VE system requests to DFT.  It is in the sequence
    { pointer format.

    dsc$ssr_dft_buffer = 'DFTB',

    dsc$ssr_smu_buffer = 'SMUB',

    { The BPTR entry defines a buffer of sequence pointers.  The sequence pointers point to data in the boot
    { that has to be accessed from system core.  This entry is in the sequence pointer format.

    dsc$ssr_boot_pointer_area = 'BPTR',

    { The NAME entry defines a buffer that contains the recovery state of memory (the SSR).  The buffer
    { contains ascii character strings that describe the state.  It indicates whether the memory image
    { is present and in good shape.  It is set at system commit time.  System commit time is that point
    { at which the system is in a state where doing a deadstart will recover the system that was running.
    { This entry is in the sequence pointer format.

    dsc$ssr_image_status = 'NAME',

    { The VEPP entry defines the buffer for keeping track of PPs and channels assigned to NOS/VE.  It is in
    { the sequence pointer format.

    dsc$ssr_resource_assignment = 'VEPP',

    { The HDWR entry defines a buffer to save the CPU register values of the most recently deadstarted NOS/VE
    { system.  The entries in the buffer are in five word groups.  The first word in each group defines four
    { register numbers, 16 bits for each register, followed by the corresponding register value starting with
    { the left most register number.  This entry is in the sequence pointer format.

    dsc$ssr_initial_cpu_registers = 'HDWR',

    { The DSAV entry defines a buffer to save the CPU register values for EI.  The entries in the buffer are
    { in the same format as those defined for HDWR.  This entry is in the sequence pointer format.

    dsc$ssr_deadstart_save_area = 'DSAV',

    { The RSAV entry defines a buffer to save the CPU register values of the host operating system when
    { switching from 170 to dual state mode of operation.  The entries in the buffer are in the same format
    { as those defined in HDWR.  This entry is in the sequence pointer format.

    dsc$ssr_recovery_save_area = 'RSAV',

    dsc$ssr_pointer_save_area = 'CREP',

    dsc$ssr_driver_code_buffer = 'DRCP',

    { The PPBF entry defines a buffer of contiguous memory.  These memory locations are used for loading and
    { dumping PPs and some CTI interfaces.  This entry is in the sequence pointer format.

    dsc$ssr_pp_controlware_buf = 'PPBF',

    { The RIHT entry defines a buffer for the modify bit map of the page table.  It is in the sequence
    { pointer format.

    dsc$ssr_modify_bit_map_pt = 'RIHT',

    { The SYSL entry defines the SSR system level number.  This entry is in the value format.  It contains the
    { system level number that is checked by system core to determine compatibility between the system core
    { and the boot.  The values are setup in the deck dsm$system_status_record which contains the PP code for
    { the SSR.

    dsc$ssr_system_level_number = 'SYSL',

    { The DFTS entry defines the offset and length of the second DFT buffer.  This entry is in the sequence
    { pointer format.  DFTS contains a mini DFT buffer used for communication purposes by the primary and
    { secondary DFT.  As of version 6 DFT, this entry will no longer contain valid information.  The entry
    { is left intact for back level support.  Non dual I4 systems running with a version 6 DFT will expect
    { this area to be zeros.

    dsc$ssr_secondary_dft_block = 'DFTS',

    { The SCIR entry defines a request area for SCI to use.  This entry is in the sequence pointer format.

    dsc$ssr_sci_request_area = 'SCIR',

    { The STAT entry contains data for the System Deadstart Status statistic.  This entry is in the sequence
    { pointer format.

    dsc$ssr_system_deadstart_status = 'STAT',

    { The SCKS entry contains the SSR checksum used by VPB to verify the SSR directory in memory.  It is in
    { the value format.

    dsc$ssr_checksum = 'SCKS',

    { The WAIT entry contains the operator intervention flag from CTI or from the NVE subsystems.  SCI picks
    { up this information from CTI through the MRT and places the value in this entry OR the NVE subsystem
    { Places the wait information in this entry.  This entry is in the value format.

    dsc$ssr_operator_intervention = 'WAIT',

    { The SCPT entry defines an area to be used for the SCI Parameter Table when not allocated by NOS, NOS/BE,
    { or SCI during the standalone deadstart process.  This entry is in the sequence pointer format.

    dsc$ssr_sci_parameter_table = 'SCPT',

    dsc$ssr_directory_end = 'SSDE';
*DECK DECK=DSC$SYSTEM_LOG_FILE_SIZE EXPAND=FALSE

  CONST
    dsc$system_log_file_size = 8000(16);

*DECK DECK=DSD$OS_GLOBAL_VARIABLES EXPAND=FALSE
?? NEWTITLE := '~~~~~   common deck DSD$OS_GLOBAL_VARIABLES', EJECT ??
{*********************************************************

{  Dsc global variables, deck DSD$OS_GLOBAL_VARIABLES.

{*********************************************************

  VAR
    command_file: file, {legible_file
    error_flag: boolean,
    exitcd: [XREF] integer,
    mycmnds: string (7),

{  System definition variables.

    auto_recovery: boolean := FALSE, {recovery mode
    cptp_r_pointer: dst$r_pointer, {critical_page_table_r_pointer
    interface_block_addr: integer := 0, { in words
    load_offset_bytes: integer := 0,
    min_nve_memory: integer := 2 * one_megabytes,
    memory_limit: integer := 2097152, {size in words
    nve_memory: integer := 0, {nve memory in bytes
    ssr_address_words: integer := 0;
?? OLDTITLE ??
*DECK DECK=DSE$DEADSTART_IO_ERRORS EXPAND=FALSE
*copyc dsc$condition_limits

?? FMT (FORMAT := OFF) ??

{ Deadstart IO Errors }

  CONST
     {220 - 229}
    dse$tape_io_error               = dsc$min_ecc + 220,
       {E +P1}
    dse$disk_io_error               = dsc$min_ecc + 221,
       {E +P1}
    dse$incorrect_deadstart_file    = dsc$min_ecc + 222,
       {E +P1}
    dse$damaged_deadstart_file      = dsc$min_ecc + 223,
       {E +P1}
    dse$unknown_deadstart_device    = dsc$min_ecc + 224;
       {E +P1}

?? FMT (FORMAT := ON) ??
*DECK DECK=DSE$DEADSTART_MULTIPRO_ERRORS EXPAND=FALSE
?? NEWTITLE := 'DSE$DEADSTART_MULTIPRO_ERRORS : ''DS'' 0 .. 10' ??
*copyc dsc$condition_limits

  CONST
    dse$model_number_not_in_table = dsc$min_ecc + 0;
    {E The cpus model number is not in the search table; +T }

?? OLDTITLE ??

*DECK DECK=DSE$DEADSTART_UTILITY_ERRORS EXPAND=FALSE
*copyc dsc$condition_limits

?? FMT (FORMAT := OFF) ??

{Deadstart Utility Errors: 'DS' 20 - 39 }

  CONST
    dse$empty_input_file            = dsc$min_ecc + 20,
       {E The input file is empty.}
    dse$empty_record_list           = dsc$min_ecc + 21,
       {E No records exist on the current record list.}
    dse$invalid_range               = dsc$min_ecc + 22,
       {E The range specified is invalid.}
    dse$invalid_record              = dsc$min_ecc + 23,
       {E The input file contains an invalid +P1.}
    dse$invalid_vdt_format          = dsc$min_ecc + 24,
       {E The DATA_12_IN_16 parameter is not allowed with the VDT_FILE parameter.}
    dse$multiple_crebff_called      = dsc$min_ecc + 25,
       {E The utility CREATE_BINARY_FORMATTED_FILE cannot be called multiple times.}
    dse$record_not_found            = dsc$min_ecc + 26;
       {E The desired record was not found.}

?? FMT (FORMAT := ON) ??
*DECK DECK=DSE$DFT_ERRORS EXPAND=FALSE
*copyc dsc$condition_limits

?? FMT (FORMAT := OFF) ??

{ dft errors }

  CONST
     {90 - 119}
    dse$dft_request_failed = dsc$min_ecc + 91,
       {E DFT request was rejected}

    dse$dft_not_responding = dsc$min_ecc + 92,
       {E DFT is not responding}

    dse$dft_returned_unknown_status = dsc$min_ecc + 94,
       {E DFT returned unknown status, +P, to the operating system.}

    dse$dft_invalid_cda_read = dsc$min_ecc + 95,
       {E The CDA sector requested contains invalid data.}

    dse$dft_retry_request = dsc$min_ecc + 96,
       {E The dft request failed but may be retried.}

    dse$cda_too_large = dsc$min_ecc + 102,
       {E The CDA sector is too large for the buffer provided.}

    dse$no_cda_data = dsc$min_ecc + 103,
       {E The CDA sector does not contain any data.}

    dse$dft_dual_i4_not_supported = dsc$min_ecc + 104,
       {E DFT buffer structure at incorrect version for dual IOU support.}

    dse$dft_error_from_2ap = dsc$min_ecc + 105,
       {E +P1}

    dse$dft_not_allowed_on_cy2000 = dsc$min_ecc + 106,
       {E DFT request not allowed on a Cyber 2000 Mainframe.}

    dse$dft_only_allowed_on_cy2000 = dsc$min_ecc + 107,
       {E DFT request is only allowed on a Cyber 2000 Mainframe.}

    dse$dft_hw_element_not_found = dsc$min_ecc + 108,
       {E DFT request failed, hardware element not found.}

    dse$dft_hw_element_reserved = dsc$min_ecc + 109,
       {E DFT request failed, hardware element reserved.}

    dse$dft_hw_element_not_power_up = dsc$min_ecc + 110,
       {E DFT request failed, hardware element not powered up.}

    dse$dft_insuff_request_length = dsc$min_ecc + 111,
       {E DFT request failed, request length insufficient for response.}

    dse$dft_state_already_exists = dsc$min_ecc + 112,
       {W MRT state of hardware element already equals the requested state.}

    dse$dft_state_not_changed = dsc$min_ecc + 113,
       {E The element state change of +P1 to +P2 is not allowed.}

    dse$dft_state_part_changed = dsc$min_ecc + 114,
       {W Element state change made, however final state, +P1, is not exactly the requested state of +P2 .}

    dse$dft_undefined_mrt_state = dsc$min_ecc + 115,
       {E Service Processor found an undefined element state in the MRT.}

    dse$dft_undefined_req_state = dsc$min_ecc + 116,
       {E NOS/VE issued an undefined element state for the requested element state change.}

    dse$dft_sp_error = dsc$min_ecc + 117,
       {E The DFT request failed with the following error status from the service processor: +P1 .}

    dse$dft_reissue_request = dsc$min_ecc + 118;
       {E Reissue the current DFT request, the original request was not able to be processed.}

?? FMT (FORMAT := ON) ??
*DECK DECK=DSE$ERROR_CODES EXPAND=FALSE
*copyc dsc$condition_limits

?? FMT (FORMAT := OFF) ??

{ Deadstart Errors }

     {0 - 9}
*copyc dse$deadstart_multipro_errors

     {11 - 19}
*copyc dse$misc_ds_errors_part_a

     {20 - 39}
*copyc dse$deadstart_utility_errors

     {040 - 089}
*copyc dse$recovery_services_errors

     {090 - 119}
*copyc dse$dft_errors

     {120 - 129}
*copyc dse$pp_library_errors

     {130 - 159}
*copyc dse$resource_errors

     {160 - 179}
*copyc dse$nos_fap_errors

     {180 - 199}
     {unused}

     {200 - 219}
*copyc dse$estdbs_errors

     {220 - 229}
*copyc dse$deadstart_io_errors

     {230 - 239}
*copyc dse$interval_password_errors

?? FMT (FORMAT := ON) ??
*DECK DECK=DSE$ESTDBS_ERRORS EXPAND=FALSE

*copyc dsc$condition_limits

?? FMT (FORMAT := OFF) ??

{ Establish Disk Based System Errors: 'DS' 200 - 219 }

  CONST
    dse$estdbs_not_finished = dsc$min_ecc + 200,
       {E Cannot use COMNS command until ESTDBS is finished.}

    dse$no_deadstart_file_to_commit = dsc$min_ecc + 201,
       {W No deadstart file was found to commit.}

    dse$must_specify_catalog_or_vsn = dsc$min_ecc + 202,
       {E Must specify either a deadstart catalog or an external/recorded vsn.}

    dse$cannot_use_both_catalog_vsn = dsc$min_ecc + 203,
       {E Cannot specify both a deadstart catalog and an external/recorded vsn.}

    dse$vsn_required = dsc$min_ecc + 204,
       {E Either an external or recorded vsn must be specified.}

    dse$not_deadstart_tape = dsc$min_ecc + 205,
       {E The assigned tape is not a valid deadstart tape.}

    dse$required_file_missing = dsc$min_ecc + 206,
       {E The required file, +P1, is missing.}

    dse$file_name_too_long = dsc$min_ecc + 207;
       {E The file name, +P1, must be less than 18 characters in length.}

?? FMT (FORMAT := ON) ??
*DECK DECK=DSE$INTERVAL_PASSWORD_ERRORS EXPAND=FALSE
*copyc dsc$condition_limits

?? FMT (FORMAT := OFF) ??

  { Interval/Password Errors

  CONST
     {230 - 239}

    dse$seven_character_password     = dsc$min_ecc + 230,
        {E The password must contain seven characters.}

    dse$alphanumeric_password        = dsc$min_ecc + 231,
        {E The password must contain only alphanumeric characters.}

    dse$invalid_password             = dsc$min_ecc + 232,
        {E The password entered is invalid.}

    dse$no_password_exists           = dsc$min_ecc + 233,
        {E This command can not be parsed until its associated password has been established.}

    dse$password_exists              = dsc$min_ecc + 234,
        {E The password has already been established, use the change password command instead.}

    dse$command_not_allowed          = dsc$min_ecc + 235,
        {E This command is not allowed on this mainframe.}

    dse$invalid_interval_entered     = dsc$min_ecc + 236,
        {E The date entered must be in the future.}

    dse$window_lock_not_allowed      = dsc$min_ecc + 237;
        {E The locking of the main window is not allowed on this mainframe.}

?? FMT (FORMAT := ON) ??
*DECK DECK=DSE$MISC_DS_ERRORS_PART_A EXPAND=FALSE
*copyc dsc$condition_limits

?? FMT (FORMAT := OFF) ??

{ Miscellaneous Deadstart Errors }

  CONST
     {11 - 19}
    dse$not_executing_in_sys_job    = dsc$min_ecc + 11,
       {E Must be executing within the system job}
    dse$sysl_not_in_ssr             = dsc$min_ecc + 12,
       {F SYSL entry is not in the SSR}
    dse$system_level_mismatch       = dsc$min_ecc + 13,
       {F System core and VCB system level numbers do not match}
    dse$read_invalid_time_zone      = dsc$min_ecc + 14,
       {E Unable to obtain valid time zone data from VCU in the common disk area.}
    dse$write_invalid_time_zone     = dsc$min_ecc + 15,
       {E Unable to store invalid time zone data in VCU in the common disk area.}
    dse$mf_element_id_not_found     = dsc$min_ecc + 16;
       {E The desired entry was not found in the Mainframe Element Table.}

?? FMT (FORMAT := ON) ??
*DECK DECK=DSE$NOS_FAP_ERRORS EXPAND=FALSE

*copyc dsc$condition_limits

?? FMT (FORMAT := OFF) ??

{ NOS FAP Errors: 'DS' 160 - 179 }

  CONST
    dse$command_not_supported       = dsc$min_ecc + 160,
       {E NOS FAP does not support the command used.}
    dse$tape_damaged                = dsc$min_ecc + 161,
       {E Trailer portion on tape is damaged -- Bad tape.}
    dse$write_at_eor                = dsc$min_ecc + 162;
       {E Attempting to write at an End_of_record.}

?? FMT (FORMAT := ON) ??
*DECK DECK=DSE$PP_LIBRARY_ERRORS EXPAND=FALSE

*copyc dsc$condition_limits

?? FMT (FORMAT := OFF) ??

{ PP Library Errors: 'DS' 120 - 129 }

  CONST
    dse$driver_not_found            = dsc$min_ecc + 120,
       {E The driver, +P1, was not found in the PP library.}
    dse$buffer_too_small            = dsc$min_ecc + 121,
       {E The PP image is too large for the buffer provided.}
    dse$driver_damaged              = dsc$min_ecc + 122;
       {E The driver was found but is damaged on the PP library.}

?? FMT (FORMAT := ON) ??
*DECK DECK=DSE$RECOVERY_SERVICES_ERRORS EXPAND=FALSE

*copyc dsc$condition_limits

?? FMT (FORMAT := OFF) ??

{ Recovery Services errors: 'DS' 40 - 89 }

  CONST
    dse$unable_to_find_hdwrregs = dsc$min_ecc + 40,
       {E Unable to find hardware register values in image file.}

    dse$asid_invalid = dsc$min_ecc + 41,
       {E ASID invalid.}

    dse$image_file_too_large = dsc$min_ecc + 42,
       {E Image file used is too large for memory.}

    dse$resume_not_allowed = dsc$min_ecc + 43,
       {E Resume_system not allowed after upgrade of deadstart file.}

    dse$cant_upgrade_to_new_dsfile = dsc$min_ecc + 44,
       {E Unable to upgrade to new dsfile on system disk.}

    dse$cant_attach_label_sysdev = dsc$min_ecc + 45,
       {E Bad status trying to attach device label on system dev.}

    dse$cm_table_not_configured = dsc$min_ecc + 46;
       {E A CM table is not configured.}

?? FMT (FORMAT := ON) ??
*DECK DECK=DSE$RESOURCE_ERRORS EXPAND=FALSE
*copyc dsc$condition_limits

?? FMT (FORMAT := OFF) ??

{ request resource errors:  'DS' 130 - 159}

  CONST
    dse$cannot_return_resource = dsc$min_ecc + 130,
       {E +P1 }

    dse$pp_not_assigned_to_ve = dsc$min_ecc + 131,
       {E +P1 }
    dse$pp_not_available_to_ve = dsc$min_ecc + 132,
       {E +P1 }

    dse$ch_assigned_to_ve = dsc$min_ecc + 133,
       {E +P1 }
    dse$ch_not_available_to_ve = dsc$min_ecc + 134,
       {E +P1 }

    dse$eq_not_available_to_ve = dsc$min_ecc + 135,
       {E +P1 }

    dse$resource_not_available = dsc$min_ecc + 136,
       {E +P1 }
    dse$resource_does_not_exist = dsc$min_ecc + 137,
       {E +P1 }
    dse$resource_already_assigned = dsc$min_ecc + 138,
       {E +P1 }
    dse$dont_load_controlware = dsc$min_ecc + 139,
       {E +P1 }
    dse$cio_channel_not_present = dsc$min_ecc + 140,
       {E +P1 }
    dse$cio_pp_not_present = dsc$min_ecc + 141,
       {E +P1 }
    dse$illegal_request = dsc$min_ecc + 142,
       {E +P1 }

    dse$controlware_not_found = dsc$min_ecc + 143,
       {E The requested controlware is not on CIP.}

    dse$nil_caller_ptr = dsc$min_ecc + 144,
       {E The caller sent a NIL pointer for the PP data.}
    dse$cant_store_pp_in_ssr = dsc$min_ecc + 145,
       {E The caller is not allowed to use the SSR to store their PP.}

    dse$invalid_number = dsc$min_ecc + 146,
       {E +P1 }
    dse$invalid_request_options = dsc$min_ecc + 147,
       {E Invalid resource request options selected.}
    {148 unused.


    dse$resume_address_too_small = dsc$min_ecc + 149,
       {E The resume address given is too small for PP.}
    dse$resume_address_too_large = dsc$min_ecc + 150;
       {E The resume address given is too large for PP.}

?? FMT (FORMAT := ON) ??
*DECK DECK=DSI$930_DUMP_LOAD_IDLE_PP EXPAND=FALSE
          EJECT
*         CTEXT  DSI$930 DUMP LOAD IDLE PP
 DSIDLI   SPACE  4,10
***              THIS COMMON DECK CONTAINS THE S0/S0E-SPECIFIC VARIANTS OF
*         THE ROUTINES CONTAINED IN COMMON DECK *DSI$DUMP_LOAD_IDLE_PP*.
*         THE S0/S0E ARE SO DIFFERENT FROM OTHER IOU-S THAT HAVING SEPARATE
*         ROUTINES MAKES MORE SENSE THAN THE AMOUNT OF SPECIAL CASING
*         THAT WOULD OTHERWISE BE REQUIRED.
 DDP      SPACE  4,10
***       DDP - DEADSTART DUMP PP.
*
*         ENTRY  (A) = PP TYPE AND NUMBER.
*                (T1) = CHANNEL NUMBER ON DEADSTART PP ON.
*
*         EXIT   PP DOING BLOCK OUTPUT ON CHANNEL (T1).
*
*         USES   EC, RN, T1.


 DDP      SUBR               ENTRY/EXIT
          RJM    PPR
          LDD    T1
          STM    IDPA        SET CHANNEL NUMBER
          LDM    IDPA+5
          LPN    37
          LMC    140         SET *DUMP*/*IDLE*
          STM    IDPA+5
          RJM    PDC         PREPARE DEADSTART CHANNEL
          WRITMR IDPA        DEADSTART LOAD IOU
          UJN    DDPX        RETURN
 DLP      SPACE  4,10
***       DLP - DEADSTART LOAD PP.
*
*         ENTRY  (A) = PP TYPE AND NUMBER.
*                (T1) = CHANNEL NUMBER TO DEADSTART PP TO.
*
*         EXIT   PP DOING BLOCK INPUT ON CHANNEL (T1).
*
*         USES   EC, RN, T1.


 DLP      SUBR               ENTRY/EXIT
          RJM    PPR
          LDD    T1          SET CHANNEL NUMBER
          STM    IDPA
          LDM    IDPA+5
          LPN    37
          LMC    200         SET *LOAD*
          STM    IDPA+5
          RJM    PDC         PREPARE DEADSTART CHANNEL
          WRITMR IDPA        DEADSTART LOAD IOU
          UJN    DLPX        RETURN
 IDP      SPACE  4,10
**        IDP - IDLE PP.
*
*         ENTRY  (A) = PP TYPE AND NUMBER TO IDLE.
*
*         EXIT   PP IDLED.
*
*         USES   EC, RN.


 IDP      SUBR               ENTRY/EXIT
          RJM    PPR         PRESET PP
          LDN    16
          STM    IDPA        SET TO CHANNEL 16
          LDM    IDPA+5
          LPN    37
          LMN    40          SET *IDLE*
          STM    IDPA+5
          WRITMR IDPA        WRITE IOU REGISTER TO IDLE PP
          RJM    WFI         WAIT FOR IDLE
          NJN    IDP2        IF IDLE DID NOT OCCUR
 IDP1     UJN    IDPX        RETURN

*         AT THIS POINT THE PP DID NOT IDLE FROM JUST AN IDLE.
*         RETRY DOING A DUMP IDLE IN CASE THE PP IS HUNG.

 IDP2     LDM    IDPA+5
          LPN    37
          LMC    140         SET *DUMP*/*IDLE*
          STM    IDPA+5
          WRITMR IDPA
          RJM    WFI         WAIT FOR IDLE
          UJN    IDP1        RETURN

 IDPA     BSS    10
 PDC      SPACE  4,10
**        PDC - PREPARE DEADSTART CHANNEL.
*
*         ENTRY  (T1) = CHANNEL NUMBER TO DEADSTART PP ON.
*
*         EXIT   CHANNEL ACTIVE AND EMPTY.


 PDC      SUBR               ENTRY/EXIT
          LDC    DCNI+40
          ADD    T1
          STM    PCHA
          LMC    ACNI&DCNI
          STM    PCHB
 PCHA     DCN    CH+40       DEACTIVATE POSSIBLE ACTIVE CHANNEL
 PCH1     SBN    1
          PJN    PCH1        WAIT A BIT
 PCHB     ACN    CH+40       ACTIVATE EMPTY CHANNEL
          UJN    PDCX        RETURN
 PPR      SPACE  4,10
**        PPR - PRESET PP ROUTINES.
*
*         SETS *EC* AND STATUS REGISTER NUMBERS ACCORDINGLY.
*
*         ENTRY  (A) = PP TYPE AND NUMBER.
*
*         EXIT   (A) IS RESTORED TO ENTRY VALUE.


 PPR      SUBR               ENTRY/EXIT
          STML   PPTN        SAVE PP TYPE AND NUMBER
          LPN    37          ISOLATE PP NUMBER
          ADN    S0IEC       SET *EC* REGISTER NUMBER
          STM    PPRE
          ADN    S0IST-S0IEC SET STATUS-1 REGISTER NUMBER
          STM    PPRS
          LDML   I0CC        SET CONNECT CODE
          STDL   EC
          LDM    PPRE        SET REGISTER NUMBER
          STD    RN
          READMR IDPA
          LDML   PPTN        RESTORE PP TYPE AND NUMBER
          UJN    PPRX        RETURN

 PPRE     CON    0           *EC* REGISTER NUMBER
 PPRS     CON    0           STATUS-1 REGISTER NUMBER
 WFI      SPACE  4,10
**        WFI - WAIT FOR IDLE.
*
*         ENTRY  (IDPA - IDPA+7) = CURRENT *EC* REGISTER.
*
*         EXIT   (A) = 0 IF PP IS IDLED.
*
*         USES   RN, T1.


 WFI      SUBR               ENTRY/EXIT
          LDC    500D
          STDL   T1
          LDM    PPRS        SET STATUS-1 REGISTER NUMBER
          STD    RN
 WFI1     READMR WFIA        READ PP STATUS 1 REGISTER
          LDM    WFIA+2
          LPC    177
          LMC    177
          ZJN    WFI2        IF IDLED
          SODL   T1
          NJN    WFI1        IF NOT TIMED OUT
          LDN    77
 WFI2     UJN    WFIX        RETURN

 WFIA     BSSZ   10

*         END    DSI$930 DUMP LOAD IDLE PP
*DECK DECK=DSI$C170_ACCESS_TO_SSR EXPAND=FALSE
?? NEWTITLE := '~~~~~   common deck DSI$C170_ACCESS_TO_SSR', EJECT ??

{  SSR access routines, deck DSI$C170_ACCESS_TO_SSR.

*copyc dsc$ssr_entry_constants

  PROCEDURE get_ssr_data
    (    ssr_offset: integer;
         buffer: ^cell;
         length: integer);

    VAR
      ssr_copy_info: memory_copy_header;

    ssr_copy_info.length := length;
    ssr_copy_info.copy_method := ve64_to_nos32;
    ssr_copy_info.pva_type := start_of_ssr;
    ssr_copy_info.byte_rma := ssr_offset;
    copy_memory (ssr_copy_info, buffer);

  PROCEND get_ssr_data;
?? SKIP := 3 ??

  PROCEDURE store_ssr_data
    (    ssr_offset: integer;
         buffer: ^cell;
         length: integer);

    VAR
      ssr_copy_info: memory_copy_header;

    ssr_copy_info.length := length;
    ssr_copy_info.copy_method := nos32_to_ve64;
    ssr_copy_info.pva_type := start_of_ssr;
    ssr_copy_info.byte_rma := ssr_offset;
    copy_memory (ssr_copy_info, buffer);

  PROCEND store_ssr_data;
?? SKIP := 3 ??

  PROCEDURE [XDCL] find_ssr_entry ALIAS 'dspfind'
    (    name: string (4);
     VAR ssr_offset: integer);

    VAR
      i: integer,
      ssr_length: [STATIC] integer := 0,
      ascii_name: 0 .. 0ffffffff(16),
      directory: ^ARRAY [1 .. * ] OF integer;

    IF ssr_length = 0 THEN
      get_ssr_data (4, ^i, 1);
      ssr_length := i DIV left_slot * 2;
      IF (ssr_length = 0) OR (ssr_length > 100) THEN
        error_processor (invalid_ssr, fatal_error);
      IFEND;
      IF (ssr_length = 0) OR (ssr_length > 100) THEN
        error_processor (invalid_ssr, fatal_error);
      IFEND;
    IFEND;

    PUSH directory: [1 .. ssr_length];
    get_ssr_data (0, directory, ssr_length);

    ascii_name := $INTEGER (name (1)) * 1000000(16) + $INTEGER (name (2)) *
          10000(16) + $INTEGER (name (3)) * 100(16) + $INTEGER (name (4));

    i := 1;
    WHILE directory^ [i] <> ascii_name DO
      i := i + 2;
      IF i > ssr_length THEN
        error_processor (incorrect_ssr_set_operation, fatal_error);
      IFEND;
    WHILEND;
    ssr_offset := (i - 1) * 4;

  PROCEND find_ssr_entry;
?? SKIP := 3 ??

  PROCEDURE [XDCL] set_ssr_directory_entry ALIAS 'dspsets'
    (    ssr_offset: integer;
         new_left: 0 .. 0ffff(16);
         new_right: 0 .. 0ffff(16));

    VAR
      half_word: 0 .. 0ffffffff(16);

    half_word := new_left * left_slot + new_right;
    store_ssr_data (ssr_offset + 4, ^half_word, 1);

  PROCEND set_ssr_directory_entry;
?? SKIP := 3 ??

  PROCEDURE [XDCL] get_ssr_directory_entry ALIAS 'dspgets'
    (    ssr_offset: integer;
     VAR old_left: integer;
     VAR old_right: integer);

    VAR
      half_word: 0 .. 0ffffffff(16);

    get_ssr_data (ssr_offset + 4, ^half_word, 1);
    old_left := half_word DIV left_slot;
    old_right := half_word MOD left_slot;

  PROCEND get_ssr_directory_entry;
?? OLDTITLE ??
*DECK DECK=DSI$DEADSTART_COMMAND_PROCESSOR EXPAND=FALSE
?? NEWTITLE := '~~~~~   common deck DSI$DEADSTART_COMMAND_PROCESSOR', EJECT ??

  TYPE
    dsc_commands = (run, dump, panel, scd, tnvejob, dsoption,
          timelimit, vsn, density, endlst);

  CONST
*IF ($string($name(wev$target_operating_system))='NOS')
    bpi_1600 = 4,  { 1600 BPI (PE) for NOS tape request.
    bpi_6250 = 5;  { 6250 BPI (GE) for NOS tape request.
*ELSE
    bpi_1600 = 3,  { 1600 BPI (PE) for NOS/BE tape request.
    bpi_6250 = 1;  { 6250 BPI (GE) for NOS/BE tape request.
*IFEND

{  The following two variables are referenced by assembly language labelled tape
{  routines.  Each variable must be one 60 bit word.

  VAR
    dsv$dump_tape_density ALIAS 'dsv#den': [XDCL] integer := bpi_6250,
    dsv$dump_tape_vsn ALIAS 'dsv#vsn': [XDCL] ARRAY [1 .. 1] OF PACKED ARRAY [0 .. 9]
          OF 0 .. 3f(16) := [[04, 15(8), 20(8), 33(8), 33(8), 01, 55(8), 55(8), 55(8), 55(8)]],
    dsv$ssr_operator_intervention: 0 .. 1;

  VAR
    command: dsc_commands,
    critical_dump_allowed: boolean,
    memory_to_be_dumped: string (8),
    run_mode: boolean := TRUE,
    take_dump: boolean := TRUE,
    terminate_nve_job: boolean := FALSE,
    timeout_limit: integer := 1800; { 1800 seconds

?? EJECT ??

{  PURPOSE:
{    Get the next command from the input buffer.

  PROCEDURE do_command
    (inhibit_tape_commands: boolean;
     VAR command_error_flag: boolean);

    CONST
      cmrdck_specifier = 0fffff(16),
      display_specifier = 0ffff0(16);

    VAR
      command_list: [STATIC] ARRAY [dsc_commands] OF string (10) := ['*RUN',
        '*DUMP', '*PANEL', '*SCD', '*TNVEJOB', '*DSOPTION', '*TIMEOUT',
        '*VSN', '*DENSITY', '*ENDLST'];

    VAR
      d8st: PACKED RECORD
        fill_1: 0 .. 777777777777(8),
        scd_port: 0 .. 77(8),
        scd_pp: 0 .. 77(8),
        fill_2: 0 .. 7777(8),
      RECEND;

    VAR
      change_memory_error: boolean,
      dc_vsn_char_index: 0 .. 9,
      dc_vsn_word_index: integer,
      dump_tape_vsn: ARRAY [1 .. 1] OF PACKED ARRAY [0 .. 9] OF 0 .. 3f(16),
      eol: boolean,
      i: integer,
      next_param: param_type, {next command parameter
      panel_word_number,
      panel_word_value: integer,
      param_value: c180_word, {next parameter value
      param_is_false: boolean,
      param_is_true: boolean,
      save_text_line: string (line_width),
      source_index: ost$string_index,
      trial_command: dsc_commands;

    command_error_flag := FALSE;
    IF text_line (1) = ' ' THEN
      RETURN;
    IFEND;
    command_error_flag := TRUE;
    show_message (text_line, operator_echo_line, no_scroll);

  /process_command/
    BEGIN

    /search_period/
      FOR i := 1 TO line_width DO
        IF text_line (i) = '.' THEN
          EXIT /search_period/;
        IFEND;
      FOREND /search_period/;
      IF text_line (i) <> '.' THEN
        EXIT /process_command/;
      IFEND;

      extract_param (next_param, 0);

    /find_command/
      FOR trial_command := run TO endlst DO
        IF next_param = command_list [trial_command] THEN
          text_line (1) := ' ';
          EXIT /find_command/;
        IFEND;
      FOREND /find_command/;
      IF next_param <> command_list [trial_command] THEN
        EXIT /process_command/;
      IFEND;

{  Decode and process commands.

      extract_param (next_param, 1);
      IF (next_param = 'CRITICAL') AND (NOT critical_dump_allowed) THEN
        EXIT /process_command/;
      IFEND;
      param_is_true := (next_param = 'ON') OR (next_param = 'TRUE') OR
            (next_param = 'YES') OR (next_param = 'ALL') OR
            (next_param = 'CRITICAL') OR (next_param = 'NONE');
      param_is_false := (next_param = 'OFF') OR (next_param = 'FALSE') OR
            (next_param = 'NO');

      CASE trial_command OF

      = dsoption =

      = panel =
        make_number (next_param, param_value, error_flag, oct);
        IF error_flag = TRUE OR (param_value.left <> 0) THEN
          EXIT /process_command/;
        IFEND;
        panel_word_number := param_value.right;
        extract_param (next_param, 2);
        make_number (next_param, param_value, error_flag, oct);
        IF error_flag = TRUE OR (param_value.left <> 0) THEN
          EXIT /process_command/;
        IFEND;
        panel_word_value := param_value.right;
        IF panel_word_number = cmrdck_specifier THEN

          { Ignore the dcfile number, NOS/VE now retrieves the value from
          { the boot screens.

        ELSEIF panel_word_number = display_specifier THEN

          { Save the operator intervention bit to be saved in the SSR
          { during the update of the SSR.

          IF (panel_word_value < 0) OR (panel_word_value > 1) THEN
            EXIT /process_command/;
          IFEND;
          dsv$ssr_operator_intervention := panel_word_value;
        IFEND;

      = scd =
        make_number (next_param, param_value, error_flag, dec);
        IF error_flag OR (param_value.right > 1) OR (param_value.left <> 0)
              THEN
          EXIT /process_command/;
        IFEND;

{  Store the SCD port number in word D8ST of the EICB.

        get_dscb (dscb_d8st, ^d8st, 1);
        d8st.scd_port := param_value.right;
        put_dscb (dscb_d8st, ^d8st, 1);

{  System operation control commands.

      = dump =
        IF inhibit_tape_commands THEN
          command_error_flag := TRUE;
          EXIT /process_command/;
        ELSE
          IF param_is_false THEN
            take_dump := FALSE;
          ELSEIF param_is_true THEN
            take_dump := TRUE;
            memory_to_be_dumped := next_param;
          ELSE
            EXIT /process_command/;
          IFEND;
        IFEND;

      = run =
        run_mode := TRUE;

      = tnvejob =
        IF param_is_false THEN
          terminate_nve_job := FALSE;
        ELSEIF param_is_true THEN
          terminate_nve_job := TRUE;
        ELSE
          EXIT /process_command/;
        IFEND;

      = timelimit =
        make_number (next_param, param_value, error_flag, dec);
        timeout_limit := param_value.right;

      = density =
        IF inhibit_tape_commands THEN
          command_error_flag := TRUE;
          EXIT /process_command/;
        ELSE

{  Save density in global variables for assembly language labelled tape routines.

          IF next_param = 'PE' THEN
            dsv$dump_tape_density := bpi_1600;
          ELSEIF next_param = 'GE' THEN
            dsv$dump_tape_density := bpi_6250;
          ELSE
            EXIT /process_command/;
          IFEND;
        IFEND;

      = vsn =
        IF inhibit_tape_commands THEN
          command_error_flag := TRUE;
          EXIT /process_command/;
        ELSE

{  Convert ascii string to display code string and save in global variable for
{  assembly language labelled tape routines.

          dc_vsn_word_index := LOWERBOUND(dump_tape_vsn);
          dc_vsn_char_index := 0;
          source_index := 1;
          eol := FALSE;

{  Convert the vsn to display code.  The vsn is a maximum of 6 characters but next_param is
{  is longer than that so the display code string will be blank filled.

          utp$convert_string_to_dc_string (utc$ascii64, dump_tape_vsn, dc_vsn_word_index,
                 dc_vsn_char_index, next_param, source_index, eol);

        /check_vsn_length/
          FOR dc_vsn_char_index := 9 DOWNTO 0 DO
            IF dump_tape_vsn [LOWERBOUND(dump_tape_vsn)][dc_vsn_char_index] <> 55(8) THEN
              IF dc_vsn_char_index > 5 THEN
                EXIT /process_command/
              ELSE
                EXIT /check_vsn_length/;
              IFEND;
            ELSE
              IF dc_vsn_char_index = 0 THEN

{  Do not allow vsn of all blanks.

                EXIT /process_command/
              IFEND;
            IFEND;
          FOREND /check_vsn_length/;

          dsv$dump_tape_vsn := dump_tape_vsn;
        IFEND;

      = endlst =
        {do nothing
      ELSE
        EXIT /process_command/;
      CASEND;
      command_error_flag := FALSE;
      show_message (' ', message_line, no_scroll);
    END /process_command/;
    IF command_error_flag THEN
      save_text_line := text_line;
      text_line (1, 7) := '*ERROR ';
      text_line (8, * ) := save_text_line;
      show_message ('INPUT ERROR, IGNORED', message_line, no_scroll);
    IFEND;
    command := trial_command;
    show_message (text_line, line_position, auto);

  PROCEND do_command;
?? EJECT ??

{ PURPOSE:
{   Wait for the operator to perform an action.

  PROCEDURE wait_for_operator_action
    (inhibit_tape_commands: boolean;
     VAR error: boolean);

    VAR
      clock_value: integer,
      timeout_threshold: integer;

    gettime (clock_value);
    timeout_threshold := timeout_limit + clock_value;

    REPEAT
      convert_k_display;
      IF text_line (1) = ' ' THEN
        gettime (clock_value);
        IF clock_value > timeout_threshold THEN
          dyfstring ('operator timeout', system_dayf);
          run_mode := TRUE;
          do_command (inhibit_tape_commands, error);
        ELSE
          wakeup;
        IFEND;
      ELSE
        do_command (inhibit_tape_commands, error);
      IFEND;
    UNTIL run_mode;

  PROCEND wait_for_operator_action;
?? EJECT ??

{ PURPOSE:
{   Convert the k display from display code to ascii.

*copyc zutpd2s


  PROCEDURE convert_k_display;

    TYPE
      k_input_copy = ARRAY [1 .. 7] OF integer;


    VAR
      kinpb: [XREF] kdispb_line,
      k_input_buffer: ^k_input_copy,
      dcwi: integer,
      dcci: 0 .. 9,
      sl: ost$string_length,
      eol: boolean,
      i,
      j: integer;

    text_line := ' ';
    k_input_buffer := #LOC (kinpb);

    IF k_input_buffer^ [1] <> 0 THEN
      dcwi := 1;
      dcci := 0;
      eol := FALSE;
      utp$convert_dc_string_to_string (utc$ascii64, kinpb, dcwi, dcci,
            text_line, sl, eol);
      text_line := text_line (1, sl);
      FOR i := 1 TO 7 DO
        k_input_buffer^ [i] := 0;
      FOREND;
    IFEND;

  PROCEND convert_k_display;
?? EJECT ??

{ PURPOSE:
{  Get the next command from the current command file.

  VAR
    file_mark_position: file_mark,
    text_line: [STATIC] string (line_width);


  PROCEDURE get_next_command
    (VAR file_name: ^cell,
         char_no: integer);

    VAR
      line_end: boolean,
      lost_text: string (8),
      lost_char_cnt: integer,
      local_line: string (line_width);

{  Read next line from command file.

    lg#getpart (file_name, line_end, char_no, local_line);
    WHILE (line_end = FALSE) DO
      f#mark (file_name, file_mark_position);
      IF (file_mark_position = data#) THEN
        lg#getpart (file_name, line_end, lost_char_cnt, lost_text);
      IFEND;
    WHILEND;
    IF char_no = 0 THEN
      RETURN;
    IFEND;

{  Display command.

    text_line := local_line (1, char_no);

  PROCEND get_next_command;
?? EJECT ??

  PROCEDURE read_deadstart_command_file
    (inhibit_tape_commands: boolean);

    VAR
      command_length: integer,
      error_in_command,
      error: boolean;

    error_in_command := FALSE;

  /get_ds_commands/
    WHILE active_cmnds_file DO
      get_next_command (command_file, command_length);
      do_command (inhibit_tape_commands, error);
      IF error THEN
        error_in_command := TRUE;
      IFEND;
      IF (command = endlst) OR (command_length = 0) THEN
        EXIT /get_ds_commands/;
      IFEND;
    WHILEND /get_ds_commands/;
    IF error_in_command OR (sw2 IN jcr.sense_switches) THEN
      display;
      run_mode := FALSE;
      REPEAT
        convert_k_display;
        do_command (inhibit_tape_commands, error);
        wakeup;
      UNTIL run_mode;
    IFEND;

  PROCEND read_deadstart_command_file;
?? OLDTITLE ??
*DECK DECK=DSI$DEADSTART_UTILITIES EXPAND=FALSE
?? NEWTITLE := '~~~~~   common deck DSI$DEADSTART_UTILITIES', EJECT ??

  TYPE
    error_codes = (
{} no_pp_available,
{} directory_too_small_for_pp_lib,
{} pp_too_large,
{} deadstrt_level_used_was_unknown,
{} nosve_down,
{} attempted_to_ds_a_running_nosve,
{} pp_illegally_assigned_to_nve,
{} unknown_deadstrt_tape_header_id,
{} nosve_boot_progs_not_installed,
{} insufficient_memory_load_core,
{} error_dumping_nos_ve,
{} chosen_memory_less_then_nve_min,
{} unable_to_obtain_request_memory,
{} error_in_linking_data_to_nosve,
{} ssr_image_not_found,
{} incorrect_ssr_set_operation,
{} ssr_element_was_too_large,
{} incorrect_nve_request,
{} cant_request_tape_pos_recovery,
{} request_tape_position_unknown,
{} controlware_buffer_too_small,
{} invalid_ssr,
{} fatal_170_error,
{} ok,
{} ve_not_enabled_in_cmrdeck),
    error_types = (fatal_error, checkpoint_error, warning);

?? SKIP := 3 ??

  VAR
    r1g_error_flag: 0 .. 77(8),
    ds_error_messages: [STATIC] array [error_codes] of string (40) := [
{} 'NO PP AVAILABLE.                        ',
{} 'DIRECTORY TOO SMALL FOR PP LIBRARY.     ',
{} 'PP TOO LARGE.                           ',
{} 'DEADSTART LEVEL USED WAS UNKNOWN.       ',
{} 'NOS/VE DOWN.                            ',
{} 'ATTEMPTED TO DEADSTART A RUNNING NOSVE. ',
{} 'PP ILLEGALLY ASSIGNED TO NVE.           ',
{} 'UNKNOWN DEADSTART TAPE HEADER ID.       ',
{} 'NOS/VE BOOT PROGRAMS NOT INSTALLED.     ',
{} 'INSUFFICIENT MEMORY TO LOAD SYSTEM CORE.',
{} 'ERROR DUMPING NOS/VE, TRY AGAIN.        ',
{} 'CHOSEN MEMORY WAS LESS THEN NVE MINIMUM.',
{} 'UNABLE TO OBTAIN REQUESTED MEMORY.      ',
{} 'ERROR OCCURRED IN LINKING DATA TO NOSVE.',
{} 'SSR IMAGE NOT FOUND.                    ',
{} 'INCORRECT SSR SET OPERATION.            ',
{} 'SSR ELEMENT WAS TOO LARGE.              ',
{} 'INCORRECT NVE REQUEST.                  ',
{} 'CANNOT REQUEST TAPE POSITION IN RECOVERY',
{} 'REQUEST FOR TAPE POSITION WAS UNKNOWN.  ',
{} 'CONTROLWARE BUFFER IN SSR TOO SMALL.    ',
{} 'SSR IMAGE IS DAMAGED OR INVALID.        ',
{} 'FATAL 170 ERROR, SEE DAYFILE FOR DETAILS',
{} 'OK, NO ERROR.                           ',
{} 'VE NOT ENABLED IN CMRDECK.              '];

?? SKIP := 3 ??
{**********************************************************

{ PURPOSE:
{   Record the error in the dayfile and abort if fatal error.

  PROCEDURE error_processor
    (    error_code: error_codes;
         error_type: error_types);

{  Record error in dayfile.

    dyfstring (ds_error_messages [error_code], 0);

{  Terminate dsc job - step on fatal error.

    IF error_type <> warning THEN
      jcr.global_error_flag := 77(8); {deadstart error
      jcr.global_r1 := $INTEGER (error_code);
      jcrset;
      endprgr; {exit with error
    IFEND;

  PROCEND error_processor;
?? OLDTITLE ??
*DECK DECK=DSI$DEFINE_HARDWARE_CONFIG EXPAND=FALSE
?? NEWTITLE := '~~~~~   common deck DSI$DEFINE_HARDWARE_CONFIG', EJECT ??
{***************************************************************

{  Preset configuration record definitions, deck DSI$DEFINE_HARDWARE_CONFIG.

{  System hardware configuration record.

*copyc dst$cc_cti_hardware_block

{  Define hardware configuration based on CEVAL interface.

  VAR
    console: dst$cc_display_console_info,
    configuration_record: ARRAY [1 .. 10] OF dst$cc_cti_hardware_block;

  PROCEDURE set_configuration;

    VAR
      i: integer,
      cr: ^dst$cc_cti_hardware_block,
      mab: ARRAY [1 .. 100] OF dst$cc_generic_element,
      entry: 1 .. 100;

    pp_table.size := #SIZE (mab);
    pp_table.data_buffer := ^mab;
    callsda (fetch_hdt, pp_table);

    entry := 1;
    i := 1;

    WHILE mab [entry].size > 0 DO
      cr := #LOC (mab [entry]);
      CASE cr^.iou.id OF
      = $INTEGER (dsc$id_processor_info) =
        configuration_record [i].processor := cr^.processor;

      = $INTEGER (dsc$id_iou_info) =
        configuration_record [i].iou := cr^.iou;

      = $INTEGER (dsc$id_central_memory_info) =
        configuration_record [i].memory := cr^.memory;

      = $INTEGER (dsc$id_display_console_info) =
        configuration_record [i].console := cr^.console;
        console := cr^.console;

      = $INTEGER (dsc$id_mainframe_info) =
        configuration_record [i].mainframe := cr^.mainframe;

      ELSE

       { Unrecognized mab type, decrement configuration_record index so
       { that there are no holes in this array.  All of the entries that
       { deadstart cares about are contiguous.

        i := i - 1;
      CASEND;
      entry := entry + mab [entry].size;
      i := i + 1;
    WHILEND;

  PROCEND set_configuration;
?? OLDTITLE ??
*DECK DECK=DSI$DEFINE_LONG_INSTRUCTION EXPAND=FALSE
          CTEXT  DSI$DEFINE LONG INSTRUCTIONS                            R123_OS        1
          IF     -DEF,QUAL$,1                                            R123_OS        2
          QUAL   COMPDLI                                                 R123_OS        3
          SPACE  4,10                                                    R123_OS        4
          BASE   M                                                       R123_OS        5
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992               SCW_1080       1
 DLI      SPACE  4,10                                                    R123_OS        7
**        DLI - DEFINE LONG INSTRUCTION.                                 R123_OS        8
*                                                                        R123_OS        9
*         ENTRY  (A) = ADDRESS OF LONG INSTRUCTION TABLE.                R123_OS       10
*                                                                        R123_OS       11
*         EXIT   LONG INSTRUCTIONS DEFINED.                              R123_OS       12
                                                                         R123_OS       13
                                                                         R123_OS       14
 STILI    EQU    4400+1S15                                               R123_OS       15
                                                                         R123_OS       16
 DLI      SUBR               ENTRY/EXIT                                  R123_OS       17
          STD    T2                                                      R123_OS       18
          RJM    SMI         OBTAIN MAINTENANCE CHANNEL                  R123_OS       19
          DCN    MR+40                                                   R123_OS       20
          FNC    MRDC,MR     KILL DEADMAN TIMER                          R123_OS       21
          DCN    MR+40                                                   R123_OS       22
          LDC    STILI+T3                                                R123_OS       23
          ACN    MR                                                      R123_OS       24
          OAN    MR                                                      R123_OS       25
          LDN    1                                                       R123_OS       26
          IAM    DLIA,MR     READ *STIL* TO MEMORY                       R123_OS       27
          RJM    CMI         RETURN MAINTENANCE CHANNEL                  R123_OS       28
 DLI1     LDI    T2          ADDRESS OF 16 BIT INSTRUCTION               R123_OS       29
          ZJN    DLIX        IF FINISHED                                 R123_OS       30
          STD    T3                                                      R123_OS       31
          LDI    T3                                                      R123_OS       32
          LMC    1S15        CONVERT TO 16-BIT INSTRUCTION               R123_OS       33
 DLIA     STIL   T3                                                      R123_OS       34
          AOD    T2                                                      R123_OS       35
          UJN    DLI1        PROCESS NEXT INSTRUCTION                    R123_OS       36
          SPACE  4,10                                                    R123_OS       37
          BASE   *                                                       R123_OS       38
 QUAL$    IF     -DEF,QUAL$                                              R123_OS       39
          QUAL   *                                                       R123_OS       40
 DLI      EQU    /COMPDLI/DLI                                            R123_OS       41
 QUAL$    ENDIF                                                          R123_OS       42
          SPACE  4                                                       R123_OS       43
          ENDX                                                           R123_OS       44
*DECK DECK=DSI$DFT_TYPES_AND_CONSTANTS EXPAND=FALSE

{  Define types and constants for dedicated fault tolerance (DFT) buffer
{  that are used on the 170 side (cybil_cc).

  CONST
    dsc$db_fixed_length = 6 * 8,

{  Define length of mainframe element counters buffer, both NOS and NOS/BE
{  must use the same value.

    dsc$db_mainframe_element_l = 10 * 8;

  TYPE
    dst$dft_control_word = PACKED RECORD
      po: 0 .. 0f(16),
      seq_num: 0 .. 0ff(16),
      rl: 0 .. 0ff(16),
      pp: 0 .. 0ff(16),
      lbuf: 0 .. 0ff(16),
      nbuf: 0 .. 0ff(16),
      flags: 0 .. 0ffff(16),
    RECEND,

    r_register_format = PACKED RECORD
      offset: 0 .. 0fff(16),
      r_upper: 0 .. 0ffff(16),
      r_lower: 0 .. 0ffff(16),
      length: 0 .. 0ffff(16),
    RECEND;
*DECK DECK=DSI$DISPLAY_DAYFILE_MESSAGE EXPAND=FALSE
?? NEWTITLE := '~~~~~   common deck DSI$DISPLAY_DAYFILE_MESSAGE', EJECT ??
{************************************************************

{  Put message in dayfile, deck DSI$DISPLAY_DAYFILE_MESSAGE.

{************************************************************
?? PUSH (LISTEXT := ON) ??
*copyc zutps2d
*copyc zn7pmsg
?? POP ??

  CONST
    system_dayf = 0,
    bdisplay_line1 = 1,
    bdisplay_line2 = 2,
    user_dayf = 3,
    error_log = 4,
    account = 5,
    debug_log = 7;

?? SKIP := 3 ??

{ PURPOSE:
{   Write string into dayfile.

  PROCEDURE [XDCL] dyfstring
    (    s: string ( * );
         dayfile: 0 .. 7);

    VAR
      dcm: ARRAY [1 .. 8] OF PACKED ARRAY [0 .. 9] OF 0 .. 3f(16),
      dcwi: integer,
      dcci: 0 .. 9,
      log: integer,
      si: ost$string_index,
      eol: boolean;

    log := dayfile;
    IF sw1 IN jcr.sense_switches THEN
      log := user_dayf;
    IFEND;
    IF log <> debug_log THEN
      si := 1;
      dcwi := 1;
      dcci := 0;
      eol := TRUE;
      utp$convert_string_to_dc_string (utc$ascii64, dcm, dcwi, dcci, s, si,
            eol);
      n7p$issue_dayfile_message (#LOC (dcm), log);
    IFEND;

  PROCEND dyfstring;

{ PURPOSE:
{  Send message and number to dayfile.

  PROCEDURE [XDCL] dyfstrnum
    (    s: string ( * );
         value: integer;
         dayfile: 0 .. 7);

    VAR
      new_s: ^string ( * ),
      n,
      i: integer;

    i := STRLENGTH (s);
    PUSH new_s: [i + 10];
    new_s^ (1, i) := s (1, i);
    new_s^ (i + 1, 10) := '          ';
    STRINGREP (new_s^ (i + 1, 10), n, value);
    dyfstring (new_s^, dayfile);

  PROCEND dyfstrnum;
?? OLDTITLE ??
*DECK DECK=DSI$DUMP_LOAD_IDLE_PP EXPAND=FALSE
          CTEXT  DSI$DUMP LOAD IDLE PP                                   R123_OS        1
          SPACE  4,10                                                    R123_OS        2
          IF     -DEF,QUAL$,1                                            R123_OS        3
          QUAL   COMPIDP                                                 R123_OS        4
          BASE   M                                                       R123_OS        5
 IDP      SPACE  4,10                                                    R123_OS        6
***              DSI$DUMP LOAD IDLE CONTAINS THE ROUTINES                R123_OS        7
*         USED TO DUMP, LOAD, AND IDLE PPS VIA THE                       R123_OS        8
*         MAINTENANCE CHANNEL.                                           R123_OS        9
*                                                                        DOH_58         1
*         A ROUTINE, *MCH*, TO MASTER CLEAR A SPECIFIC CHANNEL           DOH_58         2
*         IS ALSO AVAILABLE IF THE SYMBOL *MCH$* IS DEFINED.             DOH_58         3
                                                                         DOH_58         4
                                                                         R123_OS       10
 PPNO     BSS    0           PP TYPE AND NUMBER PASSED AS PARAMETER.     R123_OS       11
          VFD    8/0         PP TYPE,                                    R123_OS       12
                               = 0 IMPLIES NONCONCURRENT.                R123_OS       13
                               = 1 IMPLIES CONCURRENT.                   R123_OS       14
          VFD    8/0         PP NUMBER.                                  R123_OS       15
 PPCH     CON    0           PP / CH INDICATOR (0=PP, 1=CH)              DOH_315        1
 PPR      SPACE  4,15                                                    DOH_315        2
**        PPR - PRESET PP ROUTINES.                                      R123_OS       17
*                                                                        R123_OS       18
*         DETERMINES IF NIO OR CIO PP TO BE LOADED AND SETS EC, AND      R123_OS       19
*         STATUS REGISTER NUMBERS ACCORDINGLY.                           R123_OS       20
*                                                                        R123_OS       21
*         ENTRY  (A) = PP NUMBER AND TYPE OF PP.                         R123_OS       22
*                                                                        R123_OS       23
*         USES                                                           R123_OS       26
*                *PPRE* TO HOLD REGISTER NUMBER FOR ENVIRONMENT CONTROL. R123_OS       27
*                *PPRS* TO HOLD REGISTER NUMBER FOR STATUS REGISTER.     R123_OS       28
*                                                                        R123_OS       29
*         CALLS  RII, SPM.                                               KAP_2011       1
                                                                         KAP_87         5
                                                                         R123_OS       30
 PPR      SUBR               ENTRY/EXIT                                  R123_OS       31
          STM    PPNO        SAVE PP TYPE AND NUMBER                     R123_OS       32
          SHN    21-10       GET TYPE                                    R123_OS       33
          PJN    PPR1        IF NIO PP                                   R123_OS       34
          LDM    IOUM                                                    GJF_8138       1
          LMC    0#42                                                    GJF_8140       1
          NJN    PPR0        IF NOT I4S IOU                              KAP_4035       1
          LDN    30B                                                     KAP_4035       2
          RAML   PPNO        BIAS BY 30(8) FOR CIO PP                    KAP_4035       3
          UJN    PPR1                                                    GJF_8138       7
                                                                         GJF_8138       8
 PPR0     LDN    ECIO                                                    GJF_8138       9
          STM    PPRE        SAVE REG NO FOR CIO ENV. CTRL               R123_OS       36
          LDC    SCIO                                                    R123_OS       37
          STM    PPRS        SAVE REG NO FOR CIO STATUS REG              R123_OS       38
          UJN    PPR2        CONTINUE                                    R123_OS       39
                                                                         R123_OS       40
 PPR1     LDN    ENIO                                                    R123_OS       41
          STM    PPRE        REG NO FOR NIO ENV CTRL                     R123_OS       42
          LDC    SNIO                                                    R123_OS       43
          STM    PPRS        REG NO FOR NIO STATUS REG                   R123_OS       44
 PPR2     RJM    SPM         SET PP MODE                                 DOH_315        3
          LDM    I0CC                                                    DOH_315        4
          STD    EC          SET UP CONNECT CODE                         R123_OS       47
          RJM    RII         READ IOU EC REGISTER                        KAP_2011       2
          LDML   PPCH                                                    DOH_315        5
          NJP    PPRX        IF CHANNEL REQUEST                          GJF_8138      10
          LDM    IDPA+4                                                  R123_OS       51
          LPC    0#C0        PRESERVE SYSTEM INITIALIZED BIT             DOH_315        7
          LMM    PPRA                                                    R123_OS       53
          STM    IDPA+4                                                  R123_OS       54
          LJM    PPRX        RETURN                                      R123_OS       55
                                                                         R123_OS       56
 PPRE     CON    0           ENVIRONMENT CONTROL REGISTER NUMBER         R123_OS       57
 PPRA     CON    0           STORAGE FOR ENV CTRL BYTE 4                 R123_OS       58
 PPRS     CON    0           STATUS REGISTER NUMBER                      R123_OS       59
 SPM      SPACE  4,10                                                    R123_OS       60
**        SPM - SET PP MODE.                                             R123_OS       61
*                                                                        R123_OS       62
*         SETS PP MODE IN ENVIRONMENT CONTROL FOR 4K OR 8K.              R123_OS       63
                                                                         KAP_87         6
                                                                         KAP_87         7
 SPM1     LDM    PPNO                                                    KAP_2011       3
          LPN    0#1F        MAKE JUST PP NUMBER                         KAP_2011       4
          SCN    40                                                      KAP_2011       5
          LMN    40          SET AUTO BIT                                KAP_2011       6
          STM    PPRA                                                    KAP_2011       7
                                                                         KAP_2011       8
 SPM      SUBR               ENTRY/EXIT                                  R123_OS       65
          LDM    PPNO        GET PP NUMBER                               R123_OS       66
          SHN    21-10                                                   R123_OS       67
          PJN    SPM1        IF NIO PP                                   R123_OS       68
          LDM    PPNO                                                    R123_OS       69
          LPC    0#7F        CLEAR MODE PARAMETER BIT                    R123_OS       70
          STM    PPRA                                                    R123_OS       72
          UJN    SPMX        RETURN                                      DOH_315        8
 IDP      SPACE  4,10                                                    KAP_81         1
**        IDP - IDLE PP.                                                 R123_OS       83
*                                                                        R123_OS       84
*         ENTRY  (A) = PP TYPE AND NUMBER TO IDLE.                       R123_OS       85
*                                                                        R123_OS       86
*         EXIT   PP IDLED.                                               R123_OS       87
*                                                                        R123_OS       88
*         USES   RN, EC, T6.                                             R123_OS       89
*                                                                        KAP_87         8
*         CALLS  CIE, PPR, WFI, WII.                                     KAP_87         9
                                                                         R123_OS       90
                                                                         R123_OS       91
 IDP      SUBR               ENTRY/EXIT                                  R123_OS       92
          RJM    PPR         PRESET PP                                   R123_OS       93
          LDM    IDPA+6      SET IDLE, K REGISTER                        KAP_87        10
          SCN    37                                                      KAP_87        11
          LMN    6                                                       KAP_87        12
          STM    IDPA+6                                                  R123_OS       95
          LDM    IDPA+7                                                  R123_OS       96
          SCN    40                                                      R123_OS       97
          LMN    40          SET ENABLE IDLE, BIT58                      R123_OS       98
          STM    IDPA+7                                                  R123_OS       99
          LDN    16         DUMMY CHANNEL                                R123_OS      100
          STM    IDPA+5                                                  R123_OS      101
          RJM    WII         WRITE IOU REGISTER TO IDLE PP               KAP_87        13
          RJM    WFI         WAIT FOR IDLE                               R123_OS      103
                                                                         R123_OS      104
*         NOTE THE FOLLOWING COMMENTED CODE SHOULD BE USED HOWEVER       R123_OS      105
*         IT IS NOT BECAUSE EXECUTING IT ON AN I2 WILL NOT               R123_OS      106
*         REALLY IDLE THE PP. THERE WAS AN FCO 2705 WHICH SUPPOSEDLY     R123_OS      107
*         FIXES THIS.                                                    R123_OS      108
                                                                         R123_OS      109
*         NJN    IDP1        IF NOT SUCESSFUL                            R123_OS      110
*         RJM    CIE         CLEAR IOU EC REGISTER                       R123_OS      111
*         LJM    IDPX                                                    R123_OS      112
                                                                         R123_OS      113
*         DEADSTART PP INTO IDLE MODE.                                   R123_OS      114
*                                                                        KAP_81         2
*         IF AT THE TIME THE PP WAS IDLED, IT WAS HUNG AT A CHANNEL      KAP_81         3
*         FUNCTION INSTRUCTION, THE DUMP IDLE WILL CAUSE A FORCED EXIT   KAP_81         4
*         OF THE INSTRUCTION.  BECAUSE THIS IS DONE WITH AN OAM          KAP_81         5
*         INSTRUCTION, THE P ADDRESS (AFTER THE PP IS DUMP IDLED) WILL   KAP_81         6
*         BE SET TO WHATEVER HAPPENS TO BE IN PP ADDRESS 0 + 1.          KAP_81         7
                                                                         R123_OS      115
 IDP1     LDM    IDPA+6      SET DUMP, IDLE, K REGISTER                  KAP_87        14
          SCN    37                                                      KAP_87        15
          LMN    16                                                      KAP_87        16
          STM    IDPA+6                                                  R123_OS      117
          LDM    IDPA+7                                                  R123_OS      118
          SCN    40                                                      R123_OS      119
          LMN    40          SET ENABLE                                  R123_OS      120
          STM    IDPA+7                                                  R123_OS      121
          LDM    PPRE                                                    R123_OS      122
          STD    RN                                                      R123_OS      123
          RJM    WII         WRITE IOU EC REGISTER                       KAP_87        17
          RJM    WFI         WAIT FOR IDLE                               R123_OS      125
          RJM    CIE         CLEAR IOU EC REGISTER                       R123_OS      126
          LJM    IDPX        RETURN                                      R123_OS      127
                                                                         R123_OS      128
 IDPA     BSS    10                                                      R123_OS      129
 WFI      SPACE  4,15                                                    KAP_87        18
**        WFI - WAIT FOR IDLE.                                           R123_OS      131
*                                                                        R123_OS      132
*         ENTRY  (IDPA - IDPA+7) = CURRENT EC REGISTER.                  R123_OS      133
*                                                                        R123_OS      134
*         EXIT   (A) = 0 IF PP IS IDLING.                                R123_OS      135
*                                                                        R123_OS      136
*         USES   RN, T6.                                                 R123_OS      137
*                                                                        KAP_87        19
*         CALLS  WII.                                                    KAP_87        20
*                                                                        KAP_87        21
*         MACROS LOCKMR, READMR.                                         KAP_87        22
                                                                         R123_OS      138
                                                                         R123_OS      139
 WFI      SUBR               ENTRY/EXIT                                  R123_OS      140
          LDC    4096D/5                                                 R123_OS      141
          STD    T1                                                      R123_OS      142
          LDM    IDPA+6      SELECT K REGISTER                           KAP_87        23
          SCN    37                                                      KAP_87        24
          LMN    2                                                       KAP_87        25
          STM    IDPA+6                                                  R123_OS      144
          LDM    IDPA+7      CLEAR DUMP/LOAD/IDLE ENABLE BIT             R123_OS      145
          SCN    40                                                      R123_OS      146
          STM    IDPA+7                                                  R123_OS      147
 WFI1     LOCKMR SET                                                     R123_OS      148
          LDM    PPRE                                                    R123_OS      149
          STD    RN                                                      R123_OS      150
          RJM    WII         SET K REGISTER DISPLAY                      KAP_87        26
          LDM    PPRS                                                    R123_OS      152
          STD    RN                                                      R123_OS      153
          READMR WFIA        READ STATUS REGISTER                        R123_OS      154
          LOCKMR CLEAR                                                   R123_OS      155
          LDM    WFIA+4                                                  R123_OS      156
          LPN    3                                                       R123_OS      157
          SHN    10                                                      R123_OS      158
          ADM    WFIA+5                                                  R123_OS      159
          SHN    10                                                      R123_OS      160
          ADM    WFIA+6                                                  R123_OS      161
          SHN    -6          INTERNAL REGISTER CONTENT OF SELECTED PP    R123_OS      162
          LMC    1077                                                    R123_OS      163
          ZJN    WFI3        IF IDLED                                    R123_OS      164
          SOD    T1                                                      R123_OS      165
          ZJN    WFI2        IF TIMED OUT                                R123_OS      166
          LJM    WFI1        TRY AGAIN                                   R123_OS      167
                                                                         R123_OS      168
 WFI2     LDN    77                                                      R123_OS      169
 WFI3     LJM    WFIX        RETURN                                      R123_OS      170
                                                                         R123_OS      171
 WFIA     BSSZ   10                                                      R123_OS      172
 DLP      SPACE  4,10                                                    R123_OS      173
***       DLP - DEADSTART LOAD PP.                                       R123_OS      174
*                                                                        R123_OS      175
*         ENTRY  (A) = PP TYPE AND NUMBER.                               R123_OS      176
*                (T1) = CHANNEL NUMBER TO DEADSTART PP TO.               R123_OS      177
*                                                                        R123_OS      178
*         EXIT   PP DOING BLOCK INPUT ON CHANNEL (T1).                   R123_OS      179
*                                                                        R123_OS      180
*         USES   EC, RN, T1, T6.                                         R123_OS      181
*                                                                        KAP_87        27
*         CALLS  CIE, PDC, PPR, WII.                                     KAP_87        28
                                                                         R123_OS      182
                                                                         R123_OS      183
 DLP      SUBR               ENTRY/EXIT                                  R123_OS      184
          RJM    PPR                                                     R123_OS      185
          LDD    T1                                                      R123_OS      186
          STM    IDPA+5                                                  R123_OS      187
          LDM    IDPA+6      SET LOAD MODE                               KAP_87        29
          SCN    37          PRESERVE UPPER BITS                         KAP_87        30
          ADN    20                                                      KAP_87        31
          STM    IDPA+6                                                  R123_OS      189
          LDM    IDPA+7                                                  R123_OS      190
          SCN    40                                                      R123_OS      191
          LMN    40                                                      R123_OS      192
          STM    IDPA+7                                                  R123_OS      193
          RJM    PDC         PREPARE DEADSTART CHANNEL                   R123_OS      194
          RJM    WII         DEADSTART LOAD IOU                          KAP_87        32
          RJM    CIE         CLEAR IOU EC REGISTER                       R123_OS      196
          UJN    DLPX        RETURN                                      KAP_87        33
 DDP      SPACE  4,10                                                    R123_OS      198
***       DDP - DEADSTART DUMP PP.                                       R123_OS      199
*                                                                        R123_OS      200
*         ENTRY  (A) = PP TYPE AND NUMBER.                               R123_OS      201
*                (T1) = CHANNEL NUMBER ON DEADSTART PP ON.               R123_OS      202
*                                                                        R123_OS      203
*         EXIT   PP DOING BLOCK OUTPUT ON CHANNEL (T1).                  R123_OS      204
*                                                                        R123_OS      205
*         USES   EC, RN, T1, T6.                                         R123_OS      206
*                                                                        KAP_87        34
*         CALLS  CIE, PDC, PPR, WII.                                     KAP_87        35
                                                                         R123_OS      207
                                                                         R123_OS      208
 DDP      SUBR               ENTRY/EXIT                                  R123_OS      209
          RJM    PPR                                                     R123_OS      210
          LDD    T1                                                      R123_OS      211
          STM    IDPA+5                                                  R123_OS      212
          LDM    IDPA+6      SET DUMP + IDLE MODE                        KAP_87        36
          SCN    37                                                      KAP_87        37
          LMN    14                                                      KAP_87        38
          STM    IDPA+6                                                  R123_OS      214
          LDM    IDPA+7                                                  R123_OS      215
          SCN    40                                                      R123_OS      216
          LMN    40                                                      R123_OS      217
          STM    IDPA+7                                                  R123_OS      218
          RJM    PDC         PREPARE DEADSTART CHANNEL                   R123_OS      219
          RJM    WII         DEADSTART LOAD IOU                          KAP_87        39
          RJM    CIE         CLEAR IOU EC REGISTER                       R123_OS      221
          UJN    DDPX        RETURN                                      R123_OS      222
 .A       IF     DEF,MCH$                                                DOH_58         7
 MCH      SPACE  4,10                                                    DOH_55         6
**        MCH - MASTER CLEAR CHANNEL.                                    DOH_55         7
*                                                                        DOH_55         8
*         ENTRY  (A) = CHANNEL TYPE AND NUMBER.                          DOH_55         9
*                                                                        DOH_55        10
*         EXIT   CHANNEL MASTER CLEARED.                                 DOH_55        11
*                                                                        KAP_87        40
*         CALLS  CIE, PPR, WII.                                          KAP_87        41
                                                                         DOH_55        12
                                                                         DOH_55        13
 MCH      SUBR               ENTRY/EXIT                                  DOH_55        14
          STDL   T1                                                      DOH_315        9
          LDN    1           SET CHANNEL PROCESSING                      DOH_315       10
          STML   PPCH                                                    DOH_315       11
          LDDL   T1                                                      DOH_315       12
          RJM    PPR         PRESET PP ROUTINES                          DOH_55        19
          LDML   IDPA+5      SET CHANNEL NUMBER                          DOH_55        20
          LPC    0#FFE0                                                  DOH_55        21
          STML   IDPA+5                                                  DOH_55        22
          LDML   PPNO                                                    DOH_55        23
          LPC    0#1F                                                    DOH_55        24
          RAML   IDPA+5                                                  DOH_55        25
          LDML   IDPA+7      SET INDIVIDUAL CHANNEL MASTER CLEAR         DOH_221        1
          SCN    2                                                       DOH_55        27
          LMN    2                                                       DOH_55        28
          STML   IDPA+7                                                  DOH_55        29
          RJM    WII         MASTER CLEAR CHANNEL                        KAP_87        42
          RJM    CIE         CLEAR IOU EC REGISTER                       DOH_55        31
          LDN    0           SET DEFAULT MODE                            DOH_315       13
          STML   PPCH                                                    DOH_315       14
          UJP    MCHX        RETURN                                      DOH_55        34
 .A       ENDIF                                                          DOH_58         8
 CIE      SPACE  4,10                                                    R123_OS      223
**        CIE - CLEAR IOU EC REGISTER.                                   R123_OS      224
*                                                                        R123_OS      225
*         ENTRY  (EC) = I0CC.                                            R123_OS      226
*                                                                        R123_OS      227
*         EXIT   IOU EC REGISTER RESET.                                  R123_OS      228
*                                                                        KAP_87        43
*         CALLS  RII, WII.                                               KAP_2011       9
                                                                         R123_OS      229
                                                                         R123_OS      230
 CIE      SUBR               ENTRY/EXIT                                  R123_OS      231
          RJM    RII         READ IOU EC REGISTER                        KAP_2011      10
          LDN    0                                                       R123_OS      235
          STM    IDPA+5                                                  R123_OS      236
          LDM    IDPA+6                                                  KAP_87        47
          SCN    37                                                      KAP_87        48
          STM    IDPA+6                                                  R123_OS      237
          LDM    IDPA+7                                                  R123_OS      238
          SCN    40                                                      R123_OS      239
          STM    IDPA+7      CLEAR ENABLE DUMP/LOAD/IDLE                 R123_OS      240
          LDM    IDPA+4                                                  R123_OS      241
          LPC    0#C0        SAVE UPPER BITS                             DOH_315       15
          STM    IDPA+4                                                  R123_OS      243
          RJM    WII         WRITE IOU EC REGISTER                       KAP_87        49
          UJN    CIEX        RETURN                                      KAP_2011      11
 PDC      SPACE  4,10                                                    R123_OS      246
**        PDC - PREPARE DEADSTART CHANNEL.                               R123_OS      247
*                                                                        R123_OS      248
*         ENTRY  (T1) = CHANNEL NUMBER TO DEADSTART PP ON.               R123_OS      249
*                                                                        R123_OS      250
*         EXIT   CHANNEL ACTIVE AND EMPTY.                               R123_OS      251
                                                                         R123_OS      252
                                                                         R123_OS      253
 PDC      SUBR               ENTRY/EXIT                                  R123_OS      254
          LDC    DCNI+40                                                 R123_OS      255
          LMD    T1                                                      R123_OS      256
          STM    PCHA                                                    R123_OS      257
          LMC    ACNI&DCNI                                               R123_OS      258
          STM    PCHB                                                    R123_OS      259
 PCHA     DCN    CH+40       DROP POSSIBLE ACTIVE CHANNEL                R123_OS      260
 PCH1     SBN    1                                                       R123_OS      261
          PJN    PCH1        WAIT A BIT                                  R123_OS      262
 PCHB     ACN    CH+40       ACTIVATE EMPTY CHANNEL                      R123_OS      263
          UJN    PDCX        RETURN                                      R123_OS      264
 RII      SPACE  4,10                                                    KAP_2011      12
**        RII - READ IOU EC REGISTER INTO *IDPA*.                        KAP_2011      13
*                                                                        KAP_2011      14
*         ENTRY  (EC) = IOCC.                                            KAP_2011      15
*                (PPRE) = REGISTER NUMBER.                               KAP_2011      16
*                                                                        KAP_2011      17
*         EXIT   (IDPA - IDPA+7) = IOU EC REGISTER.                      KAP_2011      18
*                                                                        KAP_2011      19
*         USES   RN.                                                     KAP_2011      20
*                                                                        KAP_2011      21
*         MACROS READMR.                                                 KAP_2011      22
                                                                         KAP_2011      23
                                                                         KAP_2011      24
 RII      SUBR               ENTRY/EXIT                                  KAP_2011      25
          LDM    PPRE        SET REGISTER NUMBER                         KAP_2011      26
          STD    RN                                                      KAP_2011      27
          READMR IDPA        READ IOU EC REGISTER                        KAP_2011      28
          UJN    RIIX        RETURN                                      KAP_2011      29
 WII      SPACE  4,10                                                    KAP_87        50
**        WII - WRITE IOU EC REGISTER FROM *IDPA*.                       KAP_2011      30
*                                                                        KAP_87        52
*         ENTRY  (RN) = IOU EC REGISTER NUMBER.                          KAP_87        53
*                (EC) = CONNECT CODE.                                    KAP_87        54
*                                                                        KAP_87        55
*         EXIT   IOU EC REGISTER WRITTEN.                                KAP_87        56
*                                                                        KAP_87        57
*         MACROS WRITMR.                                                 KAP_87        58
                                                                         KAP_87        59
                                                                         KAP_87        60
 WII      SUBR               ENTRY/EXIT                                  KAP_87        61
          WRITMR IDPA                                                    DOH_315       16
          UJN    WIIX        RETURN                                      KAP_87        63
          SPACE  4,10                                                    R123_OS      265
          BASE   *                                                       R123_OS      266
 QUAL$    IF     -DEF,QUAL$                                              R123_OS      267
          QUAL   *                                                       R123_OS      268
 DDP      EQU    /COMPIDP/DDP                                            R123_OS      269
 DLP      EQU    /COMPIDP/DLP                                            R123_OS      270
 IDP      EQU    /COMPIDP/IDP                                            R123_OS      271
 PPRE     EQU    /COMPIDP/PPRE                                           GJF_8055       1
 CIE      EQU    /COMPIDP/CIE                                            GJF_8055       2
 .B       IF     DEF,MCH$                                                DOH_58         9
 MCH      EQU    /COMPIDP/MCH                                            DOH_55        35
 .B       ENDIF                                                          DOH_58        10
 QUAL$    ENDIF                                                          R123_OS      272
          SPACE  4,10                                                    R123_OS      273
          ENDX                                                           R123_OS      274
*DECK DECK=DSI$FETCH_BUFFER_CONTROLWARE EXPAND=FALSE
          EJECT
          TITLE  LOADBC - FETCH BUFFER CONTROLWARE FROM NOS.
**        LOADBC - FETCH BUFFER CONTROLWARE FROM NOS.
*
*         CALL
*           LOADBC (CHANNEL, ^BUFFER, ^BUFFER_LENGTH, ^STATUS);


          ENTRY  LOADBC
 LOADBC   BSS    0
          RJ     ZSMRENT     DECODE PARAMETERS
          SB1    1
          RJ     GCN         GET CONTROLWARE NAME
          NZ     B5,LBC1     IF NAME NOT FOUND
          RJ     RCF         READ CONTROLWARE FILE
          NZ     B5,LBC1     IF CONTROLWARE NOT FOUND
          RJ     RPC         RE-PACKAGE CONTROLWARE
 LBC1     SX6    B5
          SA1    STATUS
          SA6    X1          SAVE STATUS
          RETURN IN
          JP     ZSMRRET     RETURN TO CYBIL ROUTINE
 LOADBC   SPACE  4,10
**        FILE ENVIRONMENT TABLE.


 IN       BSS    0
 SYSTEM   RFILEB 0,5000,(FET=9)
 LOADBC   SPACE  4,10
**        CONTROL STORAGE CELLS.


 CHN      EQU    PARSV+0     CHANNEL NUMBER
 BUFA     EQU    PARSV+1     BUFFER ADDRESS
 BUFL     EQU    PARSV+2     BUFFER LENGTH
 STATUS   EQU    PARSV+3     STATUS
 CRN      CON    0           CONTROLWARE RECORD NAME LEFT JUSTIFIED
 CWL      CON    0           CONTROLWARE LENGTH
 FWC      CON    0           FWA OF CONTROLWARE
 LWC      CON    0           LWA+1 OF CONTROLWARE
 RCF      SPACE  4,15
**        RCF - READ CONTROLWARE FILE.
*
*         EXIT   (B5) = 0, IF VALID CONTROLWARE FILE READ.
*                (B5) .NE. 0, IF ERROR ENCOUNTERED.
*
*         USES   X - ALL.
*                A - 1, 2, 3, 6, 7.
*                B - 2, 3, 4, 5, 6.
*
*         MACROS ASSIGN, READ, REWIND, SKIPB, SKIPEI, STATUS.


 RCF      SUBR               ENTRY/EXIT

*         SET BUFFER POINTERS IN FET.

          SA2    BUFA        BUFFER ADDRESS
          SA3    A2+B1       BUFFER LENGTH
          SX6    X2
          SA1    IN+1        FIRST
          MX4    42
          SA3    X3
          BX7    X4*X1
          IX7    X2+X7
          SA6    A1+B1       STORE IN
          SA7    A1          STORE FIRST
          SA6    A6+B1       STORE OUT
          IX6    X6+X3
          SA6    A6+B1       STORE LIMIT

*         ASSIGN SYSTEM FILE.

          ASSIGN IN
          SKIPEI IN,R        POSITION TO EOI
          SKIPB  IN,2,R      POSITION TO BEGINNING OF DIRECTORY
          READ   IN,R        READ DIRECTORY
          SA1    X2+B1       FETCH BUFFER ADDRESS *FIRST*
          SA2    A1+B1       READ *IN* POINTER
          SB2    X1
          SA3    B2          LENGTH OF 7700 TABLE
          SB3    X2+         (B3) = LWA+1 OF DATA READ
          SA2    CRN
          LX3    24
          SB2    B2+X3       FIRST RECORD ON SYSTEM DIRECTORY
          MX7    42
 RCF1     SA1    B2+         READ DIRECTORY ENTRY
          LT     B2,B3,RCF2  IF NOT END OF DIRECTORY
          SB5    1           SET RESPONSE CODE
          EQ     RCFX        EXIT

 RCF2     BX3    X7*X1
          BX3    X3-X2
          NZ     X3,RCF3     IF CONTROLWARE NOT FOUND
          BX1    -X7*X1
          SX1    X1-10
          ZR     X1,RCF4     IF CONTROLWARE FOUND
 RCF3     SB2    B2+2
          EQ     RCF1        TEST IF NEXT ENTRY

 RCF4     SA1    A1+B1       SET RANDOM ADDRESS IN FET
          MX7    -29
          SA2    IN+6
          BX2    X7*X2
          BX6    -X7*X1
          BX6    X6+X2
          SA6    A2
          SA1    IN+2        RESET *IN* = *FIRST*
          SA2    IN+1
          MX7    -18
          BX2    -X7*X2
          BX1    X7*X1
          BX6    X1+X2
          SA6    A1

*         READ CONTROLWARE RECORD

          READ   IN,R        READ CONTROLWARE RECORD
          SA1    IN+2        READ *IN* POINTER
          SA2    A1+B1       READ *OUT* POINTER
          SB2    X2
          SA3    B2
          SB6    X1          SAVE *IN*
          MX0    12
          MX1    6           FORM 7700 MASK
          BX2    X0*X3
          SB5    2
          BX1    X1-X2
          NZ     X1,RCFX     IF NOT 7700 TABLE
          LX3    12
          BX2    X0*X3       LENGTH OF 7700 TABLE
          SB5    3
          LX2    12
          SB3    X2+B1
          SA2    B2+B3       READ EXPECTED 5200 TABLE
          SX3    5200B
          SX6    A2+B1       FWA OF CONTROLWARE
          SA6    FWC
          SB2    X6          *OUT* = FWA OF CONTROLWARE
          SX6    X2-1        SUBTRACT LENGTH OF 5200 TABLE
          SX7    A2
          IX7    X2+X7       ADD CONTROLWARE LENGTH
          SB4    X6
          BX2    X0*X2
          SA7    LWC         SAVE LWA+1 OF CONTROLWARE
          LX2    12
          BX2    X2-X3
          NZ     X2,RCFX     IF NOT 5200 TABLE
          SB6    B6-B2       *IN* - *OUT*
          SB6    B6-B4
          SB5    4
          NZ     B6,RCFX     IF CM WORD COUNT DOES NOT MATCH
          SB5    B0+
          SA6    CWL         SAVE CONTROLWARE LENGTH
          EQ     RCFX        EXIT
 RPC      SPACE  4,10
**        RPC - REPACKAGE CONTROWARE.
*
*         ENTRY  (BUFA) = PLACE TO STORE CONTROLWARE.
*                (FWC) = FWA OF UNPACKED CONTROLWARE.
*                (CWL) = LENGTH OF CONTROLWARE IN WORDS.
*
*         EXIT   CONTROLWARE PACKED 8 IN 8.


 RPC      SUBR               ENTRY/EXIT
          SA1    RPCA
          SA2    A1+B1
          BX6    X1
          BX7    X2
          SA6    GTN         PRESET GET NIBBLE
          SA7    A6+B1
          JP     GTN         ENTER CO-ROUTINES

 GTN      EQ     STN0        STORE NIBBLE
 STN      EQ     GTN0        GET NIBBLE
          EQ     GTN

 RPC1     SX2    0
          RJ     STN         STORE NIBBLE
          SB3    15
          LT     B5,B3,RPC1  WAIT UNTIL LAST WORD IS STORED
          SX6    B2
          SA1    BUFL
          SA6    X1          SAVE DATA LENGTH
          SB5    B0          EXIT WITHOUT ERROR
          EQ     RPCX        RETURN

 RPCA     EQ     STN0        INITIAL CO-ROUTINE ADDRESSES
          EQ     GTN0

*         CO-ROUTINE TO GET NIBBLES FROM UNPACKED CONTROLWARE.

 GTN0     SA2    FWC         START OF CONTROLWARE
          SA3    CWL         CONTROLWARE LENGTH IN WORDS
          SA2    X2-1
          SB3    X3
 GTN1     SB4    4           NUMBER OF 8 BIT BYTES IN WORD
          SA2    A2+B1
          SB3    B3-B1
          NG     B3,RPC1     IF END OF DATA
 GTN2     LX2    4
          RJ     STN         STORE NIBBLE
          LX2    4
          RJ     STN         STORE NIBBLE
          SB4    B4-B1
          LX2    4
          PL     B4,GTN2     IF MORE DATA IN WORD
          EQ     GTN1        FETCH NEXT WORD

*         CO-ROUTINE TO STORE NIBBLES INTO BUFFER.

 STN0     SA1    BUFA        ADDRESS OF BUFFER
          SB2    B0
          MX5    4
 STN1     SB5    15          NIBBLES IN PACKED WORD
          SX6    0
 STN2     RJ     GTN         GET NIBBLE
          BX7    X5*X2       ISOLATE NIBBLE
          BX6    X6+X7
          SB5    B5-B1
          LX6    4
          NZ     B5,STN2     IF MORE NIBBLES TO STORE
          SA6    X1+B2
          SB2    B2+B1
          EQ     STN1        CONTINUE
 GCN      SPACE  4,10
**        GCN - GET CONTROLWARE NAME.
*
*         EXIT   (B5) .NE. ZERO IF NAME NOT FOUND.
*                (B5) = 0 IF NAME OBTAINED.
*                (CRN) = CONTROLWARE RECORD NAME.
*
*         USES   X - 1, 2, 4, 5, 6, 7.
*                A - 1, 4, 5, 6, 7.
*                B - 2, 3, 4, 5, 7.
*
*         MACROS SYSTEM.


 GCN      SUBR               ENTRY/EXIT
          SA1    CBUF
          PL     X1,GCN5     IF TABLES ALREADY OBTAINED
          SYSTEM RSB,R,GCNC,0
          SA1    GCNB        GET FWA OF CHANNEL TABLES
          MX2    -18
          AX1    12
          SA4    GCNA
          BX3    -X2*X1
          SX3    X3+CTALL*2
          LX3    18          POSITION FWA OF CHANNEL TABLES
          BX6    X3+X4
          SA6    A4
          SYSTEM RSB,R,GCNA,0  READ CHANNEL TABLES
 GCN5     SA5    CHN         GET CHANNEL NUMBER
          SB2    B0
 GCN6     SX5    X5-5        DIVIDE BY 5 LOOP
          NG     X5,GCN7     IF DIVIDE COMPLETE
          SB2    B2+B1
          EQ     GCN6        CONTINUE DIVIDE

 GCN7     SB3    X5+6        SAVE BYTE INDEX FOR CONTROLWARE TABLE
          SA1    CBUF+B2
 GCN8     LX1    12
          SB3    B3-B1
          NZ     B3,GCN8     IF CHANNEL NOT IN CORRECT POSITION
          MX5    -4
          BX1    -X5*X1      GET CONTROLLER TYPE INDEX
          SB3    X1
          SA1    B3+GCND     GET CONTROLWORD RECORD NAME
          NZ     X1,GCN9     IF CONTROLWARE ON CHANNEL
          SB5    5
          EQ     GCNX        EXIT

 GCN9     BX6    X1
          SA6    CRN
          SB5    B0
 GCN11    EQ     GCNX        EXIT


 GCNA     VFD    12/0,12/CTALL,18/0,18/CBUF

 GCNB     CON    -1          TEMPORARY BUFFER
 GCNC     VFD    12/0,12/1,18/CHTP,18/GCNB


**        TABLE OF CONTROLWARE TYPES.

 GCND     BSS    0
          LOC    0
          CON    0           0 - NO CONTROLWARE
          DATA   0LBCS       1 - HT (7054/7154/7152)
          DATA   0LBCF       2 - FT (7154/7152)
          DATA   0LFMD       3 - FMD (7155)
          DATA   0LADP       4 - FSC ADAPTER
          DATA   0LPHD       5 - DEMA/AFMD (7155-10)
          DATA   0L170       6 - CYBER 170 NAD
          CON    0           7 - UNUSED (NO CONTROLWARE)
          CON    0           10- UNUSED (NO CONTROLWARE)
          CON    0           11- UNUSED (NO CONTROLWARE)
          CON    0           12- UNUSED (NO CONTROLWARE)
          CON    0           13- UNUSED (NO CONTROLWARE)
          CON    0           14- UNUSED (NO CONTROLWARE)
          CON    0           15- UNUSED (NO CONTROLWARE)
          CON    0           16- UNUSED (NO CONTROLWARE)
          CON    0           17- UNUSED (NO CONTROLWARE)
          LOC    *O
 CBUF     CON    -1          CHANNEL TABLE BUFFER
          BSS    CTALL
*DECK DECK=DSI$FIND_CIP_MODULE EXPAND=FALSE
          CTEXT  DSI$FIND CIP MODULE                                     R123_OS        1
          SPACE  4,10                                                    R123_OS        2
 QUAL$    IF     -DEF,QUAL$                                              R123_OS        3
          QUAL   DSIFCM                                                  R123_OS        4
 QUAL$    ENDIF                                                          R123_OS        5
          BASE   M                                                       R123_OS        6
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992               SCW_1090       1
 DSIFCM   SPACE  4,10                                                    R123_OS        8
***       DSI$FIND_CIP_MODULE.                                           R123_OS        9
*         B. R. HANSON       85/05/14.                                   R123_OS       10
 FCM      SPACE  4,10                                                    R123_OS       11
***       PROVIDES A ROUTINE TO FIND A MODULE IN THE CIP CM DIRECTORY.   R123_OS       12
 FCM      SPACE  4,10                                                    R123_OS       13
**        FCM - FIND CIP MODULE.                                         R123_OS       14
*                                                                        R123_OS       15
*         ENTRY  (A) = ADDRESS OF FOUR CHARACTER DISPLAY CODE NAME.      R123_OS       16
*                                                                        R123_OS       17
*         EXIT   (A) = OFFSET FROM R-REGISTER OF MODULE HEADER.          R123_OS       18
*                (R) = ADDRESS/100B OF MODULE HEADER.                    R123_OS       19
*                (A) = 0, IF NOT FOUND.                                  R123_OS       20
*                                                                        R123_OS       21
*         USES   CM - CM+3, T1, W0 - W3.                                 R123_OS       22
*                                                                        R123_OS       23
*         CALLS  IIB.                                                    R123_OS       24
                                                                         R123_OS       25
                                                                         R123_OS       26
 FCM3     LDDL   CM          RETURN OFFSET                               DOH_334        1
          ADC    RR                                                      DOH_334        2
                                                                         DOH_334        3
 FCM      SUBR               ENTRY/EXIT                                  R123_OS       27
          STD    T1                                                      R123_OS       28
 CD       IF     DEF,CD                                                  R123_OS       29
          LRD    CD+1                                                    R123_OS       30
          SRD    CM+1                                                    R123_OS       31
          LDDL   CD                                                      R123_OS       32
 CD       ELSE                                                           R123_OS       33
          LDN    DSCM+2                                                  R123_OS       34
          RJM    IIB                                                     R123_OS       35
          CRDL   CM          READ CIP POINTER                            R123_OS       36
          LDDL   CM                                                      R123_OS       37
 CD       ENDIF                                                          R123_OS       38
                                                                         R123_OS       39
 FCM1     STDL   CM                                                      R123_OS       40
          LRD    CM+1                                                    R123_OS       41
          ADC    RR                                                      R123_OS       42
          CRDL   W0                                                      R123_OS       43
          LDD    W0                                                      R123_OS       44
          ADD    W1                                                      R123_OS       45
          ZJN    FCMX        IF END OF DIRECTORY                         R123_OS       46
          LDD    W0                                                      R123_OS       47
          LMI    T1                                                      R123_OS       48
          NJN    FCM2        IF NO MATCH                                 R123_OS       49
          LDD    W1                                                      R123_OS       50
          LMM    1,T1                                                    R123_OS       51
          ZJN    FCM3        IF MATCH                                    DOH_334        4
                                                                         R123_OS       56
 FCM2     LDDL   W3          OFFSET TO NEXT MODULE HEADER                R123_OS       57
          RADL   CM                                                      R123_OS       58
          SHN    -6                                                      R123_OS       59
          RADL   CM+2                                                    R123_OS       60
          SHN    -14                                                     R123_OS       61
          RADL   CM+1                                                    R123_OS       62
          LDD    CM                                                      R123_OS       63
          LPN    77                                                      R123_OS       64
          UJN    FCM1        FETCH NEXT ENTRY                            R123_OS       65
          SPACE  4,10                                                    R123_OS       66
          BASE   *                                                       R123_OS       67
 QUAL$    IF     -DEF,QUAL$                                              R123_OS       68
          QUAL   *                                                       R123_OS       69
 FCM      EQU    /DSIFCM/FCM                                             R123_OS       70
 QUAL$    ENDIF                                                          R123_OS       71
          ENDX                                                           R123_OS       72
*DECK DECK=DSI$FIND_SPAA_RMA EXPAND=FALSE
          EJECT                                                          R152_OS        1
          TITLE  DSI$FIND SPAA RMA.                                      R152_OS        2
**        FSR - FIND SPAA RMA.                                           R152_OS        3
*                                                                        R152_OS        4
*         SEARCH SPAA FOR ID AND RETURN THE CORRESPONDING RMA.           R152_OS        5
*                                                                        R152_OS        6
*         ENTRY  (A) = SPAA ID CODE.                                     R152_OS        7
*                (DSRTP - DSRTP+1) = POINTER TO POINTER TO SPAA.         R152_OS        8
*                                                                        R152_OS        9
*         EXIT   (A) = ADDRESS OF SPAA ENTRY.                            R152_OS       10
*                (W2 - W3) = RMA OF ENTRY.                               R152_OS       11
*                                                                        R152_OS       12
*         USES   T2, W0 - W6.                                            R152_OS       13
*                                                                        R152_OS       14
*         CALLS  STA.                                                    R152_OS       15
                                                                         R152_OS       16
                                                                         R152_OS       17
 FSR2     LDDL   W6          RETURN POINTER TO ENTRY                     R152_OS       18
          LMC    400000B                                                 R152_OS       19
                                                                         R152_OS       20
 FSR      SUBR               ENTRY/EXIT                                  R152_OS       21
          STD    T2          SET ID TO SEARCH FOR                        R152_OS       22
          LDN    DRVTBLP                                                 R152_OS       23
          RJM    IIB                                                     R152_OS       24
          CRDL   W0                                                      R152_OS       25
          RJM    STA         SET SET ADDRESS OF SPAA                     R152_OS       26
 FSR1     LDDL   W6          FETCH NEXT ENTRY OF SPAA                    R152_OS       27
          LMC    400000                                                  R152_OS       28
          CRDL   W0                                                      R152_OS       29
          LDDL   W1          ENTRY IDENTIFIER                            R152_OS       30
          ZJN    FSRX        IF ENTRY NOT FOUND                          R152_OS       31
          LMD    T2                                                      R152_OS       32
          ZJN    FSR2        IF ENTRY FOUND                              R152_OS       33
          LDN    2                                                       R152_OS       34
          RAD    W6          INCREMENT INDEX INTO SPAA                   R152_OS       35
          UJN    FSR1        TRY NEXT ENTRY                              R152_OS       36
*DECK DECK=DSI$GET_HARDWARE_ELEMENT EXPAND=FALSE
          CTEXT  DSI$GET HARDWARE ELEMENT                               
          SPACE  4                                                      
 QUAL$    IF     -DEF,QUAL$                                             
          QUAL   DSIGHE                                                 
 QUAL$    ENDIF                                                         
          BASE   M                                                      
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992              
          SPACE  4                                                      
***       DSI$GET_HARDWARE_ELEMENT                                      
*         G. J. FALCONER     85/05/14.                                  
          SPACE  4                                                      
***              PROVIDES ROUTINES TO FIND SPECIFIC OR ARBITRARY        
*         HARDWARE ELEMENT DEFINITIONS AND TO REWRITE THE               
*         DEFINITON.                                                    
*                                                                       
*         THIS DECK REQUIRES THAT THE USER HAS DEFINED A BUFFER         
*         IN THE FOLLOWING MANNER OR OF THE APPROPRIATE SIZE.           
*                                                                       
*                  BSSZ   3           SLACK FOR ENTRY                   
*         HBUF     BSSZ   CMXLEN      HARDWARE ELEMENT BUFFER           
*                                                                       
*         IF THE WRITE MRT ROUTINE (*WHE*) IS TO BE USED, THE           
*         SYMBOL WHE$ MUST BE DEFINED.                                  
 GNE      SPACE  4,10                                                   
**        GNE - GET NEXT HARDWARE ELEMENT ENTRY.                        
*                                                                       
*         ENTRY  GNEA = PP WORD OFFSET TO NEXT ELEMENT.                 
*                INXW = WORD OFFSET TO 2AP IN CIP DIRECTORY.            
*                INXP = PP WORD OFFSET WITHIN 2AP.                      
*                (HP - HP+1) = R-REGISTER POINTER TO 2AP.               
*                                                                       
*         EXIT   HBUF = CONTAINS NEXT ENTRY.                            
*                A = ELEMENT ID OR -1 IF NO MORE ENTRIES.               
*                                                                       
*         USES   T1.                                                    
*                                                                       
*         NOTE   *HBUF* AND 3 ADDITIONAL CELLS MUST BE DEFINED BY       
*                THE CALLER OF THIS COMMON DECK.                        
                                                                        
                                                                        
 GNE1     LCN    1                                                      
                                                                        
 GNE      SUBR               ENTRY/EXIT                                 
                                                                        
*         CONVERT PP WORD OFFSET TO CM ADDRESS AND OFFSET FROM HBUF.    
                                                                        
          LDM    INDEX       INDEX INTO HARDWARE TABLE                  
          LPN    3                                                      
          STD    T1                                                     
          LDC    HBUF                                                   
          SBD    T1                                                     
          STM    GNEA        WHERE TO READ SO ENTRY STARTS AT HBUF      
                                                                        
          LDN    CMXLEN/4                                               
          STD    T1                                                     
          LDM    INDEX       COMPUTE CM WORD OFFSET                     
          SHN    -2                                                     
          ADC    RR+1                                                   
 INXW     EQU    *-1                                                    
          LRD    HP                                                     
          CRML   *,T1        READ INTO HBUF                             
 GNEA     EQU    *-1                                                    
          LDM    HBUF                                                   
          ZJN    GNE1                                                   
          SHN    -6                                                     
          RAM    INDEX                                                  
          LDM    HBUF        FETCH ELEMENT ID                           
          LPN    77                                                     
          UJN    GNEX        RETURN                                     
                                                                        
 INDEX    CON    0                                                      
                                                                        
 FHE      SPACE  4,10                                                   
**        FHE - FIND HARDWARE ELEMENT                                   
*                                                                       
*         ENTRY  (A) = 6/NUMBER, 12/KIND OF ELEMENT.                    
*                                                                       
*         EXIT   (A) = ORDINAL OF ELEMENT OR -1 IF NOT FOUND.           
*                                                                       
*         USES   T2, T3, T4.                                            
*                                                                       
*         CALLS  GNE, RHT.                                              
                                                                        
                                                                        
 FHE      SUBR                                                          
          STD    T3          KIND OF ELEMENT                            
          SHN    -14                                                    
          STD    T4          NUMBER OF ELEMENT                          
          LDN    0                                                      
          STD    T2                                                     
          RJM    RHT         RESET HARDWARE TABLE                       
                                                                        
 FHE1     AOD    T2          INCREMENT ELEMENT ORDINAL                  
          RJM    GNE         GET NEXT ELEMENT                           
          MJN    FHEX        IF AT END OF TABLE                         
          SBD    T3                                                     
          NJN    FHE1        IF WRONG KIND OF ELEMENT                   
          SOD    T4                                                     
          PJN    FHE1        IF WRONG NUMBER                            
          SOD    T2          ELEMENT ORDINAL                            
          UJN    FHEX        RETURN                                     
 PHT      SPACE  4,10                                                   
          USE    PRESET                                                 
                                                                        
**        PHT - PREPARE HARDWARE TABLES.                                
*                                                                       
*         EXIT   HP, INXP, INDEX = SETUP FOR GNE.                       
*                                                                       
*         USES   W0 - W3.                                               
*                                                                       
*         CALLS  FCM.                                                   
                                                                        
                                                                        
 PHT      SUBR               ENTRY/EXIT                                 
          FINDCM 2AP         FIND 2AP IN THE CIP CM DIRECTORY           
          RAM    INXW                                                   
          CRDL   W0          READ HDWR OFFSET VALUE                     
          LDD    W0                                                     
          STM    INXP        SAVE PP WORD OFFSET TO HARDWARE TABLE      
          STM    INDEX       RESET HARDWARE TABLE                       
          SRD    HP          SAVE R-REGISTER POINTER                    
          UJN    PHTX        RETURN                                     
                                                                        
          USE    *                                                      
 RHT      SPACE  4,10                                                   
**        RHT - RESET HARDWARE TABLE.                                   
*                                                                       
*         USES   NONE.                                                  
*                                                                       
*         EXIT   INDEX = RESET TO START OF TABLE.                       
                                                                        
                                                                        
 RHT      SUBR               ENTRY/EXIT                                 
          LDC    **                                                     
 INXP     EQU    *-1         PP WORD OFFSET TO HARDWARE TABLE           
          STM    INDEX                                                  
          UJN    RHTX        RETURN                                     
                                                                        
                                                                        
 .A       IF     DEF,WHE$                                               
 WHE      SPACE  4,15                                                   
**        WHE - WRITE HARDWARE ELEMENT.                                 
*                                                                       
*         ENTRY  (A) = 6/NUMBER, 12/KIND OF ELEMENT.                    
*                (T5) = FWA OF NEW ELEMENT DEFINITION.                  
*                                                                       
*         EXIT   (A) = 0 IF REQUEST COMPLETED SUCCESSUFULLY.            
*                    = -1 IF REQUEST COULD NOT BE COMPLETED.            
*                (HBUF) = NEW DESCRIPTOR.                               
*                                                                       
*         USES   T1, T2, T3, T5.                                        
*                                                                       
*         CALLS  DBC, EBC, FHE.                                         
                                                                        
                                                                        
 WHE20    LCN    1           ERROR                                      
                                                                        
 WHE      SUBR               ENTRY/EXIT                                 
          RJM    FHE         FIND HARDWARE ELEMENT                      
          MJN    WHEX        IF ELEMENT NOT IN MRT CURRENTLY            
          LDM    GNEA        SET OFFSET                                 
          STM    WHEA                                                   
          LDC    HBUF                                                   
          STD    T2                                                     
          LDIL   T2          HEADERS MUST MATCH                         
          LMIL   T5                                                     
          NJN    WHE20       IF MISMATCH                                
          LDIL   T2          GET NUMBER OF BYTES                        
          SHN    -6                                                     
          STDL   T3                                                     
          LMC    777777                                                 
          RAM    INDEX                                                  
 WHE10    LDIL   T5          TRANSFER NEW DEFINITION TO HBUF            
          STIL   T2                                                     
          AOD    T5                                                     
          AOD    T2                                                     
          SOD    T3                                                     
          NJN    WHE10       IF TRANSFER NOT COMPLETE                   
          RJM    DBC         DISABLE BOUNDS CHECKING                    
          LDN    CMXLEN/4                                               
          STD    T1                                                     
          LDM    INDEX                                                  
          SHN    -2                                                     
          ADML   INXW                                                   
          ADC    RR                                                     
          LRD    HP                                                     
          CWML   *,T1                                                   
 WHEA     EQU    *-1                                                    
          RJM    EBC         ENABLE BOUNDS CHECKING                     
          LDN    0           REQUEST COMPLETED NORMALLY                 
          UJP    WHEX        RETURN                                     
                                                                        
                                                                        
 .A       ENDIF                                                         
          SPACE  4                                                      
          BASE   *                                                      
 QUAL$    IF     -DEF,QUAL$                                             
          QUAL   *                                                      
 GNE      EQU    /DSIGHE/GNE                                            
 FHE      EQU    /DSIGHE/FHE                                            
 PHT      EQU    /DSIGHE/PHT                                            
 .B       IF     DEF,WHE$                                               
 WHE      EQU    /DSIGHE/WHE                                            
 .B       ENDIF                                                         
 QUAL$    ENDIF                                                         
          ENDX                                                          
*DECK DECK=DSI$K_DISPLAY_CONTROL EXPAND=FALSE
?? NEWTITLE := '~~~~~   common deck DSI$K_DISPLAY_CONTROL', EJECT ??
{********************************************************

{  Display control, deck DSI$K_DISPLAY_CONTROL.

{ ********************************************************

  CONST
    line_width = 60, {display line width in characters
    header_line = 1, {header line on k display
    message_line = 22, {k display line for message output
    operator_echo_line = 23; {k display line for operator echo

  TYPE
    scroll_types = (scroll, no_scroll, auto),
    kdispb_line = ARRAY [1 .. 7] OF PACKED ARRAY [0 .. 9] OF 0 .. 63,
    param_type = string (line_width);

  VAR
    position: integer, {current position in buffer
    line_position: integer := 1,
    beginning_line_position: integer := 1,
    active_cmnds_file: boolean,
    default_recovery: boolean := TRUE;

?? SKIP := 3 ??
{**********************************************************

{ PURPOSE:
{   Clear k display screen.


  PROCEDURE clear_screen;

    VAR
      i: integer;

    FOR i := 1 TO message_line - 1 DO
      show_message (' ', i, no_scroll);
    FOREND;

  PROCEND clear_screen;
  ?? SKIP := 3 ??
{**********************************************************

{ PURPOSE:
{   Convert k display title to display code.


  PROCEDURE convert_title
    (    k_display_title: string (16));

    VAR
      ktitle: [XREF] ARRAY [1 .. 2] OF PACKED ARRAY [0 .. 9] OF 0 .. 63,
      dcwi: integer,
      dcci: 0 .. 9,
      si: ost$string_index,
      eol: boolean;

    si := 1;
    dcwi := 1;
    dcci := 0;
    eol := TRUE;
    utp$convert_string_to_dc_string (utc$ascii64, ktitle, dcwi, dcci,
          k_display_title, si, eol);

  PROCEND convert_title;
  ?? SKIP := 3 ??
{**********************************************************

{ PURPOSE:
{   Show k display screen.


  PROCEDURE show_message
    (    s: string ( * ),
         line: integer,
         scroll_k_display: scroll_types);

    TYPE
      k_output_copy = ARRAY [1 .. operator_echo_line] OF PACKED RECORD
        header: 0 .. 777777777777(8),
        stuff: 0 .. 77777777(8),
        rest: ARRAY [1 .. 6] OF integer,
      RECEND;

    VAR
      kdispb: [XREF] ARRAY [1 .. operator_echo_line] OF kdispb_line,
      k_display_buffer: ^k_output_copy,
      save_header: 0 .. 777777777777(8),
      display_line: 0 .. operator_echo_line,
      i: integer,
      dcwi: integer,
      scroll_dir: scroll_types,
      dcci: 0 .. 9,
      si: ost$string_index,
      eol: boolean,
      new_string: string (60);

    scroll_dir := scroll_k_display;
    IF scroll_k_display = auto THEN
      IF line_position = 20 THEN
        scroll_dir := scroll;
      ELSE
        scroll_dir := no_scroll;
        line_position := line_position + 1;
      IFEND;
    IFEND;

    k_display_buffer := #LOC (kdispb);
    new_string := s;
    si := 1;
    dcwi := 1;
    dcci := 6;
    eol := TRUE;
    IF scroll_dir = scroll THEN
      FOR i := beginning_line_position TO 19 DO
        save_header := k_display_buffer^ [i].header;
        k_display_buffer^ [i] := k_display_buffer^ [i + 1];
        k_display_buffer^ [i].header := save_header;
      FOREND;
      display_line := 20;
    ELSE
      display_line := line;
    IFEND;
    utp$convert_string_to_dc_string (utc$ascii64, kdispb [display_line], dcwi,
          dcci, new_string, si, eol);

  PROCEND show_message;
  ?? SKIP := 3 ??
{**********************************************************

{ PURPOSE:
{   Skip blanks in input buffer.

  PROCEDURE skip_blanks;

    FOR position := position TO line_width DO
      IF text_line (position) <> ' ' THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND skip_blanks;
  ?? SKIP := 3 ??
{********************************************************

{ PURPOSE:
{   Extract parameter from the command line.


  PROCEDURE extract_param
    (VAR param_value: param_type;
         param_position: integer);

    VAR
      param_cnt: integer,
      number_of_char,
      begin_of_param,
      end_of_param: integer;

{  Skip leading blanks.

    position := 1;
    skip_blanks;

    param_cnt := 0;
    begin_of_param := position;
    end_of_param := 0;
    number_of_char := 0;

{  Find parameter; parameter delimiters are /blank/, /=/ and
{  command is terminated by '.' character.

  /search/
    WHILE position <= line_width DO
      CASE text_line (position) OF
      = '=', ' ', ',' =
        IF param_cnt < param_position THEN
          position := position + 1; {skip separator character
          begin_of_param := position;
          number_of_char := 0;
          param_cnt := param_cnt + 1;
          skip_blanks; {skip leading blanks
          CYCLE /search/;
        ELSEIF param_cnt = param_position THEN
          end_of_param := number_of_char;
          EXIT /search/;
        IFEND;
      = '.' =
        IF param_cnt < param_position THEN
          end_of_param := 0;
        ELSE
          end_of_param := number_of_char;
        IFEND;
        EXIT /search/; {period found
      ELSE
        position := position + 1;
        number_of_char := number_of_char + 1;
      CASEND;
    WHILEND /search/;

    param_value := text_line (begin_of_param, end_of_param);

  PROCEND extract_param;
  ?? SKIP := 3 ??
{********************************************************

{ PURPOSE:
{   Make integer from parameter list.


  TYPE
    number_type = (none, bin, oct, dec, hex);

  PROCEDURE make_number
    (VAR number_param: param_type,
         number_value: c180_word,
         error: boolean;
         default_base: number_type);

    CONST
      max_chars_param = 30; {max number of characters in a parameter

    TYPE
      half_c180w = PACKED RECORD
        ovfl: 0 .. 0fffffff(16), {28 bits
        digits: 0 .. 0ffffffff(16), {32 bits
      RECEND;

    VAR
      digit_array: [STATIC] ARRAY [0 .. 15] OF char := ['0', '1', '2', '3',
        '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'],
      c180_number_template: PACKED RECORD
        pad1: 0 .. 0fffffff(16),
        u_fld: 0 .. 0ffffffff(16),
        pad2: 0 .. 0fffffff(16),
        l_fld: 0 .. 0ffffffff(16),
      RECEND,
      u: ^half_c180w,
      l: ^half_c180w,
      u_value: integer,
      l_value: integer,
      display_digit: integer,
      digit_cnt: integer,
      scaler: integer,
      i,
      j: integer;

{  Initialize return parameters.

    error := TRUE;
    number_value.left := 0;
    number_value.right := 0;

{  Find prefix base if specified.

    CASE number_param (1) OF
    = 'X', 'H' =
      scaler := 16;
      position := 2;
    = 'O' =
      scaler := 8;
      position := 2;
    ELSE
      CASE default_base OF
      = bin =
        scaler := 2;
      = oct =
        scaler := 8;
      = dec =
        scaler := 10;
      = hex =
        scaler := 16;
      ELSE
        scaler := 10;
      CASEND;
      position := 1;
    CASEND;

{  Find postfix base when prefix base not specified.

    i := position;
    WHILE (number_param (i) <> '(') AND (number_param (i) <> ' ') AND (i <
          max_chars_param - 3) DO
      i := i + 1;
    WHILEND;
    IF number_param (i) = '(' THEN
      IF position = 2 THEN
        RETURN;
      IFEND;
      IF number_param (i + 2) = ')' THEN {1 digit suffix
        IF number_param (i + 1) = '8' THEN
          scaler := 8;
        ELSEIF number_param (i + 1) = '2' THEN
          scaler := 2;
        ELSE
          RETURN;
        IFEND;
      ELSEIF (number_param (i + 1) = '1') AND (number_param (i + 3) = ')') THEN
        IF number_param (i + 2) = '0' THEN
          scaler := 10;
        ELSEIF number_param (i + 2) = '6' THEN
          scaler := 16;
        ELSE
          RETURN;
        IFEND;
      ELSE
        RETURN;
      IFEND;
    IFEND;

{  Make number.

{  Extract digits.

    u := #LOC (u_value);
    l := #LOC (l_value);
    u_value := 0;
    l_value := 0;

    FOR digit_cnt := position TO i - 1 DO

    /get_digit/
      FOR j := 0 TO 15 DO
        IF number_param (digit_cnt) = digit_array [j] THEN
          display_digit := j;
          EXIT /get_digit/;
        IFEND;
      FOREND /get_digit/;
      IF number_param (digit_cnt) <> digit_array [j] THEN
        RETURN;
      IFEND;

      IF display_digit >= scaler THEN
        RETURN;
      IFEND;

{  Scale partial result.

      l_value := l_value * scaler;
      u_value := u_value * scaler;
      l_value := l_value + display_digit;
      u_value := u_value + l^.ovfl;
      l^.ovfl := 0;
    FOREND;

{  Produce c180 word result.

    IF u^.ovfl <> 0 THEN
      RETURN;
    IFEND; {number too big
    error := FALSE;
    number_value.left := u^.digits;
    number_value.right := l^.digits;

  PROCEND make_number;
?? OLDTITLE ??
*DECK DECK=DSI$MAINTENANCE_REGISTER_ACCESS EXPAND=FALSE
          CTEXT  DSI$MAINTENANCE REGISTER ACCESS.
 MRA      SPACE  4,10
**        THIS DECK IS A COMPOSITE OF FOUR MAINTENANCE
*         REGISTER PROCESSING DECKS
*         CTP$MR_PROTOCOL_PREPROCESS_S1 IS USED AS THE GENERIC PREPROCESSOR
*         CTP$MR_PROTOCOL_PROCESS IS USED AS THE MAIN PROCESSOR
*         CTP$MR_RETRY_OPERATION_FOR_SCI IS USED FOR RETRYING ERRORS
*         CTP$MR_PROTOCOL_POSTPROCESS_930 IS USED AS THE GENERIC POSTPROCESSOR
 QUAL$    IF     -DEF,QUAL$
          QUAL   DSIMRA
 QUAL$    ENDIF
          BASE   M
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4,10
*COPY CTP$MR_PROTOCOL_PREPROCESS_S1
*COPY CTP$MR_RETRY_OPERATION_FOR_SCI
*COPY CTP$MR_PROTOCOL_PROCESS
*COPY CTP$MR_PROTOCOL_POSTPROCESS_930
          BASE   *
 QUAL$    IF     -DEF,QUAL$
          QUAL   *
 AMR      EQU    /DSIMRA/AMR
 CLI      EQU    /DSIMRA/CLI
 CMI      EQU    /DSIMRA/CMI
 LOCK     EQU    /DSIMRA/LOCK
 MRRC     EQU    /DSIMRA/SMIA
 MRFA     EQU    /DSIMRA/MRFA
 MRFN     EQU    /DSIMRA/MRFN
 RMR      EQU    /DSIMRA/RMR
 SLI      EQU    /DSIMRA/SLI
 SMI      EQU    /DSIMRA/SMI
 WCC      EQU    /DSIMRA/WCC
 QUAL$    ENDIF
          SPACE  4,10
          ENDX
*DECK DECK=DSI$MAINTENANCE_REGISTER_MACROS EXPAND=FALSE
          CTEXT  DSI$MAINTENANCE REGISTER MACROS.
          SPACE  4,10
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 MRM      SPACE  4,10
***       DSI$MAINTENANCE REGISTER MACROS.
*         B. R. HANSON       81/01/29.
          SPACE  4,10
***              DEFINES SEVERAL MACROS WHICH ARE USED IN THE
*         PACKAGES THAT NEED TO ACCESS THE MAINTENANCE CHANNEL.
*         THE USE OF THESE MACROS REQUIRES THE PRESENCE OF THE
*         COMMON DECK *DSI$MAINTENANCE_REGISTER_ACCESS* AND TAGS
*         *RN*, *MRER*, AND OPTIONALLY *EC*.  *RN* IS A DIRECT CELL
*         USED TO PASS THE REGISTER NUMBER TO *AMR*.  *MRER* IS
*         THE ENTRY ADDRESS INTO AN ERROR PROCESSOR FOR FATAL
*         MAINTENANCE CHANNEL ERRORS.  *EC* IS THE DIRECT CELL
*         USED BY THE MACROS TO OBTAIN THE DEFAULT PORT ACCESS CODE.
 EXITMR   SPACE  4,10
**        EXITMR - SET MAINTENANCE REGISTER EXIT ADDRESS.
*
*         EXITMR ADDR
*
*         ENTRY  *ADDR* = ADDRESS TO CALL IF A CHANNEL ERROR
*                         OCCURS TOO MANY TIMES ON A READ.
*
*         NOTE   WHEN EXECUTION RESUMES AT *ADDR* FOR ERRORS ON
*                A READ, THE LONG TERM INTERLOCK WILL HAVE BEEN
*                CLEARED.


          PURGMAC EXITMR

 EXITMR   MACRO  ADDR
          MACREF EXITMR
          LDC    ADDR
          STM    MRFA
 EXITMR   ENDM
 FATALMR  SPACE  4,10
**        FATALMR - SET FATAL MAINTENANCE REGISTER EXIT ADDRESS.
*
*         FATALMR ADDR
*
*         ENTRY  *ADDR* = ADDRESS TO CALL IF A FATAL ERROR OCCURS.
*
*         NOTE   WHEN EXECUTION RESUMES AT *ADDR* FOR A FATAL ERROR,
*                FURTHER USE OF CH17 MAY NOT BE POSSIBLE.


          PURGMAC FATALMR

 FATALMR  MACRO  ADDR
          MACREF FATALMR
          LDC    ADDR
          STM    MRFN
 FATALMR  ENDM
 FUNCMR   SPACE  4,10
**        FUNCMR - FUNCTION MAINTENANCE CHANNEL.
*
*         FUNCMR PAC,FUNCTION
*
*         ENTRY  *PAC* = ADDRESS OF PORT ACCESS CODE FOR DESIRED
*                   ELEMENT.  *EC* IS ASSUMED IF NO PARAMETER IS GIVEN.
*                *FUNCTION* = FUNCTION TO SEND TO ELEMENT.
*
*         CALLS  CMI, SMI.


          PURGMAC FUNCMR

 FUNCMR   MACRO  PAC,FN
          MACREF FUNCMR
          LDK    FN
 .P       IFC    NE,$PAC$$
          LMM    PAC
 .P       ELSE
          LMD    EC
 .P       ENDIF
          RJM    SMI
          FAN    MR
          AJM    *,MR        WAIT FOR FUNCTION TO TAKE
          RJM    CMI
 FUNCMR   ENDM
 LOCKMR   SPACE  4,10
**        LOCKMR - SET OR CLEAR A LONG TERM INTERLOCK ON THE
*                MAINTENANCE CHANNEL.
*
*         LOCKMR OP,ADDR
*
*         ENTRY  *OP* = *SET* TO SET THE LONG TERM INTERLOCK.
*                *OP* = *CLEAR* TO CLEAR THE LONG TERM INTERLOCK.
*                *ADDR* = OPTIONAL ERROR EXIT ADDRESS.
*
*         CALLS  CLI, SLI.


          PURGMAC LOCKMR

 LOCKMR   MACRO  OP,ADDR
          MACREF LOCKMR
 .A       IFC    NE,$ADDR$$
          EXITMR ADDR
 .A       ENDIF
 .L       IFC    EQ,$OP$SET$
          RJM    SLI         SET LONG TERM INTERLOCK
 .L       ELSE
          IFC    NE,$OP$CLEAR$,1
          ERR                ILLEGAL OPTION ON *LOCKMR*
          RJM    CLI         CLEAR LONG TERM INTERLOCK
 .L       ENDIF
 LOCKMR   ENDM
 READMR   SPACE  4,15
**        READMR - READ MAINTENANCE REGISTER.
*
*         READMR A,PAC,REG,S
*
*         ENTRY  *A* = ADDRESS OF BUFFER FOR REGISTER DATA.
*                *PAC* = ADDRESS OF PORT ACCESS CODE FOR DESIRED
*                   ELEMENT.  *EC* IS USED IF PARAMETER OMITTED.
*                *REG* = REGISTER NUMBER.  IF OMITTED, THE REGISTER
*                   NUMBER IS OBTAINED FROM DIRECT CELL *RN*.
*                *S* = SIZE OF REGISTER IN WORDS.  ASSUMED TO BE 10.
*
*         EXIT   (A - A+S-1) = REGISTER DATA.
*                (RN) = REGISTER NUMBER.
*
*         CALLS  AMR, CMI.


          PURGMAC READMR

 READMR   MACRO  A,PAC,R,S
          MACREF  READMR
 .R       IFC    NE,$R$$
          LDK    R
          STD    RN
 .R       ENDIF
 .P       IFC    EQ,$PAC$$
          LDD    EC
 .P       ELSE
          LDM    PAC
 .P       ENDIF
          LMC    MRRD
          RJM    AMR
 .S       IFC    NE,$S$$
          LDN    S
 .S       ENDIF
          IAM    A,MR
          RJM    CMI         CLEAR INTERLOCK
 READMR   ENDM
 WRITMR   SPACE  4,15
**        WRITMR - WRITE MAINTENANCE REGISTER.
*
*         WRITMR A,PAC,REG,S
*
*         ENTRY  *A* = ADDRESS OF BUFFER OF REGISTER DATA.
*                *PAC* = ADDRESS OF PORT ACCESS CODE FOR DESIRED
*                   ELEMENT.  *EC* IS USED IF PARAMETER OMITTED.
*                *REG* = REGISTER NUMBER.  ASSUMED TO BE 10.
*                   NUMBER IS OBTAINED FROM DIRECT CELL *RN*.
*                *S* = SIZE OF REGISTER IN WORDS.  ASSUMED TO BE 10.
*
*         EXIT   DATA FROM (A - A+S-1) WRITTEN TO REGISTER.
*                (RN) = REGISTER NUMBER.
*
*         CALLS  AMR, CMI.


          PURGMAC WRITMR

 WRITMR   MACRO  A,PAC,R,S
          MACREF WRITMR
 .R       IFC    NE,$R$$
          LDK    R
          STD    RN
 .R       ENDIF
 .P       IFC    NE,$PAC$$
          LDM    PAC
 .P       ELSE
          LDD    EC
 .P       ENDIF
          LMC    MRWT
          RJM    AMR
 .S       IFC    NE,$S$$
          LDN    S
 .S       ENDIF
          OAM    A,MR
          RJM    WCC         WAIT FOR COMPLETE AND CHECK *SS* (FOR S0)
 WRITMR   ENDM
          SPACE  4
          ENDX
*DECK DECK=DSI$PACK_UNPACK_REGISTERS EXPAND=FALSE
          CTEXT  DSI$PACK UNPACK REGISTERS                               R152_OS        1
          SPACE  4                                                       R152_OS        2
 QUAL$    IF     -DEF,QUAL$                                              R152_OS        3
          QUAL   DSIPUR                                                  R152_OS        4
 QUAL$    ENDIF                                                          R152_OS        5
          BASE   M                                                       R152_OS        6
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992               SCW_1080       1
          SPACE  4,10                                                    R152_OS        8
***       DSI$PACK_UNPACK_REGISTERS                                      R152_OS        9
*         B. R. HANSON.      85/05/14.                                   R152_OS       10
          SPACE  4,10                                                    R152_OS       11
***              PROVIDES ROUTINES TO MANAGE THE MAINTENANCE REGISTER    R152_OS       12
*         BUFFERS.                                                       R152_OS       13
 GLOBAL   SPACE  4,10                                                    R152_OS       14
**        GLOBAL DATA.                                                   R152_OS       15
                                                                         R152_OS       16
                                                                         R152_OS       17
 RHDR     BSSZ   4           HEADER WORD                                 R152_OS       18
 MRVAL    BSSZ   4           BUFFER FOR PACKED DATA                      R152_OS       19
 RINX     CON    0           OFFSET TO MR BUFFER                         R152_OS       20
 PAC      SPACE  4,10                                                    R152_OS       21
**        PAC - PACK MAINTENANCE REGISTERS FROM HARDWARE BUFFER.         R152_OS       22
*                                                                        R152_OS       23
*         ENTRY  (RDATA) = REGISTER TO BE PACKED.                        R152_OS       24
*                                                                        R152_OS       25
*         EXIT   (MRVAL) = PACKED REGISTER.                              R152_OS       26
                                                                         R152_OS       27
                                                                         R152_OS       28
 PAC      SUBR               ENTRY/EXIT                                  R152_OS       29
          LDM    RDATA                                                   R152_OS       30
          SHN    10                                                      R152_OS       31
          LMM    RDATA+1                                                 R152_OS       32
          STML   MRVAL                                                   R152_OS       33
          LDM    RDATA+2                                                 R152_OS       34
          SHN    10                                                      R152_OS       35
          LMM    RDATA+3                                                 R152_OS       36
          STML   MRVAL+1                                                 R152_OS       37
          LDM    RDATA+4                                                 R152_OS       38
          SHN    10                                                      R152_OS       39
          LMM    RDATA+5                                                 R152_OS       40
          STML   MRVAL+2                                                 R152_OS       41
          LDM    RDATA+6                                                 R152_OS       42
          SHN    10                                                      R152_OS       43
          LMM    RDATA+7                                                 R152_OS       44
          STML   MRVAL+3                                                 R152_OS       45
          UJN    PACX        RETURN                                      R152_OS       46
 UPR      SPACE  4,10                                                    R152_OS       47
**        UPR - UNPACK REGISTER.                                         R152_OS       48
*                                                                        R152_OS       49
*         ENTRY  (MRVAL - MRVAL+3) = PACKED REGISTER.                    R152_OS       50
*                                                                        R152_OS       51
*         EXIT   (RDATA - RDATA+7) = UNPACKED REGISTER.                  R152_OS       52
                                                                         R152_OS       53
                                                                         R152_OS       54
 UPR      SUBR               ENTRY/EXIT                                  R152_OS       55
          LDML   MRVAL                                                   R152_OS       56
          STM    RDATA+1                                                 R152_OS       57
          SHN    -10                                                     R152_OS       58
          STM    RDATA                                                   R152_OS       59
          LDML   MRVAL+1                                                 R152_OS       60
          STM    RDATA+3                                                 R152_OS       61
          SHN    -10                                                     R152_OS       62
          STM    RDATA+2                                                 R152_OS       63
          LDML   MRVAL+2                                                 R152_OS       64
          STM    RDATA+5                                                 R152_OS       65
          SHN    -10                                                     R152_OS       66
          STM    RDATA+4                                                 R152_OS       67
          LDML   MRVAL+3                                                 R152_OS       68
          STM    RDATA+7                                                 R152_OS       69
          SHN    -10                                                     R152_OS       70
          STM    RDATA+6                                                 R152_OS       71
          UJN    UPRX        RETURN                                      R152_OS       72
 GNR      SPACE  4,10                                                    R152_OS       73
**        GNR - GET NEXT REGISTER.                                       R152_OS       74
*                                                                        R152_OS       75
*         ENTRY  (T2) = INDEX INTO REGISTER BUFFER.                      R152_OS       76
*                (RINX) = OFFSET TO MR BUFFER.                           R152_OS       77
*                                                                        R152_OS       78
*         EXIT   (RN) = REGISTER NUMBER.                                 R152_OS       79
*                (RDATA - RDATA+7) = REGISTER DATA.                      R152_OS       80
*                                                                        R152_OS       81
*         CALLS  IRI, UPR.                                               R152_OS       82
                                                                         R152_OS       83
                                                                         R152_OS       84
 GNR      SUBR               ENTRY/EXIT                                  R152_OS       85
          LDML   RINX                                                    R152_OS       86
          ADC    RR                                                      R152_OS       87
          CRML   RHDR,ON                                                 R152_OS       88
          ADD    T2                                                      R152_OS       89
          CRML   MRVAL,ON    FETCH REGISTER DATA                         R152_OS       90
          RJM    UPR         UNPACK REGISTER                             R152_OS       91
          LDML   RHDR,T2                                                 R152_OS       92
          STDL   RN                                                      R152_OS       93
          RJM    IRI         INCREMENT REGISTER INDEX                    R152_OS       94
          LDDL   RN                                                      R152_OS       95
          UJN    GNRX        RETURN                                      R152_OS       96
 SNR      SPACE  4,10                                                    R152_OS       97
**        SNR - STORE NEXT REGISTER.                                     R152_OS       98
*                                                                        R152_OS       99
*         ENTRY  (T2) = INDEX INTO REGISTER BUFFER.                      R152_OS      100
*                (RN) = REGISTER NUMBER.                                 R152_OS      101
*                (RINX) = OFFSET TO MR BUFFER.                           R152_OS      102
*                (RDATA - RDATA+7) = REGISTER DATA.                      R152_OS      103
*                                                                        R152_OS      104
*         EXIT   DATA IS STORED IN THE BUFFER.                           R152_OS      105
*                                                                        R152_OS      106
*         CALLS  IRI, PAC.                                               R152_OS      107
                                                                         R152_OS      108
                                                                         R152_OS      109
 SNR      SUBR               ENTRY/EXIT                                  R152_OS      110
          LDDL   RN          FETCH REGISTER NUMBER                       R152_OS      111
          STML   RHDR,T2                                                 R152_OS      112
          RJM    PAC         PACK REGISTER                               R152_OS      113
          LDML   RINX                                                    R152_OS      114
          ADC    RR                                                      R152_OS      115
          CWML   RHDR,ON                                                 R152_OS      116
          ADD    T2                                                      R152_OS      117
          CWML   MRVAL,ON    STORE REGISTER DATA                         R152_OS      118
          RJM    IRI         INCREMENT REGISTER INDEX                    R152_OS      119
          UJN    SNRX        RETURN                                      R152_OS      120
 IRI      SPACE  4,10                                                    R152_OS      121
**        IRI - INCREMENT REGISTER INDEX.                                R152_OS      122
*                                                                        R152_OS      123
*         ENTRY  (T2) = INDEX INTO REGISTER BUFFER.                      R152_OS      124
*                                                                        R152_OS      125
*         EXIT   (T2) = UPDATED.                                         R152_OS      126
*                                                                        R152_OS      127
*         CALLS  SRB.                                                    R152_OS      128
                                                                         R152_OS      129
                                                                         R152_OS      130
 IRI      SUBR               ENTRY/EXIT                                  R152_OS      131
          AOD    T2                                                      R152_OS      132
          LPN    3                                                       R152_OS      133
          STD    T2                                                      R152_OS      134
          NJN    IRIX        IF NO CHANGE                                R152_OS      135
          LDN    5                                                       R152_OS      136
          RAML   RINX        UPDATE INDEX                                R152_OS      137
          RJM    SRB                                                     R152_OS      138
          UJN    IRIX        RETURN                                      R152_OS      139
 SRB      SPACE  4,10                                                    R152_OS      140
**        SRB - SET UP REGISTER BUFFERS.                                 R152_OS      141
*                                                                        R152_OS      142
*         ENTRY  (A) = INDEX FROM R-REGISTER TO BUFFER.                  R152_OS      143
*                                                                        R152_OS      144
*         EXIT   (RHDR) = CLEARED.                                       R152_OS      145
*                (T2) = 0.                                               R152_OS      146
                                                                         R152_OS      147
                                                                         R152_OS      148
 SRB      SUBR               ENTRY/EXIT                                  R152_OS      149
          STML   RINX                                                    R152_OS      150
          LDN    0                                                       R152_OS      151
          STD    T2                                                      R152_OS      152
          STM    RHDR                                                    R152_OS      153
          STM    RHDR+1                                                  R152_OS      154
          STM    RHDR+2                                                  R152_OS      155
          STM    RHDR+3                                                  R152_OS      156
          UJN    SRBX        RETURN                                      R152_OS      157
          SPACE  4                                                       R152_OS      158
          BASE   *                                                       R152_OS      159
 QUAL$    IF     -DEF,QUAL$                                              R152_OS      160
          QUAL   *                                                       R152_OS      161
 GNR      EQU    /DSIPUR/GNR                                             R152_OS      162
 MRVAL    EQU    /DSIPUR/MRVAL                                           R152_OS      163
 PAC      EQU    /DSIPUR/PAC                                             R152_OS      164
 UPR      EQU    /DSIPUR/UPR                                             R152_OS      165
 SNR      EQU    /DSIPUR/SNR                                             R152_OS      166
 SRB      EQU    /DSIPUR/SRB                                             R152_OS      167
 QUAL$    ENDIF                                                          R152_OS      168
          ENDX                                                           R152_OS      169
*DECK DECK=DSI$PP_INSTRUCTION_MNEMONICS EXPAND=FALSE
          CTEXT  DSI$PP INSTRUCTION MNEMONICS.
          BASE   M
 PIM      SPACE  4,10
***       DSI$PP INSTRUCTION MNEMONICS.
*         P. D. KOCH.        80/10/09.
 PIM      SPACE  4,10
***              DEFINES THE MNEMONICS FOR ALL PERIPHERAL
*         PROCESSOR INSTRUCTIONS.  MNEMONICS ARE DEFINED IN
*         NUMERICAL ORDER.


 PSNI     EQU    0077        PASS
 LJMI     EQU    0100        LONG JUMP
 RJMI     EQU    0200        RETURN JUMP
 UJNI     EQU    0300        UNCONDITIONAL JUMP
 ZJNI     EQU    0400        ZERO JUMP
 NJNI     EQU    0500        NONZERO JUMP
 PJNI     EQU    0600        PLUS JUMP
 MJNI     EQU    0700        MINUS JUMP

 SHNI     EQU    1000        SHIFT
 LMNI     EQU    1100        LOGICAL DIFFERENCE
 LPNI     EQU    1200        LOGICAL PRODUCT
 SCNI     EQU    1300        SELECTIVE CLEAR
 LDNI     EQU    1400        LOAD
 LCNI     EQU    1500        LOAD COMPLEMENT
 ADNI     EQU    1600        ADD
 SBNI     EQU    1700        SUBTRACT

 LDCI     EQU    2000        LOAD CONSTANT
 ADCI     EQU    2100        ADD CONSTANT
 LPCI     EQU    2200        LOGICAL PRODUCT CONSTANT
 LMCI     EQU    2300        LOGICAL DIFFERENCE CONSTANT
 LRDI     EQU    2400        LOAD R-REGISTER DIRECT
 SRDI     EQU    2500        STORE R-REGISTER DIRECT
 EXNI     EQU    2600        EXCHANGE JUMP
 MXNI     EQU    2610        MONITOR EXCHANGE JUMP
 MANI     EQU    2620        MONITOR EXCHANGE JUMP TO (MA)
 ERNI     EQU    2700        EXTENDED READ STATUS (6416)
 KPTI     EQU    2700        KEYPOINT

 LDDI     EQU    3000        LOAD DIRECT
 ADDI     EQU    3100        ADD DIRECT
 SBDI     EQU    3200        SUBTRACT DIRECT
 LMDI     EQU    3300        LOGICAL DIFFERENCE DIRECT
 STDI     EQU    3400        STORE DIRECT
 RADI     EQU    3500        REPLACE ADD DIRECT
 AODI     EQU    3600        REPLACE ADD ONE DIRECT
 SODI     EQU    3700        REPLACE SUBTRACT ONE DIRECT

 LDII     EQU    4000        LOAD INDIRECT
 ADII     EQU    4100        ADD INDIRECT
 SBII     EQU    4200        SUBTRACT INDIRECT
 LMII     EQU    4300        LOGICAL DIFFERENCE INDIRECT
 STII     EQU    4400        STORE INDIRECT
 RAII     EQU    4500        REPLACE ADD INDIRECT
 AOII     EQU    4600        REPLACE ADD ONE INDIRECT
 SOII     EQU    4700        REPLACE SUBTRACT ONE INDIRECT

 LDMI     EQU    5000        LOAD MEMORY
 ADMI     EQU    5100        ADD MEMORY
 SBMI     EQU    5200        SUBTRACT MEMORY
 LMMI     EQU    5300        LOGICAL DIFFERENCE MEMORY
 STMI     EQU    5400        STORE MEMORY
 RAMI     EQU    5500        REPLACE ADD MEMORY
 AOMI     EQU    5600        REPLACE ADD ONE MEMORY
 SOMI     EQU    5700        REPLACE SUBTRACT ONE MEMORY

 CRDI     EQU    6000        CENTRAL READ DIRECT
 CRMI     EQU    6100        CENTRAL READ MEMORY
 CWDI     EQU    6200        CENTRAL WRITE DIRECT
 CWMI     EQU    6300        CENTRAL WRITE MEMORY
 AJMI     EQU    6400        ACTIVE CHANNEL JUMP
 SCFI     EQU    6440        TEST AND SET CHANNEL FLAG
 IJMI     EQU    6500        INACTIVE CHANNEL JUMP
 CCFI     EQU    6540        CLEAR CHANNEL FLAG
 FJMI     EQU    6600        FULL CHANNEL JUMP
 SFMI     EQU    6640        TEST AND CLEAR CHANNEL ERROR FLAG SET
 EJMI     EQU    6700        EMPTY CHANNEL JUMP
 CFMI     EQU    6740        TEST AND CLEAR CHANNEL ERROR FLAG CLEAR

 IANI     EQU    7000        INPUT BYTE FROM CHANNEL
 IAMI     EQU    7100        INPUT WORDS FROM CHANNEL
 OANI     EQU    7200        OUTPUT BYTE ON CHANNEL
 OAMI     EQU    7300        OUTPUT WORDS ON CHANNEL
 ACNI     EQU    7400        ACTIVATE CHANNEL
 DCNI     EQU    7500        DISCONNECT CHANNEL
 FANI     EQU    7600        FUNCTION CHANNEL
 FNCI     EQU    7700        FUNCTION CHANNEL

 RDSLI    EQU    100000      READ AND SET LOCK
 RDCLI    EQU    100100      READ AND CLEAR LOCK

 LPDLI    EQU    102200      LOGICAL PRODUCT
 LPILI    EQU    102300      LOGICAL PRODUCT
 LPMLI    EQU    102400      LOGICAL PRODUCT
 INPNI    EQU    102600      INTERRUPT PROCESSOR

 LDDLI    EQU    103000      LOAD DIRECT LONG
 ADDLI    EQU    103100      ADD DIRECT LONG
 SBDLI    EQU    103200      SUBTRACT DIRECT LONG
 LMDLI    EQU    103300      LOGICAL DIFFERENCE DIRECT LONG
 STDLI    EQU    103400      STORE DIRECT LONG
 RADLI    EQU    103500      REPLACE ADD DIRECT LONG
 AODLI    EQU    103600      REPLACE ADD ONE DIRECT LONG
 SODLI    EQU    103700      REPLACE SUBTRACT ONE DIRECT LONG

 LDILI    EQU    104000      LOAD INDIRECT LONG
 ADILI    EQU    104100      ADD INDIRECT LONG
 SBILI    EQU    104200      SUBTRACT INDIRECT LONG
 LMILI    EQU    104300      LOGICAL DIFFERENCE INDIRECT LONG
 STILI    EQU    104400      STORE INDIRECT LONG
 RAILI    EQU    104500      REPLACE ADD INDIRECT LONG
 AOILI    EQU    104600      REPLACE ADD ONE INDIRECT LONG
 SOILI    EQU    104700      REPLACE SUBTRACT ONE INDIRECT LONG

 LDMLI    EQU    105000      LOAD MEMORY LONG
 ADMLI    EQU    105100      ADD MEMORY LONG
 SBMLI    EQU    105200      SUBTRACT MEMORY LONG
 LMMLI    EQU    105300      LOGICAL DIFFERENCE MEMORY LONG
 STMLI    EQU    105400      STORE MEMORY LONG
 RAMLI    EQU    105500      REPLACE ADD MEMORY LONG
 AOMLI    EQU    105600      REPLACE ADD ONE MEMORY LONG
 SOMLI    EQU    105700      REPLACE SUBTRACT ONE MEMORY LONG

 CRDLI    EQU    106000      CENTRAL READ DIRECT LONG
 CRMLI    EQU    106100      CENTRAL READ MEMORY LONG
 CWDLI    EQU    106200      CENTRAL WRITE DIRECT LONG
 CWMLI    EQU    106300      CENTRAL WRITE MEMORY LONG
 TSJMI    EQU    106400      JUMP IF CHANNEL FLAG SET
 FCJMI    EQU    106500      JUMP IF CHANNEL FLAG CLEAR
 PIM      SPACE  4,10
          BASE   *
          ENDX
*DECK DECK=DSI$PP_MACROS EXPAND=FALSE
          CTEXT  DSI$PP MACROS.
 DSIPMAC  SPACE  4,10
***       DSI$PP MACROS.
*         G. R. MANSFIELD.  09/27/69.
*         W. E. GOEBEL.      78/07/12.
 DSIPMAC  SPACE  4,10
***              DEFINES SEVERAL MACROS WHICH ARE USED IN THE
*         SYSTEM PP PACKAGES.
 DSIPMAC  SPACE  4,10
***       SCRATCH SYMBOLS.
*
*
*         THE FOLLOWING SYMBOLS ARE USED IN MACROS FOR SCRATCH.
*         .1, .2, .3, .4, .5.


          NOREF  .1,.2,.3,.4
 MACREF   SPACE  4,10
**        MACREF - GENERATE MACRO SYMBOLIC REFERENCE TABLE LISTING.
*
*         CAUSES THE MACRO NAME TO BE LISTED IN THE SYMBOLIC
*         REFERENCE TABLE UNDER THE QUALIFIER *MACRO$*.
*
*         MACREF MNAME
*                MNAME    MACRO NAME FOR REFERENCE TABLE.


          PURGMAC  MACREF
 MACREF   MACRO  N
  QUAL MACRO$
N SET *
  QUAL *
  ENDM
 ADK      SPACE  4,10
***       ADK - ADD CONSTANT TO (A).
*
*         GENERATES EITHER AN *ADC*, *ADN*, OR *SBN* INSTRUCTION,
*         DEPENDING UPON THE VALUE OF THE OPERAND.  IF THE VALUE
*         OF THE OPERAND REDUCES TO ZERO, NO INSTRUCTION WILL BE
*         GENERATED.
*
*         ADK    K
*
*         ENTRY  K = CONSTANT TO BE ADDED TO (A).
*
*         NOTE   BECAUSE OF THE VARIABILITY OF THE CODE
*                GENERATED BY THIS MACRO, IT MUST NOT BE
*                CHANGED BY ON-LINE CODE MODIFICATION.


          PURGMAC  ADK
 ADK      MACRO  K
  LOCAL B
  IF DEF,K,10D
B SET K
  IFMI K,4
  IFGE K,-77B,7
  IFNE K,-0,7
  SBN -B
  SKIP 5
  IFLE K,77B,3
  IFNE K,0,3
  ADN K
  SKIP 1
  ADC K
 ADK      ENDM
 BITSET   SPACE  4,10
***       BITSET - GENERATE BIT CONSTANT.
*
*
*NAME     BITSET (P1,P2,...,PN)
*         ENTRY  *NAME* = NAME OF BIT CONSTANT.
*                (PN) = BITS TO SET.


          PURGMAC  BITSET
          MACRO  BITSET,N,P
N SET 0
  IRP P
.1 DECMIC P
N SET N+1S".1"
  IRP
  BSS     0
  ENDM
          SPACE  4,10
***       DEFINE ABSOLUTE MEMORY INSTRUCTIONS.
*
*
*         LJP    ADDRESS
*         RJP    ADDRESS
*         LDP    ADDRESS
*         ADP    ADDRESS
*         SBP    ADDRESS
*         LMP    ADDRESS
*         STP    ADDRESS
*         RAP    ADDRESS
*         AOP    ADDRESS
*         SOP    ADDRESS
*
*         DEFINE ABSOLUTE MEMORY INSTRUCTION FOR USE BY OTHER MACROS.
*         ENTRY  (ADDRESS) = ABSOLUTE MEMORY ADDRESS.


 LJP      PPOP   5,0100B
 RJP      PPOP   5,0200B
 LDP      PPOP   5,5000B
 ADP      PPOP   5,5100B
 SBP      PPOP   5,5200B
 LMP      PPOP   5,5300B
 STP      PPOP   5,5400B
 RAP      PPOP   5,5500B
 AOP      PPOP   5,5600B
 SOP      PPOP   5,5700B
 LDBC     SPACE  4,10
***       LDBC - LOAD (A) WITH BIT CONSTANT.
*
*
*         LDBC   (P1,P2,...,PN)
*         LOAD (A) WITH A CONSTANT CONTAINING BITS PN.


          PURGMAC  LDBC
 LDBC     MACRO  P
  .1 (P)
  LDK .1
  ENDM
 ADBC     SPACE  4,10
***       ADBC - ADD BIT CONSTANT TO (A).
*
*
*         ADBC   (P1,P2,...,PN)
*         ADD A CONSTANT CONTAINING BITS PN TO (A).


          PURGMAC  ADBC
 ADBC     MACRO  P
  .1 (P)
  ADK .1
  ENDM
 LPBC     SPACE  4,10
***       LPBC - LOGICAL PRODUCT BIT CONSTANT WITH (A).
*
*
*         LPBC   (P1,P2,...,PN)
*         LOGICAL PRODUCT OF (A) AND CONSTANT CONTAINING BITS PN.


          PURGMAC  LPBC
 LPBC     MACRO  P
  .1 (P)
  LPK .1
  ENDM
 LMBC     SPACE  4,10
***       LMBC - ADD BIT CONSTANT TO (A).
*
*
*         LMBC   (P1,P2,...,PN)
*         LOGICAL DIFFERENCE OF (A) AND CONSTANT CONTAINING BITS PN.


          PURGMAC  LMBC
 LMBC     MACRO  P
  .1 (P)
  LMK .1
  ENDM
 BSSN     SPACE  4,10
***       BSSN - SEQUENTIAL TAG DEFINITION WITHOUT RESERVING SPACE.
*
*
* BEGIN   BSSN   A           BEGIN TAG DEFINITION SEQUENCE
* TAG1    BSSN   N
* .       .      .
* .       .      .
*
* TAGN    BSSN   N
* END     BSSN               END TAG DEFINITION SEQUENCE
*
*         TO GET THE TAG VALUES PRINTED ON A LISTING A *LIST G*
*         CARD MUST BE PRESENT BEFORE THIS MACRO IS CALLED.
*
*                A = NUMBER TO START TAG DEFINITION AT.
*                N = NUMBER OF LOCATIONS RESERVED TO THIS TAG.


          PURGMAC  BSSN
          MACRO  BSSN,T,N
.1 IFC EQ,*T*BEGIN*
.2 IFC NE,*N**
  LOC N
.2 ELSE 1
  LOC 0
.3 SKIP
.1 ENDIF
.2 IFC EQ,*T*END*
  LOC *O
.3 SKIP
.2 ENDIF
  IFC NE,*T**,1
T EQU *
  LOC *+N
.3 ENDIF
  ENDM
 DEFC     SPACE  4,10
***       DEFC - CONDITIONALLY DEFINE SYMBOL.
*
*
* SYM     DEFC   VAL


          PURGMAC  DEFC
          MACRO  DEFC,SYM,VAL
  MACREF DEFC
  IF -DEF,SYM,1
 SYM = VAL
  ENDM
 DFIM     SPACE  4,10
***       DFIM - DEFINE INSTRUCTION MODIFICATION.
*
*TAG      DFIM   (OPC),ADR
*
*         ENTRY  *OPC* = COMPASS OP CODE AND VARIABLE FIELD.
*                *ADR* = ADDRESS TO BE MODIFIED WITH *OPC*.
*                      = * IF NOT SPECIFIED.
*                *TAG* = OPTIONAL LOCATION FIELD SYMBOL.
*
*         EXIT   *OPC* PLACED IN REMOTE BLOCK NAMED BY
*                *R$* MICRO (DEFAULT IS *SRMT*).


          PURGMAC  DFIM
          MACRO  DFIM,TAG,OPC,ADR
  LOCAL X,Y,Z
  MACREF DFIM
Z MICRO 1,, "QUAL"
X SET ADR *
Y EQU *O-*L+X
  IF -MIC,R$,1
R$ MICRO 1,4, SRMT
"R$" RMT
  IF DEF,"R$"A,1
  IFEQ "R$"A,10000,3
"R$" EQU *O
  QUAL
"R$"A SET 10000
  IFNE /"Z"/Y,"R$"A,4
"R$"B SET *O
"R$"C SET 0
  ORG *O+1
  CON /"Z"/Y
"R$"A SET /"Z"/Y
  QUAL "Z"
  LOC X+"R$"C
  IFC NE,$TAG$$,1
TAG BSS 0
  OPC
  QUAL
"R$"C SET *O-"R$"B-2
  ORG "R$"B
  CON "R$"C
  ORG *O+"R$"C+1
  RMT
 DFIM     ENDM
 DIMB     SPACE  4,10
***       DIMB - DUMP INSTRUCTION MODIFICATION BLOCK.
*
*         DIMB   BN
*
*         ENTRY  *BN* = NAME OF REMOTE BLOCK.
*                     = *SRMT* IF NOT SPECIFIED.


          PURGMAC  DIMB
 DIMB     MACRO  BN
  LOCAL Q
  MACREF DIMB
Q MICRO 1,, "QUAL"
  IFC EQ,*BN**,2
TN MICRO 1,4, SRMT
  ELSE 1
TN MICRO 1,, BN
  QUAL
  NOREF "TN"A,"TN"B,"TN"C
  QUAL *
"TN" HERE
  CON 0
"TN"A SET 10000
  QUAL "Q"
 DIMB     ENDM
 ISTORE   SPACE  4,15
***       ISTORE - INSTRUCTION STORE.
*
*         BUILDS AND STORES PP INSTRUCTION VIA IN-LINE CODE
*         MODIFICATION.  LOCATION TO BE MODIFIED MUST BE
*         PREVIOUSLY DEFINED.
*
*         ISTORE CADDR,(INSTR)
*
*         ENTRY  CADDR = ADDRESS OF CODE TO BE MODIFIED.
*                INSTR = INSTRUCTION (OPERATION CODE AND ADDRESS
*                        FIELD) TO BE STORED.


          PURGMAC  ISTORE
 ISTORE   MACRO  CADDR,INSTR
  MACREF ISTORE
  LDC **
  ORG *-1
  LOC CADDR
  INSTR
  LOC *O
  STM CADDR
 ISTORE   ENDM
 LDK      SPACE  4,10
***       LDK - LOAD CONSTANT INTO (A).
*
*         GENERATES EITHER A *LDC*, *LDN*, OR *LCN* INSTRUCTION,
*         DEPENDING UPON THE VALUE OF THE OPERAND.
*
*         LDK    K
*
*         ENTRY  K = CONSTANT TO BE LOADED INTO (A).
*
*         NOTE   BECAUSE OF THE VARIABILITY OF THE CODE
*                GENERATED BY THIS MACRO, IT MUST NOT BE
*                CHANGED BY ON-LINE CODE MODIFICATION.


          PURGMAC  LDK
 LDK      MACRO  K
  IF DEF,K,8D
  IFMI K,4
  IFGE K,-77B,6
.1 SET K
  LCN -.1
  SKIP 4
  IFLE K,77B,2
  LDN K
  SKIP 1
  LDC K
 LDK      ENDM
 LMK      SPACE  4,10
***       LMK - LOGICAL MINUS CONSTANT WITH (A).
*
*         GENERATES EITHER AN *LMC* OR AN *LMN* INSTRUCTION,
*         DEPENDING UPON THE VALUE OF THE OPERAND. IF THE
*         VALUE OF THE OPERAND REDUCES TO ZERO, NO INSTRUCTION
*         WILL BE GENERATED.
*
*         LMK    K
*
*         ENTRY  K = CONSTANT TO BE MINUSED WITH (A).
*
*         NOTE   BECAUSE OF THE VARIABILITY OF THE CODE
*                GENERATED BY THIS MACRO, IT MUST NOT BE
*                CHANGED BY ON-LINE CODE MODIFICATION.


          PURGMAC  LMK
 LMK      MACRO  K
  LOCAL B
  IF DEF,K,6
B SET K
  IFPL K,4
  IFLE K,77B,3
  IFNE K,0,3
  LMN K
  SKIP 1
  LMC K
 LMK      ENDM
 LPK      SPACE  4,10
***       LPK - LOGICAL PRODUCT CONSTANT WITH (A).
*
*         GENERATES EITHER AN *LPC*, *LPN*, OR *SCN* INSTRUCTION,
*         DEPENDING UPON THE VALUE OF THE OPERAND.  IF THE VALUE
*         OF THE OPERARND REDUCES TO ZERO, NO INSTRUCTION WILL BE
*         GENERATED.
*
*         LPK    K
*
*         ENTRY  K = CONSTANT TO BE *ANDED* WITH (A).
*
*         NOTE   BECAUSE OF THE VARIABILITY OF THE CODE
*                GENERATED BY THIS MACRO, IT MUST NOT BE
*                CHANGED BY ON-LINE CODE MODIFICATION.


          PURGMAC  LPK
 LPK      MACRO  K
  IF DEF,K,9D
  IFMI K,5
  IFGE K,-77B,7
  IFNE K,0,7
.1 SET K
  SCN -.1
  SKIP 4
  IFLE K,77B,2
  LPN K
  SKIP 1
  LPC K
 LPK      ENDM
 MDIN     SPACE  4,20
***       MDIN - MODIFY INSTRUCTIONS FROM REMOTE LIST.
*
*         MDIN   BN
*
*         ENTRY  *BN* = NAME OF REMOTE BLOCK.
*                    = *SRMT* IF NOT SPECIFIED.
*
*         EXIT   (A) = 0.
*
*         USES   T0 - T2.
*
*         FORMAT OF REMOTE BLOCK SEGMENT =
*
*                VFD    12  / BYTE COUNT (N).
*                VFD    12  / LOCATION FOR CODE.
*                VFD    N*12/ (N) BYTES OF CODE.


          PURGMAC  MDIN
 MDIN     MACRO  BN
  LOCAL L1,L2,L3
  MACREF MDIN
  IFC EQ,*BN**,2
TN MICRO 1,4, SRMT
  ELSE 1
TN MICRO 1,, BN
  LDC "TN"-1
  STD T1
  UJN L3

L1 STD T0
  AOD T1
  LDI T1
  STD T2
L2 AOD T1
  LDI T1
  STI T2
  AOD T2
  SOD T0
  NJN L2
L3 AOD T1
  LDI T1
  NJN L1
 MDIN     ENDM
 MJP      SPACE  4,10
***       MJP - CONDITIONAL NEGATIVE SHORT OR LONG JUMP.
*
*         GENERATES EITHER AN *MJN* OR THE EQUIVALENT LONG JUMP
*         SERIES, DEPENDING UPON THE VALUE OF THE ADDRESS FIELD,
*         AND UPON WHETHER THE ADDRESS HAS OR HAS NOT YET BEEN
*         DEFINED.
*
*         MJP    ADDR
*
*         ENTRY  ADDR = BRANCH ADDRESS.
*
*         NOTE   DISCRETION SHOULD BE EXERCISED IN THE USE OF
*                THIS MACRO AS IT WILL ALWAYS GENERATE A LONG
*                JUMP SEQUENCE WHEN BRANCHING FORWARD.


          PURGMAC  MJP
 MJP      MACRO  A
.J IF DEF,A
.J IFLE *-A,37B
  MJN A
.J ELSE
  PJN *+3
  LJM A
.J ENDIF
 MJP      ENDM
 NJP      SPACE  4,10
***       NJP - CONDITIONAL NONZERO SHORT OR LONG JUMP.
*
*         GENERATES EITHER AN *NJN* OR THE EQUIVALENT LONG JUMP
*         SERIES, DEPENDING UPON THE VALUE OF THE ADDRESS FIELD,
*         AND UPON WHETHER THE ADDRESS HAS OR HAS NOT YET BEEN
*         DEFINED.
*
*         NJP    ADDR
*
*         ENTRY  ADDR = BRANCH ADDRESS.
*
*         NOTE   DISCRETION SHOULD BE EXERCISED IN THE USE OF
*                THIS MACRO AS IT WILL ALWAYS GENERATE A LONG
*                JUMP SEQUENCE WHEN BRANCHING FORWARD.


          PURGMAC  NJP
 NJP      MACRO  A
.J IF DEF,A
.J IFLE *-A,37B
  NJN A
.J ELSE
  ZJN *+3
  LJM A
.J ENDIF
 NJP      ENDM
 OVERFLOW SPACE  4,20
***       OVERFLOW - TEST FOR PP MEMORY OVERFLOW.
*
*         THIS MACRO IS INTENDED TO TEST FOR PP MEMORY OVERFLOW WHEN
*         LOADING OVERLAYS FROM MASS STORAGE.  THIS MACRO SHOULD
*         BE PLACED AT THE END OF THE OVERLAY BEING TESTED.  IT REPORTS
*         AN OVERFLOW IF *+7 EXCEEDS *ADDR*.  SINCE PP-S ARE ASSEMBLED
*         ON THE C170 SIDE AND THEN MOVED TO THE C180 SIDE (60 BIT TO
*         64 BIT CONVERSION), THE +7 ACCOUNTS FOR THE WORST CASE FILL
*         THAT MAY BE REQUIRED TO MAKE A 64 BIT WORD.
*
*         OVERFLOW ADDR
*
*         ENTRY  ADDR = ADDRESS THAT IS NOT TO BE DESTROYED.  (I.E.
*                   LWA+1 OF AREA BEING LOADED INTO.)
*
*         NOTE.  THIS MACRO USES A *USE OVERFLOW* PSEUDO OP TO FORCE
*                THE LITERALS BLOCK TO BE DEFINED.  IF THE PROGRAM HAS
*                A USE BLOCK CALLED *OVERFLOW* THE TEST WILL BE
*                INCORRECT.


          PURGMAC  OVERFLOW

 OVERFLOW MACRO  ADDR
          MACREF OVERFLOW
          USE    OVERFLOW
          LIST   M
          ERRPL  *+7-ADDR    CODE OVERFLOWS INTO *ADDR*
          LIST   *
 OVERFLOW ENDM
 PJP      SPACE  4,10
***       PJP - CONDITIONAL POSITIVE SHORT OR LONG JUMP.
*
*         GENERATES EITHER A *PJN* OR THE EQUIVALENT LONG JUMP
*         SERIES, DEPENDING UPON THE VALUE OF THE ADDRESS FIELD,
*         AND UPON WHETHER THE ADDRESS HAS OR HAS NOT YET BEEN
*         DEFINED.
*
*         PJP    ADDR
*
*         ENTRY  ADDR = BRANCH ADDRESS.
*
*         NOTE   DISCRETION SHOULD BE EXERCISED IN THE USE OF
*                THIS MACRO AS IT WILL ALWAYS GENERATE A LONG
*                JUMP SEQUENCE WHEN BRANCHING FORWARD.


          PURGMAC  PJP
 PJP      MACRO  A
.J IF DEF,A
.J IFLE *-A,37B
  PJN A
.J ELSE
  MJN *+3
  LJM A
.J ENDIF
 PJP      ENDM
 SBK      SPACE  4,10
***       SBK - SUBTRACT CONSTANT FROM (A).
*
*         GENERATES EITHER AN *ADC*, *SBN*, OR *ADN* INSTRUCTION,
*         DEPENDING UPON THE VALUE OF THE OPERAND.  IF THE VALUE
*         OF THE OPERAND REDUCES TO ZERO, NO INSTRUCTION WILL BE
*         GENERATED.
*
*         SBK    K
*
*         ENTRY  K = CONSTANT TO BE SUBTRACTED FROM (A).
*
*         NOTE   BECAUSE OF THE VARIABILITY OF THE CODE
*                GENERATED BY THIS MACRO, IT MUST NOT BE
*                CHANGED BY ON-LINE CODE MODIFICATION.


          PURGMAC  SBK
 SBK      MACRO  K
  LOCAL B
  IF DEF,K,3
.1 SET K
  ADK -.1
  SKIP 5
  RMT
B EQU K
  RMT
.1 MICRO 1,,*B*
  ADC -".1"
 SBK      ENDM
 SUBR     SPACE  4,10
***       SUBR - DEFINE SUBROUTINE ENTRY/EXIT LINE.
*
*
*NAME     SUBR
*         DECLARE *NAME* TO BE THE ENTRY POINT TO A PP SUBROUTINE.
*         THIS SUBROUTINE IS ENTERED VIA RETURN JUMP TO *NAME*.
*
*         THE FOLLOWING CODE IS GENERATED -
*NAMEX    LJM    *
*NAME     EQU    *-1


          PURGMAC  SUBR
          MACRO  SUBR,A
A_X LJP *
A EQU *-1
  ENDM
 UJP      SPACE  4,10
***       UJP - UNCONDITIONAL SHORT OR LONG JUMP.
*
*         GENERATES EITHER A *UJN* OR AN *LJM* INSTRUCTION,
*         DEPENDING UPON THE VALUE OF THE ADDRESS FIELD,
*         AND UPON WHETHER THE ADDRESS HAS OR HAS NOT YET
*         BEEN DEFINED.
*
*         UJP    ADDR
*
*         ENTRY  ADDR = BRANCH ADDRESS.
*
*         NOTE   DISCRETION SHOULD BE EXERCISED IN THE USE OF
*                THIS MACRO AS IT WILL ALWAYS GENERATE A LONG
*                JUMP SEQUENCE WHEN BRANCHING FORWARD.


          PURGMAC  UJP
 UJP      MACRO  A
.J IF DEF,A
.J IFLE *-A,37B
  UJN A
.J ELSE
  LJM A
.J ENDIF
 UJP      ENDM
 ZJP      SPACE  4,10
***       ZJP - CONDITIONAL ZERO SHORT OR LONG JUMP.
*
*         GENERATES EITHER A *ZJN* OR THE EQUIVALENT LONG JUMP
*         SERIES, DEPENDING UPON THE VALUE OF THE ADDRESS FIELD,
*         AND UPON WHETHER THE ADDRESS HAS OR HAS NOT YET BEEN
*         DEFINED.
*
*         ZJP    ADDR
*
*         ENTRY  ADDR = BRANCH ADDRESS.
*
*         NOTE   DISCRETION SHOULD BE EXERCISED IN THE USE OF
*                THIS MACRO AS IT WILL ALWAYS GENERATE A LONG
*                JUMP SEQUENCE WHEN BRANCHING FORWARD.


          PURGMAC  ZJP
 ZJP      MACRO  A
.J IF DEF,A
.J IFLE *-A,37B
  ZJN A
.J ELSE
  NJN *+3
  LJM A
.J ENDIF
 ZJP      ENDM
 .1       SPACE  4,10
**        .1 - GENERATE BIT CONSTANT.
*
*
*         .1     (P1,P2,...,PN)
*         ENTRY  (PN) = BIT CONSTANT TO SET.


          PURGMAC  .1
 .1       MACRO  P
.1 SET 0
  IRP P
.2 DECMIC P
.1 SET .1+1S".2"
  IRP
  ENDM
 BITCON   SPACE  4,10
***       BITCON - SET BIT CONSTANT.
*
*
*         BITCON (P1,P2,...,PN)
*         ENTRY  (PN) = BIT NUMBERS TO SET.


          PURGMAC  BITCON
 BITCON   MACRO  P
  NOREF   .1
.1 BITSET (P)
  CON .1
  ENDM
 INDEX    SPACE  4,10
***       INDEX - GENERATE INDEXED TABLE.
*
*
*NAME     INDEX  TYPE,ADDRESS
*         THIS MACRO IS INTENDED TO GENERATE TABLES WHICH ARE INDEXED
*         BY SYMBOLIC CONSTANTS SUCH AS FILE AND JOB ORIGIN CODES.
*         IT HAS 3 CALLING SEQUENCES.
*         IF *NAME* IS PRESENT, THE FWA OF THE TABLE IS SET TO *NAME*.
*
*         IF *ADDRESS* IS MISSING, THE TABLE IS TERMINATED WITH AN
*         *ORG* TO THE END OF THE TABLE.  THIS RESULTS IN ZERO ENTRIES
*         FOR UNDEFINED ENTRIES IN THE TABLE.
*
*         OTHERWISE, A TABLE ENTRY IS MADE AT *INDEX* + *TYPE* OF
*         *ADDRESS*.
*
*         EXAMPLE - TO GENERATE A TABLE FOR PROCESSING FILE TYPES.
*
*TFTP     INDEX              BEGIN TABLE
*
*         INDEX  PRFT,PRP    PROCESS PRINT FILE AT *PRP*
*         INDEX  LOFT,LOP    PROCESS LOCAL FILE AT *LOP*
*
*         INDEX  MXFT        TERMINATE TABLE AT *TFTP*+*MXFT*
*
*         THE CODE PROCESSING THIS TABLE NOTES THAT -
*         A FILE TYPE \ *MXFT* CANNOT BE PROCESSED,
*         A TABLE ENTRY = 0, CANNOT BE PROCESSED.
*
*         USES   SYMBOL NAME *INDEX*.
*         CALLS  NONE.


          PURGMAC  INDEX
          MACRO  INDEX,A,B,C
  IFC NE,$A$$
A BSS 0
.2 SET A
  ELSE 5
  ORG .2+B
  IFC NE,$C$$,2
  LOC B
  CON C
  BSS 0
  ENDM
 ASCII    SPACE  4,10
***       ASCII - DEFINE ASCII DATA.
*
*         ASCII  (ASCII STRING),SIZE


          PURGMAC  ASCII
 ASCII    MACRO  STRING,SIZE
    LOCAL  C,CH,CV,SZ,FW,LC,SH
    CODE N
 CH MICRO  1,,$STRING$
 SZ MICCNT CH
 SH SET 2Ra/0#100
 C  SET 1
 LC SET 0
 FW SET SIZE 8D
    DUP SZ
 CH MICRO  C,1,$STRING$
 CV SET 1R"CH"
 .2 IFEQ CV,SH
 LC SET 0#20
 .2 ELSE
    VFD FW/CV+LC
 LC SET 0
 .2 ENDIF
 C  SET C+1
    ENDD
    VFD 8/0
    BSS 0
    CODE *
          ENDM
 SSRE     SPACE  4,10
**        SSRE - FETCH SSR ENTRY.
*
*         SSRE NAME


          PURGMAC  SSRE
 SSRE     MACRO  NAME
  LOCAL C
  CODE N
  LDC =4R_NAME
  RJM FSE
  CODE *
          ENDM
 FINDCM   SPACE  4,10
***       FINDCM - FIND CIP MODULE.
*
*         FINDCM  (MODULE NAME)


          PURGMAC  FINDCM
 FINDCM   MACRO  NAME
  CODE D
  LDC  =C*NAME*
  RJM  FCM
  CODE *
          ENDM
 OVERLAY  SPACE  4,10
**        OVERLAY - DEFINE OVERLAY TITLE AND LOAD ADDRESS
*
*         OVERLAY  (DESCRIPTION),LOAD ADDRESS


          PURGMAC  OVERLAY
 ALPHABET MICRO  1,25,*ABCDEFGHIJKLMNOP*
 SCI      MICRO  1,4,*SCIO*
 DFT      MICRO  1,4,*DFTO*
 PRGMS    MICRO  1,,*"SCI""DFT"*
 OVERLAY  MACRO  DESC,LOADADD
          LOCAL  AD
          QUAL   *
          NOREF  OVLN
 OVLL     SET    OVLL+1
          IFEQ   OVLL,21,2
 OVLL     SET    1
 OVLU     SET    OVLU+1
 OVLN     SET    OVLU*20+OVLL-21
 PRGNAM   MICRO  PRGM*4-3,4,*"PRGMS"*
 CHL      MICRO  OVLL,1,*"ALPHABET"*
 CHU      MICRO  OVLU,1,*"ALPHABET"*
 NU       OCTMIC OVLN,2
 AD       OCTMIC LOADADD OVLA
          TITLE  "PRGNAM""CHU""CHL" ("NU") - DESC.
          IDENT  "PRGNAM""CHU""CHL","AD"  "NU"  DESC
          QUAL   "PRGNAM""CHU""CHL"
          ORG    "AD"
          ENDM
 OVLL     SET    1           INITIALIZE OVERLAY NUMBER
 OVLU     SET    1
 ROUTINE  SPACE  4,10
***       ROUTINE - SET UP CALL TO AN OVERLAY ROUTINE.
*
*         RNAME  ROUTINE.
*
*         MACRO WHICH ESTABLISHES AN ENTRY POINT FOR THE CALL MACRO.
*
*         RNAME  = NAMED ENTRY POINT.


          PURGMAC  ROUTINE
          MACRO  ROUTINE,RNAME
          QUAL
 RNAME    BSS    0
 RNAME_O  EQU    OVLN
          QUAL   *
 RNAME_X  EQU    LNOF
          ENDM
 CALL     SPACE  4,10
**        CALL - CALL A SUBROUTINE BY FIRST LOADING ITS OVERLAY.
*
*         GIVES CONTROL TO A ROUTINE IN THE SAME OR DIFFERENT
*         OVERLAY.  WHEN THAT ROUTINE COMPLETES CONTROL RETURNS
*         TO THE STATEMENTS FOLLOWING THIS MACRO.
*
*         PARAMETERS:
*         RTN    = NAME OF CORRESPONDING ROUTINE TO CALL.


          PURGMAC  CALL
 CALL     MACRO  NAME
          LDC    NAME+NAME_O*10000
          RJM    LNO
          ENDM
 EQUAL    SPACE  4,10
***       EQUAL - SET UP EQUATE FOR QUALIFIER
*
*         PNAME  EQUAL


          PURGMAC  EQUAL
          MACRO  EQUAL,PNAME
          QUAL   *
 PNAME    EQU    /"PRGNAM""CHU""CHL"/PNAME
          ENDM
          ENDX
*DECK DECK=DSI$PP_SSR_INTERFACE EXPAND=FALSE
          CTEXT  DSI$PP SSR INTERFACE
          SPACE  4,10
 QUAL$    IF     -DEF,QUAL$
          QUAL   DSIPSI
 QUAL$    ENDIF
          BASE   M
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 DSIPSI   SPACE  4,10
***       DSI$PP_SSR_INTERFACE.
*         B. R. HANSON       85/05/14.
 DSIPSI   SPACE  4,10
***       DSI$PP SSR INTERFACE CONTAINS THE ROUTINES
*         NECESSARY TO ACCESS IN THE SSR.
*
*         THIS DECK REQUIRES THAT THE USER HAVE THE FOLLOWING
*         ADDRESSES DEFINED IN THE MAIN PROGRAM.
*
*         T2      : ANY DIRECT CELL.
*         W0 - W5 : DIRECT CELLS IN CONTIGUOUS ORDER.
*         SA, SA+1: TWO CONTIGUOUS DIRECT CELLS TO CONTAIN THE R-REGISTER
*                   FOR THE SSR ADDRESS.
*         SAAO    : A MEMORY LOCATION TO CONTAIN THE OFFSET FROM THE
*                   R-REGISTER.
*
*         THE *IIB* ROUTINE IN THE COMMON DECK DSI$PP UTILITY SUBROUTINES
*         IS ALSO REQUIRED.
 FSE      SPACE  4,10
**        FSE - FIND SSR ENTRY.
*
*         ENTRY  (A) = ADDRESS OF SSR NAME IN ASCII.
*
*         EXIT   (A) = ADDRESS OF SSR ENTRY BLOCK.
*                (W1) = WORD OFFSET OF ENTRY IN SSR.
*                (W2 - W5) = SSR ENTRY.
*
*         USES   T2, W1 - W5.
*
*         CALLS  INS.


 FSE1     LDDL   W5          FETCH BLOCK OFFSET
          RJM    INS         PREPARE FOR CM READ/WRITE

 FSE      SUBR               ENTRY/EXIT
          STDL   T2
          LDN    0
          STD    W1
 FSE2     RJM    INS         FETCH SSR ENTRY
          CRDL   W2
          LDDL   W2
          SBIL   T2
          ADDL   W3
          SBML   1,T2
          ZJN    FSE1        IF MATCH
          AOD    W1
          UJN    FSE2        CHECK NEXT ENTRY
 INS      SPACE  4,10
**        INS - INCREMENT SSR ADDRESS.
*
*         ENTRY  (A) = 16-BIT INCREMENT.
*                (SA - SA) = SSR DIRECTORY ADDRESS (BASE).
*                (SAAO) = OFFSET FROM R-REGISTER.
*
*         EXIT   (A) = PARTIAL ADDRESS (RAR OVERFLOW).
*                (RAR) = RELOCATION VALUE.
*
*         USES   NONE.


 INS      SUBR               ENTRY/EXIT
          LRD    SA
          ADM    SAAO
          ADC    400000B
          UJN    INSX        EXIT
 SSR      SPACE  4,10
**        SSR - SET UP SSR RMA POINTER.
*
*         EXIT   (A) = 0, IF SSR NOT READY.
*                (A) = 1, IF SSR READY.
*                (SAAO) = OFFSET TO SSR FROM R-REGISTER.
*                (SA - SA+1) = SSR R-REGISTER VALUE.
*
*         USES   W0 - W3.
*
*         CALLS  IIB.


 SSR      SUBR               ENTRY/EXIT
          LDN    D8SSR
          RJM    IIB         INDEX FROM INTERFACE BLOCK
          CRDL   W0
          LDD    W0          FETCH OFFSET FROM R
          STM    SAAO
          LRD    W1          FETCH R-REGISTER
          SRD    SA
          UJN    SSRX        RETURN
          SPACE  4,10
          BASE   *
 QUAL$    IF     -DEF,QUAL$
          QUAL   *
 FSE      EQU    /DSIPSI/FSE
 INS      EQU    /DSIPSI/INS
 SSR      EQU    /DSIPSI/SSR
 QUAL$    ENDIF
          ENDX
*DECK DECK=DSI$PP_UTILITY_SUBROUTINES EXPAND=FALSE
          CTEXT  DSI$PP UTILITY SUBROUTINES                              R123_OS        1
          SPACE  4                                                       R123_OS        2
 QUAL$    IF     -DEF,QUAL$                                              R123_OS        3
          QUAL   DSIPUS                                                  R123_OS        4
 QUAL$    ENDIF                                                          R123_OS        5
          BASE   M                                                       R123_OS        6
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992               SCW_1080       1
          SPACE  4                                                       R123_OS        8
***       DSI$PP_UTILITY_SUBROUTINES.                                    R123_OS        9
*         B. R. HANSON       85/05/14.                                   R123_OS       10
          SPACE  4                                                       R123_OS       11
***              PROVIDES ROUTINES OF GENERAL UTILITY.                   R123_OS       12
*                                                                        R123_OS       13
 SCF      SPACE  4,10                                                    R123_OS       14
**        SCF - SET CHANNEL FLAG.                                        R123_OS       15
*                                                                        R123_OS       16
*         ENTRY  (A) = CHANNEL NUMBER.                                   R123_OS       17
*                                                                        R123_OS       18
*         EXIT   CHANNEL FLAG SET FOR SPECIFIED CHANNEL.                 R123_OS       19
*                                                                        R123_OS       20
*         USES   NONE.                                                   R123_OS       21
                                                                         R123_OS       22
                                                                         R123_OS       23
 SCF      SUBR               ENTRY/EXIT                                  R123_OS       24
          LMC    6440                                                    R123_OS       25
          STM    SCFA        MODIFY SCF INSTRUCTION                      R123_OS       26
 SCF1     SCF    SCF3,MR     ACCESS MAINTENANCE CHANNEL                  R123_OS       27
 SCFA     SCF    SCF2,**     TEST AND SET FLAG FOR CHANNEL               R123_OS       28
          CCF    *,MR        CLEAR MAINTENANCE CHANNEL FLAG              R123_OS       29
          UJN    SCFX        RETURN                                      R123_OS       30
                                                                         R123_OS       31
 SCF2     CCF    *,MR        CLEAR MAINTENANCE CHANNEL INTERLOCK         R123_OS       32
 SCF3     LDN    77                                                      R123_OS       33
          SBN    1                                                       R123_OS       34
          PJN    *-1                                                     R123_OS       35
          UJN    SCF1        TRY ACCESS AGAIN                            R123_OS       36
 STA      SPACE  4,10                                                    R123_OS       37
**        STA     - SET TRANSFER ADDRESS.                                R123_OS       38
*                                                                        R123_OS       39
*         ADDRESS AND RAR REGISTER ARE SET FOR TRANSFER                  R123_OS       40
*         OVER 256K RMA.                                                 R123_OS       41
*                                                                        R123_OS       42
*         ENTRY  W2 - W3)= 32 BIT TRANSFER ADDRESS.                      R123_OS       43
*                                                                        R123_OS       44
*         EXIT   (A)      = OFFSET FROM R-REGISTER.                      R123_OS       45
*                (W4 - W5)= R-REGISTER VALUE.                            R123_OS       46
*                (W6)     = OFFSET FROM R-REGISTER.                      R123_OS       47
*                                                                        R123_OS       48
*         USES   W4 - W6.                                                R123_OS       49
                                                                         R123_OS       50
                                                                         R123_OS       51
 STA      SUBR                                                           R123_OS       52
          LDDL   W3                                                      R123_OS       53
          LPN    77         MAKE RAR(0-5) BITS                           R123_OS       54
          STD    W6         SAVE RAR OVERFLOW                            R123_OS       55
          LDDL   W3                                                      R123_OS       56
          SHN    -6         LOWER 10 BITS OF RAR                         R123_OS       57
          STD    W5                                                      R123_OS       58
          LDDL   W2         UPPER 16 BITS                                R123_OS       59
          LPN    3          GET LOWER 2 BITS                             R123_OS       60
          SHN    12                                                      R123_OS       61
          RAD    W5         MAKE LOWER 12 BITS OF RAR                    R123_OS       62
          LDDL   W2         UPPER 16 BITS                                R123_OS       63
          SHN    -2                                                      R123_OS       64
          STD    W4         UPPER 10D RAR BITS                           R123_OS       65
          LRD    W4         LOAD TRANSFER RAR                            R123_OS       66
          LDD    W6         LOAD PARTIAL TRANSFER ADDRESS                R123_OS       67
          UJN    STAX                                                    R123_OS       68
 IIB      SPACE  4,10                                                    R123_OS       69
**        IIB - INDEX INTERFACE BLOCK.                                   R123_OS       70
*                                                                        R123_OS       71
*         ENTRY  (A) = OFFSET INTO INTERFACE BLOCK.                      R123_OS       72
*                                                                        R123_OS       73
*         EXIT   (A) = RMA OF DESIRED WORD IN BLOCK.                     R123_OS       74
*                                                                        R123_OS       75
*         USES   NONE.                                                   R123_OS       76
                                                                         R123_OS       77
                                                                         R123_OS       78
 IIB      SUBR               ENTRY/EXIT                                  R123_OS       79
          ADDL   IB                                                      R123_OS       80
          LRD    IB+1                                                    R123_OS       81
          ADC    400000      ACTIVATE R-REGISTER                         R123_OS       82
          UJN    IIBX        RETURN                                      R123_OS       83
 PIB      SPACE  4,10                                                    R123_OS       84
          USE    PRESET                                                  R123_OS       85
                                                                         R123_OS       86
**        PIB - PREPARE INTERFACE BLOCK.                                 R123_OS       87
*                                                                        R123_OS       88
*         EXIT   (IB - IB+2) = R-REGISTER CONSTRUCT TO ACCESS EICB.      R123_OS       89
*                            = UNCHANGED IF EICB ADDRESS INVALID.        KAP_25         1
*                                                                        R123_OS       90
*         USES   T1 - T4.                                                R123_OS       91
                                                                         R123_OS       92
                                                                         R123_OS       93
 PIB      SUBR               ENTRY/EXIT                                  R123_OS       94
          LDN    EICBP                                                   R123_OS       95
          CRDL   T1                                                      R123_OS       96
          LDDL   T3                                                      R123_OS       97
          STDL   W2                                                      R123_OS       98
          NJN    PIBX        IF NOT VALID ADDRESS (TOO LARGE)            KAP_25         2
          LDDL   T4                                                      R123_OS       99
          STDL   W3                                                      R123_OS      100
          RJM    STA                                                     R123_OS      101
          STD    IB                                                      R123_OS      102
          SRD    IB+1                                                    R123_OS      103
          UJN    PIBX        RETURN                                      R123_OS      104
                                                                         R123_OS      105
          USE    *                                                       R123_OS      106
          SPACE  4                                                       R123_OS      107
          BASE   *                                                       R123_OS      108
 QUAL$    IF     -DEF,QUAL$                                              R123_OS      109
          QUAL   *                                                       R123_OS      110
 IIB      EQU    /DSIPUS/IIB                                             R123_OS      111
 PIB      EQU    /DSIPUS/PIB                                             R123_OS      112
 SCF      EQU    /DSIPUS/SCF                                             R123_OS      113
 STA      EQU    /DSIPUS/STA                                             R123_OS      114
 QUAL$    ENDIF                                                          R123_OS      115
          ENDX                                                           R123_OS      116
*DECK DECK=DSI$RECORD_BUFFER_DET EXPAND=FALSE
          TITLE  DSI$RECORD BUFFER DET                                   R152_OS        1
          SPACE  4,10                                                    R152_OS        2
*         PSEUDO REGISTERS, USED AS CONTROL VALUES.                      R152_OS        3
                                                                         R152_OS        4
 RN.NULL  EQU    0#FF        NULL REGISTER DEFINITION FF(16)             R152_OS        5
 RN.PRST  EQU    0#FFE       BUFFER VALUES PRESET FFE(16)                R152_OS        6
 RN.ERR   EQU    0#FFF       ERROR REGISTER DEFINITION FFF(16)           R152_OS        7
          SPACE  4,10                                                    R152_OS        8
*         WRD OFFSETS INTO RECORD BUFFER (RECBFR)                        R152_OS        9
                                                                         R152_OS       10
 RECBFR   BSS    0                                                       R152_OS       11
 RDATA    BSS    10B         MAINTENANCE REGISTER VALUE                  R152_OS       12
 RNBR     CON    0           REGISTER NUMBER                             R152_OS       13
 RCODE    CON    0           REGISTER OPERATION/ SIZE                    R152_OS       14
 RBFRL    EQU    2                                                       R152_OS       15
 ZRECB    SPACE  4,10                                                    R152_OS       16
**        ZERCB - ZERO RECORD BUFFER.                                    R152_OS       17
*                                                                        R152_OS       18
                                                                         R152_OS       19
                                                                         R152_OS       20
 ZRECB    SUBR               ENTRY/EXIT                                  R152_OS       21
          LDN    0                                                       R152_OS       22
          STD    T5                                                      R152_OS       23
 ZRECB1   BSS    0                                                       R152_OS       24
          LDN    0                                                       R152_OS       25
          STM    RDATA,T5                                                R152_OS       26
          AOD    T5                                                      R152_OS       27
          LMN    8D                                                      R152_OS       28
          NJN    ZRECB1                                                  R152_OS       29
          UJN    ZRECBX      RETURN                                      R152_OS       30
*DECK DECK=DSI$REDEFINE_IO_INSTRUCTIONS EXPAND=FALSE
          CTEXT  DSI$REDEFINE IO INSTRUCTIONS.
          SPACE  4,10
          BASE   M
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 COMPCHI  SPACE  4
***       DSI$REDEFINE IO INSTRUCTIONS.
*         G. R. MANSFIELD.  70/10/04.
 COMPCHI  SPACE  4
***              REDEFINES THE I/O INSTRUCTIONS TO PRODUCE
*         A CHANNEL TABLE BY REMOTE CODE.
*
*         IF *RICHI$* IS UNDEFINED, THE CHANNEL INSTRUCTIONS WILL BE
*         REDEFINED AT THE TIME *COMPCHI* IS ASSEMBLED AND THE MACRO
*         *RICHI* WILL NOT BE CREATED.  IF *RICHI$* IS DEFINED,
*         HOWEVER, THE MACRO *RICHI* WILL BE CREATED AND INSTRUCTION
*         REDEFINITION WILL NOT TAKE PLACE UNTIL *RICHI* IS CALLED.
*         THE MACROS *RICHI* AND *RSTC* CAN BE USED TO ENABLE OR
*         DESABLE INSTRUCTION REDEFINITION.
*
*         ORIGINAL FORM MAY BE USED BY APPENDING A *.* TO THE ORIGINAL
*         OPCODE.
*
*         INSTRUCTIONS REDEFINED -
*                AJM
*                IJM
*                FJM
*                EJM
*                IAM
*                OAM
*                SCF
*                CCF
*                SFM
*                CFM
*                FNC
*                IAN
*                OAN
*                ACN
*                DCN
*                FAN
 CHIM     SPACE  4
**        CHIM - REDEFINE M-TYPE CHANNEL INSTRUCTIONS.
*
*
*         CHIM   OPC,CODE
*         ENTRY  *OPC* = INSTRUCTION MNEMONIC.
*                *CODE* = OPERATION CODE.


          PURGMAC CHIM
 CHIM     MACRO  OPC,CODE
          PURGMAC OPC
 OPC.     PPOP   7,CODE
 OPC      MACRO  M,D
          LOCAL  A
 A        OPC.   M,D
          RMT
          CON    A
          RMT
 OPC      ENDM
 CHIM     ENDM
 CHIN     SPACE  4
**        CHIN - REDEFINE N-TYPE CHANNEL INSTRUCTIONS.
*
*
*         CHIN   OPC,CODE
*         ENTRY  *OPC* = INSTRUCTION MNEMONIC.
*                *CODE* = OPERATION CODE.


          PURGMAC CHIN
 CHIN     MACRO  OPC,CODE
          PURGMAC OPC
 OPC.     PPOP   4,CODE
 OPC      MACRO  D
          LOCAL  A
 A        OPC.   D
          RMT
          CON    A
          RMT
 OPC      ENDM
 CHIN     ENDM
 RICHI    SPACE  4
***       RICHI - REDEFINE CHANNEL INSTRUCTIONS.
*
*         RICHI
*         EACH TIME *RICHI* IS CALLED, INSTRUCTION REDEFINITION OCCURS.
*         *RICHI* IS CREATED ONLY IF *RICHI$* IS DEFINED.


          IF     DEF,RICHI$,2
          PURGMAC RICHI
 RICHI    MACRO

          CHIM   AJM,6400
          CHIM   SCF,6440
          CHIM   IJM,6500
          CHIM   CCF,6540
          CHIM   FJM,6600
          CHIM   SFM,6640
          CHIM   EJM,6700
          CHIM   CFM,6740
          CHIM   IAM,7100
          CHIM   OAM,7300
          CHIM   FNC,7700

          CHIN   IAN,7000
          CHIN   OAN,7200
          CHIN   ACN,7400
          CHIN   DCN,7500
          CHIN   FAN,7600

          ENDM
 CHTE     SPACE  4
***       CHTE - CREATE CHANNEL TABLE ENTRY.
*
*
*         CHTE   ADDRESS
*         ENTRY  (ADDRESS) = ADDRESS TO INSERT IN CHANNEL TABLE.


          PURGMAC CHTE
 CHTE     MACRO  A
          LOCAL  B
 B        EQU    A
          RMT
          CON    B
          RMT
          ENDM
 CHTL     SPACE  4
***       CHTL - CREATE LAST ENTRY IN CHANNEL TABLE.
*
*
*         CHTL   ADDRESS
*         ENTRY  (ADDRESS) = ADDRESS TO INSERT AS LAST ENTRY IN CHANNEL
*         TABLE.
*
*         NOTE-  WHEN THIS CALL IS USED CHANNEL TABLE WILL NOT
*         TERMINATE WITH A ZERO BYTE.


          PURGMAC CHTL
 CHTL     MACRO  A
          LOCAL  B
 B        EQU    A
 CHTL     RMT
          CON    B
 CHTL     RMT
          ENDM
 CHTB     SPACE  4
***       CHTB - DEFINE CHANNEL TABLE.
*         CHANNEL TABLE IS TERMINATED BY A ZERO WORD.
*
*
*LOC      CHTB
*         ENTRY  *LOC* = FWA OF CHANNEL TABLE.


          PURGMAC CHTB
          MACRO  CHTB,A
          LOCAL  B,C
 A        BSS    0
          HERE
 B        SET    *
 CHTL     HERE
 C        SET    *
          IFEQ   B,C,1       IF NO SPECIAL TERMINATOR
 A_E      DATA   0           TERMINATE TABLE
          ENDM
 RSTC     SPACE  4
***       RSTC - RESTORE CHANNEL INSTRUCTIONS.
*
*
*         RSTC


          PURGMAC RSTC
 RSTC     MACRO
          PURGMAC AJM
          PURGMAC SCF
          PURGMAC IJM
          PURGMAC CCF
          PURGMAC FJM
          PURGMAC SFM
          PURGMAC EJM
          PURGMAC CFM
          PURGMAC IAN
          PURGMAC IAM
          PURGMAC OAN
          PURGMAC OAM
          PURGMAC ACN
          PURGMAC DCN
          PURGMAC FAN
          PURGMAC FNC
 AJM      OPSYN  AJM.
 SCF      OPSYN  SCF.
 IJM      OPSYN  IJM.
 CCF      OPSYN  CCF.
 FJM      OPSYN  FJM.
 SFM      OPSYN  SFM.
 EJM      OPSYN  EJM.
 CFM      OPSYN  CFM.
 IAN      OPSYN  IAN.
 IAM      OPSYN  IAM.
 OAN      OPSYN  OAN.
 OAM      OPSYN  OAM.
 ACN      OPSYN  ACN.
 DCN      OPSYN  DCN.
 FAN      OPSYN  FAN.
 FNC      OPSYN  FNC.
          ENDM
          SPACE  4,10
          BASE   *
          ENDX
*DECK DECK=DSI$S0_DUMP_LOAD_IDLE_PP EXPAND=FALSE
          CTEXT  DSI$S0 DUMP LOAD IDLE PP
          SPACE  4,10
          IF     -DEF,QUAL$,1
          QUAL   COMPPRQ
          BASE   M
 DSIDLI   SPACE  4,10
***              THIS COMMON DECK CONTAINS THE S0/S0E-SPECIFIC VARIANTS OF
*         THE ROUTINES CONTAINED IN COMMON DECK *DSI$DUMP_LOAD_IDLE_PP*.
*         THE S0/S0E ARE SO DIFFERENT FROM OTHER IOU-S THAT HAVING SEPARATE
*         ROUTINES MAKES MORE SENSE THAN THE AMOUNT OF SPECIAL CASING
*         THAT WOULD OTHERWISE BE REQUIRED.
 GLOBAL   SPACE  4,10
**        GLOBAL VARIABLES.


 PPNO     BSS    1           PP NUMBER (PASSED AS PARAMETER)
 DDP      SPACE  4,10
***       DDP - DEADSTART DUMP PP.
*
*         ENTRY  (A) = PP TYPE AND NUMBER.
*                (T1) = CHANNEL NUMBER ON DEADSTART PP ON.
*
*         EXIT   PP DOING BLOCK OUTPUT ON CHANNEL (T1).
*
*         USES   EC, RN, T1.


 DDP      SUBR               ENTRY/EXIT
          RJM    PPR
          LDD    T1
          STM    IDPA        SET CHANNEL NUMBER
          LDM    IDPA+5
          LPN    37
          LMC    140         SET *DUMP*/*IDLE*
          STM    IDPA+5
          RJM    PDC         PREPARE DEADSTART CHANNEL
          WRITMR IDPA        DEADSTART LOAD IOU
          UJN    DDPX        RETURN
 DLP      SPACE  4,10
***       DLP - DEADSTART LOAD PP.
*
*         ENTRY  (A) = PP TYPE AND NUMBER.
*                (T1) = CHANNEL NUMBER TO DEADSTART PP TO.
*
*         EXIT   PP DOING BLOCK INPUT ON CHANNEL (T1).
*
*         USES   EC, RN, T1.


 DLP      SUBR               ENTRY/EXIT
          RJM    PPR
          LDD    T1          SET CHANNEL NUMBER
          STM    IDPA
          LDM    IDPA+5
          LPN    37
          LMC    200         SET *LOAD*
          STM    IDPA+5
          RJM    PDC         PREPARE DEADSTART CHANNEL
          WRITMR IDPA        DEADSTART LOAD IOU
          UJN    DLPX        RETURN
 IDP      SPACE  4,10
**        IDP - IDLE PP.
*
*         ENTRY  (A) = PP TYPE AND NUMBER TO IDLE.
*
*         EXIT   PP IDLED.
*
*         USES   EC, RN.


 IDP      SUBR               ENTRY/EXIT
          RJM    PPR         PRESET PP
          LDN    16
          STM    IDPA        SET TO CHANNEL 16
          LDM    IDPA+5
          LPN    37
          LMN    40          SET *IDLE*
          STM    IDPA+5
          WRITMR IDPA        WRITE IOU REGISTER TO IDLE PP
          RJM    WFI         WAIT FOR IDLE
          NJN    IDP2        IF IDLE DID NOT OCCUR
 IDP1     UJN    IDPX

*         AT THIS POINT THE PP DIDNT IDLE FROM JUST AN IDLE.
*         RETRY DOING A DUMP IDLE IN CASE THE PP IS HUNG.
*
*         IF AT THE TIME THE PP WAS IDLED, IT WAS HUNG AT A CHANNEL
*         FUNCTION INSTRUCTION, THE DUMP IDLE WILL CAUSE A FORCED
*         EXIT OF THE INSTRUCTION.  BECAUSE THIS IS DONE WITH AN OAM
*         INSTRUCTION, THE P ADDRESS (AFTER THE PP IS DUMP IDLED)
*         WILL BE SET TO WHATEVER HAPPENS TO BE IN PP ADDRESS 0 + 1.

 IDP2     LDM    IDPA+5
          LPN    37
          LMC    140         SET *DUMP*/*IDLE*
          STM    IDPA+5
          WRITMR IDPA
          RJM    WFI         WAIT FOR IDLE
          UJN    IDP1        RETURN

 IDPA     BSS    10
 PDC      SPACE  4,10
**        PDC - PREPARE DEADSTART CHANNEL.
*
*         ENTRY  (T1) = CHANNEL NUMBER TO DEADSTART PP ON.
*
*         EXIT   CHANNEL ACTIVE AND EMPTY.


 PDC      SUBR               ENTRY/EXIT
          LDC    DCNI+40
          ADD    T1
          STM    PCHA
          LMC    ACNI&DCNI
          STM    PCHB
 PCHA     DCN    CH+40       DEACTIVATE POSSIBLE ACTIVE CHANNEL
 PCH1     SBN    1
          PJN    PCH1        WAIT A BIT
 PCHB     ACN    CH+40       ACTIVATE EMPTY CHANNEL
          UJN    PDCX        RETURN
 PPR      SPACE  4,10
**        PPR - PRESET PP ROUTINES.
*
*         SETS *EC* AND STATUS REGISTER NUMBERS ACCORDINGLY.
*
*         ENTRY  (A) = PP TYPE AND NUMBER.
*
*         EXIT   (A) IS RESTORED TO ENTRY VALUE.


 PPR      SUBR               ENTRY/EXIT
          STML   PPNO        SAVE PP TYPE AND NUMBER
          LPN    37          ISOLATE PP NUMBER
          ADN    S0IEC       SET *EC* REGISTER NUMBER
          STM    PPRE
          ADN    S0IST-S0IEC SET STATUS-1 REGISTER NUMBER
          STM    PPRS
          LDML   I0CC        SET CONNECT CODE
          STDL   EC
          LDM    PPRE        SET REGISTER NUMBER
          STD    RN
          READMR IDPA
          LDML   PPNO        RESTORE PP TYPE AND NUMBER
          UJN    PPRX        RETURN

 PPRE     CON    0           *EC* REGISTER NUMBER
 PPRS     CON    0           STATUS-1 REGISTER NUMBER
 WFI      SPACE  4,10
**        WFI - WAIT FOR IDLE.
*
*         ENTRY  (IDPA - IDPA+7) = CURRENT *EC* REGISTER.
*
*         EXIT   (A) = 0 IF PP IS IDLED.
*
*         USES   RN, T1.


 WFI      SUBR               ENTRY/EXIT
          LDC    500D
          STDL   T1
          LDM    PPRS        SET STATUS-1 REGISTER NUMBER
          STD    RN
 WFI1     READMR WFIA        READ PP STATUS 1 REGISTER
          LDM    WFIA+2
          LPC    177
          LMC    177
          ZJN    WFI2        IF IDLED
          SODL   T1
          NJN    WFI1        IF NOT TIMED OUT
          LDN    77
 WFI2     UJN    WFIX        RETURN

 WFIA     BSSZ   10
          SPACE  4,10
          BASE   *
 QUAL$    IF     -DEF,QUAL$
          QUAL   *
 DDP      EQU    /COMPPRQ/DDP
 DLP      EQU    /COMPPRQ/DLP
 IDP      EQU    /COMPPRQ/IDP
 QUAL$    ENDIF
          SPACE  4,10
          ENDX
*DECK DECK=DSI$SERVICE_MEMORY_ERRORS EXPAND=TRUE
 SME      SPACE  4,10
**        SME - SERVICE MEMORY ERROR.
*
*         CALLS  UST, *LOG*, *REW*.


          ROUTINE SME

          LDC    MOETT
          STD    T3
 SME1     LDM    MOET,T3     GET SYNDROME ENTRY
          SBM    SYCD
          ZJN    SME2        IF HAVE A MATCH
          SOD    T3
          PJN    SME1        IF TRY ANOTHER
          LJM    SME3        NOT MULTIPLE ODD ERROR


*         SET UP BUFFER CONTROL WORD.
*
*         DFT ANALYSIS - ERROR PRIORITY = UNCORRECTED ERROR.
*         DFT ANALYSIS - CODE = MULTIPLE ODD BIT ERROR.

 SME2     SETDAN (EPUN,DAMOB)

*         FLAGS = VALID 170, VALID 180.

          SETFLG (BC.FV7,BC.FV8)
          SETOSA OSMOB       OS ACTION = MULTIPLE ODD BIT ERROR
          CALL   LOG
          UJN    SME7        RETURN

 SME3     DEPCALL SME4,SMEA

 SME4     CALL   REW         REWRITE SINGLE BIT ERROR
          UJN    SME6

 SME5     CALL   REWS0       REWRITE SINGLE BIT ERROR FOR S0
 SME6     RJM    UST         UPDATE SECDED ID TABLE
          ZJN    SME7        IF NOT TO LOG THIS ERROR
          CALL   LOG
 SME7     LJM    SMEX

 SMEA     INDEX
          INDEX  M930A,SME5
          INDEX  M930B,SME5
          INDEX  M930C,SME5
          INDEX  M930D,SME5
          INDEX  MEND
 MOET     SPACE  4,10
**        MOET - TABLE OF MULTIPLE ODD BIT ERRORS.
*
*         12/ CODE
*
*         CODE IS SYNDROME FOR MULTIPLE ODD BIT ERROR BEING
*         REPORTED AS SINGLE BIT ERROR.


 MOET     BSS    0
          LOC    0
          DATA   0#13,0#15,0#16,0#19,0#1A,0#1C,0#1F,0#23
          DATA   0#25,0#26,0#29,0#2A,0#2C,0#2F,0#31,0#32
          DATA   0#34,0#38,0#43,0#45,0#46,0#49,0#4A,0#4C
          DATA   0#4F,0#51,0#52,0#54,0#58,0#61,0#62,0#64
          DATA   0#68,0#83,0#85,0#86,0#89,0#8A,0#8C,0#8F
          DATA   0#91,0#92,0#94,0#98,0#A1,0#A2,0#A4,0#A8
          DATA   0#C1,0#C2,0#C4,0#C8,0#F1,0#F2,0#F4,0#F8
 MOETT    EQU    *-1
          LOC    *O
          EJECT
 UST      SPACE  4,10
**        UST - UPDATE SECDED ID TABLE.
*
*         ENTRY  (SBER - SBER+1) = ADDRESS OF ERROR.
*                (SYCD) = SYNDROME CODE.
*
*         EXIT   (A) <> 0 IF ENTRY SHOULD BE LOGGED.
*                (A) = 0 IF ENTRY SHOULD NOT BE LOGGED.
*                A NEW ENTRY IS CREATED OR AN EXISTING ENTRY UPDATED.
*
*         USES   T4, T5, W0 - W7.
*
*         CALLS  IDA, SPB.


 UST      SUBR               ENTRY/EXIT
          LDN    0
          STD    T4
          LDN    SECP        SECDED ID TABLE POINTER OFFSET
          RJM    IDA
          CRDL   W0          READ IN POINTER WORD
          LRD    W1          SET UP R-REGISTER
 UST1     LDD    W0
          ADD    T4
          ADC    RR
          CRDL   W4          READ ENTRY
          LDD    W4          COUNT FIELD
          ZJN    UST3        IF FREE ENTRY
          LDML   SBER
          SBDL   W5
          NJN    UST2        IF NO MATCH
          LDML   SBER+1
          SBDL   W6
          NJN    UST2        IF NO MATCH SECOND PART
          AOD    W4          MATCH - BUMP COUNT
          LDD    W0
          ADD    T4
          ADC    RR
          CWDL   W4          REWRITE ENTRY
          LDN    0
          UJP    USTX        IF OK POSITIVE

 UST2     AOD    T4
          SBD    W3
          ZJN    UST4        IF THRU SCANNING
          UJN    UST1        LOOP

 UST3     LDM    USTA
          NJN    UST2
          AOM    USTA        MARK THAT FREE ENTRY FOUND
          LDD    T4
          STD    T5          HOLDS FREE ENTRY
          UJP    UST2        LOOP

 UST4     LDM    USTA
          ZJN    UST5        IF NO FREE ENTRY FOUND
          LDN    1           CREATE A NEW ENTRY
          STD    W4          COUNT IS 1
          LDM    SYCD        SYNDROME
          STD    W7
          LDML   SBER+1      ADDRESS
          STDL   W6
          LDML   SBER
          STDL   W5
          RJM    SPB         SET PP BOUNDS
          LDD    W0
          ADD    T5
          ADC    RR
          CWDL   W4          WRITE NEW ENTRY
          LDN    1
 UST5     LJM    USTX

 USTA     CON    0
*DECK DECK=DSI$SUPPORT_EICB_VERSION_4 EXPAND=FALSE

 { common deck DSI$SUPPORT_EICB_VERSION_4
 { The EICB version was advanced to 4 to signal users of the NOS PP program
 { called VER that there is support in VER for the I4 concurrent peripherals,
 { If the eicb version is 4, the new function codes will be used,
 { if the eicb version is less than 4, the old functions codes will be used.

  CONST
    dsc$eicb_version_4 = 4(8);

  VAR
    got_eicb_d7ty: [STATIC] boolean := FALSE,
    d7ty: [STATIC] PACKED RECORD
       rfu: 0 .. 77(8),
       date: 0 .. 777777(8),
       time: 0 .. 777777(8),
       os_type: 0 .. 77(8),
       eicb_version: 0 .. 77(8),
       rfu_1: 0 .. 77(8),
    RECEND;
*DECK DECK=DSI$TERMINATION_EDD_DUMP EXPAND=FALSE
?? NEWTITLE := '~~~~~   common deck DSI$TERMINATION_EDD_DUMP', EJECT ??

{ PURPOSE:
{   Dump the NOS/VE environment to the dump file.  The format of this file
{   is the same as an EDD dump tape excluding memory used by the 170
{   OS and anything that can not be retrieved without damaging the
{   170 process.

  PROCEDURE nosve_edd_dump;

?? PUSH (LISTEXT := ON) ??
*copyc dst$dft_puf_subfunctions
*copyc dst$dft_request_codes
*copyc dsi$dft_types_and_constants
*copyc dst$iou_number
*copyc ost$central_memory_model_number
*copyc ost$hardware_subranges
*copyc ost$iou_model_number
*copyc ost$processor_model_number
?? PUSH (LISTEXT := OFF) ??

    TYPE
      char_arr = PACKED ARRAY [1 .. 10] OF 0 .. 63;

    TYPE
      edd_register_format = PACKED ARRAY [1 .. 10] OF 0 .. 7777(8);

*copyc pxiotyp

{ PURPOSE:
{   Open binary labelled tape file as local file.

    PROCEDURE [XREF] bi#olt
      (VAR binary_file: file;
           file_name: string ( * );
           status: file_status;
           mode: file_mode;
           position: file_position);

    PROCEDURE [XREF] bi#put_tape ALIAS 'bi#putt'
      (    binary_file: file;
           pointer_to_source: ^cell;
           length_of_source: integer);

    PROCEDURE [XREF] bi#weof_tape ALIAS 'bi#weft'
      (    binary_file: file);

    PROCEDURE [XREF] p32to60
      (    word_count: integer;
           unpacked_data: ^cell;
           packed_data: ^cell);

    PROCEDURE [XREF] get_date_time ALIAS 'gtdttm'
      (VAR date: char_arr;
       VAR time: char_arr);

?? NEWTITLE := '~~~~~   procedure read_register', EJECT ??

{ PURPOSE:
{   Read a maintenance register either from the maintenance channel
{   via SDA (SDA passes a request to DFT) or from the ssr_register
{   list provided in the call.  The ssr register list register value
{   pre-empts the hardware value.
{
{   NOTE: The maintenance register port code for reading the maintenance
{   register is passed in 'pp_table.port_code' by the caller.

    TYPE
      register_list = ^ARRAY [1 .. * ] OF register_record;

    VAR
      register_block_buffer: PACKED RECORD
        tape_block_header: cell,
        register: ARRAY [1 .. 50] OF edd_register_format,
      RECEND,
      ssr_registers: register_list;

    PROCEDURE read_register
      (VAR edd_data: edd_register_format;
           register_number: integer;
           ssr_register_list: register_list;
           iou_number: dst$iou_number;
           maintenance_register_port_code: 0 .. 0fff(16));

{  Define type definition for DFT request to read a maintenance register.
{  It is defined in a 60 bit world but will be passed to DFT as 60 bits
{  in 64 bits right justified.

      TYPE
        dft_read_maintenance_register = PACKED RECORD

{  Word 0.

          response: 0 .. 0f(16),
          request: 0 .. 0ff(16),
          iou_number: 0 .. 0ff(16),
          unused: 0 .. 0ff(16),
          maintenance_register_port: 0 .. 0ffff(16),
          maintenance_register_number: 0 .. 0ffff(16),

{  word 1.

          maintenance_register_value_p: dst$r_pointer,
        RECEND,

{  Define type definition to describe format of maintenance register returned
{  by DFT.

        dft_maintenance_register_format = PACKED RECORD

{  Word 0.

          unused_1: 0 .. 0f(16),
          byte_1: 0 .. 0ff(16),
          unused_2: 0 .. 0ff(16),
          byte_2: 0 .. 0ff(16),
          unused_3: 0 .. 0ff(16),
          byte_3: 0 .. 0ff(16),
          unused_4: 0 .. 0ff(16),
          byte_4: 0 .. 0ff(16),

{  Word 1.

          unused_5: 0 .. 0f(16),
          byte_5: 0 .. 0ff(16),
          unused_6: 0 .. 0ff(16),
          byte_6: 0 .. 0ff(16),
          unused_7: 0 .. 0ff(16),
          byte_7: 0 .. 0ff(16),
          unused_8: 0 .. 0ff(16),
          byte_8: 0 .. 0ff(16),
        RECEND;

      VAR
        dft_request: dft_read_maintenance_register,
        ei_copy_memory_header: memory_copy_header,
        found: boolean,
        i: integer,
        maintenance_register: dft_maintenance_register_format,
        register: register_record,
        sda_request: pp_data_type;

      found := FALSE;
      register.length := 8;
      register.number := register_number;
      edd_data [1] := 8;
      edd_data [2] := register_number;

      IF ssr_register_list <> NIL THEN

      /check_saved_registers/
        FOR i := 1 TO UPPERBOUND (ssr_register_list^) DO
          IF ssr_register_list^ [i].number = register_number THEN
            register := ssr_register_list^ [i];
            found := TRUE;
            EXIT /check_saved_registers/;
          IFEND;
        FOREND /check_saved_registers/;
      IFEND;

      IF NOT found THEN

{  Read the register by passing a DFT request through SDA.

        dft_request.response := 0;
        dft_request.request := dsc$dft_read_maint_register;
        dft_request.iou_number := iou_number;
        dft_request.maintenance_register_port :=
              maintenance_register_port_code;
        dft_request.maintenance_register_number := register_number;
        dft_request.maintenance_register_value_p := dft_request_r_pointer;
        dft_request.maintenance_register_value_p.offset :=
              dft_request.maintenance_register_value_p.offset + 2;
        dft_request.maintenance_register_value_p.length := 2;

        sda_request.dft_request_length := 2;
        sda_request.ve_dft_request_p.offset := dft_request_r_pointer.offset;
        sda_request.ve_dft_request_p.rupper := dft_request_r_pointer.rupper;
        sda_request.ve_dft_request_p.rlower := dft_request_r_pointer.rlower;
        sda_request.os_170_dft_request_p := ^dft_request;
        callsda (write_dft_request_block, sda_request);

        IF dft_request.response <> normal_dft_response THEN
          dyfstring ('ERROR READING MAINTENANCE REGISTER.', user_dayf);
        IFEND;

{  Copy memory from where DFT returned register information to a local
{  variable.

        ei_copy_memory_header.pva_type := dft_request_pva_type;
        ei_copy_memory_header.byte_rma := dft_request_byte_rma + (2 * 8);
        ei_copy_memory_header.copy_method := ve60_to_nos60;
        ei_copy_memory_header.length := 2;
        copy_memory (ei_copy_memory_header, ^maintenance_register);

{  Move register to EDD format variable.

        edd_data [3] := maintenance_register.byte_1;
        edd_data [4] := maintenance_register.byte_2;
        edd_data [5] := maintenance_register.byte_3;
        edd_data [6] := maintenance_register.byte_4;
        edd_data [7] := maintenance_register.byte_5;
        edd_data [8] := maintenance_register.byte_6;
        edd_data [9] := maintenance_register.byte_7;
        edd_data [10] := maintenance_register.byte_8;
      ELSE

{  Reformat register data from saved registers.

        FOR i := 1 TO 8 DO
          edd_data [i + 2] := register.register_value [i];
        FOREND;
      IFEND;

    PROCEND read_register;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure create_dump_identifier_record', EJECT ??

{ PURPOSE:
{   Write the dump identifier record, DID, to the dump file.

    PROCEDURE create_dump_identifier_record;

      CONST
        all_nve_memory = 1,
        critical_nve_memory = 3,
        dual_state_dump_utility_version = 1,
        no_nve_memory = 2,
        nve_run_dump = 1;

      VAR
        did_record: PACKED RECORD
          tape_block_header: cell,
          ident: 0 .. 0ffff(16),
          memory_dumped: 0 .. 0ffff(16),
          fill1: 0 .. 0fffffff(16),
          fill2: integer,
        RECEND;

      format_edd_header ('DID', 0, dual_state_dump_utility_version);

      did_record.fill1 := 0;
      did_record.fill2 := 0;
      did_record.ident := 1;
      IF (memory_to_be_dumped = 'CRITICAL') THEN
        did_record.memory_dumped := critical_nve_memory;
      ELSEIF memory_to_be_dumped = 'NONE' THEN
        did_record.memory_dumped := no_nve_memory;
      ELSE
        did_record.memory_dumped := all_nve_memory;
      IFEND;

      bi#put_tape (vedump, ^did_record, 2);

    PROCEND create_dump_identifier_record;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure format_edd_header', EJECT ??

{ PURPOSE:
{   Write a header to the dump tape in EDD format.

    PROCEDURE format_edd_header
      (    idname: string (3);
           fwa: integer;
           dump_length: integer);

      TYPE
        dst$header_word_1 = PACKED RECORD
          ident: 0 .. 777777(8),
          radial: 0 .. 77(8),
          fwa: 0 .. 777777(8),
          length: 0 .. 777777(8),
        RECEND,

        dst$edd_header = PACKED RECORD
          word1: ALIGNED dst$header_word_1,
          word2: integer,
          word3: char_arr,
          word4: char_arr,
        RECEND;

      VAR
        dc_string: ^ARRAY [1 .. 4] OF PACKED ARRAY [0 .. 9] OF 0 .. 77(8),
        edd_header: [STATIC] string (20) := '***G******DSMTRM  00',
        si: ost$string_index,
        dcci: 0 .. 9,
        eol: boolean,
        i: integer,
        output_buffer: PACKED RECORD
          tape_block_header: cell,
          edd_header: dst$edd_header,
        RECEND;

      i := 1;
      dcci := 0;
      si := 1;
      eol := TRUE;
      dc_string := #LOC (output_buffer.edd_header.word1);
      edd_header (1, 3) := idname;
      utp$convert_string_to_dc_string (utc$ascii64, dc_string^, i, dcci,
            edd_header, si, eol);

      output_buffer.edd_header.word1.radial := pp_table.port_code DIV 100(16);
      output_buffer.edd_header.word1.fwa := fwa;
      output_buffer.edd_header.word1.length := dump_length;
      output_buffer.edd_header.word3 := os_date;
      output_buffer.edd_header.word4 := os_time;
      bi#put_tape (vedump, ^output_buffer, 4);

    PROCEND format_edd_header;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure dump_iou_registers', EJECT ??

{ PURPOSE:
{   Dump the iou maintenance registers.

    PROCEDURE dump_iou_registers
      (    iou_info: dst$cc_iou_info);

      CONST
        max_number_of_imr = 30,

{  mr_offset is used in accessing the maintenance register values in the
{  options_installed_registers array.  This is necessary since the
{  procedure read_register returns byte zero of the desired maintenance
{  register in location 3 of the array.

        mr_offset = 3;

      VAR
        edd_header_id: string (3),
        i: 1 .. 4,

{  Define 2 dimensional array of IOU maintenance registers to dump.  The first
{  array is for I1 and I2 IOUs, the second is for I4 IOUs and the third is
{  for I4C IOUs.

        iou_registers: [STATIC] PACKED ARRAY [1 .. 4] OF PACKED ARRAY
          [1 .. max_number_of_imr] OF 0 .. 7777(8) := [ [0(16), 10(16),
          12(16), 18(16), 21(16), 30(16), 40(16), 80(16), 81(16), 0a0(16),
          0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0],
          [0(16), 10(16), 12(16), 16(16), 18(16), 1c(16),
          21(16), 25(16), 30(16), 34(16), 40(16), 44(16), 80(16), 81(16),
          84(16), 85(16), 0a0(16), 0a4(16), 0b0(16), 0b1(16), 0b2(16),
          0b3(16), 0b4(16), 0b5(16), 0b6(16), 0b7(16), 0b8(16), 0b9(16),
          0, 0],
          [0(16), 10(16), 12(16), 18(16), 21(16), 30(16), 40(16), 80(16),
          81(16), 0a0(16), 0b0(16), 0b1(16), 0b2(16), 0b3(16), 0b4(16),
          0b5(16), 0b6(16), 0b7(16), 0b8(16), 0b9(16), 0c0(16), 0c1(16),
          0c2(16), 0c3(16), 0c4(16), 0c5(16), 0c6(16), 0c7(16), 0c8(16),
          0c9(16)],
          [0(16), 10(16), 12(16), 18(16), 21(16), 30(16), 40(16), 80(16),
          81(16), 0a0(16), 0b0(16), 0b1(16), 0b2(16), 0b3(16), 0, 0, 0,
          0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0]],
        j: 1 .. max_number_of_imr,
        length: integer,
        number_of_imr_to_dump: 1 .. max_number_of_imr,
        options_installed_registers: edd_register_format;

{  Process IOU maintenance registers (IMx record).

      dyfstring ('DUMPING IMX', debug_log);

      IF ious_observed <> 0 THEN
        STRINGREP (edd_header_id (1, 3), length, ious_observed:3);
        edd_header_id (1, 2) := 'IM';  { Set header for secondary IOU.
      ELSE
        edd_header_id (1, 3) := 'IMR';  { Set header for primary IOU.
      IFEND;

      format_edd_header (edd_header_id, 0, 0);

{  Select the set of registers to be dumped.  This is a common set of
{  registers for all IOU's except for the I4 with the CIO subsystem and
{  for the I4C.  For an I4 with the CIO subsystem, two different cases
{  are processed:  the second barrel present or not.  The set of
{  registers to be dumped is specific to the I4 with the CIO subsystem in
{  both cases.  Registers b5 - b9 will only be dumped when both barrels
{  are present.  For an I4C registers b0 - b9 and c0 - c9 are dumped in
{  addition to the standard set of registers.

      i := 1;  { Default IOU type of I1 or I2.
      number_of_imr_to_dump := 10;

      CASE iou_info.element_id.model_number OF
      = osc$imn_40 =
        read_register (options_installed_registers, 12(16), NIL,
              ious_observed, iou_info.port_code);
        IF ((options_installed_registers[mr_offset+7] DIV 80(16))
          MOD 2) <> 0 THEN { CIO subsystem present
          i := 2;  { IOU type is I4.
          number_of_imr_to_dump := 23;
          read_register (options_installed_registers, 16(16), NIL,
                ious_observed, iou_info.port_code);
          IF ((options_installed_registers[mr_offset+2] DIV 2)
            MOD 2) <> 0 THEN { barrel 1 present
            number_of_imr_to_dump := 28;
          IFEND;
        IFEND;
      = osc$imn_44 =
        i := 3;
        number_of_imr_to_dump := 20;
        read_register (options_installed_registers, 12(16), NIL,
              ious_observed, iou_info.port_code);
        IF ((options_installed_registers[mr_offset+2] DIV 4(16))
          MOD 2) <> 0 THEN { barrel 2 is present
          IF ((options_installed_registers[mr_offset+2] DIV 8(16))
            MOD 2) <> 0 THEN { barrel 3 is present
            number_of_imr_to_dump := number_of_imr_to_dump + 10;
          ELSE
            number_of_imr_to_dump := number_of_imr_to_dump + 5;
          IFEND;
        IFEND;

     = osc$imn_42 =
       i := 4;
       number_of_imr_to_dump := 14
      ELSE

      CASEND;

      FOR j := 1 TO number_of_imr_to_dump DO
        read_register (register_block_buffer.register [j],
              iou_registers [i] [j], NIL, ious_observed, iou_info.port_code);
      FOREND;

      register_block_buffer.register [number_of_imr_to_dump + 1] [1] := 0;

      bi#put_tape (vedump, ^register_block_buffer,
            (number_of_imr_to_dump * 2) + 1);

      ious_observed := ious_observed + 1;

    PROCEND dump_iou_registers;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure determine_assigned_channels', EJECT ??

{ PURPOSE:
{   Determine which channels are assigned to NOS/VE by calling VER.

    PROCEDURE determine_assigned_channels
      (    max_number_of_chs: integer;
           iou_number: dst$iou_number;
       VAR channel_request: ver_request_block);

      VAR
        i: integer;

      FOR i := 1 TO max_number_of_chs DO
        IF i < 13 THEN  { Process NIO channels 0 - 13(8).
          channel_request.channels [i].primary := i - 1;
          channel_request.channels [i].kind := nio_channel;
        ELSEIF i > 24 THEN  { Process CIO channels 0 - 11(8).
          channel_request.channels [i].primary := i - 25;
          channel_request.channels [i].kind := cio_channel;
          { Note that it is not necessary to distinguish between barrel 0
          { and barrel 1 for the stct VER request.
        ELSE  { Process NIO channels 20 - 33(8).
          channel_request.channels [i].primary := i + 3;
          channel_request.channels [i].kind := nio_channel;
        IFEND;
        IF d7ty.eicb_version < dsc$eicb_version_4 THEN
          channel_request.channels [i].kind := 0;
        IFEND;
        channel_request.channels [i].fill := 0;
        channel_request.channels [i].status := 0;
      FOREND;

      IF iou_number = 0 THEN

{  Primary IOU, call VER to determine which channels are assigned to NOS/VE.
{  All channels are assumed to be assigned to NOS/VE in secondary IOUs.

        channel_request.length := max_number_of_chs;
        channel_request.general_status := 0;
        IF d7ty.eicb_version < dsc$eicb_version_4 THEN
          { use pre NOS 2.5.1 request code
          callver (channel_request, stch, TRUE);
        ELSE
          { use NOS 2.5.1 request code
          callver (channel_request, stct, TRUE);
        IFEND;
      IFEND;

    PROCEND determine_assigned_channels;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure determine_assigned_pps', EJECT ??

{ PURPOSE:
{   Determine which PPs are assigned to NOS/VE by calling VER.

    PROCEDURE determine_assigned_pps
      (    max_number_of_pps: integer;
           iou_number: dst$iou_number;
           cri: integer);

      VAR
        i: integer,
        offset: integer,
        pp_off: dst$cc_barrel_vector;

      FOR i := 1 TO max_number_of_pps DO
        IF i < 11 THEN  { Process non-driver pp's (numbered 0 - 11(8)).
          ver_request.pps [i].primary := i - 1;
          ver_request.pps [i].kind := non_driver_pp;
        ELSEIF i > 20 THEN  { Process CIO pp's (numbered 0 - 11(8)).
          ver_request.pps [i].primary := i - 21;
          ver_request.pps [i].kind := cio_cluster_0;
          { Note that it is not necessary to distinguish between barrel 0
          { and barrel 1 for the stpt VER request.
        ELSE  { Process driver pp's (numbered 20(8) - 31(8)).
          ver_request.pps [i].primary := i + 5;
          ver_request.pps [i].kind := driver_pp;
        IFEND;
        IF d7ty.eicb_version < dsc$eicb_version_4 THEN
          ver_request.pps [i].kind := 0;
        IFEND;
        ver_request.pps [i].fill := 0;
        ver_request.pps [i].status := 0;
      FOREND;

      IF iou_number = 0 THEN

{  For IOU0, call VER to determine which PPs are assigned to NOS/VE.

        ver_request.length := max_number_of_pps;
        ver_request.general_status := 0;
        IF d7ty.eicb_version < dsc$eicb_version_4 THEN
          { use pre NOS 2.5.1 request code
          callver (ver_request, stpp, TRUE);
        ELSE
          { use NOS 2.5.1 request code
          callver (ver_request, stpt, TRUE);
        IFEND;
      ELSE

{  For IOU1, examine the IOU descriptor to determine which PPs could be assigned to NOS/VE.

        FOR i := 1 TO max_number_of_pps DO
          IF i < 11 THEN
            pp_off := configuration_record [cri].iou.pps_physically_missing.barrel_0;
            offset := 0;
          ELSEIF (i > 10) AND (i < 21) THEN
            pp_off := configuration_record [cri].iou.pps_physically_missing.barrel_1;
            offset := 10;
          ELSEIF i > 20 THEN
            pp_off := configuration_record [cri].iou.cpps_physically_missing;
            offset := 20;
          IFEND;
          IF pp_off [i - offset - 1] THEN
            ver_request.pps [i].status := 2;
          IFEND;
        FOREND;
      IFEND;

    PROCEND determine_assigned_pps;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure get_CIO_channel_status', EJECT ??

{ PURPOSE:
{   Read the corresponding B or C register to get the CIO channel status.

    PROCEDURE get_cio_channel_status
      (    cio_channel_number: integer;
           iou_number: dst$iou_number;
           iou_port_code: 0 .. 0fff(16);
       VAR channel_status: 0 .. 0f(16));

      TYPE
        b_register_bit_level = PACKED RECORD
          CASE register_fields OF
          = field_level =
            field: 0 .. 7777(8),
          = bit_level =
            fill: 0 .. 1777(8),
            bit1: 0 .. 1,
            bit2: 0 .. 1,
          CASEND,
        RECEND;

      TYPE
        register_fields = (bit_level, field_level);

      CONST
        channel_status_offset = 8,
        max_number_of_b_reg = 10,
        max_number_of_c_reg = 10;

      VAR
        b_registers: [STATIC] PACKED ARRAY [0 .. max_number_of_b_reg - 1] OF
          0 .. 7777(8) := [ 0b0(16), 0b1(16), 0b2(16), 0b3(16), 0b4(16),
          0b5(16), 0b6(16), 0b7(16), 0b8(16), 0b9(16)],
        bc_register_contents: edd_register_format,
        c_registers: [STATIC] PACKED ARRAY [0 .. max_number_of_c_reg - 1] OF
          0 .. 7777(8) := [ 0c0(16), 0c1(16), 0c2(16), 0c3(16), 0c4(16),
          0c5(16), 0c6(16), 0c7(16), 0c8(16), 0c9(16)],
        change_bits_around: b_register_bit_level,
        save_one_bit: 0 .. 1;

      CASE cio_channel_number OF
      = 0 .. 11(8) =
        read_register (bc_register_contents, b_registers [CIO_channel_number],
          NIL, iou_number, iou_port_code);
      = 20(8) .. 31(8) =
        read_register (bc_register_contents, c_registers [CIO_channel_number-20(8)],
          NIL, iou_number, iou_port_code);
      ELSE
        bc_register_contents [channel_status_offset] := 0;
      CASEND;

{  The order of the channel flag bits in the B and C registers is:
{     bit  44 active flag
{          45 full flag
{          46 channel error flag
{          47 channel flag
{  In the dump output record, bits 46 and 47 are switched around.
{  Therefore, the following code is needed to change the channel
{  flag and the channel error flag around.

      change_bits_around.field := bc_register_contents [channel_status_offset];
      save_one_bit := change_bits_around.bit1;
      change_bits_around.bit1 := change_bits_around.bit2;
      change_bits_around.bit2 := save_one_bit;

      channel_status := change_bits_around.field;

    PROCEND get_cio_channel_status;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure move_apqk_to_output_record', EJECT ??

{ PURPOSE:
{   Read the PP A, P, Q and K registers and format them into the EDD
{   output buffer.

    PROCEDURE move_apqk_to_output_record
      (VAR cm_header: memory_copy_header;
       VAR output_buffer: PACKED ARRAY [0 .. 8] OF 0 .. 0fff(16));

      TYPE
        temp_apqk_hold = PACKED RECORD
          fill1: 0 .. 0ffff(16),
          p1: 0 .. 0ff(16),
          p2: 0 .. 0ff(16),
          fill2: 0 .. 0ffff(16),
          q1: 0 .. 0ff(16),
          q2: 0 .. 0f(16),
          q3: 0 .. 0f(16),
          fill3: 0 .. 0ffff(16),
          k1: 0 .. 0ff(16),
          k2: 0 .. 0ff(16),
          fill4: 0 .. 3fff(16),
          a1: 0 .. 3(16),
          a2: 0 .. 0ff(16),
          a3: 0 .. 0ff(16),
        RECEND;

      VAR
        temp_apqk_buffer: temp_apqk_hold;

      copy_memory (cm_header, ^temp_apqk_buffer);

{  Move registers to the output buffer.

      output_buffer [0] := temp_apqk_buffer.p1;
      output_buffer [1] := temp_apqk_buffer.p2;
      output_buffer [2] := temp_apqk_buffer.q1;
      output_buffer [3] := temp_apqk_buffer.q2 * 10(16) + temp_apqk_buffer.q3;
      output_buffer [4] := temp_apqk_buffer.k1;
      output_buffer [5] := temp_apqk_buffer.k2;
      output_buffer [6] := temp_apqk_buffer.a1;
      output_buffer [7] := temp_apqk_buffer.a2;
      output_buffer [8] := temp_apqk_buffer.a3;

   PROCEND move_apqk_to_output_record;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure move_ch_status_to_output_record', EJECT ??

{ PURPOSE:
{   Read the channel status data and format it into the EDD output
{   buffer.

    PROCEDURE move_ch_status_to_output_record
      (VAR cm_header: memory_copy_header;
       VAR output_buffer: 0 .. 0f(16));

{  When the channel status is copied from 64 to 60 bit memory, the status
{  is at the beginning of the second 60-bit word.  Therefore, in the
{  following record the integers simply create fill for unused areas.

      TYPE
        temp_status_hold = PACKED RECORD
          fill1: integer,
          status: 0 .. 0f(16),
          fill2: integer,
        RECEND;

      VAR
        temp_status_buffer: temp_status_hold;

      copy_memory (cm_header, ^temp_status_buffer);
      output_buffer := temp_status_buffer.status;

   PROCEND move_ch_status_to_output_record;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure dump_iou_contents', EJECT ??

{ PURPOSE:
{   Dump the A, P, Q and K registers and the contents of each pp
{   assigned to NOS/VE.  Also, dump the channel status for each
{   channel assigned to NOS/VE.

    PROCEDURE dump_iou_contents
      (    iou_number: dst$iou_number;
           iou_port_code: 0 .. 0fff(16);
           cri: integer);

{  Define the type definition for the DFT requests to dump PP information
{  and channel status.  In the DFT world these are 64 bit word  structures
{  but are defined such that the requests can be constructed in 60 bit and
{  each 60 bit word is moved into a 64 bit word right justified.

      TYPE
        dft_request_block = PACKED RECORD
          CASE dft_request_block_types OF
          = pp_utility_functions =

{  Word 0.

            pp_dft_response: 0 .. 0f(16),
            pp_dft_function: 0 .. 0ff(16),
            pp_iou_number: 0 .. 0ff(16),
            cio: 0 .. 0ff(16),
            pp_number: 0 .. 0ff(16),
            subfunction: 0 .. 0ff(16),
            pp_resume_address: 0 .. 0ffff(16),

{  Word 1.

            pp_dump_buffer: dst$r_pointer,
          = channel_status_function =

{  Word 0.

            c_dft_response: 0 .. 0f(16),
            c_dft_function: 0 .. 0ff(16),
            c_iou_number: 0 .. 0ff(16),
            channel_number: 0 .. 0ff(16),
            fill2: 0 .. 0ffffffff(16),

{  Word 1.

            c_dump_buffer: dst$r_pointer,
          CASEND,
        RECEND;

      TYPE
        dft_request_block_types = (pp_utility_functions,
                                   channel_status_function);

      CONST
        apqk_register_bytes_per_pp = 9,
        apqk_register_bytes_per_record = apqk_register_bytes_per_pp * 2 *
              max_pps_in_record,
        ch_status_bytes_per_record = max_channels_in_record * 2,
        cio_pp = 1,
        csf_record_cm_word_size = (max_channels_in_record * 8 * 2 + 59) DIV 60,
        data_rec_length_for_i4_mem = 2188,
        data_rec_length_for_non_i4_mem = 1096,
        dft_request_length = 2,
        max_channels_in_record = 38,
        max_number_of_nio_chs = 28,
        max_number_of_cio_chs = 10,
        max_number_of_nio_pps = 20,
        max_number_of_cio_pps = 10,
        max_pps_in_record = max_number_of_nio_pps + max_number_of_cio_pps,
        nio_pp = 0,
        prb_record_cm_word_size = ((apqk_register_bytes_per_pp * 2) *
              max_pps_in_record) DIV 5;

      VAR
        addr: integer,
        apqk_data: PACKED ARRAY [0 .. apqk_register_bytes_per_pp - 1]
              OF 0 .. 0fff(16),
        assigned_chs_buffer: ARRAY [1 .. max_channels_in_record] OF
              iou_resource,
        channel_data: 0 .. 0f(16),
        cm_header: memory_copy_header,

{  In the dump output record, the channel status is four bits and is right
{  justified in an 8-bit byte (ie 4/fill, 4/status).  If these 8-bit
{  bytes are packed into 60-bit words (170 CYBIL) there are four bits
{  left over in each word.  Therefore, the following variable is defined
{  in terms of 4-bit fields and the length is multiplied by 2.

        csf_buffer: PACKED RECORD
          tape_block_header: cell,
          channel_status: PACKED ARRAY [0 ..
                (ch_status_bytes_per_record * 2) - 1] OF 0 .. 0f(16),
        RECEND,
        dft_channel_request_block: dft_request_block,
        dft_pp_request_block: dft_request_block,
        entry: integer,
        i: integer,
        i4_present: boolean,
        i4c_present: boolean,
        j: integer,
        length: integer,
        logical_pp_number_base_8: 0 .. 31,
        max_number_of_chs: max_number_of_nio_chs .. max_number_of_nio_chs +
              max_number_of_cio_chs,
        max_number_of_pps: max_number_of_nio_pps .. max_number_of_nio_pps +
              max_number_of_cio_pps,
        mppn:  0 .. 31,  {  Temporary used to compute logical pp number(8)
        offset: integer,
        pp_buffer: PACKED RECORD
          tape_header_block: cell,
          memory: ALIGNED PACKED ARRAY [1 .. 2200] OF integer,
        RECEND,
        pp_size_cm_words: 0 .. 16383,
        pp_register_buffer: PACKED RECORD
          tape_header_block: cell,
          apqk_data: PACKED ARRAY [0 .. apqk_register_bytes_per_record - 1]
                OF 0 .. 0fff(16),
        RECEND,
        record_id: string (3),
        ver_channel_request: ver_request_block;

      IF nve_memory = 0 THEN
        RETURN;
      IFEND;

{  The IOU record will determine PP size based on IOU model number.
{  SDA dumps only 4K of NIO PPs because they have the 4K attribute
{  and the second 4K cannot be dumped.

      CASE configuration_record [cri].iou.element_id.model_number OF
      = osc$imn_40 =
        i4_present := TRUE;
        i4c_present := FALSE;
      = osc$imn_44 =
        i4_present := FALSE;
        i4c_present := TRUE;
      = osc$imn_42 =
        i4_present := TRUE;
        i4c_present := FALSE;
      ELSE
        i4_present := FALSE;
        i4c_present := FALSE;
      CASEND;

{  Obtain the 170 OS EICB version number.  If the value has already been
{  obtained (it is kept in a global variable external to this common deck),
{  then it will not be retrieved again.  Starting with version 4, a
{  distinction is made between driver and non-driver PP's on an 810/830, and
{  concurrent PP's and channels  may be present.  Due to these changes, there
{  is a new set of VER requests to be used; however, for compatibility, the
{  old versions of the requests need to be used when run with a 170 OS EICB
{  version number less than 4.

      IF NOT got_eicb_d7ty THEN
        get_dscb(dscb_d7ty, ^d7ty, 1);
        { the eicb entry d7ty.eicb_version will be used to choose VER functions
        got_eicb_d7ty:= TRUE;
      IFEND;
      IF (d7ty.eicb_version < dsc$eicb_version_4) OR i4c_present THEN
        max_number_of_pps := max_number_of_nio_pps;
        max_number_of_chs := max_number_of_nio_chs;
      ELSE
        max_number_of_pps := max_number_of_nio_pps + max_number_of_cio_pps;
        max_number_of_chs := max_number_of_nio_chs + max_number_of_cio_chs;
      IFEND;

{  Determine which PPs and channels are assigned to NOS/VE.

      determine_assigned_channels (max_number_of_chs - 4, iou_number,
            ver_channel_request);
      determine_assigned_pps (max_number_of_pps, iou_number, cri);

{  Move the assigned channels data to the assigned_chs_buffer which contains
{  space for channels 14(8) - 17(8).

      FOR i := 1 TO max_number_of_chs DO
        IF i < 12 THEN

{  Process channel data for channels 0 - 13(8).

          assigned_chs_buffer [i] := ver_channel_request.channels [i];

        ELSEIF i < 16 THEN

{  Set channel status for channels 14(8) - 17(8) to not assigned.

          assigned_chs_buffer [i].status := 2;

        ELSE

{  Process channel data for channels 20(8) and up.

          assigned_chs_buffer [i] := ver_channel_request.channels [i - 4];

        IFEND;
      FOREND;

      cm_header.pva_type := dft_request_pva_type;
      cm_header.byte_rma := dft_request_byte_rma +
            (dft_request_length * 8);
      dyfstrnum ('Dump IOU', iou_number, user_dayf);

{  Zero out pp register buffer.  This is the structure that will hold the A,
{  P, Q and K register data until the record is written to the dump file.

      FOR i := 0 TO apqk_register_bytes_per_record - 1 DO
        pp_register_buffer.apqk_data [i] := 0;
      FOREND;

{  Zero out csf_record.  This is the structure that will hold the channel
{  status data until the record is written to the dump file.

      FOR i := 0 TO (ch_status_bytes_per_record - 1) * 2 DO
        csf_buffer.channel_status [i] := 0;
      FOREND;

      pp_table.ve_dft_request_p.offset := dft_request_r_pointer.offset;
      pp_table.ve_dft_request_p.rupper := dft_request_r_pointer.rupper;
      pp_table.ve_dft_request_p.rlower := dft_request_r_pointer.rlower;

{  Initialize SDA request block for function write_dft_request_block.

      pp_table.dft_request_length := dft_request_length;
      pp_table.os_170_dft_request_p := ^dft_pp_request_block;

{  Initialize DFT PP request block to dump APQK only.  The APQK data will
{  be dumped to the SSR PP buffer following the DFT request block.
{  Therefore, the dump buffer r-register offset must be incremented by the
{  length of the DFT request block.

      dft_pp_request_block.pp_dft_function := dsc$dft_process_pp_function;
      dft_pp_request_block.pp_iou_number := iou_number;
      dft_pp_request_block.cio := 0;
      dft_pp_request_block.subfunction := dsc$dpuf_dump_pp_registers;
      dft_pp_request_block.pp_dump_buffer := dft_request_r_pointer;
      dft_pp_request_block.pp_dump_buffer.offset :=
            dft_pp_request_block.pp_dump_buffer.offset + dft_request_length;
      dft_pp_request_block.pp_dump_buffer.length := data_rec_length_for_i4_mem;

{  Initialize DFT channel request block.  The channel status data will
{  be dumped to the SSR PP buffer following the DFT request block.
{  Therefore, the dump buffer r-register offset must be incremented by the
{  length of the DFT request block.

      dft_channel_request_block.c_dft_function :=
            dsc$dft_get_nio_channel_status;
      dft_channel_request_block.c_iou_number := iou_number;
      dft_channel_request_block.fill2 := 0;
      dft_channel_request_block.c_dump_buffer :=
            dft_pp_request_block.pp_dump_buffer;

{  Loop through the PPs and dump the pre-idle set of A,P,Q and K
{  registers for each NOS/VE PP.  DFT dumps the register data to
{  dsc$ssr_pp_controlware_buf in the SSR.  The data is then
{  copied from the SSR, packing the 64 bit data into 60 bit words,
{  and is stored in pp register buffer.

      cm_header.copy_method := ve64_to_nos60;
      cm_header.length := 2;

    /before_idle_apqk_loop/
      FOR i := 0 TO max_number_of_pps - 1 DO
        IF ver_request.pps [i+1].status <= 1 THEN
          IF (i > 19) OR i4c_present THEN
            dft_pp_request_block.cio := cio_pp;
          ELSE
            dft_pp_request_block.cio := nio_pp;
          IFEND;
          dft_pp_request_block.pp_number := ver_request.pps [i+1].primary;
          dft_pp_request_block.pp_dft_response := 0;
          callsda (write_dft_request_block, pp_table);

          IF dft_pp_request_block.pp_dft_response =
                normal_dft_response THEN
            move_apqk_to_output_record (cm_header, apqk_data);
          ELSE

{  DFT request did not complete normally, set all values to a default of zero.

            FOR j := 0 TO 8 DO
              apqk_data [j] := 0;
            FOREND;
          IFEND;

          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2]
                := apqk_data [0];
          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2 + 1]
                := apqk_data [1];
          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2 + 2]
                := apqk_data [2];
          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2 + 3]
                := apqk_data [3];
          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2 + 4]
                := apqk_data [4];
          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2 + 5]
                := apqk_data [5];
          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2 + 6]
                := apqk_data [6];
          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2 + 7]
                := apqk_data [7];
          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2 + 8]
                := apqk_data [8];

        IFEND;
      FOREND /before_idle_apqk_loop/;

{  Get pre-idle channel status.

    /before_idle_ch_status_loop/
      FOR i := 0 TO max_number_of_chs - 1 DO
        IF assigned_chs_buffer [i+1].status <= 1 THEN
          IF (i > 27) OR i4c_present THEN

{  CIO channel - get channel status from the corresponding B or C register.

            get_cio_channel_status (assigned_chs_buffer [i+1].primary,
                  iou_number, iou_port_code, channel_data);

          ELSE

{  NIO channel - get channel status through DFT request.

            dft_channel_request_block.channel_number :=
                  assigned_chs_buffer [i+1].primary;
            pp_table.dft_request_length := dft_request_length;
            pp_table.os_170_dft_request_p := ^dft_channel_request_block;
            dft_channel_request_block.c_dft_response := 0;
            callsda (write_dft_request_block, pp_table);

            IF dft_channel_request_block.c_dft_response =
                  normal_dft_response THEN
              move_ch_status_to_output_record (cm_header, channel_data);
            ELSE

{  DFT request did not complete normally, set channel status to zero.

              channel_data := 0;
            IFEND;
          IFEND;
          csf_buffer.channel_status [(i * 2) + 1] := channel_data;
        IFEND;
      FOREND /before_idle_ch_status_loop/;

{  Set DFT request block to idle PP only.

      dft_pp_request_block.subfunction := dsc$dpuf_idle_pp;
      pp_table.os_170_dft_request_p := ^dft_pp_request_block;
      pp_table.dft_request_length := dft_request_length;

{  Idle all NOS/VE PPs.

    /idle_pp_loop/
      FOR i := 0 TO max_number_of_pps - 1 DO
        IF ver_request.pps [i+1].status <= 1 THEN
          IF (i > 19) OR i4c_present THEN
            dft_pp_request_block.cio := cio_pp;
          ELSE
            dft_pp_request_block.cio := nio_pp;
          IFEND;
          dft_pp_request_block.pp_number := ver_request.pps [i+1].primary;
          dft_pp_request_block.pp_dft_response := 0;
          callsda (write_dft_request_block, pp_table);

          IF dft_pp_request_block.pp_dft_response <> normal_dft_response THEN

{  DFT request did not complete normally, issue dayfile message and continue.

            IF (dft_pp_request_block.cio = nio_pp) OR i4c_present THEN
              dyfstrnum ('Unable to idle pp', i, user_dayf);
            ELSE
              dyfstrnum ('Unable to idle CIO pp', i, user_dayf);
            IFEND;
          IFEND;
        IFEND;
      FOREND /idle_pp_loop/;

{  Get post-idle channel status.

    /after_idle_ch_status_loop/
      FOR i := 0 TO max_number_of_chs - 1 DO
        IF assigned_chs_buffer [i+1].status <= 1 THEN
          IF (i > 27) OR i4c_present THEN

{  CIO channel - get channel status from the corresponding B or C register.

            get_cio_channel_status (assigned_chs_buffer [i+1].primary,
                  iou_number, iou_port_code, channel_data);

          ELSE

{  NIO channel - get channel status through DFT request.

            dft_channel_request_block.channel_number :=
              assigned_chs_buffer [i+1].primary;
            pp_table.dft_request_length := dft_request_length;
            pp_table.os_170_dft_request_p := ^dft_channel_request_block;
            dft_channel_request_block.c_dft_response := 0;
            callsda (write_dft_request_block, pp_table);

            IF dft_channel_request_block.c_dft_response =
                  normal_dft_response THEN
              move_ch_status_to_output_record (cm_header, channel_data);
            ELSE

{  DFT request did not complete normally, set channel status to zero.

              channel_data := 0;
            IFEND;
          IFEND;
          csf_buffer.channel_status [(i * 2) + ch_status_bytes_per_record + 1]
                := channel_data;
        IFEND;
      FOREND /after_idle_ch_status_loop/;

{  Set DFT request block to dump APQK registers and PP memory.

      dft_pp_request_block.subfunction := dsc$dpuf_idle_dump_pp;
      pp_table.os_170_dft_request_p := ^dft_pp_request_block;
      pp_table.dft_request_length := dft_request_length;

{  Loop through the PPs and dump the post-idle set of A,P,Q and K registers
{  and the memory for each NOS/VE PP.  DFT dumps the register data and PP
{  memory to dsc$ssr_pp_controlware_buf in the SSR.  The register data is
{  copied from the SSR, packing the 64 bit data into 60 bit words and
{  storing it in pp register buffer.  Then the PP memory is copied from the
{  SSR to pp buffer, packing the 64 bit SSR contents into 60 bit words.

{  Zero out the pp buffer so that if dumping 8K NIO PPs the second half
{  will be all zeros.

      FOR i := LOWERBOUND(pp_buffer.memory) to UPPERBOUND(pp_buffer.memory) DO
        pp_buffer.memory [i] := 0;
      FOREND;

    /after_idle_apqk_and_memory_loop/
      FOR i := 0 TO max_number_of_pps - 1 DO
        IF ver_request.pps [i+1].status <= 1 THEN
          mppn := ver_request.pps [i+1].primary;
          logical_pp_number_base_8 := (mppn DIV 8) * 10 + mppn MOD 8;
          IF (i > 19) OR i4c_present THEN  { CIO PP being dumped
            dft_pp_request_block.cio := cio_pp;
            pp_size_cm_words := data_rec_length_for_i4_mem;
          ELSE  { NIO PP being dumped
            dft_pp_request_block.cio := nio_pp;
            IF i4_present OR i4c_present THEN
              pp_size_cm_words := data_rec_length_for_i4_mem;
            ELSE
              pp_size_cm_words := data_rec_length_for_non_i4_mem;
            IFEND;
          IFEND;

          dft_pp_request_block.pp_number := ver_request.pps [i+1].primary;
          dft_pp_request_block.pp_dft_response := 0;
          callsda (write_dft_request_block, pp_table);
          cm_header.length := 2;

          IF dft_pp_request_block.pp_dft_response = normal_dft_response THEN
            move_apqk_to_output_record (cm_header, apqk_data);
          ELSE

{  DFT request did not complete normally, set all values to a default of zero.

            FOR j := 0 TO 8 DO
              apqk_data [j] := 0;
            FOREND;
          IFEND;

          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 0] := apqk_data [0];
          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 1] := apqk_data [1];
          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 2] := apqk_data [2];
          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 3] := apqk_data [3];
          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 4] := apqk_data [4];
          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 5] := apqk_data [5];
          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 6] := apqk_data [6];
          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 7] := apqk_data [7];
          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 8] := apqk_data [8];

          IF dft_pp_request_block.pp_dft_response = normal_dft_response THEN

{  Increment cm_header.byte_rma to point past the A,P,Q,K data
{  to the beginning of the PP memory and set the correct length.
{  Note that on an i4c the PPs must be treated as CIO in the
{  DFT requests since that is how DFT treats them.  However, as
{  far as constructing the dump record, they are treated as NIO
{  so the analyst will not have to specify the pp type parameter
{  when using the analyze dump utility.

            cm_header.byte_rma := cm_header.byte_rma + (2 * 8);
            IF i > 19 THEN  { CIO PP being dumped.
              dyfstrnum ('CPP dumped', logical_pp_number_base_8, user_dayf);
              record_id(1) := $CHAR (iou_number + $INTEGER ('D'));

{  Pack all 8K for CIO PPs.

              cm_header.length := data_rec_length_for_i4_mem;
            ELSE  { NIO PP being dumped.
              dyfstrnum ('PP dumped', logical_pp_number_base_8, user_dayf);
              record_id(1) := $CHAR (iou_number + $INTEGER ('I'));

{  Pack only 4K for NIO PPs except for the I4C.

              IF i4c_present THEN
                cm_header.length := data_rec_length_for_i4_mem;
              ELSE
                cm_header.length := data_rec_length_for_non_i4_mem;
              IFEND;
            IFEND;

            record_id(2) := $CHAR (logical_pp_number_base_8 DIV 10 +
                  $INTEGER ('0'));
            record_id(3) := $CHAR (logical_pp_number_base_8 MOD 10 +
                  $INTEGER ('0'));
            format_edd_header (record_id, 0, 0);
            copy_memory (cm_header, ^pp_buffer.memory);
            bi#put_tape (vedump, ^pp_buffer, pp_size_cm_words);

{  Decrement cm_header.byte_rma back to the A,P,Q,K data.

            cm_header.byte_rma := cm_header.byte_rma - (2 * 8);
          IFEND;
        IFEND;
      FOREND /after_idle_apqk_and_memory_loop/;

{  Write PSR (APQK registers) and CSF (channel status) records.

      IF iou_number <> 0 THEN
        STRINGREP (record_id (1, 3), length, iou_number:3);
        record_id (1, 2) := 'PS';  { Set header ID for secondary IOU.
      ELSE
        record_id (1, 3) := 'PSR';  { Set header ID for primary IOU.
      IFEND;

      format_edd_header (record_id, 0, 0);
      bi#put_tape (vedump, ^pp_register_buffer, prb_record_cm_word_size);

      IF iou_number <> 0 THEN
        STRINGREP (record_id (1, 3), length, iou_number:3);
        record_id (1, 2) := 'CS';  { Set header ID for secondary IOU.
      ELSE
        record_id (1, 3) := 'CSF';  { Set header ID for primary IOU.
      IFEND;

      format_edd_header (record_id, 0, 0);
      bi#put_tape (vedump, ^csf_buffer, csf_record_cm_word_size);

    PROCEND dump_iou_contents;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure dump_mem_registers', EJECT ??

{ PURPOSE:
{   Dump the memory maintenance registers.

    PROCEDURE dump_mem_registers
      (    cm_info: dst$cc_central_memory_info);

      CONST
        base_number_of_mmr_to_dump = 6,
        max_number_of_mmr = 13;

      VAR
        i: 1 .. max_number_of_mmr,
        mem_registers: [STATIC] PACKED ARRAY [1 .. max_number_of_mmr]
          OF 0 .. 7777(8) := [0, 10(16), 12(16), 20(16), 21(16), 0a0(16),
          0a1(16), 0a2(16), 0a3(16), 0a4(16), 0a5(16), 0a6(16), 0a7(16)],
        number_of_mmr_to_dump: 1 .. max_number_of_mmr;

{  Process Memory Maintenance registers. (MMR)

      dyfstring ('DUMPING CM', debug_log);

      format_edd_header ('MMR', 0, 0);

      CASE cm_info.element_id.model_number OF

      = osc$cmmn_40, osc$cmmn_41, osc$cmmn_42 = { 990/990E/994/995E
        number_of_mmr_to_dump := base_number_of_mmr_to_dump + 7;

      ELSE

        mem_registers[base_number_of_mmr_to_dump+1] := 0a4(16);
        mem_registers[base_number_of_mmr_to_dump+2] := 0a8(16);
        number_of_mmr_to_dump := base_number_of_mmr_to_dump + 2;

      CASEND;

      FOR i := 1 TO number_of_mmr_to_dump DO
        read_register (register_block_buffer.register [i], mem_registers [i],
               NIL, 0, cm_info.port_code);
      FOREND;
      register_block_buffer.register [number_of_mmr_to_dump + 1] [1] := 0;

      bi#put_tape (vedump, ^register_block_buffer,
            (number_of_mmr_to_dump * 2) + 1);

    PROCEND dump_mem_registers;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure determine_dft_block_length', EJECT ??

{ PURPOSE:
{   Determine the length of the entire DFT block and each buffer making up
{   the DFT block.

    PROCEDURE determine_dft_block_length
      (    number_of_dft_buffers_to_dump: integer;
           dft_control_word: dst$dft_control_word;
       VAR dft_buffer_length_words: integer;
       VAR dft_buffer_lengths_p: ^ARRAY [ 0 .. * ] OF integer);

      VAR
        cm_header: memory_copy_header,
        dft_bi: integer,
        dftb_p_word: r_register_format;

      set_ei_pva (start_of_dft_buffer_0, 1);
      cm_header.byte_rma := 0;
      cm_header.length := 1;
      cm_header.copy_method := ve60_to_nos60;
      cm_header.pva_type := dft_buffer;
      dft_buffer_length_words := 0;

{  Get the length of the fixed part of the DFT buffer.  The length of the
{  fixed part of the DFT buffer has to be determined in one of two ways
{  depending on the revision level of the DFT block.  The PO field was
{  added at revision level 2.

        IF dft_control_word.rl < 2 THEN
          dft_buffer_length_words := dft_buffer_length_words +
                dft_control_word.nbuf + ((dsc$db_fixed_length +
                dsc$db_mainframe_element_l) DIV 8);
          dft_buffer_lengths_p^[0] := dsc$db_fixed_length +
                 dsc$db_mainframe_element_l + (dft_control_word.nbuf * 8);
        ELSEIF dft_control_word.rl < 4 THEN
          dft_buffer_length_words := dft_buffer_length_words +
                dft_control_word.nbuf + dft_control_word.po +
                (dsc$db_mainframe_element_l DIV 8);
          dft_buffer_lengths_p^[0] := ((dft_control_word.po +
                dft_control_word.nbuf) * 8) + dsc$db_mainframe_element_l;
        ELSE
          dft_buffer_length_words := dft_buffer_length_words +
                dft_control_word.po;
          dft_buffer_lengths_p^[0] := (dft_control_word.po * 8);
        IFEND;

{  Determine length of each variable DFT buffer.

        FOR dft_bi := (LOWERBOUND(dft_buffer_lengths_p^) + 1) TO
              number_of_dft_buffers_to_dump - 1 DO
          cm_header.byte_rma := cm_header.byte_rma + 8;
          copy_memory (cm_header, #LOC(dftb_p_word));
          dft_buffer_length_words := dft_buffer_length_words +
                dftb_p_word.length;
          dft_buffer_lengths_p^[dft_bi] := dftb_p_word.length * 8;
        FOREND;

    PROCEND determine_dft_block_length;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure dump_critical_page_table', EJECT ??

{ PURPOSE:
{   Dump the critical page table.

    PROCEDURE dump_critical_page_table
      (    page_size_mask: 0 .. 177(8));

      CONST
        dump_block_size_bytes = dump_block_size * 15 DIV 2;

      VAR
        bytes_dumped_so_far: integer,
        cm_header: memory_copy_header,
        cptp_rma: integer,
        dump_length_60_bit_words: integer,
        dump_length_8_bit_bytes: integer,
        memory_buffer: PACKED RECORD
             tape_block_header: cell,
             words: ALIGNED PACKED ARRAY [1 .. dump_block_size] OF integer,
        RECEND,
        total_record_length: integer;

{  Determine the number of 170 CM words to dump.  This value must be
{  a multiple of 2 because of the conversion algorithm used by EI.
{  If it is not a multiple of 2 170 CM words, EI will abort the job.

      dump_length_60_bit_words := (cptp_r_pointer.length * 64) DIV 60;
      IF ((cptp_r_pointer.length * 64) MOD 60) <> 0 THEN
        dump_length_60_bit_words := dump_length_60_bit_words + 1;
      IFEND;
      IF (dump_length_60_bit_words MOD 2) <> 0 THEN
        dump_length_60_bit_words := dump_length_60_bit_words + 1;
      IFEND;
      format_edd_header ('CPT', page_size_mask, cptp_r_pointer.length);

{  Determine the rma of the critical page table.

      cptp_rma := cptp_r_pointer.rupper * 10000000(8) + cptp_r_pointer.rlower *
           1000(8) + cptp_r_pointer.offset * 10(8);

      dump_length_8_bit_bytes := (cptp_r_pointer.length * 8);
      bytes_dumped_so_far := 0;
      total_record_length := 0;
      cm_header.length := dump_block_size;
      cm_header.copy_method := ve64_to_nos60;
      cm_header.pva_type := start_of_ve;
      cm_header.byte_rma := cptp_rma - load_offset_bytes;

      WHILE (bytes_dumped_so_far + dump_block_size_bytes) < dump_length_8_bit_bytes DO
        copy_memory (cm_header, ^memory_buffer.words);
        bi#put_tape (vedump, ^memory_buffer, #SIZE (memory_buffer.words));
        cm_header.byte_rma := cm_header.byte_rma + dump_block_size_bytes;
        total_record_length := total_record_length + #SIZE (memory_buffer.words);
        bytes_dumped_so_far := bytes_dumped_so_far + dump_block_size_bytes;
      WHILEND;

{  Dump the remainder of the critical page table.

      cm_header.length := dump_length_60_bit_words - total_record_length;
      copy_memory (cm_header, ^memory_buffer.words);

      bi#put_tape (vedump, ^memory_buffer, cm_header.length);

    PROCEND dump_critical_page_table;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure dump_critical_memory', EJECT ??

{ PURPOSE:
{   Dump only the critical NOS/VE memory as defined by the critical page table.

    PROCEDURE dump_critical_memory
      (    page_size_mask: 0 .. 177(8));

      CONST
        dump_block_size_bytes = dump_block_size * 15 DIV 2;

      VAR
        bit_index: 0 .. 63,
        bytes_dumped_so_far: integer,
        cm_header: memory_copy_header,
        cpt_header: memory_copy_header,
        cpt_word: PACKED ARRAY [0 .. 119] OF 0 .. 1,
        cptp_rma: integer,
        end_of_word_reached: boolean,
        fill_words_in_last_page: integer,
        index: 1 .. 7,
        last_page_bit_index: 0 .. 63,
        last_page_found: boolean,
        last_page_length_60_bit_words: integer,
        last_page_length_8_bit_bytes: integer,
        last_page_word_index: integer,
        mask: integer,
        memory_buffer: PACKED RECORD
          tape_block_header: cell,
          words: ALIGNED PACKED ARRAY [1 .. dump_block_size] OF integer,
        RECEND,
        page_dump_length_60_bit_words: integer,
        page_dump_length_8_bit_bytes: integer,
        page_frame_number: integer,
        page_frame_number_left: integer,
        page_frame_number_right: integer,
        page_rma: integer,
        page_size: integer,
        total_record_length: integer,
        word_index: integer;

      dyfstring ('cm dump - critical memory.', system_dayf);

{  Determine the page size from the page size mask.

      page_size := 512;
      mask := page_size_mask;

      FOR index := 1 TO 7 DO
        IF (mask MOD 2) = 0 THEN
          page_size := page_size * 2;
          mask := mask DIV 2;
        IFEND;
      FOREND;

{  Initialize copy memory parameters for reading each word of the critical page table.

      cpt_header.length := 2;
      cpt_header.copy_method := ve64_to_nos60;
      cpt_header.pva_type := start_of_ve;
      cptp_rma := cptp_r_pointer.rupper * 10000000(8) + cptp_r_pointer.rlower *
           1000(8) + cptp_r_pointer.offset * 10(8);
      cpt_header.byte_rma := cptp_rma - load_offset_bytes + (cptp_r_pointer.length - 1);

{  Initialize parameters for reading each page of memory.

      page_dump_length_60_bit_words := ((page_size DIV 8) * 64) DIV 60;
      IF (((page_size DIV 8) * 64) MOD 60) <> 0 THEN
        page_dump_length_60_bit_words := page_dump_length_60_bit_words + 1;
      IFEND;
      IF (page_dump_length_60_bit_words MOD 2) <> 0 THEN
        page_dump_length_60_bit_words := page_dump_length_60_bit_words + 1;
      IFEND;
      page_dump_length_8_bit_bytes := (page_dump_length_60_bit_words * 60) DIV 8;

      last_page_length_60_bit_words := ((page_size DIV 8) * 64) DIV 60;
      fill_words_in_last_page := 0;
      IF (((page_size DIV 8) * 64) MOD 60) <> 0 THEN
        fill_words_in_last_page := 1;
      IFEND;
      IF (last_page_length_60_bit_words MOD 2) <> 0 THEN
        last_page_length_60_bit_words := last_page_length_60_bit_words - 1;
        fill_words_in_last_page := fill_words_in_last_page + 1;
      IFEND;
      last_page_length_8_bit_bytes := (last_page_length_60_bit_words * 60) DIV 8;

      cm_header.copy_method := ve64_to_nos60;
      cm_header.pva_type := start_of_ve;

{  Find the bit that corresponds to the last page of NOS/VE assigned memory.  Memory must be
{  dumped in 60 bit words and EI requires an even number of 60 bit words to be dumped.  Therefore,
{  if the number of 64 bit words does not fit exactly into 60 bit words or if the number of 60 bit
{  words is not even, then the number of 60 bit words is rounded up.  This works fine for all pages
{  except the last page of NOS/VE assigned memory.  Rounding up for the last page would cause an
{  attempt to dump a few bytes past the end of NOS/VE assigned memory and EI would abort the NVE
{  subsystem.  Therefore, for the last page only, the number of 60 bit words is rounded down instead
{  of up when copied through EI.  Then when written to the dump tape, an extra word of fill is
{  written, if necessary, to ensure that the dump tape record is at least a full page.

      cpt_header.byte_rma := cptp_rma - load_offset_bytes + ((cptp_r_pointer.length - 1) * 8);
      word_index := cptp_r_pointer.length - 1;
      last_page_found := FALSE;
      WHILE NOT last_page_found DO
        copy_memory (cpt_header, ^cpt_word);
        cpt_header.byte_rma := cpt_header.byte_rma - 8;

{  Scan this word backwards to see if it contains the last bit set in the critical page table.

        bit_index := 63;
        end_of_word_reached := FALSE;
        WHILE NOT end_of_word_reached DO
          IF cpt_word [bit_index] = 1 THEN
            last_page_word_index := word_index;
            last_page_bit_index := bit_index;
            last_page_found := TRUE;
            end_of_word_reached := TRUE;
          IFEND;
          IF bit_index = 0 THEN
            end_of_word_reached := TRUE;
          ELSE
            bit_index := bit_index - 1;
          IFEND;
        WHILEND;
        word_index := word_index - 1;
      WHILEND;

{  Scan the critical page table and dump the corresponding page of memory for each bit that is set.

      cpt_header.byte_rma := cptp_rma - load_offset_bytes;
      FOR word_index := 0 TO cptp_r_pointer.length - 1 DO

{  Get the next word from the critical page table.

        copy_memory (cpt_header, ^cpt_word);
        cpt_header.byte_rma := cpt_header.byte_rma + 8;

{  Scan each bit in this critical page table word.  If set, then dump the corresponding page of memory.

        FOR bit_index := 0 TO 63 DO
          IF cpt_word [bit_index] = 1 THEN

{  Determine the page frame number and write the EDD header record.

            page_frame_number := word_index * 64 + bit_index;
            page_frame_number_left := page_frame_number DIV 1000000(8);
            page_frame_number_right := page_frame_number MOD 1000000(8);
            format_edd_header ('CCM', page_frame_number_left, page_frame_number_right);

{  Copy the page of memory to the dump tape.

            bytes_dumped_so_far := 0;
            total_record_length := 0;
            page_rma := page_frame_number * page_size;
            cm_header.byte_rma := page_rma - load_offset_bytes;
            cm_header.length := dump_block_size;

            IF (word_index <> last_page_word_index) OR (bit_index <> last_page_bit_index) THEN

              WHILE (bytes_dumped_so_far + dump_block_size_bytes) < page_dump_length_8_bit_bytes DO
                copy_memory (cm_header, ^memory_buffer.words);
                bi#put_tape (vedump, ^memory_buffer, #SIZE (memory_buffer.words));
                cm_header.byte_rma := cm_header.byte_rma + dump_block_size_bytes;
                total_record_length := total_record_length + #SIZE (memory_buffer.words);
                bytes_dumped_so_far := bytes_dumped_so_far + dump_block_size_bytes;
              WHILEND;

{  Dump the remainder of the critical page.

              cm_header.length := page_dump_length_60_bit_words - total_record_length;
              copy_memory (cm_header, ^memory_buffer.words);

              bi#put_tape (vedump, ^memory_buffer, cm_header.length);

            ELSE

{  Dump the last page of NOS/VE memory.

              WHILE (bytes_dumped_so_far + dump_block_size_bytes) < last_page_length_8_bit_bytes DO
                copy_memory (cm_header, ^memory_buffer.words);
                bi#put_tape (vedump, ^memory_buffer, #SIZE (memory_buffer.words));
                cm_header.byte_rma := cm_header.byte_rma + dump_block_size_bytes;
                total_record_length := total_record_length + #SIZE (memory_buffer.words);
                bytes_dumped_so_far := bytes_dumped_so_far + dump_block_size_bytes;
              WHILEND;

{  Dump the remainder of the last page.

              cm_header.length := last_page_length_60_bit_words - total_record_length;
              copy_memory (cm_header, ^memory_buffer.words);

              IF (((page_size DIV 8) * 64) MOD 60) <> 0 THEN

{  A word of fill is needed.

                bi#put_tape (vedump, ^memory_buffer, cm_header.length + 1);

              ELSE

                bi#put_tape (vedump, ^memory_buffer, cm_header.length);

              IFEND;
            IFEND;
          IFEND;
        FOREND;
      FOREND;

    PROCEND dump_critical_memory;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure get_page_size_mask', EJECT ??

{ PURPOSE:
{   Get the page size mask from the CPU register, 4A.

    PROCEDURE get_page_size_mask
      (VAR page_size_mask: 0 .. 177(8));

      VAR
        cpu_port_code: 0 .. 0fff(16),
        cpu_register_4a_contents: edd_register_format,
        index: integer,
        port_code_found: boolean;

{  Find a CPU port code to use.

      port_code_found := FALSE;
      index := LOWERBOUND(configuration_record);
      REPEAT
        CASE configuration_record [index].processor.id OF
        = dsc$id_processor_info =
          port_code_found := TRUE;

        ELSE

          index := index + 1;

        CASEND;

      UNTIL port_code_found = TRUE;

      cpu_port_code := configuration_record [index].processor.port_code;

{  Read CPU register 4A.

      read_register (cpu_register_4a_contents, 4A(16), ssr_registers, 0, cpu_port_code);
      page_size_mask := cpu_register_4a_contents [10];

    PROCEND get_page_size_mask;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure dump_memory', EJECT ??

{ PURPOSE:
{   Dump the memory used by NOS/VE (if specified by the *DUMP= command), the DFT buffers
{   if they exist and the EI control block (EICB).

    PROCEDURE dump_memory;

      CONST
        dump_block_size_bytes = dump_block_size * 15 DIV 2;

      TYPE
        dst$dscb_d7ty = PACKED RECORD
          fill: 0 .. 3f(16),
          date: 0 .. 3ffff(16),
          time: 0 .. 3ffff(16),
          os_type_170: 0 .. 3f(16),
          interface_block_version_number: 0 .. 3f(16),
          interface_block_level_number: 0 .. 3f(16),
        RECEND,

        dst$dscb_d8ty = PACKED RECORD
          fill: 0 .. 3ffffffff(16),
          ei_version_number: 0 .. 0ff(16),
          os_type_180: 0 .. 3f(16),
          interface_block_version_number: 0 .. 3f(16),
          interface_block_level_number: 0 .. 3f(16),
        RECEND,

        dst$four_bit_array = PACKED ARRAY [1 .. (dump_block_size * 15)] OF
              0 .. 0f(16);

      PROCEDURE catenate_64_to_60
        (    fba_p: ^dst$four_bit_array;
             byte_count: integer;
             mw170_p: ^dst$four_bit_array;
         VAR mwfbi: integer);

{ PURPOSE:
{   The purpose of this procedure is to catenate a buffer of 64 bit data in
{   60 bit words with a previously dumped buffer of similar data that is not
{   word aligned so that the 64 bit data will be contiguous when written to a
{   file.  The 170 word buffer is written to the dump file when it is full.
{
{     FBA_P: pointer to the 64 bit data to be catenated.
{
{     BYTE_COUNT: number of bytes (8 bits/byte) to catenate.
{
{     MW170_P: pointer to the 170 word buffer where the data is to be moved to.
{
{     MWFBI: index to the next 4 bit position in the 170 word buffer.
{
{     The variable 'memory_buffer' which is not passed as a parameter is
{ assumed to be the buffer that 'mw170_p' points to.  This is the buffer
{ that is emptied when IO has to be done.

        VAR
          fbi: integer,
          four_bit_count: integer;


        four_bit_count := byte_count * 2;

        FOR fbi := LOWERBOUND(fba_p^) to four_bit_count DO
          mw170_p^ [mwfbi] := fba_p^ [fbi];
          mwfbi := mwfbi + 1;
          IF mwfbi > (dump_block_size_bytes * 2) THEN
            bi#put_tape (vedump, ^memory_buffer, #SIZE(mw170_p^));
            mwfbi := LOWERBOUND(mw170_p^);
          IFEND;
        FOREND;

      PROCEND catenate_64_to_60;


      VAR
        cm_header: memory_copy_header,
        dft_bi: integer,
        dft_buffer_lengths_p: ^ARRAY [ 0 .. * ] OF integer,
        dft_buffer_length_words: integer,
        dft_control_word: dst$dft_control_word,
        dftb_p_word: r_register_format,
        dscb_d7ty_word: dst$dscb_d7ty,
        dscb_d8ty_word: dst$dscb_d8ty,
        dump_length: integer,
        fba_p: ^dst$four_bit_array,
        four_bit_array: dst$four_bit_array,
        fwa: integer,
        i: integer,
        mwfbi: integer,
        memory_buffer: PACKED RECORD
          tape_block_header: cell,
          words: ALIGNED PACKED ARRAY [1 .. dump_block_size] OF integer,
        RECEND,
        mw_p: ^dst$four_bit_array,
        number_of_dft_buffers_to_dump: integer,
        page_size_mask: 0 .. 177(8),
        total_record_length: integer;

      IF nve_memory = 0 THEN
        RETURN;
      IFEND;

{  Check the EI version number to ensure that it can process this
{  request and the interface block version number to ensure that the DFT
{  block exists.

      get_dscb (dscb_d8ty, #LOC(dscb_d8ty_word), 1);
      get_dscb (dscb_d7ty, #LOC(dscb_d7ty_word), 1);

      IF (dscb_d8ty_word.ei_version_number >= 15(16)) AND (dscb_d7ty_word.
            interface_block_version_number >= 3) THEN

        set_ei_pva (start_of_dft_buffer_0, 1);
        cm_header.byte_rma := 0;
        cm_header.length := 1;
        cm_header.copy_method := ve60_to_nos60;
        cm_header.pva_type := dft_buffer;

{  Read the DFT control word to get the DFT version number and set the
{  number of DFT buffers to be dumped accordingly.

        copy_memory (cm_header, #LOC(dft_control_word));

        IF dft_control_word.rl <= 3 THEN
          number_of_dft_buffers_to_dump := 4;
        ELSE
          number_of_dft_buffers_to_dump := dft_control_word.po;
        IFEND;

        PUSH dft_buffer_lengths_p: [ 0 .. number_of_dft_buffers_to_dump ];

        determine_dft_block_length (number_of_dft_buffers_to_dump,
              dft_control_word, dft_buffer_length_words, dft_buffer_lengths_p);
        format_edd_header ('DFT', 0, dft_buffer_length_words);

{  Dump DFT buffers.

        cm_header.copy_method := ve64_to_nos60;
        cm_header.pva_type := dft_buffer;
        fba_p := ^four_bit_array;
        mw_p := #LOC(memory_buffer.words);
        mwfbi := LOWERBOUND(memory_buffer.words);

        FOR dft_bi := LOWERBOUND(dft_buffer_lengths_p^) TO
              number_of_dft_buffers_to_dump - 1 DO
          dump_length := dft_buffer_lengths_p^[dft_bi];

          IF dump_length > 0 THEN
            cm_header.length := dump_block_size;
            cm_header.byte_rma := 0;
            total_record_length := 0;
            set_ei_pva (dft_bi * 100(16) + dft_buffer, 1);

            WHILE (cm_header.byte_rma + dump_block_size_bytes) < dump_length DO
              copy_memory (cm_header, #LOC(four_bit_array));
              catenate_64_to_60 (fba_p, dump_block_size_bytes, mw_p, mwfbi);
              cm_header.byte_rma := cm_header.byte_rma + dump_block_size_bytes;
              total_record_length := total_record_length +
                    #SIZE (memory_buffer.words);
            WHILEND;

 {  Convert the number of remaining bytes to dump to 170 CM words.  This value
 {  must be a multiple of 2 because of the conversion algorithm used by EI.
 {  If it is not a multiple of 2 170 CM words, EI will abort the job.

            i := (dump_length - cm_header.byte_rma) * 8;
            cm_header.length := i DIV 60;

            IF (i MOD 60) <> 0 THEN
              cm_header.length := cm_header.length + 1;
            IFEND;

            IF (cm_header.length MOD 2) <> 0 THEN
              cm_header.length := cm_header.length + 1;
            IFEND;

            copy_memory (cm_header, #LOC(four_bit_array));
            catenate_64_to_60 (fba_p, i DIV 8, mw_p, mwfbi);
          IFEND;
        FOREND;

        IF mwfbi > LOWERBOUND(memory_buffer.words) THEN

 {  There is data in the memory buffer, write it to the dump file.

          mwfbi := mwfbi - 1;
          i := mwfbi DIV 15;

          IF (mwfbi MOD 15) <> 0 THEN
            i := i + 1;
          IFEND;

          bi#put_tape (vedump, ^memory_buffer, i);
        IFEND;

      IFEND;

{  Dump NOS/VE memory.  If *DUMP=NONE was specified, no NOS/VE memory is dumped.
{  If *DUMP=CRITICAL was specified, only critical memory (as defined by the critical
{  page table) is dumped as *CCM* records.  Otherwise, all of NOS/VE memory is
{  dumped as one *MEM* record.

      get_page_size_mask (page_size_mask);

      IF memory_to_be_dumped <> 'NONE' THEN
        IF cptp_r_pointer.length <> 0 THEN
          dump_critical_page_table (page_size_mask);
        IFEND;
        IF memory_to_be_dumped = 'CRITICAL' THEN
          dump_critical_memory (page_size_mask);
        ELSE
          dyfstrnum ('cm dump fwa', load_offset_bytes, system_dayf);
          dyfstrnum ('cm dump length', nve_memory, system_dayf);
          fwa := load_offset_bytes DIV bytes_per_octal_1k_words;
          dump_length := nve_memory DIV bytes_per_octal_1k_words;
          format_edd_header ('MEM', fwa, dump_length);

          dump_length := nve_memory;
          total_record_length := 0;
          cm_header.length := dump_block_size;
          cm_header.byte_rma := 0;
          cm_header.copy_method := ve64_to_nos60;
          cm_header.pva_type := start_of_ve;

          WHILE (cm_header.byte_rma + dump_block_size_bytes) < dump_length DO
            copy_memory (cm_header, ^memory_buffer.words);
            bi#put_tape (vedump, ^memory_buffer, #SIZE (memory_buffer.words));
            cm_header.byte_rma := cm_header.byte_rma + dump_block_size_bytes;
            total_record_length := total_record_length +
                  #SIZE (memory_buffer.words);
          WHILEND;

{  Dump remainder of memory.

          i := (dump_length - cm_header.byte_rma) * 2;
          cm_header.length := (i DIV 30) * 2;
          copy_memory (cm_header, ^memory_buffer.words);

          i := (i + 14) DIV 15;
          i := ((total_record_length + i + 63) DIV 64) * 64 - total_record_length;
          bi#put_tape (vedump, ^memory_buffer, i);
        IFEND;
      IFEND;

{  Dump EICB.

{  Determine the number of 170 CM words to dump.  This value must be
{  a multiple of 2 because of the conversion algorithm used by EI.
{  If it is not a multiple of 2 170 CM words, EI will abort the job.

      dump_length := (dscb_dscbl * 64) DIV 60;
      IF ((dscb_dscbl * 64) MOD 60) <> 0 THEN
        dump_length := dump_length + 1;
      IFEND;
      IF (dump_length MOD 2) <> 0 THEN
        dump_length := dump_length + 1;
      IFEND;

      format_edd_header ('DSB', 0, dump_length);
      cm_header.copy_method := ve64_to_nos60;
      cm_header.pva_type := interface_block;
      cm_header.length := dump_length;
      cm_header.byte_rma := dscb_d7ty * 8;
      copy_memory (cm_header, ^memory_buffer.words);
      bi#put_tape (vedump, ^memory_buffer, dump_length);

    PROCEND dump_memory;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure dump_cpu_registers', EJECT ??

{ PURPOSE:
{   First dump the processor maintenance registers from the live registers
{   updating them from the register save area in the SSR if present.
{   Then if the MPS register is defined in the SSR, dump the exchange
{   package image from the memory referenced by MPS.

    PROCEDURE dump_cpu_registers
      (    cpu_info: dst$cc_processor_info);

      CONST
       base_number_of_pmr_to_dump = 12,
       max_number_of_pmr = 27,
       mps_reg_number = 41(16);

      VAR
        cm_header: memory_copy_header,
        cpu_registers: [STATIC] PACKED ARRAY [1 .. max_number_of_pmr]
          OF 0 .. 7777(8) := [0, 10(16), 11(16), 12(16), 13(16), 30(16),
          41(16), 48(16), 49(16), 4a(16), 61(16), 80(16), 81(16), 82(16),
          83(16), 84(16), 85(16), 86(16), 87(16), 88(16), 89(16), 8a(16),
          8b(16), 8c(16), 8d(16), 8e(16), 8f(16)],
        xp_buffer: PACKED RECORD
          tape_block_header: cell,
          xp_registers: ARRAY [0 .. 63] OF integer,
        RECEND,
        i: integer,
        left: integer,
        mps_reg: integer,
        mps_reg_found: boolean,
        number_of_pmr_to_dump: integer,
        reg: edd_register_format,
        ri: 1 .. max_number_of_pmr,
        right: integer,
        ssr_header: memory_copy_header;

      VAR
        ssr_block: PACKED RECORD
          f0: 0 .. 0fffffff(16),
          rn0: 0 .. 0ffff(16),
          rn1: 0 .. 0ffff(16),
          f1: 0 .. 0fffffff(16),
          rn2: 0 .. 0ffff(16),
          rn3: 0 .. 0ffff(16),
          rv0: c180_word,
          rv1: c180_word,
          rv2: c180_word,
          rv3: c180_word,
        RECEND;

      PROCEDURE build_register
        (    rn: integer;
             rv: c180_word);

        VAR
          j: integer,
          v1: integer,
          v2: integer;

        dyfstrnum ('BUILD REG', rn, debug_log);
        v1 := rv.left;
        v2 := rv.right;
        FOR j := 1 TO 4 DO
          ssr_registers^ [ri].register_value [5 - j] := v1 MOD 256;
          ssr_registers^ [ri].register_value [9 - j] := v2 MOD 256;
          v1 := v1 DIV 256;
          v2 := v2 DIV 256;
        FOREND;
        ssr_registers^ [ri].number := rn;
        ri := ri + 1;

      PROCEND build_register;

{  Process Processor Maintenance Registers. (PMR)

      IF cpu_info.status.processor_down THEN
        dyfstrnum ('SKIPPING CPU', cpus_observed, debug_log);
        cpus_observed := cpus_observed + 1;
        RETURN;
      IFEND;

      dyfstrnum ('DUMPING CPU', cpus_observed, debug_log);

      pp_table.port_code := cpu_info.port_code;
      format_edd_header ('PMR', 0, 0);
      ssr_registers := NIL;
      IF ssr_address_words <> 0 THEN
        find_ssr_entry ('RSAV', left);
        get_ssr_directory_entry (left, left, right);
        ssr_header.pva_type := start_of_ssr;
        ssr_header.copy_method := ve64_to_nos32;
        ssr_header.length := #SIZE (ssr_block);
        ssr_header.byte_rma := right * 8 + 16 * 8 * cpus_observed;
        PUSH ssr_registers: [1 .. 8];
        ri := 1;
        FOR i := 1 TO 2 DO
          copy_memory (ssr_header, ^ssr_block);
          ssr_header.byte_rma := ssr_header.byte_rma + 5 * 8;
          build_register (ssr_block.rn0, ssr_block.rv0);
          build_register (ssr_block.rn1, ssr_block.rv1);
          build_register (ssr_block.rn2, ssr_block.rv2);
          build_register (ssr_block.rn3, ssr_block.rv3);
        FOREND;
      IFEND;

      CASE cpu_info.element_id.model_number OF

      = osc$cyber_180_model_815, osc$cyber_180_model_825 =
        cpu_registers[base_number_of_pmr_to_dump + 1] := 90(16);
        cpu_registers[base_number_of_pmr_to_dump + 2] := 93(16);
        number_of_pmr_to_dump := base_number_of_pmr_to_dump + 2;

      = osc$cyber_180_model_810, osc$cyber_180_model_830 = { includes 810A/830A
        { 810/830/810A/830A
        cpu_registers[base_number_of_pmr_to_dump + 2] := 90(16);
        cpu_registers[base_number_of_pmr_to_dump + 3] := 91(16);
        cpu_registers[base_number_of_pmr_to_dump + 4] := 93(16);
        number_of_pmr_to_dump := base_number_of_pmr_to_dump + 4;

      = osc$cyber_180_model_835 =
        cpu_registers[base_number_of_pmr_to_dump + 2] := 90(16);
        cpu_registers[base_number_of_pmr_to_dump + 3] := 92(16);
        number_of_pmr_to_dump := base_number_of_pmr_to_dump + 3;

      = osc$cyber_180_model_840, osc$cyber_180_model_840s,
        osc$cyber_180_model_845, osc$cyber_180_model_845s,
        osc$cyber_180_model_850, osc$cyber_180_model_855,
        osc$cyber_180_model_855s, osc$cyber_180_model_860,
        osc$cyber_180_model_9601, osc$cyber_180_model_9603 =

        { 840/845/850/855/860/840S/845S/855S/840A/850A/860A/870A.
        number_of_pmr_to_dump := base_number_of_pmr_to_dump + 9;

      = osc$cyber_180_model_990, osc$cyber_180_model_990e,
        osc$cyber_180_model_994 = { 990/990E/994/995E
        number_of_pmr_to_dump := base_number_of_pmr_to_dump + 0f(16);

      ELSE

        number_of_pmr_to_dump := base_number_of_pmr_to_dump;

      CASEND;

      FOR ri := 1 TO number_of_pmr_to_dump DO
        read_register (register_block_buffer.register [ri],
              cpu_registers [ri], ssr_registers, 0, cpu_info.port_code);
      FOREND;
      register_block_buffer.register [number_of_pmr_to_dump + 1] [1] := 0;

      bi#put_tape (vedump, ^register_block_buffer,
            (number_of_pmr_to_dump * 2) + 1);

{  Process Processor Exchange Package.

      mps_reg_found := FALSE;
      IF ssr_address_words <> 0 THEN
        FOR i := 1 TO UPPERBOUND (ssr_registers^) DO
          IF ssr_registers^ [i].number = mps_reg_number THEN
            mps_reg_found := TRUE;
          IFEND;
        FOREND;
      IFEND;

      IF mps_reg_found THEN
        read_register (reg, mps_reg_number, ssr_registers, 0,
              cpu_info.port_code);

        mps_reg := 0;
        FOR i := 3 TO 10 DO
          mps_reg := mps_reg * 100(16) + reg [i];
        FOREND;

        IF (mps_reg > load_offset_bytes) AND (load_offset_bytes <> 0) THEN
          format_edd_header ('PXP', 0, 0);

          cm_header.copy_method := ve64_to_nos60;
          cm_header.pva_type := start_of_ve;
          cm_header.byte_rma := mps_reg - load_offset_bytes;
          cm_header.length := 64;
          copy_memory (cm_header, ^xp_buffer.xp_registers);

          bi#put_tape (vedump, ^xp_buffer, 56);
        IFEND;
      IFEND;
      cpus_observed := cpus_observed + 1;

    PROCEND dump_cpu_registers;
?? OLDTITLE, EJECT ??

{ PURPOSE:
{   Dump the NOS/VE environment to the dump file.

    VAR
      cpus_observed: integer,
      index: integer,
      iou_number: integer,
      ious_observed: integer,
      os_date: char_arr,
      os_time: char_arr,
      total_size: integer,
      vedump: ^cell,
      vedump_file: string (7);

{  Initialize for dumping the NOS/VE environment.

    vedump_file := 'CHKTAPE';
    bi#olt (vedump, vedump_file, new#, output#, first#);

    get_date_time (os_date, os_time);
    IF load_offset_bytes <> 0 THEN
      set_ei_pva (start_of_ve, load_offset_bytes DIV 8);
    IFEND;
    total_size := 0;
    index := LOWERBOUND(configuration_record);
    cpus_observed := 0;
    ious_observed := 0;

    create_dump_identifier_record;

{  Dump the maintenance registers for those elements defined in the
{  mainframe reconfiguration table.

    WHILE configuration_record [index].iou.size > 0 DO

      CASE configuration_record [index].iou.id OF

      = dsc$id_iou_info =
        dump_iou_registers (configuration_record [index].iou);

      = dsc$id_central_memory_info =
        dump_mem_registers (configuration_record [index].memory);

      = dsc$id_processor_info =
        dump_cpu_registers (configuration_record [index].processor);

      ELSE

      CASEND;

      index := index + 1;
    WHILEND;

    dump_memory;

{  Dump IOU contents for each IOU.

    iou_number := 0;
    index := LOWERBOUND(configuration_record);

    WHILE configuration_record [index].iou.size > 0 DO

      CASE configuration_record [index].iou.id OF

      = dsc$id_iou_info =
        dump_iou_contents (iou_number,
              configuration_record [index].iou.port_code, index);
        iou_number := iou_number + 1;
      ELSE

{  Ignore other records.

      CASEND;

      index := index + 1;
    WHILEND;

{  Close the dump file.

    bi#weof_tape (vedump);
    bi#close (vedump, asis#);

  PROCEND nosve_edd_dump;
?? OLDTITLE ??
*DECK DECK=DSI$TRANSMIT_DATA_VIA_SSR EXPAND=FALSE
?? NEWTITLE := '~~~~~   common deck DSI$TRANSMIT_DATA_VIA_SSR', EJECT ??
{*********************************************************}
{}
{ SSR helper routines for resource requests, deck DSI$TRANSMIT_DATA_VIA_SSR}
{}
{*********************************************************}

  TYPE
    transfer_entry = record
      offset: 0 .. 0ffffffff(16),
      length: 0 .. 0ffffffff(16),
    recend;

  VAR
    dsv$send_buffer: integer := 0,
    dsv$receive_buffer: integer := 0;

?? SKIP := 3 ??

  PROCEDURE [XDCL] dsp$receive_data_via_ssr ALIAS 'dsp$rec' (VAR buffer: ^SEQ (
    * ));

    VAR
      left: integer,
      right: integer,
      entry: transfer_entry,
      cm_copy_info: memory_copy_header;

    IF dsv$receive_buffer = 0 THEN
      find_ssr_entry (dsc$ssr_c180_transfer_buffer, dsv$receive_buffer);
      get_ssr_directory_entry (dsv$receive_buffer, left, right);
      dsv$receive_buffer := right * 8;
    IFEND;

{ read buffer descriptor rma from nve
    get_ssr_data (dsv$receive_buffer, ^entry, 2);
    IF exitcd = 0 THEN
      error_processor (nosve_down, fatal_error);
    IFEND;

    buffer := NIL;

    IF entry.offset > 0 THEN
{ read data into stack
      cm_copy_info.byte_rma := entry.offset;
      cm_copy_info.length := (entry.length + 14) DIV 15 * 2;
      cm_copy_info.copy_method := ve64_to_nos60;
      cm_copy_info.pva_type := start_of_mf_wired;

      ALLOCATE buffer: [[REP cm_copy_info.length OF integer]];
      RESET buffer;
      copy_memory (cm_copy_info, buffer);

{ clear descriptor rma
      entry.offset := 0;
      entry.length := 0;
      store_ssr_data (dsv$receive_buffer, ^entry, 2);
    IFEND;
  PROCEND dsp$receive_data_via_ssr;
?? SKIP := 3 ??

  PROCEDURE [XDCL] dsp$send_data_via_ssr ALIAS 'dsp$sen' (data: ^cell,
        data_length: integer);

    VAR
      cm_copy_info: memory_copy_header,
      entry: transfer_entry,
      left: integer,
      right: integer;

    IF dsv$send_buffer = 0 THEN
      find_ssr_entry (dsc$ssr_c170_transfer_buffer, dsv$send_buffer);
      get_ssr_directory_entry (dsv$send_buffer, left, right);
      dsv$send_buffer := right * 8;
    IFEND;

    get_ssr_data (dsv$send_buffer, ^entry, 2);
    WHILE entry.length > 0 DO
      wakeup;
      get_ssr_data (dsv$send_buffer, ^entry, 2);
      IF exitcd = 0 THEN
        error_processor (nosve_down, fatal_error);
      IFEND;
    WHILEND;

{ Set transmit buffer size in c170_send_buffer.

    entry.length := (data_length + 1) DIV 2 * 15;
    store_ssr_data (dsv$send_buffer, ^entry, 2);

{ Await receive buffer offset preset in c70_send_buffer from 180 side.

    REPEAT
      wakeup;
      get_ssr_data (dsv$send_buffer, ^entry, 2);
      IF exitcd = 0 THEN
        error_processor (nosve_down, fatal_error);
      IFEND;
    UNTIL entry.offset > 0;

{ send information to NOS/ve
    cm_copy_info.byte_rma := entry.offset;
    cm_copy_info.length := (data_length + 1) DIV 2 * 2;
    cm_copy_info.copy_method := nos60_to_ve64;
    cm_copy_info.pva_type := start_of_mf_wired;

    copy_memory (cm_copy_info, data);

    entry.offset := 0;
    store_ssr_data (dsv$send_buffer, ^entry.offset, 1);
  PROCEND dsp$send_data_via_ssr;

?? OLDTITLE ??
*DECK DECK=DSI$VALIDATE_PP_BOUNDS EXPAND=FALSE
          CTEXT  DSI$VALIDATE PP BOUNDS                                 
          SPACE  4,10                                                   
 QUAL$    IF     -DEF,QUAL$                                             
          QUAL   DSIVPB                                                 
 QUAL$    ENDIF                                                         
          BASE   M                                                      
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992              
 DSIVPB   SPACE  4,10                                                   
***       DSI$VALIDATE_PP_BOUNDS.                                       
*         B. R. HANSON.      85/05/16.                                  
*         J. L. GOERGEN.     86/02/21.                                  
 DSIVPB   SPACE  4,10                                                   
***              PROVIDES ROUTINES TO VERIFY THE PP CM ACCESS VALIDATION
*         OF A GIVEN PP USING THE OS BOUNDS REGISTER.                   
 NOTE     SPACE  4,10                                                   
****      PROGRAMMING NOTES.                                            
*                                                                       
*         IMPORTANT NOTE: THERE ARE CELLS WHICH MUST BE DEFINED         
*         EXTERNAL TO THIS COMMON DECK FOR THIS DECK TO FUNCTION.       
*         THEY ARE *PPNO*,  *ISPB*, *IOUM*, *I0CC*.                     
*         IN ADDITION, IF THE SYMBOL *PPTYPE* IS DEFINED, THEN          
*         THE LOCATION *PPTY* WILL BE USED BY *SPB*.                    
****                                                                    
 CPB      SPACE  4,10                                                   
**        CPB - CHECK PP BIT IN HARDWARE REGISTER.                      
*                                                                       
*         ENTRY  (A) = PP NUMBER.                                       
*                (RDATA - RDATA+7) = MAINTENANCE REGISTER DATA.         
*                (CPBA) = (LDNI + PP_RECONFIGURATION)                   
*                (CPBB) = (SBNI + PHYSICAL_BARRELS)                     
*                                                                       
*         EXIT   (A) = PP BIT VALUE.                                    
*                                                                       
*         USES   T1, T2.                                                
*                                                                       
*         CALLS  SPM.                                                   
                                                                        
                                                                        
 CPB1     LDN    0           PRESET INDEX FOR BARREL 0                  
          STD    T2                                                     
          LDD    T1                                                     
          LPN    37          CLEAR CONCURRENT BIT                       
          STD    T1                                                     
          SBN    5           TEST CIO BARREL                            
          MJN    CPB3        IF BARREL 0                                
          LDN    1           SET INDEX FOR BARREL 1                     
          STD    T2                                                     
 CPB3     LDD    T1          GET PP NUMBER                              
          ADC    SHNI                                                   
          STM    CPBC        SET SHIFT INSTRUCTION                      
          LDN    1                                                      
 CPBC     SHN    **                                                     
 CPB4     LPML   RDATA,T2    CHECK PROPER BYTE                          
                                                                        
 CPB      SUBR               ENTRY/EXIT                                 
          STD    T1          SAVE PP NUMBER                             
          LPC    0#100       CHECK CONCURRENT BIT                       
          NJN    CPB1        IF A CIO PP                                
          LDD    T1          REGAIN PP NUMBER                           
          RJM    SPM         SET UP PP MASK AND T2                      
          UJN    CPB4        CONTINUE                                   
 SPM      SPACE  4,10                                                   
**        SPM - SET UP PP MASK.                                         
*                                                                       
*         ENTRY  (A) = PP NUMBER.                                       
*                                                                       
*         EXIT   (A) = BIT SET FOR PP NUMBER.                           
*                (T2) = PHYSICAL BARREL NUMBER.                         
*                                                                       
*         USES   T1, T2.                                                
                                                                        
                                                                        
 SPM      SUBR               ENTRY/EXIT                                 
          STD    T1          SAVE PP NUMBER                             
          LDN    0                                                      
          STD    T2                                                     
          LDD    T1                                                     
          SBN    20                                                     
          MJN    SPM1        IF IN BARRELS ZERO OR ONE                  
          STD    T1                                                     
          AOD    T2                                                     
          AOD    T2                                                     
 SPM1     LDD    T1                                                     
          SBN    5                                                      
          MJN    SPM2        IF IN LOWER HALF OF BARREL                 
          STD    T1                                                     
          AOD    T2                                                     
 SPM2     LDN    **          PP RECONFIGURATION SWITCHES                
 SPMA     EQU    *-1         (MODIFIED FROM ROUTINE *PII*)              
          RAD    T2                                                     
 SPMB     SBN    **          PHYSICAL BARRELS (MODIFIED BY *PII*)       
          MJN    SPM3        IF RECONFIGURATION OK                      
          STD    T2          RECONFIGURED TO LOWER BARREL               
 SPM3     LDC    SHNI                                                   
          ADD    T1                                                     
          STM    SPMC        SET SHIFT INSTRUCTION                      
          LDN    1                                                      
 SPMC     SHN    **                                                     
          UJN    SPMX        RETURN                                     
 CRD      SPACE  4,10                                                   
**        CRD - CALCULATE R-REGISTER DIFFERENCE.                        
*                                                                       
*         ENTRY  R-REGISTER IS SET UP.                                  
*                (RDATA - RDATA+7) = OS BOUNDS REGISTER.                
*                                                                       
*         EXIT   (A) < 0, IF OSB ADDRESS < PP ADDRESS.                  
*                (A) > 0, IF OSB ADDRESS > PP ADDRESS.                  
*                                                                       
*         USES   T3, T4.                                                
                                                                        
                                                                        
 CRD      SUBR               ENTRY/EXIT                                 
          SRD    T3                                                     
                                                                        
*         SINCE OS BOUNDS IS SCALED BY 2 ** 10 DO THE                   
*         SAME TO THE R-REGISTER.                                       
                                                                        
          LDD    T3          BUILD OSB BYTE 5                           
          SHN    -10                                                    
          STM    CRDA                                                   
          LDM    RDATA+5                                                
          SBM    CRDA                                                   
          NJN    CRDX        IF NOT EQUAL TO OS BOUNDS                  
          LDD    T3          BUILD OSB BYTE 6                           
          LPK    0#FF                                                   
          STM    CRDA                                                   
          LDM    RDATA+6                                                
          SBM    CRDA                                                   
 CRD1     NJN    CRDX        IF NOT EQUAL TO OS BOUNDS                  
          LDD    T4          BUILD OSB BYTE 7                           
          SHN    -4                                                     
          STM    CRDA                                                   
          LDM    RDATA+7                                                
          SBM    CRDA                                                   
          NJN    CRDX        IF NOT EQUAL TO OS BOUNDS                  
          LDN    1                                                      
          SHN    21-0                                                   
          UJN    CRD1        RETURN WITH (A) < 0                        
                                                                        
 CRDA     CON    0                                                      
 SPB      SPACE  4,20                                                   
**        SPB - SET PP BOUNDARY.                                        
*                                                                       
*         ENTRY  R-REGISTER SET UP.                                     
*                (PPNO) = 8/PP TYPE, 8/PP NUMBER OF CURRENT PP.         
*                (ISPB) = FLAG DEFINED IN PP TO INDICATE                
*                WHETHER TO IGNORE SETTING OS BOUNDS OR NOT.            
*                                                                       
*         EXIT   OS BOUNDS BIT IS SET FOR PARTICULAR                    
*                SITUATION SO NO ERRORS WILL OCCUR.                     
*                IF *PPTYPE* IS DEFINED, THEN (PPTY) = 0 IF UPPER PP.   
*                                                                       
*         USES   T1, T2, RDATA.                                         
*                                                                       
*         CALLS  CRD, PII, SPM.                                         
*                                                                       
*         MACROS READMR, WRITMR.                                        
*                                                                       
*         NOTES  IT IS ASSUMED THAT THE STATUS OF THE DESIGNATED        
*                PP CAN BE DETERMINED FROM THE *IOSB* MAINTENANCE       
*                REGISTER.                                              
                                                                        
                                                                        
 SPB      SUBR               ENTRY/EXIT                                 
          LDM    ISPB        GLOBAL FLAG FOR IGNORING BOUNDS SETTING    
          NJN    SPBX        IF TO IGNORE                               
          LOCKMR SET                                                    
          READMR RDATA,I0CC,IOSB                                        
          LDM    PPNO                                                   
          LPC    0#FF                                                   
          RJM    SPM                                                    
          STD    T1          SAVE MASK                                  
          RJM    CRD         GET WHICH SIDE OF BOUNDARY WRITE IS ON     
          MJN    SPB1        IF  PP ADDRESS > OSB                       
          LDD    T1          FETCH MASK                                 
          LPML   RDATA,T2                                               
          NJN    SPB3        IF LOWER PP                                
          UJN    SPB2        TOGGLE UPPER TO LOWER                      
                                                                        
 SPB1     LDD    T1          FETCH MASK                                 
          LPML   RDATA,T2                                               
          ZJN    SPB3        IF UPPER PP                                
 SPB2     LDM    RDATA,T2                                               
          LMD    T1          TOGGLE THE BOUNDS BIT                      
          STM    RDATA,T2                                               
 .A       IF     DEF,PPTYPE                                             
          LPML   T1          SAVE PP TYPE FLAG (0 = UPPER PP)           
          STM    PPTY                                                   
 .A       ENDIF                                                         
          WRITMR RDATA,I0CC                                             
 SPB3     LOCKMR CLEAR                                                  
          LJM    SPBX        RETURN                                     
 PII      SPACE  4,10                                                   
**        PII - PRESET IOU INFORMATION.                                 
*                                                                       
*         ENTRY  (I0CC) = ACCESS CODE TO IOU.                           
*                (IOUM) = MODEL OF IOU.                                 
*                                                                       
*         EXIT   (SPMA) = (LDNI + BARREL_RECONFIGURATION)               
*                (SPMB) = (SBNI + INSTALLED_BARRELS)                    
*                                                                       
*         USES   T1.                                                    
*                                                                       
*         MACROS READMR.                                                
                                                                        
                                                                        
 PII      SUBR               ENTRY/EXIT                                 
          READMR PIIC,I0CC,ISTR  IOU STATUS REGISTER                    
          READMR PIIB,I0CC,OIMR  OPTIONS INSTALLED                      
          LDN    0                                                      
          STD    T1                                                     
          LDM    PIIB+2      BARRELS INSTALLED                          
          SHN    21-1                                                   
          PJN    PII3        IF ONLY 1 BARREL                           
          SHN    21-0                                                   
          PJN    PII2        IF TWO BARRELS                             
          SHN    21-0                                                   
          PJN    PII1        IF THREE BARRELS                           
          AOD    T1                                                     
 PII1     AOD    T1          THREE BARRELS                              
 PII2     AOD    T1          TWO BARRELS                                
 PII3     AOD    T1          ONE BARREL                                 
          RAM    SPMB        SAVE INSTALLED BARRELS IN *SPM*            
          LDM    IOUM        GET ELEMENT MODEL                          
          SHN    -4                                                     
          LMN    1                                                      
          ZJN    PII4        IF MODEL I1                                
          AOM    PIIA                                                   
 PII4     LDM    PIIC+7      BARREL RECONFIGURATION                     
          SHN    -3                                                     
 PIIA     LPN    2           ONLY BIT 4 VALID ON I1                     
*         LPN    3           BITS 3 AND 4 VALID ON I2/I4                
          RAM    SPMA        STORE BARREL RECONFIGURATION IN *SPM*      
          LJM    PIIX        RETURN                                     
                                                                        
*         NOTE - TO SAVE SPACE, THE FOLLOWING BUFFERS OVERLAP           
*         THE UNUSED PORTION OF *PIIC* WITH *PIIB*.                     
                                                                        
 PIIB     BSS    1           OPTIONS INSTALLED                          
 PIIC     BSS    10          STATUS REGISTER                            
          SPACE  4,10                                                   
          BASE   *                                                      
 QUAL$    IF     -DEF,QUAL$                                             
          QUAL   *                                                      
 CPB      EQU    /DSIVPB/CPB                                            
 SPB      EQU    /DSIVPB/SPB                                            
 PII      EQU    /DSIVPB/PII                                            
 CRD      EQU    /DSIVPB/CRD                                            
 SPM      EQU    /DSIVPB/SPM                                            
 QUAL$    ENDIF                                                         
          ENDX                                                          
*DECK DECK=DSI$VIRTUAL_MEMORY_ACCESS EXPAND=FALSE
?? NEWTITLE := '~~~~~   common deck DSI$VIRTUAL_MEMORY_ACCESS', EJECT ??

  CONST

{  Dual state control block (DSCB) constants.

    dscb_d7ty = 0,
    dscb_d7jp = dscb_d7ty + 1,
    dscb_d7st = dscb_d7jp + 2,
    dscb_d7rs = dscb_d7st + 1,
    dscb_d7cm = dscb_d7rs + 3,
    dscb_d7sv = dscb_d7cm + 2,
    dscb_d8ty = dscb_d7sv + 6,
    dscb_d8tm = dscb_d8ty + 1,
    dscb_d8jp = dscb_d8tm + 2,
    dscb_d8st = dscb_d8jp + 2,
    dscb_d8ds = dscb_d8st + 1,
    dscb_d8sv = dscb_d8ds + 3,
    dscb_dscm = dscb_d8sv + 6,
    dscb_dfcm = dscb_dscm + 5,
    dscb_dscbl = dscb_dfcm + 11,
    dscb_ssrptr = dscb_d8sv + 1,
    dscb_dftptr = dscb_d7rs + 1,
    dscb_cptptr = dscb_dfcm + 8;

  TYPE
    dst$r_pointer = PACKED RECORD
      offset: 0 .. 0fff(16),
      rupper: 0 .. 0ffff(16),
      rlower: 0 .. 0ffff(16),
      length: 0 .. 0ffff(16),
    RECEND;

  TYPE
    c180_word = RECORD
      left: integer,
      right: integer,
    RECEND,
    c180_data = ^ARRAY [ * ] OF c180_word;

?? SKIP := 3 ??

  PROCEDURE get_dscb
    (    fwa: integer;
         buffer: ^cell;
         size: integer);

    VAR
      cm_copy_info: [STATIC] memory_copy_header := [0, ve60_to_nos60,
        interface_block, 0];

    cm_copy_info.byte_rma := fwa * 8;
    cm_copy_info.length := size;
    copy_memory (cm_copy_info, buffer);

  PROCEND get_dscb;
?? SKIP := 3 ??

  PROCEDURE put_dscb
    (    fwa: integer;
         buffer: ^cell;
         size: integer);

    VAR
      cm_copy_info: [STATIC] memory_copy_header := [0, nos60_to_ve60,
        interface_block, 0];

    cm_copy_info.byte_rma := fwa * 8;
    cm_copy_info.length := size;
    copy_memory (cm_copy_info, buffer);

  PROCEND put_dscb;
?? PUSH (LISTEXT := ON) ??
*copyc dsp$copy_memory
?? POP ??
?? OLDTITLE ??
*DECK DECK=DSM$ACCFILE EXPAND=TRUE
.PROC,ACCFILE*I,
.
.HELP
 THIS PROCEDURE CREATES THE PARTNER JOB TEMPLATE FILE USED
 BY THE REMOTE HOST AND INTERSTATE COMMUNICATION EXECUTIVES
 TO GENERATE PROPER ACCOUNTING INFORMATION FOR PARTNER JOBS.

.ENDHELP
REWIND,ICACCNT.
REWIND,RHACCNT.
REVERT. ICACCNT AND RHACCNT FILES CREATED.
.DATA,ICACCNT.
&JOB
*IF ($string($name(wev$target_operating_system))='NOS')
USER,&USER,&PASSWORD,&FAMILY.
CHARGE,&CHARGE,&PROJECT.
USECPU(1)
*IFEND
.DATA,RHACCNT.
&JOB
*IF ($string($name(wev$target_operating_system))='NOS')
USER,&USER,&PASSWORD,&FAMILY.
CHARGE,&CHARGE,&PROJECT.
USECPU(1)
*IFEND
/EOR
*DECK DECK=DSM$BOOT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Boot' ??
MODULE dsm$boot;

{ PURPOSE:
{   This module contains all of the procedures needed to load the boot pieces from the deadstart device.
{   After the boot pieces (monitor image and system core image) are loaded, this module contains the
{   the procedure which calls DFT to change the monitor exchange package from the boot to system core.
{   This is the last code in the boot to be executed.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc bat$record_header_type
*copyc dsc$max_dcfile_length
*copyc dst$dcfile_identifier
*copyc dpt$rb_display_request
*copyc mmt$segment_descriptor_table
*copyc mtc$job_fixed_segment
*copyc osc$purge_map_and_cache
*copyc ost$exchange_package
*copyc ost$hardware_subranges
*copyc pmt$virtual_memory_image_header
*copyc syc$monitor_segment_numbers
?? POP ??
*copyc cmp$configure_deadstart_device
*copyc cmp$de_configure_ds_device
*copyc cmp$vcmb_menu_manager
*copyc cmp$write_os_status
*copyc dsp$change_monitor_xp
*copyc dsp$prepare_deadstart_io
*copyc dsp$read_deadstart_device
*copyc dsp$read_header_labels
*copyc dsp$save_boot_data_pointer
*copyc dsp$store_data_in_ssr
*copyc i#build_adaptable_seq_pointer
*copyc i#call_monitor
*copyc i#real_memory_address
*copyc mmp$boot_add_sdt_sdtx_entry
*copyc mmp$get_max_sdt_pointer
*copyc osp$system_error
*copyc pmp$zero_out_table
*copyc syp$display_deadstart_message
*copyc syp$trace_deadstart_message
?? EJECT ??
*copyc cmv$system_device_data
*copyc jmv$jmtr_xcb
*copyc mmv$pt_length
*copyc mtv$monitor_segment_table
*copyc mtv$nst_p
*copyc osv$mainframe_wired_heap
*copyc osv$page_size
?? POP ??
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??
  TYPE
    asid_list_entry = RECORD
      asid: ost$asid,
      link_p: ^asid_list_entry,
    RECEND,

    segment_list_entry = RECORD
      linked_segment_description: pmt$linked_segment_description,
      link_p: ^segment_list_entry,
    RECEND,

    segment_table_entry = PACKED RECORD
      ste: ost$segment_descriptor,
      fill: 0 .. 0ffffff(16),
    RECEND;
?? EJECT ??
  VAR
    dsv$dcfile_identifier: [XDCL] dst$dcfile_identifier,
    dsv$display_deadstart_messages: [XDCL] boolean := TRUE,
    dsv$maximum_memory_size: [XDCL] integer := 0,

    asid_seed: integer := 1,
    core_sta_p: ^SEQ ( * ),
    current_asid_entry_p: ^asid_list_entry := NIL,
    current_core_segment_entry_p: ^segment_list_entry := NIL,
    current_monitor_segment_entry_p: ^segment_list_entry := NIL,
    job_fixed_asid: ost$asid,
    monitor_sta_p: ^SEQ ( * ),
    monitor_xp_p: ^ost$exchange_package,
    sdte: mmt$segment_descriptor := [[osc$vl_regular_segment, osc$non_executable, osc$read_uncontrolled,
          osc$write_uncontrolled, 1, 1, 0, [FALSE, FALSE, 0]], 0, 0],
    top_asid_entry_p: ^asid_list_entry := NIL,
    top_core_segment_entry_p: ^segment_list_entry := NIL,
    top_monitor_segment_entry_p: ^segment_list_entry := NIL;
?? TITLE := 'build_asid', EJECT ??

{ PURPOSE:
{   This procedure assigns an asid.  The algorithm attempts to distribute ASIDS as far apart in the page
{   table as possible.  It checks that the asid does not already exists on the asid list.

  PROCEDURE build_asid
    (VAR asid: ost$asid);

    CONST
      nos_asid = 0ffff(16);

    VAR
      asid_entry_p: ^asid_list_entry,
      asid_found: boolean,
      asid_index: integer,
      page_table_length: integer,
      ptl_index: integer;

    asid_found := TRUE;
    page_table_length := mmv$pt_length * 8;

    REPEAT
      asid_index := asid_seed;
      asid_seed := asid_seed + 1;

      { Determine value to mirror the ASID seed based on the page table size.

      ptl_index := page_table_length DIV 32;
      ptl_index := (((page_table_length DIV 32) - 1) MOD 8000(16)) + 1;
      asid := 0;

      {  Generate the ASID, this creates a mirror image of the initial ASID seed.

      WHILE asid_index <> 0 DO
        IF (asid_index MOD 2) <> 0 THEN
          asid := asid + ptl_index;
        IFEND;
        asid_index := asid_index DIV 2;
        ptl_index := ptl_index DIV 2;
      WHILEND;

      IF (asid <> nos_asid) THEN
        asid_found := FALSE;
        asid_entry_p := top_asid_entry_p^.link_p;

       /search_asid_list/
        WHILE asid_entry_p <> NIL DO
          IF asid_entry_p^.asid = asid THEN
            asid_found := TRUE;
            EXIT /search_asid_list/;
          IFEND;
          asid_entry_p := asid_entry_p^.link_p;
        WHILEND /search_asid_list/;
      IFEND;

    UNTIL NOT asid_found;

  PROCEND build_asid;
?? TITLE := 'define_sta', EJECT ??

{ PURPOSE:
{   This procedure defines the STA (system table address) pointer for the given XP pointer.

  PROCEDURE define_sta
    (VAR xp_p: ^ost$exchange_package;
     VAR sta_p: ^SEQ ( * ));

    { Assumes that sta1/sta2 is a relative offset into xp/st segment.

    i#build_adaptable_seq_pointer (#RING (xp_p), #SEGMENT (xp_p),
          (10000(16) * xp_p^.segment_table_address_1) + xp_p^.segment_table_address_2,
          (xp_p^.segment_table_length + 1) * 8, 0, sta_p);

  PROCEND define_sta;
?? TITLE := 'find_segment', EJECT ??

{ PURPOSE:
{   This procedure searches the currect segment list for the desired segment.

  PROCEDURE find_segment
    (    segment_list_p: ^segment_list_entry;
         segment_number: ost$segment;
     VAR segment_entry: segment_list_entry);

    VAR
      segment_entry_p: ^segment_list_entry;

    segment_entry_p := segment_list_p^.link_p;

    WHILE segment_entry_p <> NIL DO
      IF segment_entry_p^.linked_segment_description.segment_number = segment_number THEN
        segment_entry := segment_entry_p^;
        RETURN;
      IFEND;
      segment_entry_p := segment_entry_p^.link_p;
    WHILEND;

    osp$system_error ('Unable to find desired segment in the segment entry list.', NIL);

  PROCEND find_segment;
?? TITLE := 'initiate_deadstart', EJECT ??

{ PURPOSE:
{   This procedure performs the final initialization of system core environment and then calls
{   DFT to start the CPU in the newly defined monitor address space.
{ NOTES:
{   There is no return from the call to this procedure, execution begins with the monitor
{   exchange package in system core.

  PROCEDURE initiate_deadstart;

    VAR
      boot_asids: [STATIC] dst$boot_asids := [0, 0, 0, 0],
      buffer_p: ^cell,
      core_sdt_p: ^mmt$segment_descriptor_table,
      display_rb: dpt$rb_display_request,
      monitor_sdt_p: ^mmt$segment_descriptor_table,
      mps: integer,
      status: ost$status,
      ste_p: ^integer;

    { Perform functions of real memory builder - define_segment, share_segment, extend_segment
    { HELP!!! How to do extend?????????????

    boot_asids.code_data := mtv$monitor_segment_table.st [0a(16)].ste.asid;
    boot_asids.job_stack := mtv$monitor_segment_table.st [0c(16)].ste.asid;
    boot_asids.mtr_stack := mtv$monitor_segment_table.st [0b(16)].ste.asid;
    boot_asids.spare := 0;
    dsp$save_boot_data_pointer (dsc$boot_asids, #SEQ (boot_asids));

    { Move some segment descriptor entries from the monitor boot SDT to the monitor SDT of the system
    { core.  Some segments in the system job monitor of system core are initialized from monitor's SDT.

    RESET core_sta_p;
    RESET monitor_sta_p;
    NEXT core_sdt_p: [0 .. 63] IN core_sta_p;
    NEXT monitor_sdt_p: [0 .. 63] IN monitor_sta_p;

    monitor_sdt_p^.st [syc$msn_page_table] := mtv$monitor_segment_table.st [syc$msn_page_table];
    monitor_sdt_p^.st [syc$msn_cyber_170_cache_bypass] :=
          mtv$monitor_segment_table.st [syc$msn_cyber_170_cache_bypass];
    monitor_sdt_p^.st [syc$msn_cyber_170] := mtv$monitor_segment_table.st [syc$msn_cyber_170];
    monitor_sdt_p^.st [syc$msn_system_status_record] :=
          mtv$monitor_segment_table.st [syc$msn_system_status_record];
    core_sdt_p^.st [syc$msn_page_table] := monitor_sdt_p^.st [syc$msn_page_table];
    core_sdt_p^.st [osc$segnum_mainframe_wired] := monitor_sdt_p^.st [syc$msn_mainframe_wired];
    core_sdt_p^.st [osc$segnum_mainframe_wired_cb] := monitor_sdt_p^.st [syc$msn_mainframe_wired_cb];
    core_sdt_p^.st [syc$msn_network_wired] := monitor_sdt_p^.st [syc$msn_network_wired];
    monitor_sdt_p^.st [mtc$job_fixed_segment] := core_sdt_p^.st [osc$segnum_job_fixed_heap];

    { Provide pointer to the EICB and the SDTE of the NOS exchange package.

    ste_p := #LOC (mtv$monitor_segment_table.st [#SEGMENT (osv$mainframe_wired_heap)]);
    monitor_xp_p^.x_registers [13] := ste_p^;
    monitor_xp_p^.x_registers [15] := #OFFSET (mtv$nst_p);
    i#real_memory_address (monitor_xp_p, mps);

    buffer_p := NIL;
    #PURGE_BUFFER (osc$purge_all_page_seg_map, buffer_p);
    #PURGE_BUFFER (osc$purge_all_cache, buffer_p);
    syp$display_deadstart_message ('Deadstart NOS/VE ...');

    { Check that SCD has finished displaying all data in the display queue.

    display_rb.reqcode := syc$rc_update_system_display;
    display_rb.action := dpc$da_check_scd_status;
    i#call_monitor (#LOC (display_rb), #SIZE (display_rb));

    dsp$change_monitor_xp (dsc$dft_select_first_active_cpu, mps, status);
    osp$system_error ('Deadstart cpu.', ^status);

  PROCEND initiate_deadstart;
?? TITLE := 'load_dcfile', EJECT ??

{ PURPOSE:
{   This procedure loads the DCFILE from the deadstart device.  The DCFILE must be loaded in the boot
{   because it is needed in system core before the page frame table is initialized and the deadstart
{   device can not be read until the page frame table is initialized.

  PROCEDURE load_dcfile;

    VAR
      bam_record_header_seq_p: ^SEQ ( * ),
      bam_record_header: bat$record_header,
      data_size_read: integer,
      dcfile_bam_header_p: ^bat$record_header,
      dcfile_found: boolean,
      dcfile_identifier_p: ^dst$dcfile_identifier,
      dcfile_length_p: ^0 .. dsc$max_dcfile_length,
      dcfile_line_p: ^SEQ ( * ),
      dcfile_seq_p: ^SEQ ( * ),
      device_line_p: ^SEQ ( * ),
      device_line_seq_p: ^SEQ ( * ),
      file_identifier: dst$deadstart_file_identifier;

    dsp$read_header_labels (file_identifier);
    IF file_identifier <> 'DCFILE' THEN
      osp$system_error ('Invalid deadstart file: Cannot find DCFILE.', NIL);
    IFEND;

    { Search for the correct DCFILE.

    bam_record_header_seq_p := #SEQ (bam_record_header);
    PUSH device_line_seq_p: [[REP osc$max_string_size OF cell]];
    RESET device_line_seq_p;
    dcfile_found := FALSE;

   /search_for_dcfile/
    WHILE TRUE DO
      dsp$read_deadstart_device (#SIZE (bam_record_header_seq_p^), bam_record_header_seq_p, data_size_read);
      IF data_size_read < #SIZE (bam_record_header_seq_p^) THEN
        EXIT /search_for_dcfile/;
      IFEND;
      IF bam_record_header.length > 0 THEN
        dsp$read_deadstart_device (bam_record_header.length, device_line_seq_p, data_size_read);
        IF data_size_read < bam_record_header.length THEN
          EXIT /search_for_dcfile/;
        IFEND;
        IF bam_record_header.length >= #SIZE (dst$dcfile_identifier) THEN
          NEXT dcfile_identifier_p IN device_line_seq_p;
          IF dcfile_identifier_p^ = dsv$dcfile_identifier THEN
            dcfile_found := TRUE;
            EXIT /search_for_dcfile/;
          IFEND;
        IFEND;
      IFEND;
    WHILEND /search_for_dcfile/;

    ALLOCATE dcfile_seq_p: [[REP dsc$max_dcfile_length OF cell]] IN osv$mainframe_wired_heap^;
    RESET dcfile_seq_p;
    dsp$save_boot_data_pointer (dsc$dcfile_data, dcfile_seq_p);
    NEXT dcfile_length_p IN dcfile_seq_p;
    dcfile_length_p^ := 0;

    IF NOT dcfile_found THEN
      RETURN;
    IFEND;

    WHILE TRUE DO
      dsp$read_deadstart_device (#SIZE (bam_record_header_seq_p^), bam_record_header_seq_p, data_size_read);
      IF data_size_read < #SIZE (bam_record_header_seq_p^) THEN
        RETURN;
      IFEND;
      IF bam_record_header.length > 0 THEN
        dsp$read_deadstart_device (bam_record_header.length, device_line_seq_p, data_size_read);
        IF data_size_read < bam_record_header.length THEN
          RETURN;
        IFEND;
        IF bam_record_header.length >= #SIZE (dst$dcfile_identifier) THEN
          NEXT dcfile_identifier_p IN device_line_seq_p;
          IF dcfile_identifier_p^ (1, 3) = dsv$dcfile_identifier (1, 3) THEN
            RETURN;
          IFEND;
          RESET device_line_seq_p;
        IFEND;

        NEXT dcfile_bam_header_p IN dcfile_seq_p;
        dcfile_length_p^ := dcfile_length_p^ + #SIZE (dcfile_bam_header_p^);
        dcfile_bam_header_p^ := bam_record_header;

        NEXT device_line_p: [[REP bam_record_header.length OF cell]] IN device_line_seq_p;
        RESET device_line_p;

        NEXT dcfile_line_p: [[REP bam_record_header.length OF cell]] IN dcfile_seq_p;
        dcfile_length_p^ := dcfile_length_p^ + #SIZE (dcfile_line_p^);
        RESET dcfile_line_p;

        dcfile_line_p^ := device_line_p^;
      IFEND;
    WHILEND;

  PROCEND load_dcfile;
?? TITLE := 'load_monitor_image', EJECT ??

{ PURPOSE:
{   This procedure loads the monitor image from the deadstart device.

  PROCEDURE load_monitor_image;

    CONST
      byte_limit = 500000(16);

    VAR
      asid: ost$asid,
      boot_page_count: integer,
      boot_page_size: integer,
      boot_segment: ost$segment,
      data_p: ^SEQ ( * ),
      data_size_read: integer,
      end_rma: integer,
      job_fixed_segment_number: ost$segment,
      memory_bounds: dst$ssr_boot_memory_bounds,
      memory_image_header: pmt$virtual_memory_image_header,
      memory_image_header_seq_p: ^SEQ ( * ),
      message: string (80),
      message_length: integer,
      page_boundary_segment_length: integer,
      remainder: integer,
      rma: integer,
      sdt_p: mmt$max_sdt_p,
      sdtxe: mmt$segment_descriptor_extended,
      segment_b_and_c_index: 1 .. 2,
      segment_entry: segment_list_entry,
      segment_header: pmt$linked_segment_description,
      segment_header_seq_p: ^SEQ ( * ),
      segment_index: ost$segment,
      segment_length: ost$segment_length,
      segment_number: ost$segment,
      start_rma: integer,
      status: ost$status,
      sva: ost$system_virtual_address,
      sva_count: integer,
      sva_found: boolean,
      sva_index: integer,
      temp_pva_p: ^cell;

    { The monitor image's header labels are not read here because they were read as part of
    { the dsp$prepare_deadstart_io code.

    { Read monitor image's memory image header from the deadstart device.

    memory_image_header_seq_p := #SEQ (memory_image_header);
    dsp$read_deadstart_device (#SIZE (pmt$virtual_memory_image_header), memory_image_header_seq_p,
          data_size_read);
    IF data_size_read < #SIZE (pmt$virtual_memory_image_header) THEN
      osp$system_error ('Invalid monitor memory image header.', NIL);
    IFEND;

    segment_header_seq_p := #SEQ (segment_header);
    segment_number := 0;
    job_fixed_segment_number := 0;
    FOR segment_index := 1 TO memory_image_header.number_of_segments DO

      { Read monitor image's segment header.

      RESET segment_header_seq_p;
      dsp$read_deadstart_device (#SIZE (pmt$linked_segment_description), segment_header_seq_p,
            data_size_read);
      IF data_size_read < #SIZE (pmt$linked_segment_description) THEN
        osp$system_error ('Invalid monitor segment header.', NIL);
      IFEND;

      { Build an ASID and add it to the SDT.

      build_asid (asid);
      sdte.ste.asid := asid;
      mmp$boot_add_sdt_sdtx_entry (sdte, sdtxe, segment_number);

      STRINGREP (message, message_length, '  loading segment ', segment_header.segment_number: 4: #(16),
            asid: 6: #(16), segment_header.length: 20);
      syp$trace_deadstart_message (message (1, message_length));

      { Pad the monitor code segment to enable recovery process capability of reload in monitor code space.

      IF segment_header.segment_number = #SEGMENT (memory_image_header.starting_procedure.code_pva) THEN

        { Build a job fixed ASID and add it to the SDT.

        build_asid (job_fixed_asid);
        sdte.ste.asid := job_fixed_asid;
        mmp$boot_add_sdt_sdtx_entry (sdte, sdtxe, job_fixed_segment_number);

        { Count the number of pages assigned to the boot.  The boot has three segments (A, B and C).

        boot_page_count := 0;
        boot_segment := #SEGMENT (osv$mainframe_wired_heap);
        mmp$get_max_sdt_pointer (^jmv$jmtr_xcb, sdt_p);
        sva.asid := sdt_p^.st [boot_segment].ste.asid;
        sva.offset := 0;
        WHILE (sva.offset < byte_limit) DO
          sva_found := FALSE;
          #HASH_SVA (sva, sva_index, sva_count, sva_found);
          IF sva_found THEN
            boot_page_count := boot_page_count + 1;
          IFEND;
          sva.offset := sva.offset + osv$page_size;
        WHILEND;
        FOR segment_b_and_c_index := 1 TO 2 DO { find # of pages in segments B and C }
          boot_segment := boot_segment + 1;
          sva.asid := sdt_p^.st [boot_segment].ste.asid;
          sva.offset := 0;
          sva_found := FALSE;
          REPEAT
            #HASH_SVA (sva, sva_index, sva_count, sva_found);
            IF sva_found THEN
              boot_page_count := boot_page_count + 1;
            IFEND;
            sva.offset := sva.offset + osv$page_size;
          UNTIL NOT sva_found;
        FOREND;
        boot_page_count := boot_page_count + 20;
        boot_page_size := (boot_page_count * osv$page_size);

        { Assign real memory to monitor code segment.

        temp_pva_p := #ADDRESS (1, segment_number, 0);
        pmp$zero_out_table (temp_pva_p, segment_header.length);

        { Round the segment length to a page boundary.

        page_boundary_segment_length := ((segment_header.length + osv$page_size - 1) DIV
              osv$page_size) * osv$page_size;

        { Add the remainder of pages to the system job's job fixed segment.

        remainder := boot_page_size - page_boundary_segment_length;
        temp_pva_p := #ADDRESS (1, job_fixed_segment_number, 0);
        pmp$zero_out_table (temp_pva_p, remainder);

        { Determine if the memory obtained is sequential.

        i#real_memory_address (#ADDRESS (1, segment_number, 0), start_rma);
        i#real_memory_address (#ADDRESS (1, job_fixed_segment_number, remainder - 1), end_rma);
        IF (end_rma - start_rma + 1) <> boot_page_size THEN
          osp$system_error ('Did not obtain sequential memory for monitor image.', NIL);
        IFEND;

        { Save the memory bounds in the SSR.  The RMA is converted to units of 100 octal words.

        rma := start_rma DIV 1000(8);
        memory_bounds.start_address.r_lower := rma MOD 10000(8);
        memory_bounds.start_address.r_upper := rma DIV 10000(8);
        rma := (end_rma - start_rma + 1) DIV 1000(8);
        memory_bounds.length.r_lower := rma MOD 10000(8);
        memory_bounds.length.r_upper := rma DIV 10000(8);
        dsp$store_data_in_ssr (dsc$ssr_boot_memory_bounds, #SEQ (memory_bounds));

      IFEND;

      { Read the monitor image's segment from the deadstart device.

      i#build_adaptable_seq_pointer (1, segment_number, 0, segment_header.length, 0, data_p);
      dsp$read_deadstart_device (segment_header.length, data_p, data_size_read);
      IF data_size_read < segment_header.length THEN
        osp$system_error ('Unable to read a segment from the deadstart device.', NIL);
      IFEND;
      save_segment_entry (asid, segment_header, current_monitor_segment_entry_p);
      save_asid_entry (asid);
    FOREND;

    { Find the monitor exchange package segment.  Add the ASID to the SDT.

    find_segment (top_monitor_segment_entry_p, #SEGMENT (memory_image_header.exchange_package),
          segment_entry);
    sdte.ste.asid := segment_entry.linked_segment_description.segment_descriptor.asid;
    mmp$boot_add_sdt_sdtx_entry (sdte, sdtxe, segment_number);

    { Retrieve a pointer to the monitor exchange package.

    monitor_xp_p := #ADDRESS (1, segment_number, #OFFSET (memory_image_header.exchange_package));
    define_sta (monitor_xp_p, monitor_sta_p);

    monitor_xp_p^.p_register.pva.seg := #SEGMENT (memory_image_header.starting_procedure.code_pva);
    monitor_xp_p^.p_register.pva.offset := #OFFSET (memory_image_header.starting_procedure.code_pva);
    monitor_xp_p^.a3 := memory_image_header.starting_procedure.binding_pva;

    i#real_memory_address (monitor_sta_p, rma);
    monitor_xp_p^.segment_table_address_1 := rma DIV 10000(16);
    monitor_xp_p^.segment_table_address_2 := rma MOD 10000(16);

    move_stes_to_segment_table (top_monitor_segment_entry_p, monitor_xp_p, monitor_sta_p, status);

  PROCEND load_monitor_image;
?? TITLE := 'load_system_core_image', EJECT ??

{ PURPOSE:
{   This procedure loads the system core image from the deadstart device.

  PROCEDURE load_system_core_image;

    VAR
      asid: ost$asid,
      core_xp_p: ^ost$exchange_package,
      data_p: ^SEQ ( * ),
      data_size_read: integer,
      file_identifier: dst$deadstart_file_identifier,
      memory_image_header: pmt$virtual_memory_image_header,
      memory_image_header_seq_p: ^SEQ ( * ),
      message: string (80),
      message_length: integer,
      ring_index: 1 .. 3,
      rma: integer,
      sdtxe: mmt$segment_descriptor_extended,
      segment_entry: segment_list_entry,
      segment_header: pmt$linked_segment_description,
      segment_header_seq_p: ^SEQ ( * ),
      segment_index: ost$segment,
      segment_length: ost$segment_length,
      segment_number: ost$segment,
      status: ost$status,
      stp_p: ^mmt$segment_descriptor_table;

    dsp$read_header_labels (file_identifier);
    IF file_identifier <> 'SYSTEM_CORE_IMAGE' THEN
      osp$system_error ('Invalid deadstart file: Cannot find SYSTEM_CORE_IMAGE.', NIL);
    IFEND;

    { Read system core image's memory image header from the deadstart device.

    memory_image_header_seq_p := #SEQ (memory_image_header);
    dsp$read_deadstart_device (#SIZE (pmt$virtual_memory_image_header), memory_image_header_seq_p,
          data_size_read);
    IF data_size_read < #SIZE (pmt$virtual_memory_image_header) THEN
      osp$system_error ('Invalid system core memory image header.', NIL);
    IFEND;

    segment_header_seq_p := #SEQ (segment_header);
    segment_number := 0;
    FOR segment_index := 1 TO memory_image_header.number_of_segments DO

      { Read system core image's segment header.

      RESET segment_header_seq_p;
      dsp$read_deadstart_device (#SIZE (pmt$linked_segment_description), segment_header_seq_p,
            data_size_read);
      IF data_size_read < #SIZE (pmt$linked_segment_description) THEN
        osp$system_error ('Invalid monitor segment header.', NIL);
      IFEND;

      { Build an ASID and add it to the SDT.

      IF segment_header.segment_number = #SEGMENT (memory_image_header.exchange_package) THEN
        asid := job_fixed_asid;
      ELSE
        build_asid (asid);
      IFEND;
      sdte.ste.asid := asid;
      mmp$boot_add_sdt_sdtx_entry (sdte, sdtxe, segment_number);

      STRINGREP (message, message_length, '  loading segment ', segment_header.segment_number: 4: #(16),
            asid: 6: #(16), segment_header.length: 20);
      syp$trace_deadstart_message (message (1, message_length));

      { Read the system core image's segment from the deadstart device.

      i#build_adaptable_seq_pointer (1, segment_number, 0, segment_header.length, 0, data_p);
      dsp$read_deadstart_device (segment_header.length, data_p, data_size_read);
      IF data_size_read < segment_header.length THEN
        osp$system_error ('Unable to read a segment from the deadstart device.', NIL);
      IFEND;
      save_segment_entry (asid, segment_header, current_core_segment_entry_p);
      save_asid_entry (asid);
    FOREND;

    { Find the system core exchange package segment.  Add the ASID to the SDT.

    find_segment (top_core_segment_entry_p, #SEGMENT (memory_image_header.exchange_package),
          segment_entry);
    sdte.ste.asid := segment_entry.linked_segment_description.segment_descriptor.asid;
    mmp$boot_add_sdt_sdtx_entry (sdte, sdtxe, segment_number);

    { Retrieve a pointer to the system core exchange package.

    core_xp_p := #ADDRESS (1, segment_number, #OFFSET (memory_image_header.exchange_package));
    define_sta (core_xp_p, core_sta_p);

    core_xp_p^.p_register.pva.ring := #RING (memory_image_header.starting_procedure.code_pva);
    core_xp_p^.p_register.pva.seg := #SEGMENT (memory_image_header.starting_procedure.code_pva);
    core_xp_p^.p_register.pva.offset := #OFFSET (memory_image_header.starting_procedure.code_pva);
    core_xp_p^.a3 := memory_image_header.starting_procedure.binding_pva;

    i#real_memory_address (core_sta_p, rma);
    core_xp_p^.segment_table_address_1 := rma DIV 10000(16);
    core_xp_p^.segment_table_address_2 := rma MOD 10000(16);

    move_stes_to_segment_table (top_core_segment_entry_p, core_xp_p, core_sta_p, status);

    RESET core_sta_p;
    NEXT stp_p: [0 .. core_xp_p^.segment_table_length] IN core_sta_p;
    FOR ring_index := 1 TO 3 DO
      core_xp_p^.tos_registers [ring_index].pva.ring := ring_index;
      stp_p^.st [core_xp_p^.tos_registers [ring_index].pva.seg].ste.r1 := ring_index;
      stp_p^.st [core_xp_p^.tos_registers [ring_index].pva.seg].ste.r2 := ring_index;
    FOREND;

  PROCEND load_system_core_image;
?? TITLE := 'move_stes_to_segment_table', EJECT ??

  PROCEDURE move_stes_to_segment_table
    (    segment_list_p: ^segment_list_entry;
     VAR xp_p: ^ost$exchange_package;
     VAR segment_table_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      entry: segment_table_entry,
      segment_entry_p: ^segment_list_entry,
      ste_p: ^ARRAY [0 .. * ] OF segment_table_entry;

    RESET segment_table_p;
    NEXT ste_p: [0 .. xp_p^.segment_table_length] IN segment_table_p;

    entry.fill := 0;
    segment_entry_p := segment_list_p^.link_p;
    WHILE segment_entry_p <> NIL DO
      entry.ste := segment_entry_p^.linked_segment_description.segment_descriptor;
      ste_p^ [segment_entry_p^.linked_segment_description.segment_number] := entry;
      segment_entry_p := segment_entry_p^.link_p;
    WHILEND;

  PROCEND move_stes_to_segment_table;
?? TITLE := 'save_asid_entry', EJECT ??

{ PURPOSE:
{   This procedure allocates an asid entry, saves the asid in the entry and adds the entry to the asid list.

  PROCEDURE save_asid_entry
    (    asid: ost$asid);

    VAR
      asid_entry_p: ^asid_list_entry;

    ALLOCATE asid_entry_p IN osv$mainframe_wired_heap^;
    asid_entry_p^.asid := asid;
    asid_entry_p^.link_p := NIL;

    current_asid_entry_p^.link_p := asid_entry_p;
    current_asid_entry_p := current_asid_entry_p^.link_p;

  PROCEND save_asid_entry;
?? TITLE := 'save_segment_entry', EJECT ??

{ PURPOSE:
{   This procedure allocates a segment entry, saves the segment information in the entry and
{   adds the entry to the segment list.

  PROCEDURE save_segment_entry
    (    asid: ost$asid;
         segment_descriptor: pmt$linked_segment_description;
     VAR current_segment_entry_p: ^segment_list_entry);

    VAR
      segment_entry_p: ^segment_list_entry;

    ALLOCATE segment_entry_p IN osv$mainframe_wired_heap^;
    segment_entry_p^.linked_segment_description := segment_descriptor;
    segment_entry_p^.linked_segment_description.segment_descriptor.asid := asid;
    segment_entry_p^.link_p := NIL;

    current_segment_entry_p^.link_p := segment_entry_p;
    current_segment_entry_p := current_segment_entry_p^.link_p;

  PROCEND save_segment_entry;
?? TITLE := 'dsp$boot_deadstart_loader', EJECT ??

{ PURPOSE:
{   This procedure determines whether the deadstart device contains a valid deadstart file and
{   loads the memory image and the system core image from the device.  If there are no fatal errors
{   during the loading of these files, control should change to the system core after this procedure
{   has completed.

  PROCEDURE [XDCL] dsp$boot_deadstart_loader;

    VAR
      asid_index: integer,
      display_deadstart_screens: boolean,
      sdt_p: mmt$max_sdt_p,
      status: ost$status;

    { Configure the deadstart device and read the first labels from the device.  The deadstart
    { displays will be accessed if there is any error.

    display_deadstart_screens := FALSE;

    /access_deadstart_device/
    WHILE TRUE DO
      IF display_deadstart_screens THEN
        cmp$write_os_status (' ', status);
        cmp$de_configure_ds_device (status);
        cmp$vcmb_menu_manager;
      IFEND;
      display_deadstart_screens := TRUE;

      IF cmv$system_device_data [cmc$sdt_tape_device].specified THEN
        cmp$configure_deadstart_device (cmc$sdt_tape_device, status);
      ELSE
        cmp$configure_deadstart_device (cmc$sdt_disk_device, status);
      IFEND;
      IF NOT status.normal THEN
        CYCLE /access_deadstart_device/;
      IFEND;

      dsp$prepare_deadstart_io (status);
      IF NOT status.normal THEN
        CYCLE /access_deadstart_device/;
      IFEND;

      EXIT /access_deadstart_device/;
    WHILEND /access_deadstart_device/;

    { Set up some variables used by the loading procedures.

    ALLOCATE top_asid_entry_p IN osv$mainframe_wired_heap^;
    top_asid_entry_p^.link_p := NIL;
    current_asid_entry_p := top_asid_entry_p;

    ALLOCATE top_monitor_segment_entry_p IN osv$mainframe_wired_heap^;
    top_monitor_segment_entry_p^.link_p := NIL;
    current_monitor_segment_entry_p := top_monitor_segment_entry_p;

    ALLOCATE top_core_segment_entry_p IN osv$mainframe_wired_heap^;
    top_core_segment_entry_p^.link_p := NIL;
    current_core_segment_entry_p := top_core_segment_entry_p;

    { Reserve the BOOT asids.

    mmp$get_max_sdt_pointer (^jmv$jmtr_xcb, sdt_p);
    FOR asid_index := 0 TO jmv$jmtr_xcb.xp.segment_table_length DO
      IF sdt_p^.st [asid_index].ste.vl <> osc$vl_invalid_entry THEN
        save_asid_entry (sdt_p^.st [asid_index].ste.asid);
      IFEND;
    FOREND;
    save_asid_entry (0);

    { Load the monitor image.

    syp$display_deadstart_message ('Loading the monitor image ...');
    load_monitor_image;

    { Load the system core image.

    syp$display_deadstart_message ('Loading the system core image ...');
    load_system_core_image;

    { Load the DCFILE.

    syp$display_deadstart_message ('Loading the DCFILE ...');
    load_dcfile;

    { Deconfigure the deadstart device.

    cmp$de_configure_ds_device (status);
    IF NOT status.normal THEN
      osp$system_error ('Deconfigure deadstart device failed', ^status);
    IFEND;

    { Initiate the deadstart of system core.

    initiate_deadstart;

  PROCEND dsp$boot_deadstart_loader;
MODEND dsm$boot
*DECK DECK=DSM$BOOT_INTERRUPT_HANDLER EXPAND=TRUE
dsm$boot_interrupt_handler IDENT
*COPY     SYA$CONSTANTS
.
.  Deck SYA$CYBIL_INTERFACE_PROCEDURES follows but is not listed.
         list,1  0,0,0
*COPY   SYA$CYBIL_INTERFACE_PROCEDURES
         list,1  1,2,0
         page
*COPY   MTA$CPU_STATE_TABLE
*COPY   MTA$SMU_COMMUNICATION_BLOCK
*COPY    OSA$DUAL_STATE_CONTROL_BLOCK
*copyc mta$dft_block
*COPY OSA$KEYPOINT_CLASSES
*copyc sya$xp_and_sf_constants
.
.
.      Define offsets into the request table entry.
.
rqtbles  equ     5*8                   .Size of request table entry
rn       equ     0                     .Highest RN for the request
il       equ     1                     .Interlock ordinal
rc       equ     2                     .Request code
totalt   equ     1*8                   .Total time for the request
maxt     equ     2*8                   .Max time to process the request
rqcnt    equ     maxt+4                .Count of times request was issued
wtcnt    equ     3*8                   .count of times waited for lock
maxwt    equ     wtcnt+4               .max wait for lock
totwt    equ     4*8                   .total wait time for lock
.
.      define offsets into interlock table.
.
ilsize   equ     3*8                   .size of interlock table entry.
ilflag   equ     0                     .interlock flag
lockcp   equ     1                     .lowest four (4) bytes of base constant
                                       . register contents of locking cpu
ilwtcnt  equ     1*8                   .lock wait count
ilmaxwt  equ     ilwtcnt+4             .max wait for lock
iltotwt  equ     2*8                   .total wait for lock
.
.      Define the request codes.  These request codes should match the
.      CYBIL declarations in SYDMTRR.
.
rqunim   equ     0                     .Unimplemented request code
rqpf     equ     9                     .Code for PAGE FAULT.
rqfault  equ     20                    .Code for MCR/UCR faults.
tsksw    equ     51                    .task switch
pswarn   equ     52                    .process short warning
mon_smu  equ     53                    .monitor_smu_status
proc_io  equ     54                    .process_io_completions
ascii_kb equ     56                    .process ascii keyboard
key_pnt  equ     57                    .monitor_keypoint_recorder
per_call equ     58                    .periodic_call
proc_due equ     59                    .process_due
in_ckp   equ     60                    .initiate_checkpoint
mm_ei    equ     62                    .process_170_mtr_requests
proc_dft equ     66                    .process DFT block
         page
.
.
. XTRACE - This macro is used to keep trace information about what happens.
.    The TRACE buffer is a circular buffer containing a list of the last
.    128 items of interest. Items currently maintained are:
.       0. exchange to job mode. (timestamp)
.       1. exchange from job mode. (timestamp, MCR)
.       2. trap in monitor mode. (timestamp, MCR)
.       3. EXCHANGE to NOS for EXCHREQ trap. (timestamp)
.       4. EXCHANGE back from NOS for EXCHREQ trap. (timestamp, MCR)
.       5. Taskswitch. (timestamp, new task XP RMA)
.    An entry in the trace buffer is 1 word long and contains:
.       bit 0 - 3,  trace id. Same as item number in above list
.       bit 4-31, data dependant on id. Usually MCR or XP RMA.
.       bit 32-63, elapsed microseconds since last entry in trace buffer
.
.    calling sequence to macro....
.
.        xtrace  p0,p1,p2,p3
.           p0 - contains trace id (0 .. 4)
.           p1 - contains data to be saved
.           p2, p3 - 2 X-registers that can be used for scratch
.              WARNING - X0 cannot be used for p2.
.           p4 - scratch A register
         PROC
xtrace   pname
f:(0)    bss     0
         local   t1,t2
         lx      f:(2,2),a_cst,tracectl
         brxgt   x0,f:(2,2),t2
         cpyxa   f:(2,4),f:(2,2)
         entp    f:(2,3),0
         cpytx   f:(2,3),f:(2,3)
         lx      f:(2,2),f:(2,4),0
         sx      f:(2,3),f:(2,4),0
         subx    f:(2,3),f:(2,2)
         entp    f:(2,2),f:(2,0)
         insb    f:(2,3),f:(2,2),x0,0003(8)
         lx      f:(2,2),f:(2,4),8
         isob    f:(2,2),f:(2,2),x0,7007(8)   .WARNING - <tracesiz> dependent.
         incx    f:(2,2),1
         sx      f:(2,2),f:(2,4),8
         do      sn:(f:(2,1))/=sn:(0)
         insb    f:(2,3),f:(2,1),x0,0433(8)
54       dend
         sxi     f:(2,3),f:(2,4),f:(2,2),8
t2       bss    0
         pend
         page
.
.
. HISTO - This macro is used to build a table of values of a variable. The
.         table consists of 64 word aligned values T0 .. t63. The value
.         of T0 is the number of times the macro was executed with
.         of the input variable negative (full word). For 1 <= i <=63,
.         the value of Ti is the number of times the macro was executed
.         with 2**(i-1) <= input variable < 2**i.
.
.       histo    xpar,atab,tab,xscr1,xscr2
.            where   xpar - X register that contains the value to be tabulated
.                    atab - A register that points to tabulation table
.                    tab  - symbol assigned to tabulation table - beginning
.                          of table is at (atab)+tab
.                    xscr1- X register to use for scratch calculations.
.                    xscr2- X register to use for scratch calculations.
.
ahisto   equ     0                     .Set this variable non-zero to activate HISTO
.
         PROC
histo    pname
         do      ahisto/=0
         do      sc:(f:(2,2))=0
         USE     oss$mainframe_wired
         def     f:(2,2)
         align   0,32
         vfd,64  c'f:(2,2)'
f:(2,2)  bssz    64*8
         USE     #LASTSEC
         dend
         local   l1,l2
         brxge   f:(2,0),x0,l1
         entn    f:(2,3),1
         brxeq   x0,x0,l2
l1       cnif    f:(2,3),f:(2,0)
         isob    f:(2,3),f:(2,3),x0,0413(8)
l2       lxi     f:(2,4),f:(2,1),f:(2,3),f:(2,2)+8
         incx    f:(2,4),1
         sxi     f:(2,4),f:(2,1),f:(2,3),f:(2,2)+8
         DEND
         PEND
         page
.
.
. ERRSTOP - This macro generates a call to the error stop routine to
.           terminate 180 operation after an unrecoverable error has
.           occurred.
.
.         errstop p1
.              where p1 = label on a string that defines the error halt message
.
         PROC
errstop  pname
f:(0)    addaq   af,a_root,f:(2,0)
         cpyaa   ae,a0
         addaq   a0,a0,8
         sa      af,ae,0
         entl    x0,31
         sbyts,2 x0,ae,x0,6
         ente    x0,00ff(16)
         callseg bs_errst,a_bindin,ae
         PEND
         page
*COPY     OSA$BASIC_REGISTER_EQUATES
         page
*COPY   SYA$ISSUE_KEYPOINTS_IN_HANDLERS
         page
.
.
.  Define A and X register usage
.   Note...
.        1. X0, X1, X2, XD, XE and XF are scratch registers
.        2. AE and AF are scratch registers
.        3.AF contains a pointer to 'xpinitv' at deadstart time. Its
.          used only for system initialization
.
a_sitret areg    15                    .Return address for PRSIT routine.
a_cst    areg    8                     .Pointer to CST.
a_rqtbl  areg    7                     .Contains the pointer to REQTBL entry
a_xcb    areg    6
a_root   areg    5
a_dscb   areg    4                     .NOS170 DSCB.
.
x_mcr    xreg    3                     .Scratch reg for MCR
x_ucr    xreg    4                     .Scratch reg for UCR
x_clock  xreg    5                     .Contains PIT/FRC values.
x_envir1 equ     00d7(16)              .Environment for CALL.
.
.  Equates for call to Interrupt processor.
.
x_inmcr  xreg    7                     .NOS170 MCR.
x_infrc  xreg    6                     .Save for free running clock.
a_innosx areg    9                     .Pointer to NOS XCB.
a_inret  areg    10                    .Return address.
a_rq_ret areg    11                    .rqproc return address
a_parm   areg    12                    .call parameters
a_extret areg    13                    .return from extint.
.
.  Equates for IDLE180.
x_resume xreg     8                    .contains RESUME ALLOWED.
.
         page
.
.
.  define procedure to define and initialize cst entries.
.
.
         PROC
defcst   pname
lpidz    set     0
         while   lpidz<f:(2,0)
         local   cst1
cst1     bssz    cstsize
.  Preset some values in the CST.

.        The value of MEMPORT is set early in initialization based on processor type.

         org     cst1+memport
         vfd,8   1**(lpidz*2)
         org     cst1+lpid
         vfd,8   lpidz
         org     cst1+lpid8
         vfs,8   lpidz*8
         org     cst1+cpu_stat
         vfd,8   2
         org     cst1+tracectl
         vfd,16  0
         address r,trace+lpidz*(tracesiz+2)*8
         org     cst1+taskid
         vfd,16,8 1,1
         org     cst1+dsprior
         vfd,16  0308(16)
         org     cst1+jcbp
         vfd,4,12,32 1,mstlen,0
         org     cst1+xcbp
         vfd,4,12,32 1,mstlen,jrootsiz
         org     cst1+cptime
         vfd,64  0ffffffffffff(16)
         org     cst1+cachtim
         vfd,64  07fffffffffffffff(16)
         org     cst1+maptim
         vfd,64  07fffffffffffffff(16)
         org     cst1+idlstats+idle_cnt
         vfd,56  1                       . initialize the cpu idle count
         org     cst1+cstsize
lpidz    set     lpidz+1
         dend
         pend
         page
...................................................................
.
.   Define the bootstrap section to the Assembler. This section
.   will contain code,data,and binding entries
.
...................................................................
oss$mainframe_wired   SECTION working,read+execute+write
         USE     oss$mainframe_wired
.....................................................................
.        LIT       - Load Interface Table.
.
.        The load interface table provides the information required
.        by the NOS/VE boot to establish the full boot environment.
.
.        Define the load size of the boot.
.
         def     root
root     equ     $
         def     osv$boot_load_size_in_bytes
osv$boot_load_size_in_bytes bss 0
BOOT_LBA vfd,32  2000(16)
.
.        Define the NOS/VE BOOT version and level.  The format of this
.        is rigidly defined.  If it is changed the utility that packages
.        the BOOT for CIP tapes must also be modified.
.
         def     osv$boot_version
osv$boot_version bss 0
         vfd,6   0                     .filler
         vfd,6   1                     . os type
         vfd,6   0                     .Interface version
         vfd,6   0                     .Interface level
.
.        The version number is a decimal number that is put in hex for convenience
.        when checking version number in memory.
.
         vfd,8   007(16)               .BOOT version number
.
.        DEFINE BOOT STOP ADDRESS.
.
         def     osp$boot_halt
         align   0,8
osp$boot_halt bss    0
         brreq   X0,X0,osp$boot_halt   .STOP THE MUSIC
.
.        Date dsm$boot_interrupt_handler deck changed.
.
         def     osv$boot_assembly_date
osv$boot_assembly_date bss 0
*put '  vfd,32 '//$substr($date(iso),6,2)//$substr($date(iso),9,2)//$substr($date(iso),1,4)//'(16)'
.
.        Relative byte offset from beginning of boot of monitor exchange package.
.
.        NOTE:
.        The location of this offset can not change without changing SCI, this is
.        how SCI figures out where the exchange package of boot monitor is.  SCI
.        expects to find it at byte offset 10(16) from the beginning of the boot.
.
         def     osv$boot_mps_offset
osv$boot_mps_offset bss 0
         vfd,32  mxp
.
...................................................................
.
.        NOS/VE memory limits.  Defines the upper and lower bounds of NOS/VE
.        memory, the bounds are RMAs.  During deadstart the memory upper bound
.        is determined by the size of the memory image.
.
.        NOTE:  The memlimit variable is referenced from Cybil, definition is
.        defined by the variable 'osv$180_memory_limits'.
.
...................................................................
memlimit vfd,32  0                     .Lower bound.
         vfd,32  0                     .Upper bound during deadstart.
         vfd,32  0                     .Upper bound after system initialized.
         PAGE

.        Variables and equates specifically for boot module.
.
.        Real memory word address 71(8) (real memory address 1c8(16)) contains the
.        real memory word address of the environment interface control block (EICB).

eicbadr  equ     71(8)*8               .Real memory address of EICB pointer.
bctadr   equ     65(8)*8               .Real memory address of the Boot Control Table.
.
pgtabpva vfd,48  0100000000000(16)     .page table PVA
mstkpva  vfd,48  0100b00000000(16)     .mtr stack PVA
jstkpva  vfd,48  0100c00000000(16)     .job stack PVA
.
         align   0,8
free_rma vfd,64  0                     .RMA of available memory
sadjcbp  address r,jcb
sadmsdt  address r,mst
sadjsdt  address r,jst
sadxcbp  address r,jxcb
         defg    osv$boot_sdte
         defg    osv$boot
         defg    osv$boot_is_executing
         defg    dsv$ssr_sdte
osv$boot vfd,8   1
osv$boot_sdte vfd,64 0
dsv$ssr_sdte  vfd,64 0
osv$boot_is_executing vfd,8 1
hnsk_p   address p,dsv$cpu_pp_communication_block
         ref     dsv$cpu_pp_communication_block
         align   0,8
         page
.....................................................................
.
.   Define the initial monitor exchange package and segment table.
.   The monitor exchange package and segment table are located at
.   the beginning of the primary boot segment.
.
.....................................................................
mstackl  equ     xpsize+mstlen*8+mstksize
         align   0,32
mxp      ALIAS   MTV$MONITOR_EXCHANGE_PACKAGE
         def     mst
         defg    mxp
mxp      bssz    xpsize
         align   0,32
mst      bssz    mstlen*8
mstend   bss       0
         xpa     mxp,2,begin
         xpa     mxp,xptos,nil
         xpareg  mxp,a_tos,nil
         xpareg  mxp,a_csf,nil
         xpareg  mxp,a_psa,nil
         xpareg  mxp,a_bindin,bindsec
         xpv     mxp,10+a_xcb*8,mstlen+01000(16),16
         xpv     mxp,12+a_xcb*8,jr_mxcb,32
         xpareg  mxp,a_root,root,0
         xpareg  mxp,a_plist,nil
         xpareg  mxp,7,mxp,0
         xpareg  mxp,8,nil
         xpareg  mxp,9,nil
         xpareg  mxp,10,nil
         xpareg  mxp,11,nil
         xpareg  mxp,12,nil
         xpareg  mxp,13,nil
         xpareg  mxp,14,nil
         xpareg  mxp,15,nil
         xpv     mxp,xpstal,mst,16         .Segment table address
         xpv     mxp,xpstl,mstlen,16       .Segment table length
         xpv     mxp,xpmm,m_mtrmsk,16  .Monitor mask
         xpv     mxp,xpum,m_usrmsk,16  .User mask
         xpv     mxp,xpkm,0,16
         xpv     mxp,xppit,0ffff(16),16  .Monitor PIT
         xpv     mxp,xppit+8,0ffff(16),16
         xpv     mxp,xplrn,1,16
         xpa     mxp,xptp,bs_trap,0
         xpv     mxp,xpflgte,00000(16),16
         xpv     mxp,xpbc1,cst0u,16
         xpv     mxp,xpbc2,cst0l,16
         xpv     mxp,248,cst0,32  .Set offset and length of CST0 into XE
         xpv     mxp,252,cstsize,32
         page
.
. Note that only two Segment table entries contain an ASID. The ASID
. for the page table and the primary boot segment will be changed
. early in the execution of this module. The ASIDs found in this
. segment table must not be changed as SCI knows these two ASIDS
. and will create one PTE for each of these two segments as
. part of the process of loading the boot for deadstart.
.
mst      alias   MTV$MONITOR_SEGMENT_TABLE
         org     mst
pt_seg   vfd,64  0ca11000100000000(16)  .seg 0 page table segment

.        Segment 1 is used for a special purpose while creating the page table
.        entries for the page table.  A page table entry is added to the first
.        page of the page table for page 0 of this segment.  If the page for
.        the page table entry is not in the page table, the page frame address of
.        the segment 1 page table entry is changed to point to the page for the
.        new page table entry.  The new page table entry is then stored in the
.        page table using segment 1.  The page table entry for segment 1 is
.        deleted after all of the page table entries for the page table are
.        created.  The ASID of segment 1 is zero.

seg1     vfd,64  0ca11000000000000(16)  .seg  1, used to create page table
         vfd,64  00000000000000000(16)  .seg  2  null entry
mnosste  vfd,64  00000000000000000(16)  .seg  3  NOS
mnsfste  vfd,64  00000000000000000(16)  .seg  4  NOS stack and the SSR
         vfd,64  00000000000000000(16)  .seg  5  null entry
         vfd,64  00000000000000000(16)  .seg  6  null entry
         vfd,64  00000000000000000(16)  .seg  7  null entry
         vfd,64  00000000000000000(16)  .seg  8  null entry
         vfd,64  00000000000000000(16)  .seg  9  null entry
bootste  vfd,64  0fe11000200000000(16)  .seg  A  BOOT primary segment
msfste   vfd,64  0ca11000000000000(16)  .seg  B  Boot monitor mode stack segment
jsfste   vfd,64  0ca11000000000000(16)  .seg  C  Boot job mode stack segment
         vfd,64  00000000000000000(16)  .Pad segment table
.
         org     mstend
         page
.....................................................................
.
.   BOOT - Execution at deadstart starts here. Create page table entries for
.          page table, boot segment, boot stack, job stack, NOS,
.          and NOS (trap) stack.  Segment 1 is defined with an ASID of zero,
.          it is used to address any page during initialization of the page
.          table.  If the page where the page table entry is to be stored does
.          not have a valid page table entry, the RMA in the page table entry
.          for segment 1, page 0 is changed and that PVA is used to store the
.          page table entry.  Using this method allows the building of the
.          page table entries with the final ASID the first time.
.
.          This is what the page table looks like when execution starts here:
.               page_table [2] = page table entry for page 0 of page table.
.               page_table [4] = page table entry for page 0 of this code.
.               page_table [0] = will be used for segment 1 page table entry,
.                                initially it is zero.
.....................................................................
         def     begin
         def     rqproc
         def     run_nos
begin    bss     0
         def     osp$prepare_os_environment
osp$prepare_os_environment equ $
.
.        Purge all maps and cache.
.
         purge   x0,2                  .purge all of cache.
         purge   x0,0f(16)             .purge all maps.
.
.        Establish X-register values required to manipulate page table.
.                xd = page table length.
.                xe = page size mask.
.                xf = page offset mask, used to mask page number from SVA.
.
begin2   entl    x0,r_psm              .page size mask
         cpysx   x2,x0
         isom    xf,x0,47
         shfx    x2,x2,x0,9
         iorx    xf,x2                 .form mask for page offset
         notx    xe,xf
         incx    xe,1                  .page size in bytes

         entl    x0,r_ptl              .page table length
         cpysx   x2,x0
         incr    x2,1
         shfx    xd,x2,x0,12           .Xd:= page table length in bytes
.
.        Create page table entry for the first page of the page table using the
.        new ASID.  Expect this page table entry to be in page 0 of page table.
.
         addpxq  a9,x0,boot5           .Find ASID for page table
         brreq   x0,x0,fasid
boot5    bss     0
         shfx    x3,x3,x0,32           .X3:= SVA of page table
         la      ac,a_root,pgtabpva    .PVA of page table
         isom    x4,x0,1               .Create page table entry for segment 1
         tpage   xc,ac
         sbyts,8 x4,ac,x0,0
         cpyxx   x6,xc                 .X6:= RMA of page table
         cpyxx   x5,xe                 .X5:= length of one page
         addpxq  a9,x0,boot10
         brreq   x0,x0,cseg            .Create PTE for page 0 of page table
boot10   bss     0
         shfx    x4,x3,x0,-32          .Store new PT ASID in segment table
         entp    x8,0                  .Zero out page table entry for first
                                       . page of page table with old ASID
         sbyts,2 x4,a_root,x0,pt_seg+2
         sbyts,8 x8,ac,x0,2*8

.        Purge all maps and cache in order to start using new page table ASID.

         purge   x0,2
         purge   x0,0f(16)

.        Create page table entry for remainder of page table with new ASID.

         cpyxx   x5,xd                 .Page table length
         addpxq  a9,x0,boot15
         brreq   x0,x0,cseg            .Create page table entries for page table
boot15   bss     0
.
.        Create page table entries for the boot segment using new ASID.
.
         entp    x8,0                  .Zero out page table entry for segment 1
         addpxq  a9,x0,boot20          .Find ASID for boot segment
         sbyts,8 x8,ac,x0,0
         brreq   x0,x0,fasid
boot20   bss     0
         shfx    x3,x3,x0,32           .X3:= SVA of boot segment
         tpage   x6,a_root
         lbyts,4 x5,a_root,x0,boot_lba  .Length of boot segment
         addpxq  a9,x0,boot25
         brreq   x0,x0,cseg            .Create page table entries for boot segment
boot25   bss     0
         shfx    x4,x3,x0,-32          .Store new boot segment ASID in
                                       . segment table
         entp    x8,0
         sx      x6,a_root,free_rma    .Save RMA of available memory
         sbyts,8 x8,a_root,x0,seg1     .Zero out segment table entry for segment 1
         sbyts,2 x4,a_root,x0,bootste+2
.
.        Purge all maps and cache in order to start using new boot segment ASID.
.
         purge   x0,2
         purge   x0,0f(16)

.        On some machines the page map may not be cleared by the purge instructions
.        for the currently executing code.  Doing an inter segment branch will clear
.        the page map when P is translated from the PVA again.  It handily works out
.        that we now are beyond the minimum environment needed for startup.

         addpxq  a9,x0,boot30          .set branch address.
         brdir   a9,x0                 .clear page map.
         page
..
.        CSEG - Create page table entries for specified segment.
.               Creation of the page table is special cased.  If the page where
.               the page table entry is to be stored is not valid, the entry
.               is stored using segment 1.
.
.        ENTRY:
.                x3 = SVA of start of segment.
.                x6 = RMA of start of segment.
.                x5 = length of segment (offset of last byte address + 1).
.                xe = page size in bytes.
.                xf = page offset mask.
.                a9 = return address.
.                ac = PVA of page table
.
.        EXIT:
.                x3 = SVA of page following segment created.
.                x6 = RMA of page following segment created.
.
.        USES:
.                a - 7, b.
.                x - 1, 2, 3, 4, 6, 8, 9.
.

cseg     entp    x8,3                  .valid + continue bit
         la      ab,a_root,pgtabpva    .PVA of page table.
         shfx    x8,x8,x0,62-0
cseg5    lpage   x2,x3,x1
.
.        If there are no available slots in the page table for
.        the SVA, then LPAGE returns with X1 equal to 32,
.        ie. the number of entries searched.
.
         cpyaa   a7,ab
         ente    x4,31
         addax   a7,x2                 .Page table PVA for page table entry
         brrgt   x1,x4,cseg20          .If no available slot in page table
         cpyxx   x1,x3
         tpage   x9,a7                 .Check if page table page in memory.
         andx    x1,xf                 .form segment/page identifier
         shfx    x4,x6,x0,-9           .form page frame address
         shfr    x1,x1,x0,1            .trim sign bit from offset
         shfx    x1,x1,x0,22-9-1
         iorx    x1,x4
         iorx    x1,x8
         brrgt   x0,x9,cseg15          .If page table page not in memory
         sbyts,8 x1,ac,x2,0            .store page table entry
cseg10   bss     0
         addr    x3,xe                 .update SVA
         addr    x6,xe                 .update RMA
         brrgt   x5,x3,cseg5           .if more entries to build
         brdir   a9,x0                 .return

.        Page table page not in memory, store page table entry using segment 1.

cseg15   bss     0
         entl    x0,r_pta
         ente    x9,1001(16)           .Form PVA for segment 1
         cpysx   x4,x0                 .Page table address
         shfx    x9,x9,x0,32
         addr    x4,x2                 .RMA for page table entry
         cpyxx   x2,x4
         andx    x4,xf                 .Round to page size
         inhx    x2,xf                 .Offset from page frame address for PTE
         shfx    x4,x4,x0,-9           .Page frame address

.        Set page frame address in page table entry for segment 1.  Page frame
.        address is for the page of the page table where the PTE entry is to
.        be stored.

         sbyts,3 x4,ab,x0,5
         cpyxa   a7,x9
         purge   x9,10                 .Purge page map, page table modified
         sbyts,8 x1,a7,x2,0            .Store page table entry for PT page
         brreq   x0,x0,cseg10          .Continue

.        Page table full, hang.

cseg20   brreq   x0,x0,cseg20          .Page table full, hang

         page
..
.        FASID - Find ASID.
.                This algorithm attempts to distribute ASIDs as far apart in
.                the page table as possible.  The algorithm is described below
.                in Cybil.
.
.        ENTRY:
.                a9 = return address.
.        EXIT:
.                x3 = ASID generated by algorithm.
.
.        USES:
.                x - 0,1, 2, 3, 4, 5, 7, 8.
.
. Selecting ASIDs for each segment
.
. PROCEDURE get_asid (VAR asid: ost$asid);
.
.
.   VAR
.     i,
.     f: integer,
.     found: boolean,
.     last_asid: ^dst$reserved_asids;
.   found := TRUE;
.   page_table_length := mmv$pt_length * 8;
.   REPEAT
.     i := asid_seed;
.     asid_seed := asid_seed + 1;
. {  Page_table_length is the PTL register.
.     f := ((((page_table_length MOD 100(16)) + 1) * 1000(16) DIV 32);
.     asid := 0;
.     WHILE i <> 0 DO
.       IF (i MOD 2) <> 0 THEN
.         asid := asid + f;
.       IFEND;
.       i := i DIV 2;
.       f := f DIV 2;
.     WHILEND;
.
.     IF (asid <> nos_asid) THEN
.       search_reserved_asids (asid, found, last_asid);
.     IFEND;
.   UNTIL NOT found;
. PROCEND get_asid;
.



fasid    bss     0
         lbyts,2 x1,a_root,x0,asidseed  .ASID seed
         entl    x0,r_ptl
         cpyxx   x7,x1                 .Initial ASID seed, represents i
         incx    x1,1                  .increment asid seed by 1
         cpysx   x2,x0                 .Read PTL register
         sbyts,2 x1,a_root,x0,asidseed
         isob    x2,x2,x0,(56*64)+7    .low order 8 bits of PTL
         entp    x3,0                  .asid:=0
         incx    x2,1
         shfx    x2,x2,x0,12-5         .((PTL + 1) * 1000(16)) DIV 32, represents f

.        Generate ASID, basically this creates a mirror image of the initial
.        ASID seed.

fasid5   bss     0
         isob    x4,x7,x0,(63*64)+0
         shfx    x7,x7,x0,-1           .Initial ASID seed DIV 2
         brxeq   x4,x0,fasid10         .If even number, nothing to invert
         addx    x3,x2
fasid10  bss     0
         shfx    x2,x2,x0,-1           .ASID hash DIV 2
         brrne   x7,x0,fasid5          .If more bits to invert
         brreq   x0,x3,fasid           .If ASID of zero, will not use
         isom    x4,x0,(48*64)+15      .hardwired 170 asid of 0FFFF(16)
         entp    x6,0                  .Initialize 'asidlist' index
         brxeq   x4,x3,fasid           .If 170 ASID, find another one
.
.        Check list of previously assigned ASIDs to see if already assigned.

fasid15  bss     0
         lbyts,2 x2,a_root,x6,asidlist
         incx    x6,2
         brreq   x2,x3,fasid           .If ASID already assigned
         brrne   x2,x0,fasid15         .If more ASIDs in previously assigned
                                       . ASID list
         decx    x6,2
         sbyts,2 x3,a_root,x6,asidlist  .Save assigned ASID in list
         brdir   a9,x0               .Return

.        Define area to save list of assigned ASIDs.  Expect this list to
.        end with a zero ASID.  If more than 15 ASIDs are ever assigned this
.        list will have to be expanded.

asidlist vfd,16*16 0
asidseed vfd,16  1                   .Initial ASID seed

.        The initial part of the boot must run in less than a 2K page, this
.        is the end of that code.

pof      bss     0                   .page overflow check.
         error,pof>7ff(16)  c'VCB overflows 2K page size.'

         PAGE

.        At this point all of the page table entries are defined for the page
.        table and the boot code segment.

         align   0,2
boot30   bss     0
         sbyts,8 x8,ac,x0,4*8          .Zero out old page table entry for first
                                       . page of boot segment
.
.        Find preferred ASID for the SSR segment.  When running dual state
.        bytes 0 to 0fff(16) of the SSR segment are used for the 170
.        stack.  The SSR begins at byte offset 1000(16).
.
         addpxq  a9,x0,boot35
         brreq   x0,x0,fasid
.
.        Add segment table entries for 170 and 170 stack into monitor's segment
.        table.  Create page table entries to address EICB.
.
boot35   bss     0
         sbyts,2 x3,a_root,x0,nsfste+2  .Save ASID in 170 segment table
         la      af,a_root,sadmsdt
         la      ae,a_root,nossegt
         lbyts,8 x5,ae,x0,snnos170*8
         isom    x3,x0,((1*64)+0)
         sx      x5,af,snnosmtr*8
         iorx    x5,x3                 .set cache bypass attribute.
         sx      x5,af,sn170mcb*8      .set 170 cache bypass segment table entry.
         lbyts,8 x5,ae,x0,snsf170*8
         sx      x5,af,snsfmtr*8
         sbyts,8 x5,a_root,x0,dsv$ssr_sdte  .make NOS stack STE ( SSR ) known to
                                       .  job mode
         lbyts,2 x3,af,x0,snnosmtr*8+2
         shfx    x3,x3,x0,32           .X3:=SVA for NOS segment
         ente    x5,eicbadr            .X5:=offset to EICB
         entp    x6,0                  .NOS/page 0 begins at RMA=0
         addpxq  a9,x0,boot40
         brreq   x0,x0,cseg            .create PTEs to address EICB pointer

boot40   bss     0
         la      ae,a_root,eicb_pva
         lbyts,4 x1,ae,x0,eicbadr+4    .eicb address is in first 28 bits
         shfx    x1,x1,x0,3            .byte offset to eicb
         cpyaa   a_dscb,ae
         addax   a_dscb,x1             .a_dscb:= pva of eicb
         sa      a_dscb,a_root,eicb_pva
         addxq   x5,x1,dscbl           .LBA + 1 of EICB.
.
.        If x3r >= x5r then lba of EICB is addressable. If not create page
.        table entries to address it.
.
         brrge   x3,x5,boot45          .if EICB in same page as pointer
         addpxq  a9,x0,boot45
         brreq   x0,x0,cseg            .Create page table entries for all of EICB
.
. At this point have defined PTEs to reference EICB from the NOS segment.  Now
. create PTEs for remainder of NOS.  When running NOS/VE standalone the EICB
. and DFT buffer are addressed with the NOS segment.
.
.        X3 = SVA+1 of last NOS page defined in page table.
.        X6 = RMA+1 of last NOS page defined in page table.
.
boot45   bss     0
         lx      xa,a_dscb,d7cm+8
         isob    x2,xa,x0,2027(8)      .NOS/VE FWA/1000(8)
         shfx    x5,x2,x0,9+3          .NOS LBA+1
         brrge   x6,x5,boot50          .if all of needed NOS PTEs created
         addpxq  a9,x0,boot50
         brreq   x0,x0,cseg            .create remainder of NOS PTEs.
.
boot50   bss     0
.
.        Fetch and store pointer to the DFT block
.          r_pointer: offset, r_upper, r_lower, size
.          rma of r_pointer = r_upper*10000000(8) + r_lower*1000(8) + offset*10(8)
.
         lbyts,2 x6,a_dscb,x0,dscm+3*8+2  .Load r_upper into x6
         lbyts,2 xb,a_dscb,x0,dscm+3*8+4  .Load r_lower into xb
         shfx    x6,x6,x0,7*3          .Shift: r_upper * 10000000(8)
         shfx    xb,xb,x0,3*3          .Shift: r_lower * 1000(8)
         addx    x6,xb                 .Add r_lower to r_upper
         lbyts,2 xb,a_dscb,x0,dscm+3*8+0  .Load offset into xb
         shfx    xb,xb,x0,1*3          .Shift: offset * 10(8)
         addx    x6,xb                 .Add offset to (r_upper + r_lower)
         entp    xb,sn170mcb
         sa      a_dscb,a_root,mtvdftb  .save base ptr: ring number.
         sbyts,1 xb,a_root,x0,mtvdftb+1  .set cache bypass segment number for
                                       . DFT buffer.
         sbyts,4 x6,a_root,x0,mtvdftb+2  .store dft offset in ptr
.
.        Create PTEs for the 170 xp stack segment and the SSR.  The 170 stack
.        and the SSR are in the same segment.  The 170 stack is from offset
.        0 to 0fff(16), the SSR starts at offset 1000(16).  The last byte
.        address of the SSR is determined from NOS/VE last word address in
.        the EICB.

         lbyts,2 x6,a_dscb,x0,d8sv+8+2 .X6:=R-upper bits
         lbyts,2 xb,a_dscb,x0,d8sv+8+4 .Xb:=R-lower bits
         shfx    x6,x6,x0,6*3
         insb    x6,xb,x0,5613(8)
         shfx    x6,x6,x0,3
         ente    x1,1000(16)           .Size of 170 stack
         subx    x6,x1                 .X6 contains RMA of NOS stack
.
         la      a7,a_root,sadmsdt
         lbyts,2 x3,a7,x0,snsfmtr*8+2
         shfx    x3,x3,x0,32           .x3:=SVA for NOS stack segment
.
         lx      x7,a_dscb,d7cm+8
         isob    x9,x7,x0,5027(8)      .X9:= NVE_CM LWA+1/1000B
         shfx    x5,x9,x0,9+3          .X5:= NVE_CM LBA
         subx    x5,x6                 .x5:= byte count for NOS stack
         addpxq  a9,x0,boot55
         brreq   x0,x0,cseg            .Create 170 stack and SSR page table entries
.
boot55   bss     0

.        Create PTEs for boot's monitor stack segment.

         addpxq  a9,x0,boot60
         brreq   x0,x0,fasid
boot60   bss     0
         sbyts,2 x3,a_root,x0,msfste+2
         shfx    x3,x3,x0,32           .X3:= SVA of mtr stack
         ente    x5,2000(16)           .initial size for stack
         lx      x6,a_root,free_rma
         addpxq  a9,x0,boot65
         brreq   x0,x0,cseg            .Create PTEs for boot's monitor stack
.
boot65   bss     0
.        load mtr a0,a1 with pva to stack segment
.
         la      a_dsp,a_root,mstkpva
         la      a_csf,a_root,mstkpva
.
.        establish pva to the cpu state table, set KBP
.
         ente    x0,63(16)             .initialize KBP register
         isom    x1,x0,2020(8),x0      .NOT CORRECT FOR MULTIPROCESSOR
         cpyxs   x1,x0                 .need to do in every processor
         entl    x0,r_bc
         cpysx   x1,x0                 .get  base constant.
         cpyax   x2,a_root
         addx    x1,x2                 .form pointer to cst
         cpyxa   a_cst,x1
.
.        store pointer to cpu-state-table in mtr stack as per
.        mtm$monitor_interrupt_handler startup code
.
         addaq   a_dsp,a_dsp,mstkfram
         sa      a_cst,a_csf,10        .Save CST_P for p-list.
.
.        save contents of x6, ie: LBA of available free memory
         sx       x6,a_root,free_rma
.
.        Create page table entries for the boot's job mode stack.
.
         addpxq  a9,x0,boot70
         brreq   x0,x0,fasid

boot70   bss     0
         entc    x1,#boff(jsfste+2)
         sbyts,2 x3,a_root,x1,0
         shfx    x3,x3,x0,32           .X3 := SVA of job stack
.
         lx      x6,a_root,free_rma
         ente    x5,1000(16)           .initial size for stack
         addpxq  a9,x0,boot75
         brreq   x0,x0,cseg            .Create PTEs for boot's job mode stack
         page
.....................................................................
.
.     Define tables internal to monitor. Some of the tables are
.     referenced by other modules running in monitor.
.
.....................................................................
.
.        The following is the definition of the communication block to
.        talk to the NOS/VE console (SCI).
.
         align   0,8
asciiblk bss     0                     .ascii console communications block
         vfd,8   0                     .input buffer id
         vfd,8,8,8 0,0,0               .character buffer
         vfd,32  0                     .rma of last output entry processed
         vfd,8   0                     .console driver command
         vfd,8   0                     .hold display flag
         vfd,8   0                     .echo line size
         vfd,8   0                     .undefined
         vfd,32  0                     .rma of output list
.
dpv$scd_block_p address r,asciiblk
.
         align   0,8
dpv$scd_time  vfd,64 0
.
         align   0,8
cst0     bss     0
         defcst  maxcst
cst0l    equ     cst0&0ffff(16)        .lower 16 bits of cst address
cst0u    equ     cst0-cst0l            .upper 16 bits of cst address
.
os_type  vfd,64  0                     .Operating mode
os_terms vfd,8   0                     .170 termination status (0=running,
         vfd,48  0                     .  1=mode error, 2=fatal due)
syskcb_p vfd,48  0ffff80000000(16)     .Pointer to system keypoint control block
act_kpc  vfd,8   0                     .Active keypoint count (software only)
multpro  vfd,8   0                     .TRUE if dualstate.
manddlst vfd,8   1                     .TRUE if dualstate is mandatory at this site.
jkcb_off vfd,32  0                     .Offset in JCB to job KCB pointer
         align   0,8
nosjps   vfd,64  0                     .JPS of NOS170 if Dual State active.
nosexit  vfd,64  0                     .Time of last exit from NOS170.
eicb_pva vfd,4,12,32    1,snnosmtr,0   .Contains PVA of EICB
bct_pva  vfd,4,12,32    1,snnosmtr,bctadr   .Contains PVA of Boot Control Table
nossf    vfd,4,12,32    1,snsfmtr,0    .Contains PVA of NOS stack
nosxp    address r,a170_xp             .Contains PVA of NOS XP
nossegt  address r,a170_st             .Pointer to NOS segment table ..
         vfd,32,32,32  a170_stl*8,0,8  .  ... rest of adaptable pointer to seg table.
.
mlist    vfd,16    00100(16)           .memory_link_status.
         align   0,8
ve_vrsn  vfd,32,14,6,6,6  ost$psr,0,ost$nve,if_versn,if_level  .psr lvl, OS type, i/f version and level
eiflag   vfd,64  0fffffffffffff(16)    .EXTERNAL INTERRUPT flag
eiinc    vfd,64  1000000               .Rate at which external interrupts must
                                       .be checked for.  NOTE: because of the
                                       .algorithm used, asyninc must not be
                                       .larger than this number.
extiou   vfd,64  1                     .IOU sets this word non-zero when
                                       . sending external interrupt.
asyntime vfd,64  0                     .Time to check async activities.
asyninc  vfd,64  200000                .Rate at which asyn activities are chec.
sitvalue vfd,64  50000                 .Default SIT value.
num_proc vfd,64  1                     .number of processors
mstacklx vfd,64  mstackl               .length of monitor stack.
num_cst  vfd,64  maxcst                .Number of cst tables.
lockwait vfd,64  0                     .Total time spent waiting for dual CPU interlock.

.        Define interrupt ports for IOU external interrupts.  This is a mask with bit
.        7 being port 0, bit 6 being port 1, bit 5 being port 2, etc.  Currently all
.        non S0 machines interrupt on port 1 (value of 1) and the S0 interrupts on
.        port 2 (value of 4).  The value of this variable is set early in
.        initialization, it is set to the same value as memport.

intport  vfd,8   1                     .Interrupt port mask for IOU external
                                       . interrupts.
         defg    osv$cpus_physically_configured
osv$cpus_physically_configured vfd,8 0
mtrprior vfd,16  708(16)               .Priority of 180 if control is
                                       . given to 170 via trap in 180 monitor.
multipos vfd,8   0                     .Nonzero if multiprocessing possible without
                                       . a deadstart.
         align   0,16
a170_xp  bssz    xpsize
a170_st  bssz    a170_stl*8
osv_bl   bssz    32                    .osv$build_level
nostime  vfd,64  0                     .Total time spent in NOS.
mmtime   vfd,64  0ffffffffffff(16)     .Time to call Memory Manager.
scbtime  vfd,64  0                     .Time to check SCB status.
alltime  vfd,64  0ffffffffffff(16)     .max time for async lock set
mmretrn  vfd,64  0                     .re_ran nos in monitor mode.
cpu1nos  vfd,8   0                     .CPU 1 dedicated to NOS.
haltring vfd,8   0                     .Halt CP on MCR fault <= this number.
asylock  vfd,8   0                     .asynchronous interrupt lock.
asylocki vfd,8   0                     .asynchronous interrupt lock for STEP.
fltinj   vfd,8   0                     .Enable fault injection utility.
mtvdftb  vfd,48  0ffff80000000(16)     .Pointer to DFT block control_word
nossegp  vfd,4,12,32 1,snnosmtr,0      .Pointer to NOS segment
mtrstp   address r,mst                 .Pointer to MTR SEG TABLE
mtrxpp   address r,mxp                 .pointer to mtr xp
endtbls  vfd,16,32,64 0ffff(16),080000000(16),0 .Pointer to mainframe wired heap.
         align     0,8
debug0   vfd,1024  0                   .Array of debug values
.
.
.         The following is a cybil record.  Immediately after deadstart
.         the NOS system time and date and the free running clock value
.         are saved in this record.  During deadstart initialization these
.         values are converted to NOS/VE base system time.
.
         align   0,8
nos_tod  vfd,64  55333357333357333357(8) .NOS time of day (60 bits of display code)
nos_date vfd,64  55433450334350343657(8) .NOS date (60 bits of display code)
cor_frc  vfd,48  0                     .Free running clock corresponding to 'nos_tod'
nosve_bt bss     0                     .NOS/VE base time
nosve_sc vfd,8   0                     .Second
nosve_mn vfd,8   0                     .Minute
nosve_hr vfd,8   0                     .Hour
nosve_da vfd,8   0                     .Day
nosve_mo vfd,8   0                     .Month
nosve_yr vfd,16  0                     .Year
nosve_cf vfd,48  0                     .Corresponding free running clock
.
.         Define symbols to reference NOS date and time in NOS's field length.
.
nostod   equ     3421(8)               .NOS time of day address mask
nosdate  equ     1221(8)               .NOS date address mask
.
.        End of base system time record.
         align   0,8
tracesiz equ     256                   .Number of trace entries per processor
                                       . (must be power of 2.
                                       . WARNING - TRACE macro must be changed
                                       . if TRACESIZ is changed.
dtrace   bss     0                     .Dummy trace buffer.
trace    bssz    8*maxcst*(2+tracesiz) .Array to keep trace information
                                       .  of what happens in monitor. See
                                       .  the XTRACE macro.
xpinitv  bss     xpsize                .Initial value for all job mode
.                                       exchange packages.
initmxp  bss     xpsize                .initial value of mtr xp.
.
.
.   Error mesasages displayed on error stop.
.
fatalucr  vfd,248   c'FATAL MTR UCR                  '
fatalmcr  vfd,248   c'FATAL MTR MCR                  '
csthalt   vfd,248   c'HALTED VIA CST REQUEST         '
stubcall  vfd,248   c'CALL TO MONITOR STUB           '
          page
.      Set up the NOS XP.
.
.  Initialize the NOS170 Exchange Package
.
.
         ref     mtp$170_trap_handler
a170xpin bss     0
         xpa     a170_xp,2,mtp$170_trap_handler
         xpareg  a170_xp,a_tos,nil
         xpareg  a170_xp,a_csf,nil
         xpareg  a170_xp,a_psa,nil
         xpv     a170_xp,a_bindin*8+10,01000(16)+snsf170,16
         xpareg  a170_xp,a_plist,nil
         xpareg  a170_xp,5,nil
         xpareg  a170_xp,6,nil
         xpareg  a170_xp,7,nil
         xpareg  a170_xp,8,nil
         xpareg  a170_xp,9,nil
         xpareg  a170_xp,10,nil
         xpareg  a170_xp,11,nil
         xpareg  a170_xp,12,nil
         xpareg  a170_xp,13,nil
         xpareg  a170_xp,14,nil
         xpareg  a170_xp,15,nil
         xpv     a170_xp,xpstl,a170_stl,16
         xpv     a170_xp,xpmm,0fbfc(16),16
         xpv     a170_xp,xpum,0ff7f(16),16
         xpv     a170_xp,xpkm,0ffff(16),16
         xpv     a170_xp,xppit,0000f(16),16
         xpv     a170_xp,xppit+8,04240(16),16
         xpv     a170_xp,xplrn,1,16
         xpv     a170_xp,xpflgte,00002(16),16
.
         org     a170_st+snnos170*8
nosste   vfd,64  09a11ffff00000000(16) .STE for NOS
         org     a170_st+snsf170*8
nsfste   vfd,64  0ca13000000000000(16) .STE for NOS stack
. The NOS stack segment will be in the NOS/VE job mode address space
. and known as the SSR segment. The STE is initially defined here
. to be cache bypass, nonexecutable, read and write uncontrolled
. with ring 1 = 1 and ring 2 = 3, the asid will be computed.
         org     a170xpin
.
. Define the SMU Communications Block (SCB)
.
         align   0,8
scb      bss     scbsize               .SCB communication area.
.
mtv$idle_message_line bss 0            .message written to line 1 of console
         vfd,8,8 0,1                   .y position on console
         vfd,8,8 0,0                   .length
         vfd,32  0                     .rma field
         bss     80                    .text of message
         bss     6                     .space for pointer

         page
         align   0,32
jxcb     bssz    xcbsize
.   * * * * * * * * warning - dont change the above constant
.                             unless MTMGR is also changed
jst      bssz    jstlen*8
sdtxtbl  bssz    jstlen*sdtxsize
endjcb   equ     $
         xpa     jxcb,2,osp$start
         xpareg  jxcb,a_tos,nil
         xpareg  jxcb,a_csf,nil
         xpareg  jxcb,a_psa,nil
         xpareg  jxcb,a_bindin,bindsec
         xpareg  jxcb,4,nil
         xpareg  jxcb,5,nil
         xpareg  jxcb,6,nil
         xpareg  jxcb,7,nil
         xpareg  jxcb,8,nil
         xpareg  jxcb,9,nil
         xpareg  jxcb,10,nil
         xpareg  jxcb,11,nil
         xpareg  jxcb,12,nil
         xpareg  jxcb,13,nil
         xpareg  jxcb,14,nil
         xpareg  jxcb,15,nil
         xpv     jxcb,xpstal,jst,16    .Segment table address
         xpv     jxcb,xpstl,jstlen-1,16  .Segment table length
         xpv     jxcb,xpflgte,00000(16),16   .Set trap-enable
         xpv     jxcb,xpmm,j_mtrmsk,16
         xpv     jxcb,xpum,j_usrmsk,16
         xpv     jxcb,xpkm,0,16
         xpv     jxcb,xppit,07fff(16),16
         xpv     jxcb,xppit+8,0ffff(16),16
         xpv     jxcb,xplrn,15,16
         xpv     jxcb,xpbc1,0,16          .task_id DIV 10000(16) for $JOBMNTR
         xpv     jxcb,xpbc2,jxcb_off,16   .task_id MOD 10000(16) for $JOBMNTR
         xpa     jxcb,xptp,pr_trap
         xpa     jxcb,xpdlp,nil
         xpa     jxcb,xptos,nil
         org     endjcb
         page
.   Define static data for pseudo job fixed segment
.
jobfix   equ     $
         entp    x1,0
         align   0,8
         defg osp$start
osp$start bss    0
         ente    x0,00d7(16)
         callseg bs_init,a_bindin,a_plist
.
         align   0,32
         defg    jobroot
         defg    sdtxtbl
         defg    jst
jcb      bss     0
jobroot  bssz    jrootsiz              .Job root
         align   0,8
xcblist  vfd,16,32  0ffff(16),080000000(16)
         bssz    32                 .* * * must be as big as a sig lock.
tasktem  vfd,16,32  0ffff(16),080000000(16)
         bssz    12
         align   0,8
         defg    sysjob,keyinp,keylock
         defg    jfheapp
sysjob   alias   JMV$EXECUTING_WITHIN_SYSTEM_JOB
keyinp   alias   JMV$KEYBOARD_BUFFER
KEYLOCK  ALIAS   JMV$KEYBOARD_BUFFER_LOCK
JFHEAPP  ALIAS   OSV$JOB_FIXED_HEAP
keyinp   bssz    56
keylock  bssz    8
jfheapp  vfd,16,32,80 0ffff(16),080000000(16),0
jobtrapp vfd,16,32 0FFFF(16),080000000(16)
         vfd,16,32 0FFFF(16),080000000(16)
logcntl  vfd,16,32 0FFFF(16),080000000(16)
sfcntl   vfd,16,32 0FFFF(16),080000000(16)
         bssz    12
sysjob   vfd,8   1
.
.
.  Define fields in the Job Root
.
         defg    jcb
jcb      alias   jmv$jcb
sdtxtbl  alias   JMV$SDTX
         defg    jst
jst      alias   jmv$sdt
         defg    jxcb
jxcb     alias   JMV$JMTR_XCB
jxcb_off equ     #BOFF(jxcb)
         defg    xcblist
xcblist  alias   JOB_XCB_LIST
         defg    tasktem
tasktem  alias   PMV$TASK_TEMPLATE
         defg    jobtrapp
jobtrapp ALIAS   JMV$JOB_TRAP_HANDLER
         defg    logcntl
logcntl  alias   LGV$LOCAL_LOG_CNTL_P
         defg    sfcntl
sfcntl   alias   SFV$LOCAL_ROUTING_CONTROL_TABLE
         ref     jbegin
jbegin   alias   osp$initialize
         page
. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
. TRAKTEF - This macro enables/disables the MCR mask bit 49
.           (normally unused) to indicate to THETA models 40 - 44
.           what the current state of the trap register is.  This
.           is used as a software workaround for 'stop on error'
.           hardware found only on the THETA processor models
.           listed above.  On other models this information is
.           not used, even though the flag is tracked.
. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
         proc
traktef  pname
f:(0)    bss     0
         local   tf1,tf2
         ente    x3,f:(2,0)            .Enable or Disable?
         ente    x2,m_mcrtef
         entl    x0,r_mm               .Get live register for mtr mask
         cpysx   x1,x0
         brxeq   x3,x0,tf1             .Branch to clear Trap enable flag
         iorx    x1,x2                 .Set the Traps_Enabled bit in the live
         brxeq   x0,x0,tf2             .  mtr mask
tf1      inhx    x1,x2                 .Clear the Traps_Enabled bit in the live
tf2      cpyxs   x1,x0                 .  mtr mask
         bss     0
         pend
.............................................................................
.
.      Set up the request table for the various requests.
.
.
.  RQTABLE -  This macro generates monitor request table entries,
.             and binding section pointers. it also increments *MTRQMAX*
.             to indicate the maximum number of requests.
.
.                RQTABLE  REC_CODE,HRN,INT_ORD,NAME
.                  req_code = request code.
.                  hrn      = highest ring number for call.
.                  int_ord  = interlock ordinal.
.                  name     = procedure name to process request.
.
         proc
rqtable  pname
         vfd,8   f:(2,1)               .Highest ring number for the call
         vfd,8   f:(2,2)               .Interlock ordinal
         vfd,8   f:(2,0)               .Request code
         vfd,40  0
         vfd,64  0
         vfd,32  0
         vfd,32  0
         vfd,32  0
         vfd,32  0
         vfd,64  0
mtrqmax  set     mtrqmax+1
         do      f:(2,2)>maxilo
maxilo   set     f:(2,2)
         dend
         use     binding
         do      sc:(f:(2,3))/=7
         ref     f:(2,3)
         dend
         address ce,f:(2,3)
         use     #lastsec
         pend
.
.   initialize maximum requests to -1.
.
mtrqmax  set     -1
maxilo   set     0
         page
.....................................................................
.
.   Define Binding Section
.
.   define fwa of binding section and reqtable pointers.
....................................................................
         use     binding
         def     bindsec
bindsec  bss     0
bs_rqtbl bss     0
         use     #lastsec
         page
...............................................................................
. NOTE: If the highest interlock ordinal value is changed
. (parameter 3 in the macro calls below), be sure to change the
. constant value MTC$MAXIMUM_IL_TABLE_INDEX in the deck
. MTT$REQUEST_INTERLOCK_TABLE to match it.
...............................................................................
         align   0,8
reqtbl   bss     0
         rqtable 0,15,1,tmp$process_unknown_req_fault
         rqtable 1,13,0,tmp$cycle
         rqtable 2,13,0,tmp$delay
         rqtable 3,3,1,tmp$process_unknown_req_fault
         rqtable 4,1,1,iop$io_processor
         rqtable 5,13,1,tmp$process_unknown_req_fault
         rqtable 6,13,1,tmp$process_unknown_req_fault
         rqtable 7,13,1,tmp$process_unknown_req_fault
         rqtable 8,2,1,tmp$process_unknown_req_fault
         rqtable 9,0,1,pr_pf
         rqtable 10,2,1,tmp$process_unknown_req_fault
         rqtable 11,2,1,osp$boot_update_page_table
         rqtable 12,13,1,tmp$process_unknown_req_fault
         rqtable 13,13,1,tmp$process_unknown_req_fault
         rqtable 14,1,1,tmp$process_unknown_req_fault
         rqtable 15,2,1,tmp$process_unknown_req_fault
         rqtable 16,1,1,tmp$process_unknown_req_fault
         rqtable 17,3,1,tmp$process_unknown_req_fault
         rqtable 18,3,1,tmp$process_unknown_req_fault
         rqtable 19,3,0,mtp$mtr_step_unstep_system
         rqtable 20,0,1,tmp$process_task_mcr_fault
         rqtable 21,15,1,tmp$mtr_process_system_error
         rqtable 22,3,0,tmp$process_unknown_req_fault
         rqtable 23,3,1,tmp$process_unknown_req_fault
         rqtable 24,3,1,tmp$process_unknown_req_fault
         rqtable 25,13,0,tmp$process_unknown_req_fault
         rqtable 26,3,0,tmp$process_unknown_req_fault
         rqtable 27,15,0,tmp$process_unknown_req_fault
         rqtable 28,2,1,tmp$process_unknown_req_fault
         rqtable 29,3,1,tmp$process_unknown_req_fault
         rqtable 30,13,1,tmp$process_unknown_req_fault
         rqtable 31,6,1,tmp$process_unknown_req_fault
         rqtable 32,3,1,tmp$process_unknown_req_fault
         rqtable 33,1,1,tmp$process_unknown_req_fault
         rqtable 34,2,1,tmp$process_unknown_req_fault
         rqtable 35,3,0,tmp$process_unknown_req_fault
         rqtable 36,3,0,tmp$process_unknown_req_fault
         rqtable 37,11,1,tmp$process_unknown_req_fault
         rqtable 38,13,1,tmp$process_unknown_req_fault
         rqtable 39,13,1,tmp$process_unknown_req_fault
         rqtable 40,13,1,tmp$process_unknown_req_fault
         rqtable 41,1,1,tmp$process_unknown_req_fault
         rqtable 42,1,1,tmp$process_unknown_req_fault
         rqtable 43,1,1,tmp$process_unknown_req_fault
         rqtable 44,1,1,iop$tape_queue_request
         rqtable 45,1,1,tmp$process_unknown_req_fault
         rqtable 46,3,1,cmp$monitor_routines
         rqtable 47,3,1,tmp$process_unknown_req_fault
         rqtable 48,13,1,tmp$process_unknown_req_fault
         rqtable 49,3,1,dsp$issue_dft_request
         rqtable 50,13,1,tmp$process_unknown_req_fault
         rqtable 51,0,0,tmp$switch_task
         rqtable 52,0,0,mtp$process_short_warning
         rqtable 53,0,0,mtp$monitor_system_status
         rqtable 54,0,1,iop$process_io_completions
         rqtable 55,3,0,dpp$display_request
         rqtable 56,0,0,dpp$process_scd_block
         rqtable 57,3,1,tmp$process_unknown_req_fault
         rqtable 58,0,1,tmp$process_unknown_req_fault
         rqtable 59,0,0,mtp$process_due
         rqtable 60,0,0,mtp$initiate_system_idle
         rqtable 61,15,1,tmp$process_unknown_req_fault
         rqtable 62,0,0,mtp$process_170_mtr_requests
         rqtable 63,0,0,mtp$error_stop
         rqtable 64,1,1,tmp$process_unknown_req_fault
         rqtable 65,3,0,dsp$access_logging_data
         rqtable 66,0,0,dsp$process_dft_entry
         rqtable 67,15,1,tmp$process_unknown_req_fault
         rqtable 68,15,1,tmp$process_unknown_req_fault
         rqtable 69,15,1,tmp$process_unknown_req_fault
         rqtable 70,15,1,tmp$process_unknown_req_fault
         rqtable 71,15,1,tmp$process_unknown_req_fault
         rqtable 72,15,1,tmp$process_unknown_req_fault
         rqtable 73,15,1,tmp$process_unknown_req_fault
         rqtable 74,15,1,tmp$process_unknown_req_fault
         rqtable 75,15,1,tmp$process_unknown_req_fault
         rqtable 76,15,1,tmp$process_unknown_req_fault
         rqtable 77,15,1,tmp$process_unknown_req_fault
         rqtable 78,15,1,tmp$process_unknown_req_fault
         rqtable 79,15,1,tmp$process_unknown_req_fault
         rqtable 80,3,1,dsp$mtr_manage_system_ds_status
         page
         use     binding
bs_pgflt address ce,osp$process_mtr_page_fault
.
pr_errst ALIAS   MTP$ERROR_STOP
pr_dft   ALIAS   DSP$PROCESS_DFT_ENTRY
         ref     pr_dft
         ref     ptllock
         ref     pr_errst
         def     bs_trap
.
bs_trap  address ce,traprtn
bs_errst address c,pr_errst
bs_root  address p,root
bs_ptlok address p,ptllock
.
.................................................................
.   Define Binding Section for job mode boot XP
.
         def     pr_trap
         ref     jpstraprtn
pr_trap  address ce,jpstraprtn
bs_init  address ce,jbegin
.
jpstraprtn ALIAS SYP$SYSTEM_CORE_TRAP_HANDLER
         use     #lastsec
         page
.
.      Define the interlock words.  Initially only one lock word
.      is used by the various request processors.
.
.
         align   0,8
il_tbl   bssz    maxilo*3*8            .Interlock word
         page
         defg    haltring
         defg    scbtime,mmtime,nostime
         defg    alltime,cpu1nos
         defg    sitvalue,fltinj
         defg    dpv$scd_block_p,mtv$idle_message_line
         defg    dpv$scd_time
         defg    extiou
         defg    mtrprior
         defg    endtbls,memlimit,cst0
         defg    xpinitv,os_type,scb,os_terms
         defg    trace,nosjps,nosxp,eicb_pva,bct_pva,nossegp,dtrace
         defg    syskcb_p,act_kpc,jkcb_off
         defg    nosve_bt,nos_tod,mlist
         defg    reqtbl
         def     il_tbl
         defg    multpro
         defg    manddlst
         defg    eiflag
         defg    lockwait
         defg    debug0
         defg    intport
         defg    asyntime,asyntime
         defg    num_proc
         defg    initmxp
         defg    osv_bl
         def     int
         def     nossegt
initmxp  ALIAS   OSV$INITIAL_MONITOR_XP
fltinj   ALIAS   syv$enable_fault_injection
         defg    num_cst,multipos
         defg    mstacklx
         defg    mtvdftb
mstacklx ALIAS   osv$monitor_stack_length
num_cst  ALIAS   osv$maximum_cst_tables
num_proc ALIAS   osv$number_of_processors
multipos ALIAS   osv$multiple_processors
lockwait ALIAS   osv$monitor_interlock_wait_time
ptllock  ALIAS   TMV$PTL_LOCK
eiflag   ALIAS   osv$external_interrupt_time
intport  ALIAS   osv$external_interrupt_selector
asyntime ALIAS   OSV$TIME_TO_CHECK_ASYN
asyninc  ALIAS   OSV$RATE_TO_CHECK_ASYN
multpro  ALIAS   OSV$MULTI_PROCESSOR
manddlst ALIAS   syv$mandatory_dualstate
debug0   ALIAS   osv$debug
mtrprior ALIAS   OSV$MONITOR_PRIORITY
reqtbl   ALIAS   MTV$REQUEST_TABLE
il_tbl   ALIAS   mtv$request_interlock_table
nosjps   ALIAS   MTV$NOS_JPS
sitvalue ALIAS   OSV$DEFAULT_SIT_VALUE
os_type  ALIAS   OSV$170_OS_TYPE
os_terms ALIAS   OSV$170_OS_TERMINATION_STATUS
nossegp  ALIAS   MTV$NOS_SEG_P
nostime  ALIAS   MTV$TOTAL_NOS_CPU_TIME
haltring ALIAS   MTV$HALT_CPU_RING_NUMBER
extiou   ALIAS   OSV$IOU_EXTERNAL_INTERRUPT
mtvdftb  ALIAS   mtv$dft_block_p
scb      ALIAS   MTV$SCB
nosxp    ALIAS   MTV$NS_XP_P
eicb_pva ALIAS   MTV$NST_P
bct_pva  ALIAS   DSV$BOOT_CONTROL_TABLE_P
nossegt  ALIAS   MTV$NOS_SEGMENT_TABLE_P
dtrace   ALIAS   MTV$DUMMY_TRACE_BUFFER
trace    ALIAS   MTV$TRACE_BUFFER
osv_bl   ALIAS   osv$build_level
ENDTBLS  ALIAS   OSV$MAINFRAME_WIRED_HEAP
memlimit ALIAS   OSV$180_MEMORY_LIMITS
MMTIME   ALIAS   MMV$TIME_TO_CALL_MEM_MGR
scbtime  ALIAS   MTV$TIME_TO_CHECK_SCB_STATUS
alltime  ALIAS   MTV$MAX_ASYNC_LOCK_TIME
cpu1nos  ALIAS   MTV$CPU1_DEDICATED_TO_NOS
CST0     ALIAS   MTV$CST0
XPINITV  ALIAS   MTV$XP_INITIAL_VALUE
syskcb_p ALIAS   SYV$SYSTEM_KCB_P
act_kpc  ALIAS   SYV$ACTIVE_KEYPOINT_COUNT
jkcb_off ALIAS   SYV$JOB_KCB_P_OFFSET
ROOT     ALIAS   MTV$ROOT
BEGIN    ALIAS   MTP$BEGIN
TRAPRTN  ALIAS   MTP$TRAP_HANDLER
BINDSEC  ALIAS   MTV$BINDING_SECTION
BS_TRAP  ALIAS   MTV$TRAP_CBP
NOSVE_BT ALIAS   OSV$BASE_SYSTEM_TIME
NOS_TOD  ALIAS   SYV$NOS_SYSTEM_TIME
MLIST    ALIAS   MTV$MLI_STATUS
         page

         align   0,2
boot75   bss     0
         sx      x6,a_root,free_rma
         la      af,a_root,jstkpva
         la      ae,a_root,sadxcbp
         sa      af,ae,8+2             .store proper PVA into initial job mode XP.dsp
         sa      af,ae,8+8+2           .store proper PVA into initial job mode XP.csf
         sa      af,ae,xptos           .store proper PVA into initial job mode XP.tosr1
.
         la      ae,a_root,sadjcbp     .init jcb pointer
         sa      ae,a_cst,jcbp
         la      a_xcb,a_root,sadxcbp  .init xcb pointer
         sa      a_xcb,a_cst,xcbp
         la      af,a_root,sadjsdt     .init job mode sta
         tpage   x1,af
         sbyts,2 x1,a_xcb,x0,xpstal    .lower 16
         shfx    x1,x1,x0,-16
         sbyts,2 x1,a_xcb,x0,xpstau    .upper 16 bits
         la      ae,a_root,sadmsdt     .copy mtr sdt to job mode
         movb,ae,x0 af,x1 0,9,8*15(16),0 0,9,8*15(16),0
         tpage   x1,a_xcb              .Save RMA of XCB in CST.
         sx      x1,a_cst,xcbrma
         entl    x0,r_jps              .Update JPS.
         cpyxs   x1,x0
.
         entl    x0,r_eid              .Get element ID
         cpysx   x1,x0
         sx      x1,a_cst,elem_id      .Save EID in CST.
.
.        IF THIS IS CYBER 2000,
.        Clear the monitor mode monitor mask bit 48 of the job mode monitor
.        mask bit 48 of the job exchange package.
.
         isob    x1,x1,x0,(40*64+7)    .High order 7 bits of model number from
                                       . element id.
         ente    x2,46(16)             .CYBER 2000 Model 46
         brreq   x1,x2,begin2_1
         incx    x2,2                  .CYBER 2000 Model 48
         brreq   x1,x2,begin2_1
         brxeq   x0,x0,begin2_2
begin2_1 lbyts,2 x1,a_xcb,x0,xpmm
         ente    x2,m_mcrdue           .Remove DUE bit (48) from MM
         inhx    x1,x2
         sbyts,2 x1,a_xcb,x0,xpmm
         entl    x0,r_mm
         cpyxs   x1,x0                 .Replace MM in register
         la      ac,a_root,mtrxpp
         lbyts,2 x1,ac,x0,xpmm
         sbyts,2 x1,ac,x0,xpmm         . and monitor XP
begin2_2 entp    x0,0                  .start cache and map purging
         sx      x0,a_cst,cachtim
         sx      x0,a_cst,maptim
         tpage   x1,a7                 .Store MPS into CST.
         sbyts,4 x1,a_cst,x0,mps
         la      ad,a_root,eicb_pva      .FWA of NOS field length.
         cpytx   x1,x0                 .Reset time task began execution.
         entl    x0,r_eid
         sx      x1,a_root,nosexit     .Set time when last exited NOS
         cpysx   xe,x0                 .element id.
         entp    x6,5                  .high order 4 bits of S0 model number.
         isob    xe,xe,x0,(40*64+3)    .high order 4 bits of model number from
                                       . element id.
         sx      x1,a_root,scb+scbnsrv

.        Set up memory and interrupt port mask based on processor.

         lbyts,1 x1,a_cst,x0,memport   .memory and interrupt port mask for non S0
         brrne   xe,x6,begin2_5        .if not an S0.
         incr    x1,3                  .If S0, change port 0 (int sel = 1) to a 4,
         entp    x2,4                  .  port 1 (int sel = 4) to an 8.
         brxeq   x1,x2,begin2_5        .If cpu 0, then 4 is the right answer,
         entp    x1,8                  .  otherwise 8 is the answer.
begin2_5 bss     0
         sbyts,1 x1,a_cst,x0,memport   .Set up port number mask for ext interrupts.
         sbyts,1 x1,a_root,x0,intport
         lx      xe,a_root,ve_vrsn     .ve os type, dscb version/level
         sx      xe,a_dscb,d8ty        .save in block

.        Set the NOS/VE memory limits.  Both upper bounds are set to the RMA of
.        the SSR.

         lx      x1,a_dscb,d7cm+8      .fetch memory limits
         isob    xe,x1,x0,(64-48)*100(8)+24-1  .NOS/VE fwa DIV 10000(8)
         shfx    xe,xe,x0,12
         sbyts,4 xe,a_root,x0,memlimit .set memory lower bound
         la      ae,a_root,nossf
         tpage   xe,ae
         sbyts,4 xe,a_root,x0,memlimit+4  .set deadstart upper bound to the SSR RMA
         sbyts,4 xe,a_root,x0,memlimit+8  .set upper bound to the SSR RMA
.
         lx      xe,a_dscb,d7ty        .determine STATE
         isob    x1,xe,x0,5605(8)
         sbyts,1 x1,a_root,x0,os_type
         brreq   x1,x0,begin3          .if not dualstate jump
.
.         Save NOS base system time and the corresponding value of the free running clock.
.
         isob    x2,xe,x0,nostod       .isolate time of day pointer
         isob    xe,xe,x0,nosdate      .isolate date pointer
         lxi     x2,ad,x2,0            .time of day (display code)
         lxi     xe,ad,xe,0            .date (display code)
         cpytx   x1,x0                 .Free running clock
         sx      x2,a_root,nos_tod
         sx      xe,a_root,nos_date
         ente    x2,cor_frc
         sbyts,6 x1,a_root,x2,0
         addaq   af,a_root,a170_xp
         entp    x2,0                  .Clear left halt of nosjps
         tpage   x2,af
         sx      x2,a_root,nosjps
         sbyts,4 x2,a_cst,x0,dualstat
         addaq   ae,a_root,a170_st     .Store upper bits of nos seg table adr.
         tpage   x2,ae
         sbyts,2 x2,af,x0,xpstal
         shfx    x2,x2,x0,-16
         sbyts,2 x2,af,x0,xpstau
         la      af,a_root,mtrstp      .Set entry for MNFR WIRED SEG in NOS ST
         cpyax   x1,a_root             .a_root is mnfr wired segment
         isob    x1,x1,x0,2413(8)      .isolate segment number
         shfx    x1,x1,x0,3            .make sdt number
         lbyts,8 x2,af,x1,0            .get sdt entry
         sbyts,8 x2,ae,x1,0            .set sdt entry in nos st
         brcr    5,1,begin4            .Force EXCH bit
         brreq   x0,x0,begin4
.
begin3   isom    x1,x0,2020(8),x0      .Set NOS XP pointer to NIL
         sbyts,6 x1,a_root,x0,nosxp
.
.        Clear the monitor mode monitor mask bit 49 of the monitor
.        exchange package and bit 49 in the monitor mask register.
.
begin4   traktef 0                     .NO-OP; trap bit already disabled
         cpyxx   x6,x2                 .  X2 = m_mcrtef
                                       .  Use reg to clear mtr mask
         addaq   af,a_root,xpinitv     .Save the job exchange package
         movb,a_xcb,x0 af,x1 0,9,255,0 0,9,255,0
         movb,a_xcb,x0 af,x1 0,9,xpsize-255,255 0,9,xpsize-255,255
         la      ae,a_root,mtrxpp      .move original xp to
         addaq   af,a_root,initmxp     .mainframe wired.
         lbyts,2 x1,ae,x0,xpmm         .Get the mtr mask in the mtr xp
         inhx    x1,x6                 .Inhibit tef bit
         sbyts,2 x1,ae,x0,xpmm         .Store mtr mask in the mtr xp
         movb,ae,x0 af,x1 0,9,255,0 0,9,255,0
         movb,ae,x0 af,x1 0,9,xpsize-255,255 0,9,xpsize-255,255
         entl    x0,r_jps              .Save current JPS in CST.
         cpysx   x0,x0
         sx      x0,a_cst,xcbrma
         brxeq   x0,x0,begin22
.
.    The following code is initialization code for all cpus EXCEPT the first.
.
begin5   bss     0
         la      a_dscb,a_root,eicb_pva  .Pointer to interface block
         isom    x1,x0,2020(8),x0
         sbyts,6 x1,a_cst,x0,xcbp      .nill xcb pointer.
         entp    x1,1
         sbyts,1  x1,a_cst,x0,caldisp  .call dispatcher.
.
.    Complete processor initialization for ALL processors.
.
begin22  lx      x1,a_root,sitvalue    .Reset SIT.
         entl    x0,r_sit
         cpyxs   x1,x0
         entp    x0,0
         sbyts,1 x0,a_cst,x0,cpu_stat  .set cpu status running
         entl    x0,r_te               .Enable traps
         cpyxs   x0,x0
         page
.
.   Dispatch next task
.
intdislp bss     0                     .Begin of interrupt-dispatch-loop.
         entl    x0,r_pit              .Save monitor clock.
         cpysx   x_clock,x0
.
.  Process asynchronous interrupts (EXT INT, Console input, Memory mgr)
.
async    entl    x0,0                  .Check if time to check async
         cpytx   x2,x0                 .  activities.
         sbyts,1 x0,a_cst,x0,asyncp
         sx      x2,a_cst,cpwell       .Update cpu alive flag.
         sx      x2,a_root,scb+scbnsrv .Update '180 alive' flag.
         lx      x1,a_root,asyntime
         brxge   x1,x2,asynce          .Jump if not time.
         addaq   ae,a_root,asylock
         lbset   x1,ae,x0              .test and set lock
         brrgt   x1,x0,asynce          .jump if another processor here
 .
         lx      x1,a_root,asyninc     .Update time to next check async.
         addx    x1,x2
         sx      x1,a_root,asyntime
         lx      x1,a_root,eiflag
         brxgt   x1,x2,async6          .jump if not time
         lx      x1,a_root,eiinc
         addx    x1,x2
         sx      x1,a_root,eiflag
         entl    x0,0
         sx      x0,a_root,extiou
         cpyaa   a_parm,a0
         addpxq  a_rq_ret,x0,async6    .set return address.
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*proc_io
         addaq   ae,a_bindin,16*proc_io
         brreq   x0,x0,rqproc
async6   lx      x1,a_root,dpv$scd_time
         brxgt   x1,x2,async8          .jump if not time
         addpxq  a_rq_ret,x0,async12   .set return address.
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*ascii_kb
         addaq   ae,a_bindin,16*ascii_kb
         brreq   x0,x0,rqproc
.
async8   la      ae,a_root,mtvdftb     .Fetch pointer to DFT block.
         lx      x1,ae,dftcw           .Get DFT control word.
         shfx    x1,x1,x0,62           .Check E8 field.
         brxge   x1,x0,async12         .jump if not set.
         addpxq  a_rq_ret,x0,async12   .set return address.
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*proc_dft
         addaq   ae,a_bindin,16*proc_dft
         brreq   x0,x0,rqproc
.
async12  lx      x1,a_root,scbtime     .Check if time to look at SCB status.
         entp    x2,0
         cpytx   x2,x2
         brxge   x1,x2,async15         .Jump if SCB check not required.
         cpyaa   a_parm,a_csf          .Save parameter list
         addpxq  a_rq_ret,x0,async14   .set return address.
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*mon_smu
         addaq   ae,a_bindin,16*mon_smu
         brreq   x0,x0,rqproc
         cpyaa   a_parm,a0             .Restore previous parameter list
async14  entp    x2,0
         cpytx   x2,x2
async15  lx      x1,a_root,mmtime      .Check if time to call Mem Mgr.
         brxge   x1,x2,async50         .Jump if Mem Mgr call not needed.
         addpxq  a_rq_ret,x0,async50   .set return address.
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*per_call
         addaq   ae,a_bindin,16*per_call
         brreq   x0,x0,rqproc
async50  addaq   ae,a_root,asylock
         entl    x0,0
         sbyts,1 x0,ae,x0,0            .clear lock
         brreq   x0,x0,async           .check for more before exiting
asynce   lx      x1,a_cst,discntl      .get dispatch control flags.
.
.  Call the task switch routine if necessary.
.
         shfx    x1,x1,x0,-32          .Check dispatch flag.
         brxeq   x1,x0,tsckpr          .Jump if task switch not needed.
         lx      x1,a_cst,discntl      .Make sure async flags are not set.
         brrne   x1,x0,tsckpr
         la      a_xcb,a_cst,xcbp
         cpyax   x1,a_xcb               .Check for NIL xcb
         entl    x0,0
         brrgt   x0,x1,tswit4
         lbyts,2 x1,a_xcb,x0,xppit     .Calculate JOB MODE time
         lbyts,2 x2,a_xcb,x0,xppit+8
         insb    x2,x1,x0,4017(8)
         ents    x2                    .sign extend
         lx      x1,a_cst,jtime
         subx    x1,x2
         sx      x1,a_cst,jtime
         isom    x1,x0,4037(8)         .Save monitor mode time in CST.
         subx    x1,x_clock
         sx      x1,a_cst,mtime
tswit4   addpxq  a_rq_ret,x0,tswit5    .set return address.
         cpyaa   a_parm,a_csf
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*tsksw
         addaq   ae,a_bindin,16*tsksw
         brreq   x0,x0,rqproc
tswit5   isom    x_clock,x0,4037(8)    .Reset monitor clock.
         entl    x0,r_sit              .Reset SIT.
         lx      x1,a_cst,cptime
         cpyxs   x1,x0
         entl    x0,0                  .Reset CST fields -
         sbyts,4 x0,a_cst,x0,discntl   .Clear task switch control flags.
         sx      x0,a_cst,mtime        .  monitor mode time
         la      a_xcb,a_cst,xcbp      .Reload pointer to current XCB.
         cpyax   x1,a_xcb              .Skip next part if XCB is NIL.
         brrgt   x0,x1,tswit8
         lbyts,2 x1,a_xcb,x0,xppit     .Reset JOB MODE time
         lbyts,2 x2,a_xcb,x0,xppit+8
         insb    x2,x1,x0,4017(8)
         ents    x2                    .sign extend
         sx      x2,a_cst,jtime
         tpage   x1,a_xcb              .Save RMA of XCB in CST.
         sx      x1,a_cst,xcbrma
         entl    x0,r_jps                 .Update JPS.
         cpyxs   x1,x0
tswit8   xtrace  5,x1,xe,xd,ae
.
.  Run NOS 170 if it has a priority greater than 180 has.
.
tsckpr   lbyts,2 xe,a_cst,x0,dsprior   .Update 180 priority in DSCB.
         lx      x1,a_cst,discntl      .Get dispatch flags.
         brxne   x1,x0,async           .Cycle loop if flags are set.
         lbyts,1 x1,a_cst,x0,lpid8     .get cpu index
         lbyts,2 x1,a_dscb,x1,np170pr  .Get 170 priority.
         shfc    x2,xe,x0,-4           .Shift off sub priority.
         shfc    x1,x1,x0,-4
         brrgt   x2,x1,async90         .Run 180 if 180pr>170pr.
         brrne   x2,x1,tsckpr3         .Run 170 if 170pr > 180 pr.
         brreq   x2,x0,idle            .Go to idle routine if 180pr = 0.
         isob    x2,x2,x0,0003(8)      .Isolate 180 subpriority.
         entl    x0,0                  .Read the free running clock to calculate
         cpytx   x0,x0                 .  the 170 subpriority.
         isob    x1,x0,x0,5603(8)
         brxgt   x2,x1,async90         .Jump if 180 has highest priority.
tsckpr3  addpxq  a_inret,x0,tsckpr5    .Set up return address and
         brxeq   x0,x0,run_nos         .  run NOS 170.
tsckpr5  entl    x0,r_te               .Enable traps.
         cpyxs   x0,x0
         lbyts,1 x2,a_cst,x0,dsprior   .Run user task if system not idle.
         brxne   x2,x0,async90
         lx      x1,a_cst,discntl       .Cycle the loop if task switch/async.
         brxne   x1,x0,async
.
.  Idle if no 180 task was found ready.
.
idle     entl    x0,r_td               .Disable traps
         cpyxs   x0,x0
         entp    xe,0                  .Set 180 priority
         addpxq  a_inret,x0,idle3      .Idle in NOS 170 if present.
         brxeq   x0,x0,run_nos
idle3    lbyts,1 x1,a_cst,x0,nextstat
         brxne   x1,x0,idle4           .branch to main idle loop
         sbyts,1 x1,a_cst,x0,cpu_stat  .store haltreq into cpu_stat
idle4    addpxq  a_extret,x0,idle3
         brcr    8,0,extrq             .branch if EXT INT is set
         lbyts,1 x1,a_cst,x0,cpu_stat
         brxne   x1,x0,idle3           .loop if haltreq set
         lx      x1,a_cst,discntl      .exit when flags are set
         brxne   x1,x0,idle10
         addpxq  a_sitret,x0,idle3
         brcr    11,0,prsit            .jump if SIT is set
         entp    x1,1
         sbyts,1 x1,a_cst,x0,caldisp
.
idle10   lx      x1,a_root,sitvalue    .Put big number in SIT to reduce
         entl    x0,r_sit              . likelyhood of unnecessary SIT.
         cpyxs   x1,x0
         entl    x0,r_te               .exit idle routine
         cpyxs   x0,x0
         brxeq   x0,x0,async
.
.  Reload PIT for current 180 task.
.
async90  entl    x0,r_pit              .Reload monitor clock (PIT).
         cpyxs   x_clock,x0
.
.   End of task switch loop.
         page
...............   beginning of critical region ............
.
.               CRITICAL REGION - between labels BCRIT1 and ECRIT1
.
.   If any changes are made in thie following code,
.   be sure to look at the code at the begining of the trap handler.
.   Under certain circumstances, P will be reset to the beginning
.   of the critical region.
.
.
BCRIT1   bss     0
exchloop bss     0
         lx      x1,a_cst,discntl      .Check for task switch or async
         brxne   x1,x0,intdislp        . activity. Branch if found.
         xtrace  0,0,x1,x0,ae
         entp    x0,0
         sbyts,2 x0,a_xcb,x0,xpmcr     .Clear user's MCR
         lbyts,2 x1,a_cst,x0,taskid
         shfx    x1,x1,x0,13
         keypoint oscmtr,x1,oskexc8x
ecrit1   exchange
...............   end of critical region ............
.
.
.   Get the MCR from the user XP.
.
         lbyts,2 x_mcr,a_xcb,x0,xpmcr  .Get MCR from user XP
         xtrace  1,x_mcr,x1,x0,ae      .Save MCR in trace buffer.
         shfx    x1,x_mcr,x0,13        .Keypoint MCR.
         keypoint oscmtr,x1,oskexc8
         histo   x_mcr,a_root,tabmcrj,xe,xf
.
.
.  Special case an MCR of EXCH ONLY. This is the most frequent interrupt.
.  In EXCH is set and other bits are set as well, the EXCH will be handled
.  later.
.
         ente    x1,m_mcrexc           .Check for only EXCH set.
         brxne   x1,x_mcr,ckhdw        .Jump if not EXCH only.
         entl    x0,r_pit              .Stop the clock.
         cpysx   x_clock,x0
         ente    xe,#boff(a170_xp)
         sbyts,2 x1,a_root,xe,xpmcr
         addpxq  a_inret,x0,ckexsp5    .Set up return address.
         lbyts,2 xe,a_cst,x0,dsprior   .Get current 180 priority.
         brxeq   x0,x0,run_nos         .Go run NOS 170.
ckexsp5  entl    x0,r_pit              .Start monitor clock.
         cpyxs   x_clock,x0
         entl    x0,r_te               .Enable traps.
         cpyxs   x0,x0
         brxeq   x0,x0,exchloop
.
.
.   Process hardware errors - (DUE, SHORT WARNING).
.
ckhdw    ente    x1,m_mcrhdw           .Check for hardware errors
         andx    x1,x_mcr
         brreq   x1,x0,ckasync
         shfc    x1,x_mcr,x0,18        .Check for short warning.
         brrge   x1,x0,ckdue           .Jump if no short warning.
         cpyaa   a_parm,a0
         addpxq  a_rq_ret,x0,ckdue     .set return address.
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*pswarn
         addaq   ae,a_bindin,16*pswarn
         brreq   x0,x0,rqproc
ckdue    shfc    x1,x_mcr,x0,16        .Check for DUE.
         brrge   x1,x0,ckasync
         purge   x0,2                  .Purge cache and map.
         purge   x0,15
         entp    x1,0                  .Set up plist
         sx      x1,a_csf,0
         sa      a_xcb,a_csf,18
         cpyaa   a_parm,a_csf
         addpxq  a_rq_ret,x0,ckdue1    .set return address.
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*proc_due
         addaq   ae,a_bindin,16*proc_due
         brreq   x0,x0,rqproc
ckdue1   ente    x_mcr,m_mcrasy        .Force async interrupts since these
.                                       may be invalid because of DUE.
.
.   Process asynchronous interrupts.
.
ckasync  ente    x1,m_mcrasy           .Check for asynchronous interrupt
         andx    x1,x_mcr
         brreq   x1,x0,ckuser          .Jump if no asynchronous interrupt
         entl    x0,r_pit              .Stop the monitor clock.
         cpysx   x_clock,x0
         shfc    x1,x_mcr,x0,27        .Check for SIT.
         brrge   x1,x0,ckextint        .Jump if no SIT.
         addpxq  a_sitret,x0,ckextint  .Set up return address.
         brxeq   x0,x0,prsit           .Go process SIT interrupt.
ckextint shfx    x1,x_mcr,x0,24        .Check for EXT INT
         addpxq  a_extret,x0,ckexch
         brrgt   x0,x1,extrq           .Jump if  EXT INT.
ckexch   ente    x1,m_mcrexs           .Clear SIT and EXTINT.
         andx    x1,x_mcr
         sbyts,2 x_mcr,a_xcb,x0,xpmcr  .Clear MCR - see trap handler.
         shfx    x1,x_mcr,x0,21        .Check for EXCH
         brrge   x1,x0,ckasyncx        .Jump if no EXCH
         ente    x1,m_mcrexc           .Set EXCH bit in NOS XP
         ente    xe,#boff(a170_xp)
         sbyts,2 x1,a_root,xe,xpmcr
         addpxq  a_inret,x0,ckexch5
         lbyts,2 xe,a_cst,x0,dsprior   .Get current 180 priority.
         brxeq   x0,x0,run_nos         .Run NOS
ckexch5  entl    x0,r_te               .Enable traps
         cpyxs   x0,x0
ckasyncx entl    x0,r_pit              .Start monitor clock.
         cpyxs   x_clock,x0
         brxeq   x_mcr,x0,exchloop
.
.   Process faults normally handled in job mode via trap handler.
.
ckuser   ente    x1,j_mcrusr           .Check for condition that will
         cpyaa   a_parm,a_csf
         addpxq  a_rq_ret,x0,exchloop
         andx    x1,x_mcr              .be processed in job mode          .
         brreq   x1,x0,ckpf            .Jump if no job mode request
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*rqfault
         addaq   ae,a_bindin,16*rqfault
         brreq   x0,x0,rqproc
.
.   Check for a Page Fault.
.
ckpf     shfx    x1,x_mcr,x0,57        .Check for a page fault.
         brxge   x1,x0,ckmcall         .Jump if no page fault.
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*rqpf
         addaq   ae,a_bindin,16*rqpf
         brreq   x0,x0,rqproc          .Process page fault
.
.   Check for a System Call request.
.
ckmcall  shfx    x1,x_mcr,x0,58        .Check for a SYSTEM CALL.
         brxge   x1,x0,ckucr           .Jump if no SYSTEM CALL.
         lbyts,1 x1,a_xcb,x0,xpxregs   .Get request code
         ente    xe,mtrqmax            .Check for max req code.
         brxge   xe,x1,ckmcall5        .Jump if ok.
         entp    x1,0
ckmcall5 addaq   af,a_xcb,xpxregs      .Set up plist to point to
         sa      af,a_csf,0            .X_regs of current task
         addaq   a_rqtbl,a_root,reqtbl .Build pointer to the request table entry
         mulxq   xe,x1,rqtbles
         addax   a_rqtbl,xe
         cpyaa   ae,a_bindin           .Calculate binding section entry
         shfx    x1,x1,x0,4
         addax   ae,x1
         lbyts,1 xe,a_rqtbl,x0,rn      .Validate the ring number
         lbyts,1 x2,a_xcb,x0,2         .Get p.rn from XCB
         shfx    x2,x2,x0,-4
         brxge   xe,x2,rqproc
         addaq   a_rqtbl,a_root,reqtbl .Reset pointer to request 0 entry
         addaq   ae,a_bindin,16*rqunim
         brxeq   x0,x0,rqproc
.
.   If control gets here, there is a chance that the MCR value was zero
.   (except for possible async/sel interrupts). Check for a UCR fault that
.   caused a monitor exchange because traps were disabled.
.
ckucr    lbyts,2 x1,a_xcb,x0,xpucr     .Check for fatal UCR faults.
         ente    x0,j_usrabt
         andx    x1,x0
         brxeq   x1,x0,exchloop        .Jump if no fatal faults.
         lbyts,2 x1,a_xcb,x0,xpflgte   .Check for traps enabled
         isob    x1,x1,x0,7601(8)
         decr    x1,2
         brreq   x1,x0,exchloop        .Jump if traps not disabled
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*rqfault
         addaq   ae,a_bindin,16*rqfault
         brreq   x0,x0,rqproc          .back to job mode
         page
.....................................................................
.
.   Trap Handling Routine for traps that occur in Monitor Mode
.
.....................................................................
         def     traprtn
         align   0,8
traprtn  bss     0
         entl    x0,r_pit              .Save PIT
         cpysx   x_clock,x0
         la      a_root,a_bindin,bs_root
         la      a_dscb,a_root,eicb_pva
         ente    x0,r_bc
         cpysx   x1,x0                 .get  base constant.
         cpyax   x2,a_root
         addx    x1,x2                 .form pointer to cst
         cpyxa   a_cst,x1
         addaq   a0,a0,mstkfram
         sa      a_cst,a_csf,10        .Sace CST_P in p-list.
.
         lbyts,2 x_mcr,a_psa,x0,sfsa_mcr .Get MCR
         lbyts,2 x_ucr,a_psa,x0,sfsa_ucr .Get UCR
         xtrace  2,x_mcr,x1,x0,ae      .Save MCR in trace buffer.
         histo   x_mcr,a_root,tabmcrt,xe,xf
.
.   DO NOT halt the processor if a DUE or SHORT WARNING occurred.
.
         ente    x1,m_mcrhlt+m_mcrhdw+m_mcrpf  .Check for fatal errors.
         andx    x1,x_mcr
         brxeq   x1,x0,trhdw6          .If no fatal MCR errors
         shfc    x1,x_mcr,x0,50        .Check short warning.
         brxge   x1,x0,trckdue
         addpxq  a_rq_ret,x0,trckdue   .set return address.
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*pswarn
         cpyaa   a_parm,a_csf
         addaq   ae,a_bindin,16*pswarn
         brreq   x0,x0,rqproc
trckdue  shfc    x1,x_mcr,x0,48        .Check DUE.
         brxge   x1,x0,trhdw5
         ente    x_mcr,m_mcrasy        .Force all async interrupts.
         purge   x0,2                  .Purge cache and map.
         purge   x0,15
         entp    x1,2                  .Set up plist
         sx      x1,a_csf,0            .Store code to indicate DUE in monitor.
         sa      a2,a_csf,18           .Store pointer to save area.
         cpyaa   a_parm,a_csf
         addpxq  a_rq_ret,x0,trhdw5    .set return address
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*proc_due
         addaq   ae,a_bindin,16*proc_due
         brreq   x0,x0,rqproc
trhdw5   ente    x1,m_mcrhlt+m_mcrpf   .Halt if any fatal
         andx    x1,x_mcr              .  conditions are set
         brxeq   x1,x0,trhdw6          .If no fatal MCR conditions
         errstop fatalmcr
trhdw6   bss     0
.        keypt   oscmtr,osktrpm,x_mcr,x_ucr,xe
.
.  If the trap occurred between the labels BCRIT1 and ECRIT1, reset the
.  trapped 'P' address to the label BCRIT1.
.
         lbyts,4 x1,a_psa,x0,4         .Get P from SFSA.
         addpxq  ae,x0,ecrit1
         cpyax   x2,ae
         brrgt   x1,x2,trresex
         addpxq  ae,x0,bcrit1
         cpyax   x2,ae
         brrgt   x2,x1,trresex
         sa      ae,a_psa,2
.
. The following field definition is used to support the PSFSA instruction which is
. required for CYBER-2000 but is not available in the ASSEMBLER language yet.
. When it is available, replace the VFD line with the following line:
.        psfsa                         .Purge the SFSA pushdown (CYBER-2000 only)
.
         vfd,16   0701(16)             .Purge SFSA pushdown (CYBER-2000 only)
trresex  bss     0
.
.  Protect against the case where 1) a SIT or EXT INT occurred in 180 job
.  mode to cause an exchange to monitor and 2) prior to processing the
.  SIT/EXT INT an EXCH occurred to cause a trap.
.
         la      a_xcb,a_cst,xcbp      .Fetch XCB pointer.
         cpyax   x1,a_xcb              .Skip this check if NIL.
         brrgt   x0,x1,trnom
         lbyts,2 x1,a_xcb,x0,xpmcr     .Fetch MCR from current XP.
         iorx    x_mcr,x1              .Merge with trapped MCR.
         ente    x2,m_mcrasy
         inhx    x1,x2
         sbyts,2 x1,a_xcb,x0,xpmcr     .Store MCR less asynch bits.
trnom    bss     0
.
.  Process asynchronous interrupts.
.
         ente    x1,m_mcrasy           .Check for asynchronous interrupts.
         andx    x1,x_mcr
         brxeq   x1,x0,trasy15         .Jump if no asynchronous interrupts.
         shfc    x1,x_mcr,x0,27        .Check for SIT.
         brrge   x1,x0,trasy5          .Jump if no SIT.
         addpxq  a_sitret,x0,trasy5    .Set up return address.
         brxeq   x0,x0,prsit           .Go process SIT interrupt.
trasy5   shfx    x1,x_mcr,x0,24        .Check for EXT INT
         addpxq  a_extret,x0,trasy8
         brrgt   x0,x1,extrq           .Jump if  EXT INT
trasy8   shfx    x1,x_mcr,x0,21        .Check for EXCH
         brrge   x1,x0,trasy15         .Jump if no EXCH
         entl    x0,5                  .Set EXCH bit in MCR.
         sbit    x0,a_root,a170_xp+xpmcr,x0
         ente    xe,#boff(mtrprior)
         lbyts,2 x1,a_root,xe,0        .Get 180 monitor priority.
         lbyts,2 xe,a_cst,x0,dsprior   .Dont change if already greater.
         brxgt   xe,x1,trasy9
         cpyxx   xe,x1
trasy9   entl    x0,r_jps              .Check if NOS170 is the current task.
         cpysx   x1,x0
         lbyts,4 x2,a_cst,x0,dualstat
         addpxq  a_inret,x0,trasy15
         brxne   x2,x1,run_nos         .Go run NOS 170.
.
.   Halt processor if fatal UCR fault occurred.
.
trasy15  ente    x1,m_usrabt           .Check for fatal UCR fault
         andx    x1,x_ucr
         brxeq   x1,x0,trkey           .Jump if no fatal error
         errstop fatalucr
.
.         Check for keypoint trap and software keypoint recording.
.
trkey    bss     0
         shfx    x1,x_ucr,x0,22
         brrge   x1,x0,trkeye          .If not keypoint trap
         lbyts,1 x1,a_root,x0,act_kpc
         brreq   x1,x0,trkeye          .If software keypoints not active
.
.         Software recording of keypoints turned on, record keypoint in
.         circular buffer.
.
.         Form keypoint.
.
         entl    x0,0c8(16)            .Read keypoint class
         cpysx   xe,x0
         entl    x0,0c7(16)            .Read keypoint code
         cpysx   xf,x0
         insb    xf,xe,x0,3403(8)      .Combine keypoint class and code
         entp    x0,0                  .Read free running clock
         cpytx   xe,x0
         insb    xf,xe,x0,0231(8)      .Add free running clock
         cpyaa   a_parm,a0
         addpxq  a_rq_ret,x0,trkeye    .set return address.
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*key_pnt
         addaq   ae,a_bindin,16*key_pnt
         brreq   x0,x0,rqproc
trkeye   bss     0
.
.   Set TRAP ENABLE DELAY and return.
.
.        keypt   oscmtr,osktrpmx,x0,x_ucr,xe
         entl    x0,r_ted              .Set trap enable delay
         cpyxs   x0,x0
         entl    x0,r_pit              .Restore PIT
         cpyxs   x_clock,x0
         return
         page
.........................................................................
.
.      This routine updates the request statistics and calls the
.      appropriate request processor.
.
.      entry condition:
.            a_rqtbl - pointer to request table entry for request.
.            ae      - pointer to binding section entry for request proc.
.           a_rq_ret - return address
.           a_parm - pointer to parameters.
.
.      This routine exits back to the main dispatch loop.
.........................................................................
.
rqproc   bss     0
         lbyts,1 x1,a_root,x0,multpro
         brxeq   x1,x0,rqpr14          .if not multi_processor
         lbyts,1 x1,a_rqtbl,x0,il
         brxeq   x1,x0,rqpr14          .if interlock not required
         addaq   af,a_root,il_tbl
         decr    x1,1
         mulxq   x1,x1,ilsize
         addax   af,x1                 .pva of interlock table
         entp    x0,0
         lbset   x1,af,x0
         brreq   x1,x0,rqpr12          .if request accepted
         lbyts,4 x1,a_rqtbl,x0,wtcnt
         incr    x1,1
         sbyts,4 x1,a_rqtbl,x0,wtcnt   .increment request reject count.
         lbyts,4 x1,af,x0,ilwtcnt
         incr    x1,1
         sbyts,4 x1,af,x0,ilwtcnt      .increment lock reject count
         ente    xe,r_pit
         cpysx   xe,xe                 .get current pit
rqpr4    entp    x0,0
         lbset   x2,af,x0
         brreq   x2,x0,rqpr6
         ente    x0,-20                .idle to reduce memory contention
rqpr5    brinc   x0,x0,rqpr5
         lbyts,1 x2,a_cst,x0,nextstat  .check for halt cpu request
         brxeq   x2,x0,rqpr4
         errstop csthalt
rqpr6    entl    x0,r_pit
         cpysx   x2,x0                 .current pit
         cpyxs   xe,x0                 .Restore PIT- don't charge user for lock wait.
         subx    xe,x2
         lx      x2,a_root,lockwait    .increment total lock wait time
         addx    x2,xe
         sx      x2,a_root,lockwait
         lx      x2,a_rqtbl,totwt
         addx    x2,xe
         sx      x2,a_rqtbl,totwt      .increment request wait time
         lx      x2,af,iltotwt
         addx    x2,xe
         sx      x2,af,iltotwt         .increment lock wait time
         lbyts,4 x2,a_rqtbl,x0,maxwt
         brxge   x2,xe,rqpr10          .if not longest request wait
         sbyts,4 xe,a_rqtbl,x0,maxwt
rqpr10   lbyts,4 x2,af,x0,ilmaxwt
         brxge   x2,xe,rqpr12          .if not longest lock wait
         sbyts,4 xe,af,x0,ilmaxwt
rqpr12   cpyax   x1,af                 .x1 = pva of interlock table
         ente    x2,r_bc
         cpysx   xe,x2                 .get base constant.
         sbyts,4 x2,af,x0,lockcp       .Store ID of locking CPU
rqpr14   bss     0                     .x1 = zero if no interlock.
         lbyts,4 xe,a_rqtbl,x0,rqcnt   .Update request count
         incr    xe,1
         sbyts,4 xe,a_rqtbl,x0,rqcnt
         entl    x0,r_pit
         cpysx   x2,x0                 .Get current PIT
         ente    x0,x_envir1           .Process the request
         callseg bs_rqtbl,ae,a_parm
         entl    x0,r_pit
         cpysx   xd,x0                 .Calculate time to process the request
         subx    x2,xd
         lx      xd,a_rqtbl,totalt     .Update total time
         addx    xd,x2
         sx      xd,a_rqtbl,totalt
         lbyts,4 xd,a_rqtbl,x0,maxt    .Update max time
         brxge   xd,x2,rqpr20
         sbyts,4 x2,a_rqtbl,x0,maxt
rqpr20   brxeq   x1,x0,rqpr30          .exit if no lock
         entl    x0,0
         cpyxa   af,x1
         sx      x0,af,ilflag          .Clear lock and ID field in interlock table
rqpr30   brdir   a_rq_ret,x0           .return
         page
.........................................................................
.
.  This routine is called whenever a SIT interrupt occurs.
.
.........................................................................
.
prsit    bss     0
         entp    xf,1                  .Set up X15 with 'TRUE'.
         entp    x0,0                  .Set up X0 with 'FALSE'.
         cpytx   x2,x0                 .Free running clock ->X2.
         sx      x2,a_root,scb+scbnsrv .Update '180 alive' flag.
         sbyts,1 xf,a_cst,x0,caldisp
.
prsit25  lx      x1,a_root,sitvalue    .Reset SIT.
         entl    x0,r_sit
         cpyxs   x1,x0
.
         brdir   a_sitret,x0
         page
.........................................................................
.
.   The purpose of this routine is to give control to NOS170.
.
.   NOTE: This routine may be entered with traps disabled or enabled.
.         Reentry of the routine from the trap handler is prevented by
.         setting the JPS register to NOS_JPS.  This routine exits with
.         disabled unless NOS is not present. In this case no change is
.         made to the TE register.
.
.     Enter with 180 priority in XE.
.
.........................................................................
.
.
run_nos  bss     0
.
         lbyts,4 x1,a_cst,x0,dualstat  .Exit if no dual state.
         brxeq   x1,x0,runexit
.
         entl    x0,r_jps
         cpyxs   x1,x0                 .Copy NOS_JPS to JPS reg
         addaq   a_innosx,a_root,a170_xp
.
         lbyts,1 x1,a_cst,x0,lpid8     .Store 180 priority.
         sbyts,2 xe,a_dscb,x1,np180pr
.
         entp    x_infrc,0             .Get current time
         cpytx   x_infrc,x_infrc
         lx      x2,a_root,nosexit     .Update time not spent in NOS
         subx    x2,x_infrc
         notx    x2,x2
         histo   x2,a_root,tabnnos,xe,xf
         lx      x1,a_dscb,npxtime
         addx    x1,x2
         sx      x1,a_dscb,npxtime
.
.  (BEGIN - EXCH loop).   Exchange to NOS170.
.
runnos6  bss     0
         entp    x_infrc,0             .Get current time
         cpytx   x_infrc,x_infrc
         la      af,a_root,hnsk_p      .Update monitor handshaking time
         sx      x_infrc,af,8

         xtrace  3,0,x1,xe,ae
         entl    x0,r_te               .Enable traps
         cpyxs   x0,x0
         keypoint oscmtr,x0,oskexc7
runnos7  exchange
         lbyts,2 x_inmcr,a_innosx,x0,xpmcr .Get MCR
         shfx    x2,x_inmcr,x0,13
         keypoint oscmtr,x2,oskexc7x
         entl    x0,r_td               .Disable traps
         cpyxs   x0,x0
         lbyts,2 x_inmcr,a_innosx,x0,xpmcr .Get MCR
         ente    x2,m_mcrexc           .Clear MCR except for EXCH
         andx    x2,x_inmcr
         sbyts,2 x2,a_innosx,x0,xpmcr
         xtrace  4,x_inmcr,xe,xd,ae    .Save NOS MCR in trace buffer
         histo   x_inmcr,a_root,tabmcr7,xe,xf
.
.   Process 'give up CPU' if only bit set in the MCR is 'system call'.
.
         ente    x2,m_mcrmcl
         brxne   x_inmcr,x2,runnos8    .Jump if not sys call ONLY.
         lbyts,1 x2,a_innosx,x0,xpvmid .Make sure request is from
         brxne   x2,x0,runnos50        .  170 state.
.
.   Process hardware errors - DUE.
.
runnos8  shfc    x2,x_inmcr,x0,16      .Check for DUE.
         brrge   x2,x0,runnos10        .Jump if no DUE.
         purge   x0,2                  .Purge cache and map.
         purge   x0,15
         entl    x0,1                  .Set up plist - DUE in 170 mode
         sx      x0,a_csf,0
         sa      a_innosx,a_csf,18
         addpxq  a_rq_ret,x0,runnos9   .set return address.
         cpyaa   a_parm,a_csf
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*proc_due
         addaq   ae,a_bindin,16*proc_due
         brreq   x0,x0,rqproc
runnos9  ente    x2,0490(16)           .Force async bit - may be lost.
         iorx    x_inmcr,x2
         lbyts,1 x2,a_innosx,x0,xpflgte .Check PROCESS-NOT-DAMAGED.
         shfr    x2,x2,x0,27
         brrge   x2,x0,runnos10        .Jump if damaged.
         ente    x2,7fff(16)           .Clear DUE in MCR.
         andx    x_inmcr,x2

.
.   Process short warning conditions.
.
runnos10 shfc    x2,x_inmcr,x0,18      .Check for SHORT WARNING.
         brrge   x2,x0,runnos11        .Jump if no SHORT WARNING.
         addpxq  a_rq_ret,x0,runnos11  .set return address.
         cpyaa   a_parm,a0
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*pswarn
         addaq   ae,a_bindin,16*pswarn
         brreq   x0,x0,rqproc
.
.   Process SIT interrupt.
.
runnos11 shfc    x2,x_inmcr,x0,27      .Check for SIT.
         addpxq  a_sitret,x0,runnos12  .Go process SIT interrupt.
         brrgt   x0,x2,prsit           .Jump if SIT present.
.
.   Process EXTERNAL INTERRUPT.
.
runnos12 shfc    x2,x_inmcr,x0,24      .Check for EXT INT.
         addpxq  a_extret,x0,runnos16
         brrgt   x0,x2,extrq           .Jump if  EXT INT.
.
.   Process SYSTEM CALL requests.
.
runnos16 shfc    x2,x_inmcr,x0,26      .Check for SYSTEM CALL.
         brrge   x2,x0,runnos20        .Jump if no SYSTEM CALL.
         lbyts,1 x2,a_innosx,x0,xpvmid .Check whether 170 or 180 request.
         brxeq   x2,x0,runnos18        .Jump if 180 request.
         shfc    x2,x_inmcr,x0,21      .Exit if EXCH not set.
         brrge   x2,x0,runnos50
         brxeq   x0,x0,runnos6
runnos18 entp    x0,0
         sx      x0,a_csf,1*8
         ente    x0,020(16)
         sx      x0,a_csf,2*8
         sa      a_csf,a_csf,3*8
         addaq   a_parm,a_csf,8
         addpxq  a_rq_ret,x0,runnos24  .set return address.
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*mm_ei
         addaq   ae,a_bindin,16*mm_ei
         brreq   x0,x0,rqproc
.
.   Check for FATAL NOS170 errors.  Stop running 170 if fatal
.   errors occured.
.
runnos20 ente    x2,0DB4C(16)          .Check for fatal 170 MCR
         andx    x2,x_inmcr
         brreq   x_inmcr,x0,runnos22   .Fatal if MCR = 0.
         brreq   x2,x0,runnos30        .Jump if no fatal 170 errors
runnos22 addaq   af,a_csf,8
         entp    x0,2
         sx      x0,af,0
         sx      x_inmcr,af,1*8
         sa      a_csf,af,2*8
         addpxq  a_rq_ret,x0,runnos24  .set return address.
         cpyaa   a_parm,af
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*mm_ei
         addaq   ae,a_bindin,16*mm_ei
         brreq   x0,x0,rqproc
runnos24 sa      a_cst,a_csf,10        .Restore CST_P in p-list.
         lbyts,1 x2,a_csf,X0,0
         brreq   x2,x0,runnos30        .if not a fatal nos error
         shfx    x1,x_inmcr,x0,-15     .Store termination status -
         incx    x1,1                  . 2=DUE, 1=other
         sbyts,1 x1,a_root,x0,os_terms
         entl    x0,0                  .Clear dual state flag.
         sbyts,4 x0,a_cst,x0,dualstat  .Stop running NOS170.
         sbyts,2 x0,a_dscb,x0,np170pr  .Clear 170 priority.
         entl    x0,1                  .Initiate 180 checkpoint
         sbyts,1 x0,a_cst,x0,caldisp   .Force call to dispatcher.
         sbyts,8 x0,a_csf,x0,0         .Set up plist
         addpxq  a_rq_ret,x0,runnos50  .set return address.
         cpyaa   a_parm,a_csf
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*in_ckp
         addaq   ae,a_bindin,16*in_ckp
         brreq   x0,x0,rqproc
.
.   Check if it is time to run 180.  If not, exchange back to 170.
.   If 180 needs the CPU and NOS170 is in job mode, it's OK to switch to 180.
.
runnos30 lx      x2,a_cst,discntl .Check if dispat should be called
         brxeq   x2,x0,runnos6
.
.   Its time to run 180 again. If NOS170 is in 170 job mode or in EI as
.  a result of a call from job mode, its ok to exit. Otherwise, set 180
.  priority to a high value and return to NOS170. It should give up control
.  quickly.
.
         shfc    x2,x_inmcr,x0,21      .Cant exit if EXCH is set in 170 XP.
         brrgt   x0,x2,runnos35        .Jump if EXCH is set.
         lbyts,1 x2,a_innosx,x0,xpvmid .Get 170 mode VMID.
         lx      xd,a_innosx,xpucr     .Get word that contains monitor flag.
         brxne   x2,x0,runnos32         .Jump if in 170 mode.
         la      af,a_innosx,2*8+8+2   .get pointer to stack frame save area
         lx      xd,af,xpucr           .Get monitor flag from save area.
runnos32 shfc    xd,xd,x0,31           .Move monitor flag to bit 0.
         brxge   xd,x0,runnos50        .Jump if ok to exit from 170.
.
runnos35 lbyts,1 x1,a_cst,x0,lpid8     .Cant exit. Raise 180 priority.
         ente    x2,708(16)
         sbyts,2 x2,a_dscb,x1,np180pr
         brxeq   x0,x0,runnos6
.
.
.   End of EXCH loop.
.
runnos50 entp    x0,0                  .Get current time
         cpytx   x1,x0
         sx      x1,a_root,nosexit
         subx    x1,x_infrc
         histo   x1,a_root,tabinos,xe,xf
         lx      x2,a_root,nostime     .Update total NOS cpu time
         addx    x1,x2
         sx      x1,a_root,nostime
         entl    x0,r_jps              .Reset JPS
         lx      x1,a_cst,xcbrma
         cpyxs   x1,x0
runexit  brdir   a_inret,x0            .Return to where called from
         page
.........................................................................
.
.        process requests from another processor
.
.        entry conditions:
.           a_extret - return address
.
.........................................................................
.
extrq    lbyts,1 x1,a_root,x0,multpro
         brxeq   x1,x0,extrq5          .jump if not multiprocessor
         entp    x2,0
         entl    x0,tsk_sw
         lx      x1,a_cst,ext_int
         shfc    x1,x1,x0,tsk_sw
         brxge   x1,x0,extrq1          .jump if no task switch
         sbit    x2,a_cst,ext_int,x0
         entl    x0,1
         sbyts,1 x0,a_cst,x0,caldisp   .set task switch flag
extrq1   entl    x0,pur_ca
         shfc    x1,x1,x0,pur_ca-tsk_sw+64
         brxge   x1,x0,extrq2          .jump if cache purge not needed
         sbit    x2,a_cst,ext_int,x0
         cpytx   x0,x2                 .free running clock
         purge   x0,2                  .purge cache
         sx      x0,a_cst,cachtim
extrq2   entl    x0,pur_map
         shfc    x1,x1,x0,pur_map-pur_ca+64
         brxge   x1,x0,extrq3          .jump if map purge not needed
         sbit    x2,a_cst,ext_int,x0
         cpytx   x0,x2                 .free running clock
         purge   x0,15                 .purge map
         sx      x0,a_cst,maptim
extrq3   shfc    x1,x1,x0,step_pr-pur_map+64
         brxge   x1,x0,extrq4          .jump if no error halt
         errstop csthalt
extrq4   lbyts,1 x1,a_cst,x0,memport   .Dont check IO completions if
         ente    xe,#boff(intport)
         lbyts,1 x2,a_root,xe,0        . IOU doesnt send them to this CPU.
         brxne   x1,x2,extrqx
         lx      x1,a_root,extiou      .Exit if no external interrupts
         brxeq   x1,x0,extrq6          . have been sent by IOU.
extrq5   entl    x0,1
         sx      x0,a_root,eiflag      .Set flag that ext interrupt.
         sx      x0,a_root,asyntime
         sbyts,1 x0,a_cst,x0,asyncp
extrq6   la      ae,a_root,dpv$scd_block_p
         addaq   ae,ae,4
         entp    x0,0
         lbset   x1,ae,x0
         brrne   x1,x0,extrqx          .If SCD block not updated
         cpyaa   a_rq_ret,a_extret     .set return address.
         addaq   a_rqtbl,a_root,reqtbl+rqtbles*ascii_kb
         addaq   ae,a_bindin,16*ascii_kb
         brreq   x0,x0,rqproc
extrqx   brdir   a_extret,x0
         page
........................................................................
.
.        MTP$IDLE_180  routine to idle 180.
.
.        This routine is called to put 180 into an idle state. Only
.        the system console is kept alive and only the monitor window
.        will respond to commands. If dual state is present, 180 will idle
.        and give control to NOS/NOS-BE. Depending on why the system idled,
.        the system may be able to be resumed via a RESUME_SYSTEM command.
.
.            mtp$idle_180 (resume_permitted: boolean)
.
........................................................................
         align     0,8
idle180  ALIAS     MTP$IDLE_180
idle180  procedur
idleres  param     val,subrange,1
.
         ploadx    x_resume,idleres             .Load RESUME_ALLOWED - A4 gets
.                                                clobbered later.
         la        a_root,a_bindin,bs_root

         la        a_dscb,a_root,eicb_pva
         addaq     a0,a0,mstkfram
         entl      x0,r_pit                     .Save PIT - dont charge current task for idle
         cpysx     x_clock,x0                   . time.
         ente      x0,r_bc
         cpysx     x1,x0                        .get  base constant.
         cpyax     x2,a_root
         addx      x1,x2                       .form pointer to cst
         cpyxa     a_cst,x1
.
         entl      x0,0c2(16)                  .Enable traps in case we got here via trap
         cpyxs     x0,x0                       . handler.
.
i180a    entp      xe,0                        .Set 180 priority to 0.
         addpxq    a_inret,x0,i180c            .Run NOS170 if it is present. (If not present
         brreq     x0,x0,run_nos               .  runnos returns immediately.)
i180c    bss       0
         entp      x0,0                        .Set lock for calling
         addaq     af,a_root,asylocki          .  mtp$monitor_system_status.
         lbset     x1,af,x0
         brrgt     x1,x0,i180f                 .Jump if already locked.
         la        ae,a_root,mtvdftb           .Fetch pointer to DFT block.
         lx        x1,ae,dftcw                 .Get DFT control word.
         shfx      x1,x1,x0,62                 .Check E8 field.
         brxge     x1,x0,i180e                 .Jump if not set.
         ente      x0,00ff(16)
         addaq     ae,a_bindin,16*proc_dft     .Set up call to dsp$process_dft_block.
         callseg   bs_rqtbl,ae,a0              .Call dsp$process_dft_block.
i180e    bss       0
         ente      x0,00ff(16)
         addaq     ae,a_bindin,16*mon_smu      .Set up call to mtp$monitor_system_status.
         callseg   bs_rqtbl,ae,a0              .Call mtp$monitor_system_status.
         entp      x0,0                        .Clear call environment.
         sbyts,1   x0,af,x0,0                  .Clear lock.
i180f    bss       0
         ente      xc,scb+scbstepr
         lbyts,1   x1,a_root,xc,0              .Loop if STEP still requested.
         brrne     x1,x0,i180a
         brxeq     x_resume,x0,i180a           .Loop if resume not permitted.
.
         entl      x0,r_pit                    .Restore PIT.
         cpyxs     x_clock,x0
         return
.
         page
....................................................................................
.  Name:
         align   0,8
.    MTP$CST_POINTER
.  Purpose:
.    this procedure returns the pointer to the CPU STATE TABLE for the
.    current processor.
.  Output:
.    CST_P: pointer to the CST.
....................................................................................
.
.  FUNCTION [XDCL] mtp$cst_pointer (cst_id: 0..1): ^cell
.
.
cstp     alias   MTP$CST_POINTER
cstp     function pointer
cst_id   param   val,subrange,1
         la      a_root,a_bindin,bs_root
         ente    x0,r_bc
         cpysx   x1,x0                 .get  base constant.
         cpyax   x2,a_root
         addx    x1,x2                 .form pointer to cst
         freturnx x1
         page
.........................................................................
.
.   This routine is called from cybil to send interrupts to other processors.
.
.      PROCEDURE [XREF] mtp$interrupt_processor (port_mask: 0..255)
.
.........................................................................
.
int      alias   MTP$INTERRUPT_PROCESSOR
int      procedur
intmask  param   val,subrange,1
         ploadx  x2,intmask
         intrupt x2,0
         return
         page

.        The following is a list of external references that should exist in monitor
.        boot.  They are needed to satisfy external references to link without errors.
.        They are not needed for normal execution, if they are ever called, it is a
.        fatal error.

         defg    OSP$PROCESS_MTR_PAGE_FAULT
         defg    MMP$ASSIGN_PAGE_TO_MONITOR
         defg    TMP$SEND_MONITOR_FAULT
         defg    DMV$P_ACTIVE_VOLUME_TABLE
         defg    DMP$SEARCH_ACTIVE_VOLUME_TABLE
         defg    DMP$CREATE_DEVICE_FILE
         defg    DMP$DETACH_DEVICE_FILE
         defg    NAV$NETWORK_RESPONSE_PROCESSOR
         defg    RFV$RESPONSE_PROCESSOR
         defg    DFV$PROCESS_MULTIWORD_RESPONSE
         defg    IOV$PROCESS_SUBSYSTEM_RESPONSE
         defg    SYP$INVOKE_SYSTEM_DEBUGGER
         defg    DSP$TEST_RESOURCE_REQUESTS
         defg    SYP$INVOKE_SYSCORE_COND_HANDLER
         defg    SYP$INVOKE_SYSCORE_UCR_HANDLER
         defg    SYP$SET_PROCESS_INTERVAL_TIMER
         defg    SYP$MFH_FOR_HANG_TASK
         defg    DMP$SET_FILE_TABLE_LOCATOR
         defg    DMP$GET_FILE_DESCRIPTOR_ENTRY
         defg    DMP$GET_UNUSED_AVT_ENTRY
         defg    DMP$LOCK_AVT_ENTRY
         defg    DMP$UNLOCK_AVT_ENTRY
         defg    DMP$RELEASE_AVT_ENTRY
         defg    PMP$GET_JOB_NAMES

         align   0,8

OSP$PROCESS_MTR_PAGE_FAULT             bss   0
MMP$ASSIGN_PAGE_TO_MONITOR             bss   0
TMP$SEND_MONITOR_FAULT                 bss   0
DMV$P_ACTIVE_VOLUME_TABLE              bss   0
DMP$SEARCH_ACTIVE_VOLUME_TABLE         bss   0
DMP$CREATE_DEVICE_FILE                 bss   0
DMP$DETACH_DEVICE_FILE                 bss   0
NAV$NETWORK_RESPONSE_PROCESSOR         bss   0
RFV$RESPONSE_PROCESSOR                 bss   0
DFV$PROCESS_MULTIWORD_RESPONSE         bss   0
IOV$PROCESS_SUBSYSTEM_RESPONSE         bss   0
SYP$INVOKE_SYSTEM_DEBUGGER             bss   0
DSP$TEST_RESOURCE_REQUESTS             bss   0
SYP$INVOKE_SYSCORE_COND_HANDLER        bss   0
SYP$INVOKE_SYSCORE_UCR_HANDLER         bss   0
SYP$SET_PROCESS_INTERVAL_TIMER         bss   0
SYP$MFH_FOR_HANG_TASK                  bss   0
DMP$SET_FILE_TABLE_LOCATOR             bss   0
DMP$GET_FILE_DESCRIPTOR_ENTRY          bss   0
DMP$GET_UNUSED_AVT_ENTRY               bss   0
DMP$LOCK_AVT_ENTRY                     bss   0
DMP$UNLOCK_AVT_ENTRY                   bss   0
DMP$RELEASE_AVT_ENTRY                  bss   0
PMP$GET_JOB_NAMES                      bss   0

         errstop stubcall              .Call to a stub in monitor, fatal error

         end     begin
*DECK DECK=DSM$CALL_TO_DEADSTART EXPAND=TRUE
          IDENT  DSMDST
          ENTRY  DSMDST
 DSMDST   EQ     =XDSPDST
          END    DSMDST
*DECK DECK=DSM$CREATE_VE_DEADSTART_CATALOG EXPAND=TRUE
PROCEDURE create_ve_deadstart_catalog, crevdc (
  deadstart_catalog, dc: file = $required
  external_vsn, evsn, ev: any of
      string 1..6
      name 1..6
    anyend = $optional
  recorded_vsn, rvsn, rv: any of
      string 1..6
      name 1..6
    anyend = $optional
  type, t: any of
      key
        mt9$1600
        mt9$6250
        mt18$38000
      keyend
    anyend = mt9$6250
  removable_media_group, rmg: (BY_NAME, ADVANCED) any of
      key
        none
      keyend
      name
    anyend = osd$reqmt_removable_media_group, none
  status)

*copyc dst$deadstart_record_lists

  VAR
    beginning_of_file_id: integer
    catalog_path: string
    created_catalogs: list 0 .. $max_list OF file
    created_files: list 0 .. $max_list OF file
    end_of_file_id: integer
    file_id: string 1 .. $max_name
    finished: boolean
    first_file: boolean = TRUE
    ignore_status: status
    index: integer
    info_file: string 1 .. $max_name = $unique
    line: string
    local_file: string 1 .. $max_name = $unique
    local_status: status
    previous_catalog_path: string
    return_file: file
    tape_file: string 1 .. $max_name = $unique
    temp_file_id: string 1 .. 17
  VAREND

  created_catalogs = ()
  created_files = ()

  set_file_attributes f=$fname(info_file) pf=continuous

  catalog_block: BLOCK

    "  Request the labelled deadstart tape.

    IF NOT $specified(external_vsn) AND NOT $specified(recorded_vsn) THEN
      IF removable_media_group = 'NONE' THEN
        local_status = $status(FALSE, 'DS', dse$vsn_required)
        EXIT catalog_block
      IFEND
    IFEND
    IF NOT $specified(external_vsn) AND NOT $specified(recorded_vsn) THEN
      request_magnetic_tape f=$fname(tape_file) r=false ..
            t=type rmg=removable_media_group status=local_status
      EXIT catalog_block WHEN NOT local_status.normal
    ELSEIF NOT $specified(external_vsn) THEN
      request_magnetic_tape f=$fname(tape_file) rvsn=recorded_vsn r=false ..
            t=type rmg=removable_media_group status=local_status
      EXIT catalog_block WHEN NOT local_status.normal
    ELSEIF NOT $specified(recorded_vsn) THEN
      request_magnetic_tape f=$fname(tape_file) evsn=external_vsn r=false ..
            t=type rmg=removable_media_group status=local_status
      EXIT catalog_block WHEN NOT local_status.normal
    ELSE
      request_magnetic_tape f=$fname(tape_file) evsn=external_vsn rvsn=recorded_vsn r=false ..
            t=type rmg=removable_media_group status=local_status
      EXIT catalog_block WHEN NOT local_status.normal
    IFEND
    set_file_attributes f=$fname(tape_file) flt=labelled status=local_status
    EXIT catalog_block WHEN NOT local_status.normal

    "  Create the catalogs to which the files on the deadstart tape will be written.

    create_catalog c=deadstart_catalog status=local_status
    IF NOT local_status.normal THEN
      EXIT catalog_block WHEN $condition(local_status.condition) <> 'PFE$NAME_ALREADY_SUBCATALOG'
    ELSE
      created_catalogs = $add(deadstart_catalog, created_catalogs)
    IFEND

    "  For each file on the deadstart tape, get the file identifier, validate the file with the required
    "  files list, create a file by that name in the deadstart catalog, and copy the file to the deadstart
    "  catalog file according to the site catalog.

    index = 1
    WHILE index <= deadstart_file_count DO

      REPEAT
        IF first_file THEN
          change_tape_label_attributes f=$fname(tape_file) fsp=beginning_of_set rl=no status=local_status
          first_file = FALSE
        ELSE
          change_tape_label_attributes f=$fname(tape_file) fsp=next_file rl=no status=local_status
        IFEND
        EXIT catalog_block WHEN NOT local_status.normal

        IF deadstart_file_list(index).site_catalog = 'CIP' THEN
          set_file_attributes f=$fname(local_file) block_type=SS record_type=U status=local_status
          EXIT catalog_block WHEN NOT local_status.normal
        IFEND;

        copy_file i=$fname(tape_file) o=$fname(local_file) status=local_status
        EXIT catalog_block WHEN NOT local_status.normal

        display_tape_label_attributes f=$fname(tape_file) do=(file_identifier, current_file) ..
              o=$fname(info_file) status=local_status
        EXIT catalog_block WHEN NOT local_status.normal
        accept_line v=line i=$fname(info_file) status=local_status
        EXIT catalog_block WHEN NOT local_status.normal
        beginning_of_file_id = $scan_string(':', line)+3
        file_id = $substr(line, beginning_of_file_id, 18)
        end_of_file_id = $scan_string('''',file_id)-1
        file_id = $substr(file_id, 1, end_of_file_id)
        temp_file_id = $substr(file_id, 1, 17, ' ')
        put_line l=' Moving the file '//temp_file_id//' from the tape to the deadstart catalog.'

        IF index <> deadstart_file_count THEN
          WHILE file_id <> deadstart_file_list(index).tape_name DO
            IF deadstart_file_list(index).site_required OR (index > deadstart_file_count) THEN
              local_status = $status(FALSE, 'DS', dse$not_deadstart_tape)
              EXIT catalog_block
            IFEND
            index = index + 1
          WHILEND
          IF deadstart_file_list(index).site_catalog = ' ' THEN
            catalog_path = $string(deadstart_catalog)
          ELSE
            catalog_path = $string(deadstart_catalog)//'.'//deadstart_file_list(index).site_catalog
            create_catalog c=$fname(catalog_path) status=local_status
            IF NOT local_status.normal THEN
              EXIT catalog_block WHEN $condition(local_status.condition) <> 'PFE$NAME_ALREADY_SUBCATALOG'
            ELSE
              created_catalogs = $add($fname(catalog_path), created_catalogs)
            IFEND
          IFEND
          file_name = catalog_path//'.'//deadstart_file_list(index).tape_name
          previous_catalog_path = catalog_path
          finished = TRUE

        ELSEIF file_id <> last_deadstart_tape_name THEN

          "  File exists on the deadstart tape but is not in the required files list.

          file_name = previous_catalog_path//'.'//file_id
          file_name = $TRIM(file_name ' ' trailing)
          finished = FALSE

        ELSE
          IF deadstart_file_list(index).site_catalog = ' ' THEN
            catalog_path = $string(deadstart_catalog)
          ELSE
            catalog_path = $string(deadstart_catalog)//'.'//deadstart_file_list(index).site_catalog
            create_catalog c=$fname(catalog_path) status=local_status
            IF NOT local_status.normal THEN
              EXIT catalog_block WHEN $condition(local_status.condition) <> 'PFE$NAME_ALREADY_SUBCATALOG'
            ELSE
              created_catalogs = $add($fname(catalog_path), created_catalogs)
            IFEND
          IFEND
          file_name = catalog_path//'.'//deadstart_file_list(index).tape_name
          finished = TRUE
        IFEND

        copy_file i=$fname(local_file) o=$fname(file_name//'.$next') status=local_status
        EXIT catalog_block WHEN NOT local_status.normal
        IF deadstart_file_list(index).object_library_file THEN
          change_file_attributes f=$fname(file_name//'.$high') fc=object fs=library status=local_status
          EXIT catalog_block WHEN NOT local_status.normal
        IFEND
        created_files = $add($fname(file_name//'.$high'), created_files)
        detach_file f=$fname(local_file) status=ignore_status
      UNTIL finished
      index = index + 1
    WHILEND

  BLOCKEND catalog_block

  detach_file f=$fname(tape_file) status=ignore_status
  detach_file f=$fname(info_file) status=ignore_status
  detach_file f=$fname(local_file) status=ignore_status
  IF NOT local_status.normal THEN

    "  Delete any files that were created.

    WHILE NOT $nil(created_files) DO
      return_file = $first(created_files)
      created_files = $rest(created_files)
      delete_file f=return_file status=ignore_status
    WHILEND

    "  Delete any catalogs that were created.

    WHILE NOT $nil(created_catalogs) DO
      return_file = $first(created_catalogs)
      created_catalogs = $rest(created_catalogs)
      delete_catalog c=return_file do=catalog_and_contents status=ignore_status
    WHILEND
  IFEND
  EXIT PROCEDURE WITH local_status WHEN NOT local_status.normal

PROCEND create_ve_deadstart_catalog
*DECK DECK=DSM$CREATE_VE_DEADSTART_TAPE EXPAND=TRUE
PROCEDURE create_ve_deadstart_tape, crevdt (
  deadstart_catalog, dc: file = $required
  external_vsn, evsn, ev: any of
      string 1..6
      name 1..6
    anyend = $optional
  recorded_vsn, rvsn, rv: any of
      string 1..6
      name 1..6
    anyend = $optional
  type, t: any of
      key
        mt9$1600
        mt9$6250
        mt18$38000
      keyend
    anyend = mt9$6250
  product_files, pf: (HIDDEN) list of file = $optional
  removable_media_group, rmg: (BY_NAME, ADVANCED) any of
      key
        none
      keyend
      name
    anyend = osd$reqmt_removable_media_group, none
  unload_deadstart_tape, udt: boolean = TRUE
  status)

*copyc dst$deadstart_record_lists

  TYPE
    files_record: RECORD
      name: string 0 .. $max_name
      file_id: string 1 .. 17
    RECEND
  TYPEND

  VAR
    block_type: name
    deadstart_tape: string 0 .. $max_name = $unique
    file_count: integer
    file_id: string 0 .. $max_name
    file_name: file
    file_name_string: string
    ignore_status: status
    index: integer
    local_status: status
    maxbl: integer
    record_type: name
    release_tapes_message: list of string = (' WARNING - You are not validated for RELEASE_TAPES.', ..
' You must have a REMOVABLE_MEDIA_ACCESS validation for ((RELEASE_TAPES (WRITE)))', ..
' to create a secure deadstart tape.  This tape is not secure.')
    temp_product_list: list 0 .. $max_list of file
    total_deadstart_file_count: integer
  VAREND

  IF $specified(product_files) THEN
    total_deadstart_file_count = deadstart_file_count + $size(product_files)
  ELSE
    total_deadstart_file_count = deadstart_file_count
  IFEND

  VAR
    deadstart_files: ARRAY 1 .. total_deadstart_file_count OF files_record
  VAREND

  FOR index = 1 TO total_deadstart_file_count DO
    deadstart_files(index).name = $unique
  FOREND

  crevdt_block: BLOCK

    display_catalog c=deadstart_catalog o=$null status=local_status
    EXIT crevdt_block WHEN NOT local_status.normal

    IF NOT $specified(external_vsn) AND NOT $specified(recorded_vsn) THEN
      IF removable_media_group = 'NONE' THEN
        local_status = $status(FALSE, 'DS', dse$vsn_required)
        EXIT crevdt_block
      IFEND
    IFEND

    " Acquire the deadstart files.

    put_line l=' Acquire the deadstart files.' o=$response

    file_count = 1
    acquire_files: FOR index = 1 TO deadstart_file_count DO
      IF index = deadstart_file_count THEN
        IF $specified(product_files) THEN
          temp_product_list = product_files
          WHILE NOT $nil(temp_product_list) DO
            file_name = $first(temp_product_list)
            temp_product_list = $rest(temp_product_list)
            attach_file f=file_name lfn=$name(deadstart_files(file_count).name) am=(read execute) ..
                  sm=(read execute) status=local_status
            EXIT crevdt_block WHEN NOT local_status.normal
            file_id = $strrep($first($reverse($path_elements(file_name))))
            IF $size(file_id) > 17 THEN
              deadstart_files(file_count).file_id = file_id(1, 17)
            ELSE
              deadstart_files(file_count).file_id = file_id
            IFEND
            file_count = file_count + 1
          WHILEND
        IFEND
      IFEND
      IF deadstart_file_list(index).site_catalog = '' THEN
        file_name_string = $string(deadstart_catalog)//'.'//deadstart_file_list(index).tape_name
      ELSE
        file_name_string = $string(deadstart_catalog)//'.'//deadstart_file_list(index).site_catalog//'.'// ..
              deadstart_file_list(index).tape_name
      IFEND
      attach_file f=$fname(file_name_string) lfn=$name(deadstart_files(file_count).name) am=(read execute) ..
            sm=(read execute) status=local_status
      IF NOT local_status.normal THEN
        IF deadstart_file_list(index).site_required THEN
          EXIT crevdt_block
        ELSE
          CYCLE acquire_files
        IFEND
      IFEND
      deadstart_files(file_count).file_id = deadstart_file_list(index).tape_name
      file_count = file_count + 1
    FOREND acquire_files

    " Request the deadstart tape.

    put_line l=' Begin writing the deadstart tape.' o=$response
    IF NOT $specified(external_vsn) AND NOT $specified(recorded_vsn) THEN
      request_magnetic_tape f=$fname(deadstart_tape) r=TRUE t=type ..
           rmg=removable_media_group status=local_status
    ELSEIF NOT $specified(external_vsn) THEN
      request_magnetic_tape f=$fname(deadstart_tape) rvsn=recorded_vsn r=TRUE t=type ..
           rmg=removable_media_group status=local_status
    ELSEIF NOT $specified(recorded_vsn) THEN
      request_magnetic_tape f=$fname(deadstart_tape) evsn=external_vsn r=TRUE t=type ..
           rmg=removable_media_group status=local_status
    ELSE
      request_magnetic_tape f=$fname(deadstart_tape) evsn=external_vsn rvsn=recorded_vsn ..
           r=TRUE t=type rmg=removable_media_group status=local_status
    IFEND
    EXIT crevdt_block WHEN NOT local_status.normal
    set_file_attribute f=$fname(deadstart_tape) flt=labelled status=local_status
    EXIT crevdt_block WHEN NOT local_status.normal
    change_tape_label_attributes f=$fname(deadstart_tape) removable_media_group=release_tapes ..
        status=local_status
    IF (NOT local_status.normal) AND (local_status.condition = AV157) THEN
      "User not validated for RELEASE_TAPES; try again without it"
      change_tape_label_attributes f=$fname(deadstart_tape) status=local_status
      EXIT crevdt_block WHEN NOT local_status.normal
      display_value release_tapes_message
    IFEND

    IF type = 'MT18$38000' THEN
      maxbl=32640
    ELSE
      maxbl=4128
    IFEND;

    " Copy the deadstart files to the deadstart tape.

    FOR index = 1 TO (file_count - 1) DO
      IF index <= deadstart_tape_cip_file_count THEN
        change_tape_label_attributes f=$fname(deadstart_tape) fsp=next_file rl=TRUE ..
            fi=deadstart_files(index).file_id bt=US rt=U maxbl=4128 status=local_status
      ELSE
        get_block_and_record_type i=$fname(deadstart_files(index).name) bt=block_type rt=record_type ..
              status=local_status
        EXIT crevdt_block WHEN NOT local_status.normal
        change_tape_label_attributes f=$fname(deadstart_tape) fsp=next_file rl=TRUE ..
            fi=deadstart_files(index).file_id bt=block_type rt=record_type maxbl=maxbl status=local_status
      IFEND;
      EXIT crevdt_block WHEN NOT local_status.normal
      put_line l=' Copying the file, '//deadstart_files(index).file_id//', to the deadstart tape.' o=$response
      copy_file i=$fname(deadstart_files(index).name) o=$fname(deadstart_tape) status=local_status
      EXIT crevdt_block WHEN NOT local_status.normal
    FOREND

    put_line l=' Deadstart tape written.' o=$response

  BLOCKEND crevdt_block

  detach_file f=$fname(deadstart_tape) uv=unload_deadstart_tape status=ignore_status

  FOR index = 1 TO total_deadstart_file_count DO
    detach_file f=$fname(deadstart_files(index).name) status=ignore_status
  FOREND

  EXIT PROCEDURE WITH local_status WHEN NOT local_status.normal

PROCEND create_ve_deadstart_tape
*DECK DECK=DSM$DEADSTART_FAPS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Deadstart File FAPs' ??
MODULE dsm$deadstart_faps;

{ PURPOSE:
{   This module contains FAPS used by the deadstart utilities.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dse$nos_fap_errors
*copyc mld$memory_link_declarations
?? POP ??
*copyc amp$access_method
*copyc amp$fetch_fap_pointer
*copyc amp$store_fap_pointer
*copyc i#build_adaptable_seq_pointer
*copyc i#move
*copyc osp$set_status_abnormal
?? TITLE := 'Global Declarations Declaraed by This Module', EJECT ??
  CONST
    ai_eop = 4,
    ai_end_of_file = 7,
    ai_end_of_op = 8,

    max_words = (mlc$max_message_length DIV (512 * 8)) * 512,
    disk_block_size = max_words * 8,

    tape_block_size = 256 * 15,
    tape_trailer_eof = 17(8),
    tape_trailer_eor = 0;

  TYPE
    disk_fap_block = RECORD
      file_identifier: amt$file_identifier,
      next_type_of_partition: integer,
      write_end_of_partition: boolean,
      write_to_file: boolean,
    RECEND,

    i_tape_fap_block = RECORD
      file_identifier: amt$file_identifier,
      tape_block: ARRAY [1 .. (tape_block_size + 6)] OF char,
      tape_block_counter: integer,
      data_in_block: integer,
      block_number: integer,
      record_length: amt$max_record_length,
      file_position: amt$file_position,
      write_to_file: boolean,
    RECEND,

    padded_trailer_record = PACKED RECORD
      pad: 0 .. 15,
      trailer: tape_trailer,
      junk: 0 .. 15,
    RECEND,

    si_tape_fap_block = RECORD
      file_identifier: amt$file_identifier,
      block_number: integer,
      write_to_file: boolean,
    RECEND,

    tape_trailer = PACKED RECORD
      block_length: 0 .. 7777(8),
      block_number: 0 .. 77777777(8),
      block_level: 0 .. 7777(8),
    RECEND;
?? TITLE := 'disk_close_file', EJECT ??

{  PURPOSE:
{    This procedure closes the file that has the disk FAP attached.

  PROCEDURE disk_close_file
    (    call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR file_information_p: ^disk_fap_block;
     VAR status: ost$status);

    VAR
      file_identifier: amt$file_identifier;

    status.normal := TRUE;

   /close_file/
    BEGIN
      IF file_information_p^.write_to_file THEN

        { Write the end of partition information to the file.

        disk_write_eop_partition (file_information_p, layer_number, status);
        IF NOT status.normal THEN
          EXIT /close_file/;
        IFEND;
        file_information_p^.next_type_of_partition := ai_end_of_op;
        disk_write_eop_partition (file_information_p, layer_number, status);
        IF NOT status.normal THEN
          EXIT /close_file/;
        IFEND;
      IFEND;
    END /close_file/;

    file_identifier := file_information_p^.file_identifier;
    FREE file_information_p;
    amp$access_method (file_identifier, call_block, layer_number, status);

  PROCEND disk_close_file;
?? TITLE := 'disk_get_next', EJECT ??

{  PURPOSE:
{    This procedure retrieves a record of data from the file that has the disk fap attached.

  PROCEDURE disk_get_next
    (    file_information_p: ^disk_fap_block;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      access_byte_address: amt$file_byte_address,
      access_call_block: amt$call_block,
      access_file_position: amt$file_position,
      access_transfer_count: amt$transfer_count,
      conversion_data_index: integer,
      conversion_data_p: ^PACKED ARRAY [1 .. *] OF 0 .. 0f(16),
      conversion_area_p: ^SEQ ( * ),
      data_block_p: ^SEQ ( * ),
      disk_block: ARRAY [1 .. disk_block_size] OF cell,
      end_of_partition_type: integer,
      file_position_p: ^amt$file_position,
      half_byte_index: 0 .. 16,
      total_data_size_p: ^amt$transfer_count,
      working_storage_data_index: integer,
      working_storage_data_p: ^PACKED ARRAY [1 .. *] OF 0 .. 0f(16),
      working_storage_seq_p: ^SEQ ( * );

    status.normal := TRUE;

    { Build a sequence pointer to the working storage area that will hold the data retrieved.

    file_position_p := call_block.getn.file_position;
    total_data_size_p := call_block.getn.transfer_count;
    total_data_size_p^ := 0;
    i#build_adaptable_seq_pointer (#RING (call_block.getn.working_storage_area),
       #SEGMENT (call_block.getn.working_storage_area),
       #OFFSET (call_block.getn.working_storage_area),
       call_block.getn.working_storage_length, 0, working_storage_seq_p);

    { Build the call block that will remove the data from the disk file.

    access_call_block.operation := amc$get_next_req;
    access_call_block.getn.working_storage_area := ^disk_block;
    access_call_block.getn.working_storage_length := #SIZE (disk_block);
    access_call_block.getn.transfer_count := ^access_transfer_count;
    access_call_block.getn.byte_address := ^access_byte_address;
    access_call_block.getn.file_position := ^access_file_position;

    { Retrieve chunks of data until an end of partition is reached.

    REPEAT
      amp$access_method (file_information_p^.file_identifier, access_call_block, layer_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF access_transfer_count > 0 THEN
        NEXT data_block_p: [[REP access_transfer_count OF cell]] IN working_storage_seq_p;
        i#move (^disk_block, data_block_p, access_transfer_count);
        total_data_size_p^ := total_data_size_p^ + access_transfer_count;
      IFEND;
    UNTIL access_file_position = amc$eop;

    IF total_data_size_p^ <> 0 THEN
      PUSH conversion_area_p: [[REP total_data_size_p^ OF cell]];
      RESET conversion_area_p;
      RESET working_storage_seq_p;

      { The data must be converted from groups of 60-bits of data stored right-justified into
      { 64-bit groups to PACKED data.

      NEXT working_storage_data_p: [1 .. (total_data_size_p^ * 2)] IN working_storage_seq_p;
      NEXT conversion_data_p: [1 .. (total_data_size_p^ * 2)] IN conversion_area_p;
      working_storage_data_index := 1;
      conversion_data_index := 1;
      half_byte_index := 0;
      WHILE (working_storage_data_index <= (total_data_size_p^ * 2)) DO
        CASE half_byte_index OF
        = 0 =

          { Skip over the half byte of zero.

        ELSE
          conversion_data_p^ [conversion_data_index] := working_storage_data_p^ [working_storage_data_index];
          conversion_data_index := conversion_data_index + 1;
          conversion_data_p^ [conversion_data_index] := 0;
        CASEND;
        working_storage_data_index := working_storage_data_index + 1;
        half_byte_index := (half_byte_index + 1) MOD 16;
      WHILEND;
      total_data_size_p^ := conversion_data_index DIV 2;
      RESET conversion_area_p;
      RESET working_storage_seq_p;
      i#move (conversion_area_p, working_storage_seq_p, total_data_size_p^);
    IFEND;

    { Retrieve the end of partition data and use it to find the file position.

    access_call_block.getn.working_storage_area := ^end_of_partition_type;
    access_call_block.getn.working_storage_length := #SIZE(end_of_partition_type);
    amp$access_method (file_information_p^.file_identifier, access_call_block, layer_number, status);
    IF end_of_partition_type = ai_eop THEN
      file_position_p^ := amc$eor;
    ELSEIF end_of_partition_type = ai_end_of_file THEN
      file_position_p^ := amc$eop;
    ELSEIF end_of_partition_type = ai_end_of_op THEN
      file_position_p^ := amc$eoi;
    IFEND;

  PROCEND disk_get_next;
?? TITLE := 'disk_open_file', EJECT ??

{  PURPOSE:
{    This procedure opens the file that has the disk FAP attached.  It also creates a pointer associated with
{    the FAP to save file information that is used for all the calls to access the file.

  PROCEDURE disk_open_file
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      file_information_p: ^disk_fap_block;

    status.normal := TRUE;

    { Open the file.

    amp$access_method (file_identifier, call_block, layer_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Create a FAP pointer that will store necessary information between calls to the FAP.  A FAP pointer
    { is associated with each instance of the file being opened.

    ALLOCATE file_information_p;
    amp$store_fap_pointer (file_identifier, layer_number, file_information_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_information_p^.file_identifier := file_identifier;
    file_information_p^.next_type_of_partition := ai_eop;
    file_information_p^.write_to_file := FALSE;
    file_information_p^.write_end_of_partition := FALSE;

  PROCEND disk_open_file;
?? TITLE := 'disk_put_next', EJECT ??

{  PURPOSE:
{    This procedure puts a record of data onto the file that has the disk fap attached.

  PROCEDURE disk_put_next
    (    file_information_p: ^disk_fap_block;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      access_byte_address: amt$file_byte_address,
      access_call_block: amt$call_block,
      block_size: 1 .. disk_block_size,
      conversion_area_p: ^ SEQ ( * ),
      conversion_data_index: integer,
      conversion_data_p: ^PACKED ARRAY [1 .. *] OF 0 .. 0f(16),
      data_block_p: ^SEQ ( * ),
      disk_block: ARRAY [1 .. disk_block_size] OF cell,
      half_byte_index: 0 .. 16,
      new_record_size: integer,
      working_storage_data_index: integer,
      working_storage_data_p: ^PACKED ARRAY [1 ..*] OF 0 .. 0f(16),
      working_storage_seq_p: ^SEQ ( * );

    status.normal := TRUE;

    IF call_block.putn.working_storage_length = 0 THEN
      RETURN;
    IFEND;

    { Build a sequence pointer to the working storage area that contains the data to be stored.

    i#build_adaptable_seq_pointer (#RING (call_block.putn.working_storage_area),
       #SEGMENT (call_block.putn.working_storage_area),
       #OFFSET (call_block.putn.working_storage_area),
       call_block.putn.working_storage_length, 0, working_storage_seq_p);

    { Write the end of partition information, if necessary.

    IF file_information_p^.write_end_of_partition THEN
      disk_write_eop_partition (file_information_p, layer_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      file_information_p^.next_type_of_partition := ai_eop;
    IFEND;
    file_information_p^.write_end_of_partition := TRUE;

    { Build a call block to put the data.

    access_call_block.operation := amc$put_next_req;
    access_call_block.putn.working_storage_area := ^disk_block;
    access_call_block.putn.byte_address := ^access_byte_address;
    access_byte_address := 0;

    { The data must be converted from the working storage area into groups of 60-bits of data stored
    { right-justified into 64-bit groups.  The new record size (which is defined in bytes) is found
    { by adding up how many 64-bit units are needed to fit the 60-bit chunks.

    new_record_size := ((((call_block.putn.working_storage_length * 8) + 59) DIV 60) * 64) DIV 8;
    PUSH conversion_area_p: [[REP new_record_size OF cell]];
    RESET conversion_area_p;
    NEXT working_storage_data_p: [1 .. (call_block.putn.working_storage_length * 2)] IN working_storage_seq_p;
    NEXT conversion_data_p: [1 .. (new_record_size * 2)] IN conversion_area_p;
    working_storage_data_index := 1;
    conversion_data_index := 1;
    half_byte_index := 0;
    WHILE (working_storage_data_index <= (call_block.putn.working_storage_length * 2)) DO
      CASE half_byte_index OF
      = 0 =
        conversion_data_p^ [conversion_data_index] := 0;
      ELSE
        conversion_data_p^ [conversion_data_index] := working_storage_data_p^ [working_storage_data_index];
        working_storage_data_index := working_storage_data_index + 1;
      CASEND;
      conversion_data_index := conversion_data_index + 1;
      half_byte_index := (half_byte_index + 1) MOD 16;
    WHILEND;
    FOR working_storage_data_index := conversion_data_index TO (new_record_size * 2) DO
      conversion_data_p^ [working_storage_data_index] := 0;
    FOREND;

    { Move the data from the conversion area to the file.

    RESET conversion_area_p;
    WHILE new_record_size > 0 DO
      IF new_record_size > disk_block_size THEN
        block_size := disk_block_size;
      ELSE
        block_size := new_record_size;
      IFEND;
      new_record_size := new_record_size - block_size;
      access_call_block.putn.working_storage_length := block_size;
      NEXT data_block_p: [[REP block_size OF cell]] IN conversion_area_p;
      i#move (data_block_p, ^disk_block, block_size);
      amp$access_method (file_information_p^.file_identifier, access_call_block, layer_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    WHILEND;

  PROCEND disk_put_next;
?? TITLE := 'disk_write_eop_partition', EJECT ??

{  PURPOSE:
{    This procedure writes the end of partition information at the end of each record.

  PROCEDURE disk_write_eop_partition
    (    file_information_p: ^disk_fap_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      access_byte_address: amt$file_byte_address,
      access_call_block: amt$call_block,
      type_of_partition: integer;

    status.normal := TRUE;
    IF file_information_p^.next_type_of_partition <> ai_eop THEN
      access_call_block.operation := amc$put_next_req;
      access_call_block.putn.working_storage_area := ^type_of_partition;
      access_call_block.putn.working_storage_length := 0;
      access_call_block.putn.byte_address := ^access_byte_address;
      access_byte_address := 0;
      amp$access_method (file_information_p^.file_identifier, access_call_block, layer_number, status);
      IF NOT status.normal THEN
       RETURN;
      IFEND;
    IFEND;

    access_call_block.operation := amc$write_end_partition_req;
    amp$access_method (file_information_p^.file_identifier, access_call_block, layer_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    access_call_block.operation := amc$put_next_req;
    access_call_block.putn.working_storage_area := ^type_of_partition;
    access_call_block.putn.working_storage_length := #SIZE(type_of_partition);
    access_call_block.putn.byte_address := ^access_byte_address;
    access_byte_address := 0;
    type_of_partition := file_information_p^.next_type_of_partition;
    amp$access_method (file_information_p^.file_identifier, access_call_block, layer_number, status);

  PROCEND disk_write_eop_partition;
?? TITLE := 'i_tape_close_file', EJECT ??

{ PURPOSE:
{   This procedure closes the file that has the I tape FAP attached.

  PROCEDURE i_tape_close_file
    (    call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR file_information_p: ^i_tape_fap_block;
     VAR status: ost$status);

    VAR
      file_identifier: amt$file_identifier;

    status.normal := TRUE;

   /close_i_tape/
    BEGIN
      IF file_information_p^.write_to_file THEN
        IF file_information_p^.data_in_block <> 0 THEN
          i_tape_put_block (file_information_p, layer_number, status);
          IF NOT status.normal THEN
            EXIT /close_i_tape/;
          IFEND;
        IFEND;

        tape_finish_file (file_information_p^.file_identifier, file_information_p^.block_number,
              layer_number, status);
        IF NOT status.normal THEN
          EXIT /close_i_tape/;
        IFEND;
      IFEND;
    END /close_i_tape/;

    file_identifier := file_information_p^.file_identifier;
    FREE file_information_p;
    amp$access_method (file_identifier, call_block, layer_number, status);

  PROCEND i_tape_close_file;
?? TITLE := 'i_tape_get_block', EJECT ??

{ PURPOSE:
{   This procedure retrieves a block from an I tape.

  PROCEDURE i_tape_get_block
    (    file_information_p: ^i_tape_fap_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      access_byte_address: amt$file_byte_address,
      access_call_block: amt$call_block,
      access_file_position: amt$file_position,
      access_transfer_count: amt$transfer_count,
      padded_trailer: padded_trailer_record,
      trailer: tape_trailer;

    status.normal := TRUE;
    access_call_block.operation := amc$get_next_req;
    access_call_block.getn.working_storage_area := ^file_information_p^.tape_block;
    access_call_block.getn.working_storage_length := #SIZE (file_information_p^.tape_block);
    access_call_block.getn.transfer_count := ^access_transfer_count;
    access_call_block.getn.byte_address := ^access_byte_address;
    access_call_block.getn.file_position := ^access_file_position;
    amp$access_method (file_information_p^.file_identifier, access_call_block, layer_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (access_transfer_count = 0) AND (access_file_position = amc$eoi) THEN
      file_information_p^.file_position := amc$eoi;
      RETURN;
    IFEND;

    IF (access_transfer_count * 8) MOD 12 = 0 THEN
      i#move (^file_information_p^.tape_block [access_transfer_count - 5], ^trailer, 6);
    ELSE
      i#move (^file_information_p^.tape_block [access_transfer_count - 6], ^padded_trailer, 7);
      trailer := padded_trailer.trailer;
      padded_trailer.trailer.block_length := 0;
    IFEND;

    IF access_transfer_count <> (((trailer.block_length * 12) + 7) DIV 8) THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$tape_damaged, '', status);
      RETURN;
    IFEND;
    IF trailer.block_number <> (file_information_p^.block_number + 1) THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$tape_damaged, '', status);
      RETURN;
    IFEND;

    file_information_p^.block_number := trailer.block_number;
    file_information_p^.data_in_block := access_transfer_count - 6;
    IF access_file_position = amc$eoi THEN
      file_information_p^.file_position := amc$eoi;
    ELSEIF trailer.block_level = 15 THEN
      file_information_p^.file_position := amc$eop;
    ELSEIF file_information_p^.data_in_block < tape_block_size THEN
      file_information_p^.file_position := amc$eor;
    ELSE
      file_information_p^.file_position := amc$mid_record;
    IFEND;
    file_information_p^.tape_block_counter := 1;

  PROCEND i_tape_get_block;
?? TITLE := 'i_tape_get_next', EJECT ??

{ PURPOSE:
{   This procedure retrieves a record from an I tape.

  PROCEDURE i_tape_get_next
    (    file_information_p: ^i_tape_fap_block;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      data_block_p: ^SEQ ( * ),
      file_position_p: ^amt$file_position,
      length: integer,
      transfer_count_p: ^amt$transfer_count,
      working_storage_p: ^SEQ ( * );

    status.normal := TRUE;
    file_position_p := call_block.getn.file_position;
    transfer_count_p := call_block.getn.transfer_count;
    transfer_count_p^ := 0;
    i#build_adaptable_seq_pointer (#RING (call_block.getn.working_storage_area),
          #SEGMENT (call_block.getn.working_storage_area), #OFFSET (call_block.getn.working_storage_area),
          call_block.getn.working_storage_length, 0, working_storage_p);

    WHILE file_information_p^.file_position <> amc$eor DO
      i_tape_get_block (file_information_p, layer_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF file_information_p^.file_position = amc$eoi THEN
        file_position_p^ := file_information_p^.file_position;
        RETURN;
      IFEND;
    WHILEND;
    file_information_p^.data_in_block := 0;

    WHILE call_block.getn.working_storage_length > transfer_count_p^ DO
      WHILE file_information_p^.data_in_block = 0 DO
        i_tape_get_block (file_information_p, layer_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF (file_information_p^.data_in_block = 0) AND
              (file_information_p^.file_position <> amc$mid_record) THEN
          file_position_p^ := file_information_p^.file_position;
          RETURN;
        IFEND;
      WHILEND;
      IF (call_block.getn.working_storage_length - transfer_count_p^) < file_information_p^.data_in_block THEN
        length := call_block.getn.working_storage_length - transfer_count_p^;
      ELSE
        length := file_information_p^.data_in_block;
      IFEND;
      NEXT data_block_p: [[REP length OF cell]] IN working_storage_p;
      i#move (^file_information_p^.tape_block [file_information_p^.tape_block_counter], data_block_p, length);
      file_information_p^.tape_block_counter := file_information_p^.tape_block_counter + length;
      file_information_p^.data_in_block := file_information_p^.data_in_block - length;
      transfer_count_p^ := transfer_count_p^ + length;
      IF file_information_p^.file_position = amc$eor THEN
        file_position_p^ := file_information_p^.file_position;
        RETURN;
      IFEND;
    WHILEND;

    file_position_p^ := file_information_p^.file_position;

  PROCEND i_tape_get_next;
?? TITLE := 'i_tape_get_partial', EJECT ??

{ PURPOSE:
{   This procedure retrieves a partial record from an I tape.

  PROCEDURE i_tape_get_partial
    (    file_information_p: ^i_tape_fap_block;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      data_block_p: ^SEQ ( * ),
      file_position_p: ^amt$file_position,
      length: integer,
      record_length_p: ^amt$max_record_length,
      skip_option: amt$skip_option,
      transfer_count_p: ^amt$transfer_count,
      working_storage_p: ^SEQ ( * );

    status.normal := TRUE;
    file_position_p := call_block.getp.file_position;
    record_length_p := call_block.getp.record_length;
    skip_option := call_block.getp.skip_option;
    transfer_count_p := call_block.getp.transfer_count;
    transfer_count_p^ := 0;
    i#build_adaptable_seq_pointer (#RING (call_block.getp.working_storage_area),
          #SEGMENT (call_block.getp.working_storage_area), #OFFSET (call_block.getp.working_storage_area),
          call_block.getp.working_storage_length, 0, working_storage_p);

    IF skip_option = amc$skip_to_eor THEN
      WHILE file_information_p^.file_position <> amc$eor DO
        i_tape_get_block (file_information_p, layer_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF file_information_p^.file_position = amc$eoi THEN
          file_position_p^ := file_information_p^.file_position;
          RETURN;
        IFEND;
      WHILEND;
      file_information_p^.data_in_block := 0;
      file_information_p^.record_length := 0;
    IFEND;

   /get_data_loop/
    WHILE call_block.getp.working_storage_length > transfer_count_p^ DO
      WHILE file_information_p^.data_in_block = 0 DO
        i_tape_get_block (file_information_p, layer_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF (file_information_p^.data_in_block = 0) AND
              (file_information_p^.file_position <> amc$mid_record) THEN
          EXIT /get_data_loop/;
        IFEND;
      WHILEND;
      IF (call_block.getp.working_storage_length - transfer_count_p^) < file_information_p^.data_in_block THEN
        length := call_block.getp.working_storage_length - transfer_count_p^;
      ELSE
        length := file_information_p^.data_in_block;
      IFEND;
      NEXT data_block_p: [[REP length OF cell]] IN working_storage_p;
      i#move (^file_information_p^.tape_block [file_information_p^.tape_block_counter], data_block_p, length);
      file_information_p^.tape_block_counter := file_information_p^.tape_block_counter + length;
      file_information_p^.data_in_block := file_information_p^.data_in_block - length;
      transfer_count_p^ := transfer_count_p^ + length;
      IF file_information_p^.file_position = amc$eor THEN
        EXIT /get_data_loop/;
      IFEND;
    WHILEND /get_data_loop/;

    file_information_p^.record_length := file_information_p^.record_length + transfer_count_p^;
    record_length_p^ := file_information_p^.record_length;
    file_position_p^ := file_information_p^.file_position;

  PROCEND i_tape_get_partial;
?? TITLE := 'i_tape_open_file', EJECT ??

{ PURPOSE:
{   This procedure opens an I tape file.

  PROCEDURE i_tape_open_file
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      file_information_p: ^i_tape_fap_block;

    status.normal := TRUE;
    amp$access_method (file_identifier, call_block, layer_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE file_information_p;
    amp$store_fap_pointer (file_identifier, layer_number, file_information_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_information_p^.file_identifier := file_identifier;
    file_information_p^.tape_block_counter := 1;
    file_information_p^.data_in_block := 0;
    file_information_p^.block_number := -1;
    file_information_p^.record_length := 0;
    file_information_p^.file_position := amc$eor;
    file_information_p^.write_to_file := FALSE;

  PROCEND i_tape_open_file;
?? TITLE := 'i_tape_put_block', EJECT ??

{ PURPOSE:
{   This procedure puts a block of data on the I tape.

  PROCEDURE i_tape_put_block
    (    file_information_p: ^i_tape_fap_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      access_byte_address: amt$file_byte_address,
      access_call_block: amt$call_block,
      data_length: integer,
      padding_needed: integer,
      padded_trailer: padded_trailer_record,
      trailer: tape_trailer;

    status.normal := TRUE;
    access_call_block.operation := amc$put_next_req;
    access_call_block.putn.working_storage_area := ^file_information_p^.tape_block;
    access_call_block.putn.byte_address := ^access_byte_address;

    data_length := file_information_p^.data_in_block;
    padding_needed := 60 - ((data_length * 8) MOD 60);
    IF padding_needed < 56 THEN
      data_length := data_length + (padding_needed DIV 8);
    IFEND;

    IF ((data_length + 6) * 8 ) MOD 12 = 0 THEN
      trailer.block_length := ((data_length + 6) * 8) DIV 12;
      trailer.block_number := file_information_p^.block_number + 1;
      trailer.block_level := 0;
      i#move (^trailer, ^file_information_p^.tape_block [data_length + 1], 6);
    ELSE
      IF padding_needed < 56 THEN
        data_length := data_length + 1;
      ELSE
        i#move (^file_information_p^.tape_block [data_length], ^padded_trailer, 1);
      IFEND;
      padded_trailer.trailer.block_length := ((data_length + 6) * 8) DIV 12;
      padded_trailer.trailer.block_number := file_information_p^.block_number + 1;
      padded_trailer.trailer.block_level := 0;
      i#move (^padded_trailer, ^file_information_p^.tape_block [data_length], 7);
    IFEND;

    access_call_block.putn.working_storage_length := data_length + 6;
    amp$access_method (file_information_p^.file_identifier, access_call_block, layer_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_information_p^.block_number := file_information_p^.block_number + 1;
    file_information_p^.data_in_block := 0;
    file_information_p^.tape_block_counter := 1;

  PROCEND i_tape_put_block;
?? TITLE := 'i_tape_put_next', EJECT ??

{ PURPOSE:
{   This procedure puts the next record on an I tape.

  PROCEDURE i_tape_put_next
    (    file_information_p: ^i_tape_fap_block;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      data_block_p: ^SEQ ( * ),
      data_length: integer,
      length: integer,
      working_storage_p: ^SEQ ( * );

    status.normal := TRUE;
    i#build_adaptable_seq_pointer (#RING (call_block.putn.working_storage_area),
          #SEGMENT (call_block.putn.working_storage_area), #OFFSET (call_block.putn.working_storage_area),
          call_block.putn.working_storage_length, 0, working_storage_p);

    IF file_information_p^.file_position <> amc$eor THEN
      i_tape_put_block (file_information_p, layer_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      file_information_p^.file_position := amc$mid_record;
    IFEND;
    data_length := call_block.putn.working_storage_length;
    WHILE data_length <> 0 DO
      IF file_information_p^.data_in_block = tape_block_size THEN
        i_tape_put_block (file_information_p, layer_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        file_information_p^.file_position := amc$mid_record;
      IFEND;
      IF data_length <= (tape_block_size - file_information_p^.data_in_block) THEN
        length := data_length;
      ELSE
        length := tape_block_size - file_information_p^.data_in_block;
      IFEND;
      NEXT data_block_p: [[REP length OF cell]] IN working_storage_p;
      i#move (data_block_p, ^file_information_p^.tape_block [file_information_p^.tape_block_counter], length);
      file_information_p^.tape_block_counter := file_information_p^.tape_block_counter + length;
      file_information_p^.data_in_block := file_information_p^.data_in_block + length;
      data_length := data_length - length;
    WHILEND;

    i_tape_put_block (file_information_p, layer_number, status);
    file_information_p^.file_position := amc$eor;

  PROCEND i_tape_put_next;
?? TITLE := 'i_tape_put_partial', EJECT ??

{ PURPOSE:
{   This procedure puts a partial record on an I tape.

  PROCEDURE i_tape_put_partial
    (    file_information_p: ^i_tape_fap_block;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      data_block_p: ^SEQ ( * ),
      data_length: integer,
      length: integer,
      working_storage_p: ^SEQ ( * );

    status.normal := TRUE;
    i#build_adaptable_seq_pointer (#RING (call_block.putp.working_storage_area),
          #SEGMENT (call_block.putp.working_storage_area), #OFFSET (call_block.putp.working_storage_area),
          call_block.putp.working_storage_length, 0, working_storage_p);

    IF (call_block.putp.term_option = amc$continue) AND (file_information_p^.file_position = amc$eor) THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$write_at_eor, '', status);
      RETURN;
    IFEND;
    IF (call_block.putp.term_option = amc$start) AND (file_information_p^.file_position <> amc$eor) THEN
      i_tape_put_block (file_information_p, layer_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    IF call_block.putp.term_option = amc$start THEN
      file_information_p^.file_position := amc$mid_record;
    IFEND;

    data_length := call_block.putp.working_storage_length;
    WHILE data_length <> 0 DO
      IF file_information_p^.data_in_block = tape_block_size THEN
        i_tape_put_block (file_information_p, layer_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        file_information_p^.file_position := amc$mid_record;
      IFEND;
      IF data_length <= (tape_block_size - file_information_p^.data_in_block) THEN
        length := data_length;
      ELSE
        length := tape_block_size - file_information_p^.data_in_block;
      IFEND;
      NEXT data_block_p: [[REP length OF cell]] IN working_storage_p;
      i#move (data_block_p, ^file_information_p^.tape_block [file_information_p^.tape_block_counter], length);
      file_information_p^.tape_block_counter := file_information_p^.tape_block_counter + length;
      file_information_p^.data_in_block := file_information_p^.data_in_block + length;
      data_length := data_length - length;
    WHILEND;

    IF call_block.putp.term_option = amc$terminate THEN
      i_tape_put_block (file_information_p, layer_number, status);
      file_information_p^.file_position := amc$eor;
    IFEND;

  PROCEND i_tape_put_partial;
?? TITLE := 'i_tape_write_eof', EJECT ??

{ PURPOSE:
{   This procedure writes an EOF mark on the I tape.

  PROCEDURE i_tape_write_eof
    (    file_information_p: ^i_tape_fap_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      access_byte_address: amt$file_byte_address,
      access_call_block: amt$call_block,
      trailer: tape_trailer;

    status.normal := TRUE;
    IF file_information_p^.data_in_block <> 0 THEN
      i_tape_put_block (file_information_p, layer_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    access_call_block.operation := amc$put_next_req;
    access_call_block.putn.working_storage_area := ^trailer;
    access_call_block.putn.working_storage_length := #SIZE (trailer);
    access_call_block.putn.byte_address := ^access_byte_address;
    trailer.block_length := 4;
    trailer.block_number := file_information_p^.block_number + 1;
    trailer.block_level := 15;
    file_information_p^.block_number := file_information_p^.block_number + 1;
    amp$access_method (file_information_p^.file_identifier, access_call_block, layer_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_information_p^.file_position := amc$eop;

  PROCEND i_tape_write_eof;
?? TITLE := 'si_tape_close_file', EJECT ??

{  PURPOSE:
{    This procedure closes the file that has the SI tape FAP attached.

  PROCEDURE si_tape_close_file
    (    call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR file_information_p: ^si_tape_fap_block;
     VAR status: ost$status);

    VAR
      file_identifier: amt$file_identifier;

    status.normal := TRUE;

   /close_si_tape/
    BEGIN
      IF file_information_p^.write_to_file THEN

        { Write the EOF mark and the tape marks to the file.

        tape_finish_file (file_information_p^.file_identifier,
              file_information_p^.block_number, layer_number, status);
        IF NOT status.normal THEN
          EXIT /close_si_tape/;
        IFEND;
      IFEND;
    END /close_si_tape/;

    file_identifier := file_information_p^.file_identifier;
    FREE file_information_p;
    amp$access_method (file_identifier, call_block, layer_number, status);

  PROCEND si_tape_close_file;
?? TITLE := 'si_tape_get_next', EJECT ??

{  PURPOSE:
{    This procedure retrieves a record of data from the file that has a SI fap attached.

  PROCEDURE si_tape_get_next
    (    file_information_p: ^si_tape_fap_block;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      access_byte_address: amt$file_byte_address,
      access_call_block: amt$call_block,
      access_file_position: amt$file_position,
      data_block_seq_p: ^SEQ ( * ),
      data_size: amt$transfer_count,
      file_position_p: ^amt$file_position,
      padded_trailer: padded_trailer_record,
      tape_block: ARRAY [1 .. (tape_block_size + 6)] OF char,
      total_data_size_p: ^amt$transfer_count,
      trailer: tape_trailer,
      trailer_found: boolean,
      working_storage_seq_p: ^SEQ ( * );

    status.normal := TRUE;

    { Build a sequence pointer to the working storage area that will hold the data retrieved.

    file_position_p := call_block.getn.file_position;
    total_data_size_p := call_block.getn.transfer_count;
    total_data_size_p^ := 0;
    i#build_adaptable_seq_pointer (#RING (call_block.getn.working_storage_area),
          #SEGMENT (call_block.getn.working_storage_area), #OFFSET (call_block.getn.working_storage_area),
          call_block.getn.working_storage_length, 0, working_storage_seq_p);

    { Build the call block that will remove the data from the SI tape.  The data is removed from the tape
    { in chunks of size "tape_block_size".  The last chunk of data for the record has a tape trailer.

    access_call_block.operation := amc$get_next_req;
    access_call_block.getn.working_storage_area := ^tape_block;
    access_call_block.getn.working_storage_length := #SIZE (tape_block);
    access_call_block.getn.transfer_count := ^data_size;
    access_call_block.getn.byte_address := ^access_byte_address;
    access_call_block.getn.file_position := ^access_file_position;

    trailer_found := FALSE;
    REPEAT

      { Retrieve chunks of data until an "EOI" is reached.

      amp$access_method (file_information_p^.file_identifier, access_call_block, layer_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (data_size = 0) AND (access_file_position = amc$eoi) THEN
        file_position_p^ := amc$eoi;
        RETURN;
      IFEND;

      { If the data size of the tape chunk is less then the tape block size then the tape chunk is the last
      { chunk of the record and it has a trailer.  It may possibly contain only a trailer.

      IF data_size < tape_block_size THEN
        trailer_found := TRUE;
        IF (data_size MOD 3) = 0 THEN

          { If the data read from the tape is divisible by 3, then the data in the tape chunk contains an
          { even number of 60-bit words.  The data is written to the tape in 3 groups of 8 bits and an even
          { number of 60-bit words contains a number of 8-bit units that is divisible by 3.  This type of
          { tape chunk contains a normal 48-bit tape trailer following in the data.

          i#move (^tape_block [data_size - (#SIZE (tape_trailer) - 1)], ^trailer, #SIZE (tape_trailer));
        ELSE

          { If the data read from the tape is not divisible by 3, then there will be a remainder of 2.  This
          { occurs when data in the tape chunk contains an odd number of 60-bit words.  An odd number of
          { 60-bit words and a 48-bit tape trailer do not break down evenly into 3 groups of 8 bits.  In
          { this case, all possible 3 groups of 8 bit units are written to the tape and the leftover is
          { written into 2 groups of 8 bit units.  The last four bits of the last group is invalid data and
          { will be ignored.  Because this structure does not fit on a byte boundary a special trailer
          { structure is used to remove the trailer from the data.  The first four bits of this special
          { trailer is actually the last four bits of the valid data.

          i#move (^tape_block [data_size - (#SIZE (padded_trailer_record) - 1)],
                ^padded_trailer, #SIZE (padded_trailer_record));
          trailer := padded_trailer.trailer;
          padded_trailer.trailer.block_length := 0;
        IFEND;

        { Remove the size of the trailer from the data size.

        data_size := data_size - #SIZE (tape_trailer);
      ELSE
        file_information_p^.block_number := file_information_p^.block_number + 1;
      IFEND;

      { Move the data from the tape chunk to the working storage area.

      IF data_size > 0 THEN
        NEXT data_block_seq_p: [[REP data_size OF cell]] IN working_storage_seq_p;
        i#move (^tape_block, data_block_seq_p, data_size);
        total_data_size_p^ := total_data_size_p^ + data_size;
      IFEND;
    UNTIL trailer_found;

    { Check to see if the trailer is damaged.

    IF (data_size + #SIZE (tape_trailer)) <> (((trailer.block_length * 12) + 7) DIV 8) THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$tape_damaged, '', status);
      RETURN;
    IFEND;
    IF trailer.block_number <> (file_information_p^.block_number + 1) THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$tape_damaged, '', status);
      RETURN;
    IFEND;

    { Retrieve the file position from the trailer.

    IF access_file_position = amc$eoi THEN
      file_position_p^ := amc$eoi;
    ELSE
      file_information_p^.block_number := trailer.block_number;
      IF trailer.block_level = tape_trailer_eof THEN
        file_position_p^ := amc$eop;
      ELSEIF trailer.block_level = tape_trailer_eor THEN
        file_position_p^ := amc$eor;
      IFEND;
    IFEND;

  PROCEND si_tape_get_next;
?? TITLE := 'si_tape_open_file', EJECT ??

{  PURPOSE:
{    This procedure opens the file that has the SI tape fap attached.  It also creates a pointer
{    associated with the FAP to save file information that is used for all the calls to access the file.

  PROCEDURE si_tape_open_file
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      file_information_p: ^si_tape_fap_block;

    status.normal := TRUE;

    { Open the file.

    amp$access_method (file_identifier, call_block, layer_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Save a fap pointer that contains some file information.

    ALLOCATE file_information_p;
    file_information_p^.file_identifier := file_identifier;
    file_information_p^.block_number := -1;
    file_information_p^.write_to_file := FALSE;

    amp$store_fap_pointer (file_identifier, layer_number, file_information_p, status);

  PROCEND si_tape_open_file;
?? TITLE := 'si_tape_put_next', EJECT ??

{  PURPOSE:
{    This procedure puts a record of data onto the file that has a SI fap attached.

  PROCEDURE si_tape_put_next
    (    file_information_p: ^si_tape_fap_block;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      access_byte_address: amt$file_byte_address,
      access_call_block: amt$call_block,
      data_block_seq_p: ^SEQ ( * ),
      data_size: integer,
      data_size_to_put: integer,
      extra_data: integer,
      padded_trailer: padded_trailer_record,
      tape_block: ARRAY [1 .. tape_block_size + 6] OF char,
      trailer: tape_trailer,
      trailer_written: boolean,
      working_storage_seq_p: ^SEQ ( * );

    status.normal := TRUE;

    { Build a sequence pointer to the working storage area that contains the data to be stored.

    i#build_adaptable_seq_pointer (#RING (call_block.putn.working_storage_area),
          #SEGMENT (call_block.putn.working_storage_area), #OFFSET (call_block.putn.working_storage_area),
          call_block.putn.working_storage_length, 0, working_storage_seq_p);

    { Build a call block to put the data.

    access_call_block.operation := amc$put_next_req;
    access_call_block.putn.working_storage_area := ^tape_block;
    access_call_block.putn.byte_address := ^access_byte_address;

    data_size := call_block.putn.working_storage_length;

    { The data is put into tape chunks with the last chunk containing a trailer.  The last chunk
    { may possibly contain only a trailer.

    REPEAT

      { Find out how much data will be stored in this tape chunk.

      IF data_size >= tape_block_size THEN
        data_size_to_put := tape_block_size;
        trailer_written := FALSE;
      ELSE
        data_size_to_put := data_size;
        trailer_written := TRUE;
      IFEND;

      { Move the data from the working storage area to the tape chunk.

      IF data_size_to_put > 0 THEN
        NEXT data_block_seq_p: [[REP data_size_to_put OF cell]] IN working_storage_seq_p;
        i#move (data_block_seq_p, ^tape_block, data_size_to_put);
      IFEND;

      IF NOT trailer_written THEN
        access_call_block.putn.working_storage_length := data_size_to_put;
        data_size := data_size - data_size_to_put;
      ELSE
        access_call_block.putn.working_storage_length := data_size_to_put + #SIZE (tape_trailer);

        { The block length in the trailer is defined to be in 12-bit units (a NOS byte).

        trailer.block_length := ((data_size_to_put + #SIZE (tape_trailer)) * 8) DIV 12;
        trailer.block_number := file_information_p^.block_number + 1;
        trailer.block_level := tape_trailer_eor;

        IF (data_size_to_put + #SIZE (tape_trailer)) MOD 3 = 0 THEN

          { If the data size and the size of the tape trailer is divisible by 3, then the data to be put
          { in the tape chunk contains an even number of 60-bit words.  The data is written to the tape in
          { 3 groups of 8 bits and an even number of 60-bit words contains a number of 8-bit units that is
          { divisible by 3.  This type of tape chunk contains a normal 48-bit tape trailer following the data.

          i#move (^trailer, ^tape_block [data_size_to_put + 1], #SIZE (tape_trailer));
        ELSE

          { If the data size and the tape trailer size is not divisible by 3, then there will be a remainder
          { of 2.  This occurs when data in the tape chunk contains an odd number of 60-bit words.  An odd
          { number of 60-bit words and a 48-bit tape trailer do not break down evenly into 3 groups of 8 bits.
          { In this case, all possible 3 groups of 8 bit units are written to the tape and the leftover is
          { written into 2 groups of 8 bit units.  The last four bits of the last group is invalid data and
          { should be ignored.  Because this structure does not fit on a byte boundary a special trailer
          { structure is used to add the trailer to the data.  The first four bits of this special trailer is
          { actually the last four bits of the valid data so that the tape trailer immediately follows the
          { last 60-bit word.

          i#move (^tape_block [data_size_to_put], ^padded_trailer, 1);
          padded_trailer.trailer := trailer;
          i#move (^padded_trailer, ^tape_block [data_size_to_put], #SIZE (padded_trailer_record));
        IFEND;
      IFEND;

      amp$access_method (file_information_p^.file_identifier, access_call_block, layer_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      file_information_p^.block_number := file_information_p^.block_number + 1;
    UNTIL trailer_written;

  PROCEND si_tape_put_next;
?? TITLE := 'si_tape_write_eof', EJECT ??

{  PURPOSE:
{    This procedure puts an "EOF" mark on the file that has a SI fap attached.

  PROCEDURE si_tape_write_eof
    (    file_information_p: ^si_tape_fap_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      access_byte_address: amt$file_byte_address,
      access_call_block: amt$call_block,
      trailer: tape_trailer;

    status.normal := TRUE;

    { Build the call block that writes the EOF.

    access_call_block.operation := amc$put_next_req;
    access_call_block.putn.working_storage_area := ^trailer;
    access_call_block.putn.working_storage_length := #SIZE (trailer);
    access_call_block.putn.byte_address := ^access_byte_address;

    { The block length in the trailer is defined to be in 12-bit units (a NOS byte).

    trailer.block_length := (#SIZE (tape_trailer) * 8) DIV 12;
    trailer.block_number := file_information_p^.block_number + 1;
    trailer.block_level := tape_trailer_eof;

    file_information_p^.block_number := file_information_p^.block_number + 1;

    amp$access_method (file_information_p^.file_identifier, access_call_block, layer_number, status);

  PROCEND si_tape_write_eof;
?? TITLE := 'tape_finish_file', EJECT ??

{  PURPOSE:
{    This procedure writes some necessary ending information to the file.  The necessary ending
{    information contains a tape mark, EOF data and three tape marks.

  PROCEDURE tape_finish_file
    (    file_identifier: amt$file_identifier;
         block_number: integer;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      access_byte_address: amt$file_byte_address,
      access_call_block: amt$call_block,
      string_length: integer,
      tape_block: ARRAY [1 ..tape_block_size + 6] OF char,
      tape_block_index: 1 .. 80,
      temp_string: string (8);

    status.normal := TRUE;
    access_call_block.operation := amc$write_tape_mark_req;
    amp$access_method (file_identifier, access_call_block, layer_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Write the EOF data to the file.

    tape_block [1] := 'E';
    tape_block [2] := 'O';
    tape_block [3] := 'F';
    tape_block [4] := '1';
    FOR tape_block_index := 5 TO 80 DO
      tape_block [tape_block_index] := ' ';
    FOREND;
    STRINGREP (temp_string, string_length, (1000000 + block_number + 1));
    tape_block [55] := temp_string (3);
    tape_block [56] := temp_string (4);
    tape_block [57] := temp_string (5);
    tape_block [58] := temp_string (6);
    tape_block [59] := temp_string (7);
    tape_block [60] := temp_string (8);
    access_call_block.operation := amc$put_next_req;
    access_call_block.putn.working_storage_area := ^tape_block;
    access_call_block.putn.working_storage_length := 80;
    access_call_block.putn.byte_address := ^access_byte_address;
    amp$access_method (file_identifier, access_call_block, layer_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Write three tape marks to the file.

    FOR tape_block_index := 1 TO 3 DO
      access_call_block.operation := amc$write_tape_mark_req;
      amp$access_method (file_identifier, access_call_block, layer_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND tape_finish_file;
?? TITLE := 'dsp$mrf_disk_format', EJECT ??

{  PURPOSE:
{    This procedure is the FAP used to access disk files that were retrieved from NOS using the
{    command 'REPLACE_MULTI_RECORD_FILE' or disk files that will be sent to NOS using the command
{    'GET_MULTI_RECORD_FILE'.

  PROCEDURE [XDCL, #GATE] dsp$mrf_disk_format
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      file_information_p: ^disk_fap_block;

    status.normal := TRUE;
    IF call_block.operation <> amc$open_req THEN
      amp$fetch_fap_pointer (file_identifier, layer_number, file_information_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    CASE call_block.operation OF
    = amc$close_req =
      disk_close_file (call_block, layer_number, file_information_p, status);
    = amc$get_next_req =
      disk_get_next (file_information_p, call_block, layer_number, status);
    = amc$open_req =
      disk_open_file (file_identifier, call_block, layer_number, status);
    = amc$put_next_req =
      file_information_p^.write_to_file := TRUE;
      disk_put_next (file_information_p, call_block, layer_number, status);
    = amc$rewind_req =
      amp$access_method (file_information_p^.file_identifier, call_block, layer_number, status);
    = amc$write_end_partition_req =
      disk_write_eop_partition (file_information_p, layer_number, status);
      file_information_p^.next_type_of_partition := ai_end_of_file;
    ELSE
      osp$set_status_abnormal (dsc$display_processor_id, dse$command_not_supported, '', status);
    CASEND;

  PROCEND dsp$mrf_disk_format;
?? TITLE := 'dsp$i_tape_format', EJECT ??

{  PURPOSE:
{    This procedure is the FAP used to read or write tapes in I format.

  PROCEDURE [XDCL, #GATE] dsp$i_tape_format
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      file_information_p: ^i_tape_fap_block;

    status.normal := TRUE;
    IF call_block.operation = amc$open_req THEN
      i_tape_open_file (file_identifier, call_block, layer_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    amp$fetch_fap_pointer (file_identifier, layer_number, file_information_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE call_block.operation OF
    = amc$open_req, amc$close_req =
      ;
    = amc$get_next_req =
      i_tape_get_next (file_information_p, call_block, layer_number, status);
    = amc$get_partial_req =
      i_tape_get_partial (file_information_p, call_block, layer_number, status);
    = amc$put_next_req =
      file_information_p^.write_to_file := TRUE;
      i_tape_put_next (file_information_p, call_block, layer_number, status);
    = amc$put_partial_req =
      file_information_p^.write_to_file := TRUE;
      i_tape_put_partial (file_information_p, call_block, layer_number, status);
    = amc$write_end_partition_req =
      file_information_p^.write_to_file := TRUE;
      i_tape_write_eof (file_information_p, layer_number, status);
    = amc$rewind_req =
      amp$access_method (file_identifier, call_block, layer_number, status);
    ELSE
      osp$set_status_abnormal (dsc$display_processor_id, dse$command_not_supported,
         '', status);
    CASEND;

    IF call_block.operation = amc$close_req THEN
      i_tape_close_file (call_block, layer_number, file_information_p, status);
    IFEND;

  PROCEND dsp$i_tape_format;
?? TITLE := 'dsp$si_tape_format', EJECT ??

{  PURPOSE:
{    This procedure is the FAP used to read or write tapes in SI format.

  PROCEDURE [XDCL, #GATE] dsp$si_tape_format
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      file_information_p: ^si_tape_fap_block;

    status.normal := TRUE;

    IF call_block.operation <> amc$open_req THEN
      amp$fetch_fap_pointer (file_identifier, layer_number, file_information_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    CASE call_block.operation OF
    = amc$close_req =
      si_tape_close_file (call_block, layer_number, file_information_p, status);
    = amc$get_next_req =
      si_tape_get_next (file_information_p, call_block, layer_number, status);
    = amc$open_req =
      si_tape_open_file (file_identifier, call_block, layer_number, status);
    = amc$put_next_req =
      file_information_p^.write_to_file := TRUE;
      si_tape_put_next (file_information_p, call_block, layer_number, status);
    = amc$rewind_req =
      amp$access_method (file_information_p^.file_identifier, call_block, layer_number, status);
    = amc$write_end_partition_req =
      file_information_p^.write_to_file := TRUE;
      si_tape_write_eof (file_information_p, layer_number, status);
    ELSE
      osp$set_status_abnormal (dsc$display_processor_id, dse$command_not_supported, '', status);
    CASEND;

  PROCEND dsp$si_tape_format;
MODEND dsm$deadstart_faps;
*DECK DECK=DSM$DEADSTART_FILE_MANAGEMENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Deadstart File Management' ??
MODULE dsm$deadstart_file_management;

{ PURPOSE:
{   This module contains the interfaces that manage device files for the
{   deadstart process.  The following files are currently being managed.
{     1. The image file that is written by the VCB program.
{     2. A primary copy of the NOS/VE deadstart file, saved after deadstart.
{     3. A secondary/upgrade copy of the deadstart file, saved after deadstart.
{     4. A spare entry reserved for future use.
{ DESIGN:
{   Each of the files listed above is a pair of device files; one containing
{   the raw data and a partner containing an array of disk MAUs (minimum
{   addressable units) that are used to address the device file.  The starting MAU
{   of the mau file is stored in the device label of the system device.  The mass
{   storage space allocated by the procedures contained herein occur at different
{   times with respect to the state of device management.  The deadstart files are
{   installed after the deadstart is complete and a more fault tolerant approach to
{   errors is taken whereas the image file creation occurs at the front end of the
{   installation deadstart and errors are fatal.
{
{   Following is a picture of the two device files and their relationship to each
{   other.  Each MAU of the data device file contains either a deadstart file or
{   the image file.  Each MAU of the mau device file contains a header followed by
{   a list of allocation units of the data device file.  The mau file is the map
{   of the data device file, it shows where and the order of the data in the data
{   device file.  The header in the mau file contains information necessary to perform
{   IO efficiently and the allocation unit of the next MAU in the mau file.  This
{   allows the mau file to exceed one allocation unit.  The mau file, by its nature
{   and content, is a much smaller file than the data device file.
{
{      Data device file                               Mau device file
{     __________________                             __________________
{     |                |                             |             ---|---:
{     |  MAU - 1       |                             |  MAU - 1       |   :
{     |                |                             |                |   :
{     |----------------|                             |----------------|   :
{     |                |                             |            <---|---:
{     |  MAU - 2       |                             |  MAU - 2       |
{     |                |                             |                |
{     |----------------|                             |----------------|
{     |                |                             |                |
{     |  MAU - 3       |                            //\\             //\\
{     |                |                            \\//             \\//
{     |----------------|                             |                |
{     |                |                             |----------------|
{     |                |                             |                |
{     |                |                             |  MAU - n-1     |
{     |                |                             |                |
{     |                |                             ------------------
{
{   //\\             //\\
{   \\//             \\//
{
{     |                |
{     |                |
{     |                |
{     |----------------|
{     |                |
{     |  MAU - n-1     |
{     |                |
{     |                |
{     ------------------


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmc$deadstart_file_alloc_size
*copyc dmt$error_condition_codes
*copyc dmt$mau_list
*copyc dse$estdbs_errors
*copyc dst$image_file
?? POP ??
*copyc dmp$allocate_file_space_r1
*copyc dmp$attach_device_file
*copyc dmp$close_file
*copyc dmp$create_device_file
*copyc dmp$detach_device_file
*copyc dmp$evacuate_active_device_log
*copyc dmp$get_fau_entry
*copyc dmp$get_fmd_by_index
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$open_file
*copyc dmp$open_label
*copyc dmp$set_eoi
*copyc dsp$get_integer_from_rdf
*copyc dsp$system_committed
*copyc gfp$get_locked_fde_p
*copyc gfp$unlock_fde_p
*copyc i#move
*copyc mmp$free_pages
*copyc mmp$write_modified_pages
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$delay
*copyc pmp$zero_out_table
?? EJECT ??
*copyc dmv$null_sfid
*copyc dmv$system_device_information
*copyc osv$page_size
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    c$image_mau_file_name = 'dsc$image_file_mau_list';

  VAR
    current_installed_file_length: amt$file_byte_address,
    system_device_label_sfid: dmt$system_file_id;

?? TITLE := 'attach_or_create_the_mau_file', EJECT ??

{ PURPOSE:
{   This procedure either attaches or creates a MAU file and stores the MAUs for
{   a given file in the MAU file.  It returns the address of the first MAU.

  PROCEDURE attach_or_create_the_mau_file
    (    file_name: ost$name;
         file_mau_count: dmt$mau_count;
         file_mau_list_p: ^dmt$mau_address_list;
         file_transfer_unit_size: dmt$allocation_size;
         mau_file_name: ost$name;
     VAR first_mau: dmt$mau_address_entry;
     VAR status: ost$status);

    VAR
      allocate_pass_count: 0 .. 5,
      block_count: dmt$mau_count,
      block_header_p: ^dmt$mau_list_header,
      block_mau_entry_p: ^dmt$mau_address_entry,
      close_status: ost$status,
      detach_status: ost$status,
      file_mau_index: dmt$mau_count,
      file_segment_pointer: mmt$segment_pointer,
      file_sfid: dmt$system_file_id,
      ignore: boolean,
      ignore_status: ost$status,
      mau_addresses_per_block: dmt$allocation_size,
      mau_count: dmt$allocation_size,
      mau_file_avt_index: dmt$active_volume_table_index,
      mau_file_length: amt$file_byte_address,
      mau_file_mau_count: dmt$mau_count,
      mau_file_mau_list_p: ^dmt$mau_address_list,
      mau_file_transfer_unit_size: dmt$allocation_size,
      physical_file_attributes: ARRAY [1 .. 3] OF dmt$new_device_file_attribute;

    status.normal := TRUE;

    { Attach or create the MAU file.

    mau_addresses_per_block := (file_transfer_unit_size - #SIZE (dmt$mau_list_header)) DIV 8;
    mau_file_length := ((file_mau_count DIV mau_addresses_per_block) + 1) * file_transfer_unit_size;
    dmp$attach_device_file (dmv$system_device_recorded_vsn, mau_file_name, file_sfid, status);
    IF NOT status.normal AND (status.condition = dme$unknown_device_file) THEN
      physical_file_attributes [1].keyword := dmc$clear_space;
      physical_file_attributes [1].required := FALSE;
      physical_file_attributes [2].keyword := dmc$file_limit;
      physical_file_attributes [2].limit := UPPERVALUE (amt$file_limit);
      physical_file_attributes [3].keyword := dmc$requested_allocation_size;
      physical_file_attributes [3].requested_allocation_size := dmc$deadstart_file_alloc_size;
      dmp$create_device_file (mau_file_name, dmv$system_device_recorded_vsn, ^physical_file_attributes,
            mau_file_length, file_sfid, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /attach_mau_file/
    BEGIN
      file_segment_pointer.kind := mmc$sequence_pointer;
      dmp$open_file (file_sfid, 1, 1, mmc$sar_write_extend, mmc$as_sequential,
            file_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /attach_mau_file/;
      IFEND;

    /open_mau_file/
      BEGIN

        {  Extend the mau file if necessary.

        allocate_pass_count := 5;
        REPEAT
          dmp$allocate_file_space_r1 (file_sfid, mau_file_length, 0, 0, osc$nowait, sfc$no_limit, status);
          IF NOT status.normal THEN
            pmp$delay (1000, ignore_status);
          IFEND;
          allocate_pass_count := allocate_pass_count - 1;
        UNTIL status.normal OR (allocate_pass_count = 0);
        IF NOT status.normal THEN
          EXIT /open_mau_file/;
        IFEND;

        { Build the MAU list for the MAU file.

        PUSH mau_file_mau_list_p: [1 .. dmc$max_mau_addresses];
        build_mau_list (file_sfid, mau_file_mau_list_p, mau_file_mau_count,
              mau_file_transfer_unit_size, mau_file_avt_index, status);
        IF NOT status.normal THEN
          EXIT /open_mau_file/;
        IFEND;

        { Store the MAUs for the file in the MAU file.  Each allocation unit of the mau file contains a
        { header followed by the list of allocation units of the device file.  The header contains the
        { allocation unit of the next mau file MAU.

        RESET file_segment_pointer.seq_pointer;
        mau_count := mau_addresses_per_block + 1;
        block_count := 0;
        block_header_p := NIL;

        FOR file_mau_index := 1 TO file_mau_count DO
          IF mau_count > mau_addresses_per_block THEN
            block_count := block_count + 1;
            IF block_header_p <> NIL THEN
              IF block_count <= mau_file_mau_count THEN
                block_header_p^.next_mau_list_address := mau_file_mau_list_p^ [block_count];
              ELSE
                osp$system_error ('Not enough space in MAU file.', NIL);
              IFEND;
            IFEND;
            NEXT block_header_p IN file_segment_pointer.seq_pointer;
            block_header_p^.valid_data := 1;
            block_header_p^.first_mau_of_maufile := mau_file_mau_list_p^ [block_count];
            block_header_p^.dsfile_name := file_name;
            block_header_p^.maufile_name := mau_file_name;
            block_header_p^.block_size := file_transfer_unit_size;
            block_header_p^.total_mau_addresses := file_mau_count;
            block_header_p^.next_mau_list_address := 0;
            mau_count := 1;
          IFEND;
          NEXT block_mau_entry_p IN file_segment_pointer.seq_pointer;
          block_mau_entry_p^ := file_mau_list_p^ [file_mau_index];
          mau_count := mau_count + 1;
        FOREND;

        { Return the first MAU of the mau file.

        first_mau := mau_file_mau_list_p^ [1];

        mmp$write_modified_pages (file_segment_pointer.seq_pointer, mau_file_length, osc$wait, status);
      END /open_mau_file/;
      dmp$close_file (file_segment_pointer.seq_pointer, close_status);

    END /attach_mau_file/;
    dmp$detach_device_file (file_sfid, ignore, ignore, detach_status);
    IF status.normal THEN
      IF NOT close_status.normal THEN
        status := close_status;
      ELSEIF NOT detach_status.normal THEN
        status := detach_status;
      IFEND;
    IFEND;

  PROCEND attach_or_create_the_mau_file;
?? TITLE := 'build_mau_list', EJECT ??

{ PURPOSE:
{   This procedure builds the mau list for the given system file.

  PROCEDURE build_mau_list
    (    system_file_id: dmt$system_file_id;
     VAR mau_list_p: ^dmt$mau_address_list;
     VAR mau_count: dmt$mau_count;
     VAR transfer_unit_size: dmt$allocation_size;
     VAR device_file_avt_index: dmt$active_volume_table_index;
     VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      fau_entry_p: ^dmt$file_allocation_unit,
      disk_file_descriptor_p: ^dmt$disk_file_descriptor,
      file_descriptor_entry_p: gft$locked_file_desc_entry_p,
      file_medium_descriptor_p: ^dmt$file_medium_descriptor,
      maus_per_dau: dmt$maus_per_dau;

    status.normal := TRUE;
    mau_count := 0;
    transfer_unit_size := 0;

    gfp$get_locked_fde_p (system_file_id, file_descriptor_entry_p);
    IF file_descriptor_entry_p = NIL THEN
      osp$set_status_abnormal ('DM', dme$unable_to_locate_fde,
            'Unable to locate FDE in DM file descriptor', status);
      RETURN;
    IFEND;

    dmp$get_disk_file_descriptor_p (file_descriptor_entry_p, disk_file_descriptor_p);

    dmp$get_fmd_by_index (disk_file_descriptor_p, 1, file_medium_descriptor_p);
    device_file_avt_index := file_medium_descriptor_p^.avt_index;
    byte_address := 0;
    transfer_unit_size := file_descriptor_entry_p^.allocation_unit_size;
    WHILE byte_address < disk_file_descriptor_p^.highest_offset_allocated DO
      dmp$get_fau_entry (disk_file_descriptor_p, byte_address, fau_entry_p);
      IF (fau_entry_p <> NIL) AND (fau_entry_p^.state >= dmc$fau_invalid_data) THEN
        dmp$get_fmd_by_index (disk_file_descriptor_p, fau_entry_p^.fmd_index, file_medium_descriptor_p);
        maus_per_dau := file_medium_descriptor_p^.maus_per_dau;
        IF mau_count = UPPERBOUND (mau_list_p^) THEN
          mau_count := 0;
          gfp$unlock_fde_p (file_descriptor_entry_p);
          osp$set_status_abnormal ('DM', dme$maulist_too_small,
                'Maulist too small to represent file in mau units', status);
          RETURN;
        IFEND;
        mau_count := mau_count + 1;
        mau_list_p^ [mau_count] := fau_entry_p^.dau_address * maus_per_dau;
      ELSE
        osp$system_error ('Cannot create mau file', NIL);
      IFEND;
      byte_address := byte_address + transfer_unit_size;
    WHILEND;

    gfp$unlock_fde_p (file_descriptor_entry_p);

    IF mau_count = 0 THEN
      osp$set_status_abnormal ('DM', dme$unable_to_locate_fde,
            'Unable to locate FDE in DM file descriptor', status);
    IFEND;

  PROCEND build_mau_list;
?? TITLE := 'install_file', EJECT ??

{ PURPOSE:
{   This procedure creates a device file and a corresponding file (mau file) that contains the allocation
{   units of the device file.

  PROCEDURE install_file
    (    file_length: amt$file_byte_address;
         current_file_length: amt$file_byte_address;  { Used only if extending the image file.
         file_name: ost$name;
         mau_file_name: ost$name;
     VAR first_mau: dmt$mau_address_entry;
     VAR status: ost$status);


     TYPE
       trick_pointer = record
         case 0 .. 2 of
           = 0 =
             cell_pointer: ^cell,
           = 1 =
             pva: ost$pva,
           = 2 =
             byte_pointer: ^0 .. 0ff(16),
         casend,
       recend;

    VAR
      allocate_pass_count: 0 .. 5,
      byte: 0 .. 0ff(16),
      call_evacuate_device_log: boolean,
      close_status: ost$status,
      detach_status: ost$status,
      device_file_avt_index: dmt$active_volume_table_index,
      device_file_created: boolean,
      device_file_pointer: trick_pointer,
      fde_p: gft$locked_file_desc_entry_p,
      file_mau_count: dmt$mau_count,
      file_mau_list_p: ^dmt$mau_address_list,
      file_segment_pointer: mmt$segment_pointer,
      file_sfid: dmt$system_file_id,
      file_transfer_unit_size: dmt$allocation_size,
      ignore: boolean,
      ignore_status: ost$status,
      physical_file_attributes: ARRAY [1 .. 3] OF dmt$new_device_file_attribute;

    status.normal := TRUE;

    { Attach or create the file.

    device_file_created := FALSE;
    dmp$attach_device_file (dmv$system_device_recorded_vsn, file_name, file_sfid, status);
    IF NOT status.normal AND (status.condition = dme$unknown_device_file) THEN
      physical_file_attributes [1].keyword := dmc$clear_space;
      physical_file_attributes [1].required := FALSE;
      physical_file_attributes [2].keyword := dmc$file_limit;
      physical_file_attributes [2].limit := UPPERVALUE (amt$file_limit);
      physical_file_attributes [3].keyword := dmc$requested_allocation_size;
      physical_file_attributes [3].requested_allocation_size := dmc$max_bytes_per_allocation;
      dmp$create_device_file (file_name, dmv$system_device_recorded_vsn, ^physical_file_attributes,
            file_length, file_sfid, status);
      device_file_created := TRUE;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    call_evacuate_device_log := FALSE;

  /attach_file/
    BEGIN
      file_segment_pointer.kind := mmc$cell_pointer;
      dmp$open_file (file_sfid, 1, 1, mmc$sar_write_extend, mmc$as_sequential,
            file_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /attach_file/;
      IFEND;

    /open_file/
      BEGIN

        { Extend the device file if necessary.

        allocate_pass_count := 5;
        REPEAT
          dmp$allocate_file_space_r1 (file_sfid, file_length, 0, 0, osc$nowait, sfc$no_limit, status);
          IF NOT status.normal THEN
            pmp$delay (1000, ignore_status);
          IFEND;
          allocate_pass_count := allocate_pass_count - 1;
        UNTIL status.normal OR (allocate_pass_count = 0);
        IF NOT status.normal THEN
          EXIT /open_file/;
        IFEND;

        IF NOT device_file_created THEN

          { The device file was extended and not created.  No data moved to file, make explicit calls to
          { device management to set new EOI and touch each page beyond current file length to new file
          { length to initialize all of mass storage space allocated.

          gfp$get_locked_fde_p (file_sfid, fde_p);
          fde_p^.file_limit := file_length;
          fde_p^.eoi_byte_address := file_length;
          gfp$unlock_fde_p (fde_p);

          { Write each page of file extension, free them and read them back in to verify no IO errors.

          device_file_pointer.cell_pointer := file_segment_pointer.cell_pointer;
          device_file_pointer.pva.offset := current_file_length;
          pmp$zero_out_table (device_file_pointer.cell_pointer, (file_length - current_file_length));
          mmp$write_modified_pages (file_segment_pointer.cell_pointer, file_length, osc$wait, status);
          IF NOT status.normal THEN
            EXIT /open_file/;
          IFEND;

          mmp$free_pages (file_segment_pointer.cell_pointer, file_length, osc$wait, status);
          IF NOT status.normal THEN
            EXIT /open_file/;
          IFEND;

          /read_each_new_page/
          WHILE device_file_pointer.pva.offset < file_length DO
            byte := device_file_pointer.byte_pointer^;
            device_file_pointer.pva.offset := device_file_pointer.pva.offset + osv$page_size;
          WHILEND /read_each_new_page/;

          { Image file extended, evacuate device log after device file detached.

          call_evacuate_device_log := TRUE;
        IFEND;

        { Build the MAU list for the file.

        PUSH file_mau_list_p: [1 .. dmc$max_mau_addresses];
        build_mau_list (file_sfid, file_mau_list_p, file_mau_count, file_transfer_unit_size,
              device_file_avt_index, status);
        IF NOT status.normal THEN
          EXIT /open_file/;
        IFEND;
        mmp$write_modified_pages (file_segment_pointer.cell_pointer, file_length, osc$wait, status);
      END /open_file/;
      dmp$close_file (file_segment_pointer.cell_pointer, close_status);

    END /attach_file/;
    dmp$detach_device_file (file_sfid, ignore, ignore, detach_status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT close_status.normal THEN
      status := close_status;
      RETURN;
    IFEND;
    IF NOT detach_status.normal THEN
      status := detach_status;
      RETURN;
    IFEND;

    attach_or_create_the_mau_file (file_name, file_mau_count, file_mau_list_p, file_transfer_unit_size,
          mau_file_name, first_mau, status);

    IF (call_evacuate_device_log) and (status.normal) THEN

      { Flush the device log to disk to prevent recovery failure if system should abort before log normally
      { flushed to disk.

      dmp$evacuate_active_device_log (device_file_avt_index, status);
    IFEND;

  PROCEND install_file;
?? TITLE := 'dsp$append_file_to_ds_file', EJECT ??

{ PURPOSE:
{   This procedure appends a file to the device deadstart file.
{ DESIGN:
{   Create the device deadstart file if it does not already exist.  Allocate the
{   space and append the file.

  PROCEDURE [XDCL, #GATE] dsp$append_file_to_ds_file
    (    file_length: amt$file_byte_address;
         deadstart_file: ost$name;
     VAR file_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      allocate_pass_count: 0 .. 5,
      close_status: ost$status,
      data_p: ^SEQ ( * ),
      detach_status: ost$status,
      file_data_p: ^SEQ ( * ),
      file_segment_pointer: mmt$segment_pointer,
      file_sfid: dmt$system_file_id,
      ignore: boolean,
      ignore_status: ost$status,
      physical_file_attributes: ARRAY [1..3] OF dmt$new_device_file_attribute;

    status.normal := TRUE;

    {  Attach or create the device file.

    dmp$attach_device_file (dmv$system_device_recorded_vsn, deadstart_file, file_sfid, status);

    IF NOT status.normal AND (status.condition = dme$unknown_device_file) THEN
      physical_file_attributes [1].keyword := dmc$clear_space;
      physical_file_attributes [1].required := FALSE;
      physical_file_attributes [2].keyword := dmc$file_limit;
      physical_file_attributes [2].limit := UPPERVALUE (amt$file_limit);
      physical_file_attributes [3].keyword := dmc$requested_allocation_size;
      physical_file_attributes [3].requested_allocation_size := dmc$deadstart_file_alloc_size;
      dmp$create_device_file (deadstart_file, dmv$system_device_recorded_vsn,
            ^physical_file_attributes, file_length, file_sfid, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

   /attach_file/
    BEGIN
      file_segment_pointer.kind := mmc$sequence_pointer;
      dmp$open_file (file_sfid, 1, 1, mmc$sar_write_extend, mmc$as_sequential,
            file_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /attach_file/;
      IFEND;

      { Allocate the space needed for the new file to be added to the system device file.
      { Move the data from the new file to the system device file.  Then write the
      { modified pages.

     /open_file/
      BEGIN

        allocate_pass_count := 5;
        REPEAT
          dmp$allocate_file_space_r1 (file_sfid, current_installed_file_length, file_length,
                0, osc$nowait, sfc$no_limit, status);
          IF NOT status.normal THEN
            pmp$delay (1000, ignore_status);
          IFEND;
          allocate_pass_count := allocate_pass_count - 1;
        UNTIL status.normal OR (allocate_pass_count = 0);
        IF NOT status.normal THEN
          EXIT /open_file/;
        IFEND;

        { Skip the data that has already been written.

        IF current_installed_file_length <> 0 THEN
          NEXT data_p: [[REP current_installed_file_length OF CELL]] IN file_segment_pointer.seq_pointer;
        IFEND;

        { Copy the data from the new file to the device file.

        NEXT data_p: [[REP file_length OF CELL]] IN file_segment_pointer.seq_pointer;
        RESET file_p;
        NEXT file_data_p: [[REP file_length OF cell]] IN file_p;
        data_p^ := file_data_p^;
        mmp$write_modified_pages (file_segment_pointer.seq_pointer, file_length, osc$wait, status);
        IF NOT status.normal THEN
          EXIT /open_file/;
        IFEND;
        current_installed_file_length := current_installed_file_length + file_length;
        dmp$set_eoi (file_sfid, current_installed_file_length, status);
        IF NOT status.normal THEN
          EXIT /open_file/;
        IFEND;
      END /open_file/;
      dmp$close_file (file_segment_pointer.seq_pointer, close_status);

    END /attach_file/;
    dmp$detach_device_file (file_sfid, ignore, ignore, detach_status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT close_status.normal THEN
      status := close_status;
      RETURN;
    IFEND;
    IF NOT detach_status.normal THEN
      status := detach_status;
      RETURN;
    IFEND;

  PROCEND dsp$append_file_to_ds_file;
?? TITLE := 'dsp$attach_label_for_upgrade', EJECT ??

{ PURPOSE:
{   When the system is terminated, device management idles and then
{   deadstart idles.  If a commit new system has been requested then
{   data in the label file on the system device must be changed.  It
{   cannot be attached once device management has idled.  This procedure
{   attaches the label file to get the SFID so that it can be opened
{   after device management has been idled.

  PROCEDURE [XDCL, #GATE] dsp$attach_label_for_upgrade;

    VAR
      commit_new_dsfile: integer,
      ignore: boolean,
      label_header_p: ^dmt$volume_label_header,
      label_p: ^dmt$ms_volume_label,
      local_status: ost$status,
      user_supplied_name: ost$name;

    { Determine if an upgrade to a new disk deadstart file has been requested.

    system_device_label_sfid := dmv$null_sfid;
    dsp$get_integer_from_rdf (dsc$rdf_commit_new_dsfile_flag, dsc$rdf_production, commit_new_dsfile);
    IF commit_new_dsfile = $INTEGER (FALSE) THEN
      RETURN;
    IFEND;

    { Attempt to attach the system device file and open the label.

    user_supplied_name := 'LABEL';
    user_supplied_name (6, rmc$recorded_vsn_size) := dmv$system_device_recorded_vsn;
    dmp$attach_device_file (dmv$system_device_recorded_vsn, user_supplied_name,
          system_device_label_sfid, local_status);
    IF NOT local_status.normal THEN
      system_device_label_sfid := dmv$null_sfid;
      RETURN;
    IFEND;
    dmp$open_label (system_device_label_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_modify,
          mmc$as_random, label_p, local_status);
    IF NOT local_status.normal THEN
      dmp$detach_device_file (system_device_label_sfid, ignore, ignore, local_status);
      system_device_label_sfid := dmv$null_sfid;
      RETURN;
    IFEND;

    { Check the system device label for the presence of a deadstart file to upgrade.

    RESET label_p;
    NEXT label_header_p IN label_p;

    IF label_header_p^.secondary_deadstart_file = 0 THEN
      dmp$close_file (label_p, local_status);
      dmp$detach_device_file (system_device_label_sfid, ignore, ignore, local_status);
      system_device_label_sfid := dmv$null_sfid;
      RETURN;
    IFEND;

    { An upgrade can occur, the label file SFID is known and can be used to open the label
    { so the label file can now be closed.

    dmp$close_file (label_p, local_status);

  PROCEND dsp$attach_label_for_upgrade;
?? TITLE := 'dsp$check_system_available', EJECT ??

{ PURPOSE:
{   This procedure checks the Secondary Deadstart File MAU in the system device
{   label to see if there is a system to commit.

  PROCEDURE [XDCL, #GATE] dsp$check_system_available
    (VAR status: ost$status);

    VAR
      close_status: ost$status,
      detach_status: ost$status,
      file_sfid: dmt$system_file_id,
      ignore: boolean,
      label_header_p: ^dmt$volume_label_header,
      label_p: ^dmt$ms_volume_label,
      user_supplied_name: ost$name;

    status.normal := TRUE;

    { Attach the system device file and open the label.

    user_supplied_name := 'LABEL';
    user_supplied_name (6, rmc$recorded_vsn_size) := dmv$system_device_recorded_vsn;
    dmp$attach_device_file (dmv$system_device_recorded_vsn, user_supplied_name, file_sfid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /attach_system_file/
    BEGIN
      dmp$open_label (file_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_modify, mmc$as_random,
            label_p, status);
      IF NOT status.normal THEN
        EXIT /attach_system_file/;
      IFEND;

      { Retrieve the label from the system file.

      RESET label_p;
      NEXT label_header_p IN label_p;

      { Check if there is a Secondary Deadstart File MAU.  This will determine whether there is a system
      { to commit.

      IF label_header_p^.secondary_deadstart_file = 0 THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$no_deadstart_file_to_commit, '', status);
      IFEND;

      dmp$close_file (label_p, close_status);

    END /attach_system_file/;
    dmp$detach_device_file (file_sfid, ignore, ignore, detach_status);
    IF status.normal THEN
      IF NOT close_status.normal THEN
        status := close_status;
      ELSEIF NOT detach_status.normal THEN
        status := detach_status;
      IFEND;
    IFEND;

  PROCEND dsp$check_system_available;
?? TITLE := 'dsp$complete_deadstart_file', EJECT ??

{ PURPOSE:
{   This procedure creates the MAU file and builds the MAU list.

  PROCEDURE [XDCL, #GATE] dsp$complete_deadstart_file
    (    deadstart_file: ost$name;
         mau_file_name: ost$name;
     VAR status: ost$status);

    VAR
      close_status: ost$status,
      detach_status: ost$status,
      file_mau_count: dmt$mau_count,
      file_mau_list_p: ^dmt$mau_address_list,
      file_sfid: dmt$system_file_id,
      file_transfer_unit_size: dmt$allocation_size,
      first_mau: dmt$mau_address_entry,
      ignore: boolean,
      label_header_p: ^dmt$volume_label_header,
      label_p: ^dmt$ms_volume_label,
      mau_file_avt_index: dmt$active_volume_table_index,
      user_supplied_name: ost$name;

    status.normal := TRUE;

    {  Attach the device deadstart file.

    dmp$attach_device_file (dmv$system_device_recorded_vsn, deadstart_file, file_sfid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Build the MAU list for the file.

    PUSH file_mau_list_p: [1 .. dmc$max_mau_addresses];
    build_mau_list (file_sfid, file_mau_list_p, file_mau_count, file_transfer_unit_size,
          mau_file_avt_index, status);

    dmp$detach_device_file (file_sfid, ignore, ignore, detach_status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT detach_status.normal THEN
      status := detach_status;
      RETURN;
    IFEND;

    attach_or_create_the_mau_file (deadstart_file, file_mau_count, file_mau_list_p,
          file_transfer_unit_size, mau_file_name, first_mau, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Set the first MAU of the deadstart file in the Secondary Deadstart file MAU in the system
    { device label.

    { Attach the system device file and open the label.

    user_supplied_name := 'LABEL';
    user_supplied_name (6, rmc$recorded_vsn_size) := dmv$system_device_recorded_vsn;
    dmp$attach_device_file (dmv$system_device_recorded_vsn, user_supplied_name, file_sfid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /attach_system_file/
    BEGIN
      dmp$open_label (file_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_modify, mmc$as_random,
            label_p, status);
      IF NOT status.normal THEN
        EXIT /attach_system_file/;
      IFEND;

    /open_system_label/
      BEGIN

        { Retrieve the label from the system file.

        RESET label_p;
        NEXT label_header_p IN label_p;

        { Store the first MAU of the deadstart file in the Secondary Deadstart File MAU
        { in the system device label.

        label_header_p^.secondary_deadstart_file := first_mau;
        mmp$write_modified_pages (label_header_p, #SIZE (label_header_p^), osc$wait, status);

      END /open_system_label/;
      dmp$close_file (label_p, close_status);

    END /attach_system_file/;
    dmp$detach_device_file (file_sfid, ignore, ignore, detach_status);
    IF status.normal THEN
      IF NOT close_status.normal THEN
        status := close_status;
      ELSEIF NOT detach_status.normal THEN
        status := detach_status;
      IFEND;
    IFEND;

  PROCEND dsp$complete_deadstart_file;
?? TITLE := 'dsp$create_image_file', EJECT ??

{ PURPOSE:
{   This procedure creates the image file and stores the first MAU of
{   the image file mau file in the system device label which VCB will use
{   to locate where to write the image file.

  PROCEDURE [XDCL] dsp$create_image_file
    (    file_length: amt$file_byte_address;
     VAR status: ost$status);

    VAR
      close_status: ost$status,
      detach_status: ost$status,
      file_name: ost$name,
      file_sfid: dmt$system_file_id,
      first_mau: dmt$mau_address_entry,
      ignore: boolean,
      label_header_p: ^dmt$volume_label_header,
      label_p: ^dmt$ms_volume_label,
      mau_file_name: ost$name,
      user_supplied_name: ost$name;

    status.normal := TRUE;

    { The image file must be created before the system is committed.

    IF dsp$system_committed () THEN
       osp$system_error ('Must create image file before system committed', NIL);
    IFEND;

    { Install the image file.

    file_name := dsc$image_file_name;
    mau_file_name := c$image_mau_file_name;
    install_file (file_length, 0, file_name, mau_file_name, first_mau, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Attach the system device file and open the label.

    user_supplied_name := 'LABEL';
    user_supplied_name (6, rmc$recorded_vsn_size) := dmv$system_device_recorded_vsn;
    dmp$attach_device_file (dmv$system_device_recorded_vsn, user_supplied_name, file_sfid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /attach_system_file/
    BEGIN
      dmp$open_label (file_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_modify, mmc$as_random,
            label_p, status);
      IF NOT status.normal THEN
        EXIT /attach_system_file/;
      IFEND;

      { Retrieve the label from the system file.

      RESET label_p;
      NEXT label_header_p IN label_p;

      { Store the first MAU of the image file mau file in the system device label.

      label_header_p^.image_file := first_mau;
      mmp$write_modified_pages (label_header_p, #SIZE (label_header_p^), osc$wait, status);

      dmp$close_file (label_p, close_status);

    END /attach_system_file/;
    dmp$detach_device_file (file_sfid, ignore, ignore, detach_status);
    IF status.normal THEN
      IF NOT close_status.normal THEN
        status := close_status;
      ELSEIF NOT detach_status.normal THEN
        status := detach_status;
      IFEND;
    IFEND;

  PROCEND dsp$create_image_file;
?? TITLE := 'dsp$extend_image_file', EJECT ??

{ PURPOSE:
{   This procedure extends the image file if its size has increased since the last system deadstart.  This
{   implies that a different system is running than was previously running.  This is intended to occur right
{   before the system is committed.
{
{ DESIGN:
{   The same process is used as creating the image file but because the file is being extended there is no
{   need to update the allocation unit of the first MAU of the image file mau file in the system label.
{   Extending the image file does not change any data on the file although the mau file is rewritten.

  PROCEDURE [XDCL] dsp$extend_image_file
    (    file_length: amt$file_byte_address;
         current_file_length: amt$file_byte_address;
     VAR status: ost$status);

    VAR
      file_name: ost$name,
      first_mau: dmt$mau_address_entry,
      mau_file_name: ost$name;

    status.normal := TRUE;

    file_name := dsc$image_file_name;
    mau_file_name := c$image_mau_file_name;
    install_file (file_length, current_file_length, file_name, mau_file_name, first_mau, status);

  PROCEND dsp$extend_image_file;
?? TITLE := 'dsp$prep_ds_file_installation', EJECT ??

{ PURPOSE:
{   This procedure determines which deadstart file slot to use.
{ DESIGN:
{   If the primary deadstart file is stored in one of the slots then the other
{   slot is used.

  PROCEDURE [XDCL, #GATE] dsp$prep_ds_file_installation
    (VAR deadstart_file_name: ost$name;
     VAR mau_file_name: ost$name;
     VAR status: ost$status);

    CONST
      slot_1_file_name = 'dsfile_1',
      slot_1_mau_file_name = 'maufile_1',
      slot_2_file_name = 'dsfile_2',
      slot_2_mau_file_name = 'maufile_2';

    VAR
      close_status: ost$status,
      detach_status: ost$status,
      file_segment_pointer: mmt$segment_pointer,
      file_sfid: dmt$system_file_id,
      first_mau_slot_1: dmt$mau_address_entry,
      ignore: boolean,
      label_header_p: ^dmt$volume_label_header,
      label_p: ^dmt$ms_volume_label,
      mau_file_header_p: ^dmt$mau_list_header,
      user_supplied_name: ost$name;

    status.normal := TRUE;

    current_installed_file_length := 0;

    { Attempt to retrieve the first MAU from the file in SLOT 1.
    { If the file in SLOT 1 does not exist then the first MAU is zero.

  /retrieve_first_mau/
    BEGIN
      mau_file_name := slot_1_mau_file_name;
      dmp$attach_device_file (dmv$system_device_recorded_vsn, mau_file_name, file_sfid, status);
      IF NOT status.normal THEN
        first_mau_slot_1 := 0;
        EXIT /retrieve_first_mau/;
      IFEND;

    /attach_file/
      BEGIN
        file_segment_pointer.kind := mmc$sequence_pointer;
        dmp$open_file (file_sfid, 1, 1, mmc$sar_write_extend, mmc$as_sequential,
              file_segment_pointer, status);
        IF NOT status.normal THEN
          first_mau_slot_1 := 0;
          EXIT /attach_file/;
        IFEND;

        RESET file_segment_pointer.seq_pointer;
        NEXT mau_file_header_p IN file_segment_pointer.seq_pointer;
        first_mau_slot_1 := mau_file_header_p^.first_mau_of_maufile;

        { Okay to ignore the status because at this point the file may not exist.

        dmp$close_file (file_segment_pointer.seq_pointer, close_status);

      END /attach_file/;
      dmp$detach_device_file (file_sfid, ignore, ignore, detach_status);
    END /retrieve_first_mau/;

    { Attach the system device file and open the label.

    user_supplied_name := 'LABEL';
    user_supplied_name (6, rmc$recorded_vsn_size) := dmv$system_device_recorded_vsn;
    dmp$attach_device_file (dmv$system_device_recorded_vsn, user_supplied_name, file_sfid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /attach_system_file/
    BEGIN
      dmp$open_label (file_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_modify, mmc$as_random,
            label_p, status);
      IF NOT status.normal THEN
        EXIT /attach_system_file/;
      IFEND;

      { Retrieve the label from the system file.

      RESET label_p;
      NEXT label_header_p IN label_p;

      { Determine in which SLOT to install the deadstart file.

      IF label_header_p^.primary_deadstart_file = first_mau_slot_1 THEN
        deadstart_file_name := slot_2_file_name;
        mau_file_name := slot_2_mau_file_name;
      ELSE
        deadstart_file_name := slot_1_file_name;
        mau_file_name := slot_1_mau_file_name;
      IFEND;

      dmp$close_file (label_p, close_status);

    END /attach_system_file/;
    dmp$detach_device_file (file_sfid, ignore, ignore, detach_status);
    IF status.normal THEN
      IF NOT close_status.normal THEN
        status := close_status;
      ELSEIF NOT detach_status.normal THEN
        status := detach_status;
      IFEND;
    IFEND;

  PROCEND dsp$prep_ds_file_installation;
?? TITLE := 'dsp$upgrade_primary_dsfile_mau', EJECT ??

{ PURPOSE:
{   This procedure upgrades the Primary Deadstart File MAU in the system device
{   label with the Secondary Deadstart File MAU.
{ DESIGN:
{   This procedure can not use the device management "attach" and "detach"
{   because this procedure will be executed after device management idles.
{   The system device SFID is saved prior to the device management idle.

  PROCEDURE [XDCL] dsp$upgrade_primary_dsfile_mau
    (VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      label_header_p: ^dmt$volume_label_header,
      label_p: ^dmt$ms_volume_label;

    status.normal := TRUE;

    { Check for a saved SFID.  If none exists then there is no deadstart file to upgrade.

    IF system_device_label_sfid = dmv$null_sfid THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$no_deadstart_file_to_commit, '', status);
      RETURN;
    IFEND;

    dmp$open_label (system_device_label_sfid, osc$os_ring_1, osc$tsrv_ring,
          mmc$sar_modify, mmc$as_random, label_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Move the Secondary Deadstart File MAU to the Primary Deadstart File MAU.

    RESET label_p;
    NEXT label_header_p IN label_p;
    label_header_p^.primary_deadstart_file := label_header_p^.secondary_deadstart_file;
    label_header_p^.secondary_deadstart_file := 0;

    mmp$write_modified_pages (label_header_p, #SIZE (label_header_p^), osc$wait, status);

    dmp$close_file (label_p, ignore_status);

  PROCEND dsp$upgrade_primary_dsfile_mau;
MODEND dsm$deadstart_file_management;
*DECK DECK=DSM$DEADSTART_IO EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Deadstart IO' ??
MODULE dsm$deadstart_io;

{ PURPOSE:
{   This module contains all of the procedures needed to read data from the deadstart device.
{ NOTES:
{   This module resides in both the BOOT and in the SYSTEM CORE.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmc$deadstart_file_alloc_size
*copyc dmt$deadstart_label_files
*copyc dmt$mau_list
*copyc dse$deadstart_io_errors
*copyc dst$deadstart_file_identifier
*copyc dst$header_information
*copyc fst$ansi_hdr1_label
*copyc fst$ansi_hdr2_label
*copyc fst$ansi_vol1_label
?? POP ??
*copyc cmp$get_logical_unit_number
*copyc cmp$get_unit_type
*copyc dmp$get_physical_attributes
*copyc dmp$locate_volume_label
*copyc dsp$fetch_boot_data
*copyc dsp$save_boot_data_pointer
*copyc iop$forspace_tape_to_tapemark
*copyc iop$free_boot_tape_tables
*copyc iop$initialize_tape_ud
*copyc iop$mass_storage_io
*copyc iop$read_tape
*copyc iop$rewind_tape
*copyc iop$tape_request_status
*copyc iop$unload_tape
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$delay
*copyc pmp$zero_out_table
?? EJECT ??
*copyc cmv$system_device_data
*copyc osv$boot
*copyc osv$boot_is_executing
*copyc osv$mainframe_wired_heap
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??
  CONST
    max_disk_data_length = dmc$deadstart_file_alloc_size,
    max_mau_list_size = 20000000 DIV dmc$deadstart_file_alloc_size,

  { Reel to reel tape constants.

    max_tape_blocks_reel = 10,
    max_tape_data_length_reel = max_tape_blocks_reel * ioc$max_tape_not_long_blk_lgth,

  { Cartridge tape constants.

    max_tape_blocks_cart = 1,
    max_tape_data_length_cart = max_tape_blocks_cart * ioc$cart_tape_default_maxbl;

  TYPE
    current_blocks = 1 .. (max_tape_blocks_reel + 1),

    deadstart_disk_information = RECORD
      device_address: dmt$ms_logical_device_address,
      current_address: 0 .. (dmc$max_mau_address + 1),
      mau_count: dmt$mau_count,
      buffer_amount: 0 .. max_disk_data_length,
      file_size: integer,
    RECEND,

    deadstart_header_information = RECORD
      block_type: string (2),
      record_type: string (1),
    RECEND,

    deadstart_io_data = RECORD
      unit_class: cmt$unit_class,
      cm_unit_type: cmt$unit_type,
      data_end_mark_reached: boolean,
      data_end_mark_read: boolean,
      header_information: deadstart_header_information,
      disk: deadstart_disk_information,
      tape: deadstart_tape_information,
    RECEND,

    deadstart_label_id = string (4),

    deadstart_tape_information = RECORD
      maxbl: 0 .. ioc$cart_tape_default_maxbl,
      maximum_blocks: 0 .. max_tape_blocks_reel,
      blocks_read: 0 .. max_tape_blocks_reel,
      current_block: current_blocks,
      block_size_already_read: 0 .. ioc$cart_tape_default_maxbl,
    RECEND,

    { Note - The following type must be aligned so that all the tape transfer count buffers
    { reside in the same memory page.

    deadstart_tape_transfer_counts = RECORD
      buffers: ALIGNED [0 MOD 256] ARRAY [1 .. *] OF iot$tape_transfer_count,
    RECEND;
?? EJECT ??
  VAR
    dsv$unload_deadstart_tape: [XDCL] boolean := TRUE,
    osv$deadstart_device_lun: [XDCL] iot$logical_unit,

    io_buffer_seq_p: ^SEQ ( * ) := NIL,
    io_data: deadstart_io_data,
    label_seq_p: ^SEQ ( * ) := NIL,
    mau_list_p: ^dmt$mau_address_list := NIL,
    tape_data: iot$read_tape_description,
    tape_transfer_counts_p: ^deadstart_tape_transfer_counts := NIL;
?? TITLE := 'check_tape_status', EJECT ??

{ PURPOSE:
{   This procedure checks the status of the tape request.
{   If the input parameter wait_for_completion is FALSE, the tape_io_status
{   has already been obtained and is an input to this procedure

  PROCEDURE check_tape_status
    (    io_id: iot$io_id;
         wait_for_completion: boolean;
     VAR tape_io_status: iot$tape_io_status;   {input if wait_for_completion = False
     VAR status: ost$status);

    VAR
      dummy_sfid: dmt$system_file_id,
      tape_condition_code: ost$status_condition_code,
      tape_error_text: string (80);

    status.normal := TRUE;

  /wait_for_status/
    WHILE TRUE DO
      IF wait_for_completion THEN
        iop$tape_request_status (dummy_sfid, io_id, {wait=} FALSE, tape_io_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF NOT tape_io_status.io_complete THEN
          pmp$delay (100, status);
          CYCLE /wait_for_status/;
        IFEND;
      IFEND;

      IF NOT tape_io_status.unit_ready THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$tape_io_error,
              'The tape unit is not ready.', status);
        RETURN;
      IFEND;

      tape_condition_code := dse$tape_io_error;
      tape_error_text := ' ';

      IF NOT tape_io_status.normal_completion THEN
        CASE tape_io_status.completion_code OF
        = ioc$tapemark_read =
          io_data.data_end_mark_read := TRUE;
        = ioc$load_point =
          tape_error_text := 'Tape IO error - load_point.';
        = ioc$load_point_block_count_ne_0 =
          tape_error_text := 'Tape IO error - load point block count ne 0.';
        = ioc$no_write_ring =
          tape_error_text := 'Tape IO error - no write ring.';
        = ioc$not_capable_of_density =
          tape_error_text := 'Tape IO error - not capable of density.';
        = ioc$blank_tape =
          tape_error_text := 'Tape IO error - blank tape.';
        = ioc$erase_limit_exceeded =
          tape_error_text := 'Tape IO error - erase limit exceeded.';
        = ioc$system_software_failure =
          tape_error_text := 'Tape IO error - system software failure.';
        = ioc$read_past_phys_eot =
          tape_error_text := 'Tape IO error - attempted read past physical EOT.';
        = ioc$indeterminate =
          tape_error_text := 'Tape IO error - indeterminate.';
        = ioc$input_channel_parity =
          tape_error_text := 'Tape IO error - input channel parity.';
        = ioc$user_own_recovery =
          tape_error_text := 'Tape IO error - user own recovery.';
        = ioc$output_channel_parity =
          tape_error_text := 'Tape IO error - output channel parity.';
        = ioc$controller_failure =
          tape_error_text := 'Tape IO error - controller failure.';
        = ioc$unit_failure =
          tape_error_text := 'Tape IO error - unit failure.';
        = ioc$function_timeout =
          tape_error_text := 'Tape IO error - functIOn timeout.';
        = ioc$tape_medium_failure =
          tape_error_text := 'Tape IO error - tape medium failure.';
        = ioc$unit_reserved =
          tape_error_text := 'Tape IO error - unit reserved.';
        = ioc$iou_output_parity =
          tape_error_text := 'Tape IO error - IOu output parity.';
        = ioc$indeterminate_output_parity =
          tape_error_text := 'Tape IO error - indeterminate output parity.';
        = ioc$unable_to_set_agc =
          tape_error_text := 'Tape IO error - unable to set AGC.';
        = ioc$alert_condition_encountered =
          tape_condition_code := dse$damaged_deadstart_file;
          tape_error_text := 'The deadstart file is damaged or built incorrectly';
        ELSE
          osp$system_error ('Unknown tape failure', #LOC (tape_io_status));
        CASEND;

      ELSE {normal completion}
        IF tape_io_status.end_of_tape THEN
          tape_error_text := 'Tape IO error - end of tape.';
        IFEND;
        IF tape_io_status.position_uncertain THEN
          tape_error_text := 'Tape IO error - position uncertain.';
        IFEND;
      IFEND;

      IF tape_error_text <> ' ' THEN
        osp$set_status_abnormal (dsc$display_processor_id, tape_condition_code, tape_error_text, status);
      IFEND;
      RETURN;

    WHILEND /wait_for_status/;

  PROCEND check_tape_status;
?? TITLE := 'convert_string_to_file_size', EJECT ??

{ PURPOSE:
{   This procedure converts the file size string that is found in the HDR2 label to an integer value.

  PROCEDURE convert_string_to_file_size
    (    hdr2_label: fst$ansi_hdr2_label);

    VAR
      actual_integer: 0 .. 0ff(16),
      file_size: integer,
      file_size_string: string (8),
      integer_char: 0 .. 0ff(16),
      multiplier: integer,
      string_index: 1 .. 8;

    file_size_string := hdr2_label.block_length;
    file_size_string ((#SIZE (hdr2_label.block_length) + 1), *) := hdr2_label.ve_block_length_ext;
    file_size := 0;
    multiplier := 1;
    FOR string_index := 8 DOWNTO 1 DO
      integer_char := $INTEGER (file_size_string (string_index));
      IF (integer_char >= $INTEGER ('0')) AND (integer_char <= $INTEGER ('9')) THEN
        actual_integer := integer_char - $INTEGER ('0');
      ELSEIF (integer_char >= $INTEGER ('A')) AND (integer_char <= $INTEGER ('F')) THEN
        actual_integer := integer_char - $INTEGER ('7');
      ELSE
        osp$system_error ('ERROR: invalid file size on disk deadstart file.', NIL);
      IFEND;
      file_size := file_size + (actual_integer * multiplier);
      multiplier := multiplier * 10(16);
    FOREND;

    io_data.disk.file_size := file_size;

  PROCEND convert_string_to_file_size;
?? TITLE := 'position_deadstart_file', EJECT ??

{ PURPOSE:
{   This procedure reads the VOL1 label and the data up to the first "data end" mark.  Certain information
{   is checked in the VOL1, HDR1, and HDR2 labels that exist before this first "data end" mark.  This
{   information determines whether the deadstart file is valid.

  PROCEDURE position_deadstart_file
    (VAR status: ost$status);

    VAR
      hdr1_label_p: ^fst$ansi_hdr1_label,
      hdr2_label_p: ^fst$ansi_hdr2_label,
      label_found: boolean,
      label_id: deadstart_label_id,
      monitor_image_found: boolean;

    status.normal := TRUE;

    IF io_data.unit_class = cmc$mass_storage_unit THEN
      io_data.disk.file_size := #SIZE (fst$ansi_hdr1_label) * 3;
    IFEND;

    { Read the VOL1 label.

    read_label (label_seq_p, label_id, label_found);
    IF NOT label_found OR (label_id <> 'VOL1') THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$incorrect_deadstart_file,
            'Incorrect deadstart file: No VOL1 label', status);
      RETURN;
    IFEND;

    { Skip over the other possible VOLN labels and read the HDR1 label.

    REPEAT
      read_label (label_seq_p, label_id, label_found);
    UNTIL NOT label_found OR (label_id = 'HDR1');
    IF NOT label_found THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$incorrect_deadstart_file,
            'Incorrect deadstart file: No HDR1 label', status);
      RETURN;
    IFEND;

    { Skip over the CIP files on the deadstart tape.  Read until the MONITOR_IMAGE file is found.

    WHILE TRUE DO
      NEXT hdr1_label_p IN label_seq_p;
      monitor_image_found := (hdr1_label_p^.file_identifier = 'MONITOR_IMAGE');

      { Read the HDR2 label.

      read_label (label_seq_p, label_id, label_found);
      IF NOT label_found OR (label_id <> 'HDR2') THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$incorrect_deadstart_file,
              'Incorrect deadstart file: No HDR2 label', status);
        RETURN;
      IFEND;

      { Retrieve the preceeding file size from the HDR2 label for disk deadstarts.

      NEXT hdr2_label_p IN label_seq_p;
      io_data.header_information.block_type := hdr2_label_p^.ve_block_type;
      io_data.header_information.record_type := hdr2_label_p^.ve_record_type;

      { Skip over any more HDRN labels.

      skip_to_next_data_end;

      IF io_data.unit_class = cmc$mass_storage_unit THEN
        convert_string_to_file_size (hdr2_label_p^);
      IFEND;

      IF monitor_image_found THEN
        RETURN;
      IFEND;

      { Skip over the CIP file.

      skip_to_next_data_end;

      { Skip over the EOFN records.

      skip_to_next_data_end;

      { Read the next HDR1 label.

      read_label (label_seq_p, label_id, label_found);
      IF NOT label_found THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$incorrect_deadstart_file,
              'Incorrect deadstart file: No HDR1 label', status);
        RETURN;
      IFEND;
    WHILEND;

  PROCEND position_deadstart_file;
?? TITLE := 'read_data', EJECT ??

{ PURPOSE:
{   This procedure reads data from the deadstart file into an IO buffer.  The IO buffer is a set size.  This
{   procedure is called to fill the IO buffer.  The deadstart file data is read until the IO buffer is full
{   or until the "data end" mark is reached.  The "data end" mark is a tape mark on a tape or the end of a
{   file on the disk.  The end of a file on the disk can be found by the size of the file which is stored in
{   the HDR2 label on the disk.  When all of the data has been read, according to this size in the label,
{   then the "data end" mark has been found.  This procedure maintains the file size.

  PROCEDURE read_data;

    VAR
      disk_completion_status_p: ^iot$completion_status,
      dummy_sfid: dmt$system_file_id,
      io_id: iot$io_id,
      status: ost$status,
      tape_io_status: iot$tape_io_status;

    CASE io_data.unit_class OF
    = cmc$magnetic_tape_unit =
      io_data.data_end_mark_read := FALSE;
      iop$read_tape (dummy_sfid, FALSE, io_data.tape.maxbl, ^tape_data,
            io_data.tape.maximum_blocks, io_id, status);
      IF NOT status.normal THEN
        osp$system_error ('Tape IO error', ^status);
      IFEND;

      check_tape_status (io_id, TRUE, tape_io_status, status);
      IF NOT status.normal THEN
        osp$system_error ('Tape IO error', ^status);
      IFEND;

      reset_tape_data_area;
      io_data.tape.current_block := 1;
      io_data.tape.blocks_read := io_data.tape.maximum_blocks - tape_io_status.residual_block_count;
      io_data.tape.block_size_already_read := 0;

    = cmc$mass_storage_unit =
      IF io_data.disk.buffer_amount <= 0 THEN
        IF io_data.disk.current_address > io_data.disk.mau_count THEN
          osp$system_error ('Read past end of deadstart file', NIL);
        IFEND;
        PUSH disk_completion_status_p;
        RESET io_buffer_seq_p;
        io_data.disk.device_address.allocation_unit_mau_address := mau_list_p^ [io_data.disk.current_address];
        iop$mass_storage_io (io_buffer_seq_p, max_disk_data_length, ioc$read_mass_storage,
              io_data.disk.device_address, TRUE, disk_completion_status_p, status);
        IF NOT status.normal THEN
          osp$system_error ('Disk read failure', ^status);
        IFEND;
        RESET io_buffer_seq_p;
        io_data.disk.current_address := io_data.disk.current_address + 1;
        io_data.disk.buffer_amount := max_disk_data_length;
      IFEND;
      io_data.data_end_mark_read := (io_data.disk.file_size <= io_data.disk.buffer_amount);

    ELSE
      osp$system_error ('The deadstart device is unknown', NIL);
    CASEND;

  PROCEND read_data;
?? TITLE := 'read_label', EJECT ??

{ PURPOSE:
{   This procedure is called to read a label from the deadstart device.

  PROCEDURE read_label
    (VAR label_seq_p: ^SEQ ( * );
     VAR label_id: deadstart_label_id;
     VAR label_found: boolean);

    VAR
      data_size_read: integer,
      label_p: ^fst$ansi_hdr1_label;

    { Read the label.

    RESET label_seq_p;
    dsp$read_deadstart_device (#SIZE (fst$ansi_hdr1_label), label_seq_p, data_size_read);
    IF data_size_read < #SIZE (fst$ansi_hdr1_label) THEN
      label_found := FALSE;
      RETURN;
    IFEND;

    { Retrive the label id (ie. VOL1, HDR1 or HDR2) from the label.

    RESET label_seq_p;
    NEXT label_p IN label_seq_p;
    label_id (1, 3) := label_p^.label_identifier;
    label_id (4) := label_p^.label_number;

    RESET label_seq_p;
    label_found := TRUE;

  PROCEND read_label;
?? TITLE := 'reset_tape_data_area', EJECT ??

{ PURPOSE:
{   This procedure resets the tape data area.  This must be done initially and after every
{   call to IOP$READ_TAPE.  The procedure iop$read_tape changes the values in the tape data variable.

  PROCEDURE reset_tape_data_area;

    VAR
      block_index: 1 .. max_tape_blocks_reel,
      data_seq_p: ^SEQ ( * );

    RESET io_buffer_seq_p;
    FOR block_index := 1 TO io_data.tape.maximum_blocks DO
      tape_data [block_index].block_transfer_length := ^tape_transfer_counts_p^.buffers [block_index];
      IF io_data.cm_unit_type = cmc$mt5682_1x THEN
        NEXT data_seq_p: [[REP ioc$cart_tape_default_maxbl OF cell]] IN io_buffer_seq_p;
      ELSE
        NEXT data_seq_p: [[REP ioc$max_tape_not_long_blk_lgth OF cell]] IN io_buffer_seq_p;
      IFEND;
      tape_data [block_index].buffer_area := ^data_seq_p^;
    FOREND;

  PROCEND reset_tape_data_area;
?? TITLE := 'skip_to_next_data_end', EJECT ??

{ PURPOSE:
{   This procedure moves the tape or disk file forward past the next data end mark.

  PROCEDURE skip_to_next_data_end;

    VAR
      data_size: integer,
      dummy_io_id: iot$io_id,
      dummy_sfid: dmt$system_file_id,
      tape_io_status: iot$tape_io_status,
      status: ost$status,
      skip_data_p: ^SEQ ( * );

    IF NOT io_data.data_end_mark_reached THEN

      CASE io_data.unit_class OF
      = cmc$magnetic_tape_unit =

        IF NOT io_data.data_end_mark_read THEN
          iop$forspace_tape_to_tapemark (dummy_sfid, tape_io_status, status);
          IF NOT status.normal THEN
            osp$system_error ('Skip tapemark failed.', ^status);
          IFEND;
          check_tape_status (dummy_io_id, FALSE, tape_io_status, status);
          IF NOT status.normal THEN
            osp$system_error ('Skip tapemark I/O error.', ^status);
          IFEND;
        IFEND;
        io_data.tape.current_block := io_data.tape.maximum_blocks + 1;

      = cmc$mass_storage_unit =

        WHILE io_data.disk.file_size > 0 DO
          IF io_data.disk.buffer_amount <= 0 THEN
            read_data;
          IFEND;
          IF io_data.disk.buffer_amount < io_data.disk.file_size THEN
            data_size := io_data.disk.buffer_amount;
          ELSE
            data_size := io_data.disk.file_size;
          IFEND;
          NEXT skip_data_p: [[REP data_size OF cell]] IN io_buffer_seq_p;
          io_data.disk.buffer_amount := io_data.disk.buffer_amount - data_size;
          io_data.disk.file_size := io_data.disk.file_size - data_size;
        WHILEND

      ELSE
        osp$system_error ('The deadstart device is unknown.', NIL);
      CASEND;
    IFEND;

    io_data.data_end_mark_reached := FALSE;
    io_data.data_end_mark_read := FALSE;

  PROCEND skip_to_next_data_end;
?? TITLE := 'dsp$cleanup_deadstart_io', EJECT ??

{ PURPOSE:
{   This procedure is called when the deadstart IO is finished.  It rewinds the tape and
{   frees all the allocated space.

  PROCEDURE [XDCL, #GATE] dsp$cleanup_deadstart_io
    (VAR status: ost$status);

    VAR
      detachment_options: fmt$detachment_options,
      dummy_sfid: dmt$system_file_id,
      io_id: iot$io_id,
      tape_io_status: iot$tape_io_status;

    status.normal := TRUE;
    IF io_data.unit_class = cmc$magnetic_tape_unit THEN
      IF osv$boot_is_executing OR (NOT dsv$unload_deadstart_tape) THEN
        iop$rewind_tape (dummy_sfid, io_id, status);
        IF status.normal THEN
          check_tape_status (io_id, TRUE, tape_io_status, status);
        IFEND;
        IF NOT osv$boot_is_executing THEN
          iop$free_boot_tape_tables;
        IFEND;
      ELSE
        detachment_options.device_class := rmc$magnetic_tape_device;
        detachment_options.physical_unload := TRUE;
        iop$unload_tape (dummy_sfid, detachment_options, io_id, status);
        IF status.normal THEN
          check_tape_status (io_id, TRUE, tape_io_status, status);
        IFEND;
      IFEND;
    IFEND;

    IF tape_transfer_counts_p <> NIL THEN
      FREE tape_transfer_counts_p IN osv$mainframe_wired_heap^;
    IFEND;

    IF mau_list_p <> NIL THEN
      FREE mau_list_p IN osv$mainframe_wired_heap^;
    IFEND;

    IF io_buffer_seq_p <> NIL THEN
      FREE io_buffer_seq_p IN osv$mainframe_wired_heap^;
    IFEND;

    IF label_seq_p <> NIL THEN
      FREE label_seq_p IN osv$mainframe_wired_heap^;
    IFEND;

    osv$boot := osv$boot_is_executing;

  PROCEND dsp$cleanup_deadstart_io;
?? TITLE := 'dsp$fetch_mau_list', EJECT ??

{ PURPOSE:
{   This procedure fetches the MAU list of the deadstart file on the system device.

  PROCEDURE [XDCL] dsp$fetch_mau_list
    (    only_perform_allocates: boolean;
         label_file: dmt$deadstart_label_files;
     VAR mau_list_p: ^dmt$mau_address_list;
     VAR mau_count: dmt$mau_count;
     VAR transfer_size: integer;
     VAR status: ost$status);

    VAR
      completion_status_p: ^iot$completion_status,
      device_address: dmt$ms_logical_device_address,
      full_mau_list_p: ^dmt$mau_list,
      index: dmt$mau_count,
      label_area_p: ^ARRAY [1 .. * ] OF cell,
      label_found: boolean,
      label_header_p: ^dmt$volume_label_header,
      label_p: ^dmt$ms_volume_label,
      mau_address: dmt$mau_address_entry,
      mau_list_index: dmt$mau_count,
      physical_attributes_p: ^dmt$physical_device_attributes,
      required_io_size: integer;

    status.normal := TRUE;

    { Retrieve the physical attributes of the disk device.

    PUSH physical_attributes_p: [1 .. 4];
    physical_attributes_p^ [1].keyword := dmc$bytes_per_mau;
    physical_attributes_p^ [2].keyword := dmc$maus_per_cylinder;
    physical_attributes_p^ [3].keyword := dmc$maus_per_dau;
    physical_attributes_p^ [4].keyword := dmc$cylinders_per_device;
    dmp$get_physical_attributes (cmv$system_device_data [cmc$sdt_disk_device].unit_id, physical_attributes_p,
          status);
    IF NOT status.normal THEN
      osp$system_error ('Disk initialization failed', ^status);
    IFEND;

    { Allocate all of the necessary space to account for memory size.

    PUSH completion_status_p;
    PUSH label_p: [[REP #SIZE (dmt$volume_label_header) OF cell]];
    PUSH label_area_p: [1 .. dmc$deadstart_file_alloc_size];
    pmp$zero_out_table (label_area_p, #SIZE (label_area_p^));
    ALLOCATE mau_list_p: [1 .. max_mau_list_size] IN osv$mainframe_wired_heap^;
    pmp$zero_out_table (mau_list_p, #SIZE (mau_list_p^));

    IF only_perform_allocates THEN
      RETURN;
    IFEND;

    { Setup the disk IO.

    dsp$retrieve_device_address (dmc$deadstart_file_alloc_size, device_address);

    { Read the label from the disk.

    dmp$locate_volume_label (device_address.logical_unit_number, physical_attributes_p,
          label_p^, label_found);
    IF NOT label_found THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$disk_io_error,
            'Volume label not found on system device.', status);
      RETURN;
    IFEND;
    RESET label_p;
    NEXT label_header_p IN label_p;

    { Retrieve the mau address from the label.

    CASE label_file OF
    = dmc$dlf_primary_entry =
      mau_address := label_header_p^.primary_deadstart_file;
    = dmc$dlf_secondary_entry =
      mau_address := label_header_p^.secondary_deadstart_file;
    = dmc$dlf_image_entry =
      mau_address := label_header_p^.image_file;
    = dmc$dlf_spare_entry =
      mau_address := label_header_p^.spare_file;
    ELSE
    CASEND;
    IF (mau_address <= 0) OR (mau_address > (physical_attributes_p^ [2].maus_per_cylinder *
          physical_attributes_p^ [4].cylinders_per_device)) THEN
      IF label_file = dmc$dlf_image_entry THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$disk_io_error,
              'Image file not found on system device.', status);
      ELSE
        osp$set_status_abnormal (dsc$display_processor_id, dse$disk_io_error,
              'Deadstart file not installed.', status);
      IFEND;
      RETURN;
    IFEND;

    { Read the first mau list block as a small block.

    device_address.allocation_unit_mau_address := mau_address;
    iop$mass_storage_io (label_area_p, dmc$deadstart_file_alloc_size, ioc$read_mass_storage,
          device_address, TRUE, completion_status_p, status);
    IF NOT status.normal THEN
      osp$system_error ('Disk read failure', ^status);
    IFEND;

    { Retrieve the mau list plus mau list header from the label area.

    full_mau_list_p := #LOC (label_area_p^);
    IF (full_mau_list_p^.header.valid_data <> 1) OR
          (full_mau_list_p^.header.first_mau_of_maufile <> mau_address) THEN
      IF label_file = dmc$dlf_image_entry THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$disk_io_error,
              'Image file not found on system device.', status);
      ELSE
        osp$set_status_abnormal (dsc$display_processor_id, dse$disk_io_error,
              'Deadstart file not installed.', status);
      IFEND;
      RETURN;
    IFEND;
    transfer_size := full_mau_list_p^.header.block_size;
    mau_count := full_mau_list_p^.header.total_mau_addresses;

    { Read only the required amount to save memory space.

    required_io_size := transfer_size;
    IF ((mau_count * 8) + #SIZE (dmt$mau_list_header)) < required_io_size THEN
      required_io_size := ((mau_count * 8) + #SIZE (dmt$mau_list_header));
      IF (required_io_size MOD physical_attributes_p^ [1].bytes_per_mau) <> 0 THEN
        required_io_size := required_io_size + (physical_attributes_p^ [1].bytes_per_mau -
              (required_io_size MOD physical_attributes_p^ [1].bytes_per_mau));
      IFEND;
    IFEND;

    { Re-allocate IO area to the required size.

    PUSH label_area_p: [1 .. required_io_size];
    full_mau_list_p := #LOC (label_area_p^);
    pmp$zero_out_table (label_area_p, required_io_size);
    dsp$retrieve_device_address (required_io_size, device_address);

    { Retrieve the MAU list from the disk.

    IF mau_count > max_mau_list_size THEN
      FREE mau_list_p IN osv$mainframe_wired_heap^;
      ALLOCATE mau_list_p: [1 .. mau_count] IN osv$mainframe_wired_heap^;
      pmp$zero_out_table (mau_list_p, #SIZE (mau_list_p^));
    IFEND;
    mau_list_index := 0;
    WHILE mau_address <> 0 DO
      device_address.allocation_unit_mau_address := mau_address;
      iop$mass_storage_io (label_area_p, required_io_size, ioc$read_mass_storage,
            device_address, TRUE, completion_status_p, status);
      IF NOT status.normal THEN
        osp$system_error ('Disk read failure', ^status);
      IFEND;
      FOR index := 1 TO (required_io_size - #SIZE (dmt$mau_list_header)) DIV 8 DO
        IF mau_list_index < mau_count THEN
          mau_list_index := mau_list_index + 1;
          mau_list_p^ [mau_list_index] := full_mau_list_p^.mau_addresses [index];
        IFEND;
      FOREND;
      mau_address := full_mau_list_p^.header.next_mau_list_address;
    WHILEND;

  PROCEND dsp$fetch_mau_list;
?? TITLE := 'dsp$initialize_io', EJECT ??

{ PURPOSE:
{   This procedure initializes the tape for deadstart.

  PROCEDURE [XDCL, #GATE] dsp$initialize_io
    (    element_name: cmt$element_name;
     VAR status: ost$status);

    VAR
      dummy_sfid: dmt$system_file_id,
      tape_initialization_record: dmt$tape_initialization_record;

    status.normal := TRUE;

    cmp$get_logical_unit_number (element_name, osv$deadstart_device_lun, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF io_data.unit_class = cmc$magnetic_tape_unit THEN
      tape_initialization_record.logical_unit_number := osv$deadstart_device_lun;
      tape_initialization_record.density := rmc$1600;

      iop$initialize_tape_ud (tape_initialization_record, {multiple_requests_possible} FALSE, status);
    IFEND;

  PROCEND dsp$initialize_io;
?? TITLE := 'dsp$prepare_deadstart_io', EJECT ??

{ PURPOSE:
{   This procedure is called to prepare and setup the deadstart IO device.  It also validates the
{   deadstart tape or disk file.

  PROCEDURE [XDCL] dsp$prepare_deadstart_io
    (VAR status: ost$status);

    VAR
      data_seq_p: ^SEQ ( * ),
      dummy_sfid: dmt$system_file_id,
      element_name: cmt$element_name,
      found: boolean,
      ignore_status: ost$status,
      io_id: iot$io_id,
      io_unit_type: iot$unit_type,
      only_perform_allocates: boolean,
      product_id: cmt$product_identification,
      skip_data_p: ^SEQ ( * ),
      tape_io_status: iot$tape_io_status,
      transfer_size: integer;

    status.normal := TRUE;

    { Retrieve the product id and element name of the deadstart device.

    IF cmv$system_device_data [cmc$sdt_tape_device].specified THEN
      product_id := cmv$system_device_data [cmc$sdt_tape_device].unit_id;
      element_name := cmv$system_device_data [cmc$sdt_tape_device].unit_name;
    ELSE
      product_id := cmv$system_device_data [cmc$sdt_disk_device].unit_id;
      element_name := cmv$system_device_data [cmc$sdt_disk_device].unit_name;
    IFEND;

    { Determine whether the deadstart device is a tape or a disk.

    cmp$get_unit_type (product_id, io_data.cm_unit_type, io_unit_type, io_data.unit_class, found);
    IF NOT found THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$unknown_deadstart_device,
            'The deadstart device is unknown', status);
      RETURN;
    IFEND;

    dsp$initialize_io (element_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Setup or retrieve the variable that will contain all information pertaining to reading the tape
    { or disk file.  This variable is saved during the transition from boot to system core.

    IF osv$boot_is_executing THEN
      io_data.data_end_mark_read := FALSE;
      io_data.data_end_mark_reached := FALSE;
      io_data.header_information.block_type := ' ';
      io_data.header_information.record_type := ' ';
      io_data.disk.buffer_amount := 0;
      io_data.disk.file_size := 0;
      io_data.tape.blocks_read := 0;
      IF io_data.cm_unit_type = cmc$mt5682_1x THEN
        io_data.tape.maxbl := ioc$cart_tape_default_maxbl;
        io_data.tape.maximum_blocks := max_tape_blocks_cart;
        io_data.tape.current_block := max_tape_blocks_cart + 1;
      ELSE { Not cartridge tape
        io_data.tape.maxbl := ioc$max_tape_not_long_blk_lgth;
        io_data.tape.maximum_blocks := max_tape_blocks_reel;
        io_data.tape.current_block := max_tape_blocks_reel + 1;
      IFEND;
    ELSE
      data_seq_p := #SEQ (io_data);
      dsp$fetch_boot_data (dsc$io_environment, data_seq_p);
    IFEND;

   /allocate_data_areas/
    BEGIN

      { Fetch the MAU list in both cases to allow allocations to take place.

      IF osv$boot_is_executing THEN
        only_perform_allocates := (io_data.unit_class = cmc$magnetic_tape_unit);
        dsp$fetch_mau_list (only_perform_allocates, dmc$dlf_primary_entry, mau_list_p, io_data.disk.mau_count,
              transfer_size, status);
        IF NOT status.normal THEN
          EXIT /allocate_data_areas/;
        IFEND;
      IFEND;

      { Setup the IO buffer area.  Data is read from the deadstart device to this buffer area.

      CASE io_data.unit_class OF
      = cmc$magnetic_tape_unit =

        ALLOCATE tape_transfer_counts_p: [1 .. io_data.tape.maximum_blocks] IN osv$mainframe_wired_heap^;
        IF io_data.cm_unit_type = cmc$mt5682_1x THEN
          ALLOCATE io_buffer_seq_p: [[REP max_tape_data_length_cart OF cell]] IN osv$mainframe_wired_heap^;
        ELSE
          ALLOCATE io_buffer_seq_p: [[REP max_tape_data_length_reel OF cell]] IN osv$mainframe_wired_heap^;
        IFEND;

        reset_tape_data_area;
        IF osv$boot_is_executing THEN
          iop$rewind_tape (dummy_sfid, io_id, status);
          IF NOT status.normal THEN
            EXIT /allocate_data_areas/;
          IFEND;
          check_tape_status (io_id, TRUE, tape_io_status, status);
          IF NOT status.normal THEN
            EXIT /allocate_data_areas/;
          IFEND;
        IFEND;

      = cmc$mass_storage_unit =

        dsp$retrieve_device_address (max_disk_data_length, io_data.disk.device_address);
        ALLOCATE io_buffer_seq_p: [[REP max_disk_data_length OF cell]] IN osv$mainframe_wired_heap^;

        IF osv$boot_is_executing THEN
          IF (transfer_size MOD dmc$deadstart_file_alloc_size) <> 0 THEN
            osp$set_status_abnormal (dsc$display_processor_id, dse$disk_io_error,
                  'Incorrect deadstart file (transfer size error) on the system device', status);
            EXIT /allocate_data_areas/;
          IFEND;
          io_data.disk.current_address := 1;
        ELSE
          IF io_data.disk.mau_count <= 0 THEN
            osp$set_status_abnormal (dsc$display_processor_id, dse$disk_io_error,
                  'Incorrect deadstart file (MAU count) on the system device', status);
            EXIT /allocate_data_areas/;
          IFEND;
          ALLOCATE mau_list_p: [1 .. dmc$deadstart_file_alloc_size] IN osv$mainframe_wired_heap^;
        IFEND;

      ELSE
        osp$set_status_abnormal (dsc$display_processor_id, dse$unknown_deadstart_device,
              'The deadstart device is unknown', status);
        EXIT /allocate_data_areas/;
      CASEND;

      IF osv$boot_is_executing THEN
        pmp$zero_out_table (io_buffer_seq_p, #SIZE (io_buffer_seq_p^));
        dsp$save_boot_data_pointer (dsc$io_environment, #SEQ (io_data));
        dsp$save_boot_data_pointer (dsc$io_buffer, io_buffer_seq_p);
        IF io_data.unit_class = cmc$magnetic_tape_unit THEN
          dsp$save_boot_data_pointer (dsc$transfer_counts, #SEQ (tape_transfer_counts_p^));
        ELSE  {io_data.unit_class = cmc$mass_storage_unit
          dsp$save_boot_data_pointer (dsc$mau_list, #SEQ (mau_list_p^));
        IFEND;
      ELSE
        dsp$fetch_boot_data (dsc$io_buffer, io_buffer_seq_p);
        RESET io_buffer_seq_p;
        IF io_data.unit_class = cmc$magnetic_tape_unit THEN
          data_seq_p := #SEQ (tape_transfer_counts_p^);
          dsp$fetch_boot_data (dsc$transfer_counts, data_seq_p);
        ELSE  {io_data.unit_class = cmc$mass_storage_unit
          IF (max_disk_data_length - io_data.disk.buffer_amount) > 0 THEN
            NEXT skip_data_p: [[REP (max_disk_data_length - io_data.disk.buffer_amount) OF cell]]
                  IN io_buffer_seq_p;
          IFEND;
          data_seq_p := #SEQ (mau_list_p^);
          dsp$fetch_boot_data (dsc$mau_list, data_seq_p);
        IFEND;
      IFEND;

      { Setup a buffer area to read the labels.

      ALLOCATE label_seq_p: [[REP #SIZE (fst$ansi_hdr1_label) OF cell]] IN osv$mainframe_wired_heap^;

      { Position and validate the deadstart file.

      IF osv$boot_is_executing THEN
        position_deadstart_file (status);
        IF NOT status.normal THEN
          EXIT /allocate_data_areas/;
        IFEND;
      IFEND;

    END /allocate_data_areas/;

    IF NOT status.normal AND osv$boot_is_executing THEN
      dsp$cleanup_deadstart_io (ignore_status);
    IFEND;

  PROCEND dsp$prepare_deadstart_io;
?? TITLE := 'dsp$read_deadstart_device', EJECT ??

{ PURPOSE:
{   This procedure is called to retrieve an amount of data from an deadstart file.  The caller sends a
{   length describing the amount of data it wants and a pointer to an area in which the data will be
{   returned.  This procedure retrieves the desired amount of data from the IO buffer and returns it
{   to the caller.  The call may recieve less then it requested if a "data end" mark is encountered.

  PROCEDURE [XDCL, #GATE] dsp$read_deadstart_device
    (    data_length: integer;
     VAR data_buffer_p: ^SEQ ( * );
     VAR data_size_read: integer);

    VAR
      amount_to_read: integer,
      block_data_left: integer,
      block_data_p: ^SEQ ( * ),
      data_size: integer,
      data_p: ^SEQ ( * ),
      skip_data_p: ^SEQ ( * );

    IF io_data.data_end_mark_reached THEN
      data_size_read := 0;
      RETURN;
    IFEND;

    IF (data_length = 0) OR (data_buffer_p = NIL) THEN
      osp$system_error ('Incorrect request to dsp$read_deadstart_device.', NIL);
    IFEND;

    amount_to_read := data_length;
    data_size_read := 0;
    RESET data_buffer_p;

   /read_file_data/
    REPEAT

      CASE io_data.unit_class OF
      = cmc$magnetic_tape_unit =
        IF io_data.tape.current_block > io_data.tape.blocks_read THEN
          IF io_data.data_end_mark_read THEN
            EXIT /read_file_data/;
          ELSE
            read_data;
            IF io_data.data_end_mark_read AND (io_data.tape.current_block > io_data.tape.blocks_read) THEN
              EXIT /read_file_data/;
            IFEND;
          IFEND;
        IFEND;
        RESET io_buffer_seq_p TO tape_data [io_data.tape.current_block].buffer_area;
        IF io_data.tape.block_size_already_read > 0 THEN
          NEXT skip_data_p: [[REP io_data.tape.block_size_already_read OF cell]] IN io_buffer_seq_p;
        IFEND;
        block_data_left := tape_transfer_counts_p^.buffers [io_data.tape.current_block].length -
              io_data.tape.block_size_already_read;

        IF block_data_left < amount_to_read THEN
          data_size := block_data_left;
        ELSE
          data_size := amount_to_read;
        IFEND;
        IF data_size = 0 THEN
          osp$system_error ('Incorrect deadstart tape.', NIL);
        IFEND;
        NEXT block_data_p: [[REP data_size OF cell]] IN io_buffer_seq_p;
        NEXT data_p: [[REP data_size OF cell]] IN data_buffer_p;
        data_p^ := block_data_p^;

        data_size_read := data_size_read + data_size;
        amount_to_read := amount_to_read - data_size;
        io_data.tape.block_size_already_read := io_data.tape.block_size_already_read + data_size;
        IF io_data.tape.block_size_already_read >=
              tape_transfer_counts_p^.buffers [io_data.tape.current_block].length THEN
          io_data.tape.current_block := io_data.tape.current_block + 1;
          io_data.tape.block_size_already_read := 0;
        IFEND;

      = cmc$mass_storage_unit =
        IF amount_to_read > io_data.disk.file_size THEN
          amount_to_read := io_data.disk.file_size;
        IFEND;
        IF io_data.disk.buffer_amount <= 0 THEN
          read_data;
        IFEND;
        IF io_data.disk.file_size <= 0 THEN
          io_data.data_end_mark_read := TRUE;
          EXIT /read_file_data/;
        IFEND;

        IF io_data.disk.buffer_amount < amount_to_read THEN
          data_size := io_data.disk.buffer_amount;
        ELSE
          data_size := amount_to_read;
        IFEND;
        IF data_size = 0 THEN
          osp$system_error ('Incorrect deadstart tape.', NIL);
        IFEND;
        NEXT block_data_p: [[REP data_size OF cell]] IN io_buffer_seq_p;
        NEXT data_p: [[REP data_size OF cell]] IN data_buffer_p;
        data_p^ := block_data_p^;

        data_size_read := data_size_read + data_size;
        amount_to_read := amount_to_read - data_size;
        io_data.disk.buffer_amount := io_data.disk.buffer_amount - data_size;
        io_data.disk.file_size := io_data.disk.file_size - data_size;

      ELSE
        osp$system_error ('The deadstart device is unknown', NIL);
      CASEND;

    UNTIL amount_to_read <= 0; {read_file_data
    RESET data_buffer_p;

    CASE io_data.unit_class OF
    = cmc$magnetic_tape_unit =
      io_data.data_end_mark_reached := (io_data.data_end_mark_read AND
            (io_data.tape.current_block > io_data.tape.blocks_read));
    = cmc$mass_storage_unit =
      io_data.data_end_mark_reached := (io_data.data_end_mark_read AND (io_data.disk.file_size <= 0));
    ELSE
    CASEND;

  PROCEND dsp$read_deadstart_device;
?? TITLE := 'dsp$read_header_labels', EJECT ??

{ PURPOSE:
{   This procedure is called to read the header labels from the deadstart file.  The procedure
{   will first make sure that the last file's data end mark has been reached.  The procedure then
{   will skip over the EOFN labels, read the HDR1 and HDR2 labels and then skip to the data end mark.

  PROCEDURE [XDCL, #GATE] dsp$read_header_labels
    (VAR file_identifier: dst$deadstart_file_identifier);

    VAR
      hdr1_label_p: ^fst$ansi_hdr1_label,
      hdr2_label_p: ^fst$ansi_hdr2_label,
      label_found: boolean,
      label_id: deadstart_label_id;

    { Skip over any unused data on the individual file.

    skip_to_next_data_end;

    { Skip over the EOFN records.

    skip_to_next_data_end;

    io_data.disk.file_size := #SIZE (fst$ansi_hdr1_label) + #SIZE (fst$ansi_hdr2_label);

    { Read the HDR1 label and retrieve the file identifier.

    read_label (label_seq_p, label_id, label_found);
    IF NOT label_found OR (label_id <> 'HDR1') THEN
      osp$system_error ('Incorrect deadstart file: No HDR1 label', NIL);
    IFEND;
    NEXT hdr1_label_p IN label_seq_p;
    file_identifier := hdr1_label_p^.file_identifier;

    { Read the HDR2 label and retrieve the preceeding file size for disk deadstarts.

    read_label (label_seq_p, label_id, label_found);
    IF NOT label_found OR (label_id <> 'HDR2') THEN
      osp$system_error ('Incorrect deadstart file: No HDR2 label', NIL);
    IFEND;
    NEXT hdr2_label_p IN label_seq_p;
    io_data.header_information.block_type := hdr2_label_p^.ve_block_type;
    io_data.header_information.record_type := hdr2_label_p^.ve_record_type;

    { Skip over any more HDRN labels.

    skip_to_next_data_end;

    IF io_data.unit_class = cmc$mass_storage_unit THEN
      convert_string_to_file_size (hdr2_label_p^);
    IFEND;

  PROCEND dsp$read_header_labels;
?? TITLE := 'dsp$retrieve_device_address', EJECT ??

{ PURPOSE:
{   This procedure is used to retrieve the device address from the logical unit.

  PROCEDURE [XDCL] dsp$retrieve_device_address
    (    transfer_size: integer;
     VAR device_address: dmt$ms_logical_device_address);

    VAR
      physical_attributes_p: ^dmt$physical_device_attributes,
      status: ost$status;

    PUSH physical_attributes_p: [1 .. 2];
    physical_attributes_p^ [1].keyword := dmc$bytes_per_mau;
    physical_attributes_p^ [2].keyword := dmc$maus_per_cylinder;
    dmp$get_physical_attributes (cmv$system_device_data [cmc$sdt_disk_device].unit_id, physical_attributes_p,
          status);
    IF NOT status.normal THEN
      osp$system_error ('Disk initialization failed', ^status);
    IFEND;

    cmp$get_logical_unit_number (cmv$system_device_data [cmc$sdt_disk_device].unit_name,
          device_address.logical_unit_number, status);
    IF NOT status.normal THEN
      osp$system_error ('Error in getting logical unit number', ^status);
    IFEND;
    device_address.maus_per_position := physical_attributes_p^ [2].maus_per_cylinder;
    device_address.transfer_length := transfer_size DIV physical_attributes_p^ [1].bytes_per_mau;
    device_address.transfer_mau_offset := 0;
    device_address.write_translation := FALSE;

  PROCEND dsp$retrieve_device_address;
?? TITLE := 'dsp$retrieve_header_information', EJECT ??

{ PURPOSE:
{   This procedure retrieves information from the tape label.  A disk deadstart file contains the
{   same label format.

  PROCEDURE [XDCL, #GATE] dsp$retrieve_header_information
    (VAR header_information: dst$header_information);

    IF io_data.header_information.block_type = 'US' THEN
      header_information.block_type := amc$user_specified;
    ELSE
      header_information.block_type := amc$system_specified;
    IFEND;

    IF io_data.header_information.record_type = 'V' THEN
      header_information.record_type := amc$variable;
    ELSE
      header_information.record_type := amc$undefined;
    IFEND;

  PROCEND dsp$retrieve_header_information;
MODEND dsm$deadstart_io;
*DECK DECK=DSM$DEADSTART_NOS_VE EXPAND=TRUE
?? RIGHT := 110 ??
MODULE dsm$deadstart_nos_ve ALIAS 'DSMDNV';

*copy pxiotyp
?? PUSH (LISTEXT := ON) ??
*copy pxziobs
*copy lgzclos
*copy lgzget
*copy lgzopen
*copy lgzgetp
*copy fzmark
*copy fzwords
*copyc zuttpfd
*copyc zn7ppfm
?? POP ??
*copy dsc$constant_definitions
*copy dsd$os_global_variables
*copy dsp$dst_global_variables
*copy dsp$copy_memory
*copy dsi$virtual_memory_access
*copyc dsi$support_eicb_version_4
*copyc dst$dual_state_control_block_cc
?? SKIP := 3 ??

  PROCEDURE clear_memory (address: integer;
        length: integer);

    VAR
      i: integer,
      size: integer,
      clear_request: memory_copy_header,
      buffer: array [1 .. 1000] of integer;

    size := length DIV 8;
    clear_request.pva_type := start_of_ve;
    clear_request.copy_method := nos60_to_ve60;
    clear_request.byte_rma := address;
    clear_request.length := 1000;

    FOR i := 1 TO 1000 DO
      buffer [i] := 0;
    FOREND;

    REPEAT
      IF size < 1000 THEN
        clear_request.length := size;
      IFEND;
      copy_memory (clear_request, ^buffer);
      size := size - clear_request.length;
      clear_request.byte_rma := clear_request.byte_rma + clear_request.length *
            8;
    UNTIL size = 0;
  PROCEND clear_memory;
*copy dsi$display_dayfile_message
*copy dsc$job_control_registers
*copy dsp$callsda
*copy dsp$callver
*copy dsi$deadstart_utilities
*copy dsi$k_display_control
*copy dsi$deadstart_command_processor
*copy dsi$c170_access_to_ssr
*copy dsi$transmit_data_via_ssr
?? NEWTITLE := '~~~~~   ssr service routines', EJECT ??

  PROCEDURE store_ssr_slot (name: string (4);
        slot: integer);

    VAR
      entry: integer;

    find_ssr_entry (name, entry);
    store_ssr_data (entry + 4, ^slot, 1);
  PROCEND store_ssr_slot;
?? SKIP := 3 ??

  PROCEDURE build_r_addr (VAR address: integer;
        p: dst$r_pointer);

    address := p.offset + p.rlower * 100(8) + p.rupper * 1000000(8);
  PROCEND build_r_addr;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   define central memory configuration', EJECT ??
{**********************************************************}

  VAR
    memory_available: integer,
    memory_assigned: integer,
    ssr_length: [STATIC] integer := 0,
    ssr_address: [STATIC] integer := 0,
    actual_page_size: integer,
    page_table_length: integer,
    actual_load_address: integer;

?? SKIP := 3 ??
{**********************************************************}

  PROCEDURE check_environment;

    VAR
      i: integer;

    IF NOT got_eicb_d7ty THEN
      get_dscb(dscb_d7ty,^d7ty, 1);
      { the eicb entry d7ty.eicb_version will be used to choose VER functions
      got_eicb_d7ty:= TRUE;
    IFEND;

{}
{ check for any PP's assigned to NOS/ve
{}
    FOR i := 1 TO 20 DO
      IF i < 11 THEN
        ver_request.pps [i].primary := i - 1;
      ELSE
        ver_request.pps [i].primary := i + 5;
      IFEND;
      ver_request.pps [i].kind := 0;
      ver_request.pps [i].fill := 0;
      ver_request.pps [i].status := 0;
    FOREND;
    ver_request.return_all := FALSE;
    ver_request.length := 20;
    ver_request.general_status := 0;
    IF d7ty.eicb_version < dsc$eicb_version_4 THEN
      { try old code on ver request
      callver (ver_request, stpp, TRUE);
    ELSE
      { try new ( ie. NOS 2.5.1 ) request code
      callver (ver_request, stpt, TRUE);
    IFEND;
    FOR i := 1 TO 20 DO
      IF ver_request.pps [i].status <= 1 THEN
        error_processor (pp_illegally_assigned_to_nve, fatal_error);
      IFEND;
    FOREND;
{}
{ validate cm requirements
{}
    ver_request.general_status := 0;
    ver_request.length := 2;
    callver (ver_request, stmr, TRUE);
    memory_available := ver_request.resources.available_words_div_1000 *
          bytes_per_octal_1k_words;
    ver_request.general_status := 0;
    callver (ver_request, stcm, TRUE);
    load_offset_bytes := ver_request.cm_block.fwa_div_1000 *
          bytes_per_octal_1k_words;
    memory_assigned := ver_request.cm_block.words_div_1000 *
          bytes_per_octal_1k_words;
    IF nve_memory = 0 THEN
      nve_memory := memory_available + memory_assigned;
    IFEND;
    IF (nve_memory < min_nve_memory) THEN
      error_processor (chosen_memory_less_then_nve_min, fatal_error);
    IFEND;
    dyfstrnum ('memory request', nve_memory, user_dayf);
  PROCEND check_environment;
?? EJECT ??
{**********************************************************}

  PROCEDURE set_nve_load_address;

{ Request whatever memory is needed to run ve.

    IF nve_memory > memory_assigned THEN
      ver_request.general_status := 0;
      ver_request.length := 2;
      ver_request.cm_block.words_div_1000 := (nve_memory - memory_assigned) DIV
            bytes_per_octal_1k_words;
      callver (ver_request, rscm, TRUE);
      IF (ver_request.general_status > 1) THEN
        error_processor (unable_to_obtain_request_memory, fatal_error);
      IFEND;
      load_offset_bytes := ver_request.cm_block.fwa_div_1000 *
            bytes_per_octal_1k_words;
      nve_memory := ver_request.cm_block.words_div_1000 *
            bytes_per_octal_1k_words;
    IFEND;

{ Form word address for memory limit.
    memory_limit := (load_offset_bytes + nve_memory) DIV 8;
    dyfstrnum ('load offset', load_offset_bytes, user_dayf);
    dyfstrnum ('memory size', memory_limit * 8, user_dayf);

  PROCEND set_nve_load_address;
?? OLDTITLE ??
?? EJECT ??

  PROCEDURE deadstart_nve;

    VAR
      cm_copy_info: [STATIC] memory_copy_header := [0, nos32_to_ve64,
        interface_block, 0],
      ii: integer,
      left: integer,
      right: integer,
      veparam: packed record
        fill1: 0 .. 0fffffff(16),
        stack_rma: 0 .. 0ffffffff(16),
        fill2: 0 .. 0fffffff(16),
        jps_rma: 0 .. 0ffffffff(16),
      recend;

{ provide a save area for the NOS stack

    dyfstring ('deadstartve.', debug_log);
    veparam.jps_rma := 0;
    find_ssr_entry (dsc$ssr_driver_code_buffer, ii);
    get_ssr_directory_entry (ii, left, right);
    veparam.stack_rma := (ssr_address_words + right) * 8;
    cm_copy_info.byte_rma := (dscb_d8ds + 2) * 8;
    cm_copy_info.length := 2;
    copy_memory (cm_copy_info, ^veparam);

{}
{stop C170 environment and start NOS/VE deadstart}
{initialization}
{}
    deadstart_cpu (start_dual_state);
{}
  PROCEND deadstart_nve;
?? NEWTITLE := '~~~~~   respond to nve requests', EJECT ??
*copyc dsp$claim_nve_resources

  PROCEDURE respond_to_nve_requests;

    VAR
      block: ^SEQ ( * ),
      rma: integer,
      nve_request_p: ^dst$170_request_block;

    REPEAT
      dsp$receive_data_via_ssr (block);
      IF block <> NIL THEN
        dyfstring ('Process ve request.', debug_log);
        NEXT nve_request_p IN block;
        CASE nve_request_p^.request OF

        = dsc$170_rb_request_resources, dsc$170_rb_update_free_clock =
          dsp$claim_nve_resources (nve_request_p^);

        = dsc$170_rb_call_dft_through_sda =
          rma := nve_request_p^.dft_request_rma DIV 8;
          pp_table.ssr_buffer.offset := rma MOD 100(8);
          pp_table.ssr_buffer.rlower := (rma DIV 100(8)) MOD 10000(8);
          pp_table.ssr_buffer.rupper := rma DIV 1000000(8);
          callsda (call_dft, pp_table);

        = dsc$170_rb_complete_deadstart =
          dyfstring ('complete deadstart', user_dayf);
          IF NOT nve_request_p^.terminating THEN
            jcr.r2 := xecute_runve;
            jcrset;
          IFEND;
          RETURN;

        ELSE
          error_processor (incorrect_nve_request, fatal_error);
        CASEND;
        dsp$send_data_via_ssr (block, #SIZE (block^));
        FREE block;
      ELSE
        wakeup;
        wakeup;
      IFEND;
    UNTIL FALSE;
  PROCEND respond_to_nve_requests;
?? OLDTITLE ??
?? EJECT ??

  PROCEDURE establish_ds_environment;

    check_environment;
    normalize_environment;
    set_nve_load_address;
  PROCEND establish_ds_environment;
?? SKIP := 3 ??

  PROCEDURE load_pp_boot (pp: integer);
    find_ssr;
    dyfstrnum ('load vpb.', pp, debug_log);
    dyfstring ('sci loading vcb.', user_dayf);
    pp_table.pp_number := pp;
    callsda (load_vpb, pp_table);
    dyfstring ('vcb loaded.', user_dayf);
  PROCEND load_pp_boot;
?? SKIP := 3 ??

{ PURPOSE:
{   Return a PP to C170 through the VER interface.

  PROCEDURE return_pp (pp: integer);

    IF NOT got_eicb_d7ty THEN
      get_dscb(dscb_d7ty,^d7ty, 1);
      { the eicb entry d7ty.eicb_version will be used to choose VER functions
      got_eicb_d7ty:= TRUE;
    IFEND;

    ver_request.return_all := FALSE;
    ver_request.general_status := 0;
    ver_request.length := 1;
    ver_request.pp.primary := pp;

    IF d7ty.eicb_version < dsc$eicb_version_4 THEN
      { use pre NOS 2.5.1 request code
      ver_request.pp.kind := 0;
      callver (ver_request, rtpp, TRUE);
    ELSE
      { use NOS 2.5.1 request code
      ver_request.pp.kind := non_driver_pp;
      callver (ver_request, rnpt, TRUE);
    IFEND;
  PROCEND return_pp;
?? SKIP := 3 ??

  PROCEDURE assign_pps;

    CONST
      boot_not_loaded = 2,
      deadstart_ok = 1;

    VAR
      pp: integer,
      d8st: dst$dscb_cc_d8st_word;

    PROCEDURE [XREF] obtain_pp (VAR pp: integer);

    dyfstring ('assign pps.', debug_log);

{  Obtain a PP in which to load *SCI*.  If *SDA* determines that *SCI* is
{  already executing in a PP, then the PP obtained here will be returned.

    obtain_pp (pp);
    load_pp_boot (pp);
    get_dscb (dscb_d8st, ^d8st, 1);
    WHILE d8st.sci_deadstart_status = 0 DO
      wakeup;
      get_dscb (dscb_d8st, ^d8st, 1);
    WHILEND;
    IF NOT d8st.nosve_owns_sci_pp THEN
      return_pp (pp);
    ELSE
      d8st.sci_pp_number := pp;
    IFEND;
    IF d8st.sci_deadstart_status = deadstart_ok THEN
      put_dscb (dscb_d8st, ^d8st, 1);
    ELSEIF d8st.sci_deadstart_status = boot_not_loaded THEN
      error_processor (nosve_boot_progs_not_installed, fatal_error);
    IFEND;
  PROCEND assign_pps;
?? SKIP := 3 ??

  PROCEDURE find_ssr;

    VAR
      i: integer,
      ssr_ptr: dst$r_pointer;

    dyfstring ('find ssr.', debug_log);
    get_dscb (dscb_ssrptr, ^ssr_ptr, 1);
    build_r_addr (ssr_address_words, ssr_ptr);

{ define EI rma.}
    IF ssr_address_words > 0 THEN
      dyfstrnum ('ssr address', ssr_address_words, user_dayf);
      set_ei_pva (start_of_ssr, ssr_address_words);
    IFEND;
  PROCEND find_ssr;
?? SKIP := 3 ??

{ PURPOSE:
{   This procedure updates the SSR when deadstart is initiated.

  PROCEDURE update_ssr;

    VAR
      left: integer,
      right: integer,
      ssr_entry_offset: integer,
      transfer_buffer_offset: integer,
      minilink_transfer_entry: transfer_entry;

    find_ssr;
    dyfstring ('update ssr.', debug_log);

    { Save the operator intervention flag in the SSR.

    find_ssr_entry (dsc$ssr_operator_intervention, ssr_entry_offset);
    set_ssr_directory_entry (ssr_entry_offset, 0, $INTEGER (dsv$ssr_operator_intervention));

 {  Initialize C70B and C80B for minilink communications in the event
 {  system terminated while minilink was in use.

    find_ssr_entry (dsc$ssr_c170_transfer_buffer, ssr_entry_offset);
    get_ssr_directory_entry (ssr_entry_offset, left, right);
    transfer_buffer_offset := right * 8;
    minilink_transfer_entry.offset := 0;
    minilink_transfer_entry.length := 0;
    store_ssr_data (transfer_buffer_offset, ^minilink_transfer_entry, 2);

    find_ssr_entry (dsc$ssr_c180_transfer_buffer, ssr_entry_offset);
    get_ssr_directory_entry (ssr_entry_offset, left, right);
    transfer_buffer_offset := right * 8;
    store_ssr_data (transfer_buffer_offset, ^minilink_transfer_entry, 2);

  PROCEND update_ssr;
?? NEWTITLE := '~~~~~   Normalize the EICB', EJECT ??
{*********************************************************}
{}
{normalize environment for level zero deadstart}
{}

  PROCEDURE normalize_environment;

    TYPE
      mtt$dscb_os_status_flags = packed record
        operational_mode: boolean,
        maintenance_mode: boolean,
        step_mode: boolean,
        bit56_bit52: 0 .. 37(8),
        checkpoint_complete: boolean,
        checkpoint_in_progress: boolean,
        bit49_bit48: 0 .. 3,
      recend;

    VAR
      d7st: packed record
        status_flags: mtt$dscb_os_status_flags,
        ep_status: 0 .. 03777(8),
        drop_ve_flag: boolean,
        rfu: 0 .. 777777777777(8),
      recend;

{}
{delete dropve bit and rewrite c7st word.}
{}
    get_dscb (dscb_d7st, ^d7st, 1);
    d7st.drop_ve_flag := FALSE;
    put_dscb (dscb_d7st, ^d7st, 1);
{}
  PROCEND normalize_environment;
?? OLDTITLE ??
?? EJECT ??

  PROCEDURE initialize_dstve;

    TYPE
      vebtype = PACKED RECORD
        value : 0 .. 7777(8),
        fill : 0 .. 7777777777777777(8),
      RECEND;

    VAR
      logical_cm_gt_256_mb: boolean,
      memory_size: integer,
      ve_status: integer,
      veb : vebtype;

{}
{Ensure VE is enabled in CMRDECK.
{}
    pp_table.size := #SIZE(veb);
    pp_table.data_buffer := ^veb;
    callsda (fetch_ve_enabled_status, pp_table);
    IF veb.value = 0 THEN
      error_processor (ve_not_enabled_in_cmrdeck, fatal_error)
    IFEND;
{}
{read command file}
{}
    mycmnds := 'cmdfile';
    lg#open (command_file, mycmnds, old#, input#, first#);
    f#mark (command_file, file_mark_position);
    IF ((file_mark_position = eoi#) OR (file_mark_position = eof#)) THEN
      active_cmnds_file := FALSE;
    ELSE
      active_cmnds_file := TRUE;
    IFEND;
    line_position := 4;
    beginning_line_position := line_position;

    jcrget;
    jcr.error_flag := 0;
    jcr.global_error_flag := 0;
    jcr.r2 := xecute_trmve;
    jcrset;

    ver_request.general_status := 0;
    ver_request.length := 2;
    ver_request.cm_block.words_div_1000 := 0;
    ver_request.cm_block.lwa_div_1000 := 0;
    callver (ver_request, stcm, TRUE);
    IF ver_request.general_status = 1 THEN
      memory_size := ver_request.cm_block.lwa_div_1000 *
           bytes_per_octal_1k_words;
      logical_cm_gt_256_mb := ((memory_size DIV 100000(16)) > 256);
    ELSE
      logical_cm_gt_256_mb := FALSE;
    IFEND;

    read_deadstart_command_file(logical_cm_gt_256_mb);

{}
{check for nosve already running and stop deadstart when true}
{}
    get_ve_status (ve_status);
    IF exitcd <> 0 THEN
      error_processor (attempted_to_ds_a_running_nosve, fatal_error);
    IFEND;

  PROCEND initialize_dstve;
?? NEWTITLE := '~~~~~   MAIN DSTVE PROGRAM', EJECT ??
{}
{BEGIN MAIN DSTVE PROGRAM}
{}

  PROGRAM [XDCL] dspdst;

{}
{initialize dstve
{}
    makscpb; { make me a busy system controlpoint }
    convert_title ('  DEADSTART VE  ');
    initialize_dstve;
{}
{Start NVE deadstart}
{}

    establish_ds_environment;
    assign_pps;
    update_ssr;
    deadstart_nve;
    respond_to_nve_requests;

    endprgr;
{}
  PROCEND dspdst;
MODEND dsm$deadstart_nos_ve;
*DECK DECK=DSM$DEADSTART_SERVICES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Miscellaneous Procedures' ??
MODULE dsm$deadstart_services;

{ PURPOSE:
{   This module contains utility procedures used during and after the deadstart process.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmt$channel_type
*copyc cyd$cybil_structure_definitions
*copyc dse$error_codes
*copyc dst$boot_data_kinds
*copyc dst$change_processor_state
*copyc dst$channel_state
*copyc dst$cpu_attributes
*copyc dst$dft_requests
*copyc dst$iou_information_table
*copyc osc$maximum_processors
*copyc oss$mainframe_pageable
*copyc ost$heap
*copyc ost$iou_model_number
*copyc ost$processor_id
?? POP ??
*copyc clp$convert_integer_to_string
*copyc dsp$access_secure_mode
*copyc dsp$access_vcu_cda_data
*copyc dsp$change_cy2000_element
*copyc dsp$get_cy2000_element
*copyc dsp$get_data_from_ssr
*copyc dsp$get_entry_from_ssr
*copyc dsp$get_iou_status_register
*copyc dsp$manage_virtual_cpu
*copyc dsp$read_mrt_entry
*copyc dsp$start_additional_cpu
*copyc dsp$store_data_in_ssr
*copyc dsp$write_mrt_entry
*copyc i#real_memory_address
*copyc osp$extend_heap
*copyc osp$fatal_system_error
*copyc osp$free_heap_pages
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$zero_out_table
?? EJECT ??
*copyc avv$security_options
*copyc dsv$automatic_pp_reload
*copyc dsv$mainframe_type
*copyc dsv$mf_element_table_p
*copyc dsv$mtr_dft_requests
*copyc jmv$sdt
*copyc mmv$pft_p
*copyc mtv$cst0
*copyc mtv$scb
*copyc osv$mainframe_wired_heap
*copyc osv$mainframe_wired_cb_heap
*copyc osv$page_size
*copyc osv$boot_sdte
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  CONST
    c$number_of_memory_elements = 1,
    c$number_of_page_map_elements = 1;

  TYPE
    t$boot_data_list = ARRAY [dst$boot_data_kinds] OF REL (SEQ ( * )) ^SEQ ( * );

  VAR
    dsv$boot_data_base_p: [XDCL] ^SEQ ( * ) := NIL,


    v$iou_information_table: [STATIC, oss$mainframe_pageable] dst$iou_information_table,
    v$mrt_channel_types: [STATIC, oss$mainframe_pageable]
          ARRAY [dst$iou_number] OF
          ARRAY [dst$channel_protocol_type] OF
          ARRAY [dst$physical_resource_number] OF RECORD
            known_channel_type: boolean,
            channel_type: cmt$channel_type,
          RECEND,
    v$number_of_ious: [STATIC, oss$mainframe_pageable] 0 .. dsc$max_number_of_ious;
?? OLDTITLE ??
?? NEWTITLE := 'build_channel_types_table', EJECT ??

{ PURPOSE:
{   This procedure builds the table containing channel types.

  PROCEDURE build_channel_types_table
    (    model_type: dst$iou_model_types;
         iou_number: dst$iou_number;
         mrt_entry: dst$mrt_entry);

?? NEWTITLE := 'retrieve_channel_types', EJECT ??

{ PURPOSE:
{   This procedure retrieves the channel types from the MRT.

    PROCEDURE retrieve_channel_types
      (    number_of_entries: 1 .. 12;
           iou_number: dst$iou_number;
           channel_protocol: dst$channel_protocol_type;
           mrt_channel_types: ARRAY [1 .. *] OF dst$mrt_two_channel_descriptor);

      VAR
        index: 1 .. 12,
        number: 0 .. 34(8);

      number := 0;
      FOR index := 1 TO number_of_entries DO

        { Retrieve the channel type from the 'a' channel entry in the two channel entry from the MRT.

        v$mrt_channel_types [iou_number] [channel_protocol] [number].known_channel_type := TRUE;
        CASE mrt_channel_types [index].a_channel_type OF
        = dsc$mrt_ct_cyber_170_channel, dsc$mrt_ct_170_dma_esm_enhanced =
          v$mrt_channel_types [iou_number] [channel_protocol] [number].channel_type := cmc$170_channel;
        = dsc$mrt_ct_ici_s0 =
          v$mrt_channel_types [iou_number] [channel_protocol] [number].channel_type := cmc$ici_channel;
        = dsc$mrt_ct_isi_channel, dsc$mrt_ct_isi_dma_channel =
          v$mrt_channel_types [iou_number] [channel_protocol] [number].channel_type := cmc$isi_channel;
        = dsc$mrt_ct_ipi_dma_enhanced, dsc$mrt_ct_ipi_s0, dsc$mrt_ct_ipi_dma_dual_port =
          v$mrt_channel_types [iou_number] [channel_protocol] [number].channel_type := cmc$ipi_channel;
        ELSE
          v$mrt_channel_types [iou_number] [channel_protocol] [number].known_channel_type := FALSE;
        CASEND;
        number := number + 1;

        { Retrieve the channel type from the 'b' channel entry in the two channel entry from the MRT.

        v$mrt_channel_types [iou_number] [channel_protocol] [number].known_channel_type := TRUE;
        CASE mrt_channel_types [index].b_channel_type OF
        = dsc$mrt_ct_cyber_170_channel, dsc$mrt_ct_170_dma_esm_enhanced =
          v$mrt_channel_types [iou_number] [channel_protocol] [number].channel_type := cmc$170_channel;
        = dsc$mrt_ct_ici_s0 =
          v$mrt_channel_types [iou_number] [channel_protocol] [number].channel_type := cmc$ici_channel;
        = dsc$mrt_ct_isi_channel, dsc$mrt_ct_isi_dma_channel =
          v$mrt_channel_types [iou_number] [channel_protocol] [number].channel_type := cmc$isi_channel;
        = dsc$mrt_ct_ipi_dma_enhanced, dsc$mrt_ct_ipi_s0, dsc$mrt_ct_ipi_dma_dual_port =
          v$mrt_channel_types [iou_number] [channel_protocol] [number].channel_type := cmc$ipi_channel;
        ELSE
          v$mrt_channel_types [iou_number] [channel_protocol] [number].known_channel_type := FALSE;
        CASEND;
        number := number + 1;
        IF number = 14(8) THEN
          number := 20(8);
        IFEND;
      FOREND;

    PROCEND retrieve_channel_types;

?? OLDTITLE, EJECT ??

    VAR
      mrt_channel_types: ARRAY [1 .. 12] OF dst$mrt_two_channel_descriptor;

    { Retrieve the NIO channel states.

    mrt_channel_types [1] := mrt_entry.iou.channel_00_01;
    mrt_channel_types [2] := mrt_entry.iou.channel_02_03;
    mrt_channel_types [3] := mrt_entry.iou.channel_04_05;
    mrt_channel_types [4] := mrt_entry.iou.channel_06_07;
    mrt_channel_types [5] := mrt_entry.iou.channel_10b_11b;
    mrt_channel_types [6] := mrt_entry.iou.channel_12b_13b;
    mrt_channel_types [7] := mrt_entry.iou.channel_20b_21b;
    mrt_channel_types [8] := mrt_entry.iou.channel_22b_23b;
    mrt_channel_types [9] := mrt_entry.iou.channel_24b_25b;
    mrt_channel_types [10] := mrt_entry.iou.channel_26b_27b;
    mrt_channel_types [11] := mrt_entry.iou.channel_30b_31b;
    mrt_channel_types [12] := mrt_entry.iou.channel_32b_33b;

    IF model_type = dsc$imn_i4_44_model THEN
      retrieve_channel_types (12, iou_number, dsc$cpt_cio, mrt_channel_types);
    ELSE
      retrieve_channel_types (12, iou_number, dsc$cpt_nio, mrt_channel_types);

      { Retrieve the CIO channel states.

      mrt_channel_types [1] := mrt_entry.iou.i4_cio_channel_00_01;
      mrt_channel_types [2] := mrt_entry.iou.i4_cio_channel_02_03;
      mrt_channel_types [3] := mrt_entry.iou.i4_cio_channel_04_05;
      mrt_channel_types [4] := mrt_entry.iou.i4_cio_channel_06_07;
      mrt_channel_types [5] := mrt_entry.iou.i4_cio_channel_10b_11b;

      retrieve_channel_types (5, iou_number, dsc$cpt_cio, mrt_channel_types);
    IFEND;

  PROCEND build_channel_types_table;
?? OLDTITLE ??
?? NEWTITLE := 'build_iou_table', EJECT ??

{ PURPOSE:
{   This procedure places iou information in the iou information table.

  PROCEDURE build_iou_table
    (    iou_index: dst$iou_number;
         model_number: 0 .. 0fff(16));

    v$number_of_ious := v$number_of_ious + 1;
    v$iou_information_table [v$number_of_ious].physical_iou_number := iou_index;

    { Setup the IOU MODEL TYPE from the model number in the MRT.

    CASE model_number OF
    = osc$imn_10 =
      v$iou_information_table [v$number_of_ious].model_type := dsc$imn_i1_10_model;
    = osc$imn_11 =
      v$iou_information_table [v$number_of_ious].model_type := dsc$imn_i1_11_model;
    = osc$imn_12 =
      v$iou_information_table [v$number_of_ious].model_type := dsc$imn_i1_12_model;
    = osc$imn_13 =
      v$iou_information_table [v$number_of_ious].model_type := dsc$imn_i1_13_model;
    = osc$imn_14 =
      v$iou_information_table [v$number_of_ious].model_type := dsc$imn_i1_14_model;
    = osc$imn_20 =
      v$iou_information_table [v$number_of_ious].model_type := dsc$imn_i2_20_model;
    = osc$imn_40 =
      v$iou_information_table [v$number_of_ious].model_type := dsc$imn_i4_40_model;
    = osc$imn_42 =
      v$iou_information_table [v$number_of_ious].model_type := dsc$imn_i4_42_model;
    = osc$imn_44 =
      v$iou_information_table [v$number_of_ious].model_type := dsc$imn_i4_44_model;
    = osc$imn_46 =
      v$iou_information_table [v$number_of_ious].model_type := dsc$imn_i4_46_model;
    = osc$imn_50, osc$imn_51, osc$imn_52, osc$imn_53, osc$imn_54, osc$imn_55,
      osc$imn_5B, osc$imn_5C, osc$imn_5D, osc$imn_5E, osc$imn_5F =
      v$iou_information_table [v$number_of_ious].model_type := dsc$imn_i0_5x_model;
    ELSE
      osp$system_error ('Unrecognized IOU model number in the MRT', NIL);
    CASEND;

  PROCEND build_iou_table;
?? OLDTITLE ??
?? NEWTITLE := 'build_mainframe_element_entry', EJECT ??

{ PURPOSE:
{   This procedure builds a table entry from data in the element id from the MRT.
{   An output variable is used as an accumulator for the number of elements in the table.

  PROCEDURE build_mainframe_element_entry
    (    element_number: 0 .. 0ff(16);
         element_id: dst$dft_element_id;
     VAR actual_number_of_elements: ost$processor_element_number;
     VAR element_table_p: ^SEQ ( * ));

    VAR
      element_entry_p: ^dst$mf_element_table_entry,
      ignore_status: ost$status,
      number_string: ost$string;

    NEXT element_entry_p IN element_table_p;
    actual_number_of_elements := actual_number_of_elements + 1;
    element_entry_p^.element_id.element_number := element_number;
    element_entry_p^.element_id.dft_entry_id := element_id.element_number;
    element_entry_p^.model_number := element_id.model_number;
    element_entry_p^.serial_number := element_id.serial_number;

    clp$convert_integer_to_string (element_number, 16, FALSE, number_string, ignore_status);
    element_entry_p^.element_number_string.size := number_string.size;
    element_entry_p^.element_number_string.value := number_string.value;
    clp$convert_integer_to_string (element_entry_p^.model_number, 16, FALSE, number_string, ignore_status);
    element_entry_p^.model_number_string.size := number_string.size;
    element_entry_p^.model_number_string.value := number_string.value;
    clp$convert_integer_to_string (element_entry_p^.serial_number, 16, FALSE, number_string, ignore_status);
    element_entry_p^.serial_number_string.size := number_string.size;
    element_entry_p^.serial_number_string.value := number_string.value;

  PROCEND build_mainframe_element_entry;
?? OLDTITLE ??
?? NEWTITLE := 'cy2000_build_ch_types_table', EJECT ??

{ PURPOSE:
{   This procedure builds the table containing channel types for a Cyber 2000 mainframe.

  PROCEDURE cy2000_build_ch_types_table
    (    iou_number: dst$iou_number;
         element_id: 0 .. 0ff(16);
     VAR status: ost$status);

    VAR
      channel_element: dst$dft_get_channel_element,
      channel_element_seq_p: ^SEQ ( * ),
      channel_type: 0 .. 0ff(16),
      number: 0 .. 34(8);

    channel_element_seq_p := #SEQ (channel_element);
    RESET channel_element_seq_p;
    dsp$get_cy2000_element (element_id, dsc$dft_sub_channel, channel_element_seq_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    number := 0;
    WHILE number <= 33(8) DO
      IF number <= 13(8) THEN
        channel_type := channel_element.lower_channels [number].channel_type;
      ELSE
        channel_type := channel_element.upper_channels [number].channel_type;
      IFEND;
      CASE channel_type OF
      = dsc$mrt_ct_cyber_170_channel =
        v$mrt_channel_types [iou_number] [dsc$cpt_nio] [number].known_channel_type := TRUE;
        v$mrt_channel_types [iou_number] [dsc$cpt_nio] [number].channel_type := cmc$170_channel;
      = dsc$mrt_ct_170_dma_esm_enhanced =
        v$mrt_channel_types [iou_number] [dsc$cpt_cio] [number].known_channel_type := TRUE;
        v$mrt_channel_types [iou_number] [dsc$cpt_cio] [number].channel_type := cmc$170_channel;
      = dsc$mrt_ct_ici_s0 =
        v$mrt_channel_types [iou_number] [dsc$cpt_cio] [number].known_channel_type := TRUE;
        v$mrt_channel_types [iou_number] [dsc$cpt_cio] [number].channel_type := cmc$ici_channel;
      = dsc$mrt_ct_isi_channel, dsc$mrt_ct_isi_dma_channel =
        v$mrt_channel_types [iou_number] [dsc$cpt_cio] [number].known_channel_type := TRUE;
        v$mrt_channel_types [iou_number] [dsc$cpt_cio] [number].channel_type := cmc$isi_channel;
      = dsc$mrt_ct_ipi_dma_enhanced, dsc$mrt_ct_ipi_s0, dsc$mrt_ct_ipi_dma_dual_port =
        v$mrt_channel_types [iou_number] [dsc$cpt_cio] [number].known_channel_type := TRUE;
        v$mrt_channel_types [iou_number] [dsc$cpt_cio] [number].channel_type := cmc$ipi_channel;
      ELSE
      CASEND;
      number := number + 1;
      IF number = 14(8) THEN
        number := 20(8);
      IFEND;
    WHILEND;

  PROCEND cy2000_build_ch_types_table;
?? OLDTITLE ??
?? NEWTITLE := 'cy2000_build_mf_information', EJECT ??

{ PURPOSE:
{   This procedure builds the mainframe tables for a Cyber 2000 mainframe.

  PROCEDURE cy2000_build_mf_information;

    VAR
      actual_number_of_elements: ost$processor_element_number,
      cpu_element: dst$dft_get_cpu_element,
      cpu_index: ost$logical_processor_id,
      element_entry_p: ^dst$mf_element_table_entry,
      element_id: 0 .. 0ff(16),
      element_seq_p: ^SEQ ( * ),
      entry_index: ost$processor_element_number,
      iou_element: dst$dft_get_iou_element,
      iou_index: dst$iou_number,
      memory_element: dst$dft_get_memory_element,
      mode: 0 .. 0ffff(16),
      possible_number_of_elements: ost$processor_element_number,
      status: ost$status,
      temp_element_table_p: ^SEQ ( * );

    actual_number_of_elements := 0;
    possible_number_of_elements := osc$maximum_processors + c$number_of_memory_elements +
          dsc$max_number_of_ious;
    PUSH temp_element_table_p: [[REP possible_number_of_elements OF dst$mf_element_table_entry]];
    RESET temp_element_table_p;

    { Retrieve the CPU information from the MRT and build the CPU entry in the mainframe element table.

    element_id := dsc$dftb_eid_cpu0_element;
    element_seq_p := #SEQ (cpu_element);
    FOR cpu_index := LOWERVALUE (ost$logical_processor_id) TO UPPERVALUE (ost$logical_processor_id) DO
      RESET element_seq_p;
      dsp$get_cy2000_element (element_id, dsc$dft_sub_none, element_seq_p, status);
      IF status.normal AND (cpu_element.state <> dsc$dft_state_not_installed) THEN
        build_mainframe_element_entry (cpu_index, cpu_element.element_id, actual_number_of_elements,
              temp_element_table_p);
        IF cpu_element.vector_degrade = 0 THEN
          mtv$scb.vector_simulation_control.vector_divide_degraded :=
                mtv$scb.vector_simulation_control.vector_divide_degraded - $ost$processor_id_set [cpu_index];
        ELSE
          mtv$scb.vector_simulation_control.vector_divide_degraded :=
                mtv$scb.vector_simulation_control.vector_divide_degraded + $ost$processor_id_set [cpu_index];
        IFEND;
      IFEND;
      element_id := element_id + 10(16);
    FOREND;

    { Retrieve the MEMORY information from the MRT and build the MEMORY entry in the mainframe element table.

    element_seq_p := #SEQ (memory_element);
    RESET element_seq_p;
    dsp$get_cy2000_element (dsc$dftb_eid_memory_element, dsc$dft_sub_none, element_seq_p, status);
    IF NOT status.normal THEN
      osp$system_error ('ERROR, unable to find MEMORY information in the MRT.', NIL);
    IFEND;
    build_mainframe_element_entry (0, memory_element.element_id, actual_number_of_elements,
          temp_element_table_p);

    { Retrieve the IOU information from the MRT and build the IOU entry in the mainframe element table.

    element_id := dsc$dftb_eid_iou0_element;
    element_seq_p := #SEQ (iou_element);
    FOR iou_index := LOWERVALUE (dst$iou_number) TO UPPERVALUE (dst$iou_number) DO
      RESET element_seq_p;
      dsp$get_cy2000_element (element_id, dsc$dft_sub_none, element_seq_p, status);
      IF status.normal AND (iou_element.state <> dsc$dft_state_not_installed) THEN
        build_mainframe_element_entry (iou_index, iou_element.element_id, actual_number_of_elements,
            temp_element_table_p);
        IF iou_element.state = dsc$dft_state_on THEN
          build_iou_table (iou_index, iou_element.element_id.model_number);
          cy2000_build_ch_types_table (iou_index, element_id, status);
          IF NOT status.normal THEN
            osp$system_error ('ERROR, unable to determine channel type.', NIL);
          IFEND;
        IFEND;
      IFEND;
      element_id := element_id + 10(16);
    FOREND;

    IF v$number_of_ious = 0 THEN
      osp$system_error ('ERROR, unable to find IOU information in the MRT.', NIL);
    IFEND;

    { Store the element table in mainframe wired.

    ALLOCATE dsv$mf_element_table_p: [1 .. actual_number_of_elements] IN osv$mainframe_wired_heap^;
    RESET temp_element_table_p;
    FOR entry_index := 1 TO actual_number_of_elements DO
      NEXT element_entry_p IN temp_element_table_p;
      dsv$mf_element_table_p^ [entry_index] := element_entry_p^;
    FOREND;

    { Recover the secure analysis state.

    dsp$access_secure_mode (dsc$dft_return_secure_mode, mode, status);
    IF status.normal THEN
      avv$security_options [avc$vso_secure_analysis].active := (mode = dsc$dft_secure_mode_enabled);
    IFEND;

  PROCEND cy2000_build_mf_information;
?? OLDTITLE ??
?? NEWTITLE := 'cy2000_change_channel_states', EJECT ??

{ PURPOSE:
{   This procedure changes specific channel states in the MRT on a Cyber 2000 mainframe.

  PROCEDURE cy2000_change_channel_states
    (    channel_state_list: dst$partial_channel_state_list;
     VAR status: ost$status);

    VAR
      element_id: 0 .. 0ff(16),
      element_state: 0 .. 0ff(16),
      list_index: integer;

    status.normal := TRUE;

    FOR list_index := LOWERBOUND (channel_state_list) TO UPPERBOUND (channel_state_list) DO
      element_id := (channel_state_list [list_index].channel.iou_number * 10(16)) + dsc$dftb_eid_iou0_element;
      CASE channel_state_list [list_index].element_state OF
      = cmc$on =
        element_state := dsc$dft_state_on;
      = cmc$down =
        element_state := dsc$dft_state_down_by_operator;
      = cmc$off =
        element_state := dsc$dft_state_off;
      ELSE
        element_state := 0ff(16);
      CASEND;
      dsp$change_cy2000_element (element_id,
            (dsc$dft_sub_channel + channel_state_list [list_index].channel.number), element_state, status);
    FOREND;

  PROCEND cy2000_change_channel_states;
?? OLDTITLE ??
?? NEWTITLE := 'cy2000_read_channel_states', EJECT ??

{ PURPOSE:
{   This procedure reads the channel states from the MRT on Cyber 2000 mainframes.

  PROCEDURE cy2000_read_channel_states
    (VAR channel_state_list: dst$entire_channel_state_list;
     VAR status: ost$status);

    VAR
      channel_element: dst$dft_get_channel_element,
      channel_element_seq_p: ^SEQ ( * ),
      channel_protocol: dst$channel_protocol_type,
      channel_state: 0 .. 0ff(16),
      element_id: 0 .. 0ff(16),
      iou_index: dst$number_of_ious,
      iou_information_table: dst$iou_information_table,
      iou_number: dst$iou_number,
      number: 0 .. 34(8),
      number_of_ious: dst$number_of_ious,
      protocol_index: dst$channel_protocol_type;

    status.normal := TRUE;

    { Initialize the channel state list.

    FOR iou_number := LOWERVALUE (dst$iou_number) TO UPPERVALUE (dst$iou_number) DO
      FOR protocol_index := LOWERVALUE (dst$channel_protocol_type) TO
            UPPERVALUE (dst$channel_protocol_type) DO
        FOR number := LOWERVALUE (dst$physical_resource_number) TO
              UPPERVALUE (dst$physical_resource_number) DO
          channel_state_list [iou_number] [protocol_index] [number] := cmc$down;
        FOREND;
      FOREND;
    FOREND;

    dsp$retrieve_iou_information (number_of_ious, iou_information_table);
    channel_element_seq_p := #SEQ (channel_element);

    FOR iou_index := 1 TO number_of_ious DO
      iou_number := iou_information_table [iou_index].physical_iou_number;
      element_id := (iou_number * 10(16)) + dsc$dftb_eid_iou0_element;
      RESET channel_element_seq_p;
      dsp$get_cy2000_element (element_id, dsc$dft_sub_channel, channel_element_seq_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      number := 0;
      WHILE number <= 33(8) DO
        IF number <= 13(8) THEN
          channel_state := channel_element.lower_channels [number].state;
        ELSE
          channel_state := channel_element.upper_channels [number].state;
        IFEND;
        IF (number = 32(8)) OR (number = 33(8)) THEN
          channel_protocol := dsc$cpt_nio;
        ELSE
          channel_protocol := dsc$cpt_cio;
        IFEND;
        CASE channel_state OF
        = dsc$dft_state_on =
          channel_state_list [iou_number] [channel_protocol] [number] := cmc$on;
        = dsc$dft_state_down_by_system, dsc$dft_state_down_by_operator =
          channel_state_list [iou_number] [channel_protocol] [number] := cmc$down;
        ELSE
          channel_state_list [iou_number] [channel_protocol] [number] := cmc$off;
        CASEND;
        number := number + 1;
        IF number = 14(8) THEN
          number := 20(8);
        IFEND;
      WHILEND;
    FOREND;

  PROCEND cy2000_read_channel_states;
?? OLDTITLE ??
?? NEWTITLE := 'perform_miscellaneous_things', EJECT ??

{ PURPOSE:
{   This procedure performs several miscellaneous tasks early in deadstart.

  PROCEDURE perform_miscellaneous_things;

    TYPE
      t$iou_status = PACKED RECORD
        CASE 0 .. 2 OF
        = 0 =
          register: integer,
        = 1 =
          unused_1: 0 .. 0ffffffff(16),
          unused_2: 0 .. 07ffffff(16),
          bits_59_63: 0 .. 1f(16),
        = 2 =
          unused_a: 0 .. 0ffffffff(16),
          unused_b: 0 .. 01fffffff(16),
          bits_61_63: 0 .. 7,
        CASEND,
      RECEND;

    VAR
      iou: dst$iou_number,
      iou_status: t$iou_status,
      iou_status_register: integer,
      request_p: ^SEQ ( * ),
      status: ost$status;

    { Allocate space for the DFT requests issued from monitor.

    IF dsv$mtr_dft_requests.puf_p = NIL THEN
      dsp$allocate_continuous_memory (osv$mainframe_wired_cb_heap, #SIZE (dst$dft_process_pp_function),
            request_p);
      RESET request_p;
      NEXT dsv$mtr_dft_requests.puf_p IN request_p;
    IFEND;
    IF dsv$mtr_dft_requests.reload_sci_p = NIL THEN
      dsp$allocate_continuous_memory (osv$mainframe_wired_cb_heap, #SIZE (dst$dft_reload_sci),
            request_p);
      RESET request_p;
      NEXT dsv$mtr_dft_requests.reload_sci_p IN request_p;
    IFEND;
    IF dsv$mtr_dft_requests.puf_data_p = NIL THEN
      dsp$allocate_continuous_memory (osv$mainframe_wired_cb_heap, #SIZE (dst$mtr_dft_puf_memory_area),
            request_p);
      RESET request_p;
      NEXT dsv$mtr_dft_requests.puf_data_p IN request_p;
    IFEND;

    { Retrieve the IOU model type(s) for the automatic pp reload variable.

    FOR iou := 1 TO v$number_of_ious DO
      dsv$automatic_pp_reload.iou_model_type [v$iou_information_table [iou].physical_iou_number] :=
            v$iou_information_table [iou].model_type;
    FOREND;

    { Retrieves the IOU status register via DFT to and determine if the hardware physical PPs have
    { been reconfigured.  If reconfiguration has occurred, then the automatic reload of PPs will not
    { be allowed if DFT detects that a PP has hung.

   /search_ious/
    FOR iou := 0 TO (dsc$max_number_of_ious - 1) DO
      IF dsv$automatic_pp_reload.iou_model_type [iou] = dsc$imn_null_model THEN
        CYCLE /search_ious/;
      IFEND;

      dsp$get_iou_status_register (iou, iou_status_register, status);
      IF NOT status.normal THEN
        osp$system_error ('Unable to retrieve the IOU status register via DFT.', ^status);
      IFEND;
      iou_status.register := iou_status_register;

      CASE dsv$automatic_pp_reload.iou_model_type [iou] OF
      = dsc$imn_i1_10_model, dsc$imn_i1_11_model, dsc$imn_i1_12_model, dsc$imn_i1_13_model,
            dsc$imn_i1_14_model, dsc$imn_i2_20_model, dsc$imn_i4_40_model =
        dsv$automatic_pp_reload.pps_reconfigured := (iou_status.bits_59_63 <> 0);
        EXIT /search_ious/;
      = dsc$imn_i4_42_model, dsc$imn_i4_44_model, dsc$imn_i4_46_model =
        dsv$automatic_pp_reload.pps_reconfigured := (iou_status.bits_61_63 <> 0);
        EXIT /search_ious/;
      ELSE
      CASEND;
    FOREND /search_ious/;

  PROCEND perform_miscellaneous_things;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$allocate_continuous_memory', EJECT ??

{ PURPOSE:
{   This procedure returns a sequence pointer to an area of continuous memory.

  PROCEDURE [XDCL] dsp$allocate_continuous_memory
    (    heap_p: ^ost$heap;
         size: integer;
     VAR return_seq_p: ^SEQ ( * ));

    TYPE
      aligned_seq = RECORD
        seq_area: ALIGNED [0 MOD 65536] SEQ ( * ),
      RECEND,
      chain = RECORD
        seq_p: ^SEQ ( * ),
        chain_p: ^chain,
      RECEND;

    VAR
      aligned_seq_p: ^aligned_seq,
      area_index: integer,
      area_ok: boolean,
      area_p: ^ARRAY [1 .. *] OF cell,
      chain_p: ^chain,
      first_rma: integer,
      last_rma: integer,
      new_chain_p: ^chain,
      new_seq_p: ^SEQ ( * ),
      page_boundary_p: ^cell;

    area_ok := FALSE;
    chain_p := NIL;
    page_boundary_p := NIL;

    WHILE NOT area_ok DO
      osp$extend_heap (size, heap_p, page_boundary_p);
      ALLOCATE aligned_seq_p: [[REP size OF cell]] IN heap_p^;
      new_seq_p := ^aligned_seq_p^.seq_area;
      RESET new_seq_p;
      NEXT area_p: [1 .. size] IN new_seq_p;
      i#real_memory_address (#LOC (area_p^ [1]), first_rma);

      { Make sure that the heap contains continuous memory.

      area_ok := TRUE;
      area_index := 1;
      WHILE (area_index < size) AND area_ok DO
        area_index := area_index + osv$page_size;
        IF area_index > size THEN
          area_index := size;
        IFEND;
        i#real_memory_address (#LOC (area_p^[area_index]), last_rma);
        area_ok := (area_index - 1) = (last_rma - first_rma);
      WHILEND;

      IF area_ok THEN
        return_seq_p := new_seq_p;
      ELSE

        { Save a pointer to the unused meory area so that it can be freed later.

        PUSH new_chain_p;
        new_chain_p^.seq_p := new_seq_p;
        new_chain_p^.chain_p := chain_p;
        chain_p := new_chain_p;
      IFEND;
    WHILEND;

    { Free the unused memory areas.

    WHILE chain_p <> NIL DO
      new_seq_p := chain_p^.seq_p;
      chain_p := chain_p^.chain_p;
      FREE new_seq_p IN heap_p^;
    WHILEND;
    IF mmv$pft_p <> NIL THEN
      osp$free_heap_pages (heap_p);
    IFEND;

    { Zero out the return sequence.

    RESET return_seq_p;
    pmp$zero_out_table (return_seq_p, #SIZE (return_seq_p^));

  PROCEND dsp$allocate_continuous_memory;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$build_mainframe_information', EJECT ??

{ PURPOSE:
{   This procedure builds some tables from the MRT entries for IOU, CPU, MEMORY and PAGE_MAP.
{   The following variables are built by this procedure.
{       * A table is built which contains the element id, model number and serial number.  The
{         model and serial number are stored in string format because they are used numerous times
{         in the system in that format.
{       * A variable is built that contains the IOU model type.
{       * A variable is built that contains the number of IOUs and their names.

  PROCEDURE [XDCL] dsp$build_mainframe_information;

    VAR
      actual_number_of_elements: ost$processor_element_number,
      channel_index: dst$channel_protocol_type,
      cpu_index: ost$logical_processor_id,
      element_entry_p: ^dst$mf_element_table_entry,
      element_id: dst$dft_element_id,
      entry_index: ost$processor_element_number,
      iou_index: dst$iou_number,
      mrt_entry: dst$mrt_entry,
      number_index: dst$physical_resource_number,
      possible_number_of_elements: ost$processor_element_number,
      status: ost$status,
      temp_element_table_p: ^SEQ ( * );

    { Initialize the channel type array.

    FOR iou_index := LOWERVALUE (dst$iou_number) TO UPPERVALUE (dst$iou_number) DO
      FOR channel_index := LOWERVALUE (dst$channel_protocol_type) TO
            UPPERVALUE (dst$channel_protocol_type) DO
        FOR number_index := LOWERVALUE (dst$physical_resource_number) TO
              UPPERVALUE (dst$physical_resource_number) DO
          v$mrt_channel_types [iou_index] [channel_index] [number_index].known_channel_type := FALSE;
        FOREND;
      FOREND;
    FOREND;
    v$number_of_ious := 0;

    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      cy2000_build_mf_information;
      perform_miscellaneous_things;
      RETURN;
    IFEND;

    actual_number_of_elements := 0;
    possible_number_of_elements := osc$maximum_processors + c$number_of_memory_elements +
          dsc$max_number_of_ious + c$number_of_page_map_elements;
    PUSH temp_element_table_p: [[REP possible_number_of_elements OF dst$mf_element_table_entry]];
    RESET temp_element_table_p;

    { Retrieve the CPU information from the MRT and build the CPU entry in the mainframe element table.

    FOR cpu_index := LOWERVALUE (ost$logical_processor_id) TO UPPERVALUE (ost$logical_processor_id) DO
      dsp$read_mrt_entry (dsc$mrt_id_processor, cpu_index, mrt_entry, status);
      IF status.normal THEN
        element_id.element_number := dsc$dftb_eid_cpu0_element;
        element_id.model_number := mrt_entry.processor.element_id.model_number;
        element_id.serial_number := mrt_entry.processor.element_id.serial_number_upper * 10000(8) +
              mrt_entry.processor.element_id.serial_number_lower;
        build_mainframe_element_entry (cpu_index, element_id, actual_number_of_elements,
              temp_element_table_p);
        IF mrt_entry.processor.disable_maintenance_mode THEN
          mtv$scb.vector_simulation_control.vector_divide_degraded :=
                mtv$scb.vector_simulation_control.vector_divide_degraded - $ost$processor_id_set [cpu_index];
        ELSE
          mtv$scb.vector_simulation_control.vector_divide_degraded :=
                mtv$scb.vector_simulation_control.vector_divide_degraded + $ost$processor_id_set [cpu_index];
        IFEND;
      IFEND;
    FOREND;

    { Retrieve the MEMORY information from the MRT and build the MEMORY entry in the mainframe element table.

    dsp$read_mrt_entry (dsc$mrt_id_central_memory, 0, mrt_entry, status);
    IF NOT status.normal THEN
      osp$system_error ('ERROR, unable to find MEMORY information in the MRT.', NIL);
    IFEND;
    element_id.element_number := dsc$dftb_eid_memory_element;
    element_id.model_number := mrt_entry.memory.element_id.model_number;
    element_id.serial_number := mrt_entry.memory.element_id.serial_number_upper * 10000(8) +
          mrt_entry.memory.element_id.serial_number_lower;
    build_mainframe_element_entry (0, element_id, actual_number_of_elements, temp_element_table_p);

    { Retrieve the IOU information from the MRT and build the IOU entry in the mainframe element table.

    FOR iou_index := LOWERVALUE (dst$iou_number) TO UPPERVALUE (dst$iou_number) DO
      dsp$read_mrt_entry (dsc$mrt_id_iou, iou_index, mrt_entry, status);
      IF status.normal THEN
        element_id.element_number := dsc$dftb_eid_iou0_element;
        element_id.model_number := mrt_entry.iou.element_id.model_number;
        element_id.serial_number := mrt_entry.iou.element_id.serial_number_upper * 10000(8) +
              mrt_entry.iou.element_id.serial_number_lower;
        build_mainframe_element_entry (iou_index, element_id, actual_number_of_elements,
              temp_element_table_p);
        IF NOT ((iou_index <> LOWERVALUE (dst$iou_number)) AND mrt_entry.iou.iou_logically_off) THEN
          build_iou_table (iou_index, mrt_entry.iou.element_id.model_number);
          build_channel_types_table (v$iou_information_table [v$number_of_ious].model_type, iou_index,
                mrt_entry);
        IFEND;
      IFEND;
    FOREND;

    IF v$number_of_ious = 0 THEN
      osp$system_error ('ERROR, unable to find IOU information in the MRT.', NIL);
    IFEND;

    { Retrieve the PAGE_MAP information from the MRT and build the PAGE_MAP entry in the
    { mainframe element table.

    IF dsv$mainframe_type = dsc$mt_93x_mainframe THEN
      dsp$read_mrt_entry (dsc$mrt_id_page_map, 0, mrt_entry, status);
      IF NOT status.normal THEN
        osp$system_error ('ERROR, unable to find PAGE MAP information in the MRT.', NIL);
      IFEND;
      element_id.element_number := dsc$dftb_eid_page_map_element;
      element_id.model_number := mrt_entry.page_map.element_id.model_number;
      element_id.serial_number := mrt_entry.page_map.element_id.serial_number_upper * 10000(8) +
            mrt_entry.page_map.element_id.serial_number_lower;
      build_mainframe_element_entry (0, element_id, actual_number_of_elements, temp_element_table_p);
    IFEND;

    { Store the element table in mainframe wired.

    ALLOCATE dsv$mf_element_table_p: [1 .. actual_number_of_elements] IN osv$mainframe_wired_heap^;
    RESET temp_element_table_p;
    FOR entry_index := 1 TO actual_number_of_elements DO
      NEXT element_entry_p IN temp_element_table_p;
      dsv$mf_element_table_p^ [entry_index] := element_entry_p^;
    FOREND;

    { Recover the secure analysis state.

    dsp$read_mrt_entry (dsc$mrt_id_global_processor, 0, mrt_entry, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    avv$security_options [avc$vso_secure_analysis].active := mrt_entry.global_processor.secure_analysis;

    perform_miscellaneous_things;

  PROCEND dsp$build_mainframe_information;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$build_sequence_p', EJECT ??

{ PURPOSE:
{   This procedure builds a sequence pointer from a pointer to a cell.

  PROCEDURE [XDCL] dsp$build_sequence_p
    (    seq_pva_p: ^cell,
         limit: integer;
     VAR return_seq_p: ^SEQ ( * ));

    VAR
      seq_entry_pointer_p: ^^SEQ ( * ),
      seq_header: cyt$sequence_pointer;

    seq_entry_pointer_p := #LOC (seq_header);
    seq_header.pva := seq_pva_p;
    seq_header.length := limit;
    seq_header.nextt := 0;
    return_seq_p := seq_entry_pointer_p^;
    RESET return_seq_p;

  PROCEND dsp$build_sequence_p;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$change_channel_states', EJECT ??

{ PURPOSE:
{   This procedure changes specific channel states in the MRT.

  PROCEDURE [XDCL] dsp$change_channel_states
    (    channel_state_list: dst$partial_channel_state_list;
     VAR status: ost$status);

?? NEWTITLE := 'break_apart_channel_states', EJECT ??

{ PURPOSE:
{   This procedure breaks each two channel entry in the MRT down into individual entries.

    PROCEDURE break_apart_channel_states
      (    number_of_entries: 1 .. 12;
           channel_protocol: dst$channel_protocol_type;
           mrt_channel_states: ARRAY [1 .. *] OF dst$mrt_two_channel_descriptor;
       VAR split_channel_states: split_channel_states_type);

      VAR
        channel_number: 0 .. 34(8),
        index: 1 .. 12;

      channel_number := 0;
      FOR index := 1 TO number_of_entries DO

        { Retrieve the channel states from the 'a' channel entry in the two channel entry in the MRT.

        split_channel_states [channel_protocol] [channel_number].on_off_state :=
              mrt_channel_states [index].a_channel_on_off_status;
        split_channel_states [channel_protocol] [channel_number].up_down_state :=
              mrt_channel_states [index].a_channel_up_down_status;
        channel_number := channel_number + 1;

        { Retrieve the channel states from the 'b' channel entry in the two channel entry in the MRT.

        split_channel_states [channel_protocol] [channel_number].on_off_state :=
              mrt_channel_states [index].b_channel_on_off_status;
        split_channel_states [channel_protocol] [channel_number].up_down_state :=
              mrt_channel_states [index].b_channel_up_down_status;
        channel_number := channel_number + 1;
        IF channel_number = 14(8) THEN
          channel_number := 20(8);
        IFEND;
      FOREND;

    PROCEND break_apart_channel_states;
?? OLDTITLE ??
?? NEWTITLE := 'replace_channel_states', EJECT ??

{ PURPOSE:
{   This procedure puts the individual entries back into the two channel entries in the MRT.

    PROCEDURE replace_channel_states
      (    number_of_entries: 1 .. 12;
           channel_protocol: dst$channel_protocol_type;
           split_channel_states: split_channel_states_type;
       VAR mrt_channel_states: ARRAY [1 .. *] OF dst$mrt_two_channel_descriptor);

      VAR
        channel_number: 0 .. 34(8),
        index: 1 .. 12;

      channel_number := 0;
      FOR index := 1 TO number_of_entries DO

        { Replace the channel states for the 'a' channel entry in the two channel entry in the MRT.

        mrt_channel_states [index].a_channel_on_off_status :=
              split_channel_states [channel_protocol] [channel_number].on_off_state;
        mrt_channel_states [index].a_channel_up_down_status :=
              split_channel_states [channel_protocol] [channel_number].up_down_state;
        channel_number := channel_number + 1;

        { Replace the channel states for the 'b' channel entry in the two channel entry in the MRT.

        mrt_channel_states [index].b_channel_on_off_status :=
              split_channel_states [channel_protocol] [channel_number].on_off_state;
        mrt_channel_states [index].b_channel_up_down_status :=
              split_channel_states [channel_protocol] [channel_number].up_down_state;
        channel_number := channel_number + 1;
        IF channel_number = 14(8) THEN
          channel_number := 20(8);
        IFEND;
      FOREND;

    PROCEND replace_channel_states;
?? OLDTITLE, EJECT ??
    TYPE
      split_channel_states_record = RECORD
        on_off_state: boolean,
        up_down_state: boolean,
      RECEND,

      split_channel_states_type = ARRAY [dst$channel_protocol_type] OF
            ARRAY [dst$physical_resource_number] OF split_channel_states_record;

    VAR
      iou_index: dst$number_of_ious,
      iou_information_table: dst$iou_information_table,
      list_index: integer,
      mrt_cio_channel_states: ARRAY [1 .. 5] OF dst$mrt_two_channel_descriptor,
      mrt_nio_channel_states: ARRAY [1 .. 12] OF dst$mrt_two_channel_descriptor,
      mrt_entry: dst$mrt_entry,
      number_of_ious: dst$number_of_ious,
      split_channel_states: split_channel_states_type;

    status.normal := TRUE;

    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      cy2000_change_channel_states (channel_state_list, status);
      RETURN;
    IFEND;

    dsp$retrieve_iou_information (number_of_ious, iou_information_table);

    FOR iou_index := 1 TO number_of_ious DO

      { Read the IOU entry from the MRT.

      dsp$read_mrt_entry (dsc$mrt_id_iou, iou_information_table [iou_index].physical_iou_number,
            mrt_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      { Split apart the two channel entry groups for the NIO channels.

      mrt_nio_channel_states [1] := mrt_entry.iou.channel_00_01;
      mrt_nio_channel_states [2] := mrt_entry.iou.channel_02_03;
      mrt_nio_channel_states [3] := mrt_entry.iou.channel_04_05;
      mrt_nio_channel_states [4] := mrt_entry.iou.channel_06_07;
      mrt_nio_channel_states [5] := mrt_entry.iou.channel_10b_11b;
      mrt_nio_channel_states [6] := mrt_entry.iou.channel_12b_13b;
      mrt_nio_channel_states [7] := mrt_entry.iou.channel_20b_21b;
      mrt_nio_channel_states [8] := mrt_entry.iou.channel_22b_23b;
      mrt_nio_channel_states [9] := mrt_entry.iou.channel_24b_25b;
      mrt_nio_channel_states [10] := mrt_entry.iou.channel_26b_27b;
      mrt_nio_channel_states [11] := mrt_entry.iou.channel_30b_31b;
      mrt_nio_channel_states [12] := mrt_entry.iou.channel_32b_33b;

      IF iou_information_table [iou_index].model_type = dsc$imn_i4_44_model THEN
        break_apart_channel_states (12, dsc$cpt_cio, mrt_nio_channel_states, split_channel_states);
      ELSE
        break_apart_channel_states (12, dsc$cpt_nio, mrt_nio_channel_states, split_channel_states);

        { Split apart the two channel entry groups for the CIO channels.

        mrt_cio_channel_states [1] := mrt_entry.iou.i4_cio_channel_00_01;
        mrt_cio_channel_states [2] := mrt_entry.iou.i4_cio_channel_02_03;
        mrt_cio_channel_states [3] := mrt_entry.iou.i4_cio_channel_04_05;
        mrt_cio_channel_states [4] := mrt_entry.iou.i4_cio_channel_06_07;
        mrt_cio_channel_states [5] := mrt_entry.iou.i4_cio_channel_10b_11b;

        break_apart_channel_states (5, dsc$cpt_cio, mrt_cio_channel_states, split_channel_states);
      IFEND;

      { Change the channel states.  NOS/VE has three channel states: ON, DOWN, OFF.  The
      { MRT has four channel states: ON-OFF, UP-DOWN.  The following chart shows how these
      { two groups relate to one another.
      {       NOS/VE       MRT                    MEANING
      {       ******   ***********   **********************************
      {        ON    =  ON & UP    =  available for overall use
      {        DOWN  =  ON & DOWN  =  available for use by maintenance
      {        OFF   =  OFF & UP   =  NOT available for ANY use
      {        OFF   =  OFF & DOWN =  treated the same as OFF & UP
      {       ******   ***********   **********************************

      FOR list_index := LOWERBOUND (channel_state_list) TO UPPERBOUND (channel_state_list) DO
        IF channel_state_list [list_index].channel.iou_number =
              iou_information_table [iou_index].physical_iou_number THEN
          CASE channel_state_list [list_index].element_state OF
          = cmc$on =
            split_channel_states [channel_state_list [list_index].channel.channel_protocol]
                  [channel_state_list [list_index].channel.number].on_off_state := FALSE;
            split_channel_states [channel_state_list [list_index].channel.channel_protocol]
                  [channel_state_list [list_index].channel.number].up_down_state := FALSE;
          = cmc$down =
            split_channel_states [channel_state_list [list_index].channel.channel_protocol]
                  [channel_state_list [list_index].channel.number].on_off_state := FALSE;
            split_channel_states [channel_state_list [list_index].channel.channel_protocol]
                  [channel_state_list [list_index].channel.number].up_down_state := TRUE;
          = cmc$off =
            split_channel_states [channel_state_list [list_index].channel.channel_protocol]
                  [channel_state_list [list_index].channel.number].on_off_state := TRUE;
            split_channel_states [channel_state_list [list_index].channel.channel_protocol]
                  [channel_state_list [list_index].channel.number].up_down_state := FALSE;
          ELSE
          CASEND;
        IFEND;
      FOREND;

      { Put the individual NIO channel states back into the two channel entry groups.

      IF iou_information_table [iou_index].model_type = dsc$imn_i4_44_model THEN
        replace_channel_states (12, dsc$cpt_cio, split_channel_states, mrt_nio_channel_states);
      ELSE
        replace_channel_states (12, dsc$cpt_nio, split_channel_states, mrt_nio_channel_states);
      IFEND;

      mrt_entry.iou.channel_00_01 := mrt_nio_channel_states [1];
      mrt_entry.iou.channel_02_03 := mrt_nio_channel_states [2];
      mrt_entry.iou.channel_04_05 := mrt_nio_channel_states [3];
      mrt_entry.iou.channel_06_07 := mrt_nio_channel_states [4];
      mrt_entry.iou.channel_10b_11b := mrt_nio_channel_states [5];
      mrt_entry.iou.channel_12b_13b := mrt_nio_channel_states [6];
      mrt_entry.iou.channel_20b_21b := mrt_nio_channel_states [7];
      mrt_entry.iou.channel_22b_23b := mrt_nio_channel_states [8];
      mrt_entry.iou.channel_24b_25b := mrt_nio_channel_states [9];
      mrt_entry.iou.channel_26b_27b := mrt_nio_channel_states [10];
      mrt_entry.iou.channel_30b_31b := mrt_nio_channel_states [11];
      mrt_entry.iou.channel_32b_33b := mrt_nio_channel_states [12];

      { Put the individual CIO channel states back into the two channel entry groups.

      IF iou_information_table [iou_index].model_type <> dsc$imn_i4_44_model THEN
        replace_channel_states (5, dsc$cpt_cio, split_channel_states, mrt_cio_channel_states);

        mrt_entry.iou.i4_cio_channel_00_01 := mrt_cio_channel_states [1];
        mrt_entry.iou.i4_cio_channel_02_03 := mrt_cio_channel_states [2];
        mrt_entry.iou.i4_cio_channel_04_05 := mrt_cio_channel_states [3];
        mrt_entry.iou.i4_cio_channel_06_07 := mrt_cio_channel_states [4];
        mrt_entry.iou.i4_cio_channel_10b_11b := mrt_cio_channel_states [5];
      IFEND;

      { Write the IOU entry to the MRT.

      dsp$write_mrt_entry (dsc$mrt_id_iou, iou_information_table [iou_index].physical_iou_number,
            mrt_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    FOREND;

  PROCEND dsp$change_channel_states;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$change_processor_state', EJECT ??

{ PURPOSE:
{   This procedure changes the processor state in the processor entry in the MRT.
{ NOTE:
{   The following data applies to the non-cyber-2000 mainframes.
{     NOS/VE has three states: ON, DOWN, OFF.  The MRT has four states: ON-OFF, UP-DOWN.  The following chart
{     shows how these two groups relate to one another.
{           NOS/VE       MRT MEANING
{           ******   ************************************************
{            ON    = processor_down := FALSE, processor_off := FALSE
{            DOWN  = processor_down := TRUE , processor_off := FALSE
{            OFF   = processor_down := FALSE, processor_off := TRUE OR
{                    processor_down := TRUE , processor_off := TRUE
{           ******   ************************************************


  PROCEDURE [XDCL] dsp$change_processor_state
    (    processor_id: ost$processor_id;
         state_data: dst$change_processor_state;
         service_processor_recovery: boolean);

    VAR
      element_id: 0 .. 0ff(16),
      element_state: 0 .. 0ff(16),
      local_status: ost$status,
      mrt_entry: dst$mrt_entry;

    { If the state desired is DOWN and the CPU has not been halted via DFT then make the call to DFT to
    { halt the CPU BEFORE changing the MRT.  Otherwise DFT will incorrectly halt the CPU on its own.

    IF (state_data.state = cmc$down) AND state_data.halt_cpu_via_dft THEN
      dsp$manage_virtual_cpu (processor_id);
    IFEND;

    { Change the MRT to reflect the state change.

    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      element_id := processor_id * 10(16);
      CASE state_data.state OF
      = cmc$on =
        element_state := dsc$dft_state_on;
      = cmc$down =

        { If DFT noticed the halt of the CPU, it has already changed the MRT on CYBER 2000 and halted the CPU.

        IF NOT state_data.halt_cpu_via_dft THEN
          RETURN;
        IFEND;
        IF state_data.down_reason = dsc$pdr_down_by_operator THEN
          element_state := dsc$dft_state_down_by_operator;
        ELSE
          element_state := dsc$dft_state_down_by_system;
        IFEND;
      = cmc$off =
        element_state := dsc$dft_state_off;
      ELSE
        element_state := dsc$dft_state_not_installed;
      CASEND;
      dsp$change_cy2000_element (element_id, dsc$dft_sub_none, element_state, local_status);
      IF NOT local_status.normal THEN
        IF NOT service_processor_recovery THEN

{ This flag set indicates that the Service Processor MRT already reflects the
{ fact that the processor is running. Attempting to modify the MRT will result
{ in the following error. Ignore it .

             osp$fatal_system_error ('Unable to change MRT data', ^local_status);
        IFEND;
      IFEND;
    ELSE
      dsp$read_mrt_entry (dsc$mrt_id_processor, processor_id, mrt_entry, local_status);
      IF NOT local_status.normal THEN
        osp$fatal_system_error ('Unable to read MRT data', ^local_status);
      IFEND;
      CASE state_data.state OF
      = cmc$on =
        mrt_entry.processor.processor_down := FALSE;
        mrt_entry.processor.processor_off := FALSE;
        mrt_entry.processor.processor_down_by_operator := FALSE;
        mrt_entry.processor.processor_down_by_system := FALSE;
      = cmc$down =
        mrt_entry.processor.processor_down := TRUE;
        mrt_entry.processor.processor_off := FALSE;
        IF state_data.down_reason = dsc$pdr_down_by_operator THEN
          mrt_entry.processor.processor_down_by_operator := TRUE;
        ELSE
          mrt_entry.processor.processor_down_by_system := TRUE;
        IFEND;
      = cmc$off =
        mrt_entry.processor.processor_down := FALSE;
        mrt_entry.processor.processor_off := TRUE;
        mrt_entry.processor.processor_down_by_operator := FALSE;
        mrt_entry.processor.processor_down_by_system := FALSE;
      ELSE
      CASEND;
      dsp$write_mrt_entry (dsc$mrt_id_processor, processor_id, mrt_entry, local_status);
      IF NOT local_status.normal THEN
        osp$fatal_system_error ('Unable to change MRT data', ^local_status);
      IFEND;
    IFEND;

    { Start the CPU if the desired state is on.

    IF state_data.state = cmc$on THEN
      dsp$start_additional_cpu (processor_id);
    IFEND;

  PROCEND dsp$change_processor_state;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$change_secure_analysis', EJECT ??

{ PURPOSE:
{   This procedure changes the secure mode state in the global processor entry in the MRT.

  PROCEDURE [XDCL] dsp$change_secure_analysis
    (    secure_analysis: boolean;
     VAR status: ost$status);

    VAR
      access_function: 0 .. 0ff(16),
      mrt_entry: dst$mrt_entry,
      unused_mode: 0 .. 0ffff(16);

    status.normal := TRUE;

    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      IF secure_analysis THEN
        access_function := dsc$dft_activate_secure_mode;
      ELSE
        access_function := dsc$dft_deactivate_secure_mode;
      IFEND;
      dsp$access_secure_mode (access_function, unused_mode, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      dsp$read_mrt_entry (dsc$mrt_id_global_processor, 0, mrt_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF mrt_entry.global_processor.secure_analysis <> secure_analysis THEN
        mrt_entry.global_processor.secure_analysis := secure_analysis;
        dsp$write_mrt_entry (dsc$mrt_id_global_processor, 0, mrt_entry, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

  PROCEND dsp$change_secure_analysis;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$fetch_boot_data', EJECT ??

{ PURPOSE:
{   This procedure retrieves data from an area in the SSR that
{   contains data saved from the boot to system core.

  PROCEDURE [XDCL] dsp$fetch_boot_data
    (    data_kind: dst$boot_data_kinds;
     VAR data_p: ^SEQ ( * ));

    VAR
      boot_data_list: t$boot_data_list,
      boot_data_list_seq_p: ^SEQ ( * ),
      seq_p: ^SEQ ( * ),
      temp_data_p: ^SEQ ( * );

    IF dsv$boot_data_base_p = NIL THEN
      jmv$sdt.st [osc$segnum_job_pageable_heap] := osv$boot_sdte;
      dsp$build_sequence_p (#ADDRESS (1, osc$segnum_job_pageable_heap, 0), 0fffffff(16),
            dsv$boot_data_base_p);
    IFEND;

    boot_data_list_seq_p := #SEQ (boot_data_list);
    dsp$get_data_from_ssr (dsc$ssr_boot_pointer_area, boot_data_list_seq_p);
    seq_p := #PTR (boot_data_list [data_kind], dsv$boot_data_base_p^);
    RESET data_p;
    RESET seq_p;
    IF #SIZE (data_p^) > #SIZE (seq_p^) THEN
      NEXT temp_data_p: [[REP #SIZE (seq_p^) OF cell]] IN data_p;
      temp_data_p^ := seq_p^;
    ELSE
      NEXT temp_data_p: [[REP #SIZE (data_p^) OF cell]] IN seq_p;
      data_p^ := temp_data_p^;
    IFEND;
    RESET data_p;

  PROCEND dsp$fetch_boot_data;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$get_cpu_attributes', EJECT ??

{ PURPOSE:
{   This procedure retrieves the CPU attributes for each CPU on the system.
{ DESIGN:
{   A request to DFT is used to retrieve the CPU attributes.

  PROCEDURE [XDCL] dsp$get_cpu_attributes
    (VAR cpu_attributes: dst$cpu_attributes);

    VAR
      cpu_index: ost$logical_processor_id,
      element_entry: dst$dft_get_cpu_element,
      element_entry_seq_p: ^SEQ ( * ),
      element_id: 0 .. 0ff(16),
      local_status: ost$status,
      mrt_entry: dst$mrt_entry;

    cpu_attributes.count := 0;
    element_id := dsc$dftb_eid_cpu0_element;
    element_entry_seq_p := #SEQ (element_entry);

    FOR cpu_index := LOWERVALUE (ost$logical_processor_id) TO UPPERVALUE (ost$logical_processor_id) DO
      IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
        RESET element_entry_seq_p;
        dsp$get_cy2000_element (element_id, dsc$dft_sub_none, element_entry_seq_p, local_status);
        IF NOT local_status.normal THEN
          osp$fatal_system_error ('Unable to read MRT data.', ^local_status);
        IFEND;

        IF element_entry.state <> dsc$dft_state_not_installed THEN
          cpu_attributes.count := cpu_attributes.count + 1;
          CASE element_entry.state OF
          = dsc$dft_state_on =
            cpu_attributes.cpu [cpu_index].state := cmc$on;
            cpu_attributes.cpu [cpu_index].down_reason := dsc$pdr_null;
          = dsc$dft_state_down_by_system =
            cpu_attributes.cpu [cpu_index].state := cmc$down;
            cpu_attributes.cpu [cpu_index].down_reason := dsc$pdr_down_by_system;
          = dsc$dft_state_down_by_operator =
            cpu_attributes.cpu [cpu_index].state := cmc$down;
            cpu_attributes.cpu [cpu_index].down_reason := dsc$pdr_down_by_operator;
          ELSE
            cpu_attributes.cpu [cpu_index].state := cmc$off;
            cpu_attributes.cpu [cpu_index].down_reason := dsc$pdr_null;
          CASEND;
          cpu_attributes.cpu [cpu_index].memory_port_number := element_entry.port;
          cpu_attributes.cpu [cpu_index].element_id.fill := 0;
          cpu_attributes.cpu [cpu_index].element_id.element_number := element_entry.element_id.element_number;
          cpu_attributes.cpu [cpu_index].element_id.model_number := element_entry.element_id.model_number;
          cpu_attributes.cpu [cpu_index].element_id.serial_number := element_entry.element_id.serial_number;
          cpu_attributes.cpu [cpu_index].vectors_not_available := (element_entry.vector_degrade = 1);
        IFEND;
        element_id := element_id + 10(16);
      ELSE
        dsp$read_mrt_entry (dsc$mrt_id_processor, cpu_index, mrt_entry, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;

        cpu_attributes.count := cpu_attributes.count + 1;
        IF mrt_entry.processor.processor_off THEN
          cpu_attributes.cpu [cpu_index].state := cmc$off;
          cpu_attributes.cpu [cpu_index].down_reason := dsc$pdr_null;
        ELSEIF mrt_entry.processor.processor_down THEN
          cpu_attributes.cpu [cpu_index].state := cmc$down;
          IF mrt_entry.processor.processor_down_by_system THEN
            cpu_attributes.cpu [cpu_index].down_reason := dsc$pdr_down_by_system;
          ELSE
            cpu_attributes.cpu [cpu_index].down_reason := dsc$pdr_down_by_operator;
          IFEND;
        ELSE
          cpu_attributes.cpu [cpu_index].state := cmc$on;
          cpu_attributes.cpu [cpu_index].down_reason := dsc$pdr_null;
        IFEND;
        cpu_attributes.cpu [cpu_index].memory_port_number := mrt_entry.processor.memory_port;
        cpu_attributes.cpu [cpu_index].element_id.fill := 0;
        cpu_attributes.cpu [cpu_index].element_id.element_number :=
              mrt_entry.processor.element_id.element_number;
        cpu_attributes.cpu [cpu_index].element_id.model_number := mrt_entry.processor.element_id.model_number;
        cpu_attributes.cpu [cpu_index].element_id.serial_number :=
              mrt_entry.processor.element_id.serial_number_upper * 10000(8) +
              mrt_entry.processor.element_id.serial_number_lower;
        cpu_attributes.cpu [cpu_index].vectors_not_available :=
              NOT mrt_entry.processor.disable_maintenance_mode;
      IFEND;
    FOREND;

  PROCEND dsp$get_cpu_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$read_channel_states', EJECT ??

{ PURPOSE:
{   This procedure reads the channel states from the MRT.

  PROCEDURE [XDCL] dsp$read_channel_states
    (VAR channel_state_list: dst$entire_channel_state_list;
     VAR status: ost$status);

?? NEWTITLE := 'retrieve_channel_states', EJECT ??

{ PURPOSE:
{   This procedure builds an array of channel states from the MRT.  NOS/VE has three channel
{   states: ON, DOWN, OFF.  The MRT has four channel states: ON-OFF, UP-DOWN.  The following
{   chart shows how these two groups relate to one another.
{       NOS/VE       MRT                    MEANING
{       ******   ***********   **********************************
{        ON    =  ON & UP    =  available for overall use
{        DOWN  =  ON & DOWN  =  available for use by maintenance
{        OFF   =  OFF & UP   =  NOT available for ANY use
{        OFF   =  OFF & DOWN =  treated the same as OFF & UP
{       ******   ***********   **********************************

    PROCEDURE retrieve_channel_states
      (    number_of_entries: 1 .. 12;
           iou_number: dst$iou_number;
           channel_protocol: dst$channel_protocol_type;
           mrt_channel_states: ARRAY [1 .. *] OF dst$mrt_two_channel_descriptor;
       VAR channel_state_list: dst$entire_channel_state_list);

      VAR
        channel_number: 0 .. 34(8),
        index: 1 .. 12;

      channel_number := 0;
      FOR index := 1 TO number_of_entries DO

        { Retrieve the channel state from the 'a' channel entry in the two channel entry from the MRT.

        IF (NOT mrt_channel_states [index].a_channel_on_off_status) AND
              (NOT mrt_channel_states [index].a_channel_up_down_status) THEN
          channel_state_list [iou_number] [channel_protocol] [channel_number] := cmc$on;
        ELSEIF (NOT mrt_channel_states [index].a_channel_on_off_status) AND
              mrt_channel_states [index].a_channel_up_down_status THEN
          channel_state_list [iou_number] [channel_protocol] [channel_number] := cmc$down;
        ELSE
          channel_state_list [iou_number] [channel_protocol] [channel_number] := cmc$off;
        IFEND;
        channel_number := channel_number + 1;

        { Retrieve the channel state from the 'b' channel entry in the two channel entry from the MRT.

        IF (NOT mrt_channel_states [index].b_channel_on_off_status) AND
              (NOT mrt_channel_states [index].b_channel_up_down_status) THEN
          channel_state_list [iou_number] [channel_protocol] [channel_number] := cmc$on;
        ELSEIF (NOT mrt_channel_states [index].b_channel_on_off_status) AND
              mrt_channel_states [index].b_channel_up_down_status THEN
          channel_state_list [iou_number] [channel_protocol] [channel_number] := cmc$down;
        ELSE
          channel_state_list [iou_number] [channel_protocol] [channel_number] := cmc$off;
        IFEND;
        channel_number := channel_number + 1;
        IF channel_number = 14(8) THEN
          channel_number := 20(8);
        IFEND;
      FOREND;

    PROCEND retrieve_channel_states;

?? OLDTITLE, EJECT ??

    VAR
      iou_index: dst$number_of_ious,
      iou_information_table: dst$iou_information_table,
      iou_number: dst$iou_number,
      mrt_channel_states: ARRAY [1 .. 12] OF dst$mrt_two_channel_descriptor,
      mrt_entry: dst$mrt_entry,
      number_index: dst$physical_resource_number,
      number_of_ious: dst$number_of_ious,
      protocol_index: dst$channel_protocol_type;

    status.normal := TRUE;

    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      cy2000_read_channel_states (channel_state_list, status);
      RETURN;
    IFEND;

    { Initialize the channel state list.

    FOR iou_number := LOWERVALUE (dst$iou_number) TO UPPERVALUE (dst$iou_number) DO
      FOR protocol_index := LOWERVALUE (dst$channel_protocol_type) TO
            UPPERVALUE (dst$channel_protocol_type) DO
        FOR number_index := LOWERVALUE (dst$physical_resource_number) TO
              UPPERVALUE (dst$physical_resource_number) DO
          channel_state_list [iou_number] [protocol_index] [number_index] := cmc$down;
        FOREND;
      FOREND;
    FOREND;

    dsp$retrieve_iou_information (number_of_ious, iou_information_table);

    FOR iou_index := 1 TO number_of_ious DO

      { Read the IOU entry from the MRT.

      dsp$read_mrt_entry (dsc$mrt_id_iou, iou_information_table [iou_index].physical_iou_number,
            mrt_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      { Retrieve the NIO channel states.

      mrt_channel_states [1] := mrt_entry.iou.channel_00_01;
      mrt_channel_states [2] := mrt_entry.iou.channel_02_03;
      mrt_channel_states [3] := mrt_entry.iou.channel_04_05;
      mrt_channel_states [4] := mrt_entry.iou.channel_06_07;
      mrt_channel_states [5] := mrt_entry.iou.channel_10b_11b;
      mrt_channel_states [6] := mrt_entry.iou.channel_12b_13b;
      mrt_channel_states [7] := mrt_entry.iou.channel_20b_21b;
      mrt_channel_states [8] := mrt_entry.iou.channel_22b_23b;
      mrt_channel_states [9] := mrt_entry.iou.channel_24b_25b;
      mrt_channel_states [10] := mrt_entry.iou.channel_26b_27b;
      mrt_channel_states [11] := mrt_entry.iou.channel_30b_31b;
      mrt_channel_states [12] := mrt_entry.iou.channel_32b_33b;

      IF iou_information_table [iou_index].model_type = dsc$imn_i4_44_model THEN
        retrieve_channel_states (12, iou_information_table [iou_index].physical_iou_number,
              dsc$cpt_cio, mrt_channel_states, channel_state_list);
      ELSE
        retrieve_channel_states (12, iou_information_table [iou_index].physical_iou_number,
              dsc$cpt_nio, mrt_channel_states, channel_state_list);

        { Retrieve the CIO channel states.

        mrt_channel_states [1] := mrt_entry.iou.i4_cio_channel_00_01;
        mrt_channel_states [2] := mrt_entry.iou.i4_cio_channel_02_03;
        mrt_channel_states [3] := mrt_entry.iou.i4_cio_channel_04_05;
        mrt_channel_states [4] := mrt_entry.iou.i4_cio_channel_06_07;
        mrt_channel_states [5] := mrt_entry.iou.i4_cio_channel_10b_11b;

        retrieve_channel_states (5, iou_information_table [iou_index].physical_iou_number,
              dsc$cpt_cio, mrt_channel_states, channel_state_list);
      IFEND;

    FOREND;

  PROCEND dsp$read_channel_states;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$retrieve_channel_type', EJECT ??

{ PURPOSE:
{   This procedure retrieves a channel type from the channel types array.

  PROCEDURE [XDCL, #GATE] dsp$retrieve_channel_type
    (    channel: dst$iou_resource;
     VAR channel_type: cmt$channel_type;
     VAR channel_type_found: boolean);

    channel_type_found := v$mrt_channel_types [channel.iou_number] [channel.channel_protocol]
          [channel.number].known_channel_type;
    IF channel_type_found THEN
      channel_type := v$mrt_channel_types [channel.iou_number] [channel.channel_protocol]
            [channel.number].channel_type;
    IFEND;

  PROCEND dsp$retrieve_channel_type;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$retrieve_mf_element_entry', EJECT ??

{ PURPOSE:
{   This procedure retrieves an entry from the Mainframe element table.

  PROCEDURE [XDCL, #GATE] dsp$retrieve_mf_element_entry
    (    element_number: dst$mf_element_number;
         dft_entry_id: dst$mf_element_number;
     VAR element_entry: dst$mf_element_table_entry;
     VAR status: ost$status);

    VAR
      element_id: dst$mf_element_id,
      entry_index: ost$processor_element_number;

    status.normal := TRUE;
    element_id.element_number := element_number;
    element_id.dft_entry_id := dft_entry_id;

    FOR entry_index := LOWERBOUND (dsv$mf_element_table_p^) TO UPPERBOUND (dsv$mf_element_table_p^) DO
      IF dsv$mf_element_table_p^ [entry_index].element_id = element_id THEN
        element_entry := dsv$mf_element_table_p^ [entry_index];
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal (dsc$display_processor_id, dse$mf_element_id_not_found, '', status);

  PROCEND dsp$retrieve_mf_element_entry;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$retrieve_iou_information', EJECT ??

{ PURPOSE:
{   This procedure retrieves the IOU information from the IOU Information Table.

  PROCEDURE [XDCL, #GATE] dsp$retrieve_iou_information
    (VAR number_of_ious: dst$number_of_ious;
     VAR iou_information_table: dst$iou_information_table);

    number_of_ious := v$number_of_ious;
    iou_information_table := v$iou_information_table;

  PROCEND dsp$retrieve_iou_information;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$save_boot_data_pointer', EJECT ??

{ PURPOSE:
{   This procedure saves data in an area in the SSR that is reserved to save data from the boot
{   to system core.

  PROCEDURE [XDCL] dsp$save_boot_data_pointer
    (    data_kind: dst$boot_data_kinds;
         boot_data_p: ^SEQ ( * ));

    VAR
      boot_data_list: t$boot_data_list,
      boot_data_list_seq_p: ^SEQ ( * );

    IF dsv$boot_data_base_p = NIL THEN
      dsp$build_sequence_p (#ADDRESS (1, #SEGMENT (^dsv$boot_data_base_p), 0), 0fffffff(16),
            dsv$boot_data_base_p);
    IFEND;

    boot_data_list_seq_p := #SEQ (boot_data_list);
    dsp$get_data_from_ssr (dsc$ssr_boot_pointer_area, boot_data_list_seq_p);
    boot_data_list [data_kind] := #REL (boot_data_p, dsv$boot_data_base_p^);
    dsp$store_data_in_ssr (dsc$ssr_boot_pointer_area, #SEQ (boot_data_list));

  PROCEND dsp$save_boot_data_pointer;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$update_time_zone', EJECT ??

{ PURPOSE:
{   This procedure updates the time zone data in the VCU area of the CDA.

  PROCEDURE [XDCL] dsp$update_time_zone
    (    time_zone: ost$time_zone;
     VAR status: ost$status);

    VAR
      time_zone_data: dst$vcu_time_zone_data,
      time_zone_data_seq_p: ^SEQ ( * );

    status.normal := TRUE;
    time_zone_data.initialized := TRUE;
    time_zone_data.time_zone := time_zone;

    time_zone_data_seq_p := #SEQ (time_zone_data);
    dsp$access_vcu_cda_data (dsc$vcu_write_access, dsc$vcu_time_zone_data, time_zone_data_seq_p, status);

  PROCEND dsp$update_time_zone;
MODEND dsm$deadstart_services;
*DECK DECK=DSM$DEADSTART_SERVICES_236 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Deadstart Services 236', EJECT ??
MODULE dsm$deadstart_services_236;

{ PURPOSE:
{   This module contains deadstart procedures that need to run in osf$job_template_236.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc dsp$dft_issue_system_alert

?? OLDTITLE ??
?? NEWTITLE := 'dsp$issue_system_alert', EJECT ??

{ PURPOSE:
{   This procedure issues a system alert to DFT.

  PROCEDURE [XDCL, #GATE] dsp$issue_system_alert
    (    alert_source: dst$dft_alert_source;
         supportive_information_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      local_alert_source: dst$dft_alert_source,
      local_status: ost$status,
      local_supportive_information_p: ^SEQ ( * );

    status.normal := TRUE;

    local_status := status;
    local_alert_source := alert_source;
    local_supportive_information_p := supportive_information_p;

    dsp$dft_issue_system_alert (local_alert_source, local_supportive_information_p, local_status);
    status := local_status;

  PROCEND dsp$issue_system_alert;
MODEND dsm$deadstart_services_236;
*DECK DECK=DSM$DEADSTART_SERVICES_23D EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Deadstart Services 23D' ??
MODULE dsm$deadstart_services_23d;

{ PURPOSE:
{   This module contains the procedures that allow other procedures to call 113.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc dsp$check_interval
*copyc dsp$force_lock_of_main_window
?? OLDTITLE ??
?? NEWTITLE := 'dsp$check_interval_23d', EJECT ??

{ PURPOSE:
{   This procedure is called by the run virtual system (system job monitor) task.

  PROCEDURE [XDCL, #GATE] dsp$check_interval_23d;

    dsp$check_interval;

  PROCEND dsp$check_interval_23d;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$force_lock_of_window_23d', EJECT ??

{ PURPOSE:
{   This procedure is called by the console interaction task.

  PROCEDURE [XDCL, #GATE] dsp$force_lock_of_window_23d;

    dsp$force_lock_of_main_window;

  PROCEND dsp$force_lock_of_window_23d;
?? OLDTITLE ??
MODEND dsm$deadstart_services_23d;
*DECK DECK=DSM$DEADSTART_SERVICES_MONITOR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Deadstart Services Monitor Routines' ??
MODULE dsm$deadstart_services_monitor;

{ PURPOSE:
{   This module contains deadstart procedures which run in monitor mode.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cml$pp_timed_out
*copyc dst$cpu_pp_communication_block
*copyc dst$log_pp_timed_out
*copyc dst$mainframe_type
*copyc dst$signal_contents
*copyc dst$sub_mainframe_type
*copyc oss$mainframe_wired
*copyc oss$mainframe_wired_cb
*copyc ost$system_flag
?? POP ??
*copyc dpp$display_error
*copyc dsp$convert_seq_p_to_r_pointer
*copyc dsp$mtr_get_ssr_data_seq_ptr
*copyc dsp$report_system_message
*copyc mtp$get_date_time_at_timestamp
*copyc tmp$send_signal
?? EJECT ??
*copyc dsv$dftb_data
*copyc dsv$dfts_control_word_p
*copyc mtv$dft_block_p
*copyc mtv$nst_p
*copyc mtv$scb
*copyc mtv$time_to_call_handshaking
*copyc tmv$system_job_monitor_gtid
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    c$next_check = 2 * 1000000;       {2 seconds.

  TYPE
    t$pp_timed_out = RECORD
      sci_timed_out: boolean,
      dft_timed_out: boolean,
      dfts_timed_out_or_not_there: boolean,
    RECEND;

  VAR
    dsv$cpu_pp_communication_block: [XDCL, #GATE, oss$mainframe_wired_cb] dst$cpu_pp_communication_block :=
          [[FALSE, 0, FALSE, FALSE, FALSE, 0, 0, FALSE, FALSE, FALSE, 0, 0, 0, 0, 0], 0, 0, 0, 0],
    dsv$mainframe_type: [XDCL, #GATE] dst$mainframe_type := dsc$mt_unknown_mainframe,
    dsv$sub_mainframe_type: [XDCL, #GATE] dst$sub_mainframe_type := dsc$smt_unknown_mainframe,

    v$pps_timed_out: [oss$mainframe_wired] t$pp_timed_out := [FALSE, FALSE, FALSE];
?? OLDTITLE ??
?? NEWTITLE := 'initialize_cpu_pp_comm', EJECT ??

{ PURPOSE:
{   This procedure initializes the CPU/PP communication block and stores an R-pointer to it in EICB word
{   D8RLP.  The procedure must not be executed until the secondary DFT is loaded (if there is one).

  PROCEDURE initialize_cpu_pp_comm;

    VAR
      dft_verified: boolean,
      dfts_buffer_p: ^dst$ssr_dfts_buffer,
      dfts_buffer_seq_p: ^SEQ ( * ),
      free_running_clock: integer;

    { Initialize relocation word.

    dsv$cpu_pp_communication_block.relocation.initialized := TRUE;
    dsv$cpu_pp_communication_block.relocation.dft_pp_number := mtv$dft_block_p^.dft_pp_number;
    dsv$cpu_pp_communication_block.relocation.dft_pp_at_deadstart := mtv$dft_block_p^.dft_pp_number;
    dsv$cpu_pp_communication_block.relocation.sci_pp_number := mtv$nst_p^.d8st.sci_pp_number;
    dsv$cpu_pp_communication_block.relocation.sci_pp_at_deadstart := mtv$nst_p^.d8st.sci_pp_number;

    { Initialize free running clock words.

    free_running_clock := #FREE_RUNNING_CLOCK (0);
    dsv$cpu_pp_communication_block.monitor_time := free_running_clock;
    dsv$cpu_pp_communication_block.sci_time := free_running_clock;
    dsv$cpu_pp_communication_block.dft_time := free_running_clock;

    { Determine if a secondary IOU exists by checking if the secondary DFT has checked in.

    IF dsv$dftb_data.revision_level <= dsc$dftb_revision_level_5 THEN
      dsp$mtr_get_ssr_data_seq_ptr (dsc$ssr_secondary_dft_block, dfts_buffer_seq_p);
      NEXT dfts_buffer_p IN dfts_buffer_seq_p;
      dft_verified := dfts_buffer_p^.control_word.dft_verification;
    ELSEIF dsv$dfts_control_word_p <> NIL THEN
      dft_verified := dsv$dfts_control_word_p^.dft_verification;
    ELSE
      dft_verified := FALSE;
    IFEND;
    IF dft_verified THEN
      dsv$cpu_pp_communication_block.dfts_time := free_running_clock;
    ELSE
      v$pps_timed_out.dfts_timed_out_or_not_there := TRUE;
    IFEND;

    { Set monitor update time to current time + 5 seconds.

    mtv$time_to_call_handshaking := free_running_clock + c$next_check;

    { Set EICB pointer word.

    dsp$convert_seq_p_to_r_pointer (#SEQ (dsv$cpu_pp_communication_block),
          mtv$nst_p^.dfcm9.cpu_pp_communication_buffer);

  PROCEND initialize_cpu_pp_comm;
?? OLDTITLE ??
?? NEWTITLE := 'issue_pp_timeout_message', EJECT ??

{ PURPOSE:
{   This procedure issues a PP time out message to the display console critical window and to the
{   Engineering Log.

  PROCEDURE issue_pp_timeout_message
    (    free_running_clock_stamp: integer,
         pp_name: string (5));

    TYPE
      eng_log_msg = RECORD
        message_type: integer,
        message_data: dst$log_pp_timed_out,
      RECEND;

    VAR
      critical_window_message: string (29),
      date_time: ost$date_time,
      eng_log_message: eng_log_msg,
      msg_recorded: boolean;

    { Issue message to display console critical window.

    critical_window_message (1, 14) := 'ERR=VEOS6000- ';
    critical_window_message (15, 5) := pp_name;
    critical_window_message (20, 10) := ' TIMED OUT';
    dpp$display_error (critical_window_message);

    { Issue message to Engineering Log.

    mtp$get_date_time_at_timestamp (free_running_clock_stamp, date_time);
    eng_log_message.message_type := cml$pp_timed_out;
    eng_log_message.message_data.date_time := date_time;
    eng_log_message.message_data.pp_name := pp_name;
    dsp$report_system_message (#SEQ (eng_log_message), dsc$general_system_message, dsc$fatal_error,
          msg_recorded);

  PROCEND issue_pp_timeout_message;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$perform_cpu_pp_handshaking', EJECT ??

{ PURPOSE:
{   This procedure performs CPU/PP handshaking for monitor.  It updates the monitor time word from the free
{   running clock.  Then it checks the PP time words for PP timeout (thirty seconds since a PP updated its
{   time word).
{
{ NOTE:
{   The timeout period should be 30 seconds (5 minutes on the Cyber 2000).   However, the CPU/PP handshaking
{   design does not cover the case where an operator types control-G, control-R and looks at the TPM displays
{   for a long period of time.  In this case, DFT and SCI would hang waiting for channel 17 and monitor would
{   think they timed out.  Therefore, until this design hole is fixed, the timeout period is set to infinite.
{   When fixed the constant time_out_period should be changed to 30 * 1000000.

  PROCEDURE [XDCL] dsp$perform_cpu_pp_handshaking;

    CONST
      c$cy2000_time_out_period = 300 * 1000000,    { 5 minutes
      c$time_out_period = 0ffffffffffff(16);      { infinite - see note above

    VAR
      free_running_clock: integer,
      ignore_status: syt$monitor_status,
      signal: dst$signal_contents,
      time_out_period: integer,
      time_since_pp_checkin: integer;

    { Initialize CPU/PP communication if this is the first call.

    IF NOT dsv$cpu_pp_communication_block.relocation.initialized THEN
      initialize_cpu_pp_comm;
    IFEND;

    { Do not allow heartbeat to be updated if a fatal software or hardware error exists.

    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      IF (mtv$scb.nos_180_status.idle_code = syc$ic_system_terminated) OR
            (mtv$scb.nos_180_status.idle_code = syc$ic_fatal_software_error) OR
            (mtv$scb.nos_180_status.idle_code = syc$ic_fatal_hardware_error) OR
            (mtv$scb.nos_180_status.idle_code = syc$ic_hardware_idle) THEN
        RETURN;
      IFEND;
    IFEND;

    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      time_out_period := c$cy2000_time_out_period;
    ELSE
      time_out_period := c$time_out_period;
    IFEND;

    { Update the monitor time word.

    free_running_clock := #free_running_clock(0);
    dsv$cpu_pp_communication_block.monitor_time := free_running_clock;

    { Check the SCI time word if SCI not previously timed out.

    IF NOT v$pps_timed_out.sci_timed_out THEN
      time_since_pp_checkin := free_running_clock - dsv$cpu_pp_communication_block.sci_time;
      IF time_since_pp_checkin > time_out_period THEN
        issue_pp_timeout_message (dsv$cpu_pp_communication_block.sci_time, 'SCI  ');
        v$pps_timed_out.sci_timed_out := TRUE;
      IFEND;
    IFEND;

    { Check the DFT time word if DFT not previously timed out.

    IF NOT v$pps_timed_out.dft_timed_out THEN
      time_since_pp_checkin := free_running_clock - dsv$cpu_pp_communication_block.dft_time;
      IF time_since_pp_checkin > time_out_period THEN
        IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
          issue_pp_timeout_message (dsv$cpu_pp_communication_block.dft_time, 'SP   ');
          signal.identifier := dsc$deadstart_signal;
          signal.contents.kind := dsc$signal_post_operator_action;
          mtp$get_date_time_at_timestamp (dsv$cpu_pp_communication_block.dft_time,
                signal.contents.poa_data.date_time);
          signal.contents.poa_data.kind := dsc$signal_poa_sp_timeout;
          tmp$send_signal (tmv$system_job_monitor_gtid, signal.signal, ignore_status);
        ELSE
          issue_pp_timeout_message (dsv$cpu_pp_communication_block.dft_time, 'DFT  ');
        IFEND;
        v$pps_timed_out.dft_timed_out := TRUE;
      IFEND;
    IFEND;

    { Check the DFT-S time word if DFT-S exists and has not previously timed out.

    IF NOT v$pps_timed_out.dfts_timed_out_or_not_there THEN
      time_since_pp_checkin := free_running_clock - dsv$cpu_pp_communication_block.dfts_time;
      IF time_since_pp_checkin > time_out_period THEN
        issue_pp_timeout_message (dsv$cpu_pp_communication_block.dft_time, 'DFT-S');
        v$pps_timed_out.dfts_timed_out_or_not_there := TRUE;
      IFEND;
    IFEND;

    { Set monitor update time for next CPU/PP handshaking call.

    mtv$time_to_call_handshaking := free_running_clock + c$next_check;

  PROCEND dsp$perform_cpu_pp_handshaking;
MODEND dsm$deadstart_services_monitor;
*DECK DECK=DSM$DSMTRM EXPAND=TRUE
          IDENT  DSMTRM
          ENTRY  DSMTRM

*
*         THIS PROGRAM PROVIDES THE ENTRY POINT AND PROGRAM NAME FOR
*         *DSMTRM*, IT BRANCHES TO THE ENTRY POINT IN *DSM$TERMINATE-NOS-VE*.
*         THE REASON FOR THIS IS THAT SOME ASSEMBLY LANGUAGE K DISPLAY
*         INTERFACES MUST BE LOADED BELOW 10000(8) FOR NOS/BE.
*         *DSM$TERMINATE-NOS-VE* EXCEEDED 10000(8) WORDS WHICH CAUSED
*         THIS PROBLEM.
*

 DSMTRM   BSS    0           ENTRY.
          EQ     =XDSPTNVE   BRANCH TO *DSM$TERMINATE-NOS-VE*.
          END    DSMTRM
*DECK DECK=DSM$DST180 EXPAND=TRUE
.PROC,DST180.
REWIND,NOSVETP,CMDFILE,CMDS3.
ACCFILE.
DSMDST.
REWIND(NOSVETP)
DISPLAY(R2)
DISPLAY(R1G)
DISPLAY(EFG)
RUN180.
REVERT.
EXIT.
DMD.
DMD,0,200000.
DAYFILE,OUTPUT.
ROUTE,OUTPUT,DC=PR.
RETURN(NOSVETP)
REVERT.
/EOR
*DECK DECK=DSM$DSTCMDS EXPAND=TRUE
.PROC,DSTCMDS*I,
C   "- COMMAND DECK"                   = (*N=,*S2(01234567)),
W   "- WAIT FOR OPERATOR INTERVENTION" = (*N=,F=0,T=1),
T   "- Deadstart type                " = (*N=,CR,DISK,TAPE),
S   "- SCD PORT"                       = (*N=0,0,1),
.
.HELP
THIS PROCEDURE CREATES THE COMMAND FILE FOR *DSMDST*.
.ENDHELP
REVERT. CMDFILE CREATED.
.*
.*  THE FOLLOWING FORMS THE NORMAL COMMAND FILE FOR *DSMDST*.
.*
.DATA,CMDFILE.
.IFE,$T$.NE.$$,NEWSCD.
*DSOPTION=T.
.ENDIF,NEWSCD.
.IFE,$S$.NE.$$,NEWSCD.
*SCD=S.
.ENDIF,NEWSCD.
*RUN.                 **RUN WITHOUT PAUSE FOR OPERATOR ACTION....
.* THESE PANEL DIRECTIVES ESTABLISH THE FOLLOWING DEFAULT VALUES
.*    WORD 13 - DEFAULT SYSTEM CORE COMMAND DECK NUMBER = 01 (DCF01)
.*    WORD 13 - DEFAULT WAIT FOR OPERATOR INTERVENTION = 1 (TRUE)
*PANEL,13(8)=101.
.* IF ANY OF THE SETVE PARAMETERS C, CH, OR W HAVE BEEN SPECIFIED,
.*   THEN THE FOLLOWING DIRECTIVES OVERRIDE THE DEFAULT VALUES.
.IFE,$W$.NE.$$,NEWW.
*PANEL,0FFFF0(16)=W.  **SETVE WAIT, SET TO 1 FOR OPERATOR INTERVENTION
.ENDIF,NEWW.
.IFE,$C$.NE.$$,NEWC.
*PANEL,0FFFFF(16)=C.  **SETVE COMMAND DECK NUMBER
.ENDIF,NEWC.
*ENDLST.
*ENDLST.
/EOR
*DECK DECK=DSM$ESTABLISH_DEADSTART_CATALOG EXPAND=TRUE
PROCEDURE establish_deadstart_catalog (
  status)

  VAR
    dsv$estdbs_catalog_specified: (XREF) boolean
    dsv$estdbs_created_catalog: (XREF) string 0 .. $max_name
    dsv$estdbs_existing_catalog: (XREF) file
    dsv$estdbs_ex_vsn: (XREF) string 1 .. 6
    dsv$estdbs_re_vsn: (XREF) string 1 ..6
    dsv$estdbs_tape_type: (XREF) key mt9$1600 mt9$6250 mt18$38000 keyend
    ignore_status: status
    local_status: status
  VAREND

  WHEN any_fault DO
    put_line l=' Establish_disk_based_system failed with:'
    put_line l=$string(osv$status)
    EXIT PROCEDURE WITH osv$status
  WHENEND

  "  If a deadstart catalog parameter was not specified, call create_ve_deadstart_catalog
  "  to create a deadstart catalog from the deadstart tape.

  IF NOT dsv$estdbs_catalog_specified THEN
    IF dsv$estdbs_ex_vsn = 'NULL' THEN
      create_ve_deadstart_catalog dc=$fname('$system.'//dsv$estdbs_created_catalog) rvsn=dsv$estdbs_re_vsn ..
            t=dsv$estdbs_tape_type status=local_status
      IF NOT local_status.normal THEN
        EXIT PROCEDURE WITH local_status
      IFEND
    ELSEIF dsv$estdbs_re_vsn = 'NULL' THEN
      create_ve_deadstart_catalog dc=$fname('$system.'//dsv$estdbs_created_catalog) evsn=dsv$estdbs_ex_vsn ..
            t=dsv$estdbs_tape_type status=local_status
      IF NOT local_status.normal THEN
        EXIT PROCEDURE WITH local_status
      IFEND
    ELSE
      create_ve_deadstart_catalog dc=$fname('$system.'//dsv$estdbs_created_catalog) evsn=dsv$estdbs_ex_vsn ..
            rvsn=dsv$estdbs_re_vsn t=dsv$estdbs_tape_type status=local_status
      IF NOT local_status.normal THEN
        EXIT PROCEDURE WITH local_status
      IFEND
    IFEND
  IFEND

  "  If a deadstart catalog parameter was not specified, then install the newly created deadstart
  "  catalog.  Otherwise, install the catalog specified.

  IF NOT dsv$estdbs_catalog_specified THEN
    install_ds_catalog_to_disk dc=$fname('$system.'//dsv$estdbs_created_catalog) status=local_status
  ELSE
    install_ds_catalog_to_disk dc=dsv$estdbs_existing_catalog status=local_status
  IFEND
  EXIT PROCEDURE WITH local_status
PROCEND establish_deadstart_catalog
*DECK DECK=DSM$ESTABLISH_DISK_BASED_SYSTEM EXPAND=TRUE
PROCEDURE establish_disk_based_system, estdbs (
  deadstart_catalog, dc: file = $optional
  external_vsn, evsn, ev: any of
      string 1..6
      name 1..6
    anyend = $optional
  recorded_vsn, rvsn, rv: any of
      string 1..6
      name 1..6
    anyend = $optional
  type, t: any of
      key
        mt9$1600
        mt9$6250
        mt18$38000
      keyend
    anyend = mt9$6250
  status)

  VAR
    local_status: status
  VAREND

  "  If the deadstart_catalog is already on disk (deadstart_catalog parameter), then neither
  "  the external_vsn nor the recorded_vsn may be specified.  Otherwise, if the deadstart catalog
  "  is not already on disk, then either the external_vsn or the recorded_vsn must be specified.

  IF $specified(deadstart_catalog) THEN
    IF $specified(external_vsn) OR $specified(recorded_vsn) THEN
      local_status = $status(FALSE, 'DS', dse$cannot_use_both_catalog_vsn)
      EXIT PROCEDURE WITH local_status
    IFEND
  ELSE
    IF NOT $specified(external_vsn) AND NOT $specified(recorded_vsn) THEN
      local_status = $status(FALSE, 'DS', dse$must_specify_catalog_or_vsn)
      EXIT PROCEDURE WITH local_status
    IFEND
  IFEND

  "  Create the global variables.

  VAR
    dsv$estdbs_catalog_specified: (JOB) boolean = TRUE
    dsv$estdbs_created_catalog: (JOB) string 0 .. $max_name = $unique
    dsv$estdbs_existing_catalog: (JOB) file
    dsv$estdbs_ex_vsn: (JOB) string 1 .. 6
    dsv$estdbs_re_vsn: (JOB) string 1 ..6
    dsv$estdbs_tape_type: (JOB) key mt9$1600 mt9$6250 mt18$38000 keyend = type
  VAREND

  IF $specified(deadstart_catalog) THEN
    dsv$estdbs_existing_catalog = deadstart_catalog
  ELSE
    dsv$estdbs_catalog_specified = FALSE
  IFEND

  IF $specified(external_vsn) THEN
    dsv$estdbs_ex_vsn = $string(external_vsn)
  ELSE
    dsv$estdbs_ex_vsn = 'NULL'
  IFEND

  IF $specified(recorded_vsn) THEN
    dsv$estdbs_re_vsn = $string(recorded_vsn)
  ELSE
    dsv$estdbs_re_vsn = 'NULL'
  IFEND

  put_line l=' Establishing disk based system ... ' o=$response
  put_line l=' Please wait for completion message. ' o=$response

  "  Execute a task to install the deadstart file.

  TASK tn=install_ds_catalog_to_disk

    VAR
      command_status: status
      ignore_status: status
      local_status: status
    VAREND

    maintain_deadstart_software

      include_command c='establish_deadstart_catalog status=local_status' status=command_status
      IF NOT command_status.normal THEN
        local_status = command_status
      IFEND

    quit

    IF NOT local_status.normal THEN
      display_value v='The command Establish_disk_based_system returned the following bad status:'
      display_value v=local_status
    IFEND

    IF NOT dsv$estdbs_catalog_specified THEN
      delete_catalog c=$fname('$system.'//dsv$estdbs_created_catalog), do=catalog_and_contents, status=ignore_status
    IFEND

    delete_variable n=dsv$estdbs_catalog_specified
    delete_variable n=dsv$estdbs_created_catalog
    delete_variable n=dsv$estdbs_existing_catalog
    delete_variable n=dsv$estdbs_ex_vsn
    delete_variable n=dsv$estdbs_re_vsn
    delete_variable n=dsv$estdbs_tape_type

  TASKEND

 PROCEND establish_disk_based_system
*DECK DECK=DSM$FAKE_CM_INTERFACE EXPAND=TRUE
MODULE dsm$fake_cm_interface ALIAS 'DSMFCI';

*copy pxiotyp
?? PUSH (LISTEXT := ON) ??
*copy pxziobs
*copy dizclos
*copy dizopen
*copy dizput
*copy dizgetd
*copy dizputd
*copy dizfirs
*copy zutpabt
*copy zutpmsg
?? POP ??

  TYPE
    big_type = packed record
      case integer of
      = 0 =
        w0: 0 .. 0ffffffff(16),
        l0: 0 .. 0fffffff(16),
      = 1 =
        t1: 0 .. 0f(16),
        w1: 0 .. 0ffffffff(16),
        l1: 0 .. 0ffffff(16),
      = 2 =
        t2: 0 .. 0ff(16),
        w2: 0 .. 0ffffffff(16),
        l2: 0 .. 0fffff(16),
      = 3 =
        t3: 0 .. 0fff(16),
        w3: 0 .. 0ffffffff(16),
        l3: 0 .. 0ffff(16),
      = 4 =
        t4: 0 .. 0ffff(16),
        w4: 0 .. 0ffffffff(16),
        l4: 0 .. 0fff(16),
      = 5 =
        t5: 0 .. 0ffff(16),
        w5: 0 .. 0ffffffff(16),
        l5: 0 .. 0ff(16),
      = 6 =
        t6: 0 .. 0ffffff(16),
        w6: 0 .. 0ffffffff(16),
        l6: 0 .. 0f(16),
      = 7 =
        t7: 0 .. 0fffffff(16),
        w7: 0 .. 0ffffffff(16),
      = 8 =
        i: integer,
      casend,
    recend;

  PROCEDURE string_number (s: string ( * );
        number: integer);

    VAR
      msg: ^string ( * ),
      n: integer,
      i: integer;

    i := STRLENGTH (s);
    PUSH msg: [i + 10];
    msg^ := s;
    STRINGREP (msg^ (i + 1, 10), n, number);
    utp$issue_dayfile_message (msg^);
  PROCEND string_number;
?? NEWTITLE := '  Simulate 017 interface', EJECT ??
{*********************************************************}
{}
{ simulate 017 requests.
{}
{*********************************************************}

  CONST
    dayfile_display = 0,
    control_point_display = 1;

  TYPE
    deadstart_type = (start_dual_state, term_dual_state);

  VAR
    running: integer := 0,
    exitcd: [XREF] integer;

  PROCEDURE [XDCL] wakeup;
  PROCEND wakeup;

  PROCEDURE [XDCL] deadstart_cpu ALIAS 'dstcpu' (kind: deadstart_type);
    utp$issue_dayfile_message ('deadstart cpu');
    utp$abort;
    IF kind = start_dual_state THEN
      running := 1;
    ELSE
      running := 0;
    IFEND;
    exitcd := running;
  PROCEND deadstart_cpu;

  PROCEDURE [XDCL] get_ve_status ALIAS 'getvest' (VAR status: integer);
    utp$issue_dayfile_message ('get ve status');
    exitcd := running;
    status := 1;
  PROCEND get_ve_status;

?? OLDTITLE ??

?? NEWTITLE := '  Central memory access routines', EJECT ??
{********************************************************}
{}
{Central memory access routines}
{}
{********************************************************}

  CONST
    max_memory_transfer = 30000;

  TYPE
    cm_transfer_method = (nos60_to_ve64, ve64_to_nos60, nos32_to_ve64,
      ve64_to_nos32, nos60_to_ve60, ve60_to_nos60, zero60_to_ve64),
    starting_pva = (interface_block, start_of_ve, start_of_ssr,
      start_of_mf_wired),
    memory_copy_header = record
      length: 0 .. max_memory_transfer,
      copy_method: cm_transfer_method,
      pva_type: starting_pva,
      byte_rma: 0 .. 0ffffffff(16),
    recend;

  VAR
    memory: file := NIL,
    pvas: array [starting_pva] of integer := [60320(8), 0, 0, 0],
    plen: array [starting_pva] of integer := [61320(8), 0, 0, 0];


  PROCEDURE [XREF] abort;

  PROCEDURE [XDCL] copy_memory ALIAS 'minilnk' (VAR hdr: memory_copy_header;
        buffer_pointer: ^cell);

    VAR
      ba: ^array [1 .. 2100] of integer,
      update: boolean,
      start: integer,
      last: integer,
      length: integer,
      size: integer,
      byte_rma: integer,
      byte_length: integer,
      buf: ^array [1 .. * ] of integer,
      ip: ^integer,
      nibble: integer,
      v: integer,
      b: big_type,
      n: integer,
      j: integer,
      i: integer;

    IF memory = NIL THEN
      utp$issue_dayfile_message ('build cm file');
      di#open (memory, 'cmimage', new#, concurrent#, first#);
      PUSH ba;
      FOR i := 1 TO 4000(8) DO
        ba^ [i] := 0;
      FOREND;
      FOR i := 1 TO osmin DIV 20000(8) DO
        di#put (memory, j, ba, 4000(8));
      FOREND;
      FOR i := 1 TO 4000(8) DO
        ba^ [i] := 0ffffffff(16);
      FOREND;
      FOR i := 1 TO (velwa - osmin) DIV 20000(8) DO
        di#put (memory, j, ba, 4000(8));
      FOREND;
    IFEND;

    byte_rma := hdr.byte_rma + pvas [hdr.pva_type];
    start := byte_rma DIV 4 * 4;
    length := hdr.length;
    CASE hdr.copy_method OF
    = nos60_to_ve60, ve60_to_nos60, zero60_to_ve64 =
      byte_length := length * 8;
    = nos32_to_ve64, ve64_to_nos32 =
      byte_length := length * 4;
    = nos60_to_ve64, ve64_to_nos60 =
      byte_length := length DIV 2 * 15;
    CASEND;

    update := FALSE;

    last := (byte_rma + byte_length + 3) DIV 4 * 4;
    IF last > plen [hdr.pva_type] THEN
      utp$issue_dayfile_message ('bad cm request');
      string_number ('length ', hdr.length);
      string_number ('offset ', hdr.byte_rma);
      string_number ('method ', $INTEGER (hdr.copy_method));
      string_number ('pva    ', $INTEGER (hdr.pva_type));
      abort;
      utp$abort;
      RETURN;
    IFEND;

    size := (last - start) DIV 4;
    PUSH buf: [1 .. size + 1];

    di#getdir (memory, start DIV 4, buf, size);

    ba := buffer_pointer;
    ip := #LOC (ba);

    CASE hdr.copy_method OF

    = zero60_to_ve64 =
      update := TRUE;
      string_number ('transfer z60v64', byte_rma);
      FOR i := 1 TO length DO
        buf^ [2 * i] := 0;
        buf^ [2 * i - 1] := 0;
      FOREND;

    = nos60_to_ve60 =
      update := TRUE;
      string_number ('transfer n60v60', byte_rma);
      FOR i := 1 TO length DO
        b.i := ba^ [i];
        buf^ [2 * i] := b.w7;
        buf^ [2 * i - 1] := b.t7;
      FOREND;

    = ve60_to_nos60 =
      string_number ('transfer v60n60', byte_rma);
      FOR i := 1 TO length DO
        b.t7 := buf^ [2 * i - 1] MOD 10000000(16);
        b.w7 := buf^ [2 * i];
        ba^ [i] := b.i;
      FOREND;

    = nos32_to_ve64 =
      update := TRUE;
      string_number ('transfer n32v64', byte_rma);
      FOR i := 1 TO length DO
        buf^ [i] := ba^ [i];
      FOREND;

    = ve64_to_nos32 =
      string_number ('transfer v64n32', byte_rma);
      FOR i := 1 TO length DO
        ba^ [i] := buf^ [i];
      FOREND;

    = nos60_to_ve64 =
      update := TRUE;
      string_number ('transfer n60v64', byte_rma);
      nibble := byte_rma MOD 4;
      b.i := buf^ [1];
      CASE nibble OF
      = 2 =
        b.l1 := 0;
        j := 2;
        nibble := 6;
      = 4 =
        b.l3 := 0;
        j := 2;
        nibble := 4;
      = 6 =
        b.l5 := 0;
        j := 2;
        nibble := 2;
      = 0 =
        j := 1;
      CASEND;
      n := b.i;

      FOR i := 1 TO length DO
        b.i := ba^ [i];
        CASE nibble OF
        = 0 =
          buf^ [j] := b.w0;
          n := b.l0 * 10(16);
          j := j + 1;
        = 1 =
          buf^ [j] := n + b.t1;
          buf^ [j + 1] := b.w1;
          n := b.l1 * 100(16);
          j := j + 2;
        = 2 =
          buf^ [j] := n + b.t2;
          buf^ [j + 1] := b.w2;
          n := b.l2 * 1000(16);
          j := j + 2;
        = 3 =
          buf^ [j] := n + b.t3;
          buf^ [j + 1] := b.w3;
          n := b.l3 * 10000(16);
          j := j + 2;
        = 4 =
          buf^ [j] := n + b.t4;
          buf^ [j + 1] := b.w4;
          n := b.l4 * 100000(16);
          j := j + 2;
        = 5 =
          buf^ [j] := n + b.t5;
          buf^ [j + 1] := b.w5;
          n := b.l5 * 1000000(16);
          j := j + 2;
        = 6 =
          buf^ [j] := n + b.t6;
          buf^ [j + 1] := b.w6;
          n := b.l6 * 10000000(16);
          j := j + 2;
        = 7 =
          buf^ [j] := n + b.t7;
          buf^ [j + 1] := b.w7;
          j := j + 2;
        CASEND;
        nibble := (nibble + 1) MOD 8;
      FOREND;

      b.i := buf^ [j];
      CASE nibble OF
      = 0 =
        ;
      = 1 =
        buf^ [j] := n + b.l6;
      = 2 =
        buf^ [j] := n + b.l5;
      = 3 =
        buf^ [j] := n + b.l4;
      = 4 =
        buf^ [j] := n + b.l3;
      = 5 =
        buf^ [j] := n + b.l2;
      = 6 =
        buf^ [j] := n + b.l1;
      = 7 =
        buf^ [j] := n + b.l0;
      CASEND;


    = ve64_to_nos60 =
      string_number ('transfer v64n60', byte_rma);
      nibble := byte_rma MOD 4;

      CASE nibble OF
      = 0 =
        j := 1;
        nibble := 0;
      = 1 =
        n := buf^ [1] MOD 100(16);
        j := 2;
        nibble := 6;
      = 2 =
        n := buf^ [1] MOD 10000(16);
        j := 2;
        nibble := 4;
      = 3 =
        n := buf^ [1] MOD 1000000(16);
        j := 2;
        nibble := 2;
      CASEND;

      FOR i := 1 TO length DO
        CASE nibble OF
        = 0 =
          n := buf^ [j + 1];
          b.w0 := buf^ [j];
          b.l0 := n DIV 10(16);
          v := n MOD 10(16);
          j := j + 2;
        = 1 =
          n := buf^ [j + 1];
          b.t1 := v;
          b.w1 := buf^ [j];
          b.l1 := n DIV 100(16);
          v := n MOD 100(16);
          j := j + 2;
        = 2 =
          n := buf^ [j + 1];
          b.t2 := v;
          b.w2 := buf^ [j];
          b.l2 := n DIV 1000(16);
          v := n MOD 1000(16);
          j := j + 2;
        = 3 =
          n := buf^ [j + 1];
          b.t3 := v;
          b.w3 := buf^ [j];
          b.l3 := n DIV 10000(16);
          v := n MOD 10000(16);
          j := j + 2;
        = 4 =
          n := buf^ [j + 1];
          b.t4 := v;
          b.w4 := buf^ [j];
          b.l4 := n DIV 100000(16);
          v := n MOD 100000(16);
          j := j + 2;
        = 5 =
          n := buf^ [j + 1];
          b.t5 := v;
          b.w5 := buf^ [j];
          b.l5 := n DIV 1000000(16);
          v := n MOD 1000000(16);
          j := j + 2;
        = 6 =
          n := buf^ [j + 1];
          b.t6 := v;
          b.w6 := buf^ [j];
          b.l6 := n DIV 10000000(16);
          v := n MOD 10000000(16);
          j := j + 2;
        = 7 =
          b.i := v * 100000000(16) + buf^ [j];
          j := j + 1;
        CASEND;
        ba^ [i] := b.i;
        nibble := (nibble + 1) MOD 8;
      FOREND;
    CASEND;

    IF update THEN
      di#putdir (memory, start DIV 4, buf, size);
      di#first (memory);
    IFEND;
  PROCEND copy_memory;

  PROCEDURE [XDCL] set_ei_pva ALIAS 'seteiad' (pva: starting_pva;
        word_offset: integer);
    string_number ('set ei pva ', $INTEGER (pva));
    string_number ('  offset = ', word_offset * 8);
    pvas [pva] := word_offset * 8;
    plen [pva] := velwa;
  PROCEND set_ei_pva;

  PROCEDURE [XDCL] get_ei_pva ALIAS 'geteiad' (pva: starting_pva;
    VAR word_offset: integer);
    utp$issue_dayfile_message ('get ei address');
    word_offset := pvas [pva];
  PROCEND get_ei_pva;
?? OLDTITLE ??

?? NEWTITLE := '  Simulated VER interface', EJECT ??
{***********************************************************}
{}
{Interface to 170 OS virtual environment resource program.}
{}
{************************************************************}

  TYPE
    a170pps = packed record
      pp_number: 0 .. 77(8),
      fill: 0 .. 77777777777777(8),
      status: 0 .. 7777(8),
    recend,
    a170_channels = packed record
      channel: 0 .. 77(8),
      fill: 0 .. 77777777777777(8),
      status: 0 .. 7777(8),
    recend,
    eq_path = packed record
      channel: 0 .. 77(8),
      equipment: 0 .. 77(8),
      unit: 0 .. 77(8),
      fill: 0 .. 7777777777(8),
      status: 0 .. 7777(8),
      fil1: 0 .. 77777777(8),
      equipment_type: 0 .. 7777(8),
      fil2: 0 .. 77777(8),
      est_ordinal: 0 .. 777(8),
    recend,
    cm_request_type = packed record
      fill1: 0 .. 77777777777777(8),
      words_div_1000: 0 .. 777777(8),
      fill2: 0 .. 7777(8),
      fwa_div_1000: 0 .. 77777777(8),
      lwa_div_1000: 0 .. 77777777(8),
    recend,
    resource_status_type = packed record
      fill1: 0 .. 77777777777777(8),
      available_words_div_1000: 0 .. 777777(8),
      fill2: 0 .. 777777777777(8),
      fill3: 0 .. 777777(8),
      available_pps: 0 .. 77(8),
    recend,
    ver_functions = (rscm, rspp, rsch, rseq, rtcm, rtpp, rtch, rteq, stcm,
      stpp, stch, steq, stmr),
    ver_request_block = packed record
      return_all: boolean,
      fill: 0 .. 377777777777(8),
      length: 0 .. 7777(8),
      general_status: 0 .. 7777(8),
      case ver_functions of
      = rscm, rtcm, stcm =
        cm_block: cm_request_type,
      = stmr =
        resources: resource_status_type,
      = rspp, rtpp, stpp =
        pp_list: array [1 .. 20] of a170pps,
      = rsch, rtch, stch =
        channel_list: array [1 .. 20] of a170_channels,
      = rseq, rteq, steq =
        eq_list: array [1 .. 10] of eq_path,
      casend,
    recend;

  TYPE
    ch_set = set of 0 .. 37(8),
    pp_set = set of 0 .. 37(8);

  VAR
    next_pp: integer := 2,
    chs: ch_set := [],
    pps: pp_set := [],
    vefwa: integer := 3ec000(16),
    velwa: integer := 3ec000(16),
    osmin: integer := 100000(16);


  PROCEDURE [XDCL] callver (VAR ver_request: ver_request_block;
        operation: ver_functions;
        wait: boolean);

    VAR
      i: integer,
      avail: integer;

    utp$issue_dayfile_message ('call ver');
    ver_request.general_status := 1;
    CASE operation OF
    = rscm =
      avail := vefwa - osmin;
      IF ver_request.cm_block.words_div_1000 <= (avail DIV 10000(8)) THEN
        vefwa := vefwa - ver_request.cm_block.words_div_1000 * 10000(8);
        ver_request.cm_block.fwa_div_1000 := vefwa DIV 10000(8);
        ver_request.cm_block.lwa_div_1000 := velwa DIV 10000(8);
      ELSE
        ver_request.general_status := 40(8);
      IFEND;

    = rtcm =
      avail := velwa - vefwa;
      IF ver_request.return_all THEN
        ver_request.cm_block.words_div_1000 := avail DIV 10000(8);
      ELSEIF ver_request.cm_block.words_div_1000 > (avail DIV 10000(8)) THEN
        ver_request.cm_block.words_div_1000 := 0;
        ver_request.general_status := 41(8);
        RETURN;
      IFEND;
      vefwa := vefwa + ver_request.cm_block.words_div_1000 * 10000(8);

    = stcm =
      ver_request.cm_block.fwa_div_1000 := vefwa DIV 10000(8);
      ver_request.cm_block.lwa_div_1000 := velwa DIV 10000(8);
      ver_request.cm_block.words_div_1000 := (velwa - vefwa) DIV 10000(8);

    = stmr =
      ver_request.resources.available_words_div_1000 := (vefwa - osmin) DIV
            10000(8);
      ver_request.resources.available_pps := 10;

    = rspp =
      FOR i := 1 TO ver_request.length DO
        ver_request.pp_list [i].pp_number := next_pp;
        pps := pps + $pp_set [next_pp];
        next_pp := next_pp + 1;
      FOREND;

    = rtpp =
      IF ver_request.return_all THEN
        pps := $pp_set [];
      IFEND;
      FOR i := 1 TO ver_request.length DO
        IF ver_request.pp_list [i].pp_number IN pps THEN
          ver_request.pp_list [i].status := 1;
          pps := pps - $pp_set [ver_request.pp_list [i].pp_number];
        ELSE
          ver_request.pp_list [i].status := 51(8);
          ver_request.general_status := 51(8);
        IFEND;
      FOREND;

    = stpp =
      FOR i := 1 TO ver_request.length DO
        IF ver_request.pp_list [i].pp_number IN pps THEN
          ver_request.pp_list [i].status := 1;
        ELSE
          ver_request.pp_list [i].status := 51(8);
          ver_request.general_status := 51(8);
        IFEND;
      FOREND;

    = rsch =
      FOR i := 1 TO ver_request.length DO
        chs := chs + $ch_set [ver_request.channel_list [i].channel];
      FOREND;

    = rtch =
      IF ver_request.return_all THEN
        chs := $ch_set [];
      IFEND;
      FOR i := 1 TO ver_request.length DO
        IF ver_request.channel_list [i].channel IN chs THEN
          ver_request.channel_list [i].status := 1;
          chs := chs - $ch_set [ver_request.channel_list [i].channel];
        ELSE
          ver_request.channel_list [i].status := 51(8);
          ver_request.general_status := 51(8);
        IFEND;
      FOREND;

    = stch =
      FOR i := 1 TO ver_request.length DO
        IF ver_request.channel_list [i].channel IN chs THEN
          ver_request.channel_list [i].status := 1;
        ELSE
          ver_request.channel_list [i].status := 51(8);
          ver_request.general_status := 51(8);
        IFEND;
      FOREND;

    = rseq =
      FOR i := 1 TO ver_request.length DO
        chs := chs + $ch_set [ver_request.channel_list [i].channel];
      FOREND;

    = rteq =
      IF ver_request.return_all THEN
        chs := $ch_set [];
      IFEND;
      FOR i := 1 TO ver_request.length DO
        IF ver_request.eq_list [i].channel IN chs THEN
          ver_request.eq_list [i].status := 1;
          chs := chs - $ch_set [ver_request.eq_list [i].channel];
        ELSE
          ver_request.eq_list [i].status := 51(8);
          ver_request.general_status := 51(8);
        IFEND;
      FOREND;

    = steq =
      FOR i := 1 TO ver_request.length DO
        IF ver_request.eq_list [i].channel IN chs THEN
          ver_request.eq_list [i].status := 1;
        ELSE
          ver_request.eq_list [i].status := 51(8);
          ver_request.general_status := 51(8);
        IFEND;
      FOREND;

    CASEND;

  PROCEND callver;
?? OLDTITLE ??
?? NEWTITLE := '  Simulated SDA interface', EJECT ??
{***********************************************************}
{}
{system deadstart assist interface definitions.
{}
{***********************************************************}


  CONST
{ logical pp numbers}
    maint_mntr = 4,
    disk_driver = 3,
    system_display_driver = 9,
    pp_resident = 10,
{ SDA function codes}
    read_mch = 2, {read maintenance channel}
    dump_pp_memory = 3, {dump pp memory to trace file}
    idle_pp = 5, {idle pp}
    register_size = 8,
    dac = 6, {deactivate pp}
    load_pp_from_ssr = 8;

  TYPE
    register_record = packed record
      register_value: packed array [1 .. register_size] of 0 .. 7777(8),
      number: 0 .. 7777(8),
      length: 0 .. 77(8),
      status: 0 .. 77(8),
    recend;

  TYPE
    pp_data_type = packed record
      port_code: 0 .. 7777(8),
      fill1: 0 .. 7777(8),
      ssr_buffer: 0 .. 77777777(8),
      completion: 0 .. 7777(8),
      buffer_length: 0 .. 7777(8),
      pp_number: 0 .. 7777(8),
      logical_pp_id: 0 .. 7777(8),
      fill2: 0 .. 77(8),
      data_buffer: ^cell,
    recend;

  PROCEDURE [XDCL] callsda (fn: integer;
    VAR pp_table: pp_data_type);
    utp$issue_dayfile_message ('call sda');
  PROCEND callsda;

?? OLDTITLE ??
MODEND dsmfci;
*DECK DECK=DSM$GETNVE EXPAND=TRUE
.PROC,GETNVE*I,
LFN "- LOCAL FILE NAME"                = (*N=NOSVETP,*F),
PFN "- PERMANENT FILE NAME"            = (*N=TPXXXK,*F),
UN  "- USER NAME OF PERMANENT FILE"    = (*N=,*F),
VSN "- TAPE VOLUME SERIAL NUMBER"      = (*N=,
                                     *S6(ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789)),
D "TAPE DENSITY (GE,PE,HD,HY)"         = (*N=PE,GE,PE,HD,HY),
.
.HELP
THE GETNVE PROCEDURE GETS THE NOS/VE DEADSTART FILE FROM EITHER A
TAPE OR A USER CATALOG.

PARAMETER   DEFAULT   DESCRIPTION
  NAME       VALUE

  LFN       NOSVETP   LOCAL FILE NAME BY WHICH THE FILE IS ACCESSED
 [PFN]      TPXXXK    PERMANENT FILE NAME OF THE STORED FILE
 [UN]                 USER NAME FROM WHICH TO DEADSTART NOS/VE
 [VSN]                VOLUME SERIAL NUMBER OF THE DEADSTART TAPE
 [D]          PE      DENSITY OF THE DEADSTART TAPE

.HELP,LFN
THE LFN PARAMETER SELECTS THE NAME BY WHICH THE FILE IS ACCESSED.
THE DEFAULT VALUE IS NOSVETP.
.HELP,PFN
THE PFN PARAMETER SELECTS THE NAME BY WHICH THE FILE WAS STORED.
THE DEFAULT VALUE IS TPXXXK.
.HELP,UN
THE UN PARAMETER SPECIFIES THE USER NAME TO SEARCH FOR THE NOS/VE
DEADSTART FILE. ON NOS/BE, THIS IS A PERMANENT FILE ID.
.HELP,VSN
THE VSN PARAMETER SPECIFIES THE VOLUME SERIAL NUMBER OF THE DEADSTART
TAPE. THE CATALOGS UN AND B ARE SEARCHED IF NO VSN IS SPECIFIED.
.HELP,D
THE D PARAMETER SELECTS THE DENSITY OF THE DEADSTART FILE.
THE DEFAULT DENSITY IS PE.
.ENDHELP
.IFE,$VSN$.EQ.$$,GETTPXXXK.
  GETFILE,LFN,PFN,UN,READ.
.ELSE,GETTPXXXK.
.IFE,SYS=NOS,NOSSYS.
  $REQUEST,LFN,#D=D,F=I,LB=KU,#VSN=VSN.
.ELSE,NOSSYS.
   REQUEST,LFN,D,#VSN=VSN.
.ENDIF,NOSSYS.
  REWIND,LFN.
.ENDIF,GETTPXXXK.
REVERT. END GETNVE
/EOR
*DECK DECK=DSM$GET_BLOCK_AND_RECORD_PD EXPAND=TRUE

  create_program_description ..
    n=(get_block_and_record_type, getbart) ..
    l=(osf$current_library, cyf$run_time_library, ..
       osf$task_services_library) ..
    sp=dsp$get_block_and_record_type
*DECK DECK=DSM$GET_BLOCK_AND_RECORD_TYPE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Get block and record type' ??
MODULE dsm$get_block_and_record_type;

{ PURPOSE:
{   This module contains a procedure which retrieves the block type and record type of a file.
{ NOTES:
{   This procedure should be deleted when the $file function is smart enough to perform this function.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc amp$get_file_attributes
*copyc clp$change_variable
*copyc clp$evaluate_parameters
?? TITLE := 'dsp$get_block_and_record_type', EJECT ??

{ PURPOSE:
{   This procedure uses amp$get_file_attributes to retrieve the block type and the record
{   type of the given file.

  PROCEDURE [XDCL] dsp$get_block_and_record_type
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE get_block_and_record_type, getbart (
{ input, i: file = $required
{ block_type, bt: (VAR) name = $required
{ record_type, rt: (VAR) name  = $required
{ status)

?? PUSH (LISTEXT := ON) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 3, 16, 10, 29, 40, 812],
    clc$command, 7, 4, 3, 0, 0, 2, 4, 'GETBART'], [
    ['BLOCK_TYPE                     ',clc$nominal_entry, 2],
    ['BT                             ',clc$abbreviation_entry, 2],
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['RECORD_TYPE                    ',clc$nominal_entry, 3],
    ['RT                             ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$required_parameter, 0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$required_parameter, 0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];
?? POP ??

  CONST
    p$input = 1,
    p$block_type = 2,
    p$record_type = 3,
    p$status = 4;

  VAR
    pvt: array [1 .. 4] of clt$parameter_value;
    VAR
      contains_data: boolean,
      gfa: ARRAY [1 .. 2] OF amt$get_item,
      local_file: boolean,
      old_file: boolean,
      value: clt$data_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    gfa [1].key := amc$block_type;
    gfa [2].key := amc$record_type;

    amp$get_file_attributes (pvt [p$input].value^.file_value^, gfa, local_file, old_file,
          contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    value.kind := clc$name;
    CASE gfa [1].block_type OF
    = amc$system_specified =
      value.name_value := 'SYSTEM_SPECIFIED';
    = amc$user_specified =
      value.name_value := 'USER_SPECIFIED';
    ELSE
      value.name_value := 'SYSTEM_SPECIFIED';
    CASEND;

    clp$change_variable (pvt [p$block_type].variable^, ^value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    value.kind := clc$name;
    CASE gfa [2].record_type OF
    = amc$variable =
      value.name_value := 'VARIABLE';
    = amc$undefined =
      value.name_value := 'UNDEFINED';
    = amc$ansi_fixed =
      value.name_value := 'FIXED';
    = amc$ansi_spanned =
      value.name_value := 'ANSI_SPANNED';
    = amc$ansi_variable =
      value.name_value := 'ANSI_VARIABLE';
    ELSE
      value.name_value := 'UNDEFINED';
    CASEND;

    clp$change_variable (pvt [p$record_type].variable^, ^value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND dsp$get_block_and_record_type;
MODEND dsm$get_block_and_record_type;
*DECK DECK=DSM$INJHFU_170 EXPAND=TRUE
          IDENT  IHFU
          ENTRY  IHFU

*copyc comscvs

 RT       SPACE  3,15
*         RT - DEFINE THE RT INSTRUCTION.
*
 RTX,X,Q  OPDEF  P1,P2,K
+         VFD    9/017B,3/P1,3/P2,15/K,30/0
          ENDM
          SPACE  4,11
**        IHFU - UTILITY PROGRAM TO INJECT HARDWARE FAULTS.
*                THIS UTILITY IS PROVIDED TO FORCE HARDWARE ERRORS FOR
*                *DFT* CHECKOUT.
*
*         INPUT: THIS PROGRAM IS CALLED WITH THE FOLLOWING 4 PARAMETERS:
*                     FAULT KIND.
*                     MODE.
*                     TRAPS ENABLED.
*                     RMA OF PARITY ERROR DIVIDED BY 1000(8).
*
*                ALLOWABLE VALUES FOR FAULT KIND ARE *RETRY*, *EXCHANG*,
*                *TRAP*, *HALT*, *PDMHALT* OR *SOFTERR*.
*                ALLOWABLE VALUES FOR *MODE* ARE *JOB* OR *MONITOR*.
*                ALLOWABLE VALUES FOR *TRAPS ENABLED* ARE *TRUE* OR
*                *FALSE*.
*                THE *RMA* MUST BE SPECIFIED AS AN OCTAL NUMBER DIVIDED
*                BY 1000(8).
*                AN EXAMPLE OF A CALL:
*                     IHFU(RETRY,JOB,FALSE,60000)
*
*         OUTPUT:
*                THE SPECIFIED FAULT IS INJECTED.
*
*
*         CALLS: CDB, VIP.
*
*         USES:  A1, A6,   B1 - B3,   X1, X2, X6, X7.
*
*         NOTE:  THIS UTILITY REQUIRES SPECIAL PRIVILEGES IN ORDER TO
*                ISSUE THE 017 INSTRUCTIONS THAT REQUEST *EI* TO INJECT
*                THE HARDWARE FAULT.
*
*                THE EASIEST WAY TO RUN THIS JOB WITH THE REQUIRED
*                PRIVILEGE IS TO MODIFY AN EXISTING NVEXXXX FILE IN
*                THE LIBRARY CATALOG BY DELETING ALL COMMANDS AFTER
*                THE *USER* COMMAND AND INSERTING THE FOLLOWING:
*                     GET,IHFU/UN=XXX.
*                     DIS.
*                THIS WILL INITIATE A JOB AND BRING UP *DIS*, AT THIS
*                TIME TYPE IN THE DESIRED *IHFU* COMMAND.
*                THE *IHFU BINARY HAD TO BE PREVIOUSLY LOADED.
*
*                THIS MODULE WAS PUT ON THE SOURCE LIBRARY WITHOUT A
*                DESTINATION FILE SO THAT IT WOULD NOT GET IN THE WAY OF
*                INTEGRATION BUILDS.  WHEN COMPILING MODULE TO GENERATE
*                A BINARY THE *OL* PARAMETER MUST BE SPECIFIED ON THE
*                *COMPILE_SOURCE* COMMAND.
*
*                THERE IS A FAULT INJECTION UTILITY THAT IS ACTIVATED
*                FROM THE SYSTEM CORE DEBUGGER FOR INJECTING FAULTS ON
*                THE 180 SIDE.  ANY CHANGES MADE TO INJECT ERRORS HERE
*                SHOULD ALSO BE ADDED THERE IF IT IS APPLICABLE.  THE
*                180 FAULT INJECTION IS IN DECK
*                *SYM$INJECT_HARDWARE_FAULTS*.
*
*                SPECIAL MICROCODE IS ALSO REQUIRED TO INJECT HARDWARE
*                FAULTS.
*

 IHFU     BSS    0           ENTRY
          SB1    1           B1 = 1 THROUGH OUT PROGRAM
          SA1    B1+B1       FAULT KIND PARAMETER
          SB2    HFK         ADDRESS OF HARDWARE FAULT KIND TABLE
          SB3    HFKL        LENGTH OF HARDWARE FAULT KIND TABLE
          RJ     VIP         VERIFY HARDWARE FAULT KIND PARAMETER
          NG     X6,IHFU15   IF ERROR IN HARDWARE FAULT KIND
          BX7    X6          FAULT KIND
          SA1    A1+B1       MODE PARAMETER
          SB2    MODE        ADDRESS OF MODE TABLE
          SB3    MODEL       LENGTH OF MODE TABLE
          RJ     VIP         VERIFY MODE PARAMETER
          NG     X6,IHFU15   IF ERROR IN MODE FLAG
          LX6    8+8
          SA1    A1+B1       TRAPS ENABLED PARAMETER
          BX7    X7+X6       ADD MODE
          SB2    TE          ADDRESS OF TRAPS ENABLED TABLE
          SB3    TEL         LENGTH OF TRAPS ENABLED TABLE
          RJ     VIP         VERIFY TRAPS ENABLED PARAMETER
          NG     X6,IHFU15   IF ERROR IN TRAPS ENABLED FLAG
          LX6    8
          SA1    A1+B1       RMA/1000(8) OF PARITY ERROR PARAMETER
          BX7    X7+X6       ADD TRAPS ENABLED FLAG
          RJ     CDB         CONVERT DISPLAY CODE TO BINARY
          ZR     X6,IHFU15   IF ERROR IN RMA OF PARITY ERROR
          BX2    X6          (RMA OF PARITY ERROR)/1000(8)
          BX1    X7
          LX2    9           RMA OF PARITY ERROR

*
*         ISSUE 017 INSTRUCTION TO INJECT SPECIFIED FAULT.
*         X1 = 36/0
*              8/MODE
*              8/TRAPS ENABLED
*              8/FUALT KIND
*         X2 = RMA OF PARITY ERROR.
*

          RT     X1,X2,CVSIHF  INJECT ERROR
          MX6    30
          BX1    -X6*X1      ERROR CODE
          BX2    X6*X0       NOS/VE DOWN FLAG
          ZR     X1,IHFU5    IF NO ERROR
          MESSAGE IHFUB,5,R
          JP     IHFU20      ABORT THE JOB

 IHFU5    BSS    0
          NZ     X2,IHFU10   IF NOS/VE DOWN
          MESSAGE IHFUC,5,R
          JP     IHFU20      ABORT THE JOB

 IHFU10   BSS    0
          SX6    3REND
          LX6    59-17
          SA6    B1
          JP     *           LOOP

*         ERROR IN PARAMETER VERIFICATION, DISPLAY MESSAGE AND ABORT
*         THE JOB.

 IHFU15   BSS    0
          MESSAGE IHFUA,5,R
 IHFU20   BSS    0
          SX6    3RABT
          LX6    59-17
          SA6    B1
          JP     *           LOOP

 IHFUA    DIS    ,*ERROR IN PARAMETER.*
 IHFUB    DIS    ,*EI DID NOT RECOGNIZE FAULT KIND.*
 IHFUC    DIS    ,*NOS/VE UP, NEED EI.*

*         ALLOWABLE HARDWARE FAULT KIND VALUES.  THE PARAMETER VALUES
*         MUST MATCH VALUES DEFINED FOR THE 180 SIDE AND THE EI CODE.

 HFK      BSS    0
          VFD    42/5LRETRY,18/0
          VFD    42/7LEXCHANG,18/1
          VFD    42/4LTRAP,18/2
          VFD    42/4LHALT,18/3
          VFD    42/7LPDMHALT,18/4
          VFD    42/7LSOFTERR,18/5
 HFKL     EQU    *-HFK       LENGTH OF TABLE

*         ALLOWABLE MODE VALUES.

 MODE     BSS    0
          VFD    42/3LJOB,18/0
          VFD    42/7LMONITOR,18/1
 MODEL    EQU    *-MODE      LENGTH OF TABLE

*         ALLOWABLE TRAP ENABLED VALUES.

 TE       BSS    0
          VFD    42/5LFALSE,18/0
          VFD    42/4LTRUE,18/1
 TEL      EQU    *-TE        LENGTH OF TABLE
          SPACE  4,10
**        VIP - VERIFY INPUT PARAMETER.
*                CHECKS SPECIFIED PARAMETER TABLE FOR A MATCH
*                AND RETURNS A PARAMETER VALUE.
*
*         ENTRY:
*                (B1) = 1.
*                (B2) = ADDRESS OF PARAMETER TABLE.
*                (B3) = LENGTH OF PARAMETER TABLE.
*                (X1) = PARAMETER CHECKING FOR, LEFT JUSTIFIED WITH
*                       ZERO FILL.  LOW ORDER 18 BITS ARE NOT CHECKED.
*
*         EXIT:
*                (X6) = PARAMETER VALUE.  NEGATIVE VALUE IF NOT FOUND.
*
*         CALLS: NONE.
*
*         USES: A2,   B3,   X0, X2, X5, X6.
*
          SPACE  2
 VIP      DATA   0           ENTRY/EXIT
          SA2    B2          INITIAL ENTRY IN PARAMETER TABLE
          MX0    60-18
 VIP5     BSS    0
          BX5    X1-X2
          BX6    -X0*X2      PARAMETER VALUE
          SA2    A2+B1       NEXT ENTRY IN PARAMETER TABLE
          BX5    X0*X5
          SB3    B3-B1       DECREMENT TABLE LENGTH
          ZR     X5,VIP      IF MATCHING PARAMETER
          GT     B3,B0,VIP5  IF MORE ENTRIES IN PARAMETER TABLE
          SX6    -B1         SET NO MATCHING PARAMETER FOUND
          JP     VIP         RETURN
          SPACE  4,10
**        CDB - CONVERT DISPLAY CODE TO BINARY.
*                CONVERTS AN OCTAL DISPLAY CODE NUMBER TO ITS
*                BINARY VALUE.
*
*         ENTRY:
*                (B1) = 1.
*                (X1) = OCTAL NUMBER TO CONVERT, LEFT JUSTIFIED WITH
*                       ZERO FILL.  LOW ORDER 18 BITS ARE NOT CHECKED.
*
*         EXIT:
*                (X6) = BINARY VALUE.  ZERO IF NOT OCTAL DISPLAY
*                       CODE VALUE.
*
*         CALLS: NONE.
*
*         USES: B2,   X0, X1, X3, X4, X6.
*
          SPACE  2
 CDB10    BSS    0
          SX6    B0          RETURN WITH ERROR

 CDB      DATA   0           ENTRY/EXIT
          MX0    60-6
          LX1    6
          SX6    B0          INITIALIZE RESULT BINARY VALUE
          SB2    7
 CDB5     BSS    0
          BX2    -X0*X1      DISPLAY CODE CHARACTER
          SB2    B2-B1       DECREMENT CHARACTER COUNT
          ZR     X2,CDB      IF ALL CHARACTERS CONVERTED, RETURN
          SX3    X2-1R0      SUBTRACT DISPLAY CODE BIAS
          SX4    X2-1R8
          LX6    3
          NG     X3,CDB10    IF NOT AN OCTAL NUMBER
          PL     X4,CDB10    IF NOT AN OCTAL NUMBER
          LX1    6           POSITION NEXT CHARACTER
          BX6    X6+X3       ADD NEXT BINARY DIGIT TO BINARY NUMBER
          GE     B2,B0,CDB5  IF MORE CHARACTERS TO CONVERT
          JP     CDB         RETURN

          END    IHFU
*DECK DECK=DSM$INSTALL_DEADSTART_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Install Deadstart File' ??
MODULE dsm$install_deadstart_file;

{ PURPOSE;
{   This module contains the procedures that deal with installing
{   and committing the disk based deadstart file.

?? PUSH (LISTEXT := ON) ??
*copyc dse$error_codes
*copyc fst$ansi_hdr1_label
*copyc fst$ansi_hdr2_label
*copyc fst$ansi_vol1_label
?? POP ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_string_to_file_ref
*copyc clp$evaluate_parameters
*copyc clp$get_task_status
*copyc dsp$append_file_to_ds_file
*copyc dsp$check_system_available
*copyc dsp$complete_deadstart_file
*copyc dsp$get_integer_from_rdf
*copyc dsp$prep_ds_file_installation
*copyc dsp$store_integer_in_rdf
*copyc fsp$close_file
*copyc fsp$open_file
*copyc jmp$system_job
*copyc osp$set_status_abnormal
*copyc osp$verify_system_privilege
*copyc syp$display_deadstart_message
*copyc syp$process_deadstart_status
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    installation_interlocked: boolean := FALSE;

?? TITLE := 'dsp$commit_new_system', EJECT ??

{  PURPOSE:
{    This procedure sets a flag in the rdf_production area of the image
{    file to indicate that the disk based deadstart file PRIMARY mau
{    field should be updated to the value in the SECONDARY mau field
{    when appropriate.  The appropriate time is when a terminate_system
{    command has been entered after commit_new_system has been set to true.

  PROCEDURE [XDCL, #GATE] dsp$commit_new_system
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE commit_new_system, comns (
{ set_flag, sf: boolean = TRUE
{ status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 4, 7, 12, 54, 28, 237],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'COMNS'], [
    ['SET_FLAG                       ',clc$nominal_entry, 1],
    ['SF                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$set_flag = 1,
    p$status = 2;

  VAR
    pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      commit_new_dsfile: integer,
      task_name: ost$name,
      task_status: pmt$task_status;

    osp$verify_system_privilege;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    task_name := 'INSTALL_DS_CATALOG_TO_DISK';
    clp$get_task_status (task_name, task_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT task_status.complete THEN
      syp$display_deadstart_message ('The COMMIT_NEW_SYSTEM command cannot be used until');
      syp$display_deadstart_message ('the ESTABLISH_DISK_BASED_SYSTEM command is finished.');
      syp$display_deadstart_message ('Please wait for the completion message.');
      osp$set_status_abnormal (dsc$display_processor_id, dse$estdbs_not_finished, '', status);
      RETURN;
    IFEND;

    dsp$check_system_available (status);
    IF NOT status.normal THEN
      IF pvt [p$set_flag].value^.boolean_value.value THEN
        syp$display_deadstart_message
              ('The following error occurred while attempting to commit the new system:');
        syp$process_deadstart_status ('Unable to commit new system', FALSE, status);
      ELSE
        syp$display_deadstart_message
              ('The following error occurred while attempting to decommit the new system:');
        syp$process_deadstart_status ('Unable to decommit new system', FALSE, status);
      IFEND;
      RETURN;
    IFEND;

    dsp$get_integer_from_rdf (dsc$rdf_commit_new_dsfile_flag, dsc$rdf_production, commit_new_dsfile);

    IF pvt [p$set_flag].value^.boolean_value.value THEN
      IF commit_new_dsfile = $INTEGER(FALSE) THEN
        dsp$store_integer_in_rdf (dsc$rdf_commit_new_dsfile_flag, dsc$rdf_production,
              $INTEGER (pvt [p$set_flag].value^.boolean_value.value));
        syp$display_deadstart_message ('New system will be committed at successful');
        syp$display_deadstart_message ('   completion of a terminate_system.');
      ELSE
        syp$display_deadstart_message ('New system has already been committed.');
      IFEND;
    ELSE
      IF commit_new_dsfile = $INTEGER(TRUE) THEN
        dsp$store_integer_in_rdf (dsc$rdf_commit_new_dsfile_flag, dsc$rdf_production,
              $INTEGER (pvt [p$set_flag].value^.boolean_value.value));
        syp$display_deadstart_message ('New system has been decommitted.');
      ELSE
        syp$display_deadstart_message ('New system has already been decommitted.');
      IFEND;
    IFEND;

  PROCEND dsp$commit_new_system;
?? TITLE := 'dsp$install_deadstart_file', EJECT ??

{  PURPOSE:
{    This procedure installs the disk based deadstart file.  It is called from the
{    establish_disk_based_system procedure.

  PROCEDURE [XDCL, #GATE] dsp$install_deadstart_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE install_deadstart_file, insdf (
{ deadstart_files, df: list of file = $required
{ status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 4, 19, 15, 8, 26, 633],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'INSDF'], [
    ['DEADSTART_FILES                ',clc$nominal_entry, 1],
    ['DF                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$deadstart_files = 1,
    p$status = 2;

  VAR
    pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      attachment_options_p: ^fst$attachment_options,
      close_status: ost$status,
      deadstart_file: ost$name,
      file_attribute: ARRAY [1 .. 3] OF amt$get_item,
      file_identifier: amt$file_identifier,
      file_segment_p: amt$segment_pointer,
      header_1_label: fst$ansi_hdr1_label,
      header_2_label: fst$ansi_hdr2_label,
      ignore: boolean,
      interlock_set: boolean,
      list_p: ^clt$data_value,
      label_seq_p: ^SEQ ( * ),
      mau_file: ost$name,
      parsed_file_reference: fst$parsed_file_reference,
      temporary_string: string (8),
      volume_1_label: fst$ansi_vol1_label;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT jmp$system_job () THEN
      RETURN;
    IFEND;

    {  Set the global interlock variable to ensure that the install deadstart file process is a
    {  serial process.

    interlock_set := FALSE;
    REPEAT
      IF NOT installation_interlocked THEN
        installation_interlocked := TRUE;
        interlock_set := TRUE;
      IFEND;
    UNTIL interlock_set;

  /global_interlock_set/
    BEGIN

      dsp$prep_ds_file_installation (deadstart_file, mau_file, status);
      IF NOT status.normal THEN
        EXIT /global_interlock_set/;
      IFEND;

      {  Initialize the header records.

      volume_1_label.label_identifier := 'VOL';
      volume_1_label.label_number := '1';
      header_1_label.label_identifier := 'HDR';
      header_1_label.label_number := '1';
      header_2_label.label_identifier := 'HDR';
      header_2_label.label_number := '2';

      {  Append the VOL1 header record to the system device deadstart file.

      label_seq_p := #SEQ (volume_1_label);
      dsp$append_file_to_ds_file (#SIZE(volume_1_label), deadstart_file, label_seq_p, status);
      IF NOT status.normal THEN
        EXIT /global_interlock_set/;
      IFEND;

      PUSH attachment_options_p: [1..1];
      attachment_options_p^ [1].selector := fsc$create_file;
      attachment_options_p^ [1].create_file := FALSE;
      file_attribute [1].key := amc$file_length;
      file_attribute [2].key := amc$block_type;
      file_attribute [3].key := amc$record_type;

      {  For each file in the deadstart files list, set up the HDR1 and HDR2 headers, append the
      {  headers to the system device deadstart file, then append the file to the system device
      {  deadstart file.

      list_p := pvt [p$deadstart_files].value;
      WHILE list_p <> NIL DO

        {  Store the required information in the HDR1 and HDR2 headers.

        clp$convert_string_to_file_ref (list_p^.element_value^.file_value^, parsed_file_reference, status);
        IF NOT status.normal THEN
          EXIT /global_interlock_set/;
        IFEND;
        header_1_label.file_identifier := parsed_file_reference.path (parsed_file_reference.last_name.index,
              parsed_file_reference.last_name.size);

        amp$get_file_attributes (list_p^.element_value^.file_value^, file_attribute, ignore, ignore,
              ignore, status);
        IF NOT status.normal THEN
          EXIT /global_interlock_set/;
        IFEND;

        clp$convert_integer_to_rjstring (file_attribute [1].file_length, 16, FALSE, '0', temporary_string,
              status);
        IF NOT status.normal THEN
          EXIT /global_interlock_set/;
        IFEND;
        header_2_label.block_length := temporary_string (1,5);
        header_2_label.ve_block_length_ext := temporary_string (6,3);
        IF file_attribute [2].block_type = amc$system_specified THEN
          header_2_label.ve_block_type := 'SS';
        ELSE
          header_2_label.ve_block_type := 'US';
        IFEND;
        IF file_attribute [3].record_type = amc$variable THEN
          header_2_label.ve_record_type := 'V';
        ELSE
          header_2_label.ve_record_type := 'U';
        IFEND;

        {  Append the HDR1 and HDR2 headers to the system device deadstart file.

        label_seq_p := #SEQ (header_1_label);
        dsp$append_file_to_ds_file (#SIZE(header_1_label), deadstart_file, label_seq_p, status);
        IF NOT status.normal THEN
          EXIT /global_interlock_set/;
        IFEND;
        label_seq_p := #SEQ (header_2_label);
        dsp$append_file_to_ds_file (#SIZE(header_2_label), deadstart_file, label_seq_p, status);
        IF NOT status.normal THEN
          EXIT /global_interlock_set/;
        IFEND;

        {  Append the file to the system device deadstart file.

        fsp$open_file (list_p^.element_value^.file_value^, amc$segment, attachment_options_p, NIL, NIL,
              NIL, NIL, file_identifier, status);
        IF NOT status.normal THEN
          EXIT /global_interlock_set/;
        IFEND;

      /file_open/
        BEGIN
          amp$get_segment_pointer (file_identifier, amc$sequence_pointer, file_segment_p, status);
          IF NOT status.normal THEN
            EXIT /file_open/;
          IFEND;
          dsp$append_file_to_ds_file (file_attribute [1].file_length, deadstart_file,
                file_segment_p.sequence_pointer, status);
          IF NOT status.normal THEN
            EXIT /file_open/;
          IFEND;
        END /file_open/;

        fsp$close_file (file_identifier, close_status);
        IF NOT status.normal THEN
          EXIT /global_interlock_set/;
        IFEND;
        IF NOT close_status.normal THEN
          status := close_status;
          EXIT /global_interlock_set/;
        IFEND;

        list_p := list_p^.link;
      WHILEND;

      {  Complete the install deadstart file process.

      dsp$complete_deadstart_file (deadstart_file, mau_file, status);

    END /global_interlock_set/;

    {  Clear the global interlock variable.

    installation_interlocked := FALSE;

  PROCEND dsp$install_deadstart_file;
MODEND dsm$install_deadstart_file;
*DECK DECK=DSM$INSTALL_DS_CATALOG_TO_DISK EXPAND=TRUE
PROCEDURE install_ds_catalog_to_disk (
  deadstart_catalog, dc: file = $required
  status)

*copyc dst$deadstart_record_lists

  VAR
    catalog_files_list: list 0 .. $max_list OF name
    catalog_path: string
    command_status: status
    current_file : name
    file_name: string
    files_list: list 0 .. $max_list OF file
    files_name_list: list 0 .. $max_list OF name
    index: integer
    local_status: status
    main_path: string
    previous_catalog_path: string
  VAREND

  main_path = $string(deadstart_catalog)
  files_list = ()
  files_name_list = ()

  "  Use the standard required files list to determine if all of the required files exist in the
  "  deadstart catalog.

  create_files_list: FOR index = 1 TO deadstart_file_count DO
    IF deadstart_file_list(index).site_catalog = 'CIP' THEN
      CYCLE create_files_list
    IFEND

    "  Ensure that the required file exists.  If so, add it to the deadstart files list.

    IF deadstart_file_list(index).site_catalog = ' ' THEN
      catalog_path = main_path
    ELSE
      catalog_path = main_path//'.'//deadstart_file_list(index).site_catalog
    IFEND

    file_name = catalog_path//'.'//deadstart_file_list(index).tape_name
    IF (NOT $file($fname(file_name), permanent)) AND deadstart_file_list(index).site_required THEN
      local_status = $status(FALSE, 'DS', dse$required_file_missing, file_name)
      EXIT PROCEDURE WITH local_status
    IFEND

    IF deadstart_file_list(index).tape_name <> 'PRODUCT_EPILOG' THEN

      "  Add the file to the files list and the files name list.

      IF $file($fname(file_name), permanent) THEN
        files_list = $add($fname(file_name), files_list)
        files_name_list = $add($name(deadstart_file_list(index).tape_name), files_name_list)
      IFEND
      previous_catalog_path = catalog_path

    ELSE

      "  Before adding the product epilog file, process any other files that may exist in the product files
      "  catalog.  Determine if there are any by getting the catalog contents and subtracting the file names
      "  that have already been processed.

      catalog_files_list = $catalog_contents($fname(previous_catalog_path), include_files)
      catalog_files_list = $difference(catalog_files_list, files_name_list)
      WHILE NOT $nil(catalog_files_list) DO
        current_file = $first(catalog_files_list)
        catalog_files_list = $rest(catalog_files_list)

        "  Ensure that the file name is less than 18 characters in length and add it to the files list.

        IF $file($fname(previous_catalog_path//'.'//$string(current_file)), opened) THEN
          IF $strlen($string(current_file)) < 18 THEN
            files_list = $add($fname(previous_catalog_path//'.'//$string(current_file)), files_list)
          ELSE
            local_status = $status(FALSE, 'DS', dse$file_name_too_long, previous_catalog_path//'.'//$string(current_file))
            EXIT PROCEDURE WITH local_status
          IFEND
        IFEND
      WHILEND

      "  Add the product epilog file to the files list.

      files_list = $add($fname(file_name), files_list)
    IFEND
  FOREND create_files_list

  "  Since elements are added to lists at the beginning, the deadstart files list must be be reversed to make
  "  it in the correct order.

  files_list = $reverse(files_list)

  include_command c='install_deadstart_file df=files_list status=local_status' status=command_status

  IF local_status.normal THEN
    put_line l=' Disk based system complete. ' o=$response
  ELSE
    put_line l=' Failure attempting to establish disk based system. ' o=$response
  IFEND

  EXIT PROCEDURE WITH local_status WHEN NOT local_status.normal

PROCEND install_ds_catalog_to_disk
*DECK DECK=DSM$LABELLED_TAPE_INTERFACE EXPAND=TRUE
          IDENT  DSMLTI
          TITLE  DSMLTI - COMMON IO ROUTINES FOR BINARY LABELLED TAPE.
         COMMENT COMMON IO ROUTINES FOR BINARY LABELLED TAPE SUPPORT.
          SYSCOM
          ENTRY  PXIOOLT
          ENTRY  PX#TRTS
          ENTRY  BI#OLT
          ENTRY  BI#PUTT
          ENTRY  BI#WEFT
          EXT    DSV#DEN
          EXT    DSV#VSN
          SPACE  2
*** THIS MODULE CONTAINS VARIOUS 170 ASSEMBLY LANGUAGE ROUTINES TO PROVIDE
* THE INTERFACES FOR WRITING S LABELLED TAPES FROM CYBIL.  THESE ROUTINES
* WERE TAKEN FROM THE STANDARD CYBIL IO ROUTINES AND MODIFIED TO WRITE S
* TAPES.  THE ONLY SUPPORT PROVIDED IS TO OPEN THE TAPE, REWIND IT AND
* WRITE ON IT.  THE CYBIL_CC INTERFACES THAT SHOULD BE USED FOR WRITING S
* TAPES ARE THE FOLLOWING:
*         BI#OLT             * OPEN LABELLED S TAPE.
*         BI#PUT_TAPE        * WRITE DATA TO TAPE.
*         BI#WEOF_TAPE       * FLUSHES THE BUFFER AND WRITES EOF.
*         BI#CLOSE
*
          SPACE  2
*COPYC ZIOCOMM
C.WRITEN  EQU    264B        * WRITE NONSTOP ON S TAPE.
          SPACE  4
*** PXIOOLT - COMMON OPEN LABELLED TAPE BINARY FILE ROUTINE
*          PXIOOLT DOES THE FOLLOWING FOR BINARY FILE TYPES -
*   1)  CHECK LOGICAL FILE NAME
*   2)  CHECK IF OPEN FUNCTION LEGAL
*   3)  BUILD STANDARD 16-WORD FET
*   4)  REQUEST CIO BUFFER SPACE
*   5)  ISSUE *LFM* LABELLED TAPE REQUEST.
*   6)  ISSUE CIO OPEN FILE CALL
*
*   ANY ERROR CONDITION CAUSES JOB TO BE ABORTED.
*
*   ENTRY CONDITIONS
*     B1   1
*     B2   POINTER TO CURRENT STACK FRAME
*     B3   STACK LIMIT
*     X1   ADDRESS OF ADDRESS OF FILE DESCRIPTOR
*     X2   FILE STATUS (0 = NEW, 1 = OLD)
*     X3   FILE MODE (0 = IN, 1 = OUT, 2 = IN AND OUT)
*     X4   FILE POSITION (0 = FIRST, 1 = ASIS, 2 = LAST, 3 = NULL)
*     B5   POINTER TO LOCAL FILE NAME STRING POINTER
*     B4   ADDRESS OF CONTROL WORD AND OPEN CODE TABLE
*     DSV#DEN - VARIABLE CONTAINING TAPE DENSITY.
*     DSV#VSN - VARIABLE CONTAINING TAPE VSN.
*
*   EXIT CONDITIONS     (IF FILE NAME IS NOT NULL$)
*     B1   AS ON ENTRY
*     B2   AS ON ENTRY
*     B3   AS ON ENTRY
*     X1   ADDRESS OF FILE DESCRIPTOR
*     PX#TRTS - TAPE REQUEST STATUS, = 0 IMPLIES NORMAL AND
*          NOT EQUAL 0 IMPLIES ABNORMAL.
*
*   EXIT CONDITIONS     (IF FILE NAME IS NULL$)
*     B1   AS ON ENTRY
*     B2   POINTER TO CALLER'S STACK FRAME
*     B3   STACK LIMIT
*     X1   PROCEDURE LINKAGE WORD
*     PX#TRTS - TAPE REQUEST STATUS, = 0 IMPLIES NORMAL AND
*          NOT EQUAL 0 IMPLIES ABNORMAL.
*
*   NOTE
*          RETURN IS DIRECTLY TO THE CALLER OF THE
*          'FILE TYPE SPECIFIC' OPEN ROUTINE WITH THE
*          FILE POINTER VARIABLE SET TO NIL.
*          THIS ROUTINE WAS TAKEN FROM THE CYBIL IO ROUTINES AND
*          MADE TO WORK FOR WRITING *S* FORMAT LABELLED TAPES IN
*          BINARY MODE ONLY.
*
          SPACE  4
NULL$     VFD    18/0,42/5LNULL$
          SPACE  4
PXIOOLT   EQ     *+1S17      * ENTRY/EXIT

* EQUATE FILE POSITION = 3 TO 1

          SX4    X4-3        * DECREMENT FP BY THREE
          NZ     X4,FPORDOK  * IF NOT ZERO JUST RESTORE
          SX4    -2          * OTHERWISE CHANGE TO NEG TWO
FPORDOK   BSS    0
          SX4    X4+3        * RESTORE TO ORG VALUE, MOSTLY

          SA5    B4+X3       * GET FILE CONTROL WORD
          BX6    X5          *   AND STORE IT IN
          SA6    B2+B1       *   WORD 1 OF STACK FRAME
          BX5    X2          * COMPUTE INDEX OF OPEN CODE WORD
          LX2    3           *   = (STATUS*9)+(MODE*3)+POSITION
          IX6    X2+X5       *
          LX5    X3,B1       *
          IX5    X3+X5       *
          IX6    X6+X5       *
          IX6    X6+X4       *
          SX6    X6+B4       * GET OPEN CODE WORD
          SA5    X6+3        *
          SX6    X1          * SAVE ADDR OF ADDR OF FILE DESCRIPTOR
          BX7    X5          * SAVE OPEN CODE WORD
          SA6    A6+B1       *   WORD 2 OF STACK FRAME
          SA7    A6+B1       *   WORD 3 OF STACK FRAME

* CONVERT LOGICAL FILE NAME STRING TO DISPLAY CODE
          SX1    A7+B1       * RETURN NAME IN WORD 4 OF STACK FRAME
          CALL   =XZUTPSFN   *
          SA4    B2+4        * GET DISPLAY CODE FILE NAME
          SX2    B1
          NZ,X4  NOERR1
          CALL   =XPXIOERR   * BAD (EMPTY) FILE NAME   ERROR
NOERR1    BSS    0
          SA5    NULL$       * CHECK FOR SPECIAL FILE NAME
          BX5    X4-X5       *
          ZR,X5  NULLFILE    * BRANCH IF FILE NAME IS NULL$
          SX1    B2+4-FD.LFN * FAKE FILE ADDRESS
          LX4    18          * ALIGN LOGICAL FILE NAME
          SX3    3           * SET BINARY MODE, COMPLETION BITS
          BX6    X4+X3
          SA6    A4          * SAVE LOGICAL FILE NAME/FUNCTION WORD
          SA5    A4-B1       * RESTORE OPEN CODE WORD
          SX2    B1+B1       * CHECK FOR ILLEGAL (-1) OPEN FUNCTION
          SX7    X5          *
          ZR,X7  NOERR2
          PL,X7  NOERR2
          CALL   =XPXIOERR   *   ERROR EXIT FOR ILLEGAL OPEN REQUEST
NOERR2    BSS    0

* ALLOCATE FILE DESCRIPTOR
          SX2    FD.END+1    * SET DESCRIPTOR LENGTH
          MX3    0           * NO MEMORY GROUP
          RJ     =XCIL#ALF   * ALLOCATE MEMORY
          SX7    X1          * FWA OF DESCRIPTOR ALLOCATED
          MX2    0           * ERR CODE - NOT ENOUGH MEMORY FOR DESC.
          SX1    B2+4-FD.LFN * FAKE FILE ADDRESS
          SX4    X7-NIL
          NZ,X4  NOERR3
          CALL   =XPXIOERR   * DESCRIPTOR COULD NOT BE ALLOCATED
NOERR3    BSS    0
          SA3    B2+B1       * RESTORE FILE CONTROL WORD
          SA1    A3+B1       * RESTORE ADDR OF ADDR OF FILE DESCRIPTOR
          SA7    X1          * STORE ADDRESS OF FILE DESCRIPTOR
          SX1    X7
          SA4    B2+4        * GET LOGICAL FILE NAME/FUNCTION WORD
          BX7    X3
          BX6    X4
          SA7    X1          * STORE CONTROL WORD IN 1ST WORD OF DESC.
          SA6    X1+B1       * STORE IN FET+0

          SA0    A6          * SAVE POINTER TO FET

* ALLOCATE BUFFER AND STORE BUFFER DESCRIPTION INTO FET
          SA2    PX#IOBS     * GET CIO BUFFER SIZE
          MX3    0           * NO MEMORY GROUP
          RJ     =XCIL#ALF   * ALLOCATE MEMORY
          SX7    X1          * FWA OF BUFFER SPACE ALLOCATED
          MX2    0           * ERR CODE - NOT ENOUGH MEMORY FOR BUFFER
          SX1    A0-B1       * RESTORE FILE ADDRESS
          SX4    X7-NIL
          NZ,X4  NOERR4
          CALL   =XPXIOERR   * BUFFER COULD NOT BE ALLOCATED
NOERR4    BSS    0
          SX6    10B
          LX6    18          * MAKE IT 16B WORD FET
*IF ($string($name(wev$target_operating_system))='NOS')
          MX2    1
          BX7    X7+X6
          LX2    44+1        * SET ERROR PROCESSING BIT FOR *LFM*
          BX7    X7+X2
*ELSE
          BX7    X7+X6
*IFEND
          SA7    A0+B1       * STORE FIRST POINTER

          SX7    X7
          SA7    A7+B1       * STORE IN POINTER
          SA7    A7+B1       * STORE OUT POINTER
          SA2    PX#IOBS     * CALCULATE LIMIT
          IX7    X7+X2
          SA7    A7+B1       * STORE LIMIT

* CLEAR REMAINDER OF FILE DESCRIPTOR
          MX7    0           * SET ZERO
          DUP    FD.END-FD.LAST,1
          SA7    A7+B1       * STORE INTO NEXT DESCRIPTOR WORD
*IF ($string($name(wev$target_operating_system))='NOS')

* SET UP *FET* TO REQUEST LABELLED TAPE USING *LFM* FUNCTION.

          SA4    DSV#DEN     * DUMP TAPE DENSITY
          SA2    FET10       * SET WORD 10B OF FET
          LX4    51
          BX7    X2+X4       * MERGE DUMP TAPE DENSITY
          SA7    A0+10B
          SA2    DSV#VSN      * SET *VSN* IN FET
          MX7    36
          BX7    X7*X2       * *VSN* ONLY
          SX2    A0          * FET ADDRESS
          SA7    A7+B1
          SX7    24B         * LABEL FUNCTION CODE FOR *LFM*
          RJ     =XLFM=      * ISSUE *LFM* REQUEST FOR LABELLED TAPE
          SA2    A0          * CHECK TERMINATION STATUS
          MX7    60-8
          AX2    9+1         * RIGHT JUSTIFY TERMINATION STATUS
          BX7    -X7*X2      * TERMINATION STATUS
          SA2    A0+B1       * WORD 1 OF *FET*
          MX6    1
          SA7    PX#TRTS
          LX6    44+1
          NZ     X7,PXIOOLT  * IF ABNORMAL TERMINATION STATUS
          BX7    -X6*X2      * CLEAR ERROR PROCESSING BIT
          SX6    TPPRUSZ     * SET MAXIMUM LOGICAL RECORD SIZE
          SA7    A2          * UPDATE FET
          SA6    A0+6
*ELSE

* SET UP TAPE REQUEST USING THE REQUEST MACRO

          SA2    A0          * GET FILE NAME FROM *FET*
          MX0    42          * 7 CHAR NAME MASK
          BX7    X2*X0       * MASK OUT 7 CHAR FILE NAME
          SA7    REQBLK      * SAVE FILE NAME IN REQUEST BLOCK
          SA2    DSV#VSN     * GET VSN
          MX0    36
          BX7    X2*X0       * STRIP OUT 6 CHAR VSN

* RIGHT JUSTIFY VSN BY REMOVING TRAILING BLANKS AND INSERT DISPLAY CODE ZEROS
* ON THE LEFT.

          MX0    60-6
          SX2    1R
          LX0    24
          MX6    6           * INITIALIZE MASK TO CLEAR LEFT MOST CHARACTERS
          SB4    B0          * INITIALIZE TRAILING BLANK COUNT
          LX2    24
AVSN      BSS    0
          BX4    -X0*X7      * RIGHT MOST CHARACTER
          BX4    X4-X2
          NZ     X4,AVSN5    * IF NOT A BLANK
          BX7    X0*X7       * REMOVE TRAILING BLANK
          SB4    B4+B1       * INCREMENT TRAILING BLANK COUNT
          AX7    6
          GT     B4,B1,AVSN  * IF FIRST TRAILING BLANK
          AX6    6           * EXTEND MASK TO CLEAR LEFT MOST CHARACTER
          JP     AVSN        * CHECK NEXT CHARACTER

AVSN5     BSS    0
          EQ     B4,B0,AVSN15  * IF NO TRAILING BLANKS

* ADD DISPLAY CODE ZEROS ON LEFT SIDE OF VSN.

          SX4    1R0
          BX7    -X6*X7      * VSN
          LX4    54
AVSN10    BSS    0
          SB4    B4-B1       * DECREMENT TRAILING BLANK COUNT
          BX7    X4+X7       * ADD DISPLAY CODE ZERO
          LX4    54
          GT     B4,B0,AVSN10  * IF NOT DISPLAY CODE ZERO FILLED
AVSN15    BSS    0
          SA7    REQBLK+2    * SAVE VSN IN REQUEST BLOCK
          SA4    DSV#DEN     * TAPE DENSITY
          SA2    A7-B1       * REQUEST BLOCK + 1
          BX7    X4+X2       * SET TAPE DENSITY IN REQUEST BLOCK
          SA7    A2
          REQUEST  REQBLK    * MAKE TAPE REQUEST
          SA2    REQBLK      * GET WORD WITH ERROR CODE
          MX7    60-9        * ERROR CODE MASK
          AX2    9           * POSITION ERROR CODE
          BX7    -X7*X2      * STRIP OUT ERROR CODE
          SA7    PX#TRTS     * SAVE ERROR CODE
          NZ     X7,PXIOOLT  * EXIT IF ERROR OCCURRED
          SB4    4           * NUM OF REQ BLK WORDS TO COPY TO THE *FET*
          SB6    A0+11B      * STARTING *FET* POSITION TO COPY TAPE INFO
CLI       BSS    0
          SA2    REQBLK+4    * GET REQUEST BLOCK WORD TO COPY
          BX7    X2
          SA7    B6+B4       * SAVE WORD INTO FET
          SB4    B4-B1       * DECREMENT LOOP COUNTER
          NE     B4,CLI      * MORE TO COPY
          SX6    TPPRUSZ     * SET MAXIMUM LOGICAL RECORD SIZE
          SA6    A0+6        * STORE INTO *FET*
*IFEND

* CALL CIO TO OPEN FILE AND POSITION FILE AT BEGINNING.

          SX7    X5          * SET FUNCTION CODE
          SX2    A0          * SET FET ADDRESS
          BX7    -X7         * COMPLEMENT FUNCTION CODE FOR RECALL
          RJ     =XCIO=      * OPEN FILE

          SX1    A0-B1       * RESTORE FILE DESCRIPTOR ADDR
          EQ     PXIOOLT     * EXIT

*IF ($string($name(wev$target_operating_system))='NOS')
 FET10    VFD    1/0         * DO NOT WRITE LABEL
          VFD    1/1         * LABELLED TAPE
          VFD    1/0
          VFD    1/1         * NINE TRACK TAPE
          VFD    2/0         * UNUSED
          VFD    3/0         * DENSITY (SET AT RUN TIME)
          VFD    3/0         * CONVERSION MODE

* PROCESSING OPTIONS.

          VFD    3/1         * WRITE TRAILER SEQUENCE
          VFD    1/0         * UNUSED
          VFD    1/0         * USE INSTALLATION DEFAULT
          VFD    1/0         * USE INSTALLATION DEFAULT
          VFD    1/1         * DO NOT UNLOAD TAPE AT END
          VFD    2/2         * WRITE RING REQUIRED
          VFD    1/0         * ALLOW ERROR PROCESSING
          VFD    2/0         * ABORT ON UNRECOVERED WRITE ERROR

* END OF PROCESSING OPTIONS.

          VFD    6/3         * S FORMAT
          VFD    6/0         * DEFAULT NOISE SIZE
          VFD    24/TPPRUSZ  * MAXIMUM BLOCK SIZE
*ELSE
REQBLK    VFD    60/0        * NAME/STATUS WORD
          VFD    6/0         * NOT USED
          VFD    1/0         * NORING (SET TO FALSE)
          VFD    1/1         * RING (SET TO TRUE)
          VFD    2/0         * NOT USED
          VFD    1/0         * EXTENDED LABEL (SET TO FALSE)
          VFD    1/1         * WORDS 5-9 CONTAIN LABEL
          VFD    12/0        * NOT USED
          VFD    9/0         * NOT USED
          VFD    1/0         * 2 MAG TAPE REQUEST (SET TO FALSE)
          VFD    1/1         * VSN IN WORD 3
          VFD    1/0         * USE EXISTING LABEL (SET TO FALSE)
          VFD    12/0        * NOT USED
          VFD    6/41B       * NINE TRACK TAPE
          VFD    2/2         * S DATA FORMAT
          VFD    2/1         * SI STANDARD U LABEL
          VFD    2/0         * DENSITY (SET AT RUN TIME)

* THE VSN IS RIGHT JUSTIFIED WITH DISPLAY CODE ZERO FILL.

          VFD    36/0        * VSN (RIGHT JUSTIFIED WITH DISPLAY CODE ZERO FILL)
          VFD    24/0
          VFD    60/0        * NOT USED
          VFD    60/0        * MAG TAPE FILE HEADER LABEL WORD 1
          VFD    60/0        * MAG TAPE FILE HEADER LABEL WORD 2
          VFD    60/0        * MAG TAPE FILE HEADER LABEL WORD 3
          VFD    60/0        * MAG TAPE FILE HEADER LABEL WORD 4
          VFD    60/0        * MAG TAPE FILE HEADER LABEL WORD 5
CMUR      CON    0           * SET NO COMPARE MOVE UNIT FOR *WTW=*
*IFEND
          SPACE  4
* SINCE THE FILE NAME IS NULL$, SET THE FILE DESCRIPTOR POINTER
* VARIABLE TO NIL AND RETURN TO THE CALLER OF THE 'FILE TYPE
* SPECIFIC' OPEN ROUTINE.

NULLFILE  BSS    0
          SA1    B2+2        * RESTORE ADDR OF ADDR OF FILE DESCRIPTOR
          SX6    NIL
          SA6    X1
          DONE
          EJECT
*** PX#IOBS - INTEGER CONTAINING CIO BUFFER SIZE
*          PX#IOBS INITIALLY CONTAINS THE SIZE (IN WORDS)
*   FOR CIO BUFFERS REQUESTED FOR TAPE FILES WHEN THEY ARE OPENED.
*

TPPRUSZ   EQU    1000B       * PRU SIZE FOR TAPE.
PX#IOBS   CON    TPPRUSZ*5+5+1 * BUFFER SIZE.

*** PX#TRTS - INTEGER CONTAINING *LFM* TAPE REQUEST STATUS.  THIS
*   VARIABLE CAN BE CHECKED BY THE CALLER TO DETERMINE IF THE TAPE
*   REQUEST TERMINATED NORMALLY.  A VALUE OF ZERO IMPLIES NORMAL
*   TERMINATION.
*

PX#TRTS   CON    0

          SPACE  4
*** BI#OLT - OPEN LABELLED TAPE BINARY FILE.  THIS PROCEDURE CLAIMS
*          TO SUPPORT VARIOUS FILE STATUSES, MODES AND POSITIONS BUT
*          NONE OF THESE HAVE BEEN CHECKED OUT.  THIS PROCEDURE HAS
*          BEEN CHECKED OUT WITH *NEW*, *OUTPUT* AND *FIRST*.
*
*   ENTRY CONDITIONS
*     B1   1
*     B2   POINTER TO CALLER'S STACK FRAME / TOS
*     B3   STACK LIMIT
*     X7   PROCEDURE LINKAGE WORD
*     X1   ADDRESS OF ADDRESS OF FILE DESCRIPTOR
*     X2   FILE STATUS (0 = NEW, 1 = OLD), ALWAYS NEW.
*     X3   FILE MODE (0 = IN, 1 = OUT, 2 = IN AND OUT), ALWAYS OUT.
*     X4   FILE POSITION (0 = FIRST, 1 = ASIS, 2 = LAST, 3 = NULL), ALWAYS FIRST.
*     B5   POINTER TO LOCAL FILE NAME STRING POINTER
*
*   EXIT CONDITIONS
*     B1   AS ON ENTRY
*     B2   AS ON ENTRY
*     B3   AS ON ENTRY
*     X1   AS X7 ON ENTRY
*
          SPACE  4
BI#OLT    ENTR

* EQUATE FILE POSITION = 3 TO 1

          SX4    X4-3        * DECREMENT FP BY THREE
          NZ     X4,BIOLT5   * IF NOT ZERO JUST RESTORE
          SX4    -2          * OTHERWISE CHANGE TO NEG TWO
BIOLT5    BSS    0
          SX4    X4+3        * RESTORE TO ORG VALUE, MOSTLY

* SET POINTER TO CONTROL WORD AND OPEN CODE WORD TABLE AND CALL
* LABELLED TAPE OPEN ROUTINE.

          SB4    W.CWORD
          RJ     =XPXIOOLT
          DONE

* TABLE OF CONTROL WORDS
 W.CWORD  BSS    0
          VFD    3/0,2/2,4/2,3/4,2/0,2/2,44/0
          VFD    3/7,2/1,4/2,3/4,2/0,2/1,44/0
          VFD    3/0,2/3,4/2,3/4,2/0,2/3,44/0

* TABLE OF CIO FUNCTION CODES
 W.OCODE  BSS    0
          VFD    60/-1       * ILLEGAL
          VFD    60/-1       * ILLEGAL
          VFD    60/-1       * ILLEGAL
          VFD    60/C.OWTR   * WRITE/REWIND
          VFD    60/C.OWTR   * WRITE/REWIND
          VFD    60/C.OWTR   * WRITE/REWIND
          VFD    60/C.OAR    * ALTER/REWIND
          VFD    60/C.OAR    * ALTER/REWIND
          VFD    60/C.OAR    * ALTER/REWIND
          VFD    60/C.ORDR   * READ/REWIND
          VFD    60/C.ORDNR  * READ/NO REWIND
          VFD    1/1,59/C.ORDNR * READ/NO REWIND/SKIP TO EOI
          VFD    60/C.OWTR   * WRITE/REWIND
          VFD    60/C.OWTNR  * WRITE/NO REWIND
          VFD    1/1,59/C.OWTNR * WRITE/NO REWIND/SKIP TO EOI
          VFD    60/C.OAR    * ALTER/REWIND
          VFD    60/C.OANR   * ALTER/NO REWIND
          VFD    1/1,59/C.OANR * ALTER/NO REWIND/SKIP TO EOI
WRIF$     SET    0           * REISSUE FUNCTION CODE IN FET
OPL       XTEXT  COMCWTW
          SPACE  4
*** BPT - PUT ON BINARY TAPE FILE.  THIS ENTRY POINT IS EXTERNALIZED
*         AS *BI#PUTT*.
*
*   ENTRY CONDITIONS
*     B1   1
*     B2   POINTER TO CALLER'S STACK FRAME / TOS
*     B3   STACK LIMIT
*     X7   PROCEDURE LINKAGE WORD
*     X1   ADDRESS OF FILE DESCRIPTOR
*     X2   ADDRESS OF SOURCE, FIRST WORD IS FOR TAPE BLOCK HEADER.
*          REAL DATA STARTS AT ADDRESS+1.
*     X3   LENGTH OF SOURCE (DOES NOT INCLUDE TAPE BLOCK HEADER WORD).
*
*   EXIT CONDITIONS
*     B1   AS ON ENTRY
*     B2   AS ON ENTRY
*     B3   AS ON ENTRY
*     X1   AS X7 ON ENTRY
*
*   NOTE
*          THE CALLER MUST BE AWARE THAT THE FIRST WORD AT SOURCE
*          ADDRESS IS FOR THE TAPE BLOCK HEADER.  A TAPE BLOCK
*          HEADER IS STORED THERE IN ANY CASE.  REAL DATA TO BE
*          WRITTEN SHOULD BEGIN AT ADDRESS+1.  THE LENGTH OF DATA
*          TO BE WRITTEN DOES NOT INCLUDE THE WORD FOR THE TAPE
*          BLOCK HEADER.
*
          SPACE  4
BPT       ENTR
BI#PUTT   EQU    BPT         * EXTERNALIZED ENTRY POINT NAME
          RJ     =XPXIOCOW   * INSURE FILE IS OPEN FOR WRITE

* CHECK FOR INITIAL WRITE FLAG.
          MX6    -FDC.TLTH   * MASK FOR TRANSFER LENGTH
          BX6    X6*X5       * MASK OUT PREVIOUS TRANSFER LENGTH
          BX6    X6+X3       * MERGE IN NEW TRANSFER LENGTH
          SX4    B1
          LX4    FDC.IW      * MASK INITIAL WRITE FLAG BIT
          BX7    X4*X6       * SELECT INITIAL WRITE FLAG BIT
          BX6    -X4*X5      * CLEAR INITIAL WRITE FLAG
          SA6    A5          * UPDATE CONTROL WORD
          ZR,X7  BPT5        * NOT FIRST WRITE

* PLUG CIO WRITE REQUEST CODE INTO FET
          SA4    A5+B1       * LOAD FET WORD 0
          SX6    774B
          BX6    -X6*X4      * CLEAR CIO FUNCTION CODE
          SX4    C.WRITEN    * SET WRITE NONSTOP FUNCTION CODE
          BX6    X6+X4       * INSERT WRITE FUNCTION CODE
          SA6    A4          * UPDATE FET WORD 0

* TRANSFER DATA FROM SOURCE TO FILE
BPT5      BSS    0
          SB6    X2          * OBTAIN SOURCE ADDRESS
          SB7    X3+B1       * OBTAIN SOURCE LENGTH (INCLUDE BLOCK HEADER)
          SX2    A5+B1       * OBTAIN FET ADDRESS

* CALL SYSTEM PROCESSOR TO TRANSMIT DATA. SINCE IT DESTROYS ALL B REGS
* WE FIRST SAVE THE PASCAL-X STACK REGS INTO X5 AND RESTORE THEM LATER.
* DURING THIS SAVE OPERATION WE RELY ON B2,B3>=0 (IF THAT IS WRONG WE
* ARE IN SERIOUS TROBLE ANYWAY).  SET BLOCK HEADER IN FIRST WORD OF
* BUFFER.

          SX4    B3
          SX5    B2
          LX4    18
          BX5    X5+X4
          LX5    18
BPT10     BSS    0
          SB3    1001B
          SX6    B7-B1       * BLOCK SIZE.
          SX4    B0          * REMAINING TRANSFER COUNT
          LE     B7,B3,BPT15 * IF TRANSFER COUNT .LE. PRU SIZE
          SX6    B3-B1       * BLOCK SIZE
          SX4    B7-B3       * REMAINING TRANSFER COUNT
          SB7    B3          * TRANSFER SIZE
BPT15     BSS    0
          SA6    B6          * SET BLOCK HEADER
          BX5    X5+X4       * SAVE REMAINING TRANSFER COUNT
          RJ     WTW=        * WRITE FROM SOURCE
          SB7    X5+B1       * REMAINING TRANSFER COUNT + 1
          MX6    60-18
          SB6    B6-B1       * ADDRESS FOR BLOCK HEADER
          BX5    X6*X5       * CLEAR REMAINING TRANSFER COUNT
          NE     B7,B1,BPT10 * IF TRANSFER NOT COMPLETE

* RESTORE SAVED CONTENTS OF B2 AND B3.

          AX5    18
          SB2    X5
          AX5    18
          SB3    X5

          DONE
          SPACE  4
*** BI#WEFT - WRITE EOF ON TAPE.  ALL DATA IN BUFFER IS FLUSHED FIRST.
*     WRITE THE END OF FILE MARKER ON THE ARGUMENT FILE.
*
*   ENTRY CONDITIONS
*     B1   1
*     B2   POINTER TO CALLER'S STACK FRAME / TOS
*     B3   STACK LIMIT
*     X7   PROCEDURE LINKAGE WORD
*     X1   ADDRESS OF FILE DESCRIPTOR
*
*   EXIT CONDITIONS
*     B1   AS ON ENTRY
*     B2   AS ON ENTRY
*     B3   AS ON ENTRY
*     X1   AS X7 ON ENTRY
*
          SPACE  4
* FLUSH THE BUFFER.
BI#WEFT   ENTR
          SX7    C.WRITEN    * CIO REQUEST CODE TO FLUSH BUFFER

          RJ     =XPXIOCOW   * INSURE FILE IS OPEN FOR WRITE

* SET INITIAL WRITE FLAG IN CONTROL WORD
          SX6    B1
          LX6    FDC.IW
          SX2    X1+FD.LFN   * GET FET ADDRESS
          BX6    X6+X5       * UPDATE FILE CONTROL WORD
          SA6    A5          * RESTORE CONTROL WORD IN DESCRIPTOR

* CALL CIO TO FLUSH BUFFER.
          RJ     =XCIO=

* WRITE EOF
          SX7    -C.WRITEF   * CIO REQUEST CODE FOR WRITE EOF

* CALL CIO TO WRITE END OF FILE AND RETURN.
          RJ     =XCIO=

          DONE

          END
*DECK DECK=DSM$LOAD_PPU EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Resource Support for PPs' ??
MODULE dsm$load_ppu;

{ PURPOSE:
{   This module contains procedures that are used to support requests for IOU resources.
{ DESIGN:
{   The structures used in this module are protected by two interlocks.  The PP buffer
{   and the IOU resource table, both of which are in the SSR, must be interlocked each
{   time they are used to prevent two users from accessing the areas at the same time.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dse$error_codes
*copyc dst$dft_pp_registers
*copyc dst$driver_name
*copyc dst$iou_resource
*copyc dst$rb_logging_request
*copyc dst$resource_name
*copyc dst$resource_request
*copyc ost$hardware_subranges
*copyc ost$physical_pp_number
*copyc ost$pp_size
?? POP ??
*copyc clp$convert_integer_to_string
*copyc cmp$check_dual_pp_system_disk
*copyc cmp$update_dft_sci_location
*copyc dpp$put_critical_message
*copyc dsp$close_ssr
*copyc dsp$fetch_pp_image
*copyc dsp$get_data_from_ssr
*copyc dsp$get_ssr_data_seq_ptr
*copyc dsp$open_ssr
*copyc dsp$process_pp_function
*copyc dsp$read_cda_program
*copyc dsp$retrieve_iou_information
*copyc dsp$send_170_resource_request
*copyc dsp$store_data_in_ssr
*copyc i#move
*copyc osp$clear_mainframe_sig_lock
*copyc osp$initialize_signature_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$delay
?? EJECT ??
*copyc dsv$cpu_pp_communication_block
*copyc dsv$dftb_data
*copyc dsv$mainframe_type
*copyc osv$mainframe_wired_heap
*copyc osv$170_os_type
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??
  TYPE
    t$pp_size_array = ARRAY [dst$iou_model_types] OF ARRAY [dst$channel_protocol_type] OF ost$pp_byte_size,

    { This table is used to keep track of the IOU resource availability.  If the first bit of table entry is
    { set then the channel or pp is owned by NOS/VE.  The channel number plus the NOS/VE owned resource bit
    { is placed in the channel or pp slot in the appropriate spot in the arrays.  This table is in the SSR
    { (VEPP).

    t$iou_resource_table_entry = 0 .. 0ff(16),

    t$iou_resource_table = ARRAY [0 .. *] OF
          ARRAY [dst$channel_protocol_type] OF
          ARRAY [dst$physical_resource_number] OF RECORD
            channel: t$iou_resource_table_entry,
            pp: t$iou_resource_table_entry,
          RECEND;
?? EJECT ??
  CONST

    { The S0 has two groups of PPs.  The first group contains PP0-PP4.  The second group contains PP20-PP24.
    { The I4C has four groups of PPs.  The first group contains PP0-PP4.  The second group contains PP5-PP11.
    { The third group contains PP20-PP24.  The fourth group contains PP25-PP31.

    c$first_set_first_pp = 0,
    c$first_set_pp_4 = 4,
    c$first_set_pp_5 = 5,
    c$first_set_last_pp = 11(8),

    c$second_set_first_pp = 20(8),
    c$second_set_pp_24 = 24(8),
    c$second_set_pp_25 = 25(8),
    c$second_set_last_pp = 31(8),

    c$number_of_pps_in_set = 12(8),
    c$number_of_pps_in_cio_set = 5,
    c$number_of_pps_in_s0_set = 5,

    { This constant is used to define a resource owned by NOS/VE.

    c$nosve_owned_resource = 80(16),

    { This constant is used to define a PP that is available in the IOU resource table.

    c$available_pp = 0,

    { PP sizes are in units of PP words (16 bits per PP word).

    c$pp_size_0k = 0,
    c$pp_size_4k = 4 * 1024,
    c$pp_size_8k = 8 * 1024,
    c$pp_size_16k = 16 * 1024;

  VAR
    v$dft_sci_location: cmt$sci_dft_pp,

    v$pp_size: [READ, STATIC] t$pp_size_array := [[c$pp_size_0k,  c$pp_size_0k],
                                                  [c$pp_size_4k,  c$pp_size_0k],
                                                  [c$pp_size_4k,  c$pp_size_0k],
                                                  [c$pp_size_4k,  c$pp_size_0k],
                                                  [c$pp_size_4k,  c$pp_size_0k],
                                                  [c$pp_size_4k,  c$pp_size_0k],
                                                  [c$pp_size_4k,  c$pp_size_0k],
                                                  [c$pp_size_4k,  c$pp_size_8k],
                                                  [c$pp_size_4k,  c$pp_size_8k],
                                                  [c$pp_size_8k,  c$pp_size_8k],
                                                  [c$pp_size_8k,  c$pp_size_8k],
                                                  [c$pp_size_16k, c$pp_size_0k]],

    v$ssr_iou_resource_table_lock: ost$signature_lock,
    v$ssr_pp_buffer_interlock: ost$signature_lock;
?? TITLE := 'assign_any_pp', EJECT ??

{ PURPOSE:
{   This procedure searches for ANY available PP.  The search pattern depends on how many IOUs
{   are on the system and whether the IOUs contain NIO, CIO or both types of PPs.

  PROCEDURE assign_any_pp
    (    iou_resource_table_p: ^t$iou_resource_table;
     VAR primary_pp: dst$iou_resource;
     VAR pp_found: boolean;
     VAR status: ost$status);

    TYPE
      t$iou_data_type = ARRAY [dst$iou_number] OF RECORD
        exists: boolean,
        model_type: dst$iou_model_types,
        contains_channel_protocol: ARRAY [dst$channel_protocol_type] OF boolean,
      RECEND;

    VAR
      channel_protocol: dst$channel_protocol_type,
      ignore_partner: dst$iou_resource,
      iou_data: t$iou_data_type,
      iou_index: dst$number_of_ious,
      iou_information_table: dst$iou_information_table,
      iou_number: dst$iou_number,
      number_of_ious: dst$number_of_ious,
      pp: dst$iou_resource,
      request: dst$resource_request;

    status.normal := TRUE;
    pp_found := FALSE;

    { Create a list of available IOUs and whether the IOU has NIO and/or CIO PPs.
    { This list will be searched to find the available PP for the ANY PP request.

    FOR iou_number := LOWERBOUND (iou_data) TO UPPERBOUND (iou_data) DO
      iou_data [iou_number].exists := FALSE;
    FOREND;

    dsp$retrieve_iou_information (number_of_ious, iou_information_table);
    FOR iou_index := 1 TO number_of_ious DO
      iou_number := iou_information_table [iou_index].physical_iou_number;
      iou_data [iou_number].exists := TRUE;
      iou_data [iou_number].model_type := iou_information_table [iou_index].model_type;
      CASE iou_data [iou_number].model_type OF
      = dsc$imn_i4_40_model, dsc$imn_i4_42_model =
        iou_data [iou_number].contains_channel_protocol [dsc$cpt_nio] := TRUE;
        iou_data [iou_number].contains_channel_protocol [dsc$cpt_cio] := TRUE;
      = dsc$imn_i4_44_model, dsc$imn_i4_46_model =
        iou_data [iou_number].contains_channel_protocol [dsc$cpt_nio] := FALSE;
        iou_data [iou_number].contains_channel_protocol [dsc$cpt_cio] := TRUE;
      ELSE
        iou_data [iou_number].contains_channel_protocol [dsc$cpt_nio] := TRUE;
        iou_data [iou_number].contains_channel_protocol [dsc$cpt_cio] := FALSE;
      CASEND;
    FOREND;

    { The search begins with NIO PPs in the highest available IOU.  IF no PPs are available then the
    { next highest IOU is searched until no more IOUs exist.  If still no PP is available then the
    { search continues for CIO PPs in the highest available IOU and so on.

    FOR channel_protocol := LOWERVALUE (dst$channel_protocol_type) TO
          UPPERVALUE (dst$channel_protocol_type) DO
      FOR iou_number := UPPERVALUE (dst$iou_number) DOWNTO LOWERVALUE (dst$iou_number) DO
        IF (iou_data [iou_number].exists) AND
              (iou_data [iou_number].contains_channel_protocol [channel_protocol]) THEN
          pp.iou_number := iou_number;
          pp.channel_protocol := channel_protocol;
          pp.number := 15;
          IF (iou_number > 0) OR (osv$170_os_type = osc$ot7_none) OR
                (iou_data [iou_number].model_type = dsc$imn_i4_44_model) OR
                (iou_data [iou_number].model_type = dsc$imn_i4_46_model) THEN
            find_available_pp (LOWERVALUE (ost$physical_pp_number), UPPERVALUE (ost$physical_pp_number),
                  iou_resource_table_p, FALSE, pp, ignore_partner, pp_found);
            IF pp_found THEN
              primary_pp := pp;
              RETURN;
            IFEND;
          ELSE   {Send the request to the 170 side.
            request.channel := pp;
            request.resource_request_type := dsc$rrt_get_pp;
            request.options := $dst$resource_request_options [ ];
            request.primary_pp := pp;
            request.secondary_pp := pp;
            IF channel_protocol = dsc$cpt_cio THEN
              request.channel.number := 0;
              dsp$send_170_resource_request (request, status);
              IF NOT status.normal THEN
                request.channel.number := 5;
                dsp$send_170_resource_request (request, status);
              IFEND;
            ELSE
              dsp$send_170_resource_request (request, status);
            IFEND;
            IF status.normal THEN
              pp_found := TRUE;
              primary_pp := request.primary_pp;
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      FOREND;
    FOREND;

  PROCEND assign_any_pp;
?? TITLE := 'assign_cio_pp', EJECT ??

{ PURPOSE:
{   This procedure searches for a CIO PP.  CIO PPs must be retrieved from the same set that the
{   channel being used can access.  The PPs are searched from the lowest numbered PP to the highest
{   number PP in the set.

  PROCEDURE assign_cio_pp
    (    model_type: dst$iou_model_types;
         iou_resource_table_p: ^t$iou_resource_table;
     VAR request: dst$resource_request;
     VAR pp_found: boolean);

    VAR
      first_pp_number: ost$physical_pp_number,
      last_pp_found: boolean,
      last_pp_number: ost$physical_pp_number,
      partner_pp: dst$iou_resource,
      pp: dst$iou_resource;

    pp_found := FALSE;

    { Set up the PP number range to be searched for an available PP.

    IF dsc$rro_specific_pp IN request.options THEN
      first_pp_number := request.primary_pp.number;
      last_pp_number := first_pp_number;
    ELSE
      last_pp_found := FALSE;
      CASE model_TYPE OF
      = dsc$imn_i4_44_model =
        IF request.channel.number >= c$second_set_pp_25 THEN
          first_pp_number := c$second_set_pp_25;
        ELSEIF request.channel.number >= c$second_set_first_pp THEN
          first_pp_number := c$second_set_first_pp;
        ELSEIF request.channel.number >= c$first_set_pp_5 THEN
          first_pp_number := c$first_set_pp_5;
        ELSE
          first_pp_number := c$first_set_first_pp;
        IFEND;
      = dsc$imn_i4_46_model =
        IF request.channel.number >= 32(8) THEN
          first_pp_number := c$first_set_first_pp;
          last_pp_number := c$first_set_last_pp;
          last_pp_found := TRUE;
        ELSEIF request.channel.number >= c$second_set_pp_25 THEN
          first_pp_number := c$second_set_pp_25;
        ELSEIF request.channel.number >= c$second_set_first_pp THEN
          first_pp_number := c$second_set_first_pp;
        ELSEIF request.channel.number >= c$first_set_pp_5 THEN
          first_pp_number := c$first_set_pp_5;
        ELSE
          first_pp_number := c$first_set_first_pp;
        IFEND;
      = dsc$imn_i4_42_model =
        first_pp_number := c$first_set_first_pp;
        last_pp_number := c$first_set_pp_4;
        last_pp_found := TRUE;
      ELSE  { I4_40 }
        IF request.channel.number >= c$first_set_pp_5 THEN
          first_pp_number := c$first_set_pp_5;
        ELSE
          first_pp_number := c$first_set_first_pp;
        IFEND;
      CASEND;
      IF NOT last_pp_found THEN
        last_pp_number := first_pp_number + (c$number_of_pps_in_cio_set - 1);
      IFEND;
    IFEND;

    { Search the PP number range for an available PP.

    pp := request.primary_pp;
    partner_pp := request.secondary_pp;

    find_available_pp (first_pp_number, last_pp_number, iou_resource_table_p,
          (dsc$rro_partner_pp IN request.options), pp, partner_pp, pp_found);

    IF pp_found THEN
      request.primary_pp := pp;
      request.secondary_pp := partner_pp;
    IFEND;

  PROCEND assign_cio_pp;
?? TITLE := 'assign_nio_pp', EJECT ??

{ PURPOSE:
{   This procedure searches for a NIO PP.
{     search for SPECIFIC PP: Search for only the specified PP.
{     search for DRIVER PP:   Search PPs 20(8) - 31(8) If not found then search PPs 0 - 11(8).
{     search for PARTNER PPs: Search PPs 0(8) - 11(8) (The partner pp is then the corresponding
{                             pp in PPs 20 - 31(8) example: PP24(8) goes with PP4(8))  If not able
{                             to find a PP search for ANY two in PPs 0 - 31(8).
{     search for OTHER PP:    Search PPs 0 - 31(8)

  PROCEDURE assign_nio_pp
    (    iou_resource_table_p: ^t$iou_resource_table;
     VAR request: dst$resource_request;
     VAR pp_found: boolean);

    VAR
      first_pp_number: ost$physical_pp_number,
      ignore_pp: dst$iou_resource,
      last_pp_number: ost$physical_pp_number,
      partner_pp: dst$iou_resource,
      partner_pp_number: ost$physical_pp_number,
      pp: dst$iou_resource;

    pp_found := FALSE;

    pp := request.primary_pp;
    partner_pp := request.secondary_pp;

    IF dsc$rro_specific_pp IN request.options THEN
      find_available_pp (request.primary_pp.number, request.primary_pp.number, iou_resource_table_p,
            FALSE, pp, ignore_pp, pp_found);

    ELSEIF dsc$rro_partner_pp IN request.options THEN

      { First, an attempt is made to find a PP in the upper range and the corresponding PP in the lower range.

      first_pp_number := c$first_set_first_pp;
      last_pp_number := c$first_set_last_pp;
      pp_found := FALSE;

     /search_for_pps/
      WHILE NOT pp_found DO
        find_available_pp (first_pp_number, last_pp_number, iou_resource_table_p, FALSE, pp,
              ignore_pp, pp_found);
        IF NOT pp_found THEN
          EXIT /search_for_pps/;
        IFEND;

        partner_pp_number := pp.number + c$second_set_first_pp;
        find_available_pp (partner_pp_number, partner_pp_number, iou_resource_table_p, FALSE, partner_pp,
              ignore_pp, pp_found);
        IF pp_found THEN
          EXIT /search_for_pps/;
        IFEND;

        IF pp.number <> last_pp_number THEN
          first_pp_number := pp.number + 1;
        ELSE
          EXIT /search_for_pps/;
        IFEND;
      WHILEND /search_for_pps/;

      { Second, any two PPs are taken.

      IF NOT pp_found THEN
        find_available_pp (LOWERVALUE (ost$physical_pp_number), UPPERVALUE (ost$physical_pp_number),
              iou_resource_table_p, TRUE, pp, partner_pp, pp_found);
      IFEND;

    ELSEIF dsc$rro_driver_pp IN request.options THEN
      find_available_pp (c$second_set_first_pp, c$second_set_last_pp, iou_resource_table_p, FALSE,
            pp, ignore_pp, pp_found);

      IF NOT pp_found THEN
        find_available_pp (c$first_set_first_pp, c$first_set_last_pp, iou_resource_table_p, FALSE,
              pp, ignore_pp, pp_found);
      IFEND;

    ELSE  { request.options is a NULL set.
      find_available_pp (c$first_set_first_pp, c$second_set_last_pp, iou_resource_table_p, FALSE,
            pp, ignore_pp, pp_found);

    IFEND;

    IF pp_found THEN
      request.primary_pp := pp;
      request.secondary_pp := partner_pp;
    IFEND;

  PROCEND assign_nio_pp;
?? TITLE := 'assign_pp', EJECT ??

{ PURPOSE:
{   This procedure assigns a single or partner PP(s) to the requestor.

  PROCEDURE assign_pp
    (VAR request: dst$resource_request;
     VAR iou_resource_table_p: ^t$iou_resource_table;
     VAR status: ost$status);

    VAR
      integer_string: ost$string,
      model_type: dst$iou_model_types,
      pp_found: boolean,
      size: ost$string_size,
      text: string (osc$max_string_size);

    status.normal := TRUE;

    IF dsc$rro_any_pp IN request.options THEN
      assign_any_pp (iou_resource_table_p, request.primary_pp, pp_found, status);
    ELSE
      retrieve_iou_model_type (request.channel.iou_number, model_type, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      { Initialize the primary pp and the secondary pp with the channel data.  It is possible to have
      { NIO channels on an I4CE, however, make sure the PP channel protocol is CIO.

      IF NOT (dsc$rro_specific_pp IN request.options) THEN
        request.primary_pp := request.channel;
        request.secondary_pp := request.channel;
        IF model_type = dsc$imn_i4_46_model THEN
          request.primary_pp.channel_protocol := dsc$cpt_cio;
          request.secondary_pp.channel_protocol := dsc$cpt_cio;
        IFEND;
      IFEND;

      IF (osv$170_os_type = osc$ot7_none) OR (request.channel.iou_number > 0) OR
            (model_type = dsc$imn_i4_44_model) OR (model_type = dsc$imn_i4_46_model) THEN
        IF model_type = dsc$imn_i0_5x_model THEN
          assign_s0_pp (iou_resource_table_p, request, pp_found);
        ELSEIF (request.channel.channel_protocol = dsc$cpt_cio) OR (model_type = dsc$imn_i4_46_model) THEN
          assign_cio_pp (model_type, iou_resource_table_p, request, pp_found);
        ELSE
          assign_nio_pp (iou_resource_table_p, request, pp_found);
        IFEND;
      ELSE
        dsp$send_170_resource_request (request, status);
        pp_found := status.normal;
      IFEND;
    IFEND;

    IF NOT pp_found AND status.normal THEN
      text := ' ';
      size := 1;
      IF NOT (dsc$rro_any_pp IN request.options) THEN
        text (size, 30) := 'Unable to assign requested IOU ';
        size := size + 30;
        clp$convert_integer_to_string (request.primary_pp.iou_number, 10, FALSE, integer_string, status);
        text (size, integer_string.size) := integer_string.value (1, integer_string.size);
        size := size + integer_string.size + 1;
        IF request.channel.channel_protocol = dsc$cpt_cio THEN
          text (size, 3) := 'CPP';
          size := size + 3;
        ELSE
          text (size, 2) := 'PP';
          size := size + 2;
        IFEND;
        IF dsc$rro_specific_pp IN request.options THEN
          clp$convert_integer_to_string (request.primary_pp.number, 10, FALSE, integer_string, status);
          text (size, integer_string.size) := integer_string.value (1, integer_string.size);
          size := size + integer_string.size;
          text (size, 1) := '.';
          size := size + 1;
        ELSE
          text (size, 3) := '.  ';
          size := size + 3;
        IFEND;
      IFEND;
      IF NOT (dsc$rro_specific_pp IN request.options) THEN
        text (size, 38) := 'There are no PPs available for NOS/VE.';
        size := size + 38;
      IFEND;
      osp$set_status_abnormal (dsc$display_processor_id, dse$pp_not_available_to_ve, text, status);
    IFEND;

  PROCEND assign_pp;
?? TITLE := 'assign_s0_pp', EJECT ??

{ PURPOSE:
{   This procedure searches for an S0 PP.  S0 PPs must be retrieved from the same set that the
{   channel being used can access.  If there are no PPs in the set desired then an attempt is
{   made to relocate DFT and/or SCI and try again.

  PROCEDURE assign_s0_pp
    (VAR iou_resource_table_p: ^t$iou_resource_table;
     VAR request: dst$resource_request;
     VAR pp_found: boolean);

    VAR
      dft_sci_relocated: boolean,
      first_pp_number: ost$physical_pp_number,
      last_pp_number: ost$physical_pp_number,
      partner_pp: dst$iou_resource,
      pp: dst$iou_resource;

    pp_found := FALSE;

    { Set up the PP number range to be searched for an available PP.

    IF dsc$rro_specific_pp IN request.options THEN
      first_pp_number := request.primary_pp.number;
      last_pp_number := first_pp_number;
    ELSE
      IF request.channel.number >= c$second_set_first_pp THEN
        first_pp_number := c$second_set_first_pp;
      ELSE
        first_pp_number := c$first_set_first_pp;
      IFEND;
      last_pp_number := first_pp_number + (c$number_of_pps_in_s0_set - 1);
    IFEND;

    { Search the PP number range for an available PP.

    pp := request.primary_pp;
    partner_pp := request.secondary_pp;
    REPEAT
      dft_sci_relocated := FALSE;
      find_available_pp (first_pp_number, last_pp_number, iou_resource_table_p,
            (dsc$rro_partner_pp IN request.options), pp, partner_pp, pp_found);
      IF NOT pp_found THEN
        relocate_dft_sci (request.channel, iou_resource_table_p, dft_sci_relocated);
      IFEND;
    UNTIL NOT dft_sci_relocated;

    IF pp_found THEN
      request.primary_pp := pp;
      request.secondary_pp := partner_pp;
    IFEND;

  PROCEND assign_s0_pp;
?? TITLE := 'check_channel_pp_number', EJECT ??

{ PURPOSE:
{   This procedure checks that the channel or PP number sent with the IOU resource request is valid.

  PROCEDURE check_channel_pp_number
    (    resource_type: (c$channel_resource, c$pp_resource);
         resource: dst$iou_resource;
     VAR status: ost$status);

    VAR
      last_pp_set_1: ost$physical_pp_number,
      last_pp_set_2: ost$physical_pp_number,
      model_type: dst$iou_model_types;

    status.normal := TRUE;

    retrieve_iou_model_type (resource.iou_number, model_type, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (model_type <> dsc$imn_i0_5x_model) AND (resource.channel_protocol <> dsc$cpt_cio) THEN
      RETURN;
    IFEND;

    IF model_type = dsc$imn_i0_5x_model THEN
      IF resource_type = c$channel_resource THEN
        last_pp_set_1 := c$first_set_pp_4 + 1;
        last_pp_set_2 := c$second_set_pp_24 + 1;
      ELSE
        last_pp_set_1 := c$first_set_pp_4;
        last_pp_set_2 := c$second_set_pp_24;
      IFEND;
      IF ((resource.number >= c$first_set_first_pp) AND (resource.number <= last_pp_set_1)) OR
            ((resource.number >= c$second_set_first_pp) AND (resource.number <= last_pp_set_2)) THEN
        RETURN;
      IFEND;
    IFEND;

    IF resource.channel_protocol = dsc$cpt_cio THEN
      IF (model_type = dsc$imn_i4_44_model) OR (model_type = dsc$imn_i4_46_model) THEN
        IF ((resource.number >= c$first_set_first_pp) AND (resource.number <= c$first_set_last_pp)) OR
              ((resource.number >= c$second_set_first_pp) AND (resource.number <= c$second_set_last_pp)) THEN
          RETURN;
        IFEND;
      ELSE
        IF ((resource.number >= c$first_set_first_pp) AND (resource.number <= c$first_set_last_pp)) THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    IF resource_type = c$channel_resource THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_number,
            'The channel number is invalid.', status);
    ELSE
      osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_number,
            'The pp number is invalid.', status);
    IFEND;

  PROCEND check_channel_pp_number;
?? TITLE := 'check_for_assigned_pp', EJECT ??

{ PURPOSE:
{   This procedure checks to see if the given PP is assigned to VE.

  PROCEDURE check_for_assigned_pp
    (    pp: dst$iou_resource;
     VAR status: ost$status);

    VAR
      integer_string: ost$string,
      iou_information_table: dst$iou_information_table,
      number_of_ious: dst$number_of_ious,
      iou_resource_table_p: ^t$iou_resource_table,
      iou_resource_table_seq_p: ^SEQ ( * ),
      size: ost$string_size,
      text: string (osc$max_string_size);

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (v$ssr_iou_resource_table_lock);
    dsp$retrieve_iou_information (number_of_ious, iou_information_table);

    PUSH iou_resource_table_p: [0 .. (number_of_ious - 1)];
    iou_resource_table_seq_p := #SEQ (iou_resource_table_p^);
    dsp$get_data_from_ssr (dsc$ssr_resource_assignment, iou_resource_table_seq_p);
    IF iou_resource_table_p^ [pp.iou_number] [pp.channel_protocol] [pp.number].pp <
          c$nosve_owned_resource THEN
      text := 'IOU ';
      size := 4;
      clp$convert_integer_to_string (pp.iou_number, 10, FALSE, integer_string, status);
      text (size, integer_string.size) := integer_string.value (1, integer_string.size);
      size := size + integer_string.size + 1;
      IF pp.channel_protocol = dsc$cpt_cio THEN
        text (size, 5) := ' CPP ';
        size := size + 5;
      ELSE
        text (size, 4) := ' PP ';
        size := size + 4;
      IFEND;
      clp$convert_integer_to_string (pp.number, 10, TRUE, integer_string, status);
      text (size, integer_string.size) := integer_string.value (1, integer_string.size);
      size := size + integer_string.size + 1;
      text (size, 37) := ' is not currently assigned to NOS/VE.';
      size := size + 37;
      osp$set_status_abnormal (dsc$display_processor_id,
            dse$pp_not_assigned_to_ve, text (1, size), status);
    IFEND;
    osp$clear_mainframe_sig_lock (v$ssr_iou_resource_table_lock);

  PROCEND check_for_assigned_pp;
?? TITLE := 'check_for_partner_pps', EJECT ??

{ PURPOSE:
{   This procedure checks to see if the given PP and possibly a partner PP is assigned to VE.

  PROCEDURE check_for_partner_pps
    (    pp: dst$iou_resource;
     VAR status: ost$status);

    VAR
      partner_pp: dst$iou_resource,
      partner_pp_exists: boolean;

    status.normal := TRUE;

    check_for_assigned_pp (pp, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { If the PP is the system device PP then it must be checked to see if it has a partner PP.  If the system
    { device has a partner PP then that partner PP must be checked to see if it is assigned to NOS/VE.

    cmp$check_dual_pp_system_disk (pp, partner_pp_exists, partner_pp);
    IF partner_pp_exists THEN
      check_for_assigned_pp (partner_pp, status);
    IFEND;

  PROCEND check_for_partner_pps;
?? TITLE := 'check_for_valid_request', EJECT ??

{ PURPOSE:
{   This procedure checks the validity of the IOU resource request.

  PROCEDURE check_for_valid_request
    (    request: dst$resource_request;
         iou_resource_table_p: ^t$iou_resource_table;
     VAR status: ost$status);

    VAR
      condition_code: ost$status_condition_code,
      integer_string: ost$string,
      channel_pp_number: t$iou_resource_table_entry,
      options: dst$resource_request_options,
      partner_pp_number: t$iou_resource_table_entry,
      size: ost$string_size,
      text: string (osc$max_string_size),
      unused_status: ost$status;

    status.normal := TRUE;
    text (1, *) := ' ';
    size := 1;

    { Check the validity of the IOU number that is associated with the channel.

    check_iou_number (request.channel.iou_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE request.resource_request_type OF
    = dsc$rrt_get_pp =
      options := request.options;
      IF dsc$rro_driver_pp IN options THEN
        options := options - $dst$resource_request_options [dsc$rro_driver_pp];
      ELSEIF dsc$rro_partner_pp IN options THEN
        options := options - $dst$resource_request_options [dsc$rro_partner_pp];
      ELSEIF dsc$rro_specific_pp IN options THEN
        options := options - $dst$resource_request_options [dsc$rro_specific_pp];
      ELSEIF dsc$rro_any_pp IN options THEN
        options := options - $dst$resource_request_options [dsc$rro_any_pp];
      IFEND;
      IF options <> $dst$resource_request_options [ ] THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_request_options, '', status);
        RETURN;
      IFEND;
      IF dsc$rro_specific_pp IN request.options THEN
        check_iou_number (request.primary_pp.iou_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        check_channel_pp_number (c$pp_resource, request.primary_pp, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    = dsc$rrt_return_pp =
      check_iou_number (request.primary_pp.iou_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      channel_pp_number := iou_resource_table_p^ [request.primary_pp.iou_number]
            [request.primary_pp.channel_protocol] [request.primary_pp.number].pp;

      IF dsc$rro_partner_pp IN request.options THEN
        check_iou_number (request.secondary_pp.iou_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        partner_pp_number := iou_resource_table_p^ [request.secondary_pp.iou_number]
              [request.secondary_pp.channel_protocol] [request.secondary_pp.number].pp;
      IFEND;

      IF (channel_pp_number < c$nosve_owned_resource) OR ((dsc$rro_partner_pp IN request.options) AND
            (partner_pp_number < c$nosve_owned_resource)) THEN
        text (size, 18) := 'Cannot return IOU ';
        size := size + 18;
        clp$convert_integer_to_string (request.primary_pp.iou_number, 10, FALSE, integer_string, status);
        text (size, integer_string.size) := integer_string.value (1, integer_string.size);
        size := size + integer_string.size + 1;
        IF request.primary_pp.channel_protocol = dsc$cpt_cio THEN
          text (size, 5) := ' CPP ';
          size := size + 5;
        ELSE
          text (size, 4) := ' PP ';
          size := size + 4;
        IFEND;
        IF channel_pp_number < c$nosve_owned_resource THEN
          clp$convert_integer_to_string (request.primary_pp.number, 10,
                TRUE, integer_string, unused_status);
        ELSE
          clp$convert_integer_to_string (request.secondary_pp.number, 10,
                TRUE, integer_string, unused_status);
        IFEND;
        text (size, integer_string.size) := integer_string.value (1, integer_string.size);
        size := size + integer_string.size + 1;
        text (size, 42) := '.  It is not currently assigned to NOS/VE.';
        size := size + 42;
        osp$set_status_abnormal (dsc$display_processor_id,
              dse$cannot_return_resource, text (1, size), status);
        RETURN;
      IFEND;

    = dsc$rrt_get_channel =
      check_channel_pp_number (c$channel_resource, request.channel, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      channel_pp_number := iou_resource_table_p^ [request.channel.iou_number]
            [request.channel.channel_protocol] [request.channel.number].channel;
      IF channel_pp_number > 0 THEN
        text (size, 4) := 'IOU ';
        size := size + 4;
        clp$convert_integer_to_string (request.channel.iou_number, 10, FALSE, integer_string, status);
        text (size, integer_string.size) := integer_string.value (1, integer_string.size);
        size := size + integer_string.size + 1;
        IF request.channel.channel_protocol = dsc$cpt_cio THEN
          text (size, 5) := ' CCH ';
          size := size + 5;
        ELSE
          text (size, 4) := ' CH ';
          size := size + 4;
        IFEND;
        clp$convert_integer_to_string (request.channel.number, 10,
              TRUE, integer_string, unused_status);
        text (size, integer_string.size) := integer_string.value (1, integer_string.size);
        size := size + integer_string.size + 1;
        IF channel_pp_number < c$nosve_owned_resource THEN
          condition_code := dse$ch_not_available_to_ve;
          text (size, 38) := ' is not currently available to NOS/VE.';
          size := size + 38;
        ELSE
          condition_code := dse$ch_assigned_to_ve;
          text (size, 33) := ' is currently assigned to NOS/VE.';
          size := size + 33;
        IFEND;
        osp$set_status_abnormal (dsc$display_processor_id, condition_code, text (1, size), status);
        RETURN;
      IFEND;

    = dsc$rrt_return_channel =
      IF iou_resource_table_p^ [request.channel.iou_number] [request.channel.channel_protocol]
            [request.channel.number].channel < c$nosve_owned_resource THEN
        text (size, 18) := 'Cannot return IOU ';
        size := size + 18;
        clp$convert_integer_to_string (request.channel.iou_number, 10, FALSE, integer_string, status);
        text (size, integer_string.size) := integer_string.value (1, integer_string.size);
        size := size + integer_string.size + 1;
        IF request.channel.channel_protocol = dsc$cpt_cio THEN
          text (size, 5) := ' CCH ';
          size := size + 5;
        ELSE
          text (size, 4) := ' CH ';
          size := size + 4;
        IFEND;
        clp$convert_integer_to_string (request.channel.number, 10,
              TRUE, integer_string, unused_status);
        text (size, integer_string.size) := integer_string.value (1, integer_string.size);
        size := size + integer_string.size + 1;
        text (size, 42) := '.  It is not currently assigned to NOS/VE.';
        size := size + 42;
        osp$set_status_abnormal (dsc$display_processor_id,
              dse$cannot_return_resource, text (1, size), status);
        RETURN;
      IFEND;

    = dsc$rrt_get_equipment =
      channel_pp_number := iou_resource_table_p^ [request.channel.iou_number]
            [request.channel.channel_protocol] [request.channel.number].channel;
      IF (channel_pp_number < c$nosve_owned_resource) AND (channel_pp_number > 0) THEN
        text (size, 36) := 'Cannot get requested equipment, IOU ';
        size := size + 36;
        clp$convert_integer_to_string (request.channel.iou_number, 10, FALSE, integer_string, status);
        text (size, integer_string.size) := integer_string.value (1, integer_string.size);
        size := size + integer_string.size + 1;
        IF request.channel.channel_protocol = dsc$cpt_cio THEN
          text (size, 5) := ' CCH ';
          size := size + 5;
        ELSE
          text (size, 4) := ' CH ';
          size := size + 4;
        IFEND;
        clp$convert_integer_to_string (request.channel.number, 10,
              TRUE, integer_string, unused_status);
        text (size, integer_string.size) := integer_string.value (1, integer_string.size);
        size := size + integer_string.size + 1;
        text (size, 38) := ' is not currently available to NOS/VE.';
        size := size + 38;
        osp$set_status_abnormal (dsc$display_processor_id,
              dse$eq_not_available_to_ve, text (1, size), status);
        RETURN;
      IFEND;

    ELSE
    CASEND;

  PROCEND check_for_valid_request;
?? TITLE := 'check_iou_number', EJECT ??

{ PURPOSE:
{   This procedure checks that the IOU number sent with the IOU resource request is valid.

  PROCEDURE check_iou_number
    (    iou_number: dst$iou_number;
     VAR status: ost$status);

    VAR
      iou_index: dst$number_of_ious,
      iou_information_table: dst$iou_information_table,
      number_of_ious: dst$number_of_ious;

    status.normal := TRUE;

    dsp$retrieve_iou_information (number_of_ious, iou_information_table);
    FOR iou_index := 1 TO number_of_ious DO
      IF iou_number = iou_information_table [iou_index].physical_iou_number THEN
        RETURN;
      IFEND;
    FOREND;
    osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_number,
          'The IOU number is invalid.', status);

  PROCEND check_iou_number;
?? TITLE := 'find_available_pp', EJECT ??

{ PURPOSE:
{   This procedure searches the IOU resource table for an available PP.

  PROCEDURE find_available_pp
    (    first_pp_number: ost$physical_pp_number;
         last_pp_number: ost$physical_pp_number;
         iou_resource_table_p: ^t$iou_resource_table;
         search_for_partner_pp: boolean;
     VAR pp: dst$iou_resource;
     VAR partner_pp: dst$iou_resource;
     VAR pp_found: boolean);

    VAR
      partner_pp_number: ost$physical_pp_number,
      pp_number: ost$physical_pp_number;

    pp_found := FALSE;

   /search_for_pp/
    FOR pp_number := first_pp_number TO last_pp_number DO
      IF iou_resource_table_p^ [pp.iou_number] [pp.channel_protocol] [pp_number].pp = c$available_pp THEN
        pp.number := pp_number;
        pp_found := TRUE;
        EXIT /search_for_pp/;
      IFEND;
    FOREND /search_for_pp/;

    IF NOT pp_found OR NOT search_for_partner_pp THEN
      RETURN;
    IFEND;

    { Search for a partner PP.

    pp_found := FALSE;
    IF pp.number <> last_pp_number THEN
      FOR partner_pp_number := (pp.number + 1) TO last_pp_number DO
        IF iou_resource_table_p^ [partner_pp.iou_number] [partner_pp.channel_protocol]
              [partner_pp_number].pp = c$available_pp THEN
          partner_pp.number := partner_pp_number;
          pp_found := TRUE;
          RETURN;
        IFEND;
      FOREND;
    IFEND;

  PROCEND find_available_pp;
?? TITLE := 'idle_pp', EJECT ??

{ PURPOSE:
{   This procedure idles the given PP.  Available options are to dump the PP which includes
{   the PP registers or dump only the PP registers or only idle the PP.

  PROCEDURE idle_pp
    (    subfunction: dst$dft_puf_subfunctions;
         pp: dst$iou_resource;
         ssr_segment_number: ost$segment;
     VAR dump_area_p: ^SEQ (*);
     VAR status: ost$status);

    VAR
      dump_data_seq_p: ^SEQ ( * ),
      lock_set: boolean,
      model_type: dst$iou_model_types,
      pp_length: ost$pp_byte_size,
      ssr_data_seq_p: ^SEQ ( * ),
      ssr_ppbf_seq_p: ^SEQ ( * );

    status.normal := TRUE;
    pp_length := 0;
    ssr_ppbf_seq_p := NIL;
    lock_set := FALSE;

  /pp_idle/
    BEGIN

      CASE subfunction OF
      = dsc$dpuf_idle_dump_pp, dsc$dpuf_idle_dump_registers =
        IF dump_area_p = NIL THEN
          osp$set_status_abnormal (dsc$display_processor_id, dse$nil_caller_ptr, '', status);
          EXIT /pp_idle/;
        IFEND;

        IF subfunction = dsc$dpuf_idle_dump_pp THEN
          retrieve_iou_model_type (pp.iou_number, model_type, status);
          IF NOT status.normal THEN
            EXIT /pp_idle/;
          IFEND;
          pp_length := v$pp_size [model_type] [pp.channel_protocol] * 2;
        ELSE
          pp_length := #SIZE (dst$dft_pp_registers);
        IFEND;

        osp$set_mainframe_sig_lock (v$ssr_pp_buffer_interlock);
        lock_set := TRUE;
        dsp$get_ssr_data_seq_ptr (dsc$ssr_pp_controlware_buf, ssr_segment_number, ssr_ppbf_seq_p);
        IF #SEGMENT (dump_area_p) = #SEGMENT (ssr_ppbf_seq_p) THEN
          osp$set_status_abnormal (dsc$display_processor_id, dse$cant_store_pp_in_ssr, '', status);
          EXIT /pp_idle/;
        IFEND;
      ELSE
      CASEND;

      { Make the request to idle the PP.

      dsp$process_pp_function (subfunction, pp, 0, pp_length, ssr_ppbf_seq_p, status);
      IF NOT status.normal OR (subfunction = dsc$dpuf_idle_pp) THEN
        EXIT /pp_idle/;
      IFEND;

      { Move the dumped PP information from the SSR to the caller's area.

      RESET dump_area_p;
      NEXT dump_data_seq_p: [[REP pp_length OF cell]] IN dump_area_p;
      RESET ssr_ppbf_seq_p;
      NEXT ssr_data_seq_p: [[REP pp_length OF cell]] IN ssr_ppbf_seq_p;
      dump_data_seq_p^ := ssr_data_seq_p^;
      RESET dump_area_p;
    END /pp_idle/;

    IF lock_set THEN
      osp$clear_mainframe_sig_lock (v$ssr_pp_buffer_interlock);
    IFEND;

  PROCEND idle_pp;
?? TITLE := 'relocate_dft_sci', EJECT ??

{ PURPOSE:
{   This procedure attempts to relocate DFT or SCI on an S0.

  PROCEDURE relocate_dft_sci
    (VAR channel: dst$iou_resource;
     VAR iou_resource_table_p: ^t$iou_resource_table;
     VAR dft_sci_relocated: boolean);

    CONST
      c$first_cluster = 0,
      c$second_cluster = 2;

    VAR
      current_dft_cluster: c$first_cluster .. c$second_cluster,
      current_sci_cluster: c$first_cluster .. c$second_cluster,
      first_pp_number: ost$physical_pp_number,
      ignore_partner: dst$iou_resource,
      ignore_status: ost$status,
      last_pp_number: ost$physical_pp_number,
      old_pp_number: ost$physical_pp_number,
      pp: dst$iou_resource,
      pp_found: boolean,
      requested_cluster: c$first_cluster .. c$second_cluster;

    dft_sci_relocated := FALSE;

    { Find the number of the cluster in which DFT and SCI reside.

    IF dsv$cpu_pp_communication_block.relocation.dft_pp_number < c$second_set_first_pp THEN
      current_dft_cluster := c$first_cluster;
    ELSE
      current_dft_cluster := c$second_cluster;
    IFEND;
    IF dsv$cpu_pp_communication_block.relocation.sci_pp_number < c$second_set_first_pp THEN
      current_sci_cluster := c$first_cluster;
    ELSE
      current_sci_cluster := c$second_cluster;
    IFEND;

    { Set up search parameters for a free PP in the cluster NOT requested.

    IF channel.number >= c$second_set_first_pp THEN
      requested_cluster := c$second_cluster;
      first_pp_number := c$first_set_first_pp;
    ELSE
      requested_cluster := c$first_cluster;
      first_pp_number := c$second_set_first_pp;
    IFEND;
    last_pp_number := first_pp_number + (c$number_of_pps_in_s0_set - 1);

    { Check if DFT or SCI resides in the requested cluster.

    IF (requested_cluster <> current_dft_cluster) AND (requested_cluster <> current_sci_cluster) THEN
      RETURN;
    IFEND;

    { Attempt to find a free PP in the non-requested cluster in which to move DFT or SCI.  If the requested
    { cluster is the first cluster then SCI will be the first PP selected to be moved to the second cluster.
    { If the requested cluster is the second cluster then DFT will be the first PP selected to be moved
    { to the first cluster.  The goal is to keep DFT in the first cluster as much as possible.  DFT can only
    { access the common disk area from the first cluster.

    pp := channel;
    find_available_pp (first_pp_number, last_pp_number, iou_resource_table_p, FALSE, pp,
          ignore_partner, pp_found);
    IF NOT pp_found THEN
      RETURN;
    IFEND;

    IF requested_cluster = c$first_cluster THEN
      IF requested_cluster = current_sci_cluster THEN
        old_pp_number := dsv$cpu_pp_communication_block.relocation.sci_pp_number;
        dsv$cpu_pp_communication_block.relocation.sci_pp_number := pp.number;
        dsv$cpu_pp_communication_block.relocation.sci_idle_pending := TRUE;
        REPEAT
          #spoil (dsv$cpu_pp_communication_block);
          pmp$delay (250, ignore_status);
        UNTIL NOT dsv$cpu_pp_communication_block.relocation.sci_idle_pending;
        dpp$put_critical_message ('SCI RELOCATED', ignore_status);
      ELSE  { requested_cluster = current_dft_cluster }
        old_pp_number := dsv$cpu_pp_communication_block.relocation.dft_pp_number;
        dsv$cpu_pp_communication_block.relocation.dft_pp_number := pp.number;
        dsv$cpu_pp_communication_block.relocation.dft_idle_pending := TRUE;
        REPEAT
          #spoil (dsv$cpu_pp_communication_block);
          pmp$delay (250, ignore_status);
        UNTIL NOT dsv$cpu_pp_communication_block.relocation.dft_idle_pending;
        dpp$put_critical_message ('DFT RELOCATED', ignore_status);
      IFEND;
    ELSE  { requested_cluster = c$second_cluster }
      IF requested_cluster = current_dft_cluster THEN
        old_pp_number := dsv$cpu_pp_communication_block.relocation.dft_pp_number;
        dsv$cpu_pp_communication_block.relocation.dft_pp_number := pp.number;
        dsv$cpu_pp_communication_block.relocation.dft_idle_pending := TRUE;
        REPEAT
          #spoil (dsv$cpu_pp_communication_block);
          pmp$delay (250, ignore_status);
        UNTIL NOT dsv$cpu_pp_communication_block.relocation.dft_idle_pending;
        dpp$put_critical_message ('DFT RELOCATED', ignore_status);
      ELSE  { requested_cluster = current_sci_cluster }
        old_pp_number := dsv$cpu_pp_communication_block.relocation.sci_pp_number;
        dsv$cpu_pp_communication_block.relocation.sci_pp_number := pp.number;
        dsv$cpu_pp_communication_block.relocation.sci_idle_pending := TRUE;
        REPEAT
          #spoil (dsv$cpu_pp_communication_block);
          pmp$delay (250, ignore_status);
        UNTIL NOT dsv$cpu_pp_communication_block.relocation.sci_idle_pending;
        dpp$put_critical_message ('SCI RELOCATED', ignore_status);
      IFEND;
    IFEND;

    { Change the resource assignment table in the SSR to reflect the PP change.

    iou_resource_table_p^ [pp.iou_number] [pp.channel_protocol] [pp.number].pp :=
          iou_resource_table_p^ [pp.iou_number] [pp.channel_protocol] [old_pp_number].pp;
    iou_resource_table_p^ [pp.iou_number] [pp.channel_protocol] [old_pp_number].pp := 0;
    dsp$store_data_in_ssr (dsc$ssr_resource_assignment, #SEQ (iou_resource_table_p^));

    { Notify CM about the PP change.

    v$dft_sci_location.primary_dft_pp.number := dsv$cpu_pp_communication_block.relocation.dft_pp_number;
    v$dft_sci_location.sci_pp.number := dsv$cpu_pp_communication_block.relocation.sci_pp_number;
    cmp$update_dft_sci_location (v$dft_sci_location);

    dft_sci_relocated := TRUE;

  PROCEND relocate_dft_sci;
?? TITLE := 'retrieve_iou_model_type', EJECT ??

{ PURPOSE:
{   This procedure retrieves the IOU model type.

  PROCEDURE retrieve_iou_model_type
    (    iou_number: dst$iou_number;
     VAR model_type: dst$iou_model_types;
     VAR status: ost$status);

    VAR
      iou_index: dst$number_of_ious,
      iou_information_table: dst$iou_information_table,
      number_of_ious: dst$number_of_ious;

    status.normal := TRUE;

    dsp$retrieve_iou_information (number_of_ious, iou_information_table);
    FOR iou_index := 1 TO number_of_ious DO
      IF iou_number = iou_information_table [iou_index].physical_iou_number THEN
        model_type := iou_information_table [iou_index].model_type;
        RETURN;
      IFEND;
    FOREND;
    osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_number,
          'The IOU number is invalid.', status);

  PROCEND retrieve_iou_model_type;
?? TITLE := 'dsp$fetch_controlware', EJECT ??

{ PURPOSE:
{   This procedure retrieves the controlware from the CIP device.
{ NOTES:
{   The caller must specify a NIL pointer for the controlware.  Space will be allocated
{   in the mainframe wired heap to hold the controlware.  The caller has the responsibility
{   to free the space when the caller is finished using the space.

  PROCEDURE [XDCL] dsp$fetch_controlware
    (    controlware_name: dst$resource_name;
     VAR controlware_seq_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      controlware_length: integer,
      ssr_controlware_data_p: ^SEQ ( * ),
      ssr_ppbf_seq_p: ^SEQ ( * ),
      ssr_segment_number: ost$segment,
      unused_status: ost$status;

    status.normal := TRUE;

    { The caller must send a NIL pointer.  Space for this pointer will be allocated in the mainframe
    { wired heap.

    IF controlware_seq_p <> NIL THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$nil_caller_ptr, '', status);
      RETURN;
    IFEND;

    { Add the SSR to the caller's segment table.

    dsp$open_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (v$ssr_pp_buffer_interlock);
    dsp$get_ssr_data_seq_ptr (dsc$ssr_pp_controlware_buf, ssr_segment_number, ssr_ppbf_seq_p);

  /fetch_controlware/
    BEGIN

      { Retrieve the controlware from the CIP device.

      dsp$read_cda_program (controlware_name, ssr_ppbf_seq_p, controlware_length, status);
      IF NOT status.normal THEN
        EXIT /fetch_controlware/;
      IFEND;

      { Move the controlware from PPBF in the SSR to the mainframe wired heap.

      ALLOCATE controlware_seq_p: [[REP controlware_length OF cell]] IN osv$mainframe_wired_heap^;
      RESET controlware_seq_p;
      RESET ssr_ppbf_seq_p;
      NEXT ssr_controlware_data_p: [[REP controlware_length OF cell]] IN ssr_ppbf_seq_p;
      RESET ssr_controlware_data_p;
      controlware_seq_p^ := ssr_controlware_data_p^;
    END /fetch_controlware/;

    osp$clear_mainframe_sig_lock (v$ssr_pp_buffer_interlock );
    dsp$close_ssr (ssr_segment_number, unused_status);

  PROCEND dsp$fetch_controlware;
?? TITLE := 'dsp$get_pp_registers', EJECT ??

{ PURPOSE:
{   This procedure retrieves the PP registers of a specific PP.

  PROCEDURE [XDCL] dsp$get_pp_registers
    (    pp: dst$iou_resource;
     VAR registers: dst$dft_pp_registers;
     VAR status: ost$status);

    VAR
      registers_p: ^dst$dft_pp_registers,
      registers_size: ost$pp_byte_size,
      ssr_ppbf_seq_p: ^SEQ ( * ),
      ssr_segment_number: ost$segment,
      unused_status: ost$status;

    status.normal := TRUE;

    { Check for a valid IOU number.

    check_iou_number (pp.iou_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Add the SSR to the caller's segment table.

    dsp$open_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Lock and use the PP controlware buffer in the SSR to retrieve the PP registers.

    osp$set_mainframe_sig_lock (v$ssr_pp_buffer_interlock);
    dsp$get_ssr_data_seq_ptr (dsc$ssr_pp_controlware_buf, ssr_segment_number, ssr_ppbf_seq_p);

  /get_pp_registers/
    BEGIN

      { Check the resource assignment table in the SSR to see if the PP is indeed assigned to NOS/VE.

      check_for_assigned_pp (pp, status);
      IF NOT status.normal THEN
        EXIT /get_pp_registers/;
      IFEND;

      registers_size := #SIZE (registers);
      dsp$process_pp_function (dsc$dpuf_dump_pp_registers, pp, 0, registers_size, ssr_ppbf_seq_p, status);
      IF NOT status.normal THEN
        EXIT /get_pp_registers/;
      IFEND;

      RESET ssr_ppbf_seq_p;
      NEXT registers_p IN ssr_ppbf_seq_p;
      registers := registers_p^;
    END /get_pp_registers/;

    osp$clear_mainframe_sig_lock (v$ssr_pp_buffer_interlock);
    dsp$close_ssr (ssr_segment_number, unused_status);

  PROCEND dsp$get_pp_registers;
?? TITLE := 'dsp$idle_pp', EJECT ??

{ PURPOSE:
{   This procedure idles the given PP.  Available options are to dump the PP which includes
{   the PP registers or dump only the PP registers or only idle the PP.

  PROCEDURE [XDCL] dsp$idle_pp
    (    pp: dst$iou_resource;
         dump_registers_only: boolean;
         dump_pp: boolean;
     VAR dump_area_p: ^SEQ (*);
     VAR status: ost$status);

    VAR
      ssr_segment_number: ost$segment,
      subfunction: dst$dft_puf_subfunctions,
      unused_status: ost$status;

    status.normal := TRUE;

    { Check for a valid IOU number.

    check_iou_number (pp.iou_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Add the SSR to the caller's segment table.

    dsp$open_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /pp_idle/
    BEGIN

      { Check the resource assignment table in the SSR to see if the PP is indeed assigned to NOS/VE.

      check_for_assigned_pp (pp, status);
      IF NOT status.normal THEN
        EXIT /pp_idle/;
      IFEND;

      IF dump_pp THEN
        subfunction := dsc$dpuf_idle_dump_pp;
      ELSEIF dump_registers_only THEN
        subfunction := dsc$dpuf_idle_dump_registers;
      ELSE
        subfunction := dsc$dpuf_idle_pp;
      IFEND;

      idle_pp (subfunction, pp, ssr_segment_number, dump_area_p, status);
    END /pp_idle/;

    dsp$close_ssr (ssr_segment_number, unused_status);

  PROCEND dsp$idle_pp;
?? TITLE := 'dsp$load_pp', EJECT ??

{ PURPOSE:
{   This procedure loads a PP image into a PP.
{ DESIGN:
{   The actual PP image may be sent to the procedure OR the PP name may be sent to the
{   procedure in which case the PP image is acquired from the PP library.

  PROCEDURE [XDCL] dsp$load_pp
    (    type_of_pp_load: (dsc$load_pp_image, dsc$load_pp_by_name);
         pp: dst$iou_resource;
         image_p: ^SEQ ( * );
         name: dst$driver_name;
         table_rma: ost$real_memory_address;
     VAR status: ost$status);

    VAR
      pp_length: ost$pp_byte_size,
      ssr_pp_image_p: ^ARRAY [ost$pp_size] OF ost$pp_byte_size,
      ssr_ppbf_seq_p: ^SEQ ( * ),
      ssr_segment_number: ost$segment,
      unused_status: ost$status;

    status.normal := TRUE;

    { Check for a valid IOU number.

    check_iou_number (pp.iou_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Add the SSR to the caller's segment table.

    dsp$open_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Lock and use the PP controlware buffer in the SSR to hold the PP image.

    osp$set_mainframe_sig_lock (v$ssr_pp_buffer_interlock);
    dsp$get_ssr_data_seq_ptr (dsc$ssr_pp_controlware_buf, ssr_segment_number, ssr_ppbf_seq_p);

  /load_pp/
    BEGIN

      { Check the resource assignment table in the SSR to see if the PP(s) is/are indeed assigned to NOS/VE.

      check_for_partner_pps (pp, status);
      IF NOT status.normal THEN
        EXIT /load_pp/;
      IFEND;

      { Move the PP image to the SSR area.

      CASE type_of_pp_load OF
      = dsc$load_pp_image =
        IF #SEGMENT (image_p) = #SEGMENT (ssr_ppbf_seq_p) THEN
          osp$set_status_abnormal (dsc$display_processor_id, dse$cant_store_pp_in_ssr, '', status);
        ELSE
          pp_length := #SIZE (image_p^);
          i#move (image_p, ssr_ppbf_seq_p, pp_length);
        IFEND;
      = dsc$load_pp_by_name =
        dsp$fetch_pp_image (name, dsc$fpio_fetch_base_overlay, pp_length, ssr_ppbf_seq_p, status);
      ELSE
      CASEND;
      IF NOT status.normal THEN
        EXIT /load_pp/;
      IFEND;

      { The words 72(8) and 73(8) of the PP image must contain the RMA to the PP interface table.  This
      { allows the PP to access various things in this table.

      RESET ssr_ppbf_seq_p;
      NEXT ssr_pp_image_p IN ssr_ppbf_seq_p;
      ssr_pp_image_p^ [72(8)] := table_rma DIV 10000(16);
      ssr_pp_image_p^ [73(8)] := table_rma MOD 10000(16);
      RESET ssr_ppbf_seq_p;

      { Make the request to load the PP.

      dsp$process_pp_function (dsc$dpuf_load_pp, pp, 0, pp_length, ssr_ppbf_seq_p, status);
      IF NOT status.normal THEN
        EXIT /load_pp/;
      IFEND;

      { Wait for the pp to read the program.

      pmp$delay (1000, status);
    END /load_pp/;

    osp$clear_mainframe_sig_lock (v$ssr_pp_buffer_interlock);
    dsp$close_ssr (ssr_segment_number, unused_status);

  PROCEND dsp$load_pp;
?? TITLE := 'dsp$request_resources', EJECT ??

{ PURPOSE:
{   This procedure directs the resource requests from the system.  It attempts to get or return
{   the requested resource.  If the request fails, an appropriate message is returned.
{ DESIGN:
{   A request to DFT is made to obtain the resource in standalone mode or for requests for
{   an IOU other then IOU0 or for requests to an I4C.  Otherwise, the request is made to the
{   170 operating system.

  PROCEDURE [XDCL] dsp$request_resources
    (VAR request: dst$resource_request;
     VAR status: ost$status);

    VAR
      iou_information_table: dst$iou_information_table,
      iou_resource_table_p: ^t$iou_resource_table,
      iou_resource_table_seq_p: ^SEQ ( * ),
      model_type: dst$iou_model_types,
      no_dump_p: ^SEQ ( * ),
      number_of_ious: dst$number_of_ious,
      ssr_segment_number: ost$segment,
      unused_status: ost$status;

    status.normal := TRUE;

    { Add the SSR to the caller's segment table.

    dsp$open_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Get a pointer to the resource assignment area in the SSR.

    osp$set_mainframe_sig_lock (v$ssr_iou_resource_table_lock);
    dsp$retrieve_iou_information (number_of_ious, iou_information_table);
    PUSH iou_resource_table_p: [0 .. (number_of_ious - 1)];
    iou_resource_table_seq_p := #SEQ (iou_resource_table_p^);
    dsp$get_data_from_ssr (dsc$ssr_resource_assignment, iou_resource_table_seq_p);

  /request_resources/
    BEGIN

      { Check the validity of the request.

      check_for_valid_request (request, iou_resource_table_p, status);
      IF NOT status.normal THEN
        EXIT /request_resources/;
      IFEND;

      CASE request.resource_request_type OF
      = dsc$rrt_get_pp =
        assign_pp (request, iou_resource_table_p, status);
        IF NOT status.normal THEN
          EXIT /request_resources/;
        IFEND;
      ELSE

        { If returning the PP, attempt to idle the PP.

        IF request.resource_request_type = dsc$rrt_return_pp THEN
          no_dump_p := NIL;
          idle_pp (dsc$dpuf_idle_pp, request.primary_pp, ssr_segment_number, no_dump_p, status);
          IF (dsc$rro_partner_pp IN request.options) THEN
            idle_pp (dsc$dpuf_idle_pp, request.secondary_pp, ssr_segment_number, no_dump_p, status);
          IFEND;
        IFEND;

        { Make the request to the appropriate operating system.

        retrieve_iou_model_type (request.channel.iou_number, model_type, status);
        IF NOT status.normal THEN
          EXIT /request_resources/;
        IFEND;
        IF (request.channel.iou_number = 0) AND (osv$170_os_type <> osc$ot7_none) AND
              (model_type <> dsc$imn_i4_44_model) AND (model_type <> dsc$imn_i4_46_model) THEN
          dsp$send_170_resource_request (request, status);
          IF NOT status.normal THEN
            IF status.condition = dse$resource_does_not_exist THEN

              { Attempted to request/release an equipment that is not defined in the EST.  If it is not
              { defined in the EST then it is assumed that NOS/VE can safely use the equipment, just
              { request/release the channel.

              CASE request.resource_request_type OF
              = dsc$rrt_get_equipment =
                request.resource_request_type := dsc$rrt_get_channel;
                dsp$send_170_resource_request (request, status);
                request.resource_request_type := dsc$rrt_get_equipment;
              = dsc$rrt_return_equipment =
                request.resource_request_type := dsc$rrt_return_channel;
                dsp$send_170_resource_request (request, status);
                request.resource_request_type := dsc$rrt_return_equipment;
              ELSE
              CASEND;
            IFEND;
            IF NOT status.normal THEN
              EXIT /request_resources/;
            IFEND;
          IFEND;
        IFEND;
      CASEND;

      { Update the resource assignment table in the SSR.

      CASE request.resource_request_type OF
      = dsc$rrt_get_pp =
        iou_resource_table_p^ [request.primary_pp.iou_number] [request.primary_pp.channel_protocol]
              [request.primary_pp.number].pp := request.channel.number + c$nosve_owned_resource;
        IF (dsc$rro_partner_pp IN request.options) THEN
          iou_resource_table_p^ [request.secondary_pp.iou_number] [request.secondary_pp.channel_protocol]
                [request.secondary_pp.number].pp := request.channel.number + c$nosve_owned_resource;
        IFEND;

      = dsc$rrt_return_pp =
        iou_resource_table_p^ [request.primary_pp.iou_number] [request.primary_pp.channel_protocol]
              [request.primary_pp.number].pp := 0;
        IF (dsc$rro_partner_pp IN request.options) THEN
          iou_resource_table_p^ [request.primary_pp.iou_number] [request.secondary_pp.channel_protocol]
                [request.secondary_pp.number].pp := 0;
        IFEND;

      = dsc$rrt_get_channel =
        iou_resource_table_p^ [request.channel.iou_number] [request.channel.channel_protocol]
              [request.channel.number].channel := request.channel.number + c$nosve_owned_resource;

      = dsc$rrt_return_channel =
        iou_resource_table_p^ [request.channel.iou_number] [request.channel.channel_protocol]
              [request.channel.number].channel := 0;

      = dsc$rrt_get_equipment =
        iou_resource_table_p^ [request.channel.iou_number] [request.channel.channel_protocol]
              [request.channel.number].channel := request.channel.number + c$nosve_owned_resource;

      ELSE
      CASEND;
      dsp$store_data_in_ssr (dsc$ssr_resource_assignment, #SEQ (iou_resource_table_p^));
    END /request_resources/;

    osp$clear_mainframe_sig_lock (v$ssr_iou_resource_table_lock);
    dsp$close_ssr (ssr_segment_number, unused_status);

  PROCEND dsp$request_resources;
?? TITLE := 'dsp$resume_pp', EJECT ??

{ PURPOSE:
{   This procedure resumes the given PP at the given address minus one.

  PROCEDURE [XDCL] dsp$resume_pp
    (    pp: dst$iou_resource;
         resume_address: dst$dft_resume_address;
     VAR status: ost$status);

    VAR
      actual_resume_address: dst$dft_resume_address,
      model_type: dst$iou_model_types,
      ssr_segment_number: ost$segment,
      unused_pp_data_seq_p: ^SEQ ( * ),
      unused_pp_length: ost$pp_byte_size,
      unused_status: ost$status;

    status.normal := TRUE;

    { Check for a valid IOU number.

    check_iou_number (pp.iou_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Check for a valid resume address.

    IF resume_address <= 1 THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$resume_address_too_small, '', status);
      RETURN;
    IFEND;

    retrieve_iou_model_type (pp.iou_number, model_type, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF resume_address > v$pp_size [model_type] [pp.channel_protocol] THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$resume_address_too_large, '', status);
      RETURN;
    IFEND;

    { The actual resume address sent to DFT is the resume address minus one.

    actual_resume_address := resume_address - 1;

    { Add the SSR to the caller's segment table and interlock the SSR from other user jobs.

    dsp$open_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /resume_pp/
    BEGIN

      { Check the resource assignment table in the SSR to see if the PP is indeed assigned to NOS/VE.

      check_for_assigned_pp (pp, status);
      IF NOT status.normal THEN
        EXIT /resume_pp/;
      IFEND;

      unused_pp_length := 0;
      unused_pp_data_seq_p := NIL;
      dsp$process_pp_function (dsc$dpuf_resume_pp, pp, actual_resume_address, unused_pp_length,
            unused_pp_data_seq_p, status);
    END /resume_pp/;

    dsp$close_ssr (ssr_segment_number, unused_status);

  PROCEND dsp$resume_pp;
?? TITLE := 'dsp$setup_load_ppu_interlocks', EJECT ??

{ PURPOSE:
{   This procedure is called to initialize interlocks that this module uses.

  PROCEDURE [XDCL] dsp$setup_load_ppu_interlocks;

    VAR
      dfts_buffer: dst$ssr_dfts_buffer,
      dfts_buffer_seq_p: ^SEQ ( * ),
      dfts_control_word: dst$dftb_control_word,
      local_status: ost$status,
      model_type: dst$iou_model_types,
      rb: dst$rb_logging_request;

    osp$initialize_signature_lock (v$ssr_pp_buffer_interlock, local_status);
    IF NOT local_status.normal THEN
      osp$system_error (' Error in setting the PPBF interlock.', ^local_status);
    IFEND;

    osp$initialize_signature_lock (v$ssr_iou_resource_table_lock, local_status);
    IF NOT local_status.normal THEN
      osp$system_error (' Error in setting the VEPP interlock.', ^local_status);
    IFEND;

    { Inform CM in which PPs DFT, SCI, and the secondary DFT reside.

    IF NOT dsv$cpu_pp_communication_block.relocation.initialized THEN
      osp$system_error ('The DFT_SCI_relocation_word is not initialized', NIL);
    IFEND;

    retrieve_iou_model_type (0, model_type, local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('Error in retrieving IOU model type', ^local_status);
    IFEND;

    v$dft_sci_location.sci_pp.iou_number := 0;
    v$dft_sci_location.sci_pp.number := dsv$cpu_pp_communication_block.relocation.sci_pp_number;

    IF (model_type = dsc$imn_i4_44_model) OR (model_type = dsc$imn_i4_46_model) THEN
      v$dft_sci_location.sci_pp.channel_protocol := dsc$cpt_cio;
    ELSE
      v$dft_sci_location.sci_pp.channel_protocol := dsc$cpt_nio;
    IFEND;

    IF dsv$mainframe_type <> dsc$mt_2000_mainframe THEN
      v$dft_sci_location.primary_dft_available := TRUE;
      v$dft_sci_location.primary_dft_pp.iou_number := 0;
      v$dft_sci_location.primary_dft_pp.number := dsv$cpu_pp_communication_block.relocation.dft_pp_number;
      IF (model_type = dsc$imn_i4_44_model) OR (model_type = dsc$imn_i4_46_model) THEN
        v$dft_sci_location.primary_dft_pp.channel_protocol := dsc$cpt_cio;
      ELSE
        v$dft_sci_location.primary_dft_pp.channel_protocol := dsc$cpt_nio;
      IFEND;
    ELSE
      v$dft_sci_location.primary_dft_pp.iou_number := 0;
      v$dft_sci_location.primary_dft_pp.channel_protocol := dsc$cpt_nio;
      v$dft_sci_location.primary_dft_pp.number := 0;
    IFEND;

    IF dsv$dftb_data.revision_level <= dsc$dftb_revision_level_5 THEN
      dfts_buffer_seq_p := #SEQ (dfts_buffer);
      dsp$get_data_from_ssr (dsc$ssr_secondary_dft_block, dfts_buffer_seq_p);
      dfts_control_word := dfts_buffer.control_word;
      v$dft_sci_location.secondary_dft_available := dfts_control_word.dft_verification;
    ELSE
      rb.reqcode := syc$rc_logging_request;
      rb.action := dsc$rla_dft_retrieve_dfts_cw;
      i#call_monitor (#LOC (rb), #SIZE (rb));
      dfts_control_word := rb.dftb_dfts_control_word;
      v$dft_sci_location.secondary_dft_available := dfts_control_word.dft_verification;
    IFEND;
    IF v$dft_sci_location.secondary_dft_available THEN
      retrieve_iou_model_type (1, model_type, local_status);
      IF NOT local_status.normal THEN
        osp$system_error ('Error in retrieving IOU model type', ^local_status);
      IFEND;
      v$dft_sci_location.secondary_dft_pp.iou_number := 1;
      v$dft_sci_location.secondary_dft_pp.number := dfts_control_word.dft_pp_number;
      IF (model_type = dsc$imn_i4_44_model) OR (model_type = dsc$imn_i4_46_model) THEN
        v$dft_sci_location.secondary_dft_pp.channel_protocol := dsc$cpt_cio;
      ELSE
        v$dft_sci_location.secondary_dft_pp.channel_protocol := dsc$cpt_nio;
      IFEND;
    ELSE
      v$dft_sci_location.secondary_dft_pp.iou_number := 0;
      v$dft_sci_location.secondary_dft_pp.channel_protocol := dsc$cpt_nio;
      v$dft_sci_location.secondary_dft_pp.number := 0;
    IFEND;

    cmp$update_dft_sci_location (v$dft_sci_location);

  PROCEND dsp$setup_load_ppu_interlocks;
MODEND dsm$load_ppu;
*DECK DECK=DSM$LOG_SYSTEM_MESSAGES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : System Messages Logger' ??
MODULE dsm$log_system_messages;

{ PURPOSE:
{   This module contains procedures that log messages from the System Message buffer to the engineering log,
{   log errors from the DFT control block to the engineering log and it contains procedures that various
{   parts of the operating system call to log messages to the engineering log.
{
{ NOTES:
{   Different areas of the operating system have procedures in this module to log the data.  Each area has a
{   unique identifier at the beginning of the procedure name so that the different area's procedures can be
{   identified easily.  For example, all the code that deals with DFT has the identifier 'dft_', all the code
{   that deals with configuration management statistics has the identifier 'cm_'.  Follow this convention when
{   adding new procedures to this module.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmc$logical_unit_constants
*copyc cml$channel_identification
*copyc cml$cm_identification
*copyc cml$connection_disabled
*copyc cml$cp_identification
*copyc cml$cpu_failure_data
*copyc cml$dft_cpu_failure_data
*copyc cml$dft_critical_failure_data
*copyc cml$dft_cyber_2000_error
*copyc cml$dft_hour_element_counters
*copyc cml$dft_hour_secded_id
*copyc cml$dft_iou_failure_data
*copyc cml$dft_memory_failure_data
*copyc cml$dft_non_crit_failure_data
*copyc cml$dft_page_map_failure_data
*copyc cml$dft_power_failure_data
*copyc cml$dft_top_of_hour
*copyc cml$element_disabled
*copyc cml$element_state_change
*copyc cml$environment_failure_data
*copyc cml$iou_failure_data
*copyc cml$iou_identification
*copyc cml$job_recovery_failure
*copyc cml$job_recovery_totals
*copyc cml$memory_failure_data
*copyc cml$ms_media_flaw_change
*copyc cml$ms_volume_initialization
*copyc cml$page_map_failure_data
*copyc cml$peripheral_identification
*copyc cml$pm_identification
*copyc cml$pp_hung
*copyc cml$pp_timed_out
*copyc cml$system_continuation
*copyc cml$system_deadstart_status
*copyc cml$system_error
*copyc cml$system_informative_message
*copyc cml$system_termination
*copyc cml$top_of_hour_counters
*copyc cml$top_of_hour_secded_id
*copyc cmt$physical_channel
*copyc dmt$flaw_dau_definition
*copyc dmt$log_flaw_init_data
*copyc dst$dft_analysis_code_constants
*copyc dst$log_ele_state_change
*copyc dst$log_hung_pp_data
*copyc dst$log_ms_volume_init
*copyc dst$log_pp_timed_out
*copyc dst$rb_logging_request
*copyc dst$signal_contents
*copyc dst$system_message_types
*copyc oss$mainframe_paged_literal
*copyc oss$task_shared
*copyc ost$cpu_definitions
*copyc ost$date_time
*copyc ost$global_task_id
*copyc ost$system_error_statistic
*copyc ost$system_flag
*copyc ost$terminate_continue_stats
*copyc pmt$signal
*copyc syt$180_idle_code
?? POP ??
*copyc clp$convert_integer_to_string
*copyc clp$put_job_command_response
*copyc cmp$convert_channel_number
*copyc cmp$convert_iou_number
*copyc cmp$get_element_state
*copyc cmp$pc_get_element
*copyc cmp$pc_get_logical_unit
*copyc dfp$any_sdp_defined
*copyc dfp$log_esm_data
*copyc dfp$log_side_door_port_status
*copyc dmp$get_logical_unit_number
*copyc dmp$get_physical_attributes
*copyc dsp$clear_sys_msg_buffer_in_rdf
*copyc dsp$close_rdf
*copyc dsp$get_integer_from_rdf
*copyc dsp$get_rdf_entry_seq_pointer
*copyc dsp$lock_unlock_window_from_mtr
*copyc dsp$log_sys_msg_help
*copyc dsp$manage_dftb_space_in_mfw
*copyc dsp$open_rdf
*copyc dsp$retrieve_mf_element_entry
*copyc dsp$retrieve_iou_information
*copyc dsp$retrieve_system_ds_status
*copyc dsp$set_record_errors_flag
*copyc dsp$store_integer_in_rdf
*copyc i#call_monitor
*copyc i#current_sequence_position
*copyc iop$log_disk_data
*copyc iop$log_tape_data
*copyc nap$reload_network_pp
*copyc ofp$receive_operator_response
*copyc ofp$send_operator_message
*copyc osp$log_unformatted_status
*copyc pmp$cycle
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pmp$get_mainframe_id
*copyc pmp$log_ascii
*copyc sfp$activate_system_statistic
*copyc sfp$emit_statistic
?? EJECT ??
*copyc cmv$logical_pp_table_p
*copyc cmv$physical_configuration
*copyc dsv$actual_deadstart_phase
*copyc dsv$automatic_pp_reload
*copyc dsv$cpu_pp_communication_block
*copyc dsv$dftb_data
*copyc dsv$record_errors
*copyc dsv$turn_dft_logging_off
*copyc jmv$executing_within_system_job
*copyc osv$cpus_physically_configured
*copyc osv$task_private_heap
*copyc syv$debug_job_recovery
*copyc syv$failure_reason_p
*copyc syv$file_rcv_failure_count
*copyc syv$recovery_failure_count
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  CONST
    c$eid_register_number = 10(16),
    c$log_message_size = 62,

    { These constants describe the size of the variable 'dft_log_message'.  "NON" describes the non-specific
    { elements.

    c$number_of_iou = 0D(16),
    c$number_of_memory = 09(16),
    c$number_of_cpu = 32(16),
    c$number_of_page_map = 02(16),
    c$number_of_bad_requests = 09(16),
    c$number_of_packet = 07(16),
    c$number_of_software = 2C(16),
    c$number_of_non = 0A(16),
    c$number_of_dft_log_messages = c$number_of_iou + c$number_of_memory + c$number_of_cpu +
          c$number_of_page_map + c$number_of_bad_requests + c$number_of_packet + c$number_of_software +
          c$number_of_non,

    c$number_of_idle_log_messages = 11;

  TYPE
    t$dft_buffer_data = RECORD
      mrb_seq_p: ^SEQ ( * ),
      ssb_seq_p: ^SEQ ( * ),
      mdb_seq_p: ^SEQ ( * ),
      nrb_seq_p: ^SEQ ( * ),
    RECEND,

    t$hung_pp_message_type = (c$hpmt_null, c$hpmt_bad_status, c$hpmt_invalid_channel,
          c$hpmt_no_handshaking, c$hpmt_no_reload),

    { This is the type declaration for the constant messages for the log.

    t$ic_log_message_type = RECORD
      idle_code: syt$180_idle_code,
      value: string (c$log_message_size),
    RECEND,

    t$log_message_type = RECORD
      dft_analysis_code: dst$dftb_dft_analysis_code,
      value: string (c$log_message_size),
    RECEND,

    t$mainframe_name_type = RECORD
      size: 0 .. 31,
      value: string (31),
    RECEND,

    t$post_operator_actions = RECORD
      size: 0 .. ofc$max_operator_message_size,
      value: string (ofc$max_operator_message_size),
    RECEND,

    { This is the type declaration for the constant state messages for the log.  This information can be
    { obtained from the deck cml$element_state_change.

    t$state_counter_value = 0 .. 6,

    t$state_log_message_type = RECORD
      value: string (c$log_message_size),
      counter_value: t$state_counter_value,
    RECEND;
?? EJECT ??

  VAR

    { This variable contains the constant log messages for the messages created from the dft errors and from
    { system detected errors that have a dft analysis code described in dst$dft_analysis_code_constants.  IF
    { new error codes are added, the following decks must be changed.  This deck and CTI$DFT_ANALYSIS_CODES
    { and DST$DFT_ANALYSIS_CODE_CONSTANTS and DUM$PROCESS_DFT_BUFFER_COMMAND.

    v$dft_log_message: [READ, oss$mainframe_paged_literal] ARRAY [1 .. c$number_of_dft_log_messages]
          OF t$log_message_type :=
      { IOU }
          [[dsc$dftb_dac_iou_001, '*DEADSTART ERROR LOG IOU ERROR'],
           [dsc$dftb_dac_iou_002, '*EXPRESS DEADSTART DUMP IOU ERROR'],
           [dsc$dftb_dac_iou_003, '*CORRECTED IOU ERROR'],
           [dsc$dftb_dac_iou_004, '*UNCORRECTED IOU ERROR (PP HALT)'],
           [dsc$dftb_dac_iou_005, '*12/16 IOU CONVERSION ERROR'],
           [dsc$dftb_dac_iou_006, '*FATAL IOU ERROR (NOT PP HALT)'],
           [dsc$dftb_dac_iou_007, '*IOU CHANNEL ERROR'],
           [dsc$dftb_dac_iou_008, '*FATAL IOU ERROR (NOT PP HALT)'],
           [dsc$dftb_dac_iou_009, '*UNCORRECTED IOU ERROR (PP HALT)'],
           [dsc$dftb_dac_iou_00A, '*12/16 IOU CONVERSION ERROR'],
           [dsc$dftb_dac_iou_00B, '*IOU CHANNEL ERROR'],
           [dsc$dftb_dac_iou_00C, '*IOU SS BIT 57 CONDITION'],
           [dsc$dftb_dac_iou_0FF, '*HARDWARE ERROR'],
      { MEMORY }
           [dsc$dftb_dac_mem_101, '*DEADSTART ERROR LOG MEMORY ERROR'],
           [dsc$dftb_dac_mem_102, '*EXPRESS DEADSTART DUMP MEMORY ERROR'],
           [dsc$dftb_dac_mem_103, '*CORRECTED MEMORY ERROR'],
           [dsc$dftb_dac_mem_104, '*UNCORRECTED MEMORY ERROR'],
           [dsc$dftb_dac_mem_105, '*FATAL CM ERROR (MULTIPLE ODD BIT ERROR)'],
           [dsc$dftb_dac_mem_106, '*FATAL CM ERROR (PARTIAL WRITE PARITY ERROR)'],
           [dsc$dftb_dac_mem_107, '*RESERVED FOR FUTURE USE'],
           [dsc$dftb_dac_mem_108, '*UNCORRECTED MEMORY BOARD LEVEL ERROR'],
           [dsc$dftb_dac_mem_109, '*UNCORRECTED MEMORY INTERFACE ERROR'],
      { CPU }
           [dsc$dftb_dac_cpu_201, '*DEADSTART ERROR LOG PROCESSOR ERROR'],
           [dsc$dftb_dac_cpu_202, '*EXPRESS DEADSTART DUMP PROCESSOR ERROR'],
           [dsc$dftb_dac_cpu_203, '*CORRECTED PROCESSOR ERROR'],
           [dsc$dftb_dac_cpu_204, '*UNCORRECTED PROCESSOR ERROR'],
           [dsc$dftb_dac_cpu_205, '*RETRY IN PROGRESS'],
           [dsc$dftb_dac_cpu_206, '*SOFT CONTROL MEMORY RELOAD'],
           [dsc$dftb_dac_cpu_207, '*UNSUCCESSFUL SOFT CONTROL MEMORY RELOAD'],
           [dsc$dftb_dac_cpu_208, '*FATAL CPU HALT CLASS 1'],
           [dsc$dftb_dac_cpu_209, '*CPU ERROR EXIT MODE 20'],
           [dsc$dftb_dac_cpu_20A, '*CPU ERROR EXIT MODE 67'],
           [dsc$dftb_dac_cpu_20B, '*FATAL CPU RECOVERY ERROR'],
           [dsc$dftb_dac_cpu_20C, '*CORRECTED PROCESSOR ERROR WITH CACHE RELOAD'],
           [dsc$dftb_dac_cpu_20D, '*FATAL CPU UNCORRECTED ERROR'],
           [dsc$dftb_dac_cpu_20E, '*FATAL CPU ERROR (DUE THRESHOLD EXCEEDED)'],
           [dsc$dftb_dac_cpu_20F, '*FATAL C170 STATE DUE'],
           [dsc$dftb_dac_cpu_210, '*FATAL C170 STATE EXIT MODE HALT'],
           [dsc$dftb_dac_cpu_211, '*FATAL MONITOR DUE'],
           [dsc$dftb_dac_cpu_212, '*FATAL MONITOR ERROR'],
           [dsc$dftb_dac_cpu_213, '*FATAL MONITOR MCR'],
           [dsc$dftb_dac_cpu_214, '*FATAL EI DUE'],
           [dsc$dftb_dac_cpu_215, '*FATAL MCH ERROR'],
           [dsc$dftb_dac_cpu_216, '*FATAL JOB ERROR'],
           [dsc$dftb_dac_cpu_217, '*FATAL JOB MCR'],
           [dsc$dftb_dac_cpu_218, '*FATAL CPU N ERROR'],
           [dsc$dftb_dac_cpu_219, '*FORCED UNCORRECTED ERROR'],
           [dsc$dftb_dac_cpu_21A, '*FATAL CPU HALT CLASS 2'],
           [dsc$dftb_dac_cpu_21B, '*RETRY CONVERTED TO UNCORRECTED ERROR'],
           [dsc$dftb_dac_cpu_21C, '*RETRY EXHAUSTED'],
           [dsc$dftb_dac_cpu_21D, '*HOURLY RETRY THRESHOLD EXCEEDED'],
           [dsc$dftb_dac_cpu_21E, '*PARTIAL WRITE ADDRESS PARITY ERROR'],
           [dsc$dftb_dac_cpu_21F, '*FATAL CPU ERROR (UNABLE TO EXCHANGE OR TRAP)'],
           [dsc$dftb_dac_cpu_220, '*FATAL CPU ERROR (PROCESS DAMAGED IN MTR MODE)'],
           [dsc$dftb_dac_cpu_221, '*FATAL CPU ERROR (DUE WITH MICROCODE HALT)'],
           [dsc$dftb_dac_cpu_222, '*FATAL CPU ERROR (NO ERROR BITS PRESENT IN STATUS SUMMARY)'],
           [dsc$dftb_dac_cpu_223, '*FATAL CPU ERROR (CONTROL STORE RELOAD FAILED)'],
           [dsc$dftb_dac_cpu_224, '*FATAL CPU ERROR (RETRIES EXHAUSTED)'],
           [dsc$dftb_dac_cpu_225, '*FATAL CPU ERROR (HALT TIMEOUT)'],
           [dsc$dftb_dac_cpu_226, '*FATAL CPU ERROR (UNEXPECTED MICROCODE HALT ADDRESS)'],
           [dsc$dftb_dac_cpu_227, '*UNCORRECTED CPU ERROR (EXCHANGE VECTOR)'],
           [dsc$dftb_dac_cpu_228, '*UNCORRECTED CPU ERROR (TRAP VECTOR)'],
           [dsc$dftb_dac_cpu_229, '*UNCORRECTED CPU ERROR (HALT VECTOR)'],
           [dsc$dftb_dac_cpu_22A, '*CLOCK ERROR'],
           [dsc$dftb_dac_cpu_22B, '*FATAL CONTROL STORE ERROR (JOB MODE)'],
           [dsc$dftb_dac_cpu_22C, '*FATAL CONTROL STORE ERROR (MONITOR MODE)'],
           [dsc$dftb_dac_cpu_22D, '*CORRECTED CPU ERROR (RETRY SUCCESSFUL)'],
           [dsc$dftb_dac_cpu_22E, '*FATAL CPU MICROCODE PARITY ERROR'],
           [dsc$dftb_dac_cpu_22F, '*NEGATIVE SIT CONDITION'],
           [dsc$dftb_dac_cpu_230, '*CPU MAC HANG'],
           [dsc$dftb_dac_cpu_231, '*CPU/MEM DEADMAN TIMEOUT'],
           [dsc$dftb_dac_cpu_232, '*CPU VECTOR DEGRADE'],
      { PAGE MAP }
           [dsc$dftb_dac_map_301, '*CORRECTED PAGE MAP ERROR'],
           [dsc$dftb_dac_map_302, '*UNCORRECTED PAGE MAP ERROR'],
      { BAD REQUESTS TO DFT }
           [dsc$dftb_dac_req_401, '*BAD RESPONSE TO AN OS REQUEST'],
           [dsc$dftb_dac_req_402, '*DFT LOGGED PROCESSOR FAILURE MESSAGE'],
           [dsc$dftb_dac_req_403, '*ERROR UPDATING THE ECR RECORD'],
           [dsc$dftb_dac_req_404, '*ERRONEOUS BIT 59 SET AND NO ERROR DETECTED'],
           [dsc$dftb_dac_req_405, '*TRANSIENT BIT 59 CONDITION'],
           [dsc$dftb_dac_req_406, '*ERROR PROCESSING THE ECR RECORD IN AN ERROR CONDITION'],
           [dsc$dftb_dac_req_407, '*EPM BOARD ERROR DATA'],
           [dsc$dftb_dac_req_408, '*EPM SYSTEM ERROR DATA'],
           [dsc$dftb_dac_req_40A, '*NEGATIVE SIT CONDITION'],
      { PACKET COMMUNICATION }
           [dsc$dftb_dac_pac_501, '*BAD PACKET RESPONSE'],
           [dsc$dftb_dac_pac_502, '*PACKET SEQUENCE NUMBER MISMATCH'],
           [dsc$dftb_dac_pac_503, '*BAD PACKET PHASE IN DFT'],
           [dsc$dftb_dac_pac_504, '*DFT/2AP INTERFACE ERROR'],
           [dsc$dftb_dac_pac_505, '*PACKET TIMEOUT CONDITION'],
           [dsc$dftb_dac_pac_507, '*PACKET REQUEST QUEUE FULL REQUEST IGNORED'],
           [dsc$dftb_dac_pac_5FF, '*SERVICE PROCESSOR INTERNAL ERROR'],
      { SOFTWARE }
           [dsc$dftb_dac_sof_601, '*SCI NOT RESPONDING'],
           [dsc$dftb_dac_sof_602, '*DFT NOT RESPONDING'],
           [dsc$dftb_dac_sof_603, '*CHANNEL 17 PARITY ERROR'],
           [dsc$dftb_dac_sof_604, '*CHANNEL 17 INTERLOCK ERROR'],
           [dsc$dftb_dac_sof_605, '*CHANNEL 17 ACTIVE'],
           [dsc$dftb_dac_sof_606, '*RESERVED'],
           [dsc$dftb_dac_sof_607, '*DFT REGISTER NUMBER NOT IN THE MRB'],
           [dsc$dftb_dac_sof_608, '*DFT MAINFRAME IDENTIFICATION ERROR'],
           [dsc$dftb_dac_sof_609, '*DFT PROCESSOR TYPE ERROR'],
           [dsc$dftb_dac_sof_60A, '*DFT FATAL STACK'],
           [dsc$dftb_dac_sof_60B, '*DFT BUILD REGISTER LIST SIZE ERROR'],
           [dsc$dftb_dac_sof_60C, '*PP LOAD ERROR'],
           [dsc$dftb_dac_sof_60D, '*170 MTR MCR FAULT - DETECTED BY EI'],
           [dsc$dftb_dac_sof_60E, '*BAD SYSTEM REQUEST - DETECTED BY EI'],
           [dsc$dftb_dac_sof_60F, '*CHANNEL 17 INACTIVE'],
           [dsc$dftb_dac_sof_610, '*SCI PRESET FAILURE'],
           [dsc$dftb_dac_sof_611, '*SCI LOADED IN PP 0'],
           [dsc$dftb_dac_sof_612, '*DFT ELEMENT DESCRIPTOR NOT IN MRT'],
           [dsc$dftb_dac_sof_613, '*DFT COMM FAILURE'],
           [dsc$dftb_dac_sof_614, '*DFT INCOMPATIBLE VERSION'],
           [dsc$dftb_dac_sof_615, '*SCI TABLE SIZE TOO SMALL'],
           [dsc$dftb_dac_sof_616, '*WALL CLOCK CHIP READ ERROR'],
           [dsc$dftb_dac_sof_617, '*NOS/VE MONITOR NOT RESPONDING'],
           [dsc$dftb_dac_sof_618, '*NO PP AVAILABLE FOR DFT'],
           [dsc$dftb_dac_sof_619, '*REGISTER LIST LENGTH GREATER THEN POINTER VALUE'],
           [dsc$dftb_dac_sof_61A, '*DFT IOU FIELD PROCESSING ERROR'],
           [dsc$dftb_dac_sof_61B, '*DFT NOT FOUND IN CIP DIRECTORY'],
           [dsc$dftb_dac_sof_61C, '*DFT SECONDARY BUFFER ERROR'],
           [dsc$dftb_dac_sof_61D, '*PRIMARY BUFFER ALLOCATION ERROR'],
           [dsc$dftb_dac_sof_61E, '*DFT INTERNAL ERROR'],
           [dsc$dftb_dac_sof_61F, '*DFT CANNOT FIND COUNTER VALUE'],
           [dsc$dftb_dac_sof_620, '*DFT CANNOT FIND THRESHOLD VALUE'],
           [dsc$dftb_dac_sof_621, '*DFT DISK STATUS LENGTH EXCEEDED'],
           [dsc$dftb_dac_sof_622, '*SCI DETECTED DFT ERROR WHILE LOADING SSR'],
           [dsc$dftb_dac_sof_623, '*SCI DETECTED DFT ERROR WHILE LOADING VCB'],
           [dsc$dftb_dac_sof_624, '*SCI DETECTED DFT ERROR WHILE HALTING 170 PROCESSOR'],
           [dsc$dftb_dac_sof_625, '*SCI DETECTED DFT ERROR WHILE STARTING VIRTUAL CPU'],
           [dsc$dftb_dac_sof_626, '*SCI DETECTED DFT ERROR WHILE IDLING SECONDARY IOU'],
           [dsc$dftb_dac_sof_627, '*SCI DETECTED DFT ERROR WHILE HALTING VIRTUAL CPU'],
           [dsc$dftb_dac_sof_628, '*SCI DETECTED DFT ERROR WHILE STARTING 170 CPU'],
           [dsc$dftb_dac_sof_629, '*SCI DETECTED DFT ERROR WHILE GETTING ELEMENT DESCR'],
           [dsc$dftb_dac_sof_62A, '*SCI DETECTED DFT NEVER SET VERIFIED FLAG'],
           [dsc$dftb_dac_sof_62B, '*SCI DETECTED DFT SET BUFFER REJECT FLAG'],
           [dsc$dftb_dac_sof_6FF, '*SERVICE PROCESSOR EXECUTIVE ERROR'],
      { OTHER }
           [dsc$dftb_dac_non_701, '*ENVIRONMENT WARNING'],
           [dsc$dftb_dac_non_702, '*LONG POWER WARNING'],
           [dsc$dftb_dac_non_703, '*SHORT POWER WARNING'],
           [dsc$dftb_dac_non_704, '*ENVIRONMENT WARNING CLEAR'],
           [dsc$dftb_dac_non_705, '*LONG POWER WARNING CLEAR'],
           [dsc$dftb_dac_non_706, '*SHORT POWER WARNING CLEAR'],
           [dsc$dftb_dac_non_707, '*TOP OF HOUR MAINFRAME ELEMENT COUNTERS BUFFER'],
           [dsc$dftb_dac_non_708, '*TOP OF HOUR SECDED ID TABLE'],
           [dsc$dftb_dac_non_709, '*LONG POWER WARNING'],
           [dsc$dftb_dac_non_70A, '*LONG POWER WARNING CLEAR']],

    { This variable contains the constant log messages for the system commands: IDLE_SYSTEM, RESUME_SYSTEM,
    { STEP_SYSTEM, UNSTEP_SYSTEM, TERMINATE_SYSTEM.

    v$ic_log_message: [READ, oss$mainframe_paged_literal] ARRAY [1 .. c$number_of_idle_log_messages]
          OF t$ic_log_message_type :=
          [[syc$ic_null,                 ''],
           [syc$ic_system_terminated,    '*Reason: System TERMINATED via OPERATOR COMMAND'],
           [syc$ic_fatal_hardware_error, '*Reason: System ABORTED due to HARDWARE FAILURE'],
           [syc$ic_fatal_software_error, '*Reason: System ABORTED due to SOFTWARE FAILURE'],
           [syc$ic_long_power,           '*Reason: System IDLED due to LONG POWER WARNING'],
           [syc$ic_hardware_idle,        '*Reason: System IDLED due to HARDWARE_IDLE'],
           [syc$ic_idle_command,         '*Reason: System IDLED via OPERATOR COMMAND'],
           [syc$ic_step_command,         '*Reason: System STEPPED via OPERATOR COMMAND'],
           [syc$ic_short_power,          '*Reason: System STEPPED due to SHORT POWER WARNING'],
           [syc$ic_disk_error,           '*Reason: System STEPPED due to DISK ERROR'],
           [syc$ic_software_breakpoint,  '*Reason: System STEPPED due to SOFTWARE SELECTED BREAKPOINT']],

    v$mainframe_name: [STATIC, oss$task_shared] t$mainframe_name_type := [0, ''],

    v$post_operator_actions: [READ, oss$mainframe_paged_literal] ARRAY [dst$signal_poa_kinds] OF
          t$post_operator_actions :=
          [[37, ' The Service Processor has timed out.'],
           [61, ' A change has occurred in the mainframe hardware environment.'],
           [54, ' The System has downed a CPU due to hardware problems.']],

    v$post_operator_actions_part_2: [READ, oss$mainframe_paged_literal] t$post_operator_actions :=
          [90, '  Please contact a CDC Customer Engineer to determine if a maintenance action is required.'],

    { This variable contains the constant log messages for the message created when an element
    { state change occurs.  This information can be obtained from the deck cml$element_state_change.

    v$state_log_message: [READ, oss$mainframe_paged_literal] ARRAY [cmt$element_state] OF
          ARRAY [cmt$element_state] OF t$state_log_message_type :=
     {cmc$on to cmc$on}    [[['*STATE CHANGED FROM ON TO ON',     0],
     {cmc$on to cmc$off}     ['*STATE CHANGED FROM ON TO OFF',    2],
     {cmc$on to cmc$down}    ['*STATE CHANGED FROM ON TO DOWN',   1]],

     {cmc$off to cmc$on}    [['*STATE CHANGED FROM OFF TO ON',    5],
     {cmc$off to cmc$off}    ['*STATE CHANGED FROM OFF TO OFF',   0],
     {cmc$off to cmc$down}   ['*STATE CHANGED FROM OFF TO DOWN',  6]],

     {cmc$down to cmc$on}   [['*STATE CHANGED FROM DOWN TO ON',   3],
     {cmc$down to cmc$off}   ['*STATE CHANGED FROM DOWN TO OFF',  4],
     {cmc$down to cmc$down}  ['*STATE CHANGED FROM DOWN TO DOWN', 0]]];
?? OLDTITLE ??
?? NEWTITLE := 'access_logging_routines', EJECT ??

{ PURPOSE:
{   This procedure calls the appropriate logging routine.

  PROCEDURE access_logging_routines
    (    message_header: dst$system_message_header;
     VAR message_data_p: ^SEQ ( * ));

    VAR
      ignore_status: ost$status,
      message_type_p: ^integer,
      msg_to_log_size: integer,
      sys_msg_to_log_p: ^SEQ ( * );

    RESET message_data_p;
    CASE message_header.message_type OF
    = dsc$disk_errors =
      iop$log_disk_data (message_data_p, ignore_status);
    = dsc$tape_errors =
      iop$log_tape_data (message_data_p, ignore_status);
    = dsc$fs_stornet_errors =
      dfp$log_esm_data (message_data_p, ignore_status);
    = dsc$system_continuation, dsc$system_termination =
      dsp$log_system_message (cml$system_continuation, message_data_p, ignore_status);
    = dsc$general_system_message, dsc$general_du_error =
      IF #SIZE (message_data_p^) > 8 THEN
        NEXT message_type_p IN message_data_p;
        msg_to_log_size := message_header.message_size - #SIZE (message_type_p^);
        IF msg_to_log_size > 0 THEN
          NEXT sys_msg_to_log_p: [[REP msg_to_log_size OF cell]] IN message_data_p;
          dsp$log_system_message (message_type_p^, sys_msg_to_log_p, ignore_status);
        IFEND;
      IFEND;
    ELSE
    CASEND;

  PROCEND access_logging_routines;
?? OLDTITLE ??
?? NEWTITLE := 'cm_channel_identification', EJECT ??

{ PURPOSE:
{   This procedure is called to log the identity of a channel on the mainframe being initialized.
{   The format of the log message is described in the deck cml$channel_identification.

  PROCEDURE cm_channel_identification
    (VAR status: ost$status);

    VAR
      channel: cmt$physical_channel,
      counters_p: sft$counters,
      ignore_status: ost$status,
      message: ost$string,
      number_string: ost$string,
      pc_index: integer,
      temp_string: ost$string;

    status.normal := TRUE;
    PUSH counters_p: [1 .. 2];

    FOR pc_index := 1 TO UPPERBOUND(cmv$physical_configuration^) DO
      IF cmv$physical_configuration^ [pc_index].element_type = cmc$data_channel_element THEN

        { If the physical configuration is a channel then log the data.

        message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
        message.size := v$mainframe_name.size;

        { Retrieve the IOU name associated with the channel.

        message.value ((message.size + 1), 1) := '.';
        message.size := message.size + 1;
        temp_string.value := cmv$physical_configuration^ [pc_index].data_channel.iou;
        set_string_length (temp_string);
        message.value ((message.size + 1), temp_string.size) := temp_string.value;
        message.size := message.size + temp_string.size;

        { Retrieve the channel name.

        channel.number := cmv$physical_configuration^ [pc_index].data_channel.number;
        channel.concurrent := cmv$physical_configuration^ [pc_index].data_channel.concurrent;
        channel.port := cmv$physical_configuration^ [pc_index].data_channel.port;
        clp$convert_integer_to_string (channel.number, 10, FALSE, number_string, ignore_status);

        IF NOT channel.concurrent THEN

          { The channel is a non-concurrent channel.

          message.value ((message.size + 1), 3) := '.CH';
          message.size := message.size + 3;
          message.value ((message.size + 1), number_string.size) := number_string.value;
          message.size := message.size + number_string.size;
          counters_p^ [1] := channel.number;

        ELSE

          { The channel is a concurrent channel.

          message.value ((message.size + 1), 4) := '.CCH';
          message.size := message.size + 4;
          message.value ((message.size + 1), number_string.size) := number_string.value;
          message.size := message.size + number_string.size;
          counters_p^ [1] := channel.number + 100(8);   { Set bit 57 to indicate concurrent channel

          IF channel.port = cmc$port_a THEN

            { The port of the concurrent channel is port A.

            message.value ((message.size + 1), 1) := 'A';
            message.size := message.size + 1;

          ELSEIF channel.port = cmc$port_b THEN

            { The port of the concurrent channel is port B.

            message.value ((message.size + 1), 1) := 'B';
            message.size := message.size + 1;

          IFEND;

        IFEND;

        { Retrieve the type of channel.

        message.value ((message.size + 1), 1) := '*';
        message.size := message.size + 1;
        CASE cmv$physical_configuration^ [pc_index].data_channel.kind OF
        = cmc$170_channel =
          message.value ((message.size + 1), 3) := '170';
          message.size := message.size + 3;
          counters_p^ [2] := 1;
        = cmc$isi_channel =
          message.value ((message.size + 1), 3) := 'ISI';
          message.size := message.size + 3;
          counters_p^ [2] := 2;
        = cmc$ici_channel =
          message.value ((message.size + 1), 3) := 'ICI';
          message.size := message.size + 3;
          counters_p^ [2] := 3;
        = cmc$ipi_channel =
          message.value ((message.size + 1), 3) := 'IPI';
          message.size := message.size + 3;
          counters_p^ [2] := 4;
        ELSE
          message.value ((message.size + 1), 7) := 'UNKNOWN';
          message.size := message.size + 7;
          counters_p^ [2] := 0;
        CASEND;

        { Log the message to the engineering log.

        sfp$emit_statistic (cml$channel_identification, message.value (1, message.size), counters_p, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND cm_channel_identification;
?? OLDTITLE ??
?? NEWTITLE := 'cm_cm_identification', EJECT ??

{ PURPOSE:
{   This procedure is called to log the identity of central memory on the mainframe being
{   initialized.  The format of the log message is described in the deck cml$cm_identification.

  PROCEDURE cm_cm_identification
    (VAR status: ost$status);

    VAR
      element_entry: dst$mf_element_table_entry,
      message: ost$string;

    status.normal := TRUE;

    message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
    message.size := v$mainframe_name.size;
    message.value ((message.size + 1), 15) := '.CENTRAL_MEMORY';
    message.size := message.size + 15;

    { Retrieve the Memory element entry.

    dsp$retrieve_mf_element_entry (0, dsc$dftb_eid_memory_element, element_entry, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Construct the statistic from the mainframe element information.

    message.value ((message.size + 1), 1) := '*';
    message.size := message.size + 1;
    message.value ((message.size + 1), element_entry.model_number_string.size) :=
          element_entry.model_number_string.value;
    message.size := message.size + element_entry.model_number_string.size;

    message.value ((message.size + 1), 1) := '*';
    message.size := message.size + 1;
    message.value ((message.size + 1), element_entry.serial_number_string.size) :=
          element_entry.serial_number_string.value;
    message.size := message.size + element_entry.serial_number_string.size;

    { Log the message to the engineering log.

    sfp$emit_statistic (cml$cm_identification, message.value (1, message.size), NIL, status);

  PROCEND cm_cm_identification;
?? OLDTITLE ??
?? NEWTITLE := 'cm_cp_identification', EJECT ??

{ PURPOSE:
{   This procedure is called to log the identity of a central processor on the mainframe being
{   initialized.  The format of the log message is described in the deck cml$cp_identification.

  PROCEDURE cm_cp_identification
    (VAR status: ost$status);

    VAR
      cpu_index: ost$logical_processor_id,
      element_entry: dst$mf_element_table_entry,
      ignore_status: ost$status,
      message: ost$string,
      number_string: ost$string;

    status.normal := TRUE;

    FOR cpu_index := 0 TO (osv$cpus_physically_configured - 1) DO

      message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
      message.size := v$mainframe_name.size;
      message.value ((message.size + 1), 3) := '.CP';
      message.size := message.size + 3;
      clp$convert_integer_to_string (cpu_index, 10, FALSE, number_string, ignore_status);
      message.value ((message.size + 1), number_string.size) := number_string.value;
      message.size := message.size + number_string.size;

      { Retrieve the CPU element entry.

      dsp$retrieve_mf_element_entry (cpu_index, dsc$dftb_eid_cpu0_element, element_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      { Construct the statistic from the mainframe element information.

      message.value ((message.size + 1), 1) := '*';
      message.size := message.size + 1;
      message.value ((message.size + 1), element_entry.model_number_string.size) :=
            element_entry.model_number_string.value;
      message.size := message.size + element_entry.model_number_string.size;

      message.value ((message.size + 1), 1) := '*';
      message.size := message.size + 1;
      message.value ((message.size + 1), element_entry.serial_number_string.size) :=
            element_entry.serial_number_string.value;
      message.size := message.size + element_entry.serial_number_string.size;

      { Log the message to the engineering log.

      sfp$emit_statistic (cml$cp_identification, message.value (1, message.size), NIL, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    FOREND;

  PROCEND cm_cp_identification;
?? OLDTITLE ??
?? NEWTITLE := 'cm_element_state_change', EJECT ??

{ PURPOSE:
{   This procedure is called to log the change in the state of a system hardware element.
{   The format of the log message is described in the deck cml$element_state_change.

  PROCEDURE cm_element_state_change
    (VAR log_data_p: ^SEQ( * );
     VAR status: ost$status);

    VAR
      counters_p: sft$counters,
      message: ost$string,
      message_data_p: ^dst$log_ele_state_change,
      temp_string: ost$string;

    status.normal := TRUE;
    RESET log_data_p;
    NEXT message_data_p IN log_data_p;

    message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
    message.size := v$mainframe_name.size;

    { Retrieve the name of the mainframe or peripheral hardware
    { element which was the object of the system action.

    temp_string.value := message_data_p^.element_name;
    set_string_length (temp_string);
    message.value ((message.size + 1), 1) := '*';
    message.size := message.size + 1;
    message.value ((message.size + 1), temp_string.size) := temp_string.value;
    message.size := message.size + temp_string.size;

    { Retrieve the identification of the element specified in the active configuration.

    temp_string.value := message_data_p^.product_id.product_number;
    set_string_length (temp_string);
    message.value ((message.size + 1), 1) := '*';
    message.size := message.size + 1;
    message.value ((message.size + 1), temp_string.size) := temp_string.value;
    message.size := message.size + temp_string.size;
    IF message_data_p^.product_id.model_number <> ' ' THEN
      temp_string.value := message_data_p^.product_id.underscore;
      set_string_length (temp_string);
      message.value ((message.size + 1), temp_string.size) := temp_string.value;
      message.size := message.size + temp_string.size;
      temp_string.value := message_data_p^.product_id.model_number;
      set_string_length (temp_string);
      message.value ((message.size + 1), temp_string.size) := temp_string.value;
      message.size := message.size + temp_string.size;
    IFEND;

    { Retrieve the unique identity of the element relative to its
    { product family as specified in the active configuration (in decimal).

    temp_string.value := message_data_p^.serial_number;
    set_string_length (temp_string);
    message.value ((message.size + 1), 1) := '*';
    message.size := message.size + 1;
    message.value ((message.size + 1), temp_string.size) := temp_string.value;
    message.size := message.size + temp_string.size;

    { Retrieve the message string that describes the state change.

    temp_string.value := v$state_log_message [message_data_p^.old_state] [message_data_p^.new_state].value;
    set_string_length (temp_string);
    message.value ((message.size + 1), temp_string.size) := temp_string.value;
    message.size := message.size + temp_string.size;

    PUSH counters_p: [1 .. 2];
    counters_p^ [1] :=
          v$state_log_message [message_data_p^.old_state] [message_data_p^.new_state].counter_value;

    IF message_data_p^.initiator = 'fail' THEN
      counters_p^ [2] := 1;
    ELSEIF message_data_p^.initiator = 'op' THEN
      counters_p^ [2] := 2;
    ELSEIF message_data_p^.initiator = 'ce' THEN
      counters_p^ [2] := 3;
    ELSE
      counters_p^ [2] := 0;
    IFEND;

    { Log the message to the engineering log.

    sfp$emit_statistic (cml$element_state_change, message.value (1, message.size), counters_p, status);

  PROCEND cm_element_state_change;
?? OLDTITLE ??
?? NEWTITLE := 'cm_iou_identification', EJECT ??

{ PURPOSE:
{   This procedure is called to log the identity of an IOU on the mainframe being initialized.
{   The format of the log message is described in the deck cml$iou_identification.

  PROCEDURE cm_iou_identification
    (VAR status: ost$status);

    VAR
      element_entry: dst$mf_element_table_entry,
      ignore_status: ost$status,
      iou_index: dst$number_of_ious,
      iou_information_table: dst$iou_information_table,
      message: ost$string,
      number_of_ious: dst$number_of_ious,
      number_string: ost$string;

    status.normal := TRUE;

    dsp$retrieve_iou_information (number_of_ious, iou_information_table);

    FOR iou_index := 1 TO number_of_ious DO

      message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
      message.size := v$mainframe_name.size;

      clp$convert_integer_to_string (iou_information_table [iou_index].physical_iou_number,
            10, FALSE, number_string, ignore_status);
      message.value ((message.size + 1), 4) := '.IOU';
      message.size := message.size + 4;
      message.value ((message.size + 1), number_string.size) := number_string.value;
      message.size := message.size + number_string.size;

      { Retrieve the IOU element entry.

      dsp$retrieve_mf_element_entry (iou_information_table [iou_index].physical_iou_number,
            dsc$dftb_eid_iou0_element, element_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      { Construct the statistic from the mainframe element information.

      message.value ((message.size + 1), 1) := '*';
      message.size := message.size + 1;
      message.value ((message.size + 1), element_entry.model_number_string.size) :=
            element_entry.model_number_string.value;
      message.size := message.size + element_entry.model_number_string.size;

      message.value ((message.size + 1), 1) := '*';
      message.size := message.size + 1;
      message.value ((message.size + 1), element_entry.serial_number_string.size) :=
            element_entry.serial_number_string.value;
      message.size := message.size + element_entry.serial_number_string.size;

      { Log the message to the engineering log.

      sfp$emit_statistic (cml$iou_identification, message.value (1, message.size), NIL, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    FOREND;

  PROCEND cm_iou_identification;
?? OLDTITLE ??
?? NEWTITLE := 'cm_ms_media_flaw_change', EJECT ??

{ PURPOSE:
{   This procedure is called to log flaw changes on a peripheral storage device.
{   The format of the statistic is described in the deck cml$ms_media_flaw_change.

  PROCEDURE cm_ms_media_flaw_change
    (VAR log_data_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      counters_p: sft$counters,
      daus_per_cylinder: integer,
      element_def_p: ^cmt$element_definition,
      first_phys_adrs: dmt$physical_flaw_address,
      last_phys_adrs: dmt$physical_flaw_address,
      lun: iot$logical_unit,
      message: ost$string,
      message_data_p: ^dmt$log_flaw_init_data,
      physical_attributes_p: ^dmt$physical_device_attributes,
      sector_offset_within_cylinder: integer,
      str_el_1: string (2),
      str_el_2: string (2),
      str_el_3: string (7),
      str_el_4: string (1),
      str: string (80),
      str_length: integer,
      temp_string: ost$string;

    status.normal := TRUE;
    RESET log_data_p;
    NEXT message_data_p IN log_data_p;

    message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
    message.size := v$mainframe_name.size;

    { Obtain the element of the device that the flaw change is on.

    dmp$get_logical_unit_number (message_data_p^.recorded_vsn, lun, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH element_def_p;

    cmp$pc_get_logical_unit (lun, element_def_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Place vsn and element name in the statistic.

    message.value ((message.size + 1), 1) := '.';
    message.size := message.size + 1;
    temp_string.value := element_def_p^.element_name;
    set_string_length (temp_string);
    message.value  ((message.size + 1), temp_string.size) := temp_string.value;
    message.size := message.size + temp_string.size;
    message.value ((message.size + 1), 1) := '*';
    message.size := message.size + 1;
    message.value ((message.size + 1), 6) := message_data_p^.recorded_vsn;
    message.size := message.size + 6;
    message.value ((message.size + 1), 1) := '*';
    message.size := message.size + 1;

    { Set first half of the "MESSAGE" portion of statistic.

    IF message_data_p^.operation_code = dmc$oc_flaw_define THEN
      message.value  ((message.size +1), 21) := 'MEDIA FLAW DEFINED (C';
    ELSE
      message.value  ((message.size +1), 21) := 'MEDIA FLAW REMOVED (C';
    IFEND;
    message.size := message.size + 21;

    { Obtain the starting and ending cylinder, track, and sector address of the flaw from the first and last
    { dau address.

    PUSH physical_attributes_p: [1 .. 4];
    physical_attributes_p^[1].keyword := dmc$maus_per_cylinder;
    physical_attributes_p^[2].keyword := dmc$sectors_per_mau;
    physical_attributes_p^[3].keyword := dmc$sectors_per_track;
    physical_attributes_p^[4].keyword := dmc$maus_per_dau;

    dmp$get_physical_attributes (element_def_p^.product_id, physical_attributes_p, status);

    daus_per_cylinder := physical_attributes_p^[1].maus_per_cylinder DIV
          physical_attributes_p^[4].maus_per_dau;

    { Determine and set first cylinder, track and sector.

    first_phys_adrs.cylinder := message_data_p^.first_dau DIV daus_per_cylinder;
    sector_offset_within_cylinder := (message_data_p^.first_dau MOD daus_per_cylinder) *
          physical_attributes_p^[2].sectors_per_mau * physical_attributes_p^[4].maus_per_dau;
    first_phys_adrs.track := sector_offset_within_cylinder DIV physical_attributes_p^[3].sectors_per_track;
    first_phys_adrs.sector := sector_offset_within_cylinder MOD physical_attributes_p^[3].sectors_per_track;

    { Determine and set last cylinder, track and sector.

    last_phys_adrs.cylinder := message_data_p^.last_dau DIV daus_per_cylinder;
    sector_offset_within_cylinder := ((message_data_p^.last_dau MOD daus_per_cylinder) *
          physical_attributes_p^[2].sectors_per_mau * physical_attributes_p^[4].maus_per_dau) +
          (physical_attributes_p^[4].maus_per_dau * physical_attributes_p^[2].sectors_per_mau) - 1;
    last_phys_adrs.track := sector_offset_within_cylinder DIV physical_attributes_p^[3].sectors_per_track;
    last_phys_adrs.sector := sector_offset_within_cylinder MOD physical_attributes_p^[3].sectors_per_track;

    { Transfer the starting and ending cylinder, track, and sector data into the remainder of the "MESSAGE"
    { portion of statistic.

    str_el_1 (1, 2) := ' T';
    str_el_2 (1, 2) := ' S';
    str_el_3 (1, 7) := ') .. (C';
    str_el_4 (1, 1) := ')';
    STRINGREP (str, str_length, first_phys_adrs.cylinder, str_el_1, first_phys_adrs.track,
         str_el_2, first_phys_adrs.sector, str_el_3, last_phys_adrs.cylinder, str_el_1,
         last_phys_adrs.track, str_el_2,  last_phys_adrs.sector, str_el_4);

    message.value  ((message.size + 1), str_length) := str;
    message.size := message.size + str_length;

    { Set all values for the counter portion of statistic.

    PUSH counters_p: [1 .. 8];
    counters_p^ [1] := message_data_p^.operation_code;
    counters_p^ [2] := message_data_p^.initiator_code;
    counters_p^ [3] := first_phys_adrs.cylinder;
    counters_p^ [4] := first_phys_adrs.track;
    counters_p^ [5] := first_phys_adrs.sector;
    counters_p^ [6] := last_phys_adrs.cylinder;
    counters_p^ [7] := last_phys_adrs.track;
    counters_p^ [8] := last_phys_adrs.sector;

    { Log the message to the engineering log.

    sfp$emit_statistic (cml$ms_media_flaw_change, message.value (1, message.size), counters_p, status);

  PROCEND cm_ms_media_flaw_change;
?? OLDTITLE ??
?? NEWTITLE := 'cm_ms_volume_initialization', EJECT ??

{ PURPOSE:
{   This procedure is called to log the identity of a peripheral storage device which has been
{   initialized.  The format of the log message is described in the deck cml$ms_volume_initialization.

  PROCEDURE cm_ms_volume_initialization
    (VAR log_data_p: ^SEQ( * );
     VAR status: ost$status);

    VAR
      counters_p: sft$counters,
      message: ost$string,
      message_data_p: ^dst$log_ms_volume_init,
      temp_string: ost$string;

    status.normal := TRUE;
    RESET log_data_p;
    NEXT message_data_p IN log_data_p;

    message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
    message.size := v$mainframe_name.size;

    { Retrieve the name of the element specified in the active configuration.

    temp_string.value := message_data_p^.element_name;
    set_string_length (temp_string);
    message.value ((message.size + 1), 1) := '*';
    message.size := message.size + 1;
    message.value ((message.size + 1), temp_string.size) := temp_string.value;
    message.size := message.size + temp_string.size;

    { Retrieve the site_supplied name of the mass storage volume.

    temp_string.value := message_data_p^.recorded_vsn;
    set_string_length (temp_string);
    message.value ((message.size + 1), 1) := '*';
    message.size := message.size + 1;
    message.value ((message.size + 1), temp_string.size) := temp_string.value;
    message.size := message.size + temp_string.size;

    { Retrieve the physical unit number of the storage device on which the volume is currently mounted.

    PUSH counters_p: [1 .. 1];
    counters_p^ [1] := message_data_p^.physical_unit_number;

    { Log the message to the engineering log.

    sfp$emit_statistic (cml$ms_volume_initialization, message.value (1, message.size), counters_p, status);

  PROCEND cm_ms_volume_initialization;
?? OLDTITLE ??
?? NEWTITLE := 'cm_peripheral_identification', EJECT ??

{ PURPOSE:
{   This procedure is called to log the identity of a peripheral in NOS/VE's active configuration.
{   The format of the log message is described in the deck cml$peripheral_identification.

  PROCEDURE cm_peripheral_identification
    (VAR status: ost$status);

    VAR
      counters_p: sft$counters,
      element_state: cmt$element_state,
      iou_name: cmt$element_name,
      message: ost$string,
      pc_index: integer,
      temp_string: ost$string;

    status.normal := TRUE;
    PUSH counters_p: [1 .. 3];

  /channel_loop/
    FOR pc_index := 1 TO UPPERBOUND(cmv$physical_configuration^) DO
      CASE cmv$physical_configuration^ [pc_index].element_type OF
      = cmc$channel_adapter_element =
        counters_p^ [1] := 1;
        counters_p^ [3] := 0;
      = cmc$controller_element =
        counters_p^ [1] := 2;
        counters_p^ [3] := 0;
      = cmc$communications_element, cmc$external_processor_element =
        counters_p^ [1] := 1;
        counters_p^ [3] := 0;
      = cmc$storage_device_element =
        counters_p^ [1] := 3;
        counters_p^ [3] := cmv$physical_configuration^ [pc_index].storage_device.physical_unit_number;
      ELSE
        CYCLE /channel_loop/;
      CASEND;

      { Retrieve the element state of the peripheral.

      iou_name := 'IOU0';
      cmp$get_element_state (cmv$physical_configuration^ [pc_index].element_name, iou_name,
            element_state, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      CASE element_state OF
      = cmc$on =
        counters_p^ [2] := 1;
      = cmc$down =
        counters_p^ [2] := 2;
      = cmc$off =
        counters_p^ [2] := 3;
      CASEND;

      message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
      message.size := v$mainframe_name.size;

      { Retrieve the name of the element specified in the active configuration.

      temp_string.value := cmv$physical_configuration^ [pc_index].element_name;
      set_string_length (temp_string);
      message.value ((message.size + 1), 1) := '.';
      message.size := message.size + 1;
      message.value ((message.size + 1), temp_string.size) := temp_string.value;
      message.size := message.size + temp_string.size;

      { Retrieve the identification of the element specified in the active configuration.

      temp_string.value := cmv$physical_configuration^ [pc_index].product_id.product_number;
      set_string_length (temp_string);
      message.value ((message.size + 1), 1) := '*';
      message.size := message.size + 1;
      message.value ((message.size + 1), temp_string.size) := temp_string.value;
      message.size := message.size + temp_string.size;
      temp_string.value := cmv$physical_configuration^ [pc_index].product_id.underscore;
      set_string_length (temp_string);
      message.value ((message.size + 1), temp_string.size) := temp_string.value;
      message.size := message.size + temp_string.size;
      temp_string.value := cmv$physical_configuration^ [pc_index].product_id.model_number;
      set_string_length (temp_string);
      message.value ((message.size + 1), temp_string.size) := temp_string.value;
      message.size := message.size + temp_string.size;

      { Retrieve the unique identity of the element relative to its product family as specified in the active
      { configuration (in decimal).

      temp_string.value := cmv$physical_configuration^ [pc_index].serial_number;
      set_string_length (temp_string);
      message.value ((message.size + 1), 1) := '*';
      message.size := message.size + 1;
      message.value ((message.size + 1), temp_string.size) := temp_string.value;
      message.size := message.size + temp_string.size;

      { Log the message to the engineering log.

      sfp$emit_statistic (cml$peripheral_identification, message.value (1, message.size), counters_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    FOREND /channel_loop/;

  PROCEND cm_peripheral_identification;
?? OLDTITLE ??
?? NEWTITLE := 'cm_pm_identification', EJECT ??

{ PURPOSE:
{   This procedure is called to log the identity of a page map on the mainframe being
{   initialized.  The format of the log message is described in the deck cml$pm_identification.

  PROCEDURE cm_pm_identification
    (VAR status: ost$status);

    VAR
      element_entry: dst$mf_element_table_entry,
      message: ost$string;

    status.normal := TRUE;

    message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
    message.size := v$mainframe_name.size;
    message.value ((message.size + 1), 9) := '.PAGE_MAP';
    message.size := message.size + 9;

    { Retrieve the PAGE_MAP element entry.

    dsp$retrieve_mf_element_entry (0, dsc$dftb_eid_page_map_element, element_entry, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Construct the statistic from the mainframe element information.

    message.value ((message.size + 1), 1) := '*';
    message.size := message.size + 1;
    message.value ((message.size + 1), element_entry.model_number_string.size) :=
          element_entry.model_number_string.value;
    message.size := message.size + element_entry.model_number_string.size;

    message.value ((message.size + 1), 1) := '*';
    message.size := message.size + 1;
    message.value ((message.size + 1), element_entry.serial_number_string.size) :=
          element_entry.serial_number_string.value;
    message.size := message.size + element_entry.serial_number_string.size;

    { Log the message to the engineering log.

    sfp$emit_statistic (cml$pm_identification, message.value (1, message.size), NIL, status);

  PROCEND cm_pm_identification;
?? OLDTITLE ??
?? NEWTITLE := 'cm_system_deadstart_status', EJECT ??

{ PURPOSE:
{   This procedure is called to log the System Deadstart Status Data from the SSR.

  PROCEDURE cm_system_deadstart_status
    (VAR status: ost$status);

    CONST
      c$number_of_blocks = 4,

      c$information_words = 1,
      c$disk_errors = 2,
      c$mainframe_errors = 3,
      c$nos_or_nbe_words = 4;

    TYPE
      t$mf_error = RECORD
        data: dst$ssr_sds_mf_error_entry,
        link_p: ^t$mf_error,
      RECEND,

      t$header_word = RECORD
        id: 0 .. 0ff(16),
        rfu: 0 .. 0ffffff(16),
        number_of_errors: 0 .. 0ffff(16),
        words_per_block: 0 .. 0ffff(16),
      RECEND;

    VAR
      before_p: ^t$mf_error,
      counters_p: sft$counters,
      data_p: ^t$mf_error,
      disk_error_entry_p: ^dst$ssr_sds_disk_error_entry,
      disk_index: 1 .. dsc$ssr_sds_number_of_disk_errs,
      disk_valid_entries: 0 .. dsc$ssr_sds_number_of_disk_errs,
      entry: 1 .. dsc$ssr_sds_number_of_disk_errs,
      general_info_p: ^dst$ssr_sds_general_info,
      header_word_p: ^t$header_word,
      mainframe_error_entry_p: ^dst$ssr_sds_mf_error_entry,
      message: ost$string,
      mf_errors_p: ^t$mf_error,
      mf_index: 1 .. dsc$ssr_sds_number_of_mf_errors,
      mf_valid_entries: 0 .. dsc$ssr_sds_number_of_mf_errors,
      nos_nbe_words_p: ^dst$ssr_sds_nos_nbe_words,
      possible_counter_size: integer,
      real_counter_size: integer,
      search_p: ^t$mf_error,
      statistic_data_seq_p: ^SEQ ( * ),
      system_deadstart_status: dst$ssr_system_deadstart_status,
      temp_string: ost$string,
      top_mf_errors_p: ^t$mf_error;

    status.normal := TRUE;

    { Retrieve the data from the SSR.

    dsp$retrieve_system_ds_status (system_deadstart_status);

    { Move the top line message and the DFT message to the descriptive data message.

    message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
    message.size := v$mainframe_name.size;
    message.value ((message.size + 1), 1) := '*';
    message.size := message.size + 1;
    temp_string.value := system_deadstart_status.top_line_message;
    set_string_length (temp_string);
    message.value ((message.size + 1), temp_string.size) := temp_string.value;
    message.size := message.size + temp_string.size;
    message.value ((message.size + 1), 1) := '*';
    message.size := message.size + 1;
    temp_string.value := system_deadstart_status.dft_message;
    set_string_length (temp_string);
    message.value ((message.size + 1), temp_string.size) := temp_string.value;
    message.size := message.size + temp_string.size;

    { Decide the possible size of each part of the statistic.

    possible_counter_size := #SIZE (dst$ssr_system_deadstart_status) + (#SIZE (t$header_word) *
          c$number_of_blocks);

    { Create a sequence to use to build the data to place in the counters.

    PUSH statistic_data_seq_p: [[REP possible_counter_size OF cell]];
    RESET statistic_data_seq_p;
    real_counter_size := 0;

    { Add the general information and its header to the sequence.

    NEXT header_word_p IN statistic_data_seq_p;
    real_counter_size := real_counter_size + #SIZE (header_word_p^);
    header_word_p^.id := c$information_words;
    header_word_p^.rfu := 0;
    header_word_p^.number_of_errors := 0;
    header_word_p^.words_per_block := #SIZE (dst$ssr_sds_general_info) DIV 8;
    NEXT general_info_p IN statistic_data_seq_p;
    real_counter_size := real_counter_size + #SIZE (general_info_p^);
    general_info_p^ := system_deadstart_status.general_info;
    convert_date_time_format (system_deadstart_status.general_info.timestamp_of_crash,
          general_info_p^.timestamp_of_crash);

    { Add any valid disk errors and a header to the sequence.  If no errors exists, nothing is added to the
    { sequence.

    IF system_deadstart_status.disk_errors.number_of_valid_entries > 0 THEN
      disk_valid_entries := system_deadstart_status.disk_errors.number_of_valid_entries;
      NEXT header_word_p IN statistic_data_seq_p;
      real_counter_size := real_counter_size + #SIZE (header_word_p^);
      header_word_p^.id := c$disk_errors;
      header_word_p^.rfu := 0;
      header_word_p^.number_of_errors := disk_valid_entries;
      header_word_p^.words_per_block := disk_valid_entries * (#SIZE (dst$ssr_sds_disk_error_entry) DIV 8);
      IF system_deadstart_status.disk_errors.next_available_entry = 1 THEN
        entry := dsc$ssr_sds_number_of_disk_errs;
      ELSE
        entry := system_deadstart_status.disk_errors.next_available_entry - 1;
      IFEND;
      FOR disk_index := 1 TO disk_valid_entries DO
        NEXT disk_error_entry_p IN statistic_data_seq_p;
        real_counter_size := real_counter_size + #SIZE (disk_error_entry_p^);
        disk_error_entry_p^ := system_deadstart_status.disk_errors.entry [entry];
        convert_date_time_format (system_deadstart_status.disk_errors.entry [entry].timestamp,
              disk_error_entry_p^.timestamp);
        IF entry = 1 THEN
          entry := dsc$ssr_sds_number_of_disk_errs;
        ELSE
          entry := entry - 1;
        IFEND;
      FOREND;
    IFEND;

    { Add any valid mainframe errors and a header to the sequence.  If no errors exists, nothing is added to
    { the sequence.

    IF system_deadstart_status.mainframe_errors.number_of_valid_entries > 0 THEN

      { Create a list of the valid mainframe errors, ordering them from top to bottom with the most recent
      { time first.

      PUSH top_mf_errors_p;
      top_mf_errors_p^.link_p := NIL;
      mf_valid_entries := 0;
      FOR mf_index := 1 TO dsc$ssr_sds_number_of_mf_errors DO
        IF system_deadstart_status.mainframe_errors.data [mf_index].valid THEN
          PUSH mf_errors_p;
          mf_valid_entries := mf_valid_entries + 1;
          mf_errors_p^.data := system_deadstart_status.mainframe_errors.data [mf_index].entry;
          before_p := top_mf_errors_p;
          search_p := top_mf_errors_p^.link_p;

         /search_error_links/
          WHILE search_p <> NIL DO
            IF mf_errors_p^.data.timestamp.data >= search_p^.data.timestamp.data THEN
              EXIT /search_error_links/;
            ELSE
              before_p := search_p;
              search_p := search_p^.link_p;
            IFEND;
          WHILEND /search_error_links/;
          mf_errors_p^.link_p := before_p^.link_p;
          before_p^.link_p := mf_errors_p;
        IFEND;
      FOREND;

      IF mf_valid_entries > 0 THEN
        NEXT header_word_p IN statistic_data_seq_p;
        real_counter_size := real_counter_size + #SIZE (header_word_p^);
        header_word_p^.id := c$mainframe_errors;
        header_word_p^.rfu := 0;
        header_word_p^.number_of_errors := mf_valid_entries;
        header_word_p^.words_per_block := mf_valid_entries * (#SIZE (dst$ssr_sds_mf_error_entry) DIV 8);
        data_p := top_mf_errors_p^.link_p;
        WHILE data_p <> NIL DO
          NEXT mainframe_error_entry_p IN statistic_data_seq_p;
          real_counter_size := real_counter_size + #SIZE (mainframe_error_entry_p^);
          mainframe_error_entry_p^ := data_p^.data;
          data_p := data_p^.link_p;
        WHILEND;
      IFEND;
    IFEND;

    { Add the NOS or NBE words and a header to the sequence.

    NEXT header_word_p IN statistic_data_seq_p;
    real_counter_size := real_counter_size + #SIZE (header_word_p^);
    header_word_p^.id := c$nos_or_nbe_words;
    header_word_p^.rfu := 0;
    header_word_p^.number_of_errors := 0;
    header_word_p^.words_per_block := #SIZE (dst$ssr_sds_nos_nbe_words) DIV 8;
    NEXT nos_nbe_words_p IN statistic_data_seq_p;
    real_counter_size := real_counter_size + #SIZE (nos_nbe_words_p^);
    nos_nbe_words_p^ := system_deadstart_status.nos_nbe_words;

    RESET statistic_data_seq_p;
    NEXT counters_p: [1 .. (real_counter_size DIV 8)] IN statistic_data_seq_p;

    { Log the message to the engineering log.

    sfp$emit_statistic (cml$system_deadstart_status, message.value (1, message.size), counters_p, status);

  PROCEND cm_system_deadstart_status;
?? OLDTITLE ??
?? NEWTITLE := 'convert_date_time_format', EJECT ??

{ PURPOSE:
{   This procedure converts a date and time from the OS format of OST$DATE_TIME to the DFT date/time format.

  PROCEDURE convert_date_time_format
    (    input_date_time: dst$ssr_sds_timestamp;
     VAR output_date_time: dst$ssr_sds_timestamp);

    IF input_date_time.word = 0 THEN
      output_date_time.word := 0;
      RETURN;
    IFEND;

    output_date_time.dft.rfu_1 := 0;
    output_date_time.dft.lost_integrity := FALSE;
    output_date_time.dft.tens_of_years := input_date_time.os.year DIV 10;
    output_date_time.dft.units_of_years := input_date_time.os.year MOD 10;
    output_date_time.dft.tens_of_months := input_date_time.os.month DIV 10;
    output_date_time.dft.units_of_months := input_date_time.os.month MOD 10;
    output_date_time.dft.tens_of_days := input_date_time.os.day DIV 10;
    output_date_time.dft.units_of_days := input_date_time.os.day MOD 10;
    output_date_time.dft.tens_of_hours := input_date_time.os.hour DIV 10;
    output_date_time.dft.units_of_hours := input_date_time.os.hour MOD 10;
    output_date_time.dft.tens_of_minutes := input_date_time.os.minute DIV 10;
    output_date_time.dft.units_of_minutes := input_date_time.os.minute MOD 10;
    output_date_time.dft.tens_of_seconds := input_date_time.os.second DIV 10;
    output_date_time.dft.units_of_seconds := input_date_time.os.second MOD 10;
    output_date_time.dft.rfu_2 := 0;

  PROCEND convert_date_time_format;
?? OLDTITLE ??
?? NEWTITLE := 'convert_timestamp_to_string', EJECT ??

{ PURPOSE:
{   This procedure converts a given timestamp into a string.

  PROCEDURE convert_timestamp_to_string
    (    date_time: ost$date_time;
     VAR converted_time: ost$string);

    VAR
      date: ost$date,
      status: ost$status,
      time: ost$time;

    { Format the time part of the time stamp.

    pmp$format_compact_time (date_time, osc$millisecond_time, time, status);
    IF NOT status.normal THEN
      converted_time.value := '';
      converted_time.size := 0;
      RETURN;
    IFEND;

    { Format the date part of the time stamp.

    pmp$format_compact_date (date_time, osc$mdy_date, date, status);
    IF NOT status.normal THEN
      converted_time.value := '';
      converted_time.size := 0;
      RETURN;
    IFEND;

    converted_time.value := 'at              on         ';
    converted_time.value (4, 12) := time.millisecond;
    converted_time.value (20, 8) := date.mdy;
    set_string_length (converted_time);

  PROCEND convert_timestamp_to_string;
?? OLDTITLE ??
?? NEWTITLE := 'dft_add_element_id_information', EJECT ??

{ PURPOSE:
{   This procedure adds the element id information to the message string.

  PROCEDURE dft_add_element_id_information
    (    element_number: dst$dftb_structure_length;
     VAR message: ost$string);

    VAR
      element_entry: dst$mf_element_table_entry,
      element_number_string: ost$string,
      status: ost$status;

    IF element_number <> dsc$dftb_eid_no_known_element THEN
      dsp$retrieve_mf_element_entry ((element_number DIV 16), (element_number MOD 16), element_entry, status);
      IF status.normal THEN
        dft_convert_element_number (element_number, element_number_string);
        message.value ((message.size + 1), element_number_string.size) := element_number_string.value;
        message.size := message.size + element_number_string.size;
        message.value ((message.size + 1), 1) := '*';
        message.size := message.size + 1;
        message.value ((message.size + 1), element_entry.model_number_string.size) :=
              element_entry.model_number_string.value;
        message.size := message.size + element_entry.model_number_string.size;
        message.value ((message.size + 1), 1) := '*';
        message.size := message.size + 1;
        message.value ((message.size + 1), element_entry.serial_number_string.size) :=
              element_entry.serial_number_string.value;
        message.size := message.size + element_entry.serial_number_string.size;
      IFEND;
    IFEND;

  PROCEND dft_add_element_id_information;
?? OLDTITLE ??
?? NEWTITLE := 'dft_convert_element_number', EJECT ??

{ PURPOSE:
{   This procedure converts the element number into a string that HPA/VE expects.

  PROCEDURE dft_convert_element_number
    (    element_number: dst$mf_element_number;
     VAR element_number_string: ost$string);

    CASE element_number OF
    = dsc$dftb_eid_cpu0_element =
      element_number_string.value (1, 4) := '.CP0';
      element_number_string.size := 4;
    = dsc$dftb_eid_cpu1_element =
      element_number_string.value (1, 4) := '.CP1';
      element_number_string.size := 4;
    = dsc$dftb_eid_memory_element =
      element_number_string.value (1, 15) := '.CENTRAL_MEMORY';
      element_number_string.size := 15;
    = dsc$dftb_eid_iou0_element =
      element_number_string.value (1, 5) := '.IOU0';
      element_number_string.size := 5;
    = dsc$dftb_eid_iou1_element =
      element_number_string.value (1, 5) := '.IOU1';
      element_number_string.size := 5;
    = dsc$dftb_eid_page_map_element =
      element_number_string.value (1, 9) := '.PAGE_MAP';
      element_number_string.size := 9;
    ELSE
      element_number_string.value (1, 16) := '.UNKNOWN_ELEMENT';
      element_number_string.size := 16;
    CASEND;

  PROCEND dft_convert_element_number;
?? OLDTITLE ??
?? NEWTITLE := 'dft_log_data', EJECT ??

{ PURPOSE:
{   This procedure builds the statistics and emits them to the engineering log.
{   HPA requires that the counter field does not exceed 255.

  PROCEDURE dft_log_data
    (    control_word: dst$dftb_buffer_control_word;
         standard_dft_analysis_code: dst$dftb_dft_analysis_code;
         statistic_code: sft$statistic_code;
     VAR buffer_data: t$dft_buffer_data);

    CONST
      c$hpa_required_max_counters = 255,

      c$available_counters = (c$hpa_required_max_counters - 2),
      c$counter_block_size = c$hpa_required_max_counters;

    VAR
      block_index: dst$dftb_element_size,
      buffer_data_seq_p: ^SEQ ( * ),
      code_string: ost$string,
      counter_block_header_p: ^dst$dftb_stat_block_header,
      counter_data_seq_p: ^SEQ ( * ),
      counter_seq_p: ^SEQ ( * ),
      counters_p: sft$counters,
      date_and_time: dst$dftb_date_and_time,
      date_and_time_p: ^dst$dftb_date_and_time,
      data_size: 1 .. c$hpa_required_max_counters,
      element_entry: dst$mf_element_table_entry,
      element_number_string: ost$string,
      error_msg: ost$string,
      global_length: dst$dftb_element_size,
      ignore_status: ost$status,
      mdb_data_length_to_log: dst$dftb_element_size,
      mdb_iw_p: ^dst$dftb_mdb_information_word,
      message: ost$string,
      message_index: 1 .. c$number_of_dft_log_messages,
      mrb_group_length_needed: dst$dftb_element_size,
      mrb_type: dst$dftb_structure_length,
      nrb_iw_p: ^dst$dftb_nrb_information_word,
      nrb_data_length_to_log: dst$dftb_element_size,
      number_of_blocks: dst$dftb_element_size,
      skip_cw_p: ^dst$dftb_buffer_control_word,
      ssb_data_length_to_log: dst$dftb_element_size,
      ssb_iw_p: ^dst$dftb_ssb_information_word,
      statistic_block_header: dst$dftb_stat_block_header,
      statistic_buffer_header_p: ^dst$dftb_stat_buffer_header,
      statistic_data_seq_p: ^SEQ ( * ),
      statistic_seq_p: ^SEQ ( * ),
      status: ost$status,
      temp_string: ost$string;

    message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
    message.size := v$mainframe_name.size;

    { Retrieve the global length of the statistic and the date and time for the statistic.

    date_and_time.data := 0;
    global_length := 0;
    IF buffer_data.mrb_seq_p <> NIL THEN

      { The data contains a MRB and possibly a SSB and a MDB.  Round up the actual MRB length to a group size.

      RESET buffer_data.mrb_seq_p;
      IF buffer_data.ssb_seq_p <> NIL THEN
        RESET buffer_data.ssb_seq_p;
        NEXT ssb_iw_p IN buffer_data.ssb_seq_p;
        mrb_type := ssb_iw_p^.mrb_type;
        NEXT date_and_time_p IN buffer_data.ssb_seq_p;
        date_and_time := date_and_time_p^;
        mrb_group_length_needed := ((ssb_iw_p^.logged_mrb_size + dsc$dftb_mr_number_of_registers) DIV
              dsc$dftb_mr_group_size) * dsc$dftb_mr_group_size;
        IF dsv$dftb_data.revision_level <= dsc$dftb_revision_level_4 THEN
          ssb_data_length_to_log := ssb_iw_p^.data_length_to_log - 1;
        ELSE
          ssb_data_length_to_log := ssb_iw_p^.data_length_to_log + 1;
        IFEND;
        global_length := mrb_group_length_needed + 1 + ssb_data_length_to_log + 1;
        dft_add_element_id_information (ssb_iw_p^.element_number, message);
      ELSE
        mrb_type := dsc$dftb_sbt_mrb;
        mrb_group_length_needed := dsv$dftb_data.mrb_length;
        global_length := mrb_group_length_needed + 1;
      IFEND;
      IF buffer_data.mdb_seq_p <> NIL THEN
        RESET buffer_data.mdb_seq_p;
        NEXT mdb_iw_p IN buffer_data.mdb_seq_p;
        mdb_data_length_to_log := mdb_iw_p^.data_length_to_log - 1;
        global_length := global_length + mdb_data_length_to_log + 1;
      IFEND;

    ELSEIF buffer_data.nrb_seq_p <> NIL THEN

      { The data contains a NRB.

      RESET buffer_data.nrb_seq_p;
      NEXT skip_cw_p IN buffer_data.nrb_seq_p;
      NEXT nrb_iw_p IN buffer_data.nrb_seq_p;
      mrb_type := nrb_iw_p^.mrb_type;
      NEXT date_and_time_p IN buffer_data.nrb_seq_p;
      date_and_time := date_and_time_p^;
      IF dsv$dftb_data.revision_level <= dsc$dftb_revision_level_4 THEN
        nrb_data_length_to_log := nrb_iw_p^.data_length_to_log - 2;
      ELSE
        nrb_data_length_to_log := nrb_iw_p^.data_length_to_log + 1;
      IFEND;
      global_length := nrb_data_length_to_log + 1;
      dft_add_element_id_information (nrb_iw_p^.element_number, message);
    IFEND;
    IF global_length = 0 THEN
      RETURN;
    IFEND;

    { Add the message that corresponds to the DFT analysis code to the log message.

   /retrieve_log_message/
    FOR message_index := 1 TO c$number_of_dft_log_messages DO
      IF v$dft_log_message [message_index].dft_analysis_code = standard_dft_analysis_code THEN
        temp_string.value := v$dft_log_message [message_index].value;
        set_string_length (temp_string);
        message.value ((message.size + 1), temp_string.size) := temp_string.value;
        message.size := message.size + temp_string.size;
        EXIT /retrieve_log_message/;
      IFEND;
    FOREND /retrieve_log_message/;

    { Build the statistic block header.

    statistic_block_header.date_and_time := date_and_time.data;
    statistic_block_header.linked_block_follows := FALSE;
    statistic_block_header.block_number := 1;
    statistic_block_header.global_length := global_length;
    statistic_block_header.dft_code_version_number := 0;
    statistic_block_header.dft_interface_version_number := dsv$dftb_data.revision_level;
    statistic_block_header.rfu := 0;
    statistic_block_header.dft_analysis_code := control_word.dft_analysis_code;
    statistic_block_header.sequence_number := control_word.sequence_number;

    { Determine the number of statistic blocks needed to log the message.

    number_of_blocks := (global_length + (c$available_counters - 1)) DIV c$available_counters;
    PUSH statistic_seq_p: [[REP (number_of_blocks * c$available_counters) OF integer]];
    RESET statistic_seq_p;

    { Build the counter data.

    IF buffer_data.mrb_seq_p <> NIL THEN
      NEXT statistic_buffer_header_p IN statistic_seq_p;
      statistic_buffer_header_p^.buffer_length := mrb_group_length_needed + 1;
      statistic_buffer_header_p^.rfu := 0;
      statistic_buffer_header_p^.buffer_type := mrb_type;
      IF mrb_group_length_needed > 0 THEN
        NEXT buffer_data_seq_p: [[REP mrb_group_length_needed OF integer]] IN buffer_data.mrb_seq_p;
        NEXT statistic_data_seq_p: [[REP mrb_group_length_needed OF integer]] IN statistic_seq_p;
        statistic_data_seq_p^ := buffer_data_seq_p^;
      IFEND;

      IF buffer_data.ssb_seq_p <> NIL THEN
        NEXT statistic_buffer_header_p IN statistic_seq_p;
        statistic_buffer_header_p^.buffer_length := ssb_data_length_to_log + 1;
        statistic_buffer_header_p^.rfu := 0;
        statistic_buffer_header_p^.buffer_type := dsc$dftb_sbt_ssb;
        IF ssb_data_length_to_log > 0 THEN
          IF dsv$dftb_data.revision_level > dsc$dftb_revision_level_4 THEN
            RESET buffer_data.ssb_seq_p;
          IFEND;
          NEXT buffer_data_seq_p: [[REP ssb_data_length_to_log OF integer]] IN buffer_data.ssb_seq_p;
          NEXT statistic_data_seq_p: [[REP ssb_data_length_to_log OF integer]] IN statistic_seq_p;
          statistic_data_seq_p^ := buffer_data_seq_p^;
        IFEND;
      IFEND;

      IF buffer_data.mdb_seq_p <> NIL THEN
        NEXT statistic_buffer_header_p IN statistic_seq_p;
        statistic_buffer_header_p^.buffer_length := mdb_data_length_to_log + 1;
        statistic_buffer_header_p^.rfu := 0;
        statistic_buffer_header_p^.buffer_type := dsc$dftb_sbt_mdb;
        IF mdb_data_length_to_log > 0 THEN
          NEXT buffer_data_seq_p: [[REP mdb_data_length_to_log OF integer]] IN buffer_data.mdb_seq_p;
          NEXT statistic_data_seq_p: [[REP mdb_data_length_to_log OF integer]] IN statistic_seq_p;
          statistic_data_seq_p^ := buffer_data_seq_p^;
        IFEND;
      IFEND;

    ELSEIF buffer_data.nrb_seq_p <> NIL THEN
      NEXT statistic_buffer_header_p IN statistic_seq_p;
      statistic_buffer_header_p^.buffer_length := nrb_data_length_to_log + 1;
      statistic_buffer_header_p^.rfu := 0;
      statistic_buffer_header_p^.buffer_type := mrb_type;
      IF nrb_data_length_to_log > 0 THEN
        IF dsv$dftb_data.revision_level > dsc$dftb_revision_level_4 THEN
          RESET buffer_data.nrb_seq_p;
        IFEND;
        NEXT buffer_data_seq_p: [[REP nrb_data_length_to_log OF integer]] IN buffer_data.nrb_seq_p;
        NEXT statistic_data_seq_p: [[REP nrb_data_length_to_log OF integer]] IN statistic_seq_p;
        statistic_data_seq_p^ := buffer_data_seq_p^;
      IFEND;
    ELSE
      RETURN;
    IFEND;

    { Log the registers.

    RESET statistic_seq_p;

    PUSH counter_seq_p: [[REP c$counter_block_size OF integer]];
    FOR block_index := 1 TO number_of_blocks DO
      RESET counter_seq_p;
      NEXT counter_block_header_p IN counter_seq_p;
      counter_block_header_p^ := statistic_block_header;
      counter_block_header_p^.linked_block_follows := (block_index <> number_of_blocks);
      counter_block_header_p^.block_number := block_index;
      IF c$available_counters <= global_length THEN
        data_size := c$available_counters;
        global_length := global_length - c$available_counters;
      ELSE
        data_size := global_length;
      IFEND;
      NEXT statistic_data_seq_p: [[REP data_size OF integer]] IN statistic_seq_p;
      NEXT counter_data_seq_p: [[REP data_size OF integer]] IN counter_seq_p;
      counter_data_seq_p^ := statistic_data_seq_p^;
      RESET counter_seq_p;
      NEXT counters_p: [1 .. (data_size + 2)] IN counter_seq_p;
      sfp$emit_statistic (statistic_code, message.value (1, message.size), counters_p, ignore_status);
      IF NOT ignore_status.normal THEN
        clp$convert_integer_to_string (control_word.dft_analysis_code, 16, FALSE, code_string, ignore_status);
        error_msg.value := ' Not able to log DFT error: ';
        error_msg.value (29, *) := code_string.value;
        error_msg.size := 29 + code_string.size;
        sfp$emit_statistic (cml$system_informative_message, error_msg.value (1, error_msg.size), NIL,
              ignore_status);
      IFEND;
    FOREND;

  PROCEND dft_log_data;
?? OLDTITLE ??
?? NEWTITLE := 'dft_log_failure_data', EJECT ??

{ PURPOSE:
{   This procedure writes information about DFT failure data into the engineering log.

  PROCEDURE dft_log_failure_data
    (    mrb_length: dst$dftb_element_size;
     VAR rb: dst$rb_logging_request);

    VAR
      buffer_data: t$dft_buffer_data,
      hardware_element: dst$dftb_dft_analysis_code,
      standard_dft_analysis_code: dst$dftb_dft_analysis_code,
      statistic_code: sft$statistic_code;

    { The first digit of the dft analysis code describes the hardware element on which the error occurred
    { (IOU, MEMORY, PROCESSOR, NON).  If DFT had detected multiple errors occurring then the leftmost bit
    { of the dft analysis code is set to indicate that multiple errors occur.  This bit is cleared to get
    { the standard DFT analysis code and retrieve the hardware element type.

    hardware_element := rb.dftb_control_word.dft_analysis_code DIV 100(16);
    IF hardware_element > dsc$dftb_mrb_non THEN
      hardware_element := hardware_element - 8;
      standard_dft_analysis_code := rb.dftb_control_word.dft_analysis_code - 800(16);
    ELSE
      standard_dft_analysis_code := rb.dftb_control_word.dft_analysis_code;
    IFEND;

    dft_retrieve_statistic_code (hardware_element, rb.dftb_control_word, statistic_code);

    { Retrieve any existing buffers from the sequence.

    RESET rb.dftb_seq_p;
    buffer_data.mrb_seq_p := NIL;
    buffer_data.ssb_seq_p := NIL;
    buffer_data.mdb_seq_p := NIL;
    buffer_data.nrb_seq_p := NIL;

    { Retrieve the Maintenance Register Buffer from the sequence.

    IF dsc$dds_mrb IN rb.dftb_data_structures THEN
      NEXT buffer_data.mrb_seq_p: [[REP mrb_length OF integer]] IN rb.dftb_seq_p;
      RESET buffer_data.mrb_seq_p;
    IFEND;

    { Retrieve the Supportive Status Buffer from the sequence.

    IF dsc$dds_ssb IN rb.dftb_data_structures THEN
      NEXT buffer_data.ssb_seq_p: [[REP dsv$dftb_data.ssb_length OF integer]] IN rb.dftb_seq_p;
      RESET buffer_data.ssb_seq_p;
    IFEND;

    { Retrieve the Model Dependent Buffer from the sequence.

    IF dsc$dds_mdb IN rb.dftb_data_structures THEN
      NEXT buffer_data.mdb_seq_p: [[REP dsv$dftb_data.mdb_length OF integer]] IN rb.dftb_seq_p;
      RESET buffer_data.mdb_seq_p;
    IFEND;

    { Retrieve the Non Register Buffer from the sequence.

    IF dsc$dds_nrb IN rb.dftb_data_structures THEN
      NEXT buffer_data.nrb_seq_p: [[REP dsv$dftb_data.nrb_length OF integer]] IN rb.dftb_seq_p;
      RESET buffer_data.nrb_seq_p;
    IFEND;

    { Log the counter part of the statistic.

    IF dsv$dftb_data.revision_level <= dsc$dftb_revision_level_3 THEN
      dft_version_3_log_data (mrb_length, rb.dftb_control_word, standard_dft_analysis_code,
            statistic_code, buffer_data);
    ELSE
      dft_log_data (rb.dftb_control_word, standard_dft_analysis_code, statistic_code, buffer_data);
    IFEND;

  PROCEND dft_log_failure_data;
?? OLDTITLE ??
?? NEWTITLE := 'dft_read_eid_register', EJECT ??

{ PURPOSE:
{   This procedure retrieves information from the element identification register (EID).  This information
{   is used on most of the DFT messages written into the engineering log.  The element identification register
{   is described in the 'Maintenance Register Codes Booklet'.

  PROCEDURE dft_read_eid_register
    (    eid_register_input: integer;
     VAR element_message: ost$string);

    VAR
      eid_register: integer,
      element_number: 0 .. 0ff(16),
      ignore_status: ost$status,
      model_number: 0 .. 0ff(16),
      number_string: ost$string,
      serial_number: 0 .. 0ffff(16);

    { Remove the serial number, model number, and element number from the EID register.

    eid_register := eid_register_input;
    serial_number := eid_register MOD 10000(16);
    eid_register := eid_register DIV 10000(16);
    model_number := eid_register MOD 100(16);
    eid_register := eid_register DIV 100(16);
    element_number := eid_register MOD 100(16);

    { Build the log message from the EID register parts.

    dft_convert_element_number (element_number, element_message);

    element_message.value ((element_message.size + 1), 1) := '*';
    element_message.size := element_message.size + 1;
    clp$convert_integer_to_string (model_number, 16, FALSE, number_string, ignore_status);
    element_message.value ((element_message.size + 1), number_string.size) := number_string.value;
    element_message.size := element_message.size + number_string.size;

    element_message.value ((element_message.size + 1), 1) := '*';
    element_message.size := element_message.size + 1;
    clp$convert_integer_to_string (serial_number, 16, FALSE, number_string, ignore_status);
    element_message.value ((element_message.size + 1), number_string.size) := number_string.value;
    element_message.size := element_message.size + number_string.size;

  PROCEND dft_read_eid_register;
?? OLDTITLE ??
?? NEWTITLE := 'dft_retrieve_statistic_code', EJECT ??

{ PURPOSE:
{   This procedure retrieves the statistic code which is based on the DFT analysis code.

  PROCEDURE dft_retrieve_statistic_code
    (    hardware_element: dst$dftb_dft_analysis_code;
         control_word: dst$dftb_buffer_control_word;
     VAR statistic_code: sft$statistic_code);

    IF dsv$dftb_data.revision_level <= dsc$dftb_revision_level_3 THEN
      CASE control_word.dft_analysis_code OF
      = dsc$dftb_dac_non_707 =
        statistic_code := cml$top_of_hour_counters;
      = dsc$dftb_dac_non_708 =
        statistic_code := cml$top_of_hour_secded_id;
      ELSE
        CASE hardware_element OF
        = dsc$dftb_mrb_iou_error =
          statistic_code := cml$iou_failure_data;
        = dsc$dftb_mrb_memory_error =
          statistic_code := cml$memory_failure_data;
        = dsc$dftb_mrb_cpu_error =
          statistic_code := cml$cpu_failure_data;
        = dsc$dftb_mrb_page_map_error =
          statistic_code := cml$page_map_failure_data;
        ELSE
          statistic_code := cml$environment_failure_data;
        CASEND;
      CASEND;
    ELSE
      CASE control_word.dft_analysis_code OF
      = dsc$dftb_dac_non_707 =
        statistic_code := cml$dft_hour_element_counters;
      = dsc$dftb_dac_non_708 =
        statistic_code := cml$dft_hour_secded_id;
      = dsc$dftb_dac_iou_0FF, dsc$dftb_dac_pac_5FF, dsc$dftb_dac_sof_6FF, dsc$dftb_dac_non_709,
            dsc$dftb_dac_non_70A =
        statistic_code := cml$dft_cyber_2000_error;
      ELSE
        CASE hardware_element OF
        = dsc$dftb_mrb_iou_error =
          statistic_code := cml$dft_iou_failure_data;
        = dsc$dftb_mrb_memory_error =
          statistic_code := cml$dft_memory_failure_data;
        = dsc$dftb_mrb_cpu_error =
          statistic_code := cml$dft_cpu_failure_data;
        = dsc$dftb_mrb_page_map_error =
          statistic_code := cml$dft_page_map_failure_data;
        = dsc$dftb_mrb_bad_requests =
          statistic_code := cml$dft_non_crit_failure_data;
        = dsc$dftb_mrb_packet_error, dsc$dftb_mrb_software_error =
          statistic_code := cml$dft_critical_failure_data;
        ELSE
          statistic_code := cml$dft_power_failure_data;
        CASEND;
      CASEND;
    IFEND;

  PROCEND dft_retrieve_statistic_code;
?? OLDTITLE ??
?? NEWTITLE := 'dft_version_3_log_data', EJECT ??

{ PURPOSE:
{   This procedure uses the version 3 statistics to log the data to the engineering log.

  PROCEDURE dft_version_3_log_data
    (    mrb_length: dst$dftb_element_size;
         control_word: dst$dftb_buffer_control_word;
         standard_dft_analysis_code: dst$dftb_dft_analysis_code;
         statistic_code: sft$statistic_code;
     VAR buffer_data: t$dft_buffer_data);

    VAR
      counters_p: sft$counters,
      eid_register_p: ^integer,
      ignore_status: ost$status,
      iou_information_table: dst$iou_information_table,
      message: ost$string,
      message_index: 1 .. c$number_of_dft_log_messages,
      mrb_buffer_index: dst$dftb_structure_length,
      mrb_buffer_word_p: ^integer,
      number_of_ious: dst$number_of_ious,
      register_count: dst$dftb_structure_length,
      register_group_index: dst$dftb_structure_length,
      register_group_p: ^dst$dftb_maintenance_registers,
      register_index: 1 .. dsc$dftb_mr_number_of_registers,
      skip_word_p: ^integer,
      temp_string: ost$string;

    IF buffer_data.mrb_seq_p = NIL THEN
      RETURN;
    IFEND;

    message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
    message.size := v$mainframe_name.size;

    { Retrieve the element identification information from the EID register.

    CASE control_word.dft_analysis_code OF
    = dsc$dftb_dac_non_707 =

    = dsc$dftb_dac_non_708 =

    { The EID register is the second word in the MRB for the SECDED id table.

      NEXT skip_word_p IN buffer_data.mrb_seq_p;
      NEXT eid_register_p IN buffer_data.mrb_seq_p;
      dft_read_eid_register (eid_register_p^, temp_string);
      message.value ((message.size + 1), temp_string.size) := temp_string.value;
      message.size := message.size + temp_string.size;

    ELSE

      { Search for the EID register in the MRB.

     /retrieve_eid_information/
      FOR register_group_index := 1 TO (mrb_length DIV dsc$dftb_mr_group_size) DO
        NEXT register_group_p IN buffer_data.mrb_seq_p;
        FOR register_index := 1 TO dsc$dftb_mr_number_of_registers DO
          IF (register_group_p^.register_header [register_index].register_number = c$eid_register_number) THEN
            dft_read_eid_register (register_group_p^.register_list [register_index], temp_string);
            message.value ((message.size + 1), temp_string.size) := temp_string.value;
            message.size := message.size + temp_string.size;
            EXIT /retrieve_eid_information/;
          IFEND;
        FOREND;
      FOREND /retrieve_eid_information/;

    CASEND;
    RESET buffer_data.mrb_seq_p;

    { Add the constant message to the log message.

   /retrieve_log_message/
    FOR message_index := 1 TO c$number_of_dft_log_messages DO
      IF v$dft_log_message [message_index].dft_analysis_code = standard_dft_analysis_code THEN
        temp_string.value := v$dft_log_message [message_index].value;
        set_string_length (temp_string);
        message.value ((message.size + 1), temp_string.size) := temp_string.value;
        message.size := message.size + temp_string.size;
        EXIT /retrieve_log_message/;
      IFEND;
    FOREND /retrieve_log_message/;

    { Count the number of mrb buffer words to log.

    CASE control_word.dft_analysis_code OF

    = dsc$dftb_dac_non_707 =

      dsp$retrieve_iou_information (number_of_ious, iou_information_table);
      IF iou_information_table [1].model_type = dsc$imn_i0_5x_model THEN
        register_count := dsc$dftb_mec_s0_counters;
      ELSE
        register_count := dsc$dftb_mec_non_s0_counters;
      IFEND;

    = dsc$dftb_dac_non_708 =
      register_count := dsv$dftb_data.secded_id_table_length + 2;

    ELSE

      { The entire buffer is searched for the last non-zero buffer word.

      RESET buffer_data.mrb_seq_p;
      register_count := 0;
      FOR mrb_buffer_index := 1 TO mrb_length DO
        NEXT mrb_buffer_word_p IN buffer_data.mrb_seq_p;
        IF mrb_buffer_word_p^ <> 0 THEN
          register_count := mrb_buffer_index;
        IFEND;
      FOREND;

      { Round up the register count to the size of the group.

      register_count := ((register_count + dsc$dftb_mr_number_of_registers) DIV
            dsc$dftb_mr_group_size) * dsc$dftb_mr_group_size;
    CASEND;

    { Log the registers.

    PUSH counters_p: [1 .. (register_count + 2)];
    counters_p^ [1] := control_word.os_action_code;
    counters_p^ [2] := (control_word.dft_analysis_code * 100(16)) + control_word.sequence_number;
    RESET buffer_data.mrb_seq_p;
    FOR mrb_buffer_index := 1 TO register_count DO
      NEXT mrb_buffer_word_p IN buffer_data.mrb_seq_p;
      counters_p^ [mrb_buffer_index + 2] := mrb_buffer_word_p^;
    FOREND;

    { Log the message to the engineering log.

    sfp$emit_statistic (statistic_code, message.value (1, message.size), counters_p, ignore_status);

  PROCEND dft_version_3_log_data;
?? OLDTITLE ??
?? NEWTITLE := 'establish_sys_msgs_stats', EJECT ??

{ PURPOSE:
{   This procedure is called right before logging is allowed during deadstart to establish
{   the system message statistics.

  PROCEDURE establish_sys_msgs_stats;

    CONST
      c$number_of_statistics = 39;

    VAR
      ignore_status: ost$status,
      statistics: array [1 .. c$number_of_statistics] of sft$statistic_code,
      statistic_index: 1 .. c$number_of_statistics;

    { Set up the statistic codes for the DFT messages.

    statistics [01] := cml$cpu_failure_data;
    statistics [02] := cml$environment_failure_data;
    statistics [03] := cml$iou_failure_data;
    statistics [04] := cml$memory_failure_data;
    statistics [05] := cml$page_map_failure_data;
    statistics [06] := cml$dft_top_of_hour;
    statistics [07] := cml$top_of_hour_counters;
    statistics [08] := cml$top_of_hour_secded_id;

    statistics [09] := cml$dft_cpu_failure_data;
    statistics [10] := cml$dft_critical_failure_data;
    statistics [11] := cml$dft_cyber_2000_error;
    statistics [12] := cml$dft_hour_element_counters;
    statistics [13] := cml$dft_hour_secded_id;
    statistics [14] := cml$dft_iou_failure_data;
    statistics [15] := cml$dft_memory_failure_data;
    statistics [16] := cml$dft_non_crit_failure_data;
    statistics [17] := cml$dft_page_map_failure_data;
    statistics [18] := cml$dft_power_failure_data;
    statistics [19] := cml$dft_top_of_hour;

    { Set up the statistic codes for the Configuration Management messages.

    statistics [20] := cml$channel_identification;
    statistics [21] := cml$cm_identification;
    statistics [22] := cml$connection_disabled;
    statistics [23] := cml$cp_identification;
    statistics [24] := cml$element_disabled;
    statistics [25] := cml$element_state_change;
    statistics [26] := cml$iou_identification;
    statistics [27] := cml$ms_volume_initialization;
    statistics [28] := cml$ms_media_flaw_change;
    statistics [29] := cml$peripheral_identification;
    statistics [30] := cml$pm_identification;
    statistics [31] := cml$system_deadstart_status;

    { Set up the statistic code for the system informative message.

    statistics [32] := cml$system_informative_message;

    { Set up the statistic code for the system termination and continuation messages.

    statistics [33] := cml$system_termination;
    statistics [34] := cml$system_continuation;

    { Set up the statistic code for the PP timed out message.

    statistics [35] := cml$pp_timed_out;

    { Set up the job recovery statistics and the system error statistic.

    statistics [36] := cml$system_error;
    statistics [37] := cml$job_recovery_totals;
    statistics [38] := cml$job_recovery_failure;

    { Set up the statistic code for the PP hung message.

    statistics [39] := cml$pp_hung;

    FOR statistic_index := 1 TO c$number_of_statistics DO
      sfp$activate_system_statistic (statistics [statistic_index], $sft$binary_logset [pmc$engineering_log],
            ignore_status);
    FOREND;

  PROCEND establish_sys_msgs_stats;
?? OLDTITLE ??
?? NEWTITLE := 'get_mainframe_name', EJECT ??

{ PURPOSE:
{   This procedure retrieves the name of the mainframe.

  PROCEDURE get_mainframe_name;

    VAR
      mainframe_id: pmt$mainframe_id,
      status: ost$status;

    pmp$get_mainframe_id (mainframe_id, status);
    IF NOT status.normal THEN
      v$mainframe_name.value := 'UNKNOWN MAINFRAME NAME';
    ELSE
      v$mainframe_name.value := mainframe_id;
    IFEND;
    v$mainframe_name.size := STRLENGTH (v$mainframe_name.value);
    WHILE v$mainframe_name.value (v$mainframe_name.size) = ' ' DO
      v$mainframe_name.size := v$mainframe_name.size - 1;
    WHILEND;

  PROCEND get_mainframe_name;
?? OLDTITLE ??
?? NEWTITLE := 'os_log_system_control_data', EJECT ??

{ PURPOSE:
{   This procedure logs a message to the engineering log for the following system commands: IDLE_SYSTEM,
{   RESUME_SYSTEM, STEP_SYSTEM, UNSTEP_SYSTEM, TERMINATE_SYSTEM.  The message states whether the system
{   was terminated or continued.  The format of the log messages are described in the decks
{   cml$system_continuation and cml$system_termination.

  PROCEDURE os_log_system_control_data
    (VAR data_to_log_p: ^SEQ( * );
     VAR status: ost$status);

    VAR
      message: ost$string,
      message_index: 1 .. c$number_of_idle_log_messages,
      statistic_code: sft$statistic_code,
      temp_string: ost$string,
      terminate_continue_message_p: ^ost$terminate_continue_record;

    status.normal := TRUE;
    IF NOT jmv$executing_within_system_job THEN
      RETURN;
    IFEND;

    RESET data_to_log_p;
    NEXT terminate_continue_message_p IN data_to_log_p;

    message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
    message.size := v$mainframe_name.size;
    message.value ((message.size + 1), 1) := '*';
    message.size := message.size + 1;
    message.value ((message.size + 1), terminate_continue_message_p^.log_message.size) :=
          terminate_continue_message_p^.log_message.value;
    message.size := message.size + terminate_continue_message_p^.log_message.size;

    convert_timestamp_to_string (terminate_continue_message_p^.date_time, temp_string);
    message.value ((message.size + 1), 1) := ' ';
    message.size := message.size + 1;
    message.value ((message.size + 1), temp_string.size) := temp_string.value;
    message.size := message.size + temp_string.size;

    { Retrieve the associated log message for the log reason.

    IF terminate_continue_message_p^.log_reason <> syc$ic_null THEN

     /retrieve_log_message/
      FOR message_index := 1 TO c$number_of_idle_log_messages DO
        IF v$ic_log_message [message_index].idle_code = terminate_continue_message_p^.log_reason THEN
          temp_string.value := v$ic_log_message [message_index].value;
          set_string_length (temp_string);
          message.value ((message.size + 1), temp_string.size) := temp_string.value;
          message.size := message.size + temp_string.size;
          EXIT /retrieve_log_message/;
        IFEND;
      FOREND /retrieve_log_message/;
    IFEND;

    { Get the correct statistic code for the log message.

    CASE terminate_continue_message_p^.log_statistic OF
    = osc$idle_statistic, osc$step_statistic, osc$terminate_statistic =
      statistic_code := cml$system_termination;
    = osc$unstep_statistic, osc$resume_statistic =
      statistic_code := cml$system_continuation;
    ELSE
    CASEND;

    { Log the message to the engineering log.

    sfp$emit_statistic (statistic_code, message.value (1, message.size), NIL, status);

  PROCEND os_log_system_control_data;
?? OLDTITLE ??
?? NEWTITLE := 'os_log_system_error', EJECT ??

{ PURPOSE:
{   This procedure logs a message from a call to osp$system_error.

  PROCEDURE os_log_system_error
    (VAR data_to_log_p: ^SEQ( * );
     VAR status: ost$status);

    CONST
      c$p_address_information = 1;

    TYPE
      t$header_word = RECORD
        id: 0 .. 0ff(16),
        rfu: 0 .. 0ffffffffff(16),
        words_per_block: 0 .. 0ffff(16),
      RECEND;

    VAR
      counters_p: sft$counters,
      header_word_p: ^t$header_word,
      message: ost$string,
      p_address_index: 1 .. osc$stacks_to_display,
      p_address_p: ^integer,
      statistic_data_seq_p: ^SEQ ( * ),
      system_error_data_p: ^ost$system_error_statistic,
      temp_string: ost$string;

    status.normal := TRUE;

    RESET data_to_log_p;
    NEXT system_error_data_p IN data_to_log_p;

    message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
    message.size := v$mainframe_name.size;
    message.value ((message.size + 1), 1) := '*';
    message.size := message.size + 1;
    temp_string.value := system_error_data_p^.text;
    set_string_length (temp_string);
    message.value ((message.size + 1), temp_string.size) := temp_string.value;
    message.size := message.size + temp_string.size;

    PUSH statistic_data_seq_p: [[REP (#SIZE (system_error_data_p^) + #SIZE (t$header_word)) OF cell]];
    RESET statistic_data_seq_p;

    NEXT header_word_p IN statistic_data_seq_p;
    header_word_p^.id := c$p_address_information;
    header_word_p^.rfu := 0;
    header_word_p^.words_per_block := osc$stacks_to_display;

    FOR p_address_index := 1 TO osc$stacks_to_display DO
      NEXT p_address_p IN statistic_data_seq_p;
      p_address_p^ := system_error_data_p^.counter [p_address_index];
    FOREND;

    { Log the message to the engineering log.

    RESET statistic_data_seq_p;
    NEXT counters_p: [1 .. (osc$stacks_to_display + 1)] IN statistic_data_seq_p;
    sfp$emit_statistic (cml$system_error, message.value (1, message.size), counters_p, status);

  PROCEND os_log_system_error;
?? OLDTITLE ??
?? NEWTITLE := 'os_pp_hung', EJECT ??

{ PURPOSE:
{   This procedure logs a message to the engineering log when monitor detects that a PP has hung.
{   The message states which PP has hung.

  PROCEDURE os_pp_hung
    (VAR data_to_log_p: ^SEQ( * ));

    VAR
      counters_p: sft$counters,
      data_string: ost$string,
      hung_pp_data_p: ^dst$log_hung_pp_data,
      ignore_status: ost$status,
      message: ost$string;

    IF (data_to_log_p = NIL) OR (#SIZE (dst$log_hung_pp_data) > #SIZE (data_to_log_p^)) THEN
      RETURN;
    IFEND;
    RESET data_to_log_p;
    NEXT hung_pp_data_p IN data_to_log_p;
    IF hung_pp_data_p = NIL THEN
      RETURN;
    IFEND;

    message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
    message.size := v$mainframe_name.size;
    message.value ((message.size + 1), 4) := '.IOU';
    message.size := message.size + 4;
    clp$convert_integer_to_string (hung_pp_data_p^.pp.iou_number, 10, FALSE, data_string, ignore_status);
    message.value ((message.size + 1), data_string.size) := data_string.value;
    message.size := message.size + data_string.size;

    IF hung_pp_data_p^.channel.channel_protocol = dsc$cpt_cio THEN
      message.value ((message.size + 1), 4) := '.CCH';
      message.size := message.size + 4;
    ELSE
      message.value ((message.size + 1), 3) := '.CH';
      message.size := message.size + 3;
    IFEND;
    clp$convert_integer_to_string (hung_pp_data_p^.channel.number, 8, TRUE, data_string, ignore_status);
    message.value ((message.size + 1), data_string.size) := data_string.value;
    message.size := message.size + data_string.size;

    IF hung_pp_data_p^.pp.channel_protocol = dsc$cpt_cio THEN
      message.value ((message.size + 1), 4) := '.CPP';
      message.size := message.size + 4;
    ELSE
      message.value ((message.size + 1), 3) := '.PP';
      message.size := message.size + 3;
    IFEND;
    clp$convert_integer_to_string (hung_pp_data_p^.pp.number, 8, TRUE, data_string, ignore_status);
    message.value ((message.size + 1), data_string.size) := data_string.value;
    message.size := message.size + data_string.size;

    message.value ((message.size + 1), 22) := ' HUNG - RELOAD OF PP (';
    message.size := message.size + 22;
    data_string.value := hung_pp_data_p^.driver_name;
    set_string_length (data_string);
    message.value ((message.size + 1), data_string.size) := data_string.value;
    message.size := message.size + data_string.size;
    message.value ((message.size + 1), 11) := ') INITIATED';
    message.size := message.size + 11;

    PUSH counters_p: [1 .. 6];
    IF counters_p = NIL THEN
      RETURN;
    IFEND;
    IF hung_pp_data_p^.pp_hung_on_one_instruction THEN
      counters_p^ [1] := 1;
    ELSE
      counters_p^ [1] := 2;
    IFEND;
    counters_p^ [2] := hung_pp_data_p^.pp_registers.p_register;
    counters_p^ [3] := hung_pp_data_p^.pp_registers.k_register;
    counters_p^ [4] := hung_pp_data_p^.pp_registers.q_register;
    counters_p^ [5] := hung_pp_data_p^.pp_registers.a_register;
    counters_p^ [6] := hung_pp_data_p^.r_register;

    { Log the message to the engineering log.

    sfp$emit_statistic (cml$pp_hung, message.value (1, message.size), counters_p, ignore_status);

  PROCEND os_pp_hung;
?? OLDTITLE ??
?? NEWTITLE := 'os_pp_timed_out', EJECT ??

{ PURPOSE:
{   This procedure logs a message to the engineering log when monitor detects that a PP has timed
{   out (ie. no longer responding to CPU/PP handshaking).  The message states which PP has timed
{   out.  The format of the log message is described in the deck cml$pp_timed_out.

  PROCEDURE os_pp_timed_out
    (VAR data_to_log_p: ^SEQ( * ));

    VAR
      converted_time: ost$string,
      local_status: ost$status,
      message: ost$string,
      pp_timed_out_p: ^dst$log_pp_timed_out;

    RESET data_to_log_p;
    NEXT pp_timed_out_p IN data_to_log_p;

    message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
    message.size := v$mainframe_name.size;
    message.value ((message.size + 1), 11) := '*VE0S6000- ';
    message.size := message.size + 11;
    message.value ((message.size + 1), #SIZE (pp_timed_out_p^.pp_name)) := pp_timed_out_p^.pp_name;
    message.size := message.size + #SIZE (pp_timed_out_p^.pp_name);
    message.value ((message.size + 1), 10) := ' TIMED OUT';
    message.size := message.size + 10;

    { Convert the saved timestamp to a string that can be added to the log message.

    convert_timestamp_to_string (pp_timed_out_p^.date_time, converted_time);
    message.value ((message.size + 1), 1) := ' ';
    message.size := message.size + 1;
    message.value ((message.size + 1), converted_time.size) := converted_time.value;
    message.size := message.size + converted_time.size;
    message.value ((message.size + 1), 1) := '.';
    message.size := message.size + 1;

    { Log the message to the engineering log.

    sfp$emit_statistic (cml$pp_timed_out, message.value (1, message.size), NIL, local_status);

  PROCEND os_pp_timed_out;
?? OLDTITLE ??
?? NEWTITLE := 'post_operator_action', EJECT ??

{ PURPOSE:
{   This procedure puts a message in the operator action window.

  PROCEDURE post_operator_action
    (    signal_entry: dst$signal_contents_entry);

    VAR
      date: ost$date,
      local_status: ost$status,
      message: string (ofc$max_operator_message_size),
      message_size: 0 .. ofc$max_operator_message_size,
      response: ost$string,
      time: ost$time;

    message := ' ';
    message_size := 0;

    pmp$format_compact_time (signal_entry.poa_data.date_time, osc$hms_time, time, local_status);
    IF local_status.normal THEN
      message ((message_size + 1), 8) := time.hms;
      message_size := message_size + 9;
    IFEND;

    pmp$format_compact_date (signal_entry.poa_data.date_time, osc$mdy_date, date, local_status);
    IF local_status.normal THEN
      message ((message_size + 1), 8) := date.mdy;
      message_size := message_size + 9;
    IFEND;

    message ((message_size + 1), v$post_operator_actions [signal_entry.poa_data.kind].size) :=
          v$post_operator_actions [signal_entry.poa_data.kind].value;
    message_size := message_size + v$post_operator_actions [signal_entry.poa_data.kind].size;
    pmp$log_ascii (message (1, message_size), $pmt$ascii_logset [pmc$system_log, pmc$job_log],
          pmc$msg_origin_system, local_status);
    message ((message_size + 1), v$post_operator_actions_part_2.size) := v$post_operator_actions_part_2.value;
    message_size := message_size + v$post_operator_actions_part_2.size;
    ofp$send_operator_message (message (1, message_size), ofc$system_operator, TRUE, local_status);
    IF local_status.normal THEN
      ofp$receive_operator_response (ofc$system_operator, osc$wait, response, local_status);
    IFEND;

  PROCEND post_operator_action;
?? OLDTITLE ??
?? NEWTITLE := 'process_hung_pp', EJECT ??

{ PURPOSE:
{   This procedure processes the hung PPs that are not processed in monitor.  If the detected hung PP does
{   not support handshaking or reload then a message is sent to the operator action window.  Otherwise the
{   correct routine is called.

  PROCEDURE process_hung_pp
    (    pp_entry: cmt$logical_pp_table_entry;
         input_message: ost$string);

    VAR
      channel_element_p: ^cmt$element_definition,
      channel_name: cmt$element_name,
      channel_ordinal: cmt$channel_ordinal,
      concurrent: boolean,
      element_name: cmt$element_name,
      element_p: ^cmt$element_definition,
      iou_name: cmt$element_name,
      index: cmt$physical_equipment_number,
      local_status: ost$status,
      state: cmt$element_state,
      valid: boolean;

    IF NOT pp_entry.flags.pp_handshaking_supported THEN
      process_hung_pp_message (c$hpmt_no_handshaking, pp_entry, input_message, local_status);
      RETURN;
    IFEND;
    IF NOT pp_entry.flags.pp_reload_supported THEN
      process_hung_pp_message (c$hpmt_no_reload, pp_entry, input_message, local_status);
      RETURN;
    IFEND;

    IF pp_entry.pp_info.pp_type = cmc$lpt_network_pp_type THEN
      concurrent := (pp_entry.pp_info.channel.channel_protocol = dsc$cpt_cio);
      cmp$convert_channel_number (pp_entry.pp_info.channel.number, concurrent, pp_entry.pp_info.channel_port,
            channel_ordinal, channel_name, valid);
      IF NOT valid THEN
        process_hung_pp_message (c$hpmt_invalid_channel, pp_entry, input_message, local_status);
        RETURN;
      IFEND;
      cmp$convert_iou_number (pp_entry.pp_info.channel.iou_number, iou_name, local_status);
      IF NOT local_status.normal THEN
        process_hung_pp_message (c$hpmt_bad_status, pp_entry, input_message, local_status);
        RETURN;
      IFEND;
      cmp$pc_get_element (channel_name, iou_name, channel_element_p, local_status);
      IF NOT local_status.normal THEN
        process_hung_pp_message (c$hpmt_bad_status, pp_entry, input_message, local_status);
        RETURN;
      IFEND;

     /equipment_loop/
      FOR index := LOWERVALUE (cmt$physical_equipment_number) TO UPPERVALUE (cmt$physical_equipment_number) DO
        IF NOT channel_element_p^.data_channel.connection.equipment [index].configured THEN
          CYCLE /equipment_loop/;
        IFEND;

        element_name := channel_element_p^.data_channel.connection.equipment [index].element_name;
        cmp$pc_get_element (element_name, iou_name, element_p, local_status);
        IF NOT local_status.normal THEN
          process_hung_pp_message (c$hpmt_bad_status, pp_entry, input_message, local_status);
          RETURN;
        IFEND;

        cmp$get_element_state (element_name, iou_name, state, local_status);
        IF NOT local_status.normal THEN
          process_hung_pp_message (c$hpmt_bad_status, pp_entry, input_message, local_status);
          RETURN;
        IFEND;
        IF state <> cmc$on THEN
          CYCLE /equipment_loop/;
        IFEND;

        nap$reload_network_pp (element_name, local_status);
        IF NOT local_status.normal THEN
          process_hung_pp_message (c$hpmt_bad_status, pp_entry, input_message, local_status);
          RETURN;
        IFEND;
      FOREND /equipment_loop/;
    IFEND;

  PROCEND process_hung_pp;
?? OLDTITLE ??
?? NEWTITLE := 'process_hung_pp_from_mtr', EJECT ??

{ PURPOSE:
{   This procedure processes the hung PPs that are not processed in monitor.  If the detected hung PP does
{   not support handshaking or reload then a message is sent to the operator action window.  Otherwise the
{   correct routine is called.

  PROCEDURE process_hung_pp_from_mtr
    (    signal_entry: dst$signal_contents_entry);

    VAR
      date: ost$date,
      index: iot$pp_number,
      local_status: ost$status,
      message: ost$string,
      number_string: ost$string,
      response: ost$string,
      time: ost$time;

    message.value := ' ';
    message.size := 0;
    pmp$format_compact_time (signal_entry.poa_data.date_time, osc$hms_time, time, local_status);
    IF local_status.normal THEN
      message.value ((message.size + 1), 8) := time.hms;
      message.size := message.size + 9;
    IFEND;
    pmp$format_compact_date (signal_entry.poa_data.date_time, osc$mdy_date, date, local_status);
    IF local_status.normal THEN
      message.value ((message.size + 1), 8) := date.mdy;
      message.size := message.size + 9;
    IFEND;

    IF signal_entry.hpp_data.sci_reload_failed THEN
      message.value ((message.size + 1), 35) := 'The Automatic Reload of the SCI PP ';
      message.size := message.size + 35;
      CASE dsv$automatic_pp_reload.iou_model_type [0] OF
      = dsc$imn_i4_44_model, dsc$imn_i4_46_model =
        message.value ((message.size + 1), 4) := '(CPP';
        message.size := message.size + 4;
      ELSE
        message.value ((message.size + 1), 3) := '(PP';
        message.size := message.size + 3;
      CASEND;
      clp$convert_integer_to_string (dsv$cpu_pp_communication_block.relocation.sci_pp_number, 8, TRUE,
            number_string, local_status);
      message.value ((message.size + 1), number_string.size) := number_string.value;
      message.size := message.size + number_string.size;
      message.value ((message.size + 1), 52) := ') failed.  The system console will not be available.';
      message.size := message.size + 52;
      pmp$log_ascii (message.value (1, message.size), $pmt$ascii_logset [pmc$system_log, pmc$job_log],
            pmc$msg_origin_system, local_status);
      ofp$send_operator_message (message.value (1, message.size), ofc$system_operator, TRUE, local_status);
      IF local_status.normal THEN
        ofp$receive_operator_response (ofc$system_operator, osc$wait, response, local_status);
      IFEND;
      RETURN;
    IFEND;

    IF signal_entry.hpp_data.check_entire_table THEN
      FOR index := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
        IF cmv$logical_pp_table_p^ [index].flags.configured AND
              cmv$logical_pp_table_p^ [index].flags.resources_acquired AND
              cmv$logical_pp_table_p^ [index].flags.pp_loaded AND
              cmv$logical_pp_table_p^ [index].flags.pp_hung AND
              NOT cmv$logical_pp_table_p^ [index].flags.pp_handshaking_supported THEN
          process_hung_pp (cmv$logical_pp_table_p^ [index], message);
        IFEND;
      FOREND;
    ELSE
      process_hung_pp (cmv$logical_pp_table_p^ [signal_entry.hpp_data.logical_pp_index], message);
    IFEND;

  PROCEND process_hung_pp_from_mtr;
?? OLDTITLE ??
?? NEWTITLE := 'process_hung_pp_message', EJECT ??

{ PURPOSE:
{   This procedure creates a message describing the hung PP for the operator action window.

  PROCEDURE process_hung_pp_message
    (    message_type: t$hung_pp_message_type;
         pp_entry: cmt$logical_pp_table_entry;
         input_message: ost$string;
         status: ost$status);

    VAR
      data_string: ost$string,
      local_status: ost$status,
      message: ost$string,
      response: ost$string;

    message := input_message;

    message.value ((message.size + 1), 3) := 'IOU';
    message.size := message.size + 3;
    clp$convert_integer_to_string (pp_entry.pp_info.physical_pp.iou_number, 10, FALSE, data_string,
          local_status);
    message.value ((message.size + 1), data_string.size) := data_string.value;
    message.size := message.size + data_string.size;

    IF pp_entry.pp_info.channel.channel_protocol = dsc$cpt_cio THEN
      message.value ((message.size + 1), 4) := ' CCH';
      message.size := message.size + 4;
    ELSE
      message.value ((message.size + 1), 3) := ' CH';
      message.size := message.size + 3;
    IFEND;
    clp$convert_integer_to_string (pp_entry.pp_info.channel.number, 8, TRUE, data_string, local_status);
    message.value ((message.size + 1), data_string.size) := data_string.value;
    message.size := message.size + data_string.size;

    IF pp_entry.pp_info.physical_pp.channel_protocol = dsc$cpt_cio THEN
      message.value ((message.size + 1), 4) := ' CPP';
      message.size := message.size + 4;
    ELSE
      message.value ((message.size + 1), 3) := ' PP';
      message.size := message.size + 3;
    IFEND;
    clp$convert_integer_to_string (pp_entry.pp_info.physical_pp.number, 8, TRUE, data_string, local_status);
    message.value ((message.size + 1), data_string.size) := data_string.value;
    message.size := message.size + data_string.size;

    message.value ((message.size + 1), 2) := ' (';
    message.size := message.size + 2;
    data_string.value := pp_entry.pp_info.driver_name;
    set_string_length (data_string);
    message.value ((message.size + 1), data_string.size) := data_string.value;
    message.size := message.size + data_string.size;
    message.value ((message.size + 1), 9) := ') hung.  ';
    message.size := message.size + 9;

    CASE message_type OF
    = c$hpmt_bad_status =
      message.value ((message.size + 1), 55) := 'Process detected bad status when attempting the reload.';
      message.size := message.size + 55;
    = c$hpmt_invalid_channel =
      message.value ((message.size + 1), 56) := 'Process detected invalid channel when attempting reload.';
      message.size := message.size + 56;
    = c$hpmt_no_handshaking =
      message.value ((message.size + 1), 32) := 'PP does not support handshaking.';
      message.size := message.size + 32;
    = c$hpmt_no_reload =
      message.value ((message.size + 1), 37) := 'PP does not support automatic reload.';
      message.size := message.size + 37;
    ELSE
    CASEND;

    pmp$log_ascii (message.value (1, message.size), $pmt$ascii_logset [pmc$system_log, pmc$job_log],
          pmc$msg_origin_system, local_status);
    IF message_type = c$hpmt_bad_status THEN
      osp$log_unformatted_status (^local_status, $pmt$ascii_logset [pmc$system_log, pmc$job_log],
            pmc$msg_origin_system, FALSE);
    IFEND;
    ofp$send_operator_message (message.value (1, message.size), ofc$system_operator, TRUE, local_status);
    IF local_status.normal THEN
      ofp$receive_operator_response (ofc$system_operator, osc$wait, response, local_status);
    IFEND;

  PROCEND process_hung_pp_message;
?? OLDTITLE ??
?? NEWTITLE := 'retrieve_sys_msg_from_image', EJECT ??

{ PURPOSE:
{   This procedure retrieves the system message buffer that was stored in the RDF area during the recovering
{   of the mainframe.

  PROCEDURE retrieve_sys_msg_from_image;

    VAR
      data_size: integer,
      message_data_p: ^SEQ ( * ),
      message_header_p: ^dst$system_message_header,
      rdf_file_segment: mmt$segment_pointer,
      rdf_file_sfid: dmt$system_file_id,
      rdf_pointers: dst$rdf_pointers,
      rdf_seq_p: ^SEQ ( * ),
      sys_msg_buffer_size: integer,
      valid_data_size_p: ^integer;

    { No messages are retrieved if this is NOT a recovery deadstart.

    IF (dsv$actual_deadstart_phase <> osc$recovery_deadstart) THEN
      RETURN;
    IFEND;

    { Retrieve the size of the RDF system message buffer.  If the size is zero then no buffer exists.

    dsp$get_integer_from_rdf (dsc$rdf_sys_msg_buffer_size, dsc$rdf_system_message_buffer,
          sys_msg_buffer_size);
    IF sys_msg_buffer_size = 0 THEN
      RETURN;
    IFEND;

    { Get the pointer to the RDF area.

    dsp$open_rdf (rdf_file_sfid, rdf_file_segment, rdf_pointers);
    dsp$get_rdf_entry_seq_pointer (dsc$rdf_system_messages_buffer, dsc$rdf_system_message_buffer,
          rdf_pointers, rdf_seq_p);
    RESET rdf_seq_p;
    NEXT valid_data_size_p IN rdf_seq_p;
    data_size := valid_data_size_p^;
    WHILE data_size > #SIZE (dst$system_message_header) DO
      NEXT message_header_p IN rdf_seq_p;
      data_size := data_size - #SIZE (message_header_p^);
      IF data_size >= message_header_p^.message_size THEN
        NEXT message_data_p: [[REP message_header_p^.message_size OF cell]] IN rdf_seq_p;
        data_size := data_size - #SIZE (message_data_p^);
        access_logging_routines (message_header_p^, message_data_p);
      IFEND;
    WHILEND;
    dsp$close_rdf (rdf_file_sfid, rdf_file_segment);

    { Set the buffer size to zero in the RDF to state that there is no longer any valid buffer data.

    dsp$clear_sys_msg_buffer_in_rdf;
    dsp$store_integer_in_rdf (dsc$rdf_sys_msg_buffer_size, dsc$rdf_system_message_buffer, 0);

  PROCEND retrieve_sys_msg_from_image;
?? OLDTITLE ??
?? NEWTITLE := 'set_string_length', EJECT ??

{ PURPOSE:
{   This procedure finds the length of a string that is passed in as a parameter.  It also removes
{   any spaces that are at the beginning and at the end of the string.

  PROCEDURE set_string_length
    (VAR string_data: ost$string);

    VAR
      begin_index: ost$string_size,
      end_index: ost$string_size,
      temp_string: string (osc$max_string_size);

    { If the string is all blank set the string length to one and return.

    IF string_data.value = ' ' THEN
      string_data.size := 1;
      RETURN;
    IFEND;

    { Find the first non-blank character in the string.

    begin_index := 1;
    WHILE (begin_index <= osc$max_string_size) AND (string_data.value (begin_index) = ' ') DO
      begin_index := begin_index + 1;
    WHILEND;

    { Find the last non-blank character in the string.

    end_index := osc$max_string_size;
    WHILE (end_index > begin_index) AND (string_data.value (end_index) = ' ') DO
      end_index := end_index - 1;
    WHILEND;

    { Move the data in the string so the first non-blank character is the first character in the string and
    { determine the size of the string from the first non-blank character to the last non-blank character.

    temp_string := string_data.value;
    string_data.value := temp_string (begin_index, (end_index - begin_index) + 1);
    string_data.size := (end_index - begin_index) + 1;

  PROCEND set_string_length;
?? OLDTITLE ??
?? NEWTITLE := 'sys_log_informative_message', EJECT ??

{ PURPOSE:
{   This procedure is called to log an informative message to the engineering log.  The format
{   of the log message is described in the deck cml$system_informative_message.

  PROCEDURE sys_log_informative_message
    (VAR log_data_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      message_data_p: ^string ( * ),
      message_size: 0 .. osc$max_string_size,
      message_value: string (osc$max_string_size);

    status.normal := TRUE;

    { Retrieve the message to be logged.

    RESET log_data_p;
    NEXT message_data_p: [#SIZE (log_data_p^)] IN log_data_p;

    message_value (1, v$mainframe_name.size) := v$mainframe_name.value;
    message_size := v$mainframe_name.size;
    message_value ((message_size + 1), 1) := '*';
    message_size := message_size + 1;
    message_value ((message_size + 1), *) := message_data_p^;

    { Log the message to the engineering log.

    sfp$emit_statistic (cml$system_informative_message, message_value, NIL, status);

  PROCEND sys_log_informative_message;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$allow_sys_msg_logging', EJECT ??

{ PURPOSE:
{   This procedure allows system messages to be logged into the engineering log.  The system initialization
{   messages must be logged before any other messages can be logged.  Then any messages from the image file
{   are retrieved and logged.  The logging flag is then turned on and the messages on the system message
{   buffer can be logged.

  PROCEDURE [XDCL] dsp$allow_sys_msg_logging;

    VAR
      ignore_status: ost$status,
      iou_index: dst$number_of_ious,
      iou_information_table: dst$iou_information_table,
      number_of_ious: dst$number_of_ious;

    { Establish the statistic for the system messages.

    establish_sys_msgs_stats;

    { Retrieve the mainframe name for the statistic message.

    IF v$mainframe_name.size = 0 THEN
      get_mainframe_name;
    IFEND;

    { Set the flag that will allow system messages to be logged into the engineering log.

    dsp$set_record_errors_flag;

    { Retrieve and log any system messages that may have been saved on the image file.

    retrieve_sys_msg_from_image;

    { Log any messages that are on the circular buffer.

    dsp$retrieve_system_message (dsc$retrieve_system_message);

    { Log any DFT messages.

    IF NOT dsv$turn_dft_logging_off THEN
      dsp$log_dft_data (dsc$log_dft_flag_id);
    IFEND;

    { Log the system initialization messages.

    cm_cp_identification (ignore_status);
    cm_cm_identification (ignore_status);
    cm_iou_identification (ignore_status);
    cm_channel_identification (ignore_status);
    cm_peripheral_identification (ignore_status);

    { The identification of the page map is only logged on S0 mainframes.

    dsp$retrieve_iou_information (number_of_ious, iou_information_table);

   /search_for_s0_iou/
    FOR iou_index := 1 TO number_of_ious DO
      IF iou_information_table [iou_index].model_type = dsc$imn_i0_5x_model THEN
        cm_pm_identification (ignore_status);
        EXIT /search_for_s0_iou/;
      IFEND;
    FOREND /search_for_s0_iou/;
    cm_system_deadstart_status (ignore_status);

  PROCEND dsp$allow_sys_msg_logging;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$log_dft_data', EJECT ??

{ PURPOSE:
{   This procedure logs any errors that exist in the DFT buffer.  This routine makes calls to monitor
{   to retrieve the data from the DFT buffer.

  PROCEDURE [XDCL] dsp$log_dft_data
    (    flag_id: ost$system_flag);

    VAR
      ignore_status: ost$status,
      message: ost$string,
      rb: dst$rb_logging_request,
      request_completed: boolean,
      top_of_hour_logged: boolean;

    IF v$mainframe_name.size = 0 THEN
      get_mainframe_name;
    IFEND;

    { The following boolean notices if the top of hour statistics (element counters and SECDED ID table) are
    { logged.  If these statistics are logged then a statistic that just states 'TOP OF HOUR' must be logged.

    top_of_hour_logged := FALSE;

    { Allocate space to hold the DFT buffer data.  This space must be created in system core code.

    dsp$manage_dftb_space_in_mfw (dsc$dftb_allocate_space, rb.dftb_seq_p, request_completed);
    IF NOT request_completed THEN
      RETURN;
    IFEND;

    { Retrieve the buffer information for an error from DFT and call the correct logging routine.  Continue
    { calling monitor mode for more DFT information until there is no more information to log.

    rb.reqcode := syc$rc_logging_request;
    rb.action := dsc$rla_dft_access_buffer_entry;
    rb.dftb_data_structures := $dst$rb_dft_data_structures [ ];
    rb.dftb_clear_entries_checked := 0;
    rb.dftb_log_entries_checked := 0;

    REPEAT
      i#call_monitor (#LOC (rb), #SIZE (rb));
      CASE rb.response OF
      = dsc$rlr_dft_entry_to_log =
        top_of_hour_logged := top_of_hour_logged OR
              (rb.dftb_control_word.dft_analysis_code = dsc$dftb_dac_non_707);
        dft_log_failure_data (dsv$dftb_data.mrb_length, rb);
      = dsc$rlr_dft_entry_interlocked =
        pmp$cycle (ignore_status);
      ELSE
      CASEND;
    UNTIL (rb.response = dsc$rlr_dft_no_entry_to_log);

    { Free the space that was allocated earlier in mainframe wired.

    dsp$manage_dftb_space_in_mfw (dsc$dftb_free_space, rb.dftb_seq_p, request_completed);

    { If the top of hour stats were logged, log the 'TOP OF HOUR' statistic.

    IF top_of_hour_logged THEN
      message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
      message.size := v$mainframe_name.size;
      message.value ((message.size + 1), 12) := '*TOP OF HOUR';
      message.size := message.size + 12;

      sfp$emit_statistic (cml$dft_top_of_hour, message.value (1, message.size), NIL, ignore_status);
    IFEND;

  PROCEND dsp$log_dft_data;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$log_dft_top_of_hour', EJECT ??

{ PURPOSE:
{   This procedure makes a monitor call to the monitor routine to inform DFT that the top of hour
{   has occurred.  The monitor routine sets a bit in the DFT control word in the DFT block.  The
{   setting of this bit informs DFT to log the mainframe element counters and the SECDED ID table information.

  PROCEDURE [XDCL] dsp$log_dft_top_of_hour;

    VAR
      any_side_door_port_defined: boolean,
      ignore_status: ost$status,
      rb: dst$rb_logging_request;

    rb.reqcode := syc$rc_logging_request;
    rb.action := dsc$rla_dft_log_top_of_hour;
    i#call_monitor (#LOC (rb), #SIZE (rb));

    dfp$any_sdp_defined (any_side_door_port_defined);

    IF any_side_door_port_defined THEN
      dfp$log_side_door_port_status (dfc$sdp_top_of_hour, ignore_status);
    IFEND;

  PROCEND dsp$log_dft_top_of_hour;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$log_job_recovery_statistics', EJECT ??

{ PURPOSE:
{   This procedure logs the job recovery statistics.

  PROCEDURE [XDCL] dsp$log_job_recovery_statistics
    (    recovered_job_count: integer;
         jobs_recovering_count: integer;
     VAR status: ost$status);

    CONST
      c$cm1112_job_recovery_totals = 1,
      c$cm1113_failed_job_p_addresses = 1;

    TYPE
      t$cm1112_counters = RECORD
        total_jobs_found: integer,
        total_jobs_recovered: integer,
        total_jobs_failed: integer,
        total_jobs_terminated: integer,
      RECEND,

      t$cm1113_count_word = integer,

      t$header_word = RECORD
        id: 0 .. 0ff(16),
        rfu: 0 .. 0ffffffffff(16),
        words_per_block: 0 .. 0ffff(16),
      RECEND;

    VAR
      cm1112_counters_p: ^t$cm1112_counters,
      cm1112_data_seq_p: ^SEQ ( * ),
      cm1113_condition_code_p: ^integer,
      cm1113_count_word_p: ^t$cm1113_count_word,
      cm1113_data_seq_p: ^SEQ ( * ),
      condition_code_index: integer,
      counters_p: sft$counters,
      data_size: integer,
      error_index: integer,
      header_word_p: ^t$header_word,
      local_status: ost$status,
      message: ost$string,
      message_size: integer,
      temp_string: ost$string;

    status.normal := TRUE;

    IF v$mainframe_name.size = 0 THEN
      get_mainframe_name;
    IFEND;

    { Log the Job Recovery Totals (CM1112) Statistic.

    message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
    message.size := v$mainframe_name.size;
    message.value ((message.size + 1), 1) := '*';
    message.size := message.size + 1;
    temp_string.value := 'JOB RECOVERY COMPLETED';
    set_string_length (temp_string);
    message.value ((message.size + 1), temp_string.size) := temp_string.value;
    message.size := message.size + temp_string.size;

    data_size := #SIZE (t$cm1112_counters) + #SIZE (t$header_word);
    PUSH cm1112_data_seq_p: [[REP data_size OF cell]];
    RESET cm1112_data_seq_p;

    NEXT header_word_p IN cm1112_data_seq_p;
    header_word_p^.id := c$cm1112_job_recovery_totals;
    header_word_p^.rfu := 0;
    header_word_p^.words_per_block := (data_size - #SIZE (t$header_word)) DIV 8;

    NEXT cm1112_counters_p IN cm1112_data_seq_p;
    cm1112_counters_p^.total_jobs_found := recovered_job_count;
    cm1112_counters_p^.total_jobs_recovered := jobs_recovering_count;
    cm1112_counters_p^.total_jobs_failed := syv$recovery_failure_count;
    cm1112_counters_p^.total_jobs_terminated := syv$file_rcv_failure_count;

    RESET cm1112_data_seq_p;
    NEXT counters_p: [1 .. (data_size DIV 8)] IN cm1112_data_seq_p;
    sfp$emit_statistic (cml$job_recovery_totals, message.value (1, message.size), counters_p, status);

    STRINGREP (message.value, message_size, ' JOB RECOVERY COMPLETED', ' Jobs found:', recovered_job_count,
          '   Recovered:', jobs_recovering_count, '   Failed:', syv$recovery_failure_count,
          '   Terminated:', syv$file_rcv_failure_count);
    pmp$log_ascii (message.value (1, message_size), $pmt$ascii_logset [pmc$system_log, pmc$job_log],
          pmc$msg_origin_system, local_status);
    IF syv$debug_job_recovery THEN
      clp$put_job_command_response (message.value (1, message_size), local_status);
    IFEND;

    { Log the Job Recovery Failure (CM1113) Statistic(s).

    IF syv$failure_reason_p = NIL THEN
      RETURN;
    IFEND;

   /log_cm1113_statistic/
    FOR error_index := LOWERBOUND (syv$failure_reason_p^) TO UPPERBOUND (syv$failure_reason_p^) DO
      IF syv$failure_reason_p^ [error_index].msg_count <= 0 THEN
        EXIT /log_cm1113_statistic/;
      IFEND;
      message.value := ' ';
      message.size := 0;
      message.value (1, v$mainframe_name.size) := v$mainframe_name.value;
      message.size := v$mainframe_name.size;
      message.value ((message.size + 1), 1) := '*';
      message.size := message.size + 1;
      temp_string.value := syv$failure_reason_p^ [error_index].message;
      set_string_length (temp_string);
      message.value ((message.size + 1), temp_string.size) := temp_string.value;
      message.size := message.size + temp_string.size;

      data_size := #SIZE (t$header_word) + #SIZE (t$cm1113_count_word) +
            (syv$failure_reason_p^ [error_index].conditions_count * 8);
      ALLOCATE cm1113_data_seq_p: [[REP data_size OF cell]] IN osv$task_private_heap^;
      RESET cm1113_data_seq_p;

      NEXT header_word_p IN cm1113_data_seq_p;
      header_word_p^.id := c$cm1113_failed_job_p_addresses;
      header_word_p^.rfu := 0;
      header_word_p^.words_per_block := (data_size - #SIZE (t$header_word)) DIV 8;

      NEXT cm1113_count_word_p IN cm1113_data_seq_p;
      cm1113_count_word_p^ := syv$failure_reason_p^ [error_index].count_word;

      FOR condition_code_index := 1 TO syv$failure_reason_p^ [error_index].conditions_count DO
        NEXT cm1113_condition_code_p IN cm1113_data_seq_p;
        cm1113_condition_code_p^ :=
              syv$failure_reason_p^ [error_index].conditions [condition_code_index].code_word;
      FOREND;

      RESET cm1113_data_seq_p;
      NEXT counters_p: [1 .. (data_size DIV 8)] IN cm1113_data_seq_p;
      sfp$emit_statistic (cml$job_recovery_failure, message.value (1, message.size), counters_p, status);

      FREE cm1113_data_seq_p IN osv$task_private_heap^;
    FOREND /log_cm1113_statistic/;

  PROCEND dsp$log_job_recovery_statistics;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$log_system_message', EJECT ??

{ PURPOSE:
{   This procedure is called by any procedure that wants to log a system message into the engineering
{   log.  The reason this procedure is called first is to save the data in the circular buffer if it
{   is too early in deadstart to call the statistic routines.

  PROCEDURE [XDCL] dsp$log_system_message
    (    message_type: integer;
     VAR log_data_p: ^SEQ ( * );
     VAR status: ost$status);

    status.normal := TRUE;

    IF v$mainframe_name.size = 0 THEN
      get_mainframe_name;
    IFEND;

    { Check to see if it is too early to log any messages.  If it is too early place the messages on
    { the System Message Buffer until logging can occur.

    IF NOT dsv$record_errors THEN
      dsp$log_sys_msg_help (message_type, log_data_p);
    ELSE

      CASE message_type OF
      = cml$channel_identification =
        cm_channel_identification (status);
      = cml$cm_identification =
        cm_cm_identification (status);
      = cml$cp_identification =
        cm_cp_identification (status);
      = cml$element_state_change =
        cm_element_state_change (log_data_p, status);
      = cml$iou_identification =
        cm_iou_identification (status);
      = cml$ms_volume_initialization =
        cm_ms_volume_initialization (log_data_p, status);
      = cml$ms_media_flaw_change =
        cm_ms_media_flaw_change (log_data_p, status);
      = cml$peripheral_identification =
        cm_peripheral_identification (status);
      = cml$pm_identification =
        cm_pm_identification (status);
      = cml$pp_hung =
        os_pp_hung (log_data_p);
      = cml$pp_timed_out =
        os_pp_timed_out (log_data_p);
      = cml$system_continuation, cml$system_termination =
        os_log_system_control_data (log_data_p, status);
      = cml$system_informative_message =
        sys_log_informative_message (log_data_p, status);
      = cml$system_deadstart_status =
        cm_system_deadstart_status (status);
      = cml$system_error =
        os_log_system_error (log_data_p, status);
      ELSE
      CASEND;
    IFEND;

  PROCEND dsp$log_system_message;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$retrieve_system_message', EJECT ??

{ PURPOSE:
{   This procedure is called from a system flag that was set from the monitor routine that
{   controls the circular buffer.  It retrieves the messages from the circular buffer and
{   calls the appropriate logging routine.

  PROCEDURE [XDCL] dsp$retrieve_system_message
    (    flag_id: ost$system_flag);

    VAR
      add_data_ptr_offset: integer,
      message_to_log_p: ^SEQ ( * ),
      rb: dst$rb_logging_request,
      remove_data_seq_p: ^SEQ ( * ),
      sys_msg_header_p: ^dst$system_message_header;

    IF NOT jmv$executing_within_system_job THEN
      RETURN;
    IFEND;

    { Retrieve the information to be logged from the System Message buffer.

    rb.reqcode := syc$rc_logging_request;
    rb.action := dsc$rla_sys_msg_get_message;
    rb.sys_msg_clear_buffer := FALSE;
    i#call_monitor (#LOC (rb), #SIZE (rb));

    { Remove data from the System Message buffer until the 'remove' pointer equals the 'add' pointer.  All
    { the data after the 'remove' pointer and before the 'add' pointer is valid data.

    WHILE i#current_sequence_position (rb.sys_msg_add_data_seq_p) <>
          i#current_sequence_position (rb.sys_msg_remove_data_seq_p) DO

      remove_data_seq_p := rb.sys_msg_remove_data_seq_p;
      add_data_ptr_offset := i#current_sequence_position (rb.sys_msg_add_data_seq_p);

     /log_sys_msgs_buffer/
      WHILE TRUE DO

        { Check if all of the data has been removed from the buffer.

        IF add_data_ptr_offset = i#current_sequence_position (remove_data_seq_p) THEN
          EXIT /log_sys_msgs_buffer/;
        IFEND;

        { If the end of the buffer has been encountered then the buffer must be searched from the beginning.

        NEXT sys_msg_header_p IN remove_data_seq_p;
        IF sys_msg_header_p^.message_size = 0 THEN
          RESET remove_data_seq_p;
          CYCLE /log_sys_msgs_buffer/;
        IFEND;

        NEXT message_to_log_p: [[REP sys_msg_header_p^.message_size OF cell]] IN remove_data_seq_p;
        access_logging_routines (sys_msg_header_p^, message_to_log_p);
      WHILEND /log_sys_msgs_buffer/;

      { Clear the System Message buffer of the data that was just logged, check if there is any more data.

      rb.sys_msg_clear_buffer := TRUE;
      i#call_monitor (#LOC (rb), #SIZE (rb));
    WHILEND;

  PROCEND dsp$retrieve_system_message;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$signal_handler', EJECT ??

{ PURPOSE:
{   This procedure receives the deadstart signal from monitor and calls the appropriate routine.

  PROCEDURE [XDCL, #GATE] dsp$signal_handler
    (    originator: ost$global_task_id;
         signal: pmt$signal);

    VAR
      signal_data: dst$signal_contents;

     signal_data.signal := signal;
     CASE signal_data.identifier OF
     = dsc$deadstart_signal =
       CASE signal_data.contents.kind OF
       = dsc$signal_lock_unlock_window =
         dsp$lock_unlock_window_from_mtr (signal_data.contents);
       = dsc$signal_post_operator_action =
         post_operator_action (signal_data.contents);
       = dsc$signal_hung_pp_process =
         process_hung_pp_from_mtr (signal_data.contents);
       ELSE
       CASEND;
     ELSE
     CASEND;

  PROCEND dsp$signal_handler;
?? OLDTITLE ??
MODEND dsm$log_system_messages;
*DECK DECK=DSM$LOG_SYS_MSGS_HELPER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : System Messages Logger Helper' ??
MODULE dsm$log_sys_msgs_helper;

{ PURPOSE:
{   This module contains procedures that assist the job template procedures involved in the logging of
{   DFT errors and the logging of system messages.  When the job template procedures wish to contact the
{   logging procedures that run in monitor they call these procedures which are allowed to call monitor.
{   These procedures are also called from job template when it is necessary to write mainframe wired.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dst$dftb_manage_space
*copyc dst$rb_logging_request
*copyc dst$rb_system_deadstart_status
?? POP ??
*copyc dsp$build_sequence_p
*copyc dsp$close_rdf
*copyc dsp$fetch_list_block
*copyc dsp$get_integer_from_rdf
*copyc dsp$get_nve_image_description
*copyc dsp$get_rdf_entry_seq_pointer
*copyc dsp$open_rdf
*copyc dsp$store_integer_in_rdf
*copyc i#build_adaptable_seq_pointer
*copyc i#call_monitor
*copyc i#current_sequence_position
*copyc mmp$write_modified_pages
*copyc osp$system_error
*copyc pmp$zero_out_table
?? EJECT ??
*copyc iov$disk_pp_usage_p
*copyc dsv$dftb_data
*copyc dsv$record_errors
*copyc dsv$sys_msg_buffer_desc_p
*copyc dsv$sys_msg_buffer_size
*copyc dsv$system_deadstart_status_p
*copyc osv$mainframe_wired_heap
?? OLDTITLE ??
?? NEWTITLE := 'dsp$clear_sys_msg_buffer_in_rdf', EJECT ??

{ PURPOSE:
{   This procedure clears the system message buffer in the RDF area.

  PROCEDURE [XDCL, #GATE] dsp$clear_sys_msg_buffer_in_rdf;

    VAR
      rdf_file_segment: mmt$segment_pointer,
      rdf_file_sfid: dmt$system_file_id,
      rdf_pointers: dst$rdf_pointers,
      rdf_seq_p: ^SEQ ( * ),
      valid_data_size_p: ^integer;

    dsp$open_rdf (rdf_file_sfid, rdf_file_segment, rdf_pointers);
    dsp$get_rdf_entry_seq_pointer (dsc$rdf_system_messages_buffer, dsc$rdf_system_message_buffer,
          rdf_pointers, rdf_seq_p);
    RESET rdf_seq_p;
    NEXT valid_data_size_p IN rdf_seq_p;
    valid_data_size_p^ := 0;
    dsp$close_rdf (rdf_file_sfid, rdf_file_segment);

  PROCEND dsp$clear_sys_msg_buffer_in_rdf;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$enlarge_sys_msg_buffer', EJECT ??

{ PURPOSE:
{   This procedure enlarges the circular system message buffer in the mainframe wired heap.  It creates
{   a new system message buffer.  The size of the circular buffer is dependent upon the number of pps
{   that are on the current system.  The size equals the number of pps times 100 words times 2.

  PROCEDURE [XDCL, #GATE] dsp$enlarge_sys_msg_buffer;

    CONST

      { The new buffer size multipier is 100 words times 2.

      new_buffer_size_multiplier = (100 * 8) * 2;

    VAR
      number_of_pps: integer,
      old_buffer_seq_p: ^SEQ ( * ),
      pp_index: integer,
      rb: dst$rb_logging_request;

    { Find the number of NOS/VE pps on the system.  This number excludes any pp used by NAM/VE, RHF,
    { MALET/VE or FOREIGN Subsystem.

    number_of_pps := 0;
    IF iov$disk_pp_usage_p <> NIL THEN
      FOR pp_index := LOWERBOUND (iov$disk_pp_usage_p^) TO UPPERBOUND (iov$disk_pp_usage_p^) DO

        { If the following pointer is valid then a valid pp exists.

        IF iov$disk_pp_usage_p^ [pp_index] <> NIL THEN
          number_of_pps := number_of_pps + 1;
        IFEND;
      FOREND;
    IFEND;

    { A new buffer is not created if the new enlarged buffer size is smaller then the original System
    { Message buffer.

    IF ((number_of_pps * new_buffer_size_multiplier) <= dsv$sys_msg_buffer_size) THEN
      RETURN;
    IFEND;

    { Save a pointer to the original System Message buffer.

    old_buffer_seq_p := dsv$sys_msg_buffer_desc_p^.cm_start_of_buffer_p;

    { Create the enlarged System Message buffer and call monitor to enlarge the buffer and move all
    { the data from the old buffer to the new enlarged buffer.

    rb.sys_msg_new_buffer_size := number_of_pps * new_buffer_size_multiplier;
    ALLOCATE rb.sys_msg_add_data_seq_p: [[REP rb.sys_msg_new_buffer_size of cell]]
          IN osv$mainframe_wired_heap^;
    pmp$zero_out_table (rb.sys_msg_add_data_seq_p, rb.sys_msg_new_buffer_size);
    rb.reqcode := syc$rc_logging_request;
    rb.action := dsc$rla_sys_msg_enlarge_buffer;
    i#call_monitor (#LOC (rb), #SIZE (rb));

    { Free the original System Message buffer from mainframe wired.

    FREE old_buffer_seq_p IN osv$mainframe_wired_heap^;

  PROCEND dsp$enlarge_sys_msg_buffer;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$log_sys_msg_help', EJECT ??

{ PURPOSE:
{   This procedure allows a job template procedure to call monitor to put a message on the System
{   Message buffer if logging messages is not allowed.

  PROCEDURE [XDCL, #GATE] dsp$log_sys_msg_help
    (    message_type: integer;
     VAR log_data_p: ^SEQ ( * ));

    VAR
      data_to_log_p: ^SEQ ( * ),
      message_type_to_log_p: ^integer,
      rb: dst$rb_logging_request,
      sys_msg_data_p: ^SEQ ( * ),
      sys_msg_header_p: ^dst$system_message_header;

    { Create a dummy data record for the callers that do not have any extra data to pass along to the
    { logging procedure.

    IF log_data_p = NIL THEN
      PUSH data_to_log_p: [[REP 1 OF integer]];
    ELSE
      data_to_log_p := log_data_p;
    IFEND;
    RESET data_to_log_p;

    { Allocate space in mainframe wired to hold the message to be put on the buffer.

    ALLOCATE rb.sys_msg_add_data_seq_p: [[REP (#SIZE (data_to_log_p^) + #SIZE (message_type) +
          #SIZE (dst$system_message_header)) OF cell]] IN osv$mainframe_wired_heap^;
    RESET rb.sys_msg_add_data_seq_p;

    { Put the message to be stored on the buffer in the allocated space.

    NEXT sys_msg_header_p IN rb.sys_msg_add_data_seq_p;
    sys_msg_header_p^.message_size := #SIZE (data_to_log_p^) + #SIZE (message_type);
    sys_msg_header_p^.message_type := dsc$general_system_message;
    sys_msg_header_p^.message_level := dsc$informative_message;
    NEXT message_type_to_log_p IN rb.sys_msg_add_data_seq_p;
    message_type_to_log_p^ := message_type;
    NEXT sys_msg_data_p: [[REP #SIZE (data_to_log_p^) OF cell]] IN rb.sys_msg_add_data_seq_p;
    sys_msg_data_p^ := data_to_log_p^;
    RESET rb.sys_msg_add_data_seq_p;

    { Call monitor to put the data on the buffer.

    rb.reqcode := syc$rc_logging_request;
    rb.action := dsc$rla_sys_msg_add_message;
    i#call_monitor (#LOC (rb), #SIZE (rb));
    FREE rb.sys_msg_add_data_seq_p IN osv$mainframe_wired_heap^;

  PROCEND dsp$log_sys_msg_help;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$manage_dftb_space_in_mfw', EJECT ??

{ PURPOSE:
{   This procedure allocates space or frees space in mainframe wired for logging DFT requests for a job
{   template routine.

  PROCEDURE [XDCL, #GATE] dsp$manage_dftb_space_in_mfw
    (    action: dst$dftb_manage_space;
     VAR space_seq_p: ^SEQ ( * );
     VAR request_completed: boolean);

    VAR
      local_space_seq_p: ^SEQ ( * ),
      space_size: integer;

    request_completed := FALSE;

    local_space_seq_p := space_seq_p;

    IF action = dsc$dftb_allocate_space THEN
      IF dsv$dftb_data.revision_level <= dsc$dftb_revision_level_3 THEN
        space_size := dsv$dftb_data.mrb_length;
      ELSE
        space_size := dsv$dftb_data.mrb_length + dsv$dftb_data.ssb_length + dsv$dftb_data.mdb_length +
              dsv$dftb_data.nrb_length;
      IFEND;
      IF space_size = 0 THEN
        RETURN;
      IFEND;
      ALLOCATE local_space_seq_p: [[REP space_size OF integer]] IN osv$mainframe_wired_heap^;
      pmp$zero_out_table (local_space_seq_p, (space_size * 8));
      space_seq_p := local_space_seq_p;
      RESET space_seq_p;
    ELSE
      FREE local_space_seq_p IN osv$mainframe_wired_heap^;
      space_seq_p := NIL;
    IFEND;

    request_completed := TRUE;

  PROCEND dsp$manage_dftb_space_in_mfw;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$retrieve_system_ds_status', EJECT ??

{ PURPOSE:
{   This procedure calls monitor to retrieve the System Deadstart Status from the SSR.  It also moves the
{   data from the mainframe wired pointer to the SSR and Frees the space used by the mainframe wired pointer.

  PROCEDURE [XDCL, #GATE] dsp$retrieve_system_ds_status
    (VAR data: dst$ssr_system_deadstart_status);

    VAR
      rb: dst$rb_system_deadstart_status;

    { Retrieve the system deadstart status from the SSR.

    rb.reqcode := syc$rc_system_deadstart_status;
    rb.status.normal := TRUE;
    rb.action := dsc$rb_sds_retrieve_data;
    ALLOCATE rb.data_p IN osv$mainframe_wired_heap^;
    pmp$zero_out_table (rb.data_p, #SIZE (rb.data_p^));
    i#call_monitor (#LOC (rb), #SIZE (rb));

    data := rb.data_p^;

    FREE rb.data_p IN osv$mainframe_wired_heap^;
    FREE dsv$system_deadstart_status_p IN osv$mainframe_wired_heap^;

  PROCEND dsp$retrieve_system_ds_status;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$set_record_errors_flag', EJECT ??

{ PURPOSE:
{   This procedure sets a boolean variable that allows the system messages to be logged onto the engineering
{   log.  This procedure is called by job template procedure which can not change a variable that is created
{   in monitor directly.

  PROCEDURE [XDCL, #GATE] dsp$set_record_errors_flag;

    dsv$record_errors := TRUE;

  PROCEND dsp$set_record_errors_flag;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$store_sys_msg_in_image', EJECT ??

{ PURPOSE:
{   This procedure is called during recovery to store the information that was in the system messages buffer
{   in 'old' mainframe wired.  This information is stored in rdf_system_message_buffer in the image file.

  PROCEDURE [XDCL, #GATE] dsp$store_sys_msg_in_image;

    VAR
      add_data_ptr_offset: integer,
      adj_sys_msg_desc_p: ^dst$sys_msg_buffer_desc,
      ignore_data_p: ^SEQ ( * ),
      image_descriptor: dst$nve_image_descriptor,
      local_status: ost$status,
      old_wired_segment_p: ^SEQ ( * ),
      rdf_file_segment: mmt$segment_pointer,
      rdf_file_sfid: dmt$system_file_id,
      rdf_pointers: dst$rdf_pointers,
      rdf_sys_msg_data_p: ^SEQ ( * ),
      rdf_sys_msg_header_p: ^dst$system_message_header,
      rdf_sys_msg_seq_p: ^SEQ ( * ),
      remove_data_ptr_offset: integer,
      sys_msg_buffer_size: integer,
      sys_msg_data_p: ^SEQ ( * ),
      sys_msg_desc_pp: ^^dst$sys_msg_buffer_desc,
      sys_msg_desc_seq_p: ^SEQ ( * ),
      sys_msg_header_p: ^dst$system_message_header,
      sys_msg_seq_p: ^SEQ ( * ),
      temp_old_seq_p: ^cell,
      valid_data_seq_p: ^SEQ ( * ),
      valid_data_size_p: ^integer;

    { Retrieve the size of the buffer that is stored in the RDF area and the buffer.

    dsp$get_integer_from_rdf (dsc$rdf_sys_msg_buffer_size, dsc$rdf_system_message_buffer,
          sys_msg_buffer_size);

    dsp$open_rdf (rdf_file_sfid, rdf_file_segment, rdf_pointers);
    dsp$get_rdf_entry_seq_pointer (dsc$rdf_system_messages_buffer, dsc$rdf_system_message_buffer,
          rdf_pointers, rdf_sys_msg_seq_p);
    RESET rdf_sys_msg_seq_p;

    { This integer holds the size of the valid data currently stored on the 'RDF'.

    NEXT valid_data_size_p IN rdf_sys_msg_seq_p;

    IF (valid_data_size_p^ > 0) AND (sys_msg_buffer_size > 0) AND
          (valid_data_size_p^ <= sys_msg_buffer_size) THEN

      { Valid data still exists on the image file.  This valid data MUST NOT be written over.  Advance the
      { pointer to the sequence past this valid data.

      NEXT valid_data_seq_p: [[REP valid_data_size_p^ OF cell]] IN rdf_sys_msg_seq_p;
    ELSE

      { No valid data exists on the image file.  Compute the amount of space available on the 'RDF' for the
      { buffer and store this value on the 'RDF'.

      sys_msg_buffer_size := #SIZE (rdf_sys_msg_seq_p^);
      dsp$store_integer_in_rdf (dsc$rdf_sys_msg_buffer_size, dsc$rdf_system_message_buffer,
            sys_msg_buffer_size);
      valid_data_size_p^ := 0;
    IFEND;

    { Save the information from the 'old' mainframe_wired_heap in the image file.

    dsp$get_nve_image_description (image_descriptor);
    old_wired_segment_p := image_descriptor.rcv_mainframe_wired_segment;

    IF old_wired_segment_p <> NIL THEN

      { Retrieve the sequence that contains the pointers to the System Message buffer to the old mainframe
      { wired heap.

      dsp$fetch_list_block (dsc$system_messages_buffer, sys_msg_desc_seq_p);

      { Change the ring and segment number of the sequence pointer to that of the recovered (old) mainframe
      { wired and build a sequence pointer with the new address.

      i#build_adaptable_seq_pointer (#RING (old_wired_segment_p), #SEGMENT (old_wired_segment_p),
            #OFFSET (sys_msg_desc_seq_p), #SIZE (sys_msg_desc_seq_p^), 0, sys_msg_desc_seq_p);
      RESET sys_msg_desc_seq_p;
      NEXT sys_msg_desc_pp IN sys_msg_desc_seq_p;

      { Change the ring and segment number of the pointers to the System Message buffer to that of the
      { recovered (old) mainframe wired.

      adj_sys_msg_desc_p := #ADDRESS (#RING (old_wired_segment_p), #SEGMENT (old_wired_segment_p),
            #OFFSET (sys_msg_desc_pp^));

      { Create a sequence pointer to the start of the System Message buffer.

      temp_old_seq_p := #ADDRESS (#RING (old_wired_segment_p), #SEGMENT (old_wired_segment_p),
            #OFFSET (adj_sys_msg_desc_p^.cm_start_of_buffer_p));
      dsp$build_sequence_p (temp_old_seq_p, adj_sys_msg_desc_p^.sys_msg_buffer_size, sys_msg_seq_p);

      { If data exists on the System Message buffer in the recovered (old) mainframe wired, move the data to
      { the 'RDF' area.

      add_data_ptr_offset := adj_sys_msg_desc_p^.add_data_ptr_offset;
      remove_data_ptr_offset := adj_sys_msg_desc_p^.remove_data_ptr_offset;
    ELSE
      add_data_ptr_offset := 0;
      remove_data_ptr_offset := 0;
    IFEND;

    IF add_data_ptr_offset <> remove_data_ptr_offset THEN

      { Set the sequence so the pointer points to the remove data offset.

      IF i#current_sequence_position (sys_msg_seq_p) <> remove_data_ptr_offset THEN
        NEXT ignore_data_p: [[REP remove_data_ptr_offset OF cell]] IN sys_msg_seq_p;
      IFEND;

     /move_loop/
      WHILE TRUE DO

        { Check if all of the data has been removed from the buffer.

        IF (add_data_ptr_offset > remove_data_ptr_offset) AND
              (i#current_sequence_position (sys_msg_seq_p) >= add_data_ptr_offset) THEN
          EXIT /move_loop/;
        IFEND;

        { Check if there is enough space on the 'RDF' area to store more messages.

        NEXT sys_msg_header_p IN sys_msg_seq_p;
        IF (valid_data_size_p^ + #SIZE (valid_data_size_p^) + #SIZE (dst$system_message_header) +
              sys_msg_header_p^.message_size) >= sys_msg_buffer_size THEN
          EXIT /move_loop/;
        IFEND;

        { If the message size is zero, reset the sequence and access the data from the beginning.

        IF sys_msg_header_p^.message_size = 0 THEN
          RESET sys_msg_seq_p;
          remove_data_ptr_offset := i#current_sequence_position (sys_msg_seq_p);
          CYCLE /move_loop/;
        IFEND;

        { Move the message from the buffer to the 'RDF' area.

        NEXT sys_msg_data_p: [[REP sys_msg_header_p^.message_size OF cell]] IN sys_msg_seq_p;
        NEXT rdf_sys_msg_header_p IN rdf_sys_msg_seq_p;
        NEXT rdf_sys_msg_data_p: [[REP sys_msg_header_p^.message_size OF cell]] IN rdf_sys_msg_seq_p;
        rdf_sys_msg_header_p^ := sys_msg_header_p^;
        rdf_sys_msg_data_p^ := sys_msg_data_p^;
        valid_data_size_p^ := valid_data_size_p^ + #SIZE(dst$system_message_header) +
              sys_msg_header_p^.message_size;
      WHILEND /move_loop/;
    IFEND;

    mmp$write_modified_pages (rdf_sys_msg_seq_p, #SIZE (rdf_sys_msg_seq_p^), osc$wait, local_status);
    IF NOT local_status.normal THEN
      osp$system_error (' Cannot write modified pages (dsm$log_sys_msgs_helper)', ^local_status);
    IFEND;

    dsp$close_rdf (rdf_file_sfid, rdf_file_segment);

  PROCEND dsp$store_sys_msg_in_image;
MODEND dsm$log_sys_msgs_helper;
*DECK DECK=DSM$MANAGE_DEADSTART_FILES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Manage Deadstart File Utility' ??
MODULE dsm$manage_deadstart_files;

{ PURPOSE:
{   This module contains the utility which manages deadstart files.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dse$deadstart_utility_errors
*copyc dst$c170_77_table
*copyc dst$pp_header_descriptor
*copyc pmd$memory_image_header
*copyc syc$ssr_system_level_number
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$get_next
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc amp$put_partial
*copyc amp$return
*copyc amp$set_segment_eoi
*copyc amp$write_end_partition
*copyc clp$begin_utility
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_command
*copyc clp$include_file
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc fsp$close_file
*copyc fsp$open_file
*copyc mmp$set_access_selections
*copyc osp$set_status_abnormal
*copyc pmp$generate_unique_name
*copyc pmp$get_legible_date_time
*copyc rmp$get_device_class
?? POP ??
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??
  CONST
    c$mdf_infinity = 7fffffff(16);

  TYPE
    t$mdf_add_record_data = RECORD
      file_name_p: ^fst$file_reference,
      format: clt$keyword,
      placement: clt$keyword,
      destination: clt$data_value,
      eof_data: t$mdf_eof_data,
      saved_info: t$mdf_saved_info,
    RECEND,

    t$mdf_crebff_data = RECORD
      input_file_p: ^SEQ ( * ),
      record_list_p: ^SEQ ( * ),
      scratch_area_p: ^SEQ ( * ),
      top_link_p: ^t$mdf_record_link,
      link_counter: integer,
      end_of_record_list_p: ^t$mdf_record_data,
    RECEND,

    t$mdf_crebff_files = RECORD
      input_file: ost$name,
      input_file_id: amt$file_identifier,
      record_list: ost$name,
      record_list_id: amt$file_identifier,
      scratch_area: ost$name,
      scratch_area_id: amt$file_identifier,
    RECEND,

    t$mdf_display_code_character = 0 .. 77(8),

    t$mdf_eof_data = RECORD
      read_all_eofs: boolean,
      eofs_to_read: clt$integer,
    RECEND,

    t$mdf_id_name = string (4),

    t$mdf_record_data = cell,

    t$mdf_record_link = RECORD
      name: t$mdf_record_name,
      number: integer,
      id_name: t$mdf_id_name,
      size: integer,
      data_p: ^t$mdf_record_data,
      chain_p: ^t$mdf_record_link,
      end_of_file: boolean,
      time: string (10),
      date: string (10),
      comment: string (70),
      convert_binary_data: boolean,
      convert_for_nve_file: boolean,
      pack_for_cip_file: boolean,
    RECEND,

    t$mdf_record_name = string (7),

    t$mdf_saved_info = RECORD
      setup: boolean,
      placement: clt$keyword,
      link_counter: integer,
      link_data: t$mdf_record_link,
    RECEND,

    t$mdf_seven_char_dc_string = 0 .. 077777777777777(8),

    t$mdf_type_of_access = (c$mdf_record_access, c$mdf_segment_access),

    t$mdf_type_of_open = (c$mdf_open_for_read, c$mdf_open_for_cip_write, c$mdf_open_for_other_write);
?? EJECT ??
  VAR
    v$ascii_and_display_code: ARRAY [0 .. 77(8)] OF char :=
          [' ', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R',
           'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '+',
           '-', '*', '/', '(', ')', '$', '=', ' ', ',', '.', '#', '[', ']', '%', '"', '_', '!', '&', '''',
           '?', '<', '>', '@', '\', '^', ';'],
    v$cbf_prompt_string: string (3) := 'CBF',
    v$cbf_utility_name: string (31) := 'CREATE_BINARY_FORMATTED_FILE   ',
    v$crebff_already_entered: boolean := FALSE,
    v$crebff_data: t$mdf_crebff_data,
    v$crebff_files: t$mdf_crebff_files,
    v$mandf_chaa_bcu_level: string (2) := 'SS',
    v$mandf_chaa_psr_level: string (3) := 'XXX',
    v$mdf_prompt_string: string (3) := 'MDF',
    v$mdf_utility_name: string (31) := 'MANAGE_DEADSTART_FILES         ',
    v$page_header: string (132);
?? TITLE := 'add_cip_file', EJECT ??

{ PURPOSE:
{   This procedure adds a CIP file to the record list.

  PROCEDURE add_cip_file
    (VAR add_record_data: t$mdf_add_record_data;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      eop_found: boolean,
      file_identifier: amt$file_identifier,
      file_length: amt$file_length,
      ignore_status: ost$status,
      input_data_p: ^SEQ ( * ),
      link_p: ^t$mdf_record_link,
      new_size: integer,
      position: amt$file_position,
      record_data_p: ^SEQ ( * ),
      size: amt$transfer_count,
      unused_file_segment_pointer: amt$segment_pointer;

    status.normal := TRUE;

  /add_cip/
    BEGIN
      open_file (c$mdf_open_for_read, c$mdf_record_access, add_record_data.file_name_p, file_identifier,
            unused_file_segment_pointer, file_length, status);
      IF NOT status.normal THEN
        EXIT /add_cip/;
      IFEND;

      { Read a record from the file.

      RESET v$crebff_data.input_file_p;
      NEXT input_data_p: [[REP 1 OF cell]] IN v$crebff_data.input_file_p;
      REPEAT
        amp$get_next (file_identifier, input_data_p, c$mdf_infinity, size, ba, position, status);
        IF NOT status.normal THEN
          EXIT /add_cip/;
        IFEND;
      UNTIL (size <> 0) OR (position = amc$eoi);
      IF position = amc$eoi THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_record, 'cip file', status);
        EXIT /add_cip/;
      IFEND;

      REPEAT

        { Convert the record from 16 bit format to 12 bit format if necessary.

        IF add_record_data.format = 'CIP_FILE_12_IN_16' THEN
          convert_binary_record_16_to_12 (size, v$crebff_data.input_file_p, new_size);
          size := new_size;
        IFEND;

        { Create a link on the linked list for the new record.

        create_record_link (size, link_p, add_record_data, v$crebff_data.input_file_p, status);
        IF NOT status.normal THEN
          EXIT /add_cip/;
        IFEND;

        { Move the data from the input file to the linked list.

        RESET v$crebff_data.input_file_p;
        NEXT input_data_p: [[REP size OF cell]] IN v$crebff_data.input_file_p;
        NEXT record_data_p: [[REP size OF cell]] IN v$crebff_data.record_list_p;
        record_data_p^ := input_data_p^;

        { Read the next record from the file.

        RESET v$crebff_data.input_file_p;
        NEXT input_data_p: [[REP 1 OF cell]] IN v$crebff_data.input_file_p;
        eop_found := FALSE;
        REPEAT
          amp$get_next (file_identifier, input_data_p, c$mdf_infinity, size, ba, position, status);
          IF NOT status.normal THEN
            EXIT /add_cip/;
          IFEND;
          IF eop_found AND (position = amc$eop) THEN

            { Create a record link that contains only the notice of a EOP.

            NEXT v$crebff_data.end_of_record_list_p IN v$crebff_data.record_list_p;
            create_record_link (0, link_p, add_record_data, v$crebff_data.input_file_p, status);
            IF NOT status.normal THEN
              EXIT /add_cip/;
            IFEND;
            eop_found := FALSE;
          IFEND;
          IF position = amc$eop THEN
            eop_found := TRUE;
            link_p^.end_of_file := TRUE;
            IF NOT add_record_data.eof_data.read_all_eofs THEN
              add_record_data.eof_data.eofs_to_read.value := add_record_data.eof_data.eofs_to_read.value - 1;
              IF add_record_data.eof_data.eofs_to_read.value = 0 THEN
                NEXT v$crebff_data.end_of_record_list_p IN v$crebff_data.record_list_p;
                EXIT /add_cip/;
              IFEND;
            IFEND;
          IFEND;
        UNTIL (size <> 0) OR (position = amc$eoi);
        NEXT v$crebff_data.end_of_record_list_p IN v$crebff_data.record_list_p;
      UNTIL position = amc$eoi;
    END /add_cip/;

    cleanup_links_after_command (add_record_data, status);
    fsp$close_file (file_identifier, ignore_status);

  PROCEND add_cip_file;
?? TITLE := 'add_standard_77_table_parts', EJECT ??

{ PURPOSE:
{   This procedure adds the standard parts, (standard to this utility) to the 77 table.

  PROCEDURE add_standard_77_table_parts
    (    module_name: t$mdf_record_name;
         comment_string: string (41);
     VAR standard_77_table: dst$c170_77_table);

    VAR
      dc_value: integer,
      index: 0 .. 80;

    { Replace the processor name and version to reflect that it was built by this utility.

    convert_ascii_to_dc ('DSMMDF ', dc_value);
    standard_77_table.processor_name := dc_value;
    convert_ascii_to_dc ('2.0', dc_value);
    standard_77_table.processor_version := dc_value;

    { Replace the following constant values.

    standard_77_table.target_processor := 4330(8);   {8X
    standard_77_table.valid_processor := 4330(8);    {8X
    standard_77_table.program_flag := 10(8);         {H

    { Convert the module name to display code.

    convert_ascii_to_dc (module_name, dc_value);
    index := 1;
    WHILE (dc_value MOD 100(8)) = 55(8) DO
      index := index * 100(8);
      dc_value := dc_value DIV 100(8);
    WHILEND;
    standard_77_table.module_name := dc_value * index;

    { Convert the comment string from ascii to display code and replace all blanks with zeros.

    FOR index := 1 TO STRLENGTH (comment_string) DO
      IF comment_string (index) = ' ' THEN
        standard_77_table.comments [index] := 0;
      ELSE
        convert_ascii_to_dc (comment_string (index), dc_value);
        standard_77_table.comments [index] := dc_value;
      IFEND;
    FOREND;
    FOR index := (STRLENGTH (comment_string) + 1) TO 69 DO
      standard_77_table.comments [index] := 0;
    FOREND;
    standard_77_table.comment_fill := 0;

    standard_77_table.table_type := dsc$5000_table;
    standard_77_table.l1 := 0;
    standard_77_table.l2 := 0;
    standard_77_table.fwa := 0;
    standard_77_table.lwa := 0;

  PROCEND add_standard_77_table_parts;
?? TITLE := 'build_77_table', EJECT ??

{ PURPOSE:
{   This procedure builds a 77 table.

  PROCEDURE build_77_table
    (    module_name: t$mdf_record_name;
         version: 0 .. 0ff(16);
     VAR c170_77_table: dst$c170_77_table;
     VAR status: ost$status);

    VAR
      actual_date: string (9),
      actual_time: string (9),
      comment_string: string (41),
      date: ost$date,
      dc_value: integer,
      index: 1 .. 9,
      time: ost$time;

    status.normal := TRUE;
    c170_77_table.name := 7700(8);
    c170_77_table.length := 0e(16);
    c170_77_table.unused := 0;
    c170_77_table.fill := 0;

    { Get the system date and time and store it in the correct format:
    {   DATE: YY/MM/DD.    TIME: HH.MM.SS.

    pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    actual_date (1, 2) := date.mdy (7, 2);
    actual_date (3) := '/';
    actual_date (4, 2) := date.mdy (1, 2);
    actual_date (6) := '/';
    actual_date (7, 2) := date.mdy (4, 2);
    actual_date (9) := '.';
    convert_ascii_to_dc (actual_date (1), dc_value);
    c170_77_table.date_fill := dc_value;
    FOR index := 2 TO STRLENGTH (actual_date) DO
      convert_ascii_to_dc (actual_date (index), dc_value);
      c170_77_table.date [index-1] := dc_value;
    FOREND;
    c170_77_table.date [9] := 0;

    actual_time := time.hms;
    actual_time (3) := '.';
    actual_time (6) := '.';
    actual_time (9) := '.';
    convert_ascii_to_dc (actual_time (1), dc_value);
    c170_77_table.time_fill := dc_value;
    FOR index := 2 TO STRLENGTH (actual_time) DO
      convert_ascii_to_dc (actual_time (index), dc_value);
      c170_77_table.time [index-1] := dc_value;
    FOREND;
    c170_77_table.time [9] := 0;

    c170_77_table.operating_system_id_1 := 5555555555(8);
    c170_77_table.operating_system_id_2 := 5555555555(8);
    c170_77_table.mod_level := syc$ssln_released_level_number;
    c170_77_table.compass_flag := 55(8);
    c170_77_table.hardware_requirements_1 := 5555555555(8);
    c170_77_table.hardware_requirements_2 := 55555555(8);

    comment_string := '*SMD* LVL=99 , LXXXSS_YYYY_MM_DD_HH_MM_SS';

    { Move the version to the comment string.

    comment_string (11) := $CHAR (version DIV 10(16) + 30(16));
    comment_string (12) := $CHAR (version MOD 10(16) + 30(16));

    { Move the level number to the comment string.

    comment_string (17, 3) := v$mandf_chaa_psr_level;
    comment_string (20, 2) := v$mandf_chaa_bcu_level;

    { Move the date and time to the comment string.

    comment_string (23, 2) := '19';
    comment_string (25, 2) := actual_date (1, 2);  {YY
    comment_string (28, 2) := actual_date (4, 2);  {MM
    comment_string (31, 2) := actual_date (7, 2);  {DD
    comment_string (34, 2) := actual_time (1, 2);  {HH
    comment_string (37, 2) := actual_time (4, 2);  {MM
    comment_string (40, 2) := actual_time (7, 2);  {SS

    add_standard_77_table_parts (module_name, comment_string, c170_77_table);

  PROCEND build_77_table;
?? TITLE := 'cleanup_linked_list', EJECT ??

{ PURPOSE:
{   This procedure cleans up the linked list.  The list is empty as a result of this procedure.

  PROCEDURE cleanup_linked_list;

    v$crebff_data.top_link_p^.chain_p := NIL;
    v$crebff_data.top_link_p^.number := 0;
    v$crebff_data.link_counter := 0;
    RESET v$crebff_data.record_list_p;
    NEXT v$crebff_data.end_of_record_list_p IN v$crebff_data.record_list_p;

  PROCEND cleanup_linked_list;
?? TITLE := 'cleanup_links_after_command', EJECT ??

{ PURPOSE:
{   This procedure cleans up the record link after a command.  If the status is normal,
{   the links are renumbered else the record list is returned to the state it was in
{   before the command was entered.

  PROCEDURE cleanup_links_after_command
    (    add_record_data: t$mdf_add_record_data;
         status: ost$status);

    VAR
      before_link_p: ^t$mdf_record_link,
      link_counter: integer,
      link_index: integer,
      link_p: ^t$mdf_record_link,
      placement: clt$keyword,
      save_link_p: ^t$mdf_record_link;

    IF status.normal THEN
      link_p := v$crebff_data.top_link_p;
      link_counter := 0;
      WHILE link_p <> NIL DO
        link_p^.number := link_counter;
        link_counter := link_counter + 1;
        link_p := link_p^.chain_p;
      WHILEND;
      v$crebff_data.link_counter := link_counter - 1;
    ELSEIF add_record_data.saved_info.setup THEN
      placement := add_record_data.saved_info.placement;
      link_p := v$crebff_data.top_link_p^.chain_p;
      before_link_p := v$crebff_data.top_link_p;
      WHILE link_p <> NIL DO
        IF link_p^.number > add_record_data.saved_info.link_counter THEN
          IF placement = 'REPLACE' THEN
            save_link_p := link_p^.chain_p;
            link_p^ := add_record_data.saved_info.link_data;
            link_p^.chain_p := save_link_p;
            placement := 'AFTER';
          IFEND;
          WHILE TRUE DO
            link_p := link_p^.chain_p;
            IF link_p = NIL THEN
              before_link_p^.chain_p := NIL;
              RETURN;
            IFEND;
            IF link_p^.number <= add_record_data.saved_info.link_counter THEN
              before_link_p^.chain_p := link_p;
              RETURN;
            IFEND;
          WHILEND;
        IFEND;
        before_link_p := link_p;
        link_p := link_p^.chain_p;
      WHILEND;
    IFEND;

  PROCEND cleanup_links_after_command;
?? TITLE := 'compute_cm_word_length', EJECT ??

{ PURPOSE:
{   This procedure computes the cm word length from the unpacked code length.

  PROCEDURE compute_cm_word_length
    (    code_length: dst$pp_word;
     VAR cm_word_length: dst$pp_word);

    VAR
      actual_number_of_words: dst$pp_word,
      integer_length: integer,
      real_length: real;

    actual_number_of_words := code_length - 1;
    integer_length := (actual_number_of_words * 15) DIV 16;
    real_length := ($REAL (actual_number_of_words) * 15.0) / 16.0;
    IF (real_length - $REAL (integer_length)) < 0.25 THEN
      cm_word_length := integer_length;
    ELSE
      cm_word_length := integer_length + 1;
    IFEND;

  PROCEND compute_cm_word_length;
?? TITLE := 'convert_7_char_dc', EJECT ??

{ PURPOSE:
{   This procedure converts a seven character display code string to an ascii string.

  PROCEDURE convert_7_char_dc
    (    display_code_string: t$mdf_seven_char_dc_string;
     VAR ascii_string: t$mdf_record_name);

    VAR
      convert_size: integer,
      dc_array: ARRAY [1 .. 7] OF t$mdf_display_code_character,
      dc_index: 1 .. 7,
      dc_string: t$mdf_seven_char_dc_string;

    dc_string := display_code_string;
    convert_size := 100000000000000(8);
    FOR dc_index := 1 TO 7 DO
      convert_size := convert_size DIV 100(8);
      dc_array [dc_index] := dc_string DIV convert_size;
      dc_string := dc_string MOD convert_size;
    FOREND;
    convert_dc_to_ascii (dc_array, ascii_string);

  PROCEND convert_7_char_dc;
?? TITLE := 'convert_ascii_to_dc', EJECT ??

{ PURPOSE:
{   This procedure converts an ascii string to a display code integer.

  PROCEDURE convert_ascii_to_dc
    (    ascii_string: string ( * );
     VAR display_code_value: integer);

    VAR
      ascii_index: 0 .. 77(8),
      size: integer,
      string_index: 1 .. 256;

    size := 1;
    FOR ascii_index := 2 TO STRLENGTH (ascii_string) DO
      size := size * 100(8);
    FOREND;

    display_code_value := 0;

    FOR string_index := 1 TO STRLENGTH (ascii_string) DO

     /search_ascii/
      FOR ascii_index := LOWERBOUND (v$ascii_and_display_code) TO UPPERBOUND (v$ascii_and_display_code) DO
        IF v$ascii_and_display_code [ascii_index] = ascii_string (string_index) THEN
          display_code_value := display_code_value + (ascii_index * size);
          EXIT /search_ascii/;
        IFEND;
      FOREND /search_ascii/;
      size := size DIV 100(8);
    FOREND;

  PROCEND convert_ascii_to_dc;
?? TITLE := 'convert_binary_record_16_to_12', EJECT ??

{ PURPOSE:
{   This procedure converts the data from 12-bits in 16-bit group format to 12-bits in 12-bit group format.

  PROCEDURE convert_binary_record_16_to_12
    (    input_data_size: integer;
     VAR data_seq_p: ^SEQ ( * );
     VAR new_data_size: integer);

    VAR
      data_amount_left: integer,
      c170_77_table_p: ^dst$c170_77_table,
      converted_size: integer,
      data_left_p: ^SEQ ( * ),
      data_p: ^SEQ ( * ),
      new_data_p: ^SEQ ( * ),
      unpacked_77_table_size: integer;

    RESET v$crebff_data.scratch_area_p;
    RESET data_seq_p;

    { Convert the 77 table first.

    unpacked_77_table_size := #SIZE (dst$c170_77_table) + ((#SIZE (dst$c170_77_table) DIV 12) * 4);
    convert_data_16_to_12 (unpacked_77_table_size, data_seq_p, v$crebff_data.scratch_area_p, converted_size);
    data_amount_left := input_data_size - unpacked_77_table_size;
    new_data_size := converted_size;

    RESET v$crebff_data.scratch_area_p;
    NEXT c170_77_table_p IN v$crebff_data.scratch_area_p;
    IF c170_77_table_p^.program_flag <> 10(8) THEN

      { Convert the rest of the component.

      convert_data_16_to_12 (data_amount_left, data_seq_p, v$crebff_data.scratch_area_p, converted_size);
      new_data_size := new_data_size + converted_size;
    ELSE

      { Move the rest of the component to the conversion area.

      NEXT data_left_p: [[REP data_amount_left OF cell]] IN data_seq_p;
      NEXT data_p: [[REP data_amount_left OF cell]] IN v$crebff_data.scratch_area_p;
      data_p^ := data_left_p^;
      new_data_size := new_data_size + data_amount_left;
    IFEND;

    { Move the converted data back to the input sequence.

    RESET v$crebff_data.scratch_area_p;
    RESET data_seq_p;
    NEXT data_p: [[REP new_data_size OF cell]] IN v$crebff_data.scratch_area_p;
    NEXT new_data_p: [[REP new_data_size OF cell]] IN data_seq_p;
    new_data_p^ := data_p^;
    RESET v$crebff_data.scratch_area_p;
    RESET data_seq_p;

  PROCEND convert_binary_record_16_to_12;
?? TITLE := 'convert_binary_record_12_to_16', EJECT ??

{ PURPOSE:
{   This procedure converts a record from data groups of twelve bits of data stored in twelve bit groups
{   to twelve bits of data stored right-justified in sixteen bit groups.

  PROCEDURE convert_binary_record_12_to_16
    (    file_format: clt$keyword;
         link_p: ^t$mdf_record_link;
     VAR output_data_seq_p: ^SEQ ( * );
     VAR enlarged_data_size: integer);

    VAR
      add_bytes_index: 0 .. 0f(16),
      conversion_data_index: integer,
      conversion_data_p: ^PACKED ARRAY [1 .. *] OF 0 .. 0f(16),
      extra_byte_p: ^0 .. 0ff(16),
      extra_bytes: 0 .. 0f(16),
      half_byte_index: 0 .. 4,
      bytes_to_convert: integer,
      record_data_index: integer,
      record_data_p: ^PACKED ARRAY [1 .. *] OF 0 .. 0f(16);

    RESET output_data_seq_p;

    { Find the number of bytes to convert.

    IF link_p^.convert_binary_data THEN
      bytes_to_convert := link_p^.size;
    ELSE     {convert only the 77 header.
      bytes_to_convert := #SIZE (dst$c170_77_table);
    IFEND;

    { Convert the data needed to be converted.  The new record size (which is defined in bytes) is
    { found by adding up how many 16-bit units are needed to fit the 12-bit chunks.

    enlarged_data_size := ((((bytes_to_convert * 8) + 11) DIV 12) * 16) DIV 8;
    IF link_p^.convert_binary_data AND (file_format = 'CIP_FILE') THEN
      enlarged_data_size := enlarged_data_size + (15 - (enlarged_data_size MOD 15));
    IFEND;

    NEXT record_data_p: [1 .. (bytes_to_convert * 2)] IN v$crebff_data.record_list_p;
    NEXT conversion_data_p: [1 .. (enlarged_data_size * 2)] IN output_data_seq_p;

    record_data_index := 1;
    conversion_data_index := 1;
    half_byte_index := 0;
    WHILE (record_data_index <= (bytes_to_convert * 2)) DO
      CASE half_byte_index OF
      = 0 =
        conversion_data_p^ [conversion_data_index] := 0;
      ELSE
        conversion_data_p^ [conversion_data_index] := record_data_p^ [record_data_index];
        record_data_index := record_data_index + 1;
      CASEND;
      conversion_data_index := conversion_data_index + 1;
      half_byte_index := (half_byte_index + 1) MOD 4;
    WHILEND;
    FOR record_data_index := conversion_data_index TO (enlarged_data_size * 2) DO
      conversion_data_p^ [record_data_index] := 0;
    FOREND;

    { Move the rest of the hex code from the record list to the conversion area.

    IF NOT link_p^.convert_binary_data THEN
      NEXT record_data_p: [1 .. ((link_p^.size - bytes_to_convert) * 2)] IN v$crebff_data.record_list_p;
      NEXT conversion_data_p: [1 .. ((link_p^.size - bytes_to_convert) * 2)] IN output_data_seq_p;
      enlarged_data_size := enlarged_data_size + (link_p^.size - bytes_to_convert);
      conversion_data_p^ := record_data_p^;
    IFEND;

    { For a CIP file, the data must be rounded to a record size that is divisible by both 8 and by 60
    { because the data must fit in 8-bit NOS/VE bytes and 60-bit NOS words.  There are 15 8-bit bytes
    { in 2 60-bit words.

    IF file_format = 'CIP_FILE' THEN
      extra_bytes := enlarged_data_size MOD 15;
      IF extra_bytes > 0 THEN
        FOR add_bytes_index := 1 TO (15 - extra_bytes) DO
          NEXT extra_byte_p IN output_data_seq_p;
          extra_byte_p^ := 0;
        FOREND;
        enlarged_data_size := enlarged_data_size + (15 - extra_bytes);
      IFEND;
    IFEND;

    RESET output_data_seq_p;

  PROCEND convert_binary_record_12_to_16;
?? TITLE := 'convert_data_16_to_12', EJECT ??

{ PURPOSE:
{   This procedure converts a record from data groups of 12-bits of data stored right-justified in 16-bit
{   groups to data groups of 12-bits of data stored in 12-bit groups.

  PROCEDURE convert_data_16_to_12
    (    amount_to_shrink: integer;
     VAR input_data_seq_p: ^SEQ ( * );
     VAR output_data_seq_p: ^SEQ ( * );
     VAR output_data_size: integer);

    VAR
      conversion_data_index: integer,
      conversion_data_p: ^PACKED ARRAY [1 .. *] OF 0 .. 0f(16),
      half_byte_index: 0 .. 4,
      record_data_index: integer,
      record_data_p: ^PACKED ARRAY [1 .. *] OF 0 .. 0f(16);

    NEXT record_data_p: [1 .. (amount_to_shrink * 2)] IN input_data_seq_p;
    NEXT conversion_data_p: [1 .. (amount_to_shrink * 2)] IN output_data_seq_p;
    record_data_index := 1;
    conversion_data_index := 1;
    half_byte_index := 0;
    WHILE (record_data_index <= (amount_to_shrink * 2)) DO
      CASE half_byte_index OF
      = 0 =

        { Skip over the half byte of zero.

      ELSE
        conversion_data_p^ [conversion_data_index] := record_data_p^ [record_data_index];
        conversion_data_index := conversion_data_index + 1;
        conversion_data_p^ [conversion_data_index] := 0;
      CASEND;
      record_data_index := record_data_index + 1;
      half_byte_index := (half_byte_index + 1) MOD 4;
    WHILEND;
    output_data_size := conversion_data_index DIV 2;

  PROCEND convert_data_16_to_12;
?? TITLE := 'convert_dc_to_ascii', EJECT ??

{ PURPOSE:
{   This procedure converts a display code integer to an ascii string.

  PROCEDURE convert_dc_to_ascii
    (    display_code_string: ARRAY [1 .. *] OF t$mdf_display_code_character;
     VAR ascii_string: string ( * ));

    VAR
      string_index: 1 .. 256,
      string_length: 1 .. 256;

    ascii_string := ' ';

    IF UPPERBOUND (display_code_string) > STRLENGTH (ascii_string) THEN
      string_length := STRLENGTH (ascii_string);
    ELSE
      string_length := UPPERBOUND (display_code_string);
    IFEND;

    FOR string_index := LOWERBOUND (display_code_string) TO string_length DO
      ascii_string (string_index) := v$ascii_and_display_code [display_code_string [string_index]];
    FOREND;

  PROCEND convert_dc_to_ascii;
?? TITLE := 'create_record_link', EJECT ??

{ PURPOSE:
{   This procedure creates a record link in the record list according to the parameter values of
{   the command.  (placement = (after, before, replace) and destination).

  PROCEDURE create_record_link
    (    record_size: amt$transfer_count;
     VAR link_p: ^t$mdf_record_link;
     VAR add_record_data: t$mdf_add_record_data;
     VAR table_data_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      c170_77_header_p: ^dst$c170_77_table,
      data_p: ^t$mdf_record_data,
      search_link_p: ^t$mdf_record_link;

    status.normal := TRUE;

    search_record_list (add_record_data, search_link_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Save information needed to back out of the command if it fails.

    IF NOT add_record_data.saved_info.setup THEN
      add_record_data.saved_info.setup := TRUE;
      add_record_data.saved_info.placement := add_record_data.placement;
      add_record_data.saved_info.link_counter := v$crebff_data.link_counter;
      add_record_data.saved_info.link_data := search_link_p^;
    IFEND;

    IF add_record_data.placement = 'AFTER' THEN
      ALLOCATE link_p;
      link_p^.chain_p := search_link_p^.chain_p;
      search_link_p^.chain_p := link_p;
    ELSE {add_record_data.placement = 'REPLACE'
      link_p := search_link_p;
    IFEND;

    { Increase the link counter and change the placement/destination values so that any more
    { calls to this procedure during this command are treated as AFTERs.

    v$crebff_data.link_counter := v$crebff_data.link_counter + 1;
    link_p^.number := v$crebff_data.link_counter;
    add_record_data.placement := 'AFTER';
    add_record_data.destination.kind := clc$integer;
    add_record_data.destination.integer_value.value := v$crebff_data.link_counter;

    { Retrieve the information from the 77 table to store in the link header.

    IF record_size = 0 THEN
      link_p^.name := ' ';
      link_p^.id_name := ' ';
      link_p^.time := ' ';
      link_p^.date := ' ';
      link_p^.comment := ' ';
    ELSEIF record_size >= #SIZE (dst$c170_77_table) THEN
      RESET table_data_p;
      NEXT c170_77_header_p IN table_data_p;
      IF c170_77_header_p^.name = 7700(8) THEN
        find_77_table_data (c170_77_header_p^, link_p);
      ELSE
        find_text_record_data (link_p, table_data_p);
      IFEND;
    ELSE
      find_text_record_data (link_p, table_data_p);
    IFEND;

    { Fill in the data in the link.

    RESET v$crebff_data.record_list_p TO v$crebff_data.end_of_record_list_p;
    NEXT data_p IN v$crebff_data.record_list_p;
    link_p^.size := record_size;
    link_p^.data_p := data_p;
    link_p^.convert_for_nve_file := FALSE;
    link_p^.pack_for_cip_file := FALSE;
    link_p^.end_of_file := FALSE;

  PROCEND create_record_link;
?? TITLE := 'crebf_add_record', EJECT ??

{ PURPOSE:
{   This procedure executes the command ADD_RECORD.  It adds one or more records to the record list.
{   The input file could contain a CIP file, VDT, or a list of CTI records such as the PPs for the
{   NVE deadstart file.  This list would be contained in one file.  The input file could also contain
{   a single CTI record.  The input file must contain the 77 table structure.  However, the format of
{   the input file can be in either 12-bit format or 16-bit format.

  PROCEDURE crebf_add_record
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE add_record, add_records, addr (
{   input, i: file = $required
{   format, f: key
{       (cip_file_12_in_12, cf12) (cip_file_12_in_16, cf16) (nve_file, nf) (vdt_file, vf)
{     keyend = $required
{   placement, p: key
{       (after, a) (before, b) (replace, r)
{     keyend = after
{   destination, d: any of
{       key
{         (first, f) (last, l)
{       keyend
{       integer
{       name
{     anyend = last
{   eofs_to_read, etr: any of
{       key
{         (all, a)
{       keyend
{       integer 1 .. 1000
{     anyend = all
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type4: 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 .. 4] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type5: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (3),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 22, 12, 54, 37, 603],
    clc$command, 11, 6, 2, 0, 0, 0, 6, ''], [
    ['D                              ',clc$abbreviation_entry, 4],
    ['DESTINATION                    ',clc$nominal_entry, 4],
    ['EOFS_TO_READ                   ',clc$nominal_entry, 5],
    ['ETR                            ',clc$abbreviation_entry, 5],
    ['F                              ',clc$abbreviation_entry, 2],
    ['FORMAT                         ',clc$nominal_entry, 2],
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['P                              ',clc$abbreviation_entry, 3],
    ['PLACEMENT                      ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$required_parameter, 0, 0],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 204,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 5
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 6
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [8], [
    ['CF12                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CF16                           ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['CIP_FILE_12_IN_12              ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['CIP_FILE_12_IN_16              ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['NF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['NVE_FILE                       ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['VDT_FILE                       ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['VF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4]]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [6], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['AFTER                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['BEFORE                         ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['REPLACE                        ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ,
    'after'],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type, clc$name_type],
    FALSE, 3],
    155, [[1, 0, clc$keyword_type], [4], [
      ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['FIRST                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['LAST                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'last'],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, 1000, 10]]
    ,
    'all'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$input = 1,
      p$format = 2,
      p$placement = 3,
      p$destination = 4,
      p$eofs_to_read = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      add_record_data: t$mdf_add_record_data,
      c170_77_table_p: ^dst$c170_77_table,
      convert_for_nve_file: boolean,
      file_identifier: amt$file_identifier,
      file_length: amt$file_length,
      file_segment_pointer: amt$segment_pointer,
      first_time: boolean,
      ignore_status: ost$status,
      input_data_p: ^SEQ ( * ),
      link_p: ^t$mdf_record_link,
      new_size: integer,
      pp_data_size: integer,
      record_77_table_p: ^dst$c170_77_table,
      record_data_p: ^SEQ ( * ),
      table_seq_p: ^SEQ ( * ),
      two_byte_p: ^0 .. 0ffff(16),
      unpacked_77_table_size: integer;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Retrieve the parameter values.

    add_record_data.file_name_p := pvt [p$input].value^.file_value;
    add_record_data.format := pvt [p$format].value^.keyword_value;
    add_record_data.placement := pvt [p$placement].value^.keyword_value;
    add_record_data.destination := pvt [p$destination].value^;
    IF pvt [p$eofs_to_read].value^.kind = clc$keyword THEN
      add_record_data.eof_data.read_all_eofs := TRUE;
    ELSE
      add_record_data.eof_data.read_all_eofs := FALSE;
      add_record_data.eof_data.eofs_to_read := pvt [p$eofs_to_read].value^.integer_value;
    IFEND;
    add_record_data.saved_info.setup := FALSE;

    { Add the CIP file to the record list.

    IF (add_record_data.format = 'CIP_FILE_12_IN_12') OR (add_record_data.format = 'CIP_FILE_12_IN_16') THEN
      add_cip_file (add_record_data, status);
      RETURN;
    IFEND;

    { Add the NVE or VDT file to the record list.

  /read_file/
    BEGIN
      open_file (c$mdf_open_for_read, c$mdf_segment_access, add_record_data.file_name_p, file_identifier,
            file_segment_pointer, file_length, status);
      IF NOT status.normal THEN
        EXIT /read_file/;
      IFEND;
      RESET file_segment_pointer.sequence_pointer;
      first_time := TRUE;
      unpacked_77_table_size := #SIZE (dst$c170_77_table) + ((#SIZE (dst$c170_77_table) DIV 12) * 4);

     /move_binaries/
      REPEAT

        { Check to see if the 77 table must be converted from 16 bit format to 12 bit format.

        IF file_length < #SIZE (dst$c170_77_table) THEN
          osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_record,
                add_record_data.format, status);
          EXIT /read_file/;
        IFEND;
        NEXT two_byte_p IN file_segment_pointer.sequence_pointer;
        RESET file_segment_pointer.sequence_pointer TO two_byte_p;
        IF two_byte_p^ = 0fc0(16) THEN
          IF unpacked_77_table_size > file_length THEN
            osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_record,
                  add_record_data.format, status);
            EXIT /read_file/;
          IFEND;
          convert_for_nve_file := (add_record_data.format = 'NVE_FILE');
          RESET v$crebff_data.scratch_area_p;
          convert_data_16_to_12 (unpacked_77_table_size, file_segment_pointer.sequence_pointer,
                v$crebff_data.scratch_area_p, new_size);
          RESET v$crebff_data.scratch_area_p;
          NEXT c170_77_table_p IN v$crebff_data.scratch_area_p;
          file_length := file_length - unpacked_77_table_size;
        ELSEIF two_byte_p^ = 0fc00(16) THEN
          convert_for_nve_file := FALSE;
          NEXT c170_77_table_p IN file_segment_pointer.sequence_pointer;
          file_length := file_length - #SIZE (c170_77_table_p^);
        ELSE
          osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_record,
                add_record_data.format, status);
          EXIT /read_file/;
        IFEND;

        { If this is the first time through and reading a VDT then loop to read the first PP's
        { 77 table.  The first 77 table read is VDT's 77 table.

        IF first_time AND (add_record_data.format = 'VDT_FILE') THEN
          first_time := FALSE;
          CYCLE /move_binaries/;
        IFEND;

        { Create a link on the record list for the new record.

        table_seq_p := #SEQ (c170_77_table_p^);
        RESET table_seq_p;
        create_record_link (#SIZE (dst$c170_77_table), link_p, add_record_data, table_seq_p, status);
        IF NOT status.normal THEN
          EXIT /read_file/;
        IFEND;
        link_p^.convert_for_nve_file := convert_for_nve_file;

        { Move the 77 table to the record list.

        NEXT record_77_table_p IN v$crebff_data.record_list_p;
        record_77_table_p^ := c170_77_table_p^;
        IF c170_77_table_p^.table_type = dsc$6100_table THEN
          pp_data_size := (c170_77_table_p^.code_length - 1) * 8;
        ELSE
          pp_data_size := c170_77_table_p^.lwa * 8;
        IFEND;
        link_p^.size := link_p^.size + pp_data_size;

        { Move the PP data from the input file to the record list.

        IF pp_data_size > file_length THEN
          osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_record,
                add_record_data.format, status);
          EXIT /read_file/;
        IFEND;
        NEXT input_data_p: [[REP pp_data_size OF cell]] IN file_segment_pointer.sequence_pointer;
        NEXT record_data_p: [[REP pp_data_size OF cell]] IN v$crebff_data.record_list_p;
        record_data_p^ := input_data_p^;
        file_length := file_length - pp_data_size;

        link_p^.pack_for_cip_file := (add_record_data.format = 'NVE_FILE');

        NEXT v$crebff_data.end_of_record_list_p IN v$crebff_data.record_list_p;
      UNTIL file_length < #SIZE (dst$c170_77_table);    {/move_binaries/
    END /read_file/;

    cleanup_links_after_command (add_record_data, status);
    fsp$close_file (file_identifier, ignore_status);

  PROCEND crebf_add_record;
?? TITLE := 'crebf_compare_binary_record', EJECT ??

{ PURPOSE:
{   This procedure compares two of the records on the record list.  It first removes the 77 table before it
{   executes the compare.

  PROCEDURE crebf_compare_binary_record
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE compare_binary_record, combr (
{   record, r: any of
{       key
{         (first, f) (last, l)
{       keyend
{       integer
{       name
{     anyend = first
{   with, w: any of
{       key
{         (first, f) (last, l)
{       keyend
{       integer
{       name
{     anyend = last
{   error_limit, el: integer 0 .. amc$file_byte_limit = 100
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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 .. 4] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        default_value: string (5),
      recend,
      type2: 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 .. 4] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 28, 7, 53, 33, 250],
    clc$command, 9, 5, 0, 0, 0, 0, 5, ''], [
    ['EL                             ',clc$abbreviation_entry, 3],
    ['ERROR_LIMIT                    ',clc$nominal_entry, 3],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OUTPUT                         ',clc$nominal_entry, 4],
    ['R                              ',clc$abbreviation_entry, 1],
    ['RECORD                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['W                              ',clc$abbreviation_entry, 2],
    ['WITH                           ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 204,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 2
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 204,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type, clc$name_type],
    FALSE, 3],
    155, [[1, 0, clc$keyword_type], [4], [
      ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['FIRST                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['LAST                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'first'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type, clc$name_type],
    FALSE, 3],
    155, [[1, 0, clc$keyword_type], [4], [
      ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['FIRST                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['LAST                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'last'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, amc$file_byte_limit, 10],
    '100'],
{ PARAMETER 4
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$record = 1,
      p$with = 2,
      p$error_limit = 3,
      p$output = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      ba: amt$file_byte_address,
      c170_77_header_p: ^dst$c170_77_table,
      command_line: string (osc$max_string_size),
      command_line_length: integer,
      data_p: ^SEQ ( * ),
      data_size: integer,
      enable_echoing: boolean,
      file_length: amt$file_length,
      ignore_status: ost$status,
      record_file: ost$name,
      record_file_identifier: amt$file_identifier,
      record_link_p: ^t$mdf_record_link,
      search_data: t$mdf_add_record_data,
      unique_name: ost$unique_name,
      unused_file_segment_pointer: amt$segment_pointer,
      with_file: ost$name,
      with_file_identifier: amt$file_identifier,
      with_link_p: ^t$mdf_record_link;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    search_data.placement := 'AFTER';

   /compare_binary_record/
    BEGIN

      { Retrieve a pointer to the RECORD link in the list.

      search_data.destination := pvt [p$record].value^;
      search_record_list (search_data, record_link_p, status);
      IF NOT status.normal THEN
        EXIT /compare_binary_record/;
      IFEND;

      { Open a local file to hold the RECORD file without the 77 table.

      pmp$generate_unique_name (unique_name, status);
      record_file := unique_name.value;
      open_file (c$mdf_open_for_other_write, c$mdf_record_access, ^record_file, record_file_identifier,
            unused_file_segment_pointer, file_length, status);
      IF NOT status.normal THEN
        EXIT /compare_binary_record/;
      IFEND;

      { Remove the 77 table from the record and write the data to the local RECORD file.

      RESET v$crebff_data.record_list_p TO record_link_p^.data_p;
      NEXT c170_77_header_p IN v$crebff_data.record_list_p;
      data_size := record_link_p^.size - #SIZE (c170_77_header_p^);
      NEXT data_p: [[REP data_size OF cell]] IN v$crebff_data.record_list_p;
      amp$put_partial (record_file_identifier, data_p, data_size, ba, amc$start, status);
      IF NOT status.normal THEN
        EXIT /compare_binary_record/;
      IFEND;
      fsp$close_file (record_file_identifier, ignore_status);

      { Retrieve a pointer to the WITH link in the list.

      search_data.destination := pvt [p$with].value^;
      search_record_list (search_data, with_link_p, status);
      IF NOT status.normal THEN
        EXIT /compare_binary_record/;
      IFEND;

      { Open a local file to hold the WITH file without the 77 table.

      pmp$generate_unique_name (unique_name, status);
      with_file := unique_name.value;
      open_file (c$mdf_open_for_other_write, c$mdf_record_access, ^with_file, with_file_identifier,
            unused_file_segment_pointer, file_length, status);
      IF NOT status.normal THEN
        EXIT /compare_binary_record/;
      IFEND;

      { Remove the 77 table from the record and write the data to the local WITH file.

      RESET v$crebff_data.record_list_p TO with_link_p^.data_p;
      NEXT c170_77_header_p IN v$crebff_data.record_list_p;
      data_size := with_link_p^.size - #SIZE (c170_77_header_p^);
      NEXT data_p: [[REP data_size OF cell]] IN v$crebff_data.record_list_p;
      amp$put_partial (with_file_identifier, data_p, data_size, ba, amc$start, status);
      IF NOT status.normal THEN
        EXIT /compare_binary_record/;
      IFEND;
      fsp$close_file (with_file_identifier, ignore_status);

      { Call the system's COMPARE_FILE command to compare the files containing the records without 77 tables.

      enable_echoing := TRUE;
      STRINGREP (command_line, command_line_length, 'COMPARE_FILE F=', record_file, ' W=', with_file,
            ' EL=', pvt [p$error_limit].value^.integer_value.value, ' O=', pvt [p$output].value^.file_value^);

      clp$include_command (command_line (1, command_line_length), enable_echoing, status);

    END /compare_binary_record/;

    { Return the local files.

    amp$return (record_file, ignore_status);
    amp$return (with_file, ignore_status);

  PROCEND crebf_compare_binary_record;
?? TITLE := 'crebf_delete_record', EJECT ??

{ PURPOSE:
{   This procedure executes the command DELETE_RECORD.  It deletes a record from the record list.
{   It can delete a record, a list of records, and/or a range of records from the record list.

  PROCEDURE crebf_delete_record
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE delete_record, delr (
{   record_id, ri: any of
{       key
{         (all, a)
{       keyend
{       list of range of any of
{         key
{           (first, f) (last, l)
{         keyend
{         integer
{         name
{       anyend
{     anyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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 .. 2] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: 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 .. 4] of clt$keyword_specification,
              recend,
              type_size_2: clt$type_specification_size,
              element_type_spec_2: record
                header: clt$type_specification_header,
                qualifier: clt$integer_type_qualifier,
              recend,
              type_size_3: clt$type_specification_size,
              element_type_spec_3: record
                header: clt$type_specification_header,
                qualifier: clt$name_type_qualifier,
              recend,
            recend,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 22, 13, 2, 34, 648],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['RECORD_ID                      ',clc$nominal_entry, 1],
    ['RI                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 328,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    227, [[1, 0, clc$list_type], [211, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$range_type], [204],
          [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type, clc$name_type],
          FALSE, 3],
          155, [[1, 0, clc$keyword_type], [4], [
            ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
            ['FIRST                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
            ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
            ['LAST                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
            ],
          20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
          5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
          ]
        ]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$record_id = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      before_link_p: ^t$mdf_record_link,
      end_of_file: boolean,
      high_name_p: ^clt$data_value,
      link_counter: integer,
      link_p: ^t$mdf_record_link,
      list_p: ^clt$data_value,
      name_p: ^clt$data_value,
      search_link_p: ^t$mdf_record_link;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF v$crebff_data.top_link_p^.chain_p = NIL THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$empty_record_list, '', status);
      RETURN;
    IFEND;

    { If deleting all of the records then just delete the entire list and leave.

    IF pvt [p$record_id].value^.kind = clc$keyword THEN
      cleanup_linked_list;
      RETURN;
    IFEND;

    list_p := pvt [p$record_id].value;

  /delete_record/
    WHILE list_p <> NIL DO
      name_p := list_p^.element_value;
      list_p := list_p^.link;
      high_name_p := NIL;
      IF name_p^.high_value = name_p^.low_value THEN
        name_p := name_p^.low_value;
      ELSE
        high_name_p := name_p^.high_value;
        name_p := name_p^.low_value;
      IFEND;

      { Convert the keywords FIRST and LAST to the corresponding integers on the list.

      IF name_p^.kind = clc$keyword THEN
        IF name_p^.keyword_value = 'FIRST' THEN
          name_p^.kind := clc$integer;
          name_p^.integer_value.value := v$crebff_data.top_link_p^.chain_p^.number;
        ELSE  {name_p^.keyword_value = 'LAST'
          IF high_name_p <> NIL THEN
            osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_range, '', status);
            EXIT /delete_record/;
          IFEND;
          name_p^.kind := clc$integer;
          name_p^.integer_value.value := v$crebff_data.link_counter;
        IFEND;
      IFEND;

      { Search the record list for the record to be deleted.

      before_link_p := v$crebff_data.top_link_p;
      search_link_p := v$crebff_data.top_link_p^.chain_p;

     /search_for_record/
      WHILE TRUE DO
        IF search_link_p = NIL THEN
          osp$set_status_abnormal (dsc$display_processor_id, dse$record_not_found, '', status);
          EXIT /delete_record/;
        IFEND;
        IF name_p^.kind = clc$integer THEN
          IF search_link_p^.number = name_p^.integer_value.value THEN
            EXIT /search_for_record/;
          IFEND;
        ELSE  {name_p^.kind = clc$name
          IF search_link_p^.name = name_p^.name_value THEN
            EXIT /search_for_record/;
          IFEND;
        IFEND;
        before_link_p := search_link_p;
        search_link_p := search_link_p^.chain_p;
      WHILEND /search_for_record/;

      { If the name is a range, search the record list for the other record in the range.

      IF high_name_p <> NIL THEN
        IF high_name_p^.kind = clc$keyword THEN
          IF high_name_p^.keyword_value = 'FIRST' THEN
            high_name_p^.kind := clc$integer;
            high_name_p^.integer_value.value := v$crebff_data.top_link_p^.chain_p^.number;
          ELSE  {high_name_p^.keyword_value = 'LAST'
            high_name_p^.kind := clc$integer;
            high_name_p^.integer_value.value := v$crebff_data.link_counter;
          IFEND;
        IFEND;
        end_of_file := before_link_p^.end_of_file;

       /search_for_range/
        WHILE TRUE DO
          IF search_link_p = NIL THEN
            osp$set_status_abnormal (dsc$display_processor_id, dse$record_not_found, '', status);
            EXIT /delete_record/;
          IFEND;

          { The possiblity may exists that a range with an 'end of file' record in the middle of the
          { range may be deleted.  This 'end of file' must be attached to the record preceeding the
          { range to be deleted.

          IF NOT end_of_file THEN
            end_of_file := search_link_p^.end_of_file;
          IFEND;
          IF high_name_p^.kind = clc$integer THEN
            IF search_link_p^.number = high_name_p^.integer_value.value THEN
              EXIT /search_for_range/;
            IFEND;
          ELSE  {high_name_p^.kind = clc$name
            IF search_link_p^.name = high_name_p^.name_value THEN
              EXIT /search_for_range/;
            IFEND;
          IFEND;
          search_link_p := search_link_p^.chain_p;
        WHILEND /search_for_range/;
        search_link_p^.end_of_file := end_of_file;
      IFEND;

      { Delete the record(s).

      IF NOT before_link_p^.end_of_file THEN
        before_link_p^.end_of_file := search_link_p^.end_of_file;
      IFEND;
      before_link_p^.chain_p := search_link_p^.chain_p;
      v$crebff_data.top_link_p^.end_of_file := FALSE;

    WHILEND /delete_record/;

    IF v$crebff_data.top_link_p^.chain_p = NIL THEN
      cleanup_linked_list;
    ELSE
      link_p := v$crebff_data.top_link_p;
      link_counter := 0;
      WHILE link_p <> NIL DO
        link_p^.number := link_counter;
        link_counter := link_counter + 1;
        link_p := link_p^.chain_p;
      WHILEND;
      IF link_counter <> 0 THEN
        link_counter := link_counter - 1;
      IFEND;
      v$crebff_data.link_counter := link_counter;
    IFEND;

  PROCEND crebf_delete_record;
?? TITLE := 'crebf_display_record_contents', EJECT ??

{ PURPOSE:
{   This procedure creates a listing similar to the output from DISPLAY_FILE of the record without the
{   77 table.

  PROCEDURE crebf_display_record_contents
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_record_contents, disrc (
{   record, r: any of
{       key
{         (first, f) (last, l)
{       keyend
{       integer
{       name
{     anyend = last
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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 .. 4] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 22, 13, 4, 27, 641],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['R                              ',clc$abbreviation_entry, 1],
    ['RECORD                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 204,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type, clc$name_type],
    FALSE, 3],
    155, [[1, 0, clc$keyword_type], [4], [
      ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['FIRST                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['LAST                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'last'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$record = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      ba: amt$file_byte_address,
      c170_77_header_p: ^dst$c170_77_table,
      command_line: string (osc$max_string_size),
      command_line_length: integer,
      data_p: ^SEQ ( * ),
      data_size: integer,
      enable_echoing: boolean,
      file_length: amt$file_length,
      ignore_status: ost$status,
      record_file: ost$name,
      record_file_identifier: amt$file_identifier,
      record_link_p: ^t$mdf_record_link,
      search_data: t$mdf_add_record_data,
      unique_name: ost$unique_name,
      unused_file_segment_pointer: amt$segment_pointer;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    search_data.placement := 'AFTER';

   /display_record_contents/
    BEGIN

      { Retrieve a pointer to the RECORD link in the list.

      search_data.destination := pvt [p$record].value^;
      search_record_list (search_data, record_link_p, status);
      IF NOT status.normal THEN
        EXIT /display_record_contents/;
      IFEND;

      { Open a local file to hold the RECORD file without the 77 table.

      pmp$generate_unique_name (unique_name, status);
      record_file := unique_name.value;
      open_file (c$mdf_open_for_other_write, c$mdf_record_access, ^record_file, record_file_identifier,
            unused_file_segment_pointer, file_length, status);
      IF NOT status.normal THEN
        EXIT /display_record_contents/;
      IFEND;

      { Remove the 77 table from the record and write the data to the local RECORD file.

      RESET v$crebff_data.record_list_p TO record_link_p^.data_p;
      NEXT c170_77_header_p IN v$crebff_data.record_list_p;
      data_size := record_link_p^.size - #SIZE (c170_77_header_p^);
      NEXT data_p: [[REP data_size OF cell]] IN v$crebff_data.record_list_p;
      amp$put_partial (record_file_identifier, data_p, data_size, ba, amc$start, status);
      IF NOT status.normal THEN
        EXIT /display_record_contents/;
      IFEND;
      fsp$close_file (record_file_identifier, ignore_status);

      { Call the system's DISPLAY_FILE command to display the file containing the record without a 77 table.

      enable_echoing := TRUE;
      STRINGREP (command_line, command_line_length, 'DISPLAY_FILE I=', record_file, ' O=',
            pvt [p$output].value^.file_value^);

      clp$include_command (command_line (1, command_line_length), enable_echoing, status);

    END /display_record_contents/;

    { Return the local file.

    amp$return (record_file, ignore_status);

  PROCEND crebf_display_record_contents;
?? TITLE := 'crebf_display_records', EJECT ??

{ PURPOSE:
{   This procedure executes the command DISPLAY_RECORDS.  It displays all of the information about
{   the individual records on the record list.  This information was retrieved from the 77 tables.
{   It displays the list according to the display_option parameter.

  PROCEDURE crebf_display_records
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_records, disr (
{   display_option, do: any of
{       key
{         (all, a) (none, n)
{       keyend
{       list of key
{         (comment, c) (date, d) (length, l) (time, t)
{       keyend
{     anyend = all
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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 .. 4] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 8] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 22, 13, 22, 14, 26],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 1],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 494,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    155, [[1, 0, clc$keyword_type], [4], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    319, [[1, 0, clc$list_type], [303, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [8], [
        ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['COMMENT                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['DATE                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['LENGTH                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['TIME                           ', clc$nominal_entry, clc$normal_usage_entry, 4]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$display_option = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    TYPE
      display_types = (dt_comment, dt_date, dt_length, dt_time),
      display_types_set = SET OF display_types;

    VAR
      date: ost$date,
      display_control: clt$display_control,
      display_set: display_types_set,
      end_of_file_number: integer,
      ignore_status: ost$status,
      integer_string: ost$string,
      link_p: ^t$mdf_record_link,
      list_p: ^clt$data_value,
      option_p: ^clt$data_value,
      output_line: ost$string,
      ring_attributes: amt$ring_attributes,
      time: ost$time;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /display_records/
    BEGIN
      ring_attributes.r1 := #RING (^ring_attributes);
      ring_attributes.r2 := #RING (^ring_attributes);
      ring_attributes.r3 := #RING (^ring_attributes);
      clp$open_display_reference (pvt [p$output].value^.file_value^, ^new_page_procedure, fsc$list,
            ring_attributes, display_control, status);
      IF NOT status.normal THEN
        EXIT /display_records/;
      IFEND;
      display_control.page_length := 30;
      display_control.page_width := 80;

      { Retrieve the time and the date for the page header.

      pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, status);
      IF NOT status.normal THEN
        EXIT /display_records/;
      IFEND;
      v$page_header (1, *) := 'Display of a Binary Formatted File';
      v$page_header (100, 8) := time.hms;
      v$page_header (112, 8) := date.mdy;
      v$page_header (124, *) := 'PAGE';

      { Check to see that the record list has records to list.

      IF v$crebff_data.top_link_p^.chain_p = NIL THEN
        output_line.value := ' EMPTY RECORD LIST';
        output_line.size := 18;
        output_display_line (output_line, display_control, status);
        EXIT /display_records/;
      IFEND;

      { Define which options are to be displayed.

      display_set := $display_types_set [ ];
      IF pvt [p$display_option].value^.kind = clc$keyword THEN
        IF pvt [p$display_option].value^.keyword_value = 'ALL' THEN
          display_set := -display_set;
        IFEND;
      ELSE
        list_p := pvt [p$display_option].value;
        WHILE list_p <> NIL DO
          option_p := list_p^.element_value;
          list_p := list_p^.link;
          IF option_p^.keyword_value = 'COMMENT' THEN
            display_set := display_set + $display_types_set[dt_comment];
          ELSEIF option_p^.keyword_value = 'DATE' THEN
            display_set := display_set + $display_types_set[dt_date];
          ELSEIF option_p^.keyword_value = 'LENGTH' THEN
            display_set := display_set + $display_types_set[dt_length];
          ELSEIF option_p^.keyword_value = 'TIME' THEN
            display_set := display_set + $display_types_set[dt_time];
          IFEND;
        WHILEND;
      IFEND;

      { Display the record list header.

      output_line.value := '0';
      output_line.size := 3;
      output_line.value (output_line.size, 6) := 'NUMBER';
      output_line.size := output_line.size + 7;
      output_line.value (output_line.size, 4) := 'NAME';
      output_line.size := output_line.size + 8;
      output_line.value (output_line.size, 2) := 'ID';
      output_line.size := output_line.size + 5;
      IF dt_length IN display_set THEN
        output_line.value (output_line.size, 6) := 'LENGTH';
        output_line.size := output_line.size + 11;
      IFEND;
      IF dt_time IN display_set THEN
        output_line.value (output_line.size, 4) := 'TIME';
        output_line.size := output_line.size + 10;
      IFEND;
      IF dt_date IN display_set THEN
        output_line.value (output_line.size, 4) := 'DATE';
        output_line.size := output_line.size + 10;
      IFEND;
      IF dt_comment IN display_set THEN
        output_line.value (output_line.size, 7) := 'COMMENT';
        output_line.size := output_line.size + 7;
      IFEND;
      output_display_line (output_line, display_control, status);
      IF NOT status.normal THEN
        EXIT /display_records/;
      IFEND;

      { Display the record list body.

      output_line.value := '0';
      end_of_file_number := 1;
      link_p := v$crebff_data.top_link_p^.chain_p;
      WHILE link_p <> NIL DO
        IF link_p^.size > 0 THEN
          output_line.size := 3;
          clp$convert_integer_to_string (link_p^.number, 10 , FALSE, integer_string, status);
          IF NOT status.normal THEN
            EXIT /display_records/;
          IFEND;
          output_line.value (output_line.size, 6) := integer_string.value;
          output_line.size := output_line.size + 7;
          output_line.value (output_line.size, 7) := link_p^.name;
          output_line.size := output_line.size + 8;
          output_line.value (output_line.size, 4) := link_p^.id_name;
          output_line.size := output_line.size + 5;

          IF dt_length IN display_set THEN
            clp$convert_integer_to_string (link_p^.size, 10 , FALSE, integer_string, status);
            IF NOT status.normal THEN
              EXIT /display_records/;
            IFEND;
            output_line.value (output_line.size, 10) := integer_string.value;
            output_line.size := output_line.size + 11;
          IFEND;

          IF dt_time IN display_set THEN
            output_line.value (output_line.size, 10) := link_p^.time;
            output_line.size := output_line.size + 10;
          IFEND;

          IF dt_date IN display_set THEN
            output_line.value (output_line.size, 10) := link_p^.date;
            output_line.size := output_line.size + 10;
          IFEND;

          IF dt_comment IN display_set THEN
            output_line.value (output_line.size, 70) := link_p^.comment;
            output_line.size := output_line.size + 70;
          IFEND;

          output_display_line (output_line, display_control, status);
          IF NOT status.normal THEN
            EXIT /display_records/;
          IFEND;
        IFEND;

        IF link_p^.end_of_file THEN
          output_line.value := ' END OF FILE ';
          output_line.size := 14;
          clp$convert_integer_to_string (end_of_file_number, 10 , FALSE, integer_string, status);
          IF NOT status.normal THEN
            EXIT /display_records/;
          IFEND;
          output_line.value (output_line.size, integer_string.size) := integer_string.value;
          output_line.size := output_line.size + integer_string.size;
          output_display_line (output_line, display_control, status);
          IF NOT status.normal THEN
            EXIT /display_records/;
          IFEND;
          end_of_file_number := end_of_file_number + 1;
        IFEND;

        output_line.value (1, *) := ' ';
        link_p := link_p^.chain_p;
      WHILEND;
    END /display_records/;

    clp$close_display (display_control, ignore_status);

  PROCEND crebf_display_records;
?? TITLE := 'crebf_generate_file', EJECT ??

{ PURPOSE:
{   This procedure executes the command GENERATE_FILE.  It generates a new file from the contents of the
{   record list.  It generates the file according to the format parameter.  Some rounding may be necessary
{   for a CIP file.  Packing 12 bits into 16 bit groups is necessary for DATA_12_IN_16.  The NVE_FILE
{   contains just the records in the order they are on the record list.  However, the format of a record on
{   the NVE_FILE may be 12_in_12 OR 12_in_16.  VDT_FILE contains the same as NVE_FILE except that a main 77
{   table is added to the front of the list.  This 77 table contains the module name of VDT.  The records in
{   VDT are all in the 12_in_12 format.

  PROCEDURE crebf_generate_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE generate_file, genf (
{   output, o: file = $required
{   file_format, ff: key
{       (cip_file, cf) (nve_file, nf) (vdt_file, vf)
{     keyend = $required
{   data_format, df: key
{       (data_12_in_12, d12) (data_12_in_16, d16)
{     keyend = data_12_in_12
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (13),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 22, 13, 8, 56, 336],
    clc$command, 7, 4, 2, 0, 0, 0, 4, ''], [
    ['DATA_FORMAT                    ',clc$nominal_entry, 3],
    ['DF                             ',clc$abbreviation_entry, 3],
    ['FF                             ',clc$abbreviation_entry, 2],
    ['FILE_FORMAT                    ',clc$nominal_entry, 2],
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$required_parameter, 0, 0],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 13],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [6], [
    ['CF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CIP_FILE                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['NF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['NVE_FILE                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['VDT_FILE                       ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['VF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['D12                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['D16                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['DATA_12_IN_12                  ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['DATA_12_IN_16                  ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'data_12_in_12'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$file_format = 2,
      p$data_format = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      add_bytes_index: 1 .. 15,
      ba: amt$file_byte_address,
      convert_for_nve_file: boolean,
      data_p: ^t$mdf_record_data,
      extra_bytes: 1 .. 15,
      extra_byte_p: ^0 .. 0ff(16),
      file_identifier: amt$file_identifier,
      file_length: amt$file_length,
      ignore_status: ost$status,
      link_p: ^t$mdf_record_link,
      new_record_size: integer,
      open_type: t$mdf_type_of_open,
      record_data_p: ^SEQ ( * ),
      scratch_record_data_p: ^SEQ ( * ),
      term_option: amt$term_option,
      unused_file_segment_pointer: amt$segment_pointer,
      vdt_77_table: dst$c170_77_table,
      vdt_77_table_p: ^dst$c170_77_table,
      vdt_byte_count: integer;
?? NEWTITLE := 'check_generate_file_parameters', EJECT ??

{ PURPOSE:
{   This procedure checks the generate file parameters.

    PROCEDURE check_generate_file_parameters
      (    pvt_p: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;
      IF NOT which_parameter.specific THEN
        IF (pvt_p^ [p$file_format].value^.keyword_value = 'VDT_FILE') AND
              (pvt_p^ [p$data_format].value^.keyword_value = 'DATA_12_IN_16') THEN
              osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_vdt_format, '', status);
        IFEND;
      IFEND;

    PROCEND check_generate_file_parameters;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_generate_file_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF v$crebff_data.top_link_p^.chain_p = NIL THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$empty_record_list, ' ', status);
      RETURN;
    IFEND;
    term_option := amc$start;

  /generate_file/
    BEGIN
      IF pvt [p$file_format].value^.keyword_value = 'CIP_FILE' THEN
        open_type := c$mdf_open_for_cip_write;
      ELSE
        open_type := c$mdf_open_for_other_write;
      IFEND;
      open_file (open_type, c$mdf_record_access, pvt [p$output].value^.file_value, file_identifier,
            unused_file_segment_pointer, file_length, status);
      IF NOT status.normal THEN
        EXIT /generate_file/;
      IFEND;

      { If generating VDT, build and write the VDT 77 table to the output file.  The first record in the
      { list is expected to contain the 77 table for VDT.

      IF pvt [p$file_format].value^.keyword_value = 'VDT_FILE' THEN
        link_p := v$crebff_data.top_link_p^.chain_p;
        RESET v$crebff_data.record_list_p TO link_p^.data_p;
        NEXT data_p IN v$crebff_data.record_list_p;
        NEXT vdt_77_table_p IN v$crebff_data.record_list_p;
        vdt_77_table := vdt_77_table_p^;
        vdt_byte_count := 0;
        WHILE link_p <> NIL DO
          vdt_byte_count := vdt_byte_count + link_p^.size;
          link_p := link_p^.chain_p;
        WHILEND;
        vdt_77_table.lwa := vdt_byte_count DIV 8;
        amp$put_partial (file_identifier, #LOC (vdt_77_table), #SIZE (vdt_77_table), ba, term_option,
              status);
        IF NOT status.normal THEN
          EXIT /generate_file/;
        IFEND;
        term_option := amc$continue;
      IFEND;

      { Move the records to the output file.

      link_p := v$crebff_data.top_link_p^.chain_p;
      IF link_p^.chain_p = NIL THEN
        convert_for_nve_file := FALSE;
      ELSE
        convert_for_nve_file := link_p^.convert_for_nve_file;
      IFEND;
      WHILE link_p <> NIL DO
        IF link_p^.size <> 0 THEN
          RESET v$crebff_data.record_list_p TO link_p^.data_p;
          NEXT data_p IN v$crebff_data.record_list_p;

          { If necessary, convert the data to 12-bits in 16-bit groups.

          IF (pvt [p$data_format].value^.keyword_value = 'DATA_12_IN_16') OR convert_for_nve_file THEN
            convert_binary_record_12_to_16 (pvt [p$file_format].value^.keyword_value, link_p,
                  v$crebff_data.scratch_area_p, new_record_size);
            NEXT record_data_p: [[REP new_record_size OF cell]] IN v$crebff_data.scratch_area_p;
          ELSE

            { Copy a record from the record list, no conversion.

            IF (pvt [p$file_format].value^.keyword_value = 'CIP_FILE') AND link_p^.pack_for_cip_file THEN
              RESET v$crebff_data.scratch_area_p;
              NEXT record_data_p: [[REP link_p^.size OF cell]] IN v$crebff_data.record_list_p;
              NEXT scratch_record_data_p: [[REP link_p^.size OF cell]] IN v$crebff_data.scratch_area_p;
              scratch_record_data_p^ := record_data_p^;
              extra_bytes := link_p^.size MOD 15;
              new_record_size := link_p^.size;
              IF extra_bytes > 0 THEN
                FOR add_bytes_index := 1 TO (15 - extra_bytes) DO
                  NEXT extra_byte_p IN v$crebff_data.scratch_area_p;
                  extra_byte_p^ := 0;
                FOREND;
                new_record_size := new_record_size + (15 - extra_bytes);
              IFEND;
              RESET v$crebff_data.scratch_area_p;
              NEXT record_data_p: [[REP new_record_size OF cell]] IN v$crebff_data.scratch_area_p;
            ELSE
              NEXT record_data_p: [[REP link_p^.size OF cell]] IN v$crebff_data.record_list_p;
              new_record_size := link_p^.size;
            IFEND;
          IFEND;

          { Put the data on the file.

          IF pvt [p$file_format].value^.keyword_value = 'CIP_FILE' THEN
            amp$put_next (file_identifier, record_data_p, new_record_size, ba, status);
          ELSE
            amp$put_partial (file_identifier, record_data_p, new_record_size, ba, term_option, status);
            term_option := amc$continue;
          IFEND;
          IF NOT status.normal THEN
            EXIT /generate_file/;
          IFEND;
        IFEND;

        { If necessary, write an end of partition.  This is used to denote a NOS type EOF.

        IF link_p^.end_of_file THEN
          amp$write_end_partition (file_identifier, status);
          IF NOT status.normal THEN
            EXIT /generate_file/;
          IFEND;
        IFEND;

        link_p := link_p^.chain_p;
        IF link_p <> NIL THEN
          convert_for_nve_file := link_p^.convert_for_nve_file;
        IFEND;
      WHILEND;
    END /generate_file/;

    { Cleanup the record list if the write was successful.

    IF status.normal THEN
      cleanup_linked_list;
    IFEND;
    fsp$close_file (file_identifier, ignore_status);

  PROCEND crebf_generate_file;
?? TITLE := 'crebf_quit', EJECT ??

{ PURPOSE:
{   This procedure exits the CREATE_BINARY_FORMATTED_FILE utility.

  PROCEDURE crebf_quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE quit, qui ( )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 3, 22, 13, 9, 36, 890],
    clc$command, 0, 0, 0, 0, 0, 0, 0, '']];
?? FMT (FORMAT := ON) ??
?? POP ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_include (v$cbf_utility_name, status);

  PROCEND crebf_quit;
?? TITLE := 'decode_record_type', EJECT ??

{ PURPOSE:
{   This procedure decodes the record type from the c170_77_table.

  PROCEDURE decode_record_type
    (    c170_77_table: dst$c170_77_table;
     VAR id_name: t$mdf_id_name);

    CASE c170_77_table.table_type OF
    = dsc$3400_table =
      id_name := 'REL';
    = dsc$5000_table =
      id_name := 'OVL';
    = dsc$5100_table =
      id_name := 'ABS';
    = dsc$5200_table =
      id_name := 'PPU';
    = dsc$5300_table =
      id_name := 'ABS';
    = dsc$5400_table =
      id_name := 'ABS';
    = dsc$6000_table =
      id_name := 'CAP';
    = dsc$7000_table =
      id_name := 'OPLD';
    = dsc$7001_table =
      id_name := 'OPL';
    = dsc$7002_table =
      id_name := 'OPLC';
    = dsc$7600_table =
      id_name := 'ULIB';
    ELSE
      IF (c170_77_table.table_type = 5720(8)) AND (c170_77_table.proc_header = 221703(8)) THEN
        id_name := 'PROC';  {5720 2217 03 is display code for .PROC}
      ELSEIF (c170_77_table.nos_byte_1a <> 0) AND (c170_77_table.nos_byte_1b = 0) AND
            (c170_77_table.nos_byte_3 = 0) AND (c170_77_table.nos_byte_4 <> 0) THEN
        id_name := 'PP';
        IF (c170_77_table.table_type DIV 100(8) >= 1(8)) AND
              (c170_77_table.table_type DIV 100(8) <= 32(8)) AND (c170_77_table.nos_byte_2 = 0) THEN
          id_name := 'TEXT';
        IFEND;
      ELSE
        id_name := 'TEXT';
      IFEND;
    CASEND;

  PROCEND decode_record_type;
?? TITLE := 'find_77_table_data', EJECT ??

{ PURPOSE:
{   This procedure creates the record link parts from the 77 table.

  PROCEDURE find_77_table_data
    (    c170_77_table: dst$c170_77_table;
     VAR link_p: ^t$mdf_record_link);

    VAR
      comment_array: ARRAY [1 .. 70] OF t$mdf_display_code_character,
      date_time_array: ARRAY [1 .. 10] OF t$mdf_display_code_character,
      index: 1 .. 70;

    { Convert the module name from display code to ascii.

    convert_7_char_dc (c170_77_table.module_name, link_p^.name);

    { Find the type of record according to the table word is at the end of the 77 table.

    decode_record_type (c170_77_table, link_p^.id_name);

    { Convert the time from display code to ascii.

    date_time_array [1] := c170_77_table.time_fill;
    FOR index := 1 TO 9 DO
      date_time_array [index+1] := c170_77_table.time [index];
    FOREND;
    convert_dc_to_ascii (date_time_array, link_p^.time);

    { Convert the date name from display code to ascii.

    date_time_array [1] := c170_77_table.date_fill;
    FOR index := 1 TO 9 DO
      date_time_array [index+1] := c170_77_table.date [index];
    FOREND;
    convert_dc_to_ascii (date_time_array, link_p^.date);

    { Convert the comment from display code to ascii.

    FOR index := 1 TO 69 DO
      comment_array [index] := c170_77_table.comments [index];
    FOREND;
    comment_array [70] := c170_77_table.comment_fill;
    convert_dc_to_ascii (comment_array, link_p^.comment);

    { Determine if the binary data in the record could be converted to 12_in_16.

    link_p^.convert_binary_data :=
          NOT ((c170_77_table.length = 0E(16)) AND (c170_77_table.program_flag = 10(8)));

  PROCEND find_77_table_data;
?? TITLE := 'find_text_record_data', EJECT ??

{ PURPOSE:
{   This procedure creates the record link parts from the text data.

  PROCEDURE find_text_record_data
    (VAR link_p: ^t$mdf_record_link;
     VAR table_data_p: ^SEQ ( * ));

    VAR
      c170_77_table: dst$c170_77_table,
      index: 1 .. 7,
      nos_proc_p: ^PACKED RECORD
        unused: 0 .. 777777777777(8),
        seven_nos_character: PACKED ARRAY [1 .. 8] OF t$mdf_display_code_character,
      RECEND,
      record_name_array: ARRAY [1 .. 7] OF t$mdf_display_code_character,
      seven_nos_character_p: ^PACKED ARRAY [1 .. 8] OF t$mdf_display_code_character,
      table_word_p: ^PACKED RECORD
        table_type: dst$table_id,
        nos_byte_1a: 0 .. 77(8),
        nos_byte_1b: 0 .. 77(8),
        nos_byte_2: 0 .. 7777(8),
        nos_byte_3: 0 .. 7777(8),
        nos_byte_4: 0 .. 7777(8),
      RECEND;

    { Find the record type from the first word of the record.

    NEXT table_word_p IN table_data_p;
    c170_77_table.table_type := table_word_p^.table_type;
    c170_77_table.nos_byte_1a := table_word_p^.nos_byte_1a;
    c170_77_table.nos_byte_1b := table_word_p^.nos_byte_1b;
    c170_77_table.nos_byte_2 := table_word_p^.nos_byte_2;
    c170_77_table.nos_byte_3 := table_word_p^.nos_byte_3;
    c170_77_table.nos_byte_4 := table_word_p^.nos_byte_4;
    decode_record_type (c170_77_table, link_p^.id_name);

    { Fill the display code record name with display code blanks.

    FOR index := 1 TO 7 DO
      record_name_array [index] := 55(8);
    FOREND;

    { Find the record name according to the type of record.

    IF link_p^.id_name = 'PP' THEN
      record_name_array [1] := table_word_p^.table_type DIV 100(8);
      record_name_array [2] := table_word_p^.table_type MOD 100(8);
      record_name_array [3] := table_word_p^.nos_byte_1a;
      record_name_array [4] := table_word_p^.nos_byte_1b;

    ELSEIF link_p^.id_name = 'PROC' THEN
      RESET table_data_p;
      NEXT nos_proc_p IN table_data_p;
      /name_loop/
      FOR index := 1 TO 7 DO
        IF nos_proc_p^.seven_nos_character [index] > 44(8) THEN
          EXIT /name_loop/;      { Exit if the display code character is not 0-9 or A-Z.
        ELSE
          record_name_array [index] := nos_proc_p^.seven_nos_character [index];
        IFEND;
      FOREND /name_loop/;

    ELSE
      RESET table_data_p;
      NEXT seven_nos_character_p IN table_data_p;
      FOR index := 1 TO 7 DO
        record_name_array [index] := seven_nos_character_p^ [index];
      FOREND;
    IFEND;

    { Convert the record name from display code to ascii.

    convert_dc_to_ascii (record_name_array, link_p^.name);
    link_p^.time := ' ';
    link_p^.date := ' ';
    link_p^.comment := ' ';
    link_p^.convert_binary_data := TRUE;

  PROCEND find_text_record_data;
?? TITLE := 'format_idc_record', EJECT ??

{ PURPOSE:
{   This procedure reformats the IDC binary into a format that is understood by CTI.

  PROCEDURE format_idc_record
    (    input_file_name_p: ^fst$file_reference;
         output_file_name_p: ^fst$file_reference;
     VAR status: ost$status);

    VAR
      checksum: dst$pp_word,
      cm_word_length: dst$pp_word,
      comment_string: string (41),
      data_area_file: ost$name,
      data_area_file_identifier: amt$file_identifier,
      data_area_p: ^SEQ ( * ),
      data_p: ^SEQ ( * ),
      file_identifier: amt$file_identifier,
      file_length: amt$file_length,
      file_segment_pointer: amt$segment_pointer,
      ignore_status: ost$status,
      module_name: t$mdf_record_name,
      output_77_table_p: ^dst$c170_77_table,
      output_data_p: ^SEQ ( * ),
      packed_77_table: dst$c170_77_table,
      packed_77_table_seq_p: ^SEQ ( * ),
      unpacked_77_table_p: ^dst$c170_unpacked_77_table;

    status.normal := TRUE;

  /format_idc/
    BEGIN

      { Create the scratch file to be used as a data area.

      setup_scratch_file (data_area_file, data_area_file_identifier, data_area_p, status);
      IF NOT status.normal THEN
        EXIT /format_idc/;
      IFEND;

      open_file (c$mdf_open_for_read, c$mdf_segment_access, input_file_name_p, file_identifier,
            file_segment_pointer, file_length, status);
      IF NOT status.normal THEN
        EXIT /format_idc/;
      IFEND;
      RESET file_segment_pointer.sequence_pointer;

      { Read the 77 table from the input file.  This 77 table is unpacked.

      IF file_length < #SIZE (dst$c170_unpacked_77_table) THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_record, 'IDC record', status);
        EXIT /format_idc/;
      IFEND;
      NEXT unpacked_77_table_p IN file_segment_pointer.sequence_pointer;
      IF unpacked_77_table_p^.name <> 7700(8) THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_record, 'IDC record', status);
        EXIT /format_idc/;
      IFEND;
      file_length := file_length - #SIZE (unpacked_77_table_p^);

      { Build the packed 77 table.

      packed_77_table_seq_p := #SEQ (packed_77_table);
      pack_data (#SEQ (unpacked_77_table_p^), (#SIZE (packed_77_table) DIV 8), packed_77_table_seq_p,
            checksum);
      convert_7_char_dc (packed_77_table.module_name, module_name);
      comment_string := '*SMD* LVL=99 , LXXXSS_YYYY_MM_DD_HH_MM_SS';
      comment_string (11) := $CHAR (unpacked_77_table_p^.comments [2].character_1 + 25(8));
      comment_string (12) := $CHAR (unpacked_77_table_p^.comments [2].character_2 + 25(8));
      add_standard_77_table_parts (module_name, comment_string, packed_77_table);

      compute_cm_word_length (unpacked_77_table_p^.code_length, cm_word_length);
      packed_77_table.table_type := dsc$6100_table;
      packed_77_table.code_length := cm_word_length + 1;

      { Pack the binary code.

      IF file_length < ((unpacked_77_table_p^.code_length - 1) * 8) THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_record, 'IDC record', status);
        EXIT /format_idc/;
      IFEND;
      NEXT data_p: [[REP (unpacked_77_table_p^.code_length - 1) OF integer]] IN
            file_segment_pointer.sequence_pointer;
      file_length := file_length - #SIZE (data_p^);
      pack_data (data_p, cm_word_length, data_area_p, checksum);

      fsp$close_file (file_identifier, ignore_status);

      { Write the data to the Output File.

      open_file (c$mdf_open_for_other_write, c$mdf_segment_access, output_file_name_p, file_identifier,
            file_segment_pointer, file_length, status);
      IF NOT status.normal THEN
        EXIT /format_idc/;
      IFEND;
      RESET file_segment_pointer.sequence_pointer;
      RESET data_area_p;

      { Write the Main 77 table to the Output File.

      NEXT output_77_table_p IN file_segment_pointer.sequence_pointer;
      output_77_table_p^ := packed_77_table;

      { Write the binary data to the Output File.

      NEXT data_p: [[REP (cm_word_length * 8) OF cell]] IN data_area_p;
      NEXT output_data_p: [[REP (cm_word_length * 8) OF cell]] IN file_segment_pointer.sequence_pointer;
      output_data_p^ := data_p^;

      amp$set_segment_eoi (file_identifier, file_segment_pointer, status);
    END /format_idc/;

    fsp$close_file (file_identifier, ignore_status);
    fsp$close_file (data_area_file_identifier, ignore_status);
    amp$return (data_area_file, ignore_status);

  PROCEND format_idc_record;
?? TITLE := 'format_peripheral_processor', EJECT ??

{ PURPOSE:
{   This procedure reformats the PP binary into a format that is understood by CTI.

  PROCEDURE format_peripheral_processor
    (    input_file_name_p: ^fst$file_reference;
         output_file_name_p: ^fst$file_reference;
     VAR status: ost$status);

    VAR
      checksum: dst$pp_word,
      comment_string: string (41),
      data_area_file: ost$name,
      data_area_file_identifier: amt$file_identifier,
      data_area_p: ^SEQ ( * ),
      data_header_p: ^dst$pp_header_descriptor,
      data_p: ^SEQ ( * ),
      directory_file: ost$name,
      directory_file_identifier: amt$file_identifier,
      directory_header_p: ^dst$pp_header_descriptor,
      directory_index: dst$pp_word,
      directory_p: ^SEQ ( * ),
      directory_size: integer,
      file_identifier: amt$file_identifier,
      file_length: amt$file_length,
      file_segment_pointer: amt$segment_pointer,
      ignore_status: ost$status,
      module_name: t$mdf_record_name,
      output_77_table_p: ^dst$c170_77_table,
      output_data_p: ^SEQ ( * ),
      overlay_entry_p: ^dst$pp_header_descriptor,
      overlay_number: dst$pp_word,
      overlay_offset: dst$pp_word,
      overlay_size: integer,
      packed_77_table: dst$c170_77_table,
      packed_77_table_seq_p: ^SEQ ( * ),
      resident_size: integer,
      unpacked_77_table_p: ^dst$c170_unpacked_77_table;

    status.normal := TRUE;

  /format_pp/
    BEGIN

      { Create the scratch file to be used as a data area.

      setup_scratch_file (data_area_file, data_area_file_identifier, data_area_p, status);
      IF NOT status.normal THEN
        EXIT /format_pp/;
      IFEND;

      { Create the scratch file to be used to contain the directory.

      setup_scratch_file (directory_file, directory_file_identifier, directory_p, status);
      IF NOT status.normal THEN
        EXIT /format_pp/;
      IFEND;

      open_file (c$mdf_open_for_read, c$mdf_segment_access, input_file_name_p, file_identifier,
            file_segment_pointer, file_length, status);
      IF NOT status.normal THEN
        EXIT /format_pp/;
      IFEND;
      RESET file_segment_pointer.sequence_pointer;

      { Setup the Directory Header.

      NEXT directory_header_p IN directory_p;
      directory_header_p^.load_address := 0;
      directory_header_p^.cm_word_length := 1;
      directory_header_p^.overlay_number := 0;
      directory_header_p^.checksum := 0;
      overlay_offset := 0;

      { Read the Resident 77 table from the input file.  This 77 table is unpacked.

      IF file_length < #SIZE (dst$c170_unpacked_77_table) THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_record, 'pp binary', status);
        EXIT /format_pp/;
      IFEND;
      NEXT unpacked_77_table_p IN file_segment_pointer.sequence_pointer;
      IF unpacked_77_table_p^.name <> 7700(8) THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_record, 'pp binary', status);
        EXIT /format_pp/;
      IFEND;
      file_length := file_length - #SIZE (unpacked_77_table_p^);

      { Build the packed 77 table.

      packed_77_table_seq_p := #SEQ (packed_77_table);
      pack_data (#SEQ (unpacked_77_table_p^), (#SIZE (packed_77_table) DIV 8), packed_77_table_seq_p,
            checksum);
      convert_7_char_dc (packed_77_table.module_name, module_name);
      comment_string := '*SMD* LVL=99 , LXXXSS_YYYY_MM_DD_HH_MM_SS';
      comment_string (11) := $CHAR (unpacked_77_table_p^.comments [2].character_1 + 25(8));
      comment_string (12) := $CHAR (unpacked_77_table_p^.comments [2].character_2 + 25(8));
      add_standard_77_table_parts (module_name, comment_string, packed_77_table);

      { Setup the Resident Header.

      NEXT data_header_p IN data_area_p;
      data_header_p^.load_address := unpacked_77_table_p^.load_address;
      compute_cm_word_length (unpacked_77_table_p^.code_length, data_header_p^.cm_word_length);
      packed_77_table.lwa := data_header_p^.cm_word_length + 1;
      data_header_p^.overlay_number := 0;

      overlay_offset := data_header_p^.cm_word_length + 1;

      { Pack the Resident code, find the checksum and store it in the Resident Header.

      IF file_length < ((unpacked_77_table_p^.code_length - 1) * 8) THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_record, 'pp binary', status);
        EXIT /format_pp/;
      IFEND;
      NEXT data_p: [[REP (unpacked_77_table_p^.code_length - 1) OF integer]] IN
            file_segment_pointer.sequence_pointer;
      file_length := file_length - #SIZE (data_p^);
      pack_data (data_p, data_header_p^.cm_word_length, data_area_p, data_header_p^.checksum);
      resident_size := #SIZE (data_header_p^) + (data_header_p^.cm_word_length * 8);

      { Process the Overlays.

      overlay_number := 1;
      overlay_size := 0;
      WHILE file_length > 0 DO

        { Read the Overlay 77 table from the input file.  This 77 table is unpacked.

        IF file_length < #SIZE (dst$c170_unpacked_77_table) THEN
          osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_record, 'pp binary', status);
          EXIT /format_pp/;
        IFEND;
        NEXT unpacked_77_table_p IN file_segment_pointer.sequence_pointer;
        file_length := file_length - #SIZE (unpacked_77_table_p^);

        { Setup the Overlay Header.

        NEXT data_header_p IN data_area_p;
        data_header_p^.load_address := unpacked_77_table_p^.load_address;
        compute_cm_word_length (unpacked_77_table_p^.code_length, data_header_p^.cm_word_length);
        packed_77_table.lwa := packed_77_table.lwa + data_header_p^.cm_word_length + 1;
        data_header_p^.overlay_number := overlay_number;
        overlay_number := overlay_number + 1;

        { Setup the Directory Entry for the Overlay.

        NEXT overlay_entry_p IN directory_p;
        directory_header_p^.cm_word_length := directory_header_p^.cm_word_length + 1;
        overlay_entry_p^ := data_header_p^;
        overlay_entry_p^.overlay_offset := overlay_offset;

        overlay_offset := overlay_offset + data_header_p^.cm_word_length + 1;

        { Pack the Overlay code, find the checksum and store it in the Overlay Header.

        IF file_length < ((unpacked_77_table_p^.code_length - 1) * 8) THEN
          osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_record, 'pp binary', status);
          EXIT /format_pp/;
        IFEND;
        NEXT data_p: [[REP (unpacked_77_table_p^.code_length - 1) OF integer]] IN
              file_segment_pointer.sequence_pointer;
        file_length := file_length - #SIZE (data_p^);
        pack_data (data_p, data_header_p^.cm_word_length, data_area_p, data_header_p^.checksum);
        overlay_size := overlay_size + #SIZE (data_header_p^) + (data_header_p^.cm_word_length * 8);
      WHILEND;
      fsp$close_file (file_identifier, ignore_status);

      { Complete the offset in the directory entries.

      IF directory_header_p^.cm_word_length > 1 THEN
        packed_77_table.lwa := packed_77_table.lwa + directory_header_p^.cm_word_length;

        RESET directory_p;
        NEXT directory_header_p IN directory_p;
        directory_size := directory_header_p^.cm_word_length * 8;
        directory_header_p^.cm_word_length := directory_header_p^.cm_word_length - 1;
        FOR directory_index := 1 TO directory_header_p^.cm_word_length DO
          NEXT overlay_entry_p IN directory_p;
          overlay_entry_p^.overlay_offset := overlay_entry_p^.overlay_offset +
                directory_header_p^.cm_word_length + 1;
        FOREND;
      ELSE
        directory_size := 0;
      IFEND;

      { Write the data to the Output File.

      open_file (c$mdf_open_for_other_write, c$mdf_segment_access, output_file_name_p, file_identifier,
            file_segment_pointer, file_length, status);
      IF NOT status.normal THEN
        EXIT /format_pp/;
      IFEND;
      RESET file_segment_pointer.sequence_pointer;
      RESET data_area_p;
      RESET directory_p;

      { Write the Main 77 table to the Output File.

      NEXT output_77_table_p IN file_segment_pointer.sequence_pointer;
      output_77_table_p^ := packed_77_table;

      { Write the Resident header and data to the Output File.

      NEXT data_p: [[REP resident_size OF cell]] IN data_area_p;
      NEXT output_data_p: [[REP resident_size OF cell]] IN file_segment_pointer.sequence_pointer;
      output_data_p^ := data_p^;

      { Write the Directory header and data to the Output File.

      IF directory_size > 0 THEN
        NEXT data_p: [[REP directory_size OF cell]] IN directory_p;
        NEXT output_data_p: [[REP directory_size OF cell]] IN file_segment_pointer.sequence_pointer;
        output_data_p^ := data_p^;
      IFEND;

      { Write the Overlay headers and data to the Output File.

      IF overlay_size > 0 THEN
        NEXT data_p: [[REP overlay_size OF cell]] IN data_area_p;
        NEXT output_data_p: [[REP overlay_size OF cell]] IN file_segment_pointer.sequence_pointer;
        output_data_p^ := data_p^;
      IFEND;

      amp$set_segment_eoi (file_identifier, file_segment_pointer, status);
    END /format_pp/;

    fsp$close_file (file_identifier, ignore_status);
    fsp$close_file (data_area_file_identifier, ignore_status);
    amp$return (data_area_file, ignore_status);
    fsp$close_file (directory_file_identifier, ignore_status);
    amp$return (directory_file, ignore_status);

  PROCEND format_peripheral_processor;
?? TITLE := 'format_ve_cpu_boot', EJECT ??

{ PURPOSE:
{   This procedure formats a VE binary record for the NVE deadstart file.  It expects
{   as input a file containing a memory image (VCB or EI).

  PROCEDURE format_ve_binary
    (    module_name: t$mdf_record_name;
         input_file_name_p: ^fst$file_reference;
         output_file_name_p: ^fst$file_reference;
     VAR status: ost$status);

    TYPE
      binary_version_word = RECORD
        unused: 0 .. 0ffffffffffffff(16),
        version: 0 .. 0ff(16),
      RECEND;

    VAR
      file_length: amt$file_length,
      ignore_status: ost$status,
      input_data_p: ^SEQ ( * ),
      input_file_identifier: amt$file_identifier,
      input_file_segment_pointer: amt$segment_pointer,
      left_over_bytes: 0 .. 8,
      memory_image_header_p: ^pmt$memory_image_header,
      output_data_p: ^SEQ ( * ),
      output_file_identifier: amt$file_identifier,
      output_file_segment_pointer: amt$segment_pointer,
      output_77_table_p: ^dst$c170_77_table,
      output_version_word_p: ^binary_version_word,
      unused_file_length: amt$file_length,
      version_word_p: ^binary_version_word;

    status.normal := TRUE;

  /format_binary/
    BEGIN
      open_file (c$mdf_open_for_read, c$mdf_segment_access, input_file_name_p, input_file_identifier,
            input_file_segment_pointer, file_length, status);
      IF NOT status.normal THEN
        EXIT /format_binary/;
      IFEND;
      RESET input_file_segment_pointer.sequence_pointer;
      IF file_length < (#SIZE (pmt$memory_image_header) + #SIZE (binary_version_word)) THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_record, 'memory image', status);
        EXIT /format_binary/;
      IFEND;

      open_file (c$mdf_open_for_other_write, c$mdf_segment_access, output_file_name_p, output_file_identifier,
            output_file_segment_pointer, unused_file_length, status);
      IF NOT status.normal THEN
        EXIT /format_binary/;
      IFEND;
      RESET output_file_segment_pointer.sequence_pointer;

      { Read the Memory Image Header from the input file and discard, it is not written to the output file.

      NEXT memory_image_header_p IN input_file_segment_pointer.sequence_pointer;

      { Read the Version word from the input file and use it to build the 77 table for the VE binary.
      { Write the 77 table and the version word to the output file.

      NEXT output_77_table_p IN output_file_segment_pointer.sequence_pointer;
      NEXT version_word_p IN input_file_segment_pointer.sequence_pointer;
      NEXT output_version_word_p IN output_file_segment_pointer.sequence_pointer;
      output_version_word_p^ := version_word_p^;
      build_77_table (module_name, version_word_p^.version, output_77_table_p^, status);
      IF NOT status.normal THEN
        EXIT /format_binary/;
      IFEND;
      output_77_table_p^.lwa := (file_length - #SIZE (pmt$memory_image_header) + 7) DIV 8;

      { Copy the rest of the data from the input file to the output file.

      file_length := file_length - #SIZE (pmt$memory_image_header) - #SIZE (binary_version_word);
      IF file_length <= 0 THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_record, 'memory image', status);
        EXIT /format_binary/;
      IFEND;
      NEXT input_data_p: [[REP file_length OF cell]] IN input_file_segment_pointer.sequence_pointer;
      NEXT output_data_p: [[REP file_length OF cell]] IN output_file_segment_pointer.sequence_pointer;
      output_data_p^ := input_data_p^;

      { Make sure that the data after the 77 table ends on a word boundary.

      left_over_bytes := file_length MOD 8;
      IF left_over_bytes > 0 THEN
        NEXT output_data_p: [[REP left_over_bytes OF cell]] in output_file_segment_pointer.sequence_pointer;
      IFEND;
      amp$set_segment_eoi (output_file_identifier, output_file_segment_pointer, status);
    END /format_binary/;

    fsp$close_file (output_file_identifier, ignore_status);
    fsp$close_file (input_file_identifier, ignore_status);

  PROCEND format_ve_binary;
?? TITLE := 'mandf_change_attribute', EJECT ??

{ PURPOSE:
{   This procedure is called by the command 'CHANGE_ATTRIBUTE'.  This procedure allows the user to change
{   several attribute values.  These values will remain for the life of the utility.

  PROCEDURE mandf_change_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE change_attribute, change_attributes, chaa (
{   bcu_level, bl: integer 0..0ff(16) = $optional
{   psr_level, pl: integer 0..0fff(16) = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 22, 13, 10, 46, 265],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['BCU_LEVEL                      ',clc$nominal_entry, 1],
    ['BL                             ',clc$abbreviation_entry, 1],
    ['PL                             ',clc$abbreviation_entry, 2],
    ['PSR_LEVEL                      ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 0ff(16), 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, 0fff(16), 10]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$bcu_level = 1,
      p$psr_level = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      integer_string: ost$string,
      mandf_index: 0 .. 0ff(16),
      string_index: 0 .. 0ff(16);

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$bcu_level].specified THEN
      clp$convert_integer_to_string (pvt [p$bcu_level].value^.integer_value.value, 10, FALSE,
            integer_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      mandf_index := #SIZE (v$mandf_chaa_bcu_level);
      string_index := integer_string.size;
      REPEAT
        v$mandf_chaa_bcu_level (mandf_index) := integer_string.value (string_index);
        mandf_index := mandf_index - 1;
        string_index := string_index - 1;
      UNTIL (mandf_index = 0) OR (string_index = 0);
      FOR string_index := 1 TO mandf_index DO
        v$mandf_chaa_bcu_level (string_index) := '0';
      FOREND;
    IFEND;

    IF pvt [p$psr_level].specified THEN
      clp$convert_integer_to_string (pvt [p$psr_level].value^.integer_value.value, 10, FALSE,
            integer_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      mandf_index := #SIZE (v$mandf_chaa_psr_level);
      string_index := integer_string.size;
      REPEAT
        v$mandf_chaa_psr_level (mandf_index) := integer_string.value (string_index);
        mandf_index := mandf_index - 1;
        string_index := string_index - 1;
      UNTIL (mandf_index = 0) OR (string_index = 0);
      FOR string_index := 1 TO mandf_index DO
        v$mandf_chaa_psr_level (string_index) := '0';
      FOREND;
    IFEND;

  PROCEND mandf_change_attribute;
?? TITLE := 'mandf_create_binary_file', EJECT ??

{ PURPOSE:
{   This procedure contains the starting procedure for the sub utility CREATE_BINARY_FORMATTED_FILE which
{   is used to create binary formatted files.  The output file could be a CIP file, VDT, or a list of CTI
{   records such as the PPs for the NVE deadstart file.  It is also used to convert a PP record's 77 table
{   from a format of 12 bits in each 12 bit group to 12 bits of data stored right justified in 16 bit groups
{   or vice versa.  The input file must contain records that use the 77 table structure.  It will understand
{   either format (12-bit or 16-bit) as an input file.

  PROCEDURE mandf_create_binary_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE create_binary_formatted_file, crebff (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [89, 3, 22, 13, 11, 38, 322],
    clc$command, 1, 1, 0, 0, 0, 0, 1, ''], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

{ table n=crebf_commands
{ command n=(add_record , add_records, addr ) p=crebf_add_record              cm=local
{ command n=(compare_binary_record   , combr) p=crebf_compare_binary_record   cm=local
{ command n=(delete_record           , delr ) p=crebf_delete_record           cm=local
{ command n=(display_record_contents , disrc) p=crebf_display_record_contents cm=local
{ command n=(display_records         , disr ) p=crebf_display_records         cm=local
{ command n=(generate_file           , genf ) p=crebf_generate_file           cm=local
{ command n=(quit                    , qui  ) p=crebf_quit                    cm=local

?? PUSH (LISTEXT := ON) ??
VAR
  crebf_commands: [STATIC, READ] ^clt$command_table := ^crebf_commands_entries,
  crebf_commands_entries: [STATIC, READ] array [1 .. 15] of clt$command_table_entry := [
  {} ['ADDR                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^crebf_add_record],
  {} ['ADD_RECORD                     ', clc$nominal_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^crebf_add_record],
  {} ['ADD_RECORDS                    ', clc$alias_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^crebf_add_record],
  {} ['COMBR                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^crebf_compare_binary_record],
  {} ['COMPARE_BINARY_RECORD          ', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^crebf_compare_binary_record],
  {} ['DELETE_RECORD                  ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^crebf_delete_record],
  {} ['DELR                           ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^crebf_delete_record],
  {} ['DISPLAY_RECORDS                ', clc$nominal_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^crebf_display_records],
  {} ['DISPLAY_RECORD_CONTENTS        ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^crebf_display_record_contents],
  {} ['DISR                           ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^crebf_display_records],
  {} ['DISRC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^crebf_display_record_contents],
  {} ['GENERATE_FILE                  ', clc$nominal_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^crebf_generate_file],
  {} ['GENF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^crebf_generate_file],
  {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^crebf_quit],
  {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^crebf_quit]];
?? POP ??

    VAR
      ignore_status: ost$status,
      link_p: ^t$mdf_record_link,
      utility_attributes_p: ^clt$utility_attributes;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Only allow this utility to be entered once at a time.

    IF v$crebff_already_entered THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$multiple_crebff_called, '', status);
      RETURN;
    ELSE
      v$crebff_already_entered := TRUE;
    IFEND;

    { Create the scratch file to be used as a working area to read the data into from the input files.

    setup_scratch_file (v$crebff_files.input_file, v$crebff_files.input_file_id,
          v$crebff_data.input_file_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Create the scratch file to be used as a working area that contains the record list.

    setup_scratch_file (v$crebff_files.record_list, v$crebff_files.record_list_id,
          v$crebff_data.record_list_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Create the scratch file to be used as a scratch area.

    setup_scratch_file (v$crebff_files.scratch_area, v$crebff_files.scratch_area_id,
          v$crebff_data.scratch_area_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Create the linked list.

    ALLOCATE link_p;
    v$crebff_data.top_link_p := link_p;
    cleanup_linked_list;
    link_p^.name := 'TOP';
    link_p^.number := v$crebff_data.link_counter;
    link_p^.id_name := 'TOP';
    link_p^.size := 0;
    link_p^.data_p := NIL;
    link_p^.end_of_file := FALSE;

    { Process the utility commands.

    PUSH utility_attributes_p: [1 .. 2];
    utility_attributes_p^ [1].key := clc$utility_command_table;
    utility_attributes_p^ [1].command_table := crebf_commands;
    utility_attributes_p^ [2].key := clc$utility_prompt;
    utility_attributes_p^ [2].prompt.size := #SIZE(v$cbf_prompt_string);
    utility_attributes_p^ [2].prompt.value := v$cbf_prompt_string;

    clp$begin_utility (v$cbf_utility_name, utility_attributes_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$include_file (clc$current_command_input, v$cbf_prompt_string, v$cbf_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$end_utility (v$cbf_utility_name, status);
    v$crebff_already_entered := FALSE;

    { Return the scratch files.

    fsp$close_file (v$crebff_files.input_file_id, ignore_status);
    amp$return (v$crebff_files.input_file, ignore_status);

    fsp$close_file (v$crebff_files.record_list_id, ignore_status);
    amp$return (v$crebff_files.record_list, ignore_status);

    fsp$close_file (v$crebff_files.scratch_area_id, ignore_status);
    amp$return (v$crebff_files.scratch_area, ignore_status);

  PROCEND mandf_create_binary_file;
?? TITLE := 'mandf_format_binary_record', EJECT ??

{ PURPOSE:
{   This procedure reformats the input file.  The following are the possible formats:
{     CIP_PERIPHERAL_PROCESSOR:
{       The input file must contain one PP binary with the 77 table structure, the output from
{       compile_source.  The procedure reformats this PP binary into a format that is understood by CTI.
{     EI:
{       The input file must be the EI binary from the compile.
{     VE_CPU_BOOT:
{       The input file must contain a Boot Memory Image, the output from link_boot.  The procedure
{       builds the VE CPU BOOT (VCB) record.

  PROCEDURE mandf_format_binary_record
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE format_binary_record, forbr (
{   input, i: file = $required
{   output, o: file = $required
{   format, f: key
{       (cip_peripheral_processor, cpp) ei idc (ve_cpu_boot, vcb)
{     keyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 22, 13, 16, 9, 828],
    clc$command, 7, 4, 3, 0, 0, 0, 4, ''], [
    ['F                              ',clc$abbreviation_entry, 3],
    ['FORMAT                         ',clc$nominal_entry, 3],
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$required_parameter, 0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [6], [
    ['CIP_PERIPHERAL_PROCESSOR       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['CPP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['EI                             ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['IDC                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['VCB                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['VE_CPU_BOOT                    ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$input = 1,
      p$output = 2,
      p$format = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$format].value^.keyword_value = 'CIP_PERIPHERAL_PROCESSOR' THEN
      format_peripheral_processor (pvt [p$input].value^.file_value, pvt [p$output].value^.file_value, status);
    ELSEIF pvt [p$format].value^.keyword_value = 'IDC' THEN
      format_idc_record (pvt [p$input].value^.file_value, pvt [p$output].value^.file_value, status);
    ELSEIF pvt [p$format].value^.keyword_value = 'EI' THEN
      format_ve_binary ('EI     ', pvt [p$input].value^.file_value, pvt [p$output].value^.file_value, status);
    ELSE { pvt [p$format].value^.keyword_value = 'VE_CPU_BOOT'
      format_ve_binary ('VCB    ', pvt [p$input].value^.file_value, pvt [p$output].value^.file_value, status);
    IFEND;

  PROCEND mandf_format_binary_record;
?? TITLE := 'mandf_quit', EJECT ??

{ PURPOSE:
{   This procedure exits the MANAGE_DEADSTART_FILES utility.

  PROCEDURE mandf_quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE quit, qui ( )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 3, 22, 13, 16, 52, 809],
    clc$command, 0, 0, 0, 0, 0, 0, 0, '']];
?? FMT (FORMAT := ON) ??
?? POP ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_include (v$mdf_utility_name, status);

  PROCEND mandf_quit;
?? TITLE := 'new_page_procedure', EJECT ??

{ PURPOSE:
{   This procedure processes the page header for the display_records command's output file.

  PROCEDURE new_page_procedure
    (VAR display_control: clt$display_control;
         new_page_number: integer;
     VAR status: ost$status);

    VAR
      ignore: integer;

    status.normal := TRUE;
    clp$reset_for_next_display_page (display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (v$page_header (128, * ), ignore, display_control.page_number);

    clp$put_display (display_control, v$page_header, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$new_display_line (display_control, 2, status);

  PROCEND new_page_procedure;
?? TITLE := 'open_file', EJECT ??

{ PURPOSE:
{   This procedure opens the file.

  PROCEDURE open_file
    (    open_type: t$mdf_type_of_open;
         access_type: t$mdf_type_of_access;
         file_name_p: ^fst$file_reference;
     VAR file_identifier: amt$file_identifier;
     VAR file_segment_pointer: amt$segment_pointer;
     VAR file_length: amt$file_length;
     VAR status: ost$status);

    VAR
      av_p: ^fst$file_cycle_attributes,
      contains_data: boolean,
      device_assigned: boolean,
      device_class: rmt$device_class,
      fa_p: ^fst$attachment_options,
      gfa: ARRAY [1 .. 1] OF amt$get_item,
      local_file: boolean,
      mca_p: ^fst$file_cycle_attributes,
      old_file: boolean;

    status.normal := TRUE;

    rmp$get_device_class (file_name_p^, device_assigned, device_class, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Set up the file attributes for the opening of the file.

    IF open_type = c$mdf_open_for_read THEN
      PUSH fa_p: [1 .. 4];
      fa_p^ [1].selector := fsc$access_and_share_modes;
      fa_p^ [1].access_modes.selector := fsc$specific_access_modes;
      fa_p^ [1].access_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
      fa_p^ [1].share_modes.selector := fsc$specific_share_modes;
      fa_p^ [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
      fa_p^ [2].selector := fsc$create_file;
      fa_p^ [2].create_file := FALSE;
      fa_p^ [3].selector := fsc$delete_data;
      fa_p^ [3].delete_data := FALSE;
      fa_p^ [4].selector := fsc$open_position;
      fa_p^ [4].open_position := amc$open_at_boi;
    ELSE  {open_type = c$mdf_open_for_cip_write OR open_type = c$mdf_open_for_other_write
      PUSH fa_p: [1 .. 1];
      fa_p^ [1].selector := fsc$access_and_share_modes;
      fa_p^ [1].access_modes.selector := fsc$specific_access_modes;
      fa_p^ [1].access_modes.value := $fst$file_access_options [fsc$shorten, fsc$append,
            fsc$modify, fsc$read];
      fa_p^ [1].share_modes.selector := fsc$specific_share_modes;
      fa_p^ [1].share_modes.value := $fst$file_access_options [];
    IFEND;

    IF device_class = rmc$magnetic_tape_device THEN
      PUSH mca_p: [1 .. 3];
      mca_p^ [1].selector := fsc$block_type;
      mca_p^ [1].block_type := amc$user_specified;
      mca_p^ [2].selector := fsc$record_type;
      mca_p^ [2].record_type := amc$undefined;
      mca_p^ [3].selector := fsc$min_block_length;
      mca_p^ [3].min_block_length := 6;
      PUSH av_p: [1 .. 3];
      av_p^ [1].selector := fsc$block_type;
      av_p^ [1].block_type := amc$user_specified;
      av_p^ [2].selector := fsc$record_type;
      av_p^ [2].record_type := amc$undefined;
      av_p^ [3].selector := fsc$min_block_length;
      av_p^ [3].min_block_length := 6;
    ELSEIF open_type = c$mdf_open_for_read THEN
      mca_p := NIL;
      av_p := NIL;
    ELSE {open_type = c$mdf_open_for_cip_write OR open_type = c$mdf_open_for_other_write
      gfa [1].key := amc$file_access_procedure;
      amp$get_file_attributes (file_name_p^, gfa, local_file, old_file, contains_data, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      PUSH mca_p: [1 .. 2];
      mca_p^ [1].selector := fsc$record_type;
      mca_p^ [2].selector := fsc$block_type;
      mca_p^ [2].block_type := amc$system_specified;
      PUSH av_p: [1 .. 2];
      av_p^ [1].selector := fsc$record_type;
      av_p^ [2].selector := fsc$block_type;
      av_p^ [2].block_type := amc$system_specified;
      IF  gfa [1].file_access_procedure = 'DSP$MRF_DISK_FORMAT' THEN
        mca_p^ [1].record_type := amc$variable;
        av_p^ [1].record_type := amc$variable;
      ELSE
        IF (open_type = c$mdf_open_for_cip_write) AND (v$crebff_data.link_counter > 1) AND
              (gfa [1].file_access_procedure = ' ') THEN
          mca_p^ [1].record_type := amc$variable;
          av_p^ [1].record_type := amc$variable;
        ELSE
          mca_p^ [1].record_type := amc$undefined;
          av_p^ [1].record_type := amc$undefined;
        IFEND;
      IFEND;
    IFEND;

    { Open the file for record or segment access.

    IF access_type = c$mdf_record_access THEN
      fsp$open_file (file_name_p^, amc$record, fa_p, NIL, mca_p, av_p, NIL, file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE  {access_type = c$mdf_segment_access
      fsp$open_file (file_name_p^, amc$segment, fa_p, NIL, mca_p, av_p, NIL, file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      amp$get_segment_pointer (file_identifier, amc$sequence_pointer, file_segment_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    { Retrieve the file length of the input file.

    IF open_type = c$mdf_open_for_read THEN
      gfa [1].key := amc$file_length;
      amp$get_file_attributes (file_name_p^, gfa, local_file, old_file, contains_data, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      file_length := gfa [1].file_length;
      IF file_length <= 0 THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$empty_input_file, ' ', status);
        RETURN;
      IFEND;
    IFEND;

  PROCEND open_file;
?? TITLE := 'output_display_line', EJECT ??

{ PURPOSE:
{   This procedure writes the display line to the display file.

  PROCEDURE output_display_line
    (    output_line: ost$string;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    status.normal := TRUE;

    IF output_line.value (1) = ' ' THEN
      clp$new_display_line (display_control, 0, status);
    ELSE
      clp$new_display_line (display_control, 1, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, output_line.value (2, output_line.size - 1), clc$trim, status);

  PROCEND output_display_line;
?? TITLE := 'pack_data', EJECT ??

{ PURPOSE:
{   This procedure packs the data.  It expects as input, data that is in the format of 60 bits of data
{   in a 64-bit group.  This procedure strips off the upper 4 bits of data so that there is continuous
{   bits of data.  The packed data length, which is an input parameter to this procedure, is defined to
{   be CM words.

  PROCEDURE pack_data
    (    unpacked_data_seq_p: ^SEQ ( * );
         packed_data_length: integer;
     VAR packed_data_seq_p: ^SEQ ( * );
     VAR checksum: dst$pp_word);

    VAR
      cm_word_p: ^PACKED ARRAY [1 .. 16] OF 0 .. 0f(16),
      cm_word: PACKED ARRAY [1 .. 16] OF 0 .. 0f(16),
      nibble_count: 0 .. 4,
      nibble_index: 0 .. 16,
      pp_word_array: ARRAY [0 .. 3] OF 0 .. 0f(16),
      pp_word_count: integer,
      pp_word_p: ^dst$pp_word,
      temp_unpacked_seq_p: ^SEQ ( * ),
      word_index: integer,
      word_size: integer;

    checksum := 0;
    pp_word_count := 0;
    nibble_count := 0;
    temp_unpacked_seq_p := unpacked_data_seq_p;

    word_size := #SIZE (unpacked_data_seq_p^) DIV 8;
    FOR word_index := 1 TO word_size DO
      NEXT cm_word_p IN temp_unpacked_seq_p;
      cm_word := cm_word_p^;
      FOR nibble_index := 2 TO 16 DO
        pp_word_array [nibble_count MOD 4] := cm_word [nibble_index];
        nibble_count := nibble_count + 1;
        IF (nibble_count MOD 4) = 0 THEN
          NEXT pp_word_p IN packed_data_seq_p;
          pp_word_p^ := pp_word_array [0] * 1000(16) + pp_word_array [1] * 100(16) +
                pp_word_array [2] * 10(16) + pp_word_array [3];
          checksum := (checksum + pp_word_p^) MOD 10000(16);
          pp_word_count := pp_word_count + 1;
          nibble_count := 0;
        IFEND;
      FOREND;
    FOREND;

    { Fill with zeros to 64 bit word boundry.

    FOR word_index := pp_word_count TO (packed_data_length * 4) - 1 DO
      NEXT pp_word_p IN packed_data_seq_p;
      pp_word_p^ := 0;
    FOREND;

  PROCEND pack_data;
?? TITLE := 'search_record_list', EJECT ??

{ PURPOSE:
{   This procedure searches the record list for a particular record link.

  PROCEDURE search_record_list
    (VAR add_record_data: t$mdf_add_record_data;
     VAR search_link_p: ^t$mdf_record_link;
     VAR status: ost$status);

    VAR
      search_number: integer;

    status.normal := TRUE;

    { Retrieve the number of the correct link that is involved in the placement/destination.

    CASE add_record_data.destination.kind OF
    = clc$integer =
      search_number := add_record_data.destination.integer_value.value;
    = clc$keyword =
      IF add_record_data.destination.keyword_value = 'FIRST' THEN
        search_number := v$crebff_data.top_link_p^.number;
      ELSE  { add_record_data.destination.keyword_value = 'LAST'
        search_number := v$crebff_data.link_counter;
      IFEND;
    ELSE {clc$name
      search_link_p := v$crebff_data.top_link_p^.chain_p;
     /search_for_name/
      WHILE TRUE DO
        IF search_link_p = NIL THEN
          osp$set_status_abnormal (dsc$display_processor_id, dse$record_not_found, '', status);
          RETURN;
        IFEND;
        IF search_link_p^.name = add_record_data.destination.name_value THEN
          search_number := search_link_p^.number;
          EXIT /search_for_name/;
        IFEND;
        search_link_p := search_link_p^.chain_p;
      WHILEND /search_for_name/;
    CASEND;

    { Change the BEFORE placement to the equivalent AFTER placement.

    IF add_record_data.placement = 'BEFORE' THEN
      IF search_number <> 0 THEN
        search_number := search_number - 1;
      IFEND;
      add_record_data.placement := 'AFTER';
    IFEND;

    { Search for the desired record according to destination/placement.

    search_link_p := v$crebff_data.top_link_p;
   /search_for_link/
    WHILE TRUE DO
      IF search_link_p = NIL THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$record_not_found, '', status);
        RETURN;
      IFEND;
      IF search_link_p^.number = search_number THEN
        EXIT /search_for_link/;
      IFEND;
      search_link_p := search_link_p^.chain_p;
    WHILEND /search_for_link/;

  PROCEND search_record_list;
?? TITLE := 'setup_scratch_file', EJECT ??

{ PURPOSE:
{   This procedure sets up the scratch files that are used internally by the utility.

  PROCEDURE setup_scratch_file
    (VAR file: ost$name;
     VAR file_identifier: amt$file_identifier;
     VAR scratch_file_seq_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      segment_pointer: amt$segment_pointer,
      unique_name: ost$unique_name;

    status.normal := TRUE;
    pmp$generate_unique_name (unique_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

   /open_scratch_file/
    BEGIN
      file := unique_name.value;
      fsp$open_file (file, amc$segment, NIL, NIL, NIL, NIL, NIL, file_identifier, status);
      IF NOT status.normal THEN
        EXIT /open_scratch_file/;
      IFEND;

      amp$get_segment_pointer (file_identifier, amc$sequence_pointer, segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /open_scratch_file/;
      IFEND;
      mmp$set_access_selections (segment_pointer.sequence_pointer, mmc$as_sequential, status);
    END /open_scratch_file/;

    IF NOT status.normal THEN
      fsp$close_file (file_identifier, ignore_status);
      amp$return (file, ignore_status);
    ELSE
      scratch_file_seq_p := segment_pointer.sequence_pointer;
      RESET scratch_file_seq_p;
    IFEND;

  PROCEND setup_scratch_file;
?? TITLE := 'dsp$manage_deadstart_files', EJECT ??

{ PURPOSE:
{   This procedure is the starting procedure for the utility MANAGE_DEADSTART_FILES.

  PROCEDURE [XDCL, #GATE] dsp$manage_deadstart_files
    (    parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE manage_deadstart_files, mandf (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [89, 3, 22, 13, 17, 52, 877],
    clc$command, 1, 1, 0, 0, 0, 0, 1, ''], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

{ table n=mandf_commands t=command
{ command n=(change_attribute, change_attributes, chaa  ) p=mandf_change_attribute     cm=local
{ command n=(create_binary_formatted_file       , crebff) p=mandf_create_binary_file   cm=local
{ command n=(format_binary_record               , forbr ) p=mandf_format_binary_record cm=local
{ command n=(quit                               , qui   ) p=mandf_quit                 cm=local

?? PUSH (LISTEXT := ON) ??
VAR
  mandf_commands: [STATIC, READ] ^clt$command_table := ^mandf_commands_entries,
  mandf_commands_entries: [STATIC, READ] array [1 .. 9] of  clt$command_table_entry := [
  {} ['CHAA                           ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^mandf_change_attribute],
  {} ['CHANGE_ATTRIBUTE               ', clc$nominal_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^mandf_change_attribute],
  {} ['CHANGE_ATTRIBUTES              ', clc$alias_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^mandf_change_attribute],
  {} ['CREATE_BINARY_FORMATTED_FILE   ', clc$nominal_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^mandf_create_binary_file],
  {} ['CREBFF                         ', clc$abbreviation_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^mandf_create_binary_file],
  {} ['FORBR                          ', clc$abbreviation_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^mandf_format_binary_record],
  {} ['FORMAT_BINARY_RECORD           ', clc$nominal_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^mandf_format_binary_record],
  {} ['QUI                            ', clc$abbreviation_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^mandf_quit],
  {} ['QUIT                           ', clc$nominal_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^mandf_quit]];
?? POP ??

    VAR
      utility_attributes_p: ^clt$utility_attributes;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    v$crebff_already_entered := FALSE;

    { Process the utility commands.

    PUSH utility_attributes_p: [1 .. 2];
    utility_attributes_p^ [1].key := clc$utility_command_table;
    utility_attributes_p^ [1].command_table := mandf_commands;
    utility_attributes_p^ [2].key := clc$utility_prompt;
    utility_attributes_p^ [2].prompt.size := #SIZE(v$mdf_prompt_string);
    utility_attributes_p^ [2].prompt.value := v$mdf_prompt_string;

    clp$begin_utility (v$mdf_utility_name, utility_attributes_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, v$mdf_prompt_string, v$mdf_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$end_utility (v$mdf_utility_name, status);

  PROCEND dsp$manage_deadstart_files;
MODEND dsm$manage_deadstart_files;
*DECK DECK=DSM$MANAGE_DEADSTART_FILES_PD EXPAND=TRUE

  create_program_description ..
    n=(manage_deadstart_files, mandf) ..
    l=(osf$current_library, cyf$run_time_library, ..
       osf$task_services_library) ..
    sp=dsp$manage_deadstart_files
*DECK DECK=DSM$MANAGE_INTERVAL_PASSWORD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Manage Interval Password' ??
MODULE dsm$manage_interval_password;

{ PURPOSE:
{   This module contains the procedures that manage the Operation Password data, Operation Interval data
{   and the Main Window Lock data that is saved in VCU.  This code is not allowed to be used on a 93X
{   mainframe because of the inability to access VCU after DFT relocates.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dse$interval_password_errors
*copyc dst$signal_contents
?? POP ??
*copyc clp$convert_integer_to_string
*copyc dpp$get_next_line
*copyc dpp$put_critical_message
*copyc dpp$put_next_line
*copyc dsp$access_vcu_cda_data
*copyc dsp$get_data_from_rdf
*copyc dsp$store_data_in_rdf
*copyc jmp$convert_date_time_dif_to_us
*copyc osp$fatal_system_error
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$unpack_status_condition
*copyc pmp$get_compact_date_time
*copyc pmp$get_microsecond_clock
*copyc pmp$verify_compact_date
*copyc syp$ascii_to_binary
*copyc syp$crack_command
*copyc syp$get_token
*copyc syp$process_deadstart_status
?? EJECT ??
*copyc dpv$lock_main_window
*copyc dpv$secure_input_line
*copyc dpv$system_core_display
*copyc dsv$mainframe_type
*copyc dsv$sub_mainframe_type
*copyc syv$reading_dcfile
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    t$password = RECORD
      CASE boolean OF
      = TRUE =
        password: string (7),
      = FALSE =
        encrypted_password: dst$vcu_encrypted_password,
      CASEND,
    RECEND,

    t$rdf_password_data = RECORD
      password_initialized: boolean,
      encrypted_password: dst$vcu_encrypted_password,
    RECEND,

    t$token = RECORD
      retrieved: boolean,
      data: ost$string,
      kind: t$token_kind,
      number: t$token_integer,
    RECEND,

    t$token_integer = RECORD
      value: integer,
      minimum: 0 .. 0ffff(16),
      maximum: 0 .. 0ffff(16),
    RECEND,

    t$token_kind = (c$tk_password_value, c$tk_yes_no_value, c$tk_integer_value);

?? OLDTITLE ??
?? NEWTITLE := 'change_password', EJECT ??

{ PURPOSE:
{   This procedure changes the password from its encrypted format back to its readable format or
{   it changes the password from its readable format into its encrypted format.

  PROCEDURE change_password
    (    encrypt_password: boolean;
     VAR password: t$password);

    VAR
      index: 0 .. 0ff(16),
      temp_password: t$password;

    temp_password := password;
    FOR index := LOWERBOUND (dst$vcu_encrypted_password) TO UPPERBOUND (dst$vcu_encrypted_password) DO
      IF encrypt_password THEN
        temp_password.encrypted_password [index] :=
              temp_password.encrypted_password [index] - dsc$vcu_password_mask;
      ELSE
        temp_password.encrypted_password [index] :=
              temp_password.encrypted_password [index] + dsc$vcu_password_mask;
      IFEND;
    FOREND;
    password.encrypted_password [1] := temp_password.encrypted_password [4];
    password.encrypted_password [2] := temp_password.encrypted_password [7];
    password.encrypted_password [3] := temp_password.encrypted_password [5];
    password.encrypted_password [4] := temp_password.encrypted_password [1];
    password.encrypted_password [5] := temp_password.encrypted_password [3];
    password.encrypted_password [6] := temp_password.encrypted_password [6];
    password.encrypted_password [7] := temp_password.encrypted_password [2];

  PROCEND change_password;
?? OLDTITLE ??
?? NEWTITLE := 'get_data', EJECT ??

{ PURPOSE:
{   This procedure retrieves the individual data for the SETOP and SETOI System Core Commands.

  PROCEDURE get_data
    (    id: dpt$window_id;
         question_text_1: string ( * );
         question_text_2: string ( * );
     VAR token: t$token);

    VAR
      display_string: string (osc$max_string_size),
      index: 0 .. 0ff(16),
      line_received: boolean,
      local_status: ost$status,
      loop_count: 0 .. 0ff(16),
      string_length: integer,
      text: string (70),
      token_index: 0 .. 255;

    token.retrieved := FALSE;
    loop_count := 3;

   /retrieve_answer/
    WHILE TRUE DO
      IF loop_count <= 0 THEN
        dpp$put_next_line (id, '         Allowable retries for the command exceeded, command aborted.',
              local_status);
        dpp$put_next_line (id, ' ', local_status);
        RETURN;
      ELSE
        dpp$put_next_line (id, ' ', local_status);
        loop_count := loop_count - 1;
      IFEND;

      dpp$put_next_line (id, question_text_1, local_status);
      IF question_text_2 <> ' ' THEN
        dpp$put_next_line (id, question_text_2, local_status);
      IFEND;

      text := ' ';
      IF token.kind = c$tk_password_value THEN
        dpv$secure_input_line.window_id := id;
        dpv$secure_input_line.secure := TRUE;
      IFEND;
      dpp$get_next_line (id, osc$wait, text, line_received);
      IF token.kind = c$tk_password_value THEN
        dpv$secure_input_line.secure := FALSE;
      IFEND;
      IF (text = ' ') OR NOT line_received THEN
        CYCLE /retrieve_answer/;
      IFEND;

      display_string := ' ';
      IF token.kind <> c$tk_password_value THEN
        display_string (3, *) := text;
      IFEND;
      dpp$put_next_line (id, display_string (1, 72), local_status);

      token_index := 1;
      syp$get_token (text, TRUE {upper_case}, token_index, token.data, local_status);
      IF NOT local_status.normal THEN
        dpp$put_next_line (id, 'ERROR -- Invalid value, enter valid value.', local_status);
        CYCLE /retrieve_answer/;
      IFEND;

      CASE token.kind OF
      = c$tk_password_value =
        IF token.data.size <> 7 THEN
          dpp$put_next_line (id, 'ERROR -- The PASSWORD entered is invalid.', local_status);
          CYCLE /retrieve_answer/;
        IFEND;
        FOR index := 1 TO token.data.size DO
          IF NOT ((token.data.value (index) >= 'A') AND (token.data.value (index) <= 'Z')) AND
                NOT ((token.data.value (index) >= '0') AND (token.data.value (index) <= '9')) THEN
            dpp$put_next_line (id, 'ERROR -- The PASSWORD entered is invalid.',
                  local_status);
            CYCLE /retrieve_answer/;
          IFEND;
        FOREND;

      = c$tk_yes_no_value =
        IF (token.data.value (1, token.data.size) <> 'YES') AND
              (token.data.value (1, token.data.size) <> 'NO') THEN
          dpp$put_next_line (id, 'ERROR -- Enter YES or NO.', local_status);
          CYCLE /retrieve_answer/;
        IFEND;

      = c$tk_integer_value =
        syp$ascii_to_binary (token.data.value (1, token.data.size), 10, token.number.value, local_status);
        IF NOT local_status.normal THEN
          dpp$put_next_line (id, 'ERROR -- Invalid value, enter valid value.', local_status);
          CYCLE /retrieve_answer/;
        IFEND;
        IF (token.number.value < token.number.minimum) OR (token.number.value > token.number.maximum) THEN
          STRINGREP (display_string, string_length, 'ERROR -- The value must be between ',
                token.number.minimum, ' and ', token.number.maximum, '.');
          dpp$put_next_line (id, display_string (1, string_length), local_status);
          CYCLE /retrieve_answer/;
        IFEND;
      ELSE
      CASEND;

      token.retrieved := TRUE;
      EXIT /retrieve_answer/;
    WHILEND /retrieve_answer/;

  PROCEND get_data;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$change_operation_password', EJECT ??

{ PURPOSE:
{   This procedure changes the current operation password that is stored in VCU.  It first checks that the
{   password parameter matches the password saved in VCU.  It also validates the new password before saving
{   it in VCU.

  PROCEDURE [XDCL, #GATE] dsp$change_operation_password
    (    old_password: ost$name;
         new_password: ost$name;
     VAR status: ost$status);

    VAR
      index: 0 .. 0ff(16),
      password_data: dst$vcu_password_data,
      password_data_seq_p: ^SEQ ( * ),
      rdf_password_data: t$rdf_password_data,
      vcu_password: t$password;

    status.normal := TRUE;
    IF dsv$mainframe_type = dsc$mt_93x_mainframe THEN
      osp$set_status_condition (dse$command_not_allowed, status);
      RETURN;
    IFEND;

    password_data_seq_p := #SEQ (password_data);
    dsp$access_vcu_cda_data (dsc$vcu_read_access, dsc$vcu_password_data, password_data_seq_p, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status (' ', FALSE, status);
      osp$fatal_system_error ('Problem accessing CDA area of CIP device. possible disk error.', ^status);
    IFEND;

    IF NOT password_data.password_initialized THEN
      osp$set_status_condition (dse$no_password_exists, status);
      RETURN;
    IFEND;

    vcu_password.encrypted_password := password_data.encrypted_password;
    change_password (FALSE, vcu_password);
    IF vcu_password.password <> old_password (1, 7) THEN
      osp$set_status_condition (dse$invalid_password, status);
      RETURN;
    IFEND;

    IF new_password (7) = ' ' THEN
      osp$set_status_condition (dse$seven_character_password, status);
      RETURN;
    IFEND;

    FOR index := 1 TO 7 DO
      IF NOT ((new_password (index) >= 'A') AND (new_password (index) <= 'Z')) AND
            NOT ((new_password (index) >= '0') AND (new_password (index) <= '9')) THEN
        osp$set_status_condition (dse$alphanumeric_password, status);
        RETURN;
      IFEND;
    FOREND;

    vcu_password.password := new_password (1, 7);
    change_password (TRUE, vcu_password);

    password_data.password_initialized := TRUE;
    password_data.encrypted_password := vcu_password.encrypted_password;
    password_data_seq_p := #SEQ (password_data);
    dsp$access_vcu_cda_data (dsc$vcu_write_access, dsc$vcu_password_data, password_data_seq_p, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status (' ', FALSE, status);
      osp$fatal_system_error ('Problem accessing CDA area of CIP device. possible disk error', ^status);
    IFEND;

    rdf_password_data.password_initialized := TRUE;
    rdf_password_data.encrypted_password := password_data.encrypted_password;
    dsp$store_data_in_rdf (dsc$rdf_password_interval_data, dsc$rdf_production, #SEQ (rdf_password_data));

  PROCEND dsp$change_operation_password;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$check_interval', EJECT ??

{ PURPOSE:
{   This procedure is called once per deadstart and at the top of each hour to check that the Operation
{   Interval has not expired.  If the time has expired then the system is stepped.  This code is only
{   valid if an interval has been initialized.

  PROCEDURE [XDCL, #GATE] dsp$check_interval;

    VAR
      current_frc: jmt$clock_time,
      error_string: string (72),
      local_status: ost$status,
      password_data: dst$vcu_password_data,
      password_data_seq_p: ^SEQ ( * );

    IF dsv$mainframe_type = dsc$mt_93x_mainframe THEN
       RETURN;
    IFEND;

    IF dsv$sub_mainframe_type <> dsc$smt_china_mainframe THEN

{ Temporary test and exit to compensate for service processor problem.

      IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
        RETURN;
      IFEND;

{ Temporary test and exit to compensate for dedicated load device problem, 962.

      IF dsv$mainframe_type = dsc$mt_962_972_mainframe THEN
        RETURN;
      IFEND;

{ Temporary test and exit to compensate for dedicated load device problem, 992.

      IF (dsv$mainframe_type = dsc$mt_992_mainframe) THEN
        RETURN;
      IFEND;
    IFEND;

    password_data_seq_p := #SEQ (password_data);
    dsp$access_vcu_cda_data (dsc$vcu_read_access, dsc$vcu_password_data, password_data_seq_p, local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (' ', FALSE, local_status);
      osp$fatal_system_error ('Problem accessing CDA area of CIP device. .', ^local_status);
    IFEND;

    IF NOT password_data.interval_initialized THEN
      RETURN;
    IFEND;

    error_string := ' ';
    pmp$get_microsecond_clock (current_frc, local_status);
    IF password_data.interval_expired OR (current_frc > password_data.expiration_frc) THEN
      error_string := 'The System Operation Interval has expired.';
      password_data.interval_expired := TRUE;
    ELSEIF current_frc < password_data.saved_current_frc THEN
      error_string := 'The current FRC appears damaged, expiration interval unknown.';
      password_data.interval_expired := TRUE;
    IFEND;

    password_data.saved_current_frc := current_frc;
    dsp$access_vcu_cda_data (dsc$vcu_write_access, dsc$vcu_password_data, password_data_seq_p, local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (' ', FALSE, local_status);
      osp$fatal_system_error ('Problem accessing CDA area of CIP device - ', ^local_status);
    IFEND;

    IF error_string <> ' ' THEN
      osp$fatal_system_error (error_string, NIL);
    IFEND;

  PROCEND dsp$check_interval;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$check_password_for_inisd', EJECT ??

{ PURPOSE:
{   This procedure checks the password for The INISD System Core Command on China mainframes.

  PROCEDURE [XDCL] dsp$check_password_for_inisd
    (    id: dpt$window_id;
     VAR password_valid: boolean);

    VAR
      local_status: ost$status,
      password_data: dst$vcu_password_data,
      password_data_seq_p: ^SEQ ( * ),
      token: t$token,
      vcu_password: t$password;

    password_valid := TRUE;
    IF dsv$sub_mainframe_type <> dsc$smt_china_mainframe THEN
      RETURN;
    IFEND;

    password_valid := FALSE;
    password_data_seq_p := #SEQ (password_data);
    dsp$access_vcu_cda_data (dsc$vcu_read_access, dsc$vcu_password_data, password_data_seq_p, local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (' ', FALSE, local_status);
      osp$fatal_system_error ('Problem accessing CDA area of CIP device.', ^local_status);
    IFEND;

    IF NOT password_data.password_initialized THEN
      dpp$put_next_line (id, 'ERROR -- A SETOP command has NOT yet been entered, it must be', local_status);
      dpp$put_next_line (id, '         used before the INISD command.', local_status);
      RETURN;
    IFEND;

    { Check that the user of the command has the authorization to use this command.

    vcu_password.encrypted_password := password_data.encrypted_password;
    change_password (FALSE, vcu_password);
    token.kind := c$tk_password_value;
    get_data (id, 'Enter the Operation Password:', '(it will not be displayed on the screen)', token);
    IF NOT token.retrieved THEN
      RETURN;
    IFEND;
    IF token.data.value (1, token.data.size) <> vcu_password.password THEN
      dpp$put_next_line (id, 'ERROR -- Invalid PASSWORD entered, it does not match the old PASSWORD saved.',
            local_status);
      dpp$put_next_line (id, '         The command has aborted. ', local_status);
      dpp$put_next_line (id, ' ', local_status);
      RETURN;
    IFEND;

    dpp$put_next_line (id, 'Parameter entry for the INISD command has been completed.', local_status);
    dpp$put_next_line (id, ' ', local_status);
    password_valid := TRUE;

  PROCEND dsp$check_password_for_inisd;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$check_saved_passwords', EJECT ??

{ PURPOSE:
{   This procedure checks that the password saved in VCU matches the password saved in the RDF area.  If no
{   password is saved in the RDF the the VCU password is written to the RDF.  If there is no password in
{   VCU then nothing happens.  If the VCU password does not equal the RDF password then the system is stepped.

  PROCEDURE [XDCL] dsp$check_saved_passwords;

    VAR
      local_status: ost$status,
      password_data: dst$vcu_password_data,
      password_data_seq_p: ^SEQ ( * ),
      rdf_password: t$password,
      rdf_password_data: t$rdf_password_data,
      rdf_password_data_seq_p: ^SEQ ( * ),
      vcu_password: t$password;

    IF dsv$mainframe_type = dsc$mt_93x_mainframe THEN
      RETURN;
    IFEND;

    password_data_seq_p := #SEQ (password_data);
    dsp$access_vcu_cda_data (dsc$vcu_read_access, dsc$vcu_password_data, password_data_seq_p, local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (' ', FALSE, local_status);
      osp$fatal_system_error ('Problem accessing CDA area of CIP device. ', ^local_status);
    IFEND;

    IF NOT password_data.password_initialized THEN
      RETURN;
    IFEND;

    rdf_password_data_seq_p := #SEQ (rdf_password_data);
    dsp$get_data_from_rdf (dsc$rdf_password_interval_data, dsc$rdf_production, rdf_password_data_seq_p);

    IF NOT rdf_password_data.password_initialized THEN
      rdf_password_data.password_initialized := TRUE;
      rdf_password_data.encrypted_password := password_data.encrypted_password;
      dsp$store_data_in_rdf (dsc$rdf_password_interval_data, dsc$rdf_production, #SEQ (rdf_password_data));
      RETURN;
    IFEND;

    vcu_password.encrypted_password := password_data.encrypted_password;
    change_password (FALSE, vcu_password);
    rdf_password.encrypted_password := rdf_password_data.encrypted_password;
    change_password (FALSE, rdf_password);

    IF vcu_password.password <> rdf_password.password THEN
      osp$fatal_system_error ('Operation Password mismatch, unauthorized entry, system aborted.', NIL);
    IFEND;

  PROCEND dsp$check_saved_passwords;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$force_lock_of_main_window', EJECT ??

{ PURPOSE:
{   This procedure forces the locking of the main window.  If the main window lock boolean in VCU is set then
{   the main window will be locked.

  PROCEDURE [XDCL, #GATE] dsp$force_lock_of_main_window;

    VAR
      local_status: ost$status,
      password_data: dst$vcu_password_data,
      password_data_seq_p: ^SEQ ( * );

    IF dsv$mainframe_type = dsc$mt_93x_mainframe THEN
      RETURN;
    IFEND;

    password_data_seq_p := #SEQ (password_data);
    dsp$access_vcu_cda_data (dsc$vcu_read_access, dsc$vcu_password_data, password_data_seq_p, local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (' ', FALSE, local_status);
      osp$fatal_system_error ('Problem accessing CDA area of CIP device. ', ^local_status);
    IFEND;

    IF NOT password_data.password_initialized OR NOT password_data.lock_main_window THEN
      RETURN;
    IFEND;

    dpv$lock_main_window.window_id := dpv$system_core_display;
    dpv$lock_main_window.lock := TRUE;

  PROCEND dsp$force_lock_of_main_window;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$lock_unlock_main_window', EJECT ??

{ PURPOSE:
{   This procedure locks or unlocks the main window.
{ NOTE:
{  Osp$set_status_abnormal is used in this procedure so that the status variable contains the text.
{  One of the callers of this procedure displays the status text to the console.

  PROCEDURE [XDCL, #GATE] dsp$lock_unlock_main_window
    (    password: ost$name;
         lock_window: boolean;
     VAR status: ost$status);

    VAR
      password_data: dst$vcu_password_data,
      password_data_seq_p: ^SEQ ( * ),
      vcu_password: t$password;

    status.normal := TRUE;
    IF dsv$mainframe_type = dsc$mt_93x_mainframe THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$window_lock_not_allowed,
            'The locking of the main window is not allowed on this mainframe.', status);
      RETURN;
    IFEND;

    password_data_seq_p := #SEQ (password_data);
    dsp$access_vcu_cda_data (dsc$vcu_read_access, dsc$vcu_password_data, password_data_seq_p, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status (' ', FALSE, status);
      osp$fatal_system_error ('Problem accessing CDA area of CIP device. ', ^status);
    IFEND;

    IF NOT password_data.password_initialized THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$no_password_exists,
            'This command can not be parsed until its associated password has been established.', status);
      RETURN;
    IFEND;

    vcu_password.encrypted_password := password_data.encrypted_password;
    change_password (FALSE, vcu_password);
    IF vcu_password.password <> password (1, 7) THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$invalid_password,
            'The password entered is invalid', status);
      RETURN;
    IFEND;

    password_data.lock_main_window := lock_window;
    password_data_seq_p := #SEQ (password_data);
    dsp$access_vcu_cda_data (dsc$vcu_write_access, dsc$vcu_password_data, password_data_seq_p, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status (' ', FALSE, status);
      osp$fatal_system_error ('Problem accessing CDA area of CIP device. ', ^status);
    IFEND;

    dpv$lock_main_window.window_id := dpv$system_core_display;
    dpv$lock_main_window.lock := lock_window;

  PROCEND dsp$lock_unlock_main_window;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$lock_unlock_window_from_mtr', EJECT ??

{ PURPOSE:
{   This procedure is called from a signal handler which was triggered from the monitor commands used to
{   disable and enable the main operator window.

  PROCEDURE [XDCL, #GATE] dsp$lock_unlock_window_from_mtr
    (    signal_entry: dst$signal_contents_entry);

    VAR
      display_string: ost$string,
      identifier: ost$status_identifier,
      ignore_status: ost$status,
      integer_string: ost$string,
      number: ost$status_condition_number,
      password: ost$name,
      status: ost$status;

    password := signal_entry.luw_data.password;
    dsp$lock_unlock_main_window (password, signal_entry.luw_data.lock_window, status);
    IF NOT status.normal THEN
      osp$unpack_status_condition (status.condition, identifier, number);
      display_string.value := identifier;
      display_string.size := #SIZE (identifier) + 1;
      clp$convert_integer_to_string (number, 10, FALSE, integer_string, ignore_status);
      display_string.value (display_string.size, integer_string.size) := integer_string.value;
      display_string.size := display_string.size + integer_string.size + 1;
      display_string.value (display_string.size, * ) := status.text.value (1, status.text.size);
      display_string.size := display_string.size + status.text.size;
    ELSE
      IF signal_entry.luw_data.lock_window THEN
        display_string.value := 'The main operator window has been disabled.';
        display_string.size := 43;
      ELSE
        display_string.value := 'The main operator window has been enabled.';
        display_string.size := 42;
      IFEND;
    IFEND;
    dpp$put_critical_message (display_string.value (1, display_string.size), ignore_status);

  PROCEND dsp$lock_unlock_window_from_mtr;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$process_setoi_command', EJECT ??

{ PURPOSE:
{   This procedure is called from the system core command set_operation_interval (setoi).  It is used to set
{   the Operation Interval in VCU.  A password entered as a parameter must match the password in VCU before
{   the Interval can be changed.

  PROCEDURE [XDCL] dsp$process_setoi_command
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      current_date_time: ost$date_time,
      current_frc: jmt$clock_time,
      display_string: string (osc$max_string_size),
      entered_date_time: ost$date_time,
      expiration_frc: jmt$clock_time,
      local_status: ost$status,
      loop_count: 0 .. 0ff(16),
      password: t$password,
      password_data: dst$vcu_password_data,
      password_data_seq_p: ^SEQ ( * ),
      string_length: integer,
      token: t$token;

    status.normal := TRUE;
    IF dsv$mainframe_type = dsc$mt_93x_mainframe THEN
      dpp$put_next_line (id, 'WARNING -- The SETOI command is not allowed to be used on this mainframe.',
            local_status);
      RETURN;
    IFEND;

    IF syv$reading_dcfile THEN
      dpp$put_next_line (id, 'WARNING -- The SETOI command must be entered by an operator, not from a file.',
            local_status);
      RETURN;
    IFEND;

    password_data_seq_p := #SEQ (password_data);
    dsp$access_vcu_cda_data (dsc$vcu_read_access, dsc$vcu_password_data, password_data_seq_p, local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (' ', FALSE, local_status);
      osp$fatal_system_error ('Unable to read password data from CDA.', ^local_status);
    IFEND;

    IF NOT password_data.password_initialized THEN
      dpp$put_next_line (id, 'ERROR -- A SETOP command has NOT yet been entered, it must be', local_status);
      dpp$put_next_line (id, '         used before the SETOI command.', local_status);
      RETURN;
    IFEND;

    { Check that the user of the command has the authorization to use this command.

    password.encrypted_password := password_data.encrypted_password;
    change_password (FALSE, password);
    token.kind := c$tk_password_value;
    get_data (id, 'Enter the Operation Password:', '(it will not be displayed on the screen)', token);
    IF NOT token.retrieved THEN
      RETURN;
    IFEND;
    IF token.data.value (1, token.data.size) <> password.password THEN
      dpp$put_next_line (id, 'ERROR -- Invalid PASSWORD entered, it does not match the old PASSWORD saved.',
            local_status);
      dpp$put_next_line (id, '         The command has aborted. ', local_status);
      dpp$put_next_line (id, ' ', local_status);
      RETURN;
    IFEND;

    entered_date_time.hour := 0;
    entered_date_time.minute := 0;
    entered_date_time.second := 0;
    entered_date_time.millisecond := 0;

    loop_count := 3;

   /retrieve_interval/
    WHILE TRUE DO
      IF loop_count <= 0 THEN
        dpp$put_next_line (id, '         Allowable retries for the command exceeded, command aborted.',
              local_status);
        dpp$put_next_line (id, ' ', local_status);
        RETURN;
      ELSE
        loop_count := loop_count - 1;
      IFEND;

      token.kind := c$tk_integer_value;
      token.number.minimum := 1;

      token.number.maximum := 12;
      get_data (id, 'Enter the scheduled operation expiration MONTH:', ' ', token);
      IF NOT token.retrieved THEN
        RETURN;
      IFEND;
      entered_date_time.month := token.number.value;

      token.number.maximum := 31;
      get_data (id, 'Enter the scheduled operation expiration DAY:', ' ', token);
      IF NOT token.retrieved THEN
        RETURN;
      IFEND;
      entered_date_time.day := token.number.value;

      token.number.minimum := 1900;
      token.number.maximum := 2155;
      get_data (id, 'Enter the scheduled operation expiration YEAR:', ' ', token);
      IF NOT token.retrieved THEN
        RETURN;
      IFEND;
      entered_date_time.year := token.number.value - 1900;

      pmp$verify_compact_date (entered_date_time, local_status);
      IF NOT local_status.normal THEN
        dpp$put_next_line (id, 'ERROR -- The date entered is invalid, enter a correct date.', local_status);
        dpp$put_next_line (id, ' ', local_status);
        CYCLE /retrieve_interval/;
      IFEND;

      pmp$get_compact_date_time (current_date_time, local_status);
      pmp$get_microsecond_clock (current_frc, local_status);
      jmp$convert_date_time_dif_to_us (current_date_time, entered_date_time, current_frc, expiration_frc);
      IF expiration_frc <= current_frc THEN
        dpp$put_next_line (id, 'ERROR -- The date entered must be in the future.', local_status);
        dpp$put_next_line (id, ' ', local_status);
        CYCLE /retrieve_interval/;
      IFEND;

      token.kind := c$tk_yes_no_value;
      STRINGREP (display_string, string_length, 'Mainframe operation expiration scheduled for ',
            entered_date_time.month, '/', entered_date_time.day, '/', (1900 + entered_date_time.year));
      get_data (id, display_string (1, string_length), 'Is this date correct? (YES/NO)',
            token);
      IF NOT token.retrieved THEN
        RETURN;
      IFEND;
      IF token.data.value (1, token.data.size) = 'NO' THEN
        loop_count := 3;
        CYCLE /retrieve_interval/;
      IFEND;
      EXIT /retrieve_interval/;
    WHILEND /retrieve_interval/;

    password_data.interval_initialized := TRUE;
    password_data.interval_expired := FALSE;
    password_data.saved_current_frc := current_frc;
    password_data.expiration_frc := expiration_frc;
    password_data_seq_p := #SEQ (password_data);
    dsp$access_vcu_cda_data (dsc$vcu_write_access, dsc$vcu_password_data, password_data_seq_p, local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (' ', FALSE, local_status);
      osp$fatal_system_error ('Unable to write password data to CDA.', ^local_status);
    IFEND;

    dpp$put_next_line (id, 'Parameter entry for the SETOI command has been completed.', local_status);
    dpp$put_next_line (id, ' ', local_status);

  PROCEND dsp$process_setoi_command;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$process_setop_command', EJECT ??

{ PURPOSE:
{   This procedure is called from the system core command set_operation_password (setop).  It is used to set
{   the Operation Password in VCU.  This command is only allowed to be used once, when the password data in
{   VCU is not initialized.

  PROCEDURE [XDCL] dsp$process_setop_command
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      loop_count: 0 .. 0ff(16),
      password: t$password,
      password_data: dst$vcu_password_data,
      password_data_seq_p: ^SEQ ( * ),
      token: t$token;

    status.normal := TRUE;
    IF dsv$mainframe_type = dsc$mt_93x_mainframe THEN
      dpp$put_next_line (id, 'WARNING -- The SETOP command is not allowed to be used on this mainframe.',
            local_status);
      RETURN;
    IFEND;

    IF syv$reading_dcfile THEN
      dpp$put_next_line (id, 'WARNING -- The SETOP command must be entered by an operator, not from a file.',
            local_status);
      RETURN;
    IFEND;

    password_data_seq_p := #SEQ (password_data);
    dsp$access_vcu_cda_data (dsc$vcu_read_access, dsc$vcu_password_data, password_data_seq_p, local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (' ', FALSE, local_status);
      osp$fatal_system_error ('Unable to read password data from CDA.', ^local_status);
    IFEND;

    IF password_data.password_initialized THEN
      dpp$put_next_line (id, 'ERROR -- A SETOP command has already been entered.  Use the', local_status);
      dpp$put_next_line (id, '         CHAOP command after deadstart to change the password.', local_status);
      RETURN;
    IFEND;

    token.kind := c$tk_password_value;
    loop_count := 3;

   /retrieve_password/
    WHILE TRUE DO
      IF loop_count <= 0 THEN
        dpp$put_next_line (id, '         Allowable retries for the command exceeded, command aborted.',
              local_status);
        dpp$put_next_line (id, ' ', local_status);
        RETURN;
      ELSE
        loop_count := loop_count - 1;
      IFEND;

      get_data (id, 'Enter the Operation Password:', '(it will not be displayed on the screen)', token);
      IF NOT token.retrieved THEN
        RETURN;
      IFEND;
      password.password := token.data.value (1, token.data.size);
      get_data (id, 'Please reenter the password for confirmation:', ' ', token);
      IF NOT token.retrieved THEN
        RETURN;
      IFEND;
      IF token.data.value (1, token.data.size) <> password.password THEN
        dpp$put_next_line (id, 'ERROR -- The passwords do not match, try again.', local_status);
        dpp$put_next_line (id, ' ', local_status);
        CYCLE /retrieve_password/;
      IFEND;
      EXIT /retrieve_password/;
    WHILEND /retrieve_password/;
    change_password (TRUE, password);

    password_data.password_initialized := TRUE;
    password_data.encrypted_password := password.encrypted_password;
    password_data_seq_p := #SEQ (password_data);
    dsp$access_vcu_cda_data (dsc$vcu_write_access, dsc$vcu_password_data, password_data_seq_p, local_status);
    IF NOT local_status.normal THEN
      syp$process_deadstart_status (' ', FALSE, local_status);
      osp$fatal_system_error ('Unable to write password data to CDA.', ^local_status);
    IFEND;

    dpp$put_next_line (id, 'Parameter entry for the SETOP command has been completed.', local_status);
    dpp$put_next_line (id, ' ', local_status);

  PROCEND dsp$process_setop_command;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$set_operation_interval', EJECT ??

{ PURPOSE:
{   This procedure changes the current operation interval that is stored in VCU.  It first checks that the
{   password parameter matches the password in VCU.  It also validates the date before saving the new data in
{   VCU.

  PROCEDURE [XDCL, #GATE] dsp$set_operation_interval
    (    password: ost$name;
         date_time: ost$date_time;
     VAR status: ost$status);

    VAR
      current_date_time: ost$date_time,
      current_frc: jmt$clock_time,
      expiration_frc: jmt$clock_time,
      password_data: dst$vcu_password_data,
      password_data_seq_p: ^SEQ ( * ),
      vcu_password: t$password;

    status.normal := TRUE;
    IF dsv$mainframe_type = dsc$mt_93x_mainframe THEN
      osp$set_status_condition (dse$command_not_allowed, status);
      RETURN;
    IFEND;

    password_data_seq_p := #SEQ (password_data);
    dsp$access_vcu_cda_data (dsc$vcu_read_access, dsc$vcu_password_data, password_data_seq_p, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status (' ', FALSE, status);
      osp$fatal_system_error ('Unable to read password data from CDA.', ^status);
    IFEND;

    IF NOT password_data.password_initialized THEN
      osp$set_status_condition (dse$no_password_exists, status);
      RETURN;
    IFEND;

    vcu_password.encrypted_password := password_data.encrypted_password;
    change_password (FALSE, vcu_password);
    IF vcu_password.password <> password (1, 7) THEN
      osp$set_status_condition (dse$invalid_password, status);
      RETURN;
    IFEND;

    pmp$verify_compact_date (date_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_compact_date_time (current_date_time, status);
    pmp$get_microsecond_clock (current_frc, status);
    jmp$convert_date_time_dif_to_us (current_date_time, date_time, current_frc, expiration_frc);
    IF expiration_frc <= current_frc THEN
      osp$set_status_condition (dse$invalid_interval_entered, status);
      RETURN;
    IFEND;

    password_data.interval_initialized := TRUE;
    password_data.interval_expired := FALSE;
    password_data.saved_current_frc := current_frc;
    password_data.expiration_frc := expiration_frc;
    password_data_seq_p := #SEQ (password_data);
    dsp$access_vcu_cda_data (dsc$vcu_write_access, dsc$vcu_password_data, password_data_seq_p, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status (' ', FALSE, status);
      osp$fatal_system_error ('Unable to write password data to CDA.', ^status);
    IFEND;

  PROCEND dsp$set_operation_interval;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$set_operation_password', EJECT ??

{ PURPOSE:
{   This procedure sets the operation password that is stored in VCU.

  PROCEDURE [XDCL, #GATE] dsp$set_operation_password
    (    password: ost$name;
     VAR status: ost$status);

    VAR
      index: 0 .. 0ff(16),
      password_data: dst$vcu_password_data,
      password_data_seq_p: ^SEQ ( * ),
      vcu_password: t$password;

    status.normal := TRUE;
    IF dsv$mainframe_type = dsc$mt_93x_mainframe THEN
      osp$set_status_condition (dse$command_not_allowed, status);
      RETURN;
    IFEND;

    password_data_seq_p := #SEQ (password_data);
    dsp$access_vcu_cda_data (dsc$vcu_read_access, dsc$vcu_password_data, password_data_seq_p, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status (' ', FALSE, status);
      osp$fatal_system_error ('Unable to read password data from CDA.', ^status);
    IFEND;

    IF password_data.password_initialized THEN
      osp$set_status_condition (dse$password_exists, status);
      RETURN;
    IFEND;

    IF password (7) = ' ' THEN
      osp$set_status_condition (dse$seven_character_password, status);
      RETURN;
    IFEND;

    FOR index := 1 TO 7 DO
      IF NOT ((password (index) >= 'A') AND (password (index) <= 'Z')) AND
            NOT ((password (index) >= '0') AND (password (index) <= '9')) THEN
        osp$set_status_condition (dse$alphanumeric_password, status);
        RETURN;
      IFEND;
    FOREND;

    vcu_password.password := password (1, 7);
    change_password (TRUE, vcu_password);

    password_data.password_initialized := TRUE;
    password_data.encrypted_password := vcu_password.encrypted_password;
    password_data_seq_p := #SEQ (password_data);
    dsp$access_vcu_cda_data (dsc$vcu_write_access, dsc$vcu_password_data, password_data_seq_p, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status (' ', FALSE, status);
      osp$fatal_system_error ('Unable to write password data to CDA.', ^status);
    IFEND;

  PROCEND dsp$set_operation_password;
?? OLDTITLE ??
MODEND dsm$manage_interval_password;
*DECK DECK=DSM$MANAGE_PP_LIBRARY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : PP Library Management' ??
MODULE dsm$manage_pp_library;

{ PURPOSE:
{   This module contains the procedures that maintain the PP library.
{ DESIGN:
{   The PP library is in a linked list format.  The PP entries are linked together to form the list.  Each
{   entry contains the PP's name, a pointer to the PP's data and a pointer to the next link in the list.
{   The VE disk/tape drivers (VDT) are read from the common disk area (CDA) in CTI in the BOOT.  The PP library
{   is not created in the BOOT because of space constraints.  System core accesses VDT from the BOOT memory
{   and builds the PP library in mainframe pageable.  The PPs that reside on the deadstart device are added
{   to the library later.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dse$pp_library_errors
*copyc dst$c170_77_table
*copyc dst$driver_name
*copyc dst$fetch_pp_image_option
*copyc dst$pp_header_descriptor
*copyc ost$hardware_subranges
*copyc ost$pp_size
?? POP ??
*copyc dsp$allocate_continuous_memory
*copyc dsp$fetch_boot_data
*copyc dsp$read_cda_program
*copyc dsp$read_deadstart_device
*copyc dsp$read_header_labels
*copyc dsp$retrieve_cda_data_size
*copyc dsp$save_boot_data_pointer
*copyc i#real_memory_address
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc syp$display_deadstart_message
*copyc syp$trace_deadstart_message
?? EJECT ??
*copyc dsv$boot_data_base_p
*copyc osv$boot_is_executing
*copyc osv$mainframe_pageable_heap
*copyc osv$mainframe_wired_cb_heap
*copyc osv$mainframe_wired_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  TYPE
    t$boot_entry = RECORD
      pp_entry: t$pp_entry,
      next_entry_p: ^t$boot_entry,
    RECEND,

    t$display_code_character = 0 .. 77(8),

    t$display_code_string = 0 .. 0777777777777777(8),

    t$pp_entry = RECORD
      name: dst$driver_name,
      overlay_rma: ost$real_memory_address,
      driver_code_p: ^SEQ ( * ),
      data_p: ^SEQ ( * ),
      next_p: ^t$pp_entry,
    RECEND;
?? EJECT ??
  VAR
    v$boot_entry_p: ^t$boot_entry := NIL,
    v$pp_library_p:[XDCL] ^t$pp_entry := NIL,
    v$vdt_data_seq_p: ^SEQ ( * ) := NIL;
?? OLDTITLE ??
?? NEWTITLE := 'convert_dc_int_to_ascii_string', EJECT ??

{ PURPOSE:
{   This procedure converts a seven character string from display code to ascii.

  PROCEDURE convert_dc_int_to_ascii_string
    (    display_code_name: t$display_code_string;
     VAR name: dst$driver_name);

    VAR
      convert_size: t$display_code_string,
      display_code_number: t$display_code_string,
      name_index: 1 .. 7,
      number: t$display_code_character;

    display_code_number := display_code_name;
    convert_size := 100000000000000(8);
    FOR name_index := 1 TO 7 DO
      convert_size := convert_size DIV 100(8);
      number := display_code_number DIV convert_size;
      display_code_number := display_code_number MOD convert_size;
      IF (number >= 33(8)) AND (number <= 44(8)) THEN     { display code character is between '0' and '9'
        name (name_index) := $CHAR (number + 25(8));
      ELSEIF (number >= 1(8)) AND (number <= 32(8)) THEN  { display code character is between 'A' and 'Z'
        name (name_index) := $CHAR (number + 100(8));
      ELSEIF number = 47(8) THEN
        name (name_index) := '*';
      ELSEIF number = 54(8) THEN
        name (name_index) := '=';
      ELSEIF number = 56(8) THEN
        name (name_index) := ',';
      ELSEIF number = 57(8) THEN
        name (name_index) := '.';
      ELSE
        name (name_index) := ' ';
      IFEND;
    FOREND;

  PROCEND convert_dc_int_to_ascii_string;
?? OLDTITLE ??
?? NEWTITLE := 'fetch_boot_pp', EJECT ??

{ PURPOSE:
{   This procedure reads the VE disk/tape drivers (VDT) from CTI and searches the sequence
{   for the desired PP.
{ NOTES:
{   1.  The caller of this procedure must send a pointer to a sequence to hold the PP image.
{   2.  The PP binary contains a 77 table that must be removed before it is returned to the caller.
{   3.  The PP library is not built here to keep the size of the boot small.

  PROCEDURE fetch_boot_pp
    (    name: dst$driver_name;
     VAR pp_data_seq_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      cda_data_size: integer,
      pp_77_table_p: ^dst$c170_77_table,
      pp_name: dst$driver_name,
      pp_size: integer,
      rel_vdt_p: [STATIC] REL (SEQ ( * )) ^SEQ ( * ),
      vdt_data_size: integer;

    status.normal := TRUE;

    IF v$vdt_data_seq_p = NIL THEN

      { Read the VE disk/tape drivers (VDT) from the common disk area (CDA) in CTI.

      dsp$retrieve_cda_data_size ('VDT ', cda_data_size, status);
      IF NOT status.normal THEN
        osp$system_error ('ERROR: Retrieving the data size of VDT.', ^status);
      IFEND;

      dsp$allocate_continuous_memory (osv$mainframe_wired_heap, cda_data_size, v$vdt_data_seq_p);
      RESET v$vdt_data_seq_p;

      dsp$read_cda_program ('VDT ', v$vdt_data_seq_p, vdt_data_size, status);
      IF NOT status.normal THEN
        osp$system_error ('ERROR: Reading the CDA program VDT.', ^status);
      IFEND;
      IF vdt_data_size < #SIZE (dst$c170_77_table) THEN
        osp$system_error ('ERROR: VDT is incorrectly built.', NIL);
      IFEND;
      RESET v$vdt_data_seq_p;

      { Save a pointer to the VDT data so that the data can be retrieved in system core and be used
      { to create the PP library.

      rel_vdt_p := #REL (v$vdt_data_seq_p, dsv$boot_data_base_p^);
      dsp$save_boot_data_pointer (dsc$pp_library, #SEQ (rel_vdt_p));
    IFEND;

    RESET v$vdt_data_seq_p;
    vdt_data_size := #SIZE (v$vdt_data_seq_p^);

    WHILE vdt_data_size > #SIZE (dst$c170_77_table) DO
      NEXT pp_77_table_p IN v$vdt_data_seq_p;
      vdt_data_size := vdt_data_size - #SIZE (pp_77_table_p^);
      convert_dc_int_to_ascii_string (pp_77_table_p^.module_name, pp_name);
      pp_size := pp_77_table_p^.lwa * 8;
      IF vdt_data_size < pp_size THEN
        osp$system_error ('ERROR: VDT is incorrectly built', NIL);
      IFEND;
      NEXT pp_data_seq_p: [[REP pp_size OF cell]] IN v$vdt_data_seq_p;
      vdt_data_size := vdt_data_size - #SIZE (pp_data_seq_p^);
      IF pp_name = name THEN
        RETURN;
      IFEND;
    WHILEND;
    osp$set_status_abnormal (dsc$display_processor_id, dse$driver_not_found, name, status);
    pp_data_seq_p := NIL;

  PROCEND fetch_boot_pp;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$add_to_pp_library', EJECT ??

{  PURPOSE:
{    This procedure moves the non boot driver PPs from the deadstart device to the PP library.

  PROCEDURE [XDCL] dsp$add_to_pp_library;

    VAR
      data_size_read: integer,
      file_identifier: dst$deadstart_file_identifier,
      last_pp_entry_p: ^t$pp_entry,
      library_77_table_p: ^dst$c170_77_table,
      pp_77_table: dst$c170_77_table,
      pp_77_table_seq_p: ^SEQ ( * ),
      pp_data_p: ^SEQ ( * ),
      pp_entry_p: ^t$pp_entry,
      pp_size: integer;

    dsp$read_header_labels (file_identifier);
    IF file_identifier <> 'NON_BOOT_DRIVERS' THEN
      osp$system_error ('Invalid deadstart file: Cannot find the non_boot_driver.', NIL);
    IFEND;

    { Find the last entry in the PP library.

    pp_entry_p := v$pp_library_p;
    WHILE pp_entry_p^.next_p <> NIL DO
      pp_entry_p := pp_entry_p^.next_p;
    WHILEND;
    last_pp_entry_p := pp_entry_p;
    pp_77_table_seq_p := #SEQ (pp_77_table);

   /move_non_boot_driver/
    WHILE TRUE DO
      dsp$read_deadstart_device (#SIZE (dst$c170_77_table), pp_77_table_seq_p, data_size_read);
      IF data_size_read < #SIZE (dst$c170_77_table) THEN
        EXIT /move_non_boot_driver/;
      IFEND;

      ALLOCATE pp_entry_p IN osv$mainframe_pageable_heap^;
      last_pp_entry_p^.next_p := pp_entry_p;
      pp_entry_p^.overlay_rma := 0;
      pp_entry_p^.driver_code_p := NIL;
      convert_dc_int_to_ascii_string (pp_77_table.module_name, pp_entry_p^.name);
      syp$trace_deadstart_message (pp_entry_p^.name);
      pp_size := pp_77_table.lwa * 8;

      ALLOCATE pp_entry_p^.data_p: [[REP (pp_size + #SIZE (dst$c170_77_table)) OF cell]] IN
            osv$mainframe_pageable_heap^;
      RESET pp_entry_p^.data_p;

      NEXT library_77_table_p IN pp_entry_p^.data_p;
      library_77_table_p^ := pp_77_table;
      NEXT pp_data_p: [[REP pp_size OF cell]] IN pp_entry_p^.data_p;
      RESET pp_data_p;

      dsp$read_deadstart_device (pp_size, pp_data_p, data_size_read);
      IF data_size_read < pp_size THEN
        EXIT /move_non_boot_driver/;
      IFEND;

      last_pp_entry_p := pp_entry_p;
    WHILEND /move_non_boot_driver/;

    last_pp_entry_p^.next_p := NIL;

  PROCEND dsp$add_to_pp_library;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$create_pp_library', EJECT ??

{ PURPOSE:
{   This procedure creates the PP library in system core and moves all of the PPs from the VDT sequence to
{   the PP library.  This is not done in the boot to save space.

  PROCEDURE [XDCL] dsp$create_pp_library;

    VAR
      last_pp_entry_p: ^t$pp_entry,
      library_77_table_p: ^dst$c170_77_table,
      library_data_p: ^SEQ ( * ),
      pp_77_table_p: ^dst$c170_77_table,
      pp_data_p: ^SEQ ( * ),
      pp_entry_p: ^t$pp_entry,
      pp_size: integer,
      rel_vdt_p: REL (SEQ ( * )) ^SEQ ( * ),
      rel_vdt_seq_p: ^SEQ ( * ),
      vdt_data_size: integer;

    syp$display_deadstart_message ('Creating the PP library from VDT ...');

    { Fetch the pointer to VDT in the boot memory space.

    rel_vdt_seq_p := #SEQ (rel_vdt_p);
    dsp$fetch_boot_data (dsc$pp_library, rel_vdt_seq_p);
    v$vdt_data_seq_p := #PTR (rel_vdt_p, dsv$boot_data_base_p^);
    RESET v$vdt_data_seq_p;
    vdt_data_size := #SIZE (v$vdt_data_seq_p^);

    WHILE vdt_data_size > #SIZE (dst$c170_77_table) DO
      IF v$pp_library_p = NIL THEN
        ALLOCATE v$pp_library_p IN osv$mainframe_pageable_heap^;
        pp_entry_p := v$pp_library_p;
      ELSE
        ALLOCATE pp_entry_p IN osv$mainframe_pageable_heap^;
        last_pp_entry_p^.next_p := pp_entry_p;
      IFEND;
      pp_entry_p^.overlay_rma := 0;
      pp_entry_p^.driver_code_p := NIL;

      { Read the pp's 77 table and retrieve the length of the PP.

      NEXT pp_77_table_p IN v$vdt_data_seq_p;
      vdt_data_size := vdt_data_size - #SIZE (pp_77_table_p^);
      convert_dc_int_to_ascii_string (pp_77_table_p^.module_name, pp_entry_p^.name);
      syp$trace_deadstart_message (pp_entry_p^.name);
      pp_size := pp_77_table_p^.lwa * 8;
      IF vdt_data_size < pp_size THEN
        osp$system_error ('ERROR: VDT is incorrectly built.', NIL);
      IFEND;

      { Allocate space for the pp and its 77 table.

      ALLOCATE pp_entry_p^.data_p: [[REP (#SIZE (pp_77_table_p^) + pp_size) OF cell]] IN
            osv$mainframe_pageable_heap^;
      RESET pp_entry_p^.data_p;

      NEXT library_77_table_p IN pp_entry_p^.data_p;
      library_77_table_p^ := pp_77_table_p^;

      NEXT library_data_p: [[REP pp_size OF cell]] IN pp_entry_p^.data_p;
      NEXT pp_data_p: [[REP pp_size OF cell]] IN v$vdt_data_seq_p;
      vdt_data_size := vdt_data_size - #SIZE (pp_data_p^);
      library_data_p^ := pp_data_p^;

      last_pp_entry_p := pp_entry_p;

    WHILEND;
    last_pp_entry_p^.next_p := NIL;
    v$vdt_data_seq_p := NIL;

  PROCEND dsp$create_pp_library;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$fetch_pp_image', EJECT ??

{ PURPOSE:
{   This procedure acquires the requested PP from the PP library or directly from VDT if
{   executing in the boot.
{ NOTES:
{   1.  The caller of this procedure must send a pointer to a sequence to hold the PP image.
{   2.  The PP binary contains a 77 table that must be removed before it is returned to the caller.
{   3.  Depending on the setting of OPTION, the base overlay may be returned to the sequence, or the length
{       of the overlay image (if any) may be returned as LENGTH, or the overlay image itself will be returned
{       to the sequence.

  PROCEDURE [XDCL] dsp$fetch_pp_image
    (    name: dst$driver_name;
         option: dst$fetch_pp_image_option;
     VAR length: ost$pp_byte_size;
     VAR image_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      extra_size: ost$pp_byte_size,
      image_data_p: ^SEQ ( * ),
      pp_77_table_p: ^dst$c170_77_table,
      pp_data_p: ^SEQ ( * ),
      pp_data_seq_p: ^SEQ ( * ),
      pp_entry_p: ^t$pp_entry,
      pp_header_p: ^dst$pp_header_descriptor,
      pp_size: ost$pp_byte_size,
      total_length: integer;

    status.normal := TRUE;

    IF osv$boot_is_executing THEN
      fetch_boot_pp (name, pp_data_seq_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      extra_size := #SIZE (dst$pp_header_descriptor);
      total_length := #SIZE (pp_data_seq_p^);
      IF extra_size > #SIZE (pp_data_seq_p^) THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$driver_damaged, '', status);
        RETURN;
      IFEND;
      RESET pp_data_seq_p;
    ELSE

      { Search the library for the correct PP.

      pp_entry_p := v$pp_library_p;
      WHILE pp_entry_p^.name <> name DO
        pp_entry_p := pp_entry_p^.next_p;
        IF pp_entry_p = NIL THEN
          osp$set_status_abnormal (dsc$display_processor_id, dse$driver_not_found, name, status);
          RETURN;
        IFEND;
      WHILEND;
      pp_data_seq_p := pp_entry_p^.data_p;
      total_length := #SIZE (pp_entry_p^.data_p^) - #SIZE (dst$c170_77_table);
      extra_size := #SIZE (dst$c170_77_table) + #SIZE (dst$pp_header_descriptor);
      IF extra_size > #SIZE (pp_data_seq_p^) THEN
        osp$set_status_abnormal (dsc$display_processor_id, dse$driver_damaged, '', status);
        RETURN;
      IFEND;
      RESET pp_data_seq_p;
      NEXT pp_77_table_p IN pp_data_seq_p;
    IFEND;

    NEXT pp_header_p IN pp_data_seq_p;
    pp_size := pp_header_p^.cm_word_length * 8;

    IF pp_size > (#SIZE (pp_data_seq_p^) - extra_size) THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$driver_damaged, '', status);
      RETURN;
    IFEND;

    CASE option OF
    = dsc$fpio_fetch_base_overlay =
      length := pp_size;
    = dsc$fpio_return_overlay_length =
      length := total_length - pp_size - #SIZE (dst$pp_header_descriptor);
      RETURN;
    = dsc$fpio_fetch_overlays =
      length := total_length - pp_size - #SIZE (dst$pp_header_descriptor);
      NEXT pp_data_p: [[REP pp_size OF cell]] IN pp_data_seq_p;
    ELSE
      ;
    CASEND;

    { Determine if the caller sent a large enough sequence to receive the PP/overlay image.

    IF length > #SIZE (image_p^) THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$buffer_too_small, '', status);
      RETURN;
    IFEND;

    { Move the PP/overlay image to the caller's address space.

    NEXT pp_data_p: [[REP length OF cell]] IN pp_data_seq_p;

    RESET image_p;
    NEXT image_data_p: [[REP length OF cell]] IN image_p;

    image_data_p^ := pp_data_p^;
    RESET image_p;

  PROCEND dsp$fetch_pp_image;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$move_pp_driver', EJECT ??

{ PURPOSE:
{   This procedure copies the requested PP driver's main overlay, if any, to an area of contiguous memory
{   and returns a pointer to it.  If the driver was previously copied, the previous pointer is returned.
{   If this request is made during the boot time or if the PP driver is not found, a NIL pointer is returned.

  PROCEDURE [XDCL] dsp$move_pp_driver
    (    name: dst$driver_name;
     VAR driver_code_p: ^SEQ ( * ));

    VAR
      driver_p: ^SEQ ( * ),
      driver_size: integer,
      pp_77_table_p: ^dst$c170_77_table,
      pp_entry_p: ^t$pp_entry,
      pp_header_p: ^dst$pp_header_descriptor;

    driver_code_p := NIL;

    IF osv$boot_is_executing THEN
      RETURN;
    IFEND;

    pp_entry_p := v$pp_library_p;
    WHILE (pp_entry_p <> NIL) AND (pp_entry_p^.name <> name) DO
      pp_entry_p := pp_entry_p^.next_p;
    WHILEND;
    IF pp_entry_p = NIL THEN
      RETURN;
    IFEND;

    IF pp_entry_p^.driver_code_p <> NIL THEN
      driver_code_p := pp_entry_p^.driver_code_p;
      RETURN;
    IFEND;

    RESET pp_entry_p^.data_p;
    NEXT pp_77_table_p IN pp_entry_p^.data_p;
    NEXT pp_header_p IN pp_entry_p^.data_p;
    IF (pp_77_table_p = NIL) OR (pp_header_p = NIL) THEN
      RETURN;
    IFEND;

    driver_size := pp_header_p^.cm_word_length * 8;
    NEXT driver_p: [[REP driver_size OF cell]] IN pp_entry_p^.data_p;
    IF driver_p = NIL THEN
      RETURN;
    IFEND;

    dsp$allocate_continuous_memory (osv$mainframe_wired_cb_heap, driver_size, pp_entry_p^.driver_code_p);
    pp_entry_p^.driver_code_p^ := driver_p^;
    driver_code_p := pp_entry_p^.driver_code_p;

  PROCEND dsp$move_pp_driver;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$move_pp_overlays', EJECT ??

{ PURPOSE:
{  This procedure copies the requested PP's overlays, if any, to an area of contiguous memory and returns
{  the RMA pointer to the calling procedure.  If the driver has previously had its overlays copied, the
{  previous RMA is returned.

  PROCEDURE [XDCL] dsp$move_pp_overlays
    (    name: dst$driver_name;
     VAR rma: ost$real_memory_address;
     VAR status: ost$status);

    VAR
      boot_entry_p: ^t$boot_entry,
      directory_header_p: ^dst$pp_header_descriptor,
      directory_entry_p: ^dst$pp_header_descriptor,
      directory_size: dst$pp_word,
      index: dst$pp_word,
      length: ost$pp_byte_size,
      overlay1_offset: dst$pp_word,
      pp_entry_p: ^t$pp_entry,
      rma_p: ^SEQ ( * ),
      rma_int: integer;

    status.normal := TRUE;

    { During the boot environment, each driver will be allocated a new overlay structure, since there is no
    { easy way to keep track of existing overlay structures.  The memory will be released during the
    { transition to the system core environment.  In system core, only one copy of the overlay structure for
    { a particular driver will be made.

    IF osv$boot_is_executing THEN
      boot_entry_p := v$boot_entry_p;

     /search_boot_entries/
      WHILE boot_entry_p <> NIL DO
        IF name = boot_entry_p^.pp_entry.name THEN
          EXIT /search_boot_entries/;
        IFEND;
        boot_entry_p := boot_entry_p^.next_entry_p;
      WHILEND /search_boot_entries/;

      IF boot_entry_p = NIL THEN
        ALLOCATE boot_entry_p IN osv$mainframe_wired_heap^;
        boot_entry_p^.pp_entry.name := name;
        boot_entry_p^.pp_entry.overlay_rma := 0;
        boot_entry_p^.pp_entry.driver_code_p := NIL;
        boot_entry_p^.next_entry_p := v$boot_entry_p;
        v$boot_entry_p := boot_entry_p;
      IFEND;
      pp_entry_p := ^boot_entry_p^.pp_entry;
    ELSE
      pp_entry_p := v$pp_library_p;
      WHILE pp_entry_p^.name <> name DO
        pp_entry_p := pp_entry_p^.next_p;
        IF pp_entry_p = NIL THEN
          osp$set_status_abnormal (dsc$display_processor_id, dse$driver_not_found, name, status);
          RETURN;
        IFEND;
      WHILEND;
    IFEND;

    IF pp_entry_p^.overlay_rma <> 0 THEN
      rma := pp_entry_p^.overlay_rma;
      RETURN;
    IFEND;

    { Get the length of the driver's overlay structure, if any, and allocate space in MAINFRAME_WIRED_CB_HEAP.

    dsp$fetch_pp_image (name, dsc$fpio_return_overlay_length, length, rma_p, status);
    IF (length = 0) OR (NOT status.normal) THEN
      RETURN;
    IFEND;
    dsp$allocate_continuous_memory (osv$mainframe_wired_cb_heap, length, rma_p);

    { Copy the PP overlays to the memory allocated.

    dsp$fetch_pp_image (name, dsc$fpio_fetch_overlays, length, rma_p, status);
    IF NOT status.normal THEN
      FREE rma_p IN osv$mainframe_wired_cb_heap^;
      RETURN;
    IFEND;

    { Update the PP library entry to reflect the RMA of the overlays.

    RESET rma_p;
    i#real_memory_address (rma_p, rma_int);
    rma := rma_int;
    pp_entry_p^.overlay_rma := rma;

    { The overlay directory initially contains CM word offsets from the base overlay header word.  These must
    { be converted to CM word offsets from the directory header word, since the base overlay has been removed.

    RESET rma_p;
    NEXT directory_header_p IN rma_p;
    directory_size := directory_header_p^.cm_word_length;
    NEXT directory_entry_p IN rma_p;
    overlay1_offset := directory_entry_p^.overlay_offset;
    directory_entry_p^.overlay_offset := directory_size + 1;
    FOR index := 2 TO directory_size DO
      NEXT directory_entry_p IN rma_p;
      directory_entry_p^.overlay_offset := directory_entry_p^.overlay_offset - overlay1_offset +
            directory_size + 1;
    FOREND;

  PROCEND dsp$move_pp_overlays;
?? OLDTITLE ??
MODEND dsm$manage_pp_library;
*DECK DECK=DSM$MANAGE_RDF_AND_IMAGE_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Manage RDF and Image File' ??
MODULE dsm$manage_rdf_and_image_file;

{ PURPOSE:
{   This module contains procedures used to manage the RDF areas and the image file.  The RDF (recover
{   deadstart file) areas exist before the image file on the device file.  The RDF area consists of four
{   areas.  These areas contain values that must be saved across deadstarts.  These areas are created during
{   an installation deadstart and used during continuation deadstarts.  This is a very delicate area that
{   cannot be changed without worring about back level support of the operating system.  Each RDF area
{   contains a directory and a storage area.  The directory contains entries which define the values that
{   are stored in the storage area.  Each entry contains a four character name and a relative pointer to the
{   data stored in the storage area.  Each of the four RDF areas has a special meaning to the deadstart
{   process.  The first RDF area contains data used during a production deadstart.  The second RDF area
{   contains data for the system message buffer, data from the existing buffer is stored in this area during
{   a recovery.  The third RDF contains data used during a recovery deadstart.  The fourth RDF area is unused.
{   New entries can be added to these areas.  Several things must be done for each new entry:
{     1)  An ordinal describing the entry must be added to the type declaration dst$rdf_entries.
{     2)  The v$rdf_entries array in this module, containing the four character name of the entry and the size
{         of the entry data, must be updated.
{     3)  A call to create_an_rdf_entry must be added to the procedure establish_the_rdf_areas.  That
{         procedure is divided into four areas for each RDF area so the call to create_an_rdf_entry must be
{         added in the correct place.  This will create the entry during an installation deadstart.  If the
{         entry does not exist during a continuation deadstart then the entry will be created.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmc$deadstart_file_alloc_size
*copyc dsc$rdf_constants
*copyc dst$image_file
*copyc dst$image_status
*copyc dst$list_block
*copyc dst$rdf_entries
*copyc dst$rdf_pointers
*copyc dst$rdf_type
*copyc dst$recover_deadstart_files
*copyc jmt$system_supplied_name
*copyc mmt$rcv_memory_mgr
*copyc pft$retained_restore_status
?? POP ??
*copyc dmp$attach_device_file
*copyc dmp$close_file
*copyc dmp$detach_device_file
*copyc dmp$open_file
*copyc dsp$create_image_file
*copyc dsp$update_image_values_in_ssr
*copyc i#current_sequence_position
*copyc mmp$write_modified_pages
*copyc osp$system_error
*copyc pmp$zero_out_table
?? EJECT ??
*copyc dmv$system_device_information
*copyc dsv$rdf_size
*copyc jmv$system_core_id
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  TYPE
    t$rdf_entry = RECORD
      name: t$rdf_entry_name,
      data_p: REL (SEQ ( * )) ^SEQ ( * ),
    RECEND,

    t$rdf_entry_name = string (4);
?? EJECT ??
  VAR

    { This variable contains the four character name of the RDF entry and the size, in bytes, of the RDF
    { entry data.  When a new RDF entry is added, an ordinal should be added to dst$rdf_entries and the
    { name and the size should be added to this array in the correct spot.

    v$rdf_entries: [READ] ARRAY [dst$rdf_entries] OF RECORD
      name: t$rdf_entry_name,
      size: 0 .. dsc$rdf_size,
    RECEND := [['CNDF', 8],                                              {dsc$rdf_commit_new_dsfile_flag
               ['SDST', 8],                                              {dsc$rdf_deadstart_state
               ['SDIR', dsc$rdf_directory_size],                         {dsc$rdf_directory
               ['GIMG', 8],                                              {dsc$rdf_good_image_flag
               ['SIZE', 8],                                              {dsc$rdf_image_size
               ['SKIP', 8],                                              {dsc$rdf_image_table_size
               ['JOBR', 8],                                              {dsc$rdf_job_recovery
               ['JROP', 8],                     {no longer used at 1.4.1  dsc$rdf_job_recovery_command
               ['LIST', #SIZE (dst$list_block)],                         {dsc$rdf_list_block
               ['LOAD', 8],                                              {dsc$rdf_lower_memory_limit
               ['MEMM', #SIZE (mmt$rcv_memory_mgr)],                     {dsc$rdf_page_table_modified_bit
               ['PIMW', 8],                                              {dsc$rdf_password_interval_data
               ['PREC', 8],                                              {dsc$rdf_previous_recovery_type
               ['RNAM', 32],                                             {dsc$rdf_recovery_image_status
               ['REGV', 4*8],                                            {dsc$rdf_register_values
               ['REST', #SIZE (pft$retained_restore_status)],            {dsc$rdf_restore_status
               ['NAMO', 8],                                              {dsc$rdf_ssr_name_bo_in_image
               ['STOR', dsc$rdf_size - dsc$rdf_directory_size],          {dsc$rdf_storage_area
               ['SSIZ', 8],                                              {dsc$rdf_sys_msg_buffer_size
               ['SCID', #SIZE (jmv$system_core_id)],                     {dsc$rdf_system_core_id
               ['IDLE', 32],                                             {dsc$rdf_system_idled_status
               ['SBUF', dsc$rdf_size - (dsc$rdf_directory_size + 200)],  {dsc$rdf_system_messages_buffer
               ['LSSN', jmc$system_supplied_name_size]],                 {dsc$rdf_system_supplied_name

    v$rdf_file_sfid_during_idle: dmt$system_file_id,
    v$rdf_sfid_during_idle_exists: boolean := FALSE;
?? OLDTITLE ??
?? NEWTITLE := 'create_an_rdf_entry', EJECT ??

{ PURPOSE:
{   This procedure creates an entry in the specified RDF area.  An entry consists of a name which identifies
{   the entry and a relative pointer which points to the entry's data which is stored in the RDF storage area.

  PROCEDURE create_an_rdf_entry
    (    rdf_name: dst$rdf_entries;
     VAR rdf_seq_p: ^SEQ ( * ));

    VAR
      new_rdf_entry_p: ^t$rdf_entry,
      rdf_data_seq_p: ^SEQ ( * ),
      rdf_directory_entry_p: ^t$rdf_entry,
      rdf_directory_seq_p: ^SEQ ( * ),
      rdf_storage_entry_p: ^t$rdf_entry,
      rdf_storage_seq_p: ^SEQ ( * ),
      temp_rdf_seq_p: ^SEQ ( * );

    { Strip off the directory entry and the storage entry of the RDF area.

    temp_rdf_seq_p := rdf_seq_p;
    RESET temp_rdf_seq_p;
    NEXT rdf_directory_entry_p IN temp_rdf_seq_p;
    NEXT rdf_storage_entry_p IN temp_rdf_seq_p;

    { Retrieve the sequence pointer to the next available spot in the directory.

    rdf_directory_seq_p := #PTR (rdf_directory_entry_p^.data_p, rdf_seq_p^);

    { Add the new entry and update the directory pointer to point to the next available spot in the directory.

    IF (i#current_sequence_position (rdf_directory_seq_p) + #SIZE (t$rdf_entry)) > dsc$rdf_directory_size THEN
      osp$system_error ('The RDF directory has overflowed, cannot add anymore entries', NIL);
    IFEND;
    NEXT new_rdf_entry_p IN rdf_directory_seq_p;
    new_rdf_entry_p^.name := v$rdf_entries [rdf_name].name;
    rdf_directory_entry_p^.data_p := #REL (rdf_directory_seq_p, rdf_seq_p^);

    { Retrieve the sequence pointer to the next available spot in the storage area.

    rdf_storage_seq_p := #PTR (rdf_storage_entry_p^.data_p, rdf_seq_p^);

    { Create space for the new data in the next available spot in the storage area.

    IF (i#current_sequence_position (rdf_storage_seq_p) + v$rdf_entries [rdf_name].size) > dsc$rdf_size THEN
      osp$system_error ('The RDF area has overflowed, cannot add anymore data entries', NIL);
    IFEND;
    NEXT rdf_data_seq_p: [[REP v$rdf_entries [rdf_name].size OF cell]] IN rdf_storage_seq_p;
    pmp$zero_out_table (#LOC (rdf_data_seq_p^), #SIZE (rdf_data_seq_p^));
    new_rdf_entry_p^.data_p := #REL (rdf_data_seq_p, rdf_seq_p^);

    { Update the storage pointer to point to the next available spot in the storage area.

    rdf_storage_entry_p^.data_p := #REL (rdf_storage_seq_p, rdf_seq_p^);

  PROCEND create_an_rdf_entry;
?? OLDTITLE ??
?? NEWTITLE := 'establish_the_rdf_areas', EJECT ??

{ PURPOSE:
{   This procedure establishes the RDF areas so that they are ready to be used.  This procedure should only
{   be called during an installation deadstart.

  PROCEDURE establish_the_rdf_areas;

    VAR
      local_status: ost$status,
      rdf_file_segment: mmt$segment_pointer,
      rdf_file_sfid: dmt$system_file_id,
      rdf_pointers: dst$rdf_pointers;

    dsp$open_rdf (rdf_file_sfid, rdf_file_segment, rdf_pointers);

    { Zero out the RDF area.

    pmp$zero_out_table (#LOC (rdf_file_segment.seq_pointer^), dsv$rdf_size);

    { Establish the production area of the RDF.

    format_the_rdf_area (rdf_pointers.production_seq_p);

    create_an_rdf_entry (dsc$rdf_commit_new_dsfile_flag, rdf_pointers.production_seq_p);
    create_an_rdf_entry (dsc$rdf_image_size, rdf_pointers.production_seq_p);
    create_an_rdf_entry (dsc$rdf_image_table_size, rdf_pointers.production_seq_p);
    create_an_rdf_entry (dsc$rdf_job_recovery, rdf_pointers.production_seq_p);
    create_an_rdf_entry (dsc$rdf_job_recovery_command, rdf_pointers.production_seq_p);
    create_an_rdf_entry (dsc$rdf_list_block, rdf_pointers.production_seq_p);
    create_an_rdf_entry (dsc$rdf_lower_memory_limit, rdf_pointers.production_seq_p);
    create_an_rdf_entry (dsc$rdf_page_table_modified_bit, rdf_pointers.production_seq_p);
    create_an_rdf_entry (dsc$rdf_previous_recovery_type, rdf_pointers.production_seq_p);
    create_an_rdf_entry (dsc$rdf_recovery_image_status, rdf_pointers.production_seq_p);
    create_an_rdf_entry (dsc$rdf_register_values, rdf_pointers.production_seq_p);
    create_an_rdf_entry (dsc$rdf_restore_status, rdf_pointers.production_seq_p);
    create_an_rdf_entry (dsc$rdf_ssr_name_bo_in_image, rdf_pointers.production_seq_p);
    create_an_rdf_entry (dsc$rdf_system_core_id, rdf_pointers.production_seq_p);
    create_an_rdf_entry (dsc$rdf_system_supplied_name, rdf_pointers.production_seq_p);
    create_an_rdf_entry (dsc$rdf_password_interval_data, rdf_pointers.production_seq_p);

    RESET rdf_pointers.production_seq_p;
    mmp$write_modified_pages (rdf_pointers.production_seq_p, #SIZE (rdf_pointers.production_seq_p^),
          osc$wait, local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('Cannot write modified pages (establish production rdf).', ^local_status);
    IFEND;

    { Establish the system message buffer area of the RDF.

    format_the_rdf_area (rdf_pointers.system_message_buffer_seq_p);

    create_an_rdf_entry (dsc$rdf_system_messages_buffer, rdf_pointers.system_message_buffer_seq_p);
    create_an_rdf_entry (dsc$rdf_sys_msg_buffer_size, rdf_pointers.system_message_buffer_seq_p);

    RESET rdf_pointers.system_message_buffer_seq_p;
    mmp$write_modified_pages (rdf_pointers.system_message_buffer_seq_p,
          #SIZE (rdf_pointers.system_message_buffer_seq_p^), osc$wait, local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('Cannot write modified pages (establish system message buffer rdf).', ^local_status);
    IFEND;

    { Establish the recovery area of the RDF.

    format_the_rdf_area (rdf_pointers.recovery_seq_p);

    create_an_rdf_entry (dsc$rdf_deadstart_state, rdf_pointers.recovery_seq_p);
    create_an_rdf_entry (dsc$rdf_good_image_flag, rdf_pointers.recovery_seq_p);
    create_an_rdf_entry (dsc$rdf_list_block, rdf_pointers.recovery_seq_p);
    create_an_rdf_entry (dsc$rdf_lower_memory_limit, rdf_pointers.recovery_seq_p);
    create_an_rdf_entry (dsc$rdf_page_table_modified_bit, rdf_pointers.recovery_seq_p);
    create_an_rdf_entry (dsc$rdf_recovery_image_status, rdf_pointers.recovery_seq_p);
    create_an_rdf_entry (dsc$rdf_register_values, rdf_pointers.recovery_seq_p);
    create_an_rdf_entry (dsc$rdf_ssr_name_bo_in_image, rdf_pointers.recovery_seq_p);
    create_an_rdf_entry (dsc$rdf_system_idled_status, rdf_pointers.recovery_seq_p);

    RESET rdf_pointers.recovery_seq_p;
    mmp$write_modified_pages (rdf_pointers.recovery_seq_p, #SIZE (rdf_pointers.recovery_seq_p^),
          osc$wait, local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('Cannot write modified pages (establish recovery rdf).', ^local_status);
    IFEND;

    { Establish the unused area of the RDF.

    format_the_rdf_area (rdf_pointers.unused_seq_p);

    RESET rdf_pointers.unused_seq_p;
    mmp$write_modified_pages (rdf_pointers.unused_seq_p, #SIZE (rdf_pointers.unused_seq_p^),
          osc$wait, local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('Cannot write modified pages (establish unused rdf).', ^local_status);
    IFEND;

    dsp$close_rdf (rdf_file_sfid, rdf_file_segment);

  PROCEND establish_the_rdf_areas;
?? OLDTITLE ??
?? NEWTITLE := 'format_the_rdf_area', EJECT ??

{ PURPOSE:
{   This procedure formats the specified RDF area.  Each area contains a directory area and a storage area.

  PROCEDURE format_the_rdf_area
    (VAR rdf_seq_p: ^SEQ ( * ));

    VAR
      rdf_directory_entry_p: ^t$rdf_entry,
      rdf_directory_seq_p: ^SEQ ( * ),
      rdf_storage_entry_p: ^t$rdf_entry,
      temp_rdf_seq_p: ^SEQ ( * );

    { Set a temporary pointer to the beginning of the RDF area.

    temp_rdf_seq_p := rdf_seq_p;
    RESET temp_rdf_seq_p;

    { Create the directory for the RDF area.

    NEXT rdf_directory_seq_p: [[REP dsc$rdf_directory_size OF cell]] IN temp_rdf_seq_p;
    RESET rdf_directory_seq_p;

    { Create the directory entry and the storage entry for the RDF area.  The directory entry contains a
    { pointer which points to the next available spot in the directory and the storage entry contains a
    { pointer which points to the next available spot in the storage area.

    NEXT rdf_directory_entry_p IN rdf_directory_seq_p;
    NEXT rdf_storage_entry_p IN rdf_directory_seq_p;
    rdf_directory_entry_p^.name := v$rdf_entries [dsc$rdf_directory].name;
    rdf_directory_entry_p^.data_p := #REL (rdf_directory_seq_p, rdf_seq_p^);
    rdf_storage_entry_p^.name := v$rdf_entries [dsc$rdf_storage_area].name;
    rdf_storage_entry_p^.data_p := #REL (temp_rdf_seq_p, rdf_seq_p^);

  PROCEND format_the_rdf_area;
?? OLDTITLE ??
?? NEWTITLE := 'get_pointer_to_rdf_type', EJECT ??

{ PURPOSE:
{   This procedure returns a pointer to the correct RDF area based on the RDF type.  It also checks to see if
{   the recovery segment, which contains the RDFs, is damaged.  The production RDF and the recovery RDF must
{   be defined.  It is possible, because of back level support, that the other two RDFs are not defined.

  PROCEDURE get_pointer_to_rdf_type
    (    rdf_type: dst$rdf_type;
     VAR rdf_pointers: dst$rdf_pointers;
     VAR rdf_seq_p: ^SEQ ( * ));

    VAR
      rdf_directory_entry_p: ^t$rdf_entry,
      rdf_storage_entry_p: ^t$rdf_entry,
      temp_rdf_seq_p: ^SEQ ( * );

    { Find the pointer to the correct RDF area.

    CASE rdf_type OF
    = dsc$rdf_production =
      rdf_seq_p := rdf_pointers.production_seq_p;
    = dsc$rdf_system_message_buffer =
      rdf_seq_p := rdf_pointers.system_message_buffer_seq_p;
    = dsc$rdf_recovery =
      rdf_seq_p := rdf_pointers.recovery_seq_p;
    ELSE { = dsc$rdf_unused =
      rdf_seq_p := rdf_pointers.unused_seq_p;
    CASEND;

    { Check if the recovery segment is destroyed.  If the RDF area does not have a directory entry and a
    { storage entry then the RDF area is not setup.  At this point, both the production and the recovery
    { areas should be set up.  If they are not set up then the recovery segment is considered destroyed.

    temp_rdf_seq_p := rdf_seq_p;
    RESET temp_rdf_seq_p;
    NEXT rdf_directory_entry_p IN temp_rdf_seq_p;
    NEXT rdf_storage_entry_p IN temp_rdf_seq_p;
    IF (rdf_directory_entry_p^.name <> v$rdf_entries [dsc$rdf_directory].name) OR
          (rdf_storage_entry_p^.name <> v$rdf_entries [dsc$rdf_storage_area].name) THEN
      CASE rdf_type OF
      = dsc$rdf_production =
        osp$system_error ('The production RDF in the recovery segment is destroyed', NIL);
      = dsc$rdf_system_message_buffer =

        { This is an upgrade to 1.2.1.

        format_the_rdf_area (rdf_pointers.system_message_buffer_seq_p);
        create_an_rdf_entry (dsc$rdf_system_messages_buffer, rdf_pointers.system_message_buffer_seq_p);
        create_an_rdf_entry (dsc$rdf_sys_msg_buffer_size, rdf_pointers.system_message_buffer_seq_p);
      = dsc$rdf_recovery =
        osp$system_error ('The recovery RDF in the recovery segment is destroyed', NIL);
      ELSE { = dsc$rdf_unused =

        { This is an upgrade to 1.2.1

        format_the_rdf_area (rdf_pointers.unused_seq_p);
      CASEND;
    IFEND;

  PROCEND get_pointer_to_rdf_type;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$attach_rdf_for_idle', EJECT ??

{ PURPOSE:
{   This procedure attaches the RDF device file so that it can be opened during idle_system when the attach
{   would not be allowed.

  PROCEDURE [XDCL, #GATE] dsp$attach_rdf_for_idle;

    VAR
      local_status: ost$status,
      name: ost$name;

    { Attach the RDF device file.

    name := dsc$image_file_name;
    dmp$attach_device_file (dmv$system_device_recorded_vsn, name, v$rdf_file_sfid_during_idle, local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('Cannot attach the device file for the RDF area for idle.', ^local_status);
    IFEND;
    v$rdf_sfid_during_idle_exists := TRUE;

  PROCEND dsp$attach_rdf_for_idle;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$build_recovery_segment', EJECT ??

{ PURPOSE:
{   This procedure creates a device file which contains the recovery deadstart file (RDF) area followed by
{   the image file.  The image will consist of a block of memory.  The image is written before the system is
{   loaded into this block, this plus memory outside of this block provides all needed memory from the
{   previously running system needed for system recovery.  The size of the image is determined from an entry
{   in the RDF.  The entire device file is referred to as the image file in most cases. The part of this
{   device file that contains the RDF is referred to as the image table or the RDF.
{
{ NOTE:
{   The creation of the recovery device file is only done on an installation deadstart.

  PROCEDURE [XDCL] dsp$build_recovery_segment;

    VAR
      local_status: ost$status,
      name_stored: ost$name;

    { Set size of the RDF to a multiple of the allocation size.

    dsv$rdf_size := #SIZE (dst$recover_deadstart_files);
    IF (#SIZE (dst$recover_deadstart_files) MOD dmc$deadstart_file_alloc_size) > 0 THEN
      dsv$rdf_size := dsv$rdf_size + dmc$deadstart_file_alloc_size -
            (#SIZE (dst$recover_deadstart_files) MOD dmc$deadstart_file_alloc_size);
    IFEND;

    dsp$create_image_file ((dsv$rdf_size + dsc$image_size), local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('Cannot create image file.', ^local_status);
    IFEND;

    { Create the RDF areas.

    establish_the_rdf_areas;

    dsp$store_integer_in_rdf (dsc$rdf_image_size, dsc$rdf_production, dsc$image_size);
    dsp$store_integer_in_rdf (dsc$rdf_image_table_size, dsc$rdf_production, dsv$rdf_size);
    dsp$store_integer_in_rdf (dsc$rdf_good_image_flag, dsc$rdf_recovery, $INTEGER (FALSE));

    { Set the recovery condition names to 'initialized'.

    name_stored := dsc$image_initialized;
    dsp$store_data_in_rdf (dsc$rdf_recovery_image_status, dsc$rdf_recovery, #SEQ (name_stored));
    dsp$store_data_in_rdf (dsc$rdf_system_idled_status, dsc$rdf_recovery, #SEQ (name_stored));

    dsp$update_image_values_in_ssr;

  PROCEND dsp$build_recovery_segment;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$close_image_file', EJECT ??

{ PURPOSE:
{   This procedure closes the image device file.  All modified pages of the device file are written to mass
{   storage as a result of this procedure.
{
{ NOTE:
{   All errors are considered fatal to system operation.

  PROCEDURE [XDCL] dsp$close_image_file
    (    image_file_sfid: dmt$system_file_id;
         image_file_segment: mmt$segment_pointer);

    VAR
      file_modified: boolean,
      fmd_modified: boolean,
      status: ost$status;

    { Close and detach the image file.

    dmp$close_file (image_file_segment.seq_pointer, status);
    IF NOT status.normal THEN
      osp$system_error ('Cannot close the image device file.', ^status);
    IFEND;

    dmp$detach_device_file (image_file_sfid, file_modified, fmd_modified, status);
    IF NOT status.normal THEN
      osp$system_error ('Cannot detach the image device file.', ^status);
    IFEND;

  PROCEND dsp$close_image_file;
?? OLDTITLE ??
?? TITLE := 'dsp$close_rdf', EJECT ??

{ PURPOSE:
{   This procedure closes the RDF device file.  All modified pages of the device file are written to mass
{   storage as a result of this procedure.  The RDF cannot be accessed until it is opened again.
{
{ NOTE:
{   All errors are considered fatal to system operation.

  PROCEDURE [XDCL, #GATE] dsp$close_rdf
    (    rdf_file_sfid: dmt$system_file_id;
         rdf_file_segment: mmt$segment_pointer);

    VAR
      file_modified: boolean,
      fmd_modified: boolean,
      local_status: ost$status;

    { Close and detach the RDF file.

    dmp$close_file (rdf_file_segment.seq_pointer, local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('Cannot close the device file for the RDF area.', ^local_status);
    IFEND;

    IF NOT v$rdf_sfid_during_idle_exists THEN
      dmp$detach_device_file (rdf_file_sfid, file_modified, fmd_modified, local_status);
      IF NOT local_status.normal THEN
        osp$system_error ('Cannot detach the device file for the RDF area.', ^local_status);
      IFEND;
    IFEND;

  PROCEND dsp$close_rdf;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$detach_rdf_after_resume', EJECT ??

{ PURPOSE:
{   This procedure detaches the RDF device file that was attached for the idle_system now that the system
{   is resumed.

  PROCEDURE [XDCL, #GATE] dsp$detach_rdf_after_resume;

    VAR
      file_modified: boolean,
      fmd_modified: boolean,
      local_status: ost$status;

    { Detach the RDF device file.

    dmp$detach_device_file (v$rdf_file_sfid_during_idle, file_modified, fmd_modified, local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('Cannot detach the device file for the RDF area after resume.', ^local_status);
    IFEND;
    v$rdf_sfid_during_idle_exists := FALSE;

  PROCEND dsp$detach_rdf_after_resume;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$determine_if_entry_in_rdf', EJECT ??

{ PURPOSE:
{   This procedure determines if the given RDF entry is in the specified RDF area.

  PROCEDURE [XDCL] dsp$determine_if_entry_in_rdf
    (    rdf_name: dst$rdf_entries;
         rdf_type: dst$rdf_type;
     VAR rdf_entry_exists: boolean);

    VAR
      next_avail_directory_entry_p: ^t$rdf_entry,
      rdf_directory_entry_p: ^t$rdf_entry,
      rdf_directory_seq_p: ^SEQ ( * ),
      rdf_entry_p: ^t$rdf_entry,
      rdf_file_segment: mmt$segment_pointer,
      rdf_file_sfid: dmt$system_file_id,
      rdf_seq_p: ^SEQ ( * ),
      rdf_pointers: dst$rdf_pointers,
      temp_rdf_seq_p: ^SEQ ( * );

    dsp$open_rdf (rdf_file_sfid, rdf_file_segment, rdf_pointers);

    { Retrieve the pointer to the correct RDF area.

    get_pointer_to_rdf_type (rdf_type, rdf_pointers, rdf_seq_p);

    { Retrieve the directory entry to the RDF area.

    temp_rdf_seq_p := rdf_seq_p;
    RESET temp_rdf_seq_p;
    NEXT rdf_directory_entry_p IN temp_rdf_seq_p;

    { Search the RDF directory to determine whether the specified entry exists.

    rdf_directory_seq_p := #PTR (rdf_directory_entry_p^.data_p, rdf_seq_p^);
    NEXT next_avail_directory_entry_p IN rdf_directory_seq_p;
    RESET temp_rdf_seq_p;
    NEXT rdf_entry_p IN temp_rdf_seq_p;
    rdf_entry_exists := FALSE;
    WHILE (rdf_entry_p <> next_avail_directory_entry_p) AND (NOT rdf_entry_exists) DO
      rdf_entry_exists := (rdf_entry_p^.name = v$rdf_entries [rdf_name].name);
      NEXT rdf_entry_p IN temp_rdf_seq_p;
    WHILEND;

    dsp$close_rdf (rdf_file_sfid, rdf_file_segment);

  PROCEND dsp$determine_if_entry_in_rdf;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$get_data_from_rdf', EJECT ??

{ PURPOSE:
{   This procedure retrieves data from the specified RDF area.  The caller to this procedure should set up a
{   sequence pointer to their data variable, call this procedure with the sequence pointer and then access
{   their data variable directly.
{     EXAMPLE:  data_variable_seq_p := #SEQ (data_variable);
{               dsp$get_data_from_rdf (rdf_name, rdf_type, data_variable_seq_p);
{               IF data_variable = 'xxx' THEN
{                   etc.

  PROCEDURE [XDCL, #GATE] dsp$get_data_from_rdf
    (    rdf_name: dst$rdf_entries;
         rdf_type: dst$rdf_type;
     VAR rdf_value_p: ^SEQ ( * ));

    VAR
      data_seq_p: ^SEQ ( * ),
      rdf_entry_seq_p: ^SEQ ( * ),
      rdf_file_segment: mmt$segment_pointer,
      rdf_file_sfid: dmt$system_file_id,
      rdf_pointers: dst$rdf_pointers;

    dsp$open_rdf (rdf_file_sfid, rdf_file_segment, rdf_pointers);

    { Retrieve the sequence pointer to the requested data.

    dsp$get_rdf_entry_seq_pointer (rdf_name, rdf_type, rdf_pointers, rdf_entry_seq_p);
    RESET rdf_entry_seq_p;

    { Move the data from the RDF area to the parameter sequence pointer.

    IF #SIZE (rdf_value_p^) > #SIZE (rdf_entry_seq_p^) THEN
      NEXT data_seq_p: [[REP #SIZE (rdf_entry_seq_p^) OF cell]] IN rdf_entry_seq_p;
    ELSE
      NEXT data_seq_p: [[REP #SIZE (rdf_value_p^) OF cell]] IN rdf_entry_seq_p;
    IFEND;
    rdf_value_p^ := data_seq_p^;

    dsp$close_rdf (rdf_file_sfid, rdf_file_segment);

  PROCEND dsp$get_data_from_rdf;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$get_integer_from_rdf', EJECT ??

{ PURPOSE:
{   This procedure retrieves an integer value from the specified RDF area.

  PROCEDURE [XDCL, #GATE] dsp$get_integer_from_rdf
    (    rdf_name: dst$rdf_entries;
         rdf_type: dst$rdf_type;
     VAR rdf_value: integer);

    VAR
      rdf_value_seq_p: ^SEQ ( * );

    rdf_value_seq_p := #SEQ (rdf_value);
    dsp$get_data_from_rdf (rdf_name, rdf_type, rdf_value_seq_p);

  PROCEND dsp$get_integer_from_rdf;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$get_rdf_entry_seq_pointer', EJECT ??

{ PURPOSE:
{   This procedure retrieves a pointer to the entry in the specified RDF area.  If the entry does not exists,
{   this procedure will create the entry.  This procedure expects the caller to open and close the RDF.

  PROCEDURE [XDCL, #GATE] dsp$get_rdf_entry_seq_pointer
    (    rdf_name: dst$rdf_entries;
         rdf_type: dst$rdf_type;
     VAR rdf_pointers: dst$rdf_pointers;
     VAR rdf_entry_seq_p: ^SEQ ( * ));

    VAR
      local_status: ost$status,
      next_avail_directory_entry_p: ^t$rdf_entry,
      rdf_entry_exists: boolean,
      rdf_directory_entry_p: ^t$rdf_entry,
      rdf_directory_seq_p: ^SEQ ( * ),
      rdf_entry_p: ^t$rdf_entry,
      rdf_seq_p: ^SEQ ( * ),
      temp_rdf_seq_p: ^SEQ ( * );

    { Retrieve the pointer to the correct RDF area.

    get_pointer_to_rdf_type (rdf_type, rdf_pointers, rdf_seq_p);

    { Retrieve the directory entry of the RDF area.

    temp_rdf_seq_p := rdf_seq_p;
    RESET temp_rdf_seq_p;
    NEXT rdf_directory_entry_p IN temp_rdf_seq_p;

    { Search the RDF directory to determine whether the specified entry exists.

    rdf_directory_seq_p := #PTR (rdf_directory_entry_p^.data_p, rdf_seq_p^);
    NEXT next_avail_directory_entry_p IN rdf_directory_seq_p;
    RESET temp_rdf_seq_p;
    NEXT rdf_entry_p IN temp_rdf_seq_p;
    rdf_entry_exists := FALSE;
    WHILE (rdf_entry_p <> next_avail_directory_entry_p) AND (NOT rdf_entry_exists) DO
      rdf_entry_exists := (rdf_entry_p^.name = v$rdf_entries [rdf_name].name);
      NEXT rdf_entry_p IN temp_rdf_seq_p;
    WHILEND;
    IF NOT rdf_entry_exists THEN
      create_an_rdf_entry (rdf_name, rdf_seq_p);
      RESET rdf_seq_p;
      mmp$write_modified_pages (rdf_seq_p, #SIZE (rdf_seq_p^), osc$wait, local_status);
      IF NOT local_status.normal THEN
        osp$system_error ('Cannot write modified pages (dsp$get_rdf_entry_seq_pointer)', ^local_status);
      IFEND;
    IFEND;

    { Retrieve the sequence pointer to the directory.

    rdf_directory_seq_p := #PTR (rdf_directory_entry_p^.data_p, rdf_seq_p^);

    { Find the correct entry in the directory.

    RESET rdf_directory_seq_p;
    REPEAT
      NEXT rdf_entry_p IN rdf_directory_seq_p;
    UNTIL rdf_entry_p^.name = v$rdf_entries [rdf_name].name;

    { Retrieve the sequence pointer to the storage area for the entry.

    rdf_entry_seq_p := #PTR (rdf_entry_p^.data_p, rdf_seq_p^);

  PROCEND dsp$get_rdf_entry_seq_pointer;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$open_image_file', EJECT ??

{ PURPOSE:
{   This procedure opens the image device file and allows access to the file.
{
{ NOTE:
{   All errors are considered fatal to system operation.

  PROCEDURE [XDCL] dsp$open_image_file
    (VAR image_file_sfid: dmt$system_file_id;
     VAR image_file_segment: mmt$segment_pointer;
     VAR image_file_p: ^SEQ ( * ));

    VAR
      ignore_rdf_part_p: ^SEQ ( * ),
      local_status: ost$status,
      name: ost$name,
      rdf_size: integer;

    { Attach the image file.

    name := dsc$image_file_name;
    dmp$attach_device_file (dmv$system_device_recorded_vsn, name, image_file_sfid, local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('Cannot attach image device file.', ^local_status);
    IFEND;

    { Make a segment for the image file.

    image_file_segment.kind := mmc$sequence_pointer;
    dmp$open_file (image_file_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_random,
          image_file_segment, local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('Cannot open the image device file.', ^local_status);
    IFEND;

    RESET image_file_segment.seq_pointer;

    { Get size of the RDF and save in global variable if not already done.

    IF dsv$rdf_size = 0 THEN
      dsp$get_integer_from_rdf (dsc$rdf_image_table_size, dsc$rdf_production, rdf_size);
      dsv$rdf_size := rdf_size;
    IFEND;

    { Skip over the RDF at the beginning of the device file.

    NEXT ignore_rdf_part_p: [[REP dsv$rdf_size OF cell]] IN image_file_segment.seq_pointer;

    { Retrieve a pointer to the image file.

    NEXT image_file_p: [[REP 7fffffff(16) - dsv$rdf_size OF cell]] IN image_file_segment.seq_pointer;
    RESET image_file_p;

  PROCEND dsp$open_image_file;
?? OLDTITLE ??
?? TITLE := 'dsp$open_rdf', EJECT ??

{ PURPOSE:
{   This procedure opens the RDF device file and initializes pointers to the separate RDF areas.
{
{ NOTE:
{   All errors are considered fatal to system operation.

  PROCEDURE [XDCL, #GATE] dsp$open_rdf
    (VAR rdf_file_sfid: dmt$system_file_id;
     VAR rdf_file_segment: mmt$segment_pointer;
     VAR rdf_pointers: dst$rdf_pointers);

    VAR
      local_status: ost$status,
      name: ost$name,
      rdf_p: ^dst$recover_deadstart_files;

    { Attach the RDF device file.

    IF v$rdf_sfid_during_idle_exists THEN
      rdf_file_sfid := v$rdf_file_sfid_during_idle;
    ELSE
      name := dsc$image_file_name;
      dmp$attach_device_file (dmv$system_device_recorded_vsn, name, rdf_file_sfid, local_status);
      IF NOT local_status.normal THEN
        osp$system_error ('Cannot attach the device file for the RDF area.', ^local_status);
      IFEND;
    IFEND;

    { Make a segment for the image file.

    rdf_file_segment.kind := mmc$sequence_pointer;
    dmp$open_file (rdf_file_sfid, osc$os_ring_1, osc$tsrv_ring, mmc$sar_write_extend, mmc$as_random,
          rdf_file_segment, local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('Cannot open the device file for the RDF area.', ^local_status);
    IFEND;

    { Setup the rdf pointers.

    RESET rdf_file_segment.seq_pointer;
    NEXT rdf_p IN rdf_file_segment.seq_pointer;
    rdf_pointers.production_seq_p := ^rdf_p^.production;
    rdf_pointers.system_message_buffer_seq_p := ^rdf_p^.system_message_buffer;
    rdf_pointers.recovery_seq_p := ^rdf_p^.recovery;
    rdf_pointers.unused_seq_p := ^rdf_p^.unused;

  PROCEND dsp$open_rdf;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$store_data_in_rdf', EJECT ??

{ PURPOSE:
{   This procedure stores data in the specified RDF area.  The caller of this procedure should use the #SEQ
{   function so that they do not have to set up a sequence.
{     EXAMPLE:  dsp$store_data_in_rdf (rdf_name, rdf_type, #SEQ (data_variable));
{   After the procedure call the data_variable can be access directly.

  PROCEDURE [XDCL, #GATE] dsp$store_data_in_rdf
    (    rdf_name: dst$rdf_entries;
         rdf_type: dst$rdf_type;
         rdf_value_p: ^SEQ ( * ));

    VAR
      data_seq_p: ^SEQ ( * ),
      local_status: ost$status,
      rdf_entry_seq_p: ^SEQ ( * ),
      rdf_file_segment: mmt$segment_pointer,
      rdf_file_sfid: dmt$system_file_id,
      rdf_pointers: dst$rdf_pointers;

    dsp$open_rdf (rdf_file_sfid, rdf_file_segment, rdf_pointers);

    { Retrieve the sequence pointer to the data area.

    dsp$get_rdf_entry_seq_pointer (rdf_name, rdf_type, rdf_pointers, rdf_entry_seq_p);

    { Move the data from the parameter sequence pointer to the rdf area.

    RESET rdf_entry_seq_p;
    IF #SIZE (rdf_value_p^) > #SIZE (rdf_entry_seq_p^) THEN
      osp$system_error ('Trying to store too large a data item in the rdf area', NIL);
    IFEND;
    NEXT data_seq_p: [[REP #SIZE (rdf_value_p^) OF cell]] IN rdf_entry_seq_p;
    data_seq_p^ := rdf_value_p^;

    RESET rdf_entry_seq_p;
    mmp$write_modified_pages (rdf_entry_seq_p, #SIZE (rdf_entry_seq_p^), osc$wait, local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('Cannot write modified pages (dsp$store_data_in_rdf).', ^local_status);
    IFEND;

    dsp$close_rdf (rdf_file_sfid, rdf_file_segment);

  PROCEND dsp$store_data_in_rdf;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$store_integer_in_rdf', EJECT ??

{ PURPOSE:
{   This procedure stores an integer value in the specified RDF area.

  PROCEDURE [XDCL, #GATE] dsp$store_integer_in_rdf
    (    rdf_name: dst$rdf_entries;
         rdf_type: dst$rdf_type;
         rdf_value: integer);

    dsp$store_data_in_rdf (rdf_name, rdf_type, #SEQ (rdf_value));

  PROCEND dsp$store_integer_in_rdf;
MODEND dsm$manage_rdf_and_image_file;
*DECK DECK=DSM$MANAGE_SSR_ROUTINES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Manage SSR Routines' ??
MODULE dsm$manage_ssr_routines;

{ PURPOSE:
{   This module contains the procedures that are used to manage the system status record (SSR) areas.
{ NOTE:
{   There is a corresponding module in monitor that manages the SSR routines.  Any changes made to this
{   module may also need to be made to the module dsm$mtr_manage_ssr_routines.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dst$ssr_data_types
?? POP ??
*copyc dsp$build_sequence_p
*copyc dsp$convert_seq_p_to_r_pointer
*copyc i#real_memory_address
*copyc mmp$close_asid_based_segment
*copyc mmp$create_ssr_sdtx
*copyc mmp$open_asid_based_segment
*copyc osp$system_error
?? EJECT ??
*copyc dsv$ssr_sdte
*copyc osv$boot_is_executing
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    dsv$ssr_size: [XDCL] 0 .. 0fffff(16),
    v$ssr_sdtex: mmt$segment_descriptor_extended;
?? TITLE := 'access_ssr_segment', EJECT ??

{ PURPOSE:
{   This procedure builds a sequence pointer to the SSR area and retrieves the desired ssr entry.

  PROCEDURE access_ssr_segment
    (    ssr_segment_number: ost$segment;
         ssr_entry_name: dst$ssr_entry_name;
     VAR ssr_seq_p: ^SEQ ( * );
     VAR ssr_entry_p: ^dst$ssr_entry);

    VAR
      ssr_address_p: ^cell;

    ssr_address_p := #ADDRESS (1, ssr_segment_number, dsc$ssr_offset);
    dsp$build_sequence_p (ssr_address_p, dsv$ssr_size, ssr_seq_p);

    RESET ssr_seq_p;
    REPEAT
      NEXT ssr_entry_p IN ssr_seq_p;
      IF (ssr_entry_p <> NIL) AND (ssr_entry_p^.name = ssr_entry_name) THEN
        RESET ssr_seq_p;
        RETURN;
      IFEND;
    UNTIL ssr_entry_p = NIL;
    osp$system_error (' Entry is not defined in the SSR', NIL);

  PROCEND access_ssr_segment;
?? TITLE := 'dsp$close_ssr', EJECT ??

{ PURPOSE:
{   This procedure removes the SSR from the segment table of the user.

  PROCEDURE [XDCL] dsp$close_ssr
    (VAR ssr_segment_number: ost$segment;
     VAR status: ost$status);

    status.normal := TRUE;
    IF NOT osv$boot_is_executing THEN
      mmp$close_asid_based_segment (ssr_segment_number, status);
    IFEND;

  PROCEND dsp$close_ssr;
?? TITLE := 'dsp$get_data_from_ssr', EJECT ??

{ PURPOSE:
{   This procedure retrieves data from the SSR.  The caller to this procedure should set up a sequence pointer
{   to their data variable, call this procedure with the sequence pointer and then access their data variable
{   directly.
{     EXAMPLE:  data_variable_seq_p := #SEQ (data_variable);
{               dsp$get_data_from_ssr (ssr_entry_name, data_variable_seq_p);
{               IF data_variable = 'xxx' THEN
{                   etc.

  PROCEDURE [XDCL] dsp$get_data_from_ssr
    (    ssr_entry_name: dst$ssr_entry_name;
     VAR ssr_value_p: ^SEQ ( * ));

    VAR
      data_seq_p: ^SEQ ( * ),
      skip_seq_p: ^SEQ ( * ),
      ssr_entry_p: ^dst$ssr_entry,
      ssr_segment_number: ost$segment,
      ssr_seq_p: ^SEQ ( * ),
      ssr_value_seq_p: ^SEQ ( * ),
      status: ost$status;

    dsp$open_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to open the SSR.', ^status);
    IFEND;

    access_ssr_segment (ssr_segment_number, ssr_entry_name, ssr_seq_p, ssr_entry_p);

    RESET ssr_seq_p;
    IF ssr_entry_p^.right_slot > 0 THEN
      NEXT skip_seq_p: [[REP ssr_entry_p^.right_slot OF integer]] IN ssr_seq_p;
    IFEND;
    NEXT ssr_value_seq_p: [[REP ssr_entry_p^.left_slot OF integer]] IN ssr_seq_p;
    RESET ssr_value_seq_p;

    { Move the data from the SSR area to the parameter sequence pointer.

    RESET ssr_value_p;
    IF #SIZE (ssr_value_p^) > #SIZE (ssr_value_seq_p^) THEN
      NEXT data_seq_p: [[REP #SIZE (ssr_value_seq_p^) OF cell]] IN ssr_value_p;
      data_seq_p^ := ssr_value_seq_p^;
    ELSE
      NEXT data_seq_p: [[REP #SIZE (ssr_value_p^) OF cell]] IN ssr_value_seq_p;
      ssr_value_p^ := data_seq_p^;
    IFEND;
    RESET ssr_value_p;

    dsp$close_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to close the SSR.', ^status);
    IFEND;

  PROCEND dsp$get_data_from_ssr;
?? TITLE := 'dsp$get_entry_from_ssr', EJECT ??

{ PURPOSE:
{   This procedure retrieves an entry from the SSR.

  PROCEDURE [XDCL] dsp$get_entry_from_ssr
    (    ssr_entry_name: dst$ssr_entry_name;
     VAR ssr_entry: dst$ssr_entry);

    VAR
      ssr_entry_p: ^dst$ssr_entry,
      ssr_segment_number: ost$segment,
      ssr_seq_p: ^SEQ ( * ),
      status: ost$status;

    dsp$open_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to open the SSR.', ^status);
    IFEND;

    access_ssr_segment (ssr_segment_number, ssr_entry_name, ssr_seq_p, ssr_entry_p);

    ssr_entry := ssr_entry_p^;

    dsp$close_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to close the SSR.', ^status);
    IFEND;

  PROCEND dsp$get_entry_from_ssr;
?? TITLE := 'dsp$get_ssr_data_r_pointer', EJECT ??

{ PURPOSE:
{   This procedure retrieves an r pointer to specific data in the SSR.

  PROCEDURE [XDCL] dsp$get_ssr_data_r_pointer
    (    ssr_entry_name: dst$ssr_entry_name;
     VAR ssr_data_r_pointer: dst$r_pointer);

    VAR
      ssr_data_seq_p: ^SEQ ( * ),
      ssr_segment_number: ost$segment,
      status: ost$status;

    dsp$open_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to open the SSR.', ^status);
    IFEND;

    dsp$get_ssr_data_seq_ptr (ssr_entry_name, ssr_segment_number, ssr_data_seq_p);
    dsp$convert_seq_p_to_r_pointer (ssr_data_seq_p, ssr_data_r_pointer);

    dsp$close_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to close the SSR.', ^status);
    IFEND;

  PROCEND dsp$get_ssr_data_r_pointer;
?? TITLE := 'dsp$get_ssr_data_rma', EJECT ??

{ PURPOSE:
{   This procedure retrieves an RMA to specific data in the SSR.

  PROCEDURE [XDCL] dsp$get_ssr_data_rma
    (    ssr_entry_name: dst$ssr_entry_name;
     VAR ssr_data_rma: integer;
     VAR ssr_data_size: integer);

    VAR
      ssr_data_seq_p: ^SEQ ( * ),
      ssr_segment_number: ost$segment,
      status: ost$status;

    dsp$open_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to open the SSR.', ^status);
    IFEND;

    dsp$get_ssr_data_seq_ptr (ssr_entry_name, ssr_segment_number, ssr_data_seq_p);
    i#real_memory_address (ssr_data_seq_p, ssr_data_rma);
    ssr_data_size := #SIZE (ssr_data_seq_p^);

    dsp$close_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to close the SSR.', ^status);
    IFEND;

  PROCEND dsp$get_ssr_data_rma;
?? TITLE := 'dsp$get_ssr_data_seq_ptr', EJECT ??

{ PURPOSE:
{   This procedure retrieves a pointer to specific data in the SSR.  This procedure expects the caller to
{   open and close the SSR.

  PROCEDURE [XDCL] dsp$get_ssr_data_seq_ptr
    (    ssr_entry_name: dst$ssr_entry_name;
         ssr_segment_number: ost$segment;
     VAR ssr_data_seq_p: ^SEQ ( * ));

    VAR
      skip_seq_p: ^SEQ ( * ),
      ssr_entry_p: ^dst$ssr_entry,
      ssr_seq_p: ^SEQ ( * );

    access_ssr_segment (ssr_segment_number, ssr_entry_name, ssr_seq_p, ssr_entry_p);

    IF ssr_entry_p^.right_slot > 0 THEN
      NEXT skip_seq_p: [[REP ssr_entry_p^.right_slot OF integer]] IN ssr_seq_p;
    IFEND;
    NEXT ssr_data_seq_p: [[REP ssr_entry_p^.left_slot OF integer]] IN ssr_seq_p;
    RESET ssr_data_seq_p;

  PROCEND dsp$get_ssr_data_seq_ptr;
?? TITLE := 'dsp$make_ssr_segment', EJECT ??

{ PURPOSE:
{   This procedure adds the predefined SSR segment to the NOS/VE job modes segment table.
{ NOTES:
{   The SSR segment is created in the BOOT interrupt handler in that an ASID is chosen and the PTEs are
{   created.  In the BOOT, this segment is added to the boot job segment table as segment four.  In NOS/VE
{   the segment starts out living only in the monitor segment table and in this procedure NOS/VE job mode
{   adds the segment to its segment table.

  PROCEDURE [XDCL] dsp$make_ssr_segment;

    VAR
      ssr_entry_p: ^dst$ssr_entry,
      ssr_segment_number: ost$segment,
      ssr_seq_p: ^SEQ ( * ),
      status: ost$status;

    mmp$create_ssr_sdtx (dsv$ssr_sdte, v$ssr_sdtex);
    dsp$open_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to open the SSR.', ^status);
    IFEND;

    { Make the SSR PVA just to get its true size.

    dsv$ssr_size := 10000(16);
    access_ssr_segment (ssr_segment_number, dsc$ssr_total_length, ssr_seq_p, ssr_entry_p);

    dsv$ssr_size := ssr_entry_p^.left_slot * 8;

    dsp$close_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to close the SSR.', ^status);
    IFEND;

  PROCEND dsp$make_ssr_segment;
?? TITLE := 'dsp$open_ssr', EJECT ??

{ PURPOSE:
{   This procedure adds the SSR to the segment table of the user.

  PROCEDURE [XDCL] dsp$open_ssr
    (VAR ssr_segment_number: ost$segment;
     VAR status: ost$status);

    status.normal := TRUE;
    IF osv$boot_is_executing THEN
      ssr_segment_number := dsc$ssr_segment_number;
    ELSE
      mmp$open_asid_based_segment (dsv$ssr_sdte, v$ssr_sdtex, ssr_segment_number, status);
    IFEND;

  PROCEND dsp$open_ssr;
?? TITLE := 'dsp$store_data_in_ssr', EJECT ??

{ PURPOSE:
{   This procedure stores data in the specified SSR entry.  The caller of this procedure should use the #SEQ
{   function so that they do not have to set up a sequence.
{     EXAMPLE:  dsp$store_data_in_ssr (ssr_entry_name, #SEQ (data_variable));

  PROCEDURE [XDCL] dsp$store_data_in_ssr
    (    ssr_entry_name: dst$ssr_entry_name;
         ssr_value_p: ^SEQ ( * ));

    VAR
      data_seq_p: ^SEQ ( * ),
      skip_seq_p: ^SEQ ( * ),
      ssr_entry_p: ^dst$ssr_entry,
      ssr_segment_number: ost$segment,
      ssr_seq_p: ^SEQ ( * ),
      ssr_value_seq_p: ^SEQ ( * ),
      status: ost$status;

    dsp$open_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to open the SSR.', ^status);
    IFEND;

    access_ssr_segment (ssr_segment_number, ssr_entry_name, ssr_seq_p, ssr_entry_p);

    IF ssr_entry_p^.right_slot > 0 THEN
      NEXT skip_seq_p: [[REP ssr_entry_p^.right_slot OF integer]] IN ssr_seq_p;
    IFEND;
    NEXT ssr_value_seq_p: [[REP ssr_entry_p^.left_slot OF integer]] IN ssr_seq_p;
    RESET ssr_value_seq_p;

    { Move the data from the parameter sequence pointer to the SSR entry.

    IF #SIZE (ssr_value_p^) > #SIZE (ssr_value_seq_p^) THEN
      osp$system_error (' Trying to store too large a data item in the SSR area', NIL);
    IFEND;
    NEXT data_seq_p: [[REP #SIZE (ssr_value_p^) OF cell]] IN ssr_value_seq_p;
    data_seq_p^ := ssr_value_p^;

    dsp$close_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to close the SSR.', ^status);
    IFEND;

  PROCEND dsp$store_data_in_ssr;
?? TITLE := 'dsp$store_entry_in_ssr', EJECT ??

{ PURPOSE:
{   This procedure stores an entry in the SSR.

  PROCEDURE [XDCL] dsp$store_entry_in_ssr
    (    ssr_entry_name: dst$ssr_entry_name;
         ssr_entry_type: dst$ssr_entry_types;
         ssr_entry: dst$ssr_entry);

    VAR
      ssr_entry_p: ^dst$ssr_entry,
      ssr_segment_number: ost$segment,
      ssr_seq_p: ^SEQ ( * ),
      status: ost$status;

    dsp$open_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to open the SSR.', ^status);
    IFEND;

    access_ssr_segment (ssr_segment_number, ssr_entry_name, ssr_seq_p, ssr_entry_p);

    IF ssr_entry_type = dsc$ssr_left_slot THEN
      ssr_entry_p^.left_slot := ssr_entry.left_slot;
    ELSEIF ssr_entry_type = dsc$ssr_right_slot THEN
      ssr_entry_p^.right_slot := ssr_entry.right_slot;
    ELSE
      ssr_entry_p^.whole_slot := ssr_entry.whole_slot;
    IFEND;

    dsp$close_ssr (ssr_segment_number, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to close the SSR.', ^status);
    IFEND;

  PROCEND dsp$store_entry_in_ssr;
MODEND dsm$manage_ssr_routines;
*DECK DECK=DSM$MANAGE_SYSTEM_DS_STATUS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Manage System Deadstart Status data' ??
MODULE dsm$manage_system_ds_status;

{ PURPOSE:
{   This module contains the procedures that are used to manage the System Deadstart Status data that
{   resides in the SSR.  This data is used in the System Deadstart Status statistic that is logged to the
{   Engineering log at every deadstart after the point of commitment.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dst$rb_system_deadstart_status
?? POP ??
*copyc dsp$get_data_from_ssr
*copyc dsp$store_data_in_ssr
*copyc i#call_monitor
?? EJECT ??
*copyc dsv$mainframe_type
*copyc dsv$system_deadstart_status_p
*copyc osv$build_level
?? TITLE := 'dsp$save_sys_status_build_level', EJECT ??

{ PURPOSE:
{   This procedure saves the current build level in the System Deadstart Status data in the SSR.

  PROCEDURE [XDCL] dsp$save_sys_status_build_level;

    VAR
      system_deadstart_status: dst$ssr_system_deadstart_status,
      system_deadstart_status_seq_p: ^SEQ ( * );

    system_deadstart_status_seq_p := #SEQ (system_deadstart_status);
    dsp$get_data_from_ssr (dsc$ssr_system_deadstart_status, system_deadstart_status_seq_p);
    system_deadstart_status.general_info.os_release_identifier := osv$build_level;
    dsp$store_data_in_ssr (dsc$ssr_system_deadstart_status, #SEQ (system_deadstart_status));
    IF dsv$system_deadstart_status_p <> NIL THEN
      dsv$system_deadstart_status_p^.general_info.os_release_identifier := osv$build_level;
    IFEND;

  PROCEND dsp$save_sys_status_build_level;
?? TITLE := 'dsp$save_sys_status_current_ds', EJECT ??

{ PURPOSE:
{   This procedure saves the current deadstart type in the System Deadstart Status data in the SSR.

  PROCEDURE [XDCL] dsp$save_sys_status_current_ds
    (    current_deadstart: 0 .. 0f(16));

    VAR
      auto_restart: 0 .. 1,
      rb: dst$rb_system_deadstart_status,
      system_deadstart_status: dst$ssr_system_deadstart_status,
      system_deadstart_status_seq_p: ^SEQ ( * );

    system_deadstart_status_seq_p := #SEQ (system_deadstart_status);
    dsp$get_data_from_ssr (dsc$ssr_system_deadstart_status, system_deadstart_status_seq_p);
    system_deadstart_status.general_info.deadstarts_performed_code.current_deadstart := current_deadstart;
    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      rb.reqcode := syc$rc_system_deadstart_status;
      rb.action := dsc$rb_sds_retrieve_bct_flag;
      rb.bct_flags := dsc$rb_sds_bct_auto_restart;
      i#call_monitor (#LOC (rb), #SIZE (rb));
      IF rb.bct_flag_set THEN
        rb.reqcode := syc$rc_system_deadstart_status;
        rb.action := dsc$rb_sds_clear_bct_flag;
        rb.bct_flags := dsc$rb_sds_bct_auto_restart;
        i#call_monitor (#LOC (rb), #SIZE (rb));
        auto_restart := 1;
      ELSE
        auto_restart := 0;
      IFEND;
      system_deadstart_status.general_info.deadstarts_performed_code.auto_restart := auto_restart;
    IFEND;
    dsp$store_data_in_ssr (dsc$ssr_system_deadstart_status, #SEQ (system_deadstart_status));
    IF dsv$system_deadstart_status_p <> NIL THEN
      dsv$system_deadstart_status_p^.general_info.deadstarts_performed_code.current_deadstart :=
            current_deadstart;
      IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
        dsv$system_deadstart_status_p^.general_info.deadstarts_performed_code.auto_restart := auto_restart;
      IFEND;
    IFEND;

  PROCEND dsp$save_sys_status_current_ds;
?? TITLE := 'dsp$save_sys_status_ds_file', EJECT ??

{ PURPOSE:
{   This procedure saves the deadstart file source in the System Deadstart Status data in the SSR.

  PROCEDURE [XDCL] dsp$save_sys_status_ds_file
    (    deadstart_file_source: 0 .. 0ff(16));

    VAR
      system_deadstart_status: dst$ssr_system_deadstart_status,
      system_deadstart_status_seq_p: ^SEQ ( * );

    system_deadstart_status_seq_p := #SEQ (system_deadstart_status);
    dsp$get_data_from_ssr (dsc$ssr_system_deadstart_status, system_deadstart_status_seq_p);
    system_deadstart_status.general_info.deadstart_file_source := deadstart_file_source;
    dsp$store_data_in_ssr (dsc$ssr_system_deadstart_status, #SEQ (system_deadstart_status));
    IF dsv$system_deadstart_status_p <> NIL THEN
      dsv$system_deadstart_status_p^.general_info.deadstart_file_source := deadstart_file_source;
    IFEND;

  PROCEND dsp$save_sys_status_ds_file;
MODEND dsm$manage_system_ds_status;
*DECK DECK=DSM$MTR_AUTOMATIC_PP_RELOAD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Automatic PP Reload' ??
MODULE dsm$mtr_automatic_pp_reload;

{ PURPOSE:
{   This module contains the monitor procedures that support the automatic reload of a PP.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cml$pp_hung
*copyc cyd$cybil_structure_definitions
*copyc dst$automatic_pp_reload
*copyc dst$dft_pp_registers
*copyc dst$log_hung_pp_data
*copyc dst$mtr_dft_requests
*copyc dst$signal_contents
?? POP ??
*copyc dpp$display_error
*copyc dsp$mtr_dft_puf_request
*copyc dsp$mtr_dft_reload_sci
*copyc dsp$report_system_message
*copyc dsp$mtr_reserve_puf_memory_area
*copyc dsp$mtr_return_puf_memory_area
*copyc iop$reload_hung_disk_pp
*copyc mtp$error_stop
*copyc mtp$get_date_time_at_timestamp
*copyc mtp$step_unstep_system
*copyc tmp$send_signal
?? EJECT ??
*copyc cmv$logical_pp_table_p
*copyc dsv$cpu_pp_communication_block
*copyc dsv$dftb_data
*copyc tmv$system_job_monitor_gtid
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  CONST
    c$driver_code_nil = 'It is too early in the deadstart process for the Automatic PP Reload ' CAT
          'process to successfully function.',
    c$pps_reconfigured = ', the Automatic PP Reload process is not allowed.  The PPs have been reconfigured.',
    c$process_is_disabled = 'The Automatic PP Reload process is disabled via the SETSA command.';

  VAR
    dsv$automatic_pp_reload: [XDCL, #GATE] dst$automatic_pp_reload :=
          [TRUE, FALSE, FALSE, [dsc$imn_null_model, dsc$imn_null_model]];
?? OLDTITLE ??
?? NEWTITLE := 'build_pp_address', EJECT ??

{ PURPOSE:
{   This procedure builds the PP address for a message string.

  PROCEDURE build_pp_address
    (    pp: dst$iou_resource;
         use_channel: boolean;
         channel: dst$iou_resource;
         driver_name: dst$driver_name;
     VAR message: ost$string);

    message.value := ' ';
    message.size := 1;

    message.value (message.size, 3) := 'IOU';
    message.size := message.size + 3;
    message.value (message.size, 1) := CHR ((pp.iou_number MOD 10) + ORD ('0'));
    message.size := message.size + 1;

    IF use_channel THEN
      IF channel.channel_protocol = dsc$cpt_nio THEN
        message.value (message.size, 3) := ' CH';
        message.size := message.size + 3;
      ELSE
        message.value (message.size, 4) := ' CCH';
        message.size := message.size + 4;
      IFEND;
      message.value (message.size, 1) := CHR ((channel.number DIV 8) + ORD ('0'));
      message.size := message.size + 1;
      message.value (message.size, 1) := CHR ((channel.number MOD 8) + ORD ('0'));
      message.size := message.size + 1;
      message.value (message.size, 4) := '(8) ';
      message.size := message.size + 4;
    IFEND;

    IF pp.channel_protocol = dsc$cpt_nio THEN
      message.value (message.size, 2) := 'PP';
      message.size := message.size + 2;
    ELSE
      message.value (message.size, 3) := 'CPP';
      message.size := message.size + 3;
    IFEND;
    message.value (message.size, 1) := CHR ((pp.number DIV 8) + ORD ('0'));
    message.size := message.size + 1;
    message.value (message.size, 1) := CHR ((pp.number MOD 8) + ORD ('0'));
    message.size := message.size + 1;
    message.value (message.size, 4) := '(8) ';
    message.size := message.size + 4;

    message.value (message.size, 1) := '(';
    message.size := message.size + 1;
    message.value (message.size, 7) := driver_name;
    message.size := message.size + 7;
    message.value (message.size, 9) := ') hung.  ';
    message.size := message.size + 9;

  PROCEND build_pp_address;
?? OLDTITLE ??
?? NEWTITLE := 'log_hung_pp_data', EJECT ??

{ PURPOSE:
{   This procedure retrieves the data from the hung PP for the statistic and sends the statistic to job mode
{   to be emitted.

  PROCEDURE log_hung_pp_data
    (    logical_pp: iot$pp_number);

    TYPE
      t$eng_log_msg = RECORD
        message_type: integer,
        hung_pp_data: dst$log_hung_pp_data,
      RECEND,

      t$pp_data = RECORD
        CASE 0 .. 2 OF
        = 0 =
          data: ARRAY [1 .. 2] OF integer,
        = 1 =
          pp_registers: dst$dft_pp_registers,
        = 2 =
          r_register: integer,
          unused: integer,
        CASEND,
      RECEND;

    VAR
      puf_memory_area_p: ^dst$mtr_dft_puf_memory_area,
      eng_log_msg: t$eng_log_msg,
      index: 1 .. 3,
      local_status: syt$monitor_status,
      msg_recorded: boolean,
      pp_data: ARRAY [1 .. 3] OF t$pp_data,
      seq_p: ^SEQ ( * );

    eng_log_msg.hung_pp_data.pp := cmv$logical_pp_table_p^ [logical_pp].pp_info.physical_pp;
    eng_log_msg.hung_pp_data.channel := cmv$logical_pp_table_p^ [logical_pp].pp_info.channel;
    eng_log_msg.hung_pp_data.driver_name := cmv$logical_pp_table_p^ [logical_pp].pp_info.driver_name;

    dsp$mtr_reserve_puf_memory_area (puf_memory_area_p);

    seq_p := #SEQ (puf_memory_area_p^);
    FOR index := 1 TO 3 DO
      puf_memory_area_p^.data [1] := 0;
      puf_memory_area_p^.data [2] := 0;
      dsp$mtr_dft_puf_request (dsc$dpuf_dump_pp_registers, logical_pp, 0, seq_p, local_status);
      IF NOT local_status.normal THEN
        mtp$error_stop ('Unable to perform dump_pp_registers DFT request.');
      IFEND;
      pp_data [index].data := puf_memory_area_p^.data;
    FOREND;
    eng_log_msg.hung_pp_data.pp_hung_on_one_instruction :=
          (pp_data [1].pp_registers.p_register = pp_data [2].pp_registers.p_register) AND
          (pp_data [1].pp_registers.p_register = pp_data [3].pp_registers.p_register);
    eng_log_msg.hung_pp_data.pp_registers := pp_data [3].pp_registers;

    seq_p := NIL;
    dsp$mtr_dft_puf_request (dsc$dpuf_idle_pp, logical_pp, 0, seq_p, local_status);
    IF NOT local_status.normal THEN
      mtp$error_stop ('Unable to perform idle_pp DFT request.');
    IFEND;

    seq_p := #SEQ (puf_memory_area_p^);
    puf_memory_area_p^.data [1] := 0;
    puf_memory_area_p^.data [2] := 0;
    dsp$mtr_dft_puf_request (dsc$dpuf_capture_r_register, logical_pp, 0, seq_p, local_status);
    IF NOT local_status.normal THEN
      mtp$error_stop ('Unable to perform capture_r_register DFT request.');
    IFEND;
    pp_data [1].data := puf_memory_area_p^.data;
    eng_log_msg.hung_pp_data.r_register := pp_data [1].r_register;

    { After DFT captures the R register it leaves the PP in an unknown state.  It is necessary to hardware
    { idle the PP again to assure that the PP is in a known state.

    seq_p := NIL;
    dsp$mtr_dft_puf_request (dsc$dpuf_idle_pp, logical_pp, 0, seq_p, local_status);
    IF NOT local_status.normal THEN
      mtp$error_stop ('Unable to perform idle_pp DFT request.');
    IFEND;

    dsp$mtr_return_puf_memory_area;

    eng_log_msg.message_type := cml$pp_hung;
    dsp$report_system_message (#SEQ (eng_log_msg), dsc$general_system_message, dsc$informative_message,
          msg_recorded);

  PROCEND log_hung_pp_data;
?? OLDTITLE ??
?? NEWTITLE := 'handle_hung_pp', EJECT ??

{ PURPOSE:
{   This procedure processes the hung PP.

  PROCEDURE handle_hung_pp
    (    pp: dst$iou_resource);

    VAR
      channel: dst$iou_resource,
      local_status: syt$monitor_status,
      logical_pp_index: iot$pp_number,
      message: ost$string,
      sci_pp: dst$iou_resource,
      signal: dst$signal_contents;

    retrieve_sci_pp_number (sci_pp);
    IF pp = sci_pp THEN
      IF NOT dsv$automatic_pp_reload.enabled THEN
        build_pp_address (pp, FALSE, channel, 'SCI    ', message);
        message.value (message.size, *) := c$process_is_disabled;
        step_system (message);
      IFEND;
      dsp$mtr_dft_reload_sci (pp, local_status);
      IF NOT local_status.normal THEN
        signal.identifier := dsc$deadstart_signal;
        signal.contents.kind := dsc$signal_hung_pp_process;
        mtp$get_date_time_at_timestamp (#FREE_RUNNING_CLOCK (0), signal.contents.hpp_data.date_time);
        signal.contents.hpp_data.sci_reload_failed := TRUE;
        signal.contents.hpp_data.check_entire_table := FALSE;
        signal.contents.hpp_data.logical_pp_index := 0;
        tmp$send_signal (tmv$system_job_monitor_gtid, signal.signal, local_status);
      IFEND;
      RETURN;
    IFEND;

    FOR logical_pp_index := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
      IF cmv$logical_pp_table_p^ [logical_pp_index].flags.configured AND
            (cmv$logical_pp_table_p^ [logical_pp_index].pp_info.physical_pp = pp) THEN
        IF NOT dsv$automatic_pp_reload.enabled THEN
          build_pp_address (pp, TRUE, cmv$logical_pp_table_p^ [logical_pp_index].pp_info.channel,
                cmv$logical_pp_table_p^ [logical_pp_index].pp_info.driver_name, message);
          message.value (message.size, *) := c$process_is_disabled;
          step_system (message);
        IFEND;
        IF NOT cmv$logical_pp_table_p^ [logical_pp_index].flags.pp_handshaking_supported AND
              NOT cmv$logical_pp_table_p^ [logical_pp_index].flags.pp_hung THEN
          cmv$logical_pp_table_p^ [logical_pp_index].flags.pp_hung := TRUE;
          signal.identifier := dsc$deadstart_signal;
          signal.contents.kind := dsc$signal_hung_pp_process;
          mtp$get_date_time_at_timestamp (#FREE_RUNNING_CLOCK (0), signal.contents.hpp_data.date_time);
          signal.contents.hpp_data.sci_reload_failed := FALSE;
          signal.contents.hpp_data.check_entire_table := FALSE;
          signal.contents.hpp_data.logical_pp_index := logical_pp_index;
          tmp$send_signal (tmv$system_job_monitor_gtid, signal.signal, local_status);
        IFEND;
        RETURN;
      IFEND;
    FOREND;

    IF NOT dsv$automatic_pp_reload.enabled THEN
      build_pp_address (pp, FALSE, channel, 'unknown', message);
      message.value (message.size, *) := c$process_is_disabled;
      step_system (message);
    IFEND;

  PROCEND handle_hung_pp;
?? OLDTITLE ??
?? NEWTITLE := 'retrieve_sci_pp_number', EJECT ??

{ PURPOSE:
{   This procedure retrieves the PP number of the SCI PP.

  PROCEDURE retrieve_sci_pp_number
    (VAR sci_pp: dst$iou_resource);

    sci_pp.iou_number := 0;
    CASE dsv$automatic_pp_reload.iou_model_type [0] OF
    = dsc$imn_i4_44_model, dsc$imn_i4_46_model =
      sci_pp.channel_protocol := dsc$cpt_cio;
    ELSE
      sci_pp.channel_protocol := dsc$cpt_nio;
    CASEND;
    sci_pp.number := dsv$cpu_pp_communication_block.relocation.sci_pp_number;

  PROCEND retrieve_sci_pp_number;
?? OLDTITLE ??
?? NEWTITLE := 'step_system', EJECT ??

{ PURPOSE:
{   This procedure steps the system with the given message.

  PROCEDURE step_system
    (    message: ost$string);

    VAR
      step_message: string (71);

    dpp$display_error (message.value);

    step_message := 'Automatic PP Reload process detected fatal error, see critical window.';

    mtp$step_unstep_system (syc$ic_fatal_software_error, step_message);

  PROCEND step_system;
?? OLDTITLE ??
?? NEWTITLE := 'translate_fs1_bits', EJECT ??

{ PURPOSE:
{   This procedure scans the FS1 register to determine the PP number of the hung PP.

  PROCEDURE translate_fs1_bits
    (    maintenance_register: integer;
     VAR pp: dst$iou_resource);

    TYPE
      t$maintenance_register = PACKED RECORD
        CASE 0 .. 3 OF
        = 0 =
          integer_part: integer,
        = 1 =
          s0_part: t$mr_s0_part,
        = 2 =
          other_part: t$mr_other_part,
        = 3 =
          other_part_by_bit: PACKED ARRAY [0 .. 63] OF boolean,
        CASEND,
      RECEND,

      t$mr_other_part = PACKED RECORD
        unused_1: 0 .. 7,
        bits_3_7: 0 .. 1f(16),
        unused_2: 0 .. 7,
        bits_11_15: 0 .. 1f(16),
        unused_3: 0 .. 7,
        bits_19_23: 0 .. 1f(16),
        unused_4: 0 .. 7,
        bits_27_31: 0 .. 1f(16),
        unused_5: 0 .. 0ffffffff(16),
      RECEND,

      t$mr_s0_part = PACKED RECORD
        unused_1: 0 .. 3ffffffff(16),
        bit_34: boolean,
        unused_2: 0 .. 1fffffff(16),
      RECEND;

    VAR
      pp_found: boolean,
      register: t$maintenance_register;

    register.integer_part := maintenance_register;

    IF dsv$automatic_pp_reload.iou_model_type [pp.iou_number] = dsc$imn_i0_5x_model THEN
      IF register.s0_part.bit_34 THEN
        pp.channel_protocol := dsc$cpt_nio;
        handle_hung_pp (pp);
      IFEND;
      RETURN;
    IFEND;

    WHILE TRUE DO
      pp_found := FALSE;
      IF register.other_part.bits_3_7 <> 0 THEN
        IF register.other_part_by_bit [3] THEN
          register.other_part_by_bit [3] := FALSE;
          pp_found := TRUE;
          pp.number := 4(8);
        ELSEIF register.other_part_by_bit [4] THEN
          register.other_part_by_bit [4] := FALSE;
          pp_found := TRUE;
          pp.number := 3(8);
        ELSEIF register.other_part_by_bit [5] THEN
          register.other_part_by_bit [5] := FALSE;
          pp_found := TRUE;
          pp.number := 2(8);
        ELSEIF register.other_part_by_bit [6] THEN
          register.other_part_by_bit [6] := FALSE;
          pp_found := TRUE;
          pp.number := 1(8);
        ELSEIF register.other_part_by_bit [7] THEN
          register.other_part_by_bit [7] := FALSE;
          pp_found := TRUE;
          pp.number := 0(8);
        IFEND;
      ELSEIF register.other_part.bits_11_15 <> 0 THEN
        IF register.other_part_by_bit [11] THEN
          register.other_part_by_bit [11] := FALSE;
          pp_found := TRUE;
          pp.number := 11(8);
        ELSEIF register.other_part_by_bit [12] THEN
          register.other_part_by_bit [12] := FALSE;
          pp_found := TRUE;
          pp.number := 10(8);
        ELSEIF register.other_part_by_bit [13] THEN
          register.other_part_by_bit [13] := FALSE;
          pp_found := TRUE;
          pp.number := 7(8);
        ELSEIF register.other_part_by_bit [14] THEN
          register.other_part_by_bit [14] := FALSE;
          pp_found := TRUE;
          pp.number := 6(8);
        ELSEIF register.other_part_by_bit [15] THEN
          register.other_part_by_bit [15] := FALSE;
          pp_found := TRUE;
          pp.number := 5(8);
        IFEND;
      ELSEIF register.other_part.bits_19_23 <> 0 THEN
        IF register.other_part_by_bit [19] THEN
          register.other_part_by_bit [19] := FALSE;
          pp_found := TRUE;
          pp.number := 24(8);
        ELSEIF register.other_part_by_bit [20] THEN
          register.other_part_by_bit [20] := FALSE;
          pp_found := TRUE;
          pp.number := 23(8);
        ELSEIF register.other_part_by_bit [21] THEN
          register.other_part_by_bit [21] := FALSE;
          pp_found := TRUE;
          pp.number := 22(8);
        ELSEIF register.other_part_by_bit [22] THEN
          register.other_part_by_bit [22] := FALSE;
          pp_found := TRUE;
          pp.number := 21(8);
        ELSEIF register.other_part_by_bit [23] THEN
          register.other_part_by_bit [23] := FALSE;
          pp_found := TRUE;
          pp.number := 20(8);
        IFEND;
      ELSEIF register.other_part.bits_27_31 <> 0 THEN
        IF register.other_part_by_bit [27] THEN
          register.other_part_by_bit [27] := FALSE;
          pp_found := TRUE;
          pp.number := 31(8);
        ELSEIF register.other_part_by_bit [28] THEN
          register.other_part_by_bit [28] := FALSE;
          pp_found := TRUE;
          pp.number := 30(8);
        ELSEIF register.other_part_by_bit [29] THEN
          register.other_part_by_bit [29] := FALSE;
          pp_found := TRUE;
          pp.number := 27(8);
        ELSEIF register.other_part_by_bit [30] THEN
          register.other_part_by_bit [30] := FALSE;
          pp_found := TRUE;
          pp.number := 26(8);
        ELSEIF register.other_part_by_bit [31] THEN
          register.other_part_by_bit [31] := FALSE;
          pp_found := TRUE;
          pp.number := 25(8);
        IFEND;
      IFEND;

      IF NOT pp_found THEN
        RETURN;
      IFEND;

      CASE dsv$automatic_pp_reload.iou_model_type [pp.iou_number] OF
      = dsc$imn_i1_10_model, dsc$imn_i1_11_model, dsc$imn_i1_12_model, dsc$imn_i1_13_model,
            dsc$imn_i1_14_model, dsc$imn_i2_20_model =
        pp.channel_protocol := dsc$cpt_nio;
      = dsc$imn_i4_42_model =
        IF pp.number = 25(8) THEN
          pp.channel_protocol := dsc$cpt_cio;
          pp.number := 0;
        ELSEIF pp.number = 26(8) THEN
          pp.channel_protocol := dsc$cpt_cio;
          pp.number := 1;
        ELSEIF pp.number = 27(8) THEN
          pp.channel_protocol := dsc$cpt_cio;
          pp.number := 2;
        ELSEIF pp.number = 30(8) THEN
          pp.channel_protocol := dsc$cpt_cio;
          pp.number := 3;
        ELSEIF pp.number = 31(8) THEN
          pp.channel_protocol := dsc$cpt_cio;
          pp.number := 4;
        ELSE
          pp.channel_protocol := dsc$cpt_nio;
        IFEND;
      = dsc$imn_i4_44_model, dsc$imn_i4_46_model =
        pp.channel_protocol := dsc$cpt_cio;
      ELSE
      CASEND;

      handle_hung_pp (pp);
    WHILEND;

  PROCEND translate_fs1_bits;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$mtr_handle_bit_57', EJECT ??

{ PURPOSE:
{   This procedure processes the OS Action code that is sent by DFT when it detects a bit 57 condition.
{   The procedure reloads SCI and notes all of the PPs that do not support handshaking.  PPs that do
{   support handshaking will be detected by the handshaking process.

  PROCEDURE [XDCL] dsp$mtr_handle_bit_57
    (    element_number: dst$dftb_mrt_element_index);

    VAR
      index: iot$pp_number,
      iou_number: dst$iou_number,
      local_status: syt$monitor_status,
      message: ost$string,
      sci_pp: dst$iou_resource,
      signal: dst$signal_contents;

    IF dsv$automatic_pp_reload.turned_off THEN
      RETURN;
    IFEND;

    IF element_number = dsc$dftb_eid_iou0_element THEN
      message.value := 'Fatal IOU0 error - Bit 57 condition detected';
      iou_number := 0;
    ELSE
      message.value := 'Fatal IOU1 error - Bit 57 condition detected';
      iou_number := 1;
    IFEND;
    message.size := 44;

    IF dsv$automatic_pp_reload.pps_reconfigured THEN
      message.value (message.size + 1, *) := c$pps_reconfigured;
      step_system (message);
    IFEND;

    IF NOT dsv$automatic_pp_reload.enabled THEN
      message.value (message.size, *) := c$process_is_disabled;
      step_system (message);
    IFEND;

    FOR index := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
      IF cmv$logical_pp_table_p^ [index].flags.configured AND
            cmv$logical_pp_table_p^ [index].flags.resources_acquired AND
            cmv$logical_pp_table_p^ [index].flags.pp_loaded AND
            NOT cmv$logical_pp_table_p^ [index].flags.pp_handshaking_supported AND
            NOT cmv$logical_pp_table_p^ [index].flags.pp_hung AND
            (cmv$logical_pp_table_p^ [index].pp_info.physical_pp.iou_number = iou_number) THEN
        cmv$logical_pp_table_p^ [index].flags.pp_hung := TRUE;
      IFEND;
    FOREND;

    retrieve_sci_pp_number (sci_pp);
    dsp$mtr_dft_reload_sci (sci_pp, local_status);
    IF NOT local_status.normal THEN
      signal.identifier := dsc$deadstart_signal;
      signal.contents.kind := dsc$signal_hung_pp_process;
      mtp$get_date_time_at_timestamp (#FREE_RUNNING_CLOCK (0), signal.contents.hpp_data.date_time);
      signal.contents.hpp_data.sci_reload_failed := TRUE;
      signal.contents.hpp_data.check_entire_table := FALSE;
      signal.contents.hpp_data.logical_pp_index := 0;
      tmp$send_signal (tmv$system_job_monitor_gtid, signal.signal, local_status);
    IFEND;

    signal.identifier := dsc$deadstart_signal;
    signal.contents.kind := dsc$signal_hung_pp_process;
    mtp$get_date_time_at_timestamp (#FREE_RUNNING_CLOCK (0), signal.contents.hpp_data.date_time);
    signal.contents.hpp_data.sci_reload_failed := FALSE;
    signal.contents.hpp_data.check_entire_table := TRUE;
    signal.contents.hpp_data.logical_pp_index := 0;
    tmp$send_signal (tmv$system_job_monitor_gtid, signal.signal, local_status);

  PROCEND dsp$mtr_handle_bit_57;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$mtr_handle_pp_hang', EJECT ??

{ PURPOSE:
{   This procedure processes the OS Action code that is sent by DFT when it detects a hung PP.

  PROCEDURE [XDCL] dsp$mtr_handle_pp_hang
    (    element_number: dst$dftb_mrt_element_index;
         data_from_mrb: boolean;
         data_p: ^cell);

    VAR
      buffer_seq_p: ^SEQ ( * ),
      data_length: integer,
      index: 1 .. dsc$dftb_mr_number_of_registers,
      maintenance_registers_p: ^dst$dftb_maintenance_registers,
      message: ost$string,
      nrb_internal_header_p: ^dst$dftb_nrb_internal_header,
      partial_nrb_record_p: ^ARRAY [1 .. 5] OF integer,
      pp: dst$iou_resource,
      register_data_p: ^SEQ ( * ),
      seq_entry_pp: ^^SEQ ( * ),
      seq_header: cyt$sequence_pointer,
      skip_data_p: ^SEQ ( * );

    IF dsv$automatic_pp_reload.turned_off THEN
      RETURN;
    IFEND;

    IF dsv$automatic_pp_reload.pps_reconfigured THEN
      message.value := 'Hung PP detected';
      message.size := 16;
      message.value (message.size + 1, *) := c$pps_reconfigured;
      step_system (message);
    IFEND;

    IF data_p = NIL THEN
      RETURN;
    IFEND;

    seq_entry_pp := #LOC(seq_header);
    seq_header.pva := data_p;
    IF data_from_mrb THEN
      seq_header.length := dsv$dftb_data.mrb_length * 8;
    ELSE
      seq_header.length := dsv$dftb_data.nrb_length * 8;
    IFEND;
    seq_header.nextt := 0;
    buffer_seq_p := seq_entry_pp^;
    IF buffer_seq_p = NIL THEN
      RETURN;
    IFEND;
    RESET buffer_seq_p;

   /find_register_data/
    BEGIN
      IF data_from_mrb THEN
        NEXT register_data_p: [[REP dsv$dftb_data.mrb_length OF integer]] IN buffer_seq_p;
      ELSE
        data_length := #SIZE (buffer_seq_p^);
        NEXT partial_nrb_record_p IN buffer_seq_p;
        data_length := data_length - #SIZE (partial_nrb_record_p^);
        WHILE data_length > 0 DO
          NEXT nrb_internal_header_p IN buffer_seq_p;
          IF nrb_internal_header_p^.type_code = dsc$dftb_nrb_ih_register_data THEN
            NEXT register_data_p: [[REP (nrb_internal_header_p^.length - 1) OF integer]] IN buffer_seq_p;
            EXIT /find_register_data/;
          IFEND;
          NEXT skip_data_p: [[REP (nrb_internal_header_p^.length - 1) OF integer]] IN buffer_seq_p;
          data_length := data_length - (nrb_internal_header_p^.length * 8);
        WHILEND;
        RETURN;
      IFEND;
    END /find_register_data/;

    IF element_number = dsc$dftb_eid_iou0_element THEN
      pp.iou_number := 0;
    ELSE
      pp.iou_number := 1;
    IFEND;

    RESET register_data_p;
    data_length := #SIZE (register_data_p^);
    WHILE data_length > 0 DO
      NEXT maintenance_registers_p IN register_data_p;
      data_length := data_length - #SIZE (maintenance_registers_p^);
      FOR index := 1 TO dsc$dftb_mr_number_of_registers DO

        CASE dsv$automatic_pp_reload.iou_model_type [pp.iou_number] OF
        = dsc$imn_i1_10_model, dsc$imn_i1_11_model, dsc$imn_i1_12_model, dsc$imn_i1_13_model,
              dsc$imn_i1_14_model, dsc$imn_i2_20_model, dsc$imn_i4_42_model, dsc$imn_i4_44_model,
              dsc$imn_i4_46_model =
          IF maintenance_registers_p^.register_header [index].register_number = 80(16) THEN
            translate_fs1_bits (maintenance_registers_p^.register_list [index], pp);
            RETURN;
          IFEND;

        = dsc$imn_i4_40_model =
          IF maintenance_registers_p^.register_header [index].register_number = 80(16) THEN
            pp.channel_protocol := dsc$cpt_nio;
            translate_fs1_bits (maintenance_registers_p^.register_list [index], pp);
          IFEND;
          IF maintenance_registers_p^.register_header [index].register_number = 84(16) THEN
            pp.channel_protocol := dsc$cpt_cio;
            translate_fs1_bits (maintenance_registers_p^.register_list [index], pp);
          IFEND;

        = dsc$imn_i0_5x_model =
          IF ((maintenance_registers_p^.register_header [index].register_number >= 90(16)) AND
                (maintenance_registers_p^.register_header [index].register_number <= 94(16))) THEN
            pp.number := maintenance_registers_p^.register_header [index].register_number - 90(16);
            translate_fs1_bits (maintenance_registers_p^.register_list [index], pp);
          ELSEIF ((maintenance_registers_p^.register_header [index].register_number >= 0A0(16)) AND
                (maintenance_registers_p^.register_header [index].register_number <= 0A4(16))) THEN
            pp.number := maintenance_registers_p^.register_header [index].register_number - 0A0(16);
            translate_fs1_bits (maintenance_registers_p^.register_list [index], pp);
          IFEND;

        ELSE
        CASEND;
      FOREND;
    WHILEND;

  PROCEND dsp$mtr_handle_pp_hang;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$mtr_process_hung_pp', EJECT ??

{ PURPOSE:
{   This procedure processes a hung PP that was detected by the CPU handshaking with the PP.

  PROCEDURE [XDCL] dsp$mtr_process_hung_pp
    (    logical_pp: iot$pp_number);

    VAR
      local_status: syt$monitor_status,
      message: ost$string,
      pp: dst$iou_resource,
      seq_p: ^SEQ ( * ),
      signal: dst$signal_contents;

    IF dsv$automatic_pp_reload.turned_off THEN
      RETURN;
    IFEND;

    cmv$logical_pp_table_p^ [logical_pp].flags.pp_hung := TRUE;

    pp := cmv$logical_pp_table_p^ [logical_pp].pp_info.physical_pp;

    build_pp_address (pp, TRUE, cmv$logical_pp_table_p^ [logical_pp].pp_info.channel,
          cmv$logical_pp_table_p^ [logical_pp].pp_info.driver_name, message);

    IF NOT dsv$automatic_pp_reload.enabled THEN
      message.value (message.size, *) := c$process_is_disabled;
      step_system (message);
    IFEND;

    log_hung_pp_data (logical_pp);

    { Determine if pointer to the driver code needed to reload the driver in monitor exists.
    { The pointer would not exist in the boot therefore reload is not available in the boot.

    CASE cmv$logical_pp_table_p^ [logical_pp].pp_info.pp_type OF
    = cmc$lpt_disk_pp_type, cmc$lpt_nad_pp_type =
      IF cmv$logical_pp_table_p^ [logical_pp].pp_info.driver_code_p = NIL THEN
        message.value (message.size + 1, *) := c$driver_code_nil;
        step_system (message);
      IFEND;
    ELSE
    CASEND;

    { Network channels are NOT master cleared.

    IF (cmv$logical_pp_table_p^ [logical_pp].pp_info.pp_type <> cmc$lpt_network_pp_type) AND
          (cmv$logical_pp_table_p^ [logical_pp].pp_info.pp_type <> cmc$lpt_nad_pp_type) THEN
      seq_p := NIL;
      dsp$mtr_dft_puf_request (dsc$dpuf_master_clear_channel, logical_pp, 0, seq_p, local_status);
      IF NOT local_status.normal THEN
        mtp$error_stop ('Unable to perform master_clear_channel DFT request.');
      IFEND;
    IFEND;

    IF cmv$logical_pp_table_p^ [logical_pp].flags.pp_reload_supported THEN
      CASE cmv$logical_pp_table_p^ [logical_pp].pp_info.pp_type OF
      = cmc$lpt_disk_pp_type =
        iop$reload_hung_disk_pp (logical_pp);
        RETURN;
      = cmc$lpt_nad_pp_type =
        seq_p := NIL;
        dsp$mtr_dft_puf_request (dsc$dpuf_load_pp, logical_pp, 0, seq_p, local_status);
        IF NOT local_status.normal THEN
          mtp$error_stop ('Unable to load the NAD driver via a DFT request.');
        IFEND;
        cmv$logical_pp_table_p^ [logical_pp].flags.pp_hung := FALSE;
        RETURN;
      ELSE
      CASEND;
    IFEND;

    signal.identifier := dsc$deadstart_signal;
    signal.contents.kind := dsc$signal_hung_pp_process;
    mtp$get_date_time_at_timestamp (#FREE_RUNNING_CLOCK (0), signal.contents.hpp_data.date_time);
    signal.contents.hpp_data.sci_reload_failed := FALSE;
    signal.contents.hpp_data.check_entire_table := FALSE;
    signal.contents.hpp_data.logical_pp_index := logical_pp;
    tmp$send_signal (tmv$system_job_monitor_gtid, signal.signal, local_status);

  PROCEND dsp$mtr_process_hung_pp;
?? OLDTITLE ??
MODEND dsm$mtr_automatic_pp_reload;
*DECK DECK=DSM$MTR_ISSUE_DFT_REQUEST EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : MTR - Issue DFT Requests' ??
MODULE dsm$mtr_issue_dft_request;

{ PURPOSE:
{   This module contains all of the procedures needed to issue a request to DFT in monitor.
{ NOTES:
{   This module contains many type declarations that can not be easily changed.  These type declarations
{   define a block of data that the DFT PP program expects to find in a particular order.  Caution must be
{   taken when dealing with these type declarations.  If any changes are made to the type declarations, a
{   corresponding change must be made to the DFT PP program.  All changes must be made in a way to preserve
{   backward compatibility.
{
{   *** ALL DFT REQUESTS THAT ACCESS THE CIP DISK MUST INTERLOCK THE CHANNEL BEFORE CALLING DFT.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dsc$dft_request_wait_times
*copyc dse$dft_errors
*copyc dst$dft_requests
*copyc dst$device_path
*copyc dst$rb_issue_dft_request
*copyc dst$mtr_dft_requests
*copyc ost$pp_size
?? POP ??
*copyc cmp$idle_system_device_driver
*copyc cmp$manage_channel_lock
*copyc dsp$convert_seq_p_to_r_pointer
*copyc dsp$mtr_get_ssr_data_seq_ptr
*copyc mtp$error_stop
*copyc mtp$interrupt_processor
*copyc mtp$set_status_abnormal
*copyc tmp$clear_lock
*copyc tmp$set_lock
?? EJECT ??
*copyc cmv$logical_pp_table_p
*copyc cmv$system_device_pp
*copyc dsv$automatic_pp_reload
*copyc dsv$dftb_nve_req_buffer_p
*copyc dsv$mainframe_type
*copyc osv$multiprocessor_running
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    c$iou0_port_mask = 2;

  TYPE
    t$mtr_dft_request_locks = RECORD
      main_routine: tmt$ptl_lock,
      puf: tmt$ptl_lock,
      reload_sci: tmt$ptl_lock,
      puf_data: tmt$ptl_lock,
    RECEND;
?? EJECT ??

  VAR
    dsv$cip_path: [XDCL, #GATE] dst$device_path := [FALSE, 0, 0, 0, 0],
    dsv$mtr_dft_requests: [XDCL, #GATE] dst$mtr_dft_requests := [NIL, NIL, NIL],

    v$mtr_dft_request_locks: t$mtr_dft_request_locks := [[FALSE, 0], [FALSE, 0], [FALSE, 0], [FALSE, 0]];
?? OLDTITLE ??
?? NEWTITLE := 'issue_request', EJECT ??

{ PURPOSE:
{   This procedure issues a request to DFT.
{ DESIGN:
{   The DFT Buffer contains an area referred to as the NOS/VE Request Buffer which consists of four
{   R pointers.  One of these R pointers is used to issue the request to DFT.

  PROCEDURE issue_request
    (VAR request_seq_p: ^SEQ ( * ));

    { Specifies the maximum amount of time monitor will wait for a DFT request to be completed.

    CONST
      c$cpu_wait_time = 10000000,       { 10 seconds in microseconds.
      c$dft_wait_time = 30000000;       { 30 seconds in microseconds.

    VAR
      current_time: ost$free_running_clock,
      dft_request_header_p: ^dst$dft_request_header,
      expired_time: ost$free_running_clock,
      request_r_pointer: dst$r_pointer;

    tmp$set_lock (v$mtr_dft_request_locks.main_routine);

    { Issue the request to DFT.  DFT monitors the R pointer and when the length is set to a nonzero value,
    { DFT will respond to the request.

    RESET request_seq_p;
    NEXT dft_request_header_p IN request_seq_p;
    RESET request_seq_p;

    dsp$convert_seq_p_to_r_pointer (request_seq_p, request_r_pointer);

    { Move the created request R pointer in to the correct slot in the NOS/VE Request Buffer in the DFT
    { Buffer.  This should be done using #SPOIL to assure that the R pointer is totally created before
    { it is moved into the buffer.

    #SPOIL (dsv$dftb_nve_req_buffer_p^.system_request_r_pointer);
    dsv$dftb_nve_req_buffer_p^.system_request_r_pointer := request_r_pointer;
    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      mtp$interrupt_processor (c$iou0_port_mask);
    IFEND;

    { Wait for the DFT request to complete.

    current_time := #FREE_RUNNING_CLOCK (0);
    expired_time := current_time + c$dft_wait_time;
    WHILE current_time < expired_time DO
      #SPOIL (dft_request_header_p^);
      IF dft_request_header_p^.request_status = dsc$dft_rs_no_response THEN
        current_time := #FREE_RUNNING_CLOCK (0);
      ELSE
        expired_time := current_time;
      IFEND;
    WHILEND;

    dsv$dftb_nve_req_buffer_p^.system_request_r_pointer.length := 0;

    { If starting a CPU, wait until the CPU has started before continuing.

    IF (dft_request_header_p^.request_code = dsc$dft_start_additional_cpu) AND
          (dft_request_header_p^.request_status = dsc$dft_rs_request_complete) THEN
      current_time := #FREE_RUNNING_CLOCK (0);
      expired_time := current_time + c$cpu_wait_time;
      WHILE current_time < expired_time DO
        IF osv$multiprocessor_running THEN
          expired_time := current_time;
        ELSE
          current_time := #FREE_RUNNING_CLOCK (0);
        IFEND;
      WHILEND;
    IFEND;

    tmp$clear_lock (v$mtr_dft_request_locks.main_routine);

  PROCEND issue_request;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$issue_dft_request', EJECT ??

{ PURPOSE:
{   This procedure issues a request to DFT.  Requests that pass through this routine are initiated from job
{   mode.

  PROCEDURE [XDCL] dsp$issue_dft_request
    (VAR rb: dst$rb_issue_dft_request);

    VAR
      access_deadstart_sector_p: ^dst$dft_access_deadstart_sector,
      channel_number: dst$physical_resource_number,
      dft_request_header_p: ^dst$dft_request_header,
      driver_pp_p: ^array [ost$pp_size] of ost$pp_byte_size,
      dual_system_device_driver: boolean,
      ignore_status: syt$monitor_status,
      iou_number: dst$iou_number,
      load_dual_pp: boolean,
      lock_channel: boolean,
      pp_interface_table_rma: ost$real_memory_address,
      process_pp_function_p: ^dst$dft_process_pp_function,
      request_issued: boolean,
      ssr_ppbf_seq_p: ^SEQ ( * ),
      system_device_partner_pp: dst$iou_resource;

    rb.status.normal := TRUE;

    RESET rb.dft_request_p;
    NEXT dft_request_header_p IN rb.dft_request_p;
    load_dual_pp := FALSE;

    CASE dsv$mainframe_type OF
    = dsc$mt_962_972_mainframe, dsc$mt_992_mainframe, dsc$mt_2000_mainframe =
      lock_channel := FALSE;
    ELSE
      CASE dft_request_header_p^.request_code OF
      = dsc$dft_read_cda_program, dsc$dft_access_cda_sector, dsc$dft_access_deadstart_sector,
            dsc$dft_retrieve_program_size, dsc$dft_retrieve_cda_data_size =
        lock_channel := TRUE;
      = dsc$dft_update_hardware_clock, dsc$dft_access_mrt =
        lock_channel := (dsv$mainframe_type <> dsc$mt_93x_mainframe);
      ELSE
        lock_channel := FALSE;
      CASEND;
    CASEND;

   /channel_locked/
    BEGIN
      IF lock_channel THEN
        IF dft_request_header_p^.request_code = dsc$dft_access_deadstart_sector THEN
          RESET rb.dft_request_p;
          NEXT access_deadstart_sector_p IN rb.dft_request_p;
          iou_number := access_deadstart_sector_p^.iou_number;
          channel_number := access_deadstart_sector_p^.channel_number;
        ELSE
          iou_number := dsv$cip_path.iou_number;
          channel_number := dsv$cip_path.channel_number;
        IFEND;
        cmp$manage_channel_lock ({set_lock} TRUE, iou_number, channel_number,
               {concurrent channel} FALSE, rb.status);
        IF NOT rb.status.normal THEN
          EXIT /channel_locked/;
        IFEND;
      IFEND;

      IF cmv$system_device_pp.software_idle AND
            (dft_request_header_p^.request_code = dsc$dft_process_pp_function) THEN
        RESET rb.dft_request_p;
        NEXT process_pp_function_p IN rb.dft_request_p;
        IF process_pp_function_p^.subfunction = dsc$dpuf_load_pp THEN
          cmp$idle_system_device_driver (process_pp_function_p^.pp, dual_system_device_driver,
                pp_interface_table_rma, system_device_partner_pp);
          load_dual_pp := dual_system_device_driver;
        IFEND;
      IFEND;

      issue_request (rb.dft_request_p);
    END /channel_locked/;

    IF lock_channel THEN
      cmp$manage_channel_lock ({set_lock} FALSE, iou_number, channel_number,
            {concurrent channel} FALSE, ignore_status);
    IFEND;
    IF NOT rb.status.normal OR (dft_request_header_p^.request_status <> dsc$dft_rs_request_complete) THEN
      RETURN;
    IFEND;

    IF (dft_request_header_p^.request_code = dsc$dft_process_pp_function) AND load_dual_pp THEN
      dft_request_header_p^.request_status := dsc$dft_rs_no_response;

      { Update rma of the PP interface table in the PP image.  Words 72(8) and 73(8) contain the RMA to
      { the PP interface table.  Update the PP number in the DFT request.

      dsp$mtr_get_ssr_data_seq_ptr (dsc$ssr_pp_controlware_buf, ssr_ppbf_seq_p);
      RESET ssr_ppbf_seq_p;
      NEXT driver_pp_p IN ssr_ppbf_seq_p;
      driver_pp_p^ [72(8)] := pp_interface_table_rma DIV 10000(16);
      driver_pp_p^ [73(8)] := pp_interface_table_rma MOD 10000(16);
      process_pp_function_p^.pp.number := system_device_partner_pp.number;
      issue_request (rb.dft_request_p);
    IFEND;

  PROCEND dsp$issue_dft_request;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$mtr_dft_puf_request', EJECT ??

{ PURPOSE:
{   This procedure issues the 'process pp function' DFT request from monitor.

  PROCEDURE [XDCL] dsp$mtr_dft_puf_request
    (    subfunction: dst$dft_puf_subfunctions;
         logical_pp: iot$pp_number;
         resume_address: dst$dft_resume_address;
    VAR pp_data_seq_p: ^SEQ ( * );
    VAR status: syt$monitor_status);

    TYPE
      t$pp_parameter = RECORD
        fill: ARRAY [0 .. 71(8)] OF ost$pp_byte_size,
        table_rma: ost$real_memory_address,
      RECEND;

    VAR
      dft_request_seq_p: ^SEQ ( * ),
      iou_number: dst$iou_number,
      pp_parameter_p: ^t$pp_parameter;

    status.normal := TRUE;

    { Master clearing of the channel via DFT is only allowed on I4 type IOUs.

    IF subfunction = dsc$dpuf_master_clear_channel THEN
      iou_number := cmv$logical_pp_table_p^ [logical_pp].pp_info.channel.iou_number;
      CASE dsv$automatic_pp_reload.iou_model_type [iou_number] OF
      = dsc$imn_null_model, dsc$imn_i1_10_model, dsc$imn_i1_11_model, dsc$imn_i1_12_model,
            dsc$imn_i1_13_model, dsc$imn_i1_14_model, dsc$imn_i2_20_model, dsc$imn_i0_5x_model =
        RETURN;
      ELSE
      CASEND;
    IFEND;

    tmp$set_lock (v$mtr_dft_request_locks.puf);

    dsv$mtr_dft_requests.puf_p^.header.request_code := dsc$dft_process_pp_function;
    dsv$mtr_dft_requests.puf_p^.header.request_status := 0;

    IF subfunction = dsc$dpuf_master_clear_channel THEN
      dsv$mtr_dft_requests.puf_p^.pp := cmv$logical_pp_table_p^ [logical_pp].pp_info.channel;
    ELSE
      dsv$mtr_dft_requests.puf_p^.pp := cmv$logical_pp_table_p^ [logical_pp].pp_info.physical_pp;
    IFEND;

    dsv$mtr_dft_requests.puf_p^.subfunction := subfunction;
    dsv$mtr_dft_requests.puf_p^.resume_address := resume_address;

    IF subfunction = dsc$dpuf_load_pp THEN
      RESET cmv$logical_pp_table_p^ [logical_pp].pp_info.driver_code_p;
      NEXT pp_parameter_p IN cmv$logical_pp_table_p^ [logical_pp].pp_info.driver_code_p;
      pp_parameter_p^.table_rma := cmv$logical_pp_table_p^ [logical_pp].pp_info.pp_interface_table_rma;
      RESET cmv$logical_pp_table_p^ [logical_pp].pp_info.driver_code_p;
      dsp$convert_seq_p_to_r_pointer (cmv$logical_pp_table_p^ [logical_pp].pp_info.driver_code_p,
            dsv$mtr_dft_requests.puf_p^.pp_image_rp);
    ELSEIF pp_data_seq_p <> NIL THEN
      dsp$convert_seq_p_to_r_pointer (pp_data_seq_p, dsv$mtr_dft_requests.puf_p^.pp_image_rp);
    ELSE
      dsv$mtr_dft_requests.puf_p^.pp_image_rp.offset := 0;
      dsv$mtr_dft_requests.puf_p^.pp_image_rp.rupper := 0;
      dsv$mtr_dft_requests.puf_p^.pp_image_rp.rlower := 0;
      dsv$mtr_dft_requests.puf_p^.pp_image_rp.length := 0;
    IFEND;

    dft_request_seq_p := #SEQ (dsv$mtr_dft_requests.puf_p^);
    issue_request (dft_request_seq_p);

    IF dsv$mtr_dft_requests.puf_p^.header.request_status <> dsc$dft_rs_request_complete THEN
      IF dsv$mtr_dft_requests.puf_p^.header.request_status = dsc$dft_rs_no_response THEN
        mtp$set_status_abnormal (dsc$display_processor_id, dse$dft_not_responding, status);
      ELSE
        mtp$set_status_abnormal (dsc$display_processor_id, dse$dft_request_failed, status);
      IFEND;
    IFEND;

    tmp$clear_lock (v$mtr_dft_request_locks.puf);

  PROCEND dsp$mtr_dft_puf_request;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$mtr_dft_reload_sci', EJECT ??

{ PURPOSE:
{   This procedure issues the 'reload SCI' DFT request from monitor.

  PROCEDURE [XDCL] dsp$mtr_dft_reload_sci
    (    pp: dst$iou_resource;
    VAR status: syt$monitor_status);

    VAR
      dft_request_seq_p: ^SEQ ( * );

    status.normal := TRUE;
    tmp$set_lock (v$mtr_dft_request_locks.reload_sci);

    dsv$mtr_dft_requests.reload_sci_p^.header.request_code := dsc$dft_reload_sci;
    dsv$mtr_dft_requests.reload_sci_p^.header.request_status := 0;
    dsv$mtr_dft_requests.reload_sci_p^.pp := pp;
    dsv$mtr_dft_requests.reload_sci_p^.rfu := 0;

    dft_request_seq_p := #SEQ (dsv$mtr_dft_requests.reload_sci_p^);
    issue_request (dft_request_seq_p);

    IF dsv$mtr_dft_requests.reload_sci_p^.header.request_status <> dsc$dft_rs_request_complete THEN
      IF dsv$mtr_dft_requests.reload_sci_p^.header.request_status = dsc$dft_rs_no_response THEN
        mtp$set_status_abnormal (dsc$display_processor_id, dse$dft_not_responding, status);
      ELSE
        mtp$set_status_abnormal (dsc$display_processor_id, dse$dft_request_failed, status);
      IFEND;
    IFEND;

    tmp$clear_lock (v$mtr_dft_request_locks.reload_sci);

  PROCEND dsp$mtr_dft_reload_sci;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$mtr_reserve_puf_memory_area', EJECT ??

{ PURPOSE:
{   This procedure reserves the memory area for PUF monitor dft requests.

  PROCEDURE [XDCL] dsp$mtr_reserve_puf_memory_area
    (VAR data_p: ^dst$mtr_dft_puf_memory_area);

    tmp$set_lock (v$mtr_dft_request_locks.puf_data);

    data_p := dsv$mtr_dft_requests.puf_data_p;

  PROCEND dsp$mtr_reserve_puf_memory_area;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$mtr_return_puf_memory_area', EJECT ??

{ PURPOSE:
{   This procedure returns the memory area for PUF monitor dft requests.

  PROCEDURE [XDCL] dsp$mtr_return_puf_memory_area;

    tmp$clear_lock (v$mtr_dft_request_locks.puf_data);

  PROCEND dsp$mtr_return_puf_memory_area;
?? OLDTITLE ??
MODEND dsm$mtr_issue_dft_request;
*DECK DECK=DSM$MTR_MANAGE_SSR_ROUTINES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Manage SSR Routines Monitor' ??
MODULE dsm$mtr_manage_ssr_routines;

{ PURPOSE:
{   This module contains the monitor procedures that are used to manage the system status record (SSR) areas.
{ NOTE:
{   There is a corresponding module in system_core that manages the SSR routines.  Any changes made to this
{   module may also need to be made to the module dsm$manage_ssr_routines.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cyd$cybil_structure_definitions
*copyc dst$deadstart_sequence_steps
*copyc dst$ssr_data_types
?? POP ??
*copyc mtp$error_stop
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    v$ssr_directory_seq_p: ^SEQ ( * ) := NIL,
    v$ssr_seq_p: ^SEQ ( * ) := NIL;
?? TITLE := 'get_entry_from_ssr', EJECT ??

{ PURPOSE:
{   This procedure retrieves an entry from the SSR.

  PROCEDURE get_entry_from_ssr
    (    ssr_entry_name: dst$ssr_entry_name;
     VAR ssr_entry_p: ^dst$ssr_entry);

    VAR
      seq_header_p: ^cyt$sequence_pointer,
      ssr_seq_p: ^SEQ ( * );

    IF v$ssr_directory_seq_p = NIL THEN
      seq_header_p := #LOC (v$ssr_directory_seq_p);
      seq_header_p^.pva := #ADDRESS (1, dsc$ssr_segment_number, dsc$ssr_offset);
      seq_header_p^.length := 2000(16);
      seq_header_p^.nextt := 0;
    IFEND;

    ssr_seq_p := v$ssr_directory_seq_p;
    RESET ssr_seq_p;
    REPEAT
      NEXT ssr_entry_p IN ssr_seq_p;
      IF (ssr_entry_p <> NIL) AND (ssr_entry_p^.name = ssr_entry_name) THEN
        RETURN;
      IFEND;
    UNTIL ssr_entry_p = NIL;
    mtp$error_stop (' Entry is not defined in the SSR');

  PROCEND get_entry_from_ssr;
?? TITLE := 'dsp$advance_ds_sequence_in_mtr', EJECT ??

{ PURPOSE:
{   This procedure is used to advance the deadstart sequence step in monitor mode.

  PROCEDURE [XDCL] dsp$advance_ds_sequence_in_mtr
    (    sequence_step: dst$deadstart_sequence_steps);

    VAR
      byve_p: ^dst$ssr_entry,
      sdst_p: ^dst$ssr_entry;

    CASE sequence_step OF
    = dsc$dss_system_terminated =
      get_entry_from_ssr (dsc$ssr_termination_status, byve_p);
      byve_p^.right_slot := $INTEGER (sequence_step);
    ELSE
      { do nothing
    CASEND;

    { Save the step of the current deadstart sequence in the SSR.

    get_entry_from_ssr (dsc$ssr_deadstart_state, sdst_p);
    sdst_p^.left_slot := $INTEGER (sequence_step);

  PROCEND dsp$advance_ds_sequence_in_mtr;
?? TITLE := 'dsp$mtr_get_ssr_data_seq_ptr', EJECT ??

{ PURPOSE:
{   This procedure retrieves a pointer to specific data in the SSR.

  PROCEDURE [XDCL] dsp$mtr_get_ssr_data_seq_ptr
    (    ssr_entry_name: dst$ssr_entry_name;
     VAR ssr_data_seq_p: ^SEQ ( * ));

    VAR
      seq_header_p: ^cyt$sequence_pointer,
      skip_seq_p: ^SEQ ( * ),
      ssr_entry_p: ^dst$ssr_entry,
      ssr_seq_p: ^SEQ ( * );

    get_entry_from_ssr (ssr_entry_name, ssr_entry_p);

    IF v$ssr_seq_p = NIL THEN
      seq_header_p := #LOC (v$ssr_seq_p);
      seq_header_p^.pva := #ADDRESS (1, dsc$ssr_segment_number, dsc$ssr_offset);
      seq_header_p^.length := 100000(16);
      seq_header_p^.nextt := 0;
    IFEND;

    ssr_seq_p := v$ssr_seq_p;
    RESET ssr_seq_p;
    IF ssr_entry_p^.right_slot > 0 THEN
      NEXT skip_seq_p: [[REP ssr_entry_p^.right_slot OF integer]] IN ssr_seq_p;
    IFEND;
    NEXT ssr_data_seq_p: [[REP ssr_entry_p^.left_slot OF integer]] IN ssr_seq_p;
    RESET ssr_data_seq_p;

  PROCEND dsp$mtr_get_ssr_data_seq_ptr;
MODEND dsm$mtr_manage_ssr_routines;
*DECK DECK=DSM$MTR_MANAGE_SYSTEM_DS_STATUS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Manage System Deadstart Status data in Monitor' ??
MODULE dsm$mtr_manage_system_ds_status;

{ PURPOSE:
{   This module contains the monitor procedures that are used to manage the System Deadstart Status data that
{   resides in the SSR.  This data is used in the System Deadstart Status statistic that is logged to the
{   Engineering log at every deadstart after the point of commitment.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cyd$cybil_structure_definitions
*copyc dst$rb_system_deadstart_status
?? POP ??
*copyc dsp$convert_seq_p_to_r_pointer
*copyc dsp$mtr_get_ssr_data_seq_ptr
*copyc mtp$get_date_time_at_timestamp
*copyc mtp$interrupt_processor
?? EJECT ??
*copyc dsv$boot_control_table_p
*copyc dsv$mainframe_type
*copyc mmv$pages_to_dump_p
*copyc mtv$nst_p
*copyc ost$iou_model_number
*copyc osv$170_os_termination_status
*copyc osv$170_os_type
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  CONST
    c$nos_segment_number = 3;

  VAR
    dsv$system_deadstart_status_p: [XDCL, #GATE] ^dst$ssr_system_deadstart_status := NIL,

    v$ssr_sys_status_initialized: boolean := FALSE;
?? OLDTITLE ??
?? NEWTITLE := 'retrieve_system_ds_status_data', EJECT ??

{ PURPOSE:
{   This procedure retrieves the System Deadstart Status data from the SSR and replaces it with the data in
{   the mainframe wired pointer.

  PROCEDURE retrieve_system_ds_status_data
    (VAR rb: dst$rb_system_deadstart_status);

    VAR
      system_deadstart_status_p: ^dst$ssr_system_deadstart_status,
      system_deadstart_status_seq_p: ^SEQ ( * );

    dsp$mtr_get_ssr_data_seq_ptr (dsc$ssr_system_deadstart_status, system_deadstart_status_seq_p);
    NEXT system_deadstart_status_p IN system_deadstart_status_seq_p;
    rb.data_p^ := system_deadstart_status_p^;

    system_deadstart_status_p^ := dsv$system_deadstart_status_p^;
    system_deadstart_status_p^.general_info.deadstarts_performed_code.current_deadstart :=
          dsc$ssr_sds_sdas_first_attempt;
    system_deadstart_status_p^.general_info.deadstarts_performed_code.previous_deadstart :=
          dsc$ssr_sds_sdas_first_attempt;
    system_deadstart_status_p^.general_info.number_of_recoveries_attempted := 0;

  PROCEND retrieve_system_ds_status_data;
?? OLDTITLE ??
?? NEWTITLE := 'setup_system_ds_status_data', EJECT ??

{ PURPOSE:
{   This procedure initializes the System Deadstart Status data in the SSR if it is not already initialized.
{   The data has to be initialized if the SSR had to be rebuilt.  A System Deadstart Status variable,
{   allocated in mainframe wired, will be used during the deadstart process to hold the information gathered
{   during the deadstart process.  This is done so that the SSR data from a previous crash is not damaged.
{   After the SSR data has been logged, the variable data will be moved to the SSR.

  PROCEDURE setup_system_ds_status_data;

    VAR
      disk_index: 1 .. dsc$ssr_sds_number_of_disk_errs,
      integer_p: ^integer,
      mf_index: 1 .. dsc$ssr_sds_number_of_mf_errors,
      nos_data_seq_p: ^SEQ ( * ),
      nos_nbe_index: 1 .. dsc$ssr_sds_number_of_nos_id,
      nos_nbe_words_index: 0 .. dsc$ssr_sds_number_of_nos_id,
      seq_entry_pointer_p: ^^SEQ ( * ),
      seq_header: cyt$sequence_pointer,
      system_deadstart_status_p: ^dst$ssr_system_deadstart_status,
      system_deadstart_status_seq_p: ^SEQ ( * );

    { Initialize the mainframe wired variable.

    dsv$system_deadstart_status_p^.initialized := TRUE;
    dsv$system_deadstart_status_p^.version := dsc$ssr_sds_version_1;
    dsv$system_deadstart_status_p^.top_line_message := 'NONE';
    dsv$system_deadstart_status_p^.dft_message := 'NONE';

    { Initialize the general information.  Set the OS release identifier.

    dsv$system_deadstart_status_p^.general_info.deadstarts_performed_code.current_deadstart :=
          dsc$ssr_sds_sdas_first_attempt;
    dsv$system_deadstart_status_p^.general_info.deadstarts_performed_code.previous_deadstart :=
          dsc$ssr_sds_sdas_first_attempt;
    dsv$system_deadstart_status_p^.general_info.deadstarts_performed_code.rfu := 0;
    dsv$system_deadstart_status_p^.general_info.probable_cause_of_crash := dsc$ssr_sds_cause_indeterminate;
    dsv$system_deadstart_status_p^.general_info.deadstart_file_source := 0;
    dsv$system_deadstart_status_p^.general_info.number_of_recoveries_attempted := 0;
    dsv$system_deadstart_status_p^.general_info.os_release_identifier := ' ';
    dsv$system_deadstart_status_p^.general_info.rfu := 0;
    dsv$system_deadstart_status_p^.general_info.timestamp_of_crash.word := 0;

    { Initialize the disk error information.

    dsv$system_deadstart_status_p^.disk_errors.next_available_entry := 1;
    dsv$system_deadstart_status_p^.disk_errors.number_of_valid_entries := 0;
    FOR disk_index := 1 TO dsc$ssr_sds_number_of_disk_errs DO
      dsv$system_deadstart_status_p^.disk_errors.entry [disk_index].timestamp.word := 0;
      dsv$system_deadstart_status_p^.disk_errors.entry [disk_index].element_name := ' ';
      dsv$system_deadstart_status_p^.disk_errors.entry [disk_index].last_request_good := TRUE;
    FOREND;

    { Initialize the mainframe error information.

    dsv$system_deadstart_status_p^.mainframe_errors.number_of_valid_entries := 0;
    FOR mf_index := 1 TO dsc$ssr_sds_number_of_mf_errors DO
      dsv$system_deadstart_status_p^.mainframe_errors.data [mf_index].valid := FALSE;
      dsv$system_deadstart_status_p^.mainframe_errors.data [mf_index].entry.timestamp.data := 0;
      dsv$system_deadstart_status_p^.mainframe_errors.data [mf_index].entry.timestamp.rfu := 0;
      dsv$system_deadstart_status_p^.mainframe_errors.data [mf_index].entry.rfu := 0;
      dsv$system_deadstart_status_p^.mainframe_errors.data [mf_index].entry.fault_symptom_code.upper := 0;
      dsv$system_deadstart_status_p^.mainframe_errors.data [mf_index].entry.fault_symptom_code.lower := 0;
    FOREND;
    dsv$system_deadstart_status_p^.mainframe_errors.data [1].entry.element_id := dsc$dftb_eid_cpu0_element;
    dsv$system_deadstart_status_p^.mainframe_errors.data [2].entry.element_id := dsc$dftb_eid_cpu1_element;
    dsv$system_deadstart_status_p^.mainframe_errors.data [3].entry.element_id :=
          dsc$dftb_eid_page_map_element;
    dsv$system_deadstart_status_p^.mainframe_errors.data [4].entry.element_id := dsc$dftb_eid_iou0_element;
    dsv$system_deadstart_status_p^.mainframe_errors.data [5].entry.element_id := dsc$dftb_eid_iou1_element;
    dsv$system_deadstart_status_p^.mainframe_errors.data [6].entry.element_id := dsc$dftb_eid_memory_element;
    dsv$system_deadstart_status_p^.mainframe_errors.data [7].entry.element_id :=
          dsc$dftb_eid_no_known_element;

    { Initialize the NOS and NBE words.  Set the OS type and the status of NOS or NBE.  Retrieve the
    { System Version and the System ID from the EICB for the NOS or NBE system.

    dsv$system_deadstart_status_p^.nos_nbe_words.os_type := $INTEGER (osv$170_os_type);
    dsv$system_deadstart_status_p^.nos_nbe_words.nos_nbe_status := $INTEGER (osv$170_os_termination_status);
    dsv$system_deadstart_status_p^.nos_nbe_words.rfu := 0;
    FOR nos_nbe_words_index := 1 TO dsc$ssr_sds_number_of_nos_id DO
      dsv$system_deadstart_status_p^.nos_nbe_words.identifier [nos_nbe_words_index] := 0;
    FOREND;

    IF mtv$nst_p^.d7sv2.nos_system_version_rma <> 0 THEN
      seq_entry_pointer_p := #LOC (seq_header);
      seq_header.pva := #ADDRESS (1, c$nos_segment_number, (mtv$nst_p^.d7sv2.nos_system_version_rma * 8));
      seq_header.length := dsc$ssr_sds_nos_id_count * 8;
      seq_header.nextt := 0;
      nos_data_seq_p := seq_entry_pointer_p^;
      RESET nos_data_seq_p;
      FOR nos_nbe_index := 1 TO dsc$ssr_sds_nos_id_count DO
        NEXT integer_p IN nos_data_seq_p;
        dsv$system_deadstart_status_p^.nos_nbe_words.identifier [nos_nbe_index] := integer_p^;
      FOREND;
      nos_nbe_words_index := dsc$ssr_sds_nos_id_count;
    ELSE
      nos_nbe_words_index := 0;
    IFEND;

    IF mtv$nst_p^.d7sv3.nos_nbe_system_id_rma <> 0 THEN
      seq_entry_pointer_p := #LOC (seq_header);
      seq_header.pva := #ADDRESS (1, c$nos_segment_number, (mtv$nst_p^.d7sv3.nos_nbe_system_id_rma * 8));
      seq_header.length := (dsc$ssr_sds_number_of_nos_id - nos_nbe_words_index) * 8;
      seq_header.nextt := 0;
      nos_data_seq_p := seq_entry_pointer_p^;
      RESET nos_data_seq_p;
      FOR nos_nbe_index := (nos_nbe_words_index + 1) TO dsc$ssr_sds_number_of_nos_id DO
        NEXT integer_p IN nos_data_seq_p;
        dsv$system_deadstart_status_p^.nos_nbe_words.identifier [nos_nbe_index] := integer_p^;
      FOREND;
    IFEND;

    { If the SSR was rebuilt, store the initialized variable in the SSR.  Otherwise, if the previous
    { deadstart code has not been set in the SSR data, save the current value in the previous value.
    { The current will be changed later in the deadstart process to describe the current deadstart.
    { Also determine if this is a recovery attempt and bump the number of recoveries attempted
    { counter by one.

    dsp$mtr_get_ssr_data_seq_ptr (dsc$ssr_system_deadstart_status, system_deadstart_status_seq_p);
    NEXT system_deadstart_status_p IN system_deadstart_status_seq_p;
    v$ssr_sys_status_initialized := NOT system_deadstart_status_p^.initialized;
    IF v$ssr_sys_status_initialized THEN
      system_deadstart_status_p^ := dsv$system_deadstart_status_p^;
    ELSE
      IF system_deadstart_status_p^.general_info.deadstarts_performed_code.previous_deadstart =
            dsc$ssr_sds_sdas_first_attempt THEN
        system_deadstart_status_p^.general_info.deadstarts_performed_code.previous_deadstart :=
              system_deadstart_status_p^.general_info.deadstarts_performed_code.current_deadstart;
      IFEND;
      IF system_deadstart_status_p^.general_info.deadstarts_performed_code.previous_deadstart <>
            dsc$ssr_sds_sdas_first_attempt THEN
        system_deadstart_status_p^.general_info.number_of_recoveries_attempted :=
              system_deadstart_status_p^.general_info.number_of_recoveries_attempted + 1;
      IFEND;
      system_deadstart_status_p^.nos_nbe_words.os_type :=
            dsv$system_deadstart_status_p^.nos_nbe_words.os_type;
      system_deadstart_status_p^.nos_nbe_words.identifier :=
            dsv$system_deadstart_status_p^.nos_nbe_words.identifier;
    IFEND;

    { Move the DFT message from the EICB to the SSR System Deadstart Status data and clear the ECIB message.

    IF (system_deadstart_status_p^.dft_message = 'NONE') AND ((mtv$nst_p^.dfcm4.previous_message_1 <> ' ') OR
          (mtv$nst_p^.dfcm5.previous_message_2 <> ' ') OR (mtv$nst_p^.dfcm6.previous_message_3 <> ' ')) THEN
      system_deadstart_status_p^.dft_message (1, 8) := mtv$nst_p^.dfcm4.previous_message_1;
      system_deadstart_status_p^.dft_message (9, 8) := mtv$nst_p^.dfcm5.previous_message_2;
      system_deadstart_status_p^.dft_message (17, 8) := mtv$nst_p^.dfcm6.previous_message_3;
      mtv$nst_p^.dfcm4.previous_message_1 := ' ';
      mtv$nst_p^.dfcm5.previous_message_2 := ' ';
      mtv$nst_p^.dfcm6.previous_message_3 := ' ';
    IFEND;

  PROCEND setup_system_ds_status_data;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$mtr_change_bct_flag', EJECT ??

{ PURPOSE:
{   This procedure changes a flag in the Boot Control Table.  An external interrupt is sent to
{   alert the service processor that a flag in the Boot Control Table has been changed.

  PROCEDURE [XDCL] dsp$mtr_change_bct_flag
    (    action: dst$rb_sds_actions;
         bct_flag: dst$rb_sds_bct_flags);

    CONST
      c$iou0_port_mask = 2;

    VAR
      flag_value: boolean;

    IF dsv$mainframe_type <> dsc$mt_2000_mainframe THEN
      RETURN;
    IFEND;

    flag_value := (action = dsc$rb_sds_set_bct_flag);

    CASE bct_flag OF
    = dsc$rb_sds_bct_both_cpu_error =
      dsv$boot_control_table_p^.flags.cpu_error_process_in_progress := flag_value;
      dsv$boot_control_table_p^.flags.cpu_error_fatal_after_process := flag_value;
      RETURN;
    = dsc$rb_sds_bct_ts_by_operator =
      dsv$boot_control_table_p^.flags.terminate_system_by_operator := flag_value;
    = dsc$rb_sds_bct_ts_by_error =
      dsv$boot_control_table_p^.flags.terminate_system_by_error := flag_value;
    = dsc$rb_sds_bct_auto_restart =
      dsv$boot_control_table_p^.flags.auto_restart_attempted := flag_value;
    = dsc$rb_sds_bct_sys_has_idled =
      dsv$boot_control_table_p^.flags.system_has_been_idled := flag_value;
    = dsc$rb_sds_bct_ar_control =
      dsv$boot_control_table_p^.flags.auto_restart_control := flag_value;
    = dsc$rb_sds_bct_point_of_commit =
      dsv$boot_control_table_p^.flags.point_of_commitment := flag_value;
    ELSE
      RETURN;
    CASEND;
    mtp$interrupt_processor (c$iou0_port_mask);

  PROCEND dsp$mtr_change_bct_flag;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$mtr_manage_system_ds_status', EJECT ??

{ PURPOSE:
{   This procedure allows the system core to call monitor to access the System Deadstart Status data in
{   the SSR exclusively.

  PROCEDURE [XDCL] dsp$mtr_manage_system_ds_status
    (VAR rb: dst$rb_system_deadstart_status);

    rb.status.normal := TRUE;
    CASE rb.action OF
    = dsc$rb_sds_fetch_element_id =
      fetch_element_id (rb);
    = dsc$rb_sds_initialize_data =
      setup_system_ds_status_data;
    = dsc$rb_sds_retrieve_data =
      retrieve_system_ds_status_data (rb);
    = dsc$rb_sds_set_cpt_pointer =
      dsp$convert_seq_p_to_r_pointer (#SEQ (mmv$pages_to_dump_p^),
            mtv$nst_p^.dfcm8.critical_page_table_pointer);
    = dsc$rb_sds_set_bct_flag, dsc$rb_sds_clear_bct_flag =
      dsp$mtr_change_bct_flag (rb.action, rb.bct_flags);
    = dsc$rb_sds_retrieve_bct_flag =
      CASE rb.bct_flags OF
      = dsc$rb_sds_bct_ts_by_operator =
        rb.bct_flag_set := dsv$boot_control_table_p^.flags.terminate_system_by_operator;
      = dsc$rb_sds_bct_ts_by_error =
        rb.bct_flag_set := dsv$boot_control_table_p^.flags.terminate_system_by_error;
      = dsc$rb_sds_bct_auto_restart =
        rb.bct_flag_set := dsv$boot_control_table_p^.flags.auto_restart_attempted;
      = dsc$rb_sds_bct_sys_has_idled =
        rb.bct_flag_set := dsv$boot_control_table_p^.flags.system_has_been_idled;
      = dsc$rb_sds_bct_ar_control =
        rb.bct_flag_set := dsv$boot_control_table_p^.flags.auto_restart_control;
      = dsc$rb_sds_bct_point_of_commit =
        rb.bct_flag_set := dsv$boot_control_table_p^.flags.point_of_commitment;
      ELSE
      CASEND;
    ELSE
    CASEND;

  PROCEND dsp$mtr_manage_system_ds_status;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$mtr_save_nos_nbe_status', EJECT ??

{ PURPOSE:
{   This procedure saves the NOS or NBE status in the System Deadstart Status data in the SSR.  This
{   information is saved in the SSR data only after the point of commitment.  This is done so that any
{   valid data in the SSR is not damaged.

  PROCEDURE [XDCL] dsp$mtr_save_nos_nbe_status
    (    nos_nbe_status: integer);

    VAR
      system_deadstart_status_p: ^dst$ssr_system_deadstart_status,
      system_deadstart_status_seq_p: ^SEQ ( * );

    IF (dsv$system_deadstart_status_p = NIL) OR v$ssr_sys_status_initialized THEN
      dsp$mtr_get_ssr_data_seq_ptr (dsc$ssr_system_deadstart_status, system_deadstart_status_seq_p);
      NEXT system_deadstart_status_p IN system_deadstart_status_seq_p;
    ELSE
      system_deadstart_status_p := dsv$system_deadstart_status_p;
    IFEND;
    system_deadstart_status_p^.nos_nbe_words.nos_nbe_status := nos_nbe_status;

  PROCEND dsp$mtr_save_nos_nbe_status;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$mtr_save_cause_and_time', EJECT ??

{ PURPOSE:
{   This procedure saves the probable cause of the crash and the timestamp of the crash in the System
{   Deadstart Status data in the SSR.  This information is saved in the SSR data only after the point
{   of commitment.  This is done so that any valid data in the SSR is not damaged.

  PROCEDURE [XDCL] dsp$mtr_save_cause_and_time
    (    timestamp: ost$free_running_clock;
         probable_cause: 0 .. 0ffff(16));

    VAR
      date_time: ost$date_time,
      system_deadstart_status_p: ^dst$ssr_system_deadstart_status,
      system_deadstart_status_seq_p: ^SEQ ( * );

    IF (dsv$system_deadstart_status_p = NIL) OR v$ssr_sys_status_initialized THEN
      dsp$mtr_get_ssr_data_seq_ptr (dsc$ssr_system_deadstart_status, system_deadstart_status_seq_p);
      NEXT system_deadstart_status_p IN system_deadstart_status_seq_p;
    ELSE
      system_deadstart_status_p := dsv$system_deadstart_status_p;
    IFEND;
    IF timestamp > 0 THEN
      mtp$get_date_time_at_timestamp (timestamp, date_time);
      system_deadstart_status_p^.general_info.timestamp_of_crash.os := date_time;
    ELSE
      system_deadstart_status_p^.general_info.timestamp_of_crash.word := 0;
    IFEND;
    system_deadstart_status_p^.general_info.probable_cause_of_crash := probable_cause;

  PROCEND dsp$mtr_save_cause_and_time;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$mtr_save_disk_error', EJECT ??

{ PURPOSE:
{   This procedure saves a disk error for the System Deadstart Status statistic.  If the System Deadstart
{   Status statistic has been logged OR if the System Deadstart Status data in the SSR has been initialized
{   the disk error is stored in the SSR else the disk error is stored in the mainframe wired variable.

  PROCEDURE [XDCL] dsp$mtr_save_disk_error
    (    action: dst$ssr_sds_disk_error_actions;
         timestamp: ost$free_running_clock;
         element_name: cmt$element_name);

    VAR
      date_time: ost$date_time,
      index: 1 .. dsc$ssr_sds_number_of_disk_errs,
      system_deadstart_status_p: ^dst$ssr_system_deadstart_status,
      system_deadstart_status_seq_p: ^SEQ ( * );

    IF (dsv$system_deadstart_status_p = NIL) OR v$ssr_sys_status_initialized THEN
      dsp$mtr_get_ssr_data_seq_ptr (dsc$ssr_system_deadstart_status, system_deadstart_status_seq_p);
      NEXT system_deadstart_status_p IN system_deadstart_status_seq_p;
    ELSE
      system_deadstart_status_p := dsv$system_deadstart_status_p;
    IFEND;

    IF action = dsc$ssr_sds_disk_request_good THEN
      FOR index := 1 TO dsc$ssr_sds_number_of_disk_errs DO
        IF system_deadstart_status_p^.disk_errors.entry [index].element_name = element_name THEN
          system_deadstart_status_p^.disk_errors.entry [index].last_request_good := TRUE;
        IFEND;
      FOREND;

    ELSE  { action = dsc$ssr_sds_disk_request_bad }
      index := system_deadstart_status_p^.disk_errors.next_available_entry;
      IF timestamp > 0 THEN
        mtp$get_date_time_at_timestamp (timestamp, date_time);
        system_deadstart_status_p^.disk_errors.entry [index].timestamp.os := date_time;
      ELSE
        system_deadstart_status_p^.disk_errors.entry [index].timestamp.word := 0;
      IFEND;
      system_deadstart_status_p^.disk_errors.entry [index].element_name := element_name;
      system_deadstart_status_p^.disk_errors.entry [index].last_request_good := FALSE;
      IF system_deadstart_status_p^.disk_errors.number_of_valid_entries < dsc$ssr_sds_number_of_disk_errs THEN
        system_deadstart_status_p^.disk_errors.number_of_valid_entries :=
              system_deadstart_status_p^.disk_errors.number_of_valid_entries + 1;
      IFEND;
      IF system_deadstart_status_p^.disk_errors.next_available_entry = dsc$ssr_sds_number_of_disk_errs THEN
        system_deadstart_status_p^.disk_errors.next_available_entry := 1;
      ELSE
        system_deadstart_status_p^.disk_errors.next_available_entry :=
              system_deadstart_status_p^.disk_errors.next_available_entry + 1;
      IFEND;
    IFEND;

  PROCEND dsp$mtr_save_disk_error;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$mtr_save_mainframe_error', EJECT ??

{ PURPOSE:
{   This procedure saves a mainframe error for the System Deadstart Status statistic.  If the System Deadstart
{   Status statistic has been logged OR if the System Deadstart Status data in the SSR has been initialized
{   the mainframe error is stored in the SSR else the mainframe error is stored in the mainframe wired
{   variable.

  PROCEDURE [XDCL] dsp$mtr_save_mainframe_error
    (    element_number: dst$dftb_mrt_element_index;
         date_and_time_word: dst$dftb_date_and_time;
         fault_symptom_words: dst$dftb_fault_symptom_words);

    VAR
      index: 1 .. dsc$ssr_sds_number_of_mf_errors,
      system_deadstart_status_p: ^dst$ssr_system_deadstart_status,
      system_deadstart_status_seq_p: ^SEQ ( * );

    IF (dsv$system_deadstart_status_p = NIL) OR v$ssr_sys_status_initialized THEN
      dsp$mtr_get_ssr_data_seq_ptr (dsc$ssr_system_deadstart_status, system_deadstart_status_seq_p);
      NEXT system_deadstart_status_p IN system_deadstart_status_seq_p;
    ELSE
      system_deadstart_status_p := dsv$system_deadstart_status_p;
    IFEND;

    FOR index := 1 TO dsc$ssr_sds_number_of_mf_errors DO
      IF system_deadstart_status_p^.mainframe_errors.data [index].entry.element_id = element_number THEN
        system_deadstart_status_p^.mainframe_errors.data [index].entry.timestamp := date_and_time_word;
        system_deadstart_status_p^.mainframe_errors.data [index].entry.rfu := 0;
        system_deadstart_status_p^.mainframe_errors.data [index].entry.fault_symptom_code :=
              fault_symptom_words.fault_symptom_code;
        system_deadstart_status_p^.mainframe_errors.data [index].valid := TRUE;
        IF system_deadstart_status_p^.mainframe_errors.number_of_valid_entries <
              dsc$ssr_sds_number_of_mf_errors THEN
          system_deadstart_status_p^.mainframe_errors.number_of_valid_entries :=
                system_deadstart_status_p^.mainframe_errors.number_of_valid_entries + 1;
        IFEND;
        RETURN;
      IFEND;
    FOREND;

  PROCEND dsp$mtr_save_mainframe_error;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$mtr_save_top_line_message', EJECT ??

{ PURPOSE:
{   This procedure saves the top line message in the System Deadstart Status data in the SSR.

  PROCEDURE [XDCL] dsp$mtr_save_top_line_message
    (    message: string ( * ));

    VAR
      system_deadstart_status_p: ^dst$ssr_system_deadstart_status,
      system_deadstart_status_seq_p: ^SEQ ( * );

    IF (dsv$system_deadstart_status_p = NIL) OR v$ssr_sys_status_initialized THEN
      dsp$mtr_get_ssr_data_seq_ptr (dsc$ssr_system_deadstart_status, system_deadstart_status_seq_p);
      NEXT system_deadstart_status_p IN system_deadstart_status_seq_p;
    ELSE
      system_deadstart_status_p := dsv$system_deadstart_status_p;
    IFEND;
    system_deadstart_status_p^.top_line_message := message;
    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      dsv$boot_control_table_p^.cm_message_buffer := message;
    IFEND;

  PROCEND dsp$mtr_save_top_line_message;





  PROCEDURE [XDCL] fetch_element_id
    (VAR rb: dst$rb_system_deadstart_status);


      IF mtv$nst_p^.d8st.sci_iou_model_number = osc$imn_44 THEN
        rb.iou_model := dsc$rb_model_44;
      ELSE
        rb.iou_model := dsc$rb_model_40;
      IFEND;

  PROCEND fetch_element_id;


MODEND dsm$mtr_manage_system_ds_status;
*DECK DECK=DSM$NOS_BE_COPYS EXPAND=TRUE
      PROGRAM COPYS
      IMPLICIT INTEGER (A-Z)

      COMMON /FILES/ INPUT, OUTPUT

      LOGICAL ENDF
      DIMENSION IFIT(40), OFIT(40)
      DIMENSION IWSA(512)

      CALL FILESQ (IFIT, L"LFN", INPUT,
     +    L"RT", L"S", L"BT", L"C",  L"MBL", 5120,
     +    L"BFS", O"10000")
      CALL FILESQ (OFIT, L"LFN", OUTPUT,
     +    L"RT", L"U", L"BT", L"C", L"MBL",  5120,
     +    L"MRL", 5120, L"BFS", O"10000")
      CALL OPENM (IFIT, L"INPUT", L"N")
      CALL OPENM (OFIT, L"OUTPUT", L"N")
      ENDF = .FALSE.

10    PTL = 5120
      CALL GETP (IFIT, IWSA, PTL)
      FP = IFETCH(IFIT, L"FP")
      PTL = IFETCH(IFIT, L"PTL")
      IF (PTL .NE. 0)  CALL PUT (OFIT, IWSA, PTL)
      IF (FP .NE. O"40") GO TO 20
        CALL ENDFILE (OFIT)

20    IF (FP .NE. O"100") GO TO 30
        CALL CLOSEM (IFIT, L"N")
        CALL CLOSEM (OFIT, L"N")
        ENDF = .TRUE.

30    CALL WEOR (OFIT)

      IF (.NOT. ENDF) GOTO 10

      CALL ENDRUN
      END
          IDENT  DSMNBCS

          ENTRY  DSMNBCS
          ENTRY  ENDRUN

          SYSCOM B1

          USE    /FILES/
 INPUT    DATA   0LINPUT
 OUTPUT   DATA   0LOUTPUT
          USE    *

 DSMNBCS  SB1    1
          SA1    RA.ACT
          SX5    X1

          ZR     X5,CRACK.4        IF NO PARAMETERS
          R=     A2,RA.ARG
          MX0    42
          SA1    A2+B1
          BX6    X0*X2
          BX7    X0*X1
          BX3    -X0*X2
          SX5    X5-1
          BX4    -X0*X1
          SX2    COPYSA            * FILE NAME TOO LONG.*
          ZR     X6,CRACK.1        IF FIRST PARAMETER NULL (USE DEFAULT)
          SA6    INPUT
          ZR     X3,ERROR          IF FILE NAME TOO LONG

 CRACK.1  ZR     X5,CRACK.3        IF ONLY 1 PARAMETER
          ZR     X4,ERROR          IF FILE NAME TOO LONG
          SX2    COPYSB            * TOO MANY PARAMETERS SPECIFIED.*
          SX5    X5-1
          ZR     X7,CRACK.2        IF 2ND PARAMETER NULL (USE DEFAULT)
          SA7    OUTPUT

 CRACK.2  NZ     X5,ERROR          IF TOO MANY PARAMETERS

 CRACK.3  SA1    INPUT             CALL FORTRAN PROGRAM
          SA3    OUTPUT
          SX2    COPYSC            * FILE NAME CONFLICT.*
          BX6    X1-X3
          ZR     X6,ERROR          IF INPUT AND OUTPUT FILES SAME

 CRACK.4  EQ     =XCOPYS           CALL FORTRAN PROGRAM

 ERROR    MESSAGE X2,,R
          ABORT  ,ND

 COPYSA   DATA   C* DSMNBCS - FILE NAME TOO LONG.*
 COPYSB   DATA   C* DSMNBCS - TOO MANY PARAMETERS SPECIFIED.*
 COPYSC   DATA   C* DSMNBCS - FILE NAME CONFLICT.*


 ENDRUN   DATA   0
          MESSAGE ENDRUNA,,R
          ENDRUN

 ENDRUNA  DATA   C* DSMNBCS COMPLETE.*

          END    DSMNBCS

*DECK DECK=DSM$NVE EXPAND=TRUE
.PROC,NVE,PN=,UN=.
*IF ($string($name(wev$target_operating_system))='NOSBE')
.*
.*  THIS PROCEDURE IS INITIATED BY THE CONSOLE OPERATOR TO
.*  EXECUTE THE NOS/VE DEADSTART PROCEDURE CREATED BY SETVE.
.*  THE PARAMETER VALUES ARE THE SAME AS THE PN AND UN PA-
.*  RAMETERS SPECIFIED IN THE SETVE CALL.
.*
.IFE,$UN$.EQ.$$,NOID.
ATTACH,YYYTEMP,NVE_PN.
COPYBF,YYYTEMP,NVE_PN.
RETURN,YYYTEMP.
.ELSE,NOID.
ATTACH,YYYTEMP,NVE_PN,ID=UN.
COPYBF,YYYTEMP,NVE_PN.
RETURN,YYYTEMP.
.ENDIF,NOID.
BEGIN,,NVE_PN.
*ELSE
COMMENT. THIS PROCEDURE IS FOR NOS/BE ONLY
*IFEND
/EOR
*DECK DECK=DSM$OBTAIN_RESOURCES_FOR_VE EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'Obtain resources from the C170 for VE'  ??
MODULE dsm$obtain_resources_for_ve ALIAS 'DSMORFV';
*copyc pxiotyp
?? PUSH (LISTEXT := ON) ??
*copyc zn7prcl
?? POP ??
*copyc dsc$constant_definitions
*copyc dst$deadstart_condition
*copyc dsp$dst_compass_interface
*copy dsp$copy_memory
*copy dsi$virtual_memory_access
?? EJECT ??
{***********************************************************************

*copyc dst$170_request_block
*copyc dsp$callver
*copyc dsp$callsda
*copyc dsp$send_data_via_ssr
*copyc dsp$copy_memory
*copy dsi$define_hardware_config
*copyc dsi$support_eicb_version_4
  CONST
    dsc$cpu_elid_810 = 14(16),
    dsc$cpu_elid_830 = 13(16);
  VAR
    got_cpu_attr:  boolean:= FALSE,
    request: dst$170_resource_request;
?? OLDTITLE, NEWTITLE := '~~~~~   claim_pp ', EJECT ??
  PROCEDURE claim_pp;

    VAR
      hold_general_status: 0 .. 07777(8),
      i: integer,
      j: integer,
      req_driver: boolean,
      req_partner_pp: boolean;

    req_driver := request.driver_pp;
    req_partner_pp := request.partner_pp;

  /try_both_types/
    FOR i := 1 TO 2 DO

    /try_requested_type/
      FOR j := 1 TO 400 DO  { About 10 seconds with default recall rate
        ver_request.clear := 0;
        ver_request.general_status := 0;
        ver_request.length := 1;

        IF request.channel_used.channel_protocol = dsc$cpt_nio THEN

          { Attempt to get a NIO PP.

          ver_request.pp.kind := non_driver_pp;
          IF req_partner_pp THEN
             ver_request.pp.kind := pair_of_pps;
          ELSEIF req_driver THEN
             ver_request.pp.kind := driver_pp;
          IFEND;

          IF d7ty.eicb_version < dsc$eicb_version_4 THEN
            callver (ver_request, rspp, TRUE);
          ELSE
            callver (ver_request, rspt, TRUE);
          IFEND;
          IF ver_request.general_status <= 1 THEN
             EXIT /try_both_types/;
          IFEND;
        ELSE

          { Attempt to get a single CIO PP.

          IF d7ty.eicb_version < dsc$eicb_version_4 THEN
            request.status := dsc$170_rre_bad_request;
            dyfstring ('CIO PP requests not supported', system_dayf);
            RETURN;
          IFEND;
          ver_request.pp.kind := cio_cluster_0;
          IF request.channel_used.number > 4 THEN
            ver_request.pp.kind := cio_cluster_1;
          IFEND;
          callver (ver_request, rspt, TRUE);

          { The secondary PP is set to zero to make sure a partner PP is retrieved if one is requested.

          IF ver_request.general_status <= 1 THEN
            ver_request.pp.secondary := 0;
            EXIT /try_both_types/;
          IFEND;
        IFEND;
        n7p$recall;
      FOREND /try_requested_type/;

      { Toggle driver/nondriver status and retry PP acquisition.

      IF req_partner_pp THEN
        EXIT /try_both_types/;
      ELSE
        req_driver := NOT req_driver;
      IFEND;

    FOREND /try_both_types/;

?? SKIP := 2 ??

    IF ver_request.general_status = 1 THEN
      request.primary_pp := request.channel_used;
      request.primary_pp.number := ver_request.pp.primary;
      IF request.channel_used.channel_protocol = dsc$cpt_cio THEN
        dyfstrnum ('GET CIO PP', ver_request.pp.primary, user_dayf);
      ELSE
        dyfstrnum ('GET PP', ver_request.pp.primary, user_dayf);
      IFEND;
      request.status := dsc$170_rre_request_ok;

      IF request.partner_pp THEN
        request.secondary_pp := request.channel_used;
        IF ver_request.pp.secondary > 0 THEN
          dyfstrnum ('AND PP', ver_request.pp.secondary, user_dayf);
          request.secondary_pp.number := ver_request.pp.secondary;
        ELSE

         /repeat_loop/
          FOR i := 1 to 10 DO
            ver_request.clear := 0;
            ver_request.general_status := 0;
            ver_request.length := 1;

            IF request.channel_used.channel_protocol = dsc$cpt_cio THEN

              { Get a partner CIO PP.

              ver_request.pp.kind := cio_cluster_0;
              IF request.channel_used.number > 4 THEN
                ver_request.pp.kind := cio_cluster_1;
              IFEND;
              callver (ver_request, rspt, TRUE);
            ELSE

              { This code exists for Pre NOS 2.5.1 systems.

              ver_request.pp.kind := driver_pp;
              callver (ver_request, rspp, TRUE);
            IFEND;

            IF ver_request.general_status <= 1 THEN
               EXIT /repeat_loop/;
            IFEND;
            n7p$recall;
          FOREND /repeat_loop/;

          IF ver_request.general_status > 1 THEN
            hold_general_status := ver_request.general_status;
            return_pp (request.primary_pp);
            decode_and_display_error (hold_general_status);
          ELSE
            IF request.channel_used.channel_protocol = dsc$cpt_cio THEN
              dyfstrnum ( 'GET SECOND CIO PP', ver_request.pp.primary, user_dayf);
            ELSE
              dyfstrnum ( 'GET SECOND PP', ver_request.pp.primary, user_dayf);
            IFEND;
            request.secondary_pp.number := ver_request.pp.primary;
            request.status := dsc$170_rre_request_ok;
          IFEND;
        IFEND;

        { *NOTE: Code for Special case S1 Cost Reduced PP requests for dual pps
        { here!  This code is specifically for the NOS 2.4.3 with NOS/VE 1.2.1 combination

        IF d7ty.eicb_version < dsc$eicb_version_4 THEN
        /s1cr/
          BEGIN
           IF NOT got_cpu_attr THEN
              set_configuration;
              got_cpu_attr := TRUE;
           IFEND;
           IF (configuration_record [1].processor.element_id.model_number = dsc$cpu_elid_810) OR
                 (configuration_record [1].processor.element_id.model_number = dsc$cpu_elid_830) THEN
              { Exit occurs (implicitly) for non 810/830 processors.
              s1cr_dualpp_check;
           IFEND;
          END /s1cr/;
        IFEND;
      IFEND;

    ELSEIF ver_request.general_status > 1 THEN
      decode_and_display_error (ver_request.general_status);
    ELSEIF ver_request.general_status < 0 THEN
       dyfstring ('call to VER returned with status < 1', system_dayf);
       request.status := dsc$170_rre_null_response;
       RETURN;
    IFEND;

  PROCEND claim_pp;
?? OLDTITLE, NEWTITLE := '~~~~~obtain_pp and return_pp ', EJECT ??

  PROCEDURE [XDCL] obtain_pp (VAR pp: integer);

{
{     The purpose of this procedure is to obtain a single nondriver and nonconcurrent
{ PP for NOS/VE.
{

    IF NOT got_eicb_d7ty THEN

     {  Have not read the D7TY word from the EICB, read it.

      get_dscb(dscb_d7ty,^d7ty, 1);

      { the eicb entry d7ty.eicb_version will be used to choose VER functions

      got_eicb_d7ty:= TRUE;
    IFEND;

    request.driver_pp := FALSE;
    request.partner_pp := FALSE;
    request.channel_used.channel_protocol := dsc$cpt_nio;
    request.primary_pp.number := 0;
    claim_pp;
    pp := request.primary_pp.number;
  PROCEND obtain_pp;
?? SKIP := 3 ??

  PROCEDURE return_pp (pp: dst$170_iou_resource);

    IF pp.channel_protocol = dsc$cpt_cio THEN
      dyfstrnum ('RETURN CIO PP', pp.number, user_dayf);
      ver_request.pp.kind := cio_cluster_0;
    ELSE
      dyfstrnum ('RETURN PP', pp.number, user_dayf);
      ver_request.pp.kind := driver_pp;
    IFEND;
    ver_request.pp.primary := pp.number;
    idle_driver_pp (pp);
    IF request.status = dsc$170_rre_request_ok THEN
      ver_request.general_status := 0;
      ver_request.return_all := FALSE;
      ver_request.length := 1;
      IF d7ty.eicb_version < dsc$eicb_version_4 THEN
        IF pp.channel_protocol = dsc$cpt_cio THEN
           request.status := dsc$170_rre_bad_request;
           dyfstring ('CIO PP requests not supported', system_dayf);
           RETURN;
        IFEND;
        callver (ver_request, rtpp, TRUE);
      ELSE  {use nos 2.5.1 VER request code for any return PP request
        IF pp.channel_protocol = dsc$cpt_cio THEN
           ver_request.pp.kind := cio_cluster_0;
           IF pp.number > 4 THEN
             ver_request.pp.kind := cio_cluster_1;
           IFEND;
        IFEND;
        callver (ver_request, rnpt, TRUE);
      IFEND;
      IF ver_request.general_status > 1 THEN
        decode_and_display_error (ver_request.general_status);
      IFEND;
    IFEND;
  PROCEND return_pp;
?? OLDTITLE, NEWTITLE := '~~~~~validate_driver_pp and idle_driver_pp', EJECT ??
  PROCEDURE validate_driver_pp (pp: dst$170_iou_resource);
    ver_request.general_status := 0;
    ver_request.clear := 0;
    ver_request.pp.primary := pp.number;
    ver_request.length := 1;
    IF d7ty.eicb_version < dsc$eicb_version_4 THEN
        IF pp.channel_protocol = dsc$cpt_cio THEN
           request.status := dsc$170_rre_bad_request;
           dyfstring ('CIO PP requests not supported', system_dayf);
           RETURN;
        IFEND;
       callver (ver_request, stpp, TRUE);
    ELSE
       { use NOS 2.5.1 VER request codes
        IF pp.channel_protocol = dsc$cpt_cio THEN
           ver_request.pp.kind := cio_cluster_0;
           IF pp.number > 4 THEN
             ver_request.pp.kind := cio_cluster_1;
           IFEND;
        IFEND;
       callver (ver_request, stpt, TRUE);
    IFEND;
    IF ver_request.general_status > 1 THEN
      decode_and_display_error (ver_request.general_status);
      RETURN;
    IFEND;
  PROCEND validate_driver_pp;
?? SKIP := 3 ??

  PROCEDURE idle_driver_pp (pp: dst$170_iou_resource);
    validate_driver_pp (pp);
    IF d7ty.eicb_version < dsc$eicb_version_4 THEN
        IF pp.channel_protocol = dsc$cpt_cio THEN
           request.status := dsc$170_rre_bad_request;
           dyfstring ('CIO PP requests not supported', system_dayf);
           RETURN;
        IFEND;
    IFEND;
    pp_table.pp_number := pp.number;
    IF pp.channel_protocol = dsc$cpt_cio THEN
       { when SDA idles a pp it uses bit number 8 of the
       { pp number to determine if the pp is CIO
       pp_table.pp_number:= pp_table.pp_number + 256;
    IFEND;
    callsda (idle_pp, pp_table);
  PROCEND idle_driver_pp;
?? SKIP := 3 ??
?? OLDTITLE ??

  PROCEDURE decode_and_display_error (error_status: integer);

    VAR
      status: integer;

    status := error_status DIV 8;
    CASE status OF
    = 1 = { 1X octal }
      dyfstring ('CHANNEL NOT AVAILABLE/NOT ASSIGNED', system_dayf);
      request.status := dsc$170_rre_ch_not_available;
    = 2 = { 2X octal }
      dyfstring ('EQUIPMENT NOT AVAILABLE/NOT ASSIGNED', system_dayf);
      request.status := dsc$170_rre_eq_not_available;
    = 3 = { 3X octal }
      dyfstring ('UNIT NOT AVAILABLE/NOT ASSIGNED', system_dayf);
      request.status := dsc$170_rre_unit_not_available;
    = 4 = { 4X octal }
      dyfstring ('CM NOT AVAILABLE/NOT ASSIGNED', system_dayf);
      request.status := dsc$170_rre_cm_not_available;
    = 5 = { 5X octal }
      dyfstring ('PP NOT AVAILABLE/NOT ASSIGNED', system_dayf);
      request.status := dsc$170_rre_pp_not_available;
    = 6 = { 6X octal }
      dyfstring ('CHANNEL/EQUIPMENT/UNIT NOT IN EST', system_dayf);
      request.status := dsc$170_rre_no_such_resource;
    = 7 = { 7X octal }
      dyfstring ('EQUIPMENT/UNIT ALREADY ASSIGNED TO NOS/VE', system_dayf);
      request.status := dsc$170_rre_already_assigned;
    = 10(8) = { 10X octal }
      dyfstring ('DO NOT DOWNLINE LOAD CONTROLWARE', system_dayf);
      request.status := dsc$170_rre_no_load_controlware;
    = 11(8) = { 11X octal }
      dyfstring ('CONCURRENT CHANNEL NOT PRESENT', system_dayf);
      request.status := dsc$170_rre_cio_ch_not_present;
    = 15(8) = { 15X octal }
      dyfstring ('CONCURRENT PP NOT PRESENT', system_dayf);
      request.status := dsc$170_rre_cio_pp_not_present;
    ELSE
      request.status := dsc$170_rre_bad_request;
      IF status = 38(16) THEN { 70X octal }
        dyfstring ('INSUFFICIENT LENGTH IN RESPONSE BUFFER', system_dayf);
      ELSEIF status = 40(16) THEN { 100X octal }
        dyfstring ('ILLEGAL REQUEST', system_dayf);
      ELSEIF status = 80(16) THEN { 200X octal }
        dyfstring ('DUAL STATE NOT ENABLED', system_dayf);
      ELSE
        RETURN;
      IFEND;
    CASEND;
  PROCEND decode_and_display_error;
?? NEWTITLE := '^^^^   dsp$claim_nve_resources', EJECT ??
{********************************************************}

  PROCEDURE [XDCL] dsp$claim_nve_resources (VAR rblock: dst$170_request_block);

?? SKIP := 3 ??

    PROCEDURE equipment_request (kind_of_request: ver_functions);

      VAR
        statflg: boolean;

      ver_request.clear := 0;
      ver_request.eq.channel := request.equipment_path.channel_number;
      ver_request.eq.equipment := request.equipment_path.equipment_number;
      ver_request.eq.unit := request.equipment_path.unit_number;
      ver_request.return_all := FALSE;
      IF kind_of_request = rseq THEN
        ver_request.length := 2;
      ELSE
        ver_request.length := 1;
      IFEND;
      ver_request.fill := 0;
      ver_request.general_status := 0;
      callver (ver_request, kind_of_request, statflg);
      IF ver_request.general_status > 1 THEN
        decode_and_display_error (ver_request.general_status);
      IFEND;
    PROCEND equipment_request;
?? SKIP := 3 ??
    IF NOT got_eicb_d7ty THEN
      get_dscb(dscb_d7ty,^d7ty, 1);
      { the eicb entry d7ty.eicb_version will be used to choose VER functions
      got_eicb_d7ty:= TRUE;
    IFEND;

    request := rblock.resource_request;
    request.status := dsc$170_rre_request_ok;
    CASE request.resource_request_type OF

    = dsc$170_rrt_get_channel =
      ver_request.general_status := 0;
      ver_request.return_all := FALSE;
      ver_request.length := 1;
      ver_request.channel.primary := request.channel.number;
      IF request.channel.channel_protocol = dsc$cpt_cio THEN
        IF d7ty.eicb_version < dsc$eicb_version_4 THEN
          request.status := dsc$170_rre_bad_request;
          dyfstring ('CIO channel requests not supported', system_dayf);
          RETURN;
        IFEND;
        dyfstrnum ('GET CIO CHANNEL', request.channel.number, user_dayf);
        ver_request.channel.kind := cio_channel;
        callver (ver_request, rsct, TRUE);
      ELSE
        dyfstrnum ('GET CHANNEL', request.channel.number, user_dayf);
        ver_request.channel.kind := nio_channel;
        IF d7ty.eicb_version < dsc$eicb_version_4 THEN
            { use pre 2.5.1 code on ver request
            callver (ver_request, rsch, TRUE);
        ELSE
             { try new ( ie. NOS 2.5.1 ) request code
             callver (ver_request, rsct, TRUE);
        IFEND;
      IFEND;
      IF ver_request.general_status > 1 THEN
        decode_and_display_error (ver_request.general_status);
      IFEND;

    = dsc$170_rrt_return_channel =
      ver_request.general_status := 0;
      ver_request.return_all := FALSE;
      ver_request.length := 1;
      ver_request.channel.primary := request.channel.number;
      IF d7ty.eicb_version < dsc$eicb_version_4 THEN
        IF request.channel.channel_protocol = dsc$cpt_cio THEN
           request.status := dsc$170_rre_bad_request;
           dyfstring ('CIO channel requests not supported', system_dayf);
           RETURN;
        IFEND;
        dyfstrnum ('RETURN CHANNEL', request.channel.number, user_dayf);
        ver_request.channel.kind := cio_channel;
        callver (ver_request, rtch, TRUE);
      ELSE { use NOS 2.5.1 VER requests
        IF request.channel.channel_protocol = dsc$cpt_cio THEN
           dyfstrnum ('RETURN CIO CHANNEL', request.channel.number, user_dayf);
           ver_request.channel.kind := cio_channel;
        ELSE
           dyfstrnum ('RETURN NIO CHANNEL', request.channel.number, user_dayf);
           ver_request.channel.kind := nio_channel;
        IFEND;
        callver (ver_request, rnct, TRUE);
      IFEND;
      IF ver_request.general_status > 1 THEN
        decode_and_display_error (ver_request.general_status);
      IFEND;

    = dsc$170_rrt_get_pp =
      claim_pp;

    = dsc$170_rrt_return_pp =
      return_pp (request.primary_pp);
      IF request.partner_pp THEN
        return_pp (request.secondary_pp);
      IFEND;

    = dsc$170_rrt_get_equipment =
      dyfstrnum ('GET EQUIPMENT', request.equipment_path.channel_number * 1000
            + request.equipment_path.equipment_number * 100 +
            request.equipment_path.unit_number, user_dayf);
      equipment_request (rseq);

    = dsc$170_rrt_return_equipment =
      dyfstrnum ('RETURN EQUIPMENT', request.equipment_path.channel_number * 1000
            + request.equipment_path.equipment_number * 100 +
            request.equipment_path.unit_number, user_dayf);
      equipment_request (rteq);

    = dsc$170_rrt_update_free_clock =
      dyfstring ('INCREMENT FRC' , system_dayf);
      ver_request.return_all := FALSE;
      ver_request.fill:= 0;
      ver_request.length := 1;
      ver_request.general_status := 0;
      ver_request.fill1:= 0;
      ver_request.new_value:= request.new_value;
      callver (ver_request, ifrc, TRUE);
      IF ver_request.general_status > 1 THEN
        decode_and_display_error (ver_request.general_status);
      IFEND;

    ELSE
      request.status := dsc$170_rre_bad_request;
      dyfstring ('BAD REQUEST', system_dayf);
    CASEND;

    rblock.resource_request := request;

  PROCEND dsp$claim_nve_resources;
?? TITLE := '***  S1CR_dualpp_check ***', EJECT ??
  PROCEDURE s1cr_dualpp_check;

    FUNCTION pps_r_partners_or_drivers
      (    pp_1: 0 .. 31;
           pp_2: 0 .. 31): boolean;

      pps_r_partners_or_drivers := FALSE;
      { if the pair is a partner pair everything is A-OK
      IF (pp_1 + 20(8) = pp_2) OR (pp_1 = pp_2 + 20(8)) THEN
        pps_r_partners_or_drivers := TRUE;
        RETURN;
      IFEND;
      { if they are both from the driver barrel thats okay too
      IF (pp_1 >= 20(8)) AND (pp_2 >= 20(8)) THEN
        pps_r_partners_or_drivers := TRUE;
        RETURN;
      IFEND;
    FUNCEND pps_r_partners_or_drivers;

    VAR
      temp_ver_request: ver_request_block,
      s1cr_request: dst$170_resource_request,
      s1cr_pair_req_ok: boolean,
      s1cr_req_list: array [1 .. 10] of dst$170_iou_resource,
      temp: dst$170_iou_resource,
      req_: 0 .. 11,
      i,
      j: integer;

  /s1cr_outer/
    BEGIN
      s1cr_pair_req_ok := FALSE;
      IF pps_r_partners_or_drivers (request.primary_pp.number, request.
            secondary_pp.number) THEN
        s1cr_pair_req_ok := TRUE;
        EXIT /s1cr_outer/;
      IFEND;
      {  get another pp and see if it is okay
      req_ := 0;

    /s1cr_inner/
      BEGIN
        REPEAT
          temp_ver_request.clear := 0;
          temp_ver_request.general_status := 0;
          temp_ver_request.length := 1;
          temp_ver_request.pp.kind := non_driver_pp;
          callver (temp_ver_request, rspp, TRUE);
          IF temp_ver_request.general_status <> 1 THEN
            EXIT /s1cr_inner/;
          IFEND;
          dyfstrnum ('GET PP', temp_ver_request.pp.primary, user_dayf);
          s1cr_request.primary_pp := request.channel_used;
          s1cr_request.primary_pp.number := temp_ver_request.pp.primary;

          { so now we have a new PP to consider as a candidate
          req_ := req_ + 1;
          IF pps_r_partners_or_drivers (s1cr_request.primary_pp.number,
                request.secondary_pp.number) THEN
            s1cr_pair_req_ok := TRUE;
            s1cr_req_list [req_] := request.primary_pp;
            request.primary_pp := s1cr_request.primary_pp;
            EXIT /s1cr_inner/;
          IFEND;
          IF pps_r_partners_or_drivers (s1cr_request.primary_pp.number,
                request.primary_pp.number) THEN
            s1cr_pair_req_ok := TRUE;
            s1cr_req_list [req_] := request.secondary_pp;
            request.secondary_pp := s1cr_request.primary_pp;
            EXIT /s1cr_inner/;
          IFEND;
          { this new pp gained nothing, so add it to the list and get another
          s1cr_req_list [req_] := s1cr_request.primary_pp;
          IF req_ > 1 THEN { perhaps 2 PPs from the list are ok
            FOR i := 1 TO (req_ - 1) DO
              FOR j := i TO (req_ - 1) DO
                IF pps_r_partners_or_drivers (s1cr_req_list [j].number,
                      s1cr_req_list [j + 1].number) THEN
                  s1cr_pair_req_ok := TRUE;
                  temp := request.primary_pp;
                  request.primary_pp := s1cr_req_list [j];
                  s1cr_req_list [j] := temp;
                  temp := request.secondary_pp;
                  request.secondary_pp := s1cr_req_list [j + 1];
                  s1cr_req_list [j + 1] := temp;
                  EXIT /s1cr_inner/;
                IFEND;
              FOREND;
            FOREND;
          IFEND;
        UNTIL (req_ = 10);
      END /s1cr_inner/;

      { now send the extra PPs back to NOS
      IF req_ > 0 THEN
        FOR i := 1 TO req_ DO
          temp_ver_request.clear := 0;
          temp_ver_request.general_status := 0;
          temp_ver_request.length := 1;
          temp_ver_request.pp.kind := non_driver_pp;
          temp_ver_request.pp.primary := s1cr_req_list [i].number;
          callver (temp_ver_request, rtpp, TRUE);
          IF ver_request.general_status > 1 THEN
            decode_and_display_error (ver_request.general_status);
            EXIT /s1cr_outer/;
          IFEND;
          dyfstrnum ('RETURN PP', s1cr_req_list [i].number, user_dayf);
        FOREND;
      IFEND;
    END /s1cr_outer/;
    IF NOT s1cr_pair_req_ok THEN {return the two in the request and set status
      request.status := dsc$170_rre_pp_not_available;
      { return the first one of the two
      temp_ver_request.clear := 0;
      temp_ver_request.general_status := 0;
      temp_ver_request.length := 1;
      temp_ver_request.pp.kind := non_driver_pp;
      temp_ver_request.pp.primary := request.primary_pp.number;
      callver (temp_ver_request, rtpp, TRUE);
      IF ver_request.general_status > 1 THEN
        decode_and_display_error (ver_request.general_status);
        RETURN;
      IFEND;
      dyfstrnum ('RETURN PP', request.primary_pp.number, user_dayf);
      { return the second one of the two
      temp_ver_request.clear := 0;
      temp_ver_request.general_status := 0;
      temp_ver_request.length := 1;
      temp_ver_request.pp.kind := non_driver_pp;
      temp_ver_request.pp.primary := request.secondary_pp.number;
      callver (temp_ver_request, rtpp, TRUE);
      IF ver_request.general_status > 1 THEN
        decode_and_display_error (ver_request.general_status);
      IFEND;
      dyfstrnum ('RETURN PP', request.secondary_pp.number, user_dayf);
    IFEND;
  PROCEND s1cr_dualpp_check;
?? OLDTITLE ??
MODEND dsm$obtain_resources_for_ve;
*DECK DECK=DSM$PACK_32_TO_60 EXPAND=TRUE
          IDENT  DSM3260
          TITLE  DSM$PACK 32 TO 60
          SPACE  4,10
          EXT    ZSMRRET,ZSMRENT,PARSV
          SPACE  4,10
          EJECT
*         P32TO60 - PACK 32 BIT WORDS INTO 60 BIT WORDS.
*
*         AN ARRAY OF 32 BITS RIGHT JUSTIFIED IN 60-BIT-WORDS
*         IS PACKED INTO 60-BIT-WORDS.
*
*         ENTRY  - FROM CYBIL CODE WITH PARAMETERS
*                  P32P0 = NUMBER OF 32 BIT WORDS - MUST BE MOD 15(10)
*                  P32P1 = INPUT ARRAY ADDRESS,
*                  P32P2 = OUTPUT BUFFER ADDRESS.
*
*         EXIT   - INPUT ARRAY REPACKED INTO OUTPUT BUFFER.
*
          ENTRY  P32TO60
 P32P0    EQU    0           PARAMETER 0 ADDRESS IN PARSV AREA
 P32P1    EQU    1           DITTO FOR PARAMETER ONE
 P32P2    EQU    2           DITTO FOR PARAMETER TWO
*
 P32TO60  BSS    0
          RJ     ZSMRENT     SAVE CYBIL ENVNMNT AND PARAMETERS
 P32.ENT  BSS    0           LOAD PARAMETERS
          SA1    PARSV+P32P0
          SB2    X1          NUMBER OF WORDS
          SA1    PARSV+P32P1
          SB3    X1          32 BIT ARRAY ADDRESS
          SA1    PARSV+P32P2
          SB4    X1          60 BIT BUFFER ADDRESS
          MX0    -32
 P32.00   BSS    0
          SA2    B3          LOAD NEXT 4 ARRAY WORDS INTO X2 - X3
          SA3    A2+B1
          SA4    A3+B1
          SA5    A4+B1
*
          BX6    -X0*X2
          LX6    28
          BX3    -X0*X3
          LX3    -4
          BX2    -X0*X3
          BX6    X6+X2
          SA6    B4          SAVE W0,U28W1
*
          BX7    X0*X3
          BX4    -X0*X4
          LX4    24
          BX7    X7+X4
          BX5    -X0*X5
          LX5    -8
          BX2    -X0*X5
          BX7    X7+X2
          SA7    A6+B1       SAVE L4W1,W2,U24W3
*
          BX6    X0*X5
*
          SA2    A5+B1       LOAD NEXT 4 ARRAY WORDS INTO X2 - X5
          SA3    A2+B1
          SA4    A3+B1
          SA5    A4+B1
*
          BX2    -X0*X2
          LX2    20
          BX6    X6+X2
          BX3    -X0*X3
          LX3    -12
          BX2    -X0*X3
          BX6    X6+X2
          SA6    A7+B1       SAVE L8W3,W4,U20W5
*
          BX7    X0*X3
          BX4    -X0*X4
          LX4    16
          BX7    X7+X4
          BX5    -X0*X5
          LX5    -16
          BX2    -X0*X5
          BX7    X7+X2
          SA7    A6+B1       SAVE L12W5,W6,U16W7
*
          BX6    X0*X5
*
          SA2    A5+B1       LOAD NEXT 4 ARRAY WORDS INTO X2 - X5
          SA3    A2+B1
          SA4    A3+B1
          SA5    A4+B1
*
          BX2    -X0*X2
          LX2    12
          BX6    X6+X2
          BX3    -X0*X3
          LX3    -20
          BX2    -X0*X3
          BX6    X6+X2
          SA6    A7+B1       SAVE L16W7,W8,U12W9
*
          BX7    X0*X3
          BX4    -X0*X4
          LX4    8
          BX7    X7+X4
          BX5    -X0*X5
          LX5    -24
          BX2    -X0*X5
          BX7    X7+X2
          SA7    A6+B1       SAVE L20W9,W10,U8W11
*
          BX6    X0*X5
*
          SA2    A5+B1       LOAD NEXT 3 ARRAY WORDS INTO X2 - X4
          SA3    A2+B1
          SA4    A3+B1
*
          BX2    -X0*X2
          LX2    4
          BX6    X6+X2
          BX3    -X0*X3
          LX3    -28
          BX2    -X0*X3
          BX6    X6+X2
          SA6    A7+B1       SAVE L24W11,W12,U4W13
*
          BX7    X0*X3
          BX4    -X0*X4
          BX7    X7+X4
          SA7    A6+B1       SAVE L28W13,W14
*
          SB2    B2-15D      DECREMENT B2 BY ARRAY BLOCK COUNT
          SB4    A7+B1       STEP A6 TO NEXT 60 BIT WORD
          SB3    A4+B1       STEP B3 TO NEXT ARRAY WORD
          NE     B0,B2,P32.00  MORE BUFFER WORDS TO UNPACK
 P32.EXI  BSS    0
          JP     ZSMRRET     RESTORE ISWL ENVIRONMENT AND RETURN

          END
*DECK DECK=DSM$PACK_60_TO_64 EXPAND=TRUE
          IDENT  DSA6064
          TITLE  DSM$PACK 60 TO 64
          ENTRY  P60TO64
          EXT    ZSMRENT,ZSMRRET,PARSV
          SPACE  4,10
*         P60TO64 - PACK 56/60 BITS INTO 64 BITS IN 60 BIT WORDS.
*
*         A BUFFER OF 56/60 BITS RIGHT JUSTIFIED IN 60 BITS
*         IS REPACKED INTO 64 BITS.
*
*         ENTRY  - FROM CYBIL CODE WITH PARAMETERS
*                  P60P0 = NUMBER OF 60 BIT WORDS - MUST BE MOD 16(10)
*                  MDEP1 = MODE 0 FOR B60, 1 FOR B56,
*                  MSKP2 = BIT MASK, 56/52 BITS,
*                  B60P3 = BUFFER OF 60/56 BITS,
*                  B64P4 = BUFFER OF PACKED 64 BITS.
*
*         EXIT   - INPUT ARRAY REPACKED INTO OUTPUT BUFFER.
*
 MASK     CON    3777777777777777777B
          CON    77777777777777777760B
          CON    0
 P60P0    EQU    0           PARAMETER 0 ADDRESS IN PARSV AREA
 MDEP1    EQU    1           DITTO FOR PARAMETER ONE
 MSKP2    EQU    2           DITTO FOR PARAMETER TWO
 B60P3    EQU    3           DITTO FOR PARAMETER THREE
 B64P4    EQU    4           DITTO FOR PARAMETER FOUR
*
 P60TO64  BSS    0
          RJ     ZSMRENT     SAVE CYBIL ENVNMNT AND PARAMETERS
 P56.ENT  BSS    0           LOAD PARAMETERS
*
          SA1    PARSV+P60P0
          SB2    X1          NUMBER OF WORDS IN *B2*
*
          SA1    PARSV+MDEP1
          SB5    X1          MODE 0/1 = B60/B56 IN *B5*
*
          SA2    PARSV+B60P3
          SB3    X2          INPUT BUFFER ADDRESS IN *B3*
*
          SA2    PARSV+B64P4
          SB4    X2          OUTPUT BUFFER ADDRESS IN *B4*
*
          SX5    B5          B5 = 0 FOR B60
          NZ     X5,P56.00   B56 CONVERSION
*
*         B60 CONVERSION
*
 P60.00   BSS    0
          SA1    B5+MASK
*         X1                 MASK IN *X1*
          MX0    -56
          SA2    B3          LOAD WORDS W0 - W3 INTO X2 - X5
          SA3    A2+B1
          SA4    A3+B1
          SA5    A4+B1
*
          LX2    -4
          BX6    X1*X2
          AX1    4           RIGHT SHIFT B56/52 MASK
          SA6    B4          SAVE W0, U56 BITS
*
          LX3    -8
          BX7    X1*X3
          AX1    4
          BX2    X0*X2
          AX0    4
          BX7    X2+X7
          SA7    A6+B1       SAVE W0L4,W1U52
*
          LX4    -12
          BX6    X1*X4
          AX1    4           RIGHT SHIFT 17B MASK, EXTEND SIGN ON LEFT
          BX3    X0*X3
          AX0    4
          BX6    X3+X6
          SA6    A7+B1       SAVE W1L8,W2U48
*
          LX5    -16
          BX7    X1*X5
          AX1    4
          BX4    X0*X4
          AX0    4
          BX7    X4+X7
          SA7    A6+B1       SAVE W2L12,W3U44
*
          BX7    X0*X5       TEMP SAVE W3 L16
          AX0    4
*
          SA2    A5+B1       LOAD WORDS W4 - W7 INTO X2 - X5
          SA3    A2+B1
          SA4    A3+B1
          SA5    A4+B1
*
          LX2    -20
          BX6    X1*X2
          AX1    4
          BX6    X6+X7
          SA6    A7+1        SAVE W3L16,W4U40
*
          LX3    -24
          BX7    X1*X3
          AX1    4
          BX2    X0*X2
          AX0    4
          BX7    X2+X7
          SA7    A6+B1       SAVE W4L20,W5U36
*
          LX4    -28
          BX6    X1*X4
          AX1    4
          BX3    X0*X3
          AX0    4
          BX6    X3+X6
          SA6    A7+B1       SAVE W5L24,W6U32
*
          LX5    -32
          BX7    X1*X5
          AX1    4
          BX4    X0*X4
          AX0    4
          BX7    X4+X7
          SA7    A6+B1       SAVE W6L28,W7U28
*
          BX7    X0*X5       TEMP SAVE W7L32
          AX0    4
*
          SA2    A5+B1       LOAD WORDS W8 - W11 INTO X2 - X5
          SA3    A2+B1
          SA4    A3+B1
          SA5    A4+B1
*
          LX2    -36
          BX6    X1*X2
          AX1    4
          BX6    X6+X7
          SA6    A7+1        SAVE W7L28,W8U24
*
          LX3    -40
          BX7    X1*X3
          AX1    4
          BX2    X0*X2
          AX0    4
          BX7    X2+X7
          SA7    A6+B1       SAVE W8L36,W9U20
*
          LX4    -44
          BX6    X1*X4
          AX1    4
          BX3    X0*X3
          AX0    4
          BX6    X3+X6
          SA6    A7+B1       SAVE W9L40,W10U16
*
          LX5    -48
          BX7    X1*X5
          AX1    4
          BX4    X0*X4
          AX0    4
          BX7    X4+X7
          SA7    A6+B1       SAVE W12L44,W11U12
*
          BX7    X0*X5       TEMP SAVE W11L48
          AX0    4
*
          SA2    A5+B1       LOAD WORDS W12 - W14 INTO X2 - X4
          SA3    A2+B1
          SA4    A3+B1
*
          LX2    -52
          BX6    X1*X2
          AX1    4
          BX6    X6+X7
          SA6    A7+B1       SAVE W11L48,W12U8
*
          LX3    -56
          BX7    X1*X3
          AX1    4
          BX2    X0*X2
          AX0    4
          BX7    X2+X7
          SA7    A6+B1       SAVE W12L52,W13U4
*
          BX6    X0*X3
          SA6    A7+B1       SAVE W13L56
*
          SX5    B5
          BX7    X4
 P60.01   SA7    A6+B1      SAVE W14U60
*
          SB2    B2-15D      DECREMENT B2 BY ARRAY BLOCK COUNT
          SB4    A7+B1       STEP B4 TO NEXT PACKED 64 BIT WORD
          SB3    A4+B1       STEP B3 TO NEXT ARRAY WORD
          NE     B0,B2,P60.00  MORE BUFFER WORDS TO UNPACK
 P60.EXI  BSS    0
          JP     ZSMRRET     RESTORE ISWL ENVIRONMENT AND RETURN
*
*
*         B56 CONVERSION
*
 P56.00   BSS    0
          SA1    B5+MASK
*         X1                 MASK IN *X1*
          SA2    B3          LOAD WORDS W0 - W3 INTO X2 - X5
          SA3    A2+B1
          SA4    A3+B1
          SA5    A4+B1
*
          LX2    4
          MX1    -4
          BX6    X1*X2
*
          LX3    8
          BX0    -X1*X3
          MX1    -8
          BX6    X6+X0
*
          SA6    B4          SAVE W0L56,W1U4
*
          BX7    X1*X3
*
          LX4    12
          BX0    -X1*X4
          MX1    -12
          BX7    X7+X0
*
          SA7    A6+B1       SAVE W1L52,W2U8
*
          BX6    X1*X4
*
          LX5    16
          BX0    -X1*X5
          MX1    -16
          BX6    X6+X0
*
          SA6    A7+B1       SAVE W2L48,W3U12
*
          BX7    X1*X5
*
          SA2    A5+B1       LOAD WORDS W4 - W7 INTO X2 - X5
          SA3    A2+B1
          SA4    A3+B1
          SA5    A4+B1
*
          LX2    20
          BX0    -X1*X2
          MX1    -20
          BX7    X7+X0
*
          SA7    A6+B1       SAVE W3L44,W4U16
*
          BX6    X1*X2
*
          LX3    24
          BX0    -X1*X3
          MX1    -24
          BX6    X6+X0
*
          SA6    A7+B1       SAVE W4L40,W5U20
*
          BX7    X1*X3
*
          LX4    28
          BX0    -X1*X4
          MX1    -28
          BX7    X7+X0
*
          SA7    A6+B1       SAVE W5L36,W6U24
*
          BX6    X1*X4
*
          LX5    32
          BX0    -X1*X5
          MX1    -32
          BX6    X6+X0
*
          SA6    A7+B1      SAVE W6L32,W7U28
*
          BX7    X1*X5
*
          SA2    A5+B1       LOAD WORDS W8 - 11 INTO X2 - X5
          SA3    A2+B1
          SA4    A3+B1
          SA5    A4+B1
*
          LX2    36
          BX0    -X1*X2
          MX1    -36
          BX7    X7+X0
*
          SA7    A6+B1       SAVE W7L28,W8U32
*
          BX6    X1*X2
*
          LX3    40
          BX0    -X1*X3
          MX1    -40
          BX6    X6+X0
*
          SA6    A7+B1       SAVE W8L24,W9U36
*
          BX7    X1*X3
*
          LX4    44
          BX0    -X1*X4
          MX1    -44
          BX7    X7+X0
*
          SA7    A6+B1       SAVE W9L20,W10U40
*
          BX6    X1*X4
*
          LX5    48
          BX0    -X1*X5
          MX1    -48
          BX6    X6+X0
*
          SA6    A7+B1      SAVE W10L16,W11U44
*
          BX7    X1*X5
*
*
          SA2    A5+B1       LOAD WORDS W12 - W14 INTO X2 - X5
          SA3    A2+B1
          SA4    A3+B1
*
          LX2    52
          BX0    -X1*X2
          MX1    -52
          BX7    X7+X0
*
          SA7    A6+B1       SAVE W11L12,W12U48
*
          BX6    X1*X2
*
          LX3    56
          BX0    -X1*X3
          MX1    -56
          BX6    X6+X0
*
          SA6    A7+B1       SAVE W12L8,W13U44
*
          BX7    X1*X3
*
          LX4    60
          BX0    -X1*X4
          MX1    -60
          BX7    X7+X0
*
          SA7    A6+B1       SAVE W13U4,W14L56
*
          SB2    B2-15D      DECREMENT B2 BY ARRAY BLOCK COUNT
          SB4    A7+B1       STEP B4 TO NEXT PACKED 60 BIT WORD
          SB3    A4+B1       STEP B3 TO NEXT ARRAY WORD
          NE     B0,B2,P56.00  MORE BUFFER WORDS TO UNPACK
          JP     P60.EXI     RESTORE ISWL ENVIRONMENT AND RETURN
          END
*DECK DECK=DSM$PROCESS_170_REQUESTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Process 170 Requests' ??
MODULE dsm$process_170_requests;

{ PURPOSE:
{   This module contains all of the procedures which make requests to the 170 operating system.
{ DESIGN:
{   The majority of the procedures in this module are called to create the request block that is used to make
{   the 170 request.  All of these procedures then call the one procedure that actually makes the 170 request.
{ NOTES:
{   This module contains many type declarations that can not be easily changed.  These type declarations
{   define a block of data that the 170 operating system code expects to find in a particular order.  Caution
{   must be taken when dealing with these type declarations.  If any changes are made to the type
{   declarations, a corresponding change must be made to the 170 operating system code.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dse$error_codes
*copyc dst$dft_free_run_clock_value
*copyc dst$170_request_block
*copyc dst$resource_request
*copyc ost$string
*copyc ost$wait
?? POP ??
*copyc clp$convert_integer_to_string
*copyc dpp$put_critical_message
*copyc dsp$get_data_from_ssr
*copyc dsp$store_data_in_ssr
*copyc i#real_memory_address
*copyc osp$clear_mainframe_sig_lock
*copyc osp$initialize_signature_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$cycle
*copyc pmp$delay
?? EJECT ??
*copyc osv$mainframe_wired_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
  VAR
    v$ssr_170_request_lock: ost$signature_lock;
?? OLDTITLE ??
?? NEWTITLE := 'create_170_status', EJECT ??

{ PURPOSE:
{   This procedure analyzes the status that was returned from the 170 resource request and produces a status
{   message for the system.

  PROCEDURE create_170_status
    (    resource_request_170: dst$170_resource_request;
     VAR status: ost$status);

    VAR
      condition_code: ost$status_condition_code,
      insert_size: 0 .. 80,
      insert_text: string (80),
      integer_string: ost$string,
      size: ost$string_size,
      text: string (osc$max_string_size);

    status.normal := TRUE;
    insert_text (1, *) := ' ';
    insert_size := 1;

    CASE resource_request_170.resource_request_type OF
    = dsc$170_rrt_get_pp =
      IF resource_request_170.channel_used.channel_protocol = dsc$cpt_cio THEN
        insert_text (insert_size, 4) := 'CIO ';
        insert_size := insert_size + 4;
      IFEND;
      IF resource_request_170.partner_pp THEN
        insert_text (insert_size, 8) := 'PARTNER ';
        insert_size := insert_size + 8;
      IFEND;
      IF resource_request_170.driver_pp THEN
        insert_text (insert_size, 7) := 'DRIVER ';
        insert_size := insert_size + 7;
      IFEND;
      insert_text (insert_size, 3) := 'PP ';
      insert_size := insert_size + 3;
    = dsc$170_rrt_return_pp =
      IF resource_request_170.channel_used.channel_protocol = dsc$cpt_cio THEN
        insert_text (insert_size, 4) := 'CIO ';
        insert_size := insert_size + 4;
      IFEND;
      insert_text (insert_size, 3) := 'PP ';
      insert_size := insert_size + 3;
      clp$convert_integer_to_string (resource_request_170.primary_pp.number, 10, TRUE,
            integer_string, status);
      insert_text (insert_size, integer_string.size) := integer_string.value (1, integer_string.size);
      insert_size := insert_size + integer_string.size;
    = dsc$170_rrt_get_channel, dsc$170_rrt_return_channel =
      IF resource_request_170.channel.channel_protocol = dsc$cpt_cio THEN
        insert_text (insert_size, 4) := 'CIO ';
        insert_size := insert_size + 4;
      IFEND;
      insert_text (insert_size, 8) := 'CHANNEL ';
      insert_size := insert_size + 8;
      clp$convert_integer_to_string (resource_request_170.channel.number, 10, TRUE, integer_string, status);
      insert_text (insert_size, integer_string.size) := integer_string.value (1, integer_string.size);
      insert_size := insert_size + integer_string.size;
    = dsc$170_rrt_get_equipment, dsc$170_rrt_return_equipment =
      insert_text (insert_size, 9) := 'CHANNEL: ';
      insert_size := insert_size + 9;
      clp$convert_integer_to_string (resource_request_170.equipment_path.channel_number, 10, TRUE,
            integer_string, status);
      insert_text (insert_size, integer_string.size) := integer_string.value (1, integer_string.size);
      insert_size := insert_size + integer_string.size;
      insert_text (insert_size, 12) := ' EQUIPMENT: ';
      insert_size := insert_size + 12;
      clp$convert_integer_to_string (resource_request_170.equipment_path.equipment_number, 10, TRUE,
            integer_string, status);
      insert_text (insert_size, integer_string.size) := integer_string.value (1, integer_string.size);
      insert_size := insert_size + integer_string.size;
      insert_text (insert_size, 7) := ' UNIT: ';
      insert_size := insert_size + 7;
      clp$convert_integer_to_string (resource_request_170.equipment_path.unit_number, 10, TRUE,
            integer_string, status);
      insert_text (insert_size, integer_string.size) := integer_string.value (1, integer_string.size);
      insert_size := insert_size + integer_string.size;
    = dsc$170_rrt_update_free_clock =
      insert_text (insert_size, 25) := 'Update free running clock';
      insert_size := insert_size + 25;
    ELSE
      insert_text (insert_size, 12) := 'NULL REQUEST';
      insert_size := 12;
    CASEND;

    CASE resource_request_170.status OF
    = dsc$170_rre_ch_not_available, dsc$170_rre_eq_not_available, dsc$170_rre_pp_not_available =
      condition_code := dse$resource_not_available;
    = dsc$170_rre_unit_not_available =
      insert_text (1, 4) := 'UNIT';
      insert_size := 4;
      condition_code := dse$resource_not_available;
    = dsc$170_rre_cm_not_available =
      insert_text (1, 2) := 'CM';
      insert_size := 2;
      condition_code := dse$resource_not_available;
    = dsc$170_rre_no_such_resource =
      condition_code := dse$resource_does_not_exist;
    = dsc$170_rre_already_assigned =
      condition_code := dse$resource_already_assigned;
    = dsc$170_rre_no_load_controlware =
      condition_code := dse$dont_load_controlware;
    = dsc$170_rre_cio_ch_not_present =
      clp$convert_integer_to_string (resource_request_170.channel.number, 10, TRUE, integer_string, status);
      insert_text (1, integer_string.size) := integer_string.value (1, integer_string.size);
      insert_size := integer_string.size;
      condition_code := dse$cio_channel_not_present;
    = dsc$170_rre_cio_pp_not_present =
      clp$convert_integer_to_string (resource_request_170.primary_pp.number, 10, TRUE,
            integer_string, status);
      insert_text (1, integer_string.size) := integer_string.value (1, integer_string.size);
      insert_size := integer_string.size;
      IF resource_request_170.partner_pp THEN
        insert_text (insert_size, 7) := ' OR PP ';
        insert_size := insert_size + 7;
        clp$convert_integer_to_string (resource_request_170.secondary_pp.number, 10, TRUE,
              integer_string, status);
        insert_text (insert_size, integer_string.size) := integer_string.value (1, integer_string.size);
        insert_size := insert_size + integer_string.size;
      IFEND;
      condition_code := dse$cio_pp_not_present;
    ELSE
      CASE resource_request_170.resource_request_type OF
      = dsc$170_rrt_get_pp =
        insert_text (1, 6) := 'get_pp';
        insert_size := 6;
      = dsc$170_rrt_return_pp =
        insert_text (1, 9) := 'return_pp';
        insert_size := 9;
      = dsc$170_rrt_get_channel =
        insert_text (1, 11) := 'get_channel';
        insert_size := 11;
      = dsc$170_rrt_return_channel =
        insert_text (1, 14) := 'return_channel';
        insert_size := 14;
      = dsc$170_rrt_get_equipment =
        insert_text (1, 13) := 'get_equipment';
        insert_size := 13;
      = dsc$170_rrt_return_equipment =
        insert_text (1, 16) := 'return_equipment';
        insert_size := 16;
      ELSE
      CASEND;
      condition_code := dse$illegal_request;
    CASEND;

    CASE condition_code OF
    = dse$resource_not_available =
      text := 'The desired resource, ';
      size := 22;
      text (size, insert_size) := insert_text (1, insert_size);
      size := size + insert_size;
      text (size, 44) := ' is not available or not assigned to NOS/VE.';
      size := size + 44;
    = dse$resource_does_not_exist =
      text := 'The desired resource, ';
      size := 22;
      text (size, insert_size) := insert_text (1, insert_size);
      size := size + insert_size;
      text (size, 16) := ' does not exist.';
      size := size + 16;
    = dse$resource_already_assigned =
      text := 'The desired resource, ';
      size := 22;
      text (size, insert_size) := insert_text (1, insert_size);
      size := size + insert_size;
      text (size, 31) := ' is already assigned to NOS/VE.';
      size := size + 31;
    = dse$dont_load_controlware =
      text := 'Do not load controlware.';
      size := 24;
    = dse$cio_channel_not_present =
      text := 'The concurrent channel ';
      size := 23;
      text (size, insert_size) := insert_text (1, insert_size);
      size := size + insert_size;
      text (size, 16) := ' is not present.';
      size := size + 16;
    = dse$cio_pp_not_present =
      text := 'The concurrent PP ';
      size := 18;
      text (size, insert_size) := insert_text (1, insert_size);
      size := size + insert_size;
      text (size, 16) := ' is not present.';
      size := size + 16;
    = dse$illegal_request =
      text := 'The request, ';
      size := 13;
      text (size, insert_size) := insert_text (1, insert_size);
      size := size + insert_size;
      text (size, 12) := ' is illegal.';
      size := size + 12;
    ELSE
    CASEND;

    osp$set_status_abnormal (dsc$display_processor_id, condition_code, text (1, size), status);

  PROCEND create_170_status;
?? OLDTITLE ??
?? NEWTITLE := 'send_170_request', EJECT ??

{ PURPOSE:
{   This procedure is used to send requests for resources to the 170 operating system.
{ DESIGN:
{   The request is sent to the 170 operating system through the SSR.  To send a request to the 170 operating
{   system, a pointer to the request is placed in the 180 buffer in the SSR.  A program on the 170 side
{   observes the 180 buffer for the request and acts upon it when one appears.  Any response from the 170
{   operating system is sent via the 170 buffer in the SSR.

  PROCEDURE send_170_request
    (    wait: ost$wait;
     VAR request_170: dst$170_request_block);

    VAR
      c180_length: integer,
      c180_transfer_entry_seq_p: ^SEQ ( * ),
      c180_transfer_entry: dst$ssr_170_transfer_entry,
      c170_length: integer,
      c170_transfer_entry_seq_p: ^SEQ ( * ),
      c170_transfer_entry: dst$ssr_170_transfer_entry,
      local_status: ost$status,
      receive_buffer_p: ^SEQ ( * ),
      request_170_p: ^dst$170_request_block,
      request_170_seq_p: ^SEQ ( * ),
      send_buffer_p: [STATIC] ^SEQ ( * ) := NIL;

    { The SSR buffers must be interlocked so only one user is using them at a time.

    osp$set_mainframe_sig_lock (v$ssr_170_request_lock);
    c180_transfer_entry_seq_p := #SEQ (c180_transfer_entry);

    { Wait until any previous request is finished with the request area.

    IF send_buffer_p <> NIL THEN
      REPEAT
        pmp$cycle (local_status);
        dsp$get_data_from_ssr (dsc$ssr_c180_transfer_buffer, c180_transfer_entry_seq_p);
      UNTIL c180_transfer_entry.length = 0;
      FREE send_buffer_p IN osv$mainframe_wired_heap^;
    IFEND;

    { Send the request to the 170 operating system via the 180 buffer.

    request_170_seq_p := #SEQ (request_170);
    c180_length := #SIZE (request_170_seq_p^);
    ALLOCATE send_buffer_p: [[REP c180_length OF cell]] IN osv$mainframe_wired_heap^;
    send_buffer_p^ := request_170_seq_p^;
    c180_transfer_entry.length := ((c180_length + 14) DIV 15) * 15;
    c180_transfer_entry.offset := #OFFSET (send_buffer_p);
    dsp$store_data_in_ssr (dsc$ssr_c180_transfer_buffer, #SEQ (c180_transfer_entry));

    IF wait = osc$wait THEN
      c170_transfer_entry_seq_p := #SEQ (c170_transfer_entry);
      dsp$get_data_from_ssr (dsc$ssr_c170_transfer_buffer, c170_transfer_entry_seq_p);

      { Wait until any previous request has been received.

      WHILE c170_transfer_entry.length = 0 DO
        pmp$cycle (local_status);
        dsp$get_data_from_ssr (dsc$ssr_c170_transfer_buffer, c170_transfer_entry_seq_p);
      WHILEND;

      c170_length := c170_transfer_entry.length;
      ALLOCATE receive_buffer_p: [[REP c170_length OF cell]] IN osv$mainframe_wired_heap^;
      c170_transfer_entry.offset := #OFFSET (receive_buffer_p);
      dsp$store_data_in_ssr (dsc$ssr_c170_transfer_buffer, #SEQ (c170_transfer_entry));

      { Wait for a response from the 170 operating system.

      REPEAT
        pmp$cycle (local_status);
        dsp$get_data_from_ssr (dsc$ssr_c170_transfer_buffer, c170_transfer_entry_seq_p);
      UNTIL c170_transfer_entry.offset = 0;
      c170_transfer_entry.length := 0;
      dsp$store_data_in_ssr (dsc$ssr_c170_transfer_buffer, #SEQ (c170_transfer_entry));

      RESET receive_buffer_p;
      NEXT request_170_p IN receive_buffer_p;
      request_170 := request_170_p^;
      FREE receive_buffer_p IN osv$mainframe_wired_heap^;
    IFEND;

    osp$clear_mainframe_sig_lock (v$ssr_170_request_lock);

  PROCEND send_170_request;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$call_dft_through_sda', EJECT ??

{ PURPOSE:
{   This procedure sends a request to the 170 operating system to issue a request to DFT through SDA.

  PROCEDURE [XDCL] dsp$call_dft_through_sda
    (    dft_request_p: ^SEQ ( * ));

    VAR
      request_170: dst$170_request_block,
      request_rma: integer;

    i#real_memory_address (dft_request_p, request_rma);
    request_170.request := dsc$170_rb_call_dft_through_sda;
    request_170.dft_request_rma := request_rma;
    send_170_request (osc$wait, request_170);

  PROCEND dsp$call_dft_through_sda;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$exit_deadstart', EJECT ??

{ PURPOSE:
{   This procedure sends a request to the 170 operating system to exit deadstart and begin the code to either
{   RUN VE or TERMINATE VE.

  PROCEDURE [XDCL, #GATE] dsp$exit_deadstart
    (    next_program: (dsc$terminate_ve, dsc$run_ve));

    VAR
      request_170: dst$170_request_block;

    request_170.request := dsc$170_rb_complete_deadstart;
    request_170.terminating := next_program = dsc$terminate_ve;
    send_170_request (osc$nowait, request_170);

  PROCEND dsp$exit_deadstart;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$send_170_resource_request', EJECT ??

{ PURPOSE:
{   This procedure sends the resource request to the 170 operating system.

  PROCEDURE [XDCL] dsp$send_170_resource_request
    (VAR request: dst$resource_request;
     VAR status: ost$status);

    CONST
      four_minute_wait = 4 * 60 * 1000000;

    VAR
      end_wait_time: integer,
      msg_displayed: boolean,
      request_170: dst$170_request_block;

    status.normal := TRUE;
    msg_displayed := FALSE;
    end_wait_time := #free_running_clock (0) + four_minute_wait;

  /wait_for_resource/
    WHILE TRUE DO
      request_170.request := dsc$170_rb_request_resources;
      request_170.resource_request.status := dsc$170_rre_null_response;

      CASE request.resource_request_type OF
      = dsc$rrt_get_pp =
        request_170.resource_request.resource_request_type := dsc$170_rrt_get_pp;
      = dsc$rrt_return_pp =
        request_170.resource_request.resource_request_type := dsc$170_rrt_return_pp;
      = dsc$rrt_get_channel =
        request_170.resource_request.resource_request_type := dsc$170_rrt_get_channel;
      = dsc$rrt_return_channel =
        request_170.resource_request.resource_request_type := dsc$170_rrt_return_channel;
      = dsc$rrt_get_equipment =
        request_170.resource_request.resource_request_type := dsc$170_rrt_get_equipment;
      = dsc$rrt_return_equipment =
        request_170.resource_request.resource_request_type := dsc$170_rrt_return_equipment;
      ELSE
        osp$system_error ('Invalid 170 resource request.', NIL);
      CASEND;

      CASE request.resource_request_type OF
      = dsc$rrt_get_pp, dsc$rrt_return_pp =
        request_170.resource_request.driver_pp := (dsc$rro_driver_pp IN request.options);
        request_170.resource_request.partner_pp := (dsc$rro_partner_pp IN request.options);
        request_170.resource_request.channel_used.channel_protocol := request.channel.channel_protocol;
        request_170.resource_request.channel_used.number := request.channel.number;
        request_170.resource_request.primary_pp.channel_protocol := request.primary_pp.channel_protocol;
        request_170.resource_request.primary_pp.number := request.primary_pp.number;
        request_170.resource_request.secondary_pp.channel_protocol := request.secondary_pp.channel_protocol;
        request_170.resource_request.secondary_pp.number := request.secondary_pp.number;
      = dsc$rrt_get_channel, dsc$rrt_return_channel =
        request_170.resource_request.channel.channel_protocol := request.channel.channel_protocol;
        request_170.resource_request.channel.number := request.channel.number;
      = dsc$rrt_get_equipment, dsc$rrt_return_equipment =
        request_170.resource_request.equipment_path.channel_number := request.channel.number;
        request_170.resource_request.equipment_path.equipment_number := request.equipment_number;
        request_170.resource_request.equipment_path.unit_number := request.unit_number;
      ELSE
        osp$system_error ('Invalid 170 resource request.', NIL);
      CASEND;

      send_170_request (osc$wait, request_170);

      IF request_170.resource_request.status = dsc$170_rre_request_ok THEN
        IF msg_displayed THEN
          dpp$put_critical_message ('PP obtained', status);
        IFEND;
        EXIT /wait_for_resource/;
      IFEND;

      IF (request_170.resource_request.status = dsc$170_rre_pp_not_available) AND
            (#free_running_clock (0) <= end_wait_time) THEN
        IF NOT msg_displayed THEN
          dpp$put_critical_message
                ('A PP is not yet available, will keep trying for about four minutes.', status);
          msg_displayed := TRUE;
        IFEND;
        pmp$delay (100, status);
      ELSE
        create_170_status (request_170.resource_request, status);
        EXIT /wait_for_resource/;
      IFEND;

    WHILEND /wait_for_resource/;

    CASE request.resource_request_type OF
    = dsc$rrt_get_pp =
      request.primary_pp.number := request_170.resource_request.primary_pp.number;
      request.secondary_pp.number := request_170.resource_request.secondary_pp.number;
    = dsc$rrt_get_channel =
      request.channel.number := request_170.resource_request.channel.number;
    ELSE
    CASEND;

  PROCEND dsp$send_170_resource_request;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$setup_170_request_interlock', EJECT ??

{ PURPOSE:
{   This procedure is called to initialize an interlock that this module uses.

  PROCEDURE [XDCL] dsp$setup_170_request_interlock;

    VAR
      local_status: ost$status;

    osp$initialize_signature_lock (v$ssr_170_request_lock, local_status);
    IF NOT local_status.normal THEN
      osp$system_error (' Error in setting the 170 request interlock.', ^local_status);
    IFEND;

  PROCEND dsp$setup_170_request_interlock;
?? OLDTITLE ??
MODEND dsm$process_170_requests;
*DECK DECK=DSM$PROCESS_DEADSTART_FILES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Process Deadstart Files' ??
MODULE dsm$process_deadstart_files;

{ PURPOSE:
{   This module contains the procedure which copies the deadstart files from the deadstart
{   device to local files.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc bat$record_header_type
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc amp$return
*copyc amp$set_segment_eoi
*copyc clp$include_file
*copyc cmp$convert_iou_number
*copyc cmp$get_channel_definition
*copyc cmp$get_element_name
*copyc dsp$cleanup_deadstart_io
*copyc dsp$initialize_io
*copyc dsp$read_deadstart_device
*copyc dsp$read_header_labels
*copyc dsp$retrieve_header_information
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$system_error
?? EJECT ??
*copyc cmv$system_device_data
?? TITLE := 'process_ssv_file', EJECT ??

{ PURPOSE:
{   This procedure processes files that have a block type of SYSTEM_SPECIFIED and a record
{   type of VARIABLE.  These files must be processed in a special way because of the
{   possibility of partial "bam" records from the tape file.  Typically a "bam record"
{   contains a "bam header" followed by the record data.  If the record data plus "bam header"
{   cross a tape block boundary the record data is broken up so that a tape block starts
{   with a "bam header".  There is a flag in the "bam header" denoting the starting record
{   and the ending record.  This procedure puts the starting records and the ending records
{   back into full records.

  PROCEDURE process_ssv_file
    (    deadstart_file_identifier: dst$deadstart_file_identifier;
         file_name: ost$name;
         fa_p: ^fst$attachment_options;
         mca_p: ^fst$file_cycle_attributes;
         av_p: ^fst$file_cycle_attributes;
     VAR status: ost$status);

    VAR
      ba: amt$file_byte_address,
      bam_header_p: ^bat$record_header,
      data_line_p: ^SEQ ( * ),
      file_identifier: amt$file_identifier,
      save_length: integer,
      save_line_p: ^SEQ ( * ),
      scratch_file_id: amt$file_identifier,
      scratch_file_name: ost$name,
      scratch_segment_pointer: amt$segment_pointer,
      scratch_seq_p: ^SEQ ( * ),
      temp_file_id: amt$file_identifier,
      temp_file_name: ost$name,
      temp_file_size: integer,
      temp_seq_p: ^SEQ ( * );

    status.normal := TRUE;

   /open_files/
    BEGIN

      { Open the file that will temporarily hold the deadstart file retrieved from the deadstart device.

      temp_file_name := '$LOCAL.TEMP_';
      temp_file_name (13, *) := deadstart_file_identifier;
      read_tape_to_file (temp_file_name, fa_p, mca_p, av_p, temp_seq_p, temp_file_id, temp_file_size, status);
      IF NOT status.normal THEN
        EXIT /open_files/;
      IFEND;

      { Open the file that will be used as a scratch working area.

      scratch_file_name := '$LOCAL.SCRATCH_';
      scratch_file_name (13, *) := deadstart_file_identifier;
      fsp$open_file (scratch_file_name, amc$segment, fa_p, NIL, mca_p, av_p, NIL, scratch_file_id, status);
      IF NOT status.normal THEN
        EXIT /open_files/;
      IFEND;
      amp$get_segment_pointer (scratch_file_id, amc$sequence_pointer, scratch_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /open_files/;
      IFEND;
      scratch_seq_p := scratch_segment_pointer.sequence_pointer;
      RESET scratch_seq_p;

      { Open the file that will contain the actual deadstart file.

      fsp$open_file (file_name, amc$record, fa_p, NIL, mca_p, av_p, NIL, file_identifier, status);
      IF NOT status.normal THEN
        EXIT /open_files/;
      IFEND;

      { Move the file from the temp file to the actual file.  Concatenating any broken "bam records".

     /move_the_file/
      WHILE temp_file_size >= #SIZE (bat$record_header) DO

        { Read the "bam header".

        NEXT bam_header_p IN temp_seq_p;
        temp_file_size := temp_file_size - #SIZE (bam_header_p^);
        IF temp_file_size < bam_header_p^.length THEN
          EXIT /move_the_file/;
        IFEND;
        IF bam_header_p^.length <= 0 THEN
          CYCLE /move_the_file/;
        IFEND;

        { Concatenate the broken records if necessary.

        IF bam_header_p^.header_type = bac$start_record THEN
          RESET scratch_seq_p;
          save_length := 0;

         /concatenate_the_line/
          WHILE TRUE DO
            IF bam_header_p^.length > 0 THEN
              NEXT save_line_p: [[REP bam_header_p^.length OF cell]] IN scratch_seq_p;
              RESET save_line_p;
              NEXT data_line_p: [[REP bam_header_p^.length OF cell]] IN temp_seq_p;
              temp_file_size := temp_file_size - #SIZE (data_line_p^);
              RESET data_line_p;
              save_length := save_length + bam_header_p^.length;
              save_line_p^ := data_line_p^;
            IFEND;
            IF bam_header_p^.header_type = bac$end_record THEN
              EXIT /concatenate_the_line/;
            IFEND;
            IF temp_file_size < #SIZE (bam_header_p^) THEN
              EXIT /move_the_file/;
            IFEND;
            NEXT bam_header_p IN temp_seq_p;
            temp_file_size := temp_file_size - #SIZE (bam_header_p^);
          WHILEND /concatenate_the_line/;
          RESET scratch_seq_p;
          NEXT data_line_p: [[REP save_length OF cell]] IN scratch_seq_p;

        ELSE
          NEXT data_line_p: [[REP bam_header_p^.length OF cell]] IN temp_seq_p;
          temp_file_size := temp_file_size - #SIZE (data_line_p^);
        IFEND;

        { Write the record to the actual file.

        RESET data_line_p;
        amp$put_next (file_identifier, data_line_p, #SIZE (data_line_p^), ba, status);
        IF NOT status.normal THEN
          EXIT /move_the_file/;
        IFEND;
      WHILEND /move_the_file/;
    END /open_files/;

    fsp$close_file (temp_file_id, status);
    amp$return (temp_file_name, status);

    fsp$close_file (scratch_file_id, status);
    amp$return (scratch_file_name, status);

    fsp$close_file (file_identifier, status);

  PROCEND process_ssv_file;
?? TITLE := 'read_tape_to_file', EJECT ??

{ PURPOSE:
{   This procedure reads the file from the deadstart device.

  PROCEDURE read_tape_to_file
    (    file_name: ost$name;
         fa_p: ^fst$attachment_options;
         mca_p: ^fst$file_cycle_attributes;
         av_p: ^fst$file_cycle_attributes;
     VAR file_seq_p: ^SEQ ( * );
     VAR file_identifier: amt$file_identifier;
     VAR file_size: integer;
     VAR status: ost$status);

    CONST
      large_amount = 1000000(16);

    VAR
      data_size_read: integer,
      file_data_p: ^SEQ ( * ),
      file_segment_pointer: amt$segment_pointer;

    status.normal := TRUE;

    fsp$open_file (file_name, amc$segment, fa_p, NIL, mca_p, av_p, NIL, file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    amp$get_segment_pointer (file_identifier, amc$sequence_pointer, file_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET file_segment_pointer.sequence_pointer;
    file_seq_p := file_segment_pointer.sequence_pointer;
    file_size := 0;

   /read_file_from_device/
    WHILE TRUE DO
      NEXT file_data_p: [[REP large_amount OF cell]] IN file_segment_pointer.sequence_pointer;
      dsp$read_deadstart_device (large_amount, file_data_p, data_size_read);
      file_size := file_size + data_size_read;
      IF data_size_read < large_amount THEN
        EXIT /read_file_from_device/;
      IFEND;
    WHILEND /read_file_from_device/;

    IF file_size = 0 THEN
      RETURN;
    IFEND;

    RESET file_segment_pointer.sequence_pointer;
    NEXT file_data_p: [[REP file_size OF cell]] IN file_segment_pointer.sequence_pointer;
    amp$set_segment_eoi (file_identifier, file_segment_pointer, status);
    RESET file_seq_p;

  PROCEND read_tape_to_file;
?? TITLE := 'reinitialize_io', EJECT ??

{ PURPOSE:
{   This procedure initializes the io.

  PROCEDURE reinitialize_io;

    VAR
      channel_definition: cmt$data_channel_definition,
      channel_descriptor: cmt$channel_descriptor,
      device: cmt$system_device_types,
      element_descriptor: cmt$element_descriptor,
      physical_identification: cmt$physical_identification,
      status: ost$status;

    IF cmv$system_device_data [cmc$sdt_tape_device].specified THEN
      device := cmc$sdt_tape_device;
    ELSE
      device := cmc$sdt_disk_device;
    IFEND;

    physical_identification.product_identification.product_number := ' ';
    physical_identification.serial_number := ' ';
    cmp$convert_iou_number (cmv$system_device_data [device].iou_number,
          physical_identification.hardware_address.iou, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to initialize IO.', ^status);
    IFEND;

    channel_descriptor.use_logical_identification := TRUE;
    channel_descriptor.iou := physical_identification.hardware_address.iou;
    channel_descriptor.name := cmv$system_device_data [device].channel_name;
    cmp$get_channel_definition (channel_descriptor, channel_definition, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to initialize IO.', ^status);
    IFEND;

    physical_identification.hardware_address.channel.ordinal := channel_definition.ordinal;
    physical_identification.hardware_address.channel_address :=
          cmv$system_device_data [device].equipment_number;
    physical_identification.hardware_address.unit_address :=
          cmv$system_device_data [device].unit_number;
    physical_identification.hardware_address.physical_address_specifier :=
          $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address, cmc$unit_address];
    cmp$get_element_name (physical_identification, element_descriptor, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to initialize IO.', ^status);
    IFEND;

    IF element_descriptor.element_type <> cmc$storage_device_element THEN
      osp$system_error ('Unable to initialize IO.', NIL);
    IFEND;

    dsp$initialize_io (element_descriptor.peripheral_descriptor.element_name, status);
    IF NOT status.normal THEN
      osp$system_error ('Unable to initialize IO.', ^status);
    IFEND;

  PROCEND reinitialize_io;
?? TITLE := 'dsp$process_deadstart_files', EJECT ??

{ PURPOSE:
{   This procedure moves the deadstart files from the deadstart device to local files.

  PROCEDURE [XDCL] dsp$process_deadstart_files
    (    ending_file_identifier: dst$deadstart_file_identifier;
         last_files_processed: boolean);

    VAR
      av_p: ^fst$file_cycle_attributes,
      deadstart_file_identifier: dst$deadstart_file_identifier,
      fa_p: ^fst$attachment_options,
      file_identifier: amt$file_identifier,
      file_name: ost$name,
      file_seq_p: ^SEQ ( * ),
      file_size: integer,
      header_information: dst$header_information,
      mca_p: ^fst$file_cycle_attributes,
      status: ost$status;

    reinitialize_io;

    PUSH fa_p: [1 .. 1];
    fa_p^ [1].selector := fsc$access_and_share_modes;
    fa_p^ [1].access_modes.selector := fsc$specific_access_modes;
    fa_p^ [1].access_modes.value := $fst$file_access_options [fsc$shorten, fsc$append, fsc$modify, fsc$read];
    fa_p^ [1].share_modes.selector := fsc$specific_share_modes;
    fa_p^ [1].share_modes.value := $fst$file_access_options [];
    PUSH mca_p: [1 .. 4];
    mca_p^ [1].selector := fsc$block_type;
    mca_p^ [2].selector := fsc$record_type;
    mca_p^ [3].selector := fsc$ring_attributes;
    mca_p^ [4].selector := fsc$file_contents_and_processor;
    PUSH av_p: [1 .. 4];
    av_p^ [1].selector := fsc$block_type;
    av_p^ [2].selector := fsc$record_type;
    av_p^ [3].selector := fsc$ring_attributes;
    av_p^ [4].selector := fsc$file_contents_and_processor;

   /process_all_files/
    WHILE TRUE DO
      dsp$read_header_labels (deadstart_file_identifier);
      dsp$retrieve_header_information (header_information);
      mca_p^ [1].block_type := header_information.block_type;
      mca_p^ [2].record_type := header_information.record_type;

      IF (header_information.block_type = amc$system_specified) AND
            (header_information.record_type = amc$undefined) THEN
        mca_p^ [4].file_contents := 'OBJECT_LIBRARY';
        mca_p^ [4].file_processor := amc$unknown_processor;
      ELSE
        mca_p^ [4].file_contents := amc$unknown_contents;
        mca_p^ [4].file_processor := amc$unknown_processor;
      IFEND;

      file_name := '$LOCAL.';
      file_name (8, *) := deadstart_file_identifier;

      mca_p^ [3].ring_attributes.r1 := osc$tsrv_ring;
      mca_p^ [3].ring_attributes.r2 := osc$user_ring_2;
      mca_p^ [3].ring_attributes.r3 := osc$user_ring_2;
      av_p^ := mca_p^;

      IF (header_information.block_type = amc$system_specified) AND
            (header_information.record_type = amc$variable) THEN
        process_ssv_file (deadstart_file_identifier, file_name, fa_p, mca_p, av_p, status);
      ELSE
        read_tape_to_file (file_name, fa_p, mca_p, av_p, file_seq_p, file_identifier, file_size, status);
        fsp$close_file (file_identifier, status);
      IFEND;

      IF deadstart_file_identifier = ending_file_identifier THEN
        clp$include_file (file_name, ' ', osc$null_name, status);
        amp$return (file_name, status);
        EXIT /process_all_files/;
      IFEND;
    WHILEND /process_all_files/;

    IF last_files_processed THEN
      dsp$cleanup_deadstart_io (status);
    IFEND;

  PROCEND dsp$process_deadstart_files;
MODEND dsm$process_deadstart_files;
*DECK DECK=DSM$PROCESS_DFT_REQUESTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Process DFT Requests' ??
MODULE dsm$process_dft_requests;

{ PURPOSE:
{   This module contains all of the procedures which make requests to DFT.
{ DESIGN:
{   The majority of the procedures in this module are called to create the request block that is used to make
{   the DFT request.  All of these procedures then call the one procedure that actually makes the DFT request.
{   This procedure issues a monitor request to make the DFT request.
{ NOTES:
{   This module contains many type declarations that can not be easily changed.  These type declarations
{   define a block of data that the DFT PP program expects to find in a particular order.  Caution must be
{   taken when dealing with these type declarations.  If any changes are made to the type declarations, a
{   corresponding change must be made to the DFT PP program.  All changes must be made in a way to preserve
{   backward compatibility.
{
{   *** ALL DFT REQUESTS THAT ACCESS THE CIP DISK MUST:
{          * INTERLOCK THE CHANNEL BEFORE CALLING DFT
{          * SEND THE REQUEST TO THE 170 SIDE WHEN RUNNING DUALSTATE
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmt$device_information
*copyc cmt$element_name
*copyc dmt$ms_logical_device_address
*copyc dse$error_codes
*copyc dst$change_date_time_set
*copyc dst$date_time_information
*copyc dst$deadstart_sector
*copyc dst$device_path
*copyc dst$dft_alert_source
*copyc dst$dft_cpu_selections
*copyc dst$dft_requests
*copyc dst$ds_sector_device_path
*copyc dst$mrt_entry
*copyc dst$rb_issue_dft_request
*copyc dst$resource_name
*copyc dst$vcu_cda_data
*copyc iot$completion_status
*copyc iot$io_function
*copyc osc$multiprocessor_constants
*copyc ost$date_time
*copyc ost$free_running_clock
*copyc ost$hardware_subranges
*copyc ost$pp_size
*copyc ost$processor_id
*copyc ost$status
?? POP ??
*copyc clp$convert_integer_to_string
*copyc cmp$dft_acquire_maintenance
*copyc cmp$dft_release_maintenance
*copyc dsp$allocate_continuous_memory
*copyc dsp$call_dft_through_sda
*copyc dsp$convert_seq_p_to_r_pointer
*copyc dsp$get_ssr_data_r_pointer
*copyc dsp$request_resources
*copyc dsp$retrieve_iou_information
*copyc i#call_monitor
*copyc iop$mass_storage_io
*copyc osp$append_status_parameter
*copyc osp$clear_mainframe_sig_lock
*copyc osp$fatal_system_error
*copyc osp$initialize_signature_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$cycle
*copyc pmp$zero_out_table
*copyc syp$process_deadstart_status
?? EJECT ??
*copyc dsv$cip_path
*copyc dsv$mainframe_type
*copyc mtv$cst0
*copyc osv$mainframe_wired_cb_heap
*copyc osv$170_os_type
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  CONST
    c$cda_cel_name = 'CEL ',
    c$cda_cft_name = 'CFT ',
    c$cda_mrt_name = 'MRT ',
    c$cda_rif_name = 'RIF ',
    c$cda_vcu_name = 'VCU ',

    c$cda_sector_size = (360(8) * 16) DIV 8,
    c$sector_size_for_12_bits_in_16 = 500(8) * 4;

  TYPE
    t$request_destination = (c$os_170_request, c$os_180_request),
    t$sector_for_16_bits_in_16 = RECORD
      sector: ALIGNED [0 MOD 480] PACKED ARRAY [1 .. c$cda_sector_size] OF cell,
    RECEND,
    t$sector_for_12_bits_in_16 = RECORD
      sector: ALIGNED [0 MOD 640]
            PACKED ARRAY [1 .. c$sector_size_for_12_bits_in_16] OF 0 .. 0f(16),
    RECEND;

?? EJECT ??

  VAR

    { The DFT request area sequence pointer is XDCL for debugging purposes.  It is nice to see when a system
    { crashes because of a DFT request.

    dsv$dft_request_area_p: [XDCL] ^SEQ ( * ) := NIL,

    v$dft_request_lock: ost$signature_lock,
    v$dft_request_lock_set: boolean := FALSE;
?? OLDTITLE ??
?? NEWTITLE := 'convert_name_to_cda_name', EJECT ??

{ PURPOSE:
{   This procedure converts a four character name into a CDA name which is in display code.

  PROCEDURE convert_name_to_cda_name
    (    name: dst$resource_name;
     VAR cda_name: dst$dft_cda_name);

    VAR
      display_code_characters: ARRAY [1 .. 4] OF 0 .. 077(8),
      index: 1 .. 4;

    FOR index := 1 TO 4 DO
      IF (name(index) >= '0') AND (name(index) <= '9') THEN
        display_code_characters [index] := $INTEGER (name(index)) - $INTEGER ('0') + 33(8);
      ELSEIF (name(index) >= 'A') AND (name(index) <= 'Z') THEN
        display_code_characters [index] := $INTEGER (name(index)) - $INTEGER ('A') + 01(8);
      ELSEIF (name(index) >= 'a') AND (name(index) <= 'z') THEN
        display_code_characters [index] := $INTEGER (name(index)) - $INTEGER ('a') + 01(8);
      ELSE
        display_code_characters [index] := 0;
      IFEND;
    FOREND;

    cda_name.character_1 := display_code_characters [1];
    cda_name.character_2 := display_code_characters [2];
    cda_name.character_3 := display_code_characters [3];
    cda_name.character_4 := display_code_characters [4];

  PROCEND convert_name_to_cda_name;
?? OLDTITLE ??
?? NEWTITLE := 'interpret_2ap_status', EJECT ??

{ PURPOSE:
{   This procedure converts the 2AP error status returned by DFT to a string and places the result into the
{   result status variable.

  PROCEDURE interpret_2ap_status
    (    request_code: dst$dft_request_codes;
     VAR dft_request_p: ^SEQ( * );
     VAR status: ost$status);

    VAR
      access_cda_sector_p: ^dst$dft_access_cda_sector,
      access_deadstart_sector_p: ^dst$dft_access_deadstart_sector,
      access_mrt_p: ^dst$dft_access_mrt,
      error_text: string (osc$max_string_size),
      integer_string: ost$string,
      request_recognized: boolean,
      retrieve_cda_size_p: ^dst$dft_retrieve_cda_size,
      size: ost$string_size,
      status_from_2ap: dst$dft_2ap_status;

    request_recognized := TRUE;
    RESET dft_request_p;
    CASE request_code OF
    = dsc$dft_access_deadstart_sector =
      NEXT access_deadstart_sector_p IN dft_request_p;
      status_from_2ap := access_deadstart_sector_p^.status_from_2ap;
    = dsc$dft_access_cda_sector =
      NEXT access_cda_sector_p IN dft_request_p;
      status_from_2ap := access_cda_sector_p^.status_from_2ap;
    = dsc$dft_access_mrt =
      NEXT access_mrt_p IN dft_request_p;
      status_from_2ap := access_mrt_p^.status_from_2ap;
    = dsc$dft_retrieve_program_size, dsc$dft_retrieve_cda_data_size =
      NEXT retrieve_cda_size_p IN dft_request_p;
      status_from_2ap := retrieve_cda_size_p^.status_from_2ap;
    ELSE
      request_recognized := FALSE;
    CASEND;

    IF request_recognized THEN
      error_text := 'DFT request for 2ap function ';
      size := 30;
      clp$convert_integer_to_string (status_from_2ap.function_number, 8, TRUE, integer_string, status);
      error_text (size, integer_string.size) := integer_string.value (1, integer_string.size);
      size := size + integer_string.size;
      error_text (size, 25) := ' failed:  error status = ';
      size := size + 25;
      clp$convert_integer_to_string (status_from_2ap.error_status, 8, TRUE, integer_string, status);
      error_text (size, integer_string.size) := integer_string.value (1, integer_string.size);
      size := size + integer_string.size;
      error_text (size, 1) := '.';
    ELSE
      error_text := 'DFT returned an unexpected 2AP status error for request code = ';
      size := 64;
      clp$convert_integer_to_string (request_code, 8, TRUE, integer_string, status);
      error_text (size, integer_string.size) := integer_string.value (1, integer_string.size);
      size := size + integer_string.size;
      error_text (size, 1) := '.';
    IFEND;

    osp$set_status_abnormal (dsc$display_processor_id, dse$dft_error_from_2ap, error_text, status);

  PROCEND interpret_2ap_status;
?? OLDTITLE ??
?? NEWTITLE := 'make_dft_request', EJECT ??

{ PURPOSE:
{   This procedure makes a call to monitor to issue a request to DFT.

  PROCEDURE make_dft_request
    (    destination: t$request_destination;
     VAR dft_request_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      access_deadstart_sector_info_p: ^dst$dft_access_deadstart_sector,
      change_element_state_req_p: ^dst$dft_change_element_state,
      controller_name: cmt$element_name,
      device_information: cmt$device_information,
      dft_request_header_p: ^dst$dft_request_header,
      disk_access_requested: boolean,
      device_path: dst$device_path,
      element_name: cmt$element_name,
      integer_string: ost$string,
      maintenance_acquired: boolean,
      mrt_entry: dst$mrt_entry,
      rb: dst$rb_issue_dft_request,
      size: ost$string_size,
      sp_error_seq_p: ^SEQ ( * ),
      text: string (osc$max_string_size),
      text_length: integer,
      unit_shared_interlock_set: boolean;

    status.normal := TRUE;

    IF NOT v$dft_request_lock_set THEN
      osp$initialize_signature_lock (v$dft_request_lock, status);
      IF NOT status.normal THEN
        osp$system_error (' Error in setting the DFT request interlock.', ^status);
      IFEND;
      v$dft_request_lock_set := TRUE;
    IFEND;

    { Determine whether the request requires disk access.

    RESET dft_request_p;
    NEXT dft_request_header_p IN dft_request_p;
    CASE dsv$mainframe_type OF
    = dsc$mt_962_972_mainframe, dsc$mt_992_mainframe, dsc$mt_2000_mainframe =
      disk_access_requested := FALSE;
    ELSE
      CASE dft_request_header_p^.request_code OF
      = dsc$dft_read_cda_program, dsc$dft_access_cda_sector, dsc$dft_access_deadstart_sector,
            dsc$dft_retrieve_program_size, dsc$dft_retrieve_cda_data_size =
        disk_access_requested := TRUE;
      = dsc$dft_update_hardware_clock, dsc$dft_access_mrt =
        disk_access_requested := (dsv$mainframe_type <> dsc$mt_93x_mainframe);
      ELSE
        disk_access_requested := FALSE;
      CASEND;
    CASEND;

    { Find the path to the CIP device.

    IF NOT dsv$cip_path.cip_path THEN

      { The following boolean must be set before the call to read the MRT because the call to read
      { the MRT subsequently calls this procedure.  A loop will result unless this boolean is set
      { before the call.

      CASE dsv$mainframe_type OF
      = dsc$mt_962_972_mainframe, dsc$mt_992_mainframe, dsc$mt_2000_mainframe =
        dsv$cip_path.cip_path := TRUE;

      ELSE
        dsv$cip_path.cip_path := TRUE;
        dsp$read_mrt_entry (dsc$mrt_id_global_processor, 0, mrt_entry, status);
        IF NOT status.normal THEN
          dsv$cip_path.cip_path := FALSE;
          RETURN;
        IFEND;

        { The CIP device is defined the same on both IOUs.  The IOU number is not used when
        { accessing the CIP device.  It is therefore just set to zero.

        dsv$cip_path.iou_number := 0;
        dsv$cip_path.channel_number := mrt_entry.global_processor.cip_channel;
        dsv$cip_path.unit_number := mrt_entry.global_processor.cip_disk_unit;
        dsv$cip_path.device_type := mrt_entry.global_processor.cip_disk_type;
      CASEND;
    IFEND;

    { Accessing the deadstart sector is performed only on a VE device.  No request should be sent to NOS to
    { access the deadstart sector.  The lock on the call to cmp$set_unit_shared should not be set when
    { accessing the deadstart sector because the lock will be set by device management when an attempt is
    { made to initialize the volume.

    IF disk_access_requested THEN
      IF dft_request_header_p^.request_code <> dsc$dft_access_deadstart_sector THEN
        device_path.iou_number := dsv$cip_path.iou_number;
        device_path.channel_number := dsv$cip_path.channel_number;
        device_path.unit_number := dsv$cip_path.unit_number;
        device_path.device_type := dsv$cip_path.device_type;
        device_path.cip_path := TRUE;
        unit_shared_interlock_set := TRUE;
      ELSE
        RESET dft_request_p;
        NEXT access_deadstart_sector_info_p IN dft_request_p;
        device_path.iou_number := access_deadstart_sector_info_p^.iou_number;
        device_path.channel_number := access_deadstart_sector_info_p^.channel_number;
        device_path.unit_number := access_deadstart_sector_info_p^.unit_number;
        device_path.device_type := access_deadstart_sector_info_p^.device_type;
        device_path.cip_path := ((device_path.iou_number = dsv$cip_path.iou_number) AND
              (device_path.channel_number = dsv$cip_path.channel_number) AND
              (device_path.unit_number = dsv$cip_path.unit_number) AND
              (device_path.device_type = dsv$cip_path.device_type));
        unit_shared_interlock_set := FALSE;
      IFEND;
    IFEND;
    maintenance_acquired := FALSE;

    osp$set_mainframe_sig_lock (v$dft_request_lock);

   /lock_set/
    BEGIN

      { Setup a buffer area in memory for the request to DFT.  This area must be continuous because
      { a PP (DFT) will be reading from or writing into this area.

      RESET dft_request_p;
      IF dsv$dft_request_area_p <> NIL THEN
        FREE dsv$dft_request_area_p IN osv$mainframe_wired_cb_heap^;
      IFEND;
      dsp$allocate_continuous_memory (osv$mainframe_wired_cb_heap, #SIZE (dft_request_p^),
            dsv$dft_request_area_p);
      rb.status.normal := TRUE;
      rb.dft_request_p := dsv$dft_request_area_p;
      RESET rb.dft_request_p;
      rb.dft_request_p^ := dft_request_p^;
      NEXT dft_request_header_p IN rb.dft_request_p;
      dft_request_header_p^.request_status := dsc$dft_rs_no_response;

      { Issue the DFT request.

      IF destination = c$os_170_request THEN
        dsp$call_dft_through_sda (rb.dft_request_p);
      ELSE

        { If the request accesses the disk then maintenance can not be using the disk at the same time.
        { If the disk is not being used then the disk must be reserved.  This does not have to happen
        { when the execution is in the boot.

        IF disk_access_requested THEN
          cmp$dft_acquire_maintenance (device_path, device_information, controller_name,
                element_name, unit_shared_interlock_set, maintenance_acquired, status);
          IF NOT status.normal THEN
            EXIT /lock_set/;
          IFEND;
        IFEND;

        { Call monitor to issue the request to DFT.

        rb.reqcode := syc$rc_issue_dft_request;
        i#call_monitor (#LOC (rb), #SIZE (rb));

        { Clear the shared unit if it was set.

        IF maintenance_acquired THEN
          cmp$dft_release_maintenance (device_information, controller_name, element_name,
                unit_shared_interlock_set, status);
          IF NOT status.normal THEN
            EXIT /lock_set/;
          IFEND;
        IFEND;
      IFEND;

      dft_request_p^ := rb.dft_request_p^;

      { Process the abnormal status and DFT timeout condition.

      IF NOT rb.status.normal THEN
        osp$set_status_abnormal (dsc$display_processor_id, rb.status.condition, '', status);
        EXIT /lock_set/;
      IFEND;

      CASE dft_request_header_p^.request_status OF
      = dsc$dft_rs_no_response =
        text := 'DFT is not responding ';
        size := 23;
        IF disk_access_requested THEN
          IF dft_request_header_p^.request_code <> dsc$dft_access_deadstart_sector THEN
            text (size, 13) := 'on channel = ';
            size := size + 13;
            clp$convert_integer_to_string (dsv$cip_path.channel_number, 10, TRUE, integer_string, status);
            text (size, integer_string.size) := integer_string.value (1, integer_string.size);
          ELSE
            NEXT access_deadstart_sector_info_p IN dft_request_p;
            text (size, 13) := 'on channel = ';
            size := size + 13;
            clp$convert_integer_to_string (access_deadstart_sector_info_p^.channel_number, 10, TRUE,
                  integer_string, status);
            text (size, integer_string.size) := integer_string.value (1, integer_string.size);
            size := size + integer_string.size;
            text (size, 9) := ', unit = ';
            size := size + 9;
            clp$convert_integer_to_string (access_deadstart_sector_info_p^.unit_number, 10, TRUE,
                  integer_string, status);
            text (size, integer_string.size) := integer_string.value (1, integer_string.size);
            size := size + integer_string.size;
            text (size, 1) := '.';
            RESET dft_request_p;
          IFEND;
        IFEND;
        osp$set_status_abnormal (dsc$display_processor_id, dse$dft_not_responding, text, status);
      = dsc$dft_rs_request_complete =
        { No abnormal status, request completed.
      = dsc$dft_rs_request_failed =
        STRINGREP (text, text_length, 'The DFT request, ', dft_request_header_p^.request_code: #(8),
              ', failed.');
        osp$set_status_abnormal (dsc$display_processor_id, dse$dft_request_failed, text (1, text_length),
              status);
      = dsc$dft_rs_invalid_cda_read =
        osp$set_status_abnormal (dsc$display_processor_id, dse$dft_invalid_cda_read,
              'The CDA sector requested to be read contains invalid data.', status);
      = dsc$dft_rs_retry_request =
        osp$set_status_abnormal (dsc$display_processor_id, dse$dft_retry_request,
              'The DFT request failed, but maybe retried.', status);
      = dsc$dft_rs_2ap_error =
        interpret_2ap_status (dft_request_header_p^.request_code, rb.dft_request_p, status);
      = dsc$dft_rs_incorrect_version =
        osp$set_status_abnormal (dsc$display_processor_id, dse$dft_dual_i4_not_supported,
              'DFT buffer structure at incorrect version for dual IOU support.', status);
      = dsc$dft_rs_hw_element_not_found =
        osp$set_status_abnormal (dsc$display_processor_id, dse$dft_hw_element_not_found,
              'DFT request failed, hardware element not found.', status);
      = dsc$dft_rs_hw_element_reserved =
        osp$set_status_abnormal (dsc$display_processor_id, dse$dft_hw_element_reserved,
              'DFT request failed, hardware element reserved.', status);
      = dsc$dft_rs_hw_ele_not_power_up =
        osp$set_status_abnormal (dsc$display_processor_id, dse$dft_hw_element_not_power_up,
              'DFT request failed, hardware element not powered up.', status);
      = dsc$dft_rs_insuff_req_length =
        osp$set_status_abnormal (dsc$display_processor_id, dse$dft_insuff_request_length,
              'DFT request failed, request length insufficient for response.', status);
      = dsc$dft_rs_state_already_exists =
        osp$set_status_abnormal (dsc$display_processor_id, dse$dft_state_already_exists, '', status);
      = dsc$dft_rs_state_not_changed =
        osp$set_status_abnormal (dsc$display_processor_id, dse$dft_state_not_changed, '', status);
      = dsc$dft_rs_state_part_changed =
        osp$set_status_abnormal (dsc$display_processor_id, dse$dft_state_part_changed, '', status);
      = dsc$dft_rs_undefined_mrt_state =
        osp$set_status_abnormal (dsc$display_processor_id, dse$dft_undefined_mrt_state, '', status);
      = dsc$dft_rs_undefined_req_state =
        osp$set_status_abnormal (dsc$display_processor_id, dse$dft_undefined_req_state, '', status);
      = dsc$dft_rs_sp_error =
        IF dft_request_header_p^.request_code = dsc$dft_change_element_state THEN
          sp_error_seq_p := rb.dft_request_p;
          RESET sp_error_seq_p;
          NEXT change_element_state_req_p IN sp_error_seq_p;
          clp$convert_integer_to_string (change_element_state_req_p^.sp_status, 16, TRUE, integer_string,
                status);
        ELSE
          integer_string.value := ' UNKNOWN';
          integer_string.size := 8;
        IFEND;
        osp$set_status_abnormal (dsc$display_processor_id, dse$dft_sp_error,
              integer_string.value (1, integer_string.size), status);
      = dsc$dft_rs_reissue_request =
        osp$set_status_abnormal (dsc$display_processor_id, dse$dft_reissue_request, '', status);
      ELSE
        clp$convert_integer_to_string (dft_request_header_p^.request_status, 16, TRUE, integer_string,
              status);
        osp$set_status_abnormal (dsc$display_processor_id, dse$dft_returned_unknown_status,
              integer_string.value (1, integer_string.size), status);
      CASEND;

    END /lock_set/;

    osp$clear_mainframe_sig_lock (v$dft_request_lock);

  PROCEND make_dft_request;
?? OLDTITLE ??
?? NEWTITLE := 'pack_sector', EJECT ??

{ PURPOSE:
{   This procedure takes data that is in the format of twelve bits of data in a sixteen bit unit and removes
{   the four bits of unused data.  The result is a continuous stream of data.  A PP passes data to the OS
{   from CTI in the unpacked format and this procedure removes the unused bits for the OS.

  PROCEDURE pack_sector
    (    unpacked_sector_p: ^t$sector_for_12_bits_in_16;
     VAR packed_sector_p: ^t$sector_for_12_bits_in_16);

    VAR
      index_1: 1 .. 500(8),
      index_2: 1 .. 3,
      packed_index: 1 .. (c$sector_size_for_12_bits_in_16 + 1),
      unpacked_index: 1 .. (c$sector_size_for_12_bits_in_16 + 1);

    { The unpacked_sector array is an array of half bytes.  For every sixteen bit units the first four bits
    { are zero and the last twelve bits are valid data.  The first four bits are ignored and the last twelve
    { bits of data are placed in the packed_sector array.  The unpacked_index is the index to the
    { unpacked_sector array and the packed_index is the index to the packed_sector array.  The first FOR LOOP
    { divides the arrays into sixteen bit units and the second FOR LOOP is for removing the last twelve bits
    { (three half bytes) of the sixteen bit units.

    unpacked_index := 1;
    packed_index := 1;
    FOR index_1 := 1 TO 500(8) DO
      unpacked_index := unpacked_index + 1;
      FOR index_2 := 1 TO 3 DO
        packed_sector_p^.sector [packed_index] := unpacked_sector_p^.sector [unpacked_index];
        packed_index := packed_index + 1;
        unpacked_index := unpacked_index + 1;
      FOREND;
    FOREND;

  PROCEND pack_sector;
?? OLDTITLE ??
?? NEWTITLE := 'unpack_sector', EJECT ??

{ PURPOSE:
{   This procedure takes a continuous stream of data and places it in the format of twelve bits of data in a
{   sixteen bit unit.  This is the format in which CTI expects data when it is received by a PP.

  PROCEDURE unpack_sector
    (    packed_sector_p: ^t$sector_for_12_bits_in_16;
     VAR unpacked_sector_p: ^t$sector_for_12_bits_in_16);

    VAR
      index_1: 1 .. 500(8),
      index_2: 1 .. 3,
      packed_index: 1 .. (c$sector_size_for_12_bits_in_16 + 1),
      unpacked_index: 1 .. (c$sector_size_for_12_bits_in_16 + 1);

    { The unpacked_sector array is an array of half bytes.  For every sixteen bit unit the first four bits
    { are zero and the last twelve bits are valid data from the packed_sector array.  The first FOR LOOP
    { divides the arrays into sixteen bit units and the second FOR LOOP fills the last twelve bits (three
    { half bytes) of the sixteen bit units.

    unpacked_index := 1;
    packed_index := 1;
    FOR index_1 := 1 TO 500(8) DO
      unpacked_sector_p^.sector [unpacked_index] := 0;
      unpacked_index := unpacked_index + 1;
      FOR index_2 := 1 TO 3 DO
        unpacked_sector_p^.sector [unpacked_index] := packed_sector_p^.sector [packed_index];
        packed_index := packed_index + 1;
        unpacked_index := unpacked_index + 1;
      FOREND;
    FOREND;

  PROCEND unpack_sector;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$access_deadstart_sector', EJECT ??

{ PURPOSE:
{   This procedure reads or writes the deadstart sector from the CIP device using the device path given
{   as a parameter.

  PROCEDURE [XDCL] dsp$access_deadstart_sector
    (    ds_sector_device_path: dst$ds_sector_device_path;
     VAR deadstart_sector_data_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      cda_sector_12_bit_p: ^t$sector_for_12_bits_in_16,
      completion_status_p: ^iot$completion_status,
      deadstart_sector_data_seq_p: ^SEQ ( * ),
      device_address: dmt$ms_logical_device_address,
      dft_request: dst$dft_access_deadstart_sector,
      dft_request_seq_p: ^SEQ ( * ),
      io_function: iot$io_function,
      temp_sector_data_p: ^t$sector_for_12_bits_in_16,
      temp_sector_data_seq_p: ^SEQ ( * );

    status.normal := TRUE;

    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$dft_not_allowed_on_cy2000,
            'DFT request not allowed on a Cyber 2000 mainframe.', status);
      RETURN;
    IFEND;

    pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

    { An area is allocated in mainframe wired to store the deadstart sector.  This area must not cross a page
    { boundary because a PP will be writing data into this area and reading data from this area.  The type
    { declaration of the pointer that is allocated is aligned such that it does not cross a page boundary.

    ALLOCATE temp_sector_data_p IN osv$mainframe_wired_cb_heap^;
    ALLOCATE cda_sector_12_bit_p IN osv$mainframe_wired_cb_heap^;
    pmp$zero_out_table (^temp_sector_data_p^.sector, #SIZE (temp_sector_data_p^.sector));
    pmp$zero_out_table (^cda_sector_12_bit_p^.sector, #SIZE (cda_sector_12_bit_p^.sector));
    temp_sector_data_seq_p := #SEQ (temp_sector_data_p^.sector);
    RESET temp_sector_data_seq_p;

    IF ds_sector_device_path.access_type = dsc$write_ds_sector THEN
      NEXT deadstart_sector_data_seq_p:
            [[REP #SIZE (deadstart_sector_data_p^) OF cell]] IN temp_sector_data_seq_p;
      deadstart_sector_data_seq_p^ := deadstart_sector_data_p^;
      RESET temp_sector_data_seq_p;
      unpack_sector (temp_sector_data_p, cda_sector_12_bit_p);
    IFEND;

    IF ds_sector_device_path.disk_type = dsc$large_sector_disk THEN

      { The disk type is a large sector disk (S0).  These types of disks are read with iop$mass_storage_io
      { instead of by DFT.

      device_address.maus_per_position := ds_sector_device_path.maus_per_cylinder;
      device_address.logical_unit_number := ds_sector_device_path.logical_unit_number;
      device_address.transfer_length := 1;
      device_address.transfer_mau_offset := 0;
      device_address.write_translation := FALSE;

      { CM3/FSD2 deadstart sector location Cylinder 702(10), Track 0, Sector 0.

      device_address.allocation_unit_mau_address := ds_sector_device_path.deadstart_sector_mau;
      IF ds_sector_device_path.access_type = dsc$write_ds_sector THEN
        io_function := ioc$explicit_write;
      ELSE
        io_function := ioc$explicit_read;
      IFEND;
      iop$mass_storage_io (cda_sector_12_bit_p, #SIZE (cda_sector_12_bit_p^.sector),
            io_function, device_address, TRUE, completion_status_p, status);
    ELSE

      { DFT reads all other types of disks.

      dft_request.header.request_code := dsc$dft_access_deadstart_sector;
      dft_request.iou_number := ds_sector_device_path.iou_number;
      dft_request.channel_number := ds_sector_device_path.channel_number;
      dft_request.unit_number := ds_sector_device_path.unit_number;
      dft_request.device_type := ds_sector_device_path.device_type;
      dft_request.write_sector := (ds_sector_device_path.access_type = dsc$write_ds_sector);
      dsp$convert_seq_p_to_r_pointer (#SEQ (cda_sector_12_bit_p^.sector),
            dft_request.deadstart_sector_data_rp);
      dft_request_seq_p := #SEQ (dft_request);
      make_dft_request (c$os_180_request, dft_request_seq_p, status);
    IFEND;
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Error attempting to access deadstart sector', FALSE, status);
      FREE temp_sector_data_p IN osv$mainframe_wired_cb_heap^;
      FREE cda_sector_12_bit_p IN osv$mainframe_wired_cb_heap^;
      RETURN;
    IFEND;

    IF ds_sector_device_path.access_type = dsc$read_ds_sector THEN
      pack_sector (cda_sector_12_bit_p, temp_sector_data_p);
      RESET temp_sector_data_seq_p;
      NEXT deadstart_sector_data_seq_p:
            [[REP #SIZE (deadstart_sector_data_p^) OF cell]] IN temp_sector_data_seq_p;
      deadstart_sector_data_p^ := deadstart_sector_data_seq_p^;
    IFEND;

    FREE temp_sector_data_p IN osv$mainframe_wired_cb_heap^;
    FREE cda_sector_12_bit_p IN osv$mainframe_wired_cb_heap^;

  PROCEND dsp$access_deadstart_sector;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$access_secure_mode', EJECT ??

{ PURPOSE:
{   This procedure activates, deactivates or returns the secure mode.  This request is only valid on a
{   Cyber 2000 Mainframe.

  PROCEDURE [XDCL] dsp$access_secure_mode
    (    access_function: 0 .. 0ff(16);
     VAR mode: 0 .. 0ffff(16);
     VAR status: ost$status);

    VAR
      dft_request: dst$dft_access_secured_mode,
      dft_request_seq_p: ^SEQ ( * );

    status.normal := TRUE;
    IF dsv$mainframe_type <> dsc$mt_2000_mainframe THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$dft_only_allowed_on_cy2000,
            'DFT request is only allowed on a Cyber 2000 mainframe.', status);
      RETURN;
    IFEND;

    { Build the DFT request.

    pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

    dft_request.header.request_code := dsc$dft_access_secured_mode;
    dft_request.access_function := access_function;
    dft_request_seq_p := #SEQ (dft_request);

    { Make the DFT request.

    make_dft_request (c$os_180_request, dft_request_seq_p, status);
    IF status.normal THEN
      mode := dft_request.mode;
    IFEND;

  PROCEND dsp$access_secure_mode;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$access_vcu_cda_data', EJECT ??

{ PURPOSE:
{   This procedure accesses the VCU area of the Common Disk Area (CDA) sector.  This sector contains several
{   pieces of data and this procedure accesses the correct piece.

  PROCEDURE [XDCL] dsp$access_vcu_cda_data
    (    type_of_access: dst$vcu_access_type;
         data_accessed: dst$vcu_data_accessed;
     VAR data_p: ^SEQ ( * );
     VAR status: ost$status);

    TYPE
      t$time_zone_variant = RECORD
        initialized: 0 .. 0ff(16),
        hours_from_gmt: integer,
        minutes_offset: integer,
        daylight_saving: 0 .. 0ff(16),
      RECEND;

    VAR
      bucket_data_p: ^dst$vcu_bucket_data,
      bucket_used_p: ^dst$vcu_bucket_types,
      password_data_p: ^dst$vcu_password_data,
      time_zone_data_p: ^dst$vcu_time_zone_data,
      time_zone_for_variant_p: ^dst$vcu_time_zone_data,
      time_zone_variant: t$time_zone_variant,
      time_zone_variant_seq_p: ^SEQ ( * ),
      vcu_cda_data: dst$vcu_cda_data,
      vcu_cda_data_seq_p: ^SEQ ( * ),
      version_p: ^dst$vcu_cda_version;

    status.normal := TRUE;

    RESET data_p;
    IF type_of_access = dsc$vcu_read_access THEN
      vcu_cda_data_seq_p := #SEQ (vcu_cda_data);
      pmp$zero_out_table (^vcu_cda_data_seq_p^, #SIZE (vcu_cda_data_seq_p^));
      dsp$read_cda_sector (c$cda_vcu_name, vcu_cda_data_seq_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      CASE data_accessed OF
      = dsc$vcu_bucket_data =
        NEXT bucket_data_p IN data_p;
        bucket_data_p^ := vcu_cda_data.bucket_data;
      = dsc$vcu_time_zone_data =
        time_zone_variant_seq_p := #SEQ (time_zone_variant);
        RESET time_zone_variant_seq_p;
        NEXT time_zone_for_variant_p IN time_zone_variant_seq_p;
        time_zone_for_variant_p^ := vcu_cda_data.time_zone_data;
        IF ((time_zone_variant.initialized < 0) OR (time_zone_variant.initialized > 1)) OR
              ((time_zone_variant.hours_from_gmt < -12) OR (time_zone_variant.hours_from_gmt > 12)) OR
              ((time_zone_variant.minutes_offset < -30) OR (time_zone_variant.minutes_offset > 30)) OR
              ((time_zone_variant.daylight_saving < 0) OR (time_zone_variant.daylight_saving > 1)) THEN
          osp$set_status_abnormal (dsc$display_processor_id, dse$read_invalid_time_zone,
                'Unable to obtain valid time zone data from VCU in the common disk area.', status);
          RETURN;
        IFEND;
        NEXT time_zone_data_p IN data_p;
        time_zone_data_p^ := vcu_cda_data.time_zone_data;
      = dsc$vcu_bucket_used =
        NEXT bucket_used_p IN data_p;
        bucket_used_p^ := vcu_cda_data.bucket_used;
      = dsc$vcu_password_data =
        NEXT password_data_p IN data_p;
        password_data_p^ := vcu_cda_data.password_data;
      = dsc$vcu_version =
        NEXT version_p IN data_p;
        version_p^ := vcu_cda_data.version;
      ELSE
      CASEND;

    ELSE { type_of_access = dsc$vcu_write_access }
      vcu_cda_data_seq_p := #SEQ (vcu_cda_data);
      pmp$zero_out_table (^vcu_cda_data_seq_p^, #SIZE (vcu_cda_data_seq_p^));
      dsp$read_cda_sector (c$cda_vcu_name, vcu_cda_data_seq_p, status);

      {  The status of the previous request is not checked here because if the VCU does not exist
      {  the read will fail but it is fine to try and write it.  The assumption is that this only
      {  happens once.  This should be fixed!

      CASE data_accessed OF
      = dsc$vcu_bucket_data =
        NEXT bucket_data_p IN data_p;
        vcu_cda_data.bucket_data := bucket_data_p^;
      = dsc$vcu_time_zone_data =
        time_zone_variant_seq_p := #SEQ (time_zone_variant);
        RESET time_zone_variant_seq_p;
        NEXT time_zone_for_variant_p IN time_zone_variant_seq_p;
        NEXT time_zone_data_p IN data_p;
        time_zone_for_variant_p^ := time_zone_data_p^;
        IF ((time_zone_variant.initialized < 0) OR (time_zone_variant.initialized > 1)) OR
              ((time_zone_variant.hours_from_gmt < -12) OR (time_zone_variant.hours_from_gmt > 12)) OR
              ((time_zone_variant.minutes_offset < -30) OR (time_zone_variant.minutes_offset > 30)) OR
              ((time_zone_variant.daylight_saving < 0) OR (time_zone_variant.daylight_saving > 1)) THEN
          osp$set_status_abnormal (dsc$display_processor_id, dse$write_invalid_time_zone,
                'Unable to store invalid time zone data in VCU in the common disk area.', status);
          RETURN;
        IFEND;
        vcu_cda_data.time_zone_data := time_zone_data_p^;
      = dsc$vcu_bucket_used =
        NEXT bucket_used_p IN data_p;
        vcu_cda_data.bucket_used := bucket_used_p^;
      = dsc$vcu_password_data =
        NEXT password_data_p IN data_p;
        vcu_cda_data.password_data := password_data_p^;
      = dsc$vcu_version =
        NEXT version_p IN data_p;
        vcu_cda_data.version := version_p^;
      ELSE
      CASEND;
      dsp$write_cda_sector (c$cda_vcu_name, vcu_cda_data_seq_p, status);
    IFEND;

  PROCEND dsp$access_vcu_cda_data;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$change_date_time_info', EJECT ??

{ PURPOSE
{   This procedure changes the date time information in the MRT on a Cyber 2000 mainframe.

  PROCEDURE [XDCL] dsp$change_date_time_info
    (    options_set: dst$change_date_time_set;
         date_time_information: dst$date_time_information;
     VAR status: ost$status);

    VAR
      dft_request: dst$dft_change_date_time_info,
      dft_request_seq_p: ^SEQ ( * );

    IF dsv$mainframe_type <> dsc$mt_2000_mainframe THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$dft_only_allowed_on_cy2000,
            'DFT request is only allowed on a Cyber 2000 mainframe.', status);
      RETURN;
    IFEND;

    pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

    dft_request.flags.update_bst := (dsc$cdt_base_system_time IN options_set);
    dft_request.flags.update_time_zone := (dsc$cdt_time_zone IN options_set);
    dft_request.flags.update_default_date_format := (dsc$cdt_default_date_format IN options_set);
    dft_request.flags.update_default_time_format := (dsc$cdt_default_time_format IN options_set);
    dft_request.flags.update_daylight_status := (dsc$cdt_daylight_saving_time IN options_set);

    IF dft_request.flags.update_bst THEN
      dft_request.bst_wcc.years.tens := date_time_information.bst_wcc.year DIV 10;
      dft_request.bst_wcc.years.units := date_time_information.bst_wcc.year MOD 10;
      dft_request.bst_wcc.months.tens := date_time_information.bst_wcc.month DIV 10;
      dft_request.bst_wcc.months.units := date_time_information.bst_wcc.month MOD 10;
      dft_request.bst_wcc.days.tens := date_time_information.bst_wcc.day DIV 10;
      dft_request.bst_wcc.days.units := date_time_information.bst_wcc.day MOD 10;
      dft_request.bst_wcc.hours.tens := date_time_information.bst_wcc.hour DIV 10;
      dft_request.bst_wcc.hours.units := date_time_information.bst_wcc.hour MOD 10;
      dft_request.bst_wcc.minutes.tens := date_time_information.bst_wcc.minute DIV 10;
      dft_request.bst_wcc.minutes.units := date_time_information.bst_wcc.minute MOD 10;
      dft_request.bst_wcc.seconds.tens := date_time_information.bst_wcc.second DIV 10;
      dft_request.bst_wcc.seconds.units := date_time_information.bst_wcc.second MOD 10;
      dft_request.bst_frc := date_time_information.bst_frc;
    IFEND;

    IF dft_request.flags.update_default_date_format THEN
      CASE date_time_information.default_date.date_format OF
      = osc$month_date =
        dft_request.default_date := dsc$dft_df_month;
      = osc$mdy_date =
        dft_request.default_date := dsc$dft_df_mdy;
      = osc$iso_date =
        dft_request.default_date := dsc$dft_df_isod;
      = osc$ordinal_date =
        dft_request.default_date := dsc$dft_df_ordinal;
      ELSE  {= osc$dmy_date =
        dft_request.default_date := dsc$dft_df_dmy;
      CASEND;
    IFEND;

    IF dft_request.flags.update_default_time_format THEN
      CASE date_time_information.default_time.time_format OF
      = osc$ampm_time =
        dft_request.default_time := dsc$dft_tf_ampm;
      = osc$hms_time =
        dft_request.default_time := dsc$dft_tf_hms;
      ELSE  {= osc$millisecond_time =
        IF date_time_information.default_time.format_string = 'ISOT' THEN
          dft_request.default_time := dsc$dft_tf_isot;
        ELSE
          dft_request.default_time := dsc$dft_tf_millisecond;
        IFEND;
      CASEND;
    IFEND;

    IF dft_request.flags.update_time_zone THEN
      IF date_time_information.time_zone.hours_from_gmt < 0 THEN
        dft_request.time_zone_flags.negative_time_zone_hours := TRUE;
        dft_request.time_zone_hours := date_time_information.time_zone.hours_from_gmt * (-1);
      ELSE
        dft_request.time_zone_flags.negative_time_zone_hours := FALSE;
        dft_request.time_zone_hours := date_time_information.time_zone.hours_from_gmt;
      IFEND;

      IF date_time_information.time_zone.minutes_offset < 0 THEN
        dft_request.time_zone_flags.negative_time_zone_minutes := TRUE;
        dft_request.time_zone_minutes := date_time_information.time_zone.minutes_offset * (-1);
      ELSE
        dft_request.time_zone_flags.negative_time_zone_minutes := FALSE;
        dft_request.time_zone_minutes := date_time_information.time_zone.minutes_offset;
      IFEND;
    IFEND;

    IF dft_request.flags.update_daylight_status THEN
      dft_request.time_zone_flags.daylight_saving_time :=
            date_time_information.time_zone.daylight_saving_time;
    IFEND;

    dft_request.header.request_code := dsc$dft_change_date_time_info;
    dft_request_seq_p := #SEQ (dft_request);
    make_dft_request (c$os_180_request, dft_request_seq_p, status);

  PROCEND dsp$change_date_time_info;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$change_monitor_xp', EJECT ??

{ PURPOSE:
{   This procedure makes a request to DFT to change the monitor exchange package pointer.

  PROCEDURE [XDCL] dsp$change_monitor_xp
    (    number: dst$dft_cpu_selections;
         mps: ost$real_memory_address;
     VAR status: ost$status );

    VAR
      dft_request: dst$dft_change_monitor_xp,
      dft_request_seq_p: ^SEQ ( * );

    status.normal := TRUE;

    { Build the DFT request.

    pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

    dft_request.header.request_code := dsc$dft_change_monitor_xp;
    dft_request.number := number;
    dft_request.mps := mps;
    dft_request_seq_p := #SEQ (dft_request);

    { Make the DFT request.

    make_dft_request (c$os_180_request, dft_request_seq_p, status);

  PROCEND dsp$change_monitor_xp;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$change_cy2000_element', EJECT ??

{ PURPOSE:
{   This procedure makes a request to the service processor to change an element in the MRT.

  PROCEDURE [XDCL] dsp$change_cy2000_element
    (    element_id: 0 .. 0ff(16);
         sub_element_id: 0 .. 0ffff(16);
         state: 0 .. 0ff(16);
     VAR status: ost$status);

    TYPE
      t$states = RECORD
        ordinal: 0 .. 0ff(16),
        data: string (40),
        data_size: 0 .. 40,
      RECEND;

    VAR
      dft_request: dst$dft_change_element_state,
      dft_request_seq_p: ^SEQ ( * ),
      index: 1 .. 3,
      states: ARRAY [1 .. 3] OF t$states;

    status.normal := TRUE;
    IF dsv$mainframe_type <> dsc$mt_2000_mainframe THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$dft_only_allowed_on_cy2000,
            'DFT request is only allowed on a Cyber 2000 mainframe.', status);
      RETURN;
    IFEND;

    { Build the DFT request.

    pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

    dft_request.header.request_code := dsc$dft_change_element_state;
    dft_request.element := element_id;
    dft_request.sub_element := sub_element_id;
    dft_request.state := state;
    dft_request_seq_p := #SEQ (dft_request);

    { Make the DFT request.

    make_dft_request (c$os_180_request, dft_request_seq_p, status);
    IF NOT status.normal THEN
      states [1].ordinal := dft_request.state;
      states [2].ordinal := dft_request.before_state;
      states [3].ordinal := dft_request.after_state;
      FOR index := 1 TO 3 DO
        CASE states [index].ordinal OF
        = dsc$dft_state_on =
          states [index].data := 'ON';
          states [index].data_size := 2;
        = dsc$dft_state_off =
          states [index].data := 'OFF';
          states [index].data_size := 3;
        = dsc$dft_state_down_by_system =
          states [index].data := 'DOWN_BY_SYSTEM';
          states [index].data_size := 14;
        = dsc$dft_state_down_by_operator =
          states [index].data := 'DOWN_BY_OPERATOR';
          states [index].data_size := 16;
        = dsc$dft_state_powered_off =
          states [index].data := 'POWERED_OFF';
          states [index].data_size := 11;
        = dsc$dft_state_pow_off_and_off =
          states [index].data := 'POWERED_OFF_AND_OFF';
          states [index].data_size := 19;
        = dsc$dft_state_pow_off_and_down =
          states [index].data := 'POWERED_OFF_AND_DOWN_BY_OPERATOR';
          states [index].data_size := 32;
        = dsc$dft_state_not_installed =
          states [index].data := 'NOT_INSTALLED';
          states [index].data_size := 13;
        ELSE
          states [index].data := 'UNKNOWN';
          states [index].data_size := 7;
        CASEND;
      FOREND;

      IF status.condition = dse$dft_state_not_changed THEN
        osp$append_status_parameter (osc$status_parameter_delimiter,
              states [2].data (1, states [2].data_size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              states [1].data (1, states [1].data_size), status);
      ELSEIF status.condition = dse$dft_state_part_changed THEN
        osp$append_status_parameter (osc$status_parameter_delimiter,
              states [3].data (1, states [3].data_size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              states [1].data (1, states [1].data_size), status);
      IFEND;
    IFEND;

  PROCEND dsp$change_cy2000_element;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$dft_issue_system_alert', EJECT ??

{ PURPOSE:
{   This procedure issues a system alert to the service processor DFT.

  PROCEDURE [XDCL, #GATE] dsp$dft_issue_system_alert
    (    alert_source: dst$dft_alert_source;
         supportive_information_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      dft_request_entry_p: ^SEQ ( * ),
      dft_request_p: ^dst$dft_system_state_alert,
      dft_request_seq_p: ^SEQ ( * );

    status.normal := TRUE;
    IF dsv$mainframe_type <> dsc$mt_2000_mainframe THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$dft_only_allowed_on_cy2000,
            'DFT request is only allowed on a Cyber 2000 mainframe.', status);
      RETURN;
    IFEND;

    dsp$allocate_continuous_memory (osv$mainframe_wired_cb_heap,
          (#SIZE (dst$dft_system_state_alert) + #SIZE (supportive_information_p^)), dft_request_seq_p);
    RESET dft_request_seq_p;
    pmp$zero_out_table (^dft_request_seq_p^, #SIZE (dft_request_seq_p^));
    NEXT dft_request_p IN dft_request_seq_p;
    dft_request_p^.header.request_code := dsc$dft_system_state_alert;
    dft_request_p^.flags.hpa_ve_alert := (alert_source = dsc$dft_as_hpa_ve);
    dft_request_p^.supportive_information_length := #SIZE (supportive_information_p^) DIV 8;
    NEXT dft_request_entry_p: [[REP #SIZE (supportive_information_p^) OF cell]] IN dft_request_seq_p;
    RESET dft_request_entry_p;
    dft_request_entry_p^ := supportive_information_p^;
    RESET dft_request_seq_p;

    make_dft_request (c$os_180_request, dft_request_seq_p, status);
    FREE dft_request_seq_p IN osv$mainframe_wired_cb_heap^;

  PROCEND dsp$dft_issue_system_alert;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$get_cy2000_element', EJECT ??

{ PURPOSE:
{   This procedure makes a request to the service processor to read an element from the MRT.

  PROCEDURE [XDCL] dsp$get_cy2000_element
    (    element_id: 0 .. 0ff(16);
         sub_element_id: 0 .. 0ffff(16);
     VAR entry_p: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      dft_entry_p: ^SEQ ( * ),
      dft_request_p: ^dst$dft_get_element_header,
      dft_request_seq_p: ^SEQ ( * );

    status.normal := TRUE;
    IF dsv$mainframe_type <> dsc$mt_2000_mainframe THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$dft_only_allowed_on_cy2000,
            'DFT request is only allowed on a Cyber 2000 mainframe.', status);
      RETURN;
    IFEND;

    { Build the DFT request.

    dsp$allocate_continuous_memory (osv$mainframe_wired_cb_heap,
          (#SIZE (dst$dft_get_element_header) + #SIZE (entry_p^)), dft_request_seq_p);
    RESET dft_request_seq_p;
    pmp$zero_out_table (^dft_request_seq_p^, #SIZE (dft_request_seq_p^));

    NEXT dft_request_p IN dft_request_seq_p;
    dft_request_p^.header.request_code := dsc$dft_get_element_description;
    dft_request_p^.element := element_id;
    dft_request_p^.sub_element := sub_element_id;
    dft_request_p^.length := #SIZE (entry_p^) DIV 8;
    RESET dft_request_seq_p;

    { Make the DFT request.

    make_dft_request (c$os_180_request, dft_request_seq_p, status);
    IF status.normal THEN
      RESET dft_request_seq_p;
      NEXT dft_request_p IN dft_request_seq_p;
      NEXT dft_entry_p: [[REP #SIZE (entry_p^) OF cell]] IN dft_request_seq_p;
      RESET dft_entry_p;
      entry_p^ := dft_entry_p^;
    IFEND;

    FREE dft_request_seq_p IN osv$mainframe_wired_cb_heap^;

  PROCEND dsp$get_cy2000_element;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$get_iou_status_register', EJECT ??

{ PURPOSE:
{   This procedure makes a request to DFT to get the IOU status register (register 40(16)).

  PROCEDURE [XDCL] dsp$get_iou_status_register
    (    iou_number: dst$iou_number;
     VAR iou_status_register: integer;
     VAR status: ost$status);

    VAR
      dft_request: dst$dft_get_iou_status_register,
      dft_request_seq_p: ^SEQ ( * );

    status.normal := TRUE;

    { Build the DFT request.

    pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

    dft_request.header.request_code := dsc$dft_get_iou_status_register;
    dft_request.iou_number := iou_number;
    dft_request_seq_p := #SEQ (dft_request);

    { Make the DFT request.

    make_dft_request (c$os_180_request, dft_request_seq_p, status);
    IF status.normal THEN
      iou_status_register := dft_request.iou_status_register;
    IFEND;

  PROCEND dsp$get_iou_status_register;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$load_additional_dft', EJECT ??

{ PURPOSE:
{   If running on a machine with two IOU's, the procedure sets up the secondary DFT buffer and
{   issues a request to DFT to start up DFT in the secondary IOU.

  PROCEDURE [XDCL] dsp$load_additional_dft
    (VAR status: ost$status);

    VAR
      dft_request: dst$dft_load_additional_dft,
      dft_request_seq_p: ^SEQ ( * ),
      iou_information_table: dst$iou_information_table,
      iou1_index: dst$number_of_ious,
      number_of_ious: dst$number_of_ious,
      request: dst$resource_request,
      retry_count: 1 .. 6;

    status.normal := TRUE;

    { Cyber 2000 mainframes do not use a secondary DFT.  Do not return an error.

    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      RETURN;
    IFEND;

    { Check for number of IOU's on the system.  Subsequent code will be executed only for a Dual IOU system.

    dsp$retrieve_iou_information (number_of_ious, iou_information_table);
    IF number_of_ious = 1 THEN
      RETURN;
    IFEND;

    pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

    { Find the iou_information_table index for iou1 information.

    iou1_index := LOWERVALUE (dst$number_of_ious);
    WHILE iou_information_table [iou1_index].physical_iou_number <> 1 DO
      IF iou1_index = dsc$max_number_of_ious THEN
        osp$system_error ('Secondary IOU not found in iou_information_table.', NIL);
      ELSE
        iou1_index := iou1_index + 1;
      IFEND;
    WHILEND;

    { Find a pp for the secondary DFT (DFTs).

    request.resource_request_type := dsc$rrt_get_pp;
    request.channel.number := 2;
    request.channel.iou_number := 1;
    CASE iou_information_table [iou1_index].model_type OF
    = dsc$imn_i4_44_model =
      request.channel.channel_protocol := dsc$cpt_cio;
    ELSE
      request.channel.channel_protocol := dsc$cpt_nio;
    CASEND;
    request.options := $dst$resource_request_options [ ];
    dsp$request_resources (request, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Build the DFT request.

    dft_request.header.request_code := dsc$dft_load_additional_dft;
    dft_request.pp := request.primary_pp;
    dft_request_seq_p := #SEQ (dft_request);

    { Make the DFT request.

    retry_count := 1;
    REPEAT
      make_dft_request (c$os_180_request, dft_request_seq_p, status);
      retry_count := retry_count + 1;
    UNTIL status.normal OR (retry_count > 5) OR
          ((NOT status.normal) AND (status.condition <> dse$dft_retry_request));

  PROCEND dsp$load_additional_dft;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$manage_virtual_cpu', EJECT ??

{ PURPOSE:
{   This procedure makes a request to DFT to halt the cpu.

  PROCEDURE [XDCL] dsp$manage_virtual_cpu
    (    number: ost$processor_id);

    VAR
      dft_request: dst$dft_manage_virtual_cpu,
      dft_request_seq_p: ^SEQ ( * ),
      local_status: ost$status;

    { Build the DFT request.

    pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

    dft_request.header.request_code := dsc$dft_manage_virtual_cpu;
    dft_request.number := number;
    dft_request.action := 1;
    dft_request_seq_p := #SEQ (dft_request);

    { Make the DFT request.  If DFT is not responding then halt the system since the state of the CPU
    { is unknown.  Otherwise, DFT has at least shut down the memory port and the CPU as far as we are
    { concerned is "down".  Problems may occur when an attempt is made to on the CPU but they will be
    { addressed when the attempt is made.

    make_dft_request (c$os_180_request, dft_request_seq_p, local_status);
    IF NOT local_status.normal AND (local_status.condition = dse$dft_not_responding) THEN
      osp$fatal_system_error ('DFT not responding when attempting to halt a CPU.', ^local_status);
    IFEND;

  PROCEND dsp$manage_virtual_cpu;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$process_pp_function', EJECT ??

{ PURPOSE:
{   This procedure makes a request to DFT to process a PP function.

  PROCEDURE [XDCL] dsp$process_pp_function
    (    subfunction: dst$dft_puf_subfunctions;
         pp: dst$iou_resource;
         resume_address: dst$dft_resume_address;
         pp_length: ost$pp_byte_size;
     VAR pp_data_seq_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      dft_request: dst$dft_process_pp_function,
      dft_request_seq_p: ^SEQ ( * );

    status.normal := TRUE;

    { Build the DFT request.

    pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

    dft_request.header.request_code := dsc$dft_process_pp_function;
    dft_request.subfunction := subfunction;
    dft_request.pp := pp;
    dft_request.resume_address := resume_address;
    IF pp_data_seq_p <> NIL THEN
      dsp$convert_seq_p_to_r_pointer (pp_data_seq_p, dft_request.pp_image_rp);
      dft_request.pp_image_rp.length := (pp_length + 7) DIV 8;
    IFEND;
    dft_request_seq_p := #SEQ (dft_request);

    { Make the DFT request.

    make_dft_request (c$os_180_request, dft_request_seq_p, status);

  PROCEND dsp$process_pp_function;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$read_cda_program', EJECT ??

{ PURPOSE:
{   This procedure makes a request to DFT to read a CDA program into the area specified as a parameter.

  PROCEDURE [XDCL] dsp$read_cda_program
    (    name: dst$resource_name;
     VAR program_data_p: ^SEQ ( * );
     VAR length: integer;
     VAR status: ost$status);

    VAR
      destination: t$request_destination,
      dft_request: dst$dft_read_cda_program,
      dft_request_seq_p: ^SEQ ( * ),
      first_word_address: integer,
      last_word_address: integer,
      r_pointer: dst$r_pointer;

    status.normal := TRUE;

    { Build the DFT request.

    pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

    IF osv$170_os_type = osc$ot7_none THEN
      destination := c$os_180_request;
    ELSE
      destination := c$os_170_request;
    IFEND;
    dft_request.header.request_code := dsc$dft_read_cda_program;
    dsp$convert_seq_p_to_r_pointer (program_data_p, r_pointer);
    dft_request.program_rp.offset := r_pointer.offset;
    dft_request.program_rp.rlower := r_pointer.rlower;
    dft_request.program_rp.rupper := r_pointer.rupper;
    convert_name_to_cda_name (name, dft_request.name);
    dft_request_seq_p := #SEQ (dft_request);

    { Make the DFT request.

    make_dft_request (destination, dft_request_seq_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Find the length of the CIP program.

    i#real_memory_address (program_data_p, first_word_address);
    last_word_address := ((dft_request.last_word_rp.rupper * 10000(8)) +
          (dft_request.last_word_rp.rlower MOD 10000(8))) * 100(8);
    last_word_address := (last_word_address + dft_request.last_word_rp.offset) * 8;
    length := last_word_address - first_word_address;

  PROCEND dsp$read_cda_program;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$read_cda_sector', EJECT ??

{ PURPOSE:
{   This procedure makes a request to DFT to read a sector from the common disk area.

  PROCEDURE [XDCL] dsp$read_cda_sector
    (    name: dst$resource_name;
     VAR sector_data_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      cda_data_seq_p: ^SEQ ( * ),
      cda_data_size: integer,
      cda_sector_data_p: ^SEQ ( * ),
      cda_sector_12_bit_p: ^t$sector_for_12_bits_in_16,
      destination: t$request_destination,
      dft_request: dst$dft_access_cda_sector,
      dft_request_seq_p: ^SEQ ( * ),
      temp_sector_data_p: ^t$sector_for_12_bits_in_16,
      temp_sector_data_seq_p: ^SEQ ( * );

    status.normal := TRUE;

    { An area is allocated in mainframe wired to store the cda sector.  This area
    { must not cross a page boundary because a PP is writing data to this area.

    dsp$retrieve_cda_data_size (name, cda_data_size, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dsp$allocate_continuous_memory (osv$mainframe_wired_cb_heap, cda_data_size, cda_data_seq_p);
    RESET cda_data_seq_p;
    pmp$zero_out_table (^cda_data_seq_p^, cda_data_size);

   /request_cda_size/
    BEGIN

      { Build the DFT request.

      pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

      IF osv$170_os_type = osc$ot7_none THEN
        destination := c$os_180_request;
      ELSE
        destination := c$os_170_request;
      IFEND;
      dft_request.header.request_code := dsc$dft_access_cda_sector;
      convert_name_to_cda_name (name, dft_request.name);
      dft_request.cda_information.valid_data := FALSE;
      dft_request.cda_information.sixteen_bits := (name <> c$cda_cel_name);
      dft_request.cda_information.partial_read := FALSE;
      dft_request.cda_information.write_data := FALSE;
      dft_request.cda_information.cel_sector := (name = c$cda_cel_name);
      dsp$convert_seq_p_to_r_pointer (cda_data_seq_p, dft_request.cda_sector_data_rp);
      dft_request_seq_p := #SEQ (dft_request);

      { Make the DFT request.

      make_dft_request (destination, dft_request_seq_p, status);
      IF NOT status.normal THEN
        EXIT /request_cda_size/;
      IFEND;

      { Move the data from where DFT wrote the data to the callers sequence.

     /move_data/
      BEGIN
        IF name = c$cda_cel_name THEN
          ALLOCATE temp_sector_data_p IN osv$mainframe_wired_cb_heap^;
          IF #SIZE (sector_data_p^) > #SIZE (temp_sector_data_p^.sector) THEN
            osp$set_status_abnormal (dsc$display_processor_id, dse$cda_too_large,
                  'The CDA data is too large for the callers sequence area.', status);
            EXIT /move_data/;
          IFEND;
          pmp$zero_out_table (^temp_sector_data_p^.sector, #SIZE (temp_sector_data_p^.sector));
          temp_sector_data_seq_p := #SEQ (temp_sector_data_p^.sector);
          RESET temp_sector_data_seq_p;
          RESET cda_data_seq_p;
          IF #SIZE (cda_sector_12_bit_p^) > #SIZE (cda_data_seq_p^) THEN
            osp$set_status_abnormal (dsc$display_processor_id, dse$cda_too_large,
                  'The CDA data is too large for the callers sequence area.', status);
            EXIT /move_data/;
          IFEND;
          NEXT cda_sector_12_bit_p IN cda_data_seq_p;
          pack_sector (cda_sector_12_bit_p, temp_sector_data_p);
          RESET temp_sector_data_seq_p;
          NEXT cda_sector_data_p: [[REP #SIZE (sector_data_p^) OF cell]] IN temp_sector_data_seq_p;
          sector_data_p^ := cda_sector_data_p^;
        ELSE
          RESET cda_data_seq_p;
          IF #SIZE (sector_data_p^) > #SIZE (cda_data_seq_p^) THEN
            osp$set_status_abnormal (dsc$display_processor_id, dse$cda_too_large,
                  'The CDA data is too large for the callers sequence area.', status);
            EXIT /move_data/;
          IFEND;
          NEXT cda_sector_data_p: [[REP #SIZE (sector_data_p^) OF cell]] IN cda_data_seq_p;
          sector_data_p^ := cda_sector_data_p^;
        IFEND;
      END /move_data/;

      IF name = c$cda_cel_name THEN
        FREE temp_sector_data_p IN osv$mainframe_wired_cb_heap^;
      IFEND;
    END /request_cda_size/;
    FREE cda_data_seq_p IN osv$mainframe_wired_cb_heap^;

  PROCEND dsp$read_cda_sector;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$read_date_time_information', EJECT ??

{ PURPOSE
{   This procedure reads the date time information from the MRT on a Cyber 2000 mainframe.

  PROCEDURE [XDCL] dsp$read_date_time_information
    (VAR date_time_information: dst$date_time_information;
     VAR status: ost$status);

    VAR
      dft_request: dst$dft_read_date_time_info,
      dft_request_seq_p: ^SEQ ( * );

    status.normal := TRUE;
    IF dsv$mainframe_type <> dsc$mt_2000_mainframe THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$dft_only_allowed_on_cy2000,
            'DFT request is only allowed on a Cyber 2000 mainframe.', status);
      RETURN;
    IFEND;

    pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

    dft_request.header.request_code := dsc$dft_read_date_time_info;
    dft_request_seq_p := #SEQ (dft_request);
    make_dft_request (c$os_180_request, dft_request_seq_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    date_time_information.bst_wcc.millisecond := 0;
    date_time_information.bst_wcc.second := dft_request.bst_wcc.seconds.units +
          dft_request.bst_wcc.seconds.tens * 10;
    date_time_information.bst_wcc.minute := dft_request.bst_wcc.minutes.units +
          dft_request.bst_wcc.minutes.tens * 10;
    date_time_information.bst_wcc.hour := dft_request.bst_wcc.hours.units +
          dft_request.bst_wcc.hours.tens * 10;

    date_time_information.bst_wcc.day := dft_request.bst_wcc.days.units +
          dft_request.bst_wcc.days.tens * 10;
    date_time_information.bst_wcc.month := dft_request.bst_wcc.months.units +
          dft_request.bst_wcc.months.tens * 10;
    date_time_information.bst_wcc.year := dft_request.bst_wcc.years.units +
          dft_request.bst_wcc.years.tens * 10;
    date_time_information.bst_frc := dft_request.bst_frc;

    CASE dft_request.default_date OF
    = dsc$dft_df_month =
      date_time_information.default_date.date_format := osc$month_date;
      date_time_information.default_date.format_string := 'MN D2, Y4';
    = dsc$dft_df_mdy =
      date_time_information.default_date.date_format := osc$mdy_date;
      date_time_information.default_date.format_string := 'M2/D2/Y2';
    = dsc$dft_df_isod =
      date_time_information.default_date.date_format := osc$iso_date;
      date_time_information.default_date.format_string := 'Y4-M2-D2';
    = dsc$dft_df_ordinal =
      date_time_information.default_date.date_format := osc$ordinal_date;
      date_time_information.default_date.format_string := 'Y4J3';
    = dsc$dft_df_dmy =
      date_time_information.default_date.date_format := osc$dmy_date;
      date_time_information.default_date.format_string := 'D2.M2.Y2';
    ELSE  {= dsc$dft_df_default =
      date_time_information.default_date.date_format := osc$iso_date;
      date_time_information.default_date.format_string := 'Y4-M2-D2';
    CASEND;

    CASE dft_request.default_time OF
    = dsc$dft_tf_ampm =
      date_time_information.default_time.time_format := osc$ampm_time;
      date_time_information.default_time.format_string := 'H12:MM AMORPM';
    = dsc$dft_tf_hms =
      date_time_information.default_time.time_format := osc$hms_time;
      date_time_information.default_time.format_string := 'H24:MM:SS';
    = dsc$dft_tf_millisecond =
      date_time_information.default_time.time_format := osc$millisecond_time;
      date_time_information.default_time.format_string := 'H24:MM:SS.S1000';
    = dsc$dft_tf_isot =
      date_time_information.default_time.time_format := osc$millisecond_time;
      date_time_information.default_time.format_string := 'ISOT';
    ELSE  {= dsc$dft_tf_default =
      date_time_information.default_time.time_format := osc$hms_time;
      date_time_information.default_time.format_string := 'HMS';
    CASEND;

    IF dft_request.time_zone_flags.negative_time_zone_hours THEN
      date_time_information.time_zone.hours_from_gmt := dft_request.time_zone_hours * (-1);
    ELSE
      date_time_information.time_zone.hours_from_gmt := dft_request.time_zone_hours;
    IFEND;

    IF dft_request.time_zone_flags.negative_time_zone_minutes THEN
      date_time_information.time_zone.minutes_offset := dft_request.time_zone_minutes * (-1);
    ELSE
      date_time_information.time_zone.minutes_offset := dft_request.time_zone_minutes;
    IFEND;

    date_time_information.time_zone.daylight_saving_time := dft_request.time_zone_flags.daylight_saving_time;

  PROCEND dsp$read_date_time_information;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$read_mrt_entry', EJECT ??

{ PURPOSE:
{   This procedure makes a request to DFT to read an entry from the MRT.

  PROCEDURE [XDCL] dsp$read_mrt_entry
    (    mrt_entry_id: dst$mrt_entry_id;
         mrt_element_number: dst$mrt_element_number;
     VAR mrt_entry: dst$mrt_entry;
     VAR status: ost$status);

    VAR
      destination: t$request_destination,
      dft_request: dst$dft_access_mrt,
      dft_request_seq_p: ^SEQ ( * ),
      mrt_entry_p: ^dst$mrt_entry,
      mrt_entry_seq_p: ^SEQ ( * );

    status.normal := TRUE;

    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$dft_not_allowed_on_cy2000,
            'DFT request not allowed on a Cyber 2000 mainframe.', status);
      RETURN;
    IFEND;

    { Build the DFT request.

    pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

    dft_request.header.request_code := dsc$dft_access_mrt;
    dft_request.read_mrt := 1;
    dft_request.number := mrt_element_number;
    dft_request.entry_id := $INTEGER(mrt_entry_id);
    dsp$allocate_continuous_memory (osv$mainframe_wired_cb_heap, #SIZE (dst$mrt_entry), mrt_entry_seq_p);
    RESET mrt_entry_seq_p;
    dsp$convert_seq_p_to_r_pointer (mrt_entry_seq_p, dft_request.mrt_entry_rp);
    dft_request_seq_p := #SEQ (dft_request);

    { Make the DFT request.

    IF osv$170_os_type = osc$ot7_none THEN
      destination := c$os_180_request;
    ELSE
      destination := c$os_170_request;
    IFEND;

    make_dft_request (destination, dft_request_seq_p, status);
    IF status.normal THEN
      RESET mrt_entry_seq_p;
      NEXT mrt_entry_p IN mrt_entry_seq_p;
      mrt_entry := mrt_entry_p^;
    IFEND;
    FREE mrt_entry_seq_p IN osv$mainframe_wired_cb_heap^;

  PROCEND dsp$read_mrt_entry;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$retrieve_cda_data_size', EJECT ??

{ PURPOSE:
{   This procedure makes a request to DFT to obtain the size of a particular CDA data.

  PROCEDURE [XDCL] dsp$retrieve_cda_data_size
    (    name: dst$resource_name;
     VAR cda_data_size: integer;
     VAR status: ost$status);

    VAR
      destination: t$request_destination,
      dft_request: dst$dft_retrieve_cda_size,
      dft_request_seq_p: ^SEQ ( * );

    status.normal := TRUE;

    { Build the DFT request.

    pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

    IF osv$170_os_type = osc$ot7_none THEN
      destination := c$os_180_request;
    ELSE
      destination := c$os_170_request;
    IFEND;
    IF (name = c$cda_vcu_name) OR (name = c$cda_cel_name) OR (name = c$cda_cft_name) OR
          (name = c$cda_mrt_name) OR (name = c$cda_rif_name) THEN
      dft_request.header.request_code := dsc$dft_retrieve_cda_data_size;
    ELSE
      dft_request.header.request_code := dsc$dft_retrieve_program_size;
    IFEND;
    convert_name_to_cda_name (name, dft_request.name);
    dft_request.cda_data_size := 0;
    dft_request_seq_p := #SEQ (dft_request);

    { Make the DFT request.

    make_dft_request (destination, dft_request_seq_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF dft_request.cda_data_size <= 0 THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$no_cda_data,
            'The CDA data size is zero.', status);
    ELSE
      cda_data_size := (dft_request.cda_data_size * 8);
    IFEND;

  PROCEND dsp$retrieve_cda_data_size;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$start_additional_cpu', EJECT ??

{ PURPOSE:
{   This procedure makes a request to DFT to start a CPU.

  PROCEDURE [XDCL] dsp$start_additional_cpu
    (    number: 0 .. (osc$max_number_of_processors - 1));

    VAR
      dft_request: dst$dft_start_additional_cpu,
      dft_request_seq_p: ^SEQ ( * ),
      local_status: ost$status;

    { Build the DFT request.

    pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

    dft_request.header.request_code := dsc$dft_start_additional_cpu;
    dft_request.number := number;
    dft_request.mps := mtv$cst0 [number].monitor_mps;
    dsp$get_ssr_data_r_pointer (dsc$ssr_initial_cpu_registers, dft_request.registers_rp);
    dft_request_seq_p := #SEQ (dft_request);

    { Make the DFT request.  If DFT is not responding then halt the system since the state of the CPU
    { is unknown.  Otherwise, the other CPU will notice if the started CPU is not running and down the
    { CPU because handshaking did not occur.

    make_dft_request (c$os_180_request, dft_request_seq_p, local_status);
    IF NOT local_status.normal AND (local_status.condition = dse$dft_not_responding) THEN
      osp$fatal_system_error ('DFT not responding when attempting to start a CPU.', ^local_status);
    IFEND;

  PROCEND dsp$start_additional_cpu;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$update_hardware_date_time', EJECT ??

{ PURPOSE:
{   This procedure updates the hardware date and time in the Hardware Descriptor Table (HDT) and the Wall
{   Clock Chip in all IOUs except I2s where it updates the CIP disk.
{ DESIGN:
{   A request to DFT is used to do the update of the date and time.  This update is done only in
{   standalone mode.

  PROCEDURE [XDCL] dsp$update_hardware_date_time
    (    clock: ost$free_running_clock;
         date_time: ost$date_time;
     VAR status: ost$status );

    CONST
      halfword = 100000000(16),
      parcel = 10000(16);

    VAR
      dft_request: dst$dft_update_hardware_clock,
      dft_request_seq_p: ^SEQ ( * );

    status.normal := TRUE;

    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$dft_not_allowed_on_cy2000,
            'DFT request not allowed on a Cyber 2000 mainframe.', status);
      RETURN;
    IFEND;

    IF osv$170_os_type <> osc$ot7_none THEN
      RETURN;
    IFEND;

    { Build the DFT request.

    pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

    dft_request.header.request_code := dsc$dft_update_hardware_clock;
    dft_request.year := (date_time.year DIV 10)*16 + date_time.year MOD 10;
    dft_request.month := (date_time.month DIV 10)*16 + date_time.month MOD 10;
    dft_request.day := (date_time.day DIV 10)*16 + date_time.day MOD 10;
    dft_request.hour := (date_time.hour DIV 10)*16 + date_time.hour MOD 10;
    dft_request.minute := (date_time.minute DIV 10)*16 + date_time.minute MOD 10;
    dft_request.free_running_clock_1 := 0;
    dft_request.free_running_clock_2 := clock DIV halfword;
    dft_request.free_running_clock_3 := (clock MOD halfword) DIV parcel;
    dft_request.free_running_clock_4 := clock MOD parcel;
    dft_request_seq_p := #SEQ (dft_request);

    { Make the DFT request.

    make_dft_request (c$os_180_request, dft_request_seq_p, status);

  PROCEND dsp$update_hardware_date_time;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$write_cda_sector', EJECT ??

{ PURPOSE:
{   This procedure makes a request to DFT to write a sector to the common disk area.

  PROCEDURE [XDCL] dsp$write_cda_sector
    (    name: dst$resource_name;
     VAR sector_data_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      adjusted_size_of_sector_data: 0 .. c$cda_sector_size,
      cda_sector_data_p: ^SEQ ( * ),
      cda_sector_16_bit_p: ^t$sector_for_16_bits_in_16,
      cda_sector_16_bit_seq_p: ^SEQ ( * ),
      cda_sector_12_bit_p: ^t$sector_for_12_bits_in_16,
      destination: t$request_destination,
      dft_request: dst$dft_access_cda_sector,
      dft_request_seq_p: ^SEQ ( * ),
      extra_bit_count: 0 .. c$cda_sector_size,
      sector_data_bit_count: 0 .. c$cda_sector_size,
      temp_sector_data_p: ^t$sector_for_12_bits_in_16,
      temp_sector_data_seq_p: ^SEQ ( * );

    status.normal := TRUE;

    pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

    { Check that the callers sequence is not larger then a cda sector.  The size of the sector data has been
    { adjusted to be a byte boundary so that it will divide evenly by two and no data will be lost when DFT
    { reads the data.

    RESET sector_data_p;
    adjusted_size_of_sector_data := ((#SIZE (sector_data_p^) + 7) DIV 8) * 8;
    IF adjusted_size_of_sector_data > c$cda_sector_size THEN
      osp$system_error (' Data too large to write into CDA sector', NIL);
    IFEND;

    { Allocate space in mainframe wired to store the CDA data.  This area must not cross a page boundary
    { because DFT is reading data from this area and does not understand the concept of paging.

    IF name = c$cda_cel_name THEN

      { This is a special sector.  The data is stored in a data structure that contains twelve bits of data
      { in a sixteen bit unit with the upper four bits zero.  This data structure will actually exceed a
      { sector size because only the twelve bit quantities actually make up the sector.

      ALLOCATE temp_sector_data_p IN osv$mainframe_wired_cb_heap^;
      ALLOCATE cda_sector_12_bit_p IN osv$mainframe_wired_cb_heap^;
      pmp$zero_out_table (^temp_sector_data_p^.sector, #SIZE (temp_sector_data_p^.sector));
      pmp$zero_out_table (^cda_sector_12_bit_p^.sector, #SIZE (cda_sector_12_bit_p^.sector));
      temp_sector_data_seq_p := #SEQ (temp_sector_data_p^.sector);
      RESET temp_sector_data_seq_p;
      NEXT cda_sector_data_p: [[REP #SIZE (sector_data_p^) OF cell]] IN temp_sector_data_seq_p;
      cda_sector_data_p^ := sector_data_p^;
      RESET temp_sector_data_seq_p;
      unpack_sector (temp_sector_data_p, cda_sector_12_bit_p);
      dsp$convert_seq_p_to_r_pointer (#SEQ (cda_sector_12_bit_p^.sector), dft_request.cda_sector_data_rp);
      sector_data_bit_count := adjusted_size_of_sector_data * 8;
      extra_bit_count := ((sector_data_bit_count + 11) DIV 12) * 4;
      dft_request.cda_sector_data_rp.length := ((extra_bit_count + sector_data_bit_count) + 63) DIV 64;
    ELSE

      ALLOCATE cda_sector_16_bit_p IN osv$mainframe_wired_cb_heap^;
      pmp$zero_out_table (^cda_sector_16_bit_p^.sector, #SIZE (cda_sector_16_bit_p^.sector));
      cda_sector_16_bit_seq_p := #SEQ (cda_sector_16_bit_p^.sector);
      RESET cda_sector_16_bit_seq_p;
      NEXT cda_sector_data_p: [[REP #SIZE (sector_data_p^) OF cell]] IN cda_sector_16_bit_seq_p;
      cda_sector_data_p^ := sector_data_p^;
      RESET cda_sector_16_bit_seq_p;
      dsp$convert_seq_p_to_r_pointer (cda_sector_16_bit_seq_p, dft_request.cda_sector_data_rp);
      dft_request.cda_sector_data_rp.length := (adjusted_size_of_sector_data + 7) DIV 8;
    IFEND;

    { Build the DFT request.

    IF osv$170_os_type = osc$ot7_none THEN
      destination := c$os_180_request;
    ELSE
      destination := c$os_170_request;
    IFEND;
    dft_request.header.request_code := dsc$dft_access_cda_sector;
    convert_name_to_cda_name (name, dft_request.name);
    dft_request.cda_information.valid_data := TRUE;
    dft_request.cda_information.sixteen_bits := TRUE;
    dft_request.cda_information.partial_read := FALSE;
    dft_request.cda_information.write_data := TRUE;
    dft_request.cda_information.cel_sector := (name = c$cda_cel_name);
    dft_request_seq_p := #SEQ (dft_request);

    { Make the DFT request.

    make_dft_request (destination, dft_request_seq_p, status);

    { Free the space in mainframe wired that was used to store the CDA data.

    IF name = c$cda_cel_name THEN
      FREE temp_sector_data_p IN osv$mainframe_wired_cb_heap^;
      FREE cda_sector_12_bit_p IN osv$mainframe_wired_cb_heap^;
    ELSE
      FREE cda_sector_16_bit_p IN osv$mainframe_wired_cb_heap^;
    IFEND;

  PROCEND dsp$write_cda_sector;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$write_mrt_entry', EJECT ??

{ PURPOSE:
{   This procedure makes a request to DFT to write an entry to the MRT.

  PROCEDURE [XDCL] dsp$write_mrt_entry
    (    mrt_entry_id: dst$mrt_entry_id;
         mrt_element_number: dst$mrt_element_number;
         mrt_entry: dst$mrt_entry;
     VAR status: ost$status);

    VAR
      destination: t$request_destination,
      dft_request: dst$dft_access_mrt,
      dft_request_seq_p: ^SEQ ( * ),
      mrt_entry_p: ^dst$mrt_entry,
      mrt_entry_seq_p: ^SEQ ( * );

    status.normal := TRUE;

    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      osp$set_status_abnormal (dsc$display_processor_id, dse$dft_not_allowed_on_cy2000,
            'DFT request not allowed on a Cyber 2000 mainframe.', status);
      RETURN;
    IFEND;

    { Build the DFT request.

    pmp$zero_out_table (#LOC (dft_request), #SIZE (dft_request));

    dft_request.header.request_code := dsc$dft_access_mrt;
    dft_request.read_mrt := 0;
    dft_request.number := mrt_element_number;
    dft_request.entry_id := $INTEGER(mrt_entry_id);
    dsp$allocate_continuous_memory (osv$mainframe_wired_cb_heap, #SIZE (dst$mrt_entry), mrt_entry_seq_p);
    RESET mrt_entry_seq_p;
    dsp$convert_seq_p_to_r_pointer (mrt_entry_seq_p, dft_request.mrt_entry_rp);
    NEXT mrt_entry_p IN mrt_entry_seq_p;
    mrt_entry_p^ := mrt_entry;
    CASE mrt_entry_id OF
    = dsc$mrt_id_iou =
      dft_request.mrt_entry_rp.length := (mrt_entry.iou.descriptor_id.size + 3) DIV 4;
    = dsc$mrt_id_central_memory =
      dft_request.mrt_entry_rp.length := (mrt_entry.memory.descriptor_id.size + 3) DIV 4;
    = dsc$mrt_id_processor =
      dft_request.mrt_entry_rp.length := (mrt_entry.processor.descriptor_id.size + 3) DIV 4;
    = dsc$mrt_id_mainframe =
      dft_request.mrt_entry_rp.length := (mrt_entry.mainframe.descriptor_id.size + 3) DIV 4;
    = dsc$mrt_id_flpp =
      dft_request.mrt_entry_rp.length := (mrt_entry.flpp.descriptor_id.size + 3) DIV 4;
    = dsc$mrt_id_display_console =
      dft_request.mrt_entry_rp.length := (mrt_entry.console.descriptor_id.size + 3) DIV 4;
    = dsc$mrt_id_global_processor =
      dft_request.mrt_entry_rp.length := (mrt_entry.global_processor.descriptor_id.size + 3) DIV 4;
    = dsc$mrt_id_clock_data =
      dft_request.mrt_entry_rp.length := (mrt_entry.clock_data.descriptor_id.size + 3) DIV 4;
    = dsc$mrt_id_model_dependent =
      dft_request.mrt_entry_rp.length := (mrt_entry.model_dependent.descriptor_id.size + 3) DIV 4;
    = dsc$mrt_id_page_map =
      dft_request.mrt_entry_rp.length := (mrt_entry.page_map.descriptor_id.size + 3) DIV 4;
    ELSE
      osp$system_error ('Illegal MRT entry id', NIL);
    CASEND;
    dft_request_seq_p := #SEQ (dft_request);

    { Make the DFT request.

    IF osv$170_os_type = osc$ot7_none THEN
      destination := c$os_180_request;
    ELSE
      destination := c$os_170_request;
    IFEND;

    make_dft_request (destination, dft_request_seq_p, status);
    FREE mrt_entry_seq_p IN osv$mainframe_wired_cb_heap^;

  PROCEND dsp$write_mrt_entry;
?? OLDTITLE ??
MODEND dsm$process_dft_requests;
*DECK DECK=DSM$PROCESS_SYSTEM_MESSAGES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : System Messages Processor' ??
MODULE dsm$process_system_messages;

{ PURPOSE:
{   This module contains procedures that manage the System Message buffer.  These procedures add messages
{   to the buffer, remove messages from the buffer and enlarge the buffer.  The procedures to process the
{   OS action code in the errors that DFT logs in the buffer control words in the DFT block are also
{   included in this module.  Some of the information used in this module is obtained from the DFT/OS
{   Interface Specification document, ARH6853.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cml$system_informative_message
*copyc cyd$cybil_structure_definitions
*copyc dpt$top_line_message
*copyc dst$dft_analysis_code_constants
*copyc dst$mf_element_table_entry
*copyc dst$os_action_code_constants
*copyc dst$rb_logging_request
*copyc dst$signal_contents
*copyc dst$ssr_data_types
*copyc dst$system_message_types
*copyc mmt$page_frame_index
*copyc osc$maximum_processor_number
*copyc osc$monitor_stack_mult
*copyc ost$free_running_clock
*copyc ost$hardware_subranges
?? POP ??
*copyc dpp$display_error
*copyc dsp$convert_r_pointer_to_seq_p
*copyc dsp$mtr_handle_bit_57
*copyc dsp$mtr_handle_pp_hang
*copyc dsp$mtr_save_mainframe_error
*copyc i#current_sequence_position
*copyc i#mtr_disable_traps
*copyc i#move
*copyc i#mtr_restore_traps
*copyc i#test_set_bit
*copyc mmp$mark_page_flawed
*copyc mtp$cst_p
*copyc mtp$deconfigure_divide_unit
*copyc mtp$get_date_time_at_timestamp
*copyc mtp$record_critical_hdw_status
*copyc mtp$record_noncrit_hdw_status
*copyc tmp$clear_lock
*copyc tmp$send_signal
*copyc tmp$set_lock
*copyc tmp$set_system_flag
?? EJECT ??
*copyc dsv$mainframe_type
*copyc mtv$170_due_info
*copyc mtv$cst0
*copyc mtv$dft_block_p
*copyc mtv$monitor_exchange_package
*copyc mtv$monitor_xp_slot_pointers
*copyc mtv$scb
*copyc tmv$system_job_monitor_gtid
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  CONST
    c$number_of_hardware_messages = 15;

  TYPE
    t$buffer = RECORD
      data_from_mrb: boolean,
      data_p: ^cell,
    RECEND,

    t$buffer_time = RECORD
      CASE 0 .. 2 OF
      = 0 =
        rfu_0_a: 0 .. 0ffffffff(16),
        hours: 0 .. 0ff(16),
        minutes: 0 .. 0ff(16),
        seconds: 0 .. 0ff(16),
        rfu_0_b: 0 .. 0ff(16),
      = 1 =
        rfu_1: 0 .. 0ffffffff(16),
        time: 0 .. 0ffffffff(16),
      = 2 =
        date_and_time: dst$dftb_date_and_time,
      CASEND,
    RECEND,

    t$console_message_record = RECORD
      hours: string (2),
      period_1: string (1),
      minutes: string (2),
      period_2: string (1),
      seconds: string (2),
      blank_1: string (1),
      error_string: string (4),
      code: string (12),
      blank_2: string (1),
      english_string: string (46),
    RECEND,

    t$fault_symptom_code = RECORD
      CASE 0 .. 2 OF
      = 0 =
        rfu_0: 0 .. 0ffffffff(16),
        code_string: string (12),
      = 1 =
        rfu_1: 0 .. 0ffffffff(16),
        code_1: 0 .. 0ffffffffffff(16),
        code_2: 0 .. 0ffffffffffff(16),
      = 2 =
        words: dst$dftb_fault_symptom_words,
      CASEND,
    RECEND,

    t$hardware_messages_record = RECORD
      dft_analysis_code: dst$dftb_dft_analysis_code,
      insert_number_location: 0 .. 40,
      message: string (40),
    RECEND,

    t$hardware_message_type = (c$hmt_no_message, c$hmt_180_message, c$hmt_170_message,
          c$hmt_version_3_180_message, c$hmt_version_3_170_message),

    t$partial_nrb_record = RECORD
      control_word: dst$dftb_buffer_control_word,
      information_word: dst$dftb_nrb_information_word,
      buffer_time: t$buffer_time,
      fault_symptom_code: t$fault_symptom_code,
    RECEND,

    t$partial_ssb_record = RECORD
      information_word: dst$dftb_ssb_information_word,
      buffer_time: t$buffer_time,
      fault_symptom_code: t$fault_symptom_code,
    RECEND;
?? EJECT ??
  VAR
    dsv$dftb_data: [XDCL, #GATE] dst$dftb_data_structure_info := [0, 0, 0, 0, 0, 0, 0, 0, 0],
    dsv$dftb_nve_req_buffer_p: [XDCL] ^dst$dftb_nve_req_buffer := NIL,
    dsv$dfts_control_word_p: [XDCL, #GATE] ^dst$dftb_control_word := NIL,
    dsv$mf_element_table_p: [XDCL, #GATE] ^ARRAY [1 .. *] OF dst$mf_element_table_entry := NIL,
    dsv$record_errors: [XDCL, #GATE] boolean := FALSE,
    dsv$sys_msg_buffer_desc_p: [XDCL, #GATE] ^dst$sys_msg_buffer_desc,
    dsv$sys_msg_buffer_initialized: [XDCL, #GATE] boolean := FALSE,
    dsv$sys_msg_buffer_ptrs: [XDCL, #GATE] dst$sys_msg_buffer_ptrs,
    dsv$sys_msg_buffer_size: [XDCL, #GATE] integer := dsc$sys_msg_buffer_size,
    dsv$turn_dft_logging_off: [XDCL, #GATE] boolean := FALSE,

    v$buffer: t$buffer := [TRUE, NIL],
    v$dft_hardware_messages: [READ] ARRAY [1 .. c$number_of_hardware_messages] OF
          t$hardware_messages_record :=
          [[dsc$dftb_dac_iou_004, 16, 'UNCORRECTED IOU00 ERROR'],
           [dsc$dftb_dac_iou_009, 16, 'UNCORRECTED IOU00 ERROR'],
           [dsc$dftb_dac_iou_006, 10, 'FATAL IOU00 ERROR'],
           [dsc$dftb_dac_iou_008, 10, 'FATAL IOU00 ERROR'],
           [dsc$dftb_dac_mem_105, 00, 'FATAL CM ERROR (MULTIPLE ODD BIT MEMORY)'],
           [dsc$dftb_dac_mem_106, 00, 'FATAL CM ERROR (PARTIAL WRITE PARITY)'],
           [dsc$dftb_dac_cpu_21E, 20, 'FATAL CM ERROR (CPU00 - PARTIAL WRITE)'],
           [dsc$dftb_dac_non_701, 00, 'ENVIRONMENT WARNING'],
           [dsc$dftb_dac_non_702, 00, 'LONG POWER WARNING'],
           [dsc$dftb_dac_non_703, 00, 'SHORT POWER WARNING'],
           [dsc$dftb_dac_non_704, 00, 'ENVIRONMENT WARNING NORMAL'],
           [dsc$dftb_dac_non_705, 00, 'LONG POWER WARNING NORMAL'],
           [dsc$dftb_dac_non_706, 00, 'SHORT POWER WARNING NORMAL'],
           [dsc$dftb_dac_non_709, 00, 'LONG POWER WARNING'],
           [dsc$dftb_dac_non_70A, 00, 'LONG POWER WARNING NORMAL']],

    v$dftb_buffer_entries_checked: 0 .. 10 := 0,
    v$dftb_data_retrieved: boolean := FALSE,

    v$dftb_mdb_p: ^ARRAY [0 .. *] OF dst$r_pointer := NIL,
    v$dftb_mrb_cw_offset: ost$real_memory_address := 0,
    v$dftb_mrb_offset: ost$real_memory_address := 0,
    v$dftb_nrb_offset: ost$real_memory_address := 0,
    v$dftb_ssb_offset: ost$real_memory_address := 0,

    v$sys_msg_buffer_is_full: boolean := FALSE,
    v$sys_msg_buffer_lock: tmt$ptl_lock := [FALSE, 0];
?? OLDTITLE ??
?? NEWTITLE := 'access_buffer_entry', EJECT ??

{ PURPOSE:
{   This procedure accesses a buffer entry from the DFT buffer.

  PROCEDURE access_buffer_entry
    (VAR rb: dst$rb_logging_request);

    VAR
      adjusted_pva_p: ^cell,
      buffer_cw_p: ^dst$dftb_buffer_control_word,
      cw_index: dst$dftb_element_size,
      interlock_previously_set: boolean,
      interlocked_entry_found: boolean,
      lowest_sequence_number: dst$dftb_sequence_number,
      mdb_buffer_data_p: ^SEQ ( * ),
      mdb_iw_p: ^dst$dftb_mdb_information_word,
      mdb_seq_p: ^SEQ ( * ),
      nrb_p: ^t$partial_nrb_record,
      rb_buffer_data_p: ^SEQ ( * ),
      skip_buffer_data_p: ^SEQ ( * ),
      ssb_p: ^t$partial_ssb_record;

    IF dsv$turn_dft_logging_off THEN
      RETURN;
    IFEND;

    IF NOT v$dftb_data_retrieved THEN
      setup_variables_to_dft_block;
    IFEND;

    { Clear the logging bit on the buffer entry that was just logged.

   /clear_logging_bit/
    BEGIN
      IF rb.dftb_data_structures = $dst$rb_dft_data_structures[ ] THEN
        EXIT /clear_logging_bit/;
      IFEND;

      IF dsc$dds_mrb IN rb.dftb_data_structures THEN
        buffer_cw_p := #ADDRESS (1, #SEGMENT (mtv$dft_block_p),
              v$dftb_mrb_cw_offset + ((rb.dftb_cw_index - 1) * #SIZE (dst$dftb_buffer_control_word)));
        ssb_p := #ADDRESS (1, #SEGMENT (mtv$dft_block_p),
              v$dftb_ssb_offset + ((rb.dftb_cw_index - 1) * (dsv$dftb_data.ssb_length * 8)));
      ELSEIF dsc$dds_nrb IN rb.dftb_data_structures THEN
        nrb_p := #ADDRESS (1, #SEGMENT (mtv$dft_block_p),
              v$dftb_nrb_offset + ((rb.dftb_cw_index - 1) * (dsv$dftb_data.nrb_length * 8)));
        buffer_cw_p := ^nrb_p^.control_word;
      ELSE
        EXIT /clear_logging_bit/;
      IFEND;

      IF NOT buffer_cw_p^.flags.c180_valid_data THEN
        i#test_set_bit (^buffer_cw_p^, dsc$dftb_interlock_bit, interlock_previously_set);
        IF interlock_previously_set THEN
          IF rb.dftb_clear_entries_checked < 10 THEN
            rb.dftb_clear_entries_checked := rb.dftb_clear_entries_checked + 1;
            rb.response := dsc$rlr_dft_entry_interlocked;
            RETURN;
          IFEND;
          rb.dftb_clear_entries_checked := 0;
          EXIT /clear_logging_bit/;
        IFEND;

        { Clear the MDB control word offset.  This allows DFT to reuse the buffer.

        IF (dsc$dds_mdb IN rb.dftb_data_structures) AND (buffer_cw_p^.flags.valid_mdb_data) THEN
          IF ((ssb_p^.information_word.mdb_ordinal >= 0) AND
                (ssb_p^.information_word.mdb_ordinal < dsv$dftb_data.number_of_mdbs)) AND
                (ssb_p^.information_word.unlogged = 0) THEN
            dsp$convert_r_pointer_to_seq_p (v$dftb_mdb_p^ [ssb_p^.information_word.mdb_ordinal],
                  mtv$dft_block_p, mdb_seq_p);
            NEXT mdb_iw_p IN mdb_seq_p;
            mdb_iw_p^.control_word_offset := 0;
          IFEND;
        IFEND;

        buffer_cw_p^.flags.logging_action := FALSE;
        buffer_cw_p^.flags.interlock := FALSE;
      IFEND;
    END /clear_logging_bit/;

    rb.response := dsc$rlr_dft_no_entry_to_log;
    rb.dftb_cw_index := 0;
    rb.dftb_data_structures := $dst$rb_dft_data_structures[ ];
    interlocked_entry_found := FALSE;

   /check_mrb_entries/
    BEGIN
      IF v$dftb_mrb_cw_offset <> 0 THEN

      { Search the MRB for an entry that has been processed but not logged and not interlocked.

       /search_mrb_entries/
        WHILE TRUE DO
          rb.dftb_cw_index := 0;
          lowest_sequence_number := UPPERVALUE (dst$dftb_sequence_number);
          FOR cw_index := 1 TO dsv$dftb_data.number_of_mrbs DO
            buffer_cw_p := #ADDRESS (1, #SEGMENT (mtv$dft_block_p),
                  v$dftb_mrb_cw_offset + ((cw_index - 1) * #SIZE (dst$dftb_buffer_control_word)));
            IF (buffer_cw_p^.flags.logging_action) AND (NOT buffer_cw_p^.flags.c180_valid_data) THEN
              IF NOT buffer_cw_p^.flags.interlock THEN
                IF buffer_cw_p^.sequence_number <= lowest_sequence_number THEN
                  rb.dftb_cw_index := cw_index;
                  lowest_sequence_number := buffer_cw_p^.sequence_number;
                IFEND;
              ELSE
                interlocked_entry_found := TRUE;
              IFEND;
            IFEND;
          FOREND;
          IF rb.dftb_cw_index <= 0 THEN
            EXIT /check_mrb_entries/;
          IFEND;

          buffer_cw_p := #ADDRESS (1, #SEGMENT (mtv$dft_block_p),
                v$dftb_mrb_cw_offset + ((rb.dftb_cw_index - 1) * #SIZE (dst$dftb_buffer_control_word)));
          i#test_set_bit (^buffer_cw_p^, dsc$dftb_interlock_bit, interlock_previously_set);
          IF NOT interlock_previously_set THEN
            EXIT /search_mrb_entries/;
          IFEND;
        WHILEND /search_mrb_entries/;

        { Move the MRB data to log into the return sequence.

        rb.dftb_data_structures := $dst$rb_dft_data_structures [dsc$dds_mrb];
        rb.dftb_control_word := buffer_cw_p^;
        adjusted_pva_p := #ADDRESS (1, #SEGMENT (mtv$dft_block_p),
              v$dftb_mrb_offset + (buffer_cw_p^.offset * 8));
        i#move (adjusted_pva_p, rb.dftb_seq_p, (dsv$dftb_data.mrb_length * 8));

        IF v$dftb_ssb_offset <> 0 THEN

          { Move the SSB data to the return sequence.

          RESET rb.dftb_seq_p;
          NEXT skip_buffer_data_p: [[REP dsv$dftb_data.mrb_length OF integer]] IN rb.dftb_seq_p;
          NEXT rb_buffer_data_p: [[REP dsv$dftb_data.ssb_length OF integer]] IN rb.dftb_seq_p;
          ssb_p := #ADDRESS (1, #SEGMENT (mtv$dft_block_p),
                v$dftb_ssb_offset + ((rb.dftb_cw_index - 1) * (dsv$dftb_data.ssb_length * 8)));
          i#move (ssb_p, rb_buffer_data_p, (dsv$dftb_data.ssb_length * 8));
          rb.dftb_data_structures := rb.dftb_data_structures + $dst$rb_dft_data_structures [dsc$dds_ssb];

          { Move any MDB data to the return sequence.

          IF (v$dftb_mdb_p <> NIL) AND (buffer_cw_p^.flags.valid_mdb_data) THEN
            IF ((ssb_p^.information_word.mdb_ordinal >= 0) AND
                  (ssb_p^.information_word.mdb_ordinal < dsv$dftb_data.number_of_mdbs)) AND
                  (ssb_p^.information_word.unlogged = 0) THEN
              dsp$convert_r_pointer_to_seq_p (v$dftb_mdb_p^ [ssb_p^.information_word.mdb_ordinal],
                    mtv$dft_block_p, mdb_seq_p);
              NEXT mdb_buffer_data_p: [[REP dsv$dftb_data.mdb_length OF integer]] IN mdb_seq_p;
              NEXT rb_buffer_data_p: [[REP dsv$dftb_data.mdb_length OF integer]] IN rb.dftb_seq_p;
              rb_buffer_data_p^ := mdb_buffer_data_p^;
              rb.dftb_data_structures := rb.dftb_data_structures + $dst$rb_dft_data_structures [dsc$dds_mdb];
            IFEND;
          IFEND;
        IFEND;

        RESET rb.dftb_seq_p;
        buffer_cw_p^.flags.interlock := FALSE;
        rb.response := dsc$rlr_dft_entry_to_log;
        RETURN;
      IFEND;
    END /check_mrb_entries/;

   /check_nrb_entries/
    BEGIN
      IF v$dftb_nrb_offset <> 0 THEN

        { Search the NRB for an entry that has been processed but not logged and not interlocked.

       /search_nrb_entries/
        WHILE TRUE DO
          rb.dftb_cw_index := 0;
          lowest_sequence_number := UPPERVALUE (dst$dftb_sequence_number);
          FOR cw_index := 1 TO dsv$dftb_data.number_of_nrbs DO
            nrb_p := #ADDRESS (1, #SEGMENT (mtv$dft_block_p),
                  v$dftb_nrb_offset + ((cw_index - 1) * (dsv$dftb_data.nrb_length * 8)));
            buffer_cw_p := ^nrb_p^.control_word;
            IF (buffer_cw_p^.flags.logging_action) AND (NOT buffer_cw_p^.flags.c180_valid_data) THEN
              IF NOT buffer_cw_p^.flags.interlock THEN
                IF buffer_cw_p^.sequence_number <= lowest_sequence_number THEN
                  rb.dftb_cw_index := cw_index;
                  lowest_sequence_number := buffer_cw_p^.sequence_number;
                IFEND;
              ELSE
                interlocked_entry_found := TRUE;
              IFEND;
            IFEND;
          FOREND;
          IF rb.dftb_cw_index <= 0 THEN
            EXIT /check_nrb_entries/;
          IFEND;

          nrb_p := #ADDRESS (1, #SEGMENT (mtv$dft_block_p),
                v$dftb_nrb_offset + ((rb.dftb_cw_index - 1) * (dsv$dftb_data.nrb_length * 8)));
          buffer_cw_p := ^nrb_p^.control_word;
          i#test_set_bit (^buffer_cw_p^, dsc$dftb_interlock_bit, interlock_previously_set);
          IF NOT interlock_previously_set THEN
            EXIT /search_nrb_entries/;
          IFEND;
        WHILEND /search_nrb_entries/;

        { Move the NRB data to log into the return sequence.

        rb.dftb_data_structures := $dst$rb_dft_data_structures [dsc$dds_nrb];
        rb.dftb_control_word := buffer_cw_p^;
        i#move (nrb_p, rb.dftb_seq_p, (dsv$dftb_data.nrb_length * 8));
        RESET rb.dftb_seq_p;
        buffer_cw_p^.flags.interlock := FALSE;
        rb.response := dsc$rlr_dft_entry_to_log;
        RETURN;
      IFEND;
    END /check_nrb_entries/;

    IF interlocked_entry_found AND (rb.dftb_cw_index <= 0) AND (rb.dftb_log_entries_checked < 10) THEN
      rb.dftb_log_entries_checked := rb.dftb_log_entries_checked + 1;
      rb.response := dsc$rlr_dft_entry_interlocked;
    ELSE
      rb.dftb_log_entries_checked := 0;
    IFEND;

  PROCEND access_buffer_entry;
?? OLDTITLE ??
?? NEWTITLE := 'build_fault_symptom_code', EJECT ??

{ PURPOSE:
{   This procedure builds a fault symptom code if one does not exist in the DFT buffer.
{   The fault symptom code is defined to be the following:
{               Demmxxxyyyyy
{     where,
{            D = Character indicating fault symptom code was generated by DFT
{            e = Element specifier
{                     A = DFT internal error
{                     C, D, E, F = CPU 0, 1, 2, 3 respectively
{                     I, J, K, L = IOU 0, 1, 2, 3 respectively
{                     M = Memory
{                     P = Page Maps
{                     R, S, T, U = CPU 4, 5, 6, 7 respectively
{            mm = Model number of element that reported the error
{            xxx = DFT analysis code
{            yyyyy = blanks

  PROCEDURE build_fault_symptom_code
    (    dft_analysis_code: dst$dftb_dft_analysis_code;
         element_entry: dst$mf_element_table_entry;
     VAR fault_symptom_code: string (12));

    fault_symptom_code := ' ';

    fault_symptom_code (7) := CHR ((dft_analysis_code MOD 16) + ORD ('0'));
    fault_symptom_code (6) := CHR (((dft_analysis_code DIV 16) MOD 16) + ORD ('0'));
    fault_symptom_code (5) := CHR (((dft_analysis_code DIV (16*16)) MOD 16) + ORD ('0'));

    fault_symptom_code (3, 2) := element_entry.model_number_string.value;

    fault_symptom_code (2) := 'A';
    CASE element_entry.element_id.dft_entry_id OF
    = dsc$dftb_eid_cpu0_element =
      fault_symptom_code (2) := 'C';
    = dsc$dftb_eid_cpu1_element =
      fault_symptom_code (2) := 'D';
    = dsc$dftb_eid_cpu2_element =
      fault_symptom_code (2) := 'E';
    = dsc$dftb_eid_cpu3_element =
      fault_symptom_code (2) := 'F';
    = dsc$dftb_eid_cpu4_element =
      fault_symptom_code (2) := 'R';
    = dsc$dftb_eid_cpu5_element =
      fault_symptom_code (2) := 'S';
    = dsc$dftb_eid_cpu6_element =
      fault_symptom_code (2) := 'T';
    = dsc$dftb_eid_cpu7_element =
      fault_symptom_code (2) := 'U';
    = dsc$dftb_eid_memory_element =
      fault_symptom_code (2) := 'M';
    = dsc$dftb_eid_iou0_element =
      fault_symptom_code (2) := 'I';
    = dsc$dftb_eid_iou1_element =
      fault_symptom_code (2) := 'J';
    = dsc$dftb_eid_iou2_element =
      fault_symptom_code (2) := 'K';
    = dsc$dftb_eid_iou3_element =
      fault_symptom_code (2) := 'L';
    = dsc$dftb_eid_page_map_element =
      fault_symptom_code (2) := 'P';
    ELSE
    CASEND;

    fault_symptom_code (1) := 'D';

  PROCEND build_fault_symptom_code;
?? OLDTITLE ??
?? NEWTITLE := 'degrade_vector', EJECT ??

{ PURPOSE:
{   This procedure issues a message to the critical window whenever DFT degrades a vector divide unit.
{   It also updates the vector status in the SCB.

  PROCEDURE degrade_vector
    (    element_number: dst$dftb_mrt_element_index);

    VAR
      element_entry: dst$mf_element_table_entry,
      message: string (40),
      processor_id: ost$processor_id;

    get_mf_element_entry (element_number, element_entry);
    message := 'VECTOR DIVIDE DISABLED IN PROCESSOR 00.';
    message (37, 2) := element_entry.element_number_string.value;
    dpp$display_error (message);

    CASE mtv$scb.vector_simulation_control.vector_simulation_attribute OF
    = pmc$vectors_simulated =
      message := 'AFFECTED JOBS WILL CONTINUE EXECUTION.';
    = pmc$vectors_suspended =
      message := 'AFFECTED JOBS WILL BE SUSPENDED.';
    = pmc$vectors_aborted =
      message := 'AFFECTED JOBS WILL BE ABORTED.';
    ELSE
      message := ' ';
    CASEND;
    dpp$display_error (message);

    processor_id := element_entry.element_id.element_number;
    mtp$deconfigure_divide_unit (processor_id);

  PROCEND degrade_vector;
?? OLDTITLE ??
?? NEWTITLE := 'flaw_page', EJECT ??

{ PURPOSE:
{   This procedure calls the appropriate memory manager routine to flaw the page specified in the NRSB entry.

  PROCEDURE flaw_page;

    TYPE
      t$flaw_page = RECORD
        rfu: 0 .. 0ffffffff(16),
        page_number: mmt$page_frame_index_32,
      RECEND;

    VAR
      buffer_seq_p: ^SEQ ( * ),
      data_length: integer,
      flaw_page_p: ^t$flaw_page,
      nrb_internal_header_p: ^dst$dftb_nrb_internal_header,
      partial_nrb_record_p: ^t$partial_nrb_record,
      seq_entry_pp: ^^SEQ ( * ),
      seq_header: cyt$sequence_pointer,
      skip_data_p: ^SEQ ( * );

    IF v$buffer.data_p = NIL THEN
      RETURN;
    IFEND;

    seq_entry_pp := #LOC(seq_header);
    seq_header.pva := v$buffer.data_p;
    IF v$buffer.data_from_mrb THEN
      seq_header.length := dsv$dftb_data.mrb_length * 8;
    ELSE
      seq_header.length := dsv$dftb_data.nrb_length * 8;
    IFEND;
    seq_header.nextt := 0;
    buffer_seq_p := seq_entry_pp^;

    IF buffer_seq_p = NIL THEN
      RETURN;
    IFEND;

    RESET buffer_seq_p;
    data_length := #SIZE (buffer_seq_p^);
    NEXT partial_nrb_record_p IN buffer_seq_p;
    data_length := data_length - #SIZE (partial_nrb_record_p^);
    WHILE data_length > 0 DO
      NEXT nrb_internal_header_p IN buffer_seq_p;
      IF nrb_internal_header_p^.type_code = dsc$dftb_nrb_ih_flaw_page_num THEN
        NEXT flaw_page_p IN buffer_seq_p;
        mmp$mark_page_flawed (flaw_page_p^.page_number);
        RETURN;
      IFEND;
      NEXT skip_data_p: [[REP (nrb_internal_header_p^.length - 1) OF integer]] IN buffer_seq_p;
      data_length := data_length - (nrb_internal_header_p^.length * 8);
    WHILEND;

  PROCEND flaw_page;
?? OLDTITLE ??
?? NEWTITLE := 'get_mf_element_entry', EJECT ??

{ PURPOSE:
{   This procedure retrieves an entry from the Mainframe element table.

  PROCEDURE get_mf_element_entry
    (    element_number: dst$dftb_mrt_element_index;
     VAR element_entry: dst$mf_element_table_entry);

    VAR
      element_id: dst$mf_element_id,
      entry_index: ost$processor_element_number;

    { Initialize the element entry.

    element_entry.element_id.element_number := 0;
    element_entry.element_id.dft_entry_id := 0;
    element_entry.model_number := 0;
    element_entry.serial_number := 0;
    element_entry.element_number_string.size := 1;
    element_entry.element_number_string.value := ' ';
    element_entry.model_number_string := element_entry.element_number_string;
    element_entry.serial_number_string := element_entry.element_number_string;

    IF dsv$mf_element_table_p <> NIL THEN

      { Find the element number of the error.

      element_id.element_number := element_number DIV 16;
      element_id.dft_entry_id := element_number MOD 16;

     /search_element_table/
      FOR entry_index := LOWERBOUND (dsv$mf_element_table_p^) TO UPPERBOUND (dsv$mf_element_table_p^) DO
        IF dsv$mf_element_table_p^ [entry_index].element_id = element_id THEN
          element_entry := dsv$mf_element_table_p^ [entry_index];
          EXIT /search_element_table/;
        IFEND;
      FOREND /search_element_table/;
    IFEND;

  PROCEND get_mf_element_entry;
?? OLDTITLE ??
?? NEWTITLE := 'process_os_action_code', EJECT ??

{ PURPOSE:
{   This procedure processes the OS action code that is found in the buffer control word.

  PROCEDURE process_os_action_code
    (    element_number: dst$dftb_mrt_element_index;
         buffer_time: t$buffer_time;
         fault_symptom_code: t$fault_symptom_code;
     VAR buffer_cw_p: ^dst$dftb_buffer_control_word;
     VAR buffer_entry_interlocked: boolean);

    VAR
      dft_analysis_code: dst$dftb_dft_analysis_code,
      interlock_previously_set: boolean,
      traps: 0 .. 3;

    i#mtr_disable_traps (traps);

    { Interlock the buffer control word so DFT will not use it while the OS is accessing the word.

    i#test_set_bit (^buffer_cw_p^, dsc$dftb_interlock_bit, interlock_previously_set);
    IF interlock_previously_set THEN
      buffer_entry_interlocked := TRUE;
      i#mtr_restore_traps (traps);
      RETURN;
    IFEND;

   /buffer_interlocked/
    BEGIN

      { Save the error in the System Deadstart Status statistic.

      IF buffer_cw_p^.priority >= dsc$dftb_pri_uncorrected_error THEN
        dsp$mtr_save_mainframe_error (element_number, buffer_time.date_and_time, fault_symptom_code.words);
      IFEND;

      { Return if there are no OS action codes to process.

      IF buffer_cw_p^.os_action_code = dsc$dftb_oac_no_action THEN
        EXIT /buffer_interlocked/;
      IFEND;

      { Retrieve the DFT analysis code and remove the possiblity of multiple errors.

      dft_analysis_code := buffer_cw_p^.dft_analysis_code;
      IF buffer_cw_p^.dft_analysis_code > dsc$dftb_multiple_errors THEN
        dft_analysis_code := dft_analysis_code - dsc$dftb_multiple_errors;
      IFEND;

      record_hardware_status (element_number, buffer_time, fault_symptom_code, buffer_cw_p^.os_action_code,
            dft_analysis_code);
    END /buffer_interlocked/;

    { Set the valid bit to FALSE to indicate that the OS has processed the error and
    { set the interlock bit to FALSE to allow DFT to access the buffer control word again.

    buffer_cw_p^.flags.c180_valid_data := FALSE;
    buffer_cw_p^.flags.interlock := FALSE;
    i#mtr_restore_traps (traps);

  PROCEND process_os_action_code;
?? OLDTITLE ??
?? NEWTITLE := 'record_hardware_status', EJECT ??

{ PURPOSE:
{   This procedure determines what hardware action should be taken depending upon the OS action code
{   and calls the appropriate routine to record the status.

  PROCEDURE record_hardware_status
    (    element_number: dst$dftb_mrt_element_index;
         buffer_time: t$buffer_time;
         fault_symptom_code: t$fault_symptom_code;
         os_action_code: dst$dftb_os_action_code;
         dft_analysis_code: dst$dftb_dft_analysis_code);

    VAR
      console_message: t$console_message_record,
      element_entry: dst$mf_element_table_entry,
      hardware_action: mtt$scb_hardware_status_actions,
      hardware_message: t$hardware_message_type,
      hardware_option: mtt$scb_hardware_status_options,
      ignore_status: syt$monitor_status,
      message_p: ^dpt$top_line_message,
      message_seq_p: ^SEQ ( * ),
      signal: dst$signal_contents;

    { Process the OS action code.

    CASE os_action_code OF
    = dsc$dftb_oac_no_action =
      RETURN;

    = dsc$dftb_oac_environment, dsc$dftb_oac_long_power =
      hardware_action := mtc$scb_hsa_set;
      hardware_option := mtc$scb_long_warning_idle;
      hardware_message := c$hmt_version_3_180_message;

    = dsc$dftb_oac_short_power =
      hardware_action := mtc$scb_hsa_set;
      hardware_option := mtc$scb_short_warning_step;
      hardware_message := c$hmt_version_3_180_message;

    = dsc$dftb_oac_warning_clear =
      hardware_action := mtc$scb_hsa_clear;
      hardware_message := c$hmt_version_3_180_message;
      CASE dft_analysis_code OF
      = dsc$dftb_dac_non_704, dsc$dftb_dac_non_705, dsc$dftb_dac_non_70A =
        hardware_option := mtc$scb_long_warning_idle;
      ELSE
        hardware_option := mtc$scb_short_warning_step;
      CASEND;

    = dsc$dftb_oac_fatal_iou, dsc$dftb_oac_uncorrected_iou, dsc$dftb_oac_memory =
      hardware_action := mtc$scb_hsa_set;
      hardware_option := mtc$scb_hardware_failure_step;
      hardware_message := c$hmt_version_3_180_message;

    = dsc$dftb_oac_uncorrected_memory, dsc$dftb_oac_uncorrected_cpu =
      RETURN;

    = dsc$dftb_oac_170_state_iou =
      hardware_action := mtc$scb_hsa_set;
      hardware_option := mtc$scb_170_status;
      hardware_message := c$hmt_version_3_170_message;

    = dsc$dftb_oac_system_idle, dsc$dftb_oac_180_state_idle =
      hardware_action := mtc$scb_hsa_set;
      hardware_message := c$hmt_180_message;
      CASE dft_analysis_code OF
      = dsc$dftb_dac_non_701, dsc$dftb_dac_non_702, dsc$dftb_dac_non_709 =
        hardware_option := mtc$scb_long_warning_idle;
      ELSE
        hardware_option := mtc$scb_hardware_failure_idle;
      CASEND;

    = dsc$dftb_oac_system_step, dsc$dftb_oac_180_state_step =
      hardware_action := mtc$scb_hsa_set;
      hardware_message := c$hmt_180_message;
      CASE dft_analysis_code OF
      = dsc$dftb_dac_non_703 =
        hardware_option := mtc$scb_short_warning_step;
      ELSE
        hardware_option := mtc$scb_hardware_failure_step;
      CASEND;

    = dsc$dftb_oac_system_resume, dsc$dftb_oac_180_state_resume =
      hardware_action := mtc$scb_hsa_clear;
      hardware_message := c$hmt_180_message;
      CASE dft_analysis_code OF
      = dsc$dftb_dac_non_704, dsc$dftb_dac_non_705, dsc$dftb_dac_non_70A =
        hardware_option := mtc$scb_long_warning_idle;
      ELSE
        hardware_option := mtc$scb_hardware_failure_idle;
      CASEND;

    = dsc$dftb_oac_system_unstep, dsc$dftb_oac_180_state_unstep =
      hardware_action := mtc$scb_hsa_clear;
      hardware_message := c$hmt_180_message;
      CASE dft_analysis_code OF
      = dsc$dftb_dac_non_706 =
        hardware_option := mtc$scb_short_warning_step;
      ELSE
        hardware_option :=mtc$scb_hardware_failure_step;
      CASEND;

    = dsc$dftb_oac_170_state_idle, dsc$dftb_oac_170_state_step =
      hardware_action := mtc$scb_hsa_set;
      hardware_option := mtc$scb_170_status;
      hardware_message := c$hmt_170_message;

    = dsc$dftb_oac_170_state_resume, dsc$dftb_oac_170_state_unstep =
      hardware_action := mtc$scb_hsa_clear;
      hardware_option := mtc$scb_170_status;
      hardware_message := c$hmt_170_message;

    = dsc$dftb_oac_reconfigure_nce =
      get_mf_element_entry (element_number, element_entry);
      mtp$record_noncrit_hdw_status (element_entry.element_id);
      RETURN;

    = dsc$dftb_oac_vector_degrade =
      degrade_vector (element_number);
      RETURN;

    = dsc$dftb_oac_element_degrade =
      signal.identifier := dsc$deadstart_signal;
      signal.contents.kind := dsc$signal_post_operator_action;
      mtp$get_date_time_at_timestamp (#FREE_RUNNING_CLOCK (0), signal.contents.poa_data.date_time);
      signal.contents.poa_data.kind := dsc$signal_poa_sys_in_degrade;
      tmp$send_signal (tmv$system_job_monitor_gtid, signal.signal, ignore_status);
      RETURN;

    = dsc$dftb_oac_flaw_cm_page =
      flaw_page;
      RETURN;

    = dsc$dftb_oac_handle_pp_hang =
      dsp$mtr_handle_pp_hang (element_number, v$buffer.data_from_mrb, v$buffer.data_p);
      RETURN;

    = dsc$dftb_oac_handle_bit_57 =
      dsp$mtr_handle_bit_57 (element_number);
      RETURN;

    ELSE
      RETURN;
    CASEND;

    retrieve_console_message (element_number, buffer_time, fault_symptom_code, hardware_message,
          dft_analysis_code, console_message);

    message_seq_p := #SEQ (console_message);
    RESET message_seq_p;
    NEXT message_p IN message_seq_p;
    mtp$record_critical_hdw_status (hardware_option, hardware_action, message_p^);

  PROCEND record_hardware_status;
?? OLDTITLE ??
?? NEWTITLE := 'retrieve_console_message', EJECT ??

{ PURPOSE:
{   This procedure retrieves the correct message to be displayed on the system console for the error.
{   The code supports the version 3 message structure.

  PROCEDURE retrieve_console_message
    (    element_number: dst$dftb_mrt_element_index;
         buffer_time: t$buffer_time;
         fault_symptom_code: t$fault_symptom_code;
         hardware_message: t$hardware_message_type;
         dft_analysis_code: dst$dftb_dft_analysis_code;
     VAR console_message: t$console_message_record);

    VAR
      element_entry: dst$mf_element_table_entry,
      message: string (40),
      message_index: 1 .. c$number_of_hardware_messages;

    { Retrieve the element id.

    get_mf_element_entry (element_number, element_entry);

    { Initialize the console message.

    console_message.hours := ' ';
    console_message.period_1 := '.';
    console_message.minutes := ' ';
    console_message.period_2 := '.';
    console_message.seconds := ' ';
    console_message.blank_1 := ' ';
    console_message.error_string := 'ERR=';
    console_message.blank_2 := ' ';
    console_message.code := ' ';

    { Put the time in the console message.

    IF buffer_time.time = 0 THEN
      console_message.period_1 := ' ';
      console_message.period_2 := ' ';
    ELSE
      console_message.hours (2) := CHR ((buffer_time.hours MOD 16) + ORD ('0'));
      console_message.hours (1) := CHR (((buffer_time.hours DIV 16) MOD 16) + ORD ('0'));
      console_message.minutes (2) := CHR ((buffer_time.minutes MOD 16) + ORD ('0'));
      console_message.minutes (1) := CHR (((buffer_time.minutes DIV 16) MOD 16) + ORD ('0'));
      console_message.seconds (2) := CHR ((buffer_time.seconds MOD 16) + ORD ('0'));
      console_message.seconds (1) := CHR (((buffer_time.seconds DIV 16) MOD 16) + ORD ('0'));
    IFEND;

    { Put the fault symptom code in the console message.

    IF ((fault_symptom_code.code_1 = 0) AND (fault_symptom_code.code_2 = 0)) OR
          (fault_symptom_code.code_string = ' ') THEN
      build_fault_symptom_code (dft_analysis_code, element_entry, console_message.code);
    ELSE
      console_message.code := fault_symptom_code.code_string;
    IFEND;

    { Put the English message in the console message.

    message := ' ';

   /retrieve_hardware_message/
    FOR message_index := 1 TO c$number_of_hardware_messages DO
      IF v$dft_hardware_messages [message_index].dft_analysis_code = dft_analysis_code THEN
        message := v$dft_hardware_messages [message_index].message;
        IF v$dft_hardware_messages [message_index].insert_number_location > 0 THEN
          message (v$dft_hardware_messages [message_index].insert_number_location, 2) :=
                element_entry.element_number_string.value;
        IFEND;
        EXIT /retrieve_hardware_message/;
      IFEND;
    FOREND /retrieve_hardware_message/;

    IF (hardware_message = c$hmt_version_3_170_message) OR (hardware_message = c$hmt_170_message) THEN
      console_message.english_string (1, 6) := '170 - ';
      console_message.english_string (7, *) := message;
    ELSE
      console_message.english_string := message;
    IFEND;

  PROCEND retrieve_console_message;
?? OLDTITLE ??
?? NEWTITLE := 'setup_variables_to_dft_block', EJECT ??

{ PURPOSE:
{   This procedure retrieves the necessary information from the DFT block.  It creates pointers
{   to the various areas in the block.  At version 4, the pointers are retrieved through R pointers
{   in the DFT block.  Before version 4, not all of the areas had R pointers, several of the areas
{   existed immediately after the R pointer words in the DFT block.  If a particular area in the DFT
{   block is damaged, the pointer to that area will be set to NIL so that the OS will not attempt
{   to access the area.

  PROCEDURE setup_variables_to_dft_block;

    VAR
      buffer_cw_p: ^dst$dftb_buffer_control_word,
      cst_p: ^ost$cpu_state_table,
      dft_block_seq_p: ^SEQ ( * ),
      dft_block_size: integer,
      dft_cw_p: ^dst$dftb_control_word,
      monitor_mps: integer,
      nrb_hw_p: ^dst$dftb_buffer_header_word,
      number_of_pointer_words: dst$dftb_cw_pointer_words,
      nve_req_base_p: ^cell,
      r_pointer_words_p: ^dst$dftb_r_pointer_words,
      seq_entry_pp: ^^SEQ ( * ),
      seq_header: cyt$sequence_pointer,
      seq_p: ^SEQ ( * ),
      ssb_hw_p: ^dst$dftb_buffer_header_word;

    { Setup a pointer to the address space of the first CPU started.

    mtv$monitor_xp_slot_pointers.slot_1_p := ^mtv$monitor_exchange_package;
    i#real_memory_address (mtv$monitor_xp_slot_pointers.slot_1_p, monitor_mps);
    mtp$cst_p (cst_p);
    cst_p^.monitor_mps := monitor_mps;

    { Setup a pointer to the address space of the second CPU to be started.

    mtv$monitor_xp_slot_pointers.slot_2_p := #ADDRESS (#RING (mtv$monitor_xp_slot_pointers.slot_1_p),
          #SEGMENT (mtv$monitor_xp_slot_pointers.slot_1_p), osc$monitor_stack_mult);

    v$dftb_data_retrieved := TRUE;

    { Initialize the buffer data.

    v$dftb_mrb_cw_offset := 0;
    v$dftb_mrb_offset := 0;
    dsv$dftb_data.number_of_mrbs := 0;
    dsv$dftb_data.mrb_length := 0;

    v$dftb_ssb_offset := 0;
    dsv$dftb_data.ssb_length := 0;

    v$dftb_nrb_offset := 0;
    dsv$dftb_data.number_of_nrbs := 0;
    dsv$dftb_data.nrb_length := 0;

    v$dftb_mdb_p := NIL;
    dsv$dftb_data.number_of_mdbs := 0;
    dsv$dftb_data.mdb_length := 0;

    dsv$dfts_control_word_p := NIL;
    dsv$dftb_nve_req_buffer_p := NIL;

    dsv$dftb_data.revision_level := 0;
    dsv$dftb_data.secded_id_table_length := 0;

    { If the number of pointer words is not greater than one, the DFT buffer is damaged and should
    { not be accessed.  This is accomplished by setting all of the DFT buffer pointers to NIL.

    IF mtv$dft_block_p^.pointer_words <= 1 THEN
      RETURN;
    IFEND;

    { Retrieve the actual number of pointer words.  The value in the DFT control word also includes
    { the DFT control word.

    number_of_pointer_words := mtv$dft_block_p^.pointer_words - 1;

    { Retrieve the revision level.

    dsv$dftb_data.revision_level := mtv$dft_block_p^.revision_level;

    { Retrieve the size of the DFT block data that is contiguous.

    IF dsv$dftb_data.revision_level <= dsc$dftb_revision_level_3 THEN
      dft_block_size := #SIZE (mtv$dft_block_p^) + (number_of_pointer_words * 8) +
            (mtv$dft_block_p^.number_of_mrbs * 8);
    ELSE
      dft_block_size := #SIZE (mtv$dft_block_p^) + (number_of_pointer_words * 8);
    IFEND;

    { Create a sequence pointer to the DFT block.

    seq_entry_pp := #LOC (seq_header);
    seq_header.pva := mtv$dft_block_p;
    seq_header.length := dft_block_size;
    seq_header.nextt := 0;
    dft_block_seq_p := seq_entry_pp^;
    RESET dft_block_seq_p;

    { Get the DFT control word and the DFT buffer pointer words from the DFT buffer.

    NEXT dft_cw_p IN dft_block_seq_p;
    NEXT r_pointer_words_p: [1 .. number_of_pointer_words] IN dft_block_seq_p;

    { Retrieve the length of the SECDED ID table.

    IF number_of_pointer_words >= dsc$dftb_rpw_secded_id THEN
      dsv$dftb_data.secded_id_table_length := r_pointer_words_p^ [dsc$dftb_rpw_secded_id].length;
    IFEND;

    { Find the offset of the Maintenance Register Buffer from the pointer in the DFT block.

    IF number_of_pointer_words >= dsc$dftb_rpw_mrb THEN
      dsp$convert_r_pointer_to_seq_p (r_pointer_words_p^ [dsc$dftb_rpw_mrb], mtv$dft_block_p, seq_p);
      v$dftb_mrb_offset := #OFFSET (seq_p);
    IFEND;

    { Find the offset of the Maintenance Register Buffer Controlwords from the pointer in the DFT block.

    IF (dft_cw_p^.number_of_mrbs > 0) AND (dft_cw_p^.mrb_length > 0) THEN
      dsv$dftb_data.number_of_mrbs := dft_cw_p^.number_of_mrbs;
      dsv$dftb_data.mrb_length := dft_cw_p^.mrb_length;
      IF dsv$dftb_data.revision_level <= dsc$dftb_revision_level_3 THEN
        NEXT buffer_cw_p IN dft_block_seq_p;
        v$dftb_mrb_cw_offset := #OFFSET (buffer_cw_p);
      ELSE
        IF number_of_pointer_words >= dsc$dftb_rpw_mrb_cw THEN
          dsp$convert_r_pointer_to_seq_p (r_pointer_words_p^ [dsc$dftb_rpw_mrb_cw], mtv$dft_block_p, seq_p);
          v$dftb_mrb_cw_offset := #OFFSET (seq_p);
        IFEND;
      IFEND;
    IFEND;

    { Find the offset of the Supportive Status Buffer from the pointer in the DFT block.

    IF number_of_pointer_words >= dsc$dftb_rpw_ssb THEN
      dsp$convert_r_pointer_to_seq_p (r_pointer_words_p^ [dsc$dftb_rpw_ssb], mtv$dft_block_p, seq_p);
      ssb_hw_p := #ADDRESS (1, #SEGMENT (mtv$dft_block_p), #OFFSET (seq_p));
      IF ssb_hw_p^.buffer_size > 0 THEN
        dsv$dftb_data.ssb_length := ssb_hw_p^.buffer_size;
        v$dftb_ssb_offset := #OFFSET (seq_p) + #SIZE (ssb_hw_p^);
      IFEND;
    IFEND;

    { Find the offset of the Non Register Data Buffer from the pointer in the DFT block.

    IF number_of_pointer_words >= dsc$dftb_rpw_nrb THEN
      dsp$convert_r_pointer_to_seq_p (r_pointer_words_p^ [dsc$dftb_rpw_nrb], mtv$dft_block_p, seq_p);
      nrb_hw_p := #ADDRESS (1, #SEGMENT (mtv$dft_block_p), #OFFSET (seq_p));
      IF (nrb_hw_p^.number_of_buffers > 0) AND (nrb_hw_p^.buffer_size > 0) THEN
        dsv$dftb_data.number_of_nrbs := nrb_hw_p^.number_of_buffers;
        dsv$dftb_data.nrb_length := nrb_hw_p^.buffer_size;
        v$dftb_nrb_offset := #OFFSET (seq_p) + #SIZE (nrb_hw_p^);
      IFEND;
    IFEND;

    { Create a pointer to the Model Dependent Buffer.

    IF (number_of_pointer_words >= dsc$dftb_rpw_mdb) AND
          (r_pointer_words_p^ [dsc$dftb_rpw_mdb].length > 0) THEN
      dsp$convert_r_pointer_to_seq_p (r_pointer_words_p^ [dsc$dftb_rpw_mdb], mtv$dft_block_p, seq_p);
      dsv$dftb_data.number_of_mdbs := r_pointer_words_p^ [dsc$dftb_rpw_mdb].length;
      NEXT v$dftb_mdb_p: [0 .. (dsv$dftb_data.number_of_mdbs - 1)] IN seq_p;
      IF v$dftb_mdb_p^ [0].length > 0 THEN
        dsv$dftb_data.mdb_length := v$dftb_mdb_p^ [0].length;
      ELSE
        v$dftb_mdb_p := NIL;
      IFEND;
    IFEND;

    { Create a pointer to the Secondary DFT buffer control word.

    IF (number_of_pointer_words >= dsc$dftb_rpw_dft_secondary) AND
          (r_pointer_words_p^ [dsc$dftb_rpw_dft_secondary].length > 0) THEN
      dsp$convert_r_pointer_to_seq_p (r_pointer_words_p^ [dsc$dftb_rpw_dft_secondary],
            mtv$dft_block_p, seq_p);
      NEXT dsv$dfts_control_word_p IN seq_p;
    IFEND;

    { Create a pointer to the NOS/VE Request Buffer.

    IF (number_of_pointer_words >= dsc$dftb_rpw_nosve_buffer) AND
          (r_pointer_words_p^ [dsc$dftb_rpw_nosve_buffer].length > 0) THEN
      IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
        nve_req_base_p := mtv$dft_block_p;
      ELSE
        nve_req_base_p := #ADDRESS (1, dsc$ssr_segment_number, dsc$ssr_offset);
      IFEND;
      dsp$convert_r_pointer_to_seq_p (r_pointer_words_p^ [dsc$dftb_rpw_nosve_buffer], nve_req_base_p, seq_p);
      NEXT dsv$dftb_nve_req_buffer_p IN seq_p;
    IFEND;

  PROCEND setup_variables_to_dft_block;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$access_logging_data', EJECT ??

{ PURPOSE:
{   This procedure is called from the logging routine in job template to access the DFT buffer or the system
{   message buffer.  The logging routine (stored in dsm$log_system_messages) must make a call to monitor to
{   retrieve an error buffer in the DFT buffer or data in the system message buffer.  This procedure is also
{   called to set the bit in the DFT control block to tell DFT that the top of hour has occurred.

  PROCEDURE [XDCL] dsp$access_logging_data
    (VAR rb: dst$rb_logging_request);

    VAR
      index: integer,
      interlock_previously_set: boolean,
      message_recorded: boolean,
      new_sys_msg_data_p: ^SEQ ( * ),
      new_sys_msg_header_p: ^dst$system_message_header,
      old_sys_msg_data_p: ^SEQ ( * ),
      old_sys_msg_header_p: ^dst$system_message_header,
      save_add_data_seq_p: ^SEQ ( * );

    CASE rb.action OF

    = dsc$rla_dft_setup_variables =
      IF NOT v$dftb_data_retrieved THEN
        setup_variables_to_dft_block;
      IFEND;

    = dsc$rla_dft_retrieve_dfts_cw =
      IF NOT v$dftb_data_retrieved THEN
        setup_variables_to_dft_block;
      IFEND;
      IF dsv$dfts_control_word_p <> NIL THEN
        rb.dftb_dfts_control_word := dsv$dfts_control_word_p^;
      ELSE
        rb.dftb_dfts_control_word.dft_verification := FALSE;
      IFEND;

    = dsc$rla_dft_access_buffer_entry =
      access_buffer_entry (rb);

    = dsc$rla_dft_log_top_of_hour =

      { Clear out the DUE count in the CST; otherwise the system could shut down a CPU (or worse, abort) if
      {  number of occasional DUEs exceeded the DUE threshold.

      FOR index := 0 TO osc$maximum_processor_number DO
        mtv$cst0 [index].due_count := 0;
      FOREND;

      { Do the same for the 170 DUE counters.

      mtv$170_due_info.due_count := 0;
      mtv$170_due_info.aborted_job_count := 0;

      { Every top of hour a bit must be set in the DFT control word to tell DFT that the top of hour
      { has occurred.  DFT logs some data when this bit is set and then clears the bit.

      IF dsv$turn_dft_logging_off THEN
        RETURN;
      IFEND;

      i#test_set_bit (^mtv$dft_block_p^, dsc$dftb_cw_zero_counters_bit, interlock_previously_set);

    = dsc$rla_sys_msg_add_message =

      { Put a message on the circular buffer.

      RESET rb.sys_msg_add_data_seq_p;
      WHILE i#current_sequence_position (rb.sys_msg_add_data_seq_p) < #SIZE (rb.sys_msg_add_data_seq_p^) DO
        NEXT new_sys_msg_header_p IN rb.sys_msg_add_data_seq_p;
        NEXT new_sys_msg_data_p: [[REP new_sys_msg_header_p^.message_size OF cell]]
              IN rb.sys_msg_add_data_seq_p;
        dsp$report_system_message (new_sys_msg_data_p, new_sys_msg_header_p^.message_type,
              new_sys_msg_header_p^.message_level, message_recorded);
      WHILEND;

    = dsc$rla_sys_msg_get_message =

      { When the logging procedure makes a request for data from the buffer, the 'add' and 'remove'
      { pointers are copied to the request area and logging procedures use the copies of the pointers
      { to access the buffer.  After all the data has been logged, another call is made to move the
      { 'actual remove' pointer to the position of the saved 'copied add' pointer thus destroying
      { access to that data since it has been logged.

      tmp$set_lock (v$sys_msg_buffer_lock);
      IF rb.sys_msg_clear_buffer THEN
        dsv$sys_msg_buffer_ptrs.remove_data_seq_p := rb.sys_msg_add_data_seq_p;
        dsv$sys_msg_buffer_desc_p^.remove_data_ptr_offset :=
              i#current_sequence_position (dsv$sys_msg_buffer_ptrs.remove_data_seq_p);
        v$sys_msg_buffer_is_full := FALSE;
      IFEND;
      rb.sys_msg_add_data_seq_p := dsv$sys_msg_buffer_ptrs.add_data_seq_p;
      rb.sys_msg_remove_data_seq_p := dsv$sys_msg_buffer_ptrs.remove_data_seq_p;
      tmp$clear_lock (v$sys_msg_buffer_lock);

    = dsc$rla_sys_msg_enlarge_buffer =

      { Move the data from the old System Message buffer to the new enlarged System Message buffer
      { and set all the System Message buffer variables up to point to the new enlarged buffer.

      tmp$set_lock (v$sys_msg_buffer_lock);
      save_add_data_seq_p := rb.sys_msg_add_data_seq_p;
      dsv$sys_msg_buffer_size := rb.sys_msg_new_buffer_size;
      dsv$sys_msg_buffer_desc_p^.cm_start_of_buffer_p := rb.sys_msg_add_data_seq_p;
      dsv$sys_msg_buffer_desc_p^.sys_msg_buffer_size := rb.sys_msg_new_buffer_size;

      WHILE (i#current_sequence_position (dsv$sys_msg_buffer_ptrs.remove_data_seq_p) <
            i#current_sequence_position (dsv$sys_msg_buffer_ptrs.add_data_seq_p)) DO
        NEXT old_sys_msg_header_p IN dsv$sys_msg_buffer_ptrs.remove_data_seq_p;
        IF old_sys_msg_header_p^.message_size <> 0 THEN
          NEXT old_sys_msg_data_p: [[REP old_sys_msg_header_p^.message_size OF cell]] IN
                dsv$sys_msg_buffer_ptrs.remove_data_seq_p;
          NEXT new_sys_msg_header_p IN rb.sys_msg_add_data_seq_p;
          NEXT new_sys_msg_data_p: [[REP old_sys_msg_header_p^.message_size OF cell]] IN
                rb.sys_msg_add_data_seq_p;
          new_sys_msg_header_p^ := old_sys_msg_header_p^;
          new_sys_msg_data_p^ := old_sys_msg_data_p^;
        IFEND;
      WHILEND;

      dsv$sys_msg_buffer_ptrs.add_data_seq_p := rb.sys_msg_add_data_seq_p;
      dsv$sys_msg_buffer_ptrs.remove_data_seq_p := save_add_data_seq_p;
      dsv$sys_msg_buffer_desc_p^.add_data_ptr_offset :=
            i#current_sequence_position (dsv$sys_msg_buffer_ptrs.add_data_seq_p);
      dsv$sys_msg_buffer_desc_p^.remove_data_ptr_offset :=
            i#current_sequence_position (dsv$sys_msg_buffer_ptrs.remove_data_seq_p);
      tmp$clear_lock (v$sys_msg_buffer_lock);

    ELSE
    CASEND;

  PROCEND dsp$access_logging_data;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$process_dft_entry', EJECT ??

{ PURPOSE:
{   This procedure is called if the valid_180_error bit is set in the DFT buffer.  This procedure
{   checks each buffer control word for a possible error and processes it if one exists.  It then
{   clears the valid_180_error bit and calls the logging routine via a system flag.

  PROCEDURE [XDCL] dsp$process_dft_entry;

    VAR
      buffer_cw_p: ^dst$dftb_buffer_control_word,
      buffer_entry_interlocked: boolean,
      buffer_time: t$buffer_time,
      cw_index: dst$dftb_element_size,
      dft_analysis_code: dst$dftb_dft_analysis_code,
      element_number: dst$dftb_mrt_element_index,
      fault_symptom_code: t$fault_symptom_code,
      nrb_p: ^t$partial_nrb_record,
      ssb_p: ^t$partial_ssb_record,
      status: syt$monitor_status;

    IF dsv$turn_dft_logging_off THEN
      RETURN;
    IFEND;

    WHILE NOT mtv$dft_block_p^.c180_error DO

      { In the future, it is possible that this procedure will be called without this bit being
      { set.  In this case, the system noticed the error before DFT.  The error will be picked
      { up by DFT.  It is important to wait here until DFT notices the error, logs the data and
      { sets this bit so that the data can be picked up by the OS and processed.

    WHILEND;
    mtv$dft_block_p^.c180_error := FALSE;

    IF NOT v$dftb_data_retrieved THEN
      setup_variables_to_dft_block;
    IFEND;

    buffer_entry_interlocked := FALSE;
    element_number := 0;
    buffer_time.time := 0;
    fault_symptom_code.code_1 := 0;
    fault_symptom_code.code_2 := 0;
    v$buffer.data_p := NIL;

    { Process the maintenance register buffer data.

    IF v$dftb_mrb_cw_offset <> 0 THEN
      FOR cw_index := 1 TO dsv$dftb_data.number_of_mrbs DO
        buffer_cw_p := #ADDRESS (1, #SEGMENT (mtv$dft_block_p),
              v$dftb_mrb_cw_offset + ((cw_index - 1) * #SIZE (dst$dftb_buffer_control_word)));
        IF buffer_cw_p^.flags.c180_valid_data THEN
          v$buffer.data_p := #ADDRESS (1, #SEGMENT (mtv$dft_block_p),
                v$dftb_mrb_offset + (buffer_cw_p^.offset * 8));
          v$buffer.data_from_mrb := TRUE;
          IF v$dftb_ssb_offset <> 0 THEN
            ssb_p := #ADDRESS (1, #SEGMENT (mtv$dft_block_p),
                  v$dftb_ssb_offset + ((cw_index - 1) * (dsv$dftb_data.ssb_length * 8)));
            element_number := ssb_p^.information_word.element_number;
            buffer_time := ssb_p^.buffer_time;
            fault_symptom_code := ssb_p^.fault_symptom_code;
          IFEND;
          IF  buffer_cw_p^.dft_analysis_code < 999(16) THEN
          process_os_action_code (element_number, buffer_time, fault_symptom_code, buffer_cw_p,
                buffer_entry_interlocked);
          IFEND;
        IFEND;
      FOREND;
    IFEND;

    { Process the non register buffer data.

    IF v$dftb_nrb_offset <> 0 THEN
      FOR cw_index := 1 TO dsv$dftb_data.number_of_nrbs DO
        nrb_p := #ADDRESS (1, #SEGMENT (mtv$dft_block_p),
              v$dftb_nrb_offset + ((cw_index - 1) * (dsv$dftb_data.nrb_length * 8)));
        buffer_cw_p := ^nrb_p^.control_word;
        IF buffer_cw_p^.flags.c180_valid_data THEN
          v$buffer.data_p := ^nrb_p^;
          v$buffer.data_from_mrb := FALSE;
          IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
            IF nrb_p^.information_word.cy2000_element = 1(16) THEN
              element_number := dsc$dftb_eid_cpu0_element;
            ELSEIF nrb_p^.information_word.cy2000_element = 2(16) THEN
              element_number := dsc$dftb_eid_cpu1_element;
            ELSEIF nrb_p^.information_word.cy2000_element = 4(16) THEN
              element_number := dsc$dftb_eid_memory_element;
            ELSEIF nrb_p^.information_word.cy2000_element = 8(16) THEN
              element_number := dsc$dftb_eid_iou0_element;
            ELSEIF nrb_p^.information_word.cy2000_element = 10(16) THEN
              element_number := dsc$dftb_eid_iou1_element;
            ELSE
              element_number := dsc$dftb_eid_no_known_element;
            IFEND;
          ELSE
            element_number := nrb_p^.information_word.element_number;
          IFEND;
          buffer_time := nrb_p^.buffer_time;
          fault_symptom_code := nrb_p^.fault_symptom_code;

          IF  buffer_cw_p^.dft_analysis_code < 999(16) THEN
          process_os_action_code (element_number, buffer_time, fault_symptom_code, buffer_cw_p,
                buffer_entry_interlocked);
          IFEND;
        IFEND;
      FOREND;
    IFEND;

    { If a buffer entry was found to be interlocked and the number of attempts to access the interlocked
    { buffer is less then the max, set the DFT control word flag so that after a period of time this
    { routine will be called again and hopefully the interlock will be cleared.  If after the maximum
    { attempts to access an interlocked buffer, assume the interlock is stuck and do not set the bit.

    IF buffer_entry_interlocked AND (v$dftb_buffer_entries_checked < 10) THEN
      v$dftb_buffer_entries_checked := v$dftb_buffer_entries_checked + 1;
      mtv$dft_block_p^.c180_error := TRUE;
    ELSE
      v$dftb_buffer_entries_checked := 0;
    IFEND;

    { Initiate the logging of the error to the engineering log.

    IF dsv$record_errors THEN
      tmp$set_system_flag (tmv$system_job_monitor_gtid, dsc$log_dft_flag_id, status);
    IFEND;

  PROCEND dsp$process_dft_entry;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$report_system_message', EJECT ??

{ PURPOSE:
{   This procedure logs data into the engineering log.  This procedure stores the data on a
{   circular buffer and notifies the logging routine via a system flag that there is data to log.

  PROCEDURE [XDCL] dsp$report_system_message
    (    message_seq_p: ^SEQ ( * );
         message_type: dst$system_logging_types;
         message_level: dst$system_message_levels;
     VAR message_recorded: boolean);

    VAR
      add_data_ptr_offset: integer,
      add_data_seq_p: ^SEQ ( * ),
      buffer_is_full_space_needed: 0 .. dsc$sys_msg_buffer_size,
      buffer_sys_msg_data_p: ^SEQ ( * ),
      buffer_sys_msg_header_p: ^dst$system_message_header,
      end_of_buffer_offset: integer,
      leftover_space_needed: integer,
      logical_end_of_buffer: integer,
      message_data_seq_p: ^SEQ ( * ),
      message_p: ^string (80),
      message_type_p: ^integer,
      remove_data_ptr_offset: integer,
      status: syt$monitor_status,
      system_message_header: dst$system_message_header;

    message_recorded := FALSE;
    tmp$set_lock (v$sys_msg_buffer_lock);

   /buffer_lock_set/
    BEGIN

      { Return to the caller if the System Message buffer is not initialized.

      IF NOT dsv$sys_msg_buffer_initialized THEN
        EXIT /buffer_lock_set/;
      IFEND;

      { Return to the caller if the buffer is full, the logging routine has
      { not had enough time to empty the buffer.  The message will be discarded.

      IF v$sys_msg_buffer_is_full THEN
        EXIT /buffer_lock_set/;
      IFEND;

      { Return to the caller if there is no message data to log.

      IF message_seq_p = NIL THEN
        EXIT /buffer_lock_set/;
      IFEND;
      message_data_seq_p := message_seq_p;
      RESET message_data_seq_p;

      { Create the header for the System Message buffer entry.

      system_message_header.size_name := 'SIZE';
      system_message_header.message_size := #SIZE (message_data_seq_p^);
      system_message_header.type_name := 'TYPE';
      system_message_header.message_type := message_type;
      system_message_header.level_name := 'LVEL';
      system_message_header.message_level := message_level;

      { Store the data onto the circular buffer.  The circular buffer is driven by two pointers:
      { an add_data pointer and a remove_data pointer.  Data is added to the buffer via the add_data
      { pointer and removed from the buffer via the remove_data pointer.  Therefore, the data that is
      { after the remove_data pointer and before the add_data pointer is valid data.  If, when adding
      { data to the add_data pointer, it overlaps the remove_data pointer then the buffer is full.
      { Enough space is left on the buffer to state this fact and the data is discarded.

    /save_message/
      BEGIN

        add_data_seq_p := dsv$sys_msg_buffer_ptrs.add_data_seq_p;
        add_data_ptr_offset := i#current_sequence_position (dsv$sys_msg_buffer_ptrs.add_data_seq_p);
        remove_data_ptr_offset := i#current_sequence_position (dsv$sys_msg_buffer_ptrs.remove_data_seq_p);

        { The amount of space needed to store the message is equal to the size of the
        { system message header, the size of the message to be placed on the buffer,
        { the size of the system message header for the 'buffer is full' message, the
        { message type variable discribing the message and the size of the 'buffer is
        { full' message.

        buffer_is_full_space_needed := #SIZE (dst$system_message_header) +
              8 {size of message_type_p^} + 80 {size of message_p^};
        leftover_space_needed := #SIZE (dst$system_message_header) +
              system_message_header.message_size + buffer_is_full_space_needed;

        { The logical end of buffer is the end of the buffer minus a system message header.  This
        { is to allow for a system message header to be added to the end of the physical buffer.
        { This system message header is used to show that the input pointer has wrapped around the
        { circular buffer.

        logical_end_of_buffer := dsv$sys_msg_buffer_size - #SIZE (dst$system_message_header);

        { Check if there is enough space between the add_data pointer and the end of the buffer.

        IF (add_data_ptr_offset + leftover_space_needed) > logical_end_of_buffer THEN

          { There is not enough space between the add_data pointer and the end of the buffer.
          { If the remove_data pointer is between the add_data pointer and the end of the buffer
          { OR The remove_data pointer is so close to the beginning of the buffer that there is
          { no room to store the message then the buffer is full.  The 'buffer is full' message
          { is placed on the buffer and the message is discarded.

          IF (remove_data_ptr_offset > add_data_ptr_offset) OR
                (remove_data_ptr_offset < (leftover_space_needed +
                i#current_sequence_position (dsv$sys_msg_buffer_desc_p^.cm_start_of_buffer_p))) THEN
            v$sys_msg_buffer_is_full := TRUE;
            end_of_buffer_offset := logical_end_of_buffer;
            EXIT /save_message/;
          ELSE

            { The add_data pointer is too close to the bottom of the buffer to add
            { the message.  Place a system message header with message size of zero
            { on the buffer, reset the add_data pointer which causes the buffer to
            { to wrap around.  The system message header with message size of zero
            { is a signal that the buffer has wrapped around.

            NEXT buffer_sys_msg_header_p IN add_data_seq_p;
            buffer_sys_msg_header_p^ := system_message_header;
            buffer_sys_msg_header_p^.message_size := 0;
            RESET add_data_seq_p;
            add_data_ptr_offset := i#current_sequence_position (add_data_seq_p);
          IFEND;
        IFEND;

        { Check if there is enough space between the add_data pointer and remove_data pointer to
        { put the message.  If there is not enough space then the 'buffer is full' message is
        { placed on the buffer and the message is discarded.

        IF (remove_data_ptr_offset > add_data_ptr_offset) AND
              (remove_data_ptr_offset < add_data_ptr_offset + leftover_space_needed) THEN
          v$sys_msg_buffer_is_full := TRUE;
          end_of_buffer_offset := remove_data_ptr_offset;
          EXIT /save_message/;
        IFEND;

        { Enough room exists on the buffer to place the message so the message is placed on the buffer.

        NEXT buffer_sys_msg_header_p IN add_data_seq_p;
        NEXT buffer_sys_msg_data_p: [[REP system_message_header.message_size OF cell]] IN add_data_seq_p;
        buffer_sys_msg_header_p^ := system_message_header;
        buffer_sys_msg_data_p^ := message_data_seq_p^;
        message_recorded := TRUE;

      END /save_message/;

      { If the buffer is full, place a message stating that the buffer is full on the buffer.

      IF v$sys_msg_buffer_is_full AND
            ((add_data_ptr_offset + buffer_is_full_space_needed) <= end_of_buffer_offset) THEN
        NEXT buffer_sys_msg_header_p IN add_data_seq_p;
        NEXT message_type_p IN add_data_seq_p;
        NEXT message_p IN add_data_seq_p;
        buffer_sys_msg_header_p^.size_name := 'SIZE';
        buffer_sys_msg_header_p^.message_size := #SIZE (message_type_p^) + #SIZE (message_p^);
        buffer_sys_msg_header_p^.type_name := 'TYPE';
        buffer_sys_msg_header_p^.message_type := dsc$general_system_message;
        buffer_sys_msg_header_p^.level_name := 'LVEL';
        buffer_sys_msg_header_p^.message_level := dsc$informative_message;
        message_type_p^ := cml$system_informative_message;
        message_p^ := 'The circular system message buffer has overflowed -- some data has been lost';
        message_recorded := TRUE;
      IFEND;

      { Update the System Message buffer descriptive record, saving the
      { offsets of the two pointers.

      dsv$sys_msg_buffer_ptrs.add_data_seq_p := add_data_seq_p;
      dsv$sys_msg_buffer_desc_p^.add_data_ptr_offset :=
            i#current_sequence_position (dsv$sys_msg_buffer_ptrs.add_data_seq_p);
      dsv$sys_msg_buffer_desc_p^.remove_data_ptr_offset :=
            i#current_sequence_position (dsv$sys_msg_buffer_ptrs.remove_data_seq_p);

    END /buffer_lock_set/;
    tmp$clear_lock (v$sys_msg_buffer_lock);

    { Set the system job flag to initiate the logging of message data
    { from buffer.  This logging is done in job mode.

    IF dsv$record_errors AND message_recorded THEN
      tmp$set_system_flag (tmv$system_job_monitor_gtid, dsc$retrieve_system_message, status);
    IFEND;

  PROCEND dsp$report_system_message;
?? OLDTITLE ??
MODEND dsm$process_system_messages;
*DECK DECK=DSM$PROCESS_SYS_MSGS_HELPER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : System Messages Processor' ??
MODULE dsm$process_sys_msgs_helper;

{ PURPOSE:
{   This module contains procedures that assist the job template procedures involved
{   in the logging of DFT errors and the logging of system messages.  When the job
{   template procedures wish to contact the logging procedures that run in monitor
{   they call these procedures which are allowed to call monitor.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc dsp$fetch_boot_data
*copyc dsp$save_boot_data_pointer
*copyc i#current_sequence_position
*copyc pmp$zero_out_table
?? EJECT ??
*copyc dsv$boot_data_base_p
*copyc dsv$sys_msg_buffer_desc_p
*copyc dsv$sys_msg_buffer_initialized
*copyc dsv$sys_msg_buffer_ptrs
*copyc dsv$sys_msg_buffer_size
*copyc osv$boot_is_executing
*copyc osv$mainframe_wired_heap
?? TITLE := 'dsp$initialize_sys_msg_buffer', EJECT ??

{ PURPOSE:
{   This procedure initializes the circular system message buffer in mainframe wired.  If the boot is
{   executing it saves a pointer to the buffer in the SSR otherwise it moves any data that may have been
{   saved in the boot to the system core buffer.

  PROCEDURE [XDCL] dsp$initialize_sys_msg_buffer;

    VAR
      boot_sys_msg_data_p: ^SEQ ( * ),
      boot_sys_msg_desc_p: ^dst$sys_msg_buffer_desc,
      boot_sys_msg_header_p: ^dst$system_message_header,
      boot_sys_msg_seq_p: ^SEQ ( * ),
      buffer_sys_msg_data_p: ^SEQ ( * ),
      buffer_sys_msg_header_p: ^dst$system_message_header,
      rel_sys_msg_desc_p: [STATIC] REL (SEQ ( * )) ^dst$sys_msg_buffer_desc,
      rel_sys_msg_desc_seq_p: ^SEQ ( * );

    { Create the System Message buffer in mainframe wired.  Two pointers will be used with the System
    { Message buffer.  The 'add_data_seq_p' points to where data is added to the buffer and the
    { 'remove_data_seq_p' points to where data is removed from the buffer.  At the creation of the buffer
    { both pointers point to the beginning of the buffer.

    ALLOCATE dsv$sys_msg_buffer_ptrs.add_data_seq_p: [[REP dsv$sys_msg_buffer_size of cell]]
          IN osv$mainframe_wired_heap^;
    pmp$zero_out_table (dsv$sys_msg_buffer_ptrs.add_data_seq_p, dsv$sys_msg_buffer_size);
    dsv$sys_msg_buffer_ptrs.remove_data_seq_p := dsv$sys_msg_buffer_ptrs.add_data_seq_p;

    { The variable 'dsv$sys_msg_buffer_desc' is a record containing a 'description' of the System Message
    { buffer.  It contains three things:
    {   1)  It contains a pointer to the beginning of the buffer for the boot and for system core.
    {   2)  It contains the 'add' and 'remove' pointer positions.  This is needed for moving data from the
    {       boot to system core or for moving data in recovery.
    {   3)  It contains the size of the buffer.

    ALLOCATE dsv$sys_msg_buffer_desc_p IN osv$mainframe_wired_heap^;
    dsv$sys_msg_buffer_desc_p^.sys_msg_buffer_size := dsv$sys_msg_buffer_size;

    IF osv$boot_is_executing THEN

      { Save the pointer to the boot buffer so that in system core it can be retrieved and the data on
      { the boot buffer can be moved to the system core buffer.

      dsp$save_boot_data_pointer (dsc$system_messages, #SEQ (rel_sys_msg_desc_p));
      rel_sys_msg_desc_p := #REL (dsv$sys_msg_buffer_desc_p, dsv$boot_data_base_p^);
      dsv$sys_msg_buffer_desc_p^.boot_start_of_buffer_p :=
            #REL (dsv$sys_msg_buffer_ptrs.add_data_seq_p, dsv$boot_data_base_p^);

    ELSE

      { It is okay to access the System Message buffer pointers here instead of in a monitor routine because
      { the variable dsv$sys_msg_buffer_initialized is not yet set.  This variable must be set before the
      { monitor routines can access the buffer pointers.

      dsv$sys_msg_buffer_desc_p^.cm_start_of_buffer_p := dsv$sys_msg_buffer_ptrs.add_data_seq_p;

      { Fetch the pointer to the boot buffer.

      rel_sys_msg_desc_seq_p := #SEQ (rel_sys_msg_desc_p);
      dsp$fetch_boot_data (dsc$system_messages, rel_sys_msg_desc_seq_p);
      boot_sys_msg_desc_p := #PTR (rel_sys_msg_desc_p, dsv$boot_data_base_p^);
      boot_sys_msg_seq_p := #PTR (boot_sys_msg_desc_p^.boot_start_of_buffer_p, dsv$boot_data_base_p^);

      { Move the data from the boot buffer to the system core buffer.

      WHILE (i#current_sequence_position (boot_sys_msg_seq_p) < boot_sys_msg_desc_p^.add_data_ptr_offset) DO
        NEXT boot_sys_msg_header_p IN boot_sys_msg_seq_p;
        NEXT boot_sys_msg_data_p: [[REP boot_sys_msg_header_p^.message_size OF cell]] IN boot_sys_msg_seq_p;
        NEXT buffer_sys_msg_header_p IN dsv$sys_msg_buffer_ptrs.add_data_seq_p;
        NEXT buffer_sys_msg_data_p: [[REP boot_sys_msg_header_p^.message_size OF cell]] IN
              dsv$sys_msg_buffer_ptrs.add_data_seq_p;
        buffer_sys_msg_header_p^ := boot_sys_msg_header_p^;
        buffer_sys_msg_data_p^ := boot_sys_msg_data_p^;
      WHILEND;
    IFEND;

    { Save the current 'add' and 'remove' pointer positions.

    dsv$sys_msg_buffer_desc_p^.add_data_ptr_offset :=
          i#current_sequence_position (dsv$sys_msg_buffer_ptrs.add_data_seq_p);
    dsv$sys_msg_buffer_desc_p^.remove_data_ptr_offset :=
          i#current_sequence_position (dsv$sys_msg_buffer_ptrs.remove_data_seq_p);

    { This variable tells the monitor code that the System Message buffer is initialized and ready to be used.
    { After this variable is set to true only monitor code can access the System Message buffer.

    dsv$sys_msg_buffer_initialized := TRUE;

  PROCEND dsp$initialize_sys_msg_buffer;
MODEND dsm$process_sys_msgs_helper;
*DECK DECK=DSM$RECOVERY_SERVICES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Recovery services' ??
MODULE dsm$recovery_services;

{ PURPOSE:
{   This module contains all the routines which allow:
{     1)  Access to the image file.
{     2)  Access to old mainframe wired.
{     3)  Defining the recovery sequence.
{
{ DESIGN:
{   Implementation of access to the image file is done in such a way that the image file could change and
{   not break compatability of systems either forward or backward.  The image file contains 2 parts, the
{   recovery deadstart file (RDF) followed by the memory image.  The RDF contains information organized in
{   such way that forward and backward compatability problems can be resolved.  See the module that
{   contains the routines for RDF access for a better description.  The memory image starts right after the
{   RDF on the image file.  The memory image is written by the boot when a recovery is necessary, the memory
{   image is a copy of that part of memory that is used to deadstart the system.  The SSR contains entries
{   that define the image file.  One entry defines the size of the RDF and another defines the length of the
{   memory image.  By using the values from the RDF or SSR forward and backward compatability among systems
{   is maintained.  Constants define the RDF length and the image length but these are the desired values
{   for this system, not necessarily what is defined.  The size of the image file can be increased by
{   changing the constant and recompiling, the image file will be extended when the system is committed if
{   disk space is available.  If space is not available to extend the image file the system continues running
{   with currently defined image file.  On an installation deadstart the image file is created using the
{   constants to determine its size.  If there is any doubt as to the real image characteristics, get them
{   from the RDF.  On a recovery deadstart the SSR contains the values the boot uses to write the image.  The
{   values in the SSR are obtained from the RDF during system deadstart.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cml$system_informative_message
*copyc dmc$deadstart_file_alloc_size
*copyc dsc$previous_recovery_type
*copyc dst$deadstart_condition
*copyc dst$deadstart_sequence_steps
*copyc dst$image_file
*copyc dst$image_page_description
*copyc dst$image_status
*copyc dst$list_block
*copyc dst$nve_image_descriptor
*copyc dst$r_pointer
*copyc dst$rb_system_deadstart_status
*copyc dst$recover_deadstart_files
*copyc mmt$rcv_memory_mgr
*copyc osc$processor_defined_registers
*copyc ost$deadstart_phase
?? POP ??
*copyc clp$convert_integer_to_string
*copyc dmp$set_file_limit
*copyc dpp$put_critical_message
*copyc dsp$build_sequence_p
*copyc dsp$check_saved_passwords
*copyc dsp$close_image_file
*copyc dsp$extend_image_file
*copyc dsp$get_cy2000_element
*copyc dsp$get_data_from_rdf
*copyc dsp$get_data_from_ssr
*copyc dsp$get_entry_from_ssr
*copyc dsp$get_integer_from_rdf
*copyc dsp$log_sys_msg_help
*copyc dsp$open_image_file
*copyc dsp$save_sys_status_current_ds
*copyc dsp$store_data_in_rdf
*copyc dsp$store_data_in_ssr
*copyc dsp$store_entry_in_ssr
*copyc dsp$store_integer_in_rdf
*copyc dsp$store_sys_msg_in_image
*copyc dsp$upgrade_primary_dsfile_mau
*copyc i#build_adaptable_seq_pointer
*copyc i#call_monitor
*copyc i#move
*copyc i#real_memory_address
*copyc mmp$assign_mass_storage
*copyc mmp$build_segment
*copyc mmp$commit_memory
*copyc mmp$define_image_file
*copyc mmp$free_image_pages
*copyc mmp$get_sdtx_entry_p
*copyc mmp$invalidate_segment
*copyc osp$fatal_system_error
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$find_executing_task_xcb
*copyc pmp$get_processor_attributes
*copyc pmp$zero_out_table
*copyc syp$display_deadstart_message
*copyc syp$process_deadstart_status
?? EJECT ??
*copyc dsv$ignore_image
*copyc dsv$mainframe_type
*copyc dsv$sys_msg_buffer_desc_p
*copyc gfv$null_sfid
*copyc jmv$system_core_id
*copyc mmv$default_sdtx_entry
*copyc mmv$continue_bit_count_p
*copyc mmv$mf_wired_asid
*copyc mmv$pft_p
*copyc mmv$pt_length
*copyc osv$180_memory_limits
*copyc osv$mainframe_wired_heap
*copyc osv$page_size
*copyc syv$job_recovery_option
*copyc syv$setsa_job_recovery_option
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    t$hardware_registers = RECORD
      page_table_address: integer,
      page_table_length: integer,
      page_size: integer,
      mps: integer,
    RECEND;
?? EJECT ??
  VAR
    dsv$actual_deadstart_phase: [XDCL, #GATE] ost$deadstart_phase := osc$normal_deadstart,

    { Define variable for recovery deadstart file (RDF) size, must be a multiple of deadstart
    { file allocation size so that data after it can be accessed easily.  This is the image table
    { part of the image file.  This variable is set early in deadstart to the size of the RDF obtained
    { from the RDF.  Using the size from the RDF ensures forward and backward compatability among systems.

    dsv$rdf_size: [XDCL] ost$halfword := 0,
    osv$deadstart_phase: [XDCL, #GATE] ost$deadstart_phase := osc$normal_deadstart,

    v$current_deadstart_step: dst$deadstart_sequence_steps := dsc$dss_start_deadstart_process,
    v$default_sdte: mmt$segment_descriptor := [[osc$vl_regular_segment, osc$non_executable,
          osc$read_uncontrolled, osc$write_uncontrolled, osc$os_ring_1, osc$tsrv_ring, 0,
          [FALSE, FALSE, 0]], 0, 0],
    v$image_file_p: ^SEQ ( * ) := NIL,
    v$image_file_segment: mmt$segment_pointer,
    v$image_file_sfid: dmt$system_file_id,
    v$image_good: boolean := FALSE,

    { Variable v$list_block will be saved in the RDF when the image is committed.

    v$list_block: dst$list_block := [NIL, NIL, NIL, NIL],

    v$old_load_offset: integer := 0,
    v$old_registers: t$hardware_registers,
    v$rcv_mainframe_wired_segment_p: ^SEQ ( * ) := NIL;
?? OLDTITLE ??
?? NEWTITLE := 'check_recovery_state', EJECT ??

{ PURPOSE:
{   This procedure checks the recovery state by examining variables in the RDF areas and in the SSR.

  PROCEDURE check_recovery_state
    (VAR recovery_needed: boolean;
     VAR system_core_id: ost$name;
     VAR bad_system_core_id: boolean);

    VAR
      dsv$allow_diff_levels_recovery: [XDCL] boolean := TRUE,
      good_image_flag: integer,
      name_seq_p: ^SEQ ( * ),
      recovery_name: ost$name,
      idle_status: ost$name,
      ssr_image_name: ost$name,
      ssr_seq_p: ^SEQ ( * ),
      system_core_id_seq_p: ^SEQ ( * );

    name_seq_p := #SEQ (recovery_name);
    dsp$get_data_from_rdf (dsc$rdf_recovery_image_status, dsc$rdf_recovery, name_seq_p);

    name_seq_p := #SEQ (idle_status);
    dsp$get_data_from_rdf (dsc$rdf_system_idled_status, dsc$rdf_recovery, name_seq_p);

    name_seq_p := #SEQ (ssr_image_name);
    dsp$get_data_from_ssr (dsc$ssr_image_status, name_seq_p);

    { Examine the image file fields to determine the recovery state.

    recovery_needed := TRUE;
    v$image_good := FALSE;

    IF (idle_status = dsc$nve_idled) THEN
      recovery_needed := FALSE;

    ELSEIF (recovery_name = dsc$image_initialized) THEN
      osp$fatal_system_error ('Last initial deadstart did not complete.', NIL);

    ELSEIF (recovery_name = dsc$nve_recovered) THEN

      { The image has already been recovered.

      recovery_needed := FALSE;

      { Check for image lost after recovery but before committment

      IF (ssr_image_name = dsc$ready_to_run) THEN
        dsp$get_integer_from_rdf (dsc$rdf_good_image_flag, dsc$rdf_recovery, good_image_flag);
        v$image_good := (good_image_flag = $INTEGER (TRUE));
      IFEND;

    ELSEIF (recovery_name = dsc$will_commit) AND (ssr_image_name = dsc$ready_to_run) THEN

      { Recovery of the image is required.

      v$image_good := TRUE;
    IFEND;

    v$image_good := v$image_good AND NOT dsv$ignore_image;

    system_core_id_seq_p := #SEQ (system_core_id);
    dsp$get_data_from_rdf (dsc$rdf_system_core_id, dsc$rdf_production, system_core_id_seq_p);
    IF recovery_needed THEN
      IF v$image_good AND (system_core_id <> jmv$system_core_id) THEN
        IF dsv$allow_diff_levels_recovery THEN
          bad_system_core_id := FALSE;
        ELSE
          v$image_good := FALSE;
          bad_system_core_id := TRUE;
        IFEND;
      ELSE
        bad_system_core_id := FALSE;
      IFEND;
    IFEND;

  PROCEND check_recovery_state;
?? OLDTITLE ??
?? NEWTITLE := 'commit_image', EJECT ??

{ PURPOSE:
{   This procedure sets various values in the RDF and SSR for writing the next image file and recovering
{   this instance of the system if necessary.

  PROCEDURE commit_image;

    VAR
      convert_iht:  RECORD
        CASE boolean OF
        = FALSE=
          iht_p: ^mmt$old_modified_bits,
        = TRUE =
          cbc_p: ^mmt$continue_bit_count,
        CASEND,
      RECEND,
      hash_table_data: dst$r_pointer,
      name_stored: ost$name,
      rcv_memory_mgr_info: mmt$rcv_memory_mgr,
      registers: t$hardware_registers,
      rma: integer;

    dsp$store_integer_in_rdf (dsc$rdf_good_image_flag, dsc$rdf_recovery, $INTEGER (FALSE));

    name_stored := dsc$nve_recovered;
    dsp$store_data_in_rdf (dsc$rdf_recovery_image_status, dsc$rdf_recovery, #SEQ (name_stored));

    dsp$store_integer_in_rdf (dsc$rdf_lower_memory_limit, dsc$rdf_production, osv$180_memory_limits.lower);

    registers.page_table_address := #READ_REGISTER (osc$pr_page_table_address);
    registers.page_size := osv$page_size;
    registers.page_table_length := (#READ_REGISTER (osc$pr_page_table_length) + 1) * 4096;
    registers.mps := #READ_REGISTER (osc$pr_monitor_process_state);
    dsp$store_data_in_rdf (dsc$rdf_register_values, dsc$rdf_production, #SEQ (registers));

    { Initialize the R pointer for writing the page table modify bit map during recovery deadstarts.
    { The page table modify bit map is written over the 'continue bit count' table which is not needed
    { for recovery.  This table must be contiguous memory and large enough to hold the modify bit for
    { each page table entry, 64 modify bits per word.  The modify bit map is generated by a PP at
    { deadstart time.  Set the length in words.

    i#real_memory_address (mmv$continue_bit_count_p, rma);
    hash_table_data.offset := (rma DIV 10(8)) MOD 100(8);
    hash_table_data.rupper := rma DIV 10000000(8);
    hash_table_data.rlower := (rma DIV 1000(8)) MOD 10000(8);
    IF (#SIZE (mmv$continue_bit_count_p^)) >= (mmv$pt_length DIV 8) THEN
      hash_table_data.length := mmv$pt_length DIV (8 * 8);
    ELSE
      osp$system_error ('The table for page table modify bit map is not large enough.', NIL);
    IFEND;
    dsp$store_data_in_ssr (dsc$ssr_modify_bit_map_pt, #SEQ (hash_table_data));

    rcv_memory_mgr_info.pft_p := mmv$pft_p;
    i#real_memory_address (mmv$pft_p, rcv_memory_mgr_info.pft_p_rma);
    rcv_memory_mgr_info.mfw_asid_p := ^mmv$mf_wired_asid;
    i#real_memory_address (^mmv$mf_wired_asid, rcv_memory_mgr_info.mfw_asid_p_rma);
    convert_iht.cbc_p := mmv$continue_bit_count_p;
    rcv_memory_mgr_info.iht_p := convert_iht.iht_p;
    i#real_memory_address (mmv$continue_bit_count_p, rcv_memory_mgr_info.iht_p_rma);
    dsp$store_data_in_rdf (dsc$rdf_page_table_modified_bit, dsc$rdf_production, #SEQ (rcv_memory_mgr_info));

    dsp$store_data_in_rdf (dsc$rdf_list_block, dsc$rdf_production, #SEQ (v$list_block));

    name_stored := dsc$will_commit;
    dsp$store_data_in_rdf (dsc$rdf_recovery_image_status, dsc$rdf_recovery, #SEQ (name_stored));
    dsp$store_data_in_rdf (dsc$rdf_system_idled_status, dsc$rdf_recovery, #SEQ (name_stored));
    dsp$store_data_in_ssr (dsc$ssr_image_status, #SEQ (name_stored));

  PROCEND commit_image;
?? OLDTITLE ??
?? NEWTITLE := 'fetch_pvas_of_image_mfw', EJECT ??

{ PURPOSE:
{   This procedure fetches pages for the OLD mainframe wired segment.

  PROCEDURE fetch_pvas_of_image_mfw
    (    last_image_p: ^cell;
     VAR image_page_description: dst$image_page_description;
     VAR overflow: boolean);

    VAR
      current_asid: ost$asid,
      description_size: integer,
      found_last_pva: boolean,
      image_descriptor: dst$nve_image_descriptor,
      image_iht_p: ^mmt$old_modified_bits,
      image_p: ^cell,
      image_pft_p: ^mmt$page_frame_table,
      index: integer,
      new_asid: ost$asid,
      page_count: integer,
      page_index: integer,
      pages_found: integer,
      pages_saved: integer,
      segment_number: integer,
      segment_offset: integer;

    IF NOT v$image_good THEN
      osp$system_error ('Attempting to use the bad image.', NIL);
    IFEND;

    { Get the image description.

    dsp$get_nve_image_description (image_descriptor);
    page_count := 0;
    current_asid := image_descriptor.rcv_mfw_asid_p^.current;
    IF image_descriptor.rcv_mfw_asid_p^.new <> 0 THEN
      new_asid := image_descriptor.rcv_mfw_asid_p^.new;
    ELSE
      new_asid := current_asid;
    IFEND;
    image_page_description.pagesize := image_descriptor.rcv_page_size;
    image_pft_p := image_descriptor.rcv_page_frame_tbl_p;
    image_iht_p := image_descriptor.rcv_hash_tbl_p;

    FOR index := LOWERBOUND (image_pft_p^) TO UPPERBOUND (image_pft_p^) DO
      IF (image_pft_p^ [index].sva.asid = current_asid) OR (image_pft_p^ [index].sva.asid = new_asid) THEN
        page_count := page_count + 1;
      IFEND;
    FOREND;

    { Determine if there are any pages with the current asid.

    IF (page_count = 0) OR ((current_asid = 0) AND (new_asid = 0)) THEN
      overflow := FALSE;
      image_page_description.valid_desc_count := 0;
      RETURN;
    IFEND;

    { Record the page pva's.

    description_size := UPPERBOUND (image_page_description.page_desc) -
          LOWERBOUND (image_page_description.page_desc) + 1;
    page_index := LOWERBOUND (image_page_description.page_desc);
    pages_found := 0;
    pages_saved := 0;
    segment_number := #SEGMENT (v$image_file_p);
    found_last_pva := FALSE;

  /search_ptbl/
    FOR index := LOWERBOUND (image_pft_p^) TO UPPERBOUND (image_pft_p^) DO
      IF (image_pft_p^ [index].sva.asid = current_asid) OR (image_pft_p^ [index].sva.asid = new_asid) THEN
        pages_found := pages_found + 1;
        segment_offset := image_pft_p^ [index].sva.offset;
        image_p := #ADDRESS (1, segment_number, ((image_descriptor.rcv_page_size * index) -
              image_descriptor.rcv_load_offset) + dsv$rdf_size);
        IF (last_image_p <> NIL) AND (NOT found_last_pva) THEN
          IF last_image_p = image_p THEN
            found_last_pva := TRUE;
          IFEND;
          CYCLE /search_ptbl/;
        IFEND;
        pages_saved := pages_saved + 1;
        image_page_description.page_desc [page_index].image_pva := image_p;
        image_page_description.page_desc [page_index].file_offset := segment_offset;
        image_page_description.page_desc [page_index].page_lock := mmc$lp_not_locked;
        image_page_description.page_desc [page_index].modified := image_iht_p^ [image_pft_p^ [index].pti];

        { Set false just for now...

        image_page_description.page_desc [page_index].page_frame_flawed := FALSE;
        image_page_description.page_desc [page_index].disk_file_error := FALSE;
        page_index := page_index + 1;
        IF pages_saved >= description_size THEN
          EXIT /search_ptbl/;
        IFEND;
      IFEND;
    FOREND /search_ptbl/;

    image_page_description.valid_desc_count := pages_saved;
    overflow := (pages_found < page_count);

  PROCEND fetch_pvas_of_image_mfw;
?? OLDTITLE ??
?? NEWTITLE := 'set_image_recovered', EJECT ??
  PROCEDURE set_image_recovered;

    VAR
      name_stored: ost$name;

    dsp$store_integer_in_rdf (dsc$rdf_good_image_flag, dsc$rdf_recovery, $INTEGER (v$image_good));
    name_stored := dsc$nve_recovered;
    dsp$store_data_in_rdf (dsc$rdf_recovery_image_status, dsc$rdf_recovery, #SEQ (name_stored));
    dsp$store_data_in_rdf (dsc$rdf_system_idled_status, dsc$rdf_recovery, #SEQ (name_stored));

  PROCEND set_image_recovered;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$advance_deadstart_sequence', EJECT ??

{  PURPOSE:
{    This procedure controls and records the steps of deadstart and recovery.  This procedure receives as
{    input the step to which deadstart is advancing.  Some steps have specific actions that must be taken
{    as part of advancing to that step.  An entry in the SSR and the RDF area contains the present
{    deadstart state.

  PROCEDURE [XDCL, #GATE] dsp$advance_deadstart_sequence
    (    next_deadstart_step: dst$deadstart_sequence_steps);

    VAR
      deadstart_step: dst$ssr_entry,
      deadstart_type: dst$ssr_entry,
      descriptor: dst$nve_image_descriptor,
      ignore_status: ost$status,
      image_size: integer,
      image_state: dst$ssr_entry,
      image_status: ost$name,
      integer_string: ost$string,
      job_recovery_status: string (8),
      message: string (70),
      message_seq_p: ^SEQ ( * ),
      processor_attributes: pmt$processor_attributes,
      rb: dst$rb_system_deadstart_status,
      ssr_image_length: dst$ssr_entry,
      ssr_image_offset: dst$ssr_entry,
      status: ost$status;

    v$current_deadstart_step := next_deadstart_step;
    CASE v$current_deadstart_step OF
    = dsc$dss_ssr_built =

    = dsc$dss_dcfile_read =
      syp$display_deadstart_message ('System core initialization in progress ...');

    = dsc$dss_install_templates =
      syp$display_deadstart_message ('System core loading job template ...');

    = dsc$dss_templates_installed =
      syp$display_deadstart_message ('Loading of job template completed ...');

    = dsc$dss_outward_call_to_jt =
      syp$display_deadstart_message ('System core initiating job template ...');

    = dsc$dss_job_template_started =
      syp$display_deadstart_message ('Job template initiated ...');

    = dsc$dss_ssr_committed =

      { Save data for recovery.

      pmp$get_processor_attributes (processor_attributes, status);
      IF NOT status.normal THEN
        osp$system_error ('Errors in getting processor attributes', ^status);
      IFEND;
      dsp$store_list_block (dsc$processor_attributes, #SEQ (processor_attributes));
      dsp$store_list_block (dsc$system_messages_buffer, #SEQ (dsv$sys_msg_buffer_desc_p));

    = dsc$dss_load_sitecp =
      syp$display_deadstart_message ('Loading configuration prologs ...');

    = dsc$dss_sitecp_loaded =
      syp$display_deadstart_message ('Loading of the configuration prologs completed ...');

    = dsc$dss_load_dstape_libraries =
      syp$display_deadstart_message ('Loading the deadstart files ...');

    = dsc$dss_dstape_libraries_loaded =
      syp$display_deadstart_message ('Loading of the deadstart files completed ...');

    = dsc$dss_recover_mainframe =
      syp$display_deadstart_message ('System recovering mainframe ...');

      IF dsv$actual_deadstart_phase = osc$recovery_deadstart THEN
        IF dsv$ignore_image THEN
          dsp$save_sys_status_current_ds (dsc$ssr_sds_sdas_ignore_image);
        ELSE
          dsp$get_nve_image_description (descriptor);
          IF descriptor.rcv_mainframe_wired_segment <> NIL THEN
            dsp$save_sys_status_current_ds (dsc$ssr_sds_sdas_with_image);
          ELSE
            dsp$save_sys_status_current_ds (dsc$ssr_sds_sdas_without_image);
          IFEND;
        IFEND;
        dsp$store_sys_msg_in_image;
      IFEND;

    = dsc$dss_mainframe_recovered =
      syp$display_deadstart_message ('Recovering of mainframe completed ...');

    = dsc$dss_recovery_completed =

      { Cleanup the image file after recovery.

      IF (osv$deadstart_phase = osc$recovery_deadstart) THEN
        osv$deadstart_phase := osc$normal_deadstart;
        set_image_recovered;
      IFEND;
      dsp$get_entry_from_ssr (dsc$ssr_deadstart_type, deadstart_type);
      IF deadstart_type.right_slot = $INTEGER (dsc$recovery_deadstart) THEN
        deadstart_type.right_slot := $INTEGER (dsc$deadstart_condition_empty);
        dsp$store_entry_in_ssr (dsc$ssr_deadstart_type, dsc$ssr_right_slot, deadstart_type);
      IFEND;

    = dsc$dss_system_committed =
      dsp$check_saved_passwords;

      commit_image;

      { Enable future job recoverys.

      job_recovery_status := 'enable';
      dsp$store_data_in_rdf (dsc$rdf_job_recovery, dsc$rdf_production, #SEQ (job_recovery_status));
      dsp$store_data_in_rdf (dsc$rdf_system_core_id, dsc$rdf_production, #SEQ (jmv$system_core_id));

      { Call memory manager to free all image pages and to inform it that all of memory, as defined by
      { osv$180_memory_limits, can now be used by the system.  Image file page faults will no longer be
      { special cased.  Image file page faults will be processed just like any other segment.

      mmp$free_image_pages;
      mmp$commit_memory;

      { If image length of this system is greater than image length of previous systems extend the image file.

      dsp$get_entry_from_ssr (dsc$ssr_image_length, ssr_image_length);

      IF ssr_image_length.whole_slot < dsc$image_size THEN
        dsp$get_entry_from_ssr (dsc$ssr_image_offset, ssr_image_offset);

        { Set size of the RDF to a multiple of the allocation size.

        dsv$rdf_size := #SIZE (dst$recover_deadstart_files);
        IF (#SIZE (dst$recover_deadstart_files) MOD dmc$deadstart_file_alloc_size) > 0 THEN
          dsv$rdf_size := dsv$rdf_size + dmc$deadstart_file_alloc_size -
                (#SIZE (dst$recover_deadstart_files) MOD dmc$deadstart_file_alloc_size);
        IFEND;

        { The first time the image file was extended the size of the RDF was set to its real value and not
        { padded.  The following check is to allow this first image file extension with padding of the RDF
        { removed.  When standalone deadstart was implemented the RDF was set to twice its real size.

        IF (ssr_image_offset.whole_slot <> dsc$old_rdf_size) THEN
          IF (ssr_image_offset.whole_slot <> dsv$rdf_size) THEN

            { The size of the RDF increased.  This should not happen unless deliberately done.  At that time
            { code must be added to move the old RDF contents after image file expanded.

            osp$system_error ('Size of RDF changed.', NIL);
          IFEND;
        IFEND;

        dsp$close_image_file (v$image_file_sfid, v$image_file_segment);
        dsp$extend_image_file (dsv$rdf_size + dsc$image_size, dsv$rdf_size + ssr_image_length.whole_slot,
              status);
        dsp$open_image_file (v$image_file_sfid, v$image_file_segment, v$image_file_p);

        IF status.normal THEN

          { Update image values in the RDF and SSR.

          dsp$store_integer_in_rdf (dsc$rdf_image_size, dsc$rdf_production, dsc$image_size);
          dsp$store_integer_in_rdf (dsc$rdf_image_table_size, dsc$rdf_production, dsv$rdf_size);
          dsp$update_image_values_in_ssr;
        ELSE

          { Unable to extend image file, log this fact in system log and display a message.

          message := '--WARNING-- Unable to extend image file to ';
          clp$convert_integer_to_string ((dsv$rdf_size + dsc$image_size) DIV 100000(16), 10, TRUE,
                integer_string, ignore_status);
          message (44, integer_string.size) := integer_string.value (1, integer_string.size);
          message (44 + integer_string.size, 11) := ' megabytes.';
          message_seq_p := #SEQ (message);
          dsp$log_sys_msg_help (cml$system_informative_message, message_seq_p);
          syp$display_deadstart_message (message);

          IF osv$180_memory_limits.upper > 8000000(16) THEN

            { If running with more than 128 megabytes of memory this is a fatal error.

            syp$display_deadstart_message (
                  '  Running with more than 128 megabytes of memory and could not extend image');
            syp$display_deadstart_message (
                  '  file.  Deadstart again with 128 megabytes or less of memory and free up');
            syp$display_deadstart_message (
                  '  enough space on system device to expand image file.  Can not run with more');
            syp$display_deadstart_message (
                  '  than 128 megabytes of memory and recover the system with current image file.');
            syp$display_deadstart_message (
                  '  Deadstart with 128 megabytes of memory or less and fix problem.');
            osp$fatal_system_error ('Unable to extend the image file.', ^status);
          IFEND;
        IFEND;
      IFEND;

      deadstart_type.right_slot := $INTEGER (dsc$recovery_deadstart);
      dsp$store_entry_in_ssr (dsc$ssr_deadstart_type, dsc$ssr_right_slot, deadstart_type);

      { Set the image status name in the SSR to ready_to_run AND the image state in the SSR to 0 to request
      { that an image file be written for recovery purposes.  These two steps must be done in this order and
      { one RIGHT after the other to insure the validity of the image file.  A window of error still exists
      { when using this method.  If the system were to crash after ready_to_run was set but before the image
      { state is set to 0, then the problem could exist where VCB does not write the image file but the system
      { believes it has been written.  Perhaps a new method should be used.

      image_status := dsc$ready_to_run;
      dsp$store_data_in_ssr (dsc$ssr_image_status, #SEQ (image_status));
      image_state.whole_slot := 0;
      dsp$store_entry_in_ssr (dsc$ssr_image_state, dsc$ssr_whole_slot, image_state);

      rb.reqcode := syc$rc_system_deadstart_status;
      rb.action := dsc$rb_sds_set_bct_flag;
      rb.bct_flags := dsc$rb_sds_bct_point_of_commit;
      i#call_monitor (#LOC (rb), #SIZE (rb));

      dsp$close_image_file (v$image_file_sfid, v$image_file_segment);
      IF v$rcv_mainframe_wired_segment_p <> NIL THEN
        mmp$invalidate_segment (#SEGMENT (v$rcv_mainframe_wired_segment_p), 1, NIL, status);
      IFEND;
      syp$display_deadstart_message ('System committed ...');

    ELSE

      { do nothing

    CASEND;

    { When deadstart reaches the step where the image file has been accessed to determine the status of
    { NOS/VE as a result of the last termination of NOS/VE, then the step of the current deadstart
    { sequence can be maintained in the image file/recovery segment in rdf_recovery's entry
    { dsc$rdf_deadstart_state.

    IF v$current_deadstart_step >= dsc$dss_image_retrieved THEN
      dsp$store_integer_in_rdf (dsc$rdf_deadstart_state, dsc$rdf_recovery,
            $INTEGER(v$current_deadstart_step));
    IFEND;

    { Save the step of the current deadstart sequence in the SSR.

    deadstart_step.left_slot := $INTEGER (v$current_deadstart_step);
    dsp$store_entry_in_ssr (dsc$ssr_deadstart_state, dsc$ssr_left_slot, deadstart_step);

  PROCEND dsp$advance_deadstart_sequence;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$fetch_list_block', EJECT ??

{ PURPOSE:
{   This procedure fetches a list block from the SSR.

  PROCEDURE [XDCL, #GATE] dsp$fetch_list_block
    (    list_type: dst$list_block_kind;
     VAR list_p: ^SEQ (*));

    VAR
      adj_list_array_p: ^dst$list_for_block,
      first_time: [STATIC] boolean := TRUE,
      list_array: [STATIC] dst$list_for_block,
      list_array_index: dst$list_block_kind,
      list_array_p: ^dst$list_for_block,
      list_block: dst$list_block,
      list_block_p: ^SEQ ( * ),
      list_block_seq_p: ^SEQ ( * );

    IF NOT v$image_good THEN
      osp$system_error ('Attempting to use bad image.', NIL);
    IFEND;

    IF first_time THEN
      list_block_seq_p := #SEQ (list_block);
      dsp$get_data_from_rdf (dsc$rdf_list_block, dsc$rdf_production, list_block_seq_p);
      list_block_p := list_block.list_block_p;
      i#build_adaptable_seq_pointer (#RING (v$rcv_mainframe_wired_segment_p),
            #SEGMENT (v$rcv_mainframe_wired_segment_p), #OFFSET (list_block_p), #SIZE (list_block_p^),
            0, list_block_p);
      RESET list_block_p;
      NEXT list_array_p IN list_block_p;
      adj_list_array_p := #ADDRESS (#RING (v$rcv_mainframe_wired_segment_p),
            #SEGMENT (v$rcv_mainframe_wired_segment_p), #OFFSET (list_array_p));
      FOR list_array_index := LOWERBOUND (list_array) TO UPPERBOUND (list_array) DO
        list_array [list_array_index] := adj_list_array_p^ [list_array_index];
      FOREND;
      first_time := FALSE;
    IFEND;

    list_p := list_array [list_type];
    IF list_p = NIL THEN
      osp$system_error ('Requested list block does not exist.', NIL);
    IFEND;

  PROCEND dsp$fetch_list_block;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$get_flaw_map', EJECT ??

{ PURPOSE:
{   This procedure makes a request to the service processor to retrieve the flaw map.
{   A NIL pointer is returned if problems are encountered in retrieving the flaw map.

  PROCEDURE [XDCL] dsp$get_flaw_map
    (VAR flaw_map_p: ^ARRAY [1 .. *] OF mmt$page_frame_index_32);

    VAR
      element_seq_p: ^SEQ ( * ),
      local_status: ost$status,
      memory_element: dst$dft_get_memory_element;

    flaw_map_p := NIL;
    IF dsv$mainframe_type <> dsc$mt_2000_mainframe THEN
      RETURN;
    IFEND;

    { Retrieve the flaw table length.

    element_seq_p := #SEQ (memory_element);
    RESET element_seq_p;
    dsp$get_cy2000_element (dsc$dftb_eid_memory_element, dsc$dft_sub_none, element_seq_p,
          local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    IF memory_element.flaw_table_length <= 0 THEN
      RETURN;
    IFEND;

    ALLOCATE flaw_map_p: [1 .. (memory_element.flaw_table_length * 2)] IN osv$mainframe_wired_heap^;
    pmp$zero_out_table (^flaw_map_p^, #SIZE (flaw_map_p^));

    element_seq_p := #SEQ (flaw_map_p^);
    RESET element_seq_p;
    dsp$get_cy2000_element (dsc$dftb_eid_memory_element, dsc$dft_sub_flaw_table, element_seq_p,
          local_status);
    IF NOT local_status.normal THEN
      FREE flaw_map_p IN osv$mainframe_wired_heap^;
    IFEND;

  PROCEND dsp$get_flaw_map;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$get_nve_image_description', EJECT ??

{ PURPOSE:
{   This procedure fetches a description of the image file.

  PROCEDURE [XDCL, #GATE] dsp$get_nve_image_description
    (VAR descriptor: dst$nve_image_descriptor);

    VAR
      ignore_data_seq_p: ^SEQ ( * ),
      iht_p: ^mmt$old_modified_bits,
      mfw_asid_p: ^mmt$mainframe_wired_asid,
      pft_p: ^mmt$page_frame_table,
      rcv_memory_mgr_info: mmt$rcv_memory_mgr,
      rcv_memory_mgr_info_seq_p: ^SEQ ( * );

    IF v$image_good THEN
      descriptor.rcv_jps := v$old_registers.mps;
      descriptor.rcv_system_job_mtr_jps := v$old_registers.mps;
      descriptor.rcv_page_size := v$old_registers.page_size;
      descriptor.rcv_load_offset := v$old_load_offset;
      descriptor.nve_image := v$image_file_p;
      descriptor.rcv_mainframe_wired_segment := v$rcv_mainframe_wired_segment_p;

      rcv_memory_mgr_info_seq_p := #SEQ (rcv_memory_mgr_info);
      dsp$get_data_from_rdf (dsc$rdf_page_table_modified_bit, dsc$rdf_production, rcv_memory_mgr_info_seq_p);

      RESET v$image_file_p;
      NEXT ignore_data_seq_p: [[REP (rcv_memory_mgr_info.pft_p_rma - v$old_load_offset) OF cell]]
            IN v$image_file_p;
      NEXT pft_p: [LOWERBOUND (rcv_memory_mgr_info.pft_p^) .. UPPERBOUND (rcv_memory_mgr_info.pft_p^)]
            IN v$image_file_p;
      descriptor.rcv_page_frame_tbl_p := pft_p;

      RESET v$image_file_p;
      NEXT ignore_data_seq_p: [[REP (rcv_memory_mgr_info.iht_p_rma - v$old_load_offset) OF cell]]
            IN v$image_file_p;
      NEXT iht_p: [LOWERBOUND (rcv_memory_mgr_info.iht_p^) .. UPPERBOUND (rcv_memory_mgr_info.iht_p^)]
            IN v$image_file_p;
      descriptor.rcv_hash_tbl_p := iht_p;

      RESET v$image_file_p;
      NEXT ignore_data_seq_p: [[REP (rcv_memory_mgr_info.mfw_asid_p_rma - v$old_load_offset) OF cell]]
            IN v$image_file_p;
      NEXT mfw_asid_p IN v$image_file_p;
      descriptor.rcv_mfw_asid_p := mfw_asid_p;
    ELSE
      descriptor.nve_image := NIL;
      descriptor.rcv_mainframe_wired_segment := NIL;
    IFEND;

  PROCEND dsp$get_nve_image_description;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$idle_system', EJECT ??

{ PURPOSE:
{   This procedure idles the system as far as deadstart is concerned.

  PROCEDURE [XDCL, #GATE] dsp$idle_system
    (    allow_system_commit: boolean);

    VAR
      commit_new_dsfile: integer,
      deadstart_step: dst$ssr_entry,
      deadstart_type: dst$ssr_entry,
      image_state: dst$ssr_entry,
      local_status: ost$status,
      name_stored: ost$name;

    IF allow_system_commit THEN

      { Upgrade to a new disk deadstart file, if necessary.

      dsp$get_integer_from_rdf (dsc$rdf_commit_new_dsfile_flag, dsc$rdf_production, commit_new_dsfile);
      IF commit_new_dsfile = $INTEGER (TRUE) THEN
        dsp$upgrade_primary_dsfile_mau (local_status);
        IF NOT local_status.normal THEN
          syp$display_deadstart_message
                ('The following error occurred while attempting to commit the new system:');
          syp$process_deadstart_status ('Unable to commit new system', FALSE, local_status);
          syp$display_deadstart_message ('The new system was NOT committed.');
        ELSE
          dsp$store_integer_in_rdf (dsc$rdf_commit_new_dsfile_flag, dsc$rdf_production, $INTEGER(FALSE));
          dpp$put_critical_message ('New system has been committed.', local_status);
          syp$display_deadstart_message ('New system has been committed.');
        IFEND;
      IFEND;
    IFEND;

    name_stored := dsc$ready_to_run;
    dsp$store_data_in_ssr (dsc$ssr_image_status, #SEQ (name_stored));
    set_image_recovered;

    deadstart_type.right_slot := $INTEGER (dsc$deadstart_condition_empty);
    dsp$store_entry_in_ssr (dsc$ssr_deadstart_type, dsc$ssr_right_slot, deadstart_type);
    deadstart_step.left_slot := $INTEGER (dsc$dss_recovery_completed);
    dsp$store_entry_in_ssr (dsc$ssr_deadstart_state, dsc$ssr_left_slot, deadstart_step);

    name_stored := dsc$nve_idled;
    dsp$store_data_in_rdf (dsc$rdf_system_idled_status, dsc$rdf_recovery, #SEQ (name_stored));

    dsp$advance_deadstart_sequence (dsc$dss_system_idled);

    { Set the flag to indicate that an image file does not need to be written.

    image_state.whole_slot := 2;
    dsp$store_entry_in_ssr (dsc$ssr_image_state, dsc$ssr_whole_slot, image_state);

  PROCEND dsp$idle_system;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$recover_mf_wired', EJECT ??

{ PURPOSE:
{   This procedure recovers old mainframe wired on a recovery deadstart.

  PROCEDURE [XDCL, #GATE] dsp$recover_mf_wired;

    CONST
      page_count = 9;

    VAR

      { Define static variable to assign backing store status to recovered mainframe wired segment.
      { Making the assumption this will always work, but save it in static area so that it can be
      { checked in dumps.

      assign_backing_store_status: [STATIC] ost$status,

      destination_p: ^cell,
      idle_status: ost$name,
      idle_status_seq_p: ^SEQ ( * ),
      image_description_p: ^dst$image_page_description,
      largest_rcv_mfw_file_offset: ost$segment_offset,
      last_image_p: ^cell,
      max_segment_length: ost$segment_length,
      new_wired_segment_number: integer,
      overflow: boolean,
      pages: integer,
      recovery_mainframe_wired_p: ^cell,
      register_seq_p: ^SEQ ( * ),
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segment_attributes: mmt$segment_attrib_descriptor,
      segment_number: ost$segment,
      segment_pointer: mmt$segment_pointer,
      status: ost$status,
      valid_count: integer,
      xcb_p: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb_p);
    { Determine if it is necessary to recover old mainframe wired.

    idle_status_seq_p := #SEQ (idle_status);
    dsp$get_data_from_rdf (dsc$rdf_system_idled_status, dsc$rdf_recovery, idle_status_seq_p);
    IF NOT (v$image_good AND (idle_status <> dsc$nve_idled)) THEN
      RETURN;
    IFEND;

    dsp$get_integer_from_rdf (dsc$rdf_lower_memory_limit, dsc$rdf_production, v$old_load_offset);
    register_seq_p := #SEQ (v$old_registers);
    dsp$get_data_from_rdf (dsc$rdf_register_values, dsc$rdf_production, register_seq_p);

    { Make the recovery segment.

    segment_attributes.validating_ring_number := 1;
    segment_attributes.file_limits_to_enforce := sfc$no_limit;
    PUSH segment_attributes.user_attributes: [1..1];
    segment_attributes.user_attributes^ [1].keyword := mmc$kw_ring_numbers;
    segment_attributes.user_attributes^ [1].r1 := 1;
    segment_attributes.user_attributes^ [1].r2 := 3;
    segment_attributes.sfid := gfv$null_sfid;
    mmp$build_segment (segment_attributes, NIL {shared_taskids}, segment_pointer, status);
    IF NOT status.normal THEN
      osp$system_error ('Error in making recovery segment.', ^status);
    IFEND;
    recovery_mainframe_wired_p := segment_pointer.cell_pointer;
    new_wired_segment_number := #SEGMENT (recovery_mainframe_wired_p);
    sdtx_entry_p := mmp$get_sdtx_entry_p (xcb_p, new_wired_segment_number);
    sdtx_entry_p^.open_validating_ring_number := 0;
    pages := 0;
    last_image_p := NIL;
    overflow := FALSE;
    PUSH image_description_p: [0 .. page_count];
    largest_rcv_mfw_file_offset := 0;

    REPEAT
      fetch_pvas_of_image_mfw (last_image_p, image_description_p^, overflow);
      IF image_description_p^.valid_desc_count > 0 THEN
        FOR valid_count := 0 TO image_description_p^.valid_desc_count - 1 DO
          pages := pages + 1;
          last_image_p := image_description_p^.page_desc [valid_count].image_pva;
          destination_p := #ADDRESS (1, new_wired_segment_number,
                image_description_p^.page_desc [valid_count].file_offset);
          IF (image_description_p^.page_desc [valid_count].page_lock <> mmc$lp_not_locked) OR
                image_description_p^.page_desc [valid_count].disk_file_error OR
                image_description_p^.page_desc [valid_count].page_frame_flawed THEN
            osp$system_error ('Error in recovering old mainframe wired data.', NIL);
          IFEND;

          { Assign backing store to the recovered mainframe wired segment.  Status is being ignored
          { but saved in a static variable if it is abnormal.  It is only critical that backing store
          { be assigned to this segment now if we run out of memory.

          i#move (last_image_p, destination_p, image_description_p^.pagesize);
          IF image_description_p^.page_desc [valid_count].file_offset > largest_rcv_mfw_file_offset THEN
            mmp$assign_mass_storage (new_wired_segment_number, gfv$null_sfid,
                  0, assign_backing_store_status);
            IF assign_backing_store_status.normal THEN
              largest_rcv_mfw_file_offset := image_description_p^.page_desc [valid_count].file_offset;
            IFEND;
          IFEND;
        FOREND;

      ELSE
        IF overflow THEN
          osp$system_error ('Error in recovering old mainframe wired data.', NIL);
        IFEND;
      IFEND;
    UNTIL overflow = FALSE;

    dsp$build_sequence_p (recovery_mainframe_wired_p, (pages * v$old_registers.page_size),
          v$rcv_mainframe_wired_segment_p);

  PROCEND dsp$recover_mf_wired;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$resume_system', EJECT ??
  PROCEDURE [XDCL, #GATE] dsp$resume_system;

    VAR
      image_state: dst$ssr_entry,
      name_stored: ost$name;

    name_stored := dsc$will_commit;
    dsp$store_data_in_rdf (dsc$rdf_recovery_image_status, dsc$rdf_recovery, #SEQ (name_stored));

    name_stored := dsc$ready_to_run;
    dsp$store_data_in_ssr (dsc$ssr_image_status, #SEQ (name_stored));

    name_stored := dsc$nve_resumed;
    dsp$store_data_in_rdf (dsc$rdf_system_idled_status, dsc$rdf_recovery, #SEQ (name_stored));

    dsp$advance_deadstart_sequence (dsc$dss_system_resumed);

    { Set the flag to request that an image file be written for recovery purposes.

    image_state.whole_slot := 0;
    dsp$store_entry_in_ssr (dsc$ssr_image_state, dsc$ssr_whole_slot, image_state);

  PROCEND dsp$resume_system;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$setup_deadstart', EJECT ??

{ PURPOSE:
{   This procedure is used during system initialization to setup the deadstart environment.
{   It is used to determine the deadstart phase from the image file.  The image file is opened
{   for segment access.

  PROCEDURE [XDCL, #GATE] dsp$setup_deadstart;

    VAR
      bad_system_core_id: boolean,
      commit_new_df: integer,
      deadstart_type: dst$ssr_entry,
      image_size: integer,
      idle_status: ost$name,
      idle_status_seq_p: ^SEQ ( * ),
      job_recovery_status: string (8),
      job_recovery_status_seq_p: ^SEQ ( * ),
      previous_recovery_status: string (8),
      previous_recovery_status_seq_p: ^SEQ ( * ),
      previous_recovery_type: string (8),
      previous_recovery_type_seq_p: ^SEQ ( * ),
      recovery_needed: boolean,
      register_values: t$hardware_registers,
      register_values_seq_p: ^SEQ ( * ),
      system_core_id: ost$name,
      status: ost$status;

    dsp$open_image_file (v$image_file_sfid, v$image_file_segment, v$image_file_p);
    dsv$actual_deadstart_phase := osv$deadstart_phase;


    { Set the file limit of the image file.  The file limit must be correct since it is used by Memory
    { Manager to mark the boundary between pages that are on the image file and pages that are still
    { in real memory.  Since the value of file limit is lost when the image file is detached, it must
    { be reset each deadstart before calling mmp$define_image_file.


    dsp$get_integer_from_rdf (dsc$rdf_image_size, dsc$rdf_production, image_size);
    dmp$set_file_limit (v$image_file_sfid, dsv$rdf_size + image_size, status);
    IF NOT status.normal THEN
      osp$system_error ('Error occurred setting file limit on image file.', ^status);
    IFEND;

    { Ensure that the SSR reflects the image file values for subsequent continuation deadstarts.

    dsp$update_image_values_in_ssr;

    IF (osv$deadstart_phase = osc$installation_deadstart) THEN
      deadstart_type.left_slot := $INTEGER (dsc$recovery_deadstart);
      deadstart_type.right_slot := $INTEGER (dsc$continuation_deadstart);
      dsp$store_entry_in_ssr (dsc$ssr_deadstart_type, dsc$ssr_whole_slot, deadstart_type);
      RETURN;
    IFEND;

    { Check and display the recovery state.

    check_recovery_state (recovery_needed, system_core_id, bad_system_core_id);

    IF recovery_needed THEN
      dsv$actual_deadstart_phase := osc$recovery_deadstart;
      IF v$image_good THEN
        syp$display_deadstart_message ('Attempting a recovery from memory image ...');
      ELSE
        IF bad_system_core_id THEN
          syp$display_deadstart_message ('Image is from a different level system and will be ignored ...');
        IFEND;
        syp$display_deadstart_message ('Attempting a recovery without image ...');
      IFEND;
    ELSE
      syp$display_deadstart_message ('System is in a recovered state ...');
    IFEND;

    { Record the current recovery type in the RDF. If a recovery without image has been attempted
    { since the last successful PF recovery, put dsc$recovery_without_image in the RDF.

    IF recovery_needed THEN
      IF v$image_good THEN
        previous_recovery_type_seq_p := #SEQ (previous_recovery_type);
        dsp$get_data_from_rdf (dsc$rdf_previous_recovery_type, dsc$rdf_production,
              previous_recovery_type_seq_p);
        IF previous_recovery_type = dsc$recovery_without_image THEN
          dsp$store_data_in_rdf (dsc$rdf_previous_recovery_type, dsc$rdf_production,
                #SEQ (previous_recovery_type));
        ELSE
          previous_recovery_type := dsc$recovery_with_image;
          dsp$store_data_in_rdf (dsc$rdf_previous_recovery_type, dsc$rdf_production,
                #SEQ (previous_recovery_type));
        IFEND;
      ELSE
        previous_recovery_type := dsc$recovery_without_image;
        dsp$store_data_in_rdf (dsc$rdf_previous_recovery_type, dsc$rdf_production,
              #SEQ (previous_recovery_type));
      IFEND;
    IFEND;

    dsp$get_entry_from_ssr (dsc$ssr_deadstart_type, deadstart_type);
    IF recovery_needed AND v$image_good THEN
      osv$deadstart_phase := osc$recovery_deadstart;
      IF (deadstart_type.right_slot <> $INTEGER (dsc$recovery_deadstart)) THEN
        deadstart_type.right_slot := $INTEGER (dsc$continuation_deadstart);
      IFEND;
      deadstart_type.left_slot := $INTEGER (dsc$recovery_deadstart);
    ELSE
      osv$deadstart_phase := osc$normal_deadstart;
      deadstart_type.right_slot := $INTEGER (dsc$continuation_deadstart);
      deadstart_type.left_slot := $INTEGER (dsc$continuation_deadstart);
    IFEND;
    dsp$store_entry_in_ssr (dsc$ssr_deadstart_type, dsc$ssr_whole_slot, deadstart_type);

    dsp$get_integer_from_rdf(dsc$rdf_commit_new_dsfile_flag,dsc$rdf_production,commit_new_df);
    IF commit_new_df = $INTEGER(TRUE) THEN
      syp$display_deadstart_message ('New system will be committed at successful ');
      syp$display_deadstart_message ('   completion of a terminate_system.');
    IFEND;

    { Initialize job recovery.

    syv$job_recovery_option := syv$setsa_job_recovery_option;
    IF syv$job_recovery_option <> syc$jre_enabled THEN
      job_recovery_status := 'disable';
    ELSE
      job_recovery_status := 'enable';
    IFEND;

    register_values_seq_p := #SEQ (register_values);
    dsp$get_data_from_rdf (dsc$rdf_register_values, dsc$rdf_production, register_values_seq_p);

    idle_status_seq_p := #SEQ (idle_status);
    dsp$get_data_from_rdf (dsc$rdf_system_idled_status, dsc$rdf_recovery, idle_status_seq_p);

    previous_recovery_status_seq_p := #SEQ (previous_recovery_status);
    dsp$get_data_from_rdf (dsc$rdf_job_recovery, dsc$rdf_production, previous_recovery_status_seq_p);

    IF (previous_recovery_status = 'disable') THEN

      { Previous disable - turn off job recovery to allow device management to free disk space early.

      job_recovery_status := 'disable';
      syv$job_recovery_option := syc$jre_prior_ds_disabled;
      syp$display_deadstart_message ('Job recovery disabled by prior deadstart ...');
    ELSEIF NOT v$image_good AND (idle_status <> dsc$nve_idled) THEN

      { No image - turn off job recovery to allow device management to free disk space early.

      job_recovery_status := 'disable';
      syv$job_recovery_option := syc$jre_no_image;
      syp$display_deadstart_message ('Job recovery disabled because memory image is not available ...');
    ELSEIF (system_core_id <> jmv$system_core_id) THEN

      { Different system - turn off job recovery to allow device management to free disk space early.

      job_recovery_status := 'disable';
      syv$job_recovery_option := syc$jre_different_system;
      syp$display_deadstart_message
            ('Job recovery disabled because a different system is being deadstarted ...');
    ELSEIF (register_values.page_size <> osv$page_size) THEN

      { Page size is different - turn off job recovery to allow device management to free disk space early.

      job_recovery_status := 'disable';
      syv$job_recovery_option := syc$jre_page_size_mismatch;
      syp$display_deadstart_message
            ('Job recovery disabled because a different page size is being used ...');
    ELSEIF (job_recovery_status = 'disable') THEN

      { Job recovery disabled by set_system_attribute command.

      syv$job_recovery_option := syc$jre_command_disabled;
      syp$display_deadstart_message ('Job recovery disabled by set_system_attribute command ...');
    ELSE

      { Job_recovery_status = 'enable'.

      syp$display_deadstart_message ('Job recovery enabled ...');
    IFEND;

    { Disable job recovery until the next system commit.

    IF job_recovery_status = 'disable' THEN
      dsp$store_data_in_rdf (dsc$rdf_job_recovery, dsc$rdf_production, #SEQ (job_recovery_status));
    IFEND;

    { Pass image file values to memory manager for use during page fault processing on the image file.
    { Page faults beyond file limit on the image file are special cased by memory manager.  They are
    { considered to be references to that portion of real memory that has been left undisturbed since
    { the crash.  The value passed to memory manager below is the address on the image file that
    { corresponds to the first byte of NOS/VE real memory.

    mmp$define_image_file (v$image_file_sfid, dsv$rdf_size);

    dsp$advance_deadstart_sequence (dsc$dss_image_retrieved);

  PROCEND dsp$setup_deadstart;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$store_list_block', EJECT ??

{ PURPOSE:
{   This procedure stores a list block in the SSR.

  PROCEDURE [XDCL, #GATE] dsp$store_list_block
    (    list_type: dst$list_block_kind;
         list_p: ^SEQ (*));

    VAR
      list_array_index: dst$list_block_kind,
      list_array_p: [STATIC] ^dst$list_for_block := NIL,
      list_data_seq_p: ^SEQ (*),
      list_seq_p: [STATIC] ^SEQ (*) := NIL;

    IF list_array_p = NIL THEN
      ALLOCATE list_seq_p: [[REP #SIZE (dst$list_for_block) OF cell]] IN osv$mainframe_wired_heap^;
      RESET list_seq_p;
      v$list_block.list_block_p := list_seq_p;
      NEXT list_array_p IN list_seq_p;
      FOR list_array_index := LOWERBOUND (list_array_p^) TO UPPERBOUND (list_array_p^) DO
        list_array_p^ [list_array_index] := NIL;
      FOREND;
    IFEND;

    IF list_array_p^ [list_type] <> NIL THEN
      osp$system_error ('Requested list block already exists.', NIL);
    IFEND;
    ALLOCATE list_data_seq_p: [[REP #SIZE (list_p^) OF cell]] IN osv$mainframe_wired_heap^;
    list_data_seq_p^ := list_p^;
    list_array_p^ [list_type] := list_data_seq_p;

  PROCEND dsp$store_list_block;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$system_committed', EJECT ??
  FUNCTION [XDCL, #GATE] dsp$system_committed: boolean;

    dsp$system_committed := (v$current_deadstart_step >= dsc$dss_system_committed);

  FUNCEND dsp$system_committed;
?? OLDTITLE ??
?? NEWTITLE := 'dsp$update_image_values_in_ssr', EJECT ??

{ PURPOSE:
{   This procedure saves the offset in the image file to the beginning of the image and
{   the image length in the SSR for subsequent continuation deadstarts.
{
{ NOTE:
{   The recovery device file must be open for segment access when this procedure is called.

  PROCEDURE [XDCL] dsp$update_image_values_in_ssr;

    VAR
      image_size: integer,
      rdf_size: integer,
      ssr_entry: dst$ssr_entry;

    { Store the values saved in the RDF area.  The values in the RDF area reflect the current state of the
    { image file.  It is possible to be running a system that wants to build a larger image file but not able
    { to do it.

    dsp$get_integer_from_rdf (dsc$rdf_image_table_size, dsc$rdf_production, rdf_size);
    ssr_entry.whole_slot := rdf_size;
    dsp$store_entry_in_ssr (dsc$ssr_image_offset, dsc$ssr_whole_slot, ssr_entry);

    dsp$get_integer_from_rdf (dsc$rdf_image_size, dsc$rdf_production, image_size);
    ssr_entry.whole_slot := image_size;
    dsp$store_entry_in_ssr (dsc$ssr_image_length, dsc$ssr_whole_slot, ssr_entry);

  PROCEND dsp$update_image_values_in_ssr;
MODEND dsm$recovery_services;
*DECK DECK=DSM$RUN180 EXPAND=TRUE
.PROC,RUN180.

.IFE,(R2.EQ.1).AND.(EFG.EQ.0),RUNDSC.
   RETURN(NOSVETP)
.IFE,SYS=NOS,NOSSYS.
  RUNJOBS.
  $DSMRUN.
.ELSE,NOSSYS.
  RUNIRHF.
  DSMRUN.
.ENDIF,NOSSYS.
  REVERT.
  EXIT.
  DMD.
  DMD,0,200000.
  DAYFILE,OUTPUT.
  ROUTE,OUTPUT,DC=PR.
  RETURN,NOSVETP.
  REVERT.
.ENDIF,RUNDSC.

 REVERT. DSMRUN NOT RUN.
/EOR
*DECK DECK=DSM$RUNDSC EXPAND=TRUE
.PROC,RUNDSC*I,
C   "- COMMAND DECK"                   = (*N=,*S2(01234567)),
W   "- WAIT FOR OPERATOR INTERVENTION" = (*N=,FALSE=F,TRUE=T,F,T),
T   "- DEADSTART TYPE"                 = (*N=,CR,DISK,TAPE),
S   "- SCD PORT"                       = (*N=,0,1),
N   "- NVE SUBSYSTEM CPU PRIORITY"     = (*N=,*S2(01234567)),
.
.HELP
  THIS PROCEDURE SEQUENCES THROUGH THE VARIOUS DEADSTARTS AND
  RECOVERIES REQUIRED TO BRING UP NOS/VE AND TERMINATE IT
  WITH INTEGRITY IN THE PERMANENT FILE BASE.

.ENDHELP
.*
.*   JOB CONTROL REGISTER USAGE
.*
.*   EFG = 0,   NO ERRORS
.*         1    TO
.*         76B, NOS ERROR NUMBERS,
.*         77B, NOS/VE ERROR, R1G CONTAINS THE ERROR NUMBER.
.*
SET(R1G=0)
COMMENT.
COMMENT. START NVE DEADSTART/RECOVERY
COMMENT.
.IFE,SYS.NE.NOSB,NOSSYS1.
  SETTL,*.
  SETASL,*.
  SETJSL,*.
  .IF,$N$.NE.$$.SETPR(N)
.ENDIF,NOSSYS1.
SET(EFG=0)
DSTCMDS,C,W,T,S.
SET(R2=1)
WHILE,R2.NE.0.AND.EFG.EQ.0,PROCESS.
  DST180.
  TRM180.
  SET(R2=R1G)
  DISPLAY(R1G)
ENDW,PROCESS.
COMMENT.
COMMENT. COMPLETED NVE RUN.
COMMENT.
REVERT. END RUNDSC
/EOR
*DECK DECK=DSM$RUNIRHF EXPAND=TRUE
.PROC,RUNIRHF.
*IF ($string($name(wev$target_operating_system))='NOSBE')
.*
.*   THE RUNIRHF PROCEDURE RUNS THE IRHF HELPER JOB.
.*
.*   IF SWITCH 5 IS ON WHEN IRHF GOES DOWN, THE DUMP
.*   IS SENT TO THE PRINTER, IN ANY CASE, THE DUMP IS
.*   SAVED ON FILE IRHFDMP,ID=IRHFDMP AND COPIED TO THE
.*   SHORT DUMP FILE TAKEN BY THE NVE SUBSYSTEM WHEN IT
.*   TERMINATES ABNORMALLY.
.*
  REQUEST,IRHFJOB,*Q.
  COPYBF,JOB,IRHFJOB.
  ROUTE,IRHFJOB,DC=IN.
  REVERT. IRHF STARTED.
.DATA,JOB.
IRHF170,T0.
PURGE,IRHFDMP,ID=IRHFDMP.
SKIP,NODMP.
EXIT(U)
SET(EF=0)
BKSP(OUTPUT)
REQUEST(IRHFDMP,PF)
ENDIF,NODMP.
ATTACH,TEMP,LIDLIST,ID=NOSVE.
COPYBF,TEMP,LIDLIST.
RETURN(TEMP)
REWIND(LIDLIST)
COPY,INPUT,PRACCNT.
REWIND,PRACCNT.
RHPQEP.
EXIT(U)
DMD,0,150000.
REWIND,OUTPUT.
COPY,OUTPUT,IRHFDMP.
DAYFILE,IRHFDMP.
CATALOG,IRHFDMP,ID=IRHFDMP.
UNLOAD,IRHFDMP.
IFE,SW5,ROF.
  ROUTE,OUTPUT,DC=PR.
ENDIF,ROF.
DISPOSE,OUTPUT.
*ELSE
COMMENT. THIS PROCEDURE IS FOR NOS/BE ONLY.
*IFEND
.EOR
&JOB
/EOR
*DECK DECK=DSM$RUNJOBS EXPAND=TRUE
.PROC,RUNJOBS*I,
JN "HELPER JOB NAME" = (*N=BOTH, IRHF, PASSON, BOTH).
.HELP
 The RUNJOBS procedure RUNs the IRHF and PASSON helper jobs.
.ENDHELP
.IFE,$JN$.EQ.$PASSON$,PASSON.
  ROUTE,PASSJOB,DC=IN,OT=SYOT.
  REVERT. PASSON STARTED.
.ENDIF,PASSON.
.IFE,$JN$.EQ.$IRHF$,IRHF.
  ROUTE,IRHFJOB,DC=IN,OT=SYOT.
  REVERT. IRHF STARTED.
.ENDIF,IRHF.
.IFE,$JN$.EQ.$BOTH$,BOTH.
  ROUTE,PASSJOB,DC=IN,OT=SYOT.
  ROUTE,IRHFJOB,DC=IN,OT=SYOT.
  REVERT. IRHF AND PASSON STARTED.
.ENDIF,BOTH.
.DATA,PASSJOB.
PASSON,SC=NS.
USER,SYSTEMX,SYSTEMX.
NORERUN.
SETTL,*.
SETASL,*.
SETJSL,*.
USECPU(1)
PURGE,PASSDMP/NA.
OFFSW(1,2,3,4,5,6)
* SW1=NETDBG,   SW2=PASSDBG, SW3=MLIDBG
* SW4=PACERKLG, SW5=ROUTF,   SW6=PASSCHK
SET(EF=0)
OFFSW(6)
WHILE,.NOT.SW6,PASLOOP.
VEIAF.
EXIT.
DMD,0,150000.
IFE,EF.EQ.SSE.OR.EF.EQ.ODE.OR.EF.EQ.IDE,ABNDROP.
ONSW(6)
ENDIF,ABNDROP.
DEFINE,PASSDMP/NA,CT=PU,M=R.
REWIND,OUTPUT.
COPY,OUTPUT,PASSDMP.
DAYFILE,PASSDMP.
UNLOAD,PASSDMP.
IFE,SW5,ROF.
  ROUTE,OUTPUT,DC=LP.
ENDIF,ROF.
UNLOAD,OUTPUT.
ENDW,PASLOOP.
.DATA,IRHFJOB.
IRHF170,SC=NS.
USER,SYSTEMX,SYSTEMX.
NORERUN.
SETTL,*.
SETASL,*.
SETJSL,*.
USECPU(1)
PURGE,IRHFDMP/NA.
OFFSW(5)
* SW5=ROUTF
NOEXIT.
* CREATE LOCAL FILE TO USE FOR PARTNER JOB ACCOUNTING.
COPYBR,INPUT,PRACCNT.
REWIND,PRACCNT.
* CREATE LOCAL FILE TO CREATE THE LIDLIST FILE.
COPYBR,INPUT,GENFILE.
REWIND,GENFILE.
* SET R1 AND R2 TO THE TWO CHARACTER MACHINE ID.
$SET(R1=HID/100B)
$SET(R2=HID-(R1*100B))
* CALL PROC GENFILE TO CREATE LIDLIST FILE.
$BEGIN(,GENFILE,R1+B,R2+B)
RHPQEP.
DMD,0,150000.
DEFINE,IRHFDMP/NA,CT=PU,M=R.
REWIND,OUTPUT.
COPY,OUTPUT,IRHFDMP.
DAYFILE,IRHFDMP.
UNLOAD,IRHFDMP.
IFE,SW5,ROF.
  ROUTE,OUTPUT,DC=LP.
ENDIF,ROF.
UNLOAD,OUTPUT.
RETURN(GENFILE)
RETURN(LIDLIST)
RETURN(PRACCNT)
IFE,EF.NE.ODE.AND.EF.NE.OKE.AND.EF.NE.IDE.AND.EF.NE.SSE,NORMDRP.
  REQUEST,HELP. IRHF ABORTED.
ENDIF,NORMDRP.
.EOR
&JOB
USER,&USER,&PASSWORD,&FAMILY.
CHARGE,&CHARGE,&PROJECT.
USECPU(1)
.EOR
.EXPAND(OFF)
.PROC,GENFILE*I
,C1 [1ST CHARACTER OF MACHINE ID]
    =(1=A, 2=B, 3=C, 4=D, 5=E, 6=F, 7=G,
      10=H, 11=I, 12=J, 13=K, 14=L, 15=M, 16=N, 17=O,
      20=P, 21=Q, 22=R, 23=S, 24=T, 25=U, 26=V, 27=W,
      30=X, 31=Y, 32=Z, 33=0, 34=1, 35=2, 36=3, 37=4,
      40=5, 41=6, 42=7, 43=8, 44=9)
,C2 [2ND CHARACTER OF MACHINE ID]
    =(1=A, 2=B, 3=C, 4=D, 5=E, 6=F, 7=G,
      10=H, 11=I, 12=J, 13=K, 14=L, 15=M, 16=N, 17=O,
      20=P, 21=Q, 22=R, 23=S, 24=T, 25=U, 26=V, 27=W,
      30=X, 31=Y, 32=Z, 33=0, 34=1, 35=2, 36=3, 37=4,
      40=5, 41=6, 42=7, 43=8, 44=9).
GET,LIDLIST=LIDVE_C1_C2/NA.
REVERT. GENFILE
EXIT. GENFILE
REVERT(ABORT) GENFILE
/EOR
*DECK DECK=DSM$RUN_VE EXPAND=TRUE
?? RIGHT := 110 ??
MODULE dsm$run_ve ALIAS 'DSMRUN';

*copy pxiotyp
*copy dsc$constant_definitions
*copy dsd$os_global_variables
*copy dsp$dst_global_variables
*copy dsc$job_control_registers
*copy dsp$callsda
*copy dsi$deadstart_utilities
*copy dsi$virtual_memory_access
*copyc dsi$c170_access_to_ssr
*copy dsi$transmit_data_via_ssr
*copyc dsi$display_dayfile_message
?? NEWTITLE := '~~~~~   Request resources at run time', EJECT ??
{*********************************************************}

*copyc dsp$claim_nve_resources

?? TITLE := 'dsp$check_if_ve_running', EJECT ??

{ PURPOSE:
{   This procedure checks if the NOS/VE system is running.  If it is
{   not, it issues a fatal error and aborts this subsystem step.
{ NOTES:
{   If NOS/VE is not running this subsystem step is aborted and control
{   is not returned to the caller.

  PROCEDURE [XDCL] dsp$check_if_ve_running;

    VAR
      ve_status: integer;


      get_ve_status (ve_status);
      IF exitcd = 0 THEN
        error_processor (nosve_down, fatal_error);
      IFEND;

  PROCEND dsp$check_if_ve_running;

?? TITLE := 'dsp$nve_resource_interface', EJECT ??

  PROCEDURE [XDCL] dsp$nve_resource_interface;

    VAR
      block: ^SEQ ( * ),
      nve_request_p: ^dst$170_request_block,
      rma: integer;

      jcrget;
      dsp$receive_data_via_ssr (block);
      IF block <> NIL THEN
        dyfstring ('Process ve request.', debug_log);
        NEXT nve_request_p IN block;
        CASE nve_request_p^.request OF

        = dsc$170_rb_request_resources, dsc$170_rb_update_free_clock =
          dsp$claim_nve_resources (nve_request_p^);

        = dsc$170_rb_call_dft_through_sda =
          rma := nve_request_p^.dft_request_rma DIV 8;
          pp_table.ssr_buffer.offset := rma MOD 100(8);
          pp_table.ssr_buffer.rlower := (rma DIV 100(8)) MOD 10000(8);
          pp_table.ssr_buffer.rupper := rma DIV 1000000(8);
          callsda (call_dft, pp_table);

        ELSE
          error_processor (incorrect_nve_request, fatal_error);
        CASEND;
        dsp$send_data_via_ssr (block, #SIZE (block^));
        FREE block;
      IFEND;

  PROCEND dsp$nve_resource_interface;
?? TITLE := 'dsp$nve_down_condition', EJECT ??

  PROCEDURE [XDCL] dsp$nve_down_condition ALIAS 'nvedwn';
    error_processor (nosve_down, fatal_error);
  PROCEND dsp$nve_down_condition;

MODEND dsm$run_ve;
*DECK DECK=DSM$SAVEDAY EXPAND=TRUE
.PROC,SAVEDAY*I,
DF   "- DAYFILE TYPE"                  = (
                                      0=CONTDYF,1=TESTDYF,2=RECVDYF,3=TESTDYF,
                                      4=TESTDYF,5=TESTDYF,6=TESTDYF,7=INSTDYF,
                                      8=RECODYF,9=DMPIDYF)
.
.HELP
THIS PROCEDURE SAVES THE DAYFILE ON A DEADSTART TYPE
  DEPENDENT FILE NAME.

.ENDHELP
$UNLOAD(DF)
$DAYFILE(DF)
REPFILE,DF)
$REVERT.
/EOR
*DECK DECK=DSM$SAVE_SYSTEM_INFORMATION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Save System Information' ??
MODULE dsm$save_system_information;

{ PURPOSE:
{   This module saves information vital to system operation across deadstarts.  Information is stored on a
{   device file residing on the system device created during an installation deadstart.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dsc$system_log_file_size
?? POP ??
*copyc dmp$create_device_file
*copyc dmp$detach_device_file
?? EJECT ??
*copy dmv$system_device_information
?? TITLE := 'dsp$create_system_file', EJECT ??

  PROCEDURE [XDCL] dsp$create_system_files
    (VAR status: ost$status);

    VAR
      file_attributes: ARRAY [1 .. 1] OF dmt$new_device_file_attribute,
      file_modified: boolean,
      fmd_modified: boolean,
      recorded_vsn: rmt$recorded_vsn,
      system_file_id: dmt$system_file_id,
      user_supplied_name: ost$name;

    status.normal := TRUE;

    user_supplied_name := 'DSF$SYSTEM_INFORMATION';
    recorded_vsn := dmv$system_device_recorded_vsn;

    file_attributes [1].keyword := dmc$file_limit;
    file_attributes [1].limit := UPPERVALUE (amt$file_limit);

    dmp$create_device_file (user_supplied_name, recorded_vsn, ^file_attributes, 0, system_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$detach_device_file (system_file_id, file_modified, fmd_modified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    user_supplied_name := 'LGF$SYSTEM_LOG';

    dmp$create_device_file (user_supplied_name, recorded_vsn, ^file_attributes, dsc$system_log_file_size,
        system_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$detach_device_file (system_file_id, file_modified, fmd_modified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND dsp$create_system_files;
MODEND dsm$save_system_information;
*DECK DECK=DSM$SETVE EXPAND=TRUE
.PROC,SETVE*I,
PN  "- NVE Procedure Name suffix"      = (*N=,
                           *S4(ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890)),
UN  "- User Name for NVE subsystem"    = (*F),
P   "- Password for NVE user name"     = (*N=,*F,*R),
C   "- Command deck number for DCF<c>" = (*N=,*S2(01234567)),
W   "- Wait for operator intervention" = (*N=,FALSE=F,TRUE=T,F,T),
T   "- Deadstart type                " = (*N=,CR,DISK,TAPE,D=DISK,T=TAPE),
S   "- SCD PORT"                       = (*N=,0,1),
N   "- NVE subsystem CPU priority"     = (*N=,*S2(01234567)),
.
.HELP
 The SETVE procedure creates a NVEffff procedure file on SYSTEMX
 with the necessary parameters to deadstart a NOS/VE system.
 The procedures MSSIRHF and MSSPASS are also created on SYSTEMX
 for restarting IRHF and PASSON.
 On NOS/BE, the NVEffff procedure file is made permanent with an ID
 equal to the UN parameter.

 Parameter   Default   Description
   Name       Value

  [pn]                 four character alphanumeric procedure suffix
   un                  user name from which to deadstart NOS/VE
  [p]         un_X     password for user name
  [c]          01      octal command deck number
  [w]         true     boolean wait for operator intervention value
  [s]           0      port used to run SCD
  [n]                  NVE subsystem CPU priority

.HELP,PN
 The PN parameter specifies a four character alphanumeric suffix
 appended to the procedure name NVE. The default is a null string.
.HELP,UN
 The UN parameter specifies the user name from which NOS/VE is
 deadstarted. The NOS/VE deadstart files are retained here, and
 any run time subsystem changes are contained on user library DSTLIB.
 On NOS/BE, this is the permanent file ID of the deadstart files.
.HELP,P
 The P parameter specifies the password for the UN user name.
 The default is the UN parameter with a concatenated X suffix.
.HELP,C
 The C parameter selects the octal command deck number to use from the
 deadstart file, of the form DCF<c>. The default is assigned in the
 DSTCMDS procedure.  This parameter will be ignored at L739.
.HELP,W
 The W parameter specifies a boolean value which selects whether to
 wait for operator intervention at the NOS/VE core commands display.
 The default value is TRUE.
.HELP,T
 The T parameter selects the deadstart type.  CR selects a deadstart
 useing the installed defaults.  TAPE or T selects a deadstart from
 TAPE and DISK or D selects a deadstart from an alternate disk device.
 This parameter will be ignored at L739.
.HELP,S
 The S parameter selects the port of the two port mux which the system
 console will use to communicate with the operator.
.HELP,N
 The N parameter selects a CPU priority for the NVE subsystem on NOS.
 If specified, the NVE subsystem will issue a SETPR command to set the
 CPU priority to the value.  However, if the specified value is less
 than the lower bound for the subsystem service class, then the NOS
 system will automatically raise the priority to the lower bound.
 This parameter is ignored on NOS/BE.
.ENDHELP
.IFE,SYS=NOS,NOSSYS.
  $USER,SYSTEMX,SYSTEMX.
  $REPLACE,NVE_PN.
  $REPLACE,MSSIRHF.
  $REPLACE,MSSPASS.
.ELSE,NOSSYS.
  LIBRARY,NVELIB.
  REQUEST,YYYYNVE,PF.
  COPYBF,NVE_PN,YYYYNVE.
  REPFILE,YYYYNVE,NVE_PN,,,,UN.
  RETURN,YYYYNVE,MSSPASS,MSSIRHF.
.ENDIF,NOSSYS.
REVERT. END SETVE
.DATA,NVE_PN.
.PROC,NVE_PN.
.IFE,SYS=NOS,NOSSYS2.
.IFE,$P$.EQ.$$,CHANGEPW.
  $USER,UN,UN_X.
.ELSE,CHANGEPW.
  $USER,UN,P.
.ENDIF,CHANGEPW.
$COMMON,SYSTEM.
$GTR,SYSTEM,NVELIB,U.ULIB/NVELIB
$UNLOAD,SYSTEM.
$ATTACH,DSTLIB/#UN=UN,NA.
IFE,FILE(DSTLIB,AS),USERDSTLIB.
  $LIBRARY,DSTLIB.
ENDIF,USERDSTLIB.
$LIBRARY,NVELIB/A.
.ELSE,NOSSYS2.
  LIBRARY,NVELIB.
  GETFILE,DSTLIB,,UN,READ.
  IFE,FILE(DSTLIB,AS),FNDDST.
    LIBRARY,DSTLIB.
  ENDIF,FNDDST.
.ENDIF,NOSSYS2.
RUNDSC,C,W,T,S,N.
REVERT. END NVE_PN
.DATA,MSSIRHF
.PROC,MSSIRHF.
$COMMON,SYSTEM.
$GTR,SYSTEM,NVELIB,U.ULIB/NVELIB
$UNLOAD,SYSTEM.
$ATTACH,DSTLIB/#UN=UN,NA.
IFE,FILE(DSTLIB,AS),USERDSTLIB.
  $LIBRARY,DSTLIB.
ENDIF,USERDSTLIB.
$LIBRARY,NVELIB/A.
RUNJOBS,IRHF.
$REVERT. END MSSIRHF
.DATA,MSSPASS
.PROC,MSSPASS.
$COMMON,SYSTEM.
$GTR,SYSTEM,NVELIB,U.ULIB/NVELIB
$UNLOAD,SYSTEM.
$ATTACH,DSTLIB/#UN=UN,NA.
IFE,FILE(DSTLIB,AS),USERDSTLIB.
  $LIBRARY,DSTLIB.
ENDIF,USERDSTLIB.
$LIBRARY,NVELIB/A.
RUNJOBS,PASSON.
$REVERT. END MSSPASS
/EOR
*DECK DECK=DSM$START_ALL_CPUS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Start processors' ??
MODULE dsm$start_all_cpus;

{ PURPOSE:
{   This module contains the procedure that is used to start additional processors during deadstart.  It will
{   request to start all CPUs, except the deadstart CPU, which is on according to CTI.  Also, it contains
{   procedures which will change the way memory is purged in the event of the addition or removal of a
{   processor to/from the mainframe configuration.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osc$multiprocessor_constants
*copyc osc$processor_defined_registers
*copyc ost$processor_id
?? POP ??
*copyc dsp$get_cpu_attributes
*copyc dsp$start_additional_cpu
*copyc osp$get_global_cpu_model_def
?? EJECT ??
*IF $variable(mmv$test_forced_use_cache_maps, declared) <> 'UNKNOWN'
*copyc mmv$force_use_of_cache_and_maps;
*ELSE
{ -------- Variable declarations for forcing the use of cache and maps omitted at compile time --------
*IFEND
*copyc mmv$multiple_caches
*copyc mmv$multiple_page_maps
*copyc mtv$all_cpus_have_been_started
*copyc mtv$cst0
*copyc mtv$scb
*copyc osv$cpus_physically_configured
*copyc tmv$multiple_cpus_active
?? OLDTITLE ??
?? NEWTITLE := 'dsp$start_all_cpus', EJECT ??

{ PURPOSE:
{   This procedure will start additional CPUS during deadstart.
{
{ WARNING!
{   This procedure is to be called during deadstart ONLY!.  Any other call to this procedure elsewhere will
{   produce unpredictable results, although there is a good possibility that the system will crash.

  PROCEDURE [XDCL, #GATE] dsp$start_all_cpus;

    VAR
      cpu_attributes: dst$cpu_attributes,
      cpu_index: 0 .. (osc$max_number_of_processors - 1),
      global_processor_model_def: ost$processor_model_definition;



{ The following variable is set to TRUE if we are running in NOS/CPU1 dedicated
{ mode. This implies only NOS runs in CPU 1, VE and NOS share CPU 0.

  VAR
   mtv$cpu1_dedicated_to_nos: [XREF] boolean;

   IF mtv$cpu1_dedicated_to_nos THEN
{ Don't monkey with the other processor.
     RETURN;
   IFEND;


    dsp$get_cpu_attributes (cpu_attributes);

    mtv$scb.vector_simulation_control.all_vector_divides_degraded := TRUE;
    FOR cpu_index := 0 TO osv$cpus_physically_configured - 1 DO

      { Don't "start" the processor which is executing this code.

      IF cpu_index <> #READ_REGISTER (osc$pr_maintenance_id) THEN
        IF mtv$cst0 [cpu_index].next_processor_state = cmc$on THEN
          osp$get_global_cpu_model_def (global_processor_model_def);
          mmv$multiple_caches := global_processor_model_def.cache_present;
          mmv$multiple_page_maps := global_processor_model_def.maps_present;
          dsp$start_additional_cpu (cpu_index);
        IFEND;

        IF NOT cpu_attributes.cpu [cpu_index].vectors_not_available THEN
          mtv$scb.vector_simulation_control.all_vector_divides_degraded := FALSE;
        IFEND;

        mtv$cst0 [cpu_index].processor_state := mtv$cst0 [cpu_index].next_processor_state;

        { TMV$MULTIPLE_CPUS_ACTIVE is the variable used to prevent any harmful system effects from a site
        { setting DEDICATE_A_CPU_TO_NOS TRUE and only having one cpu present. The SETSA mechanism is not
        { smart enough to detect when this would be a harmful action. The variable OSV$MULTIPROCESSOR_RUNNING
        { has the same meaning; however, the setting and resetting of OSV$MULTIPROCESSOR_RUNNING is too late.
        { There is too large of a window in which we could potentially never run NOS/VE tasks again.

        IF mtv$cst0 [cpu_index].processor_state = cmc$on THEN
          tmv$multiple_cpus_active := TRUE;
          mtv$cst0 [cpu_index].dispatching_priority_integer := 0;
        IFEND;
      ELSE
        IF NOT cpu_attributes.cpu [cpu_index].vectors_not_available THEN
          mtv$scb.vector_simulation_control.all_vector_divides_degraded := FALSE;
        IFEND;
      IFEND;
    FOREND;

    mtv$all_cpus_have_been_started := TRUE;

*IF $variable(mmv$test_forced_use_cache_maps, declared) <> 'UNKNOWN'

    { The following code is benchmark code to force use of cache and/or maps during benchmark runs.

    mmv$multiple_caches := mmv$multiple_caches OR mmv$force_use_of_cache_and_maps;
    mmv$multiple_page_maps := mmv$multiple_page_maps OR mmv$force_use_of_cache_and_maps;
*ELSE
{ -------- Code for forcing the use of cache and maps omitted at compile time --------
*IFEND

  PROCEND dsp$start_all_cpus;
?? OLDTITLE ??
MODEND dsm$start_all_cpus;
*DECK DECK=DSM$SYSTEM_STATUS_RECORD EXPAND=TRUE
          IDENT  SSR,70B                                                
          CIPPU  J                                                      
          TITLE  DSM$SYSTEM STATUS RECORD (SSR)                         
          COMMENT *SMD* LVL=03                                          
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992              
          SPACE  4,10                                                   
***       SSR - SYSTEM STATUS RECORD.                                   
*         B. R. HANSON.  85/04/41.                                      
          SPACE  4,10                                                   
***              DSMSSR IS A TEMPLATE FOR THE DIRECTORY FOR THE SYSTEM  
*         STATUS RECORD WHICH IS A MEANS OF COMMUNICATING BETWEEN       
*         NOS/VE, DEADSTART PPS, THE 170 OS, AND FUTURE DEADSTARTS OF   
*         NOS/VE.                                                       
          SPACE  4,10                                                   
***       ROUTINES USED.                                                
*                                                                       
                                                                        
                                                                        
*copy dsi$pp_macros                                                     
          SPACE  4,10                                                   
          TITLE  DIRECT LOCATION ASSIGNMENT.                            
****      DIRECT LOCATION ASSIGNMENT.                                   
                                                                        
                                                                        
          ORG    70B                                                    
          VFD    32/SSRL                                                
          VFD    32/SSRIL                                               
          ORG    76B         LOGICAL PP NUMBER OF SSR DATA              
          CON    17B                                                    
                                                                        
****                                                                    
          EJECT                                                         
**        SSR DIRECTORY TEMPLATE.                                       
*         DEFINES THE INITIAL FORMAT OF THE SSR THAT IS LOADED          
*         AT DEADSTART TIME.                                            
*                                                                       
*         NOTE:  ADDING A NEW ENTRY REQUIRES CHANGING THE DECK          
*         *DSC$SSR-ENTRY-CONSTANTS TOO.                                 
*                                                                       
                                                                        
                                                                        
          ORG    100B                                                   
                                                                        
 SSRO     SET    0           CURRENT SSR OFFSET                         
                                                                        
*                                                                       
*         SSRW - MACRO USED TO DEFINE THE SSR DIRECTORY.  AN SSR        
*         DIRECTORY IS OF ONE OF THE FOLLOWING FORMATS:                 
*                VFD     32/NAME                                        
*                VFD     32/VALUE                                       
*           OR                                                          
*                VFD     32/NAME                                        
*                VFD     16/LEFT - LEFT HALF OF VALUE.   LENGTH OF SSR  
*                               SEQUENCE.                               
*                VFD     16/RIGHT - RIGHT HALF OF VALUE.  OFFSET FROM   
*                               BEGINNING OF SSR OF THIS SSR SEQUENCE.  
*                                                                       
*         CALL:                                                         
*         SSRW   NAME,L,R    DEFINE *NAME* *L* *R* FORMAT OF ENTRY.     
*                NAME - SSR DIRECTORY ENTRY NAME.                       
*                L    - VALUE OR CHARACTER *B*.  IF *B* IS SPECIFIED    
*                       THAN AN SSR SEQUENCE IS BEING DEFINED.  THE     
*                       OFFSET IS DETERMINED FROM THE SYMBOL *SSRO*.    
*                       DEFINES RIGHT HALF OF VALUE.                    
*                R    - LENGTH OF SSR SEQUENCE.  DEFINES LEFT HALF      
*                       OF VALUE.  LENGTH IS DEFINED IN 64 BIT WORDS.   
*         SSRW   NAME,L      DEFINE *NAME* *VALUE* FORMAT OF ENTRY.     
*                NAME - SSR DIRECTORY ENTRY NAME.                       
*                L    - SPECIFIES THE 32 BIT VALUE.                     
*                                                                       
                                                                        
 SSRW     MACRO  NAME,L,R                                               
          DATA   4H_NAME                                                
 .1       IFC    NE,$R$$                                                
          CON    R                                                      
 .2       IFC    EQ,$L$B$                                               
          CON    SSRIL+SSRO                                             
 SSRO     SET    SSRO+R                                                 
 .2       ELSE                                                          
          CON    L 0                                                    
 .2       ENDIF                                                         
 .1       ELSE                                                          
          VFD    32/L                                                   
 .1       ENDIF                                                         
          ENDM                                                          
                                                                        
 SSRI     BSS    0           SSR DIRECTORY IMAGE                        
          SSRW   SSRD,,SSRIL DEFINE SSR DIRECTORY                       
          SSRW   SSRS,,SSRL  SSR SIZE                                   
          SSRW   DTYP,0      DEADSTART TYPE                             
          SSRW   RUNS,0      RUN SEQUENCING STATUS                      
          SSRW   SDST,0      SYSTEM DEADSTART STATE                     
          SSRW   BYVE,0      SYSTEM TERMINATION STATUS                  
          SSRW   IMGS,3      IMAGE STATE                                
          SSRW   IMGL,0      IMAGE LENGTH                               
          SSRW   IMGO,0      IMAGE OFFSET                               
          SSRW   C80B,B,1    C180 INTERCHANGE BUFFER                    
          SSRW   C70B,B,1    C170 INTERCHANGE BUFFER                    
          SSRW   MEMB,B,1    FWA/LWA OF AREA TO LOAD PT COPY AND VCMB   
          SSRW   DFTB,B,4    DFT BUFFER                                 
          SSRW   SMUB,B,4    SMU BUFFER                                 
          SSRW   BPTR,B,30   BOOT POINTER BLOCK                         
          SSRW   NAME,B,4    IMAGE STATUS NAME                          
          SSRW   VEPP,B,28   PPS/CHANNELS ASSIGNED                      
          SSRW   HDWR,B,20   INITIAL HARDWARE STATE                     
          SSRW   DSAV,B,16   DEADSTART REGISTER SAVE AREA               
          SSRW   RSAV,B,64   RECOVERY SAVE AREA                         
          SSRW   CREP,B,72   CORE POINTER LIST                          
          SSRW   DRCP,B,4096/4   DRIVER CODE BUFFER                     
*         SSRW   PPBF,B,20396/4  PP/CONTROLWARE BUFFER *OLD VALUE.      
          SSRW   PPBF,B,49152/8  PP/CONTROLWARE BUFFER                  
          SSRW   RIHT,B,1    R-REGISTER OF INITIAL HASH TABLE           
                                                                        
*         THE FOLLOWING ENTRY MUST BE UPDATED TO REFLECT CHANGES MADE   
*         IN SYC$SSR_SYSTEM_LEVEL_NUMBER.  THE VALUES MUST BE EQUAL IN  
*         BOTH PLACES.                                                  
*                                                                       
*         FORMAT OF ENTRY IS:                                           
*                SYSL,BCU LEVEL NUMBER, RELEASED LEVEL NUMBER           
                                                                        
          SSRW   SYSL,0,780  SYSTEM LEVEL NUMBER                        
          SSRW   DFTS,B,2    SECONDARY DFT BUFFER LEFT FOR BACK LEVEL   
          SSRW   STAT,B,640/8  SYSTEM DEADSTART STATUS STATISTIC DATA   
          SSRW   SCKS,0      SSR CHECKSUM                               
          SSRW   WAIT,1      OPERATOR INTERVENTION FLAG                 
          SSRW   SCPT,B,4    SCI PARAMETER TABLE                        
          SSRW   SSDE        SSR DIRECTORY END                          
 SIZE     SET    *-SSRI      SSR DIRECTORY IMAGE LENGTH                 
 SSRIL    EQU    SIZE/4                                                 
                                                                        
 SSRO     SET    SSRO+777                                               
 SSRL     EQU    SSRO/1000*1000  SSR LENGTH                             
                                                                        
          END                                                           
/EOR                                                                    
*DECK DECK=DSM$TERMINATE_NOS_VE EXPAND=TRUE
?? RIGHT := 110 ??
MODULE dsm$terminate_nos_ve ALIAS 'DSMTNVE';

*copy pxiotyp
?? PUSH (LISTEXT := ON) ??
*copy pxziobs
*copy bizput
*copy bizclos
*copy bizweor
*copy bizweof
*copy bizopen
*copy lgzgetp
*copy fzmark
*copy fzwords
*copy zutpw2h
*copyc zutpifl
?? POP ??
*copy dsc$constant_definitions
*copyc dst$deadstart_condition
*copyc dst$dft_request_codes
*copyc dst$dual_state_control_block_cc
*copy dsp$dst_global_variables
*copy dsc$job_control_registers
*copyc ost$hardware_subranges
*copy dsd$os_global_variables
*copyc dsp$callsda
*copyc dsp$callver

{  Define variables global to this module.

  VAR

{  Real memory word address for DFT request relative to pva type.

    dft_request_rmwa: ost$real_memory_address,

{  Byte rma of DFT request relative to pva type.

    dft_request_byte_rma: ost$real_memory_address,
    dft_request_r_pointer: dst$r_pointer,
    dft_request_pva_type: starting_pva;  { PVA type of area for DFT request.

{  Define constants global to this module.

    CONST
      normal_dft_response = 1;

*copy dsi$display_dayfile_message
*copy dsi$virtual_memory_access
*copyc dsi$support_eicb_version_4
*copy dsi$define_hardware_config
*copy dsi$deadstart_utilities
*copy dsi$k_display_control
*copy dsi$deadstart_command_processor
*copyc dsi$c170_access_to_ssr
*copyc dsi$termination_edd_dump
?? TITLE := 'determine_memory_limits', EJECT ??

{ PURPOSE:
{   Determine how much memory is assigned to NOS/VE.

    PROCEDURE determine_memory_limits;

      ver_request.general_status := 0;
      ver_request.length := 2;
      ver_request.cm_block.words_div_1000 := 0;
      ver_request.cm_block.lwa_div_1000 := 0;
      callver (ver_request, stcm, TRUE);

      IF ver_request.general_status = 1 THEN
        load_offset_bytes := ver_request.cm_block.fwa_div_1000 *
             bytes_per_octal_1k_words;
        nve_memory := ver_request.cm_block.lwa_div_1000 *
             bytes_per_octal_1k_words - load_offset_bytes;
      ELSE
        nve_memory := 0;
        load_offset_bytes := 0;
      IFEND;

    PROCEND determine_memory_limits;
?? TITLE := 'idle_secondary_ious', EJECT ??

{ PURPOSE:
{   This procedure idles all PPs (including DFT) in all secondary IOUs and
{   all channels are reset to the deadstart state.

  PROCEDURE idle_secondary_ious;

{  Define type definition for the DFT request to idle all PPs in secondary
{  IOU and reset channels to deadstart state.  In the DFT world this is a
{  64 bit structure but it is defined in 60 bits in the 170 world, each 60
{  bit word is moved into a 64 bit word right justified.

    TYPE
      dft_idle_iou_request = PACKED RECORD

{  Word 0.

        dft_response: 0 .. 0f(16),
        dft_function: 0 .. 0ff(16),
        iou_number: 0 .. 0ff(16),
        sub_function: 0 .. 0ff(16),
        fill: 0 .. 0ffffffff(16),
      RECEND;

    VAR
      cri {configuration record index}: integer,
      idle_iou_request: dft_idle_iou_request;

    cri := 1;

{  Initialize SDA request block to write DFT request.

    pp_table.dft_request_length := 1;
    pp_table.fill2 := 0;
    pp_table.ve_dft_request_p.offset := dft_request_r_pointer.offset;
    pp_table.ve_dft_request_p.rupper := dft_request_r_pointer.rupper;
    pp_table.ve_dft_request_p.rlower := dft_request_r_pointer.rlower;
    pp_table.fill4 := 0;
    pp_table.os_170_dft_request_p := ^idle_iou_request;

{  Initialize DFT request for idling secondary IOUs.

    idle_iou_request.dft_response := 0;
    idle_iou_request.dft_function := dsc$dft_idle_all_pps_and_chs;
    idle_iou_request.iou_number := 0;
    idle_iou_request.fill := 0;

    WHILE configuration_record [cri].iou.size > 0 DO

      CASE configuration_record [cri].iou.id OF

      = dsc$id_iou_info =
        IF idle_iou_request.iou_number > 0 THEN

{  Issue function to idle all PPs except DFT and set all channels in the
{  deadstart state.

          dyfstrnum ('IDLE IOU', idle_iou_request.iou_number, user_dayf);
          idle_iou_request.sub_function := 0;
          callsda (write_dft_request_block, pp_table);
          IF idle_iou_request.dft_response <> normal_dft_response THEN
            dyfstring (' Abnormal response idling PPs and CHS.', user_dayf);
          IFEND;

{  Issue DFT request to idle DFT in the secondary IOU.

          idle_iou_request.dft_response := 0;
          idle_iou_request.sub_function := 1;
          callsda (write_dft_request_block, pp_table);
          IF idle_iou_request.dft_response <> normal_dft_response THEN
            dyfstring (' Abnormal response idling DFT-S.', user_dayf);
          IFEND;
        IFEND;

        idle_iou_request.iou_number := idle_iou_request.iou_number + 1;
      ELSE

      CASEND;

      cri := cri + 1;
    WHILEND;

  PROCEND idle_secondary_ious;
?? TITLE := 'return_pps_channels', EJECT ??

{ PURPOSE:
{   Return peripheral processors and channels to c170 environment.

  PROCEDURE return_pps_channels;

    VAR
      d8st_word: dst$dscb_cc_d8st_word;

?? SKIP := 3 ??

    PROCEDURE idle_ve_pp
      (    pp: integer);

      ver_request.return_all := FALSE;
      ver_request.general_status := 0;
      ver_request.length := 1;
      ver_request.pp.primary := pp;
      ver_request.pp.kind := non_driver_pp;
      IF d7ty.eicb_version < dsc$eicb_version_4 THEN
         { use pre 2.5.1 code on ver request
         callver (ver_request, stpp, TRUE);
      ELSE
         { try new ( ie. NOS 2.5.1 ) request code
         callver (ver_request, stpt, TRUE);
      IFEND;
      IF ver_request.general_status <= 1 THEN
        pp_table.pp_number := pp;
        callsda (idle_pp, pp_table);
      IFEND;

    PROCEND idle_ve_pp;
?? SKIP := 3 ??

{  Check for and idle SCI and SCD prior to returning them via VER.
{  SCI is not returned if it is running as SCD or MDD for the host operating
{  system.

    get_dscb (dscb_d8st, ^d8st_word, 1);

    IF d8st_word.nosve_owns_sci_pp THEN

 {  SCI is not running as SCD or MDD for host operating system, return it.

      idle_ve_pp (d8st_word.sci_pp_number);
      d8st_word.sci_pp_number := 0;
      d8st_word.scd_port := 0;
      d8st_word.nosve_owns_sci_pp := FALSE;
    IFEND;

    idle_ve_pp (d8st_word.scd_pp_number);
    d8st_word.scd_pp_number := 0;
    d8st_word.operator_action := FALSE;

{  Return all channels to os.

    IF d7ty.eicb_version < dsc$eicb_version_4 THEN
    { use pre 2.5.1 code on ver request
       return_all (rtch);
    ELSE
    { use  2.5.1 code on ver request
       return_all (rnct);
    IFEND;

{  Return recovered pp to os.

    IF d7ty.eicb_version < dsc$eicb_version_4 THEN
    { use pre 2.5.1 code on ver request
       return_all (rtpp);
    ELSE
    { use  2.5.1 code on ver request
       return_all (rnpt);
    IFEND;

{  Update dual state control block.

    put_dscb (dscb_d8st, ^d8st_word, 1);

  PROCEND return_pps_channels;
?? TITLE := 'return_all', EJECT ??

  PROCEDURE return_all
    (    fcall: ver_functions);

    ver_request.return_all := TRUE;
    ver_request.general_status := 0;
    ver_request.length := 0;
    callver (ver_request, fcall, TRUE);
    IF ver_request.general_status > 1 THEN
      dyfstring ('Unable to return nve resources.', system_dayf);
    IFEND;

  PROCEND return_all;
?? TITLE := 'return_central_memory', EJECT ??

{ PURPOSE:
{   Return all central memory to the c170 operating system.

  PROCEDURE return_central_memory;

    VAR
      ssrptr: integer;

    jcr.global_r1 := $INTEGER (dsc$deadstart_condition_empty); { Inhibit recycle.
    ssrptr := 0;
    set_ei_pva (start_of_ve, 0);
    put_dscb (dscb_ssrptr, ^ssrptr, 1);
    set_ei_pva (start_of_ssr, 0);
    return_all (rtcm);
    dyfstring ('VE memory returned.', user_dayf);

  PROCEND return_central_memory;
?? TITLE := 'notify_operator', EJECT ??

  PROCEDURE [XDCL] notify_operator ALIAS 'DSPNO'
    (    msg: string ( * ));

    VAR
      i: integer;

    VAR
      s: string (40);

    s (1) := '$';
    s (2, 39) := msg;
    dyfstring (msg, system_dayf);
    dyfstring (s, bdisplay_line2);
    i := 0;
    REPEAT
      i := i + 1;
      wakeup;
    UNTIL i = 500;

  PROCEND notify_operator;
?? TITLE := 'terminate_cpu', EJECT ??

{ PURPOSE:
{   This procedure waits for the 170 trap handler to be running in EI, dumps NOS/VE
{   resources if specified and returns PPs, channels and equipment assigned
{   to NOS/VE.

  PROCEDURE terminate_cpu;

    VAR
      entry: integer,
      index: integer,
      left: integer,
      right: integer,
      save_global_r1: 0 .. 0777777(8);

    dyfstring ('cpu state switch', debug_log);

{  Wait for the 170 trap handler to be running in EI and not NOS/VE monitor.

    REPEAT
      deadstart_cpu (term_dual_state);
    UNTIL exitcd = 0;

{  Return all channels and equipment to host OS.  Need a tape channel and drive for dump.

    dyfstring ('returning channels and equipment.', debug_log);

    IF d7ty.eicb_version < dsc$eicb_version_4 THEN
    { use pre 2.5.1 code on ver request
       return_all (rtch);
    ELSE
    { use  2.5.1 code on ver request
       return_all (rnct);
    IFEND;

    return_all (rteq);

    IF take_dump THEN

{  Set global R1 to indicate dumping NOS/VE.  If abort while dumping because of tape
{  error will try again.  Restore to incoming value if dump completes successfully.

      save_global_r1 := jcr.global_r1;
      jcr.global_r1 := $INTEGER (error_dumping_nos_ve);
      jcrset;
      nosve_edd_dump;
      jcr.global_r1 := save_global_r1;
    IFEND;

    dyfstring ('returning pp-s.', debug_log);
    return_pps_channels;

  PROCEND terminate_cpu;
?? TITLE := 'dsptnve', EJECT ??

{ PURPOSE:
{   Begin NOS/VE termination, initial entry point for DSMTRM.

  PROGRAM [XDCL] dsptnve;

    VAR
      byeve: integer,
      dscb_ssr: dst$r_pointer,
      entry: integer,
      error: boolean,
      i: integer,
      left: integer,
      logical_cm_gt_256_mb: boolean,
      nve_memory_gt_64_mb: boolean,
      permsg: ^ARRAY [0 .. 54] OF string (40),
      ppbf_entry_offset: integer,
      ppbf_length: integer,
      ppbf_offset: integer,
      right: integer;

    makscpb; { make me a busy system controlpoint }

{  Prepare to read the command file.

    convert_title ('  TERMINATE VE  ');

{  Set line position for scrolling part of the screen.  This is set to
{  last line + 1 of the termination K display.  The maximum number allowed
{  for this value is 'header_line + 19'.

    line_position := header_line + 19;
    beginning_line_position := line_position;

{  Initialize K display control variables for VE termination.

    clear_screen;
    show_message ('NOS/VE TERMINATION IN PROGRESS.', header_line + 1,
          no_scroll);

{  Define file names and open dump file.

    px#iobs := large_jobs; { for faster transfers }

    jcrget;
    r1g_error_flag := $INTEGER (ok);
    IF jcr.global_error_flag = 77(8) THEN
      r1g_error_flag := jcr.global_r1; {deadstart error}
    ELSEIF jcr.global_error_flag <> 0 THEN
      r1g_error_flag := $INTEGER (fatal_170_error);
    IFEND;
    set_configuration;

{  Save the EICB version number from the EICB.  The EICB version number is used to
{  select which VER functions to use.

    get_dscb(dscb_d7ty,^d7ty, 1);
    got_eicb_d7ty:= TRUE;

{  Check for an SSR.

    get_dscb (dscb_ssrptr, ^dscb_ssr, 1);
    ssr_address_words := dscb_ssr.offset + dscb_ssr.rlower * 100(8) + dscb_ssr.
          rupper * 1000000(8);
    get_ve_status (i);
    IF (exitcd = 0) OR (ssr_address_words = 0) THEN

{  Get SSR address from EI and verify that it is the same as SSR address
{  from the EICB.

      get_ei_pva (start_of_ssr, i);
      IF i = 0 THEN
        IF ssr_address_words <> 0 THEN
          set_ei_pva (start_of_ssr, ssr_address_words);
        ELSE
          error_processor (invalid_ssr, warning);
        IFEND;
      ELSEIF i DIV 8 <> ssr_address_words THEN

{  Use SSR address that EI knows about.

        error_processor (invalid_ssr, warning);
      IFEND;

      IF ssr_address_words <> 0 THEN

{  Check first entry in SSR for validity, EI has ssr address set.

        get_ssr_directory_entry (0, left, right);
        IF (left = 0) OR (left > 100) THEN
          ssr_address_words := 0;
          error_processor (invalid_ssr, warning);
        IFEND;
      IFEND;
    IFEND;

{  Start NOS/VE termination processing.

    byeve := 0;
    terminate_nve_job := FALSE;
    run_mode := (jcr.global_error_flag = 0);
    determine_memory_limits;
    nve_memory_gt_64_mb := (nve_memory DIV 100000(16) > 64);
    logical_cm_gt_256_mb := (((nve_memory + load_offset_bytes) DIV 100000(16)) > 256);
    get_dscb (dscb_cptptr, ^cptp_r_pointer, 1);

{  Set amount of memory to be dumped to the default.

    IF nve_memory_gt_64_mb AND (cptp_r_pointer.length <> 0) THEN
      memory_to_be_dumped := 'CRITICAL';
      critical_dump_allowed := TRUE;
    ELSE
      memory_to_be_dumped := 'ALL';
      critical_dump_allowed := FALSE;
    IFEND;

    IF jcr.global_error_flag <> 0 THEN

{  Check for orderly termination.

      IF ssr_address_words <> 0 THEN
        find_ssr_entry (dsc$ssr_termination_status, entry);
        get_ssr_directory_entry (entry, left, byeve);
        dyfstrnum ('byve=', byeve, user_dayf);
      IFEND;
      IF (byeve <> 0) AND (r1g_error_flag = $INTEGER (nosve_down)) THEN
        run_mode := TRUE;
        jcr.global_error_flag := 0;
      ELSE
        permsg := #LOC (ds_error_messages);
        show_message (permsg^ [r1g_error_flag], header_line, no_scroll);
      IFEND;

      IF logical_cm_gt_256_mb THEN
        show_message ('   IT IS NOT POSSIBLE TO HAVE THE NVE SUBSYSTEM TAKE',
              header_line + 1, no_scroll);
        show_message ('   A DUMP WHEN THE LOGICAL SIZE OF MEMORY EXCEEDS',
              header_line + 2, no_scroll);
        show_message ('   256 MB.  IF A DUMP IS DESIRED, TAKE AN',
              header_line + 3, no_scroll);
        show_message ('   EXPRESS DEADSTART DUMP (EDD) NOW.',
              header_line + 4, no_scroll);
        show_message ('   (USE OF EDD WILL INTERRUPT SYSTEM OPERATION.)',
              header_line + 5, no_scroll);
        show_message (' ', header_line + 6, no_scroll);

        show_message ('   PERFORM THESE STEPS TO CONTINUE PROCESSING.',
              header_line + 7, no_scroll);
        show_message (' ', header_line + 8, no_scroll);
        show_message ('   1. SELECT A VALUE FOR THE FOLLOWING OPTION:',
              header_line + 9, no_scroll);
        show_message ('       (*TNVEJOB=FALSE. IS THE DEFAULT.)',
              header_line + 10, no_scroll);
        show_message ('       *TNVEJOB=TRUE.  TERMINATE THE NVE JOB.',
              header_line + 11, no_scroll);
        show_message ('       *TNVEJOB=FALSE. DO NOT TERMINATE THE NVE JOB.',
              header_line + 12, no_scroll);
        show_message (' ', header_line + 13, no_scroll);
        show_message (' ', header_line + 14, no_scroll);
      ELSE
        show_message ('   PERFORM THESE STEPS TO CONTINUE PROCESSING.',
              header_line + 1, no_scroll);
        show_message (' ', header_line + 2, no_scroll);
        show_message ('   1. SELECT VALUES FOR THE FOLLOWING OPTIONS:',
              header_line + 3, no_scroll);
        IF nve_memory_gt_64_mb AND (cptp_r_pointer.length <> 0) THEN
          show_message ('       (*DUMP=CRITICAL. *VSN=DMP00A. *DENSITY=GE. AND',
                header_line + 4, no_scroll);
        ELSE
          show_message ('       (*DUMP=ALL. *VSN=DMP00A. *DENSITY=GE. AND',
                header_line + 4, no_scroll);
        IFEND;

        show_message ('       *TNVEJOB=FALSE. ARE THE DEFAULTS.)',
              header_line + 5, no_scroll);
        show_message (' ', header_line + 6, no_scroll);
        show_message ('       *DUMP=ALL/TRUE. DUMP ALL CENTRAL MEMORY.',
              header_line + 7, no_scroll);

        IF nve_memory_gt_64_mb AND (cptp_r_pointer.length <> 0) THEN
          show_message ('       *DUMP=CRITICAL. DUMP CRITICAL MEMORY.',
                header_line + 8, no_scroll);
        ELSE
          show_message (' ', header_line + 8, no_scroll);
        IFEND;

        show_message ('       *DUMP=NONE.     DO NOT DUMP CENTRAL MEMORY.',
              header_line + 9, no_scroll);
        show_message ('       *DUMP=FALSE.    DO NOT GENERATE DUMP FILE.',
              header_line + 10, no_scroll);
        show_message ('       *DENSITY=PE/GE. DUMP TAPE DENSITY, PE OR GE.',
              header_line + 11, no_scroll);
        show_message ('       *VSN=XXXXXX.    DUMP TAPE VSN.',
              header_line + 12, no_scroll);
        show_message ('       *TNVEJOB=TRUE.  TERMINATE THE NVE JOB.',
              header_line + 13, no_scroll);
        show_message ('       *TNVEJOB=FALSE. DO NOT TERMINATE THE NVE JOB.',
              header_line + 14, no_scroll);

      IFEND;
      show_message (' ', header_line + 15, no_scroll);
      show_message ('   2.ENTER', header_line + 16, no_scroll);
      show_message ('       *RUN.', header_line + 17, no_scroll);

{  Last line, this line number plus 1 should be set as line position earlier
{  in this procedure.

      show_message (' ', header_line + 18, no_scroll);
    IFEND;

    IF NOT logical_cm_gt_256_mb THEN
      take_dump := (NOT run_mode);
    ELSE
      take_dump := FALSE
    IFEND;

    IF (sw2 IN jcr.sense_switches) OR (NOT run_mode) THEN
      display; {request k display in idle}
      wait_for_operator_action (logical_cm_gt_256_mb, error);
    IFEND;

    clear_screen;
    show_message ('TERMINATING NOS/VE.', header_line + 1, no_scroll);


{  Ensure that NOS/VE has terminated.

    jcr.r3 := jcr.global_r1;

{  Set flag that determines if memory returned and whether the NVE 170 job
{  should continue.  Initialize to return memory and terminate NVE 170 job.

    jcr.global_r1 := $INTEGER (dsc$deadstart_condition_empty);

    IF ssr_address_words <> 0 THEN

{  Set up r pointer for the DFT requests that are passed through SDA.  SDA
{  will move the DFT requests here and the area after the DFT request can
{  be used for information that DFT will return for the request.  Use PPBF
{  in the SSR for DFT requests and the returned information.

      find_ssr_entry (dsc$ssr_pp_controlware_buf, ppbf_entry_offset);
      get_ssr_directory_entry (ppbf_entry_offset, ppbf_length, ppbf_offset);
      dft_request_rmwa := ssr_address_words + ppbf_offset;
      dft_request_pva_type := start_of_ssr;
      dft_request_byte_rma := (ppbf_offset * 8);

      dft_request_r_pointer.offset := dft_request_rmwa MOD 100(8);
      dft_request_r_pointer.rlower := (dft_request_rmwa DIV 100(8))
            MOD 10000(8);
      dft_request_r_pointer.rupper := dft_request_rmwa DIV 1000000(8);
      dft_request_r_pointer.length := ppbf_length;

      terminate_cpu;

{  Return appropriate resources and determine what kind if any deadstart
{  to do next.

      find_ssr_entry (dsc$ssr_deadstart_type, entry);
      get_ssr_directory_entry (entry, left, right);
      dyfstrnum ('dst_type=', right, user_dayf);
      jcr.global_r1 := right;

      IF byeve = 0 THEN
        {This worries me - will we ALWAYS retain memory when required ???
        set_ssr_directory_entry (entry, left,
            $INTEGER (dsc$continuation_deadstart));
        dyfstring ('continuation forced due to nosve failure', user_dayf);
      IFEND;
    IFEND;

    return_pps_channels;
    return_all (rteq);
    idle_secondary_ious;

    IF jcr.global_r1 = $INTEGER (dsc$deadstart_condition_empty) THEN
      callsda (clear_nos_ve_dft_buffer_p, pp_table);
      return_central_memory;
      dyfstring ('nos/ve aborted.', user_dayf);
    ELSEIF terminate_nve_job THEN
      dyfstring ('NVE JOB TERMINATED BY COMMAND.', user_dayf);
      dyfstring ('  NOS/VE MEMORY NOT RETURNED.', user_dayf);

{  Set flag to terminate the NVE 170 job.

      jcr.global_r1 := $INTEGER (dsc$deadstart_condition_empty);
    ELSE
      dyfstring ('nve continuing.', user_dayf);
    IFEND;

{  Set global error flag to normal termination and write CCL registers
{  to communicate with CCL part of NVE job.

    jcr.global_error_flag := 0;
    jcrset;
    endprgr;             { nos/be scp status dropped

  PROCEND dsptnve;
MODEND dsm$terminate_nos_ve;
*DECK DECK=DSM$TERMNVE EXPAND=TRUE
.PROC,TERMNVE.
.*
.* The TERMNVE procedure performs the NOS/VE termination.
.*
.IFE,(EFG.EQ.77B).AND.(R1G.EQ.30B),NO017.
.*
.*  VE NOT ENABLED IN CMRDECK.
.*  RETURN WITHOUT TRYING TO TAKE A DUMP SINCE
.*  *DSMTRM* WOULD NOT FUNCTION CORRECTLY.
.*
REVERT. VE NOT ENABLED IN CMRDECK.
.ELSE,NO017.
DSMTRM.
REVERT.
EXIT.
DMD.
DMD,0,200000.
RETURN,CHKTAPE.
DAYFILE,OUTPUT.
IF,R1G=12B.AND.EF.EQ.PPE,TAPERR.
.*
.*  ASSUME TAPE ERROR IF PP ABORT WHILE DUMPING TAPE.
.*  RETURN WITHOUT CPU ERROR SO THAT DUMP WILL BE RETRIED.
.*
RETURN,OUTPUT.
REVERT.
ELSE,TAPERR.
.*
.*  SOME ERROR OTHER THAN AN ERROR WRITING TAPE.
.*
ROUTE,OUTPUT,DC=PR.
REVERT,ABORT.
IFEND,TAPERR.
.ENDIF,NO017.
/EOR
*DECK DECK=DSM$TEST_RESOURCE_REQUEST_CMDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Test Resource Requests' ??
MODULE dsm$test_resource_request_cmds;

{ PURPOSE:
{   This module contains a utility that is used at system core command time during deadstart to test
{   the resource requests.
{ DESIGN:
{   This utility is used during deadstart when the operator is asked to enter system core commands.  The
{   utility is entered by the command 'TESRR'.  A directory of the commands is displayed by typing in the
{   command 'HELP'.  The utility is used for debug purposes only, in some cases memory may be reserved but
{   never released because the user may want to observe the memory on a dump.  It was never the intention
{   of this utility to be anything but a debug tool for requesting resources.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_paged_literal
*copyc syt$value_kinds
?? POP ??
*copyc dpp$put_next_line
*copyc dsp$get_pp_registers
*copyc dsp$idle_pp
*copyc dsp$load_pp
*copyc dsp$request_resources
*copyc dsp$resume_pp
*copyc dsp$retrieve_channel_type
*copyc dsp$retrieve_iou_information
*copyc dsp$update_hardware_date_time
*copyc i#real_memory_address
*copyc syp$binary_to_ascii
*copyc syp$crack_command
*copyc syp$process_core_commands
?? EJECT ??
*copyc osv$mainframe_wired_heap
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??
  CONST
    output_line_length = 70;

  TYPE
    command_list = (get_any_pp_cmd, get_channel_cmd, get_channel_type_cmd, get_equipment_cmd, get_pp_cmd,
          get_pp_registers_cmd, idle_pp_cmd, load_pp_cmd, resume_pp_cmd, return_channel_cmd,
          return_equipment_cmd, return_pp_cmd, write_time_cmd),

    output_line_type = string (output_line_length);
?? EJECT ??
  { Parameter Description Tables for commands in this module.

  VAR
    channel_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 3] OF syt$parameter_descriptor := [
          [TRUE , 1, 'CHANNEL ', syc$integer_value, 0, 0, 33(8)],
          [FALSE, 1, 'IOU     ', syc$integer_value, 0, 0, 1],
          [FALSE, 1, 'CIO     ', syc$boolean_value, FALSE]],

    get_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 5] OF syt$parameter_descriptor := [
          [TRUE , 1, 'CHANNEL ', syc$integer_value, 0, 0, 33(8)],
          [FALSE, 1, 'IOU     ', syc$integer_value, 0, 0, 1],
          [FALSE, 1, 'DRIVER  ', syc$boolean_value, TRUE],
          [FALSE, 1, 'PARTNER ', syc$boolean_value, FALSE],
          [FALSE, 1, 'CIO     ', syc$boolean_value, FALSE]],

    get_pp_registers_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 3] OF
          syt$parameter_descriptor := [
          [TRUE , 1, 'PP      ', syc$integer_value, 0, 0, 31(8)],
          [FALSE, 1, 'IOU     ', syc$integer_value, 0, 0, 1],
          [FALSE, 1, 'CIO     ', syc$boolean_value, FALSE]],

    help_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 1] OF syt$parameter_descriptor := [
          [FALSE, 1, 'COMMAND ', syc$name_value, 'NONE']],

    idle_pp_pdt: [STATIC,READ, oss$mainframe_paged_literal] ARRAY [1 .. 5] OF syt$parameter_descriptor := [
          [TRUE , 1, 'PP      ', syc$integer_value, 0, 0, 31(8)],
          [TRUE , 1, 'IOU     ', syc$integer_value, 0, 0, 1],
          [FALSE, 1, 'DUMP_PP ', syc$boolean_value, FALSE],
          [FALSE, 1, 'REG_ONLY', syc$boolean_value, FALSE],
          [FALSE, 1, 'CIO     ', syc$boolean_value, FALSE]],

    load_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 5] OF syt$parameter_descriptor := [
          [TRUE , 1, 'NAME    ', syc$name_value, 'ABCDEFG'],
          [TRUE , 1, 'PP      ', syc$integer_value, 0, 0, 31(8)],
          [FALSE, 1, 'IOU     ', syc$integer_value, 0, 0, 1],
          [FALSE, 1, 'CIO     ', syc$boolean_value, FALSE],
          [FALSE, 1, 'RMA     ', syc$integer_value, 0, 0, 0fffffff(16)]],

    path_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 5] OF syt$parameter_descriptor := [
          [TRUE , 1, 'CHANNEL ', syc$integer_value, 0, 0, 33(8)],
          [TRUE , 1, 'EQUIP   ', syc$integer_value, 0, 0, 7],
          [TRUE , 1, 'UNIT    ', syc$integer_value, 0, 0, 63],
          [FALSE, 1, 'IOU     ', syc$integer_value, 0, 0, 1],
          [FALSE, 1, 'CIO     ', syc$boolean_value, FALSE]],

    pp_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 4] OF syt$parameter_descriptor := [
          [TRUE , 1, 'PP      ', syc$integer_value, 0, 0, 31(8)],
          [FALSE, 1, 'IOU     ', syc$integer_value, 0, 0, 1],
          [FALSE, 1, 'CIO     ', syc$boolean_value, FALSE],
          [FALSE, 1, 'PP      ', syc$integer_value, 30, 0, 31(8)]],

    resume_pp_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 4] OF syt$parameter_descriptor := [
          [TRUE , 1, 'PP      ', syc$integer_value, 0, 0, 31(8)],
          [TRUE , 1, 'START_P ', syc$integer_value, 0, 0, 0ffff(16)],
          [FALSE, 1, 'IOU     ', syc$integer_value, 0, 0, 1],
          [FALSE, 1, 'CIO     ', syc$boolean_value, FALSE]],

    time_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 5] OF syt$parameter_descriptor := [
          [TRUE , 1, 'YEARS   ', syc$integer_value, 0, 0, 255],
          [TRUE , 1, 'MONTHS  ', syc$integer_value, 0, 0, 12],
          [TRUE , 1, 'DAYS    ', syc$integer_value, 0, 0, 31],
          [TRUE , 1, 'HOURS   ', syc$integer_value, 0, 0, 60],
          [TRUE , 1, 'MINUTES ', syc$integer_value, 0, 0, 60]];

?? EJECT ??
  { Command Table for commands in this module.

  VAR
    command_table: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 14] OF
          syt$command_table_entry := [
          ['GETAP', 'GET_ANY_PP', FALSE, ^get_any_pp],
          ['GETC',  'GET_CHANNEL', FALSE, ^get_channel],
          ['GETCT', 'GET_CHANNEL_TYPE', FALSE, ^get_channel_type],
          ['GETE',  'GET_EQUIPMENT', FALSE, ^get_equipment],
          ['GETP',  'GET_PP', FALSE, ^get_pp],
          ['GETPR', 'GET_PP_REGISTERS', FALSE, ^get_pp_registers],
          ['HELP',  'HELP', FALSE, ^help],
          ['IDLP',  'IDLE_PP', FALSE, ^idle_pp],
          ['LOAP',  'LOAD_PP', FALSE, ^load_pp],
          ['RESP',  'RESUME_PP', FALSE, ^resume_pp],
          ['RETC',  'RETURN_CHANNEL', FALSE, ^return_channel],
          ['RETE',  'RETURN_EQUIPMENT', FALSE, ^return_equipment],
          ['RETP',  'RETURN_PP', FALSE, ^return_pp],
          ['WRIT',  'WRITE_TIME', FALSE, ^write_time]];
?? EJECT ??
  { Variables containing help displays.

  VAR
    help_command_display: ARRAY [command_list] OF output_line_type := [
          'GET_ANY_PP, GETAP',
          'GET_CHANNEL, GETC',
          'GET_CHANNEL_TYPE, GETCT',
          'GET_EQUIPMENT, GETE',
          'GET_PP, GETP',
          'GET_PP_REGISTERS, GETPR',
          'IDLE_PP, IDLP',
          'LOAD_PP, LOAP',
          'RESUME_PP, RESP',
          'RETURN_CHANNEL, RETC',
          'RETURN_EQUIPMENT, RETE',
          'RETURN_PP, RETP',
          'WRITE_TIME, WRIT'],

    help_displays: ARRAY [command_list] OF ARRAY [1 .. 6] OF output_line_type := [
           ['command:  GET_ANY_PP  alias: GETAP',
            '  parameter:  NONE',
            ' ', ' ', ' ', ' '],

           ['command:  GET_CHANNEL  alias: GETC',
            '  parameter:  CHANNEL = channel number, range = 0 .. 33(8)',
            '  parameter:  IOU = iou number, range = 0 .. 1',
            '  parameter:  CIO = boolean, TRUE = cio, FALSE = nio',
            ' ', ' '],

           ['command:  GET_CHANNEL_TYPE  alias: GETCT',
            '  parameter:  CHANNEL = channel number, range = 0 .. 33(8)',
            '  parameter:  IOU = iou number, range = 0 .. 1',
            '  parameter:  CIO = boolean, TRUE = cio, FALSE = nio',
            ' ', ' '],

           ['command:  GET_EQUIPMENT   alias: GETE',
            '  parameter:  CHANNEL = channel number, range = 0 .. 33(8)',
            '  parameter:  EQUIPMENT = equipment number, range = 0 .. 7',
            '  parameter:  UNIT = unit number, range = 0 .. 63',
            '  parameter:  IOU = iou number, range = 0 .. 1',
            '  parameter:  CIO = boolean, TRUE = cio, FALSE = nio'],

           ['command:  GET_PP   alias: GETP',
            '  parameter:  CHANNEL = channel number, range = 0 .. 33(8)',
            '  parameter:  IOU = iou number, range = 0 .. 1',
            '  parameter:  DRIVER = boolean, TRUE = driver, FALSE = nondriver',
            '  parameter:  PARTNER = boolean, TRUE = partner, FALSE = single',
            '  parameter:  CIO = boolean, TRUE = cio, FALSE = nio'],

           ['command:  GET_PP_REGISTERS alias: GETPR',
            '  parameter:  PP = pp number, range = 0 .. 31(8)',
            '  parameter:  IOU = iou number, range = 0 .. 1',
            '  parameter:  CIO = boolean, TRUE = cio, FALSE = nio',
            ' ', ' '],

           ['command:  IDLE_PP   alias: IDLP',
            '  parameter:  PP = pp number, range = 0 .. 31(8)',
            '  parameter:  IOU = iou number, range = 0 .. 1',
            '  parameter:  DUMP_PP = boolean, TRUE = dump pp, FALSE = no dump',
            '  parameter:  REGISTER_ONLY = boolean, TRUE = registers only, FALSE = --',
            '  parameter:  CIO = boolean, TRUE = cio, FALSE = nio'],

           ['command:  LOAD_PP   alias: LOAP',
            '  parameter:  NAME = name of the pp to be loaded',
            '  parameter:  PP = pp number, range = 0 .. 31(8)',
            '  parameter:  IOU = iou number, range = 0 .. 1',
            '  parameter:  CIO = boolean, TRUE = cio, FALSE = nio',
            '  parameter:  RMA = rma of the pp table, range = 0 .. 0FFFFFFFF(16)'],

           ['command:  RESUME_PP   alias: RESP',
            '  parameter:  PP = pp number, range = 0 .. 31(8)',
            '  parameter:  START_PP = pp start address, range = 0 .. 0FFFF(16)',
            '  parameter:  IOU = iou number, range = 0 .. 1',
            '  parameter:  CIO = boolean, TRUE = cio, FALSE = nio',
            ' '],

           ['command:  RETURN_CHANNEL  alias: RETC',
            '  parameter:  CHANNEL = channel number, range = 0 .. 33(8)',
            '  parameter:  IOU = iou number, range = 0 .. 1',
            '  parameter:  CIO = boolean, TRUE = cio, FALSE = nio',
            ' ', ' '],

           ['command:  RETURN_EQUIPMENT   alias: RETE',
            '  parameter:  CHANNEL = channel number, range = 0 .. 33(8)',
            '  parameter:  EQUIPMENT = equipment number, range = 0 .. 7',
            '  parameter:  UNIT = unit number, range = 0 .. 63',
            '  parameter:  IOU = iou number, range = 0 .. 1',
            '  parameter:  CIO = boolean, TRUE = cio, FALSE = nio'],

           ['command:  RETURN_PP   alias: RETP',
            '  parameter:  PP = pp number, range = 0 .. 31(8)',
            '  parameter:  IOU = iou number, range = 0 .. 1',
            '  parameter:  CIO = boolean, TRUE = cio, FALSE = nio',
            '  parameter:  PP = pp number, range = 0 .. 31(8)',
            ' '],

           ['command:  WRITE_TIME   alias: WRIT',
            '  parameter:  YEARS = year number, range = 0 .. 255',
            '  parameter:  MONTHS = month number, range = 0 .. 12',
            '  parameter:  DAYS = day number, range = 0 .. 31',
            '  parameter:  HOURS = hour number, range = 0 .. 60',
            '  parameter:  MINUTES = minute number, range = 0 .. 60']];
?? TITLE := 'get_any_pp', EJECT ??

{ PURPOSE:
{   This procedure processes the command GET_ANY_PP.  It retrieves any PP.

  PROCEDURE get_any_pp
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      ascii_number: string (5),
      ignore_status: ost$status,
      ious_in_configuration: dst$iou_information_table,
      number_of_ious: dst$number_of_ious,
      output_line: output_line_type,
      request: dst$resource_request;

    status.normal := TRUE;

    dsp$retrieve_iou_information (number_of_ious, ious_in_configuration);
    request.channel.number := 15;  { dummy channel value
    request.channel.channel_protocol := dsc$cpt_nio;
    request.channel.iou_number := ious_in_configuration [1].physical_iou_number;
    request.resource_request_type := dsc$rrt_get_pp;
    request.options := $dst$resource_request_options [dsc$rro_any_pp];

    dsp$request_resources (request, status);
    IF NOT status.normal THEN
      output_line := 'The get_any_pp request failed.';
      dpp$put_next_line (id, output_line, ignore_status);
      RETURN;
    IFEND;

    ascii_number := '  ';
    syp$binary_to_ascii (request.primary_pp.number, ascii_number, 10, 5);
    output_line := 'PP number = ';
    output_line (13, 5) := ascii_number;
    output_line (18, 6) := '(10), ';
    output_line (24, 19) := 'channel protocol = ';
    IF request.primary_pp.channel_protocol = dsc$cpt_nio THEN
      output_line (43, 5) := 'NIO, ';
    ELSE
      output_line (43, 5) := 'CIO, ';
    IFEND;
    output_line (48, 6) := 'IOU = ';
    ascii_number := '  ';
    syp$binary_to_ascii (request.primary_pp.iou_number, ascii_number, 10, 5);
    output_line (54, 5) := ascii_number;
    output_line (59, 5) := '(10).';

    dpp$put_next_line (id, output_line, status);

  PROCEND get_any_pp;
?? TITLE := 'get_channel', EJECT ??

{ PURPOSE:
{   This procedure processes the command GET_CHANNEL.  It retrieves a channel.

  PROCEDURE get_channel
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      output_line: output_line_type,
      parameters: ARRAY [1 .. 3] OF syt$parameter_value,
      request: dst$resource_request;

    status.normal := TRUE;
    syp$crack_command (channel_pdt, text, parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    request.resource_request_type := dsc$rrt_get_channel;
    request.channel.number := parameters [1].int;
    request.channel.iou_number := parameters [2].int;
    IF parameters [3].bool THEN
      request.channel.channel_protocol := dsc$cpt_cio;
    ELSE
      request.channel.channel_protocol := dsc$cpt_nio;
    IFEND;

    dsp$request_resources (request, status);
    IF NOT status.normal THEN
      output_line := 'The get_channel request failed.';
    ELSE
      output_line := 'The get_channel request completed normally.';
    IFEND;
    dpp$put_next_line (id, output_line, ignore_status);

  PROCEND get_channel;
?? TITLE := 'get_channel_type', EJECT ??

{ PURPOSE:
{   This procedure processes the command GET_CHANNEL_TYPE.  It retrieves the type of the indicated channel.

  PROCEDURE get_channel_type
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      channel: dst$iou_resource,
      channel_type: cmt$channel_type,
      found: boolean,
      ignore_status: ost$status,
      output_line: output_line_type,
      parameters: ARRAY [1 .. 3] OF syt$parameter_value;

    status.normal := TRUE;
    syp$crack_command (channel_pdt, text, parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    channel.number := parameters [1].int;
    channel.iou_number := parameters [2].int;
    IF parameters [3].bool THEN
      channel.channel_protocol := dsc$cpt_cio;
    ELSE
      channel.channel_protocol := dsc$cpt_nio;
    IFEND;

    dsp$retrieve_channel_type (channel, channel_type, found);
    IF NOT found THEN
      output_line := 'The get_channel_type request failed.';
    ELSE
      output_line := 'The get_channel_type request completed normally; type = ';
      CASE channel_type OF
      = cmc$170_channel =
        output_line (57, 4) := '170.';
      = cmc$ici_channel =
        output_line (57, 4) := 'ICI.';
      = cmc$isi_channel =
        output_line (57, 4) := 'ISI.';
      = cmc$ipi_channel =
        output_line (57, 4) := 'IPI.';
      ELSE
      CASEND;
    IFEND;
    dpp$put_next_line (id, output_line, ignore_status);

  PROCEND get_channel_type;
?? TITLE := 'get_equipment', EJECT ??

{ PURPOSE:
{   This procedure processes the command GET_EQUIPMENT.  It retrieves the desired equipment.

  PROCEDURE get_equipment
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      output_line: output_line_type,
      parameters: ARRAY [1 .. 5] OF syt$parameter_value,
      request: dst$resource_request;

    status.normal := TRUE;
    syp$crack_command (path_pdt, text, parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    request.resource_request_type := dsc$rrt_get_equipment;
    request.channel.number := parameters [1].int;
    request.channel.iou_number := parameters [4].int;
    IF parameters [5].bool THEN
      request.channel.channel_protocol := dsc$cpt_cio;
    ELSE
      request.channel.channel_protocol := dsc$cpt_nio;
    IFEND;
    request.equipment_number := parameters [2].int;
    request.unit_number := parameters [3].int;

    dsp$request_resources (request, status);
    IF NOT status.normal THEN
      output_line := 'The get_equipment request failed.';
    ELSE
      output_line := 'The get_equipment request completed normally.';
    IFEND;
    dpp$put_next_line (id, output_line, ignore_status);

  PROCEND get_equipment;
?? TITLE := 'get_pp', EJECT ??

{ PURPOSE:
{   This procedure processes the command GET_PP.  It retrieves a PP.

  PROCEDURE get_pp
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      ascii_number: string (5),
      ignore_status: ost$status,
      output_line: output_line_type,
      parameters: ARRAY [1 .. 5] OF syt$parameter_value,
      request: dst$resource_request;

    status.normal := TRUE;
    syp$crack_command (get_pdt, text, parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    request.resource_request_type := dsc$rrt_get_pp;
    request.channel.number := parameters [1].int;
    request.channel.iou_number := parameters [2].int;
    IF parameters [5].bool THEN
      request.channel.channel_protocol := dsc$cpt_cio;
    ELSE
      request.channel.channel_protocol := dsc$cpt_nio;
    IFEND;
    IF parameters [3].bool THEN
      request.options := $dst$resource_request_options [dsc$rro_driver_pp];
    IFEND;
    IF parameters [4].bool THEN
      request.options := request.options + $dst$resource_request_options [dsc$rro_partner_pp];
    IFEND;

    dsp$request_resources (request, status);
    IF NOT status.normal THEN
      output_line := 'The get_pp request failed.';
      dpp$put_next_line (id, output_line, ignore_status);
      RETURN;
    IFEND;

    ascii_number := '  ';
    syp$binary_to_ascii (request.primary_pp.number, ascii_number, 10, 5);
    output_line := 'The primary PP number = ';
    output_line (25, 5) := ascii_number;
    output_line (30, 5) := '(10).';
    dpp$put_next_line (id, output_line, status);
    IF parameters [4].bool THEN
      ascii_number := '  ';
      syp$binary_to_ascii (request.secondary_pp.number, ascii_number, 10, 5);
      output_line := 'The secondary PP number = ';
      output_line (27, 5) := ascii_number;
      output_line (32, 5) := '(10).';
      dpp$put_next_line (id, output_line, status);
    IFEND;

  PROCEND get_pp;
?? TITLE := 'get_pp_registers', EJECT ??

{ PURPOSE:
{   This procedure processes the command GET_PP_REGISTERS.  It retrieves the desired PP registers.

  PROCEDURE get_pp_registers
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      ascii_number: string (12),
      ignore_status: ost$status,
      output_line: output_line_type,
      parameters: ARRAY [1 .. 3] OF syt$parameter_value,
      pp: dst$iou_resource,
      pp_registers: dst$dft_pp_registers;

    status.normal := TRUE;
    syp$crack_command (get_pp_registers_pdt, text, parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pp.number := parameters [1].int;
    pp.iou_number := parameters [2].int;
    IF parameters [3].bool THEN
      pp.channel_protocol := dsc$cpt_cio;
    ELSE
      pp.channel_protocol := dsc$cpt_nio;
    IFEND;

    dsp$get_pp_registers (pp, pp_registers, status);
    IF NOT status.normal THEN
      output_line := 'The get_pp_registers request failed.';
      dpp$put_next_line (id, output_line, ignore_status);
      RETURN;
    IFEND;

    output_line := 'Displaying the registers of ';
    IF parameters [2].bool THEN
      output_line (29, 7) := 'CIO PP ';
    ELSE
      output_line (29, 7) := 'NIO PP ';
    IFEND;
    syp$binary_to_ascii (parameters[1].int, ascii_number, 10, 12);
    output_line (37, 12) := ascii_number;
    output_line (50, 5) := '(10).';
    dpp$put_next_line (id, output_line, status);

    { Display pp registers.

    output_line := '    P=       , Q=      , K=      , A=      .';
    syp$binary_to_ascii (pp_registers.p_register, output_line, 8, 13);
    syp$binary_to_ascii (pp_registers.q_register, output_line, 8, 23);
    syp$binary_to_ascii (pp_registers.k_register, output_line, 8, 33);
    syp$binary_to_ascii (pp_registers.a_register, output_line, 8, 43);
    dpp$put_next_line (id, output_line, status);

  PROCEND get_pp_registers;
?? TITLE := 'help', EJECT ??

{ PURPOSE:
{   This procedure processes the command HELP.  It displays the commands available through this utility.
{   It also is capable of displaying each command and its parameters individually.

  PROCEDURE help
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      command_type: command_list,
      display_command_index: command_list,
      display_line_index: 1 .. 6,
      output_line: output_line_type,
      parameters: ARRAY [1 .. 1] OF syt$parameter_value;

    status.normal := TRUE;
    syp$crack_command (help_pdt, text, parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameters [1].name = 'NONE' THEN
      FOR display_command_index := LOWERBOUND (help_command_display) TO UPPERBOUND (help_command_display) DO
        output_line := help_command_display [display_command_index];
        dpp$put_next_line (id, output_line, status);
      FOREND;
      RETURN;
    ELSEIF (parameters [1].name = 'GETAP') OR (parameters [1].name = 'GET_ANY_PP') THEN
      command_type := get_any_pp_cmd;
    ELSEIF (parameters [1].name = 'GETC') OR (parameters [1].name = 'GET_CHANNEL') THEN
      command_type := get_channel_cmd;
    ELSEIF (parameters [1].name = 'GETCT') OR (parameters [1].name = 'GET_CHANNEL_TYPE') THEN
      command_type := get_channel_type_cmd;
    ELSEIF (parameters [1].name = 'GETE') OR (parameters [1].name = 'GET_EQUIPMENT') THEN
      command_type := get_equipment_cmd;
    ELSEIF (parameters [1].name = 'GETP') OR (parameters [1].name = 'GET_PP') THEN
      command_type := get_pp_cmd;
    ELSEIF (parameters [1].name = 'GETPR') OR (parameters [1].name = 'GET_PP_REGISTERS') THEN
      command_type := get_pp_registers_cmd;
    ELSEIF (parameters [1].name = 'IDLP') OR (parameters [1].name = 'IDLE_PP') THEN
      command_type := idle_pp_cmd;
    ELSEIF (parameters [1].name = 'LOAP') OR (parameters [1].name = 'LOAD_PP') THEN
      command_type := load_pp_cmd;
    ELSEIF (parameters [1].name = 'RESP') OR (parameters [1].name = 'RESUME_PP') THEN
      command_type := resume_pp_cmd;
    ELSEIF (parameters [1].name = 'RETC') OR (parameters [1].name = 'RETURN_CHANNEL') THEN
      command_type := return_channel_cmd;
    ELSEIF (parameters [1].name = 'RETE') OR (parameters [1].name = 'RETURN_EQUIPMENT') THEN
      command_type := return_equipment_cmd;
    ELSEIF (parameters [1].name = 'RETP') OR (parameters [1].name = 'RETURN_PP') THEN
      command_type := return_pp_cmd;
    ELSEIF (parameters [1].name = 'WRIT') OR (parameters [1].name = 'WRITE_TIME') THEN
      command_type := write_time_cmd;
    ELSE
      output_line := 'ERROR -- bad command name or command not supported by HELP.';
      dpp$put_next_line (id, output_line, status);
      RETURN;
    IFEND;

    FOR display_line_index := 1 TO 6 DO
      output_line := help_displays [command_type] [display_line_index];
      IF output_line = ' ' THEN
        RETURN;
      IFEND;
      dpp$put_next_line (id, output_line, status);
    FOREND;

  PROCEND help;
?? TITLE := 'idle_pp', EJECT ??

{ PURPOSE:
{   This procedure processes the command IDLE_PP.  It idles and possibly dumps the desired PP.

  PROCEDURE idle_pp
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      ascii_number: string (8),
      ignore_status: ost$status,
      output_line: output_line_type,
      parameters: ARRAY [1 .. 5] OF syt$parameter_value,
      pp: dst$iou_resource,
      pp_dump_seq_p: ^SEQ ( * ),
      rma: integer;

    status.normal := TRUE;
    syp$crack_command (idle_pp_pdt, text, parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pp.number := parameters [1].int;
    pp.iou_number := parameters [2].int;
    IF parameters [5].bool THEN
      pp.channel_protocol := dsc$cpt_cio;
    ELSE
      pp.channel_protocol := dsc$cpt_nio;
    IFEND;
    IF parameters [3].bool THEN
      ALLOCATE pp_dump_seq_p: [[REP (16 * 1024 * 2) OF cell]] IN osv$mainframe_wired_heap^;
      RESET pp_dump_seq_p;
    ELSE
      pp_dump_seq_p := NIL;
    IFEND;

    dsp$idle_pp (pp, parameters [4].bool, parameters [3].bool, pp_dump_seq_p, status);
    IF NOT status.normal THEN
      output_line := 'The idle_pp request failed.';
      dpp$put_next_line (id, output_line, ignore_status);
      RETURN;
    IFEND;

    output_line := 'The idle_pp request completed normally.';
    dpp$put_next_line (id, output_line, status);

    IF parameters [3].bool THEN
      output_line := 'The rma address of the dumped pp in memory is ';
      i#real_memory_address (pp_dump_seq_p, rma);
      syp$binary_to_ascii (rma, ascii_number, 16, 8);
      output_line (47, 8) := ascii_number;
      dpp$put_next_line (id, output_line, status);
    IFEND;

  PROCEND idle_pp;
?? TITLE := 'load_pp', EJECT ??

{ PURPOSE:
{   This procedure processes the command LOAD_PP.  It loads the desired PP.

  PROCEDURE load_pp
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      output_line: output_line_type,
      parameters: ARRAY [1 .. 5] OF syt$parameter_value,
      pp: dst$iou_resource;

    status.normal := TRUE;
    syp$crack_command (load_pdt, text, parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pp.number := parameters [2].int;
    pp.iou_number := parameters [3].int;
    IF parameters [4].bool THEN
      pp.channel_protocol := dsc$cpt_cio;
    ELSE
      pp.channel_protocol := dsc$cpt_nio;
    IFEND;

    dsp$load_pp (dsc$load_pp_by_name, pp, NIL, parameters [1].name (1, 7), parameters [4].int, status);
    IF NOT status.normal THEN
      output_line := 'The load_pp request failed.';
    ELSE
      output_line := 'The load_pp request completed normally.';
    IFEND;
    dpp$put_next_line (id, output_line, ignore_status);

  PROCEND load_pp;
?? TITLE := 'resume_pp', EJECT ??

{ PURPOSE:
{   This procedure processes the command RESUME_PP.  It resumes the desired PP.

  PROCEDURE resume_pp
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      output_line: output_line_type,
      parameters: ARRAY [1 .. 4] OF syt$parameter_value,
      pp: dst$iou_resource;

    status.normal := TRUE;
    syp$crack_command (resume_pp_pdt, text, parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pp.number := parameters [1].int;
    pp.iou_number := parameters [3].int;
    IF parameters [4].bool THEN
      pp.channel_protocol := dsc$cpt_cio;
    ELSE
      pp.channel_protocol := dsc$cpt_nio;
    IFEND;

    dsp$resume_pp (pp, parameters [2].int, status);
    IF NOT status.normal THEN
      output_line := 'The resume_pp request failed.';
    ELSE
      output_line := 'The resume_pp request completed normally.';
    IFEND;
    dpp$put_next_line (id, output_line, ignore_status);

   PROCEND resume_pp;
?? TITLE := 'return_channel', EJECT ??

{ PURPOSE:
{   This procedure processes the command RETURN_CHANNEL.  It returns the desired channel.

  PROCEDURE return_channel
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      output_line: output_line_type,
      parameters: ARRAY [1 .. 3] OF syt$parameter_value,
      request: dst$resource_request;

    status.normal := TRUE;
    syp$crack_command (channel_pdt, text, parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    request.resource_request_type := dsc$rrt_return_channel;
    request.channel.number := parameters [1].int;
    request.channel.iou_number := parameters [2].int;
    IF parameters [3].bool THEN
      request.channel.channel_protocol := dsc$cpt_cio;
    ELSE
      request.channel.channel_protocol := dsc$cpt_nio;
    IFEND;

    dsp$request_resources (request, status);
    IF NOT status.normal THEN
      output_line := 'The return_channel request failed.';
    ELSE
      output_line := 'The return_channel request completed normally.';
    IFEND;
    dpp$put_next_line (id, output_line, ignore_status);

  PROCEND return_channel;
?? TITLE := 'return_equipment', EJECT ??

{ PURPOSE:
{   This procedure processes the command RETURN_EQUIPMENT.  It returns the desired equipment.

  PROCEDURE return_equipment
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      output_line: output_line_type,
      parameters: ARRAY [1 .. 5] OF syt$parameter_value,
      request: dst$resource_request;

    status.normal := TRUE;
    syp$crack_command (path_pdt, text, parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    request.resource_request_type := dsc$rrt_return_equipment;
    request.channel.number := parameters [1].int;
    request.channel.iou_number := parameters [4].int;
    IF parameters [5].bool THEN
      request.channel.channel_protocol := dsc$cpt_cio;
    ELSE
      request.channel.channel_protocol := dsc$cpt_nio;
    IFEND;
    request.equipment_number := parameters [2].int;
    request.unit_number := parameters [3].int;

    dsp$request_resources (request, status);
    IF NOT status.normal THEN
      output_line := 'The return_equipment request failed.';
    ELSE
      output_line := 'The return_equipment request completed normally.';
    IFEND;
    dpp$put_next_line (id, output_line, ignore_status);

  PROCEND return_equipment;
?? TITLE := 'return_pp', EJECT ??

{ PURPOSE:
{   This procedure processes the command RETURN_PP.  It returns the desired PP.

  PROCEDURE return_pp
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      output_line: output_line_type,
      parameters: ARRAY [1 .. 4] OF syt$parameter_value,
      request: dst$resource_request;

    status.normal := TRUE;
    syp$crack_command (pp_pdt, text, parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    request.resource_request_type := dsc$rrt_return_pp;
    request.primary_pp.number := parameters [1].int;
    request.primary_pp.iou_number := parameters [2].int;
    request.channel.number := 0;
    request.channel.iou_number := parameters [2].int;
    IF parameters [3].bool THEN
      request.primary_pp.channel_protocol := dsc$cpt_cio;
      request.channel.channel_protocol := dsc$cpt_cio;
    ELSE
      request.primary_pp.channel_protocol := dsc$cpt_nio;
      request.channel.channel_protocol := dsc$cpt_nio;
    IFEND;
    IF parameters [4].int < 30 THEN
      request.secondary_pp := request.primary_pp;
      request.secondary_pp.number := parameters [4].int;
      request.options := $dst$resource_request_options [dsc$rro_partner_pp];
    ELSE
      request.options := $dst$resource_request_options [];
    IFEND;

    dsp$request_resources (request, status);
    IF NOT status.normal THEN
      output_line := 'The return_pp request failed.';
    ELSE
      output_line := 'The return_pp request completed normally.';
    IFEND;
    dpp$put_next_line (id, output_line, ignore_status);

  PROCEND return_pp;
?? TITLE := 'write_time', EJECT ??

{ PURPOSE:
{   This procedure processes the command WRITE_TIME.  It writes the hardware clock.

  PROCEDURE write_time
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      date_time: ost$date_time,
      ignore_status: ost$status,
      output_line: output_line_type,
      parameters: ARRAY [1 .. 5] OF syt$parameter_value;

    status.normal := TRUE;
    syp$crack_command (time_pdt, text, parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    date_time.year := parameters [1].int;
    date_time.month := parameters [2].int;
    date_time.day := parameters [3].int;
    date_time.hour := parameters [4].int;
    date_time.minute := parameters [5].int;

    dsp$update_hardware_date_time (0, date_time, status);
    IF NOT status.normal THEN
      output_line := 'The write_time request failed.';
    ELSE
      output_line := 'The write_time request completed normally.';
    IFEND;
    dpp$put_next_line (id, output_line, ignore_status);

  PROCEND write_time;
?? TITLE := 'dsp$test_resource_request', EJECT ??

{ PURPOSE:
{   This procedure is the starting procedure for the utility.

  PROCEDURE [XDCL] dsp$test_resource_requests
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    status.normal := TRUE;
    dpp$put_next_line (id, 'Begin resource request testing utility', status);

    syp$process_core_commands (id, 'QUIT', ^command_table, status);

  PROCEND dsp$test_resource_requests;
MODEND dsm$test_resource_request_cmds;
*DECK DECK=DSM$TRM180 EXPAND=TRUE
.PROC,TRM180*I
.
.HELP
 The TRM180 procedure sequences NOS/VE termination processing.
.ENDHELP

.* *DSMTRM* SETS *R1G* TO 12B WHEN DUMPING.  IF A FAILURE OCCURS
.* WHILE DUMPING AND IT IS NOT A CPU ABORT IT IS ASSUMED TO BE A
.* FAILURE WRITING THE DUMP TAPE.  CONTROL IS RETURNED TO *DSMTRM*
.* UNTIL SUCCESSFULLY DUMPED, CPU ERROR OR THE OPERATOR DECIDES
.* TO BYPASS THE DUMP.

SET,R2=12B.
SET,EF=0.
WHILE,R2.EQ.12B.AND.EF.NE.CPE,RETRYDMP.
TERMNVE.
SET,R2=R1G.
ENDW,RETRYDMP.
TRMDUMP(TIME+)
REVERT.
EXIT.
REVERT,ABORT.
/EOR
*DECK DECK=DSM$TRMDUMP EXPAND=TRUE
.PROC,TRMDUMP*I,DNAME.
.HELP
 This procedure copies dumps and dayfiles from other NOS/VE tasks to the
 end of the dump tape.
.ENDHELP

.IFE,FILE(CHKTAPE,AS),CPYDUMP.
.IFE,SYS=NOS,NOSSYS.
   ATTACH,IRHFDMP,PASSDMP/UN=SYSTEMX,NA.
   COPY,IRHFDMP,CHKTAPE,TC=EOI,PO=R.
   COPY,PASSDMP,CHKTAPE,TC=EOI,PO=R.
   DAYFILE,DAYDUMP.
   REWIND,DAYDUMP.
   COPY,DAYDUMP,CHKTAPE,TC=EOI,PO=R.
.ELSE,NOSSYS.
   GETFILE,IRHFDMP,,IRHFDMP.
   IFE,FILE(IRHFDMP,AS),COPYIRHF.
     DSMNBCS,IRHFDMP,CHKTAPE.  IRHF DUMP
     DSMNBCS,IRHFDMP,CHKTAPE.  IRHF DAYFILE
   ENDIF,COPYIRHF.
   GETFILE,PASSDMP,,PASSDMP.
   IFE,FILE(PASSDMP,AS),COPYPASS.
     DSMNBCS,PASSDMP,CHKTAPE.  VEIAF DUMP
     DSMNBCS,PASSDMP,CHKTAPE.  VEIAF DAYFILE
   ENDIF,COPYPASS.

   DAYFILE,DAYDUMP.
   REWIND,DAYDUMP.
   DSMNBCS,DAYDUMP,CHKTAPE.
.ENDIF,NOSSYS.

UNLOAD,CHKTAPE,DUMP,DAYDUMP,IRHFDMP,PASSDMP.
SET(EF=EFG)
REVERT.
EXIT.
IFE,(EF.EQ.ODE).OR.(EF.EQ.ORE),IGNORE.
  SET(EF=EFG)
  REVERT.
ENDIF,IGNORE.
.ENDIF,CPYDUMP.
REVERT. NO DUMP TAKEN.
REVERT,NOLIST.
/EOR
*DECK DECK=DSM$VEIAF EXPAND=TRUE
.PROC,VEIAF.
*IF ($string($name(wev$target_operating_system))='NOSBE')
.IF,PNL.EQ.1,OK.
RETURN(VEIAF)
REWIND(OUTPUT)
ROUTE(OUTPUT,DEF,FID=VEIAF)
PURGE,PASSDMP,ID=PASSDMP.
SKIP,DMP.
EXIT(U)
SET(EF=0)
BKSP(OUTPUT)
REQUEST,PASSDMP,PF.
ENDIF,DMP.
RFL(50000)
LDSET,LIB=SYSOVL.
VEIAF,DBG.
RETURN(PASSDMP)
APR(11)
EXIT.
COMMENT.  VEIAF FAILED.
DMD.
DMD(0,100000)
REWIND(OUTPUT)
COPY(OUTPUT,PASSDMP)
DAYFILE,PASSDMP.
CATALOG,PASSDMP,ID=PASSDMP.
RETURN(PASSDMP)
.*  DO NOT LIST OUT THE DUMP CREATED UNLESS SENSE SWITCH
.*  4 IS SET.
IF,.NOT.SW4,KILLIST.
APR(11)
ENDIF,KILLIST.
.ELSE,OK.
COMMENT.  ERROR - NESTED CALLS.
APR(11)
.ENDIF,OK.
*ELSE
COMMENT. THIS PROCEDURE IS FOR NOS/BE ONLY.
*IFEND
/EOR
*DECK DECK=DSP$170_UPDATE_FREE_RUN_CLOCK EXPAND=FALSE
*DECK DECK=DSP$ACCESS_DEADSTART_SECTOR EXPAND=FALSE

  PROCEDURE [XREF] dsp$access_deadstart_sector
    (    ds_sector_device_path: dst$ds_sector_device_path;
     VAR deadstart_sector_data_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc dst$ds_sector_device_path
*copyc ost$status
?? POP ??
*DECK DECK=DSP$ACCESS_SECURE_MODE EXPAND=FALSE

  PROCEDURE [XREF] dsp$access_secure_mode
    (    access_function: 0 .. 0ff(16);
     VAR mode: 0 .. 0ffff(16);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DSP$ACCESS_VCU_CDA_DATA EXPAND=FALSE

  PROCEDURE [XREF] dsp$access_vcu_cda_data
    (    type_of_access: dst$vcu_access_type;
         data_access: dst$vcu_data_accessed;
     VAR data_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$vcu_cda_data
*copyc ost$status
?? POP ??
*DECK DECK=DSP$ADD_TO_PP_LIBRARY EXPAND=FALSE

  PROCEDURE [XREF] dsp$add_to_pp_library;
*DECK DECK=DSP$ADVANCE_DEADSTART_SEQUENCE EXPAND=FALSE

  PROCEDURE [XREF] dsp$advance_deadstart_sequence
    (    sequence_step: dst$deadstart_sequence_steps);

?? PUSH (LISTEXT := ON) ??
*copyc dst$deadstart_sequence_steps
?? POP ??
*DECK DECK=DSP$ADVANCE_DS_SEQUENCE_IN_MTR EXPAND=FALSE

  PROCEDURE [XREF] dsp$advance_ds_sequence_in_mtr
    (    sequence_step: dst$deadstart_sequence_steps);

?? PUSH (LISTEXT := ON) ??
*copyc dst$deadstart_sequence_steps
?? POP ??
*DECK DECK=DSP$ALLOCATE_CONTINUOUS_MEMORY EXPAND=FALSE

  PROCEDURE [XREF] dsp$allocate_continuous_memory
    (    heap_p: ^ost$heap;
         size: integer;
     VAR return_seq_p: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc ost$heap
?? POP ??
*DECK DECK=DSP$ALLOW_SYS_MSG_LOGGING EXPAND=FALSE

  PROCEDURE [XREF] dsp$allow_sys_msg_logging;
*DECK DECK=DSP$APPEND_FILE_TO_DS_FILE EXPAND=FALSE

  PROCEDURE [XREF] dsp$append_file_to_ds_file
    (    file_length: amt$file_byte_address;
         deadstart_file: ost$name;
     VAR file_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=DSP$ATTACH_LABEL_FOR_UPGRADE EXPAND=FALSE

  PROCEDURE [XREF] dsp$attach_label_for_upgrade;
*DECK DECK=DSP$ATTACH_RDF_FOR_IDLE EXPAND=FALSE

  PROCEDURE [XREF] dsp$attach_rdf_for_idle;
*DECK DECK=DSP$BOOT_DEADSTART_LOADER EXPAND=FALSE

  PROCEDURE [XREF] dsp$boot_deadstart_loader;
*DECK DECK=DSP$BUILD_MAINFRAME_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] dsp$build_mainframe_information;
*DECK DECK=DSP$BUILD_RECOVERY_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] dsp$build_recovery_segment;
*DECK DECK=DSP$BUILD_SEQUENCE_P EXPAND=FALSE

  PROCEDURE [XREF] dsp$build_sequence_p
    (    seq_pva_p: ^cell,
         limit: integer;
     VAR return_seq_p: ^SEQ ( * ));
*DECK DECK=DSP$C170_ACCESS_TO_SSR EXPAND=FALSE
?? NEWTITLE := '~~~~~   common deck DSP$C170_ACCESS_TO_SSR', EJECT ??
{}
{ssr access XREF's, deck DSP$C170_ACCESS_TO_SSR}
{}

  PROCEDURE [XREF] find_ssr_entry ALIAS 'dspfind' (name: string (4);
    VAR ssr_offset: integer);

  PROCEDURE [XREF] set_ssr_directory_entry ALIAS 'dspsets' (ssr_offset:
    integer;
        new_left: 0 .. 0ffff(16);
        new_right: 0 .. 0ffff(16));

  PROCEDURE [XREF] get_ssr_directory_entry ALIAS 'dspgets' (ssr_offset:
    integer;
    VAR old_left: integer;
    VAR old_right: integer);

*copyc dsc$ssr_entry_constants
?? OLDTITLE ??
*DECK DECK=DSP$CALLSDA EXPAND=FALSE
?? NEWTITLE := '~~~~~  common deck DSP$CALLSDA', EJECT ??
{***********************************************************

{  System deadstart assist interface definitions.

{***********************************************************


  CONST

{  SDA function codes.

    load_vpb = 1,                 {load pp boot
    read_mch = 2,                 {read maintenance register
    idle_pp = 5,                  {idle pp
    dac = 6,                      {dcn channel
    call_dft = 7,                 {call dft to process a request for ve
    fetch_hdt = 9,                {fetch hdt information from cti
    clear_nos_ve_dft_buffer_p = 10,
    write_dft_request_block = 11, {call dft to process a 170 request
    fetch_ve_enabled_status = 12; {check for VE entry in CMRDECK

  TYPE
    register_record = PACKED RECORD
      register_value: PACKED ARRAY [1 .. register_size] OF 0 .. 7777(8),
      number: 0 .. 7777(8),
      length: 0 .. 77(8),
      status: 0 .. 77(8),
    RECEND;

  TYPE
    r_pointer = PACKED RECORD
      offset: 0 .. 0fff(16),
      rupper: 0 .. 0fff(16),
      rlower: 0 .. 0fff(16),
    RECEND;

  TYPE
    sda_call = (general_calls, write_dft_request);

  TYPE
    pp_data_type = PACKED RECORD
      CASE sda_call OF
      = general_calls =

{  Word 0.

        port_code: 0 .. 7777(8),
        pp_number: 0 .. 7777(8),
        size: 0 .. 77777777(8),
        completion: 0 .. 7777(8),

{  Word 1.

        ssr_buffer: r_pointer,
        fill1: 0 .. 77(8),
        data_buffer: ^cell,

      = write_dft_request =

{  Word 0.

        fill2: 0 .. 777777777777(8),
        dft_request_length: 0 .. 7777(8),
        completion1: 0 .. 7777(8),

{  Word 1.

{  R pointer in NOS/VE memory for DFT request.

        ve_dft_request_p: r_pointer,
        fill4: 0 .. 77(8),

{  Address relative to NVE subsystem of DFT request.

        os_170_dft_request_p: ^cell,
      CASEND,
    RECEND;

  VAR
    pp_table: pp_data_type;

  PROCEDURE [XREF] callsda
    (    fn: integer;
     VAR pp_table: pp_data_type);
?? OLDTITLE ??
*DECK DECK=DSP$CALLVER EXPAND=FALSE
?? NEWTITLE := '~~~~~  common deck DSP$CALLVER', EJECT ??
{***********************************************************

{  Interface to 170 OS virtual environment resource program.

{***********************************************************

  VAR
   ver_request: ver_request_block;

  PROCEDURE [XREF] callver
    (VAR ver_request: ver_request_block;
         operation: ver_functions;
         wait: boolean);

  CONST
    nio_channel = 0,
    cio_channel = 1;

  CONST
    non_driver_pp = 0,
    driver_pp = 1,
    cio_cluster_0 = 2,
    cio_cluster_1 = 3,
    pair_of_pps = 4;

  TYPE
    ver_functions = (rscm, rspp, rsch, rseq, rtcm, rtpp, rtch, rteq, stcm,
                     stpp, stch, steq, stmr,
                     ifrc, rspt, rsct, rnpt, rnct, stpt, stct );

  TYPE
    iou_resource = PACKED RECORD
      primary: 0 .. 77(8),
      secondary: 0 .. 77(8),
      kind: 0 .. 7777(8),
      fill: 0 .. 77777777(8),
      status: 0 .. 7777(8),
    RECEND;

  TYPE
    eq_path = PACKED RECORD
      channel: 0 .. 77(8),
      equipment: 0 .. 77(8),
      unit: 0 .. 77(8),
      fill: 0 .. 7777777777(8),
      status: 0 .. 7777(8),
      fil1: 0 .. 77777777(8),
      equipment_type: 0 .. 7777(8),
      fil2: 0 .. 77777(8),
      est_ordinal: 0 .. 777(8),
    RECEND;

  TYPE
    cm_request_type = PACKED RECORD
      fill1: 0 .. 77777777777777(8),
      words_div_1000: 0 .. 777777(8),
      fill2: 0 .. 7777(8),
      fwa_div_1000: 0 .. 77777777(8),
      lwa_div_1000: 0 .. 77777777(8),
    RECEND;

  TYPE
    resource_status_type = PACKED RECORD
      fill1: 0 .. 77777777777777(8),
      available_words_div_1000: 0 .. 777777(8),
      fill2: 0 .. 777777777777(8),
      fill3: 0 .. 777777(8),
      available_pps: 0 .. 77(8),
    RECEND;

  TYPE
    ver_request_block = PACKED RECORD
      return_all: boolean,
      fill: 0 .. 377777777777(8),
      length: 0 .. 7777(8),
      general_status: 0 .. 7777(8),
      CASE ver_functions OF
      = rscm, rtcm, stcm =
        cm_block: cm_request_type,
      = stmr =
        resources: resource_status_type,
      = rspp, rtpp =
        pp: iou_resource,
      = rsch, rtch =
        channel: iou_resource,
      = stpp =
        pps: ARRAY [1 .. 30] OF iou_resource,
      = stch =
        channels: ARRAY [1 .. 34] OF iou_resource,
      = rseq, rteq =
        eq: eq_path,
      = steq =
        clear: integer,
      = ifrc =
        fill1: 0 .. 07777(8),
        new_value: 0 .. 07777777777777777(8),  { 48 bits for new FRC value
      CASEND,
    RECEND;
?? OLDTITLE ??
*DECK DECK=DSP$CALL_DFT_THROUGH_SDA EXPAND=FALSE

  PROCEDURE [XREF] dsp$call_dft_through_sda
    (    dft_request_p: ^SEQ ( * ));
*DECK DECK=DSP$CHANGE_CHANNEL_STATES EXPAND=FALSE

  PROCEDURE [XREF] dsp$change_channel_states
    (    channel_state_list: dst$partial_channel_state_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$channel_state
*copyc ost$status
?? POP ??
*DECK DECK=DSP$CHANGE_CY2000_ELEMENT EXPAND=FALSE

  PROCEDURE [XREF] dsp$change_cy2000_element
    (    element_id: 0 .. 0ff(16);
         sub_element_id: 0 .. 0ffff(16);
         status: 0 .. 0ff(16);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DSP$CHANGE_DATE_TIME_INFO EXPAND=FALSE

  PROCEDURE [XREF] dsp$change_date_time_info
    (    options_set: dst$change_date_time_set;
         date_time_information: dst$date_time_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$change_date_time_set
*copyc dst$date_time_information
*copyc ost$status
?? POP ??
*DECK DECK=DSP$CHANGE_MONITOR_XP EXPAND=FALSE

  PROCEDURE [XREF] dsp$change_monitor_xp
    (    number: dst$dft_cpu_selections;
         mps: ost$real_memory_address;
     VAR status: ost$status );

?? PUSH (LISTEXT := ON) ??
*copyc dst$dft_cpu_selections
*copyc ost$hardware_subranges
*copyc ost$status
?? POP ??
*DECK DECK=DSP$CHANGE_OPERATION_PASSWORD EXPAND=FALSE

  PROCEDURE [XREF] dsp$change_operation_password
    (    old_password: ost$name;
         new_password: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=DSP$CHANGE_PROCESSOR_STATE EXPAND=FALSE

  PROCEDURE [XREF] dsp$change_processor_state
    (    processor_id: ost$processor_id;
         state_data: dst$change_processor_state;
         service_processor_recovery: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dst$change_processor_state
*copyc ost$processor_id
?? POP ??
*DECK DECK=DSP$CHANGE_SECURE_ANALYSIS EXPAND=FALSE

  PROCEDURE [XREF] dsp$change_secure_analysis
    (    secure_analysis: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DSP$CHECK_IF_VE_RUNNING EXPAND=FALSE

  PROCEDURE [XREF] dsp$check_if_ve_running;
*DECK DECK=DSP$CHECK_INTERVAL EXPAND=FALSE

  PROCEDURE [XREF] dsp$check_interval;
*DECK DECK=DSP$CHECK_INTERVAL_23D EXPAND=FALSE

  PROCEDURE [XREF] dsp$check_interval_23d;
*DECK DECK=DSP$CHECK_PASSWORD_FOR_INISD EXPAND=FALSE

  PROCEDURE [XREF] dsp$check_password_for_inisd
    (    id: dpt$window_id;
     VAR password_valid: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
?? POP ??
*DECK DECK=DSP$CHECK_SAVED_PASSWORDS EXPAND=FALSE

  PROCEDURE [XREF] dsp$check_saved_passwords;
*DECK DECK=DSP$CHECK_SYSTEM_AVAILABLE EXPAND=FALSE

  PROCEDURE [XREF] dsp$check_system_available
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DSP$CLAIM_NVE_RESOURCES EXPAND=FALSE

  PROCEDURE [XREF] dsp$claim_nve_resources
    (VAR rblock: dst$170_request_block);

?? PUSH (LISTEXT := ON) ??
*copyc dst$170_request_block
?? POP ??
*DECK DECK=DSP$CLEANUP_DEADSTART_IO EXPAND=FALSE

  PROCEDURE [XREF] dsp$cleanup_deadstart_io
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DSP$CLEAR_OPERATOR_ACTION EXPAND=FALSE
*DECK DECK=DSP$CLEAR_SYS_MSG_BUFFER_IN_RDF EXPAND=FALSE

  PROCEDURE [XREF] dsp$clear_sys_msg_buffer_in_rdf;
*DECK DECK=DSP$CLOSE_IMAGE_FILE EXPAND=FALSE

  PROCEDURE [XREF] dsp$close_image_file
    (    image_file_sfid: dmt$system_file_id;
         image_file_segment: mmt$segment_pointer);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc mmt$attribute_keyword
?? POP ??
*DECK DECK=DSP$CLOSE_RDF EXPAND=FALSE

  PROCEDURE [XREF] dsp$close_rdf
    (    rdf_file_sfid: dmt$system_file_id;
         rdf_file_segment: mmt$segment_pointer);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc mmt$attribute_keyword
?? POP ??
*DECK DECK=DSP$CLOSE_SSR EXPAND=FALSE

  PROCEDURE [XREF] dsp$close_ssr
    (VAR ssr_segment_number: ost$segment;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=DSP$COMPLETE_DEADSTART_FILE EXPAND=FALSE

  PROCEDURE [XREF] dsp$complete_deadstart_file
    (    deadstart_file: ost$name;
         mau_file_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=DSP$CONVERT_R_POINTER_TO_SEQ_P EXPAND=FALSE

  PROCEDURE [INLINE] dsp$convert_r_pointer_to_seq_p
    (    r_pointer: dst$r_pointer;
         base_p: ^cell;
     VAR seq_p: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??

{ PURPOSE:
{   The purpose of this procedure is to convert a R pointer to a sequence pointer.

    VAR
      adjusted_pva_p: ^cell,
      base_rma: integer,
      r_pointer_rma: integer,
      seq_entry_pp: ^^SEQ ( * ),
      seq_header: cyt$sequence_pointer;

    { The r_pointer contains: offset, r_upper, r_lower, length
    { rma of r_pointer := r_upper*10000000(8) + r_lower*1000(8) + offset*10(8)

    r_pointer_rma := r_pointer.rupper * 10000000(8) + r_pointer.rlower * 1000(8) + r_pointer.offset * 10(8);

    i#real_memory_address (base_p, base_rma);
    adjusted_pva_p := #ADDRESS (#RING (base_p), #SEGMENT (base_p),
          ((r_pointer_rma - base_rma) + #OFFSET (base_p)));

    seq_entry_pp := #LOC (seq_header);
    seq_header.pva := adjusted_pva_p;
    seq_header.length := r_pointer.length * 8;
    seq_header.nextt := 0;
    seq_p := seq_entry_pp^;
    RESET seq_p;

  PROCEND dsp$convert_r_pointer_to_seq_p;

*copyc cyd$cybil_structure_definitions
*copyc dst$r_pointer
*copyc i#real_memory_address
?? POP ??
*DECK DECK=DSP$CONVERT_SEQ_P_TO_R_POINTER EXPAND=FALSE

  PROCEDURE [INLINE] dsp$convert_seq_p_to_r_pointer
    (    seq_p: ^SEQ ( * );
     VAR r_pointer: dst$r_pointer);

?? PUSH (LISTEXT := ON) ??

{ PURPOSE:
{   The purpose of this procedure is to convert a sequence pointer to
{   r_pointer format for use by a PPU.

    VAR
      seq_p_rma: integer;

    i#real_memory_address (seq_p, seq_p_rma);
    r_pointer.offset := (seq_p_rma DIV 10(8)) MOD 100(8);
    r_pointer.rupper := seq_p_rma DIV 10000000(8);
    r_pointer.rlower := (seq_p_rma DIV 1000(8)) MOD 10000(8);
    r_pointer.length := (#SIZE (seq_p^) + 7) DIV 8;

  PROCEND dsp$convert_seq_p_to_r_pointer;

*copyc dst$r_pointer
*copyc i#real_memory_address
?? POP ??
*DECK DECK=DSP$COPY_MEMORY EXPAND=FALSE
?? NEWTITLE := '~~~~~   common deck DSP$COPY_MEMORY', EJECT ??
{********************************************************

{  Central memory access routines, deck DSP$COPY_MEMORY.

{********************************************************

  CONST
    max_memory_transfer = 30000,

{  Define constants for different pva types.

    interface_block = 0,
    start_of_ve = 1,
    start_of_ssr = 2,
    start_of_mf_wired = 3,
    dft_buffer = 4,
    start_of_dft_buffer_0 = dft_buffer;

  TYPE
    cm_transfer_method = (nos60_to_ve64, ve64_to_nos60, nos32_to_ve64,
      ve64_to_nos32, nos60_to_ve60, ve60_to_nos60, zero60_to_ve64),
    starting_pva = 0 ..0ffff(16),
    memory_copy_header = RECORD

{  The length is in units of the destination.  That is, the copy operation
{  terminates when "length" units have been transferred to the destination.

      length: 0 .. max_memory_transfer,
      copy_method: cm_transfer_method,
      pva_type: starting_pva,
      byte_rma: 0 .. 0ffffffff(16),
    RECEND;

  PROCEDURE [XREF] copy_memory ALIAS 'minilnk'
    (VAR hdr: memory_copy_header;
         buffer_pointer: ^cell);

  PROCEDURE [XREF] set_ei_pva ALIAS 'seteiad'
    (    pva: starting_pva;
         word_offset: integer);

  PROCEDURE [XREF] get_ei_pva ALIAS 'geteiad'
    (    pva: starting_pva;
     VAR word_offset: integer);

*copyc dsi$dft_types_and_constants
?? OLDTITLE ??
*DECK DECK=DSP$CREATE_IMAGE_FILE EXPAND=FALSE

  PROCEDURE [XREF] dsp$create_image_file
    (    file_length: amt$file_byte_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc ost$status
?? POP ??
*DECK DECK=DSP$CREATE_PP_LIBRARY EXPAND=FALSE

    PROCEDURE [XREF] dsp$create_pp_library;
*DECK DECK=DSP$CREATE_SYSTEM_FILES EXPAND=FALSE

  PROCEDURE [XREF] dsp$create_system_files
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DSP$DETACH_RDF_AFTER_RESUME EXPAND=FALSE

  PROCEDURE [XREF] dsp$detach_rdf_after_resume;
*DECK DECK=DSP$DETERMINE_IF_ENTRY_IN_RDF EXPAND=FALSE

  PROCEDURE [XREF] dsp$determine_if_entry_in_rdf
    (    rdf_name: dst$rdf_entries;
         rdf_type: dst$rdf_type;
     VAR rdf_entry_exists: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dst$rdf_entries
*copyc dst$rdf_type
?? POP ??
*DECK DECK=DSP$DFT_ISSUE_SYSTEM_ALERT EXPAND=FALSE

  PROCEDURE [XREF] dsp$dft_issue_system_alert
    (    alert_source: dst$dft_alert_source;
         supportive_information_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$dft_alert_source
*copyc ost$status
?? POP ??
*DECK DECK=DSP$DST_COMPASS_INTERFACE EXPAND=FALSE
?? NEWTITLE := '~~~~~   common deck DSP$DST_COMPASS_INTERFACE', EJECT ??
{***********************************************************************
{}
{ dsc external entry points, deck DSP$DST_COMPASS_INTERFACE.
{}
{***********************************************************************

  CONST
    system_dayf = 0,
    bdisplay_line1 = 1,
    bdisplay_line2 = 2,
    user_dayf = 3,
    error_log = 4,
    account = 5,
    debug_log = 7;
?? SKIP := 3 ??
  PROCEDURE [XREF] dyfstring (s: string ( * );
        dayfile: 0 .. 7);

  PROCEDURE [XREF] dyfstrnum (s: string ( * );
        value: integer;
        dayfile: 0 .. 7);
?? SKIP := 3 ??

  VAR
    load_offset_bytes: [XREF] integer;
?? OLDTITLE ??
*DECK DECK=DSP$DST_GLOBAL_VARIABLES EXPAND=FALSE
?? NEWTITLE := '~~~~~   common deck DSP$DST_GLOBAL_VARIABLES', EJECT ??

  TYPE
    deadstart_type = (start_dual_state, term_dual_state);

  PROCEDURE [XREF] endprgr;

  PROCEDURE [XREF] set_priority_normal ALIAS 'setprn';

  PROCEDURE [XREF] offmode;

  PROCEDURE [XREF] onmode;

  PROCEDURE [XREF] display;

  PROCEDURE [XREF] gettime (VAR clock_value: integer);

  PROCEDURE [XREF] wakeup;

  PROCEDURE [XREF] deadstart_cpu ALIAS 'dstcpu' (kind: deadstart_type);

  PROCEDURE [XREF] get_ve_status ALIAS 'getvest' (VAR status: integer);

  PROCEDURE [XREF] makscpb;

?? OLDTITLE ??
*DECK DECK=DSP$ENLARGE_SYS_MSG_BUFFER EXPAND=FALSE

  PROCEDURE [XREF] dsp$enlarge_sys_msg_buffer;
*DECK DECK=DSP$EXIT_DEADSTART EXPAND=FALSE

  PROCEDURE [XREF] dsp$exit_deadstart
    (    next_program: (dsc$terminate_ve, dsc$run_ve));
*DECK DECK=DSP$EXTEND_IMAGE_FILE EXPAND=FALSE

  PROCEDURE [XREF] dsp$extend_image_file
    (    file_length: amt$file_byte_address;
         current_file_length: amt$file_byte_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc ost$status
?? POP ??
*DECK DECK=DSP$FETCH_BOOT_DATA EXPAND=FALSE

  PROCEDURE [XREF] dsp$fetch_boot_data
    (    data_kind: dst$boot_data_kinds;
     VAR data_p: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc dst$boot_data_kinds
?? POP ??
*DECK DECK=DSP$FETCH_CONTROLWARE EXPAND=FALSE

  PROCEDURE [XREF] dsp$fetch_controlware
    (    controlware_name: dst$resource_name;
     VAR controlware_seq_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$resource_name
*copyc ost$status
?? POP ??
*DECK DECK=DSP$FETCH_LIST_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] dsp$fetch_list_block
    (    list_type: dst$list_block_kind;
     VAR list_block_p: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc dst$list_block_kind
?? POP ??
*DECK DECK=DSP$FETCH_MAU_LIST EXPAND=FALSE

  PROCEDURE [XREF] dsp$fetch_mau_list
    (    only_perform_allocates: boolean;
         label_file: dmt$deadstart_label_files;
     VAR mau_list_p: ^dmt$mau_address_list;
     VAR mau_count: dmt$mau_count;
     VAR transfer_size: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$deadstart_label_files
*copyc dmt$mau_list
*copyc ost$status
?? POP ??
*DECK DECK=DSP$FETCH_PP_IMAGE EXPAND=FALSE

  PROCEDURE [XREF] dsp$fetch_pp_image
    (    name: dst$driver_name;
         option: dst$fetch_pp_image_option;
     VAR length: ost$pp_byte_size;
     VAR image_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc dst$driver_name
*copyc dst$fetch_pp_image_option
*copyc ost$pp_size
*copyc ost$status
?? POP ??
*DECK DECK=DSP$FORCE_LOCK_OF_MAIN_WINDOW EXPAND=FALSE

  PROCEDURE [XREF] dsp$force_lock_of_main_window;
*DECK DECK=DSP$FORCE_LOCK_OF_WINDOW_23D EXPAND=FALSE

  PROCEDURE [XREF] dsp$force_lock_of_window_23d;
*DECK DECK=DSP$GET_CPU_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] dsp$get_cpu_attributes
    (VAR cpu_attributes: dst$cpu_attributes);

?? PUSH (LISTEXT := ON) ??
*copyc dst$cpu_attributes
?? POP ??
*DECK DECK=DSP$GET_CY2000_ELEMENT EXPAND=FALSE

  PROCEDURE [XREF] dsp$get_cy2000_element
    (    element_id: 0 .. 0ff(16);
         sub_element_id: 0 .. 0ffff(16);
     VAR entry_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$dft_requests
*copyc ost$status
?? POP ??
*DECK DECK=DSP$GET_DATA_FROM_RDF EXPAND=FALSE

  PROCEDURE [XREF] dsp$get_data_from_rdf
    (    rdf_name: dst$rdf_entries;
         rdf_type: dst$rdf_type;
     VAR rdf_value_p: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc dst$rdf_entries
*copyc dst$rdf_type
?? POP ??
*DECK DECK=DSP$GET_DATA_FROM_SSR EXPAND=FALSE

  PROCEDURE [XREF] dsp$get_data_from_ssr
    (    ssr_entry_name: dst$ssr_entry_name;
     VAR ssr_value_p: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc dst$ssr_data_types
?? POP ??
*DECK DECK=DSP$GET_ENTRY_FROM_SSR EXPAND=FALSE

  PROCEDURE [XREF] dsp$get_entry_from_ssr
    (    ssr_entry_name: dst$ssr_entry_name;
     VAR ssr_entry: dst$ssr_entry);

?? PUSH (LISTEXT := ON) ??
*copyc dst$ssr_data_types
?? POP ??
*DECK DECK=DSP$GET_FLAW_MAP EXPAND=FALSE

  PROCEDURE [XREF] dsp$get_flaw_map
    ( VAR flaw_map_p: ^array [1 .. *] of mmt$page_frame_index_32);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_index
?? POP ??

*DECK DECK=DSP$GET_INTEGER_FROM_RDF EXPAND=FALSE

  PROCEDURE [XREF] dsp$get_integer_from_rdf
    (    rdf_name: dst$rdf_entries;
         rdf_type: dst$rdf_type;
     VAR rdf_value: integer);

?? PUSH (LISTEXT := ON) ??
*copyc dst$rdf_entries
*copyc dst$rdf_type
?? POP ??
*DECK DECK=DSP$GET_IOU_RESOURCE_INFO EXPAND=FALSE
*DECK DECK=DSP$GET_IOU_STATUS_REGISTER EXPAND=FALSE

  PROCEDURE [XREF] dsp$get_iou_status_register
    (    iou_number: dst$iou_number;
     VAR iou_status_register: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$iou_number
*copyc ost$status
?? POP ??
*DECK DECK=DSP$GET_NVE_IMAGE_DESCRIPTION EXPAND=FALSE

  PROCEDURE [XREF] dsp$get_nve_image_description
    (VAR descriptor: dst$nve_image_descriptor);

?? PUSH (LISTEXT := ON) ??
*copyc dst$nve_image_descriptor
?? POP ??
*DECK DECK=DSP$GET_PP_REGISTERS EXPAND=FALSE

  PROCEDURE [XREF] dsp$get_pp_registers
    (    pp: dst$iou_resource;
     VAR registers: dst$dft_pp_registers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$dft_pp_registers
*copyc dst$iou_resource
*copyc ost$status
?? POP ??
*DECK DECK=DSP$GET_RDF_ENTRY_SEQ_POINTER EXPAND=FALSE

  PROCEDURE [XREF] dsp$get_rdf_entry_seq_pointer
    (    rdf_name: dst$rdf_entries;
         rdf_type: dst$rdf_type;
     VAR rdf_pointers: dst$rdf_pointers;
     VAR rdf_entry_seq_p: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc dst$rdf_entries
*copyc dst$rdf_pointers
*copyc dst$rdf_type
?? POP ??
*DECK DECK=DSP$GET_SSR_DATA_RMA EXPAND=FALSE

  PROCEDURE [XREF] dsp$get_ssr_data_rma
    (    ssr_entry_name: dst$ssr_entry_name;
     VAR ssr_data_rma: integer;
     VAR ssr_data_size: integer);

?? PUSH (LISTEXT := ON) ??
*copyc dst$ssr_data_types
?? POP ??
*DECK DECK=DSP$GET_SSR_DATA_R_POINTER EXPAND=FALSE

  PROCEDURE [XREF] dsp$get_ssr_data_r_pointer
    (    ssr_entry_name: dst$ssr_entry_name;
     VAR ssr_data_r_pointer: dst$r_pointer);

?? PUSH (LISTEXT := ON) ??
*copyc dst$r_pointer
*copyc dst$ssr_data_types
?? POP ??
*DECK DECK=DSP$GET_SSR_DATA_SEQ_PTR EXPAND=FALSE

  PROCEDURE [XREF] dsp$get_ssr_data_seq_ptr
    (    ssr_entry_name: dst$ssr_entry_name;
         ssr_segment_number: ost$segment;
     VAR ssr_data_seq_p: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc dst$ssr_data_types
*copyc osd$virtual_address
?? POP ??
*DECK DECK=DSP$IDLE_PP EXPAND=FALSE

  PROCEDURE [XREF] dsp$idle_pp
    (    pp: dst$iou_resource;
         dump_registers_only: boolean;
         dump_pp: boolean;
     VAR dump_area_p: ^SEQ( * );
     VAR status: ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc dst$iou_resource
*copyc ost$status
?? POP ??
*DECK DECK=DSP$IDLE_SYSTEM EXPAND=FALSE

  PROCEDURE [XREF] dsp$idle_system
    (    allow_system_commit: boolean);
*DECK DECK=DSP$INITIALIZE_IO EXPAND=FALSE

  PROCEDURE [XREF] dsp$initialize_io
    (    element_name: cmt$element_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=DSP$INITIALIZE_SYS_MSG_BUFFER EXPAND=FALSE

  PROCEDURE [XREF] dsp$initialize_sys_msg_buffer;
*DECK DECK=DSP$ISSUE_SYSTEM_ALERT EXPAND=FALSE

  PROCEDURE [XREF] dsp$issue_system_alert
    (    alert_source: dst$dft_alert_source;
         supportive_information_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$dft_alert_source
*copyc ost$status
?? POP ??
*DECK DECK=DSP$LOAD_ADDITIONAL_DFT EXPAND=FALSE

  PROCEDURE [XREF] dsp$load_additional_dft
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DSP$LOAD_PP EXPAND=FALSE

  PROCEDURE [XREF] dsp$load_pp
    (    type_of_pp_load: (dsc$load_pp_image, dsc$load_pp_by_name);
         pp: dst$iou_resource;
         image_p: ^SEQ ( * );
         name: dst$driver_name;
         table_rma: ost$real_memory_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$iou_resource
*copyc dst$driver_name
*copyc ost$hardware_subranges
*copyc ost$status
?? POP ??
*DECK DECK=DSP$LOCK_UNLOCK_MAIN_WINDOW EXPAND=FALSE

  PROCEDURE [XREF] dsp$lock_unlock_main_window
    (    password: ost$name;
         lock_window: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=DSP$LOCK_UNLOCK_WINDOW_FROM_MTR EXPAND=FALSE

  PROCEDURE [XREF] dsp$lock_unlock_window_from_mtr
    (    signal_entry: dst$signal_contents_entry);

?? PUSH (LISTEXT := ON) ??
*copyc dst$signal_contents
?? POP ??
*DECK DECK=DSP$LOG_DFT_DATA EXPAND=FALSE

  PROCEDURE [XREF] dsp$log_dft_data
    (    flag_id: ost$system_flag);

?? PUSH (LISTEXT := ON) ??
*copyc ost$system_flag
?? POP ??
*DECK DECK=DSP$LOG_DFT_TOP_OF_HOUR EXPAND=FALSE

  PROCEDURE [XREF] dsp$log_dft_top_of_hour;
*DECK DECK=DSP$LOG_JOB_RECOVERY_STATISTICS EXPAND=FALSE

  PROCEDURE [XREF] dsp$log_job_recovery_statistics
    (    recovered_job_count: integer;
         jobs_recovering_count: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DSP$LOG_SYSTEM_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] dsp$log_system_message
    (    message_type: integer;
     VAR log_data_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DSP$LOG_SYS_MSG_HELP EXPAND=FALSE

  PROCEDURE [XREF] dsp$log_sys_msg_help
    (    message_type: integer;
     VAR log_data_p: ^SEQ (*));
*DECK DECK=DSP$MAKE_SSR_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] dsp$make_ssr_segment;
*DECK DECK=DSP$MANAGE_DFTB_SPACE_IN_MFW EXPAND=FALSE

  PROCEDURE [XREF] dsp$manage_dftb_space_in_mfw
    (    action: dst$dftb_manage_space;
     VAR space_seq_p: ^SEQ ( * );
     VAR request_completed: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dst$dftb_manage_space
?? POP ??
*DECK DECK=DSP$MANAGE_VIRTUAL_CPU EXPAND=FALSE

  PROCEDURE [XREF] dsp$manage_virtual_cpu
    (    number: ost$processor_id);

?? PUSH (LISTEXT := ON) ??
*copyc ost$processor_id
?? POP ??
*DECK DECK=DSP$MOVE_PP_DRIVER EXPAND=FALSE

  PROCEDURE [XREF] dsp$move_pp_driver
    (    name: dst$driver_name;
     VAR driver_code_p: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc dst$driver_name
?? POP ??
*DECK DECK=DSP$MOVE_PP_OVERLAYS EXPAND=FALSE

  PROCEDURE [XREF] dsp$move_pp_overlays
    (    name: dst$driver_name;
     VAR rma: ost$real_memory_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$driver_name
*copyc ost$hardware_subranges
*copyc ost$status
?? POP ??
*DECK DECK=DSP$MTR_CHANGE_BCT_FLAG EXPAND=FALSE

  PROCEDURE [XREF] dsp$mtr_change_bct_flag
    (    action: dst$rb_sds_actions;
         bct_flag: dst$rb_sds_bct_flags);

?? PUSH (LISTEXT := ON) ??
*copyc dst$rb_system_deadstart_status
?? POP ??
*DECK DECK=DSP$MTR_DFT_PUF_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] dsp$mtr_dft_puf_request
    (    subfunction: dst$dft_puf_subfunctions;
         logical_pp: iot$pp_number;
         resume_address: dst$dft_resume_address;
    VAR pp_data_seq_p: ^SEQ ( * );
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$dft_puf_subfunctions
*copyc dst$dft_resume_address
*copyc iot$pp_number
*copyc syt$monitor_status
?? POP ??
*DECK DECK=DSP$MTR_DFT_RELOAD_SCI EXPAND=FALSE

  PROCEDURE [XREF] dsp$mtr_dft_reload_sci
    (    pp: dst$iou_resource;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$iou_resource
*copyc syt$monitor_status
?? POP ??
*DECK DECK=DSP$MTR_GET_SSR_DATA_SEQ_PTR EXPAND=FALSE

  PROCEDURE [XREF] dsp$mtr_get_ssr_data_seq_ptr
    (    ssr_entry_name: dst$ssr_entry_name;
     VAR ssr_data_seq_p: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc dst$ssr_data_types
?? POP ??
*DECK DECK=DSP$MTR_HANDLE_BIT_57 EXPAND=FALSE

  PROCEDURE [XREF] dsp$mtr_handle_bit_57
    (    element_number: dst$dftb_mrt_element_index);

?? PUSH (LISTEXT := ON) ??
*copyc dst$180_dft_block
?? POP ??
*DECK DECK=DSP$MTR_HANDLE_PP_HANG EXPAND=FALSE

  PROCEDURE [XREF] dsp$mtr_handle_pp_hang
    (    element_number: dst$dftb_mrt_element_index;
         data_from_mrb: boolean;
         data_p: ^cell);

?? PUSH (LISTEXT := ON) ??
*copyc dst$180_dft_block
?? POP ??
*DECK DECK=DSP$MTR_PROCESS_HUNG_PP EXPAND=FALSE

  PROCEDURE [XREF] dsp$mtr_process_hung_pp
    (    logical_pp: iot$pp_number);

?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
?? POP ??
*DECK DECK=DSP$MTR_RESERVE_PUF_MEMORY_AREA EXPAND=FALSE

  PROCEDURE [XREF] dsp$mtr_reserve_puf_memory_area
    (VAR data_p: ^dst$mtr_dft_puf_memory_area);

?? PUSH (LISTEXT := ON) ??
*copyc dst$mtr_dft_requests
?? POP ??
*DECK DECK=DSP$MTR_RETURN_PUF_MEMORY_AREA EXPAND=FALSE

  PROCEDURE [XREF] dsp$mtr_return_puf_memory_area;
*DECK DECK=DSP$MTR_SAVE_CAUSE_AND_TIME EXPAND=FALSE

  PROCEDURE [XREF] dsp$mtr_save_cause_and_time
    (    timestamp: ost$free_running_clock;
         probable_cause: 0 .. 0ffff(16));

?? PUSH (LISTEXT := ON) ??
*copyc dst$ssr_data_types
*copyc ost$free_running_clock
?? POP ??
*DECK DECK=DSP$MTR_SAVE_DISK_ERROR EXPAND=FALSE

  PROCEDURE [XREF] dsp$mtr_save_disk_error
    (    action: dst$ssr_sds_disk_error_actions;
         timestamp: ost$free_running_clock;
         element_name: cmt$element_name);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc dst$ssr_data_types
*copyc ost$free_running_clock
?? POP ??
*DECK DECK=DSP$MTR_SAVE_MAINFRAME_ERROR EXPAND=FALSE

  PROCEDURE [XREF] dsp$mtr_save_mainframe_error
    (    element_number: dst$dftb_mrt_element_index;
         date_and_time_word: dst$dftb_date_and_time;
         fault_symptom_words: dst$dftb_fault_symptom_words);

?? PUSH (LISTEXT := ON) ??
*copyc dst$180_dft_block
?? POP ??
*DECK DECK=DSP$MTR_SAVE_NOS_NBE_STATUS EXPAND=FALSE

  PROCEDURE [XREF] dsp$mtr_save_nos_nbe_status
    (    nos_nbe_status: integer);

?? PUSH (LISTEXT := ON) ??
*copyc ost$170_os_termination_status
?? POP ??
*DECK DECK=DSP$MTR_SAVE_TOP_LINE_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] dsp$mtr_save_top_line_message
    (    message: string( * ));
*DECK DECK=DSP$NOTIFY_OPERATOR EXPAND=FALSE

 PROCEDURE [XREF] notify_operator ALIAS 'DSPNO'
         (s: string(*));
*DECK DECK=DSP$NVE_RESOURCE_INTERFACE EXPAND=FALSE

  PROCEDURE [XREF] dsp$nve_resource_interface;

  PROCEDURE [XREF] dsp$nve_down_condition ALIAS 'nvedwn';
*DECK DECK=DSP$OPEN_IMAGE_FILE EXPAND=FALSE

  PROCEDURE [XREF] dsp$open_image_file
    (VAR image_file_sfid: dmt$system_file_id;
     VAR image_file_segment: mmt$segment_pointer;
     VAR image_file_p: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc mmt$attribute_keyword
?? POP ??
*DECK DECK=DSP$OPEN_RDF EXPAND=FALSE

  PROCEDURE [XREF] dsp$open_rdf
    (VAR rdf_file_sfid: dmt$system_file_id;
     VAR rdf_file_segment: mmt$segment_pointer;
     VAR rdf_pointers: dst$rdf_pointers);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc dst$rdf_pointers
*copyc mmt$attribute_keyword
?? POP ??
*DECK DECK=DSP$OPEN_SSR EXPAND=FALSE

  PROCEDURE [XREF] dsp$open_ssr
    (VAR ssr_segment_number: ost$segment;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=DSP$PERFORM_CPU_PP_HANDSHAKING EXPAND=FALSE

  PROCEDURE [XREF] dsp$perform_cpu_pp_handshaking;
*DECK DECK=DSP$POST_OPERATOR_ACTION EXPAND=FALSE
*DECK DECK=DSP$PREPARE_DEADSTART_IO EXPAND=FALSE

  PROCEDURE [XREF] dsp$prepare_deadstart_io
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DSP$PREP_DS_FILE_INSTALLATION EXPAND=FALSE

  PROCEDURE [XREF] dsp$prep_ds_file_installation
    (VAR deadstart_file_name: ost$name;
     VAR mau_file_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=DSP$PROCESS_DEADSTART_FILES EXPAND=FALSE

  PROCEDURE [XREF] dsp$process_deadstart_files
    (    ending_file_identifier: dst$deadstart_file_identifier;
         last_files_processed: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dst$deadstart_file_identifier
?? POP ??
*DECK DECK=DSP$PROCESS_PP_FUNCTION EXPAND=FALSE

  PROCEDURE [XREF] dsp$process_pp_function
    (    subfunction: dst$dft_puf_subfunctions;
         pp: dst$iou_resource;
         resume_address: dst$dft_resume_address;
         pp_length: ost$pp_byte_size;
     VAR pp_data_seq_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$dft_puf_subfunctions
*copyc dst$dft_resume_address
*copyc dst$iou_resource
*copyc ost$pp_size
*copyc ost$status
?? POP ??
*DECK DECK=DSP$PROCESS_SETOI_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] dsp$process_setoi_command
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
*copyc ost$status
?? POP ??
*DECK DECK=DSP$PROCESS_SETOP_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] dsp$process_setop_command
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
*copyc ost$status
?? POP ??
*DECK DECK=DSP$READ_CDA_PROGRAM EXPAND=FALSE

  PROCEDURE [XREF] dsp$read_cda_program
    (    name: dst$resource_name;
     VAR program_data_p: ^SEQ ( * );
     VAR length: integer;
     VAR status: ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc dst$resource_name
*copyc ost$status
?? POP ??
*DECK DECK=DSP$READ_CDA_SECTOR EXPAND=FALSE

  PROCEDURE [XREF] dsp$read_cda_sector
    (    name: dst$resource_name;
     VAR sector_data_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$resource_name
*copyc ost$status
?? POP ??
*DECK DECK=DSP$READ_CHANNEL_STATES EXPAND=FALSE

  PROCEDURE [XREF] dsp$read_channel_states
    (VAR channel_state_list: dst$entire_channel_state_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$channel_state
*copyc ost$status
?? POP ??
*DECK DECK=DSP$READ_DATE_TIME_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] dsp$read_date_time_information
    (VAR date_time_information: dst$date_time_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$date_time_information
*copyc ost$status
?? POP ??
*DECK DECK=DSP$READ_DEADSTART_DEVICE EXPAND=FALSE

  PROCEDURE [XREF] dsp$read_deadstart_device
    (    data_length: integer;
     VAR data_buffer_p: ^SEQ ( * );
     VAR data_size_read: integer);
*DECK DECK=DSP$READ_HEADER_LABELS EXPAND=FALSE

  PROCEDURE [XREF] dsp$read_header_labels
    (VAR file_identifier: dst$deadstart_file_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc dst$deadstart_file_identifier
?? POP ??
*DECK DECK=DSP$READ_MRT_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] dsp$read_mrt_entry
    (    mrt_entry_id: dst$mrt_entry_id;
         mrt_element_number: dst$mrt_element_number;
     VAR mrt_entry: dst$mrt_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$mrt_entry
*copyc ost$status
?? POP ??
*DECK DECK=DSP$RECOVER_MF_WIRED EXPAND=FALSE

  PROCEDURE [XREF] dsp$recover_mf_wired;
*DECK DECK=DSP$REPORT_SYSTEM_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] dsp$report_system_message
    (    message_seq_p: ^SEQ ( * ),
         message_type: dst$system_logging_types,
         message_level: dst$system_message_levels;
     VAR message_recorded: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dst$system_logging_types
*copyc dst$system_message_levels
?? POP ??
*DECK DECK=DSP$REQUEST_RESOURCES EXPAND=FALSE

  PROCEDURE [XREF] dsp$request_resources
    (VAR request: dst$resource_request;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dse$resource_errors
*copyc dst$resource_request
*copyc ost$status
?? POP ??
*DECK DECK=DSP$RESUME_PP EXPAND=FALSE

  PROCEDURE [XREF] dsp$resume_pp
    (    pp: dst$iou_resource;
         resume_address: dst$dft_resume_address;
     VAR status: ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc dst$dft_resume_address
*copyc dst$iou_resource
*copyc ost$status
?? POP ??
*DECK DECK=DSP$RESUME_SYSTEM EXPAND=FALSE

  PROCEDURE [XREF] dsp$resume_system;
*DECK DECK=DSP$RETRIEVE_CDA_DATA_SIZE EXPAND=FALSE

  PROCEDURE [XREF] dsp$retrieve_cda_data_size
    (    name: dst$resource_name;
     VAR cda_data_size: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$resource_name
*copyc ost$status
?? POP ??
*DECK DECK=DSP$RETRIEVE_CHANNEL_TYPE EXPAND=FALSE

  PROCEDURE [XREF] dsp$retrieve_channel_type
    (    channel: dst$iou_resource;
     VAR channel_type: cmt$channel_type;
     VAR channel_type_found: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$channel_type
*copyc dst$iou_resource
?? POP ??
*DECK DECK=DSP$RETRIEVE_DEVICE_ADDRESS EXPAND=FALSE

  PROCEDURE [XREF] dsp$retrieve_device_address
    (    transfer_size: integer;
     VAR device_address: dmt$ms_logical_device_address);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$ms_logical_device_address
?? POP ??
*DECK DECK=DSP$RETRIEVE_HEADER_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] dsp$retrieve_header_information
    (VAR header_information: dst$header_information);

?? PUSH (LISTEXT := ON) ??
*copyc dst$header_information
?? POP ??
*DECK DECK=DSP$RETRIEVE_IOU_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] dsp$retrieve_iou_information
    (VAR number_of_ious: dst$number_of_ious;
     VAR iou_information_table: dst$iou_information_table);

?? PUSH (LISTEXT := ON) ??
*copyc dst$iou_information_table
?? POP ??
*DECK DECK=DSP$RETRIEVE_MF_ELEMENT_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] dsp$retrieve_mf_element_entry
    (    element_number: dst$mf_element_number;
         dft_entry_id: dst$mf_element_number;
     VAR element_entry: dst$mf_element_table_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$mf_element_table_entry
*copyc ost$status
?? POP ??
*DECK DECK=DSP$RETRIEVE_SYSTEM_DS_STATUS EXPAND=FALSE

  PROCEDURE [XREF] dsp$retrieve_system_ds_status
    (VAR data: dst$ssr_system_deadstart_status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$ssr_data_types
?? POP ??
*DECK DECK=DSP$RETRIEVE_SYSTEM_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] dsp$retrieve_system_message
    (    flag_id: ost$system_flag);

?? PUSH (LISTEXT := ON) ??
*copyc ost$system_flag
?? POP ??
*DECK DECK=DSP$SAVE_BOOT_DATA_POINTER EXPAND=FALSE

  PROCEDURE [XREF] dsp$save_boot_data_pointer
    (    data_kind: dst$boot_data_kinds;
         boot_data_p: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc dst$boot_data_kinds
?? POP ??
*DECK DECK=DSP$SAVE_SYS_STATUS_BUILD_LEVEL EXPAND=FALSE

  PROCEDURE [XREF] dsp$save_sys_status_build_level;
*DECK DECK=DSP$SAVE_SYS_STATUS_CURRENT_DS EXPAND=FALSE

  PROCEDURE [XREF] dsp$save_sys_status_current_ds
    (    current_deadstart: 0 .. 0f(16));

?? PUSH (LISTEXT := ON) ??
*copyc dst$ssr_data_types
?? POP ??
*DECK DECK=DSP$SAVE_SYS_STATUS_DS_FILE EXPAND=FALSE

  PROCEDURE [XREF] dsp$save_sys_status_ds_file
    (    deadstart_file_source: 0 .. 0ff(16));

?? PUSH (LISTEXT := ON) ??
*copyc dst$ssr_data_types
?? POP ??
*DECK DECK=DSP$SEND_170_RESOURCE_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] dsp$send_170_resource_request
    (VAR request: dst$resource_request;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$resource_request
*copyc ost$status
?? POP ??
*DECK DECK=DSP$SEND_DATA_VIA_SSR EXPAND=FALSE

  PROCEDURE [XREF] dsp$send_data_via_ssr ALIAS 'dsp$sen' (data: ^cell,
        data_length: integer);

  PROCEDURE [XREF] dsp$receive_data_via_ssr ALIAS 'dsp$rec' (VAR
    pointer_to_buffer: ^SEQ ( * ));
*DECK DECK=DSP$SETUP_170_REQUEST_INTERLOCK EXPAND=FALSE

  PROCEDURE [XREF] dsp$setup_170_request_interlock;
*DECK DECK=DSP$SETUP_DEADSTART EXPAND=FALSE

  PROCEDURE [XREF] dsp$setup_deadstart;
*DECK DECK=DSP$SETUP_LOAD_PPU_INTERLOCKS EXPAND=FALSE

  PROCEDURE [XREF] dsp$setup_load_ppu_interlocks;
*DECK DECK=DSP$SET_OPERATION_INTERVAL EXPAND=FALSE

  PROCEDURE [XREF] dsp$set_operation_interval
    (    password: ost$name;
         date_time: ost$date_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=DSP$SET_OPERATION_PASSWORD EXPAND=FALSE

  PROCEDURE [XREF] dsp$set_operation_password
    (    password: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=DSP$SET_RECORD_ERRORS_FLAG EXPAND=FALSE

  PROCEDURE [XREF] dsp$set_record_errors_flag;
*DECK DECK=DSP$SIGNAL_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] dsp$signal_handler
    (    originator: ost$global_task_id;
         signal: pmt$signal);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc pmt$signal
?? POP ??
*DECK DECK=DSP$START_ADDITIONAL_CPU EXPAND=FALSE

  PROCEDURE [XREF] dsp$start_additional_cpu
    (    number: 0 .. (osc$max_number_of_processors - 1));

?? PUSH (LISTEXT := ON) ??
*copyc osc$multiprocessor_constants
?? POP ??
*DECK DECK=DSP$START_ALL_CPUS EXPAND=TRUE

  PROCEDURE [XREF] dsp$start_all_cpus;
*DECK DECK=DSP$START_ONE_CPU EXPAND=FALSE
*DECK DECK=DSP$STORE_DATA_IN_RDF EXPAND=FALSE

  PROCEDURE [XREF] dsp$store_data_in_rdf
    (    rdf_name: dst$rdf_entries;
         rdf_type: dst$rdf_type;
         rdf_value_p: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc dst$rdf_entries
*copyc dst$rdf_type
?? POP ??
*DECK DECK=DSP$STORE_DATA_IN_SSR EXPAND=FALSE

  PROCEDURE [XREF] dsp$store_data_in_ssr
    (    ssr_entry_name: dst$ssr_entry_name;
         ssr_value_p: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc dst$ssr_data_types
?? POP ??
*DECK DECK=DSP$STORE_ENTRY_IN_SSR EXPAND=FALSE

  PROCEDURE [XREF] dsp$store_entry_in_ssr
    (    ssr_entry_name: dst$ssr_entry_name;
         ssr_entry_type: dst$ssr_entry_types;
         ssr_entry: dst$ssr_entry);

?? PUSH (LISTEXT := ON) ??
*copyc dst$ssr_data_types
?? POP ??
*DECK DECK=DSP$STORE_INTEGER_IN_RDF EXPAND=FALSE

  PROCEDURE [XREF] dsp$store_integer_in_rdf
    (    rdf_name: dst$rdf_entries;
         rdf_type: dst$rdf_type;
         rdf_value: integer);

?? PUSH (LISTEXT := ON) ??
*copyc dst$rdf_entries
*copyc dst$rdf_type
?? POP ??
*DECK DECK=DSP$STORE_LIST_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] dsp$store_list_block
    (    list_type: dst$list_block_kind;
         list_block_p: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc dst$list_block_kind
?? POP ??
*DECK DECK=DSP$STORE_SYS_MSG_IN_IMAGE EXPAND=FALSE

  PROCEDURE [XREF] dsp$store_sys_msg_in_image;
*DECK DECK=DSP$SYSTEM_COMMITTED EXPAND=FALSE

  FUNCTION [XREF] dsp$system_committed: boolean;
*DECK DECK=DSP$SYSTEM_DEADSTART_ASSIST EXPAND=TRUE
          IDENT  SDA,SDA
          PERIPH
          BASE   MIXED
          SST    OVLA,SSCP,RDS,EXR,LDS
          TITLE  DSP$SYSTEM DEADSTART ASSIST (SDA)
          SPACE  4
***       SDA    - INITIALIZE CYBER 180.
*
*         *SDA* PERFORMS DEADSTART INITIALIZATION OF
*         C180 STATE FROM THE C170 ENVIRONMENT BY
*         LOADING CPU REGISTERS AND PP DRIVERS.
*
*         CALL   - 24/*SDAP*,12/R,24/P
*
*  P      VFD    12/DEBUG,24/CR,24/RB
*
*         CR - ADDRESS OF CONFIGURATION RECORD.
*         RB - ADDRESS OF REQUEST BLOCK.
          SPACE  4
***       DAYFILE MESSAGES.
*
*         * SDA - ATTEMPT IDLE OF NOS PP.*
*         * SDA - BAD REQUEST BLOCK ADDRESS.*
*         * SDA - BUFFER OUTSIDE FL.*
*         * SDA - BUFFER TOO SMALL FOR HDT.*
*         * SDA - CIP CHANNEL IS DOWN.*
*         * SDA - FAILURE IN DFT FUNCTION.*
*         * SDA - ILLEGAL REQUEST.*
*         * SDA - ILLEGAL USER ACCESS.*
*         * SDA - NO BUFFER LENGTH SPECIFIED.*
*         * SDA - UNABLE TO LOAD SCI.*
*         * SDA - (603) CH17 PARITY ERROR.*
*         * SDA - (604) CH17 INTERLOCK ERR.*
*         * SDA - (605) CH17 ACTIVE.*
*         * SDA - (60C) PP LOAD ERROR.*
*         * SDA - (60F) CH17 INACTIVE.*


**        ROUTINES USED.


          PURGMAC SUBR,PAUSE,MONITOR,RJP
*IF ($string($name(wev$target_operating_system))='NOS')
 OPL     XTEXT     COMPMAC
*IFEND
*copy dsi$pp_macros
*copy dsi$maintenance_register_macros
*copy COMPIOU
*copy dsc$pp_mr_and_tpm_constants
*copy dsi$pp_instruction_mnemonics
*copy dsa$hardware_table_definitions
*copy dsa$ve_requests_to_dft
*copy ctc$ei_control_block
*copy cti$dft_analysis_codes
*copy ctc$dft_constants
 OPL     XTEXT     COMSDST
*IF ($string($name(wev$target_operating_system))='NOS')
 OPL     XTEXT     COMSMSC
 OPL     XTEXT     COMSCPS
 OPL     XTEXT     COMSSSD
*ELSE
 OPL     XTEXT     SSYS
*IFEND
 RICHI$   SET    0
*IF ($string($name(wev$target_operating_system))='NOSBE')
          SPACE  4,10
**        MACRO DEFINITIONS FOR NOS/BE

          PURGMAC MONITOR
 MONITOR  MACRO  FUNC
          LDK    FUNC
          RJM    R.MTR
          ENDM

          PURGMAC SUBR
          MACRO SUBR,A
A_X       LJM   *
A         EQU   *-1
          ENDM

          PURGMAC MACREF
 MACREF   MACRO   N
          QUAL    MACRO$
 N        SET     *
          QUAL    *
          ENDM
*IFEND
          SPACE  4
****      DIRECT LOCATION ASSIGNMENT.

*IF ($string($name(wev$target_operating_system))='NOSBE')
 T0       EQU    0           TEMPORARY STORAGE
 T1       EQU    1
 T2       EQU    2
 T3       EQU    3
 T4       EQU    4
 T5       EQU    5
 T6       EQU    6
 T7       EQU    7
 CM       EQU    D.T0        CM WORD BUFFER
 IR       EQU    D.PPIRB
 RA       EQU    D.RA
 FL       EQU    D.FL
 ON       EQU    D.PPONE
 CP       EQU    D.CPAD
*IFEND
 W0       EQU    20          WORKING STORAGE
 W1       EQU    21
 W2       EQU    22
 W3       EQU    23
 W4       EQU    24
 W5       EQU    25
 W6       EQU    26
 RN       EQU    27          MAINTENANCE REGISTER NUMBER
 EC       EQU    30          ELEMENT CONNECT CODE
 TW       EQU    31          CONTAINS CONSTANT 2
 IB       EQU    32 - 34     EI BUFFER POINTER
 HP       EQU    35 - 36     HARDWARE BUFFER POINTER
 SV       EQU    37 - 40     OS R-REGISTER VALUE
 VP       EQU    41 - 45     VE POINTER TO *DFT*
*IF ($string($name(wev$target_operating_system))='NOSBE')
          SPACE  4
**        NOS/BE SYSTEM EQUIVALENTS.

 ABTM     EQU    M.ABORT
 DFM      EQU    R.DFM
 DPPM     EQU    M.DPP
 DSBP     EQU    P.EICB
 HNGM     EQU    M.KILL
 PPFW     EQU    C.PPFWA
 PPR      EQU    R.IDLE
*IFEND
          SPACE  4
**        CHANNEL AND PP TYPE DEFINITIONS.
*


 CH       EQU    13B         COMMUNICATION CHANNEL
 RR       EQU    400000B     R REGISTER ACTIVATOR
 EICBP    EQU    EIBP        EI BUFFER POINTER
          TITLE  *SDA* MAIN PROGRAM
          ORG    PPFW
 SDA      RJM    PRS         CALL INITIALIZER

          LDM    SDAA,IR+2   REQUEST PROCESSOR ADDRESS
          STD    T1
          LJM    0,T1        PROCESS REQUEST


**        REQUEST PROCESSORS JUMP TABLE.


 SDAA     BSS    0
          LOC    0
          CON    ILL         ILLEGAL REQUEST
          CON    LPB         LOAD *SCI* TO DEADSTART NOS/VE
          CON    MRR         MAINTENANCE REGISTER REQUEST
          CON    ILL
          CON    ILL
          CON    IPP         IDLE PP
          CON    DAC         DEACTIVATE CHANNEL
          CON    MDR         MAKE *DFT* REQUEST
          CON    ILL
          CON    FHD         FETCH HARDWARE DESCRIPTOR
          CON    CVP         CLEAR NOS/VE *DFT* BUFFER POINTER
          CON    WDR         WRITE *DFT* REQUEST BLOCK
          CON    FVE         FETCH VE ENABLED STATUS
 MAXRQ    EQU    *
          LOC    *O
 BLOCK    SPACE  4,10
**        BLOCK - *SDA* REQUEST BLOCK CONTENTS.  THIS IS THE GENERAL FORMAT OF
*                *SDA* REQUESTS.  REQUESTS ARE 2 CM WORDS LONG AND HAVE TWO
*                BASIC FORMATS.  FORMAT ONE CONSISTS OF THE FIRST 5 PP WORDS
*                AND FORMAT 2 CONSISTS OF BOTH CM WORDS.  THE ONLY FIELDS
*                USED IN THE FIRST 5 WORDS FOR REQUESTS IN FORMAT 2 ARE THE
*                *SIZE* AND *COMPLT* FIELDS.  FORMAT 2 IS ONLY USED FOR THE
*                *WDR* REQUEST.
*


 BLOCK    BSS    0

 MRPORT   CON    0           MAINTENANCE REGISTER PORT
 PPCHNM   CON    0           4/PP TYPE(0=NIO,1=CIO),8/PP NUMBER
 SIZE     CON    0,0         PROGRAM TO LOAD FROM CIP DEVICE
 COMPLT   CON    0           COMPLETE BIT

 VBUF     CON    0,0,0       VE BUFFER POINTER
 BUFP     CON    0,0         MR BUFFER POINTER
 MRDATA   SPACE  4,10
**        MRDATA - MAINTENANCE REGISTER BUFFER.
*


 MRDATA   BSS    10
 MRREGN   CON    0
 MRSTAT   CON    0

 RDATA    EQU    MRDATA
          SPACE  4
**        GLOBAL SYMBOLS.
*


 I0CC     CON    0           IOU PORT CODE
 IOUM     CON    0           IOU MODEL NUMBER
 ISPB     CON    0           FLAG TO INDICATE WHETHER TO IGNORE OS BOUNDS
 PPNO     CON    0           *SDA* PP NUMBER

*         FOLLOWING IS NEEDED FOR GETTING HARDWARE ELEMENT ROUTINES.

          BSSZ   3
 HBUF     BSSZ   CMXLEN

 CIPCH    CON    0           CIP CHANNEL
          SPACE  4,10
**        MAINTENANCE REGISTER COMMON DECK.
*


*copy dsi$maintenance_register_access
          EJECT
**        DROP PP.
*
*         EXIT   TO *PPR*.
*
*         USES   W0.
*
*         CALLS  LDA, SPB.
*
*         MACROS MONITOR.


 DPP      LRD    SV          RESTORE OS R-REGISTER
          RJM    SPB         SET PP BOUNDARY
          LDN    1
          STM    COMPLT
          LDN    IR+3
          RJM    LDA
          CWM    BLOCK,ON    UPDATE STATUS
          MONITOR DPPM       DROP PP

*         CLEAR PP MEMORY AFTER RESIDENT.

 DPP1     LDC    DPPE
          STD    W0
 DPP3     BSS    0
          LDN    0
          STI    W0
          AOD    W0
          LMC    7775B       CLEAR TO END OF MEMORY
          NJN    DPP3
          LJM    PPR         JUMP TO IDLE LOOP
 DPPE     BSS    0
 IFM      SPACE  4,10
**        IFM - ISSUE FATAL MESSAGE AND HANG.
*
*         ENTRY  (A) = ANALYSIS CODE.
*
*         EXIT   NO EXIT.
*
*         USES   T2.
*
*         CALLS  DFM.


 IFM      BSS    0
          STM    IFMA        SAVE ANALYSIS CODE

*         SEARCH FOR ANALYSIS CODE.

          LDN    0
          STD    T2
          UJN    IFM2        CHECK FIRST ENTRY

 IFM1     LDN    2
          RAD    T2
 IFM2     LDM    IFMB,T2
          ZJN    IFM3        IF ANALYSIS CODE IS NOT IN TABLE
          LMM    IFMA
          NJN    IFM1        IF ANALYSIS CODE IS NOT IN TABLE

          LDM    IFMB+1,T2   ISSUE DAYFILE MESSAGE
          LRD    SV          RESTORE R-REGISTER
          RJM    DFM

 IFM3     LDM    IFMA
          UJN    *           HANG

 IFMA     BSSZ   1           ANALYSIS CODE

*         TABLE OF ANALYSIS CODES FOR WHICH A MESSAGE IS TO BE WRITTEN.

 PGACE    MICRO  1,,* SDA - *  PREFIX FOR GACE MICRO
 SGACE    MICRO  1,,*.*      SUFFIX FOR GACE MICRO

 IFMB     GACE   DAMP,DMMP,D * SDA - (603) CH17 PARITY ERROR.*
          GACE   DAMI,DMMI,D * SDA - (604) CH17 INTERLOCK ERR.*
          GACE   DAMA,DMMA,D * SDA - (605) CH17 ACTIVE.*
          GACE   DACI,DMCI,D * SDA - (60F) CH17 INACTIVE.*
          CON    0           END OF TABLE

 GACEM    HERE


 ILL      LDC    =C* SDA - ILLEGAL REQUEST.*

 FTL      LRD    SV          RESTORE R-REGISTER
          RJM    DFM
          MONITOR ABTM       ABORT CONTROL POINT
          LJM    DPP1
          TITLE  CVP - CLEAR NOS/VE *DFT* BUFFER POINTER
**        CLEAR NOS/VE DFT BUFFER POINTER IN *DFT* BLOCK.
*
*         EXIT   NOS/VE DFT POINTER CLEARED IN *DFT* BLOCK.
*
*         USES   VP - VP+3, W0 - W3.
*
*         CALLS  IIB.


 CVP      BSS    0
          LDN    DSDFT       FETCH *DFT* POINTER
          RJM    IIB
          CRDL   W0
          LDDL   W0+3        LENGTH OF *DFT* BLOCK
          ZJN    CVP5        IF *DFT* BLOCK NOT DEFINED
          LRD    W0+1        FETCH NVE POINTER FROM *DFT* BLOCK
          LDC    RR+NVEP
          ADD    W0
          CRDL   VP
          LDDL   VP+3        LENGTH OF NOS/VE BUFFER
          ZJN    CVP5        IF NOS/VE BUFFER NOT DEFINED
          LDN    0
          STDL   VP+3        ZERO LENGTH OF NOS/VE BUFFER
          LDC    RR+NVEP     UPDATE NOS/VE BUFFER POINTER
          ADD    W0
          CWDL   VP
 CVP5     LJM    DPP         DROP PP AND EXIT
          TITLE  DAC - DEACTIVATE CHANNEL
***       DAC - DEACTIVATE CHANNEL.
*
*         ENTRY  PPCHNM  = CHANNEL NUMBER.
*
*         EXIT   CHANNEL INACTIVE.


 DAC      BSS    0
          LDM    PPCHNM
          RAM    DACA        SET CHANNEL NUMBER
 DACA     DCN    40
          LJM    DPP         EXIT
          TITLE  FHD - FETCH HARDWARE DESCRIPTOR
***       FHD - FETCH HARDWARE DESCRIPTOR.
*
*         ENTRY  (BUFP - BUFP+1) = BUFFER FOR HARDWARE TABLE.
*
*         EXIT   TO *FTL* IF BUFFER TOO SMALL FOR HDT.
*                CIP HARDWARE TABLE COPIED TO (BUFP - BUFP+1).
*
*         USES   T2, T3, T4.
*
*         CALLS  /DSIGHE/RHT, GNE, LDA, VBA.


 FHD      BSS    0
          RJM    VBA         VERIFY BUFFER ADDRESS

          LDN    0
          STD    T4
          RJM    /DSIGHE/RHT RESET HARDWARE TABLE

 FHD1     RJM    GNE         GET NEXT HARDWARE ELEMENT

          LDM    HBUF        SAVE DESCRIPTOR LENGTH (BYTES)
          SHN    -6
          STD    T2
          LDN    0
          STD    T3
 FHD2     AOD    T3          FIND MULTIPLE OF 5 LARGER THAN DESCRIPTOR LENGTH
          SHN    2
          ADD    T3
          SBD    T2
          MJN    FHD2        IF NOT LARGE ENOUGH

          LDD    T2
          ZJN    FHD3        IF LAST ENTRY
          LDM    HBUF        STORE WORD COUNT INTO ENTRY HEADER
          LPN    77
          STM    HBUF
          LDD    T3
          SHN    6
          RAM    HBUF

 FHD3     LDD    T3
          ADD    T4
          SBM    SIZE+1
          PJN    FHD4        IF TOO LARGE FOR THE BUFFER

          LDC    BUFP        WRITE THIS ENTRY TO BUFFER IN CM
          RJM    LDA
          ADD    T4
          CWM    HBUF,T3

          LDD    T3          INCREMENT INDEX
          RAD    T4
          LDD    T2
          NJP    FHD1        IF MORE TO COPY
          LJM    DPP

 FHD4     LDC    =C* SDA - BUFFER TOO SMALL FOR HDT.*
          LJM    FTL         ABORT *SDA*
          TITLE  FVE - FETCH VE ENABLED STATUS.
***       FVE - FETCH VE ENABLED STATUS.
*
*         ENTRY  (BUFP - BUFP+1) = BUFFER REPLY.
*
*         EXIT   TO *FTL* IF BUFFER TOO SMALL FOR RESULT.
*                (BUFFER) = 12/ E, 48/0.
*                WHERE E = 1, IF VE ENABLED PER *NOS* *SSTL*.
*                             (ALWAYS 1 FOR NOS/BE).
*
*         USES   T2, T3, T4.
*
*         CALLS  LDA, VBA.


 FVE      BSS    0
          RJM    VBA         VERIFY BUFFER ADDRESS

*IF ($string($name(wev$target_operating_system)) = 'NOS')
          LDN    SSTL
          CRD    T0
          LDD    T3
          SHN    21-13
          PJN    FVE1        IF VE ENABLED AT DEADSTART
          LDN    0           SET NOT ENABLED STATUS
          STM    FVEA
*IFEND
 FVE1     LDC    BUFP        WRITE RESULT TO BUFFER IN CM
          RJM    LDA
          CWM    FVEA,ON
          LJM    DPP

 FVEA     VFD    12/1,48/0   VE ENABLED RESULT
 IPP      TITLE  IPP - IDLE PP
***       IPP - IDLE PP.
*
*         ENTRY  (PPCHNM) = PP NUMBER.
*
*         EXIT   PP IS IN HARDWARE IDLE STATE.
*
*         CALLS  IVP.


 IPP      BSS    0
          RJM    IVP         IDLE NOS/VE PP
          LJM    DPP         EXIT
          TITLE  LPB - LOAD PP BOOT
***       LPB - LOAD SYSTEM CONSOLE INTERFACE (*SCI*) TO INITIALIZE FOR
*                DEADSTARTING NOS/VE.
*
*         ENTRY  (CIPCH) = CIP CHANNEL NUMBER.
*                (PPCHNM) = PP NUMBER FOR PP BOOT.
*
*         EXIT   NORMAL EXIT IS TO *DPP* IF *SCI* LOADED AND COMPLETED ITS PRESET.
*                ERROR EXIT IS TO *FTL*.
*
*         USES   CM - CM+3.
*
*         CALLS  CSD, DCC, GSI, GVP, IIB, IVP, LPI, RCC, SPB, SNO, WSF.
*
*         MACROS FINDCM.


 LPB      BSS    0
          RJM    RCC         RESERVE CIP CHANNEL

*         THE FOLLOWING CODE CLEARS THE UPPER 4 BITS OF THE *DFT*
*         POINTER IN THE *EICB*.  SOME OF THESE BITS MAY BE SET
*         ON SOME TYPES OF MAINFRAMES.

          LRD    IB+1
          RJM    SPB         SET PP BOUNDARY
          LDN    DSDFT       GET *DFT* POINTER
          RJM    IIB
          CRDL   W0
          LDD    W0          CLEAR UPPER 4 BITS
          STD    W0
          LDN    DSDFT       REWRITE *DFT* POINTER
          RJM    IIB
          CWDL   W0

          RJM    GVP         SET VE REQUEST POINTER TO *DFT*
          RJM    CSD         CLEAR *SCI* DEADSTART STATUS IN *D8ST*

*         CHECK IF *SCI* IS RUNNING BY LOOKING FOR A PP NUMBER IN THE
*         PARAMETER TABLE.  MUST ALSO CHECK FOR *SCD* ACTIVE BIT SET
*         FOR THE CASE OF AN OLDER VERSION OF NOS RUNNING NOS/*SCD*.
*         IN THAT CASE THERE WOULD BE NO PP NUMBER IN THE PARAMETER
*         TABLE.

          RJM    GSI         GET *SCI* PARAMETER TABLE INTERLOCK
          NJN    LPB3        IF TABLE NOT DEFINED
          LDDL   CM+1        CHECK IF *SCI* LOADED
          SHN    -4
          LPN    77
          NJN    LPB4        IF *SCI* RUNNING
          LDDL   CM+2        CHECK *SCD* ACTIVE BIT
          LPC    4000
          NJN    LPB4        IF *SCD* ACTIVE
          LDM    PPCHNM      SET PP NUMBER IN *SCI* PARAMETER BLOCK
          SHN    4
          RADL   CM+1
          RJM    WSF         WRITE *SCI* PARAMETER TABLE FIRST WORD

*         LOAD *SCI*.

 LPB3     LDN    1
          RJM    SNO         SET NOS/VE OWNS THE *SCI* PP
          RJM    IVP         IDLE THE *SCI* PP
          FINDCM SCI         FIND *SCI* IN EI BUFFER SPACE
          ZJP    LPB20       IF *SCI* NOT FOUND
          ADN    1
          RJM    LPI         LOAD PP IMAGE
          NJP    LPB21       IF PP LOAD ERROR
          UJN    LPB5        SET DEADSTART FLAG

*         *SCI* IS ALREADY LOADED.

 LPB4     RJM    WSF         CLEAR *SCI* PARAMETER TABLE INTERLOCK
          LDN    0
          RJM    SNO         SET NOS/VE DOES NOT OWN THE *SCI* PP

*         SET FLAG TO INDICATE THAT *SCI* SHOULD DEADSTART NOS/VE.

 LPB5     LRD    IB+1
          RJM    SPB         SET PP BOUNDARY
          LDN    D8ST
          RJM    IIB
          CRDL   CM - CM+3   *D8ST* WORD FROM EICB.
          LDDL   CM+3
          SCN    1
          LMN    1           SET DEADSTART NOS/VE FLAG
          STDL   CM+3
          LDN    D8ST        UPDATE *D8ST* WORD IN EICB
          RJM    IIB
          CWDL   CM

 LPB10    LDN    D8DS        CHECK IF PP BOOT FINISHED WITH CHANNEL
          RJM    IIB
          CRDL   CM
          LDD    CM+1
          NJN    LPB10       WAIT FOR *SCI* PRESET COMPLETE
          RJM    DCC         DROP CIP CHANNEL

*         WAIT FOR *SCI* TO CLEAR *VE* DEADSTART FLAG.

 LPB15    LDN    D8ST        WAIT FOR *SCI* TO CLEAR *VE* DEADSTART FLAG
          RJM    IIB
          CRDL   CM          *D8ST* WORD FROM EICB
          LDDL   CM+3
          LPN    1           DEADSTART *VE* FLAG
          NJN    LPB15       IF DEADSTART *VE* FLAG NOT CLEARED
          LJM    DPP         EXIT

 LPB20    RJM    DCC         DROP CIP CHANNEL
          LDC    =C* SDA - UNABLE TO LOAD SCI.*
          UJN    LPB22       ABORT THE CONTROL POINT

 LPB21    RJM    IVP         IDLE THE *SCI* PP
          LDM    CIPCH       MAKE CIP CHANNEL INACTIVE
          LMC    DCNI+40
          STM    LPBA
          DCN    40
 LPBA     EQU    *-1
          RJM    DCC         DROP CIP CHANNEL
          LDC    =C* SDA - _"DMLE".*  * SDA - (60C) PP LOAD ERROR.*
 LPB22    LJM    FTL         ABORT THE CONTROL POINT
          TITLE  MDR - MAKE DFT REQUEST
***       MDR - MAKE *DFT* REQUEST.
*
*         ENTRY  (VBUF - VBUF+2) = ADDRESS OF REQUEST.
*
*         EXIT   TO *DPP* WHEN *DFT* HAS HONORED THE REQUEST.
*
*         USES   NONE.
*
*         CALLS  GVP, IDR, RCC.

 MDR      RJM    RCC         REQUEST CIP CHANNEL

          RJM    GVP         GET VE REQUEST POINTER
          LDN    1           SET *DFT* REQUEST BLOCK LENGTH
          RJM    IDR         ISSUE *DFT* REQUEST
          LJM    DPP         RETURN
          TITLE  MRR - READ MAINTENANCE REGISTER
***       MRR - READ MAINTENANCE REGISTER.
*
*         READ MAINTENANCE REGISTERS AS PER REQUEST.
*
*         ENTRY  (MRPORT) = MAINTENANCE REGISTER PORT ACCESS CODE.
*                (MRREGN) = MAINTENANCE REGISTER TO READ.
*
*         EXIT   (MRDATA - MRDATA+10) = DATA READ.
*
*         BLOCK FORMAT
*         12/RB0, 12/RB1, 12/RB2, 12/RB3, 12/RB4,
*         12/RB5, 12/RB6, 12/RB7, 12/RN , 12/ST ,
*
*         CALLS  LDA, VBA.
*
*         MACROS READMR.


 MRR      BSS    0
          RJM    VBA         VERIFY BUFFER ADDRESS
          LDC    BUFP
          RJM    LDA
          CRM    MRDATA,TW   READ REGISTER BLOCK
          LDM    MRREGN
          STD    RN          SET REGISTER NUMBER
          READMR MRDATA,MRPORT
          LDC    BUFP
          RJM    LDA
          CWM    MRDATA,TW   REWRITE REGISTER BLOCK
          LJM    DPP         DROP PP TO COMPLETE REQUEST
          TITLE  WDR - WRITE DFT REQUEST BLOCK
***       WDR - WRITE *DFT* REQUEST BLOCK.
*
*         ENTRY  (BLOCK - BLOCK+9) = *SDA* REQUEST IN FOLLOWING FORMAT:
*                (SIZE + 1) = LENGTH OF *DFT* REQUEST BLOCK.
*                (VBUF - VBUF+2) = ADDRESS (R POINTER) FOR *DFT* REQUEST.
*                (BUFP - BUFP+1) = OFFSET FROM CONTROL POINT RA OF *DFT*
*                                  REQUEST.
*
*         EXIT   FIRST WORD OF *DFT* REQUEST WRITTEN BACK TO CALLER WITH
*                     *DFT* STATUS SET.
*                TO *FTL* IF *DFT* REQUEST BLOCK LENGTH > 2.
*                TO *DPP* WHEN *DFT* HAS RESPONDED TO REQUEST.
*
*         USES   CM, CM+1, W6.
*
*         CALLS  GVP, IDR, LDA, RCC, VBA.


 WDR      BSS    0
          LDM    SIZE+1      CHECK *DFT* BLOCK SIZE
          STD    W6          SAVE *DFT* BLOCK SIZE
          ZJN    WDR5        IF *DFT* REQUEST LENGTH OF ZERO
          SBN    2+1
          MJN    WDR10       IF *DFT* REQUEST BLOCK NOT TOO BIG
 WDR5     BSS    0
          LDC    =C* SDA - BAD REQUEST BLOCK ADDRESS.*
          LJM    FTL         ISSUE MESSAGE AND DROP PP

 WDR10    RJM    VBA         VERIFY BUFFER ADDRESS

*         FETCH *DFT* REQUEST BLOCK.

          LDC    BUFP        FORM ADDRESS
          RJM    LDA
          CRML   WDRA,W6     READ *DFT* REQUEST BLOCK

*         SET UPPER 4 BITS OF EACH WORD READ TO ZERO.

          LDM    WDRA
          STML   WDRA
          LDM    WDRA+4
          STML   WDRA+4

*         WRITE *DFT* REQUEST BLOCK TO AREA SPECIFIED BY CALLER.  IF
*         THIS IS BELOW THE OS BOUNDS REGISTER, IT WILL GET AN IOU BOUNDS
*         FAULT.  IT COUNTS ON THE CALL TO *GVP* TO SET THIS PP ON
*         UPPER SIDE OF BOUNDS REGISTER TO WRITE VE REQUEST INTO THE *SSR*.

          RJM    RCC         REQUEST CIP CHANNEL
          RJM    GVP         GET NOS/VE REQUEST POINTER
          LDM    VBUF+1
          STD    CM
          LDM    VBUF+2
          STD    CM+1
          LDM    VBUF        CREATE ADDRESS
          LMC    RR
          LRD    CM
          CWML   WDRA,W6
          LDD    W6          REQUEST BLOCK LENGTH
          RJM    IDR         ISSUE *DFT* REQUEST.

*         MOVE THE FIRST WORD OF THE *DFT* REQUEST WITH *DFT* RESPONSE
*         BACK TO THE CALLER SO THAT THE RESPONSE CAN BE CHECKED.
*         EXPECT THE CLEARING OF THE *CIP* CHANNEL RESERVE TO SET THIS
*         PP BELOW THE OS BOUNDS REGISTER.

          LDC    BUFP        FORM ADDRESS
          RJM    LDA
          CWDL   W0          WRITE *DFT* REQUEST WORD WITH RESPONSE
          LJM    DPP         RETURN

 WDRA     BSS    10          *DFT* REQUEST BUFFER
          TITLE  COMMON SUBROUTINES
 CSD      SPACE  4,10
**        CSD - CLEAR *SCI* DEADSTART STATUS.
*
*         EXIT   *SCI* DEADSTART STATUS IN *D8ST* IS CLEAR.
*
*         USES   CM - CM+3.
*
*         CALLS  IIB, SPB.


 CSD      SUBR               ENTRY/EXIT
          LDN    D8ST
          RJM    IIB
          CRDL   CM
          LDDL   CM+3        CLEAR STATUS
          LPC    174077
          STDL   CM+3
          RJM    SPB
          LDN    D8ST        REWRITE *D8ST*
          RJM    IIB
          CWDL   CM
          UJN    CSDX        RETURN
 DCC      SPACE  4,15
**        DCC - DROP CIP CHANNEL.
*
*         ENTRY  (CIPCH) = CIP CHANNEL NUMBER
*
*         EXIT   CHANNEL IS RELEASED.
*                D8DS WORD OF EICB IS CLEARED.
*
*         USES   CM - CM+3.
*
*         CALLS  IIB, SPB.
*
*         MACROS DCHAN.


 DCC      SUBR               ENTRY/EXIT

          LRD    SV
          RJM    SPB         SET PP BOUNDARY TO 170 SIDE

          LDM    CIPCH       RELEASE THE CHANNEL
*IF ($string($name(wev$target_operating_system))='NOSBE')
          RJM    R.DCH
*ELSE
          DCHAN
*IFEND
          SRD    SV

          LDN    D8DS        CLEAR FLAG IN WORD *D8DS*
          RJM    IIB
          CRDL   CM
          LDN    0
          STD    CM+1
          LDN    D8DS
          RJM    IIB
          CWDL   CM
          UJN    DCCX        RETURN
 GSI      SPACE  4,10
**        GSI - GET *SCI* PARAMETER TABLE INTERLOCK.
*
*         EXIT   (A) <> 0 IF PARAMETER TABLE NOT DEFINED.
*                (W6) = OFFSET.
*                (W4 - W5) = R-REGISTER.
*                (CM - CM+3) = FIRST WORD OF PARAMETER TABLE WITH
*                              INTERLOCK CLEARED.
*
*         USES   CM - CM+3, W0 - W0+3.
*
*         CALLS  IIB, SPB, STA.


 GSI10    LDN    1           INDICATE TABLE NOT DEFINED

 GSI      SUBR               ENTRY/EXIT
          LDN    D7RS+2      NOS *SCI* PARAMETER TABLE ADDRESS
          RJM    IIB
          CRDL   W0
          LDDL   W0+2
          ADDL   W0+3
          ZJN    GSI10       IF TABLE NOT DEFINED
          RJM    STA         CREATE R-REGISTER ADDRESS
          RJM    SPB         SET PP BOUNDARY
 GSI5     LDN    0
          STD    CM
          STD    CM+2
          STD    CM+3
          LDC    10000       INTERLOCK BIT
          STDL   CM+1
          LDD    W6
          LMC    RR
          RDSL   CM          SET INTERLOCK
          LDDL   CM+1
          LPC    10000
          NJN    GSI5        IF INTERLOCK ALREADY SET
          UJN    GSIX        RETURN

 IDR      SPACE  4,10
**        IDR - ISSUE *DFT* REQUEST.
*
*         ENTRY  (A) = LENGTH OF *DFT* REQUEST.
*                (VBUF - VBUF+2) = R POINTER TO DFT REQUEST, NO LENGTH.
*                CIP CHANNEL RESERVED.
*
*         EXIT   (W0 - W0+3) = FIRST WORD OF *DFT* REQUEST WITH RESPONSE CODE.
*                DFT RESPONDED TO REQUEST.
*                CIP CHANNEL RESERVE CLEARED.
*
*         USES   CM - CM+3, W0 - W0+3.
*
*         CALLS  IVB, DCC.

 IDR      SUBR               ENTRY/EXIT

*         CREATE R POINTER TO *DFT* REQUEST.

          STD    CM+3        SET LENGTH OF *DFT* REQUEST
          LDM    VBUF
          STD    CM
          LDM    VBUF+1
          STD    CM+1
          LDM    VBUF+2
          STD    CM+2

          LDN    1           USE WORD 1 OF THE NOS/VE *DFT* REQUEST BUFFER
          RJM    IVB
          CWDL   CM          ISSUE REQUEST TO *DFT*

 IDR5     LDD    CM          LOOP UNTIL REQUEST COMPLETED
          ADC    RR
          LRD    CM+1
          CRDL   W0
          LDDL   W0
          SHN    -10
          ZJN    IDR5        IF REQUEST NOT YET COMPLETE

          RJM    DCC         DROP CIP CHANNEL
          UJN    IDRX        RETURN
 IVB      SPACE  4,10
**        IVB - INCREMENT *DFT* NOS/VE BLOCK.
*
*         ENTRY  (A) = OFFSET FROM *DFT* VE BLOCK.
*
*         EXIT   (A - R-REGISTER) = ADDRESS OF DESIRED WORD.


 IVB      SUBR               ENTRY/EXIT
          ADD    VP
          LMC    RR
          LRD    VP+1
          UJN    IVBX        RETURN
 IVP      SPACE  4,15
**        IVP - IDLE VE PP.
*
*         ENTRY  (PPCHNM) = PP NUMBER.
*
*         EXIT   (A) = 0, IF PP SUCCESSFULLY IDLED.
*
*         USES   RN.
*
*         CALLS  CPB, IDP, SCF.
*
*         MACROS READMR.


 IVP      SUBR               ENTRY/EXIT
          LDN    IOSB
          STD    RN
          LDM    PPCHNM
          LPC    0#100       CLEAR ALL BUT CONCURRENT BIT
          ZJN    IVP0        IF NOT CONCURRENT
          LDN    4
          RAD    RN
 IVP0     READMR RDATA,I0CC
          LDM    PPCHNM
          RJM    CPB         CHECK PP BIT IN HARDWARE REGISTER
          ZJN    IVP1        IF ASSIGNED TO NOS/VE
          LDC    =C* SDA - ATTEMPT IDLE OF NOS PP.*
          LJM    FTL

 IVP1     LDN    15
          RJM    SCF         SET CHANNEL FLAG
          LDM    PPCHNM
          RJM    IDP         IDLE PP
          CCF    *,15
          LJM    IVPX        RETURN
 GVP      SPACE  4,10
**        GVP - GET VE REQUEST POINTER.
*
*         ENTRY  PIB HAS BEEN CALLED.
*
*         EXIT   (VP - VP+3) = VE BUFFER POINTER.
*                OS BOUNDS REGISTER SET FOR WRITE TO VE BUFFER.
*
*         USES   W0 - W3.
*
*         CALLS  IIB, SPB.


 GVP1     LRD    VP+1
          RJM    SPB         SET PP BOUNDARY

 GVP      SUBR               ENTRY/EXIT
          LDN    DSDFT       FETCH *DFT* POINTER
          RJM    IIB
          CRDL   W0
          LRD    W0+1        FETCH NVE POINTER FROM *DFT* BLOCK
          LDC    RR+NVEP
          ADD    W0
          CRDL   VP
          LDDL   VP+3        LENGTH OF NOS/VE BUFFER
          NJN    GVP1        IF NOS/VE BUFFER DEFINED
          LRD    IB+1        BUILD TEMPORARY POINTER INTO EICB
          SRD    VP+1
          LDD    IB
          ADN    D8SV+2
          STD    VP
          LDN    1
          STD    VP+3
          LDC    RR+NVEP
          LRD    W0+1
          ADD    W0
          CWDL   VP
          UJP    GVP1        RETURN
 LDA      SPACE  4,10
**        LDA - LOAD ADDRESS.
*
*         ENTRY  (A) = POINTER TO ADDRESS.
*
*         EXIT   (A) = READY FOR CM INSTRUCTION.


 LDA      SUBR               ENTRY/EXIT
          STD    T1
          LRD    SV          LOAD PROPER R-REGISTER
          LDI    T1          CREATE ABSOLUTE ADDRESS
          LPN    37
          SHN    6
          ADD    RA
          SHN    6
          ADM    1,T1
          UJN    LDAX        RETURN
 LPI      SPACE  4,15
**        LPI - LOAD PP IMAGE FROM CM.  THIS SUBROUTINE IS SPECIFICALLY
*                TAILORED TO LOAD *SCI* AS FAR AS DIRECT CELL SETUP IS
*                CONCERNED.
*
*         ENTRY  (A) = OFFSET RELATIVE TO R REGISTER OF PP IMAGE.
*                (R REGISTER) = TOGETHER WITH (A) POINTS TO PP IMAGE IN CM.
*                (PPCHNM) = PP NUMBER OF PP TO LOAD.
*
*         EXIT   (A) = 0, IF NO LOAD ERROR DETECTED.
*                    .NE. 0, IF PP LOAD ERROR.
*
*         USES   CM - CM+2, T1.
*
*         CALLS  DLP, IIB, SCF.


 LPI      SUBR               ENTRY/EXIT

          STDL   CM          SAVE ADDRESS OFFSET
          SRD    CM+1        SAVE CORRESPONDING R-REGISTER

          LDN    15
          STD    T1
          RJM    SCF         ACQUIRE CHANNEL 15

          LDM    PPCHNM
          RJM    DLP         DEADSTART LOAD PP

          LDD    CM+1        SET UP R POINTER TO PP IMAGE IN BOOT
          STML   LPIAC+1
          LDD    CM+2
          STML   LPIAC+2
          LRD    CM+1
          LDDL   CM
          STML   LPIAC       SAVE R REGISTER OFFSET
          ADC    RR
          CRML   LPIAB,ON    DIRECTORY ENTRY OF PP BEING LOADED
          LDN    DSCM+2
          RJM    IIB         INDEX TO CTI DIRECTORY POINTER
          CRML   LPIAD,ON    SET CTI DIRECTORY POINTER
          LDM    PPCHNM      SET PP NUMBER IN PP BEING LOADED
          LPN    77          PP NUMBER
          STM    LPIAE
          LDN    LPIAL       LENGTH OF BOOT ROUTINE
          OAM    LPIA,15     OUTPUT BOOT
          FJM    *,15
          DCN    15+40
          CCF    *,15        RELEASE CHANNEL 15
          LJM    LPIX        RETURN
          SPACE  4
**        BOOT THAT IS LOADED INTO THE PP BEING LOADED.  IT LOADS
*         THE PP IMAGE FROM CM.  IF THE POSITION OF CELLS *LPIAB*
*         THROUGH *LPIAE* CHANGES RELATIVE TO LPIA *SCI* MUST BE
*         CHANGED TO REFLECT THIS.
*

 LPIA     BSS    0
          CON    0
          LDD    LPIAB-LPIA
          STD    LPIAA-LPIA
          LDD    LPIAC-LPIA
          ADC    RR+1
          LRD    LPIAC+1-LPIA
          CRML   **,LPIAB+1-LPIA
 LPIAA    EQU    *-1         LOAD ADDRESS OF PROGRAM
          LDN    0           SET DUAL STATE FLAG
          STD    70
          LJM    100         START RUNNING PROGRAM

*         DEFINE DIRECT CELLS IN *SCI*.  IF THESE CELLS MOVE RELATIVE
*         TO LPIA THEN *SCI* MUST BE CHANGED TO ACCOUNT FOR THIS.  THE
*         LOCATION OF *LPIAB* IS 15B FROM *LPIA*.

          ERRNZ  *-LPIA-15B  PP BOOT CHANGED, *SCI* UPDATE REQUIRED.

*         LOCATION RELATIVE TO *LPIA* IS 15B.

 LPIAB    CON    0,0,0,0     DIRECTORY ENTRY OF PP BEING LOADED.

*         LOCATION RELATIVE TO *LPIA* IS 21B.

 LPIAC    CON    0,0,0       POINTER TO PROGRAM

*         LOCATION RELATIVE TO *LPIA* IS 24B.

 LPIAD    CON    0,0,0       CTI DIRECTORY POINTER.

*         LOCATION RELATIVE TO *LPIA* IS 27B.

 LPIAE    CON    0           PP NUMBER OF PP LOADED.
 LPIAL    EQU    *-LPIA
 RCC      SPACE  4,10
**        RCC - RESERVE CIP CHANNEL.
*
*         ENTRY  NONE.
*
*         EXIT   CHANNEL IS INTERLOCKED.
*
*         USES   CM - CM+3.
*
*         CALLS  FHE, IIB.


 RCC      SUBR               ENTRY/EXIT
          LDN    GPDID       GENERAL PROCESSOR DESCRIPTOR
          RJM    FHE

          LRD    SV
          RJM    SPB         SET PP BOUNDARY TO 170

          LDM    HBUF+GPDDST
          LPN    77
          STM    CIPCH       RESERVE CHANNEL
*IF ($string($name(wev$target_operating_system))='NOSBE')
          RJM    R.RCH
*ELSE
          STD    CM+2
          LMC    4000B       SELECT RETURN ON DOWN CHANNEL
          STD    CM+1
          MONITOR  RCHM
          LDD    CM+1
          SHN    21-13
          PJN    RCC1        IF CHANNEL NOT DOWN
          LDC    =C* SDA - CIP CHANNEL IS DOWN.*
          LJM    FTL

 RCC1     BSS    0
*IFEND
          SRD    SV

          LDN    D8DS        SET CHANNEL LOCKED STATUS IN THE EICB
          RJM    IIB
          CRDL   CM
          LDN    40
          ADM    CIPCH
          STD    CM+1
          LDN    D8DS
          RJM    IIB
          CWDL   CM
          LJM    RCCX        RETURN
 SNO      SPACE  4,10
**        SNO - SET/CLEAR NOS/VE OWNS THE *SCI* PP.
*
*         ENTRY  (A) = 0 IF NOS/VE DOES NOT OWN THE *SCI* PP.
*                    = 1 IF NOS/VE OWNS THE *SCI* PP.
*
*         EXIT   FLAG SET/CLEARED IN *D8ST* ACCORDINGLY.
*
*         USES   CM - CM+3.
*
*         CALLS  IIB, SPB.


 SNO      SUBR               ENTRY/EXIT
          SHN    4
          RAM    SNOA        SAVE SET/CLEAR FLAG
          LRD    IB+1
          RJM    SPB         SET PP BOUNDARY
          LDN    D8ST
          RJM    IIB
          CRDL   CM
          LDDL   CM+1        SET/CLEAR THE FLAG
          LPC    177757
          LMN    0
 SNOA     EQU    *-1
*         LMN    20          (SET NOS/VE OWNS THE *SCI* PP)
          STDL   CM+1
          LDN    D8ST        REWRITE *D8ST*
          RJM    IIB
          CWDL   CM
          UJN    SNOX        RETURN
 VBA      SPACE  4,10
**        VBA - VERIFY BUFFER ADDRESS.
*
*         ENTRY  (BUFP - BUFP+1) = ADDRESS OF BUFFER.
*                (SIZE+1) = SIZE OF BUFFER.
*
*         EXIT   TO *FTL* IF ERROR.


 VBA      SUBR               ENTRY/EXIT
          LDM    BUFP        CHECK MAINTENANCE REGISTER BUFFER
          SHN    12D
          ADM    BUFP+1
          ADM    SIZE+1
          ADN    77
          SHN    -6
          SBD    FL
          MJN    VBAX        IF BUFFER WITHIN FL
          LDC    =C* SDA - BUFFER OUTSIDE FL.*
          LJM    FTL
 WSF      SPACE  4,10
**        WSF - WRITE *SCI* PARAMETER TABLE FIRST WORD.
*
*         ENTRY  (CM - CM+3) = UPDATED FIRST WORD.
*                (W6) = OFFSET.
*                (W4 - W5) = R-REGISTER ADDRESS.
*                TABLE INTERLOCKED.
*                PP BOUNDS SET TO LOWER PP.
*
*         EXIT   UPDATED FIRST WORD WRITTEN TO PARAMETER TABLE.


 WSF      SUBR               ENTRY/EXIT
          LRD    W4
          LDD    W6
          LMC    RR
          CWDL   CM
          UJN    WSFX        RETURN
          TITLE  SYSTEM COMMON DECKS
 COM      SPACE  4,10
**        COMMON DECKS.


          LIST   X
*copy dsi$find_cip_module
*copy dsi$pp_utility_subroutines
*copy dsi$validate_pp_bounds
*copy dsi$get_hardware_element
*copy DSI$DUMP_LOAD_IDLE_PP
          LIST   *
          EJECT
          TITLE  INITIALIZE FOR REQUEST PROCESSING
**        PRS - INITIALIZE FOR REQUEST PROCESSING.


          USE    PRESET

 BUF      BSS    0           PP MEMORY BUFFER

 PRS      SUBR
*IF ($string($name(wev$target_operating_system))='NOSBE')
          LDN    1
          STD    ON          SET CONSTANT 1
          RJM    R.RAFL      REQUEST FIELD LENGTH ACCESS
          SRD    SV          SAVE OS R-REGISTER
          LDN    P.PCOM      CALCULATE PP NUMBER
          CRD    CM
          LDD    D.PPIR
          SBD    CM+C.PCOM
          ADN    10
          SHN    -3
          STM    PPNO
          SBN    12
          MJN    PRS0        IF NOT IN THE UPPER BARREL
          LDN    6
          RAM    PPNO        CONVERT TO PHYSICAL PP NUMBER
 PRS0     LDD    D.PPIR
          CRD    IR          READ INPUT REGISTER
          LDN    P.SSCT      SUBSYSTEM CONTROL TABLE ADDRESS
          CRD    CM
          LDD    CM+C.SSCT
          SHN    3
          ADN    SS.NVE      NVE SUBSYSTEM CONTROL WORD
          CRD    CM
          LDD    CM+4
          SHN    7
          LMD    CP
*ELSE
          SRD    SV          SAVE OS R-REGISTER
          LDN    PPCP        DETERMINE PHYSICAL PP NUMBER
          CRD    CM
          LDD    IA
          SBD    CM+4
          SHN    -3
          STM    PPNO        SAVE LOGICAL PP NUMBER
          SBN    12
          MJN    PRS0        IF NOT IN THE UPPER BARREL
          LDN    6
          RAM    PPNO        CONVERT TO PHYSICAL PP NUMBER
 PRS0     LDD    CP          CHECK SUBSYSTEM ID OF CALLER
          ADN    JCIW
          CRD    CM
          LDD    CM+2
          ADC    -NVSI
*IFEND
          ZJN    PRS1        IF CORRECT SUBSYSTEM
          LDC    =C* SDA - ILLEGAL USER ACCESS.*
          LJM    FTL

 PRS1     LDD    IR+2
          SBN    MAXRQ
          MJN    PRS2        IF VALID REQUEST
          LDC    =C* SDA - ILLEGAL REQUEST.*
          LJM    FTL

 PRS2     LDD    IR+3        MAKE INTERFACE TBL ADDR
          SHN    12D
          ADD    IR+4
          ADN    2
          SHN    -6
          SBD    FL
          MJN    PRS5        IF REQUEST BLOCK IS OK
          LDC    =C* SDA - BAD REQUEST BLOCK ADDRESS.*
          LJM    FTL

*         FETCH *SDA* REQUEST BLOCK.

 PRS5     LDN    2
          STD    TW
          LDN    IR+3
          RJM    LDA         FORM ADDRESS
          CRM    BLOCK,TW    READ REQUEST BLOCK
          EXITMR IFM
          FATALMR  IFM
          LDC    MK16TBL
          RJM    DLI         MAKE 16 BIT INSTR.
          RJM    PIB         PRESET INTERFACE BLOCK
          RJM    PHT         PRESET HARDWARE TABLES
          LDN    0
          RJM    FHE         FIND IOU INFORMATION
          LDM    HBUF+CIOPC
          STM    I0CC        SAVE IOU PORT CODE
          LDM    HBUF+CIOE+EM
          SHN    -4          SHIFT OFF UPPER 4 BITS OF SERIAL NUMBER
          STM    IOUM        SAVE IOU MODEL NUMBER
          RJM    PII         PRESET IOU INFORMATION
          LRD    SV          RESTORE R-REGISTER
          LJM    PRSX        START REQUEST PROCESSING
          SPACE  4,10
*copy DSI$DEFINE_LONG_INSTRUCTION

 STCHTBL  CON    0           CHANNEL TABLE
 MK16TBL  LIST16             16 BIT INSTRUCTION TABLE
 ENDOVL   BSS    0


          END
*DECK DECK=DSP$TEST_RESOURCE_REQUESTS EXPAND=FALSE

  PROCEDURE [XREF] dsp$test_resource_requests
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
*copyc ost$status
?? POP ??
*DECK DECK=DSP$UPDATE_HARDWARE_DATE_TIME EXPAND=FALSE

  PROCEDURE [XREF] dsp$update_hardware_date_time
    (    clock: ost$free_running_clock;
         date_time: ost$date_time;
     VAR status: ost$status );

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$free_running_clock
*copyc ost$status
?? POP ??
*DECK DECK=DSP$UPDATE_IMAGE_VALUES_IN_SSR EXPAND=FALSE

  PROCEDURE [XREF] dsp$update_image_values_in_ssr;
*DECK DECK=DSP$UPDATE_TIME_ZONE EXPAND=FALSE

  PROCEDURE [XREF] dsp$update_time_zone
    (    time_zone: ost$time_zone;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$time_zone
?? POP ??
*DECK DECK=DSP$UPGRADE_PRIMARY_DSFILE_MAU EXPAND=FALSE

  PROCEDURE [XREF] dsp$upgrade_primary_dsfile_mau
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DSP$WRITE_CDA_SECTOR EXPAND=FALSE

  PROCEDURE [XREF] dsp$write_cda_sector
    (    name: dst$resource_name;
     VAR sector_data_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$resource_name
*copyc ost$status
?? POP ??
*DECK DECK=DSP$WRITE_MRT_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] dsp$write_mrt_entry
    (    mrt_entry_id: dst$mrt_entry_id;
         mrt_element_number: dst$mrt_element_number;
         mrt_entry: dst$mrt_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dst$mrt_entry
*copyc ost$status
?? POP ??
*DECK DECK=DST$170_REQUEST_BLOCK EXPAND=FALSE

{ This type declaration defines the block used to request resources from the 170 side.
{ This information is passed in the SSR under the names C80B and C70B.  This type
{ delcaration cannot exceed 8 bytes.

  TYPE
    dst$170_request_block = PACKED RECORD
      CASE request: dst$170_requests OF
      = dsc$170_rb_call_dft_through_sda =
        dft_request_rma: dst$170_request_rma,
      = dsc$170_rb_request_resources, dsc$170_rb_update_free_clock =
        resource_request: dst$170_resource_request,
      = dsc$170_rb_complete_deadstart =
        terminating: boolean,
      CASEND,
    RECEND,

    dst$170_requests = (dsc$170_rb_null_request,
          dsc$170_rb_request_resources, dsc$170_rb_call_dft_through_sda,
          dsc$170_rb_complete_deadstart, dsc$170_rb_update_free_clock),

    dst$170_request_rma = ost$real_memory_address,

    dst$170_resource_request = PACKED RECORD
      status: dst$170_resource_request_errors,
      CASE resource_request_type: dst$170_resource_request_types OF
      = dsc$170_rrt_get_pp, dsc$170_rrt_return_pp =
        driver_pp: boolean,
        partner_pp: boolean,
        channel_used: dst$170_iou_resource,
        primary_pp: dst$170_iou_resource,
        secondary_pp: dst$170_iou_resource,
      = dsc$170_rrt_get_channel, dsc$170_rrt_return_channel =
        channel: dst$170_iou_resource,
      = dsc$170_rrt_get_equipment, dsc$170_rrt_return_equipment =
        equipment_path: dst$170_iou_equipment_path,
      = dsc$170_rrt_update_free_clock =
        new_value: dst$170_free_run_clock_value,
      = dsc$170_rrt_null_request =
      CASEND,
    RECEND,

    dst$170_resource_request_errors = (dsc$170_rre_null_response,
      dsc$170_rre_request_ok, dsc$170_rre_ch_not_available,
      dsc$170_rre_eq_not_available, dsc$170_rre_unit_not_available,
      dsc$170_rre_cm_not_available, dsc$170_rre_pp_not_available,
      dsc$170_rre_no_such_resource, dsc$170_rre_already_assigned,
      dsc$170_rre_no_load_controlware, dsc$170_rre_cio_ch_not_present,
      dsc$170_rre_cio_pp_not_present, dsc$170_rre_bad_request),

    dst$170_resource_request_types = (dsc$170_rrt_null_request,
      dsc$170_rrt_get_pp, dsc$170_rrt_return_pp, dsc$170_rrt_get_channel,
      dsc$170_rrt_return_channel, dsc$170_rrt_get_equipment,
      dsc$170_rrt_return_equipment, dsc$170_rrt_update_free_clock),

    dst$170_iou_resource = PACKED RECORD
      channel_protocol: dst$channel_protocol_type,
      number: dst$physical_resource_number,
    RECEND,

    dst$170_iou_equipment_path = PACKED RECORD
      channel_number: dst$physical_resource_number,
      equipment_number: cmt$physical_equipment_number,
      unit_number: cmt$physical_unit_number,
    RECEND,

    dst$170_free_run_clock_value = 0 .. 07777777777777777(8);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$physical_equipment_number
*copyc cmt$physical_unit_number
*copyc dst$channel_protocol_type
*copyc dst$physical_resource_number
*copyc ost$hardware_subranges
?? POP ??
*DECK DECK=DST$180_DFT_BLOCK EXPAND=FALSE

  { This type declaration describes the DFT control block.  The description for this type declaration is
  { taken from the document 'DFT/OS Interface Specification' ARH6853. All the constants and type declarations
  { that describe the DFT block have the prefix 'DFTB' which is the abbreviation for 'DFT BLOCK'.

  CONST
    dsc$dftb_cw_zero_counters_bit = 58,

    { The following constants describe the element as defined by the EID register.

    dsc$dftb_eid_cpu0_element = 0,
    dsc$dftb_eid_cpu1_element = 10(16),
    dsc$dftb_eid_cpu2_element = 20(16),
    dsc$dftb_eid_cpu3_element = 30(16),
    dsc$dftb_eid_cpu4_element = 40(16),
    dsc$dftb_eid_cpu5_element = 50(16),
    dsc$dftb_eid_cpu6_element = 60(16),
    dsc$dftb_eid_cpu7_element = 70(16),
    dsc$dftb_eid_memory_element = 1,
    dsc$dftb_eid_iou0_element = 2,
    dsc$dftb_eid_iou1_element = 12(16),
    dsc$dftb_eid_iou2_element = 22(16),
    dsc$dftb_eid_iou3_element = 32(16),
    dsc$dftb_eid_page_map_element = 3,
    dsc$dftb_eid_no_known_element = 4,

    dsc$dftb_interlock_bit = 45,
    dsc$dftb_mec_non_s0_counters = 12(8),
    dsc$dftb_mec_s0_counters = 14(8),
    dsc$dftb_mr_group_size = 5,
    dsc$dftb_mr_number_of_registers = 4,

    dsc$dftb_mrb_iou_error = 0,
    dsc$dftb_mrb_memory_error = 1,
    dsc$dftb_mrb_cpu_error = 2,
    dsc$dftb_mrb_page_map_error = 3,
    dsc$dftb_mrb_bad_requests = 4,
    dsc$dftb_mrb_packet_error = 5,
    dsc$dftb_mrb_software_error = 6,
    dsc$dftb_mrb_non = 7,
    dsc$dftb_mrb_multiple_iou_error = 8,
    dsc$dftb_mrb_multiple_mem_error = 9,
    dsc$dftb_mrb_multiple_cpu_error = 0A(16),
    dsc$dftb_mrb_multiple_map_error = 0B(16),
    dsc$dftb_mrb_multiple_requests = 0C(16),
    dsc$dftb_mrb_multiple_packet = 0D(16),
    dsc$dftb_mrb_multiple_software = 0E(16),
    dsc$dftb_mrb_multiple_non = 0F(16),

    { This next constant is added to the dft_analysis_code by DFT when DFT notices multiple occurrences of an
    { error but only records one of the error occurrences.

    dsc$dftb_multiple_errors = 800(16),

    dsc$dftb_nrb_ih_fsc = 1,
    dsc$dftb_nrb_ih_register_data = 2,
    dsc$dftb_nrb_ih_page_flaw_dist = 3,
    dsc$dftb_nrb_ih_flaw_page_num = 4,
    dsc$dftb_nrb_ih_post_oper_msg = 5,

    dsc$dftb_pri_retry_in_progress = 0,
    dsc$dftb_pri_top_of_hour = 1,
    dsc$dftb_pri_corrected_error = 2,
    dsc$dftb_pri_uncorrected_error = 3,
    dsc$dftb_pri_cpu_halt = 4,
    dsc$dftb_pri_env_long_warning = 5,
    dsc$dftb_pri_short_warning = 6,

    dsc$dftb_revision_level_3 = 3,
    dsc$dftb_revision_level_4 = 4,
    dsc$dftb_revision_level_5 = 5,
    dsc$dftb_revision_level_6 = 6,

    dsc$dftb_rpw_secded_id = 1,
    dsc$dftb_rpw_mrb = 2,
    dsc$dftb_rpw_mdb = 3,
    dsc$dftb_rpw_nosve_buffer = 4,
    dsc$dftb_rpw_c170_pp_resident = 5,
    dsc$dftb_rpw_c170_os_buffer = 6,
    dsc$dftb_rpw_mrb_cw = 7,
    dsc$dftb_rpw_mec = 8,
    dsc$dftb_rpw_dft_control_info = 9,
    dsc$dftb_rpw_ssb = 10,
    dsc$dftb_rpw_nrb = 11,
    dsc$dftb_rpw_dft_cm_resident = 12,
    dsc$dftb_rpw_pp_reg_save_area = 13,
    dsc$dftb_rpw_dft_secondary = 14,

    dsc$dftb_sbt_mrb = 1,
    dsc$dftb_sbt_ssb = 2,
    dsc$dftb_sbt_mdb = 3,
    dsc$dftb_sbt_mec = 4,
    dsc$dftb_sbt_sit = 5,
    dsc$dftb_sbt_i4c = 6,
    dsc$dftb_sbt_nrb = 7;

  TYPE
    dst$dftb_cw_dft_pp_number = 0 .. 0ff(16),
    dst$dftb_cw_pointer_words = 0 .. 0f(16),
    dst$dftb_cw_revision_level = 0 .. 0ff(16),
    dst$dftb_dft_analysis_code = 0 .. 0fff(16),
    dst$dftb_element_size = 0 .. 0ffff(16),
    dst$dftb_mdb_data_header_id = 0 .. 0ffff(16),
    dst$dftb_mdb_mrb_word_index = 0 .. 0ff(16),
    dst$dftb_mdb_pfs_error_id = 0 .. 0ffff(16),
    dst$dftb_mec_threshold = 0 .. 0ff(16),
    dst$dftb_mec_error_element = 0 .. 0ffff(16),
    dst$dftb_mrb_offset = 0 .. 0ffff(16),
    dst$dftb_mrt_element_index = 0 .. 0ff(16),
    dst$dftb_os_action_code = 0 .. 0ff(16),
    dst$dftb_priority = 0 .. 0f(16),
    dst$dftb_secded_count = 0 .. 0ffff(16),
    dst$dftb_secded_address = 0 .. 0ffffffff(16),
    dst$dftb_secded_syndrome = 0 .. 0ffff(16),
    dst$dftb_sequence_number = 0 .. 0ff(16),
    dst$dftb_ssb_mdb_ordinal = 0 .. 0ff(16),
    dst$dftb_ssb_unlogged = 0 .. 0ff(16),
    dst$dftb_stat_buffer_type = 0 .. 0ff(16),
    dst$dftb_structure_length = 0 .. 0ff(16);

  TYPE

    { Type declaration for the dftb control word (cw).

    dst$dftb_control_word = PACKED RECORD
      unused: 0 .. 0f(16),
      pointer_words: dst$dftb_cw_pointer_words,
      sequence_number: dst$dftb_sequence_number,
      revision_level: dst$dftb_cw_revision_level,
      dft_pp_number: dst$dftb_cw_dft_pp_number,
      mrb_length: dst$dftb_structure_length,
      number_of_mrbs: dst$dftb_structure_length,
      unused_cw_flag_1: boolean,
      unused_cw_flag_2: boolean,
      unused_cw_flag_3: boolean,
      unused_cw_flag_4: boolean,
      logging_transaction: boolean,
      idle_dft: boolean,
      corrected_error_freeze: boolean,
      uncorrected_error_freeze: boolean,
      dft_verification: boolean,
      dft_reject: boolean,
      zero_counters_and_secded: boolean,
      c170_dedicated: boolean,
      nos_logging_errors: boolean,
      non_dedicated_mode: boolean,
      c180_error: boolean,
      c170_error: boolean,
    RECEND;

  TYPE
    dst$dftb_buffer_control_word = PACKED RECORD
      mrt_element_index: dst$dftb_mrt_element_index,
      os_action_code: dst$dftb_os_action_code,
      priority: dst$dftb_priority,
      dft_analysis_code: dst$dftb_dft_analysis_code,
      sequence_number: dst$dftb_sequence_number,
      flags: dst$dftb_error_buffer_flags,
      offset: dst$dftb_mrb_offset,
    RECEND,

    dst$dftb_buffer_header_word = PACKED RECORD
      rfu: 0 .. 0ffffffff(16),
      number_of_buffers: dst$dftb_element_size,
      buffer_size: dst$dftb_element_size,
    RECEND,

    dst$dftb_date_and_time = PACKED RECORD
      data: dst$dftb_date_and_time_data,
      rfu: 0 .. 0ff(16),
    RECEND,

    dst$dftb_date_and_time_data = 0 .. 0ffffffffffffff(16),

    dst$dftb_date_and_time_field = PACKED RECORD
      rfu_1: 0 .. 7F(16),
      lost_integrity: boolean,
      tens_of_years: 0 .. 0f(16),
      units_of_years: 0 .. 0f(16),
      tens_of_months: 0 .. 0f(16),
      units_of_months: 0 .. 0f(16),
      tens_of_days: 0 .. 0f(16),
      units_of_days: 0 .. 0f(16),
      tens_of_hours: 0 .. 0f(16),
      units_of_hours: 0 .. 0f(16),
      tens_of_minutes: 0 .. 0f(16),
      units_of_minutes: 0 .. 0f(16),
      tens_of_seconds: 0 .. 0f(16),
      units_of_seconds: 0 .. 0f(16),
      rfu_2: 0 .. 0ff(16),
    RECEND,

    dst$dftb_error_buffer_flags = PACKED RECORD
      logging_to_console: boolean,
      valid_mdb_data: boolean,
      unused: boolean,
      threshold_exceeded: boolean,
      logging_action: boolean,
      interlock: boolean,
      c180_valid_data: boolean,
      c170_valid_data: boolean,
    RECEND,

    dst$dftb_fault_symptom_code = PACKED RECORD
      upper: 0 .. 0ffffffff(16),
      lower: integer,
    RECEND,

    dst$dftb_fault_symptom_words = PACKED RECORD
      rfu: 0 .. 0ffffffff(16),
      fault_symptom_code: dst$dftb_fault_symptom_code,
    RECEND,

    dst$dftb_r_pointer_words = ARRAY [1 .. *] OF dst$r_pointer;

  TYPE

    { Type declaration for the mainframe element counters (mec).

    dst$dftb_mec_entry = PACKED RECORD
      corrected_threshold: dst$dftb_mec_threshold,
      uncorrected_threshold: dst$dftb_mec_threshold,
      unlogged_error: dst$dftb_mec_error_element,
      corrected_error: dst$dftb_mec_error_element,
      uncorrected_error: dst$dftb_mec_error_element,
    RECEND,

    { Type declaration for the dftb secded id table (secded).

    dst$dftb_secded_id_table_entry = PACKED RECORD
      count: dst$dftb_secded_count,
      address: dst$dftb_secded_address,
      syndrome: dst$dftb_secded_syndrome,
    RECEND,

    { Type declaration for the dftb mainframe register buffer (mr).

    dst$dftb_mr_header_entry = PACKED RECORD
      mainframe_element_id: 0 .. 0f(16),
      register_type: 0 .. 0f(16),
      register_number: 0 .. 0ff(16),
    RECEND,
    dst$dftb_mr_register_header = PACKED ARRAY [1 .. dsc$dftb_mr_number_of_registers]
          OF dst$dftb_mr_header_entry,
    dst$dftb_mr_register_list = ARRAY [1 .. dsc$dftb_mr_number_of_registers] OF integer,

    dst$dftb_maintenance_registers = PACKED RECORD
      register_header: dst$dftb_mr_register_header,
      register_list: dst$dftb_mr_register_list,
    RECEND,

    { Type declaration for the dftb model dependent buffer (mdb).

    dst$dftb_mdb_information_word = PACKED RECORD
      rfu: 0 .. 0ff(16),
      control_word_offset: dst$dftb_mdb_mrb_word_index,
      priority: dst$dftb_priority,
      sequence_number: dst$dftb_sequence_number,
      unused: 0 .. 0fffff(16),
      data_length_to_log: dst$dftb_element_size,
    RECEND,

    dst$dftb_mdb_block_header = PACKED RECORD
      block_length_to_log: dst$dftb_element_size,
      rfu: 0 .. 0ffff(16),
      pfs_error_id: dst$dftb_mdb_pfs_error_id,
      data_header_id: dst$dftb_mdb_data_header_id,
    RECEND,

    { Type declaration for the dftb supportive status buffer (ssb).

    dst$dftb_ssb_information_word = PACKED RECORD
      element_number: dst$dftb_structure_length,
      mrb_type: dst$dftb_structure_length,
      data_length_to_log: dst$dftb_element_size,
      unlogged: dst$dftb_ssb_unlogged,
      mdb_ordinal: dst$dftb_ssb_mdb_ordinal,
      logged_mrb_size: dst$dftb_element_size,
    RECEND,

    { Type declaration for the dftb non register buffer (nrb).

    dst$dftb_nrb_information_word = PACKED RECORD
      rfu_1: dst$dftb_element_size,
      cy2000_element: dst$dftb_element_size,
      element_number: dst$dftb_structure_length,
      mrb_type: dst$dftb_structure_length,
      data_length_to_log: dst$dftb_element_size,
    RECEND,

    dst$dftb_nrb_internal_header = PACKED RECORD
      type_code: dst$dftb_structure_length,
      count: dst$dftb_structure_length,
      element: dst$dftb_element_size,
      rfu: dst$dftb_element_size,
      length: dst$dftb_element_size,
    RECEND,

    { Type declaration for the dftb NOS/VE request buffer (nvep).

    dst$dftb_nve_req_buffer = RECORD
      sci_vpb_reserved_r_pointer: dst$r_pointer,
      sda_reserved_r_pointer: dst$r_pointer,
      system_request_r_pointer: dst$r_pointer,
      unused_request_r_pointer: dst$r_pointer,
    RECEND;

  TYPE

    { Type declarations used by the OS.

    dst$dftb_data_structure_info = RECORD
      number_of_mrbs: dst$dftb_element_size,
      mrb_length: dst$dftb_element_size,
      ssb_length: dst$dftb_element_size,
      number_of_nrbs: dst$dftb_element_size,
      nrb_length: dst$dftb_element_size,
      number_of_mdbs: dst$dftb_element_size,
      mdb_length: dst$dftb_element_size,
      secded_id_table_length: dst$dftb_element_size,
      revision_level: dst$dftb_cw_revision_level,
    RECEND,

    dst$dftb_stat_block_header = PACKED RECORD
      date_and_time: dst$dftb_date_and_time_data,
      linked_block_follows: boolean,
      block_number: 0 .. 07f(16),
      global_length: dst$dftb_element_size,
      dft_code_version_number: dst$dftb_element_size,
      dft_interface_version_number: dst$dftb_cw_revision_level,
      rfu: 0 .. 0f(16),
      dft_analysis_code: dst$dftb_dft_analysis_code,
      sequence_number: dst$dftb_sequence_number,
    RECEND,

    dst$dftb_stat_buffer_header = PACKED RECORD
      buffer_length: dst$dftb_element_size,
      rfu: 0 .. 0ffffffffff(16),
      buffer_type: dst$dftb_stat_buffer_type,
    RECEND;

*copyc dst$r_pointer
*DECK DECK=DST$AUTOMATIC_PP_RELOAD EXPAND=FALSE

  TYPE
    dst$automatic_pp_reload = RECORD
      enabled: boolean,
      turned_off: boolean,
      pps_reconfigured: boolean,
      iou_model_type: ARRAY [dst$iou_number] OF dst$iou_model_types,
    RECEND;

*copyc dst$iou_model_types
*copyc dst$iou_number
*DECK DECK=DST$BOOT_CONTROL_TABLE EXPAND=FALSE

  TYPE
    dst$bct_flags = PACKED RECORD
      unused: 0 .. 1f(16),
      cpu_error_process_in_progress: boolean,
      cpu_error_fatal_after_process: boolean,
      terminate_system_by_operator: boolean,
      terminate_system_by_error: boolean,
      auto_restart_attempted: boolean,
      system_has_been_idled: boolean,
      auto_restart_control: boolean,
      point_of_commitment: boolean,
      operator_pause: boolean,
      dft_activation: boolean,
      eicb_activation: boolean,
    RECEND,

    dst$boot_control_table = RECORD
      revision: 0 .. 0ff(16),
      reserved_1: 0 .. 0ffffff(16),
      reserved_2: 0 .. 0ffffffff(16),
      flags: dst$bct_flags,
      sci_iou_model_number: 0 .. 0ffff(16),
      dft_buffer_length: 0 .. 0ffff(16),
      sci_iou_number: 0 .. 0ff(16),
      sci_pp_number: 0 .. 0ff(16),
      last_deadstart_time: integer,
      cip_directory_r_pointer: dst$r_pointer,
      eicb_word_address: integer,
      cm_message_buffer: string (80),
    RECEND;

*copyc dst$r_pointer
*DECK DECK=DST$BOOT_DATA_KINDS EXPAND=FALSE

  TYPE
    dst$boot_data_kinds = (dsc$pp_library, dsc$dcfile_data, dsc$mau_list,
       dsc$io_environment, dsc$io_buffer, dsc$system_device_data,
       dsc$transfer_counts, dsc$controlware_loaded_flags, dsc$boot_asids,
       dsc$system_messages, dsc$boot_system_ds_status, dsc$bdk_spare_3,
       dsc$bdk_spare_4, dsc$bdk_spare_5, dsc$bdk_spare_6);

   TYPE
     dst$boot_asids = RECORD
       code_data: integer,
       job_stack: integer,
       mtr_stack: integer,
       spare: integer,
     RECEND;
*DECK DECK=DST$C170_77_TABLE EXPAND=FALSE

  CONST
    dsc$text_table = 0,
    dsc$3400_table = 3400(8),
    dsc$5000_table = 5000(8),
    dsc$5100_table = 5100(8),
    dsc$5200_table = 5200(8),
    dsc$5300_table = 5300(8),
    dsc$5400_table = 5400(8),
    dsc$proc_table = 5720(8),
    dsc$6000_table = 6000(8),
    dsc$6100_table = 6100(8),
    dsc$7000_table = 7000(8),
    dsc$7001_table = 7001(8),
    dsc$7002_table = 7002(8),
    dsc$7600_table = 7600(8),
    dsc$word_table = 7777(8);

  TYPE
    dst$table_id = 0 .. 0fff(16);

  TYPE
    dst$c170_77_table = PACKED RECORD
      name: 0 .. 7700(8),
      length: 0 .. 7700(8),
      unused: 0 .. 777777777777(8),
      module_name: 0 .. 77777777777777(8),
      fill: 0 .. 777777(8),
      date_fill: 0 .. 77(8),
      date: PACKED ARRAY [1 .. 9] OF 0 .. 77(8),
      time_fill: 0 .. 77(8),
      time: PACKED ARRAY [1 .. 9] OF 0 .. 77(8),
      operating_system_id_1: 0 .. 7777777777(8),
      operating_system_id_2: 0 .. 7777777777(8),
      processor_name: 0 .. 77777777777777(8),
      processor_version: 0 .. 777777(8),
      mod_level: 0 .. 7777777777(8),
      target_processor: 0 .. 0fff(16),
      valid_processor: 0 .. 0fff(16),
      compass_flag: 0 .. 77(8),
      program_flag: 0 .. 77(8),
      hardware_requirements_1: 0 .. 7777777777(8),
      hardware_requirements_2: 0 .. 77777777(8),
      comments: PACKED ARRAY [1 .. 69] OF 0 .. 77(8),
      comment_fill: 0 .. 17(8),
      CASE table_type: dst$table_id OF
      = dsc$5000_table =
        l1: 0 .. 77(8),
        l2: 0 .. 77(8),
        fwa: 0 .. 777777(8),
        lwa: 0 .. 777777(8),
      = dsc$6100_table =
        first_word_address: 0 .. 0ffff(16),
        load_address: 0 .. 0ffff(16),
        code_length: 0 .. 0ffff(16),
      = dsc$proc_table =
        proc_header: 0 .. 777777(8),
        unused1: 0 .. 7777777777(8),
      = dsc$text_table =
        nos_byte_1a: 0 .. 77(8),
        nos_byte_1b: 0 .. 77(8),
        nos_byte_2: 0 .. 7777(8),
        nos_byte_3: 0 .. 7777(8),
        nos_byte_4: 0 .. 7777(8),
      = dsc$word_table =
        table_type_word: 0 .. 7777777777777777(8),
      CASEND,
    RECEND,

    dst$c170_unpacked_77_table = PACKED RECORD
      first_word_fill: dst$c170_unpacked_word_fill,
      name: 0 .. 7700(8),
      length: 0 .. 7700(8),
      unused: 0 .. 777777777777(8),
      second_word_fill: dst$c170_unpacked_word_fill,
      module_name: 0 .. 77777777777777(8),
      fill: 0 .. 777777(8),
      third_word_fill: dst$c170_unpacked_word_fill,
      datefill: 0 .. 77(8),
      date: PACKED ARRAY [1 .. 9] OF 0 .. 77(8),
      fourth_word_fill: dst$c170_unpacked_word_fill,
      timefill: 0 .. 77(8),
      time: PACKED ARRAY [1 .. 9] OF 0 .. 77(8),
      fifth_word_fill: dst$c170_unpacked_word_fill,
      operating_system_id_1: 0 .. 7777777777(8),
      operating_system_id_2: 0 .. 7777777777(8),
      sixth_word_fill: dst$c170_unpacked_word_fill,
      processor_name: 0 .. 77777777777777(8),
      processor_version: 0 .. 777777(8),
      seventh_word_fill: dst$c170_unpacked_word_fill,
      mod_level: 0 .. 7777777777(8),
      target_processor: 0 .. 0fff(16),
      valid_processor: 0 .. 0fff(16),
      compass_flag: 0 .. 77(8),
      eigth_word_fill: dst$c170_unpacked_word_fill,
      program_flag: 0 .. 77(8),
      hardware_requirements_1: 0 .. 7777777777(8),
      hardware_requirements_2: 0 .. 77777777(8),
      comments: PACKED ARRAY [1 .. 7] OF dst$c170_unpacked_comment,
      sixteenth_word_fill: dst$c170_unpacked_word_fill,
      table_type: dst$table_id,
      first_word_address: 0 .. 0ffff(16),
      load_address: 0 .. 0ffff(16),
      code_length: 0 .. 0ffff(16),
    RECEND,

    dst$c170_unpacked_word_fill = 0 .. 0f(16),

    dst$c170_unpacked_comment = PACKED RECORD
      comment_word_fill: dst$c170_unpacked_word_fill,
      character_1: 0 .. 77(8),
      character_2: 0 .. 77(8),
      character_3: 0 .. 77(8),
      character_4: 0 .. 77(8),
      character_5: 0 .. 77(8),
      character_6: 0 .. 77(8),
      character_7: 0 .. 77(8),
      character_8: 0 .. 77(8),
      character_9: 0 .. 77(8),
      character_10: 0 .. 77(8),
    RECEND;
*DECK DECK=DST$CC_CTI_HARDWARE_BLOCK EXPAND=FALSE

  TYPE
    dst$cc_cti_hardware_block = RECORD
      CASE integer OF
      = dsc$id_display_console_info =
        console: dst$cc_display_console_info,
      = dsc$id_mainframe_info =
        mainframe: dst$cc_mainframe_info,
      = dsc$id_processor_info =
        processor: dst$cc_processor_info,
      = dsc$id_central_memory_info =
        memory: dst$cc_central_memory_info,
      = dsc$id_iou_info =
        iou: dst$cc_iou_info,
      CASEND,
    RECEND;

  CONST
    dsc$id_global_processor_data = 6,
    dsc$id_wall_clock_chip_values = 10(8),
    dsc$id_display_console_info = 5,
    dsc$id_mainframe_info = 3,
    dsc$id_processor_info = 2,
    dsc$id_central_memory_info = 1,
    dsc$id_iou_info = 0;

  TYPE
    dst$cc_mainframe_options = PACKED RECORD
      no_cm_extension: boolean,
      fill1: 0 .. 3777(8),
      fill2: 0 .. 3777(8),
      no_cem_pem: boolean,
      fill3: 0 .. 1777(8),
      cpu1_off: boolean,
      cpu0_off: boolean,
    RECEND;

  TYPE
    dst$cc_mainframe_info = PACKED RECORD
      size: 0 .. 77(8),
      id: 0 .. 77(8),
      options: dst$cc_mainframe_options,
      rfu0: 0 .. 7777(8),
    RECEND;

  TYPE
    dst$cc_element_id = PACKED RECORD
      pad: 0 .. 17(8),
      element_number: 0 .. 0ff(16),
      model_number: 0 .. 0ff(16),
      serial_number: 0 .. 0ffff(16),
    RECEND;

  TYPE
    dst$cc_generic_element = PACKED RECORD
      size: 0 .. 77(8),
      id: 0 .. 77(8),
      element_id: dst$cc_element_id,
      port_code: 0 .. 0fff(16),
    RECEND;

  TYPE
    dst$degradation_flags = PACKED RECORD
      page_map_0: boolean,
      page_map_1: boolean,
      page_map_2: boolean,
      page_map_3: boolean,
      segment_map_0: boolean,
      segment_map_1: boolean,
      fill0: 0 .. 3,
      cache_set_0: boolean,
      cache_set_1: boolean,
      cache_set_2: boolean,
      cache_set_3: boolean,
    RECEND;

  TYPE
    dst$processor_status = PACKED RECORD
      processor_on: boolean,
      deadstart_processor: boolean,
      fill: 0 .. 77(8),
      pmf_not_present: boolean,
      c180_not_supported: boolean,
      c170_not_supported: boolean,
      processor_down: boolean,
    RECEND;

  TYPE
    dst$cc_processor_info = PACKED RECORD
      size: 0 .. 77(8),
      id: 0 .. 77(8),
      element_id: dst$cc_element_id,
      port_code: 0 .. 0fff(16),
      degr: dst$degradation_flags,
      port: 0 .. 7777(8),
      status: dst$processor_status,
      rfu: 0 .. 77777777(8),
    RECEND;

  TYPE
    dst$cc_cm_address = 0 .. 77777777(8);

  TYPE
    dst$cc_central_memory_info = PACKED RECORD
      size: 0 .. 77(8),
      id: 0 .. 77(8),
      element_id: dst$cc_element_id,
      port_code: 0 .. 0fff(16),
      physical_central_memory_size: dst$cc_cm_address,
      logical_central_memory_size: dst$cc_cm_address,
      rfu1: 0 .. 7777(8),
      scd_reference_address: dst$cc_cm_address,
      scd_offset: 0 .. 7777(8),
    RECEND;

  TYPE
    dst$cc_barrel_vector = PACKED ARRAY [0 .. 11] OF boolean,
    dst$cc_pp_vector = PACKED RECORD
      barrel_0: dst$cc_barrel_vector,
      barrel_1: dst$cc_barrel_vector,
    RECEND;

  TYPE
    dst$cc_iou_info = PACKED RECORD
      size: 0 .. 77(8),
      id: 0 .. 77(8),
      element_id: dst$cc_element_id,
      port_code: 0 .. 0fff(16),
      pps_physically_missing: dst$cc_pp_vector,
      pps_logically_missing: dst$cc_pp_vector,
      pp_speed: 0 .. 7777(8),
      channels_missing: dst$cc_pp_vector,
      cpps_physically_missing: dst$cc_barrel_vector,
    RECEND;

  TYPE
    dst$cc_display_console_info = PACKED RECORD
      size: 0 .. 77(8),
      id: 0 .. 77(8),
      display_type: 0 .. 7777(8),
      port_flags: 0 .. 7777(8),
      mdd_pp: 0 .. 77(8),
      scd_pp: 0 .. 77(8),
      rfu: 0 .. 7777(8),
    RECEND;

  TYPE
    dst$cc_wall_clock_chip_values = PACKED RECORD
      size: 0 .. 1777(8),
      id: 0 .. 77(8),
      units_of_years: 0 .. 0f(16),
      tens_of_years: 0 .. 0f(16),
      units_of_months: 0 .. 0f(16),
      tens_of_months: 0 .. 0f(16),
      units_of_days: 0 .. 0f(16),
      tens_of_days: 0 .. 0f(16),
      units_of_hours: 0 .. 0f(16),
      tens_of_hours: 0 .. 0f(16),
      units_of_minutes: 0 .. 0f(16),
      tens_of_minutes: 0 .. 0f(16),
      units_of_seconds: 0 .. 0f(16),
      tens_of_seconds: 0 .. 0f(16),
      frc_0_15: 0 .. 0ffff(16),
      frc_16_31: 0 .. 0ffff(16),
      frc_32_47: 0 .. 0ffff(16),
      frc_48_63: 0 .. 0ffff(16),
    RECEND;
*DECK DECK=DST$CHANGE_DATE_TIME_SET EXPAND=FALSE

  TYPE
    dst$change_date_time_options = (dsc$cdt_base_system_time, dsc$cdt_time_zone, dsc$cdt_default_date_format,
          dsc$cdt_default_time_format, dsc$cdt_daylight_saving_time),

    dst$change_date_time_set = SET OF dst$change_date_time_options;
*DECK DECK=DST$CHANGE_PROCESSOR_STATE EXPAND=FALSE

  TYPE
    dst$change_processor_state = RECORD
      CASE state: cmt$element_state OF
      = cmc$down =
        down_reason: dst$processor_down_reason,
        halt_cpu_via_dft: boolean,
      CASEND,
    RECEND;

*copyc cmt$element_state
*copyc dst$processor_down_reason
*DECK DECK=DST$CHANNEL_PROTOCOL_TYPE EXPAND=FALSE

  TYPE
    dst$channel_protocol_type = (dsc$cpt_nio, dsc$cpt_cio);
*DECK DECK=DST$CHANNEL_STATE EXPAND=FALSE

  TYPE
    dst$channel_state = RECORD
      channel: dst$iou_resource,
      element_state: cmt$element_state,
    RECEND,

    dst$entire_channel_state_list = ARRAY [dst$iou_number] OF ARRAY [dst$channel_protocol_type] OF
          ARRAY [dst$physical_resource_number] OF cmt$element_state,

    dst$partial_channel_state_list = ARRAY [1 .. *] OF dst$channel_state;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_state
*copyc dst$iou_resource
?? POP ??
*DECK DECK=DST$CONTROLWARE_REQUEST EXPAND=FALSE
TYPE
  dst$controlware_request = RECORD
    CASE path: dst$controlware_path OF
   = dsc$use_channel =
     channel: 0 .. 31,
   = dsc$use_index =
     index: 0 .. 0ffffffff(16),
    CASEND,
  RECEND,

   dst$controlware_path = (dsc$use_channel, dsc$use_index),
   dst$controlware_indicies = (dsc$null, dsc$isd_adapter,
               dsc$isd_control_module, dsc$isd_control_module2,
               dsc$895,
               dsc$ismt, dsc$bcs,
               dsc$bcf, dsc$fmd, dsc$adp, dsc$phd);
*DECK DECK=DST$CPU_ATTRIBUTES EXPAND=FALSE

  TYPE
    dst$cpu_attributes = RECORD
      count: 0 .. osc$max_number_of_processors,
      cpu: ARRAY [0 .. osc$max_number_of_processors - 1] OF dst$cpu_attributes_entry,
    RECEND,

    dst$cpu_attributes_entry = RECORD
      state: cmt$element_state,
      down_reason: dst$processor_down_reason,
      memory_port_number: ost$cpu_memory_port_number,
      element_id: ost$cpu_element_id,
      vectors_not_available: boolean,
    RECEND;

*copyc cmt$element_state
*copyc dst$processor_down_reason
*copyc osc$multiprocessor_constants
*copyc ost$cpu_definitions
*DECK DECK=DST$CPU_PP_COMMUNICATION_BLOCK EXPAND=FALSE

{ WARNING! WARNING! WARNING! WARNING! WARNING! WARNING! WARNING!
{   1.  Any changes to this deck must have corresponding changes in the deck DSA$CPU_PP_COMMUNICATION_BLOCK.
{
{   2.  MTM$MONITOR_INTERRUPT_HANDLER and DSM$BOOT_INTERRUPT_HANDLER access the CPU/PP communication block.

{ PURPOSE:
{   This defines the format of the CPU/PP communication block.  The first word is the DFT/SCI relocation
{   control word defined in dst$dft_sci_relocation_control.  The next words are used by CPU/PP handshaking.

TYPE

  dst$cpu_pp_communication_block = packed record

{  DFT/SCI relocation control:

    relocation: ALIGNED [0 MOD 8] dst$dft_sci_relocation_control,

{  CPU/PP handshaking control:

    monitor_time: ALIGNED [0 MOD 8] integer,
    sci_time: ALIGNED [0 MOD 8] integer,
    dft_time: ALIGNED [0 MOD 8] integer,
    dfts_time: ALIGNED [0 MOD 8] integer,

  recend;

{   This defines the format of the DFT/SCI relocation control word.  Relocation
{   is used on Cyber 930 mainframes in order to allow more drivers to be used
{   in the CIP cluster; SCI never needs to be in the CIP cluster, and DFT needs
{   to be there only during NOS/VE deadstart.
{
{   The format is designed to be easy to use from PPs.  Any changes to this
{   definition should be made with that restriction in mind, and any changes
{   will probably require changes in DFT and SCI code as well as in the CYBIL
{   callers of this deck.

  TYPE
    dst$dft_sci_relocation_control = packed record

{ PP byte 0:

      initialized: boolean, { D8RLP pointer initialized
      rfu_1: 0 .. 3f(16), { 6 bits unused
      dft_died: boolean,
      dft_idled: boolean,
      dft_idle_pending: boolean,
      dft_pp_number: 0 .. 77(8),

{ PP byte 1:

      rfu_2: 0 .. 7f(16), { 7 bits unused
      sci_died: boolean,
      sci_idled: boolean,
      sci_idle_pending: boolean,
      sci_pp_number: 0 .. 77(8),

{ PP byte 2:

      rfu_3: 0 .. 3ff(16), { 10 bits unused
      dft_pp_at_deadstart: 0 .. 77(8),

{ PP byte 3:

      rfu_4: 0 .. 3ff(16), { 10 bits unused
      sci_pp_at_deadstart: 0 .. 77(8),

    recend;
*DECK DECK=DST$DATE_TIME_INFORMATION EXPAND=FALSE

  TYPE
    dst$date_time_information = RECORD
      bst_wcc: ost$date_time,
      bst_frc: integer,
      default_date: ost$default_date_format,
      default_time: ost$default_time_format,
      time_zone: ost$time_zone
    RECEND;

*copyc ost$date_time
*copyc ost$default_date_format
*copyc ost$default_time_format
*copyc ost$time_zone
*DECK DECK=DST$DCFILE_IDENTIFIER EXPAND=FALSE

  TYPE
    dst$dcfile_identifier = string (5);
*DECK DECK=DST$DEADSTART_CONDITION EXPAND=FALSE

  TYPE
{ define deadstart types
    dst$deadstart_condition = (dsc$deadstart_condition_empty,
      dsc$installation_deadstart, dsc$continuation_deadstart,
      dsc$recovery_deadstart);
*DECK DECK=DST$DEADSTART_FILE_IDENTIFIER EXPAND=FALSE

  TYPE
    dst$deadstart_file_identifier = string (17);
*DECK DECK=DST$DEADSTART_ORIGIN EXPAND=FALSE
*DECK DECK=DST$DEADSTART_RECORD_LISTS EXPAND=FALSE

  " This deck contains lists of record names used on deadstart tapes.

  TYPE
    cip_pp_string: string 0 .. 4
    integer_sub_range: integer 0 .. 0ff(16)
    nve_pp_string: string 0 .. 7
    tape_name_string: string 0 .. 17
  TYPEND

  " The following list contains the PPs that are placed on the cip tape.

  TYPE
    cip_pp_record: RECORD
      name: string 0 .. $max_name
      path: string 0 .. $max_name
      format: any of
        key
          (cip_peripheral_processor, cpp)
          (ei)
        keyend
      anyend
      destination: name
    RECEND
  TYPEND

  VAR
    cip_pp_count: (READ) integer_sub_range = 22
    cip_pp_list: (READ) ARRAY 1 .. cip_pp_count OF cip_pp_record =
      (('DFT0'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, DFT0), ..
       ('DFT1'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, DFT1), ..
       ('DFT2'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, DFT2), ..
       ('DFT3'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, DFT3), ..
       ('DFT4'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, DFT4), ..
       ('DFT5'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, DFT5), ..
       ('DBD0'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, DBD0), ..
       ('DBD1'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, DBD1), ..
       ('DBD2'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, DBD2), ..
       ('DBD3'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, DBD3), ..
       ('DBD4'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, DBD4), ..
       ('DBD5'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, DBD5), ..
       ('ECR0'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, ECR0), ..
       ('ECR1'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, ECR1), ..
       ('ECR2'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, ECR2), ..
       ('ECR3'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, ECR3), ..
       ('ECR4'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, ECR4), ..
       ('ECR5'                , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, ECR5), ..
       ('C170_EI_MEMORY_IMAGE', 'BUILD_LEVEL_PATH', EI                      , EI  ), ..
       ('SCI'                 , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, SCI ), ..
       ('MC417'               , 'CDCNET_PATH'     , CIP_PERIPHERAL_PROCESSOR, MC417), ..
       ('MC418'               , 'CDCNET_PATH'     , CIP_PERIPHERAL_PROCESSOR, MC418))
  VAREND

  " The following list contains ONLY the disk and tape drivers.  These are separate from the other PPs
  " because they are built into VDT which is placed in the common disk area on the CIP device.

  VAR
    vdt_pp_count: (READ) integer_sub_range = 18
    vdt_pp_list: (READ) ARRAY 1 .. vdt_pp_count OF nve_pp_string =
     ('VDT'    , ..
      'DSK55A' , ..
      'DSK55C7', ..
      'DSK7154', ..
      'ISD'    , ..
      'HYD'    , ..
      'D895'   , ..
      'DSKI'   , ..
      'D895CIO', ..
      'E9P9853', ..
      'E5P5831', ..
      'E9P5831', ..
      'TAPB'   , ..
      'TAPC'   , ..
      'TAPD'   , ..
      'TAPE'   , ..
      'E2X5680', ..
      'E9Q5698')
  VAREND

  " The following list contains ONLY the NVE PPs that are used after the system is past the boot.
  " These are separate because they are not placed in the common disk area on CTI.

  VAR
    non_boot_driver_count: (READ) integer_sub_range = 11
    non_boot_driver_list: (READ) ARRAY 1 .. non_boot_driver_count OF nve_pp_string =
     ('ICAD', ..
      'NETW', ..
      'IVB0', ..
      'IVB4', ..
      'NPDR', ..
      'NDI0', ..
      'VM5B', ..
      'SPI' , ..
      'ESMD', ..
      'SDPD', ..
      'NERD')
  VAREND

  " The following variable contains the list of the CIP files that are placed on the front of the deadstart tape.

  TYPE
    cip_file_record: RECORD
      name: string 0 .. $max_name
      path: string 0 .. $max_name
      format: any of
        key
          (cip_peripheral_processor, cpp)
          (idc)
          (ve_cpu_boot, vcb)
        keyend
      anyend
      name_12: string 0 .. $max_name
      name_16: string 0 .. $max_name
    RECEND
  TYPEND

  VAR
    cip_file_count: (READ) integer_sub_range = 6
    cip_file_list: (READ) ARRAY 1 .. cip_file_count OF cip_file_record =
      (('IDC'       , 'PP_PATH'         , IDC                     , '$NULL' , 'IDC_16'), ..
       ('SSR'       , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, 'SSR_12', 'SSR_16'), ..
       ('BOOT_IMAGE', 'BUILD_LEVEL_PATH', VE_CPU_BOOT             , 'VCB_12', 'VCB_16'), ..
       ('SCI'       , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, 'SCI_12', 'SCI_16'), ..
       ('BCT'       , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, 'BCT_12', 'BCT_16'), ..
       ('ECB'       , 'PP_PATH'         , CIP_PERIPHERAL_PROCESSOR, 'ECB_12', 'ECB_16'))
  VAREND

  " The following variable contains the list of deadstart files , the disk file name and the path to the disk file.

  TYPE
    deadstart_file_record: RECORD
      tape_name: tape_name_string
      disk_name: string 0 .. $max_name
      integration_path: string 0 .. $max_name
      site_catalog: string 0 .. $max_name
      site_required: boolean
      object_library_file: boolean
    RECEND
  TYPEND

  VAR

" The following variable is the number of CIP files on the deadstart tape.  The CIP files must be
" consecutive and the first n files of the tape.

    deadstart_tape_cip_file_count: (READ) integer_sub_range = 13

    deadstart_file_count: (READ) integer_sub_range = 27
    deadstart_file_list: (READ) ARRAY 1 .. deadstart_file_count OF deadstart_file_record =
      (('IDC_16'           ,'IDC_16'                         ,'CIP_PATH'         ,'CIP'             ,TRUE,  FALSE), ..
       ('SCI_12'           ,'SCI_12'                         ,'CIP_PATH'         ,'CIP'             ,TRUE,  FALSE), ..
       ('VCB_12'           ,'VCB_12'                         ,'CIP_PATH'         ,'CIP'             ,TRUE,  FALSE), ..
       ('SSR_12'           ,'SSR_12'                         ,'CIP_PATH'         ,'CIP'             ,TRUE,  FALSE), ..
       ('VDT_12'           ,'VDT_12'                         ,'CIP_PATH'         ,'CIP'             ,TRUE,  FALSE), ..
       ('BCT_12'           ,'BCT_12'                         ,'CIP_PATH'         ,'CIP'             ,TRUE,  FALSE), ..
       ('ECB_12'           ,'ECB_12'                         ,'CIP_PATH'         ,'CIP'             ,TRUE,  FALSE), ..
       ('SCI_16'           ,'SCI_16'                         ,'CIP_PATH'         ,'CIP'             ,TRUE,  FALSE), ..
       ('VCB_16'           ,'VCB_16'                         ,'CIP_PATH'         ,'CIP'             ,TRUE,  FALSE), ..
       ('SSR_16'           ,'SSR_16'                         ,'CIP_PATH'         ,'CIP'             ,TRUE,  FALSE), ..
       ('VDT_16'           ,'VDT_16'                         ,'CIP_PATH'         ,'CIP'             ,TRUE,  FALSE), ..
       ('BCT_16'           ,'BCT_16'                         ,'CIP_PATH'         ,'CIP'             ,TRUE,  FALSE), ..
       ('ECB_16'           ,'ECB_16'                         ,'CIP_PATH'         ,'CIP'             ,TRUE,  FALSE), ..
       ('MONITOR_IMAGE'    ,'MONITOR_IMAGE'                  ,'BUILD_LEVEL_PATH' ,''                ,TRUE,  FALSE), ..
       ('SYSTEM_CORE_IMAGE','SYSTEM_CORE_IMAGE'              ,'BUILD_LEVEL_PATH' ,''                ,TRUE,  FALSE), ..
       ('DCFILE'           ,'OSF$DEVELOPMENT_DCFILE'         ,'MAINTENANCE_PATH' ,''                ,TRUE,  FALSE), ..
       ('NON_BOOT_DRIVERS' ,'NON_BOOT_DRIVERS'               ,'BUILD_LEVEL_PATH' ,''                ,TRUE,  FALSE), ..
       ('JOB_IMAGE'        ,'JOB_IMAGE'                      ,'BUILD_LEVEL_PATH' ,''                ,TRUE,  FALSE), ..
       ('OSF$DS_LIBRARY'   ,'DEADSTART_LIBRARY'              ,'BUILD_LEVEL_PATH' ,'MF_CONFIG_FILES' ,TRUE,  TRUE ), ..
       ('PHYSICAL_CONFIG'  ,'OSF$PHYSICAL_CONFIG'            ,'MAINTENANCE_PATH' ,'MF_CONFIG_FILES' ,FALSE, FALSE), ..
       ('PROLOG_LIBRARY'   ,'OSF$PROLOG_LIBRARY'             ,'MAINTENANCE_PATH' ,'MF_CONFIG_FILES' ,FALSE, TRUE ), ..
       ('LCU_MF_SUBCMDS'   ,'OSF$LCU_MF_SUBCMDS'             ,'MAINTENANCE_PATH' ,'MF_CONFIG_FILES' ,FALSE, FALSE), ..
       ('MF_CONFIG_EPILOG' ,'OSF$MF_CONFIG_EPILOG'           ,'MAINTENANCE_PATH' ,''                ,TRUE,  FALSE), ..
       ('BUILTIN_LIBRARY'  ,'BUILTIN_LIBRARY'                ,'BUILD_LEVEL_PATH' ,'PRODUCT_FILES'   ,TRUE,  TRUE ), ..
       ('OPERATOR_LIBRARY' ,'OPERATOR_LIBRARY'               ,'BUILD_LEVEL_PATH' ,'PRODUCT_FILES'   ,TRUE,  TRUE ), ..
       ('SOU_LIBRARY'      ,'SOU_LIBRARY'                    ,'BUILD_LEVEL_PATH' ,'PRODUCT_FILES'   ,TRUE,  TRUE ), ..
       ('PRODUCT_EPILOG'   ,'OSF$PRODUCT_EPILOG'             ,'MAINTENANCE_PATH' ,''                ,TRUE,  FALSE))
    last_deadstart_tape_name: (READ) tape_name_string = 'PRODUCT_EPILOG'
  VAREND
*DECK DECK=DST$DEADSTART_SECTOR EXPAND=FALSE

{ These three constants identify a deadstart device.
{ These are identified in the "CTI Interface Specification"
{ ARH2948 in the deadstart sector format.

    CONST
      dsc$special_cti_constant_1 = 500(8),
      dsc$special_cti_constant_2 = 16(8),
      dsc$special_cti_ipl_constant = 112014(8);

    TYPE
      dst$ds_address_a = packed record
        cylinder: 0 .. 0fff(16),
        track: 0 .. 0fff(16),
        sector: 0 .. 0fff(16),
      recend,

      dst$ds_address_b = packed record
        cylinder: 0 .. 0fff(16),
        track: 0 .. 3f(16),
        sector: 0 .. 3f(16),
      recend,

      dst$ds_path = packed record
        pad: 0 .. 3f(16),
        channel: 0 .. 3f(16),
        equipment: 0 .. 3f(16),
        unit: 0 .. 3f(16),
      recend,

{  The added word comments can not be taken literally after word 56.
{  Notice word 56 is only 48 bits long instead of 60 bits long.  This
{  is because the first 12 bits included in word 57 are really the last
{  12 bits of word 56.  This continues for the rest of the record.

      dst$deadstart_sector = packed record
        {Word 0
        v1: 0 .. 0fff(16),
        v2: 0 .. 0fff(16),
        v3: 0 .. 0fffffffff(16),
        {Word 1
        v4: 0 .. 3ffff(16),
        v5: 0 .. 3ffffffffff(16),
        {Words 2 thru 55
        v6: packed array [1 .. 54 * 15] of 0 .. 0f(16),
        {Word 56
        reserved_ctia: packed array [1 .. 7] of 0 .. 0f(16),
        reserved_ctib: packed array [1 .. 3] of boolean,
        valid_ds_error_log: boolean,
        reserved_for_ctic: packed array [1 .. 4] of 0 .. 0f(16),
        {Word 57
        cti_address: dst$ds_address_a,
        cda_address: dst$ds_address_b,
        {Word 58
        msb_address: dst$ds_address_a,
        msb_path: dst$ds_path,
        {Word 59
        msl: 0 .. 0fff(16),
        reserved_cmse: 0 .. 0ffffffffffff(16),
        {Word 60
        hvs_address: dst$ds_address_a,
        hvs_path: dst$ds_path,
        {Word 61
        reserved_hvsa: packed array [1 .. 10] of 0 .. 0f(16),
        reserved_hvsb: packed array [1 .. 5] of 0 .. 0f(16),
        {Word 62
        os_address: dst$ds_address_a,
        os_path: dst$ds_path,
        {Word 63
        reserved_osa: packed array [1 .. 10] of 0 .. 0f(16),
        reserved_osb: packed array [1 .. 5] of 0 .. 0f(16),
        {the leftover 12 bits
        unused: 0 .. 0fff(16),
      recend;
*DECK DECK=DST$DEADSTART_SEQUENCE_STEPS EXPAND=FALSE

  { This type declaration defines the steps that are taken while
  { deadstarting the system.  These steps show what state the
  { deadstart process is in.  The steps are stored throughout
  { deadstart in the RDF slot "SDST" (dsc$rdf_deadstart_state).

  TYPE
    dst$deadstart_sequence_steps =
      (dsc$dss_start_deadstart_process,
       dsc$dss_ssr_built,
       dsc$dss_dcfile_read,
       dsc$dss_image_retrieved,
       dsc$dss_install_templates,
       dsc$dss_templates_installed,
       dsc$dss_outward_call_to_jt,
       dsc$dss_job_template_started,
       dsc$dss_ssr_committed,
       dsc$dss_load_sitecp,
       dsc$dss_sitecp_loaded,
       dsc$dss_idle_system_core,
       dsc$dss_system_core_idled,
       dsc$dss_recover_mainframe,
       dsc$dss_mainframe_recovered,
       dsc$dss_recovery_completed,
       dsc$dss_system_committed,
       dsc$dss_load_dstape_libraries,
       dsc$dss_dstape_libraries_loaded,
       dsc$dss_deadstart_completed,
       dsc$dss_system_idled,
       dsc$dss_system_resumed,
       dsc$dss_system_terminated);
*DECK DECK=DST$DEVICE_PATH EXPAND=FALSE

  TYPE
    dst$device_path = RECORD
      cip_path: boolean,
      iou_number: 0 .. 0ff(16),
      channel_number: 0 .. 0ff(16),
      unit_number: 0 .. 0ff(16),
      device_type: 0 .. 0ff(16),
    RECEND;
*DECK DECK=DST$DFTB_MANAGE_SPACE EXPAND=FALSE

  TYPE
    dst$dftb_manage_space = (dsc$dftb_allocate_space, dsc$dftb_free_space);
*DECK DECK=DST$DFT_ALERT_SOURCE EXPAND=FALSE

  TYPE
    dst$dft_alert_source = (dsc$dft_as_unknown, dsc$dft_as_hpa_ve);
*DECK DECK=DST$DFT_ANALYSIS_CODE_CONSTANTS EXPAND=FALSE

  { These constants describe the type of error that exists in the maintenance register buffer of the DFT
  { block.  These constants are defined in the DFT/OS Interface Specification, ARH6853.  If new error codes
  { are added, the following decks must be changed.  This deck and CTI$DFT_ANALYSIS_CODES and
  { DSM$LOG_SYSTEM_MESSAGES and DUM$PROCESS_DFT_BUFFER_COMMAND.

  CONST

    { Constants for IOU errors.

    dsc$dftb_dac_iou_001 = 001(16),   { processed by the operating system.
    dsc$dftb_dac_iou_002 = 002(16),   { processed by the operating system.
    dsc$dftb_dac_iou_003 = 003(16),   { processed by dft.
    dsc$dftb_dac_iou_004 = 004(16),   { processed by dft.
    dsc$dftb_dac_iou_005 = 005(16),   { processed by dft.
    dsc$dftb_dac_iou_006 = 006(16),   { processed by dft.
    dsc$dftb_dac_iou_007 = 007(16),   { processed by dft.
    dsc$dftb_dac_iou_008 = 008(16),   { processed by dft.
    dsc$dftb_dac_iou_009 = 009(16),   { processed by dft.
    dsc$dftb_dac_iou_00A = 00A(16),   { processed by dft.
    dsc$dftb_dac_iou_00B = 00B(16),   { processed by dft.
    dsc$dftb_dac_iou_00C = 00C(16),   { processed by dft.
    dsc$dftb_dac_iou_0FF = 0FF(16),   { processed by service processor.

    { Constants for MEMORY errors.

    dsc$dftb_dac_mem_101 = 101(16),   { processed by the operating system.
    dsc$dftb_dac_mem_102 = 102(16),   { processed by the operating system.
    dsc$dftb_dac_mem_103 = 103(16),   { processed by dft.
    dsc$dftb_dac_mem_104 = 104(16),   { processed by dft.
    dsc$dftb_dac_mem_105 = 105(16),   { processed by dft.
    dsc$dftb_dac_mem_106 = 106(16),   { processed by dft.
    dsc$dftb_dac_mem_107 = 107(16),   { processed by dft.
    dsc$dftb_dac_mem_108 = 108(16),   { processed by dft.
    dsc$dftb_dac_mem_109 = 109(16),   { processed by dft.

    { Constants for PROCESSOR errors.

    dsc$dftb_dac_cpu_201 = 201(16),   { processed by the operating system.
    dsc$dftb_dac_cpu_202 = 202(16),   { processed by the operating system.
    dsc$dftb_dac_cpu_203 = 203(16),   { processed by dft.
    dsc$dftb_dac_cpu_204 = 204(16),   { processed by dft.
    dsc$dftb_dac_cpu_205 = 205(16),   { processed by dft.
    dsc$dftb_dac_cpu_206 = 206(16),   { processed by dft.
    dsc$dftb_dac_cpu_207 = 207(16),   { processed by dft.
    dsc$dftb_dac_cpu_208 = 208(16),   { processed by dft.
    dsc$dftb_dac_cpu_209 = 209(16),   { processed by the operating system.
    dsc$dftb_dac_cpu_20A = 20A(16),   { processed by the operating system.
    dsc$dftb_dac_cpu_20B = 20B(16),   { processed by dft.
    dsc$dftb_dac_cpu_20C = 20C(16),   { processed by dft.
    dsc$dftb_dac_cpu_20D = 20D(16),   { processed by dft.
    dsc$dftb_dac_cpu_20E = 20E(16),   { processed by the operating system.
    dsc$dftb_dac_cpu_20F = 20F(16),   { processed by the operating system.
    dsc$dftb_dac_cpu_210 = 210(16),   { processed by the operating system.
    dsc$dftb_dac_cpu_211 = 211(16),   { processed by the operating system.
    dsc$dftb_dac_cpu_212 = 212(16),   { processed by the operating system.
    dsc$dftb_dac_cpu_213 = 213(16),   { processed by the operating system.
    dsc$dftb_dac_cpu_214 = 214(16),   { processed by the operating system.
    dsc$dftb_dac_cpu_215 = 215(16),   { processed by the operating system.
    dsc$dftb_dac_cpu_216 = 216(16),   { processed by the operating system.
    dsc$dftb_dac_cpu_217 = 217(16),   { processed by the operating system.
    dsc$dftb_dac_cpu_218 = 218(16),   { processed by the operating system.
    dsc$dftb_dac_cpu_219 = 219(16),   { processed by dft.
    dsc$dftb_dac_cpu_21A = 21A(16),   { processed by dft.
    dsc$dftb_dac_cpu_21B = 21B(16),   { processed by dft.
    dsc$dftb_dac_cpu_21C = 21C(16),   { processed by dft.
    dsc$dftb_dac_cpu_21D = 21D(16),   { processed by dft.
    dsc$dftb_dac_cpu_21E = 21E(16),   { processed by dft.
    dsc$dftb_dac_cpu_21F = 21F(16),   { processed by dft.
    dsc$dftb_dac_cpu_220 = 220(16),   { processed by dft.
    dsc$dftb_dac_cpu_221 = 221(16),   { processed by dft.
    dsc$dftb_dac_cpu_222 = 222(16),   { processed by dft.
    dsc$dftb_dac_cpu_223 = 223(16),   { processed by dft.
    dsc$dftb_dac_cpu_224 = 224(16),   { processed by dft.
    dsc$dftb_dac_cpu_225 = 225(16),   { processed by dft.
    dsc$dftb_dac_cpu_226 = 226(16),   { processed by dft.
    dsc$dftb_dac_cpu_227 = 227(16),   { processed by dft.
    dsc$dftb_dac_cpu_228 = 228(16),   { processed by dft.
    dsc$dftb_dac_cpu_229 = 229(16),   { processed by dft.
    dsc$dftb_dac_cpu_22A = 22A(16),   { processed by dft.
    dsc$dftb_dac_cpu_22B = 22B(16),   { processed by dft.
    dsc$dftb_dac_cpu_22C = 22C(16),   { processed by dft.
    dsc$dftb_dac_cpu_22D = 22D(16),   { processed by dft.
    dsc$dftb_dac_cpu_22E = 22E(16),   { processed by dft.
    dsc$dftb_dac_cpu_22F = 22F(16),   { processed by dft.
    dsc$dftb_dac_cpu_230 = 230(16),   { processed by dft.
    dsc$dftb_dac_cpu_231 = 231(16),   { processed by dft.
    dsc$dftb_dac_cpu_232 = 232(16),   { processed by dft.

    { Constants for PAGE MAP errors.

    dsc$dftb_dac_map_301 = 301(16),   { processed by dft.
    dsc$dftb_dac_map_302 = 302(16),   { processed by dft.

    { Constants for BAD REQUESTS TO DFT errors.

    dsc$dftb_dac_req_401 = 401(16),   { processed by dft.
    dsc$dftb_dac_req_402 = 402(16),   { processed by dft.
    dsc$dftb_dac_req_403 = 403(16),   { processed by dft.
    dsc$dftb_dac_req_404 = 404(16),   { processed by dft.
    dsc$dftb_dac_req_405 = 405(16),   { processed by dft.
    dsc$dftb_dac_req_406 = 406(16),   { processed by dft.
    dsc$dftb_dac_req_407 = 407(16),   { processed by dft.
    dsc$dftb_dac_req_408 = 408(16),   { processed by dft.
    dsc$dftb_dac_req_40A = 40A(16),   { processed by dft.

    { Constants for PACKET COMMUNICATION errors.

    dsc$dftb_dac_pac_501 = 501(16),   { processed by dft.
    dsc$dftb_dac_pac_502 = 502(16),   { processed by dft.
    dsc$dftb_dac_pac_503 = 503(16),   { processed by dft.
    dsc$dftb_dac_pac_504 = 504(16),   { processed by dft.
    dsc$dftb_dac_pac_505 = 505(16),   { processed by dft.
    dsc$dftb_dac_pac_507 = 507(16),   { processed by dft.
    dsc$dftb_dac_pac_5FF = 5FF(16),   { processed by dft.

    { Constants for SOFTWARE errors.

    dsc$dftb_dac_sof_601 = 601(16),   { processed by dft.
    dsc$dftb_dac_sof_602 = 602(16),   { processed by dft.
    dsc$dftb_dac_sof_603 = 603(16),   { processed by dft.
    dsc$dftb_dac_sof_604 = 604(16),   { processed by dft.
    dsc$dftb_dac_sof_605 = 605(16),   { processed by dft.
    dsc$dftb_dac_sof_606 = 606(16),   { processed by dft.
    dsc$dftb_dac_sof_607 = 607(16),   { processed by dft.
    dsc$dftb_dac_sof_608 = 608(16),   { processed by dft.
    dsc$dftb_dac_sof_609 = 609(16),   { processed by dft.
    dsc$dftb_dac_sof_60A = 60A(16),   { processed by dft.
    dsc$dftb_dac_sof_60B = 60B(16),   { processed by dft.
    dsc$dftb_dac_sof_60C = 60C(16),   { processed by dft.
    dsc$dftb_dac_sof_60D = 60D(16),   { processed by dft.
    dsc$dftb_dac_sof_60E = 60E(16),   { processed by dft.
    dsc$dftb_dac_sof_60F = 60F(16),   { processed by dft.
    dsc$dftb_dac_sof_610 = 610(16),   { processed by dft.
    dsc$dftb_dac_sof_611 = 611(16),   { processed by dft.
    dsc$dftb_dac_sof_612 = 612(16),   { processed by dft.
    dsc$dftb_dac_sof_613 = 613(16),   { processed by dft.
    dsc$dftb_dac_sof_614 = 614(16),   { processed by dft.
    dsc$dftb_dac_sof_615 = 615(16),   { processed by dft.
    dsc$dftb_dac_sof_616 = 616(16),   { processed by dft.
    dsc$dftb_dac_sof_617 = 617(16),   { processed by dft.
    dsc$dftb_dac_sof_618 = 618(16),   { processed by dft.
    dsc$dftb_dac_sof_619 = 619(16),   { processed by dft.
    dsc$dftb_dac_sof_61A = 61A(16),   { processed by dft.
    dsc$dftb_dac_sof_61B = 61B(16),   { processed by dft.
    dsc$dftb_dac_sof_61C = 61C(16),   { processed by dft.
    dsc$dftb_dac_sof_61D = 61D(16),   { processed by dft.
    dsc$dftb_dac_sof_61E = 61E(16),   { processed by dft.
    dsc$dftb_dac_sof_61F = 61F(16),   { processed by dft.
    dsc$dftb_dac_sof_620 = 620(16),   { processed by dft.
    dsc$dftb_dac_sof_621 = 621(16),   { processed by dft.
    dsc$dftb_dac_sof_622 = 622(16),   { processed by dft.
    dsc$dftb_dac_sof_623 = 623(16),   { processed by dft.
    dsc$dftb_dac_sof_624 = 624(16),   { processed by dft.
    dsc$dftb_dac_sof_625 = 625(16),   { processed by dft.
    dsc$dftb_dac_sof_626 = 626(16),   { processed by dft.
    dsc$dftb_dac_sof_627 = 627(16),   { processed by dft.
    dsc$dftb_dac_sof_628 = 628(16),   { processed by dft.
    dsc$dftb_dac_sof_629 = 629(16),   { processed by dft.
    dsc$dftb_dac_sof_62A = 62A(16),   { processed by dft.
    dsc$dftb_dac_sof_62B = 62B(16),   { processed by dft.
    dsc$dftb_dac_sof_6FF = 6FF(16),   { processed by dft.

    { Constants for NON specific element errors.

    dsc$dftb_dac_non_701 = 701(16),   { processed by dft.
    dsc$dftb_dac_non_702 = 702(16),   { processed by dft.
    dsc$dftb_dac_non_703 = 703(16),   { processed by dft or the operating system.
    dsc$dftb_dac_non_704 = 704(16),   { processed by dft.
    dsc$dftb_dac_non_705 = 705(16),   { processed by dft.
    dsc$dftb_dac_non_706 = 706(16),   { processed by dft.
    dsc$dftb_dac_non_707 = 707(16),   { processed by dft.
    dsc$dftb_dac_non_708 = 708(16),   { processed by dft.
    dsc$dftb_dac_non_709 = 709(16),   { processed by dft.
    dsc$dftb_dac_non_70A = 70A(16);   { processed by dft.
*DECK DECK=DST$DFT_CPU_SELECTIONS EXPAND=FALSE

  CONST
    dsc$dft_select_cpu0 = 0,
    dsc$dft_select_cpu1 = 1,
    dsc$dft_select_first_active_cpu = 10(8);

  TYPE
    dst$dft_cpu_selections = dsc$dft_select_cpu0 .. dsc$dft_select_first_active_cpu;
*DECK DECK=DST$DFT_FREE_RUN_CLOCK_VALUE EXPAND=FALSE

  TYPE
    dst$dft_free_run_clock_value = 0 .. 0ffffffffffff(16);
*DECK DECK=DST$DFT_PP_REGISTERS EXPAND=FALSE
  TYPE
     dst$dft_pp_registers = record
        p_register: 0 .. 0ffffffff(16),
        q_register: 0 .. 0ffffffff(16),
        k_register: 0 .. 0ffffffff(16),
        a_register: 0 .. 0ffffffff(16),
       recend;
*DECK DECK=DST$DFT_PUF_SUBFUNCTIONS EXPAND=FALSE

  CONST
    dsc$dpuf_null_request = 0,
    dsc$dpuf_dump_pp_registers = 1,
    dsc$dpuf_idle_pp = 2,
    dsc$dpuf_idle_dump_pp = 3,
    dsc$dpuf_idle_dump_registers = 4,
    dsc$dpuf_load_pp = 5,
    dsc$dpuf_resume_pp = 6,
    dsc$dpuf_capture_r_register = 7,
    dsc$dpuf_master_clear_channel = 8,
    dsc$dpuf_max_request = 255;

  TYPE
    dst$dft_puf_subfunctions = dsc$dpuf_null_request .. dsc$dpuf_max_request;
*DECK DECK=DST$DFT_REQUESTS EXPAND=FALSE

{ These type declarations describe formats for a block of data that is used by both the OS and DFT.  If these
{ type declarations are changed then the appropriate changes must be made in both the OS and in DFT.  If any
{ of these type declarations are changed then a new code should be created for the new request and the old
{ code should be marked reserved so it is not used again.  Creating a new request will allow DFT to continue
{ supporting the old request while beginning to support the new request.  This is necessary for back level
{ support for DFT.

  CONST

    { DFT request status codes.

    dsc$dft_rs_no_response = 0,
    dsc$dft_rs_request_complete = 1,
    dsc$dft_rs_request_failed = 2,
    dsc$dft_rs_invalid_cda_read = 3,
    dsc$dft_rs_retry_request = 4,
    dsc$dft_rs_reserved = 5,
    dsc$dft_rs_2ap_error = 6,
    dsc$dft_rs_incorrect_version = 7,
    dsc$dft_rs_hw_element_not_found = 8,
    dsc$dft_rs_hw_element_reserved = 9,
    dsc$dft_rs_hw_ele_not_power_up = 0a(16),
    dsc$dft_rs_insuff_req_length = 0b(16),
    dsc$dft_rs_state_already_exists = 0c(16),
    dsc$dft_rs_state_not_changed = 0d(16),
    dsc$dft_rs_state_part_changed = 0e(16),
    dsc$dft_rs_undefined_mrt_state = 0f(16),
    dsc$dft_rs_undefined_req_state = 10(16),
    dsc$dft_rs_sp_error = 11(16),
    dsc$dft_rs_reissue_request = 12(16),
    dsc$dft_rs_no_flaw_free_mem = 13(16),       { used by SCI only.

    { 2AP error status codes.

    dsc$dft_2ap_program_not_found = 1,
    dsc$dft_2ap_disk_status_error = 2,
    dsc$dft_2ap_cda_not_found = 3,

    { Access secure mode codes.

    dsc$dft_deactivate_secure_mode = 0,
    dsc$dft_activate_secure_mode = 1,
    dsc$dft_return_secure_mode = 2,

    dsc$dft_secure_mode_disabled = 0,
    dsc$dft_secure_mode_enabled = 1,

    { Element state codes.

    dsc$dft_state_on = 0,
    dsc$dft_state_off = 1,
    dsc$dft_state_down_by_system = 2,
    dsc$dft_state_down_by_operator = 4,
    dsc$dft_state_powered_off = 8,
    dsc$dft_state_pow_off_and_off = 9,
    dsc$dft_state_pow_off_and_down = 0c(16),
    dsc$dft_state_not_installed = 0ff(16),

    { Sub element codes.

    dsc$dft_sub_none = 0,
    dsc$dft_sub_channel = 100(16),
    dsc$dft_sub_flaw_table = 100(16),
    dsc$dft_sub_pp = 200(16);

  TYPE
    dst$dft_2ap_status = RECORD
      function_number: 0 .. 0ffff(16),
      error_status: 0 .. 0ffff(16),
      rfu: 0 .. 0ffffffff(16),
    RECEND,

    dst$dft_access_cda_sector = RECORD
      header: dst$dft_request_header,
      name: dst$dft_cda_name,
      cda_information: PACKED RECORD
        rfu1: 0 .. 01f(16),
        valid_data: boolean,
        sixteen_bits: boolean,
        partial_read: boolean,
        rfu2: boolean,
        write_data: boolean,
        cel_sector: boolean,
        rfu3: 0 .. 01f(16),
      RECEND,
      cda_sector_data_rp: dst$r_pointer,
      status_from_2ap: dst$dft_2ap_status,
    RECEND,

    dst$dft_access_deadstart_sector = RECORD
      header: dst$dft_request_header,
      iou_number: dst$iou_number,
      channel_number: dst$physical_resource_number,
      unit_number: cmt$physical_unit_number,
      device_type: 0 .. 0ff(16),
      write_sector: boolean,
      rfu: 0 .. 0ff(16),
      deadstart_sector_data_rp: dst$r_pointer,
      status_from_2ap: dst$dft_2ap_status,
    RECEND,

    dst$dft_access_mrt = RECORD
      header: dst$dft_request_header,
      read_mrt: 0 .. 0ffff(16),
      number: 0 .. 0ffff(16),
      entry_id: 0 .. 0ffff(16),
      mrt_entry_rp: dst$r_pointer,
      status_from_2ap: dst$dft_2ap_status,
    RECEND,

    dst$dft_access_secured_mode = RECORD
      header: dst$dft_request_header,
      access_function: 0 .. 0ffff(16),
      rfu1: 0 .. 0ffffffff(16),
      rfu2: 0 .. 0ffffffffffff(16),
      mode: 0 .. 0ffff(16),
    RECEND,

    dst$dft_cda_name = PACKED RECORD
      character_1: 0 .. 1777(8),
      character_2: 0 .. 77(8),
      character_3: 0 .. 1777(8),
      character_4: 0 .. 77(8),
    RECEND,

    dst$dft_change_date_time_flags = PACKED RECORD
      rfu: 0 .. 7ff(16),
      update_bst: boolean,
      update_time_zone: boolean,
      update_default_date_format: boolean,
      update_default_time_format: boolean,
      update_daylight_status: boolean,
    RECEND,

    dst$dft_change_date_time_info = RECORD
      header: dst$dft_request_header,
      rfu1: 0 .. 0ffffffff(16),
      flags: dst$dft_change_date_time_flags,
      bst_wcc: dst$dft_wall_clock_value,
      default_date: dst$dft_date_formats,
      default_time: dst$dft_time_formats,
      bst_frc: integer,
      time_zone_flags: dst$dft_time_zone_flags,
      time_zone_hours: 0 .. 0ff(16),
      time_zone_minutes: 0 .. 0ff(16),
      rfu2: 0 .. 0ffffffffff(16),
      internal_status: dst$dft_2ap_status,
    RECEND,

    dst$dft_change_element_state = RECORD
      header: dst$dft_request_header,
      element: 0 .. 0ffff(16),
      sub_element: 0 .. 0ffff(16),
      state: 0 .. 0ff(16),
      rfu_1: 0 .. 0ff(16),
      before_state: 0 .. 0ff(16),
      after_state: 0 .. 0ff(16),
      rfu_2: 0 .. 0ffff(16),
      sp_status: 0 .. 0ffffffff(16),
    RECEND,

    dst$dft_change_monitor_xp = RECORD
      header: dst$dft_request_header,
      number: 0 .. 0ffff(16),
      mps: ost$real_memory_address,
    RECEND,

    dst$dft_date_formats = (dsc$dft_df_default, dsc$dft_df_month, dsc$dft_df_mdy, dsc$dft_df_isod,
          dsc$dft_df_ordinal, dsc$dft_df_dmy),

    dst$dft_element_id = RECORD
      element_number: 0 .. 0ff(16),
      model_number: 0 .. 0ff(16),
      serial_number: 0 .. 0ffff(16),
    RECEND,

    dst$dft_get_channel_element = RECORD
      lower_channels: ARRAY [0 .. 13(8)] OF dst$dft_get_channel_entry,
      upper_channels: ARRAY [20(8) .. 33(8)] OF dst$dft_get_channel_entry,
    RECEND,

    dst$dft_get_channel_entry = RECORD
      state: 0 .. 0ff(16),
      channel_type: 0 .. 0ff(16),
    RECEND,

    dst$dft_get_cpu_element = RECORD
      element_id: dst$dft_element_id,
      state: 0 .. 0ff(16),
      port: 0 .. 0ff(16),
      vector_degrade: 0 .. 0ff(16),
      rfu: 0 .. 0ff(16),
    RECEND,

    dst$dft_get_element_header = RECORD
      header: dst$dft_request_header,
      element: 0 .. 0ffff(16),
      sub_element: 0 .. 0ffff(16),
      length: 0 .. 0ffff(16),
    RECEND,

    dst$dft_get_iou_element = RECORD
      element_id: dst$dft_element_id,
      state: 0 .. 0ff(16),
      rfu: 0 .. 0ffffff(16),
    RECEND,

    dst$dft_get_iou_status_register = RECORD
      header: dst$dft_request_header,
      iou_number: dst$iou_number,
      rfu: 0 .. 0ffffffffff(16),
      iou_status_register: integer,
    RECEND,

    dst$dft_get_memory_element = RECORD
      element_id: dst$dft_element_id,
      state: 0 .. 0ff(16),
      rfu_1: 0 .. 0ffffff(16),
      rfu_2: 0 .. 0ffff(16),
      physical_memory: 0 .. 0ffffffffffff(16),
      rfu_3: 0 .. 0ffff(16),
      available_memory: 0 .. 0ffffffffffff(16),
      page_size: 0 .. 0ffff(16),
      page_table_length: 0 .. 0ffff(16),
      rfu_4: 0 .. 0ffffffff(16),
      rfu_5: 0 .. 0ffffffff(16),
      rfu_6: 0 .. 0ffffff(16),
      flaw_table_length: 0 .. 0ff(16),
    RECEND,

    dst$dft_get_pp_element = RECORD
      lower_pps: ARRAY [0 .. 13(8)] OF dst$dft_get_pp_entry,
      upper_pps: ARRAY [20(8) .. 33(8)] OF dst$dft_get_pp_entry,
    RECEND,

    dst$dft_get_pp_entry = RECORD
      state: 0 .. 0ff(16),
      rfu: 0 .. 0ff(16),
    RECEND,

    dst$dft_load_additional_dft = RECORD
      header: dst$dft_request_header,
      pp: dst$iou_resource,
      rfu: 0 .. 0ffffff(16),
    RECEND,

    dst$dft_manage_virtual_cpu = RECORD
      header: dst$dft_request_header,
      number: 0 .. 0ff(16),
      action: 0 .. 0ff(16),
      rfu: 0 .. 0ffffffff(16),
    RECEND,

    dst$dft_one_pp_word = 0 .. 0ffff(16),

    dst$dft_partial_r_pointer = RECORD
      offset: 0 .. 0ffff(16),
      rupper: 0 .. 0ffff(16),
      rlower: 0 .. 0ffff(16),
    RECEND,

    dst$dft_process_pp_function = RECORD
      header: dst$dft_request_header,
      pp: dst$iou_resource,
      subfunction: dst$dft_puf_subfunctions,
      resume_address: dst$dft_resume_address,
      pp_image_rp: dst$r_pointer,
    RECEND,

    dst$dft_read_cda_program = RECORD
      header: dst$dft_request_header,
      program_rp: dst$dft_partial_r_pointer,
      name: dst$dft_cda_name,
      rfu: 0 .. 0ffffffff(16),
      last_word_rp: dst$dft_partial_r_pointer,
      length: 0 .. 0ffff(16),
    RECEND,

    dst$dft_read_date_time_info = RECORD
      header: dst$dft_request_header,
      rfu1: 0 .. 0ffffffffffff(16),
      bst_wcc: dst$dft_wall_clock_value,
      default_date: dst$dft_date_formats,
      default_time: dst$dft_time_formats,
      bst_frc: integer,
      time_zone_flags: dst$dft_time_zone_flags,
      time_zone_hours: 0 .. 0ff(16),
      time_zone_minutes: 0 .. 0ff(16),
      rfu2: 0 .. 0ffffffffff(16),
      internal_status: dst$dft_2ap_status,
    RECEND,

    dst$dft_reload_sci = RECORD
      header: dst$dft_request_header,
      pp: dst$iou_resource,
      rfu: 0 .. 0ffffff(16),
    RECEND,

    dst$dft_request_header = RECORD
      request_status: dst$dft_request_status,
      request_code: dst$dft_request_codes,
    RECEND,

    dst$dft_request_status = 0 .. 255,

    dst$dft_retrieve_cda_size = RECORD
      header: dst$dft_request_header,
      name: dst$dft_cda_name,
      cda_data_size: dst$dft_one_pp_word,
      status_from_2ap: dst$dft_2ap_status,
    RECEND,

    dst$dft_start_additional_cpu = RECORD
      header: dst$dft_request_header,
      number: 0 .. 0ffff(16),
      mps: ost$real_memory_address,
      registers_rp: dst$r_pointer,
    RECEND,

    dst$dft_system_alert_flags = PACKED RECORD
      rfu: 0 .. 7fff(16),
      hpa_ve_alert: boolean,
    RECEND,

    dst$dft_system_state_alert = RECORD
      header: dst$dft_request_header,
      rfu1: 0 .. 0ffffffff(16),
      flags: dst$dft_system_alert_flags,
      rfu2: 0 .. 0ffffffffffff(16),
      supportive_information_length: 0 .. 0ffff(16),
    RECEND,

    dst$dft_time_formats = (dsc$dft_tf_default, dsc$dft_tf_ampm, dsc$dft_tf_hms, dsc$dft_tf_millisecond,
          dsc$dft_tf_isot),

    dst$dft_time_zone_flags = PACKED RECORD
      rfu: 0 .. 1f(16),
      negative_time_zone_hours: boolean,
      negative_time_zone_minutes: boolean,
      daylight_saving_time: boolean,
    RECEND,

    dst$dft_update_free_run_clock = RECORD
      header: dst$dft_request_header,
      value: dst$dft_free_run_clock_value,
    RECEND,

    dst$dft_update_hardware_clock = RECORD
      header: dst$dft_request_header,
      year: 0 .. 0ff(16),
      month: 0 .. 0ff(16),
      day: 0 .. 0ff(16),
      hour: 0 .. 0ff(16),
      minute: 0 .. 0ff(16),
      rfu: 0 .. 0ff(16),
      free_running_clock_1: 0 .. 0ffff(16),
      free_running_clock_2: 0 .. 0ffff(16),
      free_running_clock_3: 0 .. 0ffff(16),
      free_running_clock_4: 0 .. 0ffff(16),
    RECEND,

    dst$dft_wall_clock_entry = PACKED RECORD
      tens: 0 .. 0f(16),
      units: 0 .. 0f(16),
    RECEND,

    dst$dft_wall_clock_value = PACKED RECORD
      years: dst$dft_wall_clock_entry,
      months: dst$dft_wall_clock_entry,
      days: dst$dft_wall_clock_entry,
      hours: dst$dft_wall_clock_entry,
      minutes: dst$dft_wall_clock_entry,
      seconds: dst$dft_wall_clock_entry,
    RECEND;

*copyc cmt$physical_unit_number
*copyc dst$dft_free_run_clock_value
*copyc dst$dft_puf_subfunctions
*copyc dst$dft_request_codes
*copyc dst$dft_resume_address
*copyc dst$iou_number
*copyc dst$iou_resource
*copyc dst$physical_resource_number
*copyc dst$r_pointer
*copyc osc$multiprocessor_constants
*copyc ost$hardware_subranges
*DECK DECK=DST$DFT_REQUEST_CODES EXPAND=FALSE

{ This type declaration contains all of the currently defined DFT request codes.  These request codes are
{ used to tell DFT which request the operating system is making.  The codes that are marked as reserved are
{ old codes that the OS no longer uses but DFT must still support because of back level support.  Any new
{ codes should be added at the bottom.  The reserved codes should not be used again.  If a request is changed
{ a new code should be created for the new request and the old code should be marked reserved so it is not
{ used again.  This allows DFT to continue supporting the old request while supporting the new request.

{ NOTE: THE RESERVED CODES SHOULD NOT BE USED AGAIN.

{ NOTE: ALL DFT REQUESTS THAT ACCESS THE CIP DISK MUST:
{          * INTERLOCK THE CHANNEL BEFORE CALLING DFT
{          * SEND THE REQUEST TO THE 170 SIDE WHEN RUNNING DUALSTATE

  CONST
    dsc$dft_null_request = 0,                { Not used by NOS/VE OS.
    dsc$dft_terminate_170_cpu = 1,           { Not used by NOS/VE OS.
    dsc$dft_terminate_all_cpus = 2,          { Not used by NOS/VE OS.
    dsc$dft_deadstart_cpu = 3,               { Not used by NOS/VE OS.
    dsc$dft_terminate_cpu = 4,               { Not used by NOS/VE OS.
    dsc$dft_code_5_reserved = 5,             { Formally load PP, changed at 1.3.1.
    dsc$dft_code_6_reserved = 6,             { Formally fetch hardware information, changed at 1.3.1.
    dsc$dft_code_7_reserved = 7,             { Formally change CPU register, changed at 1.3.1.
    dsc$dft_read_cda_program = 10(8),        { Used with Cyber-2000 and PP-Based DFT.
    dsc$dft_code_11_reserved = 11(8),        { Formally access deadstart sector, changed at 1.3.1.
    dsc$dft_code_12_reserved = 12(8),        { Formally access cda, changed at 1.3.1.
    dsc$dft_update_hardware_clock = 13(8),   { Used with PP-Based DFT only.
    dsc$dft_start_170_processor = 14(8),     { Not used by NOS/VE OS.
    dsc$dft_code_15_reserved = 15(8),        { Formally PP utility functions, changed at 1.3.1.
    dsc$dft_code_16_reserved = 16(8),        { Formally resume PP, changed at 1.3.1.
    dsc$dft_update_free_run_clock = 17(8),   { Used with PP-Based DFT only.
    dsc$dft_change_threshold_values = 20(8), { Not used by NOS/VE OS.
    dsc$dft_get_nio_channel_status = 21(8),  { Not used by NOS/VE OS.
    dsc$dft_start_additional_cpu = 22(8),    { Used with Cyber-2000 and PP-Based DFT.
    dsc$dft_change_monitor_xp = 23(8),       { Used with Cyber-2000 and PP-Based DFT.
    dsc$dft_access_deadstart_sector = 24(8), { Used with PP-Based DFT only.
    dsc$dft_access_cda_sector = 25(8),       { Used with Cyber-2000 and PP-Based DFT.
    dsc$dft_process_pp_function = 26(8),     { Used with Cyber-2000 and PP-Based DFT.
    dsc$dft_read_maint_register = 27(8),     { Not used by NOS/VE OS.
    dsc$dft_load_additional_DFT = 30(8),     { Used with PP-Based DFT only.
    dsc$dft_idle_all_pps_and_chs = 31(8),    { Not used by NOS/VE OS.
    dsc$dft_access_mrt = 32(8),              { Used with PP-Based DFT only.
    dsc$dft_retrieve_program_size = 33(8),   { Used with Cyber-2000 and PP-Based DFT.
    dsc$dft_retrieve_cda_data_size = 34(8),  { Used with Cyber-2000 and PP-Based DFT.
    dsc$dft_manage_virtual_cpu = 35(8),      { Used with Cyber-2000 and PP-Based DFT.
    dsc$dft_change_element_state = 36(8),    { Used with Cyber-2000 DFT only.
    dsc$dft_get_element_description = 37(8), { Used with Cyber-2000 DFT only.
    dsc$dft_access_secured_mode = 40(8),     { Used with Cyber-2000 DFT only.
    dsc$dft_change_date_time_info = 41(8),   { Used with Cyber-2000 DFT only.
    dsc$dft_read_date_time_info = 42(8),     { Used with Cyber-2000 DFT only.
    dsc$dft_code_43_available = 43(8),       { Code available.
    dsc$dft_system_state_alert = 44(8),      { Used with Cyber-2000 DFT only.
    dsc$dft_get_iou_status_register = 45(8), { Used with Cyber-2000 and PP-Based DFT.
    dsc$dft_reload_sci = 46(8),              { Used with Cyber-2000 and PP-Based DFT.
    dsc$dft_max_request_code = 255;

  TYPE
    dst$dft_request_codes = dsc$dft_null_request .. dsc$dft_max_request_code;
*DECK DECK=DST$DFT_RESUME_ADDRESS EXPAND=FALSE

  TYPE
    dst$dft_resume_address = 0 .. 0ffff(16);
*DECK DECK=DST$DRIVER_NAME EXPAND=FALSE

  TYPE
    dst$driver_name = string (7);
*DECK DECK=DST$DS_SECTOR_DEVICE_PATH EXPAND=FALSE

  TYPE
    dst$ds_sector_device_path = record
      disk_type: (dsc$large_sector_disk, dsc$small_sector_disk),
      access_type: (dsc$read_ds_sector, dsc$write_ds_sector),
      iou_number: dst$iou_number,
      device_type: 0 .. 0ff(16),
      channel_number: dst$physical_resource_number,
      unit_number: cmt$physical_unit_number,
      maus_per_cylinder: dmt$maus_per_position,
      deadstart_sector_mau: dmt$mau_address,
      logical_unit_number: iot$logical_unit,
    recend;

?? PUSH(LISTEXT := ON) ??
*copyc cmt$physical_unit_number
*copyc dmt$minimum_allocation_unit
*copyc dst$iou_number
*copyc dst$physical_resource_number
*copyc iot$logical_unit
?? POP ??
*DECK DECK=DST$DUAL_STATE_CONTROL_BLOCK_CC EXPAND=FALSE

{     Type definitions for the dual state control block for cybil cc.
{  Used to reference the dual state control block from the 170 side.

  TYPE
    dst$dscb_cc_d8st_word = packed record
      upper_3_bits: 0 .. 7(8),
      operator_action: boolean,
      next_19_bits: 0 .. 1777777(8),
      nosve_owns_sci_pp: boolean,
      sci_pp_number: 0 .. 7777(8),
      scd_port: 0 .. 77(8),
      scd_pp_number: 0 .. 77(8),
      dfts_load_flag: boolean,
      sci_deadstart_status: 0 .. 37(8),
      next_5_bits: 0 .. 37(8),
      deadstart_nosve: boolean,
    recend;

*DECK DECK=DST$FETCH_PP_IMAGE_OPTION EXPAND=FALSE

  TYPE
    dst$fetch_pp_image_option = (dsc$fpio_fetch_base_overlay, dsc$fpio_return_overlay_length,
          dsc$fpio_fetch_overlays);
*DECK DECK=DST$HEADER_INFORMATION EXPAND=FALSE

  TYPE
    dst$header_information = RECORD
      block_type: amt$block_type,
      record_type: amt$record_type,
    RECEND;

*copyc amt$block_type
*copyc amt$record_type
*DECK DECK=DST$IMAGE_FILE EXPAND=FALSE

{ Define constants to reference the image file.

  CONST
    dsc$image_file_name = 'dsc$image_file',

{  Define size of the RDF and memory image at the first release of standalone deadstart.

    dsc$old_rdf_size = 80000(16),
    dsc$old_image_size = 800000(16),
    dsc$image_size = 2000000(16);  {  Define 16 megabyte image size, current image size.
*DECK DECK=DST$IMAGE_PAGE_DESCRIPTION EXPAND=FALSE
{This deck defines the record that describes pages recovered from the image
{file.

  TYPE
    dst$image_page_description = RECORD
      valid_desc_count: 0 .. 7ffffffff(16),
      pagesize: ost$page_size,
      page_desc: ARRAY [ * ] OF RECORD
        image_pva: ^cell,
        file_offset: ost$segment_offset,
        modified: boolean,
        page_frame_flawed: boolean,
        disk_file_error: boolean,
        page_lock: mmt$locked_page,
      RECEND,
    RECEND;
*copyc MMT$LOCKED_PAGE
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$HARDWARE_SUBRANGES
*DECK DECK=DST$IMAGE_STATUS EXPAND=FALSE

  { This deck contains the various types of image file status.

  CONST
    dsc$image_initialized = 'image_initialized',
    dsc$nve_idled = 'nve_idled',
    dsc$nve_recovered = 'nve_recovered',
    dsc$nve_resumed = 'nve_resumed',
    dsc$ready_to_run = 'ready_to_run',
    dsc$will_commit = 'will_commit';
*DECK DECK=DST$INFORMATION_KIND EXPAND=FALSE
*DECK DECK=DST$IOU_INFORMATION_TABLE EXPAND=FALSE

  TYPE
    dst$iou_information_entry = RECORD
      physical_iou_number: dst$iou_number,
      model_type: dst$iou_model_types,
    RECEND,

    dst$iou_information_table = ARRAY [dst$number_of_ious] OF dst$iou_information_entry;

*copyc dst$iou_model_types
*copyc dst$iou_number
*copyc dst$number_of_ious
*DECK DECK=DST$IOU_MODEL_TYPES EXPAND=FALSE

{ NOTE:
{   Any new IOU added to this type will cause MALET/VE to be recompiled.

  TYPE
    dst$iou_model_types =        { IOU TYPE    / MAINFRAME(S) }
          (dsc$imn_null_model,   {
           dsc$imn_i1_10_model,  { I1 slowed   / 815
           dsc$imn_i1_11_model,  { I1 minus    / 815
           dsc$imn_i1_12_model,  { I1 full     / 825
           dsc$imn_i1_13_model,  { I1 full CR  / mo830
           dsc$imn_i1_14_model,  { I1 minus CR / mo810
           dsc$imn_i2_20_model,  { I2          / 835, 840, 850, mo855, 860
           dsc$imn_i4_40_model,  { I4          / 840, 850, 855, mo860, 990, 962, 995
           dsc$imn_i4_42_model,  { I4S         / 960
           dsc$imn_i4_44_model,  { I4C         / 860, 960(secondary), 962(primary), 990
           dsc$imn_i4_46_model,  { I4CE        / 2000
           dsc$imn_i0_5x_model); { I0 (50-5F)  / 930
*DECK DECK=DST$IOU_NUMBER EXPAND=FALSE

  TYPE
    dst$iou_number = 0 .. (dsc$max_number_of_ious - 1);

?? PUSH (LISTEXT := ON) ??
*copyc dsc$max_number_of_ious
?? POP ??
*DECK DECK=DST$IOU_RESOURCE EXPAND=FALSE

  TYPE
    dst$iou_resource = RECORD
      iou_number: dst$iou_number,
      channel_protocol: dst$channel_protocol_type,
      number: dst$physical_resource_number,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc dst$channel_protocol_type
*copyc dst$iou_number
*copyc dst$physical_resource_number
?? POP ??
*DECK DECK=DST$LIST_BLOCK EXPAND=FALSE

    TYPE
      dst$list_for_block = array [dst$list_block_kind] of ^SEQ (*),

      dst$list_block = record
        list_block_p: ^SEQ (*),
        rfu_1: ^SEQ (*),
        rfu_2: ^SEQ (*),
        rfu_3: ^SEQ (*),
      recend;

?? PUSH (LISTEXT := ON) ??
*copyc dst$list_block_kind
?? POP ??
*DECK DECK=DST$LIST_BLOCK_KIND EXPAND=FALSE

  TYPE
    dst$list_block_kind = (dsc$save_list_block, dsc$device_management,
      dsc$processor_attributes, dsc$memory_management, dsc$system_messages_buffer);
*DECK DECK=DST$LOG_ELE_STATE_CHANGE EXPAND=FALSE

  TYPE
    dst$log_ele_state_change = record
      element_name: cmt$element_name,
      product_id: cmt$product_identification,
      serial_number: cmt$serial_number,
      old_state: cmt$element_state,
      new_state: cmt$element_state,
      initiator: string (4),
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$product_identification
*copyc cmt$serial_number
*copyc cmt$element_state
?? POP ??
*DECK DECK=DST$LOG_HUNG_PP_DATA EXPAND=FALSE

  TYPE
    dst$log_hung_pp_data = RECORD
      pp: dst$iou_resource,
      channel: dst$iou_resource,
      driver_name: string (7),
      pp_hung_on_one_instruction: boolean,
      pp_registers: dst$dft_pp_registers,
      r_register: integer,
    RECEND;

*copyc dst$dft_pp_registers
*copyc dst$iou_resource
*DECK DECK=DST$LOG_MS_VOLUME_INIT EXPAND=FALSE

  TYPE
    dst$log_ms_volume_init = record
      element_name: cmt$element_name,
      recorded_vsn: string (6),
      physical_unit_number: 0 .. 63,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
?? POP ??
*DECK DECK=DST$LOG_PP_TIMED_OUT EXPAND=FALSE

  TYPE
    dst$log_pp_timed_out = RECORD
      date_time: ost$date_time,
      pp_name: string (5),
    RECEND;

*copyc ost$date_time
*DECK DECK=DST$MAINFRAME_TYPE EXPAND=FALSE

  TYPE
    dst$mainframe_type = (dsc$mt_unknown_mainframe,
                          dsc$mt_lower_8xx_mainframe,
                          dsc$mt_835_mainframe,
                          dsc$mt_upper_8xx_mainframe,
                          dsc$mt_990_mainframe,
                          dsc$mt_93x_mainframe,
                          dsc$mt_960_970_mainframe,
                          dsc$mt_962_972_mainframe,
                          dsc$mt_992_mainframe,
                          dsc$mt_994_mainframe,
                          dsc$mt_2000_mainframe);
*DECK DECK=DST$MF_ELEMENT_TABLE_ENTRY EXPAND=FALSE

  TYPE
    dst$mf_element_id = RECORD
      element_number: dst$mf_element_number,
      dft_entry_id: dst$mf_element_number,
    RECEND,

    dst$mf_element_number = 0 .. 0ff(16),

    dst$mf_element_string = RECORD
      size: 0 .. 5,
      value: string (5),
    RECEND,

    dst$mf_element_table_entry = RECORD
      element_id: dst$mf_element_id,
      model_number: ost$processor_model_number,
      serial_number: ost$processor_serial_number,
      element_number_string: dst$mf_element_string,
      model_number_string: dst$mf_element_string,
      serial_number_string: dst$mf_element_string,
    RECEND;

*copyc dst$180_dft_block
*copyc ost$processor_element_id
*DECK DECK=DST$MRT_ENTRY EXPAND=FALSE

  CONST
    dsc$mrt_ct_undefined = 0,
    dsc$mrt_ct_cyber_170_channel = 1,
    dsc$mrt_ct_isi_channel = 2,
    dsc$mrt_ct_isi_dma_channel = 3,
    dsc$mrt_ct_not_defined_4 = 4,
    dsc$mrt_ct_170_dma_esm_enhanced = 5,
    dsc$mrt_ct_ipi_dma_dual_port = 6,
    dsc$mrt_ct_ipi_dma_enhanced = 7,
    dsc$mrt_ct_pp_communication = 10(8),
    dsc$mrt_ct_scsi_interface = 11(8),
    dsc$mrt_ct_ici_s0 = 12(8),
    dsc$mrt_ct_ipi_s0 = 13(8),
    dsc$mrt_ct_not_defined_14b = 14(8),
    dsc$mrt_ct_not_defined_15b = 15(8),
    dsc$mrt_ct_not_defined_16b = 16(8),
    dsc$mrt_ct_channel_not_present = 17(8);

  TYPE
    dst$mrt_entry = RECORD
      CASE dst$mrt_entry_id OF
      = dsc$mrt_id_iou =
        iou: dst$mrt_iou_info,
      = dsc$mrt_id_central_memory =
        memory: dst$mrt_central_memory_info,
      = dsc$mrt_id_processor =
        processor: dst$mrt_processor_info,
      = dsc$mrt_id_mainframe =
        mainframe: dst$mrt_mainframe_info,
      = dsc$mrt_id_flpp =
        flpp: dst$mrt_flpp_info,
      = dsc$mrt_id_display_console =
        console: dst$mrt_display_console_info,
      = dsc$mrt_id_global_processor =
        global_processor: dst$mrt_global_processor_info,
      = dsc$mrt_id_clock_data =
        clock_data: dst$mrt_clock_data_info,
      = dsc$mrt_id_model_dependent =
        model_dependent: dst$mrt_model_dependent_info,
      = dsc$mrt_id_page_map =
        page_map: dst$mrt_page_map_info,
      CASEND,
    RECEND;

  TYPE
    dst$mrt_element_number = 0 .. 1,

    dst$mrt_entry_id = (dsc$mrt_id_iou, dsc$mrt_id_central_memory, dsc$mrt_id_processor,
          dsc$mrt_id_mainframe, dsc$mrt_id_flpp, dsc$mrt_id_display_console, dsc$mrt_id_global_processor,
          dsc$mrt_id_reserved, dsc$mrt_id_clock_data, dsc$mrt_id_model_dependent, dsc$mrt_id_page_map);

  TYPE
    dst$mrt_clock_data = PACKED RECORD
      pad: 0 .. 0ff(16),
      tens: 0 .. 0f(16),
      units: 0 .. 0f(16),
    RECEND,

    dst$mrt_cm_address = RECORD
      upper: 0 .. 0ffff(16),
      lower: 0 .. 0ffff(16),
    RECEND,

    dst$mrt_descriptor_id = PACKED RECORD
      size: 0 .. 1777(8),
      id: 0 .. 77(8),
    RECEND,

    dst$mrt_element_id = PACKED RECORD
      pad: 0 .. 0ff(16),
      element_number: 0 .. 0ff(16),
      model_number: 0 .. 0fff(16),
      serial_number_upper: 0 .. 0f(16),
      serial_number_lower: 0 .. 0ffff(16),
    RECEND,

    dst$mrt_frc_data = PACKED RECORD
      pad: 0 .. 0f(16),
      frc_bits: 0 .. 0fff(16),
    RECEND,

    dst$mrt_maintenance_channel_id = PACKED RECORD
      pad: 0 .. 0f(16),
      port: 0 .. 0f(16),
      unused: 0 .. 0f(16),
      type_code: 0 .. 0f(16),
    RECEND,

    dst$mrt_pak_descriptor = PACKED RECORD
      pad_1: 0 .. 3,
      data_00_31_secded_0_3: 0 .. 77(8),
      pad_2: 0 .. 3,
      data_32_63_secded_4_7: 0 .. 77(8),
    RECEND,

    dst$mrt_pp_barrel_vector = PACKED ARRAY [0 .. 15] OF boolean,

    dst$mrt_pp_vector = RECORD
      barrel_0: dst$mrt_pp_barrel_vector,
      barrel_1: dst$mrt_pp_barrel_vector,
    RECEND,

    dst$mrt_two_channel_descriptor = PACKED RECORD
      pad: 0 .. 0f(16),
      a_channel_on_off_status: boolean,
      a_channel_up_down_status: boolean,
      a_channel_type: 0 .. 0f(16),
      b_channel_on_off_status: boolean,
      b_channel_up_down_status: boolean,
      b_channel_type: 0 .. 0f(16),
    RECEND;

  TYPE
    dst$mrt_iou_info = PACKED RECORD
      descriptor_id: dst$mrt_descriptor_id,
      element_id: dst$mrt_element_id,
      maintenance_channel_id: dst$mrt_maintenance_channel_id,
      pps_physically_missing: dst$mrt_pp_vector,
      pps_logically_missing: dst$mrt_pp_vector,
      pad_1: 0 .. 17777(8),
      pp_speed: 0 .. 7(8),
      channels_missing: dst$mrt_pp_vector,
      physically_present_cio_pps: dst$mrt_pp_barrel_vector,
      logically_present_cio_pps: dst$mrt_pp_barrel_vector,
      physically_present_cio_channels: dst$mrt_pp_barrel_vector,
      pps_0_11b_up_down_status: dst$mrt_pp_barrel_vector,
      pps_20b_31b_up_down_status: dst$mrt_pp_barrel_vector,
      i4_cio_pps_up_down_status: dst$mrt_pp_barrel_vector,
      channel_00_01: dst$mrt_two_channel_descriptor,
      channel_02_03: dst$mrt_two_channel_descriptor,
      channel_04_05: dst$mrt_two_channel_descriptor,
      channel_06_07: dst$mrt_two_channel_descriptor,
      channel_10b_11b: dst$mrt_two_channel_descriptor,
      channel_12b_13b: dst$mrt_two_channel_descriptor,
      channel_20b_21b: dst$mrt_two_channel_descriptor,
      channel_22b_23b: dst$mrt_two_channel_descriptor,
      channel_24b_25b: dst$mrt_two_channel_descriptor,
      channel_26b_27b: dst$mrt_two_channel_descriptor,
      channel_30b_31b: dst$mrt_two_channel_descriptor,
      channel_32b_33b: dst$mrt_two_channel_descriptor,
      i4_cio_channel_00_01: dst$mrt_two_channel_descriptor,
      i4_cio_channel_02_03: dst$mrt_two_channel_descriptor,
      i4_cio_channel_04_05: dst$mrt_two_channel_descriptor,
      i4_cio_channel_06_07: dst$mrt_two_channel_descriptor,
      i4_cio_channel_10b_11b: dst$mrt_two_channel_descriptor,
      pad_2: 0 .. 77777(8),
      iou_logically_off: boolean,
    RECEND,

    dst$mrt_central_memory_info = PACKED RECORD
      descriptor_id: dst$mrt_descriptor_id,
      element_id: dst$mrt_element_id,
      maintenance_channel_id: dst$mrt_maintenance_channel_id,
      physical_central_memory_size: dst$mrt_cm_address,
      logical_central_memory_size: dst$mrt_cm_address,
      physical_cm_size_in_octal: 0 .. 0ffff(16),
      scd_reference_address: dst$mrt_cm_address,
      scd_offset: 0 .. 0ffff(16),
      operator_entered_cm_size: dst$mrt_cm_address,
    RECEND,

    dst$mrt_processor_info = PACKED RECORD
      descriptor_id: dst$mrt_descriptor_id,
      element_id: dst$mrt_element_id,
      maintenance_channel_id: dst$mrt_maintenance_channel_id,
      pad_1: 0 .. 0f(16),
      page_map_0: boolean,
      page_map_1: boolean,
      page_map_2: boolean,
      page_map_3: boolean,
      segment_map_0: boolean,
      segment_map_1: boolean,
      pad_2: boolean,
      physical_16k_cache_installed: boolean,
      cache_set_0: boolean,
      cache_set_1: boolean,
      cache_set_2: boolean,
      cache_set_3: boolean,
      pad_3: 0 .. 17777(8),
      memory_port: 0 .. 7(8),
      pad_4: 0 .. 0f(16),
      processor_down_by_operator: boolean,
      processor_down_by_system: boolean,
      processor_down: boolean,
      ibs_degrade_bits: 0 .. 0f(16),
      vector_option_not_installed: boolean,
      pmf_not_present: boolean,
      c180_not_supported: boolean,
      c170_not_supported: boolean,
      processor_off: boolean,
      pad_5: 0 .. 0f(16),
      divide_net_result_select: 0 .. 3,
      divide_net_select_for_compare: 0 .. 3,
      disable_maintenance_mode: boolean,
      pad_6: 0 .. 3,
      no_cpu0_instruction_stack: boolean,
      no_cmu_capability: boolean,
      no_cej_mej_capability: boolean,
      cpu1_not_available: boolean,
      cpu0_not_available: boolean,
      pad_7: 0 .. 77777(8),
      micro_code_not_loaded: boolean,
      micro_code_name_char_1_2: 0 .. 0ffff(16),
      micro_code_name_char_3_4: 0 .. 0ffff(16),
      micro_code_name_char_5_6: 0 .. 0ffff(16),
      micro_code_name_char_7: 0 .. 0ffff(16),
      reserved_1: 0 .. 0ffff(16),
      micro_code_date_char_1_2: 0 .. 0ffff(16),
      micro_code_date_char_3_4: 0 .. 0ffff(16),
      micro_code_date_char_5_6: 0 .. 0ffff(16),
      reserved_2: 0 .. 0ffff(16),
      reserved_3: 0 .. 0ffff(16),
    RECEND,

    dst$mrt_mainframe_info = PACKED RECORD
      descriptor_id: dst$mrt_descriptor_id,
      pad_1: 0 .. 0f(16),
      r_register_not_available: boolean,
      reserved_1: boolean,
      not_c176: boolean,
      not_c170_700: boolean,
      interlock_register_not_present: boolean,
      scr_not_present: boolean,
      reserved_2: 0 .. 77(8),
      pad_2: 0 .. 77777(8),
      no_cem_pem: boolean,
      physical_processors_present: 0 .. 0ffff(16),
      undefined: 0 .. 0ffff(16),
      char_1_2_ei_date: 0 .. 0ffff(16),
      char_3_4_ei_date: 0 .. 0ffff(16),
      char_5_6_ei_date: 0 .. 0ffff(16),
      ei_level: 0 .. 0ffff(16),
    RECEND,

    dst$mrt_flpp_info = PACKED RECORD
      descriptor_id: dst$mrt_descriptor_id,
      pad_1: 0 .. 77777(8),
      flpp_15_physically_present: boolean,
      flpp_1_14_physically_present: 0 .. 0ffff(16),
      pad_2: 0 .. 77777(8),
      flpp_15_logically_on: boolean,
      flpp_1_14_logically_on: 0 .. 0ffff(16),
    RECEND,

    dst$mrt_display_console_info = PACKED RECORD
      descriptor_id: dst$mrt_descriptor_id,
      display_type: 0 .. 0ffff(16),
      port_flags: 0 .. 0ffff(16),
      mdd_pp: 0 .. 1777(8),
      scd_pp: 0 .. 77(8),
      pad: 0 .. 0fff(16),
      mdd_to_be_loaded: boolean,
      mdd_port_number: 0 .. 7(8),
    RECEND,

    dst$mrt_global_processor_info = PACKED RECORD
      descriptor_id: dst$mrt_descriptor_id,
      micro_long_init: 0 .. 0ffff(16),
      micro_idle_short_init: 0 .. 0ffff(16),
      micro_mps_heo: 0 .. 0ffff(16),
      micro_jps_heo: 0 .. 0ffff(16),
      micro_mps_hei: 0 .. 0ffff(16),
      micro_jps_hei: 0 .. 0ffff(16),
      pad_1: 0 .. 0f(16),
      pte: 0 .. 7(8),
      ptl: 0 .. 1ff(16),
      page_size: 0 .. 0ffff(16),
      pad_2: 0 .. 3fff(16),
      secure_analysis: boolean,
      state_flag: boolean,
      pad_3: 0 .. 0f(16),
      carriage_return: boolean,
      disk_deadstart: boolean,
      tape_deadstart: boolean,
      pad_4: 0 .. 7,
      cip_channel: 0 .. 77(8),
      cip_disk_type: 0 .. 0ff(16),
      cip_disk_unit: 0 .. 0ff(16),
      reserved_1: 0 .. 0ffff(16),
      reserved_2: 0 .. 0ffff(16),
      reserved_3: 0 .. 0ffff(16),
      reserved_4: 0 .. 0ffff(16),
    RECEND,

    dst$mrt_clock_data_info = PACKED RECORD
      descriptor_id: dst$mrt_descriptor_id,
      years: dst$mrt_clock_data,
      months: dst$mrt_clock_data,
      days: dst$mrt_clock_data,
      hours: dst$mrt_clock_data,
      minutes: dst$mrt_clock_data,
      seconds: dst$mrt_clock_data,
      frc_bits_4_15: dst$mrt_frc_data,
      frc_bits_16_27: dst$mrt_frc_data,
      frc_bits_28_39: dst$mrt_frc_data,
      frc_bits_40_51: dst$mrt_frc_data,
      frc_bits_52_63: dst$mrt_frc_data,
    RECEND,

    dst$mrt_model_dependent_info = PACKED RECORD
      descriptor_id: dst$mrt_descriptor_id,
      pad_1: 0 ..177(8),
      mega_bit_cm_chip_installed: boolean,
      pad_2: 0 .. 77(8),
      upper_cm_banks_degraded: boolean,
      lower_cm_banks_degraded: boolean,
      pak_3_bank_0: dst$mrt_pak_descriptor,
      pak_3_bank_1: dst$mrt_pak_descriptor,
      pak_3_bank_2: dst$mrt_pak_descriptor,
      pak_3_bank_3: dst$mrt_pak_descriptor,
      pak_1_bank_0: dst$mrt_pak_descriptor,
      pak_1_bank_1: dst$mrt_pak_descriptor,
      pak_1_bank_2: dst$mrt_pak_descriptor,
      pak_1_bank_3: dst$mrt_pak_descriptor,
      pak_4_bank_0: dst$mrt_pak_descriptor,
      pak_4_bank_1: dst$mrt_pak_descriptor,
      pak_4_bank_2: dst$mrt_pak_descriptor,
      pak_4_bank_3: dst$mrt_pak_descriptor,
      pak_2_bank_0: dst$mrt_pak_descriptor,
      pak_2_bank_1: dst$mrt_pak_descriptor,
      pak_2_bank_2: dst$mrt_pak_descriptor,
      pak_2_bank_3: dst$mrt_pak_descriptor,
    RECEND,

    dst$mrt_page_map_info = PACKED RECORD
      descriptor_id: dst$mrt_descriptor_id,
      element_id: dst$mrt_element_id,
      pad_1: 0 .. 0f(16),
      subsystem_id: 0 .. 0f(16),
      pad_2: 0 .. 0f(16),
      subsystem_number: 0 .. 0f(16),
      pad_3: 0 .. 0fff(16),
      page_map_degrade_bits: 0 .. 0f(16),
    RECEND;
*DECK DECK=DST$MTR_DFT_REQUESTS EXPAND=FALSE

  TYPE
    dst$mtr_dft_requests = RECORD
      puf_p: ^dst$dft_process_pp_function,
      reload_sci_p: ^dst$dft_reload_sci,
      puf_data_p: ^dst$mtr_dft_puf_memory_area,
    RECEND,

    dst$mtr_dft_puf_memory_area = RECORD
      data: ALIGNED [0 MOD 8] ARRAY [1 .. 2] OF integer,
    RECEND;

*copyc dst$dft_requests
*DECK DECK=DST$NUMBER_OF_IOUS EXPAND=FALSE

  TYPE
    dst$number_of_ious = 1 .. dsc$max_number_of_ious;

?? PUSH (LISTEXT := ON) ??
*copyc dsc$max_number_of_ious
?? POP ??
*DECK DECK=DST$NVE_IMAGE_DESCRIPTOR EXPAND=FALSE

  TYPE
    dst$nve_image_descriptor = record
      rcv_mps: ost$real_memory_address,
      rcv_jps: ost$real_memory_address,
      rcv_system_job_mtr_jps: ost$real_memory_address,
      rcv_page_frame_tbl_p: ^mmt$page_frame_table,
      rcv_hash_tbl_p: ^mmt$old_modified_bits,
      rcv_mfw_asid_p: ^mmt$mainframe_wired_asid,
      rcv_page_size: ost$page_size,
      rcv_load_offset: ost$real_memory_address,
      rcv_nve_image_length: ost$byte_count,
      rcv_mainframe_wired_segment: ^SEQ ( * ),
      nve_image: ^SEQ ( * ),
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc OST$PAGE_SIZE
*copyc MMT$PAGE_FRAME_TABLE
*copyc MMT$OLD_MODIFIED_BITS
*copyc MMT$MAINFRAME_WIRED_ASID
*copyc OST$HARDWARE_SUBRANGES
?? POP ??
*DECK DECK=DST$OS_ACTION_CODE_CONSTANTS EXPAND=FALSE

  CONST
    dsc$dftb_oac_no_action          = 00(16),
    dsc$dftb_oac_environment        = 01(16),
    dsc$dftb_oac_long_power         = 02(16),
    dsc$dftb_oac_short_power        = 03(16),
    dsc$dftb_oac_warning_clear      = 04(16),
    dsc$dftb_oac_fatal_iou          = 05(16),
    dsc$dftb_oac_uncorrected_iou    = 06(16),
    dsc$dftb_oac_uncorrected_memory = 07(16),
    dsc$dftb_oac_memory             = 08(16),
    dsc$dftb_oac_uncorrected_cpu    = 09(16),
    dsc$dftb_oac_170_state_iou      = 0a(16),
    dsc$dftb_oac_system_idle        = 0b(16),
    dsc$dftb_oac_system_resume      = 0c(16),
    dsc$dftb_oac_170_state_idle     = 0d(16),
    dsc$dftb_oac_170_state_resume   = 0e(16),
    dsc$dftb_oac_180_state_idle     = 0f(16),
    dsc$dftb_oac_180_state_resume   = 10(16),
    dsc$dftb_oac_system_step        = 11(16),
    dsc$dftb_oac_system_unstep      = 12(16),
    dsc$dftb_oac_170_state_step     = 13(16),
    dsc$dftb_oac_170_state_unstep   = 14(16),
    dsc$dftb_oac_180_state_step     = 15(16),
    dsc$dftb_oac_180_state_unstep   = 16(16),
    dsc$dftb_oac_reconfigure_nce    = 17(16),  { Reconfigure non critical element.
    dsc$dftb_oac_vector_degrade     = 18(16),
    dsc$dftb_oac_element_degrade    = 19(16),
    dsc$dftb_oac_flaw_cm_page       = 1a(16),
    dsc$dftb_oac_handle_pp_hang     = 1c(16),
    dsc$dftb_oac_handle_bit_57      = 1d(16);
*DECK DECK=DST$PHYSICAL_RESOURCE_NUMBER EXPAND=FALSE

  TYPE
    dst$physical_resource_number = 0 .. 33(8);
*DECK DECK=DST$POST_OPERATOR_ACTIONS EXPAND=FALSE
*DECK DECK=DST$PP_HEADER_DESCRIPTOR EXPAND=FALSE

  TYPE
    dst$pp_header_descriptor = RECORD
      load_address: dst$pp_word,
      cm_word_length: dst$pp_word,
      overlay_number: dst$pp_word,
      CASE boolean OF
      = TRUE =
        overlay_offset: dst$pp_word,
      = FALSE =
        checksum: dst$pp_word,
      CASEND,
    RECEND,

    dst$pp_word = 0 .. 0ffff(16);
*DECK DECK=DST$PROCESSOR_DOWN_REASON EXPAND=FALSE

  TYPE
    dst$processor_down_reason = (dsc$pdr_null, dsc$pdr_down_by_operator, dsc$pdr_down_by_system);
*DECK DECK=DST$RB_ISSUE_DFT_REQUEST EXPAND=FALSE

  TYPE
    dst$rb_issue_dft_request = RECORD
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      dft_request_p: ^SEQ ( * ),
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc dse$dft_errors
*copyc syc$monitor_request_codes
*copyc syt$monitor_status
?? POP ??
*DECK DECK=DST$RB_LOGGING_REQUEST EXPAND=FALSE

  { This type declaration is used to allow communication from job mode/system core and monitor
  { mode during logging of system messages or logging of DFT errors.

  TYPE
    dst$rb_logging_request = RECORD
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      action: dst$rb_logging_actions,
      response: dst$rb_logging_responses,
      dftb_cw_index: integer,
      dftb_control_word: dst$dftb_buffer_control_word,
      dftb_data_structures: dst$rb_dft_data_structures,
      dftb_seq_p: ^SEQ ( * ),
      dftb_clear_entries_checked: 0 .. 10,
      dftb_log_entries_checked: 0 .. 10,
      dftb_dfts_control_word: dst$dftb_control_word,
      sys_msg_remove_data_seq_p: ^SEQ ( * ),
      sys_msg_add_data_seq_p: ^SEQ ( * ),
      sys_msg_clear_buffer: boolean,
      sys_msg_new_buffer_size: integer,
    RECEND,

    dst$rb_dft_data_structures = SET OF (dsc$dds_mrb, dsc$dds_ssb, dsc$dds_nrb, dsc$dds_mdb),

    dst$rb_logging_actions = (dsc$rla_dft_setup_variables, dsc$rla_dft_access_buffer_entry,
          dsc$rla_dft_log_top_of_hour, dsc$rla_sys_msg_add_message, dsc$rla_sys_msg_get_message,
          dsc$rla_sys_msg_enlarge_buffer, dsc$rla_dft_retrieve_dfts_cw),

    dst$rb_logging_responses = (dsc$rlr_dft_entry_to_log, dsc$rlr_dft_no_entry_to_log,
          dsc$rlr_dft_entry_interlocked);

*copyc dst$180_dft_block
*copyc syc$monitor_request_codes
*copyc syt$monitor_status
*DECK DECK=DST$RB_SYSTEM_DEADSTART_STATUS EXPAND=FALSE

  TYPE
    dst$rb_system_deadstart_status = RECORD
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      action: dst$rb_sds_actions,
      data_p: ^dst$ssr_system_deadstart_status,
      bct_flags: dst$rb_sds_bct_flags,
      bct_flag_set: boolean,
      iou_model: dst$rb_sds_iou_model,
    RECEND,

    dst$rb_sds_iou_model = (dsc$rb_model_40, dsc$rb_model_44),


    dst$rb_sds_actions = (dsc$rb_sds_initialize_data, dsc$rb_sds_retrieve_data,
          dsc$rb_sds_set_cpt_pointer, dsc$rb_sds_set_bct_flag, dsc$rb_sds_clear_bct_flag,
          dsc$rb_sds_retrieve_bct_flag, dsc$rb_sds_fetch_element_id),

    dst$rb_sds_bct_flags = (dsc$rb_sds_bct_both_cpu_error, dsc$rb_sds_bct_ts_by_operator,
          dsc$rb_sds_bct_ts_by_error, dsc$rb_sds_bct_auto_restart, dsc$rb_sds_bct_sys_has_idled,
          dsc$rb_sds_bct_ar_control, dsc$rb_sds_bct_point_of_commit);

*copyc dst$ssr_data_types
*copyc syc$monitor_request_codes
*copyc syt$monitor_status
*DECK DECK=DST$RDF_ENTRIES EXPAND=FALSE

  TYPE
    dst$rdf_entries = (dsc$rdf_commit_new_dsfile_flag,
                       dsc$rdf_deadstart_state,
                       dsc$rdf_directory,
                       dsc$rdf_good_image_flag,
                       dsc$rdf_image_size,
                       dsc$rdf_image_table_size,
                       dsc$rdf_job_recovery,
                       dsc$rdf_job_recovery_command,
                       dsc$rdf_list_block,
                       dsc$rdf_lower_memory_limit,
                       dsc$rdf_page_table_modified_bit,
                       dsc$rdf_password_interval_data,
                       dsc$rdf_previous_recovery_type,
                       dsc$rdf_recovery_image_status,
                       dsc$rdf_register_values,
                       dsc$rdf_restore_status,
                       dsc$rdf_ssr_name_bo_in_image,
                       dsc$rdf_storage_area,
                       dsc$rdf_sys_msg_buffer_size,
                       dsc$rdf_system_core_id,
                       dsc$rdf_system_idled_status,
                       dsc$rdf_system_messages_buffer,
                       dsc$rdf_system_supplied_name);
*DECK DECK=DST$RDF_POINTERS EXPAND=FALSE

  TYPE
    dst$rdf_pointers = RECORD
      production_seq_p: ^SEQ ( * ),
      system_message_buffer_seq_p: ^SEQ ( * ),
      recovery_seq_p: ^SEQ ( * ),
      unused_seq_p: ^SEQ ( * ),
    RECEND;
*DECK DECK=DST$RDF_TYPE EXPAND=FALSE

  TYPE
    dst$rdf_type = (dsc$rdf_production, dsc$rdf_system_message_buffer,
          dsc$rdf_recovery, dsc$rdf_unused);
*DECK DECK=DST$RECOVERY_NAME_TABLE EXPAND=FALSE

  TYPE
    dst$recovery_name_table = array [1 .. * ] of dst$recovery_address;

  TYPE
    dst$recovery_address = record
      name: pmt$program_name,
      address: ^cell,
      verification: llt$declaration_matching_value,
    recend;

*copyc llt$declaration_matching_value
*copyc pmt$program_name
*DECK DECK=DST$RECOVER_DEADSTART_FILES EXPAND=FALSE

  TYPE
    dst$recover_deadstart_files = PACKED RECORD
      production: ALIGNED dst$rdf_set_sequence,
      system_message_buffer: ALIGNED dst$rdf_set_sequence,
      recovery: ALIGNED dst$rdf_set_sequence,
      unused: ALIGNED dst$rdf_set_sequence,
    RECEND,

    dst$rdf_set_sequence = SEQ (REP dsc$rdf_size OF cell);

*copyc dsc$rdf_constants
*DECK DECK=DST$RESOURCE_NAME EXPAND=FALSE

  TYPE
    dst$resource_name = string (4);
*DECK DECK=DST$RESOURCE_REQUEST EXPAND=FALSE

  TYPE
    dst$resource_request = RECORD
      channel: dst$iou_resource,
      CASE resource_request_type: dst$resource_request_types OF
      = dsc$rrt_get_pp, dsc$rrt_return_pp =
        options: dst$resource_request_options,
        primary_pp: dst$iou_resource,
        secondary_pp: dst$iou_resource,
      = dsc$rrt_get_equipment, dsc$rrt_return_equipment =
        equipment_number: cmt$physical_equipment_number,
        unit_number: cmt$physical_unit_number,
      CASEND,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$physical_equipment_number
*copyc cmt$physical_unit_number
*copyc dst$iou_resource
*copyc dst$resource_request_options
*copyc dst$resource_request_types
?? POP ??
*DECK DECK=DST$RESOURCE_REQUEST_OPTIONS EXPAND=TRUE

  TYPE
    dst$resource_request_options = SET OF (dsc$rro_driver_pp,
          dsc$rro_partner_pp, dsc$rro_specific_pp, dsc$rro_any_pp);
*DECK DECK=DST$RESOURCE_REQUEST_TYPES EXPAND=FALSE

  TYPE
    dst$resource_request_types = (dsc$rrt_null_request, dsc$rrt_get_pp,
          dsc$rrt_return_pp, dsc$rrt_get_channel, dsc$rrt_return_channel,
          dsc$rrt_get_equipment, dsc$rrt_return_equipment,
          dsc$rrt_update_free_run_clock);
*DECK DECK=DST$R_POINTER EXPAND=FALSE

  TYPE
    dst$r_pointer = RECORD
      offset: 0 .. 0ffff(16),
      rupper: 0 .. 0ffff(16),
      rlower: 0 .. 0ffff(16),
      length: 0 .. 0ffff(16),
    RECEND;
*DECK DECK=DST$SIGNAL_CONTENTS EXPAND=FALSE

  TYPE
    dst$signal_contents = RECORD
      CASE 1 .. 2 OF
      = 1 =
        signal: pmt$signal,
      = 2 =
        identifier: pmt$signal_id,
        contents: dst$signal_contents_entry,
      CASEND,
    RECEND,

    dst$signal_contents_entry = RECORD
      CASE kind: dst$signal_kinds OF
      = dsc$signal_lock_unlock_window =
        luw_data: dst$signal_luw_data,
      = dsc$signal_post_operator_action =
        poa_data: dst$signal_poa_data,
      = dsc$signal_hung_pp_process =
        hpp_data: dst$signal_hpp_data,
      CASEND,
    RECEND,

    dst$signal_hpp_data = RECORD
      date_time: ost$date_time,
      sci_reload_failed: boolean,
      check_entire_table: boolean,
      logical_pp_index: iot$pp_number,
    RECEND,

    dst$signal_kinds = (dsc$signal_lock_unlock_window, dsc$signal_post_operator_action,
          dsc$signal_hung_pp_process, dsc$signal_reserved_4, dsc$signal_reserved_5, dsc$signal_reserved_6,
          dsc$signal_reserved_7, dsc$signal_reserved_8),

    dst$signal_luw_data = RECORD
      password: string (7),
      lock_window: boolean,
    RECEND,

    dst$signal_poa_data = RECORD
      date_time: ost$date_time,
      kind: dst$signal_poa_kinds,
    RECEND,

    dst$signal_poa_kinds = (dsc$signal_poa_sp_timeout, dsc$signal_poa_sys_in_degrade,
          dsc$signal_poa_cpu_down_by_sys);

*copyc iot$pp_number
*copyc ost$date_time
*copyc pmt$signal
*DECK DECK=DST$SSR_DATA_TYPES EXPAND=FALSE

  CONST
    dsc$ssr_offset = 1000(16),
    dsc$ssr_segment_number = 4,

    dsc$ssr_sds_cause_indeterminate = 0,
    dsc$ssr_sds_cause_mainframe = 1,
    dsc$ssr_sds_cause_disk = 2,
    dsc$ssr_sds_cause_software = 3,
    dsc$ssr_sds_cause_operator = 4,

    dsc$ssr_sds_nos_id_count = 2,
    dsc$ssr_sds_number_of_disk_errs = 6,
    dsc$ssr_sds_number_of_mf_errors = 7,
    dsc$ssr_sds_number_of_nos_id = 6,

    dsc$ssr_sds_sdas_first_attempt = 0,
    dsc$ssr_sds_sdas_installation = 1,
    dsc$ssr_sds_sdas_continuation = 2,
    dsc$ssr_sds_sdas_with_image = 3,
    dsc$ssr_sds_sdas_without_image = 4,
    dsc$ssr_sds_sdas_ignore_image = 5,

    dsc$ssr_sds_source_tape = 1,
    dsc$ssr_sds_source_disk = 2,

    dsc$ssr_sds_version_1 = 1;

  TYPE
    dst$ssr_170_transfer_entry = RECORD
      offset: 0 .. 0ffffffff(16),
      length: 0 .. 0ffffffff(16),
    RECEND,

    dst$ssr_bmb_r_register = RECORD
      r_upper: 0 .. 07777(8),
      r_lower: 0 .. 07777(8),
    RECEND,

    dst$ssr_boot_memory_bounds = RECORD
      start_address: dst$ssr_bmb_r_register,
      length: dst$ssr_bmb_r_register,
    RECEND,

    dst$ssr_deadstart_panel = ARRAY [1 .. 20(8)] OF 0 .. 0ffff(16),

    dst$ssr_dfts_buffer = RECORD
      start_of_table: integer,
      control_word: dst$dftb_control_word,
    RECEND,

    dst$ssr_entry = RECORD
      name: dst$ssr_entry_name,
      CASE 0 .. 2 OF
      = 0 =
        left_slot: 0 .. 0ffff(16),
        right_slot: 0 .. 0ffff(16),
      = 1 =
        whole_slot: 0 .. 0ffffffff(16),
      = 2 = {format of SYSL entry.
        ssln_released_level_number: 0 .. 0ffff(16),
        ssln_bcu_level_number: 0 .. 0ffff(16),
      CASEND,
    RECEND,

    dst$ssr_entry_name = string (4),

    dst$ssr_entry_types = (dsc$ssr_whole_slot, dsc$ssr_left_slot, dsc$ssr_right_slot),

    dst$ssr_system_deadstart_status = RECORD
      initialized: boolean,
      version: 0 .. 0ff(16),
      top_line_message: string (dpc$console_row_size - 4),
      dft_message: string (24),
      general_info: dst$ssr_sds_general_info,
      disk_errors: dst$ssr_sds_disk_errors,
      mainframe_errors: dst$ssr_sds_mainframe_errors,
      nos_nbe_words: dst$ssr_sds_nos_nbe_words,
    RECEND,

    dst$ssr_sds_disk_error_actions = (dsc$ssr_sds_disk_request_good, dsc$ssr_sds_disk_request_bad),

    dst$ssr_sds_disk_errors = RECORD
      next_available_entry: 1 .. dsc$ssr_sds_number_of_disk_errs,
      number_of_valid_entries: 0 .. dsc$ssr_sds_number_of_disk_errs,
      entry: ARRAY [1 .. dsc$ssr_sds_number_of_disk_errs] OF dst$ssr_sds_disk_error_entry,
    RECEND,

    dst$ssr_sds_disk_error_entry = RECORD
      timestamp: dst$ssr_sds_timestamp,
      element_name: cmt$element_name,
      last_request_good: boolean,
    RECEND,

    dst$ssr_sds_ds_performed_code = PACKED RECORD
      current_deadstart: 0 .. 0f(16),
      previous_deadstart: 0 .. 0f(16),
      auto_restart: 0 .. 0f(16),
      rfu: 0 .. 0f(16),
    RECEND,

    dst$ssr_sds_general_info = RECORD
      deadstarts_performed_code: dst$ssr_sds_ds_performed_code,
      probable_cause_of_crash: 0 .. 0ffff(16),
      deadstart_file_source: 0 .. 0ff(16),
      number_of_recoveries_attempted: 0 .. 0ffffff(16),
      os_release_identifier: string (22),
      rfu: 0 .. 0ffff(16),
      timestamp_of_crash: dst$ssr_sds_timestamp,
    RECEND,

    dst$ssr_sds_mainframe_errors = RECORD
      number_of_valid_entries: 0 .. dsc$ssr_sds_number_of_mf_errors,
      data: ARRAY [1 .. dsc$ssr_sds_number_of_mf_errors] OF dst$ssr_sds_mf_error_data,
    RECEND,

    dst$ssr_sds_mf_error_data = RECORD
      valid: boolean,
      entry: dst$ssr_sds_mf_error_entry,
    RECEND,

    dst$ssr_sds_mf_error_entry = RECORD
      timestamp: dst$dftb_date_and_time,
      element_id: dst$dftb_mrt_element_index,
      rfu: 0 .. 0ffffff(16),
      fault_symptom_code: dst$dftb_fault_symptom_code,
    RECEND,

    dst$ssr_sds_nos_nbe_words = RECORD
      os_type: 0 .. 0ff(16),
      nos_nbe_status: 0 .. 0ff(16),
      rfu: 0 .. 0ffffffffffff(16),
      identifier: ARRAY [1 .. dsc$ssr_sds_number_of_nos_id] OF integer,
    RECEND,

    dst$ssr_sds_timestamp = RECORD
      CASE 0 .. 2 OF
      = 0 =
        dft: dst$dftb_date_and_time_field,
      = 1 =
        os: ost$date_time,
      = 2 =
        word: integer,
      CASEND,
    RECEND;

*copyc cmt$element_name
*copyc dpc$console_row_size
*copyc dsc$ssr_entry_constants
*copyc dst$180_dft_block
*copyc ost$170_os_termination_status
*copyc ost$170_os_type
*copyc ost$date_time
*DECK DECK=DST$SUB_MAINFRAME_TYPE EXPAND=FALSE

  TYPE
    dst$sub_mainframe_type = (dsc$smt_unknown_mainframe, dsc$smt_china_mainframe, dsc$smt_soviet_mainframe);
*DECK DECK=DST$SYSTEM_LOGGING_TYPES EXPAND=FALSE

  TYPE
    dst$system_logging_types = (dsc$disk_errors, dsc$tape_errors,
      dsc$general_io_error, dsc$general_du_error, dsc$system_continuation,
      dsc$system_termination, dsc$general_system_message, dsc$fs_stornet_errors);
*DECK DECK=DST$SYSTEM_MESSAGE_LEVELS EXPAND=FALSE

  TYPE
    dst$system_message_levels = (dsc$fatal_error, dsc$critical_error,
      dsc$unrecovered_error, dsc$recovered_error, dsc$informative_message);
*DECK DECK=DST$SYSTEM_MESSAGE_TYPES EXPAND=FALSE

{  common deck DST$SYSTEM_MESSAGE_TYPES
{ These type declarations are used in the process of placing
{ system messages onto the System Message buffer and removing
{ system messages from the System Messages buffer.

  CONST
    { The original System Messages buffer is 256 words long.
    dsc$sys_msg_buffer_size = 256 * 8;

  TYPE
    { A system message header is placed on the System Message buffer
    { before each message placed on the buffer.  The header describes
    { the following message.

    dst$system_message_header = record
      size_name: string (4),
      message_size: 0 .. 0ffffffff(16),
      type_name: string (4),
      message_type: dst$system_logging_types,
      level_name: string (4),
      message_level: dst$system_message_levels,
    recend,

    { The following type declaration contains the pointers to
    { the system message buffer.

    dst$sys_msg_buffer_ptrs = record
      add_data_seq_p: ^SEQ ( * ),
      remove_data_seq_p: ^SEQ ( * ),
    recend,

    { The following type declaration describes various
    { parts of the system message buffer.

    dst$sys_msg_buffer_desc = record
      cm_start_of_buffer_p: ^SEQ ( * ),
      boot_start_of_buffer_p: REL (SEQ ( * )) ^SEQ ( * ),
      add_data_ptr_offset: integer,
      remove_data_ptr_offset: integer,
      sys_msg_buffer_size: integer,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc dst$system_logging_types
*copyc dst$system_message_levels
?? POP ??
*DECK DECK=DST$VCU_CDA_DATA EXPAND=FALSE

  { This type declaration fits in a CTI sector it must not become larger then a CTI
  { sector (360(8) 16-bit pp words OR 480 8-bit bytes).

  CONST

    { Define the mask used to encrypt the password.

    dsc$vcu_password_mask = 2c(16),

    { Define valid version numbers for dst$vcu_cda_version.

    dsc$vcu_131_or_earlier_system = 0,
    dsc$vcu_142_or_earlier_system = 1,
    dsc$vcu_153_or_earlier_system = 2,
    dsc$vcu_post_153_system = 3;

  TYPE
    dst$vcu_access_type = (dsc$vcu_read_access, dsc$vcu_write_access),

    dst$vcu_bucket_contents = RECORD
      backward_compatibility: boolean,  { To preserve backward compatibility, this field must be FALSE.
      specified: boolean,
      iou_number: dst$iou_number,
      channel: cmt$physical_channel,
      equipment_id: cmt$product_identification,
      equipment_number: 0 .. 0ffff(16),
      unit_id: cmt$product_identification,
      unit_number: 0 .. 0ffff(16),
      dcfile_identifier: dst$dcfile_identifier,  { Only valid in the deadstart device.
      rfu: ARRAY [1 .. 35] OF cell,
    RECEND,

    dst$vcu_bucket_data = ARRAY [dst$vcu_bucket_types] OF ARRAY [cmt$system_device_types]
          OF dst$vcu_bucket_contents,

    dst$vcu_bucket_types = (dsc$vcu_bt_disk_bucket, dsc$vcu_bt_cr_bucket, dsc$vcu_bt_tape_bucket),

    dst$vcu_cda_data = RECORD
      bucket_data: dst$vcu_bucket_data,
      time_zone_data: dst$vcu_time_zone_data,
      bucket_used: dst$vcu_bucket_types,
      password_data: dst$vcu_password_data,
      rfu: ARRAY [1 .. 16] OF cell,
      version: dst$vcu_cda_version,
    RECEND,

    dst$vcu_cda_version = 0 .. 0ff(16),

    dst$vcu_data_accessed = (dsc$vcu_bucket_data, dsc$vcu_time_zone_data, dsc$vcu_bucket_used,
          dsc$vcu_password_data, dsc$vcu_version),

    dst$vcu_encrypted_password = ARRAY [1 .. 7] OF 0 .. 0ff(16),

    dst$vcu_password_data = PACKED RECORD
      password_initialized: boolean,
      interval_initialized: boolean,
      interval_expired: boolean,
      lock_main_window: boolean,
      unsed_boolean_5: boolean,
      unsed_boolean_6: boolean,
      unsed_boolean_7: boolean,
      unsed_boolean_8: boolean,
      encrypted_password: dst$vcu_encrypted_password,
      saved_current_frc: integer,
      expiration_frc: integer,
    RECEND,

    dst$vcu_time_zone_data = RECORD
      initialized: boolean,
      time_zone: ost$time_zone,
    RECEND;

*copyc cmt$physical_channel
*copyc cmt$product_identification
*copyc cmt$system_device_types
*copyc dst$dcfile_identifier
*copyc dst$iou_number
*copyc ost$time_zone
*DECK DECK=DSV$ACTUAL_DEADSTART_PHASE EXPAND=FALSE

  VAR
    dsv$actual_deadstart_phase: [XREF] ost$deadstart_phase;

?? PUSH (LISTEXT := ON) ??
*copyc ost$deadstart_phase
?? POP ??
*DECK DECK=DSV$AUTOMATIC_PP_RELOAD EXPAND=FALSE

  VAR
    dsv$automatic_pp_reload: [XREF] dst$automatic_pp_reload;

?? PUSH (LISTEXT := ON) ??
*copyc dst$automatic_pp_reload
?? POP ??
*DECK DECK=DSV$AUTOMATIC_SYSTEM_RESTART EXPAND=FALSE

  VAR
    dsv$automatic_system_restart: [XREF] boolean;
*DECK DECK=DSV$BOOT_CONTROL_TABLE_P EXPAND=FALSE

  VAR
    dsv$boot_control_table_p: [XREF] ^dst$boot_control_table;

?? PUSH (LISTEXT := ON) ??
*copyc dst$boot_control_table
?? POP ??
*DECK DECK=DSV$BOOT_DATA_BASE_P EXPAND=FALSE

  VAR
    dsv$boot_data_base_p: [XREF] ^SEQ ( * );
*DECK DECK=DSV$CIP_PATH EXPAND=FALSE

  VAR
    dsv$cip_path: [XREF] dst$device_path;

?? PUSH (LISTEXT := ON) ??
*copyc dst$device_path
?? POP ??
*DECK DECK=DSV$CPU_PP_COMMUNICATION_BLOCK EXPAND=FALSE

  VAR
    dsv$cpu_pp_communication_block: [XREF] dst$cpu_pp_communication_block;

?? PUSH (LISTEXT := ON) ??
*copyc dst$cpu_pp_communication_block
?? POP ??

*DECK DECK=DSV$DCFILE_IDENTIFIER EXPAND=FALSE

  VAR
    dsv$dcfile_identifier: [XREF] dst$dcfile_identifier;

?? PUSH (LISTEXT := ON) ??
*copyc dst$dcfile_identifier
?? POP ??
*DECK DECK=DSV$DFTB_DATA EXPAND=FALSE

  VAR
    dsv$dftb_data: [XREF] dst$dftb_data_structure_info;

?? PUSH (LISTEXT := ON) ??
*copyc dst$180_dft_block
?? POP ??

*DECK DECK=DSV$DFTB_NVE_REQ_BUFFER_P EXPAND=FALSE

  VAR
    dsv$dftb_nve_req_buffer_p: [XREF] ^dst$dftb_nve_req_buffer;

?? PUSH (LISTEXT := ON) ??
*copyc dst$180_dft_block
?? POP ??
*DECK DECK=DSV$DFTB_SECDED_ID_TABLE_SIZE EXPAND=FALSE

  VAR
    dsv$dftb_secded_id_table_size: [XREF] 0 .. 0ffff(16);
*DECK DECK=DSV$DFTS_CONTROL_WORD_P EXPAND=FALSE

  VAR
    dsv$dfts_control_word_p: [XREF] ^dst$dftb_control_word;

?? PUSH (LISTEXT := ON) ??
*copyc dst$180_dft_block
?? POP ??
*DECK DECK=DSV$DISPLAY_DEADSTART_MESSAGES EXPAND=FALSE
  VAR
    dsv$display_deadstart_messages: [XREF] boolean;
*DECK DECK=DSV$IGNORE_IMAGE EXPAND=FALSE

  VAR
    dsv$ignore_image: [XREF] boolean;
*DECK DECK=DSV$MAINFRAME_TYPE EXPAND=FALSE

  VAR
    dsv$mainframe_type: [XREF] dst$mainframe_type;

?? PUSH (LISTEXT := ON) ??
*copyc dst$mainframe_type
?? POP ??
*DECK DECK=DSV$MF_ELEMENT_TABLE_P EXPAND=FALSE

  VAR
    dsv$mf_element_table_p: [XREF] ^ARRAY [1 .. *] OF dst$mf_element_table_entry;

?? PUSH (LISTEXT := ON) ??
*copyc dst$mf_element_table_entry
?? POP ??
*DECK DECK=DSV$MTR_DFT_REQUESTS EXPAND=FALSE

  VAR
    dsv$mtr_dft_requests: [XREF] dst$mtr_dft_requests;

?? PUSH (LISTEXT := ON) ??
*copyc dst$mtr_dft_requests
?? POP ??
*DECK DECK=DSV$POST_OPERATOR_ACTIONS EXPAND=FALSE
*DECK DECK=DSV$RDF_SIZE EXPAND=FALSE

  VAR
    dsv$rdf_size: [XREF] ost$halfword;

?? PUSH (LISTEXT := ON) ??
*copyc ost$halfword
?? POP ??
*DECK DECK=DSV$RECORD_ERRORS EXPAND=FALSE

  VAR
    dsv$record_errors: [XREF] boolean;
*DECK DECK=DSV$SEGNUM_SSR_SEQUENCE EXPAND=FALSE
*DECK DECK=DSV$SSR_SDTE EXPAND=FALSE

  VAR
    dsv$ssr_sdte: [XREF] mmt$segment_descriptor;

?? PUSH (LISTEXT := ON) ??
*copyc mmt$segment_descriptor_table
?? POP ??
*DECK DECK=DSV$SSR_SIZE EXPAND=FALSE

  VAR
    dsv$ssr_size: [XREF] 0 .. 0fffff(16);
*DECK DECK=DSV$SUB_MAINFRAME_TYPE EXPAND=FALSE

  VAR
    dsv$sub_mainframe_type: [XREF] dst$sub_mainframe_type;

?? PUSH (LISTEXT := ON) ??
*copyc dst$sub_mainframe_type
?? POP ??
*DECK DECK=DSV$SYSTEM_DEADSTART_STATUS_P EXPAND=FALSE

  VAR
    dsv$system_deadstart_status_p: [XREF] ^dst$ssr_system_deadstart_status;

?? PUSH (LISTEXT := ON) ??
*copyc dst$ssr_data_types
?? POP ??
*DECK DECK=DSV$SYS_MSG_BUFFER_DESC_P EXPAND=FALSE

  VAR
    dsv$sys_msg_buffer_desc_p: [XREF] ^dst$sys_msg_buffer_desc;

?? PUSH (LISTEXT := ON) ??
*copyc dst$system_message_types
?? POP ??
*DECK DECK=DSV$SYS_MSG_BUFFER_INITIALIZED EXPAND=FALSE

  VAR
    dsv$sys_msg_buffer_initialized: [XREF] boolean;
*DECK DECK=DSV$SYS_MSG_BUFFER_PTRS EXPAND=FALSE

  VAR
    dsv$sys_msg_buffer_ptrs: [XREF] dst$sys_msg_buffer_ptrs;

?? PUSH (LISTEXT := ON) ??
*copyc dst$system_message_types
?? POP ??
*DECK DECK=DSV$SYS_MSG_BUFFER_SIZE EXPAND=FALSE

  VAR
    dsv$sys_msg_buffer_size: [XREF] integer;
*DECK DECK=DSV$TURN_DFT_LOGGING_OFF EXPAND=FALSE

  VAR
    dsv$turn_dft_logging_off: [XREF] boolean;
*DECK DECK=DSV$UNLOAD_DEADSTART_TAPE EXPAND=FALSE

  VAR
    dsv$unload_deadstart_tape: [XREF] boolean;

*DECK DECK=DUC$CONDITION_LIMITS EXPAND=FALSE

  CONST
    duc$min_ecc = (($INTEGER ('D') * 100(16)) + $INTEGER ('U')) * 1000000(16),
    duc$max_ecc = duc$min_ecc + 1999;

  CONST
    duc$dump_analyzer_id = 'du';
*DECK DECK=DUC$DUMP_ANALYZER_CONSTANTS EXPAND=FALSE
                                                                                                              
  CONST                                                                                                       
    duc$maximum_memory_display = 2000000(16),                                                                 
    duc$revision_level = 1030,                                                                                
    duc$utility_name = 'NOSVE_DUMP_ANALYZER            ',                                                     
    duc$version = 'Analyze_dump  Version 2.0';                                                                
*DECK DECK=DUE$EXCEPTION_CONDITION_CODES EXPAND=FALSE
?? NEWTITLE := 'due$exception_condition_codes : ''DU'' 0 .. 1999' ??                                          
                                                                                                              
*copyc duc$condition_limits                                                                                   
                                                                                                              
  CONST                                                                                                       
                                                                                                              
    { Errors encountered during file management:  1-100                                                       
                                                                                                              
    due$file_empty = duc$min_ecc + 1,                                                                         
    {E File +F is empty.}                                                                                     
                                                                                                              
    due$dump_file_format_error = duc$min_ecc + 2,                                                             
    {W The dump file, +F, is not in an expected format. +P}                                                   
                                                                                                              
    due$unexpected_eoi = duc$min_ecc + 3,                                                                     
    {W An unexpected end of information was received on file +F while processing +P. +P}                      
                                                                                                              
    due$dump_file_io_error = duc$min_ecc + 4,                                                                 
    {W The processing of dump file, +F, is terminated due to read errors.}                                    
                                                                                                              
    due$improper_file_attributes = duc$min_ecc + 5,                                                           
    {E +F is not a +P file.}                                                                                  
                                                                                                              
    due$overwriting_wrong_file = duc$min_ecc + 6,                                                             
    {E +F already exists, but its preserved attributes do not match those of a +P file. ..                    
    {Either delete the file or choose another.}                                                               
                                                                                                              
    due$file_not_open = duc$min_ecc + 7,                                                                      
    {E File +F is not open.}                                                                                  
                                                                                                              
    due$open_file_limit = duc$min_ecc + 8,                                                                    
    {E An attempt was made to open file +F when the maximum number of files (+P) were already open.}          
                                                                                                              
    due$file_already_open = duc$min_ecc + 9,                                                                  
    {E File +F is already open.}                                                                              
                                                                                                              
    due$file_already_exists = duc$min_ecc + 10,                                                               
    {E File +F already exists.}                                                                               
                                                                                                              
    { Errors encountered during record management:  101-200                                                   
                                                                                                              
    due$no_restart_file = duc$min_ecc + 101,                                                                  
    {E This command/function requires the existence of a restart file.}                                       
                                                                                                              
    due$record_type_supported = duc$min_ecc + 102,                                                            
    {E This command/function only supports a record type of +P}                                               
                                                                                                              
    due$data_not_on_dump = duc$min_ecc + 103,                                                                 
    {E +P +P +P not on the dump file.}                                                                        
                                                                                                              
    due$register_not_defined = duc$min_ecc + 104,                                                             
    {E Register +P is not defined for element +P.}                                                            
                                                                                                              
    due$bad_buffer_controlware = duc$min_ecc + 105,                                                           
    {E The buffer controlware on the dump file is bad.}                                                       
                                                                                                              
    due$bad_report_record = duc$min_ecc + 106,                                                                
    {E The record contains an invalid report.}                                                                
                                                                                                              
    { Errors encountered during memory access:  201-300                                                       
                                                                                                              
    due$address_translation_error = duc$min_ecc + 201,                                                        
    {E The requested virtual address translation is not possible: +P+P +P+P +P}                               
                                                                                                              
    due$invalid_sf_pointer = duc$min_ecc + 202,                                                               
    {W The pointer to this frame is invalid+P +P+P +P}                                                        
                                                                                                              
    due$rma_and_exc_specified = duc$min_ecc + 203,                                                            
    {E The exchange parameter cannot be specified if address mode is real_memory_address.}                    
                                                                                                              
    due$incomplete_memory_display = duc$min_ecc + 204,                                                        
    {W Not all memory requested was displayed: +P}                                                            
                                                                                                              
    due$memory_display_overflow = duc$min_ecc + 205,                                                          
    {E The maximum number of bytes that can be displayed at one time is +P. You requested +P.}                
                                                                                                              
    due$processor_in_170_mode = duc$min_ecc + 206,                                                            
    {I The selected exchange package represents a process in Cyber 170 mode.}                                 
                                                                                                              
    due$soft_page_fault = duc$min_ecc + 207,                                                                  
    {W Invalid page descriptor+P +P+P +P}                                                                     
                                                                                                              
    due$invalid_seg_trans_poss = duc$min_ecc + 208,                                                           
    {W The PVA was translated with an invalid segment descriptor table entry.}                                
                                                                                                              
    due$pages_skipped = duc$min_ecc + 209,                                                                    
    {W Virtual memory from offset +P to +P is paged out.}                                                     
                                                                                                              
    due$page_fault_error_severity = duc$min_ecc + 210,                                                        
    {E A page fault was encountered+P +P+P +P}                                                                
                                                                                                              
    due$invalid_mask = duc$min_ecc + 211,                                                                     
    {E The value entered for +P: +P is not a valid mask setting.}                                             
                                                                                                              
    due$invalid_stack_frame = duc$min_ecc + 212,                                                              
    {W This frame has been overwritten.+P}                                                                    
                                                                                                              
    due$incomplete_memory_copy = duc$min_ecc + 213,                                                           
    {W Not all memory requested was copied: +P}                                                               
                                                                                                              
    due$no_memory_displayed = duc$min_ecc + 214,                                                              
    {W No memory was displayed: +P}                                                                           
                                                                                                              
    due$no_memory_copied = duc$min_ecc + 215,                                                                 
    {W No memory was copied: +P}                                                                              
                                                                                                              
    due$invalid_offset = duc$min_ecc + 216,                                                                   
    {E The specified offset is out of range.}                                                                 
                                                                                                              
    due$memory_out_of_bounds = duc$min_ecc + 217,                                                             
    {E Specified memory is out of bounds of available memory.}                                                
                                                                                                              
    due$memory_not_critical = duc$min_ecc + 218,                                                              
    {E Specified address not dumped as critical memory.}                                                      
                                                                                                              
    due$memory_partially_avail = duc$min_ecc + 219,                                                           
    {E Specified memory is only partially available.}                                                         
                                                                                                              
    { Miscellaneous errors:  301-400                                                                          
                                                                                                              
    due$nil_pointer = duc$min_ecc + 301,                                                                      
    {E Internal error - NIL pointer received.}                                                                
                                                                                                              
    due$revision_level_mismatch = duc$min_ecc + 302,                                                          
    {E Revision level of restart file does not match level of dump analyzer.}                                 
                                                                                                              
    due$invalid_address = duc$min_ecc + 303,                                                                  
    {E Address +P is not on the dump file.}                                                                   
                                                                                                              
    due$unknown_iou_model = duc$min_ecc + 304,                                                                
    {E Unable to read PP - unknown IOU model.}                                                                
                                                                                                              
    due$symbol_not_found = duc$min_ecc + 305,                                                                 
    {E +P was not found.}                                                                                     
                                                                                                              
    due$debug_table_not_avail = duc$min_ecc + 306,                                                            
    {E No debug table is available.}                                                                          
                                                                                                              
    due$no_entry_for_address = duc$min_ecc + 307,                                                             
    {E No debug table entry was found for address +P.}                                                        
                                                                                                              
    due$skipped_lines = duc$min_ecc + 308,                                                                    
    {I +P duplicate lines are suppressed.}                                                                    
                                                                                                              
    due$display_terminated = duc$min_ecc + 309,                                                               
    {I Display terminated: +P +P +P}                                                                          
                                                                                                              
    due$beginning_of_log_not_found = duc$min_ecc + 310;                                                       
    {E Beginning of the log entry cannot be found, command aborted. }                                         
?? OLDTITLE ??                                                                                                
*DECK DECK=DUE$SYMBOLIC_ACCESS_EXCEPTIONS EXPAND=FALSE
?? FMT (FORMAT := OFF) ??
?? NEWTITLE := 'due$symbolic_access_exceptions : ''DU'' 2000 .. 2199' ??
?? EJECT ??

  CONST
    duc$first_exception = (($INTEGER('D')*100(16))+$INTEGER('U'))*1000000(16),
    duc$symbolic_id = 'DU',
    duc$symbolic_access_exception = duc$first_exception + 2000;

  CONST
    due$all_not_implemented         = duc$symbolic_access_exception + 0,
    {I $ALL is not a valid parameter value when module generator is +P.}

    due$cant_display_as_integer     = duc$symbolic_access_exception + 1,
    {E Variables must be from one to eight bytes long to be displayed as integers.}

    due$cant_display_as_real        = duc$symbolic_access_exception + 2,
    {E Variables must be eight bytes long to be displayed as reals.}

    due$c_unbalanced_parens         = duc$symbolic_access_exception + 3,
    {E Unbalanced parentheses were detected.}

    due$display_all_names_hdr1      = duc$symbolic_access_exception + 4,
    {I DISPLAY OF ALL VARIABLES IN +P}

    due$display_all_names_hdr2      = duc$symbolic_access_exception + 5,
    {I +P is not active. Only static variables can be displayed.}

    due$display_all_names_hdr3      = duc$symbolic_access_exception + 6,
    {I DISPLAY OF ALL MODULE LEVEL VARIABLES IN +P}

    due$errors_in_list_of_names     = duc$symbolic_access_exception + 7,
    {E Errors encountered in display_program_value list of names.}

    due$expecting_variable_name     = duc$symbolic_access_exception + 8,
    {E The Name parameter does not contain a variable identifier.}

    due$field_not_found             = duc$symbolic_access_exception + 9,
    {E +P is not a field of the current record.}

    due$formatted_status_is         = duc$symbolic_access_exception + 10,
    {I The formatted status message is:}

    due$function_not_active         = duc$symbolic_access_exception + 11,
    {E Function +P is not active.}

    due$illegal_parameter_value     = duc$symbolic_access_exception + 12,
    {E +P is not legal for the +P parameter.}

    due$illegal_reg_num_for_p       = duc$symbolic_access_exception + 13,
    {E The REGISTER_NUMBER parameter is illegal for REGISTER_TYPE = P.}

    due$improper_address            = duc$symbolic_access_exception + 14,
    {E "+P" is not a properly formed address.}

    due$internal_error        = duc$symbolic_access_exception + 15,
    {E +P}

    due$invalid_boolean_value       = duc$symbolic_access_exception + 16,
    {E Variable +P contains an invalid boolean value.}

    due$invalid_data_type_for_func  = duc$symbolic_access_exception + 17,
    {E Variable +P is not a basic type and cannot be returned as a function value.}

    due$invalid_name_identifier     = duc$symbolic_access_exception + 18,
    {E The NAME parameter contains an invalid identifier.}

    due$invalid_name_parameter      = duc$symbolic_access_exception + 19,
    {E An invalid NAME parameter was specified.}

    due$invalid_ordinal_value       = duc$symbolic_access_exception + 20,
    {E Variable +P contains an invalid ordinal value.}

    due$invalid_parameter           = duc$symbolic_access_exception + 21,
    {E The parameter +P is not legal for this language.}

    due$invalid_pointer_reference   = duc$symbolic_access_exception + 22,
    {E A pointer dereference is not allowed for +P.}

    due$invalid_pointer_value       = duc$symbolic_access_exception + 23,
    {E +P has an invalid pointer value.}

    due$invalid_procedure           = duc$symbolic_access_exception + 24,
    {E Procedure +P does not exist.}

    due$invalid_subscript_reference = duc$symbolic_access_exception + 25,
    {E A subscript is not allowed for +P.}

    due$invalid_substring           = duc$symbolic_access_exception + 26,
    {E The substring reference is incorrectly formatted.}

    due$invalid_substring_length    = duc$symbolic_access_exception + 27,
    {E The length of substring of +P is incorrectly specified.}

    due$invalid_token_in_variable   = duc$symbolic_access_exception + 28,
    {E +P is not valid in an identifier.}

    due$invalid_type_for_subscript  = duc$symbolic_access_exception + 29,
    {E The subscript for array +P is not the right type.}

    due$in_prolog_code              = duc$symbolic_access_exception + 30,
    {I Unable to access +P.  The current stack frame is not yet initialized.}

    due$label_not_found             = duc$symbolic_access_exception + 31,
    {E Statement label +P was not found.}

    due$line_number_not_found       = duc$symbolic_access_exception + 32,
    {E The line number +P was not found.}

    due$list_not_allowed            = duc$symbolic_access_exception + 33,
    {E A list of values is not allowed for the VALUE parameter in this context.}

    due$named_entry_point_not_found = duc$symbolic_access_exception + 34,
    {E Entry point +P was not found.}

    due$named_module_not_found      = duc$symbolic_access_exception + 35,
    {E Module +P was not found.}

    due$name_parameter_missing      = duc$symbolic_access_exception + 36,
    {E The NAME parameter is required.}

    due$name_parameter_too_long     = duc$symbolic_access_exception + 37,
    {E The value entered for the NAME parameter exceeded the allowed maximum of +P.}

    due$not_valid_field_name        = duc$symbolic_access_exception + 38,
    {E +P is not a valid record field name.}

    due$no_line_numbers_in_module   = duc$symbolic_access_exception + 39,
    {E Line numbers are not available.}

    due$no_symbol_table_in_module   = duc$symbolic_access_exception + 40,
    {I No symbol table exists for module +P.}

    due$no_trap_has_occurred        = duc$symbolic_access_exception + 41,
    {E No trap has occurred.}

    due$no_vars_found               = duc$symbolic_access_exception + 42,
    {I No variables found.}

    due$only_records_have_fields    = duc$symbolic_access_exception + 43,
    {E Field specification is not allowed for +P.}

    due$parameter_value_too_long    = duc$symbolic_access_exception + 44,
    {E Parameter value +P exceeds 31 characters.}

    due$parms_only_message          = duc$symbolic_access_exception + 45,
    {I +P}

    due$procedure_not_active        = duc$symbolic_access_exception + 46,
    {E Procedure +P is not active.}

    due$proc_must_be_specd          = duc$symbolic_access_exception + 47,
    {E There are no active procedures in module +P.  The PROCEDURE parameter is also needed.}

    due$proc_not_in_module          = duc$symbolic_access_exception + 48,
    {E Procedure +P is not in module +P.}

    due$pva_not_in_any_module       = duc$symbolic_access_exception + 49,
    {E The current pva was not found in the module table.  Re-enter the command specifying
    { the module parameter.}

    due$pva_not_in_known_proc       = duc$symbolic_access_exception + 50,
    {E The specified address is not in an active procedure.}

    due$pva_not_in_section          = duc$symbolic_access_exception + 51,
    {E The specified address is not in the specified section.}

    due$pva_not_line_number         = duc$symbolic_access_exception + 52,
    {E The specified address is not a line number.}

    due$recursion_not_supported     = duc$symbolic_access_exception + 53,
    {E +P does not support recursion.}

    due$reg_not_in_stack            = duc$symbolic_access_exception + 54,
    {E The requested register is not in the stack.}

    due$scl_string_variable_reqd    = duc$symbolic_access_exception + 55,
    {E +P is not an SCL string variable.}

    due$scl_variable_expected       = duc$symbolic_access_exception + 56,
    {E +P is not an SCL variable name.}

    due$specd_section_not_in_module = duc$symbolic_access_exception + 57,
    {E Section +P is not in the specified module.}

    due$statement_number_not_found  = duc$symbolic_access_exception + 58,
    {E The specified line does not contain statement +P.}

    due$subscript_error             = duc$symbolic_access_exception + 59,
    {E Subscript syntax error was detected while scanning variable +P.}

    due$subscript_out_of_range      = duc$symbolic_access_exception + 60,
    {E The subscript is out of range for array +P.}

    due$substring_illegal           = duc$symbolic_access_exception + 61,
    {E +P is not a string.  The requested substring reference is illegal.}

    due$substring_length_range_err  = duc$symbolic_access_exception + 62,
    {E The specified length of the substring for +P is out of bounds.}

    due$substring_start_is_int      = duc$symbolic_access_exception + 63,
    {E The substring start specifier for +P must be a positive integer.}

    due$substring_start_range_err   = duc$symbolic_access_exception + 64,
    {E The specified start of the substring for +P is out of bounds.}

    due$symbol_number_not_found     = duc$symbolic_access_exception + 65,
    {E Corresponding symbol number in the symbol table could not be found.}

    due$symbol_table_not_available  = duc$symbolic_access_exception + 66,
    {E No symbol table is available for the module.}

    due$target_sf_number_too_big    = duc$symbolic_access_exception + 67,
    {E The specified stack frame was not found.}

    due$too_many_bytes_for_int      = duc$symbolic_access_exception + 68,
    {E For integers, the maximum number of bytes is eight.}

    due$type_equals_hex_only        = duc$symbolic_access_exception + 69,
    {E HEX is the only legal value of the TYPE parameter in +P.}

    due$unaligned_pointer           = duc$symbolic_access_exception + 70,
    {E Variable +P is an unaligned pointer.}

    due$unaligned_real              = duc$symbolic_access_exception + 71,
    {E Variable +P is an unaligned real number.}

    due$unaligned_string            = duc$symbolic_access_exception + 72,
    {E Variable +P is an unaligned string.}

    due$value_out_of_range          = duc$symbolic_access_exception + 73,
    {E The new value is out of range for variable +P.}

    due$value_parm_too_long         = duc$symbolic_access_exception + 74,
    {E The value entered for the VALUE parameter is too long.}

    due$variable_not_accessible     = duc$symbolic_access_exception + 75,
    {E Identifier +P is not active.}

    due$variable_not_found          = duc$symbolic_access_exception + 76,
    {E Identifier +P was not found.}

    due$unbalanced_macro_parens     = duc$symbolic_access_exception + 77,
    {E Unbalanced parenthesis in a macro.}

    due$unbalanced_function_parens  = duc$symbolic_access_exception + 78,
    {E Unbalanced parenthesis for the +P function.}

    due$unsupported_type            = duc$symbolic_access_exception + 79,
    {E Type +P is unsupported.}

    due$unsupported_subscript_type  = duc$symbolic_access_exception + 80,
    {E Unsupported subscript type.}

    due$lowerbound_non_array        = duc$symbolic_access_exception + 81,
    {E The LOWERBOUND function is valid only for arrays.}

    due$upperbound_non_array        = duc$symbolic_access_exception + 82,
    {E The UPPERBOUND function is valid only for arrays.}

    due$lowerbound_mismatch         = duc$symbolic_access_exception + 83,
    {E Lowerbound mismatch, expect +P found +P.}

    due$upperbound_mismatch         = duc$symbolic_access_exception + 84,
    {E Upperbound mismatch, expect +P found +P.}

    due$lowervalue_non_scalar       = duc$symbolic_access_exception + 85,
    {E The LOWERVALUE function is valid only for scalars.}

    due$uppervalue_non_scalar       = duc$symbolic_access_exception + 86,
    {E The UPPERVALUE function is valid only for scalars.}

    due$invalid_address_constructor = duc$symbolic_access_exception + 87,
    {E The address construction operator is not allowed with a function.}

    due$missing_function_parameters = duc$symbolic_access_exception + 88,
    {E Missing parameter(s) for the +P function.}

    due$invalid_function_nesting    = duc$symbolic_access_exception + 89,
    {E Nested functions are not allowed.}

    due$expression_end_expected     = duc$symbolic_access_exception + 90,
    {E Expecting end of expression, found "+P".}

    due$unsupported_language        = duc$symbolic_access_exception + 91,
    {E The +P programming language is not supported.}

    due$c_empty_expression          = duc$symbolic_access_exception + 92,
    {E The empty expression () is not allowed.}

    due$c_illegal_address_op        = duc$symbolic_access_exception + 93,
    {E The address operator is illegal for the expression "+P".}

    due$c_illegal_ptr_construction  = duc$symbolic_access_exception + 94,
    {E The & character must be first and only appear once.}

    due$c_must_be_pointer           = duc$symbolic_access_exception + 95,
    {E +P is not a pointer.  Pointer arithmetic is legal only for pointers and arrays.}

    due$c_ptr_mod_range_err         = duc$symbolic_access_exception + 96,
    {E A pointer arithmetic overflow was detected.}

    due$c_wrong_type_for_ptr_mod    = duc$symbolic_access_exception + 97;
    {E +P is not an integer, the only valid type for arithmetic with pointers.}

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=DUH$CLOSE_DISPLAY EXPAND=FALSE
{
{ Procedure DUP$CLOSE_DISPLAY is the central interface for closing DEBUG output
{ files.
{
{ DUP$CLOSE_DISPLAY (VAR display_control_pointer: ^clt$display_control; close_
{      default_file: boolean; VAR status)
{
{ display_control_pointer - points to the display control block describing
{      the file which the user would like closed
{
{ close_default_file - this specifies an override (when true) that prevents the
{      default output file from ever being closed
{
{ status - standard status variable
{
*DECK DECK=DUH$DISPLAY_ALL_NAMES EXPAND=FALSE
{
{This procedure is the inteface procedure to display all the variable
{names in a procedure, regardless of the language.  It was designed to be
{called by dup$display_variable, but could be called by any procedure that
{can generate the appropriate calling sequence.  This procedure calls
{subordinate procedures that are specific to each language to determine
{what variables qualify for $ALL for a particular language.  This procedure
{performs the central service of outputting display headers.
{
{Calling sequence:
{
{     home_spec: dut$home_specification (input) This procedure expects the
{        language field to be meaningful, as well as the procedure_entry field
{        Subordinate procedures may expect other fields to be valid
{
{     display_type: dut$display_type (input) This parameter specifies the
{        format in which the variables are to be displayed.
{
{     p_variant_selection: ^clt$data_value (input) This parameter specifies
{        a list of variant selections (possibly NIL) for use in fixing tagless
{        variant records.
{
{     display_control_pointer: ^clt$display_control (input,output) This
{       is a pointer to the display control block for the output file to
{       which the display is to be directed
{
{     status: ost$status (output) Status variable
{       due$all_not_implemented - Debug cannot support displaying all
{         variables in a procedure written in this language
{       due$internal_error - Covers unanticipated situations in the
{         code
{       Status variables set by subordinate procedures are not altered, but
{         are passed along
{

*DECK DECK=DUH$FIND_MODULE_TABLE_FOR_PVA EXPAND=FALSE
{
{  dup$find_module_table_for_pva searches the module address table for
{  a module the contains a specified pva.
{
{  DUP$FIND_MODULE_TABLE_FOR_PVA (PVA, MODULE, INDEX, STATUS)
{
{  PVA : (input)     is the pva for which the module address table
{                    is to be searched.
{
{  MODULE : (output) is a pointer to the module address table
{                    item (if one is found).
{
{  INDEX : (output)  is the index of the section definition record
{                    within the array of section definition records
{                    containing the pva.
{
{  STATUS : (output) is the request status. Possible value(s):
{                      due$pva_not_in_any_module
{
*DECK DECK=DUH$FIND_PROCEDURE_FOR_PVA EXPAND=FALSE
{
{  dup$find_procedure_for_pva locates the procedure which contatins the
{  specified pva.  This can be determined by the symbol table address
{  and the symbol index returned to the caller.
{
{  DUP$FIND_PROCEDURE_FOR_PVA (MODULE, SECTION_INDEX, PVA, SYMBOL,
{      SYMBOL_INDEX, STATUS)
{
{  MODULE : (input)     is the module address table item in which the
{                       pva is located.
{
{  SECTION_INDEX : (input)  is the index of the section definition record
{                       within the array of section definition records
{                       containing the pva.
{
{  PVA : (input)        is the pva for which the symbol table is to be
{                       searched.
{
{  SYMBOL : (output)    is the pointer to the debug symbol table entry.
{
{  SYMBOL_INDEX : (output)  is the index of the symbol table entry.
{
{  STATUS : (output)    is the status of the request. Possible value(s):
{                         due$no_symbol_table_in_module
{                         due$pva_not_in_known_proc
{
*DECK DECK=DUH$LOCATE_NEXT_SYMBOL EXPAND=FALSE
{
{  dup$locate_next_symbol locates the next symbol table entry (if the
{  symbol table exists).
{
{  DUP$LOCATE_NEXT_SYMBOL (SYMBOL_ADDRESS, SYMBOL_ENTRY, STATUS)
{
{  SYMBOL_ADDRESS : (input)    is a pointer to the debug symbol table.
{
{  SYMBOL_ENTRY : (input,output)  is a pointer to the current symbol
{                              table entry on input, and is a pointer
{                              to the next symbol table entry on output.
{                              The value returned = NIL if there are no
{                              more entries.
{
{  STATUS : (output)           is the status of the request. Possible value(s):
{                                due$no_symbol_table_in_module
{
*DECK DECK=DUH$LOCATE_SYMBOL_FOR_NUMBER EXPAND=FALSE
{
{  dup$locate_symbol_for_number searches the symbol table for the
{  specified symbol number.
{
{  DUP$LOCATE_SYMBOL_FOR_NUMBER (SYMBOL_ADDRESS, SYMBOL_NUMBER,
{      SYMBOL_ENTRY, STATUS)
{
{  SYMBOL_ADDRESS : (input)   is a pointer to the debug symbol table.
{
{  SYMBOL_NUMBER : (input)    is the symbol number to locate in the
{                             debug symbol table.
{
{  SYMBOL_ENTRY : (output)    is the symbol table entry corresponding
{                             to the specified symbol number.
{
{  STATUS : (output)          is the status of the request. Possible value(s):
{                               due$no_symbol_table_in_module
{                               due$symbol_number_not_found
{
*DECK DECK=DUH$MOVE_BYTES EXPAND=FALSE
{
{    The purpose of this request is to move a block of memory from one location
{  to another.  A ring number based on validation privileges is used in the
{  source address rather than the ring number provided.  This allows some users
{  to read memory segments while other users are not allowed to read them.
{
{    Users with the "read_system_memory" validation capability and those
{  running with system administrator capability are given a source ring number
{  such that they can read system memory segments.  Other users are given a
{  source ring number equal to their "minimum_ring" validation privilege so
{  that they may read segments down to that ring.
{
{    No special ring privilege is given for the destination address.  Therefore
{  the destination must be writable by the caller of this interface.
{
{    Any segment access conditions that occur as a result of the memory move
{  are converted to a status and returned in the status parameter.
{
{       DUP$MOVE_BYTES (SOURCE, DESTINATION, LENGTH, STATUS)
{
{ SOURCE: (input) This parameter specifies the source address of the block of
{       memory to be moved.  As explained above, a ring number different than
{       the one specified is actually used to read the source block.
{
{ DESTINATION: (input, indirectly output) This parameter specifies the
{       destination address of the block of memory to be moved.
{
{ LENGTH: (input) This parameter specifies the length of the block of memory to
{       be moved.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS:
{             ame$input_after_eoi
{             pme$system_condition
{

*DECK DECK=DUH$OPEN_DISPLAY EXPAND=FALSE
{
{ Procedure DUP$OPEN_DISPLAY is the central interface in DEBUG for opening
{ output files.
{
{ DUP$OPEN_DISPLAY (file_name: fst$file_reference;
{      VAR display_control_pointer: ^clt$display_control;
{      VAR status: ost$status)
{
{ file_name - the file to which the users output is destined
{
{ display_control_pointer - a pointer to a record where NOSVE stores information
{      about the file for this instance of open
{
{ status - conventional status variable
{
{ If the filename is that of the current default DEBUG output file, the users
{ display_control_pointer is modified to point to the display_control record
{ owned by this procedure which describes the default DEBUG output file.
{ DUP$OPEN_DISPLAY will return a bad status if an open is unsuccessful.
{
*DECK DECK=DUH$OUTPUT_MESSAGE EXPAND=FALSE
{
{ Procedure DUP$OUTPUT_MESSAGE takes the text sent to it and outputs it to the
{ the file specified,
{
{     DUP$OUTPUT_MESSAGE (status_message: ost$status; VAR display_control_
{       pointer, ^clt$display_control, status: ost$status)
{
{  STATUS_MESSAGE - This record contains the parameters that the OS will use
{    to fill in the message template
{
{  DISPLAY_CONTROL_POINTER - This points to a record of type display_control
{    which describes the file to whch output will be directed
{
{  STATUS - This is the standard status record for returning any errors
{
{ Procedure DUP$OUTPUT_MESSAGE uses the OS to formulate the message.  Message
{ level of brief is used and maximum message length is set to the page width in
{ the display control record.  Any bad status returned by CLP$PUT_PARTIAL will{ cause output to stop (It could
{ to the caller.
*DECK DECK=DUM$ANAD_COMMANDS EXPAND=TRUE
table n=duv$anad_commands t=command s=xdcl m=dum$anad_commands                                                
command n=(add_debug_tables, add_debug_table, adddt) p=dup$add_debug_tables cm=xref                           
command n=(change_default, chad) p=dup$change_default_command cm=xref                                         
command n=(change_default_module, chadm) p=dup$change_default_module cm=xref                                  
command n=(change_default_procedure, chadp) p=dup$change_default_procedure cm=xref                            
command n=(change_processor_register, change_processor_registers, chapr) p=dup$change_pr_command cm=xref      
command n=(compare_control_store, comcs) p=dup$compare_control_store cm=xref                                  
command n=(copy_buffer_controlware, copbc) p=dup$copy_buffer_controlware cm=xref                              
command n=(copy_control_store, copcs) p=dup$copy_control_store cm=xref                                        
command n=(copy_memory, copm) p=dup$copy_memory_command cm=xref                                               
command n=(copy_pp_memory, coppm) p=dup$copy_pp_memory_command cm=xref                                        
command n=(decode) p=dup$decode_command cm=xref                                                               
command n=(display_all_record_names, disarn, display_record_list, disrl, display_dump_record_list, disdrl) .. 
      p=dup$display_all_record_names cm=xref                                                                  
command n=(display_alternate_iou_config, disaic) p=dup$display_alternate_iou_conf cm=xref                     
command n=(display_alternate_iou_ec, disaie) p=dup$display_alternate_iou_ec cm=xref                           
command n=(display_b_and_c_registers, disbacr) p=dup$display_b_and_c_registers cm=xref                        
command n=(display_buffer_controlware, disbc) p=dup$display_buffer_controlware cm=xref                        
command n=(display_call, display_calls, disc) p=dup$display_call_command cm=xref                              
command n=(display_channel_status_flags, discsf, display_channel_conditions, discc) ..                        
        p=dup$display_csf_command cm=xref                                                                     
command n=(display_cio_registers, discr) p=dup$display_cio_regs_command cm=xref                               
command n=(display_control_store, discs) p=dup$display_control_store cm=xref                                  
command n=(display_cti_level, disctil) p=dup$display_cti_level_command cm=xref                                
command n=(display_defaults, disd) p=dup$display_defaults cm=xref                                             
command n=(display_dual_state_buffer, disdsb) p=dup$display_dsb_command cm=xref                               
command n=(display_dump_information, display_dump_info, disdi) p=dup$display_dump_info_command cm=xref        
command n=(display_dump_record, disdr) p=dup$display_dr_command cm=xref                                       
command n=(display_environment_control, disec) p=dup$display_environment_control cm=xref                      
command n=(display_exchange_package, disep) p=dup$display_exchange_pkg_cmd cm=xref                            
command n=(display_fault_status_mask, disfsm) p=dup$display_fault_status_mask cm=xref                         
command n=(display_line_number, disln) p=dup$display_line_number cm=xref                                      
command n=(display_mac_soft_registers, dismsr) p=dup$display_mac_soft_registers cm=xref                       
command n=(display_maintenance_registers, display_maintenance_register, dismr) ..                             
        p=dup$display_maintenance_reg cm=xref                                                                 
command n=(display_memory, dism) p=dup$display_memory_command cm=xref                                         
command n=(display_mrt_data, dismd) p=dup$display_mrt_data_command cm=xref                                    
command n=(display_pc_console_information, dispci) p=dup$display_pc_console_info cm=xref                      
command n=(display_pp_memory, dispm) p=dup$display_pp_memory_command cm=xref                                  
command n=(display_pp_registers, dispr) p=dup$display_pp_regs_command cm=xref                                 
command n=(display_program_value, dispv) p=dup$display_variable cm=xref                                       
command n=(display_register_file, disrf) p=dup$display_reg_file_cmd cm=xref                                   
command n=(display_report_record, disrr) p=dup$display_report_record cm=xref                                  
command n=(display_s0_pp_memory, disspm) p=dup$display_s0_pp_memory cm=xref                                   
command n=(display_s0_register_file, dissrf) p=dup$display_s0_register_file cm=xref                           
command n=(process_dft_buffer, prodb) p=dup$process_dft_buffer_command cm=xref                                
command n=(quit, qui) p=dup$quit_command cm=xref                                                              
tablend                                                                                                       
*DECK DECK=DUM$ANAD_FUNCTIONS EXPAND=TRUE
table n=duv$anad_functions t=function s=xdcl m=dum$anad_functions                                             
function n=($analyze_dump_output, $ado) p=dup$$analyze_dump_output cm=xref                                    
function n=($analyze_dump_title, $adt) p=dup$$analyze_dump_title cm=xref                                      
function n=($available, $avail) p=dup$$available cm=xref                                                      
function n=($bit) p=dup$$bit_function cm=xref                                                                 
function n=($buffer_controlware, $bc) p=dup$$buffer_controlware cm=xref                                       
function n=($buffer_controlware_string, $bcs) p=dup$$buffer_controlware_string cm=xref                        
function n=($channel_available, $ca) p=dup$$channel_available cm=xref                                         
function n=($control_store, $cs) p=dup$$control_store cm=xref                                                 
function n=($control_store_byte, $csb) p=dup$$control_store_byte cm=xref                                      
function n=($convert_unique_name, $conun, $cun) p=dup$convert_unique_name cm=xref                             
function n=($default_module, $dm) p=dup$default_module_function cm=xref                                       
function n=($default_procedure, $dp) p=dup$default_procedure_function cm=xref                                 
function n=($dump_record, $dr) p=dup$$dump_record cm=xref                                                     
function n=($dump_record_available, $dump_record_avail, $dra) p=dup$$dump_record_available cm=xref            
function n=($dump_record_length, $drl) p=dup$$dump_record_length cm=xref                                      
function n=($dump_record_type, $drt) p=dup$$dump_record_type cm=xref                                          
function n=($maintenance_register, $mr) p=dup$$maintenance_register cm=xref                                   
function n=($memory, $mem) p=dup$$memory cm=xref                                                              
function n=($memory_string, $ms) p=dup$$memory_string cm=xref                                                 
function n=($module) p=dup$$module_function cm=xref                                                           
function n=($nil_pva, $np) p=dup$$nil_pva_function cm=xref                                                    
function n=($offset, $off) p=dup$$offset_function cm=xref                                                     
function n=($pp_available, $ppa) p=dup$$pp_available cm=xref                                                  
function n=($pp_memory, $pm) p=dup$$pp_memory cm=xref                                                         
function n=($process_register, $pr) p=dup$$process_register cm=xref                                           
function n=($program_value, $pv) p=dup$program_value cm=xref                                                  
function n=($real_memory_address, $rma) p=dup$$real_memory_address cm=xref                                    
function n=($register_file, $rf) p=dup$$register_file cm=xref                                                 
function n=($register_file_string, $rfs) p=dup$$register_file_string cm=xref                                  
function n=($ring) p=dup$$ring_function cm=xref                                                               
function n=($section, $sec) p=dup$$section_function cm=xref                                                   
function n=($segment, $seg) p=dup$$segment_function cm=xref                                                   
function n=($size_buffer_controlware, $sbc) p=dup$$size_buffer_controlware cm=xref                            
function n=($size_control_store, $scs) p=dup$$size_control_store cm=xref                                      
function n=($size_register_file, $srf) p=dup$$size_register_file cm=xref                                      
function n=($symbol_address, $sa) p=dup$$symbol_address_function cm=xref                                      
tablend                                                                                                       
*DECK DECK=DUM$ANALYZE_ACTIVE_SEGMENT_TAB EXPAND=TRUE

PROC dum$analyze_active_segment_tab, analyze_active_segment_table, anaast (
  output, o: file = $output
  status)

  crev s kind=status
  crev field_offset integer
  crev field_length integer
  crev asti integer
  delf out status=s
  setfa out fc=list

  pft_entry_size = $mem($sa(mmv$pft_p)+14 4)
  pftlb = $mem($sa(mmv$pft_p)+10 4)
  pftub = ($mem($sa(mmv$pft_p)+6 4) / pft_entry_size) + pftlb - 1
  pft   = $mem($sa(mmv$pft_p) 6)-pftlb*pft_entry_size

  ast   = $mem($sa(mmv$ast_p) 6)
  ast_entry_size = $mem($sa(mmv$ast_p)+14 4)
  astub = $mem($sa(mmv$ast_p)+6 4) / ast_entry_size - 1

  mmt$page_frame_table_entry field=sva offset=field_offset length=field_length
  asid_offset = field_offset / 8
  mmt$page_frame_table_entry field=aste_p offset=field_offset length=field_length
  aste_p_offset = field_offset / 8
  mmt$active_segment_table_entry field=pages_in_memory offset=field_offset length=field_length
  pim_offset = field_offset / 8
  mmt$active_segment_table_entry field=in_use offset=field_offset length=field_length
  in_use_offset = field_offset / 8

  crev asidcnt integer d=0..65535 v=0
  crev astp integer d=0..65535 v=0ffff80000000(16)
  putl ' ANALYZE ACTIVE SEGMENT TABLE ' o=out.$eoi
  FOR pfti = pftlb to pftub do
    pftp = pft+pft_entry_size*pfti
    asid = $mem(pftp+asid_offset 2)
    asidcnt(asid) = asidcnt(asid) + 1
    if astp(asid) =  0ffff80000000(16) then
      astp(asid) = $mem(pftp+aste_p_offset 6)
      dum$asti asid ,, asti
      if (asid <> 0) AND ((asti*ast_entry_size + ast) <> astp(asid)) THEN
        putl ' PFT.ASTE_P does not point to the entry that corresponds to PFT.SVA.ASID, PFTI = '//$strrep(pfti 16) o=out.$eoi
      ifend
    elseif (astp(asid) <> $mem(pftp+aste_p_offset 6)) and (asid > 0) then
      putl ' Inconsistent PFT.ASTE_P. PFTI = '//$strrep(pfti 16) o=out.$eoi
      putl '     Found '//$strrep($mem(pftp+aste_p_offset 6) 16)//', and '//$strrep(astp(asid) 16) o=out.$eoi
    ifend
  FOREND


  crev asteok boolean d=0..65535 v=false
  for asid = 1 to 65535
    astep = astp(asid)
    if astep <> 0ffff80000000(16)
      if $mem(astep+pim_offset 2) <> asidcnt(asid) then
        putl ' AST.PIM <> number PFT entries found. ASID = '//$strrep(asid 16)//'. ASTE_P = '//$strrep(astep 16) o=out.$eoi
        putl '        AST.PIM = '//$strrep($mem(astep+pim_offset 2))//', found = '//$strrep(asidcnt(asid)) o=out.$eoi
      ifend
      asti = (astep - ast) / ast_entry_size
      asteok(asti) = TRUE
    ifend
  forend

  astfree = 0
  astfreepim = 0
  for asti = 1 to astub
    astep = ast+asti*ast_entry_size
    if NOT asteok(asti)
      if $mem(astep+pim_offset 2) > 0 then
        putl ' AST.PIM > 0 but no PFT entries found. ASTEP = '//$strrep(astep 16) o=out.$eoi
        putl '        AST.PIM = '//$strrep($mem(astep+pim_offset 2)) o=out.$eoi
      ifend
    ifend
    if $mem(astep+in_use_offset 1) = 0 then
      if $mem(astep+pim_offset 2) = 0 then
        astfree = astfree + 1
      else
        astfreepim = astfreepim + 1
        putl ' ASTE free but PIM>0, ASTI = '//$strrep(asti 16)
      ifend
    ifend
  forend
  if astfree <> $mem($sa(mmv$number_free_astes) 8) then
    putl ' Bad NUMBER_FREE_ASTES. Found = '//$strrep(astfree)//', should be '//$strrep($mem($sa(mmv$number_free_astes) 8))..
          o=out.$eoi
  ifend
  if astfreepim <> $mem($sa(mmv$number_free_astes_with_pim) 8) then
    putl ' Bad NUMBER_FREE_ASTES_WITH_PIM. Found = '//$strrep(astfreepim)//', should be '//..
          $strrep($mem($sa(mmv$number_free_astes_with_pim) 8)) o=out.$eoi
  ifend
  copf out $value(output)
PROCEND dum$analyze_active_segment_tab

*DECK DECK=DUM$ANALYZE_DUMP_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Dump Analyzer : Analyze Dump Command' ??                                               
MODULE dum$analyze_dump_command;                                                                              
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains the code for the analyze_dump command.                                               
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc clc$standard_file_names                                                                                
*copyc duc$dump_analyzer_constants                                                                            
*copyc due$exception_condition_codes                                                                          
*copyc dut$dump_environment                                                                                   
*copyc dut$execution_environment                                                                              
*copyc osc$processor_defined_registers                                                                        
*copyc osd$virtual_address                                                                                    
*copyc ost$base_system_time                                                                                   
*copyc ost$date_time                                                                                          
?? POP ??                                                                                                     
*copyc amp$get_file_attributes                                                                                
*copyc amp$get_segment_pointer                                                                                
*copyc clp$begin_utility                                                                                      
*copyc clp$close_display                                                                                      
*copyc clp$convert_integer_to_rjstring                                                                        
*copyc clp$convert_string_to_integer                                                                          
*copyc clp$create_procedure_variable                                                                          
*copyc clp$delete_variable                                                                                    
*copyc clp$end_utility                                                                                        
*copyc clp$evaluate_parameters                                                                                
*copyc clp$get_variable_value                                                                                 
*copyc clp$include_file                                                                                       
*copyc clp$include_line                                                                                       
*copyc clp$open_display_reference                                                                             
*copyc dup$copy_virtual_memory_pva                                                                            
*copyc dup$display_message                                                                                    
*copyc dup$new_page_procedure                                                                                 
*copyc dup$read_dump_file                                                                                     
*copyc dup$retrieve_exchange_package                                                                          
*copyc fsp$close_file                                                                                         
*copyc fsp$open_file                                                                                          
*copyc i#build_adaptable_seq_pointer                                                                          
*copyc i#move                                                                                                 
*copyc ocp$open_linker_debug_table                                                                            
*copyc ocp$open_running_debug_table                                                                           
*copyc ofp$display_status_message                                                                             
*copyc osp$append_status_integer                                                                              
*copyc osp$append_status_parameter                                                                            
*copyc osp$set_status_abnormal                                                                                
*copyc pmp$disestablish_cond_handler                                                                          
*copyc pmp$establish_condition_handler                                                                        
?? EJECT ??                                                                                                   
*copyc duv$anad_commands                                                                                      
*copyc duv$anad_functions                                                                                     
*copyc duv$default_parameters                                                                                 
*copyc duv$title_data                                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??                                        
                                                                                                              
  TYPE                                                                                                        
    t$bst_or_string = RECORD                                                                                  
      CASE boolean OF                                                                                         
      = TRUE =                                                                                                
        string_part: string (20),                                                                             
      = FALSE =                                                                                               
        bst_part: t$bst_part,                                                                                 
      CASEND,                                                                                                 
    RECEND,                                                                                                   
                                                                                                              
    t$bst_part = RECORD                                                                                       
      hour: string (2),                                                                                       
      colon_1: string (1),                                                                                    
      minute: string (2),                                                                                     
      colon_2: string (1),                                                                                    
      second: string (2),                                                                                     
      blanks: string (2),                                                                                     
      year: string (4),                                                                                       
      period_1: string (1),                                                                                   
      month: string (2),                                                                                      
      period_2: string (1),                                                                                   
      day: string (2),                                                                                        
    RECEND;                                                                                                   
?? EJECT ??                                                                                                   
                                                                                                              
{ Define the PDT for the analyze_dump command.                                                                
                                                                                                              
{ PROCEDURE analyze_dump, anad (                                                                              
{   dump_file, df: file = $optional                                                                           
{   restart_file, rf: file = $local.restart_file                                                              
{   debug_table, dt: any of                                                                                   
{       key                                                                                                   
{         (running_system rs) (none n)                                                                        
{       keyend                                                                                                
{       file                                                                                                  
{     anyend = running_system                                                                                 
{   title, t: string 1..25 = $optional                                                                        
{   output, o: file = $output                                                                                 
{   processing_options, po: key                                                                               
{       (all_memory am all) (critical_memory cm critical c) (no_memory nm hardware h)                         
{     keyend = all_memory                                                                                     
{   status)                                                                                                   
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 13] of clt$pdt_parameter_name,                                                       
      parameters: array [1 .. 7] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        default_value: string (19),                                                                           
      recend,                                                                                                 
      type3: 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 .. 4] of clt$keyword_specification,                                         
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
        recend,                                                                                               
        default_value: string (14),                                                                           
      recend,                                                                                                 
      type4: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$string_type_qualifier,                                                                 
      recend,                                                                                                 
      type5: record                                                                                           
        header: clt$type_specification_header,                                                                
        default_value: string (7),                                                                            
      recend,                                                                                                 
      type6: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$keyword_type_qualifier,                                                                
        keyword_specs: array [1 .. 11] of clt$keyword_specification,                                          
        default_value: string (10),                                                                           
      recend,                                                                                                 
      type7: record                                                                                           
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [90, 6, 27, 14, 12, 23, 436],                                                                             
    clc$command, 13, 7, 0, 0, 0, 0, 7, ''], [                                                                 
    ['DEBUG_TABLE                    ',clc$nominal_entry, 3],                                                 
    ['DF                             ',clc$abbreviation_entry, 1],                                            
    ['DT                             ',clc$abbreviation_entry, 3],                                            
    ['DUMP_FILE                      ',clc$nominal_entry, 1],                                                 
    ['O                              ',clc$abbreviation_entry, 5],                                            
    ['OUTPUT                         ',clc$nominal_entry, 5],                                                 
    ['PO                             ',clc$abbreviation_entry, 6],                                            
    ['PROCESSING_OPTIONS             ',clc$nominal_entry, 6],                                                 
    ['RESTART_FILE                   ',clc$nominal_entry, 2],                                                 
    ['RF                             ',clc$abbreviation_entry, 2],                                            
    ['STATUS                         ',clc$nominal_entry, 7],                                                 
    ['T                              ',clc$abbreviation_entry, 4],                                            
    ['TITLE                          ',clc$nominal_entry, 4]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [4, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],                                                                                                       
{ PARAMETER 2                                                                                                 
    [9, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,                          
  clc$optional_default_parameter, 0, 19],                                                                     
{ PARAMETER 3                                                                                                 
    [1, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 178,                        
  clc$optional_default_parameter, 0, 14],                                                                     
{ PARAMETER 4                                                                                                 
    [13, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],                                                                                                       
{ PARAMETER 5                                                                                                 
    [6, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,                          
  clc$optional_default_parameter, 0, 7],                                                                      
{ PARAMETER 6                                                                                                 
    [8, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 414,                        
  clc$optional_default_parameter, 0, 10],                                                                     
{ PARAMETER 7                                                                                                 
    [11, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name],                                                         
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,                      
  clc$optional_parameter, 0, 0]],                                                                             
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$file_type]],                                                                                  
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$file_type],                                                                                   
    '$local.restart_file'],                                                                                   
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],                                              
    FALSE, 2],                                                                                                
    155, [[1, 0, clc$keyword_type], [4], [                                                                    
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                 
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2],                      
      ['RS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                 
      ['RUNNING_SYSTEM                 ', clc$nominal_entry, clc$normal_usage_entry, 1]]                      
      ],                                                                                                      
    3, [[1, 0, clc$file_type]]                                                                                
    ,                                                                                                         
    'running_system'],                                                                                        
{ PARAMETER 4                                                                                                 
    [[1, 0, clc$string_type], [1, 25, FALSE]],                                                                
{ PARAMETER 5                                                                                                 
    [[1, 0, clc$file_type],                                                                                   
    '$output'],                                                                                               
{ PARAMETER 6                                                                                                 
    [[1, 0, clc$keyword_type], [11], [                                                                        
    ['ALL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                   
    ['ALL_MEMORY                     ', clc$nominal_entry, clc$normal_usage_entry, 1],                        
    ['AM                             ', clc$alias_entry, clc$normal_usage_entry, 1],                          
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                   
    ['CM                             ', clc$alias_entry, clc$normal_usage_entry, 2],                          
    ['CRITICAL                       ', clc$alias_entry, clc$normal_usage_entry, 2],                          
    ['CRITICAL_MEMORY                ', clc$nominal_entry, clc$normal_usage_entry, 2],                        
    ['H                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                   
    ['HARDWARE                       ', clc$alias_entry, clc$normal_usage_entry, 3],                          
    ['NM                             ', clc$alias_entry, clc$normal_usage_entry, 3],                          
    ['NO_MEMORY                      ', clc$nominal_entry, clc$normal_usage_entry, 3]]                        
    ,                                                                                                         
    'all_memory'],                                                                                            
{ PARAMETER 7                                                                                                 
    [[1, 0, clc$status_type]]];                                                                               
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$dump_file = 1,                                                                                        
      p$restart_file = 2,                                                                                     
      p$debug_table = 3,                                                                                      
      p$title = 4,                                                                                            
      p$output = 5,                                                                                           
      p$processing_options = 6,                                                                               
      p$status = 7;                                                                                           
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 7] of clt$parameter_value;                                                             
                                                                                                              
  CONST                                                                                                       
    c$file_processor = 'ANALYZE_DUMP',                                                                        
    c$processor_status_summary = 0;                                                                           
                                                                                                              
  VAR                                                                                                         
    duv$dump_environment_p: [XDCL] ^dut$dump_environment := NIL,                                              
    duv$execution_environment: [XDCL] dut$execution_environment;                                              
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'convert_microsecond_clock', EJECT ??                                                          
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure converts the microsecond clock into a time.                                                
                                                                                                              
  PROCEDURE convert_microsecond_clock                                                                         
    (    timestamp: integer;                                                                                  
         base_system_time: ost$base_system_time;                                                              
     VAR date_time: ost$date_time;                                                                            
     VAR date_time_found: boolean);                                                                           
                                                                                                              
    CONST                                                                                                     
      c$ms_per_day = 24 * 60 * 60 * 1000;                                                                     
                                                                                                              
    VAR                                                                                                       
      b1: boolean,                                                                                            
      b2: boolean,                                                                                            
      b3: boolean,                                                                                            
      day: integer,                                                                                           
      days_in_the_month: ARRAY [1 .. 12] OF 1 .. 31,                                                          
      elapsed_time: integer,                                                                                  
      hour: -1 .. 47,                                                                                         
      minute: -30 .. 119,                                                                                     
      month: 1 .. 13,                                                                                         
      second: 0 .. 119,                                                                                       
      this_is_a_leap_year: boolean,                                                                           
      year: 0 .. 2155;  {1900 + 255                                                                           
                                                                                                              
    date_time_found := FALSE;                                                                                 
                                                                                                              
    elapsed_time {ms} := (timestamp {us} - base_system_time.corresponding_microsecond_clock {us}) DIV 1000    
          {us/ms};                                                                                            
                                                                                                              
    elapsed_time := elapsed_time + (base_system_time.hour * 3600 + base_system_time.minute *                  
          60 + base_system_time.second) * 1000;                                                               
                                                                                                              
    day := base_system_time.day + (elapsed_time DIV c$ms_per_day);                                            
    elapsed_time := elapsed_time MOD c$ms_per_day;                                                            
    IF elapsed_time < 0 THEN                                                                                  
      elapsed_time := elapsed_time + c$ms_per_day;                                                            
      day := day - 1;                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    date_time.millisecond := elapsed_time {ms} MOD 1000 {ms} ;                                                
                                                                                                              
    elapsed_time {sec} := elapsed_time {ms} DIV 1000 {ms/sec} ;                                               
    date_time.second := elapsed_time {sec} MOD 60 {sec} ;                                                     
                                                                                                              
    elapsed_time {min} := elapsed_time {sec} DIV 60 {sec/min} ;                                               
    date_time.minute := elapsed_time {min} MOD 60 {min} ;                                                     
                                                                                                              
    elapsed_time {hr} := elapsed_time {min} DIV 60 {min/hr} ;                                                 
    date_time.hour := elapsed_time {hr} MOD 24 {hr} ;                                                         
                                                                                                              
    month := base_system_time.month;                                                                          
    year := base_system_time.year;                                                                            
                                                                                                              
    days_in_the_month [1] := 31;                                                                              
    days_in_the_month [3] := 31;                                                                              
    days_in_the_month [4] := 30;                                                                              
    days_in_the_month [5] := 31;                                                                              
    days_in_the_month [6] := 30;                                                                              
    days_in_the_month [7] := 31;                                                                              
    days_in_the_month [8] := 31;                                                                              
    days_in_the_month [9] := 30;                                                                              
    days_in_the_month [10] := 31;                                                                             
    days_in_the_month [11] := 30;                                                                             
    days_in_the_month [12] := 31;                                                                             
                                                                                                              
    b1 := ((year MOD 4) = 0);                                                                                 
    b2 := ((year MOD 100) <> 0);                                                                              
    b3 := ((year MOD 400) = 0);                                                                               
    this_is_a_leap_year := (b1 AND b2) OR b3;                                                                 
    IF this_is_a_leap_year THEN                                                                               
      days_in_the_month [2] := 29;                                                                            
    ELSE                                                                                                      
      days_in_the_month [2] := 28;                                                                            
    IFEND;                                                                                                    
                                                                                                              
    WHILE day < 1 DO                                                                                          
      IF month = 1 THEN                                                                                       
        month := 13;                                                                                          
        IF (year - 1 {yr} ) < LOWERVALUE (year) THEN                                                          
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
        year := year - 1;                                                                                     
        b1 := ((year MOD 4) = 0);                                                                             
        b2 := ((year MOD 100) <> 0);                                                                          
        b3 := ((year MOD 400) = 0);                                                                           
        this_is_a_leap_year := (b1 AND b2) OR b3;                                                             
        IF this_is_a_leap_year THEN                                                                           
          days_in_the_month [2] := 29;                                                                        
        ELSE                                                                                                  
          days_in_the_month [2] := 28;                                                                        
        IFEND;                                                                                                
      IFEND;                                                                                                  
      month := month - 1;                                                                                     
      day := day + days_in_the_month [month];                                                                 
    WHILEND;                                                                                                  
                                                                                                              
    WHILE day > days_in_the_month [month] DO                                                                  
      day := day - days_in_the_month [month];                                                                 
      month := month + 1 {mo} ;                                                                               
      IF month > 12 {mo} THEN                                                                                 
        IF (year + 1 {yr} ) > UPPERVALUE (year) THEN                                                          
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
        month := 1 {mo} ;                                                                                     
        year := year + 1 {yr} ;                                                                               
        b1 := ((year MOD 4) = 0);                                                                             
        b2 := ((year MOD 100) <> 0);                                                                          
        b3 := ((year MOD 400) = 0);                                                                           
        this_is_a_leap_year := (b1 AND b2) OR b3;                                                             
        IF this_is_a_leap_year THEN                                                                           
          days_in_the_month [2] := 29;                                                                        
        ELSE                                                                                                  
          days_in_the_month [2] := 28;                                                                        
        IFEND;                                                                                                
      IFEND;                                                                                                  
    WHILEND;                                                                                                  
                                                                                                              
    date_time.day := day;                                                                                     
    date_time.month := month;                                                                                 
    date_time.year := year - 1900;                                                                            
    date_time_found := TRUE;                                                                                  
                                                                                                              
  PROCEND convert_microsecond_clock;                                                                          
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'process_dump', EJECT ??                                                                       
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure opens the restart file, reads the dump file (if necessary) and builds the execution        
{   environment.                                                                                              
                                                                                                              
  PROCEDURE process_dump                                                                                      
    (VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      cell_p: ^cell,                                                                                          
      current_register: 1 .. duc$de_number_of_pro_mrs_dumped,                                                 
      display_control: clt$display_control,                                                                   
      fa_p: ^fst$attachment_options,                                                                          
      file_contains_data: boolean,                                                                            
      file_gfa: ARRAY [1 .. 1] OF amt$get_item,                                                               
      ignore_status: ost$status,                                                                              
      local_file: boolean,                                                                                    
      mca_p: ^fst$file_cycle_attributes,                                                                      
      old_file: boolean,                                                                                      
      pro_mr_jps_p: ^dut$ee_processor_mr_jps,                                                                 
      pro_mr_mps_p: ^dut$ee_processor_mr_mps,                                                                 
      pro_mr_psm_p: ^dut$ee_processor_mr_psm,                                                                 
      pro_mr_pta_p: ^dut$ee_processor_mr_pta,                                                                 
      pro_mr_ptl_p: ^dut$ee_processor_mr_ptl,                                                                 
      pro_mr_ss_p: ^dut$ee_processor_mr_ss,                                                                   
      processor: 0 .. duc$de_maximum_processors,                                                              
      psm: dut$ee_psm_value,                                                                                  
      pta: dut$ee_pta_value,                                                                                  
      ptl: dut$ee_ptl_value,                                                                                  
      ring_attributes: amt$ring_attributes;                                                                   
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Open the output file.                                                                                   
                                                                                                              
    ring_attributes.r1 := #RING (^ring_attributes);                                                           
    ring_attributes.r2 := #RING (^ring_attributes);                                                           
    ring_attributes.r3 := #RING (^ring_attributes);                                                           
    duv$execution_environment.output_file.name := pvt [p$output].value^.file_value^;                          
    duv$execution_environment.output_file.size := #SIZE (pvt [p$output].value^.file_value^);                  
    clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,         
          ring_attributes, duv$execution_environment.output_file.display_control, status);                    
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    duv$execution_environment.output_file_opened := TRUE;                                                     
                                                                                                              
    display_control := duv$execution_environment.output_file.display_control;                                 
    display_control.line_number := display_control.page_length + 1;                                           
                                                                                                              
    { Retrieve the processing options.                                                                        
                                                                                                              
    IF pvt [p$processing_options].value^.keyword_value = 'ALL_MEMORY' THEN                                    
      duv$execution_environment.processing_options := duc$ee_po_all_memory;                                   
    ELSEIF pvt [p$processing_options].value^.keyword_value = 'CRITICAL_MEMORY' THEN                           
      duv$execution_environment.processing_options := duc$ee_po_critical_memory;                              
    ELSE  { no memory }                                                                                       
      duv$execution_environment.processing_options := duc$ee_po_no_memory;                                    
    IFEND;                                                                                                    
                                                                                                              
    { Retrieve the main title.                                                                                
                                                                                                              
    IF pvt [p$title].specified THEN                                                                           
      duv$title_data.main_title := pvt [p$title].value^.string_value^;                                        
    ELSE                                                                                                      
      duv$title_data.main_title := duc$version;                                                               
    IFEND;                                                                                                    
                                                                                                              
    { Open the debug table.                                                                                   
                                                                                                              
    IF pvt [p$debug_table].value^.kind = clc$keyword THEN                                                     
      IF pvt [p$debug_table].value^.keyword_value = 'RUNNING_SYSTEM' THEN                                     
        ocp$open_running_debug_table (status);                                                                
        IF NOT status.normal THEN                                                                             
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
      IFEND;                                                                                                  
    ELSE                                                                                                      
      ocp$open_linker_debug_table (pvt [p$debug_table].value^.file_value^, status);                           
      IF NOT status.normal THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    { Determine if the restart file parameter is correctly used.                                              
                                                                                                              
    file_gfa [1].key := amc$file_processor;                                                                   
    amp$get_file_attributes (pvt [p$restart_file].value^.file_value^, file_gfa, local_file, old_file,         
          file_contains_data, status);                                                                        
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF NOT pvt [p$dump_file].specified AND NOT old_file THEN                                                  
      osp$set_status_abnormal (duc$dump_analyzer_id, due$file_empty, pvt [p$restart_file].value^.file_value^, 
            status);                                                                                          
      dup$display_message (status, display_control);                                                          
      status.normal := TRUE;                                                                                  
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF pvt [p$dump_file].specified AND old_file AND (file_gfa [1].file_processor <> c$file_processor) THEN    
      osp$set_status_abnormal (duc$dump_analyzer_id, due$overwriting_wrong_file,                              
            pvt [p$restart_file].value^.file_value^, status);                                                 
      osp$append_status_parameter (osc$status_parameter_delimiter, 'restart', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF NOT pvt [p$dump_file].specified AND (file_gfa [1].file_processor <> c$file_processor) THEN             
      osp$set_status_abnormal (duc$dump_analyzer_id, due$improper_file_attributes,                            
            pvt [p$restart_file].value^.file_value^, status);                                                 
      osp$append_status_parameter (osc$status_parameter_delimiter, 'restart', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Setup the open file parameters.                                                                         
                                                                                                              
    PUSH fa_p: [1 .. 2];                                                                                      
    fa_p^ [1].selector := fsc$access_and_share_modes;                                                         
    fa_p^ [1].access_modes.selector := fsc$specific_access_modes;                                             
    fa_p^ [1].access_modes.value := $fst$file_access_options [fsc$read, fsc$shorten, fsc$append, fsc$modify]; 
    fa_p^ [1].share_modes.selector := fsc$specific_share_modes;                                               
    fa_p^ [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$shorten, fsc$append, fsc$modify];  
    fa_p^ [2].selector := fsc$open_position;                                                                  
    fa_p^ [2].open_position := amc$open_at_boi;                                                               
                                                                                                              
    PUSH mca_p: [1 .. 1];                                                                                     
    mca_p^ [1].selector := fsc$file_contents_and_processor;                                                   
    mca_p^ [1].file_contents := fsc$unknown_contents;                                                         
    mca_p^ [1].file_processor := c$file_processor;                                                            
                                                                                                              
    { Read the dump file and build the dump environment on the restart file.                                  
                                                                                                              
    IF pvt [p$dump_file].specified THEN                                                                       
                                                                                                              
      { Open the restart file.                                                                                
                                                                                                              
      fsp$open_file (pvt [p$restart_file].value^.file_value^, amc$segment, fa_p, NIL, mca_p, NIL, NIL,        
            duv$execution_environment.restart_file.file_identifier, status);                                  
      IF NOT status.normal THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      duv$execution_environment.restart_file_opened := TRUE;                                                  
      amp$get_segment_pointer (duv$execution_environment.restart_file.file_identifier, amc$sequence_pointer,  
            duv$execution_environment.restart_file.segment_pointer, status);                                  
      IF NOT status.normal THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                          
                                                                                                              
      { Retrieve the dump environment from the restart file which will contain important data needed to       
      { analyze the dump.                                                                                     
                                                                                                              
      NEXT duv$dump_environment_p IN duv$execution_environment.restart_file.segment_pointer.sequence_pointer; 
      IF duv$dump_environment_p = NIL THEN                                                                    
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      dup$read_dump_file (pvt [p$dump_file].value^.file_value, status);                                       
      IF NOT status.normal THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      fsp$close_file (duv$execution_environment.restart_file.file_identifier, ignore_status);                 
      duv$execution_environment.restart_file_opened := FALSE;                                                 
    IFEND;                                                                                                    
                                                                                                              
    { Reopen the restart file.  The file is closed and reopened so that it has the correct file attributes.   
                                                                                                              
    amp$get_file_attributes (pvt [p$restart_file].value^.file_value^, file_gfa, local_file, old_file,         
          file_contains_data, status);                                                                        
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF NOT file_contains_data THEN                                                                            
      osp$set_status_abnormal (duc$dump_analyzer_id, due$file_empty, pvt [p$restart_file].value^.file_value^, 
            status);                                                                                          
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    fa_p^ [1].selector := fsc$access_and_share_modes;                                                         
    fa_p^ [1].access_modes.selector := fsc$specific_access_modes;                                             
    fa_p^ [1].access_modes.value := $fst$file_access_options [fsc$read];                                      
    fa_p^ [1].share_modes.selector := fsc$specific_share_modes;                                               
    fa_p^ [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];                          
    fsp$open_file (pvt [p$restart_file].value^.file_value^, amc$segment, fa_p, NIL, mca_p, NIL, NIL,          
          duv$execution_environment.restart_file.file_identifier, status);                                    
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    duv$execution_environment.restart_file_opened := TRUE;                                                    
    amp$get_segment_pointer (duv$execution_environment.restart_file.file_identifier, amc$sequence_pointer,    
          duv$execution_environment.restart_file.segment_pointer, status);                                    
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                            
                                                                                                              
    NEXT duv$dump_environment_p IN duv$execution_environment.restart_file.segment_pointer.sequence_pointer;   
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p^.revision_level <> duc$revision_level THEN                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$revision_level_mismatch,                             
            'WARNING - Restart file incompatible with current revision level of Analyze_Dump -- ' CAT         
            'Dump must be re-read from tape.', status);                                                       
      dup$display_message (status, display_control);                                                          
    IFEND;                                                                                                    
                                                                                                              
    { Retrieve the processor register values from the dump environment data.                                  
                                                                                                              
    psm.value := 0;                                                                                           
    pta.value := 0;                                                                                           
    ptl.value := 0;                                                                                           
    FOR processor := 0 TO duc$de_maximum_processors DO                                                        
      duv$execution_environment.processor_registers [processor].available :=                                  
            duv$dump_environment_p^.pro_maintenance_registers [processor].available;                          
      duv$execution_environment.processor_registers [processor].status_summary.general :=                     
            $dut$ee_pro_general_ss_set [];                                                                    
      duv$execution_environment.processor_registers [processor].job_process_state := 0;                       
      duv$execution_environment.processor_registers [processor].monitor_process_state := 0;                   
      duv$execution_environment.processor_registers [processor].page_size_mask := psm.psm;                    
      duv$execution_environment.processor_registers [processor].page_table_address := pta.pta;                
      duv$execution_environment.processor_registers [processor].page_table_length := ptl.ptl;                 
                                                                                                              
     /find_registers/                                                                                         
      FOR current_register := 1 to duc$de_number_of_pro_mrs_dumped DO                                         
        IF NOT duv$dump_environment_p^.pro_maintenance_registers [processor].                                 
              registers [current_register].available THEN                                                     
          EXIT /find_registers/;  {---->                                                                      
        IFEND;                                                                                                
        cell_p := ^duv$dump_environment_p^.pro_maintenance_registers [processor].                             
              registers [current_register].value;                                                             
        CASE duv$dump_environment_p^.pro_maintenance_registers [processor].                                   
              registers [current_register].number OF                                                          
        = c$processor_status_summary =                                                                        
          pro_mr_ss_p := cell_p;                                                                              
          duv$execution_environment.processor_registers [processor].status_summary := pro_mr_ss_p^.value;     
        = osc$pr_job_process_state =                                                                          
          pro_mr_jps_p := cell_p;                                                                             
          duv$execution_environment.processor_registers [processor].job_process_state := pro_mr_jps_p^.value; 
        = osc$pr_monitor_process_state =                                                                      
          pro_mr_mps_p := cell_p;                                                                             
          duv$execution_environment.processor_registers [processor].monitor_process_state :=                  
                pro_mr_mps_p^.value;                                                                          
        = osc$pr_page_size_mask =                                                                             
          pro_mr_psm_p := cell_p;                                                                             
          duv$execution_environment.processor_registers [processor].page_size_mask := pro_mr_psm_p^.value;    
        = osc$pr_page_table_address =                                                                         
          pro_mr_pta_p := cell_p;                                                                             
          duv$execution_environment.processor_registers [processor].page_table_address := pro_mr_pta_p^.value;
        = osc$pr_page_table_length =                                                                          
          pro_mr_ptl_p := cell_p;                                                                             
          duv$execution_environment.processor_registers [processor].page_table_length := pro_mr_ptl_p^.value; 
        ELSE                                                                                                  
        CASEND;                                                                                               
      FOREND /find_registers/;                                                                                
    FOREND;                                                                                                   
                                                                                                              
  PROCEND process_dump;                                                                                       
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'retrieve_base_system_time', EJECT ??                                                          
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure attempts to retrieve the base system time from memory.                                     
                                                                                                              
  PROCEDURE retrieve_base_system_time                                                                         
    (VAR base_system_time_found: boolean;                                                                     
     VAR base_system_time: ost$base_system_time);                                                             
                                                                                                              
    TYPE                                                                                                      
      t$string_or_record = RECORD                                                                             
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          string_part: string (13),                                                                           
        = FALSE =                                                                                             
          record_part: ost$base_system_time,                                                                  
        CASEND,                                                                                               
      RECEND;                                                                                                 
                                                                                                              
    VAR                                                                                                       
      bl_string_header_p: ^clt$type_specification_header,                                                     
      bl_string_type_p: ^clt$string_type_qualifier,                                                           
      bl_string_type_seq_p: ^SEQ ( * ),                                                                       
      bl_variable_p: ^clt$data_value,                                                                         
      bst_or_string: t$bst_or_string,                                                                         
      ignore_status: ost$status,                                                                              
      local_status: ost$status,                                                                               
      string_or_record: t$string_or_record;                                                                   
                                                                                                              
    base_system_time_found := FALSE;                                                                          
                                                                                                              
    PUSH bl_string_type_seq_p: [[REP (#SIZE (clt$type_specification_header) +                                 
          #SIZE (clt$string_type_qualifier)) OF cell]];                                                       
    RESET bl_string_type_seq_p;                                                                               
    NEXT bl_string_header_p IN bl_string_type_seq_p;                                                          
    bl_string_header_p^.version := clc$declaration_version;                                                   
    bl_string_header_p^.name_size := 0;                                                                       
    bl_string_header_p^.kind := clc$string_type;                                                              
    NEXT bl_string_type_p IN bl_string_type_seq_p;                                                            
    bl_string_type_p^.min_string_size := 13;                                                                  
    bl_string_type_p^.max_string_size := 13;                                                                  
    bl_string_type_p^.literal := FALSE;                                                                       
    RESET bl_string_type_seq_p;                                                                               
                                                                                                              
    PUSH bl_variable_p;                                                                                       
    bl_variable_p^.kind := clc$string;                                                                        
    PUSH bl_variable_p^.string_value: [13];                                                                   
    bl_variable_p^.string_value^ := ' ';                                                                      
                                                                                                              
    clp$create_procedure_variable ('DUV$BST', clc$xdcl_scope, clc$read_write, clc$immediate_evaluation,       
          bl_string_type_seq_p, bl_variable_p, local_status);                                                 
    IF NOT local_status.normal THEN                                                                           
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    clp$include_line ('duv$bst=$memory_string($symbol_address(osv$base_system_time), 13, active, 0, pva)',    
          FALSE, osc$null_name, local_status);                                                                
    IF NOT local_status.normal THEN                                                                           
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    clp$get_variable_value ('DUV$BST', bl_variable_p, local_status);                                          
    IF NOT local_status.normal THEN                                                                           
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    string_or_record.string_part := bl_variable_p^.string_value^;                                             
    bst_or_string.string_part := ' ';                                                                         
    clp$convert_integer_to_rjstring (string_or_record.record_part.second, 10, FALSE, '0',                     
          bst_or_string.bst_part.second, ignore_status);                                                      
    clp$convert_integer_to_rjstring (string_or_record.record_part.minute, 10, FALSE, '0',                     
          bst_or_string.bst_part.minute, ignore_status);                                                      
    clp$convert_integer_to_rjstring (string_or_record.record_part.hour, 10, FALSE, '0',                       
          bst_or_string.bst_part.hour, ignore_status);                                                        
    clp$convert_integer_to_rjstring (string_or_record.record_part.day, 10, FALSE, '0',                        
          bst_or_string.bst_part.day, ignore_status);                                                         
    clp$convert_integer_to_rjstring (string_or_record.record_part.month, 10, FALSE, '0',                      
          bst_or_string.bst_part.month, ignore_status);                                                       
    clp$convert_integer_to_rjstring (string_or_record.record_part.year, 10, FALSE, '0',                       
          bst_or_string.bst_part.year, ignore_status);                                                        
    bst_or_string.bst_part.colon_1 := ':';                                                                    
    bst_or_string.bst_part.colon_2 := ':';                                                                    
    bst_or_string.bst_part.period_1 := '.';                                                                   
    bst_or_string.bst_part.period_2 := '.';                                                                   
                                                                                                              
    duv$title_data.base_system_time := bst_or_string.string_part;                                             
    base_system_time_found := TRUE;                                                                           
    base_system_time := string_or_record.record_part;                                                         
                                                                                                              
    clp$delete_variable ('DUV$BST', local_status);                                                            
                                                                                                              
  PROCEND retrieve_base_system_time;                                                                          
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'retrieve_build_level', EJECT ??                                                               
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure attempts to retrieve the build level from memory.                                          
                                                                                                              
  PROCEDURE retrieve_build_level;                                                                             
                                                                                                              
    VAR                                                                                                       
      bl_string_header_p: ^clt$type_specification_header,                                                     
      bl_string_type_p: ^clt$string_type_qualifier,                                                           
      bl_string_type_seq_p: ^SEQ ( * ),                                                                       
      bl_variable_p: ^clt$data_value,                                                                         
      control_codes_to_space: [STATIC, READ] string (256) := '                                 '              
            CAT '!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklm'              
            CAT 'nopqrstuvwxyz{|}~                                                             '              
            CAT '                                                                    ',                       
      local_status: ost$status;                                                                               
                                                                                                              
    PUSH bl_string_type_seq_p: [[REP (#SIZE (clt$type_specification_header) +                                 
          #SIZE (clt$string_type_qualifier)) OF cell]];                                                       
    RESET bl_string_type_seq_p;                                                                               
    NEXT bl_string_header_p IN bl_string_type_seq_p;                                                          
    bl_string_header_p^.version := clc$declaration_version;                                                   
    bl_string_header_p^.name_size := 0;                                                                       
    bl_string_header_p^.kind := clc$string_type;                                                              
    NEXT bl_string_type_p IN bl_string_type_seq_p;                                                            
    bl_string_type_p^.min_string_size := 31;                                                                  
    bl_string_type_p^.max_string_size := 31;                                                                  
    bl_string_type_p^.literal := FALSE;                                                                       
    RESET bl_string_type_seq_p;                                                                               
                                                                                                              
    PUSH bl_variable_p;                                                                                       
    bl_variable_p^.kind := clc$string;                                                                        
    PUSH bl_variable_p^.string_value: [31];                                                                   
    bl_variable_p^.string_value^ := ' ';                                                                      
                                                                                                              
    clp$create_procedure_variable ('DUV$BL', clc$xdcl_scope, clc$read_write, clc$immediate_evaluation,        
          bl_string_type_seq_p, bl_variable_p, local_status);                                                 
    IF NOT local_status.normal THEN                                                                           
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    clp$include_line ('duv$bl=$memory_string($symbol_address(osv$build_level), 31, active, 0, pva)', FALSE,   
          osc$null_name, local_status);                                                                       
    IF NOT local_status.normal THEN                                                                           
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    clp$get_variable_value ('DUV$BL', bl_variable_p, local_status);                                           
    IF NOT local_status.normal THEN                                                                           
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    #TRANSLATE (control_codes_to_space, bl_variable_p^.string_value^, duv$title_data.system_level);           
                                                                                                              
    clp$delete_variable ('DUV$BL', local_status);                                                             
                                                                                                              
  PROCEND retrieve_build_level;                                                                               
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'retrieve_termination_time', EJECT ??                                                          
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure attempts to retrieve the termination time from memory.                                     
                                                                                                              
  PROCEDURE retrieve_termination_time                                                                         
    (    base_system_time: ost$base_system_time);                                                             
                                                                                                              
    TYPE                                                                                                      
      t$string_or_integer = RECORD                                                                            
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          string_part: string (8),                                                                            
        = FALSE =                                                                                             
          integer_part: integer,                                                                              
        CASEND,                                                                                               
      RECEND;                                                                                                 
                                                                                                              
    VAR                                                                                                       
      bl_string_header_p: ^clt$type_specification_header,                                                     
      bl_string_type_p: ^clt$string_type_qualifier,                                                           
      bl_string_type_seq_p: ^SEQ ( * ),                                                                       
      bl_variable_p: ^clt$data_value,                                                                         
      bst_or_string: t$bst_or_string,                                                                         
      date_time: ost$date_time,                                                                               
      date_time_found: boolean,                                                                               
      ignore_status: ost$status,                                                                              
      local_status: ost$status,                                                                               
      string_or_integer: t$string_or_integer,                                                                 
      year: 0 .. 0ffff(16);                                                                                   
                                                                                                              
    PUSH bl_string_type_seq_p: [[REP (#SIZE (clt$type_specification_header) +                                 
          #SIZE (clt$string_type_qualifier)) OF cell]];                                                       
    RESET bl_string_type_seq_p;                                                                               
    NEXT bl_string_header_p IN bl_string_type_seq_p;                                                          
    bl_string_header_p^.version := clc$declaration_version;                                                   
    bl_string_header_p^.name_size := 0;                                                                       
    bl_string_header_p^.kind := clc$string_type;                                                              
    NEXT bl_string_type_p IN bl_string_type_seq_p;                                                            
    bl_string_type_p^.min_string_size := 8;                                                                   
    bl_string_type_p^.max_string_size := 8;                                                                   
    bl_string_type_p^.literal := FALSE;                                                                       
    RESET bl_string_type_seq_p;                                                                               
                                                                                                              
    PUSH bl_variable_p;                                                                                       
    bl_variable_p^.kind := clc$string;                                                                        
    PUSH bl_variable_p^.string_value: [8];                                                                    
    bl_variable_p^.string_value^ := ' ';                                                                      
                                                                                                              
    clp$create_procedure_variable ('DUV$TT', clc$xdcl_scope, clc$read_write, clc$immediate_evaluation,        
          bl_string_type_seq_p, bl_variable_p, local_status);                                                 
    IF NOT local_status.normal THEN                                                                           
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    clp$include_line ('duv$tt=$memory_string($symbol_address(mtv$trace_buffer), 8, active, 0, pva)',          
          FALSE, osc$null_name, local_status);                                                                
    IF NOT local_status.normal THEN                                                                           
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    clp$get_variable_value ('DUV$TT', bl_variable_p, local_status);                                           
    IF NOT local_status.normal THEN                                                                           
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    string_or_integer.string_part := bl_variable_p^.string_value^;                                            
                                                                                                              
    convert_microsecond_clock (string_or_integer.integer_part, base_system_time, date_time,                   
          date_time_found);                                                                                   
    IF NOT date_time_found THEN                                                                               
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    bst_or_string.string_part := ' ';                                                                         
    clp$convert_integer_to_rjstring (date_time.second, 10, FALSE, '0', bst_or_string.bst_part.second,         
          ignore_status);                                                                                     
    clp$convert_integer_to_rjstring (date_time.minute, 10, FALSE, '0', bst_or_string.bst_part.minute,         
          ignore_status);                                                                                     
    clp$convert_integer_to_rjstring (date_time.hour, 10, FALSE, '0', bst_or_string.bst_part.hour,             
          ignore_status);                                                                                     
    clp$convert_integer_to_rjstring (date_time.day, 10, FALSE, '0', bst_or_string.bst_part.day,               
          ignore_status);                                                                                     
    clp$convert_integer_to_rjstring (date_time.month, 10, FALSE, '0', bst_or_string.bst_part.month,           
          ignore_status);                                                                                     
    year := 1900 + date_time.year;                                                                            
    clp$convert_integer_to_rjstring (year, 10, FALSE, '0', bst_or_string.bst_part.year, ignore_status);       
    bst_or_string.bst_part.colon_1 := ':';                                                                    
    bst_or_string.bst_part.colon_2 := ':';                                                                    
    bst_or_string.bst_part.period_1 := '.';                                                                   
    bst_or_string.bst_part.period_2 := '.';                                                                   
                                                                                                              
    duv$title_data.termination_time := bst_or_string.string_part;                                             
                                                                                                              
    clp$delete_variable ('DUV$TT', local_status);                                                             
                                                                                                              
  PROCEND retrieve_termination_time;                                                                          
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$get_bytes', EJECT ??                                                                      
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure ???                                                                                        
{ NOTE:                                                                                                       
{   This procedure is located in this module to make sure it gets loaded and linked with analyze_dump rather  
{   than the version with the same name that performs the same function in the context of Analyze System.     
                                                                                                              
  PROCEDURE [XDCL, #GATE] dup$get_bytes                                                                       
    (    source: ost$pva;                                                                                     
         input_destination_p: ^cell;                                                                          
         length: 0 .. 7fffffff(16);                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      access_data: dut$access_data,                                                                           
      bytes_copied: ost$segment_length,                                                                       
      destination_p: ^SEQ ( * ),                                                                              
      exchange_package_p: ^dut$exchange_package,                                                              
      exchange_parameter: clt$data_value,                                                                     
      ignore_status: ost$status,                                                                              
      integer_value: clt$integer,                                                                             
      processor: 0 .. duc$de_maximum_processors;                                                              
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    IF (source.ring = osc$invalid_ring) THEN {local address flag}                                             
      i#move (#ADDRESS (osc$min_ring, source.seg, source.offset), input_destination_p, length);               
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    i#build_adaptable_seq_pointer (#RING (input_destination_p), #SEGMENT (input_destination_p),               
          #OFFSET (input_destination_p), length, 0, destination_p);                                           
                                                                                                              
    IF duv$default_parameters [duc$dp_processor].default_set THEN                                             
      clp$convert_string_to_integer (duv$default_parameters [duc$dp_processor].value, integer_value,          
            ignore_status);                                                                                   
      processor := integer_value.value;                                                                       
    ELSE                                                                                                      
      processor := 0;                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF (duv$default_parameters [duc$dp_exchange].value = 'ACTIVE') OR                                         
          (duv$default_parameters [duc$dp_exchange].value = 'MONITOR') OR                                     
          (duv$default_parameters [duc$dp_exchange].value = 'JOB') THEN                                       
      exchange_parameter.kind := clc$keyword;                                                                 
      exchange_parameter.keyword_value := duv$default_parameters [duc$dp_exchange].value;                     
    ELSE                                                                                                      
      exchange_parameter.kind := clc$integer;                                                                 
      clp$convert_string_to_integer (duv$default_parameters [duc$dp_exchange].value, integer_value,           
            ignore_status);                                                                                   
      exchange_parameter.integer_value.value := integer_value.value;                                          
    IFEND;                                                                                                    
                                                                                                              
    dup$retrieve_exchange_package (processor, exchange_parameter, exchange_package_p, status);                
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF length > 0 THEN                                                                                        
      dup$copy_virtual_memory_pva (source, exchange_package_p^, processor, length, FALSE, bytes_copied,       
            destination_p, access_data, status);                                                              
      IF NOT status.normal THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      IF access_data.page_fault AND NOT access_data.memory_found THEN                                         
        osp$set_status_abnormal (duc$dump_analyzer_id, due$soft_page_fault, '', status);                      
        osp$append_status_parameter (osc$status_parameter_delimiter, ', segment = ', status);                 
        osp$append_status_integer (osc$status_parameter_delimiter, source.seg, 16, TRUE, status);             
        osp$append_status_parameter (osc$status_parameter_delimiter, ', offset = ', status);                  
        osp$append_status_integer (osc$status_parameter_delimiter, access_data.page_fault_offset, 16, TRUE,   
              status);                                                                                        
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
  PROCEND dup$get_bytes;                                                                                      
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$analyze_dump_command', EJECT ??                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure is the starting program for the analyze_dump utility.                                      
                                                                                                              
  PROGRAM dup$analyze_dump_command                                                                            
    (    parameter_list: clt$parameter_list;                                                                  
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      base_system_time: ost$base_system_time,                                                                 
      base_system_time_found: boolean,                                                                        
      exit_conditions: [STATIC] pmt$condition := [pmc$block_exit_processing,                                  
            $pmt$block_exit_reason [pmc$block_exit, pmc$program_termination, pmc$program_abort]],             
      exit_descriptor: pmt$established_handler,                                                               
      ignore_status: ost$status,                                                                              
      utility_attributes_p: ^clt$utility_attributes;                                                          
                                                                                                              
?? NEWTITLE := 'exit_condition_handler', EJECT ??                                                             
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure handles the exit condition handler for the utility.                                        
                                                                                                              
    PROCEDURE exit_condition_handler                                                                          
      (    exit_condition: pmt$condition;                                                                     
           exit_condition_descriptor_p: ^pmt$condition_information;                                           
           save_area_p: ^ost$stack_frame_save_area;                                                           
       VAR condition_status: ost$status);                                                                     
                                                                                                              
      VAR                                                                                                     
        utility_status: ost$status;                                                                           
                                                                                                              
      condition_status.normal := TRUE;                                                                        
      CASE exit_condition.selector OF                                                                         
      = pmc$block_exit_processing =                                                                           
        clp$end_utility (duc$utility_name, utility_status);                                                   
        fsp$close_file (duv$execution_environment.restart_file.file_identifier, utility_status);              
        ofp$display_status_message (' ', utility_status);                                                     
      ELSE                                                                                                    
      CASEND;                                                                                                 
                                                                                                              
    PROCEND exit_condition_handler;                                                                           
?? OLDTITLE ??                                                                                                
?? EJECT ??                                                                                                   
                                                                                                              
    status.normal := TRUE;                                                                                    
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    duv$execution_environment.output_file_opened := FALSE;                                                    
    duv$execution_environment.restart_file_opened := FALSE;                                                   
    pmp$establish_condition_handler (exit_conditions, ^exit_condition_handler, ^exit_descriptor, status);     
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    PUSH utility_attributes_p: [1 .. 5];                                                                      
    utility_attributes_p^ [1].key := clc$utility_command_search_mode;                                         
    utility_attributes_p^ [1].command_search_mode := clc$global_command_search;                               
    utility_attributes_p^ [2].key := clc$utility_command_table;                                               
    utility_attributes_p^ [2].command_table := duv$anad_commands;                                             
    utility_attributes_p^ [3].key := clc$utility_function_proc_table;                                         
    utility_attributes_p^ [3].function_processor_table := duv$anad_functions;                                 
    utility_attributes_p^ [4].key := clc$utility_online_manual;                                               
    utility_attributes_p^ [4].online_manual_name := 'analyze_dump';                                           
    utility_attributes_p^ [5].key := clc$utility_prompt;                                                      
    utility_attributes_p^ [5].prompt.value := 'AD';                                                           
    utility_attributes_p^ [5].prompt.size := 2;                                                               
                                                                                                              
    clp$begin_utility (duc$utility_name, utility_attributes_p^, status);                                      
    IF NOT status.normal THEN                                                                                 
      pmp$disestablish_cond_handler (exit_conditions, ignore_status);                                         
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
   /anad_utility/                                                                                             
    BEGIN                                                                                                     
                                                                                                              
      process_dump (status);                                                                                  
      IF NOT status.normal THEN                                                                               
        EXIT /anad_utility/;  {---->                                                                          
      IFEND;                                                                                                  
                                                                                                              
      duv$title_data.system_level := 'UNKNOWN';                                                               
      duv$title_data.base_system_time := 'UNKNOWN';                                                           
      duv$title_data.termination_time := 'UNKNOWN';                                                           
                                                                                                              
      retrieve_build_level;                                                                                   
      retrieve_base_system_time (base_system_time_found, base_system_time);                                   
      IF base_system_time_found THEN                                                                          
        retrieve_termination_time (base_system_time);                                                         
      IFEND;                                                                                                  
                                                                                                              
      ofp$display_status_message ('processing anad command input', ignore_status);                            
                                                                                                              
      clp$include_file (clc$current_command_input, '', duc$utility_name, status);                             
      IF NOT status.normal THEN                                                                               
        EXIT /anad_utility/;  {---->                                                                          
      IFEND;                                                                                                  
                                                                                                              
      ofp$display_status_message (' ', ignore_status);                                                        
                                                                                                              
    END /anad_utility/;                                                                                       
                                                                                                              
    IF duv$execution_environment.restart_file_opened THEN                                                     
      fsp$close_file (duv$execution_environment.restart_file.file_identifier, ignore_status);                 
    IFEND;                                                                                                    
    IF duv$execution_environment.output_file_opened THEN                                                      
      clp$close_display (duv$execution_environment.output_file.display_control, ignore_status);               
    IFEND;                                                                                                    
    clp$end_utility (duc$utility_name, ignore_status);                                                        
    pmp$disestablish_cond_handler (exit_conditions, ignore_status);                                           
                                                                                                              
  PROCEND dup$analyze_dump_command;                                                                           
MODEND dum$analyze_dump_command;                                                                              
*DECK DECK=DUM$ANALYZE_LOG EXPAND=TRUE
PROCEDURE dum$analyze_log, analyze_log, analog, anal (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key
      pva, sva
    keyend = sva
  stop_on_invalid_entry, soie: boolean = TRUE
  start_at_check_byte, sacb: boolean = FALSE
  display_offsets, do: boolean = TRUE
  status)


  "$FORMAT=OFF"
  VAR
    when_status: status
  VAREND
  "$FORMAT=ON"

  WHEN any_fault DO
    when_status = $previous_status
    putl ' Invoked ANALOG condition handler due to the following abnormal status:'
    disv when_status
    putl ' Enter commands, "exit_proc" to abort, or "exit_proc with when_status" to abort with status'
    include_file command prompt='analog_ch'
  WHENEND

  "$FORMAT=OFF"
  VAR
    check_byte: integer = 0a5(16)
    dmt$device_log_entries: array 0..43 of string = (..
          ' dmc$invalid_dl_entry', ' dmc$dl_allocate', ' dmc$dl_first_sft_delete', ' dmc$dl_second_sft_delete', ..
          ' dmc$dl_third_sft_delete', ' dmc$dl_create', ' dmc$dl_return_dau', ' dmc$dl_disk_tables_updated', ..
          ' dmc$dl_attach_file', ' dmc$dl_detach_file', ' dmc$dl_initialize', ' dmc$dl_last_update_entry', ..
          ' dmc$dl_purge_file', ' dmc$dl_second_purge_file', ' dmc$dl_release_dau', ' dmc$dl_release_dfl', ..
          ' dmc$dl_return_dfl', ' dmc$dl_software_flawed', ' dmc$dl_start_update', ' dmc$dl_update_disk_tables', ..
          ' dmc$dl_update_file_length', ' dmc$dl_update_fmd_length', ' dmc$dl_file_damaged', ' dmc$dl_reallocate', ..
          ' dmc$dl_trim_file', ' dmc$dl_deallocate_file_fragment', ' dmc$dl_continue_purge', ' dmc$dl_sa_on_dl_entry', ..
          ' dmc$dl_sa_after_process_dl', ' dmc$dl_sa_bef_next_dfl_change', ' dmc$dl_sa_aft_next_dfl_change', ..
          ' dmc$dl_sa_bef_next_dat_change', ' dmc$dl_sa_aft_next_dat_change', ' dmc$dl_sa_bef_logging_dtu', ..
          ' dmc$dl_sa_bef_mf_table_update', ' dmc$dl_sa_aft_mf_table_update', ' dmc$dl_ra_on_dl_entry', ..
          ' dmc$dl_ra_after_process_dl', ' dmc$dl_ra_bef_next_dfl_change', ' dmc$dl_ra_aft_next_dfl_change', ..
          ' dmc$dl_ra_bef_next_dat_change', ' dmc$dl_ra_aft_next_dat_change', ' dmc$dl_ra_bef_logging_dtu', ..
          ' dmc$dl_recycle_dau')
    entry_length: array 0..43 of integer = (..
          0, 22 " #SIZE (dmt$dl_allocate_block)", 19 " #SIZE (dmt$dl_sft_delete_block)", 19 " #SIZE (dmt$dl_sft_delete_block)", ..
          19 " #SIZE (dmt$dl_sft_delete_block)", 27 " #SIZE (dmt$dl_create_block)", 9 " #SIZE (dmt$dl_return_dau_block)", ..
          0, 19 " #SIZE (dmt$dl_attach_file_block)", 19 " #SIZE (dmt$dl_attach_file_block)", ..
          17 " #SIZE (dmt$dl_initialize_block)", 0, 20 " #SIZE (dmt$dl_purge_file_block)", 20 " #SIZE (dmt$dl_purge_file_block)", ..
          23 " #SIZE (dmt$dl_release_dau_block)", 19 " #SIZE (dmt$dl_release_dfl_block)", 8 " #SIZE (dmt$dl_return_dfl_block)", ..
          4 " #SIZE (dmt$dl_software_flaw_block)", 0, 0, 28 " #SIZE (dmt$dl_file_length_block)", ..
          28 " #SIZE (dmt$dl_fmd_length_block)", 18 " #SIZE (dmt$dl_file_damaged_block)", 33 " #SIZE (dmt$dl_reallocate)", ..
          20 " #SIZE (dmt$dl_trim_file)", 17 " #SIZE (dmt$dl_deallocate_file_fragment)", 23 " #SIZE (dmt$dl_release_dau_block)", ..
          0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9 " #SIZE (dmt$dl_return_dau_block)")
    log_address: integer = address
    output_file: file
  VAREND
  "$FORMAT=ON"

  IF $file(output open_position) = '$BOI' THEN
    output_file = output.$asis
  ELSE
    output_file = output
  IFEND

  putl ' -- DEVICE LOG ANALYSIS -- '//$strrep(address, 16)//'(16)' o=output_file

  current_log_entry = $mem(log_address, 1, job, 0, address_mode)
  IF current_log_entry <> check_byte THEN
    IF start_at_check_byte THEN
      putl ' must start at check_byte: value found was '//$strrep(current_log_entry, 16)//'(16)' o=output_file
      EXIT_PROC
    IFEND
  ELSE
    log_address = log_address + 1
  IFEND
  current_log_entry = $mem(log_address, 1, job, 0, address_mode)

  REPEAT

    IF display_offsets THEN
      putl dmt$device_log_entries(current_log_entry)//' ('//$strrep(current_log_entry, 16)//'(16)) at '//..
$strrep(log_address, 16)//'(16)' o=output_file
    ELSE
      putl dmt$device_log_entries(current_log_entry)//' ('//$strrep(current_log_entry, 16)//'(16))' ..
            o=output_file
    IFEND

    IF current_log_entry = 0 THEN
      putl '   at '//$strrep(log_address, 16)//'(16)' o=output_file
      IF stop_on_invalid_entry THEN
        EXIT_PROC
      IFEND
    ELSEIF current_log_entry = 1 THEN
      display_allocate a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 2 THEN
      display_delete a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 3 THEN
      display_delete a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 4 THEN
      display_delete a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 5 THEN
      display_create a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 6 THEN
      display_return_dau a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 8 THEN
      display_file_att a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 9 THEN
      display_file_det a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 10 THEN
      display_initialize a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 12 THEN
      display_purge a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 13 THEN
      display_purge a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 14 THEN
      display_release_dau a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 15 THEN
      display_release_dfl a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 16 THEN
      display_return_dfl a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 17 THEN
      display_software_flaw a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 20 THEN
      display_update_file_length a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 21 THEN
      display_update_fmd_length a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 22 THEN
      display_file_damaged a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 23 THEN
      display_reallocate a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 24 THEN
      display_trim_file a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 25 THEN
      display_deallocate_fragment a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 26 THEN
      display_release_dau a=log_address o=output_file am=address_mode
    ELSEIF current_log_entry = 43 THEN
      display_return_dau a=log_address o=output_file am=address_mode
    ELSE
      IF entry_length(current_log_entry) <> 0 THEN
        putl ' error number 55:'//$strrep(log_address, 16)//'(16)' o=output_file
        EXIT_PROC
      IFEND
    IFEND

    log_address = log_address + entry_length(current_log_entry) + 1

    IF $mem(log_address, 1, job, 0, address_mode) <> check_byte THEN
      putl ' cant find check byte: '//$strrep(log_address, 16)//'(16)' o=output_file
      EXIT_PROC
    IFEND

    log_address = log_address + 1

    current_log_entry = $mem(log_address, 1, job, 0, address_mode)

  UNTIL false

PROCEND dum$analyze_log
*DECK DECK=DUM$ANALYZE_PAGE_FRAME_TABLE EXPAND=TRUE

PROC dum$analyze_page_frame_table, analyze_page_frame_table, anapft (
  output, o: file = $output
  status)

  crev s status
  crev field_offset integer
  crev field_length integer
  delf out status=s
  setfa out fc=list

  pft_entry_size = $mem($sa(mmv$pft_p)+14 4)
  pagesize = $mem($sa(osv$page_size) 3)
  pftlb = $mem($sa(mmv$pft_p)+10 4)
  pftub = ($mem($sa(mmv$pft_p)+6 4) / pft_entry_size) + pftlb - 1
  pft = $mem($sa(mmv$pft_p) 6)-pftlb*pft_entry_size

  mmt$page_frame_table_entry field=queue_id offset=field_offset length=field_length
  queue_id_offset = field_offset / 8
  mmt$page_frame_table_entry field=pti offset=field_offset length=field_length
  pti_offset = field_offset / 8
  mmt$page_frame_table_entry field=sva offset=field_offset length=field_length
  sva_offset = field_offset / 8

  putl ' ANALYZE PAGE FRAME TABLE ' o=out.$eoi
  FOR pfti = pftlb to pftub do
    pftp = pft+pft_entry_size*pfti
    queueid = $mem(pftp+queue_id_offset 1)
    pti = $mem(pftp+pti_offset 3)
    ptasid = $mem(pti*8 3) / 16
    ptasid = ptasid - (ptasid / 10000(16)) * 10000(16)
    ptpfti = $mem(pti*8+5 3)
    ptpfti = (ptpfti - (ptpfti / 400000(16)) * 400000(16))*512/pagesize
    pftasid = $mem(pftp+sva_offset 2)

    IF queueid = 0 THEN
      IF pftasid <> 0 then
        putl ' Non-zero ASID in PFT entry in free queue, PFTI = '//$strrep(pfti 16) o=out.$eoi
      IFEND
      IF (ptasid <> 0) AND (ptpfti = pfti) then
        putl ' PT entry still exists but PFT entry in free queue, PFTI = '//$strrep(pfti 16) o=out.$eoi
      IFEND
    ELSEIF pftasid <> 0 THEN
      pftoffset = $mem(pftp+sva_offset+2 4)
      ptoffset = $mem(pti*8+1 7)/400000(16)
      ptoffset = (ptoffset - (ptoffset/400000(16)) * 400000(16)) * 512
      IF (ptasid <> pftasid) OR (ptpfti <> pfti) OR (ptoffset <> pftoffset) THEN
        putl ' PFT/PT mismatch at PFTI = '//$strrep(pfti 16) o=out.$eoi
"       disv (ptasid pftasid ptpfti pfti ptoffset pftoffset) "
      IFEND
    IFEND
  FOREND
  copf out $value(output)

PROCEND dum$analyze_page_frame_table

*DECK DECK=DUM$ANALYZE_PAGE_TABLE EXPAND=TRUE

PROC dum$analyze_page_table, analyze_page_table, anapt (
  output, o: file = $output
  status)

  crev stat status
  crev field_offset integer
  crev field_length integer
  delf out status=stat
  setfa out fc=list

  ptl = $mem($sa(mmv$pt_length) 8)
  pft = $mem($sa(mmv$pft_p) 6)
  pft_entry_size = $mem($sa(mmv$pft_p)+14 4)
  pftlb = $mem($sa(mmv$pft_p)+10 4)
  pftub = ($mem($sa(mmv$pft_p)+6 4) / pft_entry_size) + pftlb - 1
  pft = pft - pft_entry_size * pftlb

  mmt$page_frame_table_entry field=pti offset=field_offset length=field_length
  pti_offset = field_offset / 8
  mmt$page_frame_table_entry field=sva offset=field_offset length=field_length
  sva_offset = field_offset / 8

  putl ' ANALYZE PAGE TABLE ' o=out.$eoi
  FOR i = 0 TO ptl - 1 DO
    asid = $mem(i*8 3) / 16
    asid = asid - (asid / 10000(16)) * 10000(16)
    IF (asid <> 0) THEN
      pfti = $mod($mem(i*8+5 3) 400000(16)) * 512 / $mem($sa(osv$page_size) 3)
      IF (pfti >= pftlb) AND (pfti <= pftub) THEN
        IF $mem(pft+pft_entry_size*pfti+pti_offset 3) <> i THEN
          putl 'Bad pft index at pfti = '//$strrep(pfti 16)//', pti = '//$strrep(i 16) o=out.$eoi
        IFEND
        IF $mem(pft+pft_entry_size*pfti+sva_offset 2) <> asid THEN
          putl 'Bad ASID at pfti = '//$strrep(pfti 16)//', ASID = '//$strrep(asid 16) o=out.$eoi
        IFEND
      IFEND
    IFEND
  FOREND
  copf out $value(output)

PROCEND dum$analyze_page_table

*DECK DECK=DUM$ANALYZE_SYSTEM EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Analyze System' ??
MODULE dum$analyze_system;

{ PURPOSE:
{
{   This module contains the entry point for the Analyze System utility and some
{   of the command and function processors.  The Analyze System utility provides
{   the ability to access memory in the running system using commands and
{   functions that are similar to those provided by the Analyze Dump utility.
{   Only PVA mode addressing is supported, and only for PVA's contained in the
{   address space of the task running Analyze System.  Since much of NOS/VE is
{   addressable as PVA's in all tasks, however, this is a very useful subset.
{
{ DESIGN:
{
{   The command and function tables for the Analyze System utility are defined
{   in separate modules and are referenced as externals in this module.
{
{   Access to NOS/VE system memory is provided to this module by the
{   dup$move_bytes interface.  This module in turn provides memory access for
{   the Symbolic Access modules through the dup$get_bytes interface.  The
{   dup$get_bytes interface is placed in this module to make sure it gets loaded
{   and linked to rather than the version with the same name that performs the
{   same function in the context of Analyze Dump.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$page_widths
*copyc clc$standard_file_names
*copyc duc$dump_analyzer_constants
*copyc due$exception_condition_codes
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc clp$begin_utility
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc dup$move_bytes
*copyc fsp$close_file
*copyc fsp$open_file
*copyc ocp$open_running_debug_table
*copyc ofp$display_status_message
*copyc osp$append_status_integer
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$format_message
*copyc osp$get_message_level
*copyc osp$set_status_abnormal
*copyc pmp$get_legible_date_time
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??
  CONST
    c$utility_name = 'ANALYZE_SYSTEM                 ',
    c$prompt_string = 'as',
    c$version = 'Analyze_system (V1.0)';

  TYPE
    t$address_parameter = record
      case 0 .. 1 of
      = 0 =
        fill1: 0 .. 0ffff(16),
        pva: ost$pva,
      = 1 =
        value: integer,
      casend,
    recend;

  TYPE
    s0to63 = set of 0..63;
?? EJECT ??

  VAR
    v$control_codes_to_space: [READ] string (256) := '            '
      CAT '                     !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijkl'
      CAT 'mnopqrstuvwxyz{|}~                                                                                '
      CAT '                                                 ';

  VAR
    v$command_name: [STATIC] string (osc$max_name_size),
    v$title: [STATIC] string (25) := c$version,
    v$titles_built: [STATIC] boolean,
    wide_title: [STATIC] string (clc$wide_page_width),
    narrow_title1,
    narrow_title2: [STATIC] string (clc$narrow_page_width),
    wide: [STATIC] boolean,
    page_width: [STATIC] integer;
?? TITLE := '  dup$get_bytes', EJECT ??
{ Procedure dup$get_bytes is located in module dum$analyze_system to make sure
{ it gets loaded and linked to rather than the version with the same name that
{ performs the same function in the context of Analyze Dump.

  PROCEDURE [XDCL] dup$get_bytes (source: ost$pva;
        destination: ^cell;
        length: 0..7fffffff(16);
    VAR status: ost$status);

    VAR
      s: ost$pva;

    s := source;

    IF (s.ring = osc$invalid_ring) THEN {local address flag}
      s.ring := osc$min_ring;
    IFEND;

    dup$move_bytes (#ADDRESS (s.ring, s.seg, s.offset), destination, length, status);
  PROCEND dup$get_bytes;
?? TITLE := '  dup$analyze_system', EJECT ??

  PROGRAM dup$analyze_system (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE analyze_system, anas (
{   title, t: string 1..25 = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 28, 11, 15, 23, 909],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['STATUS                         ',clc$nominal_entry, 2],
    ['T                              ',clc$abbreviation_entry, 1],
    ['TITLE                          ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [1, 25, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$title = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

*copy duv$anas_functions
*copy duv$anas_commands


    VAR
      p_attributes: ^clt$utility_attributes;


    PROCEDURE exit_condition_handler (exit_condition: pmt$condition;
          exit_condition_descriptor: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

      VAR
        utility_status: ost$status;

      condition_status.normal := TRUE;
      CASE exit_condition.selector OF
      = pmc$block_exit_processing =
        clp$end_utility (c$utility_name, utility_status);
        ofp$display_status_message (' ', utility_status);
      ELSE
      CASEND;
    PROCEND exit_condition_handler;


?? NEWTITLE := '    Main routine', EJECT ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$title].specified THEN
      v$title := pvt [p$title].value^.string_value^;
    IFEND;

    ocp$open_running_debug_table (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^exit_condition_handler);

    PUSH p_attributes: [1 .. 4];
    p_attributes^ [1].key := clc$utility_command_search_mode;
    p_attributes^ [1].command_search_mode := clc$global_command_search;
    p_attributes^ [2].key := clc$utility_command_table;
    p_attributes^ [2].command_table := duv$anas_commands;
    p_attributes^ [3].key := clc$utility_function_proc_table;
    p_attributes^ [3].function_processor_table := duv$anas_functions;
    p_attributes^ [4].key := clc$utility_prompt;
    p_attributes^ [4].prompt.value := c$prompt_string;
    p_attributes^ [4].prompt.size := STRLENGTH (c$prompt_string);

    clp$begin_utility (c$utility_name, p_attributes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ofp$display_status_message ('processing command input', status);
    clp$include_file (clc$current_command_input, '', c$utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    ofp$display_status_message (' ', status);

    clp$end_utility (c$utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$disestablish_cond_handler;
  PROCEND dup$analyze_system;
?? OLDTITLE ??
?? TITLE := '  build_standard_title', EJECT ??

  PROCEDURE build_standard_title (wide: boolean;
        command_name: string (osc$max_name_size);
    VAR wide_title: string (clc$wide_page_width);
    VAR narrow_title1: string (clc$narrow_page_width);
    VAR narrow_title2: string (clc$narrow_page_width);
    VAR status: ost$status);

    CONST
      max_date_time_length = 18;

    VAR
      date_substring: string (max_date_time_length),
      time_substring: string (max_date_time_length),
      date: ost$date,
      time: ost$time;


    PROCEDURE assign_date (VAR substr: string ( * );
          date: ost$date);


      substr := '';
      CASE date.date_format OF
      = osc$month_date =
        substr := date.month;
      = osc$mdy_date =
        substr := date.mdy;
      = osc$iso_date =
        substr := date.iso;
      = osc$ordinal_date =
        substr := date.ordinal;
      = osc$dmy_date =
        substr := date.dmy;
      CASEND;

    PROCEND assign_date;


    PROCEDURE assign_time (VAR substr: string ( * );
          time: ost$time);

      substr := '';
      CASE time.time_format OF
      = osc$ampm_time =
        substr := time.ampm;
      = osc$hms_time =
        substr := time.hms;
      = osc$millisecond_time =
        substr := time.millisecond;
      CASEND;

    PROCEND assign_time;


    pmp$get_legible_date_time (osc$default_date, date, osc$default_time, time,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF wide THEN

      wide_title := '';
      wide_title (1, 25) := v$title;
      wide_title (41, 31) := command_name;
      assign_date (date_substring, date);
      wide_title (90, 18) := date_substring;
      assign_time (time_substring, time);
      wide_title (109, 12) := time_substring;
      wide_title (122, 5) := 'PAGE ';

    ELSE

      narrow_title1 := '';
      narrow_title2 := '';
      narrow_title1 (1, 25) := v$title;
      narrow_title1 (28, 31) := command_name;
      narrow_title1 (62, 5) := 'PAGE ';
      assign_date (date_substring, date);
      narrow_title2 (1, 18) := date_substring;
      assign_time (time_substring, time);
      narrow_title2 (21, 12) := time_substring;

    IFEND;


  PROCEND build_standard_title;
?? TITLE := '  dup$anas_copy_memory_command', EJECT ??
  PROCEDURE [XDCL] dup$anas_copy_memory_command (parameter_list:
    clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE copy_memory, copm (
{   address, a: integer = $required
{   file, f: file = $required
{   byte_count, bc: integer 0..osc$max_segment_length = 100000(16)
{   exchange, e: any of
{       key
{         (active, a)
{         (monitor, m)
{         (job, j)
{       keyend
{       integer 0..0ffffffff(16)
{     anyend = active
{   processor, p: integer 0..3 = 0
{   address_mode, am: key
{       (process_virtual_address, pva)
{     keyend = process_virtual_address
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (10),
      recend,
      type4: 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 .. 6] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (6),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (23),
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 28, 11, 34, 32, 838],
    clc$command, 13, 7, 2, 0, 0, 0, 7, ''], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['ADDRESS                        ',clc$nominal_entry, 1],
    ['ADDRESS_MODE                   ',clc$nominal_entry, 6],
    ['AM                             ',clc$abbreviation_entry, 6],
    ['BC                             ',clc$abbreviation_entry, 3],
    ['BYTE_COUNT                     ',clc$nominal_entry, 3],
    ['E                              ',clc$abbreviation_entry, 4],
    ['EXCHANGE                       ',clc$nominal_entry, 4],
    ['F                              ',clc$abbreviation_entry, 2],
    ['FILE                           ',clc$nominal_entry, 2],
    ['P                              ',clc$abbreviation_entry, 5],
    ['PROCESSOR                      ',clc$nominal_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 7]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 10],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 269,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 5
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 6
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81,
  clc$optional_default_parameter, 0, 23],
{ PARAMETER 7
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, osc$max_segment_length, 10],
    '100000(16)'],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    229, [[1, 0, clc$keyword_type], [6], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['MONITOR                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]]
    ,
    'active'],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [0, 3, 10],
    '0'],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [2], [
    ['PROCESS_VIRTUAL_ADDRESS        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['PVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1]]
    ,
    'process_virtual_address'],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$address = 1,
      p$file = 2,
      p$byte_count = 3,
      p$exchange = 4,
      p$processor = 5,
      p$address_mode = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

    VAR
      attachment: [STATIC, READ] array [1 .. 1] of fst$attachment_option := [[fsc$access_and_share_modes,
            [fsc$specific_access_modes, [fsc$read, fsc$shorten, fsc$append, fsc$modify]],
            [fsc$determine_from_access_modes]]],
      attributes: [STATIC, READ] array [1 .. 1] of fst$file_cycle_attribute :=
            [[fsc$record_type, amc$undefined]],
      address: t$address_parameter,
      bytes: ost$segment_length,
      bytes_returned: ost$segment_length,
      copy_count: integer,
      fid: amt$file_identifier,
      file_open: boolean,
      file_pointer: amt$segment_pointer,
      local_status: ost$status,
      memory_buffer: ^SEQ ( * );

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      clean_up;

    PROCEND abort_handler;
?? OLDTITLE ??
?? NEWTITLE := '    clean_up', EJECT ??

    PROCEDURE [INLINE] clean_up;

      VAR ignore_status: ost$status;

      IF file_open THEN
        fsp$close_file (fid, ignore_status);
      IFEND;

    PROCEND clean_up;
?? TITLE := '    main routine', EJECT ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    address.value := pvt [p$address].value^.integer_value.value;

    file_open := false;
    osp$establish_block_exit_hndlr (^abort_handler);

    bytes := pvt [p$byte_count].value^.integer_value.value;

    fsp$open_file (pvt [p$file].value^.file_value^, amc$segment, ^attachment, ^attributes, NIL, NIL, NIL, fid,
         status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    file_open := true;
    amp$get_segment_pointer (fid, amc$sequence_pointer, file_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    memory_buffer := NIL;
    IF (file_pointer.sequence_pointer <> NIL) THEN
      RESET file_pointer.sequence_pointer;
      NEXT memory_buffer: [[REP bytes OF cell]] IN file_pointer.sequence_pointer;
    IFEND;

    IF (memory_buffer = NIL) THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer,
            'getting pointer to file for memory copy.', status);
    ELSE
      copy_count := bytes;
      RESET file_pointer.sequence_pointer;

      REPEAT
        NEXT memory_buffer:[[REP copy_count OF cell]] IN file_pointer.sequence_pointer;
        RESET memory_buffer;

        IF (copy_count > 16384) THEN
          bytes_returned := 16384;
        ELSE
          bytes_returned := copy_count;
        IFEND;

        dup$move_bytes (#address (1, address.pva.seg, address.
              pva.offset), #LOC (memory_buffer^), bytes_returned, status);

        IF status.normal THEN
          copy_count := copy_count - bytes_returned;

          IF (copy_count > 0) THEN
            RESET file_pointer.sequence_pointer TO memory_buffer;
            NEXT memory_buffer: [[REP bytes_returned of cell]] IN
                  file_pointer.sequence_pointer;
            address.pva.offset := address.pva.offset + bytes_returned;
          IFEND;
        ELSE
          copy_count := 0;
          RESET file_pointer.sequence_pointer TO memory_buffer;
          amp$set_segment_eoi (fid, file_pointer, local_status);
        IFEND;
      UNTIL copy_count <= 0;

      IF status.normal THEN
        amp$set_segment_eoi (fid, file_pointer, status);
      IFEND;
    IFEND;

    fsp$close_file (fid, local_status);
    IF (status.normal AND NOT local_status.normal) THEN
      status := local_status;
    IFEND;

    osp$disestablish_cond_handler;
  PROCEND dup$anas_copy_memory_command;
?? OLDTITLE ??
?? TITLE := '  display_memory', EJECT ??

  PROCEDURE display_memory (VAR display_control:
    clt$display_control;
        memory_parameter: ^SEQ ( * );
        bytes: integer;
        start_address: ost$segment_offset;
        numeric_display: boolean;
        ascii_display: boolean;
    VAR status: ost$status);

    PROCEDURE [inline] convert_byte_to_hex_string (byte: 0 .. 0ff(16);
      VAR str: string (2));

      VAR
        ptr: ^packed record
          left: 0 .. 0f(16),
          right: 0 .. 0f(16)
        recend;

      ptr := #LOC (byte);
      str (1) := hex_chars [ptr^.left];
      str (2) := hex_chars [ptr^.right];

    PROCEND convert_byte_to_hex_string;

    CONST
      bytes_in_item = 8,
      size_of_address = 8,
      spaces_bet_ad_and_display = 3,
      fixed = size_of_address + spaces_bet_ad_and_display,
      space_for_numeric_byte = 2;

    VAR
      ascii_tab_column: 1 .. 256,
      byte: ^0 .. 0ff(16),
      byte_count: 1 .. 2,
      bytes_displayed: integer,
      bytes_this_line: 0 .. 132,
      char_index: 0 .. 255,
      current_item: 1 .. 63,
      display_address: ost$segment_length,
      first_item: ^cell,
      first_line: boolean,
      half_words: 1 .. 2,
      half_half_words: 1 .. 2,
      hex_chars: [static] array [0 .. 0f(16)] of char :=
         ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A',
          'B', 'C', 'D', 'E', 'F'],
      item_ascii: ^string ( * ),
      items_per_line: 0 .. 100,
      line_buffer: ^string ( * ),
      line_index: 1 .. 256,
      local_status: ost$status,
      memory: ^SEQ ( * ),
      page_width: amt$page_width,
      previous_line: ^string ( * ),
      repeated_lines: integer,
      space_for_numeric_item: 0 .. 132,
      space_for_ascii_item: 0 .. 132;

    memory := memory_parameter;

    IF display_control.page_width > 132 THEN
      page_width := 132;
    ELSEIF display_control.page_width < 40 THEN
      page_width := 40;
    ELSE
      page_width := display_control.page_width;
    IFEND;


    IF numeric_display THEN
      space_for_numeric_item := bytes_in_item * space_for_numeric_byte + 6;
    ELSE
      space_for_numeric_item := 0;
    IFEND;
    IF ascii_display THEN
      space_for_ascii_item := bytes_in_item;
    ELSE
      space_for_ascii_item := 0;
    IFEND;

    items_per_line := (page_width - fixed) DIV (space_for_ascii_item +
          space_for_numeric_item);
    IF items_per_line = 0 THEN
      items_per_line := 1;
      page_width := fixed + space_for_ascii_item + space_for_numeric_item;
    IFEND;
    ascii_tab_column := fixed + (items_per_line * space_for_numeric_item) + 1;

    PUSH line_buffer: [page_width];
    PUSH previous_line: [page_width];
    IF (line_buffer = NIL) OR (previous_line = NIL) THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer,
        'processing display_memory', status);
      RETURN;
    IFEND;

    previous_line^ := ' ';
    repeated_lines := 0;
    display_address := start_address;
    bytes_displayed := 0;
    bytes_this_line := items_per_line * space_for_ascii_item;
    first_line := TRUE;

  /display_items/
    WHILE TRUE DO
      line_buffer^ := ' ';
      line_index := 1;
      clp$convert_integer_to_rjstring (display_address, 16, FALSE, '0',
            line_buffer^ (line_index, size_of_address), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      line_index := line_index + size_of_address + spaces_bet_ad_and_display;
      NEXT byte IN memory;
      IF byte = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer,
          'processing display_memory', status);
        RETURN;
      IFEND;
      first_item := byte;
      RESET memory TO first_item;

      IF numeric_display THEN
        bytes_this_line := 0;

      /format_numeric/
        FOR current_item := 1 TO items_per_line DO
          FOR half_words := 1 TO 2 DO
            FOR half_half_words := 1 TO 2 DO
              FOR byte_count := 1 TO 2 DO
                NEXT byte IN memory;
                IF byte = NIL THEN
                  osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer,
                        'processing display_memory', status);
                  RETURN;
                IFEND;
                convert_byte_to_hex_string (byte^, line_buffer^
                       (line_index, 2));
                line_index := line_index + 2;
                bytes_this_line := bytes_this_line + 1;
                bytes_displayed := bytes_displayed + 1;
                IF bytes_displayed >= bytes THEN
                  IF first_line THEN
                    line_index := line_index + 3;
                  ELSE
                    line_index := ascii_tab_column;
                  IFEND;
                  EXIT /format_numeric/;
                IFEND;
              FOREND;
              line_index := line_index + 1;
            FOREND;
          FOREND;
          line_index := line_index + 2;
        FOREND /format_numeric/;
      IFEND;
      IF ascii_display THEN
        IF NOT numeric_display THEN
          IF (bytes - bytes_displayed) < bytes_this_line THEN
            bytes_this_line := bytes - bytes_displayed;
          IFEND;
          bytes_displayed := bytes_displayed + bytes_this_line;
        IFEND;
        RESET memory TO first_item;
        NEXT item_ascii: [bytes_this_line] IN memory;
        IF item_ascii = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer,
            'processing display_memory', status);
          RETURN;
        IFEND;
        #translate (v$control_codes_to_space, item_ascii^, line_buffer^
              (line_index, bytes_this_line));
      IFEND;
      IF ((line_buffer^ (size_of_address + 1, * )) = (previous_line^
            (size_of_address + 1, * ))) AND (bytes_displayed < bytes) THEN
        previous_line^ := line_buffer^;
        repeated_lines := repeated_lines + 1;
      ELSE
        IF repeated_lines > 1 THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$skipped_lines, '', local_status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                repeated_lines, 10, FALSE, local_status);
          display_status_message (local_status, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSEIF repeated_lines = 1 THEN
          clp$put_display (display_control, previous_line^, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        repeated_lines := 0;
        clp$put_display (display_control, line_buffer^, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        previous_line^ := line_buffer^;
      IFEND;
      display_address := display_address + bytes_this_line;
      IF bytes_displayed >= bytes THEN
        EXIT /display_items/;
      IFEND;
      first_line := FALSE;
    WHILEND /display_items/;


  PROCEND display_memory;
?? TITLE := '  dup$anas_display_memory_command', EJECT??

  PROCEDURE [XDCL] dup$anas_display_memory_command (parameter_list:
    clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE display_memory, dism (
{   address, a: integer = $required
{   bytes, b: integer 0..duc$maximum_memory_display = 8
{   exchange, e: any of
{       key
{         (active, a)
{         (monitor, m)
{         (job, j)
{       keyend
{       integer 0..0ffffffff(16)
{     anyend = active
{   processor, p: integer 0..3 = 0
{   address_mode, am: key
{       (process_virtual_address, pva)
{     keyend = process_virtual_address
{   display_option, do: list 1..2 of key
{       (numeric, n)
{       (ascii, a)
{     keyend = (numeric,    ascii)
{   title, t: string 1..31 = 'display_memory'
{   radix, r: integer 8..16 = 16
{   repeat_count, rc: integer = 0
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 21] of clt$pdt_parameter_name,
      parameters: array [1 .. 11] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: 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 .. 6] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (6),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (23),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        default_value: string (19),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (16),
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (2),
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type10: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type11: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 28, 15, 35, 18, 789],
    clc$command, 21, 11, 1, 0, 0, 0, 11, ''], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['ADDRESS                        ',clc$nominal_entry, 1],
    ['ADDRESS_MODE                   ',clc$nominal_entry, 5],
    ['AM                             ',clc$abbreviation_entry, 5],
    ['B                              ',clc$abbreviation_entry, 2],
    ['BYTES                          ',clc$nominal_entry, 2],
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 6],
    ['DO                             ',clc$abbreviation_entry, 6],
    ['E                              ',clc$abbreviation_entry, 3],
    ['EXCHANGE                       ',clc$nominal_entry, 3],
    ['O                              ',clc$abbreviation_entry, 10],
    ['OUTPUT                         ',clc$nominal_entry, 10],
    ['P                              ',clc$abbreviation_entry, 4],
    ['PROCESSOR                      ',clc$nominal_entry, 4],
    ['R                              ',clc$abbreviation_entry, 8],
    ['RADIX                          ',clc$nominal_entry, 8],
    ['RC                             ',clc$abbreviation_entry, 9],
    ['REPEAT_COUNT                   ',clc$nominal_entry, 9],
    ['STATUS                         ',clc$nominal_entry, 11],
    ['T                              ',clc$abbreviation_entry, 7],
    ['TITLE                          ',clc$nominal_entry, 7]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 269,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 4
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81,
  clc$optional_default_parameter, 0, 23],
{ PARAMETER 6
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 171,
  clc$optional_default_parameter, 0, 19],
{ PARAMETER 7
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 16],
{ PARAMETER 8
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 9
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 10
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 11
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, duc$maximum_memory_display, 10],
    '8'],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    229, [[1, 0, clc$keyword_type], [6], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['MONITOR                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]]
    ,
    'active'],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [0, 3, 10],
    '0'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [2], [
    ['PROCESS_VIRTUAL_ADDRESS        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['PVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1]]
    ,
    'process_virtual_address'],
{ PARAMETER 6
    [[1, 0, clc$list_type], [155, 1, 2, FALSE],
      [[1, 0, clc$keyword_type], [4], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['ASCII                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['NUMERIC                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    '(numeric,    ascii)'],
{ PARAMETER 7
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_memory'''],
{ PARAMETER 8
    [[1, 0, clc$integer_type], [8, 16, 10],
    '16'],
{ PARAMETER 9
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10],
    '0'],
{ PARAMETER 10
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 11
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$address = 1,
      p$bytes = 2,
      p$exchange = 3,
      p$processor = 4,
      p$address_mode = 5,
      p$display_option = 6,
      p$title = 7,
      p$radix = 8,
      p$repeat_count = 9,
      p$output = 10,
      p$status = 11;

    VAR
      pvt: array [1 .. 11] of clt$parameter_value;

    CONST
      ascii = 'ASCII                          ',
      numeric = 'NUMERIC                        ';

    VAR
      address: t$address_parameter,
      ascii_display: boolean,
      buffer_size: ost$segment_length,
      bytes: ost$segment_length,
      bytes_returned: ost$segment_length,
      display_control: clt$display_control,
      display_count: integer,
      len: integer,
      local_status: ost$status,
      memory_buffer: ^SEQ ( * ),
      numeric_display: boolean,
      output_open: boolean,
      p_element: ^clt$data_value,
      p_list: ^clt$data_value,
      radix: 8 .. 16,
      rc: integer,
      repeat_count: integer,
      ring_attributes: amt$ring_attributes,
      str: string (osc$max_string_size);

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      clean_up;

    PROCEND abort_handler;
?? OLDTITLE ??
?? NEWTITLE := '    clean_up', EJECT ??

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_open THEN
        clp$close_display (display_control, ignore_status);
        output_open := FALSE;
      IFEND;

    PROCEND clean_up;
?? TITLE := '    main routine', EJECT ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    address.value := pvt [p$address].value^.integer_value.value;
    repeat_count := pvt [p$repeat_count].value^.integer_value.value;

    numeric_display := FALSE;
    ascii_display := FALSE;

    p_list := pvt [p$display_option].value;
    WHILE (p_list <> NIL) DO
      p_element := p_list^.element_value;
      p_list := p_list^.link;
      IF (p_element <> NIL) THEN
        IF (p_element^.keyword_value = numeric) THEN
          numeric_display := TRUE;
        ELSEIF (p_element^.keyword_value = ascii) THEN
          ascii_display := TRUE;
        IFEND;
      IFEND;
    WHILEND;

    output_open := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^new_page_procedure, fsc$list,
          ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output_open := TRUE;

    v$titles_built := FALSE;
    v$command_name := pvt [p$title].value^.string_value^;

    bytes := pvt [p$bytes].value^.integer_value.value;

    IF bytes > duc$maximum_memory_display THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$memory_display_overflow, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            duc$maximum_memory_display, 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, bytes, 10,
            FALSE, status);
      RETURN;
    ELSEIF bytes = 0 THEN
      RETURN;
    IFEND;

    radix := pvt [p$radix].value^.integer_value.value;
    IF (radix <> 16) AND ((bytes MOD 8) <> 0) THEN
      bytes := bytes + (8 - (bytes MOD 8));
    IFEND;
    buffer_size := bytes;
    IF radix = 8 THEN
      address.value := address.value - (address.value MOD 8);
    IFEND;

    STRINGREP (str, len, 'segment =', address.pva.seg: #(16));
    clp$put_display (display_control, str(1, len), clc$no_trim, status);

    PUSH memory_buffer: [[REP buffer_size OF cell]];
    IF memory_buffer = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer,
        'getting buffer for memory to be displayed.', status);
      RETURN;
    IFEND;

    FOR rc := 0 TO repeat_count DO
      display_count := bytes;

      REPEAT
        RESET memory_buffer;

        IF (display_count > 16384) THEN
          bytes_returned := 16384;
        ELSE
          bytes_returned := display_count;
        IFEND;

        dup$move_bytes (#address (1, address.pva.seg, address.
              pva.offset), #LOC (memory_buffer^), bytes_returned, status);

        IF NOT status.normal THEN
          clean_up;
          RETURN;
        IFEND;

        IF bytes_returned > 0 THEN
          RESET memory_buffer;
          IF radix = 16 THEN
            display_memory (display_control, memory_buffer, bytes_returned,
                  address.pva.offset, numeric_display, ascii_display, status);
          ELSE
            display_octal_memory (display_control, memory_buffer,
                  bytes_returned, address.pva.offset, numeric_display,
                  ascii_display, radix, status);
          IFEND;
          IF NOT status.normal THEN
            clean_up;
            RETURN;
          IFEND;
        IFEND;

        display_count := display_count - bytes_returned;
        address.pva.offset := address.pva.offset + bytes_returned;
      UNTIL display_count <= 0;
    FOREND;

    clean_up;

    osp$disestablish_cond_handler;
  PROCEND dup$anas_display_memory_command;
?? OLDTITLE ??
?? TITLE := '  display_octal_memory', EJECT ??

  PROCEDURE display_octal_memory (VAR display_control:
    clt$display_control;
        octal_memory_parameter: ^SEQ ( * );
        bytes: integer;
        start_address: ost$segment_offset;
        numeric_display: boolean;
        ascii_display: boolean;
        radix: 8 .. 16;
    VAR status: ost$status);

    CONST
      bytes_in_item = 8,
      size_of_address = 8,
      spaces_bet_ad_and_display = 2,
      fixed = size_of_address + spaces_bet_ad_and_display,
      space_for_numeric_word = 30;

    VAR
      ascii_tab_column: 1 .. 256,
      byte_count: 1 .. 2,
      bytes_displayed: integer,
      bytes_this_line: 0 .. 132,
      char_index: 0 .. 255,
      current_item: 1 .. 63,
      display_address: ost$segment_length,
      first_item: ^cell,
      first_line: boolean,
      half_words: 1 .. 2,
      half_half_words: 1 .. 2,
      item_ascii: ^string ( * ),
      items_per_line: 0 .. 100,
      line_buffer: ^string ( * ),
      line_index: 1 .. 256,
      local_status: ost$status,
      octal_memory: ^SEQ ( * ),
      ost_str: ost$string,
      page_width: amt$page_width,
      previous_line: ^string ( * ),
      repeated_lines: integer,
      space_for_numeric_item: 0 .. 132,
      space_for_ascii_item: 0 .. 132,
      word_index: 1 .. 22,
      word_str: string (22),
      temp_word: record
        case boolean of
        = true =
          value: integer,
        = false =
          s: s0to63,
        casend,
      recend,
      word: ^record
        case boolean of
        = true =
          value: integer,
        = false =
          s: s0to63,
        casend,
      recend;

    octal_memory := octal_memory_parameter;

    IF display_control.page_width > 132 THEN
      page_width := 132;
    ELSEIF display_control.page_width < 40 THEN
      page_width := 40;
    ELSE
      page_width := display_control.page_width;
    IFEND;


    IF numeric_display THEN
      space_for_numeric_item := space_for_numeric_word;
    ELSE
      space_for_numeric_item := 0;
    IFEND;
    IF ascii_display THEN
      space_for_ascii_item := bytes_in_item;
    ELSE
      space_for_ascii_item := 0;
    IFEND;

    items_per_line := (page_width - fixed) DIV (space_for_ascii_item +
          space_for_numeric_item);
    IF items_per_line = 0 THEN
      items_per_line := 1;
      page_width := fixed + space_for_ascii_item + space_for_numeric_item;
    IFEND;
    ascii_tab_column := fixed + (items_per_line * space_for_numeric_item) + 1;

    PUSH line_buffer: [page_width];
    PUSH previous_line: [page_width];
    IF (line_buffer = NIL) OR (previous_line = NIL) THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer,
        'processing display_memory', status);
      RETURN;
    IFEND;

    previous_line^ := ' ';
    repeated_lines := 0;
    display_address := start_address;
    bytes_displayed := 0;
    bytes_this_line := items_per_line * space_for_ascii_item;
    first_line := TRUE;

  /display_octal/
    WHILE TRUE DO
      line_buffer^ := ' ';
      line_index := 1;
      clp$convert_integer_to_rjstring (display_address, 16, FALSE, '0',
            line_buffer^ (line_index, size_of_address), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      line_index := line_index + size_of_address + spaces_bet_ad_and_display;
      NEXT word IN octal_memory;
      IF word = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer,
          'processing display_memory', status);
        RETURN;
      IFEND;
      first_item := word;
      RESET octal_memory TO first_item;

      IF numeric_display THEN
        bytes_this_line := 0;

      /format_octal/
        FOR current_item := 1 TO items_per_line DO
          NEXT word IN octal_memory;
          IF word = NIL THEN
            osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer,
                  'processing display_memory', status);
            RETURN;
          IFEND;
          IF (radix = 8) AND  (word^.value < 0) THEN
            temp_word.s := word^.s - $s0to63[0];
            clp$convert_integer_to_rjstring (temp_word.value,  radix, FALSE, '0',
                  word_str, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            word_str (1) := '1';
          ELSEIF radix = 8  THEN
            clp$convert_integer_to_rjstring (word^.value,  radix, FALSE, '0',
                  word_str, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSE
            clp$convert_integer_to_string (word^.value,  radix, FALSE,
                  ost_str, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            word_str := '';
            word_str (strlength(word_str) - ost_str.size + 1, ost_str.size)
                  := ost_str.value (1, ost_str.size);
          IFEND;
          line_buffer^ (line_index, 2) := word_str (1, 2);
          line_index := line_index + 3;
          FOR half_words := 1 TO 2 DO
            FOR half_half_words := 1 TO 2 DO
              word_index := 3 + ((half_words - 1) * 10) + ((half_half_words
                    - 1) * 5);
              line_buffer^ (line_index, 5) := word_str (word_index, 5);
              line_index := line_index + 6;
            FOREND;
            line_index := line_index + 1;
          FOREND;
          line_index := line_index + 1;
          bytes_this_line := bytes_this_line + 8;
          bytes_displayed := bytes_displayed + 8;
          IF bytes_displayed >= bytes THEN
            IF NOT first_line THEN
              line_index := ascii_tab_column;
            IFEND;
            EXIT /format_octal/;
          IFEND;
        FOREND /format_octal/;
      IFEND;
      IF ascii_display THEN
        IF NOT numeric_display THEN
          IF (bytes - bytes_displayed) < bytes_this_line THEN
            bytes_this_line := bytes - bytes_displayed;
          IFEND;
          bytes_displayed := bytes_displayed + bytes_this_line;
        IFEND;
        RESET octal_memory TO first_item;
        NEXT item_ascii: [bytes_this_line] IN octal_memory;
        IF item_ascii = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer,
            'processing display_memory', status);
          RETURN;
        IFEND;
        #translate (v$control_codes_to_space, item_ascii^, line_buffer^
              (line_index, bytes_this_line));
      IFEND;
      IF ((line_buffer^ (size_of_address + 1, * )) = (previous_line^
            (size_of_address + 1, * ))) AND (bytes_displayed < bytes) THEN
        previous_line^ := line_buffer^;
        repeated_lines := repeated_lines + 1;
      ELSE
        IF repeated_lines > 1 THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$skipped_lines, '', local_status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                repeated_lines, 10, FALSE, local_status);
          display_status_message (local_status, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSEIF repeated_lines = 1 THEN
          clp$put_display (display_control, previous_line^, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        repeated_lines := 0;
        clp$put_display (display_control, line_buffer^, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        previous_line^ := line_buffer^;
      IFEND;
      display_address := display_address + bytes_this_line;
      IF bytes_displayed >= bytes THEN
        EXIT /display_octal/;
      IFEND;
      first_line := FALSE;
    WHILEND /display_octal/;


  PROCEND display_octal_memory;
?? TITLE := '  display_status_message', EJECT ??

  PROCEDURE display_status_message (status_message: ost$status;
    VAR display_control: clt$display_control;
    VAR status: ost$status);

    VAR
      line_counter: ost$status_message_line_count,
      line_count: ^ost$status_message_line_count,
      line_size: ^ost$status_message_line_size,
      message: ^ost$status_message,
      message_level: ost$status_message_level,
      message_width: ost$max_status_message_line,
      message_line: ^string ( * );

    osp$get_message_level (message_level, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    PUSH message;
    RESET message;
    IF display_control.page_width < LOWERVALUE (message_width) THEN
      message_width := LOWERVALUE (message_width);
    ELSEIF display_control.page_width > UPPERVALUE (message_width) THEN
      message_width := UPPERVALUE (message_width);
    ELSE
      message_width := display_control.page_width;
    IFEND;
    osp$format_message (status_message, message_level, message_width,
          message^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET message;
    NEXT line_count IN message;
    FOR line_counter := 1 TO line_count^ DO
      NEXT line_size IN message;
      NEXT message_line: [line_size^] IN message;
      clp$put_display (display_control, message_line^, clc$no_trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND display_status_message;
?? TITLE := '  dup$anas_memory_function', EJECT ??

  PROCEDURE [XDCL] dup$anas_memory_function (parameter_list: clt$parameter_list;
    VAR p_work: ^clt$work_area;
    VAR p_value: ^clt$data_value;
    VAR status: ost$status);

{ FUNCTION $memory, $mem (
{   address: integer 0..0ffffffffffff(16) = $required
{   bytes: integer 1..8 = 6
{   exchange: any of
{       key
{         (active, a)
{         (monitor, m)
{         (job, j)
{       keyend
{       integer 0..0ffffffff(16)
{     anyend = active
{   processor: integer 0..3 = 0
{   address_mode: key
{       (process_virtual_address, pva)
{     keyend = process_virtual_address
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: 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 .. 6] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (6),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (23),
      recend,
    recend := [
    [1,
    [89, 3, 28, 17, 4, 14, 320],
    clc$function, 5, 5, 1, 0, 0, 0, 0, ''], [
    ['ADDRESS                        ',clc$nominal_entry, 1],
    ['ADDRESS_MODE                   ',clc$nominal_entry, 5],
    ['BYTES                          ',clc$nominal_entry, 2],
    ['EXCHANGE                       ',clc$nominal_entry, 3],
    ['PROCESSOR                      ',clc$nominal_entry, 4]],
    [
{ 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, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, 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, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [4, 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, 269,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 4
    [5, 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, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [2, 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, 81,
  clc$optional_default_parameter, 0, 23]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 0ffffffffffff(16), 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, 8, 10],
    '6'],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    229, [[1, 0, clc$keyword_type], [6], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['MONITOR                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]]
    ,
    'active'],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [0, 3, 10],
    '0'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [2], [
    ['PROCESS_VIRTUAL_ADDRESS        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['PVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1]]
    ,
    'process_virtual_address']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$address = 1,
      p$bytes = 2,
      p$exchange = 3,
      p$processor = 4,
      p$address_mode = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      address: t$address_parameter,
      p_cell: ^cell,
      size: integer;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    address.value := pvt [p$address].value^.integer_value.value;
    size := pvt [p$bytes].value^.integer_value.value;

    NEXT p_value IN p_work;
    p_value^.kind := clc$integer;
    p_value^.integer_value.value := 0;
    p_value^.integer_value.radix := 16;
    p_value^.integer_value.radix_specified := TRUE;

    p_cell := #LOC (p_value^.integer_value.value);
    p_cell := #address (#ring (p_cell), #segment (p_cell), #offset (p_cell) + 8 - size);

    dup$move_bytes (#address (1, address.pva.seg, address.pva.offset), p_cell, size, status);

  PROCEND dup$anas_memory_function;
?? TITLE := '  dup$anas_memory_string_function', EJECT ??

  PROCEDURE [XDCL] dup$anas_memory_string_function (parameter_list: clt$parameter_list;
    VAR p_work: ^clt$work_area;
    VAR p_value: ^clt$data_value;
    VAR status: ost$status);

{ FUNCTION $memory_string, $ms (
{   address: integer 0..0ffffffffffff(16) = $required
{   bytes: integer 0..osc$max_string_size = 1
{   exchange: any of
{       key
{         (active, a)
{         (monitor, m)
{         (job, j)
{       keyend
{       integer 0..0ffffffff(16)
{     anyend = active
{   processor: integer 0..3 = 0
{   address_mode: key
{       (process_virtual_address, pva)
{     keyend = process_virtual_address
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: 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 .. 6] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (6),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (23),
      recend,
    recend := [
    [1,
    [89, 3, 28, 17, 11, 17, 41],
    clc$function, 5, 5, 1, 0, 0, 0, 0, ''], [
    ['ADDRESS                        ',clc$nominal_entry, 1],
    ['ADDRESS_MODE                   ',clc$nominal_entry, 5],
    ['BYTES                          ',clc$nominal_entry, 2],
    ['EXCHANGE                       ',clc$nominal_entry, 3],
    ['PROCESSOR                      ',clc$nominal_entry, 4]],
    [
{ 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, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, 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, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [4, 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, 269,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 4
    [5, 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, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [2, 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, 81,
  clc$optional_default_parameter, 0, 23]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 0ffffffffffff(16), 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, osc$max_string_size, 10],
    '1'],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    229, [[1, 0, clc$keyword_type], [6], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['MONITOR                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]]
    ,
    'active'],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [0, 3, 10],
    '0'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [2], [
    ['PROCESS_VIRTUAL_ADDRESS        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['PVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1]]
    ,
    'process_virtual_address']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$address = 1,
      p$bytes = 2,
      p$exchange = 3,
      p$processor = 4,
      p$address_mode = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      address: t$address_parameter,
      size: integer;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    address.value := pvt [p$address].value^.integer_value.value;
    size := pvt [p$bytes].value^.integer_value.value;

    NEXT p_value IN p_work;
    p_value^.kind := clc$string;
    NEXT p_value^.string_value: [size] IN p_work;

    IF (size > 0) THEN
      dup$move_bytes (#address (1, address.pva.seg, address.pva.offset), #LOC (p_value^.string_value^), size,
            status);
    IFEND;
  PROCEND dup$anas_memory_string_function;
?? TITLE := '  new_page_procedure', EJECT ??

  PROCEDURE new_page_procedure (VAR display_control: clt$display_control;
        new_page_number: integer;
    VAR status: ost$status);

    VAR
      str: ost$string;

    clp$reset_for_next_display_page (display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF display_control.page_width < clc$narrow_page_width THEN
      page_width := clc$narrow_page_width;
    ELSE
      page_width := display_control.page_width;
    IFEND;

    wide := page_width >= clc$wide_page_width;

    clp$convert_integer_to_string (new_page_number, 10, FALSE, str, status);

    IF NOT v$titles_built THEN
      build_standard_title (wide, v$command_name, wide_title,
            narrow_title1, narrow_title2, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      v$titles_built := TRUE;
    IFEND;

    IF wide THEN
      wide_title (127, * ) := str.value (1, str.size);
      clp$put_display (display_control, wide_title, clc$trim, status);
    ELSE
      narrow_title1 (70, * ) := str.value;
      clp$put_display (display_control, narrow_title1, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_display (display_control, narrow_title2, clc$trim, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$new_display_line (display_control, 1, status);


  PROCEND new_page_procedure;
?? TITLE := '  dup$anas_quit_command', EJECT ??
  PROCEDURE [XDCL] dup$anas_quit_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE quit, qui (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [89, 3, 28, 10, 51, 17, 40],
    clc$command, 1, 1, 0, 0, 0, 0, 1, ''], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);

    IF status.normal THEN
      clp$end_include (c$utility_name, status);
    IFEND;
  PROCEND dup$anas_quit_command;
?? OLDTITLE ??
MODEND dum$analyze_system;
*DECK DECK=DUM$ANAS_COMMANDS EXPAND=TRUE
table n=duv$anas_commands t=command s=xdcl m=dum$anas_commands                                                
command n=(add_debug_tables, add_debug_table, adddt) p=dup$add_debug_tables cm=xref                           
command n=(change_default_module, chadm) p=dup$change_default_module cm=xref                                  
command n=(change_default_procedure, chadp) p=dup$change_default_procedure cm=xref                            
command n=(close_file, clof) p=dup$close_file_command cm=xref                                                 
command n=(copy_memory, copm) p=dup$anas_copy_memory_command cm=xref                                          
command n=(display_line_number, disln) p=dup$display_line_number cm=xref                                      
command n=(display_memory, dism) p=dup$anas_display_memory_command cm=xref                                    
command n=(display_program_value, dispv) p=dup$display_variable cm=xref                                       
command n=(open_file, opef) p=dup$open_file_command cm=xref                                                   
command n=(quit, qui) p=dup$anas_quit_command cm=xref                                                         
tablend                                                                                                       
*DECK DECK=DUM$ANAS_FUNCTIONS EXPAND=TRUE
table n=duv$anas_functions t=function s=xdcl m=dum$anas_functions                                             
function n=($bit) p=dup$$bit_function cm=xref                                                                 
function n=($convert_unique_name, $conun, $cun) p=dup$convert_unique_name cm=xref                             
function n=($default_module, $dm) p=dup$default_module_function cm=xref                                       
function n=($default_procedure, $dp) p=dup$default_procedure_function cm=xref                                 
function n=($file_pva, $fp) p=dup$file_pva_function cm=xref                                                   
function n=($memory, $mem) p=dup$anas_memory_function cm=xref                                                 
function n=($memory_string, $ms) p=dup$anas_memory_string_function cm=xref                                    
function n=($module) p=dup$$module_function cm=xref                                                           
function n=($nil_pva, $np) p=dup$$nil_pva_function cm=xref                                                    
function n=($offset, $off) p=dup$$offset_function cm=xref                                                     
function n=($program_value,$pv) p=dup$program_value cm=xref                                                   
function n=($ring) p=dup$$ring_function cm=xref                                                               
function n=($section, $sec) p=dup$$section_function cm=xref                                                   
function n=($segment, $seg) p=dup$$segment_function cm=xref                                                   
function n=($symbol_address, $sa) p=dup$$symbol_address_function cm=xref                                      
tablend                                                                                                       
*DECK DECK=DUM$ASID EXPAND=TRUE
PROC dum$ASID asid (
  xasti : integer -281474976710655..281474976710655 = $required
  ptl   : integer -281474976710655..281474976710655 = 0
  xasid : VAR of integer
  )

  crev a_mult k=integer
  crev a_divisor k=integer
  crev bits k=integer d=0..15
  bits(0) = 0
  bits(1) = 8
  bits(2) = 4
  bits(3) = 12
  bits(4) = 2
  bits(5) = 10
  bits(6) = 6
  bits(7) = 14
  bits(8) = 1
  bits(9) = 9
  bits(10) = 5
  bits(11) = 13
  bits(12) = 3
  bits(13) = 11
  bits(14) = 7
  bits(15) = 15
  if ptl > 0 then
    crev (ptl2 asti) k=integer
    ptl2 = $value(ptl) + 1
    a_divisor = 256 / ptl2
    a_mult = 10000(16) / mmv$a_divisor
  else
    a_divisor = $mem($sa(mmv$a_divisor) 3)
    a_mult = $mem($sa(mmv$a_mult) 3)
  ifend
  asti = $value(xasti)
  asid = bits($mod(asti, 16))*4096
  asid = bits($mod((asti/16), 16))*256+asid
  asid = bits($mod((asti/256), 16))*16+asid
  asid = bits($mod((asti/4096), 16))+asid
  asid = asid / a_divisor + $mod(asid, a_divisor) * a_mult
  if not $specified(xasid) then
    putl ' ASID = '//$strrep(asid, 16)
  else
    xasid = asid
  ifend
PROCEND dum$asid
*DECK DECK=DUM$ASTI EXPAND=TRUE
PROC dum$ASTI asti (
  xasid : integer -281474976710655..281474976710655 = $required
  ptl   : integer -281474976710655..281474976710655 = 0
  xasti : VAR of integer
  )

  crev a_mult k=integer
  crev a_divisor k=integer
  crev bits k=integer d=0..15
  bits(0) = 0
  bits(1) = 8
  bits(2) = 4
  bits(3) = 12
  bits(4) = 2
  bits(5) = 10
  bits(6) = 6
  bits(7) = 14
  bits(8) = 1
  bits(9) = 9
  bits(10) = 5
  bits(11) = 13
  bits(12) = 3
  bits(13) = 11
  bits(14) = 7
  bits(15) = 15
  if ptl > 0 then
    crev (ptl2 asid) k=integer
    ptl2 = $value(ptl) + 1
    a_divisor = 256 / ptl2
    a_mult = 10000(16) / a_divisor
  else
    a_divisor = $mem($sa(mmv$a_divisor) 3)
    a_mult = $mem($sa(mmv$a_mult) 3)
  ifend
  asid = $value(xasid)
  asid = asid / a_mult + $mod(asid, a_mult) * a_divisor
  asti = bits($mod(asid, 16))*4096
  asti = bits($mod((asid/16), 16))*256+asti
  asti = bits($mod((asid/256), 16))*16+asti
  asti = bits($mod((asid/4096), 16))+asti
  if not $specified(xasti) then
    putl ' ASTI = '//$strrep(asti, 16)
  else
    xasti = asti
  ifend
PROCEND dum$asti
*DECK DECK=DUM$CHANGE_DEFAULT_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Dump Analyzer : Change Default Command' ??                                             
MODULE dum$change_default_command;                                                                            
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains the code for the change_default command.                                             
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc dut$default_parameter_list                                                                             
?? POP ??                                                                                                     
*copyc clp$convert_integer_to_string                                                                          
*copyc clp$evaluate_parameters                                                                                
*copyc ocp$close_linker_debug_table                                                                           
*copyc ocp$open_linker_debug_table                                                                            
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??                                        
  VAR                                                                                                         
    duv$default_parameters: [XDCL] dut$default_parameter_list := [[TRUE, 'PROCESS_VIRTUAL_ADDRESS'],          
          [TRUE, 'ACTIVE'], [FALSE, ' '], [TRUE, 'NORMAL'], [FALSE, ' ']];                                    
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$change_default_command', EJECT ??                                                         
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure changes the defaults for several parameters of commands used in the analyze_dump utility.  
{   The default values are stored in a global variable.  Each command is responsible for picking up the       
{   default value before it evaluates its command.  A procedure, dup$evaluate_parameters, exists to use       
{   the default values when evaluating the command.                                                           
                                                                                                              
  PROCEDURE [XDCL] dup$change_default_command                                                                 
    (    parameter_list: clt$parameter_list;                                                                  
     VAR status: ost$status);                                                                                 
                                                                                                              
{ PROCEDURE change_default, chad (                                                                            
{   exchange, e: any of                                                                                       
{       key                                                                                                   
{         (active a) (monitor m) (job j)                                                                      
{       keyend                                                                                                
{       integer 0..0ffffffff(16)                                                                              
{     anyend = $optional                                                                                      
{   processor, p: integer 0..3 = $optional                                                                    
{   address_mode, am: key                                                                                     
{       (process_virtual_address pva) (system_virtual_address sva) (real_memory_address rma)                  
{     keyend = $optional                                                                                      
{   pp_type, pt: key                                                                                          
{       (normal  n) (concurrent_input_output cio c)                                                           
{     keyend = $optional                                                                                      
{   iou, i: integer 0..1 = $optional                                                                          
{   debug_table, dt: file = $optional                                                                         
{   status)                                                                                                   
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 13] of clt$pdt_parameter_name,                                                       
      parameters: array [1 .. 7] 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 .. 6] of clt$keyword_specification,                                         
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$integer_type_qualifier,                                                              
        recend,                                                                                               
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type3: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$keyword_type_qualifier,                                                                
        keyword_specs: array [1 .. 6] of clt$keyword_specification,                                           
      recend,                                                                                                 
      type4: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$keyword_type_qualifier,                                                                
        keyword_specs: array [1 .. 5] of clt$keyword_specification,                                           
      recend,                                                                                                 
      type5: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type6: record                                                                                           
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
      type7: record                                                                                           
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 7, 11, 10, 11, 48, 542],                                                                             
    clc$command, 13, 7, 0, 0, 0, 0, 7, ''], [                                                                 
    ['ADDRESS_MODE                   ',clc$nominal_entry, 3],                                                 
    ['AM                             ',clc$abbreviation_entry, 3],                                            
    ['DEBUG_TABLE                    ',clc$nominal_entry, 6],                                                 
    ['DT                             ',clc$abbreviation_entry, 6],                                            
    ['E                              ',clc$abbreviation_entry, 1],                                            
    ['EXCHANGE                       ',clc$nominal_entry, 1],                                                 
    ['I                              ',clc$abbreviation_entry, 5],                                            
    ['IOU                            ',clc$nominal_entry, 5],                                                 
    ['P                              ',clc$abbreviation_entry, 2],                                            
    ['PP_TYPE                        ',clc$nominal_entry, 4],                                                 
    ['PROCESSOR                      ',clc$nominal_entry, 2],                                                 
    ['PT                             ',clc$abbreviation_entry, 4],                                            
    ['STATUS                         ',clc$nominal_entry, 7]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [6, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 269,                        
  clc$optional_parameter, 0, 0],                                                                              
{ PARAMETER 2                                                                                                 
    [11, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 3                                                                                                 
    [1, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,                        
  clc$optional_parameter, 0, 0],                                                                              
{ PARAMETER 4                                                                                                 
    [10, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,                        
  clc$optional_parameter, 0, 0],                                                                              
{ PARAMETER 5                                                                                                 
    [8, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 6                                                                                                 
    [3, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],                                                                                                       
{ PARAMETER 7                                                                                                 
    [13, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name],                                                         
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,                      
  clc$optional_parameter, 0, 0]],                                                                             
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],                                           
    FALSE, 2],                                                                                                
    229, [[1, 0, clc$keyword_type], [6], [                                                                    
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                 
      ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],                      
      ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                 
      ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 3],                      
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                 
      ['MONITOR                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]                      
      ],                                                                                                      
    20, [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]]                                                    
    ],                                                                                                        
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, 3, 10]],                                                                   
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$keyword_type], [6], [                                                                         
    ['PROCESS_VIRTUAL_ADDRESS        ', clc$nominal_entry, clc$normal_usage_entry, 1],                        
    ['PVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                   
    ['REAL_MEMORY_ADDRESS            ', clc$nominal_entry, clc$normal_usage_entry, 3],                        
    ['RMA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                   
    ['SVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                   
    ['SYSTEM_VIRTUAL_ADDRESS         ', clc$nominal_entry, clc$normal_usage_entry, 2]]                        
    ],                                                                                                        
{ PARAMETER 4                                                                                                 
    [[1, 0, clc$keyword_type], [5], [                                                                         
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                   
    ['CIO                            ', clc$alias_entry, clc$normal_usage_entry, 2],                          
    ['CONCURRENT_INPUT_OUTPUT        ', clc$nominal_entry, clc$normal_usage_entry, 2],                        
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                   
    ['NORMAL                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]                        
    ],                                                                                                        
{ PARAMETER 5                                                                                                 
    [[1, 0, clc$integer_type], [0, 1, 10]],                                                                   
{ PARAMETER 6                                                                                                 
    [[1, 0, clc$file_type]],                                                                                  
{ PARAMETER 7                                                                                                 
    [[1, 0, clc$status_type]]];                                                                               
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$exchange = 1,                                                                                         
      p$processor = 2,                                                                                        
      p$address_mode = 3,                                                                                     
      p$pp_type = 4,                                                                                          
      p$iou = 5,                                                                                              
      p$debug_table = 6,                                                                                      
      p$status = 7;                                                                                           
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 7] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      default_string: ost$string,                                                                             
      parameter_index: 1 .. clc$max_parameters;                                                               
                                                                                                              
    status.normal := TRUE;                                                                                    
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
   /process_parameters/                                                                                       
    FOR parameter_index := p$exchange TO p$debug_table DO                                                     
      IF NOT pvt [parameter_index].specified THEN                                                             
        CYCLE /process_parameters/;  {---->                                                                   
      IFEND;                                                                                                  
                                                                                                              
      { Retrieve the default value as a string.                                                               
                                                                                                              
      CASE pvt [parameter_index].value^.kind OF                                                               
      = clc$keyword =                                                                                         
        default_string.value := pvt [parameter_index].value^.keyword_value;                                   
        default_string.size := #SIZE (pvt [parameter_index].value^.keyword_value);                            
                                                                                                              
      = clc$integer =                                                                                         
        clp$convert_integer_to_string (pvt [parameter_index].value^.integer_value.value,                      
              pvt [parameter_index].value^.integer_value.radix,                                               
              pvt [parameter_index].value^.integer_value.radix_specified, default_string, status);            
                                                                                                              
      = clc$file =                                                                                            
        default_string.size := 1;                                                                             
        default_string.value := ' ';                                                                          
                                                                                                              
      ELSE                                                                                                    
        CYCLE /process_parameters/;  {---->                                                                   
      CASEND;                                                                                                 
                                                                                                              
      { Store the default value in the global variable.                                                       
                                                                                                              
      CASE parameter_index OF                                                                                 
      = p$exchange =                                                                                          
        duv$default_parameters [duc$dp_exchange].default_set := TRUE;                                         
        duv$default_parameters [duc$dp_exchange].value := default_string.value;                               
                                                                                                              
      = p$processor =                                                                                         
        duv$default_parameters [duc$dp_processor].default_set := TRUE;                                        
        duv$default_parameters [duc$dp_processor].value := default_string.value;                              
                                                                                                              
      = p$address_mode =                                                                                      
        duv$default_parameters [duc$dp_address_mode].default_set := TRUE;                                     
        duv$default_parameters [duc$dp_address_mode].value := default_string.value;                           
                                                                                                              
      = p$pp_type =                                                                                           
        duv$default_parameters [duc$dp_pp_type].default_set := TRUE;                                          
        duv$default_parameters [duc$dp_pp_type].value := default_string.value;                                
                                                                                                              
      = p$iou =                                                                                               
        duv$default_parameters [duc$dp_iou].default_set := TRUE;                                              
        duv$default_parameters [duc$dp_iou].value := default_string.value;                                    
                                                                                                              
      = p$debug_table =                                                                                       
        ocp$close_linker_debug_table (status);                                                                
        IF (NOT status.normal) AND (status.condition <> oce$e_debug_table_not_open) THEN                      
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
        ocp$open_linker_debug_table (pvt [parameter_index].value^.file_value^, status);                       
        IF NOT status.normal THEN                                                                             
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
                                                                                                              
      ELSE                                                                                                    
      CASEND;                                                                                                 
                                                                                                              
    FOREND /process_parameters/;                                                                              
                                                                                                              
  PROCEND dup$change_default_command;                                                                         
MODEND dum$change_default_command;                                                                            
*DECK DECK=DUM$CHANGE_PR_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Dump Analyzer : Change Processor Command' ??                                           
MODULE dum$change_pr_command;                                                                                 
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains the code for the change_processor command.                                           
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc due$exception_condition_codes                                                                          
?? POP ??                                                                                                     
*copyc dup$evaluate_parameters                                                                                
*copyc osp$append_status_integer                                                                              
*copyc osp$set_status_abnormal                                                                                
?? EJECT ??                                                                                                   
*copyc duv$dump_environment_p                                                                                 
*copyc duv$execution_environment                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$change_pr_command', EJECT ??                                                              
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure changes values related to the processor.                                                   
                                                                                                              
  PROCEDURE [XDCL] dup$change_pr_command                                                                      
    (    parameter_list: clt$parameter_list;                                                                  
     VAR status: ost$status);                                                                                 
                                                                                                              
{ PROCEDURE change_processor, chapr, chap (                                                                   
{   job_process_state, jps: integer 0..0ffffffff(16)                                                          
{   monitor_process_state, mps: integer 0..0ffffffff(16)                                                      
{   page_size_mask, psm: integer 0..7f(16)                                                                    
{   page_table_address, pta: integer 0..0ffffffff(16)                                                         
{   page_table_length, ptl: integer 0..03fff(16)                                                              
{   processor, p: any of                                                                                      
{       key                                                                                                   
{         (all a)                                                                                             
{       keyend                                                                                                
{       integer 0..3                                                                                          
{     anyend = 0                                                                                              
{   status)                                                                                                   
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 13] of clt$pdt_parameter_name,                                                       
      parameters: array [1 .. 7] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type3: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type4: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type5: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type6: 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 .. 2] of clt$keyword_specification,                                         
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$integer_type_qualifier,                                                              
        recend,                                                                                               
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type7: record                                                                                           
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 6, 12, 10, 1, 32, 651],                                                                              
    clc$command, 13, 7, 0, 0, 0, 0, 7, ''], [                                                                 
    ['JOB_PROCESS_STATE              ',clc$nominal_entry, 1],                                                 
    ['JPS                            ',clc$abbreviation_entry, 1],                                            
    ['MONITOR_PROCESS_STATE          ',clc$nominal_entry, 2],                                                 
    ['MPS                            ',clc$abbreviation_entry, 2],                                            
    ['P                              ',clc$abbreviation_entry, 6],                                            
    ['PAGE_SIZE_MASK                 ',clc$nominal_entry, 3],                                                 
    ['PAGE_TABLE_ADDRESS             ',clc$nominal_entry, 4],                                                 
    ['PAGE_TABLE_LENGTH              ',clc$nominal_entry, 5],                                                 
    ['PROCESSOR                      ',clc$nominal_entry, 6],                                                 
    ['PSM                            ',clc$abbreviation_entry, 3],                                            
    ['PTA                            ',clc$abbreviation_entry, 4],                                            
    ['PTL                            ',clc$abbreviation_entry, 5],                                            
    ['STATUS                         ',clc$nominal_entry, 7]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [1, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 2                                                                                                 
    [3, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 3                                                                                                 
    [6, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 4                                                                                                 
    [7, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 5                                                                                                 
    [8, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 6                                                                                                 
    [9, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,                        
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 7                                                                                                 
    [13, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name],                                                         
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,                      
  clc$optional_parameter, 0, 0]],                                                                             
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]],                                                       
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]],                                                       
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$integer_type], [0, 7f(16), 10]],                                                              
{ PARAMETER 4                                                                                                 
    [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]],                                                       
{ PARAMETER 5                                                                                                 
    [[1, 0, clc$integer_type], [0, 03fff(16), 10]],                                                           
{ PARAMETER 6                                                                                                 
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],                                           
    FALSE, 2],                                                                                                
    81, [[1, 0, clc$keyword_type], [2], [                                                                     
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                 
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]                      
      ],                                                                                                      
    20, [[1, 0, clc$integer_type], [0, 3, 10]]                                                                
    ,                                                                                                         
    '0'],                                                                                                     
{ PARAMETER 7                                                                                                 
    [[1, 0, clc$status_type]]];                                                                               
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$job_process_state = 1,                                                                                
      p$monitor_process_state = 2,                                                                            
      p$page_size_mask = 3,                                                                                   
      p$page_table_address = 4,                                                                               
      p$page_table_length = 5,                                                                                
      p$processor = 6,                                                                                        
      p$status = 7;                                                                                           
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 7] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      default_list: ARRAY [1 .. 1] OF dut$default_change_list_entry,                                          
      ending_processor_index: 0 .. duc$de_maximum_processors,                                                 
      mask_index_1: 0 .. 14,                                                                                  
      mask_index_2: 0 .. 14,                                                                                  
      processor_index: 0 .. duc$de_maximum_processors,                                                        
      psm: dut$ee_psm_value,                                                                                  
      pta: dut$ee_pta_value,                                                                                  
      ptl: dut$ee_ptl_value,                                                                                  
      starting_processor_index: 0 .. duc$de_maximum_processors;                                               
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the PROCESSOR parameter.                                                   
                                                                                                              
    default_list [1].default_name := duc$dp_processor;                                                        
    default_list [1].number := p$processor;                                                                   
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Determine the starting and ending processor indexes.                                                    
                                                                                                              
    IF pvt [p$processor].value^.kind = clc$keyword THEN                                                       
      starting_processor_index := 0;                                                                          
      ending_processor_index := duc$de_maximum_processors;                                                    
    ELSE                                                                                                      
      starting_processor_index := pvt [p$processor].value^.integer_value.value;                               
      ending_processor_index := starting_processor_index;                                                     
    IFEND;                                                                                                    
                                                                                                              
    { Change the job_process_state value.                                                                     
                                                                                                              
    IF pvt [p$job_process_state].specified THEN                                                               
      FOR processor_index := starting_processor_index TO ending_processor_index DO                            
        duv$execution_environment.processor_registers [processor_index].available := TRUE;                    
        duv$execution_environment.processor_registers [processor_index].job_process_state :=                  
              pvt [p$job_process_state].value^.integer_value.value;                                           
      FOREND;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    { Change the monitor_process_state value.                                                                 
                                                                                                              
    IF pvt [p$monitor_process_state].specified THEN                                                           
      FOR processor_index := starting_processor_index TO ending_processor_index DO                            
        duv$execution_environment.processor_registers [processor_index].available := TRUE;                    
        duv$execution_environment.processor_registers [processor_index].monitor_process_state :=              
              pvt [p$monitor_process_state].value^.integer_value.value;                                       
      FOREND;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    { Change the page_size_mask value.                                                                        
                                                                                                              
    IF pvt [p$page_size_mask].specified THEN                                                                  
      psm.value := pvt [p$page_size_mask].value^.integer_value.value;                                         
      FOR mask_index_1 := 0 TO 6 DO                                                                           
        IF NOT (mask_index_1 IN psm.psm) THEN                                                                 
          FOR mask_index_2 := (mask_index_1 + 1) TO 6 DO                                                      
            IF mask_index_2 IN psm.psm THEN                                                                   
              osp$set_status_abnormal (duc$dump_analyzer_id, due$invalid_mask, 'page_size_mask', status);     
              osp$append_status_integer (osc$status_parameter_delimiter, psm.value, 16, TRUE, status);        
              RETURN;  {---->                                                                                 
            IFEND;                                                                                            
          FOREND;                                                                                             
        IFEND;                                                                                                
      FOREND;                                                                                                 
      FOR processor_index := starting_processor_index TO ending_processor_index DO                            
        duv$execution_environment.processor_registers [processor_index].available := TRUE;                    
        duv$execution_environment.processor_registers [processor_index].page_size_mask := psm.psm;            
      FOREND;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    { Change the page_table_address value.                                                                    
                                                                                                              
    IF pvt [p$page_table_address].specified THEN                                                              
      pta.value := pvt [p$page_table_address].value^.integer_value.value;                                     
      FOR processor_index := starting_processor_index TO ending_processor_index DO                            
        duv$execution_environment.processor_registers [processor_index].available := TRUE;                    
        duv$execution_environment.processor_registers [processor_index].page_table_address := pta.pta;        
      FOREND;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    { Change the page_table_length value.                                                                     
                                                                                                              
    IF pvt [p$page_table_length].specified THEN                                                               
      ptl.value := pvt [p$page_table_length].value^.integer_value.value;                                      
      FOR mask_index_1 := 0 TO 13 DO                                                                          
        IF mask_index_1 IN ptl.ptl THEN                                                                       
          FOR mask_index_2 := (mask_index_1 + 1) TO 13 DO                                                     
            IF NOT (mask_index_2 IN ptl.ptl) THEN                                                             
              osp$set_status_abnormal (duc$dump_analyzer_id, due$invalid_mask, 'page_table_length', status);  
              osp$append_status_integer (osc$status_parameter_delimiter, ptl.value, 16, TRUE, status);        
              RETURN;  {---->                                                                                 
            IFEND;                                                                                            
          FOREND;                                                                                             
        IFEND;                                                                                                
      FOREND;                                                                                                 
      FOR processor_index := starting_processor_index TO ending_processor_index DO                            
        duv$execution_environment.processor_registers [processor_index].available := TRUE;                    
        duv$execution_environment.processor_registers [processor_index].page_table_length := ptl.ptl;         
      FOREND;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
  PROCEND dup$change_pr_command;                                                                              
MODEND dum$change_pr_command;                                                                                 
*DECK DECK=DUM$COMMON_ANALYZER_ROUTINES EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Dump Analyzer : Common Analyzer Routines' ??                                           
MODULE dum$common_analyzer_routines;                                                                          
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains the common routines for the analyze_dump utility.                                    
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc clt$data_value                                                                                         
*copyc dst$r_pointer                                                                                          
*copyc due$exception_condition_codes                                                                          
*copyc dut$default_parameter_list                                                                             
*copyc dut$dft_data_types                                                                                     
*copyc dut$did_record_type                                                                                    
*copyc dut$dump_information                                                                                   
?? POP ??                                                                                                     
*copyc clp$change_pdt                                                                                         
*copyc clp$convert_integer_to_rjstring                                                                        
*copyc clp$convert_integer_to_string                                                                          
*copyc clp$evaluate_parameters                                                                                
*copyc clp$horizontal_tab_display                                                                             
*copyc clp$new_display_line                                                                                   
*copyc clp$put_display                                                                                        
*copyc clp$put_partial_display                                                                                
*copyc dup$access_real_memory                                                                                 
*copyc osp$append_status_integer                                                                              
*copyc osp$append_status_parameter                                                                            
*copyc osp$format_message                                                                                     
*copyc osp$get_message_level                                                                                  
*copyc osp$set_status_abnormal                                                                                
?? EJECT ??                                                                                                   
*copyc duv$default_parameters                                                                                 
*copyc duv$dump_environment_p                                                                                 
*copyc duv$execution_environment                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
                                                                                                              
  TYPE                                                                                                        
    t$dump_information = RECORD                                                                               
      determined: boolean,                                                                                    
      data: dut$dump_information,                                                                             
    RECEND;                                                                                                   
?? EJECT ??                                                                                                   
  VAR                                                                                                         
    v$control_codes_to_space: [READ] string (256) := '            '                                           
      CAT '                     !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijkl'
      CAT 'mnopqrstuvwxyz{|}~                                                                                '
      CAT '                                                 ',                                                
                                                                                                              
    v$dump_information: t$dump_information := [FALSE, [duc$di_dt_unknown,                                     
          [[duc$di_ic_unknown, 0, duc$di_im_unknown], [duc$di_ic_unknown, 0, duc$di_im_unknown]],             
          duc$di_tt_unknown]];                                                                                
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'determine_dump_type', EJECT ??                                                                
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure determines the dump type.  The IOU model number must be first known.                       
                                                                                                              
  PROCEDURE determine_dump_type;                                                                              
                                                                                                              
    VAR                                                                                                       
      cell_p: ^cell,                                                                                          
      local_status: ost$status,                                                                               
      memory_p: ^cell,                                                                                        
      new_byte_size: ost$segment_length,                                                                      
      restart_file_seq_p: ^SEQ ( * ),                                                                         
      utility_p: ^dut$did_identifier_entry;                                                                   
                                                                                                              
    IF NOT duv$dump_environment_p^.dump_identifier.available THEN                                             
      dup$access_real_memory (1, 0, memory_p, new_byte_size, local_status);                                   
      IF NOT local_status.normal THEN                                                                         
        v$dump_information.data.dump_type := duc$di_dt_dual_state;                                            
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      IF v$dump_information.data.iou [0].model = duc$di_im_i0_5x THEN                                         
        v$dump_information.data.dump_type := duc$di_dt_es0;                                                   
      ELSE                                                                                                    
        v$dump_information.data.dump_type := duc$di_dt_edd;                                                   
      IFEND;                                                                                                  
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;            
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),                            
          duv$dump_environment_p^.dump_identifier.first_byte);                                                
    RESET restart_file_seq_p TO cell_p;                                                                       
    NEXT utility_p IN restart_file_seq_p;                                                                     
    IF utility_p = NIL THEN                                                                                   
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF utility_p^.value = duc$did_edd_dump THEN                                                               
      v$dump_information.data.dump_type := duc$di_dt_edd;                                                     
    ELSEIF utility_p^.value = duc$did_dual_state_dump THEN                                                    
      v$dump_information.data.dump_type := duc$di_dt_dual_state;                                              
    ELSEIF utility_p^.value = duc$did_es0_dump THEN                                                           
      v$dump_information.data.dump_type := duc$di_dt_es0;                                                     
    ELSEIF utility_p^.value = duc$did_cy2000_dump THEN                                                        
      v$dump_information.data.dump_type := duc$di_dt_cy2000;                                                  
    ELSE                                                                                                      
      v$dump_information.data.dump_type := duc$di_dt_unknown;                                                 
    IFEND;                                                                                                    
                                                                                                              
  PROCEND determine_dump_type;                                                                                
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'determine_iou_information', EJECT ??                                                          
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure determines information about the iou(s).                                                   
                                                                                                              
  PROCEDURE determine_iou_information;                                                                        
                                                                                                              
    VAR                                                                                                       
      iou_index: 0 .. duc$de_maximum_ious,                                                                    
      register: dut$de_maintenance_register;                                                                  
                                                                                                              
    FOR iou_index := 0 TO duc$de_maximum_ious DO                                                              
      dup$retrieve_register (duc$de_iou, iou_index, 10(16), register);                                        
      IF register.available THEN                                                                              
        IF (register.value [duc$de_model_byte_number] >= 50(16)) AND                                          
              (register.value [duc$de_model_byte_number] <= 5F(16)) THEN                                      
          v$dump_information.data.iou [iou_index].model := duc$di_im_i0_5x;                                   
          v$dump_information.data.iou [iou_index].class := duc$di_ic_iou_16k;                                 
          v$dump_information.data.iou [iou_index].pp_word_size := 16384;                                      
        ELSEIF (register.value [duc$de_model_byte_number] >= 10(16)) AND                                      
              (register.value [duc$de_model_byte_number] <= 16(16)) THEN                                      
          v$dump_information.data.iou [iou_index].model := duc$di_im_i1_1x;                                   
          v$dump_information.data.iou [iou_index].class := duc$di_ic_iou_4k;                                  
          v$dump_information.data.iou [iou_index].pp_word_size := 4096;                                       
        ELSEIF register.value [duc$de_model_byte_number] = 20(16) THEN                                        
          v$dump_information.data.iou [iou_index].model := duc$di_im_i2_20;                                   
          v$dump_information.data.iou [iou_index].class := duc$di_ic_iou_4k;                                  
          v$dump_information.data.iou [iou_index].pp_word_size := 4096;                                       
        ELSEIF register.value [duc$de_model_byte_number] = 40(16) THEN                                        
          v$dump_information.data.iou [iou_index].model := duc$di_im_i4_40;                                   
          v$dump_information.data.iou [iou_index].class := duc$di_ic_iou_8k;                                  
          v$dump_information.data.iou [iou_index].pp_word_size := 8192;                                       
        ELSEIF register.value [duc$de_model_byte_number] = 42(16) THEN                                        
          v$dump_information.data.iou [iou_index].model := duc$di_im_i4_42;                                   
          v$dump_information.data.iou [iou_index].class := duc$di_ic_iou_8k;                                  
          v$dump_information.data.iou [iou_index].pp_word_size := 8192;                                       
        ELSEIF register.value [duc$de_model_byte_number] = 43(16) THEN                                        
          v$dump_information.data.iou [iou_index].model := duc$di_im_i4_43;                                   
          v$dump_information.data.iou [iou_index].class := duc$di_ic_iou_8k;                                  
          v$dump_information.data.iou [iou_index].pp_word_size := 8192;                                       
        ELSEIF register.value [duc$de_model_byte_number] = 44(16) THEN                                        
          v$dump_information.data.iou [iou_index].model := duc$di_im_i4_44;                                   
          v$dump_information.data.iou [iou_index].class := duc$di_ic_iou_8k;                                  
          v$dump_information.data.iou [iou_index].pp_word_size := 8192;                                       
        ELSEIF register.value [duc$de_model_byte_number] = 46(16) THEN                                        
          v$dump_information.data.iou [iou_index].model := duc$di_im_i4_46;                                   
          v$dump_information.data.iou [iou_index].class := duc$di_ic_iou_8k;                                  
          v$dump_information.data.iou [iou_index].pp_word_size := 8192;                                       
        ELSE                                                                                                  
          v$dump_information.data.iou [iou_index].model := duc$di_im_unknown;                                 
          v$dump_information.data.iou [iou_index].class := duc$di_ic_unknown;                                 
          v$dump_information.data.iou [iou_index].pp_word_size := 0;                                          
        IFEND;                                                                                                
      IFEND;                                                                                                  
    FOREND;                                                                                                   
                                                                                                              
  PROCEND determine_iou_information;                                                                          
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'determine_tape_type', EJECT ??                                                                
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure determines the tape type.                                                                  
                                                                                                              
  PROCEDURE determine_tape_type;                                                                              
                                                                                                              
    VAR                                                                                                       
      cell_p: ^cell,                                                                                          
      edd_data_p: ^dut$did_edd_data,                                                                          
      restart_file_seq_p: ^SEQ ( * ),                                                                         
      utility_p: ^dut$did_identifier_entry;                                                                   
                                                                                                              
    IF NOT duv$dump_environment_p^.dump_identifier.available THEN                                             
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;            
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),                            
          duv$dump_environment_p^.dump_identifier.first_byte);                                                
    RESET restart_file_seq_p TO cell_p;                                                                       
    NEXT utility_p IN restart_file_seq_p;                                                                     
    IF utility_p = NIL THEN                                                                                   
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF utility_p^.value = duc$did_dual_state_dump THEN                                                        
      v$dump_information.data.tape_type := duc$di_tt_unknown;                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    NEXT edd_data_p IN restart_file_seq_p;                                                                    
    IF edd_data_p = NIL THEN                                                                                  
      v$dump_information.data.tape_type := duc$di_tt_unknown;                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF edd_data_p^.tape_information.tape_type.value = 1 THEN                                                  
      v$dump_information.data.tape_type := duc$di_tt_1;                                                       
    ELSEIF edd_data_p^.tape_information.tape_type.value = 2 THEN                                              
      v$dump_information.data.tape_type := duc$di_tt_2;                                                       
    ELSEIF edd_data_p^.tape_information.tape_type.value = 3 THEN                                              
      v$dump_information.data.tape_type := duc$di_tt_3;                                                       
    ELSEIF edd_data_p^.tape_information.tape_type.value = 4 THEN                                              
      v$dump_information.data.tape_type := duc$di_tt_4;                                                       
    ELSEIF edd_data_p^.tape_information.tape_type.value = 40(8) THEN                                          
      v$dump_information.data.tape_type := duc$di_tt_40;                                                      
    ELSEIF edd_data_p^.tape_information.tape_type.value = 41(8) THEN                                          
      v$dump_information.data.tape_type := duc$di_tt_41;                                                      
    ELSE                                                                                                      
      v$dump_information.data.tape_type := duc$di_tt_unknown;                                                 
    IFEND;                                                                                                    
                                                                                                              
  PROCEND determine_tape_type;                                                                                
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$determine_dump_information', EJECT ??                                                     
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure returns information about the dump.                                                        
                                                                                                              
  PROCEDURE [XDCL] dup$determine_dump_information                                                             
    (VAR dump_information: dut$dump_information);                                                             
                                                                                                              
    IF v$dump_information.determined THEN                                                                     
      dump_information := v$dump_information.data;                                                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    determine_iou_information;                                                                                
    determine_dump_type;                                                                                      
    determine_tape_type;                                                                                      
    v$dump_information.determined := TRUE;                                                                    
    dump_information := v$dump_information.data;                                                              
                                                                                                              
  PROCEND dup$determine_dump_information;                                                                     
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$display_data', EJECT ??                                                                   
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays the requested data in numeric format and/or ascii format.                         
                                                                                                              
  PROCEDURE [XDCL] dup$display_data                                                                           
    (    display_option_list_p: ^clt$data_value;                                                              
         cm_word_structure: boolean;                                                                          
         radix: 8 .. 16;                                                                                      
         address: ost$segment_length;                                                                         
         total_units: integer;                                                                                
     VAR display_control: clt$display_control;                                                                
     VAR restart_file_seq_p: ^SEQ ( * );                                                                      
     VAR end_of_input_file: boolean;                                                                          
     VAR status: ost$status);                                                                                 
                                                                                                              
    CONST                                                                                                     
      c$cm_bytes_in_item = 8,                                                                                 
      c$cm_size_of_address = 8,                                                                               
      c$cm_size_of_address_8 = 10,                                                                            
      c$cm_space_for_numeric_byte = 2,                                                                        
      c$cm_space_for_numeric_word = 30,                                                                       
                                                                                                              
      c$pp_bytes_per_item = c$pp_bytes_per_word * c$pp_words_per_item,                                        
      c$pp_bytes_per_word = 2,                                                                                
      c$pp_size_of_address = 5,                                                                               
      c$pp_words_per_item = 8,                                                                                
                                                                                                              
      c$spaces_bet_ad_and_display = 2;                                                                        
                                                                                                              
    TYPE                                                                                                      
      t$byte = PACKED RECORD                                                                                  
        left_part: 0 .. 0f(16),                                                                               
        right_part: 0 .. 0f(16),                                                                              
      RECEND,                                                                                                 
                                                                                                              
      t$cm_word_or_set = RECORD                                                                               
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          word_part: integer,                                                                                 
        = FALSE =                                                                                             
          set_part: t$cm_word_set,                                                                            
        CASEND,                                                                                               
      RECEND,                                                                                                 
                                                                                                              
      t$cm_word_set = SET OF 0 .. 63,                                                                         
                                                                                                              
      t$display_code_cm = PACKED RECORD                                                                       
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          whole_data: integer,                                                                                
        = FALSE =                                                                                             
          unused: 0 .. 0f(16),                                                                                
          data_1: PACKED ARRAY [1 .. 5] OF 0 .. 77(8),                                                        
          data_2: PACKED ARRAY [1 .. 5] OF 0 .. 77(8),                                                        
        CASEND,                                                                                               
      RECEND,                                                                                                 
                                                                                                              
      t$display_code_pp = PACKED RECORD                                                                       
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          whole_data: 0 .. 0ffff(16),                                                                         
        = FALSE =                                                                                             
          unused: 0 .. 0f(16),                                                                                
          data: PACKED ARRAY [1 .. 2] OF 0 .. 77(8),                                                          
        CASEND,                                                                                               
      RECEND,                                                                                                 
                                                                                                              
      t$pp_word = PACKED RECORD                                                                               
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          modifier: 0 .. 0f(16),                                                                              
          twelve_bits: 0 .. 0fff(16),                                                                         
        = FALSE =                                                                                             
          value: 0 .. 0ffff(16),                                                                              
        CASEND,                                                                                               
      RECEND;                                                                                                 
                                                                                                              
    VAR                                                                                                       
      display_code_conversion: [STATIC] ARRAY [0 .. 77(8)] OF char := [' ', 'A', 'B', 'C', 'D', 'E', 'F',     
            'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y',    
            'Z', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '+', '-', '*', '/', '(', ')', '$', '=',    
            ' ', ',', '.', '#', '[', ']', '%', '"', '_', '!', '&', '''', '?', '<', '>', '@', '\', '^', ';'],  
      hex_chars: [STATIC] ARRAY [0 .. 0f(16)] OF char := ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',   
            'A', 'B', 'C', 'D', 'E', 'F'];                                                                    
                                                                                                              
    VAR                                                                                                       
      ascii_display: boolean,                                                                                 
      ascii_item_p: ^string ( * ),                                                                            
      ascii_tab_column: 1 .. 256,                                                                             
      byte_count: 1 .. 2,                                                                                     
      byte_data_p: ^0 .. 0ff(16),                                                                             
      byte_p: ^t$byte,                                                                                        
      char_index: 0 .. 0ff(16),                                                                               
      cm_word_index: 1 .. 22,                                                                                 
      cm_word_or_set_p: ^t$cm_word_or_set,                                                                    
      cm_word_string: string (22),                                                                            
      current_item: 1 .. 63,                                                                                  
      current_pp_word: 1 .. c$pp_words_per_item,                                                              
      display_address: integer,                                                                               
      display_code_cm: t$display_code_cm,                                                                     
      display_code_display: boolean,                                                                          
      display_code_pp: t$display_code_pp,                                                                     
      half_half_words: 1 .. 2,                                                                                
      half_words: 1 .. 2,                                                                                     
      ignore_status: ost$status,                                                                              
      index: 0 .. 0ff(16),                                                                                    
      integer_p: ^integer,                                                                                    
      integer_string: ost$string,                                                                             
      items_per_line: 0 .. 100,                                                                               
      line_buffer_p: ^string ( * ),                                                                           
      line_index: 1 .. 256,                                                                                   
      list_p: ^clt$data_value,                                                                                
      local_status: ost$status,                                                                               
      numeric_display: boolean,                                                                               
      option_p: ^clt$data_value,                                                                              
      page_width: amt$page_width,                                                                             
      pp_ascii_units: 0 .. 132,                                                                               
      pp_word_data_p: ^0 .. 0ffff(16),                                                                        
      pp_word_p: ^t$pp_word,                                                                                  
      previous_line_p: ^string ( * ),                                                                         
      repeated_lines: integer,                                                                                
      reset_mark_p: ^cell,                                                                                    
      size_of_address: 5 .. 10,                                                                               
      space_for_ascii_item: 0 .. 132,                                                                         
      space_for_numeric_item: 0 .. 132,                                                                       
      space_for_numeric_word: 4 .. 6,                                                                         
      temp_cm_word_or_set: t$cm_word_or_set,                                                                  
      units_displayed: integer,                                                                               
      units_this_line: 0 .. 132;                                                                              
                                                                                                              
    status.normal := TRUE;                                                                                    
    end_of_input_file := FALSE;                                                                               
                                                                                                              
    IF cm_word_structure THEN                                                                                 
      IF radix = 16 THEN                                                                                      
        size_of_address := c$cm_size_of_address;                                                              
      ELSE                                                                                                    
        size_of_address := c$cm_size_of_address_8;                                                            
      IFEND;                                                                                                  
    ELSE                                                                                                      
      size_of_address := c$pp_size_of_address;                                                                
    IFEND;                                                                                                    
                                                                                                              
    { Determine whether to display the numeric and/or the ascii/display code data.  If ASCII and DISPLAY_CODE 
    { are both selected only ASCII will be displayed.                                                         
                                                                                                              
    numeric_display := FALSE;                                                                                 
    ascii_display := FALSE;                                                                                   
    display_code_display := FALSE;                                                                            
    list_p := display_option_list_p;                                                                          
    WHILE list_p <> NIL DO                                                                                    
      option_p := list_p^.element_value;                                                                      
      list_p := list_p^.link;                                                                                 
      IF option_p^.keyword_value = 'NUMERIC' THEN                                                             
        numeric_display := TRUE;                                                                              
      ELSEIF option_p^.keyword_value = 'ASCII' THEN                                                           
        ascii_display := TRUE;                                                                                
      ELSEIF option_p^.keyword_value = 'DISPLAY_CODE' THEN                                                    
        display_code_display := TRUE;                                                                         
      IFEND;                                                                                                  
    WHILEND;                                                                                                  
    IF ascii_display AND display_code_display THEN                                                            
      display_code_display := FALSE;                                                                          
    IFEND;                                                                                                    
                                                                                                              
    { Setup the page width for the output file.                                                               
                                                                                                              
    IF display_control.page_width > 132 THEN                                                                  
      page_width := 132;                                                                                      
    ELSEIF display_control.page_width < 40 THEN                                                               
      page_width := 40;                                                                                       
    ELSE                                                                                                      
      page_width := display_control.page_width;                                                               
    IFEND;                                                                                                    
                                                                                                              
    { Determine the size of the numeric item and the ascii item.                                              
                                                                                                              
    IF cm_word_structure THEN                                                                                 
      IF numeric_display THEN                                                                                 
        IF radix = 16 THEN                                                                                    
          space_for_numeric_item := c$cm_bytes_in_item * c$cm_space_for_numeric_byte + 6;                     
        ELSE                                                                                                  
          space_for_numeric_item := c$cm_space_for_numeric_word;                                              
        IFEND;                                                                                                
      ELSE                                                                                                    
        space_for_numeric_item := 0;                                                                          
      IFEND;                                                                                                  
      IF ascii_display OR display_code_display THEN                                                           
        space_for_ascii_item := c$cm_bytes_in_item;                                                           
      ELSE                                                                                                    
        space_for_ascii_item := 0;                                                                            
      IFEND;                                                                                                  
    ELSE  { pp_word_structure                                                                                 
      IF numeric_display THEN                                                                                 
        IF radix < 16 THEN                                                                                    
          space_for_numeric_word := 6;                                                                        
        ELSE                                                                                                  
          space_for_numeric_word := 4;                                                                        
        IFEND;                                                                                                
        space_for_numeric_item := c$pp_words_per_item * (space_for_numeric_word + 1);                         
      ELSE                                                                                                    
        space_for_numeric_item := 0;                                                                          
      IFEND;                                                                                                  
      IF ascii_display OR display_code_display THEN                                                           
        space_for_ascii_item := c$pp_bytes_per_item;                                                          
      ELSE                                                                                                    
        space_for_ascii_item := 0;                                                                            
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    { Determine how many items will be displayed per line.                                                    
                                                                                                              
    items_per_line := (page_width - size_of_address - c$spaces_bet_ad_and_display) DIV                        
          (space_for_ascii_item + space_for_numeric_item);                                                    
    IF items_per_line = 0 THEN                                                                                
      items_per_line := 1;                                                                                    
      page_width := size_of_address + c$spaces_bet_ad_and_display + space_for_ascii_item +                    
            space_for_numeric_item;                                                                           
    IFEND;                                                                                                    
    ascii_tab_column := size_of_address + c$spaces_bet_ad_and_display +                                       
          (items_per_line * space_for_numeric_item) + 1;                                                      
                                                                                                              
    { Reserve space to hold a line for the output file.                                                       
                                                                                                              
    PUSH line_buffer_p: [page_width];                                                                         
    PUSH previous_line_p: [page_width];                                                                       
    IF (line_buffer_p = NIL) OR (previous_line_p = NIL) THEN                                                  
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    previous_line_p^ := ' ';                                                                                  
    repeated_lines := 0;                                                                                      
    display_address := address;                                                                               
    units_displayed := 0;                                                                                     
    units_this_line := items_per_line * space_for_ascii_item;                                                 
                                                                                                              
    WHILE TRUE DO                                                                                             
      line_buffer_p^ := ' ';                                                                                  
      line_index := 1;                                                                                        
                                                                                                              
      { Place the display address in the temporary output line.                                               
                                                                                                              
      line_buffer_p^ (line_index, size_of_address) := 'XXXXX';                                                
      clp$convert_integer_to_rjstring (display_address, radix, FALSE, '0',                                    
            line_buffer_p^ (line_index, size_of_address), ignore_status);                                     
      line_index := line_index + size_of_address + c$spaces_bet_ad_and_display;                               
                                                                                                              
      { Mark the spot in the restart file so that it can be reset to display the ascii portion                
      { after the numeric portion has been displayed.                                                         
                                                                                                              
      NEXT reset_mark_p IN restart_file_seq_p;                                                                
      IF reset_mark_p = NIL THEN                                                                              
        end_of_input_file := TRUE;                                                                            
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      RESET restart_file_seq_p TO reset_mark_p;                                                               
                                                                                                              
      { Add the numeric portion to the temporary output line.                                                 
                                                                                                              
      IF numeric_display THEN                                                                                 
        units_this_line := 0;                                                                                 
        pp_ascii_units := 0;                                                                                  
                                                                                                              
       /format_numeric/                                                                                       
        BEGIN                                                                                                 
          IF cm_word_structure THEN                                                                           
            IF radix = 16 THEN                                                                                
              FOR current_item := 1 TO items_per_line DO                                                      
                FOR half_words := 1 TO 2 DO                                                                   
                  FOR half_half_words := 1 TO 2 DO                                                            
                    FOR byte_count := 1 TO 2 DO                                                               
                      NEXT byte_p IN restart_file_seq_p;                                                      
                      IF byte_p = NIL THEN                                                                    
                        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);          
                        RETURN;  {---->                                                                       
                      IFEND;                                                                                  
                      line_buffer_p^ (line_index) := hex_chars [byte_p^.left_part];                           
                      line_buffer_p^ (line_index + 1) := hex_chars [byte_p^.right_part];                      
                      line_index := line_index + 2;                                                           
                      units_this_line := units_this_line + 1;                                                 
                      units_displayed := units_displayed + 1;                                                 
                      IF units_displayed >= total_units THEN                                                  
                        line_index := ascii_tab_column;                                                       
                        EXIT /format_numeric/;  {---->                                                        
                      IFEND;                                                                                  
                    FOREND;                                                                                   
                    line_index := line_index + 1;                                                             
                  FOREND;                                                                                     
                FOREND;                                                                                       
                line_index := line_index + 2;                                                                 
              FOREND;                                                                                         
                                                                                                              
            ELSE  { cm_word_structure and radix <> 16 }                                                       
                                                                                                              
              FOR current_item := 1 TO items_per_line DO                                                      
                NEXT cm_word_or_set_p IN restart_file_seq_p;                                                  
                IF cm_word_or_set_p = NIL THEN                                                                
                  osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                
                  RETURN;  {---->                                                                             
                IFEND;                                                                                        
                IF (radix = 8) AND (cm_word_or_set_p^.word_part < 0) THEN                                     
                  temp_cm_word_or_set.set_part := cm_word_or_set_p^.set_part - $t$cm_word_set[0];             
                  cm_word_string := 'XXXXXXXXXXXXXXXXXXXXXX';                                                 
                  clp$convert_integer_to_rjstring (temp_cm_word_or_set.word_part, radix, FALSE, '0',          
                        cm_word_string, ignore_status);                                                       
                  cm_word_string (1) := '1';                                                                  
                ELSEIF radix = 8  THEN                                                                        
                  cm_word_string := 'XXXXXXXXXXXXXXXXXXXXXX';                                                 
                  clp$convert_integer_to_rjstring (cm_word_or_set_p^.word_part, radix, FALSE, '0',            
                        cm_word_string, ignore_status);                                                       
                ELSE                                                                                          
                  clp$convert_integer_to_string (cm_word_or_set_p^.word_part, radix, FALSE, integer_string,   
                        ignore_status);                                                                       
                  cm_word_string := ' ';                                                                      
                  cm_word_string (STRLENGTH(cm_word_string) - integer_string.size + 1, integer_string.size) :=
                        integer_string.value (1, integer_string.size);                                        
                IFEND;                                                                                        
                line_buffer_p^ (line_index, 2) := cm_word_string (1, 2);                                      
                line_index := line_index + 3;                                                                 
                FOR half_words := 1 TO 2 DO                                                                   
                  FOR half_half_words := 1 TO 2 DO                                                            
                    cm_word_index := 3 + ((half_words - 1) * 10) + ((half_half_words - 1) * 5);               
                    line_buffer_p^ (line_index, 5) := cm_word_string (cm_word_index, 5);                      
                    line_index := line_index + 6;                                                             
                  FOREND;                                                                                     
                  line_index := line_index + 1;                                                               
                FOREND;                                                                                       
                line_index := line_index + 1;                                                                 
                units_this_line := units_this_line + 8;                                                       
                units_displayed := units_displayed + 8;                                                       
                IF units_displayed >= total_units THEN                                                        
                  line_index := ascii_tab_column;                                                             
                  EXIT /format_numeric/;  {---->                                                              
                IFEND;                                                                                        
              FOREND;                                                                                         
            IFEND;                                                                                            
                                                                                                              
          ELSE  { pp_word_structure                                                                           
                                                                                                              
            FOR current_item := 1 TO items_per_line DO                                                        
              FOR current_pp_word := 1 TO c$pp_words_per_item DO                                              
                NEXT pp_word_p IN restart_file_seq_p;                                                         
                IF pp_word_p = NIL THEN                                                                       
                  osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                
                  RETURN;  {---->                                                                             
                IFEND;                                                                                        
                IF pp_word_p^.value = 0 THEN                                                                  
                  line_buffer_p^ (line_index + (space_for_numeric_word - 4), 4) := '----';                    
                ELSEIF (radix = 8) AND (pp_word_p^.modifier = 0) THEN                                         
                  line_buffer_p^ (line_index + 2, 4) := 'XXXX';                                               
                  clp$convert_integer_to_rjstring (pp_word_p^.twelve_bits, 8, FALSE, '0',                     
                        line_buffer_p^ (line_index + 2, 4), ignore_status);                                   
                ELSE                                                                                          
                  line_buffer_p^ (line_index, space_for_numeric_word) := 'XXXXXX';                            
                  clp$convert_integer_to_rjstring (pp_word_p^.value, radix, FALSE, '0',                       
                        line_buffer_p^ (line_index, space_for_numeric_word), ignore_status);                  
                IFEND;                                                                                        
                line_index := line_index + space_for_numeric_word + 1;                                        
                pp_ascii_units := pp_ascii_units + 2;                                                         
                units_this_line := units_this_line + 1;                                                       
                units_displayed := units_displayed + 1;                                                       
                IF units_displayed >= total_units THEN                                                        
                  line_index := ascii_tab_column;                                                             
                  EXIT /format_numeric/;                                                                      
                IFEND;                                                                                        
              FOREND;                                                                                         
            FOREND;                                                                                           
          IFEND;                                                                                              
        END /format_numeric/;                                                                                 
      IFEND;                                                                                                  
                                                                                                              
      { Add the ascii portion to the temporary output line.                                                   
                                                                                                              
      IF ascii_display THEN                                                                                   
        IF NOT numeric_display THEN                                                                           
          IF (total_units - units_displayed) < units_this_line THEN                                           
            units_this_line := total_units - units_displayed;                                                 
          IFEND;                                                                                              
          units_displayed := units_displayed + units_this_line;                                               
          pp_ascii_units := units_this_line;                                                                  
        IFEND;                                                                                                
        RESET restart_file_seq_p TO reset_mark_p;                                                             
        IF cm_word_structure THEN                                                                             
          NEXT ascii_item_p: [units_this_line] IN restart_file_seq_p;                                         
        ELSE                                                                                                  
          NEXT ascii_item_p: [pp_ascii_units] IN restart_file_seq_p;                                          
        IFEND;                                                                                                
        IF ascii_item_p = NIL THEN                                                                            
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
        IF cm_word_structure THEN                                                                             
          #TRANSLATE (v$control_codes_to_space, ascii_item_p^, line_buffer_p^ (line_index, units_this_line)); 
        ELSE                                                                                                  
          #TRANSLATE (v$control_codes_to_space, ascii_item_p^, line_buffer_p^ (line_index, pp_ascii_units));  
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
      { Add the display code portion to the temporary output line.                                            
                                                                                                              
      IF display_code_display THEN                                                                            
        IF NOT numeric_display THEN                                                                           
          IF (total_units - units_displayed) < units_this_line THEN                                           
            units_this_line := total_units - units_displayed;                                                 
          IFEND;                                                                                              
          units_displayed := units_displayed + units_this_line;                                               
          pp_ascii_units := units_this_line;                                                                  
        IFEND;                                                                                                
        RESET restart_file_seq_p TO reset_mark_p;                                                             
        IF cm_word_structure THEN                                                                             
          FOR index := 1 TO (units_this_line DIV 8) DO                                                        
            NEXT integer_p IN restart_file_seq_p;                                                             
            display_code_cm.whole_data := integer_p^;                                                         
            FOR char_index := 1 TO 5 DO                                                                       
              line_buffer_p^ (line_index) := display_code_conversion [display_code_cm.data_1 [char_index]];   
              line_index := line_index + 1;                                                                   
             FOREND;                                                                                          
            FOR char_index := 1 TO 5 DO                                                                       
              line_buffer_p^ (line_index) := display_code_conversion [display_code_cm.data_2 [char_index]];   
              line_index := line_index + 1;                                                                   
             FOREND;                                                                                          
           FOREND;                                                                                            
        ELSE                                                                                                  
          FOR index := 1 TO (pp_ascii_units DIV 2) DO                                                         
            NEXT pp_word_data_p IN restart_file_seq_p;                                                        
            display_code_pp.whole_data := pp_word_data_p^;                                                    
            FOR char_index := 1 TO 2 DO                                                                       
              line_buffer_p^ (line_index) := display_code_conversion [display_code_pp.data [char_index]];     
              line_index := line_index + 1;                                                                   
             FOREND;                                                                                          
           FOREND;                                                                                            
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
      { Check if the temporary output line matched the previous line.  Duplicate lines are not displayed.     
                                                                                                              
      IF (line_buffer_p^ (size_of_address + 1, *) = previous_line_p^ (size_of_address + 1, *)) AND            
            (units_displayed < total_units) THEN                                                              
        previous_line_p^ := line_buffer_p^;                                                                   
        repeated_lines := repeated_lines + 1;                                                                 
      ELSE                                                                                                    
        IF repeated_lines > 1 THEN                                                                            
          osp$set_status_abnormal (duc$dump_analyzer_id, due$skipped_lines, '', local_status);                
          osp$append_status_integer (osc$status_parameter_delimiter, repeated_lines, 10, FALSE, local_status);
          dup$display_message (local_status, display_control);                                                
        ELSEIF repeated_lines = 1 THEN                                                                        
          clp$put_display (display_control, previous_line_p^, clc$trim, ignore_status);                       
        IFEND;                                                                                                
        repeated_lines := 0;                                                                                  
        clp$put_display (display_control, line_buffer_p^, clc$trim, ignore_status);                           
        previous_line_p^ := line_buffer_p^;                                                                   
      IFEND;                                                                                                  
                                                                                                              
      IF units_displayed >= total_units THEN                                                                  
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      display_address := display_address + units_this_line;                                                   
    WHILEND;                                                                                                  
                                                                                                              
  PROCEND dup$display_data;                                                                                   
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$display_message', EJECT ??                                                                
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure formats a status message and displays it to the user.                                      
                                                                                                              
  PROCEDURE [XDCL] dup$display_message                                                                        
    (    status_message: ost$status;                                                                          
     VAR display_control: clt$display_control);                                                               
                                                                                                              
    VAR                                                                                                       
      line_count_p: ^ost$status_message_line_count,                                                           
      line_counter: ost$status_message_line_count,                                                            
      line_size_p: ^ost$status_message_line_size,                                                             
      local_status: ost$status,                                                                               
      message_level: ost$status_message_level,                                                                
      message_line_p: ^string ( * ),                                                                          
      message_width: ost$max_status_message_line,                                                             
      message_p: ^ost$status_message;                                                                         
                                                                                                              
    osp$get_message_level (message_level, local_status);                                                      
    IF NOT local_status.normal THEN                                                                           
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    PUSH message_p;                                                                                           
    RESET message_p;                                                                                          
    IF message_p = NIL THEN                                                                                   
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF display_control.page_width < LOWERVALUE (message_width) THEN                                           
      message_width := LOWERVALUE (message_width);                                                            
    ELSEIF display_control.page_width > UPPERVALUE (message_width) THEN                                       
      message_width := UPPERVALUE (message_width);                                                            
    ELSE                                                                                                      
      message_width := display_control.page_width;                                                            
    IFEND;                                                                                                    
    osp$format_message (status_message, message_level, message_width, message_p^, local_status);              
    IF NOT local_status.normal THEN                                                                           
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    RESET message_p;                                                                                          
    NEXT line_count_p IN message_p;                                                                           
    IF line_count_p = NIL THEN                                                                                
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    FOR line_counter := 1 TO line_count_p^ DO                                                                 
      NEXT line_size_p IN message_p;                                                                          
      IF line_size_p = NIL THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      IF line_size_p^ > 0 THEN                                                                                
        NEXT message_line_p: [line_size_p^] IN message_p;                                                     
        IF message_line_p = NIL THEN                                                                          
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
        clp$put_display (display_control, message_line_p^, clc$no_trim, local_status);                        
        IF NOT local_status.normal THEN                                                                       
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
      IFEND;                                                                                                  
    FOREND;                                                                                                   
                                                                                                              
  PROCEND dup$display_message;                                                                                
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$display_register_data', EJECT ??                                                          
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays register data with a description.                                                 
                                                                                                              
  PROCEDURE [XDCL] dup$display_register_data                                                                  
    (    description: string (*);                                                                             
         register: ARRAY [1 .. duc$de_max_register_length] OF 0 .. 0ff(16);                                   
     VAR display_control: clt$display_control);                                                               
                                                                                                              
    TYPE                                                                                                      
      t$register_line = RECORD                                                                                
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          line: string (20),                                                                                  
        = FALSE =                                                                                             
          data: ARRAY [1 .. 4] OF t$register_line_entry,                                                      
        CASEND,                                                                                               
      RECEND,                                                                                                 
                                                                                                              
      t$register_line_entry = RECORD                                                                          
        first_byte: string (2),                                                                               
        second_byte: string (2),                                                                              
        unused: string (1),                                                                                   
      RECEND;                                                                                                 
                                                                                                              
    VAR                                                                                                       
      byte_index: 0 .. 0ff(16),                                                                               
      display_string: string (osc$max_string_size),                                                           
      ignore_status: ost$status,                                                                              
      index: 0 .. 0ff(16),                                                                                    
      register_line: t$register_line,                                                                         
      string_2: string (2),                                                                                   
      string_length: integer;                                                                                 
                                                                                                              
    byte_index := 1;                                                                                          
    register_line.line := ' ';                                                                                
    FOR index := 1 TO 4 DO                                                                                    
      clp$convert_integer_to_rjstring (register [byte_index], 16, FALSE, '0', string_2, ignore_status);       
      register_line.data [index].first_byte := string_2;                                                      
      byte_index := byte_index + 1;                                                                           
      clp$convert_integer_to_rjstring (register [byte_index], 16, FALSE, '0', string_2, ignore_status);       
      register_line.data [index].second_byte := string_2;                                                     
      byte_index := byte_index + 1;                                                                           
    FOREND;                                                                                                   
    STRINGREP (display_string, string_length, '  ', description, ' = ', register_line.line);                  
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);            
                                                                                                              
  PROCEND dup$display_register_data;                                                                          
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$evaluate_parameters', EJECT ??                                                            
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure changes the default parameter values on the pdt and calls the evaluate parameters routine. 
                                                                                                              
  PROCEDURE [XDCL] dup$evaluate_parameters                                                                    
    (    parameter_list: clt$parameter_list;                                                                  
         default_list: dut$default_change_list;                                                               
         pdt_p: ^clt$parameter_description_table;                                                             
         pvt_p: ^clt$parameter_value_table;                                                                   
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      altered_pdt_p: ^clt$parameter_description_table,                                                        
      default_index: 0 .. clc$max_parameters,                                                                 
      defaults_changed: 0 .. clc$max_parameters,                                                              
      parameter_index: clt$parameter_number,                                                                  
      parameter_value: ost$name,                                                                              
      pdt_changes_p: ^clt$pdt_changes;                                                                        
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Make a copy of the PDT.                                                                                 
                                                                                                              
    PUSH altered_pdt_p: [[REP #SIZE (pdt_p^) OF cell]];                                                       
    IF altered_pdt_p = NIL THEN                                                                               
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    RESET altered_pdt_p;                                                                                      
    altered_pdt_p^ := pdt_p^;                                                                                 
                                                                                                              
    { Determine how many default parameters sent to this procedure actually have defaults set.                
                                                                                                              
    defaults_changed := 0;                                                                                    
    FOR parameter_index := 1 TO UPPERBOUND (default_list) DO                                                  
      IF duv$default_parameters [default_list [parameter_index].default_name].default_set THEN                
        defaults_changed := defaults_changed + 1;                                                             
      IFEND;                                                                                                  
    FOREND;                                                                                                   
                                                                                                              
    { Change the default parameters that have defaults set.                                                   
                                                                                                              
    IF defaults_changed > 0 THEN                                                                              
      PUSH pdt_changes_p: [1 .. defaults_changed];                                                            
      IF pdt_changes_p = NIL THEN                                                                             
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      default_index := 0;                                                                                     
      FOR parameter_index := 1 TO UPPERBOUND (default_list) DO                                                
        IF duv$default_parameters [default_list [parameter_index].default_name].default_set THEN              
          default_index := default_index + 1;                                                                 
          parameter_value := duv$default_parameters [default_list [parameter_index].default_name].value;      
          PUSH pdt_changes_p^ [default_index].default_value: [#SIZE (parameter_value)];                       
          IF pdt_changes_p^ [default_index].default_value = NIL THEN                                          
            osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                      
            RETURN;  {---->                                                                                   
          IFEND;                                                                                              
          pdt_changes_p^ [default_index].number := default_list [parameter_index].number;                     
          pdt_changes_p^ [default_index].kind := clc$pdtc_default_value;                                      
          pdt_changes_p^ [default_index].default_value^ := parameter_value;                                   
        IFEND;                                                                                                
      FOREND;                                                                                                 
      clp$change_pdt (altered_pdt_p, pdt_changes_p^, status);                                                 
    IFEND;                                                                                                    
                                                                                                              
    clp$evaluate_parameters (parameter_list, altered_pdt_p, NIL, pvt_p, status);                              
                                                                                                              
  PROCEND dup$evaluate_parameters;                                                                            
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$find_record_list_entry', EJECT ??                                                         
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure returns the list index of a record from the "other records" list.  A NIL pointer is        
{   returned if the record is not found.                                                                      
                                                                                                              
  PROCEDURE [XDCL] dup$find_record_list_entry                                                                 
    (    data_value: clt$data_value;                                                                          
     VAR entry_p: ^dut$de_other_record_entry);                                                                
                                                                                                              
    VAR                                                                                                       
      cell_p: ^cell,                                                                                          
      list_index: 0 .. duc$de_max_other_records,                                                              
      name_index: 0 .. 3,                                                                                     
      record_name: dut$de_other_record_name,                                                                  
      restart_file_seq_p: ^SEQ ( * ),                                                                         
      search_entry_p: ^dut$de_other_record_entry,                                                             
      search_index: 0 .. duc$de_max_other_records,                                                            
      string_length: integer,                                                                                 
      temp_record_name: dut$de_other_record_name;                                                             
                                                                                                              
    entry_p := NIL;                                                                                           
    IF NOT duv$dump_environment_p^.other_records.available THEN                                               
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    search_index := 0;                                                                                        
    temp_record_name := ' ';                                                                                  
    IF data_value.kind = clc$integer THEN                                                                     
      IF (data_value.integer_value.value > 0) AND                                                             
            (data_value.integer_value.value <= duv$dump_environment_p^.other_records.number_of_records) THEN  
        search_index := data_value.integer_value.value;                                                       
      ELSE                                                                                                    
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
    ELSE                                                                                                      
      IF data_value.kind = clc$name THEN                                                                      
        record_name := data_value.name_value (1, 3);                                                          
      ELSE                                                                                                    
        record_name := data_value.string_value^;                                                              
      IFEND;                                                                                                  
                                                                                                              
      { Convert the record name from lower case to upper case if necessary.                                   
                                                                                                              
      FOR name_index := 1 TO 3 DO                                                                             
        IF ($INTEGER (record_name (name_index)) >= $INTEGER('a')) AND                                         
              ($INTEGER (record_name (name_index)) <= $INTEGER('z')) THEN                                     
          STRINGREP (temp_record_name (name_index), string_length,                                            
                $CHAR (($INTEGER (record_name (name_index)) - $INTEGER('a')) + $INTEGER('A')));               
        ELSE                                                                                                  
          temp_record_name (name_index) := record_name (name_index);                                          
        IFEND;                                                                                                
      FOREND;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    { Search the list for the correct record.                                                                 
                                                                                                              
    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;            
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),                            
          duv$dump_environment_p^.other_records.first_record);                                                
                                                                                                              
    list_index := 1;                                                                                          
    WHILE list_index <= duv$dump_environment_p^.other_records.number_of_records DO                            
      RESET restart_file_seq_p TO cell_p;                                                                     
      NEXT search_entry_p IN restart_file_seq_p;                                                              
      IF search_entry_p = NIL THEN                                                                            
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      IF (search_entry_p^.index = search_index) OR (search_entry_p^.name = temp_record_name) THEN             
        entry_p := search_entry_p;                                                                            
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      IF (search_entry_p^.name = 'CCM') AND                                                                   
            duv$dump_environment_p^.critical_memory.multiple_ccm_exists THEN                                  
        cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),                        
              duv$dump_environment_p^.critical_memory.last_ccm_other_record);                                 
        RESET restart_file_seq_p TO cell_p;                                                                   
        NEXT search_entry_p IN restart_file_seq_p;                                                            
        IF search_entry_p = NIL THEN                                                                          
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
        list_index := search_entry_p^.index + 1;                                                              
      ELSE                                                                                                    
        list_index := list_index + 1;                                                                         
      IFEND;                                                                                                  
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),                          
            search_entry_p^.next_record);                                                                     
    WHILEND;                                                                                                  
                                                                                                              
  PROCEND dup$find_record_list_entry;                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$is_cpu1_installed', EJECT ??                                                              
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure determines if the second cpu is installed and displays a message if it installed but not   
{   available on the dump.                                                                                    
                                                                                                              
  PROCEDURE [XDCL] dup$is_cpu1_installed                                                                      
    (    origin: dut$ee_cpu1_installed_commands;                                                              
         processor: 0 .. duc$de_maximum_processors;                                                           
     VAR display_control: clt$display_control);                                                               
                                                                                                              
    CONST                                                                                                     
      c$text = 'The second processor is installed but the maintenance register data is not on the dump.';     
                                                                                                              
    TYPE                                                                                                      
      t$register_byte_or_bit = PACKED RECORD                                                                  
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          byte_part: ARRAY [1 .. duc$de_max_register_length] OF 0 .. 0ff(16),                                 
        = FALSE =                                                                                             
          bit_part: PACKED ARRAY [0 .. 63] OF boolean,                                                        
        CASEND,                                                                                               
      RECEND;                                                                                                 
                                                                                                              
    VAR                                                                                                       
      ignore_status: ost$status,                                                                              
      register: dut$de_maintenance_register,                                                                  
      register_byte_or_bit: t$register_byte_or_bit;                                                           
                                                                                                              
    IF processor <> 1 THEN                                                                                    
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF NOT duv$dump_environment_p^.pro_maintenance_registers [0].available OR                                 
          duv$dump_environment_p^.pro_maintenance_registers [1].available THEN                                
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    dup$retrieve_register (duc$de_cpu, 0, 12(16), register);                                                  
    register_byte_or_bit.byte_part := register.value;                                                         
    IF register.available AND register_byte_or_bit.bit_part [59] THEN                                         
      CASE origin OF                                                                                          
      = duc$ee_cic_disd =                                                                                     
        clp$put_partial_display (display_control, '     ', clc$no_trim, amc$continue, ignore_status);         
        clp$put_partial_display (display_control, c$text, clc$no_trim, amc$terminate, ignore_status);         
      = duc$ee_cic_dismr =                                                                                    
        display_control.line_number := display_control.page_length + 1;                                       
        clp$new_display_line (display_control, 1, ignore_status);                                             
        clp$put_partial_display (display_control, '  PROCESSOR 01', clc$no_trim, amc$terminate,               
              ignore_status);                                                                                 
        clp$new_display_line (display_control, 1, ignore_status);                                             
        clp$put_partial_display (display_control, c$text, clc$no_trim, amc$terminate, ignore_status);         
      ELSE                                                                                                    
      CASEND;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
  PROCEND dup$is_cpu1_installed;                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$put_item', EJECT ??                                                                       
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure places an item on the output file.                                                         
                                                                                                              
  PROCEDURE [XDCL] dup$put_item                                                                               
    (    item: string ( * );                                                                                  
         trim_option: clt$trim_display_text_option;                                                           
         term_option: amt$term_option;                                                                        
     VAR display_control: clt$display_control);                                                               
                                                                                                              
    CONST                                                                                                     
      c$alignment = 3;                                                                                        
                                                                                                              
    VAR                                                                                                       
      ignore_status: ost$status,                                                                              
      item_index: ost$string_index,                                                                           
      item_size: ost$string_size;                                                                             
                                                                                                              
    item_size := STRLENGTH (item);                                                                            
                                                                                                              
    { Trim the item that is to be displayed.                                                                  
                                                                                                              
    IF trim_option = clc$trim THEN                                                                            
      WHILE (item_size > 2) AND (item (item_size) = ' ') DO                                                   
        item_size := item_size - 1;                                                                           
      WHILEND;                                                                                                
    IFEND;                                                                                                    
                                                                                                              
    IF item (1, 2) = ', ' THEN                                                                                
      clp$put_partial_display (display_control, ', ', clc$no_trim, amc$continue, ignore_status);              
      item_index := 3;                                                                                        
      item_size := item_size - 2;                                                                             
    ELSE                                                                                                      
      item_index := 1;                                                                                        
    IFEND;                                                                                                    
                                                                                                              
    IF (display_control.column_number <> 1) AND                                                               
          ((display_control.column_number + item_size) > display_control.page_width) THEN                     
      clp$new_display_line (display_control, 0, ignore_status);                                               
      clp$horizontal_tab_display (display_control, c$alignment, ignore_status);                               
    IFEND;                                                                                                    
                                                                                                              
    clp$put_partial_display (display_control, item (item_index, item_size), clc$no_trim, term_option,         
          ignore_status);                                                                                     
                                                                                                              
  PROCEND dup$put_item;                                                                                       
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$retrieve_bc_entry', EJECT ??                                                              
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure retrieves a buffer controlware entry.  A NIL pointer is returned if the entry is not found.
                                                                                                              
  PROCEDURE [XDCL] dup$retrieve_bc_entry                                                                      
    (    channel_number: 0 .. duc$de_maximum_channels;                                                        
     VAR entry_p: ^dut$de_buffer_controlware_entry);                                                          
                                                                                                              
    VAR                                                                                                       
      cell_p: ^cell,                                                                                          
      index: 0 .. 0ff(16),                                                                                    
      restart_file_seq_p: ^SEQ ( * ),                                                                         
      search_entry_p: ^dut$de_buffer_controlware_entry;                                                       
                                                                                                              
    entry_p := NIL;                                                                                           
    IF NOT duv$dump_environment_p^.buffer_controlware.available THEN                                          
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;            
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),                            
          duv$dump_environment_p^.buffer_controlware.first_bc_entry);                                         
    FOR index := 1 TO duv$dump_environment_p^.buffer_controlware.number_of_entries DO                         
      RESET restart_file_seq_p TO cell_p;                                                                     
      NEXT search_entry_p IN restart_file_seq_p;                                                              
      IF search_entry_p = NIL THEN                                                                            
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      IF search_entry_p^.channel_number = channel_number THEN                                                 
        entry_p := search_entry_p;                                                                            
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),                          
            search_entry_p^.next_bc_entry);                                                                   
    FOREND;                                                                                                   
                                                                                                              
  PROCEND dup$retrieve_bc_entry;                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$retrieve_cip_program', EJECT ??                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure retrieves an address to a CIP program in the EIC record.                                   
                                                                                                              
  PROCEDURE [XDCL] dup$retrieve_cip_program                                                                   
    (    cip_program_name: string (4);                                                                        
     VAR cip_program_available: boolean;                                                                      
     VAR cip_program_cell_p: ^cell);                                                                          
                                                                                                              
    CONST                                                                                                     
      c$number_of_words_before_dscm2 = 32;                                                                    
                                                                                                              
    TYPE                                                                                                      
      t$data = RECORD                                                                                         
        first_half: 0 .. 0ffff(16),                                                                           
        second_half: 0 .. 0ffff(16),                                                                          
        unused: 0 .. 0ffff(16),                                                                               
        size: 0 .. 0ffff(16),                                                                                 
      RECEND,                                                                                                 
                                                                                                              
      t$memory_register =  PACKED RECORD                                                                      
        CASE 0 .. 2 OF                                                                                        
        = 0 =                                                                                                 
          unused_0_a: 0 .. 0ffffffff(16),                                                                     
          unused_0_b: 0 .. 01fff(16),                                                                         
          bounds_bits_45_63: 0 .. 07ffff(16),                                                                 
        = 1 =                                                                                                 
          unused_1: 0 .. 0ffffffff(16),                                                                       
          bounds_bits_32_47: 0 .. 0ffff(16),                                                                  
          bounds_bits_48_63: 0 .. 0ffff(16),                                                                  
        = 2 =                                                                                                 
          value: ARRAY [1 .. duc$de_max_register_length] OF 0 .. 0ff(16),                                     
        CASEND,                                                                                               
      RECEND;                                                                                                 
                                                                                                              
    VAR                                                                                                       
      cell_p: ^cell,                                                                                          
      cip_name: 0 .. 077777777(8),                                                                            
      cpu_index: 0 .. duc$de_maximum_processors,                                                              
      cti_cm_directory_address: integer,                                                                      
      data_p: ^t$data,                                                                                        
      data_value: clt$data_value,                                                                             
      display_code: 0 .. 077777777(8),                                                                        
      entry_p: ^dut$de_other_record_entry,                                                                    
      index: 1 .. 4,                                                                                          
      model_number: 0 .. 0ff(16),                                                                             
      memory_bounds: integer,                                                                                 
      memory_register: t$memory_register,                                                                     
      offset: integer,                                                                                        
      r_pointer_p: ^dst$r_pointer,                                                                            
      record_size: integer,                                                                                   
      register: dut$de_maintenance_register,                                                                  
      restart_file_seq_p: ^SEQ ( * ),                                                                         
      skip_p: ^SEQ ( * ),                                                                                     
      use_bits_45_63: boolean;                                                                                
                                                                                                              
    cip_program_available := FALSE;                                                                           
    cip_program_cell_p := NIL;                                                                                
                                                                                                              
    { Retrieve the Processor model number and determine which way to read the memory bounds register.         
    { 930, 960, 962 and the 2000 use bits 45-63.  Every other machine uses bits 32-47.                        
                                                                                                              
   /search_cpus/                                                                                              
    FOR cpu_index := 0 TO duc$de_maximum_processors DO                                                        
      dup$retrieve_register (duc$de_cpu, cpu_index, 10(16), register);                                        
      IF register.available THEN                                                                              
        model_number := register.value [duc$de_model_byte_number];                                            
        EXIT /search_cpus/;  {---->                                                                           
      IFEND;                                                                                                  
    FOREND /search_cpus/;                                                                                     
    IF NOT register.available THEN                                                                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    use_bits_45_63 :=                                                                                         
          ((model_number >= 50(16)) AND (model_number <= 5f(16))) OR   {  93x mainframe }                     
          ((model_number >= 3a(16)) AND (model_number <= 3d(16))) OR   {  96x mainframe }                     
          ((model_number >= 46(16)) AND (model_number <= 48(16)));     { 2000 mainframe }                     
                                                                                                              
    { Retrieve the address to the CTI Directory from word DSCM+2 in the DSB record.                           
                                                                                                              
    data_value.kind := clc$name;                                                                              
    data_value.name_value := 'DSB';                                                                           
    dup$find_record_list_entry (data_value, entry_p);                                                         
    IF entry_p = NIL THEN                                                                                     
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;            
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);      
    RESET restart_file_seq_p TO cell_p;                                                                       
    NEXT skip_p: [[REP c$number_of_words_before_dscm2 OF integer]] IN restart_file_seq_p;                     
    IF skip_p = NIL THEN                                                                                      
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    NEXT r_pointer_p IN restart_file_seq_p;                                                                   
    IF r_pointer_p = NIL THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    cti_cm_directory_address := (r_pointer_p^.rupper * 10000000(8)) + (r_pointer_p^.rlower * 1000(8)) +       
          (r_pointer_p^.offset * 10(8));                                                                      
                                                                                                              
    { Retrieve the memory bounds from memory register 21(16).                                                 
                                                                                                              
    dup$retrieve_register (duc$de_memory, 0, 21(16), register);                                               
    IF NOT register.available THEN                                                                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    memory_register.value := register.value;                                                                  
    IF use_bits_45_63 THEN                                                                                    
      memory_bounds := memory_register.bounds_bits_45_63 * 4096;                                              
    ELSE                                                                                                      
      memory_bounds := memory_register.bounds_bits_32_47 * 4096;                                              
    IFEND;                                                                                                    
                                                                                                              
    { The difference between the CTI directory address and the memory bounds is the offset into               
    { the EIC record of where the CTI directory begins.                                                       
                                                                                                              
    offset := cti_cm_directory_address - memory_bounds;                                                       
                                                                                                              
    { Convert the cip program name desired to display code.                                                   
                                                                                                              
    display_code := 0;                                                                                        
    FOR index := 1 TO 4 DO                                                                                    
      display_code := display_code * 100(8);                                                                  
      IF (cip_program_name(index) >= '0') AND (cip_program_name(index) <= '9') THEN                           
        display_code := display_code + $INTEGER (cip_program_name(index)) - $INTEGER ('0') + 33(8);           
      ELSEIF (cip_program_name(index) >= 'A') AND (cip_program_name(index) <= 'Z') THEN                       
        display_code := display_code + $INTEGER (cip_program_name(index)) - $INTEGER ('A') + 01(8);           
      IFEND;                                                                                                  
    FOREND;                                                                                                   
                                                                                                              
    { Retrieve the EIC record and skip to the CTI directory.                                                  
                                                                                                              
    data_value.kind := clc$name;                                                                              
    data_value.name_value := 'EIC';                                                                           
    dup$find_record_list_entry (data_value, entry_p);                                                         
    IF entry_p = NIL THEN                                                                                     
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;            
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);      
    RESET restart_file_seq_p TO cell_p;                                                                       
    record_size := entry_p^.size;                                                                             
    NEXT skip_p: [[REP offset OF cell]] IN restart_file_seq_p;                                                
    IF skip_p = NIL THEN                                                                                      
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    record_size := record_size - #SIZE (skip_p^);                                                             
                                                                                                              
    { Search for the desired CIP program.                                                                     
                                                                                                              
    WHILE record_size > 0 DO                                                                                  
      NEXT data_p IN restart_file_seq_p;                                                                      
      IF data_p = NIL THEN                                                                                    
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      RESET restart_file_seq_p TO data_p;                                                                     
      cip_name := (data_p^.first_half * 10000(8)) + data_p^.second_half;                                      
      IF cip_name = display_code THEN                                                                         
        NEXT cip_program_cell_p IN restart_file_seq_p;                                                        
        cip_program_available := (cip_program_cell_p <> NIL);                                                 
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      NEXT skip_p: [[REP (data_p^.size * 8) OF cell]] IN restart_file_seq_p;                                  
      IF skip_p = NIL THEN                                                                                    
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      record_size := record_size - #SIZE (skip_p^);                                                           
    WHILEND;                                                                                                  
                                                                                                              
  PROCEND dup$retrieve_cip_program;                                                                           
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$retrieve_dft_pointers', EJECT ??                                                          
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure sets up the individual buffer pointers to the DFT structure.                               
                                                                                                              
  PROCEDURE [XDCL] dup$retrieve_dft_pointers                                                                  
    (VAR dft_data: dut$dft_data;                                                                              
     VAR data_length_valid: boolean;                                                                          
     VAR data_valid: boolean);                                                                                
                                                                                                              
    VAR                                                                                                       
      cell_p: ^cell,                                                                                          
      data_length: integer,                                                                                   
      data_value: clt$data_value,                                                                             
      dft_cw_p: ^dst$dftb_control_word,                                                                       
      dft_dump_record_size: amt$file_byte_address,                                                            
      dump_information: dut$dump_information,                                                                 
      entry_p: ^dut$de_other_record_entry,                                                                    
      index: dst$dftb_element_size,                                                                           
      mdb_p: ^ARRAY [1 .. *] OF dst$r_pointer,                                                                
      pointer_index: 1 .. duc$dft_max_known_pointer_words,                                                    
      r_pointer_words_p: ^dst$dftb_r_pointer_words,                                                           
      restart_file_seq_p: ^SEQ ( * ),                                                                         
      second_seq_p: ^SEQ ( * ),                                                                               
      seq_p: ^SEQ ( * );                                                                                      
                                                                                                              
    data_length_valid := FALSE;                                                                               
    data_valid := FALSE;                                                                                      
                                                                                                              
    data_value.kind := clc$name;                                                                              
    data_value.name_value := 'DFT';                                                                           
    dup$find_record_list_entry (data_value, entry_p);                                                         
    IF entry_p = NIL THEN                                                                                     
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;            
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);      
    dft_dump_record_size := entry_p^.size;                                                                    
                                                                                                              
    RESET restart_file_seq_p TO cell_p;                                                                       
    NEXT dft_cw_p IN restart_file_seq_p;                                                                      
    IF (dft_cw_p = NIL) OR (dft_cw_p^.revision_level < 4) THEN                                                
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    dft_data.actual_number_of_pointer_words := dft_cw_p^.pointer_words - 1;                                   
    IF dft_data.actual_number_of_pointer_words > duc$dft_max_known_pointer_words THEN                         
      dft_data.number_of_pointer_words := duc$dft_max_known_pointer_words;                                    
    ELSE                                                                                                      
      dft_data.number_of_pointer_words := dft_data.actual_number_of_pointer_words;                            
    IFEND;                                                                                                    
                                                                                                              
    dft_data.revision_level := dft_cw_p^.revision_level;                                                      
    dft_data.mrb_length := dft_cw_p^.mrb_length;                                                              
    dft_data.buffer [duc$dft_cw].cell_p := ^dft_cw_p^;                                                        
    dft_data.buffer [duc$dft_cw].size := #SIZE (dft_cw_p^) DIV 8;                                             
                                                                                                              
    data_length := 0;                                                                                         
    NEXT r_pointer_words_p: [1 .. dft_data.actual_number_of_pointer_words] IN restart_file_seq_p;             
    IF r_pointer_words_p = NIL THEN                                                                           
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    FOR pointer_index := 1 TO dft_data.number_of_pointer_words DO                                             
      IF r_pointer_words_p^ [pointer_index].length > 0 THEN                                                   
        NEXT seq_p: [[REP (r_pointer_words_p^ [pointer_index].length * 8) OF cell]] IN restart_file_seq_p;    
        IF seq_p = NIL THEN                                                                                   
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
        RESET seq_p;                                                                                          
        dft_data.buffer [pointer_index].cell_p := ^seq_p^;                                                    
        dft_data.buffer [pointer_index].size := r_pointer_words_p^ [pointer_index].length;                    
        data_length := data_length + dft_data.buffer [pointer_index].size;                                    
        IF pointer_index = dsc$dftb_rpw_mdb THEN                                                              
          dup$determine_dump_information (dump_information);                                                  
          IF dump_information.dump_type = duc$di_dt_unknown THEN                                              
            RETURN;  {---->                                                                                   
          IFEND;                                                                                              
          IF dump_information.dump_type = duc$di_dt_edd THEN                                                  
            RESET restart_file_seq_p TO seq_p;                                                                
            NEXT mdb_p: [1 .. r_pointer_words_p^ [pointer_index].length] IN restart_file_seq_p;               
            IF mdb_p = NIL THEN                                                                               
              RETURN;  {---->                                                                                 
            IFEND;                                                                                            
            FOR index := 1 TO r_pointer_words_p^ [pointer_index].length DO                                    
              IF mdb_p^ [index].length > 0 THEN                                                               
                NEXT second_seq_p: [[REP (mdb_p^ [index].length * 8) OF cell]] IN restart_file_seq_p;         
                IF second_seq_p = NIL THEN                                                                    
                  RETURN;  {---->                                                                             
                IFEND;                                                                                        
                RESET second_seq_p;                                                                           
                dft_data.mdb [index].cell_p := ^second_seq_p^;                                                
                dft_data.mdb [index].size := mdb_p^ [index].length;                                           
                data_length := data_length + dft_data.mdb [index].size;                                       
              ELSE                                                                                            
                dft_data.mdb [index].cell_p := NIL;                                                           
                dft_data.mdb [index].size := 0;                                                               
              IFEND;                                                                                          
            FOREND;                                                                                           
          IFEND;                                                                                              
        IFEND;                                                                                                
      ELSE                                                                                                    
        dft_data.buffer [pointer_index].cell_p := NIL;                                                        
        dft_data.buffer [pointer_index].size := 0;                                                            
      IFEND;                                                                                                  
    FOREND;                                                                                                   
                                                                                                              
    data_value.kind := clc$name;                                                                              
    data_value.name_value := 'PS1';                                                                           
    dup$find_record_list_entry (data_value, entry_p);                                                         
    IF entry_p = NIL THEN                                                                                     
      dft_data.buffer [dsc$dftb_rpw_dft_secondary].cell_p := NIL;                                             
    IFEND;                                                                                                    
                                                                                                              
    data_length_valid := ((data_length * 8) <= dft_dump_record_size);                                         
    data_valid := TRUE;                                                                                       
                                                                                                              
  PROCEND dup$retrieve_dft_pointers;                                                                          
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$retrieve_exchange_package', EJECT ??                                                      
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure retrieves the correct exchange package.                                                    
                                                                                                              
  PROCEDURE [XDCL] dup$retrieve_exchange_package                                                              
    (    processor: 0 .. duc$de_maximum_processors;                                                           
         exchange_parameter: clt$data_value;                                                                  
     VAR exchange_package_p: ^dut$exchange_package;                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      new_byte_size: ost$segment_length;                                                                      
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    IF exchange_parameter.kind = clc$integer THEN                                                             
      dup$access_real_memory (#SIZE (dut$exchange_package), exchange_parameter.integer_value.value,           
            exchange_package_p, new_byte_size, status);                                                       
      IF NOT status.normal THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
    ELSE { exchange_parameter.kind = clc$keyword }                                                            
      IF exchange_parameter.keyword_value = 'ACTIVE' THEN                                                     
        IF NOT duv$dump_environment_p^.active_exchange [processor].available THEN                             
          osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                
                'The active exchange package for processor', status);                                         
          osp$append_status_integer (osc$status_parameter_delimiter, processor, 10, FALSE, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);                         
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
        exchange_package_p := ^duv$dump_environment_p^.active_exchange [processor].value;                     
                                                                                                              
      ELSEIF exchange_parameter.keyword_value = 'MONITOR' THEN                                                
        IF NOT duv$execution_environment.processor_registers [processor].available THEN                       
          osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                
                'The mps register for processor', status);                                                    
          osp$append_status_integer (osc$status_parameter_delimiter, processor, 10, FALSE, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);                         
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
        dup$access_real_memory (#SIZE (dut$exchange_package),                                                 
              duv$execution_environment.processor_registers [processor].monitor_process_state,                
              exchange_package_p, new_byte_size, status);                                                     
        IF NOT status.normal THEN                                                                             
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
                                                                                                              
      ELSEIF exchange_parameter.keyword_value = 'JOB' THEN                                                    
        IF NOT duv$execution_environment.processor_registers [processor].available THEN                       
          osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                
                'The jps register for processor', status);                                                    
          osp$append_status_integer (osc$status_parameter_delimiter, processor, 10, FALSE, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);                         
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
        dup$access_real_memory (#SIZE (dut$exchange_package),                                                 
              duv$execution_environment.processor_registers [processor].job_process_state,                    
              exchange_package_p, new_byte_size, status);                                                     
        IF NOT status.normal THEN                                                                             
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
  PROCEND dup$retrieve_exchange_package;                                                                      
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$retrieve_register', EJECT ??                                                              
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure retrieves a register for a particular element.                                             
                                                                                                              
  PROCEDURE [XDCL] dup$retrieve_register                                                                      
    (    element: dut$de_element;                                                                             
         element_index: 0 .. 0ff(16);                                                                         
         register_number: 0 .. duc$de_max_register_number;                                                    
     VAR register: dut$de_maintenance_register);                                                              
                                                                                                              
    VAR                                                                                                       
      index: 0 .. 0ffff(16);                                                                                  
                                                                                                              
    CASE element OF                                                                                           
    = duc$de_iou =                                                                                            
      IF duv$dump_environment_p^.iou_maintenance_registers [element_index].available THEN                     
        FOR index := 1 TO duc$de_number_of_iou_mrs_dumped DO                                                  
          register := duv$dump_environment_p^.iou_maintenance_registers [element_index].registers [index];    
          IF register.available AND (register.number = register_number) THEN                                  
            RETURN;  {---->                                                                                   
          IFEND;                                                                                              
        FOREND;                                                                                               
      IFEND;                                                                                                  
    = duc$de_cpu =                                                                                            
      IF duv$dump_environment_p^.pro_maintenance_registers [element_index].available THEN                     
        FOR index := 1 TO duc$de_number_of_pro_mrs_dumped DO                                                  
          register := duv$dump_environment_p^.pro_maintenance_registers [element_index].registers [index];    
          IF register.available AND (register.number = register_number) THEN                                  
            RETURN;  {---->                                                                                   
          IFEND;                                                                                              
        FOREND;                                                                                               
      IFEND;                                                                                                  
    = duc$de_memory =                                                                                         
      IF duv$dump_environment_p^.mem_maintenance_registers.available THEN                                     
        FOR index := 1 TO duc$de_number_of_mem_mrs_dumped DO                                                  
          register := duv$dump_environment_p^.mem_maintenance_registers.registers [index];                    
          IF register.available AND (register.number = register_number) THEN                                  
            RETURN;  {---->                                                                                   
          IFEND;                                                                                              
        FOREND;                                                                                               
      IFEND;                                                                                                  
    ELSE                                                                                                      
    CASEND;                                                                                                   
    register.available := FALSE;                                                                              
                                                                                                              
  PROCEND dup$retrieve_register;                                                                              
MODEND dum$common_analyzer_routines;                                                                          
*DECK DECK=DUM$COMPARE_CONTROL_STORE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Compare Control Store Command' ??
MODULE dum$compare_control_store;

{ PURPOSE:
{   This module contains the code for the compare_control_store command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc amp$get_segment_pointer
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_partial_display
*copyc dup$evaluate_parameters
*copyc dup$new_page_procedure
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'dup$compare_control_store', EJECT ??

  PROCEDURE [XDCL] dup$compare_control_store
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE compare_control_store, comcs (
{   file, f: file = $required
{   processor, p: integer 0..3 = 0
{   shadow, s: boolean = FALSE
{   display_option, do: key
{       (brief b) (full f)
{     keyend = brief
{   title, t: string 1..31 = 'compare_control_store'
{   output, o: file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (23),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 9, 19, 8, 4, 41, 678],
    clc$command, 13, 7, 1, 0, 0, 0, 7, ''], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 4],
    ['DO                             ',clc$abbreviation_entry, 4],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 6],
    ['OUTPUT                         ',clc$nominal_entry, 6],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PROCESSOR                      ',clc$nominal_entry, 2],
    ['S                              ',clc$abbreviation_entry, 3],
    ['SHADOW                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 7],
    ['T                              ',clc$abbreviation_entry, 5],
    ['TITLE                          ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 5
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 23],
{ PARAMETER 6
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 7
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, 3, 10],
    '0'],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'FALSE'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BRIEF                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FULL                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'brief'],
{ PARAMETER 5
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''compare_control_store'''],
{ PARAMETER 6
    [[1, 0, clc$file_type]],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$processor = 2,
      p$shadow = 3,
      p$display_option = 4,
      p$title = 5,
      p$output = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

    TYPE
      t$array_or_word = RECORD
        CASE boolean OF
        = TRUE =
          array_part: ARRAY [1 .. 8] OF 0 .. 0ffff(16),
        = FALSE =
          word_part: dut$de_control_store_word,
        CASEND,
      RECEND;

    VAR
      actual_p: ^PACKED ARRAY [0 .. 127] OF 0 .. 1,
      array_or_word: t$array_or_word,
      bit: 0 .. 127,
      cell_p: ^cell,
      control_store_entry: dut$de_control_store_entry,
      control_store_size: 0 .. duc$de_control_store_size,
      default_list: ARRAY [1 .. 1] OF dut$default_change_list_entry,
      display_control: clt$display_control,
      error_count: 0 .. duc$de_control_store_size,
      expected_p: ^PACKED ARRAY [0 .. 127] OF 0 .. 1,
      fa_p: ^fst$attachment_options,
      file_buffer_p: ^ARRAY [0 .. *] OF dut$de_control_store_word,
      file_identifier: amt$file_identifier,
      file_pointer: amt$segment_pointer,
      group_index: 1 .. 8,
      ignore_status: ost$status,
      index: 0 .. duc$de_control_store_size,
      mca_p: ^fst$file_cycle_attributes,
      output_display_opened: boolean,
      processor: 0 .. 3,
      restart_file_buffer_p: ^ARRAY [0 .. *] OF dut$de_control_store_word,
      restart_file_seq_p: ^SEQ ( * ),
      ring_attributes: amt$ring_attributes,
      string_10: string (10),
      string_2: string (2),
      string_3: string (3),
      string_4: string (4);

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the files.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      fsp$close_file (file_identifier, ignore_status);
      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE , EJECT ??

    status.normal := TRUE;

    { Change the default value for the PROCESSOR parameter.

    default_list [1].default_name := duc$dp_processor;
    default_list [1].number := p$processor;
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    processor := pvt [p$processor].value^.integer_value.value;
    IF pvt [p$shadow].value^.boolean_value.value THEN
      control_store_entry := duv$dump_environment_p^.control_store.shadow [processor];
    ELSE
      control_store_entry := duv$dump_environment_p^.control_store.main [processor];
    IFEND;
    IF NOT control_store_entry.available THEN
      IF pvt [p$shadow].value^.boolean_value.value THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,
              'The shadow control store for processor', status);
      ELSE
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,
              'The main control store for processor', status);
      IFEND;
      osp$append_status_integer (osc$status_parameter_delimiter, processor, 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

    { Open the input compare file.

    PUSH fa_p: [1 .. 1];
    fa_p^ [1].selector := fsc$access_and_share_modes;
    fa_p^ [1].access_modes.selector := fsc$specific_access_modes;
    fa_p^ [1].access_modes.value := $fst$file_access_options [fsc$read];
    fa_p^ [1].share_modes.selector := fsc$specific_share_modes;
    fa_p^ [1].share_modes.value := $fst$file_access_options [fsc$read];

    PUSH mca_p: [1 .. 2];
    mca_p^ [1].selector := fsc$record_type;
    mca_p^ [1].record_type := amc$undefined;
    mca_p^ [2].selector := fsc$preset_value;
    mca_p^ [2].preset_value := -1;

    fsp$open_file (pvt [p$file].value^.file_value^, amc$segment, fa_p, NIL, mca_p, NIL, NIL, file_identifier,
          status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

   /file_opened/
    BEGIN
      amp$get_segment_pointer (file_identifier, amc$sequence_pointer, file_pointer, status);
      IF NOT status.normal THEN
        EXIT /file_opened/;  {---->
      IFEND;
      IF file_pointer.sequence_pointer = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /file_opened/;  {---->
      IFEND;
      RESET file_pointer.sequence_pointer;

      { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /file_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      { Build a sequence pointer to the control store data in the restart file.

      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),
            control_store_entry.first_byte);
      RESET restart_file_seq_p TO cell_p;
      control_store_size := control_store_entry.size;

      { Retrieve the control store data from the restart file.

      NEXT restart_file_buffer_p: [0 .. control_store_size - 1] IN restart_file_seq_p;
      IF restart_file_buffer_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /file_opened/;  {---->
      IFEND;

      { Retrieve the control store data from the input file.

      RESET file_pointer.sequence_pointer;
      NEXT file_buffer_p: [0 .. control_store_size - 1] IN file_pointer.sequence_pointer;
      IF file_buffer_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /file_opened/;  {---->
      IFEND;

      { Display the processor number.

      clp$new_display_line (display_control, 1, ignore_status);
      clp$put_partial_display (display_control, '   PROCESSOR   ', clc$no_trim, amc$continue, ignore_status);
      string_2 := 'XX';
      clp$convert_integer_to_rjstring (processor, 16, FALSE, '0', string_2, ignore_status);
      clp$put_partial_display (display_control, string_2, clc$no_trim, amc$terminate, ignore_status);

      error_count := 0;

      { Compare the control store data on the restart file with the control store data on the input file
      { word by word.

      FOR index := 0 TO (control_store_size - 1) DO
        IF restart_file_buffer_p^ [index] <> file_buffer_p^ [index] THEN
          error_count := error_count + 1;
          clp$new_display_line (display_control, 1, ignore_status);

          { Display the address of the failing word.

          clp$put_partial_display (display_control, '    word = ', clc$no_trim, amc$start, ignore_status);
          string_10 := 'XXXXXXXXXX';
          clp$convert_integer_to_rjstring (index, 16, TRUE, '0', string_10, ignore_status);
          clp$put_partial_display (display_control, string_10, clc$trim, amc$continue, ignore_status);

          { Display the identification of the failing bits.

          IF pvt [p$display_option].value^.name_value = 'FULL' THEN
            expected_p := #LOC (restart_file_buffer_p^ [index]);
            actual_p := #LOC (file_buffer_p^ [index]);
            FOR bit := 0 TO 127 DO
              IF expected_p^ [bit] <> actual_p^ [bit] THEN
                clp$put_partial_display (display_control, '     bit = ', clc$no_trim, amc$start,
                      ignore_status);
                string_3 := 'XXX';
                clp$convert_integer_to_rjstring (bit, 10, FALSE, ' ', string_3, ignore_status);
                clp$put_partial_display (display_control, string_3, clc$trim, amc$continue, ignore_status);
              IFEND;
            FOREND;
          IFEND;

          { Display the expected control store word.

          array_or_word.word_part := file_buffer_p^ [index];
          clp$put_partial_display (display_control, 'expected = ', clc$no_trim, amc$start, ignore_status);
          FOR group_index := 1 TO 8 DO
            string_4 := 'XXXX';
            clp$convert_integer_to_rjstring (array_or_word.array_part [group_index], 16, FALSE, '0', string_4,
                  ignore_status);
            clp$put_partial_display (display_control, string_4, clc$trim, amc$continue, ignore_status);
            clp$put_partial_display (display_control, ' ', clc$no_trim, amc$continue, ignore_status);
          FOREND;

         { Display the actual control store word.

          array_or_word.word_part := restart_file_buffer_p^ [index];
          clp$put_partial_display (display_control, '  actual = ', clc$no_trim, amc$start, ignore_status);
          FOR group_index := 1 TO 8 DO
            string_4 := 'XXXX';
            clp$convert_integer_to_rjstring (array_or_word.array_part [group_index], 16, FALSE, '0', string_4,
                  ignore_status);
            clp$put_partial_display (display_control, string_4, clc$trim, amc$continue, ignore_status);
            clp$put_partial_display (display_control, ' ', clc$no_trim, amc$continue, ignore_status);
          FOREND;
        IFEND;
      FOREND;

      { Display the number of control store words that were compared.

      clp$new_display_line (display_control, 2, ignore_status);
      string_10 := 'XXXXXXXXXX';
      clp$convert_integer_to_rjstring (control_store_size, 10, FALSE, ' ', string_10, ignore_status);
      clp$put_partial_display (display_control, string_10, clc$no_trim, amc$start, ignore_status);
      clp$put_partial_display (display_control, ' control store words were compared :', clc$trim,
            amc$continue, ignore_status);

      { Display the number of errors that were encountered.

      IF error_count = 0 THEN
        clp$put_partial_display (display_control, '  There were NO compare errors.', clc$no_trim,
              amc$terminate, ignore_status);
      ELSE
        string_10 := 'XXXXXXXXXX';
        clp$convert_integer_to_rjstring (error_count, 10, FALSE, ' ', string_10, ignore_status);
        clp$put_partial_display (display_control, string_10, clc$no_trim, amc$continue, ignore_status);
        clp$put_partial_display (display_control, ' errors were detected.', clc$trim, amc$terminate,
              ignore_status);
      IFEND;
    END /file_opened/;

    fsp$close_file (file_identifier, ignore_status);
    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$compare_control_store;
MODEND dum$compare_control_store;
*DECK DECK=DUM$COMPUTE_ENTRY_ADDRESS EXPAND=TRUE
PROC dum$COMPUTE_ENTRY_ADDRESS compute_entry_address (
  base        : integer = $required
  entry_index : integer -281474976710655..281474976710655 = $required
  address     : var of integer = $required
  )

  crev (el ei)
  el = $mem($value(base)+14, 4)
  ei = $value(entry_index) - $mem($value(base)+10, 4)
  $value(address) = $mem($value(base), 6) + (el * ei)

PROCEND dum$compute_entry_address
*DECK DECK=DUM$CONVERT_CTS_TO_DAU EXPAND=TRUE
PROCEDURE dum$convert_cts_to_dau, convert_cts_to_dau, concts (
  cylinder, c: integer 0..886 = 799
  track, t: integer 0..40 = 9
  sector, s: integer 0..47 = 6
  device_type, dt: integer 834..9853 = 895
  output, o: file = $output
  status)

" This procedure converts a cylinder/track/sector into a dau address.

  IF $value(device_type) = 834 THEN
    daus_per_cylinder = 10
    "  daus_per_track =         1
    sectors_per_track = 32
    tracks_per_cylinder = 10
    cylinders_per_device = 817
    sectors_per_dau = 32

  ELSEIF $value(device_type) = 836 THEN
    daus_per_cylinder = 35
    "  daus_per_track =         1.46
    sectors_per_track = 47
    tracks_per_cylinder = 24
    cylinders_per_device = 701
    sectors_per_dau = 32

  ELSEIF $value(device_type) = 844 THEN
    daus_per_cylinder = 44
    "  daus_per_track =         2.4
    sectors_per_track = 24
    tracks_per_cylinder = 19
    cylinders_per_device = 823
    sectors_per_dau = 10

  ELSEIF $value(device_type) = 885 THEN
    daus_per_cylinder = 160
    "  daus_per_track =         4
    sectors_per_track = 32
    tracks_per_cylinder = 40
    cylinders_per_device = 843
    sectors_per_dau = 8

  ELSEIF $value(device_type) = 887 THEN
    daus_per_cylinder = 38
    "  daus_per_track =         9.5
    sectors_per_track = 38
    tracks_per_cylinder = 4
    cylinders_per_device = 884
    sectors_per_dau = 4

  ELSEIF $value(device_type) = 895 THEN
    daus_per_cylinder = 37
    "  daus_per_track =         2.5
    sectors_per_track = 10
    tracks_per_cylinder = 15
    cylinders_per_device = 886
    sectors_per_dau = 4

  ELSEIF $value(device_type) = 9836 THEN
    daus_per_cylinder = 36
    "  daus_per_track =         1.5
    sectors_per_track = 12
    tracks_per_cylinder = 24
    cylinders_per_device = 703
    sectors_per_dau = 8

  ELSEIF $value(device_type) = 9853 THEN
    daus_per_cylinder = 49
    "  daus_per_track =         2.63
    sectors_per_track = 21
    tracks_per_cylinder = 19
    cylinders_per_device = 1412
    sectors_per_dau = 8

  ELSE
    EXIT_PROC WITH $status(false, 'xx', 0, ' unsupported device type: '//$strrep($value(device_type)))
  IFEND

  cyl = $value(cylinder)
  track = $value(track)
  sector = $value(sector)

  IF cyl > cylinders_per_device THEN
    EXIT_PROC WITH $status(false, 'xx', 0, ' cylinder > # of cylinders the device supports')
  ELSEIF track > tracks_per_cylinder THEN
    EXIT_PROC WITH $status(false, 'xx', 0, ' track > # of tracks/cylinder the device supports')
  ELSEIF sector > sectors_per_track THEN
    EXIT_PROC WITH $status(false, 'xx', 0, ' sector > # of sectors/track the device supports')
  IFEND

  sectors_per_cylinder =(daus_per_cylinder)* (sectors_per_dau)
  total_sector = sector + (track * sectors_per_track) + (cyl * sectors_per_cylinder)
  dau = total_sector / sectors_per_dau

  putl (' C'//..
$strrep(cyl)//' T'//$strrep(track)//' S'//$strrep(sector)//' on an '//$strrep($value(device_type))//..
' maps to dau address '//$strrep(dau)) o=$fname($strrep($value(output))//'.$eoi')

PROCEND dum$convert_cts_to_dau
*DECK DECK=DUM$CONVERT_DAU_TO_CTS EXPAND=TRUE
PROCEDURE dum$convert_dau_to_cts, convert_dau_to_cts, condau (
  dau, d: integer 0..134880 = 7393(16)
  device_type, dt: integer 834..9853 = 895
  output, o: file = $output
  status)

" This procedure converts a dau address into a cylinder/track/sector.

  IF $value(device_type) = 834 THEN
    daus_per_cylinder = 10
    "  daus_per_track =         1
    sectors_per_track = 32
    tracks_per_cylinder = 10
    cylinders_per_device = 817
    sectors_per_dau = 32

  ELSEIF $value(device_type) = 836 THEN
    daus_per_cylinder = 35
    "  daus_per_track =         1.46
    sectors_per_track = 47
    tracks_per_cylinder = 24
    cylinders_per_device = 701
    sectors_per_dau = 32

  ELSEIF $value(device_type) = 844 THEN
    daus_per_cylinder = 44
    "  daus_per_track =         2.4
    sectors_per_track = 24
    tracks_per_cylinder = 19
    cylinders_per_device = 823
    sectors_per_dau = 10

  ELSEIF $value(device_type) = 885 THEN
    daus_per_cylinder = 160
    "  daus_per_track =         4
    sectors_per_track = 32
    tracks_per_cylinder = 40
    cylinders_per_device = 843
    sectors_per_dau = 8

  ELSEIF $value(device_type) = 887 THEN
    daus_per_cylinder = 38
    "  daus_per_track =         9.5
    sectors_per_track = 38
    tracks_per_cylinder = 4
    cylinders_per_device = 884
    sectors_per_dau = 4

  ELSEIF $value(device_type) = 895 THEN
    daus_per_cylinder = 37
    "  daus_per_track =         2.5
    sectors_per_track = 10
    tracks_per_cylinder = 15
    cylinders_per_device = 886
    sectors_per_dau = 4

  ELSEIF $value(device_type) = 9836 THEN
    daus_per_cylinder = 36
    "  daus_per_track =         1.5
    sectors_per_track = 12
    tracks_per_cylinder = 24
    cylinders_per_device = 703
    sectors_per_dau = 8

  ELSEIF $value(device_type) = 9853 THEN
    daus_per_cylinder = 49
    "  daus_per_track =         2.63
    sectors_per_track = 21
    tracks_per_cylinder = 19
    cylinders_per_device = 1412
    sectors_per_dau = 8

  ELSE
    EXIT_PROC WITH $status(false, 'xx', 0, ' unsupported device type: '//$strrep($value(device_type)))
  IFEND

  dau = $value(dau)
  cylinder = dau/daus_per_cylinder

  IF cylinder > cylinders_per_device + 1 THEN
    EXIT_PROC WITH $status(false, 'xx', 0, ' dau address too large for device type')
  IFEND

  start_line = ' dau address '//$strrep(dau)//' on an '//$strrep($value(device_type))//' maps to'

  dau_remainder = $mod(dau daus_per_cylinder)
  sectors_left = dau_remainder * sectors_per_dau
  track = sectors_left / sectors_per_track
  sectors_left = $mod(sectors_left sectors_per_track)

  putl (start_line//' C'//$strrep(cylinder)//' T'//$strrep(track)//' S'//$strrep(sectors_left)) ..
        o=$fname($strrep($value(output))//'.$eoi')

"  now calculate it another way to see that we get the same numbers

  sectors_per_cylinder = daus_per_cylinder * sectors_per_dau
  sector = dau * sectors_per_dau
  cylinder2 = sector / sectors_per_cylinder
  remaining_sectors = $mod(sector sectors_per_cylinder)
  track2 = remaining_sectors / sectors_per_track
  remaining_sectors = $mod(remaining_sectors sectors_per_track)
" display the second opinion if it does not agree with the 1st calculation
  IF (cylinder2 <> cylinder) OR (track2 <> track) OR (remaining_sectors <> sectors_left) THEN
    putl ('    or maybe ') o=$fname($strrep($value(output))//'.$eoi')
    putl (' cylinder = '//..
$strrep(cylinder2)//' track = '//$strrep(track2)//' sector = '//$strrep(remaining_sectors)) ..
          o=$fname($strrep($value(output))//'.$eoi')
  IFEND

PROCEND dum$convert_dau_to_cts
*DECK DECK=DUM$CONVERT_INT_TO_USAGE_STRING EXPAND=TRUE
PROC dum$convert_int_to_usage_string, convert_int_to_usage_string, convert_integer_to_usage_string (
  value            : integer 0..31 = $required
  usage_string, us : var of string = $optional
  status           : var of status = $optional
  )

  ws = '('
  crev usage k=string d=0..4
  usage(0) = 'read'
  usage(1) = 'shorten'
  usage(2) = 'append'
  usage(3) = 'modify'
  usage(4) = 'execute'

  uset = $value(value)
  FOR i = 0 TO 4 DO
    IF uset <> (uset / 2 * 2) THEN
      ws = ws // ' ' // usage(4-i)
    IFEND
    uset = uset / 2
  FOREND
  ws = ws // ' )'
  IF $specified(us) THEN
    $value(usage_string) = ws
  ELSE
    disv ws
  IFEND

PROCEND dum$convert_int_to_usage_string

*DECK DECK=DUM$CONVERT_MICROSECOND_CLOCK EXPAND=TRUE
PROC dum$convert_microsecond_clock, convert_microsecond_clock, conmc (
  microsecond_clock, mc: integer = $required
  time_string, ts: var of string = $optional
  status)

  " This PROC converts a free running clock time, to a date time string

  crev s k=status

  " Get base system time
  bst = $sa(osv$base_system_time)
  bst_second = $mem(bst, 1)
  bst_minute = $mem(bst+1, 1)
  bst_hour = $mem(bst+2, 1)
  bst_day = $mem(bst+3, 1)
  bst_month = $mem(bst+4, 1)
  bst_year = $mem(bst+5, 2)

"pmp$get_compact_date_time

 " Compute time difference
    cms = $mem(bst+7,6)
    frc = $value(microsecond_clock)

    elapsed_time "ms" = (frc - cms)/1000

    millisecond = $MOD(elapsed_time "ms" , 1000)

    elapsed_time "sec" = elapsed_time "ms" / 1000 "ms/sec"

    second = bst_second + $MOD(elapsed_time "sec" , 60 "sec" )
    IF second >= 60 "sec" THEN
      second = second - 60 "sec"
      minute = 1 "min"
    ELSE
      minute = 0 "min"
    IFEND

    elapsed_time "min" = elapsed_time "sec" / 60 "sec/min"

    minute = minute + bst_minute + $MOD(elapsed_time "min" , 60 "min" )
    IF minute >= 60 "min" THEN
      minute = minute - 60 "min"
      hour = 1 "hr"
    ELSE
      hour = 0 "hr"
    IFEND

    elapsed_time "hr" = elapsed_time "min" / 60 "min/hr"

    hour = hour + bst_hour + $MOD(elapsed_time "hr" , 24 "hr" )
    IF hour >= 24 "hr" THEN
      hour = hour - 24 "hr"
      day = 1 "day"
    ELSE
      day = 0 "day"
    IFEND;


    create_variable days_in_the_month k=integer d=1..12
    days_in_the_month(1) = 31
    days_in_the_month(3) = 31
    days_in_the_month(4) = 30
    days_in_the_month(5) = 31
    days_in_the_month(6) = 30
    days_in_the_month(7) = 31
    days_in_the_month(8) = 31
    days_in_the_month(9) = 30
    days_in_the_month(10) = 31
    days_in_the_month(11) = 30
    days_in_the_month(12) = 31

    year = bst_year

    b1 = ($MOD(year, 4) = 0)
    b2 = ($MOD(year, 100) <> 0)
    b3 = ($MOD(year, 400) = 0)

    this_is_a_leap_year = (b1 AND b2) OR b3
    IF this_is_a_leap_year THEN
      days_in_the_month(2) = 29
    ELSE
      days_in_the_month(2) = 28
    IFEND

    elapsed_time "day" = elapsed_time "hr" / 24 "hr/day"

    day = day + bst_day + elapsed_time "day"
    month = bst_month

    WHILE day > days_in_the_month(month) DO
      day = day - days_in_the_month(month)
      month = month + 1 "mo"

      IF month > 12 "mo" THEN

        month = 1 "mo"
        year = year + 1 "yr"

        b1 = ($MOD(year, 4) = 0)
        b2 = ($MOD(year, 100) <> 0)
        b3 = ($MOD(year, 400) = 0)

        this_is_a_leap_year = (b1 AND b2) OR b3
        IF this_is_a_leap_year THEN
          days_in_the_month(2) = 29
        ELSE
          days_in_the_month(2) = 28
        IFEND

      IFEND;
    WHILEND;

  ms = $strrep(millisecond, 10)
  ms = $substr('00'//ms, $strlen(ms), 3)
  h = $strrep(hour, 10)
  h = $substr('0'//h, $strlen(h), 2)
  m = $strrep(minute, 10)
  m = $substr('0'//m, $strlen(m), 2)
  se = $strrep(second, 10)
  se = $substr('0'//se, $strlen(se), 2)
  y = $strrep(year, 10)
  mo = $strrep(month, 10)
  mo = $substr('0'//mo, $strlen(mo), 2)
  d = $strrep(day, 10)
  d = $substr('0'//d, $strlen(d), 2)

  IF $specified(time_string) THEN
   $value(time_string) = ..
                     h//':'//m//':'//se//'.'//ms//..
', '//y//'.'//mo//'.'//d
  ELSE
    put_line ' Time '//h//':'//m//':'//se//'.'//ms//..
', '//y//'.'//mo//'.'//d
 IFEND

PROCEND dum$convert_microsecond_clock
*DECK DECK=DUM$COPY_BUFFER_CONTROLWARE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Copy Buffer Controlware Command' ??
MODULE dum$copy_buffer_controlware;

{ PURPOSE:
{   This module contains the code for the copy_buffer_controlware command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc clp$evaluate_parameters
*copyc dup$retrieve_bc_entry
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
?? OLDTITLE ??
?? NEWTITLE := 'dup$copy_buffer_controlware', EJECT ??

{ PURPOSE:
{   This procedure copies the buffer controlware to an output file.

  PROCEDURE [XDCL] dup$copy_buffer_controlware
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE copy_buffer_controlware, copbc (
{   channel_number, cn: integer 0..33 = $required
{   file, f: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 2, 11, 10, 54, 506],
    clc$command, 5, 3, 2, 0, 0, 0, 3, ''], [
    ['CHANNEL_NUMBER                 ',clc$nominal_entry, 1],
    ['CN                             ',clc$abbreviation_entry, 1],
    ['F                              ',clc$abbreviation_entry, 2],
    ['FILE                           ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 33, 10]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$channel_number = 1,
      p$file = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      cell_p: ^cell,
      channel: 0 .. duc$de_maximum_channels,
      entry_p: ^dut$de_buffer_controlware_entry,
      fa_p: ^fst$attachment_options,
      file_buffer_p: ^SEQ ( * ),
      file_identifier: amt$file_identifier,
      file_pointer: amt$segment_pointer,
      ignore_status: ost$status,
      mca_p: ^fst$file_cycle_attributes,
      restart_file_buffer_p: ^SEQ ( * ),
      restart_file_seq_p: ^SEQ ( * );

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      fsp$close_file (file_identifier, ignore_status);

    PROCEND clean_up;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    channel := pvt [p$channel_number].value^.integer_value.value;
    dup$retrieve_bc_entry (channel, entry_p);
    IF entry_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,
            'The buffer controlware for channel', status);
      osp$append_status_integer (osc$status_parameter_delimiter, channel, 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);
      RETURN;  {---->
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

    { Open the output file.

    PUSH fa_p: [1 .. 1];
    fa_p^ [1].selector := fsc$access_and_share_modes;
    fa_p^ [1].access_modes.selector := fsc$specific_access_modes;
    fa_p^ [1].access_modes.value := $fst$file_access_options [fsc$read, fsc$shorten, fsc$append, fsc$modify];
    fa_p^ [1].share_modes.selector := fsc$specific_share_modes;
    fa_p^ [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$shorten, fsc$append, fsc$modify];

    PUSH mca_p: [1 .. 2];
    mca_p^ [1].selector := fsc$record_type;
    mca_p^ [1].record_type := amc$undefined;
    mca_p^ [2].selector := fsc$preset_value;
    mca_p^ [2].preset_value := -1;

    fsp$open_file (pvt [p$file].value^.file_value^, amc$segment, fa_p, NIL, mca_p, NIL, NIL, file_identifier,
          status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

   /file_opened/
    BEGIN
      amp$get_segment_pointer (file_identifier, amc$sequence_pointer, file_pointer, status);
      IF NOT status.normal THEN
        EXIT /file_opened/;  {---->
      IFEND;
      IF file_pointer.sequence_pointer = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /file_opened/;  {---->
      IFEND;
      RESET file_pointer.sequence_pointer;

      { Retrieve a pointer to the buffer controlware data in the restart file.

      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);
      RESET restart_file_seq_p TO cell_p;
      NEXT restart_file_buffer_p: [[REP entry_p^.words OF dut$de_buffer_controlware_word]] IN
            restart_file_seq_p;
      IF restart_file_buffer_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /file_opened/;  {---->
      IFEND;
      RESET restart_file_buffer_p;

      { Retrieve a pointer to the output file for the buffer controlware data.

      NEXT file_buffer_p: [[REP entry_p^.words OF dut$de_buffer_controlware_word]] IN
            file_pointer.sequence_pointer;
      IF file_buffer_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /file_opened/;  {---->
      IFEND;
      RESET file_buffer_p;

      { Copy the buffer controlware data from the restart file to the output file.

      file_buffer_p^ := restart_file_buffer_p^;
      amp$set_segment_eoi (file_identifier, file_pointer, status);
    END /file_opened/;

    fsp$close_file (file_identifier, ignore_status);
    osp$disestablish_cond_handler;

  PROCEND dup$copy_buffer_controlware;
MODEND dum$copy_buffer_controlware;
*DECK DECK=DUM$COPY_CONTROL_STORE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Copy Control Store Command' ??
MODULE dum$copy_control_store;

{ PURPOSE:
{   This module contains the code for the copy_control_store command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc dup$evaluate_parameters
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
?? OLDTITLE ??
?? NEWTITLE := 'dup$copy_control_store' ??

{ PURPOSE:
{   This procedure copies the control store data from the restart file to the output file.

  PROCEDURE [XDCL] dup$copy_control_store
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE copy_control_store, copcs (
{   file, f: file = $required
{   processor, p: integer 0..3 = 0
{   shadow, s: boolean = FALSE
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 9, 19, 8, 0, 0, 344],
    clc$command, 7, 4, 1, 0, 0, 0, 4, ''], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PROCESSOR                      ',clc$nominal_entry, 2],
    ['S                              ',clc$abbreviation_entry, 3],
    ['SHADOW                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, 3, 10],
    '0'],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'FALSE'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$processor = 2,
      p$shadow = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      cell_p: ^cell,
      control_store_entry: dut$de_control_store_entry,
      default_list: ARRAY [1 .. 1] OF dut$default_change_list_entry,
      fa_p: ^fst$attachment_options,
      file_buffer_p: ^SEQ ( * ),
      file_identifier: amt$file_identifier,
      file_pointer: amt$segment_pointer,
      ignore_status: ost$status,
      mca_p: ^fst$file_cycle_attributes,
      processor: 0 .. 3,
      restart_file_buffer_p: ^SEQ ( * ),
      restart_file_seq_p: ^SEQ ( * );

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort hander to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      fsp$close_file (file_identifier, ignore_status);

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    { Change the default value for the PROCESSOR parameter.

    default_list [1].default_name := duc$dp_processor;
    default_list [1].number := p$processor;
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    processor := pvt [p$processor].value^.integer_value.value;
    IF pvt [p$shadow].value^.boolean_value.value THEN
      control_store_entry := duv$dump_environment_p^.control_store.shadow [processor];
    ELSE
      control_store_entry := duv$dump_environment_p^.control_store.main [processor];
    IFEND;
    IF NOT control_store_entry.available THEN
      IF pvt [p$shadow].value^.boolean_value.value THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,
              'The shadow control store for processor', status);
      ELSE
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,
              'The main control store for processor', status);
      IFEND;
      osp$append_status_integer (osc$status_parameter_delimiter, processor, 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);
      RETURN;  {---->
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

    { Open the output file.

    PUSH fa_p: [1 .. 1];
    fa_p^ [1].selector := fsc$access_and_share_modes;
    fa_p^ [1].access_modes.selector := fsc$specific_access_modes;
    fa_p^ [1].access_modes.value := $fst$file_access_options [fsc$read, fsc$shorten, fsc$append, fsc$modify];
    fa_p^ [1].share_modes.selector := fsc$specific_share_modes;
    fa_p^ [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$shorten, fsc$append, fsc$modify];

    PUSH mca_p: [1 .. 2];
    mca_p^ [1].selector := fsc$record_type;
    mca_p^ [1].record_type := amc$undefined;
    mca_p^ [2].selector := fsc$preset_value;
    mca_p^ [2].preset_value := -1;

    fsp$open_file (pvt [p$file].value^.file_value^, amc$segment, fa_p, NIL, mca_p, NIL, NIL, file_identifier,
          status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

   /file_opened/
    BEGIN
      amp$get_segment_pointer (file_identifier, amc$sequence_pointer, file_pointer, status);
      IF NOT status.normal THEN
        EXIT /file_opened/;  {---->
      IFEND;
      IF file_pointer.sequence_pointer = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /file_opened/;  {---->
      IFEND;
      RESET file_pointer.sequence_pointer;

      { Retrieve a pointer to the control store data on the restart file.

      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),
            control_store_entry.first_byte);
      RESET restart_file_seq_p TO cell_p;
      NEXT restart_file_buffer_p: [[REP control_store_entry.size OF dut$de_control_store_word]] IN
            restart_file_seq_p;
      IF restart_file_buffer_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /file_opened/;  {---->
      IFEND;

      { Retrieve a pointer to the output file for the control store data.

      NEXT file_buffer_p: [[REP control_store_entry.size OF dut$de_control_store_word]] IN
            file_pointer.sequence_pointer;
      IF file_buffer_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /file_opened/;  {---->
      IFEND;

      { Copy the control store data from the restart file to the output file.

      file_buffer_p^ := restart_file_buffer_p^;
      amp$set_segment_eoi (file_identifier, file_pointer, status);
    END /file_opened/;

    fsp$close_file (file_identifier, ignore_status);
    osp$disestablish_cond_handler;

  PROCEND dup$copy_control_store;
MODEND dum$copy_control_store;
*DECK DECK=DUM$COPY_MEMORY_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Dump Analyzer : Copy Memory Command' ??                                                
MODULE dum$copy_memory_command;                                                                               
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains the code for the copy_memory command.                                                
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc due$exception_condition_codes                                                                          
?? POP ??                                                                                                     
*copyc amp$get_segment_pointer                                                                                
*copyc amp$set_segment_eoi                                                                                    
*copyc dup$access_real_memory                                                                                 
*copyc dup$copy_virtual_memory_pva                                                                            
*copyc dup$copy_virtual_memory_sva                                                                            
*copyc dup$display_message                                                                                    
*copyc dup$evaluate_parameters                                                                                
*copyc dup$retrieve_exchange_package                                                                          
*copyc fsp$close_file                                                                                         
*copyc fsp$open_file                                                                                          
*copyc osp$append_status_integer                                                                              
*copyc osp$disestablish_cond_handler                                                                          
*copyc osp$establish_block_exit_hndlr                                                                         
*copyc osp$set_status_abnormal                                                                                
?? EJECT ??                                                                                                   
*copyc duv$dump_environment_p                                                                                 
*copyc duv$execution_environment                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$copy_memory_command', EJECT ??                                                            
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure copies memory from the restart file to the output file.                                    
                                                                                                              
  PROCEDURE [XDCL] dup$copy_memory_command                                                                    
    (    parameter_list: clt$parameter_list;                                                                  
     VAR status: ost$status);                                                                                 
                                                                                                              
{ PROCEDURE copy_memory, copm (                                                                               
{   address, a: integer = $required                                                                           
{   file, f: file = $required                                                                                 
{   bytes, b, byte_count, bc: integer 0..osc$max_segment_length = 100000(16)                                  
{   exchange, e: any of                                                                                       
{       key                                                                                                   
{         (active a) (monitor m) (job j)                                                                      
{       keyend                                                                                                
{       integer 0..0ffffffff(16)                                                                              
{     anyend = 0ffffffff(16)                                                                                  
{   processor, p: integer 0..3 = 0                                                                            
{   address_mode, am: key                                                                                     
{       (process_virtual_address pva) (system_virtual_address sva) (real_memory_address rma)                  
{     keyend = process_virtual_address                                                                        
{   status)                                                                                                   
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 15] of clt$pdt_parameter_name,                                                       
      parameters: array [1 .. 7] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
      type3: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (10),                                                                           
      recend,                                                                                                 
      type4: 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 .. 6] of clt$keyword_specification,                                         
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$integer_type_qualifier,                                                              
        recend,                                                                                               
        default_value: string (13),                                                                           
      recend,                                                                                                 
      type5: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type6: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$keyword_type_qualifier,                                                                
        keyword_specs: array [1 .. 6] of clt$keyword_specification,                                           
        default_value: string (23),                                                                           
      recend,                                                                                                 
      type7: record                                                                                           
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [90, 6, 26, 8, 25, 1, 312],                                                                               
    clc$command, 15, 7, 2, 0, 0, 0, 7, ''], [                                                                 
    ['A                              ',clc$abbreviation_entry, 1],                                            
    ['ADDRESS                        ',clc$nominal_entry, 1],                                                 
    ['ADDRESS_MODE                   ',clc$nominal_entry, 6],                                                 
    ['AM                             ',clc$abbreviation_entry, 6],                                            
    ['B                              ',clc$alias_entry, 3],                                                   
    ['BC                             ',clc$abbreviation_entry, 3],                                            
    ['BYTES                          ',clc$nominal_entry, 3],                                                 
    ['BYTE_COUNT                     ',clc$alias_entry, 3],                                                   
    ['E                              ',clc$abbreviation_entry, 4],                                            
    ['EXCHANGE                       ',clc$nominal_entry, 4],                                                 
    ['F                              ',clc$abbreviation_entry, 2],                                            
    ['FILE                           ',clc$nominal_entry, 2],                                                 
    ['P                              ',clc$abbreviation_entry, 5],                                            
    ['PROCESSOR                      ',clc$nominal_entry, 5],                                                 
    ['STATUS                         ',clc$nominal_entry, 7]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [2, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 2                                                                                                 
    [12, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],                                                                                                       
{ PARAMETER 3                                                                                                 
    [7, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,                         
  clc$optional_default_parameter, 0, 10],                                                                     
{ PARAMETER 4                                                                                                 
    [10, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 269,                        
  clc$optional_default_parameter, 0, 13],                                                                     
{ PARAMETER 5                                                                                                 
    [14, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 6                                                                                                 
    [3, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,                        
  clc$optional_default_parameter, 0, 23],                                                                     
{ PARAMETER 7                                                                                                 
    [15, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name],                                                         
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,                      
  clc$optional_parameter, 0, 0]],                                                                             
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],                                       
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$file_type]],                                                                                  
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$integer_type], [0, osc$max_segment_length, 10],                                               
    '100000(16)'],                                                                                            
{ PARAMETER 4                                                                                                 
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],                                           
    FALSE, 2],                                                                                                
    229, [[1, 0, clc$keyword_type], [6], [                                                                    
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                 
      ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],                      
      ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                 
      ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 3],                      
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                 
      ['MONITOR                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]                      
      ],                                                                                                      
    20, [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]]                                                    
    ,                                                                                                         
    '0ffffffff(16)'],                                                                                         
{ PARAMETER 5                                                                                                 
    [[1, 0, clc$integer_type], [0, 3, 10],                                                                    
    '0'],                                                                                                     
{ PARAMETER 6                                                                                                 
    [[1, 0, clc$keyword_type], [6], [                                                                         
    ['PROCESS_VIRTUAL_ADDRESS        ', clc$nominal_entry, clc$normal_usage_entry, 1],                        
    ['PVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                   
    ['REAL_MEMORY_ADDRESS            ', clc$nominal_entry, clc$normal_usage_entry, 3],                        
    ['RMA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                   
    ['SVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                   
    ['SYSTEM_VIRTUAL_ADDRESS         ', clc$nominal_entry, clc$normal_usage_entry, 2]]                        
    ,                                                                                                         
    'process_virtual_address'],                                                                               
{ PARAMETER 7                                                                                                 
    [[1, 0, clc$status_type]]];                                                                               
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$address = 1,                                                                                          
      p$file = 2,                                                                                             
      p$bytes = 3,                                                                                            
      p$exchange = 4,                                                                                         
      p$processor = 5,                                                                                        
      p$address_mode = 6,                                                                                     
      p$status = 7;                                                                                           
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 7] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      access_data: dut$access_data,                                                                           
      address: dut$ee_address_parameter,                                                                      
      byte_count: ost$segment_length,                                                                         
      bytes_returned: ost$segment_length,                                                                     
      default_list: ARRAY [1 .. 3] OF dut$default_change_list_entry,                                          
      display_control: clt$display_control,                                                                   
      exchange_package_p: ^dut$exchange_package,                                                              
      fa_p: ^fst$attachment_options,                                                                          
      file_buffer_p: ^SEQ ( * ),                                                                              
      file_identifier: amt$file_identifier,                                                                   
      file_pointer: amt$segment_pointer,                                                                      
      ignore_status: ost$status,                                                                              
      invalid_segment_issued: boolean,                                                                        
      local_status: ost$status,                                                                               
      mca_p: ^fst$file_cycle_attributes,                                                                      
      memory_file_buffer_p: ^SEQ ( * ),                                                                       
      memory_file_p: ^cell,                                                                                   
      memory_skipped: ost$segment_offset,                                                                     
      new_byte_size: ost$segment_length,                                                                      
      output_file_opened: boolean,                                                                            
      page_fault_encountered: boolean,                                                                        
      skip_start: ost$segment_offset,                                                                         
      skipping_page_faulted_memory: boolean,                                                                  
      some_memory_copied: boolean,                                                                            
      starting_offset: ost$segment_offset;                                                                    
                                                                                                              
*copy dup$abort_handler                                                                                       
?? NEWTITLE := 'clean_up', EJECT ??                                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure is called from the abort handler to close the file.                                        
                                                                                                              
    PROCEDURE [INLINE] clean_up;                                                                              
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      IF output_file_opened THEN                                                                              
        fsp$close_file (file_identifier, ignore_status);                                                      
      IFEND;                                                                                                  
                                                                                                              
    PROCEND clean_up;                                                                                         
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the EXCHANGE, PROCESSOR and ADDRESS_MODE parameters.                       
                                                                                                              
    default_list [1].default_name := duc$dp_exchange;                                                         
    default_list [1].number := p$exchange;                                                                    
    default_list [2].default_name := duc$dp_processor;                                                        
    default_list [2].number := p$processor;                                                                   
    default_list [3].default_name := duc$dp_address_mode;                                                     
    default_list [3].number := p$address_mode;                                                                
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Retrieve the exchange package if needed.                                                                
                                                                                                              
    IF (pvt [p$address_mode].value^.keyword_value <> 'PROCESS_VIRTUAL_ADDRESS') AND                           
          pvt [p$exchange].specified THEN                                                                     
      osp$set_status_abnormal (duc$dump_analyzer_id, due$rma_and_exc_specified, '', status);                  
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF pvt [p$address_mode].value^.keyword_value = 'PROCESS_VIRTUAL_ADDRESS' THEN                             
      dup$retrieve_exchange_package (pvt [p$processor].value^.integer_value.value, pvt [p$exchange].value^,   
            exchange_package_p, status);                                                                      
      IF NOT status.normal THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    output_file_opened := FALSE;                                                                              
    osp$establish_block_exit_hndlr (^abort_handler);                                                          
                                                                                                              
   /file_opened/                                                                                              
    BEGIN                                                                                                     
                                                                                                              
      { Open the output file.                                                                                 
                                                                                                              
      PUSH fa_p: [1 .. 1];                                                                                    
      fa_p^ [1].selector := fsc$access_and_share_modes;                                                       
      fa_p^ [1].access_modes.selector := fsc$specific_access_modes;                                           
      fa_p^ [1].access_modes.value :=                                                                         
            $fst$file_access_options [fsc$read, fsc$shorten, fsc$append, fsc$modify];                         
      fa_p^ [1].share_modes.selector := fsc$specific_share_modes;                                             
      fa_p^ [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$shorten, fsc$append, fsc$modify];
                                                                                                              
      PUSH mca_p: [1 .. 2];                                                                                   
      mca_p^ [1].selector := fsc$record_type;                                                                 
      mca_p^ [1].record_type := amc$undefined;                                                                
      mca_p^ [2].selector := fsc$preset_value;                                                                
      mca_p^ [2].preset_value := -1;                                                                          
                                                                                                              
      fsp$open_file (pvt [p$file].value^.file_value^, amc$segment, fa_p, NIL, mca_p, NIL, NIL,                
            file_identifier, status);                                                                         
      IF NOT status.normal THEN                                                                               
        EXIT /file_opened/;  {---->                                                                           
      IFEND;                                                                                                  
      output_file_opened := TRUE;                                                                             
                                                                                                              
      amp$get_segment_pointer (file_identifier, amc$sequence_pointer, file_pointer, status);                  
      IF NOT status.normal THEN                                                                               
        EXIT /file_opened/;  {---->                                                                           
      IFEND;                                                                                                  
      IF file_pointer.sequence_pointer = NIL THEN                                                             
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        EXIT /file_opened/;  {---->                                                                           
      IFEND;                                                                                                  
      RESET file_pointer.sequence_pointer;                                                                    
                                                                                                              
      display_control := duv$execution_environment.output_file.display_control;                               
      display_control.line_number := display_control.page_length + 1;                                         
      address.rma_part := pvt [p$address].value^.integer_value.value;                                         
      starting_offset := address.pva_part.offset;                                                             
      byte_count := pvt [p$bytes].value^.integer_value.value;                                                 
                                                                                                              
      IF (pvt [p$address_mode].value^.keyword_value = 'PROCESS_VIRTUAL_ADDRESS') OR                           
            (pvt [p$address_mode].value^.keyword_value = 'SYSTEM_VIRTUAL_ADDRESS') THEN                       
        page_fault_encountered := FALSE;                                                                      
        skipping_page_faulted_memory := FALSE;                                                                
        some_memory_copied := FALSE;                                                                          
        invalid_segment_issued := FALSE;                                                                      
                                                                                                              
        REPEAT                                                                                                
          NEXT file_buffer_p: [[REP byte_count OF cell]] IN file_pointer.sequence_pointer;                    
          IF file_buffer_p = NIL THEN                                                                         
            osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                      
            EXIT /file_opened/;  {---->                                                                       
          IFEND;                                                                                              
          RESET file_buffer_p;                                                                                
                                                                                                              
          IF pvt [p$address_mode].value^.keyword_value = 'PROCESS_VIRTUAL_ADDRESS' THEN                       
            dup$copy_virtual_memory_pva (address.pva_part, exchange_package_p^,                               
                  pvt [p$processor].value^.integer_value.value, byte_count, TRUE, bytes_returned,             
                  file_buffer_p, access_data, status);                                                        
          ELSE                                                                                                
            dup$copy_virtual_memory_sva (address.sva_part, pvt [p$processor].value^.integer_value.value,      
                  byte_count, TRUE, bytes_returned, file_buffer_p, access_data, status);                      
          IFEND;                                                                                              
          IF NOT status.normal AND (status.condition <> due$memory_partially_avail) THEN                      
            EXIT /file_opened/;  {---->                                                                       
          IFEND;                                                                                              
                                                                                                              
          IF NOT access_data.valid_segment AND NOT invalid_segment_issued THEN                                
            invalid_segment_issued := TRUE;                                                                   
            osp$set_status_abnormal (duc$dump_analyzer_id, due$invalid_seg_trans_poss, '', local_status);     
            dup$display_message (local_status, display_control);                                              
          IFEND;                                                                                              
                                                                                                              
          page_fault_encountered := (access_data.page_fault AND NOT access_data.memory_found);                
                                                                                                              
          IF bytes_returned > 0 THEN                                                                          
            some_memory_copied := TRUE;                                                                       
            IF skipping_page_faulted_memory THEN                                                              
              skipping_page_faulted_memory := FALSE;                                                          
              osp$set_status_abnormal (duc$dump_analyzer_id, due$pages_skipped, '', local_status);            
              osp$append_status_integer (osc$status_parameter_delimiter, skip_start, 16, TRUE, local_status); 
              osp$append_status_integer (osc$status_parameter_delimiter, address.pva_part.offset - 1, 16,     
                    TRUE, local_status);                                                                      
              dup$display_message (local_status, display_control);                                            
            IFEND;                                                                                            
            byte_count := byte_count - bytes_returned;                                                        
          IFEND;                                                                                              
                                                                                                              
          IF page_fault_encountered THEN                                                                      
            address.pva_part.offset := access_data.next_page_offset;                                          
            IF NOT skipping_page_faulted_memory THEN                                                          
              skipping_page_faulted_memory := TRUE;                                                           
              skip_start := access_data.page_fault_offset;                                                    
            IFEND;                                                                                            
            RESET file_pointer.sequence_pointer TO file_buffer_p;                                             
            IF bytes_returned > 0 THEN                                                                        
              NEXT file_buffer_p: [[REP bytes_returned OF cell]] IN file_pointer.sequence_pointer;            
              IF file_buffer_p = NIL THEN                                                                     
                osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                  
                EXIT /file_opened/;  {---->                                                                   
              IFEND;                                                                                          
            IFEND;                                                                                            
            memory_skipped := access_data.next_page_offset - access_data.page_fault_offset;                   
            IF memory_skipped < byte_count THEN                                                               
              NEXT file_buffer_p: [[REP memory_skipped OF cell]] IN file_pointer.sequence_pointer;            
              byte_count := byte_count - memory_skipped;                                                      
            ELSE                                                                                              
              NEXT file_buffer_p: [[REP byte_count OF cell]] IN file_pointer.sequence_pointer;                
              byte_count := 0;                                                                                
            IFEND;                                                                                            
            IF file_buffer_p = NIL THEN                                                                       
              osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                    
              EXIT /file_opened/;  {---->                                                                     
            IFEND;                                                                                            
          IFEND;                                                                                              
        UNTIL byte_count <= 0;                                                                                
                                                                                                              
        IF page_fault_encountered THEN                                                                        
          IF skipping_page_faulted_memory THEN                                                                
            osp$set_status_abnormal (duc$dump_analyzer_id, due$pages_skipped, '', local_status);              
            osp$append_status_integer (osc$status_parameter_delimiter, skip_start, 16, TRUE, local_status);   
            osp$append_status_integer (osc$status_parameter_delimiter,                                        
                  (access_data.next_page_offset + byte_count - 1), 16, TRUE, local_status);                   
            dup$display_message (local_status, display_control);                                              
            RESET file_pointer.sequence_pointer;                                                              
            IF (skip_start - starting_offset) > 0 THEN                                                        
              NEXT file_buffer_p: [[REP skip_start - starting_offset OF cell]] IN                             
                    file_pointer.sequence_pointer;                                                            
              IF file_buffer_p = NIL THEN                                                                     
                osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                  
                EXIT /file_opened/;  {---->                                                                   
              IFEND;                                                                                          
            IFEND;                                                                                            
          IFEND;                                                                                              
          amp$set_segment_eoi (file_identifier, file_pointer, status);                                        
          IF NOT status.normal THEN                                                                           
            EXIT /file_opened/;  {---->                                                                       
          IFEND;                                                                                              
          IF some_memory_copied THEN                                                                          
            osp$set_status_abnormal (duc$dump_analyzer_id, due$incomplete_memory_copy,                        
                  ' a page fault was encountered.', status);                                                  
          ELSE                                                                                                
            osp$set_status_abnormal (duc$dump_analyzer_id, due$no_memory_copied,                              
                  ' a page fault was encountered.', status);                                                  
          IFEND;                                                                                              
        IFEND;                                                                                                
                                                                                                              
      ELSE  { address_mode = REAL_MEMORY_ACCESS                                                               
                                                                                                              
        dup$access_real_memory (byte_count, address.rma_part, memory_file_p, new_byte_size, status);          
        IF NOT status.normal AND (status.condition <> due$memory_partially_avail) THEN                        
          EXIT /file_opened/;  {---->                                                                         
        IFEND;                                                                                                
        bytes_returned := new_byte_size;                                                                      
                                                                                                              
        RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO memory_file_p;       
        NEXT memory_file_buffer_p: [[REP bytes_returned OF cell]] IN                                          
              duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                        
        IF memory_file_buffer_p = NIL THEN                                                                    
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          EXIT /file_opened/;  {---->                                                                         
        IFEND;                                                                                                
                                                                                                              
        NEXT file_buffer_p: [[REP bytes_returned OF cell]] IN file_pointer.sequence_pointer;                  
        IF file_buffer_p = NIL THEN                                                                           
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          EXIT /file_opened/;  {---->                                                                         
        IFEND;                                                                                                
                                                                                                              
        file_buffer_p^ := memory_file_buffer_p^;                                                              
        amp$set_segment_eoi (file_identifier, file_pointer, status);                                          
        IF NOT status.normal THEN                                                                             
          EXIT /file_opened/;  {---->                                                                         
        IFEND;                                                                                                
        IF bytes_returned < byte_count THEN                                                                   
          osp$set_status_abnormal (duc$dump_analyzer_id, due$incomplete_memory_copy,                          
                ' the remaining memory is not contained in the dump.', status);                               
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
    END /file_opened/;                                                                                        
                                                                                                              
    IF output_file_opened THEN                                                                                
      fsp$close_file (file_identifier, ignore_status);                                                        
    IFEND;                                                                                                    
    osp$disestablish_cond_handler;                                                                            
                                                                                                              
  PROCEND dup$copy_memory_command;                                                                            
MODEND dum$copy_memory_command;                                                                               
*DECK DECK=DUM$COPY_PP_MEMORY_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Dump Analyzer : Copy PP Memory Command' ??                                             
MODULE dum$copy_pp_memory_command;                                                                            
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains the code for the copy_pp_memory command.                                             
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc due$exception_condition_codes                                                                          
?? POP ??                                                                                                     
*copyc amp$get_segment_pointer                                                                                
*copyc amp$set_segment_eoi                                                                                    
*copyc dup$determine_dump_information                                                                         
*copyc dup$evaluate_parameters                                                                                
*copyc fsp$close_file                                                                                         
*copyc fsp$open_file                                                                                          
*copyc osp$append_status_integer                                                                              
*copyc osp$append_status_parameter                                                                            
*copyc osp$disestablish_cond_handler                                                                          
*copyc osp$establish_block_exit_hndlr                                                                         
*copyc osp$set_status_abnormal                                                                                
?? EJECT ??                                                                                                   
*copyc duv$dump_environment_p                                                                                 
*copyc duv$execution_environment                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$copy_pp_memory_command', EJECT ??                                                         
                                                                                                              
{ Purpose:                                                                                                    
{   This procedure copies the pp memory from the restart file to the output file.                             
                                                                                                              
  PROCEDURE [XDCL] dup$copy_pp_memory_command                                                                 
    (    parameter_list: clt$parameter_list;                                                                  
     VAR status: ost$status);                                                                                 
                                                                                                              
{ PROCEDURE copy_pp_memory, copm (                                                                            
{   pp_number, pn: integer  0..25 = $required                                                                 
{   file, f: file = $required                                                                                 
{   pp_type, pt: key                                                                                          
{       (normal n) (concurrent_input_output cio c)                                                            
{     keyend = concurrent_input_output                                                                        
{   address, a: integer 0..16383 = 0                                                                          
{   words, w, word_count, wc: integer 1..16384 = 16384                                                        
{   iou, i: integer 0..1 = 0                                                                                  
{   status)                                                                                                   
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 15] of clt$pdt_parameter_name,                                                       
      parameters: array [1 .. 7] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
      type3: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$keyword_type_qualifier,                                                                
        keyword_specs: array [1 .. 5] of clt$keyword_specification,                                           
        default_value: string (23),                                                                           
      recend,                                                                                                 
      type4: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type5: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (5),                                                                            
      recend,                                                                                                 
      type6: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type7: record                                                                                           
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [90, 3, 1, 5, 25, 0, 578],                                                                                
    clc$command, 15, 7, 2, 0, 0, 0, 7, ''], [                                                                 
    ['A                              ',clc$abbreviation_entry, 4],                                            
    ['ADDRESS                        ',clc$nominal_entry, 4],                                                 
    ['F                              ',clc$abbreviation_entry, 2],                                            
    ['FILE                           ',clc$nominal_entry, 2],                                                 
    ['I                              ',clc$abbreviation_entry, 6],                                            
    ['IOU                            ',clc$nominal_entry, 6],                                                 
    ['PN                             ',clc$abbreviation_entry, 1],                                            
    ['PP_NUMBER                      ',clc$nominal_entry, 1],                                                 
    ['PP_TYPE                        ',clc$nominal_entry, 3],                                                 
    ['PT                             ',clc$abbreviation_entry, 3],                                            
    ['STATUS                         ',clc$nominal_entry, 7],                                                 
    ['W                              ',clc$alias_entry, 5],                                                   
    ['WC                             ',clc$abbreviation_entry, 5],                                            
    ['WORDS                          ',clc$nominal_entry, 5],                                                 
    ['WORD_COUNT                     ',clc$alias_entry, 5]],                                                  
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [8, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 2                                                                                                 
    [4, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],                                                                                                       
{ PARAMETER 3                                                                                                 
    [9, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,                        
  clc$optional_default_parameter, 0, 23],                                                                     
{ PARAMETER 4                                                                                                 
    [2, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 5                                                                                                 
    [14, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,                         
  clc$optional_default_parameter, 0, 5],                                                                      
{ PARAMETER 6                                                                                                 
    [6, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 7                                                                                                 
    [11, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name],                                                         
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,                      
  clc$optional_parameter, 0, 0]],                                                                             
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 25, 10]],                                                                  
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$file_type]],                                                                                  
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$keyword_type], [5], [                                                                         
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                   
    ['CIO                            ', clc$alias_entry, clc$normal_usage_entry, 2],                          
    ['CONCURRENT_INPUT_OUTPUT        ', clc$nominal_entry, clc$normal_usage_entry, 2],                        
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                   
    ['NORMAL                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]                        
    ,                                                                                                         
    'concurrent_input_output'],                                                                               
{ PARAMETER 4                                                                                                 
    [[1, 0, clc$integer_type], [0, 16383, 10],                                                                
    '0'],                                                                                                     
{ PARAMETER 5                                                                                                 
    [[1, 0, clc$integer_type], [1, 16384, 10],                                                                
    '16384'],                                                                                                 
{ PARAMETER 6                                                                                                 
    [[1, 0, clc$integer_type], [0, 1, 10],                                                                    
    '0'],                                                                                                     
{ PARAMETER 7                                                                                                 
    [[1, 0, clc$status_type]]];                                                                               
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$pp_number = 1,                                                                                        
      p$file = 2,                                                                                             
      p$pp_type = 3,                                                                                          
      p$address = 4,                                                                                          
      p$words = 5,                                                                                            
      p$iou = 6,                                                                                              
      p$status = 7;                                                                                           
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 7] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      address: 0 .. 16383,                                                                                    
      cell_p: ^cell,                                                                                          
      default_list: ARRAY [1 .. 2] OF dut$default_change_list_entry,                                          
      dump_information: dut$dump_information,                                                                 
      fa_p: ^fst$attachment_options,                                                                          
      file_buffer_p: ^SEQ ( * ),                                                                              
      file_identifier: amt$file_identifier,                                                                   
      file_pointer: amt$segment_pointer,                                                                      
      ignore_status: ost$status,                                                                              
      iou_number: 0 .. duc$de_maximum_ious,                                                                   
      output_file_opened: boolean,                                                                            
      pp_number: 0 .. duc$de_max_pp_memories,                                                                 
      restart_file_buffer_p: ^SEQ ( * ),                                                                      
      restart_file_seq_p: ^SEQ ( * ),                                                                         
      skip_pp_data_p: ^SEQ ( * ),                                                                             
      words: 0 .. 16384;                                                                                      
                                                                                                              
*copy dup$abort_handler                                                                                       
?? NEWTITLE := 'clean_up', EJECT ??                                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure is called from the abort handler to close the file.                                        
                                                                                                              
    PROCEDURE [INLINE] clean_up;                                                                              
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      IF output_file_opened THEN                                                                              
        fsp$close_file (file_identifier, ignore_status);                                                      
      IFEND;                                                                                                  
                                                                                                              
    PROCEND clean_up;                                                                                         
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the PP_TYPE and IOU parameters.                                            
                                                                                                              
    default_list [1].default_name := duc$dp_pp_type;                                                          
    default_list [1].number := p$pp_type;                                                                     
    default_list [2].default_name := duc$dp_iou;                                                              
    default_list [2].number := p$iou;                                                                         
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Check the availability of the pp memory.                                                                
                                                                                                              
    pp_number := pvt [p$pp_number].value^.integer_value.value;                                                
    iou_number := pvt [p$iou].value^.integer_value.value;                                                     
                                                                                                              
   /determine_pp_availability/                                                                                
    BEGIN                                                                                                     
      IF (pvt [p$pp_type].value^.keyword_value = 'NORMAL') AND                                                
            duv$dump_environment_p^.iou_memory [iou_number].nio_pp [pp_number].available THEN                 
        EXIT /determine_pp_availability/;  {---->                                                             
      ELSEIF (pp_number <= duc$de_max_cio_pp_memories) AND                                                    
            duv$dump_environment_p^.iou_memory [iou_number].cio_pp [pp_number].available THEN                 
        EXIT /determine_pp_availability/;  {---->                                                             
      IFEND;                                                                                                  
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                    
            'The peripheral processor', status);                                                              
      osp$append_status_integer (osc$status_parameter_delimiter, pp_number, 8, TRUE, status);                 
      osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);                             
      RETURN;  {---->                                                                                         
    END /determine_pp_availability/;                                                                          
                                                                                                              
    { Determine how many words to copy.                                                                       
                                                                                                              
    address := pvt [p$address].value^.integer_value.value;                                                    
    words := pvt [p$words].value^.integer_value.value;                                                        
    dup$determine_dump_information (dump_information);                                                        
    IF address >= dump_information.iou [iou_number].pp_word_size THEN                                         
      osp$set_status_abnormal (duc$dump_analyzer_id, due$invalid_address, '', status);                        
      osp$append_status_integer (osc$status_parameter_delimiter, address,                                     
            pvt [p$address].value^.integer_value.radix, TRUE, status);                                        
      RETURN;  {---->                                                                                         
    ELSEIF (address + words) > dump_information.iou [iou_number].pp_word_size THEN                            
      words := dump_information.iou [iou_number].pp_word_size - address;                                      
    IFEND;                                                                                                    
                                                                                                              
    output_file_opened := FALSE;                                                                              
    osp$establish_block_exit_hndlr (^abort_handler);                                                          
                                                                                                              
   /file_opened/                                                                                              
    BEGIN                                                                                                     
                                                                                                              
      { Open the output file.                                                                                 
                                                                                                              
      PUSH fa_p: [1 .. 1];                                                                                    
      fa_p^ [1].selector := fsc$access_and_share_modes;                                                       
      fa_p^ [1].access_modes.selector := fsc$specific_access_modes;                                           
      fa_p^ [1].access_modes.value :=                                                                         
            $fst$file_access_options [fsc$read, fsc$shorten, fsc$append, fsc$modify];                         
      fa_p^ [1].share_modes.selector := fsc$specific_share_modes;                                             
      fa_p^ [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$shorten, fsc$append, fsc$modify];
                                                                                                              
      fsp$open_file (pvt [p$file].value^.file_value^, amc$segment, fa_p, NIL, NIL, NIL, NIL, file_identifier, 
            status);                                                                                          
      IF NOT status.normal THEN                                                                               
        EXIT /file_opened/;  {---->                                                                           
      IFEND;                                                                                                  
      output_file_opened := TRUE;                                                                             
                                                                                                              
      amp$get_segment_pointer (file_identifier, amc$sequence_pointer, file_pointer, status);                  
      IF NOT status.normal THEN                                                                               
        EXIT /file_opened/;  {---->                                                                           
      IFEND;                                                                                                  
      IF file_pointer.sequence_pointer = NIL THEN                                                             
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        EXIT /file_opened/;  {---->                                                                           
      IFEND;                                                                                                  
      RESET file_pointer.sequence_pointer;                                                                    
                                                                                                              
      { Retrieve a sequence pointer to the pp memory data on the restart file.                                
                                                                                                              
      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;          
      IF pvt [p$pp_type].value^.keyword_value = 'NORMAL' THEN                                                 
        cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),                        
              duv$dump_environment_p^.iou_memory [iou_number].nio_pp [pp_number].first_byte);                 
      ELSE                                                                                                    
        cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),                        
              duv$dump_environment_p^.iou_memory [iou_number].cio_pp [pp_number].first_byte);                 
      IFEND;                                                                                                  
      RESET restart_file_seq_p TO cell_p;                                                                     
                                                                                                              
      { Skip to the desired address in the pp memory data.                                                    
                                                                                                              
      IF address > 0 THEN                                                                                     
        NEXT skip_pp_data_p: [[REP (address * 2) OF cell]] IN restart_file_seq_p;                             
        IF skip_pp_data_p = NIL THEN                                                                          
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          EXIT /file_opened/;  {---->                                                                         
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
      { Retrieve a pointer to the pp memory data on the restart file.                                         
                                                                                                              
      NEXT restart_file_buffer_p: [[REP words * 2 OF cell]] IN restart_file_seq_p;                            
      IF restart_file_buffer_p = NIL THEN                                                                     
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        EXIT /file_opened/;  {---->                                                                           
      IFEND;                                                                                                  
      RESET restart_file_buffer_p;                                                                            
                                                                                                              
      { Retrieve a pointer to the output file for the pp memory data.                                         
                                                                                                              
      NEXT file_buffer_p: [[REP words * 2 OF cell]] IN file_pointer.sequence_pointer;                         
      IF file_buffer_p = NIL THEN                                                                             
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        EXIT /file_opened/;  {---->                                                                           
      IFEND;                                                                                                  
      RESET file_buffer_p;                                                                                    
                                                                                                              
      { Copy the pp memory data from the restart file to the output file.                                     
                                                                                                              
      file_buffer_p^ := restart_file_buffer_p^;                                                               
      amp$set_segment_eoi (file_identifier, file_pointer, status);                                            
    END /file_opened/;                                                                                        
                                                                                                              
    IF output_file_opened THEN                                                                                
      fsp$close_file (file_identifier, ignore_status);                                                        
    IFEND;                                                                                                    
    osp$disestablish_cond_handler;                                                                            
                                                                                                              
  PROCEND dup$copy_pp_memory_command;                                                                         
MODEND dum$copy_pp_memory_command;                                                                            
*DECK DECK=DUM$CREATE_MONITOR_FUNC_FILE EXPAND=TRUE

PROC dum$create_monitor_func_file, create_monitor_func_file , cremff (
  file, f: file = $required
  status)

COLT $value(file)
illegal_request
cycle
delay
unused_request_3
device_io
advise_in
advise_out
advise_out_in
initiate_task
page_fault
initiate_job
exit_job
free_pages
write_modified_pages
change_segment_table
check_active_pps
unused_request_16
unused_request_17
job_swapping_functions
idle_system
mcr/ucr_fault
system_error
fetch_task_statistics
unused_request_23
unused_request_24
ready_task
set_system_flag
wait
lock_ring_1_stack
mtr_send_signal
set_get_sgmnt_length
memory_manager_io
job_recovery
ring_1_sgmnt_request
task_exit
unused_request_35
update_job_task_enviro
segment_request
lock_pages
unlock_pages
fetch_unwritten_pgs
allocate_front_end
deallocate_front_end
apply_mat_changes
tape_io
translate_byte_addr
config_mgmt_request
manage_system_tasks
lock_unlock_segment
issue_dft_request
wait_io_completion
switch_task
short_warning
monitor_smu_status
process_io_completions
update_system_display
process_scd_block
keypoint_recorder
periodic_call
process_due
unused_request_60
swap_job
monitor_mode_ei
nused_request_63
io_subsys_processor
logging_request
process_dft_block
job_scheduler_request
fetch_offset_mod_pages
assign_pages
conditional_free
queue_rhfam_request
unused_request_72
file_server_request
move_pages
assign_contig_memory
reallocate_front_end
ring1_server_seg_request
monitor_cpu_self_state
stats_facility_request
system_deadstart_status
service_class_statistics
unused_request_82
unused_request_83
unused_request_84
inject_hardware_fault
quick_sweep
**

PROCEND dum$create_monitor_func_file
*DECK DECK=DUM$CREATE_SWAP_STATUS_FILE EXPAND=TRUE

PROC dum$create_swap_status_file, create_swap_status_file, cressf (
  file, f: file = $required
  status)

COLT $value(file)
null
executing
idle_tasks_initiated
job_idle_tasks_complete
idle_tasks_complete
swapped_no_io
flush_am_pages
job_allocate_swap_file
wait_allocate_swap_file
allocate_swap_file
wait_job_io_complete
job_io_complete
wait_allocate_sfd
allocate_sfd
swapped_io_cannot_init
initiate_swapout_io
wait_swapout_io_init
swapout_io_initiated
swapout_io_complete
swapped_io_complete
free_swapped_memory
swapout_complete
swapin_requested
swapin_resource_claimed
wait_swapin_io_init
swapin_io_initiated
swapin_io_complete
**

PROCEND dum$create_swap_status_file
*DECK DECK=DUM$DEBUG_TABLE_INTERFACES EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, KEYW := UPPER, IDENT := LOWER) ??
MODULE dum$debug_table_interfaces;
?? PUSH (LISTEXT := ON) ??
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc clp$evaluate_parameters
*copyc clt$data_value
*copyc clt$work_area
*copyc dbp$module_table_address
*copyc dbt$entry_point_table
*copyc dbt$module_address_table_item
*copyc due$symbolic_access_exceptions
*copyc dup$close_display
*copyc dup$display_string
*copyc dup$open_display
*copyc dup$process_module_parameter
*copyc dut$home_specification
*copyc dut$variable_search_options
*copyc dut$variable_specification
*copyc fsp$close_file
*copyc fsp$open_file
*copyc i#compare_collated
*copyc llt$form_definition
*copyc lle$load_map_diagnostics
*copyc llt$load_module
*copyc mmp$create_scratch_segment
*copyc oce$library_generator_errors
*copyc ocp$close_linker_debug_table
*copyc ocp$define_linker_debug_table
*copyc ocp$find_debug_entry_point
*copyc ocp$find_debug_module_item
*copyc ocp$open_running_debug_table
*copyc osd$registers
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$exchange_package
*copyc ost$hardware_subranges
*copyc ost$stack_frame_save_area
*copyc osv$lower_to_upper
*copyc pme$debug_exceptions
*copyc pmp$validate_previous_save_area
?? POP ??
?? NEWTITLE := 'Global Definitions', EJECT ??
  TYPE
    stack_frame_control_image = packed record
      p_reg: ost$p_register,
      fill0: 0 .. 0f(16),
      vmid: 0 .. 0f(16),
      fill1: 0 .. 0ff(16),
      dsp: ost$pva,
      frame_desc: ost$frame_descriptor,
      csf: ost$pva,
      user_condition_mask: packed array [ost$user_condition] of boolean,
      psa: ost$pva,
      fill2: 0 .. 0ffff(16),
      bsp: ost$pva,
      user_conditions: packed array [ost$user_condition] of boolean,
      arg: ost$pva,
      monitor_conditions: packed array [ost$monitor_condition] of boolean,
      fill3: 0 .. 0ffffffffffff(16),
    recend,

    stack_afield = packed record
      fill1: 0 .. 0ffff(16),
      pva: ost$pva,
    recend,

    stack_xfield = record
      lhalf: 0 .. 0ffffffff(16),
      rhalf: 0 .. 0ffffffff(16),
    recend,

    stack_frame_areg_image = packed record
      p_reg: ost$p_register,
      reg: array [0 .. 0f(16)] of stack_afield,
    recend,

    stack_frame_xreg_image = record
      p_reg: ost$p_register,
      reg: array [0 .. 32] of stack_xfield,
    recend,

    stack_image_pointer = record
      case x: 0 .. 4 of
      = 0 =
        control: ^stack_frame_control_image,
      = 1 =
        aregs: ^stack_frame_areg_image,
      = 2 =
        xregs: ^stack_frame_xreg_image,
      = 3 =
        cell_p: ^cell,
      = 4 =
        pva: ost$pva,
      casend
    recend;

  VAR
    starting_procedure_ptr: ^cell := NIL,
    trapped_save_area_address: array [1 .. 1] of ^ost$stack_frame_save_area := [NIL];

  VAR
    nested_procedures: SET OF llt$module_generator := [llc$cybil, llc$obsolete_cybil, llc$pascal];

  VAR
    non_nested_structure_generators: [READ] set of llt$module_generator := [llc$cobol, llc$fortran];

  CONST
    c$current_module = '$CURRENT',
    c$current_procedure = '$CURRENT';

  VAR
    v$default_module: pmt$program_name := c$current_module,
    v$default_procedure: pmt$program_name := c$current_procedure;

  VAR
    p_debug_directory: ^SEQ (*) := NIL,
    p_first_module: ^dbt$module_address_table_item := NIL,
    p_local_modules: ^dbt$module_address_table_item := NIL;
?? TITLE := 'dup$add_debug_tables', EJECT ??

  PROCEDURE [XDCL] dup$add_debug_tables (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE add_debug_tables, add_debug_table, adddt (
{   debug_tables, debug_table, dt: list of any of
{       key
{         (running_system, rs)
{       keyend
{       file
{     anyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 4, 10, 12, 30, 54, 666],
    clc$command, 4, 2, 1, 0, 0, 0, 2, ''], [
    ['DEBUG_TABLE                    ',clc$alias_entry, 1],
    ['DEBUG_TABLES                   ',clc$nominal_entry, 1],
    ['DT                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 120,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [104, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
      FALSE, 2],
      81, [[1, 0, clc$keyword_type], [2], [
        ['RS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['RUNNING_SYSTEM                 ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      3, [[1, 0, clc$file_type]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$debug_tables = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);

    IF status.normal THEN
      process_debug_tables (pvt [p$debug_tables].value, status);
    IFEND;
  PROCEND dup$add_debug_tables;
?? TITLE := 'dup$build_home_spec', EJECT ??
{
{ This code is used to establish the concept of a "home" module and procedure.
{ Specifically, it interprets the module, procedure, recursion_level and
{ recursion_direction parameters passed to it in parameter list form.  These
{ parameters appear on several commands.  For parameters that are not present,
{ defaults are established.  The code is further complicated by needing to solve
{ these problems:
{
{ 1)  Not all four of the above-mentioned parameters are defined for each
{     command that can call this procedure.  Also, not all parameters are valid
{     for every language that is supported.
{
{ 2)  The method for establishing defaults differs for different languages.  It
{     is not possible to establish language without assuming some default as
{     the language is determined by the line or symbol table, not the module
{     table.
{
{ The following table attempts to define the way defaults should be established
{ for module and procedure.  The code attempts to implement this scheme with the
{ case tested first being that of assuming that home being established will be
{ in a FTN (non_nested_structure language) program.
{
{_________________________|___|___|___|___|___|___|___|___|___|___|___|___|___|
{  module parameter       | T | T | T | T | F | F | F | F | F | F | F | F | F |
{ specified               |___|___|___|___|___|___|___|___|___|___|___|___|___|
{  procedure parameter    | T | F | F | F | T | T | T | F | F | F | F | F | F |
{ specified               |___|___|___|___|___|___|___|___|___|___|___|___|___|
{  default module         | N | N | N | N | T | N | F | T | T | T | F | F | F |
{ available               |___|___|___|___|___|___|___|___|___|___|___|___|___|
{  default procedure      | N | T | F | N | N | N | N | T | F | F | T | T | F |
{ available               |___|___|___|___|___|___|___|___|___|___|___|___|___|
{  language that supports | N | T | T | F | T | F | T | N | T | F | T | F | N |
{ nested procedures       |___|___|___|___|___|___|___|___|___|___|___|___|___|
{                         | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 |10 |11 |12 |13 |
{                         |___|___|___|___|___|___|___|___|___|___|___|___|___|
{
{ (1)  Use module specified and procedure specified
{
{ (2)  Use module specified and default procedure
{
{ (3)  Use specified module and current P register for procedure
{
{ (4)  Use specified module for both module and procedure
{
{ (5)  Use default module and specified procedure
{
{ (6)  Use specified procedure for both module and procedure
{
{ (7)  Use current P register to determine module and use specified procedure
{
{ (8)  Use default module and default procedure
{
{ (9)  Use default module and current P register for procedure
{
{ (10) Use default module for both module and procedure
{
{ (11) Use current P register for module and default procedure
{
{ (12) Use default procedure for both module and procedure
{
{ (13) Use current P register to determine module and procedure
{

  PROCEDURE [XDCL] dup$build_home_spec (module_name: pmt$program_name;
        procedure_name: pmt$program_name;
        recursion_level_value: clt$data_value;
        recursion_direction_value: clt$data_value;
    VAR home_spec: dut$home_specification;
    VAR status: ost$status);

    VAR
      found: boolean,
      language_questionable: boolean,
      line_table_address: ^llt$line_address_table,
      line_item_index: llt$line_address_table_size,
      local_stat: ost$status,
      local_status: ost$status,
      module_specified: boolean,
      procedure_specified: boolean,
      ring_specified: boolean,
      save_area: ^ost$stack_frame_save_area,
      section_item_index: llt$section_ordinal,
      symbol: ^llt$symbol_table_item,
      symbol_index: llt$symbol_number,
      symbol_table_address: ^llt$debug_symbol_table,
      target_ring: ost$ring,
      trapped_sf: stack_image_pointer;

    VAR
      converter: record
        case boolean of
        = FALSE =
          p_cell: ^cell,
        = TRUE =
          pva: ost$pva,
        casend,
      recend,
      pva: ost$pva;

?? EJECT ??
    local_status.normal := TRUE;
    status.normal := TRUE;
    local_stat.normal := TRUE;
    home_spec.line_table_address := NIL;
    home_spec.symbol_table_address := NIL;
    home_spec.procedure_entry.symbol := NIL;
    language_questionable := TRUE;
    home_spec.language := llc$unknown_generator;
    module_specified := (module_name <> osc$null_name);
    procedure_specified := (procedure_name  <> osc$null_name);

{Set up ring to be the ring where the user is stopped
    ring_specified := false;
    find_trapped_stack_frame (trapped_sf.cell_p, found);
    IF found THEN
      pva := trapped_sf.control^.p_reg.pva;
    ELSE
      IF (starting_procedure_ptr = NIL) THEN
        save_area := #previous_save_area ();
        converter.pva := save_area^.minimum_save_area.p_register.pva;
        starting_procedure_ptr := converter.p_cell;
      IFEND;
      converter.p_cell := starting_procedure_ptr;
      pva := converter.pva;
    IFEND;
    target_ring := pva.ring;

    IF module_specified THEN
{a specified module is always used
      find_tables_for_module_name (module_name, target_ring, ring_specified, home_spec.module_item,
            line_table_address, symbol_table_address, status);
      IF NOT status.normal THEN
        RETURN; {------->
      IFEND;
      home_spec.line_table_address := line_table_address;
      home_spec.symbol_table_address := symbol_table_address;
      IF procedure_specified THEN   {If procedure specified}
{a specified procedure is always used
        find_procedure_for_name (symbol_table_address, procedure_name, symbol, symbol_index, status);
        IF NOT status.normal THEN
          RETURN; {------->
        IFEND;
        home_spec.procedure_entry.table_entry_index := symbol_index;
        home_spec.procedure_entry.symbol := symbol;
        language_questionable := FALSE;
      ELSE
{assume a non nested structured language and use the module parameter for procedure
        local_status.normal := TRUE;
        find_procedure_for_name (symbol_table_address, module_name, symbol, symbol_index,
              local_status);
        IF (local_status.normal) AND (home_spec.symbol_table_address <> NIL) AND (symbol_table_address^.
              language IN non_nested_structure_generators) THEN
          language_questionable := FALSE;
          home_spec.procedure_entry.table_entry_index := symbol_index;
          home_spec.procedure_entry.symbol := symbol;
        IFEND;
      IFEND;
    ELSE {module not specified
      IF procedure_specified THEN
{assume that language will be a non nested structured one and use specified
{procedure for module name
        find_tables_for_module_name (procedure_name, target_ring, ring_specified, home_spec.module_item,
              line_table_address, symbol_table_address, local_stat);
        IF local_stat.normal THEN
          home_spec.symbol_table_address := symbol_table_address;
          home_spec.line_table_address := line_table_address;
          find_procedure_for_name (symbol_table_address, procedure_name, symbol, symbol_index,
                local_status);
          IF (local_status.normal) AND (symbol_table_address <> NIL) AND (symbol_table_address^.language IN
                non_nested_structure_generators) THEN
            home_spec.procedure_entry.table_entry_index := symbol_index;
            home_spec.procedure_entry.symbol := symbol;
            language_questionable := FALSE;
          IFEND;
        IFEND;
      ELSE {both module and procedure not specified}
        IF v$default_module <> c$current_module THEN
{an explicit default module exists, use it for module
          find_tables_for_module_name (v$default_module, target_ring, ring_specified,
                home_spec.module_item, line_table_address, symbol_table_address, status);
          IF NOT status.normal THEN
            RETURN; {------->
          IFEND;
          home_spec.symbol_table_address := symbol_table_address;
          home_spec.line_table_address := line_table_address;
          IF v$default_procedure <> c$current_procedure THEN
{a default procedure also exists
            find_procedure_for_name (symbol_table_address, v$default_procedure, symbol, symbol_index,
                  status);
            IF NOT status.normal THEN
              RETURN; {------->
            IFEND;
            home_spec.procedure_entry.table_entry_index := symbol_index;
            home_spec.procedure_entry.symbol := symbol;
            language_questionable := FALSE;
          ELSE
{use default module as procedure name also
            local_status.normal := TRUE;
            find_procedure_for_name (symbol_table_address, v$default_module, symbol, symbol_index,
                  local_status);
            IF (local_status.normal) AND (symbol_table_address <> NIL) AND (symbol_table_address^.language IN
                  non_nested_structure_generators) THEN
              home_spec.procedure_entry.table_entry_index := symbol_index;
              home_spec.procedure_entry.symbol := symbol;
              language_questionable := FALSE;
            IFEND;
          IFEND;
        ELSE
{no default module
          IF v$default_procedure <> c$current_procedure THEN
{Use default procedure for module
            local_stat.normal := TRUE;
            find_tables_for_module_name (v$default_procedure, target_ring, ring_specified,
                  home_spec.module_item, line_table_address, symbol_table_address, local_stat);
            IF local_stat.normal THEN
              home_spec.symbol_table_address := symbol_table_address;
              home_spec.line_table_address := line_table_address;
              local_status.normal := TRUE;
              find_procedure_for_name (symbol_table_address, v$default_procedure, symbol, symbol_index,
                    local_status);
              IF (local_status.normal) AND (symbol_table_address <> NIL) AND (symbol_table_address^.language
                    IN non_nested_structure_generators) THEN
                home_spec.procedure_entry.table_entry_index := symbol_index;
                home_spec.procedure_entry.symbol := symbol;
                language_questionable := FALSE;
              IFEND;
            IFEND;
          ELSE
{use where you are for module and procedure
            dup$find_module_table_for_pva (pva, home_spec.module_item, section_item_index, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            IF home_spec.module_item^.section_item [section_item_index].kind <> llc$code_section THEN
              osp$set_status_abnormal (duc$symbolic_id, due$internal_error,
                'Value of trapped_sf.control^.p_reg.pva not in code section', status);
              RETURN; {----->
            IFEND;
            find_line_number_for_pva (home_spec.module_item, section_item_index, pva, line_table_address,
                  line_item_index, status);
            IF status.normal THEN
              home_spec.line_table_address := line_table_address;
            ELSE
{ If we cant find the current pva in the line table, assume we are in the first
{  one for the current module.
              IF home_spec.module_item^.line_address_tables <> NIL THEN
                home_spec.line_table_address := home_spec.module_item^.line_address_tables^[0];
              IFEND;   {If there are line tables}
            IFEND;

            dup$find_procedure_for_pva (home_spec.module_item, section_item_index, pva, symbol_table_address,
                  symbol_index, status);
            IF NOT status.normal THEN
              RETURN; { ----->
            IFEND;
            home_spec.procedure_entry.table_entry_index := symbol_index;
            home_spec.procedure_entry.symbol := ^symbol_table_address^.item [symbol_index];
            home_spec.symbol_table_address := symbol_table_address;
            language_questionable := FALSE;
          IFEND; {explicit default procedure}
        IFEND; {explicit default module}
      IFEND; {procedure specified}
    IFEND; {module specified}

{if module not established or if the set of default chosen yielded the wrong
{language type

    IF (language_questionable) OR (NOT local_stat.normal) THEN
      IF NOT local_stat.normal THEN
{module has not been established
        IF v$default_module <> c$current_module THEN
{Use default module for module name
          find_tables_for_module_name (v$default_module, target_ring, ring_specified,
                home_spec.module_item, line_table_address, symbol_table_address, status);
          IF NOT status.normal THEN
            RETURN; {------->
          IFEND;
          home_spec.line_table_address := line_table_address;
          home_spec.symbol_table_address := symbol_table_address;
        ELSE
{use where you are for module
          dup$find_module_table_for_pva (pva, home_spec.module_item, section_item_index, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          IF home_spec.module_item^.section_item [section_item_index].kind <> llc$code_section THEN
            osp$set_status_abnormal (duc$symbolic_id, due$internal_error,
              'Value of trapped_sf.control^.p_reg.pva not in code section', status);
            RETURN; {----->
          IFEND;
          find_line_number_for_pva (home_spec.module_item, section_item_index, pva, line_table_address,
                line_item_index, status);
          IF status.normal THEN
            home_spec.line_table_address := line_table_address;
          ELSE
{ If we cant find the current pva in the line table, assume we are in the first
{  one for the current module.
            IF home_spec.module_item^.line_address_tables <> NIL THEN
              home_spec.line_table_address := home_spec.module_item^.line_address_tables^[0];
            IFEND;
          IFEND;

          dup$find_procedure_for_pva (home_spec.module_item, section_item_index, pva, symbol_table_address,
                symbol_index, status);
          IF NOT status.normal THEN
            RETURN; { ----->
          IFEND;
          home_spec.procedure_entry.table_entry_index := symbol_index;
          home_spec.procedure_entry.symbol := ^symbol_table_address^.item [symbol_index];
          home_spec.symbol_table_address := symbol_table_address;
        IFEND;
      IFEND;

      local_status.normal := TRUE;
      IF procedure_specified THEN
        find_procedure_for_name (symbol_table_address, procedure_name,
                     symbol, symbol_index, status);
        IF NOT status.normal THEN
          home_spec.procedure_entry.symbol := NIL;
          RETURN; {------->
        IFEND;
        home_spec.procedure_entry.table_entry_index := symbol_index;
        home_spec.procedure_entry.symbol := symbol;
      ELSE
        IF v$default_procedure <> c$current_procedure THEN
          find_procedure_for_name (symbol_table_address, v$default_procedure, symbol, symbol_index,
                status);
          IF NOT status.normal THEN
            RETURN; {------->
          IFEND;
          home_spec.procedure_entry.table_entry_index := symbol_index;
          home_spec.procedure_entry.symbol := symbol;
        ELSE
{procedure name has not already been found
          find_section_for_pva (home_spec.module_item, pva,
                        section_item_index, local_status);
          IF local_status.normal THEN
{ The current pva is in the specified module }
            dup$find_procedure_for_pva (home_spec.module_item, section_item_index, pva, symbol_table_address,
                  symbol_index, status);
            IF NOT status.normal THEN
              RETURN; { ----->
            IFEND;
{Now make sure this procedure is in the specified module
            find_procedure_for_name (home_spec.symbol_table_address, symbol_table_address^.item
                  [symbol_index].symbol_name, symbol, symbol_index, status);
            IF NOT status.normal THEN
              status.normal := TRUE;
            ELSE
              home_spec.procedure_entry.symbol := symbol;
              home_spec.procedure_entry.table_entry_index := symbol_index;
            IFEND;
          IFEND;
        IFEND;  {explicit default procedure specified}
      IFEND;  {procedure_specified}
    IFEND;  {language_questionable OR NOT local_stat.normal}
{Fill in the language field from the symbol table if available; then the line table; otherwise
{set it to unknown
    IF home_spec.symbol_table_address <> NIL THEN
      home_spec.language := home_spec.symbol_table_address^.language;
    ELSEIF home_spec.line_table_address <> NIL THEN
      home_spec.language := home_spec.line_table_address^.language;
    ELSE
    IFEND;

{ Take care of recursion_level parameter

    IF (recursion_level_value.kind = clc$integer) THEN   {If specified}
      home_spec.proc_recursion_level := recursion_level_value.integer_value.value;
    ELSE
      home_spec.proc_recursion_level := 0;
    IFEND;

{ Take care of recursion_direction parameter

    IF (recursion_direction_value.kind = clc$keyword) AND
          (recursion_direction_value.keyword_value (1) = 'F') THEN
      home_spec.stack_search_direction := duc$first_to_trapped;
    ELSE
      home_spec.stack_search_direction := duc$trapped_to_first;
    IFEND;

  PROCEND dup$build_home_spec;
?? TITLE := 'dup$build_variable_spec', EJECT ??

  PROCEDURE [XDCL] dup$build_variable_spec (
        home_spec: dut$home_specification;
        symbol_entry: dut$symbol_entry;
        nested_proc: boolean;
        current_proc: dut$symbol_entry;
    VAR variable_spec: dut$variable_specification;
    VAR status: ost$status);

{ PURPOSE: Establish a variable_spec given a symbol_entry. }

    CONST
      bits_per_byte = 8,
      bytes_per_word = 8,
      reserved_stack_space = bytes_per_word * 2,
      right_justified_offset = 2;

    VAR
      field_entry: dut$symbol_entry,
      field_offset: machine_addr_in_bits_type,
      true_current_proc: dut$symbol_entry,
      true_procedure_entry: dut$symbol_entry,
      entry_item: dbt$entry_point_table_item,
      indirectly_referenced: boolean,
      pointer: ^^ost$pva,
      helper: ^cell,
      proc_start: ost$pva,
      stack_frame_save_area: ^ost$stack_frame_save_area;

    status.normal := TRUE;
    variable_spec.name := symbol_entry.symbol^.symbol_name;
    variable_spec.symbol_entry := symbol_entry;
    variable_spec.length := symbol_entry.symbol^.var_length;
    variable_spec.length_is_bits := FALSE;
    variable_spec.bit_offset := 0;
    variable_spec.range_specified := FALSE;
    variable_spec.constant_value := FALSE;

    IF symbol_entry.symbol^.symbol_kind = llc$constant_kind THEN
      CASE symbol_entry.symbol^.constant_kind OF
      = llc$short_constant =
        CASE symbol_entry.symbol^.short_constant_value.kind OF
        = llc$boolean_kind =
          helper := #LOC(symbol_entry.symbol^.short_constant_value.boolean_value);
        = llc$char_kind =
          helper := #LOC(symbol_entry.symbol^.short_constant_value.char_value);
        = llc$bit_kind =
          helper := #LOC(symbol_entry.symbol^.short_constant_value.bit_value);
{ CYBIL sets length for bit short constants to 2 - should be 8. }
          IF (home_spec.language = llc$cybil) OR (home_spec.language = llc$obsolete_cybil) THEN
            variable_spec.length := 8;     {kludge for CYBIL bug}
          IFEND;
        = llc$integer_kind =
          helper := #LOC(symbol_entry.symbol^.short_constant_value.integer_value);
{ CYBIL sets length for integer short constants to 2 - should be 8. }
          IF (home_spec.language = llc$cybil) OR (home_spec.language = llc$obsolete_cybil) THEN
            variable_spec.length := 8;     {kludge for CYBIL bug}
          IFEND;
        CASEND;
        variable_spec.address.ring := osc$invalid_ring {flag local address};
        variable_spec.address.seg := #SEGMENT(helper);
        variable_spec.address.offset := #OFFSET(helper);
      = llc$medium_constant =
        CASE symbol_entry.symbol^.medium_constant_value.kind OF
        = llc$integer_kind =
          helper := #LOC(symbol_entry.symbol^.medium_constant_value.integer_value);
        = llc$real_kind =
          helper := #LOC(symbol_entry.symbol^.medium_constant_value.real_value);
        = llc$shortreal_kind =
          helper := #LOC(symbol_entry.symbol^.medium_constant_value.shortreal_value);
        CASEND;
        variable_spec.address.ring := osc$invalid_ring {flag local address};
        variable_spec.address.seg := #SEGMENT(helper);
        variable_spec.address.offset := #OFFSET(helper);
      = llc$long_constant =
        variable_spec.address :=
          home_spec.module_item^.section_item[symbol_entry.symbol^.constant_section_ordinal].address;
        variable_spec.address.offset :=
          variable_spec.address.offset + symbol_entry.symbol^.constant_offset;
      CASEND;
      RETURN;
    IFEND;

    indirectly_referenced := llc$var_indirectly_referenced IN symbol_entry.symbol^.var_attributes;
    CASE symbol_entry.symbol^.var_base OF
    = llc$static_base =
      variable_spec.address := home_spec.module_item^.section_item
            [symbol_entry.symbol^.var_section_ordinal].address;
      variable_spec.address.offset := variable_spec.address.offset +
            symbol_entry.symbol^.var_offset;

    = llc$stack_frame_base, llc$parm_list_base =
      IF home_spec.proc_recursion_level <> 0 THEN
        true_procedure_entry := home_spec.procedure_entry;
        WHILE true_procedure_entry.symbol^.symbol_kind <> llc$proc_kind DO
          dup$locate_symbol_for_number (home_spec.symbol_table_address,
                true_procedure_entry.symbol^.with_parent, true_procedure_entry, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        WHILEND;
        proc_start := home_spec.module_item^.section_item[
              true_procedure_entry.symbol^.proc_section_ordinal].address;
        proc_start.offset := proc_start.offset +
              true_procedure_entry.symbol^.proc_offset;
        dup$find_stack_frame_for_proc (proc_start,
              true_procedure_entry.symbol^.proc_length, home_spec.
              stack_search_direction, home_spec.proc_recursion_level,
              variable_spec.address, stack_frame_save_area, status);
        IF NOT status.normal THEN
          IF status.condition = due$procedure_not_active THEN
            osp$set_status_abnormal (duc$symbolic_id,
                due$procedure_not_active, true_procedure_entry.
                symbol^.symbol_name, status);  {put proc name in msg}
          ELSE
            IF home_spec.procedure_entry.symbol^.proc_return_type <> 0 THEN
              osp$set_status_abnormal (duc$symbolic_id, due$function_not_active,
                true_procedure_entry.symbol^.symbol_name, status)
            IFEND;
          IFEND;
          RETURN; {----->
        IFEND;
      ELSE
        stack_frame_save_area := home_spec.current_stack_frame;
        variable_spec.address.ring := #ring (stack_frame_save_area^.minimum_save_area.
              a1_current_stack_frame);
        variable_spec.address.seg := #segment (stack_frame_save_area^.minimum_save_area.
              a1_current_stack_frame);
        variable_spec.address.offset := #offset (stack_frame_save_area^.minimum_save_area.
              a1_current_stack_frame);
      IFEND;
      IF nested_proc THEN
{ First check to see if the stack is initialized. }
        check_for_prolog (home_spec, stack_frame_save_area^,
                             variable_spec.name, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        true_current_proc := current_proc;
        WHILE true_current_proc.symbol^.symbol_kind <> llc$proc_kind DO
          dup$locate_symbol_for_number (home_spec.symbol_table_address,
                true_current_proc.symbol^.with_parent, true_current_proc, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        WHILEND;
        variable_spec.address.offset := variable_spec.address.offset
              + (true_current_proc.symbol^.proc_lexical_level * bytes_per_word)
              + reserved_stack_space + right_justified_offset;
        pointer := #LOC (variable_spec.address);
        variable_spec.address := pointer^^;
      IFEND;
      IF symbol_entry.symbol^.var_base = llc$parm_list_base THEN
        IF (stack_frame_save_area^.minimum_save_area.
              frame_descriptor.a_terminating < 4) THEN
          osp$set_status_abnormal (duc$symbolic_id,
                due$variable_not_accessible, variable_spec.name, status);
          RETURN;
        IFEND;
        IF nested_proc THEN
          variable_spec.address.offset := variable_spec.address.offset
                + (true_current_proc.symbol^.proc_lexical_level * bytes_per_word)
                + reserved_stack_space + right_justified_offset;
          pointer := #LOC (variable_spec.address);
          variable_spec.address := pointer^^;
        ELSE
          variable_spec.address.ring := #ring
                (stack_frame_save_area^.a4);
          variable_spec.address.seg := #segment
                (stack_frame_save_area^.a4);
          variable_spec.address.offset := #offset
                (stack_frame_save_area^.a4);
        IFEND;
      IFEND;
      variable_spec.address.offset := variable_spec.address.offset +
            symbol_entry.symbol^.var_offset;

    = llc$xref_base =
      find_entry_point_item (variable_spec.name, entry_item, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      variable_spec.address := entry_item.address;
      indirectly_referenced := FALSE; {no dereference for xref
      {symbols}

    ELSE
      osp$set_status_abnormal (duc$symbolic_id,
            due$variable_not_accessible, variable_spec.name, status);
      RETURN;
    CASEND;

    IF indirectly_referenced THEN
      variable_spec.descriptor_address := variable_spec.address;
      pointer := #LOC (variable_spec.address);
      variable_spec.address := pointer^^;
    IFEND;

    IF (current_proc.symbol <> NIL) AND
       (current_proc.symbol^.symbol_kind = llc$pascal_with_kind) THEN
{ WITH block var_kind symbols point to a field_type entry.  This code updates
{  variable_spec in the same way locate_cybil_field does.  Any further subfields
{  will be handled in the normal way.
      dup$locate_symbol_for_number (home_spec.symbol_table_address,
        variable_spec.symbol_entry.symbol^.var_type, field_entry, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      IF field_entry.symbol^.symbol_kind = llc$field_kind THEN
        variable_spec.symbol_entry := field_entry;
        variable_spec.length := field_entry.symbol^.field_length;
        variable_spec.length_is_bits := NOT
          (llc$field_is_byte_addressable IN field_entry.symbol^.field_attributes);
        IF variable_spec.length_is_bits THEN
          field_offset := variable_spec.bit_offset + field_entry.symbol^.
                field_offset;
          variable_spec.address.offset := variable_spec.address.offset +
                (field_offset DIV bits_per_byte);
          variable_spec.bit_offset := field_offset MOD bits_per_byte;
        ELSE
          variable_spec.address.offset := variable_spec.address.offset +
                field_entry.symbol^.field_offset;
        IFEND;
      IFEND; { If field }
    IFEND; {If with block }

  PROCEND dup$build_variable_spec;
?? TITLE := 'dup$change_default_module', EJECT ??

  PROCEDURE [XDCL] dup$change_default_module  (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE change_default_module, chadm (
{   module, m: (CHECK) any of
{       key
{         $current
{       keyend
{       program_name
{       application
{     anyend = $CURRENT
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$application_type_qualifier,
        recend,
        default_value: string (8),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 12, 2, 10, 46, 18, 465],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['M                              ',clc$abbreviation_entry, 1],
    ['MODULE                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 75,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$application_type, clc$keyword_type, clc$program_name_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$CURRENT                       ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$program_name_type]],
    4, [[1, 0, clc$application_type], [FALSE]]
    ,
    '$CURRENT'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$module = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      module_name: pmt$program_name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);

    IF status.normal THEN
      dup$process_module_parameter ('MODULE', pvt [p$module].value, module_name, status);
      IF status.normal THEN
        v$default_module := module_name;
      IFEND;
    IFEND;
  PROCEND dup$change_default_module;
?? TITLE := 'dup$change_default_procedure', EJECT ??

  PROCEDURE [XDCL] dup$change_default_procedure  (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE change_default_procedure, chadp (
{   procedure, p: (CHECK) any of
{       key
{         $current
{       keyend
{       program_name
{       application
{     anyend = $CURRENT
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$application_type_qualifier,
        recend,
        default_value: string (8),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 12, 2, 11, 1, 16, 119],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['P                              ',clc$abbreviation_entry, 1],
    ['PROCEDURE                      ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 75,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$application_type, clc$keyword_type, clc$program_name_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$CURRENT                       ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$program_name_type]],
    4, [[1, 0, clc$application_type], [FALSE]]
    ,
    '$CURRENT'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$procedure = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      procedure_name: pmt$program_name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);

    IF status.normal THEN
      dup$process_module_parameter ('PROCEDURE', pvt [p$procedure].value, procedure_name, status);
      IF status.normal THEN
        v$default_procedure := procedure_name;
      IFEND;
    IFEND;
  PROCEND dup$change_default_procedure;
?? TITLE := 'dup$default_module_function', EJECT ??

  PROCEDURE [XDCL] dup$default_module_function (parameter_list: clt$parameter_list;
    VAR p_work: ^clt$work_area;
    VAR p_value: ^clt$data_value;
    VAR status: ost$status);

{ FUNCTION $default_module, $dm

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 1, 11, 10, 49, 53, 947],
    clc$function, 0, 0, 0, 0, 0, 0, 0, '']];

?? FMT (FORMAT := ON) ??
?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);

    IF status.normal THEN
      NEXT p_value IN p_work;
      p_value^.kind := clc$program_name;
      p_value^.program_name_value := v$default_module;
    IFEND;
  PROCEND dup$default_module_function;
?? TITLE := 'dup$default_procedure_function', EJECT ??

  PROCEDURE [XDCL] dup$default_procedure_function (parameter_list: clt$parameter_list;
    VAR p_work: ^clt$work_area;
    VAR p_value: ^clt$data_value;
    VAR status: ost$status);

{ FUNCTION $default_procedure, $dp

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 1, 11, 12, 19, 0, 964],
    clc$function, 0, 0, 0, 0, 0, 0, 0, '']];

?? FMT (FORMAT := ON) ??
?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);

    IF status.normal THEN
      NEXT p_value IN p_work;
      p_value^.kind := clc$program_name;
      p_value^.program_name_value := v$default_procedure;
    IFEND;
  PROCEND dup$default_procedure_function;
?? TITLE := 'dup$display_line_number', EJECT ??

  PROCEDURE [XDCL] dup$display_line_number (
        parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE display_line_number, disln (
{   procedure_offset, po, offset: (CHECK) integer 0..7fffffff(16) = 0
{   module, m: (CHECK) any of
{       program_name
{       application
{     anyend = $optional
{   procedure, p: (CHECK) any of
{       program_name
{       application
{     anyend = $optional
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type2: 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$application_type_qualifier,
        recend,
      recend,
      type3: 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$application_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 4, 28, 9, 47, 46, 472],
    clc$command, 10, 5, 0, 0, 0, 0, 5, ''], [
    ['M                              ',clc$abbreviation_entry, 2],
    ['MODULE                         ',clc$nominal_entry, 2],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OFFSET                         ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 4],
    ['P                              ',clc$abbreviation_entry, 3],
    ['PO                             ',clc$alias_entry, 1],
    ['PROCEDURE                      ',clc$nominal_entry, 3],
    ['PROCEDURE_OFFSET               ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 27, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 27, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 7fffffff(16), 10],
    '0'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$application_type, clc$program_name_type],
    FALSE, 2],
    3, [[1, 0, clc$program_name_type]],
    4, [[1, 0, clc$application_type], [FALSE]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$application_type, clc$program_name_type],
    FALSE, 2],
    3, [[1, 0, clc$program_name_type]],
    4, [[1, 0, clc$application_type], [FALSE]]
    ],
{ PARAMETER 4
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$procedure_offset = 1,
      p$module = 2,
      p$procedure = 3,
      p$output = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      display_control: clt$display_control,
      length: integer,
      line_index: llt$line_address_table_size,
      line_number: integer,
      line_string: string (30),
      local_status: ost$status,
      module_name: pmt$program_name,
      p_display_control: ^clt$display_control,
      p_line_table: ^llt$line_address_table,
      p_module: ^dbt$module_address_table_item,
      p_symbol: ^llt$symbol_table_item,
      p_symbol_table: ^llt$debug_symbol_table,
      proc_section: llt$section_ordinal,
      procedure_name: pmt$program_name,
      pva: ost$pva,
      symbol_index: llt$symbol_number;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);

    IF status.normal THEN
      dup$process_module_parameter ('MODULE', pvt [p$module].value, module_name, status);
    IFEND;

    IF status.normal THEN
      dup$process_module_parameter ('PROCEDURE', pvt [p$procedure].value, procedure_name, status);
    IFEND;

    IF status.normal THEN
      IF (module_name = osc$null_name) THEN
        module_name := v$default_module;
      IFEND;
      find_tables_for_module_name (module_name, 11, FALSE, p_module, p_line_table, p_symbol_table, status);
    IFEND;

    IF status.normal THEN
      IF (procedure_name = osc$null_name) THEN
        procedure_name := v$default_procedure;
      IFEND;
      find_procedure_for_name (p_symbol_table, procedure_name, p_symbol, symbol_index, status);
    IFEND;

    IF status.normal THEN
      proc_section := p_symbol^.proc_section_ordinal;
      pva := p_module^.section_item [proc_section].address;
      pva.offset := pva.offset + p_symbol^.proc_offset + pvt [p$procedure_offset].value^.integer_value.value;
      find_line_number_for_pva (p_module, proc_section, pva, p_line_table, line_index, status);
    IFEND;

    IF status.normal THEN
      line_number := p_line_table^.item [line_index].line_number;
      STRINGREP (line_string, length, 'Line number =', line_number);

      p_display_control := ^display_control;
      dup$open_display (pvt [p$output].value^.file_value^, p_display_control, status);

      IF status.normal THEN
        dup$display_string (p_display_control, length, line_string (1, length), 0, status);
        dup$close_display (p_display_control, FALSE, local_status);
        IF NOT local_status.normal AND status.normal THEN
          status := local_status;
        IFEND;
      IFEND;
    IFEND;
  PROCEND dup$display_line_number;
?? TITLE := 'dup$find_module_table_for_pva', EJECT ??
*copy duh$find_module_table_for_pva

  PROCEDURE [XDCL] dup$find_module_table_for_pva (pva: ost$pva;
    VAR module_item: ^dbt$module_address_table_item;
    VAR section_item_index: llt$section_ordinal;
    VAR status: ost$status);

    module_item := p_first_module;
  /look_for_module_containing_pva/
    WHILE module_item <> NIL DO
      find_section_for_pva (module_item, pva, section_item_index, status);
      IF status.normal = TRUE THEN
        EXIT /look_for_module_containing_pva/;
      IFEND;
      module_item := module_item^.next_module;
    WHILEND /look_for_module_containing_pva/;
{  if we get here and the module address table pointer is nil it
{  means that we searched the entire module table and did not find
{  a module with a section contining the specified pva.
{
    IF module_item = NIL THEN
      osp$set_status_abnormal (duc$symbolic_id, due$pva_not_in_any_module,
            osc$null_name, status);
      RETURN;
    IFEND;
  PROCEND dup$find_module_table_for_pva;
?? TITLE := 'dup$find_procedure_for_pva', EJECT ??
*copyc duh$find_procedure_for_pva

  PROCEDURE [XDCL] dup$find_procedure_for_pva (module_item: ^dbt$module_address_table_item;
        section_item_index: llt$section_ordinal;
        pva: ost$pva;
    VAR symbol_table_address: ^llt$debug_symbol_table;
    VAR symbol_index: llt$symbol_number;
    VAR status: ost$status);

    VAR
      offset: ost$segment_length,
      symbol: ^llt$symbol_table_item,
      symbol_table_index: llt$symbol_number;

    status.normal := TRUE;
{
{  check if the module actually has a symbol table
{
    IF module_item^.debug_symbol_tables = NIL THEN
      osp$set_status_abnormal (duc$symbolic_id, due$no_symbol_table_in_module, module_item^.name, status);
      RETURN; { ----->
    IFEND;
{
    offset := pva.offset - module_item^.section_item [section_item_index].address.offset;
{
{  now search the symbol table(s) for the required procedure
{
    FOR symbol_table_index := 0 TO UPPERBOUND (module_item^.debug_symbol_tables^) DO
      FOR symbol_index := 1 TO UPPERBOUND (module_item^.debug_symbol_tables^ [symbol_table_index]^.item) DO
        symbol := ^module_item^.debug_symbol_tables^ [symbol_table_index]^.item [symbol_index];
        IF symbol^.symbol_kind = llc$proc_kind THEN
          IF (module_item^.debug_symbol_tables^[symbol_table_index]^.
            language <> llc$fortran) OR ((module_item^.debug_symbol_tables^
            [symbol_table_index]^.language = llc$fortran) AND (symbol^.
            proc_lexical_level = 0)) THEN
            IF (symbol^.proc_section_ordinal = module_item^.section_item[section_item_index].section_ordinal)
                AND (symbol^.proc_offset <= offset) AND
                (symbol^.proc_offset + symbol^.proc_length > offset) THEN
              symbol_table_address := module_item^.debug_symbol_tables^[symbol_table_index];
              RETURN; { ----->
            IFEND;
          IFEND;
        ELSEIF symbol^.symbol_kind = llc$pascal_with_kind THEN
          IF (symbol^.with_section_ordinal = module_item^.section_item[section_item_index].section_ordinal)
              AND (symbol^.with_offset <= offset) AND
                (symbol^.with_offset + symbol^.with_length > offset) THEN
            symbol_table_address := module_item^.debug_symbol_tables^[symbol_table_index];
            RETURN; { ----->
          IFEND;
        IFEND;
      FOREND;
    FOREND;

{  procedure not found for this address.

    osp$set_status_abnormal (duc$symbolic_id, due$pva_not_in_known_proc,
          osc$null_name, status);

  PROCEND dup$find_procedure_for_pva;
?? TITLE := 'dup$find_stack_frame_for_proc', EJECT ??

  PROCEDURE [XDCL] dup$find_stack_frame_for_proc (proc_start: ost$pva;
    proc_length: ost$segment_length;
    search_direction: dut$stack_search_direction;
    target_sf_number: dut$proc_recursion_number;
    VAR target_sf: ost$pva;
    VAR target_sf_save_area: ^ost$stack_frame_save_area;
    VAR status: ost$status);

    VAR
      trapped_sf_found: boolean,
      trapped_to_first_target_sf_num,
      trapped_to_first_sf_counter,
      total_sf_count_for_proc: dut$proc_recursion_number,
      trapped_sf_sa_ptr: ^cell,
      sa_ptr: ^ost$stack_frame_save_area,
      sa_p_register: ost$pva;


    find_trapped_stack_frame (trapped_sf_sa_ptr, trapped_sf_found);
    IF NOT trapped_sf_found THEN
      osp$set_status_abnormal (duc$symbolic_id, due$no_trap_has_occurred, osc$null_name,
        status);
      RETURN; {------>
    IFEND;

{If search_direction is duc$trapped_to_first then the search takes place backwards starting with the last
{(i.e. trapped) stack frame in direction of the first stack frame of the task. The search counter
{trapped_to_first_sf_counter is increased by one each time a stack frame to the procedure identified by
{proc_start is encountered. The search is continued until the search counter reaches the value
{of target_sf_number, or the first frame of the task is reached, in which case there are fewer frames
{for that procedure in the stack than target_sf_number expresses.
{Note that there are always 3 or 4 system stack frames on top of the trapped user frame.
{
{If search_direction is duc$first_to_trapped, the search direction is conceptually forwards starting
{with the first procedure of the stack in direction of the trapped frame of the task until the
{target_sf_number'th frame to that procedure is encountered, or the top of stack is reached.
{Note, however, the actual searching can take place only from trapped to first frame (see previous save area).
{Therefore, when search_direction is duc$first_to_trapped, we have to search at first all the way to the first
{frame, obtain the total number of frames belonging to that procedure, recalculate the position of the
{target_sf in terms of trapped_to_first direction, the search the stack again in backward direction
{until the target frame is found.


{Calculate the value of trapped_to_first_target_sf_num. This value represents the position of the
{target stack frame assuming a search direction from trapped to first frame.

    IF search_direction = duc$trapped_to_first THEN
      trapped_to_first_target_sf_num := target_sf_number;
    ELSE {search direction is from first to trapped stack frame}
      sa_ptr := trapped_sf_sa_ptr;
      trapped_to_first_sf_counter := 0;
      WHILE sa_ptr <> NIL DO
        sa_p_register := sa_ptr^.minimum_save_area.p_register.pva;
        IF (sa_p_register.ring = proc_start.ring) AND
          (sa_p_register.seg = proc_start.seg) AND
          (proc_start.offset <= sa_p_register.offset) AND
          (sa_p_register.offset < proc_start.offset + proc_length) THEN
          trapped_to_first_sf_counter := trapped_to_first_sf_counter + 1;
        IFEND;
        pmp$validate_previous_save_area (sa_ptr, status);
        IF NOT status.normal THEN
          RETURN; {------>
        IFEND;
        sa_ptr := sa_ptr^.minimum_save_area.a2_previous_save_area;
      WHILEND;
      total_sf_count_for_proc := trapped_to_first_sf_counter;
      IF total_sf_count_for_proc < target_sf_number THEN
        IF total_sf_count_for_proc = 0 THEN    {the procedure is not active}
          osp$set_status_abnormal (duc$symbolic_id, due$procedure_not_active,
                   '', status);
        ELSE     {recursion_level parameter too big}
          osp$set_status_abnormal (duc$symbolic_id, due$target_sf_number_too_big,
                   '', status);
        IFEND;
        RETURN; {----->
      ELSE
        trapped_to_first_target_sf_num := total_sf_count_for_proc - target_sf_number + 1;
      IFEND;
    IFEND;

{Find target stack frame to procedure with target_sf_number parameter value if search_direction is
{duc$trapped_to_first, or with recalculated target stack frame number if search_direction is
{duc$first_to_trapped.

    sa_ptr := trapped_sf_sa_ptr;
    trapped_to_first_sf_counter := 0;
    WHILE sa_ptr <> NIL DO
      sa_p_register := sa_ptr^.minimum_save_area.p_register.pva;
      IF sa_ptr <> trapped_sf_sa_ptr THEN
{Assume all stack frames but the trapped stack frame were laid down by call
{instructions, meaning that the p-register points to the instruction following
{the call.  Subtract 4 from the p-register to get the address of the call.
        sa_p_register.offset := sa_p_register.offset - 4;
      IFEND;
      IF (sa_p_register.ring = proc_start.ring) AND
        (sa_p_register.seg = proc_start.seg) AND
        (proc_start.offset <= sa_p_register.offset) AND
        (sa_p_register.offset < proc_start.offset + proc_length) THEN
        trapped_to_first_sf_counter := trapped_to_first_sf_counter + 1;
        IF trapped_to_first_sf_counter = trapped_to_first_target_sf_num THEN
          target_sf.ring := #ring (sa_ptr^.minimum_save_area.a1_current_stack_frame);
          target_sf.seg := #segment (sa_ptr^.minimum_save_area.a1_current_stack_frame);
          target_sf.offset := #offset (sa_ptr^.minimum_save_area.a1_current_stack_frame);
          target_sf_save_area := sa_ptr;
          RETURN; {----->
        IFEND
      IFEND;
      IF search_direction = duc$trapped_to_first THEN
        pmp$validate_previous_save_area (sa_ptr, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      IFEND;
      sa_ptr := sa_ptr^.minimum_save_area.a2_previous_save_area;
    WHILEND;
    IF trapped_to_first_sf_counter = 0 THEN    {the procedure is not active}
      osp$set_status_abnormal (duc$symbolic_id, due$procedure_not_active,
               '', status);
    ELSE     {recursion_level parameter too big}
      osp$set_status_abnormal (duc$symbolic_id, due$target_sf_number_too_big,
               '', status);
    IFEND;

  PROCEND dup$find_stack_frame_for_proc;
?? TITLE := 'dup$locate_next_symbol', EJECT ??

*copyc duh$locate_next_symbol
  PROCEDURE [XDCL] dup$locate_next_symbol (symbol_table_address: ^llt$debug_symbol_table;
    VAR symbol_entry: {input,output} dut$symbol_entry;
    VAR status: ost$status);

    VAR
      symbol_index: llt$symbol_number;

    status.normal := TRUE;
{
{  check if the module actually has a symbol table
{
    IF symbol_table_address = NIL THEN
      osp$set_status_abnormal (duc$symbolic_id, due$symbol_table_not_available, osc$null_name, status);
      RETURN; { ----->
    IFEND;
{
{ now step to the next symbol table entry
{
    IF symbol_entry.table_entry_index < symbol_table_address^.number_of_items THEN
      symbol_index := symbol_entry.table_entry_index + 1;
      symbol_entry.table_entry_index := symbol_index;
      symbol_entry.symbol := ^symbol_table_address^.item [symbol_index];
    ELSE
      symbol_entry.symbol := NIL;   { No more entries in the symbol table }
    IFEND;

  PROCEND dup$locate_next_symbol;
?? TITLE := 'dup$locate_symbol_for_number', EJECT ??

*copyc duh$locate_symbol_for_number
  PROCEDURE [XDCL] dup$locate_symbol_for_number (symbol_table_address: ^llt$debug_symbol_table;
        symbol_number: llt$symbol_number;
    VAR symbol_entry: dut$symbol_entry;
    VAR status: ost$status);

    VAR
      symbol_index: llt$symbol_number;

    status.normal := TRUE;
{
{  check if the module actually has a symbol table
{
    IF symbol_table_address = NIL THEN
      osp$set_status_abnormal (duc$symbolic_id, due$symbol_table_not_available, osc$null_name, status);
      RETURN; { ----->
    IFEND;
{
{  now search the symbol table for the required number.  Use symbol number as index if possible.
{
    IF llc$symbol_number_is_index IN symbol_table_address^.attributes THEN
      IF (symbol_number <= 0) OR (symbol_number > symbol_table_address^.number_of_items) THEN
        osp$set_status_abnormal (duc$symbolic_id, due$symbol_number_not_found, osc$null_name, status);
        RETURN; { ----->
      IFEND;
      symbol_entry.table_entry_index := symbol_number;
      symbol_entry.symbol := ^symbol_table_address^.item[symbol_number];
      RETURN; {----->
    ELSE
      FOR symbol_index := 1 TO UPPERBOUND (symbol_table_address^.item) DO
        IF symbol_number = symbol_table_address^.item [symbol_index].symbol_number
              THEN
          symbol_entry.table_entry_index := symbol_index;
          symbol_entry.symbol := ^symbol_table_address^.item [symbol_index];
          RETURN; { ----->
        IFEND;
      FOREND;
    IFEND;
{
{  if we get here, the required symbol number was not found in
{  the symbol table.  This is impossible in principle.
{
    osp$set_status_abnormal (duc$symbolic_id, due$symbol_number_not_found,
          osc$null_name, status);

  PROCEND dup$locate_symbol_for_number;
?? TITLE := 'dup$locate_variable_symbol', EJECT ??

  PROCEDURE [XDCL] dup$locate_variable_symbol (
        variable_name: pmt$program_name;
        home_spec: dut$home_specification;
        search_options: dut$variable_search_options;
    VAR symbol_entry: dut$symbol_entry;
    VAR nested_proc: boolean;
    VAR current_proc: dut$symbol_entry;
    VAR status: ost$status);

{ PURPOSE: Find the symbol entry for the given variable name. }

    VAR
      first_symbol_number: llt$symbol_number,
      parent_symbol_number: llt$symbol_number,
      proc_start: ost$pva,
      module_level_searched: boolean,
      stack_frame_save_area: ^ost$stack_frame_save_area,
      true_procedure_entry: dut$symbol_entry,
      variable_spec: dut$variable_specification;

    current_proc := home_spec.procedure_entry;
    nested_proc := FALSE;
    module_level_searched := FALSE;

    REPEAT

/search_lexical_level/
      BEGIN
        IF current_proc.symbol <> NIL THEN
          IF current_proc.symbol^.symbol_kind = llc$proc_kind THEN
            first_symbol_number := current_proc.symbol^.first_symbol_for_proc;
          ELSE { Must be a WITH block }
            first_symbol_number := current_proc.symbol^.with_first_symbol;
          IFEND;
          IF first_symbol_number = 0 THEN
            EXIT /search_lexical_level/; {no symbols at this level}
          IFEND;
          dup$locate_symbol_for_number (home_spec.symbol_table_address,
                first_symbol_number, symbol_entry, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          module_level_searched := TRUE;
          dup$locate_symbol_for_number (home_spec.symbol_table_address,
                home_spec.symbol_table_address^.first_symbol_for_module,
                symbol_entry, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        WHILE TRUE DO
          IF ((symbol_entry.symbol^.symbol_kind = llc$var_kind) OR
              (symbol_entry.symbol^.symbol_kind = llc$constant_kind)) AND
             (symbol_entry.symbol^.symbol_name = variable_name) THEN
{ We have found the variable ... }
            RETURN;
          ELSE
{ Get the next symbol in the chain }
            IF symbol_entry.symbol^.end_of_chain THEN
              EXIT /search_lexical_level/;
            IFEND;
            dup$locate_next_symbol (home_spec.symbol_table_address,
                  symbol_entry, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        WHILEND;
      END /search_lexical_level/;

{ Check the next outer level of procedure nesting if there is one }

      IF (current_proc.symbol <> NIL) AND
         (NOT (duc$search_outer_procedures IN search_options)) AND
         (NOT (llc$proc_uses_outer_level_stack IN current_proc.symbol^.proc_attributes)) THEN
        current_proc.symbol := NIL;  { NIL means check module level next }
      IFEND;
      IF current_proc.symbol <> NIL THEN
        IF current_proc.symbol^.symbol_kind = llc$proc_kind THEN
          parent_symbol_number := current_proc.symbol^.proc_parent;
        ELSE { Must be WITH block }
          parent_symbol_number := current_proc.symbol^.with_parent;
        IFEND;
        IF parent_symbol_number = 0 THEN
          current_proc.symbol := NIL;
        ELSE
{ WITH blocks and procs that share outer level stack don't count as nested }
          IF (current_proc.symbol^.symbol_kind = llc$proc_kind) AND
             NOT (llc$proc_uses_outer_level_stack IN current_proc.symbol^.proc_attributes) THEN
            nested_proc := TRUE;
          IFEND;
          dup$locate_symbol_for_number (home_spec.symbol_table_address,
                parent_symbol_number, current_proc, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;
      IF (current_proc.symbol = NIL) AND
         (NOT(duc$search_module_level IN search_options)) THEN
        module_level_searched := TRUE; { Don't search the module level }
      IFEND;
    UNTIL module_level_searched;

    osp$set_status_abnormal (duc$symbolic_id, due$variable_not_found,
          variable_name, status);

  PROCEND dup$locate_variable_symbol;
?? TITLE := 'dup$simulate_variable', EJECT ??

  PROCEDURE [XDCL] dup$simulate_variable (home_spec: dut$home_specification;
        address: ost$pva;
        type_name: pmt$program_name;
    VAR variable_spec: dut$variable_specification;
    VAR status: ost$status);

    VAR
      maximum: integer,
      p_cell: ^cell,
      symbol_entry: dut$symbol_entry;

    locate_named_symbol (type_name, home_spec, symbol_entry, status);
    IF not status.normal THEN
      RETURN;
    IFEND;

    IF (symbol_entry.symbol^.symbol_kind = llc$var_kind) THEN
      dup$locate_symbol_for_number (home_spec.symbol_table_address, symbol_entry.symbol^.var_type,
            symbol_entry, status);
      IF not status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    variable_spec.name := symbol_entry.symbol^.symbol_name;
    variable_spec.symbol_entry := symbol_entry;
    variable_spec.address := address;
    variable_spec.length_is_bits := FALSE;
    variable_spec.bit_offset := 0;
    variable_spec.range_specified := FALSE;
    variable_spec.constant_value := FALSE;

    CASE symbol_entry.symbol^.symbol_kind OF
    = llc$longreal_kind =
      variable_spec.length := 16;
    = llc$integer_kind, llc$real_kind =
      variable_spec.length := 8;
    = llc$boolean_kind, llc$char_kind, llc$cell_kind =
      variable_spec.length := 1;
    = llc$subrange_kind =
      IF (symbol_entry.symbol^.low_value < 0) THEN
        variable_spec.length := 8;
      ELSE
        variable_spec.length := 0;
        maximum := symbol_entry.symbol^.high_value;
        REPEAT
          variable_spec.length := variable_spec.length + 1;
          maximum := maximum DIV 256;
        UNTIL (maximum = 0);
      IFEND;
    = llc$set_kind =
      variable_spec.length := (symbol_entry.symbol^.set_length + 7) DIV 8;
    = llc$ordinal_kind =
      variable_spec.length := 0;
      maximum := symbol_entry.symbol^.ordinal_upper_bound;
      REPEAT
        variable_spec.length := variable_spec.length + 1;
        maximum := maximum DIV 256;
      UNTIL (maximum = 0);
    = llc$cybil_array_kind =
      variable_spec.length := symbol_entry.symbol^.cybil_array_element_length;
    = llc$pointer_kind =
      variable_spec.length := #SIZE (p_cell);
    = llc$string_kind =
      variable_spec.length := symbol_entry.symbol^.string_length;
    = llc$bound_vrec_kind =
      dup$locate_symbol_for_number (home_spec.symbol_table_address, symbol_entry.symbol^.bound_type,
            symbol_entry, status);
      IF status.normal THEN
        variable_spec.symbol_entry := symbol_entry;
        variable_spec.length := symbol_entry.symbol^.record_length;
      IFEND;
    = llc$record_kind =
      variable_spec.length := symbol_entry.symbol^.record_length;
    ELSE
      osp$set_status_abnormal (duc$symbolic_id, due$unsupported_type, type_name, status);
    CASEND;
  PROCEND dup$simulate_variable;
?? TITLE := 'check_for_prolog', EJECT ??
{   This routine checks to see if the variables normally available for the
{    given home_spec, are unavailable because we are stopped in prolog
{    code.  A normal status is returned if
{         - The stack frame to be used in the display is not the current
{            stack frame.
{         - The current pva is in a different module or procedure than
{            described in home_spec.
{         - The current pva is not the first byte of a line which contains
{            prolog code.
{    Since the length of prologs are not available to DEBUG, this
{    routine only checks the current pva against the first byte of the
{    prolog.
{   An abnormal status is returned if
{         - An error is returned from any of the look-up routines.
{         - A line table exists for the module but no line covers the
{            current pva.  We will assume prolog in this case.
{         - The current pva is the first byte of a line which contains
{            prolog code.

  PROCEDURE check_for_prolog (
        home_spec: dut$home_specification;
        stack_frame: ost$stack_frame_save_area;
        variable_name: pmt$program_name;
    VAR status: ost$status);

    VAR
      aux_ptr: ^ost$pva,
      found: boolean,
      line_table_ptr: ^llt$line_address_table,
      line_item_index: llt$line_address_table_size,
      line_table_item: llt$line_address_item,
      module_table_ptr: ^dbt$module_address_table_item,
      pva: ost$pva,
      section_item_index: llt$section_ordinal,
      symbol_index: llt$symbol_number,
      symbol_table_ptr: ^llt$debug_symbol_table,
      trapped_sf: stack_image_pointer;

    status.normal := TRUE;
    pva := stack_frame.minimum_save_area.p_register.pva;
    dup$find_module_table_for_pva (pva, module_table_ptr, section_item_index,
                   status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (duc$symbolic_id, due$in_prolog_code,
                   variable_name, status);
      RETURN; {----->
    IFEND;
    IF home_spec.module_item <> module_table_ptr THEN
      RETURN; {----->     different module
    IFEND;

    dup$find_procedure_for_pva (module_table_ptr, section_item_index, pva,
                   symbol_table_ptr, symbol_index, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (duc$symbolic_id, due$in_prolog_code,
                   variable_name, status);
      RETURN; { ----->
    IFEND;
    IF home_spec.procedure_entry.table_entry_index <> symbol_index THEN
      RETURN; {----->     different procedure
    IFEND;

    find_line_number_for_pva (module_table_ptr, section_item_index, pva, line_table_ptr,
          line_item_index, status);
    IF NOT status.normal THEN
      IF status.condition = due$no_line_numbers_in_module THEN
        status.normal := TRUE;  {can't tell anything if no line table}
      ELSE
        osp$set_status_abnormal (duc$symbolic_id, due$in_prolog_code,
                   variable_name, status);
      IFEND;
      RETURN; {----->
    IFEND;

    CASE home_spec.language OF
    = llc$cybil, llc$obsolete_cybil =
      IF line_table_ptr^.item[line_item_index].cybil_statement_kind =
                              llc$cybil_procedure THEN
{ If the pva (where we are stopped) is the beginning of the line, return
{   the 'in prolog' error status.   Currently, we cannot tell how long the
{   prolog is, so if by chance we are stopped in the middle of the prolog,
{   that's tuff cookies.  We can only recognize the beginning.
        IF (pva.offset - module_table_ptr^.section_item[section_item_index].address.
                     offset) = line_table_ptr^.item[line_item_index].offset THEN
          osp$set_status_abnormal (duc$symbolic_id, due$in_prolog_code,
               variable_name, status);
          RETURN; {----->
        IFEND;
      IFEND;
    ELSE
      IF llc$prolog_code IN line_table_ptr^.item [line_item_index].line_attributes THEN
{ If this line entry is prolog code, don't return error if the last line entry
{  is the same line and is prolog code.  This is for BASIC which likes to jump
{  to subroutine statements.
        IF (line_item_index = 1) OR
           (line_table_ptr^.item[line_item_index].line_number <>
                    line_table_ptr^.item[line_item_index - 1].line_number) OR
           (NOT(llc$prolog_code IN line_table_ptr^.item[line_item_index - 1].line_attributes)) THEN
          osp$set_status_abnormal (duc$symbolic_id, due$in_prolog_code, variable_name,
             status);
          RETURN; {----->
        IFEND;
      IFEND;
    CASEND;
  PROCEND check_for_prolog;
?? TITLE := 'create_module_item', EJECT ??

  PROCEDURE create_module_item (module_name: pmt$program_name;
        greatest_section_ordinal: llt$section_ordinal;
    VAR p_module_item: ^dbt$module_address_table_item;
    VAR status: ost$status);

    VAR
      section_ordinal: llt$section_ordinal,
      section_item: dbt$section_item;

    status.normal := TRUE;
    NEXT p_module_item: [0 .. greatest_section_ordinal] IN p_debug_directory;

    p_module_item^.name := module_name;
    p_module_item^.language := llc$unknown_generator;
    p_module_item^.greatest_section_ordinal := greatest_section_ordinal;
    p_module_item^.application_identifier := NIL;
    p_module_item^.reinitialization_information := NIL;
    p_module_item^.next_module := NIL;
    p_module_item^.line_address_tables := NIL;
    p_module_item^.debug_symbol_tables := NIL;
    p_module_item^.supplemental_debug_tables := NIL;

    section_item.kind := llc$lts_reserved;
    section_item.address.ring := 0;
    section_item.address.seg := 0;
    section_item.address.offset := 0;
    section_item.length := 0;
    section_item.segment_access_control.cache_bypass := FALSE;
    section_item.segment_access_control.execute_privilege := osc$non_executable;
    section_item.segment_access_control.read_privilege := osc$non_readable;
    section_item.segment_access_control.write_privilege := osc$non_writable;
    section_item.ring.r1 := 0;
    section_item.ring.r2 := 0;
    section_item.ring.r3 := 0;
    section_item.key_lock.global := FALSE;
    section_item.key_lock.local := FALSE;
    section_item.key_lock.value := 0;
    section_item.name := osc$null_name;

    FOR section_ordinal := 0 to greatest_section_ordinal DO
      section_item.section_ordinal := section_ordinal;
      p_module_item^.section_item [section_ordinal] := section_item;
    FOREND;
  PROCEND create_module_item;
?? TITLE := 'find_entry_point_item', EJECT ??
{
{  This procedure searches the entry point table for an entry point of
{  a specified name.
{
{  FIND_ENTRY_POINT_ITEM (NAME, ENTRY, STATUS)
{
{  NAME : (input)    is the name of the entry point for which the
{                    entry point table is to be searched
{
{  ENTRY : (output)  is the required entry point table item (if found)
{
{  STATUS : (output) is the status of the request. Possible value(s):
{                      due$named_entry_point_not_found
{

  PROCEDURE find_entry_point_item (name: pmt$program_name;
    VAR entry_point_table_item: dbt$entry_point_table_item;
    VAR status: ost$status);

    VAR
      entry_point: dbt$entry_point_table_item,
      found: boolean,
      module_name: pmt$program_name,
      segment: ost$segment,
      offset: ost$segment_offset;

    ocp$find_debug_entry_point (name, found, module_name, segment, offset, status);

    IF status.normal THEN
      IF found THEN
        entry_point.name := name;
        entry_point.call_bracket := UPPERVALUE (ost$ring);
        entry_point.loaded_ring := UPPERVALUE (ost$ring);
        entry_point.global_lock := 0;
        entry_point.address.ring := UPPERVALUE (ost$ring);
        entry_point.address.seg := segment;
        entry_point.address.offset := offset;
        entry_point_table_item := entry_point;
      ELSE
        osp$set_status_abnormal (duc$symbolic_id, due$named_entry_point_not_found,name, status);
      IFEND;
    IFEND;
  PROCEND find_entry_point_item;
?? TITLE := 'find_line_number_for_pva', EJECT ??
{
{  This procedure searches the line address table for a specific
{  module to determine if there is a line that contains that pva.
{
{  FIND_LINE_NUMBER_FOR_PVA (MODULE, SECTION_INDEX, PVA, LINE, LINE_INDEX, STATUS)
{
{  MODULE : (input)  is the module address table item in which the
{                    pva is located.
{
{  SECTION_INDEX : (input) is the index of the section definition record
{                    within the array of section definition records
{                    containing the pva.
{
{  PVA : (input)     is the pva for which the line address table is
{                    to be searched.
{
{  LINE : (output)   is the pointer to the line address table (if one is
{                    found) which contains the pva.
{
{  LINE_INDEX : (output) is the line item index in the line address table.
{
{  STATUS : (output) is the status of the request. Possible value(s):
{                      due$no_line_numbers_in_module
{                      due$pva_not_line_number
{

  PROCEDURE find_line_number_for_pva (module_item: ^dbt$module_address_table_item;
    section_item_index: llt$section_ordinal;
    pva: ost$pva;
    VAR line_table: ^llt$line_address_table;
    VAR line_item_index: llt$line_address_table_size;
    VAR status: ost$status);

    VAR
      line_table_index: integer,
      sect_item: dbt$section_item,
      relative_offset: llt$section_offset;

    status.normal := TRUE;
{
{  check if this module actually has any line number tables
{
    IF module_item^.line_address_tables = NIL THEN
      osp$set_status_abnormal (duc$symbolic_id, due$no_line_numbers_in_module,
        osc$null_name, status);
      RETURN; {----->
    IFEND;
{
{  module does have line number tables.  Search to see if this
{  address corresponds to a line number in this module.
{
    sect_item := module_item^.section_item[section_item_index];
    relative_offset := pva.offset - module_item^.section_item[section_item_index].address.offset;
    FOR line_table_index := 0 TO UPPERBOUND (module_item^.line_address_tables^) DO
      FOR line_item_index := 1 TO UPPERBOUND (module_item^.line_address_tables^ [line_table_index]^.item) DO
        IF (sect_item.section_ordinal = module_item^.line_address_tables^ [line_table_index]^.item
          [line_item_index].section_ordinal) AND (relative_offset >= module_item^.line_address_tables^
            [line_table_index]^.item [line_item_index].offset) AND (relative_offset < module_item^.
            line_address_tables^[line_table_index]^.item [line_item_index].offset + module_item^.
            line_address_tables^ [line_table_index]^.item [line_item_index].extent) THEN
{
{  the line number has actually been found
{
          line_table := module_item^.line_address_tables^ [line_table_index];
          RETURN; {----->
        IFEND;
      FOREND;
    FOREND;
{
{  if we get here we have searched all the line address tables
{  and have not found a match for the pva we have.  This
{  situation would occur when a bound module has been encountered
{  without line numbers.  For the time being we will return a bad
{  status.
{
    osp$set_status_abnormal (duc$symbolic_id, due$pva_not_line_number,
          osc$null_name, status);
    RETURN; {----->
  PROCEND find_line_number_for_pva;
?? TITLE := 'find_procedure_for_name', EJECT ??
{
{  This procedure locates the symbol table item which corresponds to
{  the specified name.
{
{  FIND_PROCEDURE_FOR_NAME (ADDRESS, NAME, SYMBOL, INDEX, STATUS)
{
{  ADDRESS : (input)    is a pointer to the debug symbol table.
{
{  NAME : (input)       is the name of the procedure to be located.
{
{  SYMBOL : (output)    is a pointer to the debug symbol table entry.
{
{  INDEX : (output)     is the index of the symbol table item.
{
{  STATUS : (OUTPUT)    is the status of the request. Possible value(s):
{                         due$no_symbol_table_in_module
{                         due$proc_not_in_module
{

  PROCEDURE find_procedure_for_name (symbol_table_address: ^llt$debug_symbol_table;
        name: pmt$program_name;
    VAR symbol: ^llt$symbol_table_item;
    VAR symbol_index: llt$symbol_number;
    VAR status: ost$status);

    VAR
      case_sensitive: boolean,
      temp_name: pmt$program_name;

    status.normal := TRUE;
{
{  check if the module actually has a symbol table
{
    IF symbol_table_address = NIL THEN
      osp$set_status_abnormal (duc$symbolic_id, due$symbol_table_not_available, osc$null_name, status);
      RETURN; { ----->
    IFEND;
    case_sensitive := llc$language_is_case_sensitive IN
                             symbol_table_address^.attributes;
{
{  now search the symbol table for the required procedure
{
    FOR symbol_index := 1 TO UPPERBOUND (symbol_table_address^.item) DO
      symbol := ^symbol_table_address^.item [symbol_index];
      IF (symbol^.symbol_kind = llc$proc_kind) THEN
        IF ((case_sensitive) AND (symbol^.symbol_name = name)) OR
           ((NOT case_sensitive) AND (i#compare_collated(symbol^.symbol_name,
                           name, osv$lower_to_upper) = 0)) THEN
          IF NOT((symbol^.proc_length = 0) AND
               (symbol^.first_symbol_for_proc = 0)) THEN {Ignore XREF'd procs}
            RETURN; { ----->
          IFEND;
        IFEND;
      IFEND;
    FOREND;

{  procedure not found for this name.

    temp_name := name;
    IF NOT case_sensitive THEN
      #TRANSLATE (osv$lower_to_upper, temp_name, temp_name);
    IFEND;
    osp$set_status_abnormal (duc$symbolic_id, due$proc_not_in_module, temp_name, status);
    osp$append_status_parameter (osc$status_parameter_delimiter,
      symbol_table_address^.original_module_name, status);

  PROCEND find_procedure_for_name;
?? TITLE := 'find_section_for_pva', EJECT ??
{
{  This procedure searches the section definition records of a specific
{  module to locate a section that contains the pva.
{
{  FIND_SECTION_FOR_PVA (MODULE, PVA, SECTION, STATUS)
{
{  MODULE : (input)  is a pointer to the module address table item
{                    containing the section definition records to be searched.
{
{  PVA : (input)     is the pva for which the section definition records
{                    are to be searched.
{
{ SECTION : (output) is the index of the section definition record
{                    within the array of section definition records
{                    (if one is found) containing the pva.
{
{  STATUS : (output) is the request status. Possible value(s):
{                      due$pva_not_in_section
{

  PROCEDURE find_section_for_pva (module_item: ^dbt$module_address_table_item;
    pva: ost$pva;
    VAR section_item_index: llt$section_ordinal;
    VAR status: ost$status);

    status.normal := TRUE;
    FOR section_item_index := 0 TO UPPERBOUND (module_item^.section_item) DO
      IF (pva.ring = module_item^.section_item [section_item_index].address.ring) AND (pva.seg =
        module_item^.section_item [section_item_index].address.seg) AND ((pva.offset >= module_item^.
          section_item [section_item_index].address.offset) AND (pva.offset < module_item^.section_item
          [section_item_index].address.offset + module_item^.section_item [section_item_index].length)) THEN
        RETURN; { ----->
      IFEND;
    FOREND;
{
{  if we get here we've been through the section table without
{  finding a section that contains the given pva.
{
    osp$set_status_abnormal (duc$symbolic_id, due$pva_not_in_section, osc$null_name, status);
  PROCEND find_section_for_pva;
?? TITLE := 'find_section_for_specs', EJECT ??
{
{  The purpose of this request is to find the section that satisfies some given specifications.
{  The specifications are in terms of the section kind, section name and  access privileges
{  (execute, read, write).
{
{  FIND_SECTION_FOR_SPECS (MODULE, KIND, NAME, EXECUTE, READ, WRITE, SECTION, STATUS)
{
{  MODULE:  (input)   This parameter specifies the module which is searched for the section.
{
{  KIND:  (input)     This parameter specifies the kind (code, working storage, etc.) of the
{                     section to be found.
{
{  NAME:  (input)     This parameter specifies the name of the section to be found.
{                     This is either the name of a CYBIL section, or the null name.
{
{  EXECUTE:  (input)  This parameter specifies the execute privilege of the section to be found.
{
{  READ:  (input)     This parameter specifies the read privilege of the section to be found.
{
{  WRITE:  (input)    This parameter specifies the write privilege of the section to be found.
{
{  SECTION:  (output) This parameter specifies the section that satisfies the input specifications.
{
{  STATUS:  (output)  This parameter specifies the request status. Possible value(s):
{                       due$specd_section_not_in_module
{

  PROCEDURE find_section_for_specs (module_item: ^dbt$module_address_table_item;
    section_kind: llt$section_kind;
    section_name: pmt$program_name;
    execute_privileges: set of ost$execute_privilege;
    read_privileges: set of ost$read_privilege;
    write_privileges: set of ost$write_privilege;
    VAR section_item: dbt$section_item;
    VAR status: ost$status);

    VAR
      section_item_index: integer;

    status.normal := TRUE;
    FOR section_item_index := 0 TO UPPERBOUND (module_item^.section_item) DO
      section_item := module_item^.section_item [section_item_index];
      IF (section_item.kind = section_kind) AND (i#compare_collated (section_item.name, section_name,
        osv$lower_to_upper) = 0) AND (section_item.segment_access_control.execute_privilege IN
          execute_privileges) AND (section_item.segment_access_control.read_privilege IN read_privileges) AND
          (section_item.segment_access_control.write_privilege IN write_privileges) THEN
        RETURN; {------->
      IFEND;
    FOREND;
{
{ If we get here we have been thru the section table without finding a section item of the given
{ specifications for section kind, section name, and section access privileges.
{
    osp$set_status_abnormal (duc$symbolic_id, due$specd_section_not_in_module,
      section_name, status);
  PROCEND find_section_for_specs;
?? TITLE := 'find_sf_pointers_and_length', EJECT ??

  PROCEDURE find_sf_pointers_and_length (starting_sf_save_area_ptr: ^cell;
        target_sf_number: integer;
    VAR target_sf_ptr: ^cell;
    VAR target_sf_save_area_ptr: ^cell;
    VAR target_sf_length: integer;
    VAR status: ost$status);

    VAR
      frame_number: integer,
      scan_save_area: ^ost$stack_frame_save_area;

    IF starting_sf_save_area_ptr = NIL THEN
      scan_save_area := #previous_save_area ();
    ELSE
      scan_save_area := starting_sf_save_area_ptr;
    IFEND;

  /find_target_sf/
    FOR frame_number := 1 TO target_sf_number - 1 DO
      scan_save_area := scan_save_area^.minimum_save_area.a2_previous_save_area;
      IF scan_save_area = NIL THEN
        EXIT /find_target_sf/;
      IFEND;
    FOREND /find_target_sf/;
    IF NOT (scan_save_area = NIL) THEN
      target_sf_ptr := scan_save_area^.minimum_save_area.a1_current_stack_frame;
      target_sf_save_area_ptr := scan_save_area;
      target_sf_length := #offset (target_sf_save_area_ptr) - #offset (target_sf_ptr);
    ELSE
      target_sf_ptr := NIL;
      target_sf_save_area_ptr := NIL;
      target_sf_length := 0;
    IFEND;
  PROCEND find_sf_pointers_and_length;
?? TITLE := 'find_statement_label', EJECT ??
{
{   This procedure searches the symbol table for the given statement
{    label name and returns the label's symbol table entry.  If the statement
{    label is not found, symbol_entry.symbol is set to NIL.  Only symbols in the
{    scope of the procedure specified in home_spec are examined.  For nested
{    languages (e.g. CYBIL), this means if the label exists in an outer
{    procedure, it is not found.  In this case, the user needs to specify the
{    PROCEDURE to further qualify the label.
{
{   FIND_STATEMENT_LABEL (home_spec, label_name, symbol, status)
{
{   home_spec : (INPUT)    The home specification as built by
{                           dup$build_home_spec
{
{   label_name : (INPUT)   The name of the desired label as it appears in the
{                           symbol table.
{
{   symbol : (OUTPUT)      Contains a pointer to the symbol table entry of the
{                           label, if found, and contains a NIL pointer, if not
{                           found.
{
{   status : (OUTPUT)      Contains the status of the request.

  PROCEDURE find_statement_label (
        home_spec: dut$home_specification;
        label_name: pmt$program_name;
    VAR symbol_entry: dut$symbol_entry;
    VAR status: ost$status );

    VAR
      first_symbol_number: llt$symbol_number,
      section_symbol_entry: dut$symbol_entry;

    status.normal := TRUE;
    symbol_entry.symbol := NIL;

{ Statement labels are described in the symbol table. See if it is there }

    IF home_spec.symbol_table_address = NIL THEN
      osp$set_status_abnormal (duc$symbolic_id, due$no_symbol_table_in_module,
              home_spec.module_item^.name, status);
      RETURN; {----->
    IFEND;

{ Make sure there is a procedure_entry }

    IF home_spec.procedure_entry.symbol = NIL THEN
      osp$set_status_abnormal (duc$symbolic_id, due$proc_must_be_specd,
            home_spec.module_item^.name, status);
      RETURN; {----->
    IFEND;

    first_symbol_number := home_spec.procedure_entry.symbol^.first_symbol_for_proc;
    IF first_symbol_number = 0 THEN
      osp$set_status_abnormal (duc$symbolic_id, due$label_not_found, label_name, status);
      RETURN; {----->  label not in the specified procedure }
    IFEND;
    dup$locate_symbol_for_number (home_spec.symbol_table_address, first_symbol_number,
                  symbol_entry, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

/label_search/
    REPEAT
      IF (symbol_entry.symbol^.symbol_name = label_name) AND
         (symbol_entry.symbol^.symbol_kind = llc$label_kind) THEN
        EXIT /label_search/;
      IFEND;
      IF ((home_spec.language IN nested_procedures) AND (symbol_entry.symbol^.end_of_chain = TRUE)) THEN
        symbol_entry.symbol := NIL;
        EXIT /label_search/;
      IFEND;
      dup$locate_next_symbol (home_spec.symbol_table_address, symbol_entry, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    UNTIL symbol_entry.symbol = NIL;

    IF symbol_entry.symbol = NIL THEN
      osp$set_status_abnormal (duc$symbolic_id, due$label_not_found, label_name, status);
    IFEND;

  PROCEND find_statement_label;
?? TITLE := 'find_tables_for_module_name', EJECT ??
{
{  This procedure searches the module address table to find a module of a
{  specified name.  It also returns the line table address and the symbol
{  table address.
{
{  FIND_TABLES_FOR_MODULE_NAME (NAME, MODULE, LINE, SYMBOL, STATUS)
{
{  NAME : (input)    is the name of the module for which the module
{                    address table is to be searched.
{
{  RING : (input)    The first named module residing in the specified ring will
{                    be found.  If none is found but ring_must_match is false,
{                    the first named module residing in any ring will be found.
{
{  RING_MUST_MATCH : If true, the module must reside in the ring specified.
{     (input)        If false, a module residing in the specified ring will be
{                    chosen before a module residing in any other ring.
{
{  MODULE : (output) is a pointer to the module address table
{
{  LINE : (output)   is a pointer to the line address table
{
{  SYMBOL : (output) is a pointer to the debug symbol table
{                    entry (if one is found).
{
{  STATUS : (output) is the status of the request. Possible value(s):
{                      due$named_module_not_found
{

  PROCEDURE find_tables_for_module_name (
        name: pmt$program_name;
        target_ring: ost$ring;
        ring_must_match: boolean;
    VAR module_item: ^dbt$module_address_table_item;
    VAR line_table_address: ^llt$line_address_table;
    VAR symbol_table_address: ^llt$debug_symbol_table;
    VAR status: ost$status);

    VAR table_index: integer,
        temp_name: pmt$program_name,
        case_sensitive_module_found: boolean,
        current_line_table: ^llt$line_address_table,
        current_symbol_table: ^llt$debug_symbol_table,
        saved_table_index: integer,
        saved_module_item: ^dbt$module_address_table_item;

    status.normal := TRUE;
    saved_module_item := NIL;
    module_item := p_first_module;
    case_sensitive_module_found := FALSE;
    line_table_address := NIL;
    symbol_table_address := NIL;
  /search_for_original_name/
    WHILE module_item <> NIL DO
      IF module_item^.debug_symbol_tables <> NIL THEN
        FOR table_index := 0 TO UPPERBOUND (module_item^.debug_symbol_tables^) DO
          current_symbol_table := module_item^.debug_symbol_tables ^[table_index];
          IF llc$language_is_case_sensitive IN current_symbol_table^.attributes THEN
            case_sensitive_module_found := TRUE;
          IFEND;
          IF (NOT(llc$language_is_case_sensitive IN current_symbol_table^.attributes) AND
              (i#compare_collated(current_symbol_table^.original_module_name,
                         name, osv$lower_to_upper) = 0)) OR
             ((llc$language_is_case_sensitive IN current_symbol_table^.attributes) AND
              (name = current_symbol_table^.original_module_name)) THEN
            IF module_item^.section_item[0].address.ring = target_ring THEN
              EXIT /search_for_original_name/;
            ELSE
              IF NOT ring_must_match AND (saved_module_item = NIL) THEN
                saved_module_item := module_item;
                saved_table_index := table_index;
              IFEND;
            IFEND;
          IFEND;
        FOREND;
      ELSEIF module_item^.line_address_tables <> NIL THEN
        FOR table_index := 0 TO UPPERBOUND (module_item^.line_address_tables^) DO
          current_line_table := module_item^.line_address_tables ^[table_index];
          IF i#compare_collated(current_line_table^.original_module_name, name, osv$lower_to_upper)
                                                            = 0 THEN
            IF module_item^.section_item[0].address.ring = target_ring THEN
              EXIT /search_for_original_name/;
            ELSE
              IF NOT ring_must_match AND (saved_module_item = NIL) THEN
                saved_module_item := module_item;
                saved_table_index := table_index;
              IFEND;
            IFEND;
          IFEND;
        FOREND;
      IFEND;
      module_item := module_item^.next_module;
    WHILEND /search_for_original_name/;

    IF (module_item = NIL) AND (saved_module_item <> NIL) THEN
      module_item := saved_module_item;
      table_index := saved_table_index;
    IFEND;

    IF (module_item = NIL) THEN
{ Search the module table itself.  Assume upper case except for C }
      #TRANSLATE (osv$lower_to_upper, name, temp_name); {case insensitive name}
      module_item := p_first_module;
  /search_module_name/
      WHILE module_item <> NIL DO
        IF (NOT(module_item^.language = llc$the_c_language) AND
            (temp_name = module_item^.name)) OR
           ((module_item^.language = llc$the_c_language) AND
            (name = module_item^.name)) THEN
          IF module_item^.section_item[0].address.ring = target_ring THEN
            EXIT  /search_module_name/;
          ELSE
            IF NOT ring_must_match AND (saved_module_item = NIL) THEN
              saved_module_item := module_item;
            IFEND;
          IFEND;
        IFEND;
        module_item := module_item^.next_module;
      WHILEND /search_module_name/;
      IF (module_item = NIL) THEN
         module_item := saved_module_item;
      IFEND;
      table_index := 0;
    IFEND;

    IF module_item = NIL THEN              { module not found
      IF case_sensitive_module_found THEN
{ If there were no case sensitive modules found, make the name upper case }
        temp_name := name;
      IFEND;
      osp$set_status_abnormal (duc$symbolic_id, due$named_module_not_found,
                   temp_name, status);
    ELSE  { module found }
      IF module_item^.line_address_tables <> NIL THEN
        line_table_address := module_item^.line_address_tables^[table_index];
      IFEND;
      IF module_item^.debug_symbol_tables <> NIL THEN
        symbol_table_address := module_item^.debug_symbol_tables^[table_index];
      IFEND;
    IFEND;

  PROCEND find_tables_for_module_name;
?? TITLE := 'find_trapped_stack_frame', EJECT ??

  PROCEDURE find_trapped_stack_frame (VAR trapped_sf: ^cell;
    VAR found: boolean);

    trapped_sf := trapped_save_area_address [1];
    found := (trapped_sf <> NIL);
  PROCEND find_trapped_stack_frame;
?? TITLE := 'get_parm_list_address', EJECT ??
{
{  This procedure returns the address of the parameter list.
{  It obtains the address of the parameter list either from register a4,
{  or from a location in storage (from stackframe for C180 Fortran).
{  To that end, it searches the symbol table for a var_kind entry and
{  label_kind entry, both of the name DBV$PARAMETER_LIST_POINTER.
{  If both entries exist and the p_register value has at least reached
{  the instruction sequence point marked by the label, the parameter
{  list address is obtained from the storage described by the var_kind
{  entry, else it is obtained from a4 of the belonging stack frame.
{
{  GET_PARM_LIST_ADDRESS (HOME_SPECIFICATION, PARAMETER_LIST_ADDRESS,
{      STATUS)
{
{  HOME_SPECIFICATION : (input)   describes the environment of the parameter
{                                 in terms of run time and source code.
{
{  PARAMETER_LIST_ADDRESS : (output)   returns the address of the parameter
{                                      list as a PVA.
{
{  STATUS :  (output)   is the status of the request. Possible values:
{

  PROCEDURE get_parm_list_address (home_spec: dut$home_specification;
    VAR parm_list_address: ost$pva;
    VAR status: ost$status);

{****
    VAR
      a1_current_stack_frame: ^cell,
      line_item_index: llt$line_address_table_size,
      line_table: ^llt$line_address_table,
      p_register: ost$pva,
      pva_ptr: ^ost$pva,
      section_item_index: llt$section_ordinal,
      stored_address_ptr: ^cell,
      stored_address_pva: ost$pva,
      symbol_entry: dut$symbol_entry,
      var_kind_symbol: ^llt$symbol_table_item;

    status.normal := TRUE;
    dup$locate_symbol_for_number (home_spec.symbol_table_address,
        home_spec.procedure_entry.symbol^.first_symbol_for_proc, symbol_entry, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

{ Search symbol table for var_kind entry for internal name duv$parameter_list_pointer
{ starting with symbol_entry found for first_symbol_for_proc.

    var_kind_symbol := NIL;
  /symbol_table_search/
    WHILE TRUE DO
      IF (i#compare_collated (symbol_entry.symbol^.symbol_name, 'duv$parameter_list_pointer',
        osv$lower_to_upper) = 0) AND (symbol_entry.symbol^.symbol_kind = llc$var_kind) THEN
        var_kind_symbol := symbol_entry.symbol;
        EXIT /symbol_table_search/;
      IFEND;

{ Note: In Fortran, the end_of_chain field is not used to mark the last
{ symbol table item of programs, subprograms or functions. The field is
{ set to TRUE in all items, except the items associated with parameters,
{ in which end_of_chain = TRUE is used to mark the item of the last
{ parameter. Normally , the end_of_chain flag is used, and is the only way,
{ to mark the last item of the chain in the scope. Since Fortran does not yet
{ conform to this rule, 'IF symbol_entry.symbol^.end_of_chain THEN' has temporarily
{ been replaced by the following IF statement; The replacement does no harm as long as
{ get_parm_list_address is used only for Fortran.

      IF symbol_entry.table_entry_index = home_spec.symbol_table_address^.number_of_items THEN
        EXIT /symbol_table_search/;
      IFEND;
      symbol_entry.table_entry_index := symbol_entry.table_entry_index + 1;
      symbol_entry.symbol := ^home_spec.symbol_table_address^.
        item [symbol_entry.table_entry_index];
    WHILEND /symbol_table_search/;

{ Determine if the parameter list pointer is to be taken from a4 or storage, and get it from there.

    IF var_kind_symbol <> NIL THEN
      p_register := home_spec.current_stack_frame^.minimum_save_area.p_register.pva;
      find_section_for_pva (home_spec.module_item, p_register, section_item_index, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      find_line_number_for_pva (home_spec.module_item, section_item_index, p_register,
            line_table, line_item_index, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      IF NOT (llc$prolog_code IN line_table^.item [line_item_index].line_attributes) THEN
        IF var_kind_symbol^.var_base = llc$stack_frame_base THEN
          a1_current_stack_frame := home_spec.current_stack_frame^.minimum_save_area.a1_current_stack_frame;
          stored_address_pva.ring := #RING (a1_current_stack_frame);
          stored_address_pva.seg := #SEGMENT (a1_current_stack_frame);
          stored_address_pva.offset := #OFFSET (a1_current_stack_frame);
          stored_address_pva.offset := stored_address_pva.offset + var_kind_symbol^.var_offset;
        ELSE
        IFEND;
        stored_address_ptr := #ADDRESS (stored_address_pva.ring, stored_address_pva.seg,
          stored_address_pva.offset);
        pva_ptr := stored_address_ptr;
        parm_list_address := pva_ptr^;
        RETURN; {----->
      IFEND;
    IFEND;
    parm_list_address.ring := #RING (home_spec.current_stack_frame^.a4);
    parm_list_address.seg := #SEGMENT (home_spec.current_stack_frame^.a4);
    parm_list_address.offset := #OFFSET (home_spec.current_stack_frame^.a4);
  PROCEND get_parm_list_address;
?? TITLE := 'initialize_debug_directory', EJECT ??

  PROCEDURE initialize_debug_directory (VAR status: ost$status);

    VAR
      segment: amt$segment_pointer;

    IF (p_debug_directory = NIL) THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, segment, status);

      IF status.normal THEN
        p_debug_directory := segment.sequence_pointer;
        RESET p_debug_directory;
        p_local_modules := dbp$module_table_address ();
        p_first_module := p_local_modules;
      IFEND;
    IFEND;
  PROCEND initialize_debug_directory;
?? TITLE := 'locate_line_number_entry', EJECT ??
{
{  This procedure locates the line address table entry corresponding
{  to a specified source line number.
{
{  LOCATE_LINE_NUMBER_ENTRY (MODULE, LINE, ENTRY, STATUS)
{
{  MODULE (input) :  is the address of the specific module table
{                    in which the line entry is to be found.
{
{  LINE (input) :    is the source line number to be looked for in
{                    the line address table.
{
{  STATEMENT (inp) : is the statement associated with the source
{                    line number.
{
{  ENTRY (output) :  is the ordinal in the line address table
{                    of the entry corresponding to the source
{                    line number (if an entry is found).
{
{  STATUS (output) : is the status of the request. Possible value(s):
{                      due$no_line_numbers_in_module
{                      due$line_number_not_found
{                      due$statement_number_not_found

  PROCEDURE locate_line_number_entry (line_table_address: ^llt$line_address_table;
    line_number: llt$source_line_number;
    statement_number: integer;
    VAR line_table_item: llt$line_address_item;
    VAR status: ost$status);

    VAR
      line_table_index: integer,
      current_line_table: ^llt$line_address_table,
      line_item_index: llt$line_address_table_size,
      line_item_indexx: llt$line_address_table_size,
      string1: string(6),
      temp_number: integer,
      statement_hold: integer,
      save_line_number: integer,
      save_line_number1: integer;

    status.normal := TRUE;
{
{  check that module actually has a line address table
{
    IF line_table_address = NIL THEN
      osp$set_status_abnormal (duc$symbolic_id, due$no_line_numbers_in_module,
            osc$null_name, status);
      RETURN; { ----->
    IFEND;
{
{  now search the line address table
{
      /loop1/
      FOR line_item_index := 1 TO UPPERBOUND (line_table_address^.item) DO
        IF line_number = line_table_address^.item [line_item_index].line_number THEN
          save_line_number := line_table_address^.item [line_item_index].line_number;
          statement_hold := statement_number;
          IF llc$prolog_code IN line_table_address^.item [line_item_index].line_attributes THEN
            line_item_indexx := line_item_index;
            line_item_indexx := line_item_indexx + statement_hold;
          ELSE
            statement_hold := statement_hold - 1;
            line_item_indexx := line_item_index;
            line_item_indexx := line_item_indexx + statement_hold;
          IFEND;

          IF save_line_number <> line_table_address^.item [line_item_indexx].line_number THEN
            STRINGREP (string1, line_table_index, statement_number);
            osp$set_status_abnormal (duc$symbolic_id, due$statement_number_not_found,
              string1 (1, line_table_index), status);
            RETURN; {----->
          IFEND;

          IF llc$prolog_code IN line_table_address^.item [line_item_indexx].line_attributes THEN
            CYCLE /loop1/;
          ELSE
            line_table_item := line_table_address^.item [line_item_indexx];
            RETURN; {----->
          IFEND;
        IFEND;
      FOREND /loop1/;
{
{  if we get here, the required line number was not found in the
{  line address table.
{
      STRINGREP (string1, line_table_index, line_number);
    osp$set_status_abnormal (duc$symbolic_id, due$line_number_not_found, string1(1,line_table_index),
    status);
  PROCEND locate_line_number_entry;
?? TITLE := 'locate_named_symbol', EJECT ??

  PROCEDURE locate_named_symbol (symbol_name: pmt$program_name;
        home_spec: dut$home_specification;
    VAR symbol_entry: dut$symbol_entry;
    VAR status: ost$status);

    VAR
      current_proc: dut$symbol_entry,
      first_symbol_number: llt$symbol_number,
      index: llt$symbol_number,
      p_symbol_list: ^array [1 .. *] of llt$symbol_table_item,
      parent_symbol_number: llt$symbol_number,
      proc_start: ost$pva,
      module_level_searched: boolean,
      upper: llt$symbol_number;

    current_proc := home_spec.procedure_entry;
    module_level_searched := FALSE;

    REPEAT

/search_lexical_level/
      BEGIN
        IF current_proc.symbol <> NIL THEN
          IF current_proc.symbol^.symbol_kind = llc$proc_kind THEN
            first_symbol_number := current_proc.symbol^.first_symbol_for_proc;
          ELSE { Must be a WITH block }
            first_symbol_number := current_proc.symbol^.with_first_symbol;
          IFEND;
          IF first_symbol_number = 0 THEN
            EXIT /search_lexical_level/; {no symbols at this level}
          IFEND;
          dup$locate_symbol_for_number (home_spec.symbol_table_address,
                first_symbol_number, symbol_entry, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          module_level_searched := TRUE;
          dup$locate_symbol_for_number (home_spec.symbol_table_address,
                home_spec.symbol_table_address^.first_symbol_for_module,
                symbol_entry, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        WHILE TRUE DO
          IF (symbol_entry.symbol^.symbol_name = symbol_name) THEN
            RETURN;
          ELSE
{ Get the next symbol in the chain }
            IF symbol_entry.symbol^.end_of_chain THEN
              EXIT /search_lexical_level/;
            IFEND;
            dup$locate_next_symbol (home_spec.symbol_table_address,
                  symbol_entry, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        WHILEND;
      END /search_lexical_level/;

{ Check the next outer level of procedure nesting if there is one }

      IF current_proc.symbol <> NIL THEN
        IF current_proc.symbol^.symbol_kind = llc$proc_kind THEN
          parent_symbol_number := current_proc.symbol^.proc_parent;
        ELSE { Must be WITH block }
          parent_symbol_number := current_proc.symbol^.with_parent;
        IFEND;
        IF parent_symbol_number = 0 THEN
          current_proc.symbol := NIL;
        ELSE
          dup$locate_symbol_for_number (home_spec.symbol_table_address,
                parent_symbol_number, current_proc, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    UNTIL module_level_searched;

    p_symbol_list := ^home_spec.symbol_table_address^.item;
    upper := UPPERBOUND (p_symbol_list^);
    index := 1;
    WHILE (index <= upper) AND (p_symbol_list^ [index].symbol_name <> symbol_name) DO
      index := index + 1;
    WHILEND;
    IF (index <= upper) THEN
      symbol_entry.table_entry_index := index;
      symbol_entry.symbol := ^p_symbol_list^ [index];
    ELSE
      osp$set_status_abnormal (duc$symbolic_id, due$variable_not_found, symbol_name, status);
    IFEND;
  PROCEND locate_named_symbol;
?? TITLE := 'object_record_size', EJECT ??

  FUNCTION object_record_size (kind: llt$object_record_kind;
        fixer: 0 .. 7fffffff(16)): integer;

    CASE kind OF
    = llc$libraries =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$libraries: [1 .. fixer]);
      IFEND;

    = llc$section_definition, llc$unallocated_common_block =
      object_record_size := #SIZE (llt$section_definition);

    = llc$allotted_section_definition =
      object_record_size := #SIZE (llt$section_definition);

    = llc$segment_definition =
      object_record_size := #SIZE (llt$segment_definition);

    = llc$allotted_segment_definition =
      object_record_size := #SIZE (llt$segment_definition);

    = llc$obsolete_segment_definition =
      object_record_size := #SIZE (llt$obsolete_segment_definition);

    = llc$obsolete_allotted_seg_def =
      object_record_size := #SIZE (llt$obsolete_segment_definition);

    = llc$application_identifier =
      object_record_size := #SIZE (llt$application_identifier);

    = llc$transfer_symbol =
      object_record_size := #SIZE (llt$transfer_symbol);

    = llc$entry_definition =
      object_record_size := #SIZE (llt$entry_definition);

    = llc$deferred_entry_points =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$deferred_entry_points: [1 .. fixer]);
      IFEND;

    = llc$deferred_common_blocks =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$deferred_common_blocks: [1 .. fixer]);
      IFEND;

    = llc$external_linkage =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$external_linkage: [1 .. fixer]);
      IFEND;

    = llc$address_formulation =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$address_formulation: [1 .. fixer]);
      IFEND;

    = llc$text =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$text: [1 .. fixer]);
      IFEND;

    = llc$replication =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$replication: [1 .. fixer]);
      IFEND;

    = llc$bit_string_insertion =
      object_record_size := #SIZE (llt$bit_string_insertion);

    = llc$obsolete_formal_parameters =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$obsolete_formal_parameters: [[REP fixer  OF cell]]);
      IFEND;

    = llc$formal_parameters =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$formal_parameters: [[REP fixer  OF cell]]);
      IFEND;

    = llc$form_definition =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$form_definition: [[REP fixer  OF cell]]);
      IFEND;

    = llc$actual_parameters =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$actual_parameters: [[REP fixer  OF cell]]);
      IFEND;

    = llc$relocation =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$relocation: [1 .. fixer]);
      IFEND;

    = llc$binding_template =
      object_record_size := #SIZE (llt$binding_template);

    = llc$ppu_absolute =
      object_record_size := #SIZE (llt$ppu_absolute: [0 .. fixer]);

    = llc$identification =
      object_record_size := #SIZE (llt$identification);

    = llc$obsolete_line_table =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$obsolete_line_address_table: [1 .. fixer]);
      IFEND;

    = llc$68000_absolute =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$68000_absolute: [[REP fixer  OF cell]]);
      IFEND;

    = llc$line_table =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$line_address_table: [1 .. fixer]);
      IFEND;

    = llc$cybil_symbol_table_fragment =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$debug_table_fragment: [[REP fixer  OF cell]]);
      IFEND;

    = llc$symbol_table =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$symbol_table: [[REP fixer  OF cell]]);
      IFEND;

    = llc$supplemental_debug_tables =
      IF (fixer < 1) THEN
        object_record_size := -1;
      ELSE
        object_record_size := #SIZE (llt$supplemental_debug_tables: [[REP fixer  OF cell]]);
      IFEND;

    ELSE
      object_record_size := -1;
    CASEND;
  FUNCEND object_record_size;
?? TITLE := 'open_debug_file', EJECT ??

  PROCEDURE open_debug_file (debug_file: fst$file_reference;
    VAR file_contents: ost$name;
    VAR file_structure: ost$name;
    VAR p_debug_file: ^SEQ (*);
    VAR status: ost$status);

    VAR
      attachment: [STATIC] array [1 .. 2] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$read]],
            [fsc$determine_from_access_modes]], [fsc$create_file, FALSE]],
      contains_data: boolean,
      existing_file: boolean,
      file_id: amt$file_identifier,
      get_attributes: [STATIC] array [1 .. 2] of amt$get_item := [[ * , amc$file_contents, * ],
            [ * , amc$file_structure, * ]],
      local_file: boolean,
      local_status: ost$status,
      segment: amt$segment_pointer;

    amp$get_file_attributes (debug_file, get_attributes, local_file, existing_file, contains_data, status);

    IF status.normal THEN
      file_contents := get_attributes [1].file_contents;
      file_structure := get_attributes [2].file_structure;

      IF contains_data THEN
        fsp$open_file (debug_file, amc$segment, ^attachment, NIL, NIL, NIL, NIL, file_id, status);
      ELSE
        osp$set_status_abnormal ('OC', oce$e_missing_or_empty_file, debug_file, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      amp$get_segment_pointer (file_id, amc$sequence_pointer, segment, status);
      IF status.normal THEN
        p_debug_file := segment.sequence_pointer;
      ELSE
        fsp$close_file (file_id, local_status);
      IFEND;
    IFEND;
  PROCEND open_debug_file;
?? TITLE := 'process_debug_file', EJECT ??

  PROCEDURE process_debug_file (file_name: fst$file_reference;
        p_debug_file: ^SEQ (*);
    VAR status: ost$status);

    VAR
      p_descriptor: ^llt$object_text_descriptor,
      p_file: ^SEQ (*);

    status.normal := TRUE;
    p_file := p_debug_file;
    NEXT p_descriptor IN p_file;

    WHILE status.normal AND (p_descriptor <> NIL) DO
      RESET p_file TO p_descriptor;
      process_module_debug_tables (file_name, p_file, status);
      NEXT p_descriptor IN p_file;
    WHILEND;
  PROCEND process_debug_file;
?? TITLE := 'process_debug_library', EJECT ??

  PROCEDURE process_debug_library (library_name: fst$file_reference;
        p_debug_library: ^SEQ (*);
    VAR status: ost$status);

    VAR
      p_library: ^SEQ (*),
      p_library_header: ^llt$object_library_header,
      p_old_library_header: ^llt$object_library_header_v1_0,
      p_dictionaries: ^llt$object_library_dictionaries,
      p_module_dictionary: ^llt$module_dictionary,
      dictionary: 0 .. llc$max_dictionaries_on_library,
      module_count: 0 .. llc$max_modules_in_library,
      module_index: 0 .. llc$max_modules_in_library,
      p_module_header: ^llt$load_module_header,
      p_descriptor: ^llt$object_text_descriptor;


    p_library := p_debug_library;
    RESET p_library;
    NEXT p_library_header IN p_library;

    IF (p_library_header = NIL) THEN
      set_loader_error (lle$library_header_missing, library_name, '', 0, FALSE, status);
      RETURN;
    IFEND;

    IF (p_library_header^.version = llc$object_library_version) THEN
      NEXT p_dictionaries: [1 .. p_library_header^.number_of_dictionaries] IN p_library;
      IF (p_dictionaries = NIL) THEN
        set_loader_error (lle$library_header_missing, library_name, '', 0, FALSE, status);
        RETURN;
      IFEND;

      module_count := 0;
      for dictionary := LOWERBOUND (p_dictionaries^) TO UPPERBOUND (p_dictionaries^) DO
        IF (p_dictionaries^ [dictionary].kind = llc$module_dictionary) THEN
          p_module_dictionary := #PTR (p_dictionaries^ [dictionary].module_dictionary, p_library^);
          module_count := UPPERBOUND (p_module_dictionary^);
        IFEND;
      FOREND;
    ELSEIF (p_library_header^.version = 'V1.0') THEN
      RESET p_library;
      NEXT p_old_library_header IN p_library;
      IF (p_old_library_header = NIL) THEN
        set_loader_error (lle$library_header_missing, library_name, '', 0, FALSE, status);
        RETURN;
      IFEND;

      p_module_dictionary := #PTR (p_old_library_header^.module_dictionary, p_library^);
      module_count := p_old_library_header^.number_of_modules;
    ELSE
      set_loader_error (lle$wrong_library_version, library_name, '', 0, FALSE, status);
      RETURN;
    IFEND;

    IF (module_count = 0) THEN
      set_loader_error (lle$empty_module_dictionary, library_name, '', 0, FALSE, status);
      RETURN;
    ELSEIF (p_module_dictionary = NIL) THEN
      set_loader_error (lle$bad_module_dictionary_ptr, library_name, '', 0, FALSE, status);
      RETURN;
    IFEND;

    FOR module_index := 1 to module_count DO
      IF (p_module_dictionary^ [module_index].kind = llc$load_module) THEN
        p_module_header := #PTR (p_module_dictionary^ [module_index].module_header, p_library^);
        IF (p_module_header = NIL) THEN
          set_loader_error (lle$bad_module_header_ptr, library_name, 'module', module_index, FALSE, status);
          RETURN;
        IFEND;

        p_descriptor := #PTR (p_module_header^.interpretive_element, p_library^);
        IF (p_descriptor = NIL) THEN
          set_loader_error (lle$bad_interpretive_elem_ptr, library_name, '', #offset (p_module_header), TRUE,
                status);
          RETURN;
        IFEND;

        RESET p_library TO p_descriptor;
        process_module_debug_tables (library_name, p_library, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;
  PROCEND process_debug_library;
?? TITLE := 'process_debug_tables', EJECT ??

  PROCEDURE process_debug_tables (
        p_debug_table_list: ^clt$data_value;
    VAR status: ost$status);

    VAR
      content: ost$name,
      first_linker_table: boolean,
      p_debug_file: ^SEQ (*),
      p_element: ^clt$data_value,
      p_list: ^clt$data_value,
      structure: ost$name;

    initialize_debug_directory (status);

    p_list := p_debug_table_list;
    first_linker_table := TRUE;

    WHILE status.normal AND (p_list <> NIL) DO
      p_element := p_list^.element_value;
      IF (p_element^.kind = clc$file) THEN
        open_debug_file (p_element^.file_value^, content, structure, p_debug_file, status);
        IF status.normal THEN
          IF (content = amc$object) THEN
            IF (structure = amc$library) THEN
              process_debug_library (p_element^.file_value^, p_debug_file, status);
            ELSE
              process_debug_file (p_element^.file_value^, p_debug_file, status);
            IFEND;
          ELSE
            IF first_linker_table THEN
              ocp$close_linker_debug_table (status);
              first_linker_table := FALSE;
            IFEND;
            ocp$define_linker_debug_table (p_debug_file, status);
          IFEND;
        IFEND;
      ELSE
        IF first_linker_table THEN
          ocp$close_linker_debug_table (status);
          first_linker_table := FALSE;
        IFEND;
        ocp$open_running_debug_table (status);
      IFEND;
      p_list := p_list^.link;
    WHILEND;

    IF status.normal THEN
      update_section_info;
    IFEND;
  PROCEND process_debug_tables;
?? TITLE := 'process_module_debug_tables', EJECT ??

  PROCEDURE process_module_debug_tables (file_name: fst$file_reference;
    VAR p_file: ^SEQ (*);
    VAR status: ost$status);

    TYPE
      line = record
        p_next_line: ^line,
        p_line_table: ^llt$line_address_table,
      recend,

      symbol = record
        p_next_symbol: ^symbol,
        p_symbol_table: ^llt$debug_symbol_table,
      recend;

    VAR
      kind: llt$object_record_kind,
      module_name: pmt$program_name,
      greatest_section: llt$section_ordinal,
      line_count: integer,
      p_identification: ^llt$identification,
      p_module: ^dbt$module_address_table_item,
      p_descriptor: ^llt$object_text_descriptor,
      symbol_count: integer,
      p_first_line: ^line,
      p_first_symbol: ^symbol,
      p_current_line: ^line,
      p_current_symbol: ^symbol,
      p_line_table: ^llt$line_address_table,
      p_line_tables: ^array [0 .. *] of ^llt$line_address_table,
      p_symbol_table: ^llt$debug_symbol_table,
      p_symbol_tables: ^array [0 .. *] of ^llt$debug_symbol_table;


    status.normal := TRUE;
    line_count := 0;
    p_first_line := NIL;
    symbol_count := 0;
    p_first_symbol := NIL;

    NEXT p_descriptor IN p_file;
    IF (p_descriptor = NIL) OR (p_descriptor^.kind <> llc$identification) THEN
      set_loader_error (lle$identification_expected, file_name, '', #offset (p_descriptor), TRUE, status);
      RETURN;
    IFEND;
    kind := llc$identification;

    NEXT p_identification IN p_file;
    IF (p_identification = NIL) THEN
      set_loader_error (lle$premature_eof, file_name, '', 0, FALSE, status);
      RETURN;
    ELSE
      greatest_section := p_identification^.greatest_section_ordinal;
      module_name := p_identification^.name;
      create_module_item (module_name, greatest_section, p_module, status);
      IF status.normal THEN
        p_module^.next_module := p_first_module;
        p_first_module := p_module;
      IFEND;
    IFEND;

    WHILE status.normal AND (kind <> llc$transfer_symbol) DO
      NEXT p_descriptor IN p_file;
      IF (p_descriptor = NIL) THEN
        set_loader_error (lle$premature_eof, file_name, '', 0, FALSE, status);
      ELSE
        kind := p_descriptor^.kind;
        CASE kind OF

        = llc$line_table =
          NEXT p_line_table: [1 .. p_descriptor^.number_of_line_items] IN p_file;
          IF (p_line_table = NIL) THEN
            set_loader_error (lle$premature_eof, file_name, '', 0, FALSE, status);
          ELSE
            PUSH p_current_line;
            line_count := line_count + 1;
            p_current_line^.p_next_line := p_first_line;
            p_current_line^.p_line_table := p_line_table;
            p_first_line := p_current_line;
          IFEND;

        = llc$symbol_table =
          process_symbol_record (module_name, p_descriptor^.sequence_length, file_name, p_file,
                p_symbol_table, status);
          IF status.normal THEN
            PUSH p_current_symbol;
            symbol_count := symbol_count + 1;
            p_current_symbol^.p_next_symbol := p_first_symbol;
            p_current_symbol^.p_symbol_table := p_symbol_table;
            p_first_symbol := p_current_symbol;
          IFEND;

        ELSE
          skip_object_record (p_descriptor, file_name, p_file, status);
        CASEND;
      IFEND;
    WHILEND;

    IF status.normal AND (line_count > 0) THEN
      NEXT p_line_tables: [0 .. line_count - 1] IN p_debug_directory;
      p_current_line := p_first_line;
      WHILE (line_count > 0) DO
        line_count := line_count - 1;
        p_line_tables^ [line_count] := p_current_line^.p_line_table;
        p_current_line := p_current_line^.p_next_line;
      WHILEND;
      p_module^.line_address_tables := p_line_tables;
    IFEND;

    IF status.normal AND (symbol_count > 0) THEN
      NEXT p_symbol_tables: [0 .. symbol_count - 1] IN p_debug_directory;
      p_current_symbol := p_first_symbol;
      WHILE (symbol_count > 0) DO
        symbol_count := symbol_count - 1;
        p_symbol_tables^ [symbol_count] := p_current_symbol^.p_symbol_table;
        p_current_symbol := p_current_symbol^.p_next_symbol;
      WHILEND;
      p_module^.debug_symbol_tables := p_symbol_tables;
    IFEND;
  PROCEND process_module_debug_tables;
?? TITLE := 'process_symbol_record', EJECT ??

  PROCEDURE process_symbol_record (module_name: pmt$program_name;
        record_length: llt$section_length;
        object_file_name: fst$file_reference;
    VAR p_object_file: ^SEQ (*);
    VAR p_symbol_table: ^llt$debug_symbol_table;
    VAR status: ost$status);

    VAR
      p_symbol_record: ^llt$symbol_table,
      p_symbol_text: ^SEQ (*);

    status.normal := TRUE;
    NEXT p_symbol_record: [[REP record_length OF cell]] IN p_object_file;
    IF (p_symbol_record = NIL) THEN
      set_loader_error (lle$premature_eof, object_file_name, '', 0, FALSE, status);
    ELSE
      p_symbol_text := ^p_symbol_record^.text;
      RESET p_symbol_text;
      NEXT p_symbol_table: [1 .. 1] IN p_symbol_text;
      IF (p_symbol_table <> NIL) THEN
        RESET p_symbol_text;
        NEXT p_symbol_table: [1 .. p_symbol_table^.number_of_items] IN p_symbol_text;
      IFEND;
      IF (p_symbol_table = NIL) THEN
        osp$set_status_abnormal ('PM', pme$bad_debug_symbol_table, module_name, status);
      IFEND;
    IFEND;
  PROCEND process_symbol_record;
?? TITLE := 'set_loader_error', EJECT ??

  PROCEDURE set_loader_error (error_condition: ost$status_condition;
        text_1: string (*);
        text_2: string (*);
        number: integer;
        hex_base: boolean;
    VAR status: ost$status);

    osp$set_status_abnormal ('LL', error_condition, text_1, status);

    IF (text_2 <> '') THEN
      osp$append_status_parameter (osc$status_parameter_delimiter, text_2, status);
    IFEND;

    IF hex_base THEN
      osp$append_status_integer (osc$status_parameter_delimiter, number, 16, TRUE, status);
    ELSE
      osp$append_status_integer (osc$status_parameter_delimiter, number, 10, FALSE, status);
    IFEND;
  PROCEND set_loader_error;
?? TITLE := 'skip_object_record', EJECT ??

  PROCEDURE skip_object_record (p_descriptor: ^llt$object_text_descriptor;
        object_file_name: fst$file_reference;
    VAR p_object_file: ^SEQ (*);
    VAR status:ost$status);

    VAR
      fixer: 0 .. 37777777(16),
      record_size: integer,
      p_sequence: ^SEQ (*);

    status.normal := TRUE;

    CASE p_descriptor^.kind OF

    = llc$identification, llc$section_definition, llc$bit_string_insertion, llc$entry_definition,
            llc$binding_template, llc$transfer_symbol, llc$obsolete_segment_definition,
            llc$unallocated_common_block, llc$application_identifier, llc$segment_definition =
      fixer := 0;

    = llc$libraries =
      fixer := p_descriptor^.number_of_libraries;

    = llc$text, llc$replication =
      fixer := p_descriptor^.number_of_bytes;

    = llc$relocation =
      fixer := p_descriptor^.number_of_rel_items;

    = llc$address_formulation =
      fixer := p_descriptor^.number_of_adr_items;

    = llc$external_linkage =
      fixer := p_descriptor^.number_of_ext_items;

    = llc$obsolete_formal_parameters, llc$actual_parameters, llc$cybil_symbol_table_fragment,
            llc$symbol_table, llc$formal_parameters, llc$form_definition, llc$supplemental_debug_tables =
      fixer := p_descriptor^.sequence_length;

    = llc$ppu_absolute =
      fixer := p_descriptor^.number_of_words;

    = llc$allotted_section_definition, llc$allotted_segment_definition, llc$obsolete_allotted_seg_def =
      fixer := 0;

    = llc$68000_absolute =
      fixer := p_descriptor^.number_of_68000_bytes;

    = llc$line_table, llc$obsolete_line_table =
      fixer := p_descriptor^.number_of_line_items;

    = llc$deferred_entry_points =
      fixer := p_descriptor^.number_of_entry_points;

    = llc$deferred_common_blocks =
      fixer := p_descriptor^.number_of_common_blocks;
    ELSE
      set_loader_error (lle$unknown_record_kind, '', '', #offset (p_descriptor), TRUE, status);
    CASEND;

    IF status.normal THEN
      record_size := object_record_size (p_descriptor^.kind, fixer);
      IF (record_size < 0) THEN
        set_loader_error (lle$bad_fixer_value, '', '', #offset (p_descriptor), TRUE, status);
      ELSEIF (record_size > 0) THEN
        NEXT p_sequence: [[REP record_size of cell]] IN p_object_file;
        IF (p_sequence = NIL) THEN
          set_loader_error (lle$premature_eof, object_file_name, '', 0, FALSE, status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND skip_object_record;
?? TITLE := 'update_section_info', EJECT ??

  PROCEDURE update_section_info;

    VAR
      p_current_module: ^dbt$module_address_table_item,
      p_linker_module: ^pmt$module_item,
      found: boolean,
      highest_section: llt$section_ordinal,
      section_index: llt$section_ordinal,
      p_section: ^dbt$section_item,
      p_linker_section: ^pmt$section_item,
      status: ost$status;

    status.normal := TRUE;
    p_current_module := p_first_module;

    WHILE (p_current_module <> p_local_modules) AND status.normal DO
      ocp$find_debug_module_item (p_current_module^.name, 1, found, p_linker_module, status);
      IF status.normal AND found THEN
        highest_section := UPPERBOUND (p_current_module^.section_item);
        IF (highest_section > UPPERBOUND (p_linker_module^.section_item)) THEN
          highest_section := UPPERBOUND (p_linker_module^.section_item);
        IFEND;
        IF TRUE THEN;
          FOR section_index := 0 TO highest_section DO
            p_section := ^p_current_module^.section_item [section_index];
            p_linker_section := ^p_linker_module^.section_item [section_index];
            p_section^.kind := p_linker_section^.kind;
            p_section^.section_ordinal := p_linker_section^.section_ordinal;
            p_section^.address.ring := UPPERVALUE (ost$ring);
            p_section^.address.seg := p_linker_section^.address DIV 100000000(16);
            p_section^.address.offset := p_linker_section^.address MOD 100000000(16);
            p_section^.length := p_linker_section^.length;
            p_section^.segment_access_control := p_linker_section^.segment_access_control;
            p_section^.ring.r1 := p_linker_section^.ring.r1;
            p_section^.ring.r2 := p_linker_section^.ring.r2;
            p_section^.ring.r3 := p_linker_section^.ring.r3;
            p_section^.key_lock := p_linker_section^.key_lock;
            p_section^.name := p_linker_section^.name;
          FOREND;
        IFEND;
      IFEND;
      p_current_module := p_current_module^.next_module;
    WHILEND;
  PROCEND update_section_info;
?? TITLE := 'verify_procedure_exists', EJECT ??
{
{  This procedure searches the module table for a
{  procedure of a specified name.  Unlike other 'find_procedure'
{  routines, this one searches the entire module table, and returns
{  the module table if the specified proc exists somewhere.
{
{  VERIFY_PROCEDURE_EXISTS (PROCEDURE_NAME, MODULE_ITEM, STATUS)
{
{  PROCEDURE_NAME : (input)  is the procedure name we are looking for
{
{  MODULE_ITEM: (output)     is the address of the module table for the
{                              procedure and is only valid if status is
{                              normal
{
{  STATUS : (output)         is the status.  Possible values:
{                              due$invalid_procedure
{

  PROCEDURE verify_procedure_exists (
    VAR procedure_name: pmt$program_name;
    VAR module_item: ^dbt$module_address_table_item;
    VAR status: ost$status);

    VAR
      section_item: dbt$section_item,
      section_item_index: integer,
      symbol_index: llt$symbol_number,
      symbol_table_index: integer,
      symbol_table_ptr: ^llt$debug_symbol_table;

    status.normal := TRUE;
    module_item := p_first_module;   { pointer to first module table

    WHILE module_item <> NIL DO
      IF module_item^.name(1,4) <> 'DBM$' THEN   { Ignore DEBUG modules }
        IF module_item^.debug_symbol_tables <> NIL THEN
          FOR symbol_table_index := 0 TO UPPERBOUND(module_item^.debug_symbol_tables^) DO
            symbol_table_ptr := module_item^.debug_symbol_tables^[symbol_table_index];
            FOR symbol_index := 1 TO symbol_table_ptr^.number_of_items DO
              IF (symbol_table_ptr^.item[symbol_index].symbol_kind = llc$proc_kind) AND
                (symbol_table_ptr^.item[symbol_index].proc_length <> 0) THEN
                IF llc$language_is_case_sensitive IN symbol_table_ptr^.attributes THEN
                  IF symbol_table_ptr^.item[symbol_index].symbol_name = procedure_name THEN
                    RETURN; {----->
                  IFEND;
                ELSE { Language not case sensitive }
                  IF (i#compare_collated(symbol_table_ptr^.item[symbol_index].symbol_name,
                             procedure_name, osv$lower_to_upper) = 0) THEN
                    #TRANSLATE (osv$lower_to_upper, procedure_name, procedure_name);
                    RETURN; {----->
                  IFEND;
                IFEND;  { If language is case sensitive }
              IFEND;  { If this is a proc_kind symbol }
            FOREND;
          FOREND;
        ELSE { No symbol tables - check module table code sections }
          IF module_item^.language <> llc$object_library_generator THEN
            FOR section_item_index := 0 TO UPPERBOUND(module_item^.section_item) DO
              section_item := module_item^.section_item[section_item_index];
              IF (section_item.kind = llc$code_section) AND
                 (i#compare_collated(section_item.name, procedure_name, osv$lower_to_upper) = 0) THEN
                #TRANSLATE (osv$lower_to_upper, procedure_name, procedure_name);
                RETURN; {----->
              IFEND;
            FOREND;
          IFEND;  { If not a bound module }
        IFEND; { If symbol tables exist }
      IFEND; { If not a DEBUG module }
      module_item := module_item^.next_module;
    WHILEND;

{ Did not find procedure in entire module table - return error }

    osp$set_status_abnormal (duc$symbolic_id, due$invalid_procedure,
                   procedure_name, status);
  PROCEND verify_procedure_exists;
?? OLDTITLE ??
MODEND dum$debug_table_interfaces;
*DECK DECK=DUM$DECODE_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Decode Command' ??
MODULE dum$decode_command;

{ PURPOSE:
{   This module contains the code for the decode command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc duc$dump_analyzer_constants
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$access_real_memory
*copyc dup$copy_virtual_memory_pva
*copyc dup$copy_virtual_memory_sva
*copyc dup$evaluate_parameters
*copyc dup$new_page_procedure
*copyc dup$retrieve_exchange_package
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    t$instruction_designation = (c$id_non_bdp, c$id_bdp_one, c$id_bdp_two),

    t$instruction_entry = RECORD
      instruction: string (24),
      format: t$instruction_format,
      designation: t$instruction_designation,
    RECEND,

    t$instruction_format = (c$it_unimplemented, c$it_jk, c$it_jkid, c$it_jkq);
?? EJECT ??
VAR
  v$instruction_list: ARRAY [0 .. 0ff(16)] OF t$instruction_entry :=
   {00} [['HALT                    ', c$it_jk,            c$id_non_bdp],
   {01}  ['SYNC                    ', c$it_jk,            c$id_non_bdp],
   {02}  ['EXCHANGE                ', c$it_jk,            c$id_non_bdp],
   {03}  ['INTRUPT    Xk           ', c$it_jk,            c$id_non_bdp],
   {04}  ['RETURN                  ', c$it_jk,            c$id_non_bdp],
   {05}  ['PURGE      Xj,k         ', c$it_jk,            c$id_non_bdp],
   {06}  ['POP                     ', c$it_jk,            c$id_non_bdp],
   {07}  ['PSFSA      k            ', c$it_jk,            c$id_non_bdp],
   {08}  ['CPYTX      Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {09}  ['CPYAA      Ak,Aj        ', c$it_jk,            c$id_non_bdp],
   {0A}  ['CPYXA      Ak,Xj        ', c$it_jk,            c$id_non_bdp],
   {0B}  ['CPYAX      Xk,Aj        ', c$it_jk,            c$id_non_bdp],
   {0C}  ['CPYRR      Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {0D}  ['CPYXX      Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {0E}  ['CPYSX      Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {0F}  ['CPYXS      Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {10}  ['INCX       Xk,j         ', c$it_jk,            c$id_non_bdp],
   {11}  ['DECX       Xk,j         ', c$it_jk,            c$id_non_bdp],
   {12}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {13}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {14}  ['LBSET      Xk,Aj,X0     ', c$it_jk,            c$id_non_bdp],
   {15}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {16}  ['TPAGE      Xk,Aj        ', c$it_jk,            c$id_non_bdp],
   {17}  ['LPAGE      Xk,Xj,X1     ', c$it_jk,            c$id_non_bdp],
   {18}  ['IORX       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {19}  ['XORX       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {1A}  ['ANDX       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {1B}  ['NOTX       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {1C}  ['INHX       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {1D}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {1E}  ['MARK       Xk,X1,j      ', c$it_jk,            c$id_non_bdp],
   {1F}  ['ENTZ       Xk           ', c$it_jk,            c$id_non_bdp],
   {20}  ['ADDR       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {21}  ['SUBR       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {22}  ['MULR       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {23}  ['DIVR       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {24}  ['ADDX       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {25}  ['SUBX       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {26}  ['MULX       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {27}  ['DIVX       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {28}  ['INCR       Xk,j         ', c$it_jk,            c$id_non_bdp],
   {29}  ['DECR       Xk,j         ', c$it_jk,            c$id_non_bdp],
   {2A}  ['ADDAX      Ak,Xj        ', c$it_jk,            c$id_non_bdp],
   {2B}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {2C}  ['CMPR       X1,Xj,Xk     ', c$it_jk,            c$id_non_bdp],
   {2D}  ['CMPX       X1,Xj,Xk     ', c$it_jk,            c$id_non_bdp],
   {2E}  ['BRREL      Xk           ', c$it_jk,            c$id_non_bdp],
   {2F}  ['BRDIR      Aj,Xk        ', c$it_jk,            c$id_non_bdp],
   {30}  ['ADDF       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {31}  ['SUBF       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {32}  ['MULF       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {33}  ['DIVF       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {34}  ['ADDD       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {35}  ['SUBD       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {36}  ['MULD       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {37}  ['DIVD       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {38}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {39}  ['ENTX       X1,z         ', c$it_jk,            c$id_non_bdp],
   {3A}  ['CNIF       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {3B}  ['CNFI       Xk,Xj        ', c$it_jk,            c$id_non_bdp],
   {3C}  ['CMPF       X1,Xj,Xk     ', c$it_jk,            c$id_non_bdp],
   {3D}  ['ENTP       Xk,j         ', c$it_jk,            c$id_non_bdp],
   {3E}  ['ENTN       Xk,j         ', c$it_jk,            c$id_non_bdp],
   {3F}  ['ENTL       X0,z         ', c$it_jk,            c$id_non_bdp],
   {40}  ['ADDFV      Ak,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {41}  ['SUBFV      Ak,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {42}  ['MULFV      Ak,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {43}  ['DIVFV      Ak,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {44}  ['ADDXV      Ak,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {45}  ['SUBXV      Ak,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {46}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {47}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {48}  ['IORV       Ak,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {49}  ['XORV       Ak,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {4A}  ['ANDV       Ak,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {4B}  ['CNIFV      Ak,Aj,d      ', c$it_jkid         , c$id_non_bdp],
   {4C}  ['CNFIV      Ak,Aj,d      ', c$it_jkid         , c$id_non_bdp],
   {4D}  ['SHFV       Ak,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {4E}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {4F}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {50}  ['COMPEQV    Ak,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {51}  ['CMPLTV     Ak,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {52}  ['CMPGEV     Ak,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {53}  ['CMPNEV     Ak,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {54}  ['MRGV       Ak,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {55}  ['GTHV       Ak,Aj,Xi,d   ', c$it_jkid         , c$id_non_bdp],
   {56}  ['SCTV       Ak,Aj,Xi,d   ', c$it_jkid         , c$id_non_bdp],
   {57}  ['SUMFV      Xk,Ai,d      ', c$it_jkid         , c$id_non_bdp],
   {58}  ['TPSFV      Ak,Aj,Ai,X0,d', c$it_jkid         , c$id_non_bdp],
   {59}  ['TPDFV      Ak,Aj,Ai,X0,d', c$it_jkid         , c$id_non_bdp],
   {5A}  ['TSPFV      Ak,Aj,Ai,X0,d', c$it_jkid         , c$id_non_bdp],
   {5B}  ['TDPFV      Ak,Aj,Ai,X0,d', c$it_jkid         , c$id_non_bdp],
   {5C}  ['SUMPFV     Xk,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {5D}  ['GTHIV      Ak,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {5E}  ['SCTIV      Ak,Aj,Ai,d   ', c$it_jkid         , c$id_non_bdp],
   {5F}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {60}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {61}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {62}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {63}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {64}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {65}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {66}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {67}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {68}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {69}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {6A}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {6B}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {6C}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {6D}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {6E}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {6F}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {70}  ['ADDN,Aj,X0 Ak,X1        ', c$it_jk,            c$id_bdp_two],
   {71}  ['SUBN,Aj,X0 Ak,X1        ', c$it_jk,            c$id_bdp_two],
   {72}  ['MULN,Aj,X0 Ak,X1        ', c$it_jk,            c$id_bdp_two],
   {73}  ['DIVN,Aj,X0 Ak,X1        ', c$it_jk,            c$id_bdp_two],
   {74}  ['CMPN,Aj,X0 Ak,X1        ', c$it_jk,            c$id_bdp_two],
   {75}  ['MOVN,Aj,X0 Ak,X1        ', c$it_jk,            c$id_bdp_two],
   {76}  ['MOVB,Aj,X0 Ak,X1        ', c$it_jk,            c$id_bdp_two],
   {77}  ['CMPB,Aj,X0 Ak,X1        ', c$it_jk,            c$id_bdp_two],
   {78}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {79}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {7A}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {7B}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {7C}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {7D}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {7E}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {7F}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {80}  ['LMULT      Xk,Aj,q      ', c$it_jkq,           c$id_non_bdp],
   {81}  ['SMULT      Xk,Aj,q      ', c$it_jkq,           c$id_non_bdp],
   {82}  ['LX         Xk,Aj,q      ', c$it_jkq,           c$id_non_bdp],
   {83}  ['SX         Xk,Aj,q      ', c$it_jkq,           c$id_non_bdp],
   {84}  ['LA         Ak,Aj,q      ', c$it_jkq,           c$id_non_bdp],
   {85}  ['SA         Ak,Aj,q      ', c$it_jkq,           c$id_non_bdp],
   {86}  ['LBYTP,j    Xk,q         ', c$it_jkq,           c$id_non_bdp],
   {87}  ['ENTC       X1,y         ', c$it_jkq,           c$id_non_bdp],
   {88}  ['LBIT       Xk,Aj,q,X0   ', c$it_jkq,           c$id_non_bdp],
   {89}  ['SBIT       Xk,Aj,q,X0   ', c$it_jkq,           c$id_non_bdp],
   {8A}  ['ADDRQ      Xk,Xj,q      ', c$it_jkq,           c$id_non_bdp],
   {8B}  ['ADDXQ      Xk,Xj,q      ', c$it_jkq,           c$id_non_bdp],
   {8C}  ['MULRQ      Xk,Xj,q      ', c$it_jkq,           c$id_non_bdp],
   {8D}  ['ENTE       Xk,q         ', c$it_jkq,           c$id_non_bdp],
   {8E}  ['ADDAQ      Ak,Aj,q      ', c$it_jkq,           c$id_non_bdp],
   {8F}  ['ADDPXQ     Ak,Xj,q      ', c$it_jkq,           c$id_non_bdp],
   {90}  ['BRREQ      Xj,Xk,q      ', c$it_jkq,           c$id_non_bdp],
   {91}  ['BRRNE      Xj,Xk,q      ', c$it_jkq,           c$id_non_bdp],
   {92}  ['BRRGT      Xj,Xk,q      ', c$it_jkq,           c$id_non_bdp],
   {93}  ['BRRGE      Xj,Xk,q      ', c$it_jkq,           c$id_non_bdp],
   {94}  ['BRXEQ      Xj,Xk,q      ', c$it_jkq,           c$id_non_bdp],
   {95}  ['BRXNE      Xj,Xk,q      ', c$it_jkq,           c$id_non_bdp],
   {96}  ['BRXGT      Xj,Xk,q      ', c$it_jkq,           c$id_non_bdp],
   {97}  ['BRXGE      Xj,Xk,q      ', c$it_jkq,           c$id_non_bdp],
   {98}  ['BRFEQ      Xj,Xk,q      ', c$it_jkq,           c$id_non_bdp],
   {99}  ['BRFNE      Xj,Xk,q      ', c$it_jkq,           c$id_non_bdp],
   {9A}  ['BRFGT      Xj,Xk,q      ', c$it_jkq,           c$id_non_bdp],
   {9B}  ['BRFGE      Xj,Xk,q      ', c$it_jkq,           c$id_non_bdp],
   {9C}  ['BRINC      Xj,Xk,q      ', c$it_jkq,           c$id_non_bdp],
   {9D}  ['BRSEG      X1,Aj,Ak,q   ', c$it_jkq,           c$id_non_bdp],
   {9E}  ['BROVR      Xk,q         ', c$it_jkq,           c$id_non_bdp],
   {9F}  ['BRCR       j,k,q        ', c$it_jkq,           c$id_non_bdp],
   {A0}  ['LAI        Ak,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {A1}  ['SAI        Ak,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {A2}  ['LXI        Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {A3}  ['SXI        Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {A4}  ['LBYT,X0    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {A5}  ['SBYT,X0    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {A6}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {A7}  ['ADDAD      Ak,Ai,d,j    ', c$it_jkid,          c$id_non_bdp],
   {A8}  ['SHFC       Xk,Xj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {A9}  ['SHFX       Xk,Xj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {AA}  ['SHFR       Xk,Xj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {AB}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {AC}  ['ISOM       Xk,Xi,d      ', c$it_jkid,          c$id_non_bdp],
   {AD}  ['ISOB       Xk,Xj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {AE}  ['INSB       Xk,Xj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {AF}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {B0}  ['CALLREL    Aj,Ak,q      ', c$it_jkq,           c$id_non_bdp],
   {B1}  ['KEYPOINT   j,Xk,q       ', c$it_jkq,           c$id_non_bdp],
   {B2}  ['MULXQ      Xk,Xj,q      ', c$it_jkq,           c$id_non_bdp],
   {B3}  ['ENTA       X0,y         ', c$it_jkq,           c$id_non_bdp],
   {B4}  ['CMPXA      Xk,Aj,X0,q   ', c$it_jkq,           c$id_non_bdp],
   {B5}  ['CALLSEG    Aj,Ak,q      ', c$it_jkq,           c$id_non_bdp],
   {B6}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {B7}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {B8}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {B9}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {BA}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {BB}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {BC}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {BD}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {BE}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {BF}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {C0}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {C1}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {C2}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {C3}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {C4}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {C5}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {C6}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {C7}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {C8}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {C9}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {CA}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {CB}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {CC}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {CD}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {CE}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {CF}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {D0}  ['LBYTS,1    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {D1}  ['LBYTS,2    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {D2}  ['LBYTS,3    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {D3}  ['LBYTS,4    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {D4}  ['LBYTS,5    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {D5}  ['LBYTS,6    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {D6}  ['LBYTS,7    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {D7}  ['LBYTS,8    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {D8}  ['SBYTS,1    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {D9}  ['SBYTS,2    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {DA}  ['SBYTS,3    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {DB}  ['SBYTS,4    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {DC}  ['SBYTS,5    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {DD}  ['SBYTS,6    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {DE}  ['SBYTS,7    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {DF}  ['SBYTS,8    Xk,Aj,Xi,d   ', c$it_jkid,          c$id_non_bdp],
   {E0}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {E1}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {E2}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {E3}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {E4}  ['SCLN,Aj,X0 Ak,X1,Xi,d   ', c$it_jkid,          c$id_bdp_two],
   {E5}  ['SCLR,Aj,X0 Ak,X1,Xi,d   ', c$it_jkid,          c$id_bdp_two],
   {E6}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {E7}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {E8}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {E9}  ['CMPC,Aj,X0 Ak,X1,Ai,d   ', c$it_jkid,          c$id_bdp_two],
   {EA}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {EB}  ['TRANB,Aj,X0 Ak,X1,Ai,d  ', c$it_jkid,          c$id_bdp_two],
   {EC}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {ED}  ['EDIT,Aj,X0 Ak,X1,Ai,d   ', c$it_jkid,          c$id_bdp_two],
   {EE}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {EF}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {F0}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {F1}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {F2}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {F3}  ['SCNB,X0,   Ak,X1,Ai,d   ', c$it_jkid,          c$id_bdp_one],
   {F4}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {F5}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {F6}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {F7}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {F8}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {F9}  ['MOVI,Xi,d  Ak,X1,j      ', c$it_jkid,          c$id_bdp_one],
   {FA}  ['CMPI,Xi,d  Ak,X1,j      ', c$it_jkid,          c$id_bdp_one],
   {FB}  ['ADDI,X1,d  Ak,X1,j      ', c$it_jkid,          c$id_bdp_one],
   {FC}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {FD}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {FE}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp],
   {FF}  ['NO OP CODE              ', c$it_unimplemented, c$id_non_bdp]];
?? OLDTITLE ??
?? NEWTITLE := 'dup$decode_command', EJECT ??

{ PURPOSE:
{   This procedure decodes object code from memory.

  PROCEDURE [XDCL] dup$decode_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE decode (
{   address, a: integer = $required
{   bytes, b: integer 0..duc$maximum_memory_display = 8
{   exchange, e: any of
{       key
{         (active a) (monitor m) (job j)
{       keyend
{       integer 0..0ffffffff(16)
{     anyend = 0ffffffff(16)
{   processor, p: integer 0..3 = 0
{   address_mode, am: key
{       (process_virtual_address pva) (system_virtual_address sva) (real_memory_address rma)
{     keyend = process_virtual_address
{   output, o: file
{   title, t: string 1..31 = 'decode'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 15] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: 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 .. 6] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (13),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (23),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (8),
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 4, 16, 9, 12, 35, 916],
    clc$command, 15, 8, 1, 0, 0, 0, 8, ''], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['ADDRESS                        ',clc$nominal_entry, 1],
    ['ADDRESS_MODE                   ',clc$nominal_entry, 5],
    ['AM                             ',clc$abbreviation_entry, 5],
    ['B                              ',clc$abbreviation_entry, 2],
    ['BYTES                          ',clc$nominal_entry, 2],
    ['E                              ',clc$abbreviation_entry, 3],
    ['EXCHANGE                       ',clc$nominal_entry, 3],
    ['O                              ',clc$abbreviation_entry, 6],
    ['OUTPUT                         ',clc$nominal_entry, 6],
    ['P                              ',clc$abbreviation_entry, 4],
    ['PROCESSOR                      ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 8],
    ['T                              ',clc$abbreviation_entry, 7],
    ['TITLE                          ',clc$nominal_entry, 7]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 269,
  clc$optional_default_parameter, 0, 13],
{ PARAMETER 4
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 23],
{ PARAMETER 6
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 7
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 8
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, duc$maximum_memory_display, 10],
    '8'],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    229, [[1, 0, clc$keyword_type], [6], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['MONITOR                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]]
    ,
    '0ffffffff(16)'],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [0, 3, 10],
    '0'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [6], [
    ['PROCESS_VIRTUAL_ADDRESS        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['PVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['REAL_MEMORY_ADDRESS            ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['RMA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['SVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SYSTEM_VIRTUAL_ADDRESS         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'process_virtual_address'],
{ PARAMETER 6
    [[1, 0, clc$file_type]],
{ PARAMETER 7
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''decode'''],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$address = 1,
      p$bytes = 2,
      p$exchange = 3,
      p$processor = 4,
      p$address_mode = 5,
      p$output = 6,
      p$title = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    TYPE
      t$bdp_part = RECORD
        part_1: 0 .. 0ffff(16),
        part_2: 0 .. 0ffff(16),
      RECEND,

      t$data_line = RECORD
        CASE boolean OF
        = TRUE =
          line: string (60),
        = FALSE =
          space_1: string (2),
          address: string (8),
          space_2: string (3),
          op_code_jk: string (4),
          space_3: string (1),
          q_part: string (4),
          space_4: string (3),
          instruction: string (24),
        CASEND,
      RECEND,

      t$op_code_jk = PACKED RECORD
        CASE 0 .. 2 OF
        = 0 =
          op_code: 0 .. 0ff(16),
          j: 0 .. 0f(16),
          k: 0 .. 0f(16),
        = 1 =
          op_code_part: 0 .. 0ff(16),
          j_left: 0 .. 3,
          j_right: 0 .. 3,
          k_part: 0 .. 0f(16),
        = 2 =
          op_code_jk: 0 .. 0ffff(16),
        CASEND,
      RECEND,

      t$q_id_part = PACKED RECORD
        CASE 0 .. 2 OF
        = 0 =
          q: 0 .. 0ffff(16),
        = 1 =
          i: 0 .. 0f(16),
          d: 0 .. 0fff(16),
        = 2 =
          i_part: 0 .. 0f(16),
          d_bit_1: 0 .. 1,
          d_rest: 0 .. 7ff(16),
        CASEND,
      RECEND;

    VAR
      access_data: dut$access_data,
      address: dut$ee_address_parameter,
      bdp_index: 1 .. 2,
      bdp_loop_count: 0 .. 2,
      bdp_part_p: ^t$bdp_part,
      bytes: ost$segment_length,
      data_line: t$data_line,
      data_seq_p: ^SEQ ( * ),
      decode_address: ost$segment_offset,
      default_list: ARRAY [1 .. 3] OF dut$default_change_list_entry,
      display_control: clt$display_control,
      display_string: string (osc$max_string_size),
      exchange_package_p: ^dut$exchange_package,
      ignore_status: ost$status,
      index: 1 .. 24,
      instruction: string (24),
      memory_p: ^cell,
      new_byte_size: ost$segment_length,
      op_code_jk_p: ^t$op_code_jk,
      output_display_opened: boolean,
      processor: 0 .. duc$de_maximum_processors,
      q_id_part_p: ^t$q_id_part,
      ring_attributes: amt$ring_attributes,
      string_length: integer;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    { Change the default value for the EXCHANGE, PROCESSOR and ADDRESS_MODE parameters.

    default_list [1].default_name := duc$dp_exchange;
    default_list [1].number := p$exchange;
    default_list [2].default_name := duc$dp_processor;
    default_list [2].number := p$processor;
    default_list [3].default_name := duc$dp_address_mode;
    default_list [3].number := p$address_mode;
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    IF (duv$execution_environment.processing_options = duc$ee_po_no_memory) OR
          (NOT duv$dump_environment_p^.central_memory.available AND
          NOT duv$dump_environment_p^.critical_memory.available) THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The central memory is', status);
      RETURN;  {---->
    IFEND;
    IF pvt [p$bytes].value^.integer_value.value = 0 THEN
      RETURN;  {---->
    IFEND;

    IF (pvt [p$address_mode].value^.keyword_value <> 'PROCESS_VIRTUAL_ADDRESS') AND
          pvt [p$exchange].specified THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$rma_and_exc_specified, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

      { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      address.rma_part := pvt [p$address].value^.integer_value.value;
      bytes := pvt [p$bytes].value^.integer_value.value;
      processor := pvt [p$processor].value^.integer_value.value;

      IF pvt [p$address_mode].value^.keyword_value = 'PROCESS_VIRTUAL_ADDRESS' THEN
        STRINGREP (display_string, string_length, 'segment =', address.pva_part.seg: #(16));
        clp$put_display (display_control, display_string (1, string_length), clc$no_trim, status);
      IFEND;

      IF (pvt [p$address_mode].value^.keyword_value = 'PROCESS_VIRTUAL_ADDRESS') OR
            (pvt [p$address_mode].value^.keyword_value = 'SYSTEM_VIRTUAL_ADDRESS') THEN
        PUSH data_seq_p: [[REP bytes OF cell]];
        IF data_seq_p = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
          EXIT /display_opened/;  {---->
        IFEND;
        RESET data_seq_p;
      IFEND;

      IF pvt [p$address_mode].value^.keyword_value = 'PROCESS_VIRTUAL_ADDRESS' THEN
        dup$retrieve_exchange_package (processor, pvt [p$exchange].value^, exchange_package_p, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        dup$copy_virtual_memory_pva (address.pva_part, exchange_package_p^, processor, bytes, TRUE,
              new_byte_size, data_seq_p, access_data, status);
        IF NOT status.normal AND (status.condition <> due$memory_partially_avail) THEN
          EXIT /display_opened/;  {---->
        IFEND;
        IF access_data.page_fault AND NOT access_data.memory_found THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$page_fault_error_severity, '', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, ', segment = ', status);
          osp$append_status_integer (osc$status_parameter_delimiter, address.pva_part.seg, 16, TRUE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, ', offset = ', status);
          osp$append_status_integer (osc$status_parameter_delimiter, access_data.page_fault_offset, 16, TRUE,
                status);
          EXIT /display_opened/;  {---->
        IFEND;

      ELSEIF pvt [p$address_mode].value^.keyword_value = 'SYSTEM_VIRTUAL_ADDRESS' THEN
        dup$copy_virtual_memory_sva (address.sva_part, processor, bytes, TRUE, new_byte_size,
              data_seq_p, access_data, status);
        IF NOT status.normal AND (status.condition <> due$memory_partially_avail) THEN
          EXIT /display_opened/;  {---->
        IFEND;
        IF access_data.page_fault AND NOT access_data.memory_found THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$page_fault_error_severity, '', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, ', asid = ', status);
          osp$append_status_integer (osc$status_parameter_delimiter, address.sva_part.asid.value, 16, TRUE,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, ', offset = ', status);
          osp$append_status_integer (osc$status_parameter_delimiter, access_data.page_fault_offset, 16, TRUE,
                status);
          EXIT /display_opened/;  {---->
        IFEND;

      ELSE  { pvt [p$address_mode].value^.keyword_value = 'REAL_MEMORY_ADDRESS' }
        dup$access_real_memory (bytes, address.rma_part, memory_p, new_byte_size, status);
        IF NOT status.normal AND (status.condition <> due$memory_partially_avail) THEN
          EXIT /display_opened/;  {---->
        IFEND;
        RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO memory_p;
        NEXT data_seq_p: [[REP new_byte_size OF cell]] IN
              duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
        IF data_seq_p = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
          EXIT /display_opened/;  {---->
        IFEND;
      IFEND;

      decode_address := address.pva_part.offset;
      RESET data_seq_p;
      WHILE new_byte_size > 0 DO
        data_line.line := ' ';
        clp$convert_integer_to_rjstring (decode_address, 16, FALSE, '0', data_line.address, ignore_status);

        IF (new_byte_size - #SIZE (t$op_code_jk)) < 0 THEN
          EXIT /display_opened/;  {---->
        IFEND;
        NEXT op_code_jk_p IN data_seq_p;
        IF op_code_jk_p = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
          EXIT /display_opened/;  {---->
        IFEND;
        new_byte_size := new_byte_size - #SIZE (op_code_jk_p^);
        decode_address := decode_address + #SIZE (op_code_jk_p^);
        clp$convert_integer_to_rjstring (op_code_jk_p^.op_code_jk, 16, FALSE, '0', data_line.op_code_jk,
              ignore_status);

        IF (v$instruction_list [op_code_jk_p^.op_code].format = c$it_jkid) OR
              (v$instruction_list [op_code_jk_p^.op_code].format = c$it_jkq) THEN
          IF (new_byte_size - #SIZE (t$q_id_part)) < 0 THEN
            EXIT /display_opened/;  {---->
          IFEND;
          NEXT q_id_part_p IN data_seq_p;
          IF q_id_part_p = NIL THEN
            osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
            EXIT /display_opened/;  {---->
          IFEND;
          new_byte_size := new_byte_size - #SIZE (q_id_part_p^);
          decode_address := decode_address + #SIZE (q_id_part_p^);
          clp$convert_integer_to_rjstring (q_id_part_p^.q, 16, FALSE, '0', data_line.q_part, ignore_status);
        IFEND;

        instruction := v$instruction_list [op_code_jk_p^.op_code].instruction;
        FOR index := 1 TO #SIZE (instruction) DO
          IF instruction (index) = 'j' THEN
            IF (op_code_jk_p^.op_code >= 40(16)) AND (op_code_jk_p^.op_code < 60(16)) AND
                  (q_id_part_p^.d_bit_1 = 1) THEN
              instruction (index - 1) := 'X';
            IFEND;
            clp$convert_integer_to_rjstring (op_code_jk_p^.j, 16, FALSE, '0', instruction (index),
                  ignore_status);
          ELSEIF instruction (index) = 'k' THEN
            clp$convert_integer_to_rjstring (op_code_jk_p^.k, 16, FALSE, '0', instruction (index),
                  ignore_status);
          ELSEIF instruction (index) = 'i' THEN
            clp$convert_integer_to_rjstring (q_id_part_p^.i, 16, FALSE, '0', instruction (index),
                  ignore_status);
          ELSEIF instruction (index) = 'd' THEN
            clp$convert_integer_to_rjstring (q_id_part_p^.d, 16, FALSE, '0', instruction (index, 3),
                  ignore_status);
          ELSEIF instruction (index) = 'q' THEN
            clp$convert_integer_to_rjstring (q_id_part_p^.q, 16, FALSE, '0', instruction (index, 4),
                  ignore_status);
          ELSEIF instruction (index) = 'z' THEN
            clp$convert_integer_to_rjstring (op_code_jk_p^.j, 16, FALSE, '0', instruction (index),
                  ignore_status);
            clp$convert_integer_to_rjstring (op_code_jk_p^.k, 16, FALSE, '0', instruction (index+1),
                  ignore_status);
          ELSEIF instruction (index) = 'y' THEN
            clp$convert_integer_to_rjstring (op_code_jk_p^.j, 16, FALSE, '0', instruction (index),
                  ignore_status);
            clp$convert_integer_to_rjstring (op_code_jk_p^.k, 16, FALSE, '0', instruction (index+1),
                  ignore_status);
            clp$convert_integer_to_rjstring (q_id_part_p^.q, 16, FALSE, '0', instruction (index+2, 4),
                  ignore_status);
          IFEND;
        FOREND;
        IF op_code_jk_p^.op_code = 9E(16) THEN
          IF op_code_jk_p^.j_right = 0 THEN
            instruction (1, 5) := 'BROVR';
          ELSEIF op_code_jk_p^.j_right = 1 THEN
            instruction (1, 5) := 'BRUND';
          ELSEIF (op_code_jk_p^.j_right = 2) OR (op_code_jk_p^.j_right = 3) THEN
            instruction (1, 5) := 'BRUND';
          IFEND;
        IFEND;
        data_line.instruction := instruction;
        clp$put_display (display_control, data_line.line, clc$trim, ignore_status);

        IF v$instruction_list [op_code_jk_p^.op_code].designation = c$id_bdp_one THEN
          bdp_loop_count := 1;
        ELSEIF v$instruction_list [op_code_jk_p^.op_code].designation = c$id_bdp_two THEN
          bdp_loop_count := 2;
        ELSE
          bdp_loop_count := 0;
        IFEND;

        FOR bdp_index := 1 TO bdp_loop_count DO
          data_line.line := ' ';
          clp$convert_integer_to_rjstring (decode_address, 16, FALSE, '0', data_line.address, ignore_status);
          IF (new_byte_size - #SIZE (t$bdp_part)) < 0 THEN
            EXIT /display_opened/;  {---->
          IFEND;
          NEXT bdp_part_p IN data_seq_p;
          IF bdp_part_p = NIL THEN
            osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
            EXIT /display_opened/;  {---->
          IFEND;
          new_byte_size := new_byte_size - #SIZE (bdp_part_p^);
          decode_address := decode_address + #SIZE (bdp_part_p^);
          clp$convert_integer_to_rjstring (bdp_part_p^.part_1, 16, FALSE, '0', data_line.op_code_jk,
                ignore_status);
          clp$convert_integer_to_rjstring (bdp_part_p^.part_2, 16, FALSE, '0', data_line.q_part,
                ignore_status);
          clp$put_display (display_control, data_line.line, clc$trim, ignore_status);
        FOREND;
      WHILEND;

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$decode_command;
MODEND dum$decode_command;
*DECK DECK=DUM$DISPLAY_ACTIVE_JOB_LIST EXPAND=TRUE
PROCEDURE dum$display_active_job_list, display_active_job_list, disajl (
  output, o: file = $output
  status)

  VAR
    cctqm: string 1..256 = '???????????????????????????????? !"#$%&''()*+,-./0123456789:;'//..
          '<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~????????????????'//..
          '???????????????????????????????????????????????????????????????????????????????????'//..
          '??????????????????????????????'
    jmv$jcb: integer = 300000000(16)              "($sa(jmv$jcb))
    job_fixed_seg_num: integer = 14(16)           "relative to monitor address space
    job_monitor_xcb_offset: integer = 100(16)     "from start of job fixed
  VAREND

  VAR
    ajl: integer
    ajl_entry_size: integer
    ajl_ord: integer
    ajl_p: integer
    field_length: integer
    field_offset: integer
    job_name: integer
    line: string
    local_status: status
    number_of_entries: integer
    output_file: file
    system_ajl_ordinal: integer
    user_id: integer
  VAREND

  IF $file(output open_position) = '$BOI' THEN
    delete_file f=output status=local_status
    set_file_attributes f=output fc=list
  IFEND
  output_file = output.$eoi

  put_line l='1COMMAND: DISPLAY_ACTIVE_JOB_LIST' o=output_file
  put_line l=' ' o=output_file

  jmt$job_control_block field=JOBNAME offset=field_offset length=field_length
  job_name = field_offset/8            "offset into job control block
  jmt$job_control_block field=USER_ID offset=field_offset length=field_length
  user_id = field_offset/8             "offset into job control block

  change_default e=monitor am=pva
  ajl_p = $symbol_address(jmv$ajl_p)
  ajl = $memory(ajl_p)
  IF $nil_pva(ajl) THEN
    put_line l=' The active job list has not yet been established.' o=output_file
    EXIT PROCEDURE
  IFEND

  ajl_entry_size = $memory(ajl_p+14 4)
  system_ajl_ordinal = $memory(ajl_p+10 4)
  number_of_entries = $memory(ajl_p+6 4)/ajl_entry_size
  put_line l=' ajl starts at '//$strrep(ajl 16)//', entry size = '//$strrep(ajl_entry_size 16) o=output_file

  " Change the JPS value to the System Job Monitor XCB value.

  change_processor_register ..
        jps=$rma(((system_ajl_ordinal+job_fixed_seg_num)*100000000(16))+job_monitor_xcb_offset)
  change_default e=job

  FOR ajl_ord = system_ajl_ordinal TO (system_ajl_ordinal + number_of_entries - 1) DO
    IF $memory(ajl+(ajl_ord*ajl_entry_size) 3) > 0 THEN   "process entry if entry is in use.
      line = ' '//$strrep(ajl_ord)//'.'
      change_processor_register ..
            jps=$rma(((ajl_ord+job_fixed_seg_num)*100000000(16))+job_monitor_xcb_offset monitor)
      IF ajl_ord <> system_ajl_ordinal THEN
        line = line//', job name = '//$trim($translate(cctqm $memory_string(jmv$jcb+job_name 31)))
      IFEND
      line = line // ', user id = '//$trim($translate(cctqm $memory_string(jmv$jcb+user_id 31)))
      put_line l=line o=output_file
    IFEND
  FOREND

PROCEND dum$display_active_job_list
*DECK DECK=DUM$DISPLAY_ACTIVE_TASKS EXPAND=TRUE
PROCEDURE dum$display_active_tasks, display_active_tasks, disat (
  output, o: file = $output
  status)

  VAR
    jmv$jcb: integer = 300000000(16)              "($sa(jmv$jcb))
    job_monitor_xcb_offset: integer = 100(16)     "from start of job fixed
    syc$rc_maximum_value: integer = 86            "see deck syc$monitor_request_codes
  VAREND

  VAR
    field_length: integer
    field_offset: integer
    function: integer
    job_monitor_xcb: integer
    line: string
    link: integer
    local_file: file = $fname('$local.'//$unique)
    local_status: status
    mcr: integer
    monitor_functions: ARRAY 0 .. syc$rc_maximum_value OF string
    output_file: file
    task_name: integer
    task_number: integer
    task_xcb: integer
  VAREND

  IF $file(output open_position) = '$BOI' THEN
    delete_file f=output status=local_status
    set_file_attributes f=output fc=list
  IFEND
  output_file = output.$eoi

  put_line l='1COMMAND: DISPLAY_ACTIVE_TASKS' o=output_file
  put_line l=' ' o=output_file

  task_xcb = $memory($symbol_address(job_xcb_list))
  job_monitor_xcb = $rma(jmv$jcb+job_monitor_xcb_offset)

  ost$execution_control_block field=SAVE9 offset=field_offset length=field_length
  task_name = field_offset/8                  "offset into the XCB
  ost$execution_control_block field=LINK offset=field_offset length=field_length
  link = field_offset/8                       "offset into xcb

  create_monitor_func_file f=local_file
  accept_line v=monitor_functions i=local_file
  detach_file f=local_file

  task_number = 0
  process_tasks: ..
  REPEAT
    line = ' '//$strrep(task_number)//'.'
    change_processor_register jps=$rma(task_xcb)
    line = line//' task name = '//$trim($memory_string((task_xcb+task_name) 31))
    mcr = $process_register(mcr) / 20(16)
    IF mcr <> ((mcr / 2) * 2) THEN
      function = $memory(task_xcb+088(16) 1)
      IF (function > 0) AND (function <= syc$rc_maximum_value) THEN
        line = line//', monitor request = '//monitor_functions(function)
      IFEND
    IFEND
    line = line//', jps = '//$strrep($rma(task_xcb) 16)//'(16)'
    put_line l=line o=output_file
    EXIT process_tasks WHEN $rma(task_xcb) = job_monitor_xcb
    task_xcb = $memory(task_xcb+link)
    task_number = task_number + 1
  UNTIL $nil_pva(task_xcb)

PROCEND dum$display_active_tasks
*DECK DECK=DUM$DISPLAY_ACTIVE_VOLUME_TABLE EXPAND=TRUE
PROCEDURE dum$display_active_volume_table, display_active_volume_table, disavt (
  index, i: any of
      integer 1..150
      key
        all
      keyend
    anyend = all
  display_options, display_option, do: key
      (brief, b), (full, f)
    keyend = brief
  output, o: file = $output
  help, h: file = $null
  status)


  "$FORMAT=OFF"
  VAR
    when_status: status
  VAREND
  "$FORMAT=ON"

  WHEN any_fault DO
    when_status = $previous_status
    putl ' Invoked DISAVT condition handler due to the following abnormal status:'
    disv when_status
    putl ' Enter commands, "exit_proc" to abort, or "exit_proc with when_status" to abort with status'
    include_file command prompt='disavt_ch'
  WHENEND

  IF $specified(help) THEN
COLLECT_TEXT o=help until='HELPEND'
DISPLAY_ACTIVE_VOLUME_TABLE or DISAVT

  This procedure will display the active volume table and describe the
contents of selected fields of the table.  This procedure assumes the
user has previously selected the correct exchange package by available
analyze_dump commands.

PARAMETERS:

INDEX, I: integer 1..50 or key all
  This parameter selects the active volume table index of the individual
entry to be displayed if an integer is entered.  This parameter defaults
to "all".

DISPLAY_OPTIONS, DO: key full, f, brief, b
  This parameter selects the option of displaying the contents of memory
and the description of the selected fields (full), or the brief
mode of the descriptions only.  This parameter defaults to brief.

OUTPUT, O: file
  This parameter selects the file name to receive the data.  This para-
meter is defaulted to $output.  If a file name other than $output is
entered the data will be formated correctly for printer disposition and
will be sent to the file  "$asis".

STATUS

EXAMPLES OF USE:

DISPLAY_ACTIVE_VOLUME_TABLE INDEX=1
  Will display the memory contents of active volume table index 1 to
the file $output and describe the contents of selected fields.

DISAVT O=LIST
  Will display the memory contents of all active volume tables to
the user's local file list along with a description of selected
fields of the tables.  PRIF LIST will provide a hard copy.
COPF LIST will provide a page at a time to the user's terminal.

WARNINGS/KNOWN DEFICIENCIES:

ERROR HANDLER
  When any fatal error is encountered a condition handler is invoked and
the following messages will appear:
 "Invoked DISAVT condition handler due to the following abnormal status:"
 "< the error status message >"
 "Enter commands, "exit_proc" to abort, or "exit_proc with when_status"
  to abort with status"
To exit the handler enter:    "exit_proc"
To exit the handler with status, enter:   "exit_proc with when_status"

HELPEND
    EXIT_PROC
  IFEND

  "$FORMAT=OFF"
  VAR
    output_file: file
    entry_available_offset: integer = 8 " DMT$ACTIVE_VOLUME_TABLE_ENTRY.ENTRY_AVAILABLE "
  VAREND
  "$FORMAT=ON"

  IF $file(output open_position) = '$BOI' THEN
    output_file = output.$asis
  ELSE
    output_file = output
  IFEND

" Get the base values required to look at the active volume table.  Use the knowlege that
" DMV$P_ACTIVE_VOLUME_TABLE is an adaptable array.

  p_avt = $mem($sa(dmv$p_active_volume_table), 6)
  avt_length = $mem($sa(dmv$p_active_volume_table)+6, 4)
  avt_start_index = $mem($sa(dmv$p_active_volume_table)+6+4, 4)
  avt_entry_size = $mem($sa(dmv$p_active_volume_table)+6+4+4, 4)
  number_of_avt_entries = avt_length / avt_entry_size

  IF $generic_type(index) = 'KEY' THEN

    IF index = 'ALL' THEN

      FOR i = avt_start_index TO number_of_avt_entries DO
        current_avt_entry = p_avt + ((i - avt_start_index)* avt_entry_size)
        IF $mem(current_avt_entry+entry_available_offset, 1) = 0 THEN
          IF (output = :$local.$output) AND (display_option <> 'BRIEF') THEN
            put_line '1ACTIVE VOLUME TABLE ENTRY - AVT INDEX '//$strrep(i) o=output_file
          IFEND

          IF display_option = 'FULL' THEN
            display_memory a=current_avt_entry b=avt_entry_size o=output.$eoi t='AVT INDEX '//$strrep(i) ..
                  am=pva e=m p=0
          ELSE
            put_line '1ACTIVE VOLUME TABLE ENTRY - AVT INDEX '//$strrep(i) o=output_file
          IFEND
          display_brief_avt_entry index=i o=output
        IFEND
      FOREND
    IFEND

  ELSE " an index was specified

    IF output = :$local.$output AND (display_option <> 'BRIEF') THEN
      put_line '1ACTIVE VOLUME TABLE ENTRY - AVT INDEX '//$strrep(index) o=output_file
    IFEND

    current_avt_entry = (p_avt + ((index - avt_start_index)* avt_entry_size))
    IF display_option = 'FULL' THEN
      display_memory a=current_avt_entry b=avt_entry_size o=output.$eoi t='AVT INDEX '//$strrep(index) ..
            am=pva e=m p=0
      display_brief_avt_entry index o=output

    ELSEIF display_option = 'BRIEF' THEN
      put_line '1ACTIVE VOLUME TABLE ENTRY - AVT INDEX '//$strrep(index) o=output_file
      display_brief_avt_entry index o=output

    IFEND
  IFEND

PROCEND dum$display_active_volume_table
*DECK DECK=DUM$DISPLAY_ALLOCATE EXPAND=TRUE
PROCEDURE dum$display_allocate, display_allocate (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, sva, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable output_line k=string v=' '
  create_variable log_address v=$value(address)
  create_variable indent k=(string, 5) v='     '
  log_address = log_address + 1

  display_binary_unique_name log_address o=$fname(output_file) cs=indent//'gfn=' am=$value(am)
  output_line = indent//'dfl='//$strrep($mem(log_address+11, 3, j, 0, $value(am)), 16)
  output_line = output_line//' flags='//$strrep($mem(log_address+14, 1, j, 0, $value(am)), 16)
  output_line = output_line//' dau='//$strrep($mem(log_address+15, 3, j, 0, $value(am)), 16)
  output_line = output_line//' previous_dau='//$strrep($mem(log_address+18, 3, j, 0, $value(am)), 16)
  output_line = output_line//' dau/au='//$strrep($mem(log_address+21, 1, j, 0, $value(am)), 16)

  putl output_line o=$fname(output_file)

PROCEND dum$display_allocate
*DECK DECK=DUM$DISPLAY_ALLOCATION_LOG EXPAND=TRUE
PROCEDURE dum$display_allocation_log, display_allocation_log, disal (
  first, f: integer 0..3125 = 0
  last, l: integer 0..3125 = 0
  output, o: file = $output
  )

  "$FORMAT=OFF"
  VAR
    when_status: status
  VAREND
  "$FORMAT=ON"

  WHEN any_fault DO
    when_status = $previous_status
    putl ' Invoked DISAL condition handler due to the following abnormal status:'
    disv when_status
    putl ' Enter commands, "exit_proc" to abort, or "exit_proc with when_status" to abort with status'
    include_file command prompt='disal_ch'
  WHENEND

  crev s k= status

  IF $file($value(output) open_position) = '$BOI' THEN
    rewind_file $value(output) status= s
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  setfa $fname(output_file) fc= unknown

  create_variable allocation_log_entry k= string d= 0..5
  allocation_log_entry(0) = 'dmc$al_allocate'
  allocation_log_entry(1) = 'dmc$al_initialize'
  allocation_log_entry(2) = 'dmc$al_return_dau'
  allocation_log_entry(3) = 'dmc$al_software_flawed'
  allocation_log_entry(4) = 'dmc$al_reallocate'
  allocation_log_entry(5) = 'dmc$al_trim_file'

  create_variable chain_pos k= string d= 0..4
  chain_pos(0) = 'dmc$first_and_last_allocation'
  chain_pos(1) = 'dmc$first_allocation'
  chain_pos(2) = 'dmc$middle_allocation'
  chain_pos(3) = 'dmc$last_allocation'
  chain_pos(4) = 'dmc$part_of_allocation_unit'

  create_variable allocate_flag k= string d= 0..1
  allocate_flag(0) = 'dmc$dl_first_allocation'
  allocate_flag(1) = 'dmc$dl_continue_allocation'

  create_variable flaw_options k= string d=0..1
  flaw_options(0) = 'dmc$remove_flaw'
  flaw_options(1) = 'dmc$add_flaw'

  create_variable name= entry_type kind= integer
  create_variable name= line kind= string
  create_variable name= al_first kind= integer
  create_variable name= al_last kind= integer
  create_variable name= common_int kind= integer
  create_variable name= common_offset kind= integer
  create_variable name= rap_around kind= integer value= 1

  entry_type_offset = 2
  number_offset = 0
  first_offset = 16
  last_offset = 18
  committed_offset = 8
  entries_offset = 20
  entry_size = 36
  max_entry = 3125

  al_start = $sa(dmv$allocation_log)

  IF $specified(first) OR $specified(last) THEN
    al_first = $value(first)
    al_last = $value(last)
    IF al_first > al_last THEN
      al_last = max_entry
      rap_around = 2
    IFEND
  ELSE
    al_first = $memory(al_start+first_offset, 2)
    al_last = $memory(al_start+last_offset, 2)
  IFEND

  line = '               First Allocation Log Entry = '//..
$strrep(($memory(al_start+first_offset, 2)), 16)//'(16)'
  putl line o= $fname(output_file)
  line = '               Last Allocation Log Entry = '//..
$strrep(($memory(al_start+last_offset, 2)), 16)//'(16)'
  putl line o= $fname(output_file)
  line = '               Number Of Entries = '//$strrep(($memory(al_start+number_offset, 8)), 16)//'(16)'
  putl line o= $fname(output_file)
  line = '               Committed Initialize Count = '//..
$strrep(($memory(al_start+committed_offset, 8)), 16)//'(16)'
  putl line o= $fname(output_file)

  REPEAT
    FOR i = al_first TO al_last DO
      putl '  ' o= $fname(output_file)
      al_entry_adrs = al_start+entries_offset+(i * entry_size)
      display_memory al_entry_adrs, entry_size, o= $fname(output_file)
      entry_type = $memory(al_entry_adrs+entry_type_offset, 1)
      line = '   AVT Index = '//$strrep($memory(al_entry_adrs, 2))
      line = line//'    Entry Type = '//allocation_log_entry(entry_type)
      line = line//'    Entry Index = '//$strrep(i, 16)//'(16)'
      putl line o= $fname(output_file)

      IF entry_type = 0 THEN "dmc$al_allocate"
        display_binary_unique_name, al_entry_adrs+3, o= $fname(output_file), cs= '   Gfn = '
        common_string = $strrep(($memory(al_entry_adrs+14, 3)), 16)//'(16)'
        line = '   DFL Index = '//common_string
        common_int = $memory(al_entry_adrs+17, 1)
        line = line//'    Flag = '//allocate_flag(common_int)
        putl line o= $fname(output_file)
        common_string = $strrep(($memory(al_entry_adrs+18, 3)), 16)//'(16)'
        line = '   DAU Adrs = '//common_string
        common_string = $strrep(($memory(al_entry_adrs+21, 3)), 16)//'(16)'
        line = line//'    Prev DAU Adrs = '//common_string
        common_string = $strrep(($memory(al_entry_adrs+24, 1)), 16)//'(16)'
        line = line//'    DAUS Per = '//common_string
      ELSEIF entry_type = 1 THEN "dmc$al_initialize"
        display_binary_unique_name, al_entry_adrs+3, o= $fname(output_file), cs= '   GFN = '
        common_string = $strrep(($memory(al_entry_adrs+14, 3)), 16)//'(16)'
        line = '   DFL Index = '//common_string
        common_string = $strrep(($memory(al_entry_adrs+17, 3)), 16)//'(16)'
        line = line//'    DAU Adrs = '//common_string
      ELSEIF entry_type = 2 THEN "dmc$al_return_dau"
        common_string = $strrep(($memory(al_entry_adrs+3, 5)), 16)//'(16)'
        line = '   MF Assign = '//common_string
        common_string = $strrep(($memory(al_entry_adrs+8, 3)), 16)//'(16)'
        line = line//'    DAU Adrs = '//common_string
        common_string = $strrep(($memory(al_entry_adrs+11, 1)), 16)//'(16)'
        line = line//'    DAUS Per = '//common_string
      ELSEIF entry_type = 3 THEN "dmc$al_software_flawed"
        common_string = $strrep(($memory(al_entry_adrs+3, 3)), 16)//'(16)'
        line = '   DAU Adrs = '//common_string
        common_int = $memory(al_entry_adrs+6, 1)
        line = line//'    Flaw Option = '//flaw_options(common_int)
      ELSEIF entry_type = 4 THEN "dmc$reallocate"
        display_binary_unique_name, al_entry_adrs+3, o= $fname(output_file), cs= '   GFN = '
        common_string = $strrep(($memory(al_entry_adrs+14, 3)), 16)//'(16)'
        line = '   DFL Index = '//common_string
        common_string = $strrep(($memory(al_entry_adrs+17, 5)), 16)//'(16)'
        line = line//'    MF Assign = '//common_string
        common_string = $strrep(($memory(al_entry_adrs+22, 3)), 16)//'(16)'
        line = line//'    DAU Adrs = '//common_string
        putl line o= $fname(output_file)
        common_string = $strrep(($memory(al_entry_adrs+25, 3)), 16)//'(16)'
        line = '   Old DAU Adrs = '//common_string
        common_string = $strrep(($memory(al_entry_adrs+28, 3)), 16)//'(16)'
        line = line//'    Next DAU Adrs = '//common_string
        common_string = $strrep(($memory(al_entry_adrs+31, 3)), 16)//'(16)'
        line = line//'    Prev DAU Adrs = '//common_string
        putl line o= $fname(output_file)
        common_string = $strrep(($memory(al_entry_adrs+34, 1)), 16)//'(16)'
        line = '   DAUS Per = '//common_string
        common_int = $memory(al_entry_adrs+35, 1)
        line = line//'    Alloc Chain Pos = '//chain_pos(common_int)
      ELSEIF entry_type = 5 THEN "dmc$al_trim_file"
        display_binary_unique_name, al_entry_adrs+3, o= $fname(output_file), cs= '   GFN = '
        common_string = $strrep(($memory(al_entry_adrs+14, 3)), 16)//'(16)'
        line = '   DFL Index = '//common_string
        common_string = $strrep(($memory(al_entry_adrs+17, 3)), 16)//'(16)'
        line = line//'  DAU Adrs = '//common_string
        common_string = $strrep(($memory(al_entry_adrs+20, 3)), 16)//'(16)'
        line = line//'  DAU of Fragment = '//common_string
      IFEND
      putl line o= $fname(output_file)

    FOREND
    al_first = 0
    al_last = $value(last)
    rap_around = rap_around - 1
  UNTIL rap_around = 0

PROCEND dum$display_allocation_log
*DECK DECK=DUM$DISPLAY_ALL_FMDS EXPAND=TRUE
PROCEDURE dum$display_all_fmds, display_all_fmds, disafmds (
  pva: integer = $optional
  output, o: file = $output
  display_option, do: key
      (brief, b), (full, f)
    keyend = brief
  help, h: file = $null
  status)

  "$FORMAT=OFF"
  VAR
    when_status: status
  VAREND
  "$FORMAT=ON"

  WHEN any_fault DO
    when_status = $previous_status
    putl ' Invoked DISAFMDS condition handler due to the following abnormal status:'
    disv when_status
    putl ' Enter commands, "exit_proc" to abort, or "exit_proc with when_status" to abort with status'
    include_file command prompt='disafmds_ch'
  WHENEND

  IF $specified(help) THEN
COLLECT_TEXT o=help until='HELPEND'
DISPLAY_ALL_FMDS or DISAFMDS

  This procedure displays device manager's knowledge of a file by calling
the following procedures, passing the proper parameters to eliminate manual
intervention:

   Procedure             Passed Parameter
1. display_fmd           pva_of_fmd

The display_option and output parameters will be retained for all proce-
dures. This procedure assumes the user has previously selected the correct
exchange package by available analyze_dump commands.

PARAMETERS:

PVA: integer
  This parameter sets the PVA of the first file to be displayed.  This
parameter is required.

DISPLAY_OPTIONS, DO: key full, f, brief, b
  This parameter selects the option of displaying the contents of memory
and the description of the selected fields (full), or the brief
mode of the descriptions only.  This parameter defaults to brief.

OUTPUT, O: file
  This parameter selects the file name to receive the data.  This para-
meter is defaulted to $output.  If a file name other than $output is
entered the data will be formated correctly for printer disposition and
will be sent to the file  "$asis".

STATUS

WARNINGS/KNOWN DEFICIENCIES:

ERROR HANDLER
  When any fatal error is encountered a condition handler is invoked and
the following messages will appear:
 "Invoked DISXXX condition handler due to the following abnormal status:"
 "< the error status message >"
 "Enter commands, "exit_proc" to abort, or "exit_proc with when_status"
  to abort with status"
To exit the handler enter:    "exit_proc"
To exit the handler with status, enter:   "exit_proc with when_status"
 NOTE: XXX is the name of the procedure at the time of the error.

HELPEND
    EXIT_PROC
  IFEND

  IF NOT $specified(pva) THEN
    EXIT_PROC WITH $status(false, 'US', 8, 'Parameter PVA is required')
  IFEND

  "$FORMAT=OFF"
  VAR
    command_line: string
    fmd_p: integer
    next_fmd_p: integer
    next_fmd_pva: integer
    output_file: file
  VAREND
  "$FORMAT=ON"

  IF $file(output open_position) = '$BOI' THEN
    output_file = output.$asis
  ELSE
    output_file = output
  IFEND

  next_fmd_pva = pva

fmd_depth: ..
  REPEAT

    command_line = ' display_fmd pva='//$strrep(next_fmd_pva, 16)//'(16) output='//$strrep(output_file)//..
' display_option='//$strrep(display_option)//' next_fmd_p=next_fmd_p'
    include_line command_line
    next_fmd_pva = next_fmd_p

  UNTIL $nil_pva(next_fmd_p)

PROCEND dum$display_all_fmds
*DECK DECK=DUM$DISPLAY_ALL_IJL_ENTRIES EXPAND=TRUE
PROC dum$DISPLAY_ALL_IJL_ENTRIES display_all_ijl_entries, disaijle (
  output, o : file = $output
  )

  crev (junk ijll ijleso ijlesl)

  ijla = $mem($sa(jmv$ijl_p) 6)
  maxbn = $mem($sa(jmv$ijl_p)+18, 2)

  fetch_field_info jmt$initiated_job_list_entry field=jmt$initiated_job_list_entry junk ijll
  "Word aligned
  IF $mod(ijll, 64) <> 0 THEN
    ijll = ijll + 64 - $mod(ijll, 64)
  IFEND
  ijll = ijll / 8

  fetch_field_info jmt$initiated_job_list_entry field=entry_status offset=ijleso length=ijlesl
  ijleso = ijleso / 8
  ijlesl = ijlesl / 8

  oo = $string($value(output)) // '.$eoi'

  FOR ijlbn = 0 TO maxbn DO
    ijlb = $mem(ijla+8*ijlbn+2, 6)
    IF NOT $nil_pva(ijlb) THEN
      FOR ijlbi = 0 TO 31 DO
        ijlep = ijlb + ijlbi * ijll
        IF $mem(ijlep+ijleso, ijlesl) > 0 THEN

          putl ' ----- IJL  Entry '//$strrep(ijlbn)//'-'//$strrep(ijlbi) o=$fname(oo)
          jmt$initiated_job_list_entry ijlep o=$value(output)

        IFEND
      FOREND
    IFEND
  FOREND

PROCEND dum$display_all_ijl_entries
*DECK DECK=DUM$DISPLAY_ALL_JOB_FIXED EXPAND=TRUE
PROC dum$DISPLAY_ALL_JOB_FIXED display_all_job_fixed, disajf (
  o   : file = $local.job_fixed
  len : integer -281474976710655..281474976710655 = 32
  )

  crev s k=status
  pva = 01500000000(16)
  FOR i = 1 TO 50 DO
    dism pva $value(len) o=$fname($string($value(o))//'.$eoi') e=m status=s
    pva = pva + 100000000(16)
  FOREND

PROCEND dum$display_all_job_fixed
*DECK DECK=DUM$DISPLAY_ALL_KJLX_ENTRIES EXPAND=TRUE

PROC dum$display_all_kjlx_entries display_all_kjlx_entries, disakjlxe (
  output, o : file = $output
  status)

  kjlx_size = $mem(($sa(jmv$kjlx_p)+6) 4)
  kjlx_entry_size = $mem(($sa(jmv$kjlx_p)+14) 4)
  number_of_entries = kjlx_size / kjlx_entry_size
  FOR kjlx_index = 1 TO number_of_entries DO
    display_kjlx_entry kjlx_index $value(output)
  FOREND

PROCEND dum$display_all_kjlx_entries



*DECK DECK=DUM$DISPLAY_ALL_KJL_ENTRIES EXPAND=TRUE

PROC dum$display_all_kjl_entries display_all_kjl_entries, disakjle (
  output, o : file = $output
  status)

  kjl_size = $mem(($sa(jmv$kjl_p)+6) 4)
  kjl_entry_size = $mem(($sa(jmv$kjl_p)+14) 4)
  number_of_entries = kjl_size / kjl_entry_size
  FOR kjl_index = 1 TO number_of_entries DO
    display_kjl_entry kjl_index $value(output)
  FOREND

PROCEND dum$display_all_kjl_entries



*DECK DECK=DUM$DISPLAY_ALL_KOL_ENTRIES EXPAND=TRUE

PROC dum$display_all_kol_entries display_all_kol_entries, disakole (
  output, o : file = $output
  status)

  kol_size = $mem(($sa(jmv$kol_p)+6) 4)
  kol_entry_size = $mem(($sa(jmv$kol_p)+14) 4)
  number_of_entries = kol_size / kol_entry_size
  FOR kol_index = 1 TO number_of_entries DO
    display_kol_entry kol_index $value(output)
  FOREND

PROCEND dum$display_all_kol_entries



*DECK DECK=DUM$DISPLAY_ALL_NAMES EXPAND=TRUE
MODULE dum$display_all_names;
?? RIGHT := 110, LEFT := 1 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc dbt$entry_point_table
*copyc due$symbolic_access_exceptions
*copyc dup$display_language_variable
*copyc dup$display_string
*copyc dup$find_stack_frame_for_proc
*copyc dup$locate_next_symbol
*copyc dup$locate_symbol_for_number
*copyc dup$output_message
*copyc dut$variable_search_options
*copyc dut$variable_specification
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
?? POP ??
?? NEWTITLE := 'Global Definitions', EJECT ??
{ Note: In Basic, references to entire arrays require the array names to be appended with '()'.
{ That is to distinguish references of arrays from references of simple (i.e. non-array) variables.
{ To take care of up to 31 character names, the max name size (as expressed by osc$max_name_size)
{ has been expanded by 2.
{ Correspondingly, the item array of sym_name_list has been changed to an array of expanded names.

  CONST
    max_expanded_name_size = osc$max_name_size + 2,
    items_per_piece = 900;

  TYPE
    piece_number = 0 .. items_per_piece,
    sym_name_list_ptr = ^sym_name_list;

  TYPE
    sym_name_list = record
      forward_link: sym_name_list_ptr,
      backward_link: sym_name_list_ptr,
      number_of_items: piece_number,
      item: array [1 .. items_per_piece] of string (max_expanded_name_size),
    recend;
?? TITLE := 'dup$display_all_names', EJECT ??
*copyc duh$display_all_names

  PROCEDURE [XDCL] dup$display_all_names (
        home_spec: dut$home_specification;
        display_type: dut$display_type;
        p_variant_selection: ^clt$data_value;
    VAR display_control_pointer: ^clt$display_control;
    VAR status: ost$status);

    VAR
      active: boolean,
      message_status: ost$status,
      proc_start: ost$pva,
      target_sf: ost$pva,
      target_sf_save_area: ^ost$stack_frame_save_area,
      true_procedure_entry: dut$symbol_entry;

?? EJECT ??
{
{begin display_all_names
{

{
{Home_spec.procedure_entry could contain an llc$pascal_with_kind entry if this
{   is PASCAL.  Need to search through 'parents' to find a true procedure entry
{
    true_procedure_entry := home_spec.procedure_entry;
    IF true_procedure_entry.symbol <> NIL THEN
      WHILE true_procedure_entry.symbol^.symbol_kind <> llc$proc_kind DO
        dup$locate_symbol_for_number (home_spec.symbol_table_address,
              true_procedure_entry.symbol^.with_parent, true_procedure_entry, status);
        IF NOT status.normal THEN
          RETURN; {------->
        IFEND;
      WHILEND;
    IFEND;
{
{output 3 blank lines before starting
{
    clp$new_display_line (display_control_pointer^, 3, status);
    IF NOT status.normal THEN
      RETURN; {------->
    IFEND;
{
{output display header - if language is Cobol, go to a new page
{
    IF (home_spec.language = llc$cobol) THEN
      clp$new_display_page (display_control_pointer^, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    IFEND;
{
{ If there is no procedure ptr, only module level variables are displayed.
{
    IF true_procedure_entry.symbol = NIL THEN
      IF home_spec.symbol_table_address <> NIL THEN
        osp$set_status_abnormal (duc$symbolic_id, due$display_all_names_hdr3,
          home_spec.symbol_table_address^.original_module_name, message_status);
        dup$output_message (message_status, display_control_pointer, status);
        IF NOT status.normal THEN
          RETURN; {------->
        IFEND;
      IFEND;
      active := FALSE;
    ELSE
      osp$set_status_abnormal (duc$symbolic_id, due$display_all_names_hdr1,
             true_procedure_entry.symbol^.symbol_name, message_status);
      dup$output_message (message_status, display_control_pointer, status);
      IF NOT status.normal THEN
        RETURN; {------->
      IFEND;
{
{determine if the requested procedure is active.  otherwise, only static
{variables can be displayed.
{
      active := TRUE;
      IF home_spec.proc_recursion_level <> 0 THEN
        proc_start := home_spec.module_item^.section_item
                [true_procedure_entry.symbol^.proc_section_ordinal].address;
        proc_start.offset := proc_start.offset + true_procedure_entry.symbol^.proc_offset;
        dup$find_stack_frame_for_proc (proc_start, true_procedure_entry.symbol^.proc_length,
                    home_spec.stack_search_direction, home_spec.proc_recursion_level,
                    target_sf, target_sf_save_area, status);
        IF NOT status.normal THEN
{
{assume procedure is not active and output a second header line
{
          status.normal := TRUE;
          osp$set_status_abnormal (duc$symbolic_id, due$display_all_names_hdr2,
                       true_procedure_entry.symbol^.symbol_name, message_status);
          dup$output_message (message_status, display_control_pointer, status);
          IF NOT status.normal THEN
            RETURN; {------->
          IFEND;
          active := FALSE;
        IFEND;     { If NOT status.normal }
      IFEND;    { If recursion level <> 0 }
    IFEND;   {If true_procedure_entry.symbol <> NIL }
{
{output a blank line
{
    clp$new_display_line (display_control_pointer^, 1, status);
    IF NOT status.normal THEN
      RETURN; {------->
    IFEND;
{
{call a different procedure to process each different language
{
    CASE home_spec.language OF
    = llc$fortran =
      osp$set_status_abnormal (duc$symbolic_id, due$unsupported_language, 'Fortran', status);
    = llc$cobol =
      osp$set_status_abnormal (duc$symbolic_id, due$unsupported_language, 'Cobol', status);
    ELSE
      display_all_cybil_names (home_spec, display_type, active, p_variant_selection,
            display_control_pointer, status);
    CASEND;
  PROCEND dup$display_all_names;
?? TITLE := 'display_all_cybil_names', EJECT ??

  PROCEDURE display_all_cybil_names (
        home_spec: dut$home_specification;
        display_type: dut$display_type;
        active: boolean;
        p_variant_selection: ^clt$data_value;
    VAR display_control_pointer: ^clt$display_control;
    VAR status: ost$status);

    TYPE
      base_type = set of llt$base_type;

    CONST
      bytes_per_word = 8,
      bits_per_byte = 8,
      reserved_stack_space = bytes_per_word * 2,
      right_justified_offset = 2;

    VAR
      first_level: boolean,
      interesting_bases: base_type,
      local_status: ost$status,
      message_status: ost$status,
      current_piece_ptr: sym_name_list_ptr,
      desired_index: piece_number,
      expanded_symbol_name: string (max_expanded_name_size),
      first_piece: sym_name_list,
      i: piece_number,
      j: sym_name_list_ptr,
      l: 1 .. max_expanded_name_size,
      last_piece_ptr: sym_name_list_ptr,
      new_piece_ptr: sym_name_list_ptr,
      place_to_stop: piece_number,
      end_of_chain: boolean,
      symbol_table_address: ^llt$debug_symbol_table,
      tmp_home_spec: dut$home_specification,
      current_proc: dut$symbol_entry,
      module_level_searched: boolean,
      nested_proc: boolean,
      search_options: dut$variable_search_options,
      symbol_item: llt$symbol_table_item,
      symbol_entry: dut$symbol_entry;

    VAR
      char_index: 1 .. max_expanded_name_size,
      var_type_symbol_entry: dut$symbol_entry;
?? NEWTITLE := 'allocate_more_space', EJECT ??

    PROCEDURE [INLINE] allocate_more_space;
      IF last_piece_ptr^.forward_link = NIL THEN
{ Need to allocate a new piece }
        PUSH new_piece_ptr;
        IF new_piece_ptr = NIL THEN
          osp$set_status_abnormal (duc$symbolic_id, due$internal_error,
            'Debug cannot allocate enough stack space to complete the requested display.', status);
          RETURN; {----->
        IFEND;
        last_piece_ptr^.forward_link := new_piece_ptr;
        new_piece_ptr^.backward_link := last_piece_ptr;
        last_piece_ptr := new_piece_ptr;
        last_piece_ptr^.forward_link := NIL;
      ELSE
{ Next piece already there
        last_piece_ptr := last_piece_ptr^.forward_link;
      IFEND;
      last_piece_ptr^.number_of_items := 0;
    PROCEND allocate_more_space;
?? TITLE := 'add_new_item', EJECT ??

    PROCEDURE [INLINE] add_new_item;

            expanded_symbol_name := symbol_item.symbol_name;

{ If the symbol_name is a Basic array name, expand that name with '()'.

            IF home_spec.language = llc$basic THEN
              dup$locate_symbol_for_number (home_spec.symbol_table_address, symbol_entry.symbol^.var_type,
                    var_type_symbol_entry, status);
              IF var_type_symbol_entry.symbol^.symbol_kind = llc$basic_array_kind THEN
              /search_for_end_of_name/
                FOR char_index := 1 TO max_expanded_name_size DO
                  IF expanded_symbol_name (char_index) = ' ' THEN
                    expanded_symbol_name(char_index, 2) := '()';
                    EXIT /search_for_end_of_name/;
                  IFEND;
                FOREND;
              IFEND;
            IFEND;

{If this is the first item, put it into the first slot.

      IF first_piece.number_of_items = 0 THEN
        first_piece.item [1] := expanded_symbol_name;
        first_piece.number_of_items := 1;
        RETURN; {----->
      IFEND;

{If the new item goes after the last one, add it to the end.

      IF (expanded_symbol_name >= last_piece_ptr^.item [last_piece_ptr^.number_of_items]) THEN
        IF (last_piece_ptr^.number_of_items = items_per_piece) THEN
          allocate_more_space;
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;
        last_piece_ptr^.number_of_items := last_piece_ptr^.number_of_items + 1;
        last_piece_ptr^.item [last_piece_ptr^.number_of_items] := expanded_symbol_name;
        RETURN; {----->
      IFEND;

{Find the correct place in the table so that items remained sorted.

      current_piece_ptr := ^first_piece;

    /loop1/
      WHILE TRUE DO
        FOR i := 1 TO current_piece_ptr^.number_of_items DO
          IF expanded_symbol_name <= current_piece_ptr^.item [i] THEN
            desired_index := i;
            EXIT /loop1/;
          IFEND;
        FOREND;
        IF current_piece_ptr^.forward_link = NIL THEN
          desired_index := current_piece_ptr^.number_of_items;
          EXIT /loop1/;
        IFEND;
        current_piece_ptr := current_piece_ptr^.forward_link;
      WHILEND /loop1/;

{Put new symbol before theone pointed to by current_piece_ptr indexed by
{desired_index, pushing down following entries.

      j := last_piece_ptr;

    /loop2/
      WHILE TRUE DO
        IF j = current_piece_ptr THEN
          place_to_stop := desired_index;
        ELSE
          place_to_stop := 1;
        IFEND;
        IF j^.number_of_items = items_per_piece THEN
          IF j^.forward_link = NIL THEN
            allocate_more_space;
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;
          j^.forward_link^.item [1] := j^.item [items_per_piece];
          j^.forward_link^.number_of_items := j^.forward_link^.number_of_items + 1;
          j^.number_of_items := j^.number_of_items - 1;
        IFEND;
        FOR i := j^.number_of_items DOWNTO place_to_stop DO
          j^.item [i + 1] := j^.item [i];
        FOREND;
        IF j = current_piece_ptr THEN
          EXIT /loop2/;
        IFEND;
        j := j^.backward_link;
      WHILEND /loop2/;
      current_piece_ptr^.item [desired_index] := expanded_symbol_name;
      current_piece_ptr^.number_of_items := current_piece_ptr^.number_of_items + 1;
    PROCEND add_new_item;
?? TITLE := 'calculate_trailing_blanks', EJECT ??

    PROCEDURE [INLINE] calculate_trailing_blanks;

    /calc_loop/
      FOR l := max_expanded_name_size DOWNTO 1 DO
        IF j^.item [i] (l, 1) <> ' ' THEN
          EXIT /calc_loop/;
        IFEND;
      FOREND /calc_loop/;
    PROCEND calculate_trailing_blanks;

?? OLDTITLE ??
?? EJECT ??
{This begins procedure 'display_all_cybil_names'.

{In Cybil, name=$all means all symbols from the symbol table of symbol_kind llc$var_kind and
{llc$constant_kind.  If the requested procedure is not active, then only those symbols whose base type
{is llc$static_base can be output.  The symbols are sorted before being printed.

    first_level := TRUE;    {Don't put out header the first time}

{Initialization for sort.

    first_piece.forward_link := NIL;
    first_piece.backward_link := NIL;

{ Set up search options depending on the language

    tmp_home_spec := home_spec;
    CASE home_spec.language OF
    = llc$basic,
      llc$pascal,
      llc$the_c_language =
      search_options := $dut$variable_search_options [
                   duc$search_outer_procedures];
    ELSE
      search_options := $dut$variable_search_options [
                   duc$search_outer_procedures, duc$search_module_level];
    CASEND;

{Determine base type.

    symbol_table_address := home_spec.symbol_table_address;
    local_status.normal := TRUE;
    IF active THEN
      interesting_bases := $base_type [llc$static_base, llc$stack_frame_base, llc$parm_list_base,
            llc$xref_base];
    ELSE
      interesting_bases := $base_type [llc$static_base, llc$xref_base];
    IFEND;

    current_proc := home_spec.procedure_entry;
    IF current_proc.symbol <> NIL THEN
{ Make sure current_proc isn't a PASCAL WITH block entry }
      WHILE current_proc.symbol^.symbol_kind <> llc$proc_kind DO
        dup$locate_symbol_for_number (home_spec.symbol_table_address, current_proc.symbol^.with_parent,
              current_proc, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      WHILEND;
    IFEND;
    module_level_searched := FALSE;
    end_of_chain := FALSE;

    REPEAT
    { Reset the symbol name area }
      first_piece.number_of_items := 0;
      last_piece_ptr := ^first_piece;

    /search_lexical_level/
      BEGIN
        IF current_proc.symbol <> NIL THEN
          IF current_proc.symbol^.first_symbol_for_proc = 0 THEN
            EXIT /search_lexical_level/; {no symbols at this level}
          IFEND;
          dup$locate_symbol_for_number (home_spec.symbol_table_address, current_proc.symbol^.
                first_symbol_for_proc, symbol_entry, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        ELSE
          module_level_searched := TRUE;
          dup$locate_symbol_for_number (home_spec.symbol_table_address, home_spec.symbol_table_address^.
                first_symbol_for_module, symbol_entry, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;

        REPEAT
          IF ((symbol_entry.symbol^.symbol_kind = llc$var_kind) AND (symbol_entry.symbol^.var_base IN
                interesting_bases)) OR ((symbol_entry.symbol^.symbol_kind = llc$constant_kind) AND
                (symbol_entry.symbol^.symbol_name <> osc$null_name)) THEN
            symbol_item := symbol_entry.symbol^;
            add_new_item;
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;
          IF (symbol_entry.symbol = NIL) OR (symbol_entry.symbol^.end_of_chain) THEN
            EXIT /search_lexical_level/;
          IFEND;
          dup$locate_next_symbol (home_spec.symbol_table_address, symbol_entry, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        UNTIL end_of_chain;
      END /search_lexical_level/;

      tmp_home_spec.procedure_entry := current_proc;
      IF first_level THEN
        first_level := FALSE;
      ELSE
        IF current_proc.symbol <> NIL THEN
          osp$set_status_abnormal (duc$symbolic_id, due$display_all_names_hdr1,
                   current_proc.symbol^.symbol_name, message_status);
          dup$output_message (message_status, display_control_pointer, status);
        ELSE
{ CYBIL module names are case sensitive.  Make them upper case.  This code
{  should be removed when CYBIL changes to upper case. 7/86.
          expanded_symbol_name := home_spec.symbol_table_address^.original_module_name;
          IF (home_spec.language = llc$cybil) OR (home_spec.language = llc$obsolete_cybil) THEN
            #TRANSLATE (osv$lower_to_upper, expanded_symbol_name, expanded_symbol_name);
          IFEND;
          osp$set_status_abnormal (duc$symbolic_id, due$display_all_names_hdr3,
                        expanded_symbol_name, message_status);
          dup$output_message (message_status, display_control_pointer, status);
        IFEND;
        clp$new_display_line (display_control_pointer^, 1, status);
        IF NOT status.normal THEN
          RETURN; {------->
        IFEND;
      IFEND;
      IF first_piece.number_of_items = 0 THEN
        osp$set_status_abnormal (duc$symbolic_id, due$no_vars_found, osc$null_name, message_status);
        dup$output_message (message_status, display_control_pointer, status);
      IFEND;
      j := ^first_piece;

    /display_loop/
      WHILE j <> NIL DO
        FOR i := 1 TO j^.number_of_items DO
          calculate_trailing_blanks;

          dup$display_language_variable (^j^.item [i] (1, l), tmp_home_spec, display_type,
                     p_variant_selection, display_control_pointer, local_status);
          IF NOT local_status.normal THEN
            clp$new_display_line (display_control_pointer^, 0, status);
            dup$output_message (local_status, display_control_pointer, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            local_status.normal := TRUE;
          IFEND;
        FOREND;
        j := j^.forward_link;
      WHILEND /display_loop/;
      clp$new_display_line (display_control_pointer^, 1, status);

{Check the next outer level of procedure nesting if there is one.

      IF (current_proc.symbol <> NIL) AND
         (NOT (duc$search_outer_procedures IN search_options)) AND
         (NOT (llc$proc_uses_outer_level_stack IN current_proc.symbol^.proc_attributes)) THEN
        current_proc.symbol := NIL;
      IFEND;
      IF current_proc.symbol <> NIL THEN
        IF current_proc.symbol^.proc_parent = 0 THEN
          current_proc.symbol := NIL;
        ELSE
          nested_proc := TRUE;
          dup$locate_symbol_for_number (home_spec.symbol_table_address, current_proc.symbol^.proc_parent,
                current_proc, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;
      IFEND;
      IF (current_proc.symbol = NIL) AND
         (NOT(duc$search_module_level IN search_options)) THEN
        module_level_searched := TRUE;
      IFEND;
    UNTIL module_level_searched;
    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND display_all_cybil_names;
?? OLDTITLE ??
MODEND dum$display_all_names;
*DECK DECK=DUM$DISPLAY_ALL_RECORD_NAMES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display All Record Names Command' ??
MODULE dum$display_all_record_names;

{ PURPOSE:
{   This module contains the code for the display_all_record_names command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$new_page_procedure
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_all_record_names', EJECT ??

{ PURPOSE:
{   This procedure displays a list of the all records that exist on the restart file.

  PROCEDURE [XDCL] dup$display_all_record_names
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_all_record_names, disarn, display_record_list, disrl, display_dump_record_list, disdrl (
{   output, o: file
{   title, t: string 1..31 = 'display_all_record_names'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (26),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 9, 11, 13, 9, 0, 368],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TITLE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 26],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_all_record_names'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$title = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    CONST
      c$procedure_table_index = 52;

    TYPE
      t$data_line = RECORD
        CASE boolean OF
        = TRUE =
          line: string (75),
        = FALSE =
          unused_1: string (1),
          record_number: string (9),
          unused_2: string (3),
          record_name: string (6),
          unused_3: string (3),
          record_type: string (6),
          unused_4: string (3),
          record_length: string (10),
          unused_5: string (3),
          command_name: string (31),
        CASEND,
      RECEND,

      t$procedure_table = RECORD
        record_name: string (3),
        procedure_name: string (31),
      RECEND,

      t$title_line = RECORD
        CASE boolean OF
        = TRUE =
          line: string (75),
        = FALSE =
          unused_1: string (1),
          record_number: string (9),
          unused_2: string (3),
          record_name: string (6),
          unused_3: string (3),
          record_type: string (6),
          unused_4: string (3),
          record_length: string (10),
          unused_5: string (3),
          command_name: string (31),
        CASEND,
      RECEND;

    VAR
      cell_p: ^cell,
      data_line: t$data_line,
      data_to_display: boolean,
      display_control: clt$display_control,
      entries_left: boolean,
      entry_p: ^dut$de_other_record_entry,
      ignore_status: ost$status,
      integer_string: ost$string,
      list_index: 0 .. duc$de_max_other_records,
      max_index: 0 .. duc$de_max_other_records,
      min_index: 0 .. duc$de_max_other_records,
      new_entry_found: boolean,
      number_size: integer,
      output_display_opened: boolean,
      previous_name: dut$de_other_record_name,
      procedure_table_index: 0 .. c$procedure_table_index,
      record_length: amt$file_byte_address,
      record_name: string (3),
      restart_file_seq_p: ^SEQ ( * ),
      ring_attributes: amt$ring_attributes,
      title_line: t$title_line,
      total_length: 0 .. 0ffffffff(16);

    VAR
      procedure_table: [STATIC] ARRAY [1 .. c$procedure_table_index] OF t$procedure_table :=
            [['AE0', 'DISPLAY_ALTERNATE_IOU_EC'],
             ['AE1', 'DISPLAY_ALTERNATE_IOU_EC'],
             ['AIC', 'DISPLAY_ALTERNATE_IOU_CONFIG'],
             ['BC ', 'DISPLAY_BUFFER_CONTROLWARE'],
             ['BXX', 'DISPLAY_B_ANC_C_REGISTERS'],
             ['BX1', 'DISPLAY_B_ANC_C_REGISTERS'],
             ['CC1', 'DISPLAY_CIO_REGISTERS'],
             ['CCM', 'DISPLAY_MEMORY'],
             ['CCR', 'DISPLAY_CIO_REGISTERS'],
             ['CS1', 'DISPLAY_CHANNEL_STATUS_FLAGS'],
             ['CSF', 'DISPLAY_CHANNEL_STATUS_FLAGS'],
             ['CSI', 'DISPLAY_PC_CONSOLE_INFORMATION'],
             ['CXX', 'DISPLAY_B_ANC_C_REGISTERS'],
             ['CX1', 'DISPLAY_B_ANC_C_REGISTERS'],
             ['DID', 'DISPLAY_DUMP_INFORMATION'],
             ['DFT', 'PROCESS_DFT_BUFFER'],
             ['DSB', 'DISPLAY_DUAL_STATE_BUFFER'],
             ['DXX', 'DISPLAY_PP_MEMORY'],
             ['ECR', 'DISPLAY_ENVIRONMENT_CONTROL'],
             ['EC1', 'DISPLAY_ENVIRONMENT_CONTROL'],
             ['EXX', 'DISPLAY_PP_MEMORY'],
             ['FSM', 'DISPLAY_FAULT_STATUS_MASK'],
             ['FS1', 'DISPLAY_FAULT_STATUS_MASK'],
             ['IM1', 'DISPLAY_MAINTENANCE_REGISTER'],
             ['IMR', 'DISPLAY_MAINTENANCE_REGISTER'],
             ['IXX', 'DISPLAY_PP_MEMORY'],
             ['JXX', 'DISPLAY_PP_MEMORY'],
             ['JP0', 'DISPLAY_EXCHANGE_PACKAGE'],
             ['JP1', 'DISPLAY_EXCHANGE_PACKAGE'],
             ['JPS', 'DISPLAY_EXCHANGE_PACKAGE'],
             ['MEM', 'DISPLAY_MEMORY'],
             ['MMR', 'DISPLAY_MAINTENANCE_REGISTER'],
             ['MP0', 'DISPLAY_EXCHANGE_PACKAGE'],
             ['MP1', 'DISPLAY_EXCHANGE_PACKAGE'],
             ['MPS', 'DISPLAY_EXCHANGE_PACKAGE'],
             ['MSR', 'DISPLAY_MAC_SOFT_REGISTERS'],
             ['PCS', 'DISPLAY_CONTROL_STORE'],
             ['PR0', 'DISPLAY_MAINTENANCE_REGISTER'],
             ['PR1', 'DISPLAY_MAINTENANCE_REGISTER'],
             ['PMR', 'DISPLAY_MAINTENANCE_REGISTER'],
             ['PPR', 'DISPLAY_PP_REGISTERS'],
             ['PRF', 'DISPLAY_REGISTER_FILE'],
             ['PS1', 'DISPLAY_PP_REGISTERS'],
             ['PSR', 'DISPLAY_PP_REGISTERS'],
             ['PX0', 'DISPLAY_EXCHANGE_PACKAGE'],
             ['PX1', 'DISPLAY_EXCHANGE_PACKAGE'],
             ['PXP', 'DISPLAY_EXCHANGE_PACKAGE'],
             ['RFP', 'DISPLAY_S0_REGISTER_FILE'],
             ['RFS', 'DISPLAY_S0_REGISTER_FILE'],
             ['RF1', 'DISPLAY_S0_REGISTER_FILE'],
             ['RS1', 'DISPLAY_S0_REGISTER_FILE'],
             ['SXX', 'DISPLAY_PP_MEMORY']];

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

      { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      { Add to the main title.

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      { Determine if any records exist on the list.

      IF NOT duv$dump_environment_p^.other_records.available THEN
        data_line.line := ' No records available.';
        clp$put_display (display_control, data_line.line, clc$trim, ignore_status);
        EXIT /display_opened/;  {---->
      IFEND;

      { Display the title line.

      title_line.line := ' ';
      title_line.record_number := 'Record';
      title_line.record_name := 'Record';
      title_line.record_type := 'Record';
      title_line.record_length := 'Record';
      title_line.command_name := 'Command';
      clp$put_display (display_control, title_line.line, clc$trim, ignore_status);

      title_line.line := ' ';
      title_line.record_number := 'Number';
      title_line.record_name := 'Name';
      title_line.record_type := 'Type';
      title_line.record_length := 'Length';
      title_line.command_name := 'Name';
      clp$put_display (display_control, title_line.line, clc$trim, ignore_status);

      title_line.line := ' ';
      title_line.record_number := '---------';
      title_line.record_name := '------';
      title_line.record_type := '------';
      title_line.record_length := '----------';
      title_line.command_name := '-------------------------------';
      clp$put_display (display_control, title_line.line, clc$trim, ignore_status);

      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),
            duv$dump_environment_p^.other_records.first_record);

      previous_name := ' ';
      min_index := 0;
      max_index := 0;
      total_length := 0;

      data_to_display := FALSE;
      list_index := 1;
      entries_left := (duv$dump_environment_p^.other_records.number_of_records >= 1);
      WHILE entries_left OR data_to_display DO
        IF list_index <= duv$dump_environment_p^.other_records.number_of_records THEN
          RESET restart_file_seq_p TO cell_p;
          NEXT entry_p IN restart_file_seq_p;
          entries_left := (entry_p <> NIL);
          list_index := list_index + 1;
        ELSE
          entries_left := FALSE;
        IFEND;
        new_entry_found := entries_left;
        IF data_to_display THEN
          IF entries_left AND (entry_p^.name = previous_name) THEN
            total_length := total_length + entry_p^.size;
            max_index := entry_p^.index;
            new_entry_found := FALSE;
            data_to_display := TRUE;
          ELSE
            clp$convert_integer_to_string (min_index, 10, FALSE, integer_string, ignore_status);
            data_line.record_number := integer_string.value (1, integer_string.size);
            IF max_index > 0 THEN
              number_size := integer_string.size;
              data_line.record_number (number_size + 1, 1) := '-';
              number_size := number_size + 1;
              clp$convert_integer_to_string (max_index, 10, FALSE, integer_string, ignore_status);
              data_line.record_number (number_size + 1, *) := integer_string.value (1, integer_string.size);
            IFEND;
            clp$convert_integer_to_string (total_length, 10, FALSE, integer_string, ignore_status);
            data_line.record_length := integer_string.value (1, integer_string.size);
            clp$put_display (display_control, data_line.line, clc$trim, ignore_status);
            data_to_display := FALSE;
          IFEND;
        IFEND;
        IF new_entry_found THEN
          data_line.line := ' ';
          min_index := entry_p^.index;
          max_index := 0;
          previous_name := entry_p^.name;
          data_line.record_name := entry_p^.name;
          IF entry_p^.record_type = duc$de_ort_detail THEN
            data_line.record_type := 'Detail';
            data_line.command_name := 'No existing procedure';
          ELSEIF entry_p^.record_type = duc$de_ort_dump THEN
            data_line.record_type := 'Dump';
            data_line.command_name := 'DISPLAY_DUMP_RECORD';
          ELSE
            data_line.record_type := 'Report';
            data_line.command_name := 'DISPLAY_REPORT_RECORD';
          IFEND;
          total_length := entry_p^.size;

          record_name := entry_p^.name;
          CASE record_name (1) OF
          = 'I', 'J', 'D', 'E', 'S' =
            CASE record_name (2) OF
            = '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' =
              record_name (2, *) := 'XX';
            ELSE
            CASEND;
          ELSE
          CASEND;

         /locate_procedure_name/
          FOR procedure_table_index := 1 TO c$procedure_table_index DO
            IF record_name = procedure_table [procedure_table_index].record_name THEN
              data_line.command_name := procedure_table [procedure_table_index].procedure_name;
              EXIT /locate_procedure_name/;  {---->
            IFEND;
          FOREND /locate_procedure_name/;
          data_to_display := TRUE;
        IFEND;
        IF entries_left AND (entry_p^.name = 'CCM') AND
              duv$dump_environment_p^.critical_memory.multiple_ccm_exists THEN
          total_length := duv$dump_environment_p^.critical_memory.total_ccm_size;
          cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),
                duv$dump_environment_p^.critical_memory.last_ccm_other_record);
          RESET restart_file_seq_p TO cell_p;
          NEXT entry_p IN restart_file_seq_p;
          IF entry_p = NIL THEN
            entries_left := FALSE;
          ELSE
            list_index := entry_p^.index + 1;
            max_index := entry_p^.index;
          IFEND;
        IFEND;
        IF entries_left THEN
          cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),
                entry_p^.next_record);
        IFEND;
      WHILEND;

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_all_record_names;
MODEND dum$display_all_record_names;
*DECK DECK=DUM$DISPLAY_ALTERNATE_IOU_CONF EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Alternate IOU Configuration Command' ??
MODULE dum$display_alternate_iou_conf;

{ PURPOSE:
{   This module contains the command which displays the alternate IOU configuration information
{   that is stored in the AIC record.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$find_record_list_entry
*copyc dup$new_page_procedure
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_alternate_iou_conf', EJECT ??

{ PURPOSE:
{   This procedure displays the alternate iou configuration information.

  PROCEDURE [XDCL] dup$display_alternate_iou_conf
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_alternate_iou_config, disaic (
{   output, o: file = $optional
{   title, t: string 1..31 = 'display_alternate_iou_config'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (30),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 8, 31, 11, 48, 53, 171],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TITLE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 30],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_alternate_iou_config'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$title = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    TYPE
      t$bits_or_byte = PACKED RECORD
        CASE boolean OF
        = TRUE =
          bit_part: PACKED ARRAY [56 .. 63] OF boolean,
        = FALSE =
          byte_part: 0 .. 0ff(16),
        CASEND,
      RECEND,

      t$record_data = PACKED RECORD
        general_status: t$record_data_entry,
        configuration_status: t$record_data_entry,
        iou_power_on_status: t$record_data_entry,
        iou_present_status: t$record_data_entry,
        last_initiated_ds_status: t$record_data_entry,
        reserved_1: t$record_data_entry,
        reserved_2: t$record_data_entry,
        iou0_model_number: t$record_data_entry,
        reserved_3: t$record_data_entry,
        iou1_model_number: t$record_data_entry,
        reserved_4: t$record_data_entry,
        iou0_tpm_revision_msb: t$record_data_entry,
        iou0_tpm_revision_lsb: t$record_data_entry,
        iou1_tpm_revision_msb: t$record_data_entry,
        iou1_tpm_revision_lsb: t$record_data_entry,
      RECEND,

      t$record_data_entry = PACKED RECORD
        unused: 0 .. 0f(16),
        data: t$bits_or_byte,
      RECEND;

    VAR
      cell_p: ^cell,
      data_value: clt$data_value,
      display_control: clt$display_control,
      display_string: string (osc$max_string_size),
      entry_p: ^dut$de_other_record_entry,
      ignore_status: ost$status,
      output_display_opened: boolean,
      record_data_p: ^t$record_data,
      restart_file_seq_p: ^SEQ ( * ),
      ring_attributes: amt$ring_attributes,
      string_6: string (6),
      string_length: integer;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

    { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      data_value.kind := clc$name;
      data_value.name_value := 'AIC';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The AIC record is',
              status);
        EXIT /display_opened/;  {---->
      IFEND;

      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);
      RESET restart_file_seq_p TO cell_p;

      IF #SIZE (t$record_data) > entry_p^.size THEN
        clp$put_display (display_control, 'ERROR - Not enough data in the record, data not displayed.',
              clc$trim, ignore_status);
        EXIT /display_opened/;  {---->
      IFEND;

      NEXT record_data_p IN restart_file_seq_p;

      clp$put_display (display_control, 'AIC - Alternate IOU Configuration Record:', clc$trim,
            ignore_status);
      clp$put_display (display_control, ' ', clc$trim, ignore_status);

      clp$convert_integer_to_rjstring (record_data_p^.general_status.data.byte_part, 16, TRUE, '0',
            string_6, ignore_status);
      STRINGREP (display_string, string_length, ' General Status Byte = ', string_6);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
      IF record_data_p^.general_status.data.bit_part [63] THEN
        clp$put_display (display_control, '   bit 63 = 1; CMSE Load Only', clc$trim, ignore_status);
      ELSE
        clp$put_display (display_control, '   bit 63 = 0; Default System Load', clc$trim, ignore_status);
      IFEND;

      clp$convert_integer_to_rjstring (record_data_p^.configuration_status.data.byte_part, 16, TRUE, '0',
            string_6, ignore_status);
      STRINGREP (display_string, string_length, ' Configuration/Status Byte = ', string_6);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
      IF record_data_p^.configuration_status.data.bit_part [56] THEN
        clp$put_display (display_control, '   bit 56 = 1; Identifies Multiple IOU Configuration', clc$trim,
              ignore_status);
      IFEND;
      IF record_data_p^.configuration_status.data.bit_part [60] THEN
        clp$put_display (display_control, '   bit 60 = 1; Identifies IOU3', clc$trim, ignore_status);
      IFEND;
      IF record_data_p^.configuration_status.data.bit_part [61] THEN
        clp$put_display (display_control, '   bit 61 = 1; Identifies IOU2', clc$trim, ignore_status);
      IFEND;
      IF record_data_p^.configuration_status.data.bit_part [62] THEN
        clp$put_display (display_control, '   bit 62 = 1; Identifies IOU1', clc$trim, ignore_status);
      IFEND;
      IF record_data_p^.configuration_status.data.bit_part [63] THEN
        clp$put_display (display_control, '   bit 63 = 1; Identifies IOU0', clc$trim, ignore_status);
      IFEND;

      clp$convert_integer_to_rjstring (record_data_p^.iou_power_on_status.data.byte_part, 16, TRUE, '0',
            string_6, ignore_status);
      STRINGREP (display_string, string_length, ' IOU Power-On Status Byte = ', string_6);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
      IF record_data_p^.iou_power_on_status.data.bit_part [60] THEN
        clp$put_display (display_control, '   bit 60 = 1; IOU3 Power On', clc$trim, ignore_status);
      IFEND;
      IF record_data_p^.iou_power_on_status.data.bit_part [61] THEN
        clp$put_display (display_control, '   bit 61 = 1; IOU2 Power On', clc$trim, ignore_status);
      IFEND;
      IF record_data_p^.iou_power_on_status.data.bit_part [62] THEN
        clp$put_display (display_control, '   bit 62 = 1; IOU1 Power On', clc$trim, ignore_status);
      IFEND;
      IF record_data_p^.iou_power_on_status.data.bit_part [63] THEN
        clp$put_display (display_control, '   bit 63 = 1; IOU0 Power On', clc$trim, ignore_status);
      IFEND;

      clp$convert_integer_to_rjstring (record_data_p^.iou_present_status.data.byte_part, 16, TRUE, '0',
            string_6, ignore_status);
      STRINGREP (display_string, string_length, ' IOU Present Status Byte = ', string_6);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
      IF record_data_p^.iou_present_status.data.bit_part [60] THEN
        clp$put_display (display_control, '   bit 60 = 1; IOU3 Present', clc$trim, ignore_status);
      IFEND;
      IF record_data_p^.iou_present_status.data.bit_part [61] THEN
        clp$put_display (display_control, '   bit 61 = 1; IOU2 Present', clc$trim, ignore_status);
      IFEND;
      IF record_data_p^.iou_present_status.data.bit_part [62] THEN
        clp$put_display (display_control, '   bit 62 = 1; IOU1 Present', clc$trim, ignore_status);
      IFEND;
      IF record_data_p^.iou_present_status.data.bit_part [63] THEN
        clp$put_display (display_control, '   bit 63 = 1; IOU0 Present', clc$trim, ignore_status);
      IFEND;

      clp$convert_integer_to_rjstring (record_data_p^.last_initiated_ds_status.data.byte_part, 16, TRUE, '0',
            string_6, ignore_status);
      STRINGREP (display_string, string_length, ' Last Initiated DS Status Byte = ', string_6);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
      IF record_data_p^.last_initiated_ds_status.data.bit_part [60] THEN
        clp$put_display (display_control, '   bit 60 = 1; Remote Terminal Initiated Deadstart', clc$trim,
              ignore_status);
      IFEND;
      IF record_data_p^.last_initiated_ds_status.data.bit_part [61] THEN
        clp$put_display (display_control, '   bit 61 = 1; Alternate Console Initiated Deadstart', clc$trim,
              ignore_status);
      IFEND;
      IF record_data_p^.last_initiated_ds_status.data.bit_part [62] THEN
        clp$put_display (display_control, '   bit 62 = 1; PC Console Initiated Deadstart', clc$trim,
              ignore_status);
      IFEND;
      IF record_data_p^.last_initiated_ds_status.data.bit_part [63] THEN
        clp$put_display (display_control, '   bit 63 = 1; CC545 Initiated Deadstart', clc$trim,
              ignore_status);
      IFEND;

      clp$convert_integer_to_rjstring (record_data_p^.reserved_1.data.byte_part, 16, TRUE, '0',
            string_6, ignore_status);
      STRINGREP (display_string, string_length, ' Reserved Byte = ', string_6);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

      clp$convert_integer_to_rjstring (record_data_p^.reserved_2.data.byte_part, 16, TRUE, '0',
            string_6, ignore_status);
      STRINGREP (display_string, string_length, ' Reserved Byte = ', string_6);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

      clp$convert_integer_to_rjstring (record_data_p^.iou0_model_number.data.byte_part, 16, TRUE, '0',
            string_6, ignore_status);
      STRINGREP (display_string, string_length, ' IOU0 Model Number = ', string_6);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

      clp$convert_integer_to_rjstring (record_data_p^.reserved_3.data.byte_part, 16, TRUE, '0',
            string_6, ignore_status);
      STRINGREP (display_string, string_length, ' Reserved Byte = ', string_6);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

      clp$convert_integer_to_rjstring (record_data_p^.iou1_model_number.data.byte_part, 16, TRUE, '0',
            string_6, ignore_status);
      STRINGREP (display_string, string_length, ' IOU1 Model Number = ', string_6);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

      clp$convert_integer_to_rjstring (record_data_p^.reserved_4.data.byte_part, 16, TRUE, '0',
            string_6, ignore_status);
      STRINGREP (display_string, string_length, ' Reserved Byte = ', string_6);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

      clp$convert_integer_to_rjstring (record_data_p^.iou0_tpm_revision_msb.data.byte_part, 16, TRUE, '0',
            string_6, ignore_status);
      STRINGREP (display_string, string_length, ' IOU0 TPM Firmware Revision Number (MSB) = ', string_6);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

      clp$convert_integer_to_rjstring (record_data_p^.iou0_tpm_revision_lsb.data.byte_part, 16, TRUE, '0',
            string_6, ignore_status);
      STRINGREP (display_string, string_length, ' IOU0 TPM Firmware Revision Number (LSB) = ', string_6);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

      clp$convert_integer_to_rjstring (record_data_p^.iou1_tpm_revision_msb.data.byte_part, 16, TRUE, '0',
            string_6, ignore_status);
      STRINGREP (display_string, string_length, ' IOU1 TPM Firmware Revision Number (MSB) = ', string_6);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

      clp$convert_integer_to_rjstring (record_data_p^.iou1_tpm_revision_lsb.data.byte_part, 16, TRUE, '0',
            string_6, ignore_status);
      STRINGREP (display_string, string_length, ' IOU1 TPM Firmware Revision Number (LSB) = ', string_6);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_alternate_iou_conf;
MODEND dum$display_alternate_iou_conf;
*DECK DECK=DUM$DISPLAY_ALTERNATE_IOU_EC EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Alternate IOU Environment Control Command' ??
MODULE dum$display_alternate_iou_ec;

{ PURPOSE:
{   This module contains the command which displays the alternate environment control information
{   that is stored in the AE0 and AE1 records.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$determine_dump_information
*copyc dup$display_register_data
*copyc dup$find_record_list_entry
*copyc dup$new_page_procedure
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  CONST
    c$number_of_bytes = 8;

  TYPE
    t$record_data = PACKED ARRAY [1 .. c$number_of_bytes] OF t$record_data_entry,

    t$record_data_entry = PACKED RECORD
      unused: 0 .. 0f(16),
      byte_part: 0 .. 0ff(16),
    RECEND;

    VAR
      v$bit_descriptions: [STATIC] ARRAY [0 .. 63] OF string (35) :=
            [REP 32 OF ' ', '8K PP Memory', 'System Initialization', REP 17 OF ' ', 'Load Mode', 'Dump Mode',
             'Idle Mode', REP 2 OF ' ', 'Clock Wide', 'Clock Narrow', 'Enable Deadstart/Dump/Idle',
             'Enable Testmode', 'Enable O.S. Bounds Checking', 'Enable (R)+(A) to PP Memory',
             'Individual Channel MC', 'Enable Error Stop'];

?? OLDTITLE ??
?? NEWTITLE := 'display_record_data', EJECT ??

{ PURPOSE:
{   This procedure displays data from the record.

  PROCEDURE display_record_data
    (    string_index: string (1);
         entry_p: ^dut$de_other_record_entry;
         dump_information_iou: dut$di_iou_data;
     VAR display_control: clt$display_control);

    VAR
      cell_p: ^cell,
      data_size: integer,
      display_string: string (osc$max_string_size),
      error_string: string (17),
      ignore_status: ost$status,
      iou_string: string (25),
      record_data_p: ^t$record_data,
      restart_file_seq_p: ^SEQ ( * ),
      string_length: integer;

    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);
    RESET restart_file_seq_p TO cell_p;
    data_size := entry_p^.size;

    IF #SIZE (t$record_data) > data_size THEN
      clp$put_display (display_control, 'ERROR - Not enough data in the record, data not displayed.',
            clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;

    STRINGREP (display_string, string_length, 'AE', string_index, ' - Alternate IOU', string_index,
          ' Environment Control Record:');
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    clp$put_display (display_control, ' ', clc$trim, ignore_status);
    STRINGREP (display_string, string_length, '      This record contains the contents of the IOU',
          string_index, ' Dependent');
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    clp$put_display (display_control, '      Environment Control Register prior to the deadstart operation',
          clc$trim, ignore_status);
    clp$put_display (display_control, '      performed to obtain this dump.', clc$trim, ignore_status);
    clp$put_display (display_control, ' ', clc$trim, ignore_status);

    iou_string := 'The IOU model type is an ';
    CASE dump_information_iou.model OF
    = duc$di_im_i0_5x =
      STRINGREP (display_string, string_length, '      ', iou_string, 'I0.');
    = duc$di_im_i1_1x =
      STRINGREP (display_string, string_length, '      ', iou_string, 'I1.');
    = duc$di_im_i2_20 =
      STRINGREP (display_string, string_length, '      ', iou_string, 'I2, model 20.');
    = duc$di_im_i4_40 =
      STRINGREP (display_string, string_length, '      ', iou_string, 'I4, model 40.');
    = duc$di_im_i4_42 =
      STRINGREP (display_string, string_length, '      ', iou_string, 'I4, model 42.');
    = duc$di_im_i4_43 =
      STRINGREP (display_string, string_length, '      ', iou_string, 'I4, model 43.');
    = duc$di_im_i4_44 =
      STRINGREP (display_string, string_length, '      ', iou_string, 'I4, model 44.');
    = duc$di_im_i4_46 =
      STRINGREP (display_string, string_length, '      ', iou_string, 'I4, model 46.');
    ELSE
      STRINGREP (display_string, string_length, '      ', iou_string, 'unknown.');
    CASEND;
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    clp$put_display (display_control, ' ', clc$trim, ignore_status);

    NEXT record_data_p IN restart_file_seq_p;
    data_size := data_size - #SIZE (record_data_p^);
    CASE dump_information_iou.model OF
    = duc$di_im_i0_5x, duc$di_im_i1_1x, duc$di_im_i2_20, duc$di_im_i4_40, duc$di_im_i4_42 =
      display_register_data ('NIO', record_data_p^, display_control);
    ELSE
    CASEND;

    IF #SIZE (t$record_data) > data_size THEN
      clp$put_display (display_control, 'ERROR - Not enough data in the record, data not displayed.',
            clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;
    NEXT record_data_p IN restart_file_seq_p;
    CASE dump_information_iou.model OF
    = duc$di_im_i4_40, duc$di_im_i4_42, duc$di_im_i4_43, duc$di_im_i4_44, duc$di_im_i4_46 =
      display_register_data ('CIO', record_data_p^, display_control);
    ELSE
    CASEND;

  PROCEND display_record_data;
?? OLDTITLE ??
?? NEWTITLE := 'display_register_data', EJECT ??

{ PURPOSE:
{   This procedure displays the register data from the record.

  PROCEDURE display_register_data
    (    description: string (3);
         record_data: t$record_data;
     VAR display_control: clt$display_control);

    TYPE
      t$bits_or_number = PACKED RECORD
        CASE boolean OF
        = TRUE =
          bit_part: PACKED ARRAY [0 .. 4] OF boolean,
        = FALSE =
          number_part: 0 .. 1f(16),
        CASEND,
      RECEND,

      t$bytes_or_bits = RECORD
        CASE boolean OF
        = TRUE =
          byte_part: ARRAY [1 .. 8] OF 0 .. 0ff(16),
        = FALSE =
          bit_part: PACKED ARRAY [0 .. 63] OF boolean,
        CASEND,
      RECEND;

    VAR
      bits_or_number: t$bits_or_number,
      byte_index: 0 .. 0ff(16),
      bytes_or_bits: t$bytes_or_bits,
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      index: 0 .. 0ff(16),
      string_2: string (2),
      string_6: string (6),
      string_length: integer;

    FOR index := 1 TO c$number_of_bytes DO
      bytes_or_bits.byte_part [index] := record_data [index].byte_part;
    FOREND;
    STRINGREP (display_string, string_length, '   ', description, ' Environment Control Register');
    dup$display_register_data (display_string (1, string_length), bytes_or_bits.byte_part, display_control);

    FOR index := 35 TO 39 DO
      bits_or_number.bit_part [index-35] := bytes_or_bits.bit_part [index];
    FOREND;
    clp$convert_integer_to_rjstring (bits_or_number.number_part, 16, TRUE, '0', string_6, ignore_status);
    STRINGREP (display_string, string_length, '       PP Number (bits 35-39) = ', string_6);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    FOR index := 43 TO 47 DO
      bits_or_number.bit_part [index-43] := bytes_or_bits.bit_part [index];
    FOREND;
    clp$convert_integer_to_rjstring (bits_or_number.number_part, 16, TRUE, '0', string_6, ignore_status);
    STRINGREP (display_string, string_length, '       Channel Number (bits 43-47) = ', string_6);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    FOR index := 0 TO 63 DO
      IF bytes_or_bits.bit_part [index] AND (v$bit_descriptions [index] <> ' ') THEN
        STRINGREP (display_string, string_length, '       Bit ', index, ' = ', v$bit_descriptions [index]);
        clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
      IFEND;
    FOREND;

    clp$put_display (display_control, ' ', clc$trim, ignore_status);

  PROCEND display_register_data;
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_alternate_iou_ec', EJECT ??

{ PURPOSE:
{   This procedure displays the alternate iou environment control information.

  PROCEDURE [XDCL] dup$display_alternate_iou_ec
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_alternate_iou_ec, disaie (
{   output, o: file = $optional
{   title, t: string 1..31 = 'display_alternate_iou_ec'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (26),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 8, 30, 13, 12, 7, 220],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TITLE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 26],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_alternate_iou_ec'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$title = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      data_displayed: boolean,
      data_value: clt$data_value,
      display_control: clt$display_control,
      dump_information: dut$dump_information,
      entry_p: ^dut$de_other_record_entry,
      ignore_status: ost$status,
      output_display_opened: boolean,
      ring_attributes: amt$ring_attributes;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

    { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      dup$determine_dump_information (dump_information);
      data_displayed := FALSE;

      IF dump_information.iou [0].model <> duc$di_im_unknown THEN
        data_value.kind := clc$name;
        data_value.name_value := 'AE0';
        dup$find_record_list_entry (data_value, entry_p);
        IF entry_p <> NIL THEN
          data_displayed := TRUE;
          display_record_data ('0', entry_p, dump_information.iou [0], display_control);
        IFEND;
      IFEND;

      IF dump_information.iou [1].model <> duc$di_im_unknown THEN
        data_value.kind := clc$name;
        data_value.name_value := 'AE1';
        dup$find_record_list_entry (data_value, entry_p);
        IF entry_p <> NIL THEN
          data_displayed := TRUE;
          display_record_data ('1', entry_p, dump_information.iou [1], display_control);
        IFEND;
      IFEND;

      IF NOT data_displayed THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The AE0 and AE1 records are',
              status);
      IFEND;

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_alternate_iou_ec;
MODEND dum$display_alternate_iou_ec;
*DECK DECK=DUM$DISPLAY_APFT_ENTRY EXPAND=TRUE
PROC dum$display_apft_entry, display_apft_entry, disapfte (
  address, a : integer = $required
  output, o  : file = $output
  status     : var of status = $optional
  )

  " this displays a single attached pf entry and associated data structures
  " This proc converts any pointers pointed to by the base address to the
  " same segment as the parent address.
  crev ignore status
  IF $file($value(output) open_position) = '$BOI' THEN
    rewind_file $value(output) status=ignore
  IFEND
  output_file = $string($value(output)) // '.$eoi'

  entry_start = $value(address)

  valid_field_address = entry_start
  valid_entry_integer = $mem(valid_field_address, 1)
  valid_entry = (valid_entry_integer = $integer(true))
  "putl ' Valid entry = '//$strrep(valid_entry) o=$fname(output_file)
  IF NOT valid_entry THEN
    putl ' Invalid entry ' o=$fname(output_file)
    EXIT_PROC
  IFEND
  dism entry_start b=24 o=$fname(output_file)

  p_entry_field = valid_field_address + 1
  crev local status
  pfv$p_attached_pf_entry = $mem(p_entry_field)
  " Must convert to the parent segment because of the file server
  pfv$p_attached_pf_entry = $ring(entry_start)*100000000000(16) + ..
       $segment(entry_start)*100000000(16) + $offset(pfv$p_attached_pf_entry)
  putl ' p_attached_pf_entry  '//$strrep(pfv$p_attached_pf_entry, 16)//'(16)' o=$fname(output_file)
  " display this field
  " check for entry not in memory
  incl '   sfid_status_address = (pfv$p_attached_pf_entry) ' status=local
  IF NOT local.normal THEN
    EXIT_PROC WITH local
  IFEND
  sfid_state_integer = $mem(sfid_status_address, 1)
  crev sfid_state k=string d=0..2
  sfid_state(0) = ' pfc$attached_pf_normal'
  sfid_state(1) = ' pfc$attached_pf_awaiting_client'
  sfid_state(2) = ' pfc$attached_pf_in_job_recovery'
  IF sfid_state_integer <> 0 THEN
    putl ' sfid state '//sfid_state(sfid_state_integer) o=$fname(output_file)
  IFEND
  " display the sfid
  sfid_address = sfid_status_address + 1
  putl ' SFID '//$strrep($memory(sfid_address, 4), 16)//..
'(16) index(2 bytes)//residence(1 byte)//hash(1 byte) ' o=$fname(output_file)
  IF NOT $memory(sfid_address+4, 1) = $integer(on) THEN
    putl ' update_catalog '//$strrep($memory(sfid_address+4, 1)=$integer(on)) o=$fname(output_file)
  IFEND
  IF NOT $memory(sfid_address+5, 1) = $integer(on) THEN
    putl ' update_cycle_statistics '//$strrep($memory(sfid_address+5, 1)=$integer(on)) o=$fname(output_file)
  IFEND

  crev usage string
  convert_int_to_usage_string $memory(sfid_address+6, 1) usage
  putl ' access_modes '//usage o=$fname(output_file)
  crev share string
  convert_int_to_usage_string $memory(sfid_address+7, 1), share
  putl ' share_modes '//share o=$fname(output_file)

  " display the external path
  p_external_path_address = sfid_address + 17
  p_external_path = $mem(p_external_path_address)
  putl ' External path address '//$strrep(p_external_path, 16)//'(16)' o=$fname(output_file)
  external_path_size = $mem(p_external_path_address+6, 4)
  upper_bound = external_path_size / 31
  path = ' :'
  p_external_path = $ring(entry_start)*100000000000(16) + ..
       $segment(entry_start)*100000000(16) + $offset(p_external_path)
  FOR path_index = 2 TO upper_bound DO
    path = path // $memory_string(p_external_path+((path_index-1)*31), 31)
    path = $trim(path) // '.'
  FOREND
  path = path // $strrep($memory(p_external_path_address+18, 2))
  putl path o=$fname(output_file)

  gfn_size = 11
  internal_path_address = p_external_path_address + 20
".lrm.command_library.disbun internal_path_address cs=' cycle gfn: '
" dism internal_path_address
" FOR i = 1 to upper_bound do
"   internal_path_address = internal_path_address + gfn_size
".lrm.command_library.disbun internal_path_address cs=' cat '//$strrep(i)//' gfn: '
"FOREND

PROCEND dum$display_apft_entry
*DECK DECK=DUM$DISPLAY_APPLICATION_INFO EXPAND=TRUE

PROCEDURE dum$display_application_info, display_application_info, disai (
  queue_index, qi: integer 1..16 = 1
  display_option, display_options, do: key
      (remote, r)
      (task, t)
      (host, h)
      (all, a)
    keyend = all
  queue_interface_index, qii: integer = 1
  output, o: file = $output
  status)

  " This proc displays the application rpc info.
  " This proc requires RJTs most recent dump analyzer.
  " The proc assumes that dfm$monitor_process has been added.

  current_module = $default_module
  chadm dfm$monitor_process
  crev local_status status
  IF $file(output open_position) = '$BOI' THEN
    rewind_file output status=local_status
  IFEND
  set_file_attributes output fc=legible pf=continuous
  out = output.$eoi

  p_cpu_queue_header = $pv(^dfv$p_queue_interface_directory^[..
?queue_interface_index].p_queue_interface_table^..
.queue_directory.cpu_queue_pva_directory[?queue_index].p_cpu_queue^.queue_header)

  p_host_application_info = $program_value(?p_cpu_queue_header.dft$cpu_queue_header.p_host_application_info)

  IF (display_option = host) OR (display_option = all) THEN
    IF $nil_pva(p_host_application_info) THEN
      put_line ' No host application info defined.' o=out
    ELSE
      put_line ' Host application information' o=out
      WHILE NOT $nil_pva(p_host_application_info) DO
        put_line ' ' o=out
        dispv ?p_host_application_info.dft$host_application_info o=out
        p_host_application_info = $pv(..
              ?p_host_application_info.dft$host_application_info.next_p_application_info)
      WHILEND
    IFEND
  IFEND

  IF (display_option = remote) OR (display_option = all) THEN
    p_remote_application_info = $program_value(..
          ?p_cpu_queue_header.dft$cpu_queue_header.p_remote_application_info)

    put_line ' ' o=out

    IF $nil_pva(p_remote_application_info) THEN
      put_line ' No remote application info defined.' o=out
    ELSE
      put_line ' Remote application information' o=out
      WHILE NOT $nil_pva(p_remote_application_info) DO
        put_line ' ' o=out
        dispv ?p_remote_application_info.dft$remote_application_info o=out
        p_remote_application_info = $pv(..
              ?p_remote_application_info.dft$remote_application_info.next_p_application_info)
      WHILEND
    IFEND

    p_application_rpc_list = $program_value(?p_cpu_queue_header.dft$cpu_queue_header.p_application_rpc_list)
    put_line ' ' o=out

    IF $nil_pva(p_application_rpc_list) THEN
      put_line ' No remote application rpc list.' o=out
    ELSE
      put_line ' Remote application rpc list' o=out

      abc = $string(p_cpu_queue_header)
      rpc = abc//'.dft$cpu_queue_header.p_application_rpc_list'
      FOR i = 1 TO $pv(upperbound(?rpc^)) DO
        put_line ' ' o=out
        dispv ?rpc^[?i] o=out
      FOREND
    IFEND
  IFEND

" Task info
  IF (display_option = task) OR (display_option = all) THEN
    current_procedure =$default_procedure
    chadm dfm$clone_task_process
    chadp dfp$task_services_clone_task

    IF NOT $nil_pva(dfv$p_proc_addresses) THEN
      dispv dfv$p_proc_addresses^          o=out
    IFEND
    IF NOT $nil_pva(dfv$p_attached_file_pointers) THEN
      dispv dfv$p_attached_file_pointers^  o=out
    IFEND
    chadp current_procedure
  IFEND

  chadm current_module

PROCEND dum$display_application_info
*DECK DECK=DUM$DISPLAY_ASID_TRACE EXPAND=TRUE

PROC dum$display_asid_trace, display_asid_trace (output, o: file = $output)

  crev stat status
  scr = $unique
  o = $unique
COLT $fname(scr)

  1    Low asids
  2    No asids
  3    Ast reset
  4    Free aste
  5    Assign ASID
  6    Assign specific ASID
  7    Change_asid of swapped job
  8    Change_asid of monitor-only segment
  9    Change_asid of file awaiting recovery
 10    Change asid of template segment
 11    Change asid of global file
 12    Change asid of job file
 13    Reclaim asids
 14    Make page table entry, full
 15    Make page table entry, recovered
 16    Make page table entry, rec1
 17    Make page table entry, rec2
 18    Page table full called
 19    Page table full tried
 20    Page table full failed
 21    Page table full remove
 22    Reassign asid called
 23    Reassign asid in free
 24    Reassign asid make page table entry failed
 25    Reassign asid ok
 26    Reassign asid ok1
 27    Reassign asid ok2
 28    Reassign asid ok3
 29    Reassign asid ok4
 30    Reassign asid failed
 31    Reassign asid failed 1
 32    Reassign asid failed 2
 33    Reassign asid quit
 34      (unused)
 35      (unused)
 36    Reassign asid make page table entry
 37    Delete pte of terminated job for page table full
 38      (unused)
 39      (unused)
 40      (unused)

zzz
**
  rewf $fname(scr)
  setfa $fname(scr) op=$asis
  setfa $fname(o) op=$asis
  crev s string
  rewf $fname(scr)
  accl s i=$fname(scr)


  WHILE s <> 'zzz' DO
    IF $substr(s 1 3) = '  ' THEN
      putl '          '//s o=$fname(o)
    ELSE
      i = $integer($substr(s 1 3))
      j = $mem($sa(mmv$aptm_trace)+i*4 4)
      sj = '           ' // $strrep(j)
      sk = '    '//$strrep(i);sk=$substr(sk $strlen(sk)-3 4)
      putl $substr(sj $strlen(sj)-9 10)//sk//'   '//$substr(s 4 $strlen(s)-3) o=$fname(o)
    IFEND
    accl s i=$fname(scr)
  WHILEND
  copf $fname(o//'.$boi') $value(output)
  delf $fname(scr)
  delf $fname(o)

PROCEND dum$display_asid_trace
*DECK DECK=DUM$DISPLAY_ASSIGNED_PPS EXPAND=TRUE
PROCEDURE dum$display_assigned_pps, display_assigned_pps, disap (
  output, o: file = $output
  status)

  VAR
    c$flags_starting_address: (READ) integer = 0
    c$pp_info_starting_address: (READ) integer = 0d(16)
  VAREND

  VAR
    cip_driver_name: string
    driver_name: string
    ignore_status: status
    index: integer
    iou_string: string
    last_lppt_ordinal: integer
    line_string: string
    logical_pp_string: string
    logical_pp_table: integer
    logical_pp_table_p: integer
    logical_pp_table_entry: integer
    logical_pp_table_entry_size: integer
    lppt_ordinal: integer
    number_of_entries: integer
    output_file: file
    pp_string: string
    pp_type: string
    start_lppt_ordinal: integer
    string_1: string
    string_2: string
    zero_string: string
  VAREND

  IF $file(output open_position) = '$BOI' THEN
    delete_file f=output status=ignore_status
  IFEND
  output_file = output.$eoi

  logical_pp_table_p = $symbol_address(cmv$logical_pp_table_p)
  logical_pp_table = $memory(logical_pp_table_p 6 monitor)
  logical_pp_table_entry_size = $memory((logical_pp_table_p + 14) 4 monitor)
  number_of_entries = $memory((logical_pp_table_p + 6) 4 monitor) / logical_pp_table_entry_size
  start_lppt_ordinal = $memory((logical_pp_table_p + 10) 4 monitor)
  last_lppt_ordinal = start_lppt_ordinal + number_of_entries - 1
  zero_string = '0'

  put_line l=' ' o=output_file
  put_line l=' IOU   PP        DRIVER_NAME  CIP_DRIVER_NAME  TYPE_OF_PP  LOGICAL_PP' o=output_file
  put_line l=' ********************************************************************' o=output_file

  FOR lppt_ordinal = start_lppt_ordinal TO last_lppt_ordinal DO
    logical_pp_table_entry = logical_pp_table + ((lppt_ordinal - 1) * logical_pp_table_entry_size)

    IF $memory((logical_pp_table_entry + c$flags_starting_address + 2) 1 monitor) = 1 THEN
      string_1 = $strrep($memory((logical_pp_table_entry + c$pp_info_starting_address + index) 1 monitor))
      iou_string = 'IOU'//string_1

      string_1 = $strrep($memory((logical_pp_table_entry + c$pp_info_starting_address + 2) 1 monitor) 8)
      IF $integer(string_1 8) <= 7 THEN
        string_2 = zero_string//string_1
      ELSE
        string_2 = string_1
      IFEND
      IF $memory((logical_pp_table_entry + c$pp_info_starting_address + 1) 1 monitor) = 0 THEN
        pp_string = 'PP'//string_2//'(8) '
      ELSE
        pp_string = 'CPP'//string_2//'(8)'
      IFEND

      IF $memory((logical_pp_table_entry + c$pp_info_starting_address + 5) 1 monitor) = 0 THEN
        pp_type = 'unknown'
      ELSEIF $memory((logical_pp_table_entry + c$pp_info_starting_address + 5) 1 monitor) = 1 THEN
        pp_type = 'other  '
      ELSEIF $memory((logical_pp_table_entry + c$pp_info_starting_address + 5) 1 monitor) = 2 THEN
        pp_type = 'disk   '
      ELSEIF $memory((logical_pp_table_entry + c$pp_info_starting_address + 5) 1 monitor) = 3 THEN
        pp_type = 'tape   '
      ELSEIF $memory((logical_pp_table_entry + c$pp_info_starting_address + 5) 1 monitor) = 4 THEN
        pp_type = 'network'
      ELSEIF $memory((logical_pp_table_entry + c$pp_info_starting_address + 5) 1 monitor) = 5 THEN
        pp_type = 'nad    '
      ELSE
        pp_type = '       '
      IFEND

      driver_name = $memory_string((logical_pp_table_entry + c$pp_info_starting_address + 58) 7 monitor)
      cip_driver_name = $memory_string((logical_pp_table_entry + c$pp_info_starting_address + 65) 7 monitor)
      logical_pp_string = $strrep(lppt_ordinal)

      line_string = ' '//iou_string//'  '//pp_string//'  '//driver_name//'      '
      line_string = line_string//cip_driver_name//'          '//pp_type//'     '//logical_pp_string
      put_line l=line_string o=output_file
    IFEND
  FOREND

PROCEND dum$display_assigned_pps
*DECK DECK=DUM$DISPLAY_AST_ENTRY EXPAND=TRUE
PROC dum$DISPLAY_AST_ENTRY display_ast_entry, disaste (
  asti      : integer -281474976710655..281474976710655 = $required
  output, o : file = $output
  )

  crev astep
  compute_entry_address $sa(mmv$ast_p) $value(asti) astep
  oo = $string($value(output)) // '.$eoi'
  putl ' ----- Active Segment Table Entry '//$strrep($value(asti), 16) o=$fname(oo)
  mmt$active_segment_table_entry astep o=$value(output)

PROCEND dum$display_ast_entry
*DECK DECK=DUM$DISPLAY_ATTACHED_PF_TABLE EXPAND=TRUE
PROC dum$display_attached_pf_table, display_attached_pf_table, disapft (
  p_attached_pf_table, address: integer 0 .. $max_integer
  array_size, as: integer 0 .. $max_integer
  element_size, es: integer 0 .. $max_integer
  output, o : file = $output
  status    : var of status = $optional
  )

" This procedure displays all permanent files attached within
" the job.  The table defaults to the attached pf table of the current job,
" but the parameters are required for use by the file server procccdures.
" The correct job must be selected prior to using this PROC.
" When attempting to display the attached file for files attached on the server,
" the correct clone task may be selected, and must
"   be processing for this job, (alternately use display_client_mainframe file.

  crev local_status status

  IF $file($value(output) open_position) = '$BOI' THEN
    rewind_file $value(output) status=local_status
  IFEND
  output_file = $string($value(output)) // '.$eoi'

  IF $specified(p_attached_pf_table) THEN
    pfv$p_attached_pf_table = $value(p_attached_pf_table)
    lower_bound = 1
    array_size = $value(array_size)
    element_size =  $value(element_size)
  ELSE " Default to what the current task is using
    pfv$p_attached_pf_table = $mem($sa(pfv$p_p_attached_pf_table))
    array_size = $mem(pfv$p_attached_pf_table+6, 4)
    lower_bound = $mem(pfv$p_attached_pf_table+10, 4)
    element_size = $mem(pfv$p_attached_pf_table+14, 4)
    pfv$p_attached_pf_table = $mem($mem($sa(pfv$p_p_attached_pf_table)))
  IFEND
  upper_bound = lower_bound + (array_size / element_size) - 1

  putl ' pfv$p_attached_pf_table '//$strrep(pfv$p_attached_pf_table, 16)//'(16)' o=$fname(output_file)
  putl ' lower_bound '//$strrep(lower_bound)//' upper_bound '//$strrep(upper_bound)  o=$fname(output_file)
  FOR apfid = lower_bound TO upper_bound DO
    putl ' ------------ apfid '//$strrep(apfid) o=$fname(output_file)
    display_apft_entry pfv$p_attached_pf_table+((apfid-lower_bound)*element_size) o=$fname(output_file) ..
          status=local_status
    IF NOT local_status.normal THEN
      disv local_status o=$fname(output_file)
    IFEND
  FOREND

PROCEND dum$display_attached_pf_table
*DECK DECK=DUM$DISPLAY_AVT_ENTRY EXPAND=TRUE
PROC dum$DISPLAY_AVT_ENTRY display_avt_entry, disavte (
  avti      : integer -281474976710655..281474976710655 = $required
  output, o : file = $output
  )

  crev avtep
  compute_entry_address $sa(dmv$p_active_volume_table) $value(avti) avtep
  oo = $string($value(output)) // '.$eoi'
  putl ' ----- Active Volume Table Entry '//$strrep($value(avti), 16) o=$fname(oo)
  dmt$active_volume_table_entry avtep o=$value(output)

PROCEND dum$display_avt_entry
*DECK DECK=DUM$DISPLAY_BASE_SYSTEM_TIME EXPAND=TRUE
PROCEDURE dum$display_base_system_time, display_base_system_time, disbst (
  output, o: file = $output
  status)

  VAR
    local_status: status
    output_file: file
  VAREND

  IF $file(output open_position) = '$BOI' THEN
    delete_file f=output status=local_status
  IFEND
  output_file = output.$eoi

  " Display the OS version.

  display_os_version o=output_file

  " Display the base system time.

  bst = $symbol_address(osv$base_system_time)
  bst_second = $memory(bst, 1)
  bst_minute = $memory(bst+1, 1)
  bst_hour = $memory(bst+2, 1)
  bst_day = $memory(bst+3, 1)
  bst_month = $memory(bst+4, 1)
  bst_year = $memory(bst+5, 2)

  second = $strrep(bst_second, 10)
  second = $substr('0'//second, $strlen(second), 2)
  minute = $strrep(bst_minute, 10)
  minute = $substr('0'//minute, $strlen(minute), 2)
  hour = $strrep(bst_hour, 10)
  hour = $substr('0'//hour, $strlen(hour), 2)
  day = $strrep(bst_day, 10)
  day = $substr('0'//day, $strlen(day), 2)
  month = $strrep(bst_month, 10)
  month = $substr('0'//month, $strlen(month), 2)
  year = $strrep(bst_year, 10)

  data = ' NOS/VE deadstarted at '//hour//':'//minute//':'//second//', '
  data = data //year//'.'//month//'.'//day
  put_line l=data o=output_file

  " Complete the failure time.

  frc = $memory($symbol_address(mtv$trace_buffer), 8)
  time_string = ' '
  convert_microsecond_clock mc=frc ts=time_string
  put_line l=' NOS/VE terminated at '//time_string o=output_file

PROCEND dum$display_base_system_time
*DECK DECK=DUM$DISPLAY_BINARY_UNIQUE_NAME EXPAND=TRUE
PROCEDURE dum$display_binary_unique_name, display_binary_unique_name, disbun (
  pva: integer = $optional
  output, o: file = $output
  concat_string, cs: string = ' '
  address_mode, am: key pva, sva, keyend = pva
  exchange_package, ep: key m, j, keyend = j
  help, h: file = $null
  status)

  WHEN any_fault DO
    putl ' entered disbun handler - enter commands or exit_proc'
    disv osv$status
    include_file command
  WHENEND

  IF $specified(help) THEN
COLLECT_TEXT o=$value(help) until='HELPEND'
DISPLAY_BINARY_UNIQUE_NAME or DISBUN

  This procedure will decode and display 11 memory bytes pointed to
by the pva parameter as a unique binary name.  This procedure assumes
the user has previously selected the correct exchange package by
available analyze_dump commands.

PARAMETERS:

PVA: integer
  This parameter selects the address of the first bye of the eleven byte
binary unique name.  This parameter is required.

OUTPUT, O: file
  This parameter selects the file name to receive the data.  This para-
meter is defaulted to $output.  If a file name other than $output is
entered the data will be sent to the file  "$asis".

CONCAT_STRING, CS: string
  This parameter specifies a string to be added to the beginning of
the decoded binary unique name before it is output.  This parameter
is used by other procedures to append their individual labels in front
of the decoded name.  This parameter defaults to one space.

STATUS

WARNINGS/KNOWN DEFICIENCIES:

ERROR HANDLER
  When any fatal error is encountered a condition handler is invoked and
the following message will appear:
 "entered disbun condition handler - enter commands or exit_proc to abort".
This will be followed by the error status.  To exit the handler enter:
 "exit_proc".

HELPEND
    EXIT_PROC
  IFEND

  IF NOT $specified(pva) THEN
    EXIT_PROC WITH $status(false, 'US', 1, 'Parameter PVA is required')
  IFEND

  create_variable name=seq_base_number kind=integer value=$mem(($value(pva)+7), 4(16),,, $value(am))
  create_variable name=date_base_number kind=integer value=$mem(($value(pva)+3), 3(16),,, $value(am))/10(16)
  create_variable name=time_base_number kind=integer value=$mem(($value(pva)+5), 3(16),,, $value(am))/8
  create_variable name=base_operand kind=integer
  create_variable name=work_operand kind=integer
  create_variable name=string_length kind=integer
  create_variable name=sub_string kind=string
  create_variable name=result_string kind=string
  create_variable name=filler_string kind=string value='0000000'

  base_operand = ((seq_base_number)-(seq_base_number/1000000(16)/8*8*1000000(16)))/8
  work_operand = $mem(($value(pva)+2), 1(16),,, $value(am))
  sub_string = $strrep(base_operand)
  string_length = $strlen(sub_string)
  result_string = '$'//$substr(filler_string, 1, (7-string_length))
  result_string = result_string//sub_string
  result_string = result_string//$strrep(work_operand (16))//'s' "add model number"
  sub_string = $strrep($mem(($value(pva)), 2(16),,, $value(am)) (16))
  string_length = $strlen(sub_string)
  result_string = result_string//$substr(filler_string, 1, (4-string_length))
  result_string = result_string//..
$substr(sub_string, 1, string_length)//'d'//$strrep(date_base_number/100(16)/2)
  base_operand = ((date_base_number)-(date_base_number/1000(16)*1000(16)))/10(16)
  base_operand = (base_operand/2)-(base_operand/2/10(16)*10(16))
  base_operand = base_operand-(base_operand/10(16)*10(16))
  sub_string = $strrep(base_operand)
  string_length = $strlen(sub_string)
  result_string = result_string//$substr(filler_string, 1, (2-string_length))//sub_string "month"
  base_operand = date_base_number-(date_base_number/100(16)*100(16))
  base_operand = base_operand-(base_operand/10(16)/2*10(16)*2)
  sub_string = $strrep(base_operand)
  string_length = $strlen(sub_string)
  result_string = result_string//$substr(filler_string, 1, (2-string_length))//(sub_string)//'t' "add day"
  base_operand = (time_base_number-(time_base_number/10000(16)/2*10000(16))*2)
  sub_string = $strrep(base_operand/1000(16))
  string_length = $strlen(sub_string)
  result_string = result_string//$substr(filler_string, 1, (2-string_length))//sub_string "hour"
  base_operand = base_operand-(base_operand/1000(16)*1000(16))
  sub_string = $strrep(base_operand/10(16)/4)
  string_length = $strlen(sub_string)
  result_string = result_string//$substr(filler_string, 1, (2-string_length))//sub_string "min"
  base_operand = base_operand-((base_operand/10(16)/4)*10(16)*4)
  sub_string = $strrep(base_operand)
  string_length = $strlen(sub_string)
  result_string = result_string//$substr(filler_string, 1, (2-string_length))//sub_string "sec"

  IF $file($value(output) open_position) = '$BOI' THEN
    char = $strlen($string($value(output)))
    IF $substr($string($value(output)), char-4, 5) = '$ASIS' THEN
      output_file = $string($value(output))
    ELSEIF $substr($string($value(output)), char-3, 4) = '$EOI' THEN
      output_file = $string($value(output))
    ELSE
      output_file = $string($value(output))//'.$asis'
    IFEND
  ELSE
    output_file = $string($value(output))
  IFEND
  put_line line=$value(concat_string)//result_string o=$fname(output_file)

PROCEND dum$display_binary_unique_name
*DECK DECK=DUM$DISPLAY_BRIEF_AVT_ENTRY EXPAND=TRUE
PROCEDURE dum$display_brief_avt_entry, display_brief_avt_entry, disbae (
  index, i: integer 1..150 = $optional
  output, o: file = $output
  help, h: file = $null
  status)


  "$FORMAT=OFF"
  VAR
    when_status: status
  VAREND
  "$FORMAT=ON"

  WHEN any_fault DO
    when_status = $previous_status
    put_line ' Invoked DISBAE condition handler due to the following abnormal status:'
    disv when_status
    put_line ' Enter commands, "exit_proc" to abort, or "exit_proc with when_status" to abort with status'
    include_file command prompt='disbae_ch'
  WHENEND

  IF $specified(help) THEN
COLLECT_TEXT o=help until='HELPEND'
DISPLAY_BRIEF_AVT_ENTRY or DISBAE

  This procedure has been designed to be called by procedure
Display_Active_Volume_Table.  Please use Display_Active_Volume_Table
rather than this procedure.

WARNINGS/KNOWN DEFICIENCIES:

ERROR HANDLER
  When any fatal error is encountered a condition handler is invoked and
the following messages will appear:
 "Invoked DISBAE condition handler due to the following abnormal status:"
 "< the error status message >"
 "Enter commands, "exit_proc" to abort, or "exit_proc with when_status"
  to abort with status"
To exit the handler enter:    "exit_proc"
To exit the handler with status, enter:   "exit_proc with when_status"

HELPEND
    EXIT_PROC
  IFEND

  IF NOT $specified(index) THEN
    EXIT_PROC WITH $status(false, 'US', 2, 'Parameter INDEX is required')
  IFEND

  "$FORMAT=OFF"
  VAR
    output_file: file
    blank_line: string = '                                                    '
    line_first_part: string
    line_secnd_part: string
    blank_fill_count: integer
    column_two_num: integer = 42
  VAREND
  "$FORMAT=ON"

  IF $file(output open_position) = '$BOI' THEN
    output_file = output.$asis
  ELSE
    output_file = output
  IFEND

" Get the base values required to look at the active volume table.  Use the knowlege that
" DMV$P_ACTIVE_VOLUME_TABLE is an adaptable array.

  p_avt = $mem($sa(dmv$p_active_volume_table), 6)
  avt_length = $mem($sa(dmv$p_active_volume_table)+6, 4)
  avt_start_index = $mem($sa(dmv$p_active_volume_table)+6+4, 4)
  avt_entry_size = $mem($sa(dmv$p_active_volume_table)+6+4+4, 4)
  number_of_avt_entries = avt_length / avt_entry_size

  IF index > number_of_avt_entries THEN
    EXIT_PROC WITH $status(false, 'US', 0, ' specified index > number of avt entries')
  IFEND

  "$FORMAT=OFF"
  VAR
    i: integer

" The following offsets were obtained from the output of the command Display_Symbol_Table
" for the type DMT$ACTIVE_VOLUME_TABLE_ENTRY.

    entry_locked: integer
    entry_locked_offset: integer = 0(16)
    entry_available_offset: integer = 8(16)
    lun: integer
    lun_offset: integer = 9(16)
    padding: integer
    padding_offset: integer = 0b(16)
    allocation_allowed: integer
    allocation_allowed_offset: integer = 10(16)
    space_low: integer
    space_low_offset: integer = 11(16)
    space_gone: integer
    space_gone_offset: integer = 12(16)
    dmt$disk_table_status: array 0..4 of string 1..$max_name = ('dmc$table_update_inhibited' ..
          'dmc$table_update_in_progress' 'dmc$dflt_update_required' 'dmc$no_available_dflt_entries' ..
          'dmc$volume_low_on_dfl_entries')
    disk_table_status: integer
    disk_table_status_offset: integer = 13(16)
    class_offset: integer = 14(16)
    sys_class_act_element_length: integer = 4(16)
    system_class_activity_offset: integer = 18(16)
    logged_in_for_recovery: boolean
    logged_in_for_recovery_offset: integer = 2c(16)
    update_lock: integer
    update_lock_offset: integer = 30(16)
    logging_lock: integer
    logging_lock_offset: integer = 38(16)
    internal_vsn_offset: integer = 40(16)
    dat_sfid: integer
    dat_sfid_offset: integer = 4b(16)
    dfl_sfid: integer
    dfl_sfid_offset: integer = 4f(16)
    dl_sfid: integer
    dl_sfid_offset: integer = 53(16)
    dir_sfid: integer
    dir_sfid_offset: integer = 57(16)
    lt_sfid: integer
    lt_sfid_offset: integer = 5b(16)
    mf_assign: integer
    mf_assign_offset: integer = 5f(16)
    p_mat: integer
    p_mat_offset: integer = 64(16)
    p_mfl: integer
    p_mfl_offset: integer = 76(16)
    recorded_vsn: string
    recorded_vsn_offset: integer = 88(16)
    set_name: string
    set_name_offset: integer = 8e(16)
    dmt$ms_volume_system_status: array 0..3 of string 1..$max_name = ('dmc$mainframe_mounted' ..
          'dmc$mainframe_dismounted' 'dmc$system_mounted' 'dmc$system_dismounted')
    status_field: integer
    status_field_offset: integer = 0ad(16)
    volume_owner: string
    volume_owner_offset: integer = 0ae(16)
    offset_in_log: integer
    offset_in_log_offset: integer = 0ec(16)
    allocated_log_size: integer
    allocated_log_size_offset: integer = 0f2(16)
    device_log_entry_count: integer
    device_log_entry_count_offset: integer = 0f8(16)
    volume_unavailable: boolean
    volume_unavailable_offset: integer = 100(16)
    previous_alloc_allowed: boolean
    previous_alloc_allowed_offset: integer = 101(16)
    logging_process_damaged: boolean
    logging_process_damaged_offset: integer = 102(16)
  VAREND
  "$FORMAT=ON"

  current_avt_entry = (p_avt + ((index - avt_start_index)* avt_entry_size))
" putl ' Current_avt_entry at '//$strrep(current_avt_entry 16)//'(16)' o=output_file
" dism current_avt_entry 259 o=output_file

  put_line '   ' o=output_file
  IF $mem(current_avt_entry+entry_available_offset, 1) = 1 THEN
    put_line ' AVT index '//$strrep(index)//' is available (i.e., not in use)' o=output_file
    put_line '  ' o=output_file
  ELSE
    entry_locked = $mem(current_avt_entry+entry_locked_offset, 8)
    lun = $mem(current_avt_entry+lun_offset, 2)
    padding = $mem(current_avt_entry+padding_offset, 4)
    allocation_allowed = $mem(current_avt_entry+allocation_allowed_offset, 1)
    space_low = $mem(current_avt_entry+space_low_offset, 1)
    space_gone = $mem(current_avt_entry+space_gone_offset, 1)
    disk_table_status = $mem(current_avt_entry+disk_table_status_offset, 1)
    logged_in_for_recovery = ($mem(current_avt_entry+logged_in_for_recovery_offset, 1) = $integer(true))
    update_lock = $mem(current_avt_entry+update_lock_offset, 8)
    logging_lock = $mem(current_avt_entry+logging_lock_offset, 8)
    dat_sfid = $mem(current_avt_entry+dat_sfid_offset, 4)
    dfl_sfid = $mem(current_avt_entry+dfl_sfid_offset, 4)
    dl_sfid = $mem(current_avt_entry+dl_sfid_offset, 4)
    dir_sfid = $mem(current_avt_entry+dir_sfid_offset, 4)
    lt_sfid = $mem(current_avt_entry+lt_sfid_offset, 4)
    mf_assign = $mem(current_avt_entry+mf_assign_offset, 5)
    p_mat = $mem(current_avt_entry+p_mat_offset, 6)
    p_mfl = $mem(current_avt_entry+p_mfl_offset, 6)
    recorded_vsn = $ms(current_avt_entry+recorded_vsn_offset, 6)
    set_name = $ms(current_avt_entry+set_name_offset, 31)
    status_field = $mem(current_avt_entry+status_field_offset, 1)
    volume_owner = $ms(current_avt_entry+volume_owner_offset, 62)
    offset_in_log = $mem(current_avt_entry+offset_in_log_offset, 6)
    allocated_log_size = $mem(current_avt_entry+allocated_log_size_offset, 6)
    device_log_entry_count = $mem(current_avt_entry+device_log_entry_count_offset, 8)
    volume_unavailable = ($mem(current_avt_entry+volume_unavailable_offset, 1) = $integer(true))
    previous_alloc_allowed = ($mem(current_avt_entry+previous_alloc_allowed_offset, 1) = $integer(true))
    logging_process_damaged = ($mem(current_avt_entry+logging_process_damaged_offset, 1) = $integer(true))

    IF entry_locked <> 0 THEN
      put_line ' entry_locked = TRUE' o=output_file
    ELSE
      put_line ' entry_locked = FALSE' o=output_file
    IFEND

    put_line ' logical_unit_number = '//$strrep(lun 16)//'(16)' o=output_file

    put_line ' padding = '//$strrep(padding 16)//'(16)' o=output_file

    IF allocation_allowed = 1 THEN
      put_line ' allocation_allowed = TRUE' o=output_file
    ELSE
      put_line ' allocation_allowed = FALSE' o=output_file
    IFEND

    IF space_low = 1 THEN
      line_first_part = ' space_low = TRUE'
    ELSE
      line_first_part = ' space_low = FALSE'
    IFEND

    IF space_gone = 1 THEN
      line_secnd_part = ' space_gone = TRUE'
    ELSE
      line_secnd_part = ' space_gone = FALSE'
    IFEND

    blank_fill_count = (column_two_num)-($strlen(line_first_part))
    put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part o=output_file

    line = ' disk_table_status: {'
    FOR i = 59 TO 63 DO
      IF $bit(disk_table_status i) THEN
        line = line // ' ' // dmt$disk_table_status(i-59)
      IFEND
    FOREND
    put_line line//' }' o=output_file

    display_ms_classes current_avt_entry+class_offset o=output_file

    put_line ' system_class_activity:' o=output_file
    FOR i = 0 TO 4 DO
      put_line '   ['//..
$strrep(i)//'] '//$strrep($mem(current_avt_entry+system_class_activity_offset+i*sys_class_act_element_length..
, sys_class_act_element_length) 16)//'(16)' o=output_file
    FOREND

    IF logged_in_for_recovery THEN
      put_line ' logged_in_for_recovery = TRUE' o=output_file
    ELSE
      put_line ' logged_in_for_recovery = FALSE' o=output_file
    IFEND

    IF update_lock <> 0 THEN
      line_first_part = ' update_lock = { task } '//$strrep(update_lock, 16)//'(16)'
    ELSE
      line_first_part = ' update_lock = '//$strrep(update_lock, 16)//'(16)'
    IFEND

    IF logging_lock <> 0 THEN
      line_secnd_part = ' logging_lock = { task } '//$strrep(logging_lock, 16)//'(16)'
    ELSE
      line_secnd_part = ' logging_lock = '//$strrep(logging_lock, 16)//'(16)'
    IFEND

    blank_fill_count = (column_two_num)-($strlen(line_first_part))
    put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part o=output_file

    display_binary_unique_name pva=current_avt_entry+internal_vsn_offset o=output cs=' internal_vsn = '

    put_line ' recorded_vsn = '//recorded_vsn o=output_file
    put_line ' set_name = '//set_name o=output_file

    put_line ' mf_assigned = '//$strrep(mf_assign, 16)//'(16)' o=output_file

    line_first_part = ' dat_sfid = '//$strrep(dat_sfid, 16)//'(16)'
    line_secnd_part = ' mat_pointer = '//$strrep(p_mat, 16)//'(16)'
    blank_fill_count = (column_two_num)-($strlen(line_first_part))
    put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part o=output_file

    line_first_part = ' dfl_sfid = '//$strrep(dfl_sfid, 16)//'(16)'
    line_secnd_part = ' mfl_pointer = '//$strrep(p_mfl, 16)//'(16)'
    blank_fill_count = (column_two_num)-($strlen(line_first_part))
    put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part o=output_file

    line_first_part = ' dlog_sfid = '//$strrep(dl_sfid, 16)//'(16)'
    line_secnd_part = ' log_offset = '//$strrep(offset_in_log, 16)//'(16)'
    blank_fill_count = (column_two_num)-($strlen(line_first_part))
    put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part o=output_file

    line_first_part = ' dir_sfid = '//$strrep(dir_sfid, 16)//'(16)'
    line_secnd_part = ' allocated_size = '//$strrep(allocated_log_size, 16)//'(16)'
    blank_fill_count = (column_two_num)-($strlen(line_first_part))
    put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part o=output_file

    line_first_part = ' ltable_sfid = '//$strrep(lt_sfid, 16)//'(16)'
    line_secnd_part = ' entry_count = '//$strrep(device_log_entry_count, 16)//'(16)'
    blank_fill_count = (column_two_num)-($strlen(line_first_part))
    put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part o=output_file

    IF volume_unavailable THEN
      line_first_part = ' volume_unavailable = TRUE'
    ELSE
      line_first_part = ' volume_unavailable = FALSE'
    IFEND

    IF previous_alloc_allowed THEN
      line_secnd_part = ' previous_allocation_allowed = TRUE'
    ELSE
      line_secnd_part = ' previous_allocation_allowed = FALSE'
    IFEND

    blank_fill_count = (column_two_num)-($strlen(line_first_part))
    put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part o=output_file

    line = ' status: {'
    FOR i = 60 TO 63 DO
      IF $bit(status_field i) THEN
        line = line // ' ' // dmt$ms_volume_system_status(i-60)
      IFEND
    FOREND
    put_line line//' }' o=output_file

    put_line ' volume_owner:' o=output_file
    line_first_part = '   user = '//$substr(volume_owner 1 31)
    line_secnd_part = ' family = '//$substr(volume_owner 32 31)
    blank_fill_count = (column_two_num)-($strlen(line_first_part))
    put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part o=output_file

    IF logging_process_damaged THEN
      put_line ' logging_process_damaged = TRUE' o=output_file
    ELSE
      put_line ' logging_process_damaged = FALSE' o=output_file
    IFEND

  IFEND

PROCEND dum$display_brief_avt_entry
*DECK DECK=DUM$DISPLAY_BUFFER_CONTROLWARE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Buffer Controlware Command' ??
MODULE dum$display_buffer_controlware;

{ PURPOSE:
{   This module contains the code for the display_buffer_controlware command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc dup$display_data
*copyc dup$new_page_procedure
*copyc dup$retrieve_bc_entry
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_buffer_controlware', EJECT ??

{ PURPOSE:
{   This procedure displays the buffer controlware.
{ NOTE:
{   This procedure refers to a "word".  The definition of a word for this procedure is a two byte data
{   structure.

  PROCEDURE [XDCL] dup$display_buffer_controlware
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_buffer_controlware, disbc (
{   channel_number, cn: integer 0..33 = $required
{   output, o: file = $optional
{   title, t: string 1..31 = 'display_buffer_controlware'
{   display_option, do: list 1..2 of key
{       (numeric c) (ascii a) (display_code dc)
{     keyend = (numeric ascii)
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (28),
      recend,
      type4: 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 .. 6] of clt$keyword_specification,
        recend,
        default_value: string (15),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 1, 22, 11, 33, 2, 293],
    clc$command, 9, 5, 1, 0, 0, 0, 5, ''], [
    ['CHANNEL_NUMBER                 ',clc$nominal_entry, 1],
    ['CN                             ',clc$abbreviation_entry, 1],
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 4],
    ['DO                             ',clc$abbreviation_entry, 4],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['T                              ',clc$abbreviation_entry, 3],
    ['TITLE                          ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 28],
{ PARAMETER 4
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 245,
  clc$optional_default_parameter, 0, 15],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 33, 10]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_buffer_controlware'''],
{ PARAMETER 4
    [[1, 0, clc$list_type], [229, 1, 2, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [6], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['ASCII                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['DISPLAY_CODE                   ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['NUMERIC                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    '(numeric ascii)'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$channel_number = 1,
      p$output = 2,
      p$title = 3,
      p$display_option = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      cell_p: ^cell,
      channel_number: 0 .. duc$de_maximum_channels,
      display_control: clt$display_control,
      end_of_input_file: boolean,
      entry_p: ^dut$de_buffer_controlware_entry,
      ignore_status: ost$status,
      integer_string: ost$string,
      output_display_opened: boolean,
      radix: 8 .. 16,
      restart_file_buffer_p: ^SEQ ( * ),
      restart_file_seq_p: ^SEQ ( * ),
      ring_attributes: amt$ring_attributes;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    channel_number := pvt [p$channel_number].value^.integer_value.value;
    dup$retrieve_bc_entry (channel_number, entry_p);
    IF entry_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,
            'The buffer controlware for channel', status);
      osp$append_status_integer (osc$status_parameter_delimiter, channel_number, 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

      { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      IF pvt [p$title].specified THEN
        duv$title_data.command_name := pvt [p$title].value^.string_value^;
      ELSE
        duv$title_data.command_name := 'display_buffer_controlware ';
        clp$convert_integer_to_string (channel_number, 10, FALSE, integer_string, ignore_status);
        duv$title_data.command_name (28, integer_string.size) :=
              integer_string.value (1, integer_string.size);
      IFEND;

      { Retrieve a pointer to the buffer controlware data on the restart file.

      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);
      RESET restart_file_seq_p TO cell_p;
      NEXT restart_file_buffer_p: [[REP entry_p^.words OF dut$de_buffer_controlware_word]] IN
            restart_file_seq_p;
      IF restart_file_buffer_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /display_opened/;  {---->
      IFEND;
      RESET restart_file_buffer_p;

      { Determine the radix.

      IF entry_p^.channel_type = duc$de_7155_adapter THEN
        radix := 8;
      ELSE
        radix := 16;
      IFEND;

      { Display the data.

      dup$display_data (pvt [p$display_option].value, FALSE, radix, 0, entry_p^.words, display_control,
            restart_file_buffer_p, end_of_input_file, status);

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_buffer_controlware;
MODEND dum$display_buffer_controlware;
*DECK DECK=DUM$DISPLAY_B_AND_C_REGISTERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display B and C Registers Command' ??
MODULE dum$display_b_and_c_registers;

{ PURPOSE:
{   This module contains the command which displays the B and C registers that are stored in the
{   BXX/BX1 and CXX/CX1 records.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$display_register_data
*copyc dup$find_record_list_entry
*copyc dup$new_page_procedure
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'display_record_data', EJECT ??

{ PURPOSE:
{   This procedure displays data from the record.

  PROCEDURE display_record_data
    (    record_name: string (3);
         iou_index: string (1);
         entry_p: ^dut$de_other_record_entry;
     VAR display_control: clt$display_control);

    CONST
      c$number_of_bytes = 80;

    TYPE
      t$record_data = PACKED ARRAY [1 .. c$number_of_bytes] OF t$record_data_entry,

      t$record_data_entry = PACKED RECORD
        unused: 0 .. 0f(16),
        data: 0 .. 0ff(16),
      RECEND,

      t$unpacked_data = RECORD
        CASE boolean OF
        = TRUE =
          data: ARRAY [1 .. c$number_of_bytes] OF 0 .. 0ff(16),
        = FALSE =
          registers: ARRAY [0 .. 9] OF ARRAY [1 .. 8] OF 0 .. 0ff(16),
        CASEND,
      RECEND;

    VAR
      cell_p: ^cell,
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      index: 0 .. 0ff(16),
      integer_string: ost$string,
      record_data_p: ^t$record_data,
      restart_file_seq_p: ^SEQ ( * ),
      string_length: integer,
      unpacked_data: t$unpacked_data;

    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);
    RESET restart_file_seq_p TO cell_p;

    IF #SIZE (t$record_data) > entry_p^.size THEN
      clp$put_display (display_control, 'ERROR - Not enough data in the record, data not displayed.',
            clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;

    STRINGREP (display_string, string_length, record_name, ' - ', record_name(1), '-Registers:');
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    clp$put_display (display_control, ' ', clc$trim, ignore_status);
    STRINGREP (display_string, string_length, '  This record contains the pre-deadstart contents of the');
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    STRINGREP (display_string, string_length, '  ', record_name(1), '-Registers for IOU', iou_index, '.');
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    clp$put_display (display_control, ' ', clc$trim, ignore_status);

    NEXT record_data_p IN restart_file_seq_p;
    FOR index := 1 TO c$number_of_bytes DO
      unpacked_data.data [index] := record_data_p^ [index].data;
    FOREND;

    FOR index := 0 TO 9 DO
      clp$convert_integer_to_string (index, 10, FALSE, integer_string, ignore_status);
      STRINGREP (display_string, string_length, record_name(1),
            integer_string.value (1, integer_string.size));
      dup$display_register_data (display_string (1, string_length), unpacked_data.registers [index],
            display_control);
    FOREND;
    clp$put_display (display_control, ' ', clc$trim, ignore_status);

  PROCEND display_record_data;
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_b_and_c_registers', EJECT ??

{ PURPOSE:
{   This procedure displays the B and C registers.

  PROCEDURE [XDCL] dup$display_b_and_c_registers
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_b_and_c_registers, disbacr (
{   output, o: file = $optional
{   title, t: string 1..31 = 'display_b_and_c_registers'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (27),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 9, 4, 7, 52, 19, 766],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TITLE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 27],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_b_and_c_registers'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$title = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      time_zone: ost$time_zone,
      data_displayed: boolean,
      data_value: clt$data_value,
      display_control: clt$display_control,
      entry_p: ^dut$de_other_record_entry,
      ignore_status: ost$status,
      output_display_opened: boolean,
      ring_attributes: amt$ring_attributes;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

    { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      data_displayed := FALSE;

      data_value.kind := clc$name;
      data_value.name_value := 'BXX';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p <> NIL THEN
        data_displayed := TRUE;
        display_record_data ('BXX', '0', entry_p, display_control);
      IFEND;

      data_value.kind := clc$name;
      data_value.name_value := 'BX1';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p <> NIL THEN
        data_displayed := TRUE;
        display_record_data ('BX1', '1', entry_p, display_control);
      IFEND;

      data_value.kind := clc$name;
      data_value.name_value := 'CXX';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p <> NIL THEN
        data_displayed := TRUE;
        display_record_data ('CXX', '0', entry_p, display_control);
      IFEND;

      data_value.kind := clc$name;
      data_value.name_value := 'CX1';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p <> NIL THEN
        data_displayed := TRUE;
        display_record_data ('CX1', '1', entry_p, display_control);
      IFEND;

      IF NOT data_displayed THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,
              'The BXX/BX1 and CXX/CX1 records are', status);
      IFEND;

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_b_and_c_registers;
MODEND dum$display_b_and_c_registers;
*DECK DECK=DUM$DISPLAY_CALL_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Call Command' ??                                               
MODULE dum$display_call_command;                                                                              
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains the code for the display_call command.                                               
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc due$exception_condition_codes                                                                          
*copyc dut$condition_registers                                                                                
?? POP ??                                                                                                     
*copyc clp$close_display                                                                                      
*copyc clp$convert_integer_to_rjstring                                                                        
*copyc clp$get_command_origin                                                                                 
*copyc clp$horizontal_tab_display                                                                             
*copyc clp$new_display_line                                                                                   
*copyc clp$open_display_reference                                                                             
*copyc clp$put_display                                                                                        
*copyc dup$copy_virtual_memory_pva                                                                            
*copyc dup$determine_dump_information                                                                         
*copyc dup$display_exchange_package                                                                           
*copyc dup$display_message                                                                                    
*copyc dup$evaluate_parameters                                                                                
*copyc dup$new_page_procedure                                                                                 
*copyc dup$retrieve_exchange_package                                                                          
*copyc dup$put_item                                                                                           
*copyc ocp$find_debug_address                                                                                 
*copyc osp$append_status_integer                                                                              
*copyc osp$append_status_parameter                                                                            
*copyc osp$set_status_abnormal                                                                                
*copyc osp$disestablish_cond_handler                                                                          
*copyc osp$establish_block_exit_hndlr                                                                         
?? EJECT ??                                                                                                   
*copyc duv$dump_environment_p                                                                                 
*copyc duv$execution_environment                                                                              
*copyc duv$title_data                                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'display_stack_frame', EJECT ??                                                                
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays a stack frame.                                                                    
                                                                                                              
  PROCEDURE display_stack_frame                                                                               
    (    current_stack_frame: ost$pva;                                                                        
         exchange_package_p: ^dut$exchange_package;                                                           
         processor: 0 .. duc$de_maximum_processors;                                                           
         display_save_area: boolean;                                                                          
     VAR next_stack_frame_pva: ost$pva;                                                                       
     VAR display_control: clt$display_control;                                                                
     VAR status: ost$status);                                                                                 
                                                                                                              
    TYPE                                                                                                      
      t$a_register = RECORD                                                                                   
        CASE t$a_register_types OF                                                                            
        = c$a4_ucr =                                                                                          
          user_condition_register: ost$user_conditions,                                                       
        = c$a5_mcr =                                                                                          
          monitor_condition_register: ost$monitor_conditions,                                                 
        = c$a_n =                                                                                             
          two_bytes: 0 .. 0ffff(16),                                                                          
          a_register: ost$pva,                                                                                
        CASEND,                                                                                               
      RECEND,                                                                                                 
                                                                                                              
      t$a_register_types = (c$a4_ucr, c$a5_mcr, c$a_n),                                                       
                                                                                                              
      t$ascii_characters = SET OF 0 .. 255,                                                                   
                                                                                                              
      t$frame_descriptor = PACKED RECORD                                                                      
        critical_frame_flag: boolean,                                                                         
        on_condition_flag: boolean,                                                                           
        undefined: 0 .. 3(16),                                                                                
        x_starting: ost$register_number,                                                                      
        a_terminating: ost$register_number,                                                                   
        x_terminating: ost$register_number,                                                                   
      RECEND,                                                                                                 
                                                                                                              
      t$minimum_save_area = PACKED RECORD                                                                     
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          p_register: ost$p_register,                                                                         
          vmid: ost$virtual_machine_identifier,                                                               
          undefined: 0 .. 0fff(16),                                                                           
          a0_dynamic_space_pointer: ost$pva,                                                                  
          frame_descriptor: t$frame_descriptor,                                                               
          a1_current_stack_frame: ost$pva,                                                                    
          user_mask: ost$user_conditions,                                                                     
          a2_previous_save_area: ost$pva,                                                                     
        = FALSE =                                                                                             
          p: t$a_register,                                                                                    
          a_registers: ARRAY [0 .. 2] OF t$a_register,                                                        
        CASEND,                                                                                               
      RECEND,                                                                                                 
                                                                                                              
      t$stack_frame_seq = SEQ (REP 1 OF t$minimum_save_area, REP 13 OF t$a_register,                          
            REP 16 OF ost$x_register),                                                                        
                                                                                                              
      t$x_register = RECORD                                                                                   
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          int: ost$x_register,                                                                                
        = FALSE =                                                                                             
          part: ARRAY [0 .. 3] OF 0 .. 0ffff(16),                                                             
        CASEND,                                                                                               
      RECEND;                                                                                                 
                                                                                                              
    VAR                                                                                                       
      a_registers_p: ^ARRAY [ * ] OF t$a_register,                                                            
      a_terminating: ost$register_number,                                                                     
      access_data: dut$access_data,                                                                           
      blank: t$ascii_characters,                                                                              
      bytes_returned: ost$segment_length,                                                                     
      current_a_register: ost$register_number,                                                                
      current_x_register: ost$register_number,                                                                
      display_string: string (osc$max_string_size),                                                           
      found: boolean,                                                                                         
      found_blank: boolean,                                                                                   
      ignore_status: ost$status,                                                                              
      index: integer,                                                                                         
      interactive: boolean,                                                                                   
      local_status: ost$status,                                                                               
      mask_difference: ost$user_conditions,                                                                   
      maximum_frame_saved: boolean,                                                                           
      minimum_save_area_p: ^t$minimum_save_area,                                                              
      module_name: pmt$program_name,                                                                          
      monitor_condition: ost$monitor_condition,                                                               
      monitor_conditions: ost$monitor_conditions,                                                             
      offset_in_section: ost$segment_offset,                                                                  
      second_display_string: string (35),                                                                     
      section_name: pmt$program_name,                                                                         
      stack_frame_p: ^SEQ ( * ),                                                                              
      stack_frame_seq: t$stack_frame_seq,                                                                     
      stack_frame_seq_p: ^t$stack_frame_seq,                                                                  
      string_length: integer,                                                                                 
      trap_occurred: boolean,                                                                                 
      user_condition: ost$user_condition,                                                                     
      user_conditions: ost$user_conditions,                                                                   
      user_mask: ost$user_conditions,                                                                         
      x_part: 0 .. 3,                                                                                         
      x_registers_p: ^ARRAY [ * ] OF t$x_register,                                                            
      x_starting: ost$register_number,                                                                        
      x_terminating: ost$register_number;                                                                     
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    stack_frame_seq_p := ^stack_frame_seq;                                                                    
    RESET stack_frame_seq_p;                                                                                  
    user_mask := exchange_package_p^.user_mask;                                                               
                                                                                                              
    { Retrieve the current stack frame from the restart file.                                                 
                                                                                                              
    NEXT stack_frame_p: [[REP #SIZE (t$stack_frame_seq) OF cell]] IN stack_frame_seq_p;                       
    IF stack_frame_p = NIL THEN                                                                               
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    RESET stack_frame_p;                                                                                      
    dup$copy_virtual_memory_pva (current_stack_frame, exchange_package_p^, processor,                         
          #SIZE (t$stack_frame_seq), TRUE, bytes_returned, stack_frame_p, access_data, status);               
    IF NOT status.normal THEN                                                                                 
      IF status.condition = due$address_translation_error THEN                                                
        dup$display_message (status, display_control);                                                        
        osp$set_status_abnormal (duc$dump_analyzer_id, due$invalid_sf_pointer, '', status);                   
        osp$append_status_parameter (osc$status_parameter_delimiter, ', segment = ',  status);                
        osp$append_status_integer (osc$status_parameter_delimiter, current_stack_frame.seg, 16, TRUE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, ', offset = ', status);                  
        osp$append_status_integer (osc$status_parameter_delimiter, current_stack_frame.offset, 16, TRUE,      
              status);                                                                                        
        clp$get_command_origin (interactive, local_status);                                                   
        IF local_status.normal AND NOT interactive THEN                                                       
          dup$display_message (status, display_control);                                                      
        IFEND;                                                                                                
      IFEND;                                                                                                  
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF bytes_returned = 0 THEN                                                                                
      osp$set_status_abnormal (duc$dump_analyzer_id, due$display_terminated, 'This frame is paged out.',      
            status);                                                                                          
      dup$display_message (status, display_control);                                                          
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Retrieve the minimum save area, the A registers and the X registers from the stack frame.               
                                                                                                              
    RESET stack_frame_p;                                                                                      
    minimum_save_area_p := NIL;                                                                               
    a_registers_p := NIL;                                                                                     
    x_registers_p := NIL;                                                                                     
    IF bytes_returned >= #SIZE (t$minimum_save_area) THEN                                                     
      NEXT minimum_save_area_p IN stack_frame_p;                                                              
      IF minimum_save_area_p = NIL THEN                                                                       
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      next_stack_frame_pva := minimum_save_area_p^.a2_previous_save_area;                                     
      a_terminating := minimum_save_area_p^.frame_descriptor.a_terminating;                                   
      x_starting := minimum_save_area_p^.frame_descriptor.x_starting;                                         
      x_terminating := minimum_save_area_p^.frame_descriptor.x_terminating;                                   
      maximum_frame_saved := (a_terminating = 0f(16)) AND (x_starting = 0) AND (x_terminating = 0f(16));      
      IF a_terminating > 2 THEN                                                                               
        NEXT a_registers_p: [3 .. a_terminating] IN stack_frame_p;                                            
        IF a_registers_p = NIL THEN                                                                           
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
      IFEND;                                                                                                  
      IF (a_terminating >= 2) AND (x_starting <= x_terminating) THEN                                          
        NEXT x_registers_p: [x_starting .. x_terminating] IN stack_frame_p;                                   
        IF x_registers_p = NIL THEN                                                                           
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
      IFEND                                                                                                   
    IFEND;                                                                                                    
                                                                                                              
    clp$horizontal_tab_display (display_control, 13, ignore_status);                                          
                                                                                                              
    ocp$find_debug_address (minimum_save_area_p^.p_register.pva.seg,                                          
          minimum_save_area_p^.p_register.pva.offset, found, module_name, section_name, offset_in_section,    
          status);                                                                                            
    IF NOT status.normal THEN                                                                                 
      IF (status.condition <> oce$e_debug_table_not_open) THEN                                                
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      status.normal := TRUE;                                                                                  
      found := FALSE;                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF found THEN                                                                                             
      blank := $t$ascii_characters[$INTEGER(' ')];                                                            
      #SCAN (blank, section_name, index, found_blank);                                                        
      STRINGREP (display_string, string_length, section_name (1, index - 1), ' +', offset_in_section: #(16),  
            '(16)');                                                                                          
      dup$put_item (display_string (1, string_length), clc$no_trim, amc$continue, display_control);           
      STRINGREP (display_string, string_length, ' in ', module_name);                                         
      dup$put_item (display_string (1, string_length), clc$trim, amc$terminate, display_control);             
    ELSE                                                                                                      
      STRINGREP (display_string, string_length, ' P = ', minimum_save_area_p^.p_register.pva.ring: 2: #(16),  
            minimum_save_area_p^.p_register.pva.seg: 4: #(16),                                                
            minimum_save_area_p^.p_register.pva.offset: 10: #(16));                                           
      dup$put_item (display_string (1, string_length), clc$no_trim, amc$terminate, display_control);          
    IFEND;                                                                                                    
                                                                                                              
   /display_summary/                                                                                          
    BEGIN                                                                                                     
      IF (bytes_returned >= 10(16)) AND (minimum_save_area_p^.vmid <> osc$cyber_180_mode) AND                 
            (minimum_save_area_p^.vmid <> osc$cyber_170_mode) THEN                                            
        osp$set_status_abnormal (duc$dump_analyzer_id, due$invalid_stack_frame,                               
              ' The vmid field is not either 180 mode or 170 mode', local_status);                            
        dup$display_message (local_status, display_control);                                                  
        EXIT /display_summary/;  {---->                                                                       
      IFEND;                                                                                                  
                                                                                                              
      IF bytes_returned >= 18(16) THEN                                                                        
        IF a_terminating < 2 THEN                                                                             
          osp$set_status_abnormal (duc$dump_analyzer_id, due$invalid_stack_frame,                             
                ' In the sfsa descriptor, the terminating a register is less than 2.', local_status);         
          dup$display_message (local_status, display_control);                                                
          EXIT /display_summary/;  {---->                                                                     
        IFEND;                                                                                                
        IF minimum_save_area_p^.frame_descriptor.critical_frame_flag THEN                                     
          clp$put_display (display_control, ' --  The critical frame flag is set for this frame.',            
                clc$no_trim, ignore_status);                                                                  
        IFEND;                                                                                                
        IF minimum_save_area_p^.frame_descriptor.on_condition_flag THEN                                       
          clp$put_display (display_control, ' --  The on condition flag is set for this frame.', clc$no_trim, 
                ignore_status);                                                                               
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
      IF bytes_returned >= #SIZE (t$minimum_save_area) THEN                                                   
        IF user_mask <> minimum_save_area_p^.user_mask THEN                                                   
          clp$put_display (display_control, ' --  The user mask has changed:', clc$no_trim, ignore_status);   
          mask_difference := user_mask - minimum_save_area_p^.user_mask;                                      
          FOR user_condition := osc$privileged_instruction TO osc$invalid_bdp_data DO                         
            IF user_condition IN mask_difference THEN                                                         
              dup$put_item (' --  ', clc$no_trim, amc$start, display_control);                                
              dup$put_item (duv$cr_user_condition_reg_def [(duc$cr_user_condition_lower_bit +                 
                    $INTEGER (user_condition))], clc$trim, amc$continue, display_control);                    
              dup$put_item (' is now de-selected.', clc$no_trim, amc$terminate, display_control);             
            IFEND;                                                                                            
          FOREND;                                                                                             
          mask_difference := minimum_save_area_p^.user_mask - user_mask;                                      
          FOR user_condition := osc$privileged_instruction TO osc$invalid_bdp_data DO                         
            IF user_condition IN mask_difference THEN                                                         
              dup$put_item (' --  ', clc$no_trim, amc$start, display_control);                                
              dup$put_item (duv$cr_user_condition_reg_def [(duc$cr_user_condition_lower_bit +                 
                    $INTEGER (user_condition))], clc$trim, amc$continue, display_control);                    
              dup$put_item (' is now selected.', clc$no_trim, amc$terminate, display_control);                
            IFEND;                                                                                            
          FOREND;                                                                                             
          user_mask := minimum_save_area_p^.user_mask;                                                        
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
      trap_occurred := FALSE;                                                                                 
      IF bytes_returned >= 38(16) THEN                                                                        
        IF maximum_frame_saved THEN                                                                           
          user_conditions := a_registers_p^ [4].user_condition_register * user_mask;                          
          monitor_conditions := a_registers_p^ [5].monitor_condition_register *                               
                exchange_package_p^.monitor_mask;                                                             
          trap_occurred := (user_conditions <> $ost$user_conditions[ ]) OR                                    
                (monitor_conditions <> $ost$monitor_conditions[ ]);                                           
          IF trap_occurred THEN                                                                               
            clp$put_display (display_control, 'This is probably a trap frame.', clc$no_trim, ignore_status);  
          IFEND;                                                                                              
          IF user_conditions <> $ost$user_conditions [ ] THEN                                                 
            dup$put_item ('user conditions:', clc$no_trim, amc$start, display_control);                       
            FOR user_condition := osc$privileged_instruction TO osc$invalid_bdp_data DO                       
              IF user_condition IN user_conditions THEN                                                       
                clp$horizontal_tab_display (display_control, 21, ignore_status);                              
                dup$put_item (duv$cr_user_condition_reg_def [(duc$cr_user_condition_lower_bit +               
                      $INTEGER (user_condition))], clc$trim, amc$terminate, display_control);                 
              IFEND;                                                                                          
            FOREND;                                                                                           
          IFEND;                                                                                              
          IF monitor_conditions <> $ost$monitor_conditions [ ] THEN                                           
            dup$put_item ('monitor conditions:', clc$no_trim, amc$start, display_control);                    
            FOR monitor_condition := osc$detected_uncorrected_err TO osc$trap_exception DO                    
              IF monitor_condition IN monitor_conditions THEN                                                 
                clp$horizontal_tab_display (display_control, 21, ignore_status);                              
                dup$put_item (duv$cr_mtr_condition_reg_def [(duc$cr_mtr_condition_lower_bit +                 
                      $INTEGER (monitor_condition))], clc$trim, amc$terminate, display_control);              
              IFEND;                                                                                          
            FOREND;                                                                                           
          IFEND;                                                                                              
        IFEND;                                                                                                
      IFEND;                                                                                                  
    END /display_summary/;                                                                                    
                                                                                                              
   /display_frame/                                                                                            
    BEGIN                                                                                                     
      IF display_save_area THEN                                                                               
        clp$new_display_line (display_control, 1, ignore_status);                                             
        display_string := ' ';                                                                                
        clp$convert_integer_to_rjstring (minimum_save_area_p^.p.two_bytes, 16, FALSE, '0',                    
              display_string (1, 4), ignore_status);                                                          
        clp$horizontal_tab_display (display_control, 14, ignore_status);                                      
        dup$put_item (display_string (1, 4), clc$no_trim, amc$continue, display_control);                     
        STRINGREP (display_string, string_length, ' P  ',                                                     
              minimum_save_area_p^.p_register.pva.ring: 2: #(16),                                             
              minimum_save_area_p^.p_register.pva.seg: 4: #(16),                                              
              minimum_save_area_p^.p_register.pva.offset: 10: #(16));                                         
        clp$horizontal_tab_display (display_control, 24, ignore_status);                                      
        dup$put_item (display_string (1, string_length), clc$no_trim, amc$terminate, display_control);        
                                                                                                              
        IF bytes_returned < 10(16) THEN                                                                       
          EXIT /display_frame/;  {---->                                                                       
        IFEND;                                                                                                
                                                                                                              
        dup$put_item ('vmid', clc$no_trim, amc$start, display_control);                                       
        display_string := ' ';                                                                                
        clp$convert_integer_to_rjstring (minimum_save_area_p^.a_registers[0].two_bytes, 16, FALSE, '0',       
              display_string (1, 4), ignore_status);                                                          
        clp$horizontal_tab_display (display_control, 14, ignore_status);                                      
        dup$put_item (display_string (1, 4), clc$no_trim, amc$continue, display_control);                     
        STRINGREP (display_string, string_length, ' A0 ',                                                     
              minimum_save_area_p^.a0_dynamic_space_pointer.ring: 2: #(16),                                   
              minimum_save_area_p^.a0_dynamic_space_pointer.seg: 4: #(16),                                    
              minimum_save_area_p^.a0_dynamic_space_pointer.offset: 10: #(16), ' (dsp)');                     
        clp$horizontal_tab_display (display_control, 24, ignore_status);                                      
        dup$put_item (display_string (1, string_length), clc$no_trim, amc$terminate, display_control);        
                                                                                                              
        IF bytes_returned < 18(16) THEN                                                                       
          EXIT /display_frame/;  {---->                                                                       
        IFEND;                                                                                                
                                                                                                              
        dup$put_item ('sfsa desc', clc$no_trim, amc$start, display_control);                                  
        display_string := ' ';                                                                                
        clp$convert_integer_to_rjstring (minimum_save_area_p^.a_registers[1].two_bytes, 16, FALSE, '0',       
              display_string (1, 4), ignore_status);                                                          
        clp$horizontal_tab_display (display_control, 14, ignore_status);                                      
        dup$put_item (display_string (1, 4), clc$no_trim, amc$continue, display_control);                     
        STRINGREP (display_string, string_length, ' A1 ',                                                     
              minimum_save_area_p^.a1_current_stack_frame.ring: 2: #(16),                                     
              minimum_save_area_p^.a1_current_stack_frame.seg: 4: #(16),                                      
              minimum_save_area_p^.a1_current_stack_frame.offset: 10: #(16), ' (csf)');                       
        clp$horizontal_tab_display (display_control, 24, ignore_status);                                      
        dup$put_item (display_string (1, string_length), clc$no_trim, amc$terminate, display_control);        
                                                                                                              
        IF bytes_returned < 20(16) THEN                                                                       
          EXIT /display_frame/;  {---->                                                                       
        IFEND;                                                                                                
                                                                                                              
        dup$put_item ('user mask', clc$no_trim, amc$start, display_control);                                  
        display_string := ' ';                                                                                
        clp$convert_integer_to_rjstring (minimum_save_area_p^.a_registers [2].two_bytes, 16, FALSE, '0',      
              display_string (1, 4), ignore_status);                                                          
        clp$horizontal_tab_display (display_control, 14, ignore_status);                                      
        dup$put_item (display_string (1, 4), clc$no_trim, amc$continue, display_control);                     
        STRINGREP (display_string, string_length, ' A2 ',                                                     
              minimum_save_area_p^.a2_previous_save_area.ring: 2: #(16),                                      
              minimum_save_area_p^.a2_previous_save_area.seg: 4: #(16),                                       
              minimum_save_area_p^.a2_previous_save_area.offset: 10: #(16), ' (psa)');                        
        clp$horizontal_tab_display (display_control, 24, ignore_status);                                      
        dup$put_item (display_string (1, string_length), clc$no_trim, amc$terminate, display_control);        
                                                                                                              
        FOR current_a_register := 3 TO a_terminating DO                                                       
          IF bytes_returned < ((current_a_register + 2) * 8) THEN                                             
            EXIT /display_frame/;  {---->                                                                     
          IFEND;                                                                                              
          IF (current_a_register = 4) AND trap_occurred THEN                                                  
            dup$put_item ('ucr', clc$no_trim, amc$start, display_control);                                    
          ELSEIF (current_a_register = 5) AND trap_occurred THEN                                              
            dup$put_item ('mcr', clc$no_trim, amc$start, display_control);                                    
          IFEND;                                                                                              
          display_string := ' ';                                                                              
          clp$convert_integer_to_rjstring (a_registers_p^ [current_a_register].two_bytes, 16, FALSE, '0',     
                display_string (1, 4), ignore_status);                                                        
          clp$horizontal_tab_display (display_control, 14, ignore_status);                                    
          dup$put_item (display_string (1, 4), clc$no_trim, amc$continue, display_control);                   
          STRINGREP (second_display_string, string_length, current_a_register: 2: #(16));                     
          STRINGREP (display_string, string_length, ' A', second_display_string (2), ' ',                     
                a_registers_p^ [current_a_register].a_register.ring: 2: #(16),                                
                a_registers_p^ [current_a_register].a_register.seg: 4: #(16),                                 
                a_registers_p^ [current_a_register].a_register.offset: 10: #(16));                            
          clp$horizontal_tab_display (display_control, 24, ignore_status);                                    
          dup$put_item (display_string (1, string_length), clc$trim, amc$terminate, display_control);         
        FOREND;                                                                                               
                                                                                                              
        clp$new_display_line (display_control, 1, ignore_status);                                             
                                                                                                              
        FOR current_x_register := x_starting TO x_terminating DO                                              
          IF bytes_returned < ((a_terminating + 2) + (current_x_register - x_starting)) * 8 THEN              
            EXIT /display_frame/;  {---->                                                                     
          IFEND;                                                                                              
          display_string := '';                                                                               
          STRINGREP (display_string (1, 2), string_length, current_x_register: 2: #(16));                     
          display_string (1) := 'X';                                                                          
          FOR x_part := 0 TO 3 DO                                                                             
            clp$convert_integer_to_rjstring (x_registers_p^ [current_x_register].part[x_part], 16, FALSE, '0',
                  display_string (4 + x_part * 5, 4), ignore_status);                                         
          FOREND;                                                                                             
          clp$horizontal_tab_display (display_control, 11, ignore_status);                                    
          dup$put_item (display_string (1, 22), clc$no_trim, amc$terminate, display_control);                 
        FOREND;                                                                                               
                                                                                                              
      IFEND;                                                                                                  
    END /display_frame/;                                                                                      
                                                                                                              
    IF bytes_returned < #SIZE (t$minimum_save_area) THEN                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$display_terminated,                                  
            'The remainder of this frame is paged out.', status);                                             
      dup$display_message (status, display_control);                                                          
    IFEND;                                                                                                    
                                                                                                              
  PROCEND display_stack_frame;                                                                                
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$display_call_command', EJECT ??                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays the call chain.                                                                   
                                                                                                              
  PROCEDURE [XDCL] dup$display_call_command                                                                   
    (    parameter_list: clt$parameter_list;                                                                  
     VAR status: ost$status);                                                                                 
                                                                                                              
{ PROCEDURE display_call, disc (                                                                              
{   exchange, e: any of                                                                                       
{       key                                                                                                   
{         (active a) (monitor m) (job j)                                                                      
{       keyend                                                                                                
{       integer 0..0ffffffff(16)                                                                              
{     anyend = 0..0ffffffff(16)                                                                               
{   processor, p: integer 0..3 = 0                                                                            
{   count, c: any of                                                                                          
{       key                                                                                                   
{         all                                                                                                 
{       keyend                                                                                                
{       integer 1..10000                                                                                      
{     anyend = all                                                                                            
{   start, s: any of                                                                                          
{       key                                                                                                   
{         (exchange_package ep)                                                                               
{       keyend                                                                                                
{       integer 0..10000                                                                                      
{     anyend = exchange_package                                                                               
{   display_option, do: list 1..2 of key                                                                      
{       (full f) (brief b) (save s)                                                                           
{     keyend = brief                                                                                          
{   title, t: string 1..31 = 'display_call'                                                                   
{   output, o: file = $optional                                                                               
{   status)                                                                                                   
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 15] of clt$pdt_parameter_name,                                                       
      parameters: array [1 .. 8] 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 .. 6] of clt$keyword_specification,                                         
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$integer_type_qualifier,                                                              
        recend,                                                                                               
        default_value: string (16),                                                                           
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type3: 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$integer_type_qualifier,                                                              
        recend,                                                                                               
        default_value: string (3),                                                                            
      recend,                                                                                                 
      type4: 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 .. 2] of clt$keyword_specification,                                         
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$integer_type_qualifier,                                                              
        recend,                                                                                               
        default_value: string (16),                                                                           
      recend,                                                                                                 
      type5: 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 .. 6] of clt$keyword_specification,                                         
        recend,                                                                                               
        default_value: string (5),                                                                            
      recend,                                                                                                 
      type6: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$string_type_qualifier,                                                                 
        default_value: string (14),                                                                           
      recend,                                                                                                 
      type7: record                                                                                           
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
      type8: record                                                                                           
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [90, 4, 18, 8, 52, 18, 406],                                                                              
    clc$command, 15, 8, 0, 0, 0, 0, 8, ''], [                                                                 
    ['C                              ',clc$abbreviation_entry, 3],                                            
    ['COUNT                          ',clc$nominal_entry, 3],                                                 
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 5],                                                 
    ['DO                             ',clc$abbreviation_entry, 5],                                            
    ['E                              ',clc$abbreviation_entry, 1],                                            
    ['EXCHANGE                       ',clc$nominal_entry, 1],                                                 
    ['O                              ',clc$abbreviation_entry, 7],                                            
    ['OUTPUT                         ',clc$nominal_entry, 7],                                                 
    ['P                              ',clc$abbreviation_entry, 2],                                            
    ['PROCESSOR                      ',clc$nominal_entry, 2],                                                 
    ['S                              ',clc$abbreviation_entry, 4],                                            
    ['START                          ',clc$nominal_entry, 4],                                                 
    ['STATUS                         ',clc$nominal_entry, 8],                                                 
    ['T                              ',clc$abbreviation_entry, 6],                                            
    ['TITLE                          ',clc$nominal_entry, 6]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [6, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 269,                        
  clc$optional_default_parameter, 0, 16],                                                                     
{ PARAMETER 2                                                                                                 
    [10, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 3                                                                                                 
    [2, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,                         
  clc$optional_default_parameter, 0, 3],                                                                      
{ PARAMETER 4                                                                                                 
    [12, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,                        
  clc$optional_default_parameter, 0, 16],                                                                     
{ PARAMETER 5                                                                                                 
    [3, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 245,                        
  clc$optional_default_parameter, 0, 5],                                                                      
{ PARAMETER 6                                                                                                 
    [15, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,                          
  clc$optional_default_parameter, 0, 14],                                                                     
{ PARAMETER 7                                                                                                 
    [8, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],                                                                                                       
{ PARAMETER 8                                                                                                 
    [13, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name],                                                         
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,                      
  clc$optional_parameter, 0, 0]],                                                                             
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],                                           
    FALSE, 2],                                                                                                
    229, [[1, 0, clc$keyword_type], [6], [                                                                    
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                 
      ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],                      
      ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                 
      ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 3],                      
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                 
      ['MONITOR                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]                      
      ],                                                                                                      
    20, [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]]                                                    
    ,                                                                                                         
    '0..0ffffffff(16)'],                                                                                      
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, 3, 10],                                                                    
    '0'],                                                                                                     
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],                                           
    FALSE, 2],                                                                                                
    44, [[1, 0, clc$keyword_type], [1], [                                                                     
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]                      
      ],                                                                                                      
    20, [[1, 0, clc$integer_type], [1, 10000, 10]]                                                            
    ,                                                                                                         
    'all'],                                                                                                   
{ PARAMETER 4                                                                                                 
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],                                           
    FALSE, 2],                                                                                                
    81, [[1, 0, clc$keyword_type], [2], [                                                                     
      ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                 
      ['EXCHANGE_PACKAGE               ', clc$nominal_entry, clc$normal_usage_entry, 1]]                      
      ],                                                                                                      
    20, [[1, 0, clc$integer_type], [0, 10000, 10]]                                                            
    ,                                                                                                         
    'exchange_package'],                                                                                      
{ PARAMETER 5                                                                                                 
    [[1, 0, clc$list_type], [229, 1, 2, 0, FALSE, FALSE],                                                     
      [[1, 0, clc$keyword_type], [6], [                                                                       
      ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                 
      ['BRIEF                          ', clc$nominal_entry, clc$normal_usage_entry, 2],                      
      ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                 
      ['FULL                           ', clc$nominal_entry, clc$normal_usage_entry, 1],                      
      ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                 
      ['SAVE                           ', clc$nominal_entry, clc$normal_usage_entry, 3]]                      
      ]                                                                                                       
    ,                                                                                                         
    'brief'],                                                                                                 
{ PARAMETER 6                                                                                                 
    [[1, 0, clc$string_type], [1, 31, FALSE],                                                                 
    '''display_call'''],                                                                                      
{ PARAMETER 7                                                                                                 
    [[1, 0, clc$file_type]],                                                                                  
{ PARAMETER 8                                                                                                 
    [[1, 0, clc$status_type]]];                                                                               
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$exchange = 1,                                                                                         
      p$processor = 2,                                                                                        
      p$count = 3,                                                                                            
      p$start = 4,                                                                                            
      p$display_option = 5,                                                                                   
      p$title = 6,                                                                                            
      p$output = 7,                                                                                           
      p$status = 8;                                                                                           
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 8] of clt$parameter_value;                                                             
                                                                                                              
    TYPE                                                                                                      
      t$next_stack_frame_seq = SEQ (REP 1 OF ost$pva);                                                        
                                                                                                              
    VAR                                                                                                       
      access_data: dut$access_data,                                                                           
      bytes_returned: ost$segment_length,                                                                     
      count: 1 .. 10000,                                                                                      
      current: 0 .. 10000,                                                                                    
      current_stack_frame: ost$pva,                                                                           
      default_list: ARRAY [1 .. 2] OF dut$default_change_list_entry,                                          
      display_control: clt$display_control,                                                                   
      display_save_area: boolean,                                                                             
      display_string: string (osc$max_string_size),                                                           
      dump_information: dut$dump_information,                                                                 
      exchange_package_p: ^dut$exchange_package,                                                              
      full_display: boolean,                                                                                  
      ignore_status: ost$status,                                                                              
      interactive: boolean,                                                                                   
      list_p: ^clt$data_value,                                                                                
      local_status: ost$status,                                                                               
      next_stack_frame_p: ^SEQ ( * ),                                                                         
      next_stack_frame_pva: ost$pva,                                                                          
      next_stack_frame_pva_p: ^ost$pva,                                                                       
      next_stack_frame_seq: t$next_stack_frame_seq,                                                           
      next_stack_frame_seq_p: ^t$next_stack_frame_seq,                                                        
      option_p: ^clt$data_value,                                                                              
      output_display_opened: boolean,                                                                         
      processor: 0 .. duc$de_maximum_processors,                                                              
      ring_attributes: amt$ring_attributes,                                                                   
      start: 0 .. 10000,                                                                                      
      string_length: integer;                                                                                 
                                                                                                              
*copy dup$abort_handler                                                                                       
?? NEWTITLE := 'clean_up', EJECT ??                                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure is called from the abort handler to close the file.                                        
                                                                                                              
    PROCEDURE [INLINE] clean_up;                                                                              
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      IF output_display_opened THEN                                                                           
        clp$close_display (display_control, ignore_status);                                                   
      IFEND;                                                                                                  
                                                                                                              
    PROCEND clean_up;                                                                                         
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the EXCHANGE and PROCESSOR parameters.                                     
                                                                                                              
    default_list [1].default_name := duc$dp_exchange;                                                         
    default_list [1].number := p$exchange;                                                                    
    default_list [2].default_name := duc$dp_processor;                                                        
    default_list [2].number := p$processor;                                                                   
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF pvt [p$count].value^.kind = clc$keyword THEN                                                           
      count := 10000;                                                                                         
    ELSE                                                                                                      
      count := pvt [p$count].value^.integer_value.value;                                                      
    IFEND;                                                                                                    
                                                                                                              
    IF pvt [p$start].value^.kind = clc$keyword THEN                                                           
      start := 0;                                                                                             
    ELSE                                                                                                      
      start := pvt [p$start].value^.integer_value.value;                                                      
    IFEND;                                                                                                    
                                                                                                              
    { Determine the display options.                                                                          
                                                                                                              
    full_display := FALSE;                                                                                    
    display_save_area := FALSE;                                                                               
    list_p := pvt [p$display_option].value;                                                                   
    WHILE list_p <> NIL DO                                                                                    
      option_p := list_p^.element_value;                                                                      
      list_p := list_p^.link;                                                                                 
      IF option_p^.keyword_value = 'FULL' THEN                                                                
        full_display := TRUE;                                                                                 
      ELSEIF option_p^.keyword_value = 'BRIEF' THEN                                                           
        full_display := FALSE;                                                                                
      ELSE  { option_p^.keyword_value = 'SAVE' }                                                              
        display_save_area := TRUE;                                                                            
      IFEND;                                                                                                  
    WHILEND;                                                                                                  
                                                                                                              
    processor := pvt [p$processor].value^.integer_value.value;                                                
                                                                                                              
    output_display_opened := FALSE;                                                                           
    osp$establish_block_exit_hndlr (^abort_handler);                                                          
                                                                                                              
   /display_opened/                                                                                           
    BEGIN                                                                                                     
                                                                                                              
      { Prepare the output display file.                                                                      
                                                                                                              
      IF pvt [p$output].specified THEN                                                                        
        ring_attributes.r1 := #RING (^ring_attributes);                                                       
        ring_attributes.r2 := #RING (^ring_attributes);                                                       
        ring_attributes.r3 := #RING (^ring_attributes);                                                       
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,     
              ring_attributes, display_control, status);                                                      
        IF NOT status.normal THEN                                                                             
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
        output_display_opened := TRUE;                                                                        
      ELSE                                                                                                    
        display_control := duv$execution_environment.output_file.display_control;                             
        display_control.line_number := display_control.page_length + 1;                                       
      IFEND;                                                                                                  
                                                                                                              
      duv$title_data.build_title := TRUE;                                                                     
      duv$title_data.command_name := pvt [p$title].value^.string_value^;                                      
                                                                                                              
      dup$retrieve_exchange_package (processor, pvt [p$exchange].value^, exchange_package_p, status);         
      IF NOT status.normal THEN                                                                               
        EXIT /display_opened/;  {---->                                                                        
      IFEND;                                                                                                  
                                                                                                              
      dup$determine_dump_information (dump_information);                                                      
                                                                                                              
      IF pvt [p$exchange].value^.kind = clc$keyword THEN                                                      
        IF pvt [p$exchange].value^.keyword_value = 'ACTIVE' THEN                                              
          IF ((dump_information.dump_type = duc$di_dt_cy2000) AND (duc$ee_cy_monitor_mode IN                  
                duv$execution_environment.processor_registers [processor].status_summary.cy2000)) OR          
                (duc$ee_gen_180_monitor_mode IN                                                               
                duv$execution_environment.processor_registers [processor].status_summary.general) THEN        
            clp$put_display (display_control, 'Active exchange package selected: CPU is in 180 monitor mode.',
                  clc$no_trim, ignore_status);                                                                
          ELSE                                                                                                
            clp$put_display (display_control, 'Active exchange package selected: CPU is in job mode.',        
                  clc$no_trim, ignore_status);                                                                
          IFEND;                                                                                              
        ELSEIF pvt [p$exchange].value^.keyword_value = 'MONITOR' THEN                                         
          STRINGREP (display_string, string_length, 'Exchange address = ',                                    
                duv$execution_environment.processor_registers [processor].monitor_process_state: #(16),       
                '(16)');                                                                                      
          clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);      
        ELSE  { pvt [p$exchange].value^.keyword_value = 'JOB' }                                               
          STRINGREP (display_string, string_length, 'Exchange address = ',                                    
                duv$execution_environment.processor_registers [processor].job_process_state: #(16), '(16)');  
          clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);      
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
      IF start = 0 THEN                                                                                       
        dup$display_exchange_package (exchange_package_p^, full_display, display_control, status);            
        IF NOT status.normal THEN                                                                             
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
      ELSEIF exchange_package_p^.vmid = osc$cyber_170_mode THEN                                               
        osp$set_status_abnormal (duc$dump_analyzer_id, due$processor_in_170_mode, '', local_status);          
        dup$display_message (local_status, display_control);                                                  
      IFEND;                                                                                                  
                                                                                                              
      next_stack_frame_seq_p := ^next_stack_frame_seq;                                                        
      RESET next_stack_frame_seq_p;                                                                           
      next_stack_frame_pva := exchange_package_p^.a2_previous_save_area;                                      
                                                                                                              
      IF (next_stack_frame_pva.ring = osc$max_ring) AND (next_stack_frame_pva.seg = osc$maximum_segment) AND  
            (next_stack_frame_pva.offset < 0) THEN                                                            
        osp$set_status_abnormal (duc$dump_analyzer_id, due$display_terminated,                                
              'end of call chain encountered in the exchange package.', local_status);                        
        dup$display_message (local_status, display_control);                                                  
        EXIT /display_opened/;  {---->                                                                        
      IFEND;                                                                                                  
                                                                                                              
      IF start = 0 THEN                                                                                       
        IF count = 1 THEN                                                                                     
          EXIT /display_opened/;  {---->                                                                      
        ELSE                                                                                                  
          start := 1;                                                                                         
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
      { Skip to the desired stack frame.                                                                      
                                                                                                              
      FOR current := 1 TO (start - 1) DO                                                                      
                                                                                                              
        current_stack_frame := next_stack_frame_pva;                                                          
        current_stack_frame.offset := current_stack_frame.offset + 1a(16);                                    
                                                                                                              
        RESET next_stack_frame_seq_p;                                                                         
        NEXT next_stack_frame_p: [[REP 1 OF ost$pva]] IN next_stack_frame_seq_p;                              
        IF next_stack_frame_p = NIL THEN                                                                      
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
        dup$copy_virtual_memory_pva (current_stack_frame, exchange_package_p^, processor, #SIZE (ost$pva),    
              TRUE, bytes_returned, next_stack_frame_p, access_data, status);                                 
        IF NOT status.normal THEN                                                                             
          IF status.condition = due$address_translation_error THEN                                            
            dup$display_message (status, display_control);                                                    
            osp$set_status_abnormal (duc$dump_analyzer_id, due$invalid_sf_pointer, '', status);               
            osp$append_status_parameter (osc$status_parameter_delimiter, ', segment = ',  status);            
            osp$append_status_integer (osc$status_parameter_delimiter, current_stack_frame.seg, 16, TRUE,     
                  status);                                                                                    
            osp$append_status_parameter (osc$status_parameter_delimiter, ', offset = ', status);              
            osp$append_status_integer (osc$status_parameter_delimiter, current_stack_frame.offset, 16, TRUE,  
                  status);                                                                                    
            clp$get_command_origin (interactive, local_status);                                               
            IF local_status.normal AND NOT interactive THEN                                                   
              dup$display_message (status, display_control);                                                  
            IFEND;                                                                                            
          IFEND;                                                                                              
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
        IF bytes_returned < #SIZE (ost$pva) THEN                                                              
          osp$set_status_abnormal (duc$dump_analyzer_id, due$display_terminated, 'frame', local_status);      
          osp$append_status_integer (osc$status_parameter_delimiter, current, 10, FALSE, local_status);       
          osp$append_status_parameter (osc$status_parameter_delimiter, 'is paged out.', local_status);        
          dup$display_message (local_status, display_control);                                                
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
        RESET next_stack_frame_p;                                                                             
        NEXT next_stack_frame_pva_p IN next_stack_frame_p;                                                    
        IF next_stack_frame_pva_p = NIL THEN                                                                  
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
        next_stack_frame_pva := next_stack_frame_pva_p^;                                                      
                                                                                                              
        IF (next_stack_frame_pva.ring = osc$max_ring) AND (next_stack_frame_pva.seg = osc$maximum_segment) AND
              (next_stack_frame_pva.offset < 0) THEN                                                          
          osp$set_status_abnormal (duc$dump_analyzer_id, due$display_terminated,                              
                'end of call chain encountered in frame', local_status);                                      
          osp$append_status_integer (osc$status_parameter_delimiter, current, 10, FALSE, local_status);       
          dup$display_message (local_status, display_control);                                                
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
      FOREND;                                                                                                 
                                                                                                              
      { Display the desired stack frames.                                                                     
                                                                                                              
      FOR current := start TO (start + count - 1) DO                                                          
        current_stack_frame := next_stack_frame_pva;                                                          
                                                                                                              
        clp$new_display_line (display_control, 1, ignore_status);                                             
                                                                                                              
        STRINGREP (display_string, string_length, 'Frame ', current, ': ');                                   
        dup$put_item (display_string (1, string_length), clc$no_trim, amc$start, display_control);            
                                                                                                              
        display_stack_frame (current_stack_frame, exchange_package_p, processor, display_save_area,           
              next_stack_frame_pva, display_control, status);                                                 
        IF NOT status.normal THEN                                                                             
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
                                                                                                              
        IF (next_stack_frame_pva.ring = osc$max_ring) AND (next_stack_frame_pva.seg = osc$maximum_segment) AND
              (next_stack_frame_pva.offset < 0) THEN                                                          
          osp$set_status_abnormal (duc$dump_analyzer_id, due$display_terminated,                              
                'end of call chain encountered in frame', local_status);                                      
          osp$append_status_integer (osc$status_parameter_delimiter, current, 10, FALSE, local_status);       
          dup$display_message (local_status, display_control);                                                
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
      FOREND;                                                                                                 
                                                                                                              
    END /display_opened/;                                                                                     
                                                                                                              
    IF output_display_opened THEN                                                                             
      clp$close_display (display_control, ignore_status);                                                     
    IFEND;                                                                                                    
    osp$disestablish_cond_handler;                                                                            
                                                                                                              
  PROCEND dup$display_call_command;                                                                           
MODEND dum$display_call_command;                                                                              
*DECK DECK=DUM$DISPLAY_CATALOG_FILE EXPAND=TRUE
PROCEDURE dum$display_catalog_file, display_catalog_file, discf (
  catalog_file, cf: file = $required
  output, o: file = $output
  status)

  " This PROC displays a permanent file catalog.  This proc assumes you
  " are using analyze_system, and that pfm$r2_request_processor has
  " been added as a debug table.
  " When used in conjunction with analyze_dump use the copy_memory command
  " to copy the open catalog to a file that may be input to this procedure.

  VAR
    local_status: status
    ignore_status: status
    hold_file : file = $fname($unique)
    object_size: integer = 262
    cycle_size: integer = 189
    permit_size: integer = 167
    mainframe_entry_size: integer = 16
    archive_entry_size: integer = 186
    checksum_size: integer = 8
  VAREND

  set_file_attributes file=hold_file page_format=continuous
  current = $default_module
  chadm pfm$r2_request_processor

  catalog_address = $file_pva(catalog_file)
  object_count = $pv(?catalog_address.pft$catalog_file.physical_catalog_header.catalog_header..
.object_list_locator.object_count)
  object_list_adr = $pv(^?catalog_address.pft$catalog_file.physical_catalog_header.catalog_header..
.object_list_locator.relative_cell_pointer)
  object_list_adr = $mem(object_list_adr, 4)

  display_program_value name=?catalog_address.pft$catalog_file o=hold_file.$eoi

  FOR object = 1 TO object_count DO
    put_line line=(' ', ' ') o=hold_file.$eoi

    object_adr = catalog_address + object_list_adr + ((object - 1)* object_size)
    object_type = $pv(?object_adr.pft$physical_object.object_entry.object_type)
    object_name = $pv(?object_adr.pft$physical_object.object_entry.external_object_name)

    IF object_type = 'PFC$FREE_OBJECT' THEN
      put_line ' '//$strrep(object_adr, 16)//' =  '//object_type o=hold_file.$eoi
    ELSEIF (object_type = 'PFC$FILE_OBJECT') OR (object_type = 'PFC$PURGED_FILE_OBJECT') THEN
      put_line ' FILE:  '//object_name o=hold_file.$eoi
      display_program_value name=?object_adr.pft$physical_object o=hold_file.$eoi

      permit_count = $pv(?object_adr.pft$physical_object.object_entry.permit_list_locator.permit_count)
      permit_list_adr = $pv(..
            ^?object_adr.pft$physical_object.object_entry.permit_list_locator.relative_cell_pointer)
      permit_list_adr = $mem(permit_list_adr, 4)
      IF permit_count > 0 THEN
        put_line (' ', ' Permit list for file: '//object_name) o=hold_file.$eoi
        FOR permit = 1 TO permit_count DO
          permit_adr = catalog_address + permit_list_adr + ((permit - 1)* permit_size)
          display_program_value name=?permit_adr.pft$physical_permit o=hold_file.$eoi
          put_line '  ' o=hold_file.$eoi
        FOREND
      IFEND

      put_line (' ', ' === Cycle list for file: '//$trim(object_name)//' ===') o=hold_file.$eoi
      cycle_count = $pv(?object_adr.pft$physical_object.object_entry.cycle_list_locator.cycle_count)
      cycle_list_adr = $pv(..
            ^?object_adr.pft$physical_object.object_entry.cycle_list_locator.relative_cell_pointer)
      cycle_list_adr = $mem(cycle_list_adr, 4)
      FOR cycle = 1 TO cycle_count DO
        cycle_adr = catalog_address + cycle_list_adr + ((cycle - 1)* cycle_size)
        cycle_type = $pv(?cycle_adr.pft$physical_cycle.cycle_entry.entry_type)
        IF cycle_type = 'PFC$FREE_CYCLE_ENTRY' THEN
          put_line (' ', ' '//$strrep(cycle_adr, 16)//' =  PFC$FREE_CYCLE_ENTRY') o=hold_file.$eoi
        ELSE
          cycle_number = $pv(?cycle_adr.pft$physical_cycle.cycle_entry.cycle_number)
          put_line ' CYCLE: '//$trim(object_name)//'.'//$strrep(cycle_number, 10) o=hold_file.$eoi
          display_program_value name=?cycle_adr.pft$physical_cycle o=hold_file.$eoi

          fmd_size = $pv(?cycle_adr.pft$physical_cycle.cycle_entry.fmd_locator.fmd_size)
          fmd_adr = $pv(^?cycle_adr.pft$physical_cycle.cycle_entry.fmd_locator.relative_cell_pointer)
          fmd_adr = catalog_address + $mem(fmd_adr, 4)
          IF fmd_size > 0 THEN
            put_line ' ' o=hold_file.$eoi
            display_physical_fmd fmd_adr o=hold_file.$eoi
          IFEND


          IF $pv(?cycle_adr.pft$physical_cycle.cycle_entry.file_label_locator.file_label_size) > 0 THEN
            physical_label_addr = catalog_address + ..
                  $mem($pv(..
                  ^?cycle_adr.pft$physical_cycle.cycle_entry.file_label_locator.relative_cell_pointer), 4)
            put_line ' ' o=hold_file.$eoi
            dispv ?physical_label_addr.pft$physical_file_label o=hold_file.$eoi
            label_addr = physical_label_addr + checksum_size
            dispv ?label_addr.fmt$static_label_header o=hold_file.$eoi
          ELSE
            put_line 'Unable to locate file label' o=hold_file.$eoi
          IFEND

          archive_entry_count = $pv(..
                ?cycle_adr.pft$physical_cycle.cycle_entry.archive_list_locator.archive_count)
          archive_entry_addr = $pv(..
                ^?cycle_adr.pft$physical_cycle.cycle_entry.archive_list_locator.relative_cell_pointer)
          archive_entry_addr = catalog_address + $mem(archive_entry_addr, 4)
          FOR archive_entry = 1 TO archive_entry_count DO
            archive_entry_addr = archive_entry_addr + ((archive_entry-1)*archive_entry_size)
            dispv ?archive_entry_addr.pft$physical_archive o=hold_file.$eoi
          FOREND

          mainframe_addr = $pv(^?cycle_adr.pft$physical_cycle.cycle_entry.mainframe_usage_list_locator..
.relative_cell_pointer)
          mainframe_addr = catalog_address + $mem(mainframe_addr, 4)
          mainframe_count = $pv(..
                ?cycle_adr.pft$physical_cycle.cycle_entry.mainframe_usage_list_locator.mainframe_count)
          FOR mainframe = 1 TO mainframe_count DO
            mainframe_addr = mainframe_addr + ((mainframe-1)*mainframe_entry_size)
            dispv ?mainframe_addr.pft$physical_mainframe_usage o=hold_file.$eoi
          FOREND

        IFEND
      FOREND
    ELSE
      catalog_type = $pv(?object_adr.pft$physical_object.object_entry.catalog_object_locator.catalog_type)
      object_name = $pv(?object_adr.pft$physical_object.object_entry.external_object_name)

      IF catalog_type = 'PFC$EXTERNAL_CATALOG' THEN
        put_line ' EXTERNAL CATALOG: '//object_name o=hold_file.$eoi
        display_program_value name=?object_adr.pft$physical_object o=hold_file.$eoi

        permit_count = $pv(?object_adr.pft$physical_object.object_entry.permit_list_locator.permit_count)
        permit_list_adr = $pv(..
              ^?object_adr.pft$physical_object.object_entry.permit_list_locator.relative_cell_pointer)
        permit_list_adr = $mem(permit_list_adr, 4)
        IF permit_count > 0 THEN
          put_line (' ', ' Permit list for catalog: '//object_name) o=hold_file.$eoi
          FOR permit = 1 TO permit_count DO
            permit_adr = catalog_address + permit_list_adr + ((permit - 1)* permit_size)
            display_program_value name=?permit_adr.pft$physical_permit o=hold_file.$eoi
            put_line '  ' o=hold_file.$eoi
          FOREND
        IFEND

        fmd_size = $pv(..
              ?object_adr.pft$physical_object.object_entry.catalog_object_locator.fmd_locator.fmd_size)
        fmd_adr = $pv(^?object_adr.pft$physical_object.object_entry.catalog_object_locator.fmd_locator..
.relative_cell_pointer)
        fmd_adr = catalog_address + $mem(fmd_adr, 4)
        IF fmd_size > 0 THEN
          put_line ' ' o=hold_file.$eoi
          display_physical_fmd fmd_adr o=hold_file.$eoi
        IFEND

      ELSE
        put_line ' INTERNAL CATALOG (FAMILY): '//object_name o=hold_file.$eoi
        display_program_value name=?object_adr.pft$physical_object o=hold_file.$eoi

        ic_object_count = $pv(?object_adr.pft$physical_object.object_entry.catalog_object_locator..
.object_list_locator.object_count)
        ic_object_list_adr = $pv(^?object_adr.pft$physical_object.object_entry.catalog_object_locator..
.object_list_locator.relative_cell_pointer)
        ic_object_list_adr = $mem(ic_object_list_adr, 4)

        FOR ic_object = 1 TO ic_object_count DO
          put_line line=(' ', ' ') o=hold_file.$eoi

          ic_object_adr = catalog_address + ic_object_list_adr + ((ic_object - 1)* object_size)
          object_type = $pv(?ic_object_adr.pft$physical_object.object_entry.object_type)
          object_name = $pv(?ic_object_adr.pft$physical_object.object_entry.external_object_name)

          IF object_type = 'PFC$FREE_OBJECT' THEN
            put_line ' '//$strrep(ic_object_adr, 16)//' =  '//object_type o=hold_file.$eoi
          ELSEIF (object_type = 'PFC$FILE_OBJECT') OR (object_type = 'PFC$PURGED_FILE_OBJECT') THEN
            put_line ' '//$strrep(object_adr, 16)//' =  '//object_type o=hold_file.$eoi
          ELSE
            object_name = $pv(?ic_object_adr.pft$physical_object.object_entry.external_object_name)
            put_line ' INTERNAL CATALOG (MASTER CATALOG): '//object_name o=hold_file.$eoi

            display_program_value name=?ic_object_adr.pft$physical_object o=hold_file.$eoi

            permit_count = $pv(..
                  ?ic_object_adr.pft$physical_object.object_entry.permit_list_locator.permit_count)
            permit_list_adr = $pv(^?ic_object_adr.pft$physical_object.object_entry.permit_list_locator..
.relative_cell_pointer)
            permit_list_adr = $mem(permit_list_adr, 4)
            IF permit_count > 0 THEN
              put_line (' ', '    Permit list for catalog: '//object_name) o=hold_file.$eoi
              FOR permit = 1 TO permit_count DO
                permit_adr = catalog_address + permit_list_adr + ((permit - 1)* permit_size)
                display_program_value name=?permit_adr.pft$physical_permit o=hold_file.$eoi
                put_line '  ' o=hold_file.$eoi
              FOREND
            IFEND

            fmd_size = $pv(?ic_object_adr.pft$physical_object.object_entry.catalog_object_locator..
.fmd_locator.fmd_size)
            fmd_adr = $pv(^?ic_object_adr.pft$physical_object.object_entry.catalog_object_locator..
.fmd_locator.relative_cell_pointer)
            fmd_adr = catalog_address + $mem(fmd_adr, 4)
            IF fmd_size > 0 THEN
              put_line ' ' o=hold_file.$eoi
              display_physical_fmd fmd_adr o=hold_file.$eoi
            IFEND

          IFEND
        FOREND
      IFEND
    IFEND
  FOREND

  copy_file input=hold_file output=output
  close_file file=catalog_file
  change_default_module module=$name(current)

PROCEND dum$display_catalog_file
*DECK DECK=DUM$DISPLAY_CIO_REGS_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display CIO Registers Command' ??
MODULE dum$display_cio_regs_command;

{ PURPOSE:
{   This module contains the command which displays the CIO register information that
{   is contained in the CCR and CC1 dump records.
{        CCR - channel registers of the primary IOU element.
{        CC1 - channel registers of the secondary IOU element.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$find_record_list_entry
*copyc dup$new_page_procedure
*copyc dup$retrieve_register
*copyc osp$append_status_integer
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'convert_display_to_ascii', EJECT ??

{ PURPOSE:
{   This function converts a display character to an ascii character.

  FUNCTION convert_display_to_ascii (display_character: 0 .. 3f(16)): char;

    CONST
      c$a_display_code = 1,
      c$zero_display_code = 27,
      c$nine_display_code = 36,
      c$numeric_bias = 48,
      c$alphabetic_bias = 65;

    IF (display_character >= c$zero_display_code) AND (display_character <= c$nine_display_code) THEN
      convert_display_to_ascii := $CHAR (c$numeric_bias + (display_character - c$zero_display_code));
    ELSE
      convert_display_to_ascii := $CHAR (c$alphabetic_bias + (display_character - c$a_display_code));
    IFEND;

  FUNCEND convert_display_to_ascii;
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_cio_regs_command', EJECT ??

{ PURPOSE:
{   This procedure displays the cio registers.

  PROCEDURE [XDCL] dup$display_cio_regs_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_cio_registers, discr (
{   output, o: file = $optional
{   title, t: string 1..31 = 'display_cio_registers'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (23),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 4, 18, 8, 54, 14, 616],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TITLE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 23],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_cio_registers'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$title = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    TYPE
      t$ascii_char_data = RECORD
        CASE boolean OF
        = TRUE =
          data: string (2),
        = FALSE =
          char_1: char,
          char_2: char,
        CASEND,
      RECEND,

      t$channel_data = PACKED RECORD
        unused: 0 .. 0ff(16),
        data: 0 .. 0ff(16),
      RECEND,

      t$data_line = RECORD
        CASE boolean OF
        = TRUE =
          line: string (79),
        = FALSE =
          unused_1: string (1),
          iou_name: string (3),
          iou_number: string (2),
          unused_2: string (1),
          cio_name: string (3),
          channel_number: string (2),
          colon: string (1),
          unused_3: string (1),
          channel_type: string (16),
          unused_4: string (2),
          status_register: ARRAY [1 .. 4] OF t$register_string,
          unused_5: string (1),
          t_register: ARRAY [1 .. 3] OF t$register_string,
          unused_6: string (1),
          flag_mask: string (4),
          unused_7: string (3),
          test_mode_operand: string (2),
        CASEND,
      RECEND,

      t$display_code_data = PACKED RECORD
        unused: 0 .. 0f(16),
        char_1: 0 .. 77(8),
        char_2: 0 .. 77(8),
      RECEND,

      t$flag_mask = RECORD
        CASE boolean OF
        = TRUE =
          data: 0 .. 0ffff(16),
        = FALSE =
          list: ARRAY [1 .. 2] OF 0 .. 0ff(16),
        CASEND,
      RECEND,

      t$register_entry = PACKED RECORD
        channel_number: t$display_code_data,
        channel_type: t$display_code_data,
        t_register: PACKED ARRAY [0 .. 5] OF t$channel_data,
        flag_mask: PACKED ARRAY [1 .. 2] OF t$channel_data,
        test_mode_operand: t$channel_data,
      RECEND,

      t$register_list_entry = RECORD
        available: boolean,
        iou_number: 0 .. 1,
        channel_number: t$ascii_char_data,
        channel_type: t$ascii_char_data,
        status_register: t$status_register,
        t_register: t$t_register,
        flag_mask: t$flag_mask,
        test_mode_operand: 0 .. 0ff(16),
      RECEND,

      t$register_string = RECORD
        data: string (4),
        unused: string (1),
      RECEND,

      t$status_register = RECORD
        CASE boolean OF
        = TRUE =
          data: ARRAY [1 .. 4] OF 0 .. 0ffff(16),
        = FALSE =
          value: ARRAY [1 .. duc$de_max_register_length] OF 0 .. 0ff(16),
        CASEND,
      RECEND,

      t$t_register = RECORD
        CASE boolean OF
        = TRUE =
          data: ARRAY [1 .. 3] OF 0 .. 0ffff(16),
        = FALSE =
          list: ARRAY [0 .. 5] OF 0 .. 0ff(16),
        CASEND,
      RECEND,

      t$title_line = RECORD
        CASE boolean OF
        = TRUE =
          line: string (79),
        = FALSE =
          unused_1: string (34),
          status_register: string (15),
          unused_2: string (6),
          t_register: string (10),
          unused_3: string (4),
          flag_mask: string (4),
          unused_4: string (2),
          test_mode_operand: string (4),
        CASEND,
      RECEND;

    VAR
      cc1_entry_p: ^dut$de_other_record_entry,
      cell_p: ^cell,
      channels_still_exist: boolean,
      checked_cc1: boolean,
      data_line: t$data_line,
      data_size: integer,
      data_value: clt$data_value,
      display_control: clt$display_control,
      entry_p: ^dut$de_other_record_entry,
      ignore_status: ost$status,
      index: 1 .. duc$de_maximum_channels,
      index_2: 0 .. 5,
      iou_number: 0 .. duc$de_maximum_ious,
      output_display_opened: boolean,
      register: dut$de_maintenance_register,
      register_entry_p: ^t$register_entry,
      register_list: ARRAY [1 .. duc$de_maximum_channels] OF t$register_list_entry,
      register_number: 0 .. duc$de_max_register_number,
      restart_file_seq_p: ^SEQ ( * ),
      ring_attributes: amt$ring_attributes,
      title_line: t$title_line;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

    { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      data_value.kind := clc$name;
      data_value.name_value := 'CCR';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The specified record is',
              status);
        EXIT /display_opened/;  {---->
      IFEND;

      FOR index := 1 TO duc$de_maximum_channels DO
        register_list [index].available := FALSE;
      FOREND;

      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);
      RESET restart_file_seq_p TO cell_p;
      data_size := entry_p^.size;
      channels_still_exist := (data_size >= #SIZE (t$register_entry));
      checked_cc1 := FALSE;
      iou_number := 0;
      index := 1;

      WHILE channels_still_exist DO
        NEXT register_entry_p IN restart_file_seq_p;
        IF register_entry_p = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
          EXIT /display_opened/;  {---->
        IFEND;
        data_size := data_size - #SIZE (t$register_entry);
        register_list [index].available := TRUE;
        register_list [index].iou_number := iou_number;
        register_list [index].channel_number.char_1 :=
              convert_display_to_ascii (register_entry_p^.channel_number.char_1);
        register_list [index].channel_number.char_2 :=
              convert_display_to_ascii (register_entry_p^.channel_number.char_2);
        register_list [index].channel_type.char_1 :=
              convert_display_to_ascii (register_entry_p^.channel_type.char_1);
        register_list [index].channel_type.char_2 :=
              convert_display_to_ascii (register_entry_p^.channel_type.char_2);
        FOR index_2 := 0 TO 5 DO
          register_list [index].t_register.list [index_2] := register_entry_p^.t_register [index_2].data;
        FOREND;
        FOR index_2 := 1 TO 2 DO
          register_list [index].flag_mask.list [index_2] := register_entry_p^.flag_mask [index_2].data;
        FOREND;
        register_list [index].test_mode_operand := register_entry_p^.test_mode_operand.data;
        index := index + 1;
        IF data_size < #SIZE (t$register_entry) THEN
          IF checked_cc1 THEN
            channels_still_exist := FALSE;
          ELSE
            checked_cc1 := TRUE;
            data_value.kind := clc$name;
            data_value.name_value := 'CC1';
            dup$find_record_list_entry (data_value, cc1_entry_p);
            IF cc1_entry_p = NIL THEN
              channels_still_exist := FALSE;
            ELSE
              restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
              cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),
                    cc1_entry_p^.first_byte);
              RESET restart_file_seq_p TO cell_p;
              data_size := cc1_entry_p^.size;
              channels_still_exist := (data_size >= #SIZE (t$register_entry));
              iou_number := 1;
            IFEND;
          IFEND;
        IFEND;
      WHILEND;

     /register_loop/
      FOR index := 1 TO duc$de_maximum_channels DO
        IF NOT register_list [index].available THEN
          EXIT /register_loop/;  {---->
        IFEND;
        register_number := ((($INTEGER (register_list [index].channel_number.char_1) - 30(16)) * 10(8)) +
              ($INTEGER (register_list [index].channel_number.char_2) - 30(16))) + 0b0(16);
        iou_number := register_list [index].iou_number;

        dup$retrieve_register (duc$de_iou, iou_number, register_number, register);
        register_list [index].status_register.value := register.value;
      FOREND /register_loop/;

      clp$put_display (display_control, 'CIO Channel Registers', clc$trim, ignore_status);
      clp$put_display (display_control, ' ', clc$trim, ignore_status);

      title_line.line := ' ';
      title_line.flag_mask := 'FLAG';
      title_line.test_mode_operand := 'TEST';
      clp$put_display (display_control, title_line.line, clc$trim, ignore_status);

      title_line.line := ' ';
      title_line.status_register := 'STATUS REGISTER';
      title_line.t_register := 'T REGISTER';
      title_line.flag_mask := 'MASK';
      title_line.test_mode_operand := 'MODE';
      clp$put_display (display_control, title_line.line, clc$trim, ignore_status);

      title_line.line := ' ';
      title_line.status_register := '---------------';
      title_line.t_register := '----------';
      title_line.flag_mask := '----';
      title_line.test_mode_operand := '----';
      clp$put_display (display_control, title_line.line, clc$trim, ignore_status);

      FOR index := 1 TO duc$de_maximum_channels DO
        IF NOT register_list [index].available THEN
          EXIT /display_opened/;  {---->
        IFEND;

        data_line.line := ' ';
        data_line.iou_name := 'IOU';
        clp$convert_integer_to_rjstring (register_list [index].iou_number, 8, FALSE, '0',
              data_line.iou_number, ignore_status);
        data_line.cio_name := 'CCH';
        data_line.channel_number := register_list [index].channel_number.data;
        data_line.colon := ':';

        IF register_list [index].channel_type.data = '01' THEN
          data_line.channel_type := '170 Channel';
        ELSEIF register_list [index].channel_type.data = '02' THEN
          data_line.channel_type := 'ISI Channel';
        ELSEIF register_list [index].channel_type.data = '03' THEN
          data_line.channel_type := 'ISI DMA Channel';
        ELSEIF register_list [index].channel_type.data = '04' THEN
          data_line.channel_type := 'Internal Channel';
        ELSEIF register_list [index].channel_type.data = '05' THEN
          data_line.channel_type := '170 DMA ESM';
        ELSEIF register_list [index].channel_type.data = '06' THEN
          data_line.channel_type := '25MB IPI DMA';
        ELSEIF register_list [index].channel_type.data = '07' THEN
          data_line.channel_type := 'IPI DMA Channel';
        ELSEIF register_list [index].channel_type.data = '10' THEN
          data_line.channel_type := 'PP Comm Channel';
        ELSEIF register_list [index].channel_type.data = '11' THEN
          data_line.channel_type := 'SCSI Interface';
        ELSEIF register_list [index].channel_type.data = '17' THEN
          data_line.channel_type := 'Not Installed';
        ELSE
          data_line.channel_type := 'Unknown';
        IFEND;

        FOR index_2 := 1 TO 4 DO
          clp$convert_integer_to_rjstring (register_list [index].status_register.data [index_2], 16, FALSE,
                '0', data_line.status_register [index_2].data, ignore_status);
        FOREND;

        FOR index_2 := 1 TO 3 DO
          clp$convert_integer_to_rjstring (register_list [index].t_register.data [index_2], 16, FALSE,
                '0', data_line.t_register [index_2].data, ignore_status);
        FOREND;

        clp$convert_integer_to_rjstring (register_list [index].flag_mask.data, 16, FALSE,
              '0', data_line.flag_mask, ignore_status);

        clp$convert_integer_to_rjstring (register_list [index].test_mode_operand, 16, FALSE,
              '0', data_line.test_mode_operand, ignore_status);

        clp$put_display (display_control, data_line.line, clc$trim, ignore_status);
      FOREND;

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_cio_regs_command;
MODEND dum$display_cio_regs_command;
*DECK DECK=DUM$DISPLAY_CLIENT_ACCESS EXPAND=TRUE
PROCEDURE dum$display_client_access, disca (
  output, o: file = $output
  status)

  "  This procedure displays client_access from the set family table.
  "  This procedure requires RJTs most recent dump anlyzer.
  "  This procedure assumes that osm$family_manager has been added.

  current = $default_module
  crev local_status status
  set_file_attributes output fc=legible pf=continuous
  chadm osm$family_manager
  IF $file(output open_position) = '$BOI' THEN
    rewind_file output status=local_status
  IFEND
  out = output.$eoi

search: ..
  FOR pntr = $pv(LOWERBOUND(osv$family_table^)) TO ..
       $pv(UPPERBOUND(osv$family_table^)) DO
    IF $pv(osv$family_table^[?pntr].family_name) = '   ' THEN
      CYCLE search
    IFEND
    putl ' ------  Family index '//pntr o=out
    dispv osv$family_table^[?pntr] o=out

    next_p = $pv(osv$family_table^[?pntr].p_client_access_list)
    WHILE NOT $nil_pva(next_p) DO
      dispv ?next_p.dft$family_table_client_entry o=out
      next_p = $pv(?next_p.dft$family_table_client_entry.p_next_client)
    WHILEND
  FOREND search

  chadm current

PROCEND dum$display_client_access
*DECK DECK=DUM$DISPLAY_CLIENT_MAINFRAME_FI EXPAND=TRUE
PROCEDURE dum$display_client_mainframe_fi , display_client_mainframe_file discmf (
  address, a: integer 0 .. $max_integer = $mem($sa(dfv$p_client_mainframe_file))
  display_option, do: key
     (job_names, jn)
     (job_space, js)
     (attached_files, af)
     (queued_catalogs, qc)
      all
    keyend =  all
  display_deleted_jobs, ddj: boolean = false
  output, o: file = $output
  status)

 " This PROCEDURE displays the file server client mainframe file.
 "  This procedure  assumes you
 " are using RJTs analyze_system, and that dfm$client_mainframe_manager has
 " been added as a debug table.  All pointers maintained in the file are
 " converted to the base segment of the parent address.

  set_file_attributes output fc=legible pf=continuous
  out = output.$eoi

  current = $default_module
  crev status  status
  chadm dfm$client_mainframe_manager status=status
  dispv ?address.dft$client_mainframe_file o=out
  number_of_active_pointers = $pv(?address.dft$client_mainframe_file..
.mainframe_header.client_job_list_root.number_of_active_pointers)
  IF number_of_active_pointers > 0 THEN
    " There are jobs using the server
    p_job_list_pointer_array =  $pv(?address.dft$client_mainframe_file..
.mainframe_header.client_job_list_root.p_job_list_pointer_array)
    " Convert to the right segment
    p_job_list_pointer_array = $ring(address)*100000000000(16) + ..
       $segment(address)*100000000(16) + $offset(p_job_list_pointer_array)
   next_pointer_entry = p_job_list_pointer_array
    FOR pointer = 1 to  number_of_active_pointers do
      disv ' ---POINTER  ------- '//$strrep(Pointer) o=out
      dispv ?next_pointer_entry.dft$client_job_list_pointer ..
          o=out
      p_client_job_list = $pv(..
          ?next_pointer_entry.dft$client_job_list_pointer.p_client_job_list)
      p_client_job_list = $ring(address)*100000000000(16) + ..
         $segment(address)*100000000(16) + $offset(p_client_job_list)
      p_client_job_list_entry = p_client_job_list
      FOR client_job_entry = 1  TO 40 " UPPERVALUE(dft$client_job_list_index)" DO
        IF $pv(?next_pointer_entry.dft$client_job_list_pointer.assignment(?client_job_entry)) = 'A' OR ..
          display_deleted_jobs THEN
          disv ' ========= Client Job list id '//$strrep(pointer)//' '//$strrep(client_job_entry)  o=out
          dispv ?p_client_job_list_entry.dft$client_job_list_entry ..
             o=out
          p_client_job_space = $pv(?p_client_job_list_entry..
.dft$client_job_list_entry.p_client_job_space)
          IF NOT $NIL_PVA(p_client_job_space) THEN
            p_client_job_space = $ring(address)*100000000000(16) + ..
         $segment(address)*100000000(16) + $offset(p_client_job_space)
            IF (display_option = JOB_SPACE) OR (display_option = ALL) THEN
            dispv ?p_client_job_space.dft$client_job_space o=out ..
               status=status
             IFEND
            IF status.normal THEN
              " Display attached pf table
              IF (display_option = ATTACHED_FILES) OR (display_option = ALL) THEN
                 p_attached_pf_table = $pv(..
?p_client_job_space.dft$client_job_space.p_attached_pf_table)
                IF $nil_pva(p_attached_pf_table) THEN
                  disv ' No attached files '  o=out
                ELSE
                  p_attached_pf_table = $ring(address)*100000000000(16) + ..
                    $segment(address)*100000000(16) + $offset(p_attached_pf_table)
                  p_p_attached_pf_table = $pv(^..
?p_client_job_space.dft$client_job_space.p_attached_pf_table)
                  array_size = $mem(p_p_attached_pf_table+6, 4)
                  element_size = $mem(p_p_attached_pf_table+14, 4)
                  disv ' array_size '//$strrep(array_size)//' element_size '//$strrep(element_size) o=out
                  display_attached_pf_table p_attached_pf_table ..
                     array_size element_size o=out  status=status
                  IF NOT status.normal THEN
                    disv ' Unable to display attached pf table ' o=out
                    disv status o=out
                  IFEND
               IFEND
             IFEND

              " Display queued catalog table
             IF (display_option = QUEUED_CATALOGS) OR (display_option = ALL) THEN
                p_queued_catalog_table = $pv(..
?p_client_job_space.dft$client_job_space.p_queued_catalog_table)
                IF $nil_pva(p_queued_catalog_table) THEN
                  disv ' No queued catalogs '  o=out
                ELSE
                  p_queued_catalog_table= $ring(address)*100000000000(16) + ..
                    $segment(address)*100000000(16) + $offset(p_queued_catalog_table)
                  p_p_queued_catalog_table = $pv(^..
?p_client_job_space.dft$client_job_space.p_queued_catalog_table)
                  array_size = $mem(p_p_queued_catalog_table+6, 4)
                  element_size = $mem(p_p_queued_catalog_table+14, 4)
                  disv ' array_size '//$strrep(array_size)//' element_size '//$strrep(element_size) o=out
                  display_queued_catalog_table p_queued_catalog_table  ..
                   array_size element_size o=out status=status
                  IF NOT status.normal THEN
                    disv ' Unable to display queued_catalog_table'  o=out
                    disv status o=out
                  IFEND
                IFEND
              IFEND
            ELSE
              disv ' Unable to display user job area ' o=out
              disv status o=out
            IFEND
          IFEND
        IFEND
        p_client_job_list_entry = p_client_job_list_entry + 80
       "  $PV(#SIZE(0.dft$client_job_list_entry) rounded up to word
      FOREND
      next_pointer_entry = next_pointer_entry + ..
        $PV(#SIZE(0.dft$client_job_list_pointer))
    FOREND
  IFEND
  chadm current
PROCEND dum$display_client_mainframe_fi
*DECK DECK=DUM$DISPLAY_CONSOLE_SCREENS EXPAND=TRUE
PROCEDURE dum$display_console_screens, display_console_screens, discs (
  output, o: file = $output
  display_options, do:
    key
      full, f
      partial, p
    keyend = partial
  status)

  set_file_attributes f=output fc=legible pf=continuous
  output_file = output.$eoi

  window_p = $memory($symbol_address(dpv$top_window_p))
  WHILE NOT $nil_pva(window_p) DO

    " Display the window information.

    put_line l=  ' *******************************************************************************' o=output_file

    window_kind = $memory(window_p+14 1)
    present_window_line_number = $memory(window_p+39 1)

    IF (display_options = 'F') OR (display_options = 'FULL') THEN
      put_line l=' WINDOW ID = '//$strrep($memory(window_p+6 4)) o=output_file
      put_line l='        Starting console row number = '//$strrep($memory(window_p+10 1)) o=output_file
      put_line l='        Ending console row number = '//$strrep($memory(window_p+11 1)) o=output_file
      put_line l='        True window class = '//$strrep($memory(window_p+12 1)) o=output_file
      put_line l='        Actual window class = '//$strrep($memory(window_p+13 1)) o=output_file
      put_line l='        Window kind = '//$strrep(window_kind) o=output_file
      put_line l='        Table: starting line in window = '//$strrep($memory(window_p+15 8)) o=output_file
      put_line l='        Table: last line used in window = '//$strrep($memory(window_p+23 8)) o=output_file
      put_line l='        Table: next available line = '//$strrep($memory(window_p+31 8)) o=output_file
      put_line l='        Present window line number = '//$strrep(present_window_line_number) o=output_file
      put_line l=' -------------------------------------------------------------------------------' o=output_file
    IFEND

    " Display the title line of the window.

    line_p = window_p + 40
    line_size = $memory(line_p+2 1)
    IF line_size <> 0 THEN
      put_line l=' TITLE LINE:' o=output_file
      put_line l=' '//$trim($memory_string(line_p+8, line_size)) o=output_file
    ELSE
      put_line l=' TITLE LINE:' o=output_file
      put_line l=' ' o=output_file
    IFEND

    " Retrieve the input line of the window.

    line_p = line_p + 96
    input_line_exists = ($memory(window_p+14 1) = 2)
    IF input_line_exists THEN
      line_size = $memory(line_p+2 1)
      IF line_size <> 0 THEN
        input_line = ' '//$trim($memory_string(line_p+8, line_size))
      ELSE
        input_line = ' '
      IFEND
    IFEND

    " Display the lines of the window.

    line_p = line_p + 96
    IF window_kind = 1 THEN

      " Display the lines on a table.

      FOR line_index = 1 TO 30 DO
        IF $memory(line_p 2) <> 0 THEN
          line_size = $memory(line_p+2 1)
          IF line_size <> 0 THEN
            put_line l=' '//$trim($memory_string(line_p+8 line_size)) o=output_file
          IFEND
        IFEND
        line_p = line_p + 96
      FOREND

    ELSE
      save_line_p = line_p
      FOR line_index = 1 TO present_window_line_number DO
        line_p = line_p + 96
      FOREND

      FOR line_index = (present_window_line_number+1) TO 30 DO
        IF $memory(line_p 2) <> 0 THEN
          line_size = $memory(line_p+2 1)
          IF line_size <> 0 THEN
            put_line l=' '//$trim($memory_string(line_p+8 line_size)) o=output_file
          IFEND
        IFEND
        line_p = line_p + 96
      FOREND

      line_p = save_line_p
      FOR line_index = 1 TO present_window_line_number DO
        IF $memory(line_p 2) <> 0 THEN
          line_size = $memory(line_p+2 1)
          IF line_size <> 0 THEN
            put_line l=' '//$trim($memory_string(line_p+8 line_size)) o=output_file
          IFEND
        IFEND
        line_p = line_p + 96
      FOREND
    IFEND

    " Display the input line of the window.

    IF input_line_exists THEN
      put_line l=' INPUT LINE:' o=output_file
      put_line l=input_line o=output_file
    IFEND

    window_p = $memory(window_p 6)
  WHILEND

PROCEND dum$display_console_screens
*DECK DECK=DUM$DISPLAY_CONSOLE_WINDOWS EXPAND=TRUE
PROCEDURE dum$display_console_windows, display_console_windows, discw (
  output, o : file = $output
  status)

  " This procedure uses RJT's newest dump analyzer.
  " This assumes that dpm$system_console_monitor has been added.

  VAR
    local_status: status
  VAREND

  set_file_attributes f=output fc=legible pf=continuous
  IF $file(output open_position) = '$BOI' THEN
    rewind_file f=output status=local_status
  IFEND
  output_file = output.$eoi

  current_default_module = $default_module
  change_default_module m=dpm$system_console_monitor

  " Display the idle message which appears on the top line of the console.

  idle_message_line = $symbol_address(mtv$idle_message_line)
  IF $program_value(?idle_message_line.dpt$console_line.text_size) > 0 THEN
    display_value v=$program_value(?idle_message_line.dpt$console_line.text) o=output_file
  IFEND

  window_p = $program_value(dpv$top_window_p)

  WHILE NOT $nil_pva(window_p) DO
    display_value v=' ------------------------------------------------------------------------- ' o=output_file

    " Display the window's title line.

    display_value v=$program_value(?window_p.dpt$window.title.text) o=output_file

    IF $program_value(?window_p.dpt$window.kind) = DPC$WK_TABLE THEN

      " Display the lines for the TABLE window.

      FOR line_index = 1 to $program_value(UPPERBOUND(?window_p.dpt$window.lines)) DO
        IF ($program_value(?window_p.dpt$window.lines[?line_index].text_size) > 0) AND ..
              ($trim($program_value(?window_p.dpt$window.lines[?line_index].text)) <> '') THEN
          display_value v=$trim($program_value(?window_p.dpt$window.lines[?line_index].text)) o=output_file
        IFEND
      FOREND

    ELSE

      " Display the lines for the LOG or INTERACTIVE window.  Display the oldest lines first.

      most_recent = $program_value(?window_p.dpt$window.present_window_line_number)
      FOR line_index = (most_recent+1) TO $program_value(UPPERBOUND(?window_p.dpt$window.lines)) DO
        IF ($program_value(?window_p.dpt$window.lines[?line_index].text_size) > 0) AND ..
              ($trim($program_value(?window_p.dpt$window.lines[?line_index].text)) <> '') THEN
          display_value v=$trim($program_value(?window_p.dpt$window.lines[?line_index].text)) o=output_file
        IFEND
      FOREND

      FOR line_index = 1 to most_recent do
        IF ($program_value(?window_p.dpt$window.lines[?line_index].text_size) > 0) AND ..
              ($trim($program_value(?window_p.dpt$window.lines[?line_index].text)) <> '') THEN
          display_value v=$trim($program_value(?window_p.dpt$window.lines[?line_index].text)) o=output_file
        IFEND
      FOREND
    IFEND
    window_p = $program_value(?window_p.dpt$window.next_window_p)

  WHILEND

  change_default_module m=current_default_module

PROCEND dum$display_console_windows
*DECK DECK=DUM$DISPLAY_CONTROL_STORE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Control Store Command' ??
MODULE dum$display_control_store;

{ PURPOSE:
{   This module contains the code for the display_control_store command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_partial_display
*copyc dup$evaluate_parameters
*copyc dup$new_page_procedure
*copyc dup$retrieve_register
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_control_store', EJECT ??

{ PURPOSE:
{   This procedure displays the control store from the restart file.

  PROCEDURE [XDCL] dup$display_control_store
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_control_store, discs (
{   processor, p: integer 0..3 = 0
{   shadow, s: boolean = FALSE
{   output, o: file
{   title, t: string 1..31 = 'display_control_store'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (23),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 9, 18, 15, 19, 34, 45],
    clc$command, 9, 5, 0, 0, 0, 0, 5, ''], [
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['P                              ',clc$abbreviation_entry, 1],
    ['PROCESSOR                      ',clc$nominal_entry, 1],
    ['S                              ',clc$abbreviation_entry, 2],
    ['SHADOW                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['T                              ',clc$abbreviation_entry, 4],
    ['TITLE                          ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 23],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 3, 10],
    '0'],
{ PARAMETER 2
    [[1, 0, clc$boolean_type],
    'FALSE'],
{ PARAMETER 3
    [[1, 0, clc$file_type]],
{ PARAMETER 4
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_control_store'''],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$processor = 1,
      p$shadow = 2,
      p$output = 3,
      p$title = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    TYPE
      t$integer_or_string = RECORD
        CASE boolean OF
        = TRUE =
          integer_part: integer,
        = FALSE =
          string_part: string (8),
        CASEND,
      RECEND;

    VAR
      cell_p: ^cell,
      control_store_entry: dut$de_control_store_entry,
      default_list: ARRAY [1 .. 1] OF dut$default_change_list_entry,
      display_control: clt$display_control,
      ignore_status: ost$status,
      integer_or_string: t$integer_or_string,
      model_number: 0 .. 0ff(16),
      model_number_upper: 0 .. 0ff(16),
      output_display_opened: boolean,
      processor: 0 .. duc$de_maximum_processors,
      register: dut$de_maintenance_register,
      restart_file_buffer_p: ^ARRAY [0 .. * ] OF dut$de_control_store_word,
      restart_file_seq_p: ^SEQ ( * ),
      ring_attributes: amt$ring_attributes;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    { Change the default value for the PROCESSOR parameter.

    default_list [1].default_name := duc$dp_processor;
    default_list [1].number := p$processor;
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    processor := pvt [p$processor].value^.integer_value.value;
    IF pvt [p$shadow].value^.boolean_value.value THEN
      control_store_entry := duv$dump_environment_p^.control_store.shadow [processor];
    ELSE
      control_store_entry := duv$dump_environment_p^.control_store.main [processor];
    IFEND;

    IF NOT control_store_entry.available THEN
      IF pvt [p$shadow].value^.boolean_value.value THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,
              'The shadow control store for processor', status);
      ELSE
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,
              'The main control store for processor', status);
      IFEND;
      osp$append_status_integer (osc$status_parameter_delimiter, processor, 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

    { Prepare the output display file.

    IF pvt [p$output].specified THEN
      ring_attributes.r1 := #RING (^ring_attributes);
      ring_attributes.r2 := #RING (^ring_attributes);
      ring_attributes.r3 := #RING (^ring_attributes);
      clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
            ring_attributes, display_control, status);
      IF NOT status.normal THEN
        RETURN;  {---->
      IFEND;
      output_display_opened := TRUE;
    ELSE
      display_control := duv$execution_environment.output_file.display_control;
      display_control.line_number := display_control.page_length + 1;
    IFEND;

   /display_opened/
    BEGIN
      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      { Get model number from EID register to find where control store word is located (ref arh5234).

      model_number := 0;
      dup$retrieve_register (duc$de_cpu, processor, 10(16), register);
      IF register.available THEN
        model_number := register.value [duc$de_model_byte_number];
      IFEND;

      { Display the control store word.

      IF model_number = 0 THEN
        clp$put_partial_display (display_control, 'CONTROLWARE PART NUMBER/REVISION LEVEL IS UNKNOWN',
              clc$no_trim, amc$start, status);
        clp$new_display_line (display_control, 1, status);
        EXIT /display_opened/;  {---->
      IFEND;

      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),
            control_store_entry.first_byte);
      RESET restart_file_seq_p TO cell_p;

      NEXT restart_file_buffer_p: [0 .. control_store_entry.size - 1] IN restart_file_seq_p;
      IF restart_file_buffer_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /display_opened/;  {---->
      IFEND;

      model_number_upper := model_number DIV 10(16);
      CASE model_number_upper OF
      = 2 = {P2}
        integer_or_string.integer_part := restart_file_buffer_p^ [1].lower;
      = 3 = {P3}
        integer_or_string.integer_part := restart_file_buffer_p^ [0].lower;
      = 4 = {THETA}
        integer_or_string.integer_part := restart_file_buffer_p^ [4fc(16)].upper;
      ELSE
        integer_or_string.integer_part := restart_file_buffer_p^ [1].upper;
      CASEND;

      clp$put_partial_display (display_control, 'CONTROLWARE PART NUMBER/REVISION LEVEL = ', clc$no_trim,
            amc$start, status);
      clp$put_partial_display (display_control, integer_or_string.string_part, clc$no_trim, amc$continue,
            status);
      clp$new_display_line (display_control, 1, status);
    END /display_opened/;  { ---->

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_control_store;
MODEND dum$display_control_store;
*DECK DECK=DUM$DISPLAY_CREATE EXPAND=TRUE
PROCEDURE dum$display_create, display_create (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, sva, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable output_line k=string v=' '
  create_variable log_address v=$value(address)
  create_variable indent k=(string, 5) v='     '
  log_address = log_address + 1
  create_variable file_type k=string d=0..6
  file_type(0) = 'permanent'
  file_type(1) = 'device'
  file_type(2) = 'temp_named'
  file_type(3) = 'temp_unnamed'
  file_type(4) = 'catalog'
  file_type(5) = 'temp_global'
  file_type(6) = 'server'

  display_binary_unique_name log_address o=$value(output) cs=indent//'gfn=' am=$value(am)

  output_line = indent//'dfl='//$strrep($mem(log_address+11, 3, j, 0, $value(am)), 16)
  output_line = output_line//' dau/au='//$strrep($mem(log_address+14, 1, j, 0, $value(am)), 16)
  output_line = output_line//' '//file_type($mem(log_address+15, 1, j, 0, $value(am)))
  output_line = output_line//' mf_asignd='//$strrep($mem(log_address+16, 5, j, 0, $value(am)), 16)
  output_line = output_line//' fad_addr='//$strrep($mem(log_address+21, 6, j, 0, $value(am)), 16)
  putl output_line o=$fname(output_file)

PROCEND dum$display_create
*DECK DECK=DUM$DISPLAY_CSF_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Channel Status Flags Command' ??
MODULE dum$display_csf_command;

{ PURPOSE:
{   This module contains the command which displays the channel status flags that are contained
{   in the CSF and CS1 dump records.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$determine_dump_information
*copyc dup$find_record_list_entry
*copyc dup$new_page_procedure
*copyc osp$append_status_integer
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_csf_command', EJECT ??

{ PURPOSE:
{   This procedure displays the channel status flags.

  PROCEDURE [XDCL] dup$display_csf_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_channel_status_flags, discsf, display_channel_conditions, discc (
{   output, o: file = $optional
{   title, t: string 1..31 = 'display_channel_status_flags'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (30),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 4, 18, 8, 56, 28, 616],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TITLE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 30],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_channel_status_flags'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$title = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    CONST
      c$number_of_channels = (34(8) + 10) * 2;

    TYPE
      t$channel_status_entry = PACKED RECORD
        unused: 0 .. 7,
        parity_error_disabled: boolean,
        channel_active: boolean,
        channel_full: boolean,
        channel_flag: boolean,
        channel_error: boolean,
      RECEND,

      t$channel_type = (c$nio, c$cio),

      t$data_line = RECORD
        CASE boolean OF
        = TRUE =
          line: string (70),
        = FALSE =
          unused_1: string (1),
          iou_name: string (3),
          iou_number: string (2),
          unused_2: string (1),
          cio_id: string (1),
          channel_name: string (2),
          channel_number: string (2),
          unused_3: string (2),
          channel_active: string (8),
          unused_4: string (3),
          channel_full: string (5),
          unused_5: string (4),
          channel_flag: string (5),
          unused_6: string (4),
          channel_error: string (5),
          unused_7: string (6),
          parity_error_disabled: string (5),
        CASEND,
      RECEND,

      t$register_list_entry = RECORD
        available: boolean,
        iou_number: 0 .. duc$de_maximum_ious,
        channel_number: 0 .. duc$de_maximum_channels,
        channel_type: t$channel_type,
        parity_error_disabled: boolean,
        channel_active: boolean,
        channel_full: boolean,
        channel_flag: boolean,
        channel_error: boolean,
      RECEND,

      t$title_line = RECORD
        CASE boolean OF
        = TRUE =
          line: string (70),
        = FALSE =
          unused_1: string (14),
          channel_active: string (8),
          unused_2: string (2),
          channel_full: string (7),
          unused_3: string (2),
          channel_flag: string (7),
          unused_4: string (2),
          channel_error: string (7),
          unused_5: string (2),
          parity_error_disabled: string (12),
        CASEND,
      RECEND;

    VAR
      cs1_entry_p: ^dut$de_other_record_entry,
      cell_p: ^cell,
      channel_number: 0 .. duc$de_maximum_channels,
      channel_status_p: ^t$channel_status_entry,
      channel_type: t$channel_type,
      channels_still_exist: boolean,
      checked_cs1: boolean,
      data_line: t$data_line,
      data_size: integer,
      data_value: clt$data_value,
      display_control: clt$display_control,
      dump_information: dut$dump_information,
      entry_p: ^dut$de_other_record_entry,
      ignore_status: ost$status,
      index: 1 .. c$number_of_channels,
      iou_number: 0 .. duc$de_maximum_ious,
      output_display_opened: boolean,
      register_list: ARRAY [1 .. c$number_of_channels] OF t$register_list_entry,
      restart_file_seq_p: ^SEQ ( * ),
      ring_attributes: amt$ring_attributes,
      title_line: t$title_line;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

    { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      data_value.kind := clc$name;
      data_value.name_value := 'CSF';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The specified record is',
              status);
        EXIT /display_opened/;  {---->
      IFEND;

      FOR index := 1 TO c$number_of_channels DO
        register_list [index].available := FALSE;
      FOREND;

      dup$determine_dump_information (dump_information);

      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);
      RESET restart_file_seq_p TO cell_p;
      data_size := entry_p^.size;
      channels_still_exist := (data_size >= #SIZE (t$channel_status_entry));
      checked_cs1 := FALSE;
      iou_number := 0;
      channel_number := 0;
      channel_type := c$nio;
      index := 1;

      WHILE channels_still_exist DO
        NEXT channel_status_p IN restart_file_seq_p;
        IF channel_status_p = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
          EXIT /display_opened/;  {---->
        IFEND;
        data_size := data_size - #SIZE (t$channel_status_entry);
        register_list [index].available := TRUE;
        register_list [index].iou_number := iou_number;
        register_list [index].channel_number := channel_number;
        register_list [index].channel_type := channel_type;
        register_list [index].parity_error_disabled := channel_status_p^.parity_error_disabled;
        register_list [index].channel_active := channel_status_p^.channel_active;
        register_list [index].channel_full := channel_status_p^.channel_full;
        register_list [index].channel_flag := channel_status_p^.channel_flag;
        register_list [index].channel_error := channel_status_p^.channel_error;
        IF channel_number = 33(8) THEN
          IF (dump_information.iou [iou_number].model = duc$di_im_i4_43) OR
                (dump_information.iou [iou_number].model = duc$di_im_i4_44) OR
                (dump_information.iou [iou_number].model = duc$di_im_i4_46) THEN
            data_size := 0;
          ELSE
            channel_number := 0;
            channel_type := c$cio;
          IFEND;
        ELSEIF (channel_number = 11(8)) AND (channel_type = c$cio) THEN
          data_size := 0;
        ELSE
          channel_number := channel_number + 1;
        IFEND;
        index := index + 1;
        IF data_size < #SIZE (t$channel_status_entry) THEN
          IF checked_cs1 THEN
            channels_still_exist := FALSE;
          ELSE
            checked_cs1 := TRUE;
            data_value.kind := clc$name;
            data_value.name_value := 'CS1';
            dup$find_record_list_entry (data_value, cs1_entry_p);
            IF cs1_entry_p = NIL THEN
              channels_still_exist := FALSE;
            ELSE
              restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
              cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),
                    cs1_entry_p^.first_byte);
              RESET restart_file_seq_p TO cell_p;
              data_size := cs1_entry_p^.size;
              channels_still_exist := (data_size >= #SIZE (t$channel_status_entry));
              channel_number := 0;
              channel_type := c$nio;
              iou_number := 1;
            IFEND;
          IFEND;
        IFEND;
      WHILEND;

      clp$put_display (display_control, 'Channel Status Flags', clc$trim, ignore_status);
      clp$put_display (display_control, ' ', clc$trim, ignore_status);

      title_line.line := ' ';
      title_line.channel_active := 'CHANNEL';
      title_line.channel_full := 'CHANNEL';
      title_line.channel_flag := 'CHANNEL';
      title_line.channel_error := 'CHANNEL';
      title_line.parity_error_disabled := 'PARITY ERROR';
      clp$put_display (display_control, title_line.line, clc$trim, ignore_status);

      title_line.line := ' ';
      title_line.channel_active := 'ACTIVE';
      title_line.channel_full := 'FULL';
      title_line.channel_flag := 'FLAG';
      title_line.channel_error := 'ERROR';
      title_line.parity_error_disabled := 'DISABLED';
      clp$put_display (display_control, title_line.line, clc$trim, ignore_status);

      title_line.line := ' ';
      title_line.channel_active := '--------';
      title_line.channel_full := '-------';
      title_line.channel_flag := '-------';
      title_line.channel_error := '-------';
      title_line.parity_error_disabled := '------------';
      clp$put_display (display_control, title_line.line, clc$trim, ignore_status);

      FOR index := 1 TO c$number_of_channels DO
        IF NOT register_list [index].available THEN
          EXIT /display_opened/;  {---->
        IFEND;

        data_line.line := ' ';
        data_line.iou_name := 'IOU';
        clp$convert_integer_to_rjstring (register_list [index].iou_number, 8, FALSE, '0',
              data_line.iou_number, ignore_status);
        IF (register_list [index].channel_type = c$cio) OR
              (dump_information.iou[register_list [index].iou_number].model = duc$di_im_i4_43) OR
              (dump_information.iou[register_list [index].iou_number].model = duc$di_im_i4_44) OR
              (dump_information.iou[register_list [index].iou_number].model = duc$di_im_i4_46) THEN
          data_line.cio_id := 'C';
        IFEND;
        data_line.channel_name := 'CH';
        clp$convert_integer_to_rjstring (register_list [index].channel_number, 8, FALSE, '0',
              data_line.channel_number, ignore_status);

        IF register_list [index].channel_active THEN
          data_line.channel_active := ' ACTIVE ';
        ELSE
          data_line.channel_active := 'INACTIVE';
        IFEND;

        IF register_list [index].channel_full THEN
          data_line.channel_full := ' FULL';
        ELSE
          data_line.channel_full := 'EMPTY';
        IFEND;

        IF register_list [index].channel_flag THEN
          data_line.channel_flag := ' SET ';
        ELSE
          data_line.channel_flag := 'CLEAR';
        IFEND;

        IF register_list [index].channel_error THEN
          data_line.channel_error := ' SET ';
        ELSE
          data_line.channel_error := 'CLEAR';
        IFEND;

        IF (register_list [index].channel_type <> c$cio) AND
              (dump_information.iou [register_list [index].iou_number].model <> duc$di_im_i4_43) AND
              (dump_information.iou [register_list [index].iou_number].model <> duc$di_im_i4_44) AND
              (dump_information.iou [register_list [index].iou_number].model <> duc$di_im_i4_46) THEN
          IF register_list [index].parity_error_disabled THEN
            data_line.parity_error_disabled := ' SET ';
          ELSE
            data_line.parity_error_disabled := 'CLEAR';
          IFEND;
        IFEND;

        clp$put_display (display_control, data_line.line, clc$trim, ignore_status);
      FOREND;

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_csf_command;
MODEND dum$display_csf_command;
*DECK DECK=DUM$DISPLAY_CTI_LEVEL_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display CTI Level Command' ??
MODULE dum$display_cti_level_command;

{ PURPOSE:
{   This module contains the code for the display_cti_level command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$new_page_procedure
*copyc dup$retrieve_cip_program
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_cti_level_command', EJECT ??

{ PURPOSE:
{   This procedure displays the CTI level from EIC record.

  PROCEDURE [XDCL] dup$display_cti_level_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_cti_level, disctil (
{   output, o: file = $optional
{   title, t: string 1..31 = 'display_cti_level'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (19),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 4, 18, 8, 48, 54, 341],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TITLE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 19],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_cti_level'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$title = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    TYPE
      t$ascii_code = PACKED RECORD
        CASE boolean OF
        = TRUE =
          data_1: string (6),
          data_2: string (6),
        = FALSE =
          number: ARRAY [1 .. 12] OF 0 .. 0ff(16),
        CASEND,
      RECEND,

      t$display_code = PACKED RECORD
        unused: 0 .. 0f(16),
        char_1: 0 .. 077(8),
        char_2: 0 .. 077(8),
      RECEND;

    VAR
      ascii_code: t$ascii_code,
      char_index: 0 .. 0ff(16),
      cip_program_available: boolean,
      cip_program_cell_p: ^cell,
      display_code_p: ^t$display_code,
      display_code: ARRAY [1 .. 12] OF 0 .. 0ff(16),
      display_control: clt$display_control,
      display_string: string (osc$max_string_size),
      index: 0 .. 0ff(16),
      ignore_status: ost$status,
      level_address_size: integer,
      output_display_opened: boolean,
      restart_file_seq_p: ^SEQ ( * ),
      ring_attributes: amt$ring_attributes,
      skip_integer_p: ^integer,
      skip_p: ^SEQ ( * ),
      size_p: ^0 .. 0ffff(16),
      string_length: integer;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

      { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
      dup$retrieve_cip_program ('2AP ', cip_program_available, cip_program_cell_p);
      IF NOT cip_program_available THEN
        clp$put_display (display_control, ' ERROR - Cannot retrieve the 2AP CIP program.', clc$trim,
              ignore_status);
        EXIT /display_opened/;  {---->
      IFEND;
      RESET restart_file_seq_p TO cip_program_cell_p;
      NEXT skip_integer_p IN restart_file_seq_p;
      IF skip_integer_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /display_opened/;  {---->
      IFEND;
      NEXT size_p IN restart_file_seq_p;
      IF size_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /display_opened/;  {---->
      IFEND;
      level_address_size := (size_p^ * 2) + 8 - 12;
      RESET restart_file_seq_p TO cip_program_cell_p;
      NEXT skip_p: [[REP level_address_size OF cell]] IN restart_file_seq_p;
      IF skip_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /display_opened/;  {---->
      IFEND;

      char_index := 1;
      FOR index := 1 TO 6 DO
        NEXT display_code_p IN restart_file_seq_p;
        IF display_code_p = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
          EXIT /display_opened/;  {---->
        IFEND;
        display_code [char_index] := display_code_p^.char_1;
        char_index := char_index + 1;
        display_code [char_index] := display_code_p^.char_2;
        char_index := char_index + 1;
      FOREND;

      FOR index := 1 TO 12 DO
        IF (display_code [index] >= 1) AND (display_code [index] <= 26) THEN
          ascii_code.number [index] := display_code [index] + 64;
        ELSEIF (display_code [index] >= 27) AND (display_code [index] <= 36) THEN
          ascii_code.number [index] := display_code [index] + 21;
        ELSE
          ascii_code.number [index] := 32;
        IFEND;
      FOREND;

      clp$put_display (display_control, '  CTI/CIP Levels in Central Memory:', clc$trim, ignore_status);
      STRINGREP (display_string, string_length, '    CTI Internal Level = ', ascii_code.data_1);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
      STRINGREP (display_string, string_length, '    CIP Release  Level = ', ascii_code.data_2);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_cti_level_command;
MODEND dum$display_cti_level_command;
*DECK DECK=DUM$DISPLAY_DAT_HEADER EXPAND=TRUE
PROCEDURE dum$display_dat_header, display_dat_header, disdh (
  address, a: integer = $optional
  display_option, do: key full, f, brief, b, keyend = brief
  access_mode, am: key sva, pva, keyend = sva
  output, o: file = $output
  help, h: file = $null
  status)

  WHEN any_fault DO
    putl ' entered disdh condition handler - enter commands or exit_proc to abort'
    disv osv$status
    incf command
  WHENEND

  IF $specified(help) THEN
COLLECT_TEXT o=$value(help) until='HELPEND'
DISPLAY_DAT_HEADER or DISDH

  This procedure will display the device allocation table header and describe
the contents of selected fields of the table.  This procedure assumes the user
has previously selected the correct exchange package by available analyze_dump
commands.

PARAMETERS:

ADDRESS, A: integer
  This parameter is the address of the data to be displayed as the device
allocation table header.  See the parameter access_mode for further details on
acceptable integer values for input.  This parameter is required.

DISPLAY_OPTIONS, DO: key full, f, brief, b
  This parameter selects the option of displaying the contents of memory
and the description of the selected fields (full), or the brief
mode of the descriptions only.  This parameter defaults to brief.

ACCESS_MODE, AM: key sva, pva
  This parameter selects the mode in which memory is accessed by the add-
ress parameter.  A processor virtual address or system virtual address
may be entered.  This parameter defaults to sva.

OUTPUT, O: file
  This parameter selects the file name to receive the data.  This para-
meter is defaulted to $output.  If a file name other than $output is
entered the data will be formated correctly for printer disposition and
will be sent to the file  "$asis".

STATUS

WARNINGS/KNOWN DEFICIENCIES:

ERROR HANDLER
  When any fatal error is encountered a condition handler is invoked and
the following message will appear:
"entered disdh condition handler - enter commands or exit_proc to abort".
This will be followed by the error status.  To exit the handler enter:
 "exit_proc".

HELPEND
    EXIT_PROC
  IFEND

  IF NOT $specified(address) THEN
    EXIT_PROC WITH $status(false, 'US', 3, 'Parameter ADDRESS is required')
  IFEND

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable name=column_2_num kind=integer value=39
  create_variable name=column_3_num kind=integer value=50
  create_variable name=column_4_num kind=integer value=59
  create_variable name=line_first_part kind=string
  create_variable name=line_secnd_part kind=string
  create_variable name=blank_fill_count kind=integer
  create_variable name=blank_line kind=string value='                                                    '
  crev output_line k=string v=' '
  dat_start = $value(address)

  IF $strrep($value(output)) = '$OUTPUT' THEN
    put_line '1DAT HEADER   ADDRESS = '//$strrep($value(address), 16)//' (16)' o=$fname(output_file)
  IFEND

  IF (display_option = 'FULL') THEN
    dism dat_start b=828(16) am=$value(access_mode) t='DAT HEADER '//$strrep($value(address), 16)//'(16)' ..
          o=$fname(output_file)
  IFEND

  putl '  ' o=$fname(output_file)
  locked = $mem(dat_start+16, 8, j, 0, $value(access_mode))
  IF locked <> 0 THEN
    putl ' dat is locked by task '//$strrep(locked) o=$fname(output_file)
  ELSE
    putl ' dat is NOT locked' o=$fname(output_file)
  IFEND

  bytes_per_dau = $mem(dat_start+24, 2, j, 0, $value(access_mode))
  output_line = ' bytes/dau = '//$strrep(bytes_per_dau, 16)//'(16)'
  bytes_per_mau = $mem(dat_start+26, 2, j, 0, $value(access_mode))
  output_line = output_line//'      bytes/mau = '//$strrep(bytes_per_mau, 16)//'(16)'
  putl output_line o=$fname(output_file)
  output_line = ' '

  daus_per_cyl = $mem(dat_start+28, 1, j, 0, $value(access_mode))
  maus_per_dau = $mem(dat_start+29, 1, j, 0, $value(access_mode))
  output_line = ' daus/cylinder = '//$strrep(daus_per_cyl, 16)//'(16)'
  output_line = output_line//'    maus/dau = '//$strrep(maus_per_dau)
  putl output_line o=$fname(output_file)
  output_line = ' '

  cyl_per_dev = $mem(dat_start+30, 2, j, 0, $value(access_mode))
  num_entries = $mem(dat_start+32, 3, j, 0, $value(access_mode))
  output_line = ' daus_per_device = '//$strrep(num_entries)
  output_line = output_line//'    cylinders/device = '//$strrep(cyl_per_dev)
  putl output_line o=$fname(output_file)
  output_line = ' '
  putl output_line o=$fname(output_file)

  putl ' DAUS PER ALLOCATION STYLE:' o=$fname(output_file)
  a0 = $mem(dat_start+48, 1, j, 0, $value(access_mode))
  a1 = $mem(dat_start+49, 1, j, 0, $value(access_mode))
  a2 = $mem(dat_start+50, 1, j, 0, $value(access_mode))
  a3 = $mem(dat_start+51, 1, j, 0, $value(access_mode))
  a4 = $mem(dat_start+52, 1, j, 0, $value(access_mode))
  a5 = $mem(dat_start+53, 1, j, 0, $value(access_mode))
  a6 = $mem(dat_start+54, 1, j, 0, $value(access_mode))
  a7 = $mem(dat_start+55, 1, j, 0, $value(access_mode))
  a8 = $mem(dat_start+56, 1, j, 0, $value(access_mode))
  acyl = $mem(dat_start+57, 1, j, 0, $value(access_mode))
  output_line = '      a0 = '//$strrep(a0)//'  a1 = '//$strrep(a1)//'  a2 = '//$strrep(a2)
  output_line = output_line//'  a3 = '//$strrep(a3)//'  a4 = '//$strrep(a4)
  putl output_line o=$fname(output_file)
  output_line = ' '
  output_line = '      a5 = '//$strrep(a5)//'  a6 = '//$strrep(a6)//'  a7 = '//$strrep(a7)
  output_line = output_line//'  a8 = '//$strrep(a8)//'  acyl = '//$strrep(acyl)
  putl output_line o=$fname(output_file)
  output_line = ' '
  putl output_line o=$fname(output_file)

  putl ' POOL INFO:            allocated   available      off      warn     ' o=$fname(output_file)
  perm_alloc = $mem(dat_start+60, 3, j, 0, $value(access_mode))
  perm_avail = $mem(dat_start+63, 3, j, 0, $value(access_mode))
  devi_alloc = $mem(dat_start+66, 3, j, 0, $value(access_mode))
  devi_avail = $mem(dat_start+69, 3, j, 0, $value(access_mode))
  cata_alloc = $mem(dat_start+72, 3, j, 0, $value(access_mode))
  cata_avail = $mem(dat_start+75, 3, j, 0, $value(access_mode))
  temp_alloc = $mem(dat_start+78, 3, j, 0, $value(access_mode))
  temp_avail = $mem(dat_start+81, 3, j, 0, $value(access_mode))
  gene_alloc = $mem(dat_start+84, 3, j, 0, $value(access_mode))
  gene_avail = $mem(dat_start+87, 3, j, 0, $value(access_mode))
  perm_off = $mem(dat_start+96, 3, j, 0, $value(access_mode))
  perm_wrn = $mem(dat_start+99, 3, j, 0, $value(access_mode))
  devi_off = $mem(dat_start+102, 3, j, 0, $value(access_mode))
  devi_wrn = $mem(dat_start+105, 3, j, 0, $value(access_mode))
  cata_off = $mem(dat_start+108, 3, j, 0, $value(access_mode))
  cata_wrn = $mem(dat_start+111, 3, j, 0, $value(access_mode))
  temp_off = $mem(dat_start+114, 3, j, 0, $value(access_mode))
  temp_wrn = $mem(dat_start+117, 3, j, 0, $value(access_mode))
  gene_off = $mem(dat_start+120, 3, j, 0, $value(access_mode))
  gene_wrn = $mem(dat_start+123, 3, j, 0, $value(access_mode))
  line_first_part = '    permanent            '//$strrep(perm_alloc)
  line_secnd_part = $strrep(perm_avail)
  blank_fill_count = (column_2_num)-($strlen(line_first_part))
  line_first_part = line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part
  line_secnd_part = $strrep(perm_off)
  blank_fill_count = (column_3_num)-($strlen(line_first_part))
  line_first_part = line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part
  line_secnd_part = $strrep(perm_wrn)
  blank_fill_count = (column_4_num)-($strlen(line_first_part))
  line_first_part = line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part
  putl line_first_part o=$fname(output_file)

  line_first_part = '    device               '//$strrep(devi_alloc)
  line_secnd_part = $strrep(devi_avail)
  blank_fill_count = (column_2_num)-($strlen(line_first_part))
  line_first_part = line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part
  line_secnd_part = $strrep(devi_off)
  blank_fill_count = (column_3_num)-($strlen(line_first_part))
  line_first_part = line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part
  line_secnd_part = $strrep(devi_wrn)
  blank_fill_count = (column_4_num)-($strlen(line_first_part))
  line_first_part = line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part
  putl line_first_part o=$fname(output_file)

  line_first_part = '    catalog              '//$strrep(cata_alloc)
  line_secnd_part = $strrep(cata_avail)
  blank_fill_count = (column_2_num)-($strlen(line_first_part))
  line_first_part = line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part
  line_secnd_part = $strrep(cata_off)
  blank_fill_count = (column_3_num)-($strlen(line_first_part))
  line_first_part = line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part
  line_secnd_part = $strrep(cata_wrn)
  blank_fill_count = (column_4_num)-($strlen(line_first_part))
  line_first_part = line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part
  putl line_first_part o=$fname(output_file)

  line_first_part = '    temp                 '//$strrep(temp_alloc)
  line_secnd_part = $strrep(temp_avail)
  blank_fill_count = (column_2_num)-($strlen(line_first_part))
  line_first_part = line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part
  line_secnd_part = $strrep(temp_off)
  blank_fill_count = (column_3_num)-($strlen(line_first_part))
  line_first_part = line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part
  line_secnd_part = $strrep(temp_wrn)
  blank_fill_count = (column_4_num)-($strlen(line_first_part))
  line_first_part = line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part
  putl line_first_part o=$fname(output_file)

  line_first_part = '    general              '//$strrep(gene_alloc)
  line_secnd_part = $strrep(gene_avail)
  blank_fill_count = (column_2_num)-($strlen(line_first_part))
  line_first_part = line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part
  line_secnd_part = $strrep(gene_off)
  blank_fill_count = (column_3_num)-($strlen(line_first_part))
  line_first_part = line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part
  line_secnd_part = $strrep(gene_wrn)
  blank_fill_count = (column_4_num)-($strlen(line_first_part))
  line_first_part = line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part
  putl line_first_part o=$fname(output_file)

PROCEND dum$display_dat_header
*DECK DECK=DUM$DISPLAY_DEADSTART_PHASE EXPAND=TRUE
PROCEDURE dum$display_deadstart_phase, display_deadstart_phase, disdp (
  output, o: file = $output
  status)

  crev osv$ string d=0..2
  osv$(0) = 'INSTALLATION'
  osv$(1) = 'RECOVERY'
  osv$(2) = 'NORMAL'

  os_phase = $mem($sa(osv$deadstart_phase), 1)

  crev s status
  unique = $unique
  temp = '$local.'//unique//'.$eoi'
  tempboi = '$local.'//unique//'.$boi'
  detach_file $fname(temp) status=s

  putl '  osv$deadstart_phase = '//osv$(os_phase) o=$fname(temp)

  copy_file $fname(tempboi) $value(output)

  detach_file $fname(temp) status=s

PROCEND dum$display_deadstart_phase
*DECK DECK=DUM$DISPLAY_DEALLOCATE_FRAGMENT EXPAND=TRUE
PROCEDURE dum$display_deallocate_fragment, display_deallocate_fragment (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, sva, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable output_line k=string v=' '
  create_variable log_address v=$value(address)
  create_variable indent k=(string, 5) v='     '

  log_address = log_address + 1
  display_binary_unique_name log_address o=$fname(output_file) cs=indent//'gfn=' am=$value(am)
  output_line = indent//'dfl='//$strrep($mem(log_address+11, 3, j, 0, $value(am)), 16)
  output_line = output_line//' dau_adrs='//$strrep($mem(log_address+14, 3, j, 0, $value(am)), 16)
  putl output_line o=$fname(output_file)

PROCEND dum$display_deallocate_fragment
*DECK DECK=DUM$DISPLAY_DEBUG_TABLE_ENTRY EXPAND=TRUE


 PROC dum$display_debug_table_entry, display_debug_table_entry, disdte (
   entry, e: LIST OF any = $OPTIONAL
   help: boolean = FALSE
   status)
   IF $specified(help) THEN
     IF $value(help) THEN
       putl '0  DISPLAY_DEBUG_TABLE_ENTRY  (DISDTE) ' o=$output
       putl '     entry, e: LIST OF any = $REQUIRED' o=$output
       putl '     help: boolean = FALSE' o=$output
       putl '     status)' o=$output
       putl '0    This procedure uses a list of process_virtual_addresses (PVAs)' o=$output
       putl '     and/or operating_system symbols.  If the entry in the list is' o=$output
       putl '     a PVA it will return the module, section, and offset into the' o=$output
       putl '     section.  If the entry in the list is an operating_system symbol' o=$output
       putl '     the procedure will return the address of the symbol.' o=$output
       putl ' ' o=$output
       EXIT_PROC
     IFEND
   IFEND
   IF $specified(entry) THEN
     WHEN program_fault DO
       put_line '  -- ERROR -- '//$string($value(entry,i))//' was not found.' o=$output
       CONTINUE
     WHENEND
     FOR i = 1 TO $set_count(entry) DO
       IF $value_kind(entry, i) = 'INTEGER' THEN
       " Display the symbol and offset in the code for this address."
         line = ' Address: '//$strrep($value(entry, i),16)//'(16) ==> '//$section($value(entry, i))//' in Module '//$trim($module($value(entry, i)))//'.'
         disv line o=$output
       ELSEIF $value_kind(entry, i) = 'NAME' THEN
       " Display the address of this symbol, if possible."
         put_line '  Symbol: '//$string($value(entry, i))//' is located at PVA address: '//$strrep($sa($value(entry, i)),16)//'(16).' o=$output
       ELSE
       " This is an illegal value_kind.  Display this fact."
         IF ($value_kind(entry, i) = 'FILE') OR ($value_kind(entry, i) = 'BOOLEAN') THEN
           disv '-- ERROR -- Expecting NAME or INTEGER; found '//$string($value(entry, i))//' for parameter ENTRY.' o=$output
         ELSEIF $value_kind(entry, i) = 'STRING' THEN
           disv '-- ERROR -- Expecting NAME or INTEGER; found string '''//$value(entry, i)//''' for parameter ENTRY.' o=$output
         ELSEIF $value_kind(entry, i) = 'STATUS' THEN
           disv '-- ERROR -- Expecting NAME or INTEGER; found '//$string($value(entry, i))//' for parameter ENTRY.' o=$output
           disv '-- ERROR -- Expecting NAME or INTEGER; found STATUS for parameter ENTRY.' o=$output
         ELSEIF $value_kind(entry, i) = 'UNKNOWN' THEN
           disv '-- ERROR -- Expecting NAME or INTEGER; found UNKNOWN for parameter ENTRY.' o=$output
         IFEND
       IFEND
     FOREND
   IFEND
 PROCEND dum$display_debug_table_entry
*DECK DECK=DUM$DISPLAY_DEFAULTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Defaults Command' ??
MODULE dum$display_defaults;

{ PURPOSE:
{   This module contains the code for the display_defaults command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$is_cpu1_installed
*copyc dup$new_page_procedure
*copyc osp$append_status_integer
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$default_parameters
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    t$default_parameter_names = ARRAY [dut$default_parameters] OF string (12);

  VAR
    v$default_parameter_names: t$default_parameter_names := ['address_mode', 'exchange', 'iou', 'pp_type',
          'processor'];

?? OLDTITLE ??
?? NEWTITLE := 'dup$display_defaults', EJECT ??

{ PURPOSE:
{   This procedure displays the current internal default values.

  PROCEDURE [XDCL] dup$display_defaults
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_defaults, disd (
{   output, o: file = $optional
{   title, t: string 1..31 = 'display_defaults'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (18),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 6, 12, 12, 35, 38, 154],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TITLE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 18],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_defaults'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$title = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    TYPE
      t$cpu_line = RECORD
        CASE boolean OF
        = TRUE =
          line: string (31),
        = FALSE =
          unused_1: string (3),
          processor_string: string (9),
          unused_2: string (1),
          number: string (1),
          colon: string (1),
          unused_3: string (2),
          not_available: string (13),
        CASEND,
      RECEND,

      t$data_line = RECORD
        CASE boolean OF
        = TRUE =
          line: string (54),
        = FALSE =
          unused_1: string (5),
          default_name: string (26),
          unused_2: string (1),
          equal: string (1),
          unused_3: string (1),
          value: string (20),
        CASEND,
      RECEND,

      t$parameter_line = RECORD
        CASE boolean OF
        = TRUE =
          line: string (50),
        = FALSE =
          unused_1: string (3),
          parameter: string (12),
          unused_2: string (1),
          equal: string (1),
          unused_3: string (1),
          value: string (31),
        CASEND,
      RECEND;

    VAR
      cpu_line: t$cpu_line,
      data_line: t$data_line,
      display_control: clt$display_control,
      ignore_status: ost$status,
      index: dut$default_parameters,
      integer_string: ost$string,
      output_display_opened: boolean,
      parameter_line: t$parameter_line,
      processor_index: 0 .. duc$de_maximum_processors,
      psm: dut$ee_psm_value,
      pta: dut$ee_pta_value,
      ptl: dut$ee_ptl_value,
      ring_attributes: amt$ring_attributes;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

      { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      { Add to the main title.

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;
      clp$put_display (display_control, ' ', clc$trim, ignore_status);

      { Display the default values for the subcommand parameters.

      clp$put_display (display_control, ' Subcommand parameter default values:', clc$trim,
            ignore_status);

      parameter_line.line := ' ';
      parameter_line.equal := '=';

      FOR index := LOWERBOUND (duv$default_parameters) TO UPPERBOUND (duv$default_parameters) DO
        parameter_line.parameter := v$default_parameter_names [index];
        IF duv$default_parameters [index].default_set THEN
          parameter_line.value := duv$default_parameters [index].value;
        ELSE
          parameter_line.value := 'no default set';
        IFEND;
        clp$put_display (display_control, parameter_line.line, clc$trim, ignore_status);
      FOREND;
      clp$put_display (display_control, ' ', clc$trim, ignore_status);

      { Display the default values for the internal processor registers.

      clp$put_display (display_control, ' Internal processor register default values:', clc$trim,
            ignore_status);

     /process_register/
      FOR processor_index := 0 TO duc$de_maximum_processors DO
        cpu_line.line := ' ';
        cpu_line.processor_string := 'processor';
        clp$convert_integer_to_string (processor_index, 10, FALSE, integer_string, ignore_status);
        cpu_line.number := integer_string.value (1, integer_string.size);
        cpu_line.colon := ':';
        IF NOT duv$execution_environment.processor_registers [processor_index].available THEN
          cpu_line.not_available := 'not available';
          clp$put_display (display_control, cpu_line.line, clc$trim, ignore_status);
          dup$is_cpu1_installed (duc$ee_cic_disd, processor_index, display_control);
          CYCLE /process_register/;  {---->
        ELSE
          clp$put_display (display_control, cpu_line.line, clc$trim, ignore_status);
        IFEND;

        data_line.line := ' ';
        data_line.equal := '=';

        data_line.default_name := 'job_process_state, jps';
        clp$convert_integer_to_string (
              duv$execution_environment.processor_registers [processor_index].job_process_state, 16, TRUE,
              integer_string, ignore_status);
        data_line.value := integer_string.value (1, integer_string.size);
        clp$put_display (display_control, data_line.line, clc$trim, ignore_status);

        data_line.default_name := 'monitor_process_state, mps';
        clp$convert_integer_to_string (
              duv$execution_environment.processor_registers [processor_index].monitor_process_state, 16,
              TRUE, integer_string, ignore_status);
        data_line.value := integer_string.value (1, integer_string.size);
        clp$put_display (display_control, data_line.line, clc$trim, ignore_status);

        data_line.default_name := 'page_size_mask, psm';
        psm.psm := duv$execution_environment.processor_registers [processor_index].page_size_mask;
        clp$convert_integer_to_string (psm.value, 16, TRUE, integer_string, ignore_status);
        data_line.value := integer_string.value (1, integer_string.size);
        clp$put_display (display_control, data_line.line, clc$trim, ignore_status);

        data_line.default_name := 'page_table_address, pta';
        pta.pta := duv$execution_environment.processor_registers [processor_index].page_table_address;
        clp$convert_integer_to_string (pta.value, 16, TRUE, integer_string, ignore_status);
        data_line.value := integer_string.value (1, integer_string.size);
        clp$put_display (display_control, data_line.line, clc$trim, ignore_status);

        data_line.default_name := 'page_table_length, ptl';
        ptl.ptl := duv$execution_environment.processor_registers [processor_index].page_table_length;
        clp$convert_integer_to_string (ptl.value, 16, TRUE, integer_string, ignore_status);
        data_line.value := integer_string.value (1, integer_string.size);
        clp$put_display (display_control, data_line.line, clc$trim, ignore_status);

      FOREND /process_register/;
    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_defaults;
MODEND dum$display_defaults;
*DECK DECK=DUM$DISPLAY_DELETE EXPAND=TRUE
PROCEDURE dum$display_delete, display_delete (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, sva, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable output_line k=string v=' '
  create_variable log_address v=$value(address)
  create_variable indent k=(string, 5) v='     '
  log_address = log_address + 1

  display_binary_unique_name log_address o=$fname(output_file) cs=indent//'gfn=' am=$value(am)
  output_line = indent//'dfl='//$strrep($mem(log_address+11, 3, j, 0, $value(am)), 16)
  output_line = output_line//' sfid='//$strrep($mem(log_address+14, 4, j, 0, $value(am)), 16)
  output_line = output_line//' fad_index='//$strrep($mem(log_address+18, 1, j, 0, $value(am)), 16)

  putl output_line o=$fname(output_file)

PROCEND dum$display_delete
*DECK DECK=DUM$DISPLAY_DFD EXPAND=TRUE
PROCEDURE dum$display_dfd, display_dfd, disdfd (
  pva: integer = $optional
  output, o: file = $output
  display_option, do: key
      (brief, b), (full, f)
    keyend = brief
  fmd_p: (VAR) integer = $optional
  help, h: file = $null
  status)


  "$FORMAT=OFF"
  VAR
    when_status: status
  VAREND
  "$FORMAT=ON"

  WHEN any_fault DO
    when_status = $previous_status
    putl ' Invoked DISDFD condition handler due to the following abnormal status:'
    disv when_status
    putl ' Enter commands, "exit_proc" to abort, or "exit_proc with when_status" to abort with status'
    include_file command prompt='disdfd_ch'
  WHENEND

  IF $specified(help) THEN
COLLECT_TEXT o=help until='HELPEND'
DISPLAY_DFD or DISDFD

  This procedure will display a file's disk file descriptor when given a
process virtual address to the entry.  This procedure assumes the user has
selected the correct exchange package by available analyze_dump commands.

PARAMETERS:

PVA: integer
  This parameter passes the processor virtual address of the file medium
descriptor to be displayed.  This parameter is required.

OUTPUT, O: file
  This parameter selects the file name to receive the data.  This para-
meter is defaulted to $output.  If a file name other than $output is
entered the data will be formated correctly for printer disposition and
will be sent to the file  "$asis".

DISPLAY_OPTIONS, DO: key full, f, brief, b
  This parameter selects the option of displaying the contents of memory
and the description of the selected fields (full), or the brief mode of
the descriptions only.  This parameter defaults to brief.

FMD_P: integer
  This parameter is returned to the caller and specifies the pointer to
the first File Medium Descriptor (FMD).  This parameter is optional.

STATUS

WARNINGS/KNOWN DEFICIENCIES:

ERROR HANDLER
  When any fatal error is encountered a condition handler is invoked and
the following messages will appear:
 "Invoked DISDFD condition handler due to the following abnormal status:"
 "< the error status message >"
 "Enter commands, "exit_proc" to abort, or "exit_proc with when_status"
  to abort with status"
To exit the handler enter:    "exit_proc"
To exit the handler with status, enter:   "exit_proc with when_status"

HELPEND
    EXIT_PROC
  IFEND

  IF NOT $specified(pva) THEN
    EXIT_PROC WITH $status(false, 'US', 6, 'Parameter PVA is required')
  IFEND

  "$FORMAT=OFF"
  VAR
    output_file: file

    " The following offsets were obtained from the output of the command Display_Symbol_Table
    " for the type DMT$DISK_FILE_DESCRIPTOR.

    read_write_count_offset: integer = 0(16)
    delete_count_offset: integer = 2(16)
    purged_offset: integer = 5(16)
    restricted_attach_offset: integer = 6(16)
    bytes_per_allocation_offset: integer = 7(16)
    file_allocation_table_offset: integer = 0A(16)
    fat_upper_bound_offset: integer = 10(16)
    current_fmd_index_offset: integer = 12(16)
    highest_offset_allocated_offset: integer = 13(16)
    bytes_per_level_2_offset: integer = 19(16)
    dfd_modified_offset: integer = 1F(16)
    overflow_allowed_offset: integer = 20(16)
    requested_alloc_size_offset: integer = 21(16)
    requested_class_offset: integer = 24(16)
    requested_class_ordinal_offset: integer = 25(16)
    requested_transfer_size_offset: integer = 26(16)
    requested_volume_offset: integer = 29(16)
    recorded_vsn_offset: integer = 0(16)
    setname_offset: integer = 6(16)
    number_of_fmds_offset: integer = 4E(16)
    p_fmd_offset: integer = 4F(16)
    file_damaged_offset: integer = 55(16)
    damage_detection_enabled_offset: integer = 56(16)
    fmd_modified_offset: integer = 57(16)
  VAREND
  "$FORMAT=ON"

  IF $file(output open_position) = '$BOI' THEN
    output_file = output.$asis
  ELSE
    output_file = output
  IFEND

  IF output = :$local.$output THEN
    putl '1DISK FILE DESCRIPTOR ' o=output_file
  IFEND

  IF display_option = 'FULL' THEN
    display_memory pva bytes=58(16) t='DISK FILE DESCRIPTOR' o=output_file
  IFEND

  start_of_dfd = pva
  putl '   ' o=output_file

  putl ' read_write_count = '//$strrep($mem(start_of_dfd+read_write_count_offset 2) 16)//'(16)' ..
        o=output_file

  putl ' delete_count = '//$strrep($mem(start_of_dfd+delete_count_offset 3) 16)//'(16)' o=output_file

  IF $mem(start_of_dfd+purged_offset, 1) = 1 THEN
    putl ' purged = TRUE' o=output_file
  ELSE
    putl ' purged = FALSE' o=output_file
  IFEND

  IF $mem(start_of_dfd+restricted_attach_offset, 1) = 1 THEN
    putl ' restricted_attach = TRUE' o=output_file
  ELSE
    putl ' restricted_attach = FALSE' o=output_file
  IFEND

  putl ' bytes_per_allocation = '//$strrep($mem(start_of_dfd+bytes_per_allocation_offset 3) 16)//'(16)' ..
        o=output_file

  putl ' file_allocation_table = '//$strrep($mem(start_of_dfd+file_allocation_table_offset 6) 16)//'(16)' ..
        o=output_file

  putl ' fat_upper_bound = '//$strrep($mem(start_of_dfd+fat_upper_bound_offset 2) 16)//'(16)' ..
        o=output_file

  putl ' current_fmd_index = '//$strrep($mem(start_of_dfd+current_fmd_index_offset 1) 16)//'(16)' ..
        o=output_file

  putl ' highest_offset_allocated = '//..
$strrep($mem(start_of_dfd+highest_offset_allocated_offset 6) 16)//'(16)' o=output_file

  putl ' bytes_per_level_2 = '//$strrep($mem(start_of_dfd+bytes_per_level_2_offset 6) 16)//'(16)' ..
        o=output_file

  IF $mem(start_of_dfd+dfd_modified_offset, 1) = 1 THEN
    putl ' dfd_modified = TRUE' o=output_file
  ELSE
    putl ' dfd_modified = FALSE' o=output_file
  IFEND

  IF $mem(start_of_dfd+overflow_allowed_offset, 1) = 1 THEN
    putl ' overflow_allowed = TRUE' o=output_file
  ELSE
    putl ' overflow_allowed = FALSE' o=output_file
  IFEND

  putl ' requested_allocation_size = '//..
$strrep($mem(start_of_dfd+requested_alloc_size_offset, 3), 16)//'(16)' o=output_file

  putl ' requested_class = '//$ms(start_of_dfd+requested_class_offset, 1) o=output_file

  putl ' requested_class_ordinal = '//..
$strrep($memory(start_of_dfd+requested_class_ordinal_offset, 1), 16)//'(16)' o=output_file

  putl ' requested_transfer_size = '//..
$strrep($memory(start_of_dfd+requested_transfer_size_offset, 3), 16)//'(16)' o=output_file

  putl ' requested_volume:' o=output_file
  putl '   recorded_vsn = '//$memory_string(start_of_dfd+requested_volume_offset+recorded_vsn_offset, 6) ..
        o=output_file
  putl '   setname = '//$memory_string(start_of_dfd+requested_volume_offset+setname_offset, 31) ..
        o=output_file

  putl ' number_of_fmds = '//$strrep($memory(start_of_dfd+number_of_fmds_offset, 1), 16)//'(16)' ..
        o=output_file

  putl ' p_fmd = '//$strrep($memory(start_of_dfd+p_fmd_offset, 6), 16)//'(16)' o=output_file

  IF $memory(start_of_dfd+file_damaged_offset, 1) = 1 THEN
    putl ' file_damaged_offset = TRUE' o=output_file
  ELSE
    putl ' file_damaged_offset = FALSE' o=output_file
  IFEND

  IF $memory(start_of_dfd+damage_detection_enabled_offset, 1) = 1 THEN
    putl ' damage_detection_enabled = TRUE' o=output_file
  ELSE
    putl ' damage_detection_enabled = FALSE' o=output_file
  IFEND

  IF $memory(start_of_dfd+fmd_modified_offset, 1) = 1 THEN
    putl ' fmd_modified = TRUE' o=output_file
  ELSE
    putl ' fmd_modified = FALSE' o=output_file
  IFEND

  IF $specified(fmd_p) THEN
    fmd_p = $memory(start_of_dfd+p_fmd_offset, 6)
  IFEND

PROCEND dum$display_dfd
*DECK DECK=DUM$DISPLAY_DFL_ENTRY EXPAND=TRUE
PROCEDURE dum$display_dfl_entry, display_dfl_entry, disdfle (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, p, sva, s, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable flag_kind k=string d=0..2
  flag_kind(0) = 'available'
  flag_kind(1) = 'assigned to mainframe'
  flag_kind(2) = 'assigned to file'

  create_variable chain_s k=string d=0..1
  chain_s(0) = 'linked'
  chain_s(1) = 'NOT linked'

  create_variable dmt$file_damage_types k=string d=0..15
  dmt$file_damage_types(15) = 'dmc$file_damage_15'
  dmt$file_damage_types(14) = 'dmc$file_damage_14'
  dmt$file_damage_types(13) = 'dmc$file_damage_13'
  dmt$file_damage_types(12) = 'dmc$file_damage_12'
  dmt$file_damage_types(11) = 'dmc$file_damage_11'
  dmt$file_damage_types(10) = 'dmc$file_damage_10'
  dmt$file_damage_types(9) = 'dmc$file_damage_9'
  dmt$file_damage_types(8) = 'dmc$file_damage_8'
  dmt$file_damage_types(7) = 'dmc$file_damage_7'
  dmt$file_damage_types(6) = 'dmc$file_damage_6'
  dmt$file_damage_types(5) = 'dmc$file_damage_5'
  dmt$file_damage_types(4) = 'dmc$file_damage_4'
  dmt$file_damage_types(3) = 'dmc$file_damage_3'
  dmt$file_damage_types(2) = 'dmc$media_image_inconsistent'
  dmt$file_damage_types(1) = 'dmc$allocation_chain_brocken'
  dmt$file_damage_types(0) = 'dmc$eoi_modified_by_recovery'

  create_variable file_type k=string d=0..5
  file_type(0) = 'permanent'
  file_type(1) = 'device'
  file_type(2) = 'temp_named'
  file_type(3) = 'temp_unnamed'
  file_type(4) = 'catalog'
  file_type(5) = 'temp_global'
  create_variable output_line k=string v=' '
  create_variable indent k=(string, 5) v='     '

  start_of_entry = $value(address)
  display_memory start_of_entry b=56 am=$value(am) o=$fname(output_file) t='DEVICE FILE LIST ENTRY'

  gfn_address = start_of_entry+16
  display_binary_unique_name gfn_address o=$fname(output_file) cs='       gfn=' am=$value(am)

  output_line = indent//' flag='//flag_kind($mem(start_of_entry+2, 1,,, $value(am)))
  output_line = output_line//'   chain_status='//chain_s($mem(start_of_entry+3, 1,,, $value(am)))
  putl output_line o=$fname(output_file)
  output_line = ' '
  output_line = indent//' dau/au='//$strrep($mem(start_of_entry+4, 1,,, $value(am)), 16)//'(16)'
  output_line = output_line//'   file_byte_address='//..
$strrep($mem(start_of_entry+5, 6,,, $value(am)), 16)//'(16)'
  output_line = output_line//'   hash='//$strrep($mem(start_of_entry+11, 1,,, $value(am)), 16)//'(16)'
  output_line = output_line//'   '//file_type($mem(start_of_entry+12, 1,,, $value(am)))//' file'
  putl output_line o=$fname(output_file)
  output_line = ' '
  output_line = indent//' first_dau='//$strrep($mem(start_of_entry+13, 3,,, $value(am)), 16)//'(16)'
  output_line = output_line//'   subf_length='//$strrep($mem(start_of_entry+27, 6,,, $value(am)), 16)//'(16)'
  output_line = output_line//'   logical_length='//..
$strrep($mem(start_of_entry+33, 6,,, $value(am)), 16)//'(16)'
  putl output_line o=$fname(output_file)
  output_line = ' '
  output_line = indent//' eoi='//$strrep($mem(start_of_entry+39, 6,,, $value(am)), 16)//'(16)'
  output_line = output_line//'   eof='//$strrep($mem(start_of_entry+45, 6,,, $value(am)), 16)//'(16)'
  output_line = output_line//'   login_set='//$strrep($mem(start_of_entry+51, 3,,, $value(am)), 16)//'(16)'
  putl output_line o=$fname(output_file)
  null_set = true
  damage_set = $mem(start_of_entry+54, 2,,, $value(am))
  FOR i = 0 TO 15 DO
    IF damage_set <> (damage_set/ 2 * 2) THEN
      output_line = indent//' damage = '//dmt$file_damage_types(15-i)
      putl output_line o=$fname(output_file)
      null_set = false
    IFEND
    damage_set = damage_set/ 2
  FOREND

  IF null_set THEN
    output_line = indent//' damage = null set'
    putl output_line o=$fname(output_file)
  IFEND
  output_line = ' '

PROCEND dum$display_dfl_entry
*DECK DECK=DUM$DISPLAY_DF_BUFFER EXPAND=TRUE
PROCEDURE dum$display_df_buffer, display_df_buffer, disdfb (
    p_buffer: integer = $required
    remote_procedure_call, rpc: boolean = false
    monitor_entry, me: boolean = false
    output, o: file = $output
    status)

 " This displays the file server send or receive buffer.
 " The parameter remote_procedure_call is used to determine on STATUS
 "   buffers whether to look for a remote procedure call header
 " This proc uses RJTs newest dump analyzer
 " This assumes that   dfm$client_remote_procedur_call,
 " dfm$test_remote_procedure_call, and dfm$manage_client_connection have been
 " added.

   current = $default_module
   chadm dfm$client_remote_procedur_call
   set_file_attributes output fc=legible pf=continuous
   out = output.$eoi

 IF remote_procedure_call THEN
   remote_procedure_call_test = ($pv(?p_buffer.dft$buffer_header.remote_processor) = ..
          DFC$RPC_RESTARTABLE_TEST) OR ..
    ($pv(?p_buffer.dft$buffer_header.remote_processor) = ..
        DFC$RPC_UNRESTARTABLE_TEST)
 IFEND

 buffer_header_size = $pv(#size(0.dft$Buffer_header))
 rpc_buffer_header_size = $pv(#size(0.dft$rpc_buffer_header))
 rpc_response_buffer_header_size = $pv(#size(0.dft$rpc_response_buffer_header))
 mtr_status_size = $pv(#size(0.syt$monitor_status))
 os_status_size = $pv(#size(0.ost$status))
 dispv ?p_buffer.dft$Buffer_header   o=out
 IF $pv(?p_buffer.dft$buffer_header.version)= 'CYBILRPC' THEN
     p_rpc_buffer= p_buffer + buffer_header_size
     dispv ?p_rpc_buffer.dft$rpc_buffer_header  o=out
     IF remote_procedure_call THEN
       IF remote_procedure_call_test THEN
         chadm dfm$test_remote_procedure_call
         p_test_header = p_rpc_buffer + rpc_buffer_header_size
         dispv ?p_test_header.dft$rpc_test_request_header   o=out
         chadm dfm$client_remote_procedur_call
       IFEND
     IFEND
 ELSEIF $pv(?p_buffer.dft$buffer_header.version)= 'STATUS' THEN
   p_mtr_status = p_buffer + buffer_header_size
   dispv ?p_mtr_status.syt$monitor_status   o=out
   IF $pv(?p_mtr_status.syt$monitor_status.normal) THEN
      p_rpc_buffer = p_mtr_status + mtr_status_size
     IF monitor_entry THEN
       chadm dfm$process_server_response
       dispv ?p_rpc_buffer.dft$page_io_response o=out
     IFEND
   ELSE " Abnormal status
     disv $condition_name($pv(?p_mtr_status.syt$monitor_status.condition))  o=out
     IF NOT monitor_entry THEN
       p_os_status =  p_mtr_status + mtr_status_size
       dispv ?p_os_status.ost$status    o=out
       p_rpc_buffer = p_os_status + os_status_size
     IFEND
   IFEND
   IF remote_procedure_call THEN
     dispv ?p_rpc_buffer.dft$rpc_response_buffer_header   o=out
     IF remote_procedure_call_test THEN
       chadm dfm$test_remote_procedure_call
       p_test_header = p_rpc_buffer + rpc_response_buffer_header_size
       dispv ?p_test_header.dft$rpc_test_request_header  o=out
       chadm dfm$client_remote_procedur_call
     IFEND
   IFEND
 ELSEIF $pv(?p_buffer.dft$buffer_header.version)= 'POLL_MSG' THEN
   chadm dfm$manage_client_connection
   poll_header_size = $pv(#size(0.dft$poll_header))
   p_poll_header = p_buffer + buffer_header_size
   dispv ?p_poll_header.dft$poll_header o=out
   IF ($pv(?p_buffer.dft$buffer_header.remote_processor) = DFC$VERIFY_QUEUE) ..
     OR ($pv(?p_buffer.dft$buffer_header.remote_processor) = DFC$VERIFY_QUEUE_REPLY) THEN
     p_queue_info = p_poll_header + poll_header_size
     dispv ?p_queue_info.dft$poll_queue_information o=out
   IFEND
 ELSEIF $pv(?p_buffer.dft$buffer_header.version)= 'ALLOCATE' THEN
   chadm dfm$process_server_response
   p_allocate_space_request = p_buffer + buffer_header_size
   dispv ?p_allocate_space_request.dft$page_io_request o=out
 ELSEIF $pv(?p_buffer.dft$buffer_header.version)= 'PAGEIO  ' THEN
   chadm dfm$process_server_response
   p_page_io_request = p_buffer + buffer_header_size
   dispv ?p_page_io_request.dft$page_io_request o=out
 IFEND

 chadm current
PROCEND dum$display_df_buffer


*DECK DECK=DUM$DISPLAY_DR_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Dump Record Command' ??
MODULE dum$display_dr_command;

{ PURPOSE:
{   This module contains the code for the display_dump_record command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc dup$display_data
*copyc dup$find_record_list_entry
*copyc dup$new_page_procedure
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_dr_command', EJECT ??

{ PURPOSE:
{   This procedure displays a dump record from the restart file.

  PROCEDURE [XDCL] dup$display_dr_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_dump_record, disdr (
{   record_identifier, ri: any of
{       string 1..3
{       integer
{       name
{     anyend = $required
{   offset, off: integer = 0
{   bytes, b: integer 0..500000
{   display_option, do: list 1..2 of key
{       (numeric n) (ascii a) (display_code dc)
{     keyend = (numeric ascii)
{   title, t: string 1..31 = 'display_dump_record'
{   radix, r: integer 8..16 = 16
{   output, o: file
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 15] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: 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 .. 6] of clt$keyword_specification,
        recend,
        default_value: string (15),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (21),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (2),
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 1, 22, 11, 36, 21, 819],
    clc$command, 15, 8, 1, 0, 0, 0, 8, ''], [
    ['B                              ',clc$abbreviation_entry, 3],
    ['BYTES                          ',clc$nominal_entry, 3],
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 4],
    ['DO                             ',clc$abbreviation_entry, 4],
    ['O                              ',clc$abbreviation_entry, 7],
    ['OFF                            ',clc$abbreviation_entry, 2],
    ['OFFSET                         ',clc$nominal_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 7],
    ['R                              ',clc$abbreviation_entry, 6],
    ['RADIX                          ',clc$nominal_entry, 6],
    ['RECORD_IDENTIFIER              ',clc$nominal_entry, 1],
    ['RI                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 8],
    ['T                              ',clc$abbreviation_entry, 5],
    ['TITLE                          ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 57, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 245,
  clc$optional_default_parameter, 0, 15],
{ PARAMETER 5
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 21],
{ PARAMETER 6
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 7
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 8
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type, clc$name_type, clc$string_type],
    TRUE, 3],
    8, [[1, 0, clc$string_type], [1, 3, FALSE]],
    20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10],
    '0'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, 500000, 10]],
{ PARAMETER 4
    [[1, 0, clc$list_type], [229, 1, 2, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [6], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['ASCII                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['DC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['DISPLAY_CODE                   ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['NUMERIC                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    '(numeric ascii)'],
{ PARAMETER 5
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_dump_record'''],
{ PARAMETER 6
    [[1, 0, clc$integer_type], [8, 16, 10],
    '16'],
{ PARAMETER 7
    [[1, 0, clc$file_type]],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$record_identifier = 1,
      p$offset = 2,
      p$bytes = 3,
      p$display_option = 4,
      p$title = 5,
      p$radix = 6,
      p$output = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    VAR
      bytes: integer,
      cell_p: ^cell,
      display_control: clt$display_control,
      display_string: string (osc$max_string_size),
      end_of_input_file: boolean,
      entry_p: ^dut$de_other_record_entry,
      ignore_status: ost$status,
      output_display_opened: boolean,
      restart_file_seq_p: ^SEQ ( * ),
      ring_attributes: amt$ring_attributes,
      skip_data_p: ^SEQ ( * ),
      string_length: integer;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    dup$find_record_list_entry (pvt [p$record_identifier].value^, entry_p);
    IF entry_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The specified record is',
            status);
      RETURN;  {---->
    IFEND;

    IF entry_p^.record_type <> duc$de_ort_dump THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$record_type_supported, 'DUMP', status);
      RETURN;  {---->
    IFEND;

    { Determine the number of bytes to display.

    IF (pvt [p$offset].value^.integer_value.value > entry_p^.size) THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$invalid_offset, '', status);
      RETURN;  {---->
    IFEND;
    IF pvt [p$bytes].specified THEN
      bytes := pvt [p$bytes].value^.integer_value.value;
    ELSE
      bytes := entry_p^.size;
    IFEND;
    IF (bytes + pvt [p$offset].value^.integer_value.value) > entry_p^.size THEN
      bytes := entry_p^.size - pvt [p$offset].value^.integer_value.value;
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

      { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      IF pvt [p$title].specified THEN
        duv$title_data.command_name := pvt [p$title].value^.string_value^;
      ELSE
        STRINGREP (display_string, string_length, 'display_dump_record :  ', entry_p^.name);
        duv$title_data.command_name := display_string (1, string_length);
      IFEND;

      IF bytes = 0 THEN
        EXIT /display_opened/;  {---->
      IFEND;

      { Skip to the desired offset in the record data.

      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);
      RESET restart_file_seq_p TO cell_p;
      IF pvt [p$offset].value^.integer_value.value <> 0 THEN
        NEXT skip_data_p: [[REP pvt [p$offset].value^.integer_value.value OF cell]] IN restart_file_seq_p;
        IF skip_data_p = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
          EXIT /display_opened/;  {---->
        IFEND;
      IFEND;

      { Display the data.

      dup$display_data (pvt [p$display_option].value, TRUE, pvt [p$radix].value^.integer_value.value,
            pvt [p$offset].value^.integer_value.value, bytes, display_control, restart_file_seq_p,
            end_of_input_file, status);

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_dr_command;
MODEND dum$display_dr_command;
*DECK DECK=DUM$DISPLAY_DR_LIST_COMMAND EXPAND=TRUE
*DECK DECK=DUM$DISPLAY_DSB_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Dual State Buffer Command' ??
MODULE dum$display_dsb_command;

{ PURPOSE:
{   This module contains the code for the display_dual_state_buffer command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$find_record_list_entry
*copyc dup$new_page_procedure
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    v$control_codes_to_space: [READ] string (256) := '            '
      CAT '                     !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijkl'
      CAT 'mnopqrstuvwxyz{|}~                                                                                '
      CAT '                                                 ';
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_dsb_command', EJECT ??

{ PURPOSE:
{   This procedure displays the information from the Dual State Control Block which is also
{   known as the EICB.

  PROCEDURE [XDCL] dup$display_dsb_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_dual_state_buffer, disdsb (
{   output, o: file = $optional
{   title, t: string 1..31 = 'display_dual_state_buffer'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (27),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 4, 18, 8, 59, 7, 764],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TITLE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 27],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_dual_state_buffer'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$title = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    CONST
      c$eicb_length = 46;

    TYPE
      t$array_or_integer = RECORD
        CASE boolean OF
        = TRUE =
          array_part: ARRAY [1 .. 4] OF 0 .. 0ffff(16),
        = FALSE =
          integer_part: integer,
        CASEND,
      RECEND,

      t$line = RECORD
        CASE boolean OF
        = TRUE =
          title: string (11),
          register_string: string (19),
          space: string (2),
          ascii_data: string (8),
        = FALSE =
          data: string (40),
        CASEND,
      RECEND;

    VAR
      array_or_integer_p: ^t$array_or_integer,
      ascii_part_p: ^string (8),
      cell_p: ^cell,
      data_value: clt$data_value,
      display_control: clt$display_control,
      display_string: string (osc$max_string_size),
      entry_p: ^dut$de_other_record_entry,
      ignore_status: ost$status,
      index: 1 .. 4,
      integer_p: ^integer,
      line: t$line,
      new_byte_size: ost$segment_length,
      output_display_opened: boolean,
      register_seq_p: ^SEQ (REP 1 OF integer),
      register_string_index: 0 .. 0ff(16),
      restart_file_seq_p: ^SEQ ( * ),
      ring_attributes: amt$ring_attributes,
      save_p: ^cell,
      string_4: string (4),
      string_length: integer,
      titles: [static] ARRAY [1 .. c$eicb_length] OF string (11) :=
            [' D7TY    = ',
             ' D7JP    = ',
             ' D7JP+1  = ',
             ' D7ST    = ',
             ' D7RS    = ',
             ' D7RS+1  = ',
             ' D7RS+2  = ',
             ' D7CM    = ',
             ' D7CM+1  = ',
             ' D7SV    = ',
             ' D7SV+1  = ',
             ' D7SV+2  = ',
             ' D7SV+3  = ',
             ' D7SV+4  = ',
             ' D7SV+5  = ',
             ' D8TY    = ',
             ' D8TM    = ',
             ' D8TM+1  = ',
             ' D8JP    = ',
             ' D8JP+1  = ',
             ' D8ST    = ',
             ' D8DS    = ',
             ' D8DS+1  = ',
             ' D8DS+2  = ',
             ' D8SV    = ',
             ' D8SV+1  = ',
             ' D8SV+2  = ',
             ' D8SV+3  = ',
             ' D8SV+4  = ',
             ' D8SV+5  = ',
             ' DSCM    = ',
             ' DSCM+1  = ',
             ' DSCM+2  = ',
             ' DSCM+3  = ',
             ' DSCM+4  = ',
             ' DFCM    = ',
             ' DFCM+1  = ',
             ' DFCM+2  = ',
             ' DFCM+3  = ',
             ' DFCM+4  = ',
             ' DFCM+5  = ',
             ' DFCM+6  = ',
             ' DFCM+7  = ',
             ' DFCM+8  = ',
             ' DFCM+9  = ',
             ' DFCM+10 = '],
      word_index: 1 .. c$eicb_length;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

      { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      data_value.kind := clc$name;
      data_value.name_value := 'DSB';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p = NIL THEN
        clp$put_display (display_control, ' **ERROR** - Cannot find the DSB record on the restart file.',
              clc$trim, ignore_status);
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The specified record is',
              status);
        EXIT /display_opened/;  {---->
      IFEND;

      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);
      RESET restart_file_seq_p TO cell_p;

      PUSH register_seq_p;
      FOR word_index := 1 TO c$eicb_length DO
        line.data := ' ';
        line.title := titles [word_index];

        NEXT save_p IN restart_file_seq_p;
        IF save_p = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
          EXIT /display_opened/;  {---->
        IFEND;
        RESET restart_file_seq_p TO save_p;

        NEXT integer_p IN restart_file_seq_p;
        IF integer_p = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
          EXIT /display_opened/;  {---->
        IFEND;
        RESET register_seq_p;
        NEXT array_or_integer_p IN register_seq_p;
        IF array_or_integer_p = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
          EXIT /display_opened/;  {---->
        IFEND;
        array_or_integer_p^.integer_part := integer_p^;

        line.register_string := ' ';
        register_string_index := 1;
        FOR index := 1 TO 4 DO
          string_4 := 'XXXX';
          clp$convert_integer_to_rjstring (array_or_integer_p^ .array_part [index], 16, FALSE, '0',
                string_4, ignore_status);
          line.register_string (register_string_index, 4) := string_4;
          register_string_index := register_string_index + 5;
        FOREND;

        RESET restart_file_seq_p TO save_p;
        NEXT ascii_part_p IN restart_file_seq_p;
        IF ascii_part_p = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
          EXIT /display_opened/;  {---->
        IFEND;
        #TRANSLATE (v$control_codes_to_space, ascii_part_p^, line.ascii_data);

        clp$put_display (display_control, line.data, clc$trim, ignore_status);
      FOREND;

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_dsb_command;
MODEND dum$display_dsb_command;
*DECK DECK=DUM$DISPLAY_DUMP_INFO_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Dump Information Command' ??                                   
MODULE dum$display_dump_info_command;                                                                         
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains the code for the display_dump_information command.                                   
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc due$exception_condition_codes                                                                          
*copyc dut$did_record_type                                                                                    
?? POP ??                                                                                                     
*copyc dup$new_page_procedure                                                                                 
*copyc clp$close_display                                                                                      
*copyc clp$evaluate_parameters                                                                                
*copyc clp$open_display_reference                                                                             
*copyc clp$put_display                                                                                        
*copyc osp$disestablish_cond_handler                                                                          
*copyc osp$establish_block_exit_hndlr                                                                         
*copyc osp$set_status_abnormal                                                                                
?? EJECT ??                                                                                                   
*copyc duv$dump_environment_p                                                                                 
*copyc duv$execution_environment                                                                              
*copyc duv$title_data                                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'convert_byte_to_octal_string', EJECT ??                                                       
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure converts a byte into an octal string.                                                      
                                                                                                              
  PROCEDURE convert_byte_to_octal_string                                                                      
    (    byte: 0 .. 0ff(16);                                                                                  
     VAR octal_string: string (5));                                                                           
                                                                                                              
    TYPE                                                                                                      
      t$byte_record = PACKED RECORD                                                                           
        fill: 0 .. 03(16),                                                                                    
        left: 0 .. 07(16),                                                                                    
        right: 0 .. 07(16),                                                                                   
      RECEND;                                                                                                 
                                                                                                              
    VAR                                                                                                       
      byte_record_p: ^t$byte_record,                                                                          
      octal_characters: [STATIC] ARRAY [0 .. 7] OF char := ['0', '1', '2', '3', '4', '5', '6', '7'];          
                                                                                                              
    byte_record_p := #LOC (byte);                                                                             
    octal_string (1) := octal_characters [byte_record_p^.left];                                               
    octal_string (2) := octal_characters [byte_record_p^.right];                                              
    octal_string (3) := '(';                                                                                  
    octal_string (4) := '8';                                                                                  
    octal_string (5) := ')';                                                                                  
                                                                                                              
  PROCEND convert_byte_to_octal_string;                                                                       
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'display_deadstart_channel', EJECT ??                                                          
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays the deadstart channel of the dump.                                                
                                                                                                              
  PROCEDURE display_deadstart_channel                                                                         
    (    deadstart_channel: dut$did_identifier_entry;                                                         
     VAR display_control: clt$display_control);                                                               
                                                                                                              
    VAR                                                                                                       
      display_string: string (osc$max_string_size),                                                           
      ignore_status: ost$status,                                                                              
      octal_string: string (5),                                                                               
      string_length: integer;                                                                                 
                                                                                                              
    convert_byte_to_octal_string (deadstart_channel.value, octal_string);                                     
    STRINGREP (display_string, string_length, ' Deadstart channel = ', octal_string);                         
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);            
                                                                                                              
  PROCEND display_deadstart_channel;                                                                          
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'display_dump_number', EJECT ??                                                                
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays the dump number of the dump.                                                      
                                                                                                              
  PROCEDURE display_dump_number                                                                               
    (    dump_number: dut$did_identifier_entry;                                                               
     VAR display_control: clt$display_control);                                                               
                                                                                                              
    VAR                                                                                                       
      display_string: string (osc$max_string_size),                                                           
      ignore_status: ost$status,                                                                              
      octal_string: string (5),                                                                               
      string_length: integer;                                                                                 
                                                                                                              
    convert_byte_to_octal_string (dump_number.value, octal_string);                                           
    STRINGREP (display_string, string_length, ' Dump number = ', octal_string);                               
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);            
                                                                                                              
  PROCEND display_dump_number;                                                                                
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'display_dump_taken_indicator', EJECT ??                                                       
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays the dump taken indicator.                                                         
                                                                                                              
  PROCEDURE display_dump_taken_indicator                                                                      
    (    dump_taken_indicator: dut$did_identifier_entry;                                                      
     VAR display_control: clt$display_control);                                                               
                                                                                                              
    VAR                                                                                                       
      ignore_status: ost$status;                                                                              
                                                                                                              
    IF dump_taken_indicator.value <> 77(8) THEN                                                               
      clp$put_display (display_control, ' NOTE : First dump taken', clc$trim, ignore_status);                 
    ELSE                                                                                                      
      clp$put_display (display_control, ' NOTE : This is not the first dump taken', clc$trim, ignore_status); 
    IFEND;                                                                                                    
                                                                                                              
  PROCEND display_dump_taken_indicator;                                                                       
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'display_edd_revision_level', EJECT ??                                                         
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays the EDD revision level.                                                           
                                                                                                              
  PROCEDURE display_edd_revision_level                                                                        
    (VAR display_control: clt$display_control);                                                               
                                                                                                              
    VAR                                                                                                       
      display_string: string (osc$max_string_size),                                                           
      ignore_status: ost$status,                                                                              
      string_length: integer;                                                                                 
                                                                                                              
    STRINGREP (display_string, string_length, ' EDD revision level = ',                                       
          duv$dump_environment_p^.dump_identifier.edd_revision_level);                                        
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);            
                                                                                                              
  PROCEND display_edd_revision_level;                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'display_extended_memory', EJECT ??                                                            
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays the extended memory of the dump.                                                  
                                                                                                              
  PROCEDURE display_extended_memory                                                                           
    (    extended_memory: dut$did_extended_memory;                                                            
     VAR display_control: clt$display_control);                                                               
                                                                                                              
    VAR                                                                                                       
      display_string: string (osc$max_string_size),                                                           
      ignore_status: ost$status,                                                                              
      octal_string: string (5),                                                                               
      octal_string_2: string (5),                                                                             
      string_length: integer;                                                                                 
                                                                                                              
    IF (extended_memory.entry.value_1 > 0) OR (extended_memory.entry.value_2 > 0) THEN                        
      convert_byte_to_octal_string (extended_memory.entry.value_1, octal_string);                             
      convert_byte_to_octal_string (extended_memory.entry.value_2, octal_string_2);                           
      STRINGREP (display_string, string_length, ' Number of 10000(8) word blocks of extended memory = ',      
            octal_string(1, 2), octal_string_2);                                                              
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);          
                                                                                                              
      { Display the extended memory channel.                                                                  
                                                                                                              
      convert_byte_to_octal_string (extended_memory.channel.value, octal_string);                             
      STRINGREP (display_string, string_length, ' Extended Memory channel = ', octal_string);                 
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);          
    IFEND;                                                                                                    
                                                                                                              
  PROCEND display_extended_memory;                                                                            
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'display_ipi_port_number', EJECT ??                                                            
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays the IPI port number.                                                              
                                                                                                              
  PROCEDURE display_ipi_port_number                                                                           
    (    tape_information: dut$did_tape_information;                                                          
         ipi_tape_port_number: dut$did_identifier_entry;                                                      
     VAR display_control: clt$display_control);                                                               
                                                                                                              
    VAR                                                                                                       
      display_string: string (osc$max_string_size),                                                           
      ignore_status: ost$status,                                                                              
      octal_string: string (5),                                                                               
      string_length: integer;                                                                                 
                                                                                                              
    IF (tape_information.tape_type.value = 40(8)) OR (tape_information.tape_type.value = 41(8)) THEN          
      convert_byte_to_octal_string (ipi_tape_port_number.value, octal_string);                                
      STRINGREP (display_string, string_length, ' IPI tape port number = ', octal_string);                    
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);          
    IFEND;                                                                                                    
                                                                                                              
  PROCEND display_ipi_port_number;                                                                            
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'display_memory_option', EJECT ??                                                              
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays the memory option of the dump.                                                    
                                                                                                              
  PROCEDURE display_memory_option                                                                             
    (    memory_option: dut$did_identifier_entry;                                                             
     VAR display_control: clt$display_control);                                                               
                                                                                                              
    VAR                                                                                                       
      ignore_status: ost$status;                                                                              
                                                                                                              
    IF memory_option.value = duc$did_all_180_state_memory THEN                                                
      clp$put_display (display_control, ' Full memory dump was selected', clc$trim, ignore_status);           
    ELSEIF memory_option.value = duc$did_no_180_state_memory THEN                                             
      clp$put_display (display_control, ' No 180-state memory dump was selected', clc$trim, ignore_status);   
    ELSEIF memory_option.value = duc$did_critical_180_state_mem THEN                                          
      clp$put_display (display_control, ' Critical memory dump was selected', clc$trim, ignore_status);       
    ELSE                                                                                                      
      clp$put_display (display_control, ' Unknown option value.', clc$trim, ignore_status);                   
    IFEND;                                                                                                    
                                                                                                              
  PROCEND display_memory_option;                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'display_tape_information', EJECT ??                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays the tape information of the dump.                                                 
                                                                                                              
  PROCEDURE display_tape_information                                                                          
    (    tape_information: dut$did_tape_information;                                                          
     VAR display_control: clt$display_control);                                                               
                                                                                                              
    VAR                                                                                                       
      display_string: string (osc$max_string_size),                                                           
      ignore_status: ost$status,                                                                              
      octal_string: string (5),                                                                               
      string_length: integer;                                                                                 
                                                                                                              
    clp$put_display (display_control, ' Tape Selections : ', clc$trim, ignore_status);                        
    IF tape_information.tape_type.value = 1 THEN                                                              
      clp$put_display (display_control, '     tape_type = 667, 669', clc$trim, ignore_status);                
      clp$put_display (display_control, '       density = 800 BPI',  clc$trim, ignore_status);                
    ELSEIF tape_information.tape_type.value = 2 THEN                                                          
      clp$put_display (display_control, '     tape_type = 677', clc$trim, ignore_status);                     
      clp$put_display (display_control, '       density = 800 BPI', clc$trim, ignore_status);                 
      clp$put_display (display_control, '     tape_type = 639, 679, 698(ccc)', clc$trim, ignore_status);      
      clp$put_display (display_control, '       density = 1600 BPI', clc$trim, ignore_status);                
    ELSEIF tape_information.tape_type.value = 3 THEN                                                          
      clp$put_display (display_control, '     tape_type = 639, 679, 698(ccc)', clc$trim, ignore_status);      
      clp$put_display (display_control, '       density = 6250 BPI', clc$trim, ignore_status);                
    ELSEIF tape_information.tape_type.value = 4 THEN                                                          
      clp$put_display (display_control, '     tape_type = 5680', clc$trim, ignore_status);                    
      clp$put_display (display_control, '       density = 38000 BPI', clc$trim, ignore_status);               
    ELSEIF tape_information.tape_type.value = 40(8) THEN                                                      
      clp$put_display (display_control, '     tape_type = 698(ipi)', clc$trim, ignore_status);                
      clp$put_display (display_control, '       density = 1600 BPI', clc$trim, ignore_status);                
    ELSEIF tape_information.tape_type.value = 41(8) THEN                                                      
      clp$put_display (display_control, '     tape_type = 698(ipi)', clc$trim, ignore_status);                
      clp$put_display (display_control, '       density = 6250 BPI', clc$trim, ignore_status);                
    IFEND;                                                                                                    
    convert_byte_to_octal_string (tape_information.tape_channel.value, octal_string);                         
    STRINGREP (display_string, string_length, '     channel   = ', octal_string);                             
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);            
    convert_byte_to_octal_string (tape_information.tape_equipment.value, octal_string);                       
    STRINGREP (display_string, string_length, '     equipment = ', octal_string);                             
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);            
    convert_byte_to_octal_string (tape_information.tape_unit.value, octal_string);                            
    STRINGREP (display_string, string_length, '     tape unit = ', octal_string);                             
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);            
                                                                                                              
  PROCEND display_tape_information;                                                                           
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'display_unload_option', EJECT ??                                                              
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays the unload option of the dump.                                                    
                                                                                                              
  PROCEDURE display_unload_option                                                                             
    (    unload_option: dut$did_identifier_entry;                                                             
     VAR display_control: clt$display_control);                                                               
                                                                                                              
    VAR                                                                                                       
      ignore_status: ost$status;                                                                              
                                                                                                              
    IF unload_option.value <> duc$did_unload_dump_selected THEN                                               
      clp$put_display (display_control, ' Rewind dump selected', clc$trim, ignore_status);                    
    ELSE                                                                                                      
      clp$put_display (display_control, ' Unload dump selected', clc$trim, ignore_status);                    
    IFEND;                                                                                                    
                                                                                                              
  PROCEND display_unload_option;                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$display_dump_info_command', EJECT ??                                                      
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays the information from the dump identifier record.                                  
                                                                                                              
  PROCEDURE [XDCL] dup$display_dump_info_command                                                              
    (    parameter_list: clt$parameter_list;                                                                  
     VAR status: ost$status);                                                                                 
                                                                                                              
{ PROCEDURE display_dump_information, display_dump_info, disdi (                                              
{   output, o: file = $optional                                                                               
{   title, t: string 1..31 = 'display_dump_information'                                                       
{   status)                                                                                                   
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 5] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 3] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$string_type_qualifier,                                                                 
        default_value: string (26),                                                                           
      recend,                                                                                                 
      type3: record                                                                                           
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [90, 4, 16, 9, 39, 50, 817],                                                                              
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [                                                                  
    ['O                              ',clc$abbreviation_entry, 1],                                            
    ['OUTPUT                         ',clc$nominal_entry, 1],                                                 
    ['STATUS                         ',clc$nominal_entry, 3],                                                 
    ['T                              ',clc$abbreviation_entry, 2],                                            
    ['TITLE                          ',clc$nominal_entry, 2]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [2, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],                                                                                                       
{ PARAMETER 2                                                                                                 
    [5, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,                          
  clc$optional_default_parameter, 0, 26],                                                                     
{ PARAMETER 3                                                                                                 
    [3, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name],                                                         
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,                      
  clc$optional_parameter, 0, 0]],                                                                             
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$file_type]],                                                                                  
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$string_type], [1, 31, FALSE],                                                                 
    '''display_dump_information'''],                                                                          
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$status_type]]];                                                                               
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$output = 1,                                                                                           
      p$title = 2,                                                                                            
      p$status = 3;                                                                                           
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 3] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      cell_p: ^cell,                                                                                          
      cy2000_data_p: ^dut$did_edd_data,                                                                       
      display_control: clt$display_control,                                                                   
      display_string: string (osc$max_string_size),                                                           
      dual_state_data_p: ^dut$did_dual_state_data,                                                            
      edd_data_p: ^dut$did_edd_data,                                                                          
      es0_data_p: ^dut$did_edd_data,                                                                          
      ignore_status: ost$status,                                                                              
      octal_string: string (5),                                                                               
      octal_string_2: string (5),                                                                             
      output_display_opened: boolean,                                                                         
      restart_file_seq_p: ^SEQ ( * ),                                                                         
      ring_attributes: amt$ring_attributes,                                                                   
      string_length: integer,                                                                                 
      utility_p: ^dut$did_identifier_entry;                                                                   
                                                                                                              
*copy dup$abort_handler                                                                                       
?? NEWTITLE := 'clean_up', EJECT ??                                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure is called from the abort handler to close the file.                                        
                                                                                                              
    PROCEDURE [INLINE] clean_up;                                                                              
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      IF output_display_opened THEN                                                                           
        clp$close_display (display_control, ignore_status);                                                   
      IFEND;                                                                                                  
                                                                                                              
    PROCEND clean_up;                                                                                         
?? OLDTITLE ??                                                                                                
?? EJECT ??                                                                                                   
                                                                                                              
    status.normal := TRUE;                                                                                    
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    output_display_opened := FALSE;                                                                           
    osp$establish_block_exit_hndlr (^abort_handler);                                                          
                                                                                                              
   /display_opened/                                                                                           
    BEGIN                                                                                                     
                                                                                                              
      { Prepare the output display file.                                                                      
                                                                                                              
      IF pvt [p$output].specified THEN                                                                        
        ring_attributes.r1 := #RING (^ring_attributes);                                                       
        ring_attributes.r2 := #RING (^ring_attributes);                                                       
        ring_attributes.r3 := #RING (^ring_attributes);                                                       
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,     
              ring_attributes, display_control, status);                                                      
        IF NOT status.normal THEN                                                                             
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
        output_display_opened := TRUE;                                                                        
      ELSE                                                                                                    
        display_control := duv$execution_environment.output_file.display_control;                             
        display_control.line_number := display_control.page_length + 1;                                       
      IFEND;                                                                                                  
                                                                                                              
      duv$title_data.build_title := TRUE;                                                                     
      duv$title_data.command_name := pvt [p$title].value^.string_value^;                                      
                                                                                                              
      IF NOT duv$dump_environment_p^.dump_identifier.available THEN                                           
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The specified record is',       
              status);                                                                                        
        EXIT /display_opened/;  {---->                                                                        
      IFEND;                                                                                                  
                                                                                                              
      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;          
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),                          
            duv$dump_environment_p^.dump_identifier.first_byte);                                              
      RESET restart_file_seq_p TO cell_p;                                                                     
                                                                                                              
      clp$put_display (display_control, ' Dump File Information : ', clc$trim, ignore_status);                
      clp$put_display (display_control, ' ----------------------- ', clc$trim, ignore_status);                
                                                                                                              
      NEXT utility_p IN restart_file_seq_p;                                                                   
      IF utility_p = NIL THEN                                                                                 
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        EXIT /display_opened/;  {---->                                                                        
      IFEND;                                                                                                  
                                                                                                              
      IF utility_p^.value = duc$did_dual_state_dump THEN                                                      
                                                                                                              
        { Display the 'dump created' message.                                                                 
                                                                                                              
        clp$put_display (display_control, ' Dump was created by *RUN ', clc$trim, ignore_status);             
        NEXT dual_state_data_p IN restart_file_seq_p;                                                         
        IF dual_state_data_p = NIL THEN                                                                       
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
                                                                                                              
        display_memory_option (dual_state_data_p^.memory_option, display_control);                            
                                                                                                              
      ELSEIF utility_p^.value = duc$did_edd_dump THEN                                                         
                                                                                                              
        { Display the 'dump created' message.                                                                 
                                                                                                              
        clp$put_display (display_control, ' Dump was created by EDD ', clc$trim, ignore_status);              
        NEXT edd_data_p IN restart_file_seq_p;                                                                
        IF edd_data_p = NIL THEN                                                                              
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
                                                                                                              
        display_edd_revision_level (display_control);                                                         
        display_memory_option (edd_data_p^.memory_option, display_control);                                   
        display_tape_information (edd_data_p^.tape_information, display_control);                             
        display_deadstart_channel (edd_data_p^.deadstart_channel, display_control);                           
        display_extended_memory (edd_data_p^.extended_memory, display_control);                               
        display_dump_number (edd_data_p^.dump_number, display_control);                                       
        display_unload_option (edd_data_p^.unload_option, display_control);                                   
        display_dump_taken_indicator (edd_data_p^.dump_taken_indicator, display_control);                     
        display_ipi_port_number (edd_data_p^.tape_information, edd_data_p^.ipi_tape_port_number,              
              display_control);                                                                               
                                                                                                              
      ELSEIF utility_p^.value = duc$did_cy2000_dump THEN                                                      
                                                                                                              
        { Display the 'dump created' message.                                                                 
                                                                                                              
        clp$put_display (display_control, ' Dump was created by the Cyber 2000 EDD',                          
              clc$trim, ignore_status);                                                                       
        NEXT cy2000_data_p IN restart_file_seq_p;                                                             
        IF cy2000_data_p = NIL THEN                                                                           
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
                                                                                                              
        display_edd_revision_level (display_control);                                                         
        display_memory_option (cy2000_data_p^.memory_option, display_control);                                
        display_tape_information (cy2000_data_p^.tape_information, display_control);                          
        display_extended_memory (cy2000_data_p^.extended_memory, display_control);                            
        display_dump_number (cy2000_data_p^.dump_number, display_control);                                    
        display_unload_option (cy2000_data_p^.unload_option, display_control);                                
        display_ipi_port_number (cy2000_data_p^.tape_information, cy2000_data_p^.ipi_tape_port_number,        
              display_control);                                                                               
                                                                                                              
      ELSEIF utility_p^.value = duc$did_es0_dump THEN                                                         
                                                                                                              
        { Display the 'dump created' message.                                                                 
                                                                                                              
        clp$put_display (display_control, ' Dump was created by ES0 ', clc$trim, ignore_status);              
        NEXT es0_data_p IN restart_file_seq_p;                                                                
        IF es0_data_p = NIL THEN                                                                              
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
                                                                                                              
        display_edd_revision_level (display_control);                                                         
        display_memory_option (es0_data_p^.memory_option, display_control);                                   
        display_tape_information (es0_data_p^.tape_information, display_control);                             
        display_dump_number (es0_data_p^.dump_number, display_control);                                       
        display_unload_option (es0_data_p^.unload_option, display_control);                                   
        display_dump_taken_indicator (es0_data_p^.dump_taken_indicator, display_control);                     
                                                                                                              
      ELSE                                                                                                    
        clp$put_display (display_control, ' Unknown utility value.', clc$trim, ignore_status);                
      IFEND;                                                                                                  
                                                                                                              
    END /display_opened/;                                                                                     
                                                                                                              
    IF output_display_opened THEN                                                                             
      clp$close_display (display_control, ignore_status);                                                     
    IFEND;                                                                                                    
    osp$disestablish_cond_handler;                                                                            
                                                                                                              
  PROCEND dup$display_dump_info_command;                                                                      
MODEND dum$display_dump_info_command;                                                                         
*DECK DECK=DUM$DISPLAY_EI_CONTROL_BLOCK EXPAND=TRUE
PROCEDURE dum$display_ei_control_block display_ei_control_block, diseicb (
  output, o: file = $output
  status)

  VAR
    output_file: file = $fname($strrep(output)//'.$eoi')
  VAREND

  put_line l=' ----- Dual State Control Block' o=output_file
  mtt$dual_state_control_block $memory($symbol_address(mtv$nst_p), 6 monitor) o=output_file

PROCEND dum$display_ei_control_block
*DECK DECK=DUM$DISPLAY_ENTRY_STATUS_TRACE EXPAND=TRUE

PROC dum$display_entry_status_trace, display_entry_status_trace, disest (output, o: file = $output)

  crev stat status
  crev id (string 25) d=0..11
  id(00) = 'FREE                    '
  id(01) = 'TERMINATING             '
  id(02) = 'NON_SWAPPABLE           '
  id(03) = 'IN MEMORY               '
  id(04) = 'SWAPIN_IN_PROGRESS      '
  id(05) = 'SWAPPED                 '
  id(06) = 'OPERATOR_FORCE_OUT      '
  id(07) = 'SYSTEM_FORCE_OUT        '
  id(08) = 'JOB_DAMAGED             '
  id(09) = 'READY_TASK              '
  id(10) = 'SWAPIN_CANDIDATE        '
  crev in integer d=0..30 v=0
  crev out integer d=0..30 v=0
  oo = $string($value(output)) // '.$eoi'
  b = $sa(jmv$ijl_entry_status_statistics)
  FOR f = 0 TO 10 DO
    FOR t = 0 TO 10 DO
      c = $mem(b+f*11*4+t*4 4)
      IF c > 0 THEN
        in(t) = in(t)+c
        out(f) = out(f)+c
        putl ' '//id(f)//'--> '//id(t)//'  '//$strrep(c) o=$fname(oo)
      IFEND
    FOREND
  FOREND
  putl ' ' o=$fname(oo)
  putl ' ' o=$fname(oo)
  FOR i = 0 TO 10 DO
    if (in(i)>0) OR (out(i)>0) then
      ic = '          '//$strrep(in(i))
      ic = $substr(ic $strlen(ic)-7 8)
      oc = '          '//$strrep(out(i))
      oc = $substr(oc $strlen(oc)-7 8)
      if in(i)=out(i) then
        dif = '.'
      else
        dif = ', difference = '//$strrep(in(i)-out(i))
      ifend
      putl ' '//id(i)//', in= '//ic//',   out = '//oc//dif o=$fname(oo)
    ifend
  FOREND

PROCEND dum$display_entry_status_trace
*DECK DECK=DUM$DISPLAY_ENVIRONMENT_CONTROL EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Environment Control Command' ??
MODULE dum$display_environment_control;

{ PURPOSE:
{   This module contains the command which displays the environment control register are stored in the
{   ECR and EC1 records.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$display_register_data
*copyc dup$find_record_list_entry
*copyc dup$new_page_procedure
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? NEWTITLE := 'display_record_data', EJECT ??

{ PURPOSE:
{   This procedure displays data from the record.

  PROCEDURE display_record_data
    (    record_name: string (3);
         iou_index: string (1);
         entry_p: ^dut$de_other_record_entry;
     VAR display_control: clt$display_control);

    CONST
      c$number_of_bytes = 8;

    TYPE
      t$record_data = PACKED ARRAY [1 .. c$number_of_bytes] OF t$record_data_entry,

      t$record_data_entry = PACKED RECORD
        unused: 0 .. 0f(16),
        byte_part: 0 .. 0ff(16),
      RECEND;

    VAR
      cell_p: ^cell,
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      index: 0 .. 0ff(16),
      record_data_p: ^t$record_data,
      register_data: ARRAY [1 .. 8] OF 0 .. 0ff(16),
      restart_file_seq_p: ^SEQ ( * ),
      string_length: integer;

    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);
    RESET restart_file_seq_p TO cell_p;

    IF #SIZE (t$record_data) > entry_p^.size THEN
      clp$put_display (display_control, 'ERROR - Not enough data in the record, data not displayed.',
            clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;

    STRINGREP (display_string, string_length, record_name, ' - Environment Control Record:');
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    clp$put_display (display_control, ' ', clc$trim, ignore_status);
    STRINGREP (display_string, string_length, '  This record contains the pre-deadstart contents of the');
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    STRINGREP (display_string, string_length, '  Environment Control Register (IOU register 30(16)) for IOU',
          iou_index, '.');
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    clp$put_display (display_control, ' ', clc$trim, ignore_status);

    NEXT record_data_p IN restart_file_seq_p;
    FOR index := 1 TO c$number_of_bytes DO
      register_data [index] := record_data_p^ [index].byte_part;
    FOREND;

    dup$display_register_data ('environment control register', register_data, display_control);
    clp$put_display (display_control, ' ', clc$trim, ignore_status);

  PROCEND display_record_data;
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_environment_control', EJECT ??

{ PURPOSE:
{   This procedure displays the environment control information.

  PROCEDURE [XDCL] dup$display_environment_control
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_environment_control, disec (
{   output, o: file = $optional
{   title, t: string 1..31 = 'display_environment_control'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (29),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 9, 5, 13, 46, 5, 383],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TITLE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 29],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_environment_control'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$title = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      data_displayed: boolean,
      data_value: clt$data_value,
      display_control: clt$display_control,
      entry_p: ^dut$de_other_record_entry,
      ignore_status: ost$status,
      output_display_opened: boolean,
      ring_attributes: amt$ring_attributes;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

    { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      data_displayed := FALSE;

      data_value.kind := clc$name;
      data_value.name_value := 'ECR';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p <> NIL THEN
        data_displayed := TRUE;
        display_record_data ('ECR', '0', entry_p, display_control);
      IFEND;

      data_value.kind := clc$name;
      data_value.name_value := 'EC1';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p <> NIL THEN
        data_displayed := TRUE;
        display_record_data ('EC1', '1', entry_p, display_control);
      IFEND;

      IF NOT data_displayed THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The ECR and EC1 records are',
              status);
      IFEND;

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_environment_control;
MODEND dum$display_environment_control;
*DECK DECK=DUM$DISPLAY_ESM_DEFINITION_TAB EXPAND=TRUE
PROCEDURE  dum$display_esm_definition_tab, display_esm_definition_table, disesmdt, dise (
  output, o: file = $output
  status)

 " This procedure displays the file server esm definition table
 " This proc uses RJTs new dump analyzer
 " This proc assumes that dfm$monitor_process has been added.

   set_file_attributes output fc=legible pf=continuous
  out = output.$eoi
  current = $default_module
  chadm dfm$monitor_process
 IF $nil_pva($mem($sa(dfv$p_esm_definition_table)))
   putl ' NO esm defined  '  o=out
 ELSE
   p_esm_definition = $mem($sa(dfv$p_esm_definition_table))
   esm_definition = 1
   REPEAT
     putl ' ============  Esm definition === '//$strrep(esm_definition)
     dispv ?p_esm_definition.dft$esm_definition_table_entry  o=out
     FOR side_door_port = 1 to 2 DO
       IF NOT $nil_pva($pv(..
?p_esm_definition.dft$esm_definition_table_entry.p_side_door_ports[?side_door_port])) THEN
         putl ' --  Side door port '//$strrep(side_door_port) o=out
         dispv ?p_esm_definition.dft$esm_definition_table_entry.p_side_door_ports[?side_door_port]^ o=out
       IFEND
    FOREND
    IF NOT $nil_pva($pv(?p_esm_definition.dft$esm_definition_table_entry.p_element_reservation)) THEN
      dispv ?p_esm_definition.dft$esm_definition_table_entry.p_element_reservation^ o=out
    IFEND
    p_esm_definition = $pv(?p_esm_definition.dft$esm_definition_table_entry.p_next_table_entry)
    esm_definition = esm_definition + 1
   UNTIL $nil_pva(p_esm_definition)
 IFEND
 chadm current
PROCEND dum$display_esm_definition_tab
*DECK DECK=DUM$DISPLAY_ESM_ERROR EXPAND=TRUE
PROCEDURE dum$display_esm_error, display_esm_error, disesme (
  error     : integer  = $required
  output, o : file = $output
  status)

 " This procedure interrpupts the driver error code

  out = output.$eoi
 " Reference deck DFC$ESM_DRIVER_ERROR_CODES
   highest_error = 49
  create_variable name=driver_errors kind=string dimension=1..highest_error
driver_errors(1) = ' dfc$function_timeout = 1, '
driver_errors(2) = ' dfc$iou_channel_parity_error = 2, '
driver_errors(3) = ' dfc$esm_channel_parity_error = 3, '
driver_errors(4) = ' dfc$esm_double_bit_parity_error = 4, '
driver_errors(5) = ' dfc$esm_address_parity_error = 5, '
driver_errors(6) = ' dfc$esm_flag_operation_abort = 6, '
driver_errors(7) = ' dfc$adp_uncorrected_cm_error = 7, '
driver_errors(8) = ' dfc$adp_cm_reject = 8, '
driver_errors(9) = ' dfc$adp_invalid_cm_response = 9, '
driver_errors(10) = ' dfc$adp_cm_response_parity_err = 10, '
driver_errors(11) = ' dfc$adp_cmi_read_parity_err = 11, '
driver_errors(12) = ' dfc$adp_clock_fault = 12, '
driver_errors(13) = ' dfc$adp_input_buffer_overflow = 13, '
driver_errors(14) = ' dfc$adp_input_data_parity_error = 14, '
driver_errors(15) = ' dfc$adp_12_16_conversion_error = 15, '
driver_errors(16) = ' dfc$adp_jy_data_parity_error = 16, '
driver_errors(17) = ' dfc$adp_kx_pp_data_parity_error = 17, '
driver_errors(18) = ' dfc$adp_kz_board_detected_error = 18, '
driver_errors(19) = ' dfc$adp_jy_board_detected_error = 19, '
driver_errors(20) = ' dfc$adp_kx_board_detected_error = 20, '
driver_errors(21) = ' dfc$esm_address_overflow = 21, '
driver_errors(22) = ' dfc$channel_inactive_error = 22, '
driver_errors(23) = ' dfc$dma_xfer_halted_early = 23, '
driver_errors(24) = ' dfc$lsp_deadman_timeout = 24,  '
driver_errors(25) = ' dfc$unused_reserved_25 = 25,  '
driver_errors(26) = ' dfc$unused_reserved_26 = 26,  '
driver_errors(27) = ' dfc$unused_reserved_27 = 27,  '
driver_errors(28) = ' dfc$unused_reserved_28 = 28,  '
driver_errors(29) = ' dfc$unused_reserved_29 = 29,  '
driver_errors(30) = ' dfc$invalid_command_code = 30, '
driver_errors(31) = ' dfc$invalid_length_in_command = 31,  '
driver_errors(32) = ' dfc$invalid_address_in_command = 32,  '
driver_errors(33) = ' dfc$invalid_length_in_ind_list = 33, '
driver_errors(34) = ' dfc$invalid_address_in_ind_list = 34, '
driver_errors(35) = ' dfc$reserved_field_not_zero = 35, '
driver_errors(36) = ' dfc$pit_lockword_error = 36, '
driver_errors(37) = ' dfc$no_held_info_in_queue_entry = 37, '
driver_errors(38) = ' dfc$invalid_queue_index = 38, '
driver_errors(39) = ' dfc$invalid_queue_entry_index = 39, '
driver_errors(40) = ' dfc$insufficient_length_spec = 40, '
driver_errors(41) = ' dfc$driver_action_flag_not_set = 41, '
driver_errors(42) = ' dfc$destination_machine_down = 42, '
driver_errors(43) = ' dfc$queue_idle = 43, '
driver_errors(44) = ' dfc$inactive_queue_entry = 44, '
driver_errors(45) = ' dfc$invalid_driver_queue_rma = 45, '
driver_errors(46) = ' dfc$unused_reserved_46 = 46,  '
driver_errors(47) = 'dfc$unused_reserved_47 = 47, '
driver_errors(48) = ' dfc$unused_reserved_48 = 48, '
driver_errors(49) = ' dfc$unused_reserved_49 = 49; '

  IF error = 0 THEN
    putl ' NORMAL ' o=out
  ELSEIF (error  > highest_error) OR (error < 0 ) THEN
    putl '   invalid_command_code' o=out
  ELSE
    putl driver_errors(error)  o=out
  IFEND

PROCEND dum$display_esm_error
*DECK DECK=DUM$DISPLAY_EXCHANGE_PACKAGE EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Exchange Package Command' ??                                   
MODULE dum$display_exchange_package;                                                                          
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains the code for the display_exchange_package command.                                   
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc due$exception_condition_codes                                                                          
*copyc dut$condition_registers                                                                                
?? POP ??                                                                                                     
*copyc clp$close_display                                                                                      
*copyc clp$convert_integer_to_rjstring                                                                        
*copyc clp$horizontal_tab_display                                                                             
*copyc clp$new_display_line                                                                                   
*copyc clp$open_display_reference                                                                             
*copyc clp$put_display                                                                                        
*copyc dup$determine_dump_information                                                                         
*copyc dup$display_message                                                                                    
*copyc dup$evaluate_parameters                                                                                
*copyc dup$new_page_procedure                                                                                 
*copyc dup$put_item                                                                                           
*copyc dup$retrieve_exchange_package                                                                          
*copyc ocp$find_debug_address                                                                                 
*copyc osp$disestablish_cond_handler                                                                          
*copyc osp$establish_block_exit_hndlr                                                                         
*copyc osp$set_status_abnormal                                                                                
?? EJECT ??                                                                                                   
*copyc duv$dump_environment_p                                                                                 
*copyc duv$execution_environment                                                                              
*copyc duv$title_data                                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$display_exchange_package', EJECT ??                                                       
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays the exchange package to the output file.                                          
                                                                                                              
  PROCEDURE [XDCL] dup$display_exchange_package                                                               
    (    exchange_package: dut$exchange_package;                                                              
         full_display: boolean;                                                                               
     VAR display_control: clt$display_control;                                                                
     VAR status: ost$status);                                                                                 
                                                                                                              
    TYPE                                                                                                      
      t$ascii_characters = SET OF 0 .. 255;                                                                   
                                                                                                              
    VAR                                                                                                       
      blank: t$ascii_characters,                                                                              
      current_tos_register: 1 .. 0f(16),                                                                      
      display_string: string (osc$max_string_size),                                                           
      exchange_package_cell_p: ^cell,                                                                         
      found: boolean,                                                                                         
      found_blank: boolean,                                                                                   
      ignore_status: ost$status,                                                                              
      index: integer,                                                                                         
      local_status: ost$status,                                                                               
      module_name: pmt$program_name,                                                                          
      monitor_condition: ost$monitor_condition,                                                               
      monitor_conditions: ost$monitor_conditions,                                                             
      offset_in_section: ost$segment_offset,                                                                  
      section_name: pmt$program_name,                                                                         
      string_3: string (3),                                                                                   
      string_length: integer,                                                                                 
      user_condition: ost$user_condition,                                                                     
      user_conditions: ost$user_conditions,                                                                   
      xp_p: ^dut$ee_xp;                                                                                       
                                                                                                              
    status.normal := TRUE;                                                                                    
    clp$new_display_line (display_control, 1, ignore_status);                                                 
    dup$put_item ('Exchange package: ', clc$no_trim, amc$start, display_control);                             
                                                                                                              
    ocp$find_debug_address (exchange_package.p_register.pva.seg, exchange_package.p_register.pva.offset,      
          found, module_name, section_name, offset_in_section, status);                                       
    IF NOT status.normal THEN                                                                                 
      IF status.condition <> oce$e_debug_table_not_open THEN                                                  
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      status.normal := TRUE;                                                                                  
      found := FALSE;                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF found THEN                                                                                             
      blank := $t$ascii_characters[$INTEGER(' ')];                                                            
      #SCAN (blank, section_name, index, found_blank);                                                        
      STRINGREP (display_string, string_length, section_name (1, index - 1), ' +', offset_in_section: #(16),  
            '(16)');                                                                                          
      dup$put_item (display_string (1, string_length), clc$no_trim, amc$continue, display_control);           
      STRINGREP (display_string, string_length, ' in ', module_name);                                         
      dup$put_item (display_string (1, string_length), clc$trim, amc$terminate, display_control);             
    ELSE                                                                                                      
      STRINGREP (display_string, string_length, ' P = ', exchange_package.p_register.pva.ring: 2: #(16),      
            exchange_package.p_register.pva.seg: 4: #(16), exchange_package.p_register.pva.offset: 10: #(16));
      dup$put_item (display_string (1, string_length), clc$no_trim, amc$terminate, display_control);          
    IFEND;                                                                                                    
                                                                                                              
    IF exchange_package.vmid = osc$cyber_170_mode THEN                                                        
      osp$set_status_abnormal (duc$dump_analyzer_id, due$processor_in_170_mode, '', local_status);            
      dup$display_message (local_status, display_control);                                                    
    IFEND;                                                                                                    
                                                                                                              
    user_conditions := exchange_package.user_condition_register * exchange_package.user_mask;                 
    IF user_conditions <> $ost$user_conditions [ ] THEN                                                       
      dup$put_item ('user conditions:', clc$no_trim, amc$start, display_control);                             
      FOR user_condition := osc$privileged_instruction TO osc$invalid_bdp_data DO                             
        IF user_condition IN user_conditions THEN                                                             
          clp$horizontal_tab_display (display_control, 21, ignore_status);                                    
          dup$put_item (duv$cr_user_condition_reg_def [(duc$cr_user_condition_lower_bit +                     
                    $INTEGER (user_condition))], clc$trim, amc$terminate, display_control);                   
        IFEND;                                                                                                
      FOREND;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    monitor_conditions := exchange_package.monitor_condition_register * exchange_package.monitor_mask;        
    IF monitor_conditions <> $ost$monitor_conditions [ ] THEN                                                 
      dup$put_item ('monitor conditions:', clc$no_trim, amc$start, display_control);                          
      FOR monitor_condition := osc$detected_uncorrected_err TO osc$trap_exception DO                          
        IF monitor_condition IN monitor_conditions THEN                                                       
          clp$horizontal_tab_display (display_control, 21, ignore_status);                                    
          dup$put_item (duv$cr_mtr_condition_reg_def [(duc$cr_mtr_condition_lower_bit +                       
                    $INTEGER (monitor_condition))], clc$trim, amc$terminate, display_control);                
        IFEND;                                                                                                
      FOREND;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF NOT full_display THEN                                                                                  
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    exchange_package_cell_p := ^exchange_package;                                                             
    xp_p := exchange_package_cell_p;                                                                          
                                                                                                              
    { Display the P register information.                                                                     
                                                                                                              
    clp$new_display_line (display_control, 1, ignore_status);                                                 
    clp$horizontal_tab_display (display_control, 14, ignore_status);                                          
    display_string := ' ';                                                                                    
    clp$convert_integer_to_rjstring (xp_p^.p_register.two_bytes, 16, FALSE, '0', display_string (1, 4),       
          ignore_status);                                                                                     
    dup$put_item (display_string (1, 4), clc$no_trim, amc$continue, display_control);                         
    clp$horizontal_tab_display (display_control, 24, ignore_status);                                          
    STRINGREP (display_string, string_length, 'P  ', xp_p^.p_register.pva.ring: 2: #(16),                     
          xp_p^.p_register.pva.seg: 4: #(16), xp_p^.p_register.pva.offset: 10: #(16));                        
    dup$put_item (display_string (1, string_length), clc$no_trim, amc$terminate, display_control);            
                                                                                                              
    dup$display_xp_registers (xp_p^.data, display_control);                                                   
                                                                                                              
    { Display the MAX RING words.                                                                             
                                                                                                              
    dup$put_item ('max ring', clc$no_trim, amc$start, display_control);                                       
                                                                                                              
    FOR current_tos_register := 1 TO 0f(16) DO                                                                
      clp$horizontal_tab_display (display_control, 14, ignore_status);                                        
      clp$convert_integer_to_rjstring (xp_p^.tos_registers [current_tos_register].two_bytes, 16, FALSE,       
            '0', display_string (1, 4), ignore_status);                                                       
      dup$put_item (display_string (1, 4), clc$no_trim, amc$continue, display_control);                       
      STRINGREP (string_3, string_length, current_tos_register: 3);                                           
      STRINGREP (display_string, string_length, '  tos ', string_3 (2, 2));                                   
      dup$put_item (display_string (1, string_length), clc$no_trim, amc$continue, display_control);           
      clp$horizontal_tab_display (display_control, 27, ignore_status);                                        
      STRINGREP (display_string, string_length,                                                               
            xp_p^.tos_registers [current_tos_register].pva.ring: 2: #(16),                                    
            xp_p^.tos_registers [current_tos_register].pva.seg: 4: #(16),                                     
            xp_p^.tos_registers [current_tos_register].pva.offset: 10: #(16));                                
      dup$put_item (display_string (1, string_length), clc$trim, amc$terminate, display_control);             
    FOREND;                                                                                                   
                                                                                                              
  PROCEND dup$display_exchange_package;                                                                       
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$display_exchange_pkg_cmd' ??                                                              
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure processes the display_exchange_package command.                                            
                                                                                                              
  PROCEDURE [XDCL] dup$display_exchange_pkg_cmd                                                               
    (    parameter_list: clt$parameter_list;                                                                  
     VAR status: ost$status);                                                                                 
                                                                                                              
{ PROCEDURE display_exchange_package, disep (                                                                 
{   exchange, e: any of                                                                                       
{       key                                                                                                   
{         (active a) (monitor m) (job j)                                                                      
{       keyend                                                                                                
{       integer 0..0ffffffff(16)                                                                              
{     anyend = 0ffffffff(16)                                                                                  
{   processor, p: integer 0..3 = 0                                                                            
{   title, t: string 1..31 = 'display_exchange_package'                                                       
{   output, o: file = $optional                                                                               
{   status)                                                                                                   
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 9] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 5] 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 .. 6] of clt$keyword_specification,                                         
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$integer_type_qualifier,                                                              
        recend,                                                                                               
        default_value: string (13),                                                                           
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type3: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$string_type_qualifier,                                                                 
        default_value: string (26),                                                                           
      recend,                                                                                                 
      type4: record                                                                                           
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
      type5: record                                                                                           
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [90, 4, 16, 9, 44, 0, 745],                                                                               
    clc$command, 9, 5, 0, 0, 0, 0, 5, ''], [                                                                  
    ['E                              ',clc$abbreviation_entry, 1],                                            
    ['EXCHANGE                       ',clc$nominal_entry, 1],                                                 
    ['O                              ',clc$abbreviation_entry, 4],                                            
    ['OUTPUT                         ',clc$nominal_entry, 4],                                                 
    ['P                              ',clc$abbreviation_entry, 2],                                            
    ['PROCESSOR                      ',clc$nominal_entry, 2],                                                 
    ['STATUS                         ',clc$nominal_entry, 5],                                                 
    ['T                              ',clc$abbreviation_entry, 3],                                            
    ['TITLE                          ',clc$nominal_entry, 3]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [2, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 269,                        
  clc$optional_default_parameter, 0, 13],                                                                     
{ PARAMETER 2                                                                                                 
    [6, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 3                                                                                                 
    [9, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,                          
  clc$optional_default_parameter, 0, 26],                                                                     
{ PARAMETER 4                                                                                                 
    [4, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],                                                                                                       
{ PARAMETER 5                                                                                                 
    [7, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name],                                                         
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,                      
  clc$optional_parameter, 0, 0]],                                                                             
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],                                           
    FALSE, 2],                                                                                                
    229, [[1, 0, clc$keyword_type], [6], [                                                                    
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                 
      ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],                      
      ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                 
      ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 3],                      
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                 
      ['MONITOR                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]                      
      ],                                                                                                      
    20, [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]]                                                    
    ,                                                                                                         
    '0ffffffff(16)'],                                                                                         
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, 3, 10],                                                                    
    '0'],                                                                                                     
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$string_type], [1, 31, FALSE],                                                                 
    '''display_exchange_package'''],                                                                          
{ PARAMETER 4                                                                                                 
    [[1, 0, clc$file_type]],                                                                                  
{ PARAMETER 5                                                                                                 
    [[1, 0, clc$status_type]]];                                                                               
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$exchange = 1,                                                                                         
      p$processor = 2,                                                                                        
      p$title = 3,                                                                                            
      p$output = 4,                                                                                           
      p$status = 5;                                                                                           
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 5] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      default_list: ARRAY [1 .. 2] OF dut$default_change_list_entry,                                          
      display_control: clt$display_control,                                                                   
      display_string: string (osc$max_string_size),                                                           
      dump_information: dut$dump_information,                                                                 
      exchange_package_p: ^dut$exchange_package,                                                              
      ignore_status: ost$status,                                                                              
      output_display_opened: boolean,                                                                         
      processor: 0 .. duc$de_maximum_processors,                                                              
      ring_attributes: amt$ring_attributes,                                                                   
      string_length: integer;                                                                                 
                                                                                                              
*copy dup$abort_handler                                                                                       
?? NEWTITLE := 'clean_up', EJECT ??                                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure is called from the abort handler to close the file.                                        
                                                                                                              
    PROCEDURE [INLINE] clean_up;                                                                              
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      IF output_display_opened THEN                                                                           
        clp$close_display (display_control, ignore_status);                                                   
      IFEND;                                                                                                  
                                                                                                              
    PROCEND clean_up;                                                                                         
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the PROCESSOR and EXCHANGE parameters.                                     
                                                                                                              
    default_list [1].default_name := duc$dp_processor;                                                        
    default_list [1].number := p$processor;                                                                   
    default_list [2].default_name := duc$dp_exchange;                                                         
    default_list [2].number := p$exchange;                                                                    
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    processor := pvt [p$processor].value^.integer_value.value;                                                
                                                                                                              
    output_display_opened := FALSE;                                                                           
    osp$establish_block_exit_hndlr (^abort_handler);                                                          
                                                                                                              
   /display_opened/                                                                                           
    BEGIN                                                                                                     
                                                                                                              
      { Prepare the output display file.                                                                      
                                                                                                              
      IF pvt [p$output].specified THEN                                                                        
        ring_attributes.r1 := #RING (^ring_attributes);                                                       
        ring_attributes.r2 := #RING (^ring_attributes);                                                       
        ring_attributes.r3 := #RING (^ring_attributes);                                                       
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,     
              ring_attributes, display_control, status);                                                      
        IF NOT status.normal THEN                                                                             
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
        output_display_opened := TRUE;                                                                        
      ELSE                                                                                                    
        display_control := duv$execution_environment.output_file.display_control;                             
        display_control.line_number := display_control.page_length + 1;                                       
      IFEND;                                                                                                  
                                                                                                              
      duv$title_data.build_title := TRUE;                                                                     
      duv$title_data.command_name := pvt [p$title].value^.string_value^;                                      
                                                                                                              
      dup$retrieve_exchange_package (processor, pvt [p$exchange].value^, exchange_package_p, status);         
      IF NOT status.normal THEN                                                                               
        EXIT /display_opened/;  {---->                                                                        
      IFEND;                                                                                                  
                                                                                                              
      dup$determine_dump_information (dump_information);                                                      
                                                                                                              
      IF pvt [p$exchange].value^.kind = clc$keyword THEN                                                      
        IF pvt [p$exchange].value^.keyword_value = 'ACTIVE' THEN                                              
          IF ((dump_information.dump_type = duc$di_dt_cy2000) AND (duc$ee_cy_monitor_mode IN                  
                duv$execution_environment.processor_registers [processor].status_summary.cy2000)) OR          
                (duc$ee_gen_180_monitor_mode IN                                                               
                duv$execution_environment.processor_registers [processor].status_summary.general) THEN        
            clp$put_display (display_control, 'Active exchange package selected: CPU is in 180 monitor mode.',
                  clc$no_trim, ignore_status);                                                                
          ELSE                                                                                                
            clp$put_display (display_control, 'Active exchange package selected: CPU is in job mode.',        
                  clc$no_trim, ignore_status);                                                                
          IFEND;                                                                                              
        ELSEIF pvt [p$exchange].value^.keyword_value = 'MONITOR' THEN                                         
          STRINGREP (display_string, string_length, 'Exchange address = ',                                    
                duv$execution_environment.processor_registers [processor].monitor_process_state: #(16),       
                '(16)');                                                                                      
          clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);      
        ELSE  { pvt [p$exchange].value^.keyword_value = 'JOB' }                                               
          STRINGREP (display_string, string_length, 'Exchange address = ',                                    
                duv$execution_environment.processor_registers [processor].job_process_state: #(16), '(16)');  
          clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);      
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
      dup$display_exchange_package (exchange_package_p^, TRUE, display_control, status);                      
    END /display_opened/;                                                                                     
                                                                                                              
    IF output_display_opened THEN                                                                             
      clp$close_display (display_control, ignore_status);                                                     
    IFEND;                                                                                                    
    osp$disestablish_cond_handler;                                                                            
                                                                                                              
  PROCEND dup$display_exchange_pkg_cmd;                                                                       
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$display_xp_registers', EJECT ??                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays the A and X register portion of the exchange package to the output file.          
                                                                                                              
  PROCEDURE [XDCL] dup$display_xp_registers                                                                   
    (    xp_data: dut$ee_xp_data;                                                                             
     VAR display_control: clt$display_control);                                                               
                                                                                                              
    VAR                                                                                                       
      current_a_register: ost$register_number,                                                                
      current_x_register: ost$register_number,                                                                
      display_string: string (osc$max_string_size),                                                           
      ignore_status: ost$status,                                                                              
      string_3: string (3),                                                                                   
      string_length: integer,                                                                                 
      xp_labels: [READ, STATIC] ARRAY [ost$register_number] OF string (12) :=                                 
            ['vmid/uvmid', 'flags/te', 'user mask', 'monitor mask', 'ucr', 'mcr', 'kypt cl/lpid',             
             'kypt mask', 'kypt code', ' ', 'pit', ' ', 'base const', ' ', 'md flags', 'stl'],                
      x_part: 0 .. 3;                                                                                         
                                                                                                              
    { Display all of the A registers.                                                                         
                                                                                                              
    FOR current_a_register := 0 TO 0f(16) DO                                                                  
      dup$put_item (xp_labels [current_a_register], clc$no_trim, amc$start, display_control);                 
      clp$horizontal_tab_display (display_control, 14, ignore_status);                                        
      clp$convert_integer_to_rjstring (xp_data.a_regs [current_a_register].two_bytes, 16, FALSE, '0',         
            display_string (1, 4), ignore_status);                                                            
      dup$put_item (display_string (1, 4), clc$no_trim, amc$continue, display_control);                       
      clp$horizontal_tab_display (display_control, 24, ignore_status);                                        
      STRINGREP (string_3, string_length, current_a_register: 2: #(16));                                      
      STRINGREP (display_string, string_length, 'A', string_3 (2), ' ',                                       
            xp_data.a_regs [current_a_register].pva.ring: 2: #(16),                                           
            xp_data.a_regs [current_a_register].pva.seg: 4: #(16),                                            
            xp_data.a_regs [current_a_register].pva.offset: 10: #(16));                                       
      dup$put_item (display_string (1, string_length), clc$trim, amc$terminate, display_control);             
    FOREND;                                                                                                   
    clp$new_display_line (display_control, 1, ignore_status);                                                 
                                                                                                              
    { Display all of the X registers.                                                                         
                                                                                                              
    FOR current_x_register := 0 TO 0f(16) DO                                                                  
      clp$horizontal_tab_display (display_control, 11, ignore_status);                                        
      display_string := ' ';                                                                                  
      STRINGREP (display_string (1, 2), string_length, current_x_register: 2: #(16));                         
      display_string (1) := 'X';                                                                              
      FOR x_part := 0 TO 3 DO                                                                                 
        clp$convert_integer_to_rjstring (xp_data.x_regs [current_x_register].part [x_part], 16, FALSE, '0',   
              display_string (4 + x_part * 5, 4), ignore_status);                                             
      FOREND;                                                                                                 
      dup$put_item (display_string (1, 22), clc$no_trim, amc$terminate, display_control);                     
    FOREND;                                                                                                   
    clp$new_display_line (display_control, 1, ignore_status);                                                 
                                                                                                              
    { Display the MD word.                                                                                    
                                                                                                              
    dup$put_item ('md word', clc$no_trim, amc$start, display_control);                                        
    clp$horizontal_tab_display (display_control, 14, ignore_status);                                          
    display_string := ' ';                                                                                    
    FOR x_part := 0 TO 3 DO                                                                                   
      clp$convert_integer_to_rjstring (xp_data.mdw.part [x_part], 16, FALSE, '0',                             
            display_string (1 + x_part * 5, 4), ignore_status);                                               
    FOREND;                                                                                                   
    dup$put_item (display_string (1, 19), clc$no_trim, amc$terminate, display_control);                       
    clp$new_display_line (display_control, 1, ignore_status);                                                 
                                                                                                              
    { Display the STA word.                                                                                   
                                                                                                              
    dup$put_item ('sta', clc$no_trim, amc$start, display_control);                                            
    clp$horizontal_tab_display (display_control, 14, ignore_status);                                          
    clp$convert_integer_to_rjstring (xp_data.sta1.two_bytes, 16, FALSE, '0', display_string (1, 4),           
          ignore_status);                                                                                     
    dup$put_item (display_string (1, 4), clc$no_trim, amc$continue, display_control);                         
                                                                                                              
    { Display the UTP word.                                                                                   
                                                                                                              
    dup$put_item ('  utp', clc$no_trim, amc$continue, display_control);                                       
    clp$horizontal_tab_display (display_control, 27, ignore_status);                                          
    STRINGREP (display_string, string_length, xp_data.sta1.pva.ring: 2: #(16), xp_data.sta1.pva.seg: 4: #(16),
          xp_data.sta1.pva.offset: 10: #(16));                                                                
    dup$put_item (display_string (1, string_length), clc$trim, amc$terminate, display_control);               
    clp$horizontal_tab_display (display_control, 14, ignore_status);                                          
    clp$convert_integer_to_rjstring (xp_data.sta2.two_bytes, 16, FALSE, '0', display_string (1, 4),           
          ignore_status);                                                                                     
    dup$put_item (display_string (1, 4), clc$no_trim, amc$continue, display_control);                         
                                                                                                              
    { Display the TRAP word.                                                                                  
                                                                                                              
    dup$put_item ('  trap', clc$no_trim, amc$continue, display_control);                                      
    clp$horizontal_tab_display (display_control, 27, ignore_status);                                          
    STRINGREP (display_string, string_length, xp_data.sta2.pva.ring: 2: #(16), xp_data.sta2.pva.seg: 4: #(16),
          xp_data.sta2.pva.offset: 10: #(16));                                                                
    dup$put_item (display_string (1, string_length), clc$trim, amc$terminate, display_control);               
                                                                                                              
    { Display the DB IND/MASK word.                                                                           
                                                                                                              
    dup$put_item ('db ind/mask', clc$no_trim, amc$start, display_control);                                    
    clp$horizontal_tab_display (display_control, 14, ignore_status);                                          
    clp$convert_integer_to_rjstring (xp_data.debug_word.two_bytes, 16, FALSE, '0', display_string (1, 4),     
          ignore_status);                                                                                     
    dup$put_item (display_string (1, 4), clc$no_trim, amc$continue, display_control);                         
                                                                                                              
    { Display the DB LIST word.                                                                               
                                                                                                              
    dup$put_item ('  db list', clc$no_trim, amc$continue, display_control);                                   
    clp$horizontal_tab_display (display_control, 27, ignore_status);                                          
    STRINGREP (display_string, string_length, xp_data.debug_word.pva.ring: 2: #(16),                          
          xp_data.debug_word.pva.seg: 4: #(16), xp_data.debug_word.pva.offset: 10: #(16));                    
    dup$put_item (display_string (1, string_length), clc$trim, amc$terminate, display_control);               
    clp$new_display_line (display_control, 1, ignore_status);                                                 
                                                                                                              
  PROCEND dup$display_xp_registers;                                                                           
MODEND dum$display_exchange_package;                                                                          
*DECK DECK=DUM$DISPLAY_FAILURE EXPAND=TRUE
PROCEDURE dum$display_failure, display_failure, disf (
  output, o: file = output
  status: (VAR BY_NAME) status
  )

  VAR
    console_line_offset: integer
    console_line_length: integer
    cst_offset: integer
    cst_length: integer
    jps_offset: integer
    jps_length: integer
    osv$control_codes_to_quest_mark: string (256) = '???????????????????????????????? '//..
          '!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijkl'//..
          'mnopqrstuvwxyz{|}~???????????????????????????????????????????????????????????'//..
          '??????????????????????????????????????????????????????????????????????'
  VAREND

  output_file = output.$eoi

  put_line l=' ******************** FAILURE DISPLAY ********************' o=output_file

  idle_message_line = $symbol_address(mtv$idle_message_line)
  fetch_field_info t=dpt$console_line f=text o=console_line_offset l=console_line_length
  message_address = idle_message_line + console_line_offset/8
  fetch_field_info t=dpt$console_line f=text_size o=console_line_offset l=console_line_length
  message_length = $memory(idle_message_line+console_line_offset/8 console_line_length/8 monitor 0 pva)
  message = $translate(osv$control_codes_to_quest_mark, ..
        $memory_string(message_address message_length monitor 0 pva))
  put_line l='  Termination message = '//message o=output_file

  fetch_field_info t=ost$cpu_state_table f=ost$cpu_state_table o=cst_offset l=cst_length
  fetch_field_info t=ost$cpu_state_table f=xcb_rma o=jps_offset l=jps_length
  FOR index = 0 to ($memory($symbol_address(osv$cpus_logically_on) 1 monitor 0 pva)-1) DO
    jps = $memory($symbol_address(mtv$cst0)+(index*(cst_length/8))+jps_offset/8 jps_length/8 monitor 0 pva)
    put_line l='  Last task JPS (CPU '//$strrep(index)//') ='//$strrep(jps 16) o=output_file
  FOREND

  put_line l=' *********************************************************' o=output_file

PROCEND dum$display_failure
*DECK DECK=DUM$DISPLAY_FAT EXPAND=TRUE
PROCEDURE dum$display_fat, display_fat, disfat (
  sfid, s: integer = $optional
  output, o: file = $output
  help, h: file = $null
  status)


  "$FORMAT=OFF"
  VAR
    when_status: status
  VAREND
  "$FORMAT=ON"

  WHEN any_fault DO
    when_status = $previous_status
    putl ' Invoked DISFAT condition handler due to the following abnormal status:'
    disv when_status
    putl ' Enter commands, "exit_proc" to abort, or "exit_proc with when_status" to abort with status'
    include_file command prompt='disfat_ch'
  WHENEND

  IF $specified(help) THEN
COLLECT_TEXT o=help until='HELPEND'
DISPLAY_FAT or DISFAT

  This procedure will display a file allocation table and describe the
contents of selected fields of the table.  This procedure assumes the
user has previously selected the correct exchange package by available
analyze_dump commands.

PARAMETERS:

SFID, S: integer
  This parameter specifies the SFID of the file to be displayed.  This
parameter is required.

OUTPUT, O: file
  This parameter selects the file name to receive the data.  This para-
meter is defaulted to $output.  If a file name other than $output is
entered the data will be formated correctly for printer disposition and
will be sent to the file  "$asis".

STATUS

WARNINGS/KNOWN DEFICIENCIES:
 None.

ERROR HANDLER
  When any fatal error is encountered a condition handler is invoked and
the following messages will appear:
 "Invoked DISFAT condition handler due to the following abnormal status:"
 "< the error status message >"
 "Enter commands, "exit_proc" to abort, or "exit_proc with when_status"
  to abort with status"
To exit the handler enter:    "exit_proc"
To exit the handler with status, enter:   "exit_proc with when_status"

HELPEND
    EXIT_PROC
  IFEND

  IF NOT $specified(sfid) THEN
    EXIT_PROC WITH $status(false, 'US', 4, 'Parameter SFID is required')
  IFEND

  "$FORMAT=OFF"
  VAR
    output_file: file

" The following constants are found in the deck GFC$CONSTANTS.

    gfc$fde_table_base: integer = $mem($sa(gfv$fde_table_base) 8)
    gfc$fde_size: integer = $mem($sa(gfv$fde_size) 8)

    fid_index: integer = sfid/10000(16)
    fid_file_residence: integer = (sfid - fid_index*10000(16))/100(16)
    fid_file_hash: integer = $mod(sfid, 100(16))

    current_fde_entry: integer
    disk_file_descriptor_p: integer
    fat_offset: integer
    p_fat: integer
    pfau: integer
    pftr: integer
    segment: integer

" The following offsets were obtained from the output of the command Display_Symbol_Table
" for the type DMT$FILE_ALLOCATION_UNIT.

    dau_address_offset: integer = 0
    state_offset: integer = 3
    fmd_index_offset: integer = 4

    dmt$fau_states: array 0..5 of string 1..$max_name = ('dmc$fau_free', 'dmc$fau_invalid_data', ..
          'dmc$fau_invalid_and_flawed', 'dmc$fau_initialized', 'dmc$fau_initialized_and_flawed', ..
          'dmc$fau_initialization_in_prog')

" The following offsets were obtained from the output of the command Display_Symbol_Table
" for the type DMT$DISK_FILE_DESCRIPTOR.

    p_fat_offset: integer = 0a(16)
    fat_upper_bound_offset: integer = 10(16)
    bytes_per_lev_2_offset: integer = 19(16)
    bytes_per_alloc_offset: integer = 7(16)

" The following offset was obtained from the output of the command Display_Symbol_Table
" for the type GFT$FILE_DESCRIPTOR_ENTRY.

    disk_file_descriptor_p_offset: integer = 60(16)
  VAREND
  "$FORMAT=ON"

  IF $file(output open_position) = '$BOI' THEN
    output_file = output.$asis
  ELSE
    output_file = output
  IFEND

"IF output = :$local.$output THEN
  put_line '1FILE ALLOCATION TABLE  SFID = '//$strrep(sfid, 16)//'(16)' o=output_file
"IFEND

  putl '  ' o=output_file

"Find the FDE so that info about the FAT can be found."

  IF fid_file_residence <> 1 THEN
    pftr = 300000000(16) "Use job tables (in job fixed)"
    segment = 300000000(16)
  ELSE
    pftr = 100000000(16) "Use system tables (in mainframe wired)"
    segment = 100000000(16)
  IFEND
  pftr = pftr + gfc$fde_table_base

  current_fde_entry = pftr + (fid_index * gfc$fde_size)
  disk_file_descriptor_p = $memory(current_fde_entry+disk_file_descriptor_p_offset, 4) + segment

" Now capture the FAT INFO."

  p_fat = $mem(disk_file_descriptor_p+p_fat_offset, 6)
  fat_upper_bound = $mem(disk_file_descriptor_p+fat_upper_bound_offset, 2)
  bytes_per_level_2 = $mem(disk_file_descriptor_p+bytes_per_lev_2_offset, 6)
  bytes_per_allocation = $mem(disk_file_descriptor_p+bytes_per_alloc_offset, 3)
  level_2_upperbound = bytes_per_level_2 / bytes_per_allocation - 1

" Now display the FAT."

  FOR i = 0 TO fat_upper_bound DO
    fat_offset = $mem(p_fat, 6)
    putl ' '//$strrep(i, 16)//' Offset = '//$strrep(i*bytes_per_level_2, 16)//'(16)' output=output_file
    putl '  fat offset = '//$strrep(fat_offset, 16)//'(16)' output=output_file
    IF fat_offset <> 0 THEN
      pfau = fat_offset + segment
      p_fat = p_fat + 6
      FOR j = 0 TO level_2_upperbound DO
        putl '   dau address = '//$strrep($mem(pfau+dau_address_offset, 3), 16)//'(16)' output=output_file
        putl '     fau_state = '//dmt$fau_states($mem(pfau+state_offset, 1)) o=output_file
        putl '     fad index = '//$strrep($mem(pfau+fmd_index_offset, 1), 16)//'(16)' output=output_file
        pfau = pfau + 5
      FOREND
    IFEND
  FOREND

PROCEND dum$display_fat
*DECK DECK=DUM$DISPLAY_FAULT_STATUS_MASK EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Fault Status Mask Command' ??
MODULE dum$display_fault_status_mask;

{ PURPOSE:
{   This module contains the command which displays the fault status mask that are stored in the
{   FSM and FS1 records.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$display_register_data
*copyc dup$find_record_list_entry
*copyc dup$new_page_procedure
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? NEWTITLE := 'display_record_data', EJECT ??

{ PURPOSE:
{   This procedure displays data from the record.

  PROCEDURE display_record_data
    (    record_name: string (3);
         iou_index: string (1);
         entry_p: ^dut$de_other_record_entry;
     VAR display_control: clt$display_control);

    CONST
      c$number_of_bytes = 8;

    TYPE
      t$record_data = PACKED ARRAY [1 .. c$number_of_bytes] OF t$record_data_entry,

      t$record_data_entry = PACKED RECORD
        unused: 0 .. 0f(16),
        byte_part: 0 .. 0ff(16),
      RECEND;

    VAR
      cell_p: ^cell,
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      index: 0 .. 0ff(16),
      record_data_p: ^t$record_data,
      register_data: ARRAY [1 .. 8] OF 0 .. 0ff(16),
      restart_file_seq_p: ^SEQ ( * ),
      string_length: integer;

    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);
    RESET restart_file_seq_p TO cell_p;

    IF #SIZE (t$record_data) > entry_p^.size THEN
      clp$put_display (display_control, 'ERROR - Not enough data in the record, data not displayed.',
            clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;

    STRINGREP (display_string, string_length, record_name, ' - Fault Status Mask Record:');
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    clp$put_display (display_control, ' ', clc$trim, ignore_status);
    STRINGREP (display_string, string_length, '  This record contains the pre-deadstart contents');
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    STRINGREP (display_string, string_length, '  of the Fault Status Mask Register for IOU', iou_index, '.');
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    clp$put_display (display_control, ' ', clc$trim, ignore_status);

    NEXT record_data_p IN restart_file_seq_p;
    FOR index := 1 TO c$number_of_bytes DO
      register_data [index] := record_data_p^ [index].byte_part;
    FOREND;

    dup$display_register_data ('fault status mask', register_data, display_control);
    clp$put_display (display_control, ' ', clc$trim, ignore_status);

  PROCEND display_record_data;
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_fault_status_mask', EJECT ??

{ PURPOSE:
{   This procedure displays the fault status mask information.

  PROCEDURE [XDCL] dup$display_fault_status_mask
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_fault_status_mask, disfsm (
{   output, o: file = $optional
{   title, t: string 1..31 = 'display_fault_status_mask'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (27),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 9, 5, 13, 5, 58, 282],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TITLE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 27],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_fault_status_mask'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$title = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      data_displayed: boolean,
      data_value: clt$data_value,
      display_control: clt$display_control,
      entry_p: ^dut$de_other_record_entry,
      ignore_status: ost$status,
      output_display_opened: boolean,
      ring_attributes: amt$ring_attributes;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

    { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      data_displayed := FALSE;

      data_value.kind := clc$name;
      data_value.name_value := 'FSM';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p <> NIL THEN
        data_displayed := TRUE;
        display_record_data ('FSM', '0', entry_p, display_control);
      IFEND;

      data_value.kind := clc$name;
      data_value.name_value := 'FS1';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p <> NIL THEN
        data_displayed := TRUE;
        display_record_data ('FS1', '1', entry_p, display_control);
      IFEND;

      IF NOT data_displayed THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The FSM and FS1 records are',
              status);
      IFEND;

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_fault_status_mask;
MODEND dum$display_fault_status_mask;
*DECK DECK=DUM$DISPLAY_FAUS EXPAND=TRUE
PROCEDURE dum$display_faus, display_faus, display_fau, disfau (
  address, a: integer = 30000c900(16)
  table_length, tl: integer 0..100000 = 200
  lower_bound, lb: integer 0..100000 = 1
  element_length, el: integer 0..100 = 4
  output, o: file = $output
  status)

  addr = $value(address)
  array_start = addr + 18
  next_addr = $mem(addr, 6)
  next_tl = $mem(addr+6, 4)
  next_lb = $mem(addr+10, 4)
  next_el = $mem(addr+14, 4)
  crev state k=string d=0..5
  state(0) = '  state = fau free'
  state(1) = '  state = invalid'
  state(2) = '  state = invalid and flawed'
  state(3) = '  state = initialized'
  state(4) = '  state = initialized and flawed'
  state(5) = '  state = initialization in progress'
  fau_num = $value(lower_bound)
  num_entries = $value(table_length) / $value(element_length)

  IF $file($value(output) open_position) = '$BOI' THEN
    outfile = $string($value(output))//'.$asis'
  ELSE
    outfile = $string($value(output))
  IFEND

  outline = '   NEXT FAUS = '//..
$strrep(next_addr, 16)//' '//$strrep(next_tl, 16)//' '//$strrep(next_lb, 16)// ' '//$strrep(next_el, 16)

  put_line outline o=$fname(outfile)

  FOR i = 0 TO (num_entries - 1) DO
    outline = '  '//$strrep(fau_num)//'.  '
    fau_num = fau_num + 1
    dau = $mem(array_start+(i*4), 3)
    outline = outline//$strrep(dau, 16)//'(16)'
    outline = outline//state($mem(array_start+(i*4)+3, 1))

    put_line outline o=$fname(outfile)

  FOREND

  IF NOT $nil_pva(next_addr) THEN
    display_faus next_addr next_tl next_lb next_el o=$fname(outfile)
  IFEND

PROCEND dum$display_faus
*DECK DECK=DUM$DISPLAY_FDE EXPAND=TRUE
PROCEDURE dum$display_fde, display_fde, disfde (
  address, a: integer 0..$max_integer = $optional
  output, o: file = $output
  display_option, do: key
      (brief, b), (full, f)
    keyend = brief
  help, h: file = $null
  status)


  "$FORMAT=OFF"
  VAR
    when_status: status
  VAREND
  "$FORMAT=ON"

  WHEN any_fault DO
    when_status = $previous_status
    putl ' Invoked DISFDE condition handler due to the following abnormal status:'
    disv when_status
    putl ' Enter commands, "exit_proc" to abort, or "exit_proc with when_status" to abort with status'
    include_file command prompt='disfde_ch'
  WHENEND

  IF $specified(help) THEN
COLLECT_TEXT o=help until='HELPEND'
DISPLAY_FDE or DISFDE

  This procedure will display the file descriptor entry at the addres passed
to it.  This procedure assumes the user has previously selected the correct
exchange package by available analyze_dump commands.

PARAMETERS:

ADDRESS, A: integer
  This parameter specifies the FDE of the file to be displayed.  This
parameter is required.

OUTPUT, O: file
  This parameter selects the file name to receive the data.  This para-
meter is defaulted to $output.  If a file name other than $output is
entered the data will be formated correctly for printer disposition and
will be sent to the file  "$asis".

DISPLAY_OPTIONS, DO: key full, f, brief, b
  This parameter selects the option of displaying the contents of memory
and the description of the selected fields (full), or the brief mode of
the descriptions only.  This parameter defaults to brief.

STATUS

WARNINGS/KNOWN DEFICIENCIES:

ERROR HANDLER
  When any fatal error is encountered a condition handler is invoked and
the following messages will appear:
 "Invoked DISFDE condition handler due to the following abnormal status:"
 "< the error status message >"
 "Enter commands, "exit_proc" to abort, or "exit_proc with when_status"
  to abort with status"
To exit the handler enter:    "exit_proc"
To exit the handler with status, enter:   "exit_proc with when_status"

HELPEND
    EXIT_PROC
  IFEND

  IF NOT $specified(address) THEN
    EXIT_PROC WITH $status(false, 'US', 7, 'Parameter ADDRESS is required')
  IFEND

  "$FORMAT=OFF"
  VAR
    media: string
    output_file: file
  VAREND

  IF $file(output open_position) = '$BOI' THEN
    output_file = output.$asis
  ELSE
    output_file = output
  IFEND

  "$FORMAT=OFF"
  VAR
    gfc$fde_size: integer = $mem($sa(gfv$fde_size) 8)
    gfc$fde_table_base: integer = $mem($sa(gfv$fde_table_base) 8)
    current_fde_entry: integer
  VAREND
  "$FORMAT=ON"

  current_fde_entry = address

  "$FORMAT=OFF
  VAR
" The following offsets were obtained from the output of the command Display_Symbol_Table
" for the type GFT$FILE_DESCRIPTOR_ENTRY.

    job_lock_offset: integer = 0(16)
      locked_offset: integer = 0(16)
      count_offset: integer = 1(16)
      gtid_offset: integer = 2(16)
      p_register_offset: integer = 5(16)
      p_register_2_offset: integer = 0d(16)

    monitor_lock_offset: integer = 15(16)
    gft$fde_flags: array 0..7 of string 1..$max_name = ('eoi_modified' 'wire_eoi_page' 'active_file' ..
          'global_template_file' 'fde_spare_4' 'fde_spare_5' 'fde_spare_6' 'fde_spare_7')
    fde_flag_offset: integer = 16(16)
    global_name_offset: integer = 17(16)
    file_hash_thread_offset: integer = 22(16)
    attached_in_write_count_offset: integer = 28(16)
    attach_count_offset: integer = 2a(16)
    open_count_offset: integer = 2c(16)
    gft$file_kind: array 0..8 of string 1..$max_name = ('gfc$fk_job_permanent_file' 'gfc$fk_device_file' ..
          'gfc$fk_save_2' 'gfc$fk_save_3' 'gfc$fk_catalog' ..
          'gfc$fk_job_local_file' 'gfc$fk_unnamed_file' 'gfc$fk_global_unnamed' 'gfc$fk_monitor_only_unnamed')
    file_kind_offset: integer = 30(16)
    file_hash_offset: integer = 31(16)
    segment_lock_offset: integer = 32(16)
      locked_for_read_offset: integer = 0(16)
      locked_for_write_offset: integer = 4(16)
      task_queue_offset: integer = 5(16)
        task_queue_head_offset: integer = 0(16)
        task_queue_tail_offset: integer = 2(16)
    asti_offset: integer = 3b(16)
    eoi_byte_address_offset: integer = 3d(16)
    mmt$eoi_state: array 0..2 of string 1..$max_name = ('mmc$eoi_actual' 'mmc$eoi_rounded' 'mmc$eoi_uncertain')
    eoi_state_offset: integer = 43(16)
    allocation_unit_size_offset: integer = 44(16)
    transfer_unit_size_offset: integer = 47(16)
    file_limit_offset: integer = 4a(16)
    gft$queue_status: array 0..2 of string 1..$max_name = ('gfc$global_shared' 'gfc$job_shared' 'gfc$qs_job_working_set')
    queue_status_offset: integer = 50(16)
    pmt$initialization_value: array 0..3 of string 1..$max_name = ('pmc$initialize_to_zero', ..
          'pmc$initialize_to_alt_ones' 'pmc$initialize_to_indefinite' 'pmc$initialize_to_infinity')
    preset_value_offset: integer = 51(16)
    time_last_modified_offset: integer = 52(16)
    last_segment_number_offset: integer = 58(16)
    global_task_id_offset: integer = 5a(16)
    stack_for_ring_offset: integer = 5d(16)
    gft$file_media: array 0..2 of string 1..$max_name = ('gfc$fm_transient_segment' 'gfc$fm_mass_storage_file' ..
          'gfc$fm_served_file')
    file_media_offset: integer = 5e(16)
    disk_file_descriptor_p_offset: integer = 5f(16)
  VAREND
  "$FORMAT=ON"

  IF output = :$local.$output THEN
    put_line '1FILE DESCRIPTOR ENTRY   address = '//$strrep(address, 16)//'(16)' o=output_file
  IFEND

  IF display_option = 'FULL' THEN
    display_memory current_fde_entry b=gfc$fde_size title='FILE_DESCRIPTOR_ENTRY' o=output_file
  IFEND

  put_line ' job_lock:' o=output_file
  put_line '   locked = '//$strrep($memory(current_fde_entry+job_lock_offset+locked_offset, 1) 16)//'(16)' ..
        o=output_file
  put_line '   count = '//$strrep($memory(current_fde_entry+job_lock_offset+count_offset, 1) 16)//'(16)' ..
        o=output_file
  put_line '   gtid = '//$strrep($memory(current_fde_entry+job_lock_offset+gtid_offset, 3) 16)//'(16)' ..
        o=output_file
  put_line '   p_register = '//$strrep($memory(current_fde_entry+job_lock_offset+p_register_offset, 8) 16)//'(16)' ..
        o=output_file
  put_line '   p_register_2 = '//$strrep($memory(current_fde_entry+job_lock_offset+p_register_2_offset, 8) 16)//'(16)' ..
        o=output_file

  monitor_lock_integer = $memory(current_fde_entry+monitor_lock_offset, 1)
  put_line ' monitor_lock {byte variant} = '//$strrep(monitor_lock_integer) o=output_file
  IF $mod(monitor_lock_integer 2) = 1 THEN
    put_line '              {lock variant}: locked = TRUE' o=output_file
  ELSE
    put_line '              {lock variant}: locked = FALSE' o=output_file
  IFEND
  put_line '              {lock variant}: id = '//$strrep(monitor_lock_integer/2) o=output_file

  line = ''
  fde_flags = $memory(current_fde_entry+fde_flag_offset, 1)
  FOR i = 56 TO 63 DO
    IF $bit(fde_flags i) THEN
      line = line // gft$fde_flags(i - 56) // ' '
    IFEND
  FOREND
  put_line ' FDE_flags = ('//line//')' o=output_file

  display_binary_unique_name pva=current_fde_entry+global_name_offset o=output ..
        cs=' global_file_name = '

  put_line ..
        ' file_hash_thread = '//$strrep($memory(current_fde_entry+file_hash_thread_offset, 6), 16)//'(16)' ..
        o=output_file

  put_line ' attached_in_write_count = '//..
$strrep($memory(current_fde_entry+attached_in_write_count_offset, 2) 16)//'(16)' o=output_file

  put_line ' attach_count = '//$strrep($memory(current_fde_entry+attach_count_offset, 2) 16)//'(16)' ..
        o=output_file

  put_line ' open_count = '//$strrep($memory(current_fde_entry+open_count_offset, 4), 16)//'(16)' ..
        o=output_file

  put_line ' file_kind = '//gft$file_kind($memory(current_fde_entry+file_kind_offset, 1)) ..
        o=output_file

  put_line ' file_hash = '//$strrep($memory(current_fde_entry+file_hash_offset, 1) 16)//'(16)' ..
        o=output_file

  put_line ' segment_lock:' o=output_file
  put_line '   locked_for_read = '//..
$strrep($memory(current_fde_entry+segment_lock_offset+locked_for_read_offset, 4) 16)//'(16)' ..
        o=output_file
  IF $memory(current_fde_entry+segment_lock_offset+locked_for_write_offset, 1) = 1 THEN
    put_line '   locked_for_write = TRUE' o=output_file
  ELSE
    put_line '   locked_for_write = FALSE' o=output_file
  IFEND
  put_line '   task_queue:' o=output_file
  put_line '     head = '//..
$strrep($memory(current_fde_entry+segment_lock_offset+task_queue_offset+task_queue_head_offset, 2) 16)//..
'(16)' o=output_file
  put_line '     tail = '//..
$strrep($memory(current_fde_entry+segment_lock_offset+task_queue_offset+task_queue_tail_offset, 2) 16)//..
'(16)' o=output_file

  put_line ' asti = '//$strrep($memory(current_fde_entry+asti_offset, 2), 16)//'(16)' o=output_file

  put_line ..
        ' eoi_byte_address = '//$strrep($memory(current_fde_entry+eoi_byte_address_offset, 4), 16)//'(16)' ..
        o=output_file

  put_line ' eoi_state = '//mmt$eoi_state($memory(current_fde_entry+eoi_state_offset, 1)) ..
        o=output_file

  put_line ' allocation_unit_size = '//..
$strrep($memory(current_fde_entry+allocation_unit_size_offset, 3), 16)//'(16)' o=output_file

  put_line ' transfer_unit_size = '//..
$strrep($memory(current_fde_entry+transfer_unit_size_offset, 3), 16)//'(16)' o=output_file

  put_line ' file_limit = '//$strrep($memory(current_fde_entry+file_limit_offset, 6), 16)//'(16)' ..
        o=output_file

  put_line ' queue_status = '//gft$queue_status($memory(current_fde_entry+queue_status_offset, 1)) ..
        o=output_file

  put_line ' preset_value = '//pmt$initialization_value($memory(current_fde_entry+preset_value_offset, 1)) ..
        o=output_file

  put_line ' time_last_modified = '//..
$strrep($memory(current_fde_entry+time_last_modified_offset, 6), 16)//'(16)' o=output_file

  put_line ' last_segment_number = '//..
$strrep($memory(current_fde_entry+last_segment_number_offset, 2), 16)//'(16)' o=output_file

  put_line ' global_task_id = '//$strrep($memory(current_fde_entry+global_task_id_offset, 3), 16)//'(16)' ..
        o=output_file

  put_line ' stack_for_ring = '//$strrep($memory(current_fde_entry+stack_for_ring_offset, 1), 16)//'(16)' ..
        o=output_file

  media = gft$file_media($memory(current_fde_entry+file_media_offset, 1))
  put_line ' media = '//media o=output_file
  IF media = 'gfc$fm_mass_storage_file' THEN
    put_line ' disk_file_descriptor_p {relative offset} = '//..
$strrep($memory(current_fde_entry+disk_file_descriptor_p_offset, 4), 16)//'(16)' o=output_file
  ELSEIF media = 'gfc$fm_served_file' THEN
    put_line ' served_file_descriptor_p {relative offset} = '//..
$strrep($memory(current_fde_entry+disk_file_descriptor_p_offset, 4), 16)//'(16)' o=output_file
  IFEND

  sfid = ($mod(current_fde_entry 100000000(16)) - gfc$fde_table_base) / gfc$fde_size * 10000(16)
  IF (current_fde_entry / 100000000(16)) <> 1 THEN
    sfid = sfid + 200(16)
  ELSE
    sfid = sfid + 100(16)
  IFEND
  sfid = sfid + $memory(current_fde_entry+file_hash_offset, 1)
  putl ' Computed SFID for entry = '//$strrep(sfid 16)//'(16) {may not be valid}' o=output_file

PROCEND dum$display_fde
*DECK DECK=DUM$DISPLAY_FDE_TABLE EXPAND=TRUE
PROCEDURE dum$display_fde_table, display_fde_table, disfdet (
  address, a: integer 0..$max_integer = $optional
  residence, r: key
      (system, s), (job, j)
    keyend = $optional
  display_option, do: key
      (brief, b), (full, f)
    keyend = brief
  output, o: file = $output
  help, h: file = $null
  status)


  "$FORMAT=OFF"
  VAR
    when_status: status
  VAREND
  "$FORMAT=ON"

  WHEN any_fault DO
    when_status = $previous_status
    putl ' Invoked DISFDET condition handler due to the following abnormal status:'
    disv when_status
    putl ' Enter commands, "exit_proc" to abort, or "exit_proc with when_status" to abort with status'
    include_file command prompt='disfdet_ch'
  WHENEND

  IF $specified(help) THEN
COLLECT_TEXT o=help until='HELPEND'
DISPLAY_FDET or DISFDET

  This procedure will display the file descriptor entry at the addres passed
to it.  This procedure assumes the user has previously selected the correct
exchange package by available analyze_dump commands.

PARAMETERS:

ADDRESS, A: integer
  This parameter specifies the address of the FDE table to be displayed.
Either this parameter, or the following parameter must be specified.

RESIDENCE, r: key system
  This parameter specifies the residence of the FDE table to be displayed.
If SYSTEM is specified, the FDE table in mainframe wired will be displayed;
if JOB is specified, the FDE table in job-fixed will be displayed.
Either this parameter, or the preceding parameter must be specified.

OUTPUT, O: file
  This parameter selects the file name to receive the data.  This para-
meter is defaulted to $output.  If a file name other than $output is
entered the data will be formated correctly for printer disposition and
will be sent to the file  "$asis".

DISPLAY_OPTIONS, DO: key full, f, brief, b
  This parameter selects the option of displaying the contents of memory
and the description of the selected fields (full), or the brief mode of
the descriptions only.  This parameter defaults to brief.

STATUS

WARNINGS/KNOWN DEFICIENCIES:

ERROR HANDLER
  When any fatal error is encountered a condition handler is invoked and
the following messages will appear:
 "Invoked DISXXX condition handler due to the following abnormal status:"
 "< the error status message >"
 "Enter commands, "exit_proc" to abort, or "exit_proc with when_status"
  to abort with status"
To exit the handler enter:    "exit_proc"
To exit the handler with status, enter:   "exit_proc with when_status"
NOTE: XXX is the name of the procedure in effect at the time of the error.

HELPEND
    EXIT_PROC
  IFEND

  IF (NOT $specified(address)) AND (NOT $specified(residence)) THEN
    EXIT_PROC WITH $status(false, 'US', 0, 'Must specify either address or residence')
  ELSEIF $specified(address) AND $specified(residence) THEN
    EXIT_PROC WITH $status(false, 'US', 0, 'Cannot specify both address and residence')
  IFEND

  "$FORMAT=OFF"
  VAR
    output_file: file
  VAREND

  IF $file(output open_position) = '$BOI' THEN
    output_file = output.$asis
  ELSE
    output_file = output
  IFEND

  "$FORMAT=OFF"
  VAR
    gfc$fde_size: integer = $mem($sa(gfv$fde_size) 8)
    gfc$fde_table_base: integer = $mem($sa(gfv$fde_table_base) 8)
    gfc$max_file_descriptor_index: integer = 0ffff(16) "maximum value of gft$file_descriptor_index"
    current_fde_entry: integer
    fde_index: integer = 0
    local_status: status
  VAREND
  "$FORMAT=ON"

  IF $specified(residence) THEN
    IF residence = 'SYSTEM' THEN
      putl ' SYSTEM FILE TABLE ' o=output_file
      current_fde_entry = 100000000(16) + gfc$fde_table_base
    ELSE
      putl ' JOB - SYSTEM FILE TABLE ' o=output_file
      current_fde_entry = 300000000(16) + gfc$fde_table_base
    IFEND
  ELSE
    current_fde_entry = address
  IFEND

  local_status.normal = true
  put_line ' FILE DESCRIPTOR TABLE: address = '//$strrep(current_fde_entry, 16)//'(16)' o=output_file
  FOR fde_index = 0 TO gfc$max_file_descriptor_index DO
    putl ' ' o=output_file
    putl ' ' o=output_file
    putl ' FDE index '//$strrep(fde_index 16)//'(16)' o=output_file
    putl ' FDE contents follows:' o=output_file
    display_fde current_fde_entry+gfc$fde_size*fde_index output=output display_option=display_option ..
          status=local_status
    IF NOT local_status.normal THEN
      disv local_status o=output_file
      putl ' Display_FDE_Table encountered abnormal status in the call to Display_FDE:'
      disv local_status
      putl ' Enter commands, "exit_proc" to abort, or "exit_proc with local_status" to abort with status'
      include_file command prompt='disfdte_ch'
    IFEND
  FOREND

PROCEND dum$display_fde_table
*DECK DECK=DUM$DISPLAY_FILE_ATT EXPAND=TRUE
PROCEDURE dum$display_file_att, display_file_att (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, sva, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable output_line k=string v=' '
  create_variable log_address v=$value(address)
  create_variable indent k=(string, 5) v='     '
  log_address = log_address + 1

  display_binary_unique_name log_address o=$fname(output_file) cs=indent//'gfn=' am=$value(am)
  output_line = indent//'dfl='//$strrep($mem(log_address+11, 3, j, 0, $value(am)), 16)
  output_line = output_line//' mf_asignd='//$strrep($mem(log_address+14, 5, j, 0, $value(am)), 16)

  putl output_line o=$fname(output_file)

PROCEND dum$display_file_att
*DECK DECK=DUM$DISPLAY_FILE_DAMAGED EXPAND=TRUE
PROCEDURE dum$display_file_damaged, display_file_damaged (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, sva, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable output_line k=string v=' '
  create_variable log_address v=$value(address)
  create_variable indent k=(string, 5) v=' '
  log_address = log_address + 1
  create_variable null_set k=boolean
  create_variable dmt$file_damage_types k=string d=0..15
  dmt$file_damage_types(15) = 'dmc$file_damage_15'
  dmt$file_damage_types(14) = 'dmc$file_damage_14'
  dmt$file_damage_types(13) = 'dmc$file_damage_13'
  dmt$file_damage_types(12) = 'dmc$file_damage_12'
  dmt$file_damage_types(11) = 'dmc$file_damage_11'
  dmt$file_damage_types(10) = 'dmc$file_damage_10'
  dmt$file_damage_types(9) = 'dmc$file_damage_9'
  dmt$file_damage_types(8) = 'dmc$file_damage_8'
  dmt$file_damage_types(7) = 'dmc$file_damage_7'
  dmt$file_damage_types(6) = 'dmc$file_damage_6'
  dmt$file_damage_types(5) = 'dmc$file_damage_5'
  dmt$file_damage_types(4) = 'dmc$file_damage_4'
  dmt$file_damage_types(3) = 'dmc$file_damage_3'
  dmt$file_damage_types(2) = 'dmc$media_image_inconsistent'
  dmt$file_damage_types(1) = 'dmc$allocation_chain_brocken'
  dmt$file_damage_types(0) = 'dmc$eoi_modified_by_recovery'

  display_binary_unique_name log_address o=$fname(output_file) cs=indent//'    gfn=' am=$value(am)
  output_line = indent//'    dfl='//$strrep($mem(log_address+11, 3,,, $value(am)), 16)//'(16)'
  putl output_line o=$fname(output_file)

  null_set = true
  damage_set = $mem(log_address+14, 2,,, $value(am))
  FOR i = 0 TO 15 DO
    IF damage_set <> (damage_set/ 2 * 2) THEN
      output_line = indent//'    add damage = '//dmt$file_damage_types(15-i)
      putl output_line o=$fname(output_file)
      null_set = false
    IFEND
    damage_set = damage_set/2
  FOREND

  IF null_set THEN
    output_line = indent//'    add damage = null set'
    putl output_line o=$fname(output_file)
  IFEND

  null_set = true
  damage_set = $mem(log_address+16, 2,,, $value(am))
  FOR i = 0 TO 15 DO
    IF damage_set <> (damage_set/ 2 * 2) THEN
      output_line = indent//'    remove damage = '//dmt$file_damage_types(15-i)
      putl output_line o=$fname(output_file)
      null_set = false
    IFEND
    damage_set = damage_set/2
  FOREND

  IF null_set THEN
    output_line = indent//'    remove damage = null set'
    putl output_line o=$fname(output_file)
  IFEND

PROCEND dum$display_file_damaged
*DECK DECK=DUM$DISPLAY_FILE_DET EXPAND=TRUE
PROCEDURE dum$display_file_det, display_file_det (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, sva, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable output_line k=string v=' '
  create_variable log_address v=$value(address)
  create_variable indent k=(string, 5) v='     '
  log_address = log_address + 1

  display_binary_unique_name log_address o=$fname(output_file) cs=indent//'gfn=' am=$value(am)
  output_line = indent//'dfl='//$strrep($mem(log_address+11, 3, j, 0, $value(am)), 16)
  output_line = output_line//' mf_asignd='//$strrep($mem(log_address+14, 5, j, 0, $value(am)), 16)

  putl output_line o=$fname(output_file)

PROCEND dum$display_file_det
*DECK DECK=DUM$DISPLAY_FILE_MANAGER EXPAND=TRUE
*copy osd$default_pragmats
?? NEWTITLE := 'Display File Manager' ??
MODULE dum$display_file_manager;
{ PURPOSE: Provide common processing procedures that are used for symbolic
{          output.
{
{ DESIGN:  The value of the parameter file is interrogated. If it is not
{          different from the global file, the global display file is used.

?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc clp$close_display
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc pmp$get_legible_date_time
*copyc pmp$get_os_version
?? POP ??
?? TITLE := '  Global Definitions', EJECT ??
  CONST
    long_date_start = 91,
    long_header_length = 132,
    long_os_version_start = 33,
    long_page_number_start = 128, {includes leading blank}
    long_page_title_start = 123,
    long_time_start = 110,
    long_product_name_start = 56,
    os_version_length = 22,
    page_number_length = 5, {includes leading blank}
    short_product_name_start = 34,
    short_base_name_start = 41,
    short_base_title_start = 34,
    short_date_start = 2,
    short_header_length = 72,
    short_os_version_start = 9,
    short_page_number_start = 63, {includes leading blank}
    short_page_title_start = 58,
    short_time_start = 49;

  CONST
    db_product_name = 'DEBUG',
    db_product_name_length = 5,
    db_version = '1.5 ',
    db_version_length = 4,
    db_level_length = 5;

  VAR
    default_file_display_control: clt$display_control,
    default_file_open: boolean := FALSE,
    default_output_file: [READ] ost$name := clc$standard_output,
    v$level: string (db_level_length) := '*RJT*';

  CONST
    max_string_size = 65535,
    smallest_graphic = ' ',
    largest_graphic = '~',
    max_set_element = 32767,
    value_spacer = 2,
    record_indent = 2,
    first_character = 0,
    last_character = 255,
    true_value = 1,
    false_value = 0,
    bytes_per_word = 8,
    bits_per_byte = 8;

  TYPE
    value_record = record
      case boolean of
      = TRUE =
        bits: packed array [0 .. 63] of boolean,
      = FALSE =
        word_sized_value: integer,
      casend,
    recend;

?? TITLE := '  dup$close_display', EJECT ??
*copyc duh$close_display

  PROCEDURE [XDCL] dup$close_display (VAR display_control_pointer: ^clt$display_control;
        close_default_file: boolean;
    VAR status: ost$status);

{ This procedure flushes any partial line.  It will close the default output
{ file only if the boolean close_default_file is true. Otherwise, it
{ closes the file if its FID is not the same as that of the default output
{ file. All bad statuses are ignored.

    IF display_control_pointer^.data_in_line = TRUE THEN
      clp$put_partial_display (display_control_pointer^, '', clc$trim,
            amc$terminate, status);
      status.normal := TRUE;
    IFEND;
    IF close_default_file THEN
      clp$close_display (default_file_display_control, status);
      default_file_open := FALSE;
    ELSE
      IF display_control_pointer^.file_id <> default_file_display_control.
            file_id THEN
        clp$close_display (display_control_pointer^, status);
      IFEND;
    IFEND;
    status.normal := TRUE;

  PROCEND dup$close_display;
?? TITLE := '  dup$display_string', EJECT ??
{ PURPOSE: Verify that the new text will fit on the current line. Skip to the
{          next line if it won't.
{ NOTES:   If a string is longer than the line, it will be folded by BAM or the
{          terminal.

  PROCEDURE [XDCL] dup$display_string (VAR display_control_pointer: ^clt$display_control;
        space_required: amt$page_width;
        str: string ( * );
        indent_count: ost$string_size;
    VAR status: ost$status);

    IF (display_control_pointer^.column_number + space_required - 1 ) >
          display_control_pointer^.page_width THEN
      clp$new_display_line (display_control_pointer^, clc$next_display_line,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF indent_count > 0 THEN
        clp$horizontal_tab_display (display_control_pointer^, indent_count + 1,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    clp$put_partial_display (display_control_pointer^, str, clc$no_trim,
          amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND dup$display_string;
?? TITLE := '  dup$open_display', EJECT ??
*copyc duh$open_display

  PROCEDURE [XDCL] dup$open_display (file_name: fst$file_reference;
    VAR display_control_pointer: ^clt$display_control;
    VAR status: ost$status);

{This procedure interrogates the file-name parameter.  If it is not the
{default output file, it is opened using the parameter passed as
{display_control.  If it is the default output file, no open is
{performed unless the default file is not open.  The display_control_block for
{the default output file is owned by this module.

    VAR
      ring_attributes: amt$ring_attributes;

    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);

    IF file_name = default_output_file THEN
      IF NOT default_file_open THEN
        clp$open_display_reference (file_name, ^generate_title, fsc$list, ring_attributes,
              default_file_display_control, status);
        IF NOT status.normal THEN
          RETURN; {------->
        IFEND;
        default_file_open := TRUE;
      IFEND;
      display_control_pointer := ^default_file_display_control;
    ELSE
      clp$open_display_reference (file_name, ^generate_title, fsc$list, ring_attributes,
            display_control_pointer^, status);
    IFEND;
  PROCEND dup$open_display;
?? TITLE := '  generate_title', EJECT ??

  PROCEDURE generate_title (VAR display_control: {input, output}
    clt$display_control;
        page_number: integer;
    VAR status: ost$status);

{This procedure generates and outputs the standard title.  This title may
{take from 1 to 2 lines depending on the page width of the file to which
{it is destined.

    VAR
      j: integer,
      str: string (10),
      str1: string (18),
      str1_length: 0 .. 18,
      str2: string (12),
      str2_length: 0 .. 12,
      str3: string (35),
      str3_length: 0 .. 35;

    VAR
      datemdy: ost$date,
      header1: string (long_header_length),
      header1_length: 0 .. long_header_length,
      header2: string (long_header_length),
      header2_length: 0 .. long_header_length,
      os_version: pmt$os_name,
      timehms: ost$time;

    pmp$get_legible_date_time (osc$default_date, datemdy, osc$default_time, timehms,
          status);
    CASE datemdy.date_format OF
      =osc$mdy_date=
        str1 := datemdy.mdy;
        str1_length := STRLENGTH (datemdy.mdy);
      =osc$month_date=
        str1 := datemdy.month;
        str1_length := STRLENGTH (datemdy.month);
      =osc$iso_date=
        str1 := datemdy.iso;
        str1_length := STRLENGTH (datemdy.iso);
      =osc$ordinal_date=
        str1 := datemdy.ordinal;
        str1_length := STRLENGTH (datemdy.ordinal);
      =osc$dmy_date=
        str1 := datemdy.dmy;
        str1_length := STRLENGTH (datemdy.dmy);
    CASEND;
    CASE timehms.time_format OF
      =osc$ampm_time=
        str2 := timehms.ampm;
        str2_length := STRLENGTH (timehms.ampm);
      =osc$hms_time=
        str2 := timehms.hms;
        str2_length := STRLENGTH (timehms.hms);
      =osc$millisecond_time=
        str2 := timehms.millisecond;
        str2_length := STRLENGTH (timehms.millisecond);
    CASEND;
    str3 := db_product_name CAT ' ' CAT db_version CAT ' ';
    str3_length := 2 + db_product_name_length + db_version_length;
    str3(2 + db_product_name_length + db_version_length + 1, db_level_length) := v$level;
    str3_length := str3_length + db_level_length;
    pmp$get_os_version (os_version, status);

    clp$reset_for_next_display_page (display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (str, j, page_number);
    header1 := '     ';
    IF (display_control.page_width < long_header_length) THEN
      header2 := '     ';
      header1_length := short_header_length;
      header2_length := short_header_length;
      header1 (short_os_version_start, os_version_length) := os_version;
      header2 (short_date_start, str1_length ) := str1(1,str1_length);
      header1 (short_time_start, str2_length ) := str2(1,str2_length);
      header1 (short_page_title_start, 4) := 'PAGE';
      header2 (short_product_name_start, str3_length) :=
            str3;
      header1 (short_page_number_start, j) := str (1, j);
      clp$put_display (display_control, header1 (1, header1_length), clc$trim,
            status);
      IF NOT status.normal THEN
        RETURN; {------->
      IFEND;
      clp$put_display (display_control, header2 (1, header2_length), clc$trim,
            status);
      IF NOT status.normal THEN
        RETURN; {------->
      IFEND;
    ELSE
      header1_length := long_header_length;
      header1 (long_os_version_start, os_version_length) := os_version;
      header1 (long_date_start, str1_length ) := str1(1,str1_length);
      header1 (long_time_start, str2_length ) := str2(1,str2_length);
      header1 (long_page_title_start, 4) := 'PAGE';


      header1 (long_product_name_start, str3_length) :=
            str3;
      header1 (long_page_number_start, j) := str (1, j);
      clp$put_display (display_control, header1 (1, header1_length), clc$trim,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{skip a line
  clp$new_display_line (display_control,1,status);
  PROCEND generate_title;
?? OLDTITLE ??
MODEND dum$display_file_manager;
*DECK DECK=DUM$DISPLAY_FILE_TABLES EXPAND=TRUE
PROCEDURE dum$display_file_tables, display_file_tables, disft (
  sfid: integer = $optional
  output, o: file = $output
  display_option, do: key
      (brief, b), (full, f)
    keyend = brief
  display_full_fat, dff: boolean = false
  help, h: file = $null
  status)


  "$FORMAT=OFF"
  VAR
    when_status: status
  VAREND
  "$FORMAT=ON"

  WHEN any_fault DO
    when_status = $previous_status
    putl ' Invoked DISFT condition handler due to the following abnormal status:'
    disv when_status
    putl ' Enter commands, "exit_proc" to abort, or "exit_proc with when_status" to abort with status'
    include_file command prompt='disft_ch'
  WHENEND

  IF $specified(help) THEN
COLLECT_TEXT o=help until='HELPEND'
DISPLAY_FILE_TABLES or DISFT

  This procedure displays device manager's knowledge of a file by calling
the following procedures, passing the proper parameters to eliminate manual
intervention:

   Procedure             Passed Parameter
1. display_sfid          sfid
2a.  display_dfd         pva_of_dfd
     {calls}
2b.  display_fat         sfid
3. display_all_fmds      pva_of_fmd

The display_option and output parameters will be retained for all proce-
dures. This procedure assumes the user has previously selected the correct
exchange package by available analyze_dump commands.  See warnings below
for additional information on usage.

PARAMETERS:

SFID: integer
  This parameter sets the SFID of the file to be displayed.  See below
for additional information.  This parameter is required.

DISPLAY_OPTIONS, DO: key full, f, brief, b
  This parameter selects the option of displaying the contents of memory
and the description of the selected fields (full), or the brief
mode of the descriptions only.  This parameter defaults to brief.

DISPLAY_FULL_FAT, DFF: boolean
  This parameter specifies whether or not the full contents of the File
Allocation Table (FAT) should be displayed.  This parameter defaults to
FALSE.

OUTPUT, O: file
  This parameter selects the file name to receive the data.  This para-
meter is defaulted to $output.  If a file name other than $output is
entered the data will be formated correctly for printer disposition and
will be sent to the file  "$asis".

STATUS

ADDITIONAL INFORMATION:
  The SFID contains the file's index, residence, and hash.  For example
sfid 000f014b(16) is index 000f, residence 01, hash 4b.  The residence of
01 identifies this file as residing in mainframe wired tables.  An
analyze_dump command of "CHAD e=m" will need to be entered to insure proper
execution.  If the file residence is 02, indicating the file resides in job
fixed tables, a "CHAD e=j" would need to be entered.  The "CHAPR e=(Exchange
Package RMA)" command can be used for other inactive jobs in the system.  Of
course there are many other possible combinations.

WARNINGS/KNOWN DEFICIENCIES:

ERROR HANDLER
  When any fatal error is encountered a condition handler is invoked and
the following messages will appear:
 "Invoked DISXXX condition handler due to the following abnormal status:"
 "< the error status message >"
 "Enter commands, "exit_proc" to abort, or "exit_proc with when_status"
  to abort with status"
To exit the handler enter:    "exit_proc"
To exit the handler with status, enter:   "exit_proc with when_status"
 NOTE: XXX is the name of the procedure at the time of the error.

HELPEND
    EXIT_PROC
  IFEND

  IF NOT $specified(sfid) THEN
    EXIT_PROC WITH $status(false, 'US', 5, 'Parameter SFID is required')
  IFEND

  "$FORMAT=OFF"
  VAR
    command_line: string
    fmd_p: integer
    media: string
    media_pointer: integer
    output_file: file
    previous_fmd_p: integer
    previous_media_pointer: integer
  VAREND
  "$FORMAT=ON"

  IF $file(output open_position) = '$BOI' THEN
    output_file = output.$asis
  ELSE
    output_file = output
  IFEND

  command_line = ' display_sfid sfid='//..
$strrep(sfid, 16)//'(16) output='//$strrep(output)//' display_option='//$strrep(display_option)//..
' display_depth=fde media=media media_pointer=media_pointer'
  include_line command_line

  IF previous_media_pointer = media_pointer THEN
    EXIT_PROC WITH $status(false, 'us', 1, 'Display_SFID FAILURE TO PASS MEDIA_POINTER PARAMETER')
  IFEND

  IF media = 'gfc$fm_mass_storage_file' THEN
    command_line = ' display_dfd pva='//$strrep(media_pointer, 16)//'(16) output='//..
$strrep(output)//' display_option='//$strrep(display_option)//' fmd_p=fmd_p'
    include_line command_line

    IF previous_fmd_p = fmd_p THEN
      EXIT_PROC WITH $status(false, 'us', 2, 'Display_Disk_File_Descriptor FAILURE TO PASS FMD_P PARAMETER')
    IFEND

    command_line = ' display_all_fmds pva='//..
$strrep(fmd_p, 16)//'(16) output='//$strrep(output)//' display_option='//$strrep(display_option)
    include_line command_line

    IF display_full_fat THEN
      command_line = 'display_fat sfid='//$strrep(sfid 16)//'(16) output='//$strrep(output)
      include_line command_line
    IFEND

  ELSEIF media = 'gfc$fm_served_file' THEN
    command_line = ' display_sfd pva='//..
$strrep(pass_parameter, 16)//'(16) output='//$strrep(output)//' display_option='//$strrep(display_option)
    include_line command_line
  IFEND

PROCEND dum$display_file_tables
*DECK DECK=DUM$DISPLAY_FMD EXPAND=TRUE
PROCEDURE dum$display_fmd, display_fmd, disfmd (
  pva: integer = $optional
  output, o: file = $output
  display_option, do: key
      (brief, b), (full, f)
    keyend = brief
  next_fmd_p: (VAR) integer
  help, h: file = $null
  status)


" Create and set parameter to eliminate looping if called by Display_All_FMDS with a bad pva."
  IF $specified(next_fmd_p) THEN
    next_fmd_p = 0ffff80000000(16)
  IFEND

  "$FORMAT=OFF"
  VAR
    when_status: status
  VAREND
  "$FORMAT=ON"

  WHEN any_fault DO
    when_status = $previous_status
    putl ' Invoked DISFMD condition handler due to the following abnormal status:'
    disv when_status
    putl ' Enter commands, "exit_proc" to abort, or "exit_proc with when_status" to abort with status'
    include_file command prompt='disfmd_ch'
  WHENEND

  IF $specified(help) THEN
COLLECT_TEXT o=help until='HELPEND'
DISPLAY_FMD or DISFMD

  This procedure will display the file medium descriptor when given a
process virtual address to the entry.

PARAMETERS:

PVA: integer
  This parameter passes the processor virtual address of the FMD to
be displayed.  This parameter is required.

OUTPUT, O: file
  This parameter selects the file name to receive the data.  This para-
meter is defaulted to $output.  If a file name other than $output is
entered the data will be formated correctly for printer disposition and
will be sent to the file  "$asis".

DISPLAY_OPTIONS, DO: key full, f, brief, b
  This parameter selects the option of displaying the contents of memory
and the description of the selected fields (full), or the brief mode of
the descriptions only.  This parameter defaults to brief.

STATUS

WARNINGS/KNOWN DEFICIENCIES:


ERROR HANDLER
  When any fatal error is encountered a condition handler is invoked and
the following messages will appear:
 "Invoked DISFMD condition handler due to the following abnormal status:"
 "< the error status message >"
 "Enter commands, "exit_proc" to abort, or "exit_proc with when_status"
  to abort with status"
To exit the handler enter:    "exit_proc"
To exit the handler with status, enter:   "exit_proc with when_status"

HELPEND
    EXIT_PROC
  IFEND

  IF NOT $specified(pva) THEN
    EXIT_PROC WITH $status(false, 'US', 8, 'Parameter PVA is required')
  IFEND

  "$FORMAT=OFF"
  VAR
    output_file: file

" The following offsets were obtained from the output of the command Display_Symbol_Table
" for the type DMT$FILE_MEDIUM_DESCRIPTOR.

    in_use_offset: integer = 0(16)
    sfid_offset: integer = 1(16)
    avt_index_offset: integer = 5(16)
    dfl_index_offset: integer = 7(16)
    delete_logging_count_offset: integer = 0a(16)
    volume_assigned_offset: integer = 0c(16)
    fmd_allocated_length_offset: integer = 0d(16)
    bytes_per_mau_offset: integer = 13(16)
    daus_per_cylinder_offset: integer = 15(16)
    daus_per_allocation_unit_offset: integer = 16(16)
    internal_vsn_offset: integer = 17(16)
    maus_per_dau_offset: integer = 22(16)
    maus_per_transfer_unit_offset: integer = 23(16)
    p_next_fmd_offset: integer = 25(16)
    dmt$allocation_styles: array 0..9 of string 1..$max_name = ('dmc$a0', 'dmc$a1', 'dmc$a2', 'dmc$a3', ..
          'dmc$a4', 'dmc$a5', 'dmc$a6', 'dmc$a7', 'dmc$a8', 'dmc$acyl')
    allocation_style_offset: integer = 2b(16)
    fmd_length: integer = 44
  VAREND
  "$FORMAT=ON"

  IF $file(output open_position) = '$BOI' THEN
    output_file = output.$asis
  ELSE
    output_file = output
  IFEND

  pointer_fmd = pva

  IF output = :$local.$output THEN
    put_line '1FILE MEDIUM DESCRIPTOR' o=output_file
  IFEND

  IF display_option = 'FULL' THEN
    display_memory (pointer_fmd) b=fmd_length title=' FILE MEDIUM DESCRIPTOR' o=output_file
  IFEND

  put_line '  ' o=output_file
  IF $memory(pointer_fmd+in_use_offset, 1) = 1 THEN
    put_line ' in use = TRUE' o=output_file
  ELSE
    put_line ' in use = FALSE' o=output_file
  IFEND

  put_line ' sfid = '//$strrep($memory(pointer_fmd+sfid_offset, 4), 16)//'(16)' o=output_file

  put_line ' avt_index = '//$strrep($memory(pointer_fmd+avt_index_offset, 2), 16)//'(16)' o=output_file

  put_line ' device_file_list_index (dfl_index) = '//..
$strrep($memory(pointer_fmd+dfl_index_offset, 3), 16)//'(16)' o=output_file

  put_line ' delete_logging_count = '//..
$strrep($memory(pointer_fmd+delete_logging_count_offset 2), 16)//'(16)' o=output_file

  IF $memory(pointer_fmd+volume_assigned_offset, 1) = 1 THEN
    put_line ' volume assigned = TRUE' o=output_file
  ELSE
    put_line ' volume assigned = FALSE' o=output_file
  IFEND

  put_line ' fmd_allocated_length = '//..
$strrep($memory(pointer_fmd+fmd_allocated_length_offset, 6), 16)//'(16)' o=output_file

  put_line ' bytes_per_mau = '//$strrep($memory(pointer_fmd+bytes_per_mau_offset 2), 16)//'(16)' o=output_file

  put_line ' daus_per_cylinder = '//$strrep($memory(pointer_fmd+daus_per_cylinder_offset 1), 16)//'(16)' ..
        o=output_file

  put_line ' daus_per_allocation_unit = '//..
$strrep($memory(pointer_fmd+daus_per_allocation_unit_offset 1), 16)//'(16)' o=output_file

  display_binary_unique_name pva=pointer_fmd+internal_vsn_offset o=output cs=' internal vsn = '

  put_line ' maus_per_dau = '//$strrep($memory(pointer_fmd+maus_per_dau_offset 1), 16)//'(16)' o=output_file

  put_line ..
        ' maus_per_transfer = '//$strrep($memory(pointer_fmd+maus_per_transfer_unit_offset 2), 16)//'(16)' ..
        o=output_file

  put_line ' p_next_fmd = '//$strrep($memory(pointer_fmd+p_next_fmd_offset, 6), 16)//'(16)' o=output_file

  put_line ' allocation_style = '//dmt$allocation_styles($memory(pointer_fmd+allocation_style_offset 1)) ..
        o=output_file

  IF $specified(next_fmd_p) THEN
    next_fmd_p = $memory(pointer_fmd+p_next_fmd_offset, 6)
  IFEND

PROCEND dum$display_fmd
*DECK DECK=DUM$DISPLAY_GLOBAL_PAGE_QUEUE_L EXPAND=TRUE
PROCEDURE dum$display_global_page_queue_l, display_global_page_queue_l, disgpql (
  output, o: file = $output)

  VAR
    c$pql_entry_length: (READ) integer = 13
    c$page_queue_list_count: (READ) integer = 37

    c$page_queue_list: (READ) ARRAY 0 .. c$page_queue_list_count OF string 0 .. 25 =
      ('Free                     ', ..
       'Avail                    ', ..
       'Avail Modified           ', ..
       'Wired                    ', ..
       'Shared - task services   ', ..
       'Shared - PF execute      ', ..
       'Shared - PF non - execute', ..
       'Shared - Device File     ', ..
       'Shared - File Server     ', ..
       'Shared - Other           ', ..
       'Shared - Site 01         ', ..
       'Shared - Site 02         ', ..
       'Shared - Site 03         ', ..
       'Shared - Site 04         ', ..
       'Shared - Site 05         ', ..
       'Shared - Site 06         ', ..
       'Shared - Site 07         ', ..
       'Shared - Site 08         ', ..
       'Shared - Site 09         ', ..
       'Shared - Site 10         ', ..
       'Shared - Site 11         ', ..
       'Shared - Site 12         ', ..
       'Shared - Site 13         ', ..
       'Shared - Site 14         ', ..
       'Shared - Site 15         ', ..
       'Shared - Site 16         ', ..
       'Shared - Site 17         ', ..
       'Shared - Site 18         ', ..
       'Shared - Site 19         ', ..
       'Shared - Site 20         ', ..
       'Shared - Site 21         ', ..
       'Shared - Site 22         ', ..
       'Shared - Site 23         ', ..
       'Shared - Site 24         ', ..
       'Shared - Site 25         ', ..
       'Shared - IO Error Shared ', ..
       'Shared - IO Error Swapped', ..
       'Flawed                   ')

    data_string: string
    index: integer
    output_file: file
    pql: integer
    temp_string: string
  VAREND

  output_file = output.$eoi
  put_line l=' Command: DISPLAY_GLOBAL_PAGE_QUEUE_L                                           ' o=output_file
  put_line l='                                                      AGE                       ' o=output_file
  put_line l='                            FWD   BKW   COUNT  COUNT  INTERVAL  MINIMUM  MAXIMUM' o=output_file
  put_line l=' PAGE FRAME QUEUE ID        (16)  (16)  (16)   (10)   (10)      (10)     (10)   ' o=output_file
  put_line l=' -------------------------  ----  ----  -----  -----  --------  -------  -------' o=output_file

  pql = $symbol_address(mmv$gpql)

  FOR index = 0 TO c$page_queue_list_count DO
   IF (index < 9) OR ($memory(pql 6) <> 0) THEN
     data_line = '                                                                                '
     data_line(2, 25) = c$page_queue_list(index)
     temp_string = '          '//$strrep($memory(pql 2) 16)
     data_line(29, 4) = $substr(temp_string $strlen(temp_string)-3 4)
     temp_string = '          '//$strrep($memory(pql+2 2) 16)
     data_line(35, 4) = $substr(temp_string $strlen(temp_string)-3 4)
     temp_string = '          '//$strrep($memory(pql+4 2) 16)
     data_line(41, 5) = $substr(temp_string $strlen(temp_string)-4 5)
     temp_string = '          '//$strrep($memory(pql+4 2) 10)
     data_line(48, 5) = $substr(temp_string $strlen(temp_string)-4 5)
     temp_string = '          '//$strrep($memory(pql+6 1) 10)
     data_line(60, 3) = $substr(temp_string $strlen(temp_string)-2 3)
     temp_string = '          '//$strrep($memory(pql+7 4) 10)
     data_line(67, 5) = $substr(temp_string $strlen(temp_string)-4 5)
     temp_string = '          '//$strrep($memory(pql+11 2) 10)
     data_line(76, 5) = $substr(temp_string $strlen(temp_string)-4 5)
     put_line l=data_line o=output_file
   IFEND
   pql = pql + c$pql_entry_length
 FOREND

PROCEND dum$display_global_page_queue_l
*DECK DECK=DUM$DISPLAY_HASH_FROM_GFN EXPAND=TRUE
PROCEDURE dum$display_hash_from_gfn, display_hash_from_gfn, dish, dishfg (
  gfn_address, address, a, ga: integer = $required
  output, o: file = $output
  )

  x = $mem($value(address)+7, 4)
  "    strip off last 3 bits with div 8 and leading bit with mod 1000000
  hash = $mod($mod(x/8, 1000000(16)), 99)
  outline = '    the file hash is '//$strrep(hash, 16)//'(16)'
  put_line outline $value(output)

PROCEND dum$display_hash_from_gfn
*DECK DECK=DUM$DISPLAY_IJL_ENTRY EXPAND=TRUE
PROC dum$DISPLAY_IJL_ENTRY display_ijl_entry, disijle (
  ijlo      : integer -281474976710655..281474976710655 = $required
  output, o : file = $output
  )

  crev ijlep
  get_ijlep_via_ijlo $value(ijlo) ijlep
  oo = $string($value(output)) // '.$eoi'
  putl ' ----- IJL  Entry '//$strrep($value(ijlo), 16) o=$fname(oo)
  jmt$initiated_job_list_entry ijlep o=$value(output)

PROCEND dum$display_ijl_entry
*DECK DECK=DUM$DISPLAY_INITIALIZE EXPAND=TRUE
PROCEDURE dum$display_initialize, display_initialize (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, sva, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable output_line k=string v=' '
  create_variable log_address v=$value(address)
  create_variable indent k=(string, 5) v='     '
  log_address = log_address + 1

  display_binary_unique_name log_address o=$fname(output_file) cs=indent//'gfn=' am=$value(am)
  output_line = indent//'dfl='//$strrep($mem(log_address+11, 3, j, 0, $value(am)), 16)
  output_line = output_line//' dau='//$strrep($mem(log_address+14, 3, j, 0, $value(am)), 16)

  putl output_line o=$fname(output_file)

PROCEND dum$display_initialize
*DECK DECK=DUM$DISPLAY_INITIATED_JOB_LIST EXPAND=TRUE
PROCEDURE dum$display_initiated_job_list, display_initiated_job_list, disijl (
  display_option, do: key
    (job_name, jn)
    (brief, b)
    (full, f, all)
  keyend = brief
  output, o: file = $output
  status)

 " This procedure displays a brief summary of all jobs in the
 " initiated job list.   This procedure uses RJTs new dump analyzer
 " and assumed TMM$DISPATCHER has been added.

   set_file_attributes output fc=legible pf=continuous
  current = $default_module
  chadm tmm$dispatcher
  job_display = ' '
  job_name_string = ''
  FOR block = 0 TO $pv(jmv$ijl_p.max_block_in_use) DO
     FOR entry = 0 TO $pv(UPPERVALUE(0.jmt$ijl_block_index)) DO
       IF $pv(jmv$ijl_p.block_p^[?block].index_p^[?entry].entry_status) <>  JMC$IES_ENTRY_FREE THEN
         IF display_option = job_name THEN
           job_name_string = job_name_string//'    '//..
$pv(jmv$ijl_p.block_p^[?block].index_p^[?entry].job_name)
            IF $size(job_name_string) >= 70 THEN
              disv job_name_string o=output.$eoi
             job_name_string = ''
           IFEND
         ELSEIF display_option = brief THEN
         job_display = '- '//$strrep(block)//' '//$strrep(entry)//' '//..
$pv(jmv$ijl_p.block_p^[?block].index_p^[?entry].system_supplied_name)//' '//..
$pv(jmv$ijl_p.block_p^[?block].index_p^[?entry].job_name)//' '//..
$pv(jmv$ijl_p.block_p^[?block].index_p^[?entry].entry_status)
   "     dispv jmv$ijl_p.block_p^[?block].index_p^[?entry]
         disv job_display o=output.$eoi
         job_display = '  ajl '//..
$strrep($pv(jmv$ijl_p.block_p^[?block].index_p^[?entry].ajl_ordinal),16)//'(16)'// ..
'  kjl '//$strrep($pv(jmv$ijl_p.block_p^[?block].index_p^[?entry].kjl_ordinal),16)//'(16)'//..
'  '//..
$pv(jmv$ijl_p.block_p^[?block].index_p^[?entry].swap_status)//'  job_fixed_asid: '//..
$strrep($pv(jmv$ijl_p.block_p^[?block].index_p^[?entry].job_fixed_asid),16)//'(16)'
         disv job_display o=output.$eoi
       ELSEIF display_option = full then
         disv ' --- Block '//$strrep(block)//' --Entry '//$strrep(entry) o=output.$eoi
         dispv jmv$ijl_p.block_p^[?block].index_p^[?entry] o=output.$eoi
       IFEND
       IFEND
     FOREND
  FOREND
   IF $size(job_name_string) > 0 THEN
      disv job_name_string o=output.$eoi
   IFEND


  chadm $name(current)
 PROCEND dum$display_initiated_job_list
*DECK DECK=DUM$DISPLAY_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Interfaces' ??                                                 
MODULE dum$display_interfaces;                                                                                
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains routines used to display data to an output file.                                     
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc clc$page_widths                                                                                        
*copyc duc$dump_analyzer_constants                                                                            
*copyc dut$title_data                                                                                         
?? POP ??                                                                                                     
*copyc clp$convert_integer_to_string                                                                          
*copyc clp$new_display_line                                                                                   
*copyc clp$put_display                                                                                        
*copyc clp$reset_for_next_display_page                                                                        
*copyc pmp$get_legible_date_time                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??                                        
                                                                                                              
  VAR                                                                                                         
    duv$title_data: [XDCL] dut$title_data := [TRUE, duc$version, ' ', 'UNKNOWN', 'UNKNOWN', 'UNKNOWN'],       
                                                                                                              
    v$narrow_os_info_title_1: string (clc$narrow_page_width),                                                 
    v$narrow_os_info_title_2: string (clc$narrow_page_width),                                                 
    v$narrow_title_1: string (clc$narrow_page_width),                                                         
    v$narrow_title_2: string (clc$narrow_page_width),                                                         
    v$wide_os_info_title: string (clc$wide_page_width),                                                       
    v$wide_title: string (clc$wide_page_width);                                                               
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$new_page_procedure', EJECT ??                                                             
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure builds the title information for the display file.                                         
                                                                                                              
  PROCEDURE [XDCL] dup$new_page_procedure                                                                     
    (VAR display_control: clt$display_control;                                                                
         new_page_number: integer;                                                                            
     VAR status: ost$status);                                                                                 
                                                                                                              
    CONST                                                                                                     
      c$max_date_time_length = 18;                                                                            
                                                                                                              
    VAR                                                                                                       
      date: ost$date,                                                                                         
      date_substring: string (c$max_date_time_length),                                                        
      ignore_status: ost$status,                                                                              
      page_number_string: ost$string,                                                                         
      time: ost$time,                                                                                         
      time_substring: string (c$max_date_time_length),                                                        
      wide_title_used: boolean;                                                                               
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    clp$reset_for_next_display_page (display_control, status);                                                
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    wide_title_used := (display_control.page_width >= clc$wide_page_width);                                   
                                                                                                              
    IF duv$title_data.build_title THEN                                                                        
      pmp$get_legible_date_time (osc$default_date, date, osc$default_time, time, status);                     
      IF NOT status.normal THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      date_substring := ' ';                                                                                  
      CASE date.date_format OF                                                                                
      = osc$month_date =                                                                                      
        date_substring := date.month;                                                                         
      = osc$mdy_date =                                                                                        
        date_substring := date.mdy;                                                                           
      = osc$iso_date =                                                                                        
        date_substring := date.iso;                                                                           
      = osc$ordinal_date =                                                                                    
        date_substring := date.ordinal;                                                                       
      = osc$dmy_date =                                                                                        
        date_substring := date.dmy;                                                                           
      ELSE                                                                                                    
      CASEND;                                                                                                 
                                                                                                              
      time_substring := ' ';                                                                                  
      CASE time.time_format OF                                                                                
      = osc$ampm_time =                                                                                       
        time_substring := time.ampm;                                                                          
      = osc$hms_time =                                                                                        
        time_substring := time.hms;                                                                           
      = osc$millisecond_time =                                                                                
        time_substring := time.millisecond;                                                                   
      ELSE                                                                                                    
      CASEND;                                                                                                 
                                                                                                              
      IF wide_title_used THEN                                                                                 
        v$wide_title := '';                                                                                   
        v$wide_title (1, 25) := duv$title_data.main_title;                                                    
        v$wide_title (41, 31) := duv$title_data.command_name;                                                 
        v$wide_title (90, 18) := date_substring;                                                              
        v$wide_title (109, 12) := time_substring;                                                             
        v$wide_title (122, 5) := 'PAGE ';                                                                     
        v$wide_os_info_title := '';                                                                           
        v$wide_os_info_title (1, 3) := 'OS=';                                                                 
        v$wide_os_info_title (4, 31) := duv$title_data.system_level;                                          
        v$wide_os_info_title (35, 19) := '  Base System Time=';                                               
        v$wide_os_info_title (54, 20) := duv$title_data.base_system_time;                                     
        v$wide_os_info_title (74, 19) := '  Termination Time=';                                               
        v$wide_os_info_title (93, 20) := duv$title_data.termination_time;                                     
      ELSE                                                                                                    
        v$narrow_title_1 := '';                                                                               
        v$narrow_title_1 (1, 25) := duv$title_data.main_title;                                                
        v$narrow_title_1 (28, 31) := duv$title_data.command_name;                                             
        v$narrow_title_1 (62, 5) := 'PAGE ';                                                                  
        v$narrow_title_2 := '';                                                                               
        v$narrow_title_2 (1, 18) := date_substring;                                                           
        v$narrow_title_2 (21, 12) := time_substring;                                                          
        v$narrow_os_info_title_1 := '';                                                                       
        v$narrow_os_info_title_1 (1, 3) := 'OS=';                                                             
        v$narrow_os_info_title_1 (4, 31) := duv$title_data.system_level;                                      
        v$narrow_os_info_title_2 := '';                                                                       
        v$narrow_os_info_title_2 (1, 17) := 'Base System Time=';                                              
        v$narrow_os_info_title_2 (18, 20) := duv$title_data.base_system_time;                                 
        v$narrow_os_info_title_2 (38, 19) := '  Termination Time=';                                           
        v$narrow_os_info_title_2 (57, 20) := duv$title_data.termination_time;                                 
      IFEND;                                                                                                  
      duv$title_data.build_title := FALSE;                                                                    
    IFEND;                                                                                                    
                                                                                                              
    clp$convert_integer_to_string (new_page_number, 10, FALSE, page_number_string, ignore_status);            
                                                                                                              
    IF wide_title_used THEN                                                                                   
      v$wide_title (127, * ) := page_number_string.value (1, page_number_string.size);                        
      clp$put_display (display_control, v$wide_title, clc$trim, ignore_status);                               
      clp$put_display (display_control, v$wide_os_info_title, clc$trim, ignore_status);                       
    ELSE                                                                                                      
      v$narrow_title_1 (70, * ) := page_number_string.value;                                                  
      clp$put_display (display_control, v$narrow_title_1, clc$trim, ignore_status);                           
      clp$put_display (display_control, v$narrow_title_2, clc$trim, ignore_status);                           
      clp$put_display (display_control, v$narrow_os_info_title_1, clc$trim, ignore_status);                   
      clp$put_display (display_control, v$narrow_os_info_title_2, clc$trim, ignore_status);                   
    IFEND;                                                                                                    
                                                                                                              
    clp$new_display_line (display_control, 1, ignore_status);                                                 
                                                                                                              
  PROCEND dup$new_page_procedure;                                                                             
MODEND dum$display_interfaces;                                                                                
*DECK DECK=DUM$DISPLAY_IO_REQUESTS EXPAND=TRUE
PROC dum$DISPLAY_IO_REQUESTS display_io_requests, display_io_request, disir (
  logical_unit, lun, unit, u : integer -281474976710655..281474976710655 = $optional
  cylinder, c, cyl           : integer -281474976710655..281474976710655 = $optional
  track, t, tr, tk           : integer -281474976710655..281474976710655 = $optional
  sector, s, sc              : integer -281474976710655..281474976710655 = $optional
  output, o                  : file = $output
  )

  out = $unique
  out_eoi = out // '.$EOI'
  put_line, l=' IO Requests', o=$fname(out_eoi)
  put_line, l='', o=$fname(out_eoi)

  unit_specified = $specified(logical_unit)
  IF unit_specified THEN
    unit = $value(logical_unit)
  IFEND

  cylinder_specified = $specified(cylinder)
  IF cylinder_specified THEN
    cylinder = $value(cylinder)
  IFEND

  track_specified = $specified(track)
  IF track_specified THEN
    track = $value(track)
  IFEND

  sector_specified = $specified(sector)
  IF sector_specified THEN
    sector = $value(sector)
  IFEND

  request_heap = $sa(iov$request_heap)

  length = 0
  offset = 0

  fetch_field_info iot$io_disk_request,field_name=iot$io_disk_request, length=length, offset=offset
  request_length = (length / 8 + 7) / 8 * 8

  fetch_field_info iot$io_disk_request,field_name=disk_request, length=length, offset=offset
  pp_request_offset = offset / 8
  fetch_field_info iot$disk_request,field_name=request, length=length, offset=offset
  pp_request_offset = pp_request_offset + offset / 8

  fetch_field_info iot$disk_pp_request,field_name=$name('logical_unit'), length=length, offset=offset
  unit_length = length / 8
  unit_offset = offset / 8 + pp_request_offset

  fetch_field_info iot$disk_pp_request,field_name=$name('cylinder'), length=length, offset=offset
  cylinder_length = length / 8
  cylinder_offset = offset / 8 + pp_request_offset

  fetch_field_info iot$disk_pp_request,field_name=$name('track'), length=length, offset=offset
  track_length = length / 8
  track_offset = offset / 8 + pp_request_offset

  fetch_field_info iot$disk_pp_request,field_name=$name('sector'), length=length, offset=offset
  sector_length = length / 8
  sector_offset = offset / 8 + pp_request_offset

  FOR i = 0 TO 254 DO
    request_address = request_heap + request_length * i

    IF unit_specified AND (unit <> $mem(request_address+unit_offset, unit_length)) THEN
      CYCLE
    IFEND

    IF cylinder_specified AND (cylinder <> $mem(request_address+cylinder_offset, cylinder_length)) THEN
      CYCLE
    IFEND

    IF track_specified AND (track <> $mem(request_address+track_offset, track_length)) THEN
      CYCLE
    IFEND

    IF sector_specified AND (sector <> $mem(request_address+sector_offset, sector_length)) THEN
      CYCLE
    IFEND

    iot$io_disk_request, a=request_address, o=$fname(out)
  FOREND

  copy_file, i=$fname(out), o=$value(output)
  delete_file, f=$fname(out)

PROCEND dum$display_io_requests
*DECK DECK=DUM$DISPLAY_IO_SUMMARY EXPAND=TRUE

PROC dum$display_io_summary display_io_summary, disis (
  output, o : file = $output
  )

  out = $unique
  out_eoi = out // '.$EOI'

  create_variable, n=active_status, k=string, d=0..1
  active_status(0) = ' inactive'
  active_status(1) = ' active'

  request_heap = $sa(iov$request_heap)
  request_length = 152
  request_map = $sa(iov$request_heap_map)

  time_offset = 04f(16)
  time_length = 8

  unit_offset = 072(16)
  unit_length = 2

  cylinder_offset = 07a(16)
  cylinder_length = 2

  track_offset = 07c(16)
  track_length = 2

  sector_offset = 07e(16)
  sector_length = 2

  FOR i = 0 TO 254 DO
    map = $mem(request_map+i/8, 1)
    map_bit = $mod(map/(2**(7-$mod(i, 8))), 2)
    time = $mem(request_heap+request_length*i+time_offset, time_length)
    unit = $mem(request_heap+request_length*i+unit_offset, unit_length)
    cylinder = $mem(request_heap+request_length*i+cylinder_offset, cylinder_length)
    track = $mem(request_heap+request_length*i+track_offset, track_length)
    sector = $mem(request_heap+request_length*i+sector_offset, sector_length)

    index_string = $strrep(i+1, 10)
    index_string = $substr('', 1, 4-$strlen(index_string)) // index_string

    time_string = $strrep(time, 10)
    time_string = $substr('', 1, 17-$strlen(time_string)) // time_string

    unit_string = $strrep(unit, 10)
    unit_string = $substr('', 1, 3-$strlen(unit_string)) // unit_string

    cylinder_string = $strrep(cylinder, 10)
    cylinder_string = $substr('', 1, 5-$strlen(cylinder_string)) // cylinder_string

    track_string = $strrep(track, 10)
    track_string = $substr('', 1, 4-$strlen(track_string)) // track_string

    sector_string = $strrep(sector, 10)
    sector_string = $substr('', 1, 4-$strlen(sector_string)) // sector_string

    put_line, l=' i ='//index_string//' t ='//time_string//' u ='//unit_string//' cy ='//cylinder_string//..
' tk ='//track_string//' sc ='//sector_string//active_status(map_bit), o=$fname(out_eoi)
  FOREND

  copy_file, i=$fname(out), o=$value(output)
  delete_file, f=$fname(out)

PROCEND dum$display_io_summary
*DECK DECK=DUM$DISPLAY_JOB_ATTRIBUTES EXPAND=TRUE

PROC dum$display_job_attributes, display_job_attributes, disja  (
  output, o : file = $output
  status)

  jmt$job_attributes $sa(jmv$job_attributes) o=$value(output)

PROCEND dum$display_job_attributes



*DECK DECK=DUM$DISPLAY_JOB_CANDIDATE_QUEUE EXPAND=TRUE

PROC dum$display_job_candidate_queue, display_job_candidate_queue, disjcq (
  output, o : file = $output
  status)

  create_variable name=(length,offset) k=integer
  queue_address = $sa(jmv$candidate_queued_jobs)
  jmt$candidate_queued_job queue_address length=length offset=offset ..
       field=JOB_MONITOR_GLOBAL_TASK_ID
  maximum_job_class_in_use = $mem($sa(jmv$maximum_job_class_in_use) 1)
  entry_length = offset/8 + length/8
  output_eoi = $strrep($value(output))//'.$eoi'
  FOR job_class_index = 0 TO maximum_job_class_in_use DO
    put_line '  Job Class ---> '//$strrep(job_class_index 16) o=$fname(output_eoi)
    jmt$candidate_queued_job (queue_address+(entry_length*job_class_index))  ..
         o=$value(output)
  FOREND

PROCEND dum$display_job_candidate_queue



*DECK DECK=DUM$DISPLAY_JOB_CONTROL_BLOCK EXPAND=TRUE
PROC dum$DISPLAY_JOB_CONTROL_BLOCK display_job_control_block, disjcb (
  output, o : file = $output
  )

  " Cannot use $sa(jmv$jcb) - there are 2 definitions
  jmt$job_control_block 00300000000(16) o=$value(output)

PROCEND dum$display_job_control_block
*DECK DECK=DUM$DISPLAY_JOB_SERVER_TABLE EXPAND=TRUE
PROCEDURE  dum$display_job_server_table, display_job_server_table, disjst (
  output, o: file = $output
  status)

 " This procedure displays all of the servers that the current job is using.
 " This proc uses RJTs new dump analyzer.
 " This proc assumes that dfm$job_server_manager has been added.

  set_file_attributes f=output fc=legible pf=continuous
  out = output.$eoi
  current = $default_module
  change_default_module m=dfm$job_server_manager

  job_server_count = $program_value(dfv$job_server_count)
  IF job_server_count = 0 THEN
    put_line l=' Not using the server ' o=out
  ELSE
    FOR server = $program_value(lowerbound(dfv$p_job_server_table^)) TO job_server_count DO
      put_line l=' -----  Server '//$strrep(server)//' ---- ' o=out
      dispv dfv$p_job_server_table^[?server] o=out
    FOREND
  IFEND
  change_default_module m=current

PROCEND dum$display_job_server_table
*DECK DECK=DUM$DISPLAY_KJLX_ENTRY EXPAND=TRUE

PROC dum$display_kjlx_entry display_kjlx_entry, diskjlxe (
  kjlx_index : integer 1..65535 = $required
  output, o : file = $output
  status)


  kjlx_address = $mem($sa(jmv$kjlx_p) 6)
  kjlx_size = $mem(($sa(jmv$kjlx_p)+6) 4)
  kjlx_entry_size = $mem(($sa(jmv$kjlx_p)+14) 4)
  IF $value(kjlx_index) > (kjlx_size / kjlx_entry_size) THEN
    EXIT_PROC WITH $STATUS(FALSE, 'DE', 0, 'kjlx_index is out of range')
  IFEND
  kjlx_entry_address = kjlx_address + ($value(kjlx_index)-1)*kjlx_entry_size
  output_eoi = $string($value(output))//'.$eoi'
  putl ' ----- KJLX  Entry '//$strrep($value(kjlx_index), 16) o=$fname(output_eoi)
  jmt$known_job_list_extended kjlx_entry_address o=$value(output)

PROCEND dum$display_kjlx_entry



*DECK DECK=DUM$DISPLAY_KJL_ENTRY EXPAND=TRUE

PROC dum$display_kjl_entry display_kjl_entry, diskjle (
  kjl_index : integer 1..65535 = $required
  output, o : file = $output
  status)


  kjl_address = $mem($sa(jmv$kjl_p) 6)
  kjl_size = $mem(($sa(jmv$kjl_p)+6) 4)
  kjl_entry_size = $mem(($sa(jmv$kjl_p)+14) 4)
  IF $value(kjl_index) > (kjl_size / kjl_entry_size) THEN
    EXIT_PROC WITH $STATUS(FALSE, 'DE', 0, 'kjl_index is out of range')
  IFEND
  kjl_entry_address = kjl_address + ($value(kjl_index)-1)*kjl_entry_size
  output_eoi = $string($value(output))//'.$eoi'
  putl ' ----- KJL  Entry '//$strrep($value(kjl_index), 16) o=$fname(output_eoi)
  jmt$known_job_list_entry kjl_entry_address o=$value(output)

PROCEND dum$display_kjl_entry



*DECK DECK=DUM$DISPLAY_KNOWN_JOB_LIST EXPAND=TRUE

PROC dum$display_known_job_list, display_known_job_list, diskjl (
  output, o : file = $output
  status)

  jmt$known_job_list $sa(jmv$known_job_list) o=$value(output)

PROCEND dum$display_known_job_list



*DECK DECK=DUM$DISPLAY_KNOWN_OUTPUT_LIST EXPAND=TRUE

PROC dum$display_known_output_list, display_known_output_list, diskol (
  output, o : file = $output
  status)

  jmt$known_output_list $sa(jmv$known_output_list) o=$value(output)

PROCEND dum$display_known_output_list



*DECK DECK=DUM$DISPLAY_KOL_ENTRY EXPAND=TRUE

PROC dum$display_kol_entry display_kol_entry, diskole (
  kol_index : integer 1..65535 = $required
  output, o : file = $output
  status)


  kol_address = $mem($sa(jmv$kol_p) 6)
  kol_size = $mem(($sa(jmv$kol_p)+6) 4)
  kol_entry_size = $mem(($sa(jmv$kol_p)+14) 4)
  IF $value(kol_index) > (kol_size / kol_entry_size) THEN
    EXIT_PROC WITH $STATUS(FALSE, 'DE', 0, 'kol_index is out of range')
  IFEND
  kol_entry_address = kol_address + ($value(kol_index)-1)*kol_entry_size
  output_eoi = $string($value(output))//'.$eoi'
  putl ' ----- KOL  Entry '//$strrep($value(kol_index), 16) o=$fname(output_eoi)
  jmt$known_output_list_entry kol_entry_address o=$value(output)

PROCEND dum$display_kol_entry



*DECK DECK=DUM$DISPLAY_LOCKED_SEGMENTS EXPAND=TRUE
PROCEDURE dum$display_locked_segments, display_locked_segments, disls (
  ajl_ordinal, ao: any of
      key (all a) keyend
      integer
    anyend = all
  output, o: file = $output
  status)

" This procedure performs an analysis of all tasks in all jobs which are currently active (have ajl entries),
" plus monitor.  It displays the sdtx entry for any locked segment.

  VAR
    cctqm: string 1..256 = '???????????????????????????????? !"#$%&''()*+,-./0123456789:;'//..
          '<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~????????????????'//..
          '???????????????????????????????????????????????????????????????????????????????????'//..
          '??????????????????????????????'
    jmv$jcb: integer = 300000000(16)               "($sa(jmv$jcb))
    job_fixed_seg_num: integer = 14(16)            "relative to monitor address space
    job_monitor_xcb_offset: integer = 100(16)      "from start of job fixed
    sdtx_entry_size: integer = 24(16)
  VAREND

  VAR
    ajl: integer
    ajl_entry_size: integer
    ajl_ord: integer
    ajl_p: integer
    field_length: integer
    field_offset: integer
    function: integer
    in_use: integer
    in_use_len: integer
    job_monitor_xcb: integer
    job_name: integer
    last_ajl_ordinal: integer
    link: integer
    local_file: file = $fname('$local.'//$unique)
    local_status: status
    mcr: integer
    monitor_functions: ARRAY 0 .. 74 OF string
    number_of_entries: integer
    output_file: file
    pva: integer
    sdt_len_off: integer
    sdtx_offset_offset: integer
    sdtx_p: integer
    segment_lock: integer
    start_ajl_ordinal: integer
    system_ajl_ordinal: integer
    task_name: integer
    task_xcb: integer
    temp_file: file = $fname('$local.'//$unique)
    user_id: integer
  VAREND

  IF $file(output open_position) = '$BOI' THEN
    delete_file f=output status=local_status
    set_file_attributes f=output fc=list
  IFEND
  output_file = output.$eoi
  set_file_attributes f=temp_file fc=unknown

  put_line l='1COMMAND: DISPLAY_LOCKED_SEGMENTS' o=output_file
  put_line l=' ' o=output_file

  change_default e=monitor am=pva

  jmt$active_job_list_entry field=IN_USE offset=field_offset length=field_length
  in_use = field_offset/8                 "offset into ajl
  in_use_len = field_length/8             "length of in_use field in bytes
  ost$execution_control_block field=SAVE9 offset=field_offset length=field_length
  task_name = field_offset/8              "offset into the XCB
  ost$execution_control_block field=LINK offset=field_offset length=field_length
  link = field_offset/8                   "offset into xcb
  ost$execution_control_block field=SDTX_OFFSET offset=field_offset length=field_length
  sdtx_offset_offset = field_offset/8
  ost$exchange_package field=SEGMENT_TABLE_LENGTH offset=field_offset length=field_length
  sdt_len_off = field_offset/8
  mmt$segment_descriptor_extended field=SEGMENT_LOCK offset=field_offset length=field_length
  segment_lock = field_offset/8           "offset into segment descriptor table extended
  jmt$job_control_block field=JOBNAME offset=field_offset length=field_length
  job_name = field_offset/8               "offset into job control block
  jmt$job_control_block field=USER_ID offset=field_offset length=field_length
  user_id = field_offset/8                "offset into job control block

  ajl_p = $symbol_address(jmv$ajl_p)
  ajl = $memory(ajl_p)
  IF $nil_pva(ajl) THEN
    put_line l=' The active job list has not yet been established.' o=output_file
    EXIT PROCEDURE
  IFEND

  ajl_entry_size = $memory(ajl_p+14 4)
  system_ajl_ordinal = $memory(ajl_p+10 4)
  number_of_entries = $memory(ajl_p+6 4) / ajl_entry_size
  last_ajl_ordinal = system_ajl_ordinal + number_of_entries - 1

  change_processor_register ..
        jps=$rma(((system_ajl_ordinal + job_fixed_seg_num)*100000000(16))+job_monitor_xcb_offset)
  change_default e=job

  create_monitor_func_file f=local_file
  accept_line v=monitor_functions i=local_file
  detach_file f=local_file

  IF $value_kind(ajl_ordinal) = 'INTEGER' THEN
    start_ajl_ordinal = ajl_ordinal
    IF start_ajl_ordinal > last_ajl_ordinal THEN
      put_line l=' The specified ordinal is beyond the end of the active job list.' o=output_file
      EXIT PROCEDURE
    IFEND
    last_ajl_ordinal = start_ajl_ordinal
  ELSE
    start_ajl_ordinal = system_ajl_ordinal
  IFEND

  FOR ajl_ord = start_ajl_ordinal TO last_ajl_ordinal DO
    IF $memory(((ajl + (ajl_ord * ajl_entry_size)) + in_use), in_use_len) > 0 THEN "process entry
      put_line l=' *************************************************************************' o=output_file
      put_line l=' processing ajl ordinal '//$strrep(ajl_ord, 16) o=output_file
      pva = ((ajl_ord + job_fixed_seg_num) * 100000000(16)) + job_monitor_xcb_offset
      job_monitor_xcb = $rma(pva monitor)
      change_processor_register jps=job_monitor_xcb

      IF ajl_ord <> system_ajl_ordinal THEN
        put_line l=' job name = '//$trim($translate(cctqm $memory_string(jmv$jcb+job_name 31))) o=output_file
      IFEND
      put_line l=' user id = '//$trim($translate(cctqm $memory_string(jmv$jcb+user_id 31))) o=output_file
      put_line l=' -------------------------------------------------------------------------' o=output_file

      task_xcb = $memory($symbol_address(job_xcb_list))

      process_tasks: ..
      REPEAT
        change_processor_register jps=$rma(task_xcb)

        " Look for locked segments.

        sdtx_p = 300000000(16) + $memory((task_xcb + sdtx_offset_offset), 4)
        number_of_entries = $memory((task_xcb + sdt_len_off), 2)
        found = FALSE

        FOR index = 0 to number_of_entries - 1 DO
          entry_p = sdtx_p + sdtx_entry_size * index
          IF $memory(entry_p+segment_lock 1) > 2 THEN
            IF NOT found THEN
              put_line l='1Task name = '//$trim($translate(cctqm $memory_string((task_xcb+task_name) 31))) ..
                    o=output_file
              mcr = $process_register(mcr) / 10(16)
              IF mcr = ((mcr / 2) * 2) THEN
                function = $memory(task_xcb+088(16) 1)
                IF (function > 0) AND (function < 75) THEN
                  put_line l=' monitor request = '//monitor_functions(function) o=output_file
                IFEND
              IFEND
            IFEND
            put_line l=' SEGMENT '//$strrep(index) o=output_file
            display_memory a=entry_p b=sdtx_entry_size t='SEGMENT '//$strrep(index) o=temp_file
            copy_file i=temp_file o=output_file
            found = TRUE
          IFEND
        FOREND
        IF found THEN
          display_call e=job t=$strrep(ajl_ord)//' '//$memory_string((task_xcb+task_name) 24) o=temp_file
          copy_file i=temp_file o=output_file
        IFEND
        EXIT process_tasks WHEN $rma(task_xcb) = job_monitor_xcb
        task_xcb = $memory(task_xcb+link)
      UNTIL $nil_pva(task_xcb)
    IFEND
  FOREND

PROCEND dum$display_locked_segments
*DECK DECK=DUM$DISPLAY_LOGICAL_PP EXPAND=TRUE
*DECK DECK=DUM$DISPLAY_LOGICAL_PP_TABLE EXPAND=TRUE
PROCEDURE dum$display_logical_pp_table, display_logical_pp_table, dislppt, dislpt (
  ordinal, ord: any of
      range of integer
      key
        all
      keyend
    anyend = all
  new_table, nt: boolean = FALSE
  output, o: file = $output
  status)

  VAR
    c$active_check_start_address: (READ) integer = 8d(16)
    c$controller_info_start_address: (READ) integer = 5b(16)
    c$flags_size: (READ) integer = 13
    c$flags_starting_address: (READ) integer = 0
    c$handlers_starting_address: (READ) integer = 74(16)
    c$pp_info_starting_address: (READ) integer = 0d(16)
    c$task_info_starting_address: (READ) integer = 5e(16)
  VAREND

  VAR
    ignore_status: status
    index: integer
    last_lppt_ordinal: integer
    logical_pp_table: integer
    logical_pp_table_p: integer
    logical_pp_table_entry: integer
    logical_pp_table_entry_size: integer
    lppt_ordinal: integer
    number_of_entries: integer
    output_file: file
    start_lppt_ordinal: integer
    string_1: string
    string_2: string
    string_3: string
  VAREND

  IF $file(output open_position) = '$BOI' THEN
    delete_file f=output status=ignore_status
  IFEND
  output_file = output.$eoi

  IF new_table THEN
    logical_pp_table_p = $symbol_address(cmv$new_logical_pp_table_p)
  ELSE
    logical_pp_table_p = $symbol_address(cmv$logical_pp_table_p)
  IFEND
  logical_pp_table = $memory(logical_pp_table_p 6 monitor)
  logical_pp_table_entry_size = $memory((logical_pp_table_p + 14) 4 monitor)
  number_of_entries = $memory((logical_pp_table_p + 6) 4 monitor) / logical_pp_table_entry_size
  start_lppt_ordinal = $memory((logical_pp_table_p + 10) 4 monitor)
  last_lppt_ordinal = start_lppt_ordinal + number_of_entries - 1

  put_line l=' LOGICAL PP TABLE' o=output_file

  put_line l='   (entry size = '//$strrep(logical_pp_table_entry_size 10)//' bytes)' o=output_file
  put_line l='   (number of entries = '//$strrep(number_of_entries 10)//')' o=output_file
  put_line l='   (first ordinal = '//$strrep(start_lppt_ordinal 10)//')' o=output_file
  put_line l='   (last ordinal = '//$strrep(last_lppt_ordinal 10)//')' o=output_file

  IF $generic_type(ordinal) = RANGE THEN
    start_lppt_ordinal = ordinal.low
    IF start_lppt_ordinal > last_lppt_ordinal THEN
      put_line l=' ERROR -- Ordinal is beyond the end of the Logical PP Table.' o=output_file
      EXIT PROCEDURE
    IFEND
    IF start_lppt_ordinal < 0 THEN
      put_line l=' ERROR -- Ordinal is less then the starting ordinal of the Logical PP Table. ' o=output_file
      EXIT PROCEDURE
    IFEND
    last_lppt_ordinal = ordinal.high
  IFEND

  FOR lppt_ordinal = start_lppt_ordinal TO last_lppt_ordinal DO
    logical_pp_table_entry = logical_pp_table + ((lppt_ordinal - 1) * logical_pp_table_entry_size)

    put_line l=' ' o=output_file
    put_line l=' -----------------------------------------------------------------' o=output_file
    put_line l='   Logical PP Table Index = '//$strrep(lppt_ordinal) o=output_file
    put_line l='     Flags:' o=output_file

    FOR index = c$flags_starting_address TO (c$flags_size - 1) DO
      IF $memory((logical_pp_table_entry + index) 1 monitor) = 1 THEN
        string_1 = 'TRUE'
      ELSE
        string_1 = 'FALSE'
      IFEND
      IF index = 0 THEN
        put_line l='       configured = '//string_1 o=output_file
      ELSEIF index = 1 THEN
        put_line l='       resources_acquired = '//string_1 o=output_file
      ELSEIF index = 2 THEN
        put_line l='       pp_loaded = '//string_1 o=output_file
      ELSEIF index = 3 THEN
        put_line l='       disabled = '//string_1 o=output_file
      ELSEIF index = 4 THEN
        put_line l='       entry_in_use = '//string_1 o=output_file
      ELSEIF index = 5 THEN
        put_line l='       entry_reserved_by_nosve = '//string_1 o=output_file
      ELSEIF index = 6 THEN
        put_line l='       entry_reserved_by_other = '//string_1 o=output_file
      ELSEIF index = 7 THEN
        put_line l='       entry_reserved_by_system_job = '//string_1 o=output_file
      ELSEIF index = 8 THEN
        put_line l='       reservd_by_other_has_ch_present = '//string_1 o=output_file
      ELSEIF index = 9 THEN
        put_line l='       pp_hung = '//string_1 o=output_file
      ELSEIF index = 10 THEN
        put_line l='       pp_idle_resume_supported = '//string_1 o=output_file
      ELSEIF index = 11 THEN
        put_line l='       pp_handshaking_supported = '//string_1 o=output_file
      ELSEIF index = 12 THEN
        put_line l='       pp_reload_supported = '//string_1 o=output_file
      IFEND
    FOREND

    put_line l='     Pp_info:' o=output_file

    index = 0
    string_1 = $strrep($memory((logical_pp_table_entry + c$pp_info_starting_address + index) 1 monitor))
    index = index + 1
    IF $memory((logical_pp_table_entry + c$pp_info_starting_address + index) 1 monitor) = 0 THEN
      string_2 = ', PP'
    ELSE
      string_2 = ', CPP'
    IFEND
    index = index + 1
    string_3 = $strrep($memory((logical_pp_table_entry + c$pp_info_starting_address + index) 1 monitor) 8)
    index = index + 1
    put_line l='       physical_pp = IOU'//string_1//string_2//string_3//'(8)' o=output_file

    string_1 = $strrep($memory((logical_pp_table_entry + c$pp_info_starting_address + index) 2 monitor))
    index = index + 2
    put_line l='       logical_partner_pp_index = '//string_1 o=output_file

    IF $memory((logical_pp_table_entry + c$pp_info_starting_address + index) 1 monitor) = 0 THEN
      string_1 = 'cmc$lpt_null_pp_type'
    ELSEIF $memory((logical_pp_table_entry + c$pp_info_starting_address + index) 1 monitor) = 1 THEN
      string_1 = 'cmc$lpt_other_pp_type'
    ELSEIF $memory((logical_pp_table_entry + c$pp_info_starting_address + index) 1 monitor) = 2 THEN
      string_1 = 'cmc$lpt_disk_pp_type'
    ELSEIF $memory((logical_pp_table_entry + c$pp_info_starting_address + index) 1 monitor) = 3 THEN
      string_1 = 'cmc$lpt_tape_pp_type'
    ELSEIF $memory((logical_pp_table_entry + c$pp_info_starting_address + index) 1 monitor) = 4 THEN
      string_1 = 'cmc$lpt_network_pp_type'
    ELSEIF $memory((logical_pp_table_entry + c$pp_info_starting_address + index) 1 monitor) = 5 THEN
      string_1 = 'cmc$lpt_nad_pp_type'
    ELSE
      string_1 = ' '
    IFEND
    index = index + 1
    put_line l='       pp_type = '//string_1 o=output_file

    string_1 = $strrep($memory((logical_pp_table_entry + c$pp_info_starting_address + index) 4 monitor) 16)
    index = index + 4
    put_line l='       pp_interface_table_rma = '//string_1//'(16)' o=output_file

    string_1 = $strrep($memory((logical_pp_table_entry + c$pp_info_starting_address + index) 6 monitor) 16)
    index = index + 18
    put_line l='       pp_interface_table_p = '//string_1//'(16)' o=output_file

    string_1 = $strrep($memory((logical_pp_table_entry + c$pp_info_starting_address + index) 6 monitor) 16)
    index = index + 6
    put_line l='       pp_communication_buffer_p = '//string_1//'(16)' o=output_file

    string_1 = $strrep($memory((logical_pp_table_entry + c$pp_info_starting_address + index) 1 monitor))
    index = index + 1
    IF $memory((logical_pp_table_entry + c$pp_info_starting_address + index) 1 monitor) = 0 THEN
      string_2 = ', CH'
    ELSE
      string_2 = ', CCH'
    IFEND
    index = index + 1
    string_3 = $strrep($memory((logical_pp_table_entry + c$pp_info_starting_address + index) 1 monitor) 8)
    index = index + 1
    put_line l='       channel = IOU'//string_1//string_2//string_3//'(8)' o=output_file

    IF $memory((logical_pp_table_entry + c$pp_info_starting_address + index) 1 monitor) = 0 THEN
      string_1 = 'cmc$unspecified_port'
    ELSEIF $memory((logical_pp_table_entry + c$pp_info_starting_address + index) 1 monitor) = 1 THEN
      string_1 = 'cmc$port_a'
    ELSEIF $memory((logical_pp_table_entry + c$pp_info_starting_address + index) 1 monitor) = 2 THEN
      string_1 = 'cmc$port_b'
    ELSE
      string_1 = ' '
    IFEND
    index = index + 1
    put_line l='       channel_port = '//string_1 o=output_file

    string_1 = $strrep($memory((logical_pp_table_entry + c$pp_info_starting_address + index) 6 monitor) 16)
    index = index + 6
    put_line l='       channel_interlock_p = '//string_1//'(16)' o=output_file

    string_1 = $strrep($memory((logical_pp_table_entry + c$pp_info_starting_address + index) 6 monitor) 16)
    index = index + 14
    put_line l='       driver_code_p = '//string_1//'(16)' o=output_file

    string_1 = $memory_string((logical_pp_table_entry + c$pp_info_starting_address + index) 7 monitor)
    index = index + 7
    put_line l='       driver_name = '//string_1 o=output_file

    string_1 = $memory_string((logical_pp_table_entry + c$pp_info_starting_address + index) 7 monitor)
    index = index + 7
    put_line l='       cip_driver_name = '//string_1 o=output_file

    string_1 = $strrep($memory((logical_pp_table_entry + c$pp_info_starting_address + index) 6 monitor) 16)
    index = index + 6
    put_line l='       saved_io_request_p = '//string_1//'(16)' o=output_file

    put_line l='     Controller_info:' o=output_file

    index = 0
    IF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 1 THEN
      string_1 = 'TRUE'
    ELSE
      string_1 = 'FALSE'
    IFEND
    index = index + 1
    put_line l='       controlware_loaded = '//string_1 o=output_file

    IF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 1 THEN
      string_1 = 'TRUE'
    ELSE
      string_1 = 'FALSE'
    IFEND
    index = index + 1
    put_line l='       control_module_loaded = '//string_1 o=output_file

    IF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 0 THEN
      string_1 = 'cmc$ms7154_x'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 1 THEN
      string_1 = 'cmc$ms7155_1'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 2 THEN
      string_1 = 'cmc$ms7155_1x'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 3 THEN
      string_1 = 'cmc$ms7165_2x'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 4 THEN
      string_1 = 'cmc$mscm3_ct'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 5 THEN
      string_1 = 'cmc$mshydra_ct'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 6 THEN
      string_1 = 'cmc$ms5831_x'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 7 THEN
      string_1 = 'cmc$mt7021_3x'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 8 THEN
      string_1 = 'cmc$mt7021_4x'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 9 THEN
      string_1 = 'cmc$ms7255_1_1'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 10 THEN
      string_1 = 'cmc$ms7255_1_2'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 11 THEN
      string_1 = 'cmc$mt7221_2_s0'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 12 THEN
      string_1 = 'cmc$mt5680_xx'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 13 THEN
      string_1 = 'cmc$mt7221_1'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 14 THEN
      string_1 = 'cmc$mt698_xx'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 15 THEN
      string_1 = 'cmc$mt5698_xx'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 16 THEN
      string_1 = 'cmc$mp65354_11'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 17 THEN
      string_1 = 'cmc$ca2629_2'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 18 THEN
      string_1 = 'cmc$lcn380_170'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 19 THEN
      string_1 = 'cmc$mti2620_21x'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 20 THEN
      string_1 = 'cmc$mdi2621_21x'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 21 THEN
      string_1 = 'cmc$fs740_200'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 22 THEN
      string_1 = 'cmc$expresslink'
    ELSEIF $memory((logical_pp_table_entry + c$controller_info_start_address + index) 1 monitor) = 23 THEN
      string_1 = 'cmc$null_controller'
    ELSE
      string_1 = ' '
    IFEND
    index = index + 1
    put_line l='       controller_type = '//string_1 o=output_file

    put_line l='     Task_info:' o=output_file

    index = 0
    string_1 = $strrep($memory((logical_pp_table_entry + c$task_info_starting_address + index) 3 monitor) 16)
    index = index + 3
    put_line l='       gtid = '//string_1//'(16)' o=output_file

    string_1 = $memory_string((logical_pp_table_entry + c$task_info_starting_address + index) 19 monitor)
    index = index + 19
    put_line l='       reserved_job_name = '//string_1 o=output_file

    put_line l='     Handlers:' o=output_file

    index = 0
    string_1 = $strrep($memory((logical_pp_table_entry + c$handlers_starting_address + index) 6 monitor) 16)
    index = index + 12
    put_line l='       response_handler_p = '//string_1//'(16)' o=output_file

    IF $memory((logical_pp_table_entry + c$handlers_starting_address + index) 1 monitor) = 1 THEN
      string_1 = 'TRUE'
    ELSE
      string_1 = 'FALSE'
    IFEND
    index = index + 1
    put_line l='       one_word_response_allowed = '//string_1 o=output_file

    string_1 = $strrep($memory((logical_pp_table_entry + c$handlers_starting_address + index) 6 monitor) 16)
    index = index + 12
    put_line l='       one_word_response_handler_p = '//string_1//'(16)' o=output_file

    put_line l='     Active_check:' o=output_file

    index = 0
    string_1 = $strrep($memory((logical_pp_table_entry + c$active_check_start_address + index) 8 monitor) 16)
    index = index + 8
    put_line l='       timestamp = '//string_1//'(16)' o=output_file

    string_1 = $strrep($memory((logical_pp_table_entry + c$active_check_start_address + index) 8 monitor) 16)
    index = index + 8
    put_line l='       timeout = '//string_1//'(16)' o=output_file

  FOREND

PROCEND dum$display_logical_pp_table
*DECK DECK=DUM$DISPLAY_LOGICAL_UNIT_TABLE EXPAND=TRUE

PROC dum$display_logical_unit_table, display_logical_unit_table, dislut (
  ordinal, ord: integer or key all, a=all
  display_unit_queue, disuq: boolean = FALSE
  output, o: file = $output
  status)

      create_variable ignore_status k=status
      create_variable device_usage_sanctions kind=(string,25) dimension=0..2
          device_usage_sanctions(0) = 'INHIBIT LOGICAL MOUNT'
          device_usage_sanctions(1) = 'INHIBIT READ REQUEST'
          device_usage_sanctions(2) = 'INHIBIT WRITE REQUEST'
      create_variable element_state_mneumonics kind=(string,5) dimension=0..2
          element_state_mneumonics(0) = 'ON'
          element_state_mneumonics(1) = 'OFF'
          element_state_mneumonics(2) = 'DOWN'
      create_variable unit_type_map dimension=1..24
          unit_type_map(1) = 1
          unit_type_map(2) = 2
          unit_type_map(3) = 3
          unit_type_map(4) = 4
          unit_type_map(5) = 5
          unit_type_map(6) = 6
          unit_type_map(7) = 7
          unit_type_map(8) = 8
          unit_type_map(9) = 9
          unit_type_map(10)= 10
          unit_type_map(11) = 11
          unit_type_map(12) = 12
          unit_type_map(13) = 13
          unit_type_map(14) = 14
          unit_type_map(15) = 15
          unit_type_map(16) = 16
          unit_type_map(17) = 256
          unit_type_map(18) = 257
          unit_type_map(19) = 258
          unit_type_map(20) = 259
          unit_type_map(21) = 260
          unit_type_map(22) = 512
          unit_type_map(23) = 513
          unit_type_map(24) = 514
      create_variable unit_type_mneumonics kind=(string,20) dimension=1..24
          unit_type_mneumonics(1) = 'MT 679_5'
          unit_type_mneumonics(2) = 'MT 679_6'
          unit_type_mneumonics(3) = 'MT 679_7'
          unit_type_mneumonics(4) = 'MT 679_2'
          unit_type_mneumonics(5) = 'MT 679_3'
          unit_type_mneumonics(6) = 'MT 679_4'
          unit_type_mneumonics(7) = 'MT 677_2'
          unit_type_mneumonics(8) = 'MT 677_3'
          unit_type_mneumonics(9) = 'MT 677_4'
          unit_type_mneumonics(10) = 'MT 667_2'
          unit_type_mneumonics(11) = 'MT 667_8'
          unit_type_mneumonics(12) = 'MT 667_4'
          unit_type_mneumonics(13) = 'MT 669_2'
          unit_type_mneumonics(14) = 'MT 669_3'
          unit_type_mneumonics(15) = 'MT 669_4'
          unit_type_mneumonics(16) = 'MT 639_1'
          unit_type_mneumonics(17) = 'MS 844_4x'
          unit_type_mneumonics(18) = 'MS 885_1x'
          unit_type_mneumonics(19) = 'MS 885_42'
          unit_type_mneumonics(20) = 'MS 834_2'
          unit_type_mneumonics(21) = 'MS FSD'
          unit_type_mneumonics(22) = 'MDI_1'
          unit_type_mneumonics(23) = 'MAP_1'
          unit_type_mneumonics(24) = 'MAP_CMI_1'
      create_variable unit_queuing_mneumonics kind=(string,15) dimension=0..7
          unit_queuing_mneumonics(0) = 'ONE ENTRY PER QUEUE'
          unit_queuing_mneumonics(1) = 'FIRST IN FIRST OUT'
          unit_queuing_mneumonics(2) = 'FIRST IN LAST OUT'
          unit_queuing_mneumonics(3) = 'UNSUPPORTED'
          unit_queuing_mneumonics(4) = 'UNSUPPORTED'
          unit_queuing_mneumonics(5) = 'UNSUPPORTED'
          unit_queuing_mneumonics(6) = 'UNSUPPORTED'
          unit_queuing_mneumonics(7) = 'UNSUPPORTED'
      create_variable io_function_mneumonics kind=(string,20) dimension=0..13
          io_function_mneumonics(0) = 'READ PAGE'
          io_function_mneumonics(1) = 'WRITE PAGE'
          io_function_mneumonics(2) = 'EXPLICIT READ'
          io_function_mneumonics(3) = 'EXPLICIT WRITE'
          io_function_mneumonics(4) = 'SWAP IN'
          io_function_mneumonics(5) = 'SWAP OUT'
          io_function_mneumonics(6) = 'COMPARE SWAP'
          io_function_mneumonics(7) = 'WRITE VERIFY'
          io_function_mneumonics(8) = 'READ UFT'
          io_function_mneumonics(9) = 'READ MASS STORAGE'
          io_function_mneumonics(10) = 'WRITE MASS STORAGE'
          io_function_mneumonics(11) = 'NO IO'
          io_function_mneumonics(12) = 'WRITE LOCKED PAGE'
          io_function_mneumonics(13) = 'KEYPOINT IO'

      IF $file($value(output) open_position) = '$BOI' THEN
        rewind_file $value(output) status=ignore_status
        output_file = $string($value(output))//'.$ASIS'
      ELSE
        output_file = $string($value(output))
      IFEND

      "CONSTANTS
"
" LOGICAL UNIT TABLE DEFINITIONS
"
         cmc$configured = 0                  "offset of the configured flag
         cmc$logical_unit = 1                "offset of the logical unit
         cmc$interlock =3                    "offset of the interlock
         cmc$unit_interface_table_p = 4      "offset of the unit interface table pointer
         cmc$usage_sanctions = 10            "offset of the usage sanctions
         cmc$assignable_device = 11          "offset of the assignable device
         cmc$assigned = 12                   "offset of the assigned flag
         cmc$job_sequence_number = 13        "offset of the assigned job sequence number
         cmc$temporary_assigned = 18         "offset of the temporary assigned flag
         cmc$temporary_assigned_jsn = 19     "offset of the temporary assigned job sequence number
         cmc$unit_communications_buf_p = 24  "offset of the unit communications buffer pointer
         cmc$state = 37                      "offset of the unit state
"
" UNIT INTERFACE TABLE DEFINITIONS
"
         cmc$uit_logical_unit = 0            "offset of logical unit
         cmc$unit_status = 2                 "offset of the unit status
         cmc$unit_type = 4                   "offset of the unit status
         cmc$queue_count = 6                 "offset of the queue count
         cmc$communications_buff_len = 10    "offset of the communications buffer length
         cmc$communications_buff_rma = 12    "offset of the communications buffer RMA
         cmc$unit_lockword = 16              "offset of the unit lockword
         cmc$unit_queue_lockword = 24        "offset of the unit queue lockword
         cmc$first_unit_request_p = 34       "offset of the first unit queue request
         cmc$first_unit_request_rma = 44     "offset of the first unit queue RMA
"
" IO REQUEST DEFINITIONS
"
         cmc$device_request = 6              "offset of the device request pointer
"
" WIRED UNIT QUEUE REQUEST DEFINITIONS
"
         cmc$address_word_pair_count = 0     "offset of the address word pair count
         cmc$rma_list_p = 2                  "offset of the rma list pointer
         cmc$io_identification = 8           "offset of the io identification
         cmc$global_task_id = 17             "offset of the global task id
         cmc$io_function = 20                "offset of the io function
         cmc$number_of_commands = 21         "offset of the number of commands
         cmc$job_unit_queue_request_p = 22   "offset of the unit queue request pointer
         cmc$unit_queuing_option = 40        "offset of the unit queuing option
         cmc$wired_command_heap = 41         "offset of the wired command heap
         cmc$wired_pp_response = 59          "offset of the wired pp response pointer
         cmc$wired_data_commands = 65        "offset of the wired data command descriptor pointer
         cmc$wired_io_request = 83           "offset of the wired io request pointer
         cmc$subsystem_io_header_size = 96   "size of the wired header part of the queue request
"
" MASS STORAGE QUEUE REQUEST DEFINITIONS
"
"
" PP REQUEST DEFINITIONS
"
         cmc$req_next_request = 2            "offset of the next request pointer
         cmc$req_next_request_rma = 12       "offset of the next request RMA
         cmc$req_request_length = 16         "offset of the request length
         cmc$req_logical_unit = 18           "offset of the logical unit
         cmc$req_recovery_interrupt = 20     "offset of the recovery/interrupt
         cmc$req_priority = 21               "offset of the priority
         cmc$req_alert_mask = 22             "offset of the alert mask
         cmc$start_of_pp_commands = 32       "starting byte of the pp commands

      logical_unit_table_p = $sa(cmv$logical_unit_table)
      logical_unit_table = $mem(logical_unit_table_p 6 m)
      logical_unit_table_entry_size = $mem(logical_unit_table_p+14 4 m)
      number_of_entries = $mem(logical_unit_table_p+6 4 m) / logical_unit_table_entry_size
      start_lut_ordinal = $mem(logical_unit_table_p+10 4 m)
      last_lut_ordinal = start_lut_ordinal + number_of_entries - 1

      display_queue = $value(display_unit_queue)

      IF $value_kind(ordinal) = 'INTEGER' THEN
        start_lut_ordinal = $value(ordinal)
        IF start_lut_ordinal > last_lut_ordinal THEN
           put_line ' Ordinal is beyond end of Logical Unit Table ' $fname(output_file)
           EXIT_PROC
        IFEND
        IF start_lut_ordinal < 0 THEN
           put_line ' Ordinal is < starting ordinal of Logical Unit Table ' $fname(output_file)
           EXIT_PROC
        IFEND
        last_lut_ordinal = start_lut_ordinal
      IFEND

      put_line '1Processing Logical Unit Table ' $fname(output_file)
      put_line '1                             LOGICAL UNIT TABLE' o=$fname(output_file)

      FOR lut_ordinal = start_lut_ordinal TO last_lut_ordinal DO
          logical_unit_table_entry = logical_unit_table + ..
              ((lut_ordinal - 1) * logical_unit_table_entry_size)
          entry_in_use = ($mem(logical_unit_table_entry+cmc$configured 1 m) = 1)
          IF entry_in_use THEN
             configured = 'CONFIGURED'
          ELSE
             configured = 'NOT CONFIGURED'
          IFEND
          putl ' Logical Unit Table Entry - '//$strrep(lut_ordinal)//'    '//configured ..
               o=$fname(output_file)
          IF entry_in_use THEN
             logical_unit_number = $mem(logical_unit_table_entry+cmc$logical_unit 2 m)
             interlock = ($mem(logical_unit_table_entry+cmc$interlock 1 m) = 1)
             IF interlock THEN
                interlock_set='SET'
             ELSE
                interlock_set = 'NOT SET'
             IFEND
             unit_interface_table = $mem(logical_unit_table_entry+cmc$unit_interface_table_p 6 m)
             usage_sanctions = $mem(logical_unit_table_entry+cmc$usage_sanctions 1 m)
             IF usage_sanctions > 2 THEN
                device_usage_sanction = 'UNDEFINED - '//$strrep(usage_sanctions,16)//'(16)'
             ELSE
                device_usage_sanction = device_usage_sanctions(usage_sanctions)
             IFEND
             assignable_device = ($mem(logical_unit_table_entry+cmc$assignable_device 1 m) = 1)
             IF assignable_device THEN
                  assignable = 'YES'
             ELSE
                  assignable = 'NO'
             IFEND
             IF assignable_device THEN
                device_assigned = ($mem(logical_unit_table_entry+cmc$assigned 1 m) = 1)
                IF device_assigned THEN
                   assigned_job_sequence_number = $mem(logical_unit_table_entry+cmc$job_sequence_number 5 m)
                IFEND
                temporary_assigned = ($mem(logical_unit_table_entry+cmc$temporary_assigned 1 m) = 1)
                IF temporary_assigned THEN
                   temporary_assigned_job_seq_num = $mem(logical_unit_table_entry+cmc$temporary_assigned_jsn 5 m)
                IFEND
             IFEND
             communications_buffer_p = $mem(logical_unit_table_entry+cmc$unit_communications_buf_p 6 m)
             element_state = $mem(logical_unit_table_entry+cmc$state 1 m)
             IF element_state > 2 THEN
                element_state_mneumonic = 'UNDEFINED - '//$strrep(element_state,16)//'(16)'
             ELSE
                element_state_mneumonic = element_state_mneumonics(element_state)
             IFEND


             putl '       Logical unit - '//$strrep(logical_unit_number) o=$fname(output_file)
             putl '       Interlock - '//interlock_set o=$fname(output_file)
             putl '       Unit interface table pointer - '//$strrep(unit_interface_table,16)//'(16)' ..
                      o=$fname(output_file)
             putl '       Usage sanctions - '//device_usage_sanction o=$fname(output_file)
             putl '       Assignable device - '//assignable o=$fname(output_file)
             IF assignable_device THEN
               IF device_assigned THEN
                  putl '          Device assigned to - '//$strrep(assigned_job_sequence_number,16) o=$fname(output_file)
               IFEND
               IF temporary_assigned THEN
                  putl '          Device assigned to - '//$strrep(temporary_assigned_job_seq_num,16) o=$fname(output_file)
               IFEND
             IFEND
             putl '       Communications buffer pointer - '//$strrep(communications_buffer_p,16)//'(16)' o=$fname(output_file)
             putl '       Element state - '//element_state_mneumonic o=$fname(output_file)


               logical_unit = $mem(unit_interface_table+cmc$uit_logical_unit 2 m)
               element_disabled =(( $mem(unit_interface_table+cmc$unit_status 2 m) / 080000000(16)) = 1)
               IF element_disabled THEN
                    disabled = 'YES'
               ELSE
                    disabled = 'NO'
               IFEND
               unit_type = $mem(unit_interface_table+cmc$unit_type 2 m)
               unit_mneumonic = 'UNDEFINED UNIT - '//$strrep(unit_type,16)//'(16)'
               FOR index = 1 to 24 DO
                IF unit_type_map(index) = unit_type THEN
                  unit_mneumonic = unit_type_mneumonics(index)
                  EXIT
                IFEND
               FOREND
               queue_count = $mem(unit_interface_table+cmc$queue_count 1 m)
               communications_buffer_length = $mem(unit_interface_table+cmc$communications_buff_len 2 m)
               communications_buffer_rma = $mem(unit_interface_table+cmc$communications_buff_rma 4 m)
               unit_lockword = $mem(unit_interface_table+cmc$unit_lockword 8 m)
               unit_queue_lockword = $mem(unit_interface_table+cmc$unit_queue_lockword 8 m)
               unit_queue_request_p = $mem(unit_interface_table+cmc$first_unit_request_p 6 m)
               unit_queue_request_rma = $mem(unit_interface_table+cmc$first_unit_request_rma 4 m)
               putl '           UNIT INTERFACE TABLE' o=$fname(output_file)
               putl '              Logical Unit - '//$strrep(logical_unit)//'   Unit type - '//unit_mneumonic ..
                 o=$fname(output_file)
               putl '              Element disabled - '//disabled//'    Queue count - '//$strrep(queue_count,16) ..
                 o=$fname(output_file)
               putl '              Communications table length  '//$strrep(communications_buffer_length,16)//'(16)'//..
'Communications buffer RMA - '//$strrep(communications_buffer_rma,16) o=(output_file)
               putl '              Unit Lockword - '//$strrep(unit_lockword,16) o=$fname(output_file)
               putl '              Unit Request Queue Lockword - '//$strrep(unit_queue_lockword,16) o=$fname(output_file)
               putl '              Pointer to first unit request queue entry - '//$strrep(unit_queue_request_p,16)//'(16)' ..
                 o=$fname(output_file)
               putl '              RMA of first unit queue request entry - '//$strrep(unit_queue_request_rma,16)//'(16)' ..
                  o=$fname(output_file)
          IFEND
          IF display_queue THEN
             putl '           UNIT QUEUE   ' o=$fname(output_file)
             io_request = unit_queue_request_p
             WHILE io_request <> 0ffff80000000(16)
               unit_queue_request = $mem(io_request+cmc$device_request 6 m)
               putl '             Queue request - '//$strrep(unit_qeuue_request,16)//'(16)' o=$fname(output_file)
               IF $SUBSTR(unit_mneumonic,1,3) = 'MAP' THEN
                 address_word_pair_count = $mem(unit_queue_request+cmc$address_word_pair_count 2 m)
                 rma_list_p = $mem(unit_queue_request+cmc$rma_list_p 6 m)
                 io_identification = $strrep($mem(unit_queue_request+cmc$io_identification 8 m),16)//..
                   $strrep($mem(unit_queue_request+cmc$io_identification+9 1 m),16)
                 global_task_id = $strrep($mem(unit_queue_request+cmc$global_task_id 3 m),16)
                 io_function = $mem(unit_queue_request+cmc$io_function 1 m)
                 IF io_function > 13 THEN
                    io_function_mneumonic = 'UNDEFINED    '//$strrep(io_funcion,16)//'(16)'
                 ELSE
                    io_function_mneumonic = io_function_mneumonics(io_function)
                 IFEND
                 number_of_commands = $mem(unit_queue_request+cmc$number_of_commands 1 m)
                 job_unit_queue_p = $mem(unit_queue_request+cmc$job_unit_queue_request_p 6 m)
                 unit_queuing_option = $mem(unit_queue_request+cmc$unit_queuing_option 1 m)
                 IF unit_queuing_option > 7 THEN
                      unit_queue_option = 'UNDEFINED   '//$strrep(unit_queuing_option,16)//'(16)'
                 ELSE
                      unit_queue_option = unit_queuing_mneumonics(unit_queuing_option)
                 IFEND
                 wired_command_heap = $mem(unit_queue_request+cmc$wired_command_heap 6 m)
                 wired_pp_response_p = $mem(unit_queue_request+cmc$wired_pp_response 6 m)
                 wired_data_command_descriptors = $mem(unit_queue_request+cmc$wired_data_commands 6 m)
                 wired_io_request = $mem(unit_queue_request+cmc$wired_io_request 6 m)
                 pp_request = unit_queue_request + cmc$subsystem_io_header_size

                 putl '                Address word pair count - '//$strrep(address_word_pair_count) o=$fname(output_file)
                 putl '                RMA list pointer  '//$strrep(rma_list_p,16)//'(16)' o=$fname(output_file)
                 putl '                IO identification - '//io_identification o=$fname(output_file)
                 putl '                Global task id - '//global_task_id o=$fname(output_file)
                 putl '                IO function - '//$strrep(io_function_mneumonic) o=$fname(output_file)
                 putl '                Number of commands - '//$strrep(number_of_commands) o=$fname(output_file)
                 putl '                Job unit queue request pointer - '//$strrep(job_unit_queue_p,16)//'(16)' o=$fname(output_file)
                 putl '                Unit queuing control - '//unit_queue_option o=$fname(output_file)
                 putl '                Wired command heap pointer - '//$strrep(wired_command_heap,16)//'(16)' ..
                     o=$fname(output_file)
                 putl '                Wired pp response pointer - '//$strrep(wired_pp_response,16)//'(16)' ..
                     o=$fname(output_file)
                 putl '                Wired data command descriptors pointer - '//$strrep(wired_data_command_descriptors,16)//'(16)' ..
                     o=$fname(output_file)
                 putl '                Wired io request pointer - '//$strrep(wired_io_request,16)//'(16)' ..
                     o=$fname(output_file)
              IFEND
              next_request = $mem(pp_request+cmc$req_next_request 6 m)
              next_request_rma = $mem(pp_request+cmc$req_next_request_rma 4 m)
              request_length = $mem(pp_request+cmc$req_request_length 2 m)
              logical_unit_from_pp_request = $mem(pp_request+cmc$req_logical_unit 2 m)
              recovery_interrupt = $mem(pp_request+cmc$req_recovery_interrupt 1 m)
              priority = $mem(pp_request+cmc$req_priority 1 m)
              alert_mask = $mem(pp_request+cmc$req_alert_mask 1 m)
              pp_commands = pp_request + cmc$start_of_pp_commands
              putl '                  Request length - '//$strrep(requst_length,16)//'(16)' o=$fname(output_file)
              putl '                  Recovery interrupt - '//$strrep(recovery_interrupt,16)//'(16)' o=$fname(output_file)
              putl '                  Priority - '//$strrep(priority,16) o=$fname(output_file)
              putl '                  Alert mask - '//$strrep(alert_mask) o=$fname(output_file)
              putl '                  PP commands ' o=$fname(output_file)
              io_request = next_request
            WHILEND
            putl '           END OF QUEUE  ' o=$fname(output_file)
          IFEND
      FOREND
PROCEND dum$display_logical_unit_table
*DECK DECK=DUM$DISPLAY_LOGIN_TABLE EXPAND=TRUE
PROCEDURE dum$display_login_table, display_login_table, dislt (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, p, sva, s, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND
  create_variable output_line k=string
  create_variable entry_status k=string d=0..2
  entry_status(0) = 'dmc$lt_entry_available'
  entry_status(1) = 'dmc$lt_alloc_assigned_to_mf'
  entry_status(2) = 'dmc$lt_mf_logged_in'

  create_variable recovery_status k=string d=0..4
  recovery_status(0) = 'dmc$lt_normal_status'
  recovery_status(1) = 'dmc$lt_recovering'
  recovery_status(2) = 'dmc$lt_being_recovered'
  recovery_status(3) = 'dmc$lt_being_rec_log_complete'
  recovery_status(4) = 'dmc$lt_being_rec_alloc_complete'

  start = $value(address)
  display_memory start b=1000 am=$value(am) o=$fname(output_file) t=' LOGIN TABLE'
  header_length = 30
  lower = $mem(start+28, 1, j, 0, $value(am))
  upper = $mem(start+29, 1, j, 0, $value(am))
  length_of_entry = 70
  output_line = '  '

  putl '  ' o=$fname(output_file)
  putl ' SEQUENCE = '//$strrep($mem(start+24, 4, j, 0, $value(am)), 16)//'(16)' o=$fname(output_file)
  FOR index = lower TO upper DO
    entry_start = header_length + (index-1)* length_of_entry + start
    IF $mem(entry_start+0, 1, j, 0, $value(am)) <> 0 THEN
      putl '  ' o=$fname(output_file)
      putl '  ENTRY # '//$strrep(index) o=$fname(output_file)
      putl ' name: '//$memory_string(entry_start+14, 31, j, 0, $value(am)) o=$fname(output_file)
      putl ' entry status = '//entry_status($mem(entry_start+0, 1, j, 0, $value(am))) o=$fname(output_file)
      output_line = ' avt index: '//$strrep($mem(entry_start+7, 2, j, 0, $value(am)))
      output_line = output_line//'      mf assigned: '//..
$strrep($mem(entry_start+9, 5, j, 0, $value(am)), 16)//'(16)'
      putl output_line o=$fname(output_file)
      putl ' last last = '//$strrep($mem(entry_start+45, 8, j, 0, $value(am)), 16)//'(16)' ..
            o=$fname(output_file)
      putl '      last = '//$strrep($mem(entry_start+53, 8, j, 0, $value(am)), 16)//'(16)' ..
            o=$fname(output_file)
      putl '   current = '//$strrep($mem(entry_start+61, 8, j, 0, $value(am)), 16)//'(16)' ..
            o=$fname(output_file)
      putl ' recovery status = '//recovery_status($mem(entry_start+69, 1, j, 0, $value(am))) ..
            o=$fname(output_file)
    IFEND
  FOREND

PROCEND dum$display_login_table
*DECK DECK=DUM$DISPLAY_LOG_CTL_DESCRIPTOR EXPAND=TRUE
PROCEDURE dum$display_log_ctl_descriptor, display_log_control_descriptor, dislcd (
  log, l: name = $required
  output, o: file = $output
  status)

  "$FORMAT=OFF"
  VAR
    log_control_descriptor_offset: integer
    log_control_descriptor_size: integer
    log_ordinal: integer
    local_status: status
  VAREND
  "$FORMAT=ON"

" Determine the log ordinal for the specified log.

  get_log_ordinal log=log log_ordinal=log_ordinal status=local_status
  EXIT_PROC WITH local_status WHEN NOT local_status.normal

" Get the size of a log control descriptor in bytes (rounded to next whole word).

  lgt$log_control_descriptor field=lgt$log_control_descriptor offset=log_control_descriptor_offset ..
        length=log_control_descriptor_size
  log_control_descriptor_size = (log_control_descriptor_size + 63) / 8

" If it is a global log index into the global log control descriptors.

  IF (log_ordinal >= 2) AND (log_ordinal <=7) THEN
    log_control_descriptor = $sa(lgv$global_log_ctl)+((log_ordinal-2)*log_control_descriptor_size)
  ELSE
    log_control_descriptor = $sa(lgv$local_log_ctl)+(log_ordinal*log_control_descriptor_size)
  IFEND

  put_line lines=(' Log control descriptor for '//$string(log), ' ') o=output.$eoi
  lgt$log_control_descriptor a=log_control_descriptor o=output.$eoi

PROCEND dum$display_log_ctl_descriptor

*DECK DECK=DUM$DISPLAY_MAC_SOFT_REGISTERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display MAC Soft Registers Command' ??
MODULE dum$display_mac_soft_registers;

{ PURPOSE:
{   This module contains the code for the display_mac_soft_registers command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$find_record_list_entry
*copyc dup$new_page_procedure
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_mac_soft_registers', EJECT ??

{ PURPOSE:
{   This procedure displays the information from the S0 record: MSR.

  PROCEDURE [XDCL] dup$display_mac_soft_registers
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_mac_soft_registers, dismsr (
{   output, o: file = $optional
{   title, t: string 1..31 = 'display_mac_soft_registers'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (28),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 4, 18, 9, 0, 15, 961],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TITLE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 28],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_mac_soft_registers'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$title = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    TYPE
      t$data_line = RECORD
        CASE boolean OF
        = TRUE =
          line: string(22),
        = FALSE =
          space_1: string (2),
          number: string (2),
          space_2: string (2),
          value: ARRAY [1 .. 8] OF string (2),
        CASEND,
      RECEND,

      t$mac_soft_register = PACKED RECORD
        unused: 0 .. 0fff(16),
        fill: 0 .. 0f(16),
        number: 0 .. 0ff(16),
        value: PACKED ARRAY [1 .. 8] OF t$mac_soft_register_entry,
      RECEND,

      t$mac_soft_register_entry = PACKED RECORD
        fill: 0 .. 0f(16),
        data: 0 .. 0ff(16),
      RECEND,

      t$register_20 = PACKED RECORD
        CASE boolean OF
        = TRUE =
          register: ARRAY [1 .. 8] OF 0 .. 0ff(16),
        = FALSE =
          bits: PACKED ARRAY [0 .. 6] OF boolean,
          leftover: boolean,
          unused_1: 0 .. 0fffffff(16),
          unused_2: 0 .. 0fffffff(16),
        CASEND,
      RECEND,

      t$register_21 = PACKED RECORD
        CASE boolean OF
        = TRUE =
          register: ARRAY [1 .. 8] OF 0 .. 0ff(16),
        = FALSE =
          cti_pp_number: 0 .. 01f(16),
          mode: boolean,
          cti_reload_of_cm: boolean,
          unused_1: 0 .. 01ffffff(16),
          edd_select: boolean,
          edd_esm_dump_select: boolean,
          edd_tape_density: boolean,
          unused_2: 0 .. 3,
          edd_tape_type: 0 .. 7,
          unused_3: 0 .. 7,
          edd_tape_channel: 0 .. 1f(16),
          edd_tape_equipment: 0 .. 0f(16),
          edd_tape_unit: 0 .. 0f(16),
          unused_4: 0 .. 0ff(16),
        CASEND,
      RECEND,

      t$register_22 = PACKED RECORD
        CASE boolean OF
        = TRUE =
          register: ARRAY [1 .. 8] OF 0 .. 0ff(16),
        = FALSE =
          unused_1: 0 .. 0ffffffff(16),
          unused_2: 0 .. 0ffffff(16),
          edd_counter: 0 .. 0ff(16),
        CASEND,
      RECEND,

      t$register_23 = PACKED RECORD
        CASE boolean OF
        = TRUE =
          register: ARRAY [1 .. 8] OF 0 .. 0ff(16),
        = FALSE =
          initialize_cm: boolean,
          unused_1: 0 .. 07fffffff(16),
          unused_2: 0 .. 0ffffffff(16),
        CASEND,
      RECEND;

    VAR
      cell_p: ^cell,
      data_line: t$data_line,
      data_value: clt$data_value,
      display_control: clt$display_control,
      display_string: string (osc$max_string_size),
      entry_p: ^dut$de_other_record_entry,
      ignore_status: ost$status,
      index: 1 .. 8,
      mac_soft_register_p: ^t$mac_soft_register,
      msr_dump_record_size: amt$file_byte_address,
      output_display_opened: boolean,
      register: ARRAY [1 .. 8] OF 0 .. 0ff(16),
      register_20: t$register_20,
      register_21: t$register_21,
      register_22: t$register_22,
      register_23: t$register_23,
      restart_file_seq_p: ^ SEQ ( * ),
      ring_attributes: amt$ring_attributes,
      string_integer: string (6),
      string_length: integer;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

      { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      data_value.kind := clc$name;
      data_value.name_value := 'MSR';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p = NIL THEN
        clp$put_display (display_control, ' **ERROR** - Cannot find the MSR record on the restart file.',
              clc$trim, ignore_status);
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The specified record is',
              status);
        EXIT /display_opened/;  {---->
      IFEND;

      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),
            entry_p^.first_byte);
      RESET restart_file_seq_p TO cell_p;
      msr_dump_record_size := entry_p^.size;

      clp$put_display (display_control, '  MAC SOFT REGISTERS', clc$trim, ignore_status);
      clp$put_display (display_control, ' ', clc$trim, ignore_status);

      WHILE msr_dump_record_size > #SIZE (t$mac_soft_register) DO
        data_line.line := ' ';
        NEXT mac_soft_register_p IN restart_file_seq_p;
        IF mac_soft_register_p = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
          EXIT /display_opened/;  {---->
        IFEND;
        msr_dump_record_size := msr_dump_record_size - #SIZE (mac_soft_register_p^);
        clp$convert_integer_to_rjstring (mac_soft_register_p^.number, 16, FALSE, '0', data_line.number,
              ignore_status);
        FOR index := 1 TO 8 DO
          clp$convert_integer_to_rjstring (mac_soft_register_p^.value [index].data, 16, FALSE, '0',
                data_line.value [index], ignore_status);
          register [index] := mac_soft_register_p^.value [index].data;
        FOREND;
        clp$put_display (display_control, data_line.line, clc$trim, ignore_status);
        IF mac_soft_register_p^.number = 20(16) THEN
          register_20.register := register;
          IF register_20.bits [0] THEN
            clp$put_display (display_control,
                  '        BIT  00:     Check-in with the console bit is set.',
                  clc$trim, ignore_status);
          ELSE
            clp$put_display (display_control,
                  '        BIT  00:     Check-in with the console bit is NOT set.',
                  clc$trim, ignore_status);
          IFEND;
          IF register_20.bits [1] THEN
            clp$put_display (display_control,
                  '        BIT  01:     Successful acceptance of a data file from',
                  clc$trim, ignore_status);
            clp$put_display (display_control,
                  '                     console bit is set.', clc$trim, ignore_status);
          ELSE
            clp$put_display (display_control,
                  '        BIT  01:     Successful acceptance of a data file from',
                  clc$trim, ignore_status);
            clp$put_display (display_control,
                  '                     console bit is NOT set.', clc$trim, ignore_status);
          IFEND;
          IF register_20.bits [2] THEN
            clp$put_display (display_control,
                  '        BIT  02:     Unsuccessful acceptance of a data file from',
                  clc$trim, ignore_status);
            clp$put_display (display_control,
                  '                     console bit is set.', clc$trim, ignore_status);
          ELSE
            clp$put_display (display_control,
                  '        BIT  02:     Unsuccessful acceptance of a data file from',
                  clc$trim, ignore_status);
            clp$put_display (display_control,
                  '                     console bit is NOT set.', clc$trim, ignore_status);
          IFEND;
          IF register_20.bits [3] THEN
            clp$put_display (display_control,
                  '        BIT  03:     Successful acceptance and/or execution of an operator',
                  clc$trim, ignore_status);
            clp$put_display (display_control,
                  '                     command bit is set.', clc$trim, ignore_status);
          ELSE
            clp$put_display (display_control,
                  '        BIT  03:     Successful acceptance and/or execution of an operator.',
                  clc$trim, ignore_status);
            clp$put_display (display_control,
                  '                     command bit is NOT set.', clc$trim, ignore_status);
          IFEND;
          IF register_20.bits [4] THEN
            clp$put_display (display_control,
                  '        BIT  04:     Unsuccessful acceptance and/or execution of an operator',
                  clc$trim, ignore_status);
            clp$put_display (display_control,
                  '                     command bit is set.', clc$trim, ignore_status);
          ELSE
            clp$put_display (display_control,
                  '        BIT  04:     Unsuccessful acceptance and/or execution of an operator',
                  clc$trim, ignore_status);
            clp$put_display (display_control,
                  '                     command bit is NOT set.', clc$trim, ignore_status);
          IFEND;
          IF register_20.bits [5] THEN
            clp$put_display (display_control,
                  '        BIT  05:     Error detected during automatic mode bit is set.',
                  clc$trim, ignore_status);
          ELSE
            clp$put_display (display_control,
                  '        BIT  05:     Error detected during automatic mode bit is NOT set.',
                  clc$trim, ignore_status);
          IFEND;
          IF register_20.bits [6] THEN
            clp$put_display (display_control, '        BIT  06:     Enable 721 emulation bit is set.',
                  clc$trim, ignore_status);
          ELSE
            clp$put_display (display_control, '        BIT  06:     Enable 721 emulation bit is NOT set.',
                  clc$trim, ignore_status);
          IFEND;
        ELSEIF mac_soft_register_p^.number = 21(16) THEN
          register_21.register := register;
          clp$convert_integer_to_rjstring (register_21.cti_pp_number, 16, TRUE, '0',
                string_integer (1, 6), ignore_status);
          STRINGREP (display_string, string_length, '        BITS 00-04:  CTI PP Number = ',
                string_integer (1, 6), '.');
          clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
          IF register_21.mode THEN
            clp$put_display (display_control, '        BIT  05:     Mode = Manual.',
                  clc$trim, ignore_status);
          ELSE
            clp$put_display (display_control, '        BIT  05:     Mode = Automatic.',
                  clc$trim, ignore_status);
          IFEND;
          IF register_21.cti_reload_of_cm THEN
            clp$put_display (display_control, '        BIT  06:     CTI reload of CM from EDD tape = YES.',
                  clc$trim, ignore_status);
          ELSE
            clp$put_display (display_control, '        BIT  06:     CTI reload of CM from EDD tape = NO.',
                  clc$trim, ignore_status);
          IFEND;
          IF register_21.edd_select THEN
            clp$put_display (display_control, '        BIT  32:     EDD select = YES.',
                  clc$trim, ignore_status);
          ELSE
            clp$put_display (display_control, '        BIT  32:     EDD select = NO.',
                  clc$trim, ignore_status);
          IFEND;
          IF register_21.edd_esm_dump_select THEN
            clp$put_display (display_control, '        BIT  33:     EDD ESM dump select = YES.',
                  clc$trim, ignore_status);
          ELSE
            clp$put_display (display_control, '        BIT  33:     EDD ESM dump select = NO.',
                  clc$trim, ignore_status);
          IFEND;
          IF register_21.edd_tape_density THEN
            clp$put_display (display_control, '        BIT  34:     EDD tape density = 1600 PE.',
                  clc$trim, ignore_status);
          ELSE
            clp$put_display (display_control, '        BIT  34:     EDD tape density = 6250 GE.',
                  clc$trim, ignore_status);
          IFEND;
          IF register_21.edd_tape_type = 1 THEN
            clp$put_display (display_control, '        BITS 37-39:  EDD tape type = IPI.',
                  clc$trim, ignore_status);
          ELSE
            clp$put_display (display_control, '        BITS 37-39:  EDD tape_type = ISMT.',
                  clc$trim, ignore_status);
          IFEND;
          clp$convert_integer_to_rjstring (register_21.edd_tape_channel, 16, TRUE, '0',
                string_integer (1, 6), ignore_status);
          STRINGREP (display_string, string_length, '        BITS 43-47:  CM reload edd tape channel = ',
                string_integer (1, 6), '.');
          clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
          clp$convert_integer_to_rjstring (register_21.edd_tape_equipment, 16, TRUE, '0',
                string_integer (1, 6), ignore_status);
          STRINGREP (display_string, string_length, '        BITS 48-51:  CM reload edd tape equipment = ',
                string_integer (1, 6), '.');
          clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
          clp$convert_integer_to_rjstring (register_21.edd_tape_unit, 16, TRUE, '0',
                string_integer (1, 6), ignore_status);
          STRINGREP (display_string, string_length, '        BITS 52-55:  CM reload edd tape unit = ',
                string_integer (1, 6), '.');
          clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
        ELSEIF mac_soft_register_p^.number = 22(16) THEN
          register_22.register := register;
          clp$convert_integer_to_rjstring (register_22.edd_counter, 10, TRUE, '0',
                string_integer (1, 6), ignore_status);
          clp$put_display (display_control,
                '        BITS 56-63:  Number of times EDD was executed before', clc$trim, ignore_status);
          STRINGREP (display_string, string_length, '                     re-initiating NOS/VE = ',
                string_integer (1, 6), '.');
          clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
        ELSEIF mac_soft_register_p^.number = 23(16) THEN
          register_23.register := register;
          IF register_23.initialize_cm THEN
            clp$put_display (display_control, '        BIT  0:      Initialize CM bit is set.',
                  clc$trim, ignore_status);
          ELSE
            clp$put_display (display_control, '        BIT  0:      Initialize CM bit is NOT set.',
                  clc$trim, ignore_status);
          IFEND;
        ELSEIF mac_soft_register_p^.number = 27(16) THEN
          EXIT /display_opened/;  {---->
        IFEND;
      WHILEND;

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_mac_soft_registers;
MODEND dum$display_mac_soft_registers;
*DECK DECK=DUM$DISPLAY_MAINTENANCE_REG EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Maintenance Registers Command' ??
MODULE dum$display_maintenance_reg;

{ PURPOSE:
{   This module contains the code for the display_maintenance_registers command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
*copyc dut$condition_registers
*copyc dut$registers_definition
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_partial_display
*copyc dup$display_message
*copyc dup$evaluate_parameters
*copyc dup$is_cpu1_installed
*copyc dup$new_page_procedure
*copyc dup$retrieve_register
*copyc ocp$find_debug_address
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

{ Define the PDT for the display_maintenance_registers command

{ PROCEDURE display_maintenance_registers, display_maintenance_register, dismr (
{   element, e: key
{       (processor p) (input_output_unit iou) (memory m) (all a)
{     keyend = all
{   processor, p: any of
{       key
{         (all a)
{       keyend
{       integer 0..3
{     anyend = all
{   title, t: string 1..31 = 'display_maintenance_registers'
{   output, o: file = $optional
{   iou, i: any of
{       key
{         (all a)
{       keyend
{       integer 0..1
{     anyend = all
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
        default_value: string (3),
      recend,
      type2: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (31),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
      type5: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (3),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 4, 16, 9, 45, 42, 449],
    clc$command, 11, 6, 0, 0, 0, 0, 6, ''], [
    ['E                              ',clc$abbreviation_entry, 1],
    ['ELEMENT                        ',clc$nominal_entry, 1],
    ['I                              ',clc$abbreviation_entry, 5],
    ['IOU                            ',clc$nominal_entry, 5],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OUTPUT                         ',clc$nominal_entry, 4],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PROCESSOR                      ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 6],
    ['T                              ',clc$abbreviation_entry, 3],
    ['TITLE                          ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 31],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 6
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [8], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['INPUT_OUTPUT_UNIT              ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['IOU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['MEMORY                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['PROCESSOR                      ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, 3, 10]]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_maintenance_registers'''],
{ PARAMETER 4
    [[1, 0, clc$file_type]],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, 1, 10]]
    ,
    'all'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element = 1,
      p$processor = 2,
      p$title = 3,
      p$output = 4,
      p$iou = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;
?? EJECT ??
  CONST
    c$column_number = 33;

?? EJECT ??

  VAR
    v$display_control: clt$display_control,
    v$line_length: 0 .. duc$de_max_definition_length;

?? OLDTITLE ??
?? NEWTITLE := 'display_bit_names', EJECT ??

{ PURPOSE:
{   This procedure scans a byte of a register and displays the names of any bits set.

  PROCEDURE display_bit_names
    (    starting_register_byte_number: 1 .. duc$de_max_register_length;
         register_value: ARRAY [1 .. duc$de_max_register_length] OF 0 .. 0ff(16);
         register_bit_names: ARRAY [ * ] OF string (duc$de_max_definition_length));

    TYPE
      t$set_or_byte = RECORD
        CASE boolean OF
        = TRUE =
          set_part: SET OF 0 .. 7,
        = FALSE =
          byte_part: 0 .. 0ff(16),
        CASEND,
      RECEND;

    VAR
      bit: 0 .. 7,
      bit_display_length: integer,
      bit_number: integer,
      bit_string: string (9),
      byte_number: 1 .. duc$de_max_register_length,
      byte_set: t$set_or_byte,
      data_after_max_length: boolean,
      ignore_status: ost$status,
      next_position: 0 .. duc$de_max_definition_length,
      position: 0 .. duc$de_max_definition_length,
      string_2: string (2);

    FOR byte_number := starting_register_byte_number TO duc$de_max_register_length DO
      byte_set.byte_part := register_value [byte_number];

     /scan_bits/
      FOR bit := 0 TO 7 DO
        IF NOT (bit IN byte_set.set_part) THEN
          CYCLE /scan_bits/;  {---->
        IFEND;

        bit_number := ((byte_number - 1) * 8) + bit;
        IF (bit_number > UPPERBOUND (register_bit_names)) OR
              (bit_number < LOWERBOUND (register_bit_names)) THEN
          CYCLE /scan_bits/;  {---->
        IFEND;

        { Display the bit number.

        clp$horizontal_tab_display (v$display_control, c$column_number, ignore_status);
        string_2 := 'XX';
        clp$convert_integer_to_rjstring (bit_number, 10, FALSE, '0', string_2, ignore_status);
        STRINGREP (bit_string, bit_display_length, 'bit ', string_2, ' : ');
        clp$put_partial_display (v$display_control, bit_string, clc$no_trim, amc$continue, ignore_status);

        { Determine the maximum length of a line for the output file.

        data_after_max_length := FALSE;

        IF v$line_length = duc$de_max_definition_length THEN
          data_after_max_length := FALSE;
        ELSE

         /scan_bit_name/
          FOR position := (v$line_length + 1) TO STRLENGTH (register_bit_names [bit_number]) DO
            IF register_bit_names [bit_number] (position) <> ' ' THEN
              data_after_max_length := TRUE;
              EXIT /scan_bit_name/;  {---->
            IFEND;
          FOREND /scan_bit_name/;
        IFEND;

        { Display the bit name.

        IF NOT data_after_max_length THEN
          clp$put_partial_display (v$display_control, register_bit_names [bit_number] (1, v$line_length),
                clc$trim, amc$terminate, ignore_status);
        ELSE

         /locate_last_blank/
          FOR position := 0 TO (v$line_length - 1) DO
            IF (register_bit_names [bit_number] (v$line_length - position) = ' ') THEN
              EXIT /locate_last_blank/;  {---->
            IFEND;
          FOREND /locate_last_blank/;

          clp$put_partial_display (v$display_control,
                register_bit_names [bit_number] (1, (v$line_length - position)), clc$trim, amc$terminate,
                ignore_status);
          next_position := v$line_length - position + 1;
          clp$horizontal_tab_display (v$display_control, (c$column_number + 9), ignore_status);
          clp$put_partial_display (v$display_control, register_bit_names [bit_number] (next_position,
                (STRLENGTH (register_bit_names [bit_number]) - next_position)), clc$trim, amc$terminate,
                ignore_status);
        IFEND;
      FOREND /scan_bits/;
    FOREND;

  PROCEND display_bit_names;
?? OLDTITLE ??
?? NEWTITLE := 'display_eid_information', EJECT ??

{ PURPOSE:
{   This procedure displays the element number, the model number and the serial number from the EID register.

  PROCEDURE display_eid_information
    (    register_value: ARRAY [1 .. duc$de_max_register_length] OF 0 .. 0ff(16));

    VAR
      element_string: string (11),
      ignore_status: ost$status,
      serial_number_string: string (4),
      string_2: string (2);

    { Display the element number.

    CASE register_value [duc$de_element_byte_number] OF
    = 00 =
      element_string := 'PROCESSOR  ';
    = 01 =
      element_string := 'MEMORY     ';
    = 02 =
      element_string := 'IOU        ';
    = 03 =
      element_string := 'ECS COUPLER';
    = 04 =
      element_string := '    PEM    ';
    ELSE
      element_string := ' UNDEFINED ';
    CASEND;
    clp$horizontal_tab_display (v$display_control, c$column_number, ignore_status);
    clp$put_partial_display (v$display_control, 'element: ', clc$no_trim, amc$continue, ignore_status);
    clp$put_partial_display (v$display_control, element_string, clc$trim, amc$terminate, ignore_status);

    { Display the model number.

    clp$horizontal_tab_display (v$display_control, c$column_number, ignore_status);
    string_2 := 'XX';
    clp$convert_integer_to_rjstring (register_value [duc$de_model_byte_number], 16, FALSE, '0', string_2,
          ignore_status);
    clp$put_partial_display (v$display_control, 'model  : ', clc$no_trim, amc$continue, ignore_status);
    clp$put_partial_display (v$display_control, string_2, clc$trim, amc$terminate, ignore_status);

    { Display the serial number.

    clp$horizontal_tab_display (v$display_control, c$column_number, ignore_status);
    serial_number_string := 'XXXX';
    clp$convert_integer_to_rjstring (register_value [duc$de_serial_num_byte_number], 16, FALSE, '0',
          serial_number_string (1, 2), ignore_status);
    clp$convert_integer_to_rjstring (register_value [duc$de_serial_num_byte_number + 1], 16, FALSE, '0',
          serial_number_string (3, 2), ignore_status);
    clp$put_partial_display (v$display_control, 's / n  : ', clc$no_trim, amc$continue, ignore_status);
    clp$put_partial_display (v$display_control, serial_number_string, clc$trim, amc$terminate, ignore_status);

  PROCEND display_eid_information;
?? OLDTITLE ??
?? NEWTITLE := 'display_iou_registers', EJECT ??

{ PURPOSE:
{   This procedure displays the iou registers.

  PROCEDURE display_iou_registers
    (VAR status: ost$status);

    VAR
      ending_iou: 0 .. duc$de_maximum_ious,
      ignore_status: ost$status,
      iou: 0 .. duc$de_maximum_ious,
      iou_displayed: boolean,
      model_number: 0 .. 0ff(16),
      register: dut$de_maintenance_register,
      register_index: 1 .. duc$de_number_of_pro_mrs_dumped,
      starting_iou: 0 .. duc$de_maximum_ious,
      string_2: string (2);

    status.normal := TRUE;
    iou_displayed := FALSE;

    { Determine the starting and ending iou numbers to display.

    IF pvt [p$iou].value^.kind = clc$integer THEN
      starting_iou := pvt [p$iou].value^.integer_value.value;
      ending_iou := starting_iou;
    ELSE
      starting_iou := 0;
      ending_iou := duc$de_maximum_ious;
    IFEND;

   /display_iou/
    FOR iou := starting_iou TO ending_iou DO
      IF NOT duv$dump_environment_p^.iou_maintenance_registers [iou].available THEN
        IF (iou = ending_iou) AND NOT iou_displayed THEN
          IF starting_iou = ending_iou THEN
            osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,
                  'The maintenance registers for iou', status);
            osp$append_status_integer (osc$status_parameter_delimiter, iou, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'are', status);
          ELSE
            osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,
                  'The maintenance registers for the iou are', status);
          IFEND;
          RETURN;  {---->
        IFEND;
        CYCLE /display_iou/;  {---->
      IFEND;
      iou_displayed := TRUE;

      { Display the iou number.

      v$display_control.line_number := v$display_control.page_length + 1;
      clp$new_display_line (v$display_control, 1, ignore_status);
      clp$put_partial_display (v$display_control, '  INPUT/OUTPUT UNIT', clc$no_trim, amc$continue,
            ignore_status);
      string_2 := 'XX';
      clp$convert_integer_to_rjstring (iou, 16, FALSE, '0', string_2, ignore_status);
      clp$put_partial_display (v$display_control, string_2, clc$no_trim, amc$terminate, ignore_status);
      clp$new_display_line (v$display_control, 1, ignore_status);

      { Retrieve the model number.

      model_number := 0;

      dup$retrieve_register (duc$de_iou, iou, 10(16), register);
      IF register.available THEN
        model_number := register.value [duc$de_model_byte_number];
      IFEND;

     /display_register/
      FOR register_index := 1 TO duc$de_number_of_iou_mrs_dumped DO
        register := duv$dump_environment_p^.iou_maintenance_registers [iou].registers [register_index];
        IF NOT register.available THEN
          CYCLE /display_register/;  {---->
        IFEND;

        { Display the register number.

        string_2 := 'XX';
        clp$convert_integer_to_rjstring (register.number, 16, FALSE, '0', string_2, ignore_status);
        clp$put_partial_display (v$display_control, string_2, clc$trim, amc$continue, ignore_status);
        clp$put_partial_display (v$display_control, '  ', clc$no_trim, amc$continue, ignore_status);

        { Display the register in groups of sixteen bits.

        display_register_groups (register.value);

        { Display the register name.

        IF (model_number < 50(16)) OR (model_number > 5F(16)) THEN
          clp$put_partial_display (v$display_control, duv$rd_general_iou_reg_def [register.number], clc$trim,
                amc$terminate, ignore_status);
        ELSE
          clp$put_partial_display (v$display_control, duv$rd_93x_iou_reg_def [register.number], clc$trim,
                amc$terminate, ignore_status);
        IFEND;

        { Display information about certain bits set in the registers.

        CASE register.number OF
        = 0 =
          IF model_number < 40(16) THEN
            display_bit_names (1, register.value, duv$rd_i0_i1_i2_iou_ss_def);
          ELSE
            display_bit_names (1, register.value, duv$rd_general_iou_ss_def);
          IFEND;

        = 10(16) =
          display_eid_information (register.value);

        ELSE
        CASEND;
      FOREND /display_register/;
    FOREND /display_iou/;

  PROCEND display_iou_registers;
?? OLDTITLE ??
?? NEWTITLE := 'display_memory_registers', EJECT ??

{ PURPOSE:
{   This procedure displays the memory registers.

  PROCEDURE display_memory_registers
    (VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      model_number: 0 .. 0ff(16),
      register: dut$de_maintenance_register,
      register_index: 1 .. duc$de_number_of_pro_mrs_dumped,
      string_2: string (2);

    status.normal := TRUE;

    IF NOT duv$dump_environment_p^.mem_maintenance_registers.available THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,
            'The memory maintenance registers are', status);
      RETURN;  {---->
    IFEND;

    v$display_control.line_number := v$display_control.page_length + 1;
    clp$new_display_line (v$display_control, 1, ignore_status);
    clp$put_partial_display (v$display_control, '  MEMORY', clc$no_trim, amc$terminate, ignore_status);
    clp$new_display_line (v$display_control, 1, ignore_status);

    { Retrieve the model number.

    model_number := 0;

    dup$retrieve_register (duc$de_memory, 0, 10(16), register);
    IF register.available THEN
      model_number := register.value [duc$de_model_byte_number];
    IFEND;

   /display_register/
    FOR register_index := 1 TO duc$de_number_of_mem_mrs_dumped DO
      register := duv$dump_environment_p^.mem_maintenance_registers.registers [register_index];
      IF NOT register.available THEN
        CYCLE /display_register/;  {---->
      IFEND;

      { Display the register number.

      string_2 := 'XX';
      clp$convert_integer_to_rjstring (register.number, 16, FALSE, '0', string_2, ignore_status);
      clp$put_partial_display (v$display_control, string_2, clc$trim, amc$continue, status);
      clp$put_partial_display (v$display_control, '  ', clc$no_trim, amc$continue, status);

      { Display the register in groups of sixteen bits.

      display_register_groups (register.value);

      { Display the register name.

      IF (model_number >= 50(16)) AND (model_number <= 5F(16)) THEN
        clp$put_partial_display (v$display_control, duv$rd_93x_mem_reg_def [register.number], clc$trim,
              amc$terminate, ignore_status);
      ELSEIF (model_number = 46(16)) OR (model_number = 48(16)) THEN
        clp$put_partial_display (v$display_control, duv$rd_cy2000_mem_reg_def [register.number],
              clc$trim, amc$terminate, ignore_status);
      ELSE
        clp$put_partial_display (v$display_control, duv$rd_general_mem_reg_def [register.number],
              clc$trim, amc$terminate, ignore_status);
      IFEND;

      { Display information about certain bits set in the registers.

      CASE register.number OF
      = 0 =
        IF model_number = 34(16) THEN
          display_bit_names (1, register.value, duv$rd_model_34_mem_ss_def);
        ELSEIF (model_number >= 50(16)) AND (model_number <= 5F(16)) THEN
          display_bit_names (1, register.value, duv$rd_93x_mem_ss_def);
        ELSEIF (model_number = 46(16)) OR (model_number = 48(16)) THEN
          display_bit_names (1, register.value, duv$rd_cy2000_mem_ss_def);
        ELSE
          display_bit_names (1, register.value, duv$rd_general_mem_ss_def);
        IFEND;

      = 10(16) =
        display_eid_information (register.value);

      ELSE
      CASEND;
    FOREND;

  PROCEND display_memory_registers;
?? OLDTITLE ??
?? NEWTITLE := 'display_processor_registers', EJECT ??

{ PURPOSE:
{   This procedure displays the processor registers.

  PROCEDURE display_processor_registers
    (VAR status: ost$status);

    TYPE
      t$pva_or_array = RECORD
        CASE boolean OF
        = TRUE =
          array_part: ARRAY [1 .. 6] OF 0 .. 0ff(16),
        = FALSE =
          pva_part: ost$pva,
        CASEND,
      RECEND;

    VAR
      byte_number: 1 .. duc$de_max_register_length,
      display_string: string (osc$max_string_size),
      ending_processor: 0 .. duc$de_maximum_processors,
      found: boolean,
      ignore_status: ost$status,
      local_status: ost$status,
      model_number: 0 .. 0ff(16),
      module_name: pmt$program_name,
      offset: ost$segment_offset,
      offset_in_section: ost$segment_offset,
      processor: 0 .. duc$de_maximum_processors,
      processor_displayed: boolean,
      pva_or_array: t$pva_or_array,
      reg_00_second_def: boolean,
      reg_31_second_def: boolean,
      register: dut$de_maintenance_register,
      register_index: 1 .. duc$de_number_of_pro_mrs_dumped,
      register_name_string: string (duc$de_max_definition_length),
      section_name: pmt$program_name,
      segment: ost$segment,
      starting_byte_number: 1 .. duc$de_max_register_length,
      starting_processor: 0 .. duc$de_maximum_processors,
      string_2: string (2),
      string_length: integer;

    status.normal := TRUE;
    processor_displayed := FALSE;

    { Determine the starting and ending processor numbers to display.

    IF pvt [p$processor].value^.kind = clc$integer THEN
      starting_processor := pvt [p$processor].value^.integer_value.value;
      ending_processor := starting_processor;
    ELSE
      starting_processor := 0;
      ending_processor := duc$de_maximum_processors;
    IFEND;

   /display_processor/
    FOR processor := starting_processor TO ending_processor DO
      reg_00_second_def := FALSE;
      reg_31_second_def := FALSE;
      IF NOT duv$dump_environment_p^.pro_maintenance_registers [processor].available THEN
        dup$is_cpu1_installed (duc$ee_cic_dismr, processor, v$display_control);
        IF (processor = ending_processor) AND NOT processor_displayed THEN
          IF starting_processor = ending_processor THEN
            osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,
                  'The maintenance registers for processor', status);
            osp$append_status_integer (osc$status_parameter_delimiter, processor, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'are', status);
          ELSE
            osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,
                  'The maintenance registers for the processor are', status);
          IFEND;
          RETURN;  {---->
        IFEND;
        CYCLE /display_processor/;  {---->
      IFEND;
      processor_displayed := TRUE;

      { Display the processor number.

      v$display_control.line_number := v$display_control.page_length + 1;
      clp$new_display_line (v$display_control, 1, ignore_status);
      clp$put_partial_display (v$display_control, '  PROCESSOR   ', clc$no_trim, amc$continue, ignore_status);
      string_2 := 'XX';
      clp$convert_integer_to_rjstring (processor, 16, FALSE, '0', string_2, ignore_status);
      clp$put_partial_display (v$display_control, string_2, clc$no_trim, amc$terminate, ignore_status);
      clp$new_display_line (v$display_control, 1, ignore_status);

      { Retrieve the model number.

      model_number := 0;

      dup$retrieve_register (duc$de_cpu, processor, 10(16), register);
      IF register.available THEN
        model_number := register.value [duc$de_model_byte_number];
      IFEND;

     /display_register/
      FOR register_index := 1 TO duc$de_number_of_pro_mrs_dumped DO
        register := duv$dump_environment_p^.pro_maintenance_registers [processor].registers [register_index];
        IF NOT register.available THEN
          CYCLE /display_register/;  {---->
        IFEND;

        { Display the register number.

        string_2 := 'XX';
        clp$convert_integer_to_rjstring (register.number, 16, FALSE, '0', string_2, ignore_status);
        clp$put_partial_display (v$display_control, string_2, clc$trim, amc$continue, ignore_status);
        clp$put_partial_display (v$display_control, '  ', clc$no_trim, amc$continue, ignore_status);

        { Display the register in groups of sixteen bits.

        display_register_groups (register.value);

        { Display the register name.

        IF register.number = 00(16) THEN
          IF NOT reg_00_second_def THEN
            register_name_string := 'status summary before CPU halt';
            reg_00_second_def := TRUE;
          ELSE
            register_name_string := 'status summary after CPU halt';
            reg_00_second_def := FALSE;
          IFEND;
          IF (model_number <= 50(16)) OR (model_number >= 5F(16)) THEN
            duv$rd_general_pro_reg_def [register.number] := register_name_string;
          ELSEIF ((model_number >= 50(16)) AND (model_number <= 53(16))) OR
                (model_number = 5B(16)) OR (model_number = 5D(16)) OR (model_number = 5E(16)) THEN
            duv$rd_930_pro_reg_def [register.number] := register_name_string;
          ELSE
            duv$rd_932_pro_reg_def [register.number] := register_name_string;
          IFEND;
        ELSEIF register.number = 31(16) THEN
          IF NOT reg_31_second_def THEN
            register_name_string := 'csa addr before halt';
            reg_31_second_def := TRUE;
          ELSE
            register_name_string := 'csa addr after halt';
            reg_31_second_def := FALSE;
          IFEND;
          IF (model_number <= 50(16)) OR (model_number >= 5F(16)) THEN
            duv$rd_general_pro_reg_def [register.number] := register_name_string;
          ELSEIF ((model_number >= 50(16)) AND (model_number <= 53(16))) OR
                (model_number = 5B(16)) OR (model_number = 5D(16)) OR (model_number = 5E(16)) THEN
            duv$rd_930_pro_reg_def [register.number] := register_name_string;
          ELSE
            duv$rd_932_pro_reg_def [register.number] := register_name_string;
          IFEND;
        IFEND;

        IF ((model_number >= 54(16)) AND (model_number <= 55(16))) OR (model_number = 5F(16)) OR
              (model_number = 5C(16)) THEN
          clp$put_partial_display (v$display_control, duv$rd_932_pro_reg_def [register.number], clc$trim,
                amc$terminate, ignore_status);
        ELSEIF (model_number >= 50(16)) AND (model_number <= 5E(16)) THEN
          clp$put_partial_display (v$display_control, duv$rd_930_pro_reg_def [register.number], clc$trim,
                amc$terminate, ignore_status);
        ELSE
          clp$put_partial_display (v$display_control, duv$rd_general_pro_reg_def [register.number], clc$trim,
                amc$terminate, ignore_status);
        IFEND;

        { Display information about certain bits set in the registers.

        CASE register.number OF
        = 0 =
          IF (model_number = 46(16)) OR (model_number = 48(16)) THEN
            starting_byte_number := (duc$rd_cy2000_ss_lower_bit DIV 8) + 1;
            display_bit_names (starting_byte_number, register.value, duv$rd_cy2000_pro_ss_def);
          ELSE
            starting_byte_number := (duc$rd_ss_lower_bit DIV 8) + 1;
            display_bit_names (starting_byte_number, register.value, duv$rd_general_pro_ss_def);
          IFEND;

        = 10(16) =
          display_eid_information (register.value);

        = 40(16) =
          FOR byte_number := 3 TO 8 DO
            pva_or_array.array_part [byte_number - 2] := register.value [byte_number];
          FOREND;
          offset := pva_or_array.pva_part.offset;
          segment := pva_or_array.pva_part.seg;
          ocp$find_debug_address (segment, offset, found, module_name, section_name, offset_in_section,
                local_status);
          IF local_status.normal AND found THEN
            STRINGREP (display_string, string_length, 'module : ', module_name);
            clp$horizontal_tab_display (v$display_control, c$column_number, ignore_status);
            clp$put_partial_display (v$display_control, display_string (1, string_length), clc$trim,
                  amc$terminate, ignore_status);
            STRINGREP (display_string, string_length, 'procedure : ', section_name);
            clp$horizontal_tab_display (v$display_control, c$column_number, ignore_status);
            clp$put_partial_display (v$display_control, display_string (1, string_length), clc$trim,
                  amc$terminate, ignore_status);
            STRINGREP (display_string, string_length, 'offset : ', offset_in_section: #(16));
            clp$horizontal_tab_display (v$display_control, c$column_number, ignore_status);
            clp$put_partial_display (v$display_control, display_string (1, string_length), clc$trim,
                  amc$terminate, ignore_status);
          IFEND;

        = 42(16) =
          starting_byte_number := (duc$cr_mtr_condition_lower_bit DIV 8) + 1;
          display_bit_names (starting_byte_number, register.value, duv$cr_mtr_condition_reg_def);

        = 43(16) =
          starting_byte_number := (duc$cr_user_condition_lower_bit DIV 8) + 1;
          display_bit_names (starting_byte_number, register.value, duv$cr_user_condition_reg_def);

        = 80(16) =
          CASE model_number OF
          = 11(16), 12(16), 13(16), 14(16) =
            display_bit_names (1, register.value, duv$rd_pro_810_830_pfs_0);
          = 20(16) =
            display_bit_names (1, register.value, duv$rd_pro_835_pfs_0);
          = 30(16), 31(16), 32(16), 33(16) =
            display_bit_names (1, register.value, duv$rd_pro_845_860_pfs_0);
          = 40(16), 41(16), 42(16), 44(16) =
            display_bit_names (1, register.value, duv$rd_pro_990_pfs_0);
          ELSE
          CASEND;

        = 81(16) =
          CASE model_number OF
          = 13(16), 14(16) =
            display_bit_names (1, register.value, duv$rd_pro_810_830_pfs_1);
          = 20(16) =
            display_bit_names (1, register.value, duv$rd_pro_835_pfs_1);
          = 30(16), 31(16), 32(16), 33(16) =
            display_bit_names (1, register.value, duv$rd_pro_845_860_pfs_1);
          = 40(16), 41(16), 42(16), 44(16) =
            display_bit_names (1, register.value, duv$rd_pro_990_pfs_1);
          ELSE
          CASEND;

        = 82(16) =
          CASE model_number OF
          = 30(16), 31(16), 32(16), 33(16) =
            display_bit_names (1, register.value, duv$rd_pro_845_860_pfs_2);
          = 40(16), 41(16), 42(16), 44(16) =
            display_bit_names (1, register.value, duv$rd_pro_990_pfs_2);
          ELSE
          CASEND;

        = 83(16) =
          CASE model_number OF
          = 30(16), 31(16), 32(16), 33(16) =
            display_bit_names (1, register.value, duv$rd_pro_845_860_pfs_3);
          = 40(16), 41(16), 42(16), 44(16) =
            display_bit_names (1, register.value, duv$rd_pro_990_pfs_3);
          ELSE
          CASEND;

        = 84(16) =
          CASE model_number OF
          = 30(16), 31(16), 32(16), 33(16) =
            display_bit_names (1, register.value, duv$rd_pro_845_860_pfs_4);
          = 40(16), 41(16), 42(16), 44(16) =
            display_bit_names (1, register.value, duv$rd_pro_990_pfs_4);
          ELSE
          CASEND;

        = 85(16) =
          CASE model_number OF
          = 30(16), 31(16), 32(16), 33(16) =
            display_bit_names (1, register.value, duv$rd_pro_845_860_pfs_5);
          = 40(16), 41(16), 42(16), 44(16) =
            display_bit_names (1, register.value, duv$rd_pro_990_pfs_5);
          ELSE
          CASEND;

        = 86(16) =
          CASE model_number OF
          = 30(16), 31(16), 32(16), 33(16) =
            display_bit_names (1, register.value, duv$rd_pro_845_860_pfs_6);
          = 40(16), 41(16), 42(16), 44(16) =
            display_bit_names (1, register.value, duv$rd_pro_990_pfs_6);
          ELSE
          CASEND;

        = 87(16) =
          CASE model_number OF
          = 30(16), 31(16), 32(16), 33(16) =
            display_bit_names (1, register.value, duv$rd_pro_845_860_pfs_7);
          = 40(16), 41(16), 42(16), 44(16) =
            display_bit_names (1, register.value, duv$rd_pro_990_pfs_7);
          ELSE
          CASEND;

        = 88(16) =
          CASE model_number OF
          = 30(16), 31(16), 32(16), 33(16) =
            display_bit_names (1, register.value, duv$rd_pro_845_860_pfs_8);
          = 40(16), 41(16), 42(16), 44(16) =
            display_bit_names (1, register.value, duv$rd_pro_990_pfs_8);
          ELSE
          CASEND;

        = 89(16) =
          CASE model_number OF
          = 30(16), 31(16), 32(16), 33(16) =
            display_bit_names (1, register.value, duv$rd_pro_845_860_pfs_9);
          = 40(16), 41(16), 42(16), 44(16) =
            display_bit_names (1, register.value, duv$rd_pro_990_pfs_9);
          ELSE
          CASEND;

        = 8a(16) =
          CASE model_number OF
          = 40(16), 41(16), 42(16), 44(16) =
            display_bit_names (1, register.value, duv$rd_pro_990_pfs_a);
          ELSE
          CASEND;

        = 8b(16) =
          CASE model_number OF
          = 40(16), 41(16), 42(16), 44(16) =
            display_bit_names (1, register.value, duv$rd_pro_990_pfs_b);
          ELSE
          CASEND;

        = 8c(16) =
          CASE model_number OF
          = 40(16), 41(16), 42(16), 44(16) =
            display_bit_names (1, register.value, duv$rd_pro_990_pfs_c);
          ELSE
          CASEND;

        = 8d(16) =
          CASE model_number OF
          = 40(16), 41(16), 42(16), 44(16) =
            display_bit_names (1, register.value, duv$rd_pro_990_pfs_d);
          ELSE
          CASEND;

        = 8e(16) =
          CASE model_number OF
          = 40(16), 41(16), 42(16), 44(16) =
            display_bit_names (1, register.value, duv$rd_pro_990_pfs_e);
          ELSE
          CASEND;

        = 8f(16) =
          CASE model_number OF
          = 40(16), 41(16), 42(16), 44(16) =
            display_bit_names (1, register.value, duv$rd_pro_990_pfs_f);
          ELSE
          CASEND;

        ELSE
        CASEND;
      FOREND /display_register/;
    FOREND /display_processor/;

  PROCEND display_processor_registers;
?? OLDTITLE ??
?? NEWTITLE := 'display_register_groups', EJECT ??

{ PURPOSE:
{   This procedure displays the register in groups of sixteen bits.

  PROCEDURE display_register_groups
    (    register_value: ARRAY [1 .. duc$de_max_register_length] OF 0 .. 0ff(16));

    TYPE
      t$array_or_string = RECORD
        CASE boolean OF
        = TRUE =
          array_part: ARRAY [1 .. (duc$de_max_register_length DIV 2)] OF t$display_group,
        = FALSE =
          string_part: string (20),
        CASEND,
      RECEND,

      t$display_group = RECORD
        first_half: string (2),
        second_half: string (2),
        blank_space: string (1),
      RECEND;

    VAR
      array_or_string: t$array_or_string,
      byte_number: 0 .. duc$de_max_register_length,
      group_index: 1 .. duc$de_max_register_length,
      ignore_status: ost$status;

    byte_number := 0;
    FOR group_index := 1 TO (duc$de_max_register_length DIV 2) DO
      byte_number := byte_number + 1;
      array_or_string.array_part [group_index].first_half := 'XX';
      clp$convert_integer_to_rjstring (register_value [byte_number], 16, FALSE, '0',
            array_or_string.array_part [group_index].first_half, ignore_status);
      byte_number := byte_number + 1;
      array_or_string.array_part [group_index].second_half := 'XX';
      clp$convert_integer_to_rjstring (register_value [byte_number], 16, FALSE, '0',
            array_or_string.array_part [group_index].second_half, ignore_status);
      array_or_string.array_part [group_index].blank_space := ' ';
    FOREND;
    clp$put_partial_display (v$display_control, array_or_string.string_part, clc$no_trim, amc$continue,
          ignore_status);
    clp$put_partial_display (v$display_control, '      ', clc$no_trim, amc$continue, ignore_status);

  PROCEND display_register_groups;
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_maintenance_reg', EJECT ??

{ PURPOSE:
{   This procedure displays the maintenance register values for the PROCESSOR(s), the MEMORY and the IOU(s).

  PROCEDURE [XDCL] dup$display_maintenance_reg
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      default_list: ARRAY [1 .. 2] OF dut$default_change_list_entry,
      ignore_status: ost$status,
      local_status: ost$status,
      output_display_opened: boolean,
      page_width: amt$page_width,
      ring_attributes: amt$ring_attributes;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (v$display_control, ignore_status);
      IFEND;

    PROCEND clean_up;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    { Change the default value for the PROCESSOR and IOU parameters.

    default_list [1].default_name := duc$dp_processor;
    default_list [1].number := p$processor;
    default_list [2].default_name := duc$dp_iou;
    default_list [2].number := p$iou;
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

      { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, v$display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        v$display_control := duv$execution_environment.output_file.display_control;
        v$display_control.line_number := v$display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      { Setup the length of the output line.

      IF v$display_control.page_width > 132 THEN
        page_width := 132;
      ELSEIF v$display_control.page_width < 80 THEN
        page_width := 80;
      ELSE
        page_width := v$display_control.page_width;
      IFEND;
      IF (page_width - c$column_number + 9) > duc$de_max_definition_length THEN
        v$line_length := duc$de_max_definition_length;
      ELSE
        v$line_length := page_width - c$column_number + 9;
      IFEND;

      { Display the processor registers.

      IF (pvt [p$element].value^.keyword_value = 'ALL') OR
            (pvt [p$element].value^.keyword_value = 'PROCESSOR') THEN
        display_processor_registers (local_status);
        IF NOT local_status.normal THEN
          dup$display_message (local_status, v$display_control);
        IFEND;
      IFEND;

      { Display the memory registers.

      IF (pvt [p$element].value^.keyword_value = 'ALL') OR
            (pvt [p$element].value^.keyword_value = 'MEMORY') THEN
        display_memory_registers (local_status);
        IF NOT local_status.normal THEN
          dup$display_message (local_status, v$display_control);
        IFEND;
      IFEND;

      { Display the iou registers.

      IF (pvt [p$element].value^.keyword_value = 'ALL') OR
            (pvt [p$element].value^.keyword_value = 'INPUT_OUTPUT_UNIT') THEN
        display_iou_registers (local_status);
        IF NOT local_status.normal THEN
          dup$display_message (local_status, v$display_control);
        IFEND;
      IFEND;
    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (v$display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_maintenance_reg;
MODEND dum$display_maintenance_reg;
*DECK DECK=DUM$DISPLAY_MAT_CHANGE_REQUEST EXPAND=TRUE
PROCEDURE dum$display_mat_change_request, display_mat_change_request, dismcr (
  address, a, pva: integer = 1400006088(16)
  output, o: file = $output
  status)

"THIS PROCEDURE DISPLAYS DMT$MAT_CHANGE_REQUEST AND ITS ASSOCIATED
" DMT$MAT_CHANGES

  crev s status
  detf $local.djh_mat_change_requests status=s
  setfa $local.djh_mat_change_requests fc=legible pf=continuous pw=80
  out_file = '$local.djh_mat_change_requests'

  putl '                     MAT CHANGE REQUESTS' o=$fname(out_file//'.$eoi')

  dism $value(address) b=11 o=$fname(out_file//'.$eoi')

  request_addr = $value(address)
  code = $mem(request_addr, 1, m)
  avti = $mem(request_addr+1, 2, m)
  numb = $mem(request_addr+3, 2, m)
  changes_addr = $mem(request_addr+5, 6, m)
  putl ' ' o=$fname(out_file//'.$eoi')
  putl ' code = '//$strrep(code)//', avt index = '//$strrep(avti)//', number of changes = '//$strrep(numb) ..
        o=$fname(out_file//'.$eoi')
  putl ' ' o=$fname(out_file//'.$eoi')

  dism changes_addr b=(numb*4) e=m o=$fname(out_file//'.$eoi')
  putl ' ' o=$fname(out_file//'.$eoi')

  FOR index = 1 TO numb DO
    addr = changes_addr + ((index - 1)* 4)
    style = $mem(addr, 1, m)
    dau = $mem(addr+1, 3, m)
    putl ' '//$strrep(index)//'.  style = A'//$strrep(style)//', dau address = '//$strrep(dau) ..
          o=$fname(out_file//'.$eoi')
  FOREND

  copf $fname(out_file) $value(output)

  detf $local.djh_mat_change_requests status=s

PROCEND dum$display_mat_change_request
*DECK DECK=DUM$DISPLAY_MEMORY_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Memory Command' ??                                             
MODULE dum$display_memory_command;                                                                            
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains the code for the display_memory command.                                             
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc cle$ecc_parsing                                                                                        
*copyc duc$dump_analyzer_constants                                                                            
*copyc due$exception_condition_codes                                                                          
?? POP ??                                                                                                     
*copyc clp$close_display                                                                                      
*copyc clp$open_display_reference                                                                             
*copyc clp$put_display                                                                                        
*copyc dup$access_real_memory                                                                                 
*copyc dup$copy_virtual_memory_pva                                                                            
*copyc dup$copy_virtual_memory_sva                                                                            
*copyc dup$display_data                                                                                       
*copyc dup$display_message                                                                                    
*copyc dup$evaluate_parameters                                                                                
*copyc dup$new_page_procedure                                                                                 
*copyc dup$retrieve_exchange_package                                                                          
*copyc osp$append_status_integer                                                                              
*copyc osp$append_status_parameter                                                                            
*copyc osp$disestablish_cond_handler                                                                          
*copyc osp$establish_block_exit_hndlr                                                                         
*copyc osp$set_status_abnormal                                                                                
?? EJECT ??                                                                                                   
*copyc duv$dump_environment_p                                                                                 
*copyc duv$execution_environment                                                                              
*copyc duv$title_data                                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$display_memory_command', EJECT ??                                                         
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays memory from the restart file.                                                     
                                                                                                              
  PROCEDURE [XDCL] dup$display_memory_command                                                                 
    (    parameter_list: clt$parameter_list;                                                                  
     VAR status: ost$status);                                                                                 
                                                                                                              
{ PROCEDURE display_memory, dism (                                                                            
{   address, a: integer = $required                                                                           
{   bytes, b: integer 0..duc$maximum_memory_display = 8                                                       
{   exchange, e: any of                                                                                       
{       key                                                                                                   
{         (active a) (monitor m) (job j)                                                                      
{       keyend                                                                                                
{       integer 0..0ffffffff(16)                                                                              
{     anyend = 0ffffffff(16)                                                                                  
{   processor, p: integer 0..3 = 0                                                                            
{   address_mode, am: key                                                                                     
{       (process_virtual_address pva) (system_virtual_address sva) (real_memory_address rma)                  
{     keyend = process_virtual_address                                                                        
{   display_option, do: list 1..2 of key                                                                      
{        (numeric n) (ascii a) (display_code dc)                                                              
{     keyend = (numeric ascii)                                                                                
{   title, t: string 1..31 = 'display_memory'                                                                 
{   radix, r: integer 8..16 = 16                                                                              
{   repeat_count, rc: integer = 0                                                                             
{   output, o: file                                                                                           
{   status)                                                                                                   
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 21] of clt$pdt_parameter_name,                                                       
      parameters: array [1 .. 11] of clt$pdt_parameter,                                                       
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type3: 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 .. 6] of clt$keyword_specification,                                         
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$integer_type_qualifier,                                                              
        recend,                                                                                               
        default_value: string (13),                                                                           
      recend,                                                                                                 
      type4: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type5: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$keyword_type_qualifier,                                                                
        keyword_specs: array [1 .. 6] of clt$keyword_specification,                                           
        default_value: string (23),                                                                           
      recend,                                                                                                 
      type6: 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 .. 6] of clt$keyword_specification,                                         
        recend,                                                                                               
        default_value: string (15),                                                                           
      recend,                                                                                                 
      type7: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$string_type_qualifier,                                                                 
        default_value: string (16),                                                                           
      recend,                                                                                                 
      type8: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (2),                                                                            
      recend,                                                                                                 
      type9: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type10: record                                                                                          
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
      type11: record                                                                                          
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [92, 1, 22, 11, 37, 20, 951],                                                                             
    clc$command, 21, 11, 1, 0, 0, 0, 11, ''], [                                                               
    ['A                              ',clc$abbreviation_entry, 1],                                            
    ['ADDRESS                        ',clc$nominal_entry, 1],                                                 
    ['ADDRESS_MODE                   ',clc$nominal_entry, 5],                                                 
    ['AM                             ',clc$abbreviation_entry, 5],                                            
    ['B                              ',clc$abbreviation_entry, 2],                                            
    ['BYTES                          ',clc$nominal_entry, 2],                                                 
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 6],                                                 
    ['DO                             ',clc$abbreviation_entry, 6],                                            
    ['E                              ',clc$abbreviation_entry, 3],                                            
    ['EXCHANGE                       ',clc$nominal_entry, 3],                                                 
    ['O                              ',clc$abbreviation_entry, 10],                                           
    ['OUTPUT                         ',clc$nominal_entry, 10],                                                
    ['P                              ',clc$abbreviation_entry, 4],                                            
    ['PROCESSOR                      ',clc$nominal_entry, 4],                                                 
    ['R                              ',clc$abbreviation_entry, 8],                                            
    ['RADIX                          ',clc$nominal_entry, 8],                                                 
    ['RC                             ',clc$abbreviation_entry, 9],                                            
    ['REPEAT_COUNT                   ',clc$nominal_entry, 9],                                                 
    ['STATUS                         ',clc$nominal_entry, 11],                                                
    ['T                              ',clc$abbreviation_entry, 7],                                            
    ['TITLE                          ',clc$nominal_entry, 7]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [2, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 2                                                                                                 
    [6, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 3                                                                                                 
    [10, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 269,                        
  clc$optional_default_parameter, 0, 13],                                                                     
{ PARAMETER 4                                                                                                 
    [14, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 5                                                                                                 
    [3, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,                        
  clc$optional_default_parameter, 0, 23],                                                                     
{ PARAMETER 6                                                                                                 
    [7, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 245,                        
  clc$optional_default_parameter, 0, 15],                                                                     
{ PARAMETER 7                                                                                                 
    [21, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,                          
  clc$optional_default_parameter, 0, 16],                                                                     
{ PARAMETER 8                                                                                                 
    [16, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,                         
  clc$optional_default_parameter, 0, 2],                                                                      
{ PARAMETER 9                                                                                                 
    [18, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 10                                                                                                
    [12, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],                                                                                                       
{ PARAMETER 11                                                                                                
    [19, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name],                                                         
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,                      
  clc$optional_parameter, 0, 0]],                                                                             
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],                                       
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, duc$maximum_memory_display, 10],                                           
    '8'],                                                                                                     
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],                                           
    FALSE, 2],                                                                                                
    229, [[1, 0, clc$keyword_type], [6], [                                                                    
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                 
      ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],                      
      ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                 
      ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 3],                      
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                 
      ['MONITOR                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]                      
      ],                                                                                                      
    20, [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]]                                                    
    ,                                                                                                         
    '0ffffffff(16)'],                                                                                         
{ PARAMETER 4                                                                                                 
    [[1, 0, clc$integer_type], [0, 3, 10],                                                                    
    '0'],                                                                                                     
{ PARAMETER 5                                                                                                 
    [[1, 0, clc$keyword_type], [6], [                                                                         
    ['PROCESS_VIRTUAL_ADDRESS        ', clc$nominal_entry, clc$normal_usage_entry, 1],                        
    ['PVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                   
    ['REAL_MEMORY_ADDRESS            ', clc$nominal_entry, clc$normal_usage_entry, 3],                        
    ['RMA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                   
    ['SVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                   
    ['SYSTEM_VIRTUAL_ADDRESS         ', clc$nominal_entry, clc$normal_usage_entry, 2]]                        
    ,                                                                                                         
    'process_virtual_address'],                                                                               
{ PARAMETER 6                                                                                                 
    [[1, 0, clc$list_type], [229, 1, 2, 0, FALSE, FALSE],                                                     
      [[1, 0, clc$keyword_type], [6], [                                                                       
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                 
      ['ASCII                          ', clc$nominal_entry, clc$normal_usage_entry, 2],                      
      ['DC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                 
      ['DISPLAY_CODE                   ', clc$nominal_entry, clc$normal_usage_entry, 3],                      
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                 
      ['NUMERIC                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]                      
      ]                                                                                                       
    ,                                                                                                         
    '(numeric ascii)'],                                                                                       
{ PARAMETER 7                                                                                                 
    [[1, 0, clc$string_type], [1, 31, FALSE],                                                                 
    '''display_memory'''],                                                                                    
{ PARAMETER 8                                                                                                 
    [[1, 0, clc$integer_type], [8, 16, 10],                                                                   
    '16'],                                                                                                    
{ PARAMETER 9                                                                                                 
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10],                                        
    '0'],                                                                                                     
{ PARAMETER 10                                                                                                
    [[1, 0, clc$file_type]],                                                                                  
{ PARAMETER 11                                                                                                
    [[1, 0, clc$status_type]]];                                                                               
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$address = 1,                                                                                          
      p$bytes = 2,                                                                                            
      p$exchange = 3,                                                                                         
      p$processor = 4,                                                                                        
      p$address_mode = 5,                                                                                     
      p$display_option = 6,                                                                                   
      p$title = 7,                                                                                            
      p$radix = 8,                                                                                            
      p$repeat_count = 9,                                                                                     
      p$output = 10,                                                                                          
      p$status = 11;                                                                                          
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 11] of clt$parameter_value;                                                            
                                                                                                              
    CONST                                                                                                     
      c$partial_count = 10000(16);                                                                            
                                                                                                              
    VAR                                                                                                       
      access_data: dut$access_data,                                                                           
      address: dut$ee_address_parameter,                                                                      
      bytes: ost$segment_length,                                                                              
      bytes_allowed: 0 .. c$partial_count,                                                                    
      bytes_pushed: 0 .. c$partial_count,                                                                     
      bytes_returned: ost$segment_length,                                                                     
      default_list: ARRAY [1 .. 3] OF dut$default_change_list_entry,                                          
      display_control: clt$display_control,                                                                   
      display_count: integer,                                                                                 
      display_string: string (osc$max_string_size),                                                           
      end_of_input_file: boolean,                                                                             
      exchange_package_p: ^dut$exchange_package,                                                              
      ignore_status: ost$status,                                                                              
      invalid_segment_issued: boolean,                                                                        
      local_status: ost$status,                                                                               
      memory_buffer_p: ^SEQ ( * ),                                                                            
      new_byte_size: ost$segment_length,                                                                      
      output_display_opened: boolean,                                                                         
      page_fault_encountered: boolean,                                                                        
      real_memory_p: ^cell,                                                                                   
      repeat_index: integer,                                                                                  
      ring_attributes: amt$ring_attributes,                                                                   
      skip_start: ost$segment_offset,                                                                         
      skipping_page_faulted_memory: boolean,                                                                  
      some_memory_copied: boolean,                                                                            
      string_length: integer;                                                                                 
                                                                                                              
*copy dup$abort_handler                                                                                       
?? NEWTITLE := 'clean_up', EJECT ??                                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure is called from the abort handler to close the file.                                        
                                                                                                              
    PROCEDURE [INLINE] clean_up;                                                                              
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      IF output_display_opened THEN                                                                           
        clp$close_display (display_control, ignore_status);                                                   
      IFEND;                                                                                                  
                                                                                                              
    PROCEND clean_up;                                                                                         
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the EXCHANGE, PROCESSOR and ADDRESS_MODE parameters.                       
                                                                                                              
    default_list [1].default_name := duc$dp_exchange;                                                         
    default_list [1].number := p$exchange;                                                                    
    default_list [2].default_name := duc$dp_processor;                                                        
    default_list [2].number := p$processor;                                                                   
    default_list [3].default_name := duc$dp_address_mode;                                                     
    default_list [3].number := p$address_mode;                                                                
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF (duv$execution_environment.processing_options = duc$ee_po_no_memory) OR                                
          (NOT duv$dump_environment_p^.central_memory.available AND                                           
          NOT duv$dump_environment_p^.critical_memory.available) THEN                                         
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The central memory is', status);  
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF pvt [p$bytes].value^.integer_value.value = 0 THEN                                                      
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Retrieve the exchange package if needed.                                                                
                                                                                                              
    IF (pvt [p$address_mode].value^.keyword_value <> 'PROCESS_VIRTUAL_ADDRESS') AND                           
          pvt [p$exchange].specified THEN                                                                     
      osp$set_status_abnormal (duc$dump_analyzer_id, due$rma_and_exc_specified, '', status);                  
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF pvt [p$address_mode].value^.keyword_value = 'PROCESS_VIRTUAL_ADDRESS' THEN                             
      dup$retrieve_exchange_package (pvt [p$processor].value^.integer_value.value, pvt [p$exchange].value^,   
            exchange_package_p, status);                                                                      
      IF NOT status.normal THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    output_display_opened := FALSE;                                                                           
    osp$establish_block_exit_hndlr (^abort_handler);                                                          
                                                                                                              
   /display_opened/                                                                                           
    BEGIN                                                                                                     
                                                                                                              
      { Prepare the output display file.                                                                      
                                                                                                              
      IF pvt [p$output].specified THEN                                                                        
        ring_attributes.r1 := #RING (^ring_attributes);                                                       
        ring_attributes.r2 := #RING (^ring_attributes);                                                       
        ring_attributes.r3 := #RING (^ring_attributes);                                                       
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,     
              ring_attributes, display_control, status);                                                      
        IF NOT status.normal THEN                                                                             
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
        output_display_opened := TRUE;                                                                        
      ELSE                                                                                                    
        display_control := duv$execution_environment.output_file.display_control;                             
        display_control.line_number := display_control.page_length + 1;                                       
      IFEND;                                                                                                  
                                                                                                              
      duv$title_data.build_title := TRUE;                                                                     
      duv$title_data.command_name := pvt [p$title].value^.string_value^;                                      
                                                                                                              
      address.rma_part := pvt [p$address].value^.integer_value.value;                                         
      bytes := pvt [p$bytes].value^.integer_value.value;                                                      
                                                                                                              
      { Determine the number of bytes to display.  If radix <> 16 then round the number of bytes up to a full 
      { word and start displaying the data on a word boundary.                                                
                                                                                                              
      IF pvt [p$radix].value^.integer_value.value <> 16 THEN                                                  
        IF (bytes MOD 8) <> 0 THEN                                                                            
          bytes := bytes + (8 - (bytes MOD 8));                                                               
        IFEND;                                                                                                
        address.rma_part := address.rma_part - (address.rma_part MOD 8);                                      
      IFEND;                                                                                                  
                                                                                                              
      IF pvt [p$address_mode].value^.keyword_value = 'PROCESS_VIRTUAL_ADDRESS' THEN                           
        STRINGREP (display_string, string_length, 'segment =', address.pva_part.seg: #(16));                  
        clp$put_display (display_control, display_string (1, string_length), clc$no_trim, status);            
      IFEND;                                                                                                  
      memory_buffer_p := NIL;                                                                                 
                                                                                                              
      FOR repeat_index := 0 to pvt [p$repeat_count].value^.integer_value.value DO                             
                                                                                                              
        IF (pvt [p$address_mode].value^.keyword_value = 'PROCESS_VIRTUAL_ADDRESS') OR                         
              (pvt [p$address_mode].value^.keyword_value = 'SYSTEM_VIRTUAL_ADDRESS') THEN                     
          IF memory_buffer_p = NIL THEN                                                                       
            IF bytes > c$partial_count THEN                                                                   
              bytes_pushed := c$partial_count;                                                                
            ELSE                                                                                              
              bytes_pushed := bytes;                                                                          
            IFEND;                                                                                            
            PUSH memory_buffer_p: [[REP bytes_pushed OF cell]];                                               
            IF memory_buffer_p = NIL THEN                                                                     
              osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                    
              EXIT /display_opened/;  {---->                                                                  
            IFEND;                                                                                            
          IFEND;                                                                                              
                                                                                                              
          display_count := bytes;                                                                             
          page_fault_encountered := FALSE;                                                                    
          skipping_page_faulted_memory := FALSE;                                                              
          some_memory_copied := FALSE;                                                                        
          invalid_segment_issued := FALSE;                                                                    
                                                                                                              
          REPEAT                                                                                              
            RESET memory_buffer_p;                                                                            
            IF display_count >= bytes_pushed THEN                                                             
              bytes_allowed := bytes_pushed;                                                                  
            ELSE                                                                                              
              bytes_allowed := display_count;                                                                 
            IFEND;                                                                                            
            IF pvt [p$address_mode].value^.keyword_value = 'PROCESS_VIRTUAL_ADDRESS' THEN                     
              dup$copy_virtual_memory_pva (address.pva_part, exchange_package_p^,                             
                    pvt [p$processor].value^.integer_value.value, bytes_allowed, FALSE, bytes_returned,       
                    memory_buffer_p, access_data, status);                                                    
            ELSE                                                                                              
              dup$copy_virtual_memory_sva (address.sva_part, pvt [p$processor].value^.integer_value.value,    
                    bytes_allowed, FALSE, bytes_returned, memory_buffer_p, access_data, status);              
            IFEND;                                                                                            
            IF NOT status.normal AND (status.condition <> due$memory_partially_avail) THEN                    
              EXIT /display_opened/;  {---->                                                                  
            IFEND;                                                                                            
                                                                                                              
            page_fault_encountered := (access_data.page_fault AND NOT access_data.memory_found);              
                                                                                                              
            IF NOT access_data.valid_segment AND NOT invalid_segment_issued THEN                              
              invalid_segment_issued := TRUE;                                                                 
              osp$set_status_abnormal (duc$dump_analyzer_id, due$invalid_seg_trans_poss, '', local_status);   
              dup$display_message (local_status, display_control);                                            
            IFEND;                                                                                            
                                                                                                              
            IF access_data.page_fault AND access_data.memory_found THEN                                       
              osp$set_status_abnormal (duc$dump_analyzer_id, due$soft_page_fault, '', local_status);          
              IF pvt [p$address_mode].value^.keyword_value = 'PROCESS_VIRTUAL_ADDRESS' THEN                   
                osp$append_status_parameter (osc$status_parameter_delimiter, ', segment = ', local_status);   
                osp$append_status_integer (osc$status_parameter_delimiter, address.pva_part.seg, 16, TRUE,    
                      local_status);                                                                          
              ELSE                                                                                            
                osp$append_status_parameter (osc$status_parameter_delimiter, ', asid = ', local_status);      
                osp$append_status_integer (osc$status_parameter_delimiter, address.sva_part.asid.value, 16,   
                      TRUE, local_status);                                                                    
              IFEND;                                                                                          
              osp$append_status_parameter (osc$status_parameter_delimiter, ', offset = ', local_status);      
              osp$append_status_integer (osc$status_parameter_delimiter, access_data.page_fault_offset,       
                    16, TRUE, local_status);                                                                  
              dup$display_message (local_status, display_control);                                            
            IFEND;                                                                                            
                                                                                                              
            IF bytes_returned > 0 THEN                                                                        
              some_memory_copied := TRUE;                                                                     
              IF skipping_page_faulted_memory THEN                                                            
                skipping_page_faulted_memory := FALSE;                                                        
                osp$set_status_abnormal (duc$dump_analyzer_id, due$pages_skipped, '', local_status);          
                osp$append_status_integer (osc$status_parameter_delimiter, skip_start, 16, TRUE,              
                      local_status);                                                                          
                osp$append_status_integer (osc$status_parameter_delimiter, address.pva_part.offset - 1, 16,   
                      TRUE, local_status);                                                                    
                dup$display_message (local_status, display_control);                                          
              IFEND;                                                                                          
              RESET memory_buffer_p;                                                                          
              dup$display_data (pvt [p$display_option].value, TRUE,                                           
                    pvt [p$radix].value^.integer_value.value, address.pva_part.offset, bytes_returned,        
                    display_control, memory_buffer_p, end_of_input_file, status);                             
              IF NOT status.normal THEN                                                                       
                EXIT /display_opened/;  {---->                                                                
              IFEND;                                                                                          
              display_count := display_count - bytes_returned;                                                
            IFEND;                                                                                            
                                                                                                              
            IF access_data.page_fault THEN                                                                    
              address.pva_part.offset := access_data.next_page_offset;                                        
              IF NOT access_data.memory_found THEN                                                            
                IF NOT skipping_page_faulted_memory THEN                                                      
                  skipping_page_faulted_memory := TRUE;                                                       
                  skip_start := access_data.page_fault_offset;                                                
                IFEND;                                                                                        
                display_count := display_count - (access_data.next_page_offset -                              
                      access_data.page_fault_offset);                                                         
              IFEND;                                                                                          
            ELSE                                                                                              
              address.rma_part := address.rma_part + bytes_returned;                                          
            IFEND;                                                                                            
          UNTIL display_count <= 0;                                                                           
                                                                                                              
          IF page_fault_encountered THEN                                                                      
            IF skipping_page_faulted_memory THEN                                                              
              osp$set_status_abnormal (duc$dump_analyzer_id, due$pages_skipped, '', local_status);            
              osp$append_status_integer (osc$status_parameter_delimiter, skip_start, 16, TRUE,                
                    local_status);                                                                            
              osp$append_status_integer (osc$status_parameter_delimiter,                                      
                    (access_data.next_page_offset + display_count - 1), 16, TRUE, local_status);              
              dup$display_message (local_status, display_control);                                            
            IFEND;                                                                                            
            IF some_memory_copied THEN                                                                        
              osp$set_status_abnormal (duc$dump_analyzer_id, due$incomplete_memory_display,                   
                    ' a page fault was encountered.', status);                                                
            ELSE                                                                                              
              osp$set_status_abnormal (duc$dump_analyzer_id, due$no_memory_displayed,                         
                    ' a page fault was encountered.', status);                                                
            IFEND;                                                                                            
            EXIT /display_opened/;  {---->                                                                    
          IFEND;                                                                                              
                                                                                                              
        ELSE  { address_mode = REAL_MEMORY_ADDRESS                                                            
                                                                                                              
          dup$access_real_memory (bytes, address.rma_part, real_memory_p, new_byte_size, status);             
          IF NOT status.normal AND (status.condition <> due$memory_partially_avail) THEN                      
            EXIT /display_opened/;  {---->                                                                    
          IFEND;                                                                                              
          RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO real_memory_p;     
          bytes_returned := new_byte_size;                                                                    
                                                                                                              
          REPEAT                                                                                              
            IF bytes_returned >= c$partial_count THEN                                                         
              bytes_allowed := c$partial_count;                                                               
            ELSE                                                                                              
              bytes_allowed := bytes_returned;                                                                
            IFEND;                                                                                            
            NEXT memory_buffer_p: [[REP bytes_allowed OF cell]] IN                                            
                  duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                    
            IF memory_buffer_p = NIL THEN                                                                     
              osp$set_status_abnormal (duc$dump_analyzer_id, due$incomplete_memory_display,                   
                    ' the remaining memory is not contained in the dump.', status);                           
              EXIT /display_opened/;  {---->                                                                  
            IFEND;                                                                                            
            dup$display_data (pvt [p$display_option].value, TRUE, pvt [p$radix].value^.integer_value.value,   
                  address.rma_part, bytes_allowed, display_control, memory_buffer_p, end_of_input_file,       
                  status);                                                                                    
            IF NOT status.normal THEN                                                                         
              EXIT /display_opened/;  {---->                                                                  
            IFEND;                                                                                            
            bytes_returned := bytes_returned - bytes_allowed;                                                 
            address.rma_part := address.rma_part + bytes_allowed;                                             
          UNTIL bytes_returned <= 0;                                                                          
          IF new_byte_size < bytes THEN                                                                       
            osp$set_status_abnormal (duc$dump_analyzer_id, due$incomplete_memory_display,                     
                  ' the remaining memory is not contained in the dump.', local_status);                       
            dup$display_message (local_status, display_control);                                              
          IFEND;                                                                                              
        IFEND;                                                                                                
      FOREND;                                                                                                 
    END /display_opened/;                                                                                     
                                                                                                              
    IF output_display_opened THEN                                                                             
      clp$close_display (display_control, ignore_status);                                                     
    IFEND;                                                                                                    
    osp$disestablish_cond_handler;                                                                            
                                                                                                              
  PROCEND dup$display_memory_command;                                                                         
MODEND dum$display_memory_command;                                                                            
*DECK DECK=DUM$DISPLAY_MF_ALLOCATION_TABLE EXPAND=TRUE
PROCEDURE dum$display_mf_allocation_table, display_mf_allocation_table, dismat (
  avt_index, ai: any of
      integer 0..65536
      key
        all
      keyend
    anyend = all
  output, o: file = $output
  help, h: file = $null
  display_option, do: key
      (brief, b)
      (full, f)
    keyend = brief
  verify_mat, vm: boolean = false
  status)

  WHEN any_fault DO
    putl ' entered dismat condition handler - enter commands or exit_proc to abort'
    disv osv$status
    include_file command
  WHENEND

  IF $specified(help) THEN
COLLECT_TEXT o=$value(help) until='HELPEND'
DISPLAY_MF_ALLOCATION_TABLE or DISMAT

  This procedure will display the mainframe allocation table for a mass
storage device and describe the contents of selected fields of the table.
This procedure assumes the user has previously selected the correct exchange
package by available analyze_dump commands.

PARAMETERS:

AVT_INDEX, AI: integer 1..50 or key all
  This parameter selects the active volume table index of the individual
entry to be displayed if an integer is entered.  All entries will be dis-
played if the keyword "all" is entered.  This parameter defaults to "all".

OUTPUT, O: file
  This parameter selects the file name to receive the data.  This para-
meter is defaulted to $output.  If a file name other than $output is
entered the data will be formated correctly for printer disposition and
will be sent to the file  "$asis".

DISPLAY_OPTIONS, DO: key full, f, brief, b
  This parameter selects the option of displaying the contents of memory
and the description of the selected fields (full), or the brief mode of
the descriptions only.  This parameter defaults to brief.

VERIFY_MAT, VM: boolean
  This option, if set to true, will verify the MAT chains for correct
linkage and display the results. This parameter defaults to false.

STATUS

WARNINGS/KNOWN DEFICIENCIES:
  None.

ERROR HANDLER
  When any fatal error is encountered a condition handler is invoked and
the following message will appear:
 "entered dismat condition handler - enter commands or exit_proc to abort".
This will be followed by the error status.  To exit the handler enter:
 "exit_proc".

HELPEND
    EXIT_PROC
  IFEND

  create_variable name=output_file kind=string
  create_variable name=blank_line kind=string value='                                                    '
  create_variable name=type_index_a kind=integer value=0
  create_variable name=type_index_b kind=integer value=1
  create_variable name=alloc_offset_count kind=integer value=0
  create_variable name=style_offset_count kind=integer value=0
  create_variable name=line_first_part kind=string
  create_variable name=line_secnd_part kind=string
  create_variable name=blank_fill_count kind=integer
  create_variable name=column_two_num kind=integer value=40
  create_variable name=column_2_num kind=integer value=15
  create_variable name=column_3_num kind=integer value=43
  create_variable name=column_4_num kind=integer value=53
  create_variable name=ls kind=status

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  avte = 'AVTE'
  pavt = $symbol_address(dmv$p_active_volume_table)
  avt = $memory(pavt)
  avt_size = $memory(pavt+6 4)
  lowest_avt_ordinal = $memory(pavt+10 4)
  avt_entry_size = $memory(pavt+14 4)
  number_of_avt_entries = avt_size/avt_entry_size
  highest_avt_ordinal = lowest_avt_ordinal+number_of_avt_entries-1

" AVT offsets "

  avte_offset = 0b(16)
  mat_pointer_offset = 64(16)
  recorded_vsn_offset = 88(16)

" MAT offsets "

  bytes_per_dau_offset = 2
  bytes_per_mau_offset = 4
  mau_per_dau_offset = 6
  dau_per_position_offset = 7
  positions_per_device_offset = 8
  default_allocation_size_offset = 0a(16)
  default_transfer_size_offset = 0d(16)
  starting_position_offset = 10(16)
  start_search_offset = 12(16)
  avail_alloc_unit_offset = 1e(16)
  allocation_chains_offset = 3c(16)
  minimum_space_offset = 50(16)
  maximum_space_offset = 53(16)
  available_space_offset = 56(16)
  leftover_space_offset = 59(16)
  allocated_space_offset = 5c(16)
  mat_too_full_offset = 77(16)
  available_dat_space_offset = 78(16)
  dat_threshold_offset = 7b(16)
  recovery_threshold_offset = 7e(16)
  warning_threshold_offset = 81(16)
  p_mat_bit_map_offset = 84(16)
  mat_entry_array_offset = 96(16)

" MAT array entry offsets "

  allocation_style_offset = 0
  forward_link_offset = 4
  mat_entry_size = 6

  max_allocation_style = 9
  max_device_position = 1629
  nil_link = max_device_position + 1

  IF $value_kind(avt_index) = 'INTEGER' THEN
    avt_ordinal = $value(avt_index)

    IF (avt_ordinal<lowest_avt_ordinal) OR (avt_ordinal>highest_avt_ordinal) THEN
      put_line 'avt_ordinal '//$strrep(avt_ordinal)//' is out of range'
      EXIT_PROC
    IFEND

    lowest_avt_ordinal = avt_ordinal
    highest_avt_ordinal = avt_ordinal

  IFEND

search_avt: ..
  FOR avt_ordinal = lowest_avt_ordinal TO highest_avt_ordinal DO

    avt_entry = avt+(avt_ordinal-1)*avt_entry_size
    entry_in_use = ($memory_string(avt_entry+avte_offset, 4) = avte)

    IF NOT entry_in_use THEN
      put_line ' avt entry'//$strrep(avt_ordinal)//' not in use' o=$fname(output_file)
    ELSE
      mat = $memory(avt_entry+mat_pointer_offset)

      IF $strrep($value(output)) = '$OUTPUT' THEN
        put_line '1                         MAT FOR '//$memory_string(avt_entry+recorded_vsn_offset, 6) ..
              o=$fname(output_file)
      IFEND

      IF display_option = 'FULL' THEN
        display_memory mat b=mat_entry_array_offset ..
              title='MAT FOR '//$memory_string(avt_entry+recorded_vsn_offset, 6) o=$fname(output_file)
      IFEND

      put_line '                          avt index= '//$strrep($memory(mat, 2)) o=$fname(output_file)
      line_first_part = ' bytes per dau = '//$strrep($memory(mat+bytes_per_dau_offset, 2))
      line_secnd_part = ' bytes per mau = '//$strrep($memory(mat+bytes_per_mau_offset, 2))
      blank_fill_count = (column_two_num)-($strlen(line_first_part))
      put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
            o=$fname(output_file)

      line_first_part = ' daus per cylinder = '//$strrep($memory(mat+dau_per_position_offset, 1))
      line_secnd_part = ' mau per dau = '//$strrep($memory(mat+mau_per_dau_offset, 1))
      blank_fill_count = (column_two_num)-($strlen(line_first_part))
      put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
            o=$fname(output_file)

      line_first_part = ' cylinders per device = '//$strrep($memory(mat+positions_per_device_offset, 2))
      line_secnd_part = ' starting cylinder = '//$strrep($memory(mat+starting_position_offset, 2))
      blank_fill_count = (column_two_num)-($strlen(line_first_part))
      put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
            o=$fname(output_file)

      line_first_part = ' default allocation size = '//$strrep($memory(mat+default_allocation_size_offset, 3))
      line_secnd_part = ' default transfer size = '//$strrep($memory(mat+default_transfer_size_offset, 3))
      blank_fill_count = (column_two_num)-($strlen(line_first_part))
      put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
            o=$fname(output_file)

      line_first_part = ' start search cylinder = '//$strrep($memory(mat+start_search_offset, 2))
      line_secnd_part = ' available DAU bit map = '//$strrep($memory(mat+p_mat_bit_map_offset), 16)//'(16)'
      blank_fill_count = (column_two_num)-($strlen(line_first_part))
      put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
            o=$fname(output_file)

      line_first_part = ' minimum MAT space = '//$strrep($memory(mat+minimum_space_offset, 3))
      line_secnd_part = ' maximum MAT space = '//$strrep($memory(mat+maximum_space_offset, 3))
      blank_fill_count = (column_two_num)-($strlen(line_first_part))
      put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
            o=$fname(output_file)

      line_first_part = ' available MAT space = '//$strrep($memory(mat+available_space_offset, 3))
      line_secnd_part = ' leftover MAT space = '//$strrep($memory(mat+leftover_space_offset, 3))
      blank_fill_count = (column_two_num)-($strlen(line_first_part))
      put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
            o=$fname(output_file)

      total_space = $memory(mat+available_space_offset, 3)+$memory(mat+available_dat_space_offset, 3)
      line_first_part = ' total space = '//$strrep(total_space)
      IF ($memory(mat+mat_too_full_offset, 1) = 1) THEN
        line_secnd_part = ' MAT too full = TRUE'
      ELSE
        line_secnd_part = ' MAT too full = FALSE'
      IFEND
      blank_fill_count = (column_two_num)-($strlen(line_first_part))
      put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
            o=$fname(output_file)

      line_first_part = ' available DAT space = '//$strrep($memory(mat+available_dat_space_offset, 3))
      line_secnd_part = ' DAT threshold = '//$strrep($memory(mat+dat_threshold_offset, 3))
      blank_fill_count = (column_two_num)-($strlen(line_first_part))
      put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
            o=$fname(output_file)

      line_first_part = ' recovery threshold = '//$strrep($memory(mat+recovery_threshold_offset, 3))
      line_secnd_part = ' warning threshold = '//$strrep($memory(mat+warning_threshold_offset, 3))
      blank_fill_count = (column_two_num)-($strlen(line_first_part))
      put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
            o=$fname(output_file)

      put_line ' ALLOCATED SPACE:                        ALLOCATED SPACE:' o=$fname(output_file)

      line_first_part = '   permanent = '//$strrep($memory(mat+allocated_space_offset, 3))
      line_secnd_part = '  job named = '//$strrep($memory(mat+allocated_space_offset+15, 3))
      blank_fill_count = (column_two_num)-($strlen(line_first_part))
      put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
            o=$fname(output_file)

      line_first_part = '   catalog = '//$strrep($memory(mat+allocated_space_offset+12, 3))
      line_secnd_part = '  job unnamed = '//$strrep($memory(mat+allocated_space_offset+18, 3))
      blank_fill_count = (column_two_num)-($strlen(line_first_part))
      put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
            o=$fname(output_file)

      line_first_part = '   device = '//$strrep($memory(mat+allocated_space_offset+3, 3))
      line_secnd_part = '  global unnamed = '//$strrep($memory(mat+allocated_space_offset+21, 3))
      blank_fill_count = (column_two_num)-($strlen(line_first_part))
      put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
            o=$fname(output_file)

      put_line ' AVAILABLE ALLOCATION UNITS:             ALLOCATION CHAINS:' o=$fname(output_file)

      type_index_a = 0
      type_index_b = 1
      alloc_offset_count = 0
      style_offset_count = 0

      FOR index = 1 TO 5 DO

" Display available allocation units"
        line_first_part = '   A'//$strrep(type_index_a)//'='// $strrep(..
              $memory(mat+avail_alloc_unit_offset+alloc_offset_count, 3))
        alloc_offset_count = alloc_offset_count+3
        IF type_index_b < 9 THEN
          line_secnd_part = 'A'//..
$strrep(type_index_b)//'='//$strrep($memory(mat+avail_alloc_unit_offset+alloc_offset_count, 3))
        ELSE
          line_secnd_part = 'ACYL'//'='//$strrep($memory(mat+avail_alloc_unit_offset+alloc_offset_count, 3))
        IFEND
        blank_fill_count = (column_2_num)-($strlen(line_first_part))
        line_first_part = line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part

" Display allocation unit chains"
        line_secnd_part = 'A'//..
$strrep(type_index_a)//'='//$strrep($memory(mat+allocation_chains_offset+style_offset_count, 2))
        style_offset_count = style_offset_count + 2
        blank_fill_count = (column_3_num)-($strlen(line_first_part))
        line_first_part = line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part
        IF type_index_b < 9 THEN
          line_secnd_part = 'A'//..
$strrep(type_index_b)//'='//$strrep($memory(mat+allocation_chains_offset+style_offset_count, 2))
        ELSE
          line_secnd_part = 'ACYL'//'='//$strrep($memory(mat+allocation_chains_offset+style_offset_count, 2))
        IFEND
        blank_fill_count = (column_4_num)-($strlen(line_first_part))
        put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
              o=$fname(output_file)
        type_index_a = type_index_a + 2
        type_index_b = type_index_b + 2
        alloc_offset_count = alloc_offset_count + 3
        style_offset_count = style_offset_count + 2
      FOREND

      IF $value(verify_mat) THEN
        put_line '  '
        put_line '                                  VERIFYING MAT' o=$fname(output_file)
        mat = $memory(avt_entry+mat_pointer_offset)
        allocation_chain_link = mat + allocation_chains_offset
        mat_entry_array = mat + mat_entry_array_offset
      verify_chains: ..
        FOR allocation_style = 0 TO max_allocation_style DO
          IF allocation_style < 9 THEN
            line_first_part = ' verifying chain for style a'//$strrep(allocation_style)
          ELSE
            line_first_part = ' verifying chain for style acyl'
          IFEND

          link = $memory((allocation_style)*2+allocation_chain_link, 2)
          IF link = nil_link THEN
            line_secnd_part = ' this chain is nil'
            blank_fill_count = (column_two_num)-($strlen(line_first_part))
            put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
                  o=$fname(output_file)
            CYCLE verify_chains
          IFEND
          delete_variable links status=ls
          create_variable links k=boolean d=0..nil_link value=false
          message_sent = false
          crossed_links = 0
        verify_chain: ..
          BLOCK
            FOR entry = 0 TO max_device_position DO
              mat_entry = mat_entry_array + link * mat_entry_size
              forward_link = $memory(mat_entry+forward_link_offset, 2)
              style = $memory(mat_entry+allocation_style_offset, 1)
              IF links(forward_link) THEN
                line_secnd_part = '    *** circular linkage detected:'
                blank_fill_count = (column_two_num)-($strlen(line_first_part))
                put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
                      o=$fname(output_file)
                dism a=mat_entry b=mat_entry_size o=$fname(output_file)
                CYCLE verify_chains
              ELSEIF (style <> allocation_style) AND (allocation_style <= max_allocation_style) THEN
                IF NOT message_sent THEN
                  line_secnd_part = '    *** crossed linkage detected:'
                  blank_fill_count = (column_two_num)-($strlen(line_first_part))
                  put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
                        o=$fname(output_file)
                  dism a=mat_entry b=mat_entry_size o=$fname(output_file)
                  put_line '    further display of crossed linkage entries suppressed' o=$fname(output_file)
                  message_sent = true
                IFEND
                crossed_links = crossed_links + 1
              IFEND
              EXIT verify_chain WHEN forward_link = nil_link
              links(forward_link) = true
              link = forward_link
            FOREND
            put_line '    *** possible circular linkage:' o=$fname(output_file)
            put_line '    The maximum number of links has been exceeded.' o=$fname(output_file)
          BLOCKEND verify_chain
          IF crossed_links > 0 THEN
            put_line '    '//$strrep(crossed_links)//' crossed links detected.' o=$fname(output_file)
          IFEND
          line_secnd_part = ' '//$strrep(entry+1)//' entries verified'
          blank_fill_count = (column_two_num)-($strlen(line_first_part))
          put_line line_first_part//$substr(blank_line, 1, blank_fill_count)//line_secnd_part ..
                o=$fname(output_file)
        FOREND verify_chains
      IFEND
    IFEND
  FOREND search_avt

PROCEND dum$display_mf_allocation_table
*DECK DECK=DUM$DISPLAY_MONITOR_FAULTS EXPAND=TRUE
PROCEDURE dum$display_monitor_faults, display_monitor_fault, dismf (
  core_debugger, cd: boolean = false
  output, o: file = $output
  status)

  " This procedure displays the current tasks monitor faults.
  " If the task is in the system core debugger then the
  " core_debugger_parameter should be specified as TRUE
  "  This requires accessed to debug tables for module tmm$dispatcher and
  " sym$debug if core_debugger=true

  crev segment_access_fault k=string d=1..11
  set_file_attributes output fc=legible pf=continuous pw=78
  segment_access_fault(1) = 'mmc$sac_read_beyond_eoi'
  segment_access_fault(2) = 'mmc$sac_read_write_beyond_msl'
  segment_access_fault(3) = 'mmc$sac_segment_access_error'
  segment_access_fault(4) = 'mmc$sac_key_lock_violation'
  segment_access_fault(5) = 'mmc$sac_ring_violation'
  segment_access_fault(6) = 'mmc$sac_io_read_error'
  segment_access_fault(7) = 'mmc$sac_no_append_permission'
  segment_access_fault(8) = 'mmc$sac_tape_system_failure'
  segment_access_fault(9) = 'mmc$sac_file_server_terminated'
  segment_access_fault(10) = 'mmc$sac_pf_space_limit_exceeded'
  segment_access_fault(11) = 'mmc$sac_tf_space_limit_exceeded'

  current = $current_module
  IF core_debugger THEN
    chadm sym$debug
    p_monitor_faults = $pv(^monitor_faults)
    chadm m=tmm$dispatcher
  ELSE
    chadm m=tmm$dispatcher
    xcb = 0
    dum$get_xcb xcb
    p_monitor_faults = $pv(^?xcb.ost$execution_control_block.monitor_faults)
  IFEND
  "dispv ?p_monitor_faults.tmt$monitor_fault_buffer  o=output
  faults_present = 0
  FOR fault = $pv(lowervalue(0.tmt$monitor_fault_buffers)) TO $pv(uppervalue(0.tmt$monitor_fault_buffers)) DO
    IF $pv(?p_monitor_faults.tmt$monitor_fault_buffer.present[?fault]) THEN
      faults_present = faults_present + 1
      pva = $pv(?p_monitor_faults.tmt$monitor_fault_buffer.buffer[?fault].pva.seg)
      pva = pva*100000000(16)
      pva = pva + $pv(?p_monitor_faults.tmt$monitor_fault_buffer.buffer[?fault].pva.offset)
      disv ' pva '//pva//' '//$trim($module(pva))//' '//$section(pva) o=output.$eoi
      dispv ?p_monitor_faults.tmt$monitor_fault_buffer.buffer[?fault] o=output.$eoi
      IF $pv(?p_monitor_faults.tmt$monitor_fault_buffer.buffer[?fault].identifier) = ..
            mmc$segment_fault_processor_id THEN
        identifier = $pv(..
              ?p_monitor_faults.tmt$monitor_fault_buffer.buffer[?fault].segment_access_fault.identifier)
        IF (identifier >=1) AND (identifier <= 11) THEN
          disv '   -  '//segment_access_fault(identifier) o=output.$eoi
        ELSE
          disv '    - Unrecogized segment fault ' o=output.$eoi
        IFEND
      IFEND
    IFEND
  FOREND
  IF faults_present = 0 THEN
    disv ' No faults present ' o=output.$eoi
  IFEND
  chadm current

PROCEND dum$display_monitor_faults
*DECK DECK=DUM$DISPLAY_MONITOR_REQUESTS EXPAND=TRUE
PROCEDURE dum$display_monitor_requests,display_monitor_requests,dismonreq(
  output, o: file = $output
  status)

  req_table = $sa(mtv$request_table)
  req_table=req_table+14(16)
  req_table=req_table+18(16)

  put_line ' cycle = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' delay = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' unused_request_3 = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' device_io = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' advise_in = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' advise_out = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' advise_out_in = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' initiate_task = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' page_fault = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' initiate_job = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' exit_job = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' free_pages = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' write_modified_pages = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' change_segment_table = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' check_active_pps = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' unused_request_10 = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' unused_request_17 = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' job_swapping_functions = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' idle_system = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' mcr_ucr_fault = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' system_error = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' fetch_task_statistics = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' unused_request_23 = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' unused_request_24 = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' ready_task = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' set_system_flag = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' wait = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' lock_ring_1_stack = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' mtr_send_signal = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' set_get_segment_length = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' memory_manager_io = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' job_recovery_requests = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' ring1_segment_request = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' task_exit = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' unused_request_35 = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' update_job_task_enviro = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' segment_request = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' lock_pages = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' unlock_pages = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' fetch_pva_unwritten_pgs = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' allocate_front_end = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' deallocate_front_end = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' apply_mat_changes = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' tape_io = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' translate_byte_address = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' config_mgmt_request = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' manage_system_tasks = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' lock_unlock_segment = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' issue_dft_request = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' wait_io_completion = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' switch_task = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' process_short_warning = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' monitor_system_status = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' process_io_completions = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' update_system_display = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' process_scd_block = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' keypoint = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' periodic_call = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' process_due = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' unused_request_60 = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' swap_job = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' monitor_mode_ei = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' unused_request_63 = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' subsystem_request = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' logging_request = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' process_dft_block = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' job_scheduler_request = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' fetch_offset_mod_pages = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' assign_pages = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' conditional_free = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' queue_rhfam_request = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' unused_request_72 = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' file_server_request = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' move_pages = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' assign_contig_memory = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' reallocate_front_end = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' ring1_server_seg_request = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' monitor_cpu_self_state = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' stats_facility_request = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' system_deadstart_status = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' service_class_statistics = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' unused_request_82 = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' unused_request_83 = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' unused_request_84 = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi
  req_table=req_table+18(16)
  put_line ' inject_hardware_fault = '//$strrep($memory(req_table, 4), 10) o=output.$eoi
  put_line '   total = '//$strrep($memory(req_table-12, 8), 10) o=output.$eoi
  put_line '   max = '//$strrep($memory(req_table-4, 4), 10) o=output.$eoi
  put_line ' ' o=output.$eoi

PROCEND dum$display_monitor_requests
*DECK DECK=DUM$DISPLAY_MRT_DATA_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display MRT Data Command' ??
MODULE dum$display_mrt_data_command;

{ PURPOSE:
{   This module contains the code for the display_mrt_data command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dst$mrt_entry
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$new_page_procedure
*copyc dup$retrieve_cip_program
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'display_clock_data', EJECT ??

{ PURPOSE:
{   This procedure displays the clock data from the MRT in detail.

  PROCEDURE display_clock_data
    (VAR display_control: clt$display_control;
     VAR restart_file_seq_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      clock_p: ^dst$mrt_clock_data_info,
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      integer_data: 0 .. 0ff(16),
      string_2: string (2),
      string_7: string (7),
      string_length: integer;

    status.normal := TRUE;
    clp$put_display (display_control, '   DETAIL:', clc$trim, ignore_status);
    NEXT clock_p IN restart_file_seq_p;
    IF clock_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
      RETURN;  {---->
    IFEND;

    integer_data := (clock_p^.years.tens * 10(16)) + clock_p^.years.units;
    clp$convert_integer_to_rjstring (integer_data, 16, FALSE, '0', string_2, ignore_status);
    STRINGREP (display_string, string_length, '     Years = ', string_2);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    integer_data := (clock_p^.months.tens * 10(16)) + clock_p^.months.units;
    clp$convert_integer_to_rjstring (integer_data, 16, FALSE, '0', string_2, ignore_status);
    STRINGREP (display_string, string_length, '     Months = ', string_2);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    integer_data := (clock_p^.days.tens * 10(16)) + clock_p^.days.units;
    clp$convert_integer_to_rjstring (integer_data, 16, FALSE, '0', string_2, ignore_status);
    STRINGREP (display_string, string_length, '     Days = ', string_2);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    integer_data := (clock_p^.hours.tens * 10(16)) + clock_p^.hours.units;
    clp$convert_integer_to_rjstring (integer_data, 16, FALSE, '0', string_2, ignore_status);
    STRINGREP (display_string, string_length, '     Hours = ', string_2);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    integer_data := (clock_p^.minutes.tens * 10(16)) + clock_p^.minutes.units;
    clp$convert_integer_to_rjstring (integer_data, 16, FALSE, '0', string_2, ignore_status);
    STRINGREP (display_string, string_length, '     Minutes = ', string_2);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    integer_data := (clock_p^.seconds.tens * 10(16)) + clock_p^.seconds.units;
    clp$convert_integer_to_rjstring (integer_data, 16, FALSE, '0', string_2, ignore_status);
    STRINGREP (display_string, string_length, '     Seconds = ', string_2);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (clock_p^.frc_bits_4_15.frc_bits, 16, TRUE, '0', string_7,
          ignore_status);
    STRINGREP (display_string, string_length, '     FRC bits 04-15 = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (clock_p^.frc_bits_16_27.frc_bits, 16, TRUE, '0', string_7,
          ignore_status);
    STRINGREP (display_string, string_length, '     FRC bits 16-27 = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (clock_p^.frc_bits_28_39.frc_bits, 16, TRUE, '0', string_7,
          ignore_status);
    STRINGREP (display_string, string_length, '     FRC bits 28-39 = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (clock_p^.frc_bits_40_51.frc_bits, 16, TRUE, '0', string_7,
          ignore_status);
    STRINGREP (display_string, string_length, '     FRC bits 40-51 = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (clock_p^.frc_bits_52_63.frc_bits, 16, TRUE, '0', string_7,
          ignore_status);
    STRINGREP (display_string, string_length, '     FRC bits 52-63 = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

  PROCEND display_clock_data;
?? OLDTITLE ??
?? NEWTITLE := 'display_console_data', EJECT ??

{ PURPOSE:
{   This procedure displays the console data from the MRT in detail.

  PROCEDURE display_console_data
    (VAR display_control: clt$display_control;
     VAR restart_file_seq_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      console_p: ^dst$mrt_display_console_info,
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      string_4: string (4),
      string_length: integer;

    status.normal := TRUE;
    clp$put_display (display_control, '   DETAIL:', clc$trim, ignore_status);
    NEXT console_p IN restart_file_seq_p;
    IF console_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
      RETURN;  {---->
    IFEND;

    IF console_p^.display_type = 0 THEN
      clp$put_display (display_control, '     Console type = CC545', clc$trim, ignore_status);
    ELSEIF console_p^.display_type = 1 THEN
      clp$put_display (display_control, '     Console type = VIKING X', clc$trim, ignore_status);
    ELSEIF console_p^.display_type = 2 THEN
      clp$put_display (display_control, '     Console type = PC', clc$trim, ignore_status);
    ELSE
      clp$put_display (display_control, '     Console type = unknown', clc$trim, ignore_status);
    IFEND;

    IF console_p^.port_flags = 1000(8) THEN
      clp$put_display (display_control, '     CC545 on channel 10', clc$trim, ignore_status);
    ELSEIF console_p^.port_flags = 1500(8) THEN
      clp$put_display (display_control, '     Viking-X on Port 0 of the TPM', clc$trim, ignore_status);
    ELSEIF console_p^.port_flags = 1501(8) THEN
      clp$put_display (display_control, '     Viking-X on Port 1 of the TPM', clc$trim, ignore_status);
    ELSEIF console_p^.port_flags = 1510(8) THEN
      clp$put_display (display_control, '     TTY type on Port 0 of the TPM', clc$trim, ignore_status);
    ELSEIF console_p^.port_flags = 1511(8) THEN
      clp$put_display (display_control, '     TTY type on Port 1 of the TPM', clc$trim, ignore_status);
    ELSEIF console_p^.port_flags = 1520(8) THEN
      clp$put_display (display_control, '     PC type on Port 0 of the TPM', clc$trim, ignore_status);
    ELSEIF console_p^.port_flags = 1521(8) THEN
       clp$put_display (display_control, '    PC type on Port 1 of the TPM', clc$trim, ignore_status);
    IFEND;

    IF (console_p^.mdd_pp = 0) AND (console_p^.scd_pp = 0) THEN
      clp$put_display (display_control, '     Neither MDD nor SCD is loaded', clc$trim, ignore_status);
    ELSEIF console_p^.mdd_pp <> 0 THEN
      clp$convert_integer_to_rjstring (console_p^.mdd_pp, 8, TRUE, '0', string_4, ignore_status);
      STRINGREP (display_string, string_length, '     MDD PP = ', string_4);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    ELSEIF console_p^.scd_pp <> 0 THEN
      clp$convert_integer_to_rjstring (console_p^.scd_pp, 8, TRUE, '0', string_4, ignore_status);
      STRINGREP (display_string, string_length, '     SCD PP = ', string_4);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    IFEND;

    IF console_p^.mdd_to_be_loaded THEN
      clp$put_display (display_control, '     MDD is to be loaded', clc$trim, ignore_status);
    IFEND;

    clp$convert_integer_to_rjstring (console_p^.mdd_port_number, 8, TRUE, '0', string_4, ignore_status);
    STRINGREP (display_string, string_length, '     MDD Port Number = ', string_4);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

  PROCEND display_console_data;
?? OLDTITLE ??
?? NEWTITLE := 'display_cpu_data', EJECT ??

{ PURPOSE:
{   This procedure displays the cpu data from the MRT in detail.

  PROCEDURE display_cpu_data
    (VAR display_control: clt$display_control;
     VAR restart_file_seq_p: ^SEQ ( * );
     VAR status: ost$status);

    TYPE
      t$cpu = PACKED RECORD
        descriptor_id: dst$mrt_descriptor_id,
        element_id: dst$mrt_element_id,
        maintenance_channel_id: dst$mrt_maintenance_channel_id,
        unused_1: 0 .. 0f(16),
        page_map: PACKED ARRAY [0 .. 3] OF boolean,
        segment_map: PACKED ARRAY [0 .. 1] OF boolean,
        unused_2: boolean,
        physical_16k_cache_installed: boolean,
        cache_set: PACKED ARRAY [0 .. 3] OF boolean,
        unused_3: 0 .. 17777(8),
        memory_port: 0 .. 7(8),
        unused_4: 0 .. 0f(16),
        cpu_downed_by: 0 .. 3,
        up_down_status: 0 .. 1,
        ibs_degrade_bits: 0 .. 0f(16),
        vector_option_installed: 0 .. 1,
        pmf_present: 0 .. 1,
        processor_supports_180_state: 0 .. 1,
        processor_supports_170_state: 0 .. 1,
        on_off_status: 0 .. 1,
        unused_5: 0 .. 0f(16),
        div_net_result_select: 0 .. 3,
        div_net_sel_for_compare: 0 .. 3,
        enable_maintenance_mode: 0 .. 1,
        unused_6: 0 .. 3,
        cpu0_instruction_stack: 0 .. 1,
        cmu_capability: 0 .. 1,
        cej_mej_capability: 0 .. 1,
        cpu1_not_available: 0 .. 1,
        cpu0_not_available: 0 .. 1,
        unused_7: 0 .. 07fff(16),
        microcode_loaded_flag: 0 .. 1,
        microcode_1_2: 0 .. 0ffff(16),
        microcode_3_4: 0 .. 0ffff(16),
        microcode_5_6: 0 .. 0ffff(16),
        microcode_7: 0 .. 0ffff(16),
        unused_8: 0 .. 0ffff(16),
        microcode_date_1_2: 0 .. 0ffff(16),
        microcode_date_3_4: 0 .. 0ffff(16),
        microcode_date_5_6: 0 .. 0ffff(16),
        theta_standard_option: 0 .. 0ffff(16),
        unused_9: 0 .. 1fff(16),
        pip3_fast_slow_clock_frequency: 0 .. 3,
        pip3_init_clock_sys_flag: 0 .. 1,
        cpu_mps_rma_bits: PACKED ARRAY [1 .. 3] OF t$rma_bits,
      RECEND,

      t$rma_bits = PACKED RECORD
        unused_1: 0 .. 0f(16),
        bits: 0 .. 0fff(16),
      RECEND;

    VAR
      cell_p: ^cell,
      cpu_p: ^t$cpu,
      descriptor_p: ^0 .. 0ffff(16),
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      index: 0 .. 0f(16),
      integer_data: 0 .. 0fffffffff(16),
      string_5: string (5),
      string_7: string (7),
      string_8: string (8),
      string_13: string (13),
      string_length: integer;

    status.normal := TRUE;
    clp$put_display (display_control, '   DETAIL:', clc$trim, ignore_status);
    NEXT cell_p IN restart_file_seq_p;
    IF cell_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
      RETURN;  {---->
    IFEND;
    RESET restart_file_seq_p TO cell_p;
    NEXT descriptor_p IN restart_file_seq_p;
    IF descriptor_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
      RETURN;  {---->
    IFEND;
    display_element_id (display_control, restart_file_seq_p, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;
    RESET restart_file_seq_p TO cell_p;
    NEXT cpu_p IN restart_file_seq_p;
    IF cpu_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
      RETURN;  {---->
    IFEND;

    clp$convert_integer_to_rjstring (cpu_p^.maintenance_channel_id.port, 16, TRUE, '0', string_5,
          ignore_status);
    STRINGREP (display_string, string_length, '     Maintenance Channel Port = ', string_5);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (cpu_p^.maintenance_channel_id.type_code, 16, TRUE, '0', string_5,
          ignore_status);
    STRINGREP (display_string, string_length, '     Maintenance Channel Type Code = ', string_5);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    FOR index := 0 TO 3 DO
      IF cpu_p^.page_map [index] THEN
        STRINGREP (display_string, string_length, '     Page Map ', index, ' is disabled');
      ELSE
        STRINGREP (display_string, string_length, '     Page Map ', index, ' is enabled');
      IFEND;
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    FOREND;

    FOR index := 0 TO 1 DO
      IF cpu_p^.segment_map [index] THEN
        STRINGREP (display_string, string_length, '     Segment Map ', index, ' is disabled');
      ELSE
        STRINGREP (display_string, string_length, '     Segment Map ', index, ' is enabled');
      IFEND;
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    FOREND;

    IF cpu_p^.physical_16k_cache_installed THEN
      clp$put_display (display_control, '     16k Physical Cache Installed', clc$trim, ignore_status);
    ELSE
      clp$put_display (display_control, '     32k Physical Cache Installed', clc$trim, ignore_status);
    IFEND;

    FOR index := 0 TO 3 DO
      IF cpu_p^.cache_set [index] THEN
        STRINGREP (display_string, string_length, '     Cache ', index, ' is disabled');
      ELSE
        STRINGREP (display_string, string_length, '     Cache ', index, ' is enabled');
      IFEND;
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    FOREND;

    clp$convert_integer_to_rjstring (cpu_p^.memory_port, 16, TRUE, '0', string_5, ignore_status);
    STRINGREP (display_string, string_length, '     Memory Port = ', string_5);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    IF cpu_p^.cpu_downed_by = 1 THEN
      clp$put_display (display_control, '     CPU downed by DFT', clc$trim, ignore_status);
    ELSEIF cpu_p^.cpu_downed_by = 2 THEN
      clp$put_display (display_control, '     CPU downed by SYSTEM', clc$trim, ignore_status);
    ELSEIF cpu_p^.cpu_downed_by = 3 THEN
      clp$put_display (display_control, '     CPU downed by OPERATOR', clc$trim, ignore_status);
    IFEND;

    IF cpu_p^.up_down_status = 0 THEN
      clp$put_display (display_control, '     CPU is up', clc$trim, ignore_status);
    ELSE
      clp$put_display (display_control, '     CPU is down', clc$trim, ignore_status);
    IFEND;

    clp$convert_integer_to_rjstring (cpu_p^.ibs_degrade_bits, 16, TRUE, '0', string_5, ignore_status);
    STRINGREP (display_string, string_length, '     IBS Degrade Bits = ', string_5);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    IF cpu_p^.vector_option_installed = 0 THEN
      clp$put_display (display_control, '     Vector Option Installed', clc$trim, ignore_status);
    IFEND;

    IF cpu_p^.pmf_present = 0 THEN
      clp$put_display (display_control, '     PMF Present', clc$trim, ignore_status);
    IFEND;

    IF cpu_p^.processor_supports_180_state = 0 THEN
      clp$put_display (display_control, '     Processor Supports 180 State', clc$trim, ignore_status);
    IFEND;

    IF cpu_p^.processor_supports_170_state = 0 THEN
      clp$put_display (display_control, '     Processor Supports 170 State', clc$trim, ignore_status);
    IFEND;

    IF cpu_p^.on_off_status = 0 THEN
      clp$put_display (display_control, '     CPU is on', clc$trim, ignore_status);
    ELSE
      clp$put_display (display_control, '     CPU is logically off', clc$trim, ignore_status);
    IFEND;

    clp$convert_integer_to_rjstring (cpu_p^.div_net_result_select, 16, TRUE, '0', string_5, ignore_status);
    STRINGREP (display_string, string_length, '     DIV net result select = ', string_5);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (cpu_p^.div_net_sel_for_compare, 16, TRUE, '0', string_5, ignore_status);
    STRINGREP (display_string, string_length, '     DIV net sel for compare = ', string_5);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (cpu_p^.enable_maintenance_mode, 16, TRUE, '0', string_5, ignore_status);
    STRINGREP (display_string, string_length, '     Enable Maintenance Mode = ', string_5);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    IF cpu_p^.cpu0_instruction_stack = 1 THEN
      clp$put_display (display_control, '     No CPU-0 instruction stack', clc$trim, ignore_status);
    IFEND;

    IF cpu_p^.cmu_capability = 1 THEN
      clp$put_display (display_control, '     No CMU capability', clc$trim, ignore_status);
    IFEND;

    IF cpu_p^.cej_mej_capability = 1 THEN
      clp$put_display (display_control, '     No CEJ/MEJ capability', clc$trim, ignore_status);
    IFEND;

    IF cpu_p^.cpu1_not_available = 1 THEN
      clp$put_display (display_control, '     CPU-1 not available', clc$trim, ignore_status);
    IFEND;

    IF cpu_p^.cpu0_not_available = 1 THEN
      clp$put_display (display_control, '     CPU-0 not available', clc$trim, ignore_status);
    IFEND;

    clp$convert_integer_to_rjstring (cpu_p^.microcode_1_2, 8, TRUE, '0', string_7, ignore_status);
    STRINGREP (display_string, string_length, '     Characters 1 and 2 of microcode name = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (cpu_p^.microcode_3_4, 8, TRUE, '0', string_7, ignore_status);
    STRINGREP (display_string, string_length, '     Characters 3 and 4 of microcode name = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (cpu_p^.microcode_5_6, 8, TRUE, '0', string_7, ignore_status);
    STRINGREP (display_string, string_length, '     Characters 5 and 6 of microcode name = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (cpu_p^.microcode_7, 8, TRUE, '0', string_7, ignore_status);
    STRINGREP (display_string, string_length, '     Characters 7 of microcode name = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (cpu_p^.microcode_date_1_2, 8, TRUE, '0', string_7, ignore_status);
    STRINGREP (display_string, string_length, '     Characters 1 and 2 of microcode date (yy) = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (cpu_p^.microcode_date_3_4, 8, TRUE, '0', string_7, ignore_status);
    STRINGREP (display_string, string_length, '     Characters 3 and 4 of microcode date (mm) = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (cpu_p^.microcode_date_5_6, 8, TRUE, '0', string_7, ignore_status);
    STRINGREP (display_string, string_length, '     Characters 5 and 6 of microcode date (dd) = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (cpu_p^.theta_standard_option, 16, TRUE, '0', string_8, ignore_status);
    STRINGREP (display_string, string_length, '     Theta Standard Option = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (cpu_p^.pip3_fast_slow_clock_frequency, 16, TRUE, '0', string_5,
          ignore_status);
    STRINGREP (display_string, string_length, '     PIP3 fast/slow clock frequency = ', string_5);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (cpu_p^.pip3_init_clock_sys_flag, 16, TRUE, '0', string_5, ignore_status);
    STRINGREP (display_string, string_length, '     PIP3 initialize clock system flag = ', string_5);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    integer_data := (((cpu_p^.cpu_mps_rma_bits [1].bits * 1000(16)) + cpu_p^.cpu_mps_rma_bits [2].bits) *
          1000(16)) + cpu_p^.cpu_mps_rma_bits [3].bits;
    clp$convert_integer_to_rjstring (integer_data, 16, TRUE, '0', string_13, ignore_status);
    STRINGREP (display_string, string_length, '     CPU MPS RMA = ', string_13);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

  PROCEND display_cpu_data;
?? OLDTITLE ??
?? NEWTITLE := 'display_data_raw', EJECT ??

{ PURPOSE:
{   This procedure displays the MRT data raw.

  PROCEDURE display_data_raw
    (    descriptor_length: 0 .. 077(8);
     VAR restart_file_seq_p: ^SEQ ( * );
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    TYPE
      t$data_line = RECORD
        CASE boolean OF
        = TRUE =
          line: string (50),
        = FALSE =
          unused_1: string (3),
          word_part: ARRAY [1 .. 4] OF t$word_part,
        CASEND,
      RECEND,

      t$word_part = RECORD
        data: string (4),
        unsed: string (2),
      RECEND;

    VAR
      data_line: t$data_line,
      ignore_status: ost$status,
      index: 0 .. 0ff(16),
      string_4: string (4),
      word_index: 0 .. 0ff(16),
      word_p: ^0 .. 0ffff(16);

    status.normal := TRUE;

    word_index := 1;
    data_line.line := ' ';
    FOR index := 1 TO descriptor_length DO
      NEXT word_p IN restart_file_seq_p;
      IF word_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        RETURN;  {---->
      IFEND;
      clp$convert_integer_to_rjstring (word_p^, 16, FALSE, '0', string_4, ignore_status);
      data_line.word_part [word_index].data := string_4;
      IF word_index = 4 THEN
        clp$put_display (display_control, data_line.line, clc$trim, ignore_status);
        word_index := 1;
        data_line.line := ' ';
      ELSE
        word_index := word_index + 1;
      IFEND;
    FOREND;
    IF word_index > 1 THEN
      clp$put_display (display_control, data_line.line, clc$trim, ignore_status);
    IFEND;

  PROCEND display_data_raw;
?? OLDTITLE ??
?? NEWTITLE := 'display_dft_data', EJECT ??

{ PURPOSE:
{   This procedure displays the DFT data from the MRT in detail.

  PROCEDURE display_dft_data
    (VAR display_control: clt$display_control;
     VAR restart_file_seq_p: ^SEQ ( * );
     VAR status: ost$status);

    TYPE
      t$dft = PACKED RECORD
        descriptor_id: dst$mrt_descriptor_id,
        unused_1: 0 .. 0fff(16),
        upper_size: 0 .. 0f(16),
        unused_2: 0 .. 0f(16),
        lower_size: 0 .. 0fff(16),
        unused_3: 0 .. 0f(16),
        version_level: 0 .. 03f(16),
        unused_4: 0 .. 01f(16),
        dft_version_flag: 0 .. 1,
        unused_5: 0 .. 0ffff(16),
      RECEND;

    VAR
      dft_p: ^t$dft,
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      string_5: string (5),
      string_8: string (8),
      string_length: integer,
      total_size: 0 .. 0ffff(16);

    status.normal := TRUE;
    clp$put_display (display_control, '   DETAIL:', clc$trim, ignore_status);
    NEXT dft_p IN restart_file_seq_p;
    IF dft_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
      RETURN;  {---->
    IFEND;

    total_size := (dft_p^.upper_size * 1000(16)) + dft_p^.lower_size;
    clp$convert_integer_to_rjstring (total_size, 16, TRUE, '0', string_8, ignore_status);
    STRINGREP (display_string, string_length,
          '     Total size in CM words to be allocated for the DFT/OS buffer = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (dft_p^.version_level, 8, TRUE, '0', string_5, ignore_status);
    STRINGREP (display_string, string_length, '     Most recent DFT/OS Buffer version level = ', string_5);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    clp$put_display (display_control, '        (77(8) means OS boot is not installed)', clc$trim,
          ignore_status);

    IF dft_p^.dft_version_flag = 0 THEN
      clp$put_display (display_control, '     DFT Version Flag = 0', clc$trim, ignore_status);
    ELSE
      clp$put_display (display_control, '     DFT Version Flag = 1', clc$trim, ignore_status);
    IFEND;

  PROCEND display_dft_data;
?? OLDTITLE ??
?? NEWTITLE := 'display_element_id', EJECT ??

{ PURPOSE:
{   This procedure displays the element id information.

  PROCEDURE display_element_id
    (VAR display_control: clt$display_control;
     VAR restart_file_seq_p: ^SEQ ( * );
     VAR status: ost$status);

    TYPE
      t$element_data = RECORD
        CASE boolean OF
        = TRUE =
          line: string (50),
        = FALSE =
          space_1: string (5),
          element_name: string (8),
          element: string (2),
          space_2: string (2),
          model_name: string (6),
          model: string (2),
          space_3: string (2),
          serial_name: string (7),
          serial_1: string (1),
          serial_2: string (3),
        CASEND,
      RECEND,

      t$element_id = PACKED RECORD
        unused_1: 0 .. 0ff(16),
        element: 0 .. 0ff(16),
        unused_2: 0 .. 0f(16),
        model: 0 .. 0ff(16),
        serial_1: 0 .. 0f(16),
        unused_3: 0 .. 0f(16),
        serial_2: 0 .. 0fff(16),
      RECEND;

    VAR
      element_data: t$element_data,
      element_id_p: ^t$element_id,
      ignore_status: ost$status;

    status.normal := TRUE;
    NEXT element_id_p IN restart_file_seq_p;
    IF element_id_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
      RETURN;  {---->
    IFEND;
    element_data.line := ' ';
    element_data.element_name := 'ELEMENT=';
    clp$convert_integer_to_rjstring (element_id_p^.element, 16, FALSE, '0', element_data.element,
          ignore_status);
    element_data.model_name := 'MODEL=';
    clp$convert_integer_to_rjstring (element_id_p^.model, 16, FALSE, '0', element_data.model,
          ignore_status);
    element_data.serial_name := 'SERIAL=';
    clp$convert_integer_to_rjstring (element_id_p^.serial_1, 16, FALSE, '0', element_data.serial_1,
          ignore_status);
    clp$convert_integer_to_rjstring (element_id_p^.serial_2, 16, FALSE, '0', element_data.serial_2,
          ignore_status);
    clp$put_display (display_control, element_data.line, clc$trim, ignore_status);

  PROCEND display_element_id;
?? OLDTITLE ??
?? NEWTITLE := 'display_global_processor_data', EJECT ??

{ PURPOSE:
{   This procedure displays the global processor data from the MRT in detail.

  PROCEDURE display_global_processor_data
    (VAR display_control: clt$display_control;
     VAR restart_file_seq_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      global_processor_p: ^dst$mrt_global_processor_info,
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      string_4: string (4),
      string_5: string (5),
      string_6: string (6),
      string_7: string (7),
      string_8: string (8),
      string_length: integer;

    status.normal := TRUE;
    clp$put_display (display_control, '   DETAIL:', clc$trim, ignore_status);
    NEXT global_processor_p IN restart_file_seq_p;
    IF global_processor_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
      RETURN;  {---->
    IFEND;

    clp$convert_integer_to_rjstring (global_processor_p^.micro_long_init, 16, TRUE, '0', string_8,
          ignore_status);
    STRINGREP (display_string, string_length, '     Microcode Long Init address = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (global_processor_p^.micro_idle_short_init, 16, TRUE, '0', string_8,
          ignore_status);
    STRINGREP (display_string, string_length, '     Microcode Idle or Short Init address = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (global_processor_p^.micro_mps_heo, 16, TRUE, '0', string_8,
          ignore_status);
    STRINGREP (display_string, string_length, '     Microcode MPS Half Exchange Out address = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (global_processor_p^.micro_jps_heo, 16, TRUE, '0', string_8,
          ignore_status);
    STRINGREP (display_string, string_length, '     Microcode JPS Half Exchange Out address = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (global_processor_p^.micro_mps_hei, 16, TRUE, '0', string_8,
          ignore_status);
    STRINGREP (display_string, string_length, '     Microcode MPS Half Exchange In address = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (global_processor_p^.micro_jps_hei, 16, TRUE, '0', string_8,
          ignore_status);
    STRINGREP (display_string, string_length, '     Microcode JPS Half Exchange In address = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (global_processor_p^.pte, 8, TRUE, '0', string_4, ignore_status);
    STRINGREP (display_string, string_length, '     # of page table entries per page of real memory = ',
          string_4);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (global_processor_p^.ptl, 16, TRUE, '0', string_7, ignore_status);
    STRINGREP (display_string, string_length, '     Page Table length = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (global_processor_p^.page_size, 16, TRUE, '0', string_8, ignore_status);
    STRINGREP (display_string, string_length, '     Page size in K bytes = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    IF global_processor_p^.secure_analysis THEN
      clp$put_display (display_control, '     Secure mode bit is set', clc$trim, ignore_status);
    ELSE
      clp$put_display (display_control, '     Secure mode bit is not set', clc$trim, ignore_status);
    IFEND;

    IF global_processor_p^.state_flag THEN
      clp$put_display (display_control, '     State Flag = C180', clc$trim, ignore_status);
    ELSE
      clp$put_display (display_control, '     State Flag = C170', clc$trim, ignore_status);
    IFEND;

    IF global_processor_p^.carriage_return THEN
      clp$put_display (display_control,
            '     Operator entered "CR" from the initial CTI display or the *O* display', clc$trim,
            ignore_status);
    IFEND;

    IF global_processor_p^.disk_deadstart THEN
      clp$put_display (display_control, '     Operator entered "D" from CTI *O* display', clc$trim,
            ignore_status);
    IFEND;

    IF global_processor_p^.tape_deadstart THEN
      clp$put_display (display_control, '     Operator entered "T" from CTI *O* display', clc$trim,
            ignore_status);
    IFEND;

    clp$convert_integer_to_rjstring (global_processor_p^.cip_channel, 8, TRUE, '0', string_5, ignore_status);
    STRINGREP (display_string, string_length, '     CIP Channel = ', string_5);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (global_processor_p^.cip_disk_type, 8, TRUE, '0', string_6,
          ignore_status);
    STRINGREP (display_string, string_length, '     CIP Disk Type = ', string_6);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (global_processor_p^.cip_disk_unit, 8, TRUE, '0', string_6,
          ignore_status);
    STRINGREP (display_string, string_length, '     CIP Disk Unit = ', string_6);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (global_processor_p^.reserved_2, 16, TRUE, '0', string_8,
          ignore_status);
    STRINGREP (display_string, string_length,
          '     CM size from previous power on initialization deadstart = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (global_processor_p^.reserved_3, 16, TRUE, '0', string_8,
          ignore_status);
    STRINGREP (display_string, string_length,
          '     EI MPS offset from previous power on initialization deadstart = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (global_processor_p^.reserved_4, 16, TRUE, '0', string_8,
          ignore_status);
    STRINGREP (display_string, string_length, '     PTL value for larger memory sizes = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

  PROCEND display_global_processor_data;
?? OLDTITLE ??
?? NEWTITLE := 'display_iou_data', EJECT ??

{ PURPOSE:
{   This procedure displays the iou data from the MRT in detail.

  PROCEDURE display_iou_data
    (VAR display_control: clt$display_control;
     VAR restart_file_seq_p: ^SEQ ( * );
     VAR status: ost$status);

    TYPE
      t$iou = PACKED RECORD
        descriptor_id: dst$mrt_descriptor_id,
        element_id: dst$mrt_element_id,
        maintenance_channel_id: dst$mrt_maintenance_channel_id,
        pps_physically_missing: 0 .. 0ffffffff(16),
        pps_logically_missing: 0 .. 0ffffffff(16),
        pad_1: 0 .. 17777(8),
        pp_speed: 0 .. 7(8),
        channels_missing: 0 .. 0ffffffff(16),
        physically_present_cio_pps: 0 .. 0ffff(16),
        logically_present_cio_pps: 0 .. 0ffff(16),
        physically_present_cio_channels: 0 .. 0ffff(16),
        pps_0_11b_up_down_status: 0 .. 0ffff(16),
        pps_20b_31b_up_down_status: 0 .. 0ffff(16),
        i4_cio_pps_up_down_status: 0 .. 0ffff(16),
        channels: ARRAY [1 .. 12] OF 0 .. 0ffff(16),
        cio_channels: ARRAY [1 .. 5] OF 0 .. 0ffff(16),
        pad_2: 0 .. 77777(8),
        iou_logically_off: boolean,
      RECEND;

    VAR
      cell_p: ^cell,
      descriptor_p: ^0 .. 0ffff(16),
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      index: 0 .. 0f(16),
      integer_data: 0 .. 0fffffffff(16),
      iou_p: ^t$iou,
      string_5: string (5),
      string_8: string (8),
      string_12: string (12),
      string_length: integer;

    status.normal := TRUE;
    clp$put_display (display_control, '   DETAIL:', clc$trim, ignore_status);
    NEXT cell_p IN restart_file_seq_p;
    IF cell_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
      RETURN;  {---->
    IFEND;
    RESET restart_file_seq_p TO cell_p;
    NEXT descriptor_p IN restart_file_seq_p;
    IF descriptor_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
      RETURN;  {---->
    IFEND;
    display_element_id (display_control, restart_file_seq_p, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;
    RESET restart_file_seq_p TO cell_p;
    NEXT iou_p IN restart_file_seq_p;
    IF iou_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
      RETURN;  {---->
    IFEND;

    clp$convert_integer_to_rjstring (iou_p^.maintenance_channel_id.port, 16, TRUE, '0', string_5,
          ignore_status);
    STRINGREP (display_string, string_length, '     Maintenance Channel Port = ', string_5);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (iou_p^.maintenance_channel_id.type_code, 16, TRUE, '0', string_5,
          ignore_status);
    STRINGREP (display_string, string_length, '     Maintenance Channel Type Code = ', string_5);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (iou_p^.pps_physically_missing, 16, TRUE, '0', string_12, ignore_status);
    STRINGREP (display_string, string_length, '     PPs Physically Missing = ', string_12);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (iou_p^.pps_logically_missing, 16, TRUE, '0', string_12, ignore_status);
    STRINGREP (display_string, string_length, '     PPs Logically Missing = ', string_12);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (iou_p^.pp_speed, 16, TRUE, '0', string_5, ignore_status);
    STRINGREP (display_string, string_length, '     PP Speed = ', string_5);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (iou_p^.channels_missing, 16, TRUE, '0', string_12, ignore_status);
    STRINGREP (display_string, string_length, '     Channels Missing = ', string_12);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (iou_p^.physically_present_cio_pps, 16, TRUE, '0', string_8,
          ignore_status);
    STRINGREP (display_string, string_length, '     Physically present CIO PPs = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (iou_p^.logically_present_cio_pps, 16, TRUE, '0', string_8,
          ignore_status);
    STRINGREP (display_string, string_length, '     Logically present CIO PPs = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (iou_p^.physically_present_cio_channels, 16, TRUE, '0', string_8,
          ignore_status);
    STRINGREP (display_string, string_length, '     Physically present CIO Channels = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (iou_p^.pps_0_11b_up_down_status, 16, TRUE, '0', string_8, ignore_status);
    STRINGREP (display_string, string_length, '     PPs 0-11(8) UP/DOWN Status = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (iou_p^.pps_20b_31b_up_down_status, 16, TRUE, '0', string_8,
          ignore_status);
    STRINGREP (display_string, string_length, '     PPs 20(8)-31(8) UP/DOWN Status = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (iou_p^.i4_cio_pps_up_down_status, 16, TRUE, '0', string_8,
          ignore_status);
    STRINGREP (display_string, string_length, '     I4 CIO PPs UP/DOWN Status = ', string_8);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    FOR index := 1 TO 12 DO
      clp$convert_integer_to_rjstring (iou_p^.channels [index], 16, TRUE, '0', string_8, ignore_status);
      STRINGREP (display_string, string_length, '     Channels UP/DOWN Status = ', string_8);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    FOREND;

    FOR index := 1 TO 5 DO
      clp$convert_integer_to_rjstring (iou_p^.cio_channels [index], 16, TRUE, '0', string_8, ignore_status);
      STRINGREP (display_string, string_length, '     CIO Channels UP/DOWN Status = ', string_8);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);
    FOREND;

    IF iou_p^.iou_logically_off THEN
      clp$put_display (display_control, '     IOU is logically OFF', clc$trim, ignore_status);
    IFEND;

  PROCEND display_iou_data;
?? OLDTITLE ??
?? NEWTITLE := 'display_mainframe_data', EJECT ??

{ PURPOSE:
{   This procedure displays the mainframe data from the MRT in detail.

  PROCEDURE display_mainframe_data
    (VAR display_control: clt$display_control;
     VAR restart_file_seq_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      mainframe_p: ^dst$mrt_mainframe_info,
      string_7: string (7),
      string_length: integer;

    status.normal := TRUE;
    clp$put_display (display_control, '   DETAIL:', clc$trim, ignore_status);
    NEXT mainframe_p IN restart_file_seq_p;
    IF mainframe_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
      RETURN;  {---->
    IFEND;

    IF NOT mainframe_p^.r_register_not_available THEN
      clp$put_display (display_control, '     0 = R register available', clc$trim, ignore_status);
    IFEND;

    IF NOT mainframe_p^.not_c176 THEN
      clp$put_display (display_control, '     0 = C176', clc$trim, ignore_status);
    IFEND;

    IF NOT mainframe_p^.not_c170_700 THEN
      clp$put_display (display_control, '     0 = C170-700 (Model D)', clc$trim, ignore_status);
    IFEND;

    IF NOT mainframe_p^.interlock_register_not_present THEN
      clp$put_display (display_control, '     0 = interlock register present', clc$trim, ignore_status);
    IFEND;

    IF NOT mainframe_p^.scr_not_present THEN
      clp$put_display (display_control, '     0 = SCR or 865/875 Maintenance register present', clc$trim,
            ignore_status);
    IFEND;

    IF NOT mainframe_p^.no_cem_pem THEN
      clp$put_display (display_control, '     0 = CEM/PEM', clc$trim, ignore_status);
    IFEND;

    clp$convert_integer_to_rjstring (mainframe_p^.physical_processors_present, 8, TRUE, '0', string_7,
          ignore_status);
    STRINGREP (display_string, string_length, '     Physical Processors Present = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (mainframe_p^.char_1_2_ei_date, 8, TRUE, '0', string_7, ignore_status);
    STRINGREP (display_string, string_length, '     EI Date (yy) = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (mainframe_p^.char_3_4_ei_date, 8, TRUE, '0', string_7, ignore_status);
    STRINGREP (display_string, string_length, '     EI Date (mm) = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (mainframe_p^.char_5_6_ei_date, 8, TRUE, '0', string_7, ignore_status);
    STRINGREP (display_string, string_length, '     EI Date (dd) = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (mainframe_p^.ei_level, 8, TRUE, '0', string_7, ignore_status);
    STRINGREP (display_string, string_length, '     EI Level = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

  PROCEND display_mainframe_data;
?? OLDTITLE ??
?? NEWTITLE := 'display_memory_data', EJECT ??

{ PURPOSE:
{   This procedure displays the memory data from the MRT in detail.

  PROCEDURE display_memory_data
    (VAR display_control: clt$display_control;
     VAR restart_file_seq_p: ^SEQ ( * );
     VAR status: ost$status);

    TYPE
      t$cm_address = PACKED RECORD
        unused_1: 0 .. 0f(16),
        upper: 0 .. 0fff(16),
        unused_2: 0 .. 0f(16),
        lower: 0 .. 0fff(16),
      RECEND,

      t$memory = PACKED RECORD
        descriptor_id: dst$mrt_descriptor_id,
        element_id: dst$mrt_element_id,
        maintenance_channel_id: dst$mrt_maintenance_channel_id,
        physical_cm: t$cm_address,
        available_cm: t$cm_address,
        physical_cm_in_octal: 0 .. 0ffff(16),
        cip_directory: t$r_register,
        operator_entered_cm: t$cm_address,
        unused_4: 0 .. 0f(16),
        nos_or_nbe_page_table: 0 .. 0fff(16),
        ei: t$r_register,
      RECEND,

      t$r_register = PACKED RECORD
        unused_1: 0 .. 3f(16),
        msb_10_bits: 0 .. 3ff(16),
        unused_2: 0 .. 0f(16),
        lsb_12_bits: 0 .. 0fff(16),
        unused_3: 0 .. 3ff(16),
        lsb_6_bits: 0 .. 03f(16),
      RECEND;

    VAR
      cell_p: ^cell,
      descriptor_p: ^0 .. 0ffff(16),
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      integer_data_6: 0 .. 0ffffff(16),
      integer_data_octal: 0 .. 1777777777(8),
      memory_p: ^t$memory,
      string_5: string (5),
      string_7: string (7),
      string_10: string (10),
      string_11: string (11),
      string_length: integer;

    status.normal := TRUE;
    clp$put_display (display_control, '   DETAIL:', clc$trim, ignore_status);
    NEXT cell_p IN restart_file_seq_p;
    IF cell_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
      RETURN;  {---->
    IFEND;
    RESET restart_file_seq_p TO cell_p;
    NEXT descriptor_p IN restart_file_seq_p;
    IF descriptor_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
      RETURN;  {---->
    IFEND;
    display_element_id (display_control, restart_file_seq_p, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;
    RESET restart_file_seq_p TO cell_p;
    NEXT memory_p IN restart_file_seq_p;
    IF memory_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
      RETURN;  {---->
    IFEND;

    clp$convert_integer_to_rjstring (memory_p^.maintenance_channel_id.port, 16, TRUE, '0', string_5,
          ignore_status);
    STRINGREP (display_string, string_length, '     Maintenance Channel Port = ', string_5);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (memory_p^.maintenance_channel_id.type_code, 16, TRUE, '0', string_5,
          ignore_status);
    STRINGREP (display_string, string_length, '     Maintenance Channel Type Code = ', string_5);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    integer_data_6 := (memory_p^.physical_cm.upper * 1000(16)) + memory_p^.physical_cm.lower;
    clp$convert_integer_to_rjstring (integer_data_6, 16, TRUE, '0', string_10, ignore_status);
    STRINGREP (display_string, string_length, '     Physical CM Size/100(8) (in words) = ', string_10);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    integer_data_6 := (memory_p^.available_cm.upper * 1000(16)) + memory_p^.available_cm.lower;
    clp$convert_integer_to_rjstring (integer_data_6, 16, TRUE, '0', string_10, ignore_status);
    STRINGREP (display_string, string_length, '     Available CM Size/100(8) (in words) = ', string_10);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (memory_p^.physical_cm_in_octal, 8, TRUE, '0', string_7, ignore_status);
    STRINGREP (display_string, string_length, '     Physical CM size in octal MB = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    integer_data_octal := (((memory_p^.cip_directory.msb_10_bits * 10000(8)) +
          memory_p^.cip_directory.lsb_12_bits) * 100(8)) + memory_p^.cip_directory.lsb_6_bits;
    clp$convert_integer_to_rjstring (integer_data_octal, 16, TRUE, '0', string_11, ignore_status);
    STRINGREP (display_string, string_length,
          '     R register value of the FWA of the CIP directory in CM = ', string_11);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    integer_data_6 := (memory_p^.operator_entered_cm.upper * 1000(16)) + memory_p^.operator_entered_cm.lower;
    clp$convert_integer_to_rjstring (integer_data_6, 16, TRUE, '0', string_10, ignore_status);
    STRINGREP (display_string, string_length, '     Operator Entered CM Size/100(8) (in words) = ',
          string_10);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$convert_integer_to_rjstring (memory_p^.nos_or_nbe_page_table, 16, TRUE, '0', string_7, ignore_status);
    STRINGREP (display_string, string_length, '     NOS or NBE Page Table Length = ', string_7);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    integer_data_octal := (((memory_p^.ei.msb_10_bits * 10000(8)) + memory_p^.ei.lsb_12_bits) * 100(8)) +
          memory_p^.ei.lsb_6_bits;
    clp$convert_integer_to_rjstring (integer_data_octal, 16, TRUE, '0', string_11, ignore_status);
    STRINGREP (display_string, string_length,
          '     Most significant 10 bits of R reg of EI request word = ', string_11);
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

  PROCEND display_memory_data;
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_mrt_data_command', EJECT ??

{ PURPOSE:
{   This procedure displays the MRT data from the EIC record.

  PROCEDURE [XDCL] dup$display_mrt_data_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_mrt_data, dismd (
{   output, o: file = $optional
{   title, t: string 1..31 = 'display_mrt_data'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (18),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 4, 20, 9, 39, 13, 361],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TITLE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 18],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_mrt_data'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$title = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    TYPE
      t$descriptor = PACKED RECORD
        CASE boolean OF
        = TRUE =
          header: 0 .. 0ffff(16),
        = FALSE =
          unused: 0 .. 0f(16),
          length: 0 .. 077(8),
          id: 0 .. 077(8),
        CASEND,
      RECEND;

    VAR
      cell_p: ^cell,
      cell_2_p: ^cell,
      cip_program_available: boolean,
      cip_program_cell_p: ^cell,
      descriptor_p: ^t$descriptor,
      display_control: clt$display_control,
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      level_address_size: integer,
      output_display_opened: boolean,
      restart_file_seq_p: ^SEQ ( * ),
      ring_attributes: amt$ring_attributes,
      skip_integer_p: ^integer,
      skip_p: ^SEQ ( * ),
      size_p: ^0 .. 0ffff(16),
      string_length: integer;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

      { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
      dup$retrieve_cip_program ('2AP ', cip_program_available, cip_program_cell_p);
      IF NOT cip_program_available THEN
        clp$put_display (display_control, ' ERROR - Cannot retrieve the 2AP CIP program.', clc$trim,
              ignore_status);
        EXIT /display_opened/;  {---->
      IFEND;
      RESET restart_file_seq_p TO cip_program_cell_p;
      NEXT skip_integer_p IN restart_file_seq_p;
      IF skip_integer_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /display_opened/;  {---->
      IFEND;
      NEXT size_p IN restart_file_seq_p;
      IF size_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /display_opened/;  {---->
      IFEND;
      level_address_size := (size_p^ * 2) + 8;
      RESET restart_file_seq_p TO cip_program_cell_p;
      NEXT skip_p: [[REP level_address_size OF cell]] IN restart_file_seq_p;
      IF skip_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /display_opened/;  {---->
      IFEND;

      WHILE TRUE DO
        NEXT cell_p IN restart_file_seq_p;
        IF cell_p = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
          EXIT /display_opened/;  {---->
        IFEND;
        RESET restart_file_seq_p TO cell_p;
        NEXT descriptor_p IN restart_file_seq_p;
        IF descriptor_p = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
          EXIT /display_opened/;  {---->
        IFEND;
        IF descriptor_p^.header = 0 THEN
          EXIT /display_opened/;
        IFEND;
        clp$put_display (display_control, '*******************************************************',
              clc$trim, ignore_status);

        IF descriptor_p^.id = 0 THEN
          STRINGREP (display_string, string_length, ' IOU (length=', descriptor_p^.length, ')');
        ELSEIF descriptor_p^.id = 1 THEN
          STRINGREP (display_string, string_length, ' MEMORY (length=', descriptor_p^.length, ')');
        ELSEIF descriptor_p^.id = 2 THEN
          STRINGREP (display_string, string_length, ' CPU (length=', descriptor_p^.length, ')');
        ELSEIF descriptor_p^.id = 3 THEN
          STRINGREP (display_string, string_length, ' MAINFRAME (length=', descriptor_p^.length, ')');
        ELSEIF descriptor_p^.id = 4 THEN
          STRINGREP (display_string, string_length, ' FLPP (length=', descriptor_p^.length, ')');
        ELSEIF descriptor_p^.id = 5 THEN
          STRINGREP (display_string, string_length, ' CONSOLE (length=', descriptor_p^.length, ')');
        ELSEIF descriptor_p^.id = 6 THEN
          STRINGREP (display_string, string_length, ' GLOBAL PROCESSOR (length=', descriptor_p^.length, ')');
        ELSEIF descriptor_p^.id = 8 THEN
          STRINGREP (display_string, string_length, ' DATE/TIME/FRC (length=', descriptor_p^.length, ')');
        ELSEIF descriptor_p^.id = 9 THEN
          STRINGREP (display_string, string_length, ' S0 DATA (length=', descriptor_p^.length, ')');
        ELSEIF descriptor_p^.id = 10 THEN
          STRINGREP (display_string, string_length, ' PAGE MAP (length=', descriptor_p^.length, ')');
        ELSEIF descriptor_p^.id = 11 THEN
          STRINGREP (display_string, string_length, ' DFT/OS (length=', descriptor_p^.length, ')');
        ELSE
          STRINGREP (display_string, string_length, ' UNKNOWN (length=', descriptor_p^.length, ')');
        IFEND;
        clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

        RESET restart_file_seq_p TO cell_p;
        display_data_raw (descriptor_p^.length, restart_file_seq_p, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;

        NEXT cell_2_p IN restart_file_seq_p;
        IF cell_2_p = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
          EXIT /display_opened/;  {---->
        IFEND;
        RESET restart_file_seq_p TO cell_p;

        IF descriptor_p^.id = 0 THEN
          display_iou_data (display_control, restart_file_seq_p, status);
        ELSEIF descriptor_p^.id = 1 THEN
          display_memory_data (display_control, restart_file_seq_p, status);
        ELSEIF descriptor_p^.id = 2 THEN
          display_cpu_data (display_control, restart_file_seq_p, status);
        ELSEIF descriptor_p^.id = 3 THEN
          display_mainframe_data (display_control, restart_file_seq_p, status);
        ELSEIF descriptor_p^.id = 4 THEN
        ELSEIF descriptor_p^.id = 5 THEN
          display_console_data (display_control, restart_file_seq_p, status);
        ELSEIF descriptor_p^.id = 6 THEN
          display_global_processor_data (display_control, restart_file_seq_p, status);
        ELSEIF descriptor_p^.id = 8 THEN
          display_clock_data (display_control, restart_file_seq_p, status);
        ELSEIF descriptor_p^.id = 9 THEN
        ELSEIF descriptor_p^.id = 10 THEN
        ELSEIF descriptor_p^.id = 11 THEN
          display_dft_data (display_control, restart_file_seq_p, status);
        ELSE
        IFEND;
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;

        RESET restart_file_seq_p TO cell_2_p;

      WHILEND;
    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_mrt_data_command;
MODEND dum$display_mrt_data_command;
*DECK DECK=DUM$DISPLAY_MS_CLASSES EXPAND=TRUE
PROCEDURE dum$display_ms_classes, display_ms_classes, display_ms_class, dismsc (
  address, a, pva: integer = 100264d09(16)
  output, o: file = $output
  status)

  create_variable letters k=(string, 1) d=1..32
  letters(1) = ' '
  letters(2) = ' '
  letters(3) = ' '
  letters(4) = ' '
  letters(5) = ' '
  letters(6) = ' '
  letters(7) = 'A'
  letters(8) = 'B'
  letters(9) = 'C'
  letters(10) = 'D'
  letters(11) = 'E'
  letters(12) = 'F'
  letters(13) = 'G'
  letters(14) = 'H'
  letters(15) = 'I'
  letters(16) = 'J'
  letters(17) = 'K'
  letters(18) = 'L'
  letters(19) = 'M'
  letters(20) = 'N'
  letters(21) = 'O'
  letters(22) = 'P'
  letters(23) = 'Q'
  letters(24) = 'R'
  letters(25) = 'S'
  letters(26) = 'T'
  letters(27) = 'U'
  letters(28) = 'V'
  letters(29) = 'W'
  letters(30) = 'X'
  letters(31) = 'Y'
  letters(32) = 'Z'

  output_line = ' valid classes: '

  class = $mem($value(address), 4)

  FOR index = 1 TO 32 DO
    IF $bit(class, index+31) THEN
      output_line = output_line//letters(index)
    IFEND
  FOREND

  output_line = output_line//' - ('//$strrep(class, 16)//')'
  putl output_line o=$value(output)

PROCEND dum$display_ms_classes
*DECK DECK=DUM$DISPLAY_NUMBER_OF_FILES EXPAND=TRUE

PROCEDURE dum$display_number_of_files, display_number_of_files, disnof (
  output, o: file = $output
  )

  "$FORMAT=OFF"
  VAR
    cdu_number: integer=0
    entry_assignment: string
    number_of_entries: integer
    number_of_files: integer=0
    "offsets & lengths
    cycle_description_offset: integer
    entries_length: integer
    entries_offset: integer
    entry_assignment_offset: integer
    length: integer
    next_cdu_offset: integer
    offset: integer
    "addresses
    cdu_address: integer
    entries_address: integer
    entry_assignment_address: integer
  VAREND
  "$FORMAT=ON"

  fmt$cycle_description_unit field=entry_assignment offset=offset length=length
  entry_assignment_offset = offset/8

  fmt$cycle_description_unit field=entries offset=offset length=length
  entries_offset = offset/8

  fmt$cycle_description_unit field=next_cycle_description_unit offset=offset length=length
  next_cdu_offset = offset/8

  cdu_address = $memory($symbol_address(fmv$initial_cdu_pointer))


  display_value v=('DUM$DISPLAY_NUMBER_OF_FILES') o=output
  out = output.$eoi

  WHEN any_fault DO
    put_line l=(' number_of_cdus >= '//$strrep(cdu_number), ' number_of_files >= '//$strrep(number_of_files)..
          ) o=out
  WHENEND

  REPEAT
    cdu_number = cdu_number + 1
    entry_assignment_address = $memory((cdu_address+entry_assignment_offset))
    number_of_entries = $memory((cdu_address+entry_assignment_offset+6), 2)
    entry_assignment = $memory_string(entry_assignment_address, number_of_entries)
    entries_address = $memory((cdu_address+entries_offset))

    FOR i = 1 TO number_of_entries DO
      IF $substr(entry_assignment, i, 1) = 'A' THEN
        number_of_files = number_of_files + 1
      IFEND
    FOREND

    cdu_address = $memory((cdu_address+next_cdu_offset))
  UNTIL $nil_pva(cdu_address)

  put_line l=(' number_of_cdus = '//$strrep(cdu_number), ' number_of_files = '//$strrep(number_of_files)) ..
        o=out

PROCEND dum$display_number_of_files
*DECK DECK=DUM$DISPLAY_OS_BUILD_LEVEL EXPAND=TRUE
PROCEDURE dum$display_os_build_level, display_os_build_level, disobl, disbl (
  output, o: file = $output
  status)

  VAR
    build_level_string: string (31)
    local_status: status
  VAREND

  display_memory a=$symbol_address(osv$build_level) b=22 e=monitor p=0 am=pva o=$null status=local_status
  IF NOT local_status.normal THEN
    display_memory a=$symbol_address(osv$build_level) b=22 e=monitor p=1 am=pva o=$null status=local_status
    IF NOT local_status.normal THEN
      put_line l='     The OS build level is not retrievable.' o=output
      EXIT PROCEDURE
    IFEND
  IFEND

  build_level_string = ' '
  build_level_string = '     '//$memory_string($symbol_address(osv$build_level) 22 monitor 0 pva)
  put_line l=build_level_string o=output

PROCEND dum$display_os_build_level
*DECK DECK=DUM$DISPLAY_OS_VERSION EXPAND=TRUE
PROCEDURE dum$display_os_version, display_os_version, disov (
  output, o: file = $output
  status)

  VAR
    local_status: status
    output_file: file
  VAREND

  IF $file(output open_position) = '$BOI' THEN
    delete_file f=output status=local_status
  IFEND
  output_file = output.$eoi

  change_default e=monitor am=pva
  display_memory a=$symbol_address(osv$build_level) b=22 e=monitor p=0 am=pva o=$null status=local_status
  IF NOT local_status.normal THEN
    display_memory a=$symbol_address(osv$build_level) b=22 e=monitor p=1 am=pva o=$null status=local_status
    IF NOT local_status.normal THEN
      put_line l='     The OS version is not retrievable.' o=output
      EXIT PROCEDURE
    IFEND
  IFEND
  os_version = $memory_string($symbol_address(osv$build_level) 22)

  IF $substr(os_version 1 6) = 'NOS/VE' THEN
    put_line l=' Operating System Version = '//os_version o=output_file
    jps = $memory($symbol_address(mtv$cst0)+2c(16) 4)
    change_processor_register jps=jps
    change_default e=job
  ELSE
    memory_p = 100000000(16)
    os = 'NOS/VE'

    REPEAT
      memory_string = $memory_string(memory_p $max_string)
      index = $scan_string(os memory_string)
      IF index = 0 THEN
        memory_p = memory_p + $max_string - $strlen(os)
      ELSE
        os_version = $memory_string(memory_p+index-1 22)
        put_line l=' The debug table you are using does not match the' o=output_file
        put_line l=' dump. The dump is '//$quote(os_version) o=output_file
        EXIT PROCEDURE
      IFEND
    UNTIL memory_p > 100001000(16)

    put_line l=' Unable to find the os version in the dump.' o=output_file
  IFEND

PROCEND dum$display_os_version
*DECK DECK=DUM$DISPLAY_PATH_TABLE EXPAND=TRUE

PROCEDURE dum$display_path_table, display_path_table, dispt (
  display_option, d, depth, do: key
      (path_description_entry, pde)
      (cycle_description, cd)
      (full, all, f)
    keyend = path_description_entry
  output, o: file = $output
  status)

  "$FORMAT=OFF"
  VAR
    entry_assignment: string
    number_of_entries: integer
    pdu_number: integer=0
    "offsets & lengths
    entries_offset: integer
    entry_assignment_offset: integer
    length: integer
    next_pdu_offset: integer
    offset: integer
    pde_length: integer
    "addresses
    entries_address: integer
    entry_assignment_address: integer
    pde_address: integer
    pdu_address: integer
    page_status: status
  VAREND
  "$FORMAT=ON"

  fmt$path_description_unit field=next_path_description_unit offset=offset length=length
  next_pdu_offset = offset/8

  fmt$path_description_unit field=entry_assignment offset=offset length=length
  entry_assignment_offset = offset/8

  fmt$path_description_unit field=entries offset=offset length=length
  entries_offset = offset/8

  fmt$path_description_entry field=fmt$path_description_entry offset=offset length=length
  pde_length = length/8

  pdu_address = $memory($symbol_address(fmv$initial_pdu_pointer))


  display_value v=('DUM$DISPLAY_PATH_TABLE') o=output
  out = output.$eoi

  REPEAT
    pdu_number = pdu_number + 1
    put_line ('- **PATH_DESCRIPTION_UNIT** '//..
$strrep(pdu_number, 16)//'    Address = '//$strrep(pdu_address, 16)) o=out
    fmt$path_description_unit a=pdu_address o=out

    entry_assignment_address = $memory((pdu_address+entry_assignment_offset))
    number_of_entries = $memory((pdu_address+entry_assignment_offset+6), 2)
    entry_assignment = $memory_string(entry_assignment_address, number_of_entries)
    entries_address = $memory((pdu_address+entries_offset))

    put_line l=' ENTRY_ASSIGNMENT STRING' o=out
    put_line l=' '//$substr(entry_assignment, 1, number_of_entries) o=out

    FOR i = 1 TO number_of_entries DO
      IF $substr(entry_assignment, i, 1) = 'A' THEN
        pde_address = entries_address + ((i-1)* pde_length)
        put_line l=('0', '  **PATH_DESCRIPTION_ENTRY** '//..
$strrep(i)//'    Address = '//$strrep(pde_address, 16)) o=out
        dum$display_pde $offset(pde_address) do=display_option o=out status=page_status
        IF NOT page_status.normal THEN
         disv page_status o=out
        IFEND
      IFEND
    FOREND

    pdu_address = $memory((pdu_address+next_pdu_offset))
  UNTIL $nil_pva(pdu_address)

PROCEND dum$display_path_table
*DECK DECK=DUM$DISPLAY_PATH_TABLE_FILES EXPAND=TRUE

PROCEDURE dum$display_path_table_files, display_path_table_files, disptf (
  display_option, d, depth, do: key
      path
      (cycle_description, cd)
      (full, all, f)
    keyend = path
  output, o: file = $output
  status)

  "$FORMAT=OFF"
  VAR
    entry_assignment: string
    entry_type: integer
    number_of_entries: integer
    path: string
    path_node_name_size: integer
    pdu_number: integer=0
    "offsets & lengths
    cycle_number_length: integer
    cycle_number_offset: integer
    entries_offset: integer
    entry_assignment_offset: integer
    entry_type_length: integer
    entry_type_offset: integer
    first_cycle_alias_entry_offset: integer
    length: integer
    next_cycle_alias_entry_offset: integer
    next_pdu_offset: integer
    offset: integer
    parental_path_entry_offset: integer
    path_node_name_size_length: integer
    path_node_name_size_offset: integer
    path_node_name_value_offset: integer
    pde_length: integer
    cycle_description_offset: integer
    "addresses
    cycle_description_address: integer
    entries_address: integer
    entry_assignment_address: integer
    parental_path_address: integer
    pde_address: integer
    pdu_address: integer
    page_status: status
  VAREND
  "$FORMAT=ON"


  fmt$path_description_unit field=entry_assignment offset=offset length=length
  entry_assignment_offset = offset/8

  fmt$path_description_unit field=entries offset=offset length=length
  entries_offset = offset/8

  fmt$path_description_entry field=fmt$path_description_entry offset=offset length=length
  pde_length = length/8

  fmt$path_description_entry field=parental_path_entry offset=offset length=length
  parental_path_entry_offset = offset/8

  fmt$path_description_entry field=entry_type offset=offset length=length
  entry_type_offset = offset/8
  entry_type_length = length/8

  fmt$path_description_entry field=cycle_description offset=offset length=length
  cycle_description_offset = offset/8

  fmt$path_description_entry field=first_cycle_alias_entry offset=offset length=length
  first_cycle_alias_entry_offset = offset/8

  fmt$path_description_entry field=next_cycle_alias_entry offset=offset length=length
  next_cycle_alias_entry_offset = offset/8

  fmt$path_description_entry field=path_node_name offset=offset length=length
  fst$path_element field=value offset=path_node_name_value_offset length=length
  path_node_name_value_offset = (offset+path_node_name_value_offset)/8

  fst$path_element field=size offset=path_node_name_size_offset length=length
  path_node_name_size_offset = (offset+path_node_name_size_offset)/8
  path_node_name_size_length = length/8

  fmt$path_description_entry field=cycle_number offset=offset length=length
  cycle_number_offset = offset/8
  cycle_number_length = length/8

  pdu_address = $memory($symbol_address(fmv$initial_pdu_pointer))

  display_value v=('DUM$DISPLAY_PATH_TABLE_FILES') o=output
  out = output.$eoi

  REPEAT
    pdu_number = pdu_number + 1
    entry_assignment_address = $memory((pdu_address+entry_assignment_offset))
    number_of_entries = $memory((pdu_address+entry_assignment_offset+6), 2)
    entry_assignment = $memory_string(entry_assignment_address, number_of_entries)
    entries_address = $memory((pdu_address+entries_offset))

    FOR i = 1 TO number_of_entries DO
      path = ''
      IF $substr(entry_assignment, i, 1) = 'A' THEN
        pde_address = entries_address + ((i-1)* pde_length)
        entry_type = $memory((pde_address+entry_type_offset), entry_type_length)
        IF entry_type = 1 THEN "file_cycle_object
          cycle_description_address = $memory((pde_address+cycle_description_offset))
          IF NOT $nil_pva(cycle_description_address) THEN
            dum$get_path_string $offset(pde_address) path status=page_status
            put_line l=(' PDE Address = '//$strrep(pde_address, 16)//'  path = '//path) o=out
            alias_address = $memory((pde_address+first_cycle_alias_entry_offset))
            WHILE NOT $nil_pva(alias_address) DO
              path_node_name_size = $memory((alias_address+path_node_name_size_offset), ..
                    path_node_name_size_length)
              put_line l=('   PDE Address = '//$strrep(alias_address, 16)//'  alias = '//..
$memory_string((alias_address+path_node_name_value_offset), path_node_name_size)) o=out
              alias_address = $memory(alias_address+next_cycle_alias_entry_offset)
            WHILEND
            IF display_option <> path THEN
              dum$display_pde $offset(pde_address) do=display_option o=out status=page_status
              put_line l='0' o=out
            IFEND
          IFEND
        IFEND
      IFEND
    FOREND
    " first 6 bytes of pdu are ptr to next pdu "
    pdu_address = $memory(pdu_address)
  UNTIL $nil_pva(pdu_address)

PROCEND dum$display_path_table_files
*DECK DECK=DUM$DISPLAY_PC_CONSOLE_INFO EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display PC Console Information Command' ??
MODULE dum$display_pc_console_info;

{ PURPOSE:
{   This module contains the command which displays the PC console information that is stored in the
{   CSI record.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$find_record_list_entry
*copyc dup$new_page_procedure
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? NEWTITLE := 'dup$display_pc_console_info', EJECT ??

{ PURPOSE:
{   This procedure displays the PC Console information.

  PROCEDURE [XDCL] dup$display_pc_console_info
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_pc_console_info, dispci (
{   output, o: file = $optional
{   title, t: string 1..31 = 'display_pc_console_information'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (32),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 9, 4, 7, 8, 48, 425],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TITLE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 32],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_pc_console_information'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$title = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    CONST
      c$number_of_bytes = 42;

    TYPE
      t$record_data = PACKED ARRAY [1 .. c$number_of_bytes] OF t$record_data_entry,

      t$record_data_entry = PACKED RECORD
        unused: 0 .. 0f(16),
        data: 0 .. 0ff(16),
      RECEND,

      t$unpacked_data = RECORD
        CASE boolean OF
        = TRUE =
          data: ARRAY [1 .. c$number_of_bytes] OF 0 .. 0ff(16),
        = FALSE =
          pc_identifier: string (8),
          pc_revision_number: string (16),
          msdos_revision_number: string (4),
          pc_rom_bios_level: string (4),
          pc_memory_size: string (6),
          power_monitor_identifier: string (4),
        CASEND,
      RECEND;

    VAR
      cell_p: ^cell,
      data_value: clt$data_value,
      display_control: clt$display_control,
      display_string: string (osc$max_string_size),
      entry_p: ^dut$de_other_record_entry,
      ignore_status: ost$status,
      index: 0 .. 0ff(16),
      output_display_opened: boolean,
      record_data_p: ^t$record_data,
      restart_file_seq_p: ^SEQ ( * ),
      ring_attributes: amt$ring_attributes,
      string_length: integer,
      unpacked_data: t$unpacked_data;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

    { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      data_value.kind := clc$name;
      data_value.name_value := 'CSI';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The CSI record is', status);
        EXIT /display_opened/;  {---->
      IFEND;

      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);
      RESET restart_file_seq_p TO cell_p;

      IF #SIZE (t$record_data) > entry_p^.size THEN
        clp$put_display (display_control, 'ERROR - Not enough data in the record, data not displayed.',
              clc$trim, ignore_status);
        EXIT /display_opened/;  {---->
      IFEND;

      NEXT record_data_p IN restart_file_seq_p;

      FOR index := 1 TO c$number_of_bytes DO
        unpacked_data.data [index] := record_data_p^ [index].data;
      FOREND;

      clp$put_display (display_control, 'CSI - PC Console System Record:', clc$trim, ignore_status);
      clp$put_display (display_control, ' ', clc$trim, ignore_status);

      STRINGREP (display_string, string_length, ' PC Console Identifier = ', unpacked_data.pc_identifier);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

      STRINGREP (display_string, string_length, ' PC Console Level/Revision Number = ',
            unpacked_data.pc_revision_number);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

      STRINGREP (display_string, string_length, ' MSDOS Level/Revision Number = ',
            unpacked_data.msdos_revision_number);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

      STRINGREP (display_string, string_length, ' PC Console ROM BIOS Level = ',
            unpacked_data.pc_rom_bios_level);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

      STRINGREP (display_string, string_length, ' PC Console Memory Size (Kbytes) = ',
            unpacked_data.pc_memory_size);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

      STRINGREP (display_string, string_length, ' Power/Environment Monitor Identifier = ',
            unpacked_data.power_monitor_identifier);
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_pc_console_info;
MODEND dum$display_pc_console_info;
*DECK DECK=DUM$DISPLAY_PDE EXPAND=TRUE

PROCEDURE dum$display_pde, display_pde, display_path_description_entry, dispde (
  pde_offset, po: integer = $required
  display_option, d, depth, do: key
      (path_description_entry, pde)
      (cycle_description, cd)
      (full, all, f)
    keyend = path_description_entry
  output, o: file = $output
  status)

  "$FORMAT=OFF"
  VAR
    entry_type: integer
    number_of_entries: integer
    path: string
    "offsets & lengths
    cycle_description_offset: integer
    entry_type_length: integer
    entry_type_offset: integer
    gfi_offset: integer
    length: integer
    offset: integer
    "addresses
    cycle_description_address: integer
    gfi_address: integer
    pde_address: integer = (200400000000(16)+pde_offset)
    page_status: status
  VAREND
  "$FORMAT=ON"

  fmt$path_description_entry field=entry_type offset=offset length=length
  entry_type_offset = offset/8
  entry_type_length = length/8

  fmt$path_description_entry field=cycle_description offset=offset length=length
  cycle_description_offset = offset/8

  fmt$cycle_description field=global_file_information offset=offset length=length
  gfi_offset = offset/8


  display_value v=('DUM$DISPLAY_PDE') o=output
  out = output.$eoi

  dum$get_path_string pde_offset=pde_offset p=path status=page_status
  IF page_status.normal THEN
    put_line l='-path = '//$trim(path) o=out
  ELSE
    disv ' Unable to get_path ' o=out
  IFEND

  put_line l=('0 **PATH_DESCRIPTION_ENTRY**    Address = '//$strrep(pde_address, 16)) o=out
  fmt$path_description_entry a=pde_address o=out

  entry_type = $memory((pde_address+entry_type_offset), entry_type_length)
  IF (entry_type = 1) AND (display_option <> path_description_entry) THEN "file_cycle_object
    cycle_description_address = $memory((pde_address+cycle_description_offset))
    IF NOT $nil_pva(cycle_description_address) THEN
      put_line l=('0 **CYCLE_DESCRIPTION_ENTRY**    Address  = '//$strrep(cycle_description_address, 16)) ..
            o=out
      fmt$cycle_description a=cycle_description_address o=out
      IF display_option = full THEN
        gfi_address = $memory((cycle_description_address+gfi_offset))
        put_line ('0 **GLOBAL_FILE_INFORMATION**    Address  = '//$strrep(gfi_address, 16)) o=out
        bat$global_file_information a=gfi_address o=out
      IFEND
    IFEND
  IFEND

PROCEND dum$display_pde

*DECK DECK=DUM$DISPLAY_PHYSICAL_CONFIG EXPAND=TRUE
PROCEDURE dum$display_physical_config display_physical_config, dispc (
  output, o: file = $output
  status)

  VAR
    element_size: integer
    ignore_status: status
    index: integer
    number_of_entries: integer
    output_file: file
    physical_configuration_p: integer
    starting_address: integer
    total_size: integer
  VAREND

  IF $file(output open_position) = '$BOI' THEN
    delete_file f=output status=ignore_status
  IFEND
  output_file = output.$eoi

  physical_configuration_p = $symbol_address(cmv$physical_configuration)

  starting_address = $memory(physical_configuration_p, 6, job)
  total_size = $memory((physical_configuration_p + 6), 4, job)
  element_size = $memory((physical_configuration_p + 14), 4, job)

  number_of_entries = total_size / element_size

  FOR index = 0 TO (number_of_entries - 1) DO
    put_line l=' Element # '//$strrep(index+1) o=output_file
    cmt$element_definition (starting_address + index * element_size) o=output_file
  FOREND

PROCEND dum$display_physical_config
*DECK DECK=DUM$DISPLAY_PHYSICAL_FMD EXPAND=TRUE
PROCEDURE dum$display_physical_fmd, display_physical_fmd, dispfmd (
  address, a: integer = $required
  output, o: file = $output
  status)

  VAR
    header_adr: integer
    temp_file: file = $fname($unique)
  VAREND

  set_file_attributes file=temp_file page_format=continuous

  dispv ?address.pft$physical_fmd o=temp_file
  put_line ' ' o=temp_file.$eoi

  stored_fmd_adr = address + 8
  display_stored_fmd address=stored_fmd_adr o=temp_file.$eoi

  copy_file i=temp_file o=output
  detach_file f=temp_file

PROCEND dum$display_physical_fmd
*DECK DECK=DUM$DISPLAY_PP_MEMORY_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display PP Memory Command' ??                                          
MODULE dum$display_pp_memory_command;                                                                         
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains the code for the display_pp_memory command.                                          
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc due$exception_condition_codes                                                                          
?? POP ??                                                                                                     
*copyc clp$close_display                                                                                      
*copyc clp$convert_integer_to_string                                                                          
*copyc clp$open_display_reference                                                                             
*copyc clp$put_display                                                                                        
*copyc dup$determine_dump_information                                                                         
*copyc dup$display_data                                                                                       
*copyc dup$evaluate_parameters                                                                                
*copyc dup$new_page_procedure                                                                                 
*copyc dup$retrieve_register                                                                                  
*copyc osp$append_status_integer                                                                              
*copyc osp$append_status_parameter                                                                            
*copyc osp$disestablish_cond_handler                                                                          
*copyc osp$establish_block_exit_hndlr                                                                         
*copyc osp$set_status_abnormal                                                                                
?? EJECT ??                                                                                                   
*copyc duv$dump_environment_p                                                                                 
*copyc duv$execution_environment                                                                              
*copyc duv$title_data                                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'display_r_register_value', EJECT ??                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays the R register value for the desired PP.                                          
                                                                                                              
  PROCEDURE display_r_register_value                                                                          
    (    dump_information: dut$dump_information;                                                              
         iou_number: 0 .. duc$de_maximum_ious;                                                                
         pp_number: 0 .. duc$de_max_pp_memories;                                                              
         radix: 8 .. 16;                                                                                      
         nio_pp: boolean;                                                                                     
     VAR display_control: clt$display_control);                                                               
                                                                                                              
    TYPE                                                                                                      
      t$byte_or_bits = PACKED RECORD                                                                          
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          byte_part: 0 .. 0ff(16),                                                                            
        = FALSE =                                                                                             
          bit_part: PACKED ARRAY [56 .. 63] OF boolean,                                                       
        CASEND,                                                                                               
      RECEND;                                                                                                 
                                                                                                              
    VAR                                                                                                       
      byte_or_bits: t$byte_or_bits,                                                                           
      display_string: string (osc$max_string_size),                                                           
      register: dut$de_maintenance_register,                                                                  
      string_length: integer,                                                                                 
      ignore_status: ost$status,                                                                              
      integer_string: ost$string;                                                                             
                                                                                                              
    IF (iou_number > 0) AND (dump_information.dump_type <> duc$di_dt_cy2000) THEN                             
      STRINGREP (display_string, string_length,                                                               
            'WARNING: The R Register contents is invalid for each PP in IOU', iou_number, '.');               
      clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);          
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    dup$retrieve_register (duc$de_iou, iou_number, 0, register);                                              
    IF register.available THEN                                                                                
      byte_or_bits.byte_part := register.value [8];                                                           
      IF byte_or_bits.bit_part [57] AND (dump_information.iou [iou_number].model <> duc$di_im_i0_5x) THEN     
        CASE dump_information.tape_type OF                                                                    
        = duc$di_tt_unknown =                                                                                 
          clp$put_display (display_control,                                                                   
                ' WARNING: Bit 57 in the IOU Status Summary Register is set and the',                         
                clc$trim, ignore_status);                                                                     
          clp$put_display (display_control,                                                                   
                '          dump was taken on a tape drive configured on an unknown channel.',                 
                clc$trim, ignore_status);                                                                     
          clp$put_display (display_control,                                                                   
                '          It might have been necessary to perform an ADU Master Clear and',                  
                clc$trim, ignore_status);                                                                     
          clp$put_display (display_control,                                                                   
                '          therefore the R Register contents might be invalid.', clc$trim, ignore_status);    
        = duc$di_tt_40, duc$di_tt_41 =                                                                        
          clp$put_display (display_control,                                                                   
                ' WARNING: Bit 57 in the IOU Status Summary Register is set and the',                         
                clc$trim, ignore_status);                                                                     
          clp$put_display (display_control,                                                                   
                '          dump was taken on a tape drive configured on an IPI channel.',                     
                clc$trim, ignore_status);                                                                     
          clp$put_display (display_control,                                                                   
                '          It was necessary to perform an ADU Master Clear and therefore',                    
                clc$trim, ignore_status);                                                                     
          clp$put_display (display_control,                                                                   
                '          the R Register contents are invalid.', clc$trim, ignore_status);                   
        ELSE                                                                                                  
        CASEND;                                                                                               
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    IF nio_pp THEN                                                                                            
      clp$convert_integer_to_string (duv$dump_environment_p^.iou_memory [iou_number].                         
            nio_pp [pp_number].r_register, radix, TRUE, integer_string, ignore_status);                       
    ELSE                                                                                                      
      clp$convert_integer_to_string (duv$dump_environment_p^.iou_memory [iou_number].                         
            cio_pp [pp_number].r_register, radix, TRUE, integer_string, ignore_status);                       
    IFEND;                                                                                                    
    STRINGREP (display_string, string_length, 'R register = ',                                                
          integer_string.value (1, integer_string.size));                                                     
    clp$put_display (display_control, display_string (1, string_length), clc$trim, ignore_status);            
                                                                                                              
  PROCEND display_r_register_value;                                                                           
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$display_pp_memory_command', EJECT ??                                                      
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure displays the pp memory.                                                                    
{ NOTE:                                                                                                       
{   This procedure refers to a "word".  The definition of a word for this procedure is a two byte data        
{   structure.                                                                                                
                                                                                                              
  PROCEDURE [XDCL] dup$display_pp_memory_command                                                              
    (    parameter_list: clt$parameter_list;                                                                  
     VAR status: ost$status);                                                                                 
                                                                                                              
{ PROCEDURE display_pp_memory, dispm (                                                                        
{   pp_number, pn: integer 0..25 = $required                                                                  
{   address, a: integer 0..16383 = 0                                                                          
{   words, w: integer 0..16384 = 16384                                                                        
{   pp_type, pt: key                                                                                          
{       (normal n) (concurrent_input_output cio c)                                                            
{     keyend = concurrent_input_output                                                                        
{   display_option, do: list 1..2 of key                                                                      
{       (numeric n) (ascii a) (display_code dc)                                                               
{     keyend = (numeric ascii)                                                                                
{   radix, r: integer 8..16 = 8                                                                               
{   display_relocation_register, drr: boolean = $optional                                                     
{   title, t: string 1..31 = $optional                                                                        
{   output, o: file                                                                                           
{   iou, i: integer 0..1 = 0                                                                                  
{   status)                                                                                                   
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 21] of clt$pdt_parameter_name,                                                       
      parameters: array [1 .. 11] of clt$pdt_parameter,                                                       
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type3: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (5),                                                                            
      recend,                                                                                                 
      type4: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$keyword_type_qualifier,                                                                
        keyword_specs: array [1 .. 5] of clt$keyword_specification,                                           
        default_value: string (23),                                                                           
      recend,                                                                                                 
      type5: 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 .. 6] of clt$keyword_specification,                                         
        recend,                                                                                               
        default_value: string (15),                                                                           
      recend,                                                                                                 
      type6: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type7: record                                                                                           
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
      type8: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$string_type_qualifier,                                                                 
      recend,                                                                                                 
      type9: record                                                                                           
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
      type10: record                                                                                          
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type11: record                                                                                          
        header: clt$type_specification_header,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [92, 1, 22, 11, 39, 31, 112],                                                                             
    clc$command, 21, 11, 1, 0, 0, 0, 11, ''], [                                                               
    ['A                              ',clc$abbreviation_entry, 2],                                            
    ['ADDRESS                        ',clc$nominal_entry, 2],                                                 
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 5],                                                 
    ['DISPLAY_RELOCATION_REGISTER    ',clc$nominal_entry, 7],                                                 
    ['DO                             ',clc$abbreviation_entry, 5],                                            
    ['DRR                            ',clc$abbreviation_entry, 7],                                            
    ['I                              ',clc$abbreviation_entry, 10],                                           
    ['IOU                            ',clc$nominal_entry, 10],                                                
    ['O                              ',clc$abbreviation_entry, 9],                                            
    ['OUTPUT                         ',clc$nominal_entry, 9],                                                 
    ['PN                             ',clc$abbreviation_entry, 1],                                            
    ['PP_NUMBER                      ',clc$nominal_entry, 1],                                                 
    ['PP_TYPE                        ',clc$nominal_entry, 4],                                                 
    ['PT                             ',clc$abbreviation_entry, 4],                                            
    ['R                              ',clc$abbreviation_entry, 6],                                            
    ['RADIX                          ',clc$nominal_entry, 6],                                                 
    ['STATUS                         ',clc$nominal_entry, 11],                                                
    ['T                              ',clc$abbreviation_entry, 8],                                            
    ['TITLE                          ',clc$nominal_entry, 8],                                                 
    ['W                              ',clc$abbreviation_entry, 3],                                            
    ['WORDS                          ',clc$nominal_entry, 3]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [12, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 2                                                                                                 
    [2, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 3                                                                                                 
    [21, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,                         
  clc$optional_default_parameter, 0, 5],                                                                      
{ PARAMETER 4                                                                                                 
    [13, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,                        
  clc$optional_default_parameter, 0, 23],                                                                     
{ PARAMETER 5                                                                                                 
    [3, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 245,                        
  clc$optional_default_parameter, 0, 15],                                                                     
{ PARAMETER 6                                                                                                 
    [16, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 7                                                                                                 
    [4, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],                                                                                                       
{ PARAMETER 8                                                                                                 
    [19, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],                                                                                                       
{ PARAMETER 9                                                                                                 
    [10, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],                                                                                                       
{ PARAMETER 10                                                                                                
    [8, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],                               
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 11                                                                                                
    [17, clc$normal_usage_entry, clc$non_secure_parameter,                                                    
    $clt$parameter_spec_methods[clc$specify_by_name],                                                         
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,                      
  clc$optional_parameter, 0, 0]],                                                                             
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 25, 10]],                                                                  
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, 16383, 10],                                                                
    '0'],                                                                                                     
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$integer_type], [0, 16384, 10],                                                                
    '16384'],                                                                                                 
{ PARAMETER 4                                                                                                 
    [[1, 0, clc$keyword_type], [5], [                                                                         
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                   
    ['CIO                            ', clc$alias_entry, clc$normal_usage_entry, 2],                          
    ['CONCURRENT_INPUT_OUTPUT        ', clc$nominal_entry, clc$normal_usage_entry, 2],                        
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                   
    ['NORMAL                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]                        
    ,                                                                                                         
    'concurrent_input_output'],                                                                               
{ PARAMETER 5                                                                                                 
    [[1, 0, clc$list_type], [229, 1, 2, 0, FALSE, FALSE],                                                     
      [[1, 0, clc$keyword_type], [6], [                                                                       
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                 
      ['ASCII                          ', clc$nominal_entry, clc$normal_usage_entry, 2],                      
      ['DC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                 
      ['DISPLAY_CODE                   ', clc$nominal_entry, clc$normal_usage_entry, 3],                      
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                 
      ['NUMERIC                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]                      
      ]                                                                                                       
    ,                                                                                                         
    '(numeric ascii)'],                                                                                       
{ PARAMETER 6                                                                                                 
    [[1, 0, clc$integer_type], [8, 16, 10],                                                                   
    '8'],                                                                                                     
{ PARAMETER 7                                                                                                 
    [[1, 0, clc$boolean_type]],                                                                               
{ PARAMETER 8                                                                                                 
    [[1, 0, clc$string_type], [1, 31, FALSE]],                                                                
{ PARAMETER 9                                                                                                 
    [[1, 0, clc$file_type]],                                                                                  
{ PARAMETER 10                                                                                                
    [[1, 0, clc$integer_type], [0, 1, 10],                                                                    
    '0'],                                                                                                     
{ PARAMETER 11                                                                                                
    [[1, 0, clc$status_type]]];                                                                               
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$pp_number = 1,                                                                                        
      p$address = 2,                                                                                          
      p$words = 3,                                                                                            
      p$pp_type = 4,                                                                                          
      p$display_option = 5,                                                                                   
      p$radix = 6,                                                                                            
      p$display_relocation_register = 7,                                                                      
      p$title = 8,                                                                                            
      p$output = 9,                                                                                           
      p$iou = 10,                                                                                             
      p$status = 11;                                                                                          
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 11] of clt$parameter_value;                                                            
                                                                                                              
    VAR                                                                                                       
      address: 0 .. 16383,                                                                                    
      cell_p: ^cell,                                                                                          
      default_list: ARRAY [1 .. 2] OF dut$default_change_list_entry,                                          
      display_control: clt$display_control,                                                                   
      display_r_register: boolean,                                                                            
      display_string: string (osc$max_string_size),                                                           
      dump_information: dut$dump_information,                                                                 
      end_of_input_file: boolean,                                                                             
      ignore_status: ost$status,                                                                              
      integer_string: ost$string,                                                                             
      iou_number: 0 .. duc$de_maximum_ious,                                                                   
      output_display_opened: boolean,                                                                         
      pp_number: 0 .. duc$de_max_pp_memories,                                                                 
      radix: 8 .. 16,                                                                                         
      restart_file_seq_p: ^SEQ ( * ),                                                                         
      ring_attributes: amt$ring_attributes,                                                                   
      skip_pp_data_p: ^SEQ ( * ),                                                                             
      string_length: integer,                                                                                 
      words: 0 .. 16384;                                                                                      
                                                                                                              
*copy dup$abort_handler                                                                                       
?? NEWTITLE := 'clean_up', EJECT ??                                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure is called from the abort handler to close the file.                                        
                                                                                                              
    PROCEDURE [INLINE] clean_up;                                                                              
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      IF output_display_opened THEN                                                                           
        clp$close_display (display_control, ignore_status);                                                   
      IFEND;                                                                                                  
                                                                                                              
    PROCEND clean_up;                                                                                         
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the PP_TYPE and IOU parameters.                                            
                                                                                                              
    default_list [1].default_name := duc$dp_pp_type;                                                          
    default_list [1].number := p$pp_type;                                                                     
    default_list [2].default_name := duc$dp_iou;                                                              
    default_list [2].number := p$iou;                                                                         
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Check the availability of the pp memory.                                                                
                                                                                                              
    pp_number := pvt [p$pp_number].value^.integer_value.value;                                                
    iou_number := pvt [p$iou].value^.integer_value.value;                                                     
                                                                                                              
  /determine_pp_availability/                                                                                 
    BEGIN                                                                                                     
      IF pvt [p$pp_type].value^.keyword_value = 'NORMAL' THEN                                                 
        IF duv$dump_environment_p^.iou_memory [iou_number].nio_pp [pp_number].available THEN                  
          EXIT /determine_pp_availability/;  {---->                                                           
        IFEND;                                                                                                
      ELSEIF (pp_number <= duc$de_max_cio_pp_memories) AND                                                    
            duv$dump_environment_p^.iou_memory [iou_number].cio_pp [pp_number].available THEN                 
        EXIT /determine_pp_availability/;  {---->                                                             
      IFEND;                                                                                                  
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                    
            'The peripheral processor', status);                                                              
      osp$append_status_integer (osc$status_parameter_delimiter, pp_number, 8, TRUE, status);                 
      osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);                             
      RETURN;  {---->                                                                                         
    END /determine_pp_availability/;                                                                          
                                                                                                              
    { Determine how many words to display.                                                                    
                                                                                                              
    address := pvt [p$address].value^.integer_value.value;                                                    
    words := pvt [p$words].value^.integer_value.value;                                                        
    dup$determine_dump_information (dump_information);                                                        
    IF address >= dump_information.iou [iou_number].pp_word_size THEN                                         
      words := 0;                                                                                             
    ELSEIF (address + words) > dump_information.iou [iou_number].pp_word_size THEN                            
      words := dump_information.iou [iou_number].pp_word_size - address;                                      
    IFEND;                                                                                                    
                                                                                                              
    output_display_opened := FALSE;                                                                           
    osp$establish_block_exit_hndlr (^abort_handler);                                                          
                                                                                                              
   /display_opened/                                                                                           
    BEGIN                                                                                                     
                                                                                                              
    { Prepare the output display file.                                                                        
                                                                                                              
      IF pvt [p$output].specified THEN                                                                        
        ring_attributes.r1 := #RING (^ring_attributes);                                                       
        ring_attributes.r2 := #RING (^ring_attributes);                                                       
        ring_attributes.r3 := #RING (^ring_attributes);                                                       
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,     
              ring_attributes, display_control, status);                                                      
        IF NOT status.normal THEN                                                                             
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
        output_display_opened := TRUE;                                                                        
      ELSE                                                                                                    
        display_control := duv$execution_environment.output_file.display_control;                             
        display_control.line_number := display_control.page_length + 1;                                       
      IFEND;                                                                                                  
                                                                                                              
      duv$title_data.build_title := TRUE;                                                                     
      IF pvt [p$title].specified THEN                                                                         
        duv$title_data.command_name := pvt [p$title].value^.string_value^;                                    
      ELSE                                                                                                    
        duv$title_data.command_name := 'display_pp_memory pp_number=';                                        
        clp$convert_integer_to_string (pp_number, 10, FALSE, integer_string, ignore_status);                  
        duv$title_data.command_name (29, integer_string.size) :=                                              
              integer_string.value (1, integer_string.size);                                                  
      IFEND;                                                                                                  
                                                                                                              
      { Display the relocation register if desired.                                                           
                                                                                                              
      IF pvt [p$display_relocation_register].specified THEN                                                   
        display_r_register := pvt [p$display_relocation_register].value^.boolean_value.value;                 
      ELSE                                                                                                    
        display_r_register := (words = dump_information.iou [iou_number].pp_word_size);                       
      IFEND;                                                                                                  
      radix := pvt [p$radix].value^.integer_value.value;                                                      
      IF display_r_register THEN                                                                              
        display_r_register_value (dump_information, iou_number, pp_number, radix,                             
              (pvt [p$pp_type].value^.keyword_value = 'NORMAL'), display_control);                            
      IFEND;                                                                                                  
                                                                                                              
      { Return if there are no words to display.                                                              
                                                                                                              
      IF words = 0 THEN                                                                                       
        EXIT /display_opened/;  {---->                                                                        
      IFEND;                                                                                                  
                                                                                                              
      { Retrieve a sequence pointer to the pp memory data on the restart file.                                
                                                                                                              
      restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;          
      IF pvt [p$pp_type].value^.keyword_value = 'NORMAL' THEN                                                 
        cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),                        
              duv$dump_environment_p^.iou_memory [iou_number].nio_pp [pp_number].first_byte);                 
      ELSE                                                                                                    
        cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),                        
              duv$dump_environment_p^.iou_memory [iou_number].cio_pp [pp_number].first_byte);                 
      IFEND;                                                                                                  
      RESET restart_file_seq_p TO cell_p;                                                                     
                                                                                                              
      { Skip to the desired addess in the pp memory data.                                                     
                                                                                                              
      IF address <> 0 THEN                                                                                    
        NEXT skip_pp_data_p: [[REP (address * 2) OF CELL]] IN restart_file_seq_p;                             
        IF skip_pp_data_p = NIL THEN                                                                          
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          EXIT /display_opened/;  {---->                                                                      
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
      { Display the data.                                                                                     
                                                                                                              
      dup$display_data (pvt [p$display_option].value, FALSE, radix, address, words, display_control,          
            restart_file_seq_p, end_of_input_file, status);                                                   
                                                                                                              
    END /display_opened/;                                                                                     
                                                                                                              
    IF output_display_opened THEN                                                                             
      clp$close_display (display_control, ignore_status);                                                     
    IFEND;                                                                                                    
    osp$disestablish_cond_handler;                                                                            
                                                                                                              
  PROCEND dup$display_pp_memory_command;                                                                      
MODEND dum$display_pp_memory_command;                                                                         
*DECK DECK=DUM$DISPLAY_PP_REGS_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display PP Registers Command' ??
MODULE dum$display_pp_regs_command;

{ PURPOSE:
{   This module contains the code for the display_pp_registers command.
{
{   This command displays the contents of the A, P, Q and K registers for each PP that was assigned
{   to NOS/VE at the time the dump was taken (if the contents equal zero, the PP was not assigned).
{   There are several records on the dump file containing A, P, Q and K registers.
{     PSR = A, P, Q and K registers for IOU0 on non s0 mainframes.
{     PS1 = A, P, Q and K registers for IOU1 on non s0 mainframes.
{     PPR = A, P, Q and K registers for s0 mainframes.
{     DFT = A, P, Q and K registers from the DFT buffer.
{
{   PSR and PS1 dump records contain two sets of APQK registers for each PP; one set taken before the
{   PP was idled, and the second taken after.  Each set consists of 9 twelve-bit bytes (with each byte
{   containing 8 bits of right shifted valid data - except byte 6 which is 2 bits) in the following format:
{     byte 00 - P Register - Most Significant Bits (MSB)
{          01 - P Register - Least Significant Bits (LSB)
{          02 - Q Register - MSB
{          03 - Q Register - LSB
{          04 - K Register - MSB
{          05 - K Register - LSB
{          06 - A Register - Most Significant Two Bits
{          07 - A Register - 2nd LSB
{          08 - A Register - LSB
{
{   PPR contains the APDK registers for the S0.
{
{   DFT:  At a defined interval (currently 30 seconds) DFT writes the contents of the A/P/Q/K registers to a
{   buffer within the DFT/OS buffer.  It holds these values in two separate fields.  Each field is written
{   alternately at the appointed interval so the two most recent samples are available.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$determine_dump_information
*copyc dup$find_record_list_entry
*copyc dup$new_page_procedure
*copyc dup$retrieve_dft_pointers
*copyc osp$append_status_integer
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    c$number_of_s0_pps = 10,
    c$possible_number_of_pps = 60;

  TYPE
    t$a_register = PACKED RECORD
      CASE 0 .. 2 OF
      = 0 =
        register: 0 .. 3ffff(16),
      = 1 =
        ms2: 0 .. 3,
        ls2: 0 ..0ff(16),
        lsb: 0 .. 0ff(16),
      = 2 =
        bit_1: 0 .. 1,
        bit_2: 0 .. 1,
        rest: 0 .. 0ffff(16),
      CASEND,
    RECEND,

    t$apqdk_register = PACKED RECORD
      pp_available: boolean,
      iou_number: 0 .. duc$de_maximum_ious,
      pp_number: 0 .. 0ff(16),
      pp_type: t$pp_type,
      p: t$p_register,
      a: t$a_register,
      q_d: t$q_d_register,
      k: t$k_register,
      post_p: t$p_register,
      post_a: t$a_register,
      post_q_d: t$q_d_register,
      post_k: t$k_register,
    RECEND,

    t$apqdk_register_list = RECORD
      use_q_register: boolean,
      list: ARRAY [1 .. c$possible_number_of_pps] OF t$apqdk_register,
    RECEND,

    t$dec_mac_registers = RECORD
      available: boolean,
      list: ARRAY [1 .. c$number_of_s0_pps] OF t$register,
    RECEND,

    t$k_register = PACKED RECORD
      CASE 0 .. 2 OF
      = 0 =
        register: 0 .. 0ffff(16),
      = 1 =
        msb: 0 .. 0ff(16),
        lsb: 0 .. 0ff(16),
      = 2 =
        bit_1: 0 .. 1,
        zero_1: 0 .. 7,
        rest: 0 .. 03f(16),
        zero_2: 0 .. 3f(16),
      CASEND,
    RECEND,

    t$p_register = RECORD
      CASE boolean OF
      = TRUE =
        register: 0 .. 0ffff(16),
      = FALSE =
        msb: 0 .. 0ff(16),
        lsb: 0 .. 0ff(16),
      CASEND,
    RECEND,

    t$pp_type = (c$nio_0_11, c$nio_20_31, c$cio_0_11),

    t$q_d_register = PACKED RECORD
      CASE 0 .. 2 OF
      = 0 =
        q_register: 0 .. 0ffff(16),
      = 1 =
        d_register: 0 .. 3f(16),
        unused: 0 .. 3f(16),
      = 2 =
        msb: 0 .. 0ff(16),
        lsb: 0 .. 0ff(16),
      CASEND,
    RECEND,

    t$register = PACKED RECORD
      pp_number: 0 .. 0ff(16),
      CASE boolean OF
      = TRUE =
        register_word: ARRAY [1 .. 8] OF 0 .. 0ff(16),
      = FALSE =
        register: PACKED ARRAY [0 .. 63] OF 0 .. 1,
      CASEND,
    RECEND,

    t$register_list = RECORD
      dec: t$dec_mac_registers,
      psr_ppr_idle: t$apqdk_register_list,
      dft_idle: t$apqdk_register_list,
      mac: t$dec_mac_registers,
    RECEND;

?? OLDTITLE ??
?? NEWTITLE := 'build_dft_registers', EJECT ??

{ PURPOSE:
{   This procedure builds the registers from the DFT record.

  PROCEDURE build_dft_registers
    (    use_q_register: boolean;
     VAR dft_data_invalid: boolean;
     VAR register_list: t$register_list);

    TYPE
      t$dft_a_register = PACKED RECORD
        unused: 0 .. 3fff(16),
        register: 0 .. 3ffff(16),
      RECEND,

      t$dft_apqdk = RECORD
        p: t$dft_p_q_d_k_register,
        q_d: t$dft_p_q_d_k_register,
        k: t$dft_p_q_d_k_register,
        a: t$dft_a_register,
        post_p: t$dft_p_q_d_k_register,
        post_q_d: t$dft_p_q_d_k_register,
        post_k: t$dft_p_q_d_k_register,
        post_a: t$dft_a_register,
      RECEND,

      t$dft_p_q_d_k_register = RECORD
        unused: 0 .. 0ffff(16),
        register: 0 .. 0ffff(16),
      RECEND,

      t$offset = RECORD
        rfu: 0 .. 0ffffffff(16),
        offset: 0 .. 0ffffffff(16),
      RECEND;

    VAR
      apqdk_p: ^t$dft_apqdk,
      data_length_valid: boolean,
      data_size: integer,
      data_valid: boolean,
      dft_data: dut$dft_data,
      index: integer,
      iou_number: 0 .. duc$de_maximum_ious,
      offset_p: ^t$offset,
      pp_number: 0 .. 0ff(16),
      pp_type: t$pp_type,
      restart_file_seq_p: ^SEQ ( * );

    dft_data_invalid := TRUE;
    dup$retrieve_dft_pointers (dft_data, data_length_valid, data_valid);
    IF NOT data_valid OR NOT data_length_valid OR
          (dft_data.buffer [dsc$dftb_rpw_pp_reg_save_area].cell_p = NIL) THEN
      RETURN;  {---->
    IFEND;
    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
    RESET restart_file_seq_p TO dft_data.buffer [dsc$dftb_rpw_pp_reg_save_area].cell_p;

    data_size := dft_data.buffer [dsc$dftb_rpw_pp_reg_save_area].size * 8;
    NEXT offset_p IN restart_file_seq_p;
    IF offset_p = NIL THEN
      RETURN;  {---->
    IFEND;
    data_size := data_size - #SIZE (offset_p^);
    register_list.dft_idle.use_q_register := use_q_register;
    iou_number := 0;
    pp_number := 0;
    pp_type := c$nio_0_11;
    index := 1;

    WHILE data_size >= #SIZE (t$dft_apqdk) DO
      NEXT apqdk_p IN restart_file_seq_p;
      IF apqdk_p = NIL THEN
        RETURN;  {---->
      IFEND;
      data_size := data_size - #SIZE (t$dft_apqdk);
      register_list.dft_idle.list [index].pp_available := TRUE;
      register_list.dft_idle.list [index].iou_number := iou_number;
      register_list.dft_idle.list [index].pp_number := pp_number;
      register_list.dft_idle.list [index].pp_type := pp_type;
      register_list.dft_idle.list [index].p.register := apqdk_p^.p.register;
      register_list.dft_idle.list [index].q_d.q_register := apqdk_p^.q_d.register;
      register_list.dft_idle.list [index].a.register := apqdk_p^.a.register;
      register_list.dft_idle.list [index].k.register := apqdk_p^.k.register;
      register_list.dft_idle.list [index].post_p.register := apqdk_p^.post_p.register;
      register_list.dft_idle.list [index].post_q_d.q_register := apqdk_p^.post_q_d.register;
      register_list.dft_idle.list [index].post_a.register := apqdk_p^.post_a.register;
      register_list.dft_idle.list [index].post_k.register := apqdk_p^.post_k.register;
      increment_pp_number (pp_number, pp_type, iou_number);
      index := index + 1;
    WHILEND;
    dft_data_invalid := FALSE;

  PROCEND build_dft_registers;
?? OLDTITLE ??
?? NEWTITLE := 'build_other_registers', EJECT ??

{ PURPOSE:
{   This procedure builds the registers for non S0 mainframes.

  PROCEDURE build_other_registers
    (    entry_p: ^dut$de_other_record_entry;
     VAR register_list: t$register_list);

    TYPE
      t$other_a_register = PACKED RECORD
        unused_1: 0 .. 0f(16),
        unused_2: 0 .. 3f(16),
        ms2: 0 .. 3,
        unused_3: 0 .. 0f(16),
        ls2: 0 .. 0ff(16),
        unused_4: 0 .. 0f(16),
        lsb: 0 .. 0ff(16),
      RECEND,

      t$other_p_q_k_register = PACKED RECORD
        unused_1: 0 .. 0f(16),
        msb: 0 .. 0ff(16),
        unused_2: 0 .. 0f(16),
        lsb: 0 .. 0ff(16),
      RECEND,

      t$other_register = PACKED RECORD
        p: t$other_p_q_k_register,
        q: t$other_p_q_k_register,
        k: t$other_p_q_k_register,
        a: t$other_a_register,
        post_p: t$other_p_q_k_register,
        post_q: t$other_p_q_k_register,
        post_k: t$other_p_q_k_register,
        post_a: t$other_a_register,
      RECEND;

    VAR
      cell_p: ^cell,
      checked_ps1: boolean,
      data_size: integer,
      data_value: clt$data_value,
      index: 1 .. c$possible_number_of_pps,
      iou_number: 0 .. duc$de_maximum_ious,
      pp_number: 0 .. 0ff(16),
      pp_registers_still_exist: boolean,
      pp_type: t$pp_type,
      ps1_entry_p: ^dut$de_other_record_entry,
      restart_file_seq_p: ^SEQ ( * ),
      other_register_p: ^t$other_register;

    iou_number := 0;
    pp_number := 0;
    pp_type := c$nio_0_11;
    register_list.dec.available := FALSE;
    register_list.psr_ppr_idle.use_q_register := TRUE;
    register_list.mac.available := FALSE;
    index := 1;

    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);
    RESET restart_file_seq_p TO cell_p;
    data_size := entry_p^.size;
    checked_ps1 := FALSE;
    pp_registers_still_exist := TRUE;

    WHILE pp_registers_still_exist DO
      NEXT other_register_p IN restart_file_seq_p;
      IF other_register_p = NIL THEN
        RETURN;  {---->
      IFEND;
      data_size := data_size - #SIZE (t$other_register);
      register_list.psr_ppr_idle.list [index].pp_available := TRUE;
      register_list.psr_ppr_idle.list [index].iou_number := iou_number;
      register_list.psr_ppr_idle.list [index].pp_number := pp_number;
      register_list.psr_ppr_idle.list [index].pp_type := pp_type;
      register_list.psr_ppr_idle.list [index].p.msb := other_register_p^ .p.msb;
      register_list.psr_ppr_idle.list [index].p.lsb := other_register_p^ .p.lsb;
      register_list.psr_ppr_idle.list [index].q_d.msb := other_register_p^ .q.msb;
      register_list.psr_ppr_idle.list [index].q_d.lsb := other_register_p^ .q.lsb;
      register_list.psr_ppr_idle.list [index].k.msb := other_register_p^ .k.msb;
      register_list.psr_ppr_idle.list [index].k.lsb := other_register_p^ .k.lsb;
      register_list.psr_ppr_idle.list [index].a.ms2 := other_register_p^ .a.ms2;
      register_list.psr_ppr_idle.list [index].a.ls2 := other_register_p^ .a.ls2;
      register_list.psr_ppr_idle.list [index].a.lsb := other_register_p^ .a.lsb;
      register_list.psr_ppr_idle.list [index].post_p.msb := other_register_p^ .post_p.msb;
      register_list.psr_ppr_idle.list [index].post_p.lsb := other_register_p^ .post_p.lsb;
      register_list.psr_ppr_idle.list [index].post_q_d.msb := other_register_p^ .post_q.msb;
      register_list.psr_ppr_idle.list [index].post_q_d.lsb := other_register_p^ .post_q.lsb;
      register_list.psr_ppr_idle.list [index].post_k.msb := other_register_p^ .post_k.msb;
      register_list.psr_ppr_idle.list [index].post_k.lsb := other_register_p^ .post_k.lsb;
      register_list.psr_ppr_idle.list [index].post_a.ms2 := other_register_p^ .post_a.ms2;
      register_list.psr_ppr_idle.list [index].post_a.ls2 := other_register_p^ .post_a.ls2;
      register_list.psr_ppr_idle.list [index].post_a.lsb := other_register_p^ .post_a.lsb;
      increment_pp_number (pp_number, pp_type, iou_number);
      index := index + 1;
      IF data_size < #SIZE (t$other_register) THEN
        IF checked_ps1 THEN
          pp_registers_still_exist := FALSE;
        ELSE
          checked_ps1 := TRUE;
          data_value.kind := clc$name;
          data_value.name_value := 'PS1';
          dup$find_record_list_entry (data_value, ps1_entry_p);
          IF ps1_entry_p = NIL THEN
            pp_registers_still_exist := FALSE;
          ELSE
            restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
            cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),
                  ps1_entry_p^.first_byte);
            RESET restart_file_seq_p TO cell_p;
            data_size := ps1_entry_p^.size;
            pp_registers_still_exist := (data_size >= #SIZE (t$other_register));
          IFEND;
        IFEND;
      IFEND;
    WHILEND;

  PROCEND build_other_registers;
?? OLDTITLE ??
?? NEWTITLE := 'build_s0_registers', EJECT ??

{ PURPOSE:
{   This procedure builds the register array for the S0.

  PROCEDURE build_s0_registers
    (    entry_p: ^dut$de_other_record_entry;
     VAR register_list: t$register_list);

    TYPE
      t$s0_register = PACKED RECORD
        unused: 0 .. 0ff(16),
        subsystem_id: 0 .. 0f(16),
        subsystem_number: 0 .. 0f(16),
        register_type: 0 .. 0ff(16),
        number: 0 .. 0ff(16),
        CASE 0 .. 2 OF
        = 0 =
          register: PACKED ARRAY [0 .. 63] OF 0 .. 1,
        = 1 =
          unused_1: 0 .. 3ff(16),
          d: 0 .. 3f(16),
          unused_2: 0 .. 1,
          k_bit_1: 0 .. 1,
          k_rest: 0 .. 3f(16),
          a_bit_1: 0 .. 1,
          a_bit_2: 0 .. 1,
          unused_3: 0 .. 1,
          micrand_step_address: 0 .. 1f(16),
          unused_4: 0 .. 0ffffffff(16),
        = 2 =
          p: 0 .. 0ffff(16),
          a_rest: 0 .. 0ffff(16),
          unused_5: 0 .. 0ffffffff(16),
        CASEND,
      RECEND;

    VAR
     cell_p: ^cell,
      index: 1 .. c$number_of_s0_pps,
      iou_number: 0 .. duc$de_maximum_ious,
      pp_number: 0 .. 0ff(16),
      pp_type: t$pp_type,
      restart_file_seq_p: ^SEQ ( * ),
      s0_register_p: ^t$s0_register,
      two_s0_registers_p: ^ARRAY [1 .. 2] OF t$s0_register;

    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);
    RESET restart_file_seq_p TO cell_p;

    { Save the DEC registers.

    pp_number := 0;
    FOR index := 1 TO c$number_of_s0_pps DO
      NEXT s0_register_p IN restart_file_seq_p;
      IF s0_register_p = NIL THEN
        RETURN;  {---->
      IFEND;
      register_list.dec.list [index].pp_number := pp_number;
      register_list.dec.list [index].register := s0_register_p^.register;
      pp_number := pp_number + 1;
      IF pp_number = 5(8) THEN
        pp_number := 20(8);
      IFEND;
    FOREND;
    register_list.dec.available := TRUE;

    { Save the PRE A/P/D/K registers.

    iou_number := 0;
    pp_number := 0;
    pp_type := c$nio_0_11;
    register_list.psr_ppr_idle.use_q_register := FALSE;
    FOR index := 1 TO c$number_of_s0_pps DO
      NEXT two_s0_registers_p IN restart_file_seq_p;
      IF two_s0_registers_p = NIL THEN
        RETURN;  {---->
      IFEND;
      register_list.psr_ppr_idle.list [index].pp_available := TRUE;
      register_list.psr_ppr_idle.list [index].iou_number := iou_number;
      register_list.psr_ppr_idle.list [index].pp_number := pp_number;
      register_list.psr_ppr_idle.list [index].pp_type := pp_type;
      register_list.psr_ppr_idle.list [index].p.register := two_s0_registers_p^ [2].p;
      register_list.psr_ppr_idle.list [index].a.bit_1 := two_s0_registers_p^ [1].a_bit_1;
      register_list.psr_ppr_idle.list [index].a.bit_2 := two_s0_registers_p^ [1].a_bit_2;
      register_list.psr_ppr_idle.list [index].a.rest := two_s0_registers_p^ [2].a_rest;
      register_list.psr_ppr_idle.list [index].q_d.d_register := two_s0_registers_p^ [1].d;
      register_list.psr_ppr_idle.list [index].k.bit_1 := two_s0_registers_p^ [1].k_bit_1;
      register_list.psr_ppr_idle.list [index].k.zero_1 := 0;
      register_list.psr_ppr_idle.list [index].k.rest := two_s0_registers_p^ [1].k_rest;
      register_list.psr_ppr_idle.list [index].k.zero_2 := 0;
      pp_number := pp_number + 1;
      IF pp_number = 5(8) THEN
        pp_number := 20(8);
        pp_type := c$nio_20_31;
      IFEND;
    FOREND;

    { Save the POST A/P/D/K registers.

    FOR index := 1 TO c$number_of_s0_pps DO
      NEXT two_s0_registers_p IN restart_file_seq_p;
      IF two_s0_registers_p = NIL THEN
        RETURN;  {---->
      IFEND;
      register_list.psr_ppr_idle.list [index].p.register := two_s0_registers_p^ [2].p;
      register_list.psr_ppr_idle.list [index].post_a.bit_1 := two_s0_registers_p^ [1].a_bit_1;
      register_list.psr_ppr_idle.list [index].post_a.bit_2 := two_s0_registers_p^ [1].a_bit_2;
      register_list.psr_ppr_idle.list [index].post_a.rest := two_s0_registers_p^ [2].a_rest;
      register_list.psr_ppr_idle.list [index].post_q_d.d_register := two_s0_registers_p^ [1].d;
      register_list.psr_ppr_idle.list [index].post_k.bit_1 := two_s0_registers_p^ [1].k_bit_1;
      register_list.psr_ppr_idle.list [index].post_k.zero_1 := 0;
      register_list.psr_ppr_idle.list [index].post_k.rest := two_s0_registers_p^ [1].k_rest;
      register_list.psr_ppr_idle.list [index].post_k.zero_2 := 0;
    FOREND;

    { Save the MAC registers.

    NEXT s0_register_p IN restart_file_seq_p;
    IF s0_register_p = NIL THEN
      RETURN;  {---->
    IFEND;
    register_list.mac.list [1].pp_number := 20(8);
    register_list.mac.list [1].register := s0_register_p^.register;
    NEXT s0_register_p IN restart_file_seq_p;
    IF s0_register_p = NIL THEN
      RETURN;  {---->
    IFEND;
    register_list.mac.list [2].pp_number := 21(8);
    register_list.mac.list [2].register := s0_register_p^.register;
    register_list.mac.available := TRUE;

  PROCEND build_s0_registers;
?? OLDTITLE ??
?? NEWTITLE := 'display_data', EJECT ??

{ PURPOSE:
{   This procedure displays the data.

  PROCEDURE display_data
    (    dft_data_invalid: boolean;
         register_list: t$register_list;
     VAR display_control: clt$display_control);

    TYPE
      t$apqdk_data_line = RECORD
        CASE boolean OF
        = TRUE =
          line: string (70),
        = FALSE =
          space_1: string (1),
          iou_string: string (3),
          iou_number: string (2),
          space_2: string (2),
          cio_id: string (1),
          pp_string: string (2),
          pp_number: string (2),
          space_3: string (2),
          message: string (15),
          space_4: string (2),
          p: string (6),
          space_5: string (2),
          a: string (6),
          space_6: string (2),
          q_d: string (6),
          space_7: string (2),
          k: string (6),
        CASEND,
      RECEND,

      t$dec_data_line = RECORD
        CASE boolean OF
        = TRUE =
          line: string (60),
        = FALSE =
          space_1: string (1),
          pp_string: string (2),
          pp_number: string (2),
          space_2: string (2),
          register: ARRAY [1 .. 8] OF string (2),
        CASEND,
      RECEND;

    VAR
      apqdk_data_line: t$apqdk_data_line,
      dec_data_line: t$dec_data_line,
      dft_pp_found: boolean,
      dft_pp_entry: 1 .. c$possible_number_of_pps,
      dump_information: dut$dump_information,
      ignore_status: ost$status,
      index: 1 .. c$possible_number_of_pps,
      index_2: 1 .. 8,
      index_3: 1 .. c$possible_number_of_pps,
      iou_number: 0 .. duc$de_maximum_ious;

    dup$determine_dump_information (dump_information);

    IF register_list.psr_ppr_idle.use_q_register THEN
      clp$put_display (display_control, 'A/P/Q/K Register History', clc$trim, ignore_status);
    ELSE
      clp$put_display (display_control, 'A/P/D/K Register History', clc$trim, ignore_status);
    IFEND;
    apqdk_data_line.line := ' ';
    apqdk_data_line.p := '   P  ';
    apqdk_data_line.a := '   A  ';
    IF register_list.psr_ppr_idle.use_q_register THEN
      apqdk_data_line.q_d := '   Q  ';
    ELSE
      apqdk_data_line.q_d := '   D  ';
    IFEND;
    apqdk_data_line.k := '   K  ';
    clp$put_display (display_control, apqdk_data_line.line, clc$trim, ignore_status);
    apqdk_data_line.line := ' ';
    apqdk_data_line.p := '------';
    apqdk_data_line.a := '------';
    apqdk_data_line.q_d := '------';
    apqdk_data_line.k := '------';
    clp$put_display (display_control, apqdk_data_line.line, clc$trim, ignore_status);

   /display_apqdk_loop/
    FOR index := 1 TO c$possible_number_of_pps DO
      IF NOT register_list.psr_ppr_idle.list [index].pp_available THEN
        EXIT /display_apqdk_loop/;  {---->
      IFEND;

      iou_number := register_list.psr_ppr_idle.list [index].iou_number;
      IF register_list.psr_ppr_idle.list [index].pp_type = c$cio_0_11 THEN
        CASE dump_information.iou [iou_number].model OF
        = duc$di_im_i1_1x, duc$di_im_i2_20, duc$di_im_i4_43, duc$di_im_i4_44, duc$di_im_i4_46 =
          CYCLE /display_apqdk_loop/;  {---->
        ELSE
        CASEND;
      IFEND;

      apqdk_data_line.line := ' ';
      apqdk_data_line.iou_string := 'IOU';
      clp$convert_integer_to_rjstring (iou_number, 8, FALSE, '0', apqdk_data_line.iou_number, ignore_status);
      IF (register_list.psr_ppr_idle.list [index].pp_type = c$cio_0_11) OR
            (dump_information.iou [iou_number].model = duc$di_im_i4_43) OR
            (dump_information.iou [iou_number].model = duc$di_im_i4_44) OR
            (dump_information.iou [iou_number].model = duc$di_im_i4_46) THEN
        apqdk_data_line.cio_id := 'C';
      IFEND;
      apqdk_data_line.pp_string := 'PP';
      clp$convert_integer_to_rjstring (register_list.psr_ppr_idle.list [index].pp_number, 8, FALSE, '0',
            apqdk_data_line.pp_number, ignore_status);
      IF register_list.psr_ppr_idle.use_q_register THEN
        apqdk_data_line.message := 'PSR:  pre-idle';
      ELSE
        apqdk_data_line.message := 'PPR:  pre-idle';
      IFEND;
      clp$convert_integer_to_rjstring (register_list.psr_ppr_idle.list [index].p.register, 8,
            FALSE, ' ', apqdk_data_line.p, ignore_status);
      clp$convert_integer_to_rjstring (register_list.psr_ppr_idle.list [index].a.register, 8,
            FALSE, ' ', apqdk_data_line.a, ignore_status);
      IF register_list.psr_ppr_idle.use_q_register THEN
        clp$convert_integer_to_rjstring (register_list.psr_ppr_idle.list [index].q_d.q_register, 8,
              FALSE, ' ', apqdk_data_line.q_d, ignore_status);
      ELSE
        clp$convert_integer_to_rjstring (register_list.psr_ppr_idle.list [index].q_d.d_register, 8,
              FALSE, ' ', apqdk_data_line.q_d, ignore_status);
      IFEND;
      clp$convert_integer_to_rjstring (register_list.psr_ppr_idle.list [index].k.register, 8,
            FALSE, ' ', apqdk_data_line.k, ignore_status);
      clp$put_display (display_control, apqdk_data_line.line, clc$trim, ignore_status);

      apqdk_data_line.line := ' ';
      IF register_list.psr_ppr_idle.use_q_register THEN
        apqdk_data_line.message := 'PSR:  post-idle';
      ELSE
        apqdk_data_line.message := 'PPR:  post-idle';
      IFEND;
      clp$convert_integer_to_rjstring (register_list.psr_ppr_idle.list [index].post_p.register, 8,
            FALSE, ' ', apqdk_data_line.p, ignore_status);
      clp$convert_integer_to_rjstring (register_list.psr_ppr_idle.list [index].post_a.register, 8,
            FALSE, ' ', apqdk_data_line.a, ignore_status);
      IF register_list.psr_ppr_idle.use_q_register THEN
        clp$convert_integer_to_rjstring (register_list.psr_ppr_idle.list [index].post_q_d.q_register, 8,
              FALSE, ' ', apqdk_data_line.q_d, ignore_status);
      ELSE
        clp$convert_integer_to_rjstring (register_list.psr_ppr_idle.list [index].post_q_d.d_register, 8,
              FALSE, ' ', apqdk_data_line.q_d, ignore_status);
      IFEND;
      clp$convert_integer_to_rjstring (register_list.psr_ppr_idle.list [index].post_k.register, 8,
            FALSE, ' ', apqdk_data_line.k, ignore_status);
      clp$put_display (display_control, apqdk_data_line.line, clc$trim, ignore_status);

      IF dump_information.dump_type = duc$di_dt_cy2000 THEN
        clp$put_display (display_control, ' ', clc$trim, ignore_status);
        CYCLE /display_apqdk_loop/;  {---->
      IFEND;

      IF NOT dft_data_invalid THEN
        dft_pp_found := FALSE;

       /find_dft_pp_entry/
        FOR index_3 := 1 TO c$possible_number_of_pps DO
          IF (iou_number = register_list.dft_idle.list [index_3].iou_number) AND
                (register_list.psr_ppr_idle.list [index].pp_number =
                register_list.dft_idle.list [index_3].pp_number) AND
                (register_list.psr_ppr_idle.list [index].pp_type =
                register_list.dft_idle.list [index_3].pp_type) THEN
            dft_pp_found := TRUE;
            dft_pp_entry := index_3;
            EXIT /find_dft_pp_entry/;  {---->
          IFEND;
        FOREND /find_dft_pp_entry/;
      IFEND;

      IF dft_data_invalid OR NOT dft_pp_found THEN
        apqdk_data_line.line := ' ';
        apqdk_data_line.message := 'DFT:  buffer 1';
        apqdk_data_line.p := '******';
        apqdk_data_line.a := '******';
        apqdk_data_line.q_d := '******';
        apqdk_data_line.k := '******';
        clp$put_display (display_control, apqdk_data_line.line, clc$trim, ignore_status);
        apqdk_data_line.message := 'DFT:  buffer 2';
        clp$put_display (display_control, apqdk_data_line.line, clc$trim, ignore_status);
      ELSE
        apqdk_data_line.line := ' ';
        apqdk_data_line.message := 'DFT:  buffer 1';
        clp$convert_integer_to_rjstring (register_list.dft_idle.list [dft_pp_entry].p.register, 8,
              FALSE, ' ', apqdk_data_line.p, ignore_status);
        clp$convert_integer_to_rjstring (register_list.dft_idle.list [dft_pp_entry].a.register, 8,
              FALSE, ' ', apqdk_data_line.a, ignore_status);
        IF register_list.psr_ppr_idle.use_q_register THEN
          clp$convert_integer_to_rjstring (register_list.dft_idle.list [dft_pp_entry].q_d.q_register, 8,
                FALSE, ' ', apqdk_data_line.q_d, ignore_status);
        ELSE
          clp$convert_integer_to_rjstring (register_list.dft_idle.list [dft_pp_entry].q_d.d_register, 8,
                FALSE, ' ', apqdk_data_line.q_d, ignore_status);
        IFEND;
        clp$convert_integer_to_rjstring (register_list.dft_idle.list [dft_pp_entry].k.register, 8,
              FALSE, ' ', apqdk_data_line.k, ignore_status);
        clp$put_display (display_control, apqdk_data_line.line, clc$trim, ignore_status);
        apqdk_data_line.line := ' ';
        apqdk_data_line.message := 'DFT:  buffer 2';
        clp$convert_integer_to_rjstring (register_list.dft_idle.list [dft_pp_entry].post_p.register, 8,
              FALSE, ' ', apqdk_data_line.p, ignore_status);
        clp$convert_integer_to_rjstring (register_list.dft_idle.list [dft_pp_entry].post_a.register, 8,
              FALSE, ' ', apqdk_data_line.a, ignore_status);
        IF register_list.psr_ppr_idle.use_q_register THEN
          clp$convert_integer_to_rjstring (register_list.dft_idle.list [dft_pp_entry].post_q_d.q_register, 8,
                FALSE, ' ', apqdk_data_line.q_d, ignore_status);
        ELSE
          clp$convert_integer_to_rjstring (register_list.dft_idle.list [dft_pp_entry].post_q_d.d_register, 8,
                FALSE, ' ', apqdk_data_line.q_d, ignore_status);
        IFEND;
        clp$convert_integer_to_rjstring (register_list.dft_idle.list [dft_pp_entry].post_k.register, 8,
              FALSE, ' ', apqdk_data_line.k, ignore_status);
        clp$put_display (display_control, apqdk_data_line.line, clc$trim, ignore_status);
      IFEND;

      clp$put_display (display_control, ' ', clc$trim, ignore_status);
    FOREND /display_apqdk_loop/;

    IF register_list.dec.available THEN
      clp$put_display (display_control, ' ', clc$trim, ignore_status);
      clp$put_display (display_control, 'DEC Registers:', clc$trim, ignore_status);
      clp$put_display (display_control, ' ', clc$trim, ignore_status);

      FOR index := 1 TO c$number_of_s0_pps DO
        dec_data_line.line := ' ';
        dec_data_line.pp_string := 'PP';
        clp$convert_integer_to_rjstring (register_list.dec.list [index].pp_number, 8, FALSE, '0',
              dec_data_line.pp_number, ignore_status);
        FOR index_2 := 1 TO 8 DO
          clp$convert_integer_to_rjstring (register_list.dec.list [index].register_word [index_2],
                16, FALSE, '0', dec_data_line.register [index_2], ignore_status);
        FOREND;
        clp$put_display (display_control, dec_data_line.line, clc$trim, ignore_status);
        clp$put_display (display_control, ' ', clc$trim, ignore_status);
      FOREND;
    IFEND;

    IF register_list.mac.available THEN
      clp$put_display (display_control, ' ', clc$trim, ignore_status);
      clp$put_display (display_control, 'MAC Registers:', clc$trim, ignore_status);
      clp$put_display (display_control, ' ', clc$trim, ignore_status);

      FOR index := 1 TO 2 DO
        dec_data_line.line := ' ';
        clp$convert_integer_to_rjstring (register_list.mac.list [index].pp_number, 8, FALSE, '0',
              dec_data_line.pp_number, ignore_status);
        FOR index_2 := 1 TO 8 DO
          clp$convert_integer_to_rjstring (register_list.mac.list [index].register_word [index_2],
                16, FALSE, '0', dec_data_line.register [index_2], ignore_status);
        FOREND;
        clp$put_display (display_control, dec_data_line.line, clc$trim, ignore_status);
        clp$put_display (display_control, ' ', clc$trim, ignore_status);
      FOREND;
    IFEND;

  PROCEND display_data;
?? OLDTITLE ??
?? NEWTITLE := 'increment_pp_number', EJECT ??

{ PURPOSE:
{   This procedure increments the pp number, iou number and pp type.

  PROCEDURE increment_pp_number
    (VAR pp_number: 0 .. 0ff(16);
     VAR pp_type: t$pp_type;
     VAR iou_number: 0 .. duc$de_maximum_ious);

    IF pp_number = 11(8) THEN
      IF pp_type = c$nio_0_11 THEN
        pp_number := 20(8);
        pp_type := c$nio_20_31;
      ELSE  { pp_type = c$cio_0_11
        iou_number := 1;
        pp_number := 0;
        pp_type := c$nio_0_11;
      IFEND;
    ELSEIF pp_number = 31(8) THEN
      pp_number := 0;
      pp_type := c$cio_0_11;
    ELSE
      pp_number := pp_number + 1;
    IFEND;

  PROCEND increment_pp_number;
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_pp_regs_command', EJECT ??

{ PURPOSE:
{   This procedure displays the pp registers.

  PROCEDURE [XDCL] dup$display_pp_regs_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_pp_registers, dispr (
{   output, o: file = $optional
{   title, t: string 1..31 = 'display_pp_registers'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (22),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 4, 18, 9, 1, 31, 218],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TITLE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 22],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_pp_registers'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$title = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      data_value: clt$data_value,
      dft_data_invalid: boolean,
      display_control: clt$display_control,
      entry_p: ^dut$de_other_record_entry,
      ignore_status: ost$status,
      index: 1 .. c$possible_number_of_pps,
      output_display_opened: boolean,
      register_list: t$register_list,
      ring_attributes: amt$ring_attributes;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

    { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      register_list.dec.available := FALSE;
      register_list.mac.available := FALSE;
      FOR index := 1 TO c$possible_number_of_pps DO
        register_list.psr_ppr_idle.list [index].pp_available := FALSE;
        register_list.dft_idle.list [index].pp_available := FALSE;
      FOREND;

      data_value.kind := clc$name;
      data_value.name_value := 'PPR';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p <> NIL THEN
        build_s0_registers (entry_p, register_list);
        build_dft_registers (FALSE, dft_data_invalid, register_list);
      ELSE
        data_value.kind := clc$name;
        data_value.name_value := 'PSR';
        dup$find_record_list_entry (data_value, entry_p);
        IF entry_p <> NIL THEN
          build_other_registers (entry_p, register_list);
          build_dft_registers (TRUE, dft_data_invalid, register_list);
        ELSE
          osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The specified record is',
                status);
          EXIT /display_opened/;  {---->
        IFEND;
      IFEND;

      display_data (dft_data_invalid, register_list, display_control);

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_pp_regs_command;
MODEND dum$display_pp_regs_command;
*DECK DECK=DUM$DISPLAY_PP_TABLE EXPAND=TRUE
*DECK DECK=DUM$DISPLAY_PRESERVED_FAMILIES EXPAND=TRUE
PROCEDURE dum$display_preserved_families, display_preserved_families, dispf (
  address, a: integer = $required
  output, o: file = $output
  status)

" This procedure displays the preserved family table.  The preserved family
" table resides in the file $SYSTEM.DFF$PRESERVED_FAMILY_TABLE.  If need be the
" file may be opened with:
"   chafa $SYSTEM.DFF$PRESERVED_FAMILY_TABLE ra=(11 11 11)
"   anas
"     a = $file_pva($SYSTEM.DFF$PRESERVED_FAMILY_TABLE)
"    dum$display_preserved_families a
"
  current = $default_module
  chadm dfm$preserved_family_manager
  dispv ?address.dft$preserved_family_header o=output
  number_of_families = $pv(?address.dft$preserved_family_header.number_of_families)
  header_length = $pv(#size(0.dft$preserved_family_header))
  entry_length =  $pv(#size(0.dft$served_family_table_entry))
  entry = address + header_length
  FOR family = 1 TO number_of_families DO
    disv ' ---- Preserved Family '//family o=output.$eoi
    dispv ?entry.dft$served_family_table_entry o=output.$eoi
    entry = entry + entry_length
  FOREND
  chadm current

PROCEND dum$display_preserved_families
*DECK DECK=DUM$DISPLAY_PRIMARY_TASK_LIST EXPAND=TRUE


 PROC dum$display_primary_task_list, display_primary_task_list, display_ptl, disptl (
   ptl_ordinal, ptlo: integer 0 .. 4095 OR KEY all, a = all
   output, o: file = output
   help: boolean = FALSE
   status)

   IF $value(help) THEN
     put_line '0PROC display_ptl, disptl (                                   ' o=$output
     put_line '   ptl_ordinal, ptlo: integer 0 .. 4095 OR KEY all, a = all   ' o=$output
     put_line '   output, o: file = $OUTPUT                                  ' o=$output
     put_line '   help: boolean = FALSE                                      ' o=$output
     put_line '   status)                                                    ' o=$output
     put_line '0This procedure is used during an Analyze_Dump session as a   ' o=$output
     put_line ' means of producing the contents of the Primary_Task_List.  It' o=$output
     put_line ' produces the entire PTL (by default), or it can produce a    ' o=$output
     put_line ' specific PTL entry.                                          ' o=$output
     put_line '                                                              ' o=$output
     EXIT_PROC
  IFEND

   crev tmt$task_status k=string d=0..14
   tmt$task_status(0) = 'TMC$TS_NULL'
   tmt$task_status(1) = 'TMC$TS_READY (= TMC$TS_LAST_STATUS_IN_DCT)'
   tmt$task_status(2) = 'TMC$TS_TIMEOUT_REQEXP_SHORTSHRT (= TMC$TS_FIRST_STATUS_IN_WAIT_Q)'
   tmt$task_status(3) = 'TMC$TS_TIMEOUT_REQEXP_LONGLONG'
   tmt$task_status(4) = 'TMC$TS_TIMEOUT_REQEXP_LONGVLONG (= TMC$TS_LAST_STATUS_IN_WAIT_Q)'
   tmt$task_status(5) = 'TMC$TS_EXECUTING'
   tmt$task_status(6) = 'TMC$TS_TIMEOUT_REQEXP_INFLONG'
   tmt$task_status(7) = 'TMC$TS_TIMEOUT_REQEXP_INFVLONG'
   tmt$task_status(8) = 'TMC$TS_READY_BUT_SWAPPED'
   tmt$task_status(9) = 'TMC$TS_IO_WAIT_NOT_QUEUED (= TMC$TS_FIRST_READY_UNCOND)'
   tmt$task_status(10) = 'TMC$TS_PAGE_WAIT (= TMC$TS_FIRST_EXTERNAL_QUEUE)'
   tmt$task_status(11) = 'TMC$TS_MEMORY_WAIT'
   tmt$task_status(12) = 'TMC$TS_SEGMENT_LOCK_WAIT'
   tmt$task_status(13) = 'TMC$TS_JOB_EVENT_QUEUE'
   tmt$task_status(14) = 'TMC$TS_IO_WAIT_QUEUED'
   crev tmt$idle_status k=string d=0..3
   tmt$idle_status(0) = 'TMC$IS_NOT_IDLED'
   tmt$idle_status(1) = 'TMC$IS_IDLE_INITIATED'
   tmt$idle_status(2) = 'TMC$IS_IDLED'
   tmt$idle_status(3) = 'TMC$IS_IDLED_SCHED_NOTIFIED'
   crev syt$monitor_flag k=string d=0..15
   syt$monitor_flag(0) = 'TMC$MF_CAUSE_JOB_FREE_FLAG_TRAP'
   syt$monitor_flag(1) = 'MMC$MF_SEGMENT_MGR_FLAG'
   syt$monitor_flag(2) = 'DMC$MF_GLOBAL_SFT_FLAG'
   syt$monitor_flag(3) = 'DMC$MF_LOCAL_SFT_FLAG'
   syt$monitor_flag(4) = 'SYC$MF_SYSTEM_DEBUGGER'
   syt$monitor_flag(5) = 'SYC$MF_INVOKE_SYSDEBUG'
   syt$monitor_flag(6) = 'SYC$MF_HANG_TASK'
   syt$monitor_flag(7) = 'SYC$MF_DUMP_JOB_ENVIRONMENT'
   syt$monitor_flag(8) = 'SYC$MF_CAUSE_JOB_RECOVERY'
   syt$monitor_flag(9) = 'UNDEFINED_9'
   syt$monitor_flag(10) = 'UNDEFINED_10'
   syt$monitor_flag(11) = 'UNDEFINED_11'
   syt$monitor_flag(12) = 'UNDEFINED_12'
   syt$monitor_flag(13) = 'UNDEFINED_13'
   syt$monitor_flag(14) = 'UNDEFINED_14'
   syt$monitor_flag(15) = 'UNDEFINED_15'
   crev syt$system_flag k=string d=0..31
   syt$system_flag(0) = 'UNDEFINED_0'
   syt$system_flag(1) = 'AVC$MONITOR_STATISTICS_FLAG'
   syt$system_flag(2) = 'PMC$SF_TERMINATE_TASK'
   syt$system_flag(3) = 'JMC$DROP_JOB_FLAG_ID'
   syt$system_flag(4) = 'TMC$MAINFRAME_LINKED_SIGNALS'
   syt$system_flag(5) = 'JMC$LOGOUT_FLAG_ID'
   syt$system_flag(6) = 'JMC$JOB_TIME_LIMIT_FLAG_ID'
   syt$system_flag(7) = 'DSC$RETRIEVE_SYSTEM_MESSAGE'
   syt$system_flag(8) = 'NAC$CHANNELNET_INPUT_RECEIVED'
   syt$system_flag(9) = 'NLC$XT_WORK_LIST_FLAG'
   syt$system_flag(10) = 'NAC$XI_LOCAL_EVENT'
   syt$system_flag(11) = 'NAC$CHANNELNET_LOCAL_EVENT'
   syt$system_flag(12) = 'NAC$NOTIFY_ROUTING_ME'
   syt$system_flag(13) = 'SYC$JOB_RECOVERY_FLAG'
   syt$system_flag(14) = 'IOC$SUBSYSTEM_IO_COMPLETED'
   syt$system_flag(15) = 'DSC$LOG_DFT_FLAG_ID'
   syt$system_flag(16) = 'OFC$OPERATOR_BREAK_FLAG'
   syt$system_flag(17) = 'OSC$SYSTEM_UNSTEP_RESUME_FLAG'
   syt$system_flag(18) = 'NAC$CHANNELNET_OUTPUT_COMPLETE'
   syt$system_flag(19) = 'NAC$ASSIGN_CONN_TO_AM_TASK'
   syt$system_flag(20) = 'MMC$FAILED_FILE_ALLOC_FLAG'
   syt$system_flag(21) = 'UNDEFINED_21'
   syt$system_flag(22) = 'UNDEFINED_22'
   syt$system_flag(23) = 'UNDEFINED_23'
   syt$system_flag(24) = 'UNDEFINED_24'
   syt$system_flag(25) = 'UNDEFINED_25'
   syt$system_flag(26) = 'UNDEFINED_26'
   syt$system_flag(27) = 'UNDEFINED_27'
   syt$system_flag(28) = 'UNDEFINED_28'
   syt$system_flag(29) = 'UNDEFINED_29'
   syt$system_flag(30) = 'UNDEFINED_30'
   syt$system_flag(31) = 'UNDEFINED_31'

   ptl_base = $mem($sa(tmv$ptl_p))      " Beginning of PTL"
   ptl_entry = ptl_base + 20(16)        " First real entry"
   IF $file($value(output) open_position) = '$EOI' THEN
     output_file = $string($value(output))
   ELSE
     output_file = $string($value(output))//'.$eoi'
   IFEND

   IF $value_kind(ptl_ordinal) = 'NAME' THEN
     line = ' PTL ENTRY: PTL_0'
     putl line o=$fname(output_file)

     WHILE ($mem(ptl_entry+3 1) > 0) DO
       IF $mem(ptl_entry+17(16) 1) <> 0 THEN
         line = '0PTL ENTRY: TASK_'//$strrep(((ptl_entry-ptl_base)/20(16)) 16)//'(16)'
         putl line o=$fname(output_file)
         put_line ' Task '//$strrep(((ptl_entry-ptl_base)/20(16)) 16)//'(16):' o=$fname(output_file)
         val = $mem(ptl_entry+0 2)
         line = '0  ptl_thread = '//$strrep(val 16)//'(16)'
         put_line line o=$fname(output_file)
         val = $mem(ptl_entry+2 1)
         line = '   index = '//$strrep(val 16)//'(16)'
         val = $mem(ptl_entry+3 1)
         line = line//', sequence_number = '//$strrep(val 16)//'(16)'
         put_line line o=$fname(output_file)
         val = $mem(ptl_entry+4 4)
         line = '   xcb_offset = '//$strrep(val 16)//'(16)'
         put_line line o=$fname(output_file)
         val = $mem(ptl_entry+8 2)
         line = '   ijl_ordinal = '//$strrep(val 16)//'(16):'
         put_line line o=$fname(output_file)
         line = '     block_number = '//$strrep((val/32) 16)//'(16)'
         line = line//', block_index = '//$strrep($mod(val 2048) 16)//'(16)'
         put_line line o=$fname(output_file)
         val = $mem(ptl_entry+0a(16) 1)
         IF (val < 0) OR (val > 14) THEN
           line = '   status = --> RANGE ERROR <--'
         ELSE
           line = '   status = '//tmt$task_status(val)
         IFEND
         put_line line o=$fname(output_file)
         val = $mem(ptl_entry+0b(16) 1)
         IF (val < 0) OR (val > 14) THEN
           line = '   new_task_status = --> RANGE ERROR <--'
         ELSE
           line = '   new_task_status = '//tmt$task_status(val)
         IFEND
         put_line line o=$fname(output_file)
         val = $mem(ptl_entry+0c(16) 1)
         IF (val < 0) OR (val > 3) THEN
           line = '   idle_status = --> RANGE ERROR <--'
         ELSE
           line = '   idle_status = '//tmt$idle_status(val)
         IFEND
         put_line line o=$fname(output_file)
         val = $mem(ptl_entry+0d(16) 2)
         line = '   queue_link (GTID): index = '//$strrep(val 16)//'(16)'
         val = $mem(ptl_entry+0f(16) 1)
         line = line//', sequence_number = '//$strrep(val 16)//'(16)'
         put_line line o=$fname(output_file)
         val = $mem(ptl_entry+10(16) 1)
         line = '   wait_inhibited = '//$strrep(val<>0)
         put_line line o=$fname(output_file)
         val = $mem(ptl_entry+11(16) 2)
         line = '   monitor_flags = { }'
         put_line line o=$fname(output_file)
         FOR i=0 TO 15 DO
           IF $bit(val 48+i) THEN
             line = '                    '//syt$monitor_flag(i)
             put_line line o=$fname(output_file)
           IFEND
         FOREND
         val = $mem(ptl_entry+13(16) 2)
         line = '   system_flags = { }'
         put_line line o=$fname(output_file)
         FOR i=0 TO 31 DO
           IF $bit(val 32+i) THEN
             line = '                   '//syt$system_flag(i)
             put_line line o=$fname(output_file)
           IFEND
         FOREND
         val = $mem(ptl_entry+17(16) 1)
         line = '   dispatching_priority = '//$strrep(val 16)//'(16)'
         put_line line o=$fname(output_file)
         next_task = $mem(ptl_entry+18(16) 2)
         line = '   ijl_thread (ordinal of next task) = '//$strrep(next_task 16)//'(16)'
         put_line line o=$fname(output_file)
         val = $mem(ptl_entry+1A(16) 6)
         line = '   end_of_wait_time = '//$strrep(val 16)//'(16)'
         put_line line o=$fname(output_file)
       ELSE
         line = '0PTL ENTRY: TASK_'//$strrep(((ptl_entry-ptl_base)/20(16)) 16)//'(16)'
         putl line o=$fname(output_file)
         putl ' This task is undefined/unused.' o=$fname(output_file)
       IFEND
       ptl_entry = ptl_entry + 20(16)

     WHILEND

   ELSE

     ptl_entry = ptl_base + ($value(ptl_ordinal) * 20(16))
     IF ($mem(ptl_entry+3 1) = 0) AND ($mem(ptl_entry+17(16) 1) = 0) THEN
       line = ' PTL ENTRY: TASK_'//$strrep(((ptl_entry-ptl_base)/20(16)) 16)//'(16)'
       putl line o=$fname(output_file)
       putl '0This task is undefined/unused.' o=$fname(output_file)
       EXIT_PROC
     IFEND

     line = ' PTL ENTRY: TASK_'//$strrep(((ptl_entry-ptl_base)/20(16)) 16)//'(16)'
     putl line o=$fname(output_file)
     put_line '0Task '//$strrep(((ptl_entry-ptl_base)/20(16)) 16)//'(16):' o=$fname(output_file)
     val = $mem(ptl_entry+0 2)
     line = '0  ptl_thread = '//$strrep(val 16)//'(16)'
     put_line line o=$fname(output_file)
     val = $mem(ptl_entry+2 1)
     line = '   index = '//$strrep(val 16)//'(16)'
     val = $mem(ptl_entry+3 1)
     line = line//', sequence_number = '//$strrep(val 16)//'(16)'
     put_line line o=$fname(output_file)
     val = $mem(ptl_entry+4 4)
     line = '   xcb_offset = '//$strrep(val 16)//'(16)'
     put_line line o=$fname(output_file)
     val = $mem(ptl_entry+8 2)
     line = '   ijl_ordinal = '//$strrep(val 16)//'(16):'
     put_line line o=$fname(output_file)
     line = '     block_number = '//$strrep((val/32) 16)//'(16)'
     line = line//', block_index = '//$strrep($mod(val 2048) 16)//'(16)'
     put_line line o=$fname(output_file)
     val = $mem(ptl_entry+0a(16) 1)
     IF (val < 0) OR (val > 14) THEN
       line = '   status = --> RANGE ERROR <--'
     ELSE
       line = '   status = '//tmt$task_status(val)
     IFEND
     put_line line o=$fname(output_file)
     val = $mem(ptl_entry+0b(16) 1)
     IF (val < 0) OR (val > 14) THEN
       line = '   new_task_status = --> RANGE ERROR <--'
     ELSE
       line = '   new_task_status = '//tmt$task_status(val)
     IFEND
     put_line line o=$fname(output_file)
     val = $mem(ptl_entry+0c(16) 1)
     IF (val < 0) OR (val > 3) THEN
       line = '   idle_status = --> RANGE ERROR <--'
     ELSE
       line = '   idle_status = '//tmt$idle_status(val)
     IFEND
     put_line line o=$fname(output_file)
     val = $mem(ptl_entry+0d(16) 2)
     line = '   queue_link (GTID): index = '//$strrep(val 16)//'(16)'
     val = $mem(ptl_entry+0f(16) 1)
     line = line//', sequence_number = '//$strrep(val 16)//'(16)'
     put_line line o=$fname(output_file)
     val = $mem(ptl_entry+10(16) 1)
     line = '   wait_inhibited = '//$strrep(val<>0)
     put_line line o=$fname(output_file)
     val = $mem(ptl_entry+11(16) 2)
     line = '   monitor_flags = { }'
     put_line line o=$fname(output_file)
     FOR i=0 TO 15 DO
       IF $bit(val 48+i) THEN
         line = '                    '//syt$monitor_flag(i)
         put_line line o=$fname(output_file)
       IFEND
     FOREND
     val = $mem(ptl_entry+13(16) 2)
     line = '   system_flags = { }'
     put_line line o=$fname(output_file)
     FOR i=0 TO 31 DO
       IF $bit(val 32+i) THEN
         line = '                   '//syt$system_flag(i)
         put_line line o=$fname(output_file)
       IFEND
     FOREND
     val = $mem(ptl_entry+17(16) 1)
     line = '   dispatching_priority = '//$strrep(val 16)//'(16)'
     put_line line o=$fname(output_file)
     next_task = $mem(ptl_entry+18(16) 2)
     line = '   ijl_thread (ordinal of next task) = '//$strrep(next_task 16)//'(16)'
     put_line line o=$fname(output_file)
     val = $mem(ptl_entry+1A(16) 6)
     line = '   end_of_wait_time = '//$strrep(val 16)//'(16)'
     put_line line o=$fname(output_file)

   IFEND

 PROCEND dum$display_primary_task_list
*DECK DECK=DUM$DISPLAY_PURGE EXPAND=TRUE
PROCEDURE dum$display_purge, display_purge (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, sva, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable output_line k=string v=' '
  create_variable log_address v=$value(address)
  create_variable indent k=(string, 5) v='     '
  log_address = log_address + 1

  display_binary_unique_name log_address o=$fname(output_file) cs=indent//'gfn=' am=$value(am)
  output_line = indent//'dfl='//$strrep($mem(log_address+11, 3, j, 0, $value(am)), 16)
  output_line = output_line//' byte_addr='//$strrep($mem(log_address+14, 6, j, 0, $value(am)), 16)

  putl output_line o=$fname(output_file)

PROCEND dum$display_purge
*DECK DECK=DUM$DISPLAY_P_F_T_ENTRY EXPAND=TRUE
PROC dum$DISPLAY_P_F_T_ENTRY display_p_f_t_entry, dispfte (
  pfti      : integer -281474976710655..281474976710655 = $required
  output, o : file = $output
  )

  crev pftep
  compute_entry_address $sa(mmv$pft_p) $value(pfti) pftep
  oo = $string($value(output)) // '.$eoi'
  putl ' ----- Page Frame Table Entry '//$strrep($value(pfti), 16) o=$fname(oo)
  mmt$page_frame_table_entry pftep o=$value(output)

PROCEND dum$display_p_f_t_entry
*DECK DECK=DUM$DISPLAY_P_T_L_ENTRY EXPAND=TRUE
PROC dum$DISPLAY_P_T_L_ENTRY display_p_t_l_entry, disptle (
  gtid      : integer -281474976710655..281474976710655 = $required
  output, o : file = $output
  )

  crev ptlp
  get_ptlep_via_gtid $value(gtid) ptlp
  oo = $string($value(output)) // '.$eoi'
  putl ' ----- PTL  Entry '//$strrep($value(gtid), 16) o=$fname(oo)
  tmt$primary_task_list_entry ptlp o=$value(output)

PROCEND dum$display_p_t_l_entry
*DECK DECK=DUM$DISPLAY_QUEUED_CATALOGS EXPAND=TRUE
PROC dum$display_queued_catalogs, display_queued_catalogs, display_queued_catalog_table, disqct (
  address, a: integer 0 ..$max_integer
  array_size, as: integer 0 ..$max_integer
  element_size, es: integer 0 ..$max_integer
  output, o : file = $output
  status    : var of status = $optional
  )

" This incomplete procedure displays all catalogs queued within the job.
" If address, table_size, and element_size are NOT specified this
" displays the jobs queued catalog table.  These values are provided as
" parameters for use in displaying the file server client mainframe file.

  crev local_status status
  crev page_status status
  IF $file($value(output) open_position) = '$BOI' THEN
    rewind_file $value(output) status=local_status
  IFEND
  output_file = $string($value(output)) // '.$eoi'


  IF $specified(address) THEN
    array_size = $value(array_size)
    element_size = $value(element_size)
    lower_bound = 1
    IF $nil_pva($value(address)) THEN
       disv ' Nil queued catalog table ' o=$fname(output_file)
       EXIT_PROC
    IFEND
    pfv$p_queued_catalog_table = $value(address)
  ELSE
    IF $nil_pva($mem($sa(pfv$p_queued_catalog_table))) THEN
      disv ' Nil queued catalog table ' o=$fname(output_file)
      EXIT_PROC
    IFEND
    pfv$p_queued_catalog_table = $mem($sa(pfv$p_p_queued_catalog_table))
    array_size = $mem(pfv$p_queued_catalog_table+6, 4)
    lower_bound = $mem(pfv$p_queued_catalog_table+10, 4)
    element_size = $mem(pfv$p_queued_catalog_table+14, 4)
    pfv$p_queued_catalog_table = $mem($mem($sa(pfv$p_p_queued_catalog_table)))
  IFEND
  putl ' QUEUED CATALOG TABLE ' o=$fname(output_file)
  putl ' entry size '//$strrep(element_size) o=$fname(output_file)
  upper_bound = lower_bound + (array_size / element_size) - 1
  putl ' pfv$p_queued_catalog_table '//$strrep(pfv$p_queued_catalog_table, 16)//'(16)' o=$fname(output_file)
  FOR index = lower_bound TO upper_bound DO
    putl ' ----------- qct entry '//$strrep(index) o=$fname(output_file)
    entry_start = pfv$p_queued_catalog_table + ((index - lower_bound) * element_size)
    putl ' Entry start '//$strrep(entry_start, 16)//'(16)' o=$fname(output_file)
    incl ' putl $memory_string(entry_start+43,31) o=$fname(output_file)' status=page_status
    IF page_status.normal THEN
      putl ' SFID '//$strrep($memory(entry_start+97, 4), 16)//'(16)  index (2) residence(1) hash(1)' ..
            o=$fname(output_file)
    ELSE
      putl ' Page not in memory - entry '//$strrep(index) o=$fname(output_file)
      disv page_status o=$fname(output_file)
    IFEND
  FOREND

PROCEND dum$display_queued_catalogs
*DECK DECK=DUM$DISPLAY_QUEUE_ENTRY EXPAND=TRUE
PROCEDURE dum$display_queue_entry, display_queue_entry, disqe, display_queue, disq (
 queue_index, qi       : integer 1..16 = 1
 queue_entry_index, qei : any of
       integer 1..127
       key
         all
       keyend
   anyend    = all
 p_queue_interface_table, pva: integer 0..281474976710655 = 0
 display_option, do    :  key
    (driver, d)
    (cpu, c)
    (buffer, b)
    all
 keyend = all
 output, o              : file = $output
 status)

  " This proc displays the file server queue.
 "  This proc required RJTs most recent dump anlyzer.
 "  This proc assumes that dfm$Monitor_process, dfm$client_remote_procedur_call
 "  has been added.
 "  This proc defaults too the first p_queue_interface_table.
 " To determine if there is more than one queue interface table DO:
 "    display_queue_summary

  current = $default_module
  crev local_status status
  set_file_attributes output fc=legible pf=continuous
  chadm dfm$Monitor_process
  IF $file(output open_position) = '$BOI' THEN
    rewind_file output status=local_status
  IFEND
  out = output.$eoi
 "display_base_system_time (out)
  IF p_queue_interface_table= 0 THEN
    IF $nil_pva($pv(dfv$p_queue_interface_directory)) THEN
      putl ' Not using the server '  o=out
      exit_proc
    ELSE "default to the first queue interface table
      p_queue_interface_table = ..
        $pv(dfv$p_queue_interface_directory^[1].p_queue_interface_table)
    IFEND
  ELSE
    p_queue_interface_table = p_queue_interface_table
  IFEND
  IF $value_kind(queue_entry_index) = 'INTEGER' THEN
    first_queue_entry_index = queue_entry_index
    last_queue_entry_index = first_queue_entry_index
  ELSE  " ALL "
    first_queue_entry_index = 1
    last_queue_entry_index = $pv(?p_queue_interface_table.dft$queue_interface_table.queue_directory.driver_queue_pva_directory..
[?queue_index].p_driver_queue^.queue_header.number_of_queue_entries)
  IFEND

  " Display all selected queue entries
  FOR queue_entry_index = first_queue_entry_index TO last_queue_entry_index DO
    IF (display_options = DRIVER) OR (display_option = ALL) THEN
      disv '--  DRIVER QUEUE ENTRY ---'//$strrep(queue_index)//' '//$strrep(queue_entry_index)  o=out
     dispv ?p_queue_interface_table.dft$queue_interface_table.queue_directory.driver_queue_pva_directory..
[?queue_index].p_driver_queue^.queue_entries[?queue_entry_index]  o=out
     IF $pv(?p_queue_interface_table.dft$queue_interface_table.queue_directory.driver_queue_pva_directory..
[?queue_index].p_driver_queue^.queue_entries[?queue_entry_index].error_condition) <> 0 THEN
       display_esm_error $pv(?p_queue_interface_table.dft$queue_interface_table.queue_directory.driver_queue_pva_directory..
[?queue_index].p_driver_queue^.queue_entries[?queue_entry_index].error_condition) o=out
     IFEND
   IFEND
 monitor_entry = $pv(?p_queue_interface_table.dft$queue_interface_table.queue_directory.cpu_queue_pva_directory..
[?queue_index].p_cpu_queue^.queue_entries[?queue_entry_index].processor_type) = 'DFC$MONITOR'

    IF (display_option = CPU) OR (display_option = ALL) THEN
      disv '--- CPU QUEUE ENTRY ---'//$strrep(queue_index)//' '//$strrep(queue_entry_index)  o=out
      dispv ?p_queue_interface_table.dft$queue_interface_table.queue_directory.cpu_queue_pva_directory..
[?queue_index].p_cpu_queue^.queue_entries[?queue_entry_index]   o=out
      IF monitor_entry THEN
         p_server_iocb = $pv(?p_queue_interface_table.dft$queue_interface_table.queue_directory.cpu_queue_pva_directory..
[?queue_index].p_cpu_queue^.queue_entries[?queue_entry_index].p_server_iocb)
         IF NOT $nil_pva(p_server_iocb) THEN
           dispv ?p_server_iocb.mmt$server_iocb_entry o=out
        IFEND
      IFEND
    IFEND

    IF (display_option = BUFFER) OR (display_option = ALL) THEN
        p_send_buffer = $pv(?p_queue_interface_table.dft$queue_interface_table.queue_directory.cpu_queue_pva_directory..
[?queue_index].p_cpu_queue^.queue_entries[?queue_entry_index].p_send_buffer)

         p_receive_buffer = $pv(?p_queue_interface_table.dft$queue_interface_table.queue_directory.cpu_queue_pva_directory..
[?queue_index].p_cpu_queue^.queue_entries[?queue_entry_index].p_receive_buffer)

        chadm dfm$client_remote_procedur_call

        remote_procedure_call = ($pv(?p_send_buffer.dft$buffer_header.version)= 'CYBILRPC') OR ..
           ($pv(?p_receive_buffer.dft$buffer_header.version)= 'CYBILRPC')

       disv '   '   o=out
       disv '  ---- Send buffer '  o=out
       display_df_buffer p_send_buffer remote_procedure_call monitor_entry out

    disv '   '    o=out
    disv ' ----- Receive buffer '    o=out
   display_df_buffer p_receive_buffer remote_procedure_call  monitor_entry out
 IFEND
 FOREND

 chadm current
PROCEND dum$display_queue_entry
*DECK DECK=DUM$DISPLAY_QUEUE_HEADER EXPAND=TRUE
PROCEDURE dum$display_queue_header, display_queue_header, disqh (
  queue_index, qi: integer 1..16 = 1
  p_queue_interface_table, pva: integer 0..281474976710655 = 0
  display_option, do:  key (request_buffer, rb) (esm) (directory) (driver) (cpu) all keyend = all
  output, o: file = $output
  status)

 "  This proc displays the file server queue header.
 "  This proc required RJTs most recent dump analyzer.
 "  This proc assumes that dfm$Monitor_process  has been added.
 "  This proc defaults too the first p_queue_interface_table.
 "  To determine if there is more than one queue interface table DO:
 "    display_queue_summary

  set_file_attributes f=output fc=legible pf=continuous
  out = output.$eoi
  change_default_module m=dfm$monitor_process

  IF p_queue_interface_table = 0 THEN
    IF $nil_pva($program_value(dfv$p_queue_interface_directory)) THEN
      put_line l=' Not using the server ' o=out
      EXIT PROCEDURE
    ELSE  "default to the first queue interface table
      p_queue_interface_table = $program_value(dfv$p_queue_interface_directory^[1].p_queue_interface_table)
    IFEND
  ELSE
    p_queue_interface_table = p_queue_interface_table
  IFEND

  put_line l='1 Display Queue Header' o=out

  display_value v=' Queue index = '//queue_index o=out

  p_cpu_queue = $program_value(?p_queue_interface_table.dft$queue_interface_table..
.queue_directory.cpu_queue_pva_directory[?queue_index].p_cpu_queue)

  p_driver_queue = $program_value(?p_queue_interface_table.dft$queue_interface_table..
.queue_directory.driver_queue_pva_directory[?queue_index].p_driver_queue)

  display_base_system_time (out)

  IF (display_option = ALL) OR (display_option = REQUEST_BUFFER) THEN
    dispv ?p_queue_interface_table.dft$queue_interface_table.request_buffer_directory o=out

    limit = $program_value(?p_queue_interface_table.dft$queue_interface_table.request_buffer_directory.limit)

   p_request_buffer = $program_value(?p_queue_interface_table.dft$queue_interface_table..
.request_buffer_directory.p_request_buffer)

    header_listed = false
    in = 0
    WHILE in < limit DO
      p_request_buffer_entry = p_request_buffer+in
      IF $memory(p_request_buffer_entry, 8) = 0 THEN
        in = in + 8
        " 0 entry found
        CYCLE
      IFEND
      IF NOT header_listed THEN
        put_line l=' Offset P I  QI  QEI'  o=out
        header_listed = true
      IFEND

      " get the fields to display
       IF $program_value(?p_request_buffer_entry.dft$request_buffer_entry.flags.previously_processed) THEN
         prev = 'P'
       ELSE
         prev =  ' '
       IFEND
       IF $program_value(?p_request_buffer_entry.dft$request_buffer_entry.flags.inquiry) THEN
         inqu = 'I'
      "  dispv ?p_request_buffer_entry.dft$request_buffer_entry.inquiry_message o=out
       ELSE
        inqu = ' '
      IFEND
      qi = $strrep($program_value(?p_request_buffer_entry.dft$request_buffer_entry.queue_index))
      qi = $substr(qi,1,3,' ')
      qei = $strrep($program_value(?p_request_buffer_entry.dft$request_buffer_entry.queue_entry_index))
      qei = $substr(qei,1,4,' ')
      index = $substr($strrep(in),1,5,' ')
      outl = '  '//index//' '//prev//' '//inqu//'  '//qi//' '//qei
      put_line l=outl o=out
      in = in + 8
    WHILEND
  IFEND

  IF (display_option = ALL) OR (display_option = ESM) THEN
    put_line l=' ' o=out
    dispv ?p_queue_interface_table.dft$queue_interface_table.esm_base_addresses o=out
  IFEND

  IF (display_option = ALL) OR (display_option = DIRECTORY) THEN
    put_line l=' ' o=out
    dispv ?p_queue_interface_table.dft$queue_interface_table.queue_directory o=out
  IFEND

   q_count = $program_value(?p_queue_interface_table.dft$queue_interface_table..
.queue_directory.number_of_queues)

  IF (display_option = ALL) OR (display_option = CPU) THEN
    put_line l=' ' o=out
    dispv ?p_cpu_queue.dft$cpu_queue.queue_header o=out
  IFEND

  IF (display_option = ALL) OR (display_option = DRIVER) THEN
    put_line l=' ' o=out
    dispv ?p_driver_queue.dft$driver_queue.queue_header o=out
 IFEND

PROCEND dum$display_queue_header
*DECK DECK=DUM$DISPLAY_QUEUE_INTERFACE_TAB EXPAND=TRUE
PROCEDURE  dum$display_queue_interface_tab, display_queue_interface_table, disqit (
  output, o: file = $output
  status)

 " This procedure displays the file server queue interface table'
 " This proc uses RJTs new dump analyzer
 " This proc assumes that dfm$monitor_process has been added.

   set_file_attributes output fc=legible pf=continuous
  out = output.$eoi
  current = $default_module
  chadm dfm$monitor_process
 IF $nil_pva($pv(dfv$p_queue_interface_directory))
   putl ' Not using the server '  o=out
 ELSE
   FOR i = $pv(LOWERBOUND(dfv$p_queue_interface_directory^)) TO ..
           $pv(UPPERBOUND(dfv$p_queue_interface_directory^)) DO
      putl ' -----  Queue interface table entry  '//$strrep(i)//' ---- '  o=out
      address = $pv(^dfv$p_queue_interface_directory^[?i])
      dispv ?address.dft$q_interface_directory_entry o=out
      IF NOT $nil_pva($pv(?address.dft$q_interface_directory_entry.send_pp.p_element_reservations))  THEN
        dispv ?address.dft$q_interface_directory_entry.send_pp.p_element_reservations^  o=out
      IFEND
      IF NOT $nil_pva($pv(?address.dft$q_interface_directory_entry.receive_pp.p_element_reservations))  THEN
        dispv ?address.dft$q_interface_directory_entry.receive_pp.p_element_reservations^  o=out
      IFEND
   FOREND
 IFEND
 chadm current
PROCEND dum$display_queue_interface_tab
*DECK DECK=DUM$DISPLAY_QUEUE_SUMMARY EXPAND=TRUE
PROCEDURE  dum$display_queue_summary, display_queue_summary, disqs (
  output, o: file = $output
  status)

 " This procedure displays a summary of the file server state.
 " This proc uses RJTs new dump analyzer.
 " This proc assumes that dfm$monitor_process has been added.

  set_file_attributes f=output fc=legible pf=continuous
  out = output.$eoi
  current = $default_module
  change_default_module m=dfm$monitor_process

  IF $nil_pva($program_value(dfv$p_queue_interface_directory))
    put_line l=' Not using the server ' o=out
  ELSE
    FOR queue_directory_entry = $program_value(LOWERBOUND(dfv$p_queue_interface_directory^)) TO ..
          $program_value(UPPERBOUND(dfv$p_queue_interface_directory^)) DO
      address = $program_value(^dfv$p_queue_interface_directory^[?queue_directory_entry])
      p_queue_interface_table = ..
            $program_value(?address.dft$q_interface_directory_entry.p_queue_interface_table)
      display_value v='- Queue Interface '//$strrep(queue_directory_entry)//..
' -- p_queue_interface_table '//$strrep(p_queue_interface_table,16)//'(16)' o=out
      FOR queue_index = 1 to 16 DO
        p_cpu_queue = $program_value(?p_queue_interface_table.dft$queue_interface_table..
.queue_directory.cpu_queue_pva_directory[?queue_index].p_cpu_queue)
        IF NOT $nil_pva(p_cpu_queue) THEN
          p_driver_queue = $program_value(?p_queue_interface_table.dft$queue_interface_table..
.queue_directory.driver_queue_pva_directory[?queue_index].p_driver_queue)
          qi_string = $strrep(queue_index)
          IF queue_index < 10 THEN
            qi_string = ' '//qi_string
          IFEND
          state_line = ' Queue Index '//qi_string//'    '// ..
$program_value(?p_cpu_queue.dft$cpu_queue.queue_header.destination_mainframe_name)//'   '// ..
$program_value(?p_cpu_queue.dft$cpu_queue.queue_header.partner_status.server_state)
          IF queue_index <= 8 THEN
            state_line = state_line//'   CLIENT'
          ELSE
            state_line = state_line//'   SERVER '
          IFEND
          put_line l=state_line  o=out
        IFEND
      FOREND
    FOREND
  IFEND
  put_line l=' ' o=out
  change_default_module m=dfm$mtr_served_family_manager
  IF $program_value(dfv$served_family_table_root.valid) THEN
    FOR pnter = 1 TO $program_value(dfv$served_family_table_root.number_of_active_pointers) DO
      FOR family = 1 TO $program_value(dfv$served_family_table_root..
.p_family_list_pointer_array^[?pnter].highest_valid_entry) DO
        display_value v='Family '//$strrep(family)//'   '//..
$program_value(dfv$served_family_table_root.p_family_list_pointer_array^[?..
pnter].p_served_family_list^[?family].family_name)//'   '//..
$program_value(dfv$served_family_table_root.p_family_list_pointer_array^[?..
pnter].p_served_family_list^[?family].server_state) o=out
      FOREND
    FOREND
  ELSE
    display_value v=' No served families' o=out
  IFEND

  change_default_module m=current

PROCEND dum$display_queue_summary
*DECK DECK=DUM$DISPLAY_REALLOCATE EXPAND=TRUE
PROCEDURE dum$display_reallocate, display_reallocate (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, sva, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable output_line k=string v=' '
  create_variable log_address v=$value(address)
  create_variable indent k=(string, 5) v='     '
  create_variable chain_pos_int k=integer
  create_variable chain_pos k=string d=0..4
  chain_pos(0) = 'dmc$first_and_last_allocation'
  chain_pos(1) = 'dmc$first_allocation'
  chain_pos(2) = 'dmc$middle_allocation'
  chain_pos(3) = 'dmc$last_allocation'
  chain_pos(4) = 'dmc$part_of_allocation_unit'

  log_address = log_address + 1
  display_binary_unique_name log_address o=$fname(output_file) cs=indent//'gfn=' am=$value(am)
  output_line = indent//'dfl='//$strrep($mem(log_address+11, 3, j, 0, $value(am)), 16)
  output_line = output_line//' mf assigned='//$strrep($mem(log_address+14, 5, j, 0, $value(am)), 16)
  putl output_line o=$fname(output_file)
  output_line = indent//'dau_adrs='//$strrep($mem(log_address+19, 3, j, 0, $value(am)), 16)
  output_line = output_line//' old_dau_adrs='//$strrep($mem(log_address+22, 3, j, 0, $value(am)), 16)
  putl output_line o=$fname(output_file)
  output_line = indent//'next_dau_adrs='//$strrep($mem(log_address+25, 3, j, 0, $value(am)), 16)
  output_line = output_line//' prev_dau_adrs='//$strrep($mem(log_address+28, 3, j, 0, $value(am)), 16)
  putl output_line o=$fname(output_file)
  output_line = indent//'daus_per_alloc='//$strrep($mem(log_address+31, 1, j, 0, $value(am)), 16)
  chain_pos_int = $mem(log_address+32, 1, j, 0, $value(am))
  output_line = output_line//' alloc_chain_pos='//chain_pos(chain_pos_int)
  putl output_line o=$fname(output_file)

PROCEND dum$display_reallocate
*DECK DECK=DUM$DISPLAY_REGISTER_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Register File Command' ??
MODULE dum$display_register_file;

{ PURPOSE:
{   This module contains the code for the display_register_file command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_partial_display
*copyc dup$evaluate_parameters
*copyc dup$new_page_procedure
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_reg_file_cmd', EJECT ??

{ PURPOSE:
{   This procedure writes the register file data to the output file.

  PROCEDURE [XDCL] dup$display_reg_file_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_register_file, disrf (
{   processor, p: any of
{       key
{         (all a)
{       keyend
{       integer 0..3
{     anyend = 0
{   title, t: string 1..31 = 'display_register_file'
{   output, o: file
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (1),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (23),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 12, 10, 17, 32, 971],
    clc$command, 7, 4, 0, 0, 0, 0, 4, ''], [
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['P                              ',clc$abbreviation_entry, 1],
    ['PROCESSOR                      ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TITLE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 23],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, 3, 10]]
    ,
    '0'],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_register_file'''],
{ PARAMETER 3
    [[1, 0, clc$file_type]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$processor = 1,
      p$title = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    TYPE
      t$array_or_integer = RECORD
        CASE boolean OF
        = TRUE =
          array_part: ARRAY [1 .. 4] of 0 .. 0ffff(16),
        = FALSE =
          integer_part: integer,
        CASEND,
      RECEND;

    VAR
      array_or_integer: t$array_or_integer,
      default_list: ARRAY [1 .. 1] OF dut$default_change_list_entry,
      display_control: clt$display_control,
      ending_processor: 0 .. duc$de_maximum_processors,
      group_index: 1 .. 4,
      ignore_status: ost$status,
      output_display_opened: boolean,
      processor: 0 .. duc$de_maximum_processors,
      register: dut$de_register_file_entry,
      register_displayed: boolean,
      register_index: 0 .. duc$de_max_register_number,
      ring_attributes: amt$ring_attributes,
      starting_processor: 0 .. duc$de_maximum_processors,
      string_2: string (2),
      string_4: string (4);

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    { Change the default value for the PROCESSOR parameter.

    default_list [1].default_name := duc$dp_processor;
    default_list [1].number := p$processor;
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

      { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      { Determine the starting and ending processor number to display.

      IF pvt [p$processor].value^.kind = clc$integer THEN
        starting_processor := pvt [p$processor].value^.integer_value.value;
        ending_processor := starting_processor;
      ELSE
        starting_processor := 0;
        ending_processor := duc$de_maximum_processors;
      IFEND;
      register_displayed := FALSE;

      { Display the register file.

     /display_processor/
      FOR processor := starting_processor TO ending_processor DO
        IF NOT duv$dump_environment_p^.register_file [processor].available THEN
          IF (processor = ending_processor) AND NOT register_displayed THEN
            IF starting_processor = ending_processor THEN
              osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,
                    'The register file for processor', status);
              osp$append_status_integer (osc$status_parameter_delimiter, processor, 10, FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);
            ELSE
              osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,
                    'The register file for the processor is', status);
            IFEND;
            EXIT /display_opened/;  {---->
          IFEND;
          CYCLE /display_processor/;  {---->
        IFEND;
        register_displayed := TRUE;

        display_control.line_number := display_control.page_length + 1;
        clp$new_display_line (display_control, 1, ignore_status);
        clp$put_partial_display (display_control, '  PROCESSOR   ', clc$no_trim, amc$continue, ignore_status);
        string_2 := 'XX';
        clp$convert_integer_to_rjstring (processor, 16, FALSE, '0', string_2, ignore_status);
        clp$put_partial_display (display_control, string_2, clc$no_trim, amc$terminate, ignore_status);
        clp$new_display_line (display_control, 1, ignore_status);

       /display_register/
        FOR register_index := 0 TO
              (duv$dump_environment_p^.register_file [processor].number_of_registers - 1) DO
          register := duv$dump_environment_p^.register_file [processor].register [register_index];
          IF NOT register.available THEN
            CYCLE /display_register/;  {---->
          IFEND;

          { Display the register index.

          string_4 := ' XXXX';
          clp$convert_integer_to_rjstring (register_index, 16, FALSE, '0', string_4, ignore_status);
          clp$put_partial_display (display_control, string_4, clc$trim, amc$start, ignore_status);
          clp$put_partial_display (display_control, '  ', clc$no_trim, amc$continue, ignore_status);

          { Display the registers in groups of sixteen bits.

          array_or_integer.integer_part := register.value;
          FOR group_index := 1 TO 4 DO
            string_4 := 'XXXX';
            clp$convert_integer_to_rjstring (array_or_integer.array_part [group_index], 16, FALSE, '0',
                  string_4, ignore_status);
            clp$put_partial_display (display_control, string_4, clc$trim, amc$continue, ignore_status);
            clp$put_partial_display (display_control, ' ', clc$no_trim, amc$continue, ignore_status);
          FOREND;
        FOREND /display_register/;
        clp$new_display_line (display_control, 1, ignore_status);

      FOREND /display_processor/;
    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_reg_file_cmd;
MODEND dum$display_register_file;
*DECK DECK=DUM$DISPLAY_RELEASE_DAU EXPAND=TRUE
PROCEDURE dum$display_release_dau, display_release_dau (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, sva, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable output_line k=string v=' '
  create_variable log_address v=$value(address)
  create_variable indent k=(string, 5) v='     '
  log_address = log_address + 1

  display_binary_unique_name log_address o=$fname(output_file) cs=indent//'gfn=' am=$value(am)
  output_line = indent//'dfl='//$strrep($mem(log_address+11, 3, j, 0, $value(am)), 16)
  output_line = output_line//' dau='//$strrep($mem(log_address+14, 3, j, 0, $value(am)), 16)
  output_line = output_line//' dau/au='//$strrep($mem(log_address+17, 1, j, 0, $value(am)), 16)
  output_line = output_line//' mf_asignd='//$strrep($mem(log_address+18, 5, j, 0, $value(am)), 16)

  putl output_line o=$fname(output_file)

PROCEND dum$display_release_dau
*DECK DECK=DUM$DISPLAY_RELEASE_DFL EXPAND=TRUE
PROCEDURE dum$display_release_dfl, display_release_dfl (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, sva, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable output_line k=string v=' '
  create_variable log_address v=$value(address)
  create_variable indent k=(string, 5) v='     '
  log_address = log_address + 1

  display_binary_unique_name log_address o=$fname(output_file) cs=indent//'gfn=' am=$value(am)
  output_line = indent//'dfl='//$strrep($mem(log_address+11, 3, j, 0, $value(am)), 16)
  output_line = output_line//' mf_asignd='//$strrep($mem(log_address+14, 5, j, 0, $value(am)), 16)

  putl output_line o=$fname(output_file)

PROCEND dum$display_release_dfl
*DECK DECK=DUM$DISPLAY_REPORT_RECORD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display Report Record Command' ??
MODULE dum$display_report_record;

{ PURPOSE:
{   This module contains the code for the display_report_record command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$find_record_list_entry
*copyc dup$new_page_procedure
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    v$restart_file_seq_p: ^SEQ ( * );

?? OLDTITLE ??
?? NEWTITLE := 'retrieve_line', EJECT ??

{ PURPOSE:
{   This procedure retrieves a line from the report record.

  PROCEDURE retrieve_line
    (VAR report_line: string (80);
     VAR report_length: integer;
     VAR status: ost$status);

    CONST
      c$line_feed = 0a(16);

    TYPE
      t$report_line_array = RECORD
        CASE boolean OF
        = TRUE =
          line_part: string (80),
        = FALSE =
          array_part: ARRAY [1 .. 80] OF 0 .. 0ff(16),
        CASEND,
      RECEND;

    VAR
      index: 0 .. 81,
      report_byte_p: ^0 .. 0ff(16),
      report_line_array: t$report_line_array;

    status.normal := TRUE;

    report_line_array.line_part := ' ';
    report_line := ' ';
    index := 1;
    REPEAT
      NEXT report_byte_p IN v$restart_file_seq_p;
      IF report_byte_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        RETURN;  {---->
      IFEND;
      report_length := report_length - 1;
      IF (report_length = 0) AND (report_byte_p^ <> c$line_feed) THEN
        RETURN;  {---->
      IFEND;
      IF (index = 81) AND (report_byte_p^ <> c$line_feed) THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$bad_report_record, '', status);
        RETURN;  {---->
      IFEND;
      IF report_byte_p^ <> c$line_feed THEN
        report_line_array.array_part [index] := report_byte_p^;
        index := index + 1;
      IFEND;
    UNTIL report_byte_p^ = c$line_feed;
    report_line := report_line_array.line_part;

  PROCEND retrieve_line;
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_report_record', EJECT ??

{ PURPOSE:
{   This procedure displays a report record from the restart file.

  PROCEDURE [XDCL] dup$display_report_record
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_dump_record, disdr (
{   record_identifier, ri: any of
{       string 1..3
{       integer
{       name
{     anyend = $required
{   output, o: file
{   title, t: string 1..31 = 'display_report_record'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (23),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 4, 16, 9, 16, 59, 904],
    clc$command, 7, 4, 1, 0, 0, 0, 4, ''], [
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['RECORD_IDENTIFIER              ',clc$nominal_entry, 1],
    ['RI                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['T                              ',clc$abbreviation_entry, 3],
    ['TITLE                          ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 57, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 23],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type, clc$name_type, clc$string_type],
    TRUE, 3],
    8, [[1, 0, clc$string_type], [1, 3, FALSE]],
    20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_report_record'''],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$record_identifier = 1,
      p$output = 2,
      p$title = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      cell_p: ^cell,
      display_control: clt$display_control,
      display_string: string (osc$max_string_size),
      entry_p: ^dut$de_other_record_entry,
      header_line_count: 0 .. 0ff(16),
      header_lines_p: ^ARRAY [1 .. *] OF string (80),
      ignore_status: ost$status,
      index: 0 .. 0ff(16),
      output_display_opened: boolean,
      report_length: integer,
      report_line: string (80),
      ring_attributes: amt$ring_attributes,
      string_length: integer;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE ??
?? NEWTITLE := 'new_page_procedure', EJECT ??

{ PURPOSE:
{   This procedure calls the standard new page procedure and then displays some header lines.

    PROCEDURE new_page_procedure
      (VAR display_control: clt$display_control;
           new_page_number: integer;
       VAR status: ost$status);

      VAR
        index: 0 .. 0ff(16);

      status.normal := TRUE;
      dup$new_page_procedure (display_control, new_page_number, status);

      IF header_lines_p <> NIL THEN
        FOR index := 1 TO header_line_count DO
          clp$put_display (display_control, header_lines_p^ [index], clc$trim, status);
        FOREND;
      IFEND;

    PROCEND new_page_procedure;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    dup$find_record_list_entry (pvt [p$record_identifier].value^, entry_p);
    IF entry_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The specified record is',
            status);
      RETURN;  {---->
    IFEND;

    IF entry_p^.record_type <> duc$de_ort_report THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$record_type_supported, 'REPORT', status);
      RETURN;  {---->
    IFEND;

    header_line_count := 0;
    header_lines_p := NIL;
    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

      { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      IF pvt [p$title].specified THEN
        duv$title_data.command_name := pvt [p$title].value^.string_value^;
      ELSE
        STRINGREP (display_string, string_length, 'display_report_record :  ', entry_p^.name);
        duv$title_data.command_name := display_string (1, string_length);
      IFEND;

      v$restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
      cell_p := #ADDRESS (#RING (v$restart_file_seq_p), #SEGMENT (v$restart_file_seq_p), entry_p^.first_byte);
      RESET v$restart_file_seq_p TO cell_p;

      header_line_count := entry_p^.header_line_count;
      IF header_line_count > 0 THEN
        PUSH header_lines_p: [1 .. header_line_count];
      IFEND;
      FOR index := 1 TO header_line_count DO
        header_lines_p^ [index] := ' ';
      FOREND;

      report_length := entry_p^.report_record_length * 8;

      FOR index := 1 TO header_line_count DO
        retrieve_line (header_lines_p^ [index], report_length, status);
        IF NOT status.normal OR (report_length <= 0) THEN
          EXIT /display_opened/;  {---->
        IFEND;
      FOREND;

      WHILE report_length > 0 DO
        retrieve_line (report_line, report_length, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        clp$put_display (display_control, report_line, clc$trim, ignore_status);
      WHILEND;

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_report_record;
MODEND dum$display_report_record;
*DECK DECK=DUM$DISPLAY_RETURN_DAU EXPAND=TRUE
PROCEDURE dum$display_return_dau, display_return_dau (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, sva, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable output_line k=string v=' '
  create_variable log_address v=$value(address)
  create_variable indent k=(string, 5) v='     '
  log_address = log_address + 1

  output_line = indent//'mf_asignd='//$strrep($mem(log_address, 5, j, 0, $value(am)), 16)
  output_line = output_line//' dau='//$strrep($mem(log_address+5, 3, j, 0, $value(am)), 16)
  output_line = output_line//' dau/au='//$strrep($mem(log_address+8, 1, j, 0, $value(am)), 16)

  putl output_line o=$fname(output_file)

PROCEND dum$display_return_dau
*DECK DECK=DUM$DISPLAY_RETURN_DFL EXPAND=TRUE
PROCEDURE dum$display_return_dfl, display_return_dfl (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, sva, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable output_line k=string v=' '
  create_variable log_address v=$value(address)
  create_variable indent k=(string, 5) v='     '
  log_address = log_address + 1

  output_line = indent//'dfl='//$strrep($mem(log_address, 3, j, 0, $value(am)), 16)
  output_line = output_line//' mf_asignd='//$strrep($mem(log_address+3, 5, j, 0, $value(am)), 16)

  putl output_line o=$fname(output_file)

PROCEND dum$display_return_dfl
*DECK DECK=DUM$DISPLAY_S0_PP_MEM_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display S0 PP Memory Command' ??
MODULE dum$display_s0_pp_mem_command;

{ PURPOSE:
{   This module contains the code for the display_s0_pp_memory command.  It displays the contents of an S0 PP
{   memory which has been dumped to the PC floppy disk and manually moved to a NOS/VE file.  The output file
{   is in a format similar to the Analyze_Dump directive Display_PP_Memory.
{
{ DESIGN:
{   The input file is read, reformatted and displayed in the format specified by the input parameters.
{
{ NOTES:
{   After the S0 PP is dumped to the PC console floppy, the user must move the dump file from the floppy disk
{   to a NOS/VE file through the use of a micro program such as CONNECT.  The NOS/VE file is then specified as
{   the input parameter for this module.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc amp$get_segment_pointer
*copyc clp$close_display
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc dup$display_data
*copyc dup$new_page_procedure
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$set_status_abnormal
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
?? EJECT ??
*copyc duv$execution_environment
*copyc duv$title_data
?? TITLE := 'dup$display_s0_pp_memory', EJECT ??

{ PURPOSE:
{   This procedure cracks the command parameters, controls the input and output file opening and closing, and
{   calls the procedure which formats and writes the output.

  PROCEDURE [XDCL, #GATE] dup$display_s0_pp_memory
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_s0_pp_memory, disspm (
{   input, i: file = $required
{   output, o: file = $required
{   address, a: integer 0..16383 = 0
{   words, w: integer 1..16384 = 16384
{   display_option, do: list 1..2 of key
{       (numeric n) (ascii a) (display_code dc)
{     keyend = (numeric ascii)
{   radix, r: integer 8..16 = 8
{   title, t: string 1..osc$max_name_size = 'display_s0_pp_memory'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 15] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (5),
      recend,
      type5: 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 .. 6] of clt$keyword_specification,
        recend,
        default_value: string (15),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (22),
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 1, 22, 11, 40, 37, 461],
    clc$command, 15, 8, 2, 0, 0, 0, 8, ''], [
    ['A                              ',clc$abbreviation_entry, 3],
    ['ADDRESS                        ',clc$nominal_entry, 3],
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 5],
    ['DO                             ',clc$abbreviation_entry, 5],
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['R                              ',clc$abbreviation_entry, 6],
    ['RADIX                          ',clc$nominal_entry, 6],
    ['STATUS                         ',clc$nominal_entry, 8],
    ['T                              ',clc$abbreviation_entry, 7],
    ['TITLE                          ',clc$nominal_entry, 7],
    ['W                              ',clc$abbreviation_entry, 4],
    ['WORDS                          ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 5
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 245,
  clc$optional_default_parameter, 0, 15],
{ PARAMETER 6
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 7
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 22],
{ PARAMETER 8
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, 16383, 10],
    '0'],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [1, 16384, 10],
    '16384'],
{ PARAMETER 5
    [[1, 0, clc$list_type], [229, 1, 2, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [6], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['ASCII                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['DC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['DISPLAY_CODE                   ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['NUMERIC                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    '(numeric ascii)'],
{ PARAMETER 6
    [[1, 0, clc$integer_type], [8, 16, 10],
    '8'],
{ PARAMETER 7
    [[1, 0, clc$string_type], [1, osc$max_name_size, FALSE],
    '''display_s0_pp_memory'''],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$input = 1,
      p$output = 2,
      p$address = 3,
      p$words = 4,
      p$display_option = 5,
      p$radix = 6,
      p$title = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    VAR
      address: 0 .. 16383,
      display_control: clt$display_control,
      end_of_input_file: boolean,
      fa_p: ^fst$attachment_options,
      file_identifier: amt$file_identifier,
      file_pointer: amt$segment_pointer,
      ignore_status: ost$status,
      mca_p: ^fst$file_cycle_attributes,
      output_display_opened: boolean,
      skip_pp_data_p: ^SEQ ( * ),
      radix: 8 .. 16,
      ring_attributes: amt$ring_attributes,
      words: 1 .. 16384;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    address := pvt [p$address].value^.integer_value.value;
    words := pvt [p$words].value^.integer_value.value;

    { Open the input compare file.

    PUSH fa_p: [1 .. 1];
    fa_p^ [1].selector := fsc$access_and_share_modes;
    fa_p^ [1].access_modes.selector := fsc$specific_access_modes;
    fa_p^ [1].access_modes.value := $fst$file_access_options [fsc$read];
    fa_p^ [1].share_modes.selector := fsc$specific_share_modes;
    fa_p^ [1].share_modes.value := $fst$file_access_options [fsc$read];

    PUSH mca_p: [1 .. 2];
    mca_p^ [1].selector := fsc$record_type;
    mca_p^ [1].record_type := amc$undefined;
    mca_p^ [2].selector := fsc$preset_value;
    mca_p^ [2].preset_value := -1;

    fsp$open_file (pvt [p$input].value^.file_value^, amc$segment, fa_p, NIL, mca_p, NIL, NIL, file_identifier,
          status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

   /file_opened/
    BEGIN
      output_display_opened := FALSE;
      osp$establish_block_exit_hndlr (^abort_handler);

      amp$get_segment_pointer (file_identifier, amc$sequence_pointer, file_pointer, status);
      IF NOT status.normal THEN
        EXIT /file_opened/;  {---->
      IFEND;
      IF file_pointer.sequence_pointer = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /file_opened/;  {---->
      IFEND;
      RESET file_pointer.sequence_pointer;

      { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /file_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      radix := pvt [p$radix].value^.integer_value.value;

      { Return if there are no words to display.

      IF words = 0 THEN
        EXIT /file_opened/;  {---->
      IFEND;

      { Skip over sixteen-bit length value and skip to the desired address in the pp memory data.

      NEXT skip_pp_data_p: [[REP (2) OF cell]] IN file_pointer.sequence_pointer;
      IF skip_pp_data_p = NIL THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
        EXIT /file_opened/;  {---->
      IFEND;
      IF address <> 0 THEN
        NEXT skip_pp_data_p: [[REP (address * 2) OF cell]] IN file_pointer.sequence_pointer;
        IF skip_pp_data_p = NIL THEN
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);
          EXIT /file_opened/;  {---->
        IFEND;
      IFEND;

      { Display the data.

      dup$display_data (pvt [p$display_option].value, FALSE, radix, address, words, display_control,
            file_pointer.sequence_pointer, end_of_input_file, status);
      IF end_of_input_file THEN
        status.normal := TRUE;
      IFEND;
    END /file_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    fsp$close_file (file_identifier, ignore_status);
    osp$disestablish_cond_handler;

  PROCEND dup$display_s0_pp_memory;
MODEND dum$display_s0_pp_mem_command;
*DECK DECK=DUM$DISPLAY_S0_REGISTER_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Display S0 Register File Command' ??
MODULE dum$display_s0_register_file;

{ PURPOSE:
{   This module contains the code for the display_s0_register_file command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$display_xp_registers
*copyc dup$find_record_list_entry
*copyc dup$new_page_procedure
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'display_data', EJECT ??

{ PURPOSE:
{   This procedure displays the data.

  PROCEDURE display_data
    (    entry: dut$de_other_record_entry;
     VAR display_control: clt$display_control);

    TYPE
      t$data_line = RECORD
        CASE boolean OF
        = TRUE =
          line: string (50),
        = FALSE =
          first_part: t$first_part,
          space_1: string (2),
          name_part: string (8),
          space_2: string (1),
          number_1: string (4),
          space_3: string (1),
          number_2: string (4),
        CASEND,
      RECEND,

      t$first_part = RECORD
        CASE 1 .. 3 OF
        = 1 =
          name_1: string (6),
          space_1a: string (1),
          number_1a: string (4),
          space_1b: string (1),
          number_1b: string (4),
          space_1c: string (9),
        = 2 =
          name_2a: string (4),
          space_2a: string (1),
          number_2a: string (4),
          space_2b: string (2),
          name_2b: string (4),
          space_2c: string (1),
          number_2b: string (4),
          space_2d: string (5),
        = 3 =
          name_3a: string (3),
          space_3a: string (1),
          number_3a: string (2),
          space_3b: string (2),
          name_3b: string (3),
          space_3c: string (1),
          number_3b: string (2),
          space_3d: string (7),
          number_3c: string (4),
        CASEND,
      RECEND,

      t$register_1 = RECORD
        number_1: 0 .. 0ffff(16),
        number_2: 0 .. 0ffff(16),
        number_3: 0 .. 0ffff(16),
        number_4: 0 .. 0ffff(16),
      RECEND,

      t$register_2 = RECORD
        number_1: 0 .. 0ff(16),
        number_2: 0 .. 0ff(16),
        number_3: 0 .. 0ffff(16),
        number_4: 0 .. 0ffff(16),
        number_5: 0 .. 0ffff(16),
      RECEND,

      t$register_line = RECORD
        CASE boolean OF
        = TRUE =
          line: string (50),
        = FALSE =
          name_part: string (7),
          space_1: string (2),
          number_1: string (4),
          space_2: string (1),
          number_2: string (4),
          space_3: string (1),
          number_3: string (4),
          space_4: string (1),
          number_4: string (4),
        CASEND,
      RECEND;

    VAR
      cell_p: ^cell,
      data_line: t$data_line,
      ignore_status: ost$status,
      index: 0 .. 0ff(16),
      register_1_p: ^t$register_1,
      register_2_p: ^t$register_2,
      register_line: t$register_line,
      restart_file_seq_p: ^ SEQ ( * ),
      xp_data_p: ^dut$ee_xp_data;

    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry.first_byte);
    RESET restart_file_seq_p TO cell_p;

    NEXT xp_data_p IN restart_file_seq_p;
    IF xp_data_p = NIL THEN
      RETURN;  {---->
    IFEND;
    dup$display_xp_registers (xp_data_p^, display_control);

    FOR index := 24(16) TO 26(16) DO
      NEXT register_1_p IN restart_file_seq_p;
      IF register_1_p = NIL THEN
        RETURN;  {---->
      IFEND;
      register_line.line := ' ';
      register_line.name_part := 'reg XX:';
      clp$convert_integer_to_rjstring (index, 16, FALSE, '0', register_line.name_part (5, 2),
            ignore_status);
      clp$convert_integer_to_rjstring (register_1_p^.number_1, 16, FALSE, '0', register_line.number_1,
            ignore_status);
      clp$convert_integer_to_rjstring (register_1_p^.number_2, 16, FALSE, '0', register_line.number_2,
            ignore_status);
      clp$convert_integer_to_rjstring (register_1_p^.number_3, 16, FALSE, '0', register_line.number_3,
            ignore_status);
      clp$convert_integer_to_rjstring (register_1_p^.number_4, 16, FALSE, '0', register_line.number_4,
            ignore_status);
      clp$put_display (display_control, register_line.line, clc$trim, ignore_status);
    FOREND;
    clp$put_display (display_control, ' ', clc$trim, ignore_status);

    NEXT register_1_p IN restart_file_seq_p;
    IF register_1_p = NIL THEN
      RETURN;  {---->
    IFEND;
    data_line.line := ' ';
    data_line.first_part.name_1 := 'sit';
    clp$convert_integer_to_rjstring (register_1_p^.number_1, 16, FALSE, '0', data_line.first_part.number_1a,
          ignore_status);
    clp$convert_integer_to_rjstring (register_1_p^.number_2, 16, FALSE, '0', data_line.first_part.number_1b,
          ignore_status);
    data_line.name_part := 'sit(rit)';
    clp$convert_integer_to_rjstring (register_1_p^.number_3, 16, FALSE, '0', data_line.number_1,
          ignore_status);
    clp$convert_integer_to_rjstring (register_1_p^.number_4, 16, FALSE, '0', data_line.number_2,
          ignore_status);
    clp$put_display (display_control, data_line.line, clc$trim, ignore_status);

    NEXT register_2_p IN restart_file_seq_p;
    IF register_2_p = NIL THEN
      RETURN;  {---->
    IFEND;
    data_line.line := ' ';
    data_line.first_part.name_3a := 'psm';
    clp$convert_integer_to_rjstring (register_2_p^.number_1, 16, FALSE, '0', data_line.first_part.number_3a,
          ignore_status);
    data_line.first_part.name_3b := 'ptl';
    clp$convert_integer_to_rjstring (register_2_p^.number_2, 16, FALSE, '0', data_line.first_part.number_3b,
          ignore_status);
    clp$convert_integer_to_rjstring (register_2_p^.number_3, 16, FALSE, '0', data_line.first_part.number_3c,
          ignore_status);
    data_line.name_part := 'mps';
    clp$convert_integer_to_rjstring (register_2_p^.number_4, 16, FALSE, '0', data_line.number_1,
          ignore_status);
    clp$convert_integer_to_rjstring (register_2_p^.number_5, 16, FALSE, '0', data_line.number_2,
          ignore_status);
    clp$put_display (display_control, data_line.line, clc$trim, ignore_status);

    NEXT register_1_p IN restart_file_seq_p;
    IF register_1_p = NIL THEN
      RETURN;  {---->
    IFEND;
    data_line.line := ' ';
    data_line.first_part.name_1 := 'pta';
    clp$convert_integer_to_rjstring (register_1_p^.number_1, 16, FALSE, '0', data_line.first_part.number_1a,
          ignore_status);
    clp$convert_integer_to_rjstring (register_1_p^.number_2, 16, FALSE, '0', data_line.first_part.number_1b,
          ignore_status);
    data_line.name_part := 'jps';
    clp$convert_integer_to_rjstring (register_1_p^.number_3, 16, FALSE, '0', data_line.number_1,
          ignore_status);
    clp$convert_integer_to_rjstring (register_1_p^.number_4, 16, FALSE, '0', data_line.number_2,
          ignore_status);
    clp$put_display (display_control, data_line.line, clc$trim, ignore_status);

    NEXT register_1_p IN restart_file_seq_p;
    IF register_1_p = NIL THEN
      RETURN;  {---->
    IFEND;
    data_line.line := ' ';
    data_line.first_part.name_2a := 'vmcl';
    clp$convert_integer_to_rjstring (register_1_p^.number_1, 16, FALSE, '0', data_line.first_part.number_2a,
          ignore_status);
    data_line.first_part.name_2b := 'kypt';
    clp$convert_integer_to_rjstring (register_1_p^.number_2, 16, FALSE, '0', data_line.first_part.number_2b,
          ignore_status);
    data_line.name_part := 'buff';
    clp$convert_integer_to_rjstring (register_1_p^.number_3, 16, FALSE, '0', data_line.number_1,
          ignore_status);
    clp$convert_integer_to_rjstring (register_1_p^.number_4, 16, FALSE, '0', data_line.number_2,
          ignore_status);
    clp$put_display (display_control, data_line.line, clc$trim, ignore_status);
    clp$put_display (display_control, ' ', clc$trim, ignore_status);

    FOR index := 0 TO 3 DO
      NEXT register_1_p IN restart_file_seq_p;
      IF register_1_p = NIL THEN
        RETURN;  {---->
      IFEND;
      data_line.line := ' ';
      data_line.first_part.name_1 := 'tempX';
      register_line.line := ' ';
      register_line.name_part := 'reg XX:';
      clp$convert_integer_to_rjstring (index, 16, FALSE, '0', data_line.first_part.name_1 (5),
            ignore_status);
      clp$convert_integer_to_rjstring (register_1_p^.number_1, 16, FALSE, '0', data_line.first_part.number_1a,
            ignore_status);
      clp$convert_integer_to_rjstring (register_1_p^.number_2, 16, FALSE, '0', data_line.first_part.number_1b,
            ignore_status);
      data_line.name_part := 'buff';
      clp$convert_integer_to_rjstring (register_1_p^.number_3, 16, FALSE, '0', data_line.number_1,
            ignore_status);
      clp$convert_integer_to_rjstring (register_1_p^.number_4, 16, FALSE, '0', data_line.number_2,
            ignore_status);
      clp$put_display (display_control, data_line.line, clc$trim, ignore_status);
    FOREND;

    NEXT register_1_p IN restart_file_seq_p;
    IF register_1_p = NIL THEN
      RETURN;  {---->
    IFEND;
    register_line.line := ' ';
    register_line.name_part := 'p-buff ';
    clp$convert_integer_to_rjstring (register_1_p^.number_1, 16, FALSE, '0', register_line.number_1,
          ignore_status);
    clp$convert_integer_to_rjstring (register_1_p^.number_2, 16, FALSE, '0', register_line.number_2,
          ignore_status);
    clp$convert_integer_to_rjstring (register_1_p^.number_3, 16, FALSE, '0', register_line.number_3,
          ignore_status);
    clp$convert_integer_to_rjstring (register_1_p^.number_4, 16, FALSE, '0', register_line.number_4,
          ignore_status);
    clp$put_display (display_control, register_line.line, clc$trim, ignore_status);

  PROCEND display_data;
?? OLDTITLE ??
?? NEWTITLE := 'dup$display_s0_register_file', EJECT ??

{ PURPOSE:
{   This procedure displays the information from the S0 records: RFP, RFS, RF1, RS1.

  PROCEDURE [XDCL] dup$display_s0_register_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_s0_register_file, dissrf (
{   output, o: file = $optional
{   title, t: string 1..31 = 'display_s0_register_file'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??
  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (26),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 4, 16, 9, 51, 37, 909],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TITLE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 26],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''display_s0_register_file'''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$title = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      data_displayed: boolean,
      data_value: clt$data_value,
      display_control: clt$display_control,
      entry_p: ^dut$de_other_record_entry,
      ignore_status: ost$status,
      index: 1 .. 8,
      output_display_opened: boolean,
      ring_attributes: amt$ring_attributes;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

      { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        display_control := duv$execution_environment.output_file.display_control;
        display_control.line_number := display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      data_displayed := FALSE;

      data_value.kind := clc$name;
      data_value.name_value := 'RFP';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p <> NIL THEN
        data_displayed := TRUE;
        clp$put_display (display_control, ' ', clc$trim, ignore_status);
        clp$put_display (display_control, ' DUMP RECORD =  RFP', clc$trim, ignore_status);
        clp$put_display (display_control, ' ', clc$trim, ignore_status);
        display_data (entry_p^, display_control);
      IFEND;

      data_value.kind := clc$name;
      data_value.name_value := 'RFS';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p <> NIL THEN
        data_displayed := TRUE;
        clp$put_display (display_control, ' ', clc$trim, ignore_status);
        clp$put_display (display_control, ' ', clc$trim, ignore_status);
        clp$put_display (display_control, ' DUMP RECORD =  RFS', clc$trim, ignore_status);
        clp$put_display (display_control, ' ', clc$trim, ignore_status);
        display_data (entry_p^, display_control);
      IFEND;

      data_value.kind := clc$name;
      data_value.name_value := 'RF1';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p <> NIL THEN
        data_displayed := TRUE;
        clp$put_display (display_control, ' ', clc$trim, ignore_status);
        clp$put_display (display_control, ' ', clc$trim, ignore_status);
        clp$put_display (display_control, ' DUMP RECORD =  RF1', clc$trim, ignore_status);
        clp$put_display (display_control, ' ', clc$trim, ignore_status);
        display_data (entry_p^, display_control);
      IFEND;

      data_value.kind := clc$name;
      data_value.name_value := 'RS1';
      dup$find_record_list_entry (data_value, entry_p);
      IF entry_p <> NIL THEN
        data_displayed := TRUE;
        clp$put_display (display_control, ' ', clc$trim, ignore_status);
        clp$put_display (display_control, ' ', clc$trim, ignore_status);
        clp$put_display (display_control, ' DUMP RECORD =  RS1', clc$trim, ignore_status);
        clp$put_display (display_control, ' ', clc$trim, ignore_status);
        display_data (entry_p^, display_control);
      IFEND;

      IF NOT data_displayed THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,
              'The RFP/RF1 and RFS/RS1 records are', status);
      IFEND;

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$display_s0_register_file;
MODEND dum$display_s0_register_file;
*DECK DECK=DUM$DISPLAY_SDT_ENTRY EXPAND=TRUE
PROC dum$DISPLAY_SDT_ENTRY display_sdt_entry, dissdte, dissdt (
  sn        : integer -281474976710655..281474976710655 = $required
  output, o : file = $output
  )

  crev (sdto, sdtl, junk)
  crev v$xcb_pva s=xref
  fetch_field_info ost$execution_control_block field=sdtp sdto junk
  sdto = sdto / 8
  fetch_field_info mmt$segment_descriptor field=mmt$segment_descriptor junk sdtl
  sdtl = sdtl / 8
  rsdtl = $mem(v$xcb_pva+sdto+14, 4)
  IF sdtl <> rsdtl THEN
    putl ' Field lengths disagree: '//$strrep(sdtl)//' - '//$strrep(rsdtl)
    EXIT_PROC
  IFEND
  psdte = $mem(v$xcb_pva+sdto) + ($value(sn) * sdtl)
  oo = $string($value(output)) // '.$eoi'
  putl ' ----- SDT  Entry '//$strrep($value(sn), 16) o=$fname(oo)
  mmt$segment_descriptor psdte o=$value(output)

PROCEND dum$display_sdt_entry
*DECK DECK=DUM$DISPLAY_SDT_EXTENDED_ENTRY EXPAND=TRUE
PROC dum$DISPLAY_SDT_EXTENDED_ENTRY display_sdt_extended_entry, dissdtee, dissdtx (
  sn        : integer -281474976710655..281474976710655 = $required
  output, o : file = $output
  )

  crev (sdtxo, sdtxl, junk)
  crev v$xcb_pva s=xref
  fetch_field_info ost$execution_control_block field=sdtx_p sdtxo junk
  sdtxo = sdtxo / 8
  fetch_field_info mmt$segment_descriptor_extended field=mmt$segment_descriptor_extended junk sdtxl
  sdtxl = sdtxl / 8
  rsdtxl = $mem(v$xcb_pva+sdtxo+14, 4)
  IF sdtxl <> rsdtxl THEN
    putl ' Field lengths disagree: '//$strrep(sdtxl)//' - '//$strrep(rsdtxl)
    EXIT_PROC
  IFEND
  psdtxe = $mem(v$xcb_pva+sdtxo) + ($value(sn) * sdtxl)
  oo = $string($value(output)) // '.$eoi'
  putl ' ----- SDT-X  Entry '//$strrep($value(sn), 16) o=$fname(oo)
  mmt$segment_descriptor_extended psdtxe o=$value(output)

PROCEND dum$display_sdt_extended_entry
*DECK DECK=DUM$DISPLAY_SEGMENT EXPAND=TRUE

PROC dum$display_segment, display_segment, diss (
  segment_number, sn: integer
  bytes, b: integer = 256
  exchange, e: integer or key monitor m job j = job
  status)

  if $value_kind(exchange) = 'INTEGER' then
    rma = $value(exchange)
  elseif $substr($string($value(exchange)) 1 1) = 'M' then
    rma = $mr(mps)
  else
    rma = $mr(jps)
  ifend
  sta = $pr(sta 0 rma)
  bytes = $value(bytes)
  IF $specified(segment_number) THEN
      sn = $value(segment_number)
      segi = $mem(sta+sn*8 4 0 0 rma)
      IF segi <> 0 THEN
        segl = $strrep(segi+100000000(16) 16)
        snd = $strrep(sn 10)
        snd = $substr(' ' 1 4-$strlen(snd)) // snd
        snh = $strrep(sn 16)
        snh = $substr(' ' 1 4-$strlen(snh)) // snh
        disv snd//snh//'   '//$substr(segl 2 2)//'  r=('//$substr(segl 4 1)//' '//$substr(segl 5 1)//')  asid='//$substr(segl 6 4)
        asti = $mem(6+sta+sn*8 2 0 0 rma)
        disv ' ast index '//$strrep(asti 16)//'(16)'
        segi = $mem(sta+sn*8 1 0 0 rma)
        segl = $strrep(segi 2)
        segl = $substr('00000000' 1 8-$strlen(segl))//segl
        vl = $integer($substr(segl 1 2)//'(2)')
        xp = $integer($substr(segl 3 2)//'(2)')
        rp = $integer($substr(segl 5 2)//'(2)')
        wp = $integer($substr(segl 7 2)//'(2)')
        create_variables (vls xps rps wps) k=string d=0..3
        vls(0) = 'invalid entry'
        vls(1) = '(reserved)'
        vls(2) = 'regular segment'
        vls(3) = 'cache by-pass segment'
        xps(0) = 'nonexecutable segment'
        xps(1) = 'nonprivileged executable segment'
        xps(2) = 'local privileged executable segment'
        xps(3) = 'global privileged executable segment'
        rps(0) = 'nonreadable segment'
        rps(1) = 'read controlled by key/lock'
        rps(2) = 'read not controlled by key/lock'
        rps(3) = 'binding section segment - read not controlled by key/lock'
        wps(0) = 'nonwritable segment'
        wps(1) = 'write controlled by key/lock'
        wps(2) = 'write not controlled by key/lock'
        wps(3) = '(reserved)'
        putl ' vl = '//vls(vl)
        putl ' xp = '//xps(xp)
        putl ' rp = '//rps(rp)
        putl ' wp = '//wps(wp)
      IFEND
    dism a=sn*100000000(16) b=$value(bytes) e=rma
  ELSE
    words = bytes
    IF NOT $specified(bytes) THEN
      words = $mem(rma+128 2 rma 0 rma)
    IFEND
    FOR i = 0 TO words - 1 DO
      segi = $mem(sta+i*8 4 0 0 rma)
      IF segi <> 0 THEN
        segl = $strrep(segi+100000000(16) 16)
        snd = $strrep(i 10)
        snd = $substr(' ' 1 4-$strlen(snd)) // snd
        snh = $strrep(i 16)
        snh = $substr(' ' 1 4-$strlen(snh)) // snh
        disv snd//snh//'   '//$substr(segl 2 2)//'  r=('//$substr(segl 4 1)//' '//$substr(segl 5 1)//')  asid='//$substr(segl 6 4)
      IFEND
    FOREND
  IFEND

PROCEND dum$display_segment
*DECK DECK=DUM$DISPLAY_SEGMENT_TABLE_ENT EXPAND=TRUE

PROC dum$display_segment_table_ent, display_segment_table_ent, disseg (
  segment_number, sn: integer 0 .. 4095 = $required
  output, o: file = $output
  status)

  crev s k=status
  IF $file($value(output) open_position) = '$BOI' THEN
    rewind_file $value(output) status=s
    output_file = $string($value(output)) // '.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

 "!!! replace with xcb_offset = $process_register(bc) when supported in ANAD"
  jps = $maintenance_register(jps)
  xcb_offset = $mod(jps 2048)
  WHILE $rma(300000000(16)+xcb_offset) <> jps
    xcb_offset = xcb_offset + 2048
  WHILEND

  crev field_len integer
  crev field_off integer
"Constants:
  ost$execution_control_block field=sdt_offset offset=field_off length=field_len
  sdt_offset= field_off/8
  ost$execution_control_block field=sdtx_offset offset=field_off length=field_len
  xcb = 300000000(16)+xcb_offset
  sdtx_offset= field_off/8
  sdtx_length= $mem($sa(mmv$sdtx_entry_size) 8)
  sdt = 300000000(16)+$mem(xcb+sdt_offset 4)
  sdtx = 300000000(16)+$mem(xcb+sdtx_offset 4)

  dism sn*8+sdt 8 o=$fname(output_file)
  dism sn*sdtx_length+sdtx sdtx_length o=$fname(output_file)
  mmt$segment_descriptor_extended sn*sdtx_length+sdtx o=$fname(output_file)

PROCEND dum$display_segment_table_ent
*DECK DECK=DUM$DISPLAY_SEGMENT_TABLE_ENTRY EXPAND=TRUE
PROCEDURE dum$display_segment_table_entry, display_segment_table_entry, disste  (
  segment_number, sn: any of
     key
       all
     keyend
     integer 0 .. 4096
    anyend = $required
   display_option, do: key
     (sdtx)
     (sdt)
      all
   keyend = all
   output, o: file = $output
   status)
 " This procedure displays segment table entry using RJT's new dump analyzer
 " this requires tmm$dispatcher added to debug tables

  set_file_attributes output fc=legible pf=continuous pw=78
   current = $current_module
   chadm tmm$dispatcher
   xcb = 0
   dum$get_xcb xcb
   IF $generic_type(segment_number) = 'KEY' then
      " all "
    IF (display_option = all) or  (display_option =sdt) THEN
      dispv ?xcb.ost$execution_control_block.sdtp^.st  o=output
    IFEND
    IF (display_option = all) or  (display_option =sdtx) THEN
      dispv ?xcb.ost$execution_control_block.sdtx_p^.sdtx_table  o=output.$eoi
    IFEND
   ELSE  " Specific segment
    IF (display_option = all) or  (display_option =sdt) THEN
      dispv ?xcb.ost$execution_control_block.sdtp^.st[?segment_number]  o=output
    IFEND
    IF (display_option = all) or  (display_option =sdtx) THEN
      dispv ?xcb.ost$execution_control_block.sdtx_p^.sdtx_table[?segment_number]   o=output.$eoi
    IFEND
  IFEND
   chadm current
PROCEND dum$display_segment_table_entry
*DECK DECK=DUM$DISPLAY_SERVED_FAMILIES EXPAND=TRUE
PROCEDURE dum$display_served_families, display_served_families, dissf (
  output, o : file = $output
  status: (VAR, BY_NAME) status = $optional
  )

  " This proc displays the served family table.
  " This proc requires RJTs most recent dump analyzer.
  " The proc assumes that dfm$mtr_served_family_manager has been added.

  current_module = $default_module
  chadm dfm$mtr_served_family_manager
  crev local_status status
  IF $file(output open_position) = '$BOI' THEN
    rewind_file output status=local_status
  IFEND
  set_file_attributes output fc=legible pf=continuous
  out = output.$eoi

  IF $program_value(dfv$served_family_table_root.valid) THEN
    FOR pnter = 1 TO $pv(..
          dfv$served_family_table_root.number_of_active_pointers) DO
      FOR family = 1 TO $program_value(dfv$served_family_table_root..
.p_family_list_pointer_array^[?pnter].highest_valid_entry) DO
        disv 'Family '//$strrep(family)//' ------- ' o=out
        dispv dfv$served_family_table_root.p_family_list_pointer_array^[?..
pnter].p_served_family_list^[?family] o=out
      FOREND
    FOREND
  ELSE
    disv ' No served families' o=out
  IFEND
  chadm current_module

PROCEND dum$display_served_families
*DECK DECK=DUM$DISPLAY_SERVER_FILE_DESC EXPAND=TRUE
PROCEDURE dum$display_server_file_desc, display_server_file_desc, display_sfd (
  pva: integer = $optional
  output, o: file = $output
  display_option, do: key
      (brief, b), (full, f)
    keyend = brief
  help, h: file = $null
  status)


  "$FORMAT=OFF"
  VAR
    when_status: status
  VAREND
  "$FORMAT=ON"

  WHEN any_fault DO
    when_status = $previous_status
    putl ' Invoked DISPLAY_SFD condition handler due to the following abnormal status:'
    disv when_status
    putl ' Enter commands, "exit_proc" to abort, or "exit_proc with when_status" to abort with status'
    include_file command prompt='display_sfd_ch'
  WHENEND

  IF $specified(help) THEN
COLLECT_TEXT o=help until='HELPEND'
DISPLAY_SERVER_FILE_DESC or DISPLAY_SFD

  This procedure will display a served file's server file descriptor when
given a process virtual address to the entry.  This procedure assumes the
user has selected the correct exchange package by available analyze_dump
commands.

PARAMETERS:

PVA: integer
  This parameter passes the processor virtual address of the served file
descriptor to be displayed.  This parameter is required.

OUTPUT, O: file
  This parameter selects the file name to receive the data.  This para-
meter is defaulted to $output.  If a file name other than $output is
entered the data will be formated correctly for printer disposition and
will be sent to the file  "$asis".

DISPLAY_OPTIONS, DO: key full, f, brief, b
  This parameter selects the option of displaying the contents of memory
and the description of the selected fields (full), or the brief mode of
the descriptions only.  This parameter defaults to brief.

STATUS

WARNINGS/KNOWN DEFICIENCIES:

ERROR HANDLER
  When any fatal error is encountered a condition handler is invoked and
the following messages will appear:
 "Invoked DISPLAY_SFD condition handler due to the following abnormal status:"
 "< the error status message >"
 "Enter commands, "exit_proc" to abort, or "exit_proc with when_status"
  to abort with status"
To exit the handler enter:    "exit_proc"
To exit the handler with status, enter:   "exit_proc with when_status"

HELPEND
    EXIT_PROC
  IFEND

  IF NOT $specified(pva) THEN
    EXIT_PROC WITH $status(false, 'US', 6, 'Parameter PVA is required')
  IFEND

  "$FORMAT=OFF"
  VAR
    output_file: file

" The following offsets were obtained from the output of the command Display_Symbol_Table
" for the type DFT$SERVER_DESCRIPTOR.

    server_mainframe_id_offset: integer = 0(16)
      model_number_offset: integer = 0(16)
      serial_number_offset: integer = 1(16)
    served_family_tbl_index_offset: integer = 3(16)
      pointers_index_offset: integer = 0(16)
      family_list_index_offset: integer = 1(16)
    server_lifetime_offset: integer = 5(16)
    read_write_count_offset: integer = 7(16)
    purged_offset: integer = 9(16)
    highest_offset_allocated_offset: integer = 0a(16)
    bytes_per_allocation_offset: integer = 10(16)
    dft$server_state: array 0..6 of string 1..$max_name = ('dfc$active', 'dfc$deactivated', 'dfc$inactive', ..
          'dfc$awaiting_recovery', 'dfc$recovering', 'dfc$terminated', 'dfc$deleted')
    file_state_offset: integer = 13(16)

" Variant for file_state = DFC$ACTIVE:

      total_allocated_length_offset: integer = 14(16)
      remote_sfid_offset: integer = 1a(16)
      allow_other_mf_write_offset: integer = 1e(16)
      allocation_info_offset: integer = 1f(16)
        server_allocation_needed_offset: integer = 0(16)

" Variant for server_allocation_needed = FALSE:

          invalid_data_offset: integer = 1(16)

" Variant for server_allocation_needed_offset = TRUE:

          bytes_to_allocate_offset: integer = 1(16)
      requested_transfer_size_offset: integer = 26(16)

" Variant for file_state = DFC$AWAITING_RECOVERY, DFC$TERMINATED: None

  VAREND
  "$FORMAT=ON"

  IF $file(output open_position) = '$BOI' THEN
    output_file = output.$asis
  ELSE
    output_file = output
  IFEND

  IF output = :$local.$output THEN
    putl '1SERVER FILE DESCRIPTOR ' o=output_file
  IFEND

  IF display_option = 'FULL' THEN
    display_memory pva bytes=29(16) t='SERVER FILE DESCRIPTOR' o=output_file
  IFEND

  start_of_sfd = pva
  putl '   ' o=output_file

  putl ' server_mainframe_id:' o=output_file
  putl '   model_number = '//..
$strrep($mem(start_of_sfd+server_mainframe_id_offset+model_number_offset, 1) 16)//'(16)' o=output_file
  putl '   serial_number = '//..
$strrep($mem(start_of_sfd+server_mainframe_id_offset+serial_number_offset, 2) 16)//'(16)' ..
        o=output_file

  putl ' served_family_table_index:' o=output_file
  putl '   pointers_index = '//..
$strrep($mem(start_of_sfd+served_family_tbl_index_offset+pointers_index_offset, 1) 16)//'(16)' ..
        o=output_file
  putl '   family_list_index = '//..
$strrep($mem(start_of_sfd+served_family_tbl_index_offset+family_list_index_offset, 1) 16)//'(16)' ..
        o=output_file

  putl ' server_lifetime = '//$strrep($mem(start_of_sfd+server_lifetime_offset 2) 16)//'(16)' ..
        o=output_file

  putl ' read_write_count = '//$strrep($mem(start_of_sfd+read_write_count_offset 2) 16)//'(16)' ..
        o=output_file

  IF $mem(start_of_sfd+purged_offset, 1) = 1 THEN
    putl ' purged = TRUE' o=output_file
  ELSE
    putl ' purged = FALSE' o=output_file
  IFEND

  putl ' highest_offset_allocated = '//..
$strrep($mem(start_of_sfd+highest_offset_allocated_offset 6) 16)//'(16)' o=output_file

  putl ' bytes_per_allocation = '//$strrep($mem(start_of_sfd+bytes_per_allocation_offset 3) 16)//'(16)' ..
        o=output_file

  file_state = dft$server_state($mem(start_of_sfd+file_state_offset 1))
  putl ' file_state = '//file_state o=output_file

  IF file_state = 'dfc$active' THEN
    putl '   total_allocated_length = '//..
$strrep($mem(start_of_sfd+total_allocated_length_offset 6) 16)//'(16)' o=output_file

    putl '   remote_sfid = '//$strrep($mem(start_of_sfd+remote_sfid_offset 4) 16)//'(16)' ..
          o=output_file

    IF $mem(start_of_sfd+allow_other_mf_write_offset, 1) = 1 THEN
      putl '   allow_other_mainframe_writer = TRUE' o=output_file
    ELSE
      putl '   allow_other_mainframe_writer = FALSE' o=output_file
    IFEND

    putl '   allocation_info:' o=output_file
    IF $mem(start_of_sfd+allocation_info_offset+server_allocation_needed_offset, 1) = 1 THEN
      putl '     server_allocation_needed = TRUE' o=output_file
      putl '       bytes_to_allocate = '//..
$strrep($mem(start_of_sfd+allocation_info_offset+bytes_to_allocate_offset, 6) 16)//'(16)' ..
            o=output_file
    ELSE
      putl '     server_allocation_needed = FALSE' o=output_file
      putl '       invalid_data = '//..
$strrep($mem(start_of_sfd+allocation_info_offset+invalid_data_offset, 6) 16)//'(16)' o=output_file
    IFEND

    putl '   requested_transfer_size = '//..
$strrep($mem(start_of_sfd+requested_transfer_size_offset 3) 16)//'(16)' o=output_file
  IFEND

PROCEND dum$display_server_file_desc
*DECK DECK=DUM$DISPLAY_SERVER_IMAGE_FILE EXPAND=TRUE

 PROCEDURE dum$display_server_image_file, display_server_image_file, dissif (
   address, a: integer 0..$max_integer = $required
   display_pages, dp: boolean = false
   ignore_header_eoi, ihe: boolean = false
   output, o: file = $output
   status)

  current = $default_module
  crev local_status status
  set_file_attributes output fc=legible pf=continuous pw=80
  chadm dfm$manage_image
  IF $file(output open_position) = '$BOI' THEN
    rewind_file output status=local_status
  IFEND
  out = output.$eoi
  dispv ?address.dft$image_header o=out
  current_nexted = 0
  page_size = $pv(?address.dft$image_header.page_size)
  IF ($pv(?address.dft$image_header.current_eoi) > page_size) ..
     OR ignore_header_eoi THEN
     p_block_header = address + page_size
     p_current_block_seq = p_block_header
     current_nexted = $pv(#size(0.dft$image_block_header))
     block_advanced = FALSE
     WHILE $offset(p_block_header) <> 0 DO
       IF NOT block_advanced THEN
         dispv ?p_block_header.dft$image_block_header o=out
       IFEND
       block_advanced = FALSE
       FOR file_count = 1 to $pv(?p_block_header.dft$image_block_header.file_count) DO
         p_file_header = p_current_block_seq + current_nexted
         dispv ?p_file_header.dft$image_file_header o=out
         current_nexted = current_nexted + $pv(#size(0.dft$image_file_header))
         FOR page_count = 1 to $pv(?p_file_header.dft$image_file_header.page_count) DO
           IF current_nexted + $pv(#size(0.dft$image_page_header)) > page_size THEN
             p_current_block_seq = address + $pv(?p_block_header.dft$image_block_header.next_block_header_offset)
             p_block_header  = p_current_block_seq
             putl ' --- Block advanced in middle of pages ----- ' o=out
             dispv ?p_block_header.dft$image_block_header o=out
             block_advanced = TRUE
             current_nexted = $pv(#size(0.dft$image_block_header))
          IFEND
          p_page_header = p_current_block_seq + current_nexted
          current_nexted = current_nexted + $pv(#size(0.dft$image_page_header))
          dispv ?p_page_header.dft$image_page_header o=out
          IF display_pages THEN
            data_address = $pv(?p_page_header.dft$image_page_header.image_offset) + address
            dism data_address page_size o=out
          IFEND
         FOREND
       FOREND
      IF NOT block_advanced THEN
        p_current_block_seq = address + $pv(?p_block_header.dft$image_block_header.next_block_header_offset)
        p_block_header  = p_current_block_seq
        current_nexted = $pv(#size(0.dft$image_block_header))
      IFEND
     WHILEND
  IFEND
 chadm current
PROCEND dum$display_server_image_file
*DECK DECK=DUM$DISPLAY_SFID EXPAND=TRUE
PROCEDURE dum$display_sfid, display_sfid, dissfid (
  sfid, s: integer = $optional
  output, o: file = $output
  display_option, do: key
      (brief, b), (full, f)
    keyend = brief
  display_depth, dd: key
      fde, all
    keyend = fde
  media, m: (VAR) string = $optional
  media_pointer, mp: (VAR) integer = $optional
  help, h: file = $null
  status)


  "$FORMAT=OFF"
  VAR
    when_status: status
  VAREND
  "$FORMAT=ON"

  WHEN any_fault DO
    when_status = $previous_status
    putl ' Invoked DISSFID condition handler due to the following abnormal status:'
    disv when_status
    putl ' Enter commands, "exit_proc" to abort, or "exit_proc with when_status" to abort with status'
    include_file command prompt='dissfid_ch'
  WHENEND

  IF $specified(help) THEN
COLLECT_TEXT o=help until='HELPEND'
DISPLAY_SFID or DISSFID

  This procedure will display the file descriptor entry for any valid sfid passed
to it.  This procedure assumes the user has previously selected the correct
exchange package by available analyze_dump commands.

PARAMETERS:

SFID, S: integer
  This parameter specifies the SFID of the file to be displayed.  This
parameter is required.

OUTPUT, O: file
  This parameter selects the file name to receive the data.  This para-
meter is defaulted to $output.  If a file name other than $output is
entered the data will be formated correctly for printer disposition and
will be sent to the file  "$asis".

DISPLAY_OPTIONS, DO: key full, f, brief, b
  This parameter selects the option of displaying the contents of memory
and the description of the selected fields (full), or the brief mode of
the descriptions only.  This parameter defaults to brief.

DISPLAY_DEPTH, DD: key fde, all
  This parameter determines the depth of the display.  If FDE is selected
only the File_Descriptor_Entry is displayed; if ALL is selected the Device
Management table structures (DFD/SFD, FMDs, FAT, FAUs) are also displayed.
This parameter defaults to FDE, and is applicable only when the CONTINUE
parameter is false.

STATUS

ADDITIONAL INFORMATION
  The SFID contains the file's index, residence, and hash.  For example,
sfid 000f014b(16) is index 000f, residence 01, hash 4b.  The residence of
01 identifies this file as residing in mainframe wired tables.  An
analyze_dump command of "CHAD e=m" will need to be entered to insure
proper execution.  If the file residence is 02, indicating the file resides
in job fixed tables, a "CHAD e=j" would need to be entered.  The "CHAPR
e=(Exchange Package RMA)" command can be used for other inactive jobs in
the system.  Of course there are many other possible combinations.

WARNINGS/KNOWN DEFICIENCIES:

ERROR HANDLER
  When any fatal error is encountered a condition handler is invoked and
the following messages will appear:
 "Invoked DISSFID condition handler due to the following abnormal status:"
 "< the error status message >"
 "Enter commands, "exit_proc" to abort, or "exit_proc with when_status"
  to abort with status"
To exit the handler enter:    "exit_proc"
To exit the handler with status, enter:   "exit_proc with when_status"

HELPEND
    EXIT_PROC
  IFEND

  IF NOT $specified(sfid) THEN
    EXIT_PROC WITH $status(false, 'US', 7, 'Parameter SFID is required')
  IFEND

  "$FORMAT=OFF"
  VAR
    file_media: string
    output_file: file
  VAREND

  IF $file(output open_position) = '$BOI' THEN
    output_file = output.$asis
  ELSE
    output_file = output
  IFEND

  "$FORMAT=OFF"
  VAR
    gfc$fde_table_base: integer = $mem($sa(gfv$fde_table_base) 8)

" The following constant is found in the deck GFC$CONSTANTS.

    gfc$fde_size: integer = $mem($sa(gfv$fde_size) 8)

    fid_index: integer = sfid/10000(16)
    fid_file_residence: integer = (sfid - fid_index*10000(16))/100(16)
    fid_file_hash: integer = $mod(sfid, 100(16))

    pftr: integer
    current_fde_entry: integer
  VAREND
  "$FORMAT=ON"

  IF fid_file_residence <> 1 THEN
    pftr = 300000000(16) "Use job tables (in job fixed)"
  ELSE
    pftr = 100000000(16) "Use system tables (in mainframe wired)"
  IFEND
  pftr = pftr + gfc$fde_table_base

  current_fde_entry = pftr + (fid_index * gfc$fde_size)

  "$FORMAT=OFF
  VAR
" The following offsets were obtained from the output of the command Display_Symbol_Table
" for the type GFT$FILE_DESCRIPTOR_ENTRY.

    job_lock_offset: integer = 0(16)
      locked_offset: integer = 0(16)
      count_offset: integer = 1(16)
      gtid_offset: integer = 2(16)
      p_register_offset: integer = 5(16)
      p_register_2_offset: integer = 0d(16)

    monitor_lock_offset: integer = 15(16)
    gft$fde_flags: array 0..7 of string 1..$max_name = ('eoi_modified' 'wire_eoi_page' 'active_file' ..
          'global_template_file' 'fde_spare_4' 'fde_spare_5' 'fde_spare_6' 'fde_spare_7')
    fde_flag_offset: integer = 16(16)
    global_name_offset: integer = 17(16)
    file_hash_thread_offset: integer = 22(16)
    attached_in_write_count_offset: integer = 28(16)
    attach_count_offset: integer = 2a(16)
    open_count_offset: integer = 2c(16)
    gft$file_kind: array 0..8 of string 1..$max_name = ('gfc$fk_job_permanent_file' 'gfc$fk_device_file' ..
          'gfc$fk_save_2' 'gfc$fk_save_3' 'gfc$fk_catalog' ..
          'gfc$fk_job_local_file' 'gfc$fk_unnamed_file' 'gfc$fk_global_unnamed' 'gfc$fk_monitor_only_unnamed')
    file_kind_offset: integer = 30(16)
    file_hash_offset: integer = 31(16)
    segment_lock_offset: integer = 32(16)
      locked_for_read_offset: integer = 0(16)
      locked_for_write_offset: integer = 4(16)
      task_queue_offset: integer = 5(16)
        task_queue_head_offset: integer = 0(16)
        task_queue_tail_offset: integer = 2(16)
    asti_offset: integer = 3b(16)
    eoi_byte_address_offset: integer = 3d(16)
    mmt$eoi_state: array 0..2 of string 1..$max_name = ('mmc$eoi_actual' 'mmc$eoi_rounded' 'mmc$eoi_uncertain')
    eoi_state_offset: integer = 43(16)
    allocation_unit_size_offset: integer = 44(16)
    transfer_unit_size_offset: integer = 47(16)
    file_limit_offset: integer = 4a(16)
    gft$queue_status: array 0..2 of string 1..$max_name = ('gfc$global_shared' 'gfc$job_shared' 'gfc$qs_job_working_set')
    queue_status_offset: integer = 50(16)
    queue_ordinal_offset: integer = 51(16)
    pmt$initialization_value: array 0..3 of string 1..$max_name = ('pmc$initialize_to_zero', ..
          'pmc$initialize_to_alt_ones' 'pmc$initialize_to_indefinite' 'pmc$initialize_to_infinity')
    preset_value_offset: integer = 52(16)
    time_last_modified_offset: integer = 53(16)
    last_segment_number_offset: integer = 59(16)
    global_task_id_offset: integer = 5b(16)
    stack_for_ring_offset: integer = 5e(16)
    gft$file_media: array 0..2 of string 1..$max_name = ('gfc$fm_transient_segment' 'gfc$fm_mass_storage_file' ..
          'gfc$fm_served_file')
    file_media_offset: integer = 5f(16)
    disk_file_descriptor_p_offset: integer = 60(16)
  VAREND
  "$FORMAT=ON"

  IF output = :$local.$output THEN
    put_line '1FILE DESCRIPTOR ENTRY   SFID = '//$strrep(sfid, 16)//' (16)' o=output_file
  IFEND

  IF display_option = 'FULL' THEN
    display_memory current_fde_entry b=gfc$fde_size ..
          title='SFID='//$strrep(sfid, 16)//'(16)' o=output_file
  IFEND

  put_line ' job_lock:' o=output_file
  put_line '   locked = '//$strrep($memory(current_fde_entry+job_lock_offset+locked_offset, 1) 16)//'(16)' ..
        o=output_file
  put_line '   count = '//$strrep($memory(current_fde_entry+job_lock_offset+count_offset, 1) 16)//'(16)' ..
        o=output_file
  put_line '   gtid = '//$strrep($memory(current_fde_entry+job_lock_offset+gtid_offset, 3) 16)//'(16)' ..
        o=output_file
  put_line '   p_register = '//$strrep($memory(current_fde_entry+job_lock_offset+p_register_offset, 8) 16)//'(16)' ..
        o=output_file
  put_line '   p_register_2 = '//$strrep($memory(current_fde_entry+job_lock_offset+p_register_2_offset, 8) 16)//'(16)' ..
        o=output_file

  monitor_lock_integer = $memory(current_fde_entry+monitor_lock_offset, 1)
  put_line ' monitor_lock {byte variant} = '//$strrep(monitor_lock_integer) o=output_file
  IF $mod(monitor_lock_integer 2) = 1 THEN
    put_line '              {lock variant}: locked = TRUE' o=output_file
  ELSE
    put_line '              {lock variant}: locked = FALSE' o=output_file
  IFEND
  put_line '              {lock variant}: id = '//$strrep(monitor_lock_integer/2) o=output_file

  line = ''
  fde_flags = $memory(current_fde_entry+fde_flag_offset, 1)
  FOR i = 56 TO 63 DO
    IF $bit(fde_flags i) THEN
      line = line // gft$fde_flags(i - 56) // ' '
    IFEND
  FOREND
  put_line ' FDE_flags = ('//line//')' o=output_file

  display_binary_unique_name pva=current_fde_entry+global_name_offset o=output cs=' global_file_name = '

  put_line ..
        ' file_hash_thread = '//$strrep($memory(current_fde_entry+file_hash_thread_offset, 6), 16)//'(16)' ..
        o=output_file

  put_line ' attached_in_write_count = '//..
$strrep($memory(current_fde_entry+attached_in_write_count_offset, 2) 16)//'(16)' o=output_file

  put_line ' attach_count = '//$strrep($memory(current_fde_entry+attach_count_offset, 2) 16)//'(16)' ..
        o=output_file

  put_line ' open_count = '//$strrep($memory(current_fde_entry+open_count_offset, 4), 16)//'(16)' ..
        o=output_file

  put_line ' file_kind = '//gft$file_kind($memory(current_fde_entry+file_kind_offset, 1)) ..
        o=output_file

  put_line ' file_hash = '//$strrep($memory(current_fde_entry+file_hash_offset, 1) 16)//'(16)' ..
        o=output_file

  put_line ' segment_lock:' o=output_file
  put_line '   locked_for_read = '//..
$strrep($memory(current_fde_entry+segment_lock_offset+locked_for_read_offset, 4) 16)//'(16)' ..
        o=output_file
  IF $memory(current_fde_entry+segment_lock_offset+locked_for_write_offset, 1) = 1 THEN
    put_line '   locked_for_write = TRUE' o=output_file
  ELSE
    put_line '   locked_for_write = FALSE' o=output_file
  IFEND
  put_line '   task_queue:' o=output_file
  put_line '     head = '//..
$strrep($memory(current_fde_entry+segment_lock_offset+task_queue_offset+task_queue_head_offset, 2) 16)//..
'(16)' o=output_file
  put_line '     tail = '//..
$strrep($memory(current_fde_entry+segment_lock_offset+task_queue_offset+task_queue_tail_offset, 2) 16)//..
'(16)' o=output_file

  put_line ' asti = '//$strrep($memory(current_fde_entry+asti_offset, 2), 16)//'(16)' o=output_file

  put_line ..
        ' eoi_byte_address = '//$strrep($memory(current_fde_entry+eoi_byte_address_offset, 6), 16)//'(16)' ..
        o=output_file

  put_line ' eoi_state = '//mmt$eoi_state($memory(current_fde_entry+eoi_state_offset, 1)) ..
        o=output_file

  put_line ' allocation_unit_size = '//..
$strrep($memory(current_fde_entry+allocation_unit_size_offset, 3), 16)//'(16)' o=output_file

  put_line ' transfer_unit_size = '//..
$strrep($memory(current_fde_entry+transfer_unit_size_offset, 3), 16)//'(16)' o=output_file

  put_line ' file_limit = '//$strrep($memory(current_fde_entry+file_limit_offset, 6), 16)//'(16)' ..
        o=output_file

  put_line ' queue_status = '//gft$queue_status($memory(current_fde_entry+queue_status_offset, 1)) ..
        o=output_file

  put_line ' queue_ordinal = '//$strrep($memory(current_fde_entry+queue_ordinal_offset, 1), 16)//'(16)' ..
        o=output_file

  put_line ' preset_value = '//pmt$initialization_value($memory(current_fde_entry+preset_value_offset, 1)) ..
        o=output_file

  put_line ' time_last_modified = '//$strrep($memory(current_fde_entry+time_last_modified_offset, 6)) ..
        o=output_file

  put_line ' last_segment_number = '//..
$strrep($memory(current_fde_entry+last_segment_number_offset, 2), 16)//'(16)' o=output_file

  put_line ' global_task_id = '//$strrep($memory(current_fde_entry+global_task_id_offset, 3), 16)//'(16)' ..
        o=output_file

  put_line ' stack_for_ring = '//$strrep($memory(current_fde_entry+stack_for_ring_offset, 1), 16)//'(16)' ..
        o=output_file

  file_media = gft$file_media($memory(current_fde_entry+file_media_offset, 1))
  put_line ' media = '//file_media o=output_file
  IF file_media = 'gfc$fm_mass_storage_file' THEN
    put_line ' disk_file_descriptor_p {relative offset} = '//..
$strrep($memory(current_fde_entry+disk_file_descriptor_p_offset, 4), 16)//'(16)' o=output_file
  ELSEIF file_media = 'gfc$fm_served_file' THEN
    put_line ' served_file_descriptor_p {relative offset} = '//..
$strrep($memory(current_fde_entry+disk_file_descriptor_p_offset, 4), 16)//'(16)' o=output_file
  IFEND

  IF $specified(media) THEN
    media = file_media
  IFEND
  IF $specified(media_pointer) THEN
    IF fid_file_residence = 1 THEN
      media_pointer = $memory(current_fde_entry+disk_file_descriptor_p_offset, 4)+100000000(16)
    ELSE
      media_pointer = $memory(current_fde_entry+disk_file_descriptor_p_offset, 4)+300000000(16)
    IFEND
  IFEND

  IF display_depth = 'FDE' THEN
    EXIT_PROC " <------- "
  IFEND

" Display the Device_Management table structures associated with the SFID.

  "$FORMAT=OFF"
  VAR
    fmd_p: integer
  VAREND
  "$FORMAT=OFF"

  IF file_media = 'gfc$fm_mass_storage_file' THEN
    put_line ' ' o=output_file
    put_line ' DISK_FILE_DESCRIPTOR: ' o=output_file
    dfd_p = current_fde_entry / 100000000(16) * 100000000(16) + $memory(current_fde_entry+disk_file_descriptor_p_offset, 4)
    display_dfd pva=dfd_p output=output display_option=display_option fmd_p=fmd_p
    put_line ' ' o=output_file
    put_line ' FILE_MEDIUM_DESCRIPTOR(s): ' o=output_file
    display_all_fmds pva=fmd_p output=output display_option=display_option
    put_line ' ' o=output_file
    put_line ' FILE_ALLOCATION_TABLE: ' o=output_file
    display_fat sfid=sfid output=output
  ELSEIF file_media = 'gfc$fm_served_file' THEN
    put_line ' ' o=output_file
    put_line ' SERVED_FILE_DESCRIPTOR: ' o=output_file
    sfd_p = current_fde_entry / 100000000(16) * 100000000(16) + $memory(current_fde_entry+disk_file_descriptor_p_offset, 4)
    display_sfd pva=sfd_p output=output display_option=display_option
  IFEND

PROCEND dum$display_sfid
*DECK DECK=DUM$DISPLAY_SOFTWARE_FLAW EXPAND=TRUE
PROCEDURE dum$display_software_flaw, display_software_flaw (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, sva, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable output_line k=string v=' '
  create_variable log_address v=$value(address)
  create_variable indent k=(string, 5) v='     '
  log_address = log_address + 1

  output_line = indent//'dau='//$strrep($mem(log_address, 3, j, 0, $value(am)), 16)
  IF ($mem(log_address+3, 1, j, 0, $value(am)) = 1) THEN
    output_line = output_line//' flaw_option= dmc$add_flaw'
  ELSE
    output_line = output_line//' flaw_option= dmc$remove_flaw'
  IFEND

  putl output_line o=$fname(output_file)

PROCEND dum$display_software_flaw
*DECK DECK=DUM$DISPLAY_STORED_FMD EXPAND=TRUE
PROCEDURE dum$display_stored_fmd, display_stored_fmd, dissfmd(
  address, a: integer = $required
  output, o: file = $output
  status)

  VAR
    header_adr: integer
    subfile_adr: integer
    subfile_base: integer
    subfile_count: integer
    subfile_size: integer
    version_adr: integer
    temp_file: file = $fname($unique)
  VAREND

  set_file_attributes file=temp_file page_format=continuous

  version_adr = address
  dispv ?version_adr.dmt$stored_ms_version_number o=temp_file
  put_line ' ' o=temp_file.$eoi

  header_adr = version_adr + 1
  dispv ?header_adr.dmt$stored_ms_fmd_header o=temp_file.$eoi
  put_line ' ' o=temp_file.$eoi

  subfile_count = $pv(?header_adr.dmt$stored_ms_fmd_header.version_0_0.number_fmds)
  subfile_base = header_adr + $pv(#size(?header_adr.dmt$stored_ms_fmd_header))
  subfile_size = $pv(#size(?subfile_base.dmt$stored_ms_fmd_subfile))

  FOR i = 1 TO subfile_count DO
    subfile_adr = subfile_base+((i-1)*subfile_size)
    dispv ?subfile_adr.dmt$stored_ms_fmd_subfile o=temp_file.$eoi
    put_line ' ' o=temp_file.$eoi
  FOREND

  copy_file i=temp_file o=output
  detach_file temp_file
PROCEND dum$display_stored_fmd
*DECK DECK=DUM$DISPLAY_SWAP_FILE_DESC EXPAND=TRUE

PROC dum$display_swap_file_desc, display_swap_file_desc, dissfd (sfd: integer = $required
  pages, p: integer
  output, o: file = $output)

  crev (junk ijll)
  jmt$initiated_job_list_entry  field=jmt$initiated_job_list_entry junk ijll
  ijle = ijll / 8
  sje = 10
  pfte = $mem($sa(mmv$pft_p)+14, 4)
  aste = $mem($sa(mmv$ast_p)+14, 4)
  misc = 9
  crev stat status
  oo = $string($value(output)) // '.$eoi'
  p = $value(sfd)
  IF $specified(pages) THEN
    pcount = $value(pages)
  ELSE
    pcount = 0
    FOR i = 2 TO 4 DO
      pcount = pcount + $mem(p+ijle+2*i 2)
    FOREND
    pcount = pcount + $mem(p+ijle+10 2)
  IFEND
  putl ' IJL entry' o=$fname(oo)
  dism p ijle o=$fname(oo)
  p = p + ijle
  putl ' SWAPPED JOB ENTRY' o=$fname(oo)
  dism p sje o=$fname(oo)
  p = p + sje
  FOR i = 1 TO pcount DO
    putl ' ' o=$fname(oo)
    putl ' Page '//$strrep(i) o=$fname(oo)
    putl '    PFT' o=$fname(oo)
    dism p pfte o=$fname(oo)
    p = p + pfte
    putl '    PTE' o=$fname(oo)
    dism p 8 o=$fname(oo)
    p = p + 8
    putl '    AST ' o=$fname(oo)
    dism p aste o=$fname(oo)
    p = p + aste
    putl '    entry_updated, old_asid, CAL (oldasid, newasid, newasti)' o=$fname(oo)
    dism p misc o=$fname(oo)
    p = p + misc
  FOREND
  EDIF $fname(oo) o=$null p=$null
    d 'segment = ' a
  END

PROCEND dum$display_swap_file_desc

*DECK DECK=DUM$DISPLAY_SWAP_TRACE_STATS EXPAND=TRUE
PROCEDURE dum$display_swap_trace_stats, display_swap_trace_stats, dissts (
  output, o: file = $output
  status)

  VAR
    input_string: string
    local_output_file: file = $fname($unique)
    local_status: status
    scratch_file: file = $fname($unique)
  VAREND

  collect_text o=scratch_file
   SWAPPING STATISTICS

   LONG WAIT AGING
 55    Long wait aging called
 56    CP aging called
 57    Total pages removed
 58    Modified pages removed
 59    Long wait aging caused task to go ready

   Job swapped out.
 76    Total jobs swapped out (job went from R -> OR) via JOB MODE
 77    Total jobs swapped out (job went from R -> OR) via MTR MODE
 67    Advance Swap changed swap direction
 63      swapout aborted - waiting for tasks to idle
 64      swapout aborted - wait states
 82      swapout aborted - direction IN noticed at idle_task_complete
 86      swapout aborted - direction IN noticed at idle_task_comp 2nd check
 88      swapout aborted - changed direction at swapped_io_complete
 89      swapout aborted - changed direction at swapout_complete
 65      swapout aborted - swapout IO was active
 17    Allocated swap file in monitor
 18      dm flag required (should not happen often)
 19      dm transient error on allocate swap file
 61    Swapout IO error at swapout_io_complete
 08    Free mm resources called during swapout
 06        .. Free mmm resources also freed SFD
100    Freed an S2 job that had been readied
107    Recalculate the swapped job entry count -- job shared pages removed
108      recalculate from S0
109      recalculate from S2


   FLUSH AM during SWAPOUT.
 13    Pages in AM flushed.
 14    Pages linked to JWS - write to disk reject
 15    Task ready after flush
 75       .. modified pages removed

   Swap in
 16    Advanced swap from R -> R (should not happen)
 78    Swapin requests made through job mode
 79    Swapin requests made through monitor mode after S0
 80    Swapin requests made through monitor mode - S0 to R
 81    Job mode swapin request got bad status on advance swap
 83    Swap in from idle_tasks_complete
 97    No ajlo, swapin_before_io--reset to swapped out
101    No ajlo, swapin_after_io--reset to swapped out
114    No ajlo, monitor swapin.

   Claim pages for swap in
 01    Claim pages failed - Insufficient memory. (Should seldom happen.)
 02    Cant reclaim job fixed ASID because reassigned.
 03    Reclaimed ASID for job fixed.
 04    Reclaimed ASID for job fixed but not still assigned.
 05    Claim pages failed - cant assign SFD pages.
 09    Claim pages failed - got pass first memory check -- now count may be wrong.

 60    Swapin IO error at swapin_io_complete
 68    Swapin IO complete discovered job should be swapped OUT
 07       .. free_mm_resources during swapin aborted
 69    No AJL ordinal at swapin time - swapin aborted.

   Move avail-modified pages back to AM queue during SWAPIN.
 11    Total times procedure was called. (not called unless pages to move)
 12    Total pages moved. (modified stale pages + pages in AM queue at swapout)

   Change ASID of page during SWAPIN.
 21    Number of ASIDs changed in swap file desc (first time).
 20    Number of ASIDs changed in swap file desc again.
 22    Number of pages that had an ASID change.

   Reset job tables during SWAPIN from disk.
 24    No change in ASID.
 25    ASID change of permanent file in JWS.
 26      Modified PF page assigned new ASID during job recovery.
 27      Discarded unmodified PF page during job recovery.
 28      PF page assigned new ASID - DM has no ASID.
 29      PF page ASID reassigned - got new ASID from DM.
 30    Assign ASID for local file.
 31    Reuse ASID for local file.
 32    Page table entry made successfully.
 33    Page table full on attempt to make entry in page table.
 34      page table full processing failed.
 35      Changed ASID as result of page table full.
 36    Page table entry exists - Discard PF page on swapin - another job read it in while job swapped.
 37    Page table entry exists in available modified for a local file.
 38    Page table entry exists in available queue for a local file.
 39    Page table entry exists in swapped error queue for a local file.
 46    Page table full reassigned job fixed asid.

   Reset sdt and xcb tables during SWAPIN.
 40 Template ASIDs changed while job swapped.
 41 Job ASIDs changed while job swapped.
 42 Global ASIDs changed while job swapped.
 43 Total XCBs scanned during SDT updates.
 44   ASIDs need to be fixed.
 45 Fix template asid.
 47 Fix job fixed asid.
 48 Fix permanent file asid.
 49 Zero out permanent file asid.

 53   Swapins after job recovery.
 54   Reset tables zeroed out an ASID in a segment table.

 85 Could not reclaim ASID of non-pageable segment on swapin.

   SWAPPING IO
 10 IO - reject from iop$pager_io for swapin/swapout IO.

   SWAPPING DFT

 90 IO error at swapin init (resource claimed).
 91 IO error at swapout io init.
 93 Disk down at swapout io complete.
 94 Disk down at swapin io complete.
103 Advance from CANNOT init io.

104 Page queue counts different at job_io_complete.
105 Advance swap from job allocate swap file.
106 Advance swap from swapped io cannot init.

   DUMP SHARED QUEUE

 95 Abort swap at allocate sfd.
 96 Advance from wait allocate sfd.
 98 Dump shared queue for sfd.
 99 Dump shared queue to claim pages.

 87 Reserve memory request failed.
110 Pages relinked to job io error queue from swapped error queue.
111 IO errors and memory freed.
112   Pages that had M bit reset.
113 IO error on an initial write.

115 Failed to find an S2 job to free for memory.
116 Reset mmv$reassignable_page_frames.now

117 Age before swap tried.
118 Number of pages freed by aging.
119 Aging freed enough pages.  Do not continue swapout.

    UNUSED entries. A non-zero count indicates a need to update the procedure.
 23 unused
 50 unused
 51 unused
 52 unused
 62 unused
 66 unused
 70 unused
 71 unused
 72 unused
 73 unused
 74 unused
 75 unused
 84 unused
 85 unused
 92 unused
102 unused

zzz
**

  rewind_file f=scratch_file
  set_file_attribute f=scratch_file op=$asis
  set_file_attribute f=local_output_file op=$asis

  accept_line v=input_string i=scratch_file

  WHILE input_string <> 'zzz' DO
    IF $substr(input_string 1 3) = ' ' THEN
      put_line l='          '//input_string o=local_output_file
    ELSE
      index = $integer($substr(input_string 1 3))
      swap_trace_value = $memory($symbol_address(jsv$swap_trace)+index*8 8)
      sj = '           ' // $strrep(swap_trace_value)
      sk = '    '//$strrep(index)
      sk = $substr(sk $strlen(sk)-3 4)
      output_line = $substr(sj $strlen(sj)-9 10)//sk//'   '//$substr(input_string 4 $strlen(input_string)-3)
      put_line l=output_line o=local_output_file
    IFEND
    accept_line v=input_string i=scratch_file
  WHILEND
  copy_file i=local_output_file.$boi o=output
  delete_file f=scratch_file
  delete_file f=local_output_file

PROCEND dum$display_swap_trace_stats
*DECK DECK=DUM$DISPLAY_SWAP_TRANSITIONS EXPAND=TRUE

PROC dum$display_swap_transitions, display_swap_transitions, disst (output, o: file = $output)

  crev stat status
  crev id (string 30) d=0..26
  id(00) = '     NULL                    '
  id(01) = ' R - EXECUTING               '
  id(02) = 'TI - IDLE_TASKS_INITIATED    '
  id(03) = 'TJ - JOB_IDLE_TASKS_COMPLETE '
  id(04) = 'S0 - SWAPPED_NO_IO           '
  id(05) = 'FA - FLUSH_AM_PAGES          '
  id(06) = 'AJ - JOB_ALLOCATE_SWAP_FILE  '
  id(07) = 'AW - WAIT_ALLOCATE_SWAP_FILE '
  id(08) = 'AF - ALLOCATE_SWAP_FILE      '
  id(09) = 'JW - WAIT_JOB_IO_COMPLETE    '
  id(10) = 'JC - JOB_IO_COMPLETE         '
  id(11) = 'DW - WAIT_ALLOCATE_SFD       '
  id(12) = 'AD - ALLOCATE_SFD            '
  id(13) = 'SD - SWAPPED_IO_CANNOT_INIT  '
  id(14) = 'OS - INITIATE_SWAPOUT_IO     '
  id(15) = 'OW - WAIT_SWAPOUT_IO_INIT    '
  id(16) = 'OI - SWAPOUT_IO_INITIATED    '
  id(17) = 'OC - SWAPOUT_IO_COMPLETE     '
  id(18) = 'S2 - SWAPPED_IO_COMPLETE     '
  id(19) = 'FM - FREE_SWAPPED_MEMORY     '
  id(20) = ' S - SWAPOUT_COMPLETE        '
  id(21) = 'IR - SWAPIN_REQUESTED        '
  id(22) = 'IS - SWAPIN_RESOURCE_CLAIMED '
  id(23) = 'IW - WAIT_SWAPIN_IO_INIT     '
  id(24) = 'II - SWAPIN_IO_INITIATED     '
  id(25) = 'IC - SWAPIN_IO_COMPLETE      '
  crev in integer d=0..30 v=0
  crev out integer d=0..30 v=0
  oo = $string($value(output)) // '.$eoi'
  b = $sa(jsv$swap_state_statistics)
  FOR f = 0 TO 25 DO
    FOR t = 0 TO 25 DO
      c = $mem(b+f*26*16+t*16+12 4)
      IF c > 0 THEN
        in(t) = in(t)+c
        out(f) = out(f)+c
        putl ' '//id(f)//'--> '//id(t)//'  '//$strrep(c) o=$fname(oo)
      IFEND
    FOREND
  FOREND
  putl ' ' o=$fname(oo)
  putl ' ' o=$fname(oo)
  FOR i = 0 TO 25 DO
    if (in(i)>0) OR (out(i)>0) then
      ic = '          '//$strrep(in(i))
      ic = $substr(ic $strlen(ic)-7 8)
      oc = '          '//$strrep(out(i))
      oc = $substr(oc $strlen(oc)-7 8)
      if in(i)=out(i) then
        dif = '.'
      else
        dif = ', difference = '//$strrep(in(i)-out(i))
      ifend
      putl ' '//id(i)//', in= '//ic//',   out = '//oc//dif o=$fname(oo)
    ifend
  FOREND

PROCEND dum$display_swap_transitions
*DECK DECK=DUM$DISPLAY_SYSTEM_FILE_TABLE EXPAND=TRUE
PROCEDURE dum$display_system_file_table, display_system_file_table, dissft (
  residence, r: key
      (system, s), (job, j)
    keyend = system
  output, o: file = $output
  help, h: file = $null
  status)

" The SFID contains the file's index, residence, and hash.  For example,
" sfid 000f014b(16) is index 000f, residence 01, hash 4b.  The residence of
" 01 identifies this file as residing in mainframe wired tables, while
" a file residence of 02 indicates the file resides in job fixed tables.

  "$FORMAT=OFF"
  VAR
    when_status: status
  VAREND
  "$FORMAT=ON"

  WHEN any_fault DO
    when_status = $previous_status
    putl ' Invoked DISSFT condition handler due to the following abnormal status:'
    disv when_status
    putl ' Enter commands, "exit_proc" to abort, or "exit_proc with when_status" to abort with status'
    include_file command prompt='dissft_ch'
  WHENEND

  IF $specified(help) THEN
COLLECT_TEXT o=help until='HELPEND'
DISPLAY_SYSTEM_FILE_TABLE or DISSFT

  This procedure will display the full system file table.  This
procedure assumes the user has previously selected the correct
exchange package by available analyze_dump commands.

PARAMETERS:

RESIDENCE, R: key job or system
  This parameter selects the residence of the table.  This parameter
defaults to "system".  NOTE: An SFID contains a file's index,
residence, and hash.  For example, sfid 000f014b(16) is index 000f,
residence 01, hash 4b.  The residence of 01 identifies this file as
residing in mainframe wired tables, while a file residence of 02
indicates the file resides in job fixed tables.

OUTPUT, O: file
  This parameter selects the file name to receive the data.  This para-
meter is defaulted to $output.  If a file name other than $output is
entered the data will be formated correctly for printer disposition and
will be sent to the file  "$asis".

STATUS

WARNINGS/KNOWN DEFICIENCIES:

ERROR HANDLER
  When any fatal error is encountered a condition handler is invoked and
the following messages will appear:
 "Invoked DISSFT condition handler due to the following abnormal status:"
 "< the error status message >"
 "Enter commands, "exit_proc" to abort, or "exit_proc with when_status"
  to abort with status"
To exit the handler enter:    "exit_proc"
To exit the handler with status, enter:   "exit_proc with when_status"

HELPEND
    EXIT_PROC
  IFEND

  "$FORMAT=OFF"
  VAR
    fde_index: integer
    file_media: (XDCL) string
    file_table_root: integer
    local_status: status
    output_file: file
    sfid: integer

" The following constant is found in the deck GFC$CONSTANTS.

    gfc$fde_size: integer = $mem($sa(gfv$fde_size) 8)

    gfc$fde_table_base: integer = $mem($sa(gfv$fde_table_base) 8)
    gfc$max_file_descriptor_index: integer = 0ffff(16) "maximum value of gft$file_descriptor_index"
  VAREND
  "$FORMAT=ON"

  IF $file(output open_position) = '$BOI' THEN
    output_file = output.$asis
  ELSE
    output_file = output
  IFEND

  IF residence = 'SYSTEM' THEN
    putl ' SYSTEM FILE TABLE ' o=output_file
    file_table_root = 100000000(16)
    resid = 1
  ELSE
    putl ' JOB - SYSTEM FILE TABLE ' o=output_file
    file_table_root = 300000000(16)
    resid = 0
  IFEND
  file_table_root = file_table_root + gfc$fde_table_base

  putl ' System File Table: '//$strrep(file_table_root, 16)//'(16)' o=output_file
  FOR fde_index = 0 TO gfc$max_file_descriptor_index DO
    putl ' ' o=output_file
    putl ' ' o=output_file

" Construct an SFID to use with Display_SFID procedure.  File_hash is not relevant.

    sfid = (fde_index * 10000(16)) + (resid * 100(16))
    putl ' FDE index '//$strrep(fde_index 16)//'(16) = SFID '//$strrep(sfid 16)//'(16) {hash irrelevant}' o=output_file
    putl ' FDE contents follows:' o=output_file
    display_sfid sfid=sfid output=output display_option=full display_depth=fde status=local_status
    IF NOT local_status.normal THEN
      disv local_status o=output_file
      putl ' Display_SFT encountered abnormal status in the call to Display_SFID:'
      disv local_status
      putl ' Enter commands, "exit_proc" to abort, or "exit_proc with local_status" to abort with status'
      include_file command prompt='dissft_ch'
    IFEND
  FOREND

PROCEND dum$display_system_file_table
*DECK DECK=DUM$DISPLAY_SYSTEM_LOG EXPAND=TRUE
PROCEDURE dum$display_system_log, display_system_log, dissl (
  log, log_segment, ls, l: any of
      key
        (system_log, system, sl)
        (job_log, job, jl)
      keyend
      integer 0..0ffff(16)
    anyend = system_log
  start, s: integer = 0
  count, c: any of
      integer
      key
        all
      keyend
    anyend = 1000
  output, o: file = $output
  status)

  "$FORMAT=OFF
  VAR
    current_size_offset: integer
    current_size_size: integer
    found_start_of_log_message: boolean
    local_status: status
    log_control_descriptor: integer
    log_control_descriptor_offset: integer
    log_control_descriptor_size: integer
    log_data: integer
    log_data_offset: integer
    log_data_size: integer
    log_data_nextt_offset: integer
    log_data_nextt_size: integer
    log_entry_header_offset: integer
    log_entry_header_size: integer
    log_ordinal: integer
  VAREND
  "$FORMAT=ON"

" If one of the keywords was specified for the log, find the log control descriptor for the specified log.
" Otherwise, the user specified the segment number of the log to be displayed.

  IF $generic_type(log) = 'KEY' THEN
    IF $string(log) = 'SYSTEM_LOG' THEN
      log_ordinal = 7
    ELSE "JOB_LOG"
      log_ordinal = 8
    IFEND

" Get the size of a log control descriptor in bytes (rounded up to a whole word).

    lgt$log_control_descriptor field=lgt$log_control_descriptor offset=log_control_descriptor_offset ..
          length=log_control_descriptor_size
    log_control_descriptor_size = (log_control_descriptor_size + 63) / 8

" If it is a global log use the global log control descriptors, otherwise use the local log descriptors.

    IF (log_ordinal >= 2) AND (log_ordinal <=7) THEN
      log_control_descriptor = $sa(lgv$global_log_ctl)+((log_ordinal-2)*log_control_descriptor_size)
    ELSE
      log_control_descriptor = $sa(lgv$local_log_ctl)+(log_ordinal*log_control_descriptor_size)
    IFEND
    found_lcd = true

" Get a pointer to the log data.

    lgt$log_control_descriptor a=log_control_descriptor field=log_data offset=log_data_offset ..
          length=log_data_size
    log_data_offset = log_data_offset / 8
    log_data = $memory(log_control_descriptor+(log_data_offset), 6)
  ELSE " number "
    found_lcd = false
    log_data = log * 100000000(16)
  IFEND

  set_file_attributes file=output fc=legible pf=continuous
  put_line line='1System Log Display' o=output.$eoi

" Report the log's starting address.  If the log starting address is NIL, quit.

  IF $nil_pva(log_data) THEN
    put_line ' the pointer to the log is nil.' o=output.$eoi
    EXIT_PROC
  ELSE
    put_line ' log starts at '//$strrep(log_data, 16) o=output.$eoi
  IFEND

" Find the starting point for the display.

  log_data = log_data + start

" If the specified pages are not available, skip forward until the first available page is found.

  include_command 'i=$memory(log_data 1)' status=local_status
  IF NOT local_status.normal THEN
    IF $condition(local_status.condition) = 'DUE$PAGE_FAULT_ERROR_SEVERITY' THEN

" Align log data to page boundary.

      page_size = $memory($symbol_address(osv$page_size) 2) * 100(16)
      log_data = log_data - $mod(log_data page_size)

" Determine where the end of the log is.  If we do not have the log control descriptor, assume 32 pages.

      IF found_lcd THEN
        cyt$sequence_pointer a=log_control_descriptor+log_data_offset field=nextt offset=log_data_nextt_offset ..
              length=log_data_nextt_size
        log_data_nextt_size = log_data_nextt_size / 8
        log_data_nextt_offset = log_data_nextt_offset / 8
        end_of_log = $memory(log_control_descriptor+log_data_offset+log_data_nextt_offset, log_data_nextt_size)
      ELSE
        end_of_log = page_size * 32
      IFEND

      REPEAT
        log_data = log_data + page_size
        include_command 'i=$memory(log_data 1)' status=local_status
      UNTIL local_status.normal OR ($offset(log_data) > end_of_log)

      IF NOT local_status.normal THEN
        put_line l=' the log is paged out.' o=output.$eoi
        EXIT_PROC WITH local_status
      ELSE
        put_line ' first page of log in memory is '//$strrep(log_data 16) o=output.$eoi
      IFEND
    ELSE
      EXIT_PROC WITH local_status
    IFEND

  IFEND

" Align log data to the start of the next log entry.

  IF $offset(log_data) <> 0 THEN
  syncronize_log: ..
    FOR i = 0 TO 256 DO
      verify_log start=log_data+i found=found_start_of_log_message recursion_level=2
      IF found_start_of_log_message THEN
        log_data = log_data + i
        EXIT syncronize_log
      IFEND
    FOREND syncronize_log
    IF NOT found_start_of_log_message THEN
      EXIT_PROC WITH $status(false, 'DU', 310)
    IFEND
  IFEND

  IF $generic_type(count) = 'KEY' THEN
    message_count = 100000000
  ELSE
    message_count = count
  IFEND

" Determine the size of the log entry header.

  lgt$log_entry_header field=lgt$log_entry_header offset=log_entry_header_offset length=log_entry_header_size
  log_entry_header_size = log_entry_header_size / 8

" Determine the size and offset of the current size field in the log entry header.

  lgt$log_entry_header field=current_size offset=current_size_offset length=current_size_size
  current_size_offset = current_size_offset / 8
  current_size_size = current_size_size / 8

" Display the log

  FOR i = 1 TO message_count DO

" Get the length of the next log entry from the log entry header.  If the length is zero, quit.

    length = $memory(log_data+current_size_offset, current_size_size)
    IF length = 0 THEN
      EXIT_PROC
    IFEND

" Get up to 255 characters from the message.

    IF length > 255 THEN
      put_line l=' '//$memory_string(log_data+log_entry_header_size, 255) o=output.$eoi
    ELSE
      put_line l=' '//$memory_string(log_data+log_entry_header_size, length) o=output.$eoi
    IFEND

" Position log data to get the next log entry.

    log_data = log_data + length + log_entry_header_size

  FOREND

PROCEND dum$display_system_log
*DECK DECK=DUM$DISPLAY_SYSTEM_TASK_DATA EXPAND=TRUE
PROCEDURE dum$display_system_task_data, display_system_task_data, disstd (output, o: file = $output
 status)

" This procedures displays the system task table.
" This required RJT's enhanced dump analyzer.
" The system job must be selected to use this proc.
" If in anad use selajl 0, if in anas it must be done from the console.

 current = $default_module()
 chadm  osm$system_task_maint_113
 dispv system_task_table  o=output
 next_pointer = $pv(system_task_table)
 WHILE NOT $nil_pva(next_pointer) DO
   putl ' ------------------------------- ' o=output.$eoi
   dispv ?next_pointer.ost$system_task_table_entry o=output.$eoi
   next_pointer = $pv(?next_pointer.ost$system_task_table_entry.next_entry)
 WHILEND
 chadm $name(current)
PROCEND dum$display_system_task_data
*DECK DECK=DUM$DISPLAY_SYSTEM_TASK_TABLE EXPAND=TRUE
PROC dum$display_system_task_table, display_system_task_table, disstt (
  display_option, do: key brief, b, full, f = brief
  output, o : file = $output
  status: var of status
  )


  out = $string($value(output)) // '.$eoi'
  crev osv$control_codes_to_quest_mark k=(string, 256) value= '????????????'//..
'???????????????????? !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijkl'//..
'mnopqrstuvwxyz{|}~????????????????????????????????????????????????????????????????????????????????'//..
'?????????????????????????????????????????????????'

  chad e=$rma(1400000100(16))
  addr = $mem($sa(osv$system_task_table_ptr) 6)
  next_task = addr
  vn = $strrep(addr 16) // '(16)'
  putl '0System_Task_Table begins at address: '//vn o=$fname(out)

  WHILE NOT $nil_pva(next_task) DO
    addr = next_task
    v = $mem(addr+72, 6)
    next_task = v
    vn = $ms(addr+0, 31)
    vn = $translate(osv$control_codes_to_quest_mark, vn)
    putl ' Task name: '//vn//', definition location = '//$strrep(addr 16)//'(16)' o=$fname(out)

    IF $substr($string($value(display_option)) 1) = 'F' THEN
      v = $mem(addr+31, 1)
      vn = $strrep(v, 16) // '(16)'
      IF v = 1 THEN
        vn = 'TRUE'
      ELSEIF v = 0 THEN
        vn = 'FALSE'
      IFEND
      putl '   Automatic restart................. '//vn o=$fname(out)

      vn = $ms(addr+32, 31)
      vn = $translate(osv$control_codes_to_quest_mark, vn)
      putl '   Starting procedure................ '//vn o=$fname(out)

      v = $mem(addr+63, 1)
      vn = $strrep(v, 16) // '(16)'
      IF v = 3 THEN
        vn = 'OSC$TT_IGNORE_OR_PROHIBITED '
      ELSEIF v = 2 THEN
        vn = 'OSC$TT_VOLUNTARY '
      ELSEIF v = 1 THEN
        vn = 'OSC$TT_SIGNAL '
      ELSEIF v = 0 THEN
        vn = 'OSC$TT_TERMINATE '
      IFEND
      putl '   Deactivate_task option............ '//vn o=$fname(out)

      v = $mem(addr+64, 1)
      vn = $strrep(v, 16) // '(16)'
      IF v = 3 THEN
        vn = 'OSC$TT_IGNORE_OR_PROHIBITED '
      ELSEIF v = 2 THEN
        vn = 'OSC$TT_VOLUNTARY '
      ELSEIF v = 1 THEN
        vn = 'OSC$TT_SIGNAL '
      ELSEIF v = 0 THEN
        vn = 'OSC$TT_TERMINATE '
      IFEND
      putl '   Idle_task option.................. '//vn o=$fname(out)

      v = $mem(addr+65, 1)
      vn = $strrep(v, 16) // '(16)'
      IF v = 1 THEN
        vn = 'TRUE'
      ELSEIF v = 0 THEN
        vn = 'FALSE'
      IFEND
      putl '   Restart after idle................ '//vn o=$fname(out)

      v = $mem(addr+66, 1)
      vn = $strrep(v, 16) // '(16)'
      IF v = 1 THEN
        vn = 'TRUE'
      ELSEIF v = 0 THEN
        vn = 'FALSE'
      IFEND
      putl '   SPI identifier specified.......... '//vn o=$fname(out)
      IF v = 1 THEN
        v = $mem(addr+67, 1)
        vn = $strrep(v, 16) // '(16)'
        putl '    SPI identifier................... '//vn o=$fname(out)
      IFEND

      v = $mem(addr+68, 1)
      vn = $strrep(v, 16) // '(16)'
      IF v = 1 THEN
        vn = 'TRUE'
      ELSEIF v = 0 THEN
        vn = 'FALSE'
      IFEND
      putl '   Currently enabled................. '//vn o=$fname(out)

      v = $mem(addr+69, 1)
      vn = $strrep(v, 16) // '(16)'
      IF v = 1 THEN
        vn = 'TRUE'
      ELSEIF v = 0 THEN
        vn = 'FALSE'
      IFEND
      putl '   Currently active.................. '//vn o=$fname(out)

      v = $mem(addr+70, 1)
      vn = $strrep(v, 16) // '(16)'
      IF v = 1 THEN
        vn = 'TRUE'
      ELSEIF v = 0 THEN
        vn = 'FALSE'
      IFEND
      putl '   Virgin_task....................... '//vn o=$fname(out)

      v = $mem(addr+71, 1)
      vn = $strrep(v, 16) // '(16)'
      putl '   Fill_0............................ '//vn o=$fname(out)

      v = $mem(addr+72, 6)
      next_task = v
      vn = $strrep(v, 16) // '(16)'
      vv = vn
      vn = vv
      putl '   Next_system_task.................. '//vn o=$fname(out)

      v = $mem(addr+78, 6)
      vn = $strrep(v, 16) // '(16)'
      vv = vn
      v = $mem(addr+84, 4)
      vn = $strrep(v, 16) // '(16)'
      vv = vv // ', size: ' // vn
      v = $mem(addr+88, 4)
      vn = $strrep(v, 16) // '(16)'
      vv = vv // ', next: ' // vn
      vn = vv
      putl '   Program_Descriptor ( ^sequence ).. '//vn o=$fname(out)

      v = $mem(addr+92, 6)
      vn = $strrep(v, 16) // '(16)'
      vv = vn
      v = $mem(addr+98, 4)
      vn = $strrep(v, 16) // '(16)'
      vv = vv // ', size: ' // vn
      v = $mem(addr+102, 4)
      vn = $strrep(v, 16) // '(16)'
      vv = vv // ', next: ' // vn
      vn = vv
      putl '   Parameters ( ^sequence ).......... '//vn o=$fname(out)

      v = $mem(addr+106, 4)
      vn = $strrep(v, 16) // '(16)'
      putl '   Task_ID........................... '//vn o=$fname(out)

      putl '   Status_at_termination:' o=$fname(out)
      v = $mem(addr+110, 1)
      vn = $strrep(v, 16) // '(16)'
      IF v = 1 THEN
        vn = 'TRUE'
      ELSEIF v = 0 THEN
        vn = 'FALSE'
      IFEND
      putl '     Complete........................ '//vn o=$fname(out)
      putl '     Status: ' o=$fname(out)
      v = $mem(addr+111, 1)
      vn = $strrep(v, 16) // '(16)'
      IF v = 1 THEN
        vn = 'TRUE'
      ELSEIF v = 0 THEN
        vn = 'FALSE'
      IFEND
      putl '       Normal........................ '//vn o=$fname(out)
      IF v = 0 THEN
        v = $mem(addr+112, 5)
        vn = $strrep(v, 16) // '(16)'
        line = '       Condition..................... ' // vn
        vn = $ms(addr+112, 2)
        line = line // ' {' // $translate(osv$control_codes_to_quest_mark, vn)
        v2 = $mem(addr+114, 3)
        vn2 = $strrep(v2, 16) // '(16)'
        line = line // '-' // vn2 // '}: ' // $condition(v2 $translate(osv$control_codes_to_quest_mark, vn))
        putl line o=$fname(out)
        v = $mem(addr+118, 2)
        vn = $strrep(v, 16) // '(16)'
        putl '       Text: ' o=$fname(out)
        putl '         Size........................ '//vn o=$fname(out)
        vn = '...'
        putl '         Value: '//vn o=$fname(out)
        vn = $ms(addr+120, v)
        putl $translate(osv$control_codes_to_quest_mark, vn) o=$fname(out)
        v = 0
      IFEND
      putl ' ' o=$fname(out)
    IFEND
  WHILEND
  chad e=m

PROCEND dum$display_system_task_table
*DECK DECK=DUM$DISPLAY_TASK_ENVIRONMENT EXPAND=TRUE
PROCEDURE dum$display_task_environment display_task_environment, diste (
  output, o: file = $output
  status)

  VAR
    gtid: integer
    gtid_length: integer
    gtid_offset: integer
    link_length: integer
    link_offset: integer
    local_status: status
    output_file: file
    save_length: integer
    save_offset: integer
    xcb_p: integer
  VAREND

  IF $file(output open_position) = '$BOI' THEN
    delete_file f=output status=local_status
    set_file_attributes f=output fc=list
  IFEND
  output_file = output.$eoi

  put_line l='1COMMAND: DISPLAY_TASK_ENVIRONMENT' o=output_file
  put_line l=' ' o=output_file

  xcb_p = $memory($symbol_address(job_xcb_list), 6)

  fetch_field_info t=ost$execution_control_block f=GLOBAL_TASK_ID o=gtid_offset l=gtid_length
  fetch_field_info t=ost$execution_control_block f=LINK o=link_offset l=link_length
  fetch_field_info t=ost$execution_control_block f=SAVE9 o=save_offset l=save_length

  link_offset = link_offset / 8
  link_length = link_length / 8
  gtid_offset = gtid_offset / 8
  gtid_length = gtid_length / 8
  save_offset = save_offset / 8
  save_length = save_length / 8

  WHILE NOT $nil_pva(xcb_p) DO
    gtid = $memory(xcb_p+gtid_offset, gtid_length)
    line =' Address: '//$strrep(xcb_p, 16)//' Gtid: '//$strrep(gtid, 16)
    line = line//' Name: '//$ms(xcb_p+save_offset, save_length)
    put_line l=line o=output_file
    xcb_p = $memory(xcb_p+link_offset, link_length)
  WHILEND

PROCEND dum$display_task_environment
*DECK DECK=DUM$DISPLAY_TASK_FILE_TABLE EXPAND=TRUE

PROCEDURE dum$display_task_file_table, display_task_file_table, distft (
  display_option, e, expansion, do: key
      (brief, b)
      (full, all, f)
    keyend = brief
  local_file_name, lfn: name = $optional
  output, o: file = $output
  )

  "$FORMAT=OFF"
  VAR
    number_of_entries: integer
    tft_entry_assignment: string
    "offsets & lengths
    gfi_offset: integer
    length: integer
    lfn_length: integer
    lfn_offset: integer
    offset: integer
    sfl_offset: integer
    tfte_length: integer
    "addresses
    address: integer
    tfte_address: integer
  VAREND
  "$FORMAT=ON"

  bat$task_file_entry field=bat$task_file_entry offset=offset length=length
  tfte_length = length/8

  bat$task_file_entry field=global_file_information offset=offset length=length
  gfi_offset = offset/8

  bat$task_file_entry field=system_file_label offset=offset length=length
  sfl_offset = offset/8

  bat$task_file_entry field=$name('local_file_name') offset=offset length=length
  lfn_offset = offset/8
  lfn_length = length/8

  display_value v=('DUM$DISPLAY_TASK_FILE_TABLE') o=output
  out = output.$eoi

  tft_address = $memory($symbol_address(bav$task_file_table))

  number_of_entries = $memory(($symbol_address(bav$tft_entry_assignment)+6), 2)
  tft_entry_assignment = $memory_string($memory($symbol_address(bav$tft_entry_assignment)), number_of_entries)

  FOR i = 1 TO number_of_entries DO
    IF ($substr(tft_entry_assignment, i, 1) = 'A') THEN
      tfte_address = tft_address + ((i-1)* tfte_length)
      IF (NOT $specified(lfn)) OR ($memory_string((tfte_address+lfn_offset), lfn_length) = $string(lfn)) THEN
        put_line l=('- **TASK_FILE_TABLE_ENTRY** '//$strrep(i)//'    Address = '//$strrep(tfte_address, 16))..
               o=out
        bat$task_file_entry a=tfte_address o=out
        IF display_option = $name('full') THEN
          address = $memory((tfte_address+gfi_offset))
          IF NOT $nil_pva(address) THEN
            put_line l=('0 **GLOBAL_FILE_INFORMATION**    Address = '//$strrep(address, 16)) o=out
            bat$global_file_information a=address o=out
          IFEND
          address = $memory((tfte_address+sfl_offset))
          IF NOT $nil_pva(address) THEN
            put_line l=('0 **SYSTEM_FILE_LABEL**    Address = '//$strrep(address, 16)) o=out
            fmt$system_file_label a=address o=out
          IFEND
        IFEND
      IFEND
    IFEND
  FOREND

PROCEND dum$display_task_file_table

*DECK DECK=DUM$DISPLAY_TRACE_BUFFER EXPAND=TRUE

PROC dum$display_trace_buffer, display_trace_buffer, distb (
  number_of_entries, noe: integer 1..256 = 10
  processor, p: integer 0 .. 1 = 0
  output, o: file = $output
  status)


"  The TRACE buffer is a circular buffer containing a list of
"  256 items of interest per processor:

"     0  exchange to job mode  (timestamp)
"     1  exchange from job mode  (timestamp, MCR)
"     2  trap in monitor mode  (timestamp, MCR)
"     3  EXCHANGE to NOS for EXCHREQ trap  (timestamp)
"     4  EXCHANGE back from NOS for EXCHREQ trap  (timestamp, MCR)
"     5  Taskswitch  (timestamp, new task XP RMA)

"  An entry in the trace buffer is 1 word long and contains:
"     bit 0 - 3,  trace id  Same as item number in above list
"     bit 4-31, data dependent on id  Usually MCR or XP RMA
"     bit 32-63, elapsed microseconds since last entry
"           in trace buffer

  create_variable tbe k=string dimension=0..5
  tbe(0) = 'Exchange to job mode  '
  tbe(1) = 'Exchange from job mode'
  tbe(2) = 'Trap in monitor mode  '
  tbe(3) = 'EXCHANGE to NOS       '
  tbe(4) = 'EXCHANGE back from NOS'
  tbe(5) = 'Taskswitch            '

  out=$unique
  setfa $fname(out) op=$asis
  tb = $sa(mtv$trace_buffer)
  IF $value(processor) = 1 THEN
    tb = tb + 2064
  IFEND
  tb_start = tb + 16
  tb_end = tb_start + 255 * 8
  current_position = tb_start + $mem(tb+8, 8) * 8 - 8
  IF current_position < tb_start then
    current_position = tb_end
  ifend
  number_of_entries = $value(number_of_entries)
  entry_address = current_position
  putl ' Trace Buffer Display' o=$fname(out)
  putl ' Most recent entry listed first.'   o=$fname(out)
  frc = $mem(tb+2 6)                     " current free_running_clock
  frc_upper = frc -  $mod(frc 100000000(16))

  FOR count = 1 to number_of_entries DO
    trace_id = $mem(entry_address 1) / 10(16)
    data = $mem(entry_address 4) - (trace_id*10000000(16))
    entry_address = entry_address - 8
    IF entry_address = tb_start-8  THEN
      entry_address = tb_end
    IFEND
    prev_frc = frc_upper + $mem(entry_address+4 4)
    IF prev_frc > frc THEN
      prev_frc = prev_frc - 100000000(16)
      frc_upper = frc_upper - 100000000(16)
    IFEND
    micro_seconds = frc - prev_frc
    put_line ' '//$strrep(count)//'. '//tbe(trace_id)//', data='//$strrep(data 16)//', elapsed time(us)='//$strrep( ..
      micro_seconds 16)//' f.r.clock='//$strrep(frc 16)  o=$fname(out)
    frc = prev_frc
  FOREND

  rewf $fname(out)
  chafa $fname(out) file_contents=list
  copf $fname(out) $value(output)
  delf $fname(out)

PROCEND dum$display_trace_buffer
*DECK DECK=DUM$DISPLAY_TRIM_FILE EXPAND=TRUE
PROCEDURE dum$display_trim_file, display_trim_file (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, sva, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable output_line k=string v=' '
  create_variable log_address v=$value(address)
  create_variable indent k=(string, 5) v='     '

  log_address = log_address + 1
  display_binary_unique_name log_address o=$fname(output_file) cs=indent//'gfn=' am=$value(am)
  output_line = indent//'dfl='//$strrep($mem(log_address+11, 3, j, 0, $value(am)), 16)
  output_line = output_line//' dau_adrs='//$strrep($mem(log_address+14, 3, j, 0, $value(am)), 16)
  output_line = output_line//' dau_of_fragment='//$strrep($mem(log_address+17, 3, j, 0, $value(am)), 16)
  putl output_line o=$fname(output_file)

PROCEND dum$display_trim_file
*DECK DECK=DUM$DISPLAY_UPDATE_FILE_LENGTH EXPAND=TRUE
PROCEDURE dum$display_update_file_length, display_update_file_length (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key pva, sva, keyend = sva
  status)

  IF $file($value(output) open_position) = '$BOI' THEN
    output_file = $string($value(output))//'.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND

  create_variable output_line k=string v=' '
  create_variable log_address v=$value(address)
  create_variable indent k=(string, 5) v='     '
  log_address = log_address + 1

  display_binary_unique_name log_address o=$fname(output_file) cs=indent//'gfn=' am=$value(am)
  output_line = indent//'dfl='//$strrep($mem(log_address+11, 3, j, 0, $value(am)), 16)

  IF ($mem(log_address+14, 1, j, 0, $value(am)) <> 0) THEN
    output_line = output_line//' eof='//$strrep($mem(log_address+15, 6, j, 0, $value(am)), 16)
  IFEND

  IF ($mem(log_address+21, 1, j, 0, $value(am)) <> 0) THEN
    output_line = output_line//' eoi='//$strrep($mem(log_address+22, 6, j, 0, $value(am)), 16)
  IFEND

  putl output_line o=$fname(output_file)

PROCEND dum$display_update_file_length
*DECK DECK=DUM$DISPLAY_UPDATE_FMD_LENGTH EXPAND=TRUE
PROCEDURE dum$display_update_fmd_length, display_update_fmd_length (
  address, a: integer = $required
  output, o: file = $output
  address_mode, am: key
      pva, sva
    keyend = sva
  status)

  "$FORMAT=OFF"
  VAR
    indent: string 5 = '     '
    log_address: integer = address
    output_file: file
    output_line: string = ' '
  VAREND
  "$FORMAT=ON"

  IF $file(output open_position) = '$BOI' THEN
    output_file = output.$asis
  ELSE
    output_file = output
  IFEND

  log_address = log_address + 1

  display_binary_unique_name log_address o=output_file cs=indent//'gfn = ' am=address_mode
  output_line = indent//'dfl = '//$strrep($mem(log_address+11, 3, job, 0, address_mode), 16)//'(16)'

  IF $mem(log_address+14, 1, job, 0, address_mode) <> 0 THEN
    output_line = output_line//', fmd_length = '//..
$strrep($mem(log_address+15, 6, job, 0, address_mode), 16)//'(16)'
  IFEND

  IF $mem(log_address+21, 1, job, 0, address_mode) <> 0 THEN
    output_line = output_line//', logical_length = '//..
$strrep($mem(log_address+22, 6, job, 0, address_mode), 16)//'(16)'
  IFEND

  putl output_line o=output_file

PROCEND dum$display_update_fmd_length
*DECK DECK=DUM$DISPLAY_VARIABLE EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
MODULE dum$display_variable;
?? PUSH (LISTEXT := ON) ??
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$count_list_elements
*copyc clp$evaluate_expression
*copyc clp$evaluate_parameters
*copyc clp$evaluate_token
*copyc clp$get_variable
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clt$data_value
*copyc clt$string_value
*copyc clt$work_area
*copyc cyd$cybil_structure_definitions
*copyc due$symbolic_access_exceptions
*copyc dup$build_home_spec
*copyc dup$build_variable_spec
*copyc dup$close_display
*copyc dup$display_all_names
*copyc dup$display_string
*copyc dup$find_module_table_for_pva
*copyc dup$find_procedure_for_pva
*copyc dup$get_bytes
*copyc dup$locate_next_symbol
*copyc dup$locate_symbol_for_number
*copyc dup$locate_variable_symbol
*copyc dup$open_display
*copyc dup$simulate_variable
*copyc dut$display_type
*copyc dut$variable_search_options
*copyc dut$variable_specification
*copyc i#compare_collated
*copyc i#current_sequence_position
*copyc osp$append_status_integer
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc osv$lower_to_upper
*copyc pmp$continue_to_cause
*copyc pmp$convert_binary_unique_name
*copyc pmp$establish_condition_handler
?? POP ??
?? NEWTITLE := 'Global Definitions', EJECT ??
  CONST
    max_name_parameter_length = 4095,
    max_string_size = 65535,
    smallest_graphic = ' ',
    largest_graphic = '~',
    max_set_element = 32767,
    value_spacer = 2,
    record_indent = 2,
    first_character = 0,
    last_character = 255,
    true_value = 1,
    false_value = 0,
    bytes_per_word = 8,
    bits_per_byte = 8;

  TYPE
    string_list = array [1 .. *] of ^clt$string_value;

  TYPE
    iindex = 0 .. max_name_parameter_length + 1;

  TYPE
    ptr_pva_conversion = record
      case boolean of

      = true =
        cell_ptr: ^cell,

      = false =
        pva: ost$pva,
      casend,
    recend;

  TYPE
    value_record = record
      case boolean of
      = TRUE =
        bits: packed array [0 .. 63] of boolean,
      = FALSE =
        word_sized_value: integer,
      casend,
    recend,

    string_descriptor = record
      pva: ost$pva,
      length: 0..0FFFF(16)
    recend;

  VAR
    delay_change_of_type: SET OF llt$entry_kind := [llc$cybil_array_kind,
      llc$pascal_conf_array_kind ];

  VAR
    v$name_stack: SEQ (REP clc$max_string_size OF char),
    v$p_name_stack: ^SEQ (*) := ^v$name_stack;

  VAR
    v$work_area: SEQ (REP clc$max_string_size OF char);

  CONST
    reserved_stack_space = bytes_per_word * 2,
    right_justified_offset = 2;

  VAR
    simple_types: SET OF llt$entry_kind := [
          llc$integer_kind, llc$boolean_kind, llc$char_kind, llc$cell_kind ],
    scan_options: clt$token_evaluation_options := $clt$token_evaluation_options[
                                   clc$ignore_spaces_before_token,
                                   clc$classify_name_token,
                                   clc$international_char_is_token];

  VAR
    powers_of_two: [STATIC, READ] array [0 .. 62] of integer := [1, 2, 4, 8, 10(16), 20(16), 40(16), 80(16),
      100(16), 200(16), 400(16), 800(16), 1000(16), 2000(16), 4000(16), 8000(16), 10000(16), 20000(16),
      40000(16), 80000(16), 100000(16), 200000(16), 400000(16), 800000(16), 1000000(16), 2000000(16),
      4000000(16), 8000000(16), 10000000(16), 20000000(16), 40000000(16), 80000000(16), 100000000(16),
      200000000(16), 400000000(16), 800000000(16), 1000000000(16), 2000000000(16), 4000000000(16),
      8000000000(16), 10000000000(16), 20000000000(16), 40000000000(16), 80000000000(16), 100000000000(16),
      200000000000(16), 400000000000(16), 800000000000(16), 1000000000000(16), 2000000000000(16),
      4000000000000(16), 8000000000000(16), 10000000000000(16), 20000000000000(16), 40000000000000(16),
      80000000000000(16), 100000000000000(16), 200000000000000(16), 400000000000000(16), 800000000000000(16),
      1000000000000000(16), 2000000000000000(16), 4000000000000000(16)];

{ We allow pointer arithmetic on pointers and arrays.  Adding 1 to a C pointer
{  amounts to adding 1 unit of the thing being pointed to. (that is, for a ptr
{  to integer, we will add 8 for each 1 added.

  VAR
    ptr_mod_specified: boolean,
    ptr_modification: integer;
?? TITLE := 'dup$change_variable ', EJECT ??

  PROCEDURE [XDCL] dup$change_variable (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PURPOSE: Command processor for the CHANGE_VARIABLE command.

{ PROCEDURE change_program_variable, chapv (
{   name, n: (CHECK) list of application balance_brackets = $required
{   value, v: (CHECK) list of application = $required
{   module, m: (CHECK) any of
{       program_name
{       application
{     anyend = $optional
{   procedure, p: (CHECK) any of
{       program_name
{       application
{     anyend = $optional
{   recursion_level, rl: integer 1..7ffffff(16) = 1
{   recursion_direction, rd: key
{       (backward, b)
{       (forward, f)
{     keyend = backward
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$application_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$application_type_qualifier,
        recend,
      recend,
      type3: 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$application_type_qualifier,
        recend,
      recend,
      type4: 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$application_type_qualifier,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (8),
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 23, 21, 54, 51, 877],
    clc$command, 13, 7, 2, 0, 0, 0, 7, ''], [
    ['M                              ',clc$abbreviation_entry, 3],
    ['MODULE                         ',clc$nominal_entry, 3],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['P                              ',clc$abbreviation_entry, 4],
    ['PROCEDURE                      ',clc$nominal_entry, 4],
    ['RD                             ',clc$abbreviation_entry, 6],
    ['RECURSION_DIRECTION            ',clc$nominal_entry, 6],
    ['RECURSION_LEVEL                ',clc$nominal_entry, 5],
    ['RL                             ',clc$abbreviation_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 7],
    ['V                              ',clc$abbreviation_entry, 2],
    ['VALUE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 20,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 20,
  clc$required_parameter, 0, 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 27,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 27,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 6
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 7
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [4, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$application_type], [TRUE]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [4, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$application_type], [FALSE]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$application_type, clc$program_name_type],
    FALSE, 2],
    3, [[1, 0, clc$program_name_type]],
    4, [[1, 0, clc$application_type], [FALSE]]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$application_type, clc$program_name_type],
    FALSE, 2],
    3, [[1, 0, clc$program_name_type]],
    4, [[1, 0, clc$application_type], [FALSE]]
    ],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [1, 7ffffff(16), 10],
    '1'],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BACKWARD                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FORWARD                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'backward'],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$value = 2,
      p$module = 3,
      p$procedure = 4,
      p$recursion_level = 5,
      p$recursion_direction = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

    VAR
      home_spec: dut$home_specification,
      input_modified: boolean,
      index: integer,
      length: iindex,
      module_name: pmt$program_name,
      p_name_list: ^string_list,
      p_value_list: ^string_list,
      procedure_name: pmt$program_name,
      temporary_value: [STATIC] string (max_name_parameter_length),
      temporary_index: 1 .. max_name_parameter_length + 1,
      value_count: integer,
      value_name: ^string ( * ),
      variable_name: ^string ( * );

    status.normal := TRUE;
    RESET v$p_name_stack;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_variable_name ('NAME', pvt [p$name].value, p_name_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_variable_name ('VALUE', pvt [p$value].value, p_value_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dup$process_module_parameter ('MODULE', pvt [p$module].value, module_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dup$process_module_parameter ('PROCEDURE', pvt [p$procedure].value, procedure_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dup$build_home_spec (module_name, procedure_name, pvt [p$recursion_level].value^,
          pvt [p$recursion_direction].value^, home_spec, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF home_spec.symbol_table_address = NIL THEN
      osp$set_status_abnormal (duc$symbolic_id, due$no_symbol_table_in_module, home_spec.module_item^.name,
            status);
      RETURN; {------->
    IFEND;

    IF (p_name_list = NIL) THEN
      osp$set_status_abnormal (duc$symbolic_id, due$name_parameter_missing, osc$null_name, status);
      RETURN; {------->
    IFEND;

    variable_name := p_name_list^ [1];
    value_count := UPPERBOUND (p_value_list^) - LOWERBOUND (p_value_list^) + 1;
    value_name := p_value_list^ [1];

{This code tries to take into account the fact that FTN complex constants must be entered
{as a list of real values and reconstructed into a normal-looking constant while
{minimizing the possible side-effects on other languages. 1/84

    IF ((value_count <> 1) AND (home_spec.language <> llc$fortran)) OR ((value_count > 2) AND
     (home_spec.language = llc$fortran)) THEN
      osp$set_status_abnormal (duc$symbolic_id, due$list_not_allowed, osc$null_name, status);
      return; {------->
    IFEND;

    IF value_count > 1 THEN
      temporary_value (1,1) := '(';
      temporary_index := 2;
      FOR index := 1 to value_count DO
        value_name := p_value_list^ [index];
        IF STRLENGTH (value_name^) <= (max_name_parameter_length - temporary_index) THEN
          temporary_value (temporary_index, STRLENGTH (value_name^)) := value_name^;
          temporary_index := temporary_index + STRLENGTH (value_name^);
          IF index > 1 THEN
            temporary_value (temporary_index,1) := ')';
          ELSE
            temporary_value (temporary_index, 1) := ',';
            temporary_index := temporary_index + 1;
          IFEND;
        ELSE
          osp$set_status_abnormal (duc$symbolic_id, due$value_parm_too_long, osc$null_name, status);
           return; {-------->
        IFEND;
      FOREND;
      value_name := ^temporary_value (1, temporary_index);
    IFEND;

    IF home_spec.symbol_table_address <> NIL THEN
      CASE home_spec.language OF
      = llc$basic =
        change_basic_variable (variable_name, home_spec,value_name,status);
      = llc$fortran =
        change_fortran_variable (variable_name, home_spec, value_name, status);
      = llc$cobol =
        osp$set_status_abnormal (duc$symbolic_id, due$unsupported_language, 'Cobol', status);
      ELSE
        change_cybil_variable (variable_name, home_spec, value_name, status);
      CASEND;
    IFEND;
  PROCEND dup$change_variable;
?? TITLE := 'dup$display_language_variable', EJECT ??

  PROCEDURE [XDCL] dup$display_language_variable (
        variable_name: ^string ( * );
        home_spec: dut$home_specification;
        display_type: dut$display_type;
        p_variant_selection: ^clt$data_value;
    VAR display_control_pointer: ^clt$display_control;
    VAR status: ost$status);

    VAR
      break_characters: [STATIC, READ] SET OF char := ['.', ']', '^', ')', ','],
      i: integer,
      name_index: 0 .. max_name_parameter_length,
      output_index: 0 .. max_name_parameter_length,
      output_length: 0 .. max_name_parameter_length,
      remaining_length: 0 .. max_name_parameter_length,
      type_specified: boolean,
      value_index: clt$string_index,
      variable_spec: dut$variable_specification,
      working_home_spec: dut$home_specification;

    working_home_spec := home_spec;
    value_index := 1;
    CASE home_spec.language OF
    = llc$basic =
      scan_basic_variable (variable_name, working_home_spec, value_index,
                   variable_spec, status);
    = llc$fortran =
      scan_fortran_variable (variable_name, working_home_spec, value_index,
                   variable_spec, status);
    = llc$cobol =
      osp$set_status_abnormal (duc$symbolic_id, due$unsupported_language, 'Cobol', status);

    = llc$cybil, llc$obsolete_cybil,
      llc$pascal =
      scan_cybil_variable (variable_name, working_home_spec, value_index, variable_spec, status);
    = llc$the_c_language =
      scan_c_variable (variable_name, working_home_spec, value_index,
                   variable_spec, status);
    ELSE
      scan_universal_variable (variable_name, working_home_spec, variable_spec,
                   status);
    CASEND;
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
{ Format the variable name if one is given. Break it into several lines if it
{ is longer than the display width.

    IF variable_name <> NIL THEN
      name_index := 1;
      remaining_length := STRLENGTH (variable_name^);

      WHILE remaining_length > display_control_pointer^.page_width DO
        output_length := display_control_pointer^.page_width;

      /find_break_character/
        FOR output_index := output_length DOWNTO 10 DO {10 is an arbitrary
          {minimum}
          IF variable_name^ (name_index + output_index - 1) IN break_characters THEN
            output_length := output_index;
            EXIT /find_break_character/;
          IFEND;
        FOREND /find_break_character/;
        clp$put_display (display_control_pointer^, variable_name^ (name_index, output_length), clc$no_trim,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        remaining_length := remaining_length - output_length;
        name_index := name_index + output_length;
      WHILEND;

      clp$put_partial_display (display_control_pointer^, variable_name^ (name_index, remaining_length),
            clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_partial_display (display_control_pointer^, ' = ', clc$no_trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF (display_type = duc$hex_type) THEN
      display_variable_in_hex (variable_spec, display_control_pointer, status);
      RETURN;
    IFEND;

    CASE working_home_spec.language OF
    = llc$fortran =
      display_fortran_variable (working_home_spec, variable_spec, variable_name,
                     0, display_type, display_control_pointer, status);
    = llc$cobol =
      osp$set_status_abnormal (duc$symbolic_id, due$unsupported_language, 'Cobol', status);
    ELSE
      format_and_display_variable (working_home_spec, variable_spec, variable_name,
            0, display_type, p_variant_selection, display_control_pointer, status);
    CASEND;

  PROCEND dup$display_language_variable;
?? TITLE := 'dup$display_variable ', EJECT ??

  PROCEDURE [XDCL] dup$display_variable (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PURPOSE: Command processor for the DISPLAY_VARIABLE command.

{ PROCEDURE display_program_variable, dispv (
{   name, n: (CHECK) any of
{       key
{         $all
{       keyend
{       list of application balance_brackets
{     anyend = $required
{   module, m: (CHECK) any of
{       program_name
{       application
{     anyend = $optional
{   procedure, p: (CHECK) any of
{       program_name
{       application
{     anyend = $optional
{   recursion_level, rl: integer 1..7ffffff(16) = 1
{   recursion_direction, rd: key
{       (backward, b)
{       (forward, f)
{     keyend = backward
{   type, t: key
{       (natural, n)
{       (hex, h)
{       (integer, i)
{       (real, r)
{     keyend = natural
{   variant_selection, vs: list of any of
{       boolean
{       name
{       integer
{       string
{     anyend = $optional
{   output, o: file = $OUTPUT
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 17] of clt$pdt_parameter_name,
      parameters: array [1 .. 9] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$application_type_qualifier,
          recend,
        recend,
      recend,
      type2: 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$application_type_qualifier,
        recend,
      recend,
      type3: 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$application_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (8),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          type_size_3: clt$type_specification_size,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          type_size_4: clt$type_specification_size,
          element_type_spec_4: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
      recend,
      type8: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type9: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 1, 6, 15, 32, 44, 983],
    clc$command, 17, 9, 1, 0, 0, 0, 9, ''], [
    ['M                              ',clc$abbreviation_entry, 2],
    ['MODULE                         ',clc$nominal_entry, 2],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 8],
    ['OUTPUT                         ',clc$nominal_entry, 8],
    ['P                              ',clc$abbreviation_entry, 3],
    ['PROCEDURE                      ',clc$nominal_entry, 3],
    ['RD                             ',clc$abbreviation_entry, 5],
    ['RECURSION_DIRECTION            ',clc$nominal_entry, 5],
    ['RECURSION_LEVEL                ',clc$nominal_entry, 4],
    ['RL                             ',clc$abbreviation_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 9],
    ['T                              ',clc$abbreviation_entry, 6],
    ['TYPE                           ',clc$nominal_entry, 6],
    ['VARIANT_SELECTION              ',clc$nominal_entry, 7],
    ['VS                             ',clc$abbreviation_entry, 7]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 84, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 27, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 27, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 6
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 7
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 80, clc$optional_parameter,
  0, 0],
{ PARAMETER 8
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 9
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    20, [[1, 0, clc$list_type], [4, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$application_type], [TRUE]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$application_type, clc$program_name_type],
    FALSE, 2],
    3, [[1, 0, clc$program_name_type]],
    4, [[1, 0, clc$application_type], [FALSE]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$application_type, clc$program_name_type],
    FALSE, 2],
    3, [[1, 0, clc$program_name_type]],
    4, [[1, 0, clc$application_type], [FALSE]]
    ],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [1, 7ffffff(16), 10],
    '1'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BACKWARD                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FORWARD                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'backward'],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [8], [
    ['H                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['HEX                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['INTEGER                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NATURAL                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['REAL                           ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ,
    'natural'],
{ PARAMETER 7
    [[1, 0, clc$list_type], [64, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$boolean_type, clc$integer_type, clc$name_type,
      clc$string_type],
      TRUE, 4],
      3, [[1, 0, clc$boolean_type]],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
      20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
      8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
      ]
    ],
{ PARAMETER 8
    [[1, 0, clc$file_type],
    '$OUTPUT'],
{ PARAMETER 9
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$module = 2,
      p$procedure = 3,
      p$recursion_level = 4,
      p$recursion_direction = 5,
      p$type = 6,
      p$variant_selection = 7,
      p$output = 8,
      p$status = 9;

    VAR
      pvt: array [1 .. 9] of clt$parameter_value;

    VAR
      display_control: clt$display_control,
      display_control_pointer: ^clt$display_control,
      display_type: dut$display_type,
      home_spec: dut$home_specification,
      index: integer,
      input_modified: boolean,
      length: iindex,
      local_status: ost$status,
      message_status: ost$status,
      module_name: pmt$program_name,
      p_name_list: ^string_list,
      p_variant_selection: ^clt$data_value,
      procedure_name: pmt$program_name,
      recursion_specified: boolean,
      status1: ost$status,
      variable_name: ^string ( * );

    input_modified := FALSE;
    status1.normal := TRUE;
    status.normal := TRUE;
    RESET v$p_name_stack;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_variable_name ('NAME', pvt [p$name].value, p_name_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dup$process_module_parameter ('MODULE', pvt [p$module].value, module_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dup$process_module_parameter ('PROCEDURE', pvt [p$procedure].value, procedure_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dup$build_home_spec (module_name, procedure_name, pvt [p$recursion_level].value^,
          pvt [p$recursion_direction].value^, home_spec, status);
    IF NOT status.normal THEN
      RETURN; {------->
    IFEND;

    display_type := duc$natural_type;

    IF (pvt [p$type].value <> NIL) THEN
      IF (pvt [p$type].value^.keyword_value = 'HEX') THEN
        display_type := duc$hex_type;
      ELSEIF (pvt [p$type].value^.keyword_value = 'INTEGER') THEN
        display_type := duc$integer_type;
      ELSEIF (pvt [p$type].value^.keyword_value = 'REAL') THEN
        display_type := duc$real_type;
      IFEND;
    IFEND;

    p_variant_selection := pvt [p$variant_selection].value;

    IF home_spec.symbol_table_address = NIL THEN
      osp$set_status_abnormal (duc$symbolic_id, due$no_symbol_table_in_module,
       home_spec.module_item^.name, status);
      RETURN; {----->
    IFEND;

    recursion_specified := pvt [p$recursion_level].specified OR pvt [p$recursion_direction].specified;

    { For BASIC, duc$natural_type and duc$hex_type are the only legal display types }

    IF (display_type <> duc$natural_type) AND (display_type <> duc$hex_type) THEN
      IF home_spec.language = llc$basic THEN
        osp$set_status_abnormal (duc$symbolic_id, due$type_equals_hex_only,
          'BASIC', status);
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$variant_selection].specified AND NOT
                             ((home_spec.language = llc$cybil) OR
                              (home_spec.language = llc$obsolete_cybil) OR
                              (home_spec.language = llc$pascal)) THEN
      osp$set_status_abnormal (duc$symbolic_id, due$invalid_parameter,
                   'VARIANT_SELECTION', status);
      RETURN; {------->
    IFEND;

{Process NAME parameter.

    IF (p_name_list = NIL) THEN
      osp$set_status_abnormal (duc$symbolic_id, due$name_parameter_missing, osc$null_name, status);
      RETURN; {----->
    ELSE

{IF name is specified, enter loop and process one by one.

      display_control_pointer := ^display_control;

      dup$open_display (pvt [p$output].value^.file_value^, display_control_pointer, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

      /display_variable_loop/
      FOR index := LOWERBOUND (p_name_list^) TO UPPERBOUND (p_name_list^) DO
        variable_name := p_name_list^ [index];

        IF (STRLENGTH (variable_name^) = 4) AND (i#compare_collated (variable_name^(1,4),
         '$ALL', osv$lower_to_upper) = 0) THEN
            dup$display_all_names (home_spec, display_type, p_variant_selection,
                  display_control_pointer, status);
        ELSE
          IF (UPPERBOUND (p_name_list^) > LOWERBOUND (p_name_list^)) THEN {multiple names}
            dup$display_language_variable (variable_name, home_spec, display_type, p_variant_selection,
              display_control_pointer, local_status);
            IF NOT local_status.normal THEN
              clp$new_display_line (display_control_pointer^, 0, status);
              dup$output_message (local_status, display_control_pointer, status);
              IF NOT status.normal THEN
                EXIT /display_variable_loop/;
              IFEND;
              osp$set_status_abnormal (duc$symbolic_id, due$errors_in_list_of_names,
                osc$null_name, status1);
            IFEND;
          ELSE {single name}
            dup$display_language_variable (variable_name, home_spec, display_type, p_variant_selection,
              display_control_pointer, status);
          IFEND;
        IFEND;
      FOREND /display_variable_loop/;
    IFEND;

    IF status.normal AND NOT status1.normal THEN
      status := status1;
    IFEND;

    dup$close_display (display_control_pointer, FALSE, local_status);
  PROCEND dup$display_variable;
?? TITLE := 'dup$output_message', EJECT ??
*copy duh$output_message

  PROCEDURE [XDCL] dup$output_message (
        status_message: ost$status;
    VAR display_control_pointer: ^clt$display_control;
    VAR status: ost$status);

    VAR
      message: ost$status_message,
      message_area: ^ost$status_message,
      message_line_count: ^ost$status_message_line_count,
      message_line_index: 1 .. osc$max_status_message_lines,
      message_line_size: ^ost$status_message_line_size,
      message_line: ^string ( * );

    osp$format_message (status_message, osc$brief_message_level, display_control_pointer^.page_width,
          message, status);
    IF NOT status.normal THEN
      RETURN;  {------>
    IFEND;
    message_area := ^message;
    RESET message_area;
    NEXT message_line_count IN message_area;
    FOR message_line_index := 1 TO message_line_count^ DO
      NEXT message_line_size IN message_area;
      NEXT message_line: [message_line_size^] IN message_area;
      clp$put_partial_display (display_control_pointer^,message_line^, clc$no_trim,
        amc$terminate, status);
      IF NOT status.normal THEN
        return; {------->
      IFEND;
    FOREND;

  PROCEND dup$output_message;
?? TITLE := 'dup$process_module_parameter', EJECT ??

  PROCEDURE [XDCL] dup$process_module_parameter (
        parameter_name: string (*);
        p_parameter_value: ^clt$data_value;
    VAR module_name: pmt$program_name;
    VAR status: ost$status);

    VAR
      p_seq: ^SEQ (*),
      p_string: ^clt$string_value,
      program_name: pmt$program_name;

    p_seq := #SEQ (program_name);

    expand_value (parameter_name, p_parameter_value, p_seq, p_string, status);

    IF status.normal THEN
      IF (p_string = NIL) THEN
        module_name := osc$null_name;
      ELSE
        module_name := p_string^;
      IFEND;
    IFEND;
  PROCEND dup$process_module_parameter;
?? TITLE := 'dup$program_value', EJECT ??

  PROCEDURE [XDCL] dup$program_value (parameter_list: clt$parameter_list;
    VAR p_work: ^clt$work_area;
    VAR p_value: ^clt$data_value;
    VAR status: ost$status);

{ FUNCTION $program_variable, $pv (
{   name: (CHECK) application balance_brackets = $required
{   module: (CHECK) any of
{       program_name
{       application
{     anyend = $optional
{   procedure: (CHECK) any of
{       program_name
{       application
{     anyend = $optional
{   recursion_level: integer 1..7ffffff(16) = 1
{   recursion_direction: key
{       (backward, b)
{       (forward, f)
{     keyend = backward
{   type: key
{       (natural, n)
{       (integer, i)
{     keyend = natural
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$application_type_qualifier,
      recend,
      type2: 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$application_type_qualifier,
        recend,
      recend,
      type3: 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$application_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (8),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (7),
      recend,
    recend := [
    [1,
    [88, 12, 22, 14, 18, 49, 432],
    clc$function, 6, 6, 1, 0, 0, 0, 0, ''], [
    ['MODULE                         ',clc$nominal_entry, 2],
    ['NAME                           ',clc$nominal_entry, 1],
    ['PROCEDURE                      ',clc$nominal_entry, 3],
    ['RECURSION_DIRECTION            ',clc$nominal_entry, 5],
    ['RECURSION_LEVEL                ',clc$nominal_entry, 4],
    ['TYPE                           ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 4, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 27, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 27, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [5, 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, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [4, 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, 155,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 6
    [6, 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, 155,
  clc$optional_default_parameter, 0, 7]],
{ PARAMETER 1
    [[1, 0, clc$application_type], [TRUE]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$application_type, clc$program_name_type],
    FALSE, 2],
    3, [[1, 0, clc$program_name_type]],
    4, [[1, 0, clc$application_type], [FALSE]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$application_type, clc$program_name_type],
    FALSE, 2],
    3, [[1, 0, clc$program_name_type]],
    4, [[1, 0, clc$application_type], [FALSE]]
    ],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [1, 7ffffff(16), 10],
    '1'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BACKWARD                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FORWARD                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'backward'],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [4], [
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['INTEGER                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NATURAL                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'natural']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$module = 2,
      p$procedure = 3,
      p$recursion_level = 4,
      p$recursion_direction = 5,
      p$type = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      display_type: dut$display_type,
      home_spec: dut$home_specification,
      input_modified: boolean,
      length: 0 .. max_name_parameter_length + 1,
      module_name: pmt$program_name,
      p_name_list: ^string_list,
      procedure_name: pmt$program_name,
      recursion_specified: boolean,
      variable_name: ^string ( * );

    RESET v$p_name_stack;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_variable_name ('NAME', pvt [p$name].value, p_name_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dup$process_module_parameter ('MODULE', pvt [p$module].value, module_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dup$process_module_parameter ('PROCEDURE', pvt [p$procedure].value, procedure_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dup$build_home_spec (module_name, procedure_name, pvt [p$recursion_level].value^,
          pvt [p$recursion_direction].value^, home_spec, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF home_spec.module_item^.debug_symbol_tables = NIL THEN
      osp$set_status_abnormal (duc$symbolic_id, due$no_symbol_table_in_module,
            home_spec.module_item^.name, status);
      RETURN;
    IFEND;

    recursion_specified := pvt [p$recursion_level].specified OR pvt [p$recursion_direction].specified;

    display_type := duc$natural_type;

    IF (pvt [p$type].value <> NIL) AND (pvt [p$type].value^.keyword_value = 'INTEGER') THEN
      display_type := duc$integer_type;
    IFEND;

    variable_name := p_name_list^ [1];

    CASE home_spec.language OF
    = llc$basic =
      get_basic_variable_value (variable_name, home_spec, p_value, status);

    = llc$cobol =
      osp$set_status_abnormal (duc$symbolic_id, due$unsupported_language, 'Cobol', status);

    = llc$fortran =
      get_fortran_variable_value (variable_name, home_spec, p_value, status);

    ELSE
      get_cybil_variable_value (variable_name, home_spec, display_type, p_work, p_value, status);
    CASEND;

  PROCEND dup$program_value;
?? TITLE := 'change_basic_variable', EJECT ??

  PROCEDURE change_basic_variable (variable_name: ^string ( * );
        home_spec: dut$home_specification;
        value_name : ^string ( * );
    VAR status: ost$status);

    osp$set_status_abnormal (duc$symbolic_id, due$unsupported_language, 'Basic', status);
  PROCEND change_basic_variable;
?? TITLE := 'change_cybil_variable', EJECT ??

  PROCEDURE change_cybil_variable (variable_name: ^string ( * );
        home_spec: dut$home_specification;
        value_name : ^string ( * );
    VAR status: ost$status);

    osp$set_status_abnormal (duc$symbolic_id, due$unsupported_language, 'Cybil', status);
  PROCEND change_cybil_variable;
?? TITLE := 'change_fortran_variable', EJECT ??

  PROCEDURE change_fortran_variable (variable_name: ^string ( * );
        home_spec: dut$home_specification;
        value_name : ^string ( * );
    VAR status: ost$status);

    osp$set_status_abnormal (duc$symbolic_id, due$unsupported_language, 'Fortran', status);
  PROCEND change_fortran_variable;
?? TITLE := 'convert_c_string', EJECT ??
{ In C, strings are really dereferenced pointers to char.  This routine is
{  called if that situation is encountered.  The end of the string is the first
{  NUL character found.

  PROCEDURE convert_c_string (
    VAR variable_spec: {input,output} dut$variable_specification;
    VAR status: ost$status);

{ In C a string is a ptr to char.  If we find a ptr to char dereferenced, we
{  artificially change it to a string using this symbol.

  VAR
    c_symbol: [STATIC] llt$symbol_table_item;

    VAR
      ch: char,
      i: integer,
      tmp_address: ost$pva;

    i := 0;
    tmp_address := variable_spec.address;
{ Find the end of string }
    REPEAT
      tmp_address.offset := variable_spec.address.offset + i;
      dup$get_bytes (tmp_address, #LOC (ch), #SIZE (ch), status);
      i := i + 1;
    UNTIL NOT status.normal OR (ch = $CHAR(0));

    variable_spec.length := i - 1;               { The string length }
    variable_spec.max_string_length := i - 1;    { The string length }
{ Setup a new string symbol to replace the old ptr to char symbol }
    variable_spec.symbol_entry.symbol := ^c_symbol;
    variable_spec.symbol_entry.symbol^.symbol_kind := llc$string_kind;

  PROCEND convert_c_string;
?? TITLE := 'convert_pva_to_hexstring', EJECT ??
{
{  The purpose of this procedure is to convert the 48 bit string of a PVA
{  into a string of 12 hex digits: 1 hex digit for ring, 3 hex digits for
{  segment, 8 hex digits for byte number. A blank space is inserted between
{  ring and segment, segment and byte number hex digits.
{  Note: The mentioned convertion is merely a string conversion, thus it is
{        irrelevant for this conversion that the leftmost bit of the byte
{        number bit string functions as sign bit of the byte number.
{
{        CONVERT_PVA_TO_HEXSTRING (PVA, HEXSTRING, STATUS)
{
{  PVA: (input) This parameter specifies the pva that is to be converted
{       to a hex string. The pva is a record of ring number, segment number,
{       and a signed byte number.
{
{  HEXSTRING: (output) This parameter specifies the hex string represented
{       in ASCII. 12 hex digits for the pva and 2 blank spaces for sepatating
{       the hex strings for ring, segment, and byte numbers. The blanks are
{       used for readability.
{
{  STATUS: (output) This parameter specifies the request status.

  PROCEDURE convert_pva_to_hexstring (pva: ost$pva;
    VAR hexstring: string (14);
    VAR status: ost$status);

    TYPE
      alternate_view_of_pva = PACKED RECORD
                                ring: 0 .. 0F(16),
                                segment: 0 .. 0FFF(16),
                                offset: 0 .. 0FFFFFFFF(16)
                              RECEND;
{
{If the number to be converted is signed (that is, leftmost bit of its internal
{bit representation is sign bit), clp$convert_integer_to_rjstring recognizes it
{and builds the result string accordingly. Thus, if the number to be
{converted is negative, the complement will be built and the result string will
{be prefixed with a negative sign character if anough space is available.
{
{The offset field of a pva can be negative (see ost$pva),therefore its internal
{representation has a sign bit. For a positive offset, clp$convert_integer_to_rjstring
{always produces the true hex string representation of the bit string, but not
{for negative offsets.
{
{To obtain a true hex string representation of negative offsets too, we introduce
{an alternate_view_of_pva type in which the offset field is only positive,
{and then we map this type into the ost$pva type using the #LOC function.
{
    VAR
      pva_ptr: ^alternate_view_of_pva;

    pva_ptr := #LOC (pva);
    clp$convert_integer_to_rjstring (pva_ptr^.ring, 16, FALSE, '0', hexstring (1,1), status);
    clp$convert_integer_to_rjstring (pva_ptr^.segment, 16, FALSE, '0', hexstring (3, 3), status);
    clp$convert_integer_to_rjstring (pva_ptr^.offset, 16, FALSE, '0',hexstring (7, 8), status);
  PROCEND convert_pva_to_hexstring;
?? TITLE := 'display_fortran_variable', EJECT ??

  PROCEDURE display_fortran_variable (home_spec: dut$home_specification;
        variable_spec: dut$variable_specification;
        variable_name: ^string ( * );
        indent_count: integer;
        display_type: dut$display_type;
    VAR display_control_pointer: ^clt$display_control;
    VAR status: ost$status);

    osp$set_status_abnormal (duc$symbolic_id, due$unsupported_language, 'Fortran', status);
  PROCEND display_fortran_variable;
?? TITLE := 'display_variable_in_hex', EJECT ??

  PROCEDURE display_variable_in_hex (
        variable_spec: dut$variable_specification;
    VAR display_control_pointer: ^clt$display_control;
    VAR status: ost$status);

    VAR
      value_length: integer,
      value_string: string (38),
      variable_length: integer;

    clp$new_display_line (display_control_pointer^, clc$next_display_line, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF variable_spec.length = 0 THEN
      IF variable_spec.symbol_entry.symbol^.symbol_kind = llc$string_kind THEN
        dup$display_string (display_control_pointer, 45, '**This variable is a string of length zero.**',
                          0, status);
      ELSE
        dup$display_string (display_control_pointer, 42, '**TYPE=HEX not valid for this data type.**',
                          0, status);
      IFEND;
      RETURN; {----->
    IFEND;
    IF variable_spec.bit_offset <> 0 THEN
      dup$display_string (display_control_pointer, 12, 'Bit offset:',
                          0, status);
      STRINGREP (value_string, value_length, variable_spec.bit_offset,
                 ', ');
      dup$display_string (display_control_pointer, value_length,
                value_string (1, value_length), 0, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    IF variable_spec.length_is_bits THEN
      variable_length := ((variable_spec.length + variable_spec.bit_offset - 1)
                                DIV byte_size) + 1;
      dup$display_string (display_control_pointer, 12, 'Bit length:',
                          0, status);
      STRINGREP (value_string, value_length, variable_spec.length,
                 ', ');
      dup$display_string (display_control_pointer, value_length,
                value_string (1, value_length), 0, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      variable_length := variable_spec.length;
    IFEND;
    format_and_display_data (variable_spec.address, variable_length,
          16, 99999999, display_control_pointer, status);

  PROCEND display_variable_in_hex;
?? TITLE := 'enable_c_globals', EJECT ??

  PROCEDURE enable_c_globals (
    VAR home_spec: dut$home_specification);

    VAR
      global_module: pmt$program_name,
      index: integer,
      p_debug_tables: ^array [0 .. *] of ^llt$debug_symbol_table,
      upper: integer;

    global_module := 'c_globals';
    IF (home_spec.symbol_table_address^.original_module_name = global_module) THEN
      RETURN; {----->           { We have already tried the global module }
    IFEND;
    p_debug_tables := home_spec.module_item^.debug_symbol_tables;
    IF (p_debug_tables = NIL) THEN
      RETURN; {----->           { No debug tables }
    IFEND;
    upper := UPPERBOUND (p_debug_tables^);
    index := 0;
    WHILE (index <= upper) AND (p_debug_tables^ [index]^.original_module_name <> global_module) DO
      index := index + 1;
    WHILEND;
    IF (index > upper) THEN
      RETURN; {----->           { global module not found }
    IFEND;
    home_spec.symbol_table_address := p_debug_tables^ [index];
    home_spec.procedure_entry.symbol := NIL;
  PROCEND enable_c_globals;
?? TITLE := 'evaluate_c_pointer', EJECT ??

  PROCEDURE evaluate_c_pointer (
        home_spec: dut$home_specification;
        working_var_name: ^string ( * );         {For error messages only}
    VAR variable_spec: {input,output} dut$variable_specification;
    VAR status: ost$status);

    VAR
      ptr_mod: integer,
      symbol_kind: llt$entry_kind;

    symbol_kind := variable_spec.symbol_entry.symbol^.symbol_kind;
    IF symbol_kind = llc$cybil_array_kind THEN
{ C arrays can be treated as pointers.  Dereferencing an array means accessing
{  an element of the array (the 1st element if there is no pointer modification
{  to do, the (n+1)th if the value of the pointer modifier is n).
      variable_spec.length := variable_spec.symbol_entry.symbol^.cybil_array_element_length;
      dup$locate_symbol_for_number (home_spec.symbol_table_address,
                  variable_spec.symbol_entry.symbol^.cybil_array_element_type,
                  variable_spec.symbol_entry, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      reduce_cybil_type (home_spec, variable_spec, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    ELSE
      IF variable_spec.symbol_entry.symbol^.symbol_kind <> llc$pointer_kind THEN
        osp$set_status_abnormal (duc$symbolic_id, due$invalid_pointer_reference, working_var_name^, status);
        RETURN; {----->
      IFEND;

{ We have a "real" pointer.  Evaluate it.

      variable_spec.address.offset := variable_spec.address.offset + 2;
      variable_spec.length := variable_spec.length - 2;
      evaluate_cybil_pointer (home_spec, working_var_name, variable_spec, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    IFEND;

{ If the user wanted to modify the pointer, do it now.

    IF ptr_mod_specified THEN
      ptr_mod := (ptr_modification * variable_spec.length);
      IF ((variable_spec.address.offset + ptr_mod) > osc$maximum_offset) OR
         ((variable_spec.address.offset + ptr_mod) < -(osc$maximum_offset - 1)) THEN
        osp$set_status_abnormal (duc$symbolic_id, due$c_ptr_mod_range_err, '', status);
        RETURN; {----->
      ELSE
        variable_spec.address.offset := variable_spec.address.offset + ptr_mod;
      IFEND;
      ptr_mod_specified := FALSE;
      ptr_modification := 0;
    ELSE

{  If we were passed an unmodified pointer to char then make it a string }

      IF symbol_kind = llc$pointer_kind THEN
        IF variable_spec.symbol_entry.symbol^.symbol_kind = llc$char_kind THEN
{ Interpret a pointer to char as a string only if the ptr is not modified.
          convert_c_string (variable_spec, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND evaluate_c_pointer;
?? TITLE := 'evaluate_c_subscript', EJECT ??

  PROCEDURE evaluate_c_subscript (
        home_spec: dut$home_specification;
        working_var_name: ^string ( * );
        parameter_value: ^string ( * );
    VAR parameter_index: {input,output} clt$string_index;
    VAR variable_spec: {input,output} dut$variable_specification;
    VAR status: ost$status);

{ If the symbol in question is an array, call evaluate_cybil_subscript.  If
{  it is a pointer to char, the subscript reference is equivalent to modifying
{  the pointer and clp$evaluate_token it.  Otherwise, diagnose the error.

    VAR
      derefs: integer,
      scan_index: clt$string_index,
      spaces_preceded_token: boolean,
      subscript_length: clt$string_size,
      symbol_entry: dut$symbol_entry,
      token: clt$lexical_token;

    IF variable_spec.symbol_entry.symbol^.symbol_kind = llc$cybil_array_kind THEN
      evaluate_cybil_subscript (home_spec, parameter_value, parameter_index, variable_spec, status);
      RETURN; {----->
    IFEND;
    IF variable_spec.symbol_entry.symbol^.symbol_kind = llc$pointer_kind THEN
      dup$locate_symbol_for_number (home_spec.symbol_table_address,
                  variable_spec.symbol_entry.symbol^.ptr_type,
                  symbol_entry, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      scan_index := 1;
      clp$evaluate_token (parameter_value^(parameter_index,*), scan_options,
            scan_index, spaces_preceded_token, token, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      find_c_subscript (parameter_value^(parameter_index, *), subscript_length);
      IF subscript_length = 0 THEN
        osp$set_status_abnormal (duc$symbolic_id, due$subscript_error, variable_spec.name, status);
        RETURN; {----->
      IFEND;
      derefs := 0;           { No dereferences wanted here }
{ Fake no dereferences since this is a fake ptr mod.  Subscripts are higher
{  precedence than dereferences.
      modify_c_pointer (home_spec, token, working_var_name,
                   ^parameter_value^(1,parameter_index + subscript_length - 1),
                   parameter_index, derefs, variable_spec, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      evaluate_c_pointer (home_spec, working_var_name, variable_spec, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
{ Update the index if the subscript was a constant.  For variable subscripts,
{  the index is taken care of in modify_c_pointer.
      IF token.kind = clc$unsigned_integer_token THEN
        parameter_index := parameter_index + scan_index - 1;
      IFEND;
    ELSE
      osp$set_status_abnormal (duc$symbolic_id, due$invalid_subscript_reference,
              working_var_name^, status);
    IFEND;

  PROCEND evaluate_c_subscript;
?? TITLE := 'evaluate_cybil_pointer', EJECT ??
{ PURPOSE: dereference a CYBIL pointer reference.

  PROCEDURE evaluate_cybil_pointer (
        home_spec: dut$home_specification;
        parameter_name: ^string ( * );
    VAR variable_spec: {input,output} dut$variable_specification;
    VAR status: ost$status);

    VAR
      pointer: ost$pva;

    IF variable_spec.symbol_entry.symbol^.symbol_kind <> llc$pointer_kind THEN
      osp$set_status_abnormal (duc$symbolic_id, due$invalid_pointer_reference, parameter_name^, status);
      RETURN;
    IFEND;

    variable_spec.descriptor_address := variable_spec.address;
    pointer := variable_spec.address;
    dup$get_bytes (pointer, #LOC (variable_spec.address), #SIZE (variable_spec.address), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    variable_spec.length := variable_spec.symbol_entry.symbol^.ptr_object_length;
    variable_spec.length_is_bits := FALSE;
    variable_spec.bit_offset := 0;
    dup$locate_symbol_for_number (home_spec.symbol_table_address,
          variable_spec.symbol_entry.symbol^.ptr_type, variable_spec.symbol_entry, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    reduce_cybil_type (home_spec, variable_spec, status);
  PROCEND evaluate_cybil_pointer;
?? TITLE := 'evaluate_cybil_subscript', EJECT ??

  PROCEDURE evaluate_cybil_subscript (
        home_spec: dut$home_specification;
        parameter_value: ^string ( * );
    VAR parameter_index: {input,output} clt$string_index;
    VAR variable_spec: {input,output} dut$variable_specification;
    VAR status: ost$status);

{ PURPOSE: Interpret a CYBIL subscript reference and adjust the variable_spec
{          entry to describe the requested element of the array.
{ DESIGN:  The reference is examined to see if it is a constant value of the
{          appropriate type. If it is not, an attempt is made to evaluate it as
{          a variable. When the subscript has been evaluated to a value, the
{          variable_spec is modified to describe an element of the array, and
{          the address is adjusted to indicate the requested element.

    VAR
      array_element_length: llt$section_length_in_bits,
      array_element_type: llt$symbol_number,
      array_entry: dut$symbol_entry,
      element_offset: machine_addr_in_bits_type,
      index_spec: dut$variable_specification,
      index_value: integer,
      pca_lower_bound: integer,
      pca_upper_bound: integer,
      subscript_index: clt$string_index,
      tmp_home_spec: dut$home_specification;     { In case the language is C }

    array_entry := variable_spec.symbol_entry;
    IF (array_entry.symbol^.symbol_kind <> llc$cybil_array_kind) AND
       (array_entry.symbol^.symbol_kind <> llc$pascal_conf_array_kind) THEN
      osp$set_status_abnormal (duc$symbolic_id,
            due$invalid_subscript_reference, variable_spec.name, status);
      RETURN;
    IFEND;
    IF parameter_index > STRLENGTH(parameter_value^) THEN
{ We have reached the end of the parameter prematurely }
      osp$set_status_abnormal (duc$symbolic_id, due$subscript_error,
                 variable_spec.name, status);
      RETURN;
    IFEND;
    IF array_entry.symbol^.symbol_kind = llc$cybil_array_kind THEN
      array_element_type := array_entry.symbol^.cybil_array_element_type;
      array_element_length := array_entry.symbol^.cybil_array_element_length;

{ Get index specification }

      dup$locate_symbol_for_number (home_spec.symbol_table_address,
        array_entry.symbol^.cybil_index_type, index_spec.symbol_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      index_spec.range_specified := FALSE;
      index_spec.descriptor_address := variable_spec.descriptor_address;
      reduce_cybil_type (home_spec, index_spec, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE  { Setup for Pascal conformant arrays }
      array_element_type := array_entry.symbol^.conf_array_element_kind;
      array_element_length := array_entry.symbol^.conf_array_element_length;

{ Get index specification for a conformant array }

      dup$locate_symbol_for_number (home_spec.symbol_table_address,
            array_entry.symbol^.conf_array_lower_bound, index_spec.symbol_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      subscript_index := 1;
      scan_cybil_variable (^index_spec.symbol_entry.symbol^.symbol_name, home_spec, subscript_index,
            index_spec, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      get_cybil_value (index_spec, pca_lower_bound, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
{ Get upper bound value }
      dup$locate_symbol_for_number (home_spec.symbol_table_address,
            array_entry.symbol^.conf_array_upper_bound, index_spec.symbol_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      subscript_index := 1;
      scan_cybil_variable (^index_spec.symbol_entry.symbol^.symbol_name, home_spec, subscript_index,
            index_spec, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      get_cybil_value (index_spec, pca_upper_bound, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Put the conformant array upper and lower bounds into index_spec }

      index_spec.low_value := pca_lower_bound;
      index_spec.high_value := pca_upper_bound;
    IFEND;

    { C home_spec's can be modified if the variable is global.
    tmp_home_spec := home_spec;

    get_index_value (tmp_home_spec, variable_spec.name, index_spec.symbol_entry, parameter_value,
          parameter_index, index_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (index_value < index_spec.low_value) OR (index_value > index_spec.
          high_value) THEN
      osp$set_status_abnormal (duc$symbolic_id, due$subscript_out_of_range,
            variable_spec.name, status);
      RETURN;
    IFEND;

{ Modify variable_spec to describe requested element in array.}

    dup$locate_symbol_for_number (tmp_home_spec.symbol_table_address, array_element_type,
                   variable_spec.symbol_entry, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    variable_spec.range_specified := FALSE;
    reduce_cybil_type (tmp_home_spec, variable_spec, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    variable_spec.length := array_element_length;
    IF array_entry.symbol^.symbol_kind = llc$cybil_array_kind THEN
      variable_spec.length_is_bits := llc$cybil_array_is_bits IN
                           array_entry.symbol^.cybil_array_attributes;
    ELSE
      variable_spec.length_is_bits := llc$cybil_array_is_bits IN
                           array_entry.symbol^.conf_array_attributes;
    IFEND;

    element_offset := variable_spec.length * (index_value - index_spec.
          low_value);
    IF variable_spec.length_is_bits THEN
      element_offset := element_offset + variable_spec.bit_offset;
      variable_spec.address.offset := variable_spec.address.offset +
            (element_offset DIV bits_per_byte);
      variable_spec.bit_offset := element_offset MOD bits_per_byte;
    ELSE
      variable_spec.address.offset := variable_spec.address.offset +
            element_offset;
    IFEND;
  PROCEND evaluate_cybil_subscript;
?? TITLE := 'evaluate_cybil_substring', EJECT ??

  PROCEDURE evaluate_cybil_substring (
        home_spec: dut$home_specification;
        parameter_value: ^string ( * );
    VAR parameter_index: clt$string_index;
    VAR variable_spec: dut$variable_specification;
    VAR status: ost$status);

    VAR
      old_string_len: ost$segment_length,
      param_index: clt$string_index,
      scan_index: clt$string_index,
      scan_length: clt$string_size,
      spaces_preceded_token: boolean,
      starting_position: integer,
      string_entry: dut$symbol_entry,
      substring_length: integer,
      sub_var_spec: dut$variable_specification,
      token: clt$lexical_token;

    string_entry := variable_spec.symbol_entry;
    IF string_entry.symbol^.symbol_kind <> llc$string_kind THEN
      IF string_entry.symbol^.symbol_kind = llc$constant_kind THEN
        osp$set_status_abnormal (duc$symbolic_id, due$internal_error,
            'A substring reference of a constant is not legal', status);
      ELSE
        osp$set_status_abnormal (duc$symbolic_id, due$substring_illegal,
                 variable_spec.name, status);
      IFEND;
      RETURN;
    IFEND;
    IF parameter_index > STRLENGTH(parameter_value^) THEN
{ We have reached the end of the parameter prematurely }
      osp$set_status_abnormal (duc$symbolic_id, due$invalid_substring, '', status);
      RETURN;
    IFEND;

    old_string_len := variable_spec.length;
    scan_index := 1;
    clp$evaluate_token (parameter_value^(parameter_index,*), scan_options, scan_index,
                   spaces_preceded_token, token, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    CASE token.kind OF
    = clc$unsigned_integer_token =
      starting_position := token.int.value;

    = clc$simple_name_token,
      clc$name_token,
      clc$cybil_name_token =
      find_separator_token (parameter_value^(parameter_index,*), scan_length,
                   status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      param_index := 1;
      scan_cybil_variable (^parameter_value^(parameter_index,scan_length), home_spec, param_index,
            sub_var_spec, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (duc$symbolic_id, due$substring_start_is_int,
                 variable_spec.name, status);
        RETURN;
      IFEND;
      IF sub_var_spec.symbol_entry.symbol^.symbol_kind <> llc$integer_kind THEN
        osp$set_status_abnormal (duc$symbolic_id, due$substring_start_is_int,
                 variable_spec.name, status);
        RETURN;
      IFEND;
      get_cybil_value (sub_var_spec, starting_position, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (duc$symbolic_id, due$substring_start_is_int,
                 variable_spec.name, status);
        RETURN;
      IFEND;
      scan_index := 1 + scan_length;

    ELSE
      osp$set_status_abnormal (duc$symbolic_id, due$substring_start_is_int,
                 variable_spec.name, status);
      RETURN;

    CASEND;
    IF (starting_position < 1) OR
       (starting_position > variable_spec.length) THEN
      osp$set_status_abnormal (duc$symbolic_id, due$substring_start_range_err,
                 variable_spec.name, status);
      RETURN;
    IFEND;

{ Update variable_spec with new starting position }

    variable_spec.address.offset := variable_spec.address.offset +
                   starting_position - 1;
    variable_spec.length := 1;         { assume one character substring for now }
    variable_spec.max_string_length := 1;
    variable_spec.range_specified := TRUE;

{ See if a length was specified }

    clp$evaluate_token (parameter_value^(parameter_index,*), scan_options, scan_index,
                   spaces_preceded_token, token, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF token.kind = clc$right_parenthesis_token THEN
      parameter_index := parameter_index + scan_index - 1; {Update param index}
      RETURN;      {We are done...}
    IFEND;
    IF token.kind <> clc$comma_token THEN
      osp$set_status_abnormal (duc$symbolic_id, due$invalid_substring, '', status);
      RETURN;
    IFEND;

{ Get the length of the substring }

    clp$evaluate_token (parameter_value^(parameter_index,*), scan_options, scan_index,
                   spaces_preceded_token, token, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    CASE token.kind OF
    = clc$unsigned_integer_token =
      substring_length := token.int.value;

    = clc$multiply_token =
      substring_length := old_string_len - (starting_position - 1);

    = clc$simple_name_token,
      clc$name_token,
      clc$cybil_name_token =
      scan_index := scan_index - token.text_size;
      find_separator_token (parameter_value^(parameter_index + scan_index - 1,*),
                   scan_length, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      param_index := 1;
      scan_cybil_variable (^parameter_value^ (parameter_index + scan_index - 1, scan_length),
                   home_spec, param_index, sub_var_spec, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (duc$symbolic_id, due$invalid_substring_length,
                 parameter_value^, status);
        RETURN;
      IFEND;
      IF sub_var_spec.symbol_entry.symbol^.symbol_kind <> llc$integer_kind THEN
        osp$set_status_abnormal (duc$symbolic_id, due$invalid_substring_length,
                 parameter_value^, status);
        RETURN;
      IFEND;
      get_cybil_value (sub_var_spec, substring_length, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (duc$symbolic_id, due$invalid_substring_length,
                 parameter_value^, status);
        RETURN;
      IFEND;
      scan_index := scan_index + scan_length;

    ELSE
      osp$set_status_abnormal (duc$symbolic_id, due$invalid_substring_length,
                 parameter_value^, status);
      RETURN;

    CASEND;
    IF substring_length < 0 THEN
      osp$set_status_abnormal (duc$symbolic_id, due$substring_length_range_err,
                 variable_spec.name, status);
      RETURN;
    IFEND;
    IF substring_length > old_string_len - (starting_position - 1) THEN
      osp$set_status_abnormal (duc$symbolic_id, due$substring_length_range_err,
                 variable_spec.name, status);
      RETURN;
    IFEND;
    variable_spec.length := substring_length;
    variable_spec.max_string_length := substring_length;

{ Make sure next token is a right parenthesis }

    clp$evaluate_token (parameter_value^(parameter_index,*), scan_options, scan_index,
                   spaces_preceded_token, token, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF token.kind <> clc$right_parenthesis_token THEN
      osp$set_status_abnormal (duc$symbolic_id, due$invalid_substring, '', status);
      RETURN;
    IFEND;
    parameter_index := parameter_index + scan_index - 1;

  PROCEND evaluate_cybil_substring;
?? TITLE := 'expand_value', EJECT ??

  PROCEDURE expand_value (value_name: string (*);
        p_value: ^clt$data_value;
    VAR p_seq: {input, output} ^SEQ (*);
    VAR p_string: ^clt$string_value;
    VAR status: ost$status);

{ TYPE
{   expression: any
{ TYPEND

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    type_specification : [STATIC, READ, cls$declaration_section] record
      header: clt$type_specification_header,
      name: string (10),
      qualifier: clt$union_type_qualifier,
    recend := [
      [1, 10, clc$union_type], 'EXPRESSION', [-$clt$type_kinds [],
      FALSE, 0]];

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      class: clt$variable_class,
      expression_start: clt$string_index,
      macro_size: clt$string_size,
      maximum_size: integer,
      method: clt$expression_eval_method,
      mode: clt$data_access_mode,
      open_paren_count: integer,
      p_expression: ^string (*),
      p_macro_string: ^string (*),
      p_macro_value: ^clt$data_value,
      p_name: ^string (*),
      p_type_spec: ^clt$type_specification,
      p_value_string: ^clt$string_value,
      p_var_string: ^ost$string,
      p_work: ^SEQ (*),
      p_work_area: ^SEQ (*),
      query_options: clt$token_evaluation_options,
      scan_options: clt$token_evaluation_options,
      spaces: boolean,
      string_index: clt$string_index,
      temp_p_seq: ^SEQ (*),
      token: clt$lexical_token,
      value_index: clt$string_index,
      value_size: clt$string_size;

    status.normal := TRUE;
    p_work_area := ^v$work_area;
    RESET p_work_area;

    get_value_string (p_value, p_work_area, p_value_string);

    IF (p_value_string = NIL) THEN
      p_string := NIL;
    ELSE
      temp_p_seq := p_seq;
      maximum_size := #SIZE (temp_p_seq^) - i#current_sequence_position (temp_p_seq);
      IF (maximum_size > clc$max_string_size) THEN
        maximum_size := clc$max_string_size;
      ELSEIF (maximum_size < 1) THEN
        osp$set_status_abnormal (duc$symbolic_id, due$parameter_value_too_long, value_name, status);
        RETURN;
      IFEND;
      NEXT p_string: [maximum_size] IN temp_p_seq;

      scan_options := $clt$token_evaluation_options [clc$cobol_name_is_token, clc$classify_name_token,
            clc$international_char_is_token, clc$special_cybil_name_is_token];
      query_options := $clt$token_evaluation_options [clc$classify_name_token,
            clc$international_char_is_token];

      value_index := 1;
      string_index := 1;

      REPEAT
        clp$evaluate_token (p_value_string^, scan_options, value_index, spaces, token, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF (token.kind = clc$query_token) THEN
          p_work := p_work_area;

          clp$evaluate_token (p_value_string^, query_options, value_index, spaces, token, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF (token.kind = clc$left_parenthesis_token) THEN
            value_size := STRLENGTH (p_value_string^);
            expression_start := value_index;
            open_paren_count := 1;
            WHILE (value_index <= value_size) AND (open_paren_count > 0) DO
              IF (p_value_string^ (value_index) = ')') THEN
                open_paren_count := open_paren_count - 1;
              ELSEIF (p_value_string^ (value_index) = '(') THEN
                open_paren_count := open_paren_count + 1;
              IFEND;
              value_index := value_index + 1;
            WHILEND;

            IF (open_paren_count <> 0) THEN
              osp$set_status_abnormal (duc$symbolic_id, due$unbalanced_macro_parens, '', status);
              RETURN;
            IFEND;

            p_expression := ^p_value_string^ (expression_start, value_index - expression_start - 1);
            p_type_spec := #SEQ (type_specification);
            clp$evaluate_expression (p_expression^, p_type_spec, p_work, p_macro_value, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSE
            p_name := ^token.str.value (1, token.str.size);
            clp$get_variable (p_name^, p_work_area, class, mode, method, p_type_spec, p_macro_value, status);
            IF NOT status.normal THEN
              osp$set_status_abnormal (duc$symbolic_id, due$scl_variable_expected, p_name^, status);
              RETURN;
            IFEND;
          IFEND;

          get_value_string (p_macro_value, p_work, p_macro_string);

          IF (p_macro_string <> NIL) THEN
            macro_size := STRLENGTH (p_macro_string^);
            IF ((string_index + macro_size - 1) > maximum_size) THEN
              osp$set_status_abnormal (duc$symbolic_id, due$parameter_value_too_long, value_name, status);
              RETURN;
            IFEND;
            p_string^ (string_index, macro_size) := p_macro_string^;
            string_index := string_index + macro_size;
          IFEND;
        ELSE
          IF ((string_index + token.text_size - 1) > maximum_size) THEN
            osp$set_status_abnormal (duc$symbolic_id, due$parameter_value_too_long, value_name, status);
            RETURN;
          IFEND;
          p_string^ (string_index, token.text_size) := p_value_string^ (token.text_index, token.text_size);
          string_index := string_index + token.text_size;
        IFEND;
      UNTIL token.kind = clc$end_of_line_token;

      NEXT p_string: [string_index -1] IN p_seq;
    IFEND;
  PROCEND expand_value;
?? TITLE := 'find_c_sub_expression', EJECT ??
{ This routine is used to isolate sub-expressions in a variable name.

  PROCEDURE find_c_sub_expression (
        expression: string ( * );
    VAR expression_len: clt$string_size;
    VAR status: ost$status );

    VAR
      i: integer,
      l_parens: integer;

    status.normal := TRUE;
    l_parens := 0;
  /find_matching_r_paren/
    FOR i := 1 TO STRLENGTH(expression) DO
      IF expression(i) = '(' THEN
        l_parens := l_parens + 1;
      ELSEIF expression(i) = ')' THEN
        IF l_parens = 0 THEN
          expression_len := i - 1;
          IF expression_len = 0 THEN
            osp$set_status_abnormal (duc$symbolic_id, due$c_empty_expression, '', status);
          IFEND;
          RETURN; {----->
        ELSE
          l_parens := l_parens - 1;
        IFEND;
      IFEND;
    FOREND /find_matching_r_paren/;
    osp$set_status_abnormal (duc$symbolic_id, due$c_unbalanced_parens, '', status);

  PROCEND find_c_sub_expression;
?? TITLE := 'find_c_subscript', EJECT ??
{ This routine finds the length of the parameter string up to the next right
{ bracket not contained in bracket pairs.
{
{ Param_str is only the substring part of the original parameter string.
{ That is, if the original parameter is - blip[arghh[2][3]]
{ then param_str will be - arghh[2][3]]
{ and we will return sub_param_len = 11, corresponding to - arghh[2][3]
{
{ sub_param_len is zero if the brackets are unbalanced or empty.

  PROCEDURE find_c_subscript (
        param_str: string ( * );
    VAR sub_param_len: clt$string_size);

    VAR
      i: clt$string_index,
      open_brackets: integer;

    open_brackets := 0;
    FOR i := 1 TO STRLENGTH (param_str) DO
      CASE param_str(i) OF
      = ']' =
        IF open_brackets = 0 THEN
          sub_param_len := i - 1;
          RETURN; {----->
        IFEND;
        open_brackets := open_brackets - 1;

      = '[' =
        open_brackets := open_brackets + 1;

      ELSE
      CASEND;
    FOREND;
    sub_param_len := 0;

  PROCEND find_c_subscript;
?? TITLE := 'find_end_of_subscript', EJECT ??

  PROCEDURE find_end_of_subscript (
        param_str: string ( * );
    VAR sub_param_len: clt$string_size);

{ This routine is called by evaluate_cybil_subscript if the subscript is
{  not expressed as a constant.  Its purpose is to find the length of the
{  parameter string up to the next right bracket or comma (not contained in
{  bracket pairs).
{  Scan_cybil_variable is then called to evaluate the expression as a CYBIL
{  variable reference.
{  Param_str is only the substring part of the original parameter string.
{  That is, if the original parameter is - xyzzy.blip[arghh[2,3]][plugh.yup]
{  then param_str will be - arghh[2,3]][plugh.yup]
{  and we will return sub_param_len = 10, corresponding to - arghh[2,3]

    VAR
      i: clt$string_index,
      open_brackets: integer;

    open_brackets := 0;
    FOR i := 1 TO STRLENGTH (param_str) DO
      CASE param_str(i) OF
      = ']',
        ',' =
        IF open_brackets = 0 THEN
          sub_param_len := i - 1;
          RETURN;
        IFEND;
        IF param_str(i) = ']' THEN
          open_brackets := open_brackets - 1;
        IFEND;

      = '[' =
        open_brackets := open_brackets + 1;

      ELSE
      CASEND;
    FOREND;
    sub_param_len := 0;

  PROCEND find_end_of_subscript;
?? TITLE := 'find_separator_token', EJECT ??

  PROCEDURE find_separator_token (
        param_str: string ( * );
    VAR sub_param_len: clt$string_size;
    VAR status: ost$status);

{ This routine is called by evaluate_cybil_substring if the substring starting
{  position or length is not expressed as a constant.  Its purpose is to find
{  the length of the parameter string up to the next space, comma, or right
{  parenthesis (not contained in parentheses or bracket pairs).
{  Scan_cybil_variable is then called to evaluate the expression as a CYBIL
{  variable reference.
{  Param_str is only the substring part of the original parameter string.
{  That is, if the original parameter is - xyzzy.blip(arghh[2,3],plugh.yup)
{  then param_str will be - arghh[2,3],plugh.yup)
{  on the first call and we will return sub_param_len = 10, corresponding
{  to - arghh[2,3]

    VAR
      i: clt$string_index,
      open_brackets: integer,
      open_parens: integer;

    open_parens := 0;
    open_brackets := 0;
    FOR i := 1 TO STRLENGTH (param_str) DO
      CASE param_str(i) OF
      = ')',
        ',',
        ' ' =
        IF (open_parens = 0) AND
           (open_brackets = 0) THEN
          sub_param_len := i - 1;
          RETURN;
        IFEND;
        IF param_str(i) = ')' THEN
          open_parens := open_parens - 1;
        IFEND;

      = '(' =
        open_parens := open_parens + 1;

      = '[' =
        open_brackets := open_brackets + 1;

      = ']' =
        open_brackets := open_brackets - 1;

      ELSE
      CASEND;
    FOREND;
    osp$set_status_abnormal (duc$symbolic_id, due$c_unbalanced_parens,
                 '', status);

  PROCEND find_separator_token;
?? TITLE := 'format_and_display_data', EJECT ??

  PROCEDURE format_and_display_data (display_start: ost$pva;
        displayable_length: integer;
        byte_count: integer;
        repeat_count: integer;
    VAR display_control_pointer: ^clt$display_control;
    VAR status: ost$status);

    CONST
      out_str_len = 96;

    VAR
      address: ost$pva,
      bytes_per_line: integer,         {max bytes per line in long display
      first_ascii: integer,            {position in s of first ascii chr
      out_len: 0 .. out_str_len,       {length of s used.
      byte: 0 .. 255,
      s: string (out_str_len),
      character: char,
      portion_length: 1 .. 24,
      number_of_portions,
      portion_index,
      hex_position,
      index,
      actual_repeat_count,
      byte_count_rest,
      i,
      k: integer;

    PROCEDURE condition_handler (condition: pmt$condition,
          ignore_cond_inf: ^pmt$condition_information;
          ignore_save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      handler_status.normal := TRUE;
      CASE condition.selector OF
      = mmc$segment_access_condition =
        clp$put_partial_display (display_control_pointer^, s, clc$no_trim, amc$terminate, status);
        pmp$continue_to_cause (pmc$inhibit_standard_procedure, handler_status);

      CASEND;
    PROCEND condition_handler;

    VAR
      condition: [STATIC, READ] pmt$condition := [pmc$condition_combination, $pmt$condition_combination
        [pmc$system_conditions, mmc$segment_access_condition]],
      established_condition_handler: pmt$established_handler;

    s := 'STARTING ADDRESS: 0 000 00000000';
    convert_pva_to_hexstring (display_start, s (19, 14), status);
    IF NOT status.normal THEN
      RETURN; {---->
    IFEND;
    clp$put_partial_display (display_control_pointer^, s (1, 32), clc$trim, amc$terminate, status);

    pmp$establish_condition_handler (condition, ^condition_handler, ^established_condition_handler, status);

    address := display_start;

    IF byte_count < 9 THEN {format two byte_count fields per line.
      s := '00000000                               00000000                                 ';
    /display_memory_loop_one/
      FOR i := 1 TO repeat_count DO
        clp$convert_integer_to_rjstring (byte_count * (i - 1), 16, FALSE, '0', s (1 + 39 * ((i - 1) MOD 2),
              8), status);
        FOR k := 0 TO byte_count - 1 DO
          index := (i - 1) * byte_count + k + 1;
{
{If end of displayable block (section or segment) is reached,
{prpare for output and output last line, if necessary, and end display.
{
          IF index > displayable_length THEN
            IF (i MOD 2 = 1) THEN
              IF k = 0 THEN
                EXIT /display_memory_loop_one/;
              ELSE
                s (40, 8) := '        ';
              IFEND;
            ELSE { i MOD 2 = 0
              IF k = 0 THEN
                s (40,8) := '        ';
              IFEND;
            IFEND;
            clp$put_partial_display (display_control_pointer^, s(1,77),
              clc$no_trim, amc$terminate, status);
            exit /display_memory_loop_one/;
          IFEND;

          address.offset := display_start.offset + index - 1;
          dup$get_bytes (address, #LOC (byte), #SIZE (byte), status);

          IF NOT status.normal THEN
            RETURN;
          IFEND;
          character := $char (byte);

          IF (ORD (character) < 32) OR (ORD (character) > 126) THEN
            character := '?';
          IFEND;
          s (31 + 39 * ((i - 1) MOD 2) + k) := character;
          hex_position := 11 + 2 * k + k DIV 2 + 39 * ((i - 1) MOD 2);
          clp$convert_integer_to_rjstring (byte, 16, FALSE, '0', s (hex_position, 2),
                status);
        FOREND;
        IF (i MOD 2 = 0) THEN
          clp$put_partial_display (display_control_pointer^, s(1,77), clc$no_trim, amc$terminate, status);
          s := '00000000                               00000000                                 ';
        ELSEIF (i MOD 2 = 1) AND (i = repeat_count) THEN
          s (40, 8) := '        ';
          clp$put_partial_display (display_control_pointer^, s(1,77), clc$no_trim, amc$terminate, status);
        IFEND;
      FOREND /display_memory_loop_one/;
    ELSE {byte_count >= 9
{
{   If the page is wide enough, format up to 3 words per line, otherwise 2.
{If byte_count > bytes_per_line, then divide byte field of length byte_count
{into portions of bytes_per_line bytes each, with the last portion having usually less.
{There will be one line per portion.
{A new line is started at the start of each byte field of length byte_count.
{
      IF (display_control_pointer^.page_width < 96) OR
         (byte_count < 17) THEN
{ If there is only room for two words per display line or the user asked for two
        bytes_per_line := 16;
      ELSE
{ Three words will fit and user asked for more than two words per portion.
        bytes_per_line := 24;
      IFEND;
      first_ascii := 10 + (bytes_per_line * 2) + (bytes_per_line DIV 2) + 2;
      out_len := first_ascii + bytes_per_line - 1;
      number_of_portions := (byte_count + (bytes_per_line - 1)) DIV bytes_per_line;
    /display_memory_loop_two/
      FOR i := 1 TO repeat_count DO
        s := '00000000';
        clp$convert_integer_to_rjstring (byte_count * (i - 1), 16, FALSE, '0', s (1, 8), status);
        FOR portion_index := 1 TO number_of_portions DO
          IF portion_index < number_of_portions THEN
            portion_length := bytes_per_line;
          ELSE
            portion_length := byte_count - (portion_index - 1) * bytes_per_line;
          IFEND;
          FOR k := 0 TO portion_length - 1 DO
            index := byte_count * (i - 1) + bytes_per_line * (portion_index - 1) + k + 1;
{
{If end of displayable block (section or segment) is reached,
{prepare for output and output last line, if necessary, and end display.
{
            IF index > displayable_length THEN
              IF k <> 0 THEN
                clp$put_partial_display (display_control_pointer^, s(1,out_len),
                  clc$no_trim, amc$terminate, status);
              IFEND;
              exit /display_memory_loop_two/;
            IFEND;

            address.offset := display_start.offset + index - 1;
            dup$get_bytes (address, #LOC (byte), #SIZE (byte), status);

            IF NOT status.normal THEN
              RETURN;
            IFEND;
            character := $char (byte);

            IF (ORD (character) < 32) OR (ORD (character) > 126) THEN
              character := '?';
            IFEND;
            s (first_ascii + k) := character;
            hex_position := 11 + 2 * k + k DIV 2;
            clp$convert_integer_to_rjstring (byte, 16, FALSE, '0', s (hex_position, 2),
                  status);
          FOREND;
          clp$put_partial_display (display_control_pointer^, s(1,out_len),
                             clc$no_trim, amc$terminate, status);
          s := '';
        FOREND;
      FOREND /display_memory_loop_two/;

    IFEND;
  PROCEND format_and_display_data;
?? TITLE := 'format_and_display_variable', EJECT ??

  PROCEDURE format_and_display_variable (
        home_spec: dut$home_specification;
        input_variable_spec: dut$variable_specification;
        variable_name: ^string ( * );
        indent_count: ost$string_size;
        display_type: dut$display_type;
        p_variant_selection: ^clt$data_value;
    VAR display_control_pointer: ^clt$display_control;
    VAR status: ost$status);

{ PURPOSE: Format a variable value and write it on the display file.
{ DESIGN:  Simple types are displayed in accordance with their type.
{          Compound types are broken down into their elements and this
{          routine is called recursively to display the elements.

    VAR
      address: ost$pva,
      blank_fill: 0 .. bits_per_byte,
      code_address: ost$pva,
      column_number: 0 .. amc$max_page_width,
      constant_entry: dut$symbol_entry,
      constant_spec: dut$variable_specification,
      copied_string_pointer: ^string ( * ),
      element_address_ptr: ^ost$pva,
      element_found: boolean,
      element_offset: machine_addr_in_bits_type,
      element_spec: dut$variable_specification,
      element_value: integer,
      element_value_ptr: ^cell,
      err_msg: string(80),
      field_number: symbol_no,
      field_offset: machine_addr_in_bits_type,
      field_spec: dut$variable_specification,
      index_spec: dut$variable_specification,
      i: integer,
      int_string: ost$string,
      local_status: ost$status,
      local_status1: ost$status,
      longreal_value_pointer: ^^longreal,
      message: ost$status_message,
      message_area: ^ost$status_message,
      message_line_count: ^ost$status_message_line_count,
      message_line_index: 1 .. osc$max_status_message_lines,
      message_line: ^string(*),
      message_line_size: ^ost$status_message_line_size,
      module_item: ^dbt$module_address_table_item,
      name: ost$name,
      number_of_elements_ptr: ^integer,
      ordinal_entry: dut$symbol_entry,
      p_vs_list: ^clt$data_value,
      pascal_file_ptr: ^^boolean,
      pascal_file_ptr2: ^^0 .. 0FF(16),
      pca_lower_bound: integer,
      pca_upper_bound: integer,
      pointer: ost$pva,
      pointer_pva: ^ost$pva,
      pointer_to_procedure: ^^ost$pointer_to_procedure,
      procedure_entry: dut$symbol_entry,
      real_value_pointer: ^^real,
      section_item_index: llt$section_ordinal,
      select_any: boolean,
      selector_entry: dut$symbol_entry,
      selector_number: symbol_no,
      selector_value: integer,
      set_index: 0 .. max_set_element,
      set_array: packed array [0 .. 7] of boolean,
      storage: integer,
      string_index: 1 .. max_string_size,
      string_delimiter_left: string (2),
      string_delimiter_right: string (1),
      string_desc_ptr_pointer: ^^string_descriptor,
      string_value_length: 0..max_string_size,
      subscript_index: clt$string_index,
      symbol_table_address: ^llt$debug_symbol_table,
      symbol_index: symbol_no,
      unique_name: ost$binary_unique_name,
      unpacked_value: value_record,
      value: integer,
      value_length: integer,
      value_string: string (38),
      variable_kind: llt$entry_kind,
      variable_spec: dut$variable_specification,
      variant_entry: dut$symbol_entry,
      vspec: dut$variable_specification,
      vs_current_entry: integer,
      vs_value: clt$data_value;

?? NEWTITLE := '  display_array', EJECT ??
    PROCEDURE display_array (
          variable_spec: dut$variable_specification;
          index_lower_bound: integer;
          index_upper_bound: integer;
          p_variant_selection: ^clt$data_value;
      VAR element_spec: dut$variable_specification;
      VAR status: ost$status );

{ This routine displays a range of elements from an array.  For consecutive
{  duplicate elements, only the first one is displayed.  Display_repeat_count
{  is called for the duplicates.

      VAR
        actual_element_spec: dut$variable_specification,
        array_index: integer,
        string_desc_ptr_pointer: ^^string_descriptor,
        current_value: integer,
        element_kind: llt$entry_kind,
        element_length: ost$segment_length,
        last_index: integer,
        previous_value: integer,
        repeat_count: integer;

      repeat_count := 0;
      last_index := index_upper_bound - index_lower_bound;
      element_kind := element_spec.symbol_entry.symbol^.symbol_kind;
      element_length := element_spec.length;  {length occupied by each element}
{ PASCAL strings element_spec.length is the current length, not total length }
      IF (element_kind = llc$string_kind) AND
         (home_spec.language = llc$pascal) THEN
        element_length := element_spec.max_string_length + 2;
      IFEND;

    /display_elements/
      FOR array_index := 0 TO last_index DO
        IF element_spec.length_is_bits THEN
          element_offset := (element_length * array_index) + variable_spec.bit_offset;
          element_spec.address.offset := variable_spec.address.offset + (element_offset DIV bits_per_byte);
          element_spec.bit_offset := element_offset MOD bits_per_byte;
        ELSE
          element_spec.address.offset := variable_spec.address.offset + (element_length * array_index);
          element_spec.bit_offset := variable_spec.bit_offset;
        IFEND;
{ PASCAL strings have a current length which can vary from element to element }
        IF (element_kind = llc$string_kind) AND
           (home_spec.language = llc$pascal) AND
           (array_index <> 0) THEN
          element_spec.length := element_length;  {Reset max length}
          reduce_cybil_type (home_spec, element_spec, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        IF element_kind <= llc$ordinal_kind THEN
          get_cybil_value (element_spec, current_value, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF (repeat_count > 0) AND (current_value = previous_value) THEN
            repeat_count := repeat_count + 1;
            CYCLE /display_elements/;
          IFEND;
          previous_value := current_value;
        IFEND;
        display_repeat_count (repeat_count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        repeat_count := 1;
        element_spec.attribute := duc$variable_value;
        actual_element_spec := element_spec;
        IF (home_spec.language = llc$basic) AND (element_kind = llc$string_kind) THEN
          actual_element_spec.descriptor_address := element_spec.address;
          string_desc_ptr_pointer := #LOC (element_spec.address);
          actual_element_spec.length := string_desc_ptr_pointer^^.length;
          actual_element_spec.address := string_desc_ptr_pointer^^.pva;
        IFEND;
        format_and_display_variable (home_spec, actual_element_spec, NIL, indent_count,
              display_type, p_variant_selection, display_control_pointer, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
{ If there is room, tab over 'value_spacer' columns.  Otherwise, go to a new line }
        IF display_control_pointer^.column_number + value_spacer < display_control_pointer^.page_width THEN
          clp$horizontal_tab_display (display_control_pointer^, display_control_pointer^.column_number +
                value_spacer, status);
        ELSE
          clp$new_display_line (display_control_pointer^, clc$next_display_line, status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND /display_elements/;
      display_repeat_count (repeat_count, status);
    PROCEND display_array;
?? TITLE := 'display_repeat_count', EJECT ??

    PROCEDURE display_repeat_count (repeat_count: integer;
      VAR status: ost$status);

{ PURPOSE: Display the string "( n OCCURRENCES)" when n > 1.

      IF repeat_count > 1 THEN
        STRINGREP (value_string, value_length, repeat_count);
        dup$display_string (display_control_pointer, 16 + value_length, ' (', indent_count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        dup$display_string (display_control_pointer, 1, value_string (1, value_length), indent_count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        dup$display_string (display_control_pointer, 1, ' OCCURRENCES) ', indent_count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    PROCEND display_repeat_count;
?? OLDTITLE ??
?? EJECT ??
{ Begin procedure format_and_display_variable

{ Display the variable value }

    p_vs_list := p_variant_selection;
    vs_current_entry := 1;

    get_variable_attribute (home_spec, input_variable_spec, storage, variable_spec, status);
    IF NOT status.normal THEN
      IF (status.condition = due$unaligned_pointer) THEN
        dup$display_string (display_control_pointer, 31, '** Variable not byte aligned **', indent_count,
              local_status);
      IFEND;
      RETURN;
    IFEND;

    variable_kind := variable_spec.symbol_entry.symbol^.symbol_kind;
    IF variable_spec.constant_value = TRUE THEN
      dup$display_string (display_control_pointer, 11, '(CONSTANT)', indent_count, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
{ CYBIL Long constants are the only constants that are not reduced. These are
{  not represented properly in the tables.
      IF variable_kind = llc$constant_kind THEN
        dup$display_string (display_control_pointer, 40, '***CYBIL long constants not available***',
                              indent_count, status);
        RETURN; {we do not get the value of long constants}
      IFEND;
    IFEND; { If this is a constant to be displayed }

{ Display packed array of characters as a string }
    IF (variable_kind = llc$cybil_array_kind) AND
       (variable_spec.symbol_entry.symbol^.cybil_array_packing = llc$packed) THEN
      dup$locate_symbol_for_number (home_spec.symbol_table_address, variable_spec.symbol_entry.symbol^.
            cybil_array_element_type, element_spec.symbol_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF element_spec.symbol_entry.symbol^.symbol_kind = llc$char_kind THEN
        variable_kind := llc$string_kind;
      IFEND;
    IFEND;
{ See if we need to change the type }
    IF NOT (display_type = duc$natural_type) THEN
      IF NOT (variable_kind IN delay_change_of_type) THEN
{ The variable_kind is one whose type change does not need to be delayed (arrays
{   need to be delayed until we are dealing with the elements).  Change the
{   type now.
        CASE display_type OF
        = duc$integer_type =
          IF (variable_spec.length > 8) OR (variable_spec.length < 1) THEN
            osp$set_status_abnormal (duc$symbolic_id, due$cant_display_as_integer,
              '', status);
            RETURN;
          IFEND;
          variable_kind := llc$integer_kind;
        = duc$real_type =
          IF variable_spec.length <> 8 THEN
            osp$set_status_abnormal (duc$symbolic_id, due$cant_display_as_real,
              '', status);
            RETURN;
          IFEND;
          variable_kind := llc$real_kind;
        CASEND;
      IFEND;
    IFEND;  { If need to change the type from variable's natural type. }

    CASE variable_kind OF
    = llc$integer_kind =
      get_cybil_value (variable_spec, unpacked_value.word_sized_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
{If the integer was in a packed structure
      IF variable_spec.length_is_bits AND (variable_spec.range_specified AND (variable_spec.low_value < 0))
            THEN
{If the value was negative, sign-extend it
        IF unpacked_value.bits [64 - variable_spec.length] THEN
          FOR value_length := 0 TO 63 - variable_spec.length DO
            unpacked_value.bits [value_length] := TRUE;
          FOREND;
        IFEND;
      IFEND;
      clp$convert_integer_to_string (unpacked_value.word_sized_value, 16, TRUE, int_string, status);
      value_length := int_string.size;
      IF int_string.value (1) <> ' ' THEN
        dup$display_string (display_control_pointer, 1, ' ', indent_count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      dup$display_string (display_control_pointer, value_length, int_string.value (1, value_length),
            indent_count, status);

    = llc$boolean_kind =
      get_cybil_value (variable_spec, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value = false_value THEN
        dup$display_string (display_control_pointer, 6, ' FALSE', indent_count, status);
      ELSEIF value = true_value THEN
        dup$display_string (display_control_pointer, 5, ' TRUE', indent_count, status);
      ELSE
        dup$display_string (display_control_pointer, 28, ' ** INVALID BOOLEAN VALUE **', indent_count,
              status);
      IFEND;

    = llc$char_kind =
      get_cybil_value (variable_spec, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      value_string := ' '' ''';
      IF (value < ORD (smallest_graphic)) OR (value > ORD (largest_graphic)) THEN
        value_string (3) := '?';
      ELSE
        value_string (3) := CHR (value);
      IFEND;
      dup$display_string (display_control_pointer, 4, value_string (1, 4), indent_count, status);

    = llc$real_kind =
      IF variable_spec.bit_offset > 0 THEN
        dup$display_string (display_control_pointer, 20, '** Unaligned real **', indent_count, status);
        RETURN;
      IFEND;
      real_value_pointer := #LOC (variable_spec.address);
      STRINGREP (value_string, value_length, real_value_pointer^^);
      dup$display_string (display_control_pointer, value_length, value_string (1, value_length), indent_count,
            status);

    = llc$longreal_kind =
      longreal_value_pointer := #LOC (variable_spec.address);
      STRINGREP (value_string, value_length, longreal_value_pointer^^);
      dup$display_string (display_control_pointer, value_length, value_string (1, value_length),
        indent_count, status);

    = llc$cell_kind =
      get_cybil_value (variable_spec, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      STRINGREP (value_string, value_length, value: 4: #(16));
      dup$display_string (display_control_pointer, value_length, value_string (1, value_length), indent_count,
            status);

    = llc$ordinal_kind =
      get_cybil_value (variable_spec, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (value < 0) OR (value > variable_spec.symbol_entry.symbol^.ordinal_upper_bound) THEN
        dup$display_string (display_control_pointer, 27, ' ** INVALID ORDINAL VALUE **', indent_count,
              status);
      ELSE
        ordinal_entry := variable_spec.symbol_entry;
        REPEAT
          dup$locate_next_symbol (home_spec.symbol_table_address, ordinal_entry, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        UNTIL value = ordinal_entry.symbol^.short_constant_value.integer_value;
        IF ordinal_entry.symbol^.symbol_name = variable_spec.name THEN
{ If this is one of the ordinal constant symbols, display its integer value.
          STRINGREP (value_string, value_length, value);
        ELSE
          value_length := STRLENGTH (ordinal_entry.symbol^.symbol_name);
          WHILE (value_length > 0) AND (ordinal_entry.symbol^.symbol_name (value_length) = ' ') DO
            value_length := value_length - 1;
          WHILEND;
          value_string(1) := ' ';        {emulate leading blank from STRINGREP}
          value_length := value_length + 1;
          value_string(2,*) := ordinal_entry.symbol^.symbol_name;
        IFEND;
        dup$display_string (display_control_pointer, value_length,
                        value_string (1,value_length), indent_count, status);
      IFEND;

    = llc$proc_kind =
      IF variable_spec.bit_offset > 0 THEN
        dup$display_string (display_control_pointer, 28, '** Unaligned proc pointer **', indent_count,
              status);
        RETURN;
      IFEND;
      dup$find_module_table_for_pva (variable_spec.address, module_item, section_item_index, status);
      IF NOT status.normal THEN
        status.normal := TRUE;
        dup$display_string (display_control_pointer, 27, '** Invalid pointer value **', indent_count, status);
        RETURN;
      IFEND;
      IF module_item^.section_item [section_item_index].kind <> llc$binding_section THEN
        dup$display_string (display_control_pointer, 36, '** Pointer not in binding section **', indent_count,
              status);
        RETURN;
      IFEND;

      pointer_to_procedure := #LOC (variable_spec.descriptor_address);
      code_address.ring := #ring (pointer_to_procedure^^.code_base_pointer_p^.code_pva);
      code_address.seg := #segment (pointer_to_procedure^^.code_base_pointer_p^.code_pva);
      code_address.offset := #offset (pointer_to_procedure^^.code_base_pointer_p^.code_pva);
      dup$find_module_table_for_pva (code_address, module_item, section_item_index, status);
      IF status.normal THEN
        dup$display_string (display_control_pointer, 8, ' MODULE ', indent_count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        dup$find_procedure_for_pva (module_item, section_item_index, code_address, symbol_table_address,
              symbol_index, status);
        IF status.normal THEN
          value_length := STRLENGTH (symbol_table_address^.original_module_name);
          WHILE (value_length > 1) AND (symbol_table_address^.original_module_name (value_length) = ' ') DO
            value_length := value_length - 1;
          WHILEND;
          dup$display_string (display_control_pointer, value_length, symbol_table_address^.
                original_module_name (1, value_length), indent_count, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          dup$display_string (display_control_pointer, 11, ' PROCEDURE ', indent_count, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          procedure_entry.table_entry_index := symbol_index;
          procedure_entry.symbol := ^symbol_table_address^.item[symbol_index];
          value_length := STRLENGTH (procedure_entry.symbol^.symbol_name);
          WHILE (value_length > 1) AND (procedure_entry.symbol^.symbol_name (value_length) = ' ') DO
            value_length := value_length - 1;
          WHILEND;
          dup$display_string (display_control_pointer, value_length, procedure_entry.symbol^.symbol_name (1,
                value_length), indent_count, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          status.normal := TRUE;
          value_length := STRLENGTH (module_item^.name);
          WHILE (value_length > 1) AND (module_item^.name (value_length) = ' ') DO
            value_length := value_length - 1;
          WHILEND;
          dup$display_string (display_control_pointer, value_length, module_item^.name (1, value_length),
                indent_count, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          dup$display_string (display_control_pointer, 8, ' OFFSET ', indent_count, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          STRINGREP (value_string, value_length, variable_spec.address.offset - module_item^.section_item
                [section_item_index].address.offset);
          dup$display_string (display_control_pointer, value_length, value_string (1, value_length),
                indent_count, status);
        IFEND;
        clp$new_display_line (display_control_pointer^, clc$next_display_line, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        dup$display_string (display_control_pointer, 1, '  Binding pointer = ', indent_count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        pointer_pva := #LOC (pointer_to_procedure^^.code_base_pointer_p^.binding_pva);
        STRINGREP (value_string, value_length, pointer_pva^.ring: 2: #(16), pointer_pva^.seg: 4: #(16),
              pointer_pva^.offset: 9: #(16));
        dup$display_string (display_control_pointer, value_length, value_string (1, value_length),
              indent_count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        dup$display_string (display_control_pointer, 16, '  Static link = ', indent_count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        pointer_pva := #LOC (pointer_to_procedure^^.static_link);
        STRINGREP (value_string, value_length, pointer_pva^.ring: 2: #(16), pointer_pva^.seg: 4: #(16),
              pointer_pva^.offset: 9: #(16));
        dup$display_string (display_control_pointer, value_length, value_string (1, value_length),
              indent_count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        status.normal := TRUE;
        dup$display_string ( display_control_pointer, 24, ' ** NOT IN ANY MODULE **', indent_count, status);
      IFEND;

    = llc$pointer_kind =
      IF variable_spec.bit_offset > 0 THEN
        dup$display_string (display_control_pointer, 23, '** Unaligned pointer **', indent_count, status);
        RETURN;
      IFEND;
      address := variable_spec.address;
      IF home_spec.language = llc$the_c_language THEN
        address.offset := address.offset + 2;
      IFEND;
      dup$get_bytes (address, #LOC(pointer), #SIZE (pointer), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      STRINGREP (value_string, value_length, pointer.ring: 2: #(16), pointer.seg: 4:
            #(16), pointer.offset: 9: #(16));
      dup$display_string (display_control_pointer, value_length, value_string (1, value_length), indent_count,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    = llc$set_kind =
      element_found := FALSE;
      element_spec.name := ' ';
      element_spec.length := #SIZE (element_value);
      element_spec.bit_offset := 0;
      element_spec.length_is_bits := FALSE;
      element_spec.range_specified := FALSE;
      element_value_ptr := ^element_value;

      element_spec.address.ring := osc$invalid_ring {flag local address};
      element_spec.address.seg := #segment (element_value_ptr);
      element_spec.address.offset := #offset (element_value_ptr);
      element_spec.attribute := duc$variable_value;
      element_spec.constant_value := FALSE;

      dup$locate_symbol_for_number (home_spec.symbol_table_address, variable_spec.symbol_entry.symbol^.
            set_element_type, element_spec.symbol_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      reduce_cybil_type (home_spec, element_spec, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF variable_spec.length_is_bits THEN
        IF variable_spec.symbol_entry.symbol^.set_length > 57 THEN {mapped as
          {unpacked set}
          IF variable_spec.symbol_entry.symbol^.set_length > (bits_per_byte * bytes_per_word) THEN
            blank_fill := variable_spec.bit_offset;
          ELSE
            blank_fill := variable_spec.bit_offset + variable_spec.length - variable_spec.symbol_entry.
                  symbol^.set_length;
          IFEND;
        ELSE {mapped as packed set}
          blank_fill := variable_spec.bit_offset;
        IFEND;
      ELSE {length in bytes}
        IF variable_spec.length <= bytes_per_word THEN
          blank_fill := variable_spec.bit_offset + (variable_spec.length * bits_per_byte) - variable_spec.
                symbol_entry.symbol^.set_length;
        ELSE
          blank_fill := variable_spec.bit_offset;
        IFEND;
      IFEND;

{ A set is overlayed with a packed array of boolean and examined. }

      FOR set_index := 0 TO variable_spec.symbol_entry.symbol^.set_length - 1 DO
        address := variable_spec.address;
        address.offset := address.offset + (set_index + blank_fill) DIV 8;
        dup$get_bytes (address, #LOC (set_array), #SIZE (set_array), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF set_array [(set_index + blank_fill) MOD 8] THEN
          element_found := TRUE;
          IF element_spec.range_specified THEN
            element_value := element_spec.low_value + set_index;
          ELSE
            element_value := set_index;
          IFEND;
          format_and_display_variable (home_spec, element_spec, NIL, indent_count,
                display_type, p_vs_list, display_control_pointer, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
{ If there is room, tab over 'value_spacer' columns.  Otherwise, go to a new line }
          IF display_control_pointer^.column_number + value_spacer < display_control_pointer^.page_width THEN
            clp$horizontal_tab_display (display_control_pointer^, display_control_pointer^.column_number +
                  value_spacer, status);
          ELSE
            clp$new_display_line (display_control_pointer^, clc$next_display_line, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND;

      IF NOT element_found THEN
        dup$display_string (display_control_pointer, 16, ' ** EMPTY SET **', indent_count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;


    = llc$string_kind =
      IF variable_spec.bit_offset > 0 THEN
        dup$display_string (display_control_pointer, 22, '** Unaligned string **', indent_count, status);
        RETURN;
      IFEND;
      IF (home_spec.language = llc$basic) OR
         (home_spec.language = llc$the_c_language) THEN
        string_delimiter_left := ' "';
        string_delimiter_right := '"';
      ELSE
        string_delimiter_left := ' ''';
        string_delimiter_right := '''';
      IFEND;
      string_value_length := variable_spec.length;
      PUSH copied_string_pointer: [string_value_length];
      address := variable_spec.address;
      dup$get_bytes (address, #LOC (copied_string_pointer^), string_value_length, status);
      IF NOT status.normal THEN
        RETURN; {------->
      IFEND;
      FOR string_index := 1 TO string_value_length DO
        IF (copied_string_pointer^ (string_index) < smallest_graphic) OR (copied_string_pointer^
              (string_index) > largest_graphic) THEN
          copied_string_pointer^ (string_index) := '?';
        IFEND;
      FOREND;
      dup$display_string (display_control_pointer, string_value_length + 3, string_delimiter_left,
          indent_count, status);
      IF NOT status.normal THEN
        RETURN; {------->
      IFEND;
      dup$display_string (display_control_pointer, 1, copied_string_pointer^, indent_count, status);
      IF NOT status.normal THEN
        RETURN; {------>
      IFEND;
{ If the string was longer than the page width, the column num is too big.  Must
{  adjust it so that the terminating quote is in the right place.
      column_number := display_control_pointer^.column_number -
        ( (display_control_pointer^.column_number DIV display_control_pointer^.page_width) *
           display_control_pointer^.page_width );
      IF column_number <> 0 THEN
        display_control_pointer^.column_number := column_number;
      ELSE
        display_control_pointer^.column_number := display_control_pointer^.page_width;
      IFEND;
      dup$display_string (display_control_pointer, 1, string_delimiter_right, indent_count, status);

    = llc$basic_array_kind =
      element_spec.name := '   ';
      element_spec.length := 8;
      element_spec.length_is_bits := FALSE;
      element_spec.range_specified := FALSE;
      element_spec.address := variable_spec.address;
      element_spec.constant_value := FALSE;

{        Note: If the array elements are integers or reals, this is the address
{        of the first array element. If the array elements are strings, this is the
{        address of the descriptor of the first string element of the array.

      dup$locate_symbol_for_number (home_spec.symbol_table_address, variable_spec.symbol_entry.symbol^.
            basic_array_element_type, element_spec.symbol_entry, status);
      IF NOT status.normal THEN
        RETURN; {------>
      IFEND;
       number_of_elements_ptr := #address (variable_spec.descriptor_address.ring,
        variable_spec.descriptor_address.seg, variable_spec.descriptor_address.offset + 8);
       display_array (variable_spec, 1, number_of_elements_ptr^, p_vs_list, element_spec, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

    = llc$cybil_array_kind =
      element_spec.name := '   ';
      element_spec.range_specified := FALSE;
      element_spec.address := variable_spec.address;
      element_spec.descriptor_address := variable_spec.descriptor_address;
      element_spec.constant_value := FALSE;

      dup$locate_symbol_for_number (home_spec.symbol_table_address, variable_spec.symbol_entry.symbol^.
            cybil_array_element_type, element_spec.symbol_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      reduce_cybil_type (home_spec, element_spec, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      element_spec.length := variable_spec.symbol_entry.symbol^.cybil_array_element_length;
      element_spec.length_is_bits := llc$cybil_array_is_bits IN variable_spec.symbol_entry.symbol^.
            cybil_array_attributes;

      index_spec.range_specified := FALSE;
      index_spec.descriptor_address := variable_spec.descriptor_address;
      dup$locate_symbol_for_number (home_spec.symbol_table_address, variable_spec.symbol_entry.symbol^.
            cybil_index_type, index_spec.symbol_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      reduce_cybil_type (home_spec, index_spec, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

       display_array (variable_spec, index_spec.low_value, index_spec.high_value,
               p_vs_list, element_spec, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

    = llc$pascal_conf_array_kind =
      element_spec.name := '   ';
      element_spec.address := variable_spec.address;
      element_spec.length := variable_spec.symbol_entry.symbol^.conf_array_element_length;
      element_spec.length_is_bits := llc$cybil_array_is_bits IN variable_spec.symbol_entry.symbol^.
            conf_array_attributes;
      element_spec.range_specified := FALSE;
      element_spec.descriptor_address := variable_spec.descriptor_address;
      element_spec.constant_value := FALSE;

      dup$locate_symbol_for_number (home_spec.symbol_table_address, variable_spec.symbol_entry.symbol^.
            conf_array_element_kind, element_spec.symbol_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      reduce_cybil_type (home_spec, element_spec, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
{ Get the value of the lower bound }
      dup$locate_symbol_for_number (home_spec.symbol_table_address, variable_spec.symbol_entry.
            symbol^.conf_array_lower_bound, index_spec.symbol_entry, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      subscript_index := 1;
      scan_cybil_variable (^index_spec.symbol_entry.symbol^.symbol_name, home_spec, subscript_index,
            index_spec, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      get_cybil_value (index_spec, pca_lower_bound, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
{ Get the value of the upper bound }
      dup$locate_symbol_for_number (home_spec.symbol_table_address, variable_spec.symbol_entry.
            symbol^.conf_array_upper_bound, index_spec.symbol_entry, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      subscript_index := 1;
      scan_cybil_variable (^index_spec.symbol_entry.symbol^.symbol_name, home_spec, subscript_index,
            index_spec, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      get_cybil_value (index_spec, pca_upper_bound, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      display_array (variable_spec, pca_lower_bound, pca_upper_bound, p_vs_list, element_spec, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

    = llc$record_kind =
      field_number := variable_spec.symbol_entry.symbol^.record_first_field;
      selector_number := variable_spec.symbol_entry.symbol^.record_selector;

      IF (variable_spec.length = #SIZE (unique_name)) AND NOT variable_spec.length_is_bits AND
         ((home_spec.language = llc$cybil) OR (home_spec.language = llc$obsolete_cybil)) AND
         (variable_spec.symbol_entry.symbol^.symbol_name = 'OST$BINARY_UNIQUE_NAME') THEN
        address := variable_spec.address;
        dup$get_bytes (address, #LOC (unique_name), #SIZE(unique_name), status);

        IF status.normal THEN
          pmp$convert_binary_unique_name (unique_name, name, status);
        IFEND;

        IF status.normal THEN
          value_length := STRLENGTH (name);
          WHILE (value_length > 0) AND (name (value_length) = ' ') DO
            value_length := value_length - 1;
          WHILEND;
          value_string (1) := ' ';
          value_string (2, value_length) := name (1, value_length);
          dup$display_string (display_control_pointer, value_length, value_string (1, value_length + 1),
                indent_count, status);
        IFEND;

        IF status.normal THEN
          field_number := 0;
        IFEND;
      IFEND;

    /display_fields/
      WHILE field_number > 0 DO
        dup$locate_symbol_for_number (home_spec.symbol_table_address, field_number, field_spec.symbol_entry,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        field_spec.name := field_spec.symbol_entry.symbol^.symbol_name;
        field_spec.length := field_spec.symbol_entry.symbol^.field_length;
        field_number := field_spec.symbol_entry.symbol^.next_field;
        IF field_spec.length <> 0 THEN
          field_spec.length_is_bits := NOT (llc$field_is_byte_addressable IN field_spec.symbol_entry.symbol^.
                field_attributes);
          field_spec.range_specified := FALSE;
          field_spec.address := variable_spec.address;
          field_spec.descriptor_address := variable_spec.descriptor_address;
          IF field_spec.length_is_bits THEN
            field_offset := variable_spec.bit_offset + field_spec.symbol_entry.symbol^.field_offset;
            field_spec.address.offset := field_spec.address.offset + (field_offset DIV bits_per_byte);
            field_spec.bit_offset := field_offset MOD bits_per_byte;
          ELSE
            field_spec.address.offset := field_spec.address.offset + field_spec.symbol_entry.symbol^.
                  field_offset;
            field_spec.bit_offset := variable_spec.bit_offset;
          IFEND;
          reduce_cybil_type (home_spec, field_spec, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF display_control_pointer^.column_number > indent_count + 1 THEN
            clp$new_display_line (display_control_pointer^, clc$next_display_line, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
          clp$horizontal_tab_display (display_control_pointer^, indent_count + 2, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          value_string := field_spec.name;
          value_length := 31;
          WHILE value_string(value_length) = ' ' DO
            value_length := value_length - 1;
          WHILEND;
          IF NOT(llc$language_is_case_sensitive IN home_spec.symbol_table_address^.attributes) THEN
{ For non-case sensitive languages, put the field name out in lower case.  This
{  makes the display look a little nicer.
            FOR i := 1 TO value_length DO
              IF (value_string(i) >= 'A') AND
                 (value_string(i) <= 'Z') THEN
                value_string(i) := $CHAR($INTEGER(value_string(i)) + 20(16));
              IFEND;
            FOREND;
          IFEND;
          value_string(value_length + 1) := ':';
          value_length := value_length + 1;
{ Display the field name followed by a colon.
          dup$display_string (display_control_pointer, value_length,
                   value_string(1,value_length), indent_count, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          field_spec.attribute := duc$variable_value;
          field_spec.constant_value := FALSE;
          format_and_display_variable (home_spec, field_spec, NIL, indent_count + record_indent,
                display_type, p_vs_list, display_control_pointer, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          reduce_cybil_type (home_spec, field_spec, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF (field_number = 0) AND (selector_number > 0) THEN
{ Display variant part of record.  If the length of the previous field is
{  non-zero, that field is the tag, and its value determines the format of
{  the variant field.  If the length of the previous field is zero, the
{  VS parameter (if present) is used as the tag.
          select_any := FALSE;
          IF field_spec.length = 0 THEN
{ We have a tagless record }
            IF (p_vs_list = NIL) THEN {no more variant selections left}
              IF display_control_pointer^.column_number > indent_count + 1 THEN
                clp$new_display_line (display_control_pointer^, clc$next_display_line, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              IFEND;
              clp$horizontal_tab_display (display_control_pointer^, indent_count + 1, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              dup$display_string (display_control_pointer, 67,
                '**VS PARAMETER DOES NOT CONTAIN ENOUGH INFORMATION TO DISPLAY TAGLESS VARIANT**',
                indent_count, status);
              RETURN; {------->
            ELSE {find variant from next variant selection}
              vs_value := p_vs_list^.element_value^;
              err_msg := '';
              CASE vs_value.kind OF
              = clc$integer =
                selector_value := vs_value.integer_value.value;
              = clc$boolean =
                selector_value := $INTEGER(vs_value.boolean_value.value);
              = clc$string =
                selector_value := STRLENGTH (vs_value.string_value^);
                IF (selector_value <> 1) THEN
                  err_msg := '**VARIANT SELECTION NUMBER ';
                  STRINGREP (err_msg(27,*), value_length, vs_current_entry);
                  err_msg(27+value_length,*) := ' IS NOT A SCALAR TYPE**';
                IFEND;
                IF (selector_value > 0) THEN
                  selector_value := $INTEGER(vs_value.string_value^ (1));
                IFEND;
              = clc$name =
                ordinal_entry := field_spec.symbol_entry;
                IF (vs_value.name_value = 'TRUE') THEN
                  selector_value := 1;    { TRUE value }
                ELSEIF (vs_value.name_value = 'FALSE') THEN
                  selector_value := 0;    { FALSE value }
                ELSEIF (vs_value.name_value = '$FIRST') THEN
                  select_any := TRUE;     { any selection will do
                ELSEIF ordinal_entry.symbol^.symbol_kind <> llc$ordinal_kind THEN
                  err_msg := '**VARIANT SELECTION NUMBER ';
                  STRINGREP (err_msg(27,*), value_length, vs_current_entry);
                  err_msg(27+value_length,*) := ' IS THE WRONG TYPE** ';
                ELSE { the vs specified is an ordinal and should be }
                  symbol_index := ordinal_entry.symbol^.last_constant;
/ordinal_search/
                  BEGIN
                    REPEAT
                      dup$locate_next_symbol (home_spec.symbol_table_address, ordinal_entry, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;
                      IF (ordinal_entry.symbol^.symbol_name = vs_value.name_value) THEN
                        selector_value := ordinal_entry.symbol^.short_constant_value.integer_value;
                        EXIT /ordinal_search/;
                      IFEND;
                    UNTIL ordinal_entry.symbol^.symbol_number = symbol_index;
                    err_msg := '**VARIANT SELECTION NUMBER ';
                    STRINGREP (err_msg(27,*), value_length, vs_current_entry);
                    err_msg(27+value_length,*) := ', ORDINAL NOT FOUND** ';
                  END /ordinal_search/;
                IFEND;
              ELSE  { Illegal type for VS parameter }
                err_msg := '**VARIANT SELECTION NUMBER ';
                STRINGREP (err_msg(27,*), value_length, vs_current_entry);
                err_msg(27+value_length,*) := ' IS NOT A SCALAR TYPE**';
              CASEND;
              IF err_msg <> '' THEN
                IF display_control_pointer^.column_number > indent_count + 1 THEN
                  clp$new_display_line (display_control_pointer^, clc$next_display_line, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;
                IFEND;
                clp$horizontal_tab_display (display_control_pointer^, indent_count + 1, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                dup$display_string (display_control_pointer, 50+value_length, err_msg,
                   indent_count, status);
                RETURN; {------->
              IFEND;
              vs_current_entry := vs_current_entry + 1;
              p_vs_list := p_vs_list^.link;
            IFEND;
          ELSE  { here if there is a tag field }
            get_cybil_value (field_spec, selector_value, status); {last
            {field is selector}
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

/find_variant/
          REPEAT
            dup$locate_symbol_for_number (home_spec.symbol_table_address,
                                     selector_number, selector_entry, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF (select_any = TRUE) OR
               ((selector_entry.symbol^.low_selector <= selector_value) AND
               (selector_entry.symbol^.high_selector >= selector_value)) THEN
              dup$locate_symbol_for_number (home_spec.symbol_table_address,
                      selector_entry.symbol^.variation, variant_entry, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              field_number := variant_entry.symbol^.record_first_field;
              selector_number := variant_entry.symbol^.record_selector;
              EXIT /find_variant/;
            IFEND;
            selector_number := selector_entry.symbol^.next_selector;
          UNTIL selector_number = 0; {/find_variant/}
          IF (field_number = 0) AND
             (field_spec.length = 0) THEN
            IF display_control_pointer^.column_number > indent_count + 1 THEN
              clp$new_display_line (display_control_pointer^, clc$next_display_line, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
            clp$horizontal_tab_display (display_control_pointer^, indent_count + 1, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            err_msg := '**VARIANT SELECTION NUMBER ';
            STRINGREP (err_msg(27,*), value_length, vs_current_entry-1);
            err_msg(27+value_length,*) := ' IS OUT OF RANGE**';
            dup$display_string (display_control_pointer, 45+value_length, err_msg,
                   indent_count, status);
            RETURN; {------->
          IFEND;
        IFEND;  { If there is a variant portion of the record }
      WHILEND /display_fields/;

      IF ((home_spec.language = llc$cybil) OR (home_spec.language = llc$obsolete_cybil)) AND
        (i#compare_collated (variable_spec.symbol_entry.symbol^.symbol_name,'OST$STATUS',
        osv$lower_to_upper) = 0) THEN
          address := variable_spec.address;
          dup$get_bytes (address, #LOC (local_status), #SIZE (local_status), status);
          IF (status.normal AND NOT local_status.normal) THEN
          osp$format_message (local_status, osc$full_message_level,
            display_control_pointer^.page_width, message, status);
          IF status.normal THEN
            clp$put_partial_display (display_control_pointer^, '',
              clc$no_trim, amc$terminate, status);
            IF NOT status.normal THEN
              status.normal := TRUE;
              return; {------->
            IFEND;
            osp$set_status_abnormal (duc$symbolic_id,
              due$formatted_status_is, osc$null_name, local_status1);
            dup$output_message (local_status1, display_control_pointer,
              status);
            IF NOT status.normal THEN
              status.normal := TRUE;
              return; {------->
            IFEND;
            message_area := ^message;
            RESET message_area;
            NEXT message_line_count IN message_area;
            FOR message_line_index := 1 TO message_line_count^ DO
              NEXT message_line_size IN message_area;
              NEXT message_line: [message_line_size^] IN message_area;
              clp$put_display (display_control_pointer^, message_line^, clc$no_trim, status);
              IF NOT status.normal THEN
                status.normal := TRUE;
                return; {------->
              IFEND;
           FOREND;
           IFEND;
         IFEND;
       IFEND;

    = llc$heap_kind =
      dup$display_string (display_control_pointer, 11, ' ** HEAP **', indent_count, status);

    = llc$seq_kind =
      dup$display_string (display_control_pointer, 15, ' ** SEQUENCE **', indent_count, status);

    = llc$rel_ptr_kind =
      vspec := variable_spec;
      vspec.length := 4;
      get_cybil_value (vspec, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      STRINGREP (value_string, value_length, value: : #(16));
      dup$display_string (display_control_pointer, value_length,
                  value_string(1, value_length), indent_count, status);
      dup$display_string (display_control_pointer, 4, '(16)', indent_count, status);

    = llc$pascal_file_kind =

{ Pascal files are of the following format :
{                  eof: boolean, (1 byte)
{                  eol: boolean, (1 byte)
{                  mode: 0=null,1=read,2=write (1 byte)
{                  other stuff: ?  (1 byte)
{                  empty: boolean, (1 byte)
{                  buffer_defined: boolean, (1 byte)
{                  buffer: buffer type (any type)

      element_spec := variable_spec;
      clp$new_display_line (display_control_pointer^, clc$next_display_line, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
{ Display EOF information }
      dup$display_string (display_control_pointer, 8, '   EOF: ',
              indent_count + record_indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      pascal_file_ptr := #LOC(element_spec.address);
      IF pascal_file_ptr^^ = TRUE THEN
        dup$display_string (display_control_pointer, 6, ' TRUE ', indent_count, status);
      ELSE
        dup$display_string (display_control_pointer, 6, ' FALSE', indent_count, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
{ Display EOL information }
      clp$new_display_line (display_control_pointer^, clc$next_display_line, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      dup$display_string (display_control_pointer, 8, '   EOL: ',
                 indent_count + record_indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      element_spec.address.offset := element_spec.address.offset + 1;
      pascal_file_ptr := #LOC(element_spec.address);
      IF pascal_file_ptr^^ = TRUE THEN
        dup$display_string (display_control_pointer, 6, ' TRUE ', indent_count, status);
      ELSE
        dup$display_string (display_control_pointer, 6, ' FALSE', indent_count, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
{ Display mode information }
      clp$new_display_line (display_control_pointer^, clc$next_display_line, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      dup$display_string (display_control_pointer, 8, '  MODE: ',
                 indent_count + record_indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      element_spec.address.offset := element_spec.address.offset + 1;
      pascal_file_ptr2 := #LOC(element_spec.address);
      IF pascal_file_ptr2^^ = 1 THEN
        dup$display_string (display_control_pointer, 6, ' READ ', indent_count, status);
      ELSEIF pascal_file_ptr2^^ = 2 THEN
        dup$display_string (display_control_pointer, 6, ' WRITE', indent_count, status);
      ELSEIF pascal_file_ptr2^^ = 3 THEN
        dup$display_string (display_control_pointer, 4, ' R/W', indent_count, status);
      ELSE
        dup$display_string (display_control_pointer, 10, ' UNDEFINED', indent_count, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
{ Display Empty information }
      clp$new_display_line (display_control_pointer^, clc$next_display_line, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      dup$display_string (display_control_pointer, 8, ' EMPTY: ',
                 indent_count + record_indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      element_spec.address.offset := element_spec.address.offset + 2;
      pascal_file_ptr := #LOC(element_spec.address);
      IF pascal_file_ptr^^ = TRUE THEN
        dup$display_string (display_control_pointer, 6, ' TRUE ', indent_count, status);
      ELSE
        dup$display_string (display_control_pointer, 6, ' FALSE', indent_count, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
{ If the buffer is defined, display it }
      clp$new_display_line (display_control_pointer^, clc$next_display_line, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      dup$display_string (display_control_pointer, 8, 'BUFFER: ',
                    indent_count + record_indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      element_spec.address.offset := element_spec.address.offset + 1;
{ Check the buffer defined byte }
      pascal_file_ptr2 := #LOC(element_spec.address);
      IF pascal_file_ptr2^^ = 1 THEN
{ Display the buffer }
        element_spec.address.offset := element_spec.address.offset + 1;
        element_spec.length := element_spec.length - 6;
        element_spec.name := ' ';
        dup$locate_symbol_for_number (home_spec.symbol_table_address, variable_spec.symbol_entry.symbol^.
              buffer_type, element_spec.symbol_entry, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        reduce_cybil_type (home_spec, element_spec, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        format_and_display_variable (home_spec, element_spec, NIL, indent_count,
                  display_type, p_vs_list, display_control_pointer, status);
      ELSE
        dup$display_string (display_control_pointer, 13, '**UNDEFINED**',
                 indent_count + record_indent, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    ELSE
      dup$display_string (display_control_pointer, 26, '** UNEXPECTED DATA TYPE **', indent_count, status);
    CASEND;
  PROCEND format_and_display_variable;
?? TITLE := 'get_adaptable_bounds', EJECT ??

  PROCEDURE get_adaptable_bounds (home_spec: dut$home_specification;
        variable_name: pmt$program_name;
        index_type: llt$symbol_number;
        parameter_value: ^string ( * );
    VAR parameter_index: {input, output} clt$string_index;
    VAR lower_bound: integer;
    VAR upper_bound: integer;
    VAR status: ost$status);

    VAR
      bounds_specified: boolean,
      index_symbol: dut$symbol_entry,
      spaces: boolean,
      token: clt$lexical_token;

    dup$locate_symbol_for_number (home_spec.symbol_table_address, index_type, index_symbol, status);

    IF status.normal AND (index_symbol.symbol^.symbol_kind <> llc$subrange_kind) THEN
      osp$set_status_abnormal (duc$symbolic_id, due$unsupported_subscript_type, '', status);
    IFEND;

    IF status.normal THEN
      clp$evaluate_token (parameter_value^, scan_options, parameter_index, spaces, token, status);
    IFEND;

    bounds_specified := FALSE;
    IF status.normal THEN
      IF (token.kind = clc$left_bracket_token) THEN
        clp$evaluate_token (parameter_value^, scan_options, parameter_index, spaces, token, status);

        IF status.normal THEN
          IF (token.kind = clc$unsigned_integer_token) OR (token.kind = clc$signed_integer_token) THEN
            lower_bound := token.int.value;
            clp$evaluate_token (parameter_value^, scan_options, parameter_index, spaces, token, status);
          ELSE
            osp$set_status_abnormal (duc$symbolic_id, due$subscript_error, variable_name, status);
          IFEND;
        IFEND;

        IF status.normal AND (token.kind = clc$ellipsis_token) THEN
          bounds_specified := TRUE;
          clp$evaluate_token (parameter_value^, scan_options, parameter_index, spaces, token, status);

          IF status.normal THEN
            IF (token.kind = clc$unsigned_integer_token) OR (token.kind = clc$signed_integer_token) THEN
              upper_bound := token.int.value;
              clp$evaluate_token (parameter_value^, scan_options, parameter_index, spaces, token, status);
            ELSE
              osp$set_status_abnormal (duc$symbolic_id, due$subscript_error, variable_name, status);
            IFEND;
          IFEND;
        IFEND;

        IF status.normal AND (token.kind <> clc$right_bracket_token) THEN
          osp$set_status_abnormal (duc$symbolic_id, due$subscript_error, variable_name, status);
        IFEND;

      ELSE {no fixer - default to 1 element}
        lower_bound := 1;
        parameter_index := parameter_index - token.text_size;
      IFEND;
    IFEND;

    IF status.normal THEN
      IF bounds_specified THEN
        IF (index_symbol.symbol^.low_value_type <> llc$adaptable_length) AND
           (index_symbol.symbol^.low_value <> lower_bound) THEN
          osp$set_status_abnormal (duc$symbolic_id, due$lowerbound_mismatch, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, index_symbol.symbol^.low_value, 10,
               FALSE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, lower_bound, 10, FALSE, status);
        IFEND;
        IF (index_symbol.symbol^.high_value_type <> llc$adaptable_length) AND
           (index_symbol.symbol^.high_value <> upper_bound) THEN
          osp$set_status_abnormal (duc$symbolic_id, due$upperbound_mismatch, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, index_symbol.symbol^.high_value, 10,
               FALSE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, upper_bound, 10, FALSE, status);
        IFEND;
      ELSEIF (index_symbol.symbol^.low_value_type <> llc$adaptable_length) THEN
        upper_bound := index_symbol.symbol^.low_value + lower_bound - 1;
        lower_bound := index_symbol.symbol^.low_value;
      ELSEIF (index_symbol.symbol^.high_value_type <> llc$adaptable_length) THEN
        lower_bound := index_symbol.symbol^.high_value - lower_bound + 1;
        upper_bound := index_symbol.symbol^.high_value;
      ELSE
        upper_bound := lower_bound;
        lower_bound := 1;
      IFEND;
    IFEND;
  PROCEND get_adaptable_bounds;
?? TITLE := 'get_basic_variable_value', EJECT ??

  PROCEDURE get_basic_variable_value ( variable_name: ^string ( * );
        home_spec: dut$home_specification;
    VAR p_value: ^clt$data_value;
    VAR status: ost$status);

    osp$set_status_abnormal (duc$symbolic_id, due$unsupported_language, 'Basic', status);
  PROCEND get_basic_variable_value;
?? TITLE := 'get_cybil_value', EJECT ??
{ Get the current program value for variables that are 8 or less bytes.

  PROCEDURE get_cybil_value (variable_spec: dut$variable_specification;
    VAR value: integer;
    VAR status: ost$status);

    VAR
      p_value: ^cell,
      ring: ost$ring,
      segment: ost$segment,
      offset: ost$segment_offset,
      source: ost$pva,
      length: integer,
      right_fill: 0 .. bits_per_byte;

    IF variable_spec.length_is_bits THEN
      length := (variable_spec.length + variable_spec.bit_offset + bits_per_byte - 1) DIV bits_per_byte;
      right_fill := bits_per_byte - ((variable_spec.length + variable_spec.bit_offset) MOD bits_per_byte);
      IF right_fill = bits_per_byte THEN
        right_fill := 0;
      IFEND;
    ELSE
      IF variable_spec.bit_offset = 0 THEN
        length := variable_spec.length;
        right_fill := 0;
      ELSE
        length := variable_spec.length + 1;
        right_fill := bits_per_byte - variable_spec.bit_offset;
      IFEND;
    IFEND;

    value := 0;
    IF (length <= 8) THEN
      p_value := #LOC (value);
      ring := #RING (p_value);
      segment := #SEGMENT (p_value);
      offset := #OFFSET (p_value);
      offset := offset + 8 - length;
      source := variable_spec.address;
      dup$get_bytes (source, #ADDRESS (ring, segment, offset), length, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      osp$set_status_abnormal (duc$symbolic_id, due$internal_error,
            'get_cybil_value called for variable larger than one word', status);
      RETURN;
    IFEND;

    IF right_fill > 0 THEN {right shift}
      value := value DIV powers_of_two [right_fill];
    IFEND;
    IF variable_spec.length_is_bits THEN {isolate value}
      value := value MOD powers_of_two [variable_spec.length];
    ELSEIF variable_spec.bit_offset > 0 THEN
      value := value MOD powers_of_two [variable_spec.length * bits_per_byte];
    IFEND;

  PROCEND get_cybil_value;
?? TITLE := 'get_cybil_variable_value', EJECT ??

  PROCEDURE get_cybil_variable_value (
        variable_name: ^string ( * );
        home_spec: dut$home_specification;
        display_type: dut$display_type;
    VAR p_work: ^clt$work_area;
    VAR p_value: ^clt$data_value;
    VAR status: ost$status);

    VAR
      local_home_spec: dut$home_specification,
      value_index: clt$string_index,
      variable_spec: dut$variable_specification;

    local_home_spec := home_spec;
    CASE home_spec.language OF
    = llc$cybil, llc$obsolete_cybil,
      llc$pascal =
      value_index := 1;
      scan_cybil_variable (variable_name, home_spec, value_index, variable_spec, status);
    = llc$the_c_language =
      value_index := 1;
{ If we are dealing with a global variable, home_spec will change
      scan_c_variable (variable_name, local_home_spec, value_index,
           variable_spec, status);
    ELSE
      scan_universal_variable (variable_name, home_spec, variable_spec,
                   status);
    CASEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    get_variable_value (variable_name, variable_spec, local_home_spec, display_type, p_work, p_value,
          status);
  PROCEND get_cybil_variable_value;
?? TITLE := 'get_fortran_variable_value', EJECT ??

  PROCEDURE get_fortran_variable_value (variable_name: ^string ( * );
        home_spec: dut$home_specification;
    VAR p_value: ^clt$data_value;
    VAR status: ost$status);

    osp$set_status_abnormal (duc$symbolic_id, due$unsupported_language, 'Fortran', status);
  PROCEND get_fortran_variable_value;
?? TITLE := 'get_index_value', EJECT ??

  PROCEDURE get_index_value (VAR home_spec: dut$home_specification;
        variable_name: pmt$program_name;
        index_symbol: dut$symbol_entry;
        parameter_value: ^string ( * );
    VAR parameter_index: {input, output} clt$string_index;
    VAR index_value: integer;
    VAR status: ost$status);

    VAR
      index_variable: dut$variable_specification,
      ordinal_entry: dut$symbol_entry,
      ordinal_token: string (osc$max_name_size),
      scan_index: clt$string_index,
      scan_length: integer,
      spaces_preceded_token: boolean,
      subscript_is_constant: boolean,
      subscript_length: clt$string_size,
      token: clt$lexical_token;

    { Parse index value from input }

    scan_length := STRLENGTH (parameter_value^) - parameter_index + 1;
    scan_index := 1;
    clp$evaluate_token (parameter_value^ (parameter_index, scan_length), scan_options,
            scan_index, spaces_preceded_token, token, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Interpret input value according to index type }

    subscript_is_constant := FALSE;
    CASE index_symbol.symbol^.symbol_kind OF
    = llc$integer_kind =
      IF (token.kind = clc$unsigned_integer_token) OR (token.kind = clc$signed_integer_token) THEN
        subscript_is_constant := TRUE;
        index_value := token.int.value;
      IFEND;

    = llc$boolean_kind =
      IF token.kind = clc$simple_name_token THEN
        IF (token.str.size = 4) AND (token.str.value(1,4) = 'TRUE') THEN
          subscript_is_constant := TRUE;
          index_value := true_value;
        ELSEIF (token.str.size = 5) AND (token.str.value(1,5) = 'FALSE') THEN
          subscript_is_constant := TRUE;
          index_value := false_value;
        IFEND;
      IFEND;

    = llc$char_kind =
      IF token.kind = clc$string_token THEN
        IF token.str.size = 1 THEN
          subscript_is_constant := TRUE;
          index_value := ORD (token.str.value (1));
        IFEND;
      IFEND;

    = llc$ordinal_kind =
      IF (token.kind = clc$simple_name_token) OR (token.kind = clc$cybil_name_token) THEN
        ordinal_entry := index_symbol; { ordinal values follow the ordinal entry }

      /search_ordinal_values/
        REPEAT
          dup$locate_next_symbol (home_spec.symbol_table_address, ordinal_entry, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF llc$language_is_case_sensitive IN home_spec.symbol_table_address^.attributes THEN
            ordinal_token := parameter_value^(parameter_index, token.str.size);
          ELSE
            ordinal_token := token.str.value(1, token.str.size);
          IFEND;
          IF ordinal_token = ordinal_entry.symbol^.symbol_name THEN
            subscript_is_constant := TRUE;
            IF ordinal_entry.symbol^.constant_kind = llc$short_constant THEN
              index_value := ordinal_entry.symbol^.short_constant_value.integer_value;
            ELSE { assume medium constant }
              index_value := ordinal_entry.symbol^.medium_constant_value.integer_value;
            IFEND;
            EXIT /search_ordinal_values/;
          IFEND;
        UNTIL ordinal_entry.symbol^.symbol_number = index_symbol.symbol^.last_constant;
      IFEND;

    ELSE
    CASEND;

    { Use constant value or get value of variable index }

    IF subscript_is_constant THEN
      parameter_index := parameter_index + scan_index - 1;
    ELSE {may be a variable reference}
      find_end_of_subscript (parameter_value^(parameter_index, scan_length), subscript_length);
      IF subscript_length = 0 THEN
        osp$set_status_abnormal (duc$symbolic_id, due$subscript_error, variable_name, status);
        RETURN;
      IFEND;
      IF home_spec.language = llc$the_c_language THEN
        scan_c_variable (^parameter_value^(1,parameter_index + subscript_length - 1),
              home_spec, parameter_index, index_variable, status);
      ELSE
        scan_cybil_variable (^parameter_value^(1,parameter_index + subscript_length - 1),
              home_spec, parameter_index, index_variable, status);
      IFEND;

      IF NOT status.normal THEN
        osp$set_status_abnormal (duc$symbolic_id, due$invalid_type_for_subscript, variable_name, status);
        RETURN;
      IFEND;

      IF index_variable.symbol_entry.symbol <> index_symbol.symbol THEN

        { For simple types, allow the index if the symbol_kinds are equal }

        IF (NOT(index_variable.symbol_entry.symbol^.symbol_kind IN simple_types)) OR
           (index_variable.symbol_entry.symbol^.symbol_kind <> index_symbol.symbol^.symbol_kind) THEN
          osp$set_status_abnormal (duc$symbolic_id, due$invalid_type_for_subscript, variable_name, status);
          RETURN;
        IFEND;
      IFEND;
      get_cybil_value (index_variable, index_value, status);
    IFEND;
  PROCEND get_index_value;
?? TITLE := 'get_trimmed_name', EJECT ??

  PROCEDURE get_trimmed_name (p_name: ^ost$name;
    VAR p_trimmed_name: ^clt$string_value);

    VAR
      size: integer;

    size := 0;
    IF (p_name <> NIL) AND (p_name^ (1) <> ' ') THEN
      size := STRLENGTH (p_name^);
      WHILE (p_name^ (size) = ' ') DO
        size := size - 1;
      WHILEND;
    IFEND;
    IF (size > 0) THEN
      p_trimmed_name := ^p_name^ (1, size);
    ELSE
      p_trimmed_name := NIL;
    IFEND;
  PROCEND get_trimmed_name;
?? TITLE := 'get_value_string', EJECT ??

  PROCEDURE get_value_string (p_value: ^clt$data_value;
    VAR p_work_area: {input, output} ^SEQ (*);
    VAR p_string: ^clt$string_value);

    VAR
      length: clt$string_size,
      status: ost$status,
      str: ost$string;

    IF (p_value = NIL) THEN
       p_string := NIL;
    ELSE
      CASE p_value^.kind OF

      = clc$application =
        p_string := p_value^.application_value;

      = clc$cobol_name =
        get_trimmed_name (^p_value^.cobol_name_value, p_string);

      = clc$data_name =
        get_trimmed_name (^p_value^.data_name_value, p_string);

      = clc$file =
        p_string := p_value^.file_value;

      = clc$integer =
        clp$convert_integer_to_string (p_value^.integer_value.value, p_value^.integer_value.radix,
              p_value^.integer_value.radix_specified, str, status);
        length := str.size;
        NEXT p_string: [length] IN p_work_area;
        IF (p_string <> NIL) THEN
          p_string^ := str.value (1, length);
          IF (str.value (1) = ' ') THEN
            p_string := ^p_string^ (2, length - 1);
          IFEND;
        IFEND;

      = clc$keyword =
        get_trimmed_name (^p_value^.keyword_value, p_string);

      = clc$name =
        get_trimmed_name (^p_value^.name_value, p_string);

      = clc$program_name =
        get_trimmed_name (^p_value^.program_name_value, p_string);

      = clc$string =
        p_string := p_value^.string_value;

      ELSE
        p_string := NIL;
      CASEND;
    IFEND;
  PROCEND get_value_string;
?? TITLE := 'get_variable_attribute', EJECT ??

  PROCEDURE get_variable_attribute (home_spec: dut$home_specification;
        variable_spec: dut$variable_specification;
    VAR storage: integer;
    VAR attribute_spec: dut$variable_specification;
    VAR status: ost$status);

    VAR
      address: ost$pva,
      integer_symbol: [STATIC] llt$symbol_table_item,
      length: integer,
      pointer_symbol: [STATIC] llt$symbol_table_item,
      scalars: [STATIC, READ] SET OF llt$entry_kind := [llc$integer_kind, llc$boolean_kind,
            llc$char_kind, llc$cell_kind, llc$ordinal_kind, llc$subrange_kind];

    status.normal := TRUE;
    attribute_spec := variable_spec;
    length := 8;

    IF (variable_spec.attribute = duc$variable_value) THEN
      RETURN;
    IFEND;

    CASE variable_spec.attribute OF

    = duc$variable_address =
      IF variable_spec.bit_offset > 0 THEN
        osp$set_status_abnormal (duc$symbolic_id, due$unaligned_pointer, variable_spec.name, status);
        RETURN;
      IFEND;

      pointer_symbol.symbol_name := '';
      pointer_symbol.symbol_number := UPPERVALUE (llt$symbol_number);
      pointer_symbol.end_of_chain := TRUE;
      pointer_symbol.symbol_kind := llc$pointer_kind;
      pointer_symbol.ptr_type := UPPERVALUE (llt$symbol_number);
      pointer_symbol.ptr_object_length := 0;

      attribute_spec.symbol_entry.table_entry_index := UPPERVALUE (llt$symbol_number);
      attribute_spec.symbol_entry.symbol := ^pointer_symbol;

      address := variable_spec.address;
      storage := 100000000000(16) * address.ring + 100000000(16) * address.seg + address.offset;
      IF (home_spec.language <> llc$the_c_language) THEN
        length := 6;
      IFEND;

    = duc$variable_size =
      integer_symbol.symbol_name := '';
      integer_symbol.symbol_number := UPPERVALUE (llt$symbol_number);
      integer_symbol.end_of_chain := TRUE;
      integer_symbol.symbol_kind := llc$integer_kind;

      attribute_spec.symbol_entry.table_entry_index := UPPERVALUE (llt$symbol_number);
      attribute_spec.symbol_entry.symbol := ^integer_symbol;

      IF variable_spec.length_is_bits THEN
        storage := (variable_spec.length + 7) DIV 8;
      ELSE
        storage := variable_spec.length;
      IFEND;

    = duc$variable_lower_bound, duc$variable_upper_bound =
      IF (variable_spec.symbol_entry.symbol^.symbol_kind <> llc$cybil_array_kind) THEN
        IF (variable_spec.attribute = duc$variable_lower_bound) THEN
          osp$set_status_abnormal (duc$symbolic_id, due$lowerbound_non_array, '', status);
        ELSE
          osp$set_status_abnormal (duc$symbolic_id, due$upperbound_non_array, '', status);
        IFEND;
        RETURN;
      IFEND;

      dup$locate_symbol_for_number (home_spec.symbol_table_address, attribute_spec.symbol_entry.symbol^.
            cybil_index_type, attribute_spec.symbol_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      reduce_cybil_type (home_spec, attribute_spec, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (variable_spec.attribute = duc$variable_lower_bound) THEN
        storage := attribute_spec.low_value;
      ELSE
        storage := attribute_spec.high_value;
      IFEND;

    = duc$variable_lower_value, duc$variable_upper_value =
      IF NOT (variable_spec.symbol_entry.symbol^.symbol_kind IN scalars) THEN
        IF (variable_spec.attribute = duc$variable_lower_value) THEN
          osp$set_status_abnormal (duc$symbolic_id, due$lowervalue_non_scalar, '', status);
        ELSE
          osp$set_status_abnormal (duc$symbolic_id, due$uppervalue_non_scalar, '', status);
        IFEND;
        RETURN;
      IFEND;

      IF variable_spec.constant_value THEN
        get_cybil_value (variable_spec, storage, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSEIF (variable_spec.attribute = duc$variable_lower_value) THEN
        storage := attribute_spec.low_value;
      ELSE
        storage := attribute_spec.high_value;
      IFEND;

    ELSE
    CASEND;

    attribute_spec.attribute := duc$variable_value;
    attribute_spec.length := length;
    attribute_spec.bit_offset := 0;
    attribute_spec.length_is_bits := FALSE;
    attribute_spec.address.ring := osc$invalid_ring {flag local address};
    attribute_spec.address.seg := #SEGMENT (^storage);
    attribute_spec.address.offset := #OFFSET (^storage) + #SIZE (storage) - length;
  PROCEND get_variable_attribute;
?? TITLE := 'get_variable_spec', EJECT ??

  PROCEDURE get_variable_spec (home_spec: dut$home_specification;
        name: pmt$program_name;
        p_text: ^string (*);
        address_wanted: boolean;
    VAR text_index: {input, output} clt$string_index;
    VAR variable_spec: dut$variable_specification;
    VAR status: ost$status);

    CONST
      lower_bound_function = 'LOWERBOUND                     ',
      lower_value_function = 'LOWERVALUE                     ',
      size_function = '#SIZE                          ',
      upper_bound_function = 'UPPERBOUND                     ',
      upper_value_function = 'UPPERVALUE                     ';

    VAR
      attribute: dut$variable_attribute,
      index: clt$string_index,
      nested: boolean,
      open_paren_count: integer,
      options: [STATIC] dut$variable_search_options := [duc$search_outer_procedures,
                                                        duc$search_module_level],
      p_param: ^string (*),
      param_start: clt$string_index,
      proc_entry: dut$symbol_entry,
      spaces: boolean,
      symbol_entry: dut$symbol_entry,
      text_size: clt$string_size,
      token: clt$lexical_token;

    IF (name = size_function) THEN
      attribute := duc$variable_size;
    ELSEIF (name = lower_bound_function) THEN
      attribute := duc$variable_lower_bound;
    ELSEIF (name = upper_bound_function) THEN
      attribute := duc$variable_upper_bound;
    ELSEIF (name = lower_value_function) THEN
      attribute := duc$variable_lower_value;
    ELSEIF (name = upper_value_function) THEN
      attribute := duc$variable_upper_value;
    ELSEIF address_wanted THEN
      attribute := duc$variable_address;
    ELSE
      attribute := duc$variable_value;
    IFEND;

    IF address_wanted AND (attribute <> duc$variable_address) THEN
      osp$set_status_abnormal (duc$symbolic_id, due$invalid_address_constructor, '', status);
      RETURN;
    IFEND;

    IF (attribute = duc$variable_value) OR (attribute = duc$variable_address) THEN
      variable_spec.attribute := attribute;
      dup$locate_variable_symbol (name, home_spec, options, symbol_entry, nested, proc_entry, status);

      IF status.normal THEN
        dup$build_variable_spec (home_spec, symbol_entry, nested, proc_entry, variable_spec, status);
      IFEND;
    ELSE {attribute wanted}
      clp$evaluate_token (p_text^, scan_options, text_index, spaces, token, status);

      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (token.kind <> clc$left_parenthesis_token) THEN
        osp$set_status_abnormal (duc$symbolic_id, due$missing_function_parameters, name, status);
        RETURN;
      IFEND;

      text_size := STRLENGTH (p_text^);
      param_start := text_index;
      open_paren_count := 1;
      WHILE (text_index <= text_size) AND (open_paren_count > 0) DO
        IF (p_text^ (text_index) = ')') THEN
          open_paren_count := open_paren_count - 1;
        ELSEIF (p_text^ (text_index) = '(') THEN
          open_paren_count := open_paren_count + 1;
        IFEND;
        text_index := text_index + 1;
      WHILEND;

      IF (open_paren_count <> 0) THEN
        osp$set_status_abnormal (duc$symbolic_id, due$unbalanced_function_parens, name, status);
        RETURN;
      ELSEIF (text_index <= text_size) THEN
        osp$set_status_abnormal (duc$symbolic_id, due$expression_end_expected,
              p_text^ (text_index, *), status);
        RETURN;
      IFEND;

      p_param := ^p_text^ (param_start, text_index - param_start - 1);
      index := 1;
      scan_cybil_variable (p_param, home_spec, index, variable_spec, status);

      IF status.normal THEN
        IF (variable_spec.attribute = duc$variable_value) THEN
          variable_spec.attribute := attribute;
        ELSE
          osp$set_status_abnormal (duc$symbolic_id, due$invalid_function_nesting, '', status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND get_variable_spec;
?? TITLE := 'get_variable_value', EJECT ??

  PROCEDURE get_variable_value (
        variable_name: ^string ( * );
        input_variable_spec: dut$variable_specification;
        home_spec: dut$home_specification;
        display_type: dut$display_type;
    VAR p_work: ^clt$work_area;
    VAR p_value: ^clt$data_value;
    VAR status: ost$status);

{     This routine is called by several languages to return the variable value
{      given a variable_spec.  Special types for FORTRAN and COBOL are not
{      included here.

    VAR
      address: ost$pva,
      address_of_leftmost_part: ost$pva,
      address_of_rightmost_part: ost$pva,
      converter: ptr_pva_conversion,
      pointer: 0 .. 0ffffffffffff(16),
      program_value: integer,
      real_value_pointer: ^^real,
      real_var: real,
      storage: integer,
      temporary_value: integer,
      unique_name: ost$binary_unique_name,
      value_of_leftmost_part_ptr: ^real,
      value_of_rightmost_part_ptr: ^real,
      var_sym_entry: dut$symbol_entry,
      variable_kind: llt$entry_kind,
      variable_spec: dut$variable_specification;

    get_variable_attribute (home_spec, input_variable_spec, storage, variable_spec, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ For constants, we need to find out what kind of constant it is. }

    variable_kind := variable_spec.symbol_entry.symbol^.symbol_kind;
    var_sym_entry := variable_spec.symbol_entry;
    IF variable_kind = llc$constant_kind THEN
      IF (variable_spec.symbol_entry.symbol^.constant_kind = llc$long_constant) AND
         ((home_spec.symbol_table_address^.language = llc$cybil) OR
         (home_spec.symbol_table_address^.language = llc$obsolete_cybil)) THEN
        osp$set_status_abnormal (duc$symbolic_id, due$parms_only_message,
               '***CYBIL long constants not available***', status);
        RETURN; {we cannot get the value of CYBIL long constants}
      IFEND;
      dup$locate_symbol_for_number (home_spec.symbol_table_address, variable_spec.symbol_entry.symbol^.
            constant_type, var_sym_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      variable_kind := var_sym_entry.symbol^.symbol_kind;
      IF (variable_kind = llc$bit_kind) THEN
        variable_kind := llc$integer_kind; { bit constants will display as integers}
      IFEND;
      IF (variable_kind = llc$ordinal_kind) AND
         ((variable_spec.symbol_entry.symbol^.symbol_number > var_sym_entry.symbol^.symbol_number) AND
          (variable_spec.symbol_entry.symbol^.symbol_number <= var_sym_entry.symbol^.last_constant)) THEN
        variable_kind := llc$integer_kind; { ordinal member constants will display as integers}
      IFEND;
    IFEND;

    IF (display_type = duc$integer_type) THEN
      variable_kind := llc$integer_kind;
    IFEND;

    NEXT p_value IN p_work;

    CASE variable_kind OF

    = llc$integer_kind =

      get_cybil_value (variable_spec, program_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      p_value^.kind := clc$integer;
      p_value^.integer_value.value := program_value;
      p_value^.integer_value.radix := 16;
      p_value^.integer_value.radix_specified := TRUE;

    = llc$boolean_kind =

      get_cybil_value (variable_spec, program_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (program_value = false_value) OR (program_value = true_value) THEN
        p_value^.kind := clc$boolean;
        p_value^.boolean_value.value := (program_value = true_value);
        p_value^.boolean_value.kind := clc$true_false_boolean;
      ELSE
        osp$set_status_abnormal (duc$symbolic_id, due$invalid_boolean_value,
              variable_name^, status);
      IFEND;

    = llc$char_kind =

      get_cybil_value (variable_spec, program_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      p_value^.kind := clc$string;
      NEXT p_value^.string_value: [1] IN p_work;
      p_value^.string_value^ (1) := CHR (program_value);

    = llc$ordinal_kind =

      get_cybil_value (variable_spec, program_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (program_value < 0) OR
         (program_value > var_sym_entry.symbol^.ordinal_upper_bound) THEN
        osp$set_status_abnormal (duc$symbolic_id, due$invalid_ordinal_value,
              variable_name^, status);
      ELSE
      /find_ordinal/
        WHILE TRUE DO
          dup$locate_next_symbol (home_spec.symbol_table_address,
                var_sym_entry, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          CASE var_sym_entry.symbol^.constant_kind OF
          = llc$short_constant =
            temporary_value := var_sym_entry.symbol^.short_constant_value.integer_value;
          = llc$medium_constant =
            temporary_value := var_sym_entry.symbol^.medium_constant_value.integer_value;
          = llc$long_constant =
            osp$set_status_abnormal (duc$symbolic_id, due$internal_error,
              'Long_constants not supported as ordinal entries.', status);
            return; {------->
          CASEND;
          IF program_value = temporary_value THEN
            EXIT /find_ordinal/;
          IFEND;
        WHILEND /find_ordinal/;
        p_value^.kind := clc$name;
        p_value^.name_value := var_sym_entry.symbol^.symbol_name;
      IFEND;

{3/86 - The following comments document the reason why code for longreals and reals was developed
{in this manner.
{
{ 1. Cybil cannot deal with longreals properly.  For example, it does not understand assignment
{    of longreals and dereference of pointers to longreal types.
{ 2. Clt$value expects a longreal - this is permanent and independent of Cybil's longreal problem.
{ 3. The addess of the longreal value provided by variable_spec.address is a pva - this is also
{     permanent and independent of Cybil's longreal problem.
{
{Because of 1.2.3 we have the assignment of the longreal value addressed by variable_spec.address
{(which is a pva).  The longreal value represented by real_value.value has to be done in two parts,
{assignment of the leftmost part and assignment of the rightmost part.  If the value addressed by
{variable_spec.address is just of real type, then only a leftmost part exists and the righmost part
{of real_value    ue is set to 0.  In order to find the address of the rightmost part of real_value.
{value, the type converter, ptr_pva_conversion, is used.
{
{This applies to corresponding code in Fortran and Cobol.

    = llc$longreal_kind =

      IF variable_spec.bit_offset > 0 THEN
        osp$set_status_abnormal (duc$symbolic_id, due$unaligned_real,
              variable_name^, status);
        RETURN;
      IFEND;

      p_value^.kind := clc$real;
      p_value^.real_value.number_of_digits := clc$max_real_number_digits;
      address_of_leftmost_part := variable_spec.address;
      real_value_pointer := #LOC (address_of_leftmost_part);
      value_of_leftmost_part_ptr := #LOC (p_value^.real_value.value);
      value_of_leftmost_part_ptr^ := real_value_pointer^^;
      address_of_rightmost_part := address_of_leftmost_part;
      address_of_rightmost_part.offset := address_of_rightmost_part.offset + 8;
      real_value_pointer := #LOC (address_of_rightmost_part);
      converter.cell_ptr := value_of_leftmost_part_ptr;
      converter.pva.offset := converter.pva.offset + 8;
      value_of_rightmost_part_ptr := converter.cell_ptr;
      value_of_rightmost_part_ptr^ := real_value_pointer^^;

    = llc$real_kind =

      IF variable_spec.bit_offset > 0 THEN
        osp$set_status_abnormal (duc$symbolic_id, due$unaligned_real,
          variable_name^, status);
        RETURN; {----->
      IFEND;

      p_value^.kind := clc$real;
      p_value^.real_value.number_of_digits := 14;
      address_of_leftmost_part := variable_spec.address;
      real_value_pointer := #LOC (address_of_leftmost_part);
      value_of_leftmost_part_ptr := #LOC (p_value^.real_value.value);
      value_of_leftmost_part_ptr^ := real_value_pointer^^;
      converter.cell_ptr := value_of_leftmost_part_ptr;
      converter.pva.offset := converter.pva.offset + 8;
      value_of_rightmost_part_ptr := converter.cell_ptr;
      value_of_rightmost_part_ptr^ := 0.0;

    = llc$string_kind =

      IF variable_spec.bit_offset > 0 THEN
        osp$set_status_abnormal (duc$symbolic_id, due$unaligned_string,
              variable_name^, status);
        RETURN;
      IFEND;
      p_value^.kind := clc$string;
      NEXT p_value^.string_value: [variable_spec.length] IN p_work;
      address := variable_spec.address;
      dup$get_bytes (address, #LOC (p_value^.string_value^), variable_spec.length, status);

    = llc$pointer_kind =

      IF variable_spec.bit_offset > 0 THEN
        osp$set_status_abnormal (duc$symbolic_id, due$unaligned_pointer,
              variable_name^, status);
        RETURN;
      IFEND;
      p_value^.kind := clc$integer;
      p_value^.integer_value.radix := 16;
      p_value^.integer_value.radix_specified := TRUE;
      address := variable_spec.address;
      IF (home_spec.language = llc$the_c_language) THEN
        address.offset := address.offset + 2;
      IFEND;
      dup$get_bytes (address, #LOC (pointer), #SIZE (pointer), status);
      p_value^.integer_value.value := pointer;

    = llc$cell_kind =

      get_cybil_value (variable_spec, program_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      p_value^.kind := clc$integer;
      p_value^.integer_value.value := program_value;
      p_value^.integer_value.radix := 16;
      p_value^.integer_value.radix_specified := TRUE;

    = llc$record_kind =

      IF (variable_spec.length = #SIZE (unique_name)) AND NOT variable_spec.length_is_bits AND
         ((home_spec.language = llc$cybil) OR (home_spec.language = llc$obsolete_cybil)) AND
         (variable_spec.symbol_entry.symbol^.symbol_name = 'OST$BINARY_UNIQUE_NAME') THEN
        address := variable_spec.address;
        dup$get_bytes (address, #LOC (unique_name), #SIZE(unique_name), status);

        IF status.normal THEN
          p_value^.kind := clc$name;
          pmp$convert_binary_unique_name (unique_name, p_value^.name_value, status);
        IFEND;
      ELSE
        osp$set_status_abnormal (duc$symbolic_id, due$invalid_data_type_for_func, variable_name^, status);
      IFEND;
    ELSE
      osp$set_status_abnormal (duc$symbolic_id,
            due$invalid_data_type_for_func, variable_name^, status);
    CASEND;

  PROCEND get_variable_value;
?? TITLE := 'locate_c_variable', EJECT ??
{ This routine attempts to find the C symbol in the symbol table and build its
{  variable_spec.

  PROCEDURE locate_c_variable (
        var_name: ost$name;
    VAR home_spec: dut$home_specification;
    VAR variable_spec: {input,output} dut$variable_specification;
    VAR status: ost$status);

    VAR
      local_status: ost$status,
      nested: boolean,
      options: [STATIC] dut$variable_search_options := [duc$search_module_level],
      proc_entry: dut$symbol_entry,
      symbol_entry: dut$symbol_entry;

    dup$locate_variable_symbol (var_name, home_spec, options, symbol_entry, nested, proc_entry, status);
    IF NOT status.normal THEN
      enable_c_globals (home_spec);
      dup$locate_variable_symbol (var_name, home_spec, options, symbol_entry, nested, proc_entry,
            local_status);
      IF NOT local_status.normal THEN
        RETURN; {----->
      IFEND;
    IFEND;

    dup$build_variable_spec (home_spec, symbol_entry, nested, proc_entry, variable_spec, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    reduce_cybil_type (home_spec, variable_spec, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
  PROCEND locate_c_variable;
?? TITLE := 'locate_cybil_field', EJECT ??

  PROCEDURE locate_cybil_field (
        home_spec: dut$home_specification;
        parameter_value: ^string ( * );
    VAR parameter_index: {input,output} clt$string_index;
    VAR variable_spec: {input,output} dut$variable_specification;
    VAR status: ost$status);

{ PURPOSE: Modify a variable specification to reflect a field reference.

    VAR
      field_entry: dut$symbol_entry,
      field_found: boolean,
      field_offset: machine_addr_in_bits_type,
      scan_index: clt$string_index,
      scan_length: clt$string_size,
      spaces_preceded_token: boolean,
      token: clt$lexical_token;

?? NEWTITLE := '    search_record_for_field', EJECT ??

    PROCEDURE search_record_for_field (
          home_spec: dut$home_specification;
          field_name: pmt$program_name;
          record_entry: dut$symbol_entry;
      VAR field_entry: dut$symbol_entry;
      VAR field_found: boolean;
      VAR status: ost$status);

{ PURPOSE: Find the symbol entry in the symbol table for a field, given
{          the symbol entry for a record and the name of the field.
{ DESIGN:  The fixed part of the record is first scanned. If the field is
{          found, we return it to the caller. If the field is not found and
{          this is a case variant record, this procedure is called recursively
{          to search for the field in each variant.

      VAR
        next_field: symbol_no,
        next_selector: symbol_no,
        selector_entry: dut$symbol_entry,
        variant_entry: dut$symbol_entry;

      field_found := FALSE;
      next_field := record_entry.symbol^.record_first_field;

{ Search fixed part of the record for the field }

      WHILE next_field > 0 DO
        dup$locate_symbol_for_number (home_spec.symbol_table_address,
              next_field, field_entry, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF field_name = field_entry.symbol^.symbol_name THEN
          field_found := TRUE;
          RETURN;
        IFEND;
        next_field := field_entry.symbol^.next_field;
      WHILEND;

{ Field is not in the fixed part of the record. If there is a variant part,
{search it.}

      next_selector := record_entry.symbol^.record_selector;
      WHILE next_selector > 0 DO
        dup$locate_symbol_for_number (home_spec.symbol_table_address,
              next_selector, selector_entry, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        dup$locate_symbol_for_number (home_spec.symbol_table_address,
              selector_entry.symbol^.variation, variant_entry, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        search_record_for_field (home_spec, field_name, variant_entry,
              field_entry, field_found, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF field_found THEN
          RETURN;
        IFEND;
        next_selector := selector_entry.symbol^.next_selector;
      WHILEND;
    PROCEND search_record_for_field;
?? OLDTITLE, EJECT ??
{ Begin procedure locate_cybil_field }

    IF variable_spec.symbol_entry.symbol^.symbol_kind <> llc$record_kind THEN
      osp$set_status_abnormal (duc$symbolic_id,
            due$only_records_have_fields, parameter_value^ (1,
            parameter_index - 2), status);
      RETURN;
    IFEND;

    scan_length := STRLENGTH (parameter_value^) - parameter_index + 1;
    scan_index := 1;
    clp$evaluate_token (parameter_value^ (parameter_index, scan_length), scan_options,
          scan_index, spaces_preceded_token, token, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF llc$language_is_case_sensitive IN home_spec.symbol_table_address^.attributes THEN
      variable_spec.name := parameter_value^(parameter_index,token.str.size);
    ELSE
      variable_spec.name := token.str.value (1, token.str.size);
    IFEND;
    parameter_index := parameter_index + scan_index - 1;
    IF (token.kind <> clc$simple_name_token) AND (token.kind <> clc$cybil_name_token) THEN
      osp$set_status_abnormal (duc$symbolic_id, due$not_valid_field_name, token.
            descriptor, status);
      RETURN;
    IFEND;

    search_record_for_field (home_spec, variable_spec.name, variable_spec.
          symbol_entry, field_entry, field_found, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF field_found THEN
      variable_spec.symbol_entry := field_entry;
      variable_spec.length := field_entry.symbol^.field_length;
      variable_spec.length_is_bits := NOT (llc$field_is_byte_addressable IN field_entry.
        symbol^.field_attributes);
      IF variable_spec.length_is_bits THEN
        field_offset := variable_spec.bit_offset + field_entry.symbol^.
              field_offset;
        variable_spec.address.offset := variable_spec.address.offset +
              (field_offset DIV bits_per_byte);
        variable_spec.bit_offset := field_offset MOD bits_per_byte;
      ELSE
        variable_spec.address.offset := variable_spec.address.offset +
              field_entry.symbol^.field_offset;
      IFEND;
      reduce_cybil_type (home_spec, variable_spec, status);
    ELSE
      osp$set_status_abnormal (duc$symbolic_id, due$field_not_found,
                 variable_spec.name, status);
    IFEND;
  PROCEND locate_cybil_field;
?? TITLE := 'modify_c_pointer', EJECT ??

  PROCEDURE modify_c_pointer (
        home_spec: dut$home_specification;
        token: clt$lexical_token;
        working_var_name: ^string ( * );         {For error messages only}
        parameter_value: ^string ( * );
    VAR parameter_index: {input,output} clt$string_index;
    VAR dereferences_needed: {input,output} integer;
    VAR variable_spec: {input,output} dut$variable_specification;
    VAR status: ost$status);

{ In C, it is legal to add/subtract integer values to/from pointers (and
{   arrays, which are treated as pointers).  Adding n to a pointer increments
{   the pointer to point n elements beyond where it currently points.  The
{   number actually added to the pointer is a function of what the pointer
{   points to.
{ Since there can be more than one ptr modification, and we don't want to
{   "reduce" the pointer until it is dereferenced, the ptr modifications are
{   saved in the global array ptr_modification and the variable_spec left as is.
{   Note that if there is a dereference which corresponds to this modification,
{   it must occur at another recursion level. For example:
{                  dispv *(*xyz+3)
{   For this expression to work, xyz must be a pointer to a pointer.  There are
{   two dereferences.  The innermost is done before the ptr mod, and the other
{   dereference (which goes with the ptr mod) is done later in the outer
{   recursion level.

    VAR
      sub_var_home_spec: dut$home_specification,
      sub_var_value_index: clt$string_index,
      sub_variable_spec: dut$variable_specification,
      var_value: integer;

{ Pointer dereferences have a higher precedence than pointer modification.  If
{  there are any to do at this level of recursion, do them now.
    WHILE dereferences_needed > 0 DO
      evaluate_c_pointer (home_spec,
          ^working_var_name^(1+dereferences_needed,STRLENGTH(working_var_name^)-dereferences_needed),
               variable_spec, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      dereferences_needed := dereferences_needed - 1;
    WHILEND;

    IF (variable_spec.symbol_entry.symbol^.symbol_kind <> llc$pointer_kind) AND
       (variable_spec.symbol_entry.symbol^.symbol_kind <> llc$cybil_array_kind) THEN
      osp$set_status_abnormal (duc$symbolic_id, due$c_must_be_pointer, working_var_name^, status);
      RETURN; {----->
    IFEND;

    IF (token.kind = clc$signed_integer_token) OR
       (token.kind = clc$unsigned_integer_token) THEN
      ptr_modification := ptr_modification + token.int.value;
    ELSE
      sub_var_home_spec := home_spec;
      scan_c_variable (parameter_value, sub_var_home_spec, parameter_index, sub_variable_spec, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      IF sub_variable_spec.symbol_entry.symbol^.symbol_kind <> llc$integer_kind THEN
        osp$set_status_abnormal (duc$symbolic_id, due$c_wrong_type_for_ptr_mod,
                   sub_variable_spec.name, status);
        RETURN; {----->
      IFEND;
      get_cybil_value (sub_variable_spec, var_value, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      ptr_modification := ptr_modification + var_value;
    IFEND;
    ptr_mod_specified := TRUE;

  PROCEND modify_c_pointer;
?? TITLE := 'process_variable_name', EJECT ??

  PROCEDURE process_variable_name (
        value_name: string (*);
        p_variable_value: ^clt$data_value;
    VAR p_name_list: ^string_list;
    VAR status: ost$status);

    VAR
      name_count: integer,
      name_index: integer,
      p_list: ^clt$data_value,
      p_seq: ^SEQ (*),
      unit_list: clt$data_value;

    status.normal := TRUE;
    p_name_list := NIL;
    p_list := p_variable_value;

    IF (p_list <> NIL) THEN
      IF (p_list^.kind <> clc$list) THEN
        unit_list.kind := clc$list;
        unit_list.element_value := p_list;
        unit_list.link := NIL;
        p_list := ^unit_list;
      IFEND;
      name_count := clp$count_list_elements (p_list);
      IF (name_count > 0) THEN
        p_seq := v$p_name_stack;
        NEXT p_name_list: [1 .. name_count] IN p_seq;
        IF (p_name_list = NIL) THEN
          osp$set_status_abnormal (duc$symbolic_id, due$parameter_value_too_long, value_name, status);
        ELSE
          name_index := 0;
          while (name_index < name_count) AND status.normal DO
            name_index := name_index + 1;
            WHILE (p_list^.element_value = NIL) DO
              p_list := p_list^.link;
            WHILEND;
            expand_value (value_name, p_list^.element_value, p_seq, p_name_list^ [name_index], status);
            p_list := p_list^.link;
          WHILEND;
          IF status.normal THEN
            v$p_name_stack := p_seq;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND process_variable_name;
?? TITLE := 'reduce_cybil_type', EJECT ??

  PROCEDURE reduce_cybil_type (home_spec: dut$home_specification;
    VAR variable_spec: {input,output} dut$variable_specification;
    VAR status: ost$status);

{ PURPOSE: Break a symbol down to its basic type.
{ DESIGN:  If a symbol entry is not considered a basic type, any
{          relevant information in the entry is saved and the entry
{          for the more basic type is retrieved.
{ NOTE:    For a given call to this routine, more than one reductions may
{          be necessary. For instance, a variable entry may point to a
{          subrange entry, which points to an integer entry.
{

    VAR
      array_descriptor: ost$adaptable_array_pointer,
      bound_variant_descriptor: ost$bound_variant_pointer,
      constant_entry: dut$symbol_entry,
      field_number: llt$symbol_number,
      heap_descriptor: ost$adaptable_heap_pointer,
      sequence_descriptor: ost$sequence_pointer,
      string_descriptor: ost$adaptable_string_pointer,
      str_length: 0 .. 0FFFF(16),
      symbol_entry: dut$symbol_entry,
      address: ost$pva;

    IF variable_spec.symbol_entry.symbol^.symbol_kind = llc$var_kind THEN
      dup$locate_symbol_for_number (home_spec.symbol_table_address, variable_spec.symbol_entry.symbol^.
            var_type, variable_spec.symbol_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF variable_spec.symbol_entry.symbol^.symbol_kind = llc$constant_kind THEN
      IF NOT((variable_spec.symbol_entry.symbol^.constant_kind = llc$long_constant) AND
             ((home_spec.symbol_table_address^.language = llc$cybil) OR
             (home_spec.symbol_table_address^.language = llc$obsolete_cybil))) THEN
        dup$locate_symbol_for_number (home_spec.symbol_table_address, variable_spec.symbol_entry.symbol^.
             constant_type, constant_entry, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        variable_spec.symbol_entry := constant_entry;
      IFEND;
      variable_spec.constant_value := TRUE;
    IFEND;

    IF variable_spec.symbol_entry.symbol^.symbol_kind = llc$field_kind THEN
      dup$locate_symbol_for_number (home_spec.symbol_table_address, variable_spec.symbol_entry.symbol^.
            field_type, variable_spec.symbol_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF variable_spec.symbol_entry.symbol^.symbol_kind = llc$subrange_kind THEN
      variable_spec.range_specified := TRUE;
      IF variable_spec.symbol_entry.symbol^.low_value_type = llc$adaptable_length THEN
        address := variable_spec.descriptor_address;
        dup$get_bytes (address, #LOC (array_descriptor), #SIZE (array_descriptor), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        variable_spec.low_value := array_descriptor.lower_bound;
      ELSE
        variable_spec.low_value := variable_spec.symbol_entry.symbol^.low_value;
      IFEND;
      IF variable_spec.symbol_entry.symbol^.high_value_type = llc$adaptable_length THEN
        address := variable_spec.descriptor_address;
        dup$get_bytes (address, #LOC (array_descriptor), #SIZE (array_descriptor), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        variable_spec.high_value := array_descriptor.lower_bound + (array_descriptor.array_size DIV
              array_descriptor.element_size) - 1;
      ELSE
        variable_spec.high_value := variable_spec.symbol_entry.symbol^.high_value;
      IFEND;
      dup$locate_symbol_for_number (home_spec.symbol_table_address, variable_spec.symbol_entry.symbol^.
            subtype, variable_spec.symbol_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF variable_spec.symbol_entry.symbol^.symbol_kind = llc$bound_vrec_kind THEN
      dup$locate_symbol_for_number (home_spec.symbol_table_address, variable_spec.symbol_entry.symbol^.
            bound_type, variable_spec.symbol_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      address := variable_spec.descriptor_address;
      dup$get_bytes (address, #LOC (bound_variant_descriptor), #SIZE (bound_variant_descriptor), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      variable_spec.length_is_bits := FALSE;
      variable_spec.length := bound_variant_descriptor.length;

    ELSEIF variable_spec.symbol_entry.symbol^.symbol_kind = llc$record_kind THEN
      variable_spec.length_is_bits := FALSE;
      variable_spec.length := variable_spec.symbol_entry.symbol^.record_length;

      IF (variable_spec.symbol_entry.symbol^.record_binding = llc$adaptable_binding) THEN
        symbol_entry := variable_spec.symbol_entry;

        REPEAT
          field_number := symbol_entry.symbol^.record_first_field;
          WHILE (field_number > 0) DO
            dup$locate_symbol_for_number (home_spec.symbol_table_address, field_number, symbol_entry, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            field_number := symbol_entry.symbol^.next_field;
          WHILEND;
          dup$locate_symbol_for_number (home_spec.symbol_table_address, symbol_entry.symbol^.field_type,
                symbol_entry, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        UNTIL (symbol_entry.symbol^.symbol_kind <> llc$record_kind);

        address := variable_spec.descriptor_address;
        IF (symbol_entry.symbol^.symbol_kind = llc$cybil_array_kind) THEN
          dup$get_bytes (address, #LOC (array_descriptor), #SIZE (array_descriptor), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          variable_spec.length := variable_spec.length + array_descriptor.array_size;
        ELSEIF (symbol_entry.symbol^.symbol_kind = llc$string_kind) THEN
          dup$get_bytes (address, #LOC (string_descriptor), #SIZE (string_descriptor), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          variable_spec.length := variable_spec.length + string_descriptor.length;
        ELSEIF (symbol_entry.symbol^.symbol_kind = llc$seq_kind) THEN
          dup$get_bytes (address, #LOC (sequence_descriptor), #SIZE (sequence_descriptor), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          variable_spec.length := variable_spec.length + sequence_descriptor.length;
        ELSEIF (symbol_entry.symbol^.symbol_kind = llc$heap_kind) THEN
          dup$get_bytes (address, #LOC (heap_descriptor), #SIZE (heap_descriptor), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          variable_spec.length := variable_spec.length + heap_descriptor.length;
        IFEND;
      IFEND;
    IFEND;

    IF variable_spec.symbol_entry.symbol^.symbol_kind = llc$cybil_array_kind THEN
      IF llc$adaptable_binding = variable_spec.symbol_entry.symbol^.cybil_array_binding THEN
        variable_spec.length_is_bits := llc$cybil_array_is_bits IN variable_spec.symbol_entry.symbol^.
              cybil_array_attributes;
        address := variable_spec.descriptor_address;
        dup$get_bytes (address, #LOC (array_descriptor), #SIZE (array_descriptor), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        variable_spec.length := array_descriptor.array_size;
      IFEND;
    IFEND;

    IF variable_spec.symbol_entry.symbol^.symbol_kind = llc$string_kind THEN
      variable_spec.max_string_length := variable_spec.length;
      IF variable_spec.symbol_entry.symbol^.string_length_type = llc$variable_length THEN
{ The current length is in the two bytes following the string value }
        variable_spec.max_string_length := variable_spec.length - 2;
        address := variable_spec.address;
        address.offset := address.offset + variable_spec.max_string_length;
        dup$get_bytes (address, #LOC (str_length), #SIZE (str_length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        variable_spec.length := str_length;
      IFEND;
      IF variable_spec.symbol_entry.symbol^.string_length_type = llc$dynamic_length THEN
{ The first two bytes = max length, followed by the string value, followed by
{  the two bytes of current length
        address := variable_spec.address;
        dup$get_bytes (address, #LOC (str_length), #SIZE (str_length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        variable_spec.max_string_length := str_length; {save max length}
        variable_spec.address.offset := variable_spec.address.offset + 2;
        address := variable_spec.address;
        address.offset := address.offset + variable_spec.max_string_length;
        dup$get_bytes (address, #LOC (str_length), #SIZE (str_length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        variable_spec.length := str_length;
      IFEND;
      IF variable_spec.symbol_entry.symbol^.string_length_type = llc$indefinite_length THEN
{ Variable_spec.address has already been adjusted to point to the string itself.
{  The current length is contained in the two bytes following the string.
        address := variable_spec.descriptor_address;
        dup$get_bytes (address, #LOC (string_descriptor), #SIZE (string_descriptor), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        variable_spec.max_string_length := string_descriptor.length; {save max length}
        address := variable_spec.address;
        address.offset := address.offset + string_descriptor.length;
        dup$get_bytes (address, #LOC (str_length), #SIZE (str_length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        variable_spec.length := str_length;
      IFEND;
      IF variable_spec.symbol_entry.symbol^.string_length_type = llc$adaptable_length THEN
        variable_spec.length_is_bits := FALSE;
        address := variable_spec.descriptor_address;
        dup$get_bytes (address, #LOC (string_descriptor), #SIZE (string_descriptor), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        variable_spec.length := string_descriptor.length;
        variable_spec.max_string_length := string_descriptor.length;
      IFEND;
    IFEND;

{ Treat character, ordinal and boolean types like subranges }

    IF NOT variable_spec.range_specified THEN
      CASE variable_spec.symbol_entry.symbol^.symbol_kind OF
      = llc$boolean_kind =
        variable_spec.range_specified := TRUE;
        variable_spec.low_value := false_value;
        variable_spec.high_value := true_value;
      = llc$char_kind =
        variable_spec.range_specified := TRUE;
        variable_spec.low_value := first_character;
        variable_spec.high_value := last_character;
      = llc$ordinal_kind =
        variable_spec.range_specified := TRUE;
        variable_spec.low_value := 0;
        variable_spec.high_value := variable_spec.symbol_entry.symbol^.ordinal_upper_bound;
      = llc$integer_kind =
        variable_spec.low_value := LOWERVALUE (variable_spec.low_value);
        variable_spec.high_value := UPPERVALUE (variable_spec.high_value);
      = llc$cell_kind =
        variable_spec.low_value := 0;
        variable_spec.high_value := 0ff(16);
      ELSE
      CASEND;
    IFEND;

  PROCEND reduce_cybil_type;
?? TITLE := 'replace_cybil_value', EJECT ??
{ Replace the current program value for variables that are 8 or less bytes.

  PROCEDURE replace_cybil_value (variable_spec: dut$variable_specification;
    VAR replacement_value: integer;
    VAR status: ost$status);

    VAR
      integer_1: ^^0 .. 0ff(16),
      integer_2: ^^0 .. 0ffff(16),
      integer_3: ^^0 .. 0ffffff(16),
      integer_4: ^^0 .. 0ffffffff(16),
      integer_5: ^^0 .. 0ffffffffff(16),
      integer_6: ^^0 .. 0ffffffffffff(16),
      integer_7: ^^0 .. 0ffffffffffffff(16),
      integer_8: ^^integer,
      left_fill_value: integer,
      length: integer,
      right_fill: 0 .. bits_per_byte,
      right_fill_value: integer,
      value: integer;

    IF variable_spec.range_specified THEN
      IF (replacement_value < variable_spec.low_value) OR (replacement_value > variable_spec.high_value) THEN
        osp$set_status_abnormal (duc$symbolic_id, due$value_out_of_range, variable_spec.name, status);
        RETURN;
      IFEND;
    IFEND;

    IF variable_spec.length_is_bits THEN
      length := (variable_spec.length + variable_spec.bit_offset + bits_per_byte - 1) DIV bits_per_byte;
      right_fill := bits_per_byte - ((variable_spec.length + variable_spec.bit_offset) MOD bits_per_byte);
      IF right_fill = bits_per_byte THEN
        right_fill := 0;
      IFEND;
    ELSE
      IF variable_spec.bit_offset = 0 THEN
        length := variable_spec.length;
        right_fill := 0;
      ELSE
        length := variable_spec.length + 1;
        right_fill := bits_per_byte - variable_spec.bit_offset;
      IFEND;
    IFEND;
    CASE length OF
    = 1 =
      integer_1 := #LOC (variable_spec.address);
      value := integer_1^^;

    = 2 =
      integer_2 := #LOC (variable_spec.address);
      value := integer_2^^;

    = 3 =
      integer_3 := #LOC (variable_spec.address);
      value := integer_3^^;

    = 4 =
      integer_4 := #LOC (variable_spec.address);
      value := integer_4^^;

    = 5 =
      integer_5 := #LOC (variable_spec.address);
      value := integer_5^^;

    = 6 =
      integer_6 := #LOC (variable_spec.address);
      value := integer_6^^;

    = 7 =
      integer_7 := #LOC (variable_spec.address);
      value := integer_7^^;

    = 8 =
      integer_8 := #LOC (variable_spec.address);
      value := integer_8^^;

    ELSE
    CASEND;

    IF right_fill > 0 THEN {right shift}
      right_fill_value := value MOD powers_of_two [right_fill];
      value := value DIV powers_of_two [right_fill];
    ELSE
      right_fill_value := 0;
    IFEND;

    IF variable_spec.length_is_bits THEN
      value := value DIV powers_of_two [variable_spec.length];
      left_fill_value := value * powers_of_two [variable_spec.length + right_fill];
    ELSEIF variable_spec.bit_offset > 0 THEN
      value := value DIV powers_of_two [variable_spec.length * bits_per_byte];
      left_fill_value := value * powers_of_two [(variable_spec.length * bits_per_byte) + right_fill];
    ELSE
      left_fill_value := 0;
    IFEND;

    value := left_fill_value + (replacement_value * powers_of_two [right_fill]) + right_fill_value;

    CASE length OF
    = 1 =
      integer_1^^ := value;

    = 2 =
      integer_2^^ := value;

    = 3 =
      integer_3^^ := value;

    = 4 =
      integer_4^^ := value;

    = 5 =
      integer_5^^ := value;

    = 6 =
      integer_6^^ := value;

    = 7 =
      integer_7^^ := value;

    = 8 =
      integer_8^^ := value;

    ELSE
    CASEND;

  PROCEND replace_cybil_value;
?? TITLE := 'scan_basic_variable', EJECT ??

  PROCEDURE scan_basic_variable (variable_name: ^string ( * );
        home_spec: dut$home_specification;
    VAR value_index: {input,output} clt$string_index;
    VAR variable_spec: dut$variable_specification;
    VAR status: ost$status);

    osp$set_status_abnormal (duc$symbolic_id, due$unsupported_language, 'Basic', status);
  PROCEND scan_basic_variable;
?? TITLE := 'scan_c_variable', EJECT ??
{ PURPOSE: Parse a C variable_name and produce a variable_specification.
{
{  Parameters:
{     variable_name - pointer to the variable name string to be scanned.  For
{                  recursive calls to this routine, this string is a substring
{                  of the original, starting at the original first character
{                  and ending at the end of the subexpression to be scanned.
{                  e.g, dispv *(xyz+1).abc  - to evaluate the inner expression,
{                  '*(xyz+1' is passed to the recursive call with value_index
{                  equal to 3.
{     home_spec - the home specification.  Note that this is a VAR parameter
{                  and will change if the variable is a global. (Globals are
{                  contained in the module 'c_globals').
{     value_index - index into the variable name string.  Unlike the CYBIL
{                  scanner, this is 1 only on the very first call.
{     variable_spec - The variable specification which is produced by this
{                  routine.

  PROCEDURE scan_c_variable (
        variable_name: ^string ( * );
    VAR home_spec: dut$home_specification;
    VAR value_index: clt$string_index;
    VAR variable_spec: dut$variable_specification;
    VAR status: ost$status);

{ Variable evaluate_subscript_calls is used to determine if the home_spec needs
{ to be restored.  It needs to be restored if the subscript found is a global
{ variable)

    VAR
      evaluate_subscript_calls: [STATIC] integer;

    VAR
      address: ost$pva,
      dereferences_needed: integer,
      first_call: boolean,
      init_value_index: clt$string_index,
      initial_home_spec: [STATIC] dut$home_specification,
      int: integer,
      local_status: ost$status,
      msg_var_name: ^string ( * <= osc$max_string_size),
      processing_subscript: boolean,
      save_home_spec: dut$home_specification,
      scan_index: clt$string_index,
      scan_length: clt$string_index,
      spaces_preceded_token: boolean,
      sub_expression_len: clt$string_size,
      sub_expr_value_index: clt$string_index,
      token: clt$lexical_token,
      type_name: pmt$program_name,
      value_length: clt$string_index,
      var_name: ost$name,
      working_var_name: ^string ( * );           {name for error messages}

    first_call := FALSE;
    init_value_index := value_index;             {save initial value_index}
    IF value_index = 1 THEN
{ Value_index is equal to 1 only on the very first call.
      first_call := TRUE;
      evaluate_subscript_calls := 0;
      ptr_modification := 0;
      ptr_mod_specified := FALSE;
      initial_home_spec := home_spec;
    IFEND;
    IF evaluate_subscript_calls <> 0 THEN
{ This call was made from evaluate_cybil_subscript.  We must set the home_spec
{  back to the original one since if the array was a global variable, home_spec
{  has changed.
      save_home_spec := home_spec;
      home_spec := initial_home_spec;
    IFEND;
    value_length := STRLENGTH (variable_name^);
    scan_length := value_length - value_index + 1;
    scan_index := 1;

    clp$evaluate_token (variable_name^(value_index, scan_length), scan_options,
            scan_index, spaces_preceded_token, token, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

{ Check for '&' character - request for the address of the variable }
    IF (token.kind = clc$unknown_token) AND
       (token.text_size = 1) AND (token.str.value(1) = '&') THEN
      IF NOT first_call THEN
        osp$set_status_abnormal (duc$symbolic_id, due$c_illegal_ptr_construction, '', status);
        RETURN; {----->
      IFEND;
      variable_spec.attribute := duc$variable_address;
      init_value_index := init_value_index + 1;
      clp$evaluate_token (variable_name^(value_index,scan_length), scan_options,
                   scan_index, spaces_preceded_token, token, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    ELSE
      IF first_call THEN          {Only initialize the first time through}
        variable_spec.attribute := duc$variable_value;
      IFEND;
    IFEND;

{ Check for '*' tokens - request for pointer dereference.  Since the '*'
{  comes before the variable name in C, just save the number of them.  We
{  will do the dereferencing later.
    dereferences_needed := 0;
    IF (token.kind = clc$multiply_token) OR
       (token.kind = clc$exponentiate_token) THEN
      REPEAT
        IF token.kind = clc$multiply_token THEN
          dereferences_needed := dereferences_needed + 1;
        ELSE
          dereferences_needed := dereferences_needed + 2;
        IFEND;
        clp$evaluate_token (variable_name^(value_index,scan_length), scan_options,
                   scan_index, spaces_preceded_token, token, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      UNTIL (token.kind <> clc$multiply_token) AND
            (token.kind <> clc$exponentiate_token);
    IFEND;

{ Check for a sub-expression.  If there is no sub-expression, look for the
{  variable name.
    IF token.kind = clc$left_parenthesis_token THEN
      find_c_sub_expression (variable_name^(value_index + scan_index - 1,*), sub_expression_len, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      sub_expr_value_index := value_index + scan_index - 1;
      scan_c_variable (^variable_name^(1,value_index+scan_index+sub_expression_len-2),
                home_spec, sub_expr_value_index, variable_spec, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      scan_index := scan_index + sub_expression_len + 1;

    ELSEIF (token.kind = clc$simple_name_token) OR (token.kind = clc$cybil_name_token) OR
           (token.kind = clc$name_token) THEN { process variable name }
{ C is a case sensitive language.  However, there was a time when our C wasn't.
{  This code was left in to help the transition.
      IF llc$language_is_case_sensitive IN home_spec.symbol_table_address^.attributes THEN
        var_name := variable_name^(value_index + scan_index - token.str.size - 1, token.str.size);
      ELSE
        var_name := token.str.value(1,token.str.size);
      IFEND;
      locate_c_variable (var_name, home_spec, variable_spec, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

    ELSEIF (token.kind = clc$unsigned_integer_token) THEN { process address.type }
      int := token.int.value;
      clp$evaluate_token (variable_name^ (value_index, scan_length), scan_options, scan_index,
            spaces_preceded_token, token, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (token.kind <> clc$dot_token) THEN
        osp$set_status_abnormal (duc$symbolic_id, due$expecting_variable_name, token.descriptor, status);
        RETURN;
      IFEND;

      clp$evaluate_token (variable_name^ (value_index, scan_length), scan_options, scan_index,
            spaces_preceded_token, token, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (token.kind <> clc$simple_name_token) AND (token.kind <> clc$cybil_name_token) THEN
        osp$set_status_abnormal (duc$symbolic_id, due$expecting_variable_name, token.descriptor, status);
        RETURN;
      IFEND;
      IF llc$language_is_case_sensitive IN home_spec.symbol_table_address^.attributes THEN
        type_name := variable_name^(value_index + scan_index - token.str.size - 1, token.str.size);
      ELSE
        type_name := token.str.value (1, token.str.size);
      IFEND;
      address.ring := #ring (^type_name);
      address.seg := (int DIV 100000000(16)) MOD 1000(16);
      address.offset := int MOD 100000000(16);
      dup$simulate_variable (home_spec, address, type_name, variable_spec, status);
      IF NOT status.normal THEN
        enable_c_globals (home_spec);
        dup$simulate_variable (home_spec, address, type_name, variable_spec, local_status);
        IF local_status.normal THEN
          status.normal := TRUE;
        ELSE
          RETURN;
        IFEND;
      IFEND;

    ELSE
        osp$set_status_abnormal (duc$symbolic_id, due$expecting_variable_name, token.descriptor, status);
        RETURN; {----->
    IFEND;

    value_index := value_index + scan_index - 1;
    processing_subscript := FALSE;
    working_var_name := ^variable_name^(init_value_index, value_index - init_value_index);

/process_tokens/
    WHILE value_index <= value_length DO
      scan_length := value_length - value_index + 1;
      scan_index := 1;
      clp$evaluate_token (variable_name^(value_index,scan_length), scan_options,
            scan_index, spaces_preceded_token, token, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      value_index := value_index + scan_index - 1;

      CASE token.kind OF
      = clc$dot_token =
{ Structure field }
        IF variable_spec.symbol_entry.symbol^.symbol_kind <> llc$record_kind THEN
          osp$set_status_abnormal (duc$symbolic_id, due$only_records_have_fields,
            working_var_name^(1+dereferences_needed, STRLENGTH(working_var_name^)-dereferences_needed),
                      status);
          RETURN; {----->
        IFEND;
        locate_cybil_field (home_spec, variable_name, value_index, variable_spec, status);

      = clc$left_bracket_token =
{ Array subscript }
        IF processing_subscript THEN
          osp$set_status_abnormal (duc$symbolic_id, due$subscript_error, variable_name^, status);
          EXIT /process_tokens/;
        IFEND;
        processing_subscript := TRUE;
        evaluate_subscript_calls := evaluate_subscript_calls + 1;
        evaluate_c_subscript (home_spec,
              ^working_var_name^(1+dereferences_needed, STRLENGTH(working_var_name^)-dereferences_needed),
              variable_name, value_index, variable_spec, status);
        evaluate_subscript_calls := evaluate_subscript_calls - 1;

      = clc$right_bracket_token =
        IF NOT processing_subscript THEN
          osp$set_status_abnormal (duc$symbolic_id, due$subscript_error, variable_name^, status);
          EXIT /process_tokens/;
        IFEND;
        processing_subscript := FALSE;

      = clc$signed_integer_token =
{ Pointer modification }
        modify_c_pointer (home_spec, token, working_var_name, variable_name,
                   value_index, dereferences_needed, variable_spec, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;

      = clc$add_token =
{ Pointer modification }
        modify_c_pointer (home_spec, token, working_var_name, variable_name,
                   value_index, dereferences_needed, variable_spec, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;

      = clc$subtract_token =
{ Either pointer modification or field of a pointer to a structure }
        IF (value_index <= value_length) AND
           (variable_name^(value_index) = '>') THEN
{ If the next token is a '>', the variable should be a pointer to a structure
{  and the user wants to display a structure member.
          value_index := value_index + 1;    {points to structure member name}
          evaluate_c_pointer (home_spec,
              ^working_var_name^(1+dereferences_needed,STRLENGTH(working_var_name^)-dereferences_needed),
                   variable_spec, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          locate_cybil_field (home_spec, variable_name, value_index, variable_spec, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        ELSE
{ Try to interpret this as a pointer modification.
          modify_c_pointer (home_spec, token, working_var_name, variable_name,
                   value_index, dereferences_needed, variable_spec, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;

      ELSE
        osp$set_status_abnormal (duc$symbolic_id, due$invalid_token_in_variable, token.descriptor, status);
      CASEND;
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
{ Setup the error message variable name }
      working_var_name :=
        ^variable_name^(init_value_index, value_index - init_value_index);

    WHILEND /process_tokens/;
    IF evaluate_subscript_calls <> 0 THEN
      home_spec := save_home_spec;               {restore home_spec just in case
    IFEND;

{ See if there are any dereferences needed to be done now.  Pointer dereferences
{  have a lower precedence than everything except pointer modification.  The
{  routine modify_c_pointer takes care of dereferences before doing the pointer
{  arithmetic.

    WHILE dereferences_needed > 0 DO
      evaluate_c_pointer (home_spec,
          ^working_var_name^(1+dereferences_needed,STRLENGTH(working_var_name^)-dereferences_needed),
               variable_spec, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      dereferences_needed := dereferences_needed - 1;
    WHILEND;

{ If ptr mods were specified, then all the pointer modifications have not been
{  used up.  See if we can dereference the variable one more time.

    IF (first_call) AND (ptr_mod_specified) THEN
      IF (variable_spec.attribute = duc$variable_address) THEN
        msg_var_name := ^variable_name^(2,*);
        osp$set_status_abnormal (duc$symbolic_id, due$c_illegal_address_op, msg_var_name^, status);
        RETURN; {----->
      IFEND;
      evaluate_c_pointer (home_spec, working_var_name, variable_spec, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      variable_spec.attribute := duc$variable_address;
    IFEND;

  PROCEND scan_c_variable;
?? TITLE := 'scan_cybil_variable', EJECT ??

  PROCEDURE scan_cybil_variable (
        variable_name: ^string ( * );
        home_spec: dut$home_specification;
    VAR value_index: {input,output} clt$string_index;
    VAR variable_spec: dut$variable_specification;
    VAR status: ost$status);

{ PURPOSE: Parse a variable_name and produce a variable_specification.

    VAR
      address_wanted: boolean,
      array_descriptor: [STATIC] ost$adaptable_array_pointer,
      field_number: llt$symbol_number,
      lower_bound: integer,
      no_deref_indx: 1 .. 2,
      processing_subscript: boolean,
      spaces_preceded_token: boolean,
      substring_found: boolean,
      symbol_entry: dut$symbol_entry,
      token: clt$lexical_token,
      upper_bound: integer,
      value_length: clt$string_size,
      int: integer,
      address: ost$pva,
      type_name: pmt$program_name,
      var_name: pmt$program_name;

    IF variable_name^ = '' THEN
      osp$set_status_abnormal (duc$symbolic_id, due$expecting_variable_name,
            '', status);
      RETURN;
    IFEND;
    value_length := STRLENGTH (variable_name^);

    clp$evaluate_token (variable_name^, scan_options, value_index, spaces_preceded_token, token, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    address_wanted := (token.kind = clc$circumflex_token);
    IF address_wanted THEN
      variable_spec.attribute := duc$variable_address;
      clp$evaluate_token (variable_name^, scan_options, value_index, spaces_preceded_token, token, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      variable_spec.attribute := duc$variable_value;
    IFEND;

    IF (token.kind = clc$simple_name_token) OR (token.kind = clc$cybil_name_token) OR
          (token.kind = clc$name_token) THEN
      IF llc$language_is_case_sensitive IN home_spec.symbol_table_address^.attributes THEN
        var_name := variable_name^(value_index - token.str.size, token.str.size);
      ELSE
        var_name := token.str.value (1, token.str.size);
      IFEND;

      get_variable_spec (home_spec, var_name, variable_name, address_wanted, value_index,
            variable_spec, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSEIF (token.kind = clc$unsigned_integer_token) THEN
      int := token.int.value;
      clp$evaluate_token (variable_name^, scan_options, value_index, spaces_preceded_token, token, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (token.kind <> clc$dot_token) THEN
        osp$set_status_abnormal (duc$symbolic_id, due$expecting_variable_name,
              token.descriptor, status);
        RETURN;
      IFEND;

      clp$evaluate_token (variable_name^, scan_options, value_index, spaces_preceded_token, token, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (token.kind <> clc$simple_name_token) AND (token.kind <> clc$cybil_name_token) THEN
        osp$set_status_abnormal (duc$symbolic_id, due$expecting_variable_name,
              token.descriptor, status);
        RETURN;
      IFEND;
      IF llc$language_is_case_sensitive IN home_spec.symbol_table_address^.attributes THEN
        type_name := variable_name^(value_index - token.str.size, token.str.size);
      ELSE
        type_name := token.str.value (1, token.str.size);
      IFEND;
      address.ring := #ring (^type_name);
      address.seg := (int DIV 100000000(16)) MOD 1000(16);
      address.offset := int MOD 100000000(16);
      dup$simulate_variable (home_spec, address, type_name, variable_spec, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (variable_spec.symbol_entry.symbol^.symbol_kind = llc$cybil_array_kind) AND
         (variable_spec.symbol_entry.symbol^.cybil_array_binding = llc$adaptable_binding) THEN
        get_adaptable_bounds (home_spec, variable_spec.name, variable_spec.symbol_entry.symbol^.
             cybil_index_type, variable_name, value_index, lower_bound, upper_bound, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        array_descriptor.element_size := variable_spec.symbol_entry.symbol^.cybil_array_element_length;
        array_descriptor.array_size := array_descriptor.element_size * (upper_bound - lower_bound + 1);
        array_descriptor.lower_bound := lower_bound;
        variable_spec.descriptor_address.ring := osc$invalid_ring {flag local address};
        variable_spec.descriptor_address.seg := #segment (^array_descriptor);
        variable_spec.descriptor_address.offset := #offset (^array_descriptor);
      ELSEIF (variable_spec.symbol_entry.symbol^.symbol_kind = llc$record_kind) AND
             (variable_spec.symbol_entry.symbol^.record_binding = llc$adaptable_binding) THEN
        symbol_entry := variable_spec.symbol_entry;

        REPEAT
          field_number := symbol_entry.symbol^.record_first_field;
          WHILE (field_number > 0) DO
            dup$locate_symbol_for_number (home_spec.symbol_table_address, field_number, symbol_entry, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            field_number := symbol_entry.symbol^.next_field;
          WHILEND;
          dup$locate_symbol_for_number (home_spec.symbol_table_address, symbol_entry.symbol^.field_type,
                symbol_entry, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        UNTIL (symbol_entry.symbol^.symbol_kind <> llc$record_kind);

        IF (symbol_entry.symbol^.symbol_kind = llc$cybil_array_kind) THEN
          get_adaptable_bounds (home_spec, variable_spec.name, symbol_entry.symbol^.cybil_index_type,
               variable_name, value_index, lower_bound, upper_bound, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          array_descriptor.element_size := symbol_entry.symbol^.cybil_array_element_length;
          array_descriptor.array_size := array_descriptor.element_size * (upper_bound - lower_bound + 1);
          array_descriptor.lower_bound := lower_bound;
        ELSE {set descriptor to work for sequences and heaps}
          array_descriptor.array_size := 1;
          array_descriptor.lower_bound := 0;
          array_descriptor.element_size := 1;
        IFEND;

        variable_spec.descriptor_address.ring := osc$invalid_ring {flag local address};
        variable_spec.descriptor_address.seg := #segment (^array_descriptor);
        variable_spec.descriptor_address.offset := #offset (^array_descriptor);
      IFEND;
    ELSE
      osp$set_status_abnormal (duc$symbolic_id, due$expecting_variable_name,
            token.descriptor, status);
      RETURN;
    IFEND;

    IF (variable_spec.attribute = duc$variable_value) OR (variable_spec.attribute = duc$variable_address) THEN
      reduce_cybil_type (home_spec, variable_spec, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    processing_subscript := FALSE;
    substring_found := FALSE;

  /process_tokens/
    WHILE value_index <= value_length DO
      clp$evaluate_token (variable_name^, scan_options, value_index, spaces_preceded_token, token, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      CASE token.kind OF
      = clc$circumflex_token =
        no_deref_indx := 1;
        IF (variable_spec.attribute = duc$variable_address) THEN
          no_deref_indx := 2;
        IFEND;
        evaluate_cybil_pointer (home_spec, ^variable_name^(no_deref_indx,value_index-no_deref_indx-1),
              variable_spec, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;

      = clc$dot_token =
        locate_cybil_field (home_spec, variable_name, value_index, variable_spec, status);

      = clc$left_bracket_token =
        IF processing_subscript THEN
          osp$set_status_abnormal (duc$symbolic_id, due$subscript_error,
                   var_name, status);
          EXIT /process_tokens/;
        IFEND;
        processing_subscript := TRUE;
        evaluate_cybil_subscript (home_spec, variable_name, value_index, variable_spec, status);

      = clc$comma_token =
        IF NOT processing_subscript THEN
          EXIT /process_tokens/;
        IFEND;
        evaluate_cybil_subscript (home_spec, variable_name, value_index, variable_spec, status);

      = clc$right_bracket_token =
        IF NOT processing_subscript THEN
          EXIT /process_tokens/;
        IFEND;
        processing_subscript := FALSE;

      = clc$left_parenthesis_token =
        IF substring_found THEN
          osp$set_status_abnormal (duc$symbolic_id, due$invalid_substring, '', status);
          EXIT /process_tokens/;
        IFEND;
        substring_found := TRUE;        {Can only do this once}
        evaluate_cybil_substring (home_spec, variable_name, value_index, variable_spec, status);

      = clc$end_of_line_token =
        EXIT /process_tokens/;

      ELSE
        osp$set_status_abnormal (duc$symbolic_id,
              due$invalid_token_in_variable, token.descriptor, status);
      CASEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    WHILEND /process_tokens/;
    IF processing_subscript THEN
      osp$set_status_abnormal (duc$symbolic_id, due$subscript_error,
               var_name, status);
    IFEND;
  PROCEND scan_cybil_variable;
?? TITLE := 'scan_fortran_variable', EJECT ??

  PROCEDURE scan_fortran_variable (variable_name: ^string(*);
        home_spec: dut$home_specification;
    VAR value_index: clt$string_index;
    VAR variable_spec: dut$variable_specification;
    VAR status: ost$status);

    osp$set_status_abnormal (duc$symbolic_id, due$unsupported_language, 'Fortran', status);
  PROCEND scan_fortran_variable;
?? TITLE := 'scan_universal_variable', EJECT ??

  PROCEDURE scan_universal_variable (
        variable_name: ^string ( * );
        home_spec: dut$home_specification;
    VAR variable_spec: dut$variable_specification;
    VAR status: ost$status);

{ PURPOSE: Parse a variable_name and produce a variable_specification.

    VAR
      i: integer,
      nested: boolean,
      options: [STATIC] dut$variable_search_options := [duc$search_module_level],
      proc_entry: dut$symbol_entry,
      symbol_entry: dut$symbol_entry,
      value_length: 1 .. max_name_parameter_length,
      var_name: pmt$program_name;

    value_length := STRLENGTH (variable_name^);

    IF value_length > osc$max_name_size THEN
      osp$set_status_abnormal (duc$symbolic_id, due$expecting_variable_name,
            variable_name^, status);
      RETURN;
    IFEND;

    variable_spec.attribute := duc$variable_value;

    var_name := variable_name^;
{ If the language is not case sensitive, convert the name to upper case }
    IF NOT (llc$language_is_case_sensitive IN
             home_spec.symbol_table_address^.attributes) THEN
      FOR i := 1 TO value_length DO
        IF (var_name(i) >= 'a') AND (var_name(i) <= 'z') THEN
          var_name(i) := CHR($integer(var_name(i)) - 32);
        IFEND;
      FOREND;
    IFEND;
{ Find the symbol for this variable in the symbol table }
    dup$locate_variable_symbol (var_name, home_spec, options, symbol_entry, nested,
                   proc_entry, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
{ Build the variable specification }
    dup$build_variable_spec (home_spec, symbol_entry, nested, proc_entry,
                   variable_spec, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    reduce_cybil_type (home_spec, variable_spec, status);

  PROCEND scan_universal_variable;
?? OLDTITLE ??
MODEND dum$display_variable;
*DECK DECK=DUM$DUMP_ACTIVE_SEGMENT_TABLE EXPAND=TRUE

PROC dum$dump_active_segment_table, dump_active_segment_table, dumast (output, o: file = ast)
 crev s status
 ast = $mem($sa(mmv$ast_p) 6)
 astel = $mem($sa(mmv$ast_p)+14 4)
 astl  = $mem($sa(mmv$ast_p)+6 4)/astel
 detf ast status=s
 setfa $value(output) pf=c op=$eoi
 dism ast astel o=$value(output) rc=astl
 setfa $value(output) op=$boi
 edif $value(output) o=$null
   d 'segment' a
   end
 PROCEND dum$dump_active_segment_table
*DECK DECK=DUM$DUMP_ANALYZER_FUNCTIONS EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Dump Analyzer : Dump Analyzer Functions' ??                                            
MODULE dum$dump_analyzer_functions;                                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains the code for the dump analyzer functions.                                            
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc cle$ecc_parsing                                                                                        
*copyc due$exception_condition_codes                                                                          
*copyc osc$processor_defined_registers                                                                        
?? POP ??                                                                                                     
*copyc clp$evaluate_parameters                                                                                
*copyc clp$make_boolean_value                                                                                 
*copyc clp$make_file_value                                                                                    
*copyc clp$make_integer_value                                                                                 
*copyc clp$make_name_value                                                                                    
*copyc clp$make_string_value                                                                                  
*copyc dup$access_real_memory                                                                                 
*copyc dup$copy_virtual_memory_pva                                                                            
*copyc dup$copy_virtual_memory_sva                                                                            
*copyc dup$determine_dump_information                                                                         
*copyc dup$evaluate_parameters                                                                                
*copyc dup$find_record_list_entry                                                                             
*copyc dup$retrieve_bc_entry                                                                                  
*copyc dup$retrieve_exchange_package                                                                          
*copyc dup$retrieve_register                                                                                  
*copyc dup$translate_pva                                                                                      
*copyc dup$translate_sva                                                                                      
*copyc osp$append_status_integer                                                                              
*copyc osp$append_status_parameter                                                                            
*copyc osp$set_status_abnormal                                                                                
?? EJECT ??                                                                                                   
*copyc duv$dump_environment_p                                                                                 
*copyc duv$execution_environment                                                                              
*copyc duv$title_data                                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'convert_integer_to_hex_string', EJECT ??                                                      
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure converts an integer word into a hex string representation of the word.                     
                                                                                                              
  PROCEDURE convert_integer_to_hex_string                                                                     
    (    value: integer;                                                                                      
         digits_to_convert: 1 .. 16;                                                                          
     VAR hex_string: string ( * <= 16));                                                                      
                                                                                                              
    VAR                                                                                                       
      digit: 0 .. 0f(16),                                                                                     
      digit_index: 1 .. 16,                                                                                   
      hex_array: PACKED ARRAY [1 .. 16] OF 0 .. 0f(16),                                                       
      hex_digit: [STATIC] string (16) := '0123456789ABCDEF',                                                  
      temp_string: string (16);                                                                               
                                                                                                              
    #UNCHECKED_CONVERSION (value, hex_array);                                                                 
    temp_string := ' ';                                                                                       
    FOR digit_index := 1 TO digits_to_convert DO                                                              
      digit := hex_array [17 - digit_index];                                                                  
      temp_string (17 - digit_index) := hex_digit (digit + 1);                                                
    FOREND;                                                                                                   
    hex_string := temp_string (17 - STRLENGTH (hex_string), STRLENGTH (hex_string));                          
                                                                                                              
  PROCEND convert_integer_to_hex_string;                                                                      
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$analyze_dump_output', EJECT ??                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns the name of the output file as a file.                                              
                                                                                                              
  PROCEDURE [XDCL] dup$$analyze_dump_output                                                                   
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $analyze_dump_output, $ado (                                                                       
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 6, 13, 13, 53, 27, 826],                                                                             
    clc$function, 0, 0, 0, 0, 0, 0, 0, '']];                                                                  
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    VAR                                                                                                       
      value: dut$ee_output_file_record;                                                                       
                                                                                                              
    status.normal := TRUE;                                                                                    
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);                                   
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    value := duv$execution_environment.output_file;                                                           
    clp$make_file_value (value.name (1, value.size), work_area_p, result_p);                                  
                                                                                                              
  PROCEND dup$$analyze_dump_output;                                                                           
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$analyze_dump_title', EJECT ??                                                            
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns the main title of the dump as a string.                                             
                                                                                                              
  PROCEDURE [XDCL] dup$$analyze_dump_title                                                                    
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $analyze_dump_title, $adt (                                                                        
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 6, 13, 14, 4, 28, 956],                                                                              
    clc$function, 0, 0, 0, 0, 0, 0, 0, '']];                                                                  
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    status.normal := TRUE;                                                                                    
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);                                   
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    clp$make_string_value (duv$title_data.main_title, work_area_p, result_p);                                 
                                                                                                              
  PROCEND dup$$analyze_dump_title;                                                                            
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$available', EJECT ??                                                                     
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns a boolean of TRUE if the specified record is available on the dump.                 
                                                                                                              
  PROCEDURE [XDCL] dup$$available                                                                             
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $available, $avail (                                                                               
{   record_type: key of                                                                                       
{       (control_store cs c) (exchange e) (maintenance_registers mr m) (register_file rf r)                   
{     keyend = $required                                                                                      
{   processor: integer 0..3 = 0                                                                               
{   shadow: boolean = FALSE                                                                                   
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 3] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 3] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$keyword_type_qualifier,                                                                
        keyword_specs: array [1 .. 12] of clt$keyword_specification,                                          
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type3: record                                                                                           
        header: clt$type_specification_header,                                                                
        default_value: string (5),                                                                            
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [90, 9, 19, 8, 8, 15, 295],                                                                               
    clc$function, 3, 3, 1, 0, 0, 0, 0, ''], [                                                                 
    ['PROCESSOR                      ',clc$nominal_entry, 2],                                                 
    ['RECORD_TYPE                    ',clc$nominal_entry, 1],                                                 
    ['SHADOW                         ',clc$nominal_entry, 3]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [2, 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, 451,                        
  clc$required_parameter, 0, 0],                                                                              
{ PARAMETER 2                                                                                                 
    [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, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 3                                                                                                 
    [3, 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, 3,                          
  clc$optional_default_parameter, 0, 5]],                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$keyword_type], [12], [                                                                        
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                   
    ['CONTROL_STORE                  ', clc$nominal_entry, clc$normal_usage_entry, 2],                        
    ['CS                             ', clc$alias_entry, clc$normal_usage_entry, 2],                          
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                   
    ['EXCHANGE                       ', clc$nominal_entry, clc$normal_usage_entry, 3],                        
    ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],                   
    ['MAINTENANCE_REGISTERS          ', clc$nominal_entry, clc$normal_usage_entry, 4],                        
    ['MR                             ', clc$alias_entry, clc$normal_usage_entry, 4],                          
    ['OF                             ', clc$nominal_entry, clc$normal_usage_entry, 1],                        
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],                   
    ['REGISTER_FILE                  ', clc$nominal_entry, clc$normal_usage_entry, 5],                        
    ['RF                             ', clc$alias_entry, clc$normal_usage_entry, 5]]                          
    ],                                                                                                        
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, 3, 10],                                                                    
    '0'],                                                                                                     
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$boolean_type],                                                                                
    'FALSE']];                                                                                                
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$record_type = 1,                                                                                      
      p$processor = 2,                                                                                        
      p$shadow = 3;                                                                                           
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 3] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      default_list: ARRAY [1 .. 1] OF dut$default_change_list_entry,                                          
      processor: 0 .. duc$de_maximum_processors,                                                              
      record_exists: boolean;                                                                                 
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the PROCESSOR parameter.                                                   
                                                                                                              
    default_list [1].default_name := duc$dp_processor;                                                        
    default_list [1].number := p$processor;                                                                   
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    processor := pvt [p$processor].value^.integer_value.value;                                                
                                                                                                              
    IF pvt [p$record_type].value^.keyword_value = 'CONTROL_STORE' THEN                                        
      IF pvt [p$shadow].value^.boolean_value.value THEN                                                       
        record_exists := duv$dump_environment_p^.control_store.shadow [processor].available;                  
      ELSE                                                                                                    
        record_exists := duv$dump_environment_p^.control_store.main [processor].available;                    
      IFEND;                                                                                                  
    ELSEIF pvt [p$record_type].value^.keyword_value = 'EXCHANGE' THEN                                         
      record_exists := duv$dump_environment_p^.active_exchange [processor].available;                         
    ELSEIF pvt [p$record_type].value^.keyword_value = 'MAINTENANCE_REGISTERS' THEN                            
      record_exists := duv$dump_environment_p^.pro_maintenance_registers [processor].available;               
    ELSE  { pvt [p$record_type].value^.keyword_value = 'REGISTER_FILE'                                        
      record_exists := duv$dump_environment_p^.register_file [processor].available;                           
    IFEND;                                                                                                    
                                                                                                              
    clp$make_boolean_value (record_exists, clc$true_false_boolean, work_area_p, result_p);                    
                                                                                                              
  PROCEND dup$$available;                                                                                     
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$buffer_controlware', EJECT ??                                                            
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns the value of a specified buffer controlware word as an integer.                     
                                                                                                              
  PROCEDURE [XDCL] dup$$buffer_controlware                                                                    
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $buffer_controlware, $bc (                                                                         
{   word: integer 0..8192 = $required                                                                         
{   channel_number: integer 0..33 = $required                                                                 
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 2] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 2] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 6, 16, 12, 29, 30, 579],                                                                             
    clc$function, 2, 2, 2, 0, 0, 0, 0, ''], [                                                                 
    ['CHANNEL_NUMBER                 ',clc$nominal_entry, 2],                                                 
    ['WORD                           ',clc$nominal_entry, 1]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [2, 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, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 2                                                                                                 
    [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, 20, clc$required_parameter, 
  0, 0]],                                                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 8192, 10]],                                                                
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, 33, 10]]];                                                                 
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$word = 1,                                                                                             
      p$channel_number = 2;                                                                                   
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 2] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      buffer_controlware_p: ^ARRAY [0 .. * ] OF dut$de_buffer_controlware_word,                               
      buffer_controlware_size: 0 .. duc$de_maximum_bc_size,                                                   
      cell_p: ^cell,                                                                                          
      channel_number: 0 .. duc$de_maximum_channels,                                                           
      desired_word: 0 .. duc$de_maximum_bc_size,                                                              
      display_string: string (osc$max_string_size),                                                           
      entry_p: ^dut$de_buffer_controlware_entry,                                                              
      restart_file_seq_p: ^SEQ ( * ),                                                                         
      string_length: integer;                                                                                 
                                                                                                              
    status.normal := TRUE;                                                                                    
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    channel_number := pvt [p$channel_number].value^.integer_value.value;                                      
    dup$retrieve_bc_entry (channel_number, entry_p);                                                          
    IF entry_p = NIL THEN                                                                                     
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                    
            'The buffer controlware for channel', status);                                                    
      osp$append_status_integer (osc$status_parameter_delimiter, channel_number, 10, FALSE, status);          
      osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);                             
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    desired_word := pvt [p$word].value^.integer_value.value;                                                  
    buffer_controlware_size := entry_p^.words - 1;                                                            
    IF desired_word > buffer_controlware_size THEN                                                            
      STRINGREP (display_string, string_length, 'Buffer controlware address ', desired_word: #(16),           
            '(16) is');                                                                                       
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, display_string (1, string_length), 
            status);                                                                                          
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;            
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);      
    RESET restart_file_seq_p TO cell_p;                                                                       
    NEXT buffer_controlware_p: [0 .. buffer_controlware_size] IN restart_file_seq_p;                          
    IF buffer_controlware_p = NIL THEN                                                                        
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    clp$make_integer_value (buffer_controlware_p^ [desired_word], 16, TRUE, work_area_p, result_p);           
                                                                                                              
  PROCEND dup$$buffer_controlware;                                                                            
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$buffer_controlware_string', EJECT ??                                                     
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns the value of a specified buffer controlware word as a string.                       
                                                                                                              
  PROCEDURE [XDCL] dup$$buffer_controlware_string                                                             
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $buffer_controlware_string, $bcs (                                                                 
{   word: integer 0..8192 = $required                                                                         
{   channel_number: integer 0..33 = $required                                                                 
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 2] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 2] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 6, 16, 12, 30, 37, 547],                                                                             
    clc$function, 2, 2, 2, 0, 0, 0, 0, ''], [                                                                 
    ['CHANNEL_NUMBER                 ',clc$nominal_entry, 2],                                                 
    ['WORD                           ',clc$nominal_entry, 1]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [2, 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, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 2                                                                                                 
    [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, 20, clc$required_parameter, 
  0, 0]],                                                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 8192, 10]],                                                                
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, 33, 10]]];                                                                 
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$word = 1,                                                                                             
      p$channel_number = 2;                                                                                   
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 2] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      buffer_controlware_p: ^ARRAY [0 .. * ] OF dut$de_buffer_controlware_word,                               
      buffer_controlware_size: 0 .. duc$de_maximum_bc_size,                                                   
      cell_p: ^cell,                                                                                          
      channel_number: 0 .. duc$de_maximum_channels,                                                           
      desired_word: 0 .. duc$de_maximum_bc_size,                                                              
      display_string: string (osc$max_string_size),                                                           
      entry_p: ^dut$de_buffer_controlware_entry,                                                              
      restart_file_seq_p: ^SEQ ( * ),                                                                         
      string_4: string (4),                                                                                   
      string_length: integer;                                                                                 
                                                                                                              
    status.normal := TRUE;                                                                                    
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    channel_number := pvt [p$channel_number].value^.integer_value.value;                                      
    dup$retrieve_bc_entry (channel_number, entry_p);                                                          
    IF entry_p = NIL THEN                                                                                     
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                    
            'The buffer controlware for channel', status);                                                    
      osp$append_status_integer (osc$status_parameter_delimiter, channel_number, 10, FALSE, status);          
      osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);                             
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    desired_word := pvt [p$word].value^.integer_value.value;                                                  
    buffer_controlware_size := entry_p^.words - 1;                                                            
    IF desired_word > buffer_controlware_size THEN                                                            
      STRINGREP (display_string, string_length, 'Buffer controlware address ', desired_word: #(16),           
            '(16) is');                                                                                       
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, display_string (1, string_length), 
            status);                                                                                          
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;            
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p), entry_p^.first_byte);      
    RESET restart_file_seq_p TO cell_p;                                                                       
    NEXT buffer_controlware_p: [0 .. buffer_controlware_size] IN restart_file_seq_p;                          
    IF buffer_controlware_p = NIL THEN                                                                        
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    convert_integer_to_hex_string (buffer_controlware_p^ [desired_word], 4, string_4);                        
                                                                                                              
    clp$make_string_value (string_4, work_area_p, result_p);                                                  
                                                                                                              
  PROCEND dup$$buffer_controlware_string;                                                                     
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$channel_available', EJECT ??                                                             
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns a boolean of TRUE if the specified channel is available on the dump.                
                                                                                                              
  PROCEDURE [XDCL] dup$$channel_available                                                                     
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $channel_available, $ca (                                                                          
{   channel_number: integer 0..33 = $required                                                                 
{   )                                                                                                         
                                                                                                              
?? 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$integer_type_qualifier,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 6, 8, 14, 42, 32, 773],                                                                              
    clc$function, 1, 1, 1, 0, 0, 0, 0, ''], [                                                                 
    ['CHANNEL_NUMBER                 ',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, 20, clc$required_parameter, 
  0, 0]],                                                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 33, 10]]];                                                                 
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$channel_number = 1;                                                                                   
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 1] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      channel_exists: boolean,                                                                                
      channel_number: 0 .. duc$de_maximum_channels,                                                           
      entry_p: ^dut$de_buffer_controlware_entry;                                                              
                                                                                                              
    status.normal := TRUE;                                                                                    
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    channel_number := pvt [p$channel_number].value^.integer_value.value;                                      
    dup$retrieve_bc_entry (channel_number, entry_p);                                                          
    channel_exists := (entry_p <> NIL);                                                                       
                                                                                                              
    clp$make_boolean_value (channel_exists, clc$true_false_boolean, work_area_p, result_p);                   
                                                                                                              
  PROCEND dup$$channel_available;                                                                             
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$control_store', EJECT ??                                                                 
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns the contents of the specified control store register as a string.                   
                                                                                                              
  PROCEDURE [XDCL] dup$$control_store                                                                         
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $control_store, $cs (                                                                              
{   word: integer 0..32768 = $required                                                                        
{   processor: integer 0..3 = 0                                                                               
{   shadow: boolean = FALSE                                                                                   
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 3] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 3] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type3: record                                                                                           
        header: clt$type_specification_header,                                                                
        default_value: string (5),                                                                            
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [90, 9, 19, 8, 11, 20, 639],                                                                              
    clc$function, 3, 3, 1, 0, 0, 0, 0, ''], [                                                                 
    ['PROCESSOR                      ',clc$nominal_entry, 2],                                                 
    ['SHADOW                         ',clc$nominal_entry, 3],                                                 
    ['WORD                           ',clc$nominal_entry, 1]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [3, 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, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 2                                                                                                 
    [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, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 3                                                                                                 
    [2, 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, 3,                          
  clc$optional_default_parameter, 0, 5]],                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 32768, 10]],                                                               
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, 3, 10],                                                                    
    '0'],                                                                                                     
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$boolean_type],                                                                                
    'FALSE']];                                                                                                
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$word = 1,                                                                                             
      p$processor = 2,                                                                                        
      p$shadow = 3;                                                                                           
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 3] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      cell_p: ^cell,                                                                                          
      control_store_entry: dut$de_control_store_entry,                                                        
      control_store_p: ^ARRAY [0 .. *] OF dut$de_control_store_word,                                          
      control_store_size: 0 .. duc$de_control_store_size,                                                     
      default_list: ARRAY [1 .. 1] OF dut$default_change_list_entry,                                          
      desired_word: 0 .. duc$de_control_store_size,                                                           
      display_string: string (osc$max_string_size),                                                           
      lower: string (16),                                                                                     
      processor: 0 .. duc$de_maximum_processors,                                                              
      restart_file_seq_p: ^SEQ ( * ),                                                                         
      string_33: string (33),                                                                                 
      string_length: integer,                                                                                 
      upper: string (16);                                                                                     
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the PROCESSOR parameter.                                                   
                                                                                                              
    default_list [1].default_name := duc$dp_processor;                                                        
    default_list [1].number := p$processor;                                                                   
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    processor := pvt [p$processor].value^.integer_value.value;                                                
    IF pvt [p$shadow].value^.boolean_value.value THEN                                                         
      control_store_entry := duv$dump_environment_p^.control_store.shadow [processor];                        
    ELSE                                                                                                      
      control_store_entry := duv$dump_environment_p^.control_store.main [processor];                          
    IFEND;                                                                                                    
    IF NOT control_store_entry.available THEN                                                                 
      IF pvt [p$shadow].value^.boolean_value.value THEN                                                       
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                  
              'The shadow control store for processor', status);                                              
      ELSE                                                                                                    
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                  
              'The main control store for processor', status);                                                
      IFEND;                                                                                                  
      osp$append_status_integer (osc$status_parameter_delimiter, processor, 10, FALSE, status);               
      osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);                             
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    desired_word := pvt [p$word].value^.integer_value.value;                                                  
    control_store_size := control_store_entry.size - 1;                                                       
    IF desired_word > control_store_size THEN                                                                 
      STRINGREP (display_string, string_length, 'Control store address ', desired_word: #(16), '(16) is');    
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, display_string (1, string_length), 
            status);                                                                                          
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;            
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),                            
          control_store_entry.first_byte);                                                                    
    RESET restart_file_seq_p TO cell_p;                                                                       
    NEXT control_store_p: [0 .. control_store_size] IN restart_file_seq_p;                                    
    IF control_store_p = NIL THEN                                                                             
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    convert_integer_to_hex_string (control_store_p^ [desired_word].upper, 16, upper);                         
    convert_integer_to_hex_string (control_store_p^ [desired_word].lower, 16, lower);                         
                                                                                                              
    STRINGREP (string_33, string_length, upper, ' ', lower);                                                  
    clp$make_string_value (string_33 (1, string_length), work_area_p, result_p);                              
                                                                                                              
  PROCEND dup$$control_store;                                                                                 
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$control_store_byte', EJECT ??                                                            
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns the value of a specified byte of a specified control store register as an integer.  
                                                                                                              
  PROCEDURE [XDCL] dup$$control_store_byte                                                                    
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $control_store_byte, $csb (                                                                        
{   word: integer 0..32768 = $required                                                                        
{   byte: integer 0..15 = $required                                                                           
{   processor: integer 0..3 = 0                                                                               
{   shadow: boolean = FALSE                                                                                   
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 4] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 4] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type3: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type4: record                                                                                           
        header: clt$type_specification_header,                                                                
        default_value: string (5),                                                                            
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [90, 9, 19, 8, 14, 53, 691],                                                                              
    clc$function, 4, 4, 2, 0, 0, 0, 0, ''], [                                                                 
    ['BYTE                           ',clc$nominal_entry, 2],                                                 
    ['PROCESSOR                      ',clc$nominal_entry, 3],                                                 
    ['SHADOW                         ',clc$nominal_entry, 4],                                                 
    ['WORD                           ',clc$nominal_entry, 1]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [4, 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, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 2                                                                                                 
    [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, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 3                                                                                                 
    [2, 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, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 4                                                                                                 
    [3, 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, 3,                          
  clc$optional_default_parameter, 0, 5]],                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 32768, 10]],                                                               
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, 15, 10]],                                                                  
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$integer_type], [0, 3, 10],                                                                    
    '0'],                                                                                                     
{ PARAMETER 4                                                                                                 
    [[1, 0, clc$boolean_type],                                                                                
    'FALSE']];                                                                                                
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$word = 1,                                                                                             
      p$byte = 2,                                                                                             
      p$processor = 3,                                                                                        
      p$shadow = 4;                                                                                           
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 4] of clt$parameter_value;                                                             
                                                                                                              
    TYPE                                                                                                      
      t$byte_or_word = RECORD                                                                                 
        CASE boolean OF                                                                                       
        = FALSE =                                                                                             
          word: dut$de_control_store_word,                                                                    
        = TRUE =                                                                                              
          byte: PACKED ARRAY [0 .. 15] OF 0 .. 0ff(16),                                                       
        CASEND,                                                                                               
      RECEND;                                                                                                 
                                                                                                              
    VAR                                                                                                       
      byte_or_word: t$byte_or_word,                                                                           
      cell_p: ^cell,                                                                                          
      control_store_entry: dut$de_control_store_entry,                                                        
      control_store_p: ^ARRAY [0 .. *] OF dut$de_control_store_word,                                          
      control_store_size: 0 .. duc$de_control_store_size,                                                     
      default_list: ARRAY [1 .. 1] OF dut$default_change_list_entry,                                          
      desired_word: 0 .. duc$de_control_store_size,                                                           
      display_string: string (osc$max_string_size),                                                           
      processor: 0 .. duc$de_maximum_processors,                                                              
      restart_file_seq_p: ^SEQ ( * ),                                                                         
      string_length: integer;                                                                                 
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the PROCESSOR parameter.                                                   
                                                                                                              
    default_list [1].default_name := duc$dp_processor;                                                        
    default_list [1].number := p$processor;                                                                   
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    processor := pvt [p$processor].value^.integer_value.value;                                                
    IF pvt [p$shadow].value^.boolean_value.value THEN                                                         
      control_store_entry := duv$dump_environment_p^.control_store.shadow [processor];                        
    ELSE                                                                                                      
      control_store_entry := duv$dump_environment_p^.control_store.main [processor];                          
    IFEND;                                                                                                    
    IF NOT control_store_entry.available THEN                                                                 
      IF pvt [p$shadow].value^.boolean_value.value THEN                                                       
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                  
              'The shadow control store for processor', status);                                              
      ELSE                                                                                                    
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                  
              'The main control store for processor', status);                                                
      IFEND;                                                                                                  
      osp$append_status_integer (osc$status_parameter_delimiter, processor, 10, FALSE, status);               
      osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);                             
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    desired_word := pvt [p$word].value^.integer_value.value;                                                  
    control_store_size := control_store_entry.size - 1;                                                       
    IF desired_word > control_store_size THEN                                                                 
      STRINGREP (display_string, string_length, 'Control store address ', desired_word: #(16), '(16) is');    
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, display_string (1, string_length), 
            status);                                                                                          
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;            
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),                            
          control_store_entry.first_byte);                                                                    
    RESET restart_file_seq_p TO cell_p;                                                                       
    NEXT control_store_p: [0 .. control_store_size] IN restart_file_seq_p;                                    
    IF control_store_p = NIL THEN                                                                             
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    byte_or_word.word := control_store_p^ [desired_word];                                                     
                                                                                                              
    clp$make_integer_value (byte_or_word.byte [pvt [p$byte].value^.integer_value.value], 16, TRUE,            
          work_area_p, result_p);                                                                             
                                                                                                              
  PROCEND dup$$control_store_byte;                                                                            
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$dump_record', EJECT ??                                                                   
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns the dump record bytes specified as an integer.                                      
                                                                                                              
  PROCEDURE [XDCL] dup$$dump_record                                                                           
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $dump_record, $dr (                                                                                
{   record_name: any of                                                                                       
{       string 1..3                                                                                           
{       name                                                                                                  
{       integer                                                                                               
{     anyend = $required                                                                                      
{   offset: integer 0..500000 = $required                                                                     
{   byte: integer 1..8 = 8                                                                                    
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 3] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 3] 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$string_type_qualifier,                                                               
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$name_type_qualifier,                                                                 
        recend,                                                                                               
        type_size_3: clt$type_specification_size,                                                             
        element_type_spec_3: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$integer_type_qualifier,                                                              
        recend,                                                                                               
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type3: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 8, 16, 14, 44, 53, 350],                                                                             
    clc$function, 3, 3, 2, 0, 0, 0, 0, ''], [                                                                 
    ['BYTE                           ',clc$nominal_entry, 3],                                                 
    ['OFFSET                         ',clc$nominal_entry, 2],                                                 
    ['RECORD_NAME                    ',clc$nominal_entry, 1]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [3, 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, 57, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 2                                                                                                 
    [2, 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, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 3                                                                                                 
    [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, 20,                         
  clc$optional_default_parameter, 0, 1]],                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$union_type], [[clc$integer_type, clc$name_type, clc$string_type],                             
    FALSE, 3],                                                                                                
    8, [[1, 0, clc$string_type], [1, 3, FALSE]],                                                              
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],                                                       
    20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]]                                    
    ],                                                                                                        
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, 500000, 10]],                                                              
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$integer_type], [1, 8, 10],                                                                    
    '8']];                                                                                                    
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$record_name = 1,                                                                                      
      p$offset = 2,                                                                                           
      p$byte = 3;                                                                                             
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 3] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      byte_length: 1 .. 8,                                                                                    
      cell_p: ^cell,                                                                                          
      data_array_p: ^ARRAY [ * ] OF 0 .. 0ff(16),                                                             
      data_p: ^integer,                                                                                       
      data_seq_p: ^SEQ ( * ),                                                                                 
      display_string: string (osc$max_string_size),                                                           
      entry_p: ^dut$de_other_record_entry,                                                                    
      offset: 0 .. duc$de_max_other_record_length,                                                            
      restart_file_array_p: ^ARRAY [ * ] OF 0 .. 0ff(16),                                                     
      restart_file_seq_p: ^SEQ ( * ),                                                                         
      skip_data_p: ^SEQ ( * ),                                                                                
      string_length: integer;                                                                                 
                                                                                                              
    status.normal := TRUE;                                                                                    
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Search for the desired record.                                                                          
                                                                                                              
    dup$find_record_list_entry (pvt [p$record_name].value^, entry_p);                                         
    IF entry_p = NIL THEN                                                                                     
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The specified record is',         
            status);                                                                                          
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF entry_p^.record_type = duc$de_ort_report THEN                                                          
      osp$set_status_abnormal (duc$dump_analyzer_id, due$record_type_supported, 'DUMP', status);              
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Determine offset and size of area to dump.                                                              
                                                                                                              
    offset := pvt [p$offset].value^.integer_value.value;                                                      
    byte_length := pvt [p$byte].value^.integer_value.value;                                                   
    IF offset > entry_p^.size THEN                                                                            
      STRINGREP (display_string, string_length, 'Dump record offset ', offset: #(16), '(16) is');             
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, display_string (1, string_length), 
            status);                                                                                          
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF (offset + byte_length) > entry_p^.size THEN                                                            
      byte_length := entry_p^.size - offset;                                                                  
    IFEND;                                                                                                    
                                                                                                              
    { Retrieve a pointer to the dump record.                                                                  
                                                                                                              
    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;            
    cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),                            
          entry_p^.first_byte + offset);                                                                      
    RESET restart_file_seq_p TO cell_p;                                                                       
                                                                                                              
    { Allocate an area to store the data.                                                                     
                                                                                                              
    PUSH data_seq_p: [[REP 1 OF integer]];                                                                    
    RESET data_seq_p;                                                                                         
    IF data_seq_p = NIL THEN                                                                                  
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Zero out the temporary area.                                                                            
                                                                                                              
    NEXT data_p IN data_seq_p;                                                                                
    IF data_p = NIL THEN                                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    data_p^ := 0;                                                                                             
    RESET data_seq_p;                                                                                         
    IF byte_length < 8 THEN                                                                                   
      NEXT skip_data_p: [[REP (8 - byte_length) OF cell]] IN data_seq_p;                                      
      IF skip_data_p = NIL THEN                                                                               
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    { Copy the data from the restart file to temporary area.                                                  
                                                                                                              
    NEXT restart_file_array_p: [1 .. byte_length] IN restart_file_seq_p;                                      
    IF restart_file_array_p = NIL THEN                                                                        
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    NEXT data_array_p: [1 .. byte_length] IN data_seq_p;                                                      
    IF data_array_p = NIL THEN                                                                                
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    data_array_p^ := restart_file_array_p^;                                                                   
                                                                                                              
    clp$make_integer_value (data_p^, 16, TRUE, work_area_p, result_p);                                        
                                                                                                              
  PROCEND dup$$dump_record;                                                                                   
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$dump_record_available', EJECT ??                                                         
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns a boolean of TRUE if the specified dump record is on the restart file.              
                                                                                                              
  PROCEDURE [XDCL] dup$$dump_record_available                                                                 
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $dump_record_available, $dump_record_avail, $dra (                                                 
{   record_name: any of                                                                                       
{       string 1..3                                                                                           
{       name                                                                                                  
{       integer                                                                                               
{     anyend = $required                                                                                      
{   )                                                                                                         
                                                                                                              
?? 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$string_type_qualifier,                                                               
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$name_type_qualifier,                                                                 
        recend,                                                                                               
        type_size_3: clt$type_specification_size,                                                             
        element_type_spec_3: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$integer_type_qualifier,                                                              
        recend,                                                                                               
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 8, 16, 14, 47, 24, 389],                                                                             
    clc$function, 1, 1, 1, 0, 0, 0, 0, ''], [                                                                 
    ['RECORD_NAME                    ',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, 57, clc$required_parameter, 
  0, 0]],                                                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$union_type], [[clc$integer_type, clc$name_type, clc$string_type],                             
    FALSE, 3],                                                                                                
    8, [[1, 0, clc$string_type], [1, 3, FALSE]],                                                              
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],                                                       
    20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]]                                    
    ]];                                                                                                       
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$record_name = 1;                                                                                      
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 1] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      entry_p: ^dut$de_other_record_entry,                                                                    
      record_available: boolean;                                                                              
                                                                                                              
    status.normal := TRUE;                                                                                    
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Search for the desired record.                                                                          
                                                                                                              
    record_available := FALSE;                                                                                
    dup$find_record_list_entry (pvt [p$record_name].value^, entry_p);                                         
    IF (entry_p <> NIL) AND (entry_p^.record_type <> duc$de_ort_detail) THEN                                  
      record_available := (entry_p^.size <> 0);                                                               
    IFEND;                                                                                                    
                                                                                                              
    clp$make_boolean_value (record_available, clc$true_false_boolean, work_area_p, result_p);                 
                                                                                                              
  PROCEND dup$$dump_record_available;                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$dump_record_length', EJECT ??                                                            
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns the length of the specified dump record.                                            
                                                                                                              
  PROCEDURE [XDCL] dup$$dump_record_length                                                                    
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $dump_record_length, $drl (                                                                        
{   record_name: any of                                                                                       
{       string 1..3                                                                                           
{       name                                                                                                  
{       integer                                                                                               
{     anyend = $required                                                                                      
{   )                                                                                                         
                                                                                                              
?? 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$string_type_qualifier,                                                               
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$name_type_qualifier,                                                                 
        recend,                                                                                               
        type_size_3: clt$type_specification_size,                                                             
        element_type_spec_3: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$integer_type_qualifier,                                                              
        recend,                                                                                               
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 8, 16, 14, 48, 58, 820],                                                                             
    clc$function, 1, 1, 1, 0, 0, 0, 0, ''], [                                                                 
    ['RECORD_NAME                    ',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, 57, clc$required_parameter, 
  0, 0]],                                                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$union_type], [[clc$integer_type, clc$name_type, clc$string_type],                             
    FALSE, 3],                                                                                                
    8, [[1, 0, clc$string_type], [1, 3, FALSE]],                                                              
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],                                                       
    20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]]                                    
    ]];                                                                                                       
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$record_name = 1;                                                                                      
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 1] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      entry_p: ^dut$de_other_record_entry;                                                                    
                                                                                                              
    status.normal := TRUE;                                                                                    
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Search for the desired record.                                                                          
                                                                                                              
    dup$find_record_list_entry (pvt [p$record_name].value^, entry_p);                                         
    IF entry_p = NIL THEN                                                                                     
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The specified record is',         
            status);                                                                                          
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF entry_p^.record_type = duc$de_ort_detail THEN                                                          
      osp$set_status_abnormal (duc$dump_analyzer_id, due$record_type_supported, 'DUMP or REPORT', status);    
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    clp$make_integer_value (entry_p^.size, 10, TRUE, work_area_p, result_p);                                  
                                                                                                              
  PROCEND dup$$dump_record_length;                                                                            
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$dump_record_type', EJECT ??                                                              
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns the type of the specified dump record as a name.                                    
                                                                                                              
  PROCEDURE [XDCL] dup$$dump_record_type                                                                      
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $dump_record_type, $drt (                                                                          
{   record_name: any of                                                                                       
{       string 1..3                                                                                           
{       name                                                                                                  
{       integer                                                                                               
{     anyend = $required                                                                                      
{   )                                                                                                         
                                                                                                              
?? 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$string_type_qualifier,                                                               
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$name_type_qualifier,                                                                 
        recend,                                                                                               
        type_size_3: clt$type_specification_size,                                                             
        element_type_spec_3: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$integer_type_qualifier,                                                              
        recend,                                                                                               
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 12, 11, 12, 7, 54, 386],                                                                             
    clc$function, 1, 1, 1, 0, 0, 0, 0, ''], [                                                                 
    ['RECORD_NAME                    ',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, 57, clc$required_parameter, 
  0, 0]],                                                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$union_type], [[clc$integer_type, clc$name_type, clc$string_type],                             
    FALSE, 3],                                                                                                
    8, [[1, 0, clc$string_type], [1, 3, FALSE]],                                                              
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],                                                       
    20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]]                                    
    ]];                                                                                                       
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$record_name = 1;                                                                                      
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 1] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      entry_p: ^dut$de_other_record_entry,                                                                    
      record_type: ost$name;                                                                                  
                                                                                                              
    status.normal := TRUE;                                                                                    
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Search for the desired record.                                                                          
                                                                                                              
    dup$find_record_list_entry (pvt [p$record_name].value^, entry_p);                                         
    IF entry_p = NIL THEN                                                                                     
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The specified record is',         
            status);                                                                                          
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF entry_p^.record_type = duc$de_ort_dump THEN                                                            
      record_type := 'DUMP';                                                                                  
    ELSEIF entry_p^.record_type = duc$de_ort_report THEN                                                      
      record_type := 'REPORT';                                                                                
    ELSE                                                                                                      
      record_type := 'DETAIL';                                                                                
    IFEND;                                                                                                    
                                                                                                              
    clp$make_name_value (record_type, work_area_p, result_p);                                                 
                                                                                                              
  PROCEND dup$$dump_record_type;                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$maintenance_register', EJECT ??                                                          
                                                                                                              
{ PURPOSE:                                                                                                    
{ This function returns the desired maintenance register as an integer.                                       
                                                                                                              
  PROCEDURE [XDCL] dup$$maintenance_register                                                                  
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $maintenance_register, $mr (                                                                       
{   register: any of                                                                                          
{       key                                                                                                   
{         (job_process_state jps) (monitor_process_state mps)                                                 
{       keyend                                                                                                
{       integer 0..255                                                                                        
{     anyend = $required                                                                                      
{   element: key                                                                                              
{       (input_output_unit iou) (memory m) (processor p)                                                      
{     keyend = processor                                                                                      
{   processor: integer 0..3 = 0                                                                               
{   iou: integer 0..1 = 0                                                                                     
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 4] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 4] 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 .. 4] of clt$keyword_specification,                                         
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$integer_type_qualifier,                                                              
        recend,                                                                                               
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$keyword_type_qualifier,                                                                
        keyword_specs: array [1 .. 6] of clt$keyword_specification,                                           
        default_value: string (9),                                                                            
      recend,                                                                                                 
      type3: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type4: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 6, 20, 10, 26, 9, 732],                                                                              
    clc$function, 4, 4, 1, 0, 0, 0, 0, ''], [                                                                 
    ['ELEMENT                        ',clc$nominal_entry, 2],                                                 
    ['IOU                            ',clc$nominal_entry, 4],                                                 
    ['PROCESSOR                      ',clc$nominal_entry, 3],                                                 
    ['REGISTER                       ',clc$nominal_entry, 1]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [4, 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, 195,                        
  clc$required_parameter, 0, 0],                                                                              
{ PARAMETER 2                                                                                                 
    [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, 229,                        
  clc$optional_default_parameter, 0, 9],                                                                      
{ PARAMETER 3                                                                                                 
    [3, 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, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 4                                                                                                 
    [2, 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, 20,                         
  clc$optional_default_parameter, 0, 1]],                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],                                           
    FALSE, 2],                                                                                                
    155, [[1, 0, clc$keyword_type], [4], [                                                                    
      ['JOB_PROCESS_STATE              ', clc$nominal_entry, clc$normal_usage_entry, 1],                      
      ['JPS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                 
      ['MONITOR_PROCESS_STATE          ', clc$nominal_entry, clc$normal_usage_entry, 2],                      
      ['MPS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2]]                 
      ],                                                                                                      
    20, [[1, 0, clc$integer_type], [0, 255, 10]]                                                              
    ],                                                                                                        
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$keyword_type], [6], [                                                                         
    ['INPUT_OUTPUT_UNIT              ', clc$nominal_entry, clc$normal_usage_entry, 1],                        
    ['IOU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                   
    ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                   
    ['MEMORY                         ', clc$nominal_entry, clc$normal_usage_entry, 2],                        
    ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                   
    ['PROCESSOR                      ', clc$nominal_entry, clc$normal_usage_entry, 3]]                        
    ,                                                                                                         
    'processor'],                                                                                             
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$integer_type], [0, 3, 10],                                                                    
    '0'],                                                                                                     
{ PARAMETER 4                                                                                                 
    [[1, 0, clc$integer_type], [0, 1, 10],                                                                    
    '0']];                                                                                                    
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$register = 1,                                                                                         
      p$element = 2,                                                                                          
      p$processor = 3,                                                                                        
      p$iou = 4;                                                                                              
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 4] of clt$parameter_value;                                                             
                                                                                                              
    TYPE                                                                                                      
      t$integer_or_array = RECORD                                                                             
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          array_part: ARRAY [1 .. duc$de_max_register_length] OF 0 .. 0ff(16),                                
        = FALSE =                                                                                             
          integer_part: integer,                                                                              
        CASEND,                                                                                               
      RECEND;                                                                                                 
                                                                                                              
    VAR                                                                                                       
      default_list: ARRAY [1 .. 2] OF dut$default_change_list_entry,                                          
      display_string: string (osc$max_string_size),                                                           
      integer_or_array: t$integer_or_array,                                                                   
      processor: 0 .. duc$de_maximum_processors,                                                              
      register: dut$de_maintenance_register,                                                                  
      string_length: integer;                                                                                 
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the PROCESSOR and IOU parameters.                                          
                                                                                                              
    default_list [1].default_name := duc$dp_processor;                                                        
    default_list [1].number := p$processor;                                                                   
    default_list [2].default_name := duc$dp_iou;                                                              
    default_list [2].number := p$iou;                                                                         
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF (pvt [p$register].value^.kind = clc$keyword) AND                                                       
          (pvt [p$element].value^.keyword_value <> 'PROCESSOR') THEN                                          
      osp$set_status_abnormal (duc$dump_analyzer_id, due$register_not_defined,                                
            pvt [p$register].value^.keyword_value, status);                                                   
      osp$append_status_parameter (osc$status_parameter_delimiter, pvt [p$element].value^.keyword_value,      
            status);                                                                                          
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF pvt [p$element].value^.keyword_value = 'INPUT_OUTPUT_UNIT' THEN                                        
      dup$retrieve_register (duc$de_iou, pvt [p$iou].value^.integer_value.value,                              
            pvt [p$register].value^.integer_value.value, register);                                           
      IF register.available THEN                                                                              
        integer_or_array.array_part := register.value;                                                        
        clp$make_integer_value (integer_or_array.integer_part, 16, TRUE, work_area_p, result_p);              
      ELSE                                                                                                    
        STRINGREP (display_string, string_length, 'IOU register',                                             
              pvt [p$register].value^.integer_value.value: #(16), '(16) is');                                 
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                  
              display_string (1, string_length), status);                                                     
      IFEND;                                                                                                  
                                                                                                              
    ELSEIF pvt [p$element].value^.keyword_value = 'MEMORY' THEN                                               
      dup$retrieve_register (duc$de_memory, 0, pvt [p$register].value^.integer_value.value, register);        
      IF register.available THEN                                                                              
        integer_or_array.array_part := register.value;                                                        
        clp$make_integer_value (integer_or_array.integer_part, 16, TRUE, work_area_p, result_p);              
      ELSE                                                                                                    
        STRINGREP (display_string, string_length, 'Memory register',                                          
              pvt [p$register].value^.integer_value.value: #(16), '(16) is');                                 
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                  
              display_string (1, string_length), status);                                                     
      IFEND;                                                                                                  
                                                                                                              
    ELSE  { pvt [p$element].value^.keyword_value = 'PROCESSOR' }                                              
      processor := pvt [p$processor].value^.integer_value.value;                                              
      IF NOT duv$execution_environment.processor_registers [processor].available THEN                         
        osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                  
              'The processor maintenance registers for processor', status);                                   
        osp$append_status_integer (osc$status_parameter_delimiter, processor, 10, FALSE, status);             
        osp$append_status_parameter (osc$status_parameter_delimiter, 'are', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      IF pvt [p$register].value^.kind = clc$keyword THEN                                                      
        IF pvt [p$register].value^.keyword_value = 'JOB_PROCESS_STATE' THEN                                   
          integer_or_array.integer_part :=                                                                    
                duv$execution_environment.processor_registers [processor].job_process_state;                  
        ELSE                                                                                                  
          integer_or_array.integer_part :=                                                                    
                duv$execution_environment.processor_registers [processor].monitor_process_state;              
        IFEND;                                                                                                
        clp$make_integer_value (integer_or_array.integer_part, 16, TRUE, work_area_p, result_p);              
                                                                                                              
      ELSEIF pvt [p$register].value^.integer_value.value = osc$pr_job_process_state THEN                      
        integer_or_array.integer_part :=                                                                      
              duv$execution_environment.processor_registers [processor].job_process_state;                    
        clp$make_integer_value (integer_or_array.integer_part, 16, TRUE, work_area_p, result_p);              
                                                                                                              
      ELSEIF pvt [p$register].value^.integer_value.value = osc$pr_monitor_process_state THEN                  
        integer_or_array.integer_part :=                                                                      
              duv$execution_environment.processor_registers [processor].monitor_process_state;                
        clp$make_integer_value (integer_or_array.integer_part, 16, TRUE, work_area_p, result_p);              
                                                                                                              
      ELSE                                                                                                    
        dup$retrieve_register (duc$de_cpu, processor, pvt [p$register].value^.integer_value.value, register); 
        IF register.available THEN                                                                            
          integer_or_array.array_part := register.value;                                                      
          clp$make_integer_value (integer_or_array.integer_part, 16, TRUE, work_area_p, result_p);            
        ELSE                                                                                                  
          STRINGREP (display_string, string_length, 'The processor register',                                 
                pvt [p$register].value^.integer_value.value: #(16), '(16) for processor');                    
          osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                
                display_string (1, string_length), status);                                                   
          osp$append_status_integer (osc$status_parameter_delimiter, processor, 10, FALSE, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);                         
        IFEND;                                                                                                
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
  PROCEND dup$$maintenance_register;                                                                          
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$memory', EJECT ??                                                                        
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns the contents of the memory address specified as an integer.                         
                                                                                                              
  PROCEDURE [XDCL] dup$$memory                                                                                
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $memory, $mem (                                                                                    
{   address: integer 0..0ffffffffffff(16) = $required                                                         
{   byte_count: integer 1..8 = 6                                                                              
{   exchange: any of                                                                                          
{       key                                                                                                   
{         (active a) (monitor m) (job j)                                                                      
{       keyend                                                                                                
{       integer 0..0ffffffff(16)                                                                              
{     anyend = 0ffffffff(16)                                                                                  
{   processor: integer 0..3 = 0                                                                               
{   address_mode: key                                                                                         
{       (process_virtual_address pva) (system_virtual_address sva) (real_memory_address rma)                  
{     keyend = process_virtual_address                                                                        
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 5] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 5] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type3: 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 .. 6] of clt$keyword_specification,                                         
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$integer_type_qualifier,                                                              
        recend,                                                                                               
        default_value: string (13),                                                                           
      recend,                                                                                                 
      type4: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type5: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$keyword_type_qualifier,                                                                
        keyword_specs: array [1 .. 6] of clt$keyword_specification,                                           
        default_value: string (23),                                                                           
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 6, 14, 10, 10, 17, 787],                                                                             
    clc$function, 5, 5, 1, 0, 0, 0, 0, ''], [                                                                 
    ['ADDRESS                        ',clc$nominal_entry, 1],                                                 
    ['ADDRESS_MODE                   ',clc$nominal_entry, 5],                                                 
    ['BYTE_COUNT                     ',clc$nominal_entry, 2],                                                 
    ['EXCHANGE                       ',clc$nominal_entry, 3],                                                 
    ['PROCESSOR                      ',clc$nominal_entry, 4]],                                                
    [                                                                                                         
{ 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, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 2                                                                                                 
    [3, 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, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 3                                                                                                 
    [4, 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, 269,                        
  clc$optional_default_parameter, 0, 13],                                                                     
{ PARAMETER 4                                                                                                 
    [5, 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, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 5                                                                                                 
    [2, 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, 229,                        
  clc$optional_default_parameter, 0, 23]],                                                                    
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 0ffffffffffff(16), 10]],                                                   
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [1, 8, 10],                                                                    
    '6'],                                                                                                     
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],                                           
    FALSE, 2],                                                                                                
    229, [[1, 0, clc$keyword_type], [6], [                                                                    
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                 
      ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],                      
      ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                 
      ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 3],                      
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                 
      ['MONITOR                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]                      
      ],                                                                                                      
    20, [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]]                                                    
    ,                                                                                                         
    '0ffffffff(16)'],                                                                                         
{ PARAMETER 4                                                                                                 
    [[1, 0, clc$integer_type], [0, 3, 10],                                                                    
    '0'],                                                                                                     
{ PARAMETER 5                                                                                                 
    [[1, 0, clc$keyword_type], [6], [                                                                         
    ['PROCESS_VIRTUAL_ADDRESS        ', clc$nominal_entry, clc$normal_usage_entry, 1],                        
    ['PVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                   
    ['REAL_MEMORY_ADDRESS            ', clc$nominal_entry, clc$normal_usage_entry, 3],                        
    ['RMA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                   
    ['SVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                   
    ['SYSTEM_VIRTUAL_ADDRESS         ', clc$nominal_entry, clc$normal_usage_entry, 2]]                        
    ,                                                                                                         
    'process_virtual_address']];                                                                              
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$address = 1,                                                                                          
      p$byte_count = 2,                                                                                       
      p$exchange = 3,                                                                                         
      p$processor = 4,                                                                                        
      p$address_mode = 5;                                                                                     
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 5] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      access_data: dut$access_data,                                                                           
      address: dut$ee_address_parameter,                                                                      
      byte_count: 1 .. 8,                                                                                     
      bytes_returned: ost$segment_length,                                                                     
      data_array_p: ^ARRAY [ * ] OF 0 .. 0ff(16),                                                             
      data_p: ^integer,                                                                                       
      data_seq_p: ^SEQ ( * ),                                                                                 
      default_list: ARRAY [1 .. 3] OF dut$default_change_list_entry,                                          
      exchange_package_p: ^dut$exchange_package,                                                              
      memory_file_array_p: ^ARRAY [ * ] OF 0 .. 0ff(16),                                                      
      memory_p: ^cell,                                                                                        
      new_byte_size: ost$segment_length,                                                                      
      processor: 0 .. duc$de_maximum_processors,                                                              
      skip_data_p: ^SEQ ( * );                                                                                
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the EXCHANGE, PROCESSOR and ADDRESS_MODE parameters.                       
                                                                                                              
    default_list [1].default_name := duc$dp_exchange;                                                         
    default_list [1].number := p$exchange;                                                                    
    default_list [2].default_name := duc$dp_processor;                                                        
    default_list [2].number := p$processor;                                                                   
    default_list [3].default_name := duc$dp_address_mode;                                                     
    default_list [3].number := p$address_mode;                                                                
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    address.rma_part := pvt [p$address].value^.integer_value.value;                                           
    processor := pvt [p$processor].value^.integer_value.value;                                                
    byte_count := pvt [p$byte_count].value^.integer_value.value;                                              
                                                                                                              
    PUSH data_seq_p: [[REP 1 OF integer]];                                                                    
    RESET data_seq_p;                                                                                         
    IF data_seq_p = NIL THEN                                                                                  
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    NEXT data_p IN data_seq_p;                                                                                
    IF data_p = NIL THEN                                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    data_p^ := 0;                                                                                             
    RESET data_seq_p;                                                                                         
                                                                                                              
    IF pvt [p$address_mode].value^.keyword_value = 'PROCESS_VIRTUAL_ADDRESS' THEN                             
      dup$retrieve_exchange_package (processor, pvt [p$exchange].value^, exchange_package_p, status);         
      IF NOT status.normal THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      IF byte_count < 8 THEN                                                                                  
        NEXT skip_data_p: [[REP (8 - byte_count) OF cell]] IN data_seq_p;                                     
        IF skip_data_p = NIL THEN                                                                             
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
      IFEND;                                                                                                  
      dup$copy_virtual_memory_pva (address.pva_part, exchange_package_p^, processor, byte_count, TRUE,        
            bytes_returned, data_seq_p, access_data, status);                                                 
      IF NOT status.normal AND (status.condition <> due$memory_partially_avail) THEN                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      IF access_data.page_fault AND NOT access_data.memory_found THEN                                         
        osp$set_status_abnormal (duc$dump_analyzer_id, due$page_fault_error_severity, '', status);            
        osp$append_status_parameter (osc$status_parameter_delimiter, ', segment = ', status);                 
        osp$append_status_integer (osc$status_parameter_delimiter, address.pva_part.seg, 16, TRUE, status);   
        osp$append_status_parameter (osc$status_parameter_delimiter, ', offset = ', status);                  
        osp$append_status_integer (osc$status_parameter_delimiter, access_data.page_fault_offset, 16, TRUE,   
              status);                                                                                        
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
    ELSEIF pvt [p$address_mode].value^.keyword_value = 'SYSTEM_VIRTUAL_ADDRESS' THEN                          
      IF byte_count < 8 THEN                                                                                  
        NEXT skip_data_p: [[REP (8 - byte_count) OF cell]] IN data_seq_p;                                     
        IF skip_data_p = NIL THEN                                                                             
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
      IFEND;                                                                                                  
      dup$copy_virtual_memory_sva (address.sva_part, processor, byte_count, TRUE, bytes_returned,             
            data_seq_p, access_data, status);                                                                 
      IF NOT status.normal AND (status.condition <> due$memory_partially_avail) THEN                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      IF access_data.page_fault AND NOT access_data.memory_found THEN                                         
        osp$set_status_abnormal (duc$dump_analyzer_id, due$page_fault_error_severity, '', status);            
        osp$append_status_parameter (osc$status_parameter_delimiter, ', asid = ', status);                    
        osp$append_status_integer (osc$status_parameter_delimiter, address.sva_part.asid.value, 16, TRUE,     
              status);                                                                                        
        osp$append_status_parameter (osc$status_parameter_delimiter, ', offset = ', status);                  
        osp$append_status_integer (osc$status_parameter_delimiter, access_data.page_fault_offset, 16, TRUE,   
              status);                                                                                        
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
    ELSE  { pvt [p$address_mode].value^.keyword_value = 'REAL_MEMORY_ADDRESS' }                               
      dup$access_real_memory (byte_count, address.rma_part, memory_p, new_byte_size, status);                 
      IF NOT status.normal AND (status.condition <> due$memory_partially_avail) THEN                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      IF new_byte_size < 8 THEN                                                                               
        NEXT skip_data_p: [[REP (8 - new_byte_size) OF cell]] IN data_seq_p;                                  
        IF skip_data_p = NIL THEN                                                                             
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
      IFEND;                                                                                                  
      RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO memory_p;              
      NEXT memory_file_array_p: [1 .. new_byte_size] IN                                                       
            duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                          
      IF memory_file_array_p = NIL THEN                                                                       
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      NEXT data_array_p: [1 .. new_byte_size] IN data_seq_p;                                                  
      IF data_array_p = NIL THEN                                                                              
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      data_array_p^ := memory_file_array_p^;                                                                  
    IFEND;                                                                                                    
                                                                                                              
    clp$make_integer_value (data_p^, 16, TRUE, work_area_p, result_p);                                        
                                                                                                              
  PROCEND dup$$memory;                                                                                        
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$memory_string', EJECT ??                                                                 
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns the contents of the memory address as a string.                                     
                                                                                                              
  PROCEDURE [XDCL] dup$$memory_string                                                                         
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $memory_string, $ms (                                                                              
{   address: integer 0..0ffffffffffff(16) = $required                                                         
{   byte_count: integer 0..256 = 1                                                                            
{   exchange: any of                                                                                          
{       key                                                                                                   
{         (active a) (monitor m) (job j)                                                                      
{       keyend                                                                                                
{       integer 0..0ffffffff(16)                                                                              
{     anyend = 0ffffffff(16)                                                                                  
{   processor: integer 0..3 = 0                                                                               
{   address_mode: key                                                                                         
{       (process_virtual_address pva) (system_virtual_address sva) (real_memory_address rma)                  
{     keyend = process_virtual_address                                                                        
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 5] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 5] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type3: 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 .. 6] of clt$keyword_specification,                                         
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$integer_type_qualifier,                                                              
        recend,                                                                                               
        default_value: string (13),                                                                           
      recend,                                                                                                 
      type4: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type5: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$keyword_type_qualifier,                                                                
        keyword_specs: array [1 .. 6] of clt$keyword_specification,                                           
        default_value: string (23),                                                                           
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 6, 14, 10, 18, 40, 198],                                                                             
    clc$function, 5, 5, 1, 0, 0, 0, 0, ''], [                                                                 
    ['ADDRESS                        ',clc$nominal_entry, 1],                                                 
    ['ADDRESS_MODE                   ',clc$nominal_entry, 5],                                                 
    ['BYTE_COUNT                     ',clc$nominal_entry, 2],                                                 
    ['EXCHANGE                       ',clc$nominal_entry, 3],                                                 
    ['PROCESSOR                      ',clc$nominal_entry, 4]],                                                
    [                                                                                                         
{ 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, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 2                                                                                                 
    [3, 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, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 3                                                                                                 
    [4, 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, 269,                        
  clc$optional_default_parameter, 0, 13],                                                                     
{ PARAMETER 4                                                                                                 
    [5, 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, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 5                                                                                                 
    [2, 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, 229,                        
  clc$optional_default_parameter, 0, 23]],                                                                    
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 0ffffffffffff(16), 10]],                                                   
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, 256, 10],                                                                  
    '1'],                                                                                                     
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],                                           
    FALSE, 2],                                                                                                
    229, [[1, 0, clc$keyword_type], [6], [                                                                    
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                 
      ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],                      
      ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                 
      ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 3],                      
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                 
      ['MONITOR                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]                      
      ],                                                                                                      
    20, [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]]                                                    
    ,                                                                                                         
    '0ffffffff(16)'],                                                                                         
{ PARAMETER 4                                                                                                 
    [[1, 0, clc$integer_type], [0, 3, 10],                                                                    
    '0'],                                                                                                     
{ PARAMETER 5                                                                                                 
    [[1, 0, clc$keyword_type], [6], [                                                                         
    ['PROCESS_VIRTUAL_ADDRESS        ', clc$nominal_entry, clc$normal_usage_entry, 1],                        
    ['PVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                   
    ['REAL_MEMORY_ADDRESS            ', clc$nominal_entry, clc$normal_usage_entry, 3],                        
    ['RMA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                   
    ['SVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                   
    ['SYSTEM_VIRTUAL_ADDRESS         ', clc$nominal_entry, clc$normal_usage_entry, 2]]                        
    ,                                                                                                         
    'process_virtual_address']];                                                                              
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$address = 1,                                                                                          
      p$byte_count = 2,                                                                                       
      p$exchange = 3,                                                                                         
      p$processor = 4,                                                                                        
      p$address_mode = 5;                                                                                     
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 5] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      access_data: dut$access_data,                                                                           
      address: dut$ee_address_parameter,                                                                      
      byte_count: 1 .. 8,                                                                                     
      bytes_returned: ost$segment_length,                                                                     
      data_array_p: ^ARRAY [ * ] OF 0 .. 0ff(16),                                                             
      data_p: ^string ( * ),                                                                                  
      data_seq_p: ^SEQ ( * ),                                                                                 
      default_list: ARRAY [1 .. 3] OF dut$default_change_list_entry,                                          
      exchange_package_p: ^dut$exchange_package,                                                              
      memory_file_array_p: ^ARRAY [ * ] OF 0 .. 0ff(16),                                                      
      memory_p: ^cell,                                                                                        
      new_byte_size: ost$segment_length,                                                                      
      processor: 0 .. duc$de_maximum_processors,                                                              
      skip_data_p: ^SEQ ( * );                                                                                
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the EXCHANGE, PROCESSOR and ADDRESS_MODE parameters.                       
                                                                                                              
    default_list [1].default_name := duc$dp_exchange;                                                         
    default_list [1].number := p$exchange;                                                                    
    default_list [2].default_name := duc$dp_processor;                                                        
    default_list [2].number := p$processor;                                                                   
    default_list [3].default_name := duc$dp_address_mode;                                                     
    default_list [3].number := p$address_mode;                                                                
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    address.rma_part := pvt [p$address].value^.integer_value.value;                                           
    processor := pvt [p$processor].value^.integer_value.value;                                                
    byte_count := pvt [p$byte_count].value^.integer_value.value;                                              
                                                                                                              
    IF byte_count = 0 THEN                                                                                    
      clp$make_string_value ('', work_area_p, result_p);                                                      
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    PUSH data_seq_p: [[REP byte_count OF char]];                                                              
    RESET data_seq_p;                                                                                         
    IF data_seq_p = NIL THEN                                                                                  
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    NEXT data_p: [byte_count] IN data_seq_p;                                                                  
    IF data_p = NIL THEN                                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    data_p^ := ' ';                                                                                           
    RESET data_seq_p;                                                                                         
                                                                                                              
    IF pvt [p$address_mode].value^.keyword_value = 'PROCESS_VIRTUAL_ADDRESS' THEN                             
      dup$retrieve_exchange_package (processor, pvt [p$exchange].value^, exchange_package_p, status);         
      IF NOT status.normal THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      dup$copy_virtual_memory_pva (address.pva_part, exchange_package_p^, processor, byte_count, TRUE,        
            bytes_returned, data_seq_p, access_data, status);                                                 
      IF NOT status.normal AND (status.condition <> due$memory_partially_avail) THEN                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      IF access_data.page_fault AND NOT access_data.memory_found THEN                                         
        osp$set_status_abnormal (duc$dump_analyzer_id, due$page_fault_error_severity, '', status);            
        osp$append_status_parameter (osc$status_parameter_delimiter, ', segment = ', status);                 
        osp$append_status_integer (osc$status_parameter_delimiter, address.pva_part.seg, 16, TRUE, status);   
        osp$append_status_parameter (osc$status_parameter_delimiter, ', offset = ', status);                  
        osp$append_status_integer (osc$status_parameter_delimiter, access_data.page_fault_offset, 16, TRUE,   
              status);                                                                                        
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
    ELSEIF pvt [p$address_mode].value^.keyword_value = 'SYSTEM_VIRTUAL_ADDRESS' THEN                          
      dup$copy_virtual_memory_sva (address.sva_part, processor, byte_count, TRUE, bytes_returned,             
            data_seq_p, access_data, status);                                                                 
      IF NOT status.normal AND (status.condition <> due$memory_partially_avail) THEN                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      IF access_data.page_fault AND NOT access_data.memory_found THEN                                         
        osp$set_status_abnormal (duc$dump_analyzer_id, due$page_fault_error_severity, '', status);            
        osp$append_status_parameter (osc$status_parameter_delimiter, ', asid = ', status);                    
        osp$append_status_integer (osc$status_parameter_delimiter, address.sva_part.asid.value, 16, TRUE,     
              status);                                                                                        
        osp$append_status_parameter (osc$status_parameter_delimiter, ', offset = ', status);                  
        osp$append_status_integer (osc$status_parameter_delimiter, access_data.page_fault_offset, 16, TRUE,   
              status);                                                                                        
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
    ELSE  { pvt [p$address_mode].value^.keyword_value = 'REAL_MEMORY_ADDRESS' }                               
      dup$access_real_memory (byte_count, address.rma_part, memory_p, new_byte_size, status);                 
      IF NOT status.normal AND (status.condition <> due$memory_partially_avail) THEN                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO memory_p;              
      NEXT memory_file_array_p: [1 .. new_byte_size] IN                                                       
            duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                          
      IF memory_file_array_p = NIL THEN                                                                       
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      NEXT data_array_p: [1 .. new_byte_size] IN data_seq_p;                                                  
      IF data_array_p = NIL THEN                                                                              
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      data_array_p^ := memory_file_array_p^;                                                                  
    IFEND;                                                                                                    
                                                                                                              
    clp$make_string_value (data_p^, work_area_p, result_p);                                                   
                                                                                                              
  PROCEND dup$$memory_string;                                                                                 
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$pp_available', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns a boolean of TRUE if the specified pp is available in the dump.                     
                                                                                                              
  PROCEDURE [XDCL] dup$$pp_available                                                                          
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $pp_available, $ppa (                                                                              
{   pp_number: integer 0..25 = $required                                                                      
{   pp_type: key of                                                                                           
{       (normal n) (concurrent_input_output cio c)                                                            
{     keyend = concurrent_input_output                                                                        
{   iou: integer 0..1 = 0                                                                                     
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 3] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 3] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$keyword_type_qualifier,                                                                
        keyword_specs: array [1 .. 6] of clt$keyword_specification,                                           
        default_value: string (23),                                                                           
      recend,                                                                                                 
      type3: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 6, 14, 10, 36, 47, 99],                                                                              
    clc$function, 3, 3, 1, 0, 0, 0, 0, ''], [                                                                 
    ['IOU                            ',clc$nominal_entry, 3],                                                 
    ['PP_NUMBER                      ',clc$nominal_entry, 1],                                                 
    ['PP_TYPE                        ',clc$nominal_entry, 2]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [2, 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, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 2                                                                                                 
    [3, 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, 229,                        
  clc$optional_default_parameter, 0, 23],                                                                     
{ PARAMETER 3                                                                                                 
    [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, 20,                         
  clc$optional_default_parameter, 0, 1]],                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 25, 10]],                                                                  
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$keyword_type], [6], [                                                                         
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                   
    ['CIO                            ', clc$alias_entry, clc$normal_usage_entry, 3],                          
    ['CONCURRENT_INPUT_OUTPUT        ', clc$nominal_entry, clc$normal_usage_entry, 3],                        
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                   
    ['NORMAL                         ', clc$nominal_entry, clc$normal_usage_entry, 2],                        
    ['OF                             ', clc$nominal_entry, clc$normal_usage_entry, 1]]                        
    ,                                                                                                         
    'concurrent_input_output'],                                                                               
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$integer_type], [0, 1, 10],                                                                    
    '0']];                                                                                                    
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$pp_number = 1,                                                                                        
      p$pp_type = 2,                                                                                          
      p$iou = 3;                                                                                              
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 3] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      default_list: ARRAY [1 .. 2] OF dut$default_change_list_entry,                                          
      iou: 0 .. duc$de_maximum_ious,                                                                          
      pp_exists: boolean,                                                                                     
      pp_number: 0 .. duc$de_max_pp_memories;                                                                 
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the PP_TYPE and IOU parameters.                                            
                                                                                                              
    default_list [1].default_name := duc$dp_pp_type;                                                          
    default_list [1].number := p$pp_type;                                                                     
    default_list [2].default_name := duc$dp_iou;                                                              
    default_list [2].number := p$iou;                                                                         
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    pp_number := pvt [p$pp_number].value^.integer_value.value;                                                
    iou := pvt [p$iou].value^.integer_value.value;                                                            
                                                                                                              
    IF pvt [p$pp_type].value^.keyword_value = 'NORMAL' THEN                                                   
      pp_exists := duv$dump_environment_p^.iou_memory [iou].nio_pp [pp_number].available;                     
    ELSE                                                                                                      
      pp_exists := duv$dump_environment_p^.iou_memory [iou].cio_pp [pp_number].available;                     
    IFEND;                                                                                                    
                                                                                                              
    clp$make_boolean_value (pp_exists, clc$true_false_boolean, work_area_p, result_p);                        
                                                                                                              
  PROCEND dup$$pp_available;                                                                                  
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$pp_memory', EJECT ??                                                                     
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns the contents of the PP memory address specified as an integer.                      
                                                                                                              
  PROCEDURE [XDCL] dup$$pp_memory                                                                             
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $pp_memory, $pm (                                                                                  
{   pp_number: integer 0..25 = $required                                                                      
{   address: integer 0..16383 = $required                                                                     
{   pp_type: key                                                                                              
{       (normal n) (concurrent_input_output cio c)                                                            
{     keyend = concurrent_input_output                                                                        
{   iou: integer 0..1 = 0                                                                                     
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 4] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 4] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type3: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$keyword_type_qualifier,                                                                
        keyword_specs: array [1 .. 5] of clt$keyword_specification,                                           
        default_value: string (23),                                                                           
      recend,                                                                                                 
      type4: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 6, 16, 7, 5, 41, 942],                                                                               
    clc$function, 4, 4, 2, 0, 0, 0, 0, ''], [                                                                 
    ['ADDRESS                        ',clc$nominal_entry, 2],                                                 
    ['IOU                            ',clc$nominal_entry, 4],                                                 
    ['PP_NUMBER                      ',clc$nominal_entry, 1],                                                 
    ['PP_TYPE                        ',clc$nominal_entry, 3]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [3, 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, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 2                                                                                                 
    [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, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 3                                                                                                 
    [4, 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, 192,                        
  clc$optional_default_parameter, 0, 23],                                                                     
{ PARAMETER 4                                                                                                 
    [2, 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, 20,                         
  clc$optional_default_parameter, 0, 1]],                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 25, 10]],                                                                  
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, 16383, 10]],                                                               
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$keyword_type], [5], [                                                                         
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                   
    ['CIO                            ', clc$alias_entry, clc$normal_usage_entry, 2],                          
    ['CONCURRENT_INPUT_OUTPUT        ', clc$nominal_entry, clc$normal_usage_entry, 2],                        
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                   
    ['NORMAL                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]                        
    ,                                                                                                         
    'concurrent_input_output'],                                                                               
{ PARAMETER 4                                                                                                 
    [[1, 0, clc$integer_type], [0, 1, 10],                                                                    
    '0']];                                                                                                    
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$pp_number = 1,                                                                                        
      p$address = 2,                                                                                          
      p$pp_type = 3,                                                                                          
      p$iou = 4;                                                                                              
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 4] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      address: 0 .. 16383,                                                                                    
      cell_p: ^cell,                                                                                          
      default_list: ARRAY [1 .. 2] OF dut$default_change_list_entry,                                          
      dump_information: dut$dump_information,                                                                 
      iou: 0 .. duc$de_maximum_ious,                                                                          
      pp_memory_array_p: ^ARRAY [0 .. *] OF 0 .. 0ffff(16),                                                   
      pp_number: 0 .. duc$de_max_pp_memories,                                                                 
      restart_file_seq_p: ^SEQ ( * );                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the PP_TYPE and IOU parameters.                                            
                                                                                                              
    default_list [1].default_name := duc$dp_pp_type;                                                          
    default_list [1].number := p$pp_type;                                                                     
    default_list [2].default_name := duc$dp_iou;                                                              
    default_list [2].number := p$iou;                                                                         
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    pp_number := pvt [p$pp_number].value^.integer_value.value;                                                
    iou := pvt [p$iou].value^.integer_value.value;                                                            
    dup$determine_dump_information (dump_information);                                                        
                                                                                                              
   /determine_pp_availability/                                                                                
    BEGIN                                                                                                     
      IF pvt [p$pp_type].value^.keyword_value = 'NORMAL' THEN                                                 
        IF duv$dump_environment_p^.iou_memory [iou].nio_pp [pp_number].available THEN                         
          EXIT /determine_pp_availability/;  {---->                                                           
        IFEND;                                                                                                
      ELSEIF (pp_number <= duc$de_max_cio_pp_memories) AND                                                    
            duv$dump_environment_p^.iou_memory [iou].cio_pp [pp_number].available THEN                        
        EXIT /determine_pp_availability/;  {---->                                                             
      IFEND;                                                                                                  
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                    
            'The peripheral processor', status);                                                              
      osp$append_status_integer (osc$status_parameter_delimiter, pp_number, 8, TRUE, status);                 
      osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);                             
      RETURN;  {---->                                                                                         
    END /determine_pp_availability/;                                                                          
                                                                                                              
    address := pvt [p$address].value^.integer_value.value;                                                    
    IF address > dump_information.iou [iou].pp_word_size THEN                                                 
      osp$set_status_abnormal (duc$dump_analyzer_id, due$invalid_address, '', status);                        
      osp$append_status_integer (osc$status_parameter_delimiter, address, 16, TRUE, status);                  
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;            
    IF pvt [p$pp_type].value^.keyword_value = 'NORMAL' THEN                                                   
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),                          
            duv$dump_environment_p^.iou_memory [iou].nio_pp [pp_number].first_byte);                          
    ELSE                                                                                                      
      cell_p := #ADDRESS (#RING (restart_file_seq_p), #SEGMENT (restart_file_seq_p),                          
            duv$dump_environment_p^.iou_memory [iou].cio_pp [pp_number].first_byte);                          
    IFEND;                                                                                                    
    RESET restart_file_seq_p TO cell_p;                                                                       
                                                                                                              
    NEXT pp_memory_array_p: [0 .. address] IN restart_file_seq_p;                                             
    IF pp_memory_array_p = NIL THEN                                                                           
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF pvt [p$address].value^.integer_value.radix_specified THEN                                              
      clp$make_integer_value (pp_memory_array_p^ [address], pvt [p$address].value^.integer_value.radix, TRUE, 
            work_area_p, result_p);                                                                           
    ELSE                                                                                                      
      clp$make_integer_value (pp_memory_array_p^ [address], 16, TRUE, work_area_p, result_p);                 
    IFEND;                                                                                                    
                                                                                                              
  PROCEND dup$$pp_memory;                                                                                     
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$process_register', EJECT ??                                                              
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure returns the contents of the specified register as an integer.                              
                                                                                                              
  PROCEDURE [XDCL] dup$$process_register                                                                      
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $process_register, $pr (                                                                           
{   register: key                                                                                             
{       (p) (a) (x) (monitor_condition_register mcr) (user_condition_register ucr) (segment_table_address sta)
{       (top_of_stack tos) (base_constant bc)                                                                 
{     keyend = $required                                                                                      
{   register_number: integer 0..15 = 0                                                                        
{   exchange: any of                                                                                          
{       key                                                                                                   
{         (active a) (monitor m) (job j)                                                                      
{       keyend                                                                                                
{       integer 0..0ffffffff(16)                                                                              
{     anyend = 0ffffffff(16)                                                                                  
{   processor: integer 0..3 = 0                                                                               
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 4] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 4] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$keyword_type_qualifier,                                                                
        keyword_specs: array [1 .. 13] of clt$keyword_specification,                                          
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type3: 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 .. 6] of clt$keyword_specification,                                         
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$integer_type_qualifier,                                                              
        recend,                                                                                               
        default_value: string (13),                                                                           
      recend,                                                                                                 
      type4: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 7, 12, 14, 6, 15, 261],                                                                              
    clc$function, 4, 4, 1, 0, 0, 0, 0, ''], [                                                                 
    ['EXCHANGE                       ',clc$nominal_entry, 3],                                                 
    ['PROCESSOR                      ',clc$nominal_entry, 4],                                                 
    ['REGISTER                       ',clc$nominal_entry, 1],                                                 
    ['REGISTER_NUMBER                ',clc$nominal_entry, 2]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [3, 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, 488,                        
  clc$required_parameter, 0, 0],                                                                              
{ PARAMETER 2                                                                                                 
    [4, 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, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 3                                                                                                 
    [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, 269,                        
  clc$optional_default_parameter, 0, 13],                                                                     
{ PARAMETER 4                                                                                                 
    [2, 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, 20,                         
  clc$optional_default_parameter, 0, 1]],                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$keyword_type], [13], [                                                                        
    ['A                              ', clc$nominal_entry, clc$normal_usage_entry, 2],                        
    ['BASE_CONSTANT                  ', clc$nominal_entry, clc$normal_usage_entry, 8],                        
    ['BC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],                   
    ['MCR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],                   
    ['MONITOR_CONDITION_REGISTER     ', clc$nominal_entry, clc$normal_usage_entry, 4],                        
    ['P                              ', clc$nominal_entry, clc$normal_usage_entry, 1],                        
    ['SEGMENT_TABLE_ADDRESS          ', clc$nominal_entry, clc$normal_usage_entry, 6],                        
    ['STA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],                   
    ['TOP_OF_STACK                   ', clc$nominal_entry, clc$normal_usage_entry, 7],                        
    ['TOS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7],                   
    ['UCR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],                   
    ['USER_CONDITION_REGISTER        ', clc$nominal_entry, clc$normal_usage_entry, 5],                        
    ['X                              ', clc$nominal_entry, clc$normal_usage_entry, 3]]                        
    ],                                                                                                        
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, 15, 10],                                                                   
    '0'],                                                                                                     
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],                                           
    FALSE, 2],                                                                                                
    229, [[1, 0, clc$keyword_type], [6], [                                                                    
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                 
      ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],                      
      ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                 
      ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 3],                      
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                 
      ['MONITOR                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]                      
      ],                                                                                                      
    20, [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]]                                                    
    ,                                                                                                         
    '0ffffffff(16)'],                                                                                         
{ PARAMETER 4                                                                                                 
    [[1, 0, clc$integer_type], [0, 3, 10],                                                                    
    '0']];                                                                                                    
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$register = 1,                                                                                         
      p$register_number = 2,                                                                                  
      p$exchange = 3,                                                                                         
      p$processor = 4;                                                                                        
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 4] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      address: dut$ee_address_parameter,                                                                      
      cell_p: ^cell,                                                                                          
      default_list: ARRAY [1 .. 2] OF dut$default_change_list_entry,                                          
      exchange_package_p: ^dut$exchange_package,                                                              
      processor: 0 .. duc$de_maximum_processors,                                                              
      register_number: 0 .. 15,                                                                               
      xp_p: ^dut$ee_xp;                                                                                       
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the EXCHANGE and PROCESSOR parameters.                                     
                                                                                                              
    default_list [1].default_name := duc$dp_exchange;                                                         
    default_list [1].number := p$exchange;                                                                    
    default_list [2].default_name := duc$dp_processor;                                                        
    default_list [2].number := p$processor;                                                                   
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    processor := pvt [p$processor].value^.integer_value.value;                                                
    register_number := pvt [p$register_number].value^.integer_value.value;                                    
                                                                                                              
    dup$retrieve_exchange_package (processor, pvt [p$exchange].value^, exchange_package_p, status);           
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    cell_p := exchange_package_p;                                                                             
    xp_p := cell_p;                                                                                           
                                                                                                              
    address.rma_part := 0;                                                                                    
    IF pvt [p$register].value^.keyword_value = 'P' THEN                                                       
      address.pva_part := xp_p^.p_register.pva;                                                               
    ELSEIF pvt [p$register].value^.keyword_value = 'A' THEN                                                   
      address.pva_part := xp_p^.data.a_regs [register_number].pva;                                            
    ELSEIF pvt [p$register].value^.keyword_value = 'X' THEN                                                   
      address.rma_part := xp_p^.data.x_regs [register_number].int;                                            
    ELSEIF pvt [p$register].value^.keyword_value = 'MONITOR_CONDITION_REGISTER' THEN                          
      address.quarter_part_4 := xp_p^.data.a_regs [5].two_bytes;                                              
    ELSEIF pvt [p$register].value^.keyword_value = 'USER_CONDITION_REGISTER' THEN                             
      address.quarter_part_4 := xp_p^.data.a_regs [4].two_bytes;                                              
    ELSEIF pvt [p$register].value^.keyword_value = 'SEGMENT_TABLE_ADDRESS' THEN                               
      address.quarter_part_3 := xp_p^.data.sta1.two_bytes;                                                    
      address.quarter_part_4 := xp_p^.data.sta2.two_bytes;                                                    
    ELSEIF pvt [p$register].value^.keyword_value = 'TOP_OF_STACK' THEN                                        
      address.pva_part := xp_p^.tos_registers [register_number].pva;                                          
    ELSE  { pvt [p$register].value^.keyword_value = 'BASE_CONSTANT' }                                         
      address.quarter_part_3 := xp_p^.data.a_regs [0c(16)].two_bytes;                                         
      address.quarter_part_4 := xp_p^.data.a_regs [0d(16)].two_bytes;                                         
    IFEND;                                                                                                    
                                                                                                              
    clp$make_integer_value (address.rma_part, 16, TRUE, work_area_p, result_p);                               
                                                                                                              
  PROCEND dup$$process_register;                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$real_memory_address', EJECT ??                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure returns the RMA of the specified address as an integer.                                    
                                                                                                              
  PROCEDURE [XDCL] dup$$real_memory_address                                                                   
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $real_memory_address, $rma (                                                                       
{   address: integer 0..0ffffffffffff(16) = $required                                                         
{   exchange: any of                                                                                          
{       key                                                                                                   
{         (active a) (monitor m) (job j)                                                                      
{       keyend                                                                                                
{       integer 0..0ffffffff(16)                                                                              
{     anyend = 0ffffffff(16)                                                                                  
{   processor: integer 0..3 = 0                                                                               
{   address_mode: key                                                                                         
{       (process_virtual_address pva) (system_virtual_address sva) (real_memory_address rma)                  
{     keyend = process_virtual_address                                                                        
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 4] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 4] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type2: 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 .. 6] of clt$keyword_specification,                                         
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$integer_type_qualifier,                                                              
        recend,                                                                                               
        default_value: string (13),                                                                           
      recend,                                                                                                 
      type3: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type4: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$keyword_type_qualifier,                                                                
        keyword_specs: array [1 .. 6] of clt$keyword_specification,                                           
        default_value: string (23),                                                                           
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 6, 14, 10, 38, 44, 440],                                                                             
    clc$function, 4, 4, 1, 0, 0, 0, 0, ''], [                                                                 
    ['ADDRESS                        ',clc$nominal_entry, 1],                                                 
    ['ADDRESS_MODE                   ',clc$nominal_entry, 4],                                                 
    ['EXCHANGE                       ',clc$nominal_entry, 2],                                                 
    ['PROCESSOR                      ',clc$nominal_entry, 3]],                                                
    [                                                                                                         
{ 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, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 2                                                                                                 
    [3, 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, 269,                        
  clc$optional_default_parameter, 0, 13],                                                                     
{ PARAMETER 3                                                                                                 
    [4, 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, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 4                                                                                                 
    [2, 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, 229,                        
  clc$optional_default_parameter, 0, 23]],                                                                    
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 0ffffffffffff(16), 10]],                                                   
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],                                           
    FALSE, 2],                                                                                                
    229, [[1, 0, clc$keyword_type], [6], [                                                                    
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                 
      ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],                      
      ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                 
      ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 3],                      
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                 
      ['MONITOR                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]                      
      ],                                                                                                      
    20, [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]]                                                    
    ,                                                                                                         
    '0ffffffff(16)'],                                                                                         
{ PARAMETER 3                                                                                                 
    [[1, 0, clc$integer_type], [0, 3, 10],                                                                    
    '0'],                                                                                                     
{ PARAMETER 4                                                                                                 
    [[1, 0, clc$keyword_type], [6], [                                                                         
    ['PROCESS_VIRTUAL_ADDRESS        ', clc$nominal_entry, clc$normal_usage_entry, 1],                        
    ['PVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],                   
    ['REAL_MEMORY_ADDRESS            ', clc$nominal_entry, clc$normal_usage_entry, 3],                        
    ['RMA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],                   
    ['SVA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],                   
    ['SYSTEM_VIRTUAL_ADDRESS         ', clc$nominal_entry, clc$normal_usage_entry, 2]]                        
    ,                                                                                                         
    'process_virtual_address']];                                                                              
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$address = 1,                                                                                          
      p$exchange = 2,                                                                                         
      p$processor = 3,                                                                                        
      p$address_mode = 4;                                                                                     
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 4] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      access_data: dut$access_data,                                                                           
      address: dut$ee_address_parameter,                                                                      
      bytes_left: 0 .. 10000(16),                                                                             
      default_list: ARRAY [1 .. 3] OF dut$default_change_list_entry,                                          
      exchange_package_p: ^dut$exchange_package,                                                              
      memory_p: ^cell,                                                                                        
      new_byte_size: ost$segment_length,                                                                      
      processor: 0 .. duc$de_maximum_processors,                                                              
      rma: ost$real_memory_address;                                                                           
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the EXCHANGE, PROCESSOR and ADDRESS_MODE parameters.                       
                                                                                                              
    default_list [1].default_name := duc$dp_exchange;                                                         
    default_list [1].number := p$exchange;                                                                    
    default_list [2].default_name := duc$dp_processor;                                                        
    default_list [2].number := p$processor;                                                                   
    default_list [3].default_name := duc$dp_address_mode;                                                     
    default_list [3].number := p$address_mode;                                                                
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    address.rma_part := pvt [p$address].value^.integer_value.value;                                           
    processor := pvt [p$processor].value^.integer_value.value;                                                
                                                                                                              
    IF pvt [p$address_mode].value^.keyword_value = 'PROCESS_VIRTUAL_ADDRESS' THEN                             
      dup$retrieve_exchange_package (processor, pvt [p$exchange].value^, exchange_package_p, status);         
      IF NOT status.normal THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      dup$translate_pva (address.pva_part, exchange_package_p^, processor, rma, bytes_left, access_data,      
            status);                                                                                          
      IF NOT status.normal THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      IF access_data.page_fault AND NOT access_data.memory_found THEN                                         
        osp$set_status_abnormal (duc$dump_analyzer_id, due$page_fault_error_severity, '', status);            
        osp$append_status_parameter (osc$status_parameter_delimiter, ', segment = ', status);                 
        osp$append_status_integer (osc$status_parameter_delimiter, address.pva_part.seg, 16, TRUE, status);   
        osp$append_status_parameter (osc$status_parameter_delimiter, ', offset = ', status);                  
        osp$append_status_integer (osc$status_parameter_delimiter, access_data.page_fault_offset, 16, TRUE,   
              status);                                                                                        
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
    ELSEIF pvt [p$address_mode].value^.keyword_value = 'SYSTEM_VIRTUAL_ADDRESS' THEN                          
      dup$translate_sva (address.sva_part, processor, rma, bytes_left, access_data, status);                  
      IF NOT status.normal THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      IF access_data.page_fault AND NOT access_data.memory_found THEN                                         
        osp$set_status_abnormal (duc$dump_analyzer_id, due$page_fault_error_severity, '', status);            
        osp$append_status_parameter (osc$status_parameter_delimiter, ', asid = ', status);                    
        osp$append_status_integer (osc$status_parameter_delimiter, address.sva_part.asid.value, 16, TRUE,     
              status);                                                                                        
        osp$append_status_parameter (osc$status_parameter_delimiter, ', offset = ', status);                  
        osp$append_status_integer (osc$status_parameter_delimiter, access_data.page_fault_offset, 16, TRUE,   
              status);                                                                                        
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
    ELSE  { pvt [p$address_mode].value^.keyword_value = 'REAL_MEMORY_ADDRESS'                                 
      dup$access_real_memory (1, address.rma_part, memory_p, new_byte_size, status);                          
      IF NOT status.normal AND (status.condition <> due$memory_partially_avail) THEN                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      rma := address.rma_part;                                                                                
    IFEND;                                                                                                    
                                                                                                              
    clp$make_integer_value (rma, 16, TRUE, work_area_p, result_p);                                            
                                                                                                              
  PROCEND dup$$real_memory_address;                                                                           
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$register_file', EJECT ??                                                                 
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns the value of a specified register file entry as an integer.                         
                                                                                                              
  PROCEDURE [XDCL] dup$$register_file                                                                         
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $register_file, $rf (                                                                              
{   register_number: integer 0..4095 = $required                                                              
{   processor: integer 0..3 = 0                                                                               
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 2] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 2] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 6, 12, 11, 55, 40, 666],                                                                             
    clc$function, 2, 2, 1, 0, 0, 0, 0, ''], [                                                                 
    ['PROCESSOR                      ',clc$nominal_entry, 2],                                                 
    ['REGISTER_NUMBER                ',clc$nominal_entry, 1]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [2, 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, 20, clc$required_parameter, 0, 0],                                         
{ PARAMETER 2                                                                                                 
    [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, 20, clc$optional_default_parameter, 0, 1]],                                
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 4095, 10]],                                                                
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, 3, 10],                                                                    
    '0']];                                                                                                    
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$register_number = 1,                                                                                  
      p$processor = 2;                                                                                        
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 2] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      default_list: ARRAY [1 .. 1] OF dut$default_change_list_entry,                                          
      display_string: string (osc$max_string_size),                                                           
      processor: 0 .. duc$de_maximum_processors,                                                              
      register_number: 0 .. duc$de_max_register_number,                                                       
      register: integer,                                                                                      
      string_length: integer;                                                                                 
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the PROCESSOR parameter.                                                   
                                                                                                              
    default_list [1].default_name := duc$dp_processor;                                                        
    default_list [1].number := p$processor;                                                                   
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    processor := pvt [p$processor].value^.integer_value.value;                                                
    register_number := pvt [p$register_number].value^.integer_value.value;                                    
                                                                                                              
    IF NOT duv$dump_environment_p^.register_file [processor].available THEN                                   
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                    
            'The register file for processor', status);                                                       
      osp$append_status_integer (osc$status_parameter_delimiter, processor, 10, FALSE, status);               
      osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);                             
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p^.register_file [processor].register [register_number].available THEN            
      register := duv$dump_environment_p^.register_file [processor].register [register_number].value;         
      clp$make_integer_value (register, 16, TRUE, work_area_p, result_p);                                     
    ELSE                                                                                                      
      STRINGREP (display_string, string_length, 'Register file entry', register_number: #(16), '(16) is');    
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, display_string (1, string_length), 
            status);                                                                                          
    IFEND;                                                                                                    
                                                                                                              
  PROCEND dup$$register_file;                                                                                 
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$register_file_string', EJECT ??                                                          
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns the value of a specified register file entry as a string.                           
                                                                                                              
  PROCEDURE [XDCL] dup$$register_file_string                                                                  
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $register_file_string, $rfs (                                                                      
{   register_number: integer 0..4095 = $required                                                              
{   processor: integer 0..3 = 0                                                                               
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 2] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 2] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 6, 12, 11, 49, 7, 783],                                                                              
    clc$function, 2, 2, 1, 0, 0, 0, 0, ''], [                                                                 
    ['PROCESSOR                      ',clc$nominal_entry, 2],                                                 
    ['REGISTER_NUMBER                ',clc$nominal_entry, 1]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [2, 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, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 2                                                                                                 
    [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, 20,                         
  clc$optional_default_parameter, 0, 1]],                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 4095, 10]],                                                                
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, 3, 10],                                                                    
    '0']];                                                                                                    
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$register_number = 1,                                                                                  
      p$processor = 2;                                                                                        
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 2] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      default_list: ARRAY [1 .. 1] OF dut$default_change_list_entry,                                          
      display_string: string (osc$max_string_size),                                                           
      processor: 0 .. duc$de_maximum_processors,                                                              
      register_number: 0 .. duc$de_max_register_number,                                                       
      register: integer,                                                                                      
      string_16: string (16),                                                                                 
      string_length: integer;                                                                                 
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the PROCESSOR parameter.                                                   
                                                                                                              
    default_list [1].default_name := duc$dp_processor;                                                        
    default_list [1].number := p$processor;                                                                   
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    processor := pvt [p$processor].value^.integer_value.value;                                                
    register_number := pvt [p$register_number].value^.integer_value.value;                                    
                                                                                                              
    IF NOT duv$dump_environment_p^.register_file [processor].available THEN                                   
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                    
            'The register file for processor', status);                                                       
      osp$append_status_integer (osc$status_parameter_delimiter, processor, 10, FALSE, status);               
      osp$append_status_parameter (osc$status_parameter_delimiter, 'is', status);                             
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p^.register_file [processor].register [register_number].available THEN            
      register := duv$dump_environment_p^.register_file [processor].register [register_number].value;         
      convert_integer_to_hex_string (register, 16, string_16);                                                
      clp$make_string_value (string_16, work_area_p, result_p);                                               
    ELSE                                                                                                      
      STRINGREP (display_string, string_length, 'Register file entry', register_number: #(16), '(16) is');    
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, display_string (1, string_length), 
            status);                                                                                          
    IFEND;                                                                                                    
                                                                                                              
  PROCEND dup$$register_file_string;                                                                          
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$size_buffer_controlware', EJECT ??                                                       
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns the size of a channel's buffer controlware as an integer.                           
                                                                                                              
  PROCEDURE [XDCL] dup$$size_buffer_controlware                                                               
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $size_buffer_controlware, $sbc (                                                                   
{   channel_number: integer 0..33 = $required                                                                 
{   )                                                                                                         
                                                                                                              
?? 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$integer_type_qualifier,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 6, 8, 14, 50, 19, 248],                                                                              
    clc$function, 1, 1, 1, 0, 0, 0, 0, ''], [                                                                 
    ['CHANNEL_NUMBER                 ',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, 20, clc$required_parameter, 
  0, 0]],                                                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 33, 10]]];                                                                 
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$channel_number = 1;                                                                                   
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 1] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      buffer_controlware_size: integer,                                                                       
      channel_number: 0 .. duc$de_maximum_channels,                                                           
      entry_p: ^dut$de_buffer_controlware_entry;                                                              
                                                                                                              
    status.normal := TRUE;                                                                                    
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    channel_number := pvt [p$channel_number].value^.integer_value.value;                                      
    dup$retrieve_bc_entry (channel_number, entry_p);                                                          
    IF entry_p <> NIL THEN                                                                                    
      buffer_controlware_size := entry_p^.words - 1;                                                          
    ELSE                                                                                                      
      buffer_controlware_size := 0;                                                                           
    IFEND;                                                                                                    
                                                                                                              
    clp$make_integer_value (buffer_controlware_size, 16, TRUE, work_area_p, result_p);                        
                                                                                                              
  PROCEND dup$$size_buffer_controlware;                                                                       
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$size_control_store', EJECT ??                                                            
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns the size of control store as an integer.                                            
                                                                                                              
  PROCEDURE [XDCL] dup$$size_control_store                                                                    
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $size_control_store, $scs (                                                                        
{   processor: integer 0..3 = 0                                                                               
{   shadow: boolean = FALSE                                                                                   
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 2] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 2] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        default_value: string (5),                                                                            
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [90, 9, 19, 8, 18, 1, 389],                                                                               
    clc$function, 2, 2, 0, 0, 0, 0, 0, ''], [                                                                 
    ['PROCESSOR                      ',clc$nominal_entry, 1],                                                 
    ['SHADOW                         ',clc$nominal_entry, 2]],                                                
    [                                                                                                         
{ 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, 20,                         
  clc$optional_default_parameter, 0, 1],                                                                      
{ PARAMETER 2                                                                                                 
    [2, 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, 3,                          
  clc$optional_default_parameter, 0, 5]],                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 3, 10],                                                                    
    '0'],                                                                                                     
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$boolean_type],                                                                                
    'FALSE']];                                                                                                
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$processor = 1,                                                                                        
      p$shadow = 2;                                                                                           
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 2] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      control_store_entry: dut$de_control_store_entry,                                                        
      control_store_size: 0 .. duc$de_control_store_size,                                                     
      default_list: ARRAY [1 .. 1] OF dut$default_change_list_entry,                                          
      processor: 0 .. duc$de_maximum_processors;                                                              
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the PROCESSOR parameter.                                                   
                                                                                                              
    default_list [1].default_name := duc$dp_processor;                                                        
    default_list [1].number := p$processor;                                                                   
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    processor := pvt [p$processor].value^.integer_value.value;                                                
    IF pvt [p$shadow].value^.boolean_value.value THEN                                                         
      control_store_entry := duv$dump_environment_p^.control_store.shadow [processor];                        
    ELSE                                                                                                      
      control_store_entry := duv$dump_environment_p^.control_store.main [processor];                          
    IFEND;                                                                                                    
    IF control_store_entry.available THEN                                                                     
      control_store_size := control_store_entry.size - 1;                                                     
    ELSE                                                                                                      
      control_store_size := 0;                                                                                
    IFEND;                                                                                                    
                                                                                                              
    clp$make_integer_value (control_store_size, 16, TRUE, work_area_p, result_p);                             
                                                                                                              
  PROCEND dup$$size_control_store;                                                                            
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$$size_register_file', EJECT ??                                                            
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function returns the size of the register file as an integer.                                        
                                                                                                              
  PROCEDURE [XDCL] dup$$size_register_file                                                                    
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area_p: ^clt$work_area;                                                                         
     VAR result_p: ^clt$data_value;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $size_register_file, $srf (                                                                        
{   processor: integer 0..3 = 0                                                                               
{   )                                                                                                         
                                                                                                              
?? 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$integer_type_qualifier,                                                                
        default_value: string (1),                                                                            
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 6, 12, 11, 36, 26, 18],                                                                              
    clc$function, 1, 1, 0, 0, 0, 0, 0, ''], [                                                                 
    ['PROCESSOR                      ',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, 20,                         
  clc$optional_default_parameter, 0, 1]],                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 3, 10],                                                                    
    '0']];                                                                                                    
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$processor = 1;                                                                                        
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 1] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      default_list: ARRAY [1 .. 1] OF dut$default_change_list_entry,                                          
      processor: 0 .. duc$de_maximum_processors,                                                              
      register_file_size: 0 .. duc$de_max_register_number;                                                    
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Change the default value for the PROCESSOR parameter.                                                   
                                                                                                              
    default_list [1].default_name := duc$dp_processor;                                                        
    default_list [1].number := p$processor;                                                                   
    dup$evaluate_parameters (parameter_list, default_list, #SEQ (pdt), ^pvt, status);                         
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    IF duv$dump_environment_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);                        
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    processor := pvt [p$processor].value^.integer_value.value;                                                
                                                                                                              
    IF duv$dump_environment_p^.register_file [processor].available THEN                                       
      register_file_size := duv$dump_environment_p^.register_file [processor].number_of_registers - 1;        
    ELSE                                                                                                      
      register_file_size := 0;                                                                                
    IFEND;                                                                                                    
                                                                                                              
    clp$make_integer_value (register_file_size, 16, TRUE, work_area_p, result_p);                             
                                                                                                              
  PROCEND dup$$size_register_file;                                                                            
MODEND dum$dump_analyzer_functions;                                                                           
*DECK DECK=DUM$DUMP_COMMAND_LIST EXPAND=TRUE
PROCEDURE dum$dump_command_list, dump_command_list, dumcl (
  output, o: file = $output
  status)

" This procedure displays the command list of the current job.
" This needs rjt's dump analyzer

  current = $default_module()
  crev ignore status
  chadm clm$command_list_manager
  path = ' '
  dispv clv$command_list o=output.$eoi
  dispv clv$command_list.contents^ o=output.$eoi
  lfn = $pv(clv$command_list.contents^.system_command_library_lfn)
  IF lfn <> ' ' THEN
    path_offset_string = $substring(lfn, 7, 8)
    path_offset = $integer(path_offset_string, 16)
    get_path path_offset path
    disv path o=output.$eoi
  IFEND
  entry = $pv(clv$command_list.contents^.entries.first_entry)
  WHILE NOT $nil_pva(entry) DO
    dispv ?entry.clt$command_list_entry o=output.$eoi
    IF ($pv(?entry.clt$command_list_entry.kind) = CLC$CATALOG_COMMANDS) OR..
           ($pv(?entry.clt$command_list_entry.kind) = CLC$LIBRARY_COMMANDS..
          ) THEN
      lfn = $pv(?entry.clt$command_list_entry.local_file_name)
      path_offset_string = $substring(lfn, 7, 8)
      path_offset = $integer(path_offset_string, 16)
      get_path path_offset path
      disv path o=output.$eoi
    IFEND
    entry = $pv(?entry.clt$command_list_entry.next_entry)
  WHILEND
  chadm current

PROCEND dum$dump_command_list

*DECK DECK=DUM$DUMP_PAGE_FRAME_TABLE EXPAND=TRUE

PROC dum$dump_page_frame_table, dump_page_frame_table, dumpft (output, o: file = pft)
 crev s status
 pft = $mem($sa(mmv$pft_p) 6)
 pftel = $mem($sa(mmv$pft_p)+14 4)
 pftl  = $mem($sa(mmv$pft_p)+6 4)/pftel
 detf pft status=s
 setfa $value(output) pf=c op=$eoi
 dism pft pftel o=$value(output) do=(numeric) rc=pftl+1
 setfa $value(output) op=$boi
 edif $value(output) o=$null
   d 'segment' a
   end
 PROCEND dum$dump_page_frame_table
*DECK DECK=DUM$FETCH_FIELD_INFO EXPAND=TRUE
PROCEDURE dum$fetch_field_info fetch_field_info (
  type_name, type, t: name = $required
  field_name, field, f: name = $required
  offset, o: (VAR) integer = $required
  length, l: (VAR) integer = $required
  )

  VAR
    temp_length: integer
    temp_offset: integer
  VAREND

  temp_string = $string(type_name) // ' field=' // $string(field_name) // ..
        ' offset=temp_offset length=temp_length'
  include_line sl=temp_string
  offset = temp_offset
  length = temp_length

PROCEND dum$fetch_field_info
*DECK DECK=DUM$FETCH_MEMORY EXPAND=TRUE
PROC dum$FETCH_MEMORY fetch_memory (
  address    : integer -281474976710655..281474976710655 = $required
  type_name  : name = $required
  field_name : name = $required
  rtv        : var of integer = $required
  )

  crev (o l)
  s = $string($value(type_name)) // ' field=' // $string($value(field_name)) // ' o l'
  include_line s
  IF l = 0 THEN
    EXIT_PROC
  IFEND
  $value(rtv) = $mem($value(address)+o/8, l/8)

PROCEND dum$fetch_memory
*DECK DECK=DUM$FIND_KJL_INDEX_BY_SJN EXPAND=TRUE

PROC dum$find_kjl_index_by_sjn, find_kjl_index_by_sjn (
  system_job_name, sjn: name 19 = $REQUIRED
  kjl_index : VAR OF INTEGER = $required
  status)

  create_variable name=sjn_offset k=integer
  kjl_address = $mem($sa(jmv$kjl_p) 6)
  kjl_size = $mem(($sa(jmv$kjl_p)+6) 4)
  kjl_entry_size = $mem(($sa(jmv$kjl_p)+14) 4)
  number_of_kjl_entries = kjl_size / kjl_entry_size
  target_system_job_name = $strrep($value(system_job_name))

  FOR search_index = 1 TO number_of_kjl_entries DO
    kjl_entry_address = kjl_address + (search_index-1)*kjl_entry_size
    IF $memory_string(kjl_entry_address,19) = target_system_job_name THEN
      $value(kjl_index) = search_index
      EXIT_PROC
    IFEND
  FOREND
  EXIT_PROC WITH $STATUS(FALSE, 'DU', 0, 'Entry not found.')

PROCEND dum$find_kjl_index_by_sjn

*DECK DECK=DUM$FIND_KOL_INDEX_BY_SFN EXPAND=TRUE

PROC dum$find_kol_index_by_sfn, find_kol_index_by_sfn (
  system_job_name, sfn: name 19 = $REQUIRED
  kol_index : VAR OF INTEGER = $required
  status)

  create_variable name=sfn_offset k=integer
  kol_address = $mem($sa(jmv$kol_p) 6)
  kol_size = $mem(($sa(jmv$kol_p)+6) 4)
  kol_entry_size = $mem(($sa(jmv$kol_p)+14) 4)
  number_of_kol_entries = kol_size / kol_entry_size
  target_system_job_name = $strrep($value(system_job_name))

  FOR search_index = 1 TO number_of_kol_entries DO
    kol_entry_address = kol_address + (search_index-1)*kol_entry_size
    IF $memory_string(kol_entry_address,19) = target_system_job_name THEN
      $value(kol_index) = search_index
      EXIT_PROC
    IFEND
  FOREND
  EXIT_PROC WITH $STATUS(FALSE, 'DU', 0, 'Entry not found.')

PROCEND dum$find_kol_index_by_sfn

*DECK DECK=DUM$FORMAT_MICROSECOND_CLOCK EXPAND=TRUE
PROC dum$format_microsecond_clock, format_microsecond_clock, formc (
 microsecond_clock,mc: integer = $required
 formatted_clock: var of string = $required
 status)

  bst = $sa(osv$base_system_time)
  bst_second = $mem(bst, 1)
  bst_minute = $mem(bst+1, 1)
  bst_hour = $mem(bst+2, 1)
  bst_day = $mem(bst+3, 1)
  bst_month = $mem(bst+4, 1)
  bst_year = $mem(bst+5, 2)
  disv bst

"pmp$get_compact_date_time

 " Complete failure time
    disv $value(microsecond_clock)
    elapsed_time "ms" = ($value(microsecond_clock))/1000

    millisecond = $MOD(elapsed_time "ms" , 1000)

    elapsed_time "sec" = elapsed_time "ms" / 1000 "ms/sec"

    second = bst_second + $MOD(elapsed_time "sec" , 60 "sec" )
    IF second >= 60 "sec" THEN
      second = second - 60 "sec"
      minute = 1 "min"
    ELSE
      minute = 0 "min"
    IFEND

    elapsed_time "min" = elapsed_time "sec" / 60 "sec/min"

    minute = minute + bst_minute + $MOD(elapsed_time "min" , 60 "min" )
    IF minute >= 60 "min" THEN
      minute = minute - 60 "min"
      hour = 1 "hr"
    ELSE
      hour = 0 "hr"
    IFEND

    elapsed_time "hr" = elapsed_time "min" / 60 "min/hr"

    hour = hour + bst_hour + $MOD(elapsed_time "hr" , 24 "hr" )
    IF hour >= 24 "hr" THEN
      hour = hour - 24 "hr"
      day = 1 "day"
    ELSE
      day = 0 "day"
    IFEND;

    create_variable days_in_the_month k=integer d=1..12
    days_in_the_month(1) = 31
    days_in_the_month(3) = 31
    days_in_the_month(4) = 30
    days_in_the_month(5) = 31
    days_in_the_month(6) = 30
    days_in_the_month(7) = 31
    days_in_the_month(8) = 31
    days_in_the_month(9) = 30
    days_in_the_month(10) = 31
    days_in_the_month(11) = 30
    days_in_the_month(12) = 31

    year = bst_year

    b1 = ($MOD(year, 4) = 0)
    b2 = ($MOD(year, 100) <> 0)
    b3 = ($MOD(year, 400) = 0)

    this_is_a_leap_year = (b1 AND b2) OR b3
    IF this_is_a_leap_year THEN
      days_in_the_month(2) = 29
    ELSE
      days_in_the_month(2) = 28
    IFEND

    elapsed_time "day" = elapsed_time "hr" / 24 "hr/day"

    day = day + bst_day + elapsed_time "day"
    month = bst_month

    WHILE day > days_in_the_month(month) DO
      day = day - days_in_the_month(month)
      month = month + 1 "mo"

      IF month > 12 "mo" THEN

        month = 1 "mo"
        year = year + 1 "yr"

        b1 = ($MOD(year, 4) = 0)
        b2 = ($MOD(year, 100) <> 0)
        b3 = ($MOD(year, 400) = 0)

        this_is_a_leap_year = (b1 AND b2) OR b3
        IF this_is_a_leap_year THEN
          days_in_the_month(2) = 29
        ELSE
          days_in_the_month(2) = 28
        IFEND

      IFEND;
    WHILEND;

  ms = $strrep(millisecond, 10)
  ms = $substr('00'//ms, $strlen(ms), 3)
  h = $strrep(hour, 10)
  h = $substr('0'//h, $strlen(h), 2)
  m = $strrep(minute, 10)
  m = $substr('0'//m, $strlen(m), 2)
  se = $strrep(second, 10)
  se = $substr('0'//se, $strlen(se), 2)
  y = $strrep(year, 10)
  mo = $strrep(month, 10)
  mo = $substr('0'//mo, $strlen(mo), 2)
  d = $strrep(day, 10)
  d = $substr('0'//d, $strlen(d), 2)

  $value(formatted_clock)  = h//':'//m//':'//se//'.'//ms//..
', '//y//'.'//mo//'.'//d

 PROCEND
*DECK DECK=DUM$GENERATE_HEAP_MAP EXPAND=TRUE
PROC dum$generate_heap_map, generate_heap_map, genhm (
  input, i: FILE = $OPTIONAL
  output, o: FILE = $OPTIONAL
  help: BOOLEAN = FALSE
  status)

  IF $value(help) THEN
    putl '0  GENERATE_HEAP_MAP  (GENHM)' o=$output
    putl '     input, i: FILE = $OPTIONAL' o=$output
    putl '     output, o: FILE = $OPTIONAL' o=$output
    putl '     help: BOOLEAN = FALSE' o=$output
    putl '     status)' o=$output
    putl '0    This procedure looks at an input file generated in a dump and prints out' o=$output
    putl '     the configuration of the heap: offset, length of the block, and whether' o=$output
    putl '     it is allocated or free.  It requires the use of a LEGIBLE, CONTINUOUS' o=$output
    putl '     file (SETFA <file_name> FC=LEGIBLE PF=CONTINUOUS); otherwise the offsets' o=$output
    putl '     will be screwed up by the page headers.' o=$output
    putl '0    The input and output files MUST be specified despite what the header says.' o=$output
    putl ' ' o=$output
    EXIT_PROC
  IFEND

  IF (NOT $specified(input)) OR (NOT $specified(output)) THEN
    disv '-- ERROR -- The parameters INPUT and OUTPUT must be specified despite what the procedure header says.' o=$output
    EXIT_PROC
  IFEND

  crev ignore_status k=status
  IF $file($value(input), file_contents) <> 'LEGIBLE' THEN
    disv 'ERROR -- The input file: '//$string($value(input))//' is not a legible file.' o=$value(output)
    put_line ' You cannot use this procedure until you remedy this problem.' o=$fname($string($value(output))//'.$EOI')
    status = $status(FALSE, 'PF', 000000, 'The input file is not a legible file.')
    EXIT_PROC WITH status
  IFEND
  crev (scratch_string_1, scratch_string_2, build_string, offset, new_line) k=string
  crev (converted_integer_length, converted_integer, new_offset) k=integer
  crev edit_status k=status
  edit_file f=$value(input) p=$null o=$null
    edit_status.normal = TRUE
    locate_text t='0021 3651' status=edit_status
    IF NOT edit_status.normal THEN
      quit no
      delv (scratch_string_1, scratch_string_2, build_string)
      delv (converted_integer_length, converted_integer)
      EXIT_PROC WITH edit_status
    IFEND
    position_cursor n=2 status=edit_status
    IF NOT edit_status.normal THEN
      quit no
      delv (scratch_string_1, scratch_string_2, build_string)
      delv (converted_integer_length, converted_integer)
      EXIT_PROC WITH edit_status
    IFEND
    WHEN any_fault DO
      quit no
      EXIT_PROC WITH $status(FALSE, 'PF', 000000, 'Condition handler activated.')
    WHENEND
    i = 1
    page = 1
    line = 1
    mem_column_1 = 66
    mem_column_2 = 71
    allocate_column = 78

" The following comments are the possible ways memory can be displayed by ANAD.  Substring references are determined by layout: ..
00000100  0123 4567 89AB CDEF   0123 4567 89AB CDEF   0123 4567 89AB CDEF   0123 4567 89AB CDEF ..
00000100   0123 4567 89AB CDEF   0123 4567 89AB CDEF   0123 4567 89AB CDEF   0123 4567 89AB CDEF

    scratch_string_1 = $line_text
    scratch_string_2 = '0'//$substr(scratch_string_1, mem_column_1, 4)//$substr(scratch_string_1, mem_column_2, 4)//'0'//'(16)'
    disv $integer(scratch_string_2) o=:$local.$null status=edit_status
    IF NOT edit_status.normal THEN
      mem_column_1 = 65
      mem_column_2 = 70
      allocate_column = 77
      edit_status.normal = TRUE
    IFEND

    WHILE edit_status.normal DO
      IF line = 1 THEN
        put_line '1Heap map generated from file '//$string($value(input))//'                     PAGE '//$strrep(page) ..
 o=$fname($string($value(output))//'.$EOI')
        page = page + 1
        line = 3
        put_line '0  OFFSET (16)   LENGTH(16)   BLOCK STATUS     OFFSET (16)   LENGTH(16)   BLOCK STATUS     OFFSET (16)   LENGTH(16)   BLOCK STATUS' o=$fname($string($value(output))//'.$EOI')
        line = 4
        put_line '   ' o=$fname($string($value(output))//'.$EOI')
        line = 5
      IFEND
      scratch_string_1 = $line_text
      IF i = 1 THEN
        build_string = '   '
      ELSE
        build_string = build_string//'       '
      IFEND
      offset = $substr(scratch_string_1, 1, 8)
      build_string = build_string//offset                                             "OFFSET"
      scratch_string_2 = '0'//$substr(scratch_string_1, mem_column_1, 4)//$substr(scratch_string_1, mem_column_2, 4)//'0'//'(16)'
      converted_integer = $integer(scratch_string_2)
      converted_integer_length = $strlen($strrep(converted_integer, 16))
      build_string = build_string//'          '
      build_string = build_string//$substr($strrep(converted_integer,16), 1, 10)      "LENGTH"
      new_offset = $integer(offset//'(16)') + converted_integer
      IF $substr(scratch_string_1, 78) = 'F' THEN
        build_string = build_string//'allocated'
      ELSE                                                                            "ALLOCATED/FREE"
        build_string = build_string//'     free'
      IFEND
      IF i = 3 THEN
        put_line build_string o=$fname($string($value(output))//'.$EOI')
        i = 1
        IF line = 60 THEN
          line = 1
        ELSE
          line = line + 1
        IFEND
      ELSE
        i = i + 1
      IFEND
      IF $strlen($strrep(new_offset)) = 1 THEN
        new_line = '0000000'//$strrep(new_offset, 16)
      ELSEIF $strlen($strrep(new_offset)) = 2 THEN
        new_line = '000000'//$strrep(new_offset, 16)
      ELSEIF $strlen($strrep(new_offset)) = 3 THEN
        new_line = '00000'//$strrep(new_offset, 16)
      ELSEIF $strlen($strrep(new_offset)) = 4 THEN
        new_line = '0000'//$strrep(new_offset, 16)
      ELSEIF $strlen($strrep(new_offset)) = 5 THEN
        new_line = '000'//$strrep(new_offset, 16)
      ELSEIF $strlen($strrep(new_offset)) = 6 THEN
        new_line = '00'//$strrep(new_offset, 16)
      ELSEIF $strlen($strrep(new_offset)) = 7 THEN
        new_line = '0'//$strrep(new_offset, 16)
      ELSE "$strlen($strrep(new_offset)) = 8"
        new_line = $strrep(new_offset, 16)
      IFEND
      position_cursor t=new_line d=f status=edit_status
      IF NOT edit_status.normal THEN
        IF $condition(edit_status) = 'ESE$TEXT_NOT_FOUND' THEN
          edit_status = $status(FALSE, 'XX', 0, 'Not enough memory dumped to complete heap map generation. ..
You must dump as much of this segment as possible to the same input file, using file position $EOI.')
        IFEND
      IFEND
    WHILEND
  quit
  delv (scratch_string_1, scratch_string_2, build_string, new_line)
  delv (converted_integer_length, converted_integer, offset, new_offset)
  change_file_attributes f=$value(output) fc=list status=ignore_status
  EXIT_PROC WITH edit_status WHEN NOT edit_status.normal
  delv (edit_status ignore_status)

PROCEND dum$generate_heap_map
*DECK DECK=DUM$GET_IJLEP_VIA_GTID EXPAND=TRUE
PROC dum$GET_IJLEP_VIA_GTID get_ijlep_via_gtid (
  gtid  : integer -281474976710655..281474976710655 = $required
  ijlep : var of integer = $required
  )

  crev (ijlo, ptlp)
  get_ptlep_via_gtid $value(gtid) ptlp
  fetch_memory ptlp tmt$primary_task_list_entry ijl_ordinal ijlo
  get_ijlep_via_ijlo ijlo $value(ijlep)

PROCEND dum$get_ijlep_via_gtid
*DECK DECK=DUM$GET_IJLEP_VIA_IJLO EXPAND=TRUE
PROC dum$GET_IJLEP_VIA_IJLO get_ijlep_via_ijlo (
  ijlo  : integer -281474976710655..281474976710655 = $required
  ijlep : var of integer = $required
  )

  crev (junk ijll ijla ijlb ijlbn ijlbi)
  ijla = $mem($sa(jmv$ijl_p) 6)
  ijlbn = $value(ijlo) / 32
  ijlbi = $mod($value(ijlo), 32)
  ijlb = $mem(ijla+8*ijlbn+2, 6)
  fetch_field_info jmt$initiated_job_list_entry field=jmt$initiated_job_list_entry offset=junk length=ijll
  "Word aligned
  IF $mod(ijll, 64) <> 0 THEN
    ijll = ijll + 64 - $mod(ijll, 64)
  IFEND
  ijll = ijll / 8
  $value(ijlep) = ijlb + (ijll * ijlbi)

PROCEND dum$get_ijlep_via_ijlo
*DECK DECK=DUM$GET_LOG_ORDINAL EXPAND=TRUE
PROCEDURE dum$get_log_ordinal, get_log_ordinal, getlo (
  log, l: name = $required
  log_ordinal, lo: (VAR) integer = $required
  status)

  "$FORMAT=OFF"
  VAR
    index: integer
    maximum_log_ordinal: (READ) integer = 8
  VAREND
  "$FORMAT=ON"

  FOR index = 0 TO maximum_log_ordinal DO
    IF $memory_string($symbol_address(lgv$log_names)+(index*31), 31) = $string(log) THEN
      log_ordinal = index
      EXIT_PROC
    IFEND
  FOREND
  EXIT_PROC WITH $status(false, 'US', 0, $string(log)//' is not a known log.')

PROCEND dum$get_log_ordinal
*DECK DECK=DUM$GET_PATH_STRING EXPAND=TRUE

PROCEDURE dum$get_path_string, get_path_string, get_path (
  pde_offset, po: integer = $required
  path, p: (VAR) string = $optional
  status)

  "$FORMAT=OFF"
  VAR
    entry_type: integer
    path_node_name_size: integer
    path_string: string
    "offsets & lengths
    cycle_number_length: integer
    cycle_number_offset: integer
    entry_type_length: integer
    entry_type_offset: integer
    length: integer
    offset: integer
    parental_path_entry_offset: integer
    path_node_name_size_length: integer
    path_node_name_size_offset: integer
    path_node_name_value_offset: integer
    "addresses
    address: integer
    parental_path_address: integer
    pde_address: integer=(200400000000(16)+$value(pde_offset))
  VAREND
  "$FORMAT=ON"

  IF $specified(path) THEN
    path = ' unknown path '
  IFEND
  fmt$path_description_entry field=parental_path_entry offset=offset length=length
  parental_path_entry_offset = offset/8

  fmt$path_description_entry field=entry_type offset=offset length=length
  entry_type_offset = offset/8
  entry_type_length = length/8

  fmt$path_description_entry field=path_node_name offset=offset length=length
  fst$path_element field=value offset=path_node_name_value_offset length=length
  path_node_name_value_offset = (offset+path_node_name_value_offset)/8

  fst$path_element field=size offset=path_node_name_size_offset length=length
  path_node_name_size_offset = (offset+path_node_name_size_offset)/8
  path_node_name_size_length = length/8

  fmt$path_description_entry field=cycle_number offset=offset length=length
  cycle_number_offset = offset/8
  cycle_number_length = length/8

  entry_type = $memory((pde_address+entry_type_offset), entry_type_length)
  IF entry_type = 1 THEN
    path_string = '.'//$strrep($memory((pde_address+cycle_number_offset), cycle_number_length))
    parental_path_address = $memory((pde_address+parental_path_entry_offset))
  ELSE
    parental_path_address = pde_address
  IFEND
  WHILE NOT $nil_pva(parental_path_address) DO
    path_node_name_size = $memory((parental_path_address+path_node_name_size_offset), ..
          path_node_name_size_length)
    path_string = '.'//..
$memory_string((parental_path_address+path_node_name_value_offset), path_node_name_size)//path_string
    parental_path_address = $memory((parental_path_address+parental_path_entry_offset))
  WHILEND
  path_string(1) = ':'
  IF $specified(path) THEN
    path = path_string
  ELSE
    display_value v=path_string o=$output
  IFEND

PROCEND dum$get_path_string
*DECK DECK=DUM$GET_PTLEP_VIA_GTID EXPAND=TRUE
PROC dum$GET_PTLEP_VIA_GTID get_ptlep_via_gtid (
  gtid  : integer -281474976710655..281474976710655 = $required
  ptlep : var of integer = $required
  )

  crev (tindex)
  tindex = $value(gtid) / 100(16)
  compute_entry_address $sa(tmv$ptl_p) tindex $value(ptlep)

PROCEND dum$get_ptlep_via_gtid
*DECK DECK=DUM$GET_XCB EXPAND=TRUE
PROCEDURE dum$get_xcb, get_xcb, getxcb (
  xcb: (VAR) integer = $optional
  status)

 " This procedure gets the pva of the current tasks execution control block
 " If someone has a better way of doing this please change!

  set_file_attributes $local.disep fc=legible pf=continuous pw=78
  display_exchange_package o=$local.disep
  EDIT_FILE $local.disep o=$null p=$null
    p 'base const'
    left = $lt()(14, 4)
    left = '0'//left//'(16)'
    p
    right = $lt()(14, 4)
    right = '0'//right//'(16)'
    local_xcb = ($integer(left)*10000(16))+$integer(right)
    local_xcb = 300000000(16) + local_xcb
    IF $specified(xcb) THEN
      xcb = local_xcb
    ELSE
      disv local_xcb
    IFEND
  QUIT

PROCEND dum$get_xcb
*DECK DECK=DUM$LOCATE_ASID EXPAND=TRUE
PROCEDURE dum$locate_asid, locate_asid, loca (
  asid, a:integer 0 .. 0ffff(16) = $required
  exit_on_first, eof: boolean = true
  ptl: integer = 0
  output, o: file = $output
  status)


" This procedure searches the system FDE table for the specified ASID.

  "$FORMAT=OFF"
  VAR
    any_found: boolean = FALSE
    asti: integer
    current: name = $current_module
    fde: integer
    fde_table: integer = 100000000(16) + $mem($sa(gfv$fde_table_base) 8)
    gfc$fde_size: integer = $mem($sa(gfv$fde_size) 8)
    gfc$max_file_descriptor_index: integer = 0ffff(16) "maximum value of gft$file_descriptor_index"
  VAREND
  "$FORMAT=ON"

  chadm dmm$monitor_utilities

" Convert the given ASID to an ASTI which can be located in the FDE_table.

  dum$asti xasid=asid ptl=ptl xasti=asti

  FOR i = 0 TO gfc$max_file_descriptor_index DO
    fde = fde_table + (i * gfc$fde_size)
    IF $pv(?fde.gft$file_descriptor_entry.file_hash) <> 0FF(16) THEN
      IF $pv(?fde.gft$file_descriptor_entry.asti) = asti THEN
        any_found = TRUE
        put_line ' -- File entry '//$strrep(i, 16)//'(16) matches.  GFN ='//..
$pv(?fde.gft$file_descriptor_entry.global_file_name) o=output
        IF exit_on_first THEN
          chadm current
          EXIT
        IFEND
      IFEND
    IFEND

  FOREND

  IF not any_found THEN
    putl ' -- No FDE entry found for the specified ASID '  o=output
  IFEND

  chadm current

PROCEND dum$locate_asid
*DECK DECK=DUM$LOCATE_ESM_DRIVER EXPAND=TRUE
PROCEDURE dum$locate_esm_driver, locate_esm_driver, locesmd (
  display_option, do: key
      (pit, pp_interface_table)
      (response_buffer, rb)
      none
      all
    keyend = all
   output, o: file = $output
   status)

  " This procedure finds the file server drivers that are loaded.  This also optionally displays the
  " pp_interface_table, and the response buffer for the pp found.  This procedure requires RJTs current
  " dump analyzer.  This procedure requires that cmm$tables has been added.  Search for ASCII driver name
  " ESMD at location 100(8) - 101(8) or 2000(8) at location 100(8) and 0105(8) at location 101(8) - 1.3.

  VAR
    ignore_status: status
    iou: integer
    limit: integer
    line: string
    logical_pp_index: integer
    output_file: file
    pp: integer
    pp_kind: integer
    pp_type: ARRAY 1 ..2 OF string
    pp_type_name: name
    response_buffer_p: integer
  VAREND

  logical_pp_index = 0
  pp_type(1) = 'normal'
  pp_type(2) = 'cio'

  IF $file(output open_position) = '$BOI' THEN
    delete_file f=output status=ignore_status
  IFEND
  set_file_attributes f=output fc=legible pf=continuous
  output_file = output.$eoi

  FOR iou = 0 to 1 DO
    FOR pp_kind  = 1 to 2 DO
      FOR pp = 0 to 25 do
        IF (pp_type(pp_kind) = 'normal') OR (pp <= 9) THEN
          pp_type_name = $name(pp_type(pp_kind))
          IF $pp_available(pp, pp_type_name, iou) THEN
            IF ($pp_memory(pp, 100(8), pp_type_name, iou) = 42523(8) AND ..
                  $pp_memory(pp, 101(8), pp_type_name, iou) = 46504(8)) OR ..
                  ($pp_memory(pp, 100(8), pp_type_name, iou) = 2000(8) AND ..
                  $pp_memory(pp, 101(8), pp_type_name, iou) = 0105(8)) THEN
              line = ' ESM PP = IOU'//$strrep(iou)
              IF pp_type(pp_kind) = 'normal' THEN
                line = line//' PP'
              ELSE
                line = line//' CPP'
              IFEND
              line = line//$strrep(pp 8)//'(8)'
              put_line l=line o=output_file
              logical_pp_index = $pp_memory(pp, 76(8), pp_type_name, iou)
              put_line l=' Logical pp number '//$strrep(logical_pp_index)
            IFEND
          IFEND
        IFEND
      FOREND
    FOREND
  FOREND

  IF logical_pp_index = 0 THEN
    put_line l=' Unable to find the ESM PP.' o=output_file
  ELSE
    current = $default_module
    change_default_module m=cmm$monitor_routines
    IF (display_option = PIT) OR (display_option = ALL) THEN
      display_program_value n=cmv$logical_pp_table_p^[?logical_pp_index].pp_info.pp_interface_table_p^ ..
            o=output_file
    IFEND
    IF (display_option = RESPONSE_BUFFER) OR (display_option = ALL) THEN
      response_buffer_p = $program_value(cmv$logical_pp_table_p^[?logical_pp_index].pp_info..
            .pp_interface_table_p^.response_buffer)
      limit = $program_value(cmv$logical_pp_table_p^[?logical_pp_index].pp_info.pp_interface_table_p^.limit)
      display_memory a=response_buffer_p b=limit o=output_file
    IFEND
    change_default_module m=current
  IFEND

PROCEND dum$locate_esm_driver
*DECK DECK=DUM$LOCATE_FILE_KIND EXPAND=TRUE
PROCEDURE dum$locate_file_kind, locate_file_kind, locfk (
  file_kind, fk: key
      gfc$fk_job_permanent_file, gfc$fk_device_file, gfc$fk_save_2, gfc$fk_save_3, gfc$fk_catalog
      gfc$fk_job_local_file, gfc$fk_unnamed_file, gfc$fk_global_unnamed, gfc$fk_monitor_only_unnamed
    keyend = $required
  display_option, do: key
      (full, f, all)
      (brief, b)
    keyend = brief
  output, o: file = $output
  status)

" This procedure searches the system FDE table by file kind.

  "$FORMAT=OFF"
  VAR
    any_found: boolean = FALSE
    current: name = $current_module
    fde: integer
    fde_table: integer = 100000000(16) + $mem($sa(gfv$fde_table_base) 8)
    gfc$fde_size: integer = $mem($sa(gfv$fde_size) 8)
    gfc$max_file_descriptor_index: integer = 0ffff(16) "maximum value of gft$file_descriptor_index"
    p_disk_file_descriptor: integer
    p_server_descriptor: integer
  VAREND
  "$FORMAT=ON"

  chadm dmm$file_table_manager
  set_file_attributes output fc=legible pf=continuous pw=78

  FOR i = 0 TO gfc$max_file_descriptor_index DO
    fde = fde_table + (i * gfc$fde_size)
    IF $pv(?fde.gft$file_descriptor_entry.file_hash) <> 0FF(16) THEN
      IF $pv(?fde.gft$file_descriptor_entry.file_kind) = file_kind THEN
        any_found = TRUE
        put_line ' -- File entry '//$strrep(i, 16)//'(16) matches.  GFN = '//..
$pv(?fde.gft$file_descriptor_entry.global_file_name) o=output.$eoi
        IF display_option = full THEN
          dispv ?fde.gft$file_descriptor_entry o=output.$eoi
          IF ?fde.gft$file_descriptor_entry.media = gfc$fm_mass_storage_file THEN
            p_disk_file_descriptor = 100000000(16) + ..
                  $pv(?fde.gft$file_descriptor_entry.disk_file_descriptor_p)
            dispv ?p_disk_file_descriptor.dmt$disk_file_descriptor o=output.$eoi
          ELSEIF ?fde.gft$file_descriptor_entry.media = gfc$fm_served_file THEN
            p_server_descriptor = 100000000(16) + ..
                  $pv(?fde.gft$file_descriptor_entry.served_file_descriptor_p)
            dispv ?p_server_descriptor.dft$server_descriptor o=output.$eoi
          IFEND
          putl '  ------------------------ ' o=output.$eoi
        IFEND
      IFEND
    IFEND
  FOREND

  IF NOT any_found THEN
    putl ' -- '//' None found of kind '//$string(file_kind)  o=output.$eoi
  IFEND

  chadm current

PROCEND dum$locate_file_kind
*DECK DECK=DUM$LOCATE_FILE_MEDIA EXPAND=TRUE
PROCEDURE dum$locate_file_media, locate_file_media, locfm (
  file_media, fm: key
      gfc$fm_transient_segment, gfc$fm_mass_storage_file, gfc$fm_served_file
    keyend = $required
  display_option, do: key
      (full, f, all)
      (brief, b)
    keyend = brief
  output, o: file = $output
  status)

" This procedure searches the system FDE table by file media.

  "$FORMAT=OFF"
  VAR
    any_found: boolean = FALSE
    current: name = $current_module
    fde: integer
    fde_table: integer = 100000000(16) + $mem($sa(gfv$fde_table_base) 8)
    gfc$fde_size: integer = $mem($sa(gfv$fde_size) 8)
    gfc$max_file_descriptor_index: integer = 0ffff(16) "maximum value of gft$file_descriptor_index"
  VAREND
  "$FORMAT=ON"

  chadm dmm$file_table_manager
  set_file_attributes output fc=legible pf=continuous pw=78

  FOR i = 0 TO gfc$max_file_descriptor_index DO
    fde = fde_table + (i * gfc$fde_size)
    IF $pv(?fde.gft$file_descriptor_entry.file_hash) <> 0FF(16) THEN
      IF $pv(?fde.gft$file_descriptor_entry.file_media) = file_media THEN
        any_found = TRUE
        put_line ' -- File entry '//$strrep(i, 16)//'(16) matches.  GFN = '//..
$pv(?fde.gft$file_descriptor_entry.global_file_name) o=output.$eoi
        IF display_option = full THEN
          dispv ?fde.gft$file_descriptor_entry o=output.$eoi
          IF file_media = gfc$fm_mass_storage_file THEN
            p_disk_file_descriptor = 100000000(16) + ..
                  $pv(?fde.gft$file_descriptor_entry.disk_file_descriptor_p)
            dispv ?p_disk_file_descriptor.dmt$disk_file_descriptor o=output.$eoi
          ELSEIF file_media = gfc$fm_served_file THEN
            p_server_descriptor = 100000000(16) + ..
                  $pv(?fde.gft$file_descriptor_entry.served_file_descriptor_p)
            dispv ?p_server_descriptor.dft$server_descriptor o=output.$eoi
          IFEND
          putl '  ------------------------ ' o=output.$eoi
        IFEND
      IFEND
    IFEND
  FOREND

  IF NOT any_found THEN
    putl ' -- None found of media '//$string(file_media) o=output.$eoi
  IFEND

  chadm current

PROCEND dum$locate_file_media
*DECK DECK=DUM$LOCATE_FILE_TYPE EXPAND=TRUE
PROCEDURE dum$locate_file_type, locate_file_type, locft (
  file_type, ft: key
      dmc$permanent, dmc$device, dmc$temp_named, dmc$temp_unnamed, dmc$catalog
      dmc$temp_global, dmc$server_file
    keyend = dmc$server_file
  display_option, do: key
      (full, f, all)
      (brief, b)
    keyend = brief
  output, o: file = $output
  status)

  EXIT_PROC WITH $status(FALSE, 'US', 0, 'LOCATE_FILE_TYPE command has been replaced with ..
commands LOCATE_FILE_KIND and LOCATE_FILE_MEDIA.')

PROCEND dum$locate_file_type
*DECK DECK=DUM$LOCATE_GLOBAL_FILE_NAME EXPAND=TRUE
PROCEDURE dum$locate_global_file_name, locate_global_file_name, locgfn (
  global_file_name, gfn: name = $optional
  file, f: file = $optional
  status
  )

  IF $specified(global_file_name) AND $specified(file) THEN
    EXIT_PROC WITH $status(false 'us' 0 'cannot specify both gfn and file')
  ELSEIF (NOT $specified(global_file_name)) AND (NOT $specified(file)) THEN
    EXIT_PROC WITH $status(false 'us' 0 'must specify either gfn or file')
  IFEND

  "$FORMAT=OFF"
  VAR

" The following constant is found in the deck GFC$CONSTANTS.

    gfc$fde_size: integer = $mem($sa(gfv$fde_size) 8)

    gfc$fde_table_base: integer = $mem($sa(gfv$fde_table_base) 8)
    gfc$max_file_descriptor_index: integer = 0ffff(16) "maximum value of gft$file_descriptor_index"

    global_name_offset: integer = 17(16)
    local_gfn: string
    sft: integer
  VAREND
  "$FORMAT=ON"

  IF $specified(global_file_name) THEN

" Convert the Global_File_Name input parameter into a representation that would be found in memory.

    local_gfn = $convert_unique_name($string(gfn))
  ELSE
    "$FORMAT=OFF"
    VAR
      attributes: any
    VAREND
    "$FORMAT=ON"

" Determine the Global_File_Name from the File input parameter and convert it into a representation that would
" be found in memory.

    attributes = $file_attributes(file,unique_data_name)(1)
    IF $field(attributes,unique_data_name,specified)
      putl ' Global File Name = '//attributes.unique_data_name
      local_gfn = $convert_unique_name(attributes.unique_data_name)
    ELSE
      put_line,l=' Unknown file: '//file
      exit_proc
    IFEND
  IFEND

  sft = 100000000(16) + gfc$fde_table_base
  FOR i = 0 TO gfc$max_file_descriptor_index DO
    fde = sft + (i * gfc$fde_size)
    IF local_gfn = $ms(fde+global_name_offset, 11) THEN
      putl ' File entry {FDE} '//$strrep(i, 16)//'(16) matches.'
      EXIT_PROC " <------------ "
    IFEND
  FOREND

  putl ' No SFT entry found for the specified global file name.'

PROCEND dum$locate_global_file_name
*DECK DECK=DUM$LOCATE_JOB_GLOBAL_FILE_NAME EXPAND=TRUE
PROCEDURE dum$locate_job_global_file_name, locate_job_global_file_name, locjgfn (
  global_file_name, gfn: name = $optional
  file, f: file = $optional
  status
  )

  IF $specified(global_file_name) AND $specified(file) THEN
    EXIT_PROC WITH $status(false 'us' 0 'cannot specify both gfn and file')
  ELSEIF (NOT $specified(global_file_name)) AND (NOT $specified(file)) THEN
    EXIT_PROC WITH $status(false 'us' 0 'must specify either gfn or file')
  IFEND

  "$FORMAT=OFF"
  VAR

" The following constant is found in the deck GFC$CONSTANTS.

    gfc$fde_size: integer = $mem($sa(gfv$fde_size) 8)
    gfc$fde_table_base: integer = $mem($sa(gfv$fde_table_base) 8)
    gfc$max_file_descriptor_index: integer = 0ffff(16) "maximum value of gft$file_descriptor_index"

    global_name_offset: integer = 17(16)
    local_gfn: string
    sft: integer
  VAREND
  "$FORMAT=ON"

  IF $specified(global_file_name) THEN

" Convert the Global_File_Name input parameter into a representation that would be found in memory.

    local_gfn = $convert_unique_name($string(gfn))
  ELSE
    "$FORMAT=OFF"
    VAR
      attributes: any
    VAREND
    "$FORMAT=ON"

" Determine the Global_File_Name from the File input parameter and convert it into a representation that would
" be found in memory.

    attributes = $file_attributes(file,unique_data_name)(1)
    IF $field(attributes,unique_data_name,specified)
      putl ' Global File Name = '//attributes.unique_data_name
      local_gfn = $convert_unique_name(attributes.unique_data_name)
    ELSE
      put_line,l=' Unknown file: '//file
      exit_proc
    IFEND
  IFEND

  sft = 300000000(16) + gfc$fde_table_base
  FOR i = 0 TO gfc$max_file_descriptor_index DO
    fde = sft + (i * gfc$fde_size)
    IF local_gfn = $ms(fde+global_name_offset, 11) THEN
      putl ' File entry {FDE} '//$strrep(i, 16)//'(16) matches.'
      EXIT_PROC " <------------ "
    IFEND
  FOREND

  putl ' No SFT entry found for the specified job global file name.'

PROCEND dum$locate_job_global_file_name
*DECK DECK=DUM$MOVE_BYTES EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Analyze System: System Memory Access' ??                                               
MODULE dum$move_bytes;                                                                                        
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains an interface to provide controlled access to system                                  
{   memory.                                                                                                   
{                                                                                                             
{ DESIGN:                                                                                                     
{   This module is intended to be part of Task Services (ring 3) and provide                                  
{   read access to system memory for the Analyze System utility running in                                    
{   user rings.  Since most NOS/VE data segments are readable from Task                                       
{   Services, most NOS/VE data will be readable through Analyze System.                                       
{                                                                                                             
{   Validation is provided on an individual user basis through a user level,                                  
{   site defined validation capability called "read_system_memory".  The                                      
{   following definitions and structured English summarize the validation                                     
{                                                                                                             
{   read_system_memory:   user_level, site defined capability                                                 
{   system_job:           indicates if request is from within system job                                      
{   system_administrator: indicates if user is running as system administrator                                
{   secure_analysis:      indicates if system is running with secure analysis                                 
{   minimum_ring:         user's minimum ring privilege                                                       
{   caller_ring:          calling programs ring of execution                                                  
{   source_ring:          ring to be used in source address                                                   
{                                                                                                             
{   IF (system_job OR system_administrator OR read_system_memory) AND                                         
{      NOT secure_analysis THEN                                                                               
{     source_ring = 1                                                                                         
{   ELSE                                                                                                      
{     source_ring = 15                                                                                        
{   IFEND                                                                                                     
{   source_ring = minimum (source_ring, minimum_ring, caller_ring)                                            
{                                                                                                             
{   Source_ring is used to form the address from which memory is read.  If                                    
{   necessary, the hardware also votes source_ring up to the ring of execution                                
{   of the memory access routine (Task Services = 3).                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc avp$get_capability                                                                                     
*copyc avp$ring_min                                                                                           
*copyc avp$system_administrator                                                                               
*copyc avv$security_options                                                                                   
*copyc i#move                                                                                                 
*copyc jmp$system_job                                                                                         
*copyc osd$virtual_address                                                                                    
*copyc osp$establish_condition_handler                                                                        
*copyc osp$set_status_from_condition                                                                          
*copyc ost$caller_identifier                                                                                  
?? POP ??                                                                                                     
?? NEWTITLE := '  dup$move_bytes', EJECT ??                                                                   
*copy duh$move_bytes                                                                                          
                                                                                                              
  PROCEDURE [XDCL, #GATE] dup$move_bytes (source: ^cell;                                                      
        destination: ^cell;                                                                                   
        length: 0 .. 7fffffff(16);                                                                            
    VAR status: ost$status);                                                                                  
                                                                                                              
    VAR                                                                                                       
      caller_id: ost$caller_identifier,                                                                       
      local_status: ost$status,                                                                               
      minimum_ring: ost$valid_ring,                                                                           
      read_system_memory: boolean,                                                                            
      secure_analysis: boolean,                                                                               
      source_ring: ost$valid_ring,                                                                            
      system_administrator: boolean,                                                                          
      system_job: boolean;                                                                                    
                                                                                                              
    PROCEDURE move_bytes_handler                                                                              
     (    condition: pmt$condition;                                                                           
          condition_information: ^pmt$condition_information;                                                  
          save_area: ^ost$stack_frame_save_area;                                                              
      VAR handler_status: ost$status);                                                                        
                                                                                                              
      osp$set_status_from_condition ('DU', condition, save_area, status, handler_status);                     
                                                                                                              
      IF NOT handler_status.normal THEN                                                                       
        status := handler_status;                                                                             
      IFEND;                                                                                                  
                                                                                                              
      EXIT dup$move_bytes;                                                                                    
                                                                                                              
    PROCEND move_bytes_handler;                                                                               
                                                                                                              
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    osp$establish_condition_handler (^move_bytes_handler, FALSE);                                             
                                                                                                              
    system_job := jmp$system_job ();                                                                          
    system_administrator := avp$system_administrator ();                                                      
                                                                                                              
    avp$get_capability (avc$read_system_memory, avc$user, read_system_memory, local_status);                  
    read_system_memory := local_status.normal AND read_system_memory;                                         
                                                                                                              
    secure_analysis := avv$security_options [avc$vso_secure_analysis].active;                                 
                                                                                                              
    IF NOT secure_analysis AND (system_job OR system_administrator OR read_system_memory) THEN                
      source_ring := osc$os_ring_1;                                                                           
    ELSE                                                                                                      
      source_ring := osc$max_ring;                                                                            
    IFEND;                                                                                                    
                                                                                                              
    minimum_ring := avp$ring_min ();                                                                          
    IF (minimum_ring < source_ring) THEN                                                                      
      source_ring := minimum_ring;                                                                            
    IFEND;                                                                                                    
                                                                                                              
    #CALLER_ID (caller_id);                                                                                   
    IF (caller_id.ring < source_ring) THEN                                                                    
      source_ring := caller_id.ring;                                                                          
    IFEND;                                                                                                    
                                                                                                              
    i#move (#address (source_ring, #segment (source), #offset (source)), destination, length);                
  PROCEND dup$move_bytes;                                                                                     
?? OLDTITLE ??                                                                                                
MODEND dum$move_bytes;                                                                                        
*DECK DECK=DUM$PROCESS_ACTIVE_JOB_LIST EXPAND=TRUE
PROCEDURE dum$process_active_job_list, process_active_job_list, proajl (
  ajl_ordinal, ao: any of
      key (all a) keyend
      integer
    anyend = all
  include_monitor, im: boolean = TRUE
  output, o: file = $output
  status)

" This procedure performs an analysis of all tasks in all jobs
" which are currently active (have ajl entries), plus monitor.

  VAR
    cctqm: string 0..256 = '???????????????????????????????? !"#$%&''()*+,-./0123456789:;<=>?@'//..
          'ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~?????????????????????'//..
          '???????????????????????????????????????????????????????????????????????????????????'//..
          '?????????????????????????'
    jmv$jcb: integer = 300000000(16)              "($sa(jmv$jcb))
    job_fixed_seg_num: integer = 14(16)           "relative to monitor address space
    job_monitor_xcb_offset: integer = 100(16)     "from start of job fixed
  VAREND

  VAR
    adr: integer
    ajl: integer
    ajl_entry_size: integer
    ajl_ord: integer
    ajl_p: integer
    field_length: integer
    field_offset: integer
    function: integer
    gtid: integer
    jcb: integer
    job_monitor_xcb: integer
    job_name: integer
    last_ajl_ordinal: integer
    len: integer
    line: string
    line2: string
    link: integer
    local_file: file = $fname('$local.'//$unique)
    local_status: status
    mcr: integer
    monitor_functions: ARRAY 0..74 OF string
    number_of_entries: integer
    output_file: file
    pva: integer
    start_ajl_ordinal: integer
    str2: string
    system_ajl_ordinal: integer
    task_name: integer
    task_xcb: integer
    temp_file: file = $fname('$local.'//$unique)
    title_string: string
    top_of_page_needed: boolean = TRUE
    user_id: integer
  VAREND

  IF $file(output open_position) = '$BOI' THEN
    delete_file f=output status=local_status
    set_file_attributes f=output fc=list
  IFEND
  output_file = output.$eoi
  set_file_attributes f=temp_file fc=unknown

  put_line l='1COMMAND: PROCESS_ACTIVE_JOB_LIST' o=output_file
  put_line l=' ' o=output_file

  change_default e=monitor am=pva
  IF include_monitor THEN
    display_call e=monitor do=(f s) t='monitor call chain' o=temp_file
    copy_file i=temp_file o=output_file
  IFEND

  ost$execution_control_block field=SAVE9 offset=field_offset length=field_length
  task_name = field_offset/8                            "offset into the XCB
  ost$execution_control_block field=GLOBAL_TASK_ID offset=field_offset length=field_length
  gtid = field_offset/8                                 "offset into the XCB to GTID
  ost$execution_control_block field=LINK offset=field_offset length=field_length
  link = field_offset/8                                 "offset into xcb
  jmt$job_control_block field=JOBNAME offset=field_offset length=field_length
  job_name = field_offset/8                             "offset into job control block
  jmt$job_control_block field=USER_ID offset=field_offset length=field_length
  user_id = field_offset/8                              "offset into job control block

  ajl_p = $symbol_address(jmv$ajl_p)
  ajl = $memory(ajl_p)
  IF $nil_pva(ajl) THEN
    put_line l=' The active job list has not yet been established.' o=output_file
    EXIT PROCEDURE
  IFEND

  ajl_entry_size = $memory(ajl_p+14 4)
  system_ajl_ordinal = $memory(ajl_p+10 4)
  number_of_entries = $memory(ajl_p+6 4) / ajl_entry_size

  last_ajl_ordinal = system_ajl_ordinal + number_of_entries - 1
  change_processor_register ..
        jps=$rma(((system_ajl_ordinal + job_fixed_seg_num)*100000000(16))+job_monitor_xcb_offset)
  change_default e=job

  create_monitor_func_file f=local_file
  accept_line v=monitor_functions i=local_file
  detach_file f=local_file

  IF $value_kind(ajl_ordinal) = 'INTEGER' THEN
    start_ajl_ordinal = ajl_ordinal
    IF start_ajl_ordinal > last_ajl_ordinal THEN
      put_line l=' The selected ordinal is beyond the end of the active job list.' o=output_file
      EXIT PROCEDURE
    IFEND
    last_ajl_ordinal = start_ajl_ordinal
  ELSE
    start_ajl_ordinal = system_ajl_ordinal
  IFEND

  FOR ajl_ord = start_ajl_ordinal TO last_ajl_ordinal DO
    jcb = ((ajl_ord + job_fixed_seg_num) * 100000000(16))
    pva = jcb + job_monitor_xcb_offset
    include_line sl='display_value v=$rma(jcb monitor) o=$null' status=local_status
    IF local_status.normal THEN
      jcb = $memory(jcb 1 m)
    ELSE
      jcb = 0
    IFEND

    IF jcb = 255 THEN
      put_line l='1*************************************************************************' o=output_file
      put_line l=' processing ajl ordinal '//$strrep(ajl_ord,16) o=output_file
      top_of_page_needed = FALSE

      job_monitor_xcb = $rma(pva monitor)
      change_processor_register jps=job_monitor_xcb

      IF ajl_ord <> system_ajl_ordinal THEN
        put_line l=' job name = '//$trim($translate(cctqm $memory_string(jmv$jcb+job_name 31))) o=output_file
      IFEND
      put_line l=' user id = '//$trim($translate(cctqm $memory_string(jmv$jcb+user_id 31))) o=output_file
      put_line l=' -------------------------------------------------------------------------' o=output_file

      task_xcb = $memory($symbol_address(job_xcb_list))
      IF ($memory(task_xcb+88 2)*10000(16)+$memory(task_xcb+96 2)) = 7fffffff(16) THEN
        task_xcb = $memory(task_xcb+link)
      IFEND

      process_tasks: ..
      REPEAT
        change_processor_register jps=$rma(task_xcb)
        IF $job(mode) = 'INTERACTIVE' THEN
          line2 = 'Task name = '//$trim($translate(cctqm $memory_string((task_xcb+task_name) 31)))
          IF top_of_page_needed THEN
            line2 = '1'//line2
          ELSE
            line2 = ' '//line2
            top_of_page_needed = TRUE
          IFEND
          put_line l=line2 o=output_file
          put_line l=' GTID = '//$strrep($memory(task_xcb+gtid 3) 16) o=output_file
          mcr = $process_register(mcr) / 10(16)
          IF mcr = ((mcr / 2) * 2) THEN
            function = $memory(task_xcb+088(16) 1)
            IF (function > 0) AND (function < 75) THEN
              put_line l=' monitor request = '//monitor_functions(function) o=output_file
              adr = task_xcb+17*8
              line = '    '
              for i=1 to 8
                str2 = '00000000'//$strrep($memory(adr 4) 16)
                len = $strlen(str2)
                line = line//'  '//$substr(str2 len-7 8)
                adr = adr + 4
              forend
              put_line l=line o=output_file
            IFEND
          IFEND
        IFEND
        title_string = $strrep(ajl_ord)//' '//$memory_string((task_xcb+task_name) 31)
        display_call e=job o=temp_file t=$substring(title_string 1 31 ' ')
        copy_file i=temp_file o=output_file
        EXIT process_tasks WHEN $rma(task_xcb) = job_monitor_xcb
        task_xcb = $mem(task_xcb+link)
        put_line l=' -------------------------------------------------------------------------' o=output_file
      UNTIL $nil_pva(task_xcb)
    IFEND
  FOREND

  detach_file f=temp_file status=local_status

PROCEND dum$process_active_job_list
*DECK DECK=DUM$PROCESS_DFT_BUFFER_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Dump Analyzer : Process DFT Buffer Command' ??
MODULE dum$process_dft_buffer_command;

{ PURPOSE:
{   This module contains the code for the process_dft_buffer command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dst$dft_analysis_code_constants
*copyc due$exception_condition_codes
?? POP ??
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc dup$determine_dump_information
*copyc dup$new_page_procedure
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc dup$retrieve_dft_pointers
*copyc dup$retrieve_register
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc duv$dump_environment_p
*copyc duv$execution_environment
*copyc duv$title_data
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    c$message_size = 62,
    c$number_of_iou = 0D(16),
    c$number_of_memory = 09(16),
    c$number_of_cpu = 32(16),
    c$number_of_page_map = 02(16),
    c$number_of_bad_requests = 09(16),
    c$number_of_packet = 07(16),
    c$number_of_software = 2C(16),
    c$number_of_non = 0A(16),
    c$number_of_dft_messages = c$number_of_iou + c$number_of_memory + c$number_of_cpu +
          c$number_of_page_map + c$number_of_bad_requests + c$number_of_packet + c$number_of_software +
          c$number_of_non,

    c$number_of_os_actions = 1d(16),
    c$number_of_priorities = 6;

  TYPE
    t$date_time = RECORD
      CASE boolean OF
      = TRUE =
        skip: 0 .. 0ff(16),
        year: 0 .. 0ff(16),
        month: 0 .. 0ff(16),
        day: 0 .. 0ff(16),
        hour: 0 .. 0ff(16),
        minute: 0 .. 0ff(16),
        second: 0 .. 0ff(16),
        rfu: 0 .. 0ff(16),
      = FALSE =
        data: integer,
      CASEND,
    RECEND,

    t$date_time_string = RECORD
      CASE boolean OF
      = TRUE =
        month: string (2),
        slash_1: string (1),
        day: string (2),
        slash_2: string (1),
        year: string (2),
        spaces: string (2),
        hour: string (2),
        period_1: string (1),
        minute: string (2),
        period_2: string (1),
        second: string (2),
      = FALSE =
        data: string (20),
      CASEND,
    RECEND,

    t$descriptor_line = RECORD
      CASE boolean OF
      = TRUE =
        register_string: string (19),
        spaces: string (3),
        description: string (38),
      = FALSE =
        data: string (60),
      CASEND,
    RECEND,

    t$dft_message = RECORD
      dft_analysis_code: dst$dftb_dft_analysis_code,
      value: string (c$message_size),
    RECEND,

    t$fault_symptom_code = RECORD
      rfu: 0 .. 0ffffffff(16),
      CASE boolean OF
      = TRUE =
        code: string (12),
      = FALSE =
        code_array: ARRAY [1 .. 12] OF 0 .. 0ff(16),
      CASEND,
    RECEND,

    t$mdb_control_word = PACKED RECORD
      rfu_1: 0 .. 0f(16),
      long_term_interlock_flag: 0 .. 0f(16),
      control_word_offset: 0 .. 0ff(16),
      priority: 0 .. 0f(16),
      sequence_number: 0 .. 0ff(16),
      rfu_2: 0 .. 0fffff(16),
      length_to_log: 0 .. 0ffff(16),
    RECEND,

    t$sorted = RECORD
      sequence: dst$dftb_sequence_number,
      index: dst$dftb_element_size,
    RECEND;
?? EJECT ??

  VAR
    v$dash: string (76) := '   -------------------------------------------------------------------------',
    v$data: dut$dft_data := [0, 0, 0, 0, [REP (duc$dft_max_known_pointer_words + 1) OF [NIL, 0, FALSE]],
          [REP duc$dft_max_mdb_buffers OF [NIL, 0, FALSE]]],
    v$display_capture_buffer: boolean,
    v$display_control: clt$display_control,
    v$nil_error: string (49) := ' -- ERROR -- Encountered an internal NIL pointer.',
    v$restart_file_seq_p: ^SEQ ( * ),
    v$star: string (76) := ' ***************************************************************************';
?? EJECT ??

  VAR
    { This variable contains the constant log messages for the messages created from the dft errors and from
    { system detected errors that have a dft analysis code described in dst$dft_analysis_code_constants.  IF
    { new error codes are added three decks must be changed.  This deck and CTI$DFT_ANALYSIS_CODES and
    { DST$DFT_ANALYSIS_CODE_CONSTANTS and DSM$LOG_SYSTEM_MESSAGES.

    v$dft_message: [READ] ARRAY [1 .. c$number_of_dft_messages] OF t$dft_message :=
      { IOU }
          [[dsc$dftb_dac_iou_001, '*DEADSTART ERROR LOG IOU ERROR'],
           [dsc$dftb_dac_iou_002, '*EXPRESS DEADSTART DUMP IOU ERROR'],
           [dsc$dftb_dac_iou_003, '*CORRECTED IOU ERROR'],
           [dsc$dftb_dac_iou_004, '*UNCORRECTED IOU ERROR (PP HALT)'],
           [dsc$dftb_dac_iou_005, '*12/16 IOU CONVERSION ERROR'],
           [dsc$dftb_dac_iou_006, '*FATAL IOU ERROR (NOT PP HALT)'],
           [dsc$dftb_dac_iou_007, '*IOU CHANNEL ERROR'],
           [dsc$dftb_dac_iou_008, '*FATAL IOU ERROR (NOT PP HALT)'],
           [dsc$dftb_dac_iou_009, '*UNCORRECTED IOU ERROR (PP HALT)'],
           [dsc$dftb_dac_iou_00A, '*12/16 IOU CONVERSION ERROR'],
           [dsc$dftb_dac_iou_00B, '*IOU CHANNEL ERROR'],
           [dsc$dftb_dac_iou_00C, '*IOU SS BIT 57 CONDITION'],
           [dsc$dftb_dac_iou_0FF, '*HARDWARE ERROR'],
      { MEMORY }
           [dsc$dftb_dac_mem_101, '*DEADSTART ERROR LOG MEMORY ERROR'],
           [dsc$dftb_dac_mem_102, '*EXPRESS DEADSTART DUMP MEMORY ERROR'],
           [dsc$dftb_dac_mem_103, '*CORRECTED MEMORY ERROR'],
           [dsc$dftb_dac_mem_104, '*UNCORRECTED MEMORY ERROR'],
           [dsc$dftb_dac_mem_105, '*FATAL CM ERROR (MULTIPLE ODD BIT ERROR)'],
           [dsc$dftb_dac_mem_106, '*FATAL CM ERROR (PARTIAL WRITE PARITY ERROR)'],
           [dsc$dftb_dac_mem_107, '*RESERVED FOR FUTURE USE'],
           [dsc$dftb_dac_mem_108, '*UNCORRECTED MEMORY BOARD LEVEL ERROR'],
           [dsc$dftb_dac_mem_109, '*UNCORRECTED MEMORY INTERFACE ERROR'],
      { CPU }
           [dsc$dftb_dac_cpu_201, '*DEADSTART ERROR LOG PROCESSOR ERROR'],
           [dsc$dftb_dac_cpu_202, '*EXPRESS DEADSTART DUMP PROCESSOR ERROR'],
           [dsc$dftb_dac_cpu_203, '*CORRECTED PROCESSOR ERROR'],
           [dsc$dftb_dac_cpu_204, '*UNCORRECTED PROCESSOR ERROR'],
           [dsc$dftb_dac_cpu_205, '*RETRY IN PROGRESS'],
           [dsc$dftb_dac_cpu_206, '*SOFT CONTROL MEMORY RELOAD'],
           [dsc$dftb_dac_cpu_207, '*UNSUCCESSFUL SOFT CONTROL MEMORY RELOAD'],
           [dsc$dftb_dac_cpu_208, '*FATAL CPU HALT CLASS 1'],
           [dsc$dftb_dac_cpu_209, '*CPU ERROR EXIT MODE 20'],
           [dsc$dftb_dac_cpu_20A, '*CPU ERROR EXIT MODE 67'],
           [dsc$dftb_dac_cpu_20B, '*FATAL CPU RECOVERY ERROR'],
           [dsc$dftb_dac_cpu_20C, '*CORRECTED PROCESSOR ERROR WITH CACHE RELOAD'],
           [dsc$dftb_dac_cpu_20D, '*FATAL CPU UNCORRECTED ERROR'],
           [dsc$dftb_dac_cpu_20E, '*FATAL CPU ERROR (DUE THRESHOLD EXCEEDED)'],
           [dsc$dftb_dac_cpu_20F, '*FATAL C170 STATE DUE'],
           [dsc$dftb_dac_cpu_210, '*FATAL C170 STATE EXIT MODE HALT'],
           [dsc$dftb_dac_cpu_211, '*FATAL MONITOR DUE'],
           [dsc$dftb_dac_cpu_212, '*FATAL MONITOR ERROR'],
           [dsc$dftb_dac_cpu_213, '*FATAL MONITOR MCR'],
           [dsc$dftb_dac_cpu_214, '*FATAL EI DUE'],
           [dsc$dftb_dac_cpu_215, '*FATAL MCH ERROR'],
           [dsc$dftb_dac_cpu_216, '*FATAL JOB ERROR'],
           [dsc$dftb_dac_cpu_217, '*FATAL JOB MCR'],
           [dsc$dftb_dac_cpu_218, '*FATAL CPU N ERROR'],
           [dsc$dftb_dac_cpu_219, '*FORCED UNCORRECTED ERROR'],
           [dsc$dftb_dac_cpu_21A, '*FATAL CPU HALT CLASS 2'],
           [dsc$dftb_dac_cpu_21B, '*RETRY CONVERTED TO UNCORRECTED ERROR'],
           [dsc$dftb_dac_cpu_21C, '*RETRY EXHAUSTED'],
           [dsc$dftb_dac_cpu_21D, '*HOURLY RETRY THRESHOLD EXCEEDED'],
           [dsc$dftb_dac_cpu_21E, '*PARTIAL WRITE ADDRESS PARITY ERROR'],
           [dsc$dftb_dac_cpu_21F, '*FATAL CPU ERROR (UNABLE TO EXCHANGE OR TRAP)'],
           [dsc$dftb_dac_cpu_220, '*FATAL CPU ERROR (PROCESS DAMAGED IN MTR MODE)'],
           [dsc$dftb_dac_cpu_221, '*FATAL CPU ERROR (DUE WITH MICROCODE HALT)'],
           [dsc$dftb_dac_cpu_222, '*FATAL CPU ERROR (NO ERROR BITS PRESENT IN STATUS SUMMARY)'],
           [dsc$dftb_dac_cpu_223, '*FATAL CPU ERROR (CONTROL STORE RELOAD FAILED)'],
           [dsc$dftb_dac_cpu_224, '*FATAL CPU ERROR (RETRIES EXHAUSTED)'],
           [dsc$dftb_dac_cpu_225, '*FATAL CPU ERROR (HALT TIMEOUT)'],
           [dsc$dftb_dac_cpu_226, '*FATAL CPU ERROR (UNEXPECTED MICROCODE HALT ADDRESS)'],
           [dsc$dftb_dac_cpu_227, '*UNCORRECTED CPU ERROR (EXCHANGE VECTOR)'],
           [dsc$dftb_dac_cpu_228, '*UNCORRECTED CPU ERROR (TRAP VECTOR)'],
           [dsc$dftb_dac_cpu_229, '*UNCORRECTED CPU ERROR (HALT VECTOR)'],
           [dsc$dftb_dac_cpu_22A, '*CLOCK ERROR'],
           [dsc$dftb_dac_cpu_22B, '*FATAL CONTROL STORE ERROR (JOB MODE)'],
           [dsc$dftb_dac_cpu_22C, '*FATAL CONTROL STORE ERROR (MONITOR MODE)'],
           [dsc$dftb_dac_cpu_22D, '*CORRECTED CPU ERROR (RETRY SUCCESSFUL)'],
           [dsc$dftb_dac_cpu_22E, '*FATAL CPU MICROCODE PARITY ERROR'],
           [dsc$dftb_dac_cpu_22F, '*NEGATIVE SIT CONDITION'],
           [dsc$dftb_dac_cpu_230, '*CPU MAC HANG'],
           [dsc$dftb_dac_cpu_231, '*CPU/MEM DEADMAN TIMEOUT'],
           [dsc$dftb_dac_cpu_232, '*CPU VECTOR DEGRADE'],
      { PAGE MAP }
           [dsc$dftb_dac_map_301, '*CORRECTED PAGE MAP ERROR'],
           [dsc$dftb_dac_map_302, '*UNCORRECTED PAGE MAP ERROR'],
      { BAD REQUESTS TO DFT }
           [dsc$dftb_dac_req_401, '*BAD RESPONSE TO AN OS REQUEST'],
           [dsc$dftb_dac_req_402, '*DFT LOGGED PROCESSOR FAILURE MESSAGE'],
           [dsc$dftb_dac_req_403, '*ERROR UPDATING THE ECR RECORD'],
           [dsc$dftb_dac_req_404, '*ERRONEOUS BIT 59 SET AND NO ERROR DETECTED'],
           [dsc$dftb_dac_req_405, '*TRANSIENT BIT 59 CONDITION'],
           [dsc$dftb_dac_req_406, '*ERROR PROCESSING THE ECR RECORD IN AN ERROR CONDITION'],
           [dsc$dftb_dac_req_407, '*EPM BOARD ERROR DATA'],
           [dsc$dftb_dac_req_408, '*EPM SYSTEM ERROR DATA'],
           [dsc$dftb_dac_req_40A, '*NEGATIVE SIT CONDITION'],
      { PACKET COMMUNICATION }
           [dsc$dftb_dac_pac_501, '*BAD PACKET RESPONSE'],
           [dsc$dftb_dac_pac_502, '*PACKET SEQUENCE NUMBER MISMATCH'],
           [dsc$dftb_dac_pac_503, '*BAD PACKET PHASE IN DFT'],
           [dsc$dftb_dac_pac_504, '*DFT/2AP INTERFACE ERROR'],
           [dsc$dftb_dac_pac_505, '*PACKET TIMEOUT CONDITION'],
           [dsc$dftb_dac_pac_507, '*PACKET REQUEST QUEUE FULL REQUEST IGNORED'],
           [dsc$dftb_dac_pac_5FF, '*SERVICE PROCESSOR INTERNAL ERROR'],
      { SOFTWARE }
           [dsc$dftb_dac_sof_601, '*SCI NOT RESPONDING'],
           [dsc$dftb_dac_sof_602, '*DFT NOT RESPONDING'],
           [dsc$dftb_dac_sof_603, '*CHANNEL 17 PARITY ERROR'],
           [dsc$dftb_dac_sof_604, '*CHANNEL 17 INTERLOCK ERROR'],
           [dsc$dftb_dac_sof_605, '*CHANNEL 17 ACTIVE'],
           [dsc$dftb_dac_sof_606, '*RESERVED'],
           [dsc$dftb_dac_sof_607, '*DFT REGISTER NUMBER NOT IN THE MRB'],
           [dsc$dftb_dac_sof_608, '*DFT MAINFRAME IDENTIFICATION ERROR'],
           [dsc$dftb_dac_sof_609, '*DFT PROCESSOR TYPE ERROR'],
           [dsc$dftb_dac_sof_60A, '*DFT FATAL STACK'],
           [dsc$dftb_dac_sof_60B, '*DFT BUILD REGISTER LIST SIZE ERROR'],
           [dsc$dftb_dac_sof_60C, '*PP LOAD ERROR'],
           [dsc$dftb_dac_sof_60D, '*170 MTR MCR FAULT - DETECTED BY EI'],
           [dsc$dftb_dac_sof_60E, '*BAD SYSTEM REQUEST - DETECTED BY EI'],
           [dsc$dftb_dac_sof_60F, '*CHANNEL 17 INACTIVE'],
           [dsc$dftb_dac_sof_610, '*SCI PRESET FAILURE'],
           [dsc$dftb_dac_sof_611, '*SCI LOADED IN PP 0'],
           [dsc$dftb_dac_sof_612, '*DFT ELEMENT DESCRIPTOR NOT IN MRT'],
           [dsc$dftb_dac_sof_613, '*DFT COMM FAILURE'],
           [dsc$dftb_dac_sof_614, '*DFT INCOMPATIBLE VERSION'],
           [dsc$dftb_dac_sof_615, '*SCI TABLE SIZE TOO SMALL'],
           [dsc$dftb_dac_sof_616, '*WALL CLOCK CHIP READ ERROR'],
           [dsc$dftb_dac_sof_617, '*NOS/VE MONITOR NOT RESPONDING'],
           [dsc$dftb_dac_sof_618, '*NO PP AVAILABLE FOR DFT'],
           [dsc$dftb_dac_sof_619, '*REGISTER LIST LENGTH GREATER THEN POINTER VALUE'],
           [dsc$dftb_dac_sof_61A, '*DFT IOU FIELD PROCESSING ERROR'],
           [dsc$dftb_dac_sof_61B, '*DFT NOT FOUND IN CIP DIRECTORY'],
           [dsc$dftb_dac_sof_61C, '*DFT SECONDARY BUFFER ERROR'],
           [dsc$dftb_dac_sof_61D, '*PRIMARY BUFFER ALLOCATION ERROR'],
           [dsc$dftb_dac_sof_61E, '*DFT INTERNAL ERROR'],
           [dsc$dftb_dac_sof_61F, '*DFT CANNOT FIND COUNTER VALUE'],
           [dsc$dftb_dac_sof_620, '*DFT CANNOT FIND THRESHOLD VALUE'],
           [dsc$dftb_dac_sof_621, '*DFT DISK STATUS LENGTH EXCEEDED'],
           [dsc$dftb_dac_sof_622, '*SCI DETECTED DFT ERROR WHILE LOADING SSR'],
           [dsc$dftb_dac_sof_623, '*SCI DETECTED DFT ERROR WHILE LOADING VCB'],
           [dsc$dftb_dac_sof_624, '*SCI DETECTED DFT ERROR WHILE HALTING 170 PROCESSOR'],
           [dsc$dftb_dac_sof_625, '*SCI DETECTED DFT ERROR WHILE STARTING VIRTUAL CPU'],
           [dsc$dftb_dac_sof_626, '*SCI DETECTED DFT ERROR WHILE IDLING SECONDARY IOU'],
           [dsc$dftb_dac_sof_627, '*SCI DETECTED DFT ERROR WHILE HALTING VIRTUAL CPU'],
           [dsc$dftb_dac_sof_628, '*SCI DETECTED DFT ERROR WHILE STARTING 170 CPU'],
           [dsc$dftb_dac_sof_629, '*SCI DETECTED DFT ERROR WHILE GETTING ELEMENT DESCR'],
           [dsc$dftb_dac_sof_62A, '*SCI DETECTED DFT NEVER SET VERIFIED FLAG'],
           [dsc$dftb_dac_sof_62B, '*SCI DETECTED DFT SET BUFFER REJECT FLAG'],
           [dsc$dftb_dac_sof_6FF, '*SERVICE PROCESSOR EXECUTIVE ERROR'],
      { OTHER }
           [dsc$dftb_dac_non_701, '*ENVIRONMENT WARNING'],
           [dsc$dftb_dac_non_702, '*LONG POWER WARNING'],
           [dsc$dftb_dac_non_703, '*SHORT POWER WARNING'],
           [dsc$dftb_dac_non_704, '*ENVIRONMENT WARNING CLEAR'],
           [dsc$dftb_dac_non_705, '*LONG POWER WARNING CLEAR'],
           [dsc$dftb_dac_non_706, '*SHORT POWER WARNING CLEAR'],
           [dsc$dftb_dac_non_707, '*TOP OF HOUR MAINFRAME ELEMENT COUNTERS BUFFER'],
           [dsc$dftb_dac_non_708, '*TOP OF HOUR SECDED ID TABLE'],
           [dsc$dftb_dac_non_709, '*LONG POWER WARNING'],
           [dsc$dftb_dac_non_70A, '*LONG POWER WARNING CLEAR']],

    v$os_action_message: [READ] ARRAY [0 .. c$number_of_os_actions] OF string (c$message_size) :=
          ['*NULL - No OS Action Required',
           '*Environment Warning',
           '*Long Power Warning',
           '*Short Power Warning',
           '*Warning Clear',
           '*Fatal IOU Error',
           '*NOS/VE IOU Error',
           '*Uncorrected CM Error',
           '*Uncorrectable CM Parity Error',
           '*Uncorrected Processor Error',
           '*C170 State OS IOU Error',
           '*System Idle/Checkpoint',
           '*System Resume (Restart)',
           '*C170 State Idle (Checkpoint)',
           '*C170 State Resume (Restart)',
           '*C180 State Idle',
           '*C180 State Resume',
           '*System Step',
           '*System Unstep',
           '*C170 State Step',
           '*C170 State Unstep',
           '*C180 State Step',
           '*C180 State Unstep',
           '*Reconfigure Mainframe Elements',
           '*Vector Degrade',
           '*Element Degrade',
           '*Flaw CM Page',
           '*Handle PP Hang',
           '*Undefined',
           '*Handle Bit 57'],

    v$priority_message: [READ] ARRAY [0 .. c$number_of_priorities] OF string (c$message_size) :=
          ['*Retry in Progress Errors',
           '*Top of Hour Logging',
           '*Corrected Errors',
           '*Uncorrected Errors',
           '*Central Processor Catastrophic Error',
           '*Environment/Long Power Warnings',
           '*Short Power Warning'];

?? OLDTITLE ??
?? NEWTITLE := 'display_data_type', EJECT ??

{ PURPOSE:
{   This procedure displays the data type.

  PROCEDURE display_data_type
    (    data_type: dst$dftb_structure_length);

    VAR
      data_string: string (osc$max_string_size),
      ignore_status: ost$status;

    CASE data_type OF
    = dsc$dftb_sbt_mrb =
      data_string := '   Data Type = Maintenance Register Buffer Data';
    = dsc$dftb_sbt_ssb =
      data_string := '   Data Type = Supportive Status Buffer Data';
    = dsc$dftb_sbt_mdb =
      data_string := '   Data Type = Model Dependent Buffer Data';
    = dsc$dftb_sbt_mec =
      data_string := '   Data Type = Mainframe Element Counter Data';
    = dsc$dftb_sbt_sit =
      data_string := '   Data Type = SECDED ID Table Data';
    = dsc$dftb_sbt_nrb =
      data_string := '   Data Type = Non Register Status Buffer Data';
    ELSE
      data_string := '   Data Type = Unknown data type';
    CASEND;
    clp$put_display (v$display_control, data_string, clc$trim, ignore_status);

  PROCEND display_data_type;
?? OLDTITLE ??
?? NEWTITLE := 'display_date_time', EJECT ??

{ PURPOSE:
{   This procedure displays the date and time.

  PROCEDURE display_date_time
    (    date_time: t$date_time);

    VAR
      date_time_string: t$date_time_string,
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      string_length: integer;

    date_time_string.data := ' ';
    IF date_time.data = 0 THEN
      date_time_string.data := 'No date or time in entry';
    ELSE
      date_time_string.month (2) := CHR ((date_time.month MOD 16) + ORD ('0'));
      date_time_string.month (1) := CHR (((date_time.month DIV 16) MOD 16) + ORD ('0'));
      date_time_string.slash_1 := '/';
      date_time_string.day (2) := CHR ((date_time.day MOD 16) + ORD ('0'));
      date_time_string.day (1) := CHR (((date_time.day DIV 16) MOD 16) + ORD ('0'));
      date_time_string.slash_2 := '/';
      date_time_string.year (2) := CHR ((date_time.year MOD 16) + ORD ('0'));
      date_time_string.year (1) := CHR (((date_time.year DIV 16) MOD 16) + ORD ('0'));
      date_time_string.spaces := ' ';
      date_time_string.hour (2) := CHR ((date_time.hour MOD 16) + ORD ('0'));
      date_time_string.hour (1) := CHR (((date_time.hour DIV 16) MOD 16) + ORD ('0'));
      date_time_string.period_1 := './';
      date_time_string.minute (2) := CHR ((date_time.minute MOD 16) + ORD ('0'));
      date_time_string.minute (1) := CHR (((date_time.minute DIV 16) MOD 16) + ORD ('0'));
      date_time_string.period_2 := './';
      date_time_string.second (2) := CHR ((date_time.second MOD 16) + ORD ('0'));
      date_time_string.second (1) := CHR (((date_time.second DIV 16) MOD 16) + ORD ('0'));
    IFEND;
    STRINGREP (display_string, string_length, '   Date/Time = ', date_time_string.data);
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

  PROCEND display_date_time;
?? OLDTITLE ??
?? NEWTITLE := 'display_dec_data', EJECT ??

{ PURPOSE:
{   This procedure displays information from the DFT Error Control Record.

  PROCEDURE display_dec_data;

    TYPE
      t$dec_cw = RECORD
        rfu: 0 .. 0ffffffff(16),
        entry_size: dst$dftb_element_size,
        number_of_elements: dst$dftb_element_size,
      RECEND,

      t$dec_data = RECORD
        rfu_1: dst$dftb_structure_length,
        element_id: dst$dftb_structure_length,
        action: dst$dftb_element_size,
        r1: dst$dftb_element_size,
        r2: dst$dftb_element_size,
        rfu_2: 0 .. 0ffffffff(16),
        corrected_threshold: dst$dftb_element_size,
        uncorrected_threshold: dst$dftb_element_size,
        m1_bit: integer,
        r1_bits: integer,
        m2_bit: integer,
        r2_bits: integer,
      RECEND;

    VAR
      action: [STATIC] ARRAY [0 .. 12(16)] OF string (c$message_size) :=
            ['Process all errors',
             'Ignore errors',
             'Freeze on any error',
             'Freeze on corrected error',
             'Freeze on uncorrected error',
             'Freeze on (R1) bit range',
             'Freeze on (R1) specific bits',
             'Freeze on (R1) bit range and (R2) bit range',
             'Freeze on (R1) bit range and (R2) specific',
             'Freeze on (R1) specific and (R2) bit range',
             'Freeze on (R1) specific and (R2) specific',
             'Ignore corrected error',
             'Ignore uncorrected error',
             'Ignore (R1) bit range',
             'Ignore (R1) specific',
             'Ignore on (R1) bit range and (R2) bit range',
             'Ignore on (R1) bit range and (R2) specific',
             'Ignore on (R1) specific and (R2) bit range',
             'Ignore on (R1) specific and (R2) specific'],
      dec_cw_p: ^t$dec_cw,
      dec_data_p: ^t$dec_data,
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      index: dst$dftb_element_size,
      leftover: dst$dftb_element_size,
      register_string: string (19),
      skip_p: ^SEQ ( * ),
      string_length: integer;

    display_header (TRUE, ' DFT ERROR CONTROL RECORD:');
    RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_dft_control_info].cell_p;
    NEXT dec_cw_p IN v$restart_file_seq_p;
    IF dec_cw_p = NIL THEN
      clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;

    FOR index := 1 TO dec_cw_p^.number_of_elements DO
      NEXT dec_data_p IN v$restart_file_seq_p;
      IF dec_data_p = NIL THEN
        clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
        RETURN;  {---->
      IFEND;
      clp$put_display (v$display_control, v$dash, clc$trim, ignore_status);

      display_element_type (dec_data_p^.element_id);
      IF (dec_data_p^.action >= LOWERBOUND (action)) AND (dec_data_p^.action <= UPPERBOUND (action)) THEN
        STRINGREP (display_string, string_length, '   Action = ', action [dec_data_p^.action]);
      ELSE
        STRINGREP (display_string, string_length, '   Action = ', dec_data_p^.action);
      IFEND;
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

      STRINGREP (display_string, string_length,
            '   Maintenance register number associated with (R1) bit mask = ', dec_data_p^.r1);
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
      STRINGREP (display_string, string_length,
            '   Maintenance register number associated with (R2) bit mask = ', dec_data_p^.r2);
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

      STRINGREP (display_string, string_length, '   Corrected Threshold = ', dec_data_p^.corrected_threshold);
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
      STRINGREP (display_string, string_length, '   Uncorrected Threshold = ',
            dec_data_p^.uncorrected_threshold);
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

      retrieve_register_string (dec_data_p^.m1_bit, register_string);
      STRINGREP (display_string, string_length, '   M1 Bit Mask Field = ', register_string);
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
      retrieve_register_string (dec_data_p^.r1_bits, register_string);
      STRINGREP (display_string, string_length, '   R1 Bits To Select = ', register_string);
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
      retrieve_register_string (dec_data_p^.m2_bit, register_string);
      STRINGREP (display_string, string_length, '   M2 Bit Mask Field = ', register_string);
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
      retrieve_register_string (dec_data_p^.r2_bits, register_string);
      STRINGREP (display_string, string_length, '   R2 Bits To Select = ', register_string);
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

      IF (#SIZE (dec_data_p^) * 8) < dec_cw_p^.entry_size THEN
        leftover := dec_cw_p^.entry_size - (#SIZE (dec_data_p^) * 8);
        NEXT skip_p: [[REP leftover OF integer]] IN v$restart_file_seq_p;
        IF skip_p = NIL THEN
          clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
          RETURN;  {---->
        IFEND;
      IFEND;
    FOREND;

  PROCEND display_dec_data;
?? OLDTITLE ??
?? NEWTITLE := 'display_dft_control_word', EJECT ??

{ PURPOSE:
{   This procedure will display information in the DFT buffer control word.

  PROCEDURE display_dft_control_word
    (    secondary_dft: boolean);

    VAR
      dftb_cw_p: ^dst$dftb_control_word,
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      string_length: integer;

    IF NOT secondary_dft THEN
      RESET v$restart_file_seq_p TO v$data.buffer [duc$dft_cw].cell_p;
      display_header (TRUE, ' DFT BUFFER CONTROL WORD:');
    IFEND;

    NEXT dftb_cw_p IN v$restart_file_seq_p;
    IF dftb_cw_p = NIL THEN
      clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;

    STRINGREP (display_string, string_length, '   Number of Pointer Words = ', dftb_cw_p^.pointer_words,
          '(10)');
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
    STRINGREP (display_string, string_length, '   Next sequence number = ',
          dftb_cw_p^.sequence_number: #(16), '(16)');
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
    STRINGREP (display_string, string_length, '   Interface Revision Level = ',
          dftb_cw_p^.revision_level: #(16), '(16)');
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
    STRINGREP (display_string, string_length, '   DFT Hardware Logical PP Number = ',
          dftb_cw_p^.dft_pp_number, '(10)');
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
    STRINGREP (display_string, string_length, '   Length of each Maintenance Register Buffer = ',
          dftb_cw_p^.mrb_length, '(10) cm words');
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
    STRINGREP (display_string, string_length, '   Number of Maintenance Register Buffers = ',
          dftb_cw_p^.number_of_mrbs, '(10) (including scratch buffer)');
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

    clp$put_display (v$display_control, '   Flags Indicate:', clc$trim, ignore_status);
    IF dftb_cw_p^.c170_error THEN
      clp$put_display (v$display_control, '     C170 Errors exist in buffers to be processed (E7)',
            clc$trim, ignore_status);
    IFEND;
    IF dftb_cw_p^.c180_error THEN
      clp$put_display (v$display_control, '     C180 Errors exist in buffers to be processed (E8)',
            clc$trim, ignore_status);
    IFEND;
    IF dftb_cw_p^.non_dedicated_mode THEN
      clp$put_display (v$display_control,
            '     DFT was running in Non-Dedicated Mode when dump was taken (D)', clc$trim, ignore_status);
    ELSE
      clp$put_display (v$display_control, '     DFT was running in Dedicated Mode when dump was taken (D)',
            clc$trim, ignore_status);
    IFEND;
    IF dftb_cw_p^.nos_logging_errors THEN
      clp$put_display (v$display_control, '     NOS or NOS/BE logging mainframe errors at time of dump (L)',
            clc$trim, ignore_status);
    ELSE
      clp$put_display (v$display_control, '     NOS/VE logging mainframe errors at time of dump (L)',
            clc$trim, ignore_status);
    IFEND;
    IF dftb_cw_p^.c170_dedicated THEN
      clp$put_display (v$display_control,
            '     DFT should run in non dedicated mode when NOS/VE is not running (C)',
            clc$trim, ignore_status);
    ELSE
      clp$put_display (v$display_control,
            '     DFT should run in dedicated mode when NOS/VE is not running (C)', clc$trim, ignore_status);
    IFEND;
    IF dftb_cw_p^.zero_counters_and_secded THEN
      clp$put_display (v$display_control, '     Set counters and SECDED ID Table to zero (Z)',
            clc$trim, ignore_status);
    IFEND;
    IF dftb_cw_p^.dft_reject THEN
      clp$put_display (v$display_control, '     DFT does not recognize the version level set (R)',
            clc$trim, ignore_status);
    IFEND;
    IF dftb_cw_p^.dft_verification THEN
      clp$put_display (v$display_control, '     DFT has verified the interface version level (V)',
            clc$trim, ignore_status);
    ELSE
      clp$put_display (v$display_control, '     DFT has NOT verified the interface version level (V)',
            clc$trim, ignore_status);
    IFEND;
    IF dftb_cw_p^.uncorrected_error_freeze THEN
      clp$put_display (v$display_control, '     Freeze System on Uncorrected Error (FU)',
            clc$trim, ignore_status);
    IFEND;
    IF dftb_cw_p^.corrected_error_freeze THEN
      clp$put_display (v$display_control, '     Freeze System on Corrected Error (FC)',
            clc$trim, ignore_status);
    IFEND;
    IF dftb_cw_p^.idle_dft THEN
      clp$put_display (v$display_control, '     Idle DFT Flag set (T)', clc$trim, ignore_status);
    IFEND;
    IF dftb_cw_p^.logging_transaction THEN
      clp$put_display (v$display_control, '     Logging Transaction Flag set (LT)', clc$trim, ignore_status);
    IFEND;
    IF NOT secondary_dft THEN
      display_trailer;
    IFEND;

  PROCEND display_dft_control_word;
?? OLDTITLE ??
?? NEWTITLE := 'display_element_type', EJECT ??

{ PURPOSE:
{   This procedure displays the element type.

  PROCEDURE display_element_type
    (    element_number: dst$dftb_structure_length);

    VAR
      element_string: string (osc$max_string_size),
      ignore_status: ost$status;

    CASE element_number OF
    = dsc$dftb_eid_cpu0_element =
      element_string := '   Element ID = CPU 0';
    = dsc$dftb_eid_cpu1_element =
      element_string := '   Element ID = CPU 1';
    = dsc$dftb_eid_memory_element =
      element_string := '   Element ID = CENTRAL MEMORY';
    = dsc$dftb_eid_iou0_element =
      element_string := '   Element ID = IOU 0';
    = dsc$dftb_eid_iou1_element =
      element_string := '   Element ID = IOU 1';
    = dsc$dftb_eid_page_map_element =
      element_string := '   Element ID = PAGE MAP';
    = dsc$dftb_eid_no_known_element =
      element_string := '   Element ID = DFT INTERNAL';
    ELSE
      element_string := '   Element ID = UNKNOWN ELEMENT';
    CASEND;
    clp$put_display (v$display_control, element_string, clc$trim, ignore_status);

  PROCEND display_element_type;
?? OLDTITLE ??
?? NEWTITLE := 'display_fault_symptom_code', EJECT ??

{ PURPOSE:
{   This procedure displays the fault symptom code.

  PROCEDURE display_fault_symptom_code
    (    fault_symptom_code: t$fault_symptom_code);

    VAR
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      index: 1 .. 12,
      local_fault_symptom_code: t$fault_symptom_code,
      string_length: integer;

    local_fault_symptom_code := fault_symptom_code;
    FOR index := 1 TO 12 DO
      IF local_fault_symptom_code.code_array [index] = 0 THEN
        local_fault_symptom_code.code (index) := ' ';
      IFEND;
    FOREND;
    STRINGREP (display_string, string_length, '   Fault Symptom Code = ', local_fault_symptom_code.code);
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

  PROCEND display_fault_symptom_code;
?? OLDTITLE ??
?? NEWTITLE := 'display_header', EJECT ??

{ PURPOSE:
{   This procedure displays a header on the output file.

  PROCEDURE display_header
    (    small_header: boolean;
         title: string ( * ));

    VAR
      ignore_status: ost$status;

    IF small_header THEN
      clp$put_display (v$display_control, ' ', clc$trim, ignore_status);
      clp$put_display (v$display_control, v$star, clc$trim, ignore_status);
      clp$put_display (v$display_control, title, clc$trim, ignore_status);
    ELSE
      clp$put_display (v$display_control, ' ', clc$trim, ignore_status);
      clp$put_display (v$display_control, v$star, clc$trim, ignore_status);
      clp$put_display (v$display_control, title, clc$trim, ignore_status);
      clp$put_display (v$display_control, v$star, clc$trim, ignore_status);
      clp$put_display (v$display_control, ' ', clc$trim, ignore_status);
    IFEND;

  PROCEND display_header;
?? OLDTITLE ??
?? NEWTITLE := 'display_mdb_data', EJECT ??

{ PURPOSE:
{   This procedure displays the information for one of the Model Dependent Buffers.

  PROCEDURE display_mdb_data
    (    index: 0 .. duc$dft_max_mdb_buffers);

    TYPE
      t$mdb_sub_header = RECORD
        length_of_data: 0 .. 0ffff(16),
        rfu: 0 .. 0ffff(16),
        pfs_error_id: 0 .. 0ffff(16),
        data_header_id: 0 .. 0ffff(16),
      RECEND;

    VAR
      data_size: dst$dftb_element_size,
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      index_2: dst$dftb_element_size,
      integer_p: ^integer,
      mdb_cw_p: ^t$mdb_control_word,
      mdb_shw_p: ^t$mdb_sub_header,
      register_string: string (19),
      skip_p: ^SEQ ( * ),
      string_length: integer,
      sub_area_size: dst$dftb_element_size,
      titles: [STATIC] ARRAY [1 .. 0a(16)] OF string (80) :=
            ['     Sub Header ID = 01 = Soft Control Memory (SCM) Parity Error Data',
             '     Sub Header ID = 02 = CPU Capture Buffer',
             '     Sub Header ID = 03 = History File',
             '     Sub Header ID = 04 = Exchange Package',
             '     Sub Header ID = 05 = Current P address and surrounding instructions',
             '     Sub Header ID = 06 = Executing words of soft control memory',
             '     Sub Header ID = 07 = Retry Information',
             '     Sub Header ID = 08 = Soft Registers',
             '     Sub Header ID = 09 = Register File',
             '     Sub Header ID = 0A = Error During MDB Logging'];

    RESET v$restart_file_seq_p TO v$data.mdb [index].cell_p;
    NEXT mdb_cw_p IN v$restart_file_seq_p;
    IF mdb_cw_p = NIL THEN
      clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;

    STRINGREP (display_string, string_length, ' MODEL DEPENDENT BUFFER  (buffer # =',
          (index - 1), '(10)):');
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

    STRINGREP (display_string, string_length, '   SEQUENCE NUMBER = ', mdb_cw_p^.sequence_number: #(16),
          '(16)');
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

    IF mdb_cw_p^.long_term_interlock_flag = 1 THEN
      STRINGREP (display_string, string_length, '   Long Term Interlock Flag = 1(10) (first error)');
    ELSEIF mdb_cw_p^.long_term_interlock_flag = 9 THEN
      STRINGREP (display_string, string_length, '   Long Term Interlock Flag = 9(10) (overwritten)');
    ELSE
      STRINGREP (display_string, string_length, '   Long Term Interlock Flag = ',
            mdb_cw_p^.long_term_interlock_flag, '(10)');
    IFEND;
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

    STRINGREP (display_string, string_length, '   MRB Control Word Index = ',
          mdb_cw_p^.control_word_offset, '(10)');
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

    IF mdb_cw_p^.priority = 1 THEN
      STRINGREP (display_string, string_length, '   Priority = 1 = Retry in Progress (lowest priority)');
    ELSEIF mdb_cw_p^.priority = 2 THEN
      STRINGREP (display_string, string_length, '   Priority = 2 = Other Uncorrected Errors');
    ELSEIF mdb_cw_p^.priority = 3 THEN
      STRINGREP (display_string, string_length, '   Priority = 3 = Issue Timeout (highest priority)');
    ELSE
      STRINGREP (display_string, string_length, '   Priority = ', mdb_cw_p^.priority);
    IFEND;
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

    data_size := mdb_cw_p^.length_to_log;
    STRINGREP (display_string, string_length, '   Total Length to Log = ', data_size, '(10) cm words');
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

    IF data_size > 0 THEN
      data_size := data_size - 1;
    IFEND;

   /display_sub_area/
    WHILE data_size > 0 DO
      NEXT mdb_shw_p IN v$restart_file_seq_p;
      IF mdb_shw_p = NIL THEN
        clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
        RETURN;  {---->
      IFEND;
      data_size := data_size - 1;
      clp$put_display (v$display_control, v$dash, clc$trim, ignore_status);
      clp$put_display (v$display_control, '   MDB SUB HEADER WORD:', clc$trim, ignore_status);

      sub_area_size := mdb_shw_p^.length_of_data - 1;
      data_size := data_size - sub_area_size;
      STRINGREP (display_string, string_length, '     Sub Area Length = ', mdb_shw_p^.length_of_data,
            '(10) cm words');
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

      STRINGREP (display_string, string_length, '     PFS Error ID = ', mdb_shw_p^.pfs_error_id: #(16),
            '(16)');
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

      IF (mdb_shw_p^.data_header_id = 2) AND NOT v$display_capture_buffer THEN
        NEXT skip_p: [[REP sub_area_size OF integer]] IN v$restart_file_seq_p;
        IF skip_p = NIL THEN
          clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
          RETURN;  {---->
        IFEND;
        CYCLE /display_sub_area/;  {---->
      IFEND;

      IF (mdb_shw_p^.data_header_id >= LOWERBOUND (titles)) AND
            (mdb_shw_p^.data_header_id <= UPPERBOUND (titles)) THEN
        clp$put_display (v$display_control, titles [mdb_shw_p^.data_header_id], clc$trim, ignore_status);
      ELSE
        clp$put_display (v$display_control, '     Sub Header ID = ?? = Unknown Header Id', clc$trim,
              ignore_status);
      IFEND;
      clp$put_display (v$display_control, '     Sub Buffer Data:', clc$trim, ignore_status);

      CASE mdb_shw_p^.data_header_id OF
      = 5 =
        display_mdb_p_address (sub_area_size);
      = 6 =
        display_mdb_scm_executing_words (sub_area_size);
      = 7, 9 =
        FOR index_2 := 1 TO sub_area_size DO
          NEXT integer_p IN v$restart_file_seq_p;
          IF integer_p = NIL THEN
            clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
            RETURN;  {---->
          IFEND;
          retrieve_register_string (integer_p^, register_string);
          STRINGREP (display_string, string_length, '       ', register_string);
          clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
        FOREND;
      = 8 =
        display_mdb_soft_registers (sub_area_size);
      ELSE
        print_raw_data (sub_area_size);
      CASEND;
    WHILEND;

  PROCEND display_mdb_data;
?? OLDTITLE ??
?? NEWTITLE := 'display_mdb_p_address', EJECT ??

{ PURPOSE:
{   This procedure displays the P address information from the Model Dependent Buffer.

  PROCEDURE display_mdb_p_address
    (    buffer_size: dst$dftb_element_size);

    VAR
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      index: dst$dftb_element_size,
      integer_p: ^integer,
      line: t$descriptor_line,
      string_length: integer,
      titles: [STATIC] ARRAY [1 .. 14] OF string (38) :=
            ['Segment Table Entry',
             'Page Table Entry',
             'Second Page Table Entry',
             '5 Instructions Before P',
             ' ',
             ' ',
             ' ',
             ' ',
             'Instruction at P',
             '5 Instructions After P',
             ' ',
             ' ',
             ' ',
             ' '];

    FOR index := 1 TO buffer_size DO
      line.data := ' ';
      NEXT integer_p IN v$restart_file_seq_p;
      IF integer_p = NIL THEN
        clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
        RETURN;  {---->
      IFEND;
      retrieve_register_string (integer_p^, line.register_string);
      line.description := titles [index];
      STRINGREP (display_string, string_length, '       ', line.data);
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
    FOREND;

  PROCEND display_mdb_p_address;
?? OLDTITLE ??
?? NEWTITLE := 'display_mdb_scm_executing_words', EJECT ??

{ PURPOSE:
{   This procedure displays the Executing Words of the Soft Control Memories from the Model Dependent Buffer.

  PROCEDURE display_mdb_scm_executing_words
    (    buffer_size: dst$dftb_element_size);

    VAR
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      index: dst$dftb_element_size,
      integer_p: ^integer,
      line: t$descriptor_line,
      string_length: integer,
      titles: [STATIC] ARRAY [1 .. 23] OF string (38) :=
            ['Current Instruction Register',
             ' ',
             ' ',
             ' ',
             'ACU.M2',
             'ACU.M3',
             'ACU.M4',
             'BDP',
             ' ',
             'EPN',
             'EPN Error Information Table',
             'Control Store',
             ' ',
             ' ',
             ' ',
             'Control Word',
             ' ',
             ' ',
             ' ',
             'Instruction Map',
             'Instruction Buffer Stack',
             'LSU',
             'SVA.BN'];

    FOR index := 1 TO buffer_size DO
      line.data := ' ';
      NEXT integer_p IN v$restart_file_seq_p;
      IF integer_p = NIL THEN
        clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
        RETURN;  {---->
      IFEND;
      retrieve_register_string (integer_p^, line.register_string);
      line.description := titles [index];
      STRINGREP (display_string, string_length, '       ', line.data);
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
    FOREND;

  PROCEND display_mdb_scm_executing_words;
?? OLDTITLE ??
?? NEWTITLE := 'display_mdb_soft_registers', EJECT ??

{ PURPOSE:
{   This procedure displays the Soft Register information from the Model Dependent Buffer.

  PROCEDURE display_mdb_soft_registers
    (    buffer_size: dst$dftb_element_size);

    VAR
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      index: dst$dftb_element_size,
      integer_p: ^integer,
      line: t$descriptor_line,
      string_length: integer,
      titles: [STATIC] ARRAY [1 .. 27] OF string (38) :=
            ['Virtual Machine Capability',
             'Program Address',
             'MPS Pointer',
             'MCR',
             'UCR',
             'UTP',
             'STL',
             'STA',
             'Base Constant',
             'PTA',
             'PTL',
             'PSM',
             'Model Dependent Flags',
             'MM',
             'JPS Pointer',
             'SIT',
             'Kypt Buffer Pointer',
             'TE',
             'Trap Pointer',
             'Debug List Pointer',
             'Kypt Mask',
             'PIT',
             'CFF',
             'OCF',
             'Debug Index',
             'Debug Mask',
             'UM'];

    FOR index := 1 TO buffer_size DO
      line.data := ' ';
      NEXT integer_p IN v$restart_file_seq_p;
      IF integer_p = NIL THEN
        clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
        RETURN;  {---->
      IFEND;
      retrieve_register_string (integer_p^, line.register_string);
      line.description := titles [index];
      STRINGREP (display_string, string_length, '       ', line.data);
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
    FOREND;

  PROCEND display_mdb_soft_registers;
?? OLDTITLE ??
?? NEWTITLE := 'display_mec_data', EJECT ??

{ PURPOSE:
{   This procedure displays the Mainframe Element Counter Buffer information.

  PROCEDURE display_mec_data
    (    full_display: boolean);

    TYPE
      t$line = RECORD
        CASE boolean OF
        = TRUE =
          spaces: string (2),
          element_id: string (19),
          uet: string (13),
          cet: string (11),
          ulec: string (10),
          cec: string (11),
          uec: string (11),
        = FALSE =
          data: string (77),
        CASEND,
      RECEND;

    VAR
      element_id: string (2),
      ignore_status: ost$status,
      index: dst$dftb_element_size,
      integer_p: ^integer,
      line: t$line,
      register_string: string (19);

    IF full_display THEN
      display_header (TRUE, ' CURRENT MAINFRAME ELEMENT COUNTER BUFFER:');
      RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_mec].cell_p;
    IFEND;
    line.data := ' ';
    line.element_id := 'Element ID';
    line.uet := 'Uncorrected';
    line.cet := 'Corrected';
    line.ulec := 'Unlogged';
    line.cec := 'Corrected';
    line.uec := 'Uncorrected';
    clp$put_display (v$display_control, line.data, clc$trim, ignore_status);
    line.data := ' ';
    line.uet := 'Error';
    line.cet := 'Error';
    line.ulec := 'Error';
    line.cec := 'Error';
    line.uec := 'Error';
    clp$put_display (v$display_control, line.data, clc$trim, ignore_status);
    line.data := ' ';
    line.uet := 'Threshold';
    line.cet := 'Threshold';
    line.ulec := 'Counter';
    line.cec := 'Counter';
    line.uec := 'Counter';
    clp$put_display (v$display_control, line.data, clc$trim, ignore_status);

    FOR index := 1 TO v$data.buffer [dsc$dftb_rpw_mec].size DO
      line.data := ' ';
      NEXT integer_p IN v$restart_file_seq_p;
      IF integer_p = NIL THEN
        clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
        RETURN;  {---->
      IFEND;
      retrieve_register_string (integer_p^, register_string);
      IF full_display THEN
        element_id := register_string (1, 2);
      ELSE
        element_id := register_string (3, 2);
      IFEND;
      IF element_id = '00' THEN
        line.element_id := '00=CPU 0';
      ELSEIF element_id = '10' THEN
        line.element_id := '10=CPU 1';
      ELSEIF element_id = '01' THEN
        line.element_id := '01=CENTRAL MEMORY';
      ELSEIF element_id = '02' THEN
        line.element_id := '02=IOU 0';
      ELSEIF element_id = '12' THEN
        line.element_id := '12=IOU 1';
      ELSEIF element_id = '03' THEN
        line.element_id := '03=PAGE MAP';
      ELSEIF element_id = '04' THEN
        line.element_id := '04=DFT INTERNAL';
      ELSE
        line.element_id (1, 2) := element_id;
        line.element_id (3, *) := '=UNKNOWN';
      IFEND;
      IF full_display THEN
        line.uet (6) := register_string (3);
        line.cet (5) := register_string (4);
      ELSE
        line.uet (5, 3) := 'N/A';
        line.cet (4, 3) := 'N/A';
      IFEND;
      line.ulec (3, 4) := register_string (6, 4);
      line.cec (3, 4) := register_string (11, 4);
      line.uec (4, 4) := register_string (16, 4);
      clp$put_display (v$display_control, line.data, clc$trim, ignore_status);
    FOREND;

    IF full_display THEN
      display_trailer;
    IFEND;

  PROCEND display_mec_data;
?? OLDTITLE ??
?? NEWTITLE := 'display_memory_size', EJECT ??

{ PURPOSE:
{   This procedure displays the memory size from the options installed register.

  PROCEDURE display_memory_size;

    TYPE
      t$bit_or_byte = PACKED RECORD
        CASE boolean OF
        = TRUE =
          byte_part: ARRAY [1 .. 2] OF 0 .. 0ff(16),
        = FALSE =
          bit_part: PACKED ARRAY [0 .. 15] OF boolean,
        CASEND,
      RECEND;

    VAR
      bit_or_byte: t$bit_or_byte,
      dump_information: dut$dump_information,
      register: dut$de_maintenance_register;

    dup$determine_dump_information (dump_information);
    IF dump_information.iou [0].model = duc$di_im_i0_5x THEN
      dup$retrieve_register (duc$de_iou, 0, 12(16), register);
      IF register.available THEN
        IF register.value [3] = 80(16) THEN
          display_header (TRUE, ' Physical Memory Size:  8 MB');
        ELSEIF register.value [3] = 84(16) THEN
          display_header (TRUE, ' Physical Memory Size:  16 MB');
        ELSEIF register.value [3] = 0c4(16) THEN
          display_header (TRUE, ' Physical Memory Size:  32 MB');
        ELSEIF register.value [3] = 0e4(16) THEN
          display_header (TRUE, ' Physical Memory Size:  48 MB');
        ELSEIF (register.value [3] = 0f4(16)) OR (register.value [3] = 8c(16)) THEN
          display_header (TRUE, ' Physical Memory Size:  64 MB');
        ELSEIF register.value [3] = 0cc(16) THEN
          display_header (TRUE, ' Physical Memory Size:  128 MB');
        ELSE
          display_header (TRUE, ' Physical Memory Size:  Unknown');
        IFEND;
      ELSE
        display_header (TRUE, ' Physical Memory Size:  Unknown');
      IFEND;
      display_trailer;
      RETURN;  {---->
    IFEND;

    dup$retrieve_register (duc$de_memory, 0, 12(16), register);
    IF register.available THEN
      bit_or_byte.byte_part [1] := register.value [1];
      bit_or_byte.byte_part [2] := register.value [2];
      IF bit_or_byte.bit_part [12] THEN
        IF bit_or_byte.bit_part [0] THEN
          display_header (TRUE, ' Physical Memory Size:  2048 MB');
        ELSEIF bit_or_byte.bit_part [1] THEN
          display_header (TRUE, ' Physical Memory Size:  1024 MB');
        ELSEIF bit_or_byte.bit_part [2] THEN
          display_header (TRUE, ' Physical Memory Size:  512 MB');
        ELSEIF bit_or_byte.bit_part [3] THEN
          display_header (TRUE, ' Physical Memory Size:  256 MB');
        ELSEIF bit_or_byte.bit_part [4] THEN
          display_header (TRUE, ' Physical Memory Size:  128 MB');
        ELSEIF bit_or_byte.bit_part [5] THEN
          display_header (TRUE, ' Physical Memory Size:  64 MB');
        ELSEIF bit_or_byte.bit_part [6] THEN
          display_header (TRUE, ' Physical Memory Size:  32 MB');
        ELSEIF bit_or_byte.bit_part [7] THEN
          display_header (TRUE, ' Physical Memory Size:  16 MB');
        ELSEIF bit_or_byte.bit_part [8] THEN
          display_header (TRUE, ' Physical Memory Size:  8 MB');
        ELSEIF bit_or_byte.bit_part [9] THEN
          display_header (TRUE, ' Physical Memory Size:  4 MB');
        ELSEIF bit_or_byte.bit_part [10] THEN
          display_header (TRUE, ' Physical Memory Size:  2 MB');
        ELSEIF bit_or_byte.bit_part [11] THEN
          display_header (TRUE, ' Physical Memory Size:  1 MB');
        ELSE
          display_header (TRUE, ' Physical Memory Size:  Unknown');
        IFEND;
      ELSE
        IF bit_or_byte.bit_part [0] THEN
          display_header (TRUE, ' Physical Memory Size:  1 MB');
        ELSEIF bit_or_byte.bit_part [1] THEN
          display_header (TRUE, ' Physical Memory Size:  2 MB');
        ELSEIF bit_or_byte.bit_part [2] THEN
          display_header (TRUE, ' Physical Memory Size:  3 MB');
        ELSEIF bit_or_byte.bit_part [3] THEN
          display_header (TRUE, ' Physical Memory Size:  4 MB');
        ELSEIF bit_or_byte.bit_part [4] THEN
          display_header (TRUE, ' Physical Memory Size:  5 MB');
        ELSEIF bit_or_byte.bit_part [5] THEN
          display_header (TRUE, ' Physical Memory Size:  6 MB');
        ELSEIF bit_or_byte.bit_part [6] THEN
          display_header (TRUE, ' Physical Memory Size:  7 MB');
        ELSEIF bit_or_byte.bit_part [7] THEN
          display_header (TRUE, ' Physical Memory Size:  8 MB');
        ELSEIF bit_or_byte.bit_part [8] THEN
          display_header (TRUE, ' Physical Memory Size:  10 MB');
        ELSEIF bit_or_byte.bit_part [9] THEN
          display_header (TRUE, ' Physical Memory Size:  12 MB');
        ELSEIF bit_or_byte.bit_part [10] THEN
          display_header (TRUE, ' Physical Memory Size:  14 MB');
        ELSEIF bit_or_byte.bit_part [11] THEN
          display_header (TRUE, ' Physical Memory Size:  16 MB');
        ELSE
          display_header (TRUE, ' Physical Memory Size:  Unknown');
        IFEND;
      IFEND;
      display_trailer;
    ELSE
      display_header (TRUE, ' Physical Memory Size:  Unknown');
      display_trailer;
    IFEND;

  PROCEND display_memory_size;
?? OLDTITLE ??
?? NEWTITLE := 'display_mrb_data', EJECT ??

{ PURPOSE:
{   This procedure displays the information from the Mainframe Element Buffers.

  PROCEDURE display_mrb_data;

    VAR
      date_time_p: ^t$date_time,
      display_first_header: boolean,
      display_string: string (osc$max_string_size),
      fault_symptom_code_p: ^t$fault_symptom_code,
      first_time: boolean,
      ignore_status: ost$status,
      index: dst$dftb_element_size,
      index_2: dst$dftb_element_size,
      index_3: dst$dftb_element_size,
      line: t$descriptor_line,
      mdb_cw_p: ^t$mdb_control_word,
      mrb_cw_p: ^ARRAY [0 .. *] OF dst$dftb_buffer_control_word,
      mrb_p: ^ARRAY [1 .. *] OF dst$dftb_maintenance_registers,
      register_string: string (19),
      save_sorted: t$sorted,
      skip_p: ^SEQ ( * ),
      sorted_p: ^ARRAY [1 .. *] OF t$sorted,
      sorted_size: dst$dftb_element_size,
      ssb_hw_p: ^dst$dftb_buffer_header_word,
      ssb_integer_p: ^integer,
      ssb_iw_p: ^dst$dftb_ssb_information_word,
      string_2: string (2),
      string_length: integer,
      titles: [STATIC] ARRAY [1 .. 3] OF string (38) :=
            ['Control Store Address Before DFT Halt',
             'Control Store Address After DFT Halt',
             'Status Summary Register'];

    display_header (TRUE, ' MRB and SSB Scratch Buffer:');
    clp$put_display (v$display_control, ' Scratch Maintenance Register Buffer Control Word:', clc$trim,
          ignore_status);
    RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_mrb_cw].cell_p;
    print_raw_data (1);
    clp$put_display (v$display_control, v$dash, clc$trim, ignore_status);
    clp$put_display (v$display_control, ' Scratch Maintenance Register Buffer:', clc$trim, ignore_status);
    RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_mrb].cell_p;
    print_raw_data (v$data.mrb_length);
    clp$put_display (v$display_control, v$dash, clc$trim, ignore_status);
    clp$put_display (v$display_control, ' Scratch Supportive Status Buffer:', clc$trim, ignore_status);
    RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_ssb].cell_p;
    NEXT ssb_hw_p IN v$restart_file_seq_p;
    IF ssb_hw_p = NIL THEN
      clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;
    print_raw_data (ssb_hw_p^.buffer_size);

    RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_mrb_cw].cell_p;
    NEXT mrb_cw_p: [0 .. v$data.buffer [dsc$dftb_rpw_mrb_cw].size] IN v$restart_file_seq_p;
    IF mrb_cw_p = NIL THEN
      clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;
    sorted_size := v$data.buffer [dsc$dftb_rpw_mrb_cw].size - 1;
    PUSH sorted_p: [1 .. sorted_size];

    { Sort the control words into descending order by sequence number.  The scratch buffer is skipped.

    FOR index := 1 TO sorted_size DO
      sorted_p^ [index].sequence := mrb_cw_p^ [index].sequence_number;
      sorted_p^ [index].index := index;
    FOREND;
    FOR index := 1 TO (sorted_size - 1) DO
      FOR index_2 := (index + 1) TO sorted_size DO
        IF sorted_p^ [index].sequence < sorted_p^ [index_2].sequence THEN
          save_sorted := sorted_p^ [index];
          sorted_p^ [index] := sorted_p^ [index_2];
          sorted_p^ [index_2] := save_sorted;
        IFEND;
      FOREND;
    FOREND;

    FOR index := 1 TO duc$dft_max_mdb_buffers DO
      v$data.mdb [index].used := FALSE;
    FOREND;

    { Display the data.

    display_first_header := TRUE;
    FOR index := 1 TO sorted_size DO
      IF sorted_p^ [index].sequence <> 0 THEN
        IF display_first_header THEN
          display_header (TRUE, ' MRB/SSB/MDB Data; listed in descending sequence number order.');
          display_first_header := FALSE;
        IFEND;

        STRINGREP (display_string, string_length, ' MAINTENANCE REGISTER BUFFER CONTROL WORD  (buffer # =',
              sorted_p^ [index].index, '(10)):');
        display_header (TRUE, display_string (1, string_length));

        display_mrb_nrb_control_word (mrb_cw_p^ [sorted_p^ [index].index]);

        STRINGREP (display_string, string_length,
              '   Offset of the associated Maintenance Register Buffer = ',
              mrb_cw_p^ [sorted_p^ [index].index].offset: #(16), '(16)');
        clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

        clp$put_display (v$display_control, ' MAINTENANCE REGISTER BUFFER:', clc$trim, ignore_status);

        RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_mrb].cell_p;
        NEXT skip_p: [[REP (sorted_p^ [index].index * v$data.mrb_length) OF integer]] IN
              v$restart_file_seq_p;
        IF skip_p = NIL THEN
          clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
          RETURN;  {---->
        IFEND;
        NEXT mrb_p: [1 .. (v$data.mrb_length DIV dsc$dftb_mr_group_size)] IN v$restart_file_seq_p;
        IF mrb_p = NIL THEN
          clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
          RETURN;  {---->
        IFEND;
        first_time := TRUE;

       /display_registers/
        FOR index_2 := 1 TO (v$data.mrb_length DIV dsc$dftb_mr_group_size) DO
          FOR index_3 := 1 TO dsc$dftb_mr_number_of_registers DO
            IF mrb_p^ [index_2].register_header [index_3].register_number = 0 THEN
              IF NOT first_time THEN
                EXIT /display_registers/;  {---->
              ELSE
                first_time := FALSE;
              IFEND;
            IFEND;
            string_2 := 'XX';
            clp$convert_integer_to_rjstring (mrb_p^ [index_2].register_header [index_3].register_number,
                  16, FALSE, '0', string_2, ignore_status);
            retrieve_register_string (mrb_p^ [index_2].register_list [index_3], register_string);
            STRINGREP (display_string, string_length, '   ', string_2, '  ', register_string);
            clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
          FOREND;
        FOREND /display_registers/;

        clp$put_display (v$display_control, ' SUPPORTIVE STATUS BUFFER:', clc$trim, ignore_status);

        RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_ssb].cell_p;
        NEXT ssb_hw_p IN v$restart_file_seq_p;
        IF ssb_hw_p = NIL THEN
          clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
          RETURN;  {---->
        IFEND;
        NEXT skip_p: [[REP (sorted_p^ [index].index * ssb_hw_p^.buffer_size) OF integer]] IN
              v$restart_file_seq_p;
        IF skip_p = NIL THEN
          clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
          RETURN;  {---->
        IFEND;
        NEXT ssb_iw_p IN v$restart_file_seq_p;
        IF ssb_iw_p = NIL THEN
          clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
          RETURN;  {---->
        IFEND;

        display_element_type (ssb_iw_p^.element_number);

        display_data_type (ssb_iw_p^.mrb_type);

        STRINGREP (display_string, string_length, '   SSB Data Length to Log = ',
              ssb_iw_p^.data_length_to_log, '(10) cm words');
        clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

        IF ssb_iw_p^.unlogged = 1 THEN
          clp$put_display (v$display_control,
                '   Unlogged MDB condition - An MDB buffer could not be obtained', clc$trim, ignore_status);
        ELSEIF ssb_iw_p^.unlogged = 2 THEN
          clp$put_display (v$display_control,
                '   Unlogged MDB condition - The MDB buffer was overwritten by a higher priority error',
                clc$trim, ignore_status);
        IFEND;

        IF mrb_cw_p^ [sorted_p^ [index].index].flags.valid_mdb_data THEN
          STRINGREP (display_string, string_length, '   Ordinal of Associated MDB Buffer = ',
                ssb_iw_p^.mdb_ordinal);
          clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
        IFEND;

        STRINGREP (display_string, string_length, '   Logged MRB Size = ', ssb_iw_p^.logged_mrb_size,
              '(10) cm words');
        clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

        NEXT date_time_p IN v$restart_file_seq_p;
        IF date_time_p = NIL THEN
          clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
          RETURN;  {---->
        IFEND;
        display_date_time (date_time_p^);

        NEXT fault_symptom_code_p IN v$restart_file_seq_p;
        IF fault_symptom_code_p = NIL THEN
          clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
          RETURN;  {---->
        IFEND;
        display_fault_symptom_code (fault_symptom_code_p^);

        clp$put_display (v$display_control, '   Mainframe Element Status:', clc$trim, ignore_status);
        IF (ssb_iw_p^.data_length_to_log - 3) < 1 THEN
          clp$put_display (v$display_control, '     No element status', clc$trim, ignore_status);
        ELSE
          FOR index_2 := 1 TO (ssb_iw_p^.data_length_to_log - 3) DO
            line.data := ' ';
            NEXT ssb_integer_p IN v$restart_file_seq_p;
            IF ssb_integer_p = NIL THEN
              clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
              RETURN;  {---->
            IFEND;
            retrieve_register_string (ssb_integer_p^, line.register_string);
            line.description := titles [index_2];
            STRINGREP (display_string, string_length, '     ', line.data);
            clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
          FOREND;
        IFEND;

        { Determine and display a matching MDB.

       /find_mdb_match/
        FOR index_2 := 1 TO duc$dft_max_mdb_buffers DO
          IF v$data.mdb [index_2].cell_p <> NIL THEN
            RESET v$restart_file_seq_p TO v$data.mdb [index_2].cell_p;
            NEXT mdb_cw_p IN v$restart_file_seq_p;
            IF mdb_cw_p = NIL THEN
              clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
              RETURN;  {---->
            IFEND;
            IF mdb_cw_p^.sequence_number = mrb_cw_p^ [sorted_p^ [index].index].sequence_number THEN
              v$data.mdb [index_2].used := TRUE;
              display_mdb_data (index_2);
              EXIT /find_mdb_match/;  {---->
            IFEND;
          IFEND;
        FOREND /find_mdb_match/;
        display_trailer;

      IFEND;
    FOREND;

    FOR index := 1 TO duc$dft_max_mdb_buffers DO
      IF NOT v$data.mdb [index].used THEN
        IF v$data.mdb [index].cell_p <> NIL THEN
          RESET v$restart_file_seq_p TO v$data.mdb [index].cell_p;
          NEXT mdb_cw_p IN v$restart_file_seq_p;
          IF mdb_cw_p = NIL THEN
            clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
            RETURN;  {---->
          IFEND;
          IF mdb_cw_p^.sequence_number <> 0 THEN
            display_header (TRUE, ' MODEL DEPENDENT BUFFER (not associated with an existing MRB).');
            display_mdb_data (index);
            display_trailer;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND display_mrb_data;
?? OLDTITLE ??
?? NEWTITLE := 'display_mrb_nrb_control_word', EJECT ??

{ PURPOSE:
{   This procedure displays the information in the MRB or the NRB control word.

  PROCEDURE display_mrb_nrb_control_word
    (    control_word: dst$dftb_buffer_control_word);

    VAR
      dft_analysis_code: dst$dftb_dft_analysis_code,
      dft_analysis_code_message: string (c$message_size),
      dft_analysis_code_string: string (3),
      display_string: string (osc$max_string_size),
      flag_set: boolean,
      ignore_status: ost$status,
      index: dst$dftb_element_size,
      multiple_error: boolean,
      string_length: integer;

    IF (control_word.dft_analysis_code DIV 100(16)) > dsc$dftb_mrb_non THEN
      dft_analysis_code := control_word.dft_analysis_code - 800(16);
      multiple_error := TRUE;
    ELSE
      dft_analysis_code := control_word.dft_analysis_code;
      multiple_error := FALSE;
    IFEND;
    dft_analysis_code_message := '*UNKNOWN DFT ANALYSIS CODE*';

   /retrieve_dft_message/
    FOR index := 1 TO c$number_of_dft_messages DO
      IF v$dft_message [index].dft_analysis_code = dft_analysis_code THEN
        dft_analysis_code_message := v$dft_message [index].value;
        EXIT /retrieve_dft_message/;  {---->
      IFEND;
    FOREND /retrieve_dft_message/;

    STRINGREP (display_string, string_length, '   SEQUENCE NUMBER = ',
          control_word.sequence_number: #(16), '(16)');
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

    IF (control_word.os_action_code >= LOWERBOUND (v$os_action_message)) AND
          (control_word.os_action_code <= UPPERBOUND (v$os_action_message)) THEN
      STRINGREP (display_string, string_length, '   OS Action Code = ',
            control_word.os_action_code: #(16), '(16)', ' ',
            v$os_action_message [control_word.os_action_code]);
    ELSE
      STRINGREP (display_string, string_length, '   OS Action Code = ',
            control_word.os_action_code: #(16), '(16)', ' *UNKNOWN OS ACTION CODE');
    IFEND;
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

    IF (control_word.priority >= LOWERBOUND (v$priority_message)) AND
          (control_word.priority <= UPPERBOUND (v$priority_message)) THEN
      STRINGREP (display_string, string_length, '   Priority = ',  control_word.priority: #(16), '(16)',
            ' ', v$priority_message [control_word.priority]);
    ELSE
      STRINGREP (display_string, string_length, '   Priority = ',  control_word.priority: #(16), '(16)',
            ' *UNKNOWN PRIORITY');
    IFEND;
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

    dft_analysis_code_string := 'XXX';
    clp$convert_integer_to_rjstring (dft_analysis_code, 16, FALSE, '0', dft_analysis_code_string,
          ignore_status);
    STRINGREP (display_string, string_length, '   DFT Analysis Code = ',
          dft_analysis_code_string, '(16)', dft_analysis_code_message);
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
    IF multiple_error THEN
      STRINGREP (display_string, string_length, '   *Multiple Occurrence*');
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
    IFEND;

    STRINGREP (display_string, string_length, '   Flags Indicate:');
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
    flag_set := FALSE;
    IF control_word.flags.unused THEN
      flag_set := TRUE;
      clp$put_display (v$display_control, '     Reserved - future use', clc$trim, ignore_status);
    IFEND;
    IF control_word.flags.valid_mdb_data THEN
      flag_set := TRUE;
      clp$put_display (v$display_control,
            '     Additional status available in a Model Dependent Buffer (MDB)', clc$trim, ignore_status);
    IFEND;
    IF control_word.flags.logging_to_console THEN
      flag_set := TRUE;
      clp$put_display (v$display_control, '     Logging to console flag set (LC)', clc$trim, ignore_status);
    IFEND;
    IF control_word.flags.threshold_exceeded THEN
      flag_set := TRUE;
      clp$put_display (v$display_control,
            '     The error associated with this entry has caused a threshold to be exceeded (T)',
            clc$trim, ignore_status);
    IFEND;
    IF control_word.flags.logging_action THEN
      flag_set := TRUE;
      clp$put_display (v$display_control,
            '     The error being reported has not yet been logged by the OS (L)', clc$trim, ignore_status);
    IFEND;
    IF control_word.flags.interlock THEN
      flag_set := TRUE;
      clp$put_display (v$display_control, '     The Buffer is Interlocked (I)', clc$trim, ignore_status);
    IFEND;
    IF control_word.flags.c180_valid_data THEN
      flag_set := TRUE;
      clp$put_display (v$display_control, '     Error not yet processed by the 180 side (V8)', clc$trim,
            ignore_status);
    IFEND;
    IF control_word.flags.c170_valid_data THEN
      flag_set := TRUE;
      clp$put_display (v$display_control, '     Error not yet processed by the 170 side (V7)', clc$trim,
            ignore_status);
    IFEND;
    IF NOT flag_set THEN
      clp$put_display (v$display_control, '     No flags set', clc$trim, ignore_status);
    IFEND;

  PROCEND display_mrb_nrb_control_word;
?? OLDTITLE ??
?? NEWTITLE := 'display_nrb_data', EJECT ??

{ PURPOSE:
{   This procedure displays the information from the Non Status Register Buffers.

  PROCEDURE display_nrb_data;

    VAR
      date_time_p: ^t$date_time,
      display_first_header: boolean,
      display_string: string (osc$max_string_size),
      fault_symptom_code_p: ^t$fault_symptom_code,
      ignore_status: ost$status,
      index: dst$dftb_element_size,
      index_2: dst$dftb_element_size,
      nrb_cw_p: ^dst$dftb_buffer_control_word,
      nrb_hw_p: ^dst$dftb_buffer_header_word,
      nrb_integer_p: ^integer,
      nrb_iw_p: ^dst$dftb_nrb_information_word,
      register_string: string (19),
      save_sorted: t$sorted,
      skip_nrb_hw_p: ^dst$dftb_buffer_header_word,
      skip_p: ^SEQ ( * ),
      sorted_p: ^ARRAY [1 .. *] OF t$sorted,
      sorted_size: dst$dftb_element_size,
      string_length: integer;

    display_header (TRUE, ' NON REGISTER STATUS BUFFER (scratch buffer):');
    RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_nrb].cell_p;
    NEXT nrb_hw_p IN v$restart_file_seq_p;
    IF nrb_hw_p = NIL THEN
      clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;
    print_raw_data (nrb_hw_p^.buffer_size);

    RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_nrb].cell_p;
    NEXT nrb_hw_p IN v$restart_file_seq_p;
    IF nrb_hw_p = NIL THEN
      clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;
    sorted_size := nrb_hw_p^.number_of_buffers - 1;
    PUSH sorted_p: [1 .. sorted_size];

    { Sort the control words into descending order by sequence number.  The scratch buffer is skipped.

    FOR index := 1 TO sorted_size DO
      RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_nrb].cell_p;
      NEXT skip_nrb_hw_p IN v$restart_file_seq_p;
      IF skip_nrb_hw_p = NIL THEN
        clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
        RETURN;  {---->
      IFEND;
      NEXT skip_p: [[REP (index * nrb_hw_p^.buffer_size) OF integer]] IN v$restart_file_seq_p;
      IF skip_p = NIL THEN
        clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
        RETURN;  {---->
      IFEND;
      NEXT nrb_cw_p IN v$restart_file_seq_p;
      IF nrb_cw_p = NIL THEN
        clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
        RETURN;  {---->
      IFEND;
      sorted_p^ [index].sequence := nrb_cw_p^.sequence_number;
      sorted_p^ [index].index := index;
    FOREND;
    FOR index := 1 TO (sorted_size - 1) DO
      FOR index_2 := (index + 1) TO sorted_size DO
        IF sorted_p^ [index].sequence < sorted_p^ [index_2].sequence THEN
          save_sorted := sorted_p^ [index];
          sorted_p^ [index] := sorted_p^ [index_2];
          sorted_p^ [index_2] := save_sorted;
        IFEND;
      FOREND;
    FOREND;

    { Display the data.

    display_first_header := TRUE;
    FOR index := 1 TO sorted_size DO
      IF sorted_p^ [index].sequence <> 0 THEN
        IF display_first_header THEN
          display_header (TRUE, ' NRSB Data; listed in descending sequence number order.');
          display_first_header := FALSE;
        IFEND;

        STRINGREP (display_string, string_length, ' NON REGISTER STATUS BUFFER (index=',
              sorted_p^ [index].index, '(10)):');
        display_header (TRUE, display_string (1, string_length));

        RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_nrb].cell_p;
        NEXT skip_nrb_hw_p IN v$restart_file_seq_p;
        IF skip_nrb_hw_p = NIL THEN
          clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
          RETURN;  {---->
        IFEND;
        NEXT skip_p: [[REP (sorted_p^ [index].index * nrb_hw_p^.buffer_size) OF integer]] IN
              v$restart_file_seq_p;
        IF skip_p = NIL THEN
          clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
          RETURN;  {---->
        IFEND;
        NEXT nrb_cw_p IN v$restart_file_seq_p;
        IF nrb_cw_p = NIL THEN
          clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
          RETURN;  {---->
        IFEND;

        display_mrb_nrb_control_word (nrb_cw_p^);

        NEXT nrb_iw_p IN v$restart_file_seq_p;
        IF nrb_iw_p = NIL THEN
          clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
          RETURN;  {---->
        IFEND;
        display_element_type (nrb_iw_p^.element_number);
        display_data_type (nrb_iw_p^.mrb_type);

        STRINGREP (display_string, string_length, '   NRSB Data Length to Log = ',
              nrb_iw_p^.data_length_to_log, '(10) cm words');
        clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);

        NEXT date_time_p IN v$restart_file_seq_p;
        IF date_time_p = NIL THEN
          clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
          RETURN;  {---->
        IFEND;
        display_date_time (date_time_p^);

        NEXT fault_symptom_code_p IN v$restart_file_seq_p;
        IF fault_symptom_code_p = NIL THEN
          clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
          RETURN;  {---->
        IFEND;
        display_fault_symptom_code (fault_symptom_code_p^);

        clp$put_display (v$display_control, '   Error Dependent Data:', clc$trim, ignore_status);
        IF (nrb_iw_p^.data_length_to_log - 4) < 1 THEN
          clp$put_display (v$display_control, '     No dependent data', clc$trim, ignore_status);
        ELSE
          IF nrb_cw_p^.dft_analysis_code = 707(16) THEN
            display_mec_data (FALSE);
          ELSEIF nrb_cw_p^.dft_analysis_code = 708(16) THEN
            NEXT nrb_integer_p IN v$restart_file_seq_p;
            IF nrb_integer_p = NIL THEN
              clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
              RETURN;  {---->
            IFEND;
            retrieve_register_string (nrb_integer_p^, register_string);
            STRINGREP (display_string, string_length, '     Options Installed = ', register_string);
            clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
            NEXT nrb_integer_p IN v$restart_file_seq_p;
            IF nrb_integer_p = NIL THEN
              clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
              RETURN;  {---->
            IFEND;
            retrieve_register_string (nrb_integer_p^, register_string);
            STRINGREP (display_string, string_length, '     Element id register = ', register_string);
            clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
            display_secded_id_data (FALSE);
          ELSE
            FOR index_2 := 1 TO (nrb_iw_p^.data_length_to_log - 4) DO
              NEXT nrb_integer_p IN v$restart_file_seq_p;
              IF nrb_integer_p = NIL THEN
                clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
                RETURN;  {---->
              IFEND;
              retrieve_register_string (nrb_integer_p^, register_string);
              STRINGREP (display_string, string_length, '     ', register_string);
              clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
            FOREND;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND display_nrb_data;
?? OLDTITLE ??
?? NEWTITLE := 'display_os_buffer_data', EJECT ??

{ PURPOSE:
{   This procedure displays the information in the NOS/VE Buffer or the C170 OS Buffer.

  PROCEDURE display_os_buffer_data
    (    display_nosve_buffer: boolean);

    TYPE
      t$integer_or_r_pointer = RECORD
        CASE boolean OF
        = TRUE =
          integer_part: integer,
        = FALSE =
          r_pointer_part: dst$r_pointer,
        CASEND,
      RECEND,

      t$line = RECORD
        CASE boolean OF
        = TRUE =
          spaces: string (3),
          title: string (26),
          r_pointer: string (19),
          rma_title: string (10),
        = FALSE =
          data: string (60),
        CASEND,
      RECEND;

    VAR
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      index: dst$dftb_element_size,
      integer_or_r_pointer_p: ^t$integer_or_r_pointer,
      line: t$line,
      rma: integer,
      size: dst$dftb_element_size,
      string_length: integer,
      titles: [STATIC] ARRAY [1 .. 4] OF string (26) :=
            ['SCI/VPB Request Pointer = ',
             '    SDA Request Pointer = ',
             ' NOS/VE Request Pointer = ',
             ' Unused Request Pointer = '];

    IF display_nosve_buffer THEN
      display_header (TRUE, ' NOS/VE BUFFER:');
      RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_nosve_buffer].cell_p;
      size := v$data.buffer [dsc$dftb_rpw_nosve_buffer].size;
    ELSE
      display_header (TRUE, ' C170 OS BUFFER:');
      RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_c170_os_buffer].cell_p;
      size := v$data.buffer [dsc$dftb_rpw_c170_os_buffer].size;
    IFEND;

    FOR index := 1 TO size DO
      line.data := ' ';
      IF display_nosve_buffer THEN
        line.title := titles [index];
      ELSE
        line.title := '  C170 OS Request Pointer = ';
      IFEND;
      NEXT integer_or_r_pointer_p IN v$restart_file_seq_p;
      IF integer_or_r_pointer_p = NIL THEN
        clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
        RETURN;  {---->
      IFEND;
      retrieve_register_string (integer_or_r_pointer_p^.integer_part, line.r_pointer);
      line.rma_title := '    RMA = ';
      rma := integer_or_r_pointer_p^.r_pointer_part.rupper * 10000000(8) +
            integer_or_r_pointer_p^.r_pointer_part.rlower * 1000(8) +
            integer_or_r_pointer_p^.r_pointer_part.offset * 10(8);
      STRINGREP (display_string, string_length, line.data, rma: #(16), '(16)');
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
    FOREND;
    display_trailer;

  PROCEND display_os_buffer_data;
?? OLDTITLE ??
?? NEWTITLE := 'display_pp_reg_save_area_data', EJECT ??

{ PURPOSE:
{   This procedure displays the contents of the PP register save area buffer.

  PROCEDURE display_pp_reg_save_area_data;

    TYPE
      t$dft_apqk = RECORD
        p: t$dft_pp_register,
        q: t$dft_pp_register,
        k: t$dft_pp_register,
        a: t$dft_pp_register,
        p2: t$dft_pp_register,
        q2: t$dft_pp_register,
        k2: t$dft_pp_register,
        a2: t$dft_pp_register,
      RECEND,

      t$line = RECORD
        CASE boolean OF
        = TRUE =
          spaces: string (3),
          first_register_name: string (12),
          first_register: string (15),
          second_register_name: string (13),
          second_register: string (11),
        = FALSE =
          data: string (54),
        CASEND,
      RECEND,

      t$offset = RECORD
        rfu: 0 .. 0ffffffff(16),
        offset: 0 .. 0ffffffff(16),
      RECEND,

      t$pp_id_line = RECORD
        CASE boolean OF
        = TRUE =
          line: string (15),
        = FALSE =
          space_1: string (3),
          iou_word: string (3),
          iou_number: string (1),
          space_2: string (2),
          cio_id: string (1),
          pp_word: string (2),
          pp_number: string (2),
          colon: string (1),
        CASEND,
      RECEND,

      t$dft_pp_register = 0 .. 0ffffffff(16),

      t$pp_type = (c$nio_0_11, c$nio_20_31, c$cio_0_11);

    VAR
      apqk_p: ^t$dft_apqk,
      data_size: integer,
      display_string: string (osc$max_string_size),
      dump_information: dut$dump_information,
      ignore_status: ost$status,
      iou_number: 0 .. duc$de_maximum_ious,
      line: t$line,
      offset_p: ^t$offset,
      pp_id_line: t$pp_id_line,
      pp_number: 0 .. 31(8),
      pp_register_string: string (11),
      pp_type: t$pp_type,
      string_length: integer;

    display_header (TRUE, ' PP REGISTER SAVE AREA:');
    RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_pp_reg_save_area].cell_p;
    data_size := v$data.buffer [dsc$dftb_rpw_pp_reg_save_area].size * 8;
    NEXT offset_p IN v$restart_file_seq_p;
    IF offset_p = NIL THEN
      clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;
    data_size := data_size - #SIZE (t$offset);
    STRINGREP (display_string, string_length, '   Offset to Secondary IOU PP register save area = ',
          offset_p^.offset);
    clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
    iou_number := 0;
    pp_number := 0;
    pp_type := c$nio_0_11;
    dup$determine_dump_information (dump_information);

    WHILE data_size > #SIZE (t$dft_apqk) DO

     /display_pp_reg_data/
      BEGIN
        NEXT apqk_p IN v$restart_file_seq_p;
        IF apqk_p = NIL THEN
          clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
          RETURN;  {---->
        IFEND;
        data_size := data_size - #SIZE (t$dft_apqk);
        IF (apqk_p^.p = 0) AND (apqk_p^.q = 0) AND (apqk_p^.k = 0) AND (apqk_p^.a = 0) AND
              (apqk_p^.p2 = 0) AND (apqk_p^.q2 = 0) AND (apqk_p^.k2 = 0) AND (apqk_p^.a2 = 0) THEN
          EXIT /display_pp_reg_data/;  {---->
        IFEND;

        clp$put_display (v$display_control, v$dash, clc$trim, ignore_status);
        pp_id_line.line := ' ';
        pp_id_line.iou_word := 'IOU';
        clp$convert_integer_to_rjstring (iou_number, 8, FALSE, '0', pp_id_line.iou_number, ignore_status);
        IF (pp_type = c$cio_0_11) OR (dump_information.iou [iou_number].model = duc$di_im_i4_43) OR
              (dump_information.iou [iou_number].model = duc$di_im_i4_44) OR
              (dump_information.iou [iou_number].model = duc$di_im_i4_46) THEN
          pp_id_line.cio_id := 'C';
        IFEND;
        pp_id_line.pp_word := 'PP';
        clp$convert_integer_to_rjstring (pp_number, 8, FALSE, '0', pp_id_line.pp_number, ignore_status);
        pp_id_line.colon := ':';
        clp$put_display (v$display_control, pp_id_line.line, clc$trim, ignore_status);

        line.data := ' ';
        line.first_register_name := 'P Register';
        clp$convert_integer_to_rjstring (apqk_p^.p, 8, FALSE, '0', pp_register_string, ignore_status);
        line.first_register := pp_register_string;
        line.second_register_name := 'P'' Register';
        clp$convert_integer_to_rjstring (apqk_p^.p2, 8, FALSE, '0', pp_register_string, ignore_status);
        line.second_register := pp_register_string;
        clp$put_display (v$display_control, line.data, clc$trim, ignore_status);

        line.data := ' ';
        IF dump_information.iou [iou_number].model = duc$di_im_i0_5x THEN
          line.first_register_name := 'D Register';
        ELSE
          line.first_register_name := 'Q Register';
        IFEND;
        clp$convert_integer_to_rjstring (apqk_p^.q, 8, FALSE, '0', pp_register_string, ignore_status);
        line.first_register := pp_register_string;
        IF dump_information.iou [iou_number].model = duc$di_im_i0_5x THEN
          line.second_register_name := 'D'' Register';
        ELSE
          line.second_register_name := 'Q'' Register';
        IFEND;
        clp$convert_integer_to_rjstring (apqk_p^.q2, 8, FALSE, '0', pp_register_string, ignore_status);
        line.second_register := pp_register_string;
        clp$put_display (v$display_control, line.data, clc$trim, ignore_status);

        line.data := ' ';
        line.first_register_name := 'K Register';
        clp$convert_integer_to_rjstring (apqk_p^.k, 8, FALSE, '0', pp_register_string, ignore_status);
        line.first_register := pp_register_string;
        line.second_register_name := 'K'' Register';
        clp$convert_integer_to_rjstring (apqk_p^.k2, 8, FALSE, '0', pp_register_string, ignore_status);
        line.second_register := pp_register_string;
        clp$put_display (v$display_control, line.data, clc$trim, ignore_status);

        line.data := ' ';
        line.first_register_name := 'A Register';
        clp$convert_integer_to_rjstring (apqk_p^.a, 8, FALSE, '0', pp_register_string, ignore_status);
        line.first_register := pp_register_string;
        line.second_register_name := 'A'' Register';
        clp$convert_integer_to_rjstring (apqk_p^.a2, 8, FALSE, '0', pp_register_string, ignore_status);
        line.second_register := pp_register_string;
        clp$put_display (v$display_control, line.data, clc$trim, ignore_status);

      END /display_pp_reg_data/;

      IF pp_number = 11(8) THEN
        IF pp_type = c$nio_0_11 THEN
          pp_number := 20(8);
          pp_type := c$nio_20_31;
        ELSE  { pp_type = c$cio_0_11
          iou_number := 1;
          pp_number := 0;
          pp_type := c$nio_0_11
        IFEND;
      ELSEIF pp_number = 31(8) THEN
        pp_number := 0;
        pp_type := c$cio_0_11;
      ELSE
        pp_number := pp_number + 1;
      IFEND;

    WHILEND;

  PROCEND display_pp_reg_save_area_data;
?? OLDTITLE ??
?? NEWTITLE := 'display_secded_id_data', EJECT ??

{ PURPOSE:
{   This procedure displays the SECDED ID Table information.

  PROCEDURE display_secded_id_data
    (    full_display: boolean);

    TYPE
      t$line = RECORD
        CASE boolean OF
        = TRUE =
          spaces: string (5),
          count: string (7),
          address: string (11),
          syndrome: string (8),
        = FALSE =
          data: string (31),
        CASEND,
      RECEND;

    VAR
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      index: dst$dftb_element_size,
      integer_p: ^integer,
      line: t$line,
      register_string: string (19),
      string_length: integer;

    IF full_display THEN
      display_header (TRUE, ' CURRENT SECDED ID TABLE:');
      RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_secded_id].cell_p;
    IFEND;
    line.data := ' ';
    line.count := 'COUNT';
    line.address := ' ADDRESS';
    line.syndrome := 'SYNDROME';
    clp$put_display (v$display_control, line.data, clc$trim, ignore_status);

    FOR index := 1 TO v$data.buffer [dsc$dftb_rpw_secded_id].size DO
      line.data := ' ';
      NEXT integer_p IN v$restart_file_seq_p;
      IF integer_p = NIL THEN
        clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
        RETURN;  {---->
      IFEND;
      retrieve_register_string (integer_p^, register_string);
      line.count := register_string (1, 4);
      line.address := register_string (6, 9);
      line.syndrome (3, 4) := register_string (16, 4);
      clp$put_display (v$display_control, line.data, clc$trim, ignore_status);
    FOREND;

    IF full_display THEN
      display_trailer;
    IFEND;

  PROCEND display_secded_id_data;
?? OLDTITLE ??
?? NEWTITLE := 'display_secondary_dft_data', EJECT ??

{ PURPOSE:
{   This procedure will display information in the Secondary DFT Buffer.

  PROCEDURE display_secondary_dft_data;

    VAR
      dftb_cw_p: ^dst$dftb_control_word,
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      index: dst$dftb_element_size,
      integer_p: ^integer,
      main_dft_cw_p: ^dst$dftb_control_word,
      register_string: string (19),
      skip_p: ^SEQ ( * ),
      ssb_hw_p: ^dst$dftb_buffer_header_word,
      string_length: integer;

    display_header (TRUE, ' SECONDARY DFT BUFFER:');

    RESET v$restart_file_seq_p TO v$data.buffer [duc$dft_cw].cell_p;
    NEXT main_dft_cw_p IN v$restart_file_seq_p;
    IF main_dft_cw_p = NIL THEN
      clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;
    RESET v$restart_file_seq_p TO v$data.buffer[dsc$dftb_rpw_dft_secondary].cell_p;
    NEXT dftb_cw_p IN v$restart_file_seq_p;
    IF dftb_cw_p = NIL THEN
      clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;
    IF (main_dft_cw_p^.pointer_words <> dftb_cw_p^.pointer_words) OR
          (main_dft_cw_p^.revision_level <> dftb_cw_p^.revision_level) OR
          (main_dft_cw_p^.mrb_length <> dftb_cw_p^.mrb_length) THEN
      clp$put_display (v$display_control, ' Secondary DFT Buffer is damaged - cannot display the contents.',
            clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;

    clp$put_display (v$display_control, ' Secondary DFT Buffer Control Word:', clc$trim, ignore_status);

    RESET v$restart_file_seq_p TO v$data.buffer[dsc$dftb_rpw_dft_secondary].cell_p;
    display_dft_control_word (TRUE);

    RESET v$restart_file_seq_p TO v$data.buffer[dsc$dftb_rpw_dft_secondary].cell_p;
    NEXT dftb_cw_p IN v$restart_file_seq_p;
    IF dftb_cw_p = NIL THEN
      clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;

    NEXT skip_p: [[REP (v$data.actual_number_of_pointer_words + 2) OF integer]] IN v$restart_file_seq_p;
    IF skip_p = NIL THEN
      clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;
    clp$put_display (v$display_control, '   Secondary Maintenance Register Buffer Control Words:',
          clc$trim, ignore_status);
    FOR index := 1 TO dftb_cw_p^.number_of_mrbs DO
      NEXT integer_p IN v$restart_file_seq_p;
      IF integer_p = NIL THEN
        clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
        RETURN;  {---->
      IFEND;
      retrieve_register_string (integer_p^, register_string);
      STRINGREP (display_string, string_length, '     ', register_string);
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
    FOREND;

    NEXT skip_p: [[REP 2 OF integer]] IN v$restart_file_seq_p;
    IF skip_p = NIL THEN
      clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;
    clp$put_display (v$display_control, '   Secondary Maintenance Register Buffer:', clc$trim, ignore_status);
    FOR index := 1 TO dftb_cw_p^.mrb_length DO
      NEXT integer_p IN v$restart_file_seq_p;
      IF integer_p = NIL THEN
        clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
        RETURN;  {---->
      IFEND;
      retrieve_register_string (integer_p^, register_string);
      STRINGREP (display_string, string_length, '     ', register_string);
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
    FOREND;

    NEXT skip_p: [[REP 2 OF integer]] IN v$restart_file_seq_p;
    IF skip_p = NIL THEN
      clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;
    clp$put_display (v$display_control, '   Secondary Supportive Status Buffer:', clc$trim, ignore_status);
    NEXT ssb_hw_p IN v$restart_file_seq_p;
    IF ssb_hw_p = NIL THEN
      clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;
    FOR index := 1 TO (ssb_hw_p^.number_of_buffers * ssb_hw_p^.buffer_size) DO
      NEXT integer_p IN v$restart_file_seq_p;
      IF integer_p = NIL THEN
        clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
        RETURN;  {---->
      IFEND;
      retrieve_register_string (integer_p^, register_string);
      STRINGREP (display_string, string_length, '     ', register_string);
      clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
    FOREND;
    display_trailer;

  PROCEND display_secondary_dft_data;
?? OLDTITLE ??
?? NEWTITLE := 'display_trailer', EJECT ??

{ PURPOSE:
{   This procedure displays a trailer on the output file.

  PROCEDURE display_trailer;

    VAR
      ignore_status: ost$status;

    clp$put_display (v$display_control, v$star, clc$trim, ignore_status);
    clp$put_display (v$display_control, ' ', clc$trim, ignore_status);

  PROCEND display_trailer;
?? OLDTITLE ??
?? NEWTITLE := 'print_raw_data', EJECT ??

{ PURPOSE:
{   This procedure prints the raw data of a buffer.

  PROCEDURE print_raw_data
    (    data_size: dst$dftb_element_size);

    TYPE
      t$line = RECORD
        data: string (80),
        size: 1 .. 80,
      RECEND;

    VAR
      buffer_size: dst$dftb_element_size,
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      integer_p: ^integer,
      line: t$line,
      previous_line: t$line,
      register_string: string (19),
      repeated_lines: integer,
      string_length: integer;

    buffer_size := data_size;
    line.size := 1;
    line.data := ' ';
    previous_line := line;
    repeated_lines := 0;

    WHILE buffer_size > 0 DO
      NEXT integer_p IN v$restart_file_seq_p;
      IF integer_p = NIL THEN
        clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
        RETURN;  {---->
      IFEND;
      buffer_size := buffer_size - 1;
      retrieve_register_string (integer_p^, register_string);
      line.data (line.size, #SIZE (register_string)) := register_string;
      line.size := line.size + #SIZE (register_string) + 2;
      IF (line.size > 60) OR (buffer_size <= 0) THEN
        IF (line = previous_line) AND (buffer_size > 0) THEN
          repeated_lines := repeated_lines + 1;
        ELSE
          IF repeated_lines = 1 THEN
            clp$put_display (v$display_control, previous_line.data (1, previous_line.size), clc$trim,
                  ignore_status);
          ELSEIF repeated_lines > 1 THEN
            STRINGREP (display_string, string_length, ' -- ', repeated_lines,
                  ' duplicate lines are suppressed.');
            clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
          IFEND;
          repeated_lines := 0;
          clp$put_display (v$display_control, line.data (1, line.size), clc$trim, ignore_status);
          previous_line := line;
        IFEND;
        line.size := 1;
        line.data := ' ';
      IFEND;
    WHILEND;

  PROCEND print_raw_data;
?? OLDTITLE ??
?? NEWTITLE := 'retrieve_register_string', EJECT ??

{ PURPOSE:
{   This procedure builds a string of the register data it is sent.

  PROCEDURE retrieve_register_string
    (    register_value: integer;
     VAR register_string: string (19));

    TYPE
      t$array_or_integer = RECORD
        CASE boolean OF
        = TRUE =
          array_part: ARRAY [1 .. 4] OF 0 .. 0ffff(16),
        = FALSE =
          integer_part: integer,
        CASEND,
      RECEND;

    VAR
      array_or_integer_p: ^t$array_or_integer,
      ignore_status: ost$status,
      index: 1 .. 4,
      register_seq_p: ^SEQ (REP 1 OF integer),
      register_string_index: 0 .. 0ff(16),
      string_4: string (4);

    PUSH register_seq_p;
    NEXT array_or_integer_p IN register_seq_p;
    IF array_or_integer_p = NIL THEN
      clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
      RETURN;  {---->
    IFEND;
    array_or_integer_p^.integer_part := register_value;

    register_string := ' ';
    register_string_index := 1;
    FOR index := 1 TO 4 DO
      string_4 := 'XXXX';
      clp$convert_integer_to_rjstring (array_or_integer_p^ .array_part [index], 16, FALSE, '0',
            string_4, ignore_status);
      register_string (register_string_index, 4) := string_4;
      register_string_index := register_string_index + 5;
    FOREND;

  PROCEND retrieve_register_string;
?? OLDTITLE ??
?? NEWTITLE := 'dup$process_dft_buffer_command', EJECT ??

{ PURPOSE:
{   This procedure displays the information from the DFT buffer.

  PROCEDURE [XDCL] dup$process_dft_buffer_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE process_dft_buffer, prodb (
{   display_option, do: any of
{       key
{         (all)
{       keyend
{       list of key
{         (dft_control_word) (mrb_ssb_mdb) (nrsb) (secded_id_table) (mec) (dft_error_control)
{         (pp_register_save_area) (nosve_buffer) (dft_cm_resident) (c170_pp_resident) (c170_os_buffer)
{         (secondary_dft_buffer)
{       keyend
{     anyend = all
{   display_type, dt: key
{       (detailed, d) (raw, r)
{     keyend = detailed
{   display_mdb_capture_buffer, dmcb: boolean = FALSE
{   output, o: file = $optional
{   title, t: string 1..31 = 'process_dft_buffer'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] 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 .. 12] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (8),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (20),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 4, 16, 9, 56, 45, 2],
    clc$command, 11, 6, 0, 0, 0, 0, 6, ''], [
    ['DISPLAY_MDB_CAPTURE_BUFFER     ',clc$nominal_entry, 3],
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 1],
    ['DISPLAY_TYPE                   ',clc$nominal_entry, 2],
    ['DMCB                           ',clc$abbreviation_entry, 3],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['DT                             ',clc$abbreviation_entry, 2],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OUTPUT                         ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 6],
    ['T                              ',clc$abbreviation_entry, 5],
    ['TITLE                          ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 531,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 20],
{ PARAMETER 6
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    467, [[1, 0, clc$list_type], [451, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [12], [
        ['C170_OS_BUFFER                 ', clc$nominal_entry, clc$normal_usage_entry, 11],
        ['C170_PP_RESIDENT               ', clc$nominal_entry, clc$normal_usage_entry, 10],
        ['DFT_CM_RESIDENT                ', clc$nominal_entry, clc$normal_usage_entry, 9],
        ['DFT_CONTROL_WORD               ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['DFT_ERROR_CONTROL              ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['MEC                            ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['MRB_SSB_MDB                    ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['NOSVE_BUFFER                   ', clc$nominal_entry, clc$normal_usage_entry, 8],
        ['NRSB                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['PP_REGISTER_SAVE_AREA          ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['SECDED_ID_TABLE                ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['SECONDARY_DFT_BUFFER           ', clc$nominal_entry, clc$normal_usage_entry, 12]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['DETAILED                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['RAW                            ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'detailed'],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'FALSE'],
{ PARAMETER 4
    [[1, 0, clc$file_type]],
{ PARAMETER 5
    [[1, 0, clc$string_type], [1, 31, FALSE],
    '''process_dft_buffer'''],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$display_option = 1,
      p$display_type = 2,
      p$display_mdb_capture_buffer = 3,
      p$output = 4,
      p$title = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      data_length_valid: boolean,
      data_valid: boolean,
      dft_cw_p: ^dst$dftb_control_word,
      display_all_data: boolean,
      display_data: ARRAY [0 .. duc$dft_max_known_pointer_words] OF boolean,
      display_string: string (osc$max_string_size),
      ignore_status: ost$status,
      index: 1 .. duc$dft_max_mdb_buffers,
      list_p: ^clt$data_value,
      new_byte_size: ost$segment_length,
      option_p: ^clt$data_value,
      output_display_opened: boolean,
      ring_attributes: amt$ring_attributes,
      string_length: integer,
      titles: [STATIC] ARRAY [0 .. duc$dft_max_known_pointer_words] OF string (76) :=
            [' ------------    D F T  B U F F E R  C O N T R O L  W O R D     ------------',
             ' ------------            S E C D E D  I D  T A B L E            ------------',
             ' ----------- M A I N T E N A N C E  R E G I S T E R  B U F F E R -----------',
             ' ------------     M O D E L  D E P E N D E N T  B U F F E R     ------------',
             ' ------------             N O S / V E  B U F F E R              ------------',
             ' ------------    C 1 7 0  P P  R E S I D E N T  B U F F E R     ------------',
             ' ------------             C 1 7 0  O S  B U F F E R             ------------',
             ' ------------          M R B  C O N T R O L  W O R D S          ------------',
             ' ------ M A I N F R A M E  E L E M E N T  C O U N T E R  B U F F E R  ------',
             ' ------------   D F T  E R R O R  C O N T R O L  R E C O R D    ------------',
             ' ------------   S U P P O R T I V E  S T A T U S  B U F F E R   ------------',
             ' ------------ N O N  R E G I S T E R  S T A T U S  B U F F E R  ------------',
             ' ----------- D F T  C E N T R A L  M E M O R Y  R E S I D E N T ------------',
             ' ------------      P P  R E G I S T E R  S A V E  A R E A       ------------',
             ' ------------       S E C O N D A R Y  D F T  B U F F E R       ------------'],
      titles_pointer_word: [STATIC] string (76) :=
             ' ------------             P O I N T E R  W O R D S              ------------',
      word_index: 0 .. duc$dft_max_known_pointer_words;

*copy dup$abort_handler
?? NEWTITLE := 'clean_up', EJECT ??

{ PURPOSE:
{   This procedure is called from the abort handler to close the file.

    PROCEDURE [INLINE] clean_up;

      VAR
        ignore_status: ost$status;

      IF output_display_opened THEN
        clp$close_display (v$display_control, ignore_status);
      IFEND;

    PROCEND clean_up;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;  {---->
    IFEND;

    IF duv$dump_environment_p = NIL THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_restart_file, '', status);
      RETURN;  {---->
    IFEND;

    output_display_opened := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

   /display_opened/
    BEGIN

      { Prepare the output display file.

      IF pvt [p$output].specified THEN
        ring_attributes.r1 := #RING (^ring_attributes);
        ring_attributes.r2 := #RING (^ring_attributes);
        ring_attributes.r3 := #RING (^ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, ^dup$new_page_procedure, fsc$list,
              ring_attributes, v$display_control, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;  {---->
        IFEND;
        output_display_opened := TRUE;
      ELSE
        v$display_control := duv$execution_environment.output_file.display_control;
        v$display_control.line_number := v$display_control.page_length + 1;
      IFEND;

      duv$title_data.build_title := TRUE;
      duv$title_data.command_name := pvt [p$title].value^.string_value^;

      v$restart_file_seq_p := duv$execution_environment.restart_file.segment_pointer.sequence_pointer;

      { Retrieve the pointers to the individual areas of the buffer.

      dup$retrieve_dft_pointers (v$data, data_length_valid, data_valid);
      IF NOT data_length_valid THEN
        clp$put_display (v$display_control,
              'WARNING - Possible Memory Corruption in the DFT Structure on the DFT Dump Record.',
              clc$trim, ignore_status);
      IFEND;
      IF (v$data.revision_level < 4) OR (NOT data_valid) THEN
        STRINGREP (display_string, string_length, ' **ERROR** - Unsupported version.');
        clp$put_display (v$display_control, display_string (1, string_length), clc$trim, ignore_status);
        EXIT /display_opened/;  {---->
      IFEND;

      FOR word_index := 0 TO duc$dft_max_known_pointer_words DO
        display_data [word_index] := FALSE;
      FOREND;

      v$display_capture_buffer := pvt [p$display_mdb_capture_buffer].value^.boolean_value.value;
      display_all_data := (pvt [p$display_option].value^.kind = clc$keyword);
      IF NOT display_all_data THEN
        list_p := pvt [p$display_option].value;
        WHILE list_p <> NIL DO
          option_p := list_p^.element_value;
          list_p := list_p^.link;
          IF option_p^.keyword_value = 'DFT_CONTROL_WORD' THEN
            display_data [duc$dft_cw] := TRUE;
          ELSEIF option_p^.keyword_value = 'SECDED_ID_TABLE' THEN
            display_data [dsc$dftb_rpw_secded_id] := TRUE;
          ELSEIF option_p^.keyword_value = 'MRB_SSB_MDB' THEN
            display_data [dsc$dftb_rpw_mrb] := TRUE;
            display_data [dsc$dftb_rpw_mdb] := TRUE;
            display_data [dsc$dftb_rpw_mrb_cw] := TRUE;
            display_data [dsc$dftb_rpw_ssb] := TRUE;
          ELSEIF option_p^.keyword_value = 'NOSVE_BUFFER' THEN
            display_data [dsc$dftb_rpw_nosve_buffer] := TRUE;
          ELSEIF option_p^.keyword_value = 'C170_PP_RESIDENT' THEN
            display_data [dsc$dftb_rpw_c170_pp_resident] := TRUE;
          ELSEIF option_p^.keyword_value = 'C170_OS_BUFFER' THEN
            display_data [dsc$dftb_rpw_c170_os_buffer] := TRUE;
          ELSEIF option_p^.keyword_value = 'MEC' THEN
            display_data [dsc$dftb_rpw_mec] := TRUE;
          ELSEIF option_p^.keyword_value = 'DFT_ERROR_CONTROL' THEN
            display_data [dsc$dftb_rpw_dft_control_info] := TRUE;
          ELSEIF option_p^.keyword_value = 'NRSB' THEN
            display_data [dsc$dftb_rpw_nrb] := TRUE;
          ELSEIF option_p^.keyword_value = 'DFT_CM_RESIDENT' THEN
            display_data [dsc$dftb_rpw_dft_cm_resident] := TRUE;
          ELSEIF option_p^.keyword_value = 'PP_REGISTER_SAVE_AREA' THEN
            display_data [dsc$dftb_rpw_pp_reg_save_area] := TRUE;
          ELSEIF option_p^.keyword_value = 'SECONDARY_DFT_BUFFER' THEN
            display_data [dsc$dftb_rpw_dft_secondary] := TRUE;
          ELSE
          IFEND;
        WHILEND;
      IFEND;

      FOR word_index := 0 TO duc$dft_max_known_pointer_words DO
        display_data [word_index] := (display_all_data OR display_data [word_index]) AND
              (v$data.buffer [word_index].cell_p <> NIL);
      FOREND;

      IF pvt [p$display_type].value^.keyword_value = 'DETAILED' THEN
        display_memory_size;
        IF display_data [duc$dft_cw] THEN
          display_dft_control_word (FALSE);
        IFEND;
        IF display_data [dsc$dftb_rpw_mrb] AND display_data [dsc$dftb_rpw_mrb_cw] AND
              display_data [dsc$dftb_rpw_ssb] THEN
          display_mrb_data;
        IFEND;
        IF display_data [dsc$dftb_rpw_nrb] THEN
          display_nrb_data;
        IFEND;
        IF display_data [dsc$dftb_rpw_secded_id] THEN
          display_secded_id_data (TRUE);
        IFEND;
        IF display_data [dsc$dftb_rpw_mec] THEN
          display_mec_data (TRUE);
        IFEND;
        IF display_data [dsc$dftb_rpw_dft_control_info] THEN
          display_dec_data;
        IFEND;
        IF display_data [dsc$dftb_rpw_pp_reg_save_area] THEN
          display_pp_reg_save_area_data;
        IFEND;
        IF display_data [dsc$dftb_rpw_nosve_buffer] THEN
          display_os_buffer_data (TRUE);
        IFEND;
        IF display_data [dsc$dftb_rpw_c170_pp_resident] THEN
          display_header (TRUE, ' C170 PP RESIDENT BUFFER:');
          RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_c170_pp_resident].cell_p;
          print_raw_data (v$data.buffer [dsc$dftb_rpw_c170_pp_resident].size);
          display_trailer;
        IFEND;
        IF display_data [dsc$dftb_rpw_c170_os_buffer] THEN
          display_os_buffer_data (FALSE);
        IFEND;
        IF display_data [dsc$dftb_rpw_dft_cm_resident] THEN
          display_header (TRUE, ' DFT CENTRAL MEMORY RESIDENT:');
          RESET v$restart_file_seq_p TO v$data.buffer [dsc$dftb_rpw_dft_cm_resident].cell_p;
          print_raw_data (v$data.buffer [dsc$dftb_rpw_dft_cm_resident].size);
          display_trailer;
        IFEND;
        IF display_data [dsc$dftb_rpw_dft_secondary] THEN
          display_secondary_dft_data;
        IFEND;

      ELSE

      /display_raw_data/
        FOR word_index := 0 TO duc$dft_max_known_pointer_words DO
          IF NOT display_data [word_index] THEN
            CYCLE /display_raw_data/;  {---->
          IFEND;
          display_header (FALSE, titles [word_index]);
          RESET v$restart_file_seq_p TO v$data.buffer [word_index].cell_p;
          print_raw_data (v$data.buffer [word_index].size);

          IF word_index = duc$dft_cw THEN
            display_header (FALSE, titles_pointer_word);
            RESET v$restart_file_seq_p TO v$data.buffer [duc$dft_cw].cell_p;
            NEXT dft_cw_p IN v$restart_file_seq_p;
            IF dft_cw_p = NIL THEN
              clp$put_display (v$display_control, v$nil_error, clc$trim, ignore_status);
              EXIT /display_opened/;  {---->
            IFEND;
            print_raw_data (v$data.actual_number_of_pointer_words);
          IFEND;

          IF word_index = dsc$dftb_rpw_mdb THEN
            FOR index := 1 TO duc$dft_max_mdb_buffers DO
              IF v$data.mdb [index].cell_p <> NIL THEN
                clp$put_display (v$display_control, v$dash, clc$trim, ignore_status);
                RESET v$restart_file_seq_p TO v$data.mdb [index].cell_p;
                print_raw_data (v$data.mdb [index].size);
              IFEND;
            FOREND;
          IFEND;
        FOREND;

      IFEND;

    END /display_opened/;

    IF output_display_opened THEN
      clp$close_display (v$display_control, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND dup$process_dft_buffer_command;
MODEND dum$process_dft_buffer_command;
*DECK DECK=DUM$QUIT_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Dump Analyzer : Quit Command' ??                                                       
MODULE dum$quit_command;                                                                                      
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains the code for the quit command.                                                       
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc duc$dump_analyzer_constants                                                                            
?? POP ??                                                                                                     
*copyc clp$end_include                                                                                        
*copyc clp$evaluate_parameters                                                                                
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$quit_command', EJECT ??                                                                   
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure contains the command to exit the analyze_dump utility.                                     
                                                                                                              
  PROCEDURE [XDCL] dup$quit_command                                                                           
    (    parameter_list: clt$parameter_list;                                                                  
     VAR status: ost$status);                                                                                 
                                                                                                              
{ PROCEDURE quit, qui (                                                                                       
{   status)                                                                                                   
                                                                                                              
?? 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,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 5, 1, 14, 9, 40, 489],                                                                               
    clc$command, 1, 1, 0, 0, 0, 0, 1, ''], [                                                                  
    ['STATUS                         ',clc$nominal_entry, 1]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [1, clc$normal_usage_entry, clc$non_secure_parameter,                                                     
    $clt$parameter_spec_methods[clc$specify_by_name],                                                         
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,                      
  clc$optional_parameter, 0, 0]],                                                                             
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$status_type]]];                                                                               
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$status = 1;                                                                                           
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 1] of clt$parameter_value;                                                             
                                                                                                              
    status.normal := TRUE;                                                                                    
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    clp$end_include (duc$utility_name, status);                                                               
                                                                                                              
  PROCEND dup$quit_command;                                                                                   
MODEND dum$quit_command;                                                                                      
*DECK DECK=DUM$READ_DUMP_FILE EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Dump Analyzer : Read Dump File' ??                                                     
MODULE dum$read_dump_file;                                                                                    
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains the code to read the dump file.                                                      
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc clc$standard_file_names                                                                                
*copyc dst$channel_protocol_type                                                                              
*copyc duc$dump_analyzer_constants                                                                            
*copyc due$exception_condition_codes                                                                          
*copyc dut$dump_information                                                                                   
?? POP ??                                                                                                     
*copyc amp$get_next                                                                                           
*copyc amp$return                                                                                             
*copyc amp$set_segment_eoi                                                                                    
*copyc dup$display_message                                                                                    
*copyc dup$retrieve_register                                                                                  
*copyc fsp$close_file                                                                                         
*copyc fsp$open_file                                                                                          
*copyc mmp$set_access_selections                                                                              
*copyc ofp$display_status_message                                                                             
*copyc osp$append_status_parameter                                                                            
*copyc osp$get_status_severity                                                                                
*copyc osp$set_status_abnormal                                                                                
*copyc pmp$zero_out_table                                                                                     
*copyc rmp$get_device_class                                                                                   
?? EJECT ??                                                                                                   
*copyc duv$dump_environment_p                                                                                 
*copyc duv$execution_environment                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??                                        
                                                                                                              
  CONST                                                                                                       
    c$edd_tape_block_size = 3840;                                                                             
                                                                                                              
  TYPE                                                                                                        
    t$dump_label = RECORD                                                                                     
      read_label: boolean,                                                                                    
      record_name: dut$de_other_record_name,                                                                  
      CASE kind: t$dump_label_kind OF                                                                         
      = c$dlk_mem_label =                                                                                     
        first_word_address: 0 .. 0fffffff(16),                                                                
        length: 0 .. 0fffffff(16),                                                                            
      = c$dlk_ccm_label =                                                                                     
        page_number: 0 .. 0ffffffff(16),                                                                      
      = c$dlk_cpt_label =                                                                                     
        page_size_mask: 0 .. 0ff(16),                                                                         
        page_table_length: 0 .. 3ffff(16),                                                                    
      = c$dlk_did_label =                                                                                     
        edd_revision_level: string (3),                                                                       
      = c$dlk_iom_label, c$dlk_jom_label =                                                                    
        pp_number: 0 .. 99,                                                                                   
      = c$dlk_dom_label, c$dlk_eom_label =                                                                    
        cio_pp_number: 0 .. duc$de_max_cio_pp_memories,                                                       
      = c$dlk_pcs_label =                                                                                     
        shadow_control_store: boolean,                                                                        
        number_of_128_bit_regs: 0 .. 1fffff(16),                                                              
      = c$dlk_prf_label =                                                                                     
        register_file_size: 0 .. 3ffff(16),                                                                   
      = c$dlk_pmr_label, c$dlk_pr0_label, c$dlk_pr1_label,                                                    
            c$dlk_pxp_label, c$dlk_px0_label, c$dlk_px1_label,                                                
            c$dlk_jps_label, c$dlk_jp0_label, c$dlk_jp1_label,                                                
            c$dlk_mps_label, c$dlk_mp0_label, c$dlk_mp1_label =                                               
        radial_mci: 0 .. duc$de_maximum_mci_port,                                                             
      = c$dlk_other_label =                                                                                   
        record_type: dut$de_other_record_type,                                                                
        header_line_count: 0 .. 3ffff(16),                                                                    
        report_record_length: 0 .. 3ffff(16),                                                                 
      CASEND,                                                                                                 
    RECEND,                                                                                                   
                                                                                                              
    t$dump_label_kind = (c$dlk_pmr_label, c$dlk_pr0_label, c$dlk_pr1_label, c$dlk_mmr_label, c$dlk_mem_label, 
          c$dlk_imr_label, c$dlk_im1_label, c$dlk_iom_label, c$dlk_jom_label, c$dlk_dom_label,                
          c$dlk_eom_label, c$dlk_prf_label, c$dlk_pxp_label, c$dlk_px0_label, c$dlk_px1_label,                
          c$dlk_pcs_label, c$dlk_other_label, c$dlk_bc_label, c$dlk_jps_label, c$dlk_jp0_label,               
          c$dlk_jp1_label, c$dlk_cpt_label, c$dlk_ccm_label, c$dlk_mps_label, c$dlk_mp0_label,                
          c$dlk_mp1_label, c$dlk_ill_formatted_label, c$dlk_did_label, c$dlk_not_a_label),                    
                                                                                                              
    t$edd_code = PACKED RECORD                                                                                
      CASE boolean OF                                                                                         
      = TRUE =                                                                                                
        value: 0 .. 3ffff(16),                                                                                
      = FALSE =                                                                                               
        first_character: 0 .. 77(8),                                                                          
        second_character: 0 .. 77(8),                                                                         
        third_character: 0 .. 77(8),                                                                          
      CASEND,                                                                                                 
    RECEND,                                                                                                   
                                                                                                              
    t$edd_label = PACKED RECORD                                                                               
      code: t$edd_code,                                                                                       
      zero_parameter: 0 .. 3f(16),                                                                            
      first_parameter: 0 .. 3ffff(16),                                                                        
      second_parameter: 0 .. 3ffff(16),                                                                       
      message_field_1: 0 .. 01fffffffffff(16),                                                                
      message_field_2: 0 .. 01fffffffffff(16),                                                                
      message_field_3: 0 .. 01fffffffffff(16),                                                                
      message_field_4: 0 .. 01fffffffffff(16),                                                                
    RECEND;                                                                                                   
?? EJECT ??                                                                                                   
                                                                                                              
  VAR                                                                                                         
    v$display_control: clt$display_control,                                                                   
    v$dump_file_identifier: amt$file_identifier,                                                              
    v$file_name_p: ^fst$file_reference := NIL,                                                                
    v$file_position: amt$file_position,                                                                       
    v$last_bc_entry_p: ^dut$de_buffer_controlware_entry := NIL,                                               
    v$last_other_record_p: ^dut$de_other_record_entry := NIL;                                                 
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'get_next_data', EJECT ??                                                                      
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure reads the next chunk of data from the input file.  It will accept bad tape blocks.         
                                                                                                              
  PROCEDURE get_next_data                                                                                     
    (    data_size: amt$working_storage_length;                                                               
     VAR data_buffer_p: ^SEQ ( * );                                                                           
     VAR bytes_read: amt$transfer_count;                                                                      
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      file_byte_address: amt$file_byte_address;                                                               
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    amp$get_next (v$dump_file_identifier, data_buffer_p, data_size, bytes_read, file_byte_address,            
          v$file_position, status);                                                                           
    IF NOT status.normal AND (status.condition = ame$accept_bad_block) THEN                                   
      status.normal := TRUE;                                                                                  
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF NOT status.normal THEN                                                                                 
      dup$display_message (status, v$display_control);                                                        
      osp$set_status_abnormal (duc$dump_analyzer_id, due$dump_file_io_error, v$file_name_p^, status);         
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
  PROCEND get_next_data;                                                                                      
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'process_label_record', EJECT ??                                                               
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure builds the dump label record from the EDD label which resides on the input sequence.       
                                                                                                              
  PROCEDURE process_label_record                                                                              
    (VAR data_buffer_seq_p: ^SEQ ( * );                                                                       
     VAR dump_label: t$dump_label);                                                                           
                                                                                                              
    TYPE                                                                                                      
      t$shadow_bit = PACKED RECORD                                                                            
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          data: 0 .. 3ffff(16),                                                                               
        = FALSE =                                                                                             
          shadow_control_store: boolean,                                                                      
          unused: 0 .. 01ffff(16),                                                                            
        CASEND,                                                                                               
      RECEND,                                                                                                 
                                                                                                              
      t$three_characters = PACKED RECORD                                                                      
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          together: 0 .. 3ffff(16),                                                                           
        = FALSE =                                                                                             
          first_character: 0 .. 77(8),                                                                        
          second_character: 0 .. 77(8),                                                                       
          third_character: 0 .. 77(8),                                                                        
        CASEND,                                                                                               
      RECEND;                                                                                                 
                                                                                                              
    CONST                                                                                                     
      c$a_display_code = 1,                                                                                   
      c$b_display_code = 2,                                                                                   
      c$c_display_code = 3,                                                                                   
      c$d_display_code = 4,                                                                                   
      c$e_display_code = 5,                                                                                   
      c$f_display_code = 6,                                                                                   
      c$g_display_code = 7,                                                                                   
      c$h_display_code = 8,                                                                                   
      c$i_display_code = 9,                                                                                   
      c$j_display_code = 10,                                                                                  
      c$k_display_code = 11,                                                                                  
      c$l_display_code = 12,                                                                                  
      c$m_display_code = 13,                                                                                  
      c$n_display_code = 14,                                                                                  
      c$o_display_code = 15,                                                                                  
      c$p_display_code = 16,                                                                                  
      c$q_display_code = 17,                                                                                  
      c$r_display_code = 18,                                                                                  
      c$s_display_code = 19,                                                                                  
      c$t_display_code = 20,                                                                                  
      c$u_display_code = 21,                                                                                  
      c$v_display_code = 22,                                                                                  
      c$w_display_code = 23,                                                                                  
      c$x_display_code = 24,                                                                                  
      c$y_display_code = 25,                                                                                  
      c$z_display_code = 26,                                                                                  
      c$zero_display_code = 27,                                                                               
      c$one_display_code = 28,                                                                                
      c$nine_display_code = 36,                                                                               
      c$space_display_code = 45,                                                                              
      c$numeric_bias = 48,                                                                                    
      c$alphabetic_bias = 65,                                                                                 
                                                                                                              
      c$bc_display_code  = (((c$b_display_code * 40(16)) + c$c_display_code) * 40(16)) + c$space_display_code,
      c$did_display_code = (((c$d_display_code * 40(16)) + c$i_display_code) * 40(16)) + c$d_display_code,    
      c$ccm_display_code = (((c$c_display_code * 40(16)) + c$c_display_code) * 40(16)) + c$m_display_code,    
      c$cpt_display_code = (((c$c_display_code * 40(16)) + c$p_display_code) * 40(16)) + c$t_display_code,    
      c$im1_display_code = (((c$i_display_code * 40(16)) + c$m_display_code) * 40(16)) + c$one_display_code,  
      c$imr_display_code = (((c$i_display_code * 40(16)) + c$m_display_code) * 40(16)) + c$r_display_code,    
      c$jp0_display_code = (((c$j_display_code * 40(16)) + c$p_display_code) * 40(16)) + c$zero_display_code, 
      c$jp1_display_code = (((c$j_display_code * 40(16)) + c$p_display_code) * 40(16)) + c$one_display_code,  
      c$jps_display_code = (((c$j_display_code * 40(16)) + c$p_display_code) * 40(16)) + c$s_display_code,    
      c$mem_display_code = (((c$m_display_code * 40(16)) + c$e_display_code) * 40(16)) + c$m_display_code,    
      c$mmr_display_code = (((c$m_display_code * 40(16)) + c$m_display_code) * 40(16)) + c$r_display_code,    
      c$mp0_display_code = (((c$m_display_code * 40(16)) + c$p_display_code) * 40(16)) + c$zero_display_code, 
      c$mp1_display_code = (((c$m_display_code * 40(16)) + c$p_display_code) * 40(16)) + c$one_display_code,  
      c$mps_display_code = (((c$m_display_code * 40(16)) + c$p_display_code) * 40(16)) + c$s_display_code,    
      c$pcs_display_code = (((c$p_display_code * 40(16)) + c$c_display_code) * 40(16)) + c$s_display_code,    
      c$pmr_display_code = (((c$p_display_code * 40(16)) + c$m_display_code) * 40(16)) + c$r_display_code,    
      c$pr0_display_code = (((c$p_display_code * 40(16)) + c$r_display_code) * 40(16)) + c$zero_display_code, 
      c$pr1_display_code = (((c$p_display_code * 40(16)) + c$r_display_code) * 40(16)) + c$one_display_code,  
      c$prf_display_code = (((c$p_display_code * 40(16)) + c$r_display_code) * 40(16)) + c$f_display_code,    
      c$px0_display_code = (((c$p_display_code * 40(16)) + c$x_display_code) * 40(16)) + c$zero_display_code, 
      c$px1_display_code = (((c$p_display_code * 40(16)) + c$x_display_code) * 40(16)) + c$one_display_code,  
      c$pxp_display_code = (((c$p_display_code * 40(16)) + c$x_display_code) * 40(16)) + c$p_display_code;    
                                                                                                              
    VAR                                                                                                       
      edd_label_p: ^t$edd_label,                                                                              
      first_ascii_char: char,                                                                                 
      length: integer,                                                                                        
      local_status: ost$status,                                                                               
      max_pp_memories: integer,                                                                               
      pp_number: integer,                                                                                     
      second_ascii_char: char,                                                                                
      shadow_bit: t$shadow_bit,                                                                               
      third_ascii_char: char,                                                                                 
      three_characters: t$three_characters;                                                                   
                                                                                                              
?? NEWTITLE := 'convert_display_to_ascii', EJECT ??                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This function converts a display character to an ascii character.                                         
                                                                                                              
    FUNCTION convert_display_to_ascii (display_character: 0 .. 3f(16)): char;                                 
                                                                                                              
      IF (display_character >= c$zero_display_code) AND (display_character <= c$nine_display_code) THEN       
        convert_display_to_ascii := $CHAR (c$numeric_bias + (display_character - c$zero_display_code));       
      ELSEIF display_character = c$space_display_code THEN                                                    
        convert_display_to_ascii := ' ';                                                                      
      ELSE                                                                                                    
        convert_display_to_ascii := $CHAR (c$alphabetic_bias + (display_character - c$a_display_code));       
      IFEND;                                                                                                  
                                                                                                              
    FUNCEND convert_display_to_ascii;                                                                         
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    RESET data_buffer_seq_p;                                                                                  
    NEXT edd_label_p IN data_buffer_seq_p;                                                                    
    dump_label.read_label := FALSE;                                                                           
                                                                                                              
    CASE edd_label_p^.code.value OF                                                                           
    = c$bc_display_code =                                                                                     
      dump_label.kind := c$dlk_bc_label;                                                                      
                                                                                                              
    = c$did_display_code =                                                                                    
      dump_label.kind := c$dlk_did_label;                                                                     
      three_characters.together := edd_label_p^.second_parameter;                                             
      first_ascii_char := convert_display_to_ascii (three_characters.first_character);                        
      second_ascii_char := convert_display_to_ascii (three_characters.second_character);                      
      third_ascii_char := convert_display_to_ascii (three_characters.third_character);                        
      STRINGREP (dump_label.edd_revision_level, length, first_ascii_char, second_ascii_char,                  
            third_ascii_char);                                                                                
                                                                                                              
    = c$pmr_display_code, c$pr0_display_code, c$pr1_display_code,                                             
          c$pxp_display_code, c$px0_display_code, c$px1_display_code,                                         
          c$jps_display_code, c$jp0_display_code, c$jp1_display_code,                                         
          c$mps_display_code, c$mp0_display_code, c$mp1_display_code =                                        
      CASE edd_label_p^.code.value OF                                                                         
      = c$pmr_display_code =                                                                                  
        dump_label.kind := c$dlk_pmr_label;                                                                   
      = c$pr0_display_code =                                                                                  
        dump_label.kind := c$dlk_pr0_label;                                                                   
      = c$pr1_display_code =                                                                                  
        dump_label.kind := c$dlk_pr1_label;                                                                   
      = c$pxp_display_code =                                                                                  
        dump_label.kind := c$dlk_pxp_label;                                                                   
      = c$px0_display_code =                                                                                  
        dump_label.kind := c$dlk_px0_label;                                                                   
      = c$px1_display_code =                                                                                  
        dump_label.kind := c$dlk_px1_label;                                                                   
      = c$jps_display_code =                                                                                  
        dump_label.kind := c$dlk_jps_label;                                                                   
      = c$jp0_display_code =                                                                                  
        dump_label.kind := c$dlk_jp0_label;                                                                   
      = c$jp1_display_code =                                                                                  
        dump_label.kind := c$dlk_jp1_label;                                                                   
      = c$mps_display_code =                                                                                  
        dump_label.kind := c$dlk_mps_label;                                                                   
      = c$mp0_display_code =                                                                                  
        dump_label.kind := c$dlk_mp0_label;                                                                   
      ELSE  { = c$mp1_display_code = }                                                                        
        dump_label.kind := c$dlk_mp1_label;                                                                   
      CASEND;                                                                                                 
      IF (edd_label_p^.zero_parameter < c$zero_display_code) OR                                               
            (edd_label_p^.zero_parameter > (c$zero_display_code + duc$de_maximum_mci_port)) THEN              
        dump_label.radial_mci := 0;                                                                           
      ELSE                                                                                                    
        dump_label.radial_mci := edd_label_p^.zero_parameter - c$zero_display_code;                           
      IFEND;                                                                                                  
                                                                                                              
    = c$mmr_display_code =                                                                                    
      dump_label.kind := c$dlk_mmr_label;                                                                     
                                                                                                              
    = c$mem_display_code =                                                                                    
      dump_label.kind := c$dlk_mem_label;                                                                     
      dump_label.first_word_address := edd_label_p^.first_parameter * 200(16);                                
      dump_label.length := edd_label_p^.second_parameter * 200(16);                                           
                                                                                                              
    = c$cpt_display_code =                                                                                    
      dump_label.kind := c$dlk_cpt_label;                                                                     
      dump_label.page_size_mask := edd_label_p^.first_parameter;                                              
      dump_label.page_table_length := edd_label_p^.second_parameter;                                          
                                                                                                              
    = c$ccm_display_code =                                                                                    
      dump_label.kind := c$dlk_ccm_label;                                                                     
      dump_label.page_number := (edd_label_p^.first_parameter * 40000(16)) + edd_label_p^.second_parameter;   
                                                                                                              
    = c$imr_display_code =                                                                                    
      dump_label.kind := c$dlk_imr_label;                                                                     
                                                                                                              
    = c$im1_display_code =                                                                                    
      dump_label.kind := c$dlk_im1_label;                                                                     
                                                                                                              
    = c$prf_display_code =                                                                                    
      dump_label.kind := c$dlk_prf_label;                                                                     
      dump_label.register_file_size := edd_label_p^.second_parameter;                                         
                                                                                                              
    = c$pcs_display_code =                                                                                    
      dump_label.kind := c$dlk_pcs_label;                                                                     
      shadow_bit.data := edd_label_p^.first_parameter;                                                        
      dump_label.shadow_control_store := shadow_bit.shadow_control_store;                                     
      dump_label.number_of_128_bit_regs := edd_label_p^.second_parameter;                                     
                                                                                                              
    ELSE                                                                                                      
      IF (edd_label_p^.code.first_character = c$i_display_code) OR                                            
            (edd_label_p^.code.first_character = c$s_display_code) THEN                                       
        dump_label.kind := c$dlk_iom_label;                                                                   
        max_pp_memories := duc$de_max_pp_memories;                                                            
      ELSEIF edd_label_p^.code.first_character = c$j_display_code THEN                                        
        dump_label.kind := c$dlk_jom_label;                                                                   
        max_pp_memories := duc$de_max_pp_memories;                                                            
      ELSEIF edd_label_p^.code.first_character = c$d_display_code THEN                                        
        dump_label.kind := c$dlk_dom_label;                                                                   
        max_pp_memories := duc$de_max_cio_pp_memories;                                                        
      ELSEIF edd_label_p^.code.first_character = c$e_display_code THEN                                        
        dump_label.kind := c$dlk_eom_label;                                                                   
        max_pp_memories := duc$de_max_cio_pp_memories;                                                        
      ELSE                                                                                                    
        dump_label.kind := c$dlk_other_label;                                                                 
      IFEND;                                                                                                  
                                                                                                              
      IF dump_label.kind <> c$dlk_other_label THEN                                                            
        IF (edd_label_p^.code.second_character <= c$nine_display_code) AND                                    
              (edd_label_p^.code.second_character >= c$zero_display_code) AND                                 
              (edd_label_p^.code.third_character <= c$nine_display_code) AND                                  
              (edd_label_p^.code.third_character >= c$zero_display_code) THEN                                 
          pp_number := ((edd_label_p^.code.second_character - c$zero_display_code) * 8) +                     
                edd_label_p^.code.third_character - c$zero_display_code;                                      
          IF pp_number > max_pp_memories THEN                                                                 
            osp$set_status_abnormal (duc$dump_analyzer_id, due$dump_file_format_error, v$file_name_p^,        
                  local_status);                                                                              
            osp$append_status_parameter (osc$status_parameter_delimiter, 'PP number is out of range.',        
                  local_status);                                                                              
            dup$display_message (local_status, v$display_control);                                            
            dump_label.kind := c$dlk_ill_formatted_label;                                                     
          ELSE                                                                                                
            IF (dump_label.kind = c$dlk_iom_label) OR (dump_label.kind = c$dlk_jom_label) THEN                
              dump_label.pp_number := pp_number;                                                              
            ELSE  {(dump_label.kind = c$dlk_dom_label) OR (dump_label.kind = c$dlk_eom_label)                 
              dump_label.cio_pp_number := pp_number;                                                          
            IFEND;                                                                                            
          IFEND;                                                                                              
        ELSE                                                                                                  
          dump_label.kind := c$dlk_other_label;                                                               
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
      IF dump_label.kind = c$dlk_other_label THEN                                                             
        IF edd_label_p^.zero_parameter = 20(8) THEN                                                           
          dump_label.record_type := duc$de_ort_report;                                                        
          dump_label.header_line_count := edd_label_p^.first_parameter;                                       
          dump_label.report_record_length := edd_label_p^.second_parameter;                                   
        ELSE                                                                                                  
          dump_label.record_type := duc$de_ort_dump;                                                          
          dump_label.header_line_count := 0;                                                                  
          dump_label.report_record_length := 0;                                                               
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
    CASEND;                                                                                                   
                                                                                                              
    first_ascii_char := convert_display_to_ascii (edd_label_p^.code.first_character);                         
    second_ascii_char := convert_display_to_ascii (edd_label_p^.code.second_character);                       
    third_ascii_char := convert_display_to_ascii (edd_label_p^.code.third_character);                         
    STRINGREP (dump_label.record_name, length, first_ascii_char, second_ascii_char, third_ascii_char);        
                                                                                                              
  PROCEND process_label_record;                                                                               
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'read_buffer_controlware', EJECT ??                                                            
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure reads the buffer controlware from the dump file and places it on the restart file.  The    
{   controlware data on the dump file is contained in groups of 8-bits of valid data in every 12-bit group.   
{   Only the 8-bits are moved to the restart file.                                                            
                                                                                                              
  PROCEDURE read_buffer_controlware                                                                           
    (VAR dump_label: t$dump_label;                                                                            
     VAR status: ost$status);                                                                                 
                                                                                                              
    CONST                                                                                                     
      c$7154_controlware_size = 8192,                                                                         
      c$7154_buffer_size = 12300,                                                                             
      c$7154_number_of_blocks = 4,                                                                            
                                                                                                              
      c$isd_controlware_size = 16384,                                                                         
      c$isd_buffer_size = 24600,                                                                              
      c$isd_number_of_blocks = 7,                                                                             
                                                                                                              
      c$7155_controlware_size = 16384,                                                                        
      c$7155_buffer_size = 24600,                                                                             
      c$7155_number_of_blocks = 7,                                                                            
                                                                                                              
      c$ismt_controlware_size = 71680,                                                                        
      c$ismt_buffer_size = 107520,                                                                            
      c$ismt_number_of_blocks = 28,                                                                           
                                                                                                              
      c$895_controlware_size = 32768,                                                                         
      c$895_buffer_size = 49200,                                                                              
      c$895_number_of_blocks = 13,                                                                            
                                                                                                              
      c$largest_number_of_blocks = 28;                                                                        
                                                                                                              
    TYPE                                                                                                      
      t$controlware_definition = PACKED RECORD                                                                
        fill1: 0 .. 0f(16),                                                                                   
        channel_type: 0 .. 0ff(16),                                                                           
        fill2: 0 .. 0ffff(16),                                                                                
        channel_number_upper: 0 .. 3(16),                                                                     
        channel_number_lower: 0 .. 3f(16),                                                                    
      RECEND,                                                                                                 
                                                                                                              
      t$eight_in_twelve = PACKED RECORD                                                                       
        fill: 0 .. 0f(16),                                                                                    
        data: 0 .. 0ff(16),                                                                                   
      RECEND;                                                                                                 
                                                                                                              
    VAR                                                                                                       
      buffer_controlware_entry_p: ^dut$de_buffer_controlware_entry,                                           
      bytes_read: amt$transfer_count,                                                                         
      channel: 0 .. duc$de_maximum_channels,                                                                  
      channel_type: dut$de_channel_type,                                                                      
      controlware_definition_p: ^t$controlware_definition,                                                    
      controlware_size: 0 .. (2 * duc$de_maximum_bc_size),                                                    
      data_buffer_array_p: ^PACKED ARRAY [ * ] OF t$eight_in_twelve,                                          
      data_buffer_p: ^SEQ ( * ),                                                                              
      data_buffer_seq_p: ^SEQ ( * ),                                                                          
      first_pass: boolean,                                                                                    
      index: 0 .. (2 * duc$de_maximum_bc_size),                                                               
      number_of_blocks: 1 .. 28,                                                                              
      restart_file_array_p: ^ARRAY [ * ] OF 0 .. 0ff(16),                                                     
      total_bytes_read: amt$transfer_count;                                                                   
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    ofp$display_status_message ('reading channel buffer controlware', status);                                
                                                                                                              
    first_pass := TRUE;                                                                                       
                                                                                                              
    PUSH data_buffer_seq_p: [[REP (c$largest_number_of_blocks * c$edd_tape_block_size) OF cell]];             
    IF data_buffer_seq_p = NIL THEN                                                                           
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    total_bytes_read := 0;                                                                                    
                                                                                                              
    WHILE TRUE DO                                                                                             
                                                                                                              
      RESET data_buffer_seq_p;                                                                                
                                                                                                              
      { Read the first block of the controlware.                                                              
                                                                                                              
      NEXT data_buffer_p: [[REP c$edd_tape_block_size OF cell]] IN data_buffer_seq_p;                         
      IF data_buffer_p = NIL THEN                                                                             
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      RESET data_buffer_p;                                                                                    
                                                                                                              
      get_next_data (c$edd_tape_block_size, data_buffer_p, bytes_read, status);                               
      IF NOT status.normal THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      IF (bytes_read = 0) OR (v$file_position = amc$eoi) THEN                                                 
        IF first_pass THEN                                                                                    
          osp$set_status_abnormal (duc$dump_analyzer_id, due$unexpected_eoi, v$file_name_p^, status);         
          osp$append_status_parameter (osc$status_parameter_delimiter, 'the buffer controlware', status);     
        IFEND;                                                                                                
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      { If the next EDD label has been read, process the label and return.                                    
                                                                                                              
      IF bytes_read = #SIZE (t$edd_label) THEN                                                                
        process_label_record (data_buffer_p, dump_label);                                                     
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      total_bytes_read := total_bytes_read + bytes_read;                                                      
                                                                                                              
      { Get the controlware size from the first couple of bytes of the first block.                           
                                                                                                              
      RESET data_buffer_p;                                                                                    
      NEXT controlware_definition_p IN data_buffer_p;                                                         
      IF controlware_definition_p = NIL THEN                                                                  
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      IF controlware_definition_p^.channel_type = duc$de_isd_adapter THEN                                     
        controlware_size := c$isd_controlware_size;                                                           
        number_of_blocks := c$isd_number_of_blocks;                                                           
      ELSEIF controlware_definition_p^.channel_type = duc$de_7155_adapter THEN                                
        controlware_size := c$7155_controlware_size;                                                          
        number_of_blocks := c$7155_number_of_blocks;                                                          
      ELSEIF controlware_definition_p^.channel_type = duc$de_ismt_adapter THEN                                
        controlware_size := c$ismt_controlware_size;                                                          
        number_of_blocks := c$ismt_number_of_blocks;                                                          
      ELSEIF controlware_definition_p^.channel_type = duc$de_895_adapter THEN                                 
        controlware_size := c$895_controlware_size;                                                           
        number_of_blocks := c$895_number_of_blocks;                                                           
      ELSEIF controlware_definition_p^.channel_type = duc$de_7154_adapter THEN                                
        controlware_size := c$7154_controlware_size;                                                          
        number_of_blocks := c$7154_number_of_blocks;                                                          
      ELSE                                                                                                    
        osp$set_status_abnormal (duc$dump_analyzer_id, due$bad_buffer_controlware, '', status);               
        dup$display_message (status, v$display_control);                                                      
        status.normal := TRUE;                                                                                
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      { Convert the channel number from display code.                                                         
                                                                                                              
      CASE controlware_definition_p^.channel_number_upper OF                                                  
      = 0 =                                                                                                   
        channel := 1;                                                                                         
      = 1 =                                                                                                   
        channel := 2;                                                                                         
      = 2 =                                                                                                   
        channel := 3;                                                                                         
      = 3 =                                                                                                   
        channel := 0;                                                                                         
      ELSE                                                                                                    
        channel := 0;                                                                                         
      CASEND;                                                                                                 
      channel := channel * 8 + controlware_definition_p^.channel_number_lower - 33(8);                        
      channel_type := controlware_definition_p^.channel_type;                                                 
                                                                                                              
      { Read the rest of the full blocks of controlware.                                                      
                                                                                                              
      FOR index := 2 TO number_of_blocks DO                                                                   
        NEXT data_buffer_p: [[REP c$edd_tape_block_size OF cell]] IN data_buffer_seq_p;                       
        IF data_buffer_p = NIL THEN                                                                           
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
                                                                                                              
        get_next_data (c$edd_tape_block_size, data_buffer_p, bytes_read, status);                             
        IF NOT status.normal THEN                                                                             
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
                                                                                                              
        IF (bytes_read = 0) OR ((v$file_position = amc$eoi) AND (index <> number_of_blocks)) THEN             
          osp$set_status_abnormal (duc$dump_analyzer_id, due$unexpected_eoi, v$file_name_p^, status);         
          osp$append_status_parameter (osc$status_parameter_delimiter, 'the buffer controlware', status);     
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
        total_bytes_read := total_bytes_read + bytes_read;                                                    
      FOREND;                                                                                                 
      v$last_other_record_p^.size := total_bytes_read;                                                        
                                                                                                              
      { Move the controlware to the restart file.  Each 8-bit piece is embedded, right justified, into a      
      { 12-bit PP byte.  Move just the 8-bit piece of each 12-bit PP byte.                                    
                                                                                                              
      RESET data_buffer_seq_p;                                                                                
      NEXT data_buffer_array_p: [1 .. controlware_size] IN data_buffer_seq_p;                                 
      IF data_buffer_array_p = NIL THEN                                                                       
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      NEXT restart_file_array_p: [1 .. controlware_size] IN                                                   
            duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                          
      IF restart_file_array_p = NIL THEN                                                                      
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      FOR index := 1 TO controlware_size DO                                                                   
        restart_file_array_p^ [index] := data_buffer_array_p^ [index].data;                                   
      FOREND;                                                                                                 
                                                                                                              
      NEXT buffer_controlware_entry_p IN                                                                      
            duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                          
      IF buffer_controlware_entry_p = NIL THEN                                                                
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      IF NOT duv$dump_environment_p^.buffer_controlware.available THEN                                        
        duv$dump_environment_p^.buffer_controlware.available := TRUE;                                         
        duv$dump_environment_p^.buffer_controlware.first_bc_entry := #OFFSET (buffer_controlware_entry_p);    
      ELSE                                                                                                    
        v$last_bc_entry_p^.next_bc_entry := #OFFSET (buffer_controlware_entry_p);                             
      IFEND;                                                                                                  
      v$last_bc_entry_p := buffer_controlware_entry_p;                                                        
      duv$dump_environment_p^.buffer_controlware.number_of_entries :=                                         
            duv$dump_environment_p^.buffer_controlware.number_of_entries + 1;                                 
      buffer_controlware_entry_p^.channel_number := channel;                                                  
      buffer_controlware_entry_p^.channel_type := channel_type;                                               
      buffer_controlware_entry_p^.words := controlware_size DIV 2;                                            
      buffer_controlware_entry_p^.first_byte := #OFFSET (restart_file_array_p);                               
      buffer_controlware_entry_p^.next_bc_entry := 0;                                                         
                                                                                                              
      { Return if finished reading the controlware.                                                           
                                                                                                              
      IF v$file_position = amc$eoi THEN                                                                       
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      first_pass := FALSE;                                                                                    
    WHILEND;                                                                                                  
                                                                                                              
  PROCEND read_buffer_controlware;                                                                            
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'read_central_memory', EJECT ??                                                                
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure reads the central memory from the dump file and places it on the memory file.              
                                                                                                              
  PROCEDURE read_central_memory                                                                               
    (VAR dump_label: t$dump_label;                                                                            
     VAR status: ost$status);                                                                                 
                                                                                                              
    CONST                                                                                                     
      c$max_byte_length = 0ffffffff(16);                                                                      
                                                                                                              
    VAR                                                                                                       
      bytes_read: amt$transfer_count,                                                                         
      current_block_index: integer,                                                                           
      data_buffer_p: ^SEQ ( * ),                                                                              
      data_buffer_seq: SEQ (REP c$edd_tape_block_size OF cell),                                               
      data_buffer_seq_p: ^SEQ ( * ),                                                                          
      display_message: string (ofc$max_display_message),                                                      
      first_word_address: 0 .. 0fffffff(16),                                                                  
      local_status: ost$status,                                                                               
      memory_file_p: ^SEQ ( * ),                                                                              
      message_length: integer,                                                                                
      total_block_length: integer,                                                                            
      total_bytes_read: integer;                                                                              
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    ofp$display_status_message ('reading central memory', status);                                            
                                                                                                              
    { Determine the total number of tape blocks that need to be read.                                         
                                                                                                              
    IF dump_label.length = 0 THEN                                                                             
      total_block_length := c$max_byte_length DIV c$edd_tape_block_size;                                      
    ELSE                                                                                                      
      total_block_length := (dump_label.length * 8) DIV c$edd_tape_block_size;                                
      IF ((dump_label.length * 8) MOD c$edd_tape_block_size) <> 0 THEN                                        
        total_block_length := total_block_length + 1;                                                         
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    first_word_address := dump_label.first_word_address;                                                      
                                                                                                              
    { Retrieve the offset into the memory file of where the memory data will be placed.                       
                                                                                                              
    NEXT memory_file_p: [[REP 1 OF cell]] IN                                                                  
          duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                            
    IF memory_file_p = NIL THEN                                                                               
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    RESET memory_file_p;                                                                                      
    duv$dump_environment_p^.central_memory.bias := #OFFSET (memory_file_p);                                   
    RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO memory_file_p;           
                                                                                                              
    mmp$set_access_selections (duv$execution_environment.restart_file.segment_pointer.sequence_pointer,       
          mmc$as_sequential, local_status);                                                                   
    IF NOT local_status.normal THEN                                                                           
      dup$display_message (local_status, v$display_control);                                                  
    IFEND;                                                                                                    
                                                                                                              
    data_buffer_seq_p := ^data_buffer_seq;                                                                    
    IF data_buffer_seq_p = NIL THEN                                                                           
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Move the data from the dump file to the memory file.                                                    
                                                                                                              
    total_bytes_read := 0;                                                                                    
                                                                                                              
   /read_memory/                                                                                              
    FOR current_block_index := 1 TO total_block_length DO                                                     
      IF (current_block_index MOD 10) = 0 THEN                                                                
        STRINGREP (display_message, message_length, 'reading central memory block', current_block_index,      
              ' of', total_block_length);                                                                     
        ofp$display_status_message (display_message (1, message_length), local_status);                       
      IFEND;                                                                                                  
                                                                                                              
      RESET data_buffer_seq_p;                                                                                
      get_next_data (c$edd_tape_block_size, data_buffer_seq_p, bytes_read, status);                           
      IF NOT status.normal THEN                                                                               
        EXIT /read_memory/;  {---->                                                                           
      IFEND;                                                                                                  
      IF bytes_read = 0 THEN                                                                                  
        osp$set_status_abnormal (duc$dump_analyzer_id, due$unexpected_eoi, v$file_name_p^, status);           
        osp$append_status_parameter (osc$status_parameter_delimiter, 'the central memory', status);           
        osp$append_status_parameter (osc$status_parameter_delimiter,                                          
              'The central memory image is incomplete.', status);                                             
        EXIT /read_memory/;  {---->                                                                           
      IFEND;                                                                                                  
                                                                                                              
      IF (dump_label.length = 0) AND (bytes_read = #SIZE (t$edd_label)) THEN                                  
        process_label_record (data_buffer_seq_p, dump_label);                                                 
        EXIT /read_memory/;  {---->                                                                           
      IFEND;                                                                                                  
                                                                                                              
      NEXT memory_file_p: [[REP bytes_read OF cell]] IN                                                       
            duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                          
      IF memory_file_p = NIL THEN                                                                             
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        EXIT /read_memory/;  {---->                                                                           
      IFEND;                                                                                                  
      RESET data_buffer_seq_p;                                                                                
      NEXT data_buffer_p: [[REP bytes_read OF cell]] IN data_buffer_seq_p;                                    
      IF data_buffer_p = NIL THEN                                                                             
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        EXIT /read_memory/;  {---->                                                                           
      IFEND;                                                                                                  
      memory_file_p^ := data_buffer_p^;                                                                       
                                                                                                              
      total_bytes_read := total_bytes_read + bytes_read;                                                      
      IF v$file_position = amc$eoi THEN                                                                       
        EXIT /read_memory/;  {---->                                                                           
      IFEND;                                                                                                  
    FOREND /read_memory/;                                                                                     
                                                                                                              
    v$last_other_record_p^.size := total_bytes_read;                                                          
    IF total_bytes_read > 0 THEN                                                                              
      duv$dump_environment_p^.central_memory.available := TRUE;                                               
      duv$dump_environment_p^.central_memory.first_byte := first_word_address * 8;                            
      duv$dump_environment_p^.central_memory.last_byte := duv$dump_environment_p^.central_memory.first_byte + 
            total_bytes_read - 1;                                                                             
    IFEND;                                                                                                    
    mmp$set_access_selections (duv$execution_environment.restart_file.segment_pointer.sequence_pointer,       
          mmc$as_random, local_status);                                                                       
                                                                                                              
  PROCEND read_central_memory;                                                                                
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'read_control_store', EJECT ??                                                                 
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure reads the control store from the dump file and places it on the restart file.              
                                                                                                              
  PROCEDURE read_control_store                                                                                
    (VAR dump_label: t$dump_label;                                                                            
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      bytes_read: amt$transfer_count,                                                                         
      control_store_buffer_p: ^SEQ ( * ),                                                                     
      control_store_size: 0 .. duc$de_control_store_size,                                                     
      control_store_p: ^SEQ ( * ),                                                                            
      current_block_index: 0 .. duc$de_control_store_size,                                                    
      data_buffer_p: ^SEQ ( * ),                                                                              
      data_buffer_seq: SEQ (REP c$edd_tape_block_size OF cell),                                               
      data_buffer_seq_p: ^SEQ ( * ),                                                                          
      processor: 0 .. duc$de_maximum_processors,                                                              
      shadow_control_store: boolean,                                                                          
      total_block_length: 0 .. duc$de_control_store_size,                                                     
      total_bytes_read: amt$transfer_count;                                                                   
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    ofp$display_status_message ('reading processor control store (microcode)', status);                       
    shadow_control_store := dump_label.shadow_control_store;                                                  
                                                                                                              
    { Determine which processor to use.                                                                       
                                                                                                              
   /find_processor/                                                                                           
    FOR processor := 0 TO duc$de_maximum_processors DO                                                        
      IF shadow_control_store THEN                                                                            
        IF NOT duv$dump_environment_p^.control_store.shadow [processor].available THEN                        
          EXIT /find_processor/;  {---->                                                                      
        IFEND;                                                                                                
      ELSE                                                                                                    
        IF NOT duv$dump_environment_p^.control_store.main [processor].available THEN                          
          EXIT /find_processor/;  {---->                                                                      
        IFEND;                                                                                                
      IFEND;                                                                                                  
    FOREND /find_processor/;                                                                                  
                                                                                                              
    { Determine the total number of tape blocks that need to be read.                                         
                                                                                                              
    total_block_length := duc$de_control_store_size * 16 DIV c$edd_tape_block_size;                           
    IF (duc$de_control_store_size *16) MOD c$edd_tape_block_size <> 0 THEN                                    
      total_block_length := total_block_length + 1;                                                           
    IFEND;                                                                                                    
                                                                                                              
    NEXT control_store_p: [[REP 1 OF cell]] IN                                                                
          duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                            
    IF control_store_p = NIL THEN                                                                             
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    RESET control_store_p;                                                                                    
    RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO control_store_p;         
                                                                                                              
    { Move the control store from the dump file to the restart file.                                          
                                                                                                              
    control_store_size := 0;                                                                                  
    data_buffer_seq_p := ^data_buffer_seq;                                                                    
    IF data_buffer_seq_p = NIL THEN                                                                           
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    RESET data_buffer_seq_p;                                                                                  
    total_bytes_read := 0;                                                                                    
                                                                                                              
   /read_cs_blocks/                                                                                           
    FOR current_block_index := 1 TO total_block_length DO                                                     
      RESET data_buffer_seq_p;                                                                                
      get_next_data (c$edd_tape_block_size, data_buffer_seq_p, bytes_read, status);                           
      IF NOT status.normal THEN                                                                               
        EXIT /read_cs_blocks/;  {---->                                                                        
      IFEND;                                                                                                  
                                                                                                              
      IF (bytes_read = 0) OR (v$file_position = amc$eoi) THEN                                                 
        EXIT /read_cs_blocks/;  {---->                                                                        
      IFEND;                                                                                                  
                                                                                                              
      IF bytes_read = #SIZE (t$edd_label) THEN                                                                
        process_label_record (data_buffer_seq_p, dump_label);                                                 
        EXIT /read_cs_blocks/;  {---->                                                                        
      IFEND;                                                                                                  
      total_bytes_read := total_bytes_read + bytes_read;                                                      
                                                                                                              
      NEXT control_store_buffer_p: [[REP bytes_read OF cell]] IN                                              
            duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                          
      IF control_store_buffer_p = NIL THEN                                                                    
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        EXIT /read_cs_blocks/;  {---->                                                                        
      IFEND;                                                                                                  
      RESET data_buffer_seq_p;                                                                                
      NEXT data_buffer_p: [[REP bytes_read OF cell]] IN data_buffer_seq_p;                                    
      IF data_buffer_p = NIL THEN                                                                             
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        EXIT /read_cs_blocks/;  {---->                                                                        
      IFEND;                                                                                                  
      control_store_buffer_p^ := data_buffer_p^;                                                              
                                                                                                              
      control_store_size := control_store_size + bytes_read DIV 16;                                           
    FOREND /read_cs_blocks/;                                                                                  
                                                                                                              
    v$last_other_record_p^.size := total_bytes_read;                                                          
    IF control_store_size > 0 THEN                                                                            
      IF shadow_control_store THEN                                                                            
        duv$dump_environment_p^.control_store.shadow [processor].available := TRUE;                           
        duv$dump_environment_p^.control_store.shadow [processor].size := control_store_size;                  
        duv$dump_environment_p^.control_store.shadow [processor].first_byte := #OFFSET (control_store_p);     
      ELSE                                                                                                    
        duv$dump_environment_p^.control_store.main [processor].available := TRUE;                             
        duv$dump_environment_p^.control_store.main [processor].size := control_store_size;                    
        duv$dump_environment_p^.control_store.main [processor].first_byte := #OFFSET (control_store_p);       
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
  PROCEND read_control_store;                                                                                 
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'read_critical_memory', EJECT ??                                                               
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure reads the critical memory information.                                                     
                                                                                                              
  PROCEDURE read_critical_memory                                                                              
    (VAR dump_label: t$dump_label;                                                                            
     VAR critical_page_table_p: ^ARRAY [0 .. *] OF dut$de_critical_page_entry;                                
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      bytes_read: amt$transfer_count,                                                                         
      ccm_record_p: ^SEQ ( * ),                                                                               
      cxm_record_p: ^SEQ ( * ),                                                                               
      page_number: 0 .. 0ffffffff(16),                                                                        
      save_ccm_record_p: ^SEQ ( * ),                                                                          
      total_bytes_read: amt$transfer_count;                                                                   
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    ofp$display_status_message ('reading critical memory', status);                                           
                                                                                                              
    { Enter the page in the critical page table.                                                              
                                                                                                              
    NEXT ccm_record_p: [[REP 1 OF cell]] IN                                                                   
          duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                            
    IF ccm_record_p = NIL THEN                                                                                
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    save_ccm_record_p := ccm_record_p;                                                                        
    page_number := dump_label.page_number;                                                                    
    RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO ccm_record_p;            
    total_bytes_read := 0;                                                                                    
    cxm_record_p := ccm_record_p;                                                                             
                                                                                                              
   /read_ccm_record/                                                                                          
    REPEAT                                                                                                    
      NEXT ccm_record_p: [[REP c$edd_tape_block_size OF cell]] IN                                             
            duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                          
      IF ccm_record_p = NIL THEN                                                                              
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        EXIT /read_ccm_record/;  {---->                                                                       
      IFEND;                                                                                                  
                                                                                                              
      get_next_data (c$edd_tape_block_size, ccm_record_p, bytes_read, status);                                
      IF NOT status.normal THEN                                                                               
        EXIT /read_ccm_record/;  {---->                                                                       
      IFEND;                                                                                                  
      IF bytes_read = 0 THEN                                                                                  
        osp$set_status_abnormal (duc$dump_analyzer_id, due$unexpected_eoi, v$file_name_p^, status);           
        osp$append_status_parameter (osc$status_parameter_delimiter, 'the critical memory', status);          
        EXIT /read_ccm_record/;  {---->                                                                       
      IFEND;                                                                                                  
                                                                                                              
      IF bytes_read = #SIZE (t$edd_label) THEN                                                                
        RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO ccm_record_p;        
        process_label_record (ccm_record_p, dump_label);                                                      
        EXIT /read_ccm_record/;  {---->                                                                       
      IFEND;                                                                                                  
                                                                                                              
      total_bytes_read := total_bytes_read + bytes_read;                                                      
      IF v$file_position = amc$eoi THEN                                                                       
        EXIT /read_ccm_record/;  {---->                                                                       
      IFEND;                                                                                                  
    UNTIL (bytes_read < c$edd_tape_block_size);  {/read_ccm_record/}                                          
                                                                                                              
    v$last_other_record_p^.size := total_bytes_read;                                                          
    IF total_bytes_read > 0 THEN                                                                              
      RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO cxm_record_p;          
      NEXT cxm_record_p: [[REP duv$dump_environment_p^.critical_memory.page_size OF cell]] IN                 
            duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                          
      IF cxm_record_p = NIL THEN                                                                              
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      duv$dump_environment_p^.critical_memory.current_page_offset := #OFFSET (save_ccm_record_p);             
      critical_page_table_p^ [page_number].available := TRUE;                                                 
      critical_page_table_p^ [page_number].page_offset := #OFFSET (save_ccm_record_p);                        
      IF NOT duv$dump_environment_p^.critical_memory.available THEN                                           
        duv$dump_environment_p^.critical_memory.available := TRUE;                                            
        duv$dump_environment_p^.critical_memory.first_page := #OFFSET (save_ccm_record_p);                    
        duv$dump_environment_p^.critical_memory.first_rma_available :=                                        
              page_number * duv$dump_environment_p^.critical_memory.page_size;                                
        duv$dump_environment_p^.critical_memory.total_ccm_size := 0;                                          
        duv$dump_environment_p^.critical_memory.multiple_ccm_exists := FALSE;                                 
      ELSE                                                                                                    
        duv$dump_environment_p^.critical_memory.multiple_ccm_exists := TRUE;                                  
      IFEND;                                                                                                  
      duv$dump_environment_p^.critical_memory.last_rma_available :=                                           
            ((page_number + 1) * duv$dump_environment_p^.critical_memory.page_size) - 1;                      
      duv$dump_environment_p^.critical_memory.current_page_offset :=                                          
            duv$dump_environment_p^.critical_memory.current_page_offset +                                     
            duv$dump_environment_p^.critical_memory.page_size;                                                
      duv$dump_environment_p^.critical_memory.last_ccm_other_record := #OFFSET (v$last_other_record_p);       
      duv$dump_environment_p^.critical_memory.total_ccm_size :=                                               
            duv$dump_environment_p^.critical_memory.total_ccm_size + total_bytes_read;                        
    IFEND;                                                                                                    
                                                                                                              
  PROCEND read_critical_memory;                                                                               
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'read_critical_page_table', EJECT ??                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure reads the critical page table.                                                             
                                                                                                              
  PROCEDURE read_critical_page_table                                                                          
    (VAR dump_label: t$dump_label;                                                                            
     VAR critical_page_table_p: ^ARRAY [0 .. *] OF dut$de_critical_page_entry;                                
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      bytes_read: amt$transfer_count,                                                                         
      cpt_record_p: ^SEQ ( * ),                                                                               
      index: 0 .. 0ffffffff(16),                                                                              
      number_page_entries: 0 .. 0ffffffff(16),                                                                
      page_mask: 0 .. 7f(16),                                                                                 
      page_table_length: 0 .. 3ffff(16),                                                                      
      total_bytes_read: amt$transfer_count;                                                                   
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    ofp$display_status_message ('reading critical page table', status);                                       
                                                                                                              
    { Calculate the page size based on the page size mask in the CPT record label.                            
                                                                                                              
    duv$dump_environment_p^.critical_memory.page_size := 2048;                                                
    page_mask := dump_label.page_size_mask DIV 4;                                                             
    page_table_length := dump_label.page_table_length;                                                        
                                                                                                              
   /mask_loop/                                                                                                
    FOR index := 1 to 5 DO                                                                                    
      IF page_mask MOD 2 = 1 THEN                                                                             
        EXIT /mask_loop/;  {---->                                                                             
      IFEND;                                                                                                  
      duv$dump_environment_p^.critical_memory.page_size :=                                                    
            duv$dump_environment_p^.critical_memory.page_size * 2;                                            
      page_mask := page_mask DIV 2;                                                                           
    FOREND /mask_loop/;                                                                                       
                                                                                                              
    NEXT cpt_record_p: [[REP 1 OF cell]] IN                                                                   
          duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                            
    IF cpt_record_p = NIL THEN                                                                                
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    duv$dump_environment_p^.critical_memory.cpt_start := #OFFSET (cpt_record_p);                              
    RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO cpt_record_p;            
    total_bytes_read := 0;                                                                                    
                                                                                                              
   /read_cpt_record/                                                                                          
    WHILE TRUE DO                                                                                             
      NEXT cpt_record_p: [[REP c$edd_tape_block_size OF cell]] IN                                             
            duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                          
      IF cpt_record_p = NIL THEN                                                                              
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        EXIT /read_cpt_record/;  {---->                                                                       
      IFEND;                                                                                                  
                                                                                                              
      get_next_data (c$edd_tape_block_size, cpt_record_p, bytes_read, status);                                
      IF NOT status.normal THEN                                                                               
        EXIT /read_cpt_record/;  {---->                                                                       
      IFEND;                                                                                                  
                                                                                                              
      IF (bytes_read = 0) OR (v$file_position = amc$eoi) THEN                                                 
        EXIT /read_cpt_record/;  {---->                                                                       
      IFEND;                                                                                                  
                                                                                                              
      IF bytes_read = #SIZE (t$edd_label) THEN                                                                
        RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO cpt_record_p;        
        process_label_record (cpt_record_p, dump_label);                                                      
        RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO cpt_record_p;        
        EXIT /read_cpt_record/;  {---->                                                                       
      IFEND;                                                                                                  
      total_bytes_read := total_bytes_read + bytes_read;                                                      
                                                                                                              
      IF v$file_position = amc$eoi THEN                                                                       
        EXIT /read_cpt_record/;  {---->                                                                       
      IFEND;                                                                                                  
    WHILEND /read_cpt_record/;                                                                                
                                                                                                              
    v$last_other_record_p^.size := total_bytes_read;                                                          
    duv$dump_environment_p^.critical_memory.page_table_size := page_table_length;                             
    number_page_entries := page_table_length * 64;                                                            
    duv$dump_environment_p^.critical_memory.cpt_end := duv$dump_environment_p^.critical_memory.cpt_start +    
          page_table_length * 8;                                                                              
                                                                                                              
    { Allocate and initialize all critical page entries.                                                      
                                                                                                              
    NEXT critical_page_table_p: [0 .. (number_page_entries - 1)] IN                                           
          duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                            
    IF critical_page_table_p = NIL THEN                                                                       
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    duv$dump_environment_p^.critical_memory.critical_page_table_offset := #OFFSET (critical_page_table_p);    
    FOR index := 0 TO (number_page_entries - 1) DO                                                            
      critical_page_table_p^ [index].available := FALSE;                                                      
    FOREND;                                                                                                   
                                                                                                              
  PROCEND read_critical_page_table;                                                                           
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'read_dump_identifier', EJECT ??                                                               
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure reads the dump identifier from the dump file and places it on the restart file.            
                                                                                                              
  PROCEDURE read_dump_identifier                                                                              
    (VAR dump_label: t$dump_label;                                                                            
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      bytes_read: amt$transfer_count,                                                                         
      data_buffer_p: ^SEQ ( * ),                                                                              
      data_buffer_seq: SEQ (REP c$edd_tape_block_size OF cell),                                               
      data_buffer_seq_p: ^SEQ ( * ),                                                                          
      did_record_p: ^SEQ ( * ),                                                                               
      local_status: ost$status;                                                                               
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    ofp$display_status_message ('reading the dump identifier', status);                                       
                                                                                                              
    mmp$set_access_selections (duv$execution_environment.restart_file.segment_pointer.sequence_pointer,       
          mmc$as_sequential, local_status);                                                                   
    IF NOT local_status.normal THEN                                                                           
      dup$display_message (local_status, v$display_control);                                                  
    IFEND;                                                                                                    
                                                                                                              
    data_buffer_seq_p := ^data_buffer_seq;                                                                    
    IF data_buffer_seq_p = NIL THEN                                                                           
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { By agreement between EDD and *RUN, this record will not exceed a tape block in size - but its size is   
    { not identical between the two dump types.                                                               
                                                                                                              
    RESET data_buffer_seq_p;                                                                                  
    get_next_data (c$edd_tape_block_size, data_buffer_seq_p, bytes_read, status);                             
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF bytes_read = 0 THEN                                                                                    
      osp$set_status_abnormal (duc$dump_analyzer_id, due$unexpected_eoi, v$file_name_p^, status);             
      osp$append_status_parameter (osc$status_parameter_delimiter, 'the dump identifier', status);            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    v$last_other_record_p^.size := bytes_read;                                                                
                                                                                                              
    NEXT did_record_p: [[REP bytes_read OF cell]] IN                                                          
          duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                            
    IF did_record_p = NIL THEN                                                                                
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    RESET data_buffer_seq_p;                                                                                  
    NEXT data_buffer_p: [[REP bytes_read OF cell]] IN data_buffer_seq_p;                                      
    IF data_buffer_p = NIL THEN                                                                               
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    did_record_p^ := data_buffer_p^;                                                                          
                                                                                                              
    duv$dump_environment_p^.dump_identifier.available := TRUE;                                                
    duv$dump_environment_p^.dump_identifier.first_byte := #OFFSET (did_record_p);                             
    duv$dump_environment_p^.dump_identifier.size := bytes_read;                                               
    duv$dump_environment_p^.dump_identifier.edd_revision_level := dump_label.edd_revision_level;              
                                                                                                              
    mmp$set_access_selections (duv$execution_environment.restart_file.segment_pointer.sequence_pointer,       
          mmc$as_random, local_status);                                                                       
                                                                                                              
  PROCEND read_dump_identifier;                                                                               
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'read_exchange_package', EJECT ??                                                              
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure reads the exchange package from the dump file and places it on the restart file.           
                                                                                                              
  PROCEDURE read_exchange_package                                                                             
    (VAR dump_label: t$dump_label;                                                                            
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      bytes_read: amt$transfer_count,                                                                         
      data_buffer_seq: SEQ (REP c$edd_tape_block_size OF cell),                                               
      data_buffer_seq_p: ^SEQ ( * ),                                                                          
      exchange_package_p: ^dut$exchange_package,                                                              
      processor: 0 .. duc$de_maximum_processors;                                                              
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    CASE dump_label.kind OF                                                                                   
    = c$dlk_pxp_label, c$dlk_px0_label, c$dlk_px1_label =                                                     
      ofp$display_status_message ('reading processor exchange package', status);                              
    = c$dlk_jps_label, c$dlk_jp0_label, c$dlk_jp1_label =                                                     
      ofp$display_status_message ('reading job exchange package', status);                                    
    ELSE  { = c$dlk_mps_label, c$dlk_mp0_label, c$dlk_mp1_label = }                                           
      ofp$display_status_message ('reading monitor exchange package', status);                                
    CASEND;                                                                                                   
                                                                                                              
    data_buffer_seq_p := ^data_buffer_seq;                                                                    
    RESET data_buffer_seq_p;                                                                                  
                                                                                                              
    get_next_data (c$edd_tape_block_size, data_buffer_seq_p, bytes_read, status);                             
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF bytes_read = 0 THEN                                                                                    
      osp$set_status_abnormal (duc$dump_analyzer_id, due$unexpected_eoi, v$file_name_p^, status);             
      osp$append_status_parameter (osc$status_parameter_delimiter, 'the exchange package', status);           
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF bytes_read = #SIZE (t$edd_label) THEN                                                                  
      process_label_record (data_buffer_seq_p, dump_label);                                                   
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    v$last_other_record_p^.size := bytes_read;                                                                
                                                                                                              
    IF bytes_read < #SIZE (dut$exchange_package) THEN                                                         
      osp$set_status_abnormal (duc$dump_analyzer_id, due$dump_file_format_error, v$file_name_p^, status);     
      osp$append_status_parameter (osc$status_parameter_delimiter,                                            
            'The processor exchange package record is shorter than expected.', status);                       
      dup$display_message (status, v$display_control);                                                        
      status.normal := TRUE;                                                                                  
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    NEXT exchange_package_p IN data_buffer_seq_p;                                                             
    IF exchange_package_p = NIL THEN                                                                          
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    CASE dump_label.kind OF                                                                                   
    = c$dlk_pxp_label =                                                                                       
                                                                                                              
     /find_active_slot/                                                                                       
      FOR processor := 0 TO duc$de_maximum_processors DO                                                      
        IF NOT duv$dump_environment_p^.active_exchange [processor].available THEN                             
          EXIT /find_active_slot/;  {---->                                                                    
        IFEND;                                                                                                
      FOREND /find_active_slot/;                                                                              
      duv$dump_environment_p^.active_exchange [processor].available := TRUE;                                  
      duv$dump_environment_p^.active_exchange [processor].value := exchange_package_p^;                       
      duv$dump_environment_p^.active_exchange [processor].radial_mci := dump_label.radial_mci;                
                                                                                                              
    = c$dlk_px0_label =                                                                                       
                                                                                                              
      duv$dump_environment_p^.active_exchange [0].available := TRUE;                                          
      duv$dump_environment_p^.active_exchange [0].value := exchange_package_p^;                               
      duv$dump_environment_p^.active_exchange [0].radial_mci := dump_label.radial_mci;                        
                                                                                                              
    = c$dlk_px1_label =                                                                                       
                                                                                                              
      duv$dump_environment_p^.active_exchange [1].available := TRUE;                                          
      duv$dump_environment_p^.active_exchange [1].value := exchange_package_p^;                               
      duv$dump_environment_p^.active_exchange [1].radial_mci := dump_label.radial_mci;                        
                                                                                                              
    = c$dlk_jps_label =                                                                                       
                                                                                                              
     /find_jps_slot/                                                                                          
      FOR processor := 0 TO duc$de_maximum_processors DO                                                      
        IF NOT duv$dump_environment_p^.jps_exchange [processor].available THEN                                
          EXIT /find_jps_slot/;  {---->                                                                       
        IFEND;                                                                                                
      FOREND /find_jps_slot/;                                                                                 
      duv$dump_environment_p^.jps_exchange [processor].available := TRUE;                                     
      duv$dump_environment_p^.jps_exchange [processor].value := exchange_package_p^;                          
      duv$dump_environment_p^.jps_exchange [processor].radial_mci := dump_label.radial_mci;                   
                                                                                                              
    = c$dlk_jp0_label =                                                                                       
                                                                                                              
      duv$dump_environment_p^.jps_exchange [0].available := TRUE;                                             
      duv$dump_environment_p^.jps_exchange [0].value := exchange_package_p^;                                  
      duv$dump_environment_p^.jps_exchange [0].radial_mci := dump_label.radial_mci;                           
                                                                                                              
    = c$dlk_jp1_label =                                                                                       
                                                                                                              
      duv$dump_environment_p^.jps_exchange [1].available := TRUE;                                             
      duv$dump_environment_p^.jps_exchange [1].value := exchange_package_p^;                                  
      duv$dump_environment_p^.jps_exchange [1].radial_mci := dump_label.radial_mci;                           
                                                                                                              
    = c$dlk_mps_label =                                                                                       
                                                                                                              
     /find_mps_slot/                                                                                          
      FOR processor := 0 TO duc$de_maximum_processors DO                                                      
        IF NOT duv$dump_environment_p^.mps_exchange [processor].available THEN                                
          EXIT /find_mps_slot/;  {---->                                                                       
        IFEND;                                                                                                
      FOREND /find_mps_slot/;                                                                                 
      duv$dump_environment_p^.mps_exchange [processor].available := TRUE;                                     
      duv$dump_environment_p^.mps_exchange [processor].value := exchange_package_p^;                          
      duv$dump_environment_p^.mps_exchange [processor].radial_mci := dump_label.radial_mci;                   
                                                                                                              
    = c$dlk_mp0_label =                                                                                       
                                                                                                              
      duv$dump_environment_p^.mps_exchange [0].available := TRUE;                                             
      duv$dump_environment_p^.mps_exchange [0].value := exchange_package_p^;                                  
      duv$dump_environment_p^.mps_exchange [0].radial_mci := dump_label.radial_mci;                           
                                                                                                              
    ELSE  { = c$dlk_mp1_label = }                                                                             
                                                                                                              
      duv$dump_environment_p^.mps_exchange [1].available := TRUE;                                             
      duv$dump_environment_p^.mps_exchange [1].value := exchange_package_p^;                                  
      duv$dump_environment_p^.mps_exchange [1].radial_mci := dump_label.radial_mci;                           
    CASEND;                                                                                                   
                                                                                                              
  PROCEND read_exchange_package;                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'read_label_record', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure reads the EDD label from the dump file and produces a dump label.                          
                                                                                                              
  PROCEDURE read_label_record                                                                                 
    (VAR dump_label: t$dump_label;                                                                            
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      bytes_read: amt$transfer_count,                                                                         
      display_message: boolean,                                                                               
      label_buffer_seq: SEQ (REP c$edd_tape_block_size OF cell),                                              
      label_buffer_seq_p: ^SEQ ( * );                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
    label_buffer_seq_p := ^label_buffer_seq;                                                                  
    display_message := TRUE;                                                                                  
                                                                                                              
    WHILE TRUE DO                                                                                             
      RESET label_buffer_seq_p;                                                                               
      get_next_data (c$edd_tape_block_size, label_buffer_seq_p, bytes_read, status);                          
      IF NOT status.normal THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      IF (bytes_read = 0) OR (v$file_position = amc$eoi) THEN                                                 
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      IF bytes_read = #SIZE (t$edd_label) THEN                                                                
        process_label_record (label_buffer_seq_p, dump_label);                                                
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      IF display_message THEN                                                                                 
        osp$set_status_abnormal (duc$dump_analyzer_id, due$dump_file_format_error, v$file_name_p^, status);   
        osp$append_status_parameter (osc$status_parameter_delimiter,                                          
              'A header record is not an expected size.', status);                                            
        dup$display_message (status, v$display_control);                                                      
        status.normal := TRUE;                                                                                
        display_message := FALSE;                                                                             
      IFEND;                                                                                                  
    WHILEND;                                                                                                  
                                                                                                              
  PROCEND read_label_record;                                                                                  
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'read_maintenance_registers', EJECT ??                                                         
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure reads the maintenance registers from the dump file and places them on the restart file.    
                                                                                                              
  PROCEDURE read_maintenance_registers                                                                        
    (VAR dump_label: t$dump_label;                                                                            
     VAR status: ost$status);                                                                                 
                                                                                                              
    TYPE                                                                                                      
      t$register_id = PACKED RECORD                                                                           
        length: 0 .. 0fff(16),                                                                                
        number: 0 .. 0fff(16)                                                                                 
      RECEND;                                                                                                 
                                                                                                              
    VAR                                                                                                       
      byte_count: integer,                                                                                    
      bytes_read: amt$transfer_count,                                                                         
      current_byte: 1 .. duc$de_max_register_length,                                                          
      current_part: 1 .. duc$de_max_register_parts,                                                           
      current_register_length: 0 .. duc$de_max_register_length,                                               
      current_register_offset: 0 .. duc$de_max_register_length,                                               
      data_buffer_seq: SEQ (REP c$edd_tape_block_size OF cell),                                               
      data_buffer_seq_p: ^SEQ ( * ),                                                                          
      maintenance_registers_p: ^ARRAY [ * ] OF dut$de_maintenance_register,                                   
      number_of_register_parts: 0 .. 0fff(16),                                                                
      offset: 0 .. (duc$de_max_register_length * duc$de_max_register_parts),                                  
      processor: 0 .. duc$de_maximum_processors,                                                              
      register_contents_p: ^PACKED ARRAY [ * ] OF 0 .. 0fff(16),                                              
      register_id_p: ^t$register_id,                                                                          
      register_index: 1 .. duc$de_max_register_number,                                                        
      remaining_register: 1 .. (duc$de_max_register_number + 1),                                              
      zero_register: [STATIC, READ] ARRAY [1 .. duc$de_max_register_length] OF 0 .. 0ff(16) :=                
            [REP duc$de_max_register_length OF 0];                                                            
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    CASE dump_label.kind OF                                                                                   
    = c$dlk_pmr_label, c$dlk_pr0_label, c$dlk_pr1_label =                                                     
      ofp$display_status_message ('reading processor maintenance registers', status);                         
    = c$dlk_imr_label =                                                                                       
      ofp$display_status_message ('reading IOU maintenance registers', status);                               
    = c$dlk_im1_label =                                                                                       
      ofp$display_status_message ('reading secondary IOU maintenance registers', status);                     
    ELSE  { = c$dlk_mmr_label = }                                                                             
      ofp$display_status_message ('reading memory maintenance registers', status);                            
    CASEND;                                                                                                   
                                                                                                              
    data_buffer_seq_p := ^data_buffer_seq;                                                                    
    RESET data_buffer_seq_p;                                                                                  
                                                                                                              
    get_next_data (c$edd_tape_block_size, data_buffer_seq_p, bytes_read, status);                             
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF bytes_read = 0 THEN                                                                                    
      osp$set_status_abnormal (duc$dump_analyzer_id, due$unexpected_eoi, v$file_name_p^, status);             
      osp$append_status_parameter (osc$status_parameter_delimiter, 'the maintenance registers', status);      
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF bytes_read = #SIZE (t$edd_label) THEN                                                                  
      process_label_record (data_buffer_seq_p, dump_label);                                                   
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    v$last_other_record_p^.size := bytes_read;                                                                
                                                                                                              
    byte_count := 0;                                                                                          
    current_part := 1;                                                                                        
                                                                                                              
    CASE dump_label.kind OF                                                                                   
    = c$dlk_pmr_label, c$dlk_pr0_label, c$dlk_pr1_label =                                                     
      PUSH maintenance_registers_p: [1 .. duc$de_number_of_pro_mrs_dumped];                                   
    = c$dlk_imr_label, c$dlk_im1_label =                                                                      
      PUSH maintenance_registers_p: [1 .. duc$de_number_of_iou_mrs_dumped];                                   
    ELSE  { = c$dlk_mmr_label = }                                                                             
      PUSH maintenance_registers_p: [1 .. duc$de_number_of_mem_mrs_dumped];                                   
    CASEND;                                                                                                   
    IF maintenance_registers_p = NIL THEN                                                                     
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    RESET data_buffer_seq_p;                                                                                  
                                                                                                              
   /read_registers/                                                                                           
    FOR register_index := 1 TO UPPERBOUND (maintenance_registers_p^) DO                                       
                                                                                                              
      maintenance_registers_p^ [register_index].available := FALSE;                                           
      maintenance_registers_p^ [register_index].value := zero_register;                                       
                                                                                                              
      IF current_part = 1 THEN                                                                                
        NEXT register_id_p IN data_buffer_seq_p;                                                              
        IF (register_id_p = NIL) OR (register_id_p^.length = 0) OR                                            
              (register_id_p^.number > duc$de_max_register_number) THEN                                       
          EXIT /read_registers/;  {---->                                                                      
        IFEND;                                                                                                
        NEXT register_contents_p: [1 .. register_id_p^.length] IN data_buffer_seq_p;                          
        IF register_contents_p = NIL THEN                                                                     
          EXIT /read_registers/;  {---->                                                                      
        IFEND;                                                                                                
        number_of_register_parts := register_id_p^.length DIV duc$de_max_register_length;                     
        IF (register_id_p^.length MOD duc$de_max_register_length) <> 0 THEN                                   
          number_of_register_parts := number_of_register_parts + 1;                                           
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
      IF current_part = number_of_register_parts THEN                                                         
        current_register_length := register_id_p^.length MOD duc$de_max_register_length;                      
        IF current_register_length = 0 THEN                                                                   
          current_register_length := duc$de_max_register_length;                                              
        IFEND;                                                                                                
      ELSE                                                                                                    
        current_register_length := duc$de_max_register_length;                                                
      IFEND;                                                                                                  
                                                                                                              
      maintenance_registers_p^ [register_index].available := TRUE;                                            
      maintenance_registers_p^ [register_index].number := register_id_p^.number;                              
      maintenance_registers_p^ [register_index].length := current_register_length;                            
                                                                                                              
      current_register_offset := duc$de_max_register_length - current_register_length;                        
      offset := current_register_offset + ((current_part - 1) * duc$de_max_register_length);                  
      FOR current_byte := 1 TO current_register_length DO                                                     
        maintenance_registers_p^ [register_index].value [current_byte + current_register_offset] :=           
              register_contents_p^ [current_byte + offset];                                                   
      FOREND;                                                                                                 
                                                                                                              
      IF current_part = number_of_register_parts THEN                                                         
        current_part := 1;                                                                                    
        byte_count := byte_count + (((register_id_p^.length + 2) * 3) DIV 2);                                 
        IF byte_count >= bytes_read THEN                                                                      
          EXIT /read_registers/;  {---->                                                                      
        IFEND;                                                                                                
      ELSE                                                                                                    
        current_part := current_part + 1;                                                                     
      IFEND;                                                                                                  
                                                                                                              
    FOREND /read_registers/;                                                                                  
                                                                                                              
    FOR remaining_register := (register_index) + 1 TO UPPERBOUND (maintenance_registers_p^) DO                
      maintenance_registers_p^ [remaining_register].available := FALSE;                                       
    FOREND;                                                                                                   
                                                                                                              
    CASE dump_label.kind OF                                                                                   
    = c$dlk_pmr_label =                                                                                       
                                                                                                              
     /find_processor/                                                                                         
      FOR processor := 0 TO duc$de_maximum_processors DO                                                      
        IF NOT duv$dump_environment_p^.pro_maintenance_registers [processor].available THEN                   
          EXIT /find_processor/;  {---->                                                                      
        IFEND;                                                                                                
      FOREND /find_processor/;                                                                                
      duv$dump_environment_p^.pro_maintenance_registers [processor].available := TRUE;                        
      duv$dump_environment_p^.pro_maintenance_registers [processor].registers := maintenance_registers_p^;    
      duv$dump_environment_p^.pro_maintenance_registers [processor].radial_mci := dump_label.radial_mci;      
                                                                                                              
    = c$dlk_pr0_label =                                                                                       
                                                                                                              
      duv$dump_environment_p^.pro_maintenance_registers [0].available := TRUE;                                
      duv$dump_environment_p^.pro_maintenance_registers [0].registers := maintenance_registers_p^;            
      duv$dump_environment_p^.pro_maintenance_registers [0].radial_mci := dump_label.radial_mci;              
                                                                                                              
    = c$dlk_pr1_label =                                                                                       
                                                                                                              
      duv$dump_environment_p^.pro_maintenance_registers [1].available := TRUE;                                
      duv$dump_environment_p^.pro_maintenance_registers [1].registers := maintenance_registers_p^;            
      duv$dump_environment_p^.pro_maintenance_registers [1].radial_mci := dump_label.radial_mci;              
                                                                                                              
    = c$dlk_imr_label =                                                                                       
      duv$dump_environment_p^.iou_maintenance_registers [0].available := TRUE;                                
      duv$dump_environment_p^.iou_maintenance_registers [0].registers := maintenance_registers_p^;            
                                                                                                              
    = c$dlk_im1_label =                                                                                       
      duv$dump_environment_p^.iou_maintenance_registers [1].available := TRUE;                                
      duv$dump_environment_p^.iou_maintenance_registers [1].registers := maintenance_registers_p^;            
                                                                                                              
    ELSE  { = c$dlk_mmr_label = }                                                                             
      duv$dump_environment_p^.mem_maintenance_registers.available := TRUE;                                    
      duv$dump_environment_p^.mem_maintenance_registers.registers := maintenance_registers_p^;                
    CASEND;                                                                                                   
                                                                                                              
  PROCEND read_maintenance_registers;                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'read_only_critical_memory', EJECT ??                                                          
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure reads only the critical memory from the dump file and places it on the memory file.        
                                                                                                              
  PROCEDURE read_only_critical_memory                                                                         
    (    critical_page_table_p: ^ARRAY [0 .. *] OF dut$de_critical_page_entry;                                
     VAR dump_label: t$dump_label;                                                                            
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      bytes_read: amt$transfer_count,                                                                         
      cpt_image_p: ^PACKED ARRAY [0 .. *] OF boolean,                                                         
      cpt_p: ^cell,                                                                                           
      current_block_index: integer,                                                                           
      data_buffer: SEQ (REP c$edd_tape_block_size OF cell),                                                   
      data_buffer_p: ^SEQ ( * ),                                                                              
      data_p: ^SEQ ( * ),                                                                                     
      data_transfer_amount: amt$transfer_count,                                                               
      display_message: string (ofc$max_display_message),                                                      
      memory_data_p: ^SEQ ( * ),                                                                              
      memory_file_p: ^SEQ ( * ),                                                                              
      message_length: integer,                                                                                
      number_page_entries: 0 .. 0ffffffff(16),                                                                
      remainder_to_transfer: 0 .. duc$de_max_page_size,                                                       
      total_bytes_read: amt$transfer_count;                                                                   
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    ofp$display_status_message ('reading critical memory', status);                                           
                                                                                                              
    { Use the critical page table record to determine what pages of central memory to retain on the           
    { memory file.                                                                                            
                                                                                                              
    NEXT memory_file_p: [[REP 1 OF cell]] IN                                                                  
          duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                            
    IF memory_file_p = NIL THEN                                                                               
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    cpt_p := #ADDRESS (#RING (duv$execution_environment.restart_file.segment_pointer.sequence_pointer),       
          #SEGMENT (duv$execution_environment.restart_file.segment_pointer.sequence_pointer),                 
          duv$dump_environment_p^.critical_memory.cpt_start);                                                 
    RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO cpt_p;                   
    number_page_entries := duv$dump_environment_p^.critical_memory.page_table_size * 64;                      
    NEXT cpt_image_p: [0 .. number_page_entries - 1] IN                                                       
          duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                            
    IF cpt_image_p = NIL THEN                                                                                 
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO memory_file_p;           
                                                                                                              
    bytes_read := 0;                                                                                          
    total_bytes_read := 0;                                                                                    
                                                                                                              
    data_buffer_p := ^data_buffer;                                                                            
    IF data_buffer_p = NIL THEN                                                                               
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
   /read_critical_pages/                                                                                      
    FOR current_block_index := 0 TO (number_page_entries - 1) DO                                              
      IF (current_block_index MOD 10) = 0 THEN                                                                
        STRINGREP (display_message, message_length, 'reading critical central memory page',                   
              current_block_index, ' of', (number_page_entries - 1));                                         
        ofp$display_status_message (display_message (1, message_length), status);                             
      IFEND;                                                                                                  
                                                                                                              
      NEXT memory_file_p: [[REP 1 of cell]] IN                                                                
            duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                          
      IF memory_file_p = NIL THEN                                                                             
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        EXIT /read_critical_pages/;  {---->                                                                   
      IFEND;                                                                                                  
      RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO memory_file_p;         
                                                                                                              
      remainder_to_transfer := duv$dump_environment_p^.critical_memory.page_size;                             
      WHILE remainder_to_transfer > 0 DO                                                                      
        IF bytes_read = 0 THEN                                                                                
          IF v$file_position = amc$eoi THEN                                                                   
            EXIT /read_critical_pages/;  {---->                                                               
          IFEND;                                                                                              
          get_next_data (c$edd_tape_block_size, data_buffer_p, bytes_read, status);                           
          IF NOT status.normal THEN                                                                           
            EXIT /read_critical_pages/;  {---->                                                               
          IFEND;                                                                                              
          IF bytes_read = 0 THEN                                                                              
            osp$set_status_abnormal (duc$dump_analyzer_id, due$unexpected_eoi, v$file_name_p^, status);       
            osp$append_status_parameter (osc$status_parameter_delimiter, 'the critical memory', status);      
            EXIT /read_critical_pages/;  {---->                                                               
          IFEND;                                                                                              
          total_bytes_read := total_bytes_read + bytes_read;                                                  
          RESET data_buffer_p;                                                                                
        IFEND;                                                                                                
                                                                                                              
        { Transfer the data in the buffer to the memory file.                                                 
                                                                                                              
        IF remainder_to_transfer >= bytes_read THEN                                                           
          data_transfer_amount := bytes_read;                                                                 
          bytes_read := 0;                                                                                    
        ELSE                                                                                                  
          data_transfer_amount := remainder_to_transfer;                                                      
          bytes_read := bytes_read - data_transfer_amount;                                                    
        IFEND;                                                                                                
        NEXT memory_data_p: [[REP data_transfer_amount OF cell]] IN                                           
              duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                        
        IF memory_data_p = NIL THEN                                                                           
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          EXIT /read_critical_pages/;  {---->                                                                 
        IFEND;                                                                                                
        RESET memory_data_p;                                                                                  
        NEXT data_p: [[REP data_transfer_amount OF cell]] IN data_buffer_p;                                   
        IF data_p = NIL THEN                                                                                  
          osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                        
          EXIT /read_critical_pages/;  {---->                                                                 
        IFEND;                                                                                                
        memory_data_p^ := data_p^;                                                                            
                                                                                                              
        remainder_to_transfer := remainder_to_transfer - data_transfer_amount;                                
      WHILEND;                                                                                                
                                                                                                              
      IF cpt_image_p^ [current_block_index] THEN                                                              
        critical_page_table_p^ [current_block_index].available := TRUE;                                       
        critical_page_table_p^ [current_block_index].page_offset := #OFFSET (memory_file_p);                  
        IF NOT duv$dump_environment_p^.critical_memory.available THEN                                         
          duv$dump_environment_p^.critical_memory.available := TRUE;                                          
          duv$dump_environment_p^.critical_memory.first_page := #OFFSET (memory_file_p);                      
          duv$dump_environment_p^.critical_memory.first_rma_available :=                                      
                (current_block_index - 1) * duv$dump_environment_p^.critical_memory.page_size;                
        IFEND;                                                                                                
      ELSE                                                                                                    
        RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO memory_file_p;       
      IFEND;                                                                                                  
                                                                                                              
    FOREND /read_critical_pages/;                                                                             
                                                                                                              
    v$last_other_record_p^.size := total_bytes_read;                                                          
    duv$dump_environment_p^.critical_memory.last_rma_available :=  (number_page_entries *                     
          duv$dump_environment_p^.critical_memory.page_size) - 1;                                             
                                                                                                              
  PROCEND read_only_critical_memory;                                                                          
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'read_other_record', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure reads other records from the dump file and moves them to the restart file.                 
                                                                                                              
  PROCEDURE read_other_record                                                                                 
    (VAR dump_label: t$dump_label;                                                                            
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      block_count: integer,                                                                                   
      bytes_read: amt$transfer_count,                                                                         
      data_buffer_p: ^SEQ ( * ),                                                                              
      data_buffer_seq: SEQ (REP c$edd_tape_block_size OF cell),                                               
      data_buffer_seq_p: ^SEQ ( * ),                                                                          
      display_message: string (ofc$max_display_message),                                                      
      local_status: ost$status,                                                                               
      message_length: integer,                                                                                
      other_record_entry_p: ^dut$de_other_record_entry,                                                       
      other_record_p: ^SEQ ( * ),                                                                             
      save_dump_label: t$dump_label,                                                                          
      save_first_byte: amt$file_byte_address,                                                                 
      total_bytes_read: integer;                                                                              
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    ofp$display_status_message ('reading other record', status);                                              
                                                                                                              
    other_record_entry_p := v$last_other_record_p;                                                            
                                                                                                              
    NEXT other_record_p: [[REP 1 OF cell]] IN                                                                 
          duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                            
    IF other_record_p = NIL THEN                                                                              
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO other_record_p;          
    save_first_byte := #OFFSET (other_record_p);                                                              
    save_dump_label := dump_label;                                                                            
                                                                                                              
    mmp$set_access_selections (duv$execution_environment.restart_file.segment_pointer.sequence_pointer,       
          mmc$as_sequential, local_status);                                                                   
    IF NOT local_status.normal THEN                                                                           
      dup$display_message (local_status, v$display_control);                                                  
    IFEND;                                                                                                    
                                                                                                              
    data_buffer_seq_p := ^data_buffer_seq;                                                                    
    IF data_buffer_seq_p = NIL THEN                                                                           
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    block_count := 0;                                                                                         
    total_bytes_read := 0;                                                                                    
                                                                                                              
  /move_other_record/                                                                                         
    WHILE TRUE DO                                                                                             
      block_count := block_count + 1;                                                                         
      STRINGREP (display_message, message_length, 'reading  ', other_record_entry_p^.name, '  block ',        
            block_count);                                                                                     
      ofp$display_status_message (display_message (1, message_length), local_status);                         
                                                                                                              
      RESET data_buffer_seq_p;                                                                                
      get_next_data (c$edd_tape_block_size, data_buffer_seq_p, bytes_read, status);                           
      IF NOT status.normal THEN                                                                               
        EXIT /move_other_record/;  {---->                                                                     
      IFEND;                                                                                                  
      IF (bytes_read = 0) AND (v$file_position = amc$eoi) THEN                                                
        EXIT /move_other_record/;  {---->                                                                     
      IFEND;                                                                                                  
                                                                                                              
      IF bytes_read = #SIZE (t$edd_label) THEN                                                                
        process_label_record (data_buffer_seq_p, dump_label);                                                 
        EXIT /move_other_record/;  {---->                                                                     
      IFEND;                                                                                                  
                                                                                                              
      NEXT other_record_p: [[REP bytes_read OF cell]] IN                                                      
            duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                          
      IF other_record_p = NIL THEN                                                                            
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        EXIT /move_other_record/;  {---->                                                                     
      IFEND;                                                                                                  
      RESET data_buffer_seq_p;                                                                                
      NEXT data_buffer_p: [[REP bytes_read OF cell]] IN data_buffer_seq_p;                                    
      IF data_buffer_p = NIL THEN                                                                             
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        EXIT /move_other_record/;  {---->                                                                     
      IFEND;                                                                                                  
      other_record_p^ := data_buffer_p^;                                                                      
                                                                                                              
      total_bytes_read := total_bytes_read + bytes_read;                                                      
      IF v$file_position = amc$eoi THEN                                                                       
        EXIT /move_other_record/;  {---->                                                                     
      IFEND;                                                                                                  
    WHILEND /move_other_record/;                                                                              
                                                                                                              
    other_record_entry_p^.record_type := save_dump_label.record_type;                                         
    IF total_bytes_read > 0 THEN                                                                              
      other_record_entry_p^.first_byte := save_first_byte;                                                    
      other_record_entry_p^.header_line_count := save_dump_label.header_line_count;                           
      other_record_entry_p^.report_record_length := save_dump_label.report_record_length;                     
      other_record_entry_p^.size := total_bytes_read;                                                         
    IFEND;                                                                                                    
                                                                                                              
    mmp$set_access_selections (duv$execution_environment.restart_file.segment_pointer.sequence_pointer,       
          mmc$as_random, local_status);                                                                       
                                                                                                              
  PROCEND read_other_record;                                                                                  
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'read_pp_memory', EJECT ??                                                                     
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure reads the PP memory from the dump file and places it on the restart file.                  
                                                                                                              
  PROCEDURE read_pp_memory                                                                                    
    (VAR dump_label: t$dump_label;                                                                            
     VAR status: ost$status);                                                                                 
                                                                                                              
    TYPE                                                                                                      
      t$r_register = PACKED RECORD                                                                            
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          upper_10: 0 .. 3ff(16),                                                                             
          lower_12: 0 .. 0fff(16),                                                                            
        = FALSE =                                                                                             
          value: 0 .. 3fffff(16),                                                                             
        CASEND,                                                                                               
      RECEND,                                                                                                 
                                                                                                              
      t$r_register_container = PACKED RECORD                                                                  
        fill_22: 0 .. 3fffff(16),                                                                             
        upper_10: 0 .. 3ff(16),                                                                               
        fill_4: 0 .. 0f(16),                                                                                  
        lower_12: 0 .. 0fff(16),                                                                              
      RECEND;                                                                                                 
                                                                                                              
    VAR                                                                                                       
      bytes_read: amt$transfer_count,                                                                         
      data_buffer_p: ^SEQ ( * ),                                                                              
      first_time: boolean,                                                                                    
      index: 1 .. 9,                                                                                          
      iou: 0 .. duc$de_maximum_ious,                                                                          
      iou_class: dut$di_iou_class,                                                                            
      pp_buffer_array_p: ^ARRAY [1 .. *] OF cell,                                                             
      pp_memory_buffer_seq_p: ^SEQ ( * ),                                                                     
      pp_number: 0 .. duc$de_max_pp_memories,                                                                 
      pp_type: dst$channel_protocol_type,                                                                     
      pp_word_size: dut$di_pp_word_size,                                                                      
      r_register: t$r_register,                                                                               
      r_register_container_p: ^t$r_register_container,                                                        
      register: dut$de_maintenance_register,                                                                  
      restart_file_array_p: ^ARRAY [1 .. *] OF cell,                                                          
      restart_file_seq_p: ^SEQ ( * ),                                                                         
      tape_blocks: 3 .. 9,                                                                                    
      total_bytes_read: amt$transfer_count;                                                                   
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    CASE dump_label.kind OF                                                                                   
    = c$dlk_iom_label =                                                                                       
      ofp$display_status_message ('reading pp memory from iou 0', status);                                    
      pp_number := dump_label.pp_number;                                                                      
      pp_type := dsc$cpt_nio;                                                                                 
      iou := 0;                                                                                               
    = c$dlk_jom_label =                                                                                       
      ofp$display_status_message ('reading pp memory from iou 1', status);                                    
      pp_number := dump_label.pp_number;                                                                      
      pp_type := dsc$cpt_nio;                                                                                 
      iou := 1;                                                                                               
    = c$dlk_dom_label =                                                                                       
      ofp$display_status_message ('reading cio pp memory from iou 0', status);                                
      pp_number := dump_label.cio_pp_number;                                                                  
      pp_type := dsc$cpt_cio;                                                                                 
      iou := 0;                                                                                               
    ELSE  { = c$dlk_eom_label = }                                                                             
      ofp$display_status_message ('reading cio pp memory from iou 1', status);                                
      pp_number := dump_label.cio_pp_number;                                                                  
      pp_type := dsc$cpt_cio;                                                                                 
      iou := 1;                                                                                               
    CASEND;                                                                                                   
                                                                                                              
    iou_class := duc$di_ic_iou_4k;                                                                            
    pp_word_size := 4096;                                                                                     
    dup$retrieve_register (duc$de_iou, iou, 10(16), register);                                                
    IF register.available THEN                                                                                
      IF (register.value [duc$de_model_byte_number] >= 50(16)) AND                                            
            (register.value [duc$de_model_byte_number] <= 5F(16)) THEN                                        
        iou_class := duc$di_ic_iou_16k;                                                                       
        pp_word_size := 16384;                                                                                
      ELSEIF (register.value [duc$de_model_byte_number] >= 40(16)) AND                                        
            (register.value [duc$de_model_byte_number] <= 46(16)) THEN                                        
        iou_class := duc$di_ic_iou_8k;                                                                        
        pp_word_size := 8192;                                                                                 
        IF (register.value [duc$de_model_byte_number] = 44(16)) OR                                            
              (register.value [duc$de_model_byte_number] = 46(16)) THEN                                       
          pp_type := dsc$cpt_nio;                                                                             
        IFEND;                                                                                                
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    CASE iou_class OF                                                                                         
    = duc$di_ic_iou_4k =                                                                                      
      tape_blocks := 3;                                                                                       
    = duc$di_ic_iou_8k =                                                                                      
      tape_blocks := 5;                                                                                       
    = duc$di_ic_iou_16k =                                                                                     
      tape_blocks := 9;                                                                                       
    ELSE                                                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$unknown_iou_model, ' ', status);                     
      dup$display_message (status, v$display_control);                                                        
      status.normal := TRUE;                                                                                  
      RETURN;  {---->                                                                                         
    CASEND;                                                                                                   
                                                                                                              
    PUSH pp_memory_buffer_seq_p: [[REP (tape_blocks * c$edd_tape_block_size) OF cell]];                       
    IF pp_memory_buffer_seq_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    RESET pp_memory_buffer_seq_p;                                                                             
                                                                                                              
    total_bytes_read := 0;                                                                                    
    first_time := TRUE;                                                                                       
    FOR index := 1 TO tape_blocks DO                                                                          
      NEXT data_buffer_p: [[REP c$edd_tape_block_size OF cell]] IN pp_memory_buffer_seq_p;                    
      IF data_buffer_p = NIL THEN                                                                             
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      get_next_data (c$edd_tape_block_size, data_buffer_p, bytes_read, status);                               
      IF NOT status.normal THEN                                                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      IF (bytes_read = 0) OR (v$file_position = amc$eoi) THEN                                                 
        osp$set_status_abnormal (duc$dump_analyzer_id, due$unexpected_eoi, v$file_name_p^, status);           
        osp$append_status_parameter (osc$status_parameter_delimiter, 'the pp memory', status);                
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      IF first_time THEN                                                                                      
        IF bytes_read = #SIZE (t$edd_label) THEN                                                              
          process_label_record (data_buffer_p, dump_label);                                                   
          RETURN;  {---->                                                                                     
        IFEND;                                                                                                
        first_time := FALSE;                                                                                  
      IFEND;                                                                                                  
      total_bytes_read := total_bytes_read + bytes_read;                                                      
    FOREND;                                                                                                   
                                                                                                              
    v$last_other_record_p^.size := total_bytes_read;                                                          
    NEXT restart_file_seq_p: [[REP (pp_word_size * 2) OF cell]] IN                                            
          duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                            
    IF restart_file_seq_p = NIL THEN                                                                          
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    RESET restart_file_seq_p;                                                                                 
    RESET pp_memory_buffer_seq_p;                                                                             
                                                                                                              
    NEXT pp_buffer_array_p: [1 .. (pp_word_size * 2)] IN pp_memory_buffer_seq_p;                              
    IF pp_buffer_array_p = NIL THEN                                                                           
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    NEXT restart_file_array_p: [1 .. (pp_word_size * 2)] IN restart_file_seq_p;                               
    IF restart_file_array_p = NIL THEN                                                                        
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    restart_file_array_p^ := pp_buffer_array_p^;                                                              
                                                                                                              
    IF pp_type = dsc$cpt_nio THEN                                                                             
      duv$dump_environment_p^.iou_memory [iou].nio_pp [pp_number].available := TRUE;                          
      duv$dump_environment_p^.iou_memory [iou].nio_pp [pp_number].first_byte :=                               
            #OFFSET (restart_file_array_p);                                                                   
    ELSE                                                                                                      
      duv$dump_environment_p^.iou_memory [iou].cio_pp [pp_number].available := TRUE;                          
      duv$dump_environment_p^.iou_memory [iou].cio_pp [pp_number].first_byte :=                               
            #OFFSET (restart_file_array_p);                                                                   
    IFEND;                                                                                                    
                                                                                                              
    NEXT r_register_container_p IN pp_memory_buffer_seq_p;                                                    
    IF r_register_container_p = NIL THEN                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    r_register.upper_10 := r_register_container_p^.upper_10;                                                  
    r_register.lower_12 := r_register_container_p^.lower_12;                                                  
                                                                                                              
    IF pp_type = dsc$cpt_nio THEN                                                                             
      duv$dump_environment_p^.iou_memory [iou].nio_pp [pp_number].r_register := r_register.value;             
    ELSE                                                                                                      
      duv$dump_environment_p^.iou_memory [iou].cio_pp [pp_number].r_register := r_register.value;             
    IFEND;                                                                                                    
                                                                                                              
  PROCEND read_pp_memory;                                                                                     
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'read_register_file', EJECT ??                                                                 
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure reads the register file from the dump file and places it on the restart file.              
                                                                                                              
                                                                                                              
  PROCEDURE read_register_file                                                                                
    (VAR dump_label: t$dump_label;                                                                            
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      bytes_read: amt$transfer_count,                                                                         
      data_buffer_seq_p: ^SEQ ( * ),                                                                          
      processor: 0 .. duc$de_maximum_processors,                                                              
      register_contents_p: ^integer,                                                                          
      register_index: 0 .. duc$de_max_register_number,                                                        
      remaining_register: 1 .. (duc$de_max_register_number + 1);                                              
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    ofp$display_status_message ('reading processor register file', status);                                   
                                                                                                              
   /find_processor/                                                                                           
    FOR processor := 0 TO duc$de_maximum_processors DO                                                        
      IF NOT duv$dump_environment_p^.register_file [processor].available THEN                                 
        EXIT /find_processor/;  {---->                                                                        
      IFEND;                                                                                                  
    FOREND /find_processor/;                                                                                  
                                                                                                              
    PUSH data_buffer_seq_p: [[REP dump_label.register_file_size OF integer]];                                 
    IF data_buffer_seq_p = NIL THEN                                                                           
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    RESET data_buffer_seq_p;                                                                                  
                                                                                                              
    get_next_data (#SIZE (data_buffer_seq_p^), data_buffer_seq_p, bytes_read, status);                        
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF bytes_read = 0 THEN                                                                                    
      osp$set_status_abnormal (duc$dump_analyzer_id, due$unexpected_eoi, v$file_name_p^, status);             
      osp$append_status_parameter (osc$status_parameter_delimiter, 'the register file', status);              
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF bytes_read = #SIZE (t$edd_label) THEN                                                                  
      process_label_record (data_buffer_seq_p, dump_label);                                                   
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    v$last_other_record_p^.size := bytes_read;                                                                
                                                                                                              
   /read_registers/                                                                                           
    FOR register_index := 0 TO duc$de_max_register_number DO                                                  
      duv$dump_environment_p^.register_file [processor].register [register_index].available := FALSE;         
      duv$dump_environment_p^.register_file [processor].register [register_index].value := 0;                 
                                                                                                              
      NEXT register_contents_p IN data_buffer_seq_p;                                                          
      IF register_contents_p = NIL THEN                                                                       
        EXIT /read_registers/;  {---->                                                                        
      IFEND;                                                                                                  
                                                                                                              
      duv$dump_environment_p^.register_file [processor].register [register_index].available := TRUE;          
      duv$dump_environment_p^.register_file [processor].register [register_index].value :=                    
            register_contents_p^;                                                                             
                                                                                                              
    FOREND /read_registers/;                                                                                  
                                                                                                              
    FOR remaining_register := (register_index + 1) TO UPPERBOUND (duv$dump_environment_p^.register_file) DO   
      duv$dump_environment_p^.register_file [processor].register [remaining_register].available := FALSE;     
    FOREND;                                                                                                   
                                                                                                              
    duv$dump_environment_p^.register_file [processor].available := TRUE;                                      
    duv$dump_environment_p^.register_file [processor].number_of_registers := dump_label.register_file_size;   
                                                                                                              
  PROCEND read_register_file;                                                                                 
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'save_record_name', EJECT ??                                                                   
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure saves the record name on the other record linked list.                                     
                                                                                                              
  PROCEDURE save_record_name                                                                                  
    (VAR dump_label: t$dump_label;                                                                            
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      other_record_entry_p: ^dut$de_other_record_entry;                                                       
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    IF NOT duv$dump_environment_p^.other_records.available THEN                                               
      duv$dump_environment_p^.other_records.available := TRUE;                                                
      duv$dump_environment_p^.other_records.number_of_records := 0;                                           
    IFEND;                                                                                                    
                                                                                                              
    NEXT other_record_entry_p IN duv$execution_environment.restart_file.segment_pointer.sequence_pointer;     
    IF other_record_entry_p = NIL THEN                                                                        
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    duv$dump_environment_p^.other_records.number_of_records :=                                                
          duv$dump_environment_p^.other_records.number_of_records + 1;                                        
    IF v$last_other_record_p = NIL THEN                                                                       
      duv$dump_environment_p^.other_records.first_record := #OFFSET (other_record_entry_p);                   
    ELSE                                                                                                      
      v$last_other_record_p^.next_record := #OFFSET (other_record_entry_p);                                   
    IFEND;                                                                                                    
    v$last_other_record_p := other_record_entry_p;                                                            
                                                                                                              
    other_record_entry_p^.index := duv$dump_environment_p^.other_records.number_of_records;                   
    other_record_entry_p^.name := dump_label.record_name;                                                     
    other_record_entry_p^.record_type := duc$de_ort_detail;                                                   
    other_record_entry_p^.first_byte := 0;                                                                    
    other_record_entry_p^.size := 0;                                                                          
    other_record_entry_p^.header_line_count := 0;                                                             
    other_record_entry_p^.report_record_length := 0;                                                          
    other_record_entry_p^.next_record := 0;                                                                   
                                                                                                              
  PROCEND save_record_name;                                                                                   
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$read_dump_file', EJECT ??                                                                 
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure reads the dump file and builds the dump environment.                                       
                                                                                                              
  PROCEDURE [XDCL] dup$read_dump_file                                                                         
    (    file_name_p: ^fst$file_reference;                                                                    
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      critical_page_table_p: ^ARRAY [0 .. *] OF dut$de_critical_page_entry,                                   
      device_assigned: boolean,                                                                               
      device_class: rmt$device_class,                                                                         
      dump_label: t$dump_label,                                                                               
      fa_p: ^fst$attachment_options,                                                                          
      iou: 0 .. duc$de_maximum_ious,                                                                          
      local_status: ost$status,                                                                               
      mca_p: ^fst$file_cycle_attributes,                                                                      
      pp_number: 0 .. duc$de_max_pp_memories,                                                                 
      processor: 0 .. duc$de_maximum_processors,                                                              
      severity: ost$status_severity;                                                                          
                                                                                                              
    status.normal := TRUE;                                                                                    
    v$file_name_p := file_name_p;                                                                             
                                                                                                              
    { Retrieve the display control for the display file.                                                      
                                                                                                              
    v$display_control := duv$execution_environment.output_file.display_control;                               
    v$display_control.line_number := v$display_control.page_length + 1;                                       
                                                                                                              
    { Initialize the dump environment.                                                                        
                                                                                                              
    pmp$zero_out_table (#LOC (duv$dump_environment_p^), #SIZE (duv$dump_environment_p^));                     
    duv$dump_environment_p^.revision_level := duc$revision_level;                                             
                                                                                                              
    { Open the Dump File.                                                                                     
                                                                                                              
    rmp$get_device_class (v$file_name_p^, device_assigned, device_class, status);                             
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF NOT device_assigned THEN                                                                               
      osp$set_status_abnormal (duc$dump_analyzer_id, due$file_empty, v$file_name_p^, status);                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
    IF device_class = rmc$magnetic_tape_device THEN                                                           
      PUSH fa_p: [1 .. 3];                                                                                    
      fa_p^ [1].selector := fsc$access_and_share_modes;                                                       
      fa_p^ [1].access_modes.selector := fsc$specific_access_modes;                                           
      fa_p^ [1].access_modes.value := $fst$file_access_options [fsc$read];                                    
      fa_p^ [1].share_modes.selector := fsc$specific_share_modes;                                             
      fa_p^ [1].share_modes.value := $fst$file_access_options [fsc$read];                                     
      fa_p^ [2].selector := fsc$open_position;                                                                
      fa_p^ [2].open_position := amc$open_at_boi;                                                             
      fa_p^ [3].selector := fsc$tape_attachment;                                                              
      fa_p^ [3].tape_attachment.selector := fsc$tape_file_set_position;                                       
      fa_p^ [3].tape_attachment.tape_file_set_position.position := fsc$tape_beginning_of_set;                 
      PUSH mca_p: [1 .. 6];                                                                                   
      mca_p^ [1].selector := fsc$block_type;                                                                  
      mca_p^ [1].block_type := amc$user_specified;                                                            
      mca_p^ [2].selector := fsc$max_block_length;                                                            
      mca_p^ [2].max_block_length := c$edd_tape_block_size;                                                   
      mca_p^ [3].selector := fsc$max_record_length;                                                           
      mca_p^ [3].max_record_length := c$edd_tape_block_size;                                                  
      mca_p^ [4].selector := fsc$record_type;                                                                 
      mca_p^ [4].record_type := amc$undefined;                                                                
      mca_p^ [5].selector := fsc$file_organization;                                                           
      mca_p^ [5].file_organization := amc$sequential;                                                         
      mca_p^ [6].selector := fsc$file_label_type;                                                             
      mca_p^ [6].file_label_type := amc$labelled;                                                             
    ELSEIF device_class = rmc$mass_storage_device THEN                                                        
      PUSH fa_p: [1 .. 2];                                                                                    
      fa_p^ [1].selector := fsc$access_and_share_modes;                                                       
      fa_p^ [1].access_modes.selector := fsc$specific_access_modes;                                           
      fa_p^ [1].access_modes.value := $fst$file_access_options [fsc$read];                                    
      fa_p^ [1].share_modes.selector := fsc$specific_share_modes;                                             
      fa_p^ [1].share_modes.value := $fst$file_access_options [fsc$read];                                     
      fa_p^ [2].selector := fsc$open_position;                                                                
      fa_p^ [2].open_position := amc$open_at_boi;                                                             
      PUSH mca_p: [1 .. 2];                                                                                   
      mca_p^ [1].selector := fsc$record_type;                                                                 
      mca_p^ [1].record_type := amc$variable;                                                                 
      mca_p^ [2].selector := fsc$file_organization;                                                           
      mca_p^ [2].file_organization := amc$sequential;                                                         
    ELSE                                                                                                      
      osp$set_status_abnormal (duc$dump_analyzer_id, due$file_empty, v$file_name_p^, status);                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    fsp$open_file (v$file_name_p^, amc$record, fa_p, NIL, mca_p, NIL, NIL, v$dump_file_identifier, status);   
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    dump_label.read_label := TRUE;                                                                            
    v$file_position := amc$boi;                                                                               
                                                                                                              
  /read_dump/                                                                                                 
    WHILE TRUE DO                                                                                             
      IF v$file_position = amc$eoi THEN                                                                       
        EXIT /read_dump/;  {---->                                                                             
      IFEND;                                                                                                  
                                                                                                              
      IF dump_label.read_label THEN                                                                           
        read_label_record (dump_label, status);                                                               
        IF NOT status.normal OR (v$file_position = amc$eoi) THEN                                              
          EXIT /read_dump/;  {---->                                                                           
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
      dump_label.read_label := TRUE;                                                                          
      save_record_name (dump_label, status);                                                                  
      IF NOT status.normal THEN                                                                               
        EXIT /read_dump/;  {---->                                                                             
      IFEND;                                                                                                  
                                                                                                              
      CASE dump_label.kind OF                                                                                 
      = c$dlk_pmr_label, c$dlk_pr0_label, c$dlk_pr1_label,                                                    
            c$dlk_imr_label, c$dlk_im1_label, c$dlk_mmr_label =                                               
        read_maintenance_registers (dump_label, status);                                                      
        IF NOT status.normal THEN                                                                             
          EXIT /read_dump/;  {---->                                                                           
        IFEND;                                                                                                
                                                                                                              
      = c$dlk_mem_label =                                                                                     
        IF duv$execution_environment.processing_options = duc$ee_po_no_memory THEN                            
          EXIT /read_dump/;  {---->                                                                           
        ELSEIF (duv$execution_environment.processing_options = duc$ee_po_critical_memory) AND                 
              NOT duv$dump_environment_p^.critical_memory.available THEN                                      
          read_only_critical_memory (critical_page_table_p, dump_label, status);                              
        ELSE                                                                                                  
          read_central_memory (dump_label, status);                                                           
        IFEND;                                                                                                
        IF NOT status.normal THEN                                                                             
          EXIT /read_dump/;  {---->                                                                           
        IFEND;                                                                                                
                                                                                                              
      = c$dlk_did_label =                                                                                     
        read_dump_identifier (dump_label, status);                                                            
        IF NOT status.normal THEN                                                                             
          EXIT /read_dump/;  {---->                                                                           
        IFEND;                                                                                                
                                                                                                              
      = c$dlk_ccm_label =                                                                                     
        read_critical_memory (dump_label, critical_page_table_p, status);                                     
        IF NOT status.normal THEN                                                                             
          EXIT /read_dump/;  {---->                                                                           
        IFEND;                                                                                                
                                                                                                              
      = c$dlk_cpt_label =                                                                                     
        read_critical_page_table (dump_label, critical_page_table_p, status);                                 
        IF NOT status.normal THEN                                                                             
          EXIT /read_dump/;  {---->                                                                           
        IFEND;                                                                                                
                                                                                                              
      = c$dlk_iom_label, c$dlk_jom_label, c$dlk_dom_label, c$dlk_eom_label =                                  
        read_pp_memory (dump_label, status);                                                                  
        IF NOT status.normal THEN                                                                             
          EXIT /read_dump/;  {---->                                                                           
        IFEND;                                                                                                
                                                                                                              
      = c$dlk_pxp_label, c$dlk_px0_label, c$dlk_px1_label,                                                    
            c$dlk_jps_label, c$dlk_jp0_label, c$dlk_jp1_label,                                                
            c$dlk_mps_label, c$dlk_mp0_label, c$dlk_mp1_label =                                               
        read_exchange_package (dump_label, status);                                                           
        IF NOT status.normal THEN                                                                             
          EXIT /read_dump/;  {---->                                                                           
        IFEND;                                                                                                
                                                                                                              
      = c$dlk_prf_label =                                                                                     
        read_register_file (dump_label, status);                                                              
        IF NOT status.normal THEN                                                                             
          EXIT /read_dump/;  {---->                                                                           
        IFEND;                                                                                                
                                                                                                              
      = c$dlk_pcs_label =                                                                                     
        read_control_store (dump_label, status);                                                              
        IF NOT status.normal THEN                                                                             
          EXIT /read_dump/;  {---->                                                                           
        IFEND;                                                                                                
                                                                                                              
      = c$dlk_bc_label =                                                                                      
        read_buffer_controlware (dump_label, status);                                                         
        IF NOT status.normal THEN                                                                             
          EXIT /read_dump/;  {---->                                                                           
        IFEND;                                                                                                
                                                                                                              
      = c$dlk_other_label =                                                                                   
        read_other_record (dump_label, status);                                                               
        IF NOT status.normal THEN                                                                             
          EXIT /read_dump/;  {---->                                                                           
        IFEND;                                                                                                
                                                                                                              
      = c$dlk_ill_formatted_label =                                                                           
        CYCLE /read_dump/;  {---->                                                                            
                                                                                                              
      = c$dlk_not_a_label =                                                                                   
        CYCLE /read_dump/;  {---->                                                                            
                                                                                                              
      ELSE                                                                                                    
        CYCLE /read_dump/;  {---->                                                                            
      CASEND;                                                                                                 
                                                                                                              
    WHILEND /read_dump/;                                                                                      
                                                                                                              
    IF NOT status.normal THEN                                                                                 
      dup$display_message (status, v$display_control);                                                        
      osp$get_status_severity (status.condition, severity, local_status);                                     
      IF local_status.normal AND (severity <= osc$warning_status) THEN                                        
        status.normal := TRUE;                                                                                
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    amp$set_segment_eoi (duv$execution_environment.restart_file.file_identifier,                              
          duv$execution_environment.restart_file.segment_pointer, local_status);                              
    IF NOT local_status.normal THEN                                                                           
      dup$display_message (local_status, v$display_control);                                                  
    IFEND;                                                                                                    
    amp$set_segment_eoi (duv$execution_environment.restart_file.file_identifier,                              
          duv$execution_environment.restart_file.segment_pointer, local_status);                              
    IF NOT local_status.normal THEN                                                                           
      dup$display_message (local_status, v$display_control);                                                  
    IFEND;                                                                                                    
                                                                                                              
    fsp$close_file (v$dump_file_identifier, local_status);                                                    
    amp$return (v$file_name_p^, local_status);                                                                
                                                                                                              
  PROCEND dup$read_dump_file;                                                                                 
MODEND dum$read_dump_file;                                                                                    
*DECK DECK=DUM$REAL_MEMORY_ACCESS EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Dump Analyzer : Real Memory Access Routines' ??                                        
MODULE dum$real_memory_access;                                                                                
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains procedures used for real memory access.                                              
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc due$exception_condition_codes                                                                          
*copyc ost$hardware_subranges                                                                                 
?? POP ??                                                                                                     
*copyc osp$set_status_abnormal                                                                                
?? EJECT ??                                                                                                   
*copyc duv$dump_environment_p                                                                                 
*copyc duv$execution_environment                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$access_real_memory', EJECT ??                                                             
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure retrieves a pointer to the desired area in real memory.  The new byte size returned        
{   contains the byte size of the data found in memory.                                                       
                                                                                                              
  PROCEDURE [XDCL] dup$access_real_memory                                                                     
    (    size: ost$real_memory_address;                                                                       
         offset: ost$real_memory_address;                                                                     
     VAR memory_p: ^cell;                                                                                     
     VAR new_byte_size: ost$segment_length;                                                                   
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      adjusted_size: ost$real_memory_address,                                                                 
      all_pages_available: boolean,                                                                           
      cpt_p: ^cell,                                                                                           
      critical_page_table_p: ^ARRAY [0 .. *] OF dut$de_critical_page_entry,                                   
      last_available_page: 0 .. 0ffffffff(16),                                                                
      last_page_number: 0 .. 0ffffffff(16),                                                                   
      number_page_entries: 0 .. 0ffffffff(16),                                                                
      page_number: 0 .. 0ffffffff(16),                                                                        
      page_offset: amt$file_byte_address,                                                                     
      page_size: 0 .. duc$de_max_page_size,                                                                   
      remainder: ost$real_memory_address;                                                                     
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    { Check for a valid rma.                                                                                  
                                                                                                              
    IF offset > duc$de_maximum_rma THEN                                                                       
      osp$set_status_abnormal (duc$dump_analyzer_id, due$invalid_offset, '', status);                         
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Check if the memory is available on the memory file.                                                    
                                                                                                              
    IF (duv$execution_environment.processing_options = duc$ee_po_no_memory) OR                                
          (NOT duv$dump_environment_p^.central_memory.available AND                                           
          NOT duv$dump_environment_p^.critical_memory.available) THEN                                         
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump, 'The central memory is', status);  
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Check if the memory is within the bounds of the MEM record.                                             
                                                                                                              
    IF duv$dump_environment_p^.central_memory.available AND                                                   
          (offset >= duv$dump_environment_p^.central_memory.first_byte) AND                                   
          (offset <= duv$dump_environment_p^.central_memory.last_byte) THEN                                   
                                                                                                              
      IF (offset + size - 1) > duv$dump_environment_p^.central_memory.last_byte THEN                          
        osp$set_status_abnormal (duc$dump_analyzer_id, due$memory_partially_avail, '', status);               
        adjusted_size := duv$dump_environment_p^.central_memory.last_byte - offset + 1;                       
      ELSE                                                                                                    
        adjusted_size := size;                                                                                
      IFEND;                                                                                                  
      memory_p := #ADDRESS (#RING (duv$execution_environment.restart_file.segment_pointer.sequence_pointer),  
            #SEGMENT (duv$execution_environment.restart_file.segment_pointer.sequence_pointer),               
            (offset - duv$dump_environment_p^.central_memory.first_byte) +                                    
            duv$dump_environment_p^.central_memory.bias);                                                     
      new_byte_size := adjusted_size;                                                                         
                                                                                                              
    { Check if the memory is within the bounds of the critical memory.                                        
                                                                                                              
    ELSEIF duv$dump_environment_p^.critical_memory.available AND                                              
          (offset >= duv$dump_environment_p^.critical_memory.first_rma_available) AND                         
          (offset <= duv$dump_environment_p^.critical_memory.last_rma_available) THEN                         
                                                                                                              
      IF (offset + size - 1) > duv$dump_environment_p^.critical_memory.last_rma_available THEN                
        osp$set_status_abnormal (duc$dump_analyzer_id, due$memory_partially_avail, '', status);               
        adjusted_size := duv$dump_environment_p^.critical_memory.last_rma_available - offset + 1;             
      ELSE                                                                                                    
        adjusted_size := size;                                                                                
      IFEND;                                                                                                  
                                                                                                              
      page_size := duv$dump_environment_p^.critical_memory.page_size;                                         
      page_number := offset DIV page_size;                                                                    
      remainder := offset MOD page_size;                                                                      
                                                                                                              
      cpt_p := #ADDRESS (#RING (duv$execution_environment.restart_file.segment_pointer.sequence_pointer),     
            #SEGMENT (duv$execution_environment.restart_file.segment_pointer.sequence_pointer),               
            duv$dump_environment_p^.critical_memory.critical_page_table_offset);                              
      RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO cpt_p;                 
                                                                                                              
      number_page_entries := duv$dump_environment_p^.critical_memory.page_table_size * 64;                    
      NEXT critical_page_table_p: [0 .. (number_page_entries - 1)] IN                                         
            duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                          
      IF critical_page_table_p = NIL THEN                                                                     
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
      IF NOT critical_page_table_p^ [page_number].available THEN                                              
        osp$set_status_abnormal (duc$dump_analyzer_id, due$memory_not_critical, '', status);                  
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      page_offset := critical_page_table_p^ [page_number].page_offset;                                        
      memory_p := #ADDRESS (#RING (duv$execution_environment.restart_file.segment_pointer.sequence_pointer),  
            #SEGMENT (duv$execution_environment.restart_file.segment_pointer.sequence_pointer),               
            (page_offset + remainder));                                                                       
                                                                                                              
      last_page_number := (offset + adjusted_size - 1) DIV page_size;                                         
      all_pages_available := TRUE;                                                                            
                                                                                                              
     /check_page_availability/                                                                                
      FOR last_available_page := page_number TO last_page_number DO                                           
        IF NOT critical_page_table_p^ [last_available_page].available THEN                                    
          all_pages_available := FALSE;                                                                       
          EXIT /check_page_availability/;  {---->                                                             
        IFEND;                                                                                                
      FOREND /check_page_availability/;                                                                       
                                                                                                              
      IF NOT all_pages_available THEN                                                                         
        osp$set_status_abnormal (duc$dump_analyzer_id, due$memory_partially_avail, '', status);               
        new_byte_size := (last_available_page * page_size) - offset;                                          
      ELSE                                                                                                    
        new_byte_size := adjusted_size;                                                                       
      IFEND;                                                                                                  
                                                                                                              
    ELSE  { memory not contained in MEM or critical memory }                                                  
      osp$set_status_abnormal (duc$dump_analyzer_id, due$memory_out_of_bounds, '', status);                   
    IFEND;                                                                                                    
                                                                                                              
  PROCEND dup$access_real_memory;                                                                             
MODEND dum$real_memory_access;                                                                                
*DECK DECK=DUM$SEARCH_SFT EXPAND=TRUE
PROCEDURE dum$search_sft, seasft (
  field, f: any of
    name
    string
  anyend = asid
  value, v: any  = $required
  type: key
    (natural, n)
    (integer, i)
  keyend = natural
  exit_on_first, eof: boolean = true
  display_option, do: key
      (full, f, all)
      (brief, b)
    keyend = brief
  ptl: integer = 0
  output: file = $output
  status)

  " Search the system file table for any field in the entry

  "$FORMAT=OFF"
  VAR
    any_found: boolean = FALSE
    asti: integer
    current: name = $current_module
    fde: integer
    fde_table: integer = 100000000(16) + $mem($sa(gfv$fde_table_base) 8)
    gfc$fde_size: integer = $mem($sa(gfv$fde_size) 8)
    gfc$max_file_descriptor_index: integer = 0ffff(16) "maximum value of gft$file_descriptor_index"
    local_field: name = field
    local_value: any = value
  VAREND
  "$FORMAT=ON"

  chadm dmm$file_table_manager

  IF local_field = asid THEN
    dum$asti xasid=local_value ptl=ptl xasti=asti
    local_field = $name('ASTI')
    local_value = asti
  IFEND

  FOR i = 0 TO gfc$max_file_descriptor_index DO
    fde = fde_table + (i * gfc$fde_size)
    IF $pv(?fde.gft$file_descriptor_control.file_hash) <> 0FF(16) THEN
      IF type = integer THEN
        any_found = ($pv(?fde.gft$file_descriptor_entry.?local_field,,,,,integer) = local_value)
      ELSE
        any_found = ($pv(?fde.gft$file_descriptor_entry.?local_field) = local_value)
      IFEND

      IF any_found THEN
        put_line ' -- File entry '//$strrep(i, 16)//'(16) matches.  GFN = '//..
$pv(?fde.gft$file_descriptor_entry.global_file_name) o=output.$eoi

        IF display_option = full THEN
          dispv ?fde.gft$file_descriptor_entry o=output.$eoi
          IF $pv(?fde.gft$file_descriptor_entry.media) = gfc$fm_mass_storage_file THEN
            p_disk_file_descriptor = 100000000(16) + ..
                  $pv(?fde.gft$file_descriptor_entry.disk_file_descriptor_p)
            dispv ?p_disk_file_descriptor.dmt$disk_file_descriptor o=output.$eoi
          ELSEIF $pv(?fde.gft$file_descriptor_entry.media) = gfc$fm_served_file THEN
            p_server_descriptor = 100000000(16) + ..
                  $pv(?fde.gft$file_descriptor_entry.served_file_descriptor_p)
            dispv ?p_server_descriptor.dft$server_descriptor o=output.$eoi
          IFEND
          put_line ' ------------------------ ' o=output.$eoi
        IFEND

        IF exit_on_first THEN
          chadm current
          EXIT_PROC
        IFEND
      IFEND
    IFEND
  FOREND

  IF NOT any_found THEN
    put_line ' -- No SFT entry found for field: '//field//', value = '//value  o=output
  IFEND

  chadm current

PROCEND dum$search_sft
*DECK DECK=DUM$SEGMENT_FILE_MANAGER EXPAND=TRUE
MODULE dum$segment_file_manager;
?? RIGHT := 110 ??
*copy osd$default_pragmats

{ PURPOSE:
{
{   This module contains SCL command and function processors to implement
{   segment file access within the Analyze System utility.
{
{ DESIGN:
{
{   This module contains SCL commands for opening and closing files for segment
{   access and an SCL function for obtaining the address assigned to an open
{   file.  A table is maintained to describe each file that has been opened.
{   The table is keyed by the Global File Name of the file being described.
{   Each file is allowed to be opened only once.  The entry for a file contains
{   the address assigned to the file so it may be returned by the "$file_pva"
{   function whenever requested.  The entry also contains the file identifier
{   for use when the file is closed.  The "open_file" command allows files to be
{   opened with arbitrary access and share modes and to be created if desired.
{   As a convenience, the "$file_pva" function opens a file for "read" access if
{   it is not already open.  The "close_file" command may be used to close an
{   individual file or all open files.  Files are removed from the table when
{   they are closed.
{
{   The size of the table is fixed at compile time and determines the maximum
{   number of files that can be open at one time.  The size can easily be
{   changed by changing the one line in the type definitions that sets the upper
{   bound of the file list array.

?? PUSH (LISTEXT := ON) ??
*copyc amp$fetch
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc clp$evaluate_parameters
*copyc clt$work_area
*copyc due$exception_condition_codes
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$set_status_abnormal
?? POP ??
?? NEWTITLE := '  Global Definitions', EJECT ??
  CONST
    c$access_based = 'ACCESS_BASED                   ',
    c$all = 'ALL                            ',
    c$append = 'APPEND                         ',
    c$always = 'ALWAYS                         ',
    c$execute = 'EXECUTE                        ',
    c$modify = 'MODIFY                         ',
    c$never = 'NEVER                          ',
    c$permitted = 'PERMITTED                      ',
    c$read = 'READ                           ',
    c$shorten = 'SHORTEN                        ',
    c$write = 'WRITE                          ';

  TYPE
    t$create_option  = (c$always_create, c$sometimes_create, c$never_create),

    t$open_options = record
      access_mode: fst$access_modes,
      share_mode: fst$share_modes,
      create_option: t$create_option,
      allow_previous_open: boolean,
    recend;

  CONST
    c$nil_file_index = 0;

  TYPE
    t$file_list = record
      file_count: t$file_index,
      files: array [1 .. 16] of t$file_entry,
    recend,

    t$file_entry = record
      gfn: ost$binary_unique_name,
      fid: amt$file_identifier,
      pva: ^cell,
    recend,

    t$file_index = 0 .. 4096;

  VAR
    v$file_list: t$file_list := [c$nil_file_index, *];
?? TITLE := '  dup$close_file_command', EJECT ??

  PROCEDURE [XDCL] dup$close_file_command (parameter_list:
    clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE close_file, clof (
{   file, f: any of
{       key
{         all
{       keyend
{       file
{     anyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 31, 11, 28, 56, 915],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 67, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      file_exists: boolean,
      file_index: t$file_index,
      gfn: ost$binary_unique_name,
      p_file_reference: ^fst$file_reference;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$file].value^.kind = clc$file) THEN
      p_file_reference := pvt [p$file].value^.file_value;
      get_file_info (p_file_reference^, file_exists, gfn, file_index);
      IF (file_index = c$nil_file_index) THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$file_not_open, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, p_file_reference^, status);
      ELSE
        fsp$close_file (v$file_list.files [file_index].fid, status);
        IF status.normal THEN
          release_file_list_entry (file_index);
        IFEND;
      IFEND;
    ELSE
      WHILE (v$file_list.file_count > 0) AND status.normal DO
        fsp$close_file (v$file_list.files [1].fid, status);
        IF status.normal THEN
          release_file_list_entry (1);
        IFEND;
      WHILEND;
    IFEND;
  PROCEND dup$close_file_command;
?? TITLE := '  dup$file_pva_function', EJECT ??

  PROCEDURE [XDCL] dup$file_pva_function (parameter_list: clt$parameter_list;
    VAR p_work: ^clt$work_area;
    VAR p_value: ^clt$data_value;
    VAR status: ost$status);

{ FUNCTION $file_pva, $fp (
{   file: file = $required
{   )

?? 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,
      recend,
    recend := [
    [1,
    [89, 3, 29, 16, 28, 37, 631],
    clc$function, 1, 1, 1, 0, 0, 0, 0, ''], [
    ['FILE                           ',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, 3, clc$required_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      converter: record
        case 0 .. 1 of
        = 0 =
          pva: ^cell,
        = 1 =
          pva_subrange: 0 .. 0ffffffffffff(16),
        casend,
      recend;

    VAR
      file_index: t$file_index,
      open_options: t$open_options,
      pva: ^cell;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    open_options.access_mode.selector := fsc$specific_access_modes;
    open_options.access_mode.value := $fst$file_access_options [fsc$read];
    open_options.share_mode.selector := fsc$determine_from_access_modes;
    open_options.create_option := c$never_create;
    open_options.allow_previous_open := TRUE;

    open_file (pvt [p$file].value^.file_value^, open_options, file_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pva := v$file_list.files [file_index].pva;

    NEXT p_value IN p_work;
    p_value^.kind := clc$integer;
    p_value^.integer_value.radix := 16;
    p_value^.integer_value.radix_specified := TRUE;
    converter.pva := pva;
    p_value^.integer_value.value := converter.pva_subrange;
  PROCEND dup$file_pva_function;
?? TITLE := '  dup$open_file_command', EJECT ??

  PROCEDURE [XDCL] dup$open_file_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE open_file, opef (
{   file, f: file = $required
{   access_mode, am: any of
{       key
{         (permitted, p)
{         all, none
{       keyend
{       list of key
{         (read, r)
{         (execute, e)
{         (write, w)
{         (shorten, s)
{         (append, a)
{         (modify, m)
{       keyend
{     anyend = (read, execute)
{   share_mode, sm: any of
{       key
{         (access_based, ab)
{         (permitted, p, required)
{         all, none
{       keyend
{       list of key
{         (read, r)
{         (execute, e)
{         (write, w)
{         (shorten, s)
{         (append, a)
{         (modify, m)
{       keyend
{     anyend = access_based
{   create_file, cf: key
{       (always, a)
{       (sometimes, s)
{       (never, n)
{     keyend = sometimes
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: 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 .. 4] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 12] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (15),
      recend,
      type3: 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 .. 7] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 12] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (12),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (9),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 30, 11, 31, 15, 636],
    clc$command, 9, 5, 1, 0, 0, 0, 5, ''], [
    ['ACCESS_MODE                    ',clc$nominal_entry, 2],
    ['AM                             ',clc$abbreviation_entry, 2],
    ['CF                             ',clc$abbreviation_entry, 4],
    ['CREATE_FILE                    ',clc$nominal_entry, 4],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['SHARE_MODE                     ',clc$nominal_entry, 3],
    ['SM                             ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 642,
  clc$optional_default_parameter, 0, 15],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 753,
  clc$optional_default_parameter, 0, 12],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 9],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    155, [[1, 0, clc$keyword_type], [4], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['PERMITTED                      ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    467, [[1, 0, clc$list_type], [451, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [12], [
        ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['APPEND                         ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['EXECUTE                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['MODIFY                         ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['READ                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['SHORTEN                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['WRITE                          ', clc$nominal_entry, clc$normal_usage_entry, 3]]
        ]
      ]
    ,
    '(read, execute)'],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    266, [[1, 0, clc$keyword_type], [7], [
      ['AB                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ACCESS_BASED                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['P                              ', clc$alias_entry, clc$normal_usage_entry, 2],
      ['PERMITTED                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['REQUIRED                       ', clc$abbreviation_entry, clc$normal_usage_entry, 2]]
      ],
    467, [[1, 0, clc$list_type], [451, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [12], [
        ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['APPEND                         ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['EXECUTE                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['MODIFY                         ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['READ                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['SHORTEN                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['WRITE                          ', clc$nominal_entry, clc$normal_usage_entry, 3]]
        ]
      ]
    ,
    'access_based'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [6], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ALWAYS                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['NEVER                          ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SOMETIMES                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'sometimes'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$access_mode = 2,
      p$share_mode = 3,
      p$create_file = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      file_index: t$file_index,
      open_options: t$open_options;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_access_mode (pvt [p$access_mode].value^, open_options.access_mode);
    get_share_mode (pvt [p$share_mode].value^, open_options.share_mode);
    get_create_option (pvt [p$create_file].value^, open_options.create_option);
    open_options.allow_previous_open := FALSE;

    open_file (pvt [p$file].value^.file_value^, open_options, file_index, status);
  PROCEND dup$open_file_command;
?? TITLE := '  assign_file_list_entry', EJECT ??

  PROCEDURE assign_file_list_entry (VAR file_index: t$file_index);

    IF (v$file_list.file_count >= UPPERBOUND (v$file_list.files)) THEN
      file_index := c$nil_file_index;
    ELSE
      v$file_list.file_count := v$file_list.file_count + 1;
      file_index := v$file_list.file_count;
    IFEND;
  PROCEND assign_file_list_entry;
?? TITLE := '  get_access_mode', EJECT ??

  PROCEDURE get_access_mode (access_value: clt$data_value;
    VAR access_mode: fst$access_modes);

    VAR
      p_element: ^clt$data_value,
      p_list: ^clt$data_value;

    access_mode.selector := fsc$specific_access_modes;
    access_mode.value := $fst$file_access_options [];

    IF (access_value.kind = clc$keyword) THEN
      IF (access_value.keyword_value = c$permitted) THEN
        access_mode.selector := fsc$permitted_access_modes;
      ELSEIF (access_value.keyword_value = c$all) THEN
        access_mode.value := - $fst$file_access_options [];
      IFEND;
    ELSEIF (access_value.kind = clc$list) THEN
      p_list := ^access_value;
      WHILE (p_list <> NIL) DO
        p_element := p_list^.element_value;

        IF (p_element^.keyword_value = c$read) THEN
          access_mode.value := access_mode.value + $fst$file_access_options [fsc$read];
        ELSEIF (p_element^.keyword_value = c$execute) THEN
          access_mode.value := access_mode.value + $fst$file_access_options [fsc$execute];
        ELSEIF (p_element^.keyword_value = c$write) THEN
          access_mode.value := access_mode.value + $fst$file_access_options [fsc$shorten, fsc$append,
                fsc$modify];
        ELSEIF (p_element^.keyword_value = c$shorten) THEN
          access_mode.value := access_mode.value + $fst$file_access_options [fsc$shorten];
        ELSEIF (p_element^.keyword_value = c$append) THEN
          access_mode.value := access_mode.value + $fst$file_access_options [fsc$append];
        ELSEIF (p_element^.keyword_value = c$modify) THEN
          access_mode.value := access_mode.value + $fst$file_access_options [fsc$modify];
        IFEND;

        p_list := p_list^.link;
      WHILEND;
    IFEND;
  PROCEND get_access_mode;
?? TITLE := '  get_create_option', EJECT ??

  PROCEDURE get_create_option (create_value: clt$data_value;
    VAR create_option: t$create_option);

    IF (create_value.keyword_value = c$always) THEN
      create_option := c$always_create;
    ELSEIF (create_value.keyword_value = c$never) THEN
      create_option := c$never_create;
    ELSE
      create_option := c$sometimes_create;
    IFEND;
  PROCEND get_create_option;
?? TITLE := '  get_file_info', EJECT ??

  PROCEDURE get_file_info (file_reference: fst$file_reference;
    VAR file_exists: boolean;
    VAR gfn: ost$binary_unique_name;
    VAR file_index: t$file_index);

    VAR
      attribute: array [1 .. 1] of amt$get_item,
      local: boolean,
      data: boolean,
      status: ost$status;

    attribute [1].key := amc$global_file_name;
    amp$get_file_attributes (file_reference, attribute, local, file_exists, data, status);

    file_exists := status.normal AND file_exists;
    IF file_exists THEN
      gfn := attribute [1].global_file_name;
      file_index := v$file_list.file_count;
      WHILE (file_index <> c$nil_file_index) AND (gfn <> v$file_list.files [file_index].gfn) DO
        file_index := file_index - 1;
      WHILEND;
    ELSE
      file_index := c$nil_file_index;
    IFEND;
  PROCEND get_file_info;
?? TITLE := '  get_share_mode', EJECT ??

  PROCEDURE get_share_mode (share_value: clt$data_value;
    VAR share_mode: fst$share_modes);

    VAR
      p_element: ^clt$data_value,
      p_list: ^clt$data_value;

    share_mode.selector := fsc$specific_share_modes;
    share_mode.value := $fst$file_access_options [];

    IF (share_value.kind = clc$keyword) THEN
      IF (share_value.keyword_value = c$permitted) THEN
        share_mode.selector := fsc$required_share_modes;
      ELSEIF (share_value.keyword_value = c$access_based) THEN
        share_mode.selector := fsc$determine_from_access_modes;
      ELSEIF (share_value.keyword_value = c$all) THEN
        share_mode.value := - $fst$file_access_options [];
      IFEND;
    ELSEIF (share_value.kind = clc$list) THEN
      p_list := ^share_value;
      WHILE (p_list <> NIL) DO
        p_element := p_list^.element_value;

        IF (p_element^.keyword_value = c$read) THEN
          share_mode.value := share_mode.value + $fst$file_access_options [fsc$read];
        ELSEIF (p_element^.keyword_value = c$execute) THEN
          share_mode.value := share_mode.value + $fst$file_access_options [fsc$execute];
        ELSEIF (p_element^.keyword_value = c$write) THEN
          share_mode.value := share_mode.value + $fst$file_access_options [fsc$shorten, fsc$append,
                fsc$modify];
        ELSEIF (p_element^.keyword_value = c$shorten) THEN
          share_mode.value := share_mode.value + $fst$file_access_options [fsc$shorten];
        ELSEIF (p_element^.keyword_value = c$append) THEN
          share_mode.value := share_mode.value + $fst$file_access_options [fsc$append];
        ELSEIF (p_element^.keyword_value = c$modify) THEN
          share_mode.value := share_mode.value + $fst$file_access_options [fsc$modify];
        IFEND;

        p_list := p_list^.link;
      WHILEND;
    IFEND;
  PROCEND get_share_mode;
?? TITLE := '  open_file', EJECT ??

  PROCEDURE open_file (file_reference: fst$file_reference;
        open_options: t$open_options;
    VAR file_index: t$file_index;
    VAR status: ost$status);

    VAR
      attachment: array [1 .. 3] of fst$attachment_option,
      attribute: array [1 .. 1] of amt$fetch_item,
      fid: amt$file_identifier,
      file_existed: boolean,
      file_opened: boolean,
      gfn: ost$binary_unique_name,
      local_status: ost$status,
      segment: amt$segment_pointer;

    status.normal := TRUE;

    get_file_info (file_reference, file_existed, gfn, file_index);

    IF (file_index <> c$nil_file_index) THEN {file already open}
      IF NOT open_options.allow_previous_open THEN
        osp$set_status_abnormal (duc$dump_analyzer_id, due$file_already_open, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, file_reference, status);
      IFEND;
      RETURN;
    ELSEIF (open_options.create_option = c$always_create) AND file_existed THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$file_already_exists, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, file_reference, status);
      RETURN;
    IFEND;

    assign_file_list_entry (file_index);
    IF (file_index = c$nil_file_index) THEN
      osp$set_status_abnormal (duc$dump_analyzer_id, due$open_file_limit, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, file_reference, status);
      osp$append_status_integer (osc$status_parameter_delimiter, UPPERBOUND (v$file_list.files), 10, FALSE,
            status);
      RETURN;
    IFEND;

    attachment [1].selector := fsc$access_and_share_modes;
    attachment [1].access_modes := open_options.access_mode;
    attachment [1].share_modes := open_options.share_mode;

    IF (open_options.create_option = c$sometimes_create) THEN
      attachment [2].selector := fsc$null_attachment_option;
    ELSE
      attachment [2].selector := fsc$create_file;
      attachment [2].create_file := (open_options.create_option = c$always_create);
    IFEND;

    attachment [3].selector := fsc$wait_for_attachment;
    attachment [3].wait_for_attachment.wait := osc$nowait;

    fsp$open_file (file_reference, amc$segment, ^attachment, NIL, NIL, NIL, NIL, fid, status);
    file_opened := status.normal;

    IF NOT file_existed AND file_opened THEN
      attribute [1].key := amc$global_file_name;
      amp$fetch (fid, attribute, status);
      IF status.normal THEN
        gfn := attribute [1].global_file_name;
      IFEND;
    IFEND;

    IF status.normal THEN
      amp$get_segment_pointer (fid, amc$cell_pointer, segment, status);
    IFEND;

    IF status.normal THEN
      v$file_list.files [file_index].gfn := gfn;
      v$file_list.files [file_index].fid := fid;
      v$file_list.files [file_index].pva := segment.cell_pointer;
    ELSE
      release_file_list_entry (file_index);
      IF file_opened THEN
        fsp$close_file (fid, local_status);
      IFEND;
    IFEND;
  PROCEND open_file;
?? TITLE := '  release_file_list_entry', EJECT ??

  PROCEDURE release_file_list_entry (file_index: t$file_index);

    IF (file_index <> v$file_list.file_count) THEN
      v$file_list.files [file_index] := v$file_list.files [v$file_list.file_count];
    IFEND;

    v$file_list.file_count := v$file_list.file_count - 1;
  PROCEND release_file_list_entry;
?? OLDTITLE ??
MODEND dum$segment_file_manager;
*DECK DECK=DUM$SELECT_ACTIVE_JOB_LIST EXPAND=TRUE
PROCEDURE dum$select_active_job_list, select_active_job_list, selajl (
  ajl_ordinal, ao: integer = $required
  output, o: file = $output
  status)

  VAR
    cctqm: string 1..256 = '???????????????????????????????? !"#$%&''()*+,-./0123456789:;'//..
          '<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~????????????????'//..
          '???????????????????????????????????????????????????????????????????????????????????'//..
          '??????????????????????????????'
    jmv$jcb: integer = 300000000(16)              "($sa(jmv$jcb))
    job_fixed_seg_num: integer = 14(16)           "relative to monitor address space
    job_monitor_xcb_offset: integer = 100(16)     "from start of job fixed
  VAREND

  VAR
    ajl: integer
    ajl_entry: integer
    ajl_entry_size: integer
    ajl_p: integer
    field_length: integer
    field_offset: integer
    ijle_p_offset: integer
    job_name: integer
    line: string
    local_status: status
    number_of_entries: integer
    output_file: file
    pva: integer
    system_ajl_ordinal: integer
    user_id: integer
  VAREND

  IF $file(output open_position) = '$BOI' THEN
    delete_file f=output status=local_status
  IFEND
  output_file = output.$eoi

  jmt$job_control_block field=JOBNAME offset=field_offset length=field_length
  job_name = field_offset/8            "offset into job control block
  jmt$job_control_block field=USER_ID offset=field_offset length=field_length
  user_id = field_offset/8             "offset into job control block

  change_default e=monitor am=pva
  ajl_p = $symbol_address(jmv$ajl_p)
  ajl = $memory(ajl_p)
  IF $nil_pva(ajl) THEN
    put_line l=' The active job list has not yet been established.' o=output_file
    EXIT PROCEDURE
  IFEND

  ajl_entry_size = $memory(ajl_p+14 4)
  system_ajl_ordinal = $memory(ajl_p+10 4)
  number_of_entries = $memory(ajl_p+6 4) / ajl_entry_size

  change_processor_register ..
        jps=$rma(((system_ajl_ordinal + job_fixed_seg_num)*100000000(16))+job_monitor_xcb_offset)
  change_default e=job

  IF ajl_ordinal > (system_ajl_ordinal + number_of_entries - 1) THEN
    put_line l=' The selected ordinal is beyond the end of the active job list.' o=output_file
    EXIT PROCEDURE
  IFEND

  ajl_entry = ajl + (ajl_ordinal * ajl_entry_size)

  IF $memory(ajl_entry, 3) <= 0 THEN
    put_line l=' ajl entry '//$strrep(ajl_ordinal)//' is not currently active.' o=output_file
    EXIT PROCEDURE
  IFEND

  line = ' '//$strrep(ajl_ordinal)//'. '
  pva = ((ajl_ordinal + job_fixed_seg_num) * 100000000(16)) + job_monitor_xcb_offset
  change_processor_register jps=$rma(pva monitor)
  change_default e=job
  IF ajl_ordinal <> system_ajl_ordinal THEN
    line = line//', jn = '//$trim($translate(cctqm $memory_string(jmv$jcb+job_name 31)))
  IFEND
  line = line//', user id = '//$trim($translate(cctqm $memory_string(jmv$jcb+user_id 31)))
  put_line l=line o=output_file

  IF $variable(duv$ajl_entry, declared) = 'UNKNOWN' THEN
    VAR
      duv$ajl_entry: (UTILITY) integer
    VAREND
  ELSE
    VAR
      duv$ajl_entry: (XREF) integer
    VAREND
  IFEND
  duv$ajl_entry = ajl_entry

  jmt$active_job_list_entry field=ijle_p offset=field_offset length=field_length
  ijle_p_offset = field_offset/8          "offset into job control block

  IF $variable(duv$ijl_entry, declared) = 'UNKNOWN' THEN
    VAR
      duv$ijl_entry: (UTILITY) integer
    VAREND
  ELSE
    VAR
      duv$ijl_entry: (XREF) integer
    VAREND
  IFEND
  duv$ijl_entry = $mem(duv$ajl_entry+ijle_p_offset)

  put_line l=' ajl = '//$strrep(duv$ajl_entry 16)//', ijl = '//$strrep(duv$ijl_entry 16) o=output_file

PROCEND dum$select_active_job_list
*DECK DECK=DUM$SELECT_SWAPPED_JOB EXPAND=TRUE
PROC dum$select_swapped_job, selsj (job_fixed_asid, jfa: integer 0 .. 0ffffffff(16) = $required
 status)

 " This procedure attempts to make an initiated job available in the dump.

 sva = $value(job_fixed_asid) * 100000000(16)
 exchange = $rma(sva, m 0 sva)
 exchange = exchange + 100(16)
 change_processor_register  jps=exchange

PROCEND
*DECK DECK=DUM$SELECT_TASK EXPAND=TRUE
PROCEDURE dum$select_task, select_task, selt (
  task_number, tn: integer = 0
  output, o: file = $output
  status)

  VAR
    jmv$jcb: integer = 300000000(16)                 "($sa(jmv$jcb))
    job_monitor_xcb_offset: integer = 100(16)        "from start of job fixed
  VAREND

  VAR
    field_length: integer
    field_offset: integer
    function: integer
    job_monitor_xcb: integer
    line: string
    link: integer
    local_file: file = $fname('$local.'//$unique)
    local_status: status
    mcr: integer
    monitor_functions: ARRAY 0 .. 74 OF string
    output_file: file
    task_name: integer
    task_number_index: integer
    task_xcb: integer
  VAREND

  IF $file(output open_position) = '$BOI' THEN
    delete_file f=output status=local_status
  IFEND
  output_file = output.$eoi

  task_xcb = $memory($symbol_address(job_xcb_list))
  job_monitor_xcb = $rma(jmv$jcb+job_monitor_xcb_offset)

  ost$execution_control_block field=SAVE9 offset=field_offset length=field_length
  task_name = field_offset/8               "offset into the XCB
  ost$execution_control_block field=LINK offset=field_offset length=field_length
  link = field_offset/8                    "offset into xcb

  create_monitor_func_file f=local_file
  accept_line v=monitor_functions i=local_file
  detach_file f=local_file

  task_number_index = 0
  process_tasks: ..
  REPEAT
    change_processor_register jps=$rma(task_xcb)
    IF task_number_index = task_number THEN
      line = ' '//$strrep(task_number)//'.'//' task name = '//$trim($memory_string((task_xcb+task_name) 31))
      mcr = $process_register(mcr) / 20(16)
      IF mcr <> ((mcr / 2) * 2) THEN
        function = $memory(task_xcb+088(16) 1)
        IF (function > 0) AND (function < 75) THEN
          line = line//', monitor request = '//monitor_functions(function)
        IFEND
      IFEND
      line = line//', jps = '//$strrep($rma(task_xcb) 16)//'(16)'
      put_line l=line o=output_file
      EXIT PROCEDURE
    IFEND
    EXIT process_tasks WHEN $rma(task_xcb) = job_monitor_xcb
    task_xcb = $memory(task_xcb+link)
    task_number_index = task_number_index + 1
  UNTIL $nil_pva(task_xcb)

  line = ' Selected task number '//$strrep(task_number)//' is out of range.'
  put_line l=line o=output_file
  line = ' There is/are only '//$strrep(task_number_index)//' task(s) in this job.'
  put_line l=line o=output_file

PROCEND dum$select_task
*DECK DECK=DUM$SET_EXCHANGE_PACKAGE EXPAND=TRUE
PROC dum$SET_EXCHANGE_PACKAGE set_exchange_package, setep, setxp (
  gtid                : integer -281474976710655..281474976710655 = $optional
  ijlo                : integer -281474976710655..281474976710655 = $optional
  job_address, ja     : integer -281474976710655..281474976710655 = $optional
  monitor_address, ma : integer -281474976710655..281474976710655 = $optional
  )

  crev (ptlep, xcbo, ijlep, es, ajlo, a, lgtid)
  crev s k=status
  crev v$xcb_pva s=job status=s
  IF NOT s.normal THEN
    crev v$xcb_pva s=xref status=s
  IFEND
  IF $specified(gtid) THEN
    get_ijlep_via_gtid $value(gtid) ijlep
    lgtid = $value(gtid)
  ELSEIF $specified(ijlo) THEN
    get_ijlep_via_ijlo $value(ijlo) ijlep
    fetch_memory ijlep jmt$initiated_job_list_entry job_monitor_taskid lgtid
  ELSEIF $specified(job_address) THEN
    v$xcb_pva = $value(job_address)
    chapr jps=$rma($value(job_address))
    chad e=j
    EXIT_PROC
  ELSEIF $specified(monitor_address) THEN
    v$xcb_pva = $mod($value(monitor_address), 100000000(16)) + 300000000(16)
    chapr jps=$rma($value(monitor_address) m)
    chad e=j
    EXIT_PROC
  ELSE
    putl ' One of the parameters is required'
    EXIT_PROC
  IFEND

  fetch_memory ijlep jmt$initiated_job_list_entry entry_status es
  IF es > 2 THEN
    putl ' Job swapped out'
    EXIT_PROC
  IFEND
  fetch_memory ijlep jmt$initiated_job_list_entry ajl_ordinal ajlo
  get_ptlep_via_gtid lgtid ptlep
  fetch_memory ptlep tmt$primary_task_list_entry xcb_offset xcbo
  a = (ajlo + 14(16)) * 100000000(16) + xcbo

  v$xcb_pva = 3 * 100000000(16) + xcbo
  chapr jps=$rma(a, m)
  chad e=j

PROCEND dum$set_exchange_package
*DECK DECK=DUM$STAND_ALONE_FUNCTIONS EXPAND=TRUE
MODULE dum$stand_alone_functions;                                                                             
?? RIGHT := 110 ??                                                                                            
                                                                                                              
{ PURPOSE:                                                                                                    
{                                                                                                             
{   This module contains SCL functions which are independent of the dump                                      
{   environment and therefore common code can be shared between Analyze Dump and                              
{   Analyze System.                                                                                           
{                                                                                                             
{ DESIGN:                                                                                                     
{                                                                                                             
{   The SCL function processors contained in this module are intended to be                                   
{   called from both the Analyze Dump and Analyze System utilities.  Therefore,                               
{   they must be able to provide their results without accessing the dump                                     
{   environment of the restart file.                                                                          
{                                                                                                             
{   Some of the functions (e.g.  $symbol_address) access the linker debug table                               
{   through Object Code Utility procedures (e.g.  ocp$find_debug_address).  The                               
{   opening and closing of the linker debug tables is performed by Analyze Dump                               
{   and Analyze System commands external to this module using other Object Code                               
{   Utility procedures (e.g.  ocp$define_linker_debug_table).                                                 
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc clp$evaluate_parameters                                                                                
*copyc clp$make_integer_value                                                                                 
*copyc clt$work_area                                                                                          
*copyc due$exception_condition_codes                                                                          
*copyc ocp$find_debug_address                                                                                 
*copyc ocp$find_debug_entry_point                                                                             
*copyc osp$append_status_integer                                                                              
*copyc osp$set_status_abnormal                                                                                
*copyc ost$caller_identifier                                                                                  
*copyc pmp$convert_binary_unique_name                                                                         
*copyc pmp$convert_unique_to_binary                                                                           
?? POP ??                                                                                                     
?? NEWTITLE := 'Global Definitions', EJECT ??                                                                 
                                                                                                              
  TYPE                                                                                                        
    t$address = record                                                                                        
      CASE boolean OF                                                                                         
                                                                                                              
      = FALSE =                                                                                               
        int: integer,                                                                                         
                                                                                                              
      = TRUE =                                                                                                
        fill: 0 .. 0ffff(16),                                                                                 
        pva: ost$pva,                                                                                         
      CASEND,                                                                                                 
    recend;                                                                                                   
?? TITLE := 'dup$$bit_function', EJECT ??                                                                     
                                                                                                              
{                                                                                                             
{ This function returns a boolean value of true if the specified bit in the                                   
{ specified word is a binary one; otherwise, a false value is returned.                                       
{                                                                                                             
                                                                                                              
  PROCEDURE [XDCL] dup$$bit_function (parameter_list: clt$parameter_list;                                     
    VAR p_work: ^clt$work_area;                                                                               
    VAR p_value: ^clt$data_value;                                                                             
    VAR status: ost$status);                                                                                  
                                                                                                              
{ FUNCTION $bit (                                                                                             
{   word: integer = $required                                                                                 
{   bit_number: integer 0..63 = $required                                                                     
{   )                                                                                                         
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
                                                                                                              
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 2] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 2] of clt$pdt_parameter,                                                        
      type1: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
      type2: record                                                                                           
        header: clt$type_specification_header,                                                                
        qualifier: clt$integer_type_qualifier,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 3, 23, 16, 0, 4, 589],                                                                               
    clc$function, 2, 2, 2, 0, 0, 0, 0, ''], [                                                                 
    ['BIT_NUMBER                     ',clc$nominal_entry, 2],                                                 
    ['WORD                           ',clc$nominal_entry, 1]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [2, 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, 20, clc$required_parameter, 
  0, 0],                                                                                                      
{ PARAMETER 2                                                                                                 
    [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, 20, clc$required_parameter, 
  0, 0]],                                                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],                                       
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$integer_type], [0, 63, 10]]];                                                                 
                                                                                                              
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$word = 1,                                                                                             
      p$bit_number = 2;                                                                                       
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 2] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      bits: packed array [0 .. 63] of boolean;                                                                
                                                                                                              
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    NEXT p_value IN p_work;                                                                                   
    p_value^.kind := clc$boolean;                                                                             
    p_value^.boolean_value.kind := clc$true_false_boolean;                                                    
    #UNCHECKED_CONVERSION (pvt [p$word].value^.integer_value.value, bits);                                    
    p_value^.boolean_value.value := bits [pvt [p$bit_number].value^.integer_value.value];                     
  PROCEND dup$$bit_function;                                                                                  
?? TITLE := 'dup$convert_unique_name', EJECT ??                                                               
                                                                                                              
  PROCEDURE [XDCL] dup$convert_unique_name (parameter_list: clt$parameter_list;                               
    VAR p_work: ^clt$work_area;                                                                               
    VAR p_result: ^clt$data_value;                                                                            
    VAR status: ost$status);                                                                                  
                                                                                                              
{ FUNCTION $convert_unique_name, $conun, $cun (                                                               
{   unique_name: any of                                                                                       
{       string #SIZE(ost$binary_unique_name)                                                                  
{       string #SIZE(ost$name)                                                                                
{       name #SIZE(ost$name)..#SIZE(ost$name)                                                                 
{     anyend = $required                                                                                      
{   )                                                                                                         
                                                                                                              
?? 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$string_type_qualifier,                                                               
        recend,                                                                                               
        type_size_2: clt$type_specification_size,                                                             
        element_type_spec_2: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$string_type_qualifier,                                                               
        recend,                                                                                               
        type_size_3: clt$type_specification_size,                                                             
        element_type_spec_3: record                                                                           
          header: clt$type_specification_header,                                                              
          qualifier: clt$name_type_qualifier,                                                                 
        recend,                                                                                               
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 1, 17, 13, 8, 10, 64],                                                                               
    clc$function, 1, 1, 1, 0, 0, 0, 0, ''], [                                                                 
    ['UNIQUE_NAME                    ',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, 45, clc$required_parameter, 
  0, 0]],                                                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],                                               
    TRUE, 3],                                                                                                 
    8, [[1, 0, clc$string_type], [#SIZE(ost$binary_unique_name), #SIZE(ost$binary_unique_name), FALSE]],      
    8, [[1, 0, clc$string_type], [#SIZE(ost$name), #SIZE(ost$name), FALSE]],                                  
    5, [[1, 0, clc$name_type], [#SIZE(ost$name), #SIZE(ost$name)]]                                            
    ]];                                                                                                       
                                                                                                              
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$unique_name = 1;                                                                                      
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 1] of clt$parameter_value;                                                             
                                                                                                              
    TYPE                                                                                                      
      converter_type = record                                                                                 
        case boolean of                                                                                       
        = TRUE =                                                                                              
          name: ost$name,                                                                                     
        = FALSE =                                                                                             
          unique_name: ost$binary_unique_name,                                                                
        casend,                                                                                               
      recend;                                                                                                 
                                                                                                              
    VAR                                                                                                       
      binary_name_size: integer,                                                                              
      converter: converter_type,                                                                              
      name: ost$name,                                                                                         
      p_value: ^clt$data_value;                                                                               
                                                                                                              
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
                                                                                                              
    IF status.normal THEN                                                                                     
      p_value := pvt [p$unique_name].value;                                                                   
      binary_name_size := #SIZE (converter.unique_name);                                                      
      NEXT p_result IN p_work;                                                                                
                                                                                                              
      IF (p_value^.kind = clc$string) AND (STRLENGTH (p_value^.string_value^) = binary_name_size) THEN        
        p_result^.kind := clc$name;                                                                           
        converter.name (1, binary_name_size) := p_value^.string_value^;                                       
        pmp$convert_binary_unique_name (converter.unique_name, p_result^.name_value, status);                 
      ELSE                                                                                                    
        p_result^.kind := clc$string;                                                                         
        NEXT p_result^.string_value: [binary_name_size] IN p_work;                                            
        IF (p_value^.kind = clc$name) THEN                                                                    
          name := p_value^.name_value;                                                                        
        ELSE                                                                                                  
          name := p_value^.string_value^;                                                                     
        IFEND;                                                                                                
        converter.name := '';                                                                                 
        pmp$convert_unique_to_binary (name, converter.unique_name, status);                                   
        p_result^.string_value^ (1, binary_name_size) := converter.name (1, binary_name_size);                
      IFEND;                                                                                                  
    IFEND;                                                                                                    
  PROCEND dup$convert_unique_name;                                                                            
?? TITLE := 'dup$$module_function', EJECT ??                                                                  
                                                                                                              
  PROCEDURE [XDCL] dup$$module_function (parameter_list: clt$parameter_list;                                  
    VAR p_work: ^clt$work_area;                                                                               
    VAR p_value: ^clt$data_value;                                                                             
    VAR status: ost$status);                                                                                  
                                                                                                              
{ FUNCTION $module (                                                                                          
{   pva: integer 0..0ffffffffffff(16) = $required                                                             
{   )                                                                                                         
                                                                                                              
?? 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$integer_type_qualifier,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 3, 23, 17, 41, 46, 952],                                                                             
    clc$function, 1, 1, 1, 0, 0, 0, 0, ''], [                                                                 
    ['PVA                            ',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, 20, clc$required_parameter, 
  0, 0]],                                                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 0ffffffffffff(16), 10]]];                                                  
                                                                                                              
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$pva = 1;                                                                                              
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 1] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      address: t$address,                                                                                     
      found: boolean,                                                                                         
      module_name: pmt$program_name,                                                                          
      offset: ost$segment_offset,                                                                             
      offset_in_section: ost$segment_offset,                                                                  
      section_name: pmt$program_name,                                                                         
      seg: ost$segment;                                                                                       
                                                                                                              
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    address.int := pvt [p$pva].value^.integer_value.value;                                                    
    seg := address.pva.seg;                                                                                   
    offset := address.pva.offset;                                                                             
    ocp$find_debug_address (seg, offset, found, module_name, section_name, offset_in_section, status);        
                                                                                                              
    IF NOT status.normal THEN                                                                                 
      IF (status.condition = oce$e_debug_table_not_open) THEN                                                 
        osp$set_status_abnormal (duc$dump_analyzer_id, due$debug_table_not_avail, '', status);                
      IFEND;                                                                                                  
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF NOT found THEN                                                                                         
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_entry_for_address, '', status);                   
      osp$append_status_integer (osc$status_parameter_delimiter, address.int, 16, TRUE, status);              
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    NEXT p_value IN p_work;                                                                                   
    p_value^.kind := clc$string;                                                                              
    NEXT p_value^.string_value: [STRLENGTH (module_name)] IN p_work;                                          
    p_value^.string_value^ := module_name;                                                                    
                                                                                                              
  PROCEND dup$$module_function;                                                                               
?? TITLE := 'dup$$nil_pva_function', EJECT ??                                                                 
                                                                                                              
  PROCEDURE [XDCL] dup$$nil_pva_function (parameter_list: clt$parameter_list;                                 
    VAR p_work: ^clt$work_area;                                                                               
    VAR p_value: ^clt$data_value;                                                                             
    VAR status: ost$status);                                                                                  
                                                                                                              
{ FUNCTION $nil_pva, $np (                                                                                    
{   pva: integer 0..0ffffffffffff(16) = $required                                                             
{   )                                                                                                         
                                                                                                              
?? 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$integer_type_qualifier,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 3, 27, 8, 53, 11, 396],                                                                              
    clc$function, 1, 1, 1, 0, 0, 0, 0, ''], [                                                                 
    ['PVA                            ',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, 20, clc$required_parameter, 
  0, 0]],                                                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 0ffffffffffff(16), 10]]];                                                  
                                                                                                              
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$pva = 1;                                                                                              
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 1] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      address: t$address;                                                                                     
                                                                                                              
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    address.int := pvt [p$pva].value^.integer_value.value;                                                    
                                                                                                              
    NEXT p_value IN p_work;                                                                                   
    p_value^.kind := clc$boolean;                                                                             
    p_value^.boolean_value.kind := clc$true_false_boolean;                                                    
    p_value^.boolean_value.value := (address.pva.ring = osc$max_ring) AND (address.pva.seg                    
          = osc$maximum_segment) AND (address.pva.offset < 0);                                                
  PROCEND dup$$nil_pva_function;                                                                              
?? TITLE := 'dup$$offset_function', EJECT ??                                                                  
                                                                                                              
  PROCEDURE [XDCL] dup$$offset_function (parameter_list: clt$parameter_list;                                  
    VAR p_work: ^clt$work_area;                                                                               
    VAR p_value: ^clt$data_value;                                                                             
    VAR status: ost$status);                                                                                  
                                                                                                              
{ FUNCTION $offset, $off (                                                                                    
{   pva: integer 0..0ffffffffffff(16) = $required                                                             
{   )                                                                                                         
                                                                                                              
?? 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$integer_type_qualifier,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 3, 27, 9, 8, 41, 313],                                                                               
    clc$function, 1, 1, 1, 0, 0, 0, 0, ''], [                                                                 
    ['PVA                            ',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, 20, clc$required_parameter, 
  0, 0]],                                                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 0ffffffffffff(16), 10]]];                                                  
                                                                                                              
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$pva = 1;                                                                                              
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 1] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      address: t$address;                                                                                     
                                                                                                              
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    address.int := pvt [p$pva].value^.integer_value.value;                                                    
                                                                                                              
    NEXT p_value IN p_work;                                                                                   
    p_value^.kind := clc$integer;                                                                             
    p_value^.integer_value.value := address.pva.offset;                                                       
    p_value^.integer_value.radix := 16;                                                                       
    p_value^.integer_value.radix_specified := TRUE;                                                           
  PROCEND dup$$offset_function;                                                                               
?? TITLE := 'dup$$ring_function', EJECT ??                                                                    
                                                                                                              
  PROCEDURE [XDCL] dup$$ring_function                                                                         
    (    parameter_list: clt$parameter_list;                                                                  
     VAR p_work: ^clt$work_area;                                                                              
     VAR p_value: ^clt$data_value;                                                                            
     VAR status: ost$status);                                                                                 
                                                                                                              
{ FUNCTION $ring (                                                                                            
{   pva: integer 0..0ffffffffffff(16) = $optional                                                             
{   )                                                                                                         
                                                                                                              
?? 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$integer_type_qualifier,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 9, 1, 7, 24, 38, 924],                                                                               
    clc$function, 1, 1, 0, 0, 0, 0, 0, ''], [                                                                 
    ['PVA                            ',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, 20, clc$optional_parameter, 
  0, 0]],                                                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 0ffffffffffff(16), 10]]];                                                  
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$pva = 1;                                                                                              
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 1] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      address: t$address,                                                                                     
      caller_id: ost$caller_identifier;                                                                       
                                                                                                              
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    { Since this function is the same name as a $system function this causes confusion.                       
    { If the parameter is omitted, perform the same code as the $system function.                             
                                                                                                              
    IF NOT pvt [p$pva].specified THEN                                                                         
      #CALLER_ID (caller_id);                                                                                 
      clp$make_integer_value (caller_id.ring, 10, FALSE, p_work, p_value);                                    
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    address.int := pvt [p$pva].value^.integer_value.value;                                                    
                                                                                                              
    NEXT p_value IN p_work;                                                                                   
    p_value^.kind := clc$integer;                                                                             
    p_value^.integer_value.value := address.pva.ring;                                                         
    p_value^.integer_value.radix := 16;                                                                       
    p_value^.integer_value.radix_specified := TRUE;                                                           
                                                                                                              
  PROCEND dup$$ring_function;                                                                                 
?? TITLE := 'dup$$section_function', EJECT ??                                                                 
                                                                                                              
  PROCEDURE [XDCL] dup$$section_function (parameter_list: clt$parameter_list;                                 
    VAR p_work: ^clt$work_area;                                                                               
    VAR p_value: ^clt$data_value;                                                                             
    VAR status: ost$status);                                                                                  
                                                                                                              
{ FUNCTION $section, $sec (                                                                                   
{   pva: integer 0..0ffffffffffff(16) = $required                                                             
{   )                                                                                                         
                                                                                                              
?? 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$integer_type_qualifier,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 3, 27, 9, 17, 56, 315],                                                                              
    clc$function, 1, 1, 1, 0, 0, 0, 0, ''], [                                                                 
    ['PVA                            ',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, 20, clc$required_parameter, 
  0, 0]],                                                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 0ffffffffffff(16), 10]]];                                                  
                                                                                                              
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$pva = 1;                                                                                              
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 1] of clt$parameter_value;                                                             
                                                                                                              
    TYPE                                                                                                      
      ascii_characters = set of 0 .. 255;                                                                     
                                                                                                              
    VAR                                                                                                       
      address: t$address,                                                                                     
      blank: ascii_characters,                                                                                
      found: boolean,                                                                                         
      index: integer,                                                                                         
      module_name: pmt$program_name,                                                                          
      length: integer,                                                                                        
      offset: ost$segment_offset,                                                                             
      offset_in_section: ost$segment_offset,                                                                  
      s: string (50),                                                                                         
      section_name: pmt$program_name,                                                                         
      seg: ost$segment;                                                                                       
                                                                                                              
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    address.int := pvt [p$pva].value^.integer_value.value;                                                    
    seg := address.pva.seg;                                                                                   
    offset := address.pva.offset;                                                                             
    ocp$find_debug_address (seg, offset, found, module_name, section_name, offset_in_section, status);        
                                                                                                              
    IF NOT status.normal THEN                                                                                 
      IF (status.condition = oce$e_debug_table_not_open) THEN                                                 
        osp$set_status_abnormal (duc$dump_analyzer_id, due$debug_table_not_avail, '', status);                
      IFEND;                                                                                                  
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF NOT found THEN                                                                                         
      osp$set_status_abnormal (duc$dump_analyzer_id, due$no_entry_for_address, '', status);                   
      osp$append_status_integer (osc$status_parameter_delimiter, address.int, 16, TRUE, status);              
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    NEXT p_value IN p_work;                                                                                   
    p_value^.kind := clc$string;                                                                              
    blank := $ascii_characters [$INTEGER (' ')];                                                              
    #scan (blank, section_name, index, found);                                                                
    STRINGREP (s, length, section_name (1, index - 1), ' +', offset_in_section: #(16), '(16)');               
    NEXT p_value^.string_value: [length] IN p_work;                                                           
    p_value^.string_value^ := s (1, length);                                                                  
  PROCEND dup$$section_function;                                                                              
?? TITLE := 'dup$$segment_function', EJECT ??                                                                 
                                                                                                              
  PROCEDURE [XDCL] dup$$segment_function (parameter_list: clt$parameter_list;                                 
    VAR p_work: ^clt$work_area;                                                                               
    VAR p_value: ^clt$data_value;                                                                             
    VAR status: ost$status);                                                                                  
                                                                                                              
{ FUNCTION $segment, $seg (                                                                                   
{   pva: integer 0..0ffffffffffff(16) = $required                                                             
{   )                                                                                                         
                                                                                                              
?? 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$integer_type_qualifier,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 3, 27, 9, 34, 46, 607],                                                                              
    clc$function, 1, 1, 1, 0, 0, 0, 0, ''], [                                                                 
    ['PVA                            ',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, 20, clc$required_parameter, 
  0, 0]],                                                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$integer_type], [0, 0ffffffffffff(16), 10]]];                                                  
                                                                                                              
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$pva = 1;                                                                                              
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 1] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      address: t$address;                                                                                     
                                                                                                              
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    address.int := pvt [p$pva].value^.integer_value.value;                                                    
                                                                                                              
    NEXT p_value IN p_work;                                                                                   
    p_value^.kind := clc$integer;                                                                             
    p_value^.integer_value.value := address.pva.seg;                                                          
    p_value^.integer_value.radix := 16;                                                                       
    p_value^.integer_value.radix_specified := TRUE;                                                           
  PROCEND dup$$segment_function;                                                                              
?? TITLE := 'dup$$symbol_address_function', EJECT ??                                                          
                                                                                                              
  PROCEDURE [XDCL] dup$$symbol_address_function (parameter_list: clt$parameter_list;                          
    VAR p_work: ^clt$work_area;                                                                               
    VAR p_value: ^clt$data_value;                                                                             
    VAR status: ost$status);                                                                                  
                                                                                                              
{ FUNCTION $symbol_address, $sa (                                                                             
{   program_name: program_name = $required                                                                    
{   )                                                                                                         
                                                                                                              
?? 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,                                                                
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 3, 27, 9, 53, 43, 59],                                                                               
    clc$function, 1, 1, 1, 0, 0, 0, 0, ''], [                                                                 
    ['PROGRAM_NAME                   ',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, 3, clc$required_parameter, 0
  , 0]],                                                                                                      
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$program_name_type]]];                                                                         
                                                                                                              
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$program_name = 1;                                                                                     
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 1] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      address: t$address,                                                                                     
      found: boolean,                                                                                         
      module_name: pmt$program_name,                                                                          
      offset: ost$segment_offset,                                                                             
      program_name: pmt$program_name,                                                                         
      seg: ost$segment;                                                                                       
                                                                                                              
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    program_name := pvt [p$program_name].value^.program_name_value;                                           
    ocp$find_debug_entry_point (program_name, found, module_name, seg, offset, status);                       
                                                                                                              
    IF NOT status.normal THEN                                                                                 
      IF (status.condition = oce$e_debug_table_not_open) THEN                                                 
        osp$set_status_abnormal (duc$dump_analyzer_id, due$debug_table_not_avail, '', status);                
      IFEND;                                                                                                  
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF NOT found THEN                                                                                         
      osp$set_status_abnormal (duc$dump_analyzer_id, due$symbol_not_found, program_name, status);             
      RETURN;                                                                                                 
    IFEND;                                                                                                    
    address.int := 0;                                                                                         
    address.pva.seg := seg;                                                                                   
    address.pva.offset := offset;                                                                             
                                                                                                              
    NEXT p_value IN p_work;                                                                                   
    p_value^.kind := clc$integer;                                                                             
    p_value^.integer_value.value := address.int;                                                              
    p_value^.integer_value.radix := 16;                                                                       
    p_value^.integer_value.radix_specified := TRUE;                                                           
  PROCEND dup$$symbol_address_function;                                                                       
?? OLDTITLE ??                                                                                                
MODEND dum$stand_alone_functions;                                                                             
*DECK DECK=DUM$VERIFY_LOG EXPAND=TRUE
PROC dum$verify_log verify_log, verl (
  start, s: integer = $required
  found, f: var of boolean = $required
  recursion_level, rl: integer = 1
  status)

create_variable found k=boolean value=false
create_variable s k=status
start = $value(start)
length = $mem(start+2 2)
include_line 'previous = $mem(start+length+4 2)' status=s

IF s.normal AND (previous = length) THEN
  found = true
  IF $value(recursion_level) > 1 THEN
    verify_log start=$value(start)+length+4 found ..
      rl=$value(recursion_level)-1
  IFEND
IFEND

$value(found) = found

PROCEND dum$verify_log
*DECK DECK=DUM$VERIFY_PAGE_QUEUE_LIST EXPAND=TRUE

PROC dum$verify_page_queue_list, verify_page_queue_list, verpql (
  pqlep: integer = $required
  xpft_p: integer = 0
  output,o: file = $output
  status)

  crev s kind=status
  crev field_offset integer
  crev field_length integer
  delf out status=s
  setfa out fc=list

  mmt$page_frame_table_entry field=queue_id offset=field_offset length=field_length
  queue_id_offset = field_offset / 8
  mmt$page_frame_table_entry field=ijl_ordinal offset=field_offset length=field_length
  ijlo_offset = field_offset / 8
  mmt$page_frame_table_entry field=pti offset=field_offset length=field_length
  pti_offset = field_offset / 8
  mmt$page_frame_table_entry field=sva offset=field_offset length=field_length
  sva_offset = field_offset / 8

  IF $value(xpft_p) = 0 THEN
    pftp = $sa(mmv$pft_p)
  ELSE
    pftp = $value(xpft_p)
  IFEND
  pft_entry_size = $mem($sa(mmv$pft_p)+14 4)
  pft = $mem(pftp 6)
  pftlb = $mem(pftp+10 4)
  pftub = $mem(pftp+6 4) / $mem(pftp+14 4) + pftlb
  prev = 0
  pfti = $mem($value(pqlep)+2 2)
  pftep = pft + (pfti - pftlb) * pft_entry_size
  qid = $mem(pftep+queue_id_offset 1)
  ijlo = $mem(pftep+ijlo_offset 2)
  count = 0
  putl ' VERIFY PAGE QUEUE LIST ' o=out.$eoi
  WHILE pfti > 0 DO
    count = count + 1
    pftep = pft + (pfti - pftlb) * pft_entry_size
    fwd = $mem(pftep+2 2)
    bkw = $mem(pftep 2)
    putl ' '//$strrep(pfti 16)//'  '//$strrep($mem(pftep+sva_offset 6) 16) o=out.$eoi
    pti = $mem(pftep+pti_offset 3)
    IF qid <> $mem(pftep+queue_id_offset 1) THEN
      putl ' Bad queue id' o=out.$eoi
    IFEND
    IF ijlo <> $mem(pftep+ijlo_offset 2) THEN
      putl ' Bad ijlo' o=out.$eoi
    IFEND
    IF ($mem(pti*8+5 3) * 512 / 4096 <> pfti) OR ($mod($mem(pti*8 3)/16 65536) <> $mem(pftep+sva_offset 2)) THEN
      putl ' PFT.PTI doesnt point to valid entry' o=out.$eoi
    IFEND
    IF bkw <> prev THEN
      putl ' Backward pointer BAD' o=out.$eoi
    IFEND
    prev = pfti
    pfti = fwd
  WHILEND
  IF prev <> $mem($value(pqlep) 2) THEN
    putl ' PQL backward pfti is bad' o=out.$eoi
  IFEND
  c = $mem($value(pqlep)+4 2)
  IF count <> c THEN
    putl ' Bad queue count, found '//$strrep(count)//', expected '//$strrep(c) o=out.$eoi
  IFEND
  copf out $value(output)

PROCEND dum$verify_page_queue_list
*DECK DECK=DUM$VIRTUAL_MEMORY_ACCESS EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE Dump Analyzer : Virtual Memory Access' ??                                              
MODULE dum$virtual_memory_access;                                                                             
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains the code for the virtual memory access.                                              
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc due$exception_condition_codes                                                                          
*copyc dut$access_data                                                                                        
*copyc mmt$ast_index                                                                                          
*copyc ost$segment_access_control                                                                             
?? POP ??                                                                                                     
*copyc dup$access_real_memory                                                                                 
*copyc osp$append_status_integer                                                                              
*copyc osp$append_status_parameter                                                                            
*copyc osp$set_status_abnormal                                                                                
?? EJECT ??                                                                                                   
*copyc duv$dump_environment_p                                                                                 
*copyc duv$execution_environment                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??                                        
  VAR                                                                                                         
    v$page_size: 512 .. 65536;                                                                                
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'append_pva', EJECT ??                                                                         
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure appends a pva error message to the status message.                                         
                                                                                                              
  PROCEDURE append_pva                                                                                        
    (    pva: ost$pva;                                                                                        
     VAR status: ost$status);                                                                                 
                                                                                                              
    osp$append_status_parameter (osc$status_parameter_delimiter, ', segment = ', status);                     
    osp$append_status_integer (osc$status_parameter_delimiter, pva.seg, 16, TRUE, status);                    
    osp$append_status_parameter (osc$status_parameter_delimiter, ', offset = ', status);                      
    osp$append_status_integer (osc$status_parameter_delimiter, pva.offset, 16, TRUE, status);                 
                                                                                                              
  PROCEND append_pva;                                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'append_sva', EJECT ??                                                                         
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure appends an sva error message to the status message.                                        
                                                                                                              
  PROCEDURE append_sva                                                                                        
    (    sva: dut$ee_system_virtual_address;                                                                  
     VAR status: ost$status);                                                                                 
                                                                                                              
    osp$append_status_parameter (osc$status_parameter_delimiter, ', asid = ', status);                        
    osp$append_status_integer (osc$status_parameter_delimiter, sva.asid.value, 16, TRUE, status);             
    osp$append_status_parameter (osc$status_parameter_delimiter, ', offset = ', status);                      
    osp$append_status_integer (osc$status_parameter_delimiter, sva.offset, 16, TRUE, status);                 
                                                                                                              
  PROCEND append_sva;                                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'initialize_access_data', EJECT ??                                                             
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure initializes the access data record.                                                        
                                                                                                              
  PROCEDURE initialize_access_data                                                                            
    (VAR access_data: dut$access_data);                                                                       
                                                                                                              
    access_data.valid_segment := TRUE;                                                                        
    access_data.page_fault := FALSE;                                                                          
    access_data.memory_found := TRUE;                                                                         
                                                                                                              
  PROCEND initialize_access_data;                                                                             
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$copy_virtual_memory_pva', EJECT ??                                                        
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure copies memory by using a pva.                                                              
                                                                                                              
  PROCEDURE [XDCL] dup$copy_virtual_memory_pva                                                                
    (    process_virtual_address: ost$pva;                                                                    
         exchange: dut$exchange_package;                                                                      
         processor: 0 .. duc$de_maximum_processors;                                                           
         byte_count: 1 .. osc$max_segment_length;                                                             
         continue_if_possible: boolean;                                                                       
     VAR bytes_returned: ost$segment_length;                                                                  
     VAR file_data_seq_p: ^SEQ ( * );                                                                         
     VAR access_data: dut$access_data;                                                                        
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      bytes_left: 0 .. 10000(16),                                                                             
      file_data_p: ^ARRAY [ * ] OF cell,                                                                      
      memory_file_data_p: ^ARRAY [ * ] OF cell,                                                               
      memory_file_p: ^cell,                                                                                   
      new_byte_size: ost$segment_length,                                                                      
      pva: ost$pva,                                                                                           
      remaining: 0 .. osc$max_segment_length,                                                                 
      rma: ost$real_memory_address;                                                                           
                                                                                                              
    status.normal := TRUE;                                                                                    
    initialize_access_data (access_data);                                                                     
    bytes_returned := 0;                                                                                      
    pva := process_virtual_address;                                                                           
    remaining := byte_count;                                                                                  
                                                                                                              
    WHILE TRUE DO                                                                                             
      dup$translate_pva (pva, exchange, processor, rma, bytes_left, access_data, status);                     
      IF NOT status.normal OR NOT access_data.memory_found THEN                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      IF bytes_left >= remaining THEN                                                                         
        bytes_left := remaining;                                                                              
        remaining := 0;                                                                                       
      ELSE                                                                                                    
        remaining := remaining - bytes_left;                                                                  
      IFEND;                                                                                                  
                                                                                                              
      { Retrieve a pointer to the start of the current data.                                                  
                                                                                                              
      dup$access_real_memory (bytes_left, rma, memory_file_p, new_byte_size, status);                         
      IF NOT status.normal AND (status.condition <> due$memory_partially_avail) THEN                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      { Retrieve a pointer to the data on the memory file.                                                    
                                                                                                              
      RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO memory_file_p;         
      NEXT memory_file_data_p: [1 .. bytes_left] IN                                                           
            duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                          
      IF memory_file_data_p = NIL THEN                                                                        
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      { Retrieve a pointer to the data on the output file.                                                    
                                                                                                              
      NEXT file_data_p: [1 .. bytes_left] IN file_data_seq_p;                                                 
      IF file_data_p = NIL THEN                                                                               
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      { Copy the data from the memory file to the output file.                                                
                                                                                                              
      file_data_p^ := memory_file_data_p^;                                                                    
      bytes_returned := bytes_returned + bytes_left;                                                          
      IF remaining <= 0 THEN                                                                                  
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      IF access_data.page_fault AND NOT continue_if_possible THEN                                             
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      pva.offset := pva.offset + bytes_left;                                                                  
    WHILEND;                                                                                                  
                                                                                                              
  PROCEND dup$copy_virtual_memory_pva;                                                                        
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$copy_virtual_memory_sva', EJECT ??                                                        
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure copies memory using an sva.                                                                
                                                                                                              
  PROCEDURE [XDCL] dup$copy_virtual_memory_sva                                                                
    (    system_virtual_address: dut$ee_system_virtual_address;                                               
         processor: 0 .. duc$de_maximum_processors;                                                           
         byte_count: 1 .. osc$max_segment_length;                                                             
         continue_if_possible: boolean;                                                                       
     VAR bytes_returned: ost$segment_length;                                                                  
     VAR file_data_seq_p: ^SEQ ( * );                                                                         
     VAR access_data: dut$access_data;                                                                        
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      bytes_left: 0 .. 10000(16),                                                                             
      file_data_p: ^ARRAY [ * ] OF cell,                                                                      
      memory_file_data_p: ^ARRAY [ * ] OF cell,                                                               
      memory_file_p: ^cell,                                                                                   
      new_byte_size: ost$segment_length,                                                                      
      remaining: 0 .. osc$max_segment_length,                                                                 
      rma: ost$real_memory_address,                                                                           
      sva: dut$ee_system_virtual_address;                                                                     
                                                                                                              
    status.normal := TRUE;                                                                                    
    initialize_access_data (access_data);                                                                     
    bytes_returned := 0;                                                                                      
    sva := system_virtual_address;                                                                            
    remaining := byte_count;                                                                                  
                                                                                                              
    WHILE TRUE DO                                                                                             
      dup$translate_sva (sva, processor, rma, bytes_left, access_data, status);                               
      IF NOT status.normal OR NOT access_data.memory_found THEN                                               
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      IF bytes_left >= remaining THEN                                                                         
        bytes_left := remaining;                                                                              
        remaining := 0;                                                                                       
      ELSE                                                                                                    
        remaining := remaining - bytes_left;                                                                  
      IFEND;                                                                                                  
                                                                                                              
      { Retrieve a pointer to the start of the current data.                                                  
                                                                                                              
      dup$access_real_memory (bytes_left, rma, memory_file_p, new_byte_size, status);                         
      IF NOT status.normal AND (status.condition <> due$memory_partially_avail) THEN                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      { Retrieve a pointer to the data on the memory file.                                                    
                                                                                                              
      RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO memory_file_p;         
      NEXT memory_file_data_p: [1 .. bytes_left] IN                                                           
            duv$execution_environment.restart_file.segment_pointer.sequence_pointer;                          
      IF memory_file_data_p = NIL THEN                                                                        
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      { Retrieve a pointer to the data on the output file.                                                    
                                                                                                              
      NEXT file_data_p: [1 .. bytes_left] IN file_data_seq_p;                                                 
      IF file_data_p = NIL THEN                                                                               
        osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                          
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      { Copy the data from the memory file to the output file.                                                
                                                                                                              
      file_data_p^ := memory_file_data_p^;                                                                    
      bytes_returned := bytes_returned + bytes_left;                                                          
      IF remaining <= 0 THEN                                                                                  
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      IF (NOT access_data.valid_segment OR access_data.page_fault OR NOT access_data.memory_found)            
            AND NOT continue_if_possible THEN                                                                 
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      sva.offset := sva.offset + bytes_left;                                                                  
    WHILEND;                                                                                                  
                                                                                                              
  PROCEND dup$copy_virtual_memory_sva;                                                                        
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$translate_pva', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure translates a pva and determines if it is valid.                                            
                                                                                                              
  PROCEDURE [XDCL] dup$translate_pva                                                                          
    (    pva: ost$pva;                                                                                        
         exchange: dut$exchange_package;                                                                      
         processor: 0 .. duc$de_maximum_processors;                                                           
     VAR rma: ost$real_memory_address;                                                                        
     VAR bytes_left: 0 .. 10000(16);                                                                          
     VAR access_data: dut$access_data;                                                                        
     VAR status: ost$status);                                                                                 
                                                                                                              
    TYPE                                                                                                      
      t$segment_descriptor = RECORD                                                                           
        ste: t$segment_descriptor_entry,                                                                      
        fill1: 0 .. 0ff(16),                                                                                  
        asti: mmt$ast_index,                                                                                  
      RECEND,                                                                                                 
                                                                                                              
      t$segment_descriptor_entry = PACKED RECORD                                                              
        vl: (c$vl_invalid_entry, c$vl_reserved, c$vl_regular_segment, c$vl_cache_bypass),                     
        xp: ost$execute_privilege,                                                                            
        rp: ost$read_privilege,                                                                               
        wp: ost$write_privilege,                                                                              
        r1: ost$ring,                                                                                         
        r2: ost$ring,                                                                                         
        asid: dut$ee_asid,                                                                                    
        key_lock: ost$key_lock,                                                                               
      RECEND,                                                                                                 
                                                                                                              
      t$segment_descriptor_table = RECORD                                                                     
        st: ARRAY [0 .. * ] OF t$segment_descriptor,                                                          
      RECEND,                                                                                                 
                                                                                                              
      t$segment_desc_table_address = RECORD                                                                   
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          value: ost$real_memory_address,                                                                     
        = FALSE =                                                                                             
          part_1: 0 .. 0ffff(16),                                                                             
          part_2: 0 .. 0ffff(16),                                                                             
        CASEND,                                                                                               
      RECEND;                                                                                                 
                                                                                                              
    VAR                                                                                                       
      new_byte_size: ost$segment_length,                                                                      
      sdt_p: ^t$segment_descriptor_table,                                                                     
      sdta: t$segment_desc_table_address,                                                                     
      segment_descriptor_p: ^t$segment_descriptor,                                                            
      sva: dut$ee_system_virtual_address,                                                                     
      valid_segment: boolean;                                                                                 
                                                                                                              
    status.normal := TRUE;                                                                                    
    initialize_access_data (access_data);                                                                     
    valid_segment := TRUE;                                                                                    
                                                                                                              
    IF NOT duv$execution_environment.processor_registers [processor].available THEN                           
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                    
            'The processor registers psm, pta and ptl for processor', status);                                
      osp$append_status_integer (osc$status_parameter_delimiter, processor, 10, FALSE, status);               
      osp$append_status_parameter (osc$status_parameter_delimiter, 'are', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Check if the segment number is valid.                                                                   
                                                                                                              
    IF pva.seg > exchange.segment_table_length THEN                                                           
      osp$set_status_abnormal (duc$dump_analyzer_id, due$address_translation_error,                           
            'invalid segment: the segment number is greater than segment table length.', status);             
      append_pva (pva, status);                                                                               
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Retrieve a pointer to the segment descriptor.                                                           
                                                                                                              
    sdta.part_1 := exchange.segment_table_address_1;                                                          
    sdta.part_2 := exchange.segment_table_address_2;                                                          
    dup$access_real_memory ((#SIZE (t$segment_descriptor) * pva.seg), sdta.value, segment_descriptor_p,       
          new_byte_size, status);                                                                             
    IF NOT status.normal THEN                                                                                 
      IF status.condition = due$invalid_offset THEN                                                           
        osp$set_status_abnormal (duc$dump_analyzer_id, due$address_translation_error,                         
              'The segment table address and/or the segment table length in the exchange package is invalid.',
              status);                                                                                        
      IFEND;                                                                                                  
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Retrieve the segment descriptor table from the segment descriptor.                                      
                                                                                                              
    RESET duv$execution_environment.restart_file.segment_pointer.sequence_pointer TO segment_descriptor_p;    
    NEXT sdt_p: [0 .. pva.seg] IN duv$execution_environment.restart_file.segment_pointer.sequence_pointer;    
    IF sdt_p = NIL THEN                                                                                       
      osp$set_status_abnormal (duc$dump_analyzer_id, due$nil_pointer, '', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Determine if the segment is valid.                                                                      
                                                                                                              
    IF sdt_p^.st [pva.seg].ste.vl = c$vl_invalid_entry THEN                                                   
      IF sdt_p^.st [pva.seg].ste.asid.value = 0 THEN                                                          
        osp$set_status_abnormal (duc$dump_analyzer_id, due$address_translation_error,                         
              'invalid segment (the invalid entry bit is set in the segment table entry).', status);          
        append_pva (pva, status);                                                                             
        RETURN;  {---->                                                                                       
      ELSE                                                                                                    
        valid_segment := FALSE;                                                                               
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    { Check for a negative pva offset.                                                                        
                                                                                                              
    IF pva.offset < 0 THEN                                                                                    
      osp$set_status_abnormal (duc$dump_analyzer_id, due$address_translation_error,                           
            'address specification error (the offset is negative).', status);                                 
      append_pva (pva, status);                                                                               
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    { Check for a valid sva.                                                                                  
                                                                                                              
    sva.asid.asid := sdt_p^.st [pva.seg].ste.asid.asid;                                                       
    sva.offset := pva.offset;                                                                                 
    dup$translate_sva (sva, processor, rma, bytes_left, access_data, status);                                 
    IF NOT status.normal THEN                                                                                 
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    access_data.valid_segment := valid_segment;                                                               
                                                                                                              
  PROCEND dup$translate_pva;                                                                                  
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'dup$translate_sva', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure translates an sva and determines if it is valid.                                           
                                                                                                              
  PROCEDURE [XDCL] dup$translate_sva                                                                          
    (    system_virtual_address: dut$ee_system_virtual_address;                                               
         processor: 0 .. duc$de_maximum_processors;                                                           
     VAR rma: ost$real_memory_address;                                                                        
     VAR bytes_left: 0 .. 10000(16);                                                                          
     VAR access_data: dut$access_data;                                                                        
     VAR status: ost$status);                                                                                 
                                                                                                              
    TYPE                                                                                                      
      t$hash_index = PACKED RECORD                                                                            
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          hash_result: t$hash_result,                                                                         
          zeros: 0 .. 0f(16),                                                                                 
        = FALSE =                                                                                             
          fill: 0 .. 3fff(16),                                                                                
          rightmost_12_bits: 0 .. 0fff(16),                                                                   
        CASEND,                                                                                               
      RECEND,                                                                                                 
                                                                                                              
      t$hash_result = PACKED RECORD                                                                           
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          hash_upper: SET OF 0 .. 5,                                                                          
          value: SET OF 0 .. 15,                                                                              
        = FALSE =                                                                                             
          ptl: SET OF 0 .. 13,                                                                                
        CASEND,                                                                                               
      RECEND,                                                                                                 
                                                                                                              
      t$page_frame_address = PACKED RECORD                                                                    
        leftmost_15_bits: 0 .. 7fff(16),                                                                      
        psm: dut$ee_page_size_mask,                                                                           
      RECEND,                                                                                                 
                                                                                                              
      t$page_id = PACKED RECORD                                                                               
        asid: dut$ee_asid,                                                                                    
        pagenum: dut$ee_page_number,                                                                          
      RECEND,                                                                                                 
                                                                                                              
      t$page_table_entry = PACKED RECORD                                                                      
        v: boolean,                                                                                           
        c: boolean,                                                                                           
        u: boolean,                                                                                           
        m: boolean,                                                                                           
        pageid: t$page_id,                                                                                    
        pfa: t$page_frame_address,                                                                            
      RECEND,                                                                                                 
                                                                                                              
      t$page_table_reference = PACKED RECORD                                                                  
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          rma: ost$real_memory_address,                                                                       
        = FALSE =                                                                                             
          leftmost_6_bits: 0 .. 03f(16),                                                                      
          ptl: dut$ee_page_table_length,                                                                      
          rightmost_12_bits: 0 .. 0fff(16),                                                                   
        CASEND,                                                                                               
      RECEND,                                                                                                 
                                                                                                              
      t$psm_integer = RECORD                                                                                  
        case boolean of                                                                                       
        = TRUE =                                                                                              
          psm: dut$ee_page_size_mask,                                                                         
        = FALSE =                                                                                             
          int: 0 .. 0ff(16),                                                                                  
        CASEND,                                                                                               
      RECEND,                                                                                                 
                                                                                                              
      t$pt_rma_formation = PACKED RECORD                                                                      
        CASE boolean OF                                                                                       
        = TRUE =                                                                                              
          value: ost$real_memory_address,                                                                     
        = FALSE =                                                                                             
          zero: 0 .. 1,                                                                                       
          pfa: t$page_frame_address,                                                                          
          rightmost_9_bits: 0 .. 1ff(16),                                                                     
        CASEND,                                                                                               
      RECEND;                                                                                                 
                                                                                                              
    VAR                                                                                                       
      hash_index: t$hash_index,                                                                               
      max_page_offset: dut$ee_page_offset,                                                                    
      new_byte_size: ost$segment_length,                                                                      
      page_number: dut$ee_page_number,                                                                        
      page_offset: dut$ee_page_offset,                                                                        
      page_table_entry_p: ^t$page_table_entry,                                                                
      page_table_reference: t$page_table_reference,                                                           
      psm: dut$ee_page_size_mask,                                                                             
      psm_int: t$psm_integer,                                                                                 
      pta: dut$ee_page_table_address,                                                                         
      ptl: dut$ee_page_table_length,                                                                          
      pt_rma: t$pt_rma_formation,                                                                             
      search_count: 0 .. 31,                                                                                  
      sva: dut$ee_system_virtual_address;                                                                     
                                                                                                              
    status.normal := TRUE;                                                                                    
    initialize_access_data (access_data);                                                                     
    sva := system_virtual_address;                                                                            
                                                                                                              
    IF NOT duv$execution_environment.processor_registers [processor].available THEN                           
      osp$set_status_abnormal (duc$dump_analyzer_id, due$data_not_on_dump,                                    
            'The processor registers psm, pta and ptl for processor', status);                                
      osp$append_status_integer (osc$status_parameter_delimiter, processor, 10, FALSE, status);               
      osp$append_status_parameter (osc$status_parameter_delimiter, 'are', status);                            
      RETURN;  {---->                                                                                         
    IFEND;                                                                                                    
                                                                                                              
    psm := duv$execution_environment.processor_registers [processor].page_size_mask;                          
    pta := duv$execution_environment.processor_registers [processor].page_table_address;                      
    ptl := duv$execution_environment.processor_registers [processor].page_table_length;                       
    page_number := sva.pn;                                                                                    
    page_offset := sva.po;                                                                                    
    psm_int.psm := - psm;                                                                                     
    psm_int.int := psm_int.int + 1;                                                                           
    page_number.value := page_number.value DIV psm_int.int;                                                   
    sva.pn.psm := sva.pn.psm * psm;                                                                           
    page_offset.psm := page_offset.psm * ( - psm);                                                            
                                                                                                              
    max_page_offset.value := 0ffff(16);                                                                       
    max_page_offset.psm := max_page_offset.psm * ( - psm);                                                    
    v$page_size := max_page_offset.value + 1;                                                                 
    bytes_left := v$page_size - page_offset.value;                                                            
                                                                                                              
    hash_index.hash_result.hash_upper := page_number.low_order_6_bits XOR sva.asid.asid_hash;                 
    hash_index.hash_result.value := page_number.low_order_16_bits XOR sva.asid.asid;                          
    hash_index.hash_result.ptl := hash_index.hash_result.ptl * ptl;                                           
    hash_index.zeros := 0;                                                                                    
                                                                                                              
    page_table_reference.leftmost_6_bits := pta.leftmost_6_bits;                                              
    page_table_reference.ptl := pta.ptl + hash_index.hash_result.ptl;                                         
    page_table_reference.rightmost_12_bits := hash_index.rightmost_12_bits;                                   
                                                                                                              
  /search_page_table/                                                                                         
    FOR search_count := 0 TO 31 DO                                                                            
      dup$access_real_memory (#SIZE (t$page_table_entry),                                                     
            (page_table_reference.rma + (search_count * #SIZE (t$page_table_entry))), page_table_entry_p,     
            new_byte_size, status);                                                                           
      IF NOT status.normal THEN                                                                               
        osp$set_status_abnormal (duc$dump_analyzer_id, due$address_translation_error,                         
              'The calculated page table index (rma used to search the page table) is not on the dump tape',  
              status);                                                                                        
        append_sva (sva, status);                                                                             
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      IF (page_table_entry_p^.pageid.pagenum.value = sva.pn.value) AND                                        
            (page_table_entry_p^.pageid.asid.asid = sva.asid.asid) THEN                                       
        pt_rma.zero := 0;                                                                                     
        pt_rma.pfa := page_table_entry_p^.pfa;                                                                
        pt_rma.pfa.psm := pt_rma.pfa.psm + page_offset.psm;                                                   
        pt_rma.rightmost_9_bits := page_offset.rightmost_9_bits;                                              
        rma := pt_rma.value;                                                                                  
        IF NOT page_table_entry_p^.v THEN                                                                     
          access_data.page_fault := TRUE;                                                                     
          access_data.memory_found := TRUE;                                                                   
          access_data.page_fault_offset := system_virtual_address.offset;                                     
          access_data.next_page_offset := system_virtual_address.offset + bytes_left;                         
        IFEND;                                                                                                
        RETURN;  {---->                                                                                       
      IFEND;                                                                                                  
                                                                                                              
      IF NOT page_table_entry_p^.c THEN                                                                       
        EXIT /search_page_table/                                                                              
      IFEND;                                                                                                  
    FOREND /search_page_table/;                                                                               
                                                                                                              
    access_data.page_fault := TRUE;                                                                           
    access_data.memory_found := FALSE;                                                                        
    access_data.page_fault_offset := system_virtual_address.offset;                                           
    access_data.next_page_offset := system_virtual_address.offset + bytes_left;                               
    bytes_left := 0;                                                                                          
                                                                                                              
  PROCEND dup$translate_sva;                                                                                  
MODEND dum$virtual_memory_access;                                                                             
*DECK DECK=DUP$ABORT_HANDLER EXPAND=FALSE
                                                                                                              
?? NEWTITLE := 'abort_handler', EJECT ??                                                                      
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc pmt$condition                                                                                          
*copyc pmt$condition_information                                                                              
*copyc ost$stack_frame_save_area                                                                              
*copyc ost$status                                                                                             
?? POP ??                                                                                                     
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure is called from the condition handler to invoke a procedure called CLEAN_UP in the event    
{   that the procedure is aborted.                                                                            
                                                                                                              
    PROCEDURE abort_handler                                                                                   
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           save_area_p: ^ost$stack_frame_save_area;                                                           
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      clean_up;                                                                                               
                                                                                                              
    PROCEND abort_handler;                                                                                    
?? OLDTITLE ??                                                                                                
*DECK DECK=DUP$ACCESS_REAL_MEMORY EXPAND=FALSE
                                                                                                              
  PROCEDURE [XREF] dup$access_real_memory                                                                     
    (    size: ost$real_memory_address;                                                                       
         offset: ost$real_memory_address;                                                                     
     VAR memory_p: ^cell;                                                                                     
     VAR new_byte_size: ost$segment_length;                                                                   
     VAR status: ost$status);                                                                                 
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc ost$hardware_subranges                                                                                 
*copyc ost$status                                                                                             
?? POP ??                                                                                                     
*DECK DECK=DUP$BUILD_HOME_SPEC EXPAND=FALSE
  PROCEDURE [XREF] dup$build_home_spec (
        module_name: pmt$program_name;
        procedure_name: pmt$program_name;
        recursion_level_value: clt$data_value;
        recursion_direction_value: clt$data_value;
    VAR home_spec: dut$home_specification;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc dut$home_specification
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=DUP$BUILD_VARIABLE_SPEC EXPAND=FALSE
  PROCEDURE [XREF] dup$build_variable_spec (
        home_spec: dut$home_specification;
        symbol_entry: dut$symbol_entry;
        nested_proc: boolean;
        current_proc: dut$symbol_entry;
    VAR variable_spec: dut$variable_specification;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dut$home_specification
*copyc dut$variable_specification
*copyc ost$status
?? POP ??
*DECK DECK=DUP$CLOSE_DISPLAY EXPAND=FALSE
  PROCEDURE [XREF] dup$close_display (
    VAR display_control: ^clt$display_control;
        close_default_file:boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=DUP$COPY_VIRTUAL_MEMORY_PVA EXPAND=FALSE
                                                                                                              
  PROCEDURE [XREF] dup$copy_virtual_memory_pva                                                                
    (    process_virtual_address: ost$pva;                                                                    
         exchange: dut$exchange_package;                                                                      
         processor: 0 .. duc$de_maximum_processors;                                                           
         byte_count: 1 .. osc$max_segment_length;                                                             
         continue_if_possible: boolean;                                                                       
     VAR bytes_returned: ost$segment_length;                                                                  
     VAR file_data_seq_p: ^SEQ ( * );                                                                         
     VAR access_data: dut$access_data;                                                                        
     VAR status: ost$status);                                                                                 
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc dut$access_data                                                                                        
*copyc dut$exchange_package                                                                                   
*copyc dut$execution_environment                                                                              
*copyc ost$status                                                                                             
?? POP ??                                                                                                     
*DECK DECK=DUP$COPY_VIRTUAL_MEMORY_SVA EXPAND=FALSE
                                                                                                              
  PROCEDURE [XREF] dup$copy_virtual_memory_sva                                                                
    (    system_virtual_address: dut$ee_system_virtual_address;                                               
         processor: 0 .. duc$de_maximum_processors;                                                           
         byte_count: 1 .. osc$max_segment_length;                                                             
         continue_if_possible: boolean;                                                                       
     VAR bytes_returned: ost$segment_length;                                                                  
     VAR file_data_seq_p: ^SEQ ( * );                                                                         
     VAR access_data: dut$access_data;                                                                        
     VAR status: ost$status);                                                                                 
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc dut$access_data                                                                                        
*copyc dut$execution_environment                                                                              
*copyc dut$exchange_package                                                                                   
*copyc ost$status                                                                                             
?? POP ??                                                                                                     
*DECK DECK=DUP$DETERMINE_DUMP_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] dup$determine_dump_information
    (VAR dump_information: dut$dump_information);

?? PUSH (LISTEXT := ON) ??
*copyc dut$dump_information
?? POP ??
*DECK DECK=DUP$DISPLAY_ALL_NAMES EXPAND=FALSE
  PROCEDURE [XREF] dup$display_all_names (
        home_spec: dut$home_specification;
        display_type: dut$display_type;
        p_variant_selection: ^clt$data_value;
    VAR display_control_pointer: ^clt$display_control;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$display_control
*copyc dut$display_type
*copyc dut$home_specification
*copyc ost$status
?? POP ??
*DECK DECK=DUP$DISPLAY_DATA EXPAND=FALSE

  PROCEDURE [XREF] dup$display_data
    (    display_option_list_p: ^clt$data_value;
         cm_word_structure: boolean;
         radix: 8 .. 16;
         address: ost$segment_length;
         total_units: integer;
     VAR display_control: clt$display_control;
     VAR restart_file_seq_p: ^SEQ ( * );
     VAR end_of_input_file: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$display_control
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=DUP$DISPLAY_EXCHANGE_PACKAGE EXPAND=FALSE
                                                                                                              
  PROCEDURE [XREF] dup$display_exchange_package                                                               
    (    exchange_package: dut$exchange_package;                                                              
         full_display: boolean;                                                                               
     VAR display_control: clt$display_control;                                                                
     VAR status: ost$status);                                                                                 
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc dut$exchange_package                                                                                   
*copyc clt$display_control                                                                                    
*copyc ost$status                                                                                             
?? POP ??                                                                                                     
*DECK DECK=DUP$DISPLAY_LANGUAGE_VARIABLE EXPAND=FALSE
  PROCEDURE [XREF] dup$display_language_variable (
        variable_name: ^string ( * );
        home_spec: dut$home_specification;
        display_type: dut$display_type;
        p_variant_selection: ^clt$data_value;
    VAR display_control_pointer: ^clt$display_control;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$display_control
*copyc dut$display_type
*copyc dut$home_specification
*copyc ost$status
?? POP ??
*DECK DECK=DUP$DISPLAY_MEMORY EXPAND=FALSE
                                                                                                              
  PROCEDURE [XDCL] dup$display_memory                                                                         
    (VAR display_control: clt$display_control;                                                                
         memory_p: ^SEQ ( * );                                                                                
         byte_count: 1 .. 8;                                                                                  
         repeat_count: integer;                                                                               
         start_address: ost$segment_offset;                                                                   
     VAR status: ost$status);                                                                                 
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc clt$display_control                                                                                    
*copyc osd$virtual_address                                                                                    
*copyc ost$status                                                                                             
?? POP ??                                                                                                     
*DECK DECK=DUP$DISPLAY_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] dup$display_message
    (    status_message: ost$status;
     VAR display_control: clt$display_control);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=DUP$DISPLAY_REGISTER_DATA EXPAND=FALSE

  PROCEDURE [XREF] dup$display_register_data
    (    description: string (*);
         register: ARRAY [1 .. duc$de_max_register_length] OF 0 .. 0ff(16);
     VAR display_control: clt$display_control);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc dut$dump_environment
?? POP ??
*DECK DECK=DUP$DISPLAY_STRING EXPAND=FALSE
  PROCEDURE [XREF] dup$display_string (
    VAR display_control_pointer: ^clt$display_control;
        space_required: amt$page_width;
        str: string ( * );
        indent_count: ost$string_size;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amd$page_format_declarations
*copyc clt$display_control
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=DUP$DISPLAY_XP_REGISTERS EXPAND=FALSE

  PROCEDURE [XREF] dup$display_xp_registers
    (    xp_data: dut$ee_xp_data;
     VAR display_control: clt$display_control);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc dut$execution_environment
?? POP ??
*DECK DECK=DUP$EVALUATE_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] dup$evaluate_parameters
    (    parameter_list: clt$parameter_list;
         default_list: dut$default_change_list;
         pdt_p: ^clt$parameter_description_table;
         pvt_p: ^clt$parameter_value_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_description_table
*copyc clt$parameter_list
*copyc clt$parameter_value_table
*copyc dut$default_parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=DUP$FIND_MODULE_TABLE_FOR_PVA EXPAND=FALSE
  PROCEDURE [XREF] dup$find_module_table_for_pva (pva: ost$pva;
    VAR module_item: ^dbt$module_address_table_item;
    VAR section_item_index: llt$section_ordinal;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dbt$entry_point_table
*copyc dbt$module_address_table_item
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=DUP$FIND_PROCEDURE_FOR_PVA EXPAND=FALSE
  PROCEDURE [XREF] dup$find_procedure_for_pva (
        module_item: ^dbt$module_address_table_item;
        section_item_index: llt$section_ordinal;
        pva: ost$pva;
    VAR symbol_table_address: ^llt$debug_symbol_table;
    VAR symbol_index: llt$symbol_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dbt$module_address_table_item
*copyc dut$symbol_entry
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=DUP$FIND_RECORD_LIST_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] dup$find_record_list_entry
    (    data_value: clt$data_value;
     VAR entry_p: ^dut$de_other_record_entry);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc dut$dump_environment
?? POP ??
*DECK DECK=DUP$FIND_STACK_FRAME_FOR_PROC EXPAND=FALSE
  PROCEDURE [XREF] dup$find_stack_frame_for_proc (
        proc_start: ost$pva;
        proc_length: ost$segment_length;
        stack_search_direction: dut$stack_search_direction;
        target_sf_number: dut$proc_recursion_number;
    VAR target_sf: ost$pva;
    VAR target_sf_save_area: ^ost$stack_frame_save_area;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dut$proc_recursion_number
*copyc dut$stack_search_direction
*copyc osd$virtual_address
*copyc ost$stack_frame_save_area
*copyc ost$status
?? POP ??
*DECK DECK=DUP$GET_BYTES EXPAND=FALSE
  PROCEDURE [XREF] dup$get_bytes (
        source: ost$pva;
        destination: ^cell;
        length: 0..7fffffff(16);
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=DUP$IS_CPU1_INSTALLED EXPAND=FALSE

  PROCEDURE [XREF] dup$is_cpu1_installed
    (    origin: dut$ee_cpu1_installed_commands;
         processor: 0 .. duc$de_maximum_processors;
     VAR display_control: clt$display_control);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc dut$dump_environment
*copyc dut$execution_environment
?? POP ??
*DECK DECK=DUP$LOCATE_NEXT_SYMBOL EXPAND=FALSE
  PROCEDURE [XREF] dup$locate_next_symbol (
        symbol_table_address: ^llt$debug_symbol_table;
    VAR symbol_entry: {input,output} dut$symbol_entry;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dut$symbol_entry
*copyc llt$debug_symbol_table
*copyc ost$status
?? POP ??
*DECK DECK=DUP$LOCATE_SYMBOL_FOR_NUMBER EXPAND=FALSE
  PROCEDURE [XREF] dup$locate_symbol_for_number (
        symbol_table_address: ^llt$debug_symbol_table;
        symbol_number: llt$symbol_number;
    VAR symbol_entry: dut$symbol_entry;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dut$symbol_entry
*copyc llt$debug_symbol_table
*copyc ost$status
?? POP ??
*DECK DECK=DUP$LOCATE_VARIABLE_SYMBOL EXPAND=FALSE
  PROCEDURE [XREF] dup$locate_variable_symbol (
        variable_name: pmt$program_name;
        home_spec: dut$home_specification;
        search_options: dut$variable_search_options;
    VAR symbol_entry: dut$symbol_entry;
    VAR nested_proc: boolean;
    VAR current_proc: dut$symbol_entry;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dut$home_specification
*copyc dut$variable_specification
*copyc ost$status
?? POP ??
*DECK DECK=DUP$MOVE_BYTES EXPAND=FALSE

  PROCEDURE [XREF] dup$move_bytes
    (    source: ^cell;
         destination: ^cell;
         length: 0..7fffffff(16);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=DUP$NEW_PAGE_PROCEDURE EXPAND=FALSE
                                                                                                              
  PROCEDURE [XREF] dup$new_page_procedure                                                                     
    (VAR display_control: clt$display_control;                                                                
         new_page_number: integer;                                                                            
    VAR  status: ost$status);                                                                                 
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc clt$display_control                                                                                    
*copyc ost$status                                                                                             
?? POP ??                                                                                                     
*DECK DECK=DUP$OPEN_DISPLAY EXPAND=FALSE
  PROCEDURE [XREF] dup$open_display (
        file_name: fst$file_reference;
    VAR display_control_pointer: ^clt$display_control;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=DUP$OUTPUT_MESSAGE EXPAND=FALSE
  PROCEDURE [XREF] dup$output_message (
        status_message: ost$status;
    VAR display_control_pointer: ^clt$display_control;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=DUP$PROCESS_MODULE_PARAMETER EXPAND=FALSE
  PROCEDURE [XREF] dup$process_module_parameter (
        parameter_name: string (*);
        p_parameter_value: ^clt$data_value;
    VAR module_name: pmt$program_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=DUP$PUT_ITEM EXPAND=FALSE

  PROCEDURE [XREF] dup$put_item
    (    item: string ( * );
         trim_option: clt$trim_display_text_option;
         term_option: amt$term_option;
     VAR display_control: clt$display_control);

?? PUSH (LISTEXT := ON) ??
*copyc amt$term_option
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=DUP$READ_DUMP_FILE EXPAND=FALSE
                                                                                                              
  PROCEDURE [XREF] dup$read_dump_file                                                                         
    (    file_name_p: ^fst$file_reference;                                                                    
     VAR status: ost$status);                                                                                 
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc fst$file_reference                                                                                     
*copyc ost$status                                                                                             
?? POP ??                                                                                                     
*DECK DECK=DUP$RETRIEVE_BC_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] dup$retrieve_bc_entry
    (    channel_number: 0 .. duc$de_maximum_channels;
     VAR entry_p: ^dut$de_buffer_controlware_entry);

?? PUSH (LISTEXT := ON) ??
*copyc dut$dump_environment
?? POP ??
*DECK DECK=DUP$RETRIEVE_CIP_PROGRAM EXPAND=FALSE

  PROCEDURE [XREF] dup$retrieve_cip_program
    (    cip_program_name: string (4);
     VAR cip_program_available: boolean;
     VAR cip_program_cell_p: ^cell);
*DECK DECK=DUP$RETRIEVE_DFT_POINTERS EXPAND=FALSE

  PROCEDURE [XREF] dup$retrieve_dft_pointers
    (VAR dft_data: dut$dft_data;
     VAR data_length_valid: boolean;
     VAR data_valid: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc dut$dft_data_types
?? POP ??
*DECK DECK=DUP$RETRIEVE_EXCHANGE_PACKAGE EXPAND=FALSE

  PROCEDURE [XREF] dup$retrieve_exchange_package
    (    processor: 0 .. duc$de_maximum_processors;
         exchange_parameter: clt$data_value;
     VAR exchange_package_p: ^dut$exchange_package;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc dut$dump_environment
*copyc dut$exchange_package
*copyc ost$status
?? POP ??
*DECK DECK=DUP$RETRIEVE_REGISTER EXPAND=FALSE

  PROCEDURE [XREF] dup$retrieve_register
    (    element: dut$de_element;
         element_index: 0 .. 0ff(16);
         register_number: 0 .. duc$de_max_register_number;
     VAR register: dut$de_maintenance_register);

?? PUSH (LISTEXT := ON) ??
*copyc dut$dump_environment
?? POP ??
*DECK DECK=DUP$SIMULATE_VARIABLE EXPAND=FALSE
  PROCEDURE [XREF] dup$simulate_variable (
        home_spec: dut$home_specification;
        address: ost$pva;
        type_name: pmt$program_name;
    VAR variable_spec: dut$variable_specification;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dut$home_specification
*copyc dut$variable_specification
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=DUP$TRANSLATE_PVA EXPAND=FALSE
                                                                                                              
  PROCEDURE [XREF] dup$translate_pva                                                                          
    (    pva: ost$pva;                                                                                        
         exchange: dut$exchange_package;                                                                      
         processor: 0 .. duc$de_maximum_processors;                                                           
     VAR rma: ost$real_memory_address;                                                                        
     VAR bytes_left: 0 .. 10000(16);                                                                          
     VAR access_data: dut$access_data;                                                                        
     VAR status: ost$status);                                                                                 
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc dut$access_data                                                                                        
*copyc dut$exchange_package                                                                                   
*copyc dut$execution_environment                                                                              
*copyc ost$status                                                                                             
?? POP ??                                                                                                     
*DECK DECK=DUP$TRANSLATE_SVA EXPAND=FALSE
                                                                                                              
  PROCEDURE [XREF] dup$translate_sva                                                                          
    (    system_virtual_address: dut$ee_system_virtual_address;                                               
         processor: 0 .. duc$de_maximum_processors;                                                           
     VAR rma: ost$real_memory_address;                                                                        
     VAR bytes_left: 0 .. 10000(16);                                                                          
     VAR access_data: dut$access_data;                                                                        
     VAR status: ost$status);                                                                                 
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc dut$access_data                                                                                        
*copyc dut$exchange_package                                                                                   
*copyc dut$execution_environment                                                                              
*copyc ost$status                                                                                             
?? POP ??                                                                                                     
*DECK DECK=DUT$ACCESS_DATA EXPAND=FALSE

  TYPE
    dut$access_data = RECORD
      valid_segment: boolean,
      page_fault: boolean,
      memory_found: boolean,
      next_page_offset: ost$segment_offset,
      page_fault_offset: ost$segment_offset,
    RECEND;

*copyc osd$virtual_address
*DECK DECK=DUT$CONDITION_REGISTERS EXPAND=FALSE
                                                                                                              
  CONST                                                                                                       
    duc$cr_mtr_condition_lower_bit = 48,                                                                      
    duc$cr_upper_order_bit = 63,                                                                              
    duc$cr_user_condition_lower_bit = 48;                                                                     
                                                                                                              
  TYPE                                                                                                        
    dut$cr_mtr_condition_reg_def = ARRAY [duc$cr_mtr_condition_lower_bit .. duc$cr_upper_order_bit] OF        
          string (duc$de_max_definition_length),                                                              
    dut$cr_user_condition_reg_def = ARRAY [duc$cr_user_condition_lower_bit .. duc$cr_upper_order_bit] OF      
          string (duc$de_max_definition_length);                                                              
                                                                                                              
  VAR                                                                                                         
    duv$cr_mtr_condition_reg_def: [STATIC] dut$cr_mtr_condition_reg_def :=                                    
          ['detected uncorrectable error', 'MCR bit unassigned', 'short warning',                             
           'instruction specification error', 'address specification error', '170 exchange request',          
           'access violation', 'environment specification error', 'external interrupt',                       
           'page table search without find', 'system call', 'system interval timer',                          
           'invalid segment/ring number zero', 'outward call/inward return', 'soft error log',                
           'trap exception'],                                                                                 
                                                                                                              
    duv$cr_user_condition_reg_def: [STATIC] dut$cr_user_condition_reg_def :=                                  
          ['privileged instruction fault', 'unimplemented instruction', 'free flag',                          
           'process interval timer', 'inter-ring pop', 'critical frame flag', 'keypoint', 'divide fault',     
           'debug', 'arithmetic overflow', 'exponent overflow', 'exponent underflow',                         
           'floating point loss of significance', 'floating point indefinite',                                
           'arithmetic loss of significance', 'invalid BDP data'];                                            
*DECK DECK=DUT$DEFAULT_PARAMETER_LIST EXPAND=FALSE

  TYPE
    dut$default_change_list = ARRAY [1 .. *] OF dut$default_change_list_entry,

    dut$default_change_list_entry = RECORD
      default_name: dut$default_parameters,
      number: clt$parameter_number,
    RECEND,

    dut$default_parameters = (duc$dp_address_mode, duc$dp_exchange, duc$dp_iou, duc$dp_pp_type,
          duc$dp_processor),

    dut$default_parameter_list = ARRAY [dut$default_parameters] OF dut$default_parameter_values,

    dut$default_parameter_values = RECORD
      default_set: boolean,
      value: ost$name,
    RECEND;

*copyc clt$parameter_number
*copyc ost$name
*DECK DECK=DUT$DFT_DATA_TYPES EXPAND=FALSE

  CONST
    duc$dft_cw = 0,
    duc$dft_max_known_pointer_words = dsc$dftb_rpw_dft_secondary,
    duc$dft_max_mdb_buffers = 3;

  TYPE
    dut$dft_buffer = RECORD
      cell_p: ^cell,
      size: dst$dftb_element_size,
      used: boolean,
    RECEND,

    dut$dft_data = RECORD
      revision_level: dst$dftb_cw_revision_level,
      mrb_length: dst$dftb_structure_length,
      actual_number_of_pointer_words: dst$dftb_cw_pointer_words,
      number_of_pointer_words: dst$dftb_cw_pointer_words,
      buffer: ARRAY [0 .. duc$dft_max_known_pointer_words] OF dut$dft_buffer,
      mdb: ARRAY [1 .. duc$dft_max_mdb_buffers] OF dut$dft_buffer,
    RECEND;

*copyc dst$180_dft_block
*DECK DECK=DUT$DID_RECORD_TYPE EXPAND=FALSE

  CONST
    duc$did_edd_dump = 0,
    duc$did_dual_state_dump = 1,
    duc$did_es0_dump = 2,
    duc$did_cy2000_dump = 3,

    duc$did_all_180_state_memory = 1,
    duc$did_no_180_state_memory = 2,
    duc$did_critical_180_state_mem = 3,

    duc$did_unload_dump_selected = 1;

  TYPE
    dut$did_dual_state_data = RECORD
      memory_option: dut$did_identifier_entry,
    RECEND,

    dut$did_edd_data = RECORD
      memory_option: dut$did_identifier_entry,
      tape_information: dut$did_tape_information,
      deadstart_channel: dut$did_identifier_entry,
      extended_memory: dut$did_extended_memory,
      dump_number: dut$did_identifier_entry,
      unload_option: dut$did_identifier_entry,
      dump_taken_indicator: dut$did_identifier_entry,
      ipi_tape_port_number: dut$did_identifier_entry,
    RECEND,

    dut$did_extended_memory = PACKED RECORD
      entry: dut$did_extended_memory_entry,
      channel: dut$did_identifier_entry,
    RECEND,

    dut$did_extended_memory_entry = PACKED RECORD
      fill: 0 .. 0f(16),
      value_1: 0 .. 77(8),
      value_2: 0 .. 77(8),
    RECEND,

    dut$did_identifier_entry = RECORD
      fill: 0 .. 0ff(16),
      value: 0 .. 0ff(16),
    RECEND,

    dut$did_tape_information = PACKED RECORD
      tape_type: dut$did_identifier_entry,
      tape_channel: dut$did_identifier_entry,
      tape_equipment: dut$did_tape_equipment_entry,
      tape_unit: dut$did_tape_unit_entry,
    RECEND,

    dut$did_tape_equipment_entry = PACKED RECORD
      fill_1: 0 .. 0f(16),
      value: 0 .. 7,
      fill_2: 0 .. 1ff(16),
    RECEND,

    dut$did_tape_unit_entry = PACKED RECORD
      fill: 0 .. 0fff(16),
      value: 0 .. 0f(16),
    RECEND;
*DECK DECK=DUT$DISPLAY_TYPE EXPAND=FALSE
  TYPE
    dut$display_type = (duc$natural_type, duc$integer_type, dut$boolean_type,
      duc$char_type, duc$real_type, duc$longreal_type, duc$string_type,
      duc$hex_type);
*DECK DECK=DUT$DUMP_ENVIRONMENT EXPAND=FALSE
                                                                                                              
  CONST                                                                                                       
    duc$de_7154_adapter = 0,                                                                                  
    duc$de_isd_adapter = 1,                                                                                   
    duc$de_7155_adapter = 2,                                                                                  
    duc$de_ismt_adapter = 3,                                                                                  
    duc$de_895_adapter = 4;                                                                                   
                                                                                                              
  CONST                                                                                                       
    duc$de_control_store_size = 08000(16),                                                                    
    duc$de_element_byte_number = 5,                                                                           
    duc$de_max_cio_pp_memories = 25,                                                                          
    duc$de_max_definition_length = 60,                                                                        
    duc$de_max_other_record_length = 500000,                                                                  
    duc$de_max_other_records = 0ffff(16),                                                                     
    duc$de_max_page_size = 65536,                                                                             
    duc$de_max_pp_memories = 25,                                                                              
    duc$de_max_register_length = 8,                                                                           
    duc$de_max_register_number = 0fff(16),                                                                    
    duc$de_max_register_parts = 256,                                                                          
    duc$de_maximum_bc_size = 35840,                                                                           
    duc$de_maximum_channels = 33,                                                                             
    duc$de_maximum_ious = 1,                                                                                  
    duc$de_maximum_mci_port = 6,                                                                              
    duc$de_maximum_processors = 3,                                                                            
    duc$de_maximum_rma = 0ffffffff(16),                                                                       
    duc$de_model_byte_number = 6,                                                                             
    duc$de_number_of_iou_mrs_dumped = 256,                                                                    
    duc$de_number_of_mem_mrs_dumped = 256,                                                                    
    duc$de_number_of_pro_mrs_dumped = 500,                                                                    
    duc$de_serial_num_byte_number = 7;                                                                        
                                                                                                              
  TYPE                                                                                                        
    dut$dump_environment = RECORD                                                                             
      revision_level: integer,                                                                                
      dump_identifier: dut$de_dump_identifier,                                                                
      central_memory: dut$de_central_memory,                                                                  
      critical_memory: dut$de_critical_memory,                                                                
      active_exchange: dut$de_exchange_packages,                                                              
      jps_exchange: dut$de_exchange_packages,                                                                 
      mps_exchange: dut$de_exchange_packages,                                                                 
      iou_maintenance_registers: ARRAY [0 .. duc$de_maximum_ious] OF dut$de_iou_maintenance_regs,             
      mem_maintenance_registers: dut$de_mem_maintenance_regs,                                                 
      pro_maintenance_registers: ARRAY [0 .. duc$de_maximum_processors] OF dut$de_pro_maintenance_regs,       
      iou_memory: ARRAY [0 .. duc$de_maximum_ious] OF dut$de_iou_memory,                                      
      register_file: ARRAY [0 .. duc$de_maximum_processors] OF dut$de_register_file,                          
      control_store: dut$de_control_store,                                                                    
      buffer_controlware: dut$de_buffer_controlware,                                                          
      other_records: dut$de_other_records,                                                                    
    RECEND;                                                                                                   
                                                                                                              
  TYPE                                                                                                        
    dut$de_buffer_controlware = RECORD                                                                        
      available: boolean,                                                                                     
      number_of_entries: 0 .. 0ff(16),                                                                        
      first_bc_entry: amt$file_byte_address,                                                                  
    RECEND,                                                                                                   
                                                                                                              
    dut$de_buffer_controlware_entry = RECORD                                                                  
      channel_number: 0 .. duc$de_maximum_channels,                                                           
      channel_type: dut$de_channel_type,                                                                      
      words: 0 .. duc$de_maximum_bc_size,                                                                     
      first_byte: amt$file_byte_address,                                                                      
      next_bc_entry: amt$file_byte_address,                                                                   
    RECEND,                                                                                                   
                                                                                                              
    dut$de_buffer_controlware_word = 0 .. 0ffff(16),                                                          
                                                                                                              
    dut$de_central_memory = RECORD                                                                            
      available: boolean,                                                                                     
      first_byte: amt$file_byte_address,                                                                      
      last_byte: amt$file_byte_address,                                                                       
      bias: amt$file_byte_address,                                                                            
    RECEND,                                                                                                   
                                                                                                              
    dut$de_channel_type = duc$de_7154_adapter .. duc$de_ismt_adapter,                                         
                                                                                                              
    dut$de_control_store = RECORD                                                                             
      main: ARRAY [0 .. duc$de_maximum_processors] OF dut$de_control_store_entry,                             
      shadow: ARRAY [0 .. duc$de_maximum_processors] OF dut$de_control_store_entry,                           
    RECEND,                                                                                                   
                                                                                                              
    dut$de_control_store_entry = RECORD                                                                       
      available: boolean,                                                                                     
      size: 0 .. duc$de_control_store_size,                                                                   
      first_byte: amt$file_byte_address,                                                                      
    RECEND,                                                                                                   
                                                                                                              
    dut$de_control_store_word = RECORD                                                                        
      upper: integer,                                                                                         
      lower: integer,                                                                                         
    RECEND,                                                                                                   
                                                                                                              
    dut$de_critical_memory = RECORD                                                                           
      available: boolean,                                                                                     
      page_size: 0 .. duc$de_max_page_size,                                                                   
      page_table_size: 0 .. 0ffff(16),                                                                        
      cpt_start: amt$file_byte_address,                                                                       
      cpt_end: amt$file_byte_address,                                                                         
      critical_page_table_offset: amt$file_byte_address,                                                      
      first_entry: amt$file_byte_address,                                                                     
      last_entry: amt$file_byte_address,                                                                      
      current_entry: amt$file_byte_address,                                                                   
      first_page: amt$file_byte_address,                                                                      
      current_page_offset: amt$file_byte_address,                                                             
      first_rma_available: 0 .. 0ffffffff(16),                                                                
      last_rma_available: 0 .. 0ffffffff(16),                                                                 
      last_ccm_other_record: amt$file_byte_address,                                                           
      total_ccm_size: integer,                                                                                
      multiple_ccm_exists: boolean,                                                                           
    RECEND,                                                                                                   
                                                                                                              
    dut$de_critical_page_entry = RECORD                                                                       
      available: boolean,                                                                                     
      page_offset: amt$file_byte_address,                                                                     
    RECEND,                                                                                                   
                                                                                                              
    dut$de_dump_identifier = RECORD                                                                           
      available: boolean,                                                                                     
      edd_revision_level: string (3),                                                                         
      size: 0 .. 0ffff(16),                                                                                   
      first_byte: amt$file_byte_address,                                                                      
    RECEND,                                                                                                   
                                                                                                              
    dut$de_element = (duc$de_iou, duc$de_cpu, duc$de_memory),                                                 
                                                                                                              
    dut$de_exchange_data = RECORD                                                                             
      available: boolean,                                                                                     
      value: dut$exchange_package,                                                                            
      radial_mci: 0 .. duc$de_maximum_mci_port,                                                               
    RECEND,                                                                                                   
                                                                                                              
    dut$de_exchange_packages = ARRAY [0 .. duc$de_maximum_processors] OF dut$de_exchange_data,                
                                                                                                              
    dut$de_iou_maintenance_regs = RECORD                                                                      
      available: boolean,                                                                                     
      registers: ARRAY [1 .. duc$de_number_of_iou_mrs_dumped] OF dut$de_maintenance_register,                 
    RECEND,                                                                                                   
                                                                                                              
    dut$de_iou_memory = RECORD                                                                                
      nio_pp: ARRAY [0 .. duc$de_max_pp_memories] OF dut$de_pp_memory,                                        
      cio_pp: ARRAY [0 .. duc$de_max_cio_pp_memories] OF dut$de_pp_memory,                                    
    RECEND,                                                                                                   
                                                                                                              
    dut$de_maintenance_register = RECORD                                                                      
      available: boolean,                                                                                     
      number: 0 .. duc$de_max_register_number,                                                                
      part: 1 .. duc$de_max_register_parts,                                                                   
      length: 0 .. duc$de_max_register_length,                                                                
      value: ARRAY [1 .. duc$de_max_register_length] OF 0 .. 0ff(16),                                         
    RECEND,                                                                                                   
                                                                                                              
    dut$de_mem_maintenance_regs = RECORD                                                                      
      available: boolean,                                                                                     
      registers: ARRAY [1 .. duc$de_number_of_mem_mrs_dumped] OF dut$de_maintenance_register,                 
    RECEND,                                                                                                   
                                                                                                              
    dut$de_other_record_entry = RECORD                                                                        
      name: dut$de_other_record_name,                                                                         
      index: 0 .. duc$de_max_other_records,                                                                   
      record_type: dut$de_other_record_type,                                                                  
      size: 0 .. 0ffffffff(16),                                                                               
      header_line_count: 0 .. 3ffff(16),                                                                      
      report_record_length: 0 .. 3ffff(16),                                                                   
      first_byte: amt$file_byte_address,                                                                      
      next_record: amt$file_byte_address,                                                                     
    RECEND,                                                                                                   
                                                                                                              
    dut$de_other_record_name = string (3),                                                                    
                                                                                                              
    dut$de_other_records = RECORD                                                                             
      available: boolean,                                                                                     
      number_of_records: 0 .. duc$de_max_other_records,                                                       
      first_record: amt$file_byte_address,                                                                    
    RECEND,                                                                                                   
                                                                                                              
    dut$de_other_record_type = (duc$de_ort_detail, duc$de_ort_dump, duc$de_ort_report),                       
                                                                                                              
    dut$de_pp_memory = RECORD                                                                                 
      available: boolean,                                                                                     
      r_register: 0 .. 3fffff(16),                                                                            
      size: 0 .. 0ffffffff(16),                                                                               
      first_byte: amt$file_byte_address,                                                                      
    RECEND,                                                                                                   
                                                                                                              
    dut$de_pro_maintenance_regs = RECORD                                                                      
      available: boolean,                                                                                     
      registers: ARRAY [1 .. duc$de_number_of_pro_mrs_dumped] OF dut$de_maintenance_register,                 
      radial_mci: 0 .. duc$de_maximum_mci_port,                                                               
    RECEND,                                                                                                   
                                                                                                              
    dut$de_register_file = RECORD                                                                             
      available: boolean,                                                                                     
      number_of_registers: 0 .. (duc$de_max_register_number DIV 8),                                           
      register: ARRAY [0 .. (duc$de_max_register_number DIV 8)] OF dut$de_register_file_entry,                
    RECEND,                                                                                                   
                                                                                                              
    dut$de_register_file_entry = RECORD                                                                       
      available: boolean,                                                                                     
      value: integer,                                                                                         
    RECEND;                                                                                                   
                                                                                                              
*copyc dut$exchange_package                                                                                   
*copyc amt$file_byte_address                                                                                  
*copyc amt$file_identifier                                                                                    
*DECK DECK=DUT$DUMP_INFORMATION EXPAND=FALSE

  TYPE
    dut$dump_information = RECORD
      dump_type: dut$di_dump_type,
      iou: ARRAY [0 .. duc$de_maximum_ious] OF dut$di_iou_data,
      tape_type: dut$di_tape_type,
    RECEND,

    dut$di_dump_type = (duc$di_dt_unknown, duc$di_dt_edd, duc$di_dt_dual_state, duc$di_dt_es0,
          duc$di_dt_cy2000),

    dut$di_iou_class = (duc$di_ic_unknown, duc$di_ic_iou_4k, duc$di_ic_iou_8k, duc$di_ic_iou_16k),

    dut$di_iou_data = RECORD
      class: dut$di_iou_class,
      pp_word_size: dut$di_pp_word_size,
      model: dut$di_iou_model,
    RECEND,

    dut$di_iou_model = (duc$di_im_unknown, duc$di_im_i1_1x, duc$di_im_i2_20, duc$di_im_i4_40,
          duc$di_im_i4_42, duc$di_im_i4_43, duc$di_im_i4_44, duc$di_im_i4_46, duc$di_im_i0_5x),

    dut$di_pp_word_size = 0 .. 16384,

    dut$di_tape_type = (duc$di_tt_unknown, duc$di_tt_1, duc$di_tt_2, duc$di_tt_3, duc$di_tt_4,
          duc$di_tt_40, duc$di_tt_41);

*copyc dut$dump_environment
*DECK DECK=DUT$EXCHANGE_PACKAGE EXPAND=FALSE
                                                                                                              
{ NOTE:                                                                                                       
{   CYBER 180 processor exchange package, modified form of ost$exchange_package for use in a dump             
{   analyzer environment.                                                                                     
                                                                                                              
  TYPE                                                                                                        
    dut$exchange_package = PACKED RECORD                                                                      
      p_register: ost$p_register,                                                                             
      undefined1: 0 .. 0f(16),                                                                                
      vmid: ost$virtual_machine_identifier,                                                                   
      undefined2: 0 .. 0f(16),                                                                                
      uvmid: ost$virtual_machine_identifier,                                                                  
      a0_dynamic_space_pointer: ost$pva,                                                                      
      flags: ost$flags,                                                                                       
      undefined3: 0 .. 03ff(16),                                                                              
      trap_enable: ost$trap_enable,                                                                           
      a1_current_stack_frame: ost$pva,                                                                        
      user_mask: ALIGNED ost$user_conditions,                                                                 
      a2_previous_save_area: ost$pva,                                                                         
      monitor_mask: ALIGNED ost$monitor_conditions,                                                           
      a3: ost$pva,                                                                                            
      user_condition_register: ost$user_conditions,                                                           
      a4: ost$pva,                                                                                            
      monitor_condition_register: ost$monitor_conditions,                                                     
      a5: ost$pva,                                                                                            
      undefined4: 0 .. 0f(16),                                                                                
      keypoint_class_number: ost$keypoint_class,                                                              
      last_processor_id: 0 .. 0ff(16),                                                                        
      a6: ost$pva,                                                                                            
      keypoint_mask: ALIGNED ost$keypoint_mask,                                                               
      a7: ost$pva,                                                                                            
      keypoint_code_1: 0 .. 0ffff(16),                                                                        
      a8: ost$pva,                                                                                            
      keypoint_code_2: 0 .. 0ffff(16),                                                                        
      a9: ost$pva,                                                                                            
      process_interval_timer_1: 0 .. 0ffff(16),                                                               
      aa: ost$pva,                                                                                            
      process_interval_timer_2: 0 .. 0ffff(16),                                                               
      ab: ost$pva,                                                                                            
      base_constant_1: 0 .. 0ffff(16),                                                                        
      ac: ost$pva,                                                                                            
      base_constant_2: 0 .. 0ffff(16),                                                                        
      ad: ost$pva,                                                                                            
      model_dependent_flags: 0 .. 0ffff(16),                                                                  
      ae: ost$pva,                                                                                            
      undefined5: 0 .. 0f(16),                                                                                
      segment_table_length: ost$segment,                                                                      
      af: ost$pva,                                                                                            
      x_registers: ARRAY [ost$register_number] OF ost$x_register,                                             
      model_dependent_word: integer {ost$word} ,                                                              
      segment_table_address_1: 0 .. 0ffff(16),                                                                
      untranslatable_pointer: ost$pva,                                                                        
      segment_table_address_2: 0 .. 0ffff(16),                                                                
      trap_pointer: ost$pva,                                                                                  
      debug_index: 0 .. 63,                                                                                   
      undefined6: 0 .. 7,                                                                                     
      debug_mask_register: ost$debug_mask,                                                                    
      debug_list_pointer: ^ost$debug_list,                                                                    
      tos_registers: ARRAY [ost$valid_ring] OF ost$top_of_stack_pointer,                                      
    RECEND,                                                                                                   
                                                                                                              
    ost$flags = SET OF (osc$critical_frame, osc$on_condition, osc$keypoint_enable, osc$process_not_damaged),  
                                                                                                              
    ost$top_of_stack_pointer = PACKED RECORD                                                                  
      undefined: 0 .. 0fff(16),                                                                               
      largest_ring_number: ost$ring, {only present in ring 1 TOS}                                             
      pva: ost$pva,                                                                                           
    RECEND;                                                                                                   
                                                                                                              
*copyc osd$registers                                                                                          
*copyc osd$virtual_address                                                                                    
*copyc osd$conditions                                                                                         
*copyc ost$debug_code                                                                                         
*copyc ost$debug_list                                                                                         
*copyc ost$debug_mask                                                                                         
*copyc ost$keypoint_class                                                                                     
*copyc ost$stack_frame_save_area                                                                              
*copyc ost$trap_enable                                                                                        
*copyc ost$virtual_machine_identifier                                                                         
*DECK DECK=DUT$EXECUTION_ENVIRONMENT EXPAND=FALSE
                                                                                                              
  TYPE                                                                                                        
    dut$execution_environment = RECORD                                                                        
      processing_options: dut$ee_processing_options,                                                          
      output_file_opened: boolean,                                                                            
      output_file: dut$ee_output_file_record,                                                                 
      restart_file_opened: boolean,                                                                           
      restart_file: dut$ee_restart_file_record,                                                               
      processor_registers: ARRAY [0 .. duc$de_maximum_processors] OF dut$ee_processor_registers,              
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_a_register = RECORD                                                                                
      two_bytes: 0 .. 0ffff(16),                                                                              
      pva: ost$pva,                                                                                           
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_address_parameter = RECORD                                                                         
      CASE 1 .. 4 OF                                                                                          
      = 1 =                                                                                                   
        pva_fill: 0 .. 0ffff(16),                                                                             
        pva_part: ost$pva,                                                                                    
      = 2 =                                                                                                   
        sva_fill: 0 .. 0fff(16),                                                                              
        sva_part: dut$ee_system_virtual_address,                                                              
      = 3 =                                                                                                   
        rma_part: integer,                                                                                    
      = 4 =                                                                                                   
        quarter_part_1: 0 .. 0ffff(16),                                                                       
        quarter_part_2: 0 .. 0ffff(16),                                                                       
        quarter_part_3: 0 .. 0ffff(16),                                                                       
        quarter_part_4: 0 .. 0ffff(16),                                                                       
      CASEND,                                                                                                 
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_asid = PACKED RECORD                                                                               
      CASE 0 .. 2 OF                                                                                          
      = 0 =                                                                                                   
        asid: SET OF 0 .. 15,                                                                                 
      = 1 =                                                                                                   
        value: 0 .. 0ffff(16),                                                                                
      = 2 =                                                                                                   
        asid_hash: SET OF 0 .. 5,                                                                             
        filler: 0 .. 3ff(16),                                                                                 
      CASEND,                                                                                                 
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_cpu1_installed_commands = (duc$ee_cic_disd, duc$ee_cic_dismr),                                     
                                                                                                              
    dut$ee_output_file_record = RECORD                                                                        
      display_control: clt$display_control,                                                                   
      name: string (fsc$max_path_size),                                                                       
      size: 0 .. fsc$max_path_size,                                                                           
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_page_number = PACKED RECORD                                                                        
      CASE 0 .. 3 OF                                                                                          
      = 0 =                                                                                                   
        fill1: 0 .. 3f(16),                                                                                   
        low_order_16_bits: SET OF 0 .. 15,                                                                    
      = 1 =                                                                                                   
        fill2: 0 .. 7fff(16),                                                                                 
        psm: dut$ee_page_size_mask,                                                                           
      = 2 =                                                                                                   
        value: 0 .. 3fffff(16),                                                                               
      = 3 =                                                                                                   
        filler: 0 .. 0ffff(16),                                                                               
        low_order_6_bits: SET OF 0 .. 5,                                                                      
      CASEND,                                                                                                 
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_page_offset = PACKED RECORD                                                                        
      CASE boolean OF                                                                                         
      = TRUE =                                                                                                
        value: 0 .. 0ffff(16),                                                                                
      = FALSE =                                                                                               
        psm: dut$ee_page_size_mask,                                                                           
        rightmost_9_bits: 0 .. 1ff(16),                                                                       
      CASEND,                                                                                                 
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_page_size_mask = SET OF 0 .. 6,                                                                    
                                                                                                              
    dut$ee_page_table_address = PACKED RECORD                                                                 
      leftmost_6_bits: 0 .. 03f(16),                                                                          
      ptl: dut$ee_page_table_length,                                                                          
      zeros: 0 .. 0fff(16),                                                                                   
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_page_table_length = SET OF 0 .. 13,                                                                
                                                                                                              
    dut$ee_processing_options = (duc$ee_po_all_memory, duc$ee_po_critical_memory, duc$ee_po_no_memory),       
                                                                                                              
    dut$ee_processor_mr_jps = PACKED RECORD                                                                   
      fill1: 0 .. 0ffffffff(16),                                                                              
      value: ost$real_memory_address,                                                                         
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_processor_mr_mps = PACKED RECORD                                                                   
      fill1: 0 .. 0ffffffff(16),                                                                              
      value: ost$real_memory_address,                                                                         
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_processor_mr_psm = PACKED RECORD                                                                   
      fill1: 0 .. 0ffffffffffff(16),                                                                          
      fill2: 0 .. 0ff(16),                                                                                    
      fill3: boolean,                                                                                         
      value: dut$ee_page_size_mask,                                                                           
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_processor_mr_pta = PACKED RECORD                                                                   
      fill1: 0 .. 0ffffffff(16),                                                                              
      value: dut$ee_page_table_address,                                                                       
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_processor_mr_ptl = PACKED RECORD                                                                   
      fill1: 0 .. 0ffffffffffff(16),                                                                          
      fill2: 0 .. 3,                                                                                          
      value: dut$ee_page_table_length,                                                                        
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_processor_mr_ss = PACKED RECORD                                                                    
      fill: 0 .. 0ffffffffffff(16),                                                                           
      value: dut$ee_processor_status_summary,                                                                 
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_processor_registers = RECORD                                                                       
      available: boolean,                                                                                     
      status_summary: dut$ee_processor_status_summary,                                                        
      job_process_state: ost$real_memory_address,                                                             
      monitor_process_state: ost$real_memory_address,                                                         
      page_size_mask: dut$ee_page_size_mask,                                                                  
      page_table_address: dut$ee_page_table_address,                                                          
      page_table_length: dut$ee_page_table_length,                                                            
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_pro_cy2000_ss_reg_bits = (duc$ee_cy_not_used_48, duc$ee_cy_not_used_49, duc$ee_cy_not_used_50,     
          duc$ee_cy_not_used_51, duc$ee_cy_not_used_52, duc$ee_cy_monitor_mode, duc$ee_cy_clock_halted_1,     
          duc$ee_cy_clock_halted_2, duc$ee_cy_pmf_halted, duc$ee_cy_capture_buffer_halted,                    
          duc$ee_cy_microcode_halted, duc$ee_cy_not_used_59, duc$ee_cy_mac_halt, duc$ee_cy_due,               
          duc$ee_cy_subsystem_fault_bit, duc$ee_cy_retryable_error),                                          
                                                                                                              
    dut$ee_pro_general_ss_reg_bits = (duc$ee_gen_not_used_48, duc$ee_gen_not_used_49, duc$ee_gen_not_used_50, 
          duc$ee_gen_not_used_51, duc$ee_gen_not_used_52, duc$ee_gen_not_used_53, duc$ee_gen_not_used_54,     
          duc$ee_gen_not_used_55, duc$ee_gen_not_used_56, duc$ee_gen_not_used_57, duc$ee_gen_180_monitor_mode,
          duc$ee_gen_short_warning, duc$ee_gen_processor_halt, duc$ee_gen_uncorrectable_error,                
          duc$ee_gen_corrected_error, duc$ee_gen_long_warning),                                               
                                                                                                              
    dut$ee_pro_cy2000_ss_set = SET OF dut$ee_pro_cy2000_ss_reg_bits,                                          
                                                                                                              
    dut$ee_pro_general_ss_set = SET OF dut$ee_pro_general_ss_reg_bits,                                        
                                                                                                              
    dut$ee_processor_status_summary = RECORD                                                                  
      CASE boolean OF                                                                                         
      = TRUE =                                                                                                
        general: dut$ee_pro_general_ss_set,                                                                   
      = FALSE =                                                                                               
        cy2000: dut$ee_pro_cy2000_ss_set,                                                                     
      CASEND,                                                                                                 
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_psm_value = PACKED RECORD                                                                          
      CASE boolean OF                                                                                         
      = TRUE =                                                                                                
        psm: dut$ee_page_size_mask,                                                                           
      = FALSE =                                                                                               
        value: 0 .. 7f(16),                                                                                   
      CASEND,                                                                                                 
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_pta_value = PACKED RECORD                                                                          
      CASE boolean OF                                                                                         
      = TRUE =                                                                                                
        pta: dut$ee_page_table_address,                                                                       
      = FALSE =                                                                                               
        value: 0 .. 0ffffffff(16),                                                                            
      CASEND,                                                                                                 
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_ptl_value = PACKED RECORD                                                                          
      CASE boolean OF                                                                                         
      = TRUE =                                                                                                
        ptl: dut$ee_page_table_length,                                                                        
      = FALSE =                                                                                               
        value: 0 .. 03fff(16),                                                                                
      CASEND,                                                                                                 
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_restart_file_record = RECORD                                                                       
      file_identifier: amt$file_identifier,                                                                   
      segment_pointer: amt$segment_pointer                                                                    
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_system_virtual_address = PACKED RECORD                                                             
      asid: dut$ee_asid,                                                                                      
      CASE 0 .. 3 OF                                                                                          
      = 0 =                                                                                                   
        offset: ost$segment_offset,                                                                           
      = 1 =                                                                                                   
        fill1: boolean,                                                                                       
        pn: dut$ee_page_number,                                                                               
      = 2 =                                                                                                   
        fill2: 0 .. 0ffff(16),                                                                                
        po: dut$ee_page_offset,                                                                               
      CASEND,                                                                                                 
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_x_register = RECORD                                                                                
      CASE boolean OF                                                                                         
      = TRUE =                                                                                                
        part: ARRAY [0 .. 3] OF 0 .. 0ffff(16),                                                               
      = FALSE =                                                                                               
        int: integer,                                                                                         
      CASEND,                                                                                                 
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_xp = RECORD                                                                                        
      p_register: dut$ee_a_register,                                                                          
      data: dut$ee_xp_data,                                                                                   
      tos_registers: ARRAY [1 .. 0f(16)] OF dut$ee_a_register,                                                
    RECEND,                                                                                                   
                                                                                                              
    dut$ee_xp_data = RECORD                                                                                   
      a_regs: ARRAY [ost$register_number] OF dut$ee_a_register,                                               
      x_regs: ARRAY [ost$register_number] OF dut$ee_x_register,                                               
      mdw: dut$ee_x_register,                                                                                 
      sta1: dut$ee_a_register,                                                                                
      sta2: dut$ee_a_register,                                                                                
      debug_word: dut$ee_a_register,                                                                          
    RECEND;                                                                                                   
                                                                                                              
*copyc amt$file_identifier                                                                                    
*copyc amt$segment_pointer                                                                                    
*copyc clt$display_control                                                                                    
*copyc dut$dump_environment                                                                                   
*copyc fsc$max_path_size                                                                                      
*copyc osd$virtual_address                                                                                    
*copyc ost$hardware_subranges                                                                                 
*DECK DECK=DUT$HOME_SPECIFICATION EXPAND=FALSE
  TYPE
    dut$home_specification = record
      module_item: ^dbt$module_address_table_item,
      line_table_address: ^llt$line_address_table,
      symbol_table_address: ^llt$debug_symbol_table,
      procedure_entry: dut$symbol_entry,
      proc_recursion_level: dut$proc_recursion_number,
      stack_search_direction: dut$stack_search_direction,
      language: llt$module_generator,
      current_stack_frame: ^ost$stack_frame_save_area,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc dbt$module_address_table_item
*copyc dut$proc_recursion_number
*copyc dut$stack_search_direction
*copyc dut$symbol_entry
*copyc llt$debug_symbol_table
*copyc llt$line_address_table
*copyc llt$module_generator
*copyc ost$stack_frame_save_area
?? POP ??
*DECK DECK=DUT$PROC_RECURSION_NUMBER EXPAND=FALSE
  TYPE
    dut$proc_recursion_number = 0 .. 7ffffff(16);
*DECK DECK=DUT$REGISTERS_DEFINITION EXPAND=FALSE
                                                                                                              
  CONST                                                                                                       
    duc$rd_810_830_pfs0_lower_bit = 32,                                                                       
    duc$rd_810_830_pfs1_lower_bit = 24,                                                                       
    duc$rd_845_860_pfs_upper_bit = 15,                                                                        
    duc$rd_cy2000_ss_lower_bit = 53,                                                                          
    duc$rd_lower_order_bit = 0,                                                                               
    duc$rd_ss_lower_bit = 56,                                                                                 
    duc$rd_upper_order_bit = 63;                                                                              
                                                                                                              
  TYPE                                                                                                        
    dut$rd_cy2000_ss_reg_def = ARRAY [duc$rd_cy2000_ss_lower_bit .. duc$rd_upper_order_bit] OF                
          string (duc$de_max_definition_length),                                                              
    dut$rd_general_ss_reg_def = ARRAY [duc$rd_ss_lower_bit .. duc$rd_upper_order_bit] OF                      
          string (duc$de_max_definition_length),                                                              
                                                                                                              
    dut$rd_93x_iou_reg_def = ARRAY [0 .. 0ba(16)] OF string (duc$de_max_definition_length),                   
    dut$rd_general_iou_reg_def = ARRAY [0 .. 0c9(16)] OF string (duc$de_max_definition_length),               
                                                                                                              
    dut$rd_93x_mem_reg_def = ARRAY [0 .. 0ef(16)] OF string (duc$de_max_definition_length),                   
    dut$rd_general_mem_reg_def = ARRAY [0 .. 0a8(16)] OF string (duc$de_max_definition_length),               
                                                                                                              
    dut$rd_93x_pro_reg_def = ARRAY [0 .. 0e6(16)] OF string (duc$de_max_definition_length),                   
    dut$rd_general_pro_reg_def = ARRAY [0 .. 0e6(16)] OF string (duc$de_max_definition_length),               
                                                                                                              
    dut$rd_pro_810_830_pfs_0 = ARRAY [duc$rd_810_830_pfs0_lower_bit .. duc$rd_upper_order_bit] OF             
          string (duc$de_max_definition_length),                                                              
    dut$rd_pro_810_830_pfs_1 = ARRAY [duc$rd_810_830_pfs1_lower_bit .. duc$rd_upper_order_bit] OF             
          string (duc$de_max_definition_length),                                                              
    dut$rd_pro_845_860_pfs = ARRAY [duc$rd_lower_order_bit .. duc$rd_845_860_pfs_upper_bit] OF                
          string (duc$de_max_definition_length),                                                              
    dut$rd_pro_general_pfs = ARRAY [duc$rd_lower_order_bit .. duc$rd_upper_order_bit] OF                      
          string (duc$de_max_definition_length);                                                              
                                                                                                              
  VAR                                                                                                         
                                                                                                              
    { Summary status definitions.                                                                             
                                                                                                              
    duv$rd_cy2000_iou_ss_def: [STATIC] dut$rd_general_ss_reg_def :=                                           
          ['unused', 'io port block', 'unused', 'summary status', 'processor halt', 'uncorrected error',      
           'corrected error', 'physical environment monitor'],                                                
                                                                                                              
    duv$rd_general_iou_ss_def: [STATIC] dut$rd_general_ss_reg_def :=                                          
          ['unused', 'unused', 'unused', 'summary status', 'processor halt', 'uncorrected error',             
           'corrected error', 'long warning'],                                                                
                                                                                                              
    duv$rd_i0_i1_i2_iou_ss_def: [STATIC] dut$rd_general_ss_reg_def :=                                         
          ['unused', 'unused', 'unused', 'summary status', 'processor halt', 'uncorrected error',             
           'unused', 'long warning'],                                                                         
                                                                                                              
    duv$rd_93x_mem_ss_def: [STATIC] dut$rd_general_ss_reg_def :=                                              
         ['unused', 'page map error', 'unused', 'unused', 'unused', 'uncorrected error', 'corrected error',   
          'long warning'],                                                                                    
                                                                                                              
    duv$rd_cy2000_mem_ss_def: [STATIC] dut$rd_cy2000_ss_reg_def :=                                            
          ['unused', 'boards 0-15 clock halted', 'boards 16-23 clock halted', 'pmf halted or not installed',  
           'capture buffer halted', 'external interrupt', 'cel', 'error or mac halt', 'uel',                  
           'subsystem fault bit', 'unused'],                                                                  
                                                                                                              
    duv$rd_general_mem_ss_def: [STATIC] dut$rd_general_ss_reg_def :=                                          
         ['oscillator selected', 'oscillator selected', 'clock tuning mode', 'unused', 'unused',              
          'uncorrected error', 'corrected error', 'long warning'],                                            
                                                                                                              
    duv$rd_model_34_mem_ss_def: [STATIC] dut$rd_general_ss_reg_def :=                                         
         ['unused', 'unused', 'unused', 'unused', 'early warning', 'uncorrected error', 'corrected error',    
          'power/environment warning'],                                                                       
                                                                                                              
    duv$rd_cy2000_pro_ss_def: [STATIC] dut$rd_cy2000_ss_reg_def :=                                            
          ['monitor mode', 'boards 0-15 clock halted', 'boards 16-23 clock halted',                           
           'pmf halted or not installed', 'capture buffer halted or not installed', 'microcode halted',       
           'unused', 'error or mac halt', 'due', 'subsystem fault bit', 'retryable error'],                   
                                                                                                              
    duv$rd_general_pro_ss_def: [STATIC] dut$rd_general_ss_reg_def :=                                          
          ['unused', 'unused', 'c180 monitor mode', 'short warning', 'processor halted', 'uncorrected error', 
           'corrected error', 'long warning'],                                                                
                                                                                                              
    { IOU register definitions.                                                                               
                                                                                                              
    duv$rd_93x_iou_reg_def: [STATIC] dut$rd_93x_iou_reg_def :=                                                
          ['status summary', REP 15 OF ' ', 'element id', ' ', 'options installed', REP 13 OF ' ',            
           'PP 00-04 dec',  REP 9 OF ' ', 'BUS arbiter/cluster 0 dec', 'CM interface/cluster 0 dec',          
           REP 4 OF ' ', 'PP 20-24 dec', REP 9 OF ' ', 'BUS arbiter/cluster 0 dec',                           
           'CM interface/cluster 0 dec', REP 4 OF ' ', 'CH 00-01 channel dec', 'CH 02-03 channel dec',        
           'CH 04-05 channel dec', REP 5 OF ' ', 'CH 20-21 channel dec', 'CH 22-23 channel dec',              
           'CH 24-25 channel dec', REP 5 OF ' ', 'PP 00-04 status 1 register', REP 15 OF ' ',                 
           'PP 20-24 status 1 register', REP 15 OF ' ', 'PP 00-04 status 2 register', REP 15 OF ' ',          
           'PP 20-24 status 2 register', REP 15 OF ' ', 'PP 00-04 fault status register', REP 9 OF ' ',       
           'cluster 0 bus arbiter/fsr', 'cluster 0 CM interface/fsr', REP 4 OF ' ',                           
           'PP 20-24 fault status register', REP 9 OF ' ', 'cluster 2 bus arbiter/fsr',                       
           'cluster 2 CM interface/fsr', REP 4 OF ' ', 'CH 00-01 channel fsr', 'CH 02-03 channel fsr',        
           'CH 04-05 channel fsr', REP 4 OF ' ', 'CH 15,17 channel fsr', 'CH 20-21 channel fsr',              
           'CH 22-23 channel fsr', 'CH 24-25 channel fsr'],                                                   
                                                                                                              
    duv$rd_general_iou_reg_def: [STATIC] dut$rd_general_iou_reg_def :=                                        
          ['status summary', REP 15 OF ' ', 'element id', ' ', 'options installed', REP 3 OF ' ',             
           'options installed', ' ', 'fault status mask', REP 3 OF ' ', 'fault status mask', REP 4 OF ' ',    
           'os bounds', REP 3 OF ' ', 'os bounds', REP 10 OF ' ', 'dependent env control', REP 3 OF ' ',      
           'dependent env control', REP 11 OF ' ', 'status register', REP 3 OF ' ', 'status register',        
           REP 59 OF ' ', 'fault status 1', 'fault status 2', REP 2 OF ' ', 'fault status 1',                 
           'fault status 2', REP 26 OF ' ', 'test mode', REP 3 OF ' ', 'test mode', REP 11 OF ' ',            
           'channel 0 status', 'channel 1 status', 'channel 2 status', 'channel 3 status', 'channel 4 status',
           'channel 5 status', 'channel 6 status', 'channel 7 status', 'channel 8 status', 'channel 9 status',
           REP 6 OF ' ', 'channel 20 status', 'channel 21 status', 'channel 22 status', 'channel 23 status',  
           'channel 24 status', 'channel 25 status', 'channel 26 status', 'channel 27 status',                
           'channel 28 status', 'channel 29 status'],                                                         
                                                                                                              
    { Memory register definitions.                                                                            
                                                                                                              
    duv$rd_93x_mem_reg_def: [STATIC] dut$rd_93x_mem_reg_def :=                                                
          ['status summary', REP 15 OF ' ', 'element id', ' ', 'options installed', REP 13 OF ' ',            
           'dec 0 CM bus arbiter', 'dec input buffer 21-24', REP 3 OF ' ', 'dec output buffer 25-28',         
           REP 10 OF ' ', 'dec bank data and control 30-3F', REP 39 OF ' ', 'options installed', REP 7 OF ' ',
           'bounds registers 60-6F', REP 47 OF ' ', 'bus arbiter', 'output buffer 91-94', REP 3 OF ' ',       
           'input buffer 95-98', REP 10 OF ' ', 'uncorrected error log A0-AF', REP 15 OF ' ',                 
           'uncorrected error log B0-BF', REP 15 OF ' ', 'uncorrected error log C0-CF', REP 15 OF ' ',        
           'corrected error log D0-EF', REP 31 OF ' '],                                                       
                                                                                                              
    duv$rd_cy2000_mem_reg_def: [STATIC] dut$rd_general_mem_reg_def :=                                         
          ['status summary', REP 15 OF ' ', 'element id', ' ', 'options installed', REP 13 OF ' ',            
           'environment control', 'bounds register port 0', 'bounds register port 1',                         
           'bounds register port 2', 'bounds register port 3', REP 123 OF ' ', 'corr err log',                
           REP 3 OF ' ', 'uncorr err log 1', REP 3 OF ' ', 'uncorr err log 2'],                               
                                                                                                              
    duv$rd_general_mem_reg_def: [STATIC] dut$rd_general_mem_reg_def :=                                        
          ['status summary', REP 15 OF ' ', 'element id', ' ', 'options installed', REP 13 OF ' ',            
           'environment control', 'bounds register', REP 126 OF ' ', 'corr err log', REP 3 OF ' ',            
           'uncorr err log 1', REP 3 OF ' ', 'uncorr err log 2'],                                             
                                                                                                              
    { Processor register definitions.                                                                         
                                                                                                              
    duv$rd_930_pro_reg_def: [STATIC] dut$rd_93x_pro_reg_def :=                                                
          ['status summary', REP 15 OF ' ', 'element id', ' ', 'options installed',                           
           'virtual machine cap. list', REP 12 OF ' ', 'floating point adder/shifter dec', 'fp shifter dec',  
           'fp shifter dec', 'c board buffers dec', 'fp multiply dec', 'fp divide dec', 'fp divide dec',      
           'immediate data/register file dec', 'integer unit/utp/byte align dec',                             
           'control store addressing/secded dec', 'psr/register file addressing dec',                         
           'utp/register file dec', 'psr/register file/pac dec', 'process state registers dec',               
           'register file dec', 'address adder/register file dec', 'segment map dec', 'csa addr before halt', 
           'memory interface dec', 'instruction issue dec', 'cache dec', REP 11 OF ' ', 'program address',    
           'monitor process state ptr', 'monitor condition register', 'user condition register',              
           'untranslatable pointer', 'segment table length', 'segment table address', 'base constant',        
           'page table address', 'page table length', 'page size mask', 'model dependent flags',              
           'model dependent words', REP 19 OF ' ', 'monitor mask register', 'job process state ptr',          
           'system interval timer', 'keypoint buffer pointer', REP 28 OF ' ', 'uncorrected error log',        
           'uncorrected error log', REP 14 OF ' ', 'first error/corrected error log',                         
           'first error/corrected error log', 'fp shifter fs', 'fp shifter fs', 'fp shifter fs',              
           'fp shifter fs', 'c board shifters fs', 'fp multiply fs', 'fp divide fs', 'fp divide fs',          
           'immediate data/register file fs', 'integer unit/utp/byte align fs', 'integer unit/byte align fs', 
           'control store addressing fs', 'control store secded fs', 'psr/register file addressing fs',       
           'process state register fs', 'utp register file fs', 'pfs register file/pac fs',                   
           'process state registers fs', 'register file fs', 'address adder/register file fs',                
           'segment map fs', 'bdp fs', 'byte align for load fs', 'memory interface fs', 'memory interface fs',
           'instruction issue', 'instruction issue adder fs', 'cache fs', 'cache fs', REP 17 OF ' ',          
           REP 4 OF 'trap enables', 'trap pointer', 'debug pointer', 'keypoint mask', 'keypoint code',        
           'keypoint class number', 'process interval timer', REP 22 OF ' ', 'critical frame flag',           
           'critical frame flag', 'on condition flag', 'on condition flag', 'debug mask',                     
           'debug mask register', 'user mask register'],                                                      
                                                                                                              
    duv$rd_932_pro_reg_def: [STATIC] dut$rd_93x_pro_reg_def :=                                                
          ['status summary', REP 15 OF ' ', 'element id', ' ', 'options installed',                           
           'virtual machine cap. list', REP 12 OF ' ', 'register file/pfs/retry', 'multiply',                 
           'register file/multiply divide control', 'integer unit/floating point control',                    
           'f.p. adder/divide unit/register file', 'control store addressing/rf',                             
           'floating point and integer shifter', 'register file', 'pac and control store fanout and secded',  
           'immediate/byte shifter/address adder', 'psr/instruction unit', 'bdp postprocess/stream control',  
           'utp/debug/psr', 'memory interface/imm data/address adder', 'segment map file/cache fanout',       
           'cache unit/imm data/address adder', ' ', 'csa addr before halt', REP 14 OF ' ', 'program address',
           'monitor process state ptr', 'monitor condition register', 'user condition register',              
           'untranslatable pointer', 'segment table length', 'segment table address', 'base constant',        
           'page table address', 'page table length', 'page size mask', 'model dependent flags',              
           'model dependent words', REP 19 OF ' ', 'monitor mask register', 'job process state ptr',          
           'system interval timer', 'keypoint buffer pointer', REP 28 OF ' ', 'uncorrected error log',        
           'uncorrected error log', REP 14 OF ' ', 'first error/corrected error log',                         
           'first error/corrected error log', 'register file/multiply divide control',                        
           'integer unit/f.p. control', 'integer unit/f.p. control', 'f.p.adder/divide unit/register file',   
           'floating point adder', 'control store addressing/register file',                                  
           'floating point and integer shifter', 'floating point and integer shifter', 'register file',       
           'pac/control store fanout/secded', 'immediate/byte shifter/address adder',                         
           'byte shifter/address adder', 'psr/instruction unit', 'instruction issue adder',                   
           'bdp postprocess/stream control', 'utp/debug/psr', 'utp/process state register',                   
           'memory interface/imm data/address adder', 'memory interface', 'segment map file/cache fanout',    
           'cache unit/imm data/address adder', 'cache unit', REP 24 OF ' ', REP 4 OF 'trap enables',         
           'trap pointer', 'debug pointer', 'keypoint mask', 'keypoint code', 'keypoint class number',        
           'process interval timer', REP 22 OF ' ', 'critical frame flag', 'critical frame flag',             
           'on condition flag', 'on condition flag', 'debug mask', 'debug mask register',                     
           'user mask register'],                                                                             
                                                                                                              
    duv$rd_general_pro_reg_def: [STATIC] dut$rd_general_pro_reg_def :=                                        
          ['status summary', REP 15 OF ' ', 'element id', 'processor id', 'options installed',                
           'vm capability list', REP 28 OF ' ', 'dependent env ctrl', 'csa addr before halt',                 
           REP 14 OF ' ', 'program addr', 'mtr process state ptr', 'mtr condition reg', 'user condition reg', 
           'untranslatable pointer', 'segment table length', 'segment table addr', 'base constant',           
           'page table address', 'page table length', 'page size mask', REP 6 OF ' ', 'model dependent word', 
           REP 14 OF ' ', 'mtr mask', 'job process state ptr', 'system interval timer',                       
           'keypoint buffer pointer', REP 28 OF ' ',                                                          
           'proc fault status 0', 'proc fault status 1', 'proc fault status 2', 'proc fault status 3',        
           'proc fault status 4', 'proc fault status 5', 'proc fault status 6', 'proc fault status 7',        
           'proc fault status 8', 'proc fault status 9', 'proc fault status A', 'proc fault status B',        
           'proc fault status C', 'proc fault status D', 'proc fault status E', 'proc fault status F',        
           'retry corr error log', 'control store err log', ' ', 'map corr err log', REP 12 OF ' ',           
           'proc test mode', REP 31 OF ' ', 'trap enable', REP 3 OF ' ', 'trap pointer', 'debug list pointer',
           'keypt mask', 'keypt code', 'keypt class number', 'proc interval timer', REP 22 OF ' ',            
           'critical frame flag', ' ', 'on condition flag', ' ', 'debug index', 'debug mask', 'user mask'],   
                                                                                                              
    { PFS register definitions.                                                                               
                                                                                                              
    duv$rd_pro_810_830_pfs_0: [STATIC] dut$rd_pro_810_830_pfs_0 :=                                            
          ['ARVI parity error bits 0 through 7, 32 through 39',                                               
           'ARVI parity error bits 8 through 15, 40 through 47',                                              
           'ARVI parity error bits 16 through 23, 48 through 55',                                             
           'ARVI parity error bits 24 through 31, 56 through 63',                                             
           'uncorrected memory write error', 'memory reject', 'memory tag parity error',                      
           'response code parity error', 'FP exception trap index ROM parity error',                          
           'AD or BD bits 0 through 15 parity error', 'LD box ROM parity error',                              
           'ADS or BDS ROM parity errror', 'shift type ROM parity error or shifter input',                    
           'uncorrected memory read error', 'AD or BD bits 16 through 31 parity error',                       
           'AD-UN parity error ; MAC write parity error', 'memory response time-out',                         
           'CYBER ROM parity error', 'instruction parity error', 'XBD ROM parity error',                      
           'AD or BD bits 32 through 47 parity error', 'BDP adder ,data ROM ,RJB ,RKB parity error',          
           'immediate ROM', 'AD or BD bits 48 through 63 parity error',                                       
           'map parity errror bits 32 through 39', 'map parity errror bits 40 through 47',                    
           'map parity errror bits 48 through 55', 'map parity errror bits 56 through 63',                    
           'map multiple hit fault', 'not used', 'MAC error', 'any CS data parity error'],                    
                                                                                                              
    duv$rd_pro_835_pfs_0: [STATIC] dut$rd_pro_general_pfs :=                                                  
          ['cache input ,bytes 0 and 1 ,address 0', 'cache input ,bytes 2 and 3 ,address 1',                  
           'cache input ,bytes 4 and 5 ,address 2', 'cache input ,bytes 6 and 7 ,address 3',                  
           'cache output ,bytes 0 and 1', 'cache output ,bytes 2 and 3',                                      
           'cache output ,bytes 4 and 5', 'cache output ,bytes 6 and 7',                                      
           'data ,port 0 ,bytes 0 and 1', 'data ,port 0 ,bytes 2 and 3',                                      
           'data ,port 0 ,bytes 4 and 5', 'data ,port 0 ,bytes 6 and 7',                                      
           'data ,port 1 ,bytes 0 and 1', 'data ,port 1 ,bytes 2 and 3',                                      
           'data ,port 1 ,bytes 4 and 5', 'data ,port 1 ,bytes 6 and 7',                                      
           'identifier / response code , port 0', 'identifier / response code , port 1',                      
           'identifier , function , partial-write cache input', 'not used', 'CFR status good',                
           'response code = 1 error', 'response code = 5 error', 'response code = 7 error',                   
           'cache ID and CFR empty', 'CFR multiple hit', 'identifier , cache out', 'cache time-out',          
           'no overflow on simultaneous response buffer', 'function code valid , cache input',                
           'increment ident , cache input', 'MAC ROMS', 'register file , byte 0', 'register file , byte 1',   
           'register file , byte 2', 'register file , byte 3', 'register file , byte 4',                      
           'register file , byte 5', 'register file , byte 6', 'register file , byte 7',                      
           'segment number', 'I MUX ,B MUX address', 'I MUX ,B MUX address', 'I MUX ,B MUX address',          
           'I MUX ,B MUX address', 'ring parity', 'address select ROMs', 'not used',                          
           'invalidation address , exchange address', 'not used', 'BDP J stream parity error',                
           'BDP K stream parity error', 'BDP output parity error', 'BDP control to edit',                     
           'BDP branch or CYBER convert ROM', 'not used', 'floating-point trap ROM',                          
           'exponent address function address decode', 'ROM and partial write', 'not used',                   
           'identifier cache', 'immediate control ROMs', 'not used', 'not used'],                             
                                                                                                              
    duv$rd_pro_845_860_pfs_0: [STATIC] dut$rd_pro_general_pfs :=                                              
          ['R60 after PONR MCR bit 0:uncorrectable parity error',                                             
           'correctable / soft / bypass error , MAC operation PDM',                                           
           'AC address mux to LM parity error , byte 2', 'AC address mux to LM parity error , byte 3',        
           'AC address mux to LM parity error , byte 4', 'AC address mux to LM parity error , byte 5',        
           'AC address mux to LM parity error , byte 6', 'AC address mux to LM parity error , byte 7',        
           'A/C stream data assembly register parity error , byte 0',                                         
           'A/C stream data assembly register parity error , byte 1',                                         
           'A/C stream data assembly register parity error , byte 2',                                         
           'A/C stream data assembly register parity error , byte 3',                                         
           'A/C stream data assembly register parity error , byte 4',                                         
           'A/C stream data assembly register parity error , byte 5',                                         
           'A/C stream data assembly register parity error , byte 6',                                         
           'A/C stream data assembly register parity error , byte 7',                                         
           'A/C stream data buffer register parity error , byte 0',                                           
           'A/C stream data buffer register parity error , byte 1',                                           
           'A/C stream data buffer register parity error , byte 2',                                           
           'A/C stream data buffer register parity error , byte 3',                                           
           'A/C stream data buffer register parity error , byte 4',                                           
           'A/C stream data buffer register parity error , byte 5',                                           
           'A/C stream data buffer register parity error , byte 6',                                           
           'A/C stream data buffer register parity error , byte 7',                                           
           'B stream data buffer register parity error , byte 0',                                             
           'B stream data buffer register parity error , byte 1',                                             
           'B stream data buffer register parity error , byte 2',                                             
           'B stream data buffer register parity error , byte 3',                                             
           'B stream data buffer register parity error , byte 4',                                             
           'B stream data buffer register parity error , byte 5',                                             
           'B stream data buffer register parity error , byte 6',                                             
           'B stream data buffer register parity error , byte 7',                                             
           'A/C stream ASID register parity error , byte 0', 'A/C stream ASID register parity error , byte 1',
           'B stream ASID register parity error , byte 0', 'B stream ASID register parity error , byte 1',    
           'address offset select mux parity error , byte 2',                                                 
           'address offset select mux parity error , byte 3',                                                 
           'AC micrand parity error , byte 0', 'AC micrand parity error , byte 1',                            
           'recovery address register parity error , byte 0',                                                 
           'recovery address register parity error , byte 1',                                                 
           'recovery address register parity error , byte 2',                                                 
           'recovery address register parity error , byte 3',                                                 
           'ALN soft control data-out register parity error',                                                 
           'AC soft control 2 data-out register parity error',                                                
           'AC soft control 1 data-out register parity error',                                                
           'ALN shift count register parity error', 'A/C stream length counter parity error',                 
           'B stream length counter parity error', 'A stream data byte to BDP parity error',                  
           'B stream data byte to BDP parity error',                                                          
           'store bit / all other operation select mux parity error',                                         
           'convert-to-binary dat byte from BDP parity error',                                                
           'B stream stage 1 data register parity error', 'A stream stage 1 data register parity error',      
           'register file A address counter parity error', 'register file B address counter parity error',    
           'register file A data parity error', 'register file B data parity error',                          
           'decimal adder bits 10 through 17,convert_to_decimal P.E',                                         
           'table load limit register stage 3 parity error', 'common stage 7 register parity error',          
           'PFS board 0 internal parity error'],                                                              
                                                                                                              
    duv$rd_pro_990_pfs_0: [STATIC] dut$rd_pro_general_pfs :=                                                  
           ['detected uncorrected error ( DUE)', 'corrected error',                                           
           'IOU data parity error', 'functional unit read data parity error',                                 
           'register 31 parity error , byte 6', 'register 31 parity error , byte 7',                          
           'register 32 parity error , byte 6', 'register 32 parity error , byte 7',                          
           'copy out data parity error , byte 0', 'copy out data parity error , byte 1',                      
           'copy out data parity error , byte 2', 'copy out data parity error , byte 3',                      
           'copy out data parity error , byte 4', 'copy out data parity error , byte 5',                      
           'copy out data parity error , byte 6', 'copy out data parity error , byte 7',                      
           'parity error on out-register to IOU , byte 0', 'parity error on out-register to IOU , byte 1',    
           'parity error on out-register to IOU , byte 2', 'parity error on out-register to IOU , byte 3',    
           'parity error on out-register to IOU , byte 4', 'parity error on out-register to IOU , byte 5',    
           'parity error on out-register to IOU , byte 6', 'parity error on out-register to IOU , byte 7',    
           'copy data-in register parity error , byte 0', 'copy data-in register parity error , byte 1',      
           'copy data-in register parity error , byte 2', 'copy data-in register parity error , byte 3',      
           'copy data-in register parity error , byte 4', 'copy data-in register parity error , byte 5',      
           'copy data-in register parity error , byte 6', 'copy data-in register parity error , byte 7',      
           'assembly register parity error , byte 0', 'assembly register parity error , byte 1',              
           'assembly register parity error , byte 2', 'assembly register parity error , byte 3',              
           'assembly register parity error , byte 4', 'assembly register parity error , byte 5',              
           'assembly register parity error , byte 6', 'assembly register parity error , byte 7',              
           'history file ( X data ) parity error , byte 0', 'history file ( X data ) parity error , byte 1',  
           'history file ( X data ) parity error , byte 2', 'history file ( X data ) parity error , byte 3',  
           'history file ( X data ) parity error , byte 4', 'history file ( X data ) parity error , byte 5',  
           'history file ( X data ) parity error , byte 6', 'history file ( X data ) parity error , byte 7',  
           'history file ( A data ) parity error , byte 8', 'history file ( A data ) parity error , byte 9',  
           'history file ( A data ) parity error , byte 10', 'history file ( A data ) parity error , byte 11',
           'history file ( A data ) parity error , byte 12', 'history file ( A data ) parity error , byte 13',
           'history file ( P-right ) parity error , byte 14',                                                 
           'history file ( P-right ) parity error , byte 15',                                                 
           'history file ( P-right ) parity error , byte 16',                                                 
           'history file ( P-right ) parity error , byte 17',                                                 
           'IN2 error tag parity error', 'PSR error tag parity error',                                        
           'ACU error tag parity error', 'soft control memory parity error , byte 0',                         
           'soft control memory parity error , byte 1', 'soft control memory parity error , byte 2'],         
                                                                                                              
    duv$rd_pro_810_830_pfs_1: [STATIC] dut$rd_pro_810_830_pfs_1 :=                                            
          ['double error', 'chip select', REP 6 OF '  set / synd-dr1',                                        
           'double error', 'chip select', REP 6 OF '  set / synd-dr2',                                        
           'double error', 'chip select', REP 6 OF '  set / synd-dr3',                                        
           'double error', 'chip select', REP 6 OF '  set / synd-dr4',                                        
           'double error', 'chip select', REP 6 OF '  set / synd-dr5'],                                       
                                                                                                              
    duv$rd_pro_835_pfs_1: [STATIC] dut$rd_pro_general_pfs :=                                                  
          ['control store parity error , byte 0', REP 7 OF 'not used',                                        
           'control store parity error , byte 1', REP 7 OF 'not used',                                        
           'control store parity error , byte 2', REP 7 OF 'not used',                                        
           'control store parity error , byte 3', REP 7 OF 'not used',                                        
           'control store parity error , byte 4', REP 7 OF 'not used',                                        
           'control store parity error , byte 5', REP 7 OF 'not used',                                        
           'control store parity error , byte 6', REP 7 OF 'not used',                                        
           'control store parity error , byte 7', REP 7 OF 'not used'],                                       
                                                                                                              
    duv$rd_pro_845_860_pfs_1: [STATIC] dut$rd_pro_845_860_pfs :=                                              
          ['buffer RAM address counter parity error', 'C stream stage 2 data register parity error',          
           'specification error RAM , x256 RAM address parity error',                                         
           'specification error RAM , x256 RAM out data parity error',                                        
           'A stream stage 2 data register parity error', 'B stream stage 2 data register parity error',      
           'Aj descriptor parity error', 'Ak descriptor parity error', 'translate RAM address parity error',  
           'translate RAM output data parity error', 'convert-to-binary / decimal RAM address parity error',  
           'convert-to-binary / decimal RAM output data parity error',                                        
           'BDP micrand byte 0 or 1 parity error', 'BDP micrand byte 2 or 3 parity error',                    
           'BDP micrand byte 4 or 5 parity error', 'BDP micrand byte 6 or 7 parity error'],                   
                                                                                                              
    duv$rd_pro_990_pfs_1: [STATIC] dut$rd_pro_general_pfs :=                                                  
          ['MAC write assembly register parity error , byte 0',                                               
           'MAC write assembly register parity error , byte 1',                                               
           'MAC write assembly register parity error , byte 2',                                               
           'MAC write assembly register parity error , byte 3',                                               
           'MAC write assembly register parity error , byte 4',                                               
           'MAC write assembly register parity error , byte 5',                                               
           'MAC write assembly register parity error , byte 6',                                               
           'MAC write assembly register parity error , byte 7',                                               
           'MAC write assembly register parity error , byte 8',                                               
           'MAC write assembly register parity error , byte 9',                                               
           'MAC write assembly register parity error , byte 10',                                              
           'MAC write assembly register parity error , byte 11',                                              
           'MAC write assembly register parity error , byte 12',                                              
           'MAC write assembly register parity error , byte 13',                                              
           'MAC write assembly register parity error , byte 14',                                              
           'MAC write assembly register parity error , byte 15',                                              
           'CS data parity error , byte 8 or SM  auxiliary board H',                                          
           'CS data parity error , byte 9 or SM  auxiliary board G',                                          
           'CS data parity error , byte 10 or SM  auxiliary board F',                                         
           'CS data parity error , byte 11 or SM  auxiliary board E',                                         
           'CS data parity error , byte 12 or SM  auxiliary board D',                                         
           'CS data parity error , byte 13 or SM  auxiliary board C',                                         
           'CS data parity error , byte 14 or SM  auxiliary board B',                                         
           'CS data parity error , byte 15 or SM  auxiliary board A',                                         
           'CS data parity error , byte 0 or 16 , auxiliary board H',                                         
           'CS data parity error , byte 1 or 17 , auxiliary board G',                                         
           'CS data parity error , byte 2 or 18 , auxiliary board F',                                         
           'CS data parity error , byte 3 or 19 , auxiliary board E',                                         
           'CS data parity error , byte 4 or 20 , auxiliary board D',                                         
           'CS data parity error , byte 5 or 21 , auxiliary board C',                                         
           'CS data parity error , byte 6 or 22 , auxiliary board B',                                         
           'CS data parity error , byte 7 or 23 , auxiliary board A',                                         
           'control word parity error, byte 0',  'control word parity error, byte 3',                         
           'control word parity error, byte 6',  'control word parity error, byte 9',                         
           'control word parity error, byte 12', 'control word parity error, byte 15',                        
           'control word parity error, byte 18', 'control word parity error, byte 21',                        
           'control word parity error, byte 1',  'control word parity error, byte 4',                         
           'control word parity error, byte 7',  'control word parity error, byte 10',                        
           'control word parity error, byte 13', 'control word parity error, byte 16',                        
           'control word parity error, byte 19', 'control word parity error, byte 22',                        
           'control word parity error, byte 2',  'control word parity error, byte 5',                         
           'control word parity error, byte 8',  'control word parity error, byte 11',                        
           'control word parity error, byte 14', 'control word parity error, byte 17',                        
           'control word parity error, byte 20', 'control word parity error, byte 23',                        
           'CWD rank BDP descritor parity error , byte 0', 'CWD rank BDP descritor parity error , byte 1',    
           'CWD rank BDP descritor parity error , byte 2', 'CWD rank BDP descritor parity error , byte 3',    
           'CIR rank BDP descritor parity error , byte 0', 'CIR rank BDP descritor parity error , byte 1',    
           'CIR rank BDP descritor parity error , byte 2', 'CIR rank BDP descritor parity error , byte 3'],   
                                                                                                              
    duv$rd_pro_845_860_pfs_2: [STATIC] dut$rd_pro_general_pfs :=                                              
          ['immediate data byte in scale counter parity error', 'edit mask byte parity error',                
           'cache address register parity error , byte 0', 'cache address register parity error , byte 1',    
           'cache address register parity error , byte 2', 'cache address register parity error , byte 3',    
           'cache address register parity error , byte 4', 'cache address register parity error , byte 5',    
           'cache write-data parity error , byte 0', 'cache write-data parity error , byte 1',                
           'cache write-data parity error , byte 2', 'cache write-data parity error , byte 3',                
           'cache write-data parity error , byte 4', 'cache write-data parity error , byte 5',                
           'cache write-data parity error , byte 6', 'cache write-data parity error , byte 7',                
           'multiple cache hit', 'multiple cache allocate error',                                             
           'cache tag file parity error', 'cache tag file address parity error',                              
           'DAI parity error : LM read data mux , direct CMC data 3',                                         
           'DAI parity error : LM read data mux , cache read data 2',                                         
           'DAI parity error : LM read data mux , real memory address 1',                                     
           'DAI parity error : LM read data mux , buffer CMC data 0',                                         
           'cache write data from CPU parity error', 'cache block fill data from CM port parity error',       
           'cache address register P. E. 4 : cache associative tag', 'cache mark data parity error',          
           'cache address register P. E. : address mux 0 : invalidate',                                       
           'cache address register P. E. : address mux 1 : AC address',                                       
           'cache address register P. E. : address mux 2 : IF address',                                       
           'cache address register P. E. : address mux 3 : interrupt',                                        
           'modified purge code (from SM) parity error', 'LM micrand parity error , byte 0',                  
           'LM micrand parity error , byte 1', 'not used',                                                    
           'page map status parity error , set 0', 'page map status parity error , set 1',                    
           'page map status parity error , set 2', 'page map status parity error , set 3',                    
           'page map parity error , set 0', 'page map parity error , set 1',                                  
           'page map parity error , set 2', 'page map parity error , set 3',                                  
           'page frame address parity error', REP 3 OF 'not used', 'page table length register parity error', 
           'page table address register parity error', 'page offset register parity error',                   
           'page size mask parity error', 'stream mode exchange word tag parity error', REP 3 OF 'not used',  
           'CMC response 2 : corrected error write', 'CMC response 6 : corrected error read',                 
           'CMC response 1 : uncorrectable error write', 'CMC response 5 : uncorrectable error read',         
           'CMC response 7 : reject', 'CMC response 7 : parity error', 'CMC tag register parity error',       
           'PFS board 1 internal parity error'],                                                              
                                                                                                              
    duv$rd_pro_990_pfs_2: [STATIC] dut$rd_pro_general_pfs :=                                                  
          ['CSA rank P register parity error , byte 0', 'CSA rank P register parity error , byte 1',          
           'CSA rank P register parity error , byte 2', 'CSA rank P register parity error , byte 3',          
           'CSD rank P register parity error , byte 0', 'CSD rank P register parity error , byte 1',          
           'CSD rank P register parity error , byte 2', 'CSD rank P register parity error , byte 3',          
           'CWD rank P register parity error , byte 0', 'CWD rank P register parity error , byte 1',          
           'CWD rank P register parity error , byte 2', 'CWD rank P register parity error , byte 3',          
           'CIR rank P register parity error , byte 0', 'CIR rank P register parity error , byte 1',          
           'CIR rank P register parity error , byte 2', 'CIR rank P register parity error , byte 3',          
           'CSA rank UTP address register parity error , byte 0',                                             
           'CSA rank UTP address register parity error , byte 1',                                             
           'CSA rank UTP address register parity error , byte 2',                                             
           'CSA rank UTP address register parity error , byte 3',                                             
           'CWA rank UTP address register parity error , byte 0',                                             
           'CWA rank UTP address register parity error , byte 1',                                             
           'CWA rank UTP address register parity error , byte 2',                                             
           'CWA rank UTP address register parity error , byte 3',                                             
           'CIR rank UTP address register parity error , byte 0',                                             
           'CIR rank UTP address register parity error , byte 1',                                             
           'CIR rank UTP address register parity error , byte 2',                                             
           'CIR rank UTP address register parity error , byte 3',                                             
           'CSA instruction register parity error , byte 0', 'CSA instruction register parity error , byte 1',
           'CSA instruction register parity error , byte 2', 'CSA instruction register parity error , byte 3',
           'CSD instruction register parity error , byte 0', 'CSD instruction register parity error , byte 1',
           'CSD instruction register parity error , byte 2', 'CSD instruction register parity error , byte 3',
           'CWA instruction register parity error , byte 0', 'CWA instruction register parity error , byte 1',
           'CWA instruction register parity error , byte 2', 'CWA instruction register parity error , byte 3',
           'CSA rank J descriptor parity error , byte 0', 'CSA rank J descriptor parity error , byte 1',      
           'CSA rank J descriptor parity error , byte 2', 'CSA rank J descriptor parity error , byte 3',      
           'CSD rank J descriptor parity error , byte 0', 'CSD rank J descriptor parity error , byte 1',      
           'CSD rank J descriptor parity error , byte 2', 'CSD rank J descriptor parity error , byte 3',      
           'CWA rank J descriptor parity error , byte 0', 'CWA rank J descriptor parity error , byte 1',      
           'CWA rank J descriptor parity error , byte 2', 'CWA rank J descriptor parity error , byte 3',      
           'CSA rank K descriptor parity error , byte 0', 'CSA rank K descriptor parity error , byte 1',      
           'CSA rank K descriptor parity error , byte 2', 'CSA rank K descriptor parity error , byte 3',      
           'CSD rank K descriptor parity error , byte 0', 'CSD rank K descriptor parity error , byte 1',      
           'CSD rank K descriptor parity error , byte 2', 'CSD rank K descriptor parity error , byte 3',      
           'CWA rank K descriptor parity error , byte 0', 'CWA rank K descriptor parity error , byte 1',      
           'CWA rank K descriptor parity error , byte 2', 'CWA rank K descriptor parity error , byte 3'],     
                                                                                                              
    duv$rd_pro_845_860_pfs_3: [STATIC] dut$rd_pro_845_860_pfs :=                                              
          ['cache address parity error , set 0', 'cache address parity error , set 1',                        
           'cache address parity error , set 2', 'cache address parity error , set 3',                        
           'cache tag RAM parity error , set 0', 'cache tag RAM parity error , set 1',                        
           'cache tag RAM parity error , set 2', 'cache tag RAM parity error , set 3',                        
           'DAI parity error , cache data , set 0', 'DAI parity error , cache data , set 1',                  
           'DAI parity error , cache data , set 2', 'DAI parity error , cache data , set 3',                  
           'DAI parity error : DAI mux , local memory read data 3',                                           
           'DAI parity error : DAI mux , byte load data 2', 'DAI parity error : DAI mux , ALN result data 1', 
           'DAI parity error : DAI mux , functional unit micrand 0'],                                         
                                                                                                              
    duv$rd_pro_990_pfs_3: [STATIC] dut$rd_pro_general_pfs :=                                                  
          [REP 3 OF 'not used', 'illlegal soft control address auxiliary 1',                                  
           'illegal soft control address auxiliary 2', 'LSU mark lines parity error',                         
           'immediate data , scale count parity error', 'mark lines parity error',                            
           'AJ data parity error , byte 0', 'AJ data parity error , byte 1',                                  
           'AJ data parity error , byte 2', 'AJ data parity error , byte 3',                                  
           'AJ data parity error , byte 4', 'AJ data parity error , byte 5',                                  
           'AJ data parity error , byte 6', 'AJ data parity error , byte 7',                                  
           'AJ data hold register parity error , byte 0', 'AJ data hold register parity error , byte 1',      
           'AJ data hold register parity error , byte 2', 'AJ data hold register parity error , byte 3',      
           'AJ data hold register parity error , byte 4', 'AJ data hold register parity error , byte 5',      
           'AJ data hold register parity error , byte 6', 'AJ data hold register parity error , byte 7',      
           'AK data parity error , byte 0', 'AK data parity error , byte 1',                                  
           'AK data parity error , byte 2', 'AK data parity error , byte 3',                                  
           'AK data parity error , byte 4', 'AK data parity error , byte 5',                                  
           'AK data parity error , byte 6', 'AK data parity error , byte 7',                                  
           'AK data hold register parity error , byte 0', 'AK data hold register parity error , byte 1',      
           'AK data hold register parity error , byte 2', 'AK data hold register parity error , byte 3',      
           'AK data hold register parity error , byte 4', 'AK data hold register parity error , byte 5',      
           'AK data hold register parity error , byte 6', 'AK data hold register parity error , byte 7',      
           'AJ descriptor', 'AK descriptor', 'J length counter subtrahend', 'K length counter subtrahend',    
           'J length count', 'J length count after subtract', 'K length count',                               
           'K length count after subtract',                                                                   
           'output data parity error , byte 0', 'output data parity error , byte 1',                          
           'output data parity error , byte 2', 'output data parity error , byte 3',                          
           'output data parity error , byte 4', 'output data parity error , byte 5',                          
           'output data parity error , byte 6', 'output data parity error , byte 7',                          
           'soft control memory parity error , board 1', 'soft control memory parity error , board 2',        
           'convert data hold register parity error', 'convert data register parity error',                   
           'IOU micrand register parity error', 'IOU micrand register parity error , byte 1',                 
           'soft control address parity error , board 1', 'soft control address parity error , board 2'],     
                                                                                                              
    duv$rd_pro_845_860_pfs_4: [STATIC] dut$rd_pro_general_pfs :=                                              
          ['segment descriptor mux-out parity error , set 0',                                                 
           'segment descriptor mux-out parity error , set 1',                                                 
           'segment descriptor mux parity error , byte 0', 'segment descriptor mux parity error , byte 1',    
           'segment descriptor mux parity error , byte 2', 'segment descriptor mux parity error , byte 3',    
           'segment descriptor mux parity error , byte 4', 'segment descriptor mux parity error , byte 5',    
           'segment table length parity error , byte 0', 'segment table length parity error , byte 1',        
           'segment table address register P. E. , bytes 0 and 3',                                            
           'segment table address register P. E. , bytes 1 and 2',                                            
           'new P register parity error , byte 0', 'new P register parity error , byte 1',                    
           'new P register parity error , byte 2', 'new P register parity error , byte 3',                    
           'PVA register bits 4 through 7 (CBP VMID) parity error',                                           
           'PVA register bits 12 through 15 (CBP R3) parity error',                                           
           'PVA register parity error , byte 2', 'PVA register parity error , byte 3',                        
           'segment descriptor mux-out P. E. : neither set select',                                           
           'valid status RAM error : parity error or double hit',                                             
           'SM micrand parity error , byte 0', 'SM micrand parity error , byte 1', 'purge code parity error', 
           'rank 32 BDP descriptor data type register parity error', 'rank 32 j,k register parity error',     
           'rank 50 UTP register parity error , byte 2', 'rank 50 UTP register parity error , byte 4',        
           'rank 50 UTP register parity error , byte 5', 'rank 50 UTP register parity error , byte 6',        
           'rank 50 UTP register parity error , byte 7',                                                      
           'live register write-data parity error , byte 0',                                                  
           'live register write-data parity error , byte 1',                                                  
           'rank 41 general micrand parity error 2 , byte 3',                                                 
           'rank 41 general micrand parity error 1 , byte 2',                                                 
           'rank 50 P register parity error , byte 4', 'rank 50 P register parity error , byte 5',            
           'rank 50 P register parity error , byte 6', 'rank 50 P register parity error , byte 7',            
           'rank 41 general micrand parity error 3 , byte 4', 'successful retry', 'deadman time-out',         
           'debug mask parity error', 'MAC operation PDM', 'retry counter register parity error',             
           'PDM during exchange (exchange mode set)', 'rank 50 before PONR PDM',                              
           'DAI P. E. 1 : register file write data P. E. , byte 0',                                           
           'DAI P. E. 2 : register file write data P. E. , byte 1',                                           
           'DAI P. E. 3 : register file write data P. E. , byte 2',                                           
           'DAI P. E. 4 : register file write data P. E. , byte 3',                                           
           'DAI P. E. 5 : register file write data P. E. , byte 4',                                           
           'DAI P. E. 6 : register file write data P. E. , byte 5',                                           
           'DAI P. E. 7 : register file write data P. E. , byte 6',                                           
           'DAI P. E. 8 : register file write data P. E. , byte 7',                                           
           'minipipe rank 50 register file write address P. E.',                                              
           'register file read data P. E. , bytes 0 through 3',                                               
           'register file read data P. E. , bytes 4 through 7',                                               
           'CMC tag ( from LM ) parity  error', REP 3 OF 'not used', 'PFS board 2 internal parity error'],    
                                                                                                              
    duv$rd_pro_990_pfs_4: [STATIC] dut$rd_pro_general_pfs :=                                                  
          ['IMU / FPM compare fault', 'divide miscompare', 'BDP byte parity error',                           
           REP 31 OF 'not used', 'rank 6 error', 'invalid SCM 4', 'port A tag',                               
           'SCM4 function code', 'page map multiple hit', 'SCM4 parity error',                                
           'port A RMA register parity error , byte 0', 'port A RMA register parity error , byte 1',          
           'port A RMA register parity error , byte 2', 'port A RMA register parity error , byte 3',          
           'port B RMA register parity error , byte 0', 'port B RMA register parity error , byte 1',          
           'port B RMA register parity error , byte 2', 'port B RMA register parity error , byte 3',          
           'port C RMA register parity error , byte 0', 'port C RMA register parity error , byte 1',          
           'port C RMA register parity error , byte 2', 'port C RMA register parity error , byte 3',          
           'port C SVA register parity error , byte 0', 'port C SVA register parity error , byte 1',          
           'port C SVA register parity error , byte 2', 'port C SVA register parity error , byte 3',          
           'port A length counter parity error , byte 0', 'port A length counter parity error , byte 1',      
           'port C length counter parity error , byte 2', 'port C length counter parity error , byte 3',      
           'port C store tag parity error', 'rank 6 PFSA register parity error , byte 0',                     
           'rank 6 PFSA register parity error , byte 1', 'rank 6 PFSA register parity error , byte 2'],       
                                                                                                              
    duv$rd_pro_845_860_pfs_5: [STATIC] dut$rd_pro_845_860_pfs :=                                              
          ['rank 22 P register parity error , byte 4', 'rank 22 P register parity error , byte 5',            
           'rank 22 P register parity error , byte 6', 'rank 22 P register parity error , byte 7',            
           'R22 BDP descriptor data type field parity error', 'rank 22 j,k field parity error',               
           'rank 22 immediate operand parity error , byte 0',                                                 
           'rank 22 immediate operand parity error , byte 1',                                                 
           'functional unit micrand parity error , byte 6', 'functional unit micrand parity error , byte 7',  
           'register data select write field parity error , byte 0',                                          
           'register data select write field parity error , byte 1',                                          
           'increment j,k field parity error', 'not used', 'microsecond counter parity error', 'not used'],   
                                                                                                              
    duv$rd_pro_990_pfs_5: [STATIC] dut$rd_pro_general_pfs :=                                                  
          ['page table address , byte 0', 'page table address , byte 1',                                      
           'rank 4/5 SVA parity error , byte 0', 'rank 4/5 SVA parity error , byte 1',                        
           'rank 4/5 SVA parity error , byte 2', 'rank 4/5 SVA parity error , byte 3',                        
           'rank 4/5 SVA parity error , byte 4', 'rank 4/5 SVA parity error , byte 5',                        
           'page table length parity error',   'rank 6 SVA parity error , byte 0',                            
           'rank 6 SVA parity error , byte 1', 'rank 6 SVA parity error , byte 2',                            
           'rank 6 SVA parity error , byte 3', 'rank 6 SVA parity error , byte 4',                            
           'rank 6 SVA parity error , byte 5', 'rank 6 SVA parity error , byte 6',                            
           'rank 5 ring/segment parity error , byte 0', 'rank 5 ring/segment parity error , byte 1',          
           'cache purge SVA parity error , byte 0', 'cache purge SVA parity error , byte 1',                  
           'cache purge SVA parity error , byte 2', 'cache purge SVA parity error , byte 3',                  
           'cache purge SVA parity error , byte 4', 'cache purge SVA parity error , byte 5',                  
           'rank 6 ring/segment parity error , byte 0', 'rank 6 ring/segment parity error , byte 1',          
           'rank 6 LSU tag parity error , byte 0', 'rank 6 LSU tag parity error , byte 1',                    
           'rank 6 LSU tag parity error , byte 2', 'rank 6 LSU tag parity error , byte 3',                    
           'rank 6 LSU tag parity error , byte 4', 'rank 6 LSU tag parity error , byte 5',                    
           'SDE / PTE parity error , byte 0', 'SDE / PTE parity error , byte 1',                              
           'SDE / PTE parity error , byte 2', 'SDE / PTE parity error , byte 3',                              
           'SDE / PTE parity error , byte 4', 'SDE / PTE parity error , byte 5',                              
           'SDE / PTE parity error , byte 6', 'SDE / PTE parity error , byte 7',                              
           'alternate PTE parity error , byte 0', 'alternate PTE parity error , byte 1',                      
           'alternate PTE parity error , byte 2', 'segment / page identifier parity error , byte 0',          
           'segment / page identifier parity error , byte 1',                                                 
           'segment / page identifier parity error , byte 2',                                                 
           'segment / page identifier parity error , byte 3',                                                 
           'segment / page identifier parity error , byte 4',                                                 
           'debug mask parity error', 'page size mask parity error',                                          
           'data result parity error , byte 0', 'data result parity error , byte 1',                          
           'data result parity error , byte 2', 'data result parity error , byte 3',                          
           'data result parity error , byte 4', 'data result parity error , byte 5',                          
           'miss tag parity error , byte 0', 'miss tag parity error , byte 1',                                
           'miss tag parity error , byte 2', 'miss tag parity error , byte 3',                                
           'page map parity error , set 0', 'page map parity error , set 1',                                  
           'page map parity error , set 2', 'page map parity error , set 3'],                                 
                                                                                                              
    duv$rd_pro_845_860_pfs_6: [STATIC] dut$rd_pro_general_pfs :=                                              
          [REP 3 OF 'not used', 'micrand address register parity error',                                      
           'CST write data (from MAC ) parity error , byte 0',                                                
           'CST write data (from MAC ) parity error , byte 1',                                                
           'MCS field register parity error , byte 0', 'MCS field register parity error , byte 1',            
           'FU micrand buffer register (t23) parity error , byte 0',                                          
           'FU micrand buffer register (t23) parity error , byte 1',                                          
           'FU micrand buffer register (t23) parity error , byte 2',                                          
           'FU micrand buffer register (t23) parity error , byte 3',                                          
           'FU micrand buffer register (t23) parity error , byte 4',                                          
           'FU micrand buffer register (t23) parity error , byte 5',                                          
           'FU micrand buffer register (t23) parity error , byte 6',                                          
           'FU micrand buffer register (t23) parity error , byte 7',                                          
           'FU micrand register (t31) parity error , byte 0',                                                 
           'FU micrand register (t31) parity error , byte 1',                                                 
           'FU micrand register (t31) parity error , byte 2',                                                 
           'FU micrand register (t31) parity error , byte 3',                                                 
           'FU micrand register (t31) parity error , byte 4',                                                 
           'FU micrand register (t31) parity error , byte 5',                                                 
           'FU micrand register (t31) parity error , byte 6',                                                 
           'FU micrand register (t31) parity error , byte 7',                                                 
           'general micrand register (t22) parity error , byte 2',                                            
           'general micrand register (t22) parity error , byte 3',                                            
           'general micrand register (t22) parity error , byte 4',                                            
           'general micrand register (t22) parity error , byte 5',                                            
           'general micrand register (t22) parity error , byte 6',                                            
           'general micrand register (t22) parity error , byte 7',                                            
           'A-start , X-start counter register parity error',                                                 
           'A-terminate,X-terminate counter register parity error',                                           
           'maintenance channel out register (to IOU) parity error',                                          
           'maintenance channel input:write data/function word P.E.',                                         
           'maintenance channel input data fanout parity error',                                              
           'read data (to maintenance channel out register)mux P.E.',                                         
           'reference ROM address parity error', 'address translation mux parity error',                      
           'reference ROM data parity error ', 'N counter register parity error',                             
           'first level instruction C170 odd RAM A parity error',                                             
           'first level instruction C170 even RAM A parity error',                                            
           'first level instruction C180 RAM A parity error',                                                 
           'IB12 P register , byte 4', 'IB12 P register , byte 5',                                            
           'rank 12 instruction buffer opcode', 'IB12 instruction mux bits 3 , 12 through 15 , 24',           
           'IB12 instruction mux bits 16 through 23',                                                         
           'first level instruction C170 odd RAM B parity error',                                             
           'first level instruction C170 even RAM B parity error',                                            
           'first level instruction C180 RAM B parity error',                                                 
           'IB12 P register , byte 6', 'IB12 P register , byte 7',                                            
           'IB12 P instruction mux bits 33 through 40',                                                       
           'IB12 P instruction mux bits 25 through 32', 'not used',                                           
           'branch address A register parity error , byte 0',                                                 
           'branch address A register parity error , byte 1',                                                 
           'branch address A register parity error , byte 2',                                                 
           'branch address A register parity error , byte 3',                                                 
           'branch address B register parity error , byte 1',                                                 
           'branch address B register parity error , byte 2',                                                 
           'branch address B register parity error , byte 3',                                                 
           'PFS board 3 internal parity error'],                                                              
                                                                                                              
    duv$rd_pro_990_pfs_6: [STATIC] dut$rd_pro_general_pfs :=                                                  
          ['micrand parity error , byte 0', 'micrand parity error , byte 1',                                  
           'micrand parity error , byte 2', 'micrand parity error , byte 3',                                  
           'immediate byte , scale count parity error', 'buffer address parity error',                        
           'register file A address parity error', 'register file B address parity error',                    
           'register file A data out parity error', 'edit mask parity error',                                 
           'decimal convert parity error', 'C stream adder parity error',                                     
           'AJ descriptor parity error', 'AK descriptor parity error',                                        
           'A port stage-2 data parity error', 'B port stage-2 data parity error',                            
           'C stream stage-7 data parity error', 'table load limit register parity error',                    
           'register file B data-out parity error', 'C stream stage-4 address (convert) parity error',        
           'C stream stage-4 address ( EBCDIC ) parity error',                                                
           'ROM address (specification error,X256) parity error',                                             
           'ROM address (specification error,X256) parity error',                                             
           'A port stage-1 data parity error', 'C stream stage-5 data parity error ( EBCDIC )',               
           'convert data-out parity error', 'B port stage-1 data parity error',                               
           'write address parity error', 'MAC write data parity error', 'error on SCM 2', 'error on SCM 3',   
           'error on MEM-990 rank 4', 'error on transfer count from IDU',                                     
           'instruction descriptor parity error , byte 0',                                                    
           'instruction descriptor parity error , byte 1', 'instruction descriptor parity error , byte 2',    
           'BDP descriptor parity error , byte 0', 'BDP descriptor parity error , byte 1',                    
           'BDP descriptor parity error , byte 2', 'BDP descriptor parity error , byte 3',                    
           'M1 micrand register parity error , byte 0', 'M1 micrand register parity error , byte 1',          
           'M1 micrand register parity error , byte 2', 'M1 micrand register parity error , byte 3',          
           'parity error on P-right from IN1 , byte 0', 'parity error on P-right from IN1 , byte 1',          
           'parity error on P-right from IN1 , byte 2', 'parity error on P-right from IN1 , byte 3',          
           'SVA BN register parity error , byte 0', 'SVA BN register parity error , byte 1',                  
           'SVA BN register parity error , byte 2', 'SVA BN register parity error , byte 3',                  
           'SVA BN buffer register parity error , byte 0', 'SVA BN buffer register parity error , byte 1',    
           'SVA BN buffer register parity error , byte 2', 'SVA BN buffer register parity error , byte 3',    
           'increment adder operand A parity error , byte 0',                                                 
           'increment adder operand A parity error , byte 1',                                                 
           'increment adder operand A parity error , byte 2',                                                 
           'increment adder operand A parity error , byte 3',                                                 
           'increment adder operand B parity error , byte 0',                                                 
           'increment adder operand B parity error , byte 1',                                                 
           'increment adder operand B parity error , byte 2',                                                 
           'increment adder operand B parity error , byte 3'],                                                
                                                                                                              
    duv$rd_pro_845_860_pfs_7: [STATIC] dut$rd_pro_845_860_pfs :=                                              
          ['branch address adder input parity error , byte 0',                                                
           'branch address adder input parity error , byte 1',                                                
           'branch address adder input parity error , byte 2',                                                
           'branch address adder input parity error , byte 3',                                                
           'branch address register parity error , byte 0', 'branch address register parity error , byte 1',  
           'branch address register parity error , byte 2', 'branch address register parity error , byte 3',  
           'IB02 P.E.,byte 0;instruction mux bits 3,12 throuh 15,24',                                         
           'IB02 P. E. , byte 1 ; instruction mux bits 16 throuh 23',                                         
           'IB02 P. E. , byte 2 ; instruction mux bits 25 throuh 32',                                         
           'IB02 P. E. , byte 3 ; instruction mux bits 33 throuh 40',                                         
           'IB11 P.E.,byte 0;instruction mux bits 3,12 throuh 15,24',                                         
           'IB11 P. E. , byte 1 ; instruction mux bits 16 throuh 23',                                         
           'IB11 P. E. , byte 2 ; instruction mux bits 25 throuh 32',                                         
           'IB11 P. E. , byte 3 ; instruction mux bits 33 throuh 40'],                                        
                                                                                                              
    duv$rd_pro_990_pfs_7: [STATIC] dut$rd_pro_general_pfs :=                                                  
          ['data error on SDE RMA adder , byte 0', 'data error on SDE RMA adder , byte 1',                    
           'data error on SDE RMA adder , byte 2', 'data error on SDE RMA adder , byte 3',                    
           'carry error on SDE RMA adder , byte 0', 'carry error on SDE RMA adder , byte 1',                  
           'carry error on SDE RMA adder , byte 2', 'length mux/register parity error',                       
           'rank 4 SDE register copy 1 parity error , byte 0',                                                
           'rank 4 SDE register copy 1 parity error , byte 1',                                                
           'rank 4 SDE register copy 1 parity error , byte 2',                                                
           'instruction descriptor P. E. ,bits 16 through 23 copy 2',                                         
           'segment table length parity error , byte 0', 'segment table length parity error , byte 1',        
           'rank 3 function code parity error', 'rank 4 function code parity error',                          
           'rank 3 LSU micrand parity error', 'rank 5 LSU tag parity error , byte 0',                         
           'rank 5 LSU tag parity error , byte 1', 'rank 5 LSU tag parity error , byte 2',                    
           'rank 4 LSU tag parity error ', 'rank 5 LSU tag parity error , byte 0',                            
           'rank 5 LSU tag parity error , byte 1', 'rank 5 LSU tag parity error , byte 2',                    
           'invalid function code , MEM-835 , 990', 'invalid function code , MEM-845 through 860',            
           'rank 3 RN/SEG register parity error , byte 0', 'rank 3 RN/SEG register parity error , byte 1',    
           'rank 4 RN/SEG register parity error , byte 0', 'rank 4 RN/SEG register parity error , byte 1',    
           'rank 3 RN/SEG buffer parity error , byte 0', 'rank 3 RN/SEG buffer parity error , byte 1',        
           'RN/seg holding register parity error , byte 0', 'RN/seg holding register parity error , byte 1',  
           'vector length register parity error , byte 0', 'vector length register parity error , byte 1',    
           'P-left register parity error , byte 0', 'P-left register parity error , byte 1',                  
           'P-left register parity error , byte 2', 'P-left register parity error , byte 3',                  
           'new P-segment holding register parity error , byte 0',                                            
           'new P-segment holding register parity error , byte 1',                                            
           'new P-ring holding register parity error', 'B counter register parity error',                     
           'ASID holding register parity error , byte 0', 'ASID holding register parity error , byte 1',      
           'rank 4 ASID register parity error , byte 0', 'rank 4 ASID register parity error , byte 1',        
           'global key parity error', 'RAC + FLC register parity error , byte 0',                             
           'RAC + FLC register parity error , byte 1', 'RAC + FLC register parity error , byte 2',            
           'local key parity error', 'RAE + FLE register parity error , byte 0',                              
           'RAE + FLE register parity error , byte 1', 'RAE + FLE register parity error , byte 2',            
           'segment map error , set 0', 'segment map error , set 1',                                          
           'segment map error , multiple hit', REP 5 OF 'not used'],                                          
                                                                                                              
    duv$rd_pro_845_860_pfs_8: [STATIC] dut$rd_pro_general_pfs :=                                              
          ['instruction assembly register parity error , byte 0',                                             
           'instruction assembly register parity error , byte 1',                                             
           'instruction assembly register parity error , byte 2',                                             
           'instruction assembly register parity error , byte 3',                                             
           'instruction assembly register parity error , byte 4',                                             
           'instruction assembly register parity error , byte 5',                                             
           'instruction assembly register parity error , byte 6',                                             
           'instruction assembly register parity error , byte 7',                                             
           'parcel 3 save register parity error , byte 0', 'parcel 3 save register parity error , byte 1',    
           'parity error mux parity error , byte 0', 'parity error mux parity error , byte 1',                
           'parity error mux parity error , byte 2', 'parity error mux parity error , byte 3',                
           'multiply/divide minor cycle control register P.E byte 0',                                         
           'multiply/divide minor cycle control register P.E byte 1',                                         
           'C register data parity error , byte 0', 'C register data parity error , byte 1',                  
           'C register data parity error , byte 2', 'C register data parity error , byte 3',                  
           'C register data parity error , byte 4', 'C register data parity error , byte 5',                  
           'C register data parity error , byte 6', 'C register data parity error , byte 7',                  
           'B register data parity error , byte 0', 'B register data parity error , byte 1',                  
           'B register data parity error , byte 2', 'B register data parity error , byte 3',                  
           'B register data parity error , byte 4', 'B register data parity error , byte 5',                  
           'B register data parity error , byte 6', 'B register data parity error , byte 7',                  
           'large adder input parity error , byte 0',  'large adder input parity error , byte 1',             
           'large adder input parity error , byte 2',  'large adder input parity error , byte 3',             
           'large adder input parity error , byte 4',  'large adder input parity error , byte 5',             
           'large adder input parity error , byte 6',  'large adder input parity error , byte 7',             
           'large adder input parity error , byte 8',  'large adder input parity error , byte 9',             
           'large adder input parity error , byte 10', 'large adder input parity error , byte 11',            
           'large adder group 0 carry error',  'large adder group 1 carry error',                             
           'large adder group 2 carry error',  'large adder group 3 carry error',                             
           'large adder group 4 carry error',  'large adder group 5 carry error',                             
           'large adder group 6 carry error',  'large adder group 7 carry error',                             
           'large adder group 8 carry error',  'large adder group 9 carry error',                             
           'large adder group 10 carry error', 'large adder group 11 carry error',                            
           'not used', 'not used',                                                                            
           'shift count ( from AC ) parity error , byte 0', 'shift count ( from AC ) parity error , byte 1',  
           'multiply final adder carry error , group 0', 'multiply final adder carry error , group 1',        
           'not used', 'PFS board 4 internal parity error'],                                                  
                                                                                                              
    duv$rd_pro_990_pfs_8: [STATIC] dut$rd_pro_general_pfs :=                                                  
          [REP 8 OF 'not used',                                                                               
           'load BDP latch parity error , byte 0', 'load BDP latch parity error , byte 1',                    
           'load BDP latch parity error , byte 2', 'load BDP latch parity error , byte 3',                    
           'load BDP latch parity error , byte 4', 'load BDP latch parity error , byte 5',                    
           'load BDP latch parity error , byte 6', 'load BDP latch parity error , byte 7',                    
           'load state latch parity error , byte 0', 'load state latch parity error , byte 1',                
           'load state latch parity error , byte 2', 'load state latch parity error , byte 3',                
           'load state latch parity error , byte 4', 'load state latch parity error , byte 5',                
           'load state latch parity error , byte 6', 'load state latch parity error , byte 7',                
           'A-data buffer output latch parity error , byte 0',                                                
           'A-data buffer output latch parity error , byte 1',                                                
           'A-data buffer output latch parity error , byte 2',                                                
           'A-data buffer output latch parity error , byte 3',                                                
           'A-data buffer output latch parity error , byte 4',                                                
           'A-data buffer output latch parity error , byte 5',                                                
           'A-data buffer output latch parity error , byte 6',                                                
           'A-data buffer output latch parity error , byte 7',                                                
           'A-data buffer output latch 1 parity error , byte 0',                                              
           'A-data buffer output latch 1 parity error , byte 1',                                              
           'A-data buffer output latch 1 parity error , byte 2',                                              
           'A-data buffer output latch 1 parity error , byte 3',                                              
           'A-data buffer output latch 1 parity error , byte 4',                                              
           'A-data buffer output latch 1 parity error , byte 5',                                              
           'A-data buffer output latch 1 parity error , byte 6',                                              
           'A-data buffer output latch 1 parity error , byte 7',                                              
           'A-data buffer output latch 2 parity error , byte 0',                                              
           'A-data buffer output latch 2 parity error , byte 1',                                              
           'A-data buffer output latch 2 parity error , byte 2',                                              
           'A-data buffer output latch 2 parity error , byte 3',                                              
           'A-data buffer output latch 2 parity error , byte 4',                                              
           'A-data buffer output latch 2 parity error , byte 5',                                              
           'A-data buffer output latch 2 parity error , byte 6',                                              
           'A-data buffer output latch 2 parity error , byte 7',                                              
           'B-data buffer output latch parity error , byte 0',                                                
           'B-data buffer output latch parity error , byte 1',                                                
           'B-data buffer output latch parity error , byte 2',                                                
           'B-data buffer output latch parity error , byte 3',                                                
           'B-data buffer output latch parity error , byte 4',                                                
           'B-data buffer output latch parity error , byte 5',                                                
           'B-data buffer output latch parity error , byte 6',                                                
           'B-data buffer output latch parity error , byte 7',                                                
           'B-input data latch parity error , byte 0', 'B-input data latch parity error , byte 1',            
           'B-input data latch parity error , byte 2', 'B-input data latch parity error , byte 3',            
           'B-input data latch parity error , byte 4', 'B-input data latch parity error , byte 5',            
           'B-input data latch parity error , byte 6', 'B-input data latch parity error , byte 7'],           
                                                                                                              
    duv$rd_pro_845_860_pfs_9: [STATIC] dut$rd_pro_845_860_pfs :=                                              
          ['multiply final adder carry error , group 2', 'multiply final adder carry error , group 3',        
           'multiply final adder carry error , group 4', 'multiply final adder carry error , group 5',        
           'multiply final adder carry error , group 6', 'multiply final adder carry error , group 7',        
           'multiply final adder carry error , group 8', 'not used',                                          
           'ALN micrand parity error , byte 0', 'ALN micrand parity error , byte 1',                          
           'ALN micrand parity error , byte 2', 'ALN micrand parity error , byte 3',                          
           'ALN micrand parity error , byte 4', 'ALN micrand parity error , byte 5',                          
           'ALN micrand parity error , byte 6', 'ALN micrand parity error , byte 7'],                         
                                                                                                              
    duv$rd_pro_990_pfs_9: [STATIC] dut$rd_pro_general_pfs :=                                                  
          ['load X latch parity error , byte 0', 'load X latch parity error , byte 1',                        
           'load X latch parity error , byte 2', 'load X latch parity error , byte 3',                        
           'load X latch parity error , byte 4', 'load X latch parity error , byte 5',                        
           'load X latch parity error , byte 6', 'load X latch parity error , byte 7',                        
           'store input latch 2 parity error , byte 0', 'store input latch 2 parity error , byte 1',          
           'store input latch 2 parity error , byte 2', 'store input latch 2 parity error , byte 3',          
           'store input latch 2 parity error , byte 4', 'store input latch 2 parity error , byte 5',          
           'store input latch 2 parity error , byte 6', 'store input latch 2 parity error , byte 7',          
           'store buffer output latch parity error , byte 0',                                                 
           'store buffer output latch parity error , byte 1',                                                 
           'store buffer output latch parity error , byte 2',                                                 
           'store buffer output latch parity error , byte 3',                                                 
           'store buffer output latch parity error , byte 4',                                                 
           'store buffer output latch parity error , byte 5',                                                 
           'store buffer output latch parity error , byte 6',                                                 
           'store buffer output latch parity error , byte 7',                                                 
           'store data latch 3 parity error , byte 0', 'store data latch 3 parity error , byte 1',            
           'store data latch 3 parity error , byte 2', 'store data latch 3 parity error , byte 3',            
           'store data latch 3 parity error , byte 4', 'store data latch 3 parity error , byte 5',            
           'store data latch 3 parity error , byte 6', 'store data latch 3 parity error , byte 7',            
           'load A input data latch parity error , byte 0', 'load A input data latch parity error , byte 1',  
           'load A input data latch parity error , byte 2', 'load A input data latch parity error , byte 3',  
           'load A input data latch parity error , byte 4', 'load A input data latch parity error , byte 5',  
           'load A input data latch parity error , byte 6', 'load A input data latch parity error , byte 7',  
           'load A 170 RAC latch parity error , byte 0', 'load A 170 RAC latch parity error , byte 1',        
           'load A 170 RAC latch parity error , byte 2', 'load A 170 RAC latch parity error , byte 3',        
           'load A 170 temp latch parity error , byte 0', 'load A 170 temp latch parity error , byte 1',      
           'load A 170 temp latch parity error , byte 2', 'load A 170 temp latch parity error , byte 3',      
           'store mark byte output parity error', 'BDP store mark lines input latch parity error',            
           'hit buffer input latch parity error , byte 0', 'hit buffer input latch parity error , byte 1',    
           'hit buffer input latch parity error , byte 2', 'hit buffer input latch parity error , byte 3',    
           'hit buffer input latch parity error , byte 4', 'hit buffer input latch parity error , byte 5',    
           'BDP store control latch parity error', 'BDP load control input latch parity error',               
           'hit buffer output latch parity error , byte 0', 'hit buffer output latch parity error , byte 1',  
           'hit buffer output latch parity error , byte 2', 'hit buffer output latch parity error , byte 3',  
           'hit buffer output latch parity error , byte 4', 'hit buffer output latch parity error , byte 5'], 
                                                                                                              
    duv$rd_pro_990_pfs_a: [STATIC] dut$rd_pro_general_pfs :=                                                  
          ['load control mux/latch parity error , byte 0',  'load control mux/latch parity error , byte 1',   
           'load control mux/latch parity error , byte 2',  'load control mux/latch parity error , byte 3',   
           'load control mux/latch parity error , byte 4',  'load control mux/latch parity error , byte 5',   
           'load control mux/latch parity error , byte 6',  'load control mux/latch parity error , byte 7',   
           'load control mux/latch parity error , byte 8',  'load control mux/latch parity error , byte 9',   
           'load control mux/latch parity error , byte 10', 'load control mux/latch parity error , byte 11',  
           'load control mux/latch parity error , byte 12', 'load control mux/latch parity error , byte 13',  
           'vector control input latch parity error', 'illegal soft control access',                          
           'IDU control latch parity error , byte 0', 'IDU control latch parity error , byte 1',              
           'IDU control latch parity error , byte 2', 'IDU control latch parity error , byte 3',              
           'IDU control latch parity error , byte 4', 'ACU control latch parity error , byte 0',              
           'ACU control latch parity error , byte 1', 'ACU control latch parity error , byte 2',              
           'vector tag input latch parity error , byte 0', 'vector tag input latch parity error , byte 1',    
           'IDU load control input parity error , byte 0', 'IDU load control input parity error , byte 1',    
           'IDU load control input parity error , byte 2', 'IDU load control input parity error , byte 3',    
           'IDU load control input parity error , byte 4', 'IDU load control input parity error , byte 5',    
           'vector tag output latch parity error , byte 0', 'vector tag output latch parity error , byte 1',  
           'B-control buffer ACU output latch parity error , byte 0',                                         
           'B-control buffer ACU output latch parity error , byte 1',                                         
           'B-control buffer ACU output latch parity error , byte 2',                                         
           'B-control buffer ACU output latch parity error , byte 3',                                         
           'B-control buffer ACU output latch parity error , byte 4',                                         
           'B-control buffer ACU output latch parity error , byte 5',                                         
           'B-control buffer IOU output latch parity error , byte 0',                                         
           'B-control buffer IOU output latch parity error , byte 1',                                         
           'B-control buffer IOU output latch parity error , byte 2',                                         
           'B-control buffer IOU output latch parity error , byte 3',                                         
           'B-control buffer IOU output latch parity error , byte 4',                                         
           'B-control buffer IOU output latch parity error , byte 5',                                         
           'B-control buffer IOU output latch parity error , byte 6',                                         
           'B-control buffer IOU output latch parity error , byte 7',                                         
           'soft-control load input latch parity error , byte 0',                                             
           'soft-control load input latch parity error , byte 1',                                             
           'soft-control load input latch parity error , byte 2',                                             
           'soft-control load input latch parity error , byte 3',                                             
           'load control latch 2 parity error , byte 0', 'load control latch 2 parity error , byte 1',        
           'load control latch 2 parity error , byte 2', 'load control latch 2 parity error , byte 3',        
           'load control latch 3 parity error', 'MAC load control latch parity error',                        
           'load A output latch 1 parity error', 'load A output latch 2 parity error , byte 0',               
           'load A output latch 2 parity error , byte 1', 'load A output latch 3 parity error , byte 0',      
           'load A output latch 3 parity error , byte 1', 'load A output latch 3 parity error , byte 2'],     
                                                                                                              
    duv$rd_pro_990_pfs_b: [STATIC] dut$rd_pro_general_pfs :=                                                  
          ['store control input latch 1 parity error , byte 0',                                               
           'store control input latch 1 parity error , byte 1',                                               
           'store control input latch 1 parity error , byte 2',                                               
           'store control input latch 1 parity error , byte 3',                                               
           'store control input latch 2 parity error , byte 0',                                               
           'store control input latch 2 parity error , byte 1',                                               
           'store control input latch 2 parity error , byte 2',                                               
           'store control input latch 2 parity error , byte 3',                                               
           'store control select mux latch parity error , byte 0',                                            
           'store control select mux latch parity error , byte 1',                                            
           'store control select mux latch parity error , byte 2',                                            
           'store control select mux latch parity error , byte 3',                                            
           'store control latch 2 parity error , byte 0', 'store control latch 2 parity error , byte 1',      
           'store control latch 3 parity error ', REP 6 OF 'not used', 'issue time-out',                      
           'RPL rank 12 parity error , byte 0', 'RPL rank 12 parity error , byte 1',                          
           'RPL rank 12 parity error , byte 2', 'RPL rank 11 parity error , byte 0',                          
           'RPL rank 11 parity error , byte 1', 'RPL rank 11 parity error , byte 2',                          
           'RPL rank 10 parity error , byte 0', 'RPL rank 10 parity error , byte 1',                          
           'RPL rank 10 parity error , byte 2', 'RPL rank 9 parity error , byte 0',                           
           'RPL rank 9 parity error , byte 1',  'RPL rank 9 parity error , byte 2',                           
           'RPL rank 8 parity error , byte 0',  'RPL rank 8 parity error , byte 1',                           
           'RPL rank 8 parity error , byte 2',  'RPL rank 7 parity error , byte 0',                           
           'RPL rank 7 parity error , byte 1',  'RPL rank 7 parity error , byte 2',                           
           'RPL rank 6 parity error , byte 0',  'RPL rank 6 parity error , byte 1',                           
           'RPL rank 6 parity error , byte 2',  'RPL rank 5 parity error , byte 0',                           
           'RPL rank 5 parity error , byte 1',  'RPL rank 5 parity error , byte 2',                           
           'RPL rank 4 parity error , byte 0',  'RPL rank 4 parity error , byte 1',                           
           'RPL rank 4 parity error , byte 2',  'RPL rank 3 parity error , byte 0',                           
           'RPL rank 3 parity error , byte 1',  'RPL rank 3 parity error , byte 2',                           
           'RPL rank 2 parity error , byte 0',  'RPL rank 2 parity error , byte 1',                           
           'RPL rank 2 parity error , byte 2',  'RPL rank 1 parity error ',                                   
           'issue time-out error , bit 0', 'issue time-out error , bit 1',                                    
           'issue time-out error , bit 2', 'issue time-out error , bit 3',                                    
           'issue time-out error , bit 4', 'issue time-out error , bit 5',                                    
           'issue time-out error , bit 6', 'issue time-out error , bit 7'],                                   
                                                                                                              
    duv$rd_pro_990_pfs_c: [STATIC] dut$rd_pro_general_pfs :=                                                  
          ['state load latch rank 1 parity error , byte 0', 'state load latch rank 1 parity error , byte 1',  
           'state load latch rank 1 parity error , byte 2', 'state load latch rank 1 parity error , byte 3',  
           'state load mux latch rank 1 parity error , byte 4',                                               
           'state load mux latch rank 1 parity error , byte 5',                                               
           'state load mux latch rank 1 parity error , byte 6',                                               
           'state load mux latch rank 1 parity error , byte 7',                                               
           'state load latch rank 2 parity error , byte 0', 'state load latch rank 2 parity error , byte 1',  
           'state load latch rank 2 parity error , byte 2', 'state load latch rank 2 parity error , byte 3',  
           'state load latch rank 2 parity error , byte 4', 'state load latch rank 2 parity error , byte 5',  
           'state load latch rank 2 parity error , byte 6', 'state load latch rank 2 parity error , byte 7',  
           'store tag data latch parity error , byte 0', 'store tag data latch parity error , byte 1',        
           'store tag history buffer latch parity error , byte 0',                                            
           'store tag history buffer latch parity error , byte 1',                                            
           'load error parity error , byte 0', 'load error parity error , byte 1',                            
           'state load RK 2 parity error , byte 6', 'state load RK 2 parity error , byte 7',                  
           'state output mux register parity error , byte 0',                                                 
           'state output mux register parity error , byte 1',                                                 
           'state output mux register parity error , byte 2',                                                 
           'state output mux register parity error , byte 3',                                                 
           'state output mux register parity error , byte 4',                                                 
           'state output mux register parity error , byte 5',                                                 
           'state output mux register parity error , byte 6',                                                 
           'state output mux register parity error , byte 7',                                                 
           'state read mux parity error , byte 0', 'state read mux parity error , byte 1',                    
           'state read mux parity error , byte 2', 'state read mux parity error , byte 3',                    
           'state read mux parity error , byte 4', 'state read mux parity error , byte 5',                    
           'state read mux parity error , byte 6', 'state read mux parity error , byte 7',                    
           'history tag parity error , byte 0', 'history tag parity error , byte 1',                          
           'load path tag parity error', 'history tag path parity error , byte 0',                            
           'history tag path parity error , byte 1', 'history tag path parity error , byte 2',                
           'history tag path parity error , byte 3', 'history tag path parity error , byte 4',                
           'MAC write data parity error', 'MAC read data parity error',                                       
           'UTP buffer register parity error , byte 0', 'UTP buffer register parity error , byte 1',          
           'UTP buffer register parity error , byte 2', 'UTP buffer register parity error , byte 3',          
           'UTP buffer register parity error , byte 4', 'UTP buffer register parity error , byte 5',          
           'assembly/disassembly parity error , byte 0', 'assembly/disassembly parity error , byte 1',        
           'assembly/disassembly parity error , byte 2', 'assembly/disassembly parity error , byte 3',        
           'assembly/disassembly parity error , byte 4', 'assembly/disassembly parity error , byte 5',        
           'assembly/disassembly parity error , byte 6', 'assembly/disassembly parity error , byte 7'],       
                                                                                                              
    duv$rd_pro_990_pfs_d: [STATIC] dut$rd_pro_general_pfs :=                                                  
          ['response latch parity error , byte 0', 'response latch parity error , byte 1',                    
           'response latch parity error , byte 2', 'JPS auxiliary board FU 1A parity error',                  
           'JPS auxiliary board FU 1B parity error', 'user mark or monitor mark parity error',                
           'MDW byte 0 parity error', 'MDW byte 1 parity error', 'not used', 'PTL,STL or KM parity error',    
           'auxiliary board FU 1C parity error', 'auxiliary board FU 1B parity error',                        
           'auxiliary board FU 1A parity error', 'auxiliary board FU 2A parity error',                        
           'auxiliary board FU 2B parity error', 'auxiliary board FU 3A parity error', 'not used',            
           'data result register parity error , byte 0', 'data result register parity error , byte 1',        
           'data result register parity error , byte 2', 'data result register parity error , byte 3',        
           'data result register parity error , byte 4', 'data result register parity error , byte 5',        
           'data result register parity error , byte 6', 'not used', 'not used',                              
           'port A response code bit 0', 'port A response code bit 1',                                        
           'port B response code bit 0', 'port B response code bit 1',                                        
           'port C response code bit 0', 'port C response code bit 1', REP 10 OF 'not used',                  
           'register 22 parity error , byte 2',  'register 22 parity error , byte 3',                         
           'register 22 parity error , byte 8',  'register 22 parity error , byte 9',                         
           'register 22 parity error , byte 10', 'register 22 parity error , byte 11',                        
           'register 22 parity error , byte 12', 'register 22 parity error , byte 13',                        
           'register 22 parity error , byte 14', 'register 22 parity error , byte 15',                        
           'buffer input latch number 1 parity error , byte 4',                                               
           'buffer input latch number 1 parity error , byte 5',                                               
           'buffer input latch number 1 parity error , byte 6',                                               
           'buffer input latch number 1 parity error , byte 7',                                               
           'buffer input latch number 2 parity error , byte 1',                                               
           'buffer input latch number 2 parity error , byte 2',                                               
           'buffer input latch number 2 parity error , byte 3',                                               
           'buffer input latch number 2 parity error , byte 4',                                               
           'buffer input latch number 2 parity error , byte 5',                                               
           'buffer input latch number 2 parity error , byte 6',                                               
           'buffer input latch number 2 parity error , byte 7',                                               
           'MAC read data parity error'],                                                                     
                                                                                                              
    duv$rd_pro_990_pfs_e: [STATIC] dut$rd_pro_general_pfs :=                                                  
          ['180 map output register parity error , byte 0', '180 map output register parity error , byte 1',  
           '180 map output register parity error , byte 2', '180 map output register parity error , byte 3',  
           '180 map output register parity error , byte 4', '180 map output register parity error , byte 5',  
           '170 map output register parity error , byte 6', '170 map output register parity error , byte 7',  
           'map instruction register parity error , byte 0', 'map instruction register parity error , byte 1',
           'map instruction register parity error , byte 2', 'map instruction register parity error , byte 3',
           'map address register parity error , byte 0', 'map address register parity error , byte 1',        
           'map address register parity error , byte 2', 'map address register parity error , byte 3',        
           'IBA1 register parity error , byte 0', 'IBA1 register parity error , byte 1',                      
           'IBA1 register parity error , byte 2', 'IBA1 register parity error , byte 3',                      
           'SVA register parity error , byte 0', 'SVA register parity error , byte 1',                        
           'SVA register parity error , byte 2', 'SVA register parity error , byte 3',                        
           'RMA register parity error , byte 0', 'RMA register parity error , byte 1',                        
           'destination tag register parity error , byte 0', 'destination tag register parity error , byte 1',
           'CMC response counter error , set 0', 'CMC response counter error , set 1',                        
           'CMC response counter error , set 2', 'CMC response counter error , set 3',                        
           'CMC destination code register parity error', 'PFSA register parity error , byte 0',               
           'PFSA register parity error , byte 1', 'PFSA register parity error , byte 2',                      
           'IBS error , set 0', 'IBS error , set 1', 'IBS error , set 2', 'IBS error , set 3',                
           'lookahead multiple hit', 'IBS read multiple hit',                                                 
           REP 15 OF 'not used', 'IN2 error tag parity error',                                                
           'PSR error tag parity error', 'ACU error tag parity error',                                        
           'soft control memory parity error , byte 0', 'soft control memory parity error , byte 1',          
           'soft control memory parity error , byte 2', 'soft control invalid access'],                       
                                                                                                              
    duv$rd_pro_990_pfs_f: [STATIC] dut$rd_pro_general_pfs :=                                                  
          ['data memory parity error , set 0', 'data memory parity error , set 1',                            
           'data memory parity error , set 2', 'data memory parity error , set 3',                            
           'tag memory parity error , set 0',  'tag memory parity error , set 1',                             
           'tag memory parity error , set 2',  'tag memory parity error , set 3',                             
           'tag address parity error , set 0', 'tag address parity error , set 1',                            
           'tag address parity error , set 2', 'tag address parity error , set 3',                            
           'state address parity error , set 0', 'state address parity error , set 1',                        
           'state address parity error , set 2', 'state address parity error , set 3',                        
           'data memory parity error , byte/board 0', 'data memory parity error , byte/board 1',              
           'data memory parity error , byte/board 2', 'data memory parity error , byte/board 3',              
           'data memory parity error , byte/board 4', 'data memory parity error , byte/board 5',              
           'data memory parity error , byte/board 6', 'data memory parity error , byte/board 7',              
           'data/tag mux to MAC parity error', 'multiple tag hit', 'set allocation error', 'not used',        
           'CI address or SVAPTC parity error , byte 0', 'CI address or SVAPTC parity error , byte 1',        
           'CI address or SVAPTC parity error , byte 2', 'CI address or SVAPTC parity error , byte 3',        
           'CI address or SVAPTC parity error , byte 4', 'CI address or SVAPTC parity error , byte 5',        
           'input SVA parity error , byte 0', 'input SVA parity error , byte 1',                              
           'input SVA parity error , byte 2', 'input SVA parity error , byte 3',                              
           'input SVA parity error , byte 4', 'input SVA parity error , byte 5',                              
           'register 2 SVA parity error , byte 0', 'register 2 SVA parity error , byte 1',                    
           'register 2 SVA parity error , byte 2', 'register 2 SVA parity error , byte 3',                    
           'register 2 SVA parity error , byte 4', 'register 2 SVA parity error , byte 5',                    
           'register 2 second rank SVA parity error , byte 0',                                                
           'register 2 second rank SVA parity error , byte 1',                                                
           'register 2 second rank SVA parity error , byte 2',                                                
           'register 2 second rank SVA parity error , byte 3',                                                
           'register 2 second rank SVA parity error , byte 4',                                                
           'register 2 second rank SVA parity error , byte 5',                                                
           'prefetch SVA parity error , byte 0', 'prefetch SVA parity error , byte 1',                        
           'prefetch SVA parity error , byte 2', 'prefetch SVA parity error , byte 3',                        
           'prefetch SVA parity error , byte 4', 'cache load register 2 parity error',                        
           'cache load address parity error , byte 0', 'cache load address parity error , byte 1',            
           'cache load address parity error , byte 2', 'cache load address parity error , byte 3',            
           'cache load address parity error , byte 4', 'cache load address parity error , byte 5'];           
*DECK DECK=DUT$STACK_SEARCH_DIRECTION EXPAND=FALSE
  TYPE
    dut$stack_search_direction = (duc$first_to_trapped, duc$trapped_to_first);
*DECK DECK=DUT$SYMBOL_ENTRY EXPAND=FALSE
  TYPE
    dut$symbol_entry = record
      table_entry_index: llt$symbol_number,
      symbol: ^llt$symbol_table_item,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc llt$debug_symbol_table
?? POP ??
*DECK DECK=DUT$TITLE_DATA EXPAND=FALSE

  TYPE
    dut$title_data = RECORD
      build_title: boolean,
      main_title: string (25),
      command_name: ost$name,
      system_level: ost$name,
      base_system_time: string (20),
      termination_time: string (20),
    RECEND;

*copyc ost$name
*DECK DECK=DUT$VARIABLE_ATTRIBUTE EXPAND=FALSE
  TYPE
    dut$variable_attribute = (duc$variable_value, duc$variable_address,
      duc$variable_size, duc$variable_lower_bound, duc$variable_upper_bound,
      duc$variable_lower_value, duc$variable_upper_value);


*DECK DECK=DUT$VARIABLE_SEARCH_OPTIONS EXPAND=FALSE
  TYPE
    dut$variable_search_options = SET OF (duc$search_outer_procedures,
                                          duc$search_module_level);

*DECK DECK=DUT$VARIABLE_SPECIFICATION EXPAND=FALSE
  TYPE
    dut$variable_specification = RECORD
      name: pmt$program_name,
      symbol_entry: dut$symbol_entry,
      original_symbol_entry: dut$symbol_entry,
      address: ost$pva,
      length: ost$segment_length,
      bit_offset: 0 .. byte_size,
      length_is_bits: boolean,
      range_specified: boolean,
      contains_non_literal_qualifiers: boolean,
      low_value: integer,
      high_value: integer,
      descriptor_address: ost$pva,
      attribute: dut$variable_attribute,
      max_string_length: llt$string_length_range,
      constant_value: boolean,
      array_section_specified: boolean,
      stack_frame_ptr_for_base_var: ^ost$stack_frame_save_area,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc cyd$machine_definitions
*copyc dut$variable_attribute
*copyc llt$debug_symbol_table
*copyc osd$virtual_address
*copyc ost$stack_frame_save_area
*copyc pmt$program_name
?? POP ??
*DECK DECK=DUV$ANAD_COMMANDS EXPAND=FALSE
  VAR
    duv$anad_commands: [XREF, READ] ^clt$command_table;

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_table
?? POP ??
*DECK DECK=DUV$ANAD_FUNCTIONS EXPAND=FALSE
  VAR
    duv$anad_functions: [XREF, READ] ^clt$function_processor_table;

?? PUSH (LISTEXT := ON) ??
*copyc clt$function_processor_table
?? POP ??
*DECK DECK=DUV$ANAS_COMMANDS EXPAND=FALSE
  VAR
    duv$anas_commands: [XREF, READ] ^clt$command_table;

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_table
?? POP ??
*DECK DECK=DUV$ANAS_FUNCTIONS EXPAND=FALSE
  VAR
    duv$anas_functions: [XREF, READ] ^clt$function_processor_table;

?? PUSH (LISTEXT := ON) ??
*copyc clt$function_processor_table
?? POP ??
*DECK DECK=DUV$DEFAULT_PARAMETERS EXPAND=FALSE

  VAR
    duv$default_parameters: [XREF] dut$default_parameter_list;

?? PUSH (LISTEXT := ON) ??
*copyc dut$default_parameter_list
?? POP ??
*DECK DECK=DUV$DUMP_ENVIRONMENT_P EXPAND=FALSE

  VAR
    duv$dump_environment_p: [XREF] ^dut$dump_environment;

?? PUSH (LISTEXT := ON) ??
*copyc dut$dump_environment
?? POP ??
*DECK DECK=DUV$EXECUTION_ENVIRONMENT EXPAND=FALSE

  VAR
    duv$execution_environment: [XREF] dut$execution_environment;

?? PUSH (LISTEXT := ON) ??
*copyc dut$execution_environment
?? POP ??
*DECK DECK=DUV$TITLE_DATA EXPAND=FALSE

  VAR
    duv$title_data: [XREF] dut$title_data;

?? PUSH (LISTEXT := ON) ??
*copyc dut$title_data
?? POP ??
*DECK DECK=DXM$PROCESS_ONE_WORD_RESPONSE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' Hyper Channel DX: process_one_word_response ' ??
MODULE dxm$process_one_word_response;
{
{  This module contains the Hyper Channel DX one word PP response handler.
{
?? TITLE := '    Global Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dft$fs_pp_response
*copyc dft$one_word_response_handler
*copyc iot$pp_interface_table
*copyc syt$monitor_status
*copyc dfi$monitor_display
*copyc tmp$check_taskid
*copyc tmp$set_task_ready
*copyc oss$mainframe_wired
?? POP ??
?? TITLE := '   INLINE IN DECKS ', EJECT ??

  PROCEDURE [INLINE] convert_p_fs_resp_to_p_dx_resp
    (    p_fs_pp_response: ^dft$fs_pp_response;
     VAR p_dx_pp_response: ^dxt$dx_pp_response);

  { This procedure uses a variant record 'trick' to convert a variable of
  { type ^dft$fs_pp_response to one of type ^dxt$dx_pp_response.

    TYPE
      converter = record
        case (fs_pp_response, dx_pp_response) of
        = fs_pp_response =
          p_fs_pp_response: ^dft$fs_pp_response,
        = dx_pp_response =
          p_dx_pp_response: ^dxt$dx_pp_response,
        casend,
      recend;

    VAR
      converter_variable: converter;

    converter_variable.p_fs_pp_response := p_fs_pp_response;
    p_dx_pp_response := converter_variable.p_dx_pp_response;

  PROCEND convert_p_fs_resp_to_p_dx_resp;

?? PUSH (LISTEXT := ON) ??
*copyc dft$fs_pp_response
*copyc dxt$dx_pp_response
?? POP ??
?? TITLE := '    Global Variables ', EJECT ??

  VAR
    dxv$one_word_response_handler: [XDCL, STATIC, #GATE, OSS$MAINFRAME_WIRED]
          dft$one_word_response_handler := ^dxp$process_HCDX_one_word_resp;

?? TITLE := '    [XDCL] dxp$process_HCDX_one_word_resp', EJECT ??
  PROCEDURE [XDCL] dxp$process_HCDX_one_word_resp
    (    one_word_response_p: ^dft$fs_pp_response;
         pp_number: 1 .. ioc$pp_count;
     VAR status: syt$monitor_status);

    {
    {  This procedure executes in the Monitor and is called to process one word
    {  responses from the Hyper Channel DX PP driver.
    {
    {  The Hyper Channel DX PP driver's one word response contains
    {  response_flags record identical to the dft$fs_pp_response, however not
    {  all of the response flags have meaning.
    {
    {   SPECIAL_RESPONSE - This flag is detected by iom$process_io_completions
    {          and is used to indicate that a check should be made to determine
    {          if the PP response is a "special response".
    {
    {   ONE_WORD_RESPONSE - This flag is detected by iom$process_io_completions
    {          and indicates that the response is a special response to be
    {          processed by the One Word Response Handler as specified in the
    {          Logical PP table.
    {
    {   ERROR_RESPONSE - not used in Hyper Channel DX one word response.
    {
    {   INQUIRY_RESPONSE - not used in Hyper Channel DX one word response.
    {
    {   TERMINATION_PSEUDO_RESPONSE - not used in Hyper Channel DX one word response.


    VAR
      p_dx_pp_response: ^dxt$dx_pp_response;


    status.normal := TRUE;

    convert_p_fs_resp_to_p_dx_resp (one_word_response_p, p_dx_pp_response);

    tmp$check_taskid (p_dx_pp_response^.global_task_id, tmc$opt_return, status);
    IF NOT status.normal THEN
      status.normal := TRUE;
      dpp$display_error ('DX - INFORMATIVE, ONE WORD RESPONSE - TASK NO LONGER ACTIVE');
      display_integer_monitor ('DX - INVALID TASK ID, INDEX = ', $integer (
            p_dx_pp_response^.global_task_id.index));
      display_integer_monitor ('DX - INVALID TASK ID, SEQNO = ', $integer (
            p_dx_pp_response^.global_task_id.seqno));
      RETURN;
    IFEND;

    tmp$set_task_ready (p_dx_pp_response^.global_task_id, 0 {readying_task_priority},
           tmc$rc_ready_conditional);


  PROCEND dxp$process_HCDX_one_word_resp;

MODEND dxm$process_one_word_response;
*DECK DECK=DXM$STORE_ONE_WORD_RESPONSE_PTR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' DXM$STORE_ONE_WORD_RESPONSE_PTR' ??
MODULE dxm$store_one_word_response_ptr;
{
{  This module contains the procedure which provides the interface
{  to procedure cmp$store_one_word_response_ptr.
{

?? PUSH (LISTEXT := ON) ??
*copyc cmp$get_logical_pp_number
*copyc cmp$store_one_word_response_ptr
*copyc dxv$one_word_response_handler
?? POP ??
?? TITLE := ' [XDCL, #GATE]  dxp$store_one_word_response_ptr ', EJECT ??
  PROCEDURE [XDCL, #GATE] dxp$store_one_word_response_ptr
    (    element_name: cmt$element_name;
     VAR status: ost$status);

    VAR
      pp_number: iot$pp_number;

    cmp$get_logical_pp_number (element_name, pp_number, status);
    IF status.normal THEN
      cmp$store_one_word_response_ptr (pp_number, dxv$one_word_response_handler, status);
    IFEND;

  PROCEND dxp$store_one_word_response_ptr;

MODEND dxm$store_one_word_response_ptr;


*DECK DECK=DXP$STORE_ONE_WORD_RESPONSE_PTR EXPAND=FALSE

  PROCEDURE [XREF] dxp$store_one_word_response_ptr
    (    element_name: cmt$element_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc ost$status
?? POP ??

*DECK DECK=DXT$DX_PP_RESPONSE EXPAND=FALSE
{ DECK: DXT$DX_PP_RESPONSE

  TYPE
    dxt$dx_pp_response = record
      response_flags: ALIGNED [0 MOD 8] dft$response_flags,
      response_length: ALIGNED [1 MOD 8] 0 .. 0FF(16),
      function_code: ALIGNED [2 MOD 8] 0 .. 0FF(16),
      fill: ALIGNED [3 MOD 8] 0 .. 0FFFF(16),
      global_task_id: ost$global_task_id,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc dft$fs_pp_response
*copyc ost$global_task_id
?? POP ??

*DECK DECK=DXV$ONE_WORD_RESPONSE_HANDLER EXPAND=FALSE

  VAR
    dxv$one_word_response_handler: [XREF] dft$one_word_response_handler;

*copyc dft$one_word_response_handler

*DECK DECK=ESMD EXPAND=TRUE
          IDENT  ESMD
          CIPPU

          TITLE  ESMD - NOS/VE ESM/STORNET DRIVER FOR FILE SERVER
          COMMENT *SMD* LVL=01
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992.
          EJECT
*****     ESMD - ESM/STORNET PP DRIVER FOR NOS/VE FILE SERVER.
*
***       ESMD is a driver PP program which operates on behalf of the NOS/VE
*         File Server subsystem using an ESM/STORNET device to link from two
*         to eight mainframes together in a File Server configuration.
*
*         Both the ESM and STORNET device are supported by this driver, in
*         fact the program is not aware of which device is present. The driver
*         utilizes the "four bit flag registers" and one "low speed port";
*         the ESM/STORNET "fast transfer mode" is selected only when the driver
*         instructed to utilize the I4 DMA ENHANCE C170 ADAPTER channel.
*
*         This program will function in one of serveral modes depending on
*         configuration parameters passed to the driver via the File Server
*         Queue Interface Table (QIT).
*           Number of PPs:
*             File Server may utilize either one or two PP drivers. If one is
*             specified it performs both SEND TO and READ FROM ESM/STORNET
*             operations. If two is specified, one is responsible for processing
*             requests in the "Request Buffer", the other is responsible for
*             detecting and processing request in ESM/STORNET memory.
*           I/O Channel:
*             This program requires one channel, and expects exclusive access to
*             the assigned channel. The following channel types are supported -
*                Standard CY170 channel
*                I4 with DMA ENHANCED C170 ADAPTER
*                I0/S0 CYBER 170 Channel Adapter (ICI)
*
*
**        ESMD ASSEMBLY OPTIONS.
*
 ERETRY   EQU    10D         MAXIMUM NUMBER OF RETRIES ON ERROR

**        ESMD CONSTANTS.
*
 MAXREQ   EQU    14D         MAXIMUM PP REQUEST LENGTH - CM WORDS
 MLUC     EQU    1           MAXIMUM NUMBER OF LOGICAL UNITS SUPPORTED
 PAGSZ    EQU    4096        OPTIMUM SIZE OF I/O BUFFER IN 8 BIT BYTES
 PPMSZ    EQU    4096        PP MEMORY SIZE IN PP WORDS

**        ESMD / FILE SERVER CONSTANTS.
*         REFERENCE DECKS:
*             DFC$ESM_ALLOCATION_CONSTANTS
*             DFT$QUEUE_INDEX
*
 MAXDIV   EQU    16D         MAXIMUM NUMBER OF ESM DIVISIONS
 MAXIDN   EQU    8D          MAXIMUM NUMBER OF MACHINES
 MAXIND   EQU    64          MAXIMUM INDIRECT LIST LENGTH IN CM WORDS
 MAXQDE   EQU    16D         MAXIMUM NUMBER OF QUEUE DIRECTORY ENTRIES
 POLLQEI  EQU    1           POLL TASK'S QUEUE ENTRY INDEX
          EJECT
** FILE SERVER / ESMD OVERVIEW.
*
*  The players in a file server system consist of 'client tasks' which reside
*  on the 'client side', and 'server tasks' which reside on the 'server side'
*  of a file server configuration. The client initiates communication with the
*  server through a queue entry in a client to server queue. The queue entry is
*  processed by the client side PP driver (ESMD) which sends to the server side
*  PP driver. The server side PP driver receives into buffers pointed to by the
*  corresponding queue entry in a server to client queue.
*  The link between the client side ESMD and the server side ESMD is extended
*  semiconductor memory (ESM) and also known as a STORNET device.
*
*  ESMD provides for sending and receiving data from/to two separate central
*  memory buffers pointed to by each queue entry. The first of these is a
*  preallocated buffer, the length of which is 4096 bytes at most. The second
*  may be from 1 to 64 buffer areas, each of which may not cross a CM page
*  boundary. ESMD knows nothing of the contents of the data, however, by file
*  server definition the preallocated buffer is used for file server commands
*  and responses, and the list of from 1 to 64 buffers is used for file data.
*
*  ESM resources are divided among the ESM connected mainframes according to
*  parameters in the ESM record of the queue interface table. The contents of
*  the ESM record must be the same for all the mainframe's PP drivers so that
*  each PP knows which portion of ESM belongs to itself (source), and every
*  other PP (destination).
*
*  A block of ESM memory is set aside for each machine in the file server
*  configuration. Each block is subdivided into the number of specified
*  divisions, and an ESM four bit flag register is associated with each
*  subdivision of each block and with each machine in the configuration.
*  Each subdivision will be large enough to accomodate 4096 bytes of
*  command/response data, and from 16384 to 262144 bytes of file page data
*  depending on configuration parameters, and 24 bytes of "header" information
*  create by the PP driver (ESMD).
*
*  Each mainframe identifies itself and all other mainframes by a machine id
*  number assigned when the file server system configuration is defined. Each PP
*  is informed of it's own (source) machine id number via the queue directory
*  header record source id number field, and of the other mainframe's machine id
*  numbers which are specified in each driver queue header destination id number
*  field. The machine id number is a value of from one to "MAXIDN". The first
*  block of ESM memory belongs to machine id number one, the second to machine
*  id number two, etc. The subdivisions of a block provide a pool of ESM
*  buffers. The availability of a subdivision is determined via the
*  corresponding ESM four bit flag register.
*
*  A mainframe's PP driver sends to another mainframe by reserving a subdivision
*  of the ESM memory block belonging to the mainframe it is sending to, writing
*  the message data into ESM memory, and then indicating that the block's
*  subdivision is full. A mainframe's PP driver always receives (inputs) from
*  the ESM block which corresponds to it's (source) id number. The ESM four bit
*  flag register associated with each ESM memory block subdivision is the
*  mechanism which provides the 'reserved' and 'full' indications. The sending
*  PP sets the indicators, the receiving PP clears them. Any contention for
*  the same four bit flag register by multiple senders is resolved by ESM.
          EJECT
** ILLUSTRATION OF A TWO MACHINE FILE SERVER CONFIGURATION.
*
*       MACHINE ID NO. 1                         MACHINE ID NO. 2                      .
*   .........................               .........................
*  .      CLIENT SIDE        .             .       SERVER SIDE       .
* .                           .           .                           .
* ******************             *******             ******************
* *CLIENT TO SERVER*    *****    * ESM *    *****    *SERVER TO CLIENT*
* * ID NO.2 QUEUE  *  <---<-----<-------<-----<---<  * ID NO.1 QUEUE  *
* *----------------* /  * E *    *BLK 1*    * E *  \ *----------------*
* * QUEUE ENTRY 1  */   * S *    *     *    * S *   \* QUEUE ENTRY 1  *
* *----------------*\   * M *    *-----*    * M *   /*----------------*
* * QUEUE ENTRY 2  * \  * D *    *     *    * D *  / * QUEUE ENTRY 2  *
* *----------------*  \ *   *    * ESM *    *   * /  *----------------*
* *----------------*   >-->----->------->----->-->   *----------------*
* * QUEUE ENTRY N  *    *****    *BLK 2*    *****    * QUEUE ENTRY N  *
* ******************             *******             ******************
*
*
*  There are eight low speed ports on the ESM hardware, and each mainframe's PP
*  driver requires low speed port access to ESM. This limits an ESM connected
*  file server configuration to a maximum of eight mainframes. The maximum
*  number of subdivisions has been arbitrarily set at "MAXDIV", any real
*  limitation would be a function of ESM memory size.
          EJECT
** NOS/VE FILE SERVER / ESMD PP DRIVER INTERFACE.
*
*  ESMD utilizes the standard NOS/VE IOU interface tables. The PP interface
*  table (PIT) is used by ESMD as any typical NOS/VE PP driver uses it. The PIT
*  provides support of PP requests and information about the PP response buffer.
*  The difference between ESMD and typical NOS/VE PP drivers is in the request
*  queueing scheme. Instead of the unit interface table 'RMA of next request'
*  field pointing to the top of a unit request queue, for ESMD the same field is
*  the RMA of the file server 'queue interface table'.
*
*  The queue interface table contains information about -
*         1. the 'request buffer' - a circular buffer of entries
*            stored by file server CPU routines. each entry consists
*            of a queue index and queue entry index.
*         2. 'ESM base address' record - which defines the number of
*            mainframes in the ESM file server configuration, and
*            parameters used by ESMD to determine the allocation of
*            ESM among the mainframes.
*         3. the 'queue directory' - a table of 'driver queue' RMA's
*            indexed by queue index. the queue directory header
*            contains information about the number of driver queues
*            pointed to by the directory, and parameters for ESMD
*            initialization.
*
*  Each driver queue consists of -
*         1. a 'queue header' - which defines the queue type
*            ('client to server' or 'server to client'), number of
*            queue entries contained in the queue, and the machine
*            id number and queue index which this queue is connected
*            to in the file server configuration.
*         2. from 1 to 127 'queue entries' - each of which contain
*            control, command, and event/status flags, RMA's of the
*            preallocated send and receive buffers, and the RMA of a
*            list of from 1 to 4 RMA's of send/receive buffers.
*
*  The request buffer serves as the ESMD request queue. A file server task
*  obtains a queue entry, sets the appropriate command flags and RMA's, stores
*  file server command/response and/or page data in the buffers, and arranges
*  for the queue index/queue entry index to be placed in the next available
*  request buffer entry.
*
*  The request buffer entries are stored on a first come first served basis.
*  The request buffer is a circular buffer, the 'in' offset is an index to the
*  next available slot. the 'out' offset, used and advanced by ESMD, is an index
*  to the next entry to be processed.
*
*  When ESMD determines that the task (which owns the queue entry) is needed to
*  process the results of the request, a response is written to the PP response
*  buffer. The file server PP response processor will located and activate the
*  file server task.
          EJECT
** DRIVER QUEUE HEADER DEFINITION.
*
* DRIVER QUEUE HEADER -
*       *-------------------------------------------------------*
*    1  * I           *  INT/PORT   *             *     NQE     *
*       *-------------------------------------------------------*
*    2  * S           *    SIDN     *             * SQI    SQEI *
*       *-------------------------------------------------------*
*    3  * S           *    DIDN     *             * DQI    DQEI *
*       *-------------------------------------------------------*
*    4  *             *             *             *             *
*       *-------------------------------------------------------*
*
*       CM word 1 -
*         I        = Boolean, TRUE if queue is IDLE.
*         INT/PORT = Interrupt selection and port number.
*         NQE      = Number of queue entries in this queue.
*       CM word 2 -
*         S        = Boolean, TRUE if queue type is SERVER TO CLIENT.
*         SIDN     = Source machine id number.
*         SQI      = Source queue index.
*         SQEI     = Source queue entry index.
*       CM word 3 -
*         S        = Boolean, TRUE if queue type is SERVER TO CLIENT.
*         DIDN     = Destination machine id number.
*         DQI      = Destination queue index.
*         DQEI     = Destination queue entry index.
*       CM word 4 - (unused driver queue header word)
*
*       ESM Header -
*         The ESM header is derived from CM words 2 and 3 of the
*         driver queue header plus one additional CM word.
*       *-------------------------------------------------------*
*    1  * S           *    SIDN     *             * SQI    SQEI *
*       *-------------------------------------------------------*
*    2  * S           *    DIDN     *             * DQI    DQEI *
*       *-------------------------------------------------------*
*    3  *    FLAGS    *    SPMSG    *     WCB     *     WCD     *
*       *-------------------------------------------------------*
*
*       CM word 1 - Same as driver queue header CM word 2.
*       CM word 2 - Same as driver queue header CM word 3.
*       CM word 3 -
*         FLAGS    = identify special message types
*                    ERR - special message is error condition code.
*                    INQ - special message is Inquiry message.
*         SPMSG    = the special message value.
*         WCB      = CM word count of buffer data in ESM.
*         ECD      = CM word count of page data in ESM.

** QUEUE ENTRY FLAGS DEFINITION.
*
* Queue Entry Control Flags -
*  The queue entry control flags determine which file server component has
*  access to the queue entry. As a general rule the CPU component has access to
*  the queue entry as long as the subsystem action flag is true. The driver has
*  access to the queue entry as long as the subsystem action flag is false.
*  The active entry flag is set when the queue entry is assigned to a file
*  server task.
*
* ACTIVE ENTRY     - Set by subsystem when queue entry assigned.
*  'ACTIVE'          Cleared by subsystem when queue entry released.
*
* DRIVER ACTION    - Set by subsystem to indicate request is ready for driver.
*  'DRIVER'          Cleared by driver when request process.
*
* SUBSYSTEM ACTION - Set by dfp$process_server_response prior to task activate.
*  'SUBSYS'          Cleared by subsystem when queue entry released.
*
* PROCESS RESPONSE - Set by driver when server response written.
*  'PRORSP'          Cleared by dfp$process_server_response.
*
* ERROR ALERT      - Set by driver when error detected.
*  'ERRALT'          Cleared by subsystem when error processed.
*
*
* Driver Command Flags -
*  The queue entry "command" flags are set by the subsystem. These flags define
*  the action to be taken by the driver. The driver clears the command flag as
*  the specified action is executed.
*
* SEND BUFFER      - Set by subsystem to command driver to send
*  'SNDBUF'          data contained in preallocated send buffer.
*                    Cleared by driver after buffer data sent.
*
* SEND DATA        - Set by subsystem to command driver to send PAGE
*  'SNDDAT'          data at specified address (indirect option).
*                    Cleared by driver after page data sent.
*
* SEND DATA PROMPT - Set by subsystem to command driver to read
*  'SNDPMT'          page data (held over in ESM from previous request).
*                    Cleared by driver after held over page data read.
*
*
* Queue Entry Event/Status Flags -
*  The queue entry "event status" flags are set by the driver. These flags
*  indicate events which have occurred and allow the subsystem to determine the
*  state of the request. The subsystem clears these flags after recognition
*  and appropriate processing.
*
* BUFFER SENT      - Set by driver after data in preallocated
*  'BUFSNT'          send buffer is sent.
*                    Cleared by subsystem.
*
* DATA SENT        - Set by driver after page data at specified
*  'DATSNT'          address is sent (indirect option).
*                    Cleared by subsystem.
*
* BUFFER RECEIVED  - Set by driver after data received and stored
*  'BUFRCV'          in preallocated RECEIVE BUFFER.
*                    Cleared by subsystem.
*
* DATA RECEIVED    - Set by driver after page data received and
*  'DATRCV'          stored at specified address (indirect option).
*                    Cleared by subsystem
          EJECT
**  PP RESPONSE DECISION TABLE.
*  ESMD knows nothing of the contents of the data passed between the mainframes
*  in a file server configuration, however, queue type and buffer type sent or
*  received are used by ESMD to enforce file server subsystem/ESMD protocol
*  rules which define when ESMD will store a PP response buffer entry.
*
*   ALERT SUBSYSTEM VIA PP RESPONSE BUFFER ENTRY -
*
*    *--------------------------------------------------------*
*    * DRIVER SETS    *    STORE PP RESPONSE BUFFER ENTRY     *
*    * CURRENT EVENT  * CLIENT TO SERVER  * SERVER TO CLIENT  *
*    *  FLAGS         *   QUEUE ENTRY     *   QUEUE ENTRY     *
*    *--------------------------------------------------------*
*    * BUFSNT = TRUE  *        NO         *       NO          *
*    * DATSNT = FALSE *                   * CLEAR QUEUE ENTRY *
*    *--------------------------------------------------------*
*    * BUFSNT = TRUE  *        NO         *       YES         *
*    * DATSNT = TRUE  *                   *                   *
*    *--------------------------------------------------------*
*    * BUFSNT = FALSE *        NO         *       YES         *
*    * DATSNT = TRUE  *                   *                   *
*    *--------------------------------------------------------*
*    * BUFRCV = TRUE  *        YES        *       YES         *
*    * DATRCV = FALSE *                   *                   *
*    *--------------------------------------------------------*
*    * BUFRCV = TRUE  *        YES        *       YES         *
*    * DATRCV = TRUE  *                   *                   *
*    *--------------------------------------------------------*
*    * BUFRCV = FALSE *        YES        *       YES         *
*    * DATRCV = TRUE  *                   *                   *
*    *--------------------------------------------------------*
*    * DRVERR = TRUE  *        YES        *       YES         *
*    * ALL OTHERS N/A *                   *                   *
*    *--------------------------------------------------------*
          EJECT
*** PROTOCOL EXAMPLES.
*
** KEY -
*   C = client task
*   D = PP driver ESMD
*   S = server task
*
*   The character '<' and '>' represent arrows indicating which program is
*   writing or reading the four bit flag registers.
*   NOTE - The SUBSYS ACTION flag is shown here as being set by the PP driver
*          when in fact it is set by dfp$process_server_response just prior
*          to task activation.
*
*
** I. Write Page Request
*    (to SERVER without page space pre-allocated)
*
* /------- CLIENT SIDE ----------------\ /---------------- SERVER SIDE -------\
*      CLIENT TO SERVER QE         ESM  .  ESM         SERVER TO CLIENT QE
*   --------.-------.--------     FLAGS . FLAGS     --------.-------.--------
*    QUEUE  .DRIVER . EVENT       ----- . -----      QUEUE  .DRIVER . EVENT
* S  CONTROL.COMMAND. STATUS      D R R . D R R      CONTROL.COMMAND. STATUS  S
* U --------.-------.--------     A E E . A E E     --------.-------.-------- U
* B  A D S D.S S U S.B D B D      T A S . T A S      A D S D.S S U S.B D B D  B
* S  C R U R.N N N N.U A U A   D  A D E . A D E  D   C R U R.N N N N.U A U A  S
* Y  T I B V.D D U D.F T F T   R  H Y R . H Y R  R   T I B V.D D U D.F T F T  Y
* S  I V S E.B D S P.S S R R   I  E   V . E   V  I   I V S E.B D S P.S S R R  S
* T  V E Y R.U A E M.N N C C   V  L   E . L   E  V   V E Y R.U A E M.N N C C  T
* E  E R S R.F T D T.T T V V   E  D   D . D   D  E   E R S R.F T D T.T T V V  E
* M --------.-------.--------  R  ----- . -----  R   -------.-------.-------- M
*           .       .                   .                   .       .
* C> 1 0 0 0 0 0 0 0 0 0 0 0                         1 0 0 0 0 0 0 0 0 0 0 0
* C> 1 1 0 0 1 1 0 0 0 0 0 0
*                              D--------> 0 1 1  D>  1 0 1 0 0 0 0 0 0 0 1 0
*    1 0 0 0 0 0 0 0 1 1 0 0  <D          1 0 1 <D
*                                                             RESPONSE ------>S
*
*                                                    1 1 0 0 0 0 0 1 0 0 0 0 <S
*                                         1 0 1  D>  1 0 1 0 0 0 0 0 0 0 0 1
*                                         0 0 0 <D
*                                                             RESPONSE ------>S
*
*                                                    1 1 0 0 1 0 0 0 0 0 0 0 <S
*    1 0 1 0 0 0 0 0 1 1 1 0  <D  0 1 1 <--------D
*                              D> 0 0 0          D>  1 0 0 0 0 0 0 0 0 0 0 0
* C<------- RESPONSE
*
* C> 0 0 0 0 0 0 0 0 0 0 0 0
          EJECT
** II. Write Page Request
*      (to SERVER with page space pre_allocated)
*
* /------- CLIENT SIDE ----------------\ /---------------- SERVER SIDE -------\
*      CLIENT TO SERVER QE         ESM  .  ESM         SERVER TO CLIENT QE
*   --------.-------.--------     FLAGS . FLAGS     --------.-------.--------
*    QUEUE  .DRIVER . EVENT       ----- . -----      QUEUE  .DRIVER . EVENT
* S  CONTROL.COMMAND. STATUS      D R R . D R R      CONTROL.COMMAND. STATUS  S
* U --------.-------.--------     A E E . A E E     --------.-------.-------- U
* B  A D S D.S S U S.B D B D      T A S . T A S      A D S D.S S U S.B D B D  B
* S  C R U R.N N N N.U A U A   D  A D E . A D E  D   C R U R.N N N N.U A U A  S
* Y  T I B V.D D U D.F T F T   R  H Y R . H Y R  R   T I B V.D D U D.F T F T  Y
* S  I V S E.B D S P.S S R R   I  E   V . E   V  I   I V S E.B D S P.S S R R  S
* T  V E Y R.U A E M.N N C C   V  L   E . L   E  V   V E Y R.U A E M.N N C C  T
* E  E R S R.F T D T.T T V V   E  D   D . D   D  E   E R S R.F T D T.T T V V  E
* M --------.-------.--------  R  ----- . -----  R   -------.-------.-------- M
*           .       .                   .                   .       .
* C> 1 0 0 0 0 0 0 0 0 0 0 0                         1 0 0 0 0 0 0 0 0 0 0 0
* C> 1 1 0 0 1 1 0 0 0 0 0 0
*                              D--------> 0 1 1  D>  1 0 1 0 0 0 0 0 0 0 1 1
*    1 0 0 0 0 0 0 0 1 1 0 0  <D          0 0 0 <D
*                                                             RESPONSE ------>S
*
*                                                    1 1 0 0 1 0 0 0 0 0 0 0 <S
*    1 0 0 1 0 0 0 0 1 1 1 0  <D  0 1 1 <--------D
*                              D> 0 0 0          D>  1 0 0 0 0 0 0 0 0 0 0 0
* C<------- RESPONSE
*
* C> 0 0 0 0 0 0 0 0 0 0 0 0
          EJECT
** III. Read Page Request
*       (from SERVER, page space pre_allocated)
*
* /------- CLIENT SIDE ----------------\ /---------------- SERVER SIDE -------\
*      CLIENT TO SERVER QE         ESM  .  ESM         SERVER TO CLIENT QE
*   --------.-------.--------     FLAGS . FLAGS     --------.-------.--------
*    QUEUE  .DRIVER . EVENT       ----- . -----      QUEUE  .DRIVER . EVENT
* S  CONTROL.COMMAND. STATUS      D R R . D R R      CONTROL.COMMAND. STATUS  S
* U --------.-------.--------     A E E . A E E     --------.-------.-------- U
* B  A D S D.S S U S.B D B D      T A S . T A S      A D S D.S S U S.B D B D  B
* S  C R U R.N N N N.U A U A   D  A D E . A D E  D   C R U R.N N N N.U A U A  S
* Y  T I B V.D D U D.F T F T   R  H Y R . H Y R  R   T I B V.D D U D.F T F T  Y
* S  I V S E.B D S P.S S R R   I  E   V . E   V  I   I V S E.B D S P.S S R R  S
* T  V E Y R.U A E M.N N C C   V  L   E . L   E  V   V E Y R.U A E M.N N C C  T
* E  E R S R.F T D T.T T V V   E  D   D . D   D  E   E R S R.F T D T.T T V V  E
* M --------.-------.--------  R  ----- . -----  R   -------.-------.-------- M
*           .       .                   .                   .       .
* C> 1 0 0 0 0 0 0 0 0 0 0 0                         1 0 0 0 0 0 0 0 0 0 0 0
* C> 1 1 0 0 1 0 0 0 0 0 0 0
*                              D--------> 0 1 1  D>  1 0 1 0 0 0 0 0 0 0 1 0
*    1 0 0 0 0 0 0 0 1 0 0 0  <D          0 0 0 <D
*                                                             RESPONSE ------>S
*
*                                                    1 1 0 0 1 1 0 0 0 0 0 0 <S
*    1 0 1 0 0 0 0 0 1 0 1 1  <D  0 1 1 <--------D
*                              D> 0 0 0          D>  1 0 1 0 0 0 0 0 1 1 0 0
* C<------- RESPONSE                                          RESPONSE ------>S
*
* C> 0 0 0 0 0 0 0 0 0 0 0 0                         1 0 0 0 0 0 0 0 0 0 0 0 <S
          EJECT
** IV. Read Page Request
*      (from SERVER, page space not pre-allocated)
*
* /------- CLIENT SIDE ----------------\ /---------------- SERVER SIDE -------\
*      CLIENT TO SERVER QE         ESM  .  ESM         SERVER TO CLIENT QE
*   --------.-------.--------     FLAGS . FLAGS     --------.-------.--------
*    QUEUE  .DRIVER . EVENT       ----- . -----      QUEUE  .DRIVER . EVENT
* S  CONTROL.COMMAND. STATUS      D R R . D R R      CONTROL.COMMAND. STATUS  S
* U --------.-------.--------     A E E . A E E     --------.-------.-------- U
* B  A D S D.S S U S.B D B D      T A S . T A S      A D S D.S S U S.B D B D  B
* S  C R U R.N N N N.U A U A   D  A D E . A D E  D   C R U R.N N N N.U A U A  S
* Y  T I B V.D D U D.F T F T   R  H Y R . H Y R  R   T I B V.D D U D.F T F T  Y
* S  I V S E.B D S P.S S R R   I  E   V . E   V  I   I V S E.B D S P.S S R R  S
* T  V E Y R.U A E M.N N C C   V  L   E . L   E  V   V E Y R.U A E M.N N C C  T
* E  E R S R.F T D T.T T V V   E  D   D . D   D  E   E R S R.F T D T.T T V V  E
* M --------.-------.--------  R  ----- . -----  R   -------.-------.-------- M
*           .       .                   .                   .       .
* C> 1 0 0 0 0 0 0 0 0 0 0 0                         1 0 0 0 0 0 0 0 0 0 0 0
* C> 1 1 0 0 1 0 0 0 0 0 0 0
*                              D--------> 0 1 1  D>  1 0 1 0 0 0 0 0 0 0 1 0
*    1 0 0 0 0 0 0 0 1 0 0 0  <D          0 0 0 <D
*                                                             RESPONSE ------>S
*
*                                                    1 1 0 0 1 1 0 0 0 0 0 0 <S
*    1 0 1 0 0 0 0 0 1 0 1 0  <D  0 1 1 <--------D
*                              D> 1 0 1          D>  1 0 1 0 0 0 0 0 1 1 0 0
* C<------- RESPONSE                                          RESPONSE ------>S
*
*                                                    1 0 0 0 0 0 0 0 0 0 0 0 <S
* C> 1 1 0 0 0 0 0 1 0 0 0 0
*    1 0 0 0 0 0 0 0 0 0 0 1  <D  1 0 1
*                              D> 0 0 0
* C<------- RESPONSE
*
* C> 0 0 0 0 0 0 0 0 0 0 0 0
          EJECT
** V. Attach File Request
*     (or any exchange message type request)
*
* /------- CLIENT SIDE ----------------\ /---------------- SERVER SIDE -------\
*      CLIENT TO SERVER QE         ESM  .  ESM         SERVER TO CLIENT QE
*   --------.-------.--------     FLAGS . FLAGS     --------.-------.--------
*    QUEUE  .DRIVER . EVENT       ----- . -----      QUEUE  .DRIVER . EVENT
* S  CONTROL.COMMAND. STATUS      D R R . D R R      CONTROL.COMMAND. STATUS  S
* U --------.-------.--------     A E E . A E E     --------.-------.-------- U
* B  A D S D.S S U S.B D B D      T A S . T A S      A D S D.S S U S.B D B D  B
* S  C R U R.N N N N.U A U A   D  A D E . A D E  D   C R U R.N N N N.U A U A  S
* Y  T I B V.D D U D.F T F T   R  H Y R . H Y R  R   T I B V.D D U D.F T F T  Y
* S  I V S E.B D S P.S S R R   I  E   V . E   V  I   I V S E.B D S P.S S R R  S
* T  V E Y R.U A E M.N N C C   V  L   E . L   E  V   V E Y R.U A E M.N N C C  T
* E  E R S R.F T D T.T T V V   E  D   D . D   D  E   E R S R.F T D T.T T V V  E
* M --------.-------.--------  R  ----- . -----  R   -------.-------.-------- M
*           .       .                   .                   .       .
* C> 1 0 0 0 0 0 0 0 0 0 0 0                         1 0 0 0 0 0 0 0 0 0 0 0
* C> 1 1 0 0 1 0 0 0 0 0 0 0
*                              D--------> 0 1 1  D>  1 0 1 0 0 0 0 0 0 0 1 0
*    1 0 0 0 0 0 0 0 1 0 0 0  <D          0 0 0 <D
*                                                             RESPONSE ------>S
*
*                                                    1 1 0 0 1 0 0 0 0 0 0 0 <S
*    1 0 1 0 0 0 0 0 1 0 1 0  <D  0 1 1 <--------D
*                              D> 0 0 0          D>  1 0 0 0 0 0 0 0 0 0 0 0
* C <------ RESPONSE
*
* C> 0 0 0 0 0 0 0 0 0 0 0 0
          EJECT
          TITLE  MACRO DEFINITIONS
*** COMMON DECKS
*
*COPYC IODMAC1    "RECORD DEFINITION MACROS"
*COPYC IODMAC2    "LOAD/STORE MACROS"
*COPYC IODMAC3    "GENERAL MACROS"
*COPYC IODMAC4    "GENERAL MACROS"
          SPACE  4,13
*** LOCAL MACROS.
** NAME-- PAGEIO.
*
** PURPOSE-- DEFINE RETURN JUMP TO *CIO* INSTRUCTIONS SO THAT
*            LOCATIONS CAN BE SAVED IN A TABLE.

PAGEIO    MACRO
          LOCAL  TAG
 TAG      RJM    CIO
 TCIO     RMT
          CON    TAG+1
          RMT
PAGEIO    ENDM
          SPACE  4,10
** NAME-- RECOVER.
*
** PURPOSE-- CALLS SUBROUTINE 'ENG' TO BUILD ENGINEERING ERROR LOG RESPONSE
*            AND DETERMINE IF RECOVERY MAY BE ATTEMPTED.
*

RECOVER   MACRO  TAG
          RJM    ENG
          LJM    TAG
RECOVER   ENDM
          TITLE  TABLE RECORD DEFINITIONS
*
* PP TABLE.
*
 PT       RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 PART     PPWORD             PARTNER PP NUMBER
 PIT      RMA                PP INTERFACE TABLE ADDRESS (RMA)
 PITPVA   STRUCT 24          PP INTERFACE TABLE ADDRESS (PVA)

 PT       RECEND
          SPACE  6
*
* PP INTERFACE TABLE.
*
 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
          ALIGN  0,64
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER
          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)
          ALIGN  32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          EJECT
*
* UNIT DESCRIPTORS.
*
 UD       RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 UD       RECEND
          SPACE  6
*
* UNIT INTERFACE TABLE.
*
 UIT      RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
                               = 400B, 844-4X
                               = 401B, 885-1X
                               = 402B, 885-42
 QCNT     PPWORD             QUEUE COUNT
*
          ALIGN  16,64
 UBUFL    PPWORD             UNIT COMMUNICATION BUFFER LENGTH
 UBUF     RMA                UNIT COMMUNICATION BUFFER (RMA)
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

 UIT      RECEND
          EJECT

******* QUEUE INTERFACE TABLE ************************************
*
*   REQUEST BUFFER DIRECTORY.

 RBD      RECORD PACKED

          ALIGN  48,64
 IN       PPWORD             REQUEST BUFFER IN OFFSET

          ALIGN  48,64
 OUT      PPWORD             REQUEST BUFFER OUT OFFSET

          ALIGN  48,64
 LIMIT    PPWORD             REQUEST BUFFER LIMIT OFFSET

          ALIGN  32,64
 RBRMA    RMA                REQUEST BUFFER RMA

          ALIGN  16,64
 RBPVA    STRUCT 6           REQUEST BUFFER PVA

 RBD      RECEND

*
*   ESM BASE ADDRESSES.
*    THIS RECORD IS CONTAINED WITHIN THE QUEUE INTERFACE TABLE

 ESM      RECORD PACKED
          ALIGN  0,64
 NMACH    PPWORD             NUMBER OF MACHINES
 NDIVS    PPWORD             NUMBER OF DIVISIONS PER MACHINE
 BFLGA    PPWORD             BASE ESM FLAG REGISTER ADDRESS
 BMEMA    PPWORD             UPPER BITS OF BASE ESM MEMORY ADDRESS / 100(8)
          PPWORD             LOWER 16 BITS OF BASE ESM MEMORY ADDRESS / 100(8)
 DIVSZ    PPWORD             ESM DIVISION SIZE IN 60 BIT ESM WORDS / 100(8)
 D12CW    PPWORD             ESM DIVISION SIZE IN 12 BIT CHANNEL WORDS / 100(8)
 D16CW    PPWORD             ESM DIVISION SIZE IN 16 BIT CHANNEL WORDS / 100(8)

 ESM      RECEND

*
*   MAXIMUM_DATA_BYTES.
*

 MXB      RECORD PACKED
          ALIGN  0,64
          INTEGER            MAXIMUM ESM DATA RECORD BYTES
 MXB      RECEND

*
*   QUEUE DIRECTORY HEADER.
*

 QDH      RECORD PACKED
 DMASND   BOOLEAN            DMA ENHANCED CY170 ADAPTER PRESENT ON SEND CHANNEL
 DMARCV   BOOLEAN            DMA ENHANCED CY170 ADAPTER PRESENT ON RECV CHANNEL
 IOUMI0   BOOLEAN            IOU MODEL I0 (CYBER 930)

          ALIGN  16,64
 SNDPP    PPWORD             PP NUMBER TO PROCESS REQUEST BUFFER (SEND)
 RCVPP    PPWORD             PP NUMBER TO PROCESS ESM SOURCE FLAGS (RECEIVE)
 FILL1    PPWORD             UNUSED

 FILL2    PPWORD             UNUSED
 FILL3    PPWORD             UNUSED
 SIDN     PPWORD             SOURCE IDENTIFICATION NUMBER
 NQDE     PPWORD             NUMBER OF QUEUE DIRECTORY ENTRIES

 QDH      RECEND

*
* QUEUE DIRECTORY ENTRY.
*

 QDE      RECORD PACKED

          ALIGN 32,64
 DQRMA    RMA                DRIVER QUEUE RMA

 QDE      RECEND

** QUEUE INTERFACE TABLE RECORD OFFSETS **

 QIT.RBD  EQU    0               OFFSET TO REQUEST BUFFER DIRECTORY
 QIT.ESM  EQU    C.RBD           OFFSET TO ESM BASE ADDRESSES
 QIT.MXB  EQU    QIT.ESM+C.ESM   OFFSET TO MAXIMUM DATA BYTES
 QIT.QDH  EQU    QIT.MXB+C.MXB   OFFSET TO QUEUE DIRECTORY HEADER
 QIT.QDE  EQU    QIT.QDH+C.QDH   OFFSET TO QUEUE DIRECTORY ENTRIES

******************************************************************

*
* REQUEST BUFFER ENTRY.
*

 RBE     RECORD PACKED

 PRV      BOOLEAN            PREVIOUSLY PROCESSED FLAG
 INQ      BOOLEAN            INQUIRY MESSAGE FLAG
          ALIGN  16,64
          PPWORD             (NOT USED)
 SPMSG    PPWORD             SPECIAL MESSAGE (STATE INQUIRY)
 QI       CHARC              QUEUE INDEX
 QEI      CHARC              QUEUE ENTRY INDEX

 RBE     RECEND
FSSR     EJECT
*
* FILE SERVER SPECIAL RESPONSE.
*

 FSSR     RECORD PACKED
 SRFL     PPWORD             SPECIAL RESPONSE FLAGS AND LENGTH WORD
*   SR       BOOLEAN            SPECIAL RESPONSE
*   SW       BOOLEAN            SINGLE WORD RESPONSE
*   ERR      BOOLEAN            ERROR RESPONSE
*   INQ      BOOLEAN            INQUIRY MESSAGE RESPONSE
*   TPR      BOOLEAN            TERMINATION PSEUDO RESPONSE (NEVER SET BY PP)
*   ENG      BOOLEAN            ENGINEERING ERROR LOG RESPONSE
*            ALIGN  8,64
*   LEN      CHARC              SPECIAL RESPONSE LENGTH IN BYTES
 SRPAR    PPWORD             SPECIAL RESPONSE PARAMETERS (ERROR OR INQUIRY)
 LUN      PPWORD             LOGICAL UNIT
 QI       CHARC              QUEUE INDEX
 QEI      CHARC              QUEUE ENTRY INDEX

 FSSR     RECEND

*
* FILE SERVER ENGINEERING ERROR LOG PP RESPONSE RECORD.
*

 ENGRSP   RECORD PACKED

          ALIGN  0,64
 URE      BOOLEAN            UNRECOVERED ERROR
 ADP      BOOLEAN            C170 DMA ADAPTER DRIVER MODE
 DIO      BOOLEAN            ERROR OCCURRED WHILE EXECUTING IN *DIO*
 TRL      BOOLEAN            FIRST T REGISTER LOAD SUCCESSFUL
          ALIGN  8,64
 CNT      STRUCT 1           RETRY ATTEMPT COUNT
 ERR      PPWORD             INITIAL FAILURE CONDITION CODE
 LCF      PPWORD             LAST FUNCTION ISSUED ON CHANNEL PRIOR TO FAILURE
 LPF      PPWORD             ICI/ESM LOW SPEED PORT FUNCTION

          ALIGN  0,64
 LPS      PPWORD             ESM LOW SPEED PORT STATUS
 ADR      PPWORD             ESM ADDRESS (UPPER BITS)
          PPWORD             ESM ADDRESS (LOWER BITS)
 RBC      PPWORD             RESIDUAL CHANNEL WORD COUNT AFTER BLOCK I/O INST.

          ALIGN  0,64
 XBC      PPWORD             TRANSFER BYTE COUNT
 TRC      PPWORD             CY170 DMA ADAPTER 'T' REGISTER BYTE COUNT
          PPWORD             CY170 DMA ADAPTER 'T' REGISTER MSB CM ADDRESS
          PPWORD             CY170 DMA ADAPTER 'T' REGISTER LSB CM ADDRESS

          ALIGN  0,64
 ADF      PPWORD             CY170 DMA ADAPTER FUNCTION CODE
 CRC      PPWORD             CY170 DMA ADAPTER CONTROL REGISTER
 AES      PPWORD             CY170 DMA ADAPTER ERROR STATUS REGISTER
 OPS      PPWORD             CY170 DMA ADAPTER OPERATIONAL STATUS REGISTER

          ALIGN  0,64
          PPWORD             (UNUSED)
 ITR      PPWORD             INITIAL CY170 DMA ADAPTER 'T' REGISTER BYTE COUNT
          PPWORD             INITIAL CY170 DMA ADAPTER 'T' REGISTER MSB CM ADRS
          PPWORD             INITIAL CY170 DMA ADAPTER 'T' REGISTER LSB CM ADRS

 ENGRSP   RECEND
          SPACE  6

*
* DRIVER QUEUE HEADER.
*

 DQH      RECORD PACKED

          ALIGN  0,64
 IDLE     BOOLEAN            DRIVER QUEUE IDLE FLAG
          ALIGN  16,64
 RECOV    SUBRANGE 0,3       (ERROR RECOVERY OPTIONS N/A)
                                0 - ATTEMPT RECOVERY
                                1 - SUPPRESS RECOVERY, TERMINATE WITH
                                     ABNORMAL STATUS.
                                2 - RESERVED FOR FUTURE USE.
                                3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                     IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU IF SET
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    (PRIORITY N/A)

          ALIGN  48,64
 NQE      PPWORD             NUMBER OF QUEUE ENTRIES

          ALIGN  0,64
 SQTYP    BOOLEAN            SOURCE QUEUE TYPE SERVER TO CLIENT IF SET
          ALIGN  16,64
 SIDN     PPWORD             SOURCE IDENTIFICATION NUMBER
 FILL1    PPWORD             FILL
 SQI      CHARC              SOURCE QUEUE INDEX
 SQEI     CHARC              SOURCE QUEUE ENTRY INDEX

          ALIGN  0,64
 DQTYP    BOOLEAN            DESTINATION QUEUE TYPE SERVER TO CLIENT
          ALIGN  16,64
 DIDN     PPWORD             DESTINATION IDENTIFICATION NUMBER
 FILL2    PPWORD             FILL
 DQI      CHARC              DESTINATION QUEUE INDEX
 DQEI     CHARC              DESTINATION QUEUE ENTRY INDEX

 DQH      RECEND

*
* HEADER MESSAGE.
*         THIS RECORD IS APPENDED TO THE QUEUE HEADER
*         TO FORM THE ESM HEADER.

 HMSG     RECORD PACKED
 ERR      BOOLEAN            ERROR MESSAGE FLAG
 INQ      BOOLEAN            INQUIRY MESSAGE FLAG
          ALIGN  16,64
 SPMSG    PPWORD             SPECIAL MESSAGE (INQUIRY, OR ERROR)
 WCB      PPWORD             CM WORD COUNT OF DATA IN ESM BUFFER AREA
 WCD      PPWORD             CM WORD COUNT OF DATA IN ESM DATA AREA
 HMSG     RECEND

*
* DRIVER QUEUE ENTRY.
*
 DQE      RECORD PACKED

* QUEUE CONTROL FLAGS -
 ACTIVE   BOOLEAN            ACTIVE QUEUE ENTRY
 DRIVER   BOOLEAN            DRIVER ACTION
 SUBSYS   BOOLEAN            SYSTEM ACTION
 ERRALT   BOOLEAN            ERROR ALERT

* COMMAND FLAGS -
 SNDBUF   BOOLEAN            SEND BUFFER
 SNDDAT   BOOLEAN            SEND PAGE DATA
 FILL1    BOOLEAN            UNUSED
 SNDPMT   BOOLEAN            PROMPT FOR PAGE DATA

* EVENT STATUS FLAGS -
 BUFSNT   BOOLEAN            BUFFER SENT
 DATSNT   BOOLEAN            PAGE DATA SENT
 BUFRCV   BOOLEAN            BUFFER RECEIVED
 DATRCV   BOOLEAN            PAGE DATA RECEIVED

* RESERVED -
 FILL2    BOOLEAN            UNUSED
 FILL3    BOOLEAN            UNUSED
 PRORSP   BOOLEAN            PROCESS SERVER RESPONSE
 FILL5    BOOLEAN            UNUSED

 ERRCON   PPWORD             DRIVER DETECTED ERROR CONDITION
 HWCD     PPWORD             HELD OVER DATA WORD COUNT
 HDIV     PPWORD             HELD OVER DIVISION NUMBER (HELD OVER DATA)

 SIND     BOOLEAN            INDIRECT ADDRESS FLAG (DATA LIST IF SET)
          ALIGN  16,64
 SLEN     PPWORD             SEND BUFFER LENGTH
 SRMA     RMA                SEND BUFFER RMA

 RIND     BOOLEAN            INDIRECT ADDRESS FLAG (DATA LIST IF SET)
          ALIGN  16,64
 RLEN     PPWORD             RECEIVE BUFFER LENGTH
 RRMA     RMA                RECEIVE BUFFER RMA

 IND      BOOLEAN            INDIRECT ADDRESS FLAG (DATA LIST IF SET)
          ALIGN  16,64
 LEN      PPWORD             DATA/DATA LIST LENGTH
 RMA      RMA                DATA/DATA LIST RMA

 DQE      RECEND
          SPACE  6
*
* UNIT COMMUNICATION AREA.
*
 UCA      RECORD PACKED
 IN       PPWORD
 LIMIT    PPWORD
          ALIGN  0,64        RESERVED
 BID      STRUCT 32          SIXTEEN BLOCK ID ENTRIES

 UCA      RECEND
          SPACE  6
*
* PP REQUESTS.
*
 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS
                               0 - ATTEMPT RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
 LONGB    BOOLEAN            LONG INPUT BLOCK (LSB OF ALERT MASK)
          ALIGN  0,64
 SECADR   INTEGER            SECONDARY ADDRESS
 CMND     INTEGER            COMMAND SEQUENCE

 RQ       RECEND
          SPACE  6
*
* PP COMMAND.
*
 CM       RECORD PACKED

 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$

 CM       RECEND
          SPACE  6
*
* PP REQUEST RESPONSE.
*
 RS       RECORD PACKED

          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST

          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST

 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
 LONGB    BOOLEAN            LONG INPUT BLOCK (LSB OF ALERT MASK)

 ABNFL    PPWORD             ABNORMAL STATUS FLAGS
                               1XXX...X - INTERFACE ERROR
                               X1XX...X - FS ERROR
                               XX1X...X - FORCED TERMINATION, STOP UNIT
                               XXX1...X - PREMATURE TERMINATION, INPUT
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - NOT USED
                               1 - NOT USED
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
          ALIGN  40,64
          STRUCT 3           UNUSED

          ALIGN  0,64
 RXFERC   STRUCT 4           REQUESTED TRANSFER COUNT
 LASTC    RMA                LAST COMMAND RMA

          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$

 RS       RECEND

*
* ESM MEMORY ADDRESS RECORD.
* THIS RECORD IS CREATED AND USED BY THIS DRIVER PROGRAM.
*

 EMA      RECORD
 FRG      PPWORD             FLAG REGISTER ADDRESS
 HDR      PPWORD             UPPER 12 BITS OF HEADER AREA ADDRESS
          PPWORD             LOWER 12 BITS OF HEADER AREA ADDRESS
 BUF      PPWORD             UPPER 12 BITS OF BUFFER AREA ADDRESS
          PPWORD             LOWER 12 BITS OF BUFFER AREA ADDRESS
 DAT      PPWORD             UPPER 12 BITS OF DATA AREA ADDRESS
          PPWORD             LOWER 12 BITS OF DATA AREA ADDRESS
 EMA      RECEND
          TITLE  MISCELLANEOUS EQUATES
 MAXFCL   EQU    16          MAX FUNCTION CODE LENGTH = 16 BITS
 HEADLN   EQU    32          REQUEST HEADER LENGTH = 32 BYTES
 CMDLEN   EQU    4           I/O COMMAND LENGTH IN PP WORDS
 PITLEN   EQU    C.PIT+C.UD*MLUC LENGTH OF PP INTERFACE TABLE IN CM WORDS
 LENRS    EQU    40          PP'S RESPONSE BUFFER LENGTH IN BYTES

**        FOR CHANNEL TABLE.
*         CHANNEL VALUES (THE CHANNEL NUMBER IS INSERTED LATER).
*         (BIT 2**5 IS ONLY USED ON IAN AND DCN INSTRUCTIONS).

 CH00     EQU    00          WITHOUT CHANNEL BIT
 CH40     EQU    40B         WITH CHANNEL BIT
 CH14     EQU    14B         TAG FOR CHANNEL 14B
 MCH      EQU    17B         MAINTENANCE CHANNEL

** DST-DSP COMMUNICATIONS CHANNEL NUMBER.
*
 DSC      EQU    0           DST-DSP COMMUNICATIONS CHANNEL

*
**        PP COMMAND CODES.
*
 C.PC0    EQU    0           ACKNOWLEDGE
 C.PC1    EQU    1           STOP UNIT
 C.PC4    EQU    4           IDLE
 C.PC5    EQU    5           RESUME
 RSUMCMD  EQU    C.PC5       PP RESUME COMMAND

*
**        ESM MEMORY ALLOCATION.
*
 EHRDCM   EQU    3               SIZE OF HEADER IN 64 BIT CM WORDS
 EHRDES   EQU    EHRDCM*64/60+8  HEADER ESM WORDS PLUS ONE 8 WORD ESM RECORD
 EHRDSZ   EQU    EHRDES/8*8      SIZE OF HEADER AREA IN 60 BIT ESM WORDS

 EBUFCM   EQU    PAGSZ/8         SIZE OF BUFFER IN 64 BIT CM WORDS
 EBUFES   EQU    EBUFCM*64/60+8  BUFFER ESM WORDS PLUS ONE 8 WORD ESM RECORD
 EBUFSZ   EQU    EBUFES/8*8      SIZE OF BUFFER AREA IN 60 BIT ESM WORDS

 EBUFOF   EQU    EHRDSZ         BUFFER AREA OFFSET WITHIN DIVISION
          ERRNG  77B-EBUFOF     IF SUBROUTINE SEA MUST CHANGE TO SAVE OVERFLOW
 EDATOF   EQU    EHRDSZ+EBUFSZ  PAGE DATA AREA OFFSET WITHIN DIVISION
          TITLE  HARDWARE INTERFACE EQUATES.
** DMA ENHANCED CY170 ADAPTER FUNCTION CODES.
*         REF. CYBER 180
*              DMA ENHANCED CY170 ADAPTER
*              ENGINEERING SPECIFICATION NO. 22132530.

 FC.AMC   EQU    100000B     (8000H) ADAPTER MASTER CLEAR
 FC.CTR   EQU    101000B     (8200H) CLEAR 'T' REGISTERS
 FC.INP   EQU    102402B     (8500H) DMA INPUT / FAST TRANSFER / PP WC=2
 FC.OUT   EQU    103402B     (8702H) DMA OUTPUT / FAST TRANSFER / PP WC=2
 FC.CDM   EQU    104000B     (8800H) CLEAR DMA MODE
 FC.DTM   EQU    106000B     (8C00H) DISABLE TEST MODE
 FC.ETM   EQU    107000B     (8E00H) ENABLE TEST MODE
 FC.RCR   EQU    110000B     (9000H) READ CONTROL REGISTERS
 FC.WCR   EQU    111000B     (9200H) WRITE CONTROL REGISTERS
 FC.ESR   EQU    112000B     (9400H) READ ERROR STATUS REGISTER
 FC.OSR   EQU    114000B     (9800H) READ OPERATIONAL STATUS REGISTER
 FC.RTR   EQU    116000B     (9C00H) READ 'T' REGISTER
 FC.WTR   EQU    117000B     (9E00H) WRITE 'T' PRIME REGISTER

** ADAPTER OPERATIONAL STATUS REGISTER BIT MASKS.
 OS.XIP   EQU    0001B       TRANSFER IN PROGRESS
 OS.TRE   EQU    0002B       'T' PRIME REGISTER EMPTY
 OS.HLT   EQU    0004B       DMA TRANSFER HALTED
 OS.INP   EQU    0010B       DMA INPUT
 OS.OUT   EQU    0020B       DMA OUTPUT
 OS.PWZ   EQU    0040B       PP WORD COUNT EQUAL ZERO
 OS.TST   EQU    0100B       TEST MODE
 OS.CLW   EQU    0200B       EXTERNAL CLOCK PRESENT
 OS.FXM   EQU    0400B       FAST TRANSFER MODE
 OS.IDA   EQU    1000B       INPUT DATA AVAILABLE
 OS.IBF   EQU    2000B       INPUT BUFFER FULL
 OS.OBF   EQU    4000B       OUTPUT BUFFER FULL

** ADAPTER OPERATIONAL STATUS REGISTER BIT POSITION.
 OB.XIP   EQU    00D         TRANSFER IN PROGRESS
 OB.TRE   EQU    01D         'T' PRIME REGISTER EMPTY
 OB.HLT   EQU    02D         DMA TRANSFER HALTED
 OB.INP   EQU    03D         DMA INPUT
 OB.OUT   EQU    04D         DMA OUTPUT
 OB.PWZ   EQU    05D         PP WORD COUNT EQUAL ZERO
 OB.TST   EQU    06D         TEST MODE
 OB.CLW   EQU    07D         EXTERNAL CLOCK PRESENT
 OB.FXM   EQU    08D         FAST TRANSFER MODE
 OB.IDA   EQU    09D         INPUT DATA AVAILABLE
 OB.IBF   EQU    10D         INPUT BUFFER FULL
 OB.OBF   EQU    11D         OUTPUT BUFFER FULL

** CY930 ICI/C170 CONVERTER FUNCTION CODES.
*         REF. CYBER 930 (SO)
*              ENGINEERING SPECIFICATION NO. 19269753.
*              ENGINEERING SPECIFICATION NO. 19269663.

 ICI.DES  EQU    100000B     (8000H) DESELECT C170 CONVERTER
 ICI.CON  EQU    110000B     (9000H) SET CONVERTION MODE (12/16 PACK/UNPACK)
 ICI.12B  EQU    120000B     (A000H) SET 12 BIT MODE
 ICI.SSM  EQU    130000B     (B000H) SET STORNET SUBSYS MODE
 ICI.SEL  EQU    170000B     (F000H) SELECT C170 CONVERTER

*
** ESM PPU/LOW SPEED PORT FUNCTION CODES.
*         REF. CDC EXTENDED SEMICONDUCTOR MEMORY II (ESM II)
*              HARDWARE REFERENCE MANUAL NO. 60458590.

*  DATA CODES -
 FC.RED   EQU    5001B       READ ESM FUNCTION
 FC.FLG   EQU    FC.RED      FLAG FUNCTION
 FC.WRT   EQU    5002B       WRITE FUNCTION
 FC.STA   EQU    5004B       READ STATUS BITS FUNCTION
 FC.PMC   EQU    5010B       LOW SPEED PORT MASTER CLEAR

*  MODE SELECT CODES -
 FC.UBM   EQU    5401B       USE UPPER HALF BUFFER MEMORY
 FC.HST   EQU    5402B       ENABLE HIGH SPEED DATA TRANSFER
 FC.LBM   EQU    5601B       USE LOWER HALF BUFFER MEMORY
 FC.LST   EQU    5602B       DISABLE HIGH SPEED DATA TRANSFER

* ESM 4 BIT FLAG REGISTER FUNCTIONS.
 FF.ZSL   EQU    4600B       ZERO SELECT
 FF.SET   EQU    5400B       SELECTIVE SET
 FF.STA   EQU    6400B       STATUS
 FF.DER   EQU    6500B       DETECT ERROR STATUS
 FF.EQU   EQU    6600B       EQUALITY STATUS
 FF.CLR   EQU    7400B       SELECTIVE CLEAR

** ESM SUBDIVISION STATUS 4 BIT FLAG REGISTER BIT MASKS.
 FR.RSV   EQU    01B         ESM RESERVED
 FR.RDY   EQU    02B         ESM READY
 FR.HLD   EQU    04B         ESM HELD OVER PAGE DATA
 FR.XXX   EQU    10B         (NOT USED)

** ESM LOW SPEED PORT STATUS BIT MASKS.
 PS.ABT   EQU    0001B       ABORT
 PS.AOV   EQU    0002B       ADDRESS OVERFLOW IF ABORT BIT SET
 PS.DBE   EQU    0004B       DOUBLE BIT ERROR
 PS.WRT   EQU    0010B       BUSY WITH WRITE OPERATION
 PS.CPE   EQU    0020B       CHANNEL PARITY ERROR
 PS.MAP   EQU    0040B       MEMORY ADDRESS PARITY ERROR (STORNET ONLY)

          TITLE  FILE SERVER QUEUE ENTRY EQUATES.
**        QUEUE ENTRY FLAG MASKS.
*
* QUEUE CONTROL FLAGS -
 ACTIVE   EQU    100000B     ACTIVE QUEUE ENTRY
 DRIVER   EQU    040000B     DRIVER ACTION
 SUBSYS   EQU    020000B     SYSTEM ACTION
 ERRALT   EQU    010000B     ERROR ALERT

* COMMAND FLAGS -
 SNDBUF   EQU    004000B     SEND BUFFER
 SNDDAT   EQU    002000B     SEND PAGE DATA
*FILL1    EQU    001000B     UNUSED
 SNDPMT   EQU    000400B     PROMPT FOR PAGE DATA

* EVENT STATUS FLAGS -
 BUFSNT   EQU    000200B     BUFFER SENT
 DATSNT   EQU    000100B     PAGE DATA SENT
 BUFRCV   EQU    000040B     BUFFER RECEIVED
 DATRCV   EQU    000020B     PAGE DATA RECEIVED

* DRIVER STATUS FLAGS -
 PRORSP   EQU    000002B     PROCESS SERVER RESPONSE (RESULTS IN SUBSYS)

** REQUEST BUFFER ENTRY FLAG.
 RBE.PRV  EQU    100000B     PREVIOUSLY PROCESSED REQUEST BUFFER ENTRY FLAG
 RBE.INQ  EQU    040000B     INQUIRY MESSAGE REQUEST FLAG

**        SPECIAL RESPONSE FLAGS AND LENGTH WORD EQUATES.
*
* SPECIAL RESPONSE FLAGS EQUATES -
 SRF.SR   EQU    100000B     SPECIAL RESPONSE FLAG
 SRF.SW   EQU    040000B     SINGLE WORD RESPONSE FLAG
 SRF.ERR  EQU    020000B     ERROR RESPONSE FLAG
 SRF.INQ  EQU    010000B     INQUIRY MESSAGE RESPONSE FLAG
 SRF.TPR  EQU    004000B     PSEUDO TERMINATION (NEVER ISSUED BY DRIVER)
 SRF.ENG  EQU    002000B     ENGINEERING ERROR LOG RESPONSE FLAG

**        ESM HEADER FLAG EQUATES.
*
 HMF.ERR  EQU    100000B     SPECIAL MESSAGE FIELD OF HEADER IS ERROR CODE
 HMF.INQ  EQU    040000B     SPECIAL MESSAGE FIELD OF HEADER IS INQUIRY MESSAGE

**        ENGINEERING ERROR LOG RESPONSE FLAGS.
*
 ERF.URE  EQU    100000B     UNRECOVERED ERROR
 ERF.ADP  EQU    040000B     C170 DMA ADAPTER DRIVER MODE
 ERF.DIO  EQU    020000B     ERROR OCCURRED WHILE EXECUTING *DIO* SUBROUTINE
 ERF.TRL  EQU    010000B     FIRST T REGISTER LOAD SUCCESSFUL
          TITLE  REQUEST RESPONSE EQUATES.
*
**        RESPONSE CODES.
*
 R.NRM    EQU    100000B     NORMAL REQUEST TERMINATION
 R.ABN    EQU    140000B     ABNORMAL REQUEST TERMINATION

*
**        ABNORMAL STATUS FLAGS.
*
 ABN.IE   EQU    100000B     INTERFACE ERROR
 ABN.FE   EQU    040000B     FILE SERVER ERROR
 ABN.FT   EQU    020000B     FORCED TERMINATION - STOP UNIT N/A
 ABN.PT   EQU    010000B     PREMATURE TERMINATION ON INPUT N/A
          TITLE  ERROR CODES
**        FATAL HARDWARE FAILURE ERROR CODES.
 ER.BASE  EQU    0           FATAL HARDWARE FAILURE ERROR CODE BASE

 ER.FTO   EQU    ER.BASE+1   CHANNEL FUNCTION TIMEOUT ERROR
 ER.IPE   EQU    ER.BASE+2   IOU CHANNEL PARITY ERROR
 ER.CPE   EQU    ER.BASE+3   ESM DETECTED CHANNEL PARITY ERROR
 ER.DBE   EQU    ER.BASE+4   ESM DOUBLE BIT PARITY ERROR
 ER.MAP   EQU    ER.BASE+5   ESM MEMORY ADDRESS PARITY ERROR
 ER.ABT   EQU    ER.BASE+6   UNEXPECTED ABORT ON ESM FUNCTION
 ER.CME   EQU    ER.BASE+7   ADAPTER - DMA UNCORRECTED CM ERROR
 ER.CMR   EQU    ER.BASE+8   ADAPTER - CM REJECT
 ER.ICR   EQU    ER.BASE+9   ADAPTER - INVALID CM RESPONSE
 ER.CRP   EQU    ER.BASE+10  ADAPTER - CM RESPONSE CODE PARITY ERROR
 ER.CMI   EQU    ER.BASE+11  ADAPTER - CMI READ DATA PARITY ERROR
 ER.CLK   EQU    ER.BASE+12  ADAPTER - CLOCK FAULT
 ER.IBO   EQU    ER.BASE+13  ADAPTER - OVERFLOW ERROR
 ER.IER   EQU    ER.BASE+14  ADAPTER - INPUT ERROR
 ER.CVN   EQU    ER.BASE+15  ADAPTER - 12/16 CONVERSION ERROR
 ER.JYD   EQU    ER.BASE+16  ADAPTER - JY DATA ERROR
 ER.BAS   EQU    ER.BASE+17  ADAPTER - BAS PARITY ERROR
 ER.KZE   EQU    ER.BASE+18  ADAPTER - KZ BOARD ERROR
 ER.JYE   EQU    ER.BASE+19  ADAPTER - JY BOARD ERROR
 ER.KXE   EQU    ER.BASE+20  ADAPTER - KX BOARD ERROR
 ER.OVF   EQU    ER.BASE+21  OVERFLOW ESM ADDRESS ERROR
 ER.INA   EQU    ER.BASE+22  INACTIVE CHANNEL ERROR
 ER.HLT   EQU    ER.BASE+23  DMA XFER HALTED EARLY ERROR
 ER.DMT   EQU    ER.BASE+24  LOW SPEED PORT DEADMAN TIMEOUT
 ER.UU2   EQU    ER.BASE+25  (UNUSED)
 ER.UU3   EQU    ER.BASE+26  (UNUSED)
 ER.UU4   EQU    ER.BASE+27  (UNUSED)
 ER.UU5   EQU    ER.BASE+28  (UNUSED)
 ER.UU6   EQU    ER.BASE+29  (UNUSED)

**        SOFTWARE INTERFACE ERROR CODES.

 IE.E01   EQU    ER.BASE+30  INVALID COMMAND CODE
 IE.E02   EQU    ER.BASE+31  INVALID LENGTH SPECIFICATION IN COMMAND
 IE.E03   EQU    ER.BASE+32  INVALID ADDRESS SPECIFICATION IN COMMAND
 IE.E04   EQU    ER.BASE+33  INVALID LENGTH SPECIFICATION IN INDIRECT LIST
 IE.E05   EQU    ER.BASE+34  INVALID ADDRESS SPECIFICATION IN INDIRECT LIST
 IE.E06   EQU    ER.BASE+35  RESERVED FIELD IN INDIRECT LIST NOT 0
 IE.E07   EQU    ER.BASE+36  LOCKWORD ERROR
 IE.E08   EQU    ER.BASE+37  MISSING HOLD OVER INFORMATION IN QUEUE ENTRY
 IE.E09   EQU    ER.BASE+38  INVALID QUEUE INDEX
 IE.E10   EQU    ER.BASE+39  INVALID QUEUE ENTRY INDEX
 IE.E11   EQU    ER.BASE+40  INSUFFICIENT LENGTH SPECIFICATION ERROR
 IE.E12   EQU    ER.BASE+41  DRIVER ACTION FLAG NOT SET
 IE.E13   EQU    ER.BASE+42  DESTINATION MACHINE DOWN
 IE.E14   EQU    ER.BASE+43  QUEUE IDLE
 IE.E15   EQU    ER.BASE+44  INACTIVE QUEUE ENTRY
 IE.E16   EQU    ER.BASE+45  ZERO QUEUE REAL MEMORY ADDRESS
 IE.E17   EQU    ER.BASE+46  (UNUSED)
 IE.E18   EQU    ER.BASE+47  (UNUSED)
 IE.E19   EQU    ER.BASE+48  (UNUSED)
 IE.E20   EQU    ER.BASE+49  (UNUSED)

 OBSINQ   EQU    77B         OBSOLETE OR UNWANTED INQUIRY REQUEST ERROR

 ERCODM   EQU    67B         MASK FOR ERROR CODES

*
** ERROR CODE BASE.
*

 PITERR   EQU    1000B       PIT INTERFACE ERROR CODE BASE
 UITERR   EQU    1400B       UIT INTERFACE ERROR CODE BASE
 RQHERR   EQU    2000B       REQUEST HEADER INTERFACE ERROR CODE BASE
          TITLE  DIRECT CELLS
          CON    PRS-1       START OF PRESET (INITIALIZATION) ROUTINE

 T0       EQU    0
 T1       BSSZ   1           SCRATCH CELLS
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1
 T9       BSSZ   1
 T10      BSSZ   1
 T11      BSSZ   1

 SI       BSSZ   1           SOURCE ID NUMBER
 QI       BSSZ   1           QUEUE INDEX
 EI       BSSZ   1           QUEUE ENTRY INDEX
 QF       BSSZ   1           CURRENT COPY OF DRIVER QUEUE ENTRY FLAGS
 ID       BSSZ   1           SOURCE/DESTINATION ID NUMBER
 DI       BSSZ   1           SOURCE/DESTINATION ESM DIVISION NUMBER
 PS       BSSZ   1           ESM LOW SPEED PORT STATUS
 ER       BSSZ   1           ERROR CONDITION CODE

 WC       BSSZ   1           CM WORD COUNT
 P1       BSSZ   1
 P2       BSSZ   1
 P3       BSSZ   1
 P4       BSSZ   1

 CM       BSSZ   3           CENTRAL MEMORY ADDRESS
 TA       BSSZ   1           FORMA TEMPORARY ADDRESS

 RBLIM    BSSZ   1           REQUEST BUFFER LIMIT OFFSET IN CM WORDS
 RSLIM    BSSZ   1           RESPONSE BUFFER LIMIT OFFSET IN BYTES
 NDIVS    BSSZ   1           NUMBER OF ESM DIVISIONS PER MACHINE

 AI       BSSZ   1           DQENTR ADDRESS DESCRIPTOR INDEX
 LI       BSSZ   1           INDIRECT LIST INDEX IN PP WORDS
 LL       BSSZ   1           INDIRECT LIST LENGTH IN PP WORDS
 XC       BSSZ   1           CM WORD COUNT TO TRANSFER
 AC       BSSZ   1           ACTUAL I/O CM WORD COUNT
 RC       BSSZ   1           REQUESTED I/O CM WORD COUNT
 PC       BSSZ   1           CURRENT PAGE REMAINING LENGTH IN CM WORDS
 CC       BSSZ   1           CHANNEL WORD COUNT (12 OR 16 BIT)
 XBC      BSSZ   1           TRANSFER BYTE COUNT
 EMA      BSSZ   1           POINTER TO ESM ADDRESS LAST USED
 ELEC     BSSZ   1           ERROR LOG ENTRY CONDITION
 ENGPA    CON    ENGOFF      *ENG* SUBROUTINE PROCESSING ADDRESS

*         THE NEXT FIVE CELLS ARE USED BYE *RSP* AND MUST BE CONTIGUOUS.
*         TEMP STORAGE IS VALID UNTIL SUBROUTINE *RSP* EXECUTES.

 ET1      EQU    *           (TEMP STORAGE FOR SUBROUTINE *ENG*)
          BSSZ   1           (INP-3 = NEW IN POINTER IN BYTES)
 RB       EQU    *           (TEMP RESIDUAL BYTE COUNT IN 'A' REG AFTER I/O)
          BSSZ   1           (INP-2 = TOTAL RESPONSE LENGTH IN CM WORDS)
          BSSZ   1           (INP-1 = CURRENT IN POINTER IN CM WORDS)
 INP      BSSZ   1           CURRENT RESPONSE BUFFER IN POINTER IN BYTES
 OUTP     BSSZ   1           PP RESPONSE BUFFER OUT POINTEIN BYTES

*         REFORMATTED REAL MEMORY ADDRESSES
 CM.PIT   BSSZ   3           CMA OF PP INTERFACE TABLE
 CM.RBI   BSSZ   3           CMA OF REQUEST BUFFER 'IN' POINTER
 CM.QIT   EQU    CM.RBI      CMA OF QUEUE INTERFACE TABLE
 CM.RBD   EQU    CM.RBI      CMA OF REQUEST BUFFER DESCRIPTOR
 CM.RB    BSSZ   3           CMA OF REQUEST BUFFER
          ORG    72B
 PPIT     BSSZ   2           REAL MEMORY WORD ADDRESS OF PP INTERFACE TABLE
 QEBRB    BSSZ   1           QUEUE ENTRY NUMBER BLOCKING REQUEST BUFFER
 MLPRTN   BSSZ   1           MAIN LOOP RETURN ADDRESS
          ORG    76B
 PP       BSSZ   1           LOGICAL PP NUMBER
 LU       BSSZ   1           LOGICAL UNIT NUMBER
          SPACE  4

          ERRNZ  /RBD/P.IN-3 IF QIT ORDER CHANGED

 CMADR    EQU    CM          USED BY 'LOAD' MACROS
          TITLE  MAIN LOOP
*
*         MAIN LOOP.
*
          ORG    100B
          DATA   L'ESMD'
 ESMD     BSS    0
 MLP      BSS    0
          LDC    MLP1
          STDL   MLPRTN
          LJM    CPR         CHECK FOR PP REQUEST

 MLP1     LDC    1           PP IDLE FLAG SET/CLEARED VIA PP REQUEST
 PPIDLE   EQU    *-1         (PP IDLE FLAG, NONZERO IF PP IDLE)
          NJK    MLP         IF PP IDLE SKIP REQUEST BUFFER AND ESM FLAG CHECK

          LDC    **          PP NUMBER OF PP TO SEND
 SNDPP    EQU    *-1         (PP NUMBER TO PROCESS REQUEST BUFFER ENTRIES)
          SBDL   PP
          NJN    MLP2        IF THIS PP IS NOT PROCESSING REQUEST BUFFER

          LDC    MLP2
          STDL   MLPRTN
          LJM    FSQ         PROCESS REQUEST BUFFER REQUEST

 MLP2     LDC    **          PP NUMBER OF PP TO RECEIVE
 RCVPP    EQU    *-1         (PP NUMBER TO PROCESS ESM SOURCE FLAGS)
          SBDL   PP
          NJK    MLP         IF THIS PP IS NOT PROCESSING ESM SOURCE FLAGS

          LDC    MLP
          STDL   MLPRTN
          LJM    FRQ         PROCESS ESM FLAG REGISTER REQUEST
          TITLE  PROCESS REQUEST BUFFER ENTRIES (SEND)
** CSQ -  CLEAR SEND REQUEST AT REQUEST BUFFER ENTRY.
*
** PURPOSE -
*         REMOVES THE REQUEST FROM THE QUEUE BY CLEARING THE REQUEST
*         BUFFER ENTRY AND UPDATING THE OUT POINTER.
*
** INPUT -
*         P1 THRU P4 = REQUEST BUFFER ENTRY.
*         OUT    = REQUEST BUFFER OUT OFFSET IN CM WORDS.
*         RBLIM  = REQUEST BUFFER LIMIT OFFSET IN CM WORDS.
*
** OUTPUT -
*         OUT    = UPDATED REQUEST BUFFER OUT OFFSET IN CM WORDS.
*
** USES - P1 THRU P4.

 CSQ1     STDL   OUT         RESET REQUEST BUFFER OUT OFFSET

 CSQ      SUBR               ENTRY/EXIT
          LDN    0           CLEAR REQUEST BUFFER ENTRY IN PP
          STDL   P1+/RBE/P.PRV
          STDL   P1+/RBE/P.SPMSG
          STDL   P1+/RBE/P.QEI
          LOADC  CM.RB       ADDRESS OF REQUEST BUFFER
          ADDL   OUT
          CWDL   P1          CLEAR REQUEST BUFFER ENTRY IN CM
          AODL   OUT         INCREMENT OUT POINTER
          SBDL   RBLIM       REQUEST BUFFER LIMIT IN CM WORDS
          ZJN    CSQ1        IF OUT EQUAL LIMIT
          RETURN
ISQ       SPACE    4,24
** ISQ -  INITIALIZE SEND REQUEST.
*
** PURPOSE -
*         THIS SUBROUTINE ATTEMPTS TO RESERVE DESTINATION ESM SPACE
*         FOR SEND REQUESTS. A SEND PROMPT REQUEST DOES NOT REQUIRE
*         NEW RESERVATION SINCE IT IS A CONTINUATION OF A RECEIVE
*         REQUEST.
*
** INPUT -
*         (TOQP)    = IF NONZERO, QUEUE INDEX OF TOP OF REQUEST BUFFER ENTRY
*         (P1 - P4) = REQUEST BUFFER ENTRY.
*
** OUTPUT -
*         (A)    = ZERO, IF REQUEST BUFFER REQUEST INITIALIZED.
*                = NEGATIVE, IF REQUEST BUFFER ENTRY NOT PROCESSABLE.
*                = NON ZERO, IF ERROR DETECTED.
*         (HMSG) = INITIALIZED TO ZERO, IF NORMAL FILE SERVER REQUEST.
*                = INQ FLAG TRUE, IF STATE INQUIRY MESSAGE.
*                = SPMSG FROM REQUEST BUFFER IF INQUIRY.
*
** CALLS  - CIQ, RDQ, RSV.

 ISQ5     LDC    -1          REQUEST NOT READY

 ISQX     BSS    0
 ISQ      SUBR               ENTRY/EXIT
          LDDL   P1+/RBE/P.QEI  QUEUE INDEX / QUEUE ENTRY INDEX
          ZJN    ISQ5        IF REQUEST NOT READY

*         RESTORE RESPONSE WORD FOR NON INQUIRY REQUESTS.
          LDK    SRF.SR+SRF.SW+B.FSSR
          STML   RSPBUF+/FSSR/P.SRFL  RESPONSE FLAGS AND LENGTH FOR NON INQUIRY
          LDDL   P1+/RBE/P.INQ
          SHN    2+/RBE/L.INQ  INQUIRY FLAG TO SIGN POSITION
          PJN    ISQ1        IF NOT INQUIRY

*         INCASE AN ERROR OCCURS ON INQUIRY MESSAGE.
          LDK    SRF.SR+SRF.SW+SRF.INQ+B.FSSR
          STML   RSPBUF+/FSSR/P.SRFL  RESPONSE FLAGS AND LENGTH FOR INQUIRY

 ISQ1     LDDL   P1+/RBE/P.QEI  QUEUE INDEX / QUEUE ENTRY INDEX
          RJM    RDQ         READ QUEUE HEADER AND QUEUE ENTRY
          NJN    ISQX        IF QUEUE RELATED ERROR
          RJM    CIQ         CHECK IDLE OR INACTIVE QUEUE ENTRY
 ISQ1.1   BSS    0           (HOP SCOTCH TO ISQX EXIT)
          NJN    ISQX        IF QUEUE IS IDLE OR QUEUE ENTRY INACTIVE
          STML   HMSG+/HMSG/P.ERR     CLEAR HEADER FLAGS FOR SPECIAL MESSAGE
          STML   HMSG+/HMSG/P.SPMSG   CLEAR HEADER SPECIAL MESSAGE FIELD
          STML   HMSG+/HMSG/P.WCB     BUFFER CM WORD COUNT
          STML   HMSG+/HMSG/P.WCD     DATA CM WORD COUNT
          LDDL   P1+/RBE/P.INQ
          SHN    2+/RBE/L.INQ  INQUIRY FLAG TO SIGN POSITION
          PJN    ISQ2        IF NOT INQUIRY
          LDML   DQHEAD+/DQH/P.SQTYP
          SHN    2+/DQH/L.SQTYP
          MJN    ISQ1.2      IF SERVER TO CLIENT SEND INQUIRY RESPONSE
          LDDL   QF          CHECK IF INQUIRY REQUEST STILL VALID
          LPK    DRIVER+SUBSYS+SNDBUF+SNDDAT+SNDPMT+PRORSP
          ZJN    ISQ1.2      IF NOTHING GOING ON INQUIRY REQUEST IS VALID
          LDK    OBSINQ      OBSOLETE OR UNWANTED INQUIRY REQUEST
          STD    ER          FAKE ERROR ON OBSOLETE INQUIRY REQUES
          UJN    ISQ1.1      (SKIP TO EXIT)

 ISQ1.2   BSS    0
          LDK    HMF.INQ     SET INQUIRY FLAG IN HEADER MESSAGE
          STML   HMSG+/HMSG/P.INQ
          LDDL   P1+/RBE/P.SPMSG  STATE INQUIRY WORD
          STML   HMSG+/HMSG/P.SPMSG
          UJN    ISQ3        ATTEMPT ESM RESERVATION

 ISQ2     LDDL   QF          CURRENT QUEUE ENTRY FLAGS
          LPC    SNDBUF+SNDDAT
          ZJN    ISQ4        IF NOT SEND BUFFER OR DATA (SNDPMT)
          LDML   DQENTR+/DQE/P.HDIV  HELDOVER DIVISION NUMBER
          ZJN    ISQ3        IF NO HELD OVER DATA
*         HELD OVER PAGE DATA WAS NOT PROMPTED FOR, RELEASE RESERVED DEVISION.
          STDL   DI          SET DIVISION NUMBER
          LDDL   SI          SOURCE ID NUMBER
          STDL   ID          SOURCE ID NUMBER
          LDN    SADESM      ESMADR OFFSET OF SOURCE ESM ADDRESSES
          RJM    SEA         SETUP ESM ADDRESSES
          RJM    CFR         CLEAR SOURCE ESM FLAG REGISTER (RECORDS ERROR)
          LDN    0           CLEAR HOLDOVER INFORMATION IN QUEUE ENTRY
          STML   DQENTR+/DQE/P.HWCD
          STML   DQENTR+/DQE/P.HDIV
*
*         IF *FSR* IS "LOOKING AHEAD" IN THE REQUEST BUFFER WHEN THE REQUEST AT
*         THE TOP OF THE REQUEST BUFFER COULD NOT BE INITIATED THEN (TOQP) IS
*         THE QUEUE INDEX OF THAT REQUEST. IF THE CURRENT REQUEST REQUIRES ESM
*         RESERVATION AND IT'S FROM THE SAME QUEUE AS THE REQUEST AT THE TOP OF
*         THE REQUEST BUFFER IT WILL NOT BE INITIATED.
 ISQ3     BSS    0
          LDDL   QI          QUEUE INDEX OF REQUEST
          LMDL   TOQP        QUEUE INDEX WHICH CAUSE LOOK AHEAD
          ZJK    ISQ5        IF CURRENT QI SAME AS THAT WHICH CAUSED LOOK AHEAD

          RJM    RSV         RESERVE DESTINATION MACHINE ESM SPACE
*                            (A) = ZERO, DESTINATION ESM RESERVED.
*                                = NEGATIVE, DESTINATION NOT RESERVED.
*                                = NON ZERO, HARDWARE ERROR.
 ISQ4     RETURN
FSQ       EJECT
** FSQ -  FIND A SEND REQUEST IN THE REQUEST BUFFER.
*
** PURPOSE -
*         THIS SUBROUTINE SCANS THE REQUEST BUFFER, BEGINNING AT THE
*         OUT OFFSET, CLEARING CONTIGUOUS PREVIOUSLY PROCESSED REQUESTS
*         AND UPDATING THE OUT OFFSET UNTIL A NON-PREVIOUSLY PROCESSED
*         REQUEST IS FOUND OR UNTIL ALL ENTRIES HAVE BEEN EXAMINED.
*         IF THE FIRST NON-PREVIOUSLY PROCESSED REQUEST CAN BE
*         INITIALIZED IT IS CLEARED FROM THE REQUEST BUFFER, THE OUT
*         OFFSET IS UPDATED, AND THE REQUEST IS PROCESSED. IF THE FIRST
*         NON-PREVIOUSLY PROCESSED REQUEST CANNOT BE INITIALIZED AN
*         ATTEMPT IS MADE TO INITIALIZE ONE OF THE REMAINING REQUESTS.
*         IF IN THIS 'LOOK AHEAD' SITUATION A REQUEST IS INITIALIZED,
*         IT IS FLAGED AS A PREVIOUSLY PROCESSED REQUEST IN THE REQUEST
*         BUFFER, THE OUT OFFSET IS NOT UPDATED, AND THE REQUEST IS
*         PROCESSED.
*
** INPUT -
*         CM.RBI = REQUEST BUFFER IN POINTER REFORMATTED CM ADDRESS.
*         CM.RB  = REQUEST BUFFER REFORMATTED CM ADDRESS.
*         RBLIM  = REQUEST BUFFER LIMIT OFFSET IN CM WORDS.
*
** OUTPUT -
*
** USES - T5, T7 THRU T11, P1 THRU P4.
*
** CALLS - CSQ, IRS, ISQ, PSQ, UQE.

 IOUT     EQU    T5          INITIAL OUT POINTER VALUE
 OUT      EQU    T10         REQUEST BUFFER OUT POINTER (T7-T10)
 INN      EQU    T11         REQUEST BUFFER IN POINTER
 TOUT     EQU    OUT-2       TEMPORARY REQUEST BUFFER OUT POINTER
 TOQP     EQU    OUT-3       TOP OF REQUEST BUFFER POINTER


 FSQ      BSS    0           ENTRY
          LDN    0
          STDL   EI          CLEAR QUEUE ENTRY INDEX
          RJM    IRS         INITIALIZE SINGLE WORD RESPONSE BUFFER
          LOADC  CM.RBI      ADDRESS OF REQUEST BUFFER IN POINTER
          CRDL   INN-3       READ REQUEST BUFFER IN POINTER
          ADN    /RBD/C.OUT-/RBD/C.IN
          CRDL   OUT-3       READ REQUEST BUFFER OUT POINTER
          LDDL   OUT         OUT OFFSET IN BYTES
          SHN    -3          /8 FOR CM WORD OFFSET
          STDL   OUT         OUT OFFSET IN CM WORDS
          STDL   IOUT        SAVE INITIAL VALUE OF OUT POINTER
          LDDL   INN         IN OFFSET IN BYTES
          SHN    -3          /8 FOR CM WORD OFFSET
          STDL   INN         IN OFFSET IN CM WORDS
          SBDL   RBLIM       REQUEST BUFFER LIMIT IN CM WORDS
          NJN    FSQ1        IF IN NOT EQUAL LIMIT
          STDL   INN         RESET IN POINTER (CM UPDATING 'IN')
*
*         FIND AND CLEAR PREVIOUSLY PROCESS REQUEST BUFFER ENTRIES.
*
 FSQ1     LDDL   INN
          SBDL   OUT
          ZJN    FSQ5        IF IN = OUT, NO MORE REQUEST ENTRIES
          LOADC  CM.RB       ADDRESS OF REQUEST BUFFER
          ADDL   OUT         FORM REQUEST BUFFER ENTRY ADDRESS
          CRDL   P1          READ REQUEST BUFFER ENTRY
          LDDL   P1+/RBE/P.PRV
          SHN    2+/RBE/L.PRV
          PJN    FSQ3        IF NOT A PREVIOUSLY PROCESSED ENTRY
          RJM    CSQ         CLEAR REQUEST BUFFER ENTRY, UPDATE OUT
 FSQ2     UJK    FSQ1        CHECK NEXT ENTRY

*
*         ATTEMPT TO INITIALIZE THE FIRST REQUEST FOUND.
*
 FSQ3     RJM    ISQ         INITIALIZE REQUEST BUFFER REQUEST
          PJN    FSQ4        IF ABLE TO PROCESS REQUEST AT 'OUT'

*         BECAUSE FILE SERVER RELIES ENTIRELY ON SOFTWARE TO DETERMINE THE
*         PRESENCE OR ABSENCE OF A PARTNER MACHINE, IT IS POSSIBLE FOR THIS
*         DRIVER TO ASSUME THAT A MACHINE IS AVAILABLE TO RECEIVE MESSASGES
*         WHEN IN FACT IT IS NOT. THIS SITUATION OCCURS IF A PARTNER MACHINE'S
*         "MACHINE_UP" FLAG (4 bit flag register) IS ERRONIOUSLY LEFT IN THE
*         STATE WHICH INDICATES THE MACHINE IS "UP". THE "MACHINE_UP" FLAG IS
*         SET TO INDICATE MACHINE "UP" WHEN A "RESUME_PP" REQUEST IS PROCESSED;
*         THE FLAG IS SET TO INDICATE MACHINE "DOWN" AT DRIVER INITIALIZATION
*         TIME AND WHEN A "IDLE_PP" REQUEST IS PROCESSED. ANY SYSTEM FAILURE OR
*         HARDWARE FAILURE WHICH PREVENTS THE SETTING OF THE "MACHINE_UP" FLAG
*         TO "DOWN" WILL CAUSE ITS PARTNER TO CONTINUE TO ASSUME IT IS "UP".
*         THIS DRIVER STORES (send) MESSAGES INTO AN "UP" PARTNER MACHINE'S ESM
*         DIVISION SPACE AS LONG AS SPACE IS AVAILABLE. WHEN ALL SPACE IS FULL
*         REQUEST TO THAT MACHINE ARE "HELD" IN THE REQUEST BUFFER UNTIL SPACE
*         BECOMES AVAILABLE OR UNTIL THE DESTINATION MACHINE'S "MACHINE_UP" FLAG
*         INDICATES THE MACHINE IS "DOWN".  BECAUSE THE REQUEST BUFFER IS A
*         CIRCULAR BUFFER WITH "IN" AND "OUT" OFFSETS, AS LONG AS A REQUEST IS
*         BEING HELD IN THE REQUEST BUFFER THE "OUT" OFFSET CANNOT BE ADVANCED
*         AND THE POTENTIAL FOR A FULL REQUEST BUFFER CONDITION INCREASES.
*         IF FILE SERVER IS SUPPORTING MORE THAN ONE CONNECTION THE ACTIVE
*         CONNECTION MAY TERMINATE AS A RESULT OF NOT BEING ABLE TO
*         COMMUNICATE WITH IT'S PARTNER BECAUSE OF THE FULL REQUEST BUFFER.
*
*         THE FOLLOWING CODE IS TO PREVENT A REQUEST BUFFER FULL CONDITION
*         WHEN MORE THAN ONE CONNECTION IS BEING ACTIVATED. IN THIS CASE THE
*         REQUEST WHICH PREVENTS THE ADVANCEMENT OF OUT IS AN INQUIRY MESSAGE
*         AS TO THE STATUS OF A POLL MESSAGE TO A MACHINE WHICH HAS NOT YET
*         BEEN ACTIVATED.

          LDDL   QEBRB       QEI BLOCKING ADVANCEMENT OF 'OUT' SECOND TIME
          SBN    POLLQEI     CHECK IF POLLER'S QEI
          NJN    FSQ6        IF NOT POLLER'S QEI BLOCKING ADVANCEMENT OF 'OUT'
          LDDL   P1+/RBE/P.INQ
          SHN    2+/RBE/L.INQ  (INQUIRY REQUEST FLAG TO SIGN POSITION)
          PJN    FSQ6        IF NOT AN INQUIRY REQUEST
          LDK    OBSINQ      OBSOLETE OR UNWANTED INQUIRY REQUEST ERROR
          STDL   ER          FAKE ERROR SO INQUIRY REQUEST IS REMOVED
 FSQ4     BSS    0
          RJM    CSQ         CLEAR REQUEST BUFFER ENTRY, UPDATE OUT
 FSQ5     LJM    FSQ9        UPDATE OUT POINTER

*         THE FIRST REQUEST FOUND COULD NOT BE INITIALIZED.
*         LOOK AHEAD IN REQUEST BUFFER FOR A REQUEST WHICH CAN BE INITIALIZED
*
 FSQ6     LDDL   OUT         CURRENT OUT POINTER
          STDL   TOUT        TEMPORARY OUT POINTER
          LDDL   P1+/RBE/P.QI  FIRST ENTRY WHICH COULD NOT BE INITIATED
          SHN    /RBE/L.QI-/RBE/L.QEI
          STDL   TOQP        SAVE TOP OF REQUEST BUFFER QI
          LDDL   EI
          STDL   QEBRB       QUEUE ENTRY INDEX BLOCKING ADVANCEMENT OF 'OUT'

*         REQUEST BUFFER LOOK AHEAD LOOP.
 FSQ7     LDN    0
          STDL   EI          CLEAR QUEUE ENTRY INDEX
          AODL   TOUT        INCREMENT TEMP OUT POINTER
          SBDL   RBLIM
          NJN    FSQ8        IF TOUT NOT EQUAL LIMIT
          STDL   TOUT        RESET TEMP OUT POINTER
 FSQ8     LDDL   TOUT
          SBDL   INN
          ZJN    FSQ9        IF NO MORE ENTRIES
          LOADC  CM.RB       ADDRESS OF REQUEST BUFFER
          ADDL   TOUT        TEMP OUT POINTER
          CRDL   P1          READ REQUEST BUFFER ENTRY
          LDDL   P1+/RBE/P.PRV
          SHN    2+/RBE/L.PRV
          MJK    FSQ7        IF A PREVIOUSLY PROCESSED ENTRY

*         ATTEMPT TO INITIALIZE NEXT ENTRY IN REQUEST BUFFER.
          RJM    ISQ         INITIALIZE REQUEST BUFFER REQUEST
          ZJN    FSQ8.1      IF NO ERROR FOUND
          MJK    FSQ7        IF UNABLE TO INITIALIZE REQUEST
          RJM    CSQ         CLEAR REQUEST BUFFER ENTRY, UPDATE OUT
          UJK    FSQ9        UPDATE OUT POINTER
*
*         MARK REQUEST BUFFER ENTRY AS A PREVIOUSLY PROCESSED ENTRY.
*
 FSQ8.1   BSS    0
          LDK    RBE.PRV
          STDL   P1+/RBE/P.PRV  SET PREVIOUSLY PROCESSED FLAG
          LOADC  CM.RB      ADDRESS OF REQUEST BUFFER
          ADDL   TOUT       TEMP OUT POINTER
          CWDL   P1         WRITE ENTRY INTO REQUEST BUFFER
*
*         UPDATE REQUEST BUFFER OUT POINTER IN CM IF CONTIGUOUS ENTRIES FROM
*         TOP OF REQUEST BUFFER PROCESSED.
*
 FSQ9     LDDL   IOUT        INITIAL VALUE OF OUT IN CM WORDS
          SBDL   OUT         NEW REQUEST BUFFER OUT POINTER IN CM WORDS
          ZJN    FSQ10       IF NO CHANGE IN INITIAL OUT POINTER
          LDN    0           RESTORE HIGH ORDER BITS OF CM OUT POINTER
          STDL   OUT-1       ZERO
          STDL   OUT-2       ZERO
          STDL   OUT-3       ZERO
          STDL   QEBRB       CLEAR QUEUE ENTRY BLOCKING REQUEST BUFFER
          LDDL   OUT         OUT OFFSET IN CM WORDS
          SHN    3           *8 FOR BYTE OFFSET
          STDL   OUT         OUT OFFSET IN BYTES
          LOADC  CM.RBD      ADDRESS OF REQUEST BUFFER DIRECTORY
          ADK    /RBD/C.OUT  OFFSET OF OUT POINTER
          CWDL   OUT-3       WRITE UPDATED REQUEST BUFFER OUT POINTER

 FSQ10    LDDL   ER          ERROR CONDITION CODE
          ZJN    FSQ11       IF NO ERROR INITIALIZING REQUEST
          LMK    OBSINQ      CHECK IF OBSOLETE OR UNWANTED INQUIRY REQUEST
          ZJN    FSQX        IF FAKE ERROR TO DISPOSE OF INQUIRY REQUEST
          LJM    UQE         REPORT ERROR AND EXIT

 FSQ11    LDDL   EI
          NJN    PSQ         IF PROCESSABLE REQUEST FOUND

 FSQX     LJM    0,MLPRTN    EXIT
PSQ       SPACE  4,35
** PSQ - PROCESS SEND REQUEST.
*
** PURPOSE -
*       FOR FILE SERVER COMMAND/RESPONSE REQUESTS -
*         THE QUEUE ENTRY COMMAND FLAGS DEFINE THE ACTION TO BE TAKEN.
*         ONLY THE SEND COMMAND/RESPONSE (SNDBUF) AND SEND PAGE DATA (SNDDAT)
*         COMMANDS MAY OCCUR TOGETHER AND IF TOGETHER, THE SEND COMMAND/RESPONSE
*         IS PROCESSED FIRST. IF THE SEND PROMPT COMMAND IS PRESENT IT IS
*         PROCESSED AND THE OTHER COMMAND FLAGS ARE NOT EXAMINED.
*
*       FOR STATE INQUIRY REQUESTS -
*         THE QUEUE ENTRY IS NOT USED OR EFFECTED FOR STATE INQUIRY REQUEST.
*
** INPUT -
*         DQENTR = DRIVER QUEUE ENTRY.
*         DQHEAD = DRIVER QUEUE HEADER.
*         DESMAD = DESTINATION ESM ADDRESSES.
*         QI     = QUEUE INDEX.
*         EI     = QUEUE ENTRY INDEX.
*         SINGLE WORD RESPONSE -
*                   QIQEI = QUEUE INDEX / QUEUE ENTRY INDEX.
*
** OUTPUT -
*
** CALLS  - CFR, CIO/DIO, ERR, IEM, RIL, WEH, UQE.

 PSQ      BSS    0           ENTRY
          LDML   HMSG+/HMSG/P.INQ
          SHN    2+/HMSG/L.INQ
          PJN    PSQ1        IF NOT STATE INQUIRY
*
*         PROCESS 'STATE INQUIRY' REQUEST.
*
          RJM    WEH         WRITE ESM HEADER WITH STATE INQUIRY
          NJN    PSQ2        IF ERROR (QE NOT UPDATED ON INQUIRY FAILURE)
          LJM    0,MLPRTN    EXIT TO MAIN LOOP

*
*         PROCESS NON 'STATE INQUIRY' REQUEST.
*
 PSQ1     BSS    0
          LDDL   QF
          LPK    DRIVER      CHECK IF DRIVER ACTION FLAG SET
          NJN    PSQ3        IF DRIVER ACTION FLAG SET
          STDL   EI          CLEAR ENTRY INDEX SO IT'S NOT UPDATED
          LDK    IE.E12      ** DRIVER ACTION FLAG NOT SET **
 PSQ2     LJM    PSQ8        RECORD ERROR, RELEASE RESERVATION, UPDATE QE

*
*         PROCESS SEND FILE SERVER COMMAND/RESPONSE OR PROMPT REQUEST.
*
 PSQ3     BSS    0
          LDDL   QF          CURRENT QUEUE ENTRY FLAGS
          LPK    ACTIVE+SNDBUF+SNDDAT+SNDPMT
          STDL   QF          RETIAN ONLY ACTIVE AND COMMAND FLAGS
          SHN    2+/DQE/L.SNDPMT
          PJN    PSQ4        IF NOT SEND PROMPT COMMAND
          LJM    PMT         PROCESS DATA PROMPT COMMAND

 PSQ4     LDDL   QF          CURRENT QUEUE ENTRY FLAGS
          SHN    2+/DQE/L.SNDBUF
          PJN    PSQ6        IF NOT SNDBUF
*
*         PROCESS SEND BUFFER COMMAND.
*
          LDK    /DQE/P.SIND SEND BUFFER DESCRIPTOR OFFSET
          RJM    RIL         SETUP LENGTH/ADDRESS LIST
          NJN    PSQ5        IF ERROR FROM ADDRESS VALIDATION
          LDC    DESMAD+/EMA/P.BUF
          PAGEIO             CIO/DIO READ CM AND OUTPUT TO ESM
 PSQ5     NJN    PSQ8        IF ERROR
          LDDL   AC          NUMBER OF CM WORDS OUTPUT
          STML   HMSG+/HMSG/P.WCB  STORE CM WORD COUNT OF BUFFER

          LDDL   QF          CURRENT QUEUE ENTRY FLAGS
          LMK    SNDBUF+BUFSNT  CLEAR SNDBUF, SET BUFSNT
          STDL   QF

 PSQ6     LDDL   QF          CURRENT QUEUE ENTRY FLAGS
          SHN    2+/DQE/L.SNDDAT
          PJN    PSQ7        IF NOT SNDDAT
*
*         PROCESS SEND DATA COMMAND.
*
          LDK    /DQE/P.IND  PAGE DATA DESCRIPTOR OFFSET
          RJM    RIL         SETUP LENGTH/ADDRESS LIST
          NJN    PSQ8        IF ERROR
          LDC    DESMAD+/EMA/P.DAT
          PAGEIO             CIO/DIO READ CM AND OUTPUT TO ESM
          NJN    PSQ8        IF ERROR
          LDDL   AC          NUMBER OF CM WORDS OUTPUT
          STML   HMSG+/HMSG/P.WCD  STORE CM WORD COUNT OF PAGE DATA

          LDDL   QF          CURRENT QUEUE ENTRY FLAGS
          LMK    SNDDAT+DATSNT  CLEAR SNDDAT, SET DATSNT
          STDL   QF
*
*         WRITE HEADER TO ESM.
*
 PSQ7     RJM    WEH         WRITE ESM HEADER TO ESM
          ZJN    PSQ9        IF NO ERROR
*
*         ERROR PROCESSING.
*
 PSQ8     RJM    ERR         RECORD ERROR
          LDN    DADESM      ESMADR OFFSET OF DESTINATION ESM ADDRESSES
          RJM    CFR         CLEAR DESTINATION FLAG REGISTER (RECORDS ERROR)
*
*         COMPLETE THE REQUEST.
*
 PSQ9     LJM    UQE         UPDATE QUEUE ENTRY AND RETURN TO MAIN LOOP
PMT       EJECT
** PMT -  PROMPT COMMAND PROCESS.
*
** PURPOSE -
*         THE SEND PROMPT COMMAND PROVIDES FOR THE COMPLETION OF A
*         RECEIVE REQUEST, PROCESSED EARLIER, WHICH CONTAINED PAGE
*         DATA, BUT BUFFER SPACE FOR THE PAGE DATA WAS NOT ASSIGNED
*         FOR THE QUEUE ENTRY. THE PP SAVED THE ESM DIVISION
*         NUMBER IN THE RECEIVING QUEUE ENTRY SO THAT WHEN A SEND
*         PROMPT COMMAND IS DETECTED THE DATA TO BE RECEIVED CAN
*         BE LOCATED WITHOUT SEARCHING ESM HEADERS FOR IT.
*         THE TASK, INFORMED OF HOW MUCH PAGE DATA IS TO BE RECEIVED
*         VIA THE COMMAND/RESPONSE MESSAGE, HAS ALLOCATED AND ASSIGNED
*         PAGE DATA SPACE, STORED THE BUFFER POINTER AND SEND PROMPT
*         (SNDPMT) COMMAND IN THE QUEUE ENTRY, AND QUEUED THE REQUEST
*         BUFFER ENTRY.
*
** INPUT -
*         QI     = QUEUE INDEX.
*         EI     = QUEUE ENTRY INDEX.
*         DQHEAD = DRIVER QUEUE HEADER.
*         DQENTR = DRIVER QUEUE ENTRY.
*
** OUTPUT -
*         (A)    = ZERO, IF NO ERROR.
*                = NON ZERO, IF ERROR OCCURRED -
*                            - HELD DIVISION NUMBER IS ZERO.
*                            - HELD DATA COUNT IS ZERO.
*                            - ERROR FROM CALLED ROUTINE.
*         DI     = HELD OVER ESM DIVISION NUMBER.
*
** CALLS - CFR, ERR, RED, SEA, UQE.

 PMT      BSS    0           ENTRY
          LDML   DQENTR+/DQE/P.HDIV  HELDOVER DIVISION NUMBER
          ZJN    PMT3        IF HELD DIVISION NUMBER MISSING
          STDL   DI          SET DIVISION NUMBER
          LDDL   SI          SOURCE ID NUMBER
          STDL   ID          SOURCE ID NUMBER
          LDN    SADESM      ESMADR OFFSET OF SOURCE ESM ADDRESSES
          RJM    SEA         SETUP ESM ADDRESSES
          LDML   DQENTR+/DQE/P.HWCD
          ZJN    PMT3        IF HELD DATA COUNT MISSING
          STML   HMSG+/HMSG/P.WCD (SO 'RED' FINDS CORRECT WORD COUNT FOR PROMPT)
          RJM    RED         READ PAGE DATA FROM ESM
          ZJN    PMT1        IF NO ERROR
          RJM    ERR         RECORD MEDIA ERROR
 PMT1     LDN    SADESM      ESMADR OFFSET OF SOURCE ESM ADDRESSES
          RJM    CFR         CLEAR SOURCE ESM FLAG REGISTER (RECORDS ERROR)
          LDN    0           CLEAR HOLDOVER INFORMATION IN QUEUE ENTRY
          STML   DQENTR+/DQE/P.HWCD
          STML   DQENTR+/DQE/P.HDIV
 PMT2     LJM    UQE         UPDATE QUEUE ENTRY AND RETURN TO MAIN LOOP

*
*         INTERFACE ERROR PROCESSING.
*
 PMT3     LDK    IE.E08      ** MISSING HOLD OVER INFORMATION IN QE **
          RJM    ERR         RECORD ERROR
          UJN    PMT2        COMPLETE THE REQUEST
          TITLE  PROCESS SOURCE ESM FLAG REGISTERS (RECEIVE)
** FRQ -  FIND A RECEIVE REQUEST IN SOURCE ESM FLAG REGISTERS.
*
** PURPOSE -
*         ALL RECEIVE REQUESTS FOR THIS PP ARE POSTED IN THE ESM FLAG
*         REGISTERS ASSIGNED TO THIS PP. THIS SUBROUTINE TESTS EACH
*         OF THESE ESM FLAG REGISTERS UNTIL A RECEIVE REQUEST IS FOUND
*         OR UNTIL ALL FLAG REGISTERS HAVE BEEN TESTED ONCE.
*
** INPUT - NONE.
*
** OUTPUT -
*         (A)    = ZERO, IF INCOMING REQUEST FOUND.
*                = ERROR CODE, IF ERROR OCCURRED.
*         DI     = SOURCE DIVISION NUMBER.
*         ID     = SOURCE ID NUMBER.
*
** USES - T3, T4.
*
** CALL - CIQ, ERR, IRS, FOP, RDQ, REH, RSP, SEA.

 FRQ      BSS    0           ENTRY
          RJM    IRS         INITIALIZE SINGLE WORD RESPONSE BUFFER
          LDC    0           LAST DIVISION NUMBER PROCESSED
 FRQA     EQU    *-1         (LAST DIVISION NUMBER PROCESSED)
          STDL   DI
          LDK    FR.RSV+FR.RDY  FIND RESERVED AND READY ESM FLAG
          STDL   T3          SAVE 4 BIT FLAG WORD
          LDK    FF.EQU      EQUALITY STATUS FLAG FUNCTION
          STDL   T4          SAVE FLAG FUNCTION

*         SCAN SOURCE FLAG REGISTERS FROM DIVISION (FRQA)+1 TO (FRQA).
 FRQ1     LDDL   DI          LAST DIVISION CHECKED
          SBDL   NDIVS       NUMBER OF ESM DIVISIONS PER MACHINE
          NJN    FRQ2        IF NOT MAX DIVISION NUMBER
          STDL   DI          RESET/CLEAR DIVISION NUMBER
 FRQ2     AODL   DI          INCREMENT TO NEXT DIVISION NUMBER (1 THRU 8)
          ADML   TBFLGA,SI   BASE ESM FLAG REGISTER ADDRESS FOR SOURCE
          SBN    1           ADJUST DIVISION FLAG ADDRESS
          RJM    FOP         FLAG OPERATION
          ZJN    FRQ5        IF READY RESERVED FLAG FOUND
          PJN    FRQ3        IF HARDWARE ERROR  (RESPONSE ONLY, NO QE)
          LDDL   DI          LAST DIVISION CHECKED
          SBML   FRQA        LAST DIVISION NUMBER PROCESSED
          NJN    FRQ1        IF NOT COMPLETE CYCLE
          LJM    0,MLPRTN    TO MAIN LOOP

*         ERROR PROCESSING.
 FRQ3     RJM    ERR         RECORD ERROR
          LJM    UQE         WRITE RESPONSE (NO QUEUE ENTRY) AND GO TO MAIN LOOP


*         INPUT REQUEST FOUND.
 FRQ5     LDDL   DI          CURRENT DIVISION NUMBER
          STML   FRQA        SAVE AS LAST DIVISION PROCESSED

*
*         INITIALIZE RECEIVE REQUEST.
*
*         SET SOURCE ESM ADDRESSES.
 IRQ      BSS    0
          LDDL   SI          SOURCE ID NUMBER
          STDL   ID          SAVE SOURCE ID NUMBER
          LDN    SADESM      ESMADR OFFSET OF SOURCE ESM ADDRESSES
          RJM    SEA         SETUP ESM MEMORY ADDRESSES

*         READ HEADER FROM ESM.
          RJM    REH         READ ESM HEADER
          ZJN    IRQ2        IF NO ERROR
 IRQ1     LJM    PRQ5        CLEAR SOURCE FLAG REG

 IRQ2     LDML   HMSG+/HMSG/P.INQ
          SHN    2+/HMSG/L.INQ
          PJN    IRQ3        IF NOT INQUIRY MESSAGE
          LDK    SRF.SR+SRF.SW+SRF.INQ+B.FSSR
          STML   RSPBUF+/FSSR/P.SRFL  RESPONSE FLAGS AND LENGTH FOR INQUIRY

*         ESTABLISH QUEUE AND QUEUE ENTRY INDEX FROM ESM HEADER
 IRQ3     LDML   DQHEAD+/DQH/P.DQEI  DESTINATION QI AND QEI

*         READ QUEUE HEADER AND QUEUE ENTRY.
          RJM    RDQ         READ QUEUE HEADER AND QUEUE ENTRY
          NJN    IRQ3.1      IF QUEUE RELATED ERROR THROW AWAY REQUEST
          RJM    CIQ         CHECK IDLE QUEUE OR INACTIVE QUEUE ENTRY
 IRQ3.1   BSS    0
          NJK    IRQ4        IF QUEUE IDLE OR ENTRY INACTIVE THROW AWAY REQUEST
          LDML   HMSG+/HMSG/P.INQ
          SHN    2+/HMSG/L.INQ
          PJN    PRQ         IF NOT STATE INQUIRY REQUEST
*
*         PROCESS INCOMING 'STATE INQUIRY' REQUEST/RESPONSE.
*
          LDML   HMSG+/HMSG/P.SPMSG
          STML   RSPBUF+/FSSR/P.SRPAR  STORE STATE INQUIRY IN RESPONSE
          RJM    RSP         WRITE SINGLE WORD RESPONSE/INTERRUPT (IGNORE ERROR)
*
*         CLEAR SOURCE ESM FLAG REGISTER AND EXIT TO MAIN LOOP.
*
 IRQ4     BSS    0           CLEAR OUT FLAG REGISTER INCOMING REQUEST
          LDN    SADESM      ESMADR OFFSET OF SOURCE ESM ADDRESSES
          RJM    CFR         CLEAR SOURCE ESM FLAG REGISTER (RECORDS ERROR)
          ZJN    IRQ5        IF NO ERROR
          LDN    0
          STML   RSPBUF+/FSSR/P.QI   CLEAR QI/QEI FOR ONE WORD RESPONSE
          RJM    RSP         REPORT FAILURE ON FLAG OP
 IRQ5     LJM    0,MLPRTN    EXIT TO MAIN LOOP

PRQ       SPACE  4,40
** PRQ -  PROCESS RECEIVE REQUEST.
*
** PURPOSE -
*         THE ESM HEADER INDICATES THE QUEUE AND QUEUE ENTRY TO WHICH THIS
*         RECEIVE REQUEST IS DIRECTED. THE OPERATION TO BE PERFORMED IS
*         INDICATED BY COMMAND/RESPONSE WORD COUNT, AND PAGE DATA WORD
*         COUNT FIELDS OF THE ESM HEADER.
*
*         ANY INCOMING (RECEIVE) REQUEST DIRECTED TO A QUEUE WHICH IS IDLE,
*         A QUEUE ENTRY WHICH IS INACTIVE, OR A QUEUE ENTRY WITH THE DRIVER
*         ACTION FLAG SET WILL BE REMOVED FROM ESM AND IGNORED.
*
*         IF BOTH COMMAND/RESPONSE WORD COUNT AND PAGE DATA WORD
*         COUNT FIELDS ARE NON ZERO, THE COMMAND/RESPONSE RECEIVE
*         IS PROCESSED FIRST. IF THE PAGE DATA RECEIVE CAN BE
*         PROCESSED (PAGE BUFFER SPACE ASSIGNED) THE ESM FLAG
*         REGISTER WILL BE CLEARED. IF PAGE DATA BUFFER SPACE IS
*         NOT ASSIGNED TO THE QUEUE ENTRY, THE ESM DIVISION NUMBER
*         IS SAVED IN THE QUEUE ENTRY AND THE ESM FLAG REGISTER IS
*         CHANGED TO INDICATE 'HELD' PAGE DATA. THIS 'HELD' PAGE
*         DATA CONDITION IS CLEARED WHEN THE PP PROCESSES THE
*         SEND PROMPT COMMAND QUEUED VIA THE REQUEST BUFFER.
*
** INPUT -
*         DI     = SOURCE DIVISION NUMBER.
*         DQHEAD = DRIVER QUEUE HEADER.
*         DQENTR = DRIVER QUEUE ENTRY.
*         HMSG   = ESM HEADER MESSAGE.
*         QI     = QUEUE INDEX.
*         EI     = QUEUE ENTRY INDEX.
*         SESMAD = SOURCE ESM MEMORY ADDRESSES.
*
** OUTPUT -
*
** USES - T3, T4.
*
** CALL - CFR, FOP, IEM, RED, RIL, WEH, UQE.


 PRQ10    UJN    IRQ4        CLEAR SOURCE FLAG AND GO TO MAIN LOOP

 PRQ      BSS    0           ENTRY
          LDDL   QF          CURRENT QUEUE ENTRY FLAGS
          SHN    2+/DQE/L.DRIVER  CHECK IF SEND REQUEST QUEUED
          MJN    PRQ10       IF SEND REQUEST QUEUED THROW AWAY INCOMING REQUEST

          LDML   DQHEAD+/DQH/P.SQTYP  (THIS MACHINES QUEUE HEADER)
          SHN    2+/DQH/L.SQTYP
          PJN    PRQ1        IF NOT SERVER TO CLIENT QUEUE TYPE

*         REQUEST FOR SERVER SIDE.
          LDDL   QF          CURRENT QUEUE ENTRY FLAGS
          LPK    ACTIVE+SUBSYS+PRORSP
          STDL   QF          RETAIN ONLY ACTIVE FLAG FOR SERVER IF NOT BUSY
          LPK    SUBSYS+PRORSP
          ZJN    PRQ2        IF SERVER NOT BUSY WITH QE
          UJN    IRQ5        LEAVE INCOMMING REQUEST FOR NEXT TIME AROUND

*         RESPONSE FOR CLIENT SIDE.
 PRQ1     LDDL   QF          CURRENT QUEUE ENTRY FLAGS
          LPK    ACTIVE+SUBSYS+BUFSNT+DATSNT+PRORSP
          STDL   QF          RETAIN ONLY ACTIVE AND SENT EVENT FLAGS IF NOT BUSY
          LPK    SUBSYS+PRORSP
          NJN    PRQ10       CLIENT HAS QUEUE ENTRY, DUMP INCOMING RESPONSE
          LDDL   QF
          LPK    BUFSNT      THIS FLAG MUST BE SET TO RECEIVE RESPONSE
          ZJN    PRQ10       CLIENT IS NOT EXPECTING ANY RESPONSE, DUMP IT

 PRQ2     LDML   HMSG+/HMSG/P.WCB
          ZJN    PRQ3        IF NO BUFFER DATA
*
*         GET COMMAND/RESPONSE DATA FROM ESM MEMORY.
*
          LDK    /DQE/P.RIND RECEIVE BUFFER DESCRIPTOR OFFSET
          RJM    RIL         SETUP LENGTH/ADDRESS LIST
          NJN    PRQ4        IF ERROR
          LDML   HMSG+/HMSG/P.WCB
          STDL   RC          SET REQUESTED NUMBER OF CM WORDS TO INPUT
          LDC    SESMAD+/EMA/P.BUF
          PAGEIO             CIO/DIO INPUT FROM ESM AND WRITE TO CM
          NJN    PRQ4        IF ERROR

          LDDL   QF          CURRENT QUEUE ENTRY FLAGS
          LMK    BUFRCV      SET BUFFER RECEIVED FLAG
          STDL   QF

 PRQ3     LDML   HMSG+/HMSG/P.WCD
          ZJN    PRQ5        IF NO PAGE DATA
          LDML   DQENTR+/DQE/P.LEN  INDIRECT LIST LENGTH
          ZJN    PRQ8        IF PAGE DATA ADDRESS NOT ESTABLISHED
*
*         GET PAGE DATA FROM ESM MEMORY.
*
          RJM    RED         READ PAGE DATA FROM ESM
          ZJN    PRQ5        IF NO ERROR

*         RECORD ERROR.
 PRQ4     RJM    ERR         RECORD ERROR

*         CLEAR SOURCE ESM FLAGS AND COMPLETE REQUEST.
 PRQ5     LDN    SADESM      ESMADR OFFSET OF SOURCE ESM ADDRESSES
          RJM    CFR         CLEAR SOURCE ESM FLAG REGISTER (RECORDS ERROR)
 PRQ6     BSS    0           (UNUSED TAG)
 PRQ7     LJM    UQE         UPDATE QUEUE ENTRY AND RETURN TO MAIN LOOP

*
*         HOLD DATA UNTIL PROMPT FROM REQUEST BUFFER.
*
 PRQ8     BSS    0
          LDK    FF.SET      SELECTIVE SET FLAG FUNCTION
          STDL   T4          SAVE FLAG FUNCTION
          LDK    FR.RSV+FR.HLD  SET RESERVED AND HELD ESM FLAGS
          STDL   T3          FLAG WORD
          LDML   SESMAD+/EMA/P.FRG  SOURCE ESM FLAG REGISTER ADDRESS
          RJM    FOP         FLAG REGISTER OPERATION
          NJN    PRQ4        IF HARDWARE ERROR OR REJECTION
          LDDL   DI          ESM DIVISION NUMBER
          STML   DQENTR+/DQE/P.HDIV  SAVE HELD DIVISION NUMBER
          LDML   HMSG+/HMSG/P.WCD  PAGE DATA CM WORD COUNT
          STML   DQENTR+/DQE/P.HWCD  SAVE HELD PAGE DATA WORD COUNT
          UJN    PRQ7        UPDATE QUEUE ENTRY
          TITLE  SEND/RECEIVE REQUEST COMPLETION
UQE       EJECT
** UQE -  UPDATE QUEUE ENTRY FLAGS
*
** PURPOSE -
*         THE EVENT STATUS FLAGS IN THE QUEUE ENTRY INDICATE WHAT
*         OPERATION(S) THE PP HAS PERFORMED SO THAT THE TASK WHICH
*         CURRENTLY OWNS THE QUEUE ENTRY CAN TAKE APPROPRIATE ACTION
*         WHEN IT REGAINS ACCESS TO THE QUEUE ENTRY.
*         NOTE THAT IF ONLY A SEND COMMAND/RESPONSE (SNDBUF) COMMAND
*         HAS BEEN PROCESSED FROM A SERVER TO CLIENT QUEUE ALL QUEUE
*         ENTRY FLAGS (EXCEPT ASSIGNED) ARE CLEARED BY THE PP. THIS IS
*         BECAUSE THE SERVER TASK HAS COMPLETED THE LAST OF THE
*         OPERATIONS ASSOCIATED WITH A FILE SERVER REQUEST, AND FOR THE
*         PP TO ALERT THE SERVER TASK TO CLEAR THE QUEUE ENTRY FLAGS
*         WOULD BE A POOR USE OF CP TIME.
*
*         A RESPONSE BUFFER ENTRY INDIRECTLY CAUSES SOME ACTION TO
*         BE TAKEN BY THE TASK WHICH CURRENTLY OWNS THE QUEUE ENTRY.
*         THIS PORTION OF THE PROTOCOL IS BUILT INTO THIS SUBROUTINE,
*         AND THE RULES FOR DETERMINING WHEN TO WRITE A RESPONSE
*         BUFFER ENTRY ARE AS FOLLOWS -
*             WITHOUT REGARD TO QUEUE TYPE -
*                1. WHEN AN ERROR CONDITION IS INDICATED IN THE QUEUE
*                   ENTRY CONTROL FLAGS.
*                2. WHEN A COMMAND/RESPONSE MESSAGE IS RECEIVED
*                   (ESM FLAG REGISTER REQUEST) WITH OR WITHOUT PAGE
*                   DATA RECEIVED AT SAME TIME.
*                3. WHEN ONLY PAGE DATA IS RECEIVED AS A RESULT
*                   OF PROCESSING A SEND PROMPT (SNDPMT) COMMAND VIA
*                   THE REQUEST BUFFER.
*             FOR SERVER TO CLIENT QUEUE TYPE -
*                4. WHEN SEND PAGE DATA (SNDDAT) COMMAND IS PROCESSED
*                   VIA THE REQUEST BUFFER.
*
** INPUT -
*         DQENTR = DRIVER QUEUE ENTRY.
*         DQHEAD = DRIVER QUEUE HEADER.
*         EI     = QUEUE ENTRY INDEX.
*         MLPRTN = MAIN LOOP RETURN ADDRESS.
*         QF     = CURRENT DRIVER QUEUE ENTRY FLAGS WORD.
*         QI     = QUEUE INDEX.
*         RSPBUF = RESPONSE FLAGS.
*
** OUTPUT -
*         UQEA   = ZERO.
*
** USES   - T1, T2, T11.
*
** CALLS  - RSP.

 UQE      BSS    0           ENTRY (NO RETURN)
          LDML   RSPBUF+/FSSR/P.SRFL  RESPONSE FLAGS
          LPK    SRF.INQ
          NJN    UQE1        IF INQUIRY, RESPONSE ONLY, NO QUEUE ENTRY UPDATE
          LDDL   EI          CURRENT QUEUE ENTRY INDEX
          NJN    UQE2        IF QUEUE ENTRY
 UQE1     LJM    UQE6        RESPONSE ONLY, QUEUE ENTRY INDEX UNKNOWN

 UQE2     LDML   DQHEAD+/DQH/P.SQTYP
          SHN    2+/DQH/L.SQTYP
          MJN    UQE3        IF SERVER TO CLIENT QUEUE TYPE
*
*         QUEUE TYPE = CLIENT TO SERVER.
*
          LDDL   QF          CURRENT QUEUE ENTRY FLAGS
          LPK    ERRALT+BUFRCV+DATRCV
          NJN    UQE4        IF BUFFER AND/OR DATA RECEIVED, OR ERROR
          UJN    UQE5        WRITE QUEUE ENTRY TO CM
*
*         QUEUE TYPE = SERVER TO CLIENT.
*
 UQE3     LDDL   QF          CURRENT QUEUE ENTRY FLAGS
          LPK    ERRALT+DATSNT+BUFRCV+DATRCV
          NJN    UQE4        IF DATA SENT, BUFFER/DATA RECEIVED, ERROR
          LDDL   QF
          LPK    ACTIVE      CLEAR ALL FLAGS EXCEPT 'ACTIVE'
          STDL   QF
          UJN    UQE5

 UQE4     LDDL   QF          CURRENT QUEUE ENTRY FLAGS
          LMK    PRORSP      PROCESS SERVER RESPONSE (MAY ACTIVATE SUBSYSTEM)
          LPK    -DRIVER     INSURE DRIVER ACTION IS CLEAR
          STDL   QF
*
*         WRITE QUEUE ENTRY FIRST WORD TO CM.
*
 UQE5     LDDL   QF          CURRENT QUEUE ENTRY FLAGS
          STML   DQENTR+/DQE/P.ACTIVE  UPDATE QUEUE ENTRY FLAG WORD
          LDDL   QI          DRIVER QUEUE INDEX
          SHN    2           *4 = PP WORD INDEX INTO DQDIR
          STDL   T1          SAVE DQDIR INDEX (4 WORDS/ENTRY)
          LDDL   EI          DRIVER QUEUE ENTRY INDEX
          SHN    2           *4 = FOUR CM WORDS PER ENTRY
          STDL   T2          SAVE OFFSET TO QUEUE ENTRY
          LDN    1
          STDL   T11         (NUMBER OF CM WORDS TO WRITE)
          LOADR  DQDIR-4,T1  CM ADDRESS OF DRIVER QUEUE
          ADDL   T2          PLUS CM WORD OFFSET TO QUEUE ENTRY
          CWML   DQENTR,T11  WRITE DRIVER QUEUE ENTRY FIRST WORD TO CM
          LDDL   QF          CURRENT QUEUE ENTRY FLAGS
          SHN    2+/DQE/L.PRORSP
          PJN    UQE7        IF NO SERVER RESPONSE TO BE WRITTEN
 UQE6     RJM    RSP         WRITE SINGLE WORD RESPONSE/INTERRUPT
 UQE7     LJM    0,MLPRTN    RETURN TO MAIN LOOP
          TITLE  SUBROUTINES
CBC       SPACE 4,42
** CBC -  CONVERT BYTE COUNT TO CHANNEL WORD COUNT.
*
** PURPOSE -
*         MULTIPLY BYTE COUNT BY 2/3 AND ROUND UP.
*
** INPUT -
*         (A)    = NUMBER OF CM WORDS.
*
** OUTPUT -
*         (A)    = NUMBER OF 12 BIT CHANNEL WORDS.
*         CC     = NUMBER OF 12 BIT CHANNEL WORDS.
*
** USES - T1, T2.

 CBC4     BSS    0           ZERO CHANNEL WORDS

 CBC      SUBR               ENTRY/EXIT
          ZJN    CBC4        IF ZERO CM COUNT
          SHN    3           *8 FOR BYTE COUNT
          STDL   T1          8 BIT BYTE COUNT
          LDK    3           DIVIDE BY 3
          SHN    14
          STDL   T2
          LDN    0           CLEAR CHANNEL COUNT
          STDL   CC

*         DIVIDE LOOP.

 CBC1     LDDL   CC
          SHN    1
          STDL   CC
          LDDL   T1
          SBDL   T2
          MJN    CBC2
          STDL   T1
          AODL   CC          INCREMENT CHANNEL COUNT
 CBC2     LDDL   T2
          SHN    -1
          STDL   T2
          NJN    CBC1        THIS CHECK WILL MULTIPLY BY 2
          LDDL   T1
          ZJN    CBC3        IF NO NEED TO ROUND UP
          AODL   CC          ROUND UP IF REMAINDER
 CBC3     LDDL   CC          NUMBER OF 12 BIT CHANNEL WORDS
          RETURN
CFR       SPACE  4,30
** CFR -  CLEAR ESM FLAG REGISTER.
*
** PURPOSE -
*         CLEAR THE ESM FOUR BIT FLAG REGISTER, THEREBY REMOVING
*         RECEIVE REQUEST FROM QUEUE.
*
** INPUT -
*         (A)    = ESMADR OFFSET TO SOURCE/DESTINATION ESM ADDRESSES.
*
** OUTPUT -
*         (A)    = ZERO, IF ESM FLAG REGISTER CLEARED.
*                = NON ZERO, IF ERROR.
*
** USES - T1, T3, T4.
*
** CALLS - ERR, FOP.

 CFR1     RJM    ERR         RECORD ERROR

 CFR      SUBR               ENTRY/EXIT
          STDL   T1          SAVE FWA OF ESM ADDRESSES
          LDK    FF.CLR      SELECTIVE CLEAR FLAG FUNCTION
          STDL   T4
          LDK    FR.XXX+FR.HLD+FR.RDY+FR.RSV  CLEAR ALL SOURCE FLAGS
          STDL   T3          FLAG WORD
          LDML   ESMADR+/EMA/P.FRG,T1  ESM FLAG REGISTER ADDRESS
          RJM    FOP         PERFORM ESM FLAG FUNCTION
          NJN    CFR1        IF ERROR ON FLAG CLEAR OPERATION
          RETURN
CIQ       EJECT
** CIQ -  CHECK FOR IDLE QUEUE AND INACTIVE QUEUE ENTRY.
*
** PURPOSE -
*
** INPUT -
*         DQHEAD - DRIVER QUEUE HEADER.
*         QF     - DRIVER QUEUE ENTRY FLAGS.
*
** OUTPUT -
*         (A) = ZERO, IF QUEUE IS NOT IDLE AND QUEUE ENTRY IS ACTIVE.
*             = IE.E14, IF QUEUE IS IDLE.
*               IE.E15, IF QUEUE ENTRY IS INACTIVE.
*
** CALLS - ERR.

 CIQ1     LDK    IE.E14      ** QUEUE IDLE ERROR CODE **
          UJN    CIQ3        RECORD ERROR IN RESPONSE BUFFER

 CIQ2     STDL   EI          CLEAR ENTRY INDEX SO IT'S NOT EFFECTED
          LDK    IE.E15      ** INACTIVE QUEUE ENTRY ERROR CODE **
 CIQ3     RJM    ERR         RECORD ERROR IN RESPONSE BUFFER

 CIQ      SUBR               ENTRY/EXIT
          LDML   DQHEAD+/DQH/P.IDLE
          SHN    2+/DQH/P.IDLE
          MJN    CIQ1        IF QUEUE IDLE
          LDDL   QF
          LPK    ACTIVE
          ZJN    CIQ2        IF INACTIVE QUEUE ENTRY, CLEAR EI
          LDN    0           INDICATE NO ERROR
          RETURN
CPR       EJECT
** CPR -  CHECK FOR PP REQUEST.
*
** PURPOSE -
*         DETERMINE IF THERE ARE ANY PP REQUESTS TO PROCESS.
*         IF THERE ARE, LOAD AND EXECUTE OVERLAY.
*
** INPUT - NONE.
*
** OUTPUT - NONE.
*
** CALLS - LOV, PPR.
*
** USES - P1 THRU P4

 CPR      BSS    0           ENTRY
          LOADC  CM.PIT      CM ADDRESS TO A AND R FOR READ
          ADK    /PIT/C.PPQ  OFFSET TO NEXT PP REQUEST RMA
          CRDL   P1          READ NEXT PP REQUEST RMA FROM PIT
          LDDL   P3          GET FIRST HALF OF RMA OF 1ST REQUEST
          ADDL   P4          PLUS SECOND HALF
          NJN    CPR1        IF PP REQUEST QUEUED
          LJM    0,MLPRTN    TO MAIN LOOP, NO REQUESTS FOUND

 CPR1     RJM    LOV         LOAD PP OVERLAY
          LJM    PPR         PROCESS PP REQUEST

CIO       EJECT
** CIO -  CHANNEL INPUT/OUTPUT.
*
** PURPOSE -
*         PERFORM NON-DMA INPUT/OUTPUT WITH ESM.
*
** INPUT -
*         (A)    = LOCATION OF STARTING ESM ADDRESS.
*         PC     = FIRST PAGE REMAINING LENGTH TO READ/WRITE (CM WORDS).
*         RC     = REQUESTED NUMBER OF CM WORDS TO INPUT FROM CHANNEL.
*
** OUTPUT -
*         (A)    = ZERO, IF NO ERROR.
*                = ERROR CODE, IF ERROR.
*         AC     = ACTUAL CM WORD COUNT INPUT FROM CHANNEL.
*         OVLWIPE= NONZERO, OVERLAY WIPED OUT.
*         RC     = REQUESTED CM WORD COUNT TO INPUT FROM CHANNEL.
*
** USES - T6, T9.
*
** CALLS - CBC, FCN, PST, RWI, VLN.

 CIOX     EQU    *           INSUFFICIENT BUFFER SPACE ERROR EXIT

 CIO      SUBR               ENTRY/EXIT
          STDL   EMA         SAVE POINTER TO STARTING ESM ADDRESS
          STML   CIOA        STORE LOCATION OF STARTING ESM ADDRESS
          ADC    -DESMAD
          MJN    CIO1        IF INPUT FROM ESM OPERATION
          LDK    FC.WRT      ESM WRITE FUNCTION
          STDL   T6          FUNCTION CODE
          LDML   ICRM.WC     READ CM WC LONG WORDS INSTRUCTION
          UJN    CIO2

 CIO1     BSS    0
          RJM    VLN         VERIFY INDIRECT LIST BYTE LENGTHS
          NJN    CIOX        IF INSUFFICIENT BUFFER SPACE ERROR
          LDK    FC.RED      ESM READ FUNCTION
          STDL   T6          FUNCTION CODE
          LDML   ICWM.WC     WRITE CM WC LONG WORDS INSTRUCTION

*         INITIALIZE WORD COUNTERS, FUNCTION ESM, AND SEND ESM ADDRESS.
 CIO2     BSS    0
          STML   RWIA        ** MODIFY INSTRUCTION IN *RWI* **
          STML   OVLWIPE     SET OVERLAY WIPED OUT FLAG

 CIO3     BSS    0           ATTEMPT ERROR RECOVERY FROM THIS POINT
          LDDL   RC          REQUESTED CM WORD COUNT
          STDL   XC          NUMBER OF CM WORDS TO TRANSFER
          LDML   INDLST+1    FIRST PAGE NUMBER OF BYTES
          SHN    -3          /8 FOR NUMBER OF CM WORDS
          STDL   PC          NUMBER OF CM WORDS LEFT TO READ/WRITE
          LDN    0           CLEAR
          STDL   LI          RESET INDIRECT LIST ENTRY INDEX
          STDL   AC          ACTUAL CM WORD COUNT TRANSFERRED
          LDDL   T6          ESM READ OR WRITE FUNCTION
          RJM    FCN         FUNCTION CHANNEL
          ZJN    CIO4        IF NO FUNCTION TIMEOUT ERROR
          LJM    CIO14       SKIP PORT STATUS, CHECK RECOVERY

 CIO4     ACN    CH40
          LDN    3           THREE BYTES
          STDL   XBC         ESM ADDRESS TRANSFER BYTE COUNT
          LDN    2           (TWO 12 BIT PP WORDS)
          OAM    *,CH00      OUTPUT ESM STARTING ADDRESS (12 BIT)
 CIOA     EQU    *-1         (LOCATION OF ESM ADDRESS)

*         INPUT/OUTPUT LOOP.
 CIO5     BSS    0
          LDC    IOBUFL      BUFFER SIZE IN CM WORDS
          SBDL   XC          NUMBER OF CM WORDS TO I/O
          PJN    CIO6        IF ENOUGH SPACE IN BUFFER
          RADL   XC          REDUCE TO FIT IN BUFFER
 CIO6     LDDL   T6          CHECK IF READ (5001) OR WRITE (5002) FUNCTION
          SHN    17-1        (TEST WRITE 5002)
          PJN    CIO9        IF ESM READ OPERATION (5001)

*         WRITE ESM.
          RJM    RWI         READ CM VIA INDIRECT LIST INTO IOBUF
          LDDL   XC          NUMBER OF CM WORDS TO WRITE TO ESM
          SHN    3           CONVERT TO BYTE COUNT
          STDL   XBC
          SHN    -3          BACK TO CM WORDS COUNT
          RJM    CBC         CONVERT TO 12 BIT CHANNEL COUNT
          OAPM   IOBUF,CH00  OUTPUT PACKED ON CHANNEL
 CIO7     IJM    CIO8,CH00   CHANNEL INACTIVE ERROR
          FJM    CIO7,CH00   WAIT FOR CHANNEL EMPTY
          UJN    CIO11       CHECK END OF TRANSFER

 CIO8     BSS    0           INACTIVE CHANNEL
          STDL   RB          SAVE RESIDUAL BYTE COUNT
          LDK    ER.INA      ** CHANNEL INACTIVE ERROR **
          UJN    CIO13       CHECK DETAILED PORT STATUS

*         READ ESM.
 CIO9     BSS    0
          LDDL   XC          NUMBER OF CM WORDS READ FROM ESM
          SHN    3           CONVERT TO BYTE COUNT
          STDL   XBC
          SHN    -3          BACK TO CM WORDS COUNT
          RJM    CBC         CONVERT TO 12 BIT CHANNEL COUNT
          IAPM   IOBUF,CH00  INPUT PACKED FROM CHANNEL
 CIO10    IJM    CIO8,CH00   IF CHANNEL INACTIVE ERROR
          EJM    CIO10,CH00  IF CHANNEL EMPTY, WAIT FOR FULL
          RJM    RWI         WRITE IOBUF TO CM VIA INDIRECT LIST

*         CHECK FOR END OF TRANSFER.
 CIO11    BSS    0
          LDDL   XC          NUMBER OF WORDS TRANSFERED
          RADL   AC          UPDATE ACTUAL TRANSFER COUNT
          LDDL   T7          END OF LIST FLAG
          NJN    CIO12       IF END OF LIST ENCOUNTERED
          LDDL   RC          REQUESTED COUNT
          SBDL   AC          TRANSFERED COUNT
          ZJN    CIO12       IF ALL CM WORDS TRANSFERRED
          STDL   XC          NUMBER OF CM WORDS LEFT TO TRANSFER
          UJK    CIO5        CONTINUE TRANSFER

 CIO12    DCN    CH40        DISCONNECT CHANNEL
          LDN    0           NO CHANNEL FAILURE
          CFM    CIO13,CH00  IF CHANNEL ERROR FLAG NOT SET (ELSE CLEAR FLAG)
          LDK    ER.CPE      ** CHANNEL PARITY ERROR CODE **

*         CHECK FOR ESM ERRORS.

 CIO13    STDL   T9          SAVE POSSIBLE INACTIVE CHANNEL ERROR
          RJM    PST         CHECK PORT STATUS
          LPK    ERCODM      MASK FOR ERROR CODES
          NJN    CIO14       IF DETAILED ERROR CODE
          LDDL   T9          (POSSIBLE INACTIVE CHANNEL ERROR)
 CIO14    BSS    0
          RECOVER  CIO3      CHECK ERROR RECOVERY STATUS
          RETURN
ENG       EJECT
** ENG  - ENGINEERING ERROR LOG STATISTICS COLLECTIONS.
*         This subroutine builds the error log PP response. Information
*         contained in this response will be used to make an entry into
*         the Engineering Error Log.
*
** CALLING SEQUENCE -
*         MUST USE RECOVER MACRO.
*
** INPUT -
*         (A)    = Contents of 'A' register at recovery point (error code).
*
** OUTPUT - (see ERROR LOG PP RESPONSE).
*         (A) = SAME AS ON ENTRY.
*
** USES -  NONE.
*
** CALLS - EOF, EON, FCN, LOV, RSP, WED.
*
** ERROR LOG PP RESPONSE -
*
*  REC    = Recovered status (1=RECOVERED, 0=UNRECOVERED).
*  CNT    = Retry attempt count.
*  ERR    = Initial failure condition code.
*  LCF    = Last function issued on channel prior to failure.
*  LPF    = ESM LSP function code -
*            upper 4 bits = C170 ICI function code,
*            lower 12 bits = ESM LSP function code.
*  LPS    = ESM LSP status at time of initial failure.
*
*  ADR    = ESM first word address.
*  RBC    = Residual channel word count after block I/O instruction.
*  XBC    = Transfer byte count.
*
*  TRC    = CY170 DMA ADAPTER 'T' register contents -
*            1. CM byte count
*            2. most significant CM address bits
*            3. least significant CM address bits
*  ADF    = CY170 DMA ADAPTER function code.
*  CRC    = CY170 DMA ADAPTER Control Register contents.
*  AES    = CY170 DMA ADAPTER error status.
*  OPS    = CY170 DMA ADAPTER Operational Status Register contents.
*

 ENG7     BSS    0           RETRY OPERATION EXIT
          LDDL   ELEC
          SHN    18-1        RESTORE ENTRY CONDITION


 ENG      SUBR               ENTRY/EXIT
 ENGA     EQU    *-1         (RETURN ADDRESS INCREMENTED BY 2 IF NO RETRY)

          SHN    1           PRESERVER SIGN BIT ON ENTRY
          STDL   ELEC        (ENGINEERING LOG ENTRY CONDITION)
          LJM    0,ENGPA     (JUMP TO TAG *ENGOFF* OR *ENGON*)

*
*         PROCESSING ADDRESS WHEN COLLECTION MODE TURNED ON.
*
 ENGON    BSS    0           PROCESS ENTRY WHEN CURRENTLY IN COLLECTION MODE
          LDDL   ELEC        ENTRY CONDITION
          SHN    18-1        RESTORE TO ORIGINAL FORM
          MJN    ENG5        IF ABORT BIT FROM FLAG OPERATION (NO ERROR)
          ZJN    ENG5        IF NO ERROR CODE

 ENG1     BSS    0           (UNUSED TAG)
 ENG2     BSS    0           (UNUSED TAG)

*         THE ERROR PERSISTS, CLEAR THE HARDWARE.
 ENG3     BSS    0
 ENGB     UJN    ENG4        (CHANGE TO PASS IF CY930)

          RJM    CIC         MASTER CLEAR CY930 ICI CHANNEL

 ENG4     BSS    0
 ENGC     EQU    *           (ICI.12B FUNCTION ADDED TO LSP FUNCTION IF CY930)
          LDC    FC.PMC      ESM LOW SPEED PORT MASTER CLEAR FUNCTION
          RJM    FCN         (IGNORE TIMEOUT IF ANY)

          AOML   ENGRSP+/ENGRSP/P.CNT  INCREMENT RETRY COUNT
          LPN    77B         (RETRY COUNT FIELD)
          LMN    ERETRY      (MAXIMUN ERROR RETRY COUNT)
          NJK    ENG7        IF NOT MAXIMUM NUMBER OF ATTEMPTS TO RECOVER
          LDK    ERF.URE     UNRECOVERED ERROR FLAG
          RAML   ENGRSP+/ENGRSP/P.URE  SET UNRECOVERED ERROR FLAG

 ENG5     BSS    0           RECOVERED FROM ERROR
          RJM    RSP         WRITE ENGINEERING RESPONSE
          RJM    EOF         TURN OFF COLLECTION MODE
          LDDL   ELEC        ENTRY CONDITION
          SHN    18-1
*         ESM DOUBLE BIT ERROR IS ONLY DETECTED ON A READ ESM OPERATION.
          LMC    ER.DBE
          NJN    ENG6        IF NOT ESM DOUBLE BIT ERROR
          RJM    LOV         LOAD OVERLAY IF NOT PRESENT
          RJM    WED         WRITE SOURCE ESM DIVISION (CLEAR ERROR ATTEMPT)

 ENG6     BSS    0           NO ERROR OR NO RETRY EXIT
          LDN    2             (INSTRUCTION MODIFICATION MUST BE 5 LOCS APART)
          RAML   ENGA        INCREMENT RETURN ADDRESS FOR NO RETRY/NO ERROR
          UJK    ENG7        RETURN

*
*         PROCESSING ADDRESS WHEN COLLECTION MODE TURNED OFF.
*
 ENGOFF   BSS    0
          LDDL   ELEC
          SHN    18-1        RESTORE ENTRY CONDITION
          MJN    ENG6        IF ABORT BIT FROM FLAG OPERATION (NO ERROR)
          ZJN    ENG6        IF NO ERROR CODE
          RJM    EON         TURN ON COLLECTION MODE
          UJK    ENG3        CLEAR HARDWARE

EOF       SPACE  4,20
** EOF - TURN OFF ENGINEERING ERROR LOG STATISTIC COLLECTION.
*         THIS SUBROUTINE INITIALIZES THE ENGINEERING RESPONSE BUFFER.
*
** INPUT - NONE.
*
** OUTPUT -
*     ENGBUF -
*       ENGRSP RECORD -
*         UNR = FALSE (ZERO), UNRECOVERED RECOVERED ERROR IF TRUE.
*         CNT = ZERO, RECOVERY RETRY ATTEMPT COUNT.
*     ENGPA = PP ADDRESS OF *ENGOFF* (OFF PROCESSING).
*     RSPA = ADDRESS OF RSPBUF RESPONSE LENGTH.
*     RSPC = ADDRESS OF RSPBUF RESPONSE BUFFER.
*
** USES - NONE.
*
** CALLS - NONE.

 EOF      SUBR               ENTRY/EXIT
          LDC    ENGOFF      INITIAL *ENG* PROCESS ADDRESS
          STDL   ENGPA       SET *ENG* PROCESSING ADDRESS TO OFF
          LDN    0           CLEAR
          STML   ENGRSP+/ENGRSP/P.URE  UNRECOVERED FLAG AND RETRY COUNT

*         MODIFY SUBROUTINE *RSP* TO WRITE RESPONSE FROM RSPBUF.
          LDC    RSPBUF
          STML   RSPC        RESTORE ADDRESS OF RESPONSE BUFFER
          ADK    /RS/P.RESPL
          STML   RSPA        RESTORE ADDRESS OF RESPONSE LENGTH

          RETURN
EON       SPACE  4,20
** EON - TURN ON ENGINEERING ERROR LOG STATISTIC COLLECTION.
*
** PURPOSE -
*         THE FIRST OCCURRENCE OF AN I/O PROCESS FAILURE HAS OCCURED.
*         THIS SUBROUTINE COLLECTS STATISTICS PERTENANT TO THE FAILURE
*         AND BUILDS THE PP STATISTICS RESPONSE.
*
** INPUT -
*     RSPBUF = INITIALIZED FILE SERVER SPECIAL RESPONSE (SEE FSSR RECORD).
*     ENGBUF -
*       FSSR RECORD -
*         SPECIAL RESPONSE FLAGS -
*           SR  = TRUE, SPECIAL RESPONSE.
*           SW  = FALSE, SINGLE WORD.
*           ERR = FALSE, ERROR RESPONSE.
*           INQ = FALSE, INQUIRY RESPONSE.
*           TPR = FALSE, TERMINATION PSEUDO RESPONSE.
*           ENG = TRUE, ENGINEERING ERROR LOG RESPONSE.
*         LEN   = B.FSSR+B.ENGRSP, SPECIAL RESPONSE LENGTH IN 8 BIT BYTES.
*         SRPAR = ZERO, SPECIAL RESPONSE PARAMETER.
*         LUN   = LOGICAL UNIT NUMBER.
*       ENGRSP RECORD -
*         UNR    = FALSE (ZERO), UNRECOVERED RECOVERED ERROR IF TRUE.
*         ADP    = FALSE (ZERO), C170 DAM ADAPTER DRIVER MODE IF TRUE.
*         CNT    = ZERO, RECOVERY RETRY ATTEMPT COUNT.
*         ERR    = ZERO, INITIAL ERROR CONDITION CODE.
*       ELEC   = SHIFTED (A) ON ENTRY TO *ENG* (INITIAL ERROR CONDITION CODE).
*       FNCA   = LAST FUNCTION ISSUED ON CHANNEL.
*       T6     = INTENDED ESM LSP FUNCTION (i.e. READ/WRITE/FLAG OPERATIONS).
*       PS     = ESM LOW SPEED PORT STATUS.
*       EMA    = FIRST PP ADDRESS CONTAINING STARTING ESM MEMORY ADDRESS.
*       RB     = RESIDUAL BYTE COUNT (LEFT OVER IF CHANNEL INACTIVE ON I/O.)
*       XBC    = TRANSFER EIGHT BIT BYTE COUNT ATTEMPTED.
*       RTRA   = C170 DMA ADAPTER T REGISTER BYTE COUNT.
*       RTRA+1 = C170 DMA ADAPTER T REGISTER UPPER BITS OF CM ADDRESS.
*       RTRA+2 = C170 DMA ADAPTER T REGISTER LOWER BITS OF CM ADDRESS.
*       T7     = C170 DMA ADAPTER INTENDED FUNCTION CODE.
*       RCRA   = C170 DMA ADAPTER CONTROL REGISTER CONTENTS.
*       RESB   = C170 DMA ADAPTER ERROR STATUS REGISTER CONTENTS.
*       ROSA   = C170 DMA ADAPTER OPERATIONAL STATUS REGISTER CONTENTS.
*
** OUTPUT -
*     ENGPA  = PP ADDRESS OF *ENGON* (ON PROCESSING)
*     ENGBUF -
*       FSSR RECORD -
*         QI    = RSPBUF+/FSSR/P.QI
*         QEI   = RSPBUF+/FSSR/P.QEI
*       ENGRSP RECORD -
*         ERR    = RESTORED (A) ON ENTRY TO *ENG*, INITIAL ERROR CONDITION CODE.
*         LCF    = (FCNA), LAST FUNCTION ISSUED ON CHANNEL.
*         LPF    = (T6), INTENDED ESM LOW SPEED PORT FUNCTION.
*         LPS    = (PS), ESM LOW SPEED PORT STATUS.
*         ADR    = ESM MEMORY FIRST WORD ADDRESS (24 BITS OCTAL).
*         RBC    = (RB), RESIDUAL BYTE COUNT.
*         XBC    = (XC), TRANSFER BYTE COUNT.
*         TRC    = (RTRA - RTRA+2), CY170 DMA ADAPTER T REGISTER CONTENTS.
*         ADF    = (T7), C170 DMA ADAPTER INTENDED FUNCTION CODE.
*         CRC    = (RCRA), C170 DMA ADAPTER CONTROL REGISTER.
*         AES    = (RESB), C170 DMA ADAPTER ERROR STATUS REGISTER.
*         OPS    = (ROSA), C170 DMA ADAPTER OPERATIONAL STATUS REGISTER.
*     RSPA = ADDRESS OF ENGINEERING RESPONSE LENGTH (EONA).
*     RSPC = ADDRESS OF ENGINEERING RESPONSE BUFFER.
*
** USES - NONE.
*
** CALLS - EOD.


 EON      SUBR               ENTRY/EXIT
          LDC    ENGON       PP ADDRESS OF *ENG* PROCESS (ON PROCESSING)
          STDL   ENGPA       SET *ENG* PROCESSING ADDRESS TO ON

*         MODIFY SUBROUTINE *RSP* TO WRITE RESPONSE FROM ENGBUF.
          LDC    ENGBUF
          STML   RSPC        SET ADDRESS OF ENGINEERING RESPONSE BUFFER
          LDC    EONB
          STML   RSPA        SET ADDRESS OF ENGINEERING RESPONSE LENGTH

          LDML   RSPBUF+/FSSR/P.QI  COPY QUEUE AND QUEUE ENTRY INDEX
          STML   ENGQQE      (TO FSSR RECORD PORTION OF RESPONSE)
          LDDL   ELEC
          SHN    18-1        RESTORE (A) ON ENTRY TO *ENG*
          STML   ENGRSP+/ENGRSP/P.ERR
          LDML   FCNA        LAST FUNCTION ISSUED ON CHANNEL
          STML   ENGRSP+/ENGRSP/P.LCF
          LDDL   T6          INTENDED ESM LSP FUNCTION
          STML   ENGRSP+/ENGRSP/P.LPF
          LDDL   PS          ESM LOW SPEED PORT STATUS
          STML   ENGRSP+/ENGRSP/P.LPS

*         FORM 21 BIT ESM ADDRESS
          LDIL   EMA         UPPER 9 BITS OF ESM ADDRESS
          SHN    18-4        RIGHT JUSTIFY UPPER 5 BITS OF 9 BIT PORTION
          STML   ENGRSP+/ENGRSP/P.ADR  STARTING ESM ADDRESS UPPER 5 BITS
          SHN    -2          POSITION LOWER 5 BITS OF UPPER 9 TO START AT BIT 12
          SCN    77B         CLEAR LEFTOVERS
          STDL   ET1         SAVE PARTIALLY FORMED 16 BIT WORD
          AODL   EMA         INCREMENT INDIRECT ADDRESS OF ESM ADDRES
          LDIL   EMA         LOWER 12 BITS OF ESM ADDRESS
          ADDL   ET1         FORM LOWER 16 BITS OF ESM ADDRESS
          STML   ENGRSP+/ENGRSP/P.ADR+1

          LDDL   RB          RESIDUAL BYTE COUNT AFTER INACTIVE CHANNEL ON I/O
          STML   ENGRSP+/ENGRSP/P.RBC
          LDDL   XBC         TRANSFER 8 BIT BYTE COUNT
          STML   ENGRSP+/ENGRSP/P.XBC

 EONA     EQU    *           (THIS RETURN JUMP IS NOP IF NOT USING DMA ADAPTER)
          RJM    EOD         COLLECT ERROR LOG INFORMATION FOR DMA ADAPTER

          RETURN


 EONB     CON    B.FSSR+B.ENGRSP  LENGTH OF ERROR LOG RESPONSE
ERR       EJECT
** ERR -  ERROR PROCESSING.
*
** PURPOSE -
*         IF (A) NON ZERO THEN -
*           STORE ERROR CONDITION CODE INTO SINGLE WORD RESPONSE
*           AND QUEUE ENTRY ERROR CODE FIELDS.
*         IF (A) ZERO THEN RETURN TO CALLER.
*
** INPUT -
*         (A)    = ERROR CONDITION CODE.
*
** OUTPUT -
*         (A)    = ERROR CONDITION CODE.
*         SINGLE WORD RESPONSE -
*            SRFL    = SRF.ERR SET (SRF.SR, SRF.SW, AND SRL.SW ALREADY SET)
*            SRPAR   = ERROR CONDITION CODE.
*         QUEUE ENTRY -
*            ERRALT = TRUE.
*            ERRCON = ERROR CONDITION CODE.

 ERR      SUBR               ENTRY/EXIT
          STDL   ER          SAVE MOST RECENT ERROR CODE
          ZJN    ERR1        IF NO ERROR
          LDML   ERR         (CALLER'S RETURN ADDRESS)
          STML   ERRA
          LDML   RSPBUF+/FSSR/P.SRFL
          LPK    SRF.ERR
          NJN    ERR1        IF ERROR PRIOR TO CURRENT

          LDK    SRF.ERR
          RAML   RSPBUF+/FSSR/P.SRFL  SET ERROR RESPONSE FLAG
          LDDL   ER
          STML   RSPBUF+/FSSR/P.SRPAR  STORE ERROR IN SINGLE WORD RESPONSE

*         (IF NO QUEUE ENTRY (EI = 0) NOTHING HURT.
          STML   DQENTR+/DQE/P.ERRCON  STORE ERROR INTO QUEUE ENTRY
          LDDL   QF          CURRENT QUEUE ENTRY FLAGS
          LMK    ERRALT      SET QUEUE ENTRY ERROR ALERT FLAG
          STDL   QF

 ERR1     LDDL   ER          RESTORE ERROR CODE TO (A)
          RETURN

 ERRA     CON    0           CALLER'S RETURN ADDRESS FOR LAST ERROR
FCN       EJECT
** FCN -  FUNCTION.
*
** PURPOSE -
*         ISSUE FUNCTION TO ESM.
*
** ENTRY - (A) = FUNCTION CODE.
*
** OUTPUT -
*         (A)    = ZERO, IF FUNCTION ISSUED WITHOUT ERROR.
*                = ERROR CODE, IF ERROR.
*                  ER.FTO - FUNCTION TIMEOUT ERROR.
*
** USES - NONE.


 FCN3     LDN    0           NO ERROR RETURN

 FCN      SUBR               ENTRY/EXIT
          STML   FCNA        SAVE FUNCTION CODE  *INSTRUCTION MODIFICATION*
          LDN    0
          STDL   RB          CLEAR RESIDUAL BYTE COUNT
          LDN    0           (MUST HAVE 5 INSTRUCTIONS BETWEEN MODIFIED INST)
          LDN    0           (MUST HAVE 5 INSTRUCTIONS BETWEEN MODIFIED INST)
          LDN    0           (MUST HAVE 5 INSTRUCTIONS BETWEEN MODIFIED INST)
 FCN1     FNC    **,CH40     ISSUE FUNCTION  *MODIFIED INSTRUCTION*
 FCNA     EQU    *-1         (FUNCTION CODE)
          LDC    77B         TIMEOUT DELAY FOR ALL FUNCTIONS
 FCN2     IJM    FCN3,CH00   IF FUNCTION ACCEPTED
          SBN    1           (COUNT DOWN TIMEOUT DELAY)
          PJN    FCN2        IF NOT TIMEOUT

          DCN    CH40        DEACTIVATE CHANNEL
          LDK    ER.FTO      ** FUNCTION TIMEOUT ERROR CODE **
          RETURN
FOP       EJECT
** FOP -  FLAG OPERATION.
*
** PURPOSE -
*         PERFORM SPECIFIED ESM 4 BIT FLAG REGISTER OPERATION.
*
**        FORMATION OF 24 BIT FLAG REFERENCE WORD
*         FOR FOUR BIT FLAG REGISTERS.
*
*         (F = FUNCTION, W = FLAG WORD, X = ADDRESS)
*
*                             1 1 1 1 1 1
*                             5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
* ESM FLAG REGISTER          ---------------------------------
* BASE ADDRESS                0 0 X X X X X X X X X X X X X X
*    - PLUS -                --------------------------------.
* ESM FLAG REGISTER          --------------------------------.
* RELATIVE ADDRESS            0 0 X X X X X X X X X X X X X X.
*    - PLUS -                ----.---------------------------.
* ESM FUNCTION       ------------.                           .--------
* AND FLAG WORD       1 F F 1 F 0.                           .W W W W
*                    .-----------.                           .-------.
*    - TO -          .           .                           .       .
*                    .1 1        .           /1 1            .       .
*                    .1 0 9 8 7 6.5 4 3 2 1 0/1 0 9 8 7 6 5 4.3 2 1 0.
* LS 12 BITS OF      ------------------------/------------------------
* TWO PP MEMORY       1 F F 1 F 0 X X X X X X/X X X X X X X X W W W W
* WORDS (2 CHAN WDS) ------------------------/------------------------
* ARE THE 24 BIT ESM                         /
* FLAG REFERENCE WORD
*
** INPUT -
*         (A)  = FLAG REGISTER ADDRESS.
*         (T3) = 4 BIT FLAG WORD.
*         (T4) = 4 BIT FLAG REGISTER FUNCTION.
*
** OUTPUT -
*         (A)  = ZERO, IF OPERATION ACCEPTED.
*              = NEGATIVE, IF FLAG OPERATION REJECTED.
*              = ERROR CODE, IF HARDWARE ERROR OCCURRED.
*
** USES - T6.
*
** CALL - FCN, PST.

 FOP      SUBR               ENTRY/EXIT
          STDL   T6          SAVE STARTING ESM ADDRESS (MAXIMUM 14 BIT ADDRESS)
          SHN    4           LEFT JUSTIFY IN 12 BITS LOWER 8 BITS ADRS
          LMDL   T3          MERGE 4 BIT FLAG WORD AND 8 BITS OF ADRS
          LPC    7777B
          STML   FOPB+1      SAVE LOWER 12 BITS OF 24 BIT OPERATION
          LDDL   T6          (STARTING ESM FLAG ADDRESS)
          SHN    -8          RIGHT JUSTIFY UPPER 6 BITS OF ADRS (END OFF SHIFT)
          LPN    77B
          LMDL   T4          MERGE 6 BIT FLAG FUNC WITH UPPER 6 OF ADRS
          STML   FOPB        SAVE UPPER 12 BITS OF 24 BIT OPERATION
          LDN    3           THREE BYTES
          STDL   XBC         ESM ADDRESS TRANSFER BYTE COUNT

*         FORM ESM ADDRESS FOR ERROR LOG RESPONSE.
          LDDL   T6          STARTING ESM ADDRESS
          LPC    7777B
          STML   FOPC+1      SAVE LOWER 12 BITS OF STARTING ESM ADDRESS
          LDDL   T6          STARTING ESM ADDRESS
          SHN    -12         RIGHT JUSTIFY REMAINING BITS
          STML   FOPC        SAVE UPPER BITS OF STARTING ESM ADDRESS
          LDC    FOPC
          STDL   EMA         SAVE POINTER TO STARTING ESM ADDRESS

 FOP1     BSS    0           ATTEMPT RECOVERY FROM THIS POINT
 FOPA     LDC    FC.FLG      FLAG FUNCTION CODE (PLUS ICI.12B IF CY930)
          STDL   T6          SAVE OPERATION FUNCTION CODE
          RJM    FCN         ISSUE FUNCTION
          NJN    FOP4        IF CHANNEL TIMEOUT ERROR
          ACN    CH40        ACTIVATE CHANNEL
          LDN    2           NUMBER OF 12 BIT WORDS
          OAM    FOPB,CH00
 FOP2     IJM    FOP5,CH00   IF CHANNEL INACTIVE ERROR
          FJM    FOP2,CH00   WAIT FOR CHANNEL EMPTY
          DCN    CH40        DEACTIVATE CHANNEL
 FOP3     BSS    0
          LDK    ER.CPE      ** CHANNEL PARITY ERROR CODE **
          SFM    FOP4,CH00   IF CHANNEL ERROR FLAG SET
          RJM    PST         READ LOW SPEED PORT STATUS
 FOP4     BSS    0
          RECOVER  FOP1      CHECK RECOVERY STATUS
          RETURN

 FOP5     BSS    0
          STDL   RB          SAVE RESIDUAL BYTE COUNT
          LDK    ER.INA      ** INACTIVE CHANNEL ERROR **
          UJN    FOP4        CHECK RECOVERY STATUS

 FOPB     BSSZ   2           24 BIT FLAG FUNCTION, ADDRESS, FLAG WORD
 FOPC     BSSZ   2           12 BITS (UPPER AND LOWER) STARTING ESM ADDRESS
IRS       EJECT
** IRS - INITIALIZE RESPONSE.
*
** PURPOSE -
*         THIS SUBROUTINE INITIALIZES THE PP BUFFER WHICH CONTAINS
*         INFORMATION USED TO CONSTRUCT THE SINGLE WORD RESPONSE
*         ENTRY WHICH WILL BE WRITTEN TO THE PP RESPONSE BUFFER ENTRY
*         AT THE IN POINTER.
*
** INPUT -
*         LU     = LOGICAL UNIT NUMBER.
*
** OUTPUT -
*         ER     = ZERO.
*         EI     = ZERO.
*         RSPBUF = SINGLE WORD RESPONSE -
*            /FSSR/P.SRFL    = SRF.SR, SRF.SW, AND SRL.SW.
*            /FSSR/P.SRPAR   = ZERO.
*            /RS/P.RESPL     = B.FSSR.
*            /RS/P.INT       = ZERO.


 IRS      SUBR               ENTRY/EXIT
          LDK    SRF.SR+SRF.SW+B.FSSR
          STML   RSPBUF+/FSSR/P.SRFL  SINGLE WORD RESPONSE FLAGS AND LENGTH
          LDN    0           CLEAR
          STDL   ER          MOST RECENT ERROR CODE
          STML   RSPBUF+/FSSR/P.SRPAR RESPONSE ERROR CONDITION CODE
          STML   RSPBUF+/FSSR/P.QI    RESPONSE QUEUE AND QUEUE ENTRY
          STDL   EI          CURRENT QUEUE ENTRY INDEX
          LDDL   LU
          STML   RSPBUF+/FSSR/P.LUN   RESPONSE LOGICAL UNIT NUMBER

*         THESE VALUES SET TO ALLOW SHARING SUBROUTINE *RSP*
*         FOR BOTH SINGLE AND MULTI WORD RESPONSES.
          LDK    B.FSSR              SINGLE WORD RESPONSE LENGTH (8 BYTES)
          STML   RSPBUF+/RS/P.RESPL  (TO SHARE *RSP* WITH PP REQ RESP)
          LDN    0                   (CLEAR INTERRUPT FLAG AND PORT)
          STML   RSPBUF+/RS/P.INT    (TO SHARE *RSP* WITH PP REQ RESP)
          RETURN
LOV       EJECT
** LOV  - LOAD OVERLAY.
*         READS PP REQUEST PROCESSING CODE FROM PP COMMUNICATION BUFFER
*         IF NOT ALREADY IN PP MEMORY.
*
** INPUT -
*         CM.CB   = REFORMATTED RMA OF PP COMMUNICATION BUFFER.
*         OVLWIPE = ZERO, IF OVERLAY ALREADY IN PP MEMORY.
*                 = NONZERO, IF OVERLAY NOT IN PP MEMORY.
*
** OUTPUT -
*         OVLWIPE = ZERO, IF OVERLAY READ INTO PP MEMORY.
*
** USES - WC.

 CM.CB    BSSZ   3           REFORMATTED CMA OF PP COMMUNICATION BUFFER

 LOV      SUBR               ENTRY/EXIT
          LDC    **          OVERLAY WIPED OUT FLAG
 OVLWIPE  EQU    *-1         (OVERLAY WIPED OUT IF NONZERO)
          ZJN    LOV1        IF OVERLAY ALREADY PRESENT
          LDK    OVLSZ       LENGTH OF OVERLAY IN CM WORDS
          STDL   WC          SAVE CPU WORD COUNT FOR CM READ
          LOADC  CM.CB       (LOAD REFORMATTED CM ADDRESS)
          CRML   OVLSA,WC    READ OVERLAY INTO PP
          LDN    0
          STML   OVLWIPE     INDICATE OVERLAY LOADED
 LOV1     RETURN
MST       EJECT
** MST -  MACHINE STATUS CHECK.
*
** PURPOSE -
*         CHECK MACHINE STATUS AS CONTAINED IN MACHINE STATUS FLAG REGISTER.
*
** INPUT -
*         ID     = MACHINE ID NUMBER.
*
** OUTPUT -
*         (A)    = IE.E13, DESTINATION MACHINE DOWN.
*                = ZERO, DESTINATION MACHINE UP.
*
** USES - T4.
*
** CALLS - MSR.

 MST1     LDK    IE.E13      ** DESTINATION MACHINE DOWN ERROR **

 MST      SUBR               ENTRY/EXIT
          LDK    FF.EQU      4 BIT FLAG REGISTER EQUALITY STATUS FUNCTION
          STDL   T4
          LDDL   ID          MACHINE ID NUMBER
          RJM    MSR         DO STATUS FUNCTION FOR MACHINE STATUS
          MJN    MST1        IF ABORT MACHINE'S ID NUMBER NOT IN STATUS FLAG
          LDN    0           MACHINE IS UP
          RETURN
MSR       SPACE  2,20
** MSR -  MACHINE STATUS REGISTER FLAG OPERATION.
*
** PURPOSE -
*         PERFORM MACHINE STATUS 4 BIT FLAG REGISTER FUNCTIONS.
*
** INPUT -
*         (A)    = MACHINE ID.
*         (T4)   = ESM 4 BIT FLAG REGISTER FUNCTION CODE.
*
** OUTPUT -
*         (A)    = (A) AS OUTPUT OF *FOP* SUBROUTINE.
*                      ZERO, IF ACCEPT,
*                      MINUS, IF ABORT,
*                      NONZERO, IF CHANNEL ERROR.
*
** USES - T1, T3.

 MSR      SUBR               ENTRY/EXIT
          STDL   T3          (USE MACHINE ID AS MASK)
          LDML   MSFLGB      BASE MACHINE STATUS FLAG REGISTER ADDRESS
          ADDL   T3          MACHINE ID NUMBER
          SBN    1           FORM MACHINE STATUS FLAG REGISTER ADDRESS
          RJM    FOP         PERFORM FLAG REGISTER OPERATION
          RETURN
PST       EJECT
** PST -  PORT STATUS.
*
** PURPOSE -
*         READ LOW SPEED PORT STATUS AND CHECK FOR ERROR.
*
*   LOW SPEED PORT STATUS BIT ASSIGNMENTS (BITS COUNTED RIGHT TO LEFT)
*
*      BIT      DESCRIPTION
*     -----    -------------
*       0        ABORT FOR A FLAG OPERATION IF BIT 1 IS CLEAR.
*                OVERFLOW ADDRESS IF BIT 1 ALSO SET.
*       1        ACCEPT FOR FLAG OPERATION OR MEMORY TRANSFER OPERATION IF
*                BIT 0 IS CLEAR.
*                OVERFLOW ADDRESS IF BIT 0 IS SET.
*       2        DOUBLR BIT ERROR.
*       3        LOW SPEED PORT IS BUSY WITH WRITE OPERATION.
*       4        CHANNEL PARITY ERROR.
*     5-8        (UNUSED)
*       9        UPPER HALF OF BUFFER MEMORY ENABLED.
*      10        HIGH SPEED DATA TRANSFER ENABLED.
*      11        (UNUSED)
*
** INPUT - NONE.
*
** OUTPUT -
*         (A)    = ZERO, IF NO ERROR DETECTED / ACCEPT.
*                = NEGATIVE, IF ABORT STATUS BIT (FLAG OPERATIONS)
*                = ERROR CODE, IF ERROR.
*                  ER.OVF - ESM ADDRESS OVERFLOW ERROR.
*                  ER.DBE - ESM DOUBLE BIT ERROR.
*                  ER.FTO - CHANNEL/FUNCTION TIMEOUT ERROR.
*                  ER.DMT - LOW SPEED PORT DEADMAN TIMEOUT.
*                  ER.CPE - CHANNEL PARITY ERROR.
*                  ER.MAP - MEMORY ADDRESS PARITY ERROR.
*         PS     = LOW SPEED PORT STATUS.
*
** CALLS - FCN.

 PST9     DCN    CH40        DEACTIVATE CHANNEL
          LDK    ER.DMT      ** LOW SPEED PORT DEADMAN TIMEOUT ERROR CODE **

 PST      SUBR               ENTRY/EXIT
          LDN    0
          STDL   PS          CLEAR SAVED ESM LOW SPEED PORT STATUS
          LDN    77B
          STML   PSTB        INITIALIZE WAIT COUNT
          LDN    2           THREE BYTES
          STDL   XBC         LOW SPEED PORT STATUS BYTE COUNT

 PST1     BSS    0
          SOML   PSTB        DECREMENT WAIT COUNT
          ZJN    PST9        IF WRITE STATUS NOT CLEAR AFTER WAITING
 PSTA     LDC    FC.STA      STATUS FUNCTION CODE (PLUS ICI.12B IF CY930)
          RJM    FCN
          NJN    PSTX        IF FUNCTION TIMEOUT ERROR
          ACN    CH40        ACTIVATE CHANNEL
          LDK    77B         DELAY COUNT
 PST2     FJM    PST3,CH00   JUMP IF CHANNEL FULL
          IJM    PST7,CH00   JUMP IF CHANNEL INACTIVE
          SBN    1
          NJN    PST2        IF WAITING
          UJN    PST9        TIME OUT ERROR

 PST3     IAN    CH40        INPUT IF ACTIVE AND FULL
          STDL   PS          SAVE STATUS
          DCN    CH40        DEACTIVATE CHANNEL
          LPK    PS.WRT      WRITE STATUS BIT
          NJN    PST1        IF WRITE STATUS SET

          LDDL   PS          LOW SPEED PORT STATUS
          LPK    PS.ABT+PS.AOV
          LMK    PS.ABT+PS.AOV
          ZJN    PST5        IF ADDRESS OVERFLOW ERROR
          LDDL   PS
          LPK    PS.DBE+PS.CPE+PS.MAP
          NJN    PST4        IF PARITY OR DOUBLE BIT ERROR

*         NO ERROR STATUS RETURN ABORT/ACCEPT BIT IN SIGN POSITION.
          LDDL   PS          ABORT/ACCEPT BIT
          LPK    PS.ABT      (THIS IS ACTUALLY A MASK BUT SERVES DOCUMENTATION)
          SHN    17          POSITION ABORT BIT 0 TO SIGN
 PSTX     RETURN

 PST4     LPK    PS.DBE
          NJN    PST6        IF DOUBLE BIT ERROR
          LPK    PS.MAP
          NJN    PST8        IF MEMORY ADDRESS PARITY ERROR
          LDK    ER.CPE      ** CHANNEL PARITY ERROR CODE **
          UJN    PSTX

 PST5     LDK    ER.OVF      ** ESM ADDRESS OVERFLOW ERROR CODE **
          UJK    PSTX

 PST6     LDK    ER.DBE      ** ESM DOUBLE BIT ERROR CODE **
          UJK    PSTX

 PST7     LDK    ER.INA      ** INACTIVE CHANNEL ERROR **
          UJK    PSTX

 PST8     LDK    ER.MAP      ** MEMORY ADDRESS PARITY ERROR **
          UJK    PSTX

 PSTB     CON    0           WAIT FOR 'WRITE STATUS TO CLEAR' COUNT
RED       EJECT
** RED -  READ PAGE DATA FROM ESM.
*
** PURPOSE -
*         IF PAGE DATA IS READ WITHOUT ERROR THE DRIVER QUEUE ENTRY
*         FLAGS (PP COPY) ARE UPDATED.
*
** INPUT -
*         QF     = CURRENT COPY OF QUEUE ENTRY FLAGS.
*         SESMAD = SOURCE ESM ADDRESSES.
*
** OUTPUT -
*         (A)    = ZERO, IF PAGE DATA READ WITHOUT ERROR.
*                = NON ZERO, IF ERROR.
*         QF     = UPDATE QUEUE ENTRY FLAGS -
*                  DATRCV (PAGE DATA RECEIVED) = SET,
*                  SNDPMT (PROMPT COMMAND)     = CLEARED.
*         RC     = NUMBER OF CM WORDS FROM ESM HEADER.
*
** CALLS - CIO/DIO, RIL.

 RED      SUBR               ENTRY/EXIT
          LDK    /DQE/P.IND  QUEUE ENTRY OFFSET TO DESCRIPTOR
          RJM    RIL         SETUP LENGTH/ADDRESS LIST
          NJN    RED1        IF INDIRECT LIST NOT VALID
          LDML   HMSG+/HMSG/P.WCD  (IF PROMPT, THIS WAS FILLED FROM /DQE/P.HWCD)
          STDL   RC          SAVE REQUESTED PAGE DATA CM WORD COUNT
          LDC    SESMAD+/EMA/P.DAT
          PAGEIO             CIO/DIO INPUT FROM ESM AND WRITE TO CM
          NJN    RED1        IF READ ERROR
          LDDL   QF          CURRENT QUEUE ENTRY FLAGS
          LPK    -SNDPMT     CLEAR PROMPT COMMAND IN CASE SET
          LMK    DATRCV      SET DATRCV EVENT FLAG
          STDL   QF
          LDN    0           NO ERROR
 RED1     RETURN
REH       EJECT
** REH -  READ ESM HEADER.
*
** PURPOSE -
*         READ THE ESM HEADER FROM ESM MEMORY.
*
** INPUT -
*         SESMAD = SOURCE ESM ADDRESSES.
*
** OUTPUT -
*         (A)    = ZERO, IF NO ERROR.
*                = NONZERO, IF HARDWARE ERROR.
*         DQHEAD = HEADER FROM ESM, INCLUDING /HMSG/ RECORD.
*
** USES - NONE.
*
** CALL - ENG, RWH.

 REH      SUBR               ENTRY/EXIT
          LDC    SESMAD+/EMA/P.HDR
          STDL   EMA         SAVE POINTER TO STARTING ESM ADDRESS

 REH1     BSS    0           ATTEMPT ERROR RECOVERY FROM THIS POINT
 REHA     LDC    FC.RED      ESM READ FUNCTION CODE (PLUS ICI.SSM IF CY930)
          RJM    RWH         READ ESM HEADER
          RECOVER  REH1      CHECK ERROR RECOVERY
          RETURN
RDQ       EJECT
** RDQ -  READ DRIVER QUEUE HEADER AND ENTRY.
*
** PURPOSE -
*         THIS SUBROUTINE VALIDATES THE QUEUE INDEX AND QUEUE ENTRY INDEX,
*         READS THE DRIVER QUEUE HEADER AND THE QUEUE ENTRY FROM CM, AND
*         AND SETS THE ESM HEADER DESTINATION AND SOURCE QUEUE AND QUEUE
*         ENTRY INDEXES INCASE A MASSAGE IS TO BE SENT FROM THIS MACHINE.
*
** INPUT -
*         (A)    = QUEUE INDEX/QUEUE ENTRY INDEX.
*
** OUTPUT -
*         (A)    = ZERO, IF QUEUE AND QUEUE ENTRY INDEX VALID.
*                = IE.E16, IF ZERO QUEUE RMA.
*                = IE.E09, IF INVALID QUEUE INDEX.
*                = IE.E10, IF INVALID QUEUE ENTRY INDEX.
*         DQENTR = DRIVER QUEUE ENTRY RECORD.
*         DQHEAD = DRIVER QUEUE HEADER RECORD -
*                  /DQH/P.DQEI = SOURCE QUEUE ENTRY INDEX.
*                  /DQH/P.SQEI = SOURCE QUEUE ENTRY INDEX.
*         EI     = ZERO, IF INVALID QUEUE OR QUEUE ENTRY INDEX.
*                = QUEUE ENTRY INDEX, IF VALID QUEUE AND QUEUE ENTRY INDEX.
*         QI     = QUEUE INDEX.
*         QF     = CURRENT COPY OF DRIVER QUEUE ENTRY FLAG WORD.
*         (RSPBUF) - INTERRUPT FLAG AND PORT.
*                  - QUEUE INDEX AND QUEUE ENTRY INDEX.
*
** CALLS - ERR.
*
** USES - T1, T2.

 RDQ1     LDK    IE.E16      ** ZERO QUEUE ADDRESS ERROR CODE **
          UJN    RDQ4        RECORD ERROR

 RDQ2     LDK    IE.E09      ** INVALID QUEUE INDEX ERROR CODE **
          UJN    RDQ4        RECORD ERROR

 RDQ3     LDK    IE.E10      ** INVALID QUEUE ENTRY INDEX ERROR CODE **
 RDQ4     RJM    ERR         RECORD ERROR

 RDQ      SUBR               ENTRY/EXIT
          STDL   T1          SAVE QI/QEI
          LPK    377B        GET QEI
          STDL   T2          SAVE QEI
          LDDL   T1
          SHN    /DQH/L.DQI-/DQH/L.DQEI  RIGHT JUSTIFY QI
          LPK    377B
          STDL   QI          SAVE QUEUE INDEX
          ZJK    RDQ2        IF QUEUE INDEX ZERO, ERROR
          SHN    2           QI*4 = PP WORD INDEX INTO DQDIR
          STDL   T1          SAVE DQDIR INDEX (4 PP WORDS/ENTRY)
          LDC    *           NUMBER OF QUEUES
 RDQA     EQU    *-1         (NUMBER OF QUEUES SET AT INITIALIZATION TIME)
          SBDL   QI
          MJK    RDQ2        IF QUEUE INDEX .GT. NUMBER OF QUEUES, ERROR
          LDML   DQDIR-4,T1  RMA UPPER OF QUEUE
          ADML   DQDIR-4+1,T1  RMA LOWER OF QUEUE
          ZJK    RDQ1        IF REFERENCE TO NON EXISTANT QUEUE

          LDK    C.DQH       DRIVER QUEUE HEADER LENGTH IN CM WORDS
          STDL   WC
          LOADR  DQDIR-4,T1  CM ADDRESS OF DRIVER QUEUE
          STDL   CM+2        SAVE (A) OF CM ADDRESS
 ICRM.WC  EQU    *           (INSTRUCTION READ FROM CM WC LONG WORDS)
          CRML   DQHEAD,WC   READ DRIVER QUEUE HEADER

          LDML   DQHEAD+/DQH/P.NQE  NUMBER OF QUEUE ENTRIES
          SBDL   T2          (QEI)
          MJK    RDQ3        IF INVALID QUEUE ENTRY INDEX
          LDK    C.DQE       DRIVER QUEUE ENTRY LENGTH IN CM WORDS
          STDL   WC
          LDDL   T2          (QEI)
          ZJK    RDQ3        IF QUEUE ENTRY INDEX ZERO, ERROR

          STDL   EI          STORE QUEUE ENTRY INDEX
          SHN    2           *4 = FOUR CM WORDS PER ENTRY
          ADDL   CM+2        PLUS FWA OF DRIVER QUEUE
          LMK    400000B     SET RELO BIT
          CRML   DQENTR,WC   READ DRIVER QUEUE ENTRY

*
*         SET DESTINATION QUEUE ENTRY INDEXES
*         INTO HEADER FOR OUTPUT TO ESM HEADER AREA.
*
          LDML   DQHEAD+/DQH/P.DQI  DESTINATION QUEUE INDEX
          LPK    -377B       SAVE DESTINATION QUEUE INDEX
          ADDL   EI          PLUS SOURCE QUEUE ENTRY INDEX
          STML   DQHEAD+/DQH/P.DQEI  SET DESTINATION QI/QEI FOR ESM HDR

*
*         SET SOURCE QUEUE ENTRY INDEXES
*         INTO HEADER FOR OUTPUT TO ESM HEADER AREA,
*         AND QI/QEI, INTERRUPT FLAG/PORT FOR SINGLE WORD RESPONSE.
*
          LDDL   QI          SOURCE QUEUE INDEX (ON THIS MACHINE)
          SHN    /DQH/L.SQEI (LEFT JUSTIFY QUEUE INDEX)
          ADDL   EI          ADD QUEUE ENTRY INDEX
          STML   DQHEAD+/DQH/P.SQI   SET SOURCE QI/QEI FOR ESM HEADER
          STML   RSPBUF+/FSSR/P.QI   SET SOURCE QI/QEI FOR ONE WORD RESPONSE
          LDML   DQHEAD+/DQH/P.INT   INTERRUPT FLAG AND PORT
          STML   RSPBUF+/RS/P.INT    (TO SHARE *RSP* WITH PP REQ RESP)
          LDML   DQENTR+/DQE/P.ACTIVE  DRIVER QUEUE ENTRY FLAG WORD
          STDL   QF          CURRENT COPY OF QUEUE ENTRY FLAGS
          LDN    0           NO ERROR
          RETURN
RIL       EJECT
** RIL -  READ INDIRECT LIST.
*
** PURPOSE -
*         READ INDIRECT ADDRESS LIST INTO *INDLST*.
*
** INPUT -
*         (A)    = DQENTR OFFSET OF ADDRESS DESCRIPTOR.
*
** OUTPUT -
*         (A)    = ZERO, IF NO ERROR.
*                = ERROR CODE, IF INVALID ADDRESS OF LIST LENGTH.
*         AI     = PP WORD OFFSET INTO DQENTR FOR  THE
*                  ADDRESS DESCRIPTOR TO BE USED.
*         INDLST = INDIRECT LIST (LENGTH/RMA),
*                  WITH LENGTH IN BYTES,
*                  UNFORMATTED RMA'S.
*         LL     = INDIRECT LIST LENGTH IN PP WORDS.
*
** CALLS - VIL.

 RIL4     LDK    IE.E03      ** INVALID ADDRESS SPECIFICATION **

 RIL      SUBR               ENTRY/EXIT
          STDL   AI          SAVE ADDRESS DESCRIPTOR INDEX
          LDML   DQENTR+2,AI
          ADML   DQENTR+3,AI
          ZJN    RIL4        IF ZERO RMA ERROR
          LDML   DQENTR+3,AI   LOWER HALF OF RMA
          LPN    7
          NJN    RIL4        IF NOT ON CM WORD BOUNDRY
          LDML   DQENTR,AI   INDIRECT ADDRESS FLAG
          SHN    2+/DQE/L.IND
          MJN    RIL1        IF INDIRECT LIST

          LDN    0
          STML   INDLST      CLEAR FLAG/COMMAND FIELD
          LDML   DQENTR+1,AI
          STML   INDLST+1    LENGTH IN BYTES
          LDML   DQENTR+2,AI
          STML   INDLST+2    RMA PART 1
          LDML   DQENTR+3,AI
          STML   INDLST+3    RMA PART 2
          LDN    4
          STDL   LL          LIST LENGTH IN PP WORDS
          UJN    RIL2        VERIFY ADDRESS

 RIL1     LDML   DQENTR+1,AI   GET LENGTH OF INDIRECT LIST IN BYTES
          LPN    7           MASK OFF LOWER THREE BITS
          NJN    RIL3        ERROR IF LENGTH NOT A MULTIPLE OF 8

          LDML   DQENTR+1,AI   GET LENGTH OF INDIRECT LIST IN BYTES
          SHN    -1          /2 FOR PP WORD COUNT
          STDL   LL          SAVE INDIRECT LIST LENGTH IN PP WORDS
          SHN    -2          /4 FOR LIST LENGTH IN CM WORDS
          STDL   WC
          ZJN    RIL3        ERROR IF LENGTH OF INDIRECT LIST IS ZERO
          ADC    -MAXIND-1   SUBTRACT 1 MORE THAN MAX ALLOWED INDIRECTS
          PJN    RIL3        ERROR IF TOO MANY INDIRECTS

*         READ INDIRECT LIST INTO INDLST.

          LOADF  DQENTR+2,AI   SET UP CM ADDRESS IN A AND R
          CRML   INDLST,WC   READ INDIRECT LIST
 RIL2     RJM    VIL         VERIFY INDIRECT LIST
 RILX     RETURN

 RIL3     LDK    IE.E02     ** INVALID LENGTH IN COMMAND **
          UJN    RILX
RSP       EJECT
** RSP -  RESPONSE.
*
** PURPOSE -
*         WRITE RESPONSE TO CM RESPONSE BUFFER.
*
** INPUT -
*         RSPBUF - FOR SINGLE WORD RESPONSE -
*                  /FSSR/      = FILE SERVER SPECIAL RESPONSE RECORD.
*                  /RS/P.RESPL = 8, RESPONSE LENGTH.
*                  /RS/P.INT   = INTERRUPT SELECTOR FROM QUEUE HEADER.
*                  /RS/P.PORT  = PORT NUMBER FROM QUEUE HEADER.
*
*                - FOR PP REQUEST RESPONSE -
*                  /RS/ = PP REQUEST RESPONSE RECORD.
*
** USES - CM+2, INP THRU INP-3, WC.

 CM.INT   BSSZ   3           REFORMATTED CM ADDRESS OF INTERRUPT WORD.
 CM.RS    BSSZ   3           REFORMATTED CM ADDRESS OF PP RESPONSE BUFFER


 RSP      SUBR               ENTRY/EXIT

*         READ IN AND OUT POINTERS OF RESPONSE BUFFER.
 RSP1     LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADK    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   OUTP-3      READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF 'IN' POINTER
          CRDL   INP-3       READ 'IN' POINTER

*         CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.
          LDDL   INP
          SBDL   OUTP
          MJN    RSP2        IF IN .LT. OUT
          LDDL   RSLIM       RESPONSE BUFFER LIMIT OFFSET IN BYTES
          RADL   OUTP        IN .GE. OUT, SET OUT = OUT + LIMIT
 RSP2     LDML   RSPBUF+/RS/P.RESPL  GET RESPONSE LENGTH
 RSPA     EQU    *-1         (ADDRESS OF RESPONSE LENGTH)
          STML   RSPB        SAVE RESPONSE LENGTH
          STDL   INP-3       (RESPONSE LENGTH)
          SBDL   RSLIM       RESPONSE BUFFER LIMIT
          ZJN    RSP3        IF RESPONSE FITS INTO BUFFER
          PJN    *           RESPONSE IS TOO LARGE FOR BUFFER, HANG ***
 RSP3     BSS    0
          LDDL   INP         (CURRENT IN POINTER)
          RADL   INP-3       FORM NEW IN POINTER (RESPONSE LENGTH + CURRENT IN)
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          PJK    RSP1        IN NOT ENOUGH ROOM IN BUFFER, LOOP

          LDDL   INP-3       NEW IN POINTER IN BYTES
          SBDL   RSLIM       RESPONSE BUFFER LIMIT
          MJN    RSP4        IF NEW IN POINTER NOT BEYOND LIMIT
          STDL   INP-3       SET NEW IN POINTER = NUMBER OF BYTES BEYOND LIMIT

*         WRITE RESPONSE TO CM.
 RSP4     BSS    0
          LDDL   INP         ('IN' POINTER IN BYTES)
          SHN    -3
          STDL   INP-1       CURRENT 'IN' POINTER IN WORDS
          LDC    **          RESPONSE LENGTH IN BYTES
 RSPB     EQU    *-1         (STORED HERE AT RSP2)
          SHN    -3          /3 CONVERT TO CM WORDS
          STDL   WC          NUMBER OF CM  WORDS FOR 1ST BLOCK
          STDL   INP-2       TOTAL RESPONSE LENGTH IN WORDS
          LDDL   INP-3       NEW IN POINTER
          SBDL   INP         MINUS OLD IN POINTER
          PJN    RSP5        IF ONLY 1 BLOCK WRITE REQUIRED (OLD IN < NEW IN)
          LDDL   RSLIM       FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   WC          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADML   RSPC        ADD FWA OF PP RESPONSE BUFFER
          STML   RSPD        RESPONSE ADDRESS FOR 2ND BLOCK WRITE

 RSP5     LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   CM+2        SAVE CM ADDRESS
          ADDL   INP-1       ADD 'IN' OFFSET (IN CM WORDS)
          CWML   RSPBUF,WC   WRITE RESPONSE TO CM
 RSPC     EQU    *-1         (PP ADDRESS OF RESPONSE BUFFER)
          LDDL   INP-2       TOTAL RESPONSE LENGTH IN WORDS
          SBDL   WC          WORDS TRANSFERRED ON 1ST BLOCK
          ZJN    RSP6        IF ONLY 1 BLOCK WRITE REQUIRED
          STDL   WC          NUMBER OF WORDS TO TRANSFER ON 2ND BLOCK
          LDDL   CM+2        LOAD ADDRESS OF RESPONSE BUFFER
          LMK    400000B
 ICWM.WC  EQU    *           (INSTRUCTION WRITE TO CM WC LONG WORDS)
          CWML   **,WC       WRITE 2ND PART OF RESPONSE TO CM
 RSPD     EQU    *-1         (PP ADDRESS OF UNWRITTEN RESPONSE)

 RSP6     LDML   RSPBUF+/RS/P.INT  CHECK IF INTERRUPT WAS SELECTED
          LPK    /RS/K.INT
          NJN    RSP7        IF INTERRUPT SELECTED
          LDC    2400B       PSN INSTRUCTION
          UJN    RSP8

*         SET UP INTERRUPT INSTRUCTION.
 RSP7     LDML   RSPBUF+/RS/P.PORT  PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RS/L.PORT+/RS/N.PORT
          LPK    /RS/M.PORT
          ADC    102600B     INPN INSTRUCTION
 RSP8     STML   RSPE

*         UPDATE RESPONSE BUFFER 'IN' POINTER IN CM.
          LDDL   INP-3       NEW IN POINTER
          STDL   INP
          LDN    0           RESTORE CM IN POINTER FIELDS
          STDL   INP-1
          STDL   INP-2
          STDL   INP-3
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADK    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   INP-3       WRITE NEW 'IN' POINTER TO CM

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD.
          CWDL   PP-3        SET LAST BYTE NON-ZERO.
          LDN    0           (6 LSB's = 0 for INPN/S0 ENG.SPEC.19269753 PAGE 43)
 RSPE     INPN   1           (INTERRUPT OR PSN INSTRUCTION)
          CRDL   INP-3       "THROW-AWAY" CM READ FOR S1
          RETURN             EXIT
RSV       EJECT
** RSV -  RESERVE DESTINATION ESM SPACE.
*
** PURPOSE -
*         RESERVES DESTINATION ESM SPACE FOR THE SPECIFIED MACHINE
*         MACHINE ID NUMBER.
** INPUT -
*         DQHEAD = DRIVER QUEUE HEADER.
*
** OUTPUT -
*         (A)    = ZERO, IF DESTINATION ESM SPACE RESERVED.
*                = NEGATIVE, IF DESTINATION SPACE NOT AVAILABLE.
*                = ERROR CODE, IF ERROR OCCURRED.
*         DESMAD = DESTINATION ESM ADDRESSES.
*         DI     = DESTINATION ESM DIVISION NUMBER.
*         ID     = DESTINATION ID NUMBER.
*
** USES - T3, T4.
*
** CALLS - ERR, FOP, MST, SEA.

 RSV4     RJM    ERR         RECORD ERROR ON FLAG OPERATION

 RSVX     EQU    *
 RSV      SUBR               ENTRY/EXIT
          LDML   DQHEAD+/DQH/P.DIDN
          STDL   ID          SAVE DESTINATION ID NUMBER
          RJM    MST         CHECK DESTINATION MACHINE STATUS
          NJN    RSV4        IF DESTINATION MACHINE DOWN
          LDN    0
          STDL   DI          INITIALIZE DIVISION NUMBER
          LDK    FR.RSV      RESERVE ESM SPACE
          STDL   T3          SAVE 4 BIT FLAG WORD
          LDK    FF.ZSL      ZERO/SELECT FLAG FUNCTION
          STDL   T4          SAVE FLAG FUNCTION

 RSV1     AODL   DI          INCREMENT DIVISION NUMBER
          ADML   TBFLGA,ID   BASE ESM FLAG REGISTER ADDRESS FOR ID
          SBN    1           ADJUST DIVISION FLAG ADDRESS
          RJM    FOP         FLAG OPERATION
          ZJN    RSV2        IF RESERVATION OBTAINED
          PJN    RSV4        IF ERROR ON FLAG OPERATION
          LDDL   DI          CURRENT DIVISION
          SBDL   NDIVS       NUMBER OF ESM DIVISIONS PER MACHINE
          NJN    RSV1        IF MORE DIVISIONS
          LDN    PS.ABT      (THIS IS ACTUALLY A MASK BUT SERVES DOCUMENTATION)
          SHN    17          RESTORE ABORT FLAG IN SIGN BIT POSITION
          UJN    RSV3        RETURN

 RSV2     LDN    DADESM      ESMADR OFFSET OF DESTINATION ESM ADDRESSES
          RJM    SEA         SETUP ESM ADDRESSES
          LDN    0           NO ERROR
 RSV3     RETURN
RWH       EJECT
** RWH -  READ / WRITE ESM HEADER.
*
** PURPOSE -
*         CODE COMMON TO READ/WRITE ESM HEADER SUBROUTINES *REH* AND *WEH*.
*
** INPUT -
*         DESMAD = DESTINATION ESM ADDRESSES (IF WRITING ESM HEADER).
*         SESMAD = SOURCE ESM ADDRESSES (IF READING ESM HEADER).
*         DQHEAD = DRIVER QUEUE HEADER WITH DESTINATION
*                  QUEUE ENTRY INDEX, FOLLOWED BY /HMSG/ RECORD.
*
** OUTPUT -
*         (A)    = ZERO, IF NO ERROR.
*                = NONZERO, IF HARDWARE ERROR.
*
** USES - T6, T9.
*
** CALL - FCN, PST.

 RWH12    BSS    0           FUNCTION TIMEOUT ERROR EXIT

 RWH      SUBR               ENTRY/EXIT
          STDL   T6          SAVE OPERATION FUNCTION CODE
          SHN    17-1        (TEST WRITE 5002)
          MJN    RWH1        IF WRITING HEADER
          LDC    SESMAD+/EMA/P.HDR  ESM ADDRESS TO READ FROM
          UJN    RWH2        (STORE ESM ADDRESS IN OUTPUT INSTRUCTION)

 RWH1     LDC    DESMAD+/EMA/P.HDR  ESM ADDRESS TO WRITE TO
 RWH2     STML   RWHA        (MODIFY ADDRESS OUTPUT INSTRUCTION)
          LDDL   T6          (FUNCTION CODE)
          RJM    FCN         ISSUE FUNCTION
          NJN    RWH12       IF FUNCTION TIMEOUT ERROR
          LDN    3           THREE BYTES
          STDL   XBC         ESM ADDRESS TRANSFER BYTE COUNT
          ACN    CH40        ACTIVATE CHANNEL
          LDN    2
          OAM    **,CH00     (INSTRUCTION MODIFIED)
 RWHA     EQU    *-1         (ESM ADDRESS SET ON ENTRY)
 RWH3     IJM    RWH11,CH00   IF CHANNEL INACTIVE ERROR
          NJN    RWH3        WAIT FOR ZERO COUNT

 RWHB     EQU    *           (DCN CH40 - MODIFIED AT INITIALIZATION IF CY930)
          UJN    RWH4        SKIP 'DCN/ACN' WHEN NOT CY930/ICI
*         THIS IS NECESSARY FOR ICI CHANNEL TO SWITCH TO PACKING MODE.
*         DCN    CH40        TO ICI CHANNEL ONLY, ESM DOES NOT SEE THIS
          ACN    CH40        TO ICI CHANNEL ONLY, ESM DOES NOT SEE THIS

 RWH4     LDK    B.HMSG      ESM HEADER BYTE COUNT
          STDL   XBC         ESM HEADER TRANSFER BYTE COUNT
          LDDL   T6          FUNCTION CODE
          SHN    17-1        (TEST WRITE 5002)
          MJN    RWH6        IF WRITING HEADER

*         READ ESM HEADER.
 RWHC     EQU    *
          LDN    EHSIZC      ESM HEADER SIZE IN 12 BIT CHANNEL WORDS
 RWHD     EQU    *           (*IAM* MODIFIED AT INITIALIZATION IF CY930)
          IAPM   DQHEAD+/DQH/P.SQTYP,CH00
 RWH5     IJM    RWH11,CH00   IF CHANNEL INACTIVE ERROR
          EJM    RWH5,CH00   WAIT FOR CHANNEL FULL
          UJN    RWH8        DEACTIVATE CHANNEL

*         WRITE ESM HEADER.
 RWH6     BSS    0
 RWHE     EQU    *           (EHSIZ - MODIFIED AT INITIALIZATION IF CY930)
          LDN    EHSIZC      ESM HEADER SIZE IN 12 BIT CHANNEL WORDS
 RWHF     EQU    *           (*OAM* MODIFIED AT INITIALIZATION IF CY930)
          OAPM   DQHEAD+/DQH/P.SQTYP,CH00
 RWH7     IJM    RWH11,CH00   IF CHANNEL INACTIVE ERROR
          FJM    RWH7,CH00   WAIT FOR ESM TO TAKE LAST WORD OFF CHANNEL

 RWH8     BSS    0
          DCN    CH40        DEACTIVATE CHANNEL
          LDN    0           CLEAR INACTIVE CHANNEL ERROR
          CFM    RWH9,CH00   IF CHANNEL ERROR FLAG NOT SET
          LDK    ER.IPE      ** IOU CHANNEL PARITY ERROR **
 RWH9     STDL   T9
          RJM    PST         GET PORT STATUS AND CHECK IF ERROR
          LPK    ERCODM      MASK FOR ERROR CODES
          NJN    RWH10       IF DETAIL ERROR CODE
          LDDL   T9          (POSSIBLE INACTIVE CHANNEL ERROR)
 RWH10    RETURN

 RWH11    STDL   RB          SAVE RESIDUAL BYTE COUNT
          LDK    ER.INA      ** INACTIVE CHANNEL ERROR **
          UJK    RWH9        CHECK DETAIL STATUS

RWI       EJECT
** RWI -  READ/WRITE INDIRECT.
*
** PURPOSE -
*         THIS SUBROUTINE FILLS/EMPTIES THE PP I/O BUFFER FROM/TO
*         THE CM BUFFER POINTED TO BY THE INDIRECT ADDRESS LIST.
*
** INPUT -
*         INDLST = LIST OF LENGTH AND RMA -
*                  LENGTHS IN BYTES,
*                  UNFORMATTED RMA'S.
*         LI     = INDIRECT LIST INDEX IN PP WORDS.
*         LL     = INDIRECT LIST LENGTH IN PP WORDS.
*         PC     = CURRENT PAGE REMAINING LENGTH IN CM WORDS.
*         XC     = NUMBER OF CM WORDS TO TRANSFER.
*         RWIA   = CM READ/WRITE INSTRUCTION MODIFIED.
*
** OUTPUT -
*         T7     = NON ZERO, IF END OF INDIRECT LIST.
*         LI     = UPDATED TO CURRENT INDIRECT LIST INDEX IN PP WORDS.
*         PC     = PAGE REMAINING LENGTH IN CM WORDS.
*         XC     = NUMBER OF CM WORDS ACTUALLY TRANSFERRED.
*
** USES - T1, T7, T8, T9.

 RWI      SUBR               ENTRY/EXIT
          LDDL   XC          REQUESTED CM WORD COUNT TO MOVE
          STDL   WC
          LDN    0           CLEAR
          STDL   T1          ACTUAL CM WORD COUNT TRANSFERRED
          STDL   T7          RESET END OF LIST FLAG
          LDC    IOBUF
          STML   RWIB        RESET IOBUF INITIAL ADDRESS

 RWI1     LDDL   PC          CHECK REMAINING PAGE LENGTH
          SBDL   WC
          PJN    RWI2        IF ENOUGH ROOM IN THIS PAGE
          RADL   WC          NUMBER OF CM WORDS LEFT FOR THIS PAGE

 RWI2     LDML   INDLST+1,LI GET PAGE LENGTH IN BYTES
          SHN    -3          /8 FOR CM WORDS
          SBDL   PC          MINUS CURRENT PAGE LENGTH IN CM WORDS
          SHN    3           *8 FOR BYTE OFFSET
          ADML   INDLST+3,LI ADD INITIAL LOWER HALF OF UNFORMATTED RMA
          STDL   T9          SAVE LOWER HALF OF RMA FOR READ/WRITE
          SHN    -16         POSITION CARRY
          ADML   INDLST+2,LI ADD INITIAL UPPER HALF OF RMA
          STDL   T8          SAVE UPPER HALF OF RMA FOR READ/WRITE
          LOADF  T8          FORMAT AND LOAD CM RMA ADDRESS

 RWIA     EQU    *           (*CIO* STORES CM READ/WRITE INSTRUCTION)
          CRML   *,WC        ** INSTRUCTION MODIFIED (READ/WRITE) **
 RWIB     EQU    *-1         (*RWI* STORES ADDRESS WITHIN PP IOBUF)

          LDDL   WC          NUMBER OF CM WORDS MOVED TO/FROM CM
          SHN    2           *4 IN PP WORDS
          RAML   RWIB        UPDATE IOBUF ADDRESS
          LDDL   PC          CURRENT PAGE REMAINING LENGTH BEFORE MOVE
          SBDL   WC          MINUS NUMBER OF CM WORDS MOVED
          STDL   PC          UPDATE PAGE REMAINING LENGTH IN CM WORDS
          NJN    RWI3        IF ANY CM WORDS LEFT IN THIS PAGE
          LDN    4           INCREMENT TO NEXT LIST ENTRY
          RADL   LI          INDIRECT LIST INDEX
          SBDL   LL          CHECK AGAINST LIST LENGTH
          PJN    RWI4        IF END OF LIST
          LDML   INDLST+1,LI NEXT PAGE LENGTH IN BYTES
          SHN    -3          /8 FOR CM WORDS
          STDL   PC          SET NEXT LIST PAGE LENGTH IN CM WORDS

 RWI3     LDDL   WC          NUMBER OF CM WORDS MOVED
          RADL   T1          UPDATE TRANSFER COUNT
          LDDL   XC          NUMBER OF CM WORDS REQUESTED TO MOVE
          SBDL   T1
          ZJN    RWI5        IF ALL CM WORDS TRANSFERRED
          STDL   WC          NUMBER OF CM WORDS LEFT TO READ/WRITE
          UJK    RWI1        CONTINUE TRANSFER

 RWI4     LDDL   T1          UPDATE TRANSFER COUNT
          ADDL   WC
          STDL   XC
          STDL   T7          SET END OF LIST FLAG
 RWI5     RETURN
SEA       EJECT
** SEA -  SETUP ESM ADDRESSES.
*
** PURPOSE -
*         SETUP ESM MEMORY FIRST WORD ADDRESSES OF FLAG REGISTER, HEADER,
*         BUFFER, AND DATA AREAS.
*         THE 17 BIT BASE ESM MEMORY ADDRESS IS INCREMENTED TO THE ADDRESS
*         OF THE BLOCK OF MEMORY ASSIGNED TO THE SPECIFIED MACHINE ID, AND
*         THEN TO THE ADDRESS OF THE SPECIFIED SUBDIVISION WITH THAT BLOCK.
*         THIS 17 BIT ADDRESS IS MULTIPLIED BY 100(8) WHEN THE 24 BIT
*         HEADER, BUFFER, AND DATA AREA BUFFERS ARE FORMED.
*
*   FORMATION OF 24 BIT ESM MEMORY REFERENCE WORD.
*
*         (X = ADDRESS BITS)
*
*                       1 1 1 1 1 1 1
*                       7 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
*                       ----------------------------------
* ESM BASE ADRS/100(8)  X X X X X X X X X X X X X X X X X
*                      .---------------------------------.
*    - PLUS -          .                                 .
*                      . --------------------------------.
* ESM RA/100(8)        .  0 0 0 0 X X X X X X X X X X X X.
*                      . --------------------------------.
*    - TO -            .                                 .
*                     1.1                    /1 1        .
*                     1.0 9 8 7 6 5 4 3 2 1 0/1 0 9 8 7 6.5 4 3 2 1 0
* LS 12 BITS OF      ------------------------/------------------------
* TWO PP MEMORY       0 X X X X X X X X X X X/X X X X X X 0 0 0 0 0 0
* WORDS (2 CHAN WDS) ------------------------/------------------------
* ARE THE 24 BIT ESM                         /
* MEMORY REFERENCE WORD
*
** INPUT -
*         (A)  = ESMADR OFFSET TO STORE ESM ADDRESSES (SESMAD/DESMAD).
*         ID   = ID NUMBER.
*         DI   = DIVISION NUMBER.
*
** OUTPUT - AT SPECIFIED ADDRESS PLUS:
*           /EMA/P.FRG = 16 BIT ESM ADDRESS OF FLAG REGISTER
*           /EMA/P.HDR = 24 BIT ESM MEMORY ADDRESS OF HEADER AREA
*           /EMA/P.BUF = 24 BIT ESM MEMORY ADDRESS OF BUFFER AREA
*           /EMA/P.DAT = 24 BIT ESM MEMORY ADDRESS OF DATA AREA
*
** USES - T2, T3.

 SEA      SUBR               ENTRY/EXIT
          STDL   T3          SAVE ESM ADDRESS STORAGE OFFSET
          LDML   TBFLGA,ID   BASE FLAG REGISTER ADDRESS PER ID NUMBER
          ADDL   DI          DIVISION NUMBER
          SBN    1           ADJUST DIVISION FLAG ADDRESS
          STML   ESMADR+/EMA/P.FRG,T3  ESM FLAG REGISTER ADDRESS

*         THIS CODE WILL ACCOMODATE A MAXIMUM BASE ESM MEMORY ADDRESS
*         OF 8,388,544 (DECIMAL).
          LDML   BMEMAD      UPPER BIT OF BASE ESM MEMORY ADDRESS/100(8)
          SHN    16-0        (POSITION UPPER BIT OF BASE ADDRESS)
          ADML   BMEMAD+1    LOWER 16 BITS OF BASE ESM MEMORY ADDRESS/100(8)
          ADML   TBMOFF,ID   BASE ESM MEMORY ADDRESS OFFSET/100(8) FOR ID NUMBER
          ADML   TDIVOF,DI   ADD DIVISION OFFSET/100(8)
          STDL   T2          (TEMP SAVE LOWER 6 BITS OF ADDRESS)
          SHN    12          POSITION UPPER 12 OF REGISTER
          LPC    7777B       (UPPER 12 BITS)
          STML   ESMADR+/EMA/P.HDR,T3  UPPER 12 BITS OF HEADER AREA ADR
          STML   ESMADR+/EMA/P.BUF,T3  UPPER 12 BITS OF BUFFER AREA ADR
          STML   ESMADR+/EMA/P.DAT,T3  UPPER 12 BITS OF DATA AREA ADR
          LDDL   T2          LOWER 6 BITS OF ADDRESS
          LPN    77B
          SHN    6                MULTIPLY BY 100B
          STML   ESMADR+/EMA/P.HDR+1,T3  LOWER 12 BITS OF HEADER AREA
          ADN    EBUFOF           ADD OFFSET TO BUFFER AREA (MAX OFFSET 77B)
          STML   ESMADR+/EMA/P.BUF+1,T3  LOWER 12 BITS OF BUFFER AREA
          ADC    EDATOF-EBUFOF    ADD OFFSET TO DATA AREA
          STDL   T2               (SAVE OVERFLOW OF 12 BITS)
          LPC    7777B            (LOWER 12 BITS)
          STML   ESMADR+/EMA/P.DAT+1,T3  LOWER 12 BITS OF DATA AREA
          LDDL   T2
          SHN    -12              POSITION POSSIBLE CARRY DIGIT (END OFF SHIFT)
          RAML   ESMADR+/EMA/P.DAT,T3    ADD TO UPPER 12 BITS OF DATA AREA
          RETURN
VIL       EJECT
** VIL -  VERIFY INDIRECT LIST.
*
** PURPOSE -
*         VERIFY INDIRECT ADDRESSES IN LIST AT *INDLST*.
*
** INPUT -
*         INDLST = INDIRECT LIST (LENGTH/RMA),
*                  WITH LENGTH IN BYTES.
*         LL     = INDIRECT LIST LENGTH IN PP WORDS.
*
** OUTPUT -
*         (A)    = ZERO, IF VALID LIST.
*                = ERROR CODE, IF INVALID LIST.
*         LI     = INDIRECT LIST INDEX INITIALIZED TO ZERO.
*         INDLST = VALIDATED UNFORMATTED RMA ADDRESSES.
*                  WITH LENGTH IN BYTES.
*         RC     = TOTAL CM WORD COUNT PROVIDED BY LIST.

 VIL2     LDK    IE.E04      ** INVALID LENGTH IN INDIRECT LIST **
          UJN    VILX        CONTINUE
 VIL3     LDK    IE.E05      ** INVALID ADDRESS IN INDIRECT LIST **
          UJN    VILX        CONTINUE
 VIL4     LDK    IE.E06      ** RESERVED FIELD IN INDIRECT LIST NOT ZERO **
 VILX     BSS    0           COMMAND SEQUENCE ERROR

 VIL      SUBR               ENTRY/EXIT

*         VERIFY LIST.  ALL ADDRESS MUST BE ON WORD BOUNDARIES AND ALL
*         LENGTHS MUST BE MULTIPLES OF 8.

          LDN    0           INITIALIZE
          STDL   LI          INDIRECT LIST INDEX
          STDL   RC          REQUESTED TOTAL CM WORD COUNT

 VIL1     LDML   INDLST+1,LI GET LENGTH FROM ADDRESS/LENGTH PAIR
          ZJN    VIL2        ERROR IF LENGTH IS ZERO
          LPN    7           MASK LOWER THREE BITS OF LENGTH
          NJN    VIL2        IF LENGTH NOT MULTIPLE OF 8 ERROR
          LDML   INDLST+1,LI GET LENGTH FROM ADDRESS/LENGTH PAIR
          SHN    -3          /8 FOR CM WORD COUNT
          RADL   RC          COMPUTE TOTAL LENGTH FOR LIST
          MJN    VIL2        ERROR IF NEG (TOO LARGE)
          LDML   INDLST+3,LI GET LOWER HALF OF ADDRESS FROM LIST
          LPN    7           MASK OFF LOWER 3 BITS OF ADDRESS
          NJN    VIL3        ERROR IF ADDRESS NOT ON WORD BOUNDRY
          LDML   INDLST,LI   GET COMMAND AND FLAG FIELDS FROM INDIRECT
          NJN    VIL4        ERROR IF NOT ZERO
          LDK    4
          RADL   LI          POINT TO NEXT ITEM IN LIST
          SBDL   LL          LIST LENGTH IN PP WORDS
          MJN    VIL1        IF NOT DONE

          LDN    0           NO ERROR
          STDL   LI          RESET INDIRECT LIST INDEX TO ZERO
          RETURN
VLN       EJECT
** VLN -  VERIFY LENGTH.
*
** PURPOSE -
*         VERIFIES THE TOTAL LENGTH PROVIDED BY ADDRESS LIST.
*         SINCE THE TOTAL CM WORD COUNT TO INPUT COMES FROM THE ESM
*         HEADER, THE TOTAL NUMBER OF BYTES MUST BE ACCOMODATED IN THE
*         INDIRECT LIST LENGTH PARAMETERS. THE LAST NEEDED INDIRECT
*         LIST ENTRY'S LENGTH IS CHANGED TO REQUIRED LENGTH FOR LAST
*         ENTRY, AND THE *LL* VALUE IS ADJUSTED SO THAT SUBROUTINE
*         *DIO* DOES NOT INPUT FROM ESM MORE THAN NEEDED.
*         THIS ADJUSTMENT HAS NO IMPACT ON SUBROUTINE *CIO* BECAUSE IT
*         COUNTS DOWN TOTAL CM WORD COUNT TO INPUT, HOWEVER, THE LENGTH
*         VERIFICATION IS A VALID OPERATION FOR *CIO*.
*
** INPUT -
*         INDLST = LIST OF LENGTH AND RMA ENTRIES
*                  (4 WORDS/ENTRY, LENGTH IN BYTES, UNFORMATTED RMA).
*         LL     = INDIRECT LIST LENGTH IN PP WORDS.
*         RC     = REQUESTED NUMBER OF CM WORDS TO INPUT FROM CHANNEL.
*
** OUTPUT -
*         (A)    = ZERO, IF NO ERROR.
*                = IE.E11 - INSUFFICIENT LENGTH SPECIFICATION.
*         INDLST = LAST INDLST ENTRY LENGTH UPDATED.
*         LL     = NEEDED INDIRECT LIST LENGTH IN PP WORDS.
*
** USES - T1, T5, T6.

 VLNX     BSS    0           ERROR EXIT
 VLN      SUBR               ENTRY/EXIT
          LDDL   RC          REQUESTED CM WORD COUNT
          STDL   T5          CURRENT REQUESTED CM WORD COUNT
          LDN    0
          STDL   T1          INITIALIZE LIST INDEX

 VLN1     LDML   INDLST+1,T1 ENTRY SIZE IN BYTES
          SHN    -3          /8
          STDL   T6          LIST ENTRY SIZE IN CM WORDS
          SBDL   T5          MINUS CURRENT REQUESTED WORD COUNT
          PJN    VLN2        IF .LE. CURRENT ENTRY LENGTH
          LDDL   T5
          SBDL   T6          DECREMENT BY LENGTH OF CURRENT ENTRY
          STDL   T5          WORDS LEFT FOR REMAINNING ENTRIES
          LDN    4
          RADL   T1          INCREMENT TO NEXT LIST ENTRY
          SBDL   LL
          MJN    VLN1        IF NOT END OF LIST ENTRIES

          LDDL   T5          CM WORDS REMAINNING
          ZJN    VLNX        IF ALL BYTES ACCOUNTED FOR
          LDK    IE.E11      ** INSUFFICIENT LENGTH SPECIFICATION ERROR **
          UJN    VLNX        ERROR RETURN

 VLN2     LDDL   T5          REMAINNING WORD COUNT
          SHN    3           *8
          STML   INDLST+1,T1 SET NUMBER OF BYTES FOR LAST ENTRY
          LDN    4
          RADL   T1
          STDL   LL          SET LIST LENGTH TO LAST ENTRY
          LDN    0           NO ERROR
          RETURN
WEH       EJECT
** WEH -  WRITE ESM HEADER.
*
** PURPOSE -
*         WRITE HEADER TO ESM, AND SET DESTINATION ESM
*         FLAG REGISTER TO READY/RESERVED.
*
** INPUT -
*         DESMAD = DESTINATION ESM ADDRESSES.
*         DQHEAD = DRIVER QUEUE HEADER WITH DESTINATION
*                  QUEUE ENTRY INDEX, FOLLOWED BY /HMSG/ RECORD.
*
** OUTPUT -
*         (A)    = ZERO, IF NO ERROR.
*                = NONZERO, IF HARDWARE ERROR.
*
** USES - T3, T4, T6.
*
** CALL - ERR, FCN, FOP, PST.

 WEH      SUBR               ENTRY/EXIT
          LDC    DESMAD+/EMA/P.HDR
          STDL   EMA         SAVE POINTER TO STARTING ESM ADDRESS

 WEH1     BSS    0           ATTEMPT ERROR RECOVERY FROM THIS POINT
 WEHA     LDC    FC.WRT      ESM WRITE FUNCTION CODE (PLUS ICI.SSM IF CY930)
          RJM    RWH         WRITE ESM HEADER
          RECOVER  WEH1      CHECK ERROR RECOVERY
          NJN    WEH2        IF ERROR ON WRITE TO ESM
*
*         SET DESTINATION ESM FLAG REGISTER READY.
*
          LDK    FF.SET      SELECTIVE SET FLAG FUNCTION
          STDL   T4
          LDK    FR.RSV+FR.RDY  SET FLAG REGISTER RESERVED AND READY
          STDL   T3
          LDML   DESMAD+/EMA/P.FRG  DESTINATION FLAG REGISTER ADDRESS
          RJM    FOP         PERFORM ESM FLAG FUNCTION
 WEH2     BSS    0
          RETURN
          TITLE  GENERAL PURPOSE SUBROUTINES
FORMA     EJECT
** FORMA - FORMAT ADDRESS.
*
** PURPOSE -
*         FORMAT A CM REAL MEMORY ADDRESS.
*
*     THE (ADDRESS), WORD 0 BITS 0-13, AND WORD 1 BITS 3-15,
*     ARE REFORMATTED TO *CM* WORD 0 BITS 0-9, WORD 1 BITS 0-11,
*     AND WORD 2 BITS 0-5.
*     THE REFORMATTED RMA CAN BE USED BY THE LOADC MACRO.
*
** CALLING SEQUENCE - LDC    ADDRESS
*                     RJM    FORMA
*
** INPUT -
*         (A)    = ADDRESS OF A 2-WORD CM BYTE ADDRESS.
*
** OUTPUT -
*         CM - CM+2 = REFORMATTED CM RMA.

 FORMA    SUBR               ENTRY/EXIT
          STDL   TA
          LDIL   TA
          LPN    37B
          SHN    16
          LMML   1,TA
          SHN    9
          STDL   CM+1
          SHN    6
          LPN    77B
          STDL   CM+2
          LDIL   TA
          SHN    -5
          STDL   CM
          LRD    CM
          LDDL   CM+2
          LMK    400000B
          RETURN
          TITLE  ADDRESS TABLES
** ESM ADDRESS TABLES.
*
* TABLE OF ESM MEMORY DIVISION OFFSETS/100B (16 BITS).

 TDIVOF   EQU    *-1         TABLE OF ESM DIVISION OFFSETS/100(8)
          BSSZ   MAXDIV      (INDEXED BY VALUES 1 THROUGH 16)


* TABLE OF BASE ESM MEMORY ADDRESS OFFSETS /100B PER ID NUMBER (16 BITS).

 TBMOFF   EQU    *-1         TABLE OF BASE ESM MEMORY ADDRESS OFFSETS
          BSSZ   MAXIDN      BASE MEMORY ADDRESS OFFSETS FOR ID NUMBER 1 THRU 8

* TABLE OF BASE ESM FLAG REGISTER ADDRESSES PER ID NUMBER (16 BITS),
* OF ESM SUBDIVISION STATUS FLAGS.

 TBFLGA   EQU    *-1         TABLE OF BASE ESM FLAG ADDRESSES
          BSSZ   MAXIDN      BASE FLAG ADDRESSES FOR ID NUMBER 1 THROUGH 8

* BASE ESM 4 BIT FLAG REGISTER ADDRESS OF MACHINE STATUS FLAG (16 BITS).

 MSFLGB   BSS    1           BASE MACHINE STATUS 4 BIT FLAG ADDRESS

* BASE ESM MEMORY ADDRESS/100(8)

 BMEMAD   BSS    2           BASE ESM MEMORY ADDRESS/100(8)  (17 BITS)

* CURRENT SOURCE AND DESTINATION ESM ADDRESSES.

 ESMADR   BSSZ   P.EMA*2
 SESMAD   EQU    ESMADR      SOURCE ESM ADDRESSES
 DESMAD   EQU    SESMAD+P.EMA  DESTINATION ESM ADDRESSES
 SADESM   EQU    SESMAD-ESMADR  OFFSET TO SOURCE ADDRESSES
 DADESM   EQU    DESMAD-ESMADR  OFFSET TO DESTINATION ADDRESSES


** REFORMATTED RMA DRIVER QUEUE DIRECTORY.

 DQDIR    BSSZ   P.QDE*MAXQDE  REFORMATTED DRIVER QUEUE RMA'S
          TITLE  COMMON VARIABLES AND STORAGE

* DRIVER QUEUE HEADER
* ESM HEADER
 EHSIZA   EQU    P.DQH-/DQH/P.SQTYP+P.HMSG  ACTUAL ESM HEADER SIZE IN PP WORDS
 EHSIZB   EQU    EHSIZA*16   ESM HEADER SIZE IN BITS
 EHSIZC   EQU    1+EHSIZB/12 ESM HEADER SIZE IN 12 BIT CHANNEL WORDS + 1
 EHSIZ    EQU    1+EHSIZA    ESM HEADER SIZE IN 16 BIT CHANNEL WORDS + 1

 DQHEAD   BSSZ   P.DQH       DRIVER QUEUE HEADER
 HMSG     BSSZ   P.HMSG      APPENDED HEADER MESSAGE
          BSSZ   1           (PADDING FOR EXTRA CHANNEL WORD)

* DRIVER QUEUE ENTRY
 DQENTR   BSSZ   P.DQE       DRIVER QUEUE ENTRY

* INDIRECT LIST
 INDLST   BSSZ   MAXIND*4    INDIRECT LIST BUFFER (LENGTH/ADDRESS)

* RESPONSE BUFFER
 RSPBUF   BSSZ   P.RS        PP REQUEST RESPONSE BUFFER SHARED FOR ONE WORD RSP

* ENGINEERING ERROR LOG RESPONSE BUFFER
 ENGBUF   EQU    *
*         THIS IS FSSR RECORD FOR ERROR LOG RESPONSE.
          CON    SRF.SR+SRF.ENG+B.FSSR+B.ENGRSP  SPECIAL RESPONSE FLAGS/LENGTH
          CON    0           SPECIAL RESPONSE PARAMETER
 ENGLUN   CON    0           (LOGICAL UNIT SET BY *IQI*)
 ENGQQE   CON    0           (QUEUE INDEX AND QUEUE ENTRY INDEX SET BY *EON*)
*         THIS IS ENGRSP RECORD FOR ERROR LOG RESPONSE.
 ENGRSP   BSSZ   P.ENGRSP

**********************************************************************

* I/O BUFFER BEGINS HERE FOR NON-DMA ENHANCED CY170 ADAPTER I/O.

 IOBUF    EQU    *           ADDRESS OF IO BUFFERS

 PPWRDS   EQU    PPMSZ-IOBUF  NUMBER OF 16 BIT PP WORDS AVAILABLE
          ERRNG  PPWRDS       NO AVAILABLE BUFFER SPACE

*         IOBUF SIZE MUST BE MULITPLE OF 3 64 BIT CM WORDS WHICH
*         EQUALS 12 16 BIT PP WORDS, 16 12 BIT CHANNEL WORDS.
*         THIS INSURES THAT ONLY FULL CM, PP, AND CHANNEL WORDS
*         ARE BEING MANIPULATED. (192 BITS = 3*64 = 12*16 = 16*12)

 PGBIT    EQU    PAGSZ*8      NUMBER OF BITS PER CM PAGE
 RNDPGB   EQU    PGBIT-1+192  PAGE BIT COUNT ROUNDED UP TO 192 MULTIPLE

 OPBSZ    EQU    RNDPGB/192*3 ONE PAGE BUFFER SIZE IN CM WORDS
 AVBSZ    EQU    PPWRDS/12*3  AVAIL SIZE IN CM WORDS
          ERRZR  AVBSZ        NO BUFFER SPACE

          IFMI   OPBSZ-AVBSZ
*         AVAILABLE SIZE .GT. ONE PAGE+ SIZE.
 IOBUFL   EQU    OPBSZ        ONE PAGE+ BUFFER SIZE IN CM WORDS
          ELSE
 IOBUFL   EQU    AVBSZ        BUFFER SIZE IN CM WORDS (MULTI OF 3 CM)
          ENDIF
          EJECT
**        THESE TABLES ARE NOT REQUIRED AT I/O TIME.

 PITBL    BSSZ   P.PIT       PP INTERFACE TABLE
*   NOTE THIS MUST IMMEDIATLY FOLLOW PITBL
 UNITD    BSSZ   P.UD*MLUC   UNIT DESCRIPTOR PART OF PIT FOR MLUC UNITS

 UITBL    BSSZ   P.UIT       UNIT INTERFACE TABLE

 RBDIR    BSSZ   P.RBD       REQUEST BUFFER DIRECTORY

 DQDHD    BSSZ   P.QDH       DRIVER QUEUE DIRECTORY HEADER

 REQBUF   BSSZ   MAXREQ*4    PP REQUEST BUFFER LENGTH

          TITLE  COLLECT CY170 ADAPTER ERROR INFO.
** EOD -  ERROR LOG RESPONSE INFORMATION FOR CY170 DMA ADAPTER.
*         THIS SUBROUTINE IS CALLED ONLY FROM *EON* WHEN THE C170 DMA ADAPTER
*         IS BEING USED. THE CODE HAS BEEN SEPARATED AND PLACED HERE SO THAT PP
*         MEMORY USED AS BUFFER SPACE FOR NON DMA DRIVER MODE.
*
** OUTPUT -
*     ENGBUF -
*       ENGRSP RECORD -
*         ADP    = TRUE (ONE), C170 DMA ADAPTER DRIVER MODE IF TRUE.
*         DIO    = TRUE (ONE), IF ERROR OCCURRED WHILE EXECUTING *DIO*.
*         TL1    = TRUE (ONE), IF FIRST T REGISTER LOAD SUCCESSFUL.
*         TRC    = (RTRA - RTRA+2), C170 DMA ADAPTER T REGISTER CONTENTS.
*         ADF    = (T7), C170 DMA ADAPTER INTENDED FUNCTION CODE.
*         CRC    = (RCRA), C170 DMA ADAPTER CONTROL REGISTER.
*         AES    = (RESB), C170 DMA ADAPTER ERROR STATUS REGISTER.
*         OPS    = (ROSA), C170 DMA ADAPTER OPERATIONAL STATUS REGISTER.
*
** USES - NONE.


 EOD      SUBR               ENTRY/EXIT
          LDK    ERF.ADP     C170 DMA ADAPTER DRIVER MODE FLAG
          RAML   ENGRSP+/ENGRSP/P.ADP
          LDC    0
 EODA     EQU    *-1         (NONZERO,IF EXECUTING CY170 DMA TRANSFER CODE)
          NJN    EOD1        IF EXECUTING CY170 DMA ADAPTER TRANSFER CODE
          STML   ENGRSP+/ENGRSP/P.ADF    ZERO INTENDED ADAPTER OP FUNCTION
          STML   ENGRSP+/ENGRSP/P.CRC    ZERO CONTROL REGISTER
          STML   ENGRSP+/ENGRSP/P.AES    ZERO ERROR STATUS REGISTER
          STML   ENGRSP+/ENGRSP/P.OPS    ZERO OPERATIONAL STATUS REGISTER
          STML   ENGRSP+/ENGRSP/P.TRC    ZERO T REGISTER AT FAILURE BYTE COUNT
          STML   ENGRSP+/ENGRSP/P.TRC+1  ZERO T REGISTER MSB CM ADRS AT FAILURE
          STML   ENGRSP+/ENGRSP/P.TRC+2  ZERO T REGISTER LSB CM ADRS AT FAILURE
          UJN    EOD2        ZERO T REGISTER HOLDERS

 EOD1     BSS    0           ERROR OCCURRED WHILE EXECUTING IN *DIO*
          LDK    ERF.DIO     ERROR OCCURRED WHILE EXECUTING *DIO* SUBROUTINE
          RAML   ENGRSP+/ENGRSP/P.DIO
          LDDL   T7          INTENDED ADAPTER FUNCTION
          STML   ENGRSP+/ENGRSP/P.ADF
          LDML   RCRA        CONTROL REGISTER CONTENTS
          STML   ENGRSP+/ENGRSP/P.CRC
          LDML   RESB        ERROR STATUS REGISTER CONTENTS
          STML   ENGRSP+/ENGRSP/P.AES
          LDML   ROSA        OPERATIONAL STATUS REGISTER CONTENTS
          STML   ENGRSP+/ENGRSP/P.OPS

          LDC    0
 EODB     EQU    *-1         (NONZERO, IF T REGISTER LOADED FIRST TIME)
          NJN    EOD3        IF T REGISTER LOADED FIRST TIME
 EOD2     STML   ENGRSP+/ENGRSP/P.TRC    ZERO T REGISTER BYTE COUNT
          STML   ENGRSP+/ENGRSP/P.TRC+1  ZERO T REGISTER MSB CM ADDRESS
          STML   ENGRSP+/ENGRSP/P.TRC+2  ZERO T REGISTER LSB CM ADDRESS
          STML   ENGRSP+/ENGRSP/P.ITR    ZERO INITIAL T REGISTER BYTE COUNT
          STML   ENGRSP+/ENGRSP/P.ITR+1  ZERO INITIAL T REGISTER MSB CM ADDRESS
          STML   ENGRSP+/ENGRSP/P.ITR+2  ZERO INITIAL T REGISTER LSB CM ADDRESS
          UJN    EOD4

 EOD3     BSS    0           ERROR OCCURRED AFTER FIRST T REGISTER LOAD
          LDK    ERF.TRL     FIRST T REGISTER LOAD SUCCESSFUL
          RAML   ENGRSP+/ENGRSP/P.TRL
          LDML   RTRA        T REGISTER BYTE COUNT
          STML   ENGRSP+/ENGRSP/P.TRC
          LDML   RTRA+1      T REGISTER CM ADDRESS (MOST SIGNIFICANT BITS)
          STML   ENGRSP+/ENGRSP/P.TRC+1
          LDML   RTRA+2      T REGISTER CM ADDRESS (LEAST SIGNIFICANT BITS)
          STML   ENGRSP+/ENGRSP/P.TRC+2
          LDML   INDLST+1    INITIAL T REGISTER BYTE COUNT
          STML   ENGRSP+/ENGRSP/P.ITR    ZERO INITIAL T REGISTER BYTE COUNT
          LDML   INDLST+2    INITIAL T REGISTER MSB CM ADDRESS BITS
          STML   ENGRSP+/ENGRSP/P.ITR+1  ZERO INITIAL T REGISTER MSB CM ADDRESS
          LDML   INDLST+3    INITIAL T REGISTER LSB CM ADDRESS BITS
          STML   ENGRSP+/ENGRSP/P.ITR+2  ZERO INITIAL T REGISTER LSB CM ADDRESS
 EOD4     RETURN
          TITLE  DMA ENHANCED CY170 ADAPTER I/O ROUTINES.
** DIO -  DMA INPUT/OUTPUT.
*
** PURPOSE -
*         PERFORM ESM INPUT/OUTPUT VIA THE CY170 CHANNEL DMA ADAPTER.
*
** INPUT -
*         (A)    = LOCATION OF STARTING ESM ADDRESS.
*         RC     = REQUESTED NUMBER OF CM WORDS TO INPUT FROM CHANNEL.
*
** OUTPUT -
*         (A)    = ZERO, IF NO ERROR.
*                = ERROR CODE, IF ERROR.
*         AC     = ACTUAL CM WORD COUNT INPUT FROM CHANNEL.
*
** USES - T6, T7, T8, T9.
*
** CALLS - WTR, FCN, RCR, RES, ROS, RTR, VLN.

 DIOX     BSS    0           SOFT ERROR EXIT

 DIO      SUBR               ENTRY/EXIT
          STDL   EMA         SAVE POINTER TO STARTING ESM ADDRESS
          STML   DIOA        STORE LOCATION OF STARTING ESM ADDRESS
          ADC    -DESMAD     MINUS LOCATION OF DESTINATION ESM ADDRESS
          MJN    DIO1        IF DMA INPUT OPERATION

*         OUTPUT OPERATION.
*          INCREMENT LAST INDIRECT LIST ENTRY LENGTH BY TWO BYTES
*          TO INSURE THAT THE LAST CHANNEL WORD GETS FILLED OUT.
          LDN    2
          RAML   INDLST+1-4,LL  INCREMENT LAST ENTRY LENGTH BY TWO
          LDK    FC.WRT      ESM WRITE FUNCTION
          STDL   T6          ESM FUNCTION CODE
          LDK    FC.OUT      DMA OUTPUT / FAST TRANSFER / PP WC=2
          UJN    DIO2

*         INPUT OPERATION.
 DIO1     BSS    0
          RJM    VLN         VERIFY IND LIST TOTAL LENGTH .GE. RC
          NJN    DIOX        IF INSUFFICIENT LENGTH FOR INPUT ERROR
          LDK    FC.RED      ESM READ FUNCTION
          STDL   T6          ESM FUNCTION CODE
          LDK    FC.INP      DMA INPUT / FAST TRANSFER / PP WC=2

 DIO2     BSS    0
          STDL   T7          ADAPTER FUNCTION CODE

 DIO3     BSS    0           ATTEMPT ERROR RECOVERY FROM THIS POINT
          LDK    FC.AMC      ADAPTER MASTER CLEAR
          RJM    FCN         FUNCTION ADAPTER (IGNORE POSSIBLE TIMEOUT ERROR)

          AOML   EODA        SET EXECUTING CY170 TRANSFER FLAG FOR *EOD*

*         INITIALIZE WORD COUNTERS.
          LDDL   RC          REQUESTED CM WORD COUNT
          STML   AC          ACTUAL CM WORD COUNT
          LDDL   LL          LIST LENGTH IN PP WORDS
          SHN    -2          /4 FOR NUMBER OF ENTRIES IN LIST
          STDL   T8          NUMBER OF INDIRECT LIST ENTRIES
          LDC    INDLST+1
          STML   WTRA        STORE ADDRESS OF FIRST LEN/ADRS ENTRY

*         SEND FUNCTIONS TO ESM.
          LDK    FC.HST      ENABLE ESM HIGH SPEED DATA TRANSFER
          RJM    FCN         FUNCTION ESM FOR HIGH SPEED TRANSFER
          NJN    DIO7        IF ESM FUNCTION TIMEOUT ERROR
          LDDL   T6          ESM READ/WRITE FUNCTION
          RJM    FCN         FUNCTION ESM FOR READ OR WRITE
          NJN    DIO7        IF ESM FUNCTION TIMEOUT ERROR

*         WRITE ADAPTER 'T' REGISTER.
          RJM    WTR         WRITE 'T' PRIME REGISTER (FIRST)
          NJN    DIO7        IF INACTIVE ON OUTPUT ERROR

          AOML   EODB        SET T REGISTER LOADED FIRST TIME FLAG

          LDDL   T7          ADAPTER START DMA INPUT OR OUTPUT
          RJM    FCN         FUNCTION ADAPTER I/O / FAST XFER / PP WC=2
          NJN    DIO7        IF ADAPTER FUNCTION TIMEOUT ERROR

          LDN    3           THREE BYTES
          STDL   XBC         ESM ADDRESS TRANSFER BYTE COUNT

*         SEND ESM ADDRESS.
          ACN    CH40
          LDN    2
          OAM    *,CH00      OUTPUT ESM STARTING ADDRESS
 DIOA     EQU    *-1         (LOCATION OF STARTING ESM ADDRESS)
 DIO4     IJM    DIO13,CH00  IF CHANNEL INACTIVE ERROR
          NJN    DIO4        WAIT FOR ZERO COUNT
          DCN    CH40
          LDK    ER.CPE      ** CHANNEL PARITY ERROR CODE **
          SFM    DIO11,CH00   IF CHANNEL ERROR FLAG SET

*         DMA INPUT/OUTPUT LOOP.
 DIO6     LDDL   T8          INDIRECT LIST ENTRY COUNT
          ZJN    DIO10       IF NO MORE INDIRECT LIST ENTRIES
          RJM    WTR         WRITE 'T' PRIME REGISTER
 DIO7     NJN    DIO11       IF NOT THREE WORDS ACCEPTED BY ADAPTER ERROR

*         WAIT FOR 'T' PRIME REGISTER EMPTY.
 DIO8     RJM    ROS         READ ADAPTER OPERATIONAL STATUS
          NJN    DIO11       IF CHANNEL ERROR ON READ OPERATIONAL STATUS
          LDDL   T1          ADAPTER OPERATIONAL STATUS
          SHN    17-OB.TRE
          MJN    DIO6        IF ADAPTER 'T' PRIME REGISTER EMPTY CHECK FOR MORE
          LDDL   T1          ADAPTER OPERATIONAL STATUS
          SHN    17-OB.HLT
          PJN    DIO8        IF NOT DMA TRANSFER HALTED
 DIO9     LDK    ER.HLT      ** DMA XFER HALTED EARLY ERROR **
          UJN    DIO11       CHECK STATUS FOR DETAIL ERROR

*         NO MORE INDIRECT LIST ENTRIES TO SEND ADAPTER.
*         WAIT FOR DMA TRANSFER TO COMPLETE.
 DIO10    RJM    DIW         WAIT FOR I/O TRANSFER TO COMPLETE
*           (A) = ZERO, IF TRANSFER COMPLETED NORMALLY.
*               = ERROR CODE, IF ABNORMAL TRANSFER STOP

*         (SAVE ERROR CODE IN T9 INCASE NO DETAILS AVAILABLE.)
*         DMA TRANSFER STOPPED, CLEAR DMA MODE AND CHECK FOR ERRORS.
 DIO11    STDL   T9          SAVE/CLEAR ERROR CODE
          RJM    RCR         READ CONTROL REGISTER CONTENTS
          RJM    RTR         READ ADAPTER T REGISTERS
          RJM    RES         READ ESM AND ADAPTER ERROR STATUS
          NJN    DIO12       IF ESM OR ADAPTER ERROR
          LDDL   T9          ZERO OR PREVIOUS ERROR CONDITION CODE
 DIO12    RECOVER  DIO3      CHECK ERROR RECOVERY STATUS
          STDL   T9          SAVE (A)
          LDN    0
          STML   EODA        TURN OFF EXECUTING *DIO* CODE FLAG
          STML   EODB        TURN OFF FIRST T REGISTER LOAD FLAG
          LDDL   T9          RESTORE (A)
          RETURN

 DIO13    STDL   RB          SAVE RESIDUAL BYTE COUNT
          LDK    ER.INA      ** CHANNEL INACTIVE ERROR CODE **
          UJN    DIO11
DIW       SPACE  4
** DIW  - DIO WAIT FOR TRANSFER TO COMPLETE
*
** INPUT - NONE.
*
** OUTPUT -
*         (A) = ZERO, IF TRANSFER COMPLETED WITHOUT ERROR.
*             = NONZERO, IF TRANSFER HAS NOT COMPLETED. THE NONZERO VALUE IS
*                        AN ERROR CODE -
*                        ER.FTO = CHANNEL FUNCTION TIMEOUT (FROM *ROS*)
*                        ER.HLT = TRANSFER HALTED EARLY OPERATIONAL STATUS
*                        ER.INA = TRANSFER FAILED TO COMPLETE IN ALOTTED TIME
*                        ER.CLK = TRANSFER FAILED TO COMPLETE, NO EXTERNAL CLOCK
*
** CALLS - ROS.
*
** USES -

 DIW      SUBR               ENTRY/EXIT
          LDK    777B
          STML   DIWA        ESTABLISH WAIT COUNT

*         WAIT FOR DMA TRANSFER TO COMPLETE.
 DIW1     RJM    ROS         READ ADAPTER OPERATIONAL STATUS
          NJN    DIW5        IF ERROR
          LDDL   T1          ADAPTER OPERATIONAL STATUS
          SHN    17-OB.HLT
          PJN    DIW2        IF NOT DMA XFER HALTED EARLY
          LDK    ER.HLT      ** DMA XFER HALTED EARLY **
          UJN    DIW5        RETURN WITH ERROR

 DIW2     LDDL   T1          ADAPTER OPERATIONAL STATUS
          SHN    17-OB.XIP   CHECK TRANSFER IN PROGRESS BIT
          PJN    DIW4        IF TRANSFER COMPLETED
          SOML   DIWA        DECREMENT WAIT COUNT
          NJN    DIW1        IF NOT TIME TO GIVE UP

*         WAITED BEYOND MAXIMUM TIME.
          LDDL   T1
          SHN    17-OB.CLW
          MJN    DIW3        IF EXTERNAL CLOCK PRESENT
          LDK    ER.CLK      ** TRANSFER FAILED TO COMPLETE, NO EXTERNAL CLOCK *
          UJN    DIW5        RETURN WITH ERROR

 DIW3     LDK    ER.INA      ** TRANSFER FAILED TO COMPLETE IN ALOTTED TIME **
*         UJN    DIW5        RETURN WITH ERROR

 DIW4     LDN    0           NO ERROR
 DIW5     RETURN

 DIWA     CON    0           WAIT COUNT
RCR       EJECT
** RCR -  READ ADAPTER CONTROL REGISTER.
*
** PURPOSE -
*         READ DMA ADAPTER CONTROL REGISTER.
*
** INPUT - NONE.
*
** OUTPUT -
*         RCRA   = ADAPTER CONTROL REGISTER CONTENTS.
*
** USES - NONE.
*
** CALLS - FCN.

 RCR      SUBR               ENTRY/EXIT
          LDN    0
          STML   RCRA        CLEAR SAVED CONTROL REGISTER CONTENTS
          LDK    FC.RCR      READ CONTROL REGISTER
          RJM    FCN         FUNCTION ADAPTER
          NJN    RCR2        IF ADAPTER FUNCTION TIMEOUT ERROR
          ACN    CH40
          LDN    1
 RCR1     IJM    RCR2,CH00   IF CHANNEL INACTIVE ERROR
          EJM    RCR1,CH00   WAIT FOR CHANNEL FULL
          IAM    RCRA,CH40   INPUT ADAPTER CONTROL REGISTER
          DCN    CH40
 RCR2     RETURN

 RCRA     CON    0           ADAPTER CONTROL REGISTER CONTENTS
RES       EJECT
** RES -  READ ERROR STATUS REGISTER.
*
** PURPOSE -
*         THIS SUBROUTINE READS THE ADAPTER'S ERROR STATUS REGISTER, AND CALLS
*         'PST' TO READ ESM LSP STATUS. IF NO ERROR IS DETECTED IN THE ESM LSP
*         STATUS, AND IF THE ADAPTER ERROR STATUS REGISTER IS ZERO NO ERROR
*         OCCURRED AND (A) IS ZERO ON EXIT.
*         IF THE ADAPTER ERROR STATUS REGISTER IS NON ZERO AN ADAPTER ERROR
*         CODE IS DETERMINED.
*
*   ERROR STATUS REGISTER BIT ASSIGNMENTS -
*
*      BIT                DESCRIPTION
*     -----              -------------
*    15 / 48     ZERO,N/A.
*    14 / 49     ZERO,N/A.
*    13 / 50     UNCORRECTED ERROR RESPONSE FROM CM ON READ/WRITE.
*    12 / 51     REJECT RESPONSE FROM CM.
*    11 / 52     ILLEGAL RESPONSE CODE FROM CM.
*    10 / 53     PE ON CM RESPONSE CODE (IF KX=0, DETECTED BY I4/CMI).
*     9 / 54     READ DATA PE ON DMA XFER DETECTED BY I4/CMI.
*     8 / 55     EXTERNAL CLOCK FAULT.
*     7 / 56     OVERFLOW, DATA RECEIVED AFTER INPUT BUFFER FULL.
*     6 / 57     PE ON INPUT DATA.
*     5 / 58     12/16 CONVERSION ERROR (IF KZ=1, KZ BOARD ERROR).
*     4 / 59     JY DATA PARITY ERROR (BIT 62 SHOULD = 1).
*     3 / 60     BAS PARITY ERROR (BIT 63 SHOULD = 1)
*     2 / 61     KZ BOARD DETECTED ERROR.
*     1 / 62     JY BOARD DETECTED ERROR.
*     0 / 63     KX BOARD DETECTED ERROR.
*
** INPUT - NONE.
*
** OUTPUT -
*         (A)    = ZERO, IF NO ERROR.
*                = ERROR CODE, IF ERROR.
*         RESB   = ADAPTER ERROR STATUS.
*
** USES - T10.
*
** CALLS - FCN, PST.

 RES3     LDML   RESB        DMA ADAPTER STATUS
 RESA     SHN    0           * MODIFIED * SHIFT NEXT STATUS BIT TO SIGN POSITION
          MJN    RES4        IF ERROR STATUS BIT 50D+(T10) SET
          AODL   T10         INCREMENT ERROR CODE INDEX
          LDN    0           (5 INSTRUCTIONS BETWEEN INSTRUCTION MODIFICATION)
          LDN    0           (5 INSTRUCTIONS BETWEEN INSTRUCTION MODIFICATION)
          LDN    0           (5 INSTRUCTIONS BETWEEN INSTRUCTION MODIFICATION)
          AOML   RESA        * INSTRUCTION MOD * INCREMENT SHIFT COUNT AT 'RESA'
          UJN    RES3        TEST NEXT HIGH ORDER STATUS BIT

 RES4     LDML   ADPERT,T10  DMA ADAPTER ERROR CODE
          UJN    RESX        RETURN

 RES5     LDK    ER.INA      ** INACTIVE ERROR ON INPUT ERROR STATUS **
 RESX     BSS    0           EXIT

 RES      SUBR               ENTRY/EXIT
          LDN    0
          STML   RESB        CLEAR SAVED ADAPTER ERROR STATUS
          STDL   PS          CLEAR ESM LOW SPEED PORT STATUS
          LDK    FC.ESR      READ ADAPTER ERROR STATUS REGISTER
          RJM    FCN         FUNCTION ADAPTER
          NJN    RESX        IF ADAPTER FUNCTION TIMEOUT ERROR
          LDN    2           TWO BYTES
          STDL   XBC         ADAPTER STATUS TRANSFER BYTE COUNT
          ACN    CH40
          LDN    1
 RES1     IJM    RES5,CH00   IF CHANNEL INACTIVE ERROR
          EJM    RES1,CH00   IF CHANNEL EMPTY
          IAM    RESB,CH40   INPUT/CLEAR ADAPTER ERROR STATUS
          DCN    CH40
          LDK    FC.CDM      CLEAR DMA MODE
          RJM    FCN         FUNCTION ADAPTER (IGNORE TIMEOUT)
          LDK    FC.LST      DISABLE ESM HIGH SPEED DATA TRANSFER
          RJM    FCN         FUNCTION ESM (IGNORE TIMEOUT)
          RJM    PST         CHECK LOW SPEED PORT ESM STATUS
          MJN    RES2        IF ESM STATUS = ABORT BIT (NO ERROR)
          NJK    RESX        IF ESM LOW SPEED PORT ERROR

 RES2     LDML   RESB        ADAPTER ERROR STATUS
          LPC    37777B      14 BITS OF VALID ADAPTER STATUS
          ZJK    RESX        IF NO ADAPTER ERROR IN STATUS
          STML   RESB

* NOTE - THE FOLLOWING CODE MODIFIES INSTRUCTION AT TAG 'RESA'.
          LDN    0
          STDL   T10         INITIALIZE ERROR CODE INDEX
          LDML   RESA        INITIALIZE SHIFT INSTUCTION TO 'SHN  4'
          LPC    -77B        RETAIN INSTRUCTION, CLEAR SHIFT COUNT
          ADN    50D-46D     SHIFT COUNT TO POSITION BIT 50 TO SIGN BIT
          STML   RESA        * INSTRUCTION MODIFICATION *
          UJK    RES3        (MOD INSTRUCTION MUST BE AT LEAST 5 LOCS AWAY)

 RESB     BSSZ   1           ADAPTER ERROR STATUS

 ADPERT   BSS    0           ADAPTER ERROR CODE TABLE
          CON    ER.CME      50 - DMA UNCORRECTED CM ERROR
          CON    ER.CMR      51 - CM REJECT
          CON    ER.ICR      52 - INVALID CM RESPONSE
          CON    ER.CRP      53 - CM RESPONSE CODE PARITY ERROR
          CON    ER.CMI      54 - CMI READ DATA PARITY ERROR
          CON    ER.CLK      55 - CLOCK FAULT
          CON    ER.IBO      56 - OVERFLOW ERROR
          CON    ER.IER      57 - INPUT ERROR
          CON    ER.CVN      58 - 12/16 CONVERSION ERROR
          CON    ER.JYD      59 - JY DATA ERROR
          CON    ER.BAS      60 - BAS PARITY ERROR
          CON    ER.KZE      61 - KZ BOARD ERROR
          CON    ER.JYE      62 - JY BOARD ERROR
          CON    ER.KXE      63 - KX BOARD ERROR

ROS       EJECT
** ROS -  READ OPERATIONAL STATUS.
*
** PURPOSE -
*         READ DMA ADAPTER OPERATIONAL STATUS REGISTER.
*
** INPUT - NONE.
*
** OUTPUT -
*         (A)    = ZERO, IF NO ERROR.
*                = ERROR CODE, IF ERROR.
*         T1     = ADAPTER OPERATIONAL STATUS.
*         ROSA   = ADAPTER OPERATIONAL STATUS.
*
** USES - T1.
*
** CALLS - FCN.

 ROS2     LDK    ER.INA      ** CHANNEL INACTIVE ON OP STATUS INPUT **

 ROSX     BSS    0           EXIT

 ROS      SUBR               ENTRY/EXIT
          LDN    0
          STML   ROSA        CLEAR SAVED OPERATIONAL STATUS
          LDK    FC.OSR      READ OPERATIONAL STATUS REGISTER
          RJM    FCN         FUNCTION ADAPTER
          NJN    ROSX        IF ADAPTER FUNCTION TIMEOUT ERROR
          LDN    2           TWO BYTES
          STDL   XBC         ADAPTER STATUS TRANSFER BYTE COUNT
          ACN    CH40
 ROS1     IJM    ROS2,CH00   IF CHANNEL INACTIVE ERROR
          EJM    ROS1,CH00   WAIT FOR CHANNEL FULL
          IAN    CH40        INPUT ADAPTER OPERATIONAL STATUS
          STDL   T1          SAVE ADAPTER OPERATIONAL STATUS
          DCN    CH40
          STML   ROSA        SAVE ADAPTER OPERATIONAL STATUS
          LDN    0           NO ERROR
          RETURN

 ROSA     CON    0           ADAPTER OPERATIONAL STATUS REGISTER CONTENTS
RTR       EJECT
** RTR -  READ ADAPTER T REGISTERS.
*
** PURPOSE -
*         READ DMA ADAPTER T REGISTERS.
*
** INPUT - NONE.
*
** OUTPUT -
*         RTRA - RTRA + 2 = ZERO, IF UNABLE TO READ T REGISTER.
*                         = T REGISTER CONTENTS.
*
** USES - NONE.
*
** CALLS - FCN.


 RTR2     LDN    0           UNABLE TO READ ADAPTER T REGISTERS
          STML   RTRA
          STML   RTRA+1
          STML   RTRA+2

 RTR      SUBR               ENTRY/EXIT
          LDK    FC.RTR      READ T REGISTERS
          RJM    FCN         FUNCTION ADAPTER
          NJN    RTR2        IF ADAPTER FUNCTION TIMEOUT ERROR
          LDN    6           TWO BYTES
          STDL   XBC         ADAPTER T REGISTER TRANSFER BYTE COUNT
          ACN    CH40
          LDN    3
 RTR1     IJM    RTR2,CH00   IF CHANNEL INACTIVE ERROR
          EJM    RTR1,CH00   WAIT FOR CHANNEL FULL
          IAM    RTRA,CH40   INPUT ADAPTER T REGISTERS
          DCN    CH40
          RETURN

 RTRA     CON    0           BYTE COUNT
          CON    0           MOST SIGNIFICANT CM ADDRESS BITS
          CON    0           LEAST SIGNIFICANT CM ADDRESS BITS
WTR       EJECT
** WTR -  WRITE 'T' REGISTER.
*
** PURPOSE -
*         WRITE DMA ADAPTER 'T' PRIME REGISTER.
*
** INPUT -
*         WTRA   = PP ADDRESS OF LENGTH/ADDRESS INDIRECT LIST ENTRY.
*         T8     = NUMBER OF INDIRECT LIST ENTRIES TO PROCESS.
*
** OUTPUT -
*         (A)    = ZERO, IF NO ERROR.
*                = ERROR CODE, IF ERROR.
*         WTRA   = INCREMENTED TO NEXT INDIRECT LIST ENTRY.
*         T8     = NUMBER OF INDIRECT LIST ENTRIES LEFT TO PROCESS.
*
** CALLS - FCN.

 WTR1     LDK    ER.INA      ** CHANNEL INACTIVE ERROR **

 WTRX     BSS    0           EXIT

 WTR      SUBR               ENTRY/EXIT
          LDK    FC.WTR      WRITE 'T' PRIME REGISTER
          RJM    FCN         FUNCTION ADAPTER FOR T REGISTER WRITE
          NJN    WTRX        IF ADAPTER FUNCTION TIMEOUT ERROR
          LDN    6           TWO BYTES
          STDL   XBC         ADAPTER T REGISTER TRANSFER BYTE COUNT
          ACN    CH40        ACTIVATE CHANNEL
          LDN    3           NUMBER OF 16 BIT PP WORDS
          OAM    *,CH00      OUTPUT FIRST LEN/ADRS OF INDIRECT LIST
 WTRA     EQU    *-1         (PP ADDRESS OF LEN/ADRS IN INDIRECT LIST
          DCN    CH40        DEACTIVATE CHANNEL
          NJN    WTR1        IF ADAPTER INACTIVE BEFORE 3 WORDS
          SODL   T8          DECREMENT INDIRECT LIST ENTRY COUNT
          LDN    4           FOUR PP WORDS PER INDIRECT LIST ENTRY
          RAML   WTRA        INCREMENT ADDRESS OF INDIRECT LIST ENTRY
          LDN    0           NO ERROR
          RETURN
          TITLE  CYBER 930 ICI/C170 CONVERTER I/O ROUTINES.
** CIC  - CLEAR CY930 ICI CHANNEL.
*
** PURPOSE - MASTER CLEAR ICI CHANNEL, SELECT CONVERTER, MASTER CLEAR LSP.
*
** INPUT - NONE.
*
** OUTPUT - NONE.
*
** CALLS - FCN, PAUS.

 CIC      SUBR               ENTRY/EXIT
          MCLR   CH40        MASTER CLEAR CHANNEL (I0 ONLY)
          LDN    2
          RJM    PAUS        WAIT 2 MICROSECONDS
          DCN    CH40
          LDK    ICI.SEL+FC.PMC  SELECT C170 CONVERTER/MASTER CLEAR ESM LS PORT
          RJM    FCN         (IGNORE TIMEOUT IF ANY)
          RETURN
ICI       EJECT
** ICI -  ICI CHANNEL COMMAND/RESPONSE AND PAGE INPUT/OUTPUT.
*
** PURPOSE -
*         PERFORM INPUT/OUTPUT TO ESM VIA THE CY930 ICI CHANNEL.
*         THIS SUBROUTINE USES THE CHCM/CMCH INSTRUCTIONS WHICH UTILIZE THE
*         CY930'S DMA FEATURE TO I/O DATA BETWEEN ESM AND CENTRAL MEMORY.
*
** INPUT -
*         (A)    = LOCATION OF STARTING ESM ADDRESS.
*         LL     = INDIRECT LIST LENGTH IN PP WORDS.
*         RC     = REQUESTED NUMBER OF CM WORDS TO INPUT FROM CHANNEL.
*
** OUTPUT -
*         (A)    = ZERO, IF NO ERROR.
*                = ERROR CODE, IF ERROR.
*         AC     = ACTUAL CM WORD COUNT INPUT FROM CHANNEL.
*         LI     = LAST PROCESSED INDIRECT LIST INDEX IN PP WORDS.
*         RC     = UNCHANGED.
*
** USES - T6, T9.
*
** CALLS - FCN, PST, VLN.

 ICIX     EQU    *           INSUFFICIENT BUFFER SPACE ERROR EXIT

 ICI      SUBR               ENTRY/EXIT
          STDL   EMA         SAVE POINTER TO STARTING ESM ADDRESS
          STML   ICIA        STORE LOCATION OF STARTING ESM ADDRESS
          ADC    -DESMAD
          MJN    ICI1        IF INPUT FROM ESM OPERATION

*         OUTPUT OPERATION.
*          INCREMENT LAST INDIRECT LIST ENTRY LENGTH BY TWO BYTES
*          TO INSURE THAT THE LAST CHANNEL WORD GETS FILLED OUT.
          LDN    2
          RAML   INDLST+1-4,LL  INCREMENT LAST ENTRY LENGTH BY TWO BYTES
          LDK    ICI.SSM+FC.WRT  ESM WRITE FUNCTION / STORNET MODE
          UJN    ICI2

*         INPUT OPERATION.
 ICI1     BSS    0
          RJM    VLN         VERIFY INDIRECT LIST BYTE LENGTHS
          NJN    ICIX        IF INSUFFICIENT BUFFER SPACE ERROR
          LDK    ICI.SSM+FC.RED  ESM READ FUNCTION / STORNET MODE

*         INITIALIZE WORD COUNTERS, FUNCTION ESM, AND SEND ESM ADDRESS.
 ICI2     BSS    0
          STDL   T6          SAVE FUNCTION CODE
          LDDL   RC          REQUESTED CM WORD COUNT
          STML   AC          ACTUAL CM WORD COUNT

 ICI3     BSS    0           ATTEMPT ERROR RECOVERY FROM THIS POINT
          LDN    0
          STDL   LI          RESET (ZERO) INDIRECT LIST INDEX
          LDDL   T6          ESM READ OR WRITE FUNCTION (PLUS STORNET MODE)
          RJM    FCN         FUNCTION CHANNEL
          ZJN    ICI4        IF NO FUNCTION TIMEOUT ERROR
          LJM    ICI12       CHECK DETAILED PORT STATUS

 ICI4     ACN    CH40        ACTIVATE CHANNEL
          LDN    3           THREE BYTES
          STDL   XBC         ESM ADDRESS TRANSFER BYTE COUNT
          LDN    2           (TWO 12 BIT PP WORDS)
          OAM    *,CH00      OUTPUT ESM STARTING ADDRESS (12 BIT)
 ICIA     EQU    *-1         (LOCATION OF ESM ADDRESS)
 ICI5     IJM    ICI8,CH00   CHANNEL INACTIVE ERROR
          NJN    ICI5        WAIT FOR ZERO COUNT
*         THIS IS NECESSARY FOR ICI CHANNEL TO SWITCH TO PACKING MODE.
 INS.DCN  DCN    CH40        TO ICI CHANNEL ONLY, ESM DOES NOT SEE THIS
          ACN    CH40        TO ICI CHANNEL ONLY, ESM DOES NOT SEE THIS

*         INPUT/OUTPUT LOOP. (ICI SWITCHES TO PACKED MODE AFTER TWO 12 BITS)
 ICI6     BSS    0
          LDML   INDLST+1,LI BYTE COUNT FROM RMA LIST
          STDL   XBC         TRANSFER BYTE COUNT
          SHN    -1          /2 CONVERT TO 16 BIT CHANNEL WORD COUNT
          STDL   CC          CHANNEL WORD COUNT
          LDDL   T6          CHECK IF READ (5001) OR WRITE (5002) FUNCTION
          SHN    17-1        (TEST WRITE 5002)
          PJN    ICI9        IF ESM READ OPERATION (5001)

*         WRITE ESM.
          LOADF  INDLST+2,LI LOAD AND FORMAT RMA IN 'A' AND 'R' REGISTERS
          CMCH   CC,CH00     OUTPUT 16 BIT CHANNEL WORDS
 ICI7     IJM    ICI8,CH00   CHANNEL INACTIVE ERROR
          FJM    ICI7,CH00   WAIT FOR CHANNEL EMPTY
          UJN    ICI11       CHECK END OF TRANSFER

 ICI8     LDDL   CC
          STDL   RB          SAVE RESIDUAL BYTE COUNT
          LDK    ER.INA      ** CHANNEL INACTIVE ERROR **
          UJN    ICI12       CHECK DETAILED PORT STATUS

*         READ ESM.
 ICI9     BSS    0
          LOADF  INDLST+2,LI LOAD AND FORMAT RMA IN 'A' AND 'R' REGISTERS
          CHCM   CC,CH00     INPUT 16 BIT CHANNEL WORDS
 ICI10    IJM    ICI8,CH00   IF CHANNEL INACTIVE ERROR
          EJM    ICI10,CH00  IF CHANNEL EMPTY, WAIT FOR FULL

*         CHECK FOR END OF TRANSFER.
 ICI11    BSS    0
          LDN    4           (PP WORDS PER LIST ENTRY)
          RADL   LI          INCREMENT INDIRECT LIST INDEX
          SBDL   LL          SUBTRACT LIST LENGTH IN PP WORDS
          MJK    ICI6        IF RMA LIST NOT EXHAUSTED

          DCN    CH40        DISCONNECT CHANNEL
          LDN    0           NO CHANNEL FAILURE
          CFM    ICI12,CH00  IF CHANNEL ERROR FLAG NOT SET (ELSE CLEAR FLAG)
          LDK    ER.CPE      ** CHANNEL PARITY ERROR CODE **

*         CHECK FOR ESM ERRORS.

 ICI12    STDL   T9          SAVE POSSIBLE INACTIVE CHANNEL ERROR
          RJM    PST         CHECK PORT STATUS
          LPK    ERCODM      MASK FOR ERROR CODES
          NJN    ICI13       IF DETAILED ERROR CODE
          LDDL   T9          (POSSIBLE INACTIVE CHANNEL ERROR)
 ICI13    BSS    0
          RECOVER  ICI3      CHECK ERROR RECOVERY STATUS
          RETURN
PAUS      EJECT
** PAUS - PAUSE.
*
** PURPOSE -
*         THIS SUBROUTINE IS CALLED BY THE 'PAUSE' MACRO (IODMAC4).
*         DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*         MICROSECONDS.
*
** INPUT - A REGISTER SPECIFIES NUMBER OF MICROSECONDS
*          TO BE DELAYED.
*

 PAUS     SUBR               ENTRY/EXIT
 PAUS1    SBN    1           EACH ITERATION OF THIS SBN-NJN LOOP
          PSN
          PSN
          NJK    PAUS1       UTILIZES 1 MICROSECOND
          RETURN             EXIT
          TITLE  PROCESS PP REQUEST (OVERLAY)

* * *     PP REQUEST PROCESSING OVERLAY LOADED HERE.
 OVLSA    EQU    *           STARTING ADDRESS OF PP REQUEST PROCESSING OVERLAY

 PPR1     RJM    CLK         CLEAR PP LOCKWORD
 PPR2     LJM    0,MLPRTN    TO MAIN LOOP, NO REQUESTS FOUND

 PPR      BSS    0           OVERLAY PORTION OF 'PPR'
          RJM    SLK         LOCK PP-REQUEST QUEUE
          NJN    PPR2        RETURN IF PP REQUEST QUEUE ALREADY LOCKED
          LDK    PITLEN      GET LENGTH OF PIT IN CM WORDS
          STDL   WC          SAVE LENGTH FOR CM READ
          LOADC  CM.PIT      CM ADDRESS TO A AND R FOR READ
          CRML   PITBL,WC    READ IN PIT
          LDML   PITBL+/PIT/P.PPQ  GET HALF 1 OF RMA OF 1ST REQUEST
          ADML   PITBL+/PIT/P.PPQ+1
          ZJK    PPR1        IF RMA = 0 NO PP REQUEST QUEUED

          LDK    MAXREQ
          STDL   WC          SET MAX LENGTH OF PP REQUEST FOR CM READ
          LOADF  PITBL+/PIT/P.PPQ  CM ADDRESS OF REQUEST TO A AND R
          CRML   REQBUF,WC   READ PP REQUEST
          LDK    2
          STDL   WC          SET FOR 2 CM WORD TRANSFER
          LOADF  PITBL+/PIT/P.PPQ  CM ADDRESS OF REQUEST TO A AND R
          CWML   PITBL+/PIT/P.PPQPVA-1,WC  REWRITE PVA AND RMA.
          LOADC  CM.PIT      SET A AND R TO PP INTERFACE TABLE
          ADK    /PIT/C.PPQPVA  SET A AND R TO PVA IN PP INTERFACE TABLE
          CWML   REQBUF+/RQ/P.NEXTPV-1,WC  RESET PVA AND RMA TO NEXT PVA AND RMA
          LOADF  PITBL+/PIT/P.PPQ  CM ADDRESS OF REQUEST TO A AND R
          CRML   REQBUF,WC   REREAD LINK INFORMATION.
          RJM    CLK         UNLOCK PPQ
          RJM    IPR         INITIALIZE RESPONSE BUFFER FOR PP RESPONSE.
*         FALL THRU TO DO COMMAND *DCM*.
*         UJN    DCM
          ERRNZ  *-DCM       CODE ASSUMES *DCM* FOLLOWS
DCM       SPACE 4,25
** DCM -  DO COMMAND.
*
** PURPOSE -
*         PERFORM PP REQUEST COMMANDS.
*
** INPUT - COMMAND IN REQBUF.
*
** OUTPUT -
*         T1     = ADDRESS OF PP COMMAND.
*
** CALLS - DCP, EPC.
*
** USES - T1, T8, T9.

 DCM      BSS    0
          LDN    0           * INSTRUCTION MODIFICATION *
          STML   DCMC        INITIALIZE COMMAND INDEX
          LDML   REQBUF+/RQ/P.LEN  GET REQUEST LENGTH
          SBN    HEADLN      SUBTRACT HEADER LENGTH
          SHN    -3          /8 TO GET CM WORDS OF COMMANDS
          STML   DCMB        SAVE NUMBER OF COMMANDS

 DCM1     BSS    0
          LDK    REQBUF+/RQ/P.CMND  GET ADDR OF FIRST COMMAND
          ADC    **          (INSTRUCTION MODIFIED)
 DCMC     EQU    *-1
          STDL   T1          PP ADDRESS OF COMMAND

          LDK    0
          STML   RSPBUF+/RS/P.RC  CLEAR RESPONSE CODE

          LDIL   T1          GET COMMAND AND FLAGS
          SHN    -8          SHIFT OFF FLAGS
          STDL   T8          SAVE COMMAND

*         SEARCH THE COMMAND CODE TABLE FOR THIS COMMAND.
          LDN    CTBLL-2     SIZE OF PP COMMAND TABLE
          STDL   T9

 DCM2     LDDL   T8          COMMAND CODE FROM REQUEST
          SBML   CTBL,T9     COMMAND CODE FROM TABLE ENTRY
          ZJN    DCM3        ENTRY FOUND
          LCN    2
          RADL   T9          DECREMENT INDEX
          PJK    DCM2        MORE ENTRIES

          LDK    IE.E01      ** INVALID COMMAND CODE **
          RJM    EPC         (NO RETURN)

 DCM3     LDML   CTBL+1,T9   GET ADDRESS OF COMMAND ROUTINE
          STML   DCMA        SET UP JUMP * MODIFY INSTRUCTION *
          RJM    DCMAA       * VIOD INSTRUCTION PIPE FOR MODIFIED INSTRUCTION *
 DCMAA    BSS    1           *                                                *
          RJM    **          EXECUTE COMMAND * MODIFIED INSTRUCTION *
 DCMA     EQU    *-1
          SOML   DCMB        DECREMENT COMMAND COUNTER BY 1 (INSTR MODIFIER)
          ZJN    DCP         IF NO MORE COMMANDS TO DO
          LDK    CMDLEN
          RAML   DCMC        POINT TO NEXT COMMAND FIELD.
          UJK    DCM1        GO AND DO ANOTHER COMMAND

 DCMB     BSSZ   1           COMMAND COUNT
DCP       SPACE  4,10
*
*         COMPLETE COMMAND PROCESSING.
*
 DCP      LDK    R.NRM       SET NORMAL REQUEST TERMINATION INDICATOR
          RAML   RSPBUF+/RS/P.RC

 DCP1     BSS    0
          LDK    REQBUF+/RQ/P.CMND  GET PP ADDR OF FIRST COMMAND
          ADML   DCMC        GET PP ADDRESS OF LAST COMMAND
          ADC    -REQBUF     GET PP WORDS INTO REQUEST
          SHN    1           CM BYTES INTO REQUEST
          ADML   RSPBUF+/RS/P.REQ+1  ADD ON HALF 2 OF REQUEST BUFFER RMA
          STML   RSPBUF+/RS/P.LASTC+1  RMA HALF 2 OF LAST COMMAND
          SHN    -16         GET CARRY IF ANY
          ADML   RSPBUF+/RS/P.REQ  ADD ON HALF 1 OF REQUEST BUFFER RMA
          STML   RSPBUF+/RS/P.LASTC  RMA OF HALF 1 OF LAST COMMAND
          RJM    RSP         SEND RESPONSE TO CPU

 DCPA     LDN    0           (INSTRUCTION MODIFIED IF RESUME_PP COMMAND)
          ZJN    DCP2        IF NOT RESUME_PP COMMAND PROCESSED

 DCPB     EQU    *           (INSTRUCTION MODIFIED TO NOP BY *ICI*)
          RJM    IQI         COMPLETE DRIVER INITIALIZATION

 DCP2     BSS    0
          LJM    0,MLPRTN    TO MAIN LOOP
EPC       SPACE  2
** EPC -  ERROR PROCESS.
*
** PURPOSE - PROCESSING FOR ERRORS ON PP REQUESTS.
*
** INPUT -
*         (A) = INTERFACE ERROR CODE TO BE REPORTED
*
** OUTPUT -
*         RSPBUF - P.IEC = INTERFACE ERROR CODE.
*                - P.ABNFL = ABNORMAL TERMINATION.

 EPC      SUBR               ENTRY (NO RETURN)
          STML   RSPBUF+/RS/P.IEC  SET INTERFACE ERROR CODE
          LDK    ABN.IE      SET I/F ERROR FLAG
          STML   RSPBUF+/RS/P.ABNFL
*         UJK    DER         ABNORMAL TERMINATION OF REQUEST

*         DO-COMMAND ERROR PROCESSING.
 DER      LDK    R.ABN
          STML   RSPBUF+/RS/P.RC  SET ABNORMAL TERMINATION RESPONSE
          UJK    DCP1        SEND RESPONSE TO CPU
CTBL      EJECT
*         PP COMMANDS
*
 CTBL     CON    C.PC0       ACKNOWLEDGE
          CON    PC0

          CON    C.PC1       STOP UNIT
          CON    PC1

          CON    C.PC4       IDLE
          CON    PC4

          CON    C.PC5       RESUME
          CON    PC5

 CTBLL    EQU    *-CTBL      COMMAND TABLE LENGTH
PC0       EJECT
** PC0 -  PP COMMAND 0.
*
** PURPOSE -
*         PROCESS ACKNOWLEDGE COMMAND.
*
** INPUT - (NONE).
*
** OUTPUT - (NONE).
*

** PC1 - PP COMMAND 1.
*
** PURPOSE -
*         PROCESS STOP UNIT COMMAND.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
 PC1      SUBR               ENTRY/EXIT
          RETURN             EXIT

 PC0      EQU    PC1         (SAME CODE AS PC1)


** PC4 - PP COMMAND 4.
*
** PURPOSE -
*         PROCESS IDLE COMMAND.
*
** INPUT - NONE.
*
** OUTPUT - NONE.
*
** CALLS - MDN.

 PC4      SUBR               ENTRY/EXIT
          AOML   PPIDLE      SET PP IDLE FLAG NONZERO
          RJM    MDN         SET MACHINE STATUS FLAG REGISTER TO DOWN

 PC4A     EQU    *           (CHANGED AT INITIALIZATION IF CY930/ICI)
          UJN    PC4.1       (PASS - IF CY930/ICI)
          LDK    ICI.DES     DESELECT C170 CONVERTER
          RJM    FCN         FUNCTION C170 CONVERTER

 PC4.1    BSS    0
          RETURN             EXIT

** PC5 -  PP COMMAND 5.
*
** PURPOSE -
*         PROCESS RESUME COMMAND.
*
** INPUT - NONE.
*
** OUTPUT - NONE.
*
** CALLS - CIC, MUP.

 PC5      SUBR               ENTRY/EXIT
          AOML   DCPA        SET FLAG FOR RESUME_PP COMMAND PROCESSED

 PC5A     EQU    *           (INSTRUCTION MODIFIED TO NOP AFTER INITIALIZATION)
          UJN    PC5.3       (CHANNEL NOT INITIALIZED YET)

 PC5B     EQU    *           (INSTRUCTION MODIFIED TO NOP IF CY930/ICI)
          UJN    PC5.2       (PASS - IF CY930/ICI)
          RJM    CIC         MASTER CLEAR CHANNEL (I0 ONLY)

 PC5.2    BSS    0
          RJM    MUP         SET MACHINE STATUS FLAG REGISTER TO UP

          LDN    0
          STML   PPIDLE      CLEAR THE PP IDLE FLAG
 PC5.3    BSS    0
          RETURN             EXIT

          TITLE  PP REQUEST PROCESSING SUBROUTINES
CLK       SPACE  4,20
** CLK -  CLEAR PP REQUEST QUEUE LOCK.
*
** PURPOSE - CLEAR THE LOCKWORD ON THE PP REQUEST QUEUE.
*
** INPUT - (NONE)
*
** OUTPUT - QUEUE LOCK IS CLEARED IN PP REQUEST QUEUE.
*           (PPLOCK) = ZERO.
*
** USES  - T5, T7.
*
** CALLS - CLW.


 CLK      SUBR               ENTRY/EXIT
          LDC    **          GET PP LOCKED FLAG
 PPLOCK   EQU    *-1         (PP LOCKED FLAG, NON ZERO IF LOCKED)

          ZJN    CLK1        RETURN IF PP NOT LOCKED ON ENTRY
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    CLW         CLEAR PP REQUEST QUEUE LOCK
          LDN    0
          STML   PPLOCK      CLEAR PP LOCKED FLAG
 CLK1     RETURN             EXIT
CLW       SPACE 6,40
** CLW -  CLEAR LOCK.
*
** PURPOSE-- CLEARS A LOCKWORD IN CENTRAL MEMORY.
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T4 .NE. PPNO, THIS LOCKWORD IS RESERVED TO A
*            DIFFERENT PROCESSOR.
*            RESTORE THE CONTENTS OF THIS CENTRAL MEMORY LOCATION
*            AS IT EXISTED BEFORE THE VALUE FFFF FFFF XXXX XXXX
*            WAS WRITTEN.
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
*
*         4. IF T4 = PPNO, THEN CLEAR THE LOCKWORD IN CENTRAL MEMORY.
*            SET T1 - T4 = 0000 0000 0000 0000.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
*
** INPUT -
*         T7 = ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CM INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY EORD OFFSET WITHIN THE
*              INTERFACE TABLE WHICH CONTAINS THE LOCKWORD.
*
** OUTPUT -
*         A REGISTER = 0, IF THE LOCK WAS CLEARED.
*         A REGISTER .NE. O, IF THE LOCK WAS NOT CLEARED.
*
* USES  - T1, T2, T3, T4, T6.


 CLW      SUBR               ENTRY/EXIT

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.
 CLW1     BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        CM ADDRESS OF INTERFACE TABLE
          ADDL   T5          ADD LOCKWORD OFFSET
          STDL   T6          SAVE CM ADDRESS OF LOCKWORD
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.
* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          NJN    CLW2        IF THIS PP WAS FIRST TO WRITE
                             THE INTERMEDIATE VALUE
          UJK    CLW1        REPEAT THE RDSL INSTRUCTION

 CLW2     BSS
          LDDL   T4          CHECK PP NUMBER
          SBDL   PP
          ZJN    CLW3        IF THIS PP HAS THE LOCK SET

* RESTORE THE ORIGINAL CONTENTS.

          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE ORIGINAL CONTENTS
          LDN    1
          UJK    CLW4        EXIT, A REGISTER NONZERO

* CLEAR THE LOCKWORD.

 CLW3     BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          CLEAR THE LOCKWORD
          LDN    0
 CLW4     RETURN             IF LOCK CLEARED EXIT, A REGISTER = 0
*                            IF LOCK NOT CLEARED EXIT, A REGISTER NONZERO
IPR       SPACE  4,40
** IPR -  INITIALIZE PP REQUEST RESPONSE.
*
** PURPOSE -
*         INITIALIZE RESPONSE IN PP BUFFER FOR A PP REQUEST RESPONSE.
*
** INPUT -
*         REQBUF - PP REQUEST.
*
** OUTPUT -
*         RSPBUF - PP REQUEST RESPONSE INITIALIZE.


 IPR      SUBR               ENTRY/EXIT
          LDK    P.RS        GET LENGTH OF RESPONSE BUFFER
          STDL   T5          SET UP LOOP COUNTER
 IPR1     LDK    0
          STML   RSPBUF      CLEAR BUFFER
          SODL   T5          DECREMENT LOOP COUNTER
          NJK    IPR1        RELOOP UNIT BUFFER CLEARED

          LDML   REQBUF+/RQ/P.NEXTPV REQUEST PVA PART 1
          STML   RSPBUF+/RS/P.PVA
          LDML   REQBUF+/RQ/P.NEXTPV+1  REQUEST PVA PART 2
          STML   RSPBUF+/RS/P.PVA+1
          LDML   REQBUF+/RQ/P.NEXTPV+2  REQUEST PVA PART 3
          STML   RSPBUF+/RS/P.PVA+2
          LDML   REQBUF+/RQ/P.NEXT   REQUEST RMA HALF 1
          STML   RSPBUF+/RS/P.REQ
          LDML   REQBUF+/RQ/P.NEXT+1 REQUEST RMA HALF 2
          STML   RSPBUF+/RS/P.REQ+1
          LDK    B.RS                PP REQUEST RESPONSE LENGTH
          STML   RSPBUF+/RS/P.RESPL  RESPONSE LENGTH
          LDML   REQBUF+/RQ/P.LU     LOGICAL UNIT
          STML   RSPBUF+/RS/P.LU
          LDML   REQBUF+/RQ/P.RECOV  RECOVERY, INTERRUPT, PORT,PRIORITY
          STML   RSPBUF+/RS/P.RECOV
          LDML   REQBUF+/RQ/P.LONGB  ALERT MASK
          STML   RSPBUF+/RS/P.LONGB
          RETURN
MDN       EJECT
** MDN -  MACHINE DOWN.
*
** PURPOSE -
*         CLEAR MACHINE ID NUMBER FROM MACHINE STATUS ESM 4 BIT FLAG REGISTER.
*
** INPUT - NONE.
*
** OUTPUT - NONE.
*
** USES - T4.
*
** CALLS - MSR.

 MDN      SUBR               ENTRY/EXIT
          LDK    FF.CLR      SELECTIVE CLEAR FLAG REGISTER FUNCTION
          STDL   T4
          LDDL   SI          THIS MACHINE'S (SOURCE) ID NUMBER
          RJM    MSR         DO FLAG OPERATION ON MACHINE STATUS REGISTER
          RETURN
MUP       SPACE  2,20
** MUP -  MACHINE UP.
*
** PURPOSE -
*         SET MACHINE ID NUMBER INTO MACHINE STATUS ESM 4 BIT FLAG REGISTER.
*
** INPUT - NONE.
*
** OUTPUT - NONE.
*
** USES - T4.
*
** CALLS - MSR.

 MUP      SUBR               ENTRY/EXIT
          LDK    FF.SET      SELECTIVE SET FLAG REGISTER FUNCTION
          STDL   T4
          LDDL   SI          THIS MACHINE'S (SOURCE) ID NUMBER
          RJM    MSR         DO FLAG OPERATION ON MACHINE STATUS REGISTER
          RETURN
SLK       SPACE  4,18
** SLK -  LOCK PP REQUEST QUEUE.
*
** PURPOSE - SETS THE PP REQUEST QUEUE LOCK IN THE
*            PP INTERFACE TABLE.
*
** INPUT - (NONE)
*
** OUTPUT - (A)      = 0 IF LOCK WAS SUCCESSFULLY SET.
*                      .NE. 0 IF LOCK COULD NOT BE SET.
*           (PPLOCK) = NON ZERO.
*
** USES -  T5, T7.
*
** CALLS - SLW.


 SLK      SUBR               ENTRY/EXIT
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    SLW         SET THE LOCKWORD
          NJN    SLK1        RETURN IF LOCK WAS NOT SET
          LDN    1
          STML   PPLOCK      SET PP LOCKED FLAG
          LDN    0           LOCK SET
 SLK1     RETURN             EXIT

** SLW -  SET LOCKWORD.
*
** PURPOSE-- SET A LOCKWORD IN CENTRAL MEMORY.
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T1 = 0, WRITE THE PP LOCKWORD TO CENTRAL MEMORY,
*            AS DESCRIBED IN THIS STEP.  ELSE IF T1 .NE. 0, GO TO
*            STEP 4.
*            TO WRITE THE PP LOCKWORD ID:
*            SET T1 - T4 = 8000 0000 0000 PPNO, WHERE PPNO IS THE
*            LOGICAL PP NUMBER OF THIS PP.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
*
*         4. IF T1 = 8000 AND T4 = PPNO, THIS LOCKWORD WAS ALREADY
*            RESERVED TO THIS PP.
*            RESTORE THE CENTRAL MEMORY LOCATION  (CWDL   T1).
*            SET THE A REGISTER = 0, AND EXIT.
*
*         5. IF T4 .NE. PPNO, THEN THIS LOCKWORD IS RESERVED TO
*            A DIFFERENT PROCESSOR.
*            SET BIT 16 OF THE LOCKWORD THAT WAS READ WITH THE
*            RDSL INSTRUCTION, AND WRITE THE CONTENTS BACK TO
*            CENTRAL MEMORY.
*            THE PURPOSE OF SETTING BIT 16 IS TO REQUEST THE
*            OTHER PROCESSOR TO GIVE UP THE LOCKWORD.
*            LDDL   T2
*            LPC    77777B
*            ADC    100000B
*            STDL   T2
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
*
** INPUT -
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** OUTPUT -
*         A REGISTER = 0, IF THE LOCK WAS SET.
*         A REGISTER .NE. O, IF THE LOCK COULD NOT BE SET.
*
** USES - T1, T2, T3, T4, T6.


 SLW      SUBR               ENTRY/EXIT

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 SLW1     BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.

          LDDL   T1
          ADDL   T4
          ZJN    SLW4        IF LOCK CAN BE SET

* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          NJN    SLW2        IF THIS PP WAS FIRST TO WRITE
                             THE INTERMEDIATE VALUE
          UJK    SLW1        REPEAT THE RDSL INSTRUCTION

* SET BIT 16 IN THE ORIGINAL CONTENTS OF CENTRAL MEMORY AND
* WRITE IT BACK TO CENTRAL MEMORY.

 SLW2     BSS
          LDDL   T2          SET THE 'REQUEST LOCKWORD' FLAG
          LPC    77777B
          ADC    100000B
          STDL   T2
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE LOCKWORD

          LDDL   T4
          SBDL   PP          CHECK IF LOCK ALREADY SET
          NJN    SLW3        IF LOCK COULD NOT BE SET, EXIT A .NE. 0
          LDDL   T1
          ADC    -100000B
 SLW3     RETURN             IF LOCK WAS ALREADY SET, EXIT A = 0
*                            IF LOCK COULD NOT BE SET, EXIT A .NE. 0

* SET THE LOCKWORD.

 SLW4     BSS
          LDC    100000B
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          LDDL   PP
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          SET THE LOCKWORD
          LDN    0
          UJK    SLW3        EXIT, A REGISTER = 0
WED       EJECT
** WED  - WRITE ESM DIVISION.
*         THIS SUBROUTINE IS INVOKED ON ERROR RECOVERY WHEN DOUBLE BIT
*         PARITY ERROR IS DETECTED IN ESM MEMORY.
*
** PURPOSE - WRITE ESM DIVISION TO CLEAR DOUBLE BIT ERRORS.
*
** INPUT -
*         SESMAD = SOURCE ESM ADDRESSES RECORD CONTAINS HEADER RECORD
*                  ADDRESS (BEGINNING ADDRESS) OF DIVISION TO BE WRITTEN.
*
** OUTPUT -
*         (A)    = ZERO, IF NO ERROR DETECTED ON WRITE.
*                = NONZERO, ERROR CODE INDICATING FAILURE,
*                     ER.FTO - CHANNEL FUNCTION TIMEOUT ERROR CODE
*                     ER.INA - INACTIVE CHANNEL ERROR CODE.
** USES - P1.
*
** CALLS - FCN.

 WED4     BSS    0
          LDK    ER.INA      ** INACTIVE CHANNEL ERROR CODE **

 WEDX     BSS    0

 WED      SUBR               ENTRY/EXIT
          LDC    FRAC        NUMBER OF FRACTIONS OF DIVISION
          STDL   P1          INITIALIZE FRACTION OF ESM DIVISION COUNTER
 WEDA     LDC    FC.WRT      ESM WRITE FUNCTION CODE (PLUS ICI.SSM IF CY930)
          RJM    FCN         FUNCTION ESM
          NJN    WEDX        IF  FUNCTION TIMEOUT ERROR

          ACN    CH40        ACTIVATE CHANNEL
          LDN    2           OUTPUT 2 12 BIT CHANNEL WORDS (ESM ADDRESS)
          OAM    SESMAD+/EMA/P.HDR,CH00  OUTPUT STARTING ESM ADDRESS
 WED1     IJM    WED4,CH00   CHANNEL INACTIVE ERROR
          FJM    WED1,CH00   WAIT FOR CHANNEL EMPTY

 WEDB     EQU    *           (CHANGED TO DCN CH40 IF CY930/ICI)
          UJN    WED2        WHEN NOT CY930/ICI
*         THIS IS NECESSARY FOR ICI CHANNEL TO SWITCH TO PACKING MODE.
*         DCN    CH40        TO ICI CHANNEL ONLY, ESM DOES NOT SEE THIS
          ACN    CH40        TO ICI CHANNEL ONLY, ESM DOES NOT SEE THIS

*         WRITE TO EACH FRACTION OF THE CURRENT ESM DIVISION.
 WED2     BSS    0
          LDC    **          12 OR 16 BIT DIV SIZE IN CH WRDS/100(8) SET BY *IEA*
 WEDC     EQU    *-1         (DIVISION SIZE IN CHANNEL WORDS/100(8) )

 WEDD     EQU    *           (CHANGED TO *OAM* AT INITIALIZATION IF ICI)
          OAPM   0001,CH00   PACKED OUTPUT FROM PP LOCATION 0001
 WED3     IJM    WED4,CH00   CHANNEL INACTIVE ERROR
          FJM    WED3,CH00   WAIT FOR CHANNEL EMPTY

          SODL   P1          DECREMENT FRACTION OF DIVISION COUNTER
          NJN    WED2        IF MORE FRACTIONS OF ESM DIVISION TO WRITE

          DCN    CH40        DEACTIVATE CHANNEL

          LDN    0           (NO ERROR)
          RETURN

 FRAC     EQU    100B        CHANNEL WORDS PER DIVISION IS DIVIDED BY 100(8)





 OVLLN    EQU    *-OVLSA     OVERLAY LENGTH IN PP WORDS
 OVLPPW   EQU    OVLLN+3     OVERLAY LENGTH IN PP WORDS PLUS 3 (ROUND UP)
 OVLSZ    EQU    OVLPPW/4    OVERLAY SIZE IN CM WORDS
          TITLE  VE PPU INITIALIZATION - PRESET
** PRS -  PRESET.
*
** PURPOSE -
*         PRESET THE DRIVER AFTER DEADSTART.
*
** INPUT - PPIT = CM REAL MEMORY ADDRESS (2 BYTES) OF THE PP INTERFACE
*                 TABLE FOR THIS PP.
*          PP   = PP NUMBER OF THIS PP.
*
** OUTPUT -
*

 UDPNT    EQU    T6          UNIT POINTER

*         PAUSE A SUFFICIENT AMOUNT OF TIME TO PERMIT THE DEADSTART PP
*         TO DISCONNECT ALL CHANNELS.
 PRS      LDK    8
          STDL   T1
 PRS1     PAUSE  125000D     DELAY 125 MILLISECONDS
          SODL   T1
          NJK    PRS1

          REFAD  PPIT,CM.PIT   PP INTERFACE TABLE RMA
*         (LOW CORE CELL *PPIT* NOW AVAILABLE FOR PP'S USE)

*         READ PP_INTERFACE_TABLE.
          LDK    PITLEN      GET LENGTH OF PIT IN CM WORDS
          STDL   WC
          LOADC  CM.PIT      PP INTERFACE TABLE CM ADDRESS
          CRML   PITBL,WC    READ PPIT AND UNIT DESCRIPTORS

*         GET THE ASSIGNED LOGICAL PP NUMBER.
          LDML   PITBL+/PIT/P.PPNO
          STDL   PP

*         REFORMAT ADDRESS OF RESPONSE BUFFER.
          REFAD  PITBL+/PIT/P.RSBUF,CM.RS    RESPONSE BUFFER RMA

*         INITIALIZE LIMIT OF RESPONSE BUFFER.
          LDML   PITBL+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STDL   RSLIM       RESPONSE BUFFER LIMIT OFFSET IN BYTES

*         REFORMAT ADDRESS OF PP/CPU INTERRUPT WORD.
          REFAD  PITBL+/PIT/P.INT,CM.INT  INTERRUPT ADDRESS RMA

*         GET CHANNEL NUMBER.
          LDK    0
          STDL   UDPNT       UNIT POINTER
          LDML   PITBL+/PIT/P.UNITC  GET NUMBER OF UNITS
          STDL   T1
          UJN    PRS3

 PRS2     LDK    P.UD        (SIZE OF UD ENTRY IN PP WORDS)
          RADL   UDPNT       INCREMENT UNIT POINTER
 PRS3     SODL   T1          DECREMENT NUMBER OF UNITS
          MJN    *           HANG IF NO UNIT
          LDML   UNITD+/UD/P.UQT,UDPNT  GET RMA UPPER HALF
          ADML   UNITD+/UD/P.UQT+1,UDPNT
          ZJN    PRS2        IF DUMMY ENTRY
          LDDL   UDPNT
          STML   IQIA        SAVE UNIT POINTER

 PRS4     BSS    0
          RJM    CCN         CHANGE CHANNEL NUMBERS
          UJK    MLP         ENTER MAIN LOOP WITH PPIDLE, OVERLAY LOADED
          TITLE  COMPLETE FILE SERVER PP DRIVER INITIALIZATION.
** IQI -  INITIALIZE FROM QUEUE INTERFACE TABLE.
*
** PURPOSE -
*         CONTINUATION OF DRIVER INITIALIZATION. WHEN THE DRIVER WAS LOADED
*         AND EXECUTED THE 'PRS' (PRESET) CODE, IT INITIALIZED FROM PARAMETERS
*         IN THE PP INTERFACE AND UNIT DESCRIPTOR TABLES, AND ENTERED THE
*         DRIVER'S MAIN LOOP TO WAIT FOR A "RESUME" PP COMMAND.
*         WHEN FILE SERVER STORES THE POINTER TO THE QUEUE INTERFACE TABLE
*         (IN PLACE OF POINTER TO NEXT UNIT REQUEST) AND ISSUES A RESUME PP
*         REQUEST THIS SUBROUTINE IS CALLED TO COMPLETE DRIVER INITIALIZATION
*         FROM PARAMETERS IN THE QUEUE INTERFACE TABLE.
*         INITIALIZE FROM PARAMETERS IN REQUEST BUFFER DIRECTORY, ESM BASE
*         ADDRESSES, AND DRIVER QUEUE DIRECTORY.
*
** INPUT -
*         IQIA    = UNIT TABLE INDEX.
*         PITBL   = PP INTERFACE TABLE.
*         UNITD   = UNIT DESCRIPTOR ENTRY.
*
** OUTPUT -
*         CM.RB   = REFORMATTED REQUEST BUFFER CM ADDRESS.
*         CM.RBD  = REFORMATTED REQUEST BUFFER DIRECTORY CM ADDRESS.
*         CM.RBI  = REFORMATTED REQUEST BUFFER IN POINTER CM ADDRESS.
*         DQDIR   = REFORMATTED DRIVER QUEUE DIRECTORY.
*         LU      = SOURCE LOGICAL UNIT.
*         RDQA    = NUMBER OF QUEUE DIRECTORY ENTRIES.
*         RBLIM   = REQUEST BUFFER LIMIT IN 8 BIT BYTES.
*         SI      = SOURCE ID NUMBER.
*
** CALLS - ERR, IEA, IEF, IEM, II0, MDN, RSP, SAVAD, WOV, XIO.

* UNABLE TO INITIALIZE SHOULD ANY OF THESE CONDITIONS OCCUR -
*         IF NO UNIT INTERFACE TABLE ADDRESS IN UNIT DESCRIPTOR.
*         IF NO QUEUE INTERFACE TABLE ADDRESS IN UIT (NEXT UNIT REQUEST).
*         IF INSUFFICIENT LENGTH FOR OVERLAY IN PP COMMUNICATION BUFFER.
*         IF NO FILE SERVER QUEUES SPECIFIED IN QUEUE DIRECTORY.
*         IF NUMBER OF QUEUES SPECIFIED IS GREATER THAN PP'S MAXIMUM ALLOWED.
 IQIX     BSS    0           UNABLE TO INITIALIZE

 IQI      SUBR   0           ENTRY
          LDC    *           UNIT TABLE INDEX
 IQIA     EQU    *-1         (UNIT TABLE INDEX STORED BY *PRS*)
          STDL   UDPNT
          LDML   UNITD+/UD/P.UQT,UDPNT  GET RMA UPPER HALF
          ADML   UNITD+/UD/P.UQT+1,UDPNT  ADD RMA LOWER HALF
          ZJN    IQIX        IF NO UNIT INTERFACE TABLE ADDRESS

          LDK    C.UIT       GET LENGTH OF UIT
          STDL   WC          SAVE LENGTH FOR CM READ
 IQI1     LOADF  UNITD+/UD/P.UQT,UDPNT  REFORMAT/LOAD CM ADDRESS OF UIT
          CRML   UITBL,WC   READ IN UNIT INTERFACE TABLE
          LDML   UITBL+/UIT/P.NEXT  HALF 1 OF RMA FOR QIT
          ADML   UITBL+/UIT/P.NEXT+1  IF RMA=0 NO QIT QUEUED
          ZJK    IQIX        IF QIT POINTER NOT PRESENT

 IQI2     LDML   UITBL+/UIT/P.LU
          STDL   LU          SAVE LOGICAL UNIT NUMBER
          STML   ENGLUN      SAVE LOGICAL UNIT FOR ENGINEERING RESPONSE

*         CHECK IF PP COMMUNICATION BUFFER LARGE ENOUGH FOR OVERLAY.
          LDML   PITBL+/PIT/P.CBUFL  LENGTH OF COMM BUFFER IN BYTES
          SHN    -3          /8 LENGTH OF COMM BUFFER IN CPU WORDS
          ADC    -OVLSZ      LENGTH OF OVERLAY (IN CM WORDS)
          MJK    IQIX        IF INSUFFICIENT LENGTH FOR OVERLAY

*         REFORMAT AND SAVE CM ADDRESS OF QUEUE INTERFACE TABLE
*         WHICH IS ALSO THE FWA OF THE REQUEST BUFFER DIRECTORY RECORD.
          REFAD  UITBL+/UIT/P.NEXT,CM.QIT

**        READ REQUEST BUFFER DIRECTORY RECORD.
          LDK    C.RBD       LENGTH OF REQUEST BUFFER DIRECTORY RECORD
          STDL   WC          SAVE LENGTH FOR CM READ
          LOADC  CM.RBD      ADDRESS OF REQUEST BUFFER DIRECTORY
          CRML   RBDIR,WC    READ REQUEST BUFFER DIRECTORY RECORD

*         REFORMAT AND SAVE CM ADDRESS OF REQUEST BUFFER.
          REFAD  RBDIR+/RBD/P.RBRMA,CM.RB
          LDML   RBDIR+/RBD/P.LIMIT  IN BYTES
          SHN    -3          /8 FOR CM WORDS
          STDL   RBLIM        SAVE REQUEST BUFFER LIMIT IN CM WORDS

**        READ DRIVER QUEUE DIRECTORY HEADER RECORD.
 IQI3     LDK    C.QDH       LENGTH OF DRIVER QUEUE DIRECTORY HEADER
          STDL   WC          SAVE LENGTH FOR CM READ
          LOADC  CM.QIT      ADDRESS OF QUEUE INTERFACE TABLE
          ADK    QIT.QDH     ADD OFFSET TO QUEUE DIRECTORY HEADER
          CRML   DQDHD,WC    READ DRIVER QUEUE DIRECTORY HEADER RECORD
          LDML   DQDHD+/QDH/P.NQDE
          STML   RDQA        SAVE NUMBER OF QUEUE DIRECTORY ENTRIES
          STDL   T3          (SAVE FOR READ OF QUEUE DIRECTORY)
          ZJK    IQIX        IF NO QUEUES ESTABLISHED
          SBN    MAXQDE+1    (MAXIMUM NUBER OF QUEUE ENTRIES+1)
          PJK    IQIX        IF MORE QUEUES THAN SPACE
          LDML   DQDHD+/QDH/P.SIDN
          STDL   SI          ESTABLISH SOURCE ID NUMBER

*         ESTABLISH REQUEST BUFFER (SEND) AND/OR ESM FLAG PROCESSOR (RECEIVE).
          LDML   DQDHD+/QDH/P.SNDPP
          STML   SNDPP       PP TO PROCESS REQUEST BUFFER ENTRIES (SEND)
          LDML   DQDHD+/QDH/P.RCVPP
          STML   RCVPP       PP TO PROCESS ESM SOURCE FLAGS (RECEIVE)

*         IF MACHINE IS CYBER 930 IOU MODEL I0 CHANGE I/O SUBROUTINES.
          LDML   DQDHD+/QDH/P.IOUMI0
          SHN    2+/QDH/L.IOUMI0  I0U I0 MODEL TO SIGN BIT
          PJN    IQI4        IF NOT I0 IOU
          RJM    II0         INITIAL FOR CYBER 930 IOU I0
          UJN    IQI7        CONTINUE SETUP

*         IF DMA ENHANCED CY170 ADAPTER PRESENT CHANGE I/O SUBROUTINES.
 IQI4     BSS    0
          LDML   SNDPP       SEND PP NUMBER
          LMML   RCVPP       RECEIVE PP NUMBER
          ZJN    IQI5        IF SEND AND RECEIVE PP ARE THE SAME PP
          LDML   SNDPP       SEND PP NUMBER
          LMDL   PP
          ZJN    IQI5        IF THIS PP IS THE SEND PP
          LDML   DQDHD+/QDH/P.DMARCV
          SHN    2+/QDH/L.DMARCV  DMARCV TO SIGN BIT
          UJN    IQI6        CHECK IF RECEIVE CHANNEL TO USE DMA CAPABILITY

 IQI5     LDML   DQDHD+/QDH/P.DMASND
          SHN    2+/QDH/L.DMASND  DMASND TO SIGN BIT

 IQI6     PJN    IQI7        IF NOT DMA ENHANCED CY170 ADAPTER CAPABILITY
          RJM    XIO         CHANGE I/O SUBROUTINE TO *DIO*
          UJN    IQI8

*         TURN OFF ERROR LOG DMA ADAPTER INFORMATION IF NOT DMA DRIVER MODE.
 IQI7     LDN    0
* * ASSEMBLY ERROR 9 EXPECTED ON NEXT TWO INSTRUCTIONS * *
          STML   EONA        NOP "RJM  EOD"
          STML   EONA+1      NOP "RJM  EOD"

**        READ DRIVER QUEUE DIRECTORY.
 IQI8     LOADC  CM.QIT      ADDRESS OF QUEUE INTERFACE TABLE
          ADK    QIT.QDE     ADD OFFSET TO QUEUE DIRECTORY RMA ADDRESS ENTRIES
          CRML   DQDIR,T3    READ QUEUE DIRECTORY RMA ENTRIES

*         REFORMAT DRIVER QUEUE DIRECTORY ENTRIES.
          LDN    0
          STDL   T1          INITIALIZE UNFORMATTED DQDIR OFFSET
          LDC    DQDIR
          STDL   T2          INITIALIZE ADDRESS TO SAVE REFORMATTED RMA

 IQI9     LOADF  DQDIR+/QDE/P.DQRMA,T1  REFORMAT RMA INTO *CM*
          LDML   CM+2
          RJM    SAVAD       SAVE CM - CM+2 IN (T2) - (T2)+2
          LDN    0
          STML   3,T2        CLEAR OUT LEFTOVER RMA IN (T2)+3
          LDK    P.QDE       PP WORDS PER REFORMATTED RMA (3 VALID)
          RADL   T2          INCREMENT REFORMATTED RMA SAVE ADDRESS
          LDK    P.QDE       PP WORDS PER UNFORMATTED RMA ENTRY
          RADL   T1          INCREMENT UNFORMATTED DIRECTORY OFFSET
          SHN    -2          /4 FOR NUMBER OF ENTRIES
          SBML   RDQA        NUMBER OF DIRECTORY ENTRIES
          NJK    IQI9        REFORMAT AND SAVE NEXT ENTRY

*         INITIALIZE BASE ESM ADDRESSES.
          RJM    IEA         INITIALIZE ESM BASE ADDRESSES
          RJM    CKP         CHECK PORT FUNCTIONALITY
          NJN    IQI12       IF PORT FAILURE
          LDML   SNDPP       SENDING PP NUMBER
          LMDL   PP          THIS PP'S NUMBER
          NJN    IQI10       IF THIS PP IS NOT SENDING, NO ESM INITIALIZATION
          RJM    IEF         INITIALIZE THIS MACHINE'S ESM FLAG REGISTERS
          NJN    IQI12       IF ERROR
          RJM    IEM         INITIALIZE THIS MACHINE'S ESM MEMEORY BLOCK
          NJN    IQI12       IF ERROR

*         TURN OFF DRIVER INITIALIZATION.
* * ASSEMBLY ERROR 9 EXPECTED ON NEXT THREE INSTRUCTIONS * *
 IQI10    LDN    0           CLEAR "RJM IQI" IN PP REQUEST PROCESSOR
          STML   DCPB        NOP "RJM IQI"
          STML   DCPB+1      NOP "RJM IQI"
          STML   PC5A        ALLOW CHANNEL OPERATIONS AFTER RESUME_PP COMMAND
          LDN    0
          STML   PPIDLE      CLEAR THE PP IDLE FLAG
          RJM    WOV         WRITE PP OVERLAY TO COMMUNICATIONS BUFFER
          RJM    MUP         SET MACHINE STATUS FLAG REGISTER TO UP
 IQI11    BSS    0
          RETURN


 IQI12    BSS    0           INITIALIZATION ERROR
          STML   IQIC        SAVE ERROR CODE
          RJM    IRS         INITIALIZE ONE WORD RESPONSE
          LDC    *
 IQIC     EQU    *-1         (SAVED ERROR CODE)
          RJM    ERR         STORE ERROR IN ONE WORD RESPONSE
          RJM    RSP         WRITE ONE WORD RESPONSE
          UJN    IQI11       (RETURN PP NOT INITIALIZED)
CKP       SPACE  4,20
** CKP -  CHECK PORT STATUS.
*
** PURPOSE -
*         CHECK LOW SPEED PORT FUNCTIONALITY PRIOR TO INITIALIZATION
*         OF FLAGS AND MEMORY.
*
** INPUT - INITIALIZED CHANNEL NUMBERS AND ESM ADDRESSES.
*
** OUTPUT -
*           (A)    = ZERO, IF NO PORT ERROR.
*                  = NON ZERO, IF ERROR.
*
** USES - NONE.
*
** CALLS - PST, RECOVER.

 CKP      SUBR               ENTRY/EXIT
 CKP1     RJM    PST         GET PORT STATUS
          RECOVER  CKP1      RETRY TO FORCE ENGINEERING LOG MESSAGE IF ERROR
          LPK    ERCODM      (RETAIN ONLY ERROR CODE FIELD)
          RETURN
IEA       EJECT
** IEA -  INITIALIZE ESM ADDRESSES.
*
** PURPOSE -
*         INITIALIZE TABLE OF ESM BASE ADDRESSES.
*
** INPUT - CM.QIT = REFORMATTED QUEUE INTERFACE TABLE CM ADDRESS.
*
** OUTPUT - BMEMAD = BASE ESM MEMORY ADDRESS/100(8).
*           DSZCW  = DIVISION SIZE IN CHANNEL WORDS/100(8).
*           TBFLGA = TABLE OF BASE ESM FLAG REGISTER ADDRESSES PER ID.
*           TBMOFF = TABLE OF BASE ESM MEMORY ADDRESS OFFSETS/100(8) PER ID.
*           TDIVOF = TABLE OF ESM DIVISION OFFSETS/100(8).
*           NDIVS  = NUMBER OF ESM DIVISIONS PER MACHINE.
*
** USES - T1 THRU T9.
*
** CALLS - NONE.

 IEA      SUBR               ENTRY
          LDK    C.ESM       LENGTH OF ESM BASE ADDRESSES RECORD (CM WORDS)
          STDL   T9
          LOADC  CM.QIT      ADDRESS OF QUEUE INTERFACE TABLE
          ADK    QIT.ESM     OFFSET TO ESM BASE ADDRESSES RECORD
          CRML   T1,T9       READ ESM BASE ADDRESS RECORD FROM CM

          LDDL   T1+/ESM/P.NDIVS
          STDL   NDIVS       NUMBER OF DIVISIONS PER MACHINE
          STML   FRQA        INITIALIZE LAST DIVISION PROCESSED

          LDDL   T1+/ESM/P.BMEMA
          STML   BMEMAD      SAVE UPPER BIT OF BASE ESM MEMORY ADDRESS/100(8)
          LDDL   T1+/ESM/P.BMEMA+1
          STML   BMEMAD+1    SAVE LOWER BITS OF BASE ESM MEMORY ADDRESS/100(8)

          LDDL   T1+/ESM/P.D12CW
          STML   WEDC        SAVE ESM DIVISION SIZE IN 12 BIT CHAN WORDS/100(8)
 IEAA     UJN    IEA0        (CHANGED TO PASS BY *IIO* FOR 16 BIT CHANNEL

          LDDL   T1+/ESM/P.D16CW
          STML   WEDC        SAVE ESM DIVISION SIZE IN 16 BIT CHAN WORDS/100(8)

*         BUILD TABLE OF DIVISION OFFSETS/100(8).
 IEA0     BSS    0
          LDN    1
          STDL   T9          BEGIN WITH DIVISION NUMBER ONE
          LDN    0
          STML   TDIVOF,T9   (DIVISION ONE'S OFFSET ALWAYS ZERO)

 IEA1     AODL   T9          INCREMENT DIVISION NUMBER
          LDML   TDIVOF-1,T9  PREVIOUS DIVISION'S OFFSET
          ADDL   T1+/ESM/P.DIVSZ  ADD ESM DIVISION SIZE/100(8)
          STML   TDIVOF,T9   CURRENT DIVISION'S OFFSET/100(8)
          LDDL   T9
          SBDL   NDIVS
          MJN    IEA1        IF MORE DIVISION OFFSETS

 IEA2     LDDL   T1+/ESM/P.BFLGA  BASE ESM 4 BIT FLAG REGISTER ADDRESS
          STML   MSFLGB      BASE MACHINE STATUS ESM FLAG REGISTERS ADDRESS
          ADDL   T1+/ESM/P.NMACH
          STDL   T1+/ESM/P.BFLGA  BASE DIVISION STATUS ESM FLAG REGISTER ADDRESS

          LDN    0
          STDL   T9          INITIALIZE TABLE INDEX

*         STORE BASE FLAG REGISTER ADDRESS FOR EACH MACHINE.
 IEA3     AODL   T9          INCREMENT TABLE INDEX
          LDDL   T1+/ESM/P.BFLGA   CURRENT ESM BASE FLAG ADDRESS
          STML   TBFLGA,T9         STORE IN TABLE FOR CURRENT ID
          ADDL   NDIVS             INCREMENT TO BASE FOR NEXT MACHINE
          STDL   T1+/ESM/P.BFLGA   NEXT MACHINES BASE FLAG ADDRESS

*         STORE BASE ESM MEMORY ADDRESS OFFSET FOR EACH MACHINE.
          LDML   IEAB              CURRENT ESM BASE MEMORY ADDRESS OFFSET
          STML   TBMOFF,T9         STORE IN TABLE FOR CURRENT ID
          ADML   TDIVOF,NDIVS      OFFSET TO FWA OF LAST ESM DIVISION
          ADDL   T1+/ESM/P.DIVSZ   PLUS ESM DIVISION SIZE/100(8)
          STML   IEAB              SAVE ESM BASE ADDRESS OFFSET FOR NEXT MACHINE

          LDDL   T9          TABLES INDEX
          SBDL   T1+/ESM/P.NMACH
          NJN    IEA3        IF MORE MACHINE ID NUMBERS
          RETURN

 IEAB     BSSZ   1                 CURRENT ESM BASE MEMORY ADDRESS OFFSET
IEF       EJECT
** IEF -  INITIALIZE FLAG REGISTERS.
*
** PURPOSE -
*         ESM FLAG REGISTERS FOR SPECIFIED MACHINE ID NUMBER ARE SET
*         TO ZERO.
*
** INPUT -
*         (SI)    = SOURCE MACHINE ID NUMBER (THIS MACHINES ID NUMBER).
*         NDIVS  = NUMBER OF DIVISIONS PER MACHINE.
*         TBFLGA = TABLE OF BASE FLAG REGISTER ADDRESSES.
*
** OUTPUT -
*         (A)    = ZERO, IF NO ERROR.
*                      NONZERO, IF CHANNEL ERROR.
*
** USES - T2, T3, T4.
*
** CALLS - FOP.

 IEF      SUBR               ENTRY/EXIT
          LDK    FF.CLR      SELECTIVE CLEAR FLAG FUNCTION
          STDL   T4
          LDK    FR.XXX+FR.HLD+FR.RDY+FR.RSV  CLEAR ALL FLAGS
          STDL   T3
          LDML   MSFLGB      BASE 4 BIT FLAG ADDRESS FOR MACHINE STATUS FLAGS
          ADDL   SI          THIS MACHINE'S ID IS ADDRESS OFFSET
          SBN    1
          RJM    FOP         CLEAR MACHINE STATUS 4 BIT FLAG REGISTER
          LDN    0
          STDL   T2          DIVISION OFFSET

 IEF1     LDML   TBFLGA,SI   BASE FLAG REGISTER ADDRESS PER ID
          ADDL   T2          DIVISION OFFSET
          RJM    FOP         CLEAR ESM BUFFER STATUS FLAG REGISTER
          NJN    IEF2        IF ERROR WHILE INITIALIZING FLAGS
          AODL   T2          INCREMENT DIVISION OFFSET
          SBDL   NDIVS       NUMBER OF DIVISIONS PER MACHINE
          NJN    IEF1        IF MORE DIVISIONS
 IEF2     RETURN
IEM       EJECT
** IEM -  INITIALIZE ESM MEMORY.
*
** PURPOSE -
*         INITIALIZE THE BLOCK OF ESM MEMORY ASSIGNED TO THIS PP
*         BY WRITING ESM MEMEORY.
*
** INPUT -
*         (SI)   = SOURCE MACHINE ID (MACHINE THIS PP IS ON).
*         TBMOFF = TABLE OF BASE ESM MEMORY ADDRESS OFFSETS/100(8)
*
** OUTPUT -
*         (A)    = ZERO, IF NO ERROR.
*
** USES - DI.
*
** CALLS - SEA, WED.

 IEM      SUBR               ENTRY/EXIT
          LDDL   SI          THIS PP'S ID NUMBER
          STDL   ID          (USED BY *SEA*)
          LDN    0
          STDL   DI          INITIALIZE ESM DIVISION INDEX TO ZERO

*         WRITE TO EACH ESM DIVISION FOR THIS MACHINE.
 IEM1     AODL   DI          INCREMENT TO NEXT ESM DIVISION
 IEM2     BSS    0           ATTEMPT RECOVERY FROM THIS POINT
 IEMA     LDC    FC.WRT      ESM WRITE FUNCTION CODE (PLUS ICI.SSM IF CY930)
          STDL   T6          SAVE LSP FUNCTION (DONE ONLY FOR RECOVERY CODE)
          LDN    SADESM      ADDRESS OFFSET OF ADDRESS TO STORE ESM ADDRESSES
          STDL   EMA         (SAVE POINTER TO STARTING ESM ADDRESS)
          RJM    SEA         SET ESM ADDRESSES
          RJM    WED         WRITE INTO THE DIVISION

          RECOVER  IEM2

          LDDL   DI          CURRENT ESM DIVISION
          SBDL   NDIVS       NUMBER OF ESM DIVISIONS PER MACHINE
          MJK    IEM1        IF MORE ESM DIVISIONS TO WRITE
          SFM    *,CH00      CLEAR CHANNEL ERROR FLAG
          LDK    FC.PMC      ESM LOW SPEED PORT MASTER CLEAR
          RJM    FCN
          RETURN
II0       EJECT
** II0  - INITIALIZE FOR IOU MODEL I0 CY930/C170 CONVERTER CHANNEL (ICI).
*         THIS SUBROUTINE MODIFIES I/O RELATED CODE TO ALLOW OPERATION
*         ON CY930 MACHINE VIA ICI CHANNEL C170 CONVERTER.
*
*         THIS SUBROUTINE MUST BE CALLED SOME TIME AFTER *CCN* SO THAT THE
*         CORRECT CHANNEL NUMBER IS STORED INTO THE I/O INSTRUCTIONS BELOW.
*
** CALLS - CIC, XIO.

* * * THESE ARE NOT INTENDED TO BE EXECUTED AT THIS LOCATION.
 INS.IAM  IAM    *,CH00      INPUT (A) WORDS INSTRUCTION (CHANNEL TABLE CH00)
 INS.OAM  OAM    *,CH00      OUTPUT (A) WORDS INSTRUCTION (CHANNEL TABLE CH00)
* * *

 II0      SUBR               ENTRY/EXIT

*         SET ICI CY170 CONVERTER FUNCTION TO BE ADDED TO ESM FUNCTION CODES.
          LDK    ICI.SSM/10000B  STORNET SUBSYS MODE ICI FUNCTION
          RAML   WEDA        ADD ICI.SSM FUNCTION TO *LDC* INSTRUCTION
          STML   IEMA        ADD ICI.SSM FUNCTION TO *LDC* INSTRUCTION
          STML   REHA        ADD ICI.SSM FUNCTION TO *LDC* INSTRUCTION
          STML   WEHA        ADD ICI.SSM FUNCTION TO *LDC* INSTRUCTION

          LDK    ICI.12B/10000B  12 BIT MODE ICI FUNCTION
          RAML   FOPA        ADD ICI.12B FUNCTION TO *LDC* INSTRUCTION
          STML   PSTA        ADD ICI.12B FUNCTION TO *LDC* INSTRUCTION
          STML   ENGC        ADD ICI.12B FUNCTION TO *LDC* INSTRUCTION

*         MODIFY *IEA* INITIALIZE ESM ADDRESSES SUBROUTINE.
          LDN    0           'PASS' INSTRUCTION
          STML   IEAA        ALLOW ICI 16 BIT CHANNEL WORD COUNT/100(8) DIVSIZ

*         MODIFY *WED* WRITE ESM MEMORY SUBROUTINE.
          LDML   INS.OAM     OUTPUT CH00 INSTRUCTION
          STML   WEDD        CHANGE *IAPM* TO *OAM*

*         ENABLE EXECUTION OF SELECT/DESELECT ICI CONVERTER.
*         MODIFY *PC4* IDLE PP COMMAND SUBROUTINE.
*         MODIFY *ENG* ERROR RECOVERY SUBROUTINE.
          LDN    0           'PASS' INSTRUCTION
          STML   ENGB        EXECUTE MCLR AND SELECT ICI FUNCTION
          STML   PC4A        EXECUTE DESELECT ICI FUNCTION
          STML   PC5B        EXECUTE SELECT ICI FUNCTION

*         ENABLE DCN/ACN FOR STORNET MODE TURN AROUND.
*         MODIFY *WED* WRITE ESM MEMORY SUBROUTINE.
*         MODIFY *RWH* READ/WRITE ESM HEADER SUBROUTINE.
          LDML   INS.DCN     (DCN CH40  INSTRUCTION)
          STML   WEDB        EXECUTE 'DCN/ACN' FOR ICI CHANNEL
          STML   RWHB        EXECUTE 'DCN/ACN' FOR ICI CHANNEL

*         MODIFY *RWH* READ/WRITE ESM HEADER SUBROUTINE.
          LDC    EHSIZ-EHSIZC  CHANNEL WORD COUNT DIFFERENCE FOR 16 VS 12
          RAML   RWHC        CHANGE HEADER WORD COUNT FOR 16 BIT CHANNEL WORDS
          LDML   INS.IAM     INPUT CH00 INSTRUCTION
          STML   RWHD        CHANGE *IAPM* TO *IAM*
          LDC    EHSIZ-EHSIZC  CHANNEL WORD COUNT DIFFERENCE FOR 16 VS 12
          RAML   RWHE        CHANGE HEADER WORD COUNT FOR 16 BIT CHANNEL WORDS
          LDML   INS.OAM     OUTPUT CH00 INSTRUCTION
          STML   RWHF        CHANGE *OAPM* TO *OAM*

*         MODIFY *XIO* CHANGE I/O SUBROUTINE.
          LDC    ICI         ADDRESS OF ICI CHANNEL I/O SUBROUTINE
          STML   XIOA        ADDRESS OF CM I/O SUBROUTINE
          RJM    XIO         CHANGE I/O SUBROUTINE CALLS

*         SELECT ICI CY170 CONVERTER.
          RJM    CIC         MASTER CLEAR CHANNEL (I0 ONLY)
          RETURN
CNN       EJECT
** CCN -  CHANGE CHANNEL NUMBER.
*
** PURPOSE -
*         CHANGE CHANNEL NUMBER IN CHANNEL INSTRUCTIONS.
*
** INPUT -  UDPNT = POINTER TO UNIT DESCRIPTOR TABLE.
*
** OUTPUT - (NONE)
*
** USES - T1, T2, T3.

 CCNX     BSS    0

          DCN    CH40        UNCONDITIONAL DEACTIVATE CHANNEL

 CCN      SUBR               ENTRY/EXIT
          LDML   UNITD+/UD/P.CHAN,UDPNT  GET CHANNEL
          SHN    -8
          LPN    37B
          STDL   T3          SAVE NEW CHANNEL NUMBER
          SBML   CURCH       CURRENT CHANNEL NUMBER
          ZJN    CCNX        NO CHANGE NEEDED

          RAML   CURCH       SAVE NEW CURRENT CHANNEL
          LDK    0
          STDL   T1          CHANGE CHANNEL INSTRUCTIONS

 CCN1     LDML   CONCH,T1    ADDRESS OF CHANNEL INSTRUCTIONS
          ZJN    CCNX        END OF LIST
          STDL   T2
          LDIL   T2
          SCN    37B
          LMDL   T3          GET NEW CHANNEL NUMBER
          STIL   T2
          AODL   T1
          UJK    CCN1

 CURCH    CON    0           CURRENT CHANNEL NUMBER

*         CHANNEL TABLE.
*         NOTE - THE CHANNEL TABLE MUST OCCUR AFTER LAST CHANNEL INSTRUCTION.

 CONCH    BSS    0
 TCH00    HERE   TABLE CH00 - CHANNEL TABLE
 TCH40    HERE   TABLE CH40 - CHANNEL TABLE
 TTP+40B  HERE
 T40B+TP  HERE
 TTP      HERE
          CON    0
SAVAD     EJECT
** SAVAD - SAVE ADDRESS.
*
** PURPOSE -
*         MOVE A REFORMATED ADDRESS CONTAINED IN (CM)
*         TO A MEMORY LOCATION.
*
** INPUT -
*         (A)    = WORD 2 OF REFORMATTED CM RMA (CM+2).
*         CM - CM+2 = WORDS 0 AND 1 OF REFORMATTED CM RMA.
*         (T2)   = FIRST PP ADDRESS TO RECEIVE THE REFORMATED CM RMA.

 SAVAD    SUBR
          STML   2,T2
          LDDL   CM
          STIL   T2
          LDDL   CM+1
          STML   1,T2
          RETURN
WOV       EJECT
** WOV  - WRITE OVERLAY.
*
** INPUT -
*         PITBL  - PP INTERFACE TABLE.
*
** OUTPUT - NONE.
*
** USES - WC.

 WOV      SUBR               ENTRY/EXIT
*         REFORMAT AND SAVE CM ADDRESS OF PP COMMUNICATION BUFFER.
          REFAD  PITBL+/PIT/P.CBUF,CM.CB
          LDML   PITBL+/PIT/P.CBUFL  LENGTH OF COMM BUFFER IN BYTES
          SHN    -3          /8 LENGTH OF COMM BUFFER IN CPU WORDS
          ADC    -OVLSZ      LENGTH OF OVERLAY (IN CM WORDS)
          MJN    WOV1        IF INSUFFICIENT LENGTH FOR OVERLAY

*         WRITE OVERLAY TO PP COMMUNICATION BUFFER
          LDK    OVLSZ       LENGTH OF OVERLAY IN CM WORDS
          STDL   WC          SAVE CPU WORD COUNT FOR CM WRITE
          LOADC  CM.CB       (LOAD REFORMATTED CM ADDRESS)
          CWML   OVLSA,WC    WRITE OVERLAY TO CM
 WOV1     RETURN
XIO       EJECT
** XIO -  CHANGE I/O ROUTINE.
*
** PURPOSE -
*         CHANGE RETURN JUMP TO *CIO* INSTRUCTIONS TO
*         RETURN JUMP TO *DIO* INSTRUCTIONS, OR
*         IF CYBER 930, TO RETURN JUMP TO *ICI* INSTRUCTIONS.
*
** INPUT -
*         TRJCIO = TABLE OF INSTRUCTIONS TO MODIFY.
*
** OUTPUT - NONE.
*
** CALLS - FCN.
*
** USES - T1, T2.

 XIO2     BSS    0
          LDML   XIOA
          LMC    DIO
          NJN    XIOX        IF NOT CY170 DMA CHANNEL I/O ROUTINE
          LDK    FC.AMC      MASTER CLEAR DMA ADAPTER FUNCTION
          RJM    FCN

 XIOX     BSS    0
 XIO      SUBR               ENTRY/EXIT
          LDK    0
          STDL   T1
 XIO1     LDML   TRJCIO,T1   ADRS+1 OF RETURN JUMP TO CIO INSTRUCTION
          ZJN    XIO2        END OF LIST
          STDL   T2
          LDC    DIO         ADDRESS OF SUBROUTINE FOR CENTRAL MEMORY I/O
 XIOA     EQU    *-1         (*ICI* IF CY930)

          STIL   T2
          AODL   T1
          UJK    XIO1        CHANGE NEXT

*         TABLE OF RETURN JUMP TO *CIO* INSTRUCTION ADDRESS+1.
*         (GENERATED VIA *PAGEIO* MACRO)

 TRJCIO   BSS    0
 TCIO     HERE
          CON    0


          ERRPL  *-PPMSZ-1

          END    ESMD
*DECK DECK=EUM$CHANGE_MENU_VE_ACTIVATION EXPAND=TRUE

PROC change_menu_ve_activation, chamva (
  automatic, a         : boolean = yes
  natural_language, nl : name = us_english
  status               : var of status = $optional
  )

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"     The purpose of this command is to turn 'on' or 'off' the automatic
"activation of the MENU/VE user menu.  This is accomplished by modifying the
"SYSTEM_PROLOG by either adding or deleting the INITIALIZE_USER_MENU command
"and the associated delimiter lines, respectively.
*IFEND

  create_variable ignore_status k=status
  create_variable local_status k=status
  create_variable system_prolog k=string v='$system.prologs_and_epilogs.system_prolog'
  create_variable menu_startup_commands k=string v='$local.'//$unique

COLLECT_TEXT o=$fname(menu_startup_commands) until='END_COLLECT' sm='?'
"**MENU_VE STARTUP CALL**
include_line 'INITIALIZE_USER_MENU ic=true nl=?$string($value(natural_language))?' status=osv$status
"**END MENU_VE VER 1.0**
END_COLLECT

  EDIT_FILE $fname(system_prolog) p=$null o=$null
    locate_text  text='"**MENU_VE STARTUP CALL**' status=local_status
    IF local_status.normal  THEN
      delete_text text='"**MENU_VE STARTUP CALL**'..'"**END MENU_VE VER 1.0**' status=ignore_status
    IFEND
    IF $value(automatic)  THEN
      read_file $fname(menu_startup_commands) p=after il=last
    IFEND
    write_file f=$fname(system_prolog//'.$NEXT')
  END no
  change_file_attributes $fname(system_prolog//'.$HIGH') ra=(3,13,13) status=ignore_status
  detach_file $fname(system_prolog//'.$HIGH') status=ignore_status
  detach_file $fname(menu_startup_commands) status=ignore_status

PROCEND change_menu_ve_activation


*DECK DECK=EUM$CONVERT_MENU_VE EXPAND=TRUE
PROC convert_menu_ve, convmv (
  status : var of status = $optional
  )


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"     The purpose of this request is to complete site conversion of MENU/VE from
"an applications product to a VE product.  This involves removing the MENU/VE
"catalogs and command procedures from the applications environment.
"     This procedure is called by the BASE_3 installer procedure, after the
"MENU/VE files have been installed into their new catalog on VE.  If
"APP$COMMAND_LIBRARY is empty after removing the MENU/VE command procedures it is
"deleted.
*IFEND

  create_variable applications_catalog k=string v='$system.applications'

  create_variable app$command_library k=string v=applications_catalog//'.app$command_library'
  create_variable name=(proc_status, local_status, ignore_status) k=status
  create_variable modified_library k=boolean v=false
  create_variable remove_commands k=string v='$local.'//$unique

  EXIT_PROC WHEN NOT $file($fname(app$command_library), permanent)

COLLECT_TEXT o=$fname(remove_commands) until='END_COLLECT'

  PUSH file_connections

  delete_file_connection sf=$errors f=$local.output status=ignore_status

  CREATE_OBJECT_LIBRARY

  remove_block: ..
    BLOCK

      add_module l=$fname(app$command_library)

      delete_module m=select_family_admin_menu status=local_status
      IF local_status.normal THEN
        modified_library = true
      ELSEIF $condition(local_status.condition) <> 'OCE$E_SOME_MODULES_NOT' THEN
        EXIT remove_block
      IFEND

      delete_module m=select_main_menu status=local_status
      IF local_status.normal THEN
        modified_library = true
      ELSEIF $condition(local_status.condition) <> 'OCE$E_SOME_MODULES_NOT' THEN
        EXIT remove_block
      IFEND

      delete_module m=select_operators_menu status=local_status
      IF local_status.normal THEN
        modified_library = true
      ELSEIF $condition(local_status.condition) <> 'OCE$E_SOME_MODULES_NOT' THEN
        EXIT remove_block
      IFEND

      delete_module m=select_user_menu status=local_status
      IF local_status.normal THEN
        modified_library = true
      ELSEIF $condition(local_status.condition) <> 'OCE$E_SOME_MODULES_NOT' THEN
        EXIT remove_block
      IFEND

      local_status.normal = true

      EXIT remove_block WHEN NOT modified_library

      display_new_library o=$null status=local_status
      EXIT remove_block WHEN NOT local_status.normal

      generate_library l=$fname(app$command_library//'.$next')

    BLOCKEND remove_block

  QUIT

  IF (NOT local_status.normal) AND ($condition(local_status.condition) = 'OCE$W_NO_MODULES_ON_CURRENT_LIB') ..
        THEN
    local_status.normal = true
    delete_command_list_entry entry=$fname(app$command_library) status=ignore_status
    WHILE local_status.normal DO
      delete_file f=$fname(app$command_library//'.$low') status=local_status
    WHILEND
    local_status.normal = true
  IFEND

  IF local_status.normal THEN
    TASK ring=3
      $system.osf$builtin_library.delete_catalog_contents c=$fname(applications_catalog//'.ease_of_use') ..
            status=ignore_status
      delete_catalog c=$fname(applications_catalog//'.ease_of_use') status=ignore_status
      $system.osf$builtin_library.delete_catalog_contents ..
            c=$fname(applications_catalog//'.family_administration') status=ignore_status
      delete_catalog c=$fname(applications_catalog//'.family_administration') status=ignore_status
      $system.osf$builtin_library.delete_catalog_contents c=$fname(applications_catalog//'.operators_menu') ..
            status=ignore_status
      delete_catalog c=$fname(applications_catalog//'.operators_menu') status=ignore_status
    TASKEND
  IFEND

END_COLLECT

  include_file $fname(remove_commands) status=proc_status
  delete_file $fname(remove_commands) status=ignore_status
  IF proc_status.normal THEN
    proc_status = local_status
  IFEND

  EXIT_PROC WITH proc_status WHEN NOT proc_status.normal

PROCEND convert_menu_ve
*DECK DECK=EUM$INITIALIZE_USER_MENU EXPAND=TRUE

PROC initialize_user_menu, inium (
  initial_call, ic     : boolean = false
  natural_language, nl : name = us_english
  status               : var of status = $optional
  )


*IF $variable(euv$proc_doc,declared)<>'UNKNOWN'

"     The purpose of this command is to setup the user's environment to support
"activation of MENU/VE's user menu.  If ADMINISTER_USER does not define a user
"prolog, INITIALIZE_USER_MENU activates the user menu by calling SELECT_USER_MENU.
"If a user prolog is defined, execution is not done here.  When a user prolog is
"defined but does not exist, the prolog is created with a call to
"SELECT_USER_MENU.
"     Parameter INITIAL_CALL is declared for backward compatibility, the
"parameter is ignored.
"     The first section attempts to upgrade the user's environment from 1.2.2 to
"1.2.3 and beyond.  At 1.2.3 the catalog $USER.EUC$CYBER_MENU_SYSTEM is renamed
"$USER.CYBER_MENU_SYSTEM.  This is accomplished by backing up all files found in
"the old catalog and restoring them into the new catalog.  Finally, the old catalog
"is deleted.
"     In the 1.2.3 release, $USER.EUC$CYBER_MENU_SYSTEM  will be eliminated and
"MENU_VE attributes will be stored in the user's prolog per user's request.
*IFEND

  EXIT_PROC WHEN $job(mode) <> 'INTERACTIVE'

  create_variable admu_file k=string v='$local.'//$unique
  create_variable backup_file k=string v='$local.'//$unique
  create_variable catalog_status k=status
  create_variable commands k=string v='$local.'//$unique
  create_variable ignore_status k=status
  create_variable lines k=string d=10
  create_variable lines_returned k=integer v=0
  create_variable index k=integer v=1
  create_variable local_status k=status
  create_variable user_prolog k=string v=''


main_block: ..
  BLOCK

*IF $variable(euv$proc_doc,declared)<>'UNKNOWN'
" Following code is not needed for release 1.0 for there will be no new catalog and files created
"**      display_catalog c=$user.euc$cyber_menu_system o=$null status=catalog_status
"**      IF catalog_status.normal THEN
"**        display_catalog c=$user.cyber_menu_system o=$null status=catalog_status
"**        IF (NOT catalog_status.normal) AND ..    **"
"**              ($condition(catalog_status.condition) = 'PFE$UNKNOWN_LAST_SUBCATALOG') THEN
"**
"**  COLLECT_TEXT o=$fname(commands) until='END_COLLECT'
"**    BACKUP_PERMANENT_FILES bf=$fname(backup_file) l=$job_log
"**      backup_catalog c=$user.euc$cyber_menu_system
"**    QUIT
"**    RESTORE_PERMANENT_FILES l=$job_log
"**      restore_catalog c=$user.euc$cyber_menu_system bf=$fname(backup_file) ncn=$user.cyber_menu_system
"**    QUIT
"**    delete_file f=$fname(backup_file)
"**  END_COLLECT
"**
"**          include_file f=$fname(commands) status=local_status
"**          delete_file f=$fname(commands) status=ignore_status
"**          EXIT main_block WHEN NOT local_status.normal
"**          delete_catalog_contents c=$user.euc$cyber_menu_system status=ignore_status
"**          delete_catalog c=$user.euc$cyber_menu_system status=ignore_status
"**        IFEND
"**      IFEND
*IFEND


COLLECT_TEXT o=$fname(commands) until='END_COLLECT'
  ADMINISTER_VALIDATIONS
    display_user  do=user_prolog  o=$fname(admu_file)
  END_ADMINISTER_VALIDATIONS
END_COLLECT

    include_file $fname(commands) status=local_status
    delete_file $fname(commands) status=ignore_status
    EXIT main_block WHEN NOT local_status.normal

  EDIT_FILE file= $fname(admu_file) output=$null prolog=$null status= ignore_status
    locate_text 'Value:' status= ignore_status
    line_image= $trim($line_text)
    IF $substr(line_image,13,5) = '$NULL' THEN
      user_prolog= ''
    ELSE
      user_prolog= $substr(line_image,13,$strlen(line_image)-12)
    IFEND
  QUIT
  detach_file $fname(admu_file) status= ignore_status

    IF user_prolog = '' THEN

       user_prolog='$user.prolog'
COLLECT_TEXT o=$fname(commands)  until='END_COLLECT'  sm='?'
  ADMINISTER_VALIDATIONS
    CHANGE_USER  $name($job(user))
      change_user_prolog  $string(?user_prolog?)
    END_CHANGE_USER
  END_ADMINISTER_VALIDATIONS
END_COLLECT
    include_file $fname(commands) status=local_status
    delete_file $fname(commands) status=ignore_status
    EXIT main_block WHEN NOT local_status.normal

COLLECT_TEXT o=$fname(user_prolog//'.$eoi')  until='END_COLLECT'  sm='?'
" **MENU_VE USER'S MENU STARTUP CALL**
  SELECT_USER_MENU pc=true nl=?$string($value(natural_language))?  status=osv$status
" **END MENU_VE USER'S MENU VER 1.0**
END_COLLECT

    ELSEIF NOT $file($fname(user_prolog),permanent) THEN

COLLECT_TEXT o=$fname(user_prolog//'.$eoi') until='END_COLLECT' sm='?'
"**MENU_VE USER'S MENU STARTUP CALL**
  SELECT_USER_MENU pc=true nl=?$string($value(natural_language))?  status=osv$status
"**END MENU_VE USER'S MENU VER 1.0**
END_COLLECT

    IFEND

  BLOCKEND main_block

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND initialize_user_menu

*DECK DECK=EUM$SELECT_FAMILY_ADMIN_MENU EXPAND=TRUE
PROC select_family_admin_menu, selfam (
  natural_language, nl : name = us_english
  status               : var of status = $optional
  )

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"     The purpose of this command procedure is to activate the MENU/VE
"administrator menu.  For checkout purposes the variable EUV$MENU_VE_CATALOG can
"be declared XDCL'd outside this procedure to specify a different catalog then
"$SYSTEM.MENU_VE.
"
"   The first section attempts to upgrade the family administrator's environment
"from 1.2.2 to 1.2.3 and beyond.  At 1.2.3 the file $USER.FAM$DEFAULT_ATTRIBUTES
"is renamed $USER.EUF$ADMU_DEFAULT_ATTRIBUTES.
*IFEND

  IF $variable(euv$menu_ve_catalog declared) = 'NONLOCAL' THEN
    create_variable euv$menu_ve_catalog k=string s=xref
  ELSE
    create_variable euv$menu_ve_catalog k=string s=xdcl v='$SYSTEM.MENU_VE'
  IFEND

  create_variable (local_status, ignore_status) k=status
  create_variable natural_language k=string v=$string($value(natural_language))
  create_variable test_for_administrator k=string v='$local.'//$unique
  create_variable line_image k=string
  create_variable euv$terminal_hold_page k=boolean s=local v=off

select_block: ..
  BLOCK

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"  The following code is not needed in NOS/VE 1.3.1 and beyond. The user has to
"  create a new euf$default_attributes file for ADMINISTER_VALIDATIONS>
"
"   IF $file($user.fam$default_attributes permanent) AND
"         NOT $file($user.euf$admu_default_attributes permanent) THEN
"     copy_file i=$user.fam$default_attributes o=$user.euf$admu_default_attributes status=local_status
"     EXIT select_block WHEN NOT local_status.normal
"     delete_file $user.fam$default_attributes status=ignore_status
"   IFEND
*IFEND

    IF $job(mode) <> 'INTERACTIVE' THEN
      put_line ' -- ERROR -- Command can only be called interactively.' o=$response
      EXIT select_block
    ELSEIF (NOT $file($fname(euv$menu_ve_catalog//'.euf$admu_explain_'//natural_language), permanent)) OR ..
          (NOT $file($fname(euv$menu_ve_catalog//'.euf$admu_menu_'//natural_language) permanent)) THEN
      put_line ' Unable to locate the manuals for natural language '//natural_language//'.' o=$response
      EXIT select_block
    ELSEIF $terminal_model = '' THEN
      put_line ' -- ERROR -- No terminal model was specified.' o=$response
      EXIT select_block
    ELSE
    IFEND

*IF $variable(euv$proc_doc,declared)<>'UNKNOWN'
" Track original terminal attribute 'hold_page'. This is set to
" off in MENU_VE session
*IFEND

    attribute_file = $unique
    display_terminal_attribute output= $fname(attribute_file)
    EDIT_FILE file= $fname(attribute_file) output=$null prolog=$null status=ignore_status
      locate_text 'Hold_Page' status= ignore_status
      line_image = $line_text
    QUIT
    IF $scan_string('on', line_image) <> 0 THEN
      euv$terminal_hold_page = on
    IFEND
    detach_file $fname(attribute_file) status= ignore_status

    copy_file input=$fname(euv$menu_ve_catalog//'.euf$admu_menu_'//natural_language) ..
          output=$local.euf$admu_menu status=local_status
    EXIT select_block WHEN NOT local_status.normal

    copy_file input=$fname(euv$menu_ve_catalog//'.euf$admu_explain_'//natural_language) ..
          output=$local.euf$admu_explain status=local_status
    EXIT select_block WHEN NOT local_status.normal

    PUSH command_list

    create_command_list_entry entry=$fname(euv$menu_ve_catalog//'.euf$admu_menu_library') status=local_status
    IF (NOT local_status.normal) AND ($condition(local_status.condition) = 'CLE$DUPLICATE_COMMAND_LIST_ENT')..
           THEN
      local_status.normal = true
    IFEND
    EXIT select_block WHEN NOT local_status.normal

    set_terminal_attribute hp=off
    explain m=$local.euf$admu_menu status=local_status
    set_terminal_attribute hp=euv$terminal_hold_page

  BLOCKEND select_block

  detach_file $local.euf$admu_menu status=ignore_status
  detach_file $local.euf$admu_explain status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND select_family_admin_menu
*DECK DECK=EUM$SELECT_OPERATOR_MENU EXPAND=TRUE
PROCEDURE select_operator_menu, select_operators_menu, selom (
  execute_option, eo: key
      execute, extract, generate
    keyend = execute
  status)

"-----------------------------------------------------------------------------"
" Access procedure for the NOS/VE Operators Menu System.  The menu system     "
" should only be accessed from within the SYSTEM_OPERATOR_UTILITY (SOU).      "
"                                                                             "
" To modify the menu system, use the eo=extract option to get the SCL source  "
" from the object library.  Use the eo=generate option to create a new object "
" library from the modified SCL procedures.  The default eo=execute option    "
" will access the NOS/VE Operators Menu System.                               "
"                                                                             "
" Copyright Control Data Systems Inc. 1992                                    "
"-----------------------------------------------------------------------------"

  VAR
    euf$operator_menu_library : (PUSH) file
  VAREND

  IF NOT $variable(euf$operator_menu_library, initialized) THEN
    euf$operator_menu_library = $system.menu_ve.euf$operator_menu_library
  IFEND

  IF execute_option = execute THEN

    PUSH command_list
    create_command_list_entry entry=euf$operator_menu_library
    op_main_menu
    POP command_list

  ELSEIF execute_option = extract THEN

    CREATE_OBJECT_LIBRARY
      add_module library=euf$operator_menu_library
      generate_library library=$local.op_menu_source.$boi format=scl_proc
    QUIT
    put_line ' Extracted operator menu source written to file $LOCAL.OP_MENU_SOURCE'

  ELSEIF execute_option = generate THEN

    CREATE_OBJECT_LIBRARY
      add_module library=$local.op_menu_source
      generate_library euf$operator_menu_library//$next
    QUIT
    put_line ' Operator menu object library generated on file '//euf$operator_menu_library

  IFEND

PROCEND select_operator_menu
*DECK DECK=EUM$SELECT_USER_MENU EXPAND=TRUE
PROC select_user_menu, selum, menu (
  prolog_call, pc      : boolean = false
  natural_language, nl : name = us_english
  status               : var of status = $optional
  )


*IF $variable(euv$proc_doc,declared)<>'UNKNOWN'
"     The purpose of this command procedure is to activate the MENU/VE user
"menu.  For checkout purposes the variable EUV$MENU_VE_CATALOG can be declared
"XDCL'd outside this procedure to specify a different catalog than $SYSTEM.MENU_VE.
*IFEND


  EXIT_PROC WHEN $job(mode) <> 'INTERACTIVE'


  IF $variable(euv$menu_ve_catalog declared) = 'NONLOCAL' THEN
    create_variable euv$menu_ve_catalog k=string s=xref
  ELSE
    create_variable euv$menu_ve_catalog k=string s=xdcl v='$SYSTEM.MENU_VE'
  IFEND

  IF $variable(euv$initial_call,declared)='NONLOCAL' THEN
    create_variable euv$initial_call k=boolean s=xref
  ELSE
    create_variable euv$initial_call k=boolean s=xdcl v=FALSE
  IFEND

  IF $variable(euv$terminal_class,declared)='NONLOCAL' THEN
    create_variable euv$terminal_class k=string s=xref
  ELSE
    create_variable euv$terminal_class k=string s=xdcl v='TTY'
  IFEND

  IF $variable(euv$terminal_model,declared)='NONLOCAL' THEN
    create_variable euv$terminal_model k=string s=xref
  ELSE
    create_variable euv$terminal_model k=string s=xdcl v='NONE'
  IFEND

  IF $variable(euv$check_mail,declared)='NONLOCAL' THEN
    create_variable euv$check_mail k=boolean s=xref
  ELSE
    create_variable euv$check_mail k=boolean s=xdcl v=true
  IFEND

  IF $variable(euv$main_menu_display,declared)='NONLOCAL' THEN
    create_variable euv$main_menu_display k=boolean s=xref
  ELSE
    create_variable euv$main_menu_display k=boolean s=xdcl v=true
  IFEND

  IF $variable(euv$terminal_page_width,declared)='NONLOCAL' THEN
    create_variable euv$terminal_page_width k=integer s=xref
  ELSE
    create_variable euv$terminal_page_width k=integer s=xdcl v=80
  IFEND

  IF $variable(euv$terminal_page_length,declared)='NONLOCAL' THEN
    create_variable euv$terminal_page_length k=integer s=xref
  ELSE
    create_variable euv$terminal_page_length k=integer s=xdcl v=24
  IFEND

  IF $variable(euv$terminal_echo,declared)='NONLOCAL' THEN
    create_variable euv$terminal_echo k=boolean s=xref
  ELSE
    create_variable euv$terminal_echo k=boolean s=xdcl v=off
  IFEND

  IF $variable(euv$terminal_parity,declared)='NONLOCAL' THEN
    create_variable euv$terminal_parity k=string s=xref
  ELSE
    create_variable euv$terminal_parity k=string s=xdcl v='EVEN'
  IFEND

  IF $variable(euv$terminal_cfc,declared)='NONLOCAL' THEN
    create_variable euv$terminal_cfc k=boolean s=xref
  ELSE
    create_variable euv$terminal_cfc k=boolean s=xdcl v=on
  IFEND

  IF $variable(euv$terminal_path,declared)='NONLOCAL' THEN
    create_variable euv$terminal_path k=string s=xref
  ELSE
    create_variable euv$terminal_path k=string s=xdcl v=''
  IFEND

  IF $variable(euv$working_catalog,declared)='NONLOCAL' THEN
    create_variable euv$working_catalog k=string s=xref
  ELSE
    create_variable euv$working_catalog k=string s=xdcl v='$USER'
  IFEND

  IF $variable(euv$menu_command,declared)='NONLOCAL' THEN
    create_variable euv$menu_command k=string s=xref
  ELSE
    create_variable euv$menu_command k=string s=xdcl d=10
  IFEND

  IF $variable(euv$menu_text,declared)='NONLOCAL' THEN
    create_variable euv$menu_text k=string s=xref
  ELSE
    create_variable euv$menu_text k=string s=xdcl d=10
  IFEND

  create_variable euv$ignore_stat          k=status
  create_variable euv$local_stat           k=status
  create_variable euv$terminal_model_login k=string s=xdcl v='NONE'
  create_variable line_image               k=string
  create_variable euv$int_style            k=string s=xdcl v='line'
  create_variable natural_language         k=string v=$string($value(natural_language))
  create_variable euv$terminal_hold_page   k=boolean s=local v=off
  create_variable euv$initial_check_mail   k=boolean s=xdcl  v=on
  create_variable euv$main_quit            k=boolean s=xdcl  v=false

user_block: ..
  BLOCK

    IF (NOT $file($fname(euv$menu_ve_catalog//'.euf$user_explain_'//natural_language), permanent)) OR ..
          (NOT $file($fname(euv$menu_ve_catalog//'.euf$user_menu_'//natural_language) permanent)) THEN
      put_line ' Unable to locate the manuals for natural language '//natural_language//'.' o=$response
      EXIT user_block
    IFEND

    euv$terminal_model_login = $translate(lower_to_upper, $terminal_model)
    IF euv$terminal_model_login = '' THEN
      euv$terminal_model_login = 'NONE'
    IFEND

    IF (euv$terminal_model <> 'NONE') AND ..
          ((euv$terminal_model_login = euv$terminal_model) OR (euv$terminal_model_login = 'NONE')) THEN
      set_terminal_attribute tm=$name(euv$terminal_model) pw=euv$terminal_page_width ..
            pl=euv$terminal_page_length e=euv$terminal_echo p=$name(euv$terminal_parity) ..
            cfc=euv$terminal_cfc status=euv$local_stat
      EXIT user_block WHEN NOT euv$local_stat.normal
      IF ($job(c170_os_type) = 'NOS') OR ($job(c170_os_type) = 'NOS/BE') THEN
        set_terminal_attribute tc=$name(euv$terminal_class) status=euv$local_stat
      IFEND
      EXIT user_block WHEN NOT euv$local_stat.normal
    IFEND

    IF euv$terminal_path <> '' THEN
      create_variable  pa_file  k=string
      pa_file= $unique
      display_program_attribute  output= $fname(pa_file)
      EDIT_FILE file= $fname(pa_file) output=$null prolog=$null status=euv$local_stat
        locate_text  $translate(UTL,euv$terminal_path) status=euv$local_stat
        IF NOT euv$local_stat.normal  THEN
          setpa add_library= $fname(euv$terminal_path) status=euv$ignore_stat
        IFEND
      QUIT
    IFEND

    set_working_catalog $fname(euv$working_catalog) status=euv$local_stat
    IF NOT euv$local_stat.normal THEN
      put_line l=('1  The working catalog you have selected, '//euv$working_catalog, ..
            '    is not known to the system.  Your working catalog has been set to $USER.') o=$output
      set_working_catalog $user status=euv$local_stat
      EXIT user_block WHEN NOT euv$local_stat.normal
    IFEND

    IF $value(prolog_call) = true THEN
      EXIT_PROC WHEN euv$main_menu_display = false
      accept_line v=line_image i=input ..
                  p='Press RETURN when ready to go into User''s Menu or QUIT to exit to NOS/VE./'
      IF $translate(lower_to_upper, $substr(line_image, 1, 4)) = 'QUIT' THEN
        EXIT user_block
      IFEND
    IFEND

    IF $interaction_style(screen) THEN
      euv$int_style = 'screen'
    ELSEIF $interaction_style(desktop) THEN
      euv$int_style = 'desktop'
    IFEND

*IF $variable(euv$proc_doc,declared)<>'UNKNOWN'
" Track original terminal attribute 'hold_page'. This is set to
" off in MENU_VE session
*IFEND

    attr_file= $unique
    display_terminal_attribute  output= $fname(attr_file)
    EDIT_FILE file= $fname(attr_file) output=$null prolog=$null status=euv$ignore_stat
      locate_text 'Hold_Page' status= euv$ignore_stat
      line_image= $line_text
    QUIT
    IF $scan_string('on',line_image) <> 0  THEN
       euv$terminal_hold_page= on
    IFEND
    detach_file  $fname(attr_file) status= euv$ignore_stat


    detach_file $local.euf$user_explain status=euv$ignore_stat
    detach_file $local.euf$user_menu status=euv$ignore_stat

    copy_file i=$fname(euv$menu_ve_catalog//'.euf$user_explain_'//natural_language) o=$local.euf$user_explain ..
          status=euv$local_stat
    EXIT user_block WHEN NOT euv$local_stat.normal
    copy_file i=$fname(euv$menu_ve_catalog//'.euf$user_menu_'//natural_language) o=$local.euf$user_menu ..
          status=euv$local_stat
    EXIT user_block WHEN NOT euv$local_stat.normal

    change_interaction_style style=line
    set_terminal_attribute  hp=off

    WHEN  INTERRUPT  DO
      continue
    WHENEND

    quit: WHILE  NOT  euv$main_quit  DO
      explain m=$local.euf$user_menu status=euv$local_stat
    WHILEND quit

    change_interaction_style style=$name(euv$int_style)
    set_terminal_attribute  hp=euv$terminal_hold_page

  BLOCKEND user_block

  IF NOT euv$local_stat.normal THEN
    put_line (' The following error occured while in the NOS/VE User''s Menu:', ' '//$strrep(euv$local_stat)) ..
          o=$response
    accept_line v=line_image i=input p=' Press RETURN when ready to continue./'
  IFEND

  put_line l=('1 You have exited the NOS/VE Menus and may now enter NOS/VE commands.', ..
        '  To re-display the NOS/VE Main Menu you must enter the NOS/VE command', ..
        '0    SELECT_USER_MENU or SELUM', ' ') o=$output

  detach_file $local.euf$user_explain status=euv$ignore_stat
  detach_file $local.euf$user_menu status=euv$ignore_stat

PROCEND select_user_menu
*DECK DECK=EUP$GET_FILE_SELECTION EXPAND=FALSE
  PROCEDURE [XREF] eup$get_file_selection
    (    file: fst$file_reference;
         title_p: ^string ( * );
         box_x_position: cst$x_position;
         box_y_position: cst$y_position;
         actions: ^clt$data_value;
         help_module: ^clt$data_value;
     VAR path_container: string (fsc$max_path_size);
     VAR selected_file: ^fst$file_reference;
     VAR selected_action: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc cst$x_position
*copyc cst$y_position
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=EUP$GET_ITEM_SELECTIONS EXPAND=FALSE
  PROCEDURE [XREF] eup$get_item_selections
    (    items: ^clt$data_value;
         preselected_items: ^clt$data_value;
         multiple_selections: boolean;
         actions: ^clt$data_value;
         title: ^clt$string_value;
         box_x_position: cst$x_position;
         box_y_position: cst$y_position;
         width: cst$x_position;
         help_module: ^clt$data_value;
     VAR work_area: ^clt$work_area;
     VAR selected_action: ^clt$data_value;
     VAR selected_items: ^clt$data_value;
     VAR selected_item_indicies: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$work_area
*copyc cst$x_position
*copyc cst$y_position
*copyc ost$status
?? POP ??
*DECK DECK=FASLAVE EXPAND=TRUE
"  The purpose of this deck is to fool compile_source into compile
"all the fmslave decks and bampl decks.  FASLAVE deck is a dummy deck
"that fools compile_source into running create_faslave processor.  When
"create_faslave is called, key decks are expanded off the FMA
"source_library and compile onto osf$nverels.
"  The reason for having FASLAVE on the OS source library is so that
"all of the FMA decks will be recompiled when ever a new level of nos is recieved.
*DECK DECK=FDC$BASIC_CAPABILITY EXPAND=FALSE

 CONST
    fdc$basic_capability = 3;

*DECK DECK=FDC$COBOL_DIGITS_MAXIMUM EXPAND=FALSE

CONST
   fdc$cobol_digits_maximum = 36;


*DECK DECK=FDC$COBOL_ITEM_SIZE_MAXIMUM EXPAND=FALSE
CONST
  fdc$cobol_item_size_maximum = 1048575;
*DECK DECK=FDC$COBOL_OPERATIONS_MAX EXPAND=FALSE
{ Maximum COBOL operations is computed as follows:
{ one operation per PICTURE character,
{ plus one to start floating replacement
{  plus one to stop floating replacement.

CONST
   fdc$cobol_operations_max = fdc$maximum_picture_length + 2;

*copyc fdc$maximum_picture_length
*DECK DECK=FDC$DECIMAL_CURRENCY_SYMBOL EXPAND=FALSE

  CONST

    fdc$decimal_currency_symbol = '.';

*DECK DECK=FDC$DOLLAR_CURRENCY_SYMBOL EXPAND=FALSE

 CONST

    fdc$dollar_currency_symbol = '$';
*DECK DECK=FDC$HIDDEN_EDITING_CAPABILITY EXPAND=FALSE

 CONST

{ This version added hidden editing for variable text boxes.

    fdc$hidden_editing_capability = 8;
*DECK DECK=FDC$IM_SMART_CAPABILITY EXPAND=FALSE

 CONST

{ This version added support for IM/SMART and COBOL PICTURE clauses.

    fdc$im_smart_capability = 5;
*DECK DECK=FDC$INTEGER_LENGTH EXPAND=FALSE
 CONST
    fdc$integer_length = 8;
*DECK DECK=FDC$MAXIMUM_COMMENTS EXPAND=FALSE
 CONST
    fdc$maximum_comments = 10000;
*DECK DECK=FDC$MAXIMUM_COMMENT_LENGTH EXPAND=FALSE
 CONST
    fdc$maximum_comment_length = fdc$maximum_text_length;

*copyc fdc$maximum_text_length
*DECK DECK=FDC$MAXIMUM_ERRORS EXPAND=FALSE
 CONST
    fdc$maximum_errors = 10000;
*DECK DECK=FDC$MAXIMUM_ERROR_LENGTH EXPAND=FALSE
 CONST
    fdc$maximum_error_length = fdc$maximum_text_length;

*copyc fdc$maximum_text_length
*DECK DECK=FDC$MAXIMUM_EVENTS EXPAND=FALSE
 CONST
    fdc$maximum_events = 1000;
*DECK DECK=FDC$MAXIMUM_FORM_ATTRIBUTES EXPAND=FALSE
 CONST
    fdc$maximum_form_attributes = 100;
*DECK DECK=FDC$MAXIMUM_FORM_IDENTIFIER EXPAND=FALSE
 CONST
    fdc$maximum_form_identifier = 1000;
*DECK DECK=FDC$MAXIMUM_HELP_LENGTH EXPAND=FALSE
 CONST
    fdc$maximum_help_length = fdc$maximum_text_length;

*copyc fdc$maximum_text_length
*DECK DECK=FDC$MAXIMUM_OBJECTS EXPAND=FALSE
 CONST
    fdc$maximum_objects = 10000;
*DECK DECK=FDC$MAXIMUM_OBJECT_ATTRIBUTES EXPAND=FALSE
 CONST
    fdc$maximum_object_attributes = 200;
*DECK DECK=FDC$MAXIMUM_OBJECT_DISPLAYS EXPAND=FALSE
 CONST
    fdc$maximum_object_displays = 100;
*DECK DECK=FDC$MAXIMUM_OCCURRENCE EXPAND=FALSE
 CONST
    fdc$maximum_occurrence = 1000;
*DECK DECK=FDC$MAXIMUM_PICTURE_LENGTH EXPAND=FALSE

  CONST
    fdc$maximum_picture_length = 30;

*DECK DECK=FDC$MAXIMUM_PUSHES EXPAND=FALSE
 CONST
    fdc$maximum_pushes = 1000;
*DECK DECK=FDC$MAXIMUM_READ_FORMS_INDEX EXPAND=FALSE
  CONST
    fdc$maximum_read_forms_index = 4096;
*DECK DECK=FDC$MAXIMUM_RECORD_LENGTH EXPAND=FALSE
 CONST
    fdc$maximum_record_length = osc$max_segment_length;

*copyc osd$virtual_address
*DECK DECK=FDC$MAXIMUM_SCREEN_CHANGES EXPAND=FALSE
 CONST
    fdc$maximum_screen_changes = 400;
*DECK DECK=FDC$MAXIMUM_TABLES EXPAND=FALSE
 CONST
    fdc$maximum_tables = 10000;
*DECK DECK=FDC$MAXIMUM_TABLE_VARIABLES EXPAND=FALSE
 CONST
    fdc$maximum_table_variables = 10000;
*DECK DECK=FDC$MAXIMUM_TEXT_LENGTH EXPAND=FALSE
 CONST
    fdc$maximum_text_length = cyc$max_string_size;

*copyc cyc$max_string_size
*DECK DECK=FDC$MAXIMUM_VALID_RANGES EXPAND=FALSE
 CONST
    fdc$maximum_valid_ranges = 10000;
*DECK DECK=FDC$MAXIMUM_VALID_STRING EXPAND=FALSE
 CONST
    fdc$maximum_valid_string = fdc$maximum_text_length;

*copyc fdc$maximum_text_length
*DECK DECK=FDC$MAXIMUM_VALID_STRINGS EXPAND=FALSE
 CONST
    fdc$maximum_valid_strings = 10000;
*DECK DECK=FDC$MAXIMUM_VARIABLES EXPAND=FALSE
 CONST
    fdc$maximum_variables = fdc$maximum_objects;
*copyc fdc$maximum_objects
*DECK DECK=FDC$MAXIMUM_VARIABLE_LENGTH EXPAND=FALSE
 CONST
    fdc$maximum_variable_length = fdc$maximum_record_length;

*copyc fdc$maximum_record_length

*DECK DECK=FDC$MAXIMUM_X_POSITION EXPAND=FALSE
 CONST
    fdc$maximum_x_position = 256;
*DECK DECK=FDC$MAXIMUM_Y_POSITION EXPAND=FALSE
 CONST
    fdc$maximum_y_position = 256;
*DECK DECK=FDC$MAX_CHARACTER_POSITION EXPAND=FALSE
 CONST
    fdc$max_character_position = fdc$maximum_record_length;

*copyc fdc$maximum_record_length
*DECK DECK=FDC$MESSAGE_FORM_CAPABILITY EXPAND=FALSE

 CONST

{ This version added support for user defined message forms
{ for help and error messages.

    fdc$message_form_capability = 6;

*DECK DECK=FDC$MESSAGE_FORM_NAME EXPAND=FALSE

  CONST
    fdc$message_form_name = 'FDM$MESSAGE_FORM               ';

*DECK DECK=FDC$MESSAGE_VARIABLE_LENGTH EXPAND=FALSE

  CONST
    fdc$message_variable_length = 256;

*DECK DECK=FDC$MESSAGE_VARIABLE_NAME EXPAND=FALSE

  CONST
    fdc$message_variable_name = 'MESSAGE';

*DECK DECK=FDC$MESSAGE_VISIBLE_LENGTH EXPAND=FALSE
  CONST
    fdc$message_visible_length = 74;
*DECK DECK=FDC$NEW_LINE_CHARACTER EXPAND=FALSE

  CONST
    fdc$new_line_character = $CHAR (31); {Unit separator}
*DECK DECK=FDC$POUND_CURRENCY_SYMBOL EXPAND=FALSE

 CONST

    fdc$pound_currency_symbol = '#';
*DECK DECK=FDC$REAL_LENGTH EXPAND=FALSE
 CONST
    fdc$real_length = 8;
*DECK DECK=FDC$REASSIGN_EVENT_CAPABILITY EXPAND=FALSE

 CONST

{ This version added support for EMAIL. Event triggers are not assigned.

    fdc$reassign_event_capability = 7;
*DECK DECK=FDC$SCREEN_FORMATTING_VERSION EXPAND=FALSE
 CONST
    fdc$screen_formatting_version = fdc$hidden_editing_capability;

*copyc fdc$hidden_editing_capability
*DECK DECK=FDC$SCREEN_GENERATOR_VERSION EXPAND=FALSE
 CONST
    fdc$screen_generator_version = 'SCREEN FORMATTING V5.0';
*DECK DECK=FDC$SYSTEM_COORDINATE_SYSTEM EXPAND=FALSE
 CONST
    fdc$system_coordinate_system = fdc$character_system;

*copyc fdt$coordinate_system
*DECK DECK=FDC$SYSTEM_CURRENCY_SIGN EXPAND=FALSE
 CONST
    fdc$system_currency_sign = '$';
*DECK DECK=FDC$SYSTEM_DECIMAL_POINT EXPAND=FALSE
 CONST
    fdc$system_decimal_point = '.';
*DECK DECK=FDC$SYSTEM_DESIGN_TABLE_NAME EXPAND=FALSE
 CONST
    fdc$system_design_table_name = 'DTBL';
*DECK DECK=FDC$SYSTEM_DESIGN_VARIABLE_NAME EXPAND=FALSE
 CONST
    fdc$system_design_variable_name = 'DVAR';
*DECK DECK=FDC$SYSTEM_DISPLAY_NAME EXPAND=FALSE
 CONST
    fdc$system_display_name = 'HIGHLIGHT';
*DECK DECK=FDC$SYSTEM_ERROR_MESSAGE EXPAND=FALSE
 CONST
    fdc$system_error_message = 'Please correct.';
*DECK DECK=FDC$SYSTEM_EXPONENT_CHARACTER EXPAND=FALSE
 CONST
    fdc$system_exponent_character = 'E';
*DECK DECK=FDC$SYSTEM_FORM_PROCESSOR EXPAND=FALSE
 CONST
    fdc$system_form_processor = fdc$cybil_processor;

*copyc fdt$form_processor
*DECK DECK=FDC$SYSTEM_HELP_MESSAGE EXPAND=FALSE
 CONST
    fdc$system_help_message = 'Please enter.';
*DECK DECK=FDC$SYSTEM_INPUT_FORMAT EXPAND=FALSE
 CONST
    fdc$system_input_format = fdc$character_input_format;

*copyc fdt$input_format
*DECK DECK=FDC$SYSTEM_IO_MODE EXPAND=FALSE
 CONST
    fdc$system_io_mode = fdc$terminal_input_output;

*copyc fdt$io_mode
*DECK DECK=FDC$SYSTEM_OCCURRENCE EXPAND=FALSE
 CONST
    fdc$system_occurrence = 1;
*DECK DECK=FDC$SYSTEM_OUTPUT_FORMAT EXPAND=FALSE
 CONST
    fdc$system_output_format = fdc$character_output_format;

*copyc fdt$output_format
*DECK DECK=FDC$SYSTEM_PROGRAM_DATA_TYPE EXPAND=FALSE
 CONST
    fdc$system_program_data_type = fdc$program_character_type;

*copyc fdt$program_data_type
*DECK DECK=FDC$SYSTEM_RECORD_TYPE EXPAND=FALSE
 CONST
    fdc$system_record_type = fdc$program_data_type_record;

*copyc fdt$record_type
*DECK DECK=FDC$SYSTEM_THOUSANDS_SEPARATOR EXPAND=FALSE
 CONST
    fdc$system_thousands_separator = ',';
*DECK DECK=FDC$SYSTEM_UNKNOWN_ENTRY EXPAND=FALSE
 CONST
    fdc$system_unknown_entry = '?';
*DECK DECK=FDC$SYSTEM_USER_ENTRY EXPAND=FALSE
 CONST
    fdc$system_user_entry = fdc$must_enter;

*copyc fdt$terminal_user_entry
*DECK DECK=FDC$THOUSANDS_CURRENCY_SYMBOL EXPAND=FALSE

 CONST

    fdc$thousands_currency_symbol = ',';

*DECK DECK=FDC$VALIDATION_CAPABILITY EXPAND=FALSE

 CONST

{ This version added data validation.

    fdc$validation_capability = 4;
*DECK DECK=FDE$COBOL_STATUS EXPAND=FALSE
       01 FDE-COBOL-STATUS USAGE COMP PIC S9(18) SYNC LEFT.
           88 FDE-REQUEST-SUCCESSFUL VALUE 0.
           88 FDE-TERMINAL-DISCONNECTED VALUE 1.
           88 FDE-NO-INPUT-REQUEST VALUE 2.
           88 FDE-CURSOR-NOT-IN-VARIABLE VALUE 3.
           88 FDE-MORE-ERRORS-EXIST VALUE 4.
           88 FDE-UNKNOWN-FORM-NAME VALUE 5.
           88 FDE-FORM-COMPILATION-ERRORS VALUE 6.
           88 FDE-NO-SPACE-AVAILABLE VALUE 7.
           88 FDE-UNSUPPORTED-TERMINAL VALUE 8.
           88 FDE-INVALID-FORM-IDENTIFIER VALUE 9.
           88 FDE-INVALID-USER-ENTRY VALUE 10.
           88 FDE-UNKNOWN-VARIABLE-NAME VALUE 11.
           88 FDE-TOO-MANY-INTEGERS VALUE 12.
           88 FDE-OBJECT-NAME-EXISTS VALUE 13.
           88 FDE-WORK-INVALID VALUE 14.
           88 FDE-INVALID-X-FORM-POSITION VALUE 15.
           88 FDE-INVALID-Y-FORM-POSIITON VALUE 16.
           88 FDE-INVALID-WIDTH VALUE 17.
           88 FDE-INVALID-HEIGHT VALUE 18.
           88 FDE-INVALID-MESSAGE-FORM-NAME VALUE 19.
           88 FDE-INVALID-OCCURRENCE VALUE 20.
           88 FDE-INVALID-CHARACTER-POSITION VALUE 21.
           88 FDE-INVALID-MODE VALUE 22.
           88 FDE-INVALID-STATE VALUE 23.
           88 FDE-INVALID-VARIABLE-VALUE VALUE 24.
           88 FDE-INVALID-OBJECT-NAME VALUE 25.
           88 FDE-INVALID-FORM-NAME VALUE 26.
           88 FDE-FORM-CLOSED VALUE 27.
           88 FDE-TOO-MANY-ATTRIBUTES VALUE 28.
           88 FDE-INVALID-ATTRIBUTE-NAME VALUE 29.
           88 FDE-TOO-MANY-SCREEN-OCCURRENCE VALUE 30.
           88 FDE-NO-FORM-DEFINITION VALUE 31.
           88 FDE-TOO-MANY-STORED-OCCURRENCE VALUE 32.
           88 FDE-UNKNOWN-OBJECT-NAME VALUE 33.
           88 FDE-NO-DEFINE-OBJECT-NAME VALUE 34.
           88 FDE-INVALID-NAME VALUE 35.
           88 FDE-SYSTEM-ERROR VALUE 36.
           88 FDE-INVALID-TABLE-NAME VALUE 37.
           88 FDE-INVALID-VARIABLE-NAME VALUE 38.
           88 FDE-FORM-PUSHED VALUE 39.
           88 FDE-UNKNOWN-TABLE-NAME VALUE 40.
           88 FDE-NO-VARIABLE-DEFINED VALUE 41.
           88 FDE-NO-FORMS-TO-POP VALUE 42.
           88 FDE-ONLY-CHARACTER-DATA VALUE 43.
           88 FDE-ONLY-NONCHARACTER-DATA VALUE 44.
           88 FDE-FORM-DEFINITION-ERRORS VALUE 45.
           88 FDE-NO-FORMS-TO-PUSH VALUE 46.
           88 FDE-INVALID-PROGRAM-VALUES VALUE 47.
           88 FDE-INPUT-HAS-UNKNOWN-VALUE VALUE 48.
           88 FDE-INVALID-INPUT-VALUES VALUE 49.
           88 FDE-NOT-AN-INPUT-VARIABLE VALUE 50.
           88 FDE-CURSOR-NOT-IN-FORM VALUE 51.
           88 FDE-FORM-HAS-NO-VARIABLES VALUE 52.
           88 FDE-NO-FORMS-TO-SHOW VALUE 53.
           88 FDE-FORM-NOT-SCHEDULED VALUE 54.
           88 FDE-INVALID-EVENT-NAME VALUE 55.
           88 FDE-INVALID-X-POSIITON VALUE 56.
           88 FDE-INVALID-Y-POSITION VALUE 57.
           88 FDE-UNKNOWN-EVENT-NAME VALUE 58.
           88 FDE-INVALID-DECK-NAME VALUE 59.
           88 FDE-INVALID-RECORD-NAME VALUE 60.
           88 FDE-OBJECT-EXISTS VALUE 61.
           88 FDE-TABLE-NAME-EXISTS VALUE 62.
           88 FDE-OBJECT-OVERLAYS VALUE 63.
           88 FDE-TOO-MANY-REALS VALUE 64.
           88 FDE-TOO-MANY-STRINGS VALUE 65.
           88 FDE-NO-OBJECT-AT-POSITION VALUE 66.
           88 FDE-ARRAY-TOO-SMALL VALUE 67.
           88 FDE-STRING-TOO-SMALL VALUE 68.
           88 FDE-VARAIBLE-NAME-EXISTS VALUE 69.
           88 FDE-FORM-ALREADY-ADDED VALUE 70.
           88 FDE-INVALID-EVENT-ACTIVE VALUE 72.
           88 FDE-CANNOT-UPDATE-OPENED-FORM VALUE 73.
           88 FDE-HELP-FORM-EXISTS VALUE 74.
           88 FDE-ERROR-FORM-EXISTS VALUE 75.
           88 FDE-ERROR-MESSAGE-EXISTS VALUE 76.
           88 FDE-HELP-MESSAGE-EXISTS VALUE 77.
           88 FDE-INVALID-DISPLAY-NAME VALUE 78.
           88 FDE-INVALID-REAL-RANGE VALUE 79.
           88 FDE-INVALID-INTEGER-RANGE VALUE 80.
           88 FDE-UNKNOWN-INTEGER-RANGE VALUE 81.
           88 FDE-UNKNOWN-REAL-RANGE VALUE 82.
           88 FDE-UNKNOWN-VALID-STRING VALUE 83.
           88 FDE-DISPLAY-NAME-EXISTS VALUE 84.
           88 FDE-EVENT-NAME-EXISTS VALUE 85.
           88 FDE-UNKNOWN-DISPLAY-NAME VALUE 86.
           88 FDE-TOO-MANY-FORM-NAMES VALUE 87.
           88 FDE-TOO-MANY-FORM-OBJECTS VALUE      88.
           88 FDE-NO-TEXT-AT-POSITION VALUE 89.
           88 FDE-NO-TEXT-FOR-OBJECT VALUE 90.
           88 FDE-UNKNOWN-OCCURRENCE VALUE 91.
           88 FDE-NO-STRING VALUE 92.
           88 FDE-RANGE-OVERLAP VALUE 93.
           88 FDE-NO-COMMENTS-TO-DELETE VALUE 94.
           88 FDE-OBJECT-OCCURRENCE-EXISTS VALUE 95.
           88 FDE-NO-STRING-SPECIFIED VALUE 96.
           88 FDE-VALID-STRING-EXISTS VALUE 97.
           88 FDE-INVALID-OBJECT-CHANGE VALUE 98.
           88 FDE-INVALID-ADDRESS VALUE 99.
           88 FDE-TERMINAL-NOT-IDENTIFIED VALUE 100.
           88 FDE-INVALID-FORM-LANGUAGE VALUE 101.
           88 FDE-INVALID-FORM-AREA-KEY VALUE 102.
           88 FDE-FORM-NAME-REQUIRED VALUE 103.
           88 FDE-NO-FORMS-TO-READ VALUE 104.
           88 FDE-INVALID-HELP-FORM-NAME VALUE 105.
           88 FDE-INVALID-ERROR-FORM-NAME VALUE 106.
           88 FDE-CREATE-MARK-INVALID VALUE 107.
           88 FDE-DELETE-MARK-INVALID VALUE 108.
           88 FDE-NO-MARK-DEFINED VALUE 109.
           88 FDE-AREA-CUTS-OBJECT VALUE 110.
           88 FDE-COPY-OUTSIDE-FORM VALUE 111.
           88 FDE-MOVE-OUTSIDE-FORM VALUE 112.
           88 FDE-INVALID-FORM-ATTRIBUTE VALUE 113.
           88 FDE-INVALID-RECORD-ATTRIBUTE VALUE 114.
           88 FDE-INVALID-OBJECT-KEY VALUE 115.
           88 FDE-INVALID-OBJECT-ATTRIBUTE VALUE 116.
           88 FDE-INVALID-TABLE-ATTRIBUTE VALUE 117.
           88 FDE-PROGRAM-DATA-TYPE VALUE 118.
           88 FDE-INVALID-OUTPUT-FORMAT-KEY VALUE 119.
           88 FDE-INVALID-ERROR-KEY VALUE 120.
           88 FDE-INVALID-VARIABLE-ATTRIBUTE VALUE 121.
           88 FDE-INVALID-HELP-KEY VALUE 123.
           88 FDE-FEATURE-NOT-IMPLEMENTED VALUE 124.
           88 FDE-CANNOT-CHANGE-FORM VALUE 125.
           88 FDE-INVALID-RECORD-TYPE VALUE 126.
           88 FDE-OBJECT-NOT-IN-FORM VALUE 127.
           88 FDE-INVALID-FORM-PROCESSOR VALUE 128.
           88 FDE-INVALID-X-INCREMENT VALUE 129.
           88 FDE-INVALID-Y-INCREMENT VALUE 130.
           88 FDE-FORM-TOO-LARGE-FOR-SCREEN VALUE 131.
           88 FDE-INVALID-TEXT-PROCESSING VALUE 132.
           88 FDE-INVALID-DESIGN-FORM VALUE 133.
           88 FDE-NO-OBJECT-VAR-DEFINED VALUE 134.
           88 FDE-EVENT-NOT-ASSIGNED VALUE 135.
           88 FDE-FORM-NOT-ENDED VALUE 136.
           88 FDE-INVALID-EVENT-FORM-NAME VALUE 137.
           88 FDE-INVALID-EVENT-FORM-KEY VALUE 138.
           88 FDE-FORM-ALREADY-OPEN VALUE 139.
           88 FDE-INVALID-EVENT-LABLE VALUE 140.
           88 FDE-FORM-NEEDS-CONVERSTION VALUE 141.
           88 FDE-NO-EVENTS-ACTIVE VALUE 142.
           88 FDE-DELETE-OUTSIDE-FORM VALUE 143.
           88 FDE-MARK-OUTSIDE-FORM VALUE 144.
           88 FDE-BAD-DATA-VALUE VALUE 145.
           88 FDE-RECORD-DEFN-NOT-WRITTEN VALUE 146.
           88 FDE-WRONG-VARIABLE-TYPE VALUE 147.
           88 FDE-INVALID-VARIABLE-LENGTH VALUE 148.
           88 FDE-EVENT-TRIGGER-EXISTS VALUE 149.
           88 FDE-FORM-ALREADY-COMBINED VALUE 150.
           88 FDE-INVALID-TABLE-SIZE VALUE 151.
           88 FDE-FORM-NOT-ADDED VALUE 152.
           88 FDE-INVALID-INPUT-FORMAT-KEY VALUE 153.
           88 FDE-SYSTEM-ERROR-MESSAGE VALUE 154.
           88 FDE-SYSTEM-HELP-MESSAGE VALUE 155.
           88 FDE-SYSTEM-BAD-KEY-MESSAGE VALUE 156.
           88 FDE-WIDTH-AND-HEIGHT-REQUIRED VALUE 157.
           88 FDE-NO-VARIABLE-DEFINITION VALUE 158.
           88 FDE-NO-TABLE-VARIABLE VALUE 159.
           88 FDE-NO-VARIABLE-OBJECT VALUE 160.
           88 FDE-NO-TABLE-OBJECT VALUE 161.
           88 FDE-UNEQUAL-TBL-OBJ-WIDTH VALUE 162.
           88 FDE-ERROR-INPUT-CONVERSION VALUE 163.
           88 FDE-ERROR-OUTPUT-CONVERSION VALUE 164.
           88 FDE-ERROR-INVALID-VALUE VALUE 165.
           88 FDE-TERMINAL-TIMED-OUT VALUE 166.
           88 FDE-OBJECT-WIDTH-REQUIRED VALUE 167.
           88 FDE-NO-FORMS-TO-TAB VALUE 168.
           88 FDE-COBOL-19-FRACTION-DIGITS VALUE 169.
           88 FDE-COBOL-19-SIG-DIGITS VALUE 170.
           88 FDE-COBOL-BAD-OVERPUNCH-SIGN VALUE 171.
           88 FDE-COBOL-BAD-PICTURE VALUE 172.
           88 FDE-COBOL-BAD-SEPARATE-SIGN VALUE 173.
           88 FDE-COBOL-BINARY-MEANS-NUMERIC VALUE 174.
           88 FDE-COBOL-C-WITHOUT-R VALUE 175.
           88 FDE-COBOL-COMP-1-MEANS-NO-PIC VALUE 176.
           88 FDE-COBOL-COMP-2-MEANS-NO-PIC VALUE 177.
           88 FDE-COBOL-CR-DB-MUST-BE-RIGHT VALUE 178.
           88 FDE-COBOL-D-WITHOUT-B VALUE 179.
           88 FDE-COBOL-FLOAT-MUST-BE-LEFT VALUE 180.
           88 FDE-COBOL-FLOAT-TOO-BIG VALUE 181.
           88 FDE-COBOL-FREE-FORM-NOT-DEST VALUE 182.
           88 FDE-COBOL-ILLEGAL-CHAR-ENTERED VALUE 183.
           88 FDE-COBOL-ILLEGAL-PIC-CHAR VALUE 184.
           88 FDE-COBOL-INSERT-LEFT-OF-FLOAT VALUE 185.
           88 FDE-COBOL-ITEM-TOO-BIG VALUE 186.
           88 FDE-COBOL-NO-CR-OR-DB-NOW VALUE 187.
           88 FDE-COBOL-NO-PLUS-OR-MINUS-NOW VALUE 188.
           88 FDE-COBOL-NO-MULTIPLE-POINTS VALUE 189.
           88 FDE-COBOL-NO-REP-AFTER-POINT VALUE 190.
           88 FDE-COBOL-NO-REP-FOR-CR-DB  VALUE 191.
           88 FDE-COBOL-NO-SCIENTIFIC  VALUE 192.
           88 FDE-COBOL-NONBLK-OUTSIDE-PAREN VALUE 193.
           88 FDE-COBOL-NONDIGIT-REP-COUNT VALUE 194.
           88 FDE-COBOL-NOT-BOTH-V-AND-P  VALUE 195.
           88 FDE-COBOL-NOT-9P9 VALUE 196.
           88 FDE-COBOL-NOT-P9P  VALUE 197.
           88 FDE-COBOL-PACKED-MEANS-NUM-PIC VALUE 198.
           88 FDE-COBOL-RIGHT-FLT-MEANS-ALL VALUE 199.
           88 FDE-COBOL-S-MUST-BE-FIRST  VALUE 200.
           88 FDE-COBOL-SIGN-NEEDS-S  VALUE 201.
           88 FDE-COBOL-TOO-MANY-VS  VALUE 202.
           88 FDE-COBOL-TRAILING-SIGN-NONBLK VALUE 203.
           88 FDE-COBOL-TWO-POINTS-ENTERED VALUE 204.
           88 FDE-COBOL-TWO-FLOATING VALUE 205.
           88 FDE-COBOL-TWO-SIGNS VALUE 206.
           88 FDE-COBOL-TWO-SIGNS-ENTERED VALUE 207.
           88 FDE-COBOL-UNBAL-PARENS VALUE 208.
           88 FDE-COBOL-UNKNOWN-USAGE VALUE 209.
           88 FDE-COBOL-WRONG-SIGN-VS-USAGE VALUE 210.
           88 FDE-COBOL-USAGE-SIZE-TOO-BIG VALUE 211.
           88 FDE-TOO-MANY-FRACTION-DIGITS VALUE 213.
           88 FDE-TOO-MANY-SIGNIFICANT-DIGITS VALUE 214.
           88 FDE-INVALID-PICTURE VALUE 215.
           88 FDE-BINARY-REQUIRES-NUMERIC VALUE 216.
           88 FDE-PICTURE-INVALID-FOR-COMP-1 VALUE 217.
           88 FDE-PICTURE-INVALID-FOR-COMP-2 VALUE 218.
           88 FDE-CR-DB-MUST-BE-RIGHTMOST VALUE 219.
           88 FDE-FLOATING-SYMBOLS-INVALID VALUE 220.
           88 FDE-INVALID-PICTURE-CHARACTER VALUE 221.
           88 FDE-INSERTION-SYMBOLS-INVALID VALUE 222.
           88 FDE-PICTURE-ITEM-TOO-BIG VALUE 223.
           88 FDE-TOO-MANY-DECIMAL-POINTS VALUE 224.
           88 FDE-NO-REPETITION-AFTER-POINT VALUE 225.
           88 FDE-NO-REPETITION-FOR-CR-DB VALUE 226.
           88 FDE-NONDIGIT-REPETITION VALUE 227.
           88 FDE-V-AND-P-INVALID VALUE 228.
           88 FDE-P-BETWEEN-9-INVALID VALUE 229.
           88 FDE-9-BETWEEN-P-INVALID VALUE 230.
           88 FDE-PACKED-REQUIRES-NUMERIC VALUE 231.
           88 FDE-INVALID-RIGHT-FLOATING VALUE 232.
           88 FDE-S-MUST-BE-FIRST VALUE 233.
           88 FDE-PICTURE-REQUIRES-SIGN VALUE 234.
           88 FDE-TOO-MANY-VS VALUE 235.
           88 FDE-TOO-MANY-FLOATING-SYMBOLS VALUE 236.
           88 FDE-TOO-MANY-SIGN-SYMBOLS VALUE 237.
           88 FDE-UNBALANCED-PARENTHESES VALUE 238.
           88 FDE-INVALID-USAGE VALUE 239.
           88 FDE-INVALID-SIGN-FOR-USAGE VALUE 240.
           88 FDE-INPUT-FORMAT-INVALID-COBOL VALUE 241.
           88 FDE-OUTPUT-FORMAT-INVALID-COBOL VALUE 242.
           88 FDE-UNEXPECTED-CALL-TO VALUE 243.
           88 FDE-FORM-NOT-DISPLAYED VALUE 244.
           88 FDE-COBOL-INVALID-MANAGE-FORM VALUE 245.
           88 FDE-INVALID-COBOL-DATA-TYPE VALUE 246.
           88 FDE-INVALID-COBOL-CATEGORY VALUE 247.
           88 FDE-COBOL-DESTINATION-INVALID VALUE 248.
           88 FDE-COBOL-SOURCE-INVALID VALUE 249.
           88 FDE-OBJECT-SIZE-COBOL-MISMATCH VALUE 250.
           88 FDE-INCOMPATIBLE-DISPLAY-CLAUSE VALUE 251.
           88 FDE-INCOMPATIABLE-PROGRAM-CLAUSE VALUE 252.
           88 FDE-B-INVALID-FOR-PICTURE VALUE 253.
           88 FDE-COBOL-TOO-MANY-DIGITS VALUE 254.
           88 FDE-TOO-MANY-DIGITS VALUE 255.
           88 FDE-COBOL-P-NOT-SUPPORTED VALUE 256.
           88 FDE-P-INVALID-FOR-PICTURE VALUE 257.


*DECK DECK=FDE$COBOL_VARIABLE_STATUS EXPAND=FALSE
       01 FDE-COBOL-VARIABLE-STATUS USAGE COMP PIC S9(18) SYNC LEFT.
           88 FDE-NO-ERROR VALUE 0.
           88 FDE-INVALID-STRING VALUE 1.
           88 FDE-INVALID-REAL VALUE 2.
           88 FDE-INVALID-INTEGER VALUE 3.
           88 FDE-UNKNOWN-USER-VALUE VALUE 4.
           88 FDE-INVALID-BDP-DATA VALUE 5.
           88 FDE-NO-DIGITS VALUE 6.
           88 FDE-LOSS-OF-SIGNIFICANCE VALUE 7.
           88 FDE-VARIABLE-NOT-FILLED VALUE 8.
           88 FDE-OVERFLOW VALUE 9.
           88 FDE-UNDERFLOW VALUE 10.
           88 FDE-INDEFINITE VALUE 11.
           88 FDE-INFINITE VALUE 12.
           88 FDE-VARIABLE-NOT-ENTERED VALUE 13.
           88 FDE-OUTPUT-FORMAT-BAD VALUE 14.
           88 FDE-VARIABLE-TRUNCATED VALUE 15.
           88 FDE-GR-18-DIGITS VALUE 16.
           88 FDE-INVALID-OVERPUNCH-SIGN VALUE 17.
           88 FDE-INVALID-SEPARATE-SIGN VALUE 18.
           88 FDE-C-WITHOUT-R VALUE 19.
           88 FDE-D-WITHOUT-B VALUE 20.
           88 FDE-FLOATING-NUMBER-TOO-BIG VALUE 21.
           88 FDE-INVALID-CHARACTER-ENTERED VALUE 22.
           88 FDE-NO-CR-OR-DB-NOW VALUE 23.
           88 FDE-NO-PLUS-OR-MINUS-NOW VALUE 24.
           88 FDE-NO-SCIENTIFIC-NOTATION VALUE 25.
           88 FDE-NONBLK-OUTSIDE-PARENTHESES VALUE 26.
           88 FDE-NONBLK-AFTER-TRAILING-SIGN VALUE 27.
           88 FDE-TOO-MANY-DECIMALS VALUE 28.
           88 FDE-TOO-MANY-SIGNS VALUE 29.
*DECK DECK=FDE$CONDITION_IDENTIFIERS EXPAND=FALSE
?? NEWTITLE := 'FDE$CONDITION_IDENTIFIERS', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    fdc$base_condition=(($integer('F')*100(16))+$integer('D'))*1000000(16),


    fdc$format_display_identifier = 'FD',

    fde$terminal_disconnected = fdc$base_condition + 1,
    {E Terminal disconnected.}

    fde$no_input_request = fdc$base_condition + 2,
    {E No scheduled form has an input field.}

    fde$cursor_not_in_variable = fdc$base_condition + 3,
    {E Cursor is not in a variable field.}

    fde$more_errors_exist = fdc$base_condition + 4,
    {E More errors exist.}

    fde$unknown_form_name = fdc$base_condition + 5,
    {E Form +P does not exist.}

    fde$form_compilation_errors = fdc$base_condition + 6,
    {E Form +P has compilation errors.}

    fde$no_space_available = fdc$base_condition + 7,
    {E Space is not available.}

    fde$unsupported_terminal = fdc$base_condition + 8,
    {E Your terminal is not supported by screen formatting.}

    fde$invalid_form_identifier = fdc$base_condition + 9,
    {E Form identifier +P does not   exist.}

    fde$invalid_user_entry = fdc$base_condition + 10,
    {E Invalid user entry.}

    fde$unknown_variable_name = fdc$base_condition + 11,
    {E Variable +P does not exist for form +P.}

    fde$too_many_integers = fdc$base_condition + 12,
    {E Too many integer ranges specified for validation for form +P.}

    fde$object_name_exists = fdc$base_condition + 13,
    {E Object +P already exists for form +P.}

    fde$work_area_invalid = fdc$base_condition + 14,
    {E Program work area does not match +P form definition.}

    fde$invalid_x_form_position = fdc$base_condition + 15,
    {E X position +P is not valid for form +P.}

    fde$invalid_y_form_position = fdc$base_condition + 16,
    {E Y position +P is not valid for form +P.}

    fde$invalid_width = fdc$base_condition + 17,
    {E Width +P is not valid for form +P.}

    fde$invalid_height = fdc$base_condition + 18,
    {E Height +P is not valid for form +P.}

    fde$invalid_message_form_name = fdc$base_condition + 19,
    {E Message form +P is not a valid name for form +P.}

    fde$invalid_occurrence = fdc$base_condition + 20,
    {E Occurrence +P is not valid for object +P form +P.}

    fde$invalid_character_position = fdc$base_condition + 21,
    {E Character position +P is not valid for object +P form +P.}

    fde$invalid_mode = fdc$base_condition + 22,
    {E Invalid mode for variable +P, form +P.}

    fde$invalid_state = fdc$base_condition + 23,
    {E Invalid state.}

    fde$invalid_variable_value = fdc$base_condition + 24,
    {E Variable +P has invalid value for form +P.}

    fde$invalid_object_name = fdc$base_condition + 25,
    {E Object +P is not a valid name for form +P.}

    fde$invalid_form_name = fdc$base_condition + 26,
    {E Form +P is not a valid name.}

    fde$form_closed = fdc$base_condition + 27,
    {E Form +P is not open.}

    fde$too_many_attributes = fdc$base_condition + 28,
    {E Too may display attributes for form +P.}

    fde$invalid_attribute_name = fdc$base_condition + 29,
    {E Attribute +P is not a valid   name for form +P.}

    fde$too_many_screen_occurrence = fdc$base_condition + 30,
    {E Too many visible occurrences for table +P, form +P.}

    fde$no_form_definition = fdc$base_condition + 31,
    {E No form definition.}

    fde$too_many_stored_occurrence = fdc$base_condition + 32,
    {E Too many stored occurrences   for table +P, form +P.}

    fde$unknown_object_name = fdc$base_condition + 33,
    {E Object +P does not exist for form +P.}

    fde$no_define_object_name = fdc$base_condition + 34,
    {E Object +P must be defined for form +P.}

    fde$invalid_name = fdc$base_condition + 35,
    {E +P is a not a valid name.}

    fde$system_error = fdc$base_condition + 36,
    {E System error +P on form +P.}

    fde$invalid_table_name = fdc$base_condition + 37,
    {E Table +P is not a valid name for form +P.}

    fde$invalid_variable_name = fdc$base_condition + 38,
    {E Variable +P is not a valid name for form +P.}

    fde$form_pushed = fdc$base_condition + 39,
    {E Pushed form +P cannot be manipulated.}

    fde$unknown_table_name = fdc$base_condition + 40,
    {E Table +P does not exist for   form +P.}

    fde$no_table_variable_defined = fdc$base_condition + 41,
    {E No variable defined for table +P, form +P.}

    fde$no_forms_to_pop = fdc$base_condition + 42,
    {E There are no forms to pop.}

    fde$only_character_data = fdc$base_condition + 43,
    {E Only character data.}

    fde$only_noncharacter_data = fdc$base_condition + 44,
    {E Only noncharacter data.}

    fde$form_definition_errors = fdc$base_condition + 45,
    {E Form definition errors.}

    fde$no_forms_to_push = fdc$base_condition + 46,
    {E No forms are scheduled to push.}

    fde$invalid_program_values = fdc$base_condition + 47,
    {E Invalid program values exist.}

    fde$input_has_unknown_value = fdc$base_condition + 48,
    {E Terminal user indicated an unknown value.}

    fde$invalid_input_values = fdc$base_condition + 49,
    {E Terminal user entered invalid input.}

    fde$not_an_input_variable = fdc$base_condition + 50,
    {E Not an input variable.}

    fde$cursor_not_in_form = fdc$base_condition + 51,
    {E Cursor is not in any form.}

    fde$form_has_no_variables = fdc$base_condition + 52,
    {I Form +P has no variables. }

    fde$no_forms_to_show = fdc$base_condition + 53,
    {E No forms are scheduled to show.}

    fde$form_not_scheduled = fdc$base_condition + 54,
    {E Form +P instance is not scheduled.}

    fde$invalid_event_name = fdc$base_condition + 55,
    {E Event +P is not a valid name for form +P.}

    fde$invalid_x_position = fdc$base_condition + 56,
    {E X position +P is not valid for form +P.}

    fde$invalid_y_position = fdc$base_condition + 57,
    {E Y position +P is not valid for form +P.}

    fde$unknown_event_name = fdc$base_condition + 58,
    {E Event +P does not exist for   form +P.}

    fde$invalid_deck_name = fdc$base_condition + 59,
    {E Deck +P is not a valid name   for form +P.}

    fde$invalid_record_name = fdc$base_condition + 60,
    {E Record +P is not a valid name for form +P.}

    fde$object_exists = fdc$base_condition + 61,
    {E Object already exists at x position +P, y position +P for form +P.}

    fde$table_name_exists = fdc$base_condition + 62,
    {E Table +P already exists for form +P.}

    fde$object_overlays = fdc$base_condition + 63,
    {E Object at x position +P, y position +P, ..
    {overlays an existing object on form +P.}

    fde$too_many_reals = fdc$base_condition + 64,
    {E Too many ranges specified for validation of real numbers for form
    {+P.}

    fde$too_many_strings = fdc$base_condition + 65,
    {E Too many strings specified for validation of strings for form +P.}

    fde$no_object_at_position = fdc$base_condition + 66,
    {E No object at x position +P,   y position +P for form +P.}

    fde$array_too_small = fdc$base_condition + 67,
    {E Array is too small.}

    fde$string_too_small = fdc$base_condition + 68,
    {E String is too small.}

    fde$variable_name_exists = fdc$base_condition + 69,
    {E Variable +P already exists for form +P.}

    fde$form_already_added = fdc$base_condition + 70,
    {E Form +P is already added.}

    fde$invalid_event_active = fdc$base_condition + 72,
    {E Invalid event active.}

    fde$cannot_update_opened_form = fdc$base_condition + 73,
    {E Open form, form +P, cannot be updated.}

    fde$help_form_exists = fdc$base_condition + 74,
    {E Help form already exists for form +P.}

    fde$error_form_exists = fdc$base_condition + 75,
    {E Error form already exists for form +P.}

    fde$error_message_exists = fdc$base_condition + 76,
    {E Error message already exists for form +P.}

    fde$help_message_exists = fdc$base_condition + 77,
    {E Help message already exists   for form +P.}

    fde$invalid_display_name = fdc$base_condition + 78,
    {E Display +P is not a valid name for form +P.}

    fde$invalid_real_range = fdc$base_condition + 79,
    {E Real range +P - +P is not valid for variable +P, form +P.}

    fde$invalid_integer_range = fdc$base_condition + 80,
    {E Integer range +P - +P is not valid variable +P, form +P.}

    fde$unknown_integer_range = fdc$base_condition + 81,
    {E Integer range +P - +P is not known for variable +P, form +P.}

    fde$unknown_real_range = fdc$base_condition + 82,
    {E Real range +P - +P does not   exist for variable +P, form +P.}

    fde$unknown_valid_string = fdc$base_condition + 83,
    {E Validation string +P does not exist for variable +P, form +P.}

    fde$display_name_exists = fdc$base_condition + 84,
    {E Display +P already exists for form +P.}

    fde$event_name_exists = fdc$base_condition + 85,
    {E Event +P already exists for   form +P.}

    fde$unknown_display_name = fdc$base_condition + 86,
    {E Display +P does not exist for form +P.}

    fde$too_many_form_names = fdc$base_condition + 87,
    {E There are too many form names.}

    fde$too_many_form_objects = fdc$base_condition + 88,
    {E There are too many object names for form +P.}

    fde$no_text_at_position = fdc$base_condition + 89,
    {E No text at x equals +P, y equals +P, form +P.}

    fde$no_text_for_object = fdc$base_condition + 90,
    {E Object +P requires text for   form +P.}

    fde$unknown_occurrence = fdc$base_condition + 91,
    {E Occurrence +P does not exist for object +P form +P.}

    fde$no_string = fdc$base_condition + 92,
    {E A string is required.}

    fde$range_overlap = fdc$base_condition + 93,
    {E There is a range +P - +P overlap for variable +P, form +P.}

    fde$no_comments_to_delete = fdc$base_condition + 94,
    {E There are no comments to delete for form +P.}

    fde$object_occurrence_exists = fdc$base_condition + 95,
    {E Occurrence +P already exists for object +P for form +P.}

    fde$no_string_specified = fdc$base_condition + 96,
    {E A string must be specified.}

    fde$valid_string_exists = fdc$base_condition + 97,
    {E Validation string +P already exists for variable +P, form +P.}

    fde$invalid_object_change = fdc$base_condition + 98,
    {E Object change +P is not valid.}

    fde$invalid_address = fdc$base_condition + 99,
    {E Address is not valid in request for form +P.}

    fde$terminal_not_identified = fdc$base_condition + 100,
    {E Terminal name does not exist in terminal definitions. Use ..
    {SET_TERMINAL_ATTRIBUTES command with parameter TERMINAL_NAME.}

    fde$invalid_form_language = fdc$base_condition + 101,
    {E Form language +P is not valid for form +P.}

    fde$invalid_form_area_key = fdc$base_condition + 102,
    {E Form area key is not valid for form +P.}

    fde$form_name_required = fdc$base_condition + 103,
    {E A form name is required to save a form.}

    fde$no_forms_to_read = fdc$base_condition + 104,
    {E No forms scheduled to read.}

    fde$invalid_help_form_name = fdc$base_condition + 105,
    {E Help form +P is not a valid   name for form +P.}

    fde$invalid_error_form_name = fdc$base_condition + 106,
    {E Error form +P is not a valid name for form +P.}

    fde$create_mark_invalid = fdc$base_condition + 107,
    {E Create mark is only valid on a design form. Form is +P.}

    fde$delete_mark_invalid = fdc$base_condition + 108,
    {E Delete mark is only valid on a design form. Form is +P.}

    fde$no_mark_defined = fdc$base_condition + 109,
    {E No mark defined for form +P.}

    fde$area_cuts_object = fdc$base_condition + 110,
    {E Area cuts object at x = +P,  y = +P on form +P.}

    fde$copy_outside_form = fdc$base_condition + 111,
    {E Copy area outside of form +P.}

    fde$move_outside_form = fdc$base_condition + 112,
    {E Move area outside of form +P.}

    fde$invalid_form_attribute = fdc$base_condition + 113,
    {E Invalid form attribute for form +P.}

    fde$invalid_record_attribute = fdc$base_condition + 114,
    {E Invalid record attribute for form +P.}

    fde$invalid_object_key = fdc$base_condition + 115,
    {E Invalid object key for form +P.}

    fde$invalid_object_attribute = fdc$base_condition + 116,
    {E Invalid object attribute for form +P.}

    fde$invalid_table_attribute = fdc$base_condition + 117,
    {E Invalid table attribute for form +P.}

    fde$program_data_type = fdc$base_condition + 118,
    {E Invalid program data type for form +P.}

    fde$invalid_output_format_key = fdc$base_condition + 119,
    {E Invalid output format key for form +P.}

    fde$invalid_error_key = fdc$base_condition + 120,
    {E Invalid error key for form +P.}

    fde$invalid_variable_attribute = fdc$base_condition + 121,
    {E Invalid variable attribute for form +P.}

    fde$invalid_help_key = fdc$base_condition + 123,
    {E Invalid help key for form +P.}

    fde$feature_not_implemented = fdc$base_condition + 124,
    {E Feature +P is not implemented.}

    fde$cannot_change_form = fdc$base_condition + 125,
    {E Form +P, cannot be changed.}

    fde$invalid_record_type = fdc$base_condition + 126,
    {E Invalid record type for form +P.}

    fde$object_not_in_form  = fdc$base_condition + 127,
    {E Object at x position +P, y position +P is not inside form +P.}

    fde$invalid_form_processor = fdc$base_condition + 128,
    {E Invalid form processor for form +P.}

    fde$invalid_x_increment = fdc$base_condition + 129,
    {E  X increment +P is not valid for form +P.}

    fde$invalid_y_increment = fdc$base_condition + 130,
    {E Y increment +P is not valid for form +P.}

    fde$form_too_large_for_screen = fdc$base_condition + 131,
    {E Form +P at x=+P, y=+P, width=+P, height=+P outside of screen.}

    fde$invalid_text_processing = fdc$base_condition + 132,
    {E Invalid text processing for form +P.}

    fde$invalid_design_form = fdc$base_condition + 133,
    {E Form +P is not a design form.}

    fde$no_object_variable_defined = fdc$base_condition + 134,
    {E No variable defined for object +P, form +P.}

    fde$event_not_assigned = fdc$base_condition + 135,
    {E Form +P cannot be assigned a terminal event for event name +P.}

    fde$form_not_ended = fdc$base_condition + 136,
    {E Form +P was not ended.}

    fde$invalid_event_form_name = fdc$base_condition + 137,
    {E Form +P has invalid event form name +P.}

    fde$invalid_event_form_key = fdc$base_condition + 138,
    {E Form +P has invalid event form definition key.}

    fde$form_already_open = fdc$base_condition + 139,
    {E Form +P is already open.}

    fde$invalid_event_label = fdc$base_condition + 140,
    {E Event label +P is not a valid name for form +P.}

    fde$form_requires_conversion = fdc$base_condition + 141,
    {E Form +P requires conversion.}

    fde$no_events_active = fdc$base_condition + 142,
    {E Screen must have some active events.}

    fde$delete_outside_form = fdc$base_condition + 143,
    {E Delete area outside of form +P.}

    fde$mark_outside_form = fdc$base_condition + 144,
    {E Mark area outside of form +P.}

    fde$bad_data_value = fdc$base_condition + 145,
    {E Bad data value.}

    fde$record_defn_not_written = fdc$base_condition + 146,
    {E Cannot produce a FORTRAN record definition for form +P.}

    fde$wrong_variable_type = fdc$base_condition + 147,
    {E This command expects a variable type of +P.}

    fde$invalid_variable_length = fdc$base_condition + 148,
    {E Variable +P has invalid length +P for form +P.}

    fde$event_trigger_exists = fdc$base_condition + 149,
    {E Event trigger already exists for form +P.}

    fde$form_already_combined = fdc$base_condition + 150,
    {E Form +P is already combined.}

    fde$invalid_table_size = fdc$base_condition + 151,
    {E Invalid table size for table +P, form +P.}

    fde$form_not_added = fdc$base_condition + 152,
    {E Form +P not added.}

    fde$invalid_input_format_key = fdc$base_condition + 153,
    {E Invalid input format key for form +P.}

    fde$system_error_message = fdc$base_condition + 154,
    {I Please correct. }

    fde$system_help_message = fdc$base_condition + 155,
    {I Please enter. }

    fde$system_bad_key_message = fdc$base_condition + 156,
    {I Key has no meaning for cursor position. }

    fde$width_and_height_required = fdc$base_condition + 157,
    {E Form +P requires width and height. }

    fde$no_variable_definition = fdc$base_condition + 158,
    {E Form +P requires a variable definition for +P, occurrence +P.}

    fde$no_table_variable = fdc$base_condition + 159,
    {E Form +P requires a variable definition for table +P, variable +P.}

    fde$no_variable_object = fdc$base_condition + 160,
    {E Form +P requires an object for variable +P, occurrence +P.}

    fde$no_table_object = fdc$base_condition + 161,
    {E Form +P requires object for table +P, variable +P.}

    fde$unequal_tbl_obj_width = fdc$base_condition + 162,
    {E Form +P has inconsistent object width for object +P, occurrence +P.}

    fde$error_input_conversion = fdc$base_condition + 163,
    {E Form +P variable +P, occurrence +P cannot be converted ..
    {to program data type using input format definition.}

    fde$error_output_conversion = fdc$base_condition + 164,
    {E Form +P variable +P, occurrence +P program data value cannot be ..
    {displayed on form using output format definition.}

    fde$error_invalid_value = fdc$base_condition + 165,
    {E Form +P object +P, occurrence +P has an invalid initial value.}

    fde$terminal_timed_out = fdc$base_condition + 166,
    {E Terminal timed out.}

    fde$object_width_required = fdc$base_condition + 167,
    {E Form +P object +P requires a width.}

    fde$no_forms_are_scheduled = fdc$base_condition + 168,
    {E No forms are scheduled. }

    fde$cobol_19_fraction_digits = fdc$base_condition + 169,
    {E Cannot enter more than 18 digits to right of decimal point.}

    fde$cobol_19_sig_digits = fdc$base_condition + 170,
    {E Cannot enter more than 18 digits to left of decimal point.}

    fde$cobol_bad_overpunch_sign = fdc$base_condition + 171,
    {E Expected source overpunch sign to be A..R, "{" or ")".}

    fde$cobol_bad_picture = fdc$base_condition + 172,
    {E Each PICTURE character is legal, but the combination is not.}

    fde$cobol_bad_separate_sign = fdc$base_condition + 173,
    {E Expected source separate sign to be "+" or "-".}

    fde$cobol_binary_means_numeric = fdc$base_condition + 174,
    {E USAGE IS BINARY, COMPUTATIONAL, or COMP can only be used ..
    {with a PICTURE describing a numeric signed or unsigned item.}

    fde$cobol_c_without_r = fdc$base_condition + 175,
    {E "C" must be followed by "R" to form "CR".}

    fde$cobol_comp_1_means_no_pic = fdc$base_condition + 176,
    {E USAGE IS COMPUTATIONAL-1 can only be used without a PICTURE.}

    fde$cobol_comp_2_means_no_pic = fdc$base_condition + 177,
    {E USAGE IS COMPUTATIONAL-2 can only be used without a PICTURE.}

    fde$cobol_CR_DB_must_be_right = fdc$base_condition + 178,
    {E CR and DB must be rightmost in PICTURE.}

    fde$cobol_d_without_b = fdc$base_condition + 179,
    {E "D" must be followed by "B" to form "DB".}

    fde$cobol_float_must_be_left = fdc$base_condition + 180,
    {E Floating symbols in a PICTURE must occur in left-most digits.}

    fde$cobol_float_too_big = fdc$base_condition + 181,
    {E The integer portion of a COMPUTATIONAL-1 or COMPUTATIONAL-2 value ..
    {must be less than 1,000,000,000,000,000,000.}

    fde$cobol_free_form_not_dest = fdc$base_condition + 182,
    {E Free form field cannot be destination of fdp$move_to_cobol.}

    fde$cobol_illegal_char_entered = fdc$base_condition + 183,
    {E Only characters produced by numeric-edited may be entered, ..
    {plus "(" and ")", with lower case accepted. ..
    {These are digits, space, ".", "+", "-", "CR", "DB", "$", "#", "*", "/",  ..
    {or ",".}

    fde$cobol_illegal_pic_char = fdc$base_condition + 184,
    {E An illegal character is used in a PICTURE.}

    fde$cobol_insert_left_of_float = fdc$base_condition + 185,
    {E Simple insertion characters cannot appear at left of floating string.}

    fde$cobol_item_too_big = fdc$base_condition + 186,
    {E The number of character positions described in a ..
    {PICTURE cannot exceed 1,048,575.}

    fde$cobol_no_cr_or_db_now = fdc$base_condition + 187,
    {E CR and DB are not allowed for this field now.}

    fde$cobol_no_plus_or_minus_now = fdc$base_condition + 188,
    {E "+", "-", and "(...)" are not allowed in this field now. }
    {Use "CR" or "DB".}

    fde$cobol_no_multiple_points = fdc$base_condition + 189,
    {E numeric-edited PICTURE cannot have multiple points.}

    fde$cobol_no_rep_after_point = fdc$base_condition + 190,
    {E PICTURE cannot have repetition count for decimal point.}

    fde$cobol_no_rep_for_cr_db = fdc$base_condition + 191,
    {E PICTURE cannot have repetition count for CR or DB.}

    fde$cobol_no_scientific = fdc$base_condition + 192,
    {E Scientific notation is not allowed.}

    fde$cobol_nonblk_outside_paren = fdc$base_condition + 193,
    {E Parentheses, when used, must surround all non-spaces.}

    fde$cobol_nondigit_rep_count = fdc$base_condition + 194,
    {E In a PICTURE, characters between a left and right parentheses ..
    { are a repetition count, and must be decimal digits.}

    fde$cobol_not_both_v_and_p = fdc$base_condition + 195,
    {E "V" and "P" cannot both be used in a PICTURE.}

    fde$cobol_not_9p9 = fdc$base_condition + 196,
    {E Cannot have P's between 9's in PICTURE.}

    fde$cobol_not_p9p = fdc$base_condition + 197,
    {E Cannot have 9's between P's in PICTURE.}

    fde$cobol_packed_means_num_pic = fdc$base_condition + 198,
    {E USAGE IS PACKED-DECIMAL or  COMPUTATIONAL-3 ..
    {can only be used with a PICTURE describing a numeric item. }

    fde$cobol_right_flt_means_all = fdc$base_condition + 199,
    {E In a PICTURE, if any digits to the right of the decimal point ..
    {are floating symbols (e.g. ++ -- ZZ ** $$ ##) then all digits must be ..
    {represented by the floating symbol, which must also appear to the ..
    {left of the decimal point (i.e. "VZZZ" is not allowed).}

    fde$cobol_s_must_be_first = fdc$base_condition + 200,
    {E The "S" must be the first character in the PICTURE.}

    fde$cobol_sign_needs_s = fdc$base_condition + 201,
    {E For item with SIGN clause, PICTURE must have leading "S".}

    fde$cobol_too_many_vs = fdc$base_condition + 202,
    {E Only one "V" can be in a PICTURE.}

    fde$cobol_trailing_sign_nonblk = fdc$base_condition + 203,
    {E Only spaces can follow trailing "+", "-", "CR", or "DB".}

    fde$cobol_two_points_entered = fdc$base_condition + 204,
    {E Only a single decimal point may be entered.}

    fde$cobol_two_floating = fdc$base_condition + 205,
    {E PICTURE cannot have two different floating symbols.}

    fde$cobol_two_signs = fdc$base_condition + 206,
    {E PICTURE cannot have two sign symbols.}

    fde$cobol_two_signs_entered = fdc$base_condition + 207,
    {E Can have only one sign ("+", "-", "CR", "DB", or "(...)").}

    fde$cobol_unbal_parens = fdc$base_condition + 208,
    {E PICTURE has left parenthesis without matching right parenthesis.}

    fde$cobol_unknown_usage = fdc$base_condition + 209,
    {E Unrecognized USAGE keyword.}

    fde$cobol_wrong_sign_vs_usage = fdc$base_condition + 210,
    {E A SIGN clause can only be used with an item having default USAGE or ..
    {USAGE IS DISPLAY.}

    fde$cobol_usage_size_too_big = fdc$base_condition + 211,
    {E A USAGE IS FREE-FORM value cannot be longer than 255 characters.}

    fde$too_many_fraction_digits = fdc$base_condition + 213,
    {E Cannot enter more than 18 digits to right of decimal point ..
    {for variable +P, form +P.}

    fde$too_many_significant_digits = fdc$base_condition + 214,
    {E Cannot enter more than 18 digits to left of decimal point ..
    {for variable +P, form +P.}

    fde$invalid_picture = fdc$base_condition + 215,
    {E Each PICTURE character is legal, but the combination is not ..
    {for variable +P, form +P.}

    fde$binary_requires_numeric = fdc$base_condition + 216,
    {E USAGE IS BINARY, COMPUTATIONAL, or COMP can only be used ..
    {with a PICTURE describing a numeric signed or unsigned item ..
    {for variable +P, form +P.}

    fde$picture_invalid_for_comp_1 = fdc$base_condition + 217,
    {E USAGE IS COMPUTATIONAL-1 can only be used without a PICTURE ..
    {for variable +P, form +P.}

    fde$picture_invalid_for_comp_2 = fdc$base_condition + 218,
    {E USAGE IS COMPUTATIONAL-2 can only be used without a PICTURE ..
    {for variable +P, form +P.}

    fde$CR_DB_must_be_rightmost = fdc$base_condition + 219,
    {E CR and DB must be rightmost in PICTURE for variable +P, form +P.}

    fde$floating_symbols_invalid = fdc$base_condition + 220,
    {E Floating symbols in a PICTURE must occur in left-most digits ..
    {for variable +P, form +P.}

    fde$invalid_picture_character = fdc$base_condition + 221,
    {E An illegal character is used in a PICTURE for variable +P, form +P.}

    fde$insertion_symbols_invalid = fdc$base_condition + 222,
    {E Simple insertion characters cannot appear at left of floating string ..
    {for variable +P, form +P.}

    fde$picture_item_too_big = fdc$base_condition + 223,
    {E The number of character positions described in a ..
    {PICTURE cannot exceed 1,048,575 for variable +P, form +P.}

    fde$too_many_decimal_points = fdc$base_condition + 224,
    {E numeric-edited PICTURE cannot have multiple points ..
    {for variable +P, form +P.}

    fde$no_repetition_after_point = fdc$base_condition + 225,
    {E PICTURE cannot have repetition count for decimal point ..
    {for variable +P, form +P.}

    fde$no_repetition_for_cr_db = fdc$base_condition + 226,
    {E PICTURE cannot have repetition count for CR or DB ..
    {for variable +P, form +P.}

    fde$nondigit_repetition = fdc$base_condition + 227,
    {E In a PICTURE, characters between a left and right parentheses ..
    { are a repetition count, and must be decimal digits ..
    {for variable +P, form +P.}

    fde$v_and_p_invalid = fdc$base_condition + 228,
    {E "V" and "P" cannot both be used in a PICTURE ..
    {for variable +P, form +P.}

    fde$p_between_9_invalid = fdc$base_condition + 229,
    {E Cannot have P's between 9's in PICTURE ..
    {for variable +P, form +P.}

    fde$9_between_p_invalid = fdc$base_condition + 230,
    {E Cannot have 9's between P's in PICTURE ..
    {for variable +P, form +P.}

    fde$packed_requires_numeric = fdc$base_condition + 231,
    {E USAGE IS PACKED-DECIMAL or  COMPUTATIONAL-3 ..
    {can only be used with a PICTURE describing a numeric item ..
    {for variable +P, form +P.}

    fde$invalid_right_floating = fdc$base_condition + 232,
    {E In a PICTURE, if any digits to the right of the decimal point ..
    {are floating symbols (e.g. ++ -- ZZ ** $$ ##) then all digits must be ..
    {represented by the floating symbol, which must also appear to the ..
    {left of the decimal point (i.e. "VZZZ" is not allowed) ..
    {for variable +P, form +P.}

    fde$s_must_be_first = fdc$base_condition + 233,
    {E The "S" must be the first character in the PICTURE ..
    {for variable +P, form +P.}

    fde$picture_requires_sign = fdc$base_condition + 234,
    {E For item with SIGN clause, PICTURE must have leading "S" ..
    {for variable +P, form +P.}

    fde$too_many_vs = fdc$base_condition + 235,
    {E Only one "V" can be in a PICTURE for variable +P, form +P.}

    fde$too_many_floating_symbols = fdc$base_condition + 236,
    {E PICTURE cannot have two different floating symbols ..
    {for variable +P, form +P.}

    fde$too_many_sign_symbols = fdc$base_condition + 237,
    {E PICTURE cannot have two sign symbols for variable +P, form +P.}

    fde$unbalanced_parentheses = fdc$base_condition + 238,
    {E PICTURE has left parenthesis without matching right parenthesis ..
    {for variable +P, form +P.}

    fde$invalid_usage = fdc$base_condition + 239,
    {E usage must be binary, comp, computational, comp-1, computational-1 ..
    {comp-3, computational-3, packed-decimal, or display ..
    {for variable +P, form +P.}

    fde$invalid_sign_for_usage = fdc$base_condition + 240,
    {E A SIGN clause can only be used with an item having default USAGE or ..
    {USAGE IS DISPLAY for variable +P, form +P.}

    fde$input_format_invalid_cobol = fdc$base_condition + 241,
    {E Form +P variable +P cannot use input format for COBOL data type.}

    fde$output_format_invalid_cobol = fdc$base_condition + 242,
    {E Form +P variable +P cannot use output format for COBOL data type.}

    fde$unexpected_call_to = fdc$base_condition + 243,
    {E Unexpected call to +P. }

    fde$form_not_displayed = fdc$base_condition + 244,
    {E Form +P is not currently displayed. }

    fde$cobol_invalid_manage_form = fdc$base_condition + 245,
    {E MANAGE_FORM cannot use COBOL data type. Variable is +P on form +P.}

    fde$invalid_cobol_data_type = fdc$base_condition + 246,
    {E COBOL data type cannot be used for non COBOL form processor. Variable ..
    {is +P on form +p.}

    fde$invalid_cobol_category = fdc$base_condition + 247,
    {E Numeric or alphanumeric edited category cannot be used for COBOL ..
    {program clause. Alphanumeric edited or numeric signed ..
    {category cannot be used for display clause.  Variable is +P on form +P. }

    fde$cobol_destination_invalid = fdc$base_condition + 248,
    {E The destination area for data does not match COBOL description. The ..
    {COBOL description has size +P, but the destination area has size +P.}

    fde$cobol_source_invalid = fdc$base_condition + 249,
    {E The source area for data does not match COBOL description.  The COBOL ..
    {description has size +P, but the source area has size +P.}

    fde$object_size_cobol_mismatch = fdc$base_condition + 250,
    {E The COBOL description has size +P, but the object has size +P. The ..
    {object is +P on form +P.}

    fde$incompatible_display_clause = fdc$base_condition + 251,
    {E Numeric and numeric edited COBOL display pictures cannot be used with ..
    {alphabetic or alphanumeric program pictures. The variable is +P on ..
    {form +P.}

    fde$incompatible_program_clause = fdc$base_condition + 252,
    {E Numeric COBOL program pictures cannot be used with ..
    {alphabetic or alphanumeric display pictures. The variable is +P on ..
    {form +P.}

    fde$b_invalid_for_picture = fdc$base_condition + 253,
    {E COBOL editing character "B" is invalid in alphabetic picture. ..
    {The variable is +P on form +P.}

    fde$cobol_too_many_digits = fdc$base_condition + 254,
    {E A numeric item may not exceed 18 digit positions.}

    fde$too_many_digits = fdc$base_condition + 255,
    {E Numeric variable +P on form +P may not exceed 18 digit positions.}

    fde$cobol_p_not_supported = fdc$base_condition + 256,
    {E COBOL editing symbol "P" is not supported.}

    fde$p_invalid_for_picture = fdc$base_condition + 257;
    {E COBOL editing symbol "P" is not valid in picture clause. ..
    {The variable is +P on form +P.}

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??

*DECK DECK=FDE$FORTRAN_STATUS EXPAND=FALSE
      INTEGER*4 FDE$REQUEST_SUCCESSFUL
      PARAMETER (FDE$REQUEST_SUCCESSFUL=0)
      INTEGER*4 FDE$TERMINAL_DISCONNECTED
      PARAMETER (FDE$TERMINAL_DISCONNECTED=1)
      INTEGER*4 FDE$NO_INPUT_REQUEST
      PARAMETER (FDE$NO_INPUT_REQUEST=2)
      INTEGER*4 FDE$CURSOR_NOT_IN_VARIABLE
      PARAMETER (FDE$CURSOR_NOT_IN_VARIABLE=3)
      INTEGER*4 FDE$MORE_ERRORS_EXIST
      PARAMETER (FDE$MORE_ERRORS_EXIST=4)
      INTEGER*4 FDE$UNKNOWN_FORM_NAME
      PARAMETER (FDE$UNKNOWN_FORM_NAME=5)
      INTEGER*4 FDE$FORM_COMPILATION_ERRORS
      PARAMETER (FDE$FORM_COMPILATION_ERRORS=6)
      INTEGER*4 FDE$NO_SPACE_AVAILABLE
      PARAMETER (FDE$NO_SPACE_AVAILABLE=7)
      INTEGER*4 FDE$UNSUPPORTED_TERMINAL
      PARAMETER (FDE$UNSUPPORTED_TERMINAL=8)
      INTEGER*4 FDE$INVALID_FORM_IDENTIFIER
      PARAMETER (FDE$INVALID_FORM_IDENTIFIER=9)
      INTEGER*4 FDE$INVALID_USER_ENTRY
      PARAMETER (FDE$INVALID_USER_ENTRY=10)
      INTEGER*4 FDE$UNKNOWN_VARIABLE_NAME
      PARAMETER (FDE$UNKNOWN_VARIABLE_NAME=11)
      INTEGER*4 FDE$TOO_MANY_INTEGERS
      PARAMETER (FDE$TOO_MANY_INTEGERS=12)
      INTEGER*4 FDE$OBJECT_NAME_EXISTS
      PARAMETER (FDE$OBJECT_NAME_EXISTS=13)
      INTEGER*4 FDE$WORK_INVALID
      PARAMETER (FDE$WORK_INVALID=14)
      INTEGER*4 FDE$INVALID_X_FORM_POSITION
      PARAMETER (FDE$INVALID_X_FORM_POSITION=15)
      INTEGER*4 FDE$INVALID_Y_FORM_POSIITON
      PARAMETER (FDE$INVALID_Y_FORM_POSIITON=16)
      INTEGER*4 FDE$INVALID_WIDTH
      PARAMETER (FDE$INVALID_WIDTH=17)
      INTEGER*4 FDE$INVALID_HEIGHT
      PARAMETER (FDE$INVALID_HEIGHT=18)
      INTEGER*4 FDE$INVALID_MESSAGE_FORM_NAME
      PARAMETER (FDE$INVALID_MESSAGE_FORM_NAME=19)
      INTEGER*4 FDE$INVALID_OCCURRENCE
      PARAMETER (FDE$INVALID_OCCURRENCE=20)
      INTEGER*4 FDE$INVALID_CHARACTER_POSITION
      PARAMETER (FDE$INVALID_CHARACTER_POSITION=21)
      INTEGER*4 FDE$INVALID_MODE
      PARAMETER (FDE$INVALID_MODE=22)
      INTEGER*4 FDE$INVALID_STATE
      PARAMETER (FDE$INVALID_STATE=23)
      INTEGER*4 FDE$INVALID_VARIABLE_VALUE
      PARAMETER (FDE$INVALID_VARIABLE_VALUE=24)
      INTEGER*4 FDE$INVALID_OBJECT_NAME
      PARAMETER (FDE$INVALID_OBJECT_NAME=25)
      INTEGER*4 FDE$INVALID_FORM_NAME
      PARAMETER (FDE$INVALID_FORM_NAME=26)
      INTEGER*4 FDE$FORM_CLOSED
      PARAMETER (FDE$FORM_CLOSED=27)
      INTEGER*4 FDE$TOO_MANY_ATTRIBUTES
      PARAMETER (FDE$TOO_MANY_ATTRIBUTES=28)
      INTEGER*4 FDE$INVALID_ATTRIBUTE_NAME
      PARAMETER (FDE$INVALID_ATTRIBUTE_NAME=29)
      INTEGER*4 FDE$TOO_MANY_SCREEN_OCCURRENCE
      PARAMETER (FDE$TOO_MANY_SCREEN_OCCURRENCE=30)
      INTEGER*4 FDE$NO_FORM_DEFINITION
      PARAMETER (FDE$NO_FORM_DEFINITION=31)
      INTEGER*4 FDE$TOO_MANY_STORED_OCCURRENCE
      PARAMETER (FDE$TOO_MANY_STORED_OCCURRENCE=32)
      INTEGER*4 FDE$UNKNOWN_OBJECT_NAME
      PARAMETER (FDE$UNKNOWN_OBJECT_NAME=33)
      INTEGER*4 FDE$NO_DEFINE_OBJECT_NAME
      PARAMETER (FDE$NO_DEFINE_OBJECT_NAME=34)
      INTEGER*4 FDE$INVALID_NAME
      PARAMETER (FDE$INVALID_NAME=35)
      INTEGER*4 FDE$SYSTEM_ERROR
      PARAMETER (FDE$SYSTEM_ERROR=36)
      INTEGER*4 FDE$INVALID_TABLE_NAME
      PARAMETER (FDE$INVALID_TABLE_NAME=37)
      INTEGER*4 FDE$INVALID_VARIABLE_NAME
      PARAMETER (FDE$INVALID_VARIABLE_NAME=38)
      INTEGER*4 FDE$FORM_PUSHED
      PARAMETER (FDE$FORM_PUSHED=39)
      INTEGER*4 FDE$UNKNOWN_TABLE_NAME
      PARAMETER (FDE$UNKNOWN_TABLE_NAME=40)
      INTEGER*4 FDE$NO_VARIABLE_DEFINED
      PARAMETER (FDE$NO_VARIABLE_DEFINED=41)
      INTEGER*4 FDE$NO_FORMS_TO_POP
      PARAMETER (FDE$NO_FORMS_TO_POP=42)
      INTEGER*4 FDE$ONLY_CHARACTER_DATA
      PARAMETER (FDE$ONLY_CHARACTER_DATA=43)
      INTEGER*4 FDE$ONLY_NONCHARACTER_DATA
      PARAMETER (FDE$ONLY_NONCHARACTER_DATA=44)
      INTEGER*4 FDE$FORM_DEFINITION_ERRORS
      PARAMETER (FDE$FORM_DEFINITION_ERRORS=45)
      INTEGER*4 FDE$NO_FORMS_TO_PUSH
      PARAMETER (FDE$NO_FORMS_TO_PUSH=46)
      INTEGER*4 FDE$INVALID_PROGRAM_VALUES
      PARAMETER (FDE$INVALID_PROGRAM_VALUES=47)
      INTEGER*4 FDE$INPUT_HAS_UNKNOWN_VALUE
      PARAMETER (FDE$INPUT_HAS_UNKNOWN_VALUE=48)
      INTEGER*4 FDE$INVALID_INPUT_VALUES
      PARAMETER (FDE$INVALID_INPUT_VALUES=49)
      INTEGER*4 FDE$NOT_AN_INPUT_VARIABLE
      PARAMETER (FDE$NOT_AN_INPUT_VARIABLE=50)
      INTEGER*4 FDE$CURSOR_NOT_IN_FORM
      PARAMETER (FDE$CURSOR_NOT_IN_FORM=51)
      INTEGER*4 FDE$FORM_HAS_NO_VARIABLES
      PARAMETER (FDE$FORM_HAS_NO_VARIABLES=52)
      INTEGER*4 FDE$NO_FORMS_TO_SHOW
      PARAMETER (FDE$NO_FORMS_TO_SHOW=53)
      INTEGER*4 FDE$FORM_NOT_SCHEDULED
      PARAMETER (FDE$FORM_NOT_SCHEDULED=54)
      INTEGER*4 FDE$INVALID_EVENT_NAME
      PARAMETER (FDE$INVALID_EVENT_NAME=55)
      INTEGER*4 FDE$INVALID_X_POSIITON
      PARAMETER (FDE$INVALID_X_POSIITON=56)
      INTEGER*4 FDE$INVALID_Y_POSITION
      PARAMETER (FDE$INVALID_Y_POSITION=57)
      INTEGER*4 FDE$UNKNOWN_EVENT_NAME
      PARAMETER (FDE$UNKNOWN_EVENT_NAME=58)
      INTEGER*4 FDE$INVALID_DECK_NAME
      PARAMETER (FDE$INVALID_DECK_NAME=59)
      INTEGER*4 FDE$INVALID_RECORD_NAME
      PARAMETER (FDE$INVALID_RECORD_NAME=60)
      INTEGER*4 FDE$OBJECT_EXISTS
      PARAMETER (FDE$OBJECT_EXISTS=61)
      INTEGER*4 FDE$TABLE_NAME_EXISTS
      PARAMETER (FDE$TABLE_NAME_EXISTS=62)
      INTEGER*4 FDE$OBJECT_OVERLAYS
      PARAMETER (FDE$OBJECT_OVERLAYS=63)
      INTEGER*4 FDE$TOO_MANY_REALS
      PARAMETER (FDE$TOO_MANY_REALS=64)
      INTEGER*4 FDE$TOO_MANY_STRINGS
      PARAMETER (FDE$TOO_MANY_STRINGS=65)
      INTEGER*4 FDE$NO_OBJECT_AT_POSITION
      PARAMETER (FDE$NO_OBJECT_AT_POSITION=66)
      INTEGER*4 FDE$ARRAY_TOO_SMALL
      PARAMETER (FDE$ARRAY_TOO_SMALL=67)
      INTEGER*4 FDE$STRING_TOO_SMALL
      PARAMETER (FDE$STRING_TOO_SMALL=68)
      INTEGER*4 FDE$VARAIBLE_NAME_EXISTS
      PARAMETER (FDE$VARAIBLE_NAME_EXISTS=69)
      INTEGER*4 FDE$FORM_ALREADY_ADDED
      PARAMETER (FDE$FORM_ALREADY_ADDED=70)
      INTEGER*4 FDE$INVALID_EVENT_ACTIVE
      PARAMETER (FDE$INVALID_EVENT_ACTIVE=72)
      INTEGER*4 FDE$CANNOT_UPDATE_OPENED_FORM
      PARAMETER (FDE$CANNOT_UPDATE_OPENED_FORM=73)
      INTEGER*4 FDE$HELP_FORM_EXISTS
      PARAMETER (FDE$HELP_FORM_EXISTS=74)
      INTEGER*4 FDE$ERROR_FORM_EXISTS
      PARAMETER (FDE$ERROR_FORM_EXISTS=75)
      INTEGER*4 FDE$ERROR_MESSAGE_EXISTS
      PARAMETER (FDE$ERROR_MESSAGE_EXISTS=76)
      INTEGER*4 FDE$HELP_MESSAGE_EXISTS
      PARAMETER (FDE$HELP_MESSAGE_EXISTS=77)
      INTEGER*4 FDE$INVALID_DISPLAY_NAME
      PARAMETER (FDE$INVALID_DISPLAY_NAME=78)
      INTEGER*4 FDE$INVALID_REAL_RANGE
      PARAMETER (FDE$INVALID_REAL_RANGE=79)
      INTEGER*4 FDE$INVALID_INTEGER_RANGE
      PARAMETER (FDE$INVALID_INTEGER_RANGE=80)
      INTEGER*4 FDE$UNKNOWN_INTEGER_RANGE
      PARAMETER (FDE$UNKNOWN_INTEGER_RANGE=81)
      INTEGER*4 FDE$UNKNOWN_REAL_RANGE
      PARAMETER (FDE$UNKNOWN_REAL_RANGE=82)
      INTEGER*4 FDE$UNKNOWN_VALID_STRING
      PARAMETER (FDE$UNKNOWN_VALID_STRING=83)
      INTEGER*4 FDE$DISPLAY_NAME_EXISTS
      PARAMETER (FDE$DISPLAY_NAME_EXISTS=84)
      INTEGER*4 FDE$EVENT_NAME_EXISTS
      PARAMETER (FDE$EVENT_NAME_EXISTS=85)
      INTEGER*4 FDE$UNKNOWN_DISPLAY_NAME
      PARAMETER (FDE$UNKNOWN_DISPLAY_NAME=86)
      INTEGER*4 FDE$TOO_MANY_FORM_NAMES
      PARAMETER (FDE$TOO_MANY_FORM_NAMES=87)
      INTEGER*4 FDE$TOO_MANY_FORM_OBJECTS
      PARAMETER (FDE$TOO_MANY_FORM_OBJECTS=88)
      INTEGER*4 FDE$NO_TEXT_AT_POSITION
      PARAMETER (FDE$NO_TEXT_AT_POSITION=89)
      INTEGER*4 FDE$NO_TEXT_FOR_OBJECT
      PARAMETER (FDE$NO_TEXT_FOR_OBJECT=90)
      INTEGER*4 FDE$UNKNOWN_OCCURRENCE
      PARAMETER (FDE$UNKNOWN_OCCURRENCE=91)
      INTEGER*4 FDE$NO_STRING
      PARAMETER (FDE$NO_STRING=92)
      INTEGER*4 FDE$RANGE_OVERLAP
      PARAMETER (FDE$RANGE_OVERLAP=93)
      INTEGER*4 FDE$NO_COMMENTS_TO_DELETE
      PARAMETER (FDE$NO_COMMENTS_TO_DELETE=94)
      INTEGER*4 FDE$OBJECT_OCCURRENCE_EXISTS
      PARAMETER (FDE$OBJECT_OCCURRENCE_EXISTS=95)
      INTEGER*4 FDE$NO_STRING_SPECIFIED
      PARAMETER (FDE$NO_STRING_SPECIFIED=96)
      INTEGER*4 FDE$VALID_STRING_EXISTS
      PARAMETER (FDE$VALID_STRING_EXISTS=97)
      INTEGER*4 FDE$INVALID_OBJECT_CHANGE
      PARAMETER (FDE$INVALID_OBJECT_CHANGE=98)
      INTEGER*4 FDE$INVALID_ADDRESS
      PARAMETER (FDE$INVALID_ADDRESS=99)
      INTEGER*4 FDE$TERMINAL_NOT_IDENTIFIED
      PARAMETER (FDE$TERMINAL_NOT_IDENTIFIED=100)
      INTEGER*4 FDE$INVALID_FORM_LANGUAGE
      PARAMETER (FDE$INVALID_FORM_LANGUAGE=101)
      INTEGER*4 FDE$INVALID_FORM_AREA_KEY
      PARAMETER (FDE$INVALID_FORM_AREA_KEY=102)
      INTEGER*4 FDE$FORM_NAME_REQUIRED
      PARAMETER (FDE$FORM_NAME_REQUIRED=103)
      INTEGER*4 FDE$NO_FORMS_TO_READ
      PARAMETER (FDE$NO_FORMS_TO_READ=104)
      INTEGER*4 FDE$INVALID_HELP_FORM_NAME
      PARAMETER (FDE$INVALID_HELP_FORM_NAME=105)
      INTEGER*4 FDE$INVALID_ERROR_FORM_NAME
      PARAMETER (FDE$INVALID_ERROR_FORM_NAME=106)
      INTEGER*4 FDE$CREATE_MARK_INVALID
      PARAMETER (FDE$CREATE_MARK_INVALID=107)
      INTEGER*4 FDE$DELETE_MARK_INVALID
      PARAMETER (FDE$DELETE_MARK_INVALID=108)
      INTEGER*4 FDE$NO_MARK_DEFINED
      PARAMETER (FDE$NO_MARK_DEFINED=109)
      INTEGER*4 FDE$AREA_CUTS_OBJECT
      PARAMETER (FDE$AREA_CUTS_OBJECT=110)
      INTEGER*4 FDE$COPY_OUTSIDE_FORM
      PARAMETER (FDE$COPY_OUTSIDE_FORM=111)
      INTEGER*4 FDE$MOVE_OUTSIDE_FORM
      PARAMETER (FDE$MOVE_OUTSIDE_FORM=112)
      INTEGER*4 FDE$INVALID_FORM_ATTRIBUTE
      PARAMETER (FDE$INVALID_FORM_ATTRIBUTE=113)
      INTEGER*4 FDE$INVALID_RECORD_ATTRIBUTE
      PARAMETER (FDE$INVALID_RECORD_ATTRIBUTE=114)
      INTEGER*4 FDE$INVALID_OBJECT_KEY
      PARAMETER (FDE$INVALID_OBJECT_KEY=115)
      INTEGER*4 FDE$INVALID_OBJECT_ATTRIBUTE
      PARAMETER (FDE$INVALID_OBJECT_ATTRIBUTE=116)
      INTEGER*4 FDE$INVALID_TABLE_ATTRIBUTE
      PARAMETER (FDE$INVALID_TABLE_ATTRIBUTE=117)
      INTEGER*4 FDE$PROGRAM_DATA_TYPE
      PARAMETER (FDE$PROGRAM_DATA_TYPE=118)
      INTEGER*4 FDE$INVALID_OUTPUT_FORMAT_KEY
      PARAMETER (FDE$INVALID_OUTPUT_FORMAT_KEY=119)
      INTEGER*4 FDE$INVALID_ERROR_KEY
      PARAMETER (FDE$INVALID_ERROR_KEY=120)
      INTEGER*4 FDE$INVALID_VARIABLE_ATTRIBUTE
      PARAMETER (FDE$INVALID_VARIABLE_ATTRIBUTE=121)
      INTEGER*4 FDE$INVALID_HELP_KEY
      PARAMETER (FDE$INVALID_HELP_KEY=123)
      INTEGER*4 FDE$FEATURE_NOT_IMPLEMENTED
      PARAMETER (FDE$FEATURE_NOT_IMPLEMENTED=124)
      INTEGER*4 FDE$CANNOT_CHANGE_FORM
      PARAMETER (FDE$CANNOT_CHANGE_FORM=125)
      INTEGER*4 FDE$INVALID_RECORD_TYPE
      PARAMETER (FDE$INVALID_RECORD_TYPE=126)
      INTEGER*4 FDE$OBJECT_NOT_IN_FORM
      PARAMETER (FDE$OBJECT_NOT_IN_FORM=127)
      INTEGER*4 FDE$INVALID_FORM_PROCESSOR
      PARAMETER (FDE$INVALID_FORM_PROCESSOR=128)
      INTEGER*4 FDE$INVALID_X_INCREMENT
      PARAMETER (FDE$INVALID_X_INCREMENT=129)
      INTEGER*4 FDE$INVALID_Y_INCREMENT
      PARAMETER (FDE$INVALID_Y_INCREMENT=130)
      INTEGER*4 FDE$FORM_TOO_LARGE_FOR_SCREEN
      PARAMETER (FDE$FORM_TOO_LARGE_FOR_SCREEN=131)
      INTEGER*4 FDE$INVALID_TEXT_PROCESSING
      PARAMETER (FDE$INVALID_TEXT_PROCESSING=132)
      INTEGER*4 FDE$INVALID_DESIGN_FORM
      PARAMETER (FDE$INVALID_DESIGN_FORM=133)
      INTEGER*4 FDE$NO_OBJECT_VAR_DEFINED
      PARAMETER (FDE$NO_OBJECT_VAR_DEFINED=134)
      INTEGER*4 FDE$EVENT_NOT_ASSIGNED
      PARAMETER (FDE$EVENT_NOT_ASSIGNED=135)
      INTEGER*4 FDE$FORM_NOT_ENDED
      PARAMETER (FDE$FORM_NOT_ENDED=136)
      INTEGER*4 FDE$INVALID_EVENT_FORM_NAME
      PARAMETER (FDE$INVALID_EVENT_FORM_NAME=137)
      INTEGER*4 FDE$INVALID_EVENT_FORM_KEY
      PARAMETER (FDE$INVALID_EVENT_FORM_KEY=138)
      INTEGER*4 FDE$FORM_ALREADY_OPEN
      PARAMETER (FDE$FORM_ALREADY_OPEN=139)
      INTEGER*4 FDE$INVALID_EVENT_LABLE
      PARAMETER (FDE$INVALID_EVENT_LABLE=140)
      INTEGER*4 FDE$FORM_NEEDS_CONVERSTION
      PARAMETER (FDE$FORM_NEEDS_CONVERSTION=141)
      INTEGER*4 FDE$NO_EVENTS_ACTIVE
      PARAMETER (FDE$NO_EVENTS_ACTIVE=142)
      INTEGER*4 FDE$DELETE_OUTSIDE_FORM
      PARAMETER (FDE$DELETE_OUTSIDE_FORM=143)
      INTEGER*4 FDE$MARK_OUTSIDE_FORM
      PARAMETER (FDE$MARK_OUTSIDE_FORM=144)
      INTEGER*4 FDE$BAD_DATA_VALUE
      PARAMETER (FDE$BAD_DATA_VALUE=145)
      INTEGER*4 FDE$RECORD_DEFN_NOT_WRITTEN
      PARAMETER (FDE$RECORD_DEFN_NOT_WRITTEN=146)
      INTEGER*4 FDE$WRONG_VARIABLE_TYPE
      PARAMETER (FDE$WRONG_VARIABLE_TYPE=147)
      INTEGER*4 FDE$INVALID_VARIABLE_LENGTH
      PARAMETER (FDE$INVALID_VARIABLE_LENGTH=148)
      INTEGER*4 FDE$EVENT_TRIGGER_EXISTS
      PARAMETER (FDE$EVENT_TRIGGER_EXISTS=149)
      INTEGER*4 FDE$FORM_ALREADY_COMBINED
      PARAMETER (FDE$FORM_ALREADY_COMBINED=150)
      INTEGER*4 FDE$INVALID_TABLE_SIZE
      PARAMETER (FDE$INVALID_TABLE_SIZE=151)
      INTEGER*4 FDE$FORM_NOT_ADDED
      PARAMETER (FDE$FORM_NOT_ADDED=152)
      INTEGER*4 FDE$INVALID_INPUT_FORMAT_KEY
      PARAMETER (FDE$INVALID_INPUT_FORMAT_KEY=153)
      INTEGER*4 FDE$SYSTEM_ERROR_MESSAGE
      PARAMETER (FDE$SYSTEM_ERROR_MESSAGE=154)
      INTEGER*4 FDE$SYSTEM_HELP_MESSAGE
      PARAMETER (FDE$SYSTEM_HELP_MESSAGE=155)
      INTEGER*4 FDE$SYSTEM_BAD_KEY_MESSAGE
      PARAMETER (FDE$SYSTEM_BAD_KEY_MESSAGE=156)
      INTEGER*4 FDE$WIDTH_AND_HEIGHT_REQUIRED
      PARAMETER (FDE$WIDTH_AND_HEIGHT_REQUIRED=157)
      INTEGER*4 FDE$NO_VARIABLE_DEFINITION
      PARAMETER (FDE$NO_VARIABLE_DEFINITION=158)
      INTEGER*4 FDE$NO_TABLE_VARIABLE
      PARAMETER (FDE$NO_TABLE_VARIABLE=159)
      INTEGER*4 FDE$NO_VARIABLE_OBJECT
      PARAMETER (FDE$NO_VARIABLE_OBJECT=160)
      INTEGER*4 FDE$NO_TABLE_OBJECT
      PARAMETER (FDE$NO_TABLE_OBJECT=161)
      INTEGER*4 FDE$UNEQUAL_TBL_OBJ_WIDTH
      PARAMETER (FDE$UNEQUAL_TBL_OBJ_WIDTH=162)
      INTEGER*4 FDE$ERROR_INPUT_CONVERSION
      PARAMETER (FDE$ERROR_INPUT_CONVERSION=163)
      INTEGER*4 FDE$ERROR_OUTPUT_CONVERSION
      PARAMETER (FDE$ERROR_OUTPUT_CONVERSION=164)
      INTEGER*4 FDE$ERROR_INVALID_VALUE
      PARAMETER (FDE$ERROR_INVALID_VALUE=165)
      INTEGER*4 FDE$TERMINAL_TIMED_OUT
      PARAMETER (FDE$TERMINAL_TIMED_OUT=166)
      INTEGER*4 FDE$OBJECT_WIDTH_REQUIRED
      PARAMETER (FDE$OBJECT_WIDTH_REQUIRED=167)
      INTEGER*4 FDE$NO_FORMS_TO_TAB
      PARAMETER (FDE$NO_FORMS_TO_TAB=168)
      INTEGER*4 FDE$COBOL_19_FRACTION_DIGITS
      PARAMETER (FDE$COBOL_19_FRACTION_DIGITS=169)
      INTEGER*4 FDE$COBOL_19_SIG_DIGITS
      PARAMETER (FDE$COBOL_19_SIG_DIGITS=170)
      INTEGER*4 FDE$COBOL_BAD_OVERPUNCH_SIGN
      PARAMETER (FDE$COBOL_BAD_OVERPUNCH_SIGN=171)
      INTEGER*4 FDE$COBOL_BAD_PICTURE
      PARAMETER (FDE$COBOL_BAD_PICTURE=172)
      INTEGER*4 FDE$COBOL_BAD_SEPARATE_SIGN
      PARAMETER (FDE$COBOL_BAD_SEPARATE_SIGN=173)
      INTEGER*4 FDE$COBOL_BINARY_MEANS_NUMERIC
      PARAMETER (FDE$COBOL_BINARY_MEANS_NUMERIC=174)
      INTEGER*4 FDE$COBOL_C_WITHOUT_R
      PARAMETER (FDE$COBOL_C_WITHOUT_R=175)
      INTEGER*4 FDE$COBOL_COMP_1_MEANS_NO_PIC
      PARAMETER (FDE$COBOL_COMP_1_MEANS_NO_PIC=176)
      INTEGER*4 FDE$COBOL_COMP_2_MEANS_NO_PIC
      PARAMETER (FDE$COBOL_COMP_2_MEANS_NO_PIC=177)
      INTEGER*4 FDE$COBOL_CR_DB_MUST_BE_RIGHT
      PARAMETER (FDE$COBOL_CR_DB_MUST_BE_RIGHT=178)
      INTEGER*4 FDE$COBOL_D_WITHOUT_B
      PARAMETER (FDE$COBOL_D_WITHOUT_B=179)
      INTEGER*4 FDE$COBOL_FLOAT_MUST_BE_LEFT
      PARAMETER (FDE$COBOL_FLOAT_MUST_BE_LEFT=180)
      INTEGER*4 FDE$COBOL_FLOAT_TOO_BIG
      PARAMETER (FDE$COBOL_FLOAT_TOO_BIG=181)
      INTEGER*4 FDE$COBOL_FREE_FORM_NOT_DEST
      PARAMETER (FDE$COBOL_FREE_FORM_NOT_DEST=182)
      INTEGER*4 FDE$COBOL_ILLEGAL_CHAR_ENTERED
      PARAMETER (FDE$COBOL_ILLEGAL_CHAR_ENTERED=183)
      INTEGER*4 FDE$COBOL_ILLEGAL_PIC_CHAR
      PARAMETER (FDE$COBOL_ILLEGAL_PIC_CHAR=184)
      INTEGER*4 FDE$COBOL_INSERT_LEFT_OF_FLOAT
      PARAMETER (FDE$COBOL_INSERT_LEFT_OF_FLOAT=185)
      INTEGER*4 FDE$COBOL_ITEM_TOO_BIG
      PARAMETER (FDE$COBOL_ITEM_TOO_BIG=186)
      INTEGER*4 FDE$COBOL_NO_CR_OR_DB_NOW
      PARAMETER (FDE$COBOL_NO_CR_OR_DB_NOW=187)
      INTEGER*4 FDE$COBOL_NO_PLUS_OR_MINUS_NOW
      PARAMETER (FDE$COBOL_NO_PLUS_OR_MINUS_NOW=188)
      INTEGER*4 FDE$COBOL_NO_MULTIPLE_POINTS
      PARAMETER (FDE$COBOL_NO_MULTIPLE_POINTS=189)
      INTEGER*4 FDE$COBOL_NO_REP_AFTER_POINT
      PARAMETER (FDE$COBOL_NO_REP_AFTER_POINT=190)
      INTEGER*4 FDE$COBOL_NO_REP_FOR_CR_DB
      PARAMETER (FDE$COBOL_NO_REP_FOR_CR_DB=191)
      INTEGER*4 FDE$COBOL_NO_SCIENTIFIC
      PARAMETER (FDE$COBOL_NO_SCIENTIFIC=192)
      INTEGER*4 FDE$COBOL_NONBLK_OUTSIDE_PAREN
      PARAMETER (FDE$COBOL_NONBLK_OUTSIDE_PAREN=193)
      INTEGER*4 FDE$COBOL_NONDIGIT_REP_COUNT
      PARAMETER (FDE$COBOL_NONDIGIT_REP_COUNT=194)
      INTEGER*4 FDE$COBOL_NOT_BOTH_V_AND_P
      PARAMETER (FDE$COBOL_NOT_BOTH_V_AND_P=195)
      INTEGER*4 FDE$COBOL_NOT_9P9
      PARAMETER (FDE$COBOL_NOT_9P9=196)
      INTEGER*4 FDE$COBOL_NOT_P9P
      PARAMETER (FDE$COBOL_NOT_P9P=197)
      INTEGER*4 FDE$COBOL_PACKED_MEANS_NUM_PIC
      PARAMETER (FDE$COBOL_PACKED_MEANS_NUM_PIC=198)
      INTEGER*4 FDE$COBOL_RIGHT_FLT_MEANS_ALL
      PARAMETER (FDE$COBOL_RIGHT_FLT_MEANS_ALL=199)
      INTEGER*4 FDE$COBOL_S_MUST_BE_FIRST
      PARAMETER (FDE$COBOL_S_MUST_BE_FIRST=200)
      INTEGER*4 FDE$COBOL_SIGN_NEEDS_S
      PARAMETER (FDE$COBOL_SIGN_NEEDS_S=201)
      INTEGER*4 FDE$COBOL_TOO_MANY_VS
      PARAMETER (FDE$COBOL_TOO_MANY_VS=202)
      INTEGER*4 FDE$COBOL_TRAILING_SIGN_NONBLK
      PARAMETER (FDE$COBOL_TRAILING_SIGN_NONBLK=203)
      INTEGER*4 FDE$COBOL_TWO_POINTS_ENTERED
      PARAMETER (FDE$COBOL_TWO_POINTS_ENTERED=204)
      INTEGER*4 FDE$COBOL_TWO_FLOATING
      PARAMETER (FDE$COBOL_TWO_FLOATING=205)
      INTEGER*4 FDE$COBOL_TWO_SIGNS
      PARAMETER (FDE$COBOL_TWO_SIGNS=206)
      INTEGER*4 FDE$COBOL_TWO_SIGNS_ENTERED
      PARAMETER (FDE$COBOL_TWO_SIGNS_ENTERED=207)
      INTEGER*4 FDE$COBOL_UNBAL_PARENS
      PARAMETER (FDE$COBOL_UNBAL_PARENS=208)
      INTEGER*4 FDE$COBOL_UNKNOWN_USAGE
      PARAMETER (FDE$COBOL_UNKNOWN_USAGE=209)
      INTEGER*4 FDE$COBOL_WRONG_SIGN_VS_USAGE
      PARAMETER (FDE$COBOL_WRONG_SIGN_VS_USAGE=210)
      INTEGER*4 FDE$COBOL_USAGE_SIZE_TOO_BIG
      PARAMETER (FDE$COBOL_USAGE_SIZE_TOO_BIG=211)
      INTEGER*4 FDE$TOO_MANY_FRACTION_DIGITS
      PARAMETER (FDE$TOO_MANY_FRACTION_DIGITS=213)
      INTEGER*4 FDE$TOO_MANY_SIGNIFICANT_DIGITS
      PARAMETER (FDE$TOO_MANY_SIGNIFICANT_DIGITS=214)
      INTEGER*4 FDE$INVALID_PICTURE
      PARAMETER (FDE$INVALID_PICTURE=215)
      INTEGER*4 FDE$BINARY_REQUIRES_NUMERIC
      PARAMETER (FDE$BINARY_REQUIRES_NUMERIC=216)
      INTEGER*4 FDE$PICTURE_INVALID_FOR_COMP_1
      PARAMETER (FDE$PICTURE_INVALID_FOR_COMP_1=217)
      INTEGER*4 FDE$PICTURE_INVALID_FOR_COMP_2
      PARAMETER (FDE$PICTURE_INVALID_FOR_COMP_2=218)
      INTEGER*4 FDE$CR_DB_MUST_BE_RIGHTMOST
      PARAMETER (FDE$CR_DB_MUST_BE_RIGHTMOST=219)
      INTEGER*4 FDE$FLOATING_SYMBOLS_INVALID
      PARAMETER (FDE$FLOATING_SYMBOLS_INVALID=220)
      INTEGER*4 FDE$INVALID_PICTURE_CHARACTER
      PARAMETER (FDE$INVALID_PICTURE_CHARACTER=221)
      INTEGER*4 FDE$INSERTION_SYMBOLS_INVALID
      PARAMETER (FDE$INSERTION_SYMBOLS_INVALID=222)
      INTEGER*4 FDE$PICTURE_ITEM_TOO_BIG
      PARAMETER (FDE$PICTURE_ITEM_TOO_BIG=223)
      INTEGER*4 FDE$TOO_MANY_DECIMAL_POINTS
      PARAMETER (FDE$TOO_MANY_DECIMAL_POINTS=224)
      INTEGER*4 FDE$NO_REPETITION_AFTER_POINT
      PARAMETER (FDE$NO_REPETITION_AFTER_POINT=225)
      INTEGER*4 FDE$NO_REPETITION_FOR_CR_DB
      PARAMETER (FDE$NO_REPETITION_FOR_CR_DB=226)
      INTEGER*4 FDE$NONDIGIT_REPETITION
      PARAMETER (FDE$NONDIGIT_REPETITION=227)
      INTEGER*4 FDE$V_AND_P_INVALID
      PARAMETER (FDE$V_AND_P_INVALID=228)
      INTEGER*4 FDE$P_BETWEEN_9_INVALID
      PARAMETER (FDE$P_BETWEEN_9_INVALID=229)
      INTEGER*4 FDE$9_BETWEEN_P_INVALID
      PARAMETER (FDE$9_BETWEEN_P_INVALID=230)
      INTEGER*4 FDE$PACKED_REQUIRES_NUMERIC
      PARAMETER (FDE$PACKED_REQUIRES_NUMERIC=231)
      INTEGER*4 FDE$INVALID_RIGHT_FLOATING
      PARAMETER (FDE$INVALID_RIGHT_FLOATING=232)
      INTEGER*4 FDE$S_MUST_BE_FIRST
      PARAMETER (FDE$S_MUST_BE_FIRST=233)
      INTEGER*4 FDE$PICTURE_REQUIRES_SIGN
      PARAMETER (FDE$PICTURE_REQUIRES_SIGN=234)
      INTEGER*4 FDE$TOO_MANY_VS
      PARAMETER (FDE$TOO_MANY_VS=235)
      INTEGER*4 FDE$TOO_MANY_FLOATING_SYMBOLS
      PARAMETER (FDE$TOO_MANY_FLOATING_SYMBOLS=236)
      INTEGER*4 FDE$TOO_MANY_SIGN_SYMBOLS
      PARAMETER (FDE$TOO_MANY_SIGN_SYMBOLS=237)
      INTEGER*4 FDE$UNBALANCED_PARENTHESES
      PARAMETER (FDE$UNBALANCED_PARENTHESES=238)
      INTEGER*4 FDE$INVALID_USAGE
      PARAMETER (FDE$INVALID_USAGE=239)
      INTEGER*4 FDE$INVALID_SIGN_FOR_USAGE
      PARAMETER (FDE$INVALID_SIGN_FOR_USAGE=240)
      INTEGER*4 FDE$INPUT_FORMAT_INVALID_COBOL
      PARAMETER (FDE$INPUT_FORMAT_INVALID_COBOL=241)
      INTEGER*4 FDE$OUTPUT_FORMAT_INVALID_COBOL
      PARAMETER (FDE$OUTPUT_FORMAT_INVALID_COBOL=242)
      INTEGER*4 FDE$UNEXPECTED_CALL_TO
      PARAMETER (FDE$UNEXPECTED_CALL_TO=243)
      INTEGER*4 FDE$FORM_NOT_DISPLAYED
      PARAMETER (FDE$FORM_NOT_DISPLAYED=244)
      INTEGER*4 FDE$COBOL_INVALID_MANAGE_FORM
      PARAMETER (FDE$COBOL_INVALID_MANAGE_FORM=245)
      INTEGER*4 FDE$INVALID_COBOL_DATA_TYPE
      PARAMETER (FDE$INVALID_COBOL_DATA_TYPE=246)
      INTEGER*4 FDE$INVALID_COBOL_CATEGORY
      PARAMETER (FDE$INVALID_COBOL_CATEGORY=247)
      INTEGER*4 FDE$COBOL_DESTINATION_INVALID
      PARAMETER (FDE$COBOL_DESTINATION_INVALID=248)
      INTEGER*4 FDE$COBOL_SOURCE_INVALID
      PARAMETER (FDE$COBOL_SOURCE_INVALID=249)
      INTEGER*4 FDE$OBJECT_SIZE_COBOL_MISMATCH
      PARAMETER (FDE$OBJECT_SIZE_COBOL_MISMATCH=250)
      INTEGER*4 FDE$INCOMPATIBLE_DISPLAY_CLAUSE
      PARAMETER (FDE$INCOMPATIBLE_DISPLAY_CLAUSE=251)
      INTEGER*4 FDE$INCOMPATIABLE_PROGRAM_CLAUS
      PARAMETER (FDE$INCOMPATIABLE_PROGRAM_CLAUS=252)
      INTEGER*4 FDE$B_INVALID_FOR_PICTURE
      PARAMETER (FDE$B_INVALID_FOR_PICTURE=253)
      INTEGER*4 FDE$COBOL_TOO_MANY_DIGITS
      PARAMETER (FDE$COBOL_TOO_MANY_DIGITS=254)
      INTEGER*4 FDE$TOO_MANY_DIGITS
      PARAMETER (FDE$TOO_MANY_DIGITS=255)
      INTEGER*4 FDE$COBOL_P_NOT_SUPPORTED
      PARAMETER (FDE$COBOL_P_NOT_SUPPORTED=256)
      INTEGER*4 FDE$P_INVALID_FOR_PICTURE
      PARAMETER (FDE$P_INVALID_FOR_PICTURE=257)
*DECK DECK=FDE$FORTRAN_VARIABLE_STATUS EXPAND=FALSE
      INTEGER*4 FDE$NO_ERROR
      PARAMETER (FDE$NO_ERROR=0)
      INTEGER*4 FDE$INVALID_STRING
      PARAMETER (FDE$INVALID_STRING=1)
      INTEGER*4 FDE$INVALID_REAL
      PARAMETER (FDE$INVALID_REAL=2)
      INTEGER*4 FDE$INVALID_INTEGER
      PARAMETER (FDE$INVALID_INTEGER=3)
      INTEGER*4 FDE$UNKNOWN_USER_VALUE
      PARAMETER (FDE$UNKNOWN_USER_VALUE=4)
      INTEGER*4 FDE$INVALID_BDP_DATA
      PARAMETER (FDE$INVALID_BDP_DATA=5)
      INTEGER*4 FDE$NO_DIGITS
      PARAMETER (FDE$NO_DIGITS=6)
      INTEGER*4 FDE$LOSS_OF_SIGNIFICANCE
      PARAMETER (FDE$LOSS_OF_SIGNIFICANCE=7)
      INTEGER*4 FDE$VARIABLE_NOT_FILLED
      PARAMETER (FDE$VARIABLE_NOT_FILLED=8)
      INTEGER*4 FDE$OVERFLOW
      PARAMETER (FDE$OVERFLOW=9)
      INTEGER*4 FDE$UNDERFLOW
      PARAMETER (FDE$UNDERFLOW=10)
      INTEGER*4 FDE$INDEFINITE
      PARAMETER (FDE$INDEFINITE=11)
      INTEGER*4 FDE$INFINITE
      PARAMETER (FDE$INFINITE=12)
      INTEGER*4 FDE$VARIABLE_NOT_ENTERED
      PARAMETER (FDE$VARIABLE_NOT_ENTERED=13)
      INTEGER*4 FDE$OUTPUT_FORMAT_BAD
      PARAMETER (FDE$OUTPUT_FORMAT_BAD=14)
      INTEGER*4 FDE$VARIABLE_TRUNCATED
      PARAMETER (FDE$VARIABLE_TRUNCATED=15)
      INTEGER*4 FDE$GR_18_DIGITS
      PARAMETER (FDE$GR_18_DIGITS=16)
      INTEGER*4 FDE$INVALID_OVERPUNCH_SIGN
      PARAMETER (FDE$INVALID_OVERPUNCH_SIGN=17)
      INTEGER*4 FDE$INVALID_SEPARATE_SIGN
      PARAMETER (FDE$INVALID_SEPARATE_SIGN=18)
      INTEGER*4 FDE$C_WITHOUT_R
      PARAMETER (FDE$C_WITHOUT_R=19)
      INTEGER*4 FDE$D_WITHOUT_B
      PARAMETER (FDE$D_WITHOUT_B=20)
      INTEGER*4 FDE$FLOATING_NUMBER_TOO_BIG
      PARAMETER (FDE$FLOATING_NUMBER_TOO_BIG=21)
      INTEGER*4 FDE$INVALID_CHARACTER_ENTERED
      PARAMETER (FDE$INVALID_CHARACTER_ENTERED=22)
      INTEGER*4 FDE$NO_CR_OR_DB_NOW
      PARAMETER (FDE$NO_CR_OR_DB_NOW=23)
      INTEGER*4 FDE$NO_PLUS_OR_MINUS_NOW
      PARAMETER (FDE$NO_PLUS_OR_MINUS_NOW=24)
      INTEGER*4 FDE$NO_SCIENTIFIC_NOTATION
      PARAMETER (FDE$NO_SCIENTIFIC_NOTATION=25)
      INTEGER*4 FDE$NONBLK_OUTSIDE_PARENTHESES
      PARAMETER (FDE$NONBLK_OUTSIDE_PARENTHESES=26)
      INTEGER*4 FDE$NONBLK_AFTER_TRAILING_SIGN
      PARAMETER (FDE$NONBLK_AFTER_TRAILING_SIGN=27)
      INTEGER*4 FDE$TOO_MANY_DECIMALS
      PARAMETER (FDE$TOO_MANY_DECIMALS=28)
      INTEGER*4 FDE$TOO_MANY_SIGNS
      PARAMETER (FDE$TOO_MANY_SIGNS=29)
*DECK DECK=FDE$PASCAL_PROCEDURE_STATUS EXPAND=FALSE
  CONST
    fde$call_successful = 0;
    fde$terminal_disconnected = 1;
    fde$no_input_request = 2;
    fde$cursor_not_in_variable = 3;
    fde$more_errors_exist = 4;
    fde$unknown_form_name = 5;
    fde$form_compilation_errors = 6;
    fde$no_space_available = 7;
    fde$unsupported_terminal = 8;
    fde$invalid_form_identifier = 9;
    fde$invalid_user_entry = 10;
    fde$unknown_variable_name = 11;
    fde$too_many_integers = 12;
    fde$object_name_exists = 13;
    fde$work_area_invalid = 14;
    fde$invalid_x_form_position = 15;
    fde$invalid_y_form_position = 16;
    fde$invalid_width = 17;
    fde$invalid_height = 18;
    fde$invalid_message_form_name = 19;
    fde$invalid_occurrence = 20;
    fde$invalid_character_position = 21;
    fde$invalid_mode = 22;
    fde$invalid_state = 23;
    fde$invalid_variable_value = 24;
    fde$invalid_object_name = 25;
    fde$invalid_form_name = 26;
    fde$form_closed = 27;
    fde$too_many_attributes = 28;
    fde$invalid_attribute_name = 29;
    fde$too_many_screen_occurrence = 30;
    fde$no_form_definition = 31;
    fde$too_many_stored_occurrence = 32;
    fde$unknown_object_name = 33;
    fde$no_define_object_name = 34;
    fde$invalid_name = 35;
    fde$system_error = 36;
    fde$invalid_table_name = 37;
    fde$invalid_variable_name = 38;
    fde$form_pushed = 39;
    fde$unknown_table_name = 40;
    fde$no_table_variable_defined = 41;
    fde$no_forms_to_pop = 42;
    fde$only_character_data = 43;
    fde$only_noncharacter_data = 44;
    fde$form_definition_errors = 45;
    fde$no_forms_to_push = 46;
    fde$invalid_program_values = 47;
    fde$input_has_unknown_value = 48;
    fde$invalid_input_values = 49;
    fde$not_an_input_variable = 50;
    fde$cursor_not_in_form = 51;
    fde$form_has_no_variables = 52;
    fde$no_forms_to_show = 53;
    fde$form_not_scheduled = 54;
    fde$invalid_event_name = 55;
    fde$invalid_x_position = 56;
    fde$invalid_y_position = 57;
    fde$unknown_event_name = 58;
    fde$invalid_deck_name = 59;
    fde$invalid_record_name = 60;
    fde$object_exists = 61;
    fde$table_name_exists = 62;
    fde$object_overlays = 63;
    fde$too_many_reals = 64;
    fde$too_many_strings = 65;
    fde$no_object_at_position = 66;
    fde$array_too_small = 67;
    fde$string_too_small = 68;
    fde$variable_name_exists = 69;
    fde$form_already_added = 70;
    fde$invalid_event_active = 72;
    fde$cannot_update_opened_form = 73;
    fde$help_form_exists = 74;
    fde$error_form_exists = 75;
    fde$error_message_exists = 76;
    fde$help_message_exists = 77;
    fde$invalid_display_name = 78;
    fde$invalid_real_range = 79;
    fde$invalid_integer_range = 80;
    fde$unknown_integer_range = 81;
    fde$unknown_real_range = 82;
    fde$unknown_valid_string = 83;
    fde$display_name_exists = 84;
    fde$event_name_exists = 85;
    fde$unknown_display_name = 86;
    fde$too_many_form_names = 87;
    fde$too_many_form_objects = 88;
    fde$no_text_at_position = 89;
    fde$no_text_for_object = 90;
    fde$unknown_occurrence = 91;
    fde$no_string = 92;
    fde$range_overlap = 93;
    fde$no_comments_to_delete = 94;
    fde$object_occurrence_exists = 95;
    fde$no_string_specified = 96;
    fde$valid_string_exists = 97;
    fde$invalid_object_change = 98;
    fde$invalid_address = 99;
    fde$terminal_not_identified = 100;
    fde$invalid_form_language = 101;
    fde$invalid_form_area_key = 102;
    fde$form_name_required = 103;
    fde$no_forms_to_read = 104;
    fde$invalid_help_form_name = 105;
    fde$invalid_error_form_name = 106;
    fde$create_mark_invalid = 107;
    fde$delete_mark_invalid = 108;
    fde$no_mark_defined = 109;
    fde$area_cuts_object = 110;
    fde$copy_outside_form = 111;
    fde$move_outside_form = 112;
    fde$invalid_form_attribute = 113;
    fde$invalid_record_attribute = 114;
    fde$invalid_object_key = 115;
    fde$invalid_object_attribute = 116;
    fde$invalid_table_attribute = 117;
    fde$program_data_type = 118;
    fde$invalid_output_format_key = 119;
    fde$invalid_error_key = 120;
    fde$invalid_variable_attribute = 121;
    fde$invalid_help_key = 123;
    fde$feature_not_implemented = 124;
    fde$cannot_change_form = 125;
    fde$invalid_record_type = 126;
    fde$object_not_in_form  = 127;
    fde$invalid_form_processor = 128;
    fde$invalid_x_increment = 129;
    fde$invalid_y_increment = 130;
    fde$form_too_large_for_screen = 131;
    fde$invalid_text_processing = 132;
    fde$invalid_design_form = 133;
    fde$no_object_variable_defined = 134;
    fde$event_not_assigned = 135;
    fde$form_not_ended = 136;
    fde$invalid_event_form_name = 137;
    fde$invalid_event_form_key = 138;
    fde$form_already_open = 139;
    fde$invalid_event_label = 140;
    fde$form_requires_conversion = 141;
    fde$no_events_active = 142;
    fde$delete_outside_form = 143;
    fde$mark_outside_form = 144;
    fde$bad_data_value = 145;
    fde$record_defn_not_written = 146;
    fde$wrong_variable_type = 147;
    fde$invalid_variable_length = 148;
    fde$event_trigger_exists = 149;
    fde$form_already_combined = 150;
    fde$invalid_table_size = 151;
    fde$form_not_added = 152;
    fde$invalid_input_format_key = 153;
    fde$system_error_message = 154;
    fde$system_help_message = 155;
    fde$system_bad_key_message = 156;
    fde$width_and_height_required = 157;
    fde$no_variable_definiton = 158;
    fde$no_table_variable = 159;
    fde$no_variable_object = 160;
    fde$no_table_object = 161;
    fde$unequal_tbl_obj_width = 162;
    fde$error_input_conversion = 163;
    fde$error_output_conversion  = 164;
    fde$error_invalid_value = 165;
    fde$terminal_timed_out = 166;
    fde$object_width_required = 167;
    fde$no_forms_to_tab = 168;
    fde$cobol_19_fraction_digits = 169;
    fde$cobol_19_sig_digits = 170;
    fde$cobol_bad_overpunch_sign = 171;
    fde$cobol_bad_picture = 172;
    fde$cobol_bad_separate_sign  = 173;
    fde$cobol_binary_means_numeric = 174;
    fde$cobol_c_without_r = 175;
    fde$cobol_comp_1_means_no_pic = 176;
    fde$cobol_comp_2_means_no_pic = 177;
    fde$cobol_CR_DB_must_be_right = 178;
    fde$cobol_d_without_b = 179;
    fde$cobol_float_must_be_left = 180;
    fde$cobol_float_too_big = 181;
    fde$cobol_free_form_not_dest = 182;
    fde$cobol_illegal_char_entered = 183;
    fde$cobol_illegal_pic_char = 184;
    fde$cobol_insert_left_of_float = 185;
    fde$cobol_item_too_big = 186;
    fde$cobol_no_cr_or_db_now = 187;
    fde$cobol_no_plus_or_minus_now = 188;
    fde$cobol_no_multiple_points = 189;
    fde$cobol_no_rep_after_point = 190;
    fde$cobol_no_rep_for_cr_db = 191;
    fde$cobol_no_scientific = 192;
    fde$cobol_nonblk_outside_paren = 193;
    fde$cobol_nondigit_rep_count = 194;
    fde$cobol_not_both_v_and_p = 195;
    fde$cobol_not_9p9 = 196;
    fde$cobol_not_p9p = 197;
    fde$cobol_packed_means_num_pic = 198;
    fde$cobol_right_flt_means_all = 199;
    fde$cobol_s_must_be_first = 200;
    fde$cobol_sign_needs_s = 201;
    fde$cobol_too_many_vs  = 202;
    fde$cobol_trailing_sign_nonblk = 203;
    fde$cobol_two_points_entered = 204;
    fde$cobol_two_floating = 205;
    fde$cobol_two_signs = 206;
    fde$cobol_two_signs_entered = 207;
    fde$cobol_unbal_parens = 208;
    fde$cobol_unknown_usage = 209;
    fde$cobol_wrong_sign_vs_usage = 210;
    fde$cobol_usage_size_too_big = 211;
    fde$too_many_fraction_digits = 213;
    fde$too_many_significant_digits = 214;
    fde$invalid_picture = 215;
    fde$binary_requires_numeric = 216;
    fde$picture_invalid_for_comp_1 = 217;
    fde$picture_invalid_for_comp_2 = 218;
    fde$CR_DB_must_be_rightmost = 219;
    fde$floating_symbols_invalid  = 220;
    fde$invalid_picture_character = 221;
    fde$insertion_symbols_invalid = 222;
    fde$picture_item_too_big = 223;
    fde$too_many_decimal_points = 224;
    fde$no_repetition_after_point = 225;
    fde$no_repetition_for_cr_db = 226;
    fde$nondigit_repetition = 227;
    fde$v_and_p_invalid  = 228;
    fde$p_between_9_invalid = 229;
    fde$9_between_p_invalid = 230;
    fde$packed_requires_numeric = 231;
    fde$invalid_right_floating = 232;
    fde$s_must_be_first = 233;
    fde$picture_requires_sign = 234;
    fde$too_many_vs = 235;
    fde$too_many_floating_symbols  = 236;
    fde$too_many_sign_symbols = 237;
    fde$unbalanced_parentheses = 238;
    fde$invalid_usage = 239;
    fde$invalid_sign_for_usage = 240;
    fde$input_format_invalid_cobol = 241;
    fde$output_format_invalid_cobol = 242;
    fde$unexpected_call_to = 243;
    fde$form_not_displayed = 244;
    fde$cobol_invalid_manage_form = 245;
    fde$invalid_cobol_data_type = 246;
    fde$invalid_cobol_category = 247;
    fde$cobol_destination_invalid = 248;
    fde$cobol_source_invalid = 249;
    fde$object_size_cobol_mismatch = 250;
    fde$incompatible_display_clause = 251;
    fde$incompatible_program_clause = 252;
    fde$b_invalid_for_picture = 253;
    fde$cobol_too_many_digits = 254;
    fde$too_many_digits = 255;
    fde$cobol_p_not_supported = 256;
    fde$p_invalid_for_picture = 257;
*DECK DECK=FDH$ADD_FORM EXPAND=FALSE
{
{   The purpose of this request is to add a form to the list of forms
{ scheduled for display on the screen.  The next request that updates the
{ screen, fdp$read_forms or fdp$show_forms, replots the screen for the
{ terminal user.  The form lies on top of other forms occupying the same area
{ on the screen.  You cannot add a pushed form.
{
{       FDP$ADD_FORM (FORM_IDENTIFIER, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form to add to the
{       list of forms scheduled for display.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of request.
{
{       condition identifiers:  fde$bad_data_value
{                               fde$form_already_added
{                               fde$form_pushed
{                               fde$form_too_large_for_screen
{                               fde$invalid_form_identifier
{                               fde$no_space_available
{                               fde$system_error
{
*DECK DECK=FDH$ADD_OBJECT_TO_FORM_IMAGE EXPAND=FALSE
{   The purpose of this request is to add an object to the character image of
{ of the form.  The character image of the form is used to check for collisions
{ of objects.
{
{       FDP$ADD_OBJECT_TO_FORM_IMAGE (P_FORM_IMAGE, P_FORM_OBJECT_DEFINITION)
{
{       P_FORM_IMAGE: (input)  A pointer to the character image of the form.
{
{      P_FORM_OBJECT_DEFINITION: (input)  A pointer to the object to be added
{            to the image of the form.
{
*DECK DECK=FDH$BEGIN_CREATE_FORM_MODULE EXPAND=FALSE
{    The purpose of this request is to begin the CREATE_FORM_MODULE utility.
{
{       FDP$BEGIN_CREATE_FORM_MODULE (FORM_NAME, FORM_IDENTIFIER,
{             CREATE_MODULE, STATUS);
{
{ FORM_NAME: (input)  This parameter specifies the name of the form.
{
{ FORM_IDENTIFIER: (output)  This parameter specifies the form identifier that
{       following requests will use to access the form.
{
{ CREATE_MODULE: (output)  This parameter specifies whether or not the user
{       wants to create the form.  If CREATE_MODULE is TRUE, the user wants to
{       create the form.  If CREATE_MODULE is FALSE, the user does not want to
{       create the form.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of request.
{       CONDITIONS:
{             fde$form_not_ended
{             fde$no_space_available
{             fde$system_error
{
{
*DECK DECK=FDH$CHANGE_CURRENCY_SYMBOLS EXPAND=FALSE
{
{   The purpose of this request is to change the symbols used to format
{ currency for COBOL PICTURE clauses.
{
{       FDP$CHANGE_CURRENCY_SYMBOLS (PRIMARY_MONEY_SYMBOL,
{         SECONDARY_MONEY_SYMBOL, THOUSANDS_SEPARATOR_SYMBOL, DECIMAL_SYMBOL)
{
{ PRIMARY_MONEY_SYMBOL: (input)  This parameter specifies the primary symbol
{       used for money.  For example, the dollar symbol ($).
{
{ SECONDARY_MONEY_SYMBOL: (input)  This parameter specifies the secondard
{       symbol used for money.  For example, the pound symbol (#).
{
{ THOUSANDS_SEPARATOR_SYMBOL: (input)  This parameter specifies the symbol used
{       for thousands.  For example, the comma symbol (,).
{
{ DECIMAL_SYMBOL: (input)  This parameter specifies the symbol used for decimal
{       point.  For example, the period symbol (.).
{
*DECK DECK=FDH$CHANGE_FORM EXPAND=FALSE
{
{   The purpose of this request is to change the attributes that apply to the
{ entire form.
{
{       FDP$CHANGE_FORM (FORM_IDENTIFIER, FORM_ATTRIBUTES, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ FORM_ATTRIBUTES: (input/output)  This parameter specifies an array of form
{       attributes.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$display_name_exists
{                              fde$event_name_exists
{                              fde$event_trigger_exists
{                              fde$invalid_address
{                              fde$invalid_display_name
{                              fde$invalid_event_form_key
{                              fde$invalid_event_form_name
{                              fde$invalid_event_name
{                              fde$invalid_form_area_key
{                              fde$invalid_form_attribute
{                              fde$invalid_form_identifier
{                              fde$invalid_form_language
{                              fde$invalid_form_name
{                              fde$invalid_form_processor
{                              fde$invalid_height
{                              fde$invalid_help_form_name
{                              fde$invalid_help_key
{                              fde$invalid_message_form_name
{                              fde$invalid_variable_name
{                              fde$invalid_width
{                              fde$invalid_x_position
{                              fde$invalid_y_position
{                              fde$no_comments_to_delete
{                              fde$no_space_available
{                              fde$system_error
{                              fde$unknown_display_name
{                              fde$unknown_event_name
{

*DECK DECK=FDH$CHANGE_FORM_RECORD EXPAND=FALSE
{
{   The purpose of this request is to change the record definition used to
{ transfer data between the program and Screen Formatting.
{
{       FDP$CHANGE_FORM_RECORD (FORM_IDENTIFIER, RECORD_ATTRIBUTES, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ RECORD_ATTRIBUTES:  (input/output) This parameter specifies an array of
{       attributes for the record.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$cannot_change_form
{                              fde$invalid_deck_name
{                              fde$invalid_form_identifier
{                              fde$invalid_record_attribute
{                              fde$invalid_record_name
{                              fde$invalid_table_name
{                              fde$system_error
{                              fde$unknown_table_name
{
*DECK DECK=FDH$CHANGE_OBJECT EXPAND=FALSE
{
{   The purpose of this request is to change the attributes of an object.
{
{       FDP$CHANGE_OBJECT (FORM_IDENTIFIER, X_POSITION, Y_POSITION,
{         OBJECT_ATTRIBUTES, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ X_POSITION: (input)  This parameter specifies the x position of the object
{       relative to the form.
{
{ Y_POSITION: (input)  This parameter specifies the y position of the object
{       relative to the form.
{
{ OBJECT_ATTRIBUTES: (input/output)  This parameter specifies an array of object
{       attributes.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$cannot_change_form
{                              fde$invalid_address
{                              fde$invalid_form_identifier
{                              fde$invalid_height
{                              fde$invalid_object_attribute
{                              fde$invalid_object_change
{                              fde$invalid_object_key
{                              fde$invalid_object_name
{                              fde$invalid_occurrence
{                              fde$object_occurrence_exists
{                              fde$invalid_text_processing
{                              fde$invalid_width
{                              fde$invalid_x_increment
{                              fde$invalid_x_position
{                              fde$invalid_y_increment
{                              fde$invalid_y_position
{                              fde$no_text_for_object
{                              fde$no_space_available
{                              fde$object_not_in_form
{                              fde$object_overlays
{                              fde$system_error
{
*DECK DECK=FDH$CHANGE_SCREEN EXPAND=FALSE
{   The purpose of this request is to send data to the Screen Manager to change
{ the terminal screen.
{
{       FDP$CHANGE_SCREEN ( STATUS)
{
{ STATUS: (output)  This parameter specifies the status.
{
{       condition identifiers:  fde$system_error
{                               fde$terminal_disconnected
{                               fde$terminal_not_identified
{
*DECK DECK=FDH$CHANGE_STORED_OBJECT EXPAND=FALSE
{
{   The purpose of this request is to change the attributes of a stored
{ object.  A stored object has no object on the form image.
{
{       FDP$CHANGE_STORED_OBJECT (FORM_IDENTIFIER, NAME, OCCURRENCE, TEXT,
{         DISPLAY_ATTRIBUTE_SET, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ NAME: (input)  This parameter specifies the name of the stored object.
{
{ OCCURRENCE: (input)  This parameter specifies the occurrence of the stored
{       object.
{
{ TEXT: (input)  This parameter specifies the initial value for the stored
{       object.
{
{ DISPLAY_ATTRIBUTE_SET: (input)  This parameter specifies the display
{       attributes of stored object when it is initially displayed.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$cannot_change_form
{                              fde$invalid_form_identifier
{                              fde$invalid_object_name
{                              fde$invalid_occurrence
{                              fde$no_space_available
{                              fde$unknown_object_name
{
*DECK DECK=FDH$CHANGE_TABLE EXPAND=FALSE
{
{   The purpose of this request is to change the attributes of a table.
{
{       FDP$CHANGE_TABLE (FORM_IDENTIFIER, TABLE_NAME, TABLE_ATTRIBUTES,
{         STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ TABLE_NAME: (input)  This parameter specifies the name of the table.
{
{ TABLE_ATTRIBUTES:  (input/output) This parameter specifies an array of table
{       attributes.
{
{ STATUS: (output) This parameter specifies  the name of the variable to set to
{        indicate the status of the request.
{
{       condition identifiers:  fde$bad_data_value
{                               fde$cannot_change_form
{                               fde$invalid_form_identifier
{                               fde$invalid_occurrence
{                               fde$invalid_table_attribute
{                               fde$invalid_table_name
{                               fde$invalid_variable_name
{                               fde$no_space_available
{                               fde$table_name_exists
{                               fde$system_error
{                               fde$unknown_table_name
{                               fde$unknown_variable_name
{                               fde$variable_name_exists
{
*DECK DECK=FDH$CHANGE_TABLE_SIZE EXPAND=FALSE
{   The purpose of this request is to change the size of table while a terminal
{ user interacts with a form.
{
{       FDP$CHANGE_TABLE_SIZE (FORM_IDENTIFIER, TABLE_NAME, TABLE_SIZE,
{         STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the base form.
{
{ TABLE_NAME: (input)  This parameter specifies the name of the table.
{
{ TABLE_SIZE: (input)  This parameter specifies the size of the size of table.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of request.
{
{       condition identifiers:  fde$bad_data_value
{                               fde$form_pushed
{                               fde$invalid_form_identifier
{                               fde$invalid_table_size
{                               fde$unknown_table_name
{

*DECK DECK=FDH$CHANGE_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to change the attributes for a variable.
{
{       FDP$CHANGE_VARIABLE (FORM_IDENTIFIER, VARIABLE_NAME,
{         VARIABLE_ATTRIBUTES, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ VARIABLE_NAME: (input)  This parameter specifies the name of the variable.
{
{ VARIABLE_ATTRIBUTES:  (input/output) This parameter specifies an array of
{       variable attributes.
{
{ STATUS: (output) This parameter specifies the status record.
{
{       condition identifiers: fde$9_between_p_invalid
{                              fde$bad_data_value
{                              fde$binary_requires_numeric
{                              fde$cannot_change_form
{                              fde$cr_db_must_be_rightmost
{                              fde$floating_symbols_invalid
{                              fde$insertion_symbols_invalid
{                              fde$invalid_address
{                              fde$invalid_error_form_name
{                              fde$invalid_error_key
{                              fde$invalid_form_identifier
{                              fde$invalid_form_name
{                              fde$invalid_picture_character
{                              fde$invalid_right_floating
{                              fde$invalid_help_form_name
{                              fde$invalid_help_key
{                              fde$invalid_integer_range
{                              fde$invalid_output_format_key
{                              fde$invalid_picture
{                              fde$invalid_real_range
{                              fde$invalid_sign_for_usage
{                              fde$invalid_usage
{                              fde$invalid_variable_attribute
{                              fde$invalid_variable_length
{                              fde$invalid_variable_name
{                              fde$no_comments_to_delete
{                              fde$no_repetition_after_point
{                              fde$no_repetition_for_cr_db
{                              fde$no_space_available
{                              fde$no_string_specified
{                              fde$nondigit_repetition
{                              fde$p_between_9_invalid
{                              fde$packed_requires_numeric
{                              fde$picture_item_too_big
{                              fde$picture_invalid_for_comp_1
{                              fde$picture_invalid_for_comp_2
{                              fde$picture_requires_sign
{                              fde$program_data_type
{                              fde$range_overlap
{                              fde$s_must_be_first
{                              fde$system_error
{                              fde$too_many_decimal_points
{                              fde$too_many_digits
{                              fde$too_many_floating_symbols
{                              fde$too_many_sign_symbols
{                              fde$too_many_vs
{                              fde$unbalanced_parentheses
{                              fde$unknown_integer_range
{                              fde$unknown_real_range
{                              fde$unknown_valid_string
{                              fde$unknown_variable_name
{                              fde$v_and_p_invalid
{                              fde$valid_string_exists
{                              fde$variable_name_exists




*DECK DECK=FDH$CHECK_FOR_OVERLAYED_OBJECTS EXPAND=FALSE
{
{   The purpose of this request is to check if a new object overlays a current
{ object on the form.
{
{       FDP$CHECK_FOR_OVERLAYED_OBJECTS (P_FORM_IMAGE, NAME,
{         P_FORM_DEFINITION, FORM_NAME, STATUS)
{
{ P_FORM_IMAGE: (input)  This parameter specifies the character array for the
{       form.
{
{ P_FORM_DEFINITION: (input)  This parameter specifies the form definition.
{
{ FORM_NAME: (input)  This parameter specifies the name of the form.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$object_overlays
{
*DECK DECK=FDH$CHECK_OBJECT_INSIDE_FORM EXPAND=FALSE
{   The purpose of this request is to verify that an object lies inside the
{ form.
{
{       FDP$CHECK_OBJECT_INSIDE_FORM (FORM_AREA, P_FORM_OBJECT_DEFINITION,
{         FORM_NAME, STATUS)
{
{ FORM_AREA: (input)  This parameter specifies the area of the form.
{
{ P_FORM_OBJECT_DEFINITION: (input)  This parameter specifices the form object
{       to be check if it resides inside the form.
{
{ FORM_NAME: (input)  This parameter specifies the name of the form.
{
{ STATUS: (output)  This parameter specifies the status.
{
{       condition identifiers:  fde$object_not_in_form
{

*DECK DECK=FDH$CLOSE_FORM EXPAND=FALSE
{
{   The purpose of this request is to release the system resources needed to
{ process a form.  The request also deletes the form from the list of forms
{ scheduled for display.  If the form is displayed when you use this request,
{ the next request that updates the screen, fdp$show_forms or fdp$read_forms,
{ will remove the form.  A form that is currently pushed cannot be closed.
{
{       FDP$CLOSE_FORM (FORM_IDENTIFIER, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form to close from
{       the list of forms.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition_identifiers:  fde$bad_data_value
{                               fde$form_pushed
{                               fde$invalid_form_identifier
{                               fde$no_space_available
{
*DECK DECK=FDH$COMBINE_FORM EXPAND=FALSE
{
{   The purpose of this request is to combine a form to the list of forms
{ associated with a base form.  The next request that updates the screen,
{ fdp$read_forms or fdp$show_forms, replots the screen for the terminal user.
{ The form lies on top of other forms occupying the same area on the screen.
{ You cannot combine a pushed form.
{
{       FDP$COMBINE_FORM (ADDED_FORM_IDENTIFIER, COMBINE_FORM_IDENTIFIER,
{         STATUS)
{
{ ADDED_FORM_IDENTIFIER: (input)  This parameter specifies the base form.
{
{ COMBINE_FORM_IDENTIFIER: (input)  This parameter specifies the new form to
{       combine with the base form.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of request.
{
{       condition identifiers:  fde$bad_data_value
{                               fde$form_already_added
{                               fde$form_already_combined
{                               fde$form_pushed
{                               fde$form_too_large_for_screen
{                               fde$invalid_form_identifier
{                               fde$no_space_available
{                               fde$system_error
{
*DECK DECK=FDH$COMBINE_FORM_EVENTS EXPAND=FALSE
{
{   The purpose of this request is to combine a form to the list of forms
{ associated with a base form.  The events of combined form are merged with of
{ the added form.  If the same event occurs for both forms the event definition
{ for the combined form is used.  If an event for the combined form has no
{ definition for the added form, the event is added to the events recognized by
{ Screen Formatting.  If the event is added, the event menu is not updated.
{ The next request that updates the screen, fdp$read_forms or fdp$show_forms,
{ replots the screen for the terminal user.  The form lies on top of other
{ forms occupying the same area on the screen.  You cannot combine a pushed
{ form.
{
{       FDP$COMBINE_FORM_EVENTS (ADDED_FORM_IDENTIFIER,
{         COMBINE_FORM_IDENTIFIER, STATUS)
{
{ ADDED_FORM_IDENTIFIER: (input)  This parameter specifies the base form.
{
{ COMBINE_FORM_IDENTIFIER: (input)  This parameter specifies the new form to
{       combine with the base form.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of request.
{
{       condition identifiers:  fde$bad_data_value
{                               fde$form_already_added
{                               fde$form_already_combined
{                               fde$form_pushed
{                               fde$form_too_large_for_screen
{                               fde$invalid_form_identifier
{                               fde$no_space_available
{                               fde$system_error
{
*DECK DECK=FDH$CONVERT_TERMINAL_STATUS EXPAND=FALSE
{
{   The purpose of this request is to convert terminal status to
{   Screen Formatting status.
{
{       FDP$CONVERT_TERMINAL_STATUS (TERMINAL_STATUS, NEW_STATUS)
{
{ TERMINAL_STATUS: (input) This parameter specifies the terminal
{       status.
{
{ NEW_STATUS: (input) This parameter specifies the Screen
{       Formatting status.
{
{       condition identifiers: fde$system_error
{                              fde$terminal_disconnected
{                              fde$terminal_not_identified
{
*DECK DECK=FDH$CONVERT_TO_PROGRAM_VALUE EXPAND=FALSE
{
{   The purpose of this request is to convert a screen value to a program
{ value.
{
{       FDP$CONVERT_TO_PROGRAM_VALUE (FORM_IDENTIFIER, VARIABLE_NAME, P_TEXT,
{         VARIABLE_VALUE, VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  The form identifier.
{
{ VARIABLE_NAME: (input)  The name of the variable to convert.
{
{ P_TEXT: (input)  A pointer to the text from the terminal screen.
{
{ VARIABLE_VALUE: (output)  The program value.
{
{
{ VARIABLE_STATUS: (output)  This parameter specifies the status of the
{       variable.
{
{       value:  fdc$no_error
{               fdc$invalid_bdp_data
{               fdc$invalid_integer
{               fdc$invalid_real
{               fdc$overflow fdc$loss_of_significance
{               fdc$gr_18_right_of_point
{               fdc$gr_18_left_of_point
{               fdc$too_many_decimal_points
{               fdc$floating_number_too_big
{               fdc$invalid_overpunch_sign
{               fdc$invalid_separate_sign
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$feature_not_implemented
{
*DECK DECK=FDH$CONVERT_TO_PROGRAM_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to convert a screen variable to a program
{ variable.
{
{       FDP$CONVERT_TO_PROGRAM_VARIABLE (PROGRAM_DATA_TYPE, P_PROGRAM_VARIABLE,
{         PROGRAM_VARIABLE_LENGTH, INPUT_FORMAT, P_SCREEN_VARIABLE,
{         SCREEN_VARIABLE_LENGTH, VARIABLE_STATUS, STATUS)
{
{ PROGRAM_DATA_TYPE: (input)  The program data type.
{
{ P_PROGRAM_VARIABLE: (output)  A pointer to store the program variable.
{
{ PROGRAM_VARIABLE_LENGTH: (input)  The length of the program variable data.
{
{ INPUT_FORMAT: (input)  The format of the character screen variable data.
{
{ P_SCREEN_VARIABLE: (input)  A pointer to the character screen variable
{       data.
{
{ SCREEN_VARIABLE_LENGTH: (input)  The length of the screen variable data.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the status of the
{       variable.
{
{       fdc$no_error
{       fdc$invalid_bdp_data
{       fdc$invalid_integer
{       fdc$invalid_real
{       fdc$overflow
{       fdc$loss_of_significance
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$feature_not_implemented
{
*DECK DECK=FDH$CONVERT_TO_SCREEN_VALUE EXPAND=FALSE
{
{   The purpose of this request is to convert a program value to a terminal
{ screen value.
{
{       FDP$CONVERT_TO_SCREEN_VALUE (FORM_IDENTIFIER, VARIABLE_NAME,
{         VARIABLE_VALUE, P_TEXT, VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  The form identifier.
{
{ VARIABLE_NAME: (input)  The name of the variable to convert to a screen
{       value.
{
{ VARIABLE_VALUE: (input)  The value to convert to a screen value.
{
{ P_TEXT: (output)  A pointer to a string to receive the text from the terminal
{       screen.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the status of the
{       variable.
{
{       value:  fdc$no_error
{               fdc$invalid_bdp_data
{               fdc$invalid_integer
{               fdc$invalid_real
{               fdc$overflow
{               fdc$loss_of_significance
{               fdc$gr_18_right_of_point
{               fdc$gr_18_left_of_point
{               fdc$too_many_decimal_points
{               fdc$floating_number_too_big
{               fdc$invalid_overpunch_sign
{               fdc$invalid_separate_sign
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$feature_not_implemented
{
*DECK DECK=FDH$CONVERT_TO_SCREEN_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to convert a program variable to a screen
{ variable.
{
{       FDP$CONVERT_TO_SCREEN_VARIABLE (PROGRAM_DATA_TYPE, P_PROGRAM_VARIABLE,
{         PROGRAM_VARIABLE_LENGTH, OUTPUT_FORMAT, P_SCREEN_VARIABLE,
{         SCREEN_VARIABLE_LENGTH, VARIABLE_STATUS, STATUS)
{
{ PROGRAM_DATA_TYPE: (input)  The program data type.
{
{ P_PROGRAM_VARIABLE: (input)  A pointer to the program variable.
{
{ PROGRAM_VARIABLE_LENGTH: (input)  The length of the program variable data.
{
{ OUTPUT_FORMAT: (input)  The format of the character screen variable data.
{
{ P_SCREEN_VARIABLE: (input)  A pointer to store the character screen variable
{       data.
{
{ SCREEN_VARIABLE_LENGTH: (input)  The length of the screen variable data.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the status of the
{       variable.
{
{       fdc$no_error
{       fdc$invalid_bdp_data
{       fdc$no_digits
{       fdc$overflow
{       fdc$loss_of_significance
{       fdc$infinite fdc$indefinite
{       fdc$output_format_bad
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{
*DECK DECK=FDH$CONVERT_YYMMDD_TO_DATE_TIME EXPAND=FALSE
{
{   This request converts an integer representation of a date in YYMMDD form
{   to a date/time value.
{
{       FDP$CONVERT_YYMMDD_TO_DATE_TIME (YYMMDD, DATE_TIME, VARIABLE_STATUS)
{
{ YYMMDD: (input)  This parameter specifies the integer date to be
{            converted.  It must be in YYMMDD format.
{
{ DATE_TIME: (output)  This parameter specifies the resulting date/time value.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the status of the
{       value.
{
{       value:  fdc$no_error
{               fdc$invalid_integer
*DECK DECK=FDH$COPY_AREA EXPAND=FALSE
{
{   The purpose of this request is to copy all objects and unprotected text on
{ a form from one area to another area.  A design form has both objects
{ (protected text, line drawings) and unprotected text.  A target form has
{ only objects.
{
{       FDP$COPY_AREA (FORM_IDENTIFIER, FROM_X_POSITION, FROM_Y_POSITION,
{         WIDTH, HEIGHT, TO_X_POSITION, TO_Y_POSITION, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier of
{       the form.
{
{ FROM_X_POSITION: (input)  This parameter specifies the source x position of
{       the origin of the area closing the data to be copied.  The x position
{       is with respect to the form.  The origin of the area is the upper left
{       corner.
{
{ FROM_Y_POSITION: (input)  This parameter specifies the source y position of
{       the origin of the area enclosing the data to be copied.  The y
{       position is with respect to the form.  The origin of the area is the
{       upper left corner.
{
{ WIDTH: (input)  This parameter specifies the width of the area.
{
{ HEIGHT: (input)  This parameter specifies the height of the area.
{
{ TO_X_POSITION: (input)  The x position of the destination area.
{
{ TO_Y_POSITION: (input)  The y position of the destination area.
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$area_cuts_object
{                              fde$bad_data_value
{                              fde$copy_outside_form
{                              fde$invalid_form_identifier
{                              fde$no_space_available
{                              fde$system_error
{
*DECK DECK=FDH$COPY_FORM EXPAND=FALSE
{
{   The purpose of this request is to copy a form.  The copied form may then
{ be modified after a fdp$edit_form request is issued.  The form that is to be
{ copied may have resulted from a fdp$create_form request or a fdp$open_form
{ request.  This request assigns a new form identifier to the copied form.
{
{       FDH$COPY_FORM (FROM_FORM_IDENTIFIER, TO_FORM_IDENTIFIER, STATUS)
{
{ FROM_FORM_IDENTIFIER: (input)  This parameter specifies the form identifier
{       of the form to be copied.
{
{ TO_FORM_IDENTIFIER: (output)  This parameter specifies the form identifier
{       that Screen Formatting assigns to the copied form.
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$invalid_form_identifier
{                              fde$no_space_available
{                              fde$system_error
{
*DECK DECK=FDH$CREATE_COBOL_DESCRIPTION EXPAND=FALSE
{
{   The purpose of this request is to create a COBOL description for use by
{ FDP$MOVE_COBOL_DATA.
{
{       FDP$CREATE_COBOL_DESCRIPTION ( COBOL_PICTURE_SYMBOLS,
{         COBOL_USAGE_KEYWORD, DESTINATION, STATUS )
{
{ COBOL_PICTURE_SYMBOLS: (input)  This parameter contains the characters
{       comprising the PICTURE, followed by a blank character.
{
{ COBOL_USAGE_KEYWORD: (input)  This parameter corresponds to the COBOL USAGE
{       clause.
{
{ DESTINATION: (output)  This parameter will be set to the description of the
{       item, so that FDP$MOVE_COBOL_DATA can use it to move data.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             fde$cobol_bad_picture
{             fde$cobol_binary_means_numeric
{             fde$cobol_comp_1_means_no_pic
{             fde$cobol_comp_2_means_no_pic
{             fde$cobol_cr_db_must_be_right
{             fde$cobol_packed_means_num_pic
{             fde$cobol_float_must_be_left
{             fde$cobol_illegal_pic_char
{             fde$cobol_insert_left_of_float
{             fde$cobol_item_too_big
{             fde$cobol_nondigit_rep_count
{             fde$cobol_not_9p9
{             fde$cobol_not_both_v_and_p
{             fde$cobol_not_p9p
{             fde$cobol_no_multiple_points
{             fde$cobol_no_rep_after_point
{             fde$cobol_no_rep_for_cr_db
{             fde$cobol_right_flt_means_all
{             fde$cobol_sign_needs_s
{             fde$cobol_s_must_be_first
{             fde$cobol_too_many_digits
{             fde$cobol_too_many_vs
{             fde$cobol_two_floating
{             fde$cobol_two_signs
{             fde$cobol_unbal_parens
{             fde$cobol_unknown_usage
{             fde$cobol_wrong_sign_vs_usage
{
{
*DECK DECK=FDH$CREATE_CONSTANT_TEXT EXPAND=FALSE
{
{   The purpose of this request is to create constant text objects for a
{ target form using the unprotected text on the design form.  These objects
{ have no display attributes.
{
{       FDP$CREATE_CONSTANT_TEXT (DESIGN_FORM_IDENTIFIER,
{         TARGET_FORM_IDENTIFIER, STATUS)
{
{ DESIGN_FORM_IDENTIFIER: (input)  This parameter specifies the form
{       identifier of a design form that Screen Formatting should use to
{       create constant text objects from unprotected text.
{
{ TARGET_FORM_IDENTIFIER: (input)  This parameter specifies the form
{       identifier of a target form where Screen Formatting should store the
{       constant text objects.
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{      indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$cannot_change_form
{                              fde$invalid_form_identifier
{                              fde$invalid_height
{                              fde$invalid_object_attribute
{                              fde$invalid_object_change
{                              fde$invalid_object_key
{                              fde$invalid_object_name
{                              fde$invalid_occurrence
{                              fde$invalid_text_processing
{                              fde$invalid_width
{                              fde$invalid_x_increment
{                              fde$invalid_x_position
{                              fde$invalid_y_increment
{                              fde$invalid_y_position
{                              fde$no_space_available
{                              fde$no_text_for_object
{                              fde$object_not_in_form
{                              fde$object_occurrence_exists
{                              fde$object_overlays
{                              fde$system_error
{
*DECK DECK=FDH$CREATE_DESIGN_FORM EXPAND=FALSE
{
{   The purpose of this request is to create a form for interactively
{ designing other forms.
{
{ This request does not require a fdp$end_form request to signal the end
{ of the definition as does the fdp$create_form request.  After a
{ fdp$create_design_form request you may use other Screen Formatting requests
{ such as fdp$read_forms and fdp$show_forms.  The request creates a table and
{ a variable for the design form so that the fdp$get_string_variable and
{ fdp$replace_string_variable requests can access text on the form.  The
{ variable has a program character type and allows both terminal input and
{ output.  The variable character field width will be the width of the form.
{ The table will have as many occurrences
{ as the height of the form.  You may create constant objects and line drawing
{ objects at any time on the design form.  You cannot create any variable
{ objects.
{
{       FDP$CREATE_DESIGN_FORM (FORM_IDENTIFIER, FORM_ATTRIBUTES, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier that
{       Screen Formatting returns to identify the instance of the form.  Other
{       requests use this form identifier to refer to the form.
{
{ FORM_ATTRIBUTES: (input/output)  This parameter specifies an array of
{       attributes that apply to entire form.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{        to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$display_name_exists
{                              fde$event_name_exists
{                              fde$invalid_address
{                              fde$invalid_display_name
{                              fde$invalid_event_name
{                              fde$invalid_form_area_key
{                              fde$invalid_form_identifier
{                              fde$invalid_form_language
{                              fde$invalid_form_name
{                              fde$no_comments_to_delete
{                              fde$no_space_available
{                              fde$system_error
{                              fde$terminal_disconnected
{                              fde$terminal_not_identified
{                              fde$unknown_display_name
{                              fde$unknown_event_name
{
*DECK DECK=FDH$CREATE_DESIGN_TEXT EXPAND=FALSE
{
{   The purpose of this request is to create protected and unprotected text on
{ the design form from objects defined on the target form.  All constant text
{ objects without attributes on the target form are deleted.  Constant text
{ objects with attributes on the target form are created as objects on the
{ design form.  You re-create these deleted constant text objects on the target
{ form when the terminal user finishes changing the form using the
{ fdp$create_constant_text request.
{
{       FDP$CREATE_DESIGN_TEXT (TARGET_FORM_IDENTIFIER,
{         DESIGN_FORM_IDENTIFIER, STATUS)
{
{ TARGET_FORM_IDENTIFIER: (input)  This parameter specifies the target form
{       identifier to use as the source of the text for the design form.
{
{ DESIGN_FORM_IDENTIFIER: (input)  This parameter specifies the form
{       identifier of the design form.
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$invalid_form_identifier
{                              fde$no_space_available
{                              fde$invalid_design_form
{                              fde$cannot_change_form
{                              fde$system_error
{                              fde$no_text_for_object
{                              fde$object_occurrence_exists
{                              fde$bad_data_value
{                              fde$invalid_x_position
{                              fde$invalid_y_position
{                              fde$invalid_width
{                              fde$invalid_height
{                              fde$invalid_x_increment
{                              fde$invalid_y_increment
{                              fde$invalid_text_processing
{                              fde$object_not_in_form
{                              fde$object_overlays
{                              fde$invalid_object_change
{                              fde$invalid_object_key
{                              fde$invalid_object_name
{                              fde$invalid_occurrence
{                              fde$invalid_object_attribute
{                              fde$no_object_at_position
{
*DECK DECK=FDH$CREATE_EVENT_FORM EXPAND=FALSE
{
{   The purpose of this request is to create a form for displaying program
{ events.  The form you create may be displayed, saved for later display, or
{ displayed and saved for later display.  This requests ends the form
{ definition.  After this request, you may use other Screen Formatting
{ requests such as fdp$open_form, fdp$add_form, and fdp$read_forms.  The
{ form_identifier returned by this request identifies the form.
{
{       FDP$CREATE_EVENT_FORM (EVENT_MENUS, FORM_ATTRIBUTES, FORM_IDENTIFIER,
{         STATUS)
{
{ EVENT_MENUS: (input)  An array of records that describe events to be shown
{       on the event form.  Each record contains the following fields.
{
{       EVENT_NAME:  The event name that the program uses to recognize the
{             event.  It is also the name of the variable the program may use
{             to change display attribute or event label value.
{
{       EVENT_LABEL:  The initial value for event_name.
{
{       EVENT_TRIGGER:  The event trigger (function key) on the terminal that
{             causes the event.
{
{ FORM_ATTRIBUTES:  (input/output) This parameter specifies an array of
{       attributes that apply to entire form.
{
{ FORM_IDENTIFIER: (output)  This parameter specifies the form_identifier that
{       Screen Formatting returns to identify the instance of the form.  Other
{       requests use this form identifier to refer to the form.
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$display_name_exists
{                              fde$event_name_exists
{                              fde$invalid_address
{                              fde$invalid_display_name
{                              fde$invalid_event_form_key
{                              fde$invalid_event_form_name
{                              fde$invalid_event_name
{                              fde$invalid_form_area_key
{                              fde$invalid_form_attribute
{                              fde$invalid_form_identifier
{                              fde$invalid_form_language
{                              fde$invalid_form_name
{                              fde$invalid_form_processor
{                              fde$invalid_height
{                              fde$invalid_help_form_name
{                              fde$invalid_help_key
{                              fde$invalid_message_form_name
{                              fde$invalid_variable_name
{                              fde$invalid_width
{                              fde$invalid_x_position
{                              fde$invalid_y_position
{                              fde$no_comments_to_delete
{                              fde$no_space_available
{                              fde$system_error
{                              fde$terminal_not_identified
{                              fde$unknown_display_name
{                              fde$unknown_event_name
{
{
*DECK DECK=FDH$CREATE_FORM EXPAND=FALSE
{
{   The purpose of this request is to create a form.  The form you create may
{ be displayed, saved for later display, or displayed and saved for later
{ display.  After doing a
{ fdp$end_form request, you may use other Screen Formatting requests such as
{ fdp$open_form, fdp$add_form, and fdp$read_forms. The form_identifier
{ returned by this
{ request identifies the form.
{
{   You save the form with the fdp$write_form_definition request.
{
{       FDP$CREATE_FORM (FORM_IDENTIFIER, FORM_ATTRIBUTES, STATUS)
{
{ FORM_IDENTIFIER: (output)  This parameter specifies the form_identifier that
{       Screen Formatting returns to identify the instance of the form.  Other
{       requests use this form identifier to refer to the form.
{
{ FORM_ATTRIBUTES: (input/output)  This parameter specifies an array of
{ attributes
{       that apply to entire form.
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$display_name_exists
{                              fde$event_name_exists
{                              fde$event_trigger_exists
{                              fde$invalid_address
{                              fde$invalid_display_name
{                              fde$invalid_event_form_key
{                              fde$invalid_event_form_name
{                              fde$invalid_event_name
{                              fde$invalid_form_area_key
{                              fde$invalid_form_attribute
{                              fde$invalid_form_identifier
{                              fde$invalid_form_language
{                              fde$invalid_form_name
{                              fde$invalid_form_processor
{                              fde$invalid_height
{                              fde$invalid_help_form_name
{                              fde$invalid_help_key
{                              fde$invalid_message_form_name
{                              fde$invalid_variable_name
{                              fde$invalid_width
{                              fde$invalid_x_position
{                              fde$invalid_y_position
{                              fde$no_comments_to_delete
{                              fde$no_space_available
{                              fde$system_error
{                              fde$unknown_display_name
{                              fde$unknown_event_name
{
*DECK DECK=FDH$CREATE_FORM_EVENTS EXPAND=FALSE
{   The purpose of this request is to create events for a form.
{
{       FDP$CREATE_FORM_EVENTS (FORM_IDENTIFIER, DISPLAY_ATTRIBUTE_SET, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifer.
{
{ DISPLAY_ATTRIBUTE_SET: (input)  This parameter specifies the display
{       attribute set for the form.
{
{ STATUS: (output)  This parameter specifies the status.
{
{       condition identifiers:  fde$system_error
{                               fde$terminal_disconnected
{                               fde$terminal_not_identified
{
*DECK DECK=FDH$CREATE_FORM_STATUS EXPAND=FALSE
{
{   The purpose of this request is to create form status.  Form status
{ contains information that changes during use of the form.
{
{       FDP$CREATE_FORM_STATUS (FORM_IDENTIFIER, P_FORM_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (output)  This parameter specifies the form_identifier
{       assigned by the request.
{
{ P_FORM_STATUS: (output)  This parameter specifies the pointer to the form
{       status assigned by the request.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$no_space_available
{
*DECK DECK=FDH$CREATE_MARK EXPAND=FALSE
{
{   The purpose of this request is to create a distinctive display attribute
{ for a specified text area.  The display attribute marks text that the
{ terminal user wants to perform some operation upon.  Screen Formatting
{ chooses a display attribute that is appropriate for the terminal.  This
{ request may only be issued on a design form.
{
{       FDP$CREATE_MARK (FORM_IDENTIFIER, START_X_POSITION, START_Y_POSITION,
{         END_X_POSITION, END_Y_POSITION, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier.
{
{ START_X_POSITION: (input)  This parameter specifies the form x position to
{       start the mark.  The first character of a line is numbered 1.  Each
{       character position in the line going from left to right increments the
{       x position by 1.
{
{ START_Y_POSITION: (input)  This parameter specifies the form y position to
{       start the mark.  The top most line of the form is numbered 1.  Each
{       line going from top to bottom of the form line increments the y
{       position by 1.
{
{ END_X_POSITION: (input)  This parameter specifies the end x position to
{       mark.  The starting and ending positions may be the same.
{
{ END_Y_POSITION: (input)  This parameter specifies the end y position to
{       mark.  The starting and ending positions may be the same.
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$area_cuts_object
{                              fde$bad_data_value
{                              fde$create_mark_invalid
{                              fde$form_not_scheduled
{                              fde$form_pushed
{                              fde$invalid_form_identifier
{                              fde$mark_outside_form
{                              fde$no_space_available
{                              fde$system_error
{
*DECK DECK=FDH$CREATE_MESSAGE_FORM EXPAND=FALSE
{
{   The purpose of this request is to create a form for displaying messages.
{
{       FDP$CREATE_MESSAGE_FORM (FORM_IDENTIFIER, STATUS)
{
{ FORM_IDENTIFIER: (output)  This parameter specifies the form_identifier that
{       Screen Formatting returns to identify the instance of the form.  Other
{       requests use this form identifier to refer to the form.
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$display_name_exists
{                              fde$event_name_exists
{                              fde$invalid_address
{                              fde$invalid_display_name
{                              fde$invalid_event_form_key
{                              fde$invalid_event_form_name
{                              fde$invalid_event_name
{                              fde$invalid_form_area_key
{                              fde$invalid_form_attribute
{                              fde$invalid_form_identifier
{                              fde$invalid_form_language
{                              fde$invalid_form_name
{                              fde$invalid_form_processor
{                              fde$invalid_height
{                              fde$invalid_help_form_name
{                              fde$invalid_help_key
{                              fde$invalid_message_form_name
{                              fde$invalid_variable_name
{                              fde$invalid_width
{                              fde$invalid_x_position
{                              fde$invalid_y_position
{                              fde$no_comments_to_delete
{                              fde$no_space_available
{                              fde$system_error
{                              fde$terminal_not_identified
{                              fde$unknown_display_name
{                              fde$unknown_event_name
{
{
*DECK DECK=FDH$CREATE_OBJECT EXPAND=FALSE
{
{   The purpose of this request is to create an object on the form image.  The
{ object may be a line drawing, a box drawing, constant text, or variable
{ text.  The text may occupy a portion of a single line or occupy a
{ rectangular area on the form.  Text that occupies a rectangular area is
{ called a text box.  A text box may be used to display on the terminal screen
{ only a part of the data.  A text box allows clipping and wrapping of data to
{ fit the visual area of the box.  The data in the box may be scrolled to see
{ or enter more data.  The origin of a box box drawing or text box) is the
{ upper left corner.  The origin of a line is the upper left point of the
{ line.  The origin of a text line is the left most character of the text.
{ You may give name and display attributes to the object.  Programs may
{ manipulate the object using the name.  The name also associates a variable
{ text object with its variable definition.
{
{       FDP$CREATE_OBJECT (FORM_IDENTIFIER, X_POSITION, Y_POSITION,
{         OBJECT_DEFINITION, OBJECT_ATTRIBUTES, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ X_POSITION: (input)  This parameter specifies the x coordinate for the
{       origin of the object.
{
{ Y_POSITION: (input)  This parameter specifies the y coordinate for the
{       origin of the object.
{
{ OBJECT_DEFINITION: (input)  This parameter specifies the definition of the
{       object.  This is a record with a key field specifying the type of
{       object.
{
{ OBJECT_ATTRIBUTES: (input/output)  This parameter specifies an array of
{       attributes for the object.
{
{ STATUS: (output) This parameter specifies the name of the variable
{       to set to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$cannot_change_form
{                              fde$invalid_address
{                              fde$invalid_form_identifier
{                              fde$invalid_height
{                              fde$invalid_object_attribute
{                              fde$invalid_object_change
{                              fde$invalid_object_key
{                              fde$invalid_object_name
{                              fde$invalid_occurrence
{                              fde$object_occurrence_exists
{                              fde$invalid_text_processing
{                              fde$invalid_width
{                              fde$invalid_x_increment
{                              fde$invalid_x_position
{                              fde$invalid_y_increment
{                              fde$invalid_y_position
{                              fde$no_text_for_object
{                              fde$no_space_available
{                              fde$object_not_in_form
{                              fde$object_overlays
{                              fde$system_error
{
*DECK DECK=FDH$CREATE_STORED_OBJECT EXPAND=FALSE
{
{   The purpose of this request is to create a stored object.  A stored object
{ has no object on the form image.
{
{       FDP$CREATE_STORED_OBJECT (FORM_IDENTIFIER, NAME, OCCURRENCE, TEXT,
{         DISPLAY_ATTRIBUTE_SET, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ NAME: (input)  This parameter specifies the name of the stored object.
{
{ OCCURRENCE: (input)  This parameter specifies the occurrence of the stored
{       object.
{
{ TEXT: (input)  This parameter specifies the initial value for the stored
{       object.
{
{ DISPLAY_ATTRIBUTE_SET: (input)  This parameter specifies the display
{       attributes of stored object when it is initially displayed.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$cannot_change_form
{                              fde$invalid_form_identifier
{                              fde$invalid_object_name
{                              fde$invalid_occurrence
{                              fde$object_occurrence_exists
{                              fde$no_space_available
{
{
*DECK DECK=FDH$CREATE_TABLE EXPAND=FALSE
{
{   The purpose of this request is to create a table of variables.  The
{ variables that are members of the table may have more than 1 occurrence.
{
{       FDP$CREATE_TABLE (FORM_IDENTIFIER, TABLE_NAME, TABLE_ATTRIBUTES,
{         STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ TABLE_NAME: (input)  This parameter specifies the name of the table.
{
{ TABLE_ATTRIBUTES:  (input/output) This parameter specifies the attributes of
{       the table.
{
{ STATUS: (output) This parameter specifies the name of the variable to
{       set to indicate the status of the request.
{
{       condition identifiers:  fde$bad_data_value
{                               fde$cannot_change_form
{                               fde$invalid_form_identifier
{                               fde$invalid_occurrence
{                               fde$invalid_table_attribute
{                               fde$invalid_table_name
{                               fde$invalid_variable_name
{                               fde$no_space_available
{                               fde$table_name_exists
{                               fde$system_error
{                               fde$unknown_table_name
{                               fde$unknown_variable_name
{                               fde$variable_name_exists
{
*DECK DECK=FDH$CREATE_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to create a variable.
{
{       FDP$CREATE_VARIABLE (FORM_IDENTIFIER, VARIABLE_NAME,
{         VARIABLE_ATTRIBUTES, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ VARIABLE_NAME: (input)  This parameter specifies the name for the variable.
{       The name must follow the language conventions for the program that
{       will use the form.
{
{ VARIABLE_ATTRIBUTES:  (input/output) This parameter specifies an array of
{       attributes for a variable.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$9_between_p_invalid
{                              fde$bad_data_value
{                              fde$binary_requires_numeric
{                              fde$cannot_change_form
{                              fde$cr_db_must_be_rightmost
{                              fde$floating_symbols_invalid
{                              fde$insertion_symbols_invalid
{                              fde$invalid_address
{                              fde$invalid_error_form_name
{                              fde$invalid_error_key
{                              fde$invalid_form_identifier
{                              fde$invalid_form_name
{                              fde$invalid_picture_character
{                              fde$invalid_right_floating
{                              fde$invalid_help_form_name
{                              fde$invalid_help_key
{                              fde$invalid_integer_range
{                              fde$invalid_output_format_key
{                              fde$invalid_picture
{                              fde$invalid_real_range
{                              fde$invalid_sign_for_usage
{                              fde$invalid_usage
{                              fde$invalid_variable_attribute
{                              fde$invalid_variable_length
{                              fde$invalid_variable_name
{                              fde$no_comments_to_delete
{                              fde$no_repetition_after_point
{                              fde$no_repetition_for_cr_db
{                              fde$no_space_available
{                              fde$no_string_specified
{                              fde$nondigit_repetition
{                              fde$p_between_9_invalid
{                              fde$packed_requires_numeric
{                              fde$picture_item_too_big
{                              fde$picture_invalid_for_comp_1
{                              fde$picture_invalid_for_comp_2
{                              fde$picture_requires_sign
{                              fde$program_data_type
{                              fde$range_overlap
{                              fde$s_must_be_first
{                              fde$system_error
{                              fde$too_many_decimal_points
{                              fde$too_many_digits
{                              fde$too_many_floating_symbols
{                              fde$too_many_sign_symbols
{                              fde$too_many_vs
{                              fde$unbalanced_parentheses
{                              fde$unknown_integer_range
{                              fde$unknown_real_range
{                              fde$unknown_valid_string
{                              fde$v_and_p_invalid
{                              fde$valid_string_exists
{                              fde$variable_name_exists



*DECK DECK=FDH$DELETE_AREA EXPAND=FALSE
{
{   The purpose of this request is to delete all objects and unprotected text on
{ a form area.  A design form has both objects
{ (protected text, line drawings) and unprotected text.  A target form has
{ only objects.
{
{       FDP$DELETE_AREA (FORM_IDENTIFIER, X_POSITION, Y_POSITION,
{         WIDTH, HEIGHT, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier of
{       the form.
{
{ X_POSITION: (input)  This parameter specifies the source x position of
{       the origin of the area closing the data to be deleted.  The x position
{       is with respect to the form.  The origin of the area is the upper left
{       corner.
{
{ Y_POSITION: (input)  This parameter specifies the source y position of
{       the origin of the area enclosing the data to be deleted.  The y
{       position is with respect to the form.  The origin of the area is the
{       upper left corner.
{
{ WIDTH: (input)  This parameter specifies the width of the area.
{
{ HEIGHT: (input)  This parameter specifies the height of the area.
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$area_cuts_object
{                              fde$bad_data_value
{                              fde$delete_outside_form
{                              fde$invalid_form_identifier
{                              fde$system_error
{
*DECK DECK=FDH$DELETE_FORM EXPAND=FALSE
{
{   The purpose of this request is to delete a form from the list of forms
{ scheduled to display to the screen.  The next request that updates the
{ screen, fdp$read_forms or fdp$show_forms, will replot the screen for the
{ terminal user.  Any forms uncovered by a deleted form will be replotted.  A
{ deleted form remains open and can be added later.  A pushed form cannot be
{ deleted.
{
{       FDP$DELETE_FORM (FORM_IDENTIFIER, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form to delete from
{       the list of forms scheduled for display.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$form_pushed
{                              fde$form_not_scheduled
{                              fde$invalid_form_identifier
{                              fde$no_space_available
{
*DECK DECK=FDH$DELETE_MARK EXPAND=FALSE
{
{   The purpose of this request is to delete the previous mark established by
{ the fdp$create_mark request.  This request may only be used on a form
{ created with the fdp$create_design_form request.
{
{       FDP$DELETE_MARK (FORM_IDENTIFIER, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier.
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$delete_mark_invalid
{                              fde$form_not_scheduled
{                              fde$form_pushed
{                              fde$invalid_form_identifier
{                              fde$no_space_available
{                              fde$system_error
{
*DECK DECK=FDH$DELETE_OBJECT EXPAND=FALSE
{
{   The purpose of this request is to delete an object at the specified
{ position from the form.  The upper left point of a line or box defines its
{ position.  The upper left character of a text field defines its position.
{ Any associated variable or table definition is not affected by this request.
{
{       FDP$DELETE_OBJECT (FORM_IDENTIFIER, X_POSITION, Y_POSITION, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ X_POSITION: (input)  This parameter specifies the x position of the object
{       to delete.
{
{ Y_POSITION: (input)  This parameter specifies the y position of the object
{       to delete.
{
{ STATUS: (output) This parameter specifies the name of the variable
{       to set to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$cannot_change_form
{                              fde$invalid_form_identifier
{                              fde$no_object_at_position
{                              fde$no_space_available
{
*DECK DECK=FDH$DELETE_SCREEN_CHANGES EXPAND=TRUE
{   The purpose of this request is to delete changes to the terminal screen
{ that are no longer needed.
{
{       FDP$DELETE_SCREEN_CHANGES (FORM_IDENTIFIER, FORM_ADDED)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier.
{
{ FORM_ADDED: (output)  This parameter specifices when the form is currently
{       added.  This parameter is TRUE if the form is currently added.
{       Otherwise the parameter is FALSE.
*DECK DECK=FDH$DELETE_STORED_OBJECT EXPAND=FALSE
{
{   The purpose of this request is to delete a stored
{ object.  A stored object has no object on the form image.
{
{       FDP$DELETE_STORED_OBJECT (FORM_IDENTIFIER, NAME, OCCURRENCE,
{         STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ NAME: (input)  This parameter specifies the name of the stored object.
{
{ OCCURRENCE: (input)  This parameter specifies the occurrence of the stored
{       object.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$cannot_change_form
{                              fde$invalid_form_identifier
{                              fde$invalid_object_name
{                              fde$invalid_occurrence
{                              fde$unknown_object_name
{
*DECK DECK=FDH$DELETE_TABLE EXPAND=FALSE
{
{   The purpose of this request is to delete a table.  Any associated variable
{ or form objects definitions are not deleted.
{
{       FDP$DELETE_TABLE (FORM_IDENTIFIER, TABLE_NAME, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form
{
{ TABLE_NAME: (input)  This parameter specifies the table to delete.
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$cannot_change_form
{                              fde$invalid_form_identifier
{                              fde$invalid_table_name
{                              fde$unknown_table_name
{
*DECK DECK=FDH$DELETE_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to delete a variable.  Any associated table
{ or form object definitions are not updated.
{
{       FDP$DELETE_VARIABLE (FORM_IDENTIFIER, VARIABLE_NAME, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ VARIABLE_NAME: (input)  This parameter specifies the variable to delete.
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$cannot_change_form
{                              fde$invalid_form_identifier
{                              fde$invalid_variable_name
{                              fde$unknown_variable_name
{
*DECK DECK=FDH$EDIT_FORM EXPAND=FALSE
{
{   The purpose of this request is to indicate that you intend to change the
{ form definition for a copied form or a previous ended form definition.
{
{       FDP$EDIT_FORM (FORM_IDENTIFIER, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$invalid_form_identifier
{                              fde$no_space_available
{
*DECK DECK=FDH$END_FORM EXPAND=FALSE
{
{   The purpose of this request is to end the definition of a form.  This
{ request must be issued before the form may be opened.
{
{       FDP$END_FORM (FORM_IDENTIFIER, P_SEQUENCE, NUMBER_ERRORS, P_ERRORS,
{         STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ P_SEQUENCE: (input)  This parameter specifies the sequence for Screen
{       Formatting to return errors in the form definition.  If this parameter
{       is NIL, no errors are returned.
{
{ NUMBER_ERRORS: (output)  This parameter specifies the number of errors in
{       the form definition.  Screen Formatting will display the form as best
{       as it can in spite of errors.
{
{ P_ERRORS: (output)  This parameter specifies the sequence of errors found by
{       Screen Formatting.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$cannot_change_form
{                              fde$invalid_form_identifier
{                              fde$no_space_available
{
*DECK DECK=FDH$FIND_NEXT_OBJECT EXPAND=FALSE
{
{    The purpose of this request is to return the index of the next object in
{ the form following the current cursor position.
{
{       FDP$FIND_NEXT_OBJECT (X_POSITION, Y_POSITION, P_FORMS_STATUS,
{             OBJECT_INDEX)
{
{ X_POSITION: (input)  This parameter specifies the current cursor x position.
{
{ Y_POSITION: (input)  This parameter specifies the current cursor y position.
{
{ P_FORM_STATUS: (input)  This parameter specifies the form status record for
{       the form containing the cursor.
{
{ OBJECT_INDEX: (output)  This parameter returns the index of the next object
{       in the form.
{
*DECK DECK=FDH$FORTRAN_ALIASES EXPAND=FALSE
C PURPOSE:
C   The deck fdp$fortran_aliases gives short names (6 characters or less) for
C   FORTRAN place of the long names (31 characters or less) used in NOS/VE.

*DECK DECK=FDH$GENERATE_FORM_MODULE EXPAND=FALSE
{    The purpose of this request is to generate a SCL language definition for a
{ a form in a binary format.
{
{       FDP$GENERATE_FORM_MODULE (FILE_IDENTIFIER, FORM_NAME, FORM_MODULE_P,
{             STATUS)
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the file identifier on
{       which the SCL language definition for a form will be written.
{
{ FORM_NAME: (input)  This parameter specifies the name of the form.
{
{ FORM_MODULE_P:  (Input/output) This parameter specifices a pointer to a
{       sequence containing the form module.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of request.
{       CONDITIONS:
{              fde$bad_data_value
{              fde$form_requires_conversion
{              fde$no_space_available
{              fde$system_error
{
{
*DECK DECK=FDH$GENERATE_FORM_VARIABLE EXPAND=FALSE
{    The purpose of this request is to generate the language definition for the
{ variables of the form.
{
{       FDP$GENERATE_FORM_VARIABLE (FILE_IDENTIFIER, FORM_NAME, FORM_MODULE_P,
{             STATUS)
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the file identifier on
{       which the variable definition for a form will be written.
{
{ FORM_NAME: (input)  This parameter specifies the name of the form.
{
{ FORM_MODULE_P:  (Input/output) This parameter specifices a pointer to a
{       sequence containing the form module.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of request.
{       CONDITIONS:
{             fde$bad_data_value
{             fde$form_requires_conversion
{             fde$no_space_available
{             fde$system_error
{
*DECK DECK=FDH$GET_FORM_ATTRIBUTES EXPAND=FALSE
{
{   The purpose of this request is to get the current attributes of a form.
{
{       FDP$GET_FORM_ATTRIBUTES (FORM_IDENTIFIER, GET_FORM_ATTRIBUTES, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier.
{
{ GET_FORM_ATTRIBUTES:  (input/output) This parameter specifies the array of
{       form attributes you wish to know.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$invalid_form_attribute
{                              fde$invalid_event_name
{                              fde$invalid_form_identifier
{                              fde$string_too_small
{                              fde$system_error
{                              fde$unknown_event_name
{
*DECK DECK=FDH$GET_FORM_NAMES EXPAND=FALSE
{
{   The purpose of this request is to get the current names defined for a
{ form.  The fdp$get_form_attributes request using the attribute key of
{ fdc$get_number_objects, fdc$get_number_tables, and fdc$get_number_variables
{ allow you to learn the size of an array to allocate to receive the form
{ names.
{
{       FDP$GET_FORM_NAMES (FORM_IDENTIFIER, NAME_SELECTIONS, FORM_NAMES,
{         NUMBER_NAMES, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ NAME_SELECTIONS: (input)  This parameter specifies a set of selections for
{       names.  The selections are fdc$select_variable_names,
{       fdc$select_table_names, and fdc$select_object_names.
{
{ FORM_NAMES: (output)  This parameter specifies an array to hold the form
{       names.  The form names are returned in the following record.
{
{       field                       description
{       _____                       ___________
{       name           The name of the item (variable, table, object)
{
{       name_type      The type of the name, fdc$select_variable,
{                      fdc$select_table, fdc$select_object.
{
{ NUMBER_NAMES: (output)  This parameter specifies the number of names
{       returned.
{
{ STATUS: This parameter specifies the status record.
{
{       condition identifiers:  fde$bad_data_value
{                               fde$invalid_form_identifier
{                               fde$too_many_form_names
{
*DECK DECK=FDH$GET_FORM_OBJECTS EXPAND=FALSE
{
{   The purpose of this request is to get objects defined for a form.  The
{ fdp$get_form_attributes request using the attribute key of
{ fdc$get_number_objects allows you to learn the space to allocate to get form
{ objects.
{
{       FDP$GET_FORM_OBJECTS (FORM_IDENTIFIER, FORM_OBJECTS, NUMBER_OBJECTS,
{         STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ FORM_OBJECTS: (output)  This parameter specifies an array to hold the form
{       objects Screen Formatting returns.
{
{ NUMBER_OBJECTS: (output)  This parameter specifies the number of objects
{       returned.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$invalid_form_identifier
{                              fde$too_many_form_objects
{
*DECK DECK=FDH$GET_INTEGER_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to get the value of a form integer
{ variable and transfer it to the program.  You cannot get a variable from a
{ pushed form.
{
{       FDP$GET_INTEGER_VARIABLE (FORM_IDENTIFIER, NAME, OCCURRENCE, VARIABLE,
{         VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ NAME: (input)  This parameter specifies the name of the variable.
{
{ OCCURRENCE: (input)  This parameter specifies the occurrence of the variable
{       name.
{
{ VARIABLE: (output)  This parameter specifies the integer variable.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the ordinal which gives
{       the status of the variable.
{
{       value:  fdc$no_error
{               fdc$invalid_integer
{               fdc$invalid_bdp_data
{               fdc$no_digits
{               fdc$loss_of_significance
{
{ STATUS: (output) This parameter specifies the name of the variable to
{       set to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$invalid_form_identifier
{                              fde$system_error
{                              fde$unknown_occurrence
{                              fde$unknown_variable_name
{
*DECK DECK=FDH$GET_NEXT_CHANGED_VARIABLE EXPAND=FALSE
{
{    The purpose of this request is to return the name of the next variable
{ changed by the terminal user in the form.  The form cannot be pushed.
{
{       FDP$GET_NEXT_CHANGED_VARIABLE (FORM_IDENTIFIER, VARIABLE_NAME,
{             CHANGE_FOUND, OCCURRENCE, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ VARIABLE_NAME: (output)  This parameter specifies the name of the changed
{       variable.
{
{ OCCURRENCE: (output)  This parameter specifies the occurrence of the variable
{       name.
{
{ CHANGE_FOUND: (output)  This parameter specifies a boolean.  If a changed
{       variable was found, change_found is true.  Otherwise, change_found is
{       false.
{
{ STATUS: (output)  This parameter specifies the request status.
{
{       CONDITIONS:  fde$bad_data_value
{                    fde$invalid_form_identifier
{                    fde$no_space_available
{                    fde$system_error
{
*DECK DECK=FDH$GET_NEXT_EVENT EXPAND=FALSE
{
{   The purpose of this request is to get the next event that occurred as a
{ result of the last fdp$read_forms request.  Before accepting input from the
{ terminal user, the fdp$read_forms request deletes any existing events.  The
{ fdp$get_next_event returns the event name, the event type (normal or
{ abnormal) and the event position.
{
{       FDP$GET_NEXT_EVENT (EVENT_NAME, EVENT_NORMAL, EVENT_POSITION,
{         LAST_EVENT, STATUS)
{
{ EVENT_NAME: (output)  This parameter specifies the name of the event.
{
{ EVENT_NORMAL: (output)  This parameter specifies a boolean.  If the terminal
{       user entered an event defined as normal, event normal is true.
{       Otherwise, event_normal is false.
{
{ EVENT_POSITION: (output)  This parameter specifies a record that describes
{       the event position.
{
{ LAST_EVENT: (output)  This parameter specifies a boolean.  Last_event is
{       true if this is the last event.  Otherwise, last_event is false.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{        condition identifiers: fde$bad_data_value
{
*DECK DECK=FDH$GET_NEXT_INPUT_ERROR EXPAND=FALSE
{
{    The purpose of this request is to get the next variable with input errors
{ in the form record.  The form cannot be pushed.
{
{       FDP$GET_NEXT_INPUT_ERROR (FORM_IDENTIFIER, VARIABLE_NAME, OCCURRENCE,
{             VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ VARIABLE_NAME: (output)  This parameter specifies the name of the variable
{       containing the error.
{
{ OCCURRENCE: (output)  This parameter specifies the occurrence of the variable
{       name.
{
{ VARIABLE_STATUS: (output)  This parameter specifies an ordinal which gives
{       the status of the variable.  FDC$NO_ERROR means that there are no
{       further input errors in the form record. The possible values are
{       the same as those described by FDH$GET_RECORD.
{
{ STATUS: (output)  This parameter specifies the request status.
{
{       CONDITIONS:  fde$bad_data_value
{                    fde$form_pushed
{                    fde$invalid_form_identifier
{                    fde$no_space_available
{                    fde$system_error
{

*DECK DECK=FDH$GET_NEXT_OUTPUT_ERROR EXPAND=FALSE
{
{    The purpose of this request is to get the next variable with output errors
{ in the form record.  The form cannot be pushed.
{
{       FDP$GET_NEXT_OUTPUT_ERROR (FORM_IDENTIFIER, VARIABLE_NAME, OCCURRENCE,
{             VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ VARIABLE_NAME: (output)  This parameter specifies the name of the variable
{       containing the error.
{
{ OCCURRENCE: (output)  This parameter specifies the occurrence of the variable
{       name.
{
{ VARIABLE_STATUS: (output)  This parameter specifies an ordinal which gives
{       the status of the variable.  FDC$NO_ERROR means that there are no
{       further output errors in the form record. The possible values are
{       the same as those described by FDH$REPLACE_RECORD.
{
{ STATUS: (output)  This parameter specifies the request status.
{
{       CONDITIONS:  fde$bad_data_value
{                    fde$form_pushed
{                    fde$invalid_form_identifier
{                    fde$no_space_available
{                    fde$system_error
{

*DECK DECK=FDH$GET_NUMBER_OF_OCCURRENCES EXPAND=FALSE
{
{   The purpose of this request is to get the number of occurrences for
{ a variable.
{
{       FDP$GET_NUMBER_OCCURRENCES (FORM_IDENTIFIER, VARIABLE_NAME,
{            TABLE_MEMBER, OCCURRENCES, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form to add to the
{       list of forms scheduled for display.
{
{ VARIABLE_NAME: (input)  This parameter specifies the variable name.
{
{ TABLE_MEMBER: (output)  This parameter is TRUE if the variable is a member of
{       a table.  Otherwise, this parameter is FALSE.
{
{ OCCURRENCES: (output) This parameters specifies the number of occurrences
{       for the variable.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of request.
{
{       condition identifiers:  fde$bad_data_value
{                               fde$invalid_form_identifier
{                               fde$system_error
{                               fde$unknown_variable_name
{
*DECK DECK=FDH$GET_OBJECT_ATTRIBUTES EXPAND=FALSE
{
{   The purpose of this request is to get selected attributes about objects
{ placed on the form image.
{
{       FDP$GET_OBJECT_ATTRIBUTES (FORM_IDENTIFIER, X_POSITION, Y_POSITION,
{         GET_OBJECT_ATTRIBUTES, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier to
{       query.
{
{ X_POSITION: (input)  This parameter specifies the x position relative to the
{       form.
{
{ Y_POSITION: (input)  This parameter specifies the y position relative to the
{       form.
{
{ GET_OBJECT_ATTRIBUTES:  (input/output) This parameter specifies an array to
{       hold the object attributes screen formatting returns.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$invalid_form_identifier
{                              fde$invalid_object_attribute
{                              fde$no_object_at_position
{                              fde$string_too_small
{                              fde$system_error
{
*DECK DECK=FDH$GET_REAL_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to get the current value of a real form
{ variable and transfer it to the program.  You cannot get a variable from a
{ pushed form.
{
{       FDP$GET_REAL_VARIABLE (FORM_IDENTIFIER, NAME, OCCURRENCE, VARIABLE,
{         VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ NAME: (input)  This parameter specifies the name of the variable.
{
{ OCCURRENCE: (input)  This parameter specifies the occurrence of the variable
{       name.
{
{ VARIABLE: (output)  This parameter specifies the real variable.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the ordinal which gives
{       the status of the variable.
{
{       Value:  fdc$no_error
{               fdc$invalid_real
{               fdc$invalid_bdp_data
{               fdc$no_digits
{               fdc$loss_of_significance
{               fdc$overflow
{               fdc$underflow
{               fdc$infinite
{               fdc$indefinite
{
{ STATUS: (output) This parameter specifies the name of the variable
{       to set to indicate the status of the request.
{
{       condition identifiers: fde$form_not_scheduled
{                              fde$form_pushed
{                              fde$invalid_form_identifier
{                              fde$system_error
{                              fde$unknown_occurrence
{                              fde$unknown_variable_name
{
*DECK DECK=FDH$GET_RECORD EXPAND=FALSE
{
{   The purpose of this request is to get the current value of the form record
{ and transfer it to the program.  The form cannot be pushed.
{
{       FDP$GET_RECORD (FORM_IDENTIFIER, P_WORK_AREA, WORK_AREA_LENGTH,
{         VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter the form identifier for the instance
{       of the form.
{
{ P_WORK_AREA: (input)  This parameter specifies the work area for the form
{       record.
{
{ WORK_AREA_LENGTH: (input)  This parameter specifies the number of cells in
{       the work_area to be used for the record transfer.
{
{ VARIABLE_STATUS: (output)  This parameter specifes an ordinal which gives the
{       status of the variable.
{
{       Value:  fdc$no_error
{               fdc$invalid_string
{               fdc$invalid_real
{               fdc$invalid_integer
{               fdc$invalid_bdp_data
{               fdc$no_digits
{               fdc$loss_of_significance
{               fdc$underflow
{               fdc$indefinite
{               fdc$overflow
{               fdc$infinite
{               fde$cobol_nonblk_outside_paren
{               fdc$nonblk_outside_parentheses
{               fdc$no_scientific_notation
{               fdc$invalid_character_entered
{               fdc$too_many_signs
{               fdc$no_plus_or_minus_now
{               fdc$c_without_r
{               fdc$no_cr_or_db_now
{               fdc$d_without_b
{               fdc$gr_18_right_of_point
{               fdc$gr_18_left_of_point
{               fdc$too_many_decimal_points
{               fdc$nonblk_after_trailing_sign
{               fdc$floating_number_too_big
{               fdc$invalid_overpunch_sign
{               fdc$invalid_separate_sign
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers:  fde$bad_data-value
{                               fde$form_has_no_variables
{                               fde$invalid_form_identifier
{                               fde$work_area_invalid
{                               fde$system_error
{
*DECK DECK=FDH$GET_RECORD_ATTRIBUTES EXPAND=FALSE
{
{   The purpose of this request is to get the attributes of a record.
{
{       FDP$GET_RECORD_ATTRIBUTES (FORM_IDENTIFIER, GET_RECORD_ATTRIBUTES,
{         STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ GET_RECORD_ATTRIBUTES:  (input/output) This parameter specifies an array of
{       attributes you wish to know about a record.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$invalid_form_identifier
{                              fde$invalid_record_attribute
{                              fde$invalid_table_name
{                              fde$invalid_variable_name
{                              fde$unknown_table_name
{
*DECK DECK=FDH$GET_SCREEN_EVENTS EXPAND=FALSE
{
{   The purpose of this request is to get the events defined for the
{   terminal.
{
{       FDP$GET_SCREEN_EVENTS (STATUS)
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$no_space_available
{                              fde$system_error
{                              fde$terminal_disconnected
{                              fde$terminal_not_identified
{
*DECK DECK=FDH$GET_SCREEN_INPUT EXPAND=FALSE
{
{   The purpose of this request is to get input from the terminal user.
{
{       FDP$GET_SCREEN_INPUT (EVENT_NAME, EVENT_NORMAL, EVENT_POSITION, STATUS)
{
{ EVENT_NAME: (output)  This parameter specifies the program name of the event.
{
{ EVENT_NORMAL: (output)  This parameter specifies if the terminal user
{       executed a normal event.  If the event is normal, the value is TRUE.
{       Otherwise the value is FALSE.
{
{ EVENT_POSITION:  This parameter specifies the position of the terminal user
{       event.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of request.
{
{       condition identifiers:  fde$system_error
{                               fde$terminal_disconnected
{                               fde$terminal_not_identified
{
*DECK DECK=FDH$GET_SCREEN_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to get the current screen value for a form
{ variable.  You cannot get the value from a pushed form.
{
{       FDP$GET_SCREEN_VARIABLE (FORM_IDENTIFIER, NAME, OCCURRENCE,
{         SCREEN_VARIABLE, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ NAME: (input)  This parameter specifies the name of the variable.
{
{ OCCURRENCE: (input)  This parameter specifies the occurrence of the variable
{       name.
{
{ VARIABLE: (output)  This parameter returns the screen value of the variable.
{
{ STATUS: (output) This parameter specifies the name of the variable
{       to set to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$invalid_form_identifier
{                              fde$system_error
{                              fde$unknown_occurrence
{                              fde$unknown_variable_name
{
*DECK DECK=FDH$GET_STORED_OBJECT EXPAND=FALSE
{
{   The purpose of this request is to get the attributes of a stored object.
{ A stored object has no object on the form image.
{
{       FDP$GET_STORED_OBJECT (FORM_IDENTIFIER, NAME, OCCURRENCE, TEXT,
{         TEXT_LENGTH, DISPLAY_ATTRIBUTE_SET, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ NAME: (input)  This parameter specifies the name of the stored object.
{
{ OCCURRENCE: (input)  This parameter specifies the occurrence of the stored
{       object.
{
{ TEXT: (output)  This parameter specifies the initial value for the stored
{       object.
{
{ TEXT_LENGTH: (output)  This parameters specifies the length of text for the
{       stored object.
{
{ DISPLAY_ATTRIBUTE_SET: (output)  This parameter specifies the display
{       attributes of stored object when it is initially displayed.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$invalid_form_identifier
{                              fde$invalid_object_name
{                              fde$invalid_occurrence
{                              fde$unknown_object_name
{
*DECK DECK=FDH$GET_STRING_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to get the current value of a form string
{ variable and transfer it to the program.  You cannot get a variable from a
{ pushed form.
{
{       FDP$GET_STRING_VARIABLE (FORM_IDENTIFIER, NAME, OCCURRENCE, VARIABLE,
{         VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ NAME: (input)  This parameter specifies the name of the variable.
{
{ OCCURRENCE: (input)  This parameter specifies the occurrence of the variable
{       name.
{
{ VARIABLE: (output)  This parameter specifies the string variable.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the ordinal which gives
{       the status of the variable.
{
{       value:  fdc$no_error
{               fdc$invalid_string
{
{ STATUS: (output) This parameter specifies the name of the variable
{       to set to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$invalid_form_identifier
{                              fde$system_error
{                              fde$unknown_occurrence
{                              fde$unknown_variable_name
{
*DECK DECK=FDH$GET_TABLE_ATTRIBUTES EXPAND=FALSE
{
{   The purpose of this request is to get selected attributes about a table.
{
{       FDP$GET_TABLE_ATTRIBUTES (FORM_IDENTIFIER, TABLE_NAME,
{         GET_TABLE_ATTRIBUTES, STATUS)
{
{  FORM_IDENTIFIER: (input)  This parameter specifies the form identifier to
{        query.
{
{  TABLE_NAME: (input)  This parameter specifies the table name.
{
{  GET_TABLE_ATTRIBUTES:  (input/output) This parameter specifies the table
{        attributes.
{
{  STATUS: (output) This parameter specifies the status record.
{
{        condition identifiers: fde$bad_data_value
{                               fde$invalid_form_identifier
{                               fde$invalid_table_attribute
{                               fde$invalid_table_name
{                               fde$no_object_at_position
{                               fde$unknown_table_name
{
*DECK DECK=FDH$GET_VARIABLE_ATTRIBUTES EXPAND=FALSE
{
{   The purpose of this request is to get selected information about a
{ variable.
{
{       FDP$GET_VARIABLE_ATTRIBUTES (FORM_IDENTIFIER, VARIABLE_NAME,
{         GET_VARIABLE_ATTRIBUTES, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ VARIABLE_NAME: (input)  This parameter specifies the name of the variable.
{
{ GET_VARIABLE_ATTRIBUTES: (input/output)  This parameter specifies an array of
{       attributes to get.
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$invalid_address
{                              fde$invalid_form_identifier
{                              fde$invalid_variable_attribute
{                              fde$invalid_variable_name
{                              fde$system_error
{                              fde$string_too_small
{                              fde$unknown_variable_name
{
*DECK DECK=FDH$INITIALIZE_FORM_OBJECTS EXPAND=FALSE
{   The purpose of this request is to initialize all objects on the form to
{ their initialize values and attributes.
{
{       FDP$INITIALIZE_FORM_OBJECTS (FORM_IDENTIFIER, P_FORM_STATUS,
{         RECORD_CHANGES, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier of the
{       form to initialize objects.
{
{ P_FORM_STATUS: (input)  This parameter specifies the status data for a form.
{
{ RECORD_CHANGES: (input)  This parameter specifies whether changes should be
{       recorded for display on the terminal screen.  TRUE means the changes
{       should be recorded.  FALSE means the changes should not be recorded.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of request.
{
{       condition identifiers:  fde$no_space_available
{                               fde$system_error
{
*DECK DECK=FDH$INITIALIZE_FORM_RECORD EXPAND=FALSE
{   The purpose of this request is to initialize the form record variables to
{ their initialize values.
{
{       FDP$INITIALIZE_FORM_RECORD (FORM_IDENTIFIER, P_FORM_STATUS,
{         RECORD_CHANGES, VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier of the
{       form to initialize objects.
{
{ P_FORM_STATUS: (input)  This parameter specifies the status data for a form.
{
{ RECORD_CHANGES: (input)  This parameter specifies whether changes should be
{       recorded for display on the terminal screen.  TRUE means the changes
{       should be recorded.  FALSE means the changes should not be recorded.
{
{ VARIABLE_STATUS: (output)  This parameter specifies a status for variables in
{       in the record.  This parameter indicates if any of the variables could
{       not be converted to their program representation or their screen
{       representation.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of request.
{
{       condition identifiers:  fde$no_space_available
{                               fde$system_error
{
*DECK DECK=FDH$MOVE_AREA EXPAND=FALSE
{
{   The purpose of this request is to move all objects and unprotected text on
{ a form from one area to another area.  A design form has both objects
{ (protected text) and unprotected text.  A target form has only objects.
{
{       FDP$MOVE_AREA (FORM_IDENTIFIER, FROM_X_POSITION, FROM_Y_POSITION,
{         WIDTH,  WIDTH, TO_X_POSITION, TO_Y_POSITION, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier of
{       the form.
{
{ FROM_X_POSITION: (input)  This parameter specifies the x position of the
{       origin of the area closing the data to be moved with respect to the
{       form.  The origin of the area is the upper left corner.
{
{ FROM_Y_POSITION: (input)  This parameter specifies the y position of the
{       origin of the area enclosing the data to be moved with respect to the
{       form.
{
{ WIDTH: (input)  This parameter specifies the width of the area.
{
{ HEIGHT: (input)  This parameter specifies the height of the area.
{
{ TO_X_POSITION: (input)  This parameter specifies the x position of the area
{       where the data should be copied.
{
{ TO_Y_POSITION: (input)  This parameter specifies the y position of the area
{       where the data should be copied.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$invalid_form_identifier
{                              fde$move_outside_form
{                              fde$object_overlays
{                              fde$system_error
{
*DECK DECK=FDH$MOVE_COBOL_DATA EXPAND=FALSE
{
{   The purpose of this request is to move the source description and value to
{ the destination address as described by the destination description.
{
{       FDP$MOVE_COBOL_DATA (SOURCE, SOURCE_ADDRESS, DESTINATION,
{         DESTINATION_ADDRESS, STATUS)
{
{ SOURCE: (input)  This parameter describes the source item.  It must have been
{       created by FDP$MAKE_COBOL_DESCRIPTION.
{
{ SOURCE_ADDRESS: (input)  This parameter specifies the address of the first
{       (left-most, lowest-address) byte in the source field.  There are
{       SOURCE.SIZE bytes in the source field.
{
{ DESTINATION: (input)  This parameter describes how to put items in the
{       destination field.  It must have been created by
{       FDP$MAKE_COBOL_DESCRIPTION.
{
{ DESTINATION_ADDRESS:  (input/output) This parameter specifies the address of
{       the first byte for the destination field.  The user must have allocated
{       DESTINATION.SIZE bytes.  The address will not be changed, but the field
{       at the address will be set appropriately.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             fde$cobol_bad_overpunch_sign
{             fde$cobol_bad_separate_sign
{             fde$cobol_c_without_r
{             fde$cobol_destination_invalid
{             fde$cobol_d_without_b
{             fde$cobol_float_too_big
{             fde$cobol_free_form_not_dest
{             fde$cobol_illegal_char_entered
{             fde$cobol_nonblk_outside_paren
{             fde$cobol_no_cr_or_db_now
{             fde$cobol_no_plus_or_minus_now
{             fde$cobol_no_scientific
{             fde$cobol_source_invalid
{             fde$cobol_too_many_digits
{             fde$cobol_trailing_sign_nonblk
{             fde$cobol_two_points_entered
{             fde$cobol_two_signs_entered
{             fde$cobol_usage_size_too_big
{
*DECK DECK=FDH$MOVE_TO_PROGRAM_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to move a screen variable to a program
{ variable.
{
{       FDP$MOVE_TO_PROGRAM_VARIABLE (P_FORM_STATUS, P_FORM_VARIABLE,
{         P_SCREEN_VARIABLE, P_PROGRAM_VARIABLE, VARIABLE_STATUS, STATUS)
{
{ P_FORM_STATUS: (input)  A pointer to the form status data.
{
{             P_FORM_VARIABLE (input) A pointer to the form variable to move.
{
{ P_SCREEN_VARIABLE: (input)  A pointer to the character screen variable data.
{
{ P_PROGRAM_VARIABLE: (output)  A pointer to store the program variable.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the status of the
{       variable.
{
{       Value:  fdc$no_error
{               fdc$invalid_bdp_data
{               fdc$invalid_integer
{               fdc$invalid_real
{               fdc$overflow
{               fdc$loss_of_significance
{               fde$cobol_nonblk_outside_paren
{               fdc$nonblk_outside_parentheses
{               fdc$no_scientific_notation
{               fdc$invalid_character_entered
{               fdc$too_many_signs
{               fdc$no_plus_or_minus_now
{               fdc$c_without_r
{               fdc$no_cr_or_db_now
{               fdc$d_without_b
{               fdc$gr_18_right_of_point
{               fdc$gr_18_left_of_point
{               fdc$too_many_decimal_points
{               fdc$nonblk_after_trailing_sign
{               fdc$floating_number_too_big
{               fdc$invalid_overpunch_sign
{               fdc$invalid_separate_sign
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$feature_not_implemented
{
*DECK DECK=FDH$MOVE_TO_SCREEN_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to move a screen variable to a program
{ variable.
{
{       FDP$MOVE_TO_SCREEN_VARIABLE (P_FORM_STATUS, P_FORM_VARIABLE,
{         P_PROGRAM_VARIABLE, P_SCREEN_VARIABLE, VARIABLE_STATUS, STATUS)
{
{ P_FORM_STATUS: (input)  A pointer to the form status data.
{
{             P_FORM_VARIABLE (input) A pointer to the form variable to move.
{
{ P_PROGRAM_VARIABLE: (input)  A pointer to the program variable.
{
{ P_SCREEN_VARIABLE: (output)  A pointer to store the characters for the screen
{       variable.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the status of the
{       variable.
{
{       value:  fdc$no_error
{               fdc$invalid_bdp_data
{               fdc$invalid_integer
{               fdc$invalid_real
{               fdc$overflow
{               fdc$loss_of_significance
{               fdc$gr_18_right_of_point
{               fdc$gr_18_left_of_point
{               fdc$too_many_decimal_points
{               fdc$floating_number_too_big
{               fdc$invalid_overpunch_sign
{               fdc$invalid_separate_sign
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$feature_not_implemented
{
*DECK DECK=FDH$OPEN_FORM EXPAND=FALSE
{
{   The purpose of this request is to prepare a form for use by the program.
{ If the form_name is equal to OSC$NULL_NAME, then the form_identifier
{ specifies a dynamically created form.  Otherwise, Screen Formatting locates
{ the desired form by first searching the list of dynamically created forms
{ and then the forms specified by the command library list.  The
{ set_command_list specifies the command library list.  Fdp$open_form does not
{ display the form on the screen.  A form must be opened using fdp$open_form
{ before the form can be used by any other request.  The form_identifier
{ returned by this request identifies the instance of open for a form.  The
{ same form may have a number of open instances.  For each instance Screen
{ Formatting maintains the working environment of the form.  The working
{ environment includes the current value of variables and their display
{ attributes.
{
{       FDP$OPEN_FORM (FORM_NAME, FORM_IDENTIFIER, STATUS)
{
{ FORM_NAME: (input)  This parameter specifies the name of the form to open.
{       If the form name is equal to spaces, then Screen Formatting assumes
{       the form_identifier specifies the required dynamically created form.
{
{ FORM_IDENTIFIER:  (input/output) This parameter specifies the
{       form_identifier for other Screen Formatting requests to use when
{       referencing the form.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$form_already_open
{                              fde$form_not_ended
{                              fde$form_requires_conversion
{                              fde$invalid_form_identifier
{                              fde$invalid_form_name
{                              fde$no_space_available
{                              fde$system_errors
{                              fde$terminal_not_identified
{                              fde$unknown_form_name
{
*DECK DECK=FDH$OPEN_FORM_MODULE EXPAND=FALSE
{    The purpose of this request is to open a form.  Use this interface when
{ you do not want to display a form on a terminal screen, but only want to
{ access the attributes of a form.
{
{       FDP$OPEN_FORM_MODULE (FORM_MODULE_P, FORM_IDENTIFIER, STATUS)
{
{ FORM_MODULE_P:  (Input/output) This parameter specifies a pointer to a
{       sequence containing the form module.
{
{ FORM_IDENTIFIER: (output)  This parameter specifies the form identifier for
{       following requests to use to access the form.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of request.
{       CONDITIONS:
{             fde$form_requires_conversion
{             fde$no_space_available
{             fde$system_error
{
{
*DECK DECK=FDH$PASCAL_PROCEDURES EXPAND=FALSE
{
*copyc fdh$xadd_form
*copyc fdh$xchange_table_size
*copyc fdh$xdelete_form
*copyc fdh$xget_integer_variable
*copyc fdh$xget_next_changed_variable
*copyc fdh$xget_next_event
*copyc fdh$xget_real_variable
*copyc fdh$xget_string_variable
*copyc fdh$xopen_form
*copyc fdh$xpop_forms
*copyc fdh$xposition_form
*copyc fdh$xpush_forms
*copyc fdh$xread_forms
*copyc fdh$xreplace_integer_variable
*copyc fdh$xreplace_real_variable
*copyc fdh$xreplace_string_variable
*copyc fdh$xreset_form
*copyc fdh$xreset_object_attribute
*copyc fdh$xset_cursor_position
*copyc fdh$xset_line_mode
*copyc fdh$xset_object_attribute
*copyc fdh$xshow_forms
*copyc fdh$xtab_to_next_field
}
*DECK DECK=FDH$POP_FORMS EXPAND=FALSE
{
{   The purpose of this request is to dequeue the last list of forms scheduled
{ for display queued by the fdp$push_forms request and sets them as the
{ current list of forms scheduled for display.  Any forms scheduled for
{ display when the request is executed are deleted.  All events associated
{ with the forms become active upon a fdp$read_forms request.  A
{ fdp$read_forms or fdp$show_forms request displays the form.
{
{       FDP$POP_FORMS (STATUS)
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$no_forms_to_pop
{
*DECK DECK=FDH$POSITION_FORM EXPAND=FALSE
{
{   The purpose of this request is to position a form to a new location.  This
{ allows you to define a form at one location and then to display it at
{ another location or to move a form from its currently displayed location to
{ another location that is more convenient for the terminal user.  If you
{ issue this request before the form is displayed, then the form will be
{ displayed at the specified location.  If you issue this request when the
{ form is displayed, the form will be deleted from its current location and
{ added at the new location.  The next request that updates the screen,
{ fdp$read_forms or fdp$show_forms, will replot the screen for the terminal
{ user.  Any forms uncovered by the deleted form will be replotted.  The added
{ form lies on top of other forms occupying the same area on the screen.  You
{ cannot position a pushed form.
{
{       FDP$POSITION_FORM (FORM_IDENTIFIER, SCREEN_X_POSITION,
{         SCREEN_Y_POSITION, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form to position.
{
{ SCREEN_X_POSITION: (input)  This parameter specifies the x position of the
{       form to the screen.  The first x position is the first character of
{       the top line of the screen.  The first x position is numbered 1.  The
{       x position increases by 1 for each character position on the screen
{       from left to right.
{
{ SCREEN_Y_POSITION: (input)  The parameter specifies the y position of the
{       form with respect to the screen.  The first screen y position is the
{       first character on the top line of the screen.  The first y position
{       is numbered 1.  The y position increases by one for each line of the
{       form going from top to bottom.
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$form_already_added
{                              fde$form_pushed
{                              fde$form_not_scheduled
{                              fde$form_too_large_for_screen
{                              fde$invalid_form_identifier
{                              fde$no_space_available
{                              fde$system_error
{
*DECK DECK=FDH$PUSH_FORMS EXPAND=FALSE
{
{   The purpose of this request is to queue the current list of forms
{ scheduled for display in a last in, first out queue.  The fdp$pop_forms
{ request can be used to dequeue the last in list of forms.  Updates to the
{ screen will continue to show the forms.  Events associated with the forms
{ are not considered as active and are not passed to the program.  The queue
{ may contain more than one list of forms.
{
{       FDP$PUSH_FORMS (STATUS)
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifier: fde$bad_data_value
{                             fde$no_forms_to_push
{
*DECK DECK=FDH$READ_FORMS EXPAND=FALSE
{
{   The purpose of this request is to update the user's terminal screen
{   and accept input from the terminal user.  Any events which the
{ program has not retrieved with the fdp$get_next_event request are deleted
{ before accepting input from the terminal user.
{
{       FDP$READ_FORMS (STATUS)
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$no_events_active
{                              fde$no_forms_to_read
{                              fde$system_errors
{                              fde$terminal_disconnected
{
*DECK DECK=FDH$RECORD_SCREEN_CHANGE EXPAND=FALSE
{
{   The purpose of this request is to record changes to the terminal screen.
{
{       FDP$RECORD_SCREEN_CHANGE (SCREEN_CHANGE, STATUS)
{
{ SCREEN_CHANGE: (input)  This parameter specifies the screen change.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$no_space_available
{
{
*DECK DECK=FDH$REPLACE_INTEGER_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to transfer an integer variable to form
{ storage.  Form storage holds the values Screen Formatting uses to update the
{ screen or to return to a program.  You cannot replace a variable from a
{ pushed form.
{
{       FDP$REPLACE_INTEGER_VARIABLE (FORM_IDENTIFIER, NAME, OCCURRENCE,
{         VARIABLE, VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ NAME: (input)  This parameter specifies the name of the variable.
{
{ OCCURRENCE: (input)  This parameter specifies the occurrence of the variable
{       name.
{
{ VARIABLE: (input)  This parameter specifies the integer variable.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the ordinal which gives
{       the status of the variable.
{
{       value:  fdc$invalid_integer
{               fdc$loss_of_significance
{               fdc$no_error
{               fdc$output_format_bad
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$form_pushed
{                              fde$invalid_form_identfier
{                              fde$invalid_variable_name
{                              fde$no_space_available
{                              fde$system_error
{                              fde$unknown_occurrence
{                              fde$unknown_variable_name
{
*DECK DECK=FDH$REPLACE_REAL_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to transfer a real variable to form
{ storage.  Form storage holds the values screen formatting uses to update the
{ screen or to return to a program.  You cannot replace a variable from a
{ pushed form.
{
{       FDP$REPLACE_REAL_VARIABLE (FORM_IDENTIFIER, NAME, OCCURRENCE,
{         VARIABLE, VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ NAME: (input)  This parameter specifies the name of the variable.
{
{ OCCURRENCE: (input)  This parameter specifies the occurrence of the variable
{       name.
{
{ VARIABLE: (input)  This parameter specifies the real variable.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the ordinal which gives
{       the status of the variable.
{
{       value:  fdc$invalid_real
{               fdc$loss_of_significance
{               fdc$no_error
{               fdc$output_format_bad
{
{ STATUS: (output) This parameter specifies the name of the variable to
{       set to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$form_pushed
{                              fde$invalid_form_identfier
{                              fde$invalid_variable_name
{                              fde$no_space_available
{                              fde$system_error
{                              fde$unknown_occurrence
{                              fde$unknown_variable_name
{




*DECK DECK=FDH$REPLACE_RECORD EXPAND=FALSE
{
{   The purpose of this request is to transfer a program record to form
{ storage.  Form storage holds the values Screen Formatting uses to update the
{ screen or to reurn to a program.  If a fdp$get_record was then executed,
{ Screen Formatting would return the values set by the fdp$replace_record
{ request.  You cannot put a record to a pushed form.
{ A fdp$read_forms request or a fdp$show_forms request updates the
{ screen using the values from form storage.
{
{       FDP$REPLACE_RECORD (FORM_IDENTIFIER, P_WORK_AREA, WORK_AREA_LENGTH,
{         VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ P_WORK_AREA: (input)  This parameter specifies the work_area for the form
{       record.
{
{ WORK_AREA_LENGTH: (input)  This parameter specifies the number of cells in
{       the work_area.
{
{ VARIABLE_STATUS (output) This parameter specifies the ordinal
{       which gives the status of the variable.
{
{       value:  fdc$invalid_integer
{               fdc$invalid_real
{               fdc$invalid_string
{               fdc$loss_of_significance
{               fdc$no_error
{               fdc$output_format_bad
{               fdc$gr_18_right_of_point
{               fdc$gr_18_left_of_point
{               fdc$too_many_decimal_points
{               fdc$floating_number_too_big
{               fdc$invalid_overpunch_sign
{               fdc$invalid_separate_sign
{
{ STATUS: (output) This parameter specifies the name of the variable to
{       set to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$form_has_no_variables
{                              fde$form_pushed
{                              fde$invalid_form_identifier
{                              fde$no_space_available
{                              fde$work_area_invalid
{
*DECK DECK=FDH$REPLACE_STRING_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to transfer a program variable to form
{ storage.  Form storage holds the values Screen Formatting uses to update the
{ screen or to return to a program.
{
{       FDP$REPLACE_STRING_VARIABLE (FORM_IDENTIFIER, NAME, OCCURRENCE,
{         VARIABLE, VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ NAME: (input)  This parameter specifies the name of the variable.
{
{ OCCURRENCE: (input)  This parameter specifies the occurrence of the variable
{       name.
{
{ VARIABLE: (input)  This parameter specifies the string variable.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the ordinal which gives
{       the status of the variable.
{
{      value:  fdc$invalid_string
{              fdc$no_error
{
{ STATUS: (output) This parameter specifies  the name of the variable to set to
{       indicate the status of the request.
{
{      condition identifiers: fde$bad_data_value
{                             fde$form_pushed
{                             fde$invalid_form_identifier
{                             fde$system_error
{                             fde$unknown_occurrence
{                             fde$unknown_variable_name
{
*DECK DECK=FDH$RESET_FORM EXPAND=FALSE
{
{   The purpose of this request is to reset a form to the status specified by
{ the form definition.  Variables will have their initial values and display
{ attributes.  You cannot reset a pushed form.
{
{       FDP$RESET_FORM (FORM_IDENTIFIER, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier of
{       the form instance to reset.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$form_pushed
{                              fde$invalid_form_identifier
{                              fde$no_space_available
{                              fde$system_error
{
*DECK DECK=FDH$RESET_OBJECT_ATTRIBUTE EXPAND=FALSE
{
{   The purpose of this request is to reset the attributes for an object to
{ those specified in the form definition.  This request does not display the
{ form.  Follow this request with a fdp$show_forms or fdp$read_forms request
{ to display the form.  You cannot reset the attributes of a pushed form.  The
{ form must currently be added.
{
{       FDP$RESET_OBJECT_ATTRIBUTE (FORM_IDENTIFIER, OBJECT_NAME, OCCURRENCE,
{         STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ OBJECT_NAME: (input)  This parameter specifies the name of the object.
{
{ OCCURRENCE: (input)  This parameter specifies the occurrence of the object.
{       For the first occurrence or only occurrence of an object, use 1.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifier: fde$bad_data_value
{                             fde$form_pushed
{                             fde$form_not_scheduled
{                             fde$invalid_form_identifier
{                             fde$invalid_occurrence
{                             fde$no_space_available
{                             fde$unknown_object_name
{
*DECK DECK=FDH$SET_CURSOR_POSITION EXPAND=FALSE
{
{   The purpose of this request is to set the cursor to a selected object on
{ the form.  You may use this request to modify the default sequence of the
{ terminal user's entry of variable data.  The default sequence proceeds from
{ the highest priority form (the last added form) variable text object to
{ variable text object going left to right on a screen character line and from
{ top to bottom line.  You cannot set the cursor position of a pushed form.
{ The form must currently be added.
{
{       FDP$SET_CURSOR_POSITION (FORM_IDENTIFIER, OBJECT_NAME, OCCURRENCE,
{         CHARACTER_POSITION, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ OBJECT_NAME: (input)  This parameter specifies the name of object where you
{       wish to position the cursor.
{
{ OCCURRENCE: (input)  This parameter specifies the occurrence of the object.
{       For the first occurrence or only occurrence, use 1.
{
{ CHARACTER_POSITION: (input)  This parameter specifies the character position
{       in a text object to set the cursor.  A character position of 1
{       indicates the first position, a character position of 2 indicates the
{       second position, and so on.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{      to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$form_not_scheduled
{                              fde$form_pushed
{                              fde$invalid_form_identifier
{                              fde$invalid_object_name
{                              fde$invalid_character_position
{                              fde$no_object_variable_defined
{                              fde$no_space_available
{                              fde$system_error
{                              fde$unknown_object_name
{                              fde$unknown_occurrence
{
*DECK DECK=FDH$SET_DISPLAY_ATTRIBUTES EXPAND=FALSE
{   The purpose of this request is to set the non specified attributes for an
{ object.
{
{       FDP$SET_DISPLAY_ATTRIBUTES (FORM_DISPLAY_ATTRIBUTES,
{         OBJECT_DISPLAY_ATTRIBUTES, DISPLAY_ATTRIBUTE_SET)
{
{ FORM_DISPLAY_ATTRIBUTES: (input)  This parameter specificies the set of
{       display attributes for the form.
{
{ OBJECT_DISPLAY_ATTRIBUTES: (input)  This parameter specificies the set of
{       application defined display attributes for the object.
{
{ DISPLAY_ATTRIBUTE_SET: (output)  This specifies the complete set of display
{       attributes to be stored for the object definition.
*DECK DECK=FDH$SET_LINE_MODE EXPAND=FALSE
{
{   The purpose of this request is to begin line interaction with a terminal
{ user after using Screen Formatting.  The request releases all resources
{ involved with processing forms.
{
{       FDP$SET_LINE_MODE (STATUS)
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition_identifiers:  fde$bad_data_value
{
*DECK DECK=FDH$SET_OBJECT_ATTRIBUTE EXPAND=FALSE
{
{   The purpose of this request is to set a display attribute for an object.
{ The specified attribute replaces any existing attribute.  This request does
{ not display the form.  Follow this request with a fdp$show_forms or
{ fdp$read_forms request to display the form.  You cannot set the attribute of
{ a pushed form.  The form must currently be added.
{
{       FDP$SET_OBJECT_ATTRIBUTE (FORM_IDENTIFIER, OBJECT_NAME, OCCURRENCE,
{         ATTRIBUTE, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form to the attribute.
{
{ OBJECT_NAME: (input)  This parameter specifies the name of the variable,
{       line, or box to set an attribute.
{
{ OCCURRENCE: (input)  This parameter specifies the occurrence of the object
{       name.  For the first occurrence or only occurrence of an object_name,
{       use 1.
{
{ ATTRIBUTE: (input)  This parameter specifies the name of a display
{       attribute.  You may specify any attribute.
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$form_not_scheduled
{                              fde$form_pushed
{                              fde$invalid_form_identifier
{                              fde$invalid_occurrence
{                              fde$no_space_available
{                              fde$unknown_display_name
{                              fde$unknown_object_name
{                              fde$unknown_occurrenc
{
*DECK DECK=FDH$SET_SCREEN_CURSOR EXPAND=FALSE
{   The purpose of this request is to set the cursor on the terminal screen.
{
{       FDP$SET_SCREEN_CURSOR (STATUS)
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of request.
{
*DECK DECK=FDH$SHOW_FORMS EXPAND=FALSE
{
{   The purpose of this request is to write the scheduled list of forms to the
{ screen.  If a form is not already displayed on the screen, fdp$show_forms
{ writes the entire form overlaying any forms that lie beneath it.  If a form
{ is already displayed as a result of a previous fdp$read_forms or
{ fdp$show_forms request then only writes objects which have changed values or
{ display attributes.  Use this request when no form(s) have an active event or
{ input variable.
{
{       FDP$SHOW_FORMS (STATUS)
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$no_forms_to_show
{                              fde$no_forms_to_show
{                              fde$system_error
{                              fde$terminal_disconnected
{
*DECK DECK=FDH$TAB_TO_NEXT_FIELD EXPAND=FALSE
{
{    The purpose of this request is to position the cursor to the next input
{ field from the current cursor position.
{
{       FDP$TAB_TO_NEXT_FIELD (STATUS)
{
{ STATUS: (output)  This parameter specifies the request status.
{
{       CONDITIONS:  fde$bad_data_value
{                    fde$no_forms_to_tab
{                    fde$no_space_available
{                    fde$system_error
{
*DECK DECK=FDH$TAB_TO_NEXT_VARIABLE EXPAND=FALSE
{
{    The purpose of this request is to position the cursor to the next input variable
{ field in the form from the specified object.
{
{       FDP$TAB_TO_NEXT_VARIABLE (P_FORMS_STATUS, OBJECT_INDEX, STATUS)
{
{ P_FORM_STATUS: (input)  This parameter specifies the form status record for
{       the form containing the cursor.
{
{ OBJECT_INDEX: (output)  This parameter returns the index of the object
{       in the form that marks the beginning of the search.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=FDH$UPDATE_SCREEN EXPAND=FALSE
{   The purpose of this request is to update the terminal screen.
{
{       FDP$UPDATE_SCREEN (STATUS)
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of request.
{
{       condition identifiers:  fde$system_error
{                               fde$terminal_disconnected
{                               fde$terminal_not_identified
{
{
*DECK DECK=FDH$VALIDATE_COBOL_DATA EXPAND=FALSE
{
{   The purpose of this request is to validate COBOL data.
{
{       FDP$VALIDATE_COBOL_DATA (P_FORM_STATUS, P_FORM_VARIABLE_DEFINITION,
{         P_PROGRAM_VARIABLE, P_VALID_STRING, VARIABLE_STATUS)
{
{ P_FORM_STATUS: (input)  A pointer to the form status data.
{
{             P_FORM_VARIABLE_DEFINITION (input) A pointer to the form variable
{               definition.
{
{ P_PROGRAM_VARIABLE: (input)  A pointer to the program variable.
{
{ P_VALID_STRING: (output)  A pointer to the valid string.  IF NIL no valid
{       string applies.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the status of the
{       variable.
{
{       value:  fdc$no_error fdc$invalid_integer fdc$invalid_real
{             fdc$invalid_string
*DECK DECK=FDH$VALIDATE_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to validate a variable value.
{
{       FDP$VALIDATE_VARIABLE (FORM_IDENTIFIER, VARIABLE_NAME, VARIABLE_VALUE,
{         VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  The form identifier.
{
{ VARIABLE_NAME: (input)  The name of the variable to validate.
{
{ VARIABLE_VALUE: (output)  The program value to validate.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the status of the
{       variable.
{
{       value:  fdc$no_error
{               fdc$invalid_integer
{               fdc$invalid_real
{               fdc$invalid_string
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{
*DECK DECK=FDH$WRITE_FORM_DEFINITION EXPAND=FALSE
{
{   The purpose of this request is to write a form definition to a file.  An
{ application dynamically defining a form would then call the Object Code
{ Utility to save the form on a object code library.  The form may not be
{ complete and may contain errors.
{
{       FDP$WRITE_FORM_DEFINITION (FORM_IDENTIFIER, P_FORM_MODULE, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ P_FORM_MODULE: (output)  This parameter specifies a pointer to a sequence to
{       hold the form module.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$invalid_form_identifier
{                              fde$no_space_available
{
*DECK DECK=FDH$WRITE_RECORD_DEFINITION EXPAND=FALSE
{
{   The purpose of this request is to write a Source Code Utility (SCU) deck
{ describing the record transferred between a program and Screen Formatting.
{ An application dynamically defining a form would then call SCU to update the
{ source code library.
{
{       FDP$WRITE_RECORD_DEFINITION (FORM_IDENTIFIER, FILE_IDENTIFIER,
{        FORM_PROCESSOR, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the Basic Access Methods
{       file identifier for a file on which the deck should be written.
{
{ FORM_PROCESSOR : (input) This parameter specifies the programming language
{       desired for the record definition.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers:  fde$bad_data_value
{                               fde$form_definition_errors
{                               fde$form_has_no_variables
{                               fde$form_not_ended
{                               fde$invalid_form_identifier
{                               fde$invalid_form_processor
{                               fde$record_defn_not_written
{
*DECK DECK=FDH$XADD_FORM EXPAND=FALSE
{
{   The purpose of this request is to add a form to the list of forms
{ scheduled for display on the screen.  The next request that updates the
{ screen, fdp$xread_forms or fdp$xshow_forms, replots the screen.  The
{ added form lies on top of other forms scheduled for display occupying the
{ same area on the screen.  A pushed form cannot be added.
{
{       FDP$XADD_FORM (FORM_IDENTIFIER, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form to add to the
{       list of forms scheduled for display.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the results of the request.
{
{       condition identifiers:  fde$bad_data_value
{                               fde$form_already_added
{                               fde$form_pushed
{                               fde$form_too_large_for_screen
{                               fde$invalid_form_identifier
{                               fde$no_space_available
{                               fde$system_error
{
*DECK DECK=FDH$XCHANGE_TABLE_SIZE EXPAND=FALSE
{   The purpose of this request is to change the size of table while a terminal
{ user interacts with a form.
{
{       FDP$XCHANGE_TABLE_SIZE (FORM_IDENTIFIER, TABLE_NAME, TABLE_SIZE,
{         STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the base form.
{
{ TABLE_NAME: (input)  This parameter specifies the name of the table.
{
{ TABLE_SIZE: (input)  This parameter specifies the size of the size of table.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of request.
{
{       condition identifiers:  fde$bad_data_value
{                               fde$form_pushed
{                               fde$invalid_form_identifier
{                               fde$invalid_table_name
{                               fde$invalid_table_size
{                               fde$unknown_table_name
{
*DECK DECK=FDH$XCLOSE_FORM EXPAND=FALSE
{
{   The purpose of this request is to release the system resources used to
{ process a form.  The request also deletes the form from the current list of
{ forms scheduled for display.  If the form is displayed when you use this
{ request, the next request that updates the screen, fdp$xshow_forms or
{ fdp$xread_forms, will remove the form from the terminal screen.  A form that
{ is currently pushed cannot be closed.
{
{       FDP$XCLOSE_FORM (FORM_IDENTIFIER, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form to close from
{       the list of forms.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition_identifiers:  fde$bad_data_value
{                               fde$form_pushed
{                               fde$invalid_form_identifier
{                               fde$no_space_available
{
*DECK DECK=FDH$XCOMBINE_FORM EXPAND=FALSE
{   The purpose of this request is to combine a form to the list of forms
{ associated with a base form.  The next request that updates the screen,
{ fdp$read_forms or fdp$show_forms, replots the screen for the terminal user.
{ The form lies on top of other forms occupying the same area on the screen.
{ You cannot combine a pushed form.
{
{       FDP$XCOMBINE_FORM (ADDED_FORM_IDENTIFIER, COMBINE_FORM_IDENTIFIER,
{         STATUS)
{
{ ADDED_FORM_IDENTIFIER: (input)  This parameter specifies the base form.
{
{ COMBINE_FORM_IDENTIFIER: (input)  This parameter specifies the new form to
{       combine with the base form.
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of request.
{
{       condition identifiers:  fde$bad_data_value
{                               fde$form_already_added
{                               fde$form_already_combined
{                               fde$form_pushed
{                               fde$form_too_large_for_screen
{                               fde$invalid_form_identifier
{                               fde$no_space_available
{                               fde$system_error
{
{
{
*DECK DECK=FDH$XDELETE_FORM EXPAND=FALSE
{
{   The purpose of this request is to delete a form from the list of forms
{ scheduled for display.  The next request that updates the screen,
{ fdp$xread_forms or fdp$xshow_forms, replots the screen.  When the screen
{ update occurs, any forms uncovered by the deleted form will be replotted.
{ The form remains open and can be added later.  A pushed form cannot be
{ deleted.
{
{       FDP$XDELETE_FORM (FORM_IDENTIFIER, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form to delete from
{       the list of forms scheduled for display.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the results of the request.
{
{       condition_identifiers:  fde$bad_data_value
{                               fde$form_pushed
{                               fde$invalid_form_identifier
{                               fde$no_space_available
{

*DECK DECK=FDH$XGET_INTEGER_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to get the value of a integer variable and
{ transfer it to the program.
{
{       FDP$XGET_INTEGER_VARIABLE (FORM_IDENTIFIER, VARIABLE_NAME,
{         VARIABLE_OCCURRENCE, VARIABLE, VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ VARIABLE_NAME: (input)  This parameter specifies the name of the variable.
{
{ VARIABLE_OCCURRENCE: (input)  This parameter specifies the occurrence of the
{       variable name.
{
{ VARIABLE: (output)  This parameter specifies the integer variable.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the ordinal which gives
{       the status of the variable.
{
{       value:  fdc$no_error
{               fdc$invalid_integer
{               fdc$invalid_bdp_data
{               fdc$no_digits
{               fdc$loss_of_significance
{
{ STATUS: (output) This parameter specifies the name of the variable to
{       set to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$invalid_form_identifier
{                              fde$invalid_variable_name
{                              fde$system_error
{                              fde$unknown_occurrence
{
{
{
{
{
*DECK DECK=FDH$XGET_NEXT_CHANGED_VARIABLE EXPAND=FALSE
{
{    The purpose of this request is to return the name of the next variable
{ changed by the terminal user in the form.  The form cannot be pushed.
{
{       FDP$XGET_NEXT_CHANGED_VARIABLE (FORM_IDENTIFIER, VARIABLE_NAME,
{             OCCURRENCE, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ VARIABLE_NAME: (output)  This parameter specifies the name of the changed
{       variable.
{
{ OCCURRENCE: (output)  This parameter specifies the occurrence of the variable
{       name.
{
{ CHANGE_FOUND: (output)  This parameter specifies whether a changed variable
{       was found.  If a changed variable was found, change_found equals "T".
{       Otherwise, change_found is equal to "F".
{
{ STATUS: (output)  This parameter specifies the request status.
{
{       CONDITIONS:  fde$bad_data_value
{                    fde$invalid_form_identifier
{                    fde$no_space_available
{                    fde$system_error
{
*DECK DECK=FDH$XGET_NEXT_EVENT EXPAND=FALSE
{
{   The purpose of this request is to get the next event that occurred as a
{ result of a fdp$xread_forms request.  Before accepting input from the
{ terminal user, the fdp$xread_forms request deletes any existing events.
{
{       FDP$XGET_NEXT_EVENT (EVENT_NAME, EVENT_NORMAL, SCREEN_X_POSITION,
{         SCREEN_Y_POSITION, FORM_IDENTIFIER, FORM_X_POSITION,
{         FORM_Y_POSITION, EVENT_TYPE, OBJECT_NAME, OBJECT_OCCURRENCE,
{         CHARACTER_POSITION, OBJECT_TYPE, OBJECT_X_POSITION,
{         OBJECT_Y_POSITION, LAST_EVENT, STATUS)
{
{ EVENT_NAME: (output)  This parameter specifies the name of the event.
{
{ EVENT_NORMAL: (output)  This parameter specifies a normal/abnormal event.
{       If the terminal user entered an event defined as normal, event
{       equals "T".  Otherwise, event_normal is equal to "F".
{
{ SCREEN_X_POSITION: (output)  This parameter specifies the screen x position
{       where the event occurred.
{
{ SCREEN_Y_POSITION: (output)  This parameter specifies the screen y position
{       where the event occurred.
{
{ FORM_IDENTIFIER: (output)  This parameter specifies the form identifier
{       where the event occurred.
{
{ FORM_X_POSITION: (output)  This parameter specifies the form x position
{       where the event occurred.
{
{ FORM_Y_POSITION: (output)  This parameter specifies the form y position
{       where the event occurred.
{
{ EVENT_TYPE: (output)  This parameter specifies the event type.
{
{       value:  0 - The event occurred on an area of the form that contained
{                   no object.
{               1 - The event occurred on a form object.
{
{ OBJECT_NAME: (output)  This parameter specifies the name of the object where
{       the event occurred.  This parameter has meaning only if object_type
{       equals 1.
{
{ OBJECT_OCCURRENCE: (output)  This parameter specifies the occurrence of the
{       object name where the event occurred.  This parameter has meaning only
{       if object_type equals 1.
{
{ CHARACTER_POSITION: (output)  This parameter specifies the character
{       position within an object where the event occurred.  This parameter
{       has meaning only if object_type equals 1.  A character position of 1
{       indicates the first position.
{
{ OBJECT_TYPE: (output)  This parameter specifies the object type where the
{       event occurred.  This parameter has meaning only if object_type equals
{       1.
{
{        value:  0 - The event occurred on a box object.
{                1 - The event occurred on a constant text object.
{                2 - The event occurred on a constant text box object.
{                3 - The event occurred on a line object.
{                5 - The event occurred on a variable text object.
{                6 - The event occurred on a variable text box object.
{
{ OBJECT_X_POSITION: (output)  This parameter specifies the origin x position
{       of the object.  This parameter has meaning only if object_type equals
{       1.
{
{ OBJECT_Y_POSITION: (output)  This parameter specifies the origin y position
{       of the object.  This parameter has meaning only if object_type equals
{       1.
{
{ LAST_EVENT: (output)  This parameter specifies if more events  exist.
{        Last_event equals "T" is this is the last event.  Otherwise,
{        last_event equals "F".
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{        condition identifiers: fde$bad_data_value
{
*DECK DECK=FDH$XGET_NEXT_INPUT_ERROR EXPAND=FALSE
{
{    The purpose of this request is to get the next variable with input errors
{ in the form record.  The form cannot be pushed.
{
{       FDP$XGET_NEXT_INPUT_ERROR (FORM_IDENTIFIER, VARIABLE_NAME, OCCURRENCE,
{             VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the open instance of the form.
{
{ VARIABLE_NAME: (output)  This parameter specifies the name of the variable
{       containing the error.
{
{ OCCURRENCE: (output)  This parameter specifies the occurrence of the variable
{       name.
{
{ VARIABLE_STATUS: (output)  This parameter specifies an ordinal which gives
{       the status of the variable.  FDC$NO_ERROR means that there are no
{       further input errors in the form record. The possible values are
{       the same as those described by FDH$XGET_RECORD.
{
{ STATUS: (output)  This parameter specifies the request status.
{
{       CONDITIONS:  fde$bad_data_value
{                    fde$form_pushed
{                    fde$invalid_form_identifier
{                    fde$no_space_available
{                    fde$system_error
{

*DECK DECK=FDH$XGET_NEXT_OUTPUT_ERROR EXPAND=FALSE
{
{    The purpose of this request is to get the next variable with output errors
{ in the form record.  The form cannot be pushed.
{
{       FDP$XGET_NEXT_OUTPUT_ERROR (FORM_IDENTIFIER, VARIABLE_NAME, OCCURRENCE,
{             VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the open instance of the form.
{
{ VARIABLE_NAME: (output)  This parameter specifies the name of the variable
{       containing the error.
{
{ OCCURRENCE: (output)  This parameter specifies the occurrence of the variable
{       name.
{
{ VARIABLE_STATUS: (output)  This parameter specifies an ordinal which gives
{       the status of the variable.  FDC$NO_ERROR means that there are no
{       further output errors in the form record. The possible values are
{       the same as those described by FDH$XREPLACE_RECORD.
{
{ STATUS: (output)  This parameter specifies the request status.
{
{       CONDITIONS:  fde$bad_data_value
{                    fde$form_pushed
{                    fde$invalid_form_identifier
{                    fde$no_space_available
{                    fde$system_error
{
*DECK DECK=FDH$XGET_REAL_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to get the value of a real variable from a
{ form and transfers it to the program.  The form must not be pushed.
{
{       FDP$XGET_REAL_VARIABLE (FORM_IDENTIFIER, VARIABLE_NAME,
{         VARIABLE_OCCURRENCE, VARIABLE, VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ VARIABLE_NAME: (input)  This parameter specifies the name of the variable to
{       get.
{
{ VARIABLE_OCCURRENCE: (input)  This parameter specifies the occurrence of the
{       variable name.
{
{ VARIABLE: (output)  This parameter specifies the real variable.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the ordinal which gives
{       the status of the variable.
{
{       Value:  fdc$no_error
{               fdc$invalid_real
{               fdc$invalid_bdp_data
{               fdc$no_digits
{               fdc$loss_of_significance
{               fdc$overflow
{               fdc$underflow
{               fdc$infinite
{               fdc$indefinite
{
{ STATUS: (output) This parameter specifies the name of the variable
{       to set to indicate the results of the request.
{
{       condition identifiers: fde$form_not_scheduled
{                              fde$form_pushed
{                              fde$invalid_form_identifier
{                              fde$system_error
{                              fde$unknown_occurrence
{                              fde$unknown_variable_name
{
{
*DECK DECK=FDH$XGET_RECORD EXPAND=FALSE
{
{   The purpose of this request is to transfer the current values of form
{ variables to your program variables.  If you issue this request after a
{ fdp$xopen_form or a fdp$xreset_form request, the values specified in the
{ form definition are returned.  This object routine does not display the
{ form.  Use the fdp$xshow_forms or fdp$xread_forms object routine to
{ display the form.  You cannot get the variables for a pushed form.
{
{       FDP$XGET_RECORD (FORM_IDENTIFIER, WORK_AREA, VARIABLE_STATUS,
{         STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier
{       for the open instance of the form.
{
{ WORK_AREA: (input)  This parameter specifies the program work area for
{       the variables.
{
{ VARIABLE_STATUS: (output)  This parameter specifes an ordinal which gives
{       the status of the variable.
{
{       value:  fdc$no_error
{               fdc$invalid_string
{               fdc$invalid_real
{               fdc$invalid_integer
{               fdc$invalid_bdp_data
{               fdc$no_digits
{               fdc$loss_of_significance
{               fdc$underflow
{               fdc$indefinite
{               fdc$overflow
{               fdc$infinite
{
{ STATUS: (output)  This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers:  fde$bad_data-value
{                               fde$form_has_no_variables
{                               fde$invalid_form_identifier
{                               fde$work_area_invalid
{                               fde$system_error
{
*DECK DECK=FDH$XGET_STRING_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to get the value of a string variable from
{ a form and transfer it to your program.
{
{       FDP$XGET_STRING_VARIABLE (FORM_IDENTIFIER, VARIABLE_NAME,
{         VARIABLE_OCCURRENCE, VARIABLE, VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ VARIABLE_NAME: (input)  This parameter specifies the name of the variable.
{
{ VARIABLE_OCCURRENCE: (input)  This parameter specifies the occurrence of the
{       variable name.
{
{ VARIABLE: (output)  This parameter specifies the string variable.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the ordinal which gives
{       the status of the variable.
{
{       value:  fdc$no_error
{               fdc$invalid_string
{
{ STATUS: (output) This parameter specifies the name of the variable
{       to set to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$invalid_form_identifier
{                              fde$invalid_variable_name
{                              fde$system_error
{                              fde$unknown_occurrence
{
*DECK DECK=FDH$XOPEN_FORM EXPAND=FALSE
{
{   The purpose of this request is to prepare a form for use by the program.
{ If the form_name is equal to spaces, then the form_identifier
{ specifies a dynamically created form.  Otherwise, Screen Formatting
{ locates the desired form by first searching the list of dynamically
{ created forms and then the forms specified by the command library list.
{ The set_command_list specifies the command library list.
{ Fdp$open_form does not display the form on
{ the screen.  A form must be opened using fdp$open_form before the form can
{ be used by any other request.  The form_identifier returned by this request
{ identifies the instance of open for a form.  The same form may have a number
{ of open instances.  For each instance Screen Formatting maintains the
{ working environment of the form.  The working environment includes the
{ current value of variables and their display attributes.
{
{       FDP$XOPEN_FORM (FORM_NAME, FORM_IDENTIFIER, STATUS)
{
{ FORM_NAME: (input)  This parameter specifies the name of the form to open.
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form_identifier
{       that Screen Formatting has assigned to this instance of open.
{       Other Screen Formatting object routines use the form identifier
{       to reference this instance of open.
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$form_already_open
{                              fde$form_not_ended
{                              fde$form_requires_conversion
{                              fde$invalid_form_identifier
{                              fde$invalid_form_name
{                              fde$no_space_available
{                              fde$system_errors
{                              fde$unknown_form_name
{
*DECK DECK=FDH$XPOP_FORMS EXPAND=FALSE
{
{   The purpose of this request is to delete the last added list of forms
{ scheduled for display queued by the fdp$xpush_forms object routine.  All the
{ forms scheduled for display can accept events executed by the terminal user.
{ The fdp$xpop_forms object routine does not update the screen.  A
{ fdp$xread_forms or fdp$xshow_forms request updates the terminal screen.
{
{       FDP$XPOP_FORMS (STATUS)
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the results of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$no_forms_to_pop
{
*DECK DECK=FDH$XPOSITION_FORM EXPAND=FALSE
{
{   The purpose of this request is to position a form to a new screen location.
{ This allows you to define a form at one location and then to display it at
{ another location or to move a form from its currently displayed location to
{ another location that is more convenient for the terminal user.  If you
{ issue this request before the form is displayed, then the form will be
{ displayed at the specified location.  If you issue this request when the
{ form is displayed, the form will be deleted from its current location and
{ added at the new location.  The next request that updates the screen,
{ fdp$xread_forms or fdp$xshow_forms, will replot the screen for the terminal
{ user.  Any forms uncovered by the deleted form will be replotted.  The added
{ form lies on top of other forms occupying the same area on the screen.  You
{ cannot position a pushed form.
{
{       FDP$XPOSITION_FORM (FORM_IDENTIFIER, SCREEN_X_POSITION,
{         SCREEN_Y_POSITION, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form to position.
{
{ SCREEN_X_POSITION: (input)  This parameter specifies the x position of the
{       form on the screen.  The first x position is the first character of
{       the top line of the screen.  The first x position is numbered 1.  The
{       x position increases by 1 for each character position on the screen
{       from left to right.
{
{ SCREEN_Y_POSITION: (input)  The parameter specifies the y position of the
{       form with respect to the screen.  The first screen y position is the
{       first character on the top line of the screen.  The first y position
{       is numbered 1.  The y position increases by one for each line of the
{       form going from top to bottom.
{
{ STATUS: (output) This parameter specifies the integer variable to set to
{       indicate the results of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$form_already_added
{                              fde$form_pushed
{                              fde$form_not_scheduled
{                              fde$form_too_large_for_screen
{                              fde$invalid_form_identifier
{                              fde$no_space_available
{                              fde$system_error
{
*DECK DECK=FDH$XPUSH_FORMS EXPAND=FALSE
{
{   The purpose of this request is to queue the current list of forms
{ scheduled for display in a last in, first out queue.  The fdp$xpop_forms
{ request can be used to dequeue the last in list of forms.  Events associated
{ with the forms are not considered as active and are not passed to the
{ program.  The queue may contain more than one list of forms.
{
{       FDP$XPUSH_FORMS (STATUS)
{
{ STATUS: (output) This parameter specifies the name of the variable to set
{       to indicate the status of the request.
{
{       condition identifier: fde$bad_data_value
{                             fde$no_forms_to_push
{

*DECK DECK=FDH$XREAD_FORMS EXPAND=FALSE
{
{   The purpose of this request is to update the user's terminal screen, if
{ necessary, and accept input from the terminal user.  Any events which the
{ program has not retrieved with the fdp$xget_next_event request are deleted
{ before accepting input from the terminal user.
{
{       FDP$XREAD_FORMS (STATUS)
{
{ STATUS: (output) This parameter specifies the variable to set
{       to indicate the results of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$no_events_active
{                              fde$no_forms_to_read
{                              fde$system_errors
{                              fde$terminal_disconnected
{
*DECK DECK=FDH$XREPLACE_INTEGER_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to transfer an integer program variable to
{ form storage.  Form storage holds the values Screen Formatting uses to
{ update the screen or to return to a program.  You cannot replace a variable
{ for a pushed form.
{
{       FDP$XREPLACE_INTEGER_VARIABLE (FORM_IDENTIFIER, VARIABLE_NAME,
{         VARIABLE_OCCURRENCE, VARIABLE, VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ VARIABLE_NAME: (input)  This parameter specifies the name of the variable to
{       replace.
{
{ VARIABLE_OCCURRENCE: (input)  This parameter specifies the occurrence of the
{       variable name.
{
{ VARIABLE: (input)  This parameter specifies the integer variable to replace.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the integer which gives
{       the status of the variable.
{
{       value:  fdc$no_error
{               fdc$loss_of_significance
{               fdc$output_format_bad
{
{ STATUS: (output) This parameter specifies the name of the variable to set to
{       indicate the results of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$form_pushed
{                              fde$invalid_form_identfier
{                              fde$invalid_variable_name
{                              fde$no_space_available
{                              fde$system_error
{                              fde$unknown_occurrence
{
*DECK DECK=FDH$XREPLACE_REAL_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to transfer a real program variable to form
{ storage.  Form storage holds the values screen formatting uses to update the
{ screen or to return to a program.  You cannot replace a variable form a
{ pushed form.
{
{       FDP$XREPLACE_REAL_VARIABLE (FORM_IDENTIFIER, VARIABLE_NAME,
{         VARIABLE_OCCURRENCE, VARIABLE, VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ VARIABLE_NAME: (input)  This parameter specifies the name of the variable to
{       replace.
{
{ VARIABLE_OCCURRENCE: (input)  This parameter specifies the occurrence of the
{       variable name.
{
{ VARIABLE: (input)  This parameter specifies the real variable.
{
{ VARIABLE_STATUS: (output)  This parameter specifies a value which gives the
{       status of the variable.
{
{       value:  fdc$no_error
{               fdc$loss_of_significance
{               fdc$output_format_bad
{
{ STATUS: (output) This parameter specifies the name of the variable to
{       set to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$form_pushed
{                              fde$invalid_form_identfier
{                              fde$invalid_variable_name
{                              fde$no_space_available
{                              fde$system_error
{                              fde$unknown_occurrence
{
{
*DECK DECK=FDH$XREPLACE_RECORD EXPAND=FALSE
{
{   The purpose of this request is to transfer the values of program
{ variables to Screen Formatting for later display on the screen.
{ This object routine does not display the form.  Use the fdp$xshow_forms
{ or fdp$xread_forms object routine to display the form.  You cannot
{ update the variables of a pushed form.
{
{       FDP$XREPLACE_RECORD (FORM_IDENTIFIER, WORK_AREA,
{         VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the open instance of the form.
{
{ WORK_AREA: (input)  This parameter specifies the program work area for
{       variables.
{
{ VARIABLE_STATUS (output) This parameter specifies the variable
{       that gives the status of the variable.
{
{       value:  fdc$no_error
{               fdc$loss_of_significance
{               fdc$output_format_bad
{
{ STATUS: (output) This parameter specifies the name of the variable to
{       set to indicate the status of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$form_has_no_variables
{                              fde$form_pushed
{                              fde$invalid_form_identifier
{                              fde$no_space_available
{                              fde$work_area_invalid
{

*DECK DECK=FDH$XREPLACE_STRING_VARIABLE EXPAND=FALSE
{
{   The purpose of this request is to transfer a character program variable to
{ form storage.  Form storage holds the values Screen Formatting uses to
{ update the screen or to return to a program.  The form must be currently
{ open.  You cannot replace a variable from a pushed form.
{
{       FDP$XREPLACE_STRING_VARIABLE (FORM_IDENTIFIER, VARIABLE_NAME,
{         VARIABLE_OCCURRENCE, VARIABLE, VARIABLE_STATUS, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ VARIABLE_NAME: (input)  This parameter specifies the name of the variable.
{
{ VARIABLE_OCCURRENCE: (input)  This parameter specifies the occurrence of the
{       variable name.
{
{ VARIABLE: (input)  This parameter specifies the string variable.
{
{ VARIABLE_STATUS: (output)  This parameter specifies the variable which gives
{       the status of the variable.
{
{      value:  fdc$no_error
{
{ STATUS: (output) This parameter specifies  the name of the variable to set to
{       indicate the results of the request.
{
{      condition identifiers: fde$bad_data_value
{                             fde$form_pushed
{                             fde$invalid_form_identifier
{                             fde$invalid_variable_name
{                             fde$system_error
{                             fde$unknown_occurrence
{
{
*DECK DECK=FDH$XRESET_FORM EXPAND=FALSE
{
{   The purpose of this request is to initialize a form to the state
{ specified by the form definition.  A variable on the form will have
{ its initial value and initial display attribute.  Use a
{ fdp$xget_record, fdp$xget_integer_variable, fdp$xget_real_variable,
{ fdp$xget_string_variable request to transfer variable values to
{ your program.  The fdp$xreset_form object routine does not display
{ the form.  A fdp$xread_forms or a fdp$xshow_forms request will
{ update the screen.  A pushed form cannot be initialized.
{
{       FDP$XRESET_FORM (FORM_IDENTIFIER, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier
{       for the open instance of the form.
{
{ STATUS: (output) This parameter specifies the variable that indicates
{       the results of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$form_pushed
{                              fde$invalid_form_identifier
{                              fde$no_space_available
{                              fde$system_error
{

*DECK DECK=FDH$XRESET_OBJECT_ATTRIBUTE EXPAND=FALSE
{
{   The purpose of this request is to reset the display attribute for an
{ object to that specified in the form definition.  This request does not
{ display the form.  Follow this request with a fdp$xshow_forms or
{ fdp$xread_forms request to display the form.  The form must currently be
{ added.  You cannot reset the attribute of an object on a pushed form.
{
{       FDP$XRESET_OBJECT_ATTRIBUTE (FORM_IDENTIFIER, OBJECT_NAME,
{         OBJECT_OCCURRENCE, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ OBJECT_NAME: (input)  This parameter specifies a character variable that
{       contains the name of the object.
{
{ OBJECT_OCCURRENCE: (input)  This parameter specifies an integer that gives
{       the occurrence of the variable name.  Use 1 for the first or only
{       occurrence of an object.
{
{ STATUS: (output) This parameter specifies the variable that indicates
{       the results of the request.
{
{       condition identifier: fde$bad_data_value
{                             fde$form_pushed
{                             fde$form_not_scheduled
{                             fde$invalid_form_identifier
{                             fde$invalid_object_name
{                             fde$invalid_occurrence
{                             fde$no_space_available
{                             fde$unknown_object_name
{
{
*DECK DECK=FDH$XSET_CURSOR_POSITION EXPAND=FALSE
{
{   The purpose of this request is to set the form cursor to a specified
{ object for later display.  You may use this request to modify the default
{ sequence of the terminal user's entry of variable data.  The default
{ sequence proceeds from variable text to variable text going left to right on
{ each screen line and from top to bottom line.  The form must be currently
{ added.  The form cannot be pushed.
{
{       FDP$XSET_CURSOR_POSITION (FORM_IDENTIFIER, OBJECT_NAME,
{         OBJECT_OCCURRENCE, CHARACTER_POSITION, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ OBJECT_NAME: (input)  This parameter specifies the variable that contains
{       the object name where the cursor is to be positioned.
{
{ CHARACTER_POSITION: (input)  This parameter specifies the character position
{       within the object name where the cursor is to be positioned.  A
{       character position of 1 indicates the first position, a character
{       position of 2 indicates the second position, and so on.
{
{ STATUS: (output) This parameter specifies the name variable that
{      indicates the results of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$form_not_scheduled
{                              fde$form_pushed
{                              fde$invalid_form_identifier
{                              fde$invalid_object_name
{                              fde$invalid_character_position
{                              fde$no_object_variable_defined
{                              fde$no_space_available
{                              fde$system_error
{                              fde$unknown_object_name
{                              fde$unknown_occurrence
{

*DECK DECK=FDH$XSET_LINE_MODE EXPAND=FALSE
{
{   The purpose of this request is to set the terminal for a line by line
{ dialogue with the terminal user.  You typically use this object routine when
{ you are done interacting with a terminal user through forms.
{
{       FDP$XSET_LINE_MODE (STATUS)
{
{ STATUS: (output)  This parameter specifies the variable that indicates
{         the results of the request.
{
*DECK DECK=FDH$XSET_OBJECT_ATTRIBUTE EXPAND=FALSE
{
{   The purpose of this request is to change a display attribute for an
{ object.  For example, the attribute might alert a user about data
{ incorrectly entered for a variable.  The specified attribute replaces any
{ existing attribute.  This object routine does not display the form.  Follow
{ this object routine with a fdp$xshow_forms or fdp$xread_forms request to
{ display the form.  You cannot change the attributes of a pushed form.  The
{ form must be currently added in order to change the attribute of an object.
{
{       FDP$XSET_OBJECT_ATTRIBUTE (FORM_IDENTIFIER, OBJECT_NAME,
{         OBJECT_OCCURRENCE, ATTRIBUTE_NAME, STATUS)
{
{ FORM_IDENTIFIER: (input)  This parameter specifies the form identifier for
{       the instance of the form.
{
{ OBJECT_NAME: (input)  This parameter specifies name of the object to change
{       the display attributes.
{
{ OBJECT_OCCURRENCE: (input)  This parameter specifies an integer that gives
{       the occurrence of the object name.  Use 1 for the first or only
{       occurrence of an object.
{
{ ATTRIBUTE_NAME: (input)  This parameter specifies the name of a display
{       attribute.
{
{ STATUS: (output) This parameter specifies the variable that
{       indicate sthe sresultsof the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$form_not_scheduled
{                              fde$form_pushed
{                              fde$invalid_attribute_name
{                              fde$invalid_form_identifier
{                              fde$invalid_object_name
{                              fde$invalid_occurrence
{                              fde$no_space_available
{                              fde$unknown_display_name
{                              fde$unknown_object_name
{                              fde$unknown_occurrenc
{
*DECK DECK=FDH$XSHOW_FORMS EXPAND=FALSE
{
{   The purpose of this request is to write the scheduled list of forms to the
{ screen.  If a form is not already displayed on the screen, fdp$xshow_forms
{ displays the entire form overlaying any forms that lie beneath it.  If a
{ form is already displayed as a result of a previous fdp$xread_forms or
{ fdp$xshow_forms request, then only the changed objects are rewritten.  If a
{ form has variables, the variables are updated from the values set by the
{ fdp$xreplace_record, fdp$xreplace_integer_variable,
{ fdp$xreplace_real_variable, or fdp$xreplace_string_variable.
{
{       FDP$XSHOW_FORMS (STATUS)
{
{ STATUS: (output) This parameter specifies the variable that indicates
{       the results of the request.
{
{       condition identifiers: fde$bad_data_value
{                              fde$no_forms_to_show
{                              fde$no_forms_to_show
{                              fde$system_error
{                              fde$terminal_disconnected
{
*DECK DECK=FDH$XTAB_TO_NEXT_FIELD EXPAND=FALSE
{
{    The purpose of this request is to position the cursor to the next input
{ field from the current cursor position.
{
{       FDP$XTAB_TO_NEXT_FIELD (STATUS)
{
{ STATUS: (output)  This parameter specifies the request status.
{
{       CONDITIONS:  fde$bad_data_value
{                    fde$no_forms_to_tab
{                    fde$no_space_available
{                    fde$system_error
{
*DECK DECK=FDK$SCREEN_FORMATTING_KEYPOINTS EXPAND=FALSE
{ COMMON DECK FDK$SCREEN_FORMATTING_KEYPOINTS, DEFINES KEYPOINTS FOR
{ SCREEN FORMATTING PROCEDURES.

  CONST

    fdk$change_screen = fdk$base + 1,
    {E 'change_screen' }
    {X 'change_screen' }

    fdk$convert_to_program_variable = fdk$base + 2,
    {E 'convert_to_program_variable' }
    {X 'convert_to_program_variable' }

    fdk$convert_to_screen_variable = fdk$base + 3,
    {E 'fdp$convert_to_screen_variable' }
    {X 'fdp$convert_to_screen_variable' }

    fdk$create_screen_objects = fdk$base + 4,
    {E 'create_screen_objects' }
    {X 'create_screen_objects' }

    fdk$open_form = fdk$base + 5,
    {E 'fdp$open_form' }
    {X 'fdp$open_form' }

    fdk$read_forms = fdk$base + 6,
    {E 'fdp$read_forms' }
    {X 'fdp$read_forms' }

    fdk$show_forms = fdk$base + 7,
    {E 'fdp$show_forms' }
    {X 'fdp$show_forms' }

    fdk$format_screen_text = fdk$base + 8,
    {E 'format_screen_text' }
    {X 'format_screen_text' }

    fdk$get_terminal_input = fdk$base + 9;
    {E 'get_terminal_input' }
    {X 'get_terminal_input' }
*DECK DECK=FDM$COBOL_FORTRAN_REQUESTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Screen Formatting: Process COBOL and FORTRAN calls.' ??
MODULE fdm$cobol_fortran_requests;

{ PURPOSE:
{   This module process COBOL and FORTRAN calls to Screen Formatting.
{
{ DESIGN:
{   All COBOL and FORTRAN calls use data types common to these languages.
{   Convert COBOL and FORTRAN data types to CYBIL data types and call the
{   appropriate CYBIL procedure.

?? NEWTITLE := 'Global Declaractions Referenced by This Module', EJECT ??

*copyc fde$condition_identifiers
*copyc fdp$add_form
*copyc fdp$change_table_size
*copyc fdp$close_form
*copyc fdp$combine_form
*copyc fdp$delete_form
*copyc fdp$get_integer_variable
*copyc fdp$get_next_changed_variable
*copyc fdp$get_next_event
*copyc fdp$get_next_input_error
*copyc fdp$get_next_output_error
*copyc fdp$get_real_variable
*copyc fdp$get_record
*copyc fdp$get_string_variable
*copyc fdp$open_form
*copyc fdp$pop_forms
*copyc fdp$position_form
*copyc fdp$push_forms
*copyc fdp$read_forms
*copyc fdp$replace_integer_variable
*copyc fdp$replace_real_variable
*copyc fdp$replace_record
*copyc fdp$replace_string_variable
*copyc fdp$reset_form
*copyc fdp$reset_object_attribute
*copyc fdp$set_cursor_position
*copyc fdp$set_line_mode
*copyc fdp$set_object_attribute
*copyc fdp$show_forms
*copyc fdp$tab_to_next_field

*copyc osp$status_condition_number
*copyc osp$set_status_abnormal
*copyc osd$default_pragmats
*copyc ost$name
*copyc ost$status
*copyc osv$lower_to_upper

?? TITLE := 'FDP$XADD_FORM', EJECT ??
*copyc FDH$XADD_FORM

  PROCEDURE [XDCL] fdp$xadd_form
    (VAR form_identifier: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      x_form_identifier := form_identifier;
      fdp$add_form (x_form_identifier, x_status);
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xadd_form;

?? TITLE := 'FDP$XCHANGE_TABLE_SIZE', EJECT ??
*copy fdh$xchange_table_size

  PROCEDURE [XDCL] fdp$xchange_table_size
    (VAR form_identifier: integer;
     VAR table_name: string ( * );
     VAR table_size: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_table_name: ost$name,
      x_table_size: fdt$table_size,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      validate_name (table_name, x_status);
      IF x_status.normal THEN
        IF ((table_size < 0) OR (table_size > fdc$maximum_occurrence)) THEN
          osp$set_status_abnormal (fdc$format_display_identifier,
                fde$invalid_table_size, table_name, x_status);
          convert_status (x_status, status);
          RETURN;
        IFEND;
        x_form_identifier := form_identifier;
        x_table_name := table_name;
        x_table_size := table_size;
        fdp$change_table_size (x_form_identifier, x_table_name, x_table_size, x_status);
      IFEND;
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xchange_table_size;

?? TITLE := 'FDP$XCLOSE_FORM', EJECT ??
*copyc FDH$XCLOSE_FORM

  PROCEDURE [XDCL] fdp$xclose_form
    (VAR form_identifier: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      x_form_identifier := form_identifier;
      fdp$close_form (x_form_identifier, x_status);
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xclose_form;

?? TITLE := 'FDP$XCOMBINE_FORM', EJECT ??
*copy fdh$xcombine_form

  PROCEDURE [XDCL] fdp$xcombine_form
    (VAR added_form_identifier: integer;
     VAR combine_form_identifier: integer;
     VAR status: integer);

    VAR
      x_added_form_identifier: fdt$form_identifier,
      x_combine_form_identifier: fdt$form_identifier,
      x_status: ost$status;

    validate_form_identifier (added_form_identifier, x_status);
    IF x_status.normal THEN
      validate_form_identifier (combine_form_identifier, x_status);
      IF x_status.normal THEN
        x_added_form_identifier := added_form_identifier;
        x_combine_form_identifier := combine_form_identifier;
        fdp$combine_form (x_added_form_identifier, x_combine_form_identifier, x_status);
      IFEND;
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xcombine_form;

?? TITLE := 'FDP$XDELETE_FORM', EJECT ??
*copyc fdh$xdelete_form

  PROCEDURE [XDCL] fdp$xdelete_form
    (VAR form_identifier: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      x_form_identifier := form_identifier;
      fdp$delete_form (x_form_identifier, x_status);
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xdelete_form;

?? TITLE := 'FDP$XGET_INTEGER_VARIABLE', EJECT ??
*copyc fdh$xget_integer_variable

  PROCEDURE [XDCL] fdp$xget_integer_variable
    (VAR form_identifier: integer;
     VAR variable_name: string ( * );
     VAR variable_occurrence: integer;
     VAR variable: integer;
     VAR variable_status: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_variable_name: ost$name,
      x_variable_occurrence: fdt$occurrence,
      x_variable_status: fdt$variable_status,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      validate_name (variable_name, x_status);
      IF x_status.normal THEN
        validate_occurrence (variable_occurrence, x_status);
        IF x_status.normal THEN
          x_variable_name := variable_name;
          x_variable_occurrence := variable_occurrence;
          x_form_identifier := form_identifier;
          fdp$get_integer_variable (x_form_identifier, x_variable_name, x_variable_occurrence, variable,
                x_variable_status, x_status);
          IF x_status.normal THEN
            convert_variable_status (x_variable_status, variable_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xget_integer_variable;

?? TITLE := 'FDP$XGET_NEXT_CHANGED_VARIABLE', EJECT ??
*copyc fdh$xget_next_changed_variable

  PROCEDURE [XDCL] fdp$xget_next_changed_variable
    (VAR form_identifier: integer;
     VAR variable_name: string ( * );
     VAR occurrence: integer;
     VAR change_found: string (1);
     VAR status: integer);

    VAR
      x_change_found: boolean,
      x_form_identifier: fdt$form_identifier,
      x_occurrence: fdt$occurrence,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    change_found := 'F';
    IF x_status.normal THEN
      x_form_identifier := form_identifier;
      fdp$get_next_changed_variable (x_form_identifier, variable_name, x_occurrence, x_change_found,
            x_status);
      IF x_change_found THEN
        change_found := 'T';
        occurrence := x_occurrence;
      IFEND;
    IFEND;
    convert_status (x_status, status);

  PROCEND fdp$xget_next_changed_variable;
?? TITLE := 'FDP$XGET_NEXT_EVENT', EJECT ??
*copyc fdh$xget_next_event

  PROCEDURE [XDCL] fdp$xget_next_event
    (VAR event_name: string ( * );
     VAR event_normal: string (1);
     VAR screen_x_position: integer;
     VAR screen_y_position: integer;
     VAR form_identifier: integer;
     VAR form_x_position: integer;
     VAR form_y_position: integer;
     VAR event_type: integer;
     VAR object_name: string ( * );
     VAR object_occurrence: integer;
     VAR character_position: integer;
     VAR object_type: integer;
     VAR object_x_position: integer;
     VAR object_y_position: integer;
     VAR last_event: string (1);
     VAR status: integer);

    VAR
      x_event_name: ost$name,
      x_event_normal: boolean,
      x_event_position: fdt$event_position,
      x_last_event: boolean,
      x_status: ost$status;

    fdp$get_next_event (x_event_name, x_event_normal, x_event_position, x_last_event, x_status);
    IF x_status.normal THEN

      IF x_last_event THEN
        last_event := 'T';
      ELSE
        last_event := 'F';
      IFEND;

      IF x_event_normal THEN
        event_normal := 'T';
      ELSE
        event_normal := 'F';
      IFEND;

      event_name := x_event_name;
      screen_x_position := x_event_position.screen_x_position;
      screen_y_position := x_event_position.screen_y_position;
      form_identifier := x_event_position.form_identifier;
      form_x_position := x_event_position.form_x_position;
      form_y_position := x_event_position.form_y_position;
      CASE x_event_position.key OF

      = fdc$form_event =
        event_type := $INTEGER (fdc$form_event);

      = fdc$object_event =
        event_type := $INTEGER (fdc$object_event);
        object_name := x_event_position.object_name;
        object_occurrence := x_event_position.object_occurrence;
        object_x_position := x_event_position.object_x_position;
        object_y_position := x_event_position.object_y_position;

        object_type := $INTEGER (x_event_position.object_definition_key);

        CASE x_event_position.object_definition_key OF

        = fdc$variable_text, fdc$variable_text_box =
          character_position := x_event_position.character_position;

        ELSE
        CASEND;
      ELSE
      CASEND;
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xget_next_event;
?? TITLE := 'FDP$XGET_NEXT_INPUT_ERROR', EJECT ??
*copyc fdh$xget_next_input_error

  PROCEDURE [XDCL] fdp$xget_next_input_error
    (VAR form_identifier: integer;
     VAR variable_name: string ( * );
     VAR occurrence: integer;
     VAR variable_status: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_occurrence: fdt$occurrence,
      x_variable_status: fdt$variable_status,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      x_form_identifier := form_identifier;
      fdp$get_next_input_error (x_form_identifier, variable_name, x_occurrence, x_variable_status, x_status);
      IF x_status.normal THEN
        convert_variable_status (x_variable_status, variable_status);
        occurrence := x_occurrence;
      IFEND;
    IFEND;
    convert_status (x_status, status);

  PROCEND fdp$xget_next_input_error;
?? TITLE := 'FDP$XGET_NEXT_OUTPUT_ERROR', EJECT ??
*copyc fdh$xget_next_output_error

  PROCEDURE [XDCL] fdp$xget_next_output_error
    (VAR form_identifier: integer;
     VAR variable_name: string ( * );
     VAR occurrence: integer;
     VAR variable_status: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_occurrence: fdt$occurrence,
      x_variable_status: fdt$variable_status,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      x_form_identifier := form_identifier;
      fdp$get_next_output_error (x_form_identifier, variable_name, x_occurrence, x_variable_status, x_status);
      IF x_status.normal THEN
        convert_variable_status (x_variable_status, variable_status);
        occurrence := x_occurrence;
      IFEND;
    IFEND;
    convert_status (x_status, status);

  PROCEND fdp$xget_next_output_error;
?? TITLE := 'FDP$XGET_REAL_VARIABLE', EJECT ??
*copyc fdh$xget_real_variable

  PROCEDURE [XDCL] fdp$xget_real_variable
    (VAR form_identifier: integer;
     VAR variable_name: string ( * );
     VAR variable_occurrence: integer;
     VAR variable: real;
     VAR variable_status: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_variable_name: ost$name,
      x_variable_occurrence: fdt$occurrence,
      x_variable_status: fdt$variable_status,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      validate_name (variable_name, x_status);
      IF x_status.normal THEN
        validate_occurrence (variable_occurrence, x_status);
        IF x_status.normal THEN
          x_variable_name := variable_name;
          x_variable_occurrence := variable_occurrence;
          x_form_identifier := form_identifier;
          fdp$get_real_variable (x_form_identifier, x_variable_name, x_variable_occurrence, variable,
                x_variable_status, x_status);
          IF x_status.normal THEN
            convert_variable_status (x_variable_status, variable_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xget_real_variable;

?? TITLE := 'FDP$XGET_RECORD', EJECT ??
*copyc fdh$xget_record

  PROCEDURE [XDCL] fdp$xget_record
    (VAR form_identifier: integer;
     VAR work_area: string (*);
     VAR variable_status: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_variable_status: fdt$variable_status,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      x_form_identifier := form_identifier;
      fdp$get_record (x_form_identifier, ^work_area, STRLENGTH (work_area),
            x_variable_status, x_status);
      IF x_status.normal THEN
        convert_variable_status (x_variable_status, variable_status);
      IFEND;
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xget_record;

?? TITLE := 'FDP$XGET_STRING_VARIABLE', EJECT ??
*copyc fdh$xget_string_variable

  PROCEDURE [XDCL] fdp$xget_string_variable
    (VAR form_identifier: integer;
     VAR variable_name: string ( * );
     VAR variable_occurrence: integer;
     VAR variable: string ( * );
     VAR variable_status: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_variable_name: ost$name,
      x_variable_occurrence: fdt$occurrence,
      x_variable_status: fdt$variable_status,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      validate_name (variable_name, x_status);
      IF x_status.normal THEN
        validate_occurrence (variable_occurrence, x_status);
        IF x_status.normal THEN
          x_variable_name := variable_name;
          x_variable_occurrence := variable_occurrence;
          x_form_identifier := form_identifier;
          fdp$get_string_variable (x_form_identifier, x_variable_name, x_variable_occurrence, variable,
                x_variable_status, x_status);
          IF x_status.normal THEN
            convert_variable_status (x_variable_status, variable_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xget_string_variable;

?? TITLE := 'FDP$XOPEN_FORM', EJECT ??
*copyc fdh$xopen_form

  PROCEDURE [XDCL] fdp$xopen_form
    (VAR form_name: string ( * );
     VAR form_identifier: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_form_name: ost$name,
      x_status: ost$status;

    validate_name (form_name, x_status);
    IF x_status.normal THEN
      x_form_name := form_name;
      fdp$open_form (x_form_name, x_form_identifier, x_status);
      form_identifier := x_form_identifier;
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xopen_form;

?? TITLE := 'FDP$XPOP_FORMS', EJECT ??
*copyc fdh$xpop_forms

  PROCEDURE [XDCL] fdp$xpop_forms
    (VAR status: integer);

    VAR
      x_status: ost$status;

    fdp$pop_forms (x_status);
    convert_status (x_status, status);
  PROCEND fdp$xpop_forms;

?? TITLE := 'FDP$XPOSITION_FORM', EJECT ??
*copyc fdh$xposition_form

  PROCEDURE [XDCL] fdp$xposition_form
    (VAR form_identifier: integer;
     VAR screen_x_position: integer;
     VAR screen_y_position: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_screen_x_position: fdt$x_position,
      x_screen_y_position: fdt$y_position,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);

    IF x_status.normal THEN
      validate_x_position (screen_x_position, x_status);
      IF x_status.normal THEN
        validate_y_position (screen_y_position, x_status);
        IF x_status.normal THEN
          x_form_identifier := form_identifier;
          x_screen_x_position := screen_x_position;
          x_screen_y_position := screen_y_position;
          fdp$position_form (x_form_identifier, x_screen_x_position, x_screen_y_position, x_status);
        IFEND;
      IFEND;
    IFEND;
    convert_status (x_status, status);

  PROCEND fdp$xposition_form;

?? TITLE := 'FDP$XPUSH_FORMS', EJECT ??
*copyc fdh$xpush_forms

  PROCEDURE [XDCL] fdp$xpush_forms
    (VAR status: integer);

    VAR
      x_status: ost$status;

    fdp$push_forms (x_status);
    convert_status (x_status, status);
  PROCEND fdp$xpush_forms;

?? TITLE := 'FDP$XREAD_FORMS', EJECT ??
*copyc fdh$xread_forms

  PROCEDURE [XDCL] fdp$xread_forms
    (VAR status: integer);

    VAR
      x_status: ost$status;

    fdp$read_forms (x_status);
    convert_status (x_status, status);
  PROCEND fdp$xread_forms;

?? TITLE := 'FDP$XREPLACE_INTEGER_VARIABLE', EJECT ??
*copyc fdh$xreplace_integer_variable

  PROCEDURE [XDCL] fdp$xreplace_integer_variable
    (VAR form_identifier: integer;
     VAR variable_name: string ( * );
     VAR variable_occurrence: integer;
     VAR variable: integer;
     VAR variable_status: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_variable_name: ost$name,
      x_variable_occurrence: fdt$occurrence,
      x_variable_status: fdt$variable_status,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      validate_name (variable_name, x_status);
      IF x_status.normal THEN
        validate_occurrence (variable_occurrence, x_status);
        IF x_status.normal THEN
          x_variable_name := variable_name;
          x_variable_occurrence := variable_occurrence;
          x_form_identifier := form_identifier;
          fdp$replace_integer_variable (x_form_identifier, x_variable_name, x_variable_occurrence, variable,
                x_variable_status, x_status);
          IF x_status.normal THEN
            convert_variable_status (x_variable_status, variable_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xreplace_integer_variable;

?? TITLE := 'FDP$XREPLACE_REAL_VARIABLE', EJECT ??
*copyc fdh$xreplace_real_variable

  PROCEDURE [XDCL] fdp$xreplace_real_variable
    (VAR form_identifier: integer;
     VAR variable_name: string ( * );
     VAR variable_occurrence: integer;
     VAR variable: real;
     VAR variable_status: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_variable_name: ost$name,
      x_variable_occurrence: fdt$occurrence,
      x_variable_status: fdt$variable_status,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      validate_name (variable_name, x_status);
      IF x_status.normal THEN
        validate_occurrence (variable_occurrence, x_status);
        IF x_status.normal THEN
          x_variable_name := variable_name;
          x_variable_occurrence := variable_occurrence;
          x_form_identifier := form_identifier;
          fdp$replace_real_variable (x_form_identifier, x_variable_name, x_variable_occurrence, variable,
                x_variable_status, x_status);
          IF x_status.normal THEN
            convert_variable_status (x_variable_status, variable_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xreplace_real_variable;

?? TITLE := 'FDP$XREPLACE_RECORD', EJECT ??
*copyc fdh$xreplace_record

  PROCEDURE [XDCL] fdp$xreplace_record
    (VAR form_identifier: integer;
     VAR work_area: string (*);
     VAR variable_status: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_variable_status: fdt$variable_status,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      x_form_identifier := form_identifier;
      fdp$replace_record (x_form_identifier, ^work_area, STRLENGTH (work_area),
            x_variable_status, x_status);
      IF x_status.normal THEN
        convert_variable_status (x_variable_status, variable_status);
      IFEND;
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xreplace_record;

?? TITLE := 'FDP$XREPLACE_STRING_VARIABLE', EJECT ??
*copyc fdh$xreplace_string_variable

  PROCEDURE [XDCL] fdp$xreplace_string_variable
    (VAR form_identifier: integer;
     VAR variable_name: string ( * );
     VAR variable_occurrence: integer;
     VAR variable: string ( * );
     VAR variable_status: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_variable_name: ost$name,
      x_variable_occurrence: fdt$occurrence,
      x_variable_status: fdt$variable_status,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      validate_name (variable_name, x_status);
      IF x_status.normal THEN
        validate_occurrence (variable_occurrence, x_status);
        IF x_status.normal THEN
          x_form_identifier := form_identifier;
          x_variable_name := variable_name;
          x_variable_occurrence := variable_occurrence;
          fdp$replace_string_variable (x_form_identifier, x_variable_name, x_variable_occurrence, variable,
                x_variable_status, x_status);
          IF x_status.normal THEN
            convert_variable_status (x_variable_status, variable_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xreplace_string_variable;

?? TITLE := 'FDP$XRESET_FORM', EJECT ??
*copyc fdh$xreset_form

  PROCEDURE [XDCL] fdp$xreset_form
    (VAR form_identifier: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      x_form_identifier := form_identifier;
      fdp$reset_form (x_form_identifier, x_status);
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xreset_form;

?? TITLE := 'FDP$XRESET_OBJECT_ATTRIBUTE', EJECT ??
*copyc fdh$xreset_object_attribute

  PROCEDURE [XDCL] fdp$xreset_object_attribute
    (VAR form_identifier: integer;
     VAR object_name: string ( * );
     VAR object_occurrence: integer;
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_object_name: ost$name,
      x_object_occurrence: fdt$occurrence,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      validate_name (object_name, x_status);
      IF x_status.normal THEN
        validate_occurrence (object_occurrence, x_status);
        IF x_status.normal THEN
          x_object_occurrence := object_occurrence;
          x_object_name := object_name;
          x_form_identifier := form_identifier;
          fdp$reset_object_attribute (x_form_identifier, x_object_name, x_object_occurrence, x_status);
        IFEND;
      IFEND;
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xreset_object_attribute;

?? TITLE := 'FDP$XSET_CURSOR_POSITION', EJECT ??
*copyc fdh$xset_cursor_position

  PROCEDURE [XDCL] fdp$xset_cursor_position
    (VAR form_identifier: integer;
     VAR object_name: string ( * );
     VAR object_occurrence: integer;
     VAR character_position: integer;
     VAR status: integer);

    VAR
      x_character_position: fdt$character_position,
      x_form_identifier: fdt$form_identifier,
      x_object_name: ost$name,
      x_object_occurrence: fdt$occurrence,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      validate_name (object_name, x_status);
      IF x_status.normal THEN
        validate_occurrence (object_occurrence, x_status);
        IF x_status.normal THEN
          validate_character_position (character_position, x_status);
          IF x_status.normal THEN
            x_form_identifier := form_identifier;
            x_object_name := object_name;
            x_object_occurrence := object_occurrence;
            x_character_position := character_position;
            fdp$set_cursor_position (x_form_identifier, x_object_name, x_object_occurrence,
                  x_character_position, x_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xset_cursor_position;

?? TITLE := 'FDP$XSET_LINE_MODE', EJECT ??
*copyc fdh$xset_line_mode

  PROCEDURE [XDCL] fdp$xset_line_mode
    (VAR status: integer);

    VAR
      x_status: ost$status;

    fdp$set_line_mode (x_status);
    convert_status (x_status, status);
  PROCEND fdp$xset_line_mode;

?? TITLE := 'FDP$XSET_OBJECT_ATTRIBUTE', EJECT ??
*copyc fdh$xset_object_attribute

  PROCEDURE [XDCL] fdp$xset_object_attribute
    (VAR form_identifier: integer;
     VAR object_name: string ( * );
     VAR object_occurrence: integer;
     VAR attribute_name: string ( * );
     VAR status: integer);

    VAR
      x_form_identifier: fdt$form_identifier,
      x_object_name: ost$name,
      x_object_occurrence: fdt$occurrence,
      x_attribute_name: ost$name,
      x_status: ost$status;

    validate_form_identifier (form_identifier, x_status);
    IF x_status.normal THEN
      validate_name (object_name, x_status);
      IF x_status.normal THEN
        validate_occurrence (object_occurrence, x_status);
        IF x_status.normal THEN
          validate_name (attribute_name, x_status);
          IF x_status.normal THEN
            x_form_identifier := form_identifier;
            x_object_occurrence := object_occurrence;
            x_object_name := object_name;
            x_attribute_name := attribute_name;
            fdp$set_object_attribute (x_form_identifier, x_object_name, x_object_occurrence, x_attribute_name,
                  x_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    convert_status (x_status, status);
  PROCEND fdp$xset_object_attribute;

?? TITLE := 'FDP$XSHOW_FORMS', EJECT ??
*copyc fdh$xshow_forms

  PROCEDURE [XDCL] fdp$xshow_forms
    (VAR status: integer);

    VAR
      x_status: ost$status;

    fdp$show_forms (x_status);
    convert_status (x_status, status);
  PROCEND fdp$xshow_forms;

?? TITLE := 'FDP$XTAB_TO_NEXT_FIELD', EJECT ??
*copyc fdh$xtab_to_next_field

  PROCEDURE [XDCL] fdp$xtab_to_next_field
    (VAR status: integer);

    VAR
      x_status: ost$status;


    fdp$tab_to_next_field (x_status);
    convert_status (x_status, status);

  PROCEND fdp$xtab_to_next_field;

  PROCEDURE [INLINE] convert_status
    (    x_status: ost$status;
     VAR status: integer);

    IF x_status.normal THEN
      status := 0;
    ELSE
      status := osp$status_condition_number (x_status.condition);
    IFEND;
  PROCEND convert_status;

  PROCEDURE [INLINE] convert_variable_status
    (    x_variable_status: fdt$variable_status;
     VAR variable_status: integer);

    variable_status := $INTEGER (x_variable_status);
  PROCEND convert_variable_status;

  PROCEDURE [INLINE] validate_character_position
    (    character_position: integer;
     VAR status: ost$status);

    IF ((character_position > 0) AND (character_position <= fdc$max_character_position)) THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_character_position, '', status);
    IFEND;
  PROCEND validate_character_position;

  PROCEDURE [INLINE] validate_form_identifier
    (    form_identifier: integer;
     VAR status: ost$status);

    IF ((form_identifier > 0) AND (form_identifier <= fdc$maximum_form_identifier)) THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_form_identifier, '', status);
    IFEND;
  PROCEND validate_form_identifier;

  PROCEDURE [INLINE] validate_x_position
    (    x_position: integer;
     VAR status: ost$status);

    IF ((x_position > 0) AND (x_position <= fdc$maximum_x_position)) THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_x_position, '', status);
    IFEND;
  PROCEND validate_x_position;

  PROCEDURE [INLINE] validate_y_position
    (    y_position: integer;
     VAR status: ost$status);

    IF ((y_position > 0) AND (y_position <= fdc$maximum_y_position)) THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_y_position, '', status);
    IFEND;
  PROCEND validate_y_position;

  PROCEDURE [INLINE] validate_name
    (    name: string ( * );
     VAR status: ost$status);

    IF ((STRLENGTH (name) > 0) AND (STRLENGTH (name) <= osc$max_name_size)) THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_name, '', status);
    IFEND;
  PROCEND validate_name;

  PROCEDURE [INLINE] validate_occurrence
    (    occurrence: integer;
     VAR status: ost$status);

    IF ((occurrence > 0) AND (occurrence <= fdc$maximum_occurrence)) THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_occurrence, '', status);
    IFEND;
  PROCEND validate_occurrence;

MODEND fdm$cobol_fortran_requests;
*DECK DECK=FDM$CREATE_COBOL_DESCRIPTION EXPAND=TRUE

?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE fdm$create_cobol_description;
?? NEWTITLE := 'NOS/VE Screen Formatter : Move COBOL data' ??
*copyc fdc$cobol_operations_max
*copyc fde$condition_identifiers
*copyc fdt$cobol_category
*copyc fdt$cobol_picture_symbols
*copyc fdt$cobol_usage
*copyc fdt$cobol_operation
*copyc fdt$cobol_cr_db_means
*copyc fdt$cobol_description
*copyc fdt$usage
*copyc fdc$maximum_picture_length
*copyc fdv$cobol_currency_symbols
*copyc ost$status
*copyc osv$lower_to_upper

*copyc i#move
*copyc osp$set_status_abnormal

?? OLDTITLE ??
?? NEWTITLE :=  '[XDCL] fdp$create_cobol_description', EJECT ??
*copyc fdh$create_cobol_description

  PROCEDURE [XDCL] fdp$create_cobol_description
    (    cobol_picture_symbols: fdt$cobol_picture_symbols;
         cobol_usage_keyword: fdt$usage;
     VAR destination: fdt$cobol_description;
     VAR status: ost$status);

    CONST
      bytes_for_single = 8,
      bytes_for_double = 16,
      picture_index_min = 0,
      picture_index_max = 31,
      rep_count_min     = 0,
      rep_count_max     = 1048576; {From COBOL/VE Usage p. 5-20.

    TYPE
      ch = set OF CHAR; { so we can use set literals

    VAR
      chars: ch, { characters appearing in PICTURE
      chars2: ch, { characters occurring 2 or more times
      i: picture_index_min..picture_index_max,
      imax: picture_index_min..picture_index_max,
      outside_parens: BOOLEAN, { iff examining outside of repetition count
      string_picture: STRING (fdc$maximum_picture_length + 1),

      { uppercase "cobol_picture_symbols" for #SCAN

      picture: ARRAY [1 .. fdc$maximum_picture_length + 1] OF CHAR;

?? OLDTITLE ??
?? NEWTITLE := 'get_char', EJECT ??

    PROCEDURE get_char

{ Gets the next character of the picture string, and determines
{ how many times it is repeated.  Repetition is by repeating the
{ ***NOTE: The caller must ensure that picture[i] is not blank.

      (VAR i: picture_index_min..picture_index_max;
       VAR c: CHAR; { set to next char of picture string
       VAR num: rep_count_min..rep_count_max); { number of occurrences of c

      VAR
        n: rep_count_min..rep_count_max; {repetition count for particular char


      c := picture [i]; { Pick up the next character in the picture
      num := 1; { The repetition count is currently 1
      i := i + 1; { Point to the first unused character in the picture
      WHILE (picture [i] = c) OR (picture [i] = '(') DO

{ Pick up repetitions of the character
{ Note that the below "while" is incorrect only if get_char
{ is called with picture[i]=' ', since all pictures have a
{ trailing space.

        WHILE picture [i] = c DO
          num := num + 1; { Include the character in the repetition count
          i := i + 1; { Point to the next character in the picture
        WHILEND;

        IF picture [i] = '(' THEN { We have "c(...)"

{ Pick up the decimal repetition count, which
{ may be as large as 1,048,575 (COBOL/VE Usage p. 5-20.

          i := i + 1; { Skip the "("
          n := 0;

{ Note that the initial scan ensured only digits between ( and ),
{ and that a terminating ")" exists.

          WHILE (picture [i] <> ')') AND (n < 104858) DO
            n := 10 * n + $INTEGER (picture [i]) - $INTEGER ('0');
            i := i + 1;
          WHILEND;

          IF (picture [i] <> ')') OR (n > fdc$cobol_item_size_maximum) THEN

{ The number of character positions described in a COBOL
{ PICTURE cannot exceed 1,048,575.

            osp$set_status_abnormal
             (fdc$format_display_identifier, fde$cobol_item_too_big, '', status);
            EXIT fdp$create_cobol_description;
          IFEND; { Repetition count was too large

{ Now picture [i] = ')'

          i := i + 1; { Point to character after "c(...)"

{ Add the repetition count to the total count,
{ offsetting the count for the "c" of "c(...)"

          num := num + n - 1;

        IFEND { finished processing repetition count
      WHILEND { (picture [i] = c) OR (picture [i] = '(')
    PROCEND get_char;

?? OLDTITLE ??
?? NEWTITLE := 'process_alphabetic_picture', EJECT ??

    PROCEDURE process_alphabetic_picture;

{ An alphabetic picture may contain characters "A" and "B".
{ The "B" indicate that spaces are inserted in the destination
{ at that point.
{ Although the user may conceptually restrict the contents of an
{ alphabetic picture to letters, there is in fact no such restriction
{ on its contents.  Digits and graphic characters may be legally moved
{ to and from an alphabetic item.

      VAR
        c: CHAR, { Current character in "picture". Set by "get_char"
        i: picture_index_min..picture_index_max,
        num: rep_count_min..rep_count_max; { Set by "get_char"


      i := 1; { Point to first unused character in "picture"

      { Each "A" generates a "move" operation.
      { Each "B" generates an "insert" operation.

      WHILE picture [i] <> ' ' DO

        { Set "c" to the next picture character, repeated "num" times
        { and increment "i" accordingly.

        get_char (i, c, num);

{ Apply count to character size of item

        destination.size := destination.size + num;

{ Reserve space for another operation

        destination.move_operations := destination.move_operations + 1;

{ Move "num" chars, or insert "num" times

        destination.operation_numbers [destination.move_operations] := num;
        IF c = 'A' THEN { "A" means move
          destination.cobol_operations [destination.move_operations] :=
           fdc$cobol_move
        ELSE

{ "B" means insert

          destination.cobol_operations [destination.move_operations] :=
           fdc$cobol_insert;
          destination.operation_characters [destination.move_operations] :=
           ' '; { Insert spaces
        IFEND { B
      WHILEND { picture [i] <> ' '
    PROCEND process_alphabetic_picture;

    PROCEDURE process_alphanumeric_picture;

{ An alphanumeric picture may contain characters "A", "X" and "9".
{ Although the user may conceptually restrict letters to those
{ positions represented by an "A", and restrict digits to those
{ positions represented by a "9", there is in fact no such restriction
{ on the contents of an alphanumeric item. Letters, digits, and graphic
{ characters may be moved to any position of an alphanumeric item
{ regardless of whether that position is represented by "A", "X", or "9".

      VAR
        c: CHAR, { Current character in "picture". Set by "get_char"
        i: picture_index_min..picture_index_max,
        num: rep_count_min..rep_count_max; { Set by "get_char"


      i := 1; { Point to first unused character in "picture"

{ Considering the above explanation, each alphanumeric picture
{ corresponds to a single "move" operation.

{ First determine the number of characters represented by the picture

      WHILE (picture [i] <> ' ') DO

{ Set "c" to the next picture character, repeated "num" times
{ and increment "i" accordingly.

        get_char (i, c, num);

        IF destination.size + num > fdc$cobol_item_size_maximum THEN

{ The number of character positions described in a COBOL
{ PICTURE cannot exceed 1,048,575.

          osp$set_status_abnormal
           (fdc$format_display_identifier, fde$cobol_item_too_big, '', status);
          EXIT fdp$create_cobol_description;

        ELSE

{ Apply count to character size of item

          destination.size := destination.size + num;
        IFEND { size was small enough

      WHILEND;

{ Now generate the "move" operation

      destination.move_operations := 1;
      destination.cobol_operations [1] := fdc$cobol_move;
      destination.operation_numbers [1] := destination.size;
    PROCEND process_alphanumeric_picture;

?? OLDTITLE ??
?? NEWTITLE := 'process_alphanumeric_edited_pic', EJECT ??

    PROCEDURE process_alphanumeric_edited_pic;

{ An alphanumeric-edited picture may contain characters "A", "X", "9",
{ "B", "0", and "/".  The characters "A", "X", and "9" represent
{ positions containing characters.  See "process_alphanumeric_picture"
{ for a discussion.  The characters "B", "0", and "/" indicate that
{ a space, zero, and slash, respectively, are to be inserted.

      VAR
        c: CHAR, { Current character in "picture". Set by "get_char"
        i: picture_index_min..picture_index_max,
        num: rep_count_min..rep_count_max; { Set by "get_char"


      i := 1; { Point to first unused character in "picture"

{ Each "A", "X", and "9" generates a "move" operation.
{ Each "B", "0", and "/" generates an "insert" operation.
{ Note that the caller of "process_alphanumeric_edited_pic
{ has ensured that only the above characters appear in this picture.

      WHILE picture [i] <> ' ' DO

{ Set "c" to the next picture character, repeated "num" times
{ and increment "i" accordingly.

        get_char (i, c, num);

{ Apply count to character size of item

        destination.size := destination.size + num;

{ Reserve space for another operation

        destination.move_operations := destination.move_operations + 1;

{ Operation count is repetition count

        destination.operation_numbers [destination.move_operations] := num;
        IF (c = 'A') OR (c = 'X') OR (c = '9') THEN

{ Operation is "move"

          destination.cobol_operations [destination.move_operations] :=
           fdc$cobol_move
        ELSE { "B", "0", or "/"

          IF c = 'B' THEN
            c := ' '; { "B" means to insert a space
          IFEND;

{ Operation is "insert"

          destination.cobol_operations [destination.move_operations] :=
           fdc$cobol_insert;
          destination.operation_characters [destination.move_operations] := c;
        IFEND { "B", "0", or "/"
      WHILEND
    PROCEND process_alphanumeric_edited_pic;

?? OLDTITLE ??
?? NEWTITLE := 'process_numeric_picture', EJECT ??

    PROCEDURE process_numeric_picture;

{ A numeric picture may contain characters "9", "V", "P", and "S".
{ A "9" represents a position containing a digit character, possibly
{ modified by sign processing.  Only 9's correspond to character
{ positions within the item, except for a possible separate sign.
{ A (leading) "S" indicates that the number represented here may be
{ negative.  The exact way a sign is indicated depends on the "usage",
{ "sign", "leading", and "separate" parameters to
{ fdp$create_cobol_description.  These parameters correspond to the

{ COBOL USAGE and SIGN clauses.
{ A "V" indicates the position of the decimal point for numeric purposes.
{ It does not represent a character position within the item.  A decimal
{ point will not be moved when the item is moved.  Do not be confused
{ by the fact that a COBOL DISPLAY of such an item will show a decimal
{ point; COBOL reformats such items on DISPLAY to make them more
{ readable.
{ A "P" represents a digit position without a corresponding position
{ in the item.  For example, a picture representing the number of
{ thousands of dollars might be "9(6)PPP", and a picture representing
{ the number of nanoseconds might be "P(6)999".  An implied "V" is
{ at the end of the P's opposite the 9's, so the above pictures
{ would mean "9(6)PPPV" and "VP(6)999".  This redundancy is prohibited
{ so the latter two pictures are diagnosed.

      VAR
        c: CHAR, { Current character in "picture". Set by "get_char"
        found_9: BOOLEAN, { iff any 9 found
        found_9p: BOOLEAN, { iff 9's followed by P's
        found_p: BOOLEAN, { iff any P found
        found_p9: BOOLEAN, { iff P's followed by 9's
        found_v: BOOLEAN, { iff V found
        i: picture_index_min..picture_index_max,
        ignore_9: BOOLEAN, { iff "move" should ignore first digit
        num: rep_count_min..rep_count_max, { Set by "get_char"
        trailing_overpunch: BOOLEAN, { iff must append trailing overpunch sign
        trailing_separate: BOOLEAN; { iff must append trailing separate sign

{ The USAGE of this item may be DISPLAY, BINARY, or PACKED-DECIMAL.
{ The latter two cases do not need generated code.  But we go through
{ the whole process anyway so we can compute destination.number_digits,
{ destination.significant_digits and destination.sign_index.
{ For BINARY or PACKED-DECIMAL destination.sign_index will be 1

{ if the number is signed (i.e. if the picture starts with "S").

      i := 1; { Point to first unused character in "picture"
      trailing_overpunch := (destination.cobol_category = fdc$cobol_numeric_signed);
      trailing_separate := FALSE; { Do not append separate sign
      ignore_9 := FALSE; { Do not ignore the first "9"
      found_9 := FALSE; { Have not yet found any 9's
      found_v := FALSE; { Have not yet found any V's
      found_p := FALSE; { Have not yet found any P's
      found_9p := FALSE; { Have not yet found 9's followed by P's
      found_p9 := FALSE; { Have not yet found P's followed by 9's
      IF picture [1] = 'S' THEN

{ We have a leading "S" (and following S's are illegal)

        IF destination.cobol_usage = fdc$cobol_usage_binary THEN

{ For USAGE IS BINARY, remember that number may be signed.

          destination.sign_index := 1;

{ At the end of the picture, we will decrement the last "move"
{ operation and generate an overpunch sign

          trailing_overpunch := TRUE;
          destination.sign_separate := FALSE; { Indicate overpunch sign
        ELSE
          destination.sign_separate := FALSE;
        IFEND;

        i := 2; { Advance beyond "S"

{ end: picture started with "S"

      ELSEIF 'S' IN chars THEN

{ Picture had "S" not at beginning.
{ The "S" must be the first character in the COBOL PICTURE.

        osp$set_status_abnormal
         (fdc$format_display_identifier, fde$cobol_s_must_be_first, '', status);
        EXIT fdp$create_cobol_description;

      IFEND { picture had "S" not at beginning} ;

{ We have processed or diagnosed all instances of "S"


{ Each "9" causes a "move" to be done (after decimal point aligning).
{ Each "P" affects decimal point aligning.
{ The "V" affects decimal point aligning.

      WHILE (picture [i] <> ' ') DO

{ Note that the caller of "process_numeric_picture" has ensured
{ that only 9's, V's, P's, and S's are in this picture,
{ and the above processing has set "i" or "status.normal"
{ to account for all cases of "S".

        IF picture [i] = 'V' THEN

{ Found what is hopefully the only "V" in the picture

          IF found_p THEN

{ "V" and "P" cannot both be used in a COBOL PICTURE.

            osp$set_status_abnormal (
            fdc$format_display_identifier, fde$cobol_not_both_v_and_p, '', status);
            EXIT fdp$create_cobol_description;

          ELSEIF found_v THEN

{ Only one "V" can be in a COBOL PICTURE.

            osp$set_status_abnormal
             (fdc$format_display_identifier, fde$cobol_too_many_vs, '', status);
            EXIT fdp$create_cobol_description;

          ELSE
            found_v := TRUE;
          IFEND;
          i := i + 1; { Skip the "V"

        ELSEIF picture [i] = '9' THEN
          IF found_9p THEN

{ Have e.g. 999PPP999
{ Cannot have P's between 9's in COBOL PICTURE.

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_not_9p9, '', status);
            EXIT fdp$create_cobol_description;

          IFEND;
          IF found_p THEN
            found_p9 := TRUE; { Be ready to diagnose PPP999PPP
          IFEND;
          found_9 := TRUE; { Be ready to set "found_9p"

{ Adjust number of significant digits
{ Examples:  PIC 999 => destination.significant_digits = 3

{           PIC 9PP => destination.significant_digits = 3

{           PIC PP9 => destination.significant_digits = -2

{           PIC V99 => destination.significant_digits = 0


          get_char (i, c, num); { c := '9', num := repetition
          IF (NOT found_v) AND (NOT found_p) THEN
            destination.significant_digits :=
            destination.significant_digits + num;
          IFEND;

{ Increase the number of character positions appropriately

          destination.size := destination.size + num;

{ Increase the total number of digits appropriately
{ We cannot use destination.size and the number of digits because
{ we might have had a leading separate sign.

          destination.number_digits := destination.number_digits + num;

{ If this is the first set of 9's and we have already generated
{ an overpunch sign, ignore the first "9" of this move

          IF ignore_9 THEN
            num := num - 1;
            ignore_9 := FALSE;
          IFEND;

{ If we have any more 9's after the above, generate a "move"

          IF num >= 1 THEN

{ Point to the next operation entry

            destination.move_operations := destination.move_operations + 1;
            destination.cobol_operations [destination.move_operations] :=
             fdc$cobol_move; { "move"
            destination.operation_numbers [destination.move_operations] :=
             num;
          IFEND;

{ end: picture [i] = '9'

        ELSEIF picture [i] = 'P' THEN
          IF found_p9 THEN

{ Have e.g. PPP999PPP
{ Cannot have 9's between P's in COBOL PICTURE.

            osp$set_status_abnormal
             (fdc$format_display_identifier, fde$cobol_not_p9p, '', status);
            EXIT fdp$create_cobol_description;

          IFEND;
          IF found_9 THEN
            found_9p := TRUE; { Be ready to diagnose 999PPP999
          IFEND;
          found_p := TRUE; { Be ready to set "found_p9"
          IF found_v THEN

{ "V" and "P" cannot both be used in a COBOL PICTURE.

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_not_both_v_and_p, '', status);
            EXIT fdp$create_cobol_description;

          IFEND { found_v} ;

{ Adjust number of significant digits
{ Examples:  PIC 999 => destination.significant_digits = 3

{           PIC 9PP => destination.significant_digits = 3

{           PIC PP9 => destination.significant_digits = -2

{           PIC V99 => destination.significant_digits = 0

{ Set "c" to the next picture character, repeated "num" times
{ and increment "i" accordingly.

          get_char (i, c, num); { c := 'P'; num := repetition; incr i
          IF found_9 THEN { E.g. 999PPP
            destination.significant_digits :=
            destination.significant_digits + num
          ELSE { E.g. PPP with 9's later
            destination.significant_digits :=
            destination.significant_digits - num;
          IFEND;
        IFEND { P
      WHILEND;

      IF destination.number_digits > 18 THEN

{ Cannot enter more than 18 digit positions.

        osp$set_status_abnormal (
         fdc$format_display_identifier, fde$cobol_too_many_digits, '', status);
        EXIT fdp$create_cobol_description;
      IFEND;

{ If the sign is to represented by a trailing overpunch digit,
{ generate code for it now.

      IF trailing_overpunch THEN

{ Eliminate one of the 9's moved by the last operation

        destination.operation_numbers [destination.move_operations] :=
        destination.operation_numbers [destination.move_operations] - 1;

{ If 9's are still moved, advance to the next op entry

        IF destination.operation_numbers[destination.move_operations] >= 1 THEN
          destination.move_operations := destination.move_operations + 1;
        IFEND;

{ Add an operation to move a digit and apply an overpunch sign

        destination.cobol_operations [destination.move_operations] :=
         fdc$cobol_overpunch_sign;

{ Point to the character that has the sign

        destination.sign_index := destination.size;
      IFEND { trailing overpunch} ;

{ If the sign is to be represented by a trailing separate sign,
{ generate code for it now.

      IF trailing_separate THEN

{ Increment number of characters in item

        destination.size := destination.size + 1;

{ Point to character with sign

        destination.sign_index := destination.size;
        destination.move_operations :=
        destination.move_operations + 1; { Point to the next entry
        destination.cobol_operations [destination.move_operations] :=
         fdc$cobol_separate_sign;
      IFEND { trailing_separate} ;

      IF destination.cobol_usage = fdc$cobol_usage_binary THEN

{ Convert bit-length to bytes
{ See page 5-34 of the COBOL/VE Usage manual for below values.

        IF destination.sign_index = 0 THEN

{ The number has no sign

          CASE destination.number_digits OF
          = 1 =
            destination.size := 1;
          = 2 =
            destination.size := 1;
          = 3 =
            destination.size := 2;
          = 4 =
            destination.size := 2;
          = 5 =
            destination.size := 3;
          = 6 =
            destination.size := 3;
          = 7 =
            destination.size := 3;
          = 8 =
            destination.size := 4;
          = 9 =
            destination.size := 4;
          = 10 =
            destination.size := 5;
          = 11 =
            destination.size := 5;
          = 12 =
            destination.size := 5;
          = 13 =
            destination.size := 6;
          = 14 =
            destination.size := 6;
          = 15 =
            destination.size := 7;
          = 16 =
            destination.size := 7;
          = 17 =
            destination.size := 8;
          = 18 =
            destination.size := 8;
          ELSE
          CASEND

        ELSE

{ The number has a sign

          destination.sign_index := 1;
          CASE destination.number_digits OF
          = 1 =
            destination.size := 1;
          = 2 =
            destination.size := 1;
          = 3 =
            destination.size := 2;
          = 4 =
            destination.size := 2;
          = 5 =
            destination.size := 3;
          = 6 =
            destination.size := 3;
          = 7 =
            destination.size := 4;
          = 8 =
            destination.size := 4;
          = 9 =
            destination.size := 4;
          = 10 =
            destination.size := 5;
          = 11 =
            destination.size := 5;
          = 12 =
            destination.size := 6;
          = 13 =
            destination.size := 6;
          = 14 =
            destination.size := 6;
          = 15 =
            destination.size := 7;
          = 16 =
            destination.size := 7;
          = 17 =
            destination.size := 8;
          = 18 =
            destination.size := 8;
          ELSE
          CASEND;
        IFEND { The number has a sign
      IFEND { USAGE IS BINARY} ;

      IF destination.cobol_usage = fdc$cobol_usage_packed THEN

{ USAGE IS PACKED-DECIMAL
{ Convert sign.idx to proper value

        IF destination.sign_index >= 1 THEN
          destination.sign_index := 1;
        IFEND;

{ Set size according to actual bytes to be used

        destination.size :=
         (destination.number_digits + destination.sign_index + 1) DIV 2;
      IFEND;

    PROCEND process_numeric_picture;

?? OLDTITLE ??
?? NEWTITLE := 'process_numeric_edited_picture', EJECT ??

    PROCEDURE process_numeric_edited_picture;

{ A numeric-edited picture may contain characters "9", "V", "P", "S",
{ "Z", "*", "$", "#", "+", "-", "CR", "DB", ".", "B", "/", "0", or ",".
{ The "9", "V", "P", and "S" represent the same as for numeric pictures.
{ The "B", "/", "0", and "," represent the same as for alphanumeric-
{ edited pictures; the associated " ", "/", "0" and "," are inserted.
{ A single "$" is also inserted. These cases are "simple insertion".
{ A single "+", "-", "CR", and "DB" inserts characters depending on the
{ sign of the source.  If positive, "+", " ", "  ", and "  " are
{ inserted.  If negative, "-", "-", "CR", and "DB" are inserted.
{ The "." means a "." is inserted, and that this is the numeric decimal
{ point.
{ The "*", "Z", and multiple "$", "#" "+", and "-" indicate digit
{ positions where leading zeros are replaced by blanks (except for "*",
{ when they are replaced by "*").  The latter three characters also mean
{ that the character just before the first non-zero digit is replaced
{ just as if a single "$", "#", "+", or "-" represented that position.
{ The general idea is to represent digits by 9's or one of the above
{ floating symbols, allow flexible sign representation, and allow
{ insertion characters within the number.
{ There are many special cases and restrictions.  See pages 5-22 to
{ 5-29 of the COBOL/VE Usage Manual.

      CONST
        scan_min = 0,
        scan_max = 255;

      VAR
        c: CHAR, { Current character in "picture". Set by "get_char
        float: (
           float_not_yet,
           float_now,
           float_done,
           float_all_or_none,
           float_must),
        found: BOOLEAN, { to tell if #SCAN found target
        found_9: BOOLEAN, { iff any 9 found
        found_9p: BOOLEAN, { iff 9's followed by P's
        found_p: BOOLEAN, { iff any P found
        found_p9: BOOLEAN, { iff P's followed by 9's
        found_point: BOOLEAN, { iff found decimal point
        found_leading_simple: BOOLEAN, { iff found simple insertion
        found_v: BOOLEAN, { iff V found
        i: picture_index_min..picture_index_max,
        ip: picture_index_min..picture_index_max, { Set by #SCAN

{ Number of floating symbols: $$, Z, ++, etc

        n_float_symbols: picture_index_min..picture_index_max,

{ Number of sign forms: +, -, CR, DB

        n_sign_forms: picture_index_min..picture_index_max,
        num: rep_count_min..rep_count_max, { Set by "get_char"

{ Number of digits to left of point

        num_signif_digits: integer,

{ Number of digits to right of point

        num_fraction_digits: integer,
        scan_for_c: PACKED ARRAY [scan_min .. scan_max] of 0 .. 1, { to #SCAN for 'C'
        scan_for_d: PACKED ARRAY [scan_min .. scan_max] of 0 .. 1, { to #SCAN for 'D'
        scan_for_dot: PACKED ARRAY [scan_min .. scan_max] of 0 .. 1, { to #SCAN for '.'
        scan_index: scan_min .. scan_max;

?? NEWTITLE := 'generate_float', EJECT ??

      PROCEDURE generate_float;

{ Given "c" = floating character (from *, Z, $$, ##, ++, or --)
{ and "num" = repetition count for "c", checks for appropriate
{ diagnostics and generates appropriate code.

        IF found_9p THEN

{ Error: e.g. "$$PP<$>"
{ Cannot have P's between 9's in COBOL PICTURE.

          osp$set_status_abnormal (
           fdc$format_display_identifier, fde$cobol_not_9p9, '', status);
          EXIT fdp$create_cobol_description;

        IFEND;

        found_9 := TRUE; { Be ready to set "found_9p"

{ Detect e.g. "PPP###", to be ready to diagnose "PPP###PPP"

        IF found_p THEN
          found_p9 := TRUE;
        IFEND;

        IF float = float_done { e.g. "+++.9<++>" or "++9<++>"} THEN

{ Digits have already been represented by non-float

          IF found_point THEN

{ e.g. "+++.9++"
{ In a COBOL PICTURE, if any digits to the right of the decimal
{ point are floating symbols (e.g. ++ -- ZZ ** $$ ##) then all
{ digits must be represented by the floating symbol, which must
{ also appear to the left of the decimal point (i.e. "VZZZ"
{ is not allowed).

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_right_flt_means_all, '',
             status);
            EXIT fdp$create_cobol_description;

          ELSE

{ e.g. "++9++"
{ Floating symbols in a COBOL PICTURE must represent only the
{ left-most digits.

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_float_must_be_left, '',
             status);
            EXIT fdp$create_cobol_description;

          IFEND;
        IFEND;

        IF float = float_not_yet { e.g. "<++>"} THEN
          IF found_leading_simple { e.g. "$/<++>"} THEN

{ Simple insertion characters cannot appear at left of floating
{ string (e.g. ++ -- ZZ ** $$ ##) in COBOL PICTURE.

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_insert_left_of_float, '',
             status);
            EXIT fdp$create_cobol_description;

          ELSE

{ Do not count leading "+", "-", "$", or "#" as digit

            IF (c = '+') OR (c = '-') OR (c = fdv$cobol_currency_symbols.primary_money_symbol)
                  OR (c = fdv$cobol_currency_symbols.secondary_money_symbol) THEN
              num := num - 1;
            IFEND;
            float := float_now;

{ Generate op_code to initiate floating insertion

            destination.cobol_operations [destination.move_operations] :=
             fdc$cobol_set_leading_zeros;

{ Prepare skeleton operation for a later code in this procedure


{ Point to the next operation entry

            destination.move_operations := destination.move_operations + 1;

{ Include the repetition count

            destination.operation_numbers [destination.move_operations] := num;

{ Include the floating symbol

            destination.operation_characters [destination.move_operations] :=
             c;
          IFEND
        IFEND { had not found float} ;

        IF float = float_all_or_none { e.g. "++.<++>"} THEN
          float := float_must; { Require digit positions to be float
        IFEND;
        destination.cobol_operations [destination.move_operations] :=
         fdc$cobol_move_float;

{ Keep track of numeric attributes

        IF found_point THEN
          num_fraction_digits := num_fraction_digits + num
        ELSE
          num_signif_digits := num_signif_digits + num;
        IFEND;
      PROCEND generate_float;

?? OLDTITLE, EJECT ??

{ Set parameters to be used by #SCAN

      FOR scan_index := scan_min TO scan_max DO
        scan_for_c [scan_index] := 0;
        scan_for_d [scan_index] := 0;
        scan_for_dot [scan_index] := 0;
      FOREND;
      scan_for_c [$INTEGER ('C')] := 1;
      scan_for_c [$INTEGER ('c')] := 1;
      scan_for_d [$INTEGER ('D')] := 1;
      scan_for_d [$INTEGER ('d')] := 1;
      scan_for_dot [$INTEGER (fdv$cobol_currency_symbols.decimal_symbol)] := 1;

{ Diagnose more than one sign form in the picture
{ E.g. "+99999.99BCR"

      n_sign_forms := 0;

      IF '+' IN chars THEN
        n_sign_forms := n_sign_forms + 1;
      IFEND;

      IF '-' IN chars THEN
        n_sign_forms := n_sign_forms + 1;
      IFEND;

      IF 'C' IN chars THEN
        n_sign_forms := n_sign_forms + 1;
      IFEND;

      IF 'D' IN chars THEN
        n_sign_forms := n_sign_forms + 1;
      IFEND;

      IF n_sign_forms >= 2 THEN

{ COBOL PICTURE cannot have two sign symbols.

        osp$set_status_abnormal (
         fdc$format_display_identifier, fde$cobol_two_signs, '', status);
        EXIT fdp$create_cobol_description;

      IFEND;

{ Make sure that "R" follows any "C"

      IF 'C' IN chars THEN
        #SCAN (scan_for_c, string_picture, ip, found);
        IF (picture [ip + 1] = 'R') AND (picture [ip + 2] = '(') THEN

{ COBOL PICTURE cannot have repetition count for CR or DB.

          osp$set_status_abnormal (
           fdc$format_display_identifier, fde$cobol_no_rep_for_cr_db, '', status);
          EXIT fdp$create_cobol_description;

        ELSEIF (picture [ip + 1] <> 'R') OR (picture [ip + 2] <> ' ') THEN

{ CR and DB must be rightmost in COBOL PICTURE.

          osp$set_status_abnormal (
           fdc$format_display_identifier, fde$cobol_cr_db_must_be_right, '',
           status);
          EXIT fdp$create_cobol_description;
        ELSE
          destination.cr_means := fdc$cobol_negative;
          destination.db_means := fdc$cobol_positive;
        IFEND
      IFEND;


{ Make sure "B" follows "D"


      IF 'D' IN chars THEN
        #SCAN (scan_for_d, string_picture, ip, found);
        IF (picture [ip + 1] = 'B') AND (picture [ip + 2] = '(') THEN

{ COBOL PICTURE cannot have repetition count for CR or DB.

          osp$set_status_abnormal (
           fdc$format_display_identifier, fde$cobol_no_rep_for_cr_db, '', status);
          EXIT fdp$create_cobol_description;

        ELSEIF (picture [ip + 1] <> 'B') OR (picture [ip + 2] <> ' ') THEN

{ CR and DB must be rightmost in COBOL PICTURE.

          osp$set_status_abnormal (
           fdc$format_display_identifier, fde$cobol_cr_db_must_be_right, '',
           status);
          EXIT fdp$create_cobol_description;

         ELSE
          destination.db_means := fdc$cobol_negative;
          destination.cr_means := fdc$cobol_positive;
        IFEND;
      IFEND;


{ Diagnose more than one floating symbol in the picture


      n_float_symbols := 0;
      IF '+' IN chars2 THEN
        n_float_symbols := n_float_symbols + 1;
      IFEND;
      IF '-' IN chars2 THEN
        n_float_symbols := n_float_symbols + 1;
      IFEND;
      IF fdv$cobol_currency_symbols.primary_money_symbol IN chars2 THEN
        n_float_symbols := n_float_symbols + 1;
      IFEND;
      IF ((fdv$cobol_currency_symbols.secondary_money_symbol <>
            fdv$cobol_currency_symbols.primary_money_symbol) AND
            (fdv$cobol_currency_symbols.secondary_money_symbol IN chars2)) THEN
        n_float_symbols := n_float_symbols + 1;
      IFEND;
      IF 'Z' IN chars THEN
        n_float_symbols := n_float_symbols + 1;
      IFEND;
      IF '*' IN chars THEN
        n_float_symbols := n_float_symbols + 1;
      IFEND;
      IF n_float_symbols >= 2 THEN

{ COBOL PICTURE cannot have two different floating symbols.

        osp$set_status_abnormal (
         fdc$format_display_identifier, fde$cobol_two_floating, '', status);
        EXIT fdp$create_cobol_description;
      IFEND;


{ Diagnose repetition count for decimal point


      IF fdv$cobol_currency_symbols.decimal_symbol IN chars THEN
        #SCAN (scan_for_dot, string_picture, ip, found);
        IF picture [ip + 1] = '(' THEN

{ COBOL PICTURE cannot have repetition count for decimal point.

          osp$set_status_abnormal (
           fdc$format_display_identifier, fde$cobol_no_rep_after_point, '', status);
          EXIT fdp$create_cobol_description;

        IFEND;
      IFEND;


{ Diagnose multiple decimal points


      IF fdv$cobol_currency_symbols.decimal_symbol IN chars2 THEN

{ COBOL numeric-edited PICTURE cannot have multiple points.

        osp$set_status_abnormal (
         fdc$format_display_identifier, fde$cobol_no_multiple_points, '', status);
        EXIT fdp$create_cobol_description;
      IFEND;


{ All of the more obvious errors have been caught.


      float := float_not_yet; { Indicate no floating symbols yet
      found_point := FALSE; { No decimal point or "V" yet
      found_p := FALSE; { No P's yet
      found_p9 := FALSE; { No P's followed by 9's yet
      found_leading_simple := FALSE; { No leading simple insertion yet
      found_9 := FALSE; { No 9's yet
      found_9p := FALSE; { No 9's followed by P's yet
      found_v := FALSE; { No V yet
      num_signif_digits := 0; { Zero digits to left of decimal point
      num_fraction_digits := 0; { Zero digits to right of decimal point
      i := 1; { Point to first character in "picture" parameter

{ Examine each character in "picture"

      WHILE (picture [i] <> ' ') AND status.normal DO

{ Set "c" to the next picture character, repeated "num" times
{ and increment "i" accordingly.

        get_char (i, c, num);

{ Tentatively increase size by count

        destination.size := destination.size + num;

{ We will be generating an operation

        destination.move_operations := destination.move_operations + 1;

{ Include repetition count in operation

        destination.operation_numbers [destination.move_operations] := num;

{ Include picture char, just in case

        destination.operation_characters [destination.move_operations] := c;

{ Handle sign character
{ Note that "B" is handled by special-case code under "D" below,
{ since "B" alone typically means insertion of blanks.

        IF c IN $ch ['+', '-', 'C', 'R', 'D'] THEN
          IF c IN chars2 THEN { c must be "+" or "-"

{ Generate floating replacement & insertion

            generate_float { using "c" and "num"
          ELSEIF c = '+' THEN

{ Found the only '+' in picture

            destination.cobol_operations [destination.move_operations] :=
             fdc$cobol_separate_sign
          ELSE

{ Found the only '-', 'C', 'R', 'D' in picture
{ Complete the operation for this character

            destination.cobol_operations [destination.move_operations] :=
             fdc$cobol_set_char_if_negative;
            IF c = 'D' THEN

{ We must have 'B' following 'D', or else we would not
{ have gotten this far.
{ Generate a "set_char_if_neg" operation for the "B"

              destination.move_operations := destination.move_operations + 1;
              destination.cobol_operations [destination.move_operations] :=
               fdc$cobol_set_char_if_negative;
              destination.operation_characters [destination.move_operations] := 'B';

{ Set "c" to the next picture character, repeated
{ "num" times and increment "i" accordingly.

              get_char (i, c, num); { Skip the 'B'

{ Include the 'B' in the pic size

              destination.size := destination.size + 1;
              IF num >= 2 THEN

{ COBOL PICTURE cannot have repetition count for CR
{ or DB

                osp$set_status_abnormal (
                 fdc$format_display_identifier, fde$cobol_no_rep_for_cr_db, '',
                 status);
              IFEND
            IFEND { c was 'D'
          IFEND { Found the only '-', 'C', 'R', 'D' in picture

          { Done with +, -, C, R, D

        ELSEIF c = '9' THEN
          IF found_9p THEN

{ Error: e.g. "99PP<9>".
{ Cannot have P's between 9's in COBOL PICTURE.

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_not_9p9, '', status);
            EXIT fdp$create_cobol_description;
          IFEND;
          found_9 := TRUE; { Be ready to set "found_9p"
          IF found_p THEN { Have e.g. "PPP999"
            found_p9 := TRUE; { Be ready to diagnose e.g. "PPP999PPP"
          IFEND;
          IF float = float_must { e.g. "$$$.$<9>"} THEN

{ In a COBOL PICTURE, if any digits to the right of the
{ decimal point are floating symbols (e.g. ++ -- ZZ ** $$)
{ then all digits must be represented by the floating symbol
{ which must also appear to the left of the decimal point
{ (i.e. "VZZZ" is not allowed).

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_right_flt_means_all, '',
             status);
            EXIT fdp$create_cobol_description;
          IFEND;

{ Indicate that we should not have any more float symbols.

          IF float = float_now THEN

{ For example, processing is occuring on  "$$$999."

            destination.cobol_operations [destination.move_operations] :=
             fdc$cobol_stop_float;
            destination.move_operations := destination.move_operations + 1;
          IFEND;
          float := float_done;

{ Generate a decimal-point aligned "move" of the digits

          destination.cobol_operations [destination.move_operations] :=
                fdc$cobol_move;
          destination.operation_numbers [destination.move_operations] := num;
{ Update the numeric attributes of the picture

          IF found_point THEN

{ Increase number of digits to right of decimal point

            num_fraction_digits := num_fraction_digits + num
          ELSE

{ Increase number of digits to left of decimal point

            num_signif_digits := num_signif_digits + num
          IFEND;
        ELSEIF c = 'P' THEN
          IF found_p9 THEN

{ Error: e.g. "PP99<P>".
{ Cannot have 9's between P's in COBOL PICTURE.

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_not_p9p, '', status);
            EXIT fdp$create_cobol_description;
          IFEND;

          found_p := TRUE; { Be ready to set "found_p9"
          IF found_9 THEN { Have e.g. "PPP999"
            found_9p := TRUE; { Be ready to diagnose e.g. "999PPP999"
          IFEND;
          IF float = float_must { e.g. "$$$.$<P>"} THEN

{ In a COBOL PICTURE, if any digits to the right of the
{ decimal point are floating symbols (e.g. ++ -- ZZ ** $$)
{ then all digits must be represented by the floating symbol
{ which must also appear to the left of the decimal point
{ (i.e. "VZZZ" is not allowed).

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_right_flt_means_all, '',
             status);
            EXIT fdp$create_cobol_description;
          IFEND;

{ Indicate that we should have have any more float symbols

          float := float_done;

          IF found_v THEN

{ "V" and "P" cannot both be used in a COBOL PICTURE.

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_not_both_v_and_p, '',
             status);
          IFEND;

{ Delete the previously-generated instruction template

          destination.move_operations := destination.move_operations - 1;

{ Do not count this in the size of the item

          destination.size := destination.size - num;

{ Note the effect on the description of the number

          IF found_point THEN

{ Increase number of digits to right of decimal point

            num_fraction_digits := num_fraction_digits + num
          ELSE

{ Increase number of digits to left of decimal point

            num_signif_digits := num_signif_digits + num
          IFEND;

{ end: c = 'P'

        ELSEIF c IN $ch ['B', '0', '/', fdv$cobol_currency_symbols.thousands_separator_symbol] THEN
          IF float = float_not_yet THEN
            found_leading_simple := TRUE; { To check for (e.g.) "+/ZZZZ"
          IFEND;

{ If "B", insertion character is a blank

          IF c = 'B' THEN
            destination.operation_characters [destination.move_operations] :=
             ' ';
          IFEND;

{ Generate "insert"

          destination.cobol_operations [destination.move_operations] :=
           fdc$cobol_insert;

{ end: c = B, 0, /, ,

        ELSEIF c = fdv$cobol_currency_symbols.decimal_symbol THEN
          IF float = float_now THEN { e.g. "$$$.<...>"
             destination.cobol_operations [destination.move_operations] :=
              fdc$cobol_stop_float;
             destination.move_operations := destination.move_operations + 1;
             float := float_all_or_none;
          ELSEIF float = float_not_yet THEN { e.g. "999."

{ Floating symbols after the decimal point are not allowed.

            float := float_done;
         IFEND;

          found_point := TRUE;
          destination.cobol_operations [destination.move_operations] :=
           fdc$cobol_insert;
          destination.operation_characters [destination.move_operations] := c;
          destination.operation_numbers [destination.move_operations] := 1;

{ end: c = .

        ELSEIF c = 'V' THEN
          IF float = float_not_yet { e.g. "999<V>"} THEN

{ Cannot have floating symbols after the decimal point

            float := float_done
          ELSEIF float = float_now { e.g. "ZZZ<V>"} THEN
            float := float_all_or_none;
          IFEND;

{ The remaining digit positions are fraction digits.

          found_point := TRUE;

          IF found_p THEN

{ "V" and "P" cannot both be used in a COBOL PICTURE.

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_not_both_v_and_p, '',
             status);

          ELSEIF ((num > 1) OR (found_v)) THEN

{ Only one "V" can be in a COBOL PICTURE.

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_too_many_vs, '', status);
          ELSE
            found_v := TRUE;
          IFEND;

{ Tell fdp$move_cobol_data to stop suppressing leading zeros.
{ A picture such as "+$$$.$$" behaves the same as "+$$$.99"
{ during normal operations.  The difference is that the former
{ will cause the entire field to be blanked if all the digits
{ are zero, which is handled by fdp$move_cobol_data.

          destination.cobol_operations [destination.move_operations] :=
           fdc$cobol_stop_float;

{ The "V" does not count in the size of the item

          destination.size := destination.size - num;

{ end: c = V

        ELSEIF c IN $ch [fdv$cobol_currency_symbols.primary_money_symbol,
              fdv$cobol_currency_symbols.secondary_money_symbol, '*', 'Z'] THEN
          IF ((c = fdv$cobol_currency_symbols.primary_money_symbol) OR
              (c = fdv$cobol_currency_symbols.secondary_money_symbol))
                AND NOT (c IN chars2) THEN

{ Insert the single "$" or "#" character

            destination.cobol_operations [destination.move_operations] :=
             fdc$cobol_insert
          ELSE { At least "$$", "##", "*", or "Z"

{ Generate floating diagnostics and code

            generate_float
          IFEND { "$", "#"
        IFEND { "$", "#", "*", "Z"
      WHILEND;

      IF (num_signif_digits + num_fraction_digits) > 18 THEN

{ Cannot enter more than 18 digit positions.

        osp$set_status_abnormal (
         fdc$format_display_identifier, fde$cobol_too_many_digits, '', status);
        EXIT fdp$create_cobol_description;
      IFEND;

      destination.significant_digits := num_signif_digits;
      destination.number_digits := num_signif_digits + num_fraction_digits;

    PROCEND process_numeric_edited_picture;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

{ Initialize the item description

{ Number of operations for fdp$move_cobol_data

    destination.move_operations := 0;
    destination.size := 0; { Number of characters in item

{ Number of digit to left of decimal point

    destination.significant_digits := 0;
    destination.number_digits := 0; { Total number of digits
    destination.sign_index := 0; { assume no sign
    destination.cr_means := fdc$cobol_cr_db_illegal; {"CR" illegal in free-form
    destination.db_means := fdc$cobol_cr_db_illegal; {"DB" illegal in free-form
    destination.display_cr := FALSE; { fdp$move_cobol_data won't produce "CR"
    destination.display_db := FALSE; { fdp$move_cobol_data won't produce "DB"

{ For the "picture" parameter, convert lower case letters to upper case
{ The "30" below can be taken from the COBOL/VE Usage Manual.
{ It is used to determine "max_ops"; see the discussion at the end of
{ fdp$create_cobol_description.

    #TRANSLATE (osv$lower_to_upper, cobol_picture_symbols, string_picture);
    i#move (^string_picture, ^picture, #SIZE (picture));

{ Determine the category of the picture

{ The first of two steps in determining the category of the picture is
{ to tally which characters appear in the picture.  Since the picture
{ can have a repetition count, "(...)", following many characters,
{ we must recognize this since we don't want a picture such as "X(9)"
{ to be interpreted as having X's and 9's.
{ "Process_numeric_edited_picture" needs to know if certain characters
{ appear more than once, so we detect that now, also.

    chars := $ch []; { Characters appearing 1 or more times
    chars2 := $ch []; { Characters appearing 2 or more times, for numeric-edited
    outside_parens := TRUE; { Start outside of "(...)"
    FOR i := 1 TO 30 DO
      IF outside_parens THEN

{ We are not within a repetition count.

        IF picture [i] = '(' THEN

{ Start processing a repetition count.

          outside_parens := FALSE
        ELSE

{ This character is part of the logical picture,
{ not part of a repetition count

          IF (picture [i] IN chars)
                OR (picture [i+1] = '(') THEN
            chars2 := chars2 + $ch [picture [i]];
            chars  := chars  + $ch [picture [i]];
          ELSE
            chars := chars + $ch [picture [i]];
          IFEND;
        IFEND;

{ We were not within a repetition count.

      ELSE

{ We previously had "(..."

        IF picture [i] = ')' THEN

{ We have "(...)", so terminate repetition count

          outside_parens := TRUE
        ELSE

{ We are within "(..."

          IF (picture [i] = ' ') THEN

{ We ended the picture with "(..."
{ COBOL PICTURE has left parenthesis without matching right parenthesis.

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_unbal_parens, '', status);
            EXIT fdp$create_cobol_description;
          IFEND;

          IF (picture [i] < '0') OR (picture [i] > '9') THEN

{ Current character is non-digit
{ In a COBOL PICTURE, characters between a left and right
{ parentheses are a repetition count, and must be decimal
{ digits.

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_nondigit_rep_count, '',
             status);
            EXIT fdp$create_cobol_description;

          IFEND
        IFEND { not )
      IFEND { We have "(..." or "(...)"
    FOREND { i} ;

    IF NOT outside_parens THEN

{ We ended the picture with "(..."
{ COBOL PICTURE has left parenthesis without matching right parenthesis.

      osp$set_status_abnormal (
       fdc$format_display_identifier, fde$cobol_unbal_parens, '', status);
      EXIT fdp$create_cobol_description;
    IFEND;

    chars := chars - $ch [' ']; { Ignore trailing blanks

{ The second of two steps in determining the category of the picture is to
{ examine the characters we have tallied, as well as the USAGE parameter.

    IF cobol_usage_keyword = fdc$free_form_usage THEN
      destination.cobol_category := fdc$cobol_free_form
    ELSEIF 'P' IN chars THEN
      osp$set_status_abnormal (
       fdc$format_display_identifier, fde$cobol_p_not_supported, '', status);
      EXIT fdp$create_cobol_description;
    ELSEIF chars <= $ch ['A', 'B'] THEN
      destination.cobol_category := fdc$cobol_alphabetic
    ELSEIF chars <= $ch ['9', 'V', ] THEN
      destination.cobol_category := fdc$cobol_numeric_unsigned
    ELSEIF chars <= $ch ['9', 'V', 'S'] THEN
      destination.cobol_category := fdc$cobol_numeric_signed
    ELSEIF chars <= $ch ['A', 'X', '9'] THEN
      destination.cobol_category := fdc$cobol_alphanumeric
    ELSEIF (chars <= $ch ['A', 'X', '9', 'B', '0', '/'])
     AND (('A' IN chars) OR ('X' IN chars)) THEN
      destination.cobol_category := fdc$cobol_alphanumeric_edited
    ELSEIF chars <= $ch ['9', 'V', '0', '9',
      fdv$cobol_currency_symbols.thousands_separator_symbol,
      fdv$cobol_currency_symbols.decimal_symbol, '*', '+', '-',
     'C', 'R', 'D', 'B', fdv$cobol_currency_symbols.primary_money_symbol,
      fdv$cobol_currency_symbols.secondary_money_symbol, 'Z', '/'] THEN
      destination.cobol_category := fdc$cobol_numeric_edited
    ELSEIF chars <= $ch ['9', 'V', '0', '9',
      fdv$cobol_currency_symbols.thousands_separator_symbol,
      fdv$cobol_currency_symbols.decimal_symbol, '*', '+', '-',
     'C', 'R', 'D', 'B', fdv$cobol_currency_symbols.primary_money_symbol,
           fdv$cobol_currency_symbols.secondary_money_symbol, 'Z', 'A', 'X', '/', 'S'] THEN

{ Each COBOL PICTURE character is legal, but the combination is not.

      osp$set_status_abnormal (
       fdc$format_display_identifier, fde$cobol_bad_picture, '', status);
      EXIT fdp$create_cobol_description;

    ELSE

{ An illegal character is used in a COBOL PICTURE

      osp$set_status_abnormal (
       fdc$format_display_identifier, fde$cobol_illegal_pic_char, '', status);
      EXIT fdp$create_cobol_description;

    IFEND;

{ Make sure the "usage" parameter is good, and set "destination.cobol_usage"

{ Also make sure the category of the picture is consistent with "usage".

{ Make sure "usage" parameter is good, and set "usage" field

  CASE cobol_usage_keyword OF

    = fdc$free_form_usage =

{ Nothing to do.

    = fdc$binary_usage, fdc$computational_usage, fdc$comp_usage =
      CASE destination.cobol_category OF
      = fdc$cobol_numeric_signed, fdc$cobol_numeric_unsigned =
         destination.cobol_usage := fdc$cobol_usage_binary;
      ELSE

{ USAGE IS BINARY, COMPUTATIONAL, or COMP can only be used
{ with a PICTURE describing a numeric (signed or unsiged) item.

        osp$set_status_abnormal (
         fdc$format_display_identifier, fde$cobol_binary_means_numeric, '',
         status);
        EXIT fdp$create_cobol_description;
      CASEND;

    = fdc$computational_1_usage, fdc$comp_1_usage =
      IF picture [1] <> ' ' THEN

{ USAGE IS COMPUTATIONAL-1 or COMP-1 can only be used
{ without a PICTURE.

        osp$set_status_abnormal (
         fdc$format_display_identifier, fde$cobol_comp_1_means_no_pic, '', status);
        EXIT fdp$create_cobol_description;
      IFEND;
      destination.cobol_usage := fdc$cobol_usage_single;
      destination.size := bytes_for_single;
      destination.cobol_category := fdc$cobol_numeric_signed;

    = fdc$computational_2_usage, fdc$comp_2_usage =
      IF picture [1] <> ' ' THEN


{ USAGE IS COMPUTATIONAL-2 or COMP-2 can only be used
{ without a PICTURE.

        osp$set_status_abnormal (
         fdc$format_display_identifier, fde$cobol_comp_2_means_no_pic, '', status);
        EXIT fdp$create_cobol_description;
      IFEND;
      destination.cobol_usage := fdc$cobol_usage_double;
      destination.size := bytes_for_double;
      destination.cobol_category := fdc$cobol_numeric_signed;

    = fdc$computational_3_usage, fdc$comp_3_usage, fdc$packed_decimal_usage =
      CASE destination.cobol_category OF
      = fdc$cobol_numeric_signed, fdc$cobol_numeric_unsigned =
        destination.cobol_usage := fdc$cobol_usage_packed;
      ELSE

{ USAGE IS PACKED-DECIMAL, COMPUTATIONAL-3 or COMP-3
{ can only be used with a PICTURE describing a numeric item.

        osp$set_status_abnormal (
         fdc$format_display_identifier, fde$cobol_packed_means_num_pic, '',
         status);
        EXIT fdp$create_cobol_description;
      CASEND;

    = fdc$display_usage =
      destination.cobol_usage := fdc$cobol_usage_display

    ELSE

{ Unrecognized USAGE keyword for COBOL field.

      osp$set_status_abnormal (
       fdc$format_display_identifier, fde$cobol_unknown_usage, '', status);
      EXIT fdp$create_cobol_description;
    CASEND;

{ The parameters are correct, except perhaps for details of "picture".

{ Comment: Code in "process_xxx_picture" increments destination.move_operations
{          without checking to see if it exceeds "max_ops".  This is safe
{          because each character in a picture can generate at most
{          one operation, except that starting and stopping a
{          numeric-edited floating string can happen once each per
{          picture, for a maximum of 32, which is the value of max_ops.

    IF  (destination.cobol_usage = fdc$cobol_usage_display)
          OR (destination.cobol_usage = fdc$cobol_usage_binary )
          OR (destination.cobol_usage = fdc$cobol_usage_packed ) THEN

      CASE destination.cobol_category OF
      = fdc$cobol_alphabetic =
        process_alphabetic_picture;
      = fdc$cobol_alphanumeric =
        process_alphanumeric_picture;
      = fdc$cobol_alphanumeric_edited =
        process_alphanumeric_edited_pic;
      = fdc$cobol_numeric_signed, fdc$cobol_numeric_unsigned =
        process_numeric_picture;
      = fdc$cobol_numeric_edited =
        process_numeric_edited_picture;
      ELSE
      CASEND { destination.cobol_category
    IFEND { usage is display, binary, or packed-decimal
  PROCEND fdp$create_cobol_description;

MODEND fdm$create_cobol_description;

*DECK DECK=FDM$CREATE_EVENT_FORM EXPAND=TRUE

?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE fdm$create_event_form;

*copyc cyd$run_time_error_condition

*copyc csp$change_capability_level
*copyc csp$get_device_attributes
*copyc csp$get_device_dimensions

*copyc fdp$change_form
*copyc fdp$close_form
*copyc fdp$create_form
*copyc fdp$create_object
*copyc fdp$create_table
*copyc fdp$end_form
*copyc fdp$convert_terminal_status
*copyc fdp$create_variable
*copyc fdp$get_screen_events
*copyc fdp$open_form
*copyc fdt$event_label_v1
*copyc fdt$event_menu
*copyc fdt$event_trigger
*copyc fdt$screen_status
*copyc fdt$x_position
*copyc fdt$y_position

*copyc pmp$continue_to_cause

*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal

?? TITLE := 'fdp$create_event_form', EJECT ??
*copyc fdh$create_event_form

  PROCEDURE [XDCL] fdp$create_event_form
    (    event_menus: array [1 .. * ] OF fdt$event_menu;
     VAR form_attributes: fdt$form_attributes;
     VAR form_identifier: fdt$form_identifier;
     VAR status: ost$status);

    VAR
      application_functions: cst$application_functions,
      blank_label: [READ, STATIC] string (6) := ' ',
      device_attributes: array [1 .. 1] of cst$device_attribute,
      event_form_attributes: array [1 .. 1] of fdt$form_attribute,
      event_label_positions: [READ, STATIC] array [1 .. 16] of fdt$x_position :=
            [4, 14, 24, 34, 44, 54, 64, 74, 4, 14, 24, 34, 44, 54, 64, 74],
      event_labels: array [1 .. 16] of fdt$event_label_v1,
      event_names: array [1 .. 16] of ost$name,
      fdv$screen_status: [XREF] fdt$screen_status,
      key_label_increment: 0 .. 8,
      key_label_positions: [READ, STATIC] array [1 .. 16] of fdt$x_position :=
            [1, 11, 21, 31, 41, 51, 61, 71, 1, 11, 21, 31, 41, 51, 61, 71],
      line_number: cst$line_number,
      local_status: ost$status,
      n: integer,
      non_shifted_1_8: 0 .. 1,
      non_shifted_9_16: 0 .. 1,
      number_errors: fdt$number_errors,
      number_menu_rows: integer,
      object_definition: fdt$object_definition,
      object_attributes: array [1 .. 2] of fdt$object_attribute,
      p_errors: ^SEQ ( * ),
      shifted_1_8: 0 .. 1,
      shifted_9_16: 0 .. 1,
      shift_event_labels: array [1 .. 16] of fdt$event_label_v1,
      shift_event_names: array [1 .. 16] of ost$name,
      terminal_status: ost$status,
      variable_attributes: array [1 .. 2] of fdt$variable_attribute,
      variable_name: ost$name,
      visible_character_position: cst$visible_character_position,
      y_position: fdt$y_position;

?? NEWTITLE := 'condition_handler', EJECT ??

  PROCEDURE condition_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         stack_frame_save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    CASE condition.selector OF

    = pmc$system_conditions =
      IF (condition.system_conditions * $pmt$system_conditions
            [pmc$instruction_specification, pmc$address_specification,
            pmc$access_violation, pmc$invalid_segment_ring_0, pmc$divide_fault,
            pmc$arithmetic_overflow, pmc$exponent_overflow,
            pmc$exponent_underflow, pmc$fp_significance_loss,
            pmc$fp_indefinite, pmc$arithmetic_significance,
            pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$create_event_form;
      IFEND;

    = pmc$user_defined_condition =
      IF condition.user_condition_name = cye$run_time_condition THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$create_event_form;
      IFEND;

    ELSE
      ;
    CASEND;
    pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
  PROCEND condition_handler;

?? OLDTITLE ??
?? NEWTITLE := 'create_labels', EJECT ??

    PROCEDURE [INLINE] create_labels
      (    first_label: integer;
           last_label: integer;
           first_event_trigger: fdt$event_trigger;
           p_event_labels: ^array [1 .. * ] OF fdt$event_label_v1;
           p_event_names: ^array [1 .. * ] OF ost$name;
           y_position: fdt$y_position;
       VAR status: ost$status);

      VAR
        event_trigger: fdt$event_trigger,
        object_attributes: array [1 .. 2] of fdt$object_attribute;

      event_trigger := first_event_trigger;
      /create_label_objects/
      FOR n := first_label TO last_label DO

{ Create program event label.

      object_attributes [1].key := fdc$object_display;
      object_attributes [1].display_attribute := $fdt$display_attribute_set [fdc$inverse_video];
        IF (p_event_names^ [n] = osc$null_name) THEN
          object_attributes [2].key := fdc$unused_object_entry;
          object_definition.key := fdc$constant_text;
          object_definition.constant_text_width := 6;
          object_definition.p_constant_text := ^blank_label;
          fdp$create_object (form_identifier, event_label_positions [n], y_position, object_definition,
                object_attributes, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        ELSE

{ For a non-blank event name, create a variable object.  A application program
{ may change the program event label by using the event name in a replace string variable request.
{ The program event label tells the terminal user what the event does.  Examples are copy, delete,
{ and add.

          object_attributes [2].key := fdc$object_name;
          object_attributes [2].object_name := p_event_names^ [n];
          object_attributes [2].occurrence := 1;
          object_definition.key := fdc$variable_text;
          object_definition.variable_text_width := 6;
          object_definition.p_variable_text := ^p_event_labels^ [n];
          fdp$create_object (form_identifier, event_label_positions [n], y_position, object_definition,
                object_attributes, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

{ Create label for terminal function key. This tells the terminal user what key(s) to press.

        object_attributes [1].key := fdc$unused_object_entry;
        object_attributes [2].key := fdc$unused_object_entry;
        object_definition.key := fdc$constant_text;
        object_definition.constant_text_width := 2;
        object_definition.p_constant_text := ^fdv$screen_status.p_screen_event_statuses^ [event_trigger].
              event_label;
        fdp$create_object (form_identifier, key_label_positions [n], y_position, object_definition,
              object_attributes, status);
        IF NOT status.normal THEN
            RETURN;
        IFEND;

        event_trigger := SUCC (event_trigger);
      FOREND /create_label_objects/;
    PROCEND create_labels;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;

{ Get terminal event definitions. }

    IF fdv$screen_status.p_screen_event_statuses = NIL THEN
      fdp$get_screen_events (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    shifted_1_8 := 0;
    shifted_9_16 := 0;
    non_shifted_1_8 := 0;
    non_shifted_9_16 := 0;

    FOR n := LOWERBOUND (event_names) to UPPERBOUND (event_names) DO
      event_names [n] := osc$null_name;
      event_labels [n] := '';
      shift_event_names [n] := osc$null_name;
      shift_event_labels [n] := '';
    FOREND;

{ Determine events user requires.

    FOR n := LOWERBOUND (event_menus) TO UPPERBOUND (event_menus) DO
      CASE event_menus [n].event_trigger OF

      = fdc$function_1 =
        event_labels [1] := event_menus [n].event_label;
        event_names [1] := event_menus [n].event_name;
        non_shifted_1_8 := 1;

      = fdc$function_2 =
        event_labels [2] := event_menus [n].event_label;
        event_names [2] := event_menus [n].event_name;
        non_shifted_1_8 := 1;

      = fdc$function_3 =
        event_labels [3] := event_menus [n].event_label;
        event_names [3] := event_menus [n].event_name;
        non_shifted_1_8 := 1;

      = fdc$function_4 =
        event_labels [4] := event_menus [n].event_label;
        event_names [4] := event_menus [n].event_name;
        non_shifted_1_8 := 1;

      = fdc$function_5 =
        event_labels [5] := event_menus [n].event_label;
        event_names [5] := event_menus [n].event_name;
        non_shifted_1_8 := 1;

      = fdc$function_6 =
        event_labels [6] := event_menus [n].event_label;
        event_names [6] := event_menus [n].event_name;
        non_shifted_1_8 := 1;

      = fdc$function_7 =
        event_labels [7] := event_menus [n].event_label;
        event_names [7] := event_menus [n].event_name;
        non_shifted_1_8 := 1;

      = fdc$function_8 =
        event_labels [8] := event_menus [n].event_label;
        event_names [8] := event_menus [n].event_name;
        non_shifted_1_8 := 1;

      = fdc$function_9 =
        event_labels [9] := event_menus [n].event_label;
        event_names [9] := event_menus [n].event_name;
        number_menu_rows := 2;
        non_shifted_9_16 := 1;

      = fdc$function_10 =
        event_labels [10] := event_menus [n].event_label;
        event_names [10] := event_menus [n].event_name;
        non_shifted_9_16 := 1;

      = fdc$function_11 =
        event_labels [11] := event_menus [n].event_label;
        event_names [11] := event_menus [n].event_name;
        non_shifted_9_16 := 1;

      = fdc$function_12 =
        event_labels [12] := event_menus [n].event_label;
        event_names [12] := event_menus [n].event_name;
        non_shifted_9_16 := 1;

      = fdc$function_13 =
        event_labels [13] := event_menus [n].event_label;
        event_names [13] := event_menus [n].event_name;
        non_shifted_9_16 := 1;

      = fdc$function_14 =
        event_labels [14] := event_menus [n].event_label;
        event_names [14] := event_menus [n].event_name;
        non_shifted_9_16 := 1;

      = fdc$function_15 =
        event_labels [15] := event_menus [n].event_label;
        event_names [15] := event_menus [n].event_name;
        non_shifted_9_16 := 1;

      = fdc$function_16 =
        event_labels [16] := event_menus [n].event_label;
        event_names [16] := event_menus [n].event_name;
        non_shifted_9_16 := 1;

      = fdc$shift_function_1 =
        shift_event_labels [1] := event_menus [n].event_label;
        shift_event_names [1] := event_menus [n].event_name;
        shifted_1_8 := 1;

      = fdc$shift_function_2 =
        shift_event_labels [2] := event_menus [n].event_label;
        shift_event_names [2] := event_menus [n].event_name;
        shifted_1_8 := 1;

      = fdc$shift_function_3 =
        shift_event_labels [3] := event_menus [n].event_label;
        shift_event_names [3] := event_menus [n].event_name;
        shifted_1_8 := 1;

      = fdc$shift_function_4 =
        shift_event_labels [4] := event_menus [n].event_label;
        shift_event_names [4] := event_menus [n].event_name;
        shifted_1_8 := 1;

      = fdc$shift_function_5 =
        shift_event_labels [5] := event_menus [n].event_label;
        shift_event_names [5] := event_menus [n].event_name;
        shifted_1_8 := 1;

      = fdc$shift_function_6 =
        shift_event_labels [6] := event_menus [n].event_label;
        shift_event_names [6] := event_menus [n].event_name;
        shifted_1_8 := 1;

      = fdc$shift_function_7 =
        shift_event_labels [7] := event_menus [n].event_label;
        shift_event_names [7] := event_menus [n].event_name;
        shifted_1_8 := 1;

      = fdc$shift_function_8 =
        shift_event_labels [8] := event_menus [n].event_label;
        shift_event_names [8] := event_menus [n].event_name;
        shifted_1_8 := 1;

      = fdc$shift_function_9 =
        shift_event_labels [9] := event_menus [n].event_label;
        shift_event_names [9] := event_menus [n].event_name;
        shifted_9_16 := 1;

      = fdc$shift_function_10 =
        shift_event_labels [10] := event_menus [n].event_label;
        shift_event_names [10] := event_menus [n].event_name;
        shifted_9_16 := 1;

      = fdc$shift_function_11 =
        shift_event_labels [11] := event_menus [n].event_label;
        shift_event_names [11] := event_menus [n].event_name;
        shifted_9_16 := 1;

      = fdc$shift_function_12 =
        shift_event_labels [12] := event_menus [n].event_label;
        shift_event_names [12] := event_menus [n].event_name;
        shifted_9_16 := 1;

      = fdc$shift_function_13 =
        shift_event_labels [13] := event_menus [n].event_label;
        shift_event_names [13] := event_menus [n].event_name;
        shifted_9_16 := 1;

      = fdc$shift_function_14 =
        shift_event_labels [14] := event_menus [n].event_label;
        shift_event_names [14] := event_menus [n].event_name;
        shifted_9_16 := 1;

      = fdc$shift_function_15 =
        shift_event_labels [15] := event_menus [n].event_label;
        shift_event_names [15] := event_menus [n].event_name;
        shifted_9_16 := 1;

      = fdc$shift_function_16 =
        shift_event_labels [16] := event_menus [n].event_label;
        shift_event_names [16] := event_menus [n].event_name;
        shifted_9_16 := 1;

      ELSE { Do nothing for these event triggers.}
      CASEND;
    FOREND;

{ Obtain terminal device attributes to determine form size
{ and position.  If the home cursor position is on the last line
{ of the terminal screen, then the event form must not overlay
{ the last line.

    IF NOT fdv$screen_status.screen_mode_active THEN
      csp$change_capability_level (csc$screen_level, terminal_status);
      IF ((NOT terminal_status.normal) AND (terminal_status.condition <> cse$redundant_screen_level)) THEN
        fdp$convert_terminal_status (terminal_status, status);
        RETURN;
      IFEND;
      fdv$screen_status.screen_mode_active := TRUE;
    IFEND;

    device_attributes [1].key := csc$da_home_at_top;
    csp$get_device_attributes (device_attributes, terminal_status);
    IF NOT terminal_status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
      RETURN;
    IFEND;

    csp$get_device_dimensions (visible_character_position, line_number, terminal_status);
    IF NOT terminal_status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
      RETURN;
    IFEND;

{ Define event form. }
{ The application programmers"s attributes for form size and position will be }
{ replaced by those computed by Screen Formatting. }

    fdp$create_form (form_identifier, form_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Attempt to minimize the space required for the event form. }
{ Only application terminal events appear on the event form. }
{ If a shifted terminal event occurs, then the corresponding non-shifted }
{ terminal event must also be shown on the terminal. }

    IF shifted_1_8 <> 0 THEN
      non_shifted_1_8 := 1;
    IFEND;
    IF shifted_9_16 <> 0 THEN
      non_shifted_9_16 := 1;
    IFEND;

    y_position := shifted_1_8 + non_shifted_1_8 + shifted_9_16 + non_shifted_9_16;
    IF ((non_shifted_1_8 <> 0) AND (non_shifted_9_16 <> 0)) THEN
      y_position := y_position + 1;
    IFEND;

    event_form_attributes [1].key := fdc$form_area;
    event_form_attributes [1].form_area.key := fdc$defined_area;
    event_form_attributes [1].form_area.x_position := 1;
    event_form_attributes [1].form_area.height := y_position;
    IF device_attributes [1].home_at_top THEN
      event_form_attributes [1].form_area.y_position := line_number + 1 - y_position;
    ELSE
      event_form_attributes [1].form_area.y_position := line_number - y_position;
    IFEND;

    event_form_attributes [1].form_area.width := 80;
    fdp$change_form (form_identifier, event_form_attributes, status);
    IF NOT status.normal THEN
      fdp$close_form (form_identifier, local_status);
      RETURN;
    IFEND;

    variable_attributes [1].key := fdc$program_data_type;
    variable_attributes [1].program_data_type := fdc$program_character_type;
    variable_attributes [2].key := fdc$io_mode;
    variable_attributes [2].io_mode := fdc$terminal_output;

{ Create variables for event names. }
{ The application programmer may change the values and attributes by }
{ using these variable names. }

    FOR n := LOWERBOUND (event_names) to UPPERBOUND (event_names) DO
      IF (event_names [n] <> osc$null_name) THEN
        fdp$create_variable (form_identifier, event_names [n], variable_attributes, status);
        IF NOT status.normal THEN
           osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
              'creating event form', status);
          fdp$close_form (form_identifier, local_status);
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    FOR n := LOWERBOUND (shift_event_names) to UPPERBOUND (shift_event_names) DO
      IF (shift_event_names [n] <> osc$null_name) THEN
        fdp$create_variable (form_identifier, shift_event_names [n], variable_attributes, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
                'creating event form', status);
          fdp$close_form (form_identifier, local_status);
          RETURN;
        IFEND;
      IFEND;
    FOREND;


{ Create event labels on the terminal screen. }

    y_position := 1;

{ Create shifted labels for application functions 1-8. }

    IF (shifted_1_8 <> 0) THEN
      create_labels (1, 8, fdc$shift_function_1, ^shift_event_labels, ^shift_event_names,
          y_position, status);
      y_position := y_position + 1;
      IF NOT status.normal THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
           'creating event form', status);
        fdp$close_form (form_identifier, local_status);
        RETURN;
      IFEND;
    IFEND;

{ Create non-shifted labels for application functions 1-8. }

    IF (non_shifted_1_8 <> 0) THEN
      create_labels (1, 8, fdc$function_1, ^event_labels, ^event_names, y_position, status);
      y_position := y_position + 1;
      IF NOT status.normal THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
           'creating event form', status);
        fdp$close_form (form_identifier, local_status);
        RETURN;
      IFEND;
    IFEND;

{ Create shifted labels for application functions 9-16. }

    IF (non_shifted_1_8 <> 0) THEN

{ Put blank line between functions 1-8 and functions 9-16.

      y_position := y_position + 1;

    IFEND;

    IF (shifted_9_16 <> 0) THEN
      create_labels (9, 16, fdc$shift_function_9, ^shift_event_labels,
          ^shift_event_names, y_position, status);
      y_position := y_position + 1;
      IF NOT status.normal THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
           'creating event form', status);
        fdp$close_form (form_identifier, local_status);
        RETURN;
      IFEND;
    IFEND;

{ Create non-shifted labels for application functions 9-16. }

    IF (non_shifted_9_16 <> 0) THEN
      create_labels (9, 16, fdc$function_9, ^event_labels, ^event_names, y_position, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
           'creating event form', status);
        fdp$close_form (form_identifier, local_status);
        RETURN;
      IFEND;
    IFEND;

    fdp$end_form (form_identifier, NIL, number_errors, p_errors, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
           'creating event form', status);
      fdp$close_form (form_identifier, local_status);
      RETURN;
    IFEND;

    IF number_errors <> 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
           'creating event form', status);
      fdp$close_form (form_identifier, local_status);
    IFEND;
  PROCEND fdp$create_event_form;

MODEND fdm$create_event_form;
*DECK DECK=FDM$CREATE_FORM_MODULE EXPAND=TRUE

?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Screen Formatting : Create Form Module' ??
MODULE fdm$create_form_module;

{ PURPOSE:
{   This module creates a form binary from a form source language definition.
{   The form definition language uses SCL.
{
{ DESIGN:
{   This modules uses procedures furnished by SCL to do most of the processing.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fdc$maximum_valid_ranges
*copyc fdc$system_currency_sign
*copyc fdc$system_decimal_point
*copyc fdc$system_thousands_separator
*copyc fdt$form_module
*copyc fdt$sign_treatment
*copyc fdv$screen_status
*copyc ost$stack_frame_save_area
?? POP ??

*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi

*copyc clp$begin_utility
*copyc clp$count_list_elements
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc clp$trimmed_string_size

*copyc fdp$change_form
*copyc fdp$change_form_record
*copyc fdp$change_variable
*copyc fdp$close_form
*copyc fdp$create_form
*copyc fdp$create_object
*copyc fdp$create_stored_object
*copyc fdp$create_table
*copyc fdp$create_variable
*copyc fdp$end_form
*copyc fdp$write_form_definition

*copyc fsp$close_file
*copyc fsp$open_file

*copyc i#current_sequence_position

*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment

*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    fdt$long_real_record = record
      first_real: real,
      second_real: real,
    recend;

  VAR
    create_form: boolean,
    current_form_name: ost$name,
    current_form_identifier: fdt$form_identifier,
    form_ended: boolean := TRUE,
    form_processor: fdt$form_processor;

?? OLDTITLE ??
?? NEWTITLE := 'Gobal Read Storage', EJECT ??

  SECTION
    global_storage: READ;

  VAR
    one_blank: [READ, STATIC, global_storage] string (1) := ' ',
    to_cobol: [READ, STATIC, global_storage] string (256) :=
          '???????????????????????????????' CAT
          '? ????????????-??0123456789???????ABCDEFGHIJKLMNOPQRSTUVWXYZ' CAT
          '????-?abcdefghijklmnopqrstuvwxyz' CAT '??????????????????????????????????????????????????????????'
          CAT '??????????????????????????' CAT '?????????????????????????????????????????????????',
    to_scl: [READ, STATIC, global_storage] string (256) :=
          '???????????????????????????????' CAT
          '? ????????????_??0123456789???????ABCDEFGHIJKLMNOPQRSTUVWXYZ' CAT
          '????-?abcdefghijklmnopqrstuvwxyz' CAT '??????????????????????????????????????????????????????????'
          CAT '??????????????????????????' CAT '?????????????????????????????????????????????????',
    utility_name: [READ, STATIC, global_storage] ost$name := 'CREATE_FORM_MODULE',
    utility_prompt: [READ, STATIC, global_storage] string (3) := 'CFM';

?? OLDTITLE ??
?? NEWTITLE := 'Command List', EJECT ??

  SECTION
    fds$sub_commands_and_functions: READ;

{Read-only sub-command and function list for SCL}

{ table sub_commands type=command section_name=fds$sub_commands_and_functions scope=local
{ command (add_box,                addb)   add_box
{ command (add_constant_text,      addct)  add_constant_text
{ command (add_constant_text_box,  addctb) add_constant_text_box
{ command (add_display,            addd)   add_display
{ command (add_event,              adde)   add_event
{ command (add_line,               addl)   add_line
{ command (add_stored_text,        addst)  add_stored_text
{ command (add_table,              addt)   add_table
{ command (add_variable,           addv)   add_variable
{ command (add_variable_text,      addvt)  add_variable_text
{ command (add_variable_text_box,  addvtb) add_variable_text_box
{ command (set_character_input,    setci)  set_character_input
{ command (set_cobol_data,         setcd)  set_cobol_data
{ command (set_cobol_output        setco)  set_cobol_output
{ command (set_date_input,         setdi)  set_date_input
{ command (set_date_output,        setdo)  set_date_output
{ command (set_exponent_output,    seteo)  set_exponent_output
{ command (set_float_output,       setfo)  set_float_output
{ command (set_form,               setf)   set_form cm=local
{ command (set_integer_input,      setii)  set_integer_input
{ command (set_integer_output,     setio)  set_integer_output
{ command (set_money_input,        setmi)  set_money_input
{ command (set_money_output,       setmo)  set_money_output
{ command (set_real_input,         setri)  set_real_input
{ command (end_form_module,        quit,qui,endfm) end_form_module
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  sub_commands: [STATIC, READ, fds$sub_commands_and_functions] ^clt$command_table := ^sub_commands_entries,

  sub_commands_entries: [STATIC, READ, fds$sub_commands_and_functions] array [1 .. 52] of
      clt$command_table_entry := [
  {} ['ADDB                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^add_box],
  {} ['ADDCT                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^add_constant_text],
  {} ['ADDCTB                         ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^add_constant_text_box],
  {} ['ADDD                           ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^add_display],
  {} ['ADDE                           ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^add_event],
  {} ['ADDL                           ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^add_line],
  {} ['ADDST                          ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^add_stored_text],
  {} ['ADDT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^add_table],
  {} ['ADDV                           ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^add_variable],
  {} ['ADDVT                          ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^add_variable_text],
  {} ['ADDVTB                         ', clc$abbreviation_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^add_variable_text_box],
  {} ['ADD_BOX                        ', clc$nominal_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^add_box],
  {} ['ADD_CONSTANT_TEXT              ', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^add_constant_text],
  {} ['ADD_CONSTANT_TEXT_BOX          ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^add_constant_text_box],
  {} ['ADD_DISPLAY                    ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^add_display],
  {} ['ADD_EVENT                      ', clc$nominal_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^add_event],
  {} ['ADD_LINE                       ', clc$nominal_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^add_line],
  {} ['ADD_STORED_TEXT                ', clc$nominal_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^add_stored_text],
  {} ['ADD_TABLE                      ', clc$nominal_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^add_table],
  {} ['ADD_VARIABLE                   ', clc$nominal_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^add_variable],
  {} ['ADD_VARIABLE_TEXT              ', clc$nominal_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^add_variable_text],
  {} ['ADD_VARIABLE_TEXT_BOX          ', clc$nominal_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^add_variable_text_box],
  {} ['ENDFM                          ', clc$abbreviation_entry, clc$normal_usage_entry, 25,
        clc$automatically_log, clc$linked_call, ^end_form_module],
  {} ['END_FORM_MODULE                ', clc$nominal_entry, clc$normal_usage_entry, 25,
        clc$automatically_log, clc$linked_call, ^end_form_module],
  {} ['QUI                            ', clc$alias_entry, clc$normal_usage_entry, 25,
        clc$automatically_log, clc$linked_call, ^end_form_module],
  {} ['QUIT                           ', clc$alias_entry, clc$normal_usage_entry, 25,
        clc$automatically_log, clc$linked_call, ^end_form_module],
  {} ['SETCD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^set_cobol_data],
  {} ['SETCI                          ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^set_character_input],
  {} ['SETCO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 14,
        clc$automatically_log, clc$linked_call, ^set_cobol_output],
  {} ['SETDI                          ', clc$abbreviation_entry, clc$normal_usage_entry, 15,
        clc$automatically_log, clc$linked_call, ^set_date_input],
  {} ['SETDO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 16,
        clc$automatically_log, clc$linked_call, ^set_date_output],
  {} ['SETEO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 17,
        clc$automatically_log, clc$linked_call, ^set_exponent_output],
  {} ['SETF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 19,
        clc$automatically_log, clc$linked_call, ^set_form],
  {} ['SETFO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 18,
        clc$automatically_log, clc$linked_call, ^set_float_output],
  {} ['SETII                          ', clc$abbreviation_entry, clc$normal_usage_entry, 20,
        clc$automatically_log, clc$linked_call, ^set_integer_input],
  {} ['SETIO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 21,
        clc$automatically_log, clc$linked_call, ^set_integer_output],
  {} ['SETMI                          ', clc$abbreviation_entry, clc$normal_usage_entry, 22,
        clc$automatically_log, clc$linked_call, ^set_money_input],
  {} ['SETMO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 23,
        clc$automatically_log, clc$linked_call, ^set_money_output],
  {} ['SETRI                          ', clc$abbreviation_entry, clc$normal_usage_entry, 24,
        clc$automatically_log, clc$linked_call, ^set_real_input],
  {} ['SET_CHARACTER_INPUT            ', clc$nominal_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^set_character_input],
  {} ['SET_COBOL_DATA                 ', clc$nominal_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^set_cobol_data],
  {} ['SET_COBOL_OUTPUT               ', clc$nominal_entry, clc$normal_usage_entry, 14,
        clc$automatically_log, clc$linked_call, ^set_cobol_output],
  {} ['SET_DATE_INPUT                 ', clc$nominal_entry, clc$normal_usage_entry, 15,
        clc$automatically_log, clc$linked_call, ^set_date_input],
  {} ['SET_DATE_OUTPUT                ', clc$nominal_entry, clc$normal_usage_entry, 16,
        clc$automatically_log, clc$linked_call, ^set_date_output],
  {} ['SET_EXPONENT_OUTPUT            ', clc$nominal_entry, clc$normal_usage_entry, 17,
        clc$automatically_log, clc$linked_call, ^set_exponent_output],
  {} ['SET_FLOAT_OUTPUT               ', clc$nominal_entry, clc$normal_usage_entry, 18,
        clc$automatically_log, clc$linked_call, ^set_float_output],
  {} ['SET_FORM                       ', clc$nominal_entry, clc$normal_usage_entry, 19,
        clc$automatically_log, clc$linked_call, ^set_form],
  {} ['SET_INTEGER_INPUT              ', clc$nominal_entry, clc$normal_usage_entry, 20,
        clc$automatically_log, clc$linked_call, ^set_integer_input],
  {} ['SET_INTEGER_OUTPUT             ', clc$nominal_entry, clc$normal_usage_entry, 21,
        clc$automatically_log, clc$linked_call, ^set_integer_output],
  {} ['SET_MONEY_INPUT                ', clc$nominal_entry, clc$normal_usage_entry, 22,
        clc$automatically_log, clc$linked_call, ^set_money_input],
  {} ['SET_MONEY_OUTPUT               ', clc$nominal_entry, clc$normal_usage_entry, 23,
        clc$automatically_log, clc$linked_call, ^set_money_output],
  {} ['SET_REAL_INPUT                 ', clc$nominal_entry, clc$normal_usage_entry, 24,
        clc$automatically_log, clc$linked_call, ^set_real_input]];

?? POP ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] fdp$begin_create_form_module', EJECT ??
*copy fdh$begin_create_form_module

  PROCEDURE [XDCL] fdp$begin_create_form_module
    (    form_name: ost$name;
     VAR form_identifier: fdt$form_identifier;
     VAR create_module: boolean;
     VAR status: ost$status);

    VAR
      errors_p: ^SEQ ( * ),
      form_attributes: array [1 .. 3] of fdt$form_attribute,
      form_errors: amt$segment_pointer,
      local_status: ost$status,
      number_errors: integer,
      utility_attributes: array [1 .. 5] of clt$utility_attribute;

    status.normal := TRUE;
    IF NOT form_ended THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_not_ended, current_form_name, status);
      RETURN;
    IFEND;

    form_ended := FALSE;
    form_attributes [1].key := fdc$form_name;
    form_attributes [1].form_name := form_name;
    form_attributes [2].key := fdc$form_processor;
    form_attributes [2].form_processor := fdc$cobol_processor;
    form_attributes [3].key := fdc$validate_variable_values;
    form_attributes [3].validate_variable_values := TRUE;
    current_form_name := form_name;
    form_processor := fdc$cobol_processor;
    fdp$create_form (form_identifier, form_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_form_identifier := form_identifier;
    utility_attributes [1].key := clc$utility_command_search_mode;
    utility_attributes [1].command_search_mode := clc$global_command_search;
    utility_attributes [2].key := clc$utility_command_table;
    utility_attributes [2].command_table := sub_commands;
    utility_attributes [3].key := clc$utility_prompt;
    utility_attributes [3].prompt.value := utility_prompt;
    utility_attributes [3].prompt.size := 3;
    utility_attributes [4].key := clc$utility_termination_command;
    utility_attributes [4].termination_command := 'end_form_module';
    utility_attributes [5].key := clc$utility_subcmnd_log_enabled;
    utility_attributes [5].subcommand_logging_enabled := TRUE;
    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      fdp$close_form (current_form_identifier, local_status);
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, utility_prompt, utility_name, status);
    form_ended := TRUE;
    IF NOT status.normal THEN
      fdp$close_form (current_form_identifier, local_status);
      RETURN;
    IFEND;

    clp$end_utility (utility_name, status);
    IF NOT status.normal THEN
      fdp$close_form (current_form_identifier, local_status);
      RETURN;
    IFEND;

    create_module := create_form;

{ Create storage to place form errors.

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, form_errors, status);
    IF NOT status.normal THEN
      fdp$close_form (current_form_identifier, local_status);
      RETURN;
    IFEND;

    RESET form_errors.sequence_pointer;

{ Check form for errors.

    fdp$end_form (current_form_identifier, form_errors.sequence_pointer, number_errors, errors_p, status);
    IF NOT status.normal THEN
      mmp$delete_scratch_segment (form_errors, local_status);
      fdp$close_form (current_form_identifier, local_status);
      RETURN;
    IFEND;

    IF number_errors = 0 THEN
      mmp$delete_scratch_segment (form_errors, local_status);
      RETURN;
    IFEND;

    display_form_errors (errors_p, status);
    mmp$delete_scratch_segment (form_errors, local_status);
    fdp$close_form (current_form_identifier, local_status);
    osp$set_status_abnormal (fdc$format_display_identifier,fde$form_compilation_errors,
          form_name, status);

  PROCEND fdp$begin_create_form_module;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] fdp$_create_form_module', EJECT ??

  PROCEDURE [XDCL] fdp$_create_form_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm) create_form_module, crefm (
{   form_name, fn: name = $required
{   binary, b: file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 18, 16, 5, 31, 656],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'FDM$CREFM'], [
    ['B                              ',clc$abbreviation_entry, 2],
    ['BINARY                         ',clc$nominal_entry, 2],
    ['FN                             ',clc$abbreviation_entry, 1],
    ['FORM_NAME                      ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$form_name = 1,
      p$binary = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      attribute_validation: array [1 .. 1] of fst$file_cycle_attribute,
      create: boolean,
      file_identifier: amt$file_identifier,
      local_status: ost$status,
      mandated_creation_attributes: array [1 .. 1] of fst$file_cycle_attribute,
      segment_pointer: amt$segment_pointer;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$begin_create_form_module (pvt [p$form_name].value^.name_value, current_form_identifier, create,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT pvt [p$binary].specified THEN
      RETURN;
    IFEND;

    attribute_validation [1].selector := fsc$file_contents_and_processor;
    attribute_validation [1].file_contents := fsc$screen_form;
    attribute_validation [1].file_processor := osc$null_name;

    mandated_creation_attributes [1].selector := fsc$file_contents_and_processor;
    mandated_creation_attributes [1].file_contents := fsc$screen_form;
    mandated_creation_attributes [1].file_processor := osc$null_name;

    fsp$open_file (pvt [p$binary].value^.file_value^, amc$segment, NIL, NIL, ^mandated_creation_attributes,
          ^attribute_validation, NIL, file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_identifier, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      fsp$close_file (file_identifier, local_status);
      RETURN;
    IFEND;

    fdp$write_form_definition (current_form_identifier, segment_pointer.sequence_pointer, status);
    IF NOT status.normal THEN
      fsp$close_file (file_identifier, local_status);
      RETURN;
    IFEND;

    amp$set_segment_eoi (file_identifier, segment_pointer, local_status);
    IF NOT status.normal THEN
      fsp$close_file (file_identifier, local_status);
      RETURN;
    IFEND;

    fsp$close_file (file_identifier, status);

  PROCEND fdp$_create_form_module;

?? OLDTITLE ??
?? NEWTITLE := 'add_box', EJECT ??

{ PURPOSE:
{   This procedure processes the add_box command.

  PROCEDURE add_box
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_addb) add_box, addb (
{   column, c: integer 1..fdc$maximum_x_position = $required
{   line, l: integer 1..fdc$maximum_y_position = $required
{   width, w: integer 1..fdc$maximum_x_position = $required
{   height, h: integer 1..fdc$maximum_y_position = $required
{   display, displays, d: list of key
{       inverse, low_intensity, high_intensity, blink, black_background, blue_background, green_background
{       magenta_background, red_background, cyan_background, yellow_background, white_background
{       black_foreground, blue_foreground, green_foreground, magenta_foreground, red_foreground
{       cyan_foreground, yellow_foreground, white_foreground, fine_line, medium_line, bold_line
{     keyend = $optional
{   name, n: any of
{       name
{       cobol_name
{     anyend = $optional
{   occurrence, o: integer 1..fdc$maximum_occurrence = 1
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 16] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 23] of clt$keyword_specification,
        recend,
      recend,
      type6: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 18, 16, 6, 21, 586],
    clc$command, 16, 8, 4, 0, 0, 0, 8, 'FDM$CREFM_ADDB'], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['COLUMN                         ',clc$nominal_entry, 1],
    ['D                              ',clc$abbreviation_entry, 5],
    ['DISPLAY                        ',clc$nominal_entry, 5],
    ['DISPLAYS                       ',clc$alias_entry, 5],
    ['H                              ',clc$abbreviation_entry, 4],
    ['HEIGHT                         ',clc$nominal_entry, 4],
    ['L                              ',clc$abbreviation_entry, 2],
    ['LINE                           ',clc$nominal_entry, 2],
    ['N                              ',clc$abbreviation_entry, 6],
    ['NAME                           ',clc$nominal_entry, 6],
    ['O                              ',clc$abbreviation_entry, 7],
    ['OCCURRENCE                     ',clc$nominal_entry, 7],
    ['STATUS                         ',clc$nominal_entry, 8],
    ['W                              ',clc$abbreviation_entry, 3],
    ['WIDTH                          ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 5
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 874,
  clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$optional_parameter,
  0, 0],
{ PARAMETER 7
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 8
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [1, fdc$maximum_x_position, 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, fdc$maximum_y_position, 10]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, fdc$maximum_x_position, 10]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [1, fdc$maximum_y_position, 10]],
{ PARAMETER 5
    [[1, 0, clc$list_type], [858, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [23], [
      ['BLACK_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['BLACK_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['BLINK                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['BLUE_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['BLUE_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['BOLD_LINE                      ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['CYAN_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['CYAN_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['FINE_LINE                      ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['GREEN_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['GREEN_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['HIGH_INTENSITY                 ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['INVERSE                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['LOW_INTENSITY                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['MAGENTA_BACKGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['MAGENTA_FOREGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['MEDIUM_LINE                    ', clc$nominal_entry, clc$normal_usage_entry, 22],
      ['RED_BACKGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['RED_FOREGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['WHITE_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['WHITE_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['YELLOW_BACKGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['YELLOW_FOREGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 19]]
      ]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 7
    [[1, 0, clc$integer_type], [1, fdc$maximum_occurrence, 10],
    '1'],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$column = 1,
      p$line = 2,
      p$width = 3,
      p$height = 4,
      p$display = 5,
      p$name = 6,
      p$occurrence = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    VAR
      object_attributes: array [1 .. 2] of fdt$object_attribute,
      object_definition: fdt$object_definition;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    object_definition.key := fdc$box;
    object_definition.box_width := pvt [p$width].value^.integer_value.value;
    object_definition.box_height := pvt [p$height].value^.integer_value.value;

    IF pvt [p$display].specified THEN
      object_attributes [1].key := fdc$object_display;
      process_attributes (pvt [p$display].value, object_attributes [1].display_attribute, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      object_attributes [1].key := fdc$unused_object_entry;
    IFEND;


    IF pvt [p$name].specified THEN
      object_attributes [2].key := fdc$object_name;
      object_attributes [2].occurrence := pvt [p$occurrence].value^.integer_value.value;
      IF pvt [p$name].value^.kind = clc$name THEN
        convert_to_form_name (pvt [p$name].value^.name_value, form_processor,
              object_attributes [2].object_name);
      ELSE
        object_attributes [2].object_name := pvt [p$name].value^.cobol_name_value;
      IFEND;

    ELSE
      object_attributes [2].key := fdc$unused_object_entry;
    IFEND;

    fdp$create_object (current_form_identifier, pvt [p$column].value^.integer_value.value, pvt [p$line].
          value^.integer_value.value, object_definition, object_attributes, status);

  PROCEND add_box;

?? OLDTITLE ??
?? NEWTITLE := 'add_constant_text', EJECT ??

{ PURPOSE:
{   This procedure processes the add_constant_text command.

  PROCEDURE add_constant_text
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_addct) add_constant_text, addct (
{   column, c: integer 1..fdc$maximum_x_position = $required
{   line, l: integer 1..fdc$maximum_y_position = $required
{   text, t: string 0..fdc$maximum_text_length = $required
{   display, displays, d: list of key
{       inverse, low_intensity, high_intensity, blink, hidden, underline, black_background, blue_background
{       green_background, magenta_background, red_background, cyan_background, yellow_background
{       white_background, black_foreground, blue_foreground, green_foreground, magenta_foreground
{       red_foreground, cyan_foreground, yellow_foreground, white_foreground, italic, title, input, error
{       message, display_left_to_right, display_right_to_left
{     keyend = $optional
{   name, n: any of
{       name
{       cobol_name
{     anyend = $optional
{   occurrence, o: integer 1..fdc$maximum_occurrence = 1
{   width, w: integer 1..fdc$maximum_y_position = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 16] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 29] of clt$keyword_specification,
        recend,
      recend,
      type5: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 18, 16, 6, 53, 776],
    clc$command, 16, 8, 3, 0, 0, 0, 8, 'FDM$CREFM_ADDCT'], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['COLUMN                         ',clc$nominal_entry, 1],
    ['D                              ',clc$abbreviation_entry, 4],
    ['DISPLAY                        ',clc$nominal_entry, 4],
    ['DISPLAYS                       ',clc$alias_entry, 4],
    ['L                              ',clc$abbreviation_entry, 2],
    ['LINE                           ',clc$nominal_entry, 2],
    ['N                              ',clc$abbreviation_entry, 5],
    ['NAME                           ',clc$nominal_entry, 5],
    ['O                              ',clc$abbreviation_entry, 6],
    ['OCCURRENCE                     ',clc$nominal_entry, 6],
    ['STATUS                         ',clc$nominal_entry, 8],
    ['T                              ',clc$abbreviation_entry, 3],
    ['TEXT                           ',clc$nominal_entry, 3],
    ['W                              ',clc$abbreviation_entry, 7],
    ['WIDTH                          ',clc$nominal_entry, 7]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1096,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 7
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 8
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [1, fdc$maximum_x_position, 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, fdc$maximum_y_position, 10]],
{ PARAMETER 3
    [[1, 0, clc$string_type], [0, fdc$maximum_text_length, FALSE]],
{ PARAMETER 4
    [[1, 0, clc$list_type], [1080, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [29], [
      ['BLACK_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['BLACK_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['BLINK                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['BLUE_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['BLUE_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['CYAN_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['CYAN_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['DISPLAY_LEFT_TO_RIGHT          ', clc$nominal_entry, clc$normal_usage_entry, 28],
      ['DISPLAY_RIGHT_TO_LEFT          ', clc$nominal_entry, clc$normal_usage_entry, 29],
      ['ERROR                          ', clc$nominal_entry, clc$normal_usage_entry, 26],
      ['GREEN_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['GREEN_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['HIDDEN                         ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['HIGH_INTENSITY                 ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['INPUT                          ', clc$nominal_entry, clc$normal_usage_entry, 25],
      ['INVERSE                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['ITALIC                         ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['LOW_INTENSITY                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['MAGENTA_BACKGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['MAGENTA_FOREGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['MESSAGE                        ', clc$nominal_entry, clc$normal_usage_entry, 27],
      ['RED_BACKGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['RED_FOREGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 19],
      ['TITLE                          ', clc$nominal_entry, clc$normal_usage_entry, 24],
      ['UNDERLINE                      ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['WHITE_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['WHITE_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 22],
      ['YELLOW_BACKGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['YELLOW_FOREGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 21]]
      ]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 6
    [[1, 0, clc$integer_type], [1, fdc$maximum_occurrence, 10],
    '1'],
{ PARAMETER 7
    [[1, 0, clc$integer_type], [1, fdc$maximum_y_position, 10]],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$column = 1,
      p$line = 2,
      p$text = 3,
      p$display = 4,
      p$name = 5,
      p$occurrence = 6,
      p$width = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    VAR
      object_attributes: array [1 .. 2] of fdt$object_attribute,
      object_definition: fdt$object_definition;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    object_definition.key := fdc$constant_text;
    object_definition.p_constant_text := pvt [p$text].value^.string_value;
    IF pvt [p$width].specified THEN
      object_definition.constant_text_width := pvt [p$width].value^.integer_value.value;
    ELSE
      IF STRLENGTH (pvt [p$text].value^.string_value^) <> 0 THEN
        object_definition.constant_text_width := STRLENGTH (pvt [p$text].value^.string_value^);
      ELSE
        osp$set_status_abnormal (fdc$format_display_identifier, fde$object_width_required, current_form_name,
              status);
        IF pvt [p$name].specified THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, pvt [p$name].
                value^.name_value, status);
        IFEND;
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$display].specified THEN
      object_attributes [1].key := fdc$object_display;
      process_attributes (pvt [p$display].value, object_attributes [1].display_attribute, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      object_attributes [1].key := fdc$unused_object_entry;
    IFEND;

    IF pvt [p$name].specified THEN
      object_attributes [2].key := fdc$object_name;
      object_attributes [2].occurrence := pvt [p$occurrence].value^.integer_value.value;
      IF pvt [p$name].value^.kind = clc$name THEN
        convert_to_form_name (pvt [p$name].value^.name_value, form_processor,
              object_attributes [2].object_name);
      ELSE
        object_attributes [2].object_name := pvt [p$name].value^.cobol_name_value;
      IFEND;

    ELSE
      object_attributes [2].key := fdc$unused_object_entry;
    IFEND;

    fdp$create_object (current_form_identifier, pvt [p$column].value^.integer_value.value, pvt [p$line].
          value^.integer_value.value, object_definition, object_attributes, status);

  PROCEND add_constant_text;

?? OLDTITLE ??
?? NEWTITLE := 'add_constant_text_box', EJECT ??

{ PURPOSE:
{   This procedure processes the add_constant_text_box  command.

  PROCEDURE add_constant_text_box
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_addctb) add_constant_text_box, addctb (
{   column, c: integer 1..fdc$maximum_x_position = $required
{   line, l: integer 1..fdc$maximum_y_position = $required
{   text, t: string 0..fdc$maximum_text_length = $required
{   width, w: integer 1..fdc$maximum_x_position = $required
{   height, h: integer 1..fdc$maximum_y_position = $required
{   display, displays, d: list of key
{       inverse, low_intensity, high_intensity, blink, hidden, underline, black_background, blue_background
{       green_background, magenta_background, red_background, cyan_background, yellow_background
{       white_background, black_foreground, blue_foreground, green_foreground, magenta_foreground
{       red_foreground, cyan_foreground, yellow_foreground, white_foreground, italic, title, input, error
{       message, display_left_to_right, display_right_to_left
{     keyend = $optional
{   name, n: any of
{       name
{       cobol_name
{     anyend = $optional
{   occurrence, o: integer 1..fdc$maximum_occurrence = 1
{   text_format, tf: key
{       wrap_words, wrap_characters
{     keyend = wrap_words
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 20] of clt$pdt_parameter_name,
      parameters: array [1 .. 10] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 29] of clt$keyword_specification,
        recend,
      recend,
      type7: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (10),
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 18, 16, 7, 15, 502],
    clc$command, 20, 10, 5, 0, 0, 0, 10, 'FDM$CREFM_ADDCTB'], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['COLUMN                         ',clc$nominal_entry, 1],
    ['D                              ',clc$abbreviation_entry, 6],
    ['DISPLAY                        ',clc$nominal_entry, 6],
    ['DISPLAYS                       ',clc$alias_entry, 6],
    ['H                              ',clc$abbreviation_entry, 5],
    ['HEIGHT                         ',clc$nominal_entry, 5],
    ['L                              ',clc$abbreviation_entry, 2],
    ['LINE                           ',clc$nominal_entry, 2],
    ['N                              ',clc$abbreviation_entry, 7],
    ['NAME                           ',clc$nominal_entry, 7],
    ['O                              ',clc$abbreviation_entry, 8],
    ['OCCURRENCE                     ',clc$nominal_entry, 8],
    ['STATUS                         ',clc$nominal_entry, 10],
    ['T                              ',clc$abbreviation_entry, 3],
    ['TEXT                           ',clc$nominal_entry, 3],
    ['TEXT_FORMAT                    ',clc$nominal_entry, 9],
    ['TF                             ',clc$abbreviation_entry, 9],
    ['W                              ',clc$abbreviation_entry, 4],
    ['WIDTH                          ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 4
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 6
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1096,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$optional_parameter,
  0, 0],
{ PARAMETER 8
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 9
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81,
  clc$optional_default_parameter, 0, 10],
{ PARAMETER 10
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [1, fdc$maximum_x_position, 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, fdc$maximum_y_position, 10]],
{ PARAMETER 3
    [[1, 0, clc$string_type], [0, fdc$maximum_text_length, FALSE]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [1, fdc$maximum_x_position, 10]],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [1, fdc$maximum_y_position, 10]],
{ PARAMETER 6
    [[1, 0, clc$list_type], [1080, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [29], [
      ['BLACK_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['BLACK_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['BLINK                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['BLUE_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['BLUE_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['CYAN_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['CYAN_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['DISPLAY_LEFT_TO_RIGHT          ', clc$nominal_entry, clc$normal_usage_entry, 28],
      ['DISPLAY_RIGHT_TO_LEFT          ', clc$nominal_entry, clc$normal_usage_entry, 29],
      ['ERROR                          ', clc$nominal_entry, clc$normal_usage_entry, 26],
      ['GREEN_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['GREEN_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['HIDDEN                         ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['HIGH_INTENSITY                 ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['INPUT                          ', clc$nominal_entry, clc$normal_usage_entry, 25],
      ['INVERSE                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['ITALIC                         ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['LOW_INTENSITY                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['MAGENTA_BACKGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['MAGENTA_FOREGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['MESSAGE                        ', clc$nominal_entry, clc$normal_usage_entry, 27],
      ['RED_BACKGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['RED_FOREGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 19],
      ['TITLE                          ', clc$nominal_entry, clc$normal_usage_entry, 24],
      ['UNDERLINE                      ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['WHITE_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['WHITE_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 22],
      ['YELLOW_BACKGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['YELLOW_FOREGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 21]]
      ]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 8
    [[1, 0, clc$integer_type], [1, fdc$maximum_occurrence, 10],
    '1'],
{ PARAMETER 9
    [[1, 0, clc$keyword_type], [2], [
    ['WRAP_CHARACTERS                ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['WRAP_WORDS                     ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'wrap_words'],
{ PARAMETER 10
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$column = 1,
      p$line = 2,
      p$text = 3,
      p$width = 4,
      p$height = 5,
      p$display = 6,
      p$name = 7,
      p$occurrence = 8,
      p$text_format = 9,
      p$status = 10;

    VAR
      pvt: array [1 .. 10] of clt$parameter_value;

    VAR
      object_attributes: array [1 .. 2] of fdt$object_attribute,
      object_definition: fdt$object_definition;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    object_definition.key := fdc$constant_text_box;
    object_definition.p_constant_box_text := pvt [p$text].value^.string_value;
    object_definition.constant_box_width := pvt [p$width].value^.integer_value.value;
    object_definition.constant_box_height := pvt [p$height].value^.integer_value.value;
    IF (pvt [p$text_format].value^.keyword_value = 'WRAP_WORDS') THEN
      object_definition.constant_box_processing := fdc$wrap_words;
    ELSE
      object_definition.constant_box_processing := fdc$wrap_characters;
    IFEND;

    IF pvt [p$display].specified THEN
      object_attributes [1].key := fdc$object_display;
      process_attributes (pvt [p$display].value, object_attributes [1].display_attribute, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      object_attributes [1].key := fdc$unused_object_entry;
    IFEND;

    IF pvt [p$name].specified THEN
      object_attributes [2].key := fdc$object_name;
      object_attributes [2].occurrence := pvt [p$occurrence].value^.integer_value.value;
      IF pvt [p$name].value^.kind = clc$name THEN
        convert_to_form_name (pvt [p$name].value^.name_value, form_processor,
              object_attributes [2].object_name);
      ELSE
        object_attributes [2].object_name := pvt [p$name].value^.cobol_name_value;
      IFEND;

    ELSE
      object_attributes [2].key := fdc$unused_object_entry;
    IFEND;

    fdp$create_object (current_form_identifier, pvt [p$column].value^.integer_value.value, pvt [p$line].
          value^.integer_value.value, object_definition, object_attributes, status);

  PROCEND add_constant_text_box;

?? OLDTITLE ??
?? NEWTITLE := 'add_display', EJECT ??

{ PURPOSE:
{   This procedure processes the add_display_attribute command.

  PROCEDURE add_display
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_addd) add_display, addd (
{   name, n: any of
{       name
{       cobol_name
{     anyend = $required
{   display, displays, d: list of key
{       inverse, low_intensity, high_intensity, blink, underline, protect, hidden, black_background
{       blue_background, green_background, magenta_background, red_background, cyan_background
{       yellow_background, white_background, black_foreground, blue_foreground, green_foreground
{       magenta_foreground, red_foreground, cyan_foreground, yellow_foreground, white_foreground, fine_line
{       medium_line, bold_line, italic, title, input, error, message, display_left_to_right
{       display_right_to_left
{     keyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 33] of clt$keyword_specification,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 18, 16, 7, 35, 314],
    clc$command, 6, 3, 2, 0, 0, 0, 3, 'FDM$CREFM_ADDDA'], [
    ['D                              ',clc$abbreviation_entry, 2],
    ['DISPLAY                        ',clc$nominal_entry, 2],
    ['DISPLAYS                       ',clc$alias_entry, 2],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1244,
  clc$required_parameter, 0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [1228, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [33], [
      ['BLACK_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['BLACK_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['BLINK                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['BLUE_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['BLUE_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['BOLD_LINE                      ', clc$nominal_entry, clc$normal_usage_entry, 26],
      ['CYAN_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['CYAN_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['DISPLAY_LEFT_TO_RIGHT          ', clc$nominal_entry, clc$normal_usage_entry, 32],
      ['DISPLAY_RIGHT_TO_LEFT          ', clc$nominal_entry, clc$normal_usage_entry, 33],
      ['ERROR                          ', clc$nominal_entry, clc$normal_usage_entry, 30],
      ['FINE_LINE                      ', clc$nominal_entry, clc$normal_usage_entry, 24],
      ['GREEN_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['GREEN_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['HIDDEN                         ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['HIGH_INTENSITY                 ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['INPUT                          ', clc$nominal_entry, clc$normal_usage_entry, 29],
      ['INVERSE                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['ITALIC                         ', clc$nominal_entry, clc$normal_usage_entry, 27],
      ['LOW_INTENSITY                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['MAGENTA_BACKGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['MAGENTA_FOREGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 19],
      ['MEDIUM_LINE                    ', clc$nominal_entry, clc$normal_usage_entry, 25],
      ['MESSAGE                        ', clc$nominal_entry, clc$normal_usage_entry, 31],
      ['PROTECT                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['RED_BACKGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['RED_FOREGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['TITLE                          ', clc$nominal_entry, clc$normal_usage_entry, 28],
      ['UNDERLINE                      ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['WHITE_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['WHITE_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['YELLOW_BACKGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['YELLOW_FOREGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 22]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$display = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      form_attributes: array [1 .. 1] of fdt$form_attribute;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    form_attributes [1].key := fdc$add_display_definition;
    process_attributes (pvt [p$display].value, form_attributes [1].display_attribute, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$name].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$name].value^.name_value, form_processor, form_attributes [1].display_name);
    ELSE
      form_attributes [1].display_name := pvt [p$name].value^.cobol_name_value;
    IFEND;

    fdp$change_form (current_form_identifier, form_attributes, status);

  PROCEND add_display;

?? OLDTITLE ??
?? NEWTITLE := 'add_event', EJECT ??

{ PURPOSE:
{   This procedure processes the add_event command.

  PROCEDURE add_event
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_adde) add_event, adde (
{   program_event, pe: any of
{       name
{       cobol_name
{     anyend = $required
{   terminal_event, te: key
{       next, help, stop, back, up, down, forward, backward, undo, redo, quit, exit, first, last, edit, data
{       f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11, f12, f13, f14, f15, f16, shift_next, shift_help
{       shift_stop, shift_back, shift_up, shift_down, shift_forward, shift_backward, shift_edit, shift_data
{       shift_f1, shift_f2, shift_f3, shift_f4, shift_f5, shift_f6, shift_f7, shift_f8, shift_f9, shift_f10
{       shift_f11, shift_f12, shift_f13, shift_f14, shift_f15, shift_f16, pick, insert_line, delete_line, home
{     keyend = $required
{   action, a: key
{       return_normal, return_abnormal, page_table_forward, page_table_backward, scroll_table_forward
{       scroll_table_backward, display_help, erase_help, ignore, tab_next, tab_previous
{       scroll_variable_forward, scroll_variable_backward, page_variable_forward, page_variable_backward
{       page_variable_first, page_variable_last, page_table_first, page_table_last, insert_variable_line
{       delete_variable_line
{     keyend = $required
{   label, l: string 0..6 = ''
{   reassign_terminal_event, rte: (BY_NAME) boolean = TRUE
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 62] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 21] of clt$keyword_specification,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (2),
      recend,
      type5: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 9, 10, 13, 42, 18, 727],
    clc$command, 11, 6, 3, 0, 0, 0, 6, 'FDM$CREFM_ADDE'], [
    ['A                              ',clc$abbreviation_entry, 3],
    ['ACTION                         ',clc$nominal_entry, 3],
    ['L                              ',clc$abbreviation_entry, 4],
    ['LABEL                          ',clc$nominal_entry, 4],
    ['PE                             ',clc$abbreviation_entry, 1],
    ['PROGRAM_EVENT                  ',clc$nominal_entry, 1],
    ['REASSIGN_TERMINAL_EVENT        ',clc$nominal_entry, 5],
    ['RTE                            ',clc$abbreviation_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 6],
    ['TE                             ',clc$abbreviation_entry, 2],
    ['TERMINAL_EVENT                 ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 2301,
  clc$required_parameter, 0, 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 784,
  clc$required_parameter, 0, 0],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 6
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [62], [
    ['BACK                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['BACKWARD                       ', clc$nominal_entry, clc$normal_usage_entry, 8],
    ['DATA                           ', clc$nominal_entry, clc$normal_usage_entry, 16],
    ['DELETE_LINE                    ', clc$nominal_entry, clc$normal_usage_entry, 61],
    ['DOWN                           ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['EDIT                           ', clc$nominal_entry, clc$normal_usage_entry, 15],
    ['EXIT                           ', clc$nominal_entry, clc$normal_usage_entry, 12],
    ['F1                             ', clc$nominal_entry, clc$normal_usage_entry, 17],
    ['F10                            ', clc$nominal_entry, clc$normal_usage_entry, 26],
    ['F11                            ', clc$nominal_entry, clc$normal_usage_entry, 27],
    ['F12                            ', clc$nominal_entry, clc$normal_usage_entry, 28],
    ['F13                            ', clc$nominal_entry, clc$normal_usage_entry, 29],
    ['F14                            ', clc$nominal_entry, clc$normal_usage_entry, 30],
    ['F15                            ', clc$nominal_entry, clc$normal_usage_entry, 31],
    ['F16                            ', clc$nominal_entry, clc$normal_usage_entry, 32],
    ['F2                             ', clc$nominal_entry, clc$normal_usage_entry, 18],
    ['F3                             ', clc$nominal_entry, clc$normal_usage_entry, 19],
    ['F4                             ', clc$nominal_entry, clc$normal_usage_entry, 20],
    ['F5                             ', clc$nominal_entry, clc$normal_usage_entry, 21],
    ['F6                             ', clc$nominal_entry, clc$normal_usage_entry, 22],
    ['F7                             ', clc$nominal_entry, clc$normal_usage_entry, 23],
    ['F8                             ', clc$nominal_entry, clc$normal_usage_entry, 24],
    ['F9                             ', clc$nominal_entry, clc$normal_usage_entry, 25],
    ['FIRST                          ', clc$nominal_entry, clc$normal_usage_entry, 13],
    ['FORWARD                        ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['HELP                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['HOME                           ', clc$nominal_entry, clc$normal_usage_entry, 62],
    ['INSERT_LINE                    ', clc$nominal_entry, clc$normal_usage_entry, 60],
    ['LAST                           ', clc$nominal_entry, clc$normal_usage_entry, 14],
    ['NEXT                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['PICK                           ', clc$nominal_entry, clc$normal_usage_entry, 59],
    ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 11],
    ['REDO                           ', clc$nominal_entry, clc$normal_usage_entry, 10],
    ['SHIFT_BACK                     ', clc$nominal_entry, clc$normal_usage_entry, 36],
    ['SHIFT_BACKWARD                 ', clc$nominal_entry, clc$normal_usage_entry, 40],
    ['SHIFT_DATA                     ', clc$nominal_entry, clc$normal_usage_entry, 42],
    ['SHIFT_DOWN                     ', clc$nominal_entry, clc$normal_usage_entry, 38],
    ['SHIFT_EDIT                     ', clc$nominal_entry, clc$normal_usage_entry, 41],
    ['SHIFT_F1                       ', clc$nominal_entry, clc$normal_usage_entry, 43],
    ['SHIFT_F10                      ', clc$nominal_entry, clc$normal_usage_entry, 52],
    ['SHIFT_F11                      ', clc$nominal_entry, clc$normal_usage_entry, 53],
    ['SHIFT_F12                      ', clc$nominal_entry, clc$normal_usage_entry, 54],
    ['SHIFT_F13                      ', clc$nominal_entry, clc$normal_usage_entry, 55],
    ['SHIFT_F14                      ', clc$nominal_entry, clc$normal_usage_entry, 56],
    ['SHIFT_F15                      ', clc$nominal_entry, clc$normal_usage_entry, 57],
    ['SHIFT_F16                      ', clc$nominal_entry, clc$normal_usage_entry, 58],
    ['SHIFT_F2                       ', clc$nominal_entry, clc$normal_usage_entry, 44],
    ['SHIFT_F3                       ', clc$nominal_entry, clc$normal_usage_entry, 45],
    ['SHIFT_F4                       ', clc$nominal_entry, clc$normal_usage_entry, 46],
    ['SHIFT_F5                       ', clc$nominal_entry, clc$normal_usage_entry, 47],
    ['SHIFT_F6                       ', clc$nominal_entry, clc$normal_usage_entry, 48],
    ['SHIFT_F7                       ', clc$nominal_entry, clc$normal_usage_entry, 49],
    ['SHIFT_F8                       ', clc$nominal_entry, clc$normal_usage_entry, 50],
    ['SHIFT_F9                       ', clc$nominal_entry, clc$normal_usage_entry, 51],
    ['SHIFT_FORWARD                  ', clc$nominal_entry, clc$normal_usage_entry, 39],
    ['SHIFT_HELP                     ', clc$nominal_entry, clc$normal_usage_entry, 34],
    ['SHIFT_NEXT                     ', clc$nominal_entry, clc$normal_usage_entry, 33],
    ['SHIFT_STOP                     ', clc$nominal_entry, clc$normal_usage_entry, 35],
    ['SHIFT_UP                       ', clc$nominal_entry, clc$normal_usage_entry, 37],
    ['STOP                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['UNDO                           ', clc$nominal_entry, clc$normal_usage_entry, 9],
    ['UP                             ', clc$nominal_entry, clc$normal_usage_entry, 5]]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [21], [
    ['DELETE_VARIABLE_LINE           ', clc$nominal_entry, clc$normal_usage_entry, 21],
    ['DISPLAY_HELP                   ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['ERASE_HELP                     ', clc$nominal_entry, clc$normal_usage_entry, 8],
    ['IGNORE                         ', clc$nominal_entry, clc$normal_usage_entry, 9],
    ['INSERT_VARIABLE_LINE           ', clc$nominal_entry, clc$normal_usage_entry, 20],
    ['PAGE_TABLE_BACKWARD            ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['PAGE_TABLE_FIRST               ', clc$nominal_entry, clc$normal_usage_entry, 18],
    ['PAGE_TABLE_FORWARD             ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['PAGE_TABLE_LAST                ', clc$nominal_entry, clc$normal_usage_entry, 19],
    ['PAGE_VARIABLE_BACKWARD         ', clc$nominal_entry, clc$normal_usage_entry, 15],
    ['PAGE_VARIABLE_FIRST            ', clc$nominal_entry, clc$normal_usage_entry, 16],
    ['PAGE_VARIABLE_FORWARD          ', clc$nominal_entry, clc$normal_usage_entry, 14],
    ['PAGE_VARIABLE_LAST             ', clc$nominal_entry, clc$normal_usage_entry, 17],
    ['RETURN_ABNORMAL                ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['RETURN_NORMAL                  ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['SCROLL_TABLE_BACKWARD          ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['SCROLL_TABLE_FORWARD           ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['SCROLL_VARIABLE_BACKWARD       ', clc$nominal_entry, clc$normal_usage_entry, 13],
    ['SCROLL_VARIABLE_FORWARD        ', clc$nominal_entry, clc$normal_usage_entry, 12],
    ['TAB_NEXT                       ', clc$nominal_entry, clc$normal_usage_entry, 10],
    ['TAB_PREVIOUS                   ', clc$nominal_entry, clc$normal_usage_entry, 11]]
    ],
{ PARAMETER 4
    [[1, 0, clc$string_type], [0, 6, FALSE],
    ''''''],
{ PARAMETER 5
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$program_event = 1,
      p$terminal_event = 2,
      p$action = 3,
      p$label = 4,
      p$reassign_terminal_event = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    TYPE
      event_translation = record
        event_name: ost$name,
        event_trigger: fdt$event_trigger,
      recend;

    TYPE
      action_translation = record
        action_name: ost$name,
        event_action: fdt$event_action,
      recend;

    CONST
      action_maximum = 21,
      trigger_maximum = 65;

    VAR
      action: 1 .. action_maximum,
      convert_action: [READ] array [1 .. action_maximum] of action_translation :=
            [['RETURN_NORMAL', fdc$return_program_normal],
             ['RETURN_ABNORMAL', fdc$return_program_abnormal],
             ['PAGE_TABLE_FORWARD', fdc$page_table_forward],
             ['PAGE_TABLE_BACKWARD', fdc$page_table_backward],
             ['SCROLL_TABLE_FORWARD', fdc$scroll_table_forward],
             ['SCROLL_TABLE_BACKWARD', fdc$scroll_table_backward],
             ['DISPLAY_HELP', fdc$display_help],
             ['IGNORE', fdc$ignore_event],
             ['ERASE_HELP', fdc$erase_help],
             ['TAB_NEXT', fdc$tab_to_next_form_field],
             ['TAB_PREVIOUS', fdc$tab_to_previous_form_field],
             ['SCROLL_VARIABLE_FORWARD', fdc$scroll_variable_forward],
             ['SCROLL_VARIABLE_BACKWARD', fdc$scroll_variable_backward],
             ['PAGE_VARIABLE_FORWARD', fdc$page_variable_forward],
             ['PAGE_VARIABLE_BACKWARD', fdc$page_variable_backward],
             ['PAGE_VARIABLE_FIRST', fdc$page_variable_first],
             ['PAGE_VARIABLE_LAST', fdc$page_variable_last],
             ['PAGE_TABLE_FIRST', fdc$page_table_first],
             ['PAGE_TABLE_LAST', fdc$page_table_last],
             ['INSERT_VARIABLE_LINE', fdc$insert_variable_line],
             ['DELETE_VARIABLE_LINE', fdc$delete_variable_line]],

      convert_terminal_event: [READ] array [1 .. trigger_maximum] of event_translation :=
            [['NEXT', fdc$next], ['HELP', fdc$help], ['STOP', fdc$stop], ['BACK', fdc$back], ['UP', fdc$up],
            ['DOWN', fdc$down], ['FORWARD', fdc$forward], ['BACKWARD', fdc$backward], ['UNDO', fdc$undo],
            ['REDO', fdc$redo], ['QUIT', fdc$quit], ['EXIT', fdc$exit], ['FIRST', fdc$first],
            ['LAST', fdc$last], ['EDIT', fdc$edit], ['DATA', fdc$data], ['F1', fdc$function_1],
            ['F2', fdc$function_2], ['F3', fdc$function_3], ['F4', fdc$function_4], ['F5', fdc$function_5],
            ['F6', fdc$function_6], ['F7', fdc$function_7], ['F8', fdc$function_8], ['F9', fdc$function_9],
            ['F10', fdc$function_10], ['F11', fdc$function_11], ['F12', fdc$function_12],
            ['F13', fdc$function_13], ['F14', fdc$function_14], ['F15', fdc$function_15],
            ['F16', fdc$function_16], ['SHIFT_NEXT', fdc$shift_next], ['SHIFT_HELP', fdc$shift_help],
            ['SHIFT_STOP', fdc$shift_stop], ['SHIFT_BACK', fdc$shift_back], ['SHIFT_UP', fdc$shift_up],
            ['SHIFT_DOWN', fdc$shift_down], ['SHIFT_FORWARD', fdc$shift_forward],
            ['SHIFT_BACKWARD', fdc$shift_backward], ['SHIFT_EDIT', fdc$shift_edit],
            ['SHIFT_DATA', fdc$shift_data], ['SHIFT_F1', fdc$shift_function_1],
            ['SHIFT_F2', fdc$shift_function_2], ['SHIFT_F3', fdc$shift_function_3],
            ['SHIFT_F4', fdc$shift_function_4], ['SHIFT_F5', fdc$shift_function_5],
            ['SHIFT_F6', fdc$shift_function_6], ['SHIFT_F7', fdc$shift_function_7],
            ['SHIFT_F8', fdc$shift_function_8], ['SHIFT_F9', fdc$shift_function_9],
            ['SHIFT_F10', fdc$shift_function_10], ['SHIFT_F11', fdc$shift_function_11],
            ['SHIFT_F12', fdc$shift_function_12], ['SHIFT_F13', fdc$shift_function_13],
            ['SHIFT_F14', fdc$shift_function_14], ['SHIFT_F15', fdc$shift_function_15],
            ['SHIFT_F16', fdc$shift_function_16], ['PICK', fdc$pick], ['INSERT_LINE', fdc$insert_line],
            ['DELETE_LINE', fdc$delete_line], ['HOME', fdc$home_cursor], ['CLEAR_SCREEN', fdc$clear_screen],
            ['TIME_OUT', fdc$time_out], ['VARIABLE_TRIGGER', fdc$variable_trigger]],
      form_attributes: array [1 .. 1] of fdt$form_attribute,
      trigger: 1 .. trigger_maximum;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    form_attributes [1].key := fdc$add_event_v1;
    IF pvt [p$program_event].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$program_event].value^.name_value, form_processor,
            form_attributes [1].event_name_v1);
    ELSE
      form_attributes [1].event_name_v1 := pvt [p$program_event].value^.cobol_name_value;
    IFEND;

    form_attributes [1].event_label_v1 := pvt [p$label].value^.string_value^;

  /find_event_trigger/
    FOR trigger := LOWERBOUND (convert_terminal_event) TO UPPERBOUND (convert_terminal_event) DO
      IF (convert_terminal_event [trigger].event_name = pvt [p$terminal_event].value^.keyword_value) THEN
        form_attributes [1].event_trigger_v1 := convert_terminal_event [trigger].event_trigger;
        EXIT /find_event_trigger/;
      IFEND;
    FOREND /find_event_trigger/;

  /find_event_action/
    FOR action := LOWERBOUND (convert_action) TO UPPERBOUND (convert_action) DO
      IF (convert_action [action].action_name = pvt [p$action].value^.keyword_value) THEN
        form_attributes [1].event_action_v1 := convert_action [action].event_action;
        EXIT /find_event_action/;
      IFEND;
    FOREND /find_event_action/;

    form_attributes [1].event_trigger_reassignment_v1 := pvt [p$reassign_terminal_event].
          value^.boolean_value.value;
    fdp$change_form (current_form_identifier, form_attributes, status);

  PROCEND add_event;

?? OLDTITLE ??
?? NEWTITLE := '   add_line', EJECT ??

{ PURPOSE:
{   This procedure processes the add_line command.

  PROCEDURE add_line
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_addl) add_line, addl (
{   start_column, sc: integer 1..fdc$maximum_x_position = $required
{   start_line, sl: integer 1..fdc$maximum_y_position = $required
{   end_column, ec: integer 1..fdc$maximum_x_position = $required
{   end_line, el: integer 1..fdc$maximum_y_position = $required
{   display, displays, d: list of key
{       inverse, low_intensity, high_intensity, blink, black_background, blue_background, green_background
{       magenta_background, red_background, cyan_background, yellow_background, white_background
{       black_foreground, blue_foreground, green_foreground, magenta_foreground, red_foreground
{       cyan_foreground, yellow_foreground, white_foreground, fine_line, medium_line, bold_line
{     keyend = $optional
{   name, n: any of
{       name
{       cobol_name
{     anyend = $optional
{   occurrence, o: integer 1..fdc$maximum_occurrence = 1
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 16] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 23] of clt$keyword_specification,
        recend,
      recend,
      type6: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 18, 13, 24, 22, 342],
    clc$command, 16, 8, 4, 0, 0, 0, 8, 'FDM$CREFM_ADDL'], [
    ['D                              ',clc$abbreviation_entry, 5],
    ['DISPLAY                        ',clc$nominal_entry, 5],
    ['DISPLAYS                       ',clc$alias_entry, 5],
    ['EC                             ',clc$abbreviation_entry, 3],
    ['EL                             ',clc$abbreviation_entry, 4],
    ['END_COLUMN                     ',clc$nominal_entry, 3],
    ['END_LINE                       ',clc$nominal_entry, 4],
    ['N                              ',clc$abbreviation_entry, 6],
    ['NAME                           ',clc$nominal_entry, 6],
    ['O                              ',clc$abbreviation_entry, 7],
    ['OCCURRENCE                     ',clc$nominal_entry, 7],
    ['SC                             ',clc$abbreviation_entry, 1],
    ['SL                             ',clc$abbreviation_entry, 2],
    ['START_COLUMN                   ',clc$nominal_entry, 1],
    ['START_LINE                     ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 8]],
    [
{ PARAMETER 1
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 5
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 874,
  clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$optional_parameter,
  0, 0],
{ PARAMETER 7
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 8
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [1, fdc$maximum_x_position, 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, fdc$maximum_y_position, 10]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, fdc$maximum_x_position, 10]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [1, fdc$maximum_y_position, 10]],
{ PARAMETER 5
    [[1, 0, clc$list_type], [858, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [23], [
      ['BLACK_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['BLACK_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['BLINK                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['BLUE_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['BLUE_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['BOLD_LINE                      ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['CYAN_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['CYAN_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['FINE_LINE                      ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['GREEN_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['GREEN_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['HIGH_INTENSITY                 ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['INVERSE                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['LOW_INTENSITY                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['MAGENTA_BACKGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['MAGENTA_FOREGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['MEDIUM_LINE                    ', clc$nominal_entry, clc$normal_usage_entry, 22],
      ['RED_BACKGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['RED_FOREGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['WHITE_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['WHITE_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['YELLOW_BACKGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['YELLOW_FOREGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 19]]
      ]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 7
    [[1, 0, clc$integer_type], [1, fdc$maximum_occurrence, 10],
    '1'],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$start_column = 1,
      p$start_line = 2,
      p$end_column = 3,
      p$end_line = 4,
      p$display = 5,
      p$name = 6,
      p$occurrence = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    VAR
      object_attributes: array [1 .. 2] of fdt$object_attribute,
      object_definition: fdt$object_definition;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    object_definition.key := fdc$line;
    IF (pvt [p$end_column].value^.integer_value.value > pvt [p$start_column].value^.integer_value.value) THEN
      object_definition.x_increment := pvt [p$end_column].value^.integer_value.value -
            pvt [p$start_column].value^.integer_value.value;
    ELSE
      object_definition.x_increment := pvt [p$start_column].value^.integer_value.value -
            pvt [p$end_column].value^.integer_value.value;
    IFEND;

    IF (pvt [p$end_line].value^.integer_value.value > pvt [p$start_line].value^.integer_value.value) THEN
      object_definition.y_increment := pvt [p$end_line].value^.integer_value.value - pvt [p$start_line].
            value^.integer_value.value;
    ELSE
      object_definition.y_increment := pvt [p$start_line].value^.integer_value.value - pvt [p$end_line].
            value^.integer_value.value;
    IFEND;

    IF pvt [p$display].specified THEN
      object_attributes [1].key := fdc$object_display;
      process_attributes (pvt [p$display].value, object_attributes [1].display_attribute, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      object_attributes [1].key := fdc$unused_object_entry;
    IFEND;

    IF pvt [p$name].specified THEN
      object_attributes [2].key := fdc$object_name;
      object_attributes [2].occurrence := pvt [p$occurrence].value^.integer_value.value;
      IF pvt [p$name].value^.kind = clc$name THEN
        convert_to_form_name (pvt [p$name].value^.name_value, form_processor,
              object_attributes [2].object_name);
      ELSE
        object_attributes [2].object_name := pvt [p$name].value^.cobol_name_value;
      IFEND;

    ELSE
      object_attributes [2].key := fdc$unused_object_entry;
    IFEND;

    fdp$create_object (current_form_identifier, pvt [p$start_column].
          value^.integer_value.value, pvt [p$start_line].value^.integer_value.value, object_definition,
          object_attributes, status);

  PROCEND add_line;

?? OLDTITLE ??
?? NEWTITLE := 'add_stored_text', EJECT ??

{ PURPOSE:
{   This procedure processes the add_stored_text command.

  PROCEDURE add_stored_text
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_addst) add_stored_text, addst (
{   variable_name, vn: any of
{       name
{       cobol_name
{     anyend = $required
{   occurrence, o: integer 1..fdc$maximum_occurrence = $required
{   text, t: string 0..fdc$maximum_text_length = ''
{   display, displays, d: list of key
{       inverse, low_intensity, high_intensity, blink, underline, protect, hidden, black_background
{       blue_background, green_background, magenta_background, red_background, cyan_background
{       yellow_background, white_background, black_foreground, blue_foreground, green_foreground
{       magenta_foreground, red_foreground, cyan_foreground, yellow_foreground, white_foreground, italic
{       title, input, error, message, display_left_to_right, display_right_to_left
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (2),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 30] of clt$keyword_specification,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 18, 16, 8, 25, 589],
    clc$command, 10, 5, 2, 0, 0, 0, 5, 'FDM$CREFM_ADDST'], [
    ['D                              ',clc$abbreviation_entry, 4],
    ['DISPLAY                        ',clc$nominal_entry, 4],
    ['DISPLAYS                       ',clc$alias_entry, 4],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OCCURRENCE                     ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['T                              ',clc$abbreviation_entry, 3],
    ['TEXT                           ',clc$nominal_entry, 3],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 1],
    ['VN                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 4
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1133,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, fdc$maximum_occurrence, 10]],
{ PARAMETER 3
    [[1, 0, clc$string_type], [0, fdc$maximum_text_length, FALSE],
    ''''''],
{ PARAMETER 4
    [[1, 0, clc$list_type], [1117, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [30], [
      ['BLACK_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['BLACK_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['BLINK                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['BLUE_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['BLUE_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['CYAN_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['CYAN_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['DISPLAY_LEFT_TO_RIGHT          ', clc$nominal_entry, clc$normal_usage_entry, 29],
      ['DISPLAY_RIGHT_TO_LEFT          ', clc$nominal_entry, clc$normal_usage_entry, 30],
      ['ERROR                          ', clc$nominal_entry, clc$normal_usage_entry, 27],
      ['GREEN_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['GREEN_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['HIDDEN                         ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['HIGH_INTENSITY                 ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['INPUT                          ', clc$nominal_entry, clc$normal_usage_entry, 26],
      ['INVERSE                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['ITALIC                         ', clc$nominal_entry, clc$normal_usage_entry, 24],
      ['LOW_INTENSITY                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['MAGENTA_BACKGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['MAGENTA_FOREGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 19],
      ['MESSAGE                        ', clc$nominal_entry, clc$normal_usage_entry, 28],
      ['PROTECT                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['RED_BACKGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['RED_FOREGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['TITLE                          ', clc$nominal_entry, clc$normal_usage_entry, 25],
      ['UNDERLINE                      ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['WHITE_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['WHITE_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['YELLOW_BACKGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['YELLOW_FOREGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 22]]
      ]
    ],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$variable_name = 1,
      p$occurrence = 2,
      p$text = 3,
      p$display = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      display_attribute_set: fdt$display_attribute_set,
      variable_name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_attributes (pvt [p$display].value, display_attribute_set, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$variable_name].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$variable_name].value^.name_value, form_processor, variable_name);
    ELSE
      variable_name := pvt [p$variable_name].value^.cobol_name_value;
    IFEND;

    fdp$create_stored_object (current_form_identifier, variable_name,
          pvt [p$occurrence].value^.integer_value.value, pvt [p$text].value^.string_value^,
          display_attribute_set, status);

  PROCEND add_stored_text;

?? OLDTITLE ??
?? NEWTITLE := 'add_table', EJECT ??

{ PURPOSE:
{   This procedure processes the add_table command.

  PROCEDURE add_table
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_addt) add_table, addt (
{   table_name, tn: any of
{       name
{       cobol_name
{     anyend = $required
{   variable_name, variable_names, vn: list of any of
{       name
{       cobol_name
{     anyend = $required
{   stored_occurrence, stored_occurrences, so: integer 1..fdc$maximum_occurrence = $required
{   visible_occurrence, visible_occurrences, vo: integer 1..fdc$maximum_occurrence = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 12] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$name_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 18, 16, 8, 44, 615],
    clc$command, 12, 5, 3, 0, 0, 0, 5, 'FDM$CREFM_ADDT'], [
    ['SO                             ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['STORED_OCCURRENCE              ',clc$nominal_entry, 3],
    ['STORED_OCCURRENCES             ',clc$alias_entry, 3],
    ['TABLE_NAME                     ',clc$nominal_entry, 1],
    ['TN                             ',clc$abbreviation_entry, 1],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 2],
    ['VARIABLE_NAMES                 ',clc$alias_entry, 2],
    ['VISIBLE_OCCURRENCE             ',clc$nominal_entry, 4],
    ['VISIBLE_OCCURRENCES            ',clc$alias_entry, 4],
    ['VN                             ',clc$abbreviation_entry, 2],
    ['VO                             ',clc$abbreviation_entry, 4]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 44, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 5
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [28, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
      FALSE, 2],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
      3, [[1, 0, clc$cobol_name_type]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, fdc$maximum_occurrence, 10]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [1, fdc$maximum_occurrence, 10]],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$table_name = 1,
      p$variable_name = 2,
      p$stored_occurrence = 3,
      p$visible_occurrence = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    CONST
      stored_attribute = 1,
      visible_attribute = 2;

    VAR
      list_size: clt$list_size,

      data_value_p: ^clt$data_value,
      table_attributes_p: ^array [1 .. * ] of fdt$table_attribute,
      table_name: ost$name,
      variable_attribute: visible_attribute + 1 .. clc$max_list_size + visible_attribute;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$table_name].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$table_name].value^.name_value, form_processor, table_name);
    ELSE
      table_name := pvt [p$table_name].value^.cobol_name_value;
    IFEND;

    list_size := clp$count_list_elements (pvt [p$variable_name].value);
    PUSH table_attributes_p: [1 .. list_size + visible_attribute];
    table_attributes_p^ [stored_attribute].key := fdc$stored_occurrence;
    table_attributes_p^ [stored_attribute].stored_occurrence := pvt [p$stored_occurrence].value^.
          integer_value.value;

    table_attributes_p^ [visible_attribute].key := fdc$visible_occurrence;
    IF pvt [p$visible_occurrence].specified THEN
      table_attributes_p^ [visible_attribute].visible_occurrence :=
            pvt [p$visible_occurrence].value^.integer_value.value;
    ELSE
      table_attributes_p^ [visible_attribute].visible_occurrence :=
            pvt [p$stored_occurrence].value^.integer_value.value;
    IFEND;

    data_value_p := pvt [p$variable_name].value;

    FOR variable_attribute := (visible_attribute + 1) TO visible_attribute + list_size DO
      table_attributes_p^ [variable_attribute].key := fdc$add_table_variable;
      IF data_value_p^.element_value^.kind = clc$name THEN
        convert_to_form_name (data_value_p^.element_value^.name_value, form_processor,
              table_attributes_p^ [variable_attribute].variable_name);
      ELSE
        table_attributes_p^ [variable_attribute].variable_name :=
              data_value_p^.element_value^.cobol_name_value;
      IFEND;

      data_value_p := data_value_p^.link;
    FOREND;

    fdp$create_table (current_form_identifier, table_name, table_attributes_p^, status);

  PROCEND add_table;

?? OLDTITLE ??
?? NEWTITLE := 'add_variable', EJECT ??

{ PURPOSE:
{   This procedure processes the add_variable command.

  PROCEDURE add_variable
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_addv) add_variable, addv (
{   variable_name, vn: any of
{       name
{       cobol_name
{     anyend = $required
{   io_mode, im: key
{       input, input_output, output, program
{     keyend = input_output
{   data_type, dt: key
{       character, integer, real, uppercase, cobol
{     keyend = character
{   error_processing, ep: any of
{       key
{         none, system
{       keyend
{       name
{       string 0..fdc$maximum_y_position
{     anyend = none
{   error_display, error_displays, ed: list of key
{       inverse, low_intensity, high_intensity, blink, underline, protect, hidden, black_background
{       blue_background, green_background, magenta_background, red_background, cyan_background
{       yellow_background, white_background, black_foreground, blue_foreground, green_foreground
{       magenta_foreground, red_foreground, cyan_foreground, yellow_foreground, white_foreground, error
{       italic, title, input, message
{     keyend = $optional
{   help_processing, hp: any of
{       key
{         none, system
{       keyend
{       name
{       string 0..fdc$maximum_y_position
{     anyend = none
{   length, l: integer 1..fdc$maximum_text_length = $optional
{   user_entry, user_entries, ue: list of key
{       optional, must_enter
{     keyend = optional
{   comment, comments, c: list of string 1..fdc$maximum_comment_length = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 22] of clt$pdt_parameter_name,
      parameters: array [1 .. 10] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (12),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
        default_value: string (9),
      recend,
      type4: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 28] of clt$keyword_specification,
        recend,
      recend,
      type6: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 2] of clt$keyword_specification,
        recend,
        default_value: string (8),
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 26, 15, 23, 3, 998],
    clc$command, 22, 10, 1, 0, 0, 0, 10, 'FDM$CREFM_ADDV'], [
    ['C                              ',clc$abbreviation_entry, 9],
    ['COMMENT                        ',clc$nominal_entry, 9],
    ['COMMENTS                       ',clc$alias_entry, 9],
    ['DATA_TYPE                      ',clc$nominal_entry, 3],
    ['DT                             ',clc$abbreviation_entry, 3],
    ['ED                             ',clc$abbreviation_entry, 5],
    ['EP                             ',clc$abbreviation_entry, 4],
    ['ERROR_DISPLAY                  ',clc$nominal_entry, 5],
    ['ERROR_DISPLAYS                 ',clc$alias_entry, 5],
    ['ERROR_PROCESSING               ',clc$nominal_entry, 4],
    ['HELP_PROCESSING                ',clc$nominal_entry, 6],
    ['HP                             ',clc$abbreviation_entry, 6],
    ['IM                             ',clc$abbreviation_entry, 2],
    ['IO_MODE                        ',clc$nominal_entry, 2],
    ['L                              ',clc$abbreviation_entry, 7],
    ['LENGTH                         ',clc$nominal_entry, 7],
    ['STATUS                         ',clc$nominal_entry, 10],
    ['UE                             ',clc$abbreviation_entry, 8],
    ['USER_ENTRIES                   ',clc$alias_entry, 8],
    ['USER_ENTRY                     ',clc$nominal_entry, 8],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 1],
    ['VN                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 12],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,
  clc$optional_default_parameter, 0, 9],
{ PARAMETER 4
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 5
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1059,
  clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 7
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 8
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 97,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 9
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 24, clc$optional_parameter,
  0, 0],
{ PARAMETER 10
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['INPUT                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['INPUT_OUTPUT                   ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['OUTPUT                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['PROGRAM                        ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ,
    'input_output'],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [5], [
    ['CHARACTER                      ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['COBOL                          ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['INTEGER                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['REAL                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['UPPERCASE                      ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ,
    'character'],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type, clc$string_type],
    FALSE, 3],
    81, [[1, 0, clc$keyword_type], [2], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    8, [[1, 0, clc$string_type], [0, fdc$maximum_y_position, FALSE]]
    ,
    'none'],
{ PARAMETER 5
    [[1, 0, clc$list_type], [1043, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [28], [
      ['BLACK_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['BLACK_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['BLINK                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['BLUE_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['BLUE_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['CYAN_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['CYAN_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['ERROR                          ', clc$nominal_entry, clc$normal_usage_entry, 24],
      ['GREEN_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['GREEN_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['HIDDEN                         ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['HIGH_INTENSITY                 ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['INPUT                          ', clc$nominal_entry, clc$normal_usage_entry, 27],
      ['INVERSE                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['ITALIC                         ', clc$nominal_entry, clc$normal_usage_entry, 25],
      ['LOW_INTENSITY                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['MAGENTA_BACKGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['MAGENTA_FOREGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 19],
      ['MESSAGE                        ', clc$nominal_entry, clc$normal_usage_entry, 28],
      ['PROTECT                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['RED_BACKGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['RED_FOREGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['TITLE                          ', clc$nominal_entry, clc$normal_usage_entry, 26],
      ['UNDERLINE                      ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['WHITE_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['WHITE_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['YELLOW_BACKGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['YELLOW_FOREGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 22]]
      ]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type, clc$string_type],
    FALSE, 3],
    81, [[1, 0, clc$keyword_type], [2], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    8, [[1, 0, clc$string_type], [0, fdc$maximum_y_position, FALSE]]
    ,
    'none'],
{ PARAMETER 7
    [[1, 0, clc$integer_type], [1, fdc$maximum_text_length, 10]],
{ PARAMETER 8
    [[1, 0, clc$list_type], [81, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [2], [
      ['MUST_ENTER                     ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['OPTIONAL                       ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'optional'],
{ PARAMETER 9
    [[1, 0, clc$list_type], [8, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$string_type], [1, fdc$maximum_comment_length, FALSE]]
    ],
{ PARAMETER 10
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$variable_name = 1,
      p$io_mode = 2,
      p$data_type = 3,
      p$error_processing = 4,
      p$error_display = 5,
      p$help_processing = 6,
      p$length = 7,
      p$user_entry = 8,
      p$comment = 9,
      p$status = 10;

    VAR
      pvt: array [1 .. 10] of clt$parameter_value;

    CONST
      io_attribute = 1,
      data_type_attribute = 2,
      error_processing_attribute = 3,
      help_attribute = 4,
      error_display_attribute = 5,
      length_attribute = 6,
      user_entry_attribute = 7,
      comment_attribute = 8;

    VAR
      comment_list_size: clt$list_size,
      keyword: clt$keyword,
      user_entry_list_size: clt$list_size,
      n: integer,
      data_value_p: ^clt$data_value,
      variable_attributes_p: ^array [1 .. * ] of fdt$variable_attribute,
      variable_name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$variable_name].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$variable_name].value^.name_value, form_processor, variable_name);
    ELSE
      variable_name := pvt [p$variable_name].value^.cobol_name_value;
    IFEND;

    comment_list_size := clp$count_list_elements (pvt [p$comment].value);
    PUSH variable_attributes_p: [1 .. comment_list_size + user_entry_attribute];
    variable_attributes_p^ [io_attribute].key := fdc$io_mode;
    IF (pvt [p$io_mode].value^.keyword_value = 'INPUT') THEN
      variable_attributes_p^ [io_attribute].io_mode := fdc$terminal_input;
    ELSEIF (pvt [p$io_mode].value^.keyword_value = 'INPUT_OUTPUT') THEN
      variable_attributes_p^ [io_attribute].io_mode := fdc$terminal_input_output;
    ELSEIF (pvt [p$io_mode].value^.keyword_value = 'OUTPUT') THEN
      variable_attributes_p^ [io_attribute].io_mode := fdc$terminal_output;
    ELSEIF (pvt [p$io_mode].value^.keyword_value = 'PROGRAM') THEN
      variable_attributes_p^ [io_attribute].io_mode := fdc$program_input_output;
    IFEND;

    variable_attributes_p^ [data_type_attribute].key := fdc$program_data_type;
    IF (pvt [p$data_type].value^.keyword_value = 'CHARACTER') THEN
      variable_attributes_p^ [data_type_attribute].program_data_type := fdc$program_character_type;
    ELSEIF (pvt [p$data_type].value^.keyword_value = 'INTEGER') THEN
      variable_attributes_p^ [data_type_attribute].program_data_type := fdc$program_integer_type;
    ELSEIF (pvt [p$data_type].value^.keyword_value = 'REAL') THEN
      variable_attributes_p^ [data_type_attribute].program_data_type := fdc$program_real_type;
    ELSEIF (pvt [p$data_type].value^.keyword_value = 'UPPERCASE') THEN
      variable_attributes_p^ [data_type_attribute].program_data_type := fdc$program_upper_case_type;
    ELSEIF (pvt [p$data_type].value^.keyword_value = 'COBOL') THEN
      variable_attributes_p^ [data_type_attribute].program_data_type := fdc$program_cobol_type;
    IFEND;

    variable_attributes_p^ [error_processing_attribute].key := fdc$variable_error;
    CASE pvt [p$error_processing].value^.kind OF

    = clc$keyword =
      IF (pvt [p$error_processing].value^.keyword_value = 'SYSTEM') THEN
        variable_attributes_p^ [error_processing_attribute].variable_error.key := fdc$system_default_error;
      ELSEIF (pvt [p$error_processing].value^.keyword_value = 'NONE') THEN
        variable_attributes_p^ [error_processing_attribute].variable_error.key := fdc$no_error_response;
      IFEND;

    = clc$name =
      variable_attributes_p^ [error_processing_attribute].variable_error.key := fdc$error_form;
      variable_attributes_p^ [error_processing_attribute].variable_error.error_form :=
            pvt [p$error_processing].value^.name_value;
    ELSE
      variable_attributes_p^ [error_processing_attribute].variable_error.key := fdc$error_message;
      variable_attributes_p^ [error_processing_attribute].variable_error.p_error_message :=
            pvt [p$error_processing].value^.string_value;
    CASEND;

    variable_attributes_p^ [help_attribute].key := fdc$variable_help;
    CASE pvt [p$help_processing].value^.kind OF

    = clc$keyword =
      IF (pvt [p$help_processing].value^.keyword_value = 'SYSTEM') THEN
        variable_attributes_p^ [help_attribute].variable_help.key := fdc$system_default_help;
      ELSE
        variable_attributes_p^ [help_attribute].variable_help.key := fdc$no_help_response;
      IFEND;

    = clc$name =
      variable_attributes_p^ [help_attribute].variable_help.key := fdc$help_form;
      variable_attributes_p^ [help_attribute].variable_help.help_form :=
            pvt [p$help_processing].value^.name_value;

    ELSE
      variable_attributes_p^ [help_attribute].variable_help.key := fdc$help_message;
      variable_attributes_p^ [help_attribute].variable_help.p_help_message :=
            pvt [p$help_processing].value^.string_value;
    CASEND;

    IF pvt [p$error_display].specified THEN
      variable_attributes_p^ [error_display_attribute].key := fdc$error_display;
      process_attributes (pvt [p$error_display].value, variable_attributes_p^ [error_display_attribute].
            display_attribute, status);
      IF NOT status.normal THEN
       RETURN;
      IFEND;
    ELSE
      variable_attributes_p^ [error_display_attribute].key := fdc$unused_variable_entry;
    IFEND;

    IF pvt [p$length].specified THEN
      variable_attributes_p^ [length_attribute].key := fdc$variable_length;
      variable_attributes_p^ [length_attribute].variable_length := pvt [p$length].value^.integer_value.value;
    ELSE
      variable_attributes_p^ [length_attribute].key := fdc$unused_variable_entry;
    IFEND;

    variable_attributes_p^ [user_entry_attribute].key := fdc$terminal_user_entry;
    variable_attributes_p^ [user_entry_attribute].terminal_user_entry := $fdt$terminal_user_entry [];

    data_value_p := pvt [p$user_entry].value;
    user_entry_list_size := clp$count_list_elements (data_value_p);

  /get_next_entry/
    FOR n := 1 TO user_entry_list_size DO
      keyword := data_value_p^.element_value^.keyword_value;
      IF (keyword = 'OPTIONAL') THEN
        variable_attributes_p^ [user_entry_attribute].terminal_user_entry :=
              variable_attributes_p^ [user_entry_attribute].terminal_user_entry +
              $fdt$terminal_user_entry [fdc$entry_optional];
      ELSE
        variable_attributes_p^ [user_entry_attribute].terminal_user_entry :=
              variable_attributes_p^ [user_entry_attribute].terminal_user_entry +
              $fdt$terminal_user_entry [fdc$must_enter];
      IFEND;

      data_value_p := data_value_p^.link;

    FOREND /get_next_entry/;

    data_value_p := pvt [p$comment].value;

  /get_comment/
    FOR n := comment_attribute TO comment_list_size + user_entry_attribute DO
      variable_attributes_p^ [n].key := fdc$add_var_comment;
      variable_attributes_p^ [n].p_var_comment := data_value_p^.element_value^.string_value;
      data_value_p := data_value_p^.link;
    FOREND /get_comment/;

    fdp$create_variable (current_form_identifier, variable_name, variable_attributes_p^, status);

  PROCEND add_variable;

?? OLDTITLE ??
?? NEWTITLE := 'add_variable_text', EJECT ??

{ PURPOSE:
{   This procedure processes the add_variable_text command.

  PROCEDURE add_variable_text
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (fdm$crefm_addvt) add_variable_text, addvt (
{   column, c: integer 1..fdc$maximum_x_position = $required
{   line, l: integer 1..fdc$maximum_y_position = $required
{   text, t: string 0..fdc$maximum_text_length = $required
{   variable_name, vn: any of
{       name
{       cobol_name
{     anyend = $required
{   occurrence, o: integer 1..fdc$maximum_occurrence = 1
{   display, displays, d: list of key
{       inverse, low_intensity, high_intensity, blink, underline, protect, hidden, black_background
{       blue_background, green_background, magenta_background, red_background, cyan_background
{       yellow_background, white_background, black_foreground, blue_foreground, green_foreground
{       magenta_foreground, red_foreground, cyan_foreground, yellow_foreground, white_foreground, italic
{       title, input, error, message, display_left_to_right, display_right_to_left
{     keyend = $optional
{   width, w: integer 1..fdc$maximum_y_position = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 16] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type4: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 30] of clt$keyword_specification,
        recend,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 18, 16, 9, 26, 715],
    clc$command, 16, 8, 4, 0, 0, 0, 8, 'FDM$CREFM_ADDVT'], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['COLUMN                         ',clc$nominal_entry, 1],
    ['D                              ',clc$abbreviation_entry, 6],
    ['DISPLAY                        ',clc$nominal_entry, 6],
    ['DISPLAYS                       ',clc$alias_entry, 6],
    ['L                              ',clc$abbreviation_entry, 2],
    ['LINE                           ',clc$nominal_entry, 2],
    ['O                              ',clc$abbreviation_entry, 5],
    ['OCCURRENCE                     ',clc$nominal_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 8],
    ['T                              ',clc$abbreviation_entry, 3],
    ['TEXT                           ',clc$nominal_entry, 3],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 4],
    ['VN                             ',clc$abbreviation_entry, 4],
    ['W                              ',clc$abbreviation_entry, 7],
    ['WIDTH                          ',clc$nominal_entry, 7]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 4
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 6
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1133,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 8
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [1, fdc$maximum_x_position, 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, fdc$maximum_y_position, 10]],
{ PARAMETER 3
    [[1, 0, clc$string_type], [0, fdc$maximum_text_length, FALSE]],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [1, fdc$maximum_occurrence, 10],
    '1'],
{ PARAMETER 6
    [[1, 0, clc$list_type], [1117, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [30], [
      ['BLACK_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['BLACK_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['BLINK                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['BLUE_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['BLUE_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['CYAN_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['CYAN_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['DISPLAY_LEFT_TO_RIGHT          ', clc$nominal_entry, clc$normal_usage_entry, 29],
      ['DISPLAY_RIGHT_TO_LEFT          ', clc$nominal_entry, clc$normal_usage_entry, 30],
      ['ERROR                          ', clc$nominal_entry, clc$normal_usage_entry, 27],
      ['GREEN_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['GREEN_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['HIDDEN                         ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['HIGH_INTENSITY                 ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['INPUT                          ', clc$nominal_entry, clc$normal_usage_entry, 26],
      ['INVERSE                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['ITALIC                         ', clc$nominal_entry, clc$normal_usage_entry, 24],
      ['LOW_INTENSITY                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['MAGENTA_BACKGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['MAGENTA_FOREGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 19],
      ['MESSAGE                        ', clc$nominal_entry, clc$normal_usage_entry, 28],
      ['PROTECT                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['RED_BACKGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['RED_FOREGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['TITLE                          ', clc$nominal_entry, clc$normal_usage_entry, 25],
      ['UNDERLINE                      ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['WHITE_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['WHITE_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['YELLOW_BACKGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['YELLOW_FOREGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 22]]
      ]
    ],
{ PARAMETER 7
    [[1, 0, clc$integer_type], [1, fdc$maximum_y_position, 10]],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$column = 1,
      p$line = 2,
      p$text = 3,
      p$variable_name = 4,
      p$occurrence = 5,
      p$display = 6,
      p$width = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    VAR
      object_attributes: array [1 .. 2] of fdt$object_attribute,
      object_definition: fdt$object_definition;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    object_definition.key := fdc$variable_text;
    object_definition.p_variable_text := pvt [p$text].value^.string_value;
    IF pvt [p$width].specified THEN
      object_definition.variable_text_width := pvt [p$width].value^.integer_value.value;
    ELSE

{ If user does not specify the width, then the length of the text is used.

      IF STRLENGTH (pvt [p$text].value^.string_value^) <> 0 THEN
        object_definition.variable_text_width := STRLENGTH (pvt [p$text].value^.string_value^);
      ELSE
        osp$set_status_abnormal (fdc$format_display_identifier, fde$object_width_required, current_form_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, pvt [p$variable_name].value^.name_value,
              status);
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$display].specified THEN
      object_attributes [1].key := fdc$object_display;
      process_attributes (pvt [p$display].value, object_attributes [1].display_attribute, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      object_attributes [1].key := fdc$unused_object_entry;
    IFEND;

    object_attributes [2].key := fdc$object_name;
    object_attributes [2].occurrence := pvt [p$occurrence].value^.integer_value.value;
    IF pvt [p$variable_name].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$variable_name].value^.name_value, form_processor,
            object_attributes [2].object_name);
    ELSE
      object_attributes [2].object_name := pvt [p$variable_name].value^.cobol_name_value;
    IFEND;

{ Special fix for Screen Design Facility.  SDF cannot handle zero length strings.

    IF STRLENGTH (object_definition.p_variable_text^) = 0 THEN
      object_definition.p_variable_text := ^one_blank;
    IFEND;

    fdp$create_object (current_form_identifier, pvt [p$column].value^.integer_value.value, pvt [p$line].
          value^.integer_value.value, object_definition, object_attributes, status);

  PROCEND add_variable_text;

?? OLDTITLE ??
?? NEWTITLE := 'add_variable_text_box', EJECT ??

{ PURPOSE:
{   This procedure processes the add_variable_text_box command.

  PROCEDURE add_variable_text_box
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_addvtb) add_variable_text_box, addvtb (
{   column, c: integer 1..fdc$maximum_x_position = $required
{   line, l: integer 1..fdc$maximum_y_position = $required
{   text, t: string 0..fdc$maximum_text_length = $required
{   width, w: integer 1..fdc$maximum_x_position = $required
{   height, h: integer 1..fdc$maximum_y_position = $required
{   variable_name, vn: any of
{       name
{       cobol_name
{     anyend = $required
{   occurrence, o: integer 1..fdc$maximum_occurrence = 1
{   display, displays, d: list of key
{       inverse, low_intensity, high_intensity, blink, underline, protect, hidden, black_background
{       blue_background, green_background, magenta_background, red_background, cyan_background
{       yellow_background, white_background, black_foreground, blue_foreground, green_foreground
{       magenta_foreground, red_foreground, cyan_foreground, yellow_foreground, white_foreground, italic
{       title, input, error, message, display_left_to_right, display_right_to_left
{     keyend = $optional
{   text_format, tf: key
{       wrap_words, wrap_characters
{     keyend = wrap_words
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 20] of clt$pdt_parameter_name,
      parameters: array [1 .. 10] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type6: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 30] of clt$keyword_specification,
        recend,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (10),
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 18, 16, 9, 43, 812],
    clc$command, 20, 10, 6, 0, 0, 0, 10, 'FDM$CREFM_ADDVTB'], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['COLUMN                         ',clc$nominal_entry, 1],
    ['D                              ',clc$abbreviation_entry, 8],
    ['DISPLAY                        ',clc$nominal_entry, 8],
    ['DISPLAYS                       ',clc$alias_entry, 8],
    ['H                              ',clc$abbreviation_entry, 5],
    ['HEIGHT                         ',clc$nominal_entry, 5],
    ['L                              ',clc$abbreviation_entry, 2],
    ['LINE                           ',clc$nominal_entry, 2],
    ['O                              ',clc$abbreviation_entry, 7],
    ['OCCURRENCE                     ',clc$nominal_entry, 7],
    ['STATUS                         ',clc$nominal_entry, 10],
    ['T                              ',clc$abbreviation_entry, 3],
    ['TEXT                           ',clc$nominal_entry, 3],
    ['TEXT_FORMAT                    ',clc$nominal_entry, 9],
    ['TF                             ',clc$abbreviation_entry, 9],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 6],
    ['VN                             ',clc$abbreviation_entry, 6],
    ['W                              ',clc$abbreviation_entry, 4],
    ['WIDTH                          ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 4
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 6
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 7
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 8
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1133,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81,
  clc$optional_default_parameter, 0, 10],
{ PARAMETER 10
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [1, fdc$maximum_x_position, 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, fdc$maximum_y_position, 10]],
{ PARAMETER 3
    [[1, 0, clc$string_type], [0, fdc$maximum_text_length, FALSE]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [1, fdc$maximum_x_position, 10]],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [1, fdc$maximum_y_position, 10]],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 7
    [[1, 0, clc$integer_type], [1, fdc$maximum_occurrence, 10],
    '1'],
{ PARAMETER 8
    [[1, 0, clc$list_type], [1117, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [30], [
      ['BLACK_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['BLACK_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['BLINK                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['BLUE_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['BLUE_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['CYAN_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['CYAN_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['DISPLAY_LEFT_TO_RIGHT          ', clc$nominal_entry, clc$normal_usage_entry, 29],
      ['DISPLAY_RIGHT_TO_LEFT          ', clc$nominal_entry, clc$normal_usage_entry, 30],
      ['ERROR                          ', clc$nominal_entry, clc$normal_usage_entry, 27],
      ['GREEN_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['GREEN_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['HIDDEN                         ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['HIGH_INTENSITY                 ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['INPUT                          ', clc$nominal_entry, clc$normal_usage_entry, 26],
      ['INVERSE                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['ITALIC                         ', clc$nominal_entry, clc$normal_usage_entry, 24],
      ['LOW_INTENSITY                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['MAGENTA_BACKGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['MAGENTA_FOREGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 19],
      ['MESSAGE                        ', clc$nominal_entry, clc$normal_usage_entry, 28],
      ['PROTECT                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['RED_BACKGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['RED_FOREGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['TITLE                          ', clc$nominal_entry, clc$normal_usage_entry, 25],
      ['UNDERLINE                      ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['WHITE_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['WHITE_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['YELLOW_BACKGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['YELLOW_FOREGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 22]]
      ]
    ],
{ PARAMETER 9
    [[1, 0, clc$keyword_type], [2], [
    ['WRAP_CHARACTERS                ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['WRAP_WORDS                     ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'wrap_words'],
{ PARAMETER 10
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$column = 1,
      p$line = 2,
      p$text = 3,
      p$width = 4,
      p$height = 5,
      p$variable_name = 6,
      p$occurrence = 7,
      p$display = 8,
      p$text_format = 9,
      p$status = 10;

    VAR
      pvt: array [1 .. 10] of clt$parameter_value;

    VAR
      fix_string_p: ^string(*),
      object_attributes: array [1 .. 2] of fdt$object_attribute,
      object_definition: fdt$object_definition;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    object_definition.key := fdc$variable_text_box;
    object_definition.p_variable_box_text := pvt [p$text].value^.string_value;
    object_definition.variable_box_width := pvt [p$width].value^.integer_value.value;
    object_definition.variable_box_height := pvt [p$height].value^.integer_value.value;
    IF (pvt [p$text_format].value^.keyword_value = 'WRAP_WORDS') THEN
      object_definition.variable_box_processing := fdc$wrap_words;
    ELSE
      object_definition.variable_box_processing := fdc$wrap_characters;
    IFEND;

    IF pvt [p$display].specified THEN
      object_attributes [1].key := fdc$object_display;
      process_attributes (pvt [p$display].value, object_attributes [1].display_attribute, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      object_attributes [1].key := fdc$unused_object_entry;
    IFEND;

    object_attributes [2].key := fdc$object_name;
    object_attributes [2].occurrence := pvt [p$occurrence].value^.integer_value.value;
    IF pvt [p$variable_name].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$variable_name].value^.name_value, form_processor,
            object_attributes [2].object_name);
    ELSE
      object_attributes [2].object_name := pvt [p$variable_name].value^.cobol_name_value;
    IFEND;

{ Fix for Screen Design Facility. SDF cannot process zero length strings.

    IF STRLENGTH (object_definition.p_variable_box_text^) = 0 THEN
      object_definition.p_variable_box_text := ^one_blank;
    IFEND;

    fdp$create_object (current_form_identifier, pvt [p$column].value^.integer_value.value, pvt [p$line].
          value^.integer_value.value, object_definition, object_attributes, status);

  PROCEND add_variable_text_box;

?? OLDTITLE ??
?? NEWTITLE := 'set_character_input', EJECT ??

{ PURPOSE:
{   This procedure processes the set_character_input command.

  PROCEDURE set_character_input
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_setci) set_character_input, setci (
{   variable_name, vn: any of
{       name
{       cobol_name
{     anyend = $required
{   valid_value, valid_values, vv: list of string 0..fdc$maximum_valid_string = $optional
{   compare_to_substring, cts: boolean = TRUE
{   entry_format, ef: key
{       character, alphabetic, digits, signed
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 27, 9, 26, 27, 400],
    clc$command, 10, 5, 1, 0, 0, 0, 5, 'FDM$CREFM_SETCI'], [
    ['COMPARE_TO_SUBSTRING           ',clc$nominal_entry, 3],
    ['CTS                            ',clc$abbreviation_entry, 3],
    ['EF                             ',clc$abbreviation_entry, 4],
    ['ENTRY_FORMAT                   ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['VALID_VALUE                    ',clc$nominal_entry, 2],
    ['VALID_VALUES                   ',clc$alias_entry, 2],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 1],
    ['VN                             ',clc$abbreviation_entry, 1],
    ['VV                             ',clc$abbreviation_entry, 2]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 24, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [8, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$string_type], [0, fdc$maximum_valid_string, FALSE]]
    ],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [4], [
    ['ALPHABETIC                     ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['CHARACTER                      ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['DIGITS                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['SIGNED                         ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$variable_name = 1,
      p$valid_value = 2,
      p$compare_to_substring = 3,
      p$entry_format = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    CONST
      compare_attribute = 1,
      format_attribute = 2,
      value_attribute = 3;

    VAR
      list_size: clt$list_size,
      next_data_value_p: ^clt$data_value,
      variable_attributes_p: ^array [1 .. * ] of fdt$variable_attribute,
      valid_value: value_attribute .. clc$max_list_size + value_attribute,
      variable_name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    list_size := clp$count_list_elements (pvt [p$valid_value].value);
    PUSH variable_attributes_p: [1 .. list_size + format_attribute];

    variable_attributes_p^ [compare_attribute].key := fdc$string_compare_rules;
    variable_attributes_p^ [compare_attribute].compare_to_unique_substring :=
          pvt [p$compare_to_substring].value^.boolean_value.value;
    variable_attributes_p^ [compare_attribute].compare_in_upper_case := FALSE;

    IF pvt [p$entry_format].specified THEN
      variable_attributes_p^ [format_attribute].key := fdc$input_format;
      IF pvt [p$entry_format].value^.keyword_value = 'CHARACTER' THEN
        variable_attributes_p^ [format_attribute].input_format.key := fdc$character_input_format;
      ELSEIF pvt [p$entry_format].value^.keyword_value = 'ALPHABETIC' THEN
        variable_attributes_p^ [format_attribute].input_format.key := fdc$alphabetic_input_format;
      ELSEIF pvt [p$entry_format].value^.keyword_value = 'DIGITS' THEN
        variable_attributes_p^ [format_attribute].input_format.key := fdc$digits_input_format;
      ELSE
        variable_attributes_p^ [format_attribute].input_format.key := fdc$signed_input_format;
      IFEND;
    ELSE
       variable_attributes_p^ [format_attribute].key := fdc$unused_variable_entry;
    IFEND;

    next_data_value_p := pvt [p$valid_value].value;

  /get_valid_string/
    FOR valid_value := value_attribute TO list_size + format_attribute DO
      variable_attributes_p^ [valid_value].key := fdc$add_valid_string;
      variable_attributes_p^ [valid_value].p_valid_string := next_data_value_p^.element_value^.string_value;
      next_data_value_p := next_data_value_p^.link;
    FOREND /get_valid_string/;

    IF pvt [p$variable_name].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$variable_name].value^.name_value, form_processor, variable_name);
    ELSE
      variable_name := pvt [p$variable_name].value^.cobol_name_value;
    IFEND;

    fdp$change_variable (current_form_identifier, variable_name, variable_attributes_p^, status);

  PROCEND set_character_input;

?? OLDTITLE ??
?? NEWTITLE := 'set_cobol_data', EJECT ??
{ PURPOSE:
{   This procedure processes the set_cobol_data command.

  PROCEDURE set_cobol_data
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_setcd) set_cobol_data, setcd (
{   variable_name, vn: any of
{       name
{       cobol_name
{     anyend = $required
{   usage, u: key
{       binary, computational, comp, computational_1, comp_1, computational_3, comp_3, display, packed_decimal
{     keyend = display
{   picture, p: string 0..fdc$maximum_picture_length = ''
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 9] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (2),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 14, 16, 38, 28, 515],
    clc$command, 7, 4, 1, 0, 0, 0, 4, 'FDM$CREFM_SETCD'], [
    ['P                              ',clc$abbreviation_entry, 3],
    ['PICTURE                        ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['U                              ',clc$abbreviation_entry, 2],
    ['USAGE                          ',clc$nominal_entry, 2],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 1],
    ['VN                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 340,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 4
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [9], [
    ['BINARY                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['COMP                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['COMPUTATIONAL                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['COMPUTATIONAL_1                ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['COMPUTATIONAL_3                ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['COMP_1                         ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['COMP_3                         ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['DISPLAY                        ', clc$nominal_entry, clc$normal_usage_entry, 8],
    ['PACKED_DECIMAL                 ', clc$nominal_entry, clc$normal_usage_entry, 9]]
    ,
    'display'],
{ PARAMETER 3
    [[1, 0, clc$string_type], [0, fdc$maximum_picture_length, FALSE],
    ''''''],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$variable_name = 1,
      p$usage = 2,
      p$picture = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      cobol_program_clause : fdt$cobol_program_clause,
      variable_attributes: array [1 .. 2] of fdt$variable_attribute,
      variable_name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cobol_program_clause.picture := pvt[p$picture].value^.string_value^;
    IF pvt [p$usage].value^.keyword_value = 'BINARY' THEN
      cobol_program_clause.usage := fdc$binary_usage;
    ELSEIF pvt [p$usage].value^.keyword_value = 'COMPUTATIONAL' THEN
      cobol_program_clause.usage := fdc$computational_usage;
    ELSEIF pvt [p$usage].value^.keyword_value = 'COMP' THEN
      cobol_program_clause.usage := fdc$comp_usage;
    ELSEIF pvt [p$usage].value^.keyword_value = 'COMPUTATIONAL_1' THEN
      cobol_program_clause.usage := fdc$computational_1_usage;
    ELSEIF pvt [p$usage].value^.keyword_value = 'COMP_1' THEN
      cobol_program_clause.usage := fdc$comp_1_usage;
    ELSEIF pvt [p$usage].value^.keyword_value = 'COMPUTATIONAL_3' THEN
      cobol_program_clause.usage := fdc$computational_3_usage;
    ELSEIF pvt [p$usage].value^.keyword_value = 'COMP_3' THEN
      cobol_program_clause.usage := fdc$comp_3_usage;
    ELSEIF pvt [p$usage].value^.keyword_value = 'DISPLAY' THEN
      cobol_program_clause.usage := fdc$display_usage;
    ELSE { PACKED_DECIMAL
       cobol_program_clause.usage := fdc$packed_decimal_usage;
    IFEND;

    variable_attributes [1].key := fdc$program_data_type;
    variable_attributes [1].program_data_type := fdc$program_cobol_type;
    variable_attributes [2].key := fdc$cobol_program_clause;
    variable_attributes [2].p_cobol_program_clause := ^cobol_program_clause;

    IF pvt [p$variable_name].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$variable_name].value^.name_value,
            form_processor, variable_name);
    ELSE
      variable_name := pvt [p$variable_name].value^.cobol_name_value;
    IFEND;

    fdp$change_variable (current_form_identifier, variable_name,
          variable_attributes, status);

  PROCEND set_cobol_data;

?? OLDTITLE ??
?? NEWTITLE := 'set_cobol_output', EJECT ??
{ PURPOSE:
{   This procedure processes the set_cobol_output command.

  PROCEDURE set_cobol_output
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_setco) set_cobol_output, setco (
{   variable_name, vn: any of
{       name
{       cobol_name
{     anyend = $required
{   picture, p: string 0..fdc$maximum_picture_length = ''
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (2),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 14, 16, 39, 42, 673],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'FDM$CREFM_SETCO'], [
    ['P                              ',clc$abbreviation_entry, 2],
    ['PICTURE                        ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 1],
    ['VN                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$string_type], [0, fdc$maximum_picture_length, FALSE],
    ''''''],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$variable_name = 1,
      p$picture = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      cobol_display_clause: fdt$cobol_display_clause,
      variable_attributes: array [1 .. 2] of fdt$variable_attribute,
      variable_name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cobol_display_clause.picture := pvt[p$picture].value^.string_value^;
    variable_attributes [1].key := fdc$program_data_type;
    variable_attributes [1].program_data_type := fdc$program_cobol_type;
    variable_attributes [2].key := fdc$cobol_display_clause;
    variable_attributes [2].p_cobol_display_clause := ^cobol_display_clause;

    IF pvt [p$variable_name].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$variable_name].value^.name_value,
            form_processor, variable_name);
    ELSE
      variable_name := pvt [p$variable_name].value^.cobol_name_value;
    IFEND;

 fdp$change_variable (current_form_identifier, variable_name,
          variable_attributes, status);

  PROCEND set_cobol_output;

?? OLDTITLE ??
?? NEWTITLE := 'set_date_input', EJECT ??

{ PURPOSE:
{   This procedure processes the set_date_input command.

  PROCEDURE set_date_input
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_setdi) set_date_input, setdi (
{   variable_name, vn: any of
{       name
{       cobol_name
{     anyend = $required
{   format, f: key
{       dmy, mdy, ydm, isod, month
{     keyend = mdy
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 5, 6, 14, 26, 28, 94],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'FDM$CREFM_SETDI'], [
    ['F                              ',clc$abbreviation_entry, 2],
    ['FORMAT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 1],
    ['VN                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [5], [
    ['DMY                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ISOD                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['MDY                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['MONTH                          ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['YDM                            ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ,
    'mdy'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$variable_name = 1,
      p$format = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      variable_attributes: array [1 .. 1] of fdt$variable_attribute,
      variable_name: ost$name;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    variable_attributes [1].key := fdc$input_format;
    IF pvt [p$format].value^.keyword_value = 'MDY' THEN
      variable_attributes [1].input_format.key := fdc$mdy_format;
    ELSEIF pvt [p$format].value^.keyword_value = 'YDM' THEN
      variable_attributes [1].input_format.key := fdc$ydm_format;
    ELSEIF pvt [p$format].value^.keyword_value = 'ISOD' THEN
      variable_attributes [1].input_format.key := fdc$iso_date_format;
    ELSEIF pvt [p$format].value^.keyword_value = 'MONTH' THEN
      variable_attributes [1].input_format.key := fdc$month_dd_yyyy_format;
    ELSE { pvt [p$format].value^.keyword_value = 'DMY'
      variable_attributes [1].input_format.key := fdc$dmy_format;
    IFEND;

    IF pvt [p$variable_name].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$variable_name].value^.name_value, form_processor, variable_name);
    ELSE
      variable_name := pvt [p$variable_name].value^.cobol_name_value;
    IFEND;

    fdp$change_variable (current_form_identifier, variable_name, variable_attributes, status);

  PROCEND set_date_input;

?? OLDTITLE ??
?? NEWTITLE := 'set_date_output', EJECT ??

{ PURPOSE:
{   This procedure processes the set_date_output command.

  PROCEDURE set_date_output
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_setdo) set_date_output, setdo (
{   variable_name, vn: any of
{       name
{       cobol_name
{     anyend = $required
{   format, f: key
{       dmy, mdy, ydm, isod, month
{     keyend = mdy
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 5, 9, 9, 51, 42, 651],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'FDM$CREFM_SETDO'], [
    ['F                              ',clc$abbreviation_entry, 2],
    ['FORMAT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 1],
    ['VN                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [5], [
    ['DMY                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ISOD                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['MDY                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['MONTH                          ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['YDM                            ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ,
    'mdy'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$variable_name = 1,
      p$format = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      variable_attributes: array [1 .. 1] of fdt$variable_attribute,
      variable_name: ost$name;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    variable_attributes [1].key := fdc$output_format;
    IF pvt [p$format].value^.keyword_value = 'MDY' THEN
      variable_attributes [1].output_format.key := fdc$mdy_output_format;
    ELSEIF pvt [p$format].value^.keyword_value = 'YDM' THEN
      variable_attributes [1].output_format.key := fdc$ydm_output_format;
    ELSEIF pvt [p$format].value^.keyword_value = 'MONTH' THEN
      variable_attributes [1].output_format.key := fdc$month_dd_yyyy_out_format;
    ELSEIF pvt [p$format].value^.keyword_value = 'ISOD' THEN
      variable_attributes [1].output_format.key := fdc$iso_output_format;
    ELSE { pvt [p$format].value^.keyword_value = 'DMY'
      variable_attributes [1].output_format.key := fdc$dmy_output_format;
    IFEND;

    IF pvt [p$variable_name].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$variable_name].value^.name_value, form_processor, variable_name);
    ELSE
      variable_name := pvt [p$variable_name].value^.cobol_name_value;
    IFEND;

    fdp$change_variable (current_form_identifier, variable_name, variable_attributes, status);

  PROCEND set_date_output;

?? OLDTITLE ??
?? NEWTITLE := 'set_exponent_output', EJECT ??

{ PURPOSE:
{   This procedure processes the set_exponent_output command.

  PROCEDURE set_exponent_output
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_seteo) set_exponent_output, seteo (
{   variable_name, vn: any of
{       name
{       cobol_name
{     anyend = $required
{   format, f: key
{       ee, ge
{     keyend = $required
{   width, w: integer 1..19 = $required
{   digits_right_of_decimal, drod: integer 0..19 = $required
{   digits_in_exponent, die: integer 0..19 = $required
{   sign, s: key
{       minus_if_negative, always_signed
{     keyend = minus_if_negative
{   suppress_zero, sz: boolean = TRUE
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 15] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (17),
      recend,
      type7: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 18, 16, 10, 40, 538],
    clc$command, 15, 8, 5, 0, 0, 0, 8, 'FDM$CREFM_SETEO'], [
    ['DIE                            ',clc$abbreviation_entry, 5],
    ['DIGITS_IN_EXPONENT             ',clc$nominal_entry, 5],
    ['DIGITS_RIGHT_OF_DECIMAL        ',clc$nominal_entry, 4],
    ['DROD                           ',clc$abbreviation_entry, 4],
    ['F                              ',clc$abbreviation_entry, 2],
    ['FORMAT                         ',clc$nominal_entry, 2],
    ['S                              ',clc$abbreviation_entry, 6],
    ['SIGN                           ',clc$nominal_entry, 6],
    ['STATUS                         ',clc$nominal_entry, 8],
    ['SUPPRESS_ZERO                  ',clc$nominal_entry, 7],
    ['SZ                             ',clc$abbreviation_entry, 7],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 1],
    ['VN                             ',clc$abbreviation_entry, 1],
    ['W                              ',clc$abbreviation_entry, 3],
    ['WIDTH                          ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 4
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 5
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 6
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81,
  clc$optional_default_parameter, 0, 17],
{ PARAMETER 7
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 8
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [2], [
    ['EE                             ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['GE                             ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, 19, 10]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [0, 19, 10]],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [0, 19, 10]],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [2], [
    ['ALWAYS_SIGNED                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['MINUS_IF_NEGATIVE              ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'minus_if_negative'],
{ PARAMETER 7
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$variable_name = 1,
      p$format = 2,
      p$width = 3,
      p$digits_right_of_decimal = 4,
      p$digits_in_exponent = 5,
      p$sign = 6,
      p$suppress_zero = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    VAR
      variable_attributes: array [1 .. 1] of fdt$variable_attribute,
      variable_name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    variable_attributes [1].key := fdc$output_format;
    IF pvt [p$format].value^.keyword_value = 'EE' THEN
      variable_attributes [1].output_format.key := fdc$e_e_output_format;
    ELSE
      variable_attributes [1].output_format.key := fdc$g_e_output_format;
    IFEND;

    variable_attributes [1].output_format.exponent_output_format.field_width :=
          pvt [p$width].value^.integer_value.value;
    variable_attributes [1].output_format.exponent_output_format.digits_in_exponent :=
          pvt [p$digits_in_exponent].value^.integer_value.value;
    variable_attributes [1].output_format.exponent_output_format.digits_right_decimal :=
          pvt [p$digits_right_of_decimal].value^.integer_value.value;
    IF pvt [p$sign].value^.keyword_value = 'MINUS_IF_NEGATIVE' THEN
      variable_attributes [1].output_format.exponent_output_format.sign_treatment := mlc$minus_if_negative;
    ELSE
      variable_attributes [1].output_format.exponent_output_format.sign_treatment := mlc$always_signed;
    IFEND;

    variable_attributes [1].output_format.exponent_output_format.suppress_zero := pvt [p$suppress_zero].
          value^.boolean_value.value;

    IF pvt [p$variable_name].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$variable_name].value^.name_value, form_processor, variable_name);
    ELSE
      variable_name := pvt [p$variable_name].value^.cobol_name_value;
    IFEND;

    fdp$change_variable (current_form_identifier, variable_name, variable_attributes, status);

  PROCEND set_exponent_output;

?? OLDTITLE ??
?? NEWTITLE := 'set_float_output', EJECT ??

{ PURPOSE:
{   This procedure processes the set_float_output command.

  PROCEDURE set_float_output
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_setfo) set_float_output, setfo (
{   variable_name, vn: any of
{       name
{       cobol_name
{     anyend = $required
{   format, f: key
{       f, g, e
{     keyend = $required
{   width, w: integer 1..19 = $required
{   digits_right_of_decimal, drod: integer 0..19 = $required
{   sign, s: key
{       minus_if_negative, always_signed
{     keyend = minus_if_negative
{   suppress_zero, sz: boolean = TRUE
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (17),
      recend,
      type6: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 18, 16, 10, 59, 755],
    clc$command, 13, 7, 4, 0, 0, 0, 7, 'FDM$CREFM_SETFO'], [
    ['DIGITS_RIGHT_OF_DECIMAL        ',clc$nominal_entry, 4],
    ['DROD                           ',clc$abbreviation_entry, 4],
    ['F                              ',clc$abbreviation_entry, 2],
    ['FORMAT                         ',clc$nominal_entry, 2],
    ['S                              ',clc$abbreviation_entry, 5],
    ['SIGN                           ',clc$nominal_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 7],
    ['SUPPRESS_ZERO                  ',clc$nominal_entry, 6],
    ['SZ                             ',clc$abbreviation_entry, 6],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 1],
    ['VN                             ',clc$abbreviation_entry, 1],
    ['W                              ',clc$abbreviation_entry, 3],
    ['WIDTH                          ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$required_parameter, 0, 0],
{ PARAMETER 3
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 4
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 5
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81,
  clc$optional_default_parameter, 0, 17],
{ PARAMETER 6
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 7
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [3], [
    ['E                              ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['F                              ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['G                              ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, 19, 10]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [0, 19, 10]],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [2], [
    ['ALWAYS_SIGNED                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['MINUS_IF_NEGATIVE              ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'minus_if_negative'],
{ PARAMETER 6
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$variable_name = 1,
      p$format = 2,
      p$width = 3,
      p$digits_right_of_decimal = 4,
      p$sign = 5,
      p$suppress_zero = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

    VAR
      variable_attributes: array [1 .. 1] of fdt$variable_attribute,
      variable_name: ost$name;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    variable_attributes [1].key := fdc$output_format;
    IF pvt [p$format].value^.keyword_value = 'F' THEN
      variable_attributes [1].output_format.key := fdc$f_output_format;
    ELSEIF pvt [p$format].value^.keyword_value = 'G' THEN
      variable_attributes [1].output_format.key := fdc$g_output_format;
    ELSE
      variable_attributes [1].output_format.key := fdc$e_output_format;
    IFEND;

    variable_attributes [1].output_format.float_output_format.digits_right_decimal :=
          pvt [p$digits_right_of_decimal].value^.integer_value.value;
    variable_attributes [1].output_format.float_output_format.field_width :=
          pvt [p$width].value^.integer_value.value;
    IF pvt [p$sign].value^.keyword_value = 'MINUS_IF_NEGATIVE' THEN
      variable_attributes [1].output_format.float_output_format.sign_treatment := mlc$minus_if_negative;
    ELSE
      variable_attributes [1].output_format.float_output_format.sign_treatment := mlc$always_signed;
    IFEND;

    variable_attributes [1].output_format.float_output_format.suppress_zero :=
          pvt [p$suppress_zero].value^.boolean_value.value;

    IF pvt [p$variable_name].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$variable_name].value^.name_value, form_processor, variable_name);
    ELSE
      variable_name := pvt [p$variable_name].value^.cobol_name_value;
    IFEND;

    fdp$change_variable (current_form_identifier, variable_name, variable_attributes, status);

  PROCEND set_float_output;

?? OLDTITLE ??
?? NEWTITLE := 'set_form', EJECT ??

{ PURPOSE:
{   This procedure processes the set_form command.

  PROCEDURE set_form
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_setf) set_form, setf (
{   processor, p: key
{       ansi_fortran, cdc_fortran, extended_fortran, cobol, cybil, pascal, scl
{     keyend = cobol
{   column, c: integer 1..fdc$maximum_x_position = 1
{   line, l: integer 1..fdc$maximum_y_position = 1
{   width, w: integer 1..fdc$maximum_x_position = $optional
{   height, h: integer 1..fdc$maximum_y_position = $optional
{   display, displays, d: list of key
{       inverse, low_intensity, high_intensity, blink, black_background, blue_background, green_background
{       magenta_background, red_background, cyan_background, yellow_background, white_background
{       black_foreground, blue_foreground, green_foreground, magenta_foreground, red_foreground
{       cyan_foreground, yellow_foreground, white_foreground, fine_border, medium_border, bold_border
{       display_left_to_right, display_right_to_left
{     keyend = (black_background, white_foreground,display_left_to_right)
{   comment, comments: (BY_NAME) list of string 1..fdc$maximum_comment_length = $optional
{   event_form, ef: (BY_NAME) any of
{       key
{         system, none
{       keyend
{       name
{     anyend = system
{   help_processing, hp: (BY_NAME) any of
{       key
{         system, none
{       keyend
{       name
{       string 0..fdc$maximum_y_position
{     anyend = none
{   error_message_form, emf, message_form, mf: (BY_NAME) any of
{       key
{         system
{       keyend
{       name
{     anyend = system
{   variable_deck_name, vdn: (BY_NAME) name = $optional
{   variable_record_name, vrn: (BY_NAME) any of
{       name
{       cobol_name
{     anyend = $optional
{   invalid_data_character, idc: (BY_NAME) any of
{       key
{         none
{       keyend
{       string 1..1
{     anyend = none
{   help_message_form, hmf: (BY_NAME) any of
{       key
{         system
{       keyend
{       name
{     anyend = system
{   hidden_editing, he: (BY_NAME) boolean = FALSE
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 34] of clt$pdt_parameter_name,
      parameters: array [1 .. 16] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 7] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type6: 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 .. 25] of clt$keyword_specification,
        recend,
        default_value: string (58),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type8: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        default_value: string (6),
      recend,
      type9: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type10: 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$name_type_qualifier,
        recend,
        default_value: string (6),
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type12: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type13: 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$string_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type14: 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$name_type_qualifier,
        recend,
        default_value: string (6),
      recend,
      type15: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type16: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 7, 18, 16, 18, 9, 313],
    clc$command, 34, 16, 0, 0, 0, 0, 16, 'FDM$CREFM_SETF'], [
    ['C                              ',clc$abbreviation_entry, 2],
    ['COLUMN                         ',clc$nominal_entry, 2],
    ['COMMENT                        ',clc$nominal_entry, 7],
    ['COMMENTS                       ',clc$abbreviation_entry, 7],
    ['D                              ',clc$abbreviation_entry, 6],
    ['DISPLAY                        ',clc$nominal_entry, 6],
    ['DISPLAYS                       ',clc$alias_entry, 6],
    ['EF                             ',clc$abbreviation_entry, 8],
    ['EMF                            ',clc$alias_entry, 10],
    ['ERROR_MESSAGE_FORM             ',clc$nominal_entry, 10],
    ['EVENT_FORM                     ',clc$nominal_entry, 8],
    ['H                              ',clc$abbreviation_entry, 5],
    ['HE                             ',clc$abbreviation_entry, 15],
    ['HEIGHT                         ',clc$nominal_entry, 5],
    ['HELP_MESSAGE_FORM              ',clc$nominal_entry, 14],
    ['HELP_PROCESSING                ',clc$nominal_entry, 9],
    ['HIDDEN_EDITING                 ',clc$nominal_entry, 15],
    ['HMF                            ',clc$abbreviation_entry, 14],
    ['HP                             ',clc$abbreviation_entry, 9],
    ['IDC                            ',clc$abbreviation_entry, 13],
    ['INVALID_DATA_CHARACTER         ',clc$nominal_entry, 13],
    ['L                              ',clc$abbreviation_entry, 3],
    ['LINE                           ',clc$nominal_entry, 3],
    ['MESSAGE_FORM                   ',clc$alias_entry, 10],
    ['MF                             ',clc$abbreviation_entry, 10],
    ['P                              ',clc$abbreviation_entry, 1],
    ['PROCESSOR                      ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 16],
    ['VARIABLE_DECK_NAME             ',clc$nominal_entry, 11],
    ['VARIABLE_RECORD_NAME           ',clc$nominal_entry, 12],
    ['VDN                            ',clc$abbreviation_entry, 11],
    ['VRN                            ',clc$abbreviation_entry, 12],
    ['W                              ',clc$abbreviation_entry, 4],
    ['WIDTH                          ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [27, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 266,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [34, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 5
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 948,
  clc$optional_default_parameter, 0, 58],
{ PARAMETER 7
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 24, clc$optional_parameter,
  0, 0],
{ PARAMETER 8
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 106,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 9
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 10
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 11
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 12
    [30, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$optional_parameter,
  0, 0],
{ PARAMETER 13
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 72,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 14
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 15
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 16
    [28, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [7], [
    ['ANSI_FORTRAN                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['CDC_FORTRAN                    ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['COBOL                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['CYBIL                          ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['EXTENDED_FORTRAN               ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['PASCAL                         ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['SCL                            ', clc$nominal_entry, clc$normal_usage_entry, 7]]
    ,
    'cobol'],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, fdc$maximum_x_position, 10],
    '1'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, fdc$maximum_y_position, 10],
    '1'],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [1, fdc$maximum_x_position, 10]],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [1, fdc$maximum_y_position, 10]],
{ PARAMETER 6
    [[1, 0, clc$list_type], [932, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [25], [
      ['BLACK_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['BLACK_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['BLINK                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['BLUE_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['BLUE_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['BOLD_BORDER                    ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['CYAN_BACKGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['CYAN_FOREGROUND                ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['DISPLAY_LEFT_TO_RIGHT          ', clc$nominal_entry, clc$normal_usage_entry, 24],
      ['DISPLAY_RIGHT_TO_LEFT          ', clc$nominal_entry, clc$normal_usage_entry, 25],
      ['FINE_BORDER                    ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['GREEN_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['GREEN_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['HIGH_INTENSITY                 ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['INVERSE                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['LOW_INTENSITY                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['MAGENTA_BACKGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['MAGENTA_FOREGROUND             ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['MEDIUM_BORDER                  ', clc$nominal_entry, clc$normal_usage_entry, 22],
      ['RED_BACKGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['RED_FOREGROUND                 ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['WHITE_BACKGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['WHITE_FOREGROUND               ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['YELLOW_BACKGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['YELLOW_FOREGROUND              ', clc$nominal_entry, clc$normal_usage_entry, 19]]
      ]
    ,
    '(black_background, white_foreground,display_left_to_right)'],
{ PARAMETER 7
    [[1, 0, clc$list_type], [8, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$string_type], [1, fdc$maximum_comment_length, FALSE]]
    ],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'system'],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type, clc$string_type],
    FALSE, 3],
    81, [[1, 0, clc$keyword_type], [2], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    8, [[1, 0, clc$string_type], [0, fdc$maximum_y_position, FALSE]]
    ,
    'none'],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'system'],
{ PARAMETER 11
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 12
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 13
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$string_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [1, 1, FALSE]]
    ,
    'none'],
{ PARAMETER 14
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'system'],
{ PARAMETER 15
    [[1, 0, clc$boolean_type],
    'FALSE'],
{ PARAMETER 16
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$processor = 1,
      p$column = 2,
      p$line = 3,
      p$width = 4,
      p$height = 5,
      p$display = 6,
      p$comment = 7,
      p$event_form = 8,
      p$help_processing = 9,
      p$error_message_form = 10,
      p$variable_deck_name = 11,
      p$variable_record_name = 12,
      p$invalid_data_character = 13,
      p$help_message_form = 14,
      p$hidden_editing = 15,
      p$status = 16;

    VAR
      pvt: array [1 .. 16] of clt$parameter_value;

    CONST
      processor_attribute = 1,
      area_attribute = 2,
      display_attribute = 3,
      event_form_attribute = 4,
      help_attribute = 5,
      error_message_form_attribute = 6,
      invalid_data_attribute = 7,
      help_message_form_attribute = 8,
      hidden_editing_attribute =9,
      comment_attribute = 10;

    VAR
      comment: comment_attribute .. clc$max_list_size + comment_attribute,
      form_attributes_p: ^array [1 .. * ] of fdt$form_attribute,
      list_size: clt$list_size,
      local_status: ost$status,
      next_data_value_p: ^clt$data_value,
      record_attributes: array [1 .. 2] of fdt$record_attribute;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    list_size := clp$count_list_elements (pvt [p$comment].value);
    PUSH form_attributes_p: [1 .. list_size + hidden_editing_attribute];
    form_attributes_p^ [processor_attribute].key := fdc$form_processor;
    IF (pvt [p$processor].value^.keyword_value = 'COBOL') THEN
      form_attributes_p^ [processor_attribute].form_processor := fdc$cobol_processor;
    ELSEIF (pvt [p$processor].value^.keyword_value = 'CDC_FORTRAN') THEN
      form_attributes_p^ [processor_attribute].form_processor := fdc$cdc_fortran_processor;
    ELSEIF (pvt [p$processor].value^.keyword_value = 'ANSI_FORTRAN') THEN
      form_attributes_p^ [processor_attribute].form_processor := fdc$ansi_fortran_processor;
    ELSEIF (pvt [p$processor].value^.keyword_value = 'EXTENDED_FORTRAN') THEN
      form_attributes_p^ [processor_attribute].form_processor := fdc$extended_fortran_processor;
    ELSEIF (pvt [p$processor].value^.keyword_value = 'CYBIL') THEN
      form_attributes_p^ [processor_attribute].form_processor := fdc$cybil_processor;
    ELSEIF (pvt [p$processor].value^.keyword_value = 'PASCAL') THEN
      form_attributes_p^ [processor_attribute].form_processor := fdc$pascal_processor;
    ELSE
      form_attributes_p^ [processor_attribute].form_processor := fdc$scl_processor;
    IFEND;

    form_processor := form_attributes_p^ [processor_attribute].form_processor;

    form_attributes_p^ [area_attribute].key := fdc$form_area;
    IF (((pvt [p$column].specified) AND (pvt [p$column].value^.integer_value.value <> 1)) OR
          ((pvt [p$line].specified) AND (pvt [p$line].value^.integer_value.value <> 1))) THEN
      IF ((NOT pvt [p$width].specified) AND (NOT pvt [p$height].specified)) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$width_and_height_required,
              current_form_name, status);
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$width].specified THEN
      form_attributes_p^ [area_attribute].form_area.key := fdc$defined_area;
      form_attributes_p^ [area_attribute].form_area.x_position := pvt [p$column].value^.integer_value.value;
      form_attributes_p^ [area_attribute].form_area.y_position := pvt [p$line].value^.integer_value.value;
      form_attributes_p^ [area_attribute].form_area.width := pvt [p$width].value^.integer_value.value;
      form_attributes_p^ [area_attribute].form_area.height := pvt [p$height].value^.integer_value.value
    ELSE
      form_attributes_p^ [area_attribute].form_area.key := fdc$screen_area;
    IFEND;

    form_attributes_p^ [display_attribute].key := fdc$form_display_attribute;
    process_attributes (pvt [p$display].value, form_attributes_p^ [display_attribute].form_display_attribute,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    form_attributes_p^ [event_form_attribute].key := fdc$event_form;
    IF pvt [p$event_form].value^.kind = clc$keyword THEN
      IF (pvt [p$event_form].value^.keyword_value = 'SYSTEM') THEN
        form_attributes_p^ [event_form_attribute].event_form_definition.key := fdc$system_default_event_form;
      ELSE
        form_attributes_p^ [event_form_attribute].event_form_definition.key := fdc$no_event_form;
      IFEND;

    ELSE
      form_attributes_p^ [event_form_attribute].event_form_definition.key := fdc$user_event_form;
      form_attributes_p^ [event_form_attribute].event_form_definition.event_form_name :=
            pvt [p$event_form].value^.name_value;
    IFEND;

    form_attributes_p^ [help_attribute].key := fdc$form_help;
    CASE pvt [p$help_processing].value^.kind OF

    = clc$keyword =
      IF (pvt [p$help_processing].value^.keyword_value = 'SYSTEM') THEN
        form_attributes_p^ [help_attribute].form_help.key := fdc$system_default_help
      ELSE
        form_attributes_p^ [help_attribute].form_help.key := fdc$no_help_response;
      IFEND;

    = clc$name =
      form_attributes_p^ [help_attribute].form_help.key := fdc$help_form;
      form_attributes_p^ [help_attribute].form_help.help_form := pvt [p$help_processing].value^.name_value;

    ELSE
      form_attributes_p^ [help_attribute].form_help.key := fdc$help_message;
      form_attributes_p^ [help_attribute].form_help.p_help_message :=
            pvt [p$help_processing].value^.string_value;
    CASEND;

    form_attributes_p^ [error_message_form_attribute].key := fdc$error_message_form;
    IF pvt [p$error_message_form].value^.kind = clc$keyword THEN
      form_attributes_p^ [error_message_form_attribute].error_message_form := osc$null_name;
    ELSE
      form_attributes_p^ [error_message_form_attribute].error_message_form :=
            pvt [p$error_message_form].value^.name_value;
    IFEND;

    IF pvt [p$invalid_data_character].value^.kind = clc$keyword THEN
      form_attributes_p^ [invalid_data_attribute].key := fdc$invalid_data_character;
      form_attributes_p^ [invalid_data_attribute].invalid_data_character.defined := FALSE;
    ELSE
      form_attributes_p^ [invalid_data_attribute].key := fdc$invalid_data_character;
      form_attributes_p^ [invalid_data_attribute].invalid_data_character.defined := TRUE;
      form_attributes_p^ [invalid_data_attribute].invalid_data_character.character :=
               pvt[p$invalid_data_character].value^.string_value^(1);
    IFEND;

    form_attributes_p^ [help_message_form_attribute].key := fdc$help_message_form;
    IF pvt [p$help_message_form].value^.kind = clc$keyword THEN
      form_attributes_p^ [help_message_form_attribute].message_form := osc$null_name;
    ELSE
      form_attributes_p^ [help_message_form_attribute].help_message_form :=
            pvt [p$help_message_form].value^.name_value;
    IFEND;

    form_attributes_p^ [hidden_editing_attribute].key := fdc$hidden_editing;
    form_attributes_p^ [hidden_editing_attribute].hidden_editing :=
          pvt [p$hidden_editing].value^.boolean_value.value;

{ Process one or more comments.

    next_data_value_p := pvt [p$comment].value;

  /get_comment/
    FOR comment := comment_attribute TO UPPERBOUND (form_attributes_p^) DO
      form_attributes_p^ [comment].key := fdc$add_form_comment;
      form_attributes_p^ [comment].p_form_comment := next_data_value_p^.element_value^.string_value;
      next_data_value_p := next_data_value_p^.link;
    FOREND /get_comment/;

    fdp$change_form (current_form_identifier, form_attributes_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$variable_deck_name].specified THEN
      record_attributes [1].key := fdc$record_deck_name;
      record_attributes [1].record_deck_name := pvt [p$variable_deck_name].value^.name_value;
    ELSE
      record_attributes [1].key := fdc$unused_record_entry;
    IFEND;

    IF pvt [p$variable_record_name].specified THEN
      record_attributes [2].key := fdc$record_name;
      record_attributes [2].record_name := pvt [p$variable_record_name].value^.name_value;
    ELSE
      record_attributes [2].key := fdc$unused_record_entry;
    IFEND;

    IF (pvt [p$variable_deck_name].specified OR pvt [p$variable_record_name].specified) THEN
      fdp$change_form_record (current_form_identifier, record_attributes, status);
    IFEND;

  PROCEND set_form;

?? OLDTITLE ??
?? NEWTITLE := 'set_integer_input', EJECT ??

{ PURPOSE:
{   This procedure processes the set_integer_input command.

  PROCEDURE set_integer_input
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_setii) set_integer_input, setii (
{   variable_name, vn: any of
{       name
{       cobol_name
{     anyend = $required
{   valid_value, valid_values, vv: list 0..fdc$maximum_valid_ranges of range of integer = $optional
{   entry_format, ef: key
{       digits, signed
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$range_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 19, 13, 47, 11, 147],
    clc$command, 8, 4, 1, 0, 0, 0, 4, 'FDM$CREFM_SETII'], [
    ['EF                             ',clc$abbreviation_entry, 3],
    ['ENTRY_FORMAT                   ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['VALID_VALUE                    ',clc$nominal_entry, 2],
    ['VALID_VALUES                   ',clc$alias_entry, 2],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 1],
    ['VN                             ',clc$abbreviation_entry, 1],
    ['VV                             ',clc$abbreviation_entry, 2]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 43, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [27, 0, fdc$maximum_valid_ranges, FALSE],
      [[1, 0, clc$range_type], [20],
        [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [2], [
    ['DIGITS                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['SIGNED                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$variable_name = 1,
      p$valid_value = 2,
      p$entry_format = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      list_size: clt$list_size,
      next_data_value_p: ^clt$data_value,
      valid_value: 2 .. clc$max_list_size + 1,
      variable_attributes_p: ^array [1 .. * ] of fdt$variable_attribute,
      variable_name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    list_size := clp$count_list_elements (pvt [p$valid_value].value);
    PUSH variable_attributes_p: [1 .. list_size + 1];

    IF pvt [p$entry_format].specified THEN
      variable_attributes_p^ [1].key := fdc$input_format;
      IF pvt [p$entry_format].value^.keyword_value = 'DIGITS' THEN
        variable_attributes_p^ [1].input_format.key := fdc$digits_input_format;
      ELSE
        variable_attributes_p^ [1].input_format.key := fdc$signed_input_format;
      IFEND;
    ELSE
      variable_attributes_p^ [1].key := fdc$unused_variable_entry;
    IFEND;

    next_data_value_p := pvt [p$valid_value].value;

  /get_valid_integer/
    FOR valid_value := 2 TO list_size + 1 DO
      variable_attributes_p^ [valid_value].key := fdc$add_valid_integer_range;
      variable_attributes_p^ [valid_value].maximum_integer :=
            next_data_value_p^.element_value^.high_value^.integer_value.value;
      variable_attributes_p^ [valid_value].minimum_integer := next_data_value_p^.element_value^.low_value^.
            integer_value.value;
      next_data_value_p := next_data_value_p^.link;
    FOREND /get_valid_integer/;

    IF pvt [p$variable_name].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$variable_name].value^.name_value, form_processor, variable_name);
    ELSE
      variable_name := pvt [p$variable_name].value^.cobol_name_value;
    IFEND;

    fdp$change_variable (current_form_identifier, variable_name, variable_attributes_p^, status);

  PROCEND set_integer_input;

?? OLDTITLE ??
?? NEWTITLE := 'set_integer_output', EJECT ??

{ PURPOSE:
{   This procedure processes the set_integer_output command.

  PROCEDURE set_integer_output
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_setio) set_integer_output, setio (
{   variable_name, vn: any of
{       name
{       cobol_name
{     anyend = $required
{   width, w: integer 1..19 = $required
{   minimum_digit, minimum_digits, md: integer 0..19 = 0
{   sign, s: key
{       minus_if_negative, always_signed
{     keyend = minus_if_negative
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (17),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 18, 16, 11, 56, 746],
    clc$command, 10, 5, 2, 0, 0, 0, 5, 'FDM$CREFM_SETIO'], [
    ['MD                             ',clc$abbreviation_entry, 3],
    ['MINIMUM_DIGIT                  ',clc$nominal_entry, 3],
    ['MINIMUM_DIGITS                 ',clc$alias_entry, 3],
    ['S                              ',clc$abbreviation_entry, 4],
    ['SIGN                           ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 1],
    ['VN                             ',clc$abbreviation_entry, 1],
    ['W                              ',clc$abbreviation_entry, 2],
    ['WIDTH                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81,
  clc$optional_default_parameter, 0, 17],
{ PARAMETER 5
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, 19, 10]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, 19, 10],
    '0'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [2], [
    ['ALWAYS_SIGNED                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['MINUS_IF_NEGATIVE              ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'minus_if_negative'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$variable_name = 1,
      p$width = 2,
      p$minimum_digit = 3,
      p$sign = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      list_size: clt$list_size,
      variable_attributes: array [1 .. 1] of fdt$variable_attribute,
      variable_name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    variable_attributes [1].key := fdc$output_format;
    variable_attributes [1].output_format.key := fdc$integer_output_format;
    variable_attributes [1].output_format.integer_output_format.field_width :=
          pvt [p$width].value^.integer_value.value;
    variable_attributes [1].output_format.integer_output_format.minimum_output_digits :=
          pvt [p$minimum_digit].value^.integer_value.value;
    IF pvt [p$sign].value^.keyword_value = 'MINUS_IF_NEGATIVE' THEN
      variable_attributes [1].output_format.integer_output_format.sign_treatment := mlc$minus_if_negative;
    ELSE
      variable_attributes [1].output_format.integer_output_format.sign_treatment := mlc$always_signed;
    IFEND;


    IF pvt [p$variable_name].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$variable_name].value^.name_value, form_processor, variable_name);
    ELSE
      variable_name := pvt [p$variable_name].value^.cobol_name_value;
    IFEND;

    fdp$change_variable (current_form_identifier, variable_name, variable_attributes, status);

  PROCEND set_integer_output;

?? OLDTITLE ??
?? NEWTITLE := 'set_money_input', EJECT ??

{ PURPOSE:
{   This procedure processes the set_money_input command.

  PROCEDURE set_money_input
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_setmi) set_money_input, setmi (
{   variable_name, vn: any of
{       name
{       cobol_name
{     anyend = $required
{   money_symbol, ms: string 1 = '$'
{   thousands_separator, ts: string 1 = ','
{   decimal_point, dp: string 1 = '.'
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (3),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 10, 23, 16, 46, 27, 738],
    clc$command, 9, 5, 1, 0, 0, 0, 5, 'FDM$CREFM_SETMI'], [
    ['DECIMAL_POINT                  ',clc$nominal_entry, 4],
    ['DP                             ',clc$abbreviation_entry, 4],
    ['MONEY_SYMBOL                   ',clc$nominal_entry, 2],
    ['MS                             ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['THOUSANDS_SEPARATOR            ',clc$nominal_entry, 3],
    ['TS                             ',clc$abbreviation_entry, 3],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 1],
    ['VN                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 5
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 1, FALSE],
    '''$'''],
{ PARAMETER 3
    [[1, 0, clc$string_type], [1, 1, FALSE],
    ''','''],
{ PARAMETER 4
    [[1, 0, clc$string_type], [1, 1, FALSE],
    '''.'''],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$variable_name = 1,
      p$money_symbol = 2,
      p$thousands_separator = 3,
      p$decimal_point = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      variable_attributes: array [1 .. 1] of fdt$variable_attribute,
      variable_name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    variable_attributes [1].key := fdc$input_format;
    variable_attributes [1].input_format.key := fdc$currency_input_format;
    variable_attributes [1].input_format.input_currency_format.currency_sybmol :=
          pvt [p$money_symbol].value^.string_value^;
    variable_attributes [1].input_format.input_currency_format.thousands_separator :=
          pvt [p$thousands_separator].value^.string_value^;
    variable_attributes [1].input_format.input_currency_format.decimal_point :=
          pvt [p$decimal_point].value^.string_value^;

    IF pvt [p$variable_name].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$variable_name].value^.name_value, form_processor, variable_name);

    ELSE
      variable_name := pvt [p$variable_name].value^.cobol_name_value;
    IFEND;

    fdp$change_variable (current_form_identifier, variable_name, variable_attributes, status);

  PROCEND set_money_input;

?? OLDTITLE ??
?? NEWTITLE := 'set_money_output', EJECT ??

{ PURPOSE:
{   This procedure processes the set_money_output command.

  PROCEDURE set_money_output
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_setmo) set_money_output, setmo (
{   variable_name, vn: any of
{       name
{       cobol_name
{     anyend = $required
{   money_symbol, ms: string 1 = '$'
{   thousands_separator, ts: string 1 = ','
{   decimal_point, dp: string 1 = '.'
{   sign, s: key
{       minus_if_negative, always_signed
{     keyend = minus_if_negative
{   suppress_zero, sz: boolean = TRUE
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (3),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (17),
      recend,
      type6: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 10, 23, 16, 51, 31, 208],
    clc$command, 13, 7, 1, 0, 0, 0, 7, 'FDM$CREFM_SETMO'], [
    ['DECIMAL_POINT                  ',clc$nominal_entry, 4],
    ['DP                             ',clc$abbreviation_entry, 4],
    ['MONEY_SYMBOL                   ',clc$nominal_entry, 2],
    ['MS                             ',clc$abbreviation_entry, 2],
    ['S                              ',clc$abbreviation_entry, 5],
    ['SIGN                           ',clc$nominal_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 7],
    ['SUPPRESS_ZERO                  ',clc$nominal_entry, 6],
    ['SZ                             ',clc$abbreviation_entry, 6],
    ['THOUSANDS_SEPARATOR            ',clc$nominal_entry, 3],
    ['TS                             ',clc$abbreviation_entry, 3],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 1],
    ['VN                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 5
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81,
  clc$optional_default_parameter, 0, 17],
{ PARAMETER 6
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 7
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 1, FALSE],
    '''$'''],
{ PARAMETER 3
    [[1, 0, clc$string_type], [1, 1, FALSE],
    ''','''],
{ PARAMETER 4
    [[1, 0, clc$string_type], [1, 1, FALSE],
    '''.'''],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [2], [
    ['ALWAYS_SIGNED                  ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['MINUS_IF_NEGATIVE              ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'minus_if_negative'],
{ PARAMETER 6
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$variable_name = 1,
      p$money_symbol = 2,
      p$thousands_separator = 3,
      p$decimal_point = 4,
      p$sign = 5,
      p$suppress_zero = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

    VAR
      variable_attributes: array [1 .. 1] of fdt$variable_attribute,
      variable_name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    variable_attributes [1].key := fdc$output_format;
    variable_attributes [1].output_format.key := fdc$currency_output_format;
    variable_attributes [1].output_format.output_currency_format.currency_sybmol := pvt [p$money_symbol].
          value^.string_value^;
    variable_attributes [1].output_format.output_currency_format.thousands_separator :=
          pvt [p$thousands_separator].value^.string_value^;
    variable_attributes [1].output_format.output_currency_format.decimal_point := pvt [p$decimal_point].
          value^.string_value^;
    variable_attributes [1].output_format.output_currency_format.suppress_leading_zeros :=
          pvt [p$suppress_zero].value^.boolean_value.value;
    IF pvt [p$sign].value^.keyword_value = 'MINUS_IF_NEGATIVE' THEN
      variable_attributes [1].output_format.output_currency_format.sign_treatment := mlc$minus_if_negative;
    ELSE
      variable_attributes [1].output_format.output_currency_format.sign_treatment := mlc$always_signed;
    IFEND;

    IF pvt [p$variable_name].value^.kind = clc$name THEN

      convert_to_form_name (pvt [p$variable_name].value^.name_value, form_processor, variable_name);
    ELSE
      variable_name := pvt [p$variable_name].value^.cobol_name_value;
    IFEND;

    fdp$change_variable (current_form_identifier, variable_name, variable_attributes, status);

  PROCEND set_money_output;

?? OLDTITLE ??
?? NEWTITLE := 'set_real_input', EJECT ??

{ PURPOSE:
{   This procedure processes the set_real_input command.

  PROCEDURE set_real_input
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_setri) set_real_input, setri (
{   variable_name, vn: any of
{       name
{       cobol_name
{     anyend = $required
{   valid_value, valid_values, vv: list 1..fdc$maximum_valid_ranges of range of real = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$range_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$real_type_qualifier,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 22, 11, 43, 35, 889],
    clc$command, 6, 3, 1, 0, 0, 0, 3, 'FDM$CREFM_SETRI'], [
    ['STATUS                         ',clc$nominal_entry, 3],
    ['VALID_VALUE                    ',clc$nominal_entry, 2],
    ['VALID_VALUES                   ',clc$alias_entry, 2],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 1],
    ['VN                             ',clc$abbreviation_entry, 1],
    ['VV                             ',clc$abbreviation_entry, 2]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 28, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 58, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$cobol_name_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    3, [[1, 0, clc$cobol_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [42, 1, fdc$maximum_valid_ranges, FALSE],
      [[1, 0, clc$range_type], [35],
        [[1, 0, clc$real_type],
        [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
        [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]]
        ]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$variable_name = 1,
      p$valid_value = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      list_size: clt$list_size,
      long_real_record: fdt$long_real_record,
      next_data_value_p: ^clt$data_value,
      valid_value: 1 .. clc$max_list_size,
      variable_attributes_p: ^array [1 .. * ] of fdt$variable_attribute,
      variable_name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    list_size := clp$count_list_elements (pvt [p$valid_value].value);
    PUSH variable_attributes_p: [1 .. list_size];

    next_data_value_p := pvt [p$valid_value].value;

  /get_valid_real/
    FOR valid_value := 1 TO list_size DO
      variable_attributes_p^ [valid_value].key := fdc$add_valid_real_range;
      #UNCHECKED_CONVERSION (next_data_value_p^.element_value^.high_value^.real_value.value,
            long_real_record);
      variable_attributes_p^ [valid_value].maximum_real := long_real_record.first_real;
      #UNCHECKED_CONVERSION (next_data_value_p^.element_value^.low_value^.real_value.value, long_real_record);
      variable_attributes_p^ [valid_value].minimum_real := long_real_record.first_real;
      next_data_value_p := next_data_value_p^.link;
    FOREND /get_valid_real/;

    IF pvt [p$variable_name].value^.kind = clc$name THEN
      convert_to_form_name (pvt [p$variable_name].value^.name_value, form_processor, variable_name);
    ELSE
      variable_name := pvt [p$variable_name].value^.cobol_name_value;
    IFEND;

    fdp$change_variable (current_form_identifier, variable_name, variable_attributes_p^, status);

  PROCEND set_real_input;

?? OLDTITLE ??
?? NEWTITLE := 'end_form_module', EJECT ??

{ PURPOSE:
{   This procedure processes the end_form_module command.

  PROCEDURE end_form_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$crefm_endfm) end_form_module, endfm, quit, qui (
{   create_module, cm: boolean = yes
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 18, 16, 13, 23, 274],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'FDM$CREFM_ENDFM'], [
    ['CM                             ',clc$abbreviation_entry, 1],
    ['CREATE_MODULE                  ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type],
    'yes'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$create_module = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_form := pvt [p$create_module].value^.boolean_value.value;
    clp$end_include (utility_name, status);

  PROCEND end_form_module;

?? OLDTITLE ??
?? NEWTITLE := 'convert_to_form_name', EJECT ??

{ PURPOSE:
{   This procedure converts the name appearing in the command to the name
{   appropriate for the form language.
{
{ DESIGN:
{   Allow forms with a COBOL processor to be used under the SCL interface.
{   The SCL interface allows users to quickly prototype applications.
{   Convert the SCL name to the name used on the form.

  PROCEDURE [INLINE] convert_to_form_name
    (    name: ost$name;
         form_processor: fdt$form_processor;
     VAR form_name: ost$name);

    IF form_processor = fdc$cobol_processor THEN
      #TRANSLATE (to_cobol, name, form_name);
    ELSE
      form_name := name;
    IFEND;

  PROCEND convert_to_form_name;

?? OLDTITLE ??
?? NEWTITLE := 'convert_to_scl_name', EJECT ??

{ PURPOSE:
{   This procedure converts the name defined for the form language to a
{   SCL name.
{
{ DESIGN:
{   Allow forms with a COBOL processor to be used under the SCL interface.
{   The SCL interface allows users to quickly prototype applications.
{   Convert the name used on the form to an SCL name.

  PROCEDURE [INLINE] convert_to_scl_name
    (    name: ost$name;
         form_processor: fdt$form_processor;
     VAR scl_name: ost$name);

    IF form_processor = fdc$cobol_processor THEN
      #TRANSLATE (to_scl, name, scl_name);
    ELSE
      scl_name := name;
    IFEND;

  PROCEND convert_to_scl_name;

?? OLDTITLE ??
?? NEWTITLE := 'display_form_errors', EJECT ??

{ PURPOSE:
{   This procedure displays form errors.

  PROCEDURE display_form_errors
    (VAR errors_p: ^SEQ ( * );
     VAR display_status: ost$status);

    VAR
      error_input_conversion_p: ^fdt$error_input_conversion,
      error_invalid_value_p: ^fdt$error_invalid_value,
      error_header_p: ^fdt$error_header,
      error_no_table_object_p: ^fdt$error_no_table_object,
      error_no_table_variable_p: ^fdt$error_no_table_variable,
      error_no_variable_def_p: ^fdt$error_no_variable_def,
      error_no_variable_object_p: ^fdt$error_no_variable_object,
      error_output_conversion_p: ^fdt$error_output_conversion,
      error_unequal_tbl_obj_width_p: ^fdt$error_unequal_tbl_obj_width,
      local_status: ost$status,
      status: ost$status;

    display_status.normal := TRUE;
    RESET errors_p;
    NEXT error_header_p IN errors_p;

{ Unpack error message from sequence and display it.

    WHILE error_header_p <> NIL DO
      CASE error_header_p^.key OF

      = fdc$no_variable_definition =
        NEXT error_no_variable_def_p IN errors_p;
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_variable_definition, current_form_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, error_no_variable_def_p^.variable_name,
              status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (error_no_variable_def_p^.occurrence), 10, FALSE, status);
        osp$generate_error_message (status, local_status);

      = fdc$no_table_variable =
        NEXT error_no_table_variable_p IN errors_p;
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_table_variable, current_form_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, error_no_table_variable_p^.table_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, error_no_table_variable_p^.variable_name,
              status);
        osp$generate_error_message (status, local_status);

      = fdc$no_variable_object =
        NEXT error_no_variable_object_p IN errors_p;
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_variable_object, current_form_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              error_no_variable_object_p^.variable_name, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (error_no_variable_object_p^.occurrence), 10, FALSE, status);
        osp$generate_error_message (status, local_status);

      = fdc$no_table_object =
        NEXT error_no_table_object_p IN errors_p;
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_table_object, current_form_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, error_no_table_object_p^.table_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, error_no_table_object_p^.variable_name,
              status);
        osp$generate_error_message (status, local_status);

      = fdc$unequal_tbl_obj_width =
        NEXT error_unequal_tbl_obj_width_p IN errors_p;
        osp$set_status_abnormal (fdc$format_display_identifier, fde$unequal_tbl_obj_width, current_form_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              error_unequal_tbl_obj_width_p^.table_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              error_unequal_tbl_obj_width_p^.variable_name, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (error_unequal_tbl_obj_width_p^.occurrence), 10, FALSE, status);
        osp$generate_error_message (status, local_status);

      = fdc$error_input_conversion =
        NEXT error_input_conversion_p IN errors_p;
        osp$set_status_abnormal (fdc$format_display_identifier, fde$error_input_conversion, current_form_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, error_input_conversion_p^.variable_name,
              status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (error_input_conversion_p^.occurrence), 10, FALSE, status);
        osp$generate_error_message (status, local_status);

      = fdc$error_output_conversion =
        NEXT error_output_conversion_p IN errors_p;
        osp$set_status_abnormal (fdc$format_display_identifier, fde$error_output_conversion,
              current_form_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, error_output_conversion_p^.variable_name,
              status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (error_output_conversion_p^.occurrence), 10, FALSE, status);
        osp$generate_error_message (status, local_status);

      = fdc$error_invalid_value =
        NEXT error_invalid_value_p IN errors_p;
        osp$set_status_abnormal (fdc$format_display_identifier, fde$error_invalid_value, current_form_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, error_invalid_value_p^.variable_name,
              status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (error_invalid_value_p^.occurrence), 10, FALSE, status);
        osp$generate_error_message (status, local_status);

      ELSE
        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'invalid error value',
              display_status);
        RETURN;
      CASEND;

      NEXT error_header_p IN errors_p;

    WHILEND;
  PROCEND display_form_errors;

?? OLDTITLE ??
?? NEWTITLE := 'process_attributes', EJECT ??

{ PURPOSE:
{   Convert key word specified in display attribute to Screen Formatting
{   ordinal.

  PROCEDURE process_attributes
    (    data_value_p: ^clt$data_value;
     VAR display_attribute_set: fdt$display_attribute_set;
     VAR status: ost$status);

    TYPE
      attribute_translation = record
        attribute_name: ost$name,
        display_attribute: fdt$display_attribute,
      recend;

    CONST
      attribute_maximum = 36;

    VAR
      attribute: 1 .. attribute_maximum,
      convert_attribute: [READ] array [1 .. attribute_maximum] of attribute_translation :=

{ Place most frequently used attributes at the beginning of the array.

      [['ITALIC', fdc$italic_display_attribute], ['TITLE', fdc$title_display_attribute],
            ['INPUT', fdc$input_display_attribute], ['ERROR', fdc$error_display_attribute],
            ['MESSAGE', fdc$message_display_attribute], ['INVERSE', fdc$inverse_video],
            ['LOW_INTENSITY', fdc$low_intensity], ['HIGH_INTENSITY', fdc$high_intensity],
            ['BLINK', fdc$blink], ['UNDERLINE', fdc$underline], ['PROTECT', fdc$protect],
            ['HIDDEN', fdc$hidden], ['BLACK_FOREGROUND', fdc$black_foreground],
            ['BLACK_BACKGROUND', fdc$black_background], ['BLUE_FOREGROUND', fdc$blue_foreground],
            ['BLUE_BACKGROUND', fdc$blue_background], ['GREEN_FOREGROUND', fdc$green_foreground],
            ['GREEN_BACKGROUND', fdc$green_background], ['MAGENTA_FOREGROUND', fdc$magenta_foreground],
            ['MAGENTA_BACKGROUND', fdc$magenta_background], ['RED_FOREGROUND', fdc$red_foreground],
            ['RED_BACKGROUND', fdc$red_background], ['CYAN_FOREGROUND', fdc$cyan_foreground],
            ['CYAN_BACKGROUND', fdc$cyan_background], ['YELLOW_FOREGROUND', fdc$yellow_foreground],
            ['YELLOW_BACKGROUND', fdc$yellow_background], ['WHITE_FOREGROUND', fdc$white_foreground],
            ['WHITE_BACKGROUND', fdc$white_background], ['FINE_LINE', fdc$fine_line],
            ['MEDIUM_LINE', fdc$medium_line], ['BOLD_LINE', fdc$bold_line], ['FINE_BORDER', fdc$fine_border],
            ['MEDIUM_BORDER', fdc$medium_border], ['BOLD_BORDER', fdc$bold_border],
            ['DISPLAY_LEFT_TO_RIGHT', fdc$display_left_to_right],
            ['DISPLAY_RIGHT_TO_LEFT', fdc$display_right_to_left]],
      keyword: clt$keyword,
      list: clt$list_size,
      list_size: clt$list_size,
      next_data_value_p: ^clt$data_value;

    status.normal := TRUE;
    display_attribute_set := $fdt$display_attribute_set [];
    list_size := clp$count_list_elements (data_value_p);
    next_data_value_p := data_value_p;

  /get_next_attribute/
    FOR list := 1 TO list_size DO
      keyword := next_data_value_p^.element_value^.keyword_value;

{ Convert key word attribute to Screen Formatting ordinal attribute.

    /find_attribute/
      FOR attribute := LOWERBOUND (convert_attribute) TO UPPERBOUND (convert_attribute) DO
        IF (keyword = convert_attribute [attribute].attribute_name) THEN
          display_attribute_set := display_attribute_set + $fdt$display_attribute_set
                [convert_attribute [attribute].display_attribute];
          next_data_value_p := next_data_value_p^.link;
          CYCLE /get_next_attribute/;
        IFEND;
      FOREND /find_attribute/;

      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'invalid display attribute',
            status);
      RETURN;
    FOREND /get_next_attribute/;

  PROCEND process_attributes;

MODEND fdm$create_form_module;

*DECK DECK=FDM$CREATE_MESSAGE_FORM EXPAND=TRUE

?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Screen Formatting:  Create message form' ??
MODULE fdm$create_message_form;

{ PURPOSE:
{   This module creates the message form used to displaying help and error
{ messages.
{
{ DESIGN:
{   Use Screen Formatting procedures to define a form.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc cyd$run_time_error_condition
?? POP ??

*copyc fdc$message_form_name
*copyc fdc$message_variable_length
*copyc fdc$message_visible_length

*copyc fdp$close_form
*copyc fdp$create_form
*copyc fdp$create_object
*copyc fdp$create_variable
*copyc fdp$end_form
*copyc fdv$message_variable_name
*copyc osp$set_status_abnormal

?? TITLE := 'fdp$create_message_form', EJECT ??
*copyc fdh$create_message_form

  PROCEDURE [XDCL] fdp$create_message_form
    (VAR form_identifier: fdt$form_identifier;
     VAR status: ost$status);

    VAR
      form_attributes: array [1 .. 8] of fdt$form_attribute,
      initial_value: string (1),
      local_status: ost$status,
      number_errors: fdt$number_errors,
      object_definition: fdt$object_definition,
      object_attributes: array [1 .. 1] of fdt$object_attribute,
      p_errors: ^SEQ ( * ),
      variable_attributes: array [1 .. 3] of fdt$variable_attribute;

    status.normal := TRUE;

{ Create form definition.  Define paging events so that terminal user
{ may see messages longer than the visible size of the variable text.
{ Specify a border around the form so that the terminal user easily
{ sees the context of the form and notes the message.

    form_attributes [1].key := fdc$form_area;
    form_attributes [1].form_area.key := fdc$defined_area;
    form_attributes [1].form_area.x_position := 2;
    form_attributes [1].form_area.y_position := 1;
    form_attributes [1].form_area.height := 3;
    form_attributes [1].form_area.width := 78;
    form_attributes [2].key := fdc$form_display_attribute;
    form_attributes [2].form_display_attribute := $fdt$display_attribute_set
          [fdc$medium_border, fdc$black_background, fdc$white_foreground];
    form_attributes [3].key := fdc$add_event;
    form_attributes [3].event_name := 'FWD';
    form_attributes [3].event_label := 'Fwd';
    form_attributes [3].event_trigger := fdc$forward;
    form_attributes [3].event_action := fdc$page_variable_forward;
    form_attributes [4].key := fdc$add_event;
    form_attributes [4].event_name := 'BKW';
    form_attributes [4].event_label := 'bkw';
    form_attributes [4].event_trigger := fdc$backward;
    form_attributes [4].event_action := fdc$page_variable_backward;
    form_attributes [5].key := fdc$add_event;
    form_attributes [5].event_name := 'FIRST';
    form_attributes [5].event_label := 'First';
    form_attributes [5].event_trigger := fdc$shift_backward;
    form_attributes [5].event_action := fdc$page_variable_first;
    form_attributes [6].key := fdc$add_event;
    form_attributes [6].event_name := 'LAST';
    form_attributes [6].event_label := 'Last';
    form_attributes [6].event_trigger := fdc$shift_forward;
    form_attributes [6].event_action := fdc$page_variable_last;
    form_attributes [7].key := fdc$add_event;
    form_attributes [7].event_name := 'BACK';
    form_attributes [7].event_label := 'Back';
    form_attributes [7].event_trigger := fdc$back;
    form_attributes [7].event_action := fdc$erase_help;
    form_attributes [8].key := fdc$form_name;
    form_attributes [8].form_name := fdc$message_form_name;
    fdp$create_form (form_identifier, form_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Create variable for message.

    variable_attributes [1].key := fdc$program_data_type;
    variable_attributes [1].program_data_type := fdc$program_character_type;
    variable_attributes [2].key := fdc$io_mode;
    variable_attributes [2].io_mode := fdc$terminal_output;
    variable_attributes [3].key := fdc$variable_length;
    variable_attributes [3].variable_length := fdc$message_variable_length;
    fdp$create_variable (form_identifier, fdv$message_variable_name, variable_attributes, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'creating message form',
            status);
      fdp$close_form (form_identifier, local_status);
      RETURN;
    IFEND;

{ Create object for variable.

    object_attributes [1].key := fdc$object_name;
    object_attributes [1].object_name := fdv$message_variable_name;
    object_attributes [1].occurrence := 1;
    object_definition.key := fdc$variable_text;
    object_definition.variable_text_width := fdc$message_visible_length;
    initial_value := ' ';
    object_definition.p_variable_text := ^initial_value;
    fdp$create_object (form_identifier, 3, 2, object_definition, object_attributes, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'creating message form',
            status);
      fdp$close_form (form_identifier, local_status);
      RETURN;
    IFEND;

    fdp$end_form (form_identifier, NIL, number_errors, p_errors, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'creating message form',
            status);
      fdp$close_form (form_identifier, local_status);
      RETURN;
    IFEND;

    IF number_errors <> 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'creating message form',
            status);
      fdp$close_form (form_identifier, local_status);
    IFEND;
  PROCEND fdp$create_message_form;

MODEND fdm$create_message_form;
*DECK DECK=FDM$DESIGN_FORM EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Screen Formatter : Design Form' ??
MODULE fdm$design_form;
?? NEWTITLE := 'Global Declarations', EJECT ??
*copyc amp$put_next

*copyc clp$trimmed_string_size

*copyc cyd$run_time_error_condition

*copyc fdc$im_smart_capability
*copyc fdc$integer_length
*copyc fdc$message_form_capability
*copyc fdc$real_length
*copyc fdc$reassign_event_capability
*copyc fdc$system_design_variable_name
*copyc fdc$system_design_table_name
*copyc fdc$screen_formatting_version
*copyc fdc$validation_capability
*copyc fdc$screen_generator_version
*copyc fde$condition_identifiers
*copyc fdp$change_form
*copyc fdp$change_object
*copyc fdp$check_for_active_form
*copyc fdp$check_for_overlayed_objects
*copyc fdp$close_form
*copyc fdp$convert_to_cobol_name
*copyc fdp$convert_to_fortran_name
*copyc fdp$convert_terminal_status
*copyc fdp$convert_to_screen_variable
*copyc fdp$create_form
*copyc fdp$create_form_status
*copyc fdp$create_object
*copyc fdp$create_table
*copyc fdp$create_variable
*copyc fdp$end_form
*copyc fdp$delete_object
*copyc fdp$find_change_form_definition
*copyc fdp$find_display_name
*copyc fdp$find_form_definition
*copyc fdp$find_form_status
*copyc fdp$find_object_definition
*copyc fdp$find_variable_definition
*copyc fdp$get_string_variable
*copyc fdp$locate_added_variable_facts
*copyc fdp$open_form
*copyc fdp$ptr_comments
*copyc fdp$ptr_displays
*copyc fdp$ptr_events
*copyc fdp$ptr_event_command
*copyc fdp$ptr_objects
*copyc fdp$ptr_record_definitions
*copyc fdp$ptr_tables
*copyc fdp$ptr_table_objects
*copyc fdp$ptr_table_variables
*copyc fdp$ptr_text
*copyc fdp$ptr_valid_integers
*copyc fdp$ptr_valid_reals
*copyc fdp$ptr_valid_strings
*copyc fdp$ptr_variable
*copyc fdp$ptr_variables
*copyc fdp$record_screen_change
*copyc fdp$rel_comments
*copyc fdp$rel_displays
*copyc fdp$rel_event_command
*copyc fdp$rel_events
*copyc fdp$rel_objects
*copyc fdp$rel_tables
*copyc fdp$rel_table_objects
*copyc fdp$rel_table_variables
*copyc fdp$rel_text
*copyc fdp$rel_record_definitions
*copyc fdp$rel_valid_integers
*copyc fdp$rel_valid_reals
*copyc fdp$rel_valid_strings
*copyc fdp$rel_variables
*copyc fdp$replace_string_variable
*copyc fdt$comment_index
*copyc fdt$display_index
*copyc fdt$event_index
*copyc fdt$number_record_variables
*copyc fdt$table_variable_index
*copyc fdt$valid_integer_index
*copyc fdt$valid_real_index
*copyc fdt$valid_string_index
*copyc fdt$error_header

*copyc i#current_sequence_position
*copyc i#move

*copyc llt$identification
*copyc llt$module_generator
*copyc llt$module_kind
*copyc llt$object_text_descriptor
*copyc llt$object_record_kind

*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc mmp$verify_access

*copyc pmp$continue_to_cause
*copyc pmp$generate_unique_name
*copyc pmp$get_legible_date_time

*copyc osp$append_status_parameter
*copyc osp$append_status_integer
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal
*copyc ost$name

*copyc fdv$colors
*copyc fdv$to_cobol
*copyc fdv$to_cybil
*copyc fdv$to_fortran
*copyc fdv$to_extended_fortran
*copyc fdv$screen_status

?? TITLE := 'fdp$copy_area', EJECT ??
*copyc fdh$copy_area

  PROCEDURE [XDCL] fdp$copy_area
    (    form_identifier: fdt$form_identifier;
         from_x_position: fdt$x_position;
         from_y_position: fdt$y_position;
         width: fdt$width;
         height: fdt$height;
         to_x_position: fdt$x_position;
         to_y_position: fdt$y_position;
     VAR status: ost$status);

    VAR
      active_objects: fdt$number_objects,
      copy_objects: fdt$number_objects,
      form_object_definition: fdt$form_object_definition,
      high_x_position: fdt$x_position,
      high_y_position: fdt$y_position,
      from_occurrence: fdt$occurrence,
      local_status: ost$status,
      object_attributes: array [1 .. 1] of fdt$object_attribute,
      object_definition: fdt$object_definition,
      object_exists: boolean,
      object_index: fdt$object_index,
      p_copied_text: ^fdt$text,
      p_form_definition: ^fdt$form_definition,
      p_form_image: ^fdt$form_image,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_copy_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_copy_text: ^fdt$text,
      p_form_module: ^fdt$form_module,
      p_form_status: ^fdt$form_status,
      p_text: ^fdt$text,
      p_text_sequence: ^SEQ ( * ),
      text_length: fdt$text_length,
      to_occurrence: fdt$occurrence,
      variable_name: ost$name,
      variable_status: fdt$variable_status,
      x_increment: integer,
      x_position: fdt$x_position,
      y_increment: integer,
      y_position: fdt$y_position;

?? NEWTITLE := 'condition_handler', EJECT ??

  PROCEDURE condition_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         stack_frame_save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    CASE condition.selector OF

    = pmc$system_conditions =
      IF (condition.system_conditions * $pmt$system_conditions
            [pmc$instruction_specification, pmc$address_specification,
            pmc$access_violation, pmc$invalid_segment_ring_0, pmc$divide_fault,
            pmc$arithmetic_overflow, pmc$exponent_overflow,
            pmc$exponent_underflow, pmc$fp_significance_loss,
            pmc$fp_indefinite, pmc$arithmetic_significance,
            pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$copy_area;
      IFEND;

    = pmc$user_defined_condition =
      IF condition.user_condition_name = cye$run_time_condition THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$copy_area;
      IFEND;

    ELSE
      ;
    CASEND;
    pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
  PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;

{ The destination area must be inside area occupied by form. }

    IF p_form_definition^.form_area.key = fdc$defined_area THEN
      IF (to_x_position - 1 + width) > p_form_definition^.form_area.width THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$copy_outside_form, p_form_definition^.
              form_name, status);
        RETURN;
      IFEND;

      IF (to_y_position - 1 + height) > p_form_definition^.form_area.height THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$copy_outside_form, p_form_definition^.
              form_name, status);
        RETURN;
      IFEND;
    IFEND;

    high_y_position := from_y_position + height - 1;
    high_x_position := from_x_position + width - 1;
    active_objects := p_form_definition^.form_object_definitions.active_number;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    p_form_module := p_form_status^.p_form_module;

{ The source area must not slice any existing objects.
{ Free text may be slieced

    check_for_sliced_objects (p_form_status, p_form_definition, p_form_module, p_form_object_definitions,
          active_objects, from_x_position, from_y_position, high_x_position, high_y_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ The destination area must not overlay any existing objects.

    form_object_definition.key := fdc$form_constant_text_box;
    form_object_definition.constant_box_height := height;
    form_object_definition.constant_box_width := width;
    form_object_definition.x_position := to_x_position;
    form_object_definition.y_position := to_y_position;
    p_form_image := p_form_status^.p_form_image;
    IF p_form_image <> NIL THEN
      fdp$check_for_overlayed_objects (p_form_image,
           ^form_object_definition, p_form_definition^.form_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Free text must not overlay any objects. }

    IF p_form_status^.design_form THEN
      variable_name := p_form_status^.design_variable_name;
      PUSH p_text: [p_form_definition^.form_area.width];

    /check_free_text_overlay/
      FOR y_position := 1 TO height DO
        to_occurrence := to_y_position + y_position - 1;
        fdp$get_string_variable (form_identifier, variable_name, to_occurrence, p_text^, variable_status,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'copy area get failed', status);
          RETURN;
        IFEND;

        FOR x_position := to_x_position TO to_x_position + width - 1 DO
          IF p_text^ (x_position, 1) <> ' ' THEN
            IF p_form_image <> NIL THEN
              IF p_form_image^ [to_occurrence] (x_position, 1) <> ' ' THEN
                osp$set_status_abnormal (fdc$format_display_identifier, fde$object_overlays, '', status);
                osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (x_position),
                    10, FALSE, status);
                osp$append_status_integer (osc$status_parameter_delimiter,
                     $INTEGER (to_occurrence), 10, FALSE, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      p_form_definition^.form_name, status);
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        FOREND;
      FOREND /check_free_text_overlay/;
    IFEND;

    x_increment := to_x_position - from_x_position;
    y_increment := to_y_position - from_y_position;
    copy_objects := 0;
    IF active_objects > 0 THEN

{ Form list of objects contained in the source area to copy. }

      PUSH p_copy_object_definitions: [1 .. active_objects];

    /find_objects_to_copy/
      FOR object_index := 1 TO active_objects DO
        p_form_object_definition := ^p_form_object_definitions^ [object_index];
        CASE p_form_object_definition^.key OF

        = fdc$form_variable_text =

{ Do not copy variable for design form. It is only the background for other
{ objects created by the form designer.

          IF p_form_status^.design_form THEN
            IF p_form_object_definition^.name = variable_name THEN
              CYCLE /find_objects_to_copy/;
            IFEND;
          IFEND;

        = fdc$form_text_box_fragment, fdc$form_unused_object,
          fdc$form_stored_variable =

{ Stored objects do not appear on the screen.
{ Fragments will be created from source object.

          CYCLE /find_objects_to_copy/;

         ELSE
         CASEND;

        IF p_form_object_definition^.y_position >= from_y_position THEN
          IF p_form_object_definition^.y_position <= high_y_position THEN
            IF p_form_object_definition^.x_position >= from_x_position THEN
              IF p_form_object_definition^.x_position <= high_x_position THEN
                copy_objects := copy_objects + 1;
                p_copy_object_definitions^ [copy_objects] := p_form_object_definition^;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND /find_objects_to_copy/;
    IFEND;

{ Save the free text in the area to copy. }

    IF p_form_status^.design_form THEN
      PUSH p_text_sequence: [[REP (height * width) OF CHAR]];
      RESET p_text_sequence;

    /get_free_text/
      FOR y_position := 1 TO height DO
        from_occurrence := from_y_position + y_position - 1;
        fdp$get_string_variable (form_identifier, variable_name, from_occurrence, p_text^, variable_status,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'copy area get failed', status);
          RETURN;
        IFEND;
        NEXT p_copy_text: [width] IN p_text_sequence;
        p_copy_text^ := p_text^ (from_x_position, width);
      FOREND /get_free_text/;

      RESET p_text_sequence;

{ Copy free text in area. }

    /copy_free_text/
      FOR y_position := 1 TO height DO
        to_occurrence := to_y_position + y_position - 1;
        fdp$get_string_variable (form_identifier, variable_name, to_occurrence, p_text^, variable_status,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'copy area get failed', status);
          RETURN;
        IFEND;
        NEXT p_copy_text: [width] IN p_text_sequence;
        p_text^ (to_x_position, width) := p_copy_text^;
        fdp$replace_string_variable (form_identifier, variable_name, to_occurrence, p_text^, variable_status,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'copy area replace failed', status);
          RETURN;
        IFEND;
      FOREND /copy_free_text/;
    IFEND;

    object_attributes [1].key := fdc$object_display;

{ Copy objects in area. }

  /copy_area_objects/
    FOR object_index := 1 TO copy_objects DO
      p_form_object_definition := ^p_copy_object_definitions^ [object_index];
      object_attributes [1].display_attribute := p_form_object_definition^.display_attribute;
      x_position := p_form_object_definition^.x_position + x_increment;
      y_position := p_form_object_definition^.y_position + y_increment;

      CASE p_form_object_definition^.key OF

      = fdc$form_box =
        object_definition.key := fdc$box;
        object_definition.box_width := p_form_object_definition^.box_width;
        object_definition.box_height := p_form_object_definition^.box_height;
        fdp$create_object (form_identifier, x_position, y_position, object_definition, object_attributes,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'copy area create object failed', status);
          RETURN;
        IFEND;

      = fdc$form_line =
        object_definition.key := fdc$line;
        object_definition.x_increment := p_form_object_definition^.x_increment;
        object_definition.y_increment := p_form_object_definition^.y_increment;
        fdp$create_object (form_identifier, x_position, y_position, object_definition, object_attributes,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'copy area create object failed', status);
          RETURN;
        IFEND;

      = fdc$form_variable_text =
        object_definition.key := fdc$variable_text;
        object_definition.variable_text_width := p_form_object_definition^.text_variable_width;
        object_definition.p_variable_text := fdp$ptr_text (p_form_object_definition^.text_variable_text,
              p_form_module);
        fdp$create_object (form_identifier, x_position, y_position, object_definition, object_attributes,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'copy area create object failed', status);
          RETURN;
        IFEND;

      = fdc$form_variable_text_box =
        object_definition.key := fdc$variable_text_box;
        object_definition.variable_box_height := p_form_object_definition^.variable_box_height;
        object_definition.variable_box_width := p_form_object_definition^.variable_box_width;
        object_definition.variable_box_processing := p_form_object_definition^.variable_box_processing;
        object_definition.p_variable_box_text := fdp$ptr_text
              (p_form_object_definition^.variable_box_text, p_form_module);
        fdp$create_object (form_identifier, x_position, y_position, object_definition, object_attributes,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'copy area create object', status);
          RETURN;
        IFEND;

      = fdc$form_constant_text =
        object_definition.key := fdc$constant_text;
        object_definition.p_constant_text := fdp$ptr_text (p_form_object_definition^.constant_text,
              p_form_module);
        object_definition.constant_text_width := p_form_object_definition^.constant_text_width;
        fdp$create_object (form_identifier, x_position, y_position, object_definition, object_attributes,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'copy area create object failed', status);
          RETURN;
        IFEND;

      = fdc$form_constant_text_box =
        object_definition.key := fdc$constant_text_box;
        object_definition.constant_box_height := p_form_object_definition^.constant_box_height;
        object_definition.constant_box_processing := p_form_object_definition^.constant_box_processing;
        object_definition.constant_box_width := p_form_object_definition^.constant_box_width;
        object_definition.p_constant_box_text := fdp$ptr_text
              (p_form_object_definition^.constant_box_text, p_form_module);
        fdp$create_object (form_identifier, x_position, y_position, object_definition, object_attributes,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'copy area create object failed', status);
          RETURN;
        IFEND;

      = fdc$form_table =
        object_definition.key := fdc$table;
        object_definition.table_width := p_form_object_definition^.table_width;
        object_definition.table_height := p_form_object_definition^.table_height;
        fdp$create_object (form_identifier, x_position, y_position, object_definition, object_attributes,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'copy area create object failed', status);
          RETURN;
        IFEND;

      ELSE
      CASEND;
    FOREND /copy_area_objects/;

  PROCEND fdp$copy_area;

?? TITLE := 'fdp$delete_area', EJECT ??
*copyc fdh$delete_area

  PROCEDURE [XDCL] fdp$delete_area
    (    form_identifier: fdt$form_identifier;
         x_position: fdt$x_position;
         y_position: fdt$y_position;
         width: fdt$width;
         height: fdt$height;
     VAR status: ost$status);

    VAR
      active_objects: fdt$number_objects,
      delete_objects: fdt$number_objects,
      high_x_position: fdt$x_position,
      high_y_position: fdt$y_position,
      object_index: fdt$object_index,
      object_x_position: fdt$x_position,
      object_y_position: fdt$y_position,
      occurrence: fdt$occurrence,
      p_delete_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_definition: ^fdt$form_definition,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_module: ^fdt$form_module,
      p_form_status: ^fdt$form_status,
      p_text: ^fdt$text,
      variable_name: ost$name,
      variable_status: fdt$variable_status;

?? NEWTITLE := 'condition_handler', EJECT ??

  PROCEDURE condition_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         stack_frame_save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    CASE condition.selector OF

    = pmc$system_conditions =
      IF (condition.system_conditions * $pmt$system_conditions
            [pmc$instruction_specification, pmc$address_specification,
            pmc$access_violation, pmc$invalid_segment_ring_0, pmc$divide_fault,
            pmc$arithmetic_overflow, pmc$exponent_overflow,
            pmc$exponent_underflow, pmc$fp_significance_loss,
            pmc$fp_indefinite, pmc$arithmetic_significance,
            pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$delete_area;
      IFEND;

    = pmc$user_defined_condition =
      IF condition.user_condition_name = cye$run_time_condition THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$delete_area;
      IFEND;

    ELSE
      ;
    CASEND;
    pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
  PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;

{ Delete area must be inside area occupied by form. }

    IF p_form_definition^.form_area.key = fdc$defined_area THEN
      IF (x_position - 1 + width) > p_form_definition^.form_area.width THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$delete_outside_form, p_form_definition^.
              form_name, status);
        RETURN;
      IFEND;

      IF (y_position - 1 + height) > p_form_definition^.form_area.height THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$delete_outside_form, p_form_definition^.
              form_name, status);
        RETURN;
      IFEND;
    IFEND;

    high_y_position := y_position + height - 1;
    high_x_position := x_position + width - 1;
    active_objects := p_form_definition^.form_object_definitions.active_number;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    p_form_module := p_form_status^.p_form_module;

{ Delete area must not slice any objects. }

    check_for_sliced_objects (p_form_status, p_form_definition, p_form_module, p_form_object_definitions,
          active_objects, x_position, y_position, high_x_position, high_y_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    delete_objects := 0;
    IF active_objects > 0 THEN
      PUSH p_delete_object_definitions: [1 .. active_objects];
      variable_name := p_form_status^.design_variable_name;

{ Form list of objects to delete. }
{ Do not delete design variable objects used for free text on }
{ the design form. }

    /find_objects_to_delete/
      FOR object_index := 1 TO active_objects DO
        p_form_object_definition := ^p_form_object_definitions^ [object_index];
        CASE p_form_object_definition^.key OF

        = fdc$form_variable_text =

{ The design variable is only used as a background for
{ doing work on the design form.  Do not delete it.

          IF p_form_status^.design_form THEN
            IF p_form_object_definition^.name = variable_name THEN
              CYCLE /find_objects_to_delete/;
            IFEND;
          IFEND;

        = fdc$form_text_box_fragment, fdc$form_unused_object,
          fdc$form_stored_variable =

{ Stored objects do not appear on the screen.
{ Fragments will be deleted when the source object is deleted.

            CYCLE /find_objects_to_delete/;

        ELSE
        CASEND;

        IF p_form_object_definition^.y_position >= y_position THEN
          IF p_form_object_definition^.y_position <= high_y_position THEN
            IF p_form_object_definition^.x_position >= x_position THEN
              IF p_form_object_definition^.x_position <= high_x_position THEN
                delete_objects := delete_objects + 1;
                p_delete_object_definitions^ [delete_objects] := p_form_object_definition^;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND /find_objects_to_delete/;
    IFEND;

{ Delete the objects in the area. }

  /delete_form_objects/
    FOR object_index := 1 TO delete_objects DO
      p_form_object_definition := ^p_delete_object_definitions^ [object_index];
      fdp$delete_object (form_identifier, p_form_object_definition^.x_position, p_form_object_definition^.
            y_position, status);
      IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'delete area delete object failed', status);
        RETURN;
      IFEND;
    FOREND /delete_form_objects/;

    IF p_form_status^.design_form THEN
      PUSH p_text: [p_form_definition^.form_area.width];

{ Delete free text in the area. }

    /delete_free_text/
      FOR occurrence := y_position TO high_y_position DO
        fdp$get_string_variable (form_identifier, variable_name, occurrence, p_text^, variable_status,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'delete area get failed', status);
          RETURN;
        IFEND;

        IF p_text^ (x_position, width) <> ' ' THEN
          p_text^ (x_position, width) := ' ';
          fdp$replace_string_variable (form_identifier, variable_name, occurrence, p_text^, variable_status,
                status);
          IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'delete area replace failed', status);
            RETURN;
          IFEND;
        IFEND;
      FOREND /delete_free_text/;
    IFEND;

  PROCEND fdp$delete_area;

?? TITLE := 'fdp$move_area', EJECT ??
*copyc fdh$move_area

  PROCEDURE [XDCL] fdp$move_area
    (    form_identifier: fdt$form_identifier;
         from_x_position: fdt$x_position;
         from_y_position: fdt$y_position;
         width: fdt$width;
         height: fdt$height;
         to_x_position: fdt$x_position;
         to_y_position: fdt$y_position;
     VAR status: ost$status);

    VAR
      active_objects: fdt$number_objects,
      form_object_definition: fdt$form_object_definition,
      high_x_position: fdt$x_position,
      high_y_position: fdt$y_position,
      from_occurrence: fdt$occurrence,
      local_status: ost$status,
      move_objects: fdt$number_objects,
      object_attributes: array [1 .. 2] of fdt$object_attribute,
      object_definition: fdt$object_definition,
      object_exists: boolean,
      object_index: fdt$object_index,
      p_copied_text: ^fdt$text,
      p_form_definition: ^fdt$form_definition,
      p_form_image: ^fdt$form_image,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_module: ^fdt$form_module,
      p_form_status: ^fdt$form_status,
      p_move_text: ^fdt$text,
      p_move_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_text: ^fdt$text,
      p_text_sequence: ^SEQ ( * ),
      text_length: fdt$text_length,
      to_high_x_position: fdt$x_position,
      to_high_y_position: fdt$y_position,
      to_occurrence: fdt$occurrence,
      variable_name: ost$name,
      variable_status: fdt$variable_status,
      x_increment: integer,
      x_position: fdt$x_position,
      y_increment: integer,
      y_position: fdt$y_position;

?? NEWTITLE := 'condition_handler', EJECT ??

  PROCEDURE condition_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         stack_frame_save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    CASE condition.selector OF

    = pmc$system_conditions =
      IF (condition.system_conditions * $pmt$system_conditions
            [pmc$instruction_specification, pmc$address_specification,
            pmc$access_violation, pmc$invalid_segment_ring_0, pmc$divide_fault,
            pmc$arithmetic_overflow, pmc$exponent_overflow,
            pmc$exponent_underflow, pmc$fp_significance_loss,
            pmc$fp_indefinite, pmc$arithmetic_significance,
            pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$move_area;
      IFEND;

    = pmc$user_defined_condition =
      IF condition.user_condition_name = cye$run_time_condition THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$move_area;
      IFEND;

    ELSE
      ;
    CASEND;
    pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
  PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;

{ Move destination area must not go outside boundaries of form. }

    IF p_form_definition^.form_area.key = fdc$defined_area THEN
      IF (to_x_position - 1 + width) > p_form_definition^.form_area.width THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$move_outside_form, p_form_definition^.
              form_name, status);
        RETURN;
      IFEND;

      IF (to_y_position - 1 + height) > p_form_definition^.form_area.height THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$move_outside_form, p_form_definition^.
              form_name, status);
        RETURN;
      IFEND;
    IFEND;

    high_y_position := from_y_position + height - 1;
    high_x_position := from_x_position + width - 1;
    active_objects := p_form_definition^.form_object_definitions.active_number;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    p_form_module := p_form_status^.p_form_module;

{ On a move to exactly the same area, do nothing. }

    IF ((from_x_position = to_x_position) AND (from_y_position = to_y_position)) THEN
      RETURN;
    IFEND;

{ The source area must not slice any existing objects. }
{ Free text may be sliced. }

    check_for_sliced_objects (p_form_status, p_form_definition, p_form_module, p_form_object_definitions,
          active_objects, from_x_position, from_y_position, high_x_position, high_y_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ The objects in the from area must not collide with any existing objects in the }
{ to area.  Check for collisions in areas formed by intersections of to and from areas }
{ outside of the from area. }

    to_high_y_position := to_y_position + height - 1;
    to_high_x_position := to_x_position + width - 1;
    p_form_image := p_form_status^.p_form_image;
    form_object_definition.key := fdc$form_constant_text_box;

    IF (to_high_x_position >= from_x_position) AND
         (to_high_y_position >= from_y_position) AND
         (to_high_x_position <= high_x_position) AND
         (to_high_y_position <= high_y_position) THEN

{ Lower right corner of to area is inside of from area. }
{ Check to area above from area. }

      IF from_y_position > to_y_position THEN
        form_object_definition.constant_box_height := from_y_position - to_y_position;
        form_object_definition.constant_box_width := width;
        form_object_definition.x_position := to_x_position;
        form_object_definition.y_position := to_y_position;
        IF p_form_image <> NIL THEN
          fdp$check_for_overlayed_objects (p_form_image,
               ^form_object_definition, p_form_definition^.form_name, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;

{ Check to area to left of from area. }

      IF from_x_position > to_x_position THEN
        form_object_definition.constant_box_height := to_high_y_position - from_y_position + 1;
        form_object_definition.constant_box_width := from_x_position - to_x_position;
        form_object_definition.x_position := to_x_position;
        form_object_definition.y_position := from_y_position;
        IF p_form_image <> NIL THEN
          fdp$check_for_overlayed_objects (p_form_image,
               ^form_object_definition, p_form_definition^.form_name, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;

    ELSEIF (to_x_position >= from_x_position) AND
         (to_high_y_position >= from_y_position) AND
         (to_x_position <= high_x_position) AND
         (to_high_y_position <= high_y_position) THEN

{ Lower left corner of to area is inside of from area. }
{ Check to area above from area. }

      IF from_y_position > to_y_position THEN
        form_object_definition.constant_box_height := from_y_position - to_y_position;
        form_object_definition.constant_box_width := width;
        form_object_definition.x_position := to_x_position;
        form_object_definition.y_position := to_y_position;
        IF p_form_image <> NIL THEN
          fdp$check_for_overlayed_objects (p_form_image,
               ^form_object_definition, p_form_definition^.form_name, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;

{ Check to area to right of from area. }

      IF to_high_x_position > high_x_position THEN
        form_object_definition.constant_box_height :=
             to_high_y_position - from_y_position + 1;
        form_object_definition.constant_box_width := to_high_x_position - high_x_position;
        form_object_definition.x_position := high_x_position + 1;
        form_object_definition.y_position := from_y_position;
        IF p_form_image <> NIL THEN
          fdp$check_for_overlayed_objects (p_form_image,
               ^form_object_definition, p_form_definition^.form_name, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;

    ELSEIF (to_high_x_position >= from_x_position) AND
         (to_y_position >= from_y_position) AND
         (to_high_x_position <= high_x_position) AND
         (to_y_position <= high_y_position) THEN

{ Upper right corner of to area is inside of from area. }
{ Check to area below from area. }

      IF to_high_y_position > high_y_position THEN
        form_object_definition.constant_box_height := to_high_y_position - high_y_position;
        form_object_definition.constant_box_width := width;
        form_object_definition.x_position := to_x_position;
        form_object_definition.y_position := high_y_position + 1;
        IF p_form_image <> NIL THEN
          fdp$check_for_overlayed_objects (p_form_image,
               ^form_object_definition, p_form_definition^.form_name, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;

{ Check to area to left of from area. }

      IF from_x_position > to_x_position THEN
        form_object_definition.constant_box_height := high_y_position - y_position + 1;
        form_object_definition.constant_box_width := from_x_position - to_x_position;
        form_object_definition.x_position := to_x_position;
        form_object_definition.y_position := to_y_position;
        IF p_form_image <> NIL THEN
          fdp$check_for_overlayed_objects (p_form_image,
               ^form_object_definition, p_form_definition^.form_name, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;

    ELSEIF (to_x_position >= from_x_position) AND
         (to_y_position >= from_y_position) AND
         (to_x_position <= high_x_position) AND
         (to_y_position <= high_y_position) THEN

{ Upper left corner of to area is inside of from area. }
{ Check to area below from area. }


    IF to_high_y_position > high_y_position THEN
      form_object_definition.constant_box_height := to_high_y_position - high_y_position;
      form_object_definition.constant_box_width := width;
      form_object_definition.x_position := to_x_position;
      form_object_definition.y_position := high_y_position + 1;
      IF p_form_image <> NIL THEN
        fdp$check_for_overlayed_objects (p_form_image,
             ^form_object_definition, p_form_definition^.form_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

{ Check to area to right of from area. }

      IF to_high_x_position > high_x_position THEN
        form_object_definition.constant_box_height := high_y_position - to_y_position + 1;
        form_object_definition.constant_box_width := to_high_x_position - high_x_position;
        form_object_definition.x_position := high_x_position + 1;
        form_object_definition.y_position := to_y_position;
        IF p_form_image <> NIL THEN
          fdp$check_for_overlayed_objects (p_form_image,
               ^form_object_definition, p_form_definition^.form_name, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
       IFEND;
     IFEND;

    ELSE { The to area does not overlay the from area. }
      form_object_definition.constant_box_height := height;
      form_object_definition.constant_box_width := width;
      form_object_definition.x_position := to_x_position;
      form_object_definition.y_position := to_y_position;
      IF p_form_image <> NIL THEN
        fdp$check_for_overlayed_objects (p_form_image,
             ^form_object_definition, p_form_definition^.form_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

{ Check that free text will not overlay any objects. }

    IF p_form_status^.design_form THEN
      variable_name := p_form_status^.design_variable_name;
      PUSH p_text: [p_form_definition^.form_area.width];

    /check_free_text_overlay/
      FOR y_position := 1 TO height DO
        to_occurrence := to_y_position + y_position - 1;
        fdp$get_string_variable (form_identifier, variable_name, to_occurrence, p_text^, variable_status,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'move area get failed', status);
          RETURN;
        IFEND;
        FOR x_position := to_x_position TO to_x_position + width - 1 DO
          IF p_text^ (x_position, 1) <> ' ' THEN
            IF p_form_image <> NIL THEN
              IF p_form_image^ [to_occurrence] (x_position, 1) <> ' ' THEN
                osp$set_status_abnormal (fdc$format_display_identifier, fde$object_overlays, '', status);
                osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (x_position),
                    10, FALSE, status);
                osp$append_status_integer (osc$status_parameter_delimiter,
                     $INTEGER (to_occurrence), 10, FALSE, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                     p_form_definition^.form_name, status);
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        FOREND;
      FOREND /check_free_text_overlay/;
    IFEND;

{ Form list of objects to move. }

    x_increment := to_x_position - from_x_position;
    y_increment := to_y_position - from_y_position;
    move_objects := 0;
    IF active_objects > 0 THEN

      PUSH p_move_object_definitions: [1 .. active_objects];

    /find_objects_to_move/
      FOR object_index := 1 TO active_objects DO
        p_form_object_definition := ^p_form_object_definitions^ [object_index];
        CASE p_form_object_definition^.key OF

        = fdc$form_variable_text =

{ Do not move design variable on the design form.
{ It is only a background for other objects created by the form designer.

          IF p_form_status^.design_form THEN
            IF p_form_object_definition^.name = variable_name THEN
              CYCLE /find_objects_to_move/;
             IFEND;
          IFEND;

       = fdc$form_text_box_fragment, fdc$form_unused_object,
         fdc$form_stored_variable =

{ Stored objects do not appear on the screen.
{ Fragments will be moved when the source item is moved.

         CYCLE /find_objects_to_move/;

       ELSE
       CASEND;

        IF p_form_object_definition^.y_position >= from_y_position THEN
          IF p_form_object_definition^.y_position <= high_y_position THEN
            IF p_form_object_definition^.x_position >= from_x_position THEN
              IF p_form_object_definition^.x_position <= high_x_position THEN
                move_objects := move_objects + 1;
                p_move_object_definitions^ [move_objects] := p_form_object_definition^;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND /find_objects_to_move/;
    IFEND;

    IF p_form_status^.design_form THEN
      PUSH p_text_sequence: [[REP (height * width) OF CHAR]];
      RESET p_text_sequence;

{ Move free text on the design form. }

    /find_free_text/
      FOR y_position := 1 TO height DO
        from_occurrence := from_y_position + y_position - 1;
        fdp$get_string_variable (form_identifier, variable_name, from_occurrence, p_text^, variable_status,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'move area get failed', status);
          RETURN;
        IFEND;

        NEXT p_move_text: [width] IN p_text_sequence;
        p_move_text^ := p_text^ (from_x_position, width);
      FOREND /find_free_text/;

{ Delete the free text in the from area. }

    /delete_free_text/
      FOR y_position := 1 TO height DO
        from_occurrence := from_y_position + y_position - 1;
        fdp$get_string_variable (form_identifier, variable_name, from_occurrence, p_text^, variable_status,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'move area get failed', status);
          RETURN;
        IFEND;

        p_text^ (from_x_position, width) := ' ';
        fdp$replace_string_variable (form_identifier, variable_name, from_occurrence, p_text^,
              variable_status, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'move area replace failed', status);
          RETURN;
        IFEND;
      FOREND /delete_free_text/;

      RESET p_text_sequence;

{ Add the free text in the to area. }

    /move_free_text/
      FOR y_position := 1 TO height DO
        to_occurrence := to_y_position + y_position - 1;
        fdp$get_string_variable (form_identifier, variable_name, to_occurrence, p_text^, variable_status,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'move area get failed', status);
          RETURN;
        IFEND;
        NEXT p_move_text: [width] IN p_text_sequence;
        p_text^ (to_x_position, width) := p_move_text^;
        fdp$replace_string_variable (form_identifier, variable_name, to_occurrence, p_text^, variable_status,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'move area replace failed', status);
          RETURN;
        IFEND;
      FOREND /move_free_text/;
    IFEND;

{ Delete the objects in the from area so that they will not collide when they are }
{ added in the to area. }

    FOR object_index := 1 TO move_objects DO
      fdp$delete_object (form_identifier, p_move_object_definitions^ [object_index].x_position,
            p_move_object_definitions^ [object_index].y_position, status);
      IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'move area delete object failed', status);
        RETURN;
      IFEND;
    FOREND;

    object_attributes [1].key := fdc$object_display;

{ Create new objects in the to area. }

  /move_objects_in_area/
    FOR object_index := 1 TO move_objects DO
      p_form_object_definition := ^p_move_object_definitions^ [object_index];
      object_attributes [1].display_attribute := p_form_object_definition^.display_attribute;
      IF p_form_object_definition^.name <> osc$null_name THEN
        object_attributes [2].key := fdc$object_name;
        object_attributes [2].object_name := p_form_object_definition^.name;
        object_attributes [2].occurrence := p_form_object_definition^.occurrence;
      ELSE
        object_attributes [2].key := fdc$unused_object_entry;
      IFEND;

      x_position := p_form_object_definition^.x_position + x_increment;
      y_position := p_form_object_definition^.y_position + y_increment;
      CASE p_form_object_definition^.key OF

      = fdc$form_box =
        object_definition.key := fdc$box;
        object_definition.box_width := p_form_object_definition^.box_width;
        object_definition.box_height := p_form_object_definition^.box_height;
        fdp$create_object (form_identifier, x_position, y_position, object_definition, object_attributes,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'move area create object failed', status);
          RETURN;
        IFEND;

      = fdc$form_line =
        object_definition.key := fdc$line;
        object_definition.x_increment := p_form_object_definition^.x_increment;
        object_definition.y_increment := p_form_object_definition^.y_increment;
        fdp$create_object (form_identifier, x_position, y_position, object_definition, object_attributes,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'move area create object failed', status);
          RETURN;
        IFEND;

      = fdc$form_variable_text =
        object_definition.key := fdc$variable_text;
        object_definition.variable_text_width := p_form_object_definition^.text_variable_width;
        object_definition.p_variable_text := fdp$ptr_text (p_form_object_definition^.text_variable_text,
              p_form_module);
        fdp$create_object (form_identifier, x_position, y_position, object_definition, object_attributes,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'move area create object failed', status);
          RETURN;
        IFEND;

      = fdc$form_variable_text_box =
        object_definition.key := fdc$variable_text_box;
        object_definition.variable_box_height := p_form_object_definition^.variable_box_height;
        object_definition.variable_box_width := p_form_object_definition^.variable_box_width;
        object_definition.variable_box_processing := p_form_object_definition^.variable_box_processing;
        object_definition.p_variable_box_text := fdp$ptr_text
              (p_form_object_definition^.variable_box_text, p_form_module);
        fdp$create_object (form_identifier, x_position, y_position, object_definition, object_attributes,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'move area create object failed', status);
          RETURN;
        IFEND;

      = fdc$form_constant_text =
        object_definition.key := fdc$constant_text;
        object_definition.p_constant_text := fdp$ptr_text (p_form_object_definition^.constant_text,
              p_form_module);
        object_definition.constant_text_width := p_form_object_definition^.constant_text_width;
        fdp$create_object (form_identifier, x_position, y_position, object_definition, object_attributes,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'move area create object failed', status);
          RETURN;
        IFEND;

      = fdc$form_constant_text_box =
        object_definition.key := fdc$constant_text_box;
        object_definition.constant_box_height := p_form_object_definition^.constant_box_height;
        object_definition.constant_box_processing := p_form_object_definition^.constant_box_processing;
        object_definition.constant_box_width := p_form_object_definition^.constant_box_width;
        object_definition.p_constant_box_text := fdp$ptr_text
              (p_form_object_definition^.constant_box_text, p_form_module);
        fdp$create_object (form_identifier, x_position, y_position, object_definition, object_attributes,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'move area create object failed', status);
          RETURN;
        IFEND;

      = fdc$form_table =
        object_definition.key := fdc$table;
        object_definition.table_width := p_form_object_definition^.table_width;
        object_definition.table_height := p_form_object_definition^.table_height;
        fdp$create_object (form_identifier, x_position, y_position, object_definition, object_attributes,
              status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'move area create object failed', status);
          RETURN;
        IFEND;

      ELSE
        { Do nothing for remaining objects. }
      CASEND;

    FOREND /move_objects_in_area/;

  PROCEND fdp$move_area;

?? TITLE := 'fdp$copy_form', EJECT ??
*copyc fdh$copy_form

  PROCEDURE [XDCL] fdp$copy_form
    (    from_form_identifier: fdt$form_identifier;
     VAR to_form_identifier: fdt$form_identifier;
     VAR status: ost$status);

    VAR
      form_work_area: amt$segment_pointer,
      local_status: ost$status,
      p_from_form_module: ^fdt$form_module,
      p_from_form_status: ^fdt$form_status,
      p_to_form_status: ^fdt$form_status;

?? NEWTITLE := 'condition_handler', EJECT ??

  PROCEDURE condition_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         stack_frame_save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    CASE condition.selector OF

    = pmc$system_conditions =
      IF (condition.system_conditions * $pmt$system_conditions
            [pmc$instruction_specification, pmc$address_specification,
            pmc$access_violation, pmc$invalid_segment_ring_0, pmc$divide_fault,
            pmc$arithmetic_overflow, pmc$exponent_overflow,
            pmc$exponent_underflow, pmc$fp_significance_loss,
            pmc$fp_indefinite, pmc$arithmetic_significance,
            pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
      IF form_work_area.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (p_to_form_status^.segment_pointer, local_status);
      IFEND;
      IF p_to_form_status <> NIL THEN
        p_to_form_status^.entry_used := FALSE;
      IFEND;
        EXIT fdp$copy_form;
      IFEND;

    = pmc$user_defined_condition =
      IF condition.user_condition_name = cye$run_time_condition THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
      IF form_work_area.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (p_to_form_status^.segment_pointer, local_status);
      IFEND;
      IF p_to_form_status <> NIL THEN
        p_to_form_status^.entry_used := FALSE;
      IFEND;
        EXIT fdp$copy_form;
      IFEND;

    ELSE
      ;
    CASEND;
    pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
  PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    p_to_form_status := NIL;
    form_work_area.kind := amc$sequence_pointer;
    form_work_area.sequence_pointer := NIL;
    osp$establish_condition_handler (^condition_handler, TRUE);
    fdp$find_form_definition (from_form_identifier, p_from_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$create_form_status (to_form_identifier, p_to_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_to_form_status^ := p_from_form_status^;
    p_to_form_status^.active_form_object_statuses := 0;
    p_to_form_status^.added := FALSE;
    p_to_form_status^.defined_dynamically := TRUE;
    p_to_form_status^.displayed_on_screen := FALSE;
    p_to_form_status^.event_form_defined := FALSE;
    p_to_form_status^.events_active := FALSE;
    p_to_form_status^.field_number_defined := FALSE;
    p_to_form_status^.graphic_identifier_defined := FALSE;
    p_to_form_status^.last_cursor_position_valid := FALSE;
    p_to_form_status^.mark_defined := FALSE;
    p_to_form_status^.opened := FALSE;
    p_to_form_status^.opened_for_query_only := FALSE;
    p_to_form_status^.owned_by_system := FALSE;
    p_to_form_status^.p_form_event_statuses := NIL;
    p_to_form_status^.p_form_image := NIL;
    p_to_form_status^.p_form_object_statuses := NIL;
    p_to_form_status^.p_form_table_statuses := NIL;
    p_to_form_status^.p_program_record := NIL;
    p_to_form_status^.p_screen_record := NIL;
    p_to_form_status^.push_count := 0;
    p_to_form_status^.storage_allocated := FALSE;
    p_to_form_status^.total_form_object_statuses := 0;
    p_to_form_status^.validate_variable_values := FALSE;
    p_to_form_status^.fast_form_creation := FALSE;
    p_from_form_module := p_from_form_status^.p_form_module;

{ The definition for the form is placed in a sequence in a scratch segment. }
{ All pointers in the sequence must be relative pointers so  that the sequence may }
{ later be saved on an object code library. }

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, form_work_area,
          status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
      p_to_form_status^.entry_used := FALSE;
      RETURN;
    IFEND;

    p_to_form_status^.segment_pointer := form_work_area;
    RESET p_to_form_status^.segment_pointer.sequence_pointer;
    p_to_form_status^.p_form_module := p_to_form_status^.segment_pointer.sequence_pointer;
    copy_form (p_from_form_status, p_to_form_status, status);
    IF NOT status.normal THEN
      mmp$delete_scratch_segment (p_to_form_status^.segment_pointer, local_status);
      p_to_form_status^.entry_used := FALSE;
    IFEND;
  PROCEND fdp$copy_form;

?? TITLE := 'copy_form', EJECT ??

  PROCEDURE copy_form
    (    p_from_form_status: ^fdt$form_status;
         p_to_form_status: ^fdt$form_status;
     VAR status: ost$status);

    VAR
      p_from_form_definition: ^fdt$form_definition,
      p_from_form_module: ^fdt$form_module,
      p_from_help_message: ^fdt$help_message,
      p_to_form_definition: ^fdt$form_definition,
      p_to_form_module: ^fdt$form_module,
      p_to_help_message: ^fdt$help_message;

?? NEWTITLE := 'copy_added_variable_definition', EJECT ??
{  PURPOSE:
{    This procedure handles overflow from the original form variable definition.
{  DESIGN:
{    If the old form was created before the IM/SMART feature, create an additional
{    data area for the variable on the new form.

    PROCEDURE copy_added_variable_definition
      (    p_old_form_definition: ^fdt$form_definition;
           p_old_form_variable_definition: ^fdt$form_variable_definition;
           p_old_form_module: ^fdt$form_module;
           p_new_form_variable_definition: {output} ^fdt$form_variable_definition;
       VAR p_new_form_module: ^fdt$form_module;
       VAR status: ost$status);

      VAR
        p_new_added_variable_definition: ^fdt$added_variable_definition,
        p_new_comment: ^fdt$comment,
        p_new_sequence: ^SEQ (*),
        p_old_added_variable_definition: ^fdt$added_variable_definition,
        p_old_comment: ^fdt$comment,
        p_new_comments: ^array [1 .. * ] of fdt$comment_definition,
        p_old_comments: ^array [1 .. * ] of fdt$comment_definition;

      status.normal := TRUE;

{ Make a form created before the IM SMART capability look like one created after
{ the IM SMART capability.  For a form created before the IM SMART capability create
{ a temporary additional data area for the variable.

      IF p_old_form_definition^.screen_formatting_version <
            fdc$im_smart_capability THEN
        PUSH p_old_added_variable_definition;
        i#move (^p_old_form_variable_definition^.additional_variable_facts,
              ^p_old_added_variable_definition^.comment_definitions,
              #SIZE (fdt$comment_definitions));
        p_old_added_variable_definition^.form_cobol_display_clause.defined := FALSE;
        p_old_added_variable_definition^.form_cobol_program_clause.defined := FALSE;
      ELSE

{ The form was created using the IM SMART capability.  The comment field of the
{ form variable definition was replaced to point to the additional data area for the
{ variable.

        fdp$locate_added_variable_facts (p_old_form_module, p_old_form_variable_definition,
             p_old_added_variable_definition);
      IFEND;

{ Create the new additional data area for the form variable definition. All copied
{ forms will have the additional data area and a version greater-equal to the
{ fdc$im_smart_capability.

      NEXT p_new_sequence: [[REP #SIZE(fdt$added_variable_definition) OF cell]] IN
            p_new_form_module;
      IF p_new_sequence = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
             fde$no_space_available, '', status);
        RETURN;
      IFEND;

      RESET p_new_sequence;
      NEXT p_new_added_variable_definition IN p_new_sequence;
      p_new_added_variable_definition^ := p_old_added_variable_definition^;
      p_new_form_variable_definition^.additional_variable_facts.additional_definitions :=
            #REL(p_new_sequence, p_new_form_module^);
      copy_comments (p_old_added_variable_definition^.comment_definitions.active_number,
            p_old_added_variable_definition^.comment_definitions,  p_old_form_module,
            p_new_form_module, p_new_added_variable_definition^.comment_definitions, status);

    PROCEND copy_added_variable_definition;

?? OLDTITLE ??
?? NEWTITLE := 'copy_comments', EJECT ??

    PROCEDURE  copy_comments
      (    active_number: fdt$number_comments;
           old_comment_definitions: fdt$comment_definitions;
           p_old_form_module: ^fdt$form_module;
       VAR p_new_form_module: ^fdt$form_module;
       VAR new_comment_definitions: fdt$comment_definitions;
       VAR status: ost$status);

      VAR
        comment_index: fdt$comment_index,
        p_new_comment: ^fdt$comment,
        p_old_comment: ^fdt$comment,
        p_new_comments: ^array [1 .. * ] of fdt$comment_definition,
        p_old_comments: ^array [1 .. * ] of fdt$comment_definition;

      status.normal := TRUE;
      IF active_number > 0 THEN
        p_old_comments := fdp$ptr_comments (old_comment_definitions, p_old_form_module);
        NEXT p_new_comments: [1 .. active_number] IN p_new_form_module;
        IF p_new_comments <> NIL THEN
          fdp$rel_comments (p_new_comments, p_new_form_module, new_comment_definitions);
          new_comment_definitions.active_number := active_number;

        /copy_comment_definitions/
          FOR comment_index := 1 TO active_number DO
            p_old_comment := #PTR (p_old_comments^ [comment_index].p_comment, p_old_form_module^);
            NEXT p_new_comment: [STRLENGTH (p_old_comment^)] IN p_new_form_module;
            IF p_new_comment <> NIL THEN
              p_new_comment^ := p_old_comment^;
              p_new_comments^ [comment_index].p_comment := #REL (p_new_comment, p_new_form_module^);

            ELSE { No space could be allocated to copy comment. }
              fdp$rel_comments (NIL, p_new_form_module, new_comment_definitions);
              new_comment_definitions.active_number := 0;
              osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
              EXIT /copy_comment_definitions/;
            IFEND;
          FOREND /copy_comment_definitions/;

        ELSE { No space for new comments. }
          fdp$rel_comments (NIL, p_new_form_module, new_comment_definitions);
          new_comment_definitions.active_number := 0;
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        IFEND;

      ELSE { No old comments are active. }
        fdp$rel_comments (NIL, p_new_form_module, new_comment_definitions);
        new_comment_definitions.active_number := 0;
      IFEND;

    PROCEND copy_comments;


?? OLDTITLE ??
?? NEWTITLE := 'copy_display_definitions', EJECT ??

    PROCEDURE [INLINE] copy_display_definitions
      (    active_number: fdt$number_object_displays;
           p_old_display_definitions: ^array [1 .. * ] OF fdt$display_definition;
           p_new_form_status: ^fdt$form_status;
           p_new_form_definition: ^fdt$form_definition;
       VAR p_new_form_module: ^fdt$form_module;
       VAR status: ost$status);

      VAR
        display_index: fdt$display_index,
        p_new_display_definitions: ^array [1 .. * ] of fdt$display_definition;

      status.normal := TRUE;
      IF active_number > 0 THEN
        NEXT p_new_display_definitions: [1 .. active_number] IN p_new_form_module;

        IF p_new_display_definitions <> NIL THEN
          fdp$rel_displays (p_new_display_definitions, p_new_form_status);
          p_new_form_definition^.display_definitions.active_number := active_number;
          FOR display_index := 1 TO active_number DO
            p_new_display_definitions^ [display_index] := p_old_display_definitions^ [display_index];
          FOREND;

        ELSE { No space for new displays. }
          fdp$rel_displays (NIL, p_new_form_status);
          p_new_form_definition^.display_definitions.active_number := 0;
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        IFEND;

      ELSE { No old displays are active. }
        fdp$rel_displays (NIL, p_new_form_status);
        p_new_form_definition^.display_definitions.active_number := 0;
      IFEND;
    PROCEND copy_display_definitions;

?? OLDTITLE ??
?? NEWTITLE := 'copy_event_definitions', EJECT ??

    PROCEDURE [INLINE] copy_event_definitions
      (    p_old_form_definition: ^fdt$form_definition;
           active_number: fdt$number_events;
           p_old_event_definitions: ^array [1 .. * ] OF fdt$event_definition;
           p_new_form_status: ^fdt$form_status;
           p_new_form_definition: ^fdt$form_definition;
       VAR p_new_form_module: ^fdt$form_module;
       VAR status: ost$status);

      VAR
        event_index: fdt$event_index,
        p_new_event_definitions: ^array [1 .. * ] of fdt$event_definition;

      status.normal := TRUE;
      IF active_number > 0 THEN
        NEXT p_new_event_definitions: [1 .. active_number] IN p_new_form_module;
        IF p_new_event_definitions <> NIL THEN
          fdp$rel_events (p_new_event_definitions, p_new_form_status);
          p_new_form_definition^.event_definitions.active_number := active_number;
          FOR event_index := 1 TO active_number DO
            p_new_event_definitions^ [event_index] := p_old_event_definitions^ [event_index];
            IF (p_old_form_definition^.screen_formatting_version <
                  fdc$reassign_event_capability) THEN
               p_new_event_definitions^ [event_index].event_trigger_reassignment := TRUE;
            IFEND;
          FOREND;

        ELSE { No space for new events. }
          fdp$rel_events (NIL, p_new_form_status);
          p_new_form_definition^.event_definitions.active_number := 0;
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        IFEND;

      ELSE { No events are defined. }
        fdp$rel_events (NIL, p_new_form_status);
        p_new_form_definition^.event_definitions.active_number := 0;
      IFEND;
    PROCEND copy_event_definitions;

?? OLDTITLE ??
?? NEWTITLE := 'copy_object_definitions', EJECT ??

    PROCEDURE copy_object_definitions
      (    active_number: fdt$number_objects;
           p_old_form_module: ^fdt$form_module;
           p_old_object_definitions: ^array [1 .. * ] OF fdt$form_object_definition;
           p_new_form_status: ^fdt$form_status;
           p_new_form_definition: ^fdt$form_definition;
       VAR p_new_form_module: ^fdt$form_module;
       VAR status: ost$status);

      VAR
        form_object_key: fdt$form_object_key,
        old_object_index: fdt$object_index,
        p_new_object_definition: ^fdt$form_object_definition,
        p_new_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
        p_old_object_definition: ^fdt$form_object_definition,
        p_new_text: ^fdt$text,
        p_old_text: ^fdt$text;

      status.normal := TRUE;
      IF active_number = 0 THEN
        fdp$rel_objects (NIL, p_new_form_status);
        p_new_form_definition^.form_object_definitions.active_number := 0;
        RETURN;
      IFEND;

      NEXT p_new_object_definitions: [1 .. active_number] IN p_new_form_module;
      IF p_new_object_definitions = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

      fdp$rel_objects (p_new_object_definitions, p_new_form_status);
      p_new_form_definition^.form_object_definitions.active_number := active_number;

    /copy_objects/
      FOR old_object_index := 1 TO active_number DO
        p_old_object_definition := ^p_old_object_definitions^ [old_object_index];
        p_new_object_definitions^ [old_object_index] := p_old_object_definition^;
        form_object_key := p_old_object_definition^.key;
        CASE form_object_key OF

        = fdc$form_box, fdc$form_line, fdc$form_table, fdc$form_text_box_fragment,
          fdc$form_unused_object =

{ Do nothing. }

        = fdc$form_constant_text =
          p_new_object_definition := ^p_new_object_definitions^ [old_object_index];
          p_old_text := fdp$ptr_text (p_old_object_definition^.constant_text, p_old_form_module);
          NEXT p_new_text: [STRLENGTH (p_old_text^)] IN p_new_form_module;
          IF p_new_text <> NIL THEN
            p_new_text^ := p_old_text^;
            fdp$rel_text (p_new_text, p_new_form_module, p_new_object_definition^.constant_text);

          ELSE { No space for text. }
            p_new_object_definition^.key := fdc$form_unused_object;
            osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
            RETURN;
          IFEND;

        = fdc$form_constant_text_box =
          p_new_object_definition := ^p_new_object_definitions^ [old_object_index];
          p_old_text := fdp$ptr_text (p_old_object_definition^.constant_box_text, p_old_form_module);
          NEXT p_new_text: [STRLENGTH (p_old_text^)] IN p_new_form_module;
          IF p_new_text <> NIL THEN
            p_new_text^ := p_old_text^;
            fdp$rel_text (p_new_text, p_new_form_module, p_new_object_definition^.constant_box_text);

          ELSE { No space for text. }
            p_new_object_definition^.key := fdc$form_unused_object;
            osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
            RETURN;
          IFEND;

        = fdc$form_stored_variable =
          p_new_object_definition := ^p_new_object_definitions^ [old_object_index];
          p_old_text := fdp$ptr_text (p_old_object_definition^.stored_variable_text, p_old_form_module);
          NEXT p_new_text: [STRLENGTH (p_old_text^)] IN p_new_form_module;
          IF p_new_text <> NIL THEN
            p_new_text^ := p_old_text^;
            fdp$rel_text (p_new_text, p_new_form_module, p_new_object_definition^.stored_variable_text);

          ELSE { No space for text. }
            p_new_object_definition^.key := fdc$form_unused_object;
            osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
            RETURN;
          IFEND;

        = fdc$form_variable_text =
          p_new_object_definition := ^p_new_object_definitions^ [old_object_index];
          p_old_text := fdp$ptr_text (p_old_object_definition^.text_variable_text, p_old_form_module);
          NEXT p_new_text: [STRLENGTH (p_old_text^)] IN p_new_form_module;
          IF p_new_text <> NIL THEN
            p_new_text^ := p_old_text^;
            fdp$rel_text (p_new_text, p_new_form_module, p_new_object_definition^.text_variable_text);

          ELSE { No space for text. }
            p_new_object_definition^.key := fdc$form_unused_object;
            osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
            RETURN;
          IFEND;

        = fdc$form_variable_text_box =
          p_new_object_definition := ^p_new_object_definitions^ [old_object_index];
          p_old_text := fdp$ptr_text (p_old_object_definition^.variable_box_text, p_old_form_module);
          NEXT p_new_text: [STRLENGTH (p_old_text^)] IN p_new_form_module;
          IF p_new_text <> NIL THEN
            p_new_text^ := p_old_text^;
            fdp$rel_text (p_new_text, p_new_form_module, p_new_object_definition^.variable_box_text);

          ELSE { No space for text. }
            p_new_object_definition^.key := fdc$form_unused_object;
            osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
            RETURN;
          IFEND;

        ELSE { Invalid object definition key. }
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
               'copy found invalid object', status);
          RETURN;
        CASEND;
      FOREND /copy_objects/;
    PROCEND copy_object_definitions;

?? OLDTITLE ??
?? NEWTITLE := 'copy_record_definitions', EJECT ??

    PROCEDURE [INLINE] copy_record_definitions
      (    active_number: fdt$number_record_variables;
           p_old_record_definitions: ^array [1 .. * ] OF fdt$variable_record_definition;
           p_new_form_definition: ^fdt$form_definition;
           p_new_form_status: ^fdt$form_status;
       VAR p_new_form_module: ^fdt$form_module;
       VAR status: ost$status);

      VAR
        record_index: fdt$number_record_variables,
        p_new_record_definitions: ^array [1 .. * ] of fdt$variable_record_definition;

      status.normal := TRUE;
      IF active_number > 0 THEN
        NEXT p_new_record_definitions: [1 .. active_number] IN p_new_form_module;
        IF p_new_record_definitions <> NIL THEN
          fdp$rel_record_definitions (p_new_record_definitions, p_new_form_status);
          p_new_form_definition^.record_definitions.active_number := active_number;
          FOR record_index := 1 TO active_number DO
            p_new_record_definitions^ [record_index] := p_old_record_definitions^ [record_index];
          FOREND;

        ELSE { No space for copying record definitions. }
          fdp$rel_record_definitions (NIL, p_new_form_status);
          p_new_form_definition^.record_definitions.active_number := 0;
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        IFEND;

      ELSE { No old record definitions exist. }
        fdp$rel_record_definitions (NIL, p_new_form_status);
        p_new_form_definition^.record_definitions.active_number := 0;
      IFEND;
    PROCEND copy_record_definitions;

?? OLDTITLE ??
?? NEWTITLE := 'copy_table_definitions', EJECT ??

    PROCEDURE copy_table_definitions
      (    active_number: fdt$number_tables;
           p_old_form_module: ^fdt$form_module;
           p_old_table_definitions: ^array [1 .. * ] OF fdt$form_table_definition;
           p_new_form_status: ^fdt$form_status;
           p_new_form_definition: ^fdt$form_definition;
       VAR p_new_form_module: ^fdt$form_module;
       VAR status: ost$status);

      VAR
        number_objects: fdt$number_objects,
        number_table_variables: fdt$number_table_variables,
        object_index: fdt$object_index,
        p_new_table_definitions: ^array [1 .. * ] of fdt$form_table_definition,
        p_new_table_objects: ^array [1 .. * ] of fdt$table_object,
        p_new_table_variables: ^array [1 .. * ] of fdt$table_variable,
        p_old_table_object: ^fdt$table_object,
        p_old_table_objects: ^array [1 .. * ] of fdt$table_object,
        p_old_table_definition: ^fdt$form_table_definition,
        p_old_table_variable: ^fdt$table_variable,
        p_old_table_variables: ^array [1 .. * ] of fdt$table_variable,
        table_index: fdt$table_index,
        table_variable_index: fdt$table_variable_index;

      status.normal := TRUE;
      IF active_number = 0 THEN
        fdp$rel_tables (NIL, p_new_form_status);
        p_new_form_definition^.form_table_definitions.active_number := 0;
        RETURN;
      IFEND;

      NEXT p_new_table_definitions: [1 .. active_number] IN p_new_form_module;
      IF p_new_table_definitions = NIL THEN
        fdp$rel_tables (NIL, p_new_form_status);
        p_new_form_definition^.form_table_definitions.active_number := 0;
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

      fdp$rel_tables (p_new_table_definitions, p_new_form_status);
      p_new_form_definition^.form_table_definitions.active_number := active_number;

    /copy_tables/
      FOR table_index := 1 TO active_number DO
        p_old_table_definition := ^p_old_table_definitions^ [table_index];
        p_new_table_definitions^ [table_index] := p_old_table_definition^;
        number_table_variables := p_old_table_definition^.table_variables.active_number;
        IF number_table_variables > 0 THEN
          p_old_table_variables := fdp$ptr_table_variables (p_old_table_definition^.table_variables,
                p_old_form_module);
          NEXT p_new_table_variables: [1 .. number_table_variables] IN p_new_form_module;
          IF p_new_table_variables <> NIL THEN
            fdp$rel_table_variables (p_new_table_variables, p_new_form_module,
                  p_new_table_definitions^ [table_index].table_variables);
            p_new_table_definitions^ [table_index].table_variables.active_number := number_table_variables;

          /copy_table_variables/
            FOR table_variable_index := 1 TO number_table_variables DO
              p_old_table_variable := ^p_old_table_variables^ [table_variable_index];
              p_new_table_variables^ [table_variable_index] := p_old_table_variable^;
              number_objects := p_old_table_variable^.table_objects.active_number;
              IF number_objects > 0 THEN
                p_old_table_objects := fdp$ptr_table_objects (p_old_table_variable^.table_objects,
                      p_old_form_module);
                NEXT p_new_table_objects: [1 .. number_objects] IN p_new_form_module;
                IF p_new_table_objects <> NIL THEN
                  fdp$rel_table_objects (p_new_table_objects, p_new_form_module,
                        p_new_table_variables^ [table_variable_index].table_objects);
                  p_new_table_variables^ [table_variable_index].table_objects.active_number := number_objects;

                /copy_variable_occurrences/
                  FOR object_index := 1 TO number_objects DO
                    p_new_table_objects^ [object_index] := p_old_table_objects^ [object_index];
                  FOREND /copy_variable_occurrences/;

                ELSE { No space for variable occurrences. }
                  osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
                  RETURN;
                IFEND;
              IFEND;

            FOREND /copy_table_variables/;
          IFEND;
        IFEND;
      FOREND /copy_tables/;
    PROCEND copy_table_definitions;

?? OLDTITLE ??
?? NEWTITLE := 'copy_valid_integers', EJECT ??

    PROCEDURE [INLINE] copy_valid_integers
      (    active_number: fdt$number_valid_integers;
           p_old_valid_integers: ^array [1 .. * ] OF fdt$valid_integer_range;
           p_new_form_definition: ^fdt$form_definition;
       VAR p_new_form_module: ^fdt$form_module;
       VAR p_new_valid_integers: ^array [1 .. * ] of fdt$valid_integer_range;
       VAR status: ost$status);

      VAR
        valid_integer_index: fdt$valid_integer_index;

      status.normal := TRUE;
      IF active_number > 0 THEN
        NEXT p_new_valid_integers: [1 .. active_number] IN p_new_form_module;
        IF p_new_valid_integers <> NIL THEN
          FOR valid_integer_index := 1 TO active_number DO
            p_new_valid_integers^ [valid_integer_index] := p_old_valid_integers^ [valid_integer_index];
          FOREND;

        ELSE { No space for new valid_integers. }
          p_new_valid_integers := NIL;
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        IFEND;

      ELSE { No old valid_integers are active. }
        p_new_valid_integers := NIL;
      IFEND;
    PROCEND copy_valid_integers;

?? OLDTITLE ??
?? NEWTITLE := 'copy_valid_reals', EJECT ??

    PROCEDURE [INLINE] copy_valid_reals
      (    active_number: fdt$number_valid_reals;
           p_old_valid_reals: ^array [1 .. * ] OF fdt$valid_real_range;
           p_new_form_definition: ^fdt$form_definition;
       VAR p_new_form_module: ^fdt$form_module;
       VAR p_new_valid_reals: ^array [1 .. * ] of fdt$valid_real_range;
       VAR status: ost$status);

      VAR
        valid_real_index: fdt$valid_real_index;

      status.normal := TRUE;
      IF active_number > 0 THEN
        NEXT p_new_valid_reals: [1 .. active_number] IN p_new_form_module;

        IF p_new_valid_reals <> NIL THEN
          FOR valid_real_index := 1 TO active_number DO
            p_new_valid_reals^ [valid_real_index] := p_old_valid_reals^ [valid_real_index];
          FOREND;

        ELSE { No space for new valid_reals. }
          p_new_valid_reals := NIL;
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        IFEND;

      ELSE { No old valid_reals are active. }
        p_new_valid_reals := NIL;
      IFEND;
    PROCEND copy_valid_reals;

?? OLDTITLE ??
?? NEWTITLE := 'copy_valid_strings', EJECT ??

    PROCEDURE [INLINE] copy_valid_strings
      (    active_number: fdt$number_valid_strings;
           p_old_valid_strings: ^array [1 .. * ] OF fdt$valid_string_definition;
           p_old_form_module: ^fdt$form_module;
       VAR p_new_form_module: ^fdt$form_module;
           p_new_form_definition: ^fdt$form_definition;
       VAR p_new_valid_strings: ^array [1 .. * ] of fdt$valid_string_definition;
       VAR status: ost$status);

      VAR
        p_new_valid_string: ^fdt$valid_string,
        p_old_valid_string: ^fdt$valid_string,
        valid_string_index: fdt$valid_string_index;

      status.normal := TRUE;
      IF active_number > 0 THEN
        NEXT p_new_valid_strings: [1 .. active_number] IN p_new_form_module;
        IF p_new_valid_strings <> NIL THEN

        /copy_strings/
          FOR valid_string_index := 1 TO active_number DO
            p_old_valid_string := #PTR (p_old_valid_strings^ [valid_string_index].p_valid_string,
                  p_old_form_module^);
            NEXT p_new_valid_string: [STRLENGTH (p_old_valid_string^)] IN p_new_form_module;
            IF p_new_valid_string <> NIL THEN
              p_new_valid_string^ := p_old_valid_string^;
              p_new_valid_strings^ [valid_string_index].p_valid_string :=
                    #REL (p_new_valid_string, p_new_form_module^);

            ELSE { No space for new valid string. }
              p_new_valid_strings := NIL;
              osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
              EXIT /copy_strings/;
            IFEND;
          FOREND /copy_strings/;

        ELSE { No space for new valid_strings. }
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        IFEND;

      ELSE { No old valid_strings are active. }
        p_new_valid_strings := NIL;
      IFEND;
    PROCEND copy_valid_strings;

?? OLDTITLE ??
?? NEWTITLE := 'copy_variable_definitions', EJECT ??

    PROCEDURE [INLINE] copy_variable_definitions
      (    active_number: fdt$number_variables;
           p_old_form_module: ^fdt$form_module;
           p_old_form_definition: ^fdt$form_definition;
           p_old_variable_definitions: ^array [1 .. * ] OF fdt$form_variable_definition;
           p_new_form_status: ^fdt$form_status;
           p_new_form_definition: ^fdt$form_definition;
       VAR p_new_form_module: ^fdt$form_module;
       VAR status: ost$status);

      VAR
        p_new_error_message: ^fdt$error_message,
        p_new_help_message: ^fdt$help_message,
        p_new_text: ^fdt$text,
        p_new_valid_integers: ^array [1 .. * ] of fdt$valid_integer_range,
        p_new_valid_reals: ^array [1 .. * ] of fdt$valid_real_range,
        p_new_valid_strings: ^array [1 .. * ] of fdt$valid_string_definition,
        p_new_variable_definition: ^fdt$form_variable_definition,
        p_new_variable_definitions: ^array [1 .. * ] of fdt$form_variable_definition,
        p_old_error_message: ^fdt$error_message,
        p_old_help_message: ^fdt$help_message,
        p_old_text: ^fdt$text,
        p_old_variable_definition: ^fdt$form_variable_definition,
        variable_index: fdt$variable_index;

      status.normal := TRUE;
      IF active_number = 0 THEN
        fdp$rel_variables (NIL, p_new_form_status);
        p_new_form_definition^.form_variable_definitions.active_number := 0;
        EXIT copy_variable_definitions;
      IFEND;

      NEXT p_new_variable_definitions: [1 .. active_number] IN p_new_form_module;
      IF p_new_variable_definitions = NIL THEN
        fdp$rel_variables (NIL, p_new_form_status);
        p_new_form_definition^.form_variable_definitions.active_number := 0;
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        EXIT copy_variable_definitions;
      IFEND;

      fdp$rel_variables (p_new_variable_definitions, p_new_form_status);
      p_new_form_definition^.form_variable_definitions.active_number := active_number;

    /copy_variables/
      FOR variable_index := 1 TO active_number DO
        p_new_variable_definition := ^p_new_variable_definitions^ [variable_index];
        p_old_variable_definition := ^p_old_variable_definitions^ [variable_index];
        p_new_variable_definition^ := p_old_variable_definition^;
        copy_added_variable_definition (p_old_form_definition,
              p_old_variable_definition, p_old_form_module,
              p_new_variable_definition, p_new_form_module, status);
        IF NOT status.normal THEN
          EXIT copy_variable_definitions;
        IFEND;

        IF (p_old_form_definition^.screen_formatting_version <
              fdc$validation_capability) THEN
          p_new_variable_definition^.terminal_user_entry := $fdt$terminal_user_entry
               [fdc$entry_optional];
        IFEND;

        CASE p_old_variable_definition^.error_definition.key OF

        = fdc$no_error_response, fdc$error_form =

{ Do nothing. The information has already been copied.

        = fdc$error_message =

          p_old_error_message := #PTR (p_old_variable_definition^.error_definition.p_error_message,
                p_old_form_module^);
          NEXT p_new_error_message: [STRLENGTH (p_old_error_message^)] IN p_new_form_module;
          IF p_new_error_message = NIL THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
            RETURN;
          IFEND;
          p_new_error_message^ := p_old_error_message^;
          p_new_variable_definition^.error_definition.p_error_message :=
                #REL (p_new_error_message, p_new_form_module^);

         = fdc$system_default_error =
           IF (p_old_form_definition^.screen_formatting_version <
                 fdc$validation_capability) THEN
             p_new_variable_definition^.error_definition.key := fdc$no_error_response;
           IFEND;

        ELSE { Invalid error definition key. }
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, '', status);
          EXIT copy_variable_definitions;
        CASEND;

        CASE p_old_variable_definition^.help_definition.key OF

        = fdc$no_help_response, fdc$help_form =

{ Do nothing. The information has already been copied.

        = fdc$help_message =

          p_old_help_message := #PTR (p_old_variable_definition^.help_definition.p_help_message,
                p_old_form_module^);
          NEXT p_new_help_message: [STRLENGTH (p_old_help_message^)] IN p_new_form_module;
          IF p_new_help_message = NIL THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
            EXIT copy_variable_definitions;
          IFEND;
          p_new_help_message^ := p_old_help_message^;
          p_new_variable_definition^.help_definition.p_help_message :=
                #REL (p_new_help_message, p_new_form_module^);

         = fdc$system_default_help =
           IF (p_old_form_definition^.screen_formatting_version <
                 fdc$validation_capability) THEN
             p_new_variable_definition^.help_definition.key := fdc$no_help_response;
           IFEND;

        ELSE { Invalid error definition key. }
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, '', status);
          EXIT copy_variable_definitions;
        CASEND;

        copy_valid_integers (p_old_variable_definition^.valid_integer_ranges.active_number,
              fdp$ptr_valid_integers (p_old_variable_definition^.valid_integer_ranges, p_old_form_module),
              p_new_form_definition, p_new_form_module, p_new_valid_integers, status);
        IF NOT status.normal THEN
          fdp$rel_valid_integers (p_new_valid_integers, p_new_form_module, p_new_variable_definition^.
                valid_integer_ranges);
          p_new_variable_definition^.valid_integer_ranges.active_number := 0;
          EXIT copy_variable_definitions;
        IFEND;

        fdp$rel_valid_integers (p_new_valid_integers, p_new_form_module, p_new_variable_definition^.
              valid_integer_ranges);
        p_new_variable_definition^.valid_integer_ranges.active_number := p_new_variable_definition^.
              valid_integer_ranges.total_number;
        copy_valid_reals (p_old_variable_definition^.valid_real_ranges.active_number,
              fdp$ptr_valid_reals (p_old_variable_definition^.valid_real_ranges, p_old_form_module),
              p_new_form_definition, p_new_form_module, p_new_valid_reals, status);
        IF NOT status.normal THEN
          fdp$rel_valid_reals (p_new_valid_reals, p_new_form_module, p_new_variable_definition^.
                valid_real_ranges);
          p_new_variable_definition^.valid_real_ranges.active_number := 0;
           EXIT copy_variable_definitions;
        IFEND;
        fdp$rel_valid_reals (p_new_valid_reals, p_new_form_module, p_new_variable_definition^.
              valid_real_ranges);
        p_new_variable_definition^.valid_real_ranges.active_number := p_new_variable_definition^.
              valid_real_ranges.total_number;

        copy_valid_strings (p_old_variable_definition^.valid_strings.active_number,
              fdp$ptr_valid_strings (p_old_variable_definition^.valid_strings, p_old_form_module),
              p_old_form_module, p_new_form_module, p_new_form_definition, p_new_valid_strings, status);
        IF NOT status.normal THEN
          fdp$rel_valid_strings (p_new_valid_strings, p_new_form_module, p_new_variable_definition^.
                valid_strings);
          p_new_variable_definition^.valid_strings.active_number := 0;
          EXIT copy_variable_definitions;
        IFEND;
        fdp$rel_valid_strings (p_new_valid_strings, p_new_form_module, p_new_variable_definition^.
              valid_strings);
        p_new_variable_definition^.valid_strings.active_number := p_new_variable_definition^.valid_strings.
              total_number;
      FOREND /copy_variables/;
    PROCEND copy_variable_definitions;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    p_to_form_module := p_to_form_status^.p_form_module;
    p_from_form_module := p_from_form_status^.p_form_module;
    p_from_form_definition := p_from_form_status^.p_form_definition;

{ Copy form definition. }

    NEXT p_to_form_definition IN p_to_form_status^.p_form_module;
    p_to_form_definition^ := p_from_form_definition^;
    p_to_form_status^.p_form_definition := p_to_form_definition;

    CASE p_from_form_definition^.help_definition.key OF

    = fdc$no_help_response, fdc$help_form =

{ Do nothing. The help definition has already been copied. }

    = fdc$help_message =
      p_from_help_message := #PTR (p_from_form_definition^.help_definition.p_help_message,
            p_from_form_module^);
      NEXT p_to_help_message: [STRLENGTH (p_from_help_message^)] IN p_to_form_status^.p_form_module;
      IF p_to_help_message = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;
      p_to_help_message^ := p_from_help_message^;
      p_to_form_definition^.help_definition.p_help_message := #REL (p_to_help_message, p_to_form_module^);

     = fdc$system_default_help =
       IF p_from_form_definition^.screen_formatting_version <
             fdc$validation_capability THEN
         p_to_form_definition^.help_definition.key := fdc$no_help_response;
       IFEND;

    ELSE { Invalid help key. }
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
          'invalid help key', status);
      RETURN;
    CASEND;

{ Initialize help_message_form for prior versions of forms.

    IF p_from_form_definition^.screen_formatting_version < fdc$message_form_capability THEN
      p_to_form_definition^.help_message_form := osc$null_name;
    IFEND;

    copy_comments (p_from_form_definition^.comment_definitions.active_number, p_to_form_definition^.
          comment_definitions, p_from_form_module, p_to_form_status^.p_form_module,
          p_to_form_definition^.comment_definitions, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    copy_display_definitions (p_from_form_definition^.display_definitions.active_number,
          p_from_form_status^.p_display_definitions, p_to_form_status, p_to_form_definition,
          p_to_form_status^.p_form_module, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    copy_event_definitions (p_from_form_definition,
          p_from_form_definition^.event_definitions.active_number, p_from_form_status^.
          p_event_definitions, p_to_form_status, p_to_form_definition, p_to_form_status^.p_form_module,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    copy_object_definitions (p_from_form_definition^.form_object_definitions.active_number,
          p_from_form_module, p_from_form_status^.p_form_object_definitions, p_to_form_status,
          p_to_form_definition, p_to_form_status^.p_form_module, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    copy_table_definitions (p_from_form_definition^.form_table_definitions.active_number,
          p_from_form_module, p_from_form_status^.p_form_table_definitions, p_to_form_status,
          p_to_form_definition, p_to_form_status^.p_form_module, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    copy_variable_definitions (p_from_form_definition^.form_variable_definitions.active_number,
         p_from_form_module, p_from_form_definition,
         p_from_form_status^.p_form_variable_definitions, p_to_form_status,
         p_to_form_definition, p_to_form_status^.p_form_module, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    copy_record_definitions (p_from_form_definition^.record_definitions.active_number,
         p_from_form_status^.p_form_record_definitions, p_to_form_definition, p_to_form_status,
         p_to_form_status^.p_form_module, status);

    IF p_to_form_definition^.screen_formatting_version < fdc$im_smart_capability THEN
      p_to_form_definition^.invalid_data_character.defined := FALSE;
    IFEND;
    p_to_form_definition^.screen_formatting_version := fdc$screen_formatting_version;

  PROCEND copy_form;

?? TITLE := 'fdp$create_design_text', EJECT ??
*copyc fdh$create_design_text

  PROCEDURE [XDCL] fdp$create_design_text
    (    target_form_identifier: fdt$form_identifier;
         design_form_identifier: fdt$form_identifier;
     VAR status: ost$status);

    VAR
      display_attribute_set: fdt$display_attribute_set,
      initial_value_length: fdt$program_variable_length,
      number_objects: fdt$number_objects,
      object_attributes: array [1 .. 2] of fdt$object_attribute,
      object_definition: fdt$object_definition,
      form_object_key: fdt$form_object_key,
      object_index: fdt$object_index,
      occurrence: fdt$occurrence,
      p_design_text: ^fdt$text,
      p_design_form_status: ^fdt$form_status,
      p_form_definition: ^fdt$form_definition,
      p_form_module: ^fdt$form_module,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_program_variable: ^cell,
      p_saved_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_target_form_status: ^fdt$form_status,
      p_text: ^fdt$text,
      text_length: fdt$text_length,
      variable_name: ost$name,
      variable_status: fdt$variable_status,
      x_increment: fdt$x_increment,
      y_increment: fdt$y_increment,
      x_position: fdt$x_position,
      y_position: fdt$y_position;

?? NEWTITLE := 'condition_handler', EJECT ??

  PROCEDURE condition_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         stack_frame_save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    CASE condition.selector OF

    = pmc$system_conditions =
      IF (condition.system_conditions * $pmt$system_conditions
            [pmc$instruction_specification, pmc$address_specification,
            pmc$access_violation, pmc$invalid_segment_ring_0, pmc$divide_fault,
            pmc$arithmetic_overflow, pmc$exponent_overflow,
            pmc$exponent_underflow, pmc$fp_significance_loss,
            pmc$fp_indefinite, pmc$arithmetic_significance,
            pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$create_design_text;
      IFEND;

    = pmc$user_defined_condition =
      IF condition.user_condition_name = cye$run_time_condition THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$create_design_text;
      IFEND;

    ELSE
      ;
    CASEND;
    pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
  PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_status (design_form_identifier, p_design_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT p_design_form_status^.design_form THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_design_form, p_design_form_status^.
            p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    fdp$find_change_form_definition (target_form_identifier, p_target_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_target_form_status^.p_form_definition;
    number_objects := p_form_definition^.form_object_definitions.active_number;
    IF number_objects = 0 THEN
      RETURN;
    IFEND;

    p_form_object_definitions := p_target_form_status^.p_form_object_definitions;
    p_form_module := p_target_form_status^.p_form_module;
    PUSH p_design_text: [p_design_form_status^.p_form_definition^.width];
    variable_name := p_design_form_status^.design_variable_name;

    IF p_form_definition^.form_area.key = fdc$defined_area THEN
      x_increment := p_form_definition^.form_area.x_position - 1;
      y_increment := p_form_definition^.form_area.y_position - 1;

    ELSE
      x_increment := 0;
      y_increment := 0;
    IFEND;

    display_attribute_set := p_form_definition^.display_attribute * fdv$colors;
    object_attributes [1].key := fdc$object_display;

{ Create objects on the design form from the target form. }
{ Constant text objects with the same attributes of the form }
{ and no name will become free text on the design form. }

    FOR object_index := 1 TO number_objects DO
      p_form_object_definition := ^p_form_object_definitions^ [object_index];
      x_position := p_form_object_definition^.x_position + x_increment;
      y_position := p_form_object_definition^.y_position + y_increment;
      form_object_key := p_form_object_definition^.key;
      object_attributes [1].display_attribute := p_form_object_definition^.display_attribute -
          $fdt$display_attribute_set [fdc$hidden];
      IF p_form_object_definition^.name <> osc$null_name THEN
        object_attributes [2].key := fdc$object_name;
        object_attributes [2].object_name := p_form_object_definition^.name;
        object_attributes [2].occurrence := p_form_object_definition^.occurrence;
      ELSE
        object_attributes [2].key := fdc$unused_object_entry;
      IFEND;
      CASE form_object_key OF

      = fdc$form_box =
        object_definition.key := fdc$box;
        object_definition.box_width := p_form_object_definition^.box_width;
        object_definition.box_height := p_form_object_definition^.box_height;
        fdp$create_object (design_form_identifier, x_position, y_position, object_definition,
              object_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = fdc$form_line =
        object_definition.key := fdc$line;
        object_definition.x_increment := p_form_object_definition^.x_increment;
        object_definition.y_increment := p_form_object_definition^.y_increment;
        fdp$create_object (design_form_identifier, x_position, y_position, object_definition,
              object_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = fdc$form_table =
        object_definition.key := fdc$table;
        object_definition.table_width := p_form_object_definition^.table_width;
        object_definition.table_height := p_form_object_definition^.table_height;
        fdp$create_object (design_form_identifier, x_position, y_position, object_definition,
              object_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = fdc$form_variable_text =
        object_definition.key := fdc$constant_text;
        object_definition.p_constant_text := fdp$ptr_text (p_form_object_definition^.text_variable_text,
              p_form_module);
        object_definition.constant_text_width := p_form_object_definition^.text_variable_width;
        IF ((object_attributes [1].display_attribute -
           $fdt$display_attribute_set [fdc$protect, fdc$display_left_to_right, fdc$display_right_to_left])
          = display_attribute_set) THEN
          object_attributes [1].display_attribute := p_design_form_status^.design_display_attribute;
        IFEND;
        fdp$create_object (design_form_identifier, x_position, y_position, object_definition,
              object_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = fdc$form_variable_text_box =
        object_definition.key := fdc$constant_text_box;
        object_definition.p_constant_box_text := fdp$ptr_text
              (p_form_object_definition^.variable_box_text, p_form_module);
        object_definition.constant_box_width := p_form_object_definition^.variable_box_width;
        object_definition.constant_box_height := p_form_object_definition^.variable_box_height;
        object_definition.constant_box_processing := p_form_object_definition^.variable_box_processing;
        IF ((object_attributes [1].display_attribute -
          $fdt$display_attribute_set [fdc$protect, fdc$display_left_to_right, fdc$display_right_to_left])
          = display_attribute_set) THEN
          object_attributes [1].display_attribute := p_design_form_status^.design_display_attribute;
        IFEND;
        fdp$create_object (design_form_identifier, x_position, y_position, object_definition,
              object_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = fdc$form_constant_text =
        p_text := fdp$ptr_text (p_form_object_definition^.constant_text, p_form_module);
        text_length := STRLENGTH (p_text^);

        IF (((object_attributes [1].display_attribute -
               $fdt$display_attribute_set [fdc$protect, fdc$display_left_to_right,
               fdc$display_right_to_left ])  =
               display_attribute_set) AND
              (p_form_object_definition^.name = osc$null_name)) THEN
          occurrence := y_position;
          fdp$get_string_variable (design_form_identifier, variable_name, occurrence, p_design_text^,
                variable_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          p_design_text^ (x_position, text_length) := p_text^;
          fdp$replace_string_variable (design_form_identifier, variable_name, occurrence, p_design_text^,
                variable_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        ELSE { The constant text has non color attributes. }
          IF ((object_attributes [1].display_attribute -
            $fdt$display_attribute_set [fdc$protect, fdc$display_left_to_right,
            fdc$display_right_to_left]) =
            display_attribute_set) THEN
            object_attributes [1].display_attribute := p_design_form_status^.design_display_attribute;
          IFEND;

          object_definition.key := fdc$constant_text;
          object_definition.p_constant_text := p_text;
          object_definition.constant_text_width := p_form_object_definition^.constant_text_width;
          fdp$create_object (design_form_identifier, x_position, y_position, object_definition,
                object_attributes, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      = fdc$form_constant_text_box =
        object_definition.key := fdc$constant_text_box;
        object_definition.p_constant_box_text := fdp$ptr_text
              (p_form_object_definition^.constant_box_text, p_form_module);
        object_definition.constant_box_width := p_form_object_definition^.constant_box_width;
        object_definition.constant_box_height := p_form_object_definition^.constant_box_height;
        object_definition.constant_box_processing := p_form_object_definition^.constant_box_processing;
        fdp$create_object (design_form_identifier, x_position, y_position, object_definition,
              object_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSE { Ignore objects not generated  by the user directly.  }
      CASEND;
    FOREND;


   IF ((x_increment = 0) AND (y_increment = 0)) THEN

{ The design and target forms have the same origin. }
{ Delete constant text objects from the target from that }
{ are free text on the design form.  The constant text objects }
{ on the target form will be re-created by the fdp$create_constant_text request. }


  /delete_constant_text/
    FOR object_index := 1 TO number_objects DO
      p_form_object_definition := ^p_form_object_definitions^ [object_index];
      CASE p_form_object_definition^.key OF

      = fdc$form_constant_text =
        IF (((p_form_object_definition^.display_attribute -
              $fdt$display_attribute_set [fdc$protect, fdc$display_left_to_right,
              fdc$display_right_to_left])  =
               display_attribute_set) AND
              (p_form_object_definition^.name = osc$null_name)) THEN
          fdp$delete_object (target_form_identifier, p_form_object_definition^.x_position,
                p_form_object_definition^.y_position, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      ELSE { Ignore objects not generated by the user directly.  }
      CASEND;
    FOREND /delete_constant_text/;

  ELSE { The design form and the target form do not same origin.}

{ Relocate objects on the target form to match those of the design form. }

    IF number_objects > 0 THEN
      PUSH p_saved_object_definitions: [1 .. number_objects];
      FOR object_index := 1 TO number_objects DO
        p_saved_object_definitions^ [object_index] := p_form_object_definitions^ [object_index];
      FOREND;
    IFEND;

  /delete_objects/
    FOR object_index := 1 TO number_objects DO
      p_form_object_definition := ^p_saved_object_definitions^ [object_index];
      fdp$delete_object (target_form_identifier, p_form_object_definition^.x_position,
           p_form_object_definition^.y_position, status);
    FOREND /delete_objects/;

{ Make target form area equal to design form area. }

    p_form_definition^.form_area := p_design_form_status^.p_form_definition^.form_area;

  /relocate_target_form/
    FOR object_index := 1 TO number_objects DO
      p_form_object_definition := ^p_saved_object_definitions^ [object_index];
      x_position := p_form_object_definition^.x_position + x_increment;
      y_position := p_form_object_definition^.y_position + y_increment;
      form_object_key := p_form_object_definition^.key;
      object_attributes [1].display_attribute := p_form_object_definition^.display_attribute -
           $fdt$display_attribute_set [fdc$hidden];
      IF p_form_object_definition^.name <> osc$null_name THEN
        object_attributes [2].key := fdc$object_name;
        object_attributes [2].object_name := p_form_object_definition^.name;
        object_attributes [2].occurrence := p_form_object_definition^.occurrence;
      ELSE
        object_attributes [2].key := fdc$unused_object_entry;
      IFEND;

      CASE form_object_key OF

      = fdc$form_box =
        object_definition.key := fdc$box;
        object_definition.box_width := p_form_object_definition^.box_width;
        object_definition.box_height := p_form_object_definition^.box_height;
        fdp$create_object (target_form_identifier, x_position, y_position, object_definition,
              object_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = fdc$form_line =
        object_definition.key := fdc$line;
        object_definition.x_increment := p_form_object_definition^.x_increment;
        object_definition.y_increment := p_form_object_definition^.y_increment;
        fdp$create_object (target_form_identifier, x_position, y_position, object_definition,
              object_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = fdc$form_table =
        object_definition.key := fdc$table;
        object_definition.table_width := p_form_object_definition^.table_width;
        object_definition.table_height := p_form_object_definition^.table_height;
        fdp$create_object (target_form_identifier, x_position, y_position, object_definition,
              object_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = fdc$form_variable_text =
        object_definition.key := fdc$variable_text;
        object_definition.p_variable_text := fdp$ptr_text (p_form_object_definition^.text_variable_text,
              p_form_module);
        object_definition.variable_text_width := p_form_object_definition^.text_variable_width;
        fdp$create_object (target_form_identifier, x_position, y_position, object_definition,
              object_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = fdc$form_variable_text_box =
        object_definition.key := fdc$variable_text_box;
        object_definition.p_variable_box_text := fdp$ptr_text
              (p_form_object_definition^.variable_box_text, p_form_module);
        object_definition.variable_box_width := p_form_object_definition^.variable_box_width;
        object_definition.variable_box_height := p_form_object_definition^.variable_box_height;
        object_definition.variable_box_processing := p_form_object_definition^.variable_box_processing;
        fdp$create_object (target_form_identifier, x_position, y_position, object_definition,
              object_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = fdc$form_constant_text =
        p_text := fdp$ptr_text (p_form_object_definition^.constant_text, p_form_module);
        text_length := STRLENGTH (p_text^);

        IF (((object_attributes [1].display_attribute - $fdt$display_attribute_set [fdc$protect,
               fdc$display_left_to_right, fdc$display_right_to_left])  =
               display_attribute_set) AND
              (p_form_object_definition^.name = osc$null_name)) THEN

{ This is free text on the design form. Do not create an object on the target form. }

          CYCLE /relocate_target_form/;
        IFEND;

          object_definition.key := fdc$constant_text;
          object_definition.p_constant_text := p_text;
          object_definition.constant_text_width := p_form_object_definition^.constant_text_width;
          fdp$create_object (target_form_identifier, x_position, y_position, object_definition,
                object_attributes, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

      = fdc$form_constant_text_box =
        object_definition.key := fdc$constant_text_box;
        object_definition.p_constant_box_text := fdp$ptr_text
              (p_form_object_definition^.constant_box_text, p_form_module);
        object_definition.constant_box_width := p_form_object_definition^.constant_box_width;
        object_definition.constant_box_height := p_form_object_definition^.constant_box_height;
        object_definition.constant_box_processing := p_form_object_definition^.constant_box_processing;
        fdp$create_object (target_form_identifier, x_position, y_position, object_definition,
              object_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSE { Ignore objects not generated  by the user directly.  }
      CASEND;
    FOREND /relocate_target_form/;
  IFEND;
  PROCEND fdp$create_design_text;

?? TITLE := 'fdp$create_constant_text', EJECT ??
*copyc fdh$create_constant_text

  PROCEDURE [XDCL] fdp$create_constant_text
    (    design_form_identifier: fdt$form_identifier;
         target_form_identifier: fdt$form_identifier;
     VAR status: ost$status);


    VAR
      design_text_length: fdt$text_length,
      display_attribute_set: fdt$display_attribute_set,
      end_x_position: fdt$x_position,
      object_attributes: array [1 .. 1] of fdt$object_attribute,
      object_definition: fdt$object_definition,
      object_exists: boolean,
      object_index: fdt$object_index,
      object_x_position: fdt$x_position,
      object_y_position: fdt$y_position,
      p_form_image: ^fdt$form_image,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_design_form_definition: ^fdt$form_definition,
      p_design_form_status: ^fdt$form_status,
      p_target_form_definition: ^fdt$form_definition,
      p_target_form_status: ^fdt$form_status,
      p_object_text: ^fdt$text,
      p_text: ^fdt$text,
      max_x_position: fdt$x_position,
      max_y_position: fdt$y_position,
      min_x_position: fdt$x_position,
      min_y_position: fdt$y_position,
      number_objects: fdt$number_objects,
      start_x_position: fdt$x_position,
      variable_name: ost$name,
      variable_status: fdt$variable_status,
      x_increment: fdt$x_increment,
      y_increment: fdt$y_increment,
      x_position: fdt$x_position,
      y_position: fdt$y_position;

?? NEWTITLE := 'condition_handler', EJECT ??

  PROCEDURE condition_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         stack_frame_save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    CASE condition.selector OF

    = pmc$system_conditions =
      IF (condition.system_conditions * $pmt$system_conditions
            [pmc$instruction_specification, pmc$address_specification,
            pmc$access_violation, pmc$invalid_segment_ring_0, pmc$divide_fault,
            pmc$arithmetic_overflow, pmc$exponent_overflow,
            pmc$exponent_underflow, pmc$fp_significance_loss,
            pmc$fp_indefinite, pmc$arithmetic_significance,
            pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$create_constant_text;
      IFEND;

    = pmc$user_defined_condition =
      IF condition.user_condition_name = cye$run_time_condition THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$create_constant_text;
      IFEND;

    ELSE
      ;
    CASEND;
    pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
  PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_status (design_form_identifier, p_design_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT p_design_form_status^.design_form THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_design_form, p_design_form_status^.
            p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    fdp$find_form_definition (target_form_identifier, p_target_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_design_form_definition := p_design_form_status^.p_form_definition;
    p_target_form_definition := p_target_form_status^.p_form_definition;
    number_objects := p_target_form_definition^.form_object_definitions.active_number;
    p_form_object_definitions := p_target_form_status^.p_form_object_definitions;
    display_attribute_set := p_target_form_definition^.display_attribute * fdv$colors;

    IF p_target_form_definition^.form_area.key = fdc$defined_area THEN
      min_x_position := p_target_form_definition^.form_area.x_position;
      min_y_position := p_target_form_definition^.form_area.y_position;
      max_x_position := min_x_position + p_target_form_definition^.form_area.width - 1;
      max_y_position := min_y_position + p_target_form_definition^.form_area.height - 1;

      IF max_x_position > p_design_form_definition^.form_area.width THEN
        max_x_position := p_design_form_definition^.form_area.width;
      IFEND;

      IF max_y_position > p_design_form_definition^.form_area.height  THEN
        max_y_position := p_design_form_definition^.form_area.height;
      IFEND;

    ELSE { The design form always has a  defined  area.  }
      max_x_position := p_design_form_definition^.form_area.width;
      max_y_position := p_design_form_definition^.form_area.height;
      min_x_position := p_design_form_definition^.form_area.x_position;
      min_y_position := p_design_form_definition^.form_area.y_position;
    IFEND;

    x_increment := min_x_position - 1;
    y_increment := min_y_position - 1;

    variable_name := p_design_form_status^.design_variable_name;
    object_definition.key := fdc$constant_text;
    object_attributes [1].key := fdc$unused_object_entry;
    design_text_length := p_design_form_definition^.form_area.width;
    PUSH p_text: [design_text_length];
    p_form_image := p_design_form_status^.p_form_image;

{ Get free text entered by the terminal user. }
{ Create constant text objects for the free text. }

  /read_lines/
    FOR y_position := min_y_position TO max_y_position DO
      fdp$get_string_variable (design_form_identifier, variable_name, y_position, p_text^, variable_status,
            status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
              'create constant text get failed', status);
        RETURN;
      IFEND;

      object_exists := FALSE;
      x_position := min_x_position;

{ Ignore spaces before free text. }

    /find_start_object/
      WHILE x_position < max_x_position + 1 DO
        IF p_text^ (x_position, 1) = ' ' THEN
          x_position := x_position + 1;
          CYCLE /find_start_object/;
        IFEND;
        object_exists := TRUE;
        start_x_position := x_position;
        x_position := x_position + 1;

      /find_end_object/
        WHILE x_position < max_x_position + 1 DO
          IF p_text^ (x_position, 1) <> ' ' THEN
            x_position := x_position + 1;
            CYCLE /find_end_object/;
          IFEND;

{ Scan is at end of word.  Try to make the object include a sentence. }
{ The object cannot be intersected by a line or a box. }

          IF ((p_form_image <> NIL) AND
               (p_form_image^ [y_position] (x_position, 1) = ' ') AND
               ((x_position + 1) < (max_x_position + 1)) AND
               (p_text^ (x_position + 1, 1) <> ' ')) THEN
            x_position := x_position + 1;
            CYCLE /find_end_object/;
          IFEND;

          end_x_position := x_position - 1;
          x_position := x_position + 1;

          object_definition.p_constant_text := ^p_text^ (start_x_position, end_x_position - start_x_position +
                1);
          object_definition.constant_text_width := end_x_position - start_x_position + 1;
          object_x_position := start_x_position - x_increment;
          object_y_position := y_position - y_increment;
          fdp$create_object (target_form_identifier, object_x_position, object_y_position, object_definition,
                object_attributes, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          object_exists := FALSE;
          CYCLE /find_start_object/;
        WHILEND /find_end_object/;
      WHILEND /find_start_object/;

{ Complete any started object. }

      IF object_exists THEN
        end_x_position := max_x_position;
        object_definition.p_constant_text := ^p_text^ (start_x_position, end_x_position - start_x_position +
              1);
        object_definition.constant_text_width := end_x_position - start_x_position + 1;
        object_x_position := start_x_position - x_increment;
        object_y_position := y_position - y_increment;
        fdp$create_object (target_form_identifier, object_x_position, object_y_position, object_definition,
              object_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND /read_lines/;
  PROCEND fdp$create_constant_text;

?? TITLE := 'fdp$create_mark', EJECT ??
*copyc fdh$create_mark

  PROCEDURE [XDCL] fdp$create_mark
    (    form_identifier: fdt$form_identifier;
         start_x_position: fdt$x_position;
         start_y_position: fdt$y_position;
         end_x_position: fdt$x_position;
         end_y_position: fdt$y_position;
     VAR status: ost$status);

    VAR
      active_objects: fdt$number_objects,
      character_position: fdt$character_position,
      cursor_x_position: fdt$x_position,
      cursor_y_position: fdt$y_position,
      end_object_x_position: fdt$x_position,
      end_object_y_position: fdt$y_position,
      high_x_position: fdt$x_position,
      high_y_position: fdt$y_position,
      local_status: ost$status,
      low_x_position: fdt$x_position,
      low_y_position: fdt$y_position,
      object_exists: boolean,
      object_index: fdt$object_index,
      parent_object_index: fdt$object_index,
      object_x_position: fdt$x_position,
      object_y_position: fdt$y_position,
      occurrence_exists: boolean,
      name_exists: boolean,
      occurrence: fdt$occurrence,
      p_form_definition: ^fdt$form_definition,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_module: ^fdt$form_module,
      p_form_status: ^fdt$form_status,
      screen_change: fdt$screen_change,
      text_length: fdt$text_length,
      variable_name: ost$name,
      width: fdt$width,
      y_position: fdt$y_position;

?? NEWTITLE := 'condition_handler', EJECT ??

  PROCEDURE condition_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         stack_frame_save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    CASE condition.selector OF

    = pmc$system_conditions =
      IF (condition.system_conditions * $pmt$system_conditions
            [pmc$instruction_specification, pmc$address_specification,
            pmc$access_violation, pmc$invalid_segment_ring_0, pmc$divide_fault,
            pmc$arithmetic_overflow, pmc$exponent_overflow,
            pmc$exponent_underflow, pmc$fp_significance_loss,
            pmc$fp_indefinite, pmc$arithmetic_significance,
            pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$create_mark;
      IFEND;

    = pmc$user_defined_condition =
      IF condition.user_condition_name = cye$run_time_condition THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$create_mark;
      IFEND;

    ELSE
      ;
    CASEND;
    pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
  PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$check_for_active_form (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ A mark may only occur on a design form. }

    p_form_definition := p_form_status^.p_form_definition;
    IF NOT p_form_status^.design_form THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$create_mark_invalid, p_form_definition^.
            form_name, status);
      RETURN;
    IFEND;

    IF start_y_position > end_y_position THEN
      high_y_position := start_y_position;
      low_y_position := end_y_position;
    ELSE
      low_y_position := start_y_position;
      high_y_position := end_y_position;
    IFEND;

    IF start_x_position > end_x_position THEN
      high_x_position := start_x_position;
      low_x_position := end_x_position;
    ELSE
      low_x_position := start_x_position;
      high_x_position := end_x_position;
    IFEND;

{ The mark must be inside area occupied by form. }

    IF p_form_definition^.form_area.key = fdc$defined_area THEN
      IF high_x_position > p_form_definition^.form_area.width THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$mark_outside_form, p_form_definition^.
              form_name, status);
        RETURN;
      IFEND;

      IF high_y_position > p_form_definition^.form_area.height THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$mark_outside_form, p_form_definition^.
              form_name, status);
        RETURN;
      IFEND;
    IFEND;

    active_objects := p_form_definition^.form_object_definitions.active_number;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    p_form_module := p_form_status^.p_form_module;

{ If the marked area contains more than one character, the mark must }
{ completely contain any affected objects. }

    IF NOT ((low_x_position = high_x_position) AND (low_y_position = high_y_position)) THEN
      check_for_sliced_objects (p_form_status, p_form_definition, p_form_module, p_form_object_definitions,
            active_objects, low_x_position, low_y_position, high_x_position, high_y_position, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Delete previous mark if any.  Only one mark at a time is permitted. }

    IF p_form_status^.mark_defined THEN
      fdp$delete_mark (form_identifier, local_status);
    IFEND;

    variable_name := p_form_status^.design_variable_name;
    p_form_status^.mark_start_x_position := low_x_position;
    p_form_status^.mark_end_x_position := high_x_position;
    p_form_status^.mark_start_y_position := low_y_position;
    p_form_status^.mark_end_y_position := high_y_position;
    p_form_status^.mark_defined := TRUE;

    screen_change.key := fdc$create_mark;
    screen_change.mark_object := FALSE;
    screen_change.create_mark_form_identifier := form_identifier;
    screen_change.start_x_position := low_x_position;
    screen_change.end_x_position := high_x_position;
    cursor_x_position := high_x_position + 1;
    cursor_y_position := high_y_position;

{ Mark affected lines of free text on the design form. }

    FOR y_position := low_y_position TO high_y_position DO
      occurrence := y_position;
      fdp$find_object_definition (variable_name, occurrence, p_form_status^.p_form_object_definitions,
            p_form_definition^.form_object_definitions.active_number, p_form_object_definition, object_index,
            name_exists, occurrence_exists);

      IF NOT name_exists THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
        'create mark design variable not found', status);
        RETURN;
      IFEND;

      IF NOT occurrence_exists THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
        'create mark design occurrence not found', status);
        RETURN;
      IFEND;

      screen_change.start_y_position := y_position;
      screen_change.end_y_position := y_position;
      screen_change.create_mark_object_index := object_index;
      fdp$record_screen_change (screen_change, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

{ Mark objects by adding inverse video to their display attributes. }
{ If mark is on any part of object, mark the entire object. }

    screen_change.key := fdc$set_attribute;

  /find_objects/
    FOR object_index := 1 TO active_objects DO
      p_form_object_definition := ^p_form_object_definitions^ [object_index];

      object_x_position := p_form_object_definition^.x_position;
      object_y_position := p_form_object_definition^.y_position;
      CASE p_form_object_definition^.key OF

      = fdc$form_constant_text =

        end_object_x_position := object_x_position + p_form_object_definition^.constant_text_width - 1;
        IF ((low_y_position <= object_y_position) AND (high_y_position >= object_y_position) AND
              (low_x_position <= object_x_position) AND (high_x_position >= end_object_x_position)) THEN
          screen_change.attribute := $fdt$display_attribute_set [fdc$inverse_video] +
                p_form_object_definition^.display_attribute;
          screen_change.attribute_object_index := object_index;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          CYCLE /find_objects/;
        IFEND;

        IF ((low_y_position >= object_y_position) AND (high_y_position <= object_y_position) AND
              (low_x_position >= object_x_position) AND (high_x_position <= end_object_x_position)) THEN
          screen_change.attribute := $fdt$display_attribute_set [fdc$inverse_video] +
                p_form_object_definition^.display_attribute;
          screen_change.attribute_object_index := object_index;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          CYCLE /find_objects/;
        IFEND;

      = fdc$form_constant_text_box =
        end_object_x_position := object_x_position + p_form_object_definition^.constant_box_width - 1;
        end_object_y_position := object_y_position + p_form_object_definition^.constant_box_height - 1;
        IF ((low_y_position <= object_y_position) AND (high_y_position >= end_object_y_position) AND
              (low_x_position <= object_x_position) AND (high_x_position >= end_object_x_position)) THEN
          screen_change.attribute_object_index := object_index;
          screen_change.attribute := $fdt$display_attribute_set [fdc$inverse_video] +
                p_form_object_definition^.display_attribute;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          CYCLE /find_objects/;
        IFEND;

        IF ((low_y_position >= object_y_position) AND (high_y_position <= end_object_y_position) AND
              (low_x_position >= object_x_position) AND (high_x_position <= end_object_x_position)) THEN
          screen_change.attribute := $fdt$display_attribute_set [fdc$inverse_video] +
                p_form_object_definition^.display_attribute;
          screen_change.attribute_object_index := object_index;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          CYCLE /find_objects/;
        IFEND;

      = fdc$form_box =
        end_object_x_position := object_x_position + p_form_object_definition^.box_width - 1;
        end_object_y_position := object_y_position + p_form_object_definition^.box_height - 1;
        IF ((low_x_position <= object_x_position) AND (low_y_position <= object_y_position) AND
              (high_x_position >= end_object_x_position) AND (high_y_position >= end_object_y_position)) THEN
          screen_change.attribute := $fdt$display_attribute_set [fdc$inverse_video] +
                p_form_object_definition^.display_attribute;
          screen_change.attribute_object_index := object_index;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          CYCLE /find_objects/;
        IFEND;

        { Check for mark on horizontal  lines of box. }

        IF ((low_y_position = object_y_position) OR (high_y_position = end_object_y_position)) THEN
          IF ((low_x_position >= object_x_position) AND (high_x_position <= end_object_x_position)) THEN
            screen_change.attribute_object_index := object_index;
            screen_change.attribute := $fdt$display_attribute_set [fdc$inverse_video] +
                  p_form_object_definition^.display_attribute;
            fdp$record_screen_change (screen_change, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            CYCLE /find_objects/;
          IFEND;
        IFEND;

        { Check for mark on vertical lines of box. }

        IF ((low_x_position = object_x_position) OR (high_x_position = end_object_x_position)) THEN
          IF ((low_y_position >= object_y_position) AND (high_y_position <= end_object_y_position)) THEN
            screen_change.attribute_object_index := object_index;
            screen_change.attribute := $fdt$display_attribute_set [fdc$inverse_video] +
                  p_form_object_definition^.display_attribute;
            fdp$record_screen_change (screen_change, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            CYCLE /find_objects/;
          IFEND;
        IFEND;

      = fdc$form_line =
        end_object_x_position := object_x_position + p_form_object_definition^.x_increment;
        end_object_y_position := object_y_position + p_form_object_definition^.y_increment;
        IF ((low_x_position <= object_x_position) AND (low_y_position <= object_y_position) AND
              (high_x_position >= end_object_x_position) AND (high_y_position >= end_object_y_position)) THEN
          screen_change.attribute := $fdt$display_attribute_set [fdc$inverse_video] +
                p_form_object_definition^.display_attribute;
          screen_change.attribute_object_index := object_index;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          CYCLE /find_objects/;
        IFEND;

        IF ((low_x_position >= object_x_position) AND (low_y_position >= object_y_position) AND
              (high_x_position <= end_object_x_position) AND (high_y_position <= end_object_y_position)) THEN
          screen_change.attribute_object_index := object_index;
          screen_change.attribute := $fdt$display_attribute_set [fdc$inverse_video] +
                p_form_object_definition^.display_attribute;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          CYCLE /find_objects/;
        IFEND;

      ELSE

{ Ignore object.

      CASEND;

    FOREND /find_objects/;
  PROCEND fdp$create_mark;

?? TITLE := 'fdp$delete_mark', EJECT ??
*copyc fdh$delete_mark

  PROCEDURE [XDCL] fdp$delete_mark
    (    form_identifier: fdt$form_identifier;
     VAR status: ost$status);

    VAR
      active_objects: fdt$number_objects,
      character_position: fdt$character_position,
      end_object_x_position: fdt$x_position,
      end_object_y_position: fdt$y_position,
      high_x_position: fdt$x_position,
      high_y_position: fdt$y_position,
      local_status: ost$status,
      low_x_position: fdt$x_position,
      low_y_position: fdt$y_position,
      object_index: fdt$object_index,
      object_x_position: fdt$x_position,
      object_y_position: fdt$y_position,
      name_exists: boolean,
      occurrence: fdt$occurrence,
      occurrence_exists: boolean,
      p_form_definition: ^fdt$form_definition,
      p_form_module: ^fdt$form_module,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_status: ^fdt$form_status,
      parent_object_index: fdt$object_index,
      screen_change: fdt$screen_change,
      variable_name: ost$name,
      width: fdt$width;

?? NEWTITLE := 'condition_handler', EJECT ??

  PROCEDURE condition_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         stack_frame_save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    CASE condition.selector OF

    = pmc$system_conditions =
      IF (condition.system_conditions * $pmt$system_conditions
            [pmc$instruction_specification, pmc$address_specification,
            pmc$access_violation, pmc$invalid_segment_ring_0, pmc$divide_fault,
            pmc$arithmetic_overflow, pmc$exponent_overflow,
            pmc$exponent_underflow, pmc$fp_significance_loss,
            pmc$fp_indefinite, pmc$arithmetic_significance,
            pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$delete_mark;
      IFEND;

    = pmc$user_defined_condition =
      IF condition.user_condition_name = cye$run_time_condition THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$delete_mark;
      IFEND;

    ELSE
      ;
    CASEND;
    pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
  PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$check_for_active_form (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    IF NOT p_form_status^.design_form THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$delete_mark_invalid, p_form_definition^.
            form_name, status);
      RETURN;
    IFEND;

    IF NOT p_form_status^.mark_defined THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_mark_defined, p_form_definition^.
            form_name, status);
      RETURN;
    IFEND;

    p_form_status^.mark_defined := FALSE;
    screen_change.key := fdc$delete_mark;
    screen_change.delete_mark_object := FALSE;
    screen_change.delete_mark_form_identifier := form_identifier;
    variable_name := p_form_status^.design_variable_name;
    low_y_position := p_form_status^.mark_start_y_position;
    high_y_position := p_form_status^.mark_end_y_position;
    low_x_position := p_form_status^.mark_start_x_position;
    high_x_position := p_form_status^.mark_end_x_position;

{ Delete mark on free text of design form. }

    FOR occurrence := low_y_position TO high_y_position DO
      fdp$find_object_definition (variable_name, occurrence, p_form_status^.p_form_object_definitions,
            p_form_definition^.form_object_definitions.active_number, p_form_object_definition, object_index,
            name_exists, occurrence_exists);
      IF NOT name_exists THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
             'delete mark design variable not found', status);
        RETURN;
      IFEND;

      IF NOT occurrence_exists THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
             'delete mark design occurrence not found', status);
        RETURN;
      IFEND;

      screen_change.delete_mark_object_index := object_index;
      fdp$record_screen_change (screen_change, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    active_objects := p_form_definition^.form_object_definitions.active_number;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    screen_change.key := fdc$set_attribute;

{ Delete marks on objects. }
{ Set display attributes of object to its defined state. }

  /find_objects/
    FOR object_index := 1 TO active_objects DO
      p_form_object_definition := ^p_form_object_definitions^ [object_index];

      object_x_position := p_form_object_definition^.x_position;
      object_y_position := p_form_object_definition^.y_position;
      CASE p_form_object_definition^.key OF

      = fdc$form_constant_text =

        end_object_x_position := object_x_position + p_form_object_definition^.constant_text_width - 1;
        IF ((low_y_position <= object_y_position) AND (high_y_position >= object_y_position) AND
              (low_x_position <= object_x_position) AND (high_x_position >= end_object_x_position)) THEN
          screen_change.attribute := p_form_object_definition^.display_attribute;
          screen_change.attribute_object_index := object_index;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          CYCLE /find_objects/;
        IFEND;

        IF ((low_y_position >= object_y_position) AND (high_y_position <= object_y_position) AND
              (low_x_position >= object_x_position) AND (high_x_position <= end_object_x_position)) THEN
          screen_change.attribute := p_form_object_definition^.display_attribute;
          screen_change.attribute_object_index := object_index;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          CYCLE /find_objects/;
        IFEND;

      = fdc$form_constant_text_box =
        end_object_x_position := object_x_position + p_form_object_definition^.constant_box_width - 1;
        end_object_y_position := object_y_position + p_form_object_definition^.constant_box_height - 1;
        IF ((low_y_position <= object_y_position) AND (high_y_position >= end_object_y_position) AND
              (low_x_position <= object_x_position) AND (high_x_position >= end_object_x_position)) THEN
          screen_change.attribute_object_index := object_index;
          screen_change.attribute := p_form_object_definition^.display_attribute;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          CYCLE /find_objects/;
        IFEND;

        IF ((low_y_position >= object_y_position) AND (high_y_position <= end_object_y_position) AND
              (low_x_position >= object_x_position) AND (high_x_position <= end_object_x_position)) THEN
          screen_change.attribute := p_form_object_definition^.display_attribute;
          screen_change.attribute_object_index := object_index;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          CYCLE /find_objects/;
        IFEND;

      = fdc$form_box =
        end_object_x_position := object_x_position + p_form_object_definition^.box_width - 1;
        end_object_y_position := object_y_position + p_form_object_definition^.box_height - 1;
        IF ((low_x_position <= object_x_position) AND (low_y_position <= object_y_position) AND
              (high_x_position >= end_object_x_position) AND (high_y_position >= end_object_y_position)) THEN
          screen_change.attribute := p_form_object_definition^.display_attribute;
          screen_change.attribute_object_index := object_index;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          CYCLE /find_objects/;
        IFEND;


        { Check for mark on horizontal  lines of box. }

        IF ((low_y_position = object_y_position) OR (high_y_position = end_object_y_position)) THEN
          IF ((low_x_position >= object_x_position) AND (high_x_position <= end_object_x_position)) THEN
            screen_change.attribute := p_form_object_definition^.display_attribute;
            screen_change.attribute_object_index := object_index;
            fdp$record_screen_change (screen_change, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            CYCLE /find_objects/;
          IFEND;
        IFEND;

        { Check for mark on vertical  lines of box. }

        IF ((low_x_position = object_x_position) OR (high_x_position = end_object_x_position)) THEN
          IF ((low_y_position >= object_y_position) AND (high_y_position <= end_object_y_position)) THEN
            screen_change.attribute_object_index := object_index;
            screen_change.attribute := p_form_object_definition^.display_attribute;
            fdp$record_screen_change (screen_change, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            CYCLE /find_objects/;
          IFEND;
        IFEND;

      = fdc$form_line =
        end_object_x_position := object_x_position + p_form_object_definition^.x_increment;
        end_object_y_position := object_y_position + p_form_object_definition^.y_increment;
        IF ((low_x_position <= object_x_position) AND (low_y_position <= object_y_position) AND
              (high_x_position >= end_object_x_position) AND (high_y_position >= end_object_y_position)) THEN
          screen_change.attribute := p_form_object_definition^.display_attribute;
          screen_change.attribute_object_index := object_index;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          CYCLE /find_objects/;
        IFEND;

        IF ((low_x_position >= object_x_position) AND (low_y_position >= object_y_position) AND
              (high_x_position <= end_object_x_position) AND (high_y_position <= end_object_y_position)) THEN
          screen_change.attribute_object_index := object_index;
          screen_change.attribute := p_form_object_definition^.display_attribute;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          CYCLE /find_objects/;
        IFEND;
      ELSE
      CASEND;

    FOREND /find_objects/;

  PROCEND fdp$delete_mark;

?? TITLE := 'fdp$write_form_definition', EJECT ??
*copyc fdh$write_form_definition

  PROCEDURE [XDCL] fdp$write_form_definition
    (    form_identifier: fdt$form_identifier;
     VAR p_form_module: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      actual_sequence_length: llt$section_length,
      form_object_text_descriptor: ^llt$object_text_descriptor,
      identification: ^llt$identification,
      local_status: ost$status,
      object_text_descriptor: ^llt$object_text_descriptor,
      p_comment: ^fdt$comment,
      p_comments: ^array [1 .. * ] of fdt$comment_definition,
      p_form_status: ^fdt$form_status,
      p_to_form_definition: ^fdt$form_definition,
      p_form_definition: ^fdt$form_definition,
      p_to_form_status: ^fdt$form_status,
      remaining_sequence_length: llt$section_length,
      to_form_identifier: fdt$form_identifier;

?? NEWTITLE := 'condition_handler', EJECT ??

  PROCEDURE condition_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         stack_frame_save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    CASE condition.selector OF

    = pmc$system_conditions =
      IF (condition.system_conditions * $pmt$system_conditions
            [pmc$instruction_specification, pmc$address_specification,
            pmc$access_violation, pmc$invalid_segment_ring_0, pmc$divide_fault,
            pmc$arithmetic_overflow, pmc$exponent_overflow,
            pmc$exponent_underflow, pmc$fp_significance_loss,
            pmc$fp_indefinite, pmc$arithmetic_significance,
            pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
      IF p_to_form_status <> NIL THEN
        p_to_form_status^.entry_used := FALSE;
      IFEND;
        EXIT fdp$write_form_definition;
      IFEND;

    = pmc$user_defined_condition =
      IF condition.user_condition_name = cye$run_time_condition THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
      IF p_to_form_status <> NIL THEN
        p_to_form_status^.entry_used := FALSE;
      IFEND;
        EXIT fdp$write_form_definition;
      IFEND;

    ELSE
      ;
    CASEND;
    pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
  PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    p_to_form_status := NIL;
    osp$establish_condition_handler (^condition_handler, TRUE);
    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    IF p_form_definition^.form_name = osc$null_name THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_name_required, '', status);
      RETURN;
    IFEND;

    fdp$create_form_status (to_form_identifier, p_to_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT object_text_descriptor IN p_form_module;
    IF object_text_descriptor = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
      p_to_form_status^.entry_used := FALSE;
      RETURN;
    IFEND;
    object_text_descriptor^.kind := llc$identification;

    NEXT identification IN p_form_module;
    IF identification = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
      p_to_form_status^.entry_used := FALSE;
      RETURN;
    IFEND;

    identification^.name := p_form_definition^.form_name;
    identification^.object_text_version := llc$object_text_version;
    identification^.kind := llc$form;
    pmp$get_legible_date_time (osc$mdy_date, identification^.date_created, osc$hms_time, identification^.
          time_created, local_status);
    identification^.attributes := $llt$module_attributes [llc$nonbindable, llc$nonexecutable];
    identification^.generator_id := llc$screen_formatter;
    identification^.generator_name_vers := fdc$screen_generator_version;

    p_comments := fdp$ptr_comments (p_form_definition^.comment_definitions, p_form_module);
    IF p_comments <> NIL THEN
      p_comment := #PTR (p_comments^ [1].p_comment, p_form_module^);
      identification^.commentary := p_comment^;
    ELSE
      identification^.commentary := ' ';
    IFEND;

    NEXT form_object_text_descriptor IN p_form_module;
    IF form_object_text_descriptor = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
      p_to_form_status^.entry_used := FALSE;
      RETURN;
    IFEND;

    form_object_text_descriptor^.kind := llc$form_definition;
    remaining_sequence_length := #SIZE (p_form_module^) - i#current_sequence_position (p_form_module);
    NEXT p_to_form_status^.p_form_module: [[REP remaining_sequence_length OF cell]] IN p_form_module;
    RESET p_to_form_status^.p_form_module;
    copy_form (p_form_status, p_to_form_status, status);
    IF NOT status.normal THEN
      p_to_form_status^.entry_used := FALSE;
      RETURN;
    IFEND;

    actual_sequence_length := i#current_sequence_position (p_to_form_status^.p_form_module);
    RESET p_form_module TO form_object_text_descriptor;
    NEXT form_object_text_descriptor IN p_form_module;
    form_object_text_descriptor^.sequence_length := actual_sequence_length;
    NEXT p_to_form_status^.p_form_module: [[REP actual_sequence_length OF cell]] IN p_form_module;
    p_to_form_status^.entry_used := FALSE;

  PROCEND fdp$write_form_definition;

?? TITLE := 'fdp$write_record_definition', EJECT ??
*copyc fdh$write_record_definition

  PROCEDURE [XDCL] fdp$write_record_definition
    (    form_identifier: fdt$form_identifier;
         file_identifier: amt$file_identifier;
         form_processor: fdt$form_processor;
     VAR status: ost$status);

    CONST
      line_maximum = 132;

    VAR
      additional_definitions:  fdt$additional_definitions,
      deck_name: ost$name,
      fba: amt$file_byte_address,
      fortran_form: boolean,
      line_out: string (line_maximum),
      line_length: integer,
      no_of_occurrences: fdt$occurrence,
      occurrences_string: string (5),
      occurrences_string_length: integer,
      p_added_variable_definition:^fdt$added_variable_definition,
      p_form_definition: ^fdt$form_definition,
      p_form_record_definitions: ^array [1 .. * ] of fdt$variable_record_definition,
      p_form_table_definition: ^fdt$form_table_definition,
      p_form_table_definitions: ^array [1 .. * ] of fdt$form_table_definition,
      p_form_status: ^fdt$form_status,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_variable_definitions: ^array [1 .. * ] of fdt$form_variable_definition,
      p_record_definitions: ^array [1 .. * ] of fdt$variable_record_definition,
      p_sequence: ^SEQ (*),
      p_table_object: ^fdt$table_object,
      p_table_objects: ^array [1 .. * ] of fdt$table_object,
      p_table_variable: ^fdt$table_variable,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable,
      p_text: ^fdt$text,
      p_variable_record_definition: ^fdt$variable_record_definition,
      record_index: fdt$variable_index,
      record_name: ost$name,
      scratch_name: ost$name,
      table_index: fdt$table_index,
      table_name: ost$name,
      table_variable_index: fdt$variable_index,
      temp_line: string (line_maximum),
      temp_line_length: integer,
      variable_index: fdt$variable_index,
      variable_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$write_record_definition;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$write_record_definition;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE ??
?? NEWTITLE := 'write_cobol_record', EJECT ??
{ PURPOSE:
{   This procedure writes the record definition for a COBOL processor.

    PROCEDURE write_cobol_record;

      CONST
        integer_specifications = ' PIC S9(18) COMP SYNC LEFT.',
        level_01 = '       01  ',
        level_03 = '03',
        level_03_column = 12,
        level_05 = '05',
        level_05_column  = 16,
        occurs_clause = ' OCCURS',
        picture_clause = ' PIC ',
        real_specifications = ' COMP-1.',
        synchronized_clause = ' SYNC LEFT';

      VAR
        cobol_level: string (2),
        starting_column: level_03_column .. level_05_column;

?? NEWTITLE := 'write_cobol_line', EJECT ??
{ PURPOSE:
{   This procedure writes one or more source code lines for the COBOL compiler.

    PROCEDURE write_cobol_line;

      CONST
        start_column = 16,
        cobol_column_maximum = 72;

      VAR
        break_column: 1 .. line_maximum,
        last_column: 1 .. line_maximum,
        new_line: string (line_maximum);

      IF line_length < cobol_column_maximum + 1 THEN
        amp$put_next (file_identifier, ^line_out, line_length, fba, status);
        IF NOT status.normal THEN
            EXIT fdp$write_record_definition;
        IFEND;
        RETURN;
      IFEND;

{ The line is longer than the 72 columns COBOL allows.  Write two lines.
{ The first line includes as many full words as possible up to and including
{ column 72.  A space indicates the end of a word.
{ The next line includes the rest of the data. A non blank character will always
{ be found before column 1.

      /find_word_break/
      FOR break_column := cobol_column_maximum DOWNTO 1 DO
        IF line_out (break_column, 1) = ' ' THEN
          EXIT /find_word_break/;
        IFEND;
      FOREND /find_word_break/;

      /remove_trailing_spaces/
      FOR last_column := break_column - 1 DOWNTO 1 DO
        IF line_out (last_column, 1) <> ' ' THEN
          EXIT /remove_trailing_spaces/;
        IFEND;
      FOREND /remove_trailing_spaces/;

      amp$put_next (file_identifier, ^line_out, last_column, fba, status);
      IF NOT status.normal THEN
        EXIT fdp$write_record_definition;
      IFEND;

      new_line (1, start_column - 1) := '';
      new_line (start_column, line_length - break_column) :=
            line_out (break_column + 1, line_length - break_column);
      amp$put_next (file_identifier, ^new_line,
            start_column + line_length - break_column - 1, fba, status);
      IF NOT status.normal THEN
        EXIT fdp$write_record_definition;
      IFEND;

    PROCEND write_cobol_line;

?? OLDTITLE ??
?? NEWTITLE := 'write_cobol_variable', EJECT ??
{ PURPOSE:
{   This procedure writes the COBOL clause for a variable.

    PROCEDURE write_cobol_variable;

      VAR
        p_added_variable_definition: ^fdt$added_variable_definition,
        usage: string (15 + 1);

?? OLDTITLE ??
?? NEWTITLE := 'get_usage_string', EJECT ??
{ PURPOSE:
{   This procedure gets the string for the USAGE clause.

     PROCEDURE get_usage_string;

     CASE p_added_variable_definition^.form_cobol_program_clause.
                    cobol_program_clause.usage OF
     = fdc$binary_usage =
       usage := ' BINARY';
     = fdc$computational_usage =
       usage := ' COMPUTATIONAL';
     = fdc$comp_usage =
       usage := ' COMP';
     = fdc$computational_1_usage =
       usage := ' COMPUTATIONAL-1';
     = fdc$comp_1_usage=
       usage := ' COMP-1';
     = fdc$computational_2_usage =
        usage := ' COMPUTATIONAL-2';
     = fdc$comp_2_usage =
       usage := ' COMP-2';
     = fdc$computational_3_usage =
        usage := ' COMPUTATIONAL-3';
     = fdc$comp_3_usage =
       usage := ' COMP-3';
     = fdc$packed_decimal_usage =
       usage := ' PACKED-DECIMAL';
     ELSE { Do not output default for fdc$display_usage.
       usage := '';
     CASEND;

     PROCEND get_usage_string;

?? OLDTITLE, EJECT ??

      variable_name := p_form_variable_definition^.name;
      fdp$convert_to_cobol_name (variable_name);
      line_out (1, starting_column - 1)  := '';
      STRINGREP (line_out, line_length, line_out (1, starting_column - 1), cobol_level, '  ',
            variable_name (1, clp$trimmed_string_size (variable_name)));
      CASE p_form_variable_definition^.program_data_type OF

          = fdc$program_integer_type =
            STRINGREP (line_out, line_length, line_out (1, line_length), integer_specifications);

          = fdc$program_real_type =
            STRINGREP (line_out, line_length, line_out (1, line_length), real_specifications);

          = fdc$program_cobol_type =
            fdp$locate_added_variable_facts (p_form_status^.p_form_module, p_form_variable_definition,
                  p_added_variable_definition);
            CASE p_added_variable_definition^.program_cobol_description.cobol_usage OF

            = fdc$cobol_usage_single =
              get_usage_string;
              STRINGREP (line_out, line_length, line_out (1, line_length),
                    usage (1, clp$trimmed_string_size (usage)), '.');

            = fdc$cobol_usage_binary =
              get_usage_string;
              STRINGREP (line_out, line_length, line_out (1, line_length),
                   usage (1, clp$trimmed_string_size (usage)), picture_clause,
                     p_added_variable_definition^.form_cobol_program_clause.cobol_program_clause.picture
                    (1, clp$trimmed_string_size (p_added_variable_definition^.form_cobol_program_clause.
                    cobol_program_clause.picture)));

{ Sychronize COMPUTATONAL item if item takes a word.

              IF p_added_variable_definition^.program_cobol_description.size = fdc$integer_length THEN
                STRINGREP (line_out, line_length, line_out (1, line_length), synchronized_clause, '.');
              ELSE
                STRINGREP (line_out, line_length, line_out (1, line_length), '.');
              IFEND;

            ELSE { Process other COBOL usages.
              get_usage_string;
              STRINGREP (line_out, line_length, line_out (1, line_length),
                   usage (1, clp$trimmed_string_size (usage)), picture_clause,
                   p_added_variable_definition^.form_cobol_program_clause.cobol_program_clause.picture
                   (1, clp$trimmed_string_size (p_added_variable_definition^.form_cobol_program_clause.
                   cobol_program_clause.picture)), '.');
           CASEND;

         ELSE {fdc$program_character_type, fdc$program_upper_case_type
           STRINGREP (temp_line, temp_line_length, p_form_variable_definition^.program_variable_length);
           STRINGREP ( line_out, line_length, line_out (1, line_length), picture_clause,
                 'X(', temp_line (2, temp_line_length - 1), ').');

         CASEND;

         write_cobol_line;

       PROCEND write_cobol_variable;

?? OLDTITLE ??
?? NEWTITLE := 'write_fortran_table', EJECT ??

{ PURPOSE:
{   This procedure writes the COBOL source statements for a form that was
{   defined with a FORTRAN processor.
{ DESIGN:
{   FORTRAN does not have a record structure.  Every variable in a table must have an OCCURS clause.

     PROCEDURE write_fortran_table;

       FOR table_variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
         p_table_variable := ^p_table_variables^ [table_variable_index];
         p_form_variable_definition := ^p_form_variable_definitions^ [p_table_variable^.variable_index];
         variable_name := p_form_variable_definition^.name;
         fdp$convert_to_cobol_name (variable_name);
         line_out (1, level_03_column - 1)  := '';
         STRINGREP (line_out, line_length, line_out (1, level_03_column - 1), level_03, '  ',
               variable_name (1, clp$trimmed_string_size (variable_name)),
               occurs_clause, no_of_occurrences);
         CASE p_form_variable_definition^.program_data_type OF

         = fdc$program_integer_type =
           STRINGREP (line_out, line_length, line_out (1, line_length), integer_specifications);

         = fdc$program_real_type =
           STRINGREP (line_out, line_length, line_out (1, line_length), real_specifications);

         ELSE {fdc$program_character_type, fdc$program_upper_case_type}
           STRINGREP (temp_line, temp_line_length, p_form_variable_definition^.program_variable_length);
           STRINGREP (line_out, line_length, line_out (1, line_length), picture_clause, 'X(',
                 temp_line (2, temp_line_length - 1), ').');

         CASEND;

         write_cobol_line;
       FOREND;

     PROCEND write_fortran_table;

?? OLDTITLE, EJECT ??

{  Write record name as 01 level data item.

      fdp$convert_to_cobol_name (record_name);
      STRINGREP (line_out, line_length, level_01, record_name
            (1, clp$trimmed_string_size (record_name)),  '.');
      write_cobol_line;

      FOR record_index := 1 TO UPPERBOUND (p_form_status^.p_form_record_definitions^) DO
        p_variable_record_definition := ^p_record_definitions^ [record_index];
        CASE p_variable_record_definition^.key OF

{  Output definition for a single variable. The variable will be a 03 level data item.

        = fdc$record_variable =
          p_form_variable_definition := ^p_form_variable_definitions^
                [p_variable_record_definition^.variable_index];
          starting_column := level_03_column;
          cobol_level := level_03;
          write_cobol_variable;

{  Output definition for a table.

        = fdc$record_table =
          table_index := p_variable_record_definition^.table_index;
          p_form_table_definition := ^p_form_table_definitions^ [table_index];
          p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
                p_form_status^.p_form_module);
          table_name := p_form_table_definition^.name;
          fdp$convert_to_cobol_name (table_name);
          no_of_occurrences := p_form_table_definition^.stored_occurrence;
          IF fortran_form THEN

{ A FORTRAN form requires that every variable in a table has an OCCURS clause.

            write_fortran_table;

          ELSE

{ A table will be a 03 level data item with an OCCURS clause.
{ Variables in the table will be 05 level data items.

            STRINGREP (line_out, line_length, '           ', level_03, '  ',
                  table_name (1, clp$trimmed_string_size (table_name)), occurs_clause,
                  no_of_occurrences, '.');
            write_cobol_line;
            starting_column := level_05_column;
            cobol_level := level_05;
            FOR table_variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
              p_table_variable := ^p_table_variables^ [table_variable_index];
              p_form_variable_definition := ^p_form_variable_definitions^ [p_table_variable^.variable_index];
              write_cobol_variable;
            FOREND;
          IFEND;
        CASEND;
      FOREND;

    PROCEND write_cobol_record;

?? OLDTITLE ??
?? NEWTITLE := 'write_cybil_record', EJECT ??

    PROCEDURE write_cybil_record;

{
{  WRITE CYBIL FORMAT RECORD.
{
      #TRANSLATE (fdv$to_cybil, record_name, scratch_name);
      record_name := scratch_name;
      STRINGREP (line_out, line_length, '  TYPE');
      amp$put_next (file_identifier, ^line_out, line_length, fba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      STRINGREP (line_out, line_length, '    ', record_name (1, clp$trimmed_string_size (record_name)),
            ' = record');
      amp$put_next (file_identifier, ^line_out, line_length, fba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Align record on word boundary. This makes CYBIL data mapping the same as COBOL and FORTRAN.

      STRINGREP (line_out, line_length, '      align_field: ALIGNED [0 MOD 8] string (0),');
      amp$put_next (file_identifier, ^line_out, line_length, fba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      FOR record_index := 1 TO UPPERBOUND (p_form_status^.p_form_record_definitions^) DO
        p_variable_record_definition := ^p_record_definitions^ [record_index];
        CASE p_variable_record_definition^.key OF

{
{  OUTPUT DEFINITION FOR A SIMPLE VARIABLE.
{
        = fdc$record_variable =
          p_form_variable_definition := ^p_form_variable_definitions^
                [p_variable_record_definition^.variable_index];
          variable_name := p_form_variable_definition^.name;
          #TRANSLATE (fdv$to_cybil, variable_name, scratch_name);
          variable_name := scratch_name;
          CASE p_form_variable_definition^.program_data_type OF

          = fdc$program_integer_type =
            STRINGREP (line_out, line_length, '      ', variable_name
                  (1, clp$trimmed_string_size (variable_name)), ': ALIGNED [0 MOD 8] integer,');

          = fdc$program_real_type =
            STRINGREP (line_out, line_length, '      ', variable_name
                  (1, clp$trimmed_string_size (variable_name)), ': ALIGNED [0 MOD 8] real,');

          ELSE  {fdc$program_character_type, fdc$program_upper_case_type

{ Intermediate stringrep so can delete leading blank before integer.

            STRINGREP (temp_line, temp_line_length, p_form_variable_definition^.program_variable_length);
            STRINGREP (line_out, line_length, '      ', variable_name
                  (1, clp$trimmed_string_size (variable_name)), ': string (',
                  temp_line (2, temp_line_length - 1), '),');
          CASEND;
          amp$put_next (file_identifier, ^line_out, line_length, fba, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{  OUTPUT DEFINITION FOR A TABLE.

        = fdc$record_table =
          table_index := p_variable_record_definition^.table_index;
          p_form_table_definition := ^p_form_table_definitions^ [table_index];
          p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
                p_form_status^.p_form_module);
          no_of_occurrences := p_form_table_definition^.stored_occurrence;
          IF fortran_form THEN

{ A FORTRAN form requires that every variable in a table is an array.

            FOR table_variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
              p_table_variable := ^p_table_variables^ [table_variable_index];
              p_form_variable_definition := ^p_form_variable_definitions^ [p_table_variable^.variable_index];
              variable_name := p_form_variable_definition^.name;
              #TRANSLATE (fdv$to_cybil, variable_name, scratch_name);
              variable_name := scratch_name;
              CASE p_form_variable_definition^.program_data_type OF

              = fdc$program_integer_type =
                STRINGREP (line_out, line_length, '      ', variable_name
                      (1, clp$trimmed_string_size (variable_name)), ': ALIGNED [0 MOD 8]');
                amp$put_next (file_identifier, ^line_out, line_length, fba, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                STRINGREP (line_out, line_length, ' array [1 ..', no_of_occurrences, '] of integer,');

              = fdc$program_real_type =
                STRINGREP (line_out, line_length, '      ', variable_name
                      (1, clp$trimmed_string_size (variable_name)), ': ALIGNED [0 MOD 8]');
                amp$put_next (file_identifier, ^line_out, line_length, fba, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                STRINGREP (line_out, line_length, ' array [1 ..', no_of_occurrences, '] of real,');

              ELSE {fdc$program_character_type, fdc$program_upper_case_type

{ Intermediate stringrep so can delete leading blank before integer.

                STRINGREP (temp_line, temp_line_length, p_form_variable_definition^.program_variable_length);
                STRINGREP (line_out, line_length, '      ', variable_name
                      (1, clp$trimmed_string_size (variable_name)), ': array [1 ..', no_of_occurrences,
                      '] of string(', temp_line (2, temp_line_length - 1), '),');
              CASEND;
              amp$put_next (file_identifier, ^line_out, line_length, fba, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            FOREND;

          ELSE { This is not a FORTRAN form.

{ A table will be a record with one or more variables.
{ The record will occur one or more times.

            table_name := p_form_table_definition^.name;
            #TRANSLATE (fdv$to_cybil, table_name, scratch_name);
            table_name := scratch_name;
            STRINGREP (line_out, line_length, '      ', table_name (1, clp$trimmed_string_size (table_name)),
                  ': array [1 ..', no_of_occurrences, '] of record');
            amp$put_next (file_identifier, ^line_out, line_length, fba, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            FOR table_variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
              p_table_variable := ^p_table_variables^ [table_variable_index];
              p_form_variable_definition := ^p_form_variable_definitions^ [p_table_variable^.variable_index];
              variable_name := p_form_variable_definition^.name;
              #TRANSLATE (fdv$to_cybil, variable_name, scratch_name);
              variable_name := scratch_name;
              CASE p_form_variable_definition^.program_data_type OF

              = fdc$program_integer_type =
                STRINGREP (line_out, line_length, '        ',
                      variable_name (1, clp$trimmed_string_size (variable_name)),
                      ': ALIGNED [0 MOD 8] integer,');

              = fdc$program_real_type =
                STRINGREP (line_out, line_length, '        ',
                      variable_name (1, clp$trimmed_string_size (variable_name)),
                      ': ALIGNED [0 MOD 8] real,');

              ELSE {fdc$program_character_type, fdc$program_upper_case_type

{ Intermediate stringrep so can delete leading blank before integer.

                STRINGREP (temp_line, temp_line_length, p_form_variable_definition^.program_variable_length);
                STRINGREP (line_out, line_length, '        ',
                      variable_name (1, clp$trimmed_string_size (variable_name)),
                      ': string (', temp_line (2, temp_line_length - 1), '),');
              CASEND;
              amp$put_next (file_identifier, ^line_out, line_length, fba, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            FOREND;

            STRINGREP (line_out, line_length, '      recend,');
            amp$put_next (file_identifier, ^line_out, line_length, fba, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        CASEND;
      FOREND;

      STRINGREP (line_out, line_length, '    recend;');
      amp$put_next (file_identifier, ^line_out, line_length, fba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    PROCEND write_cybil_record;

?? OLDTITLE ??
?? NEWTITLE := 'write_fortran_record', EJECT ??

    PROCEDURE write_fortran_record;

      VAR
        equivalence_length: integer,
        equivalence_string: string (20+31+1),
        redefine_record_name: ost$name;

?? NEWTITLE := 'write_fortran_line', EJECT ??

{ PURPOSE:
{   This procedure writes one or more source code lines for the FORTRAN compiler.

    PROCEDURE write_fortran_line;

      CONST
        fortran_start_column = 7,
        fortran_maximum_column = 72;

      VAR
        break_column: 1 .. line_maximum,
        last_column: 1 .. line_maximum,
        new_line: string (line_maximum);

      IF line_length < fortran_maximum_column + 1 THEN
        amp$put_next (file_identifier, ^line_out, line_length, fba, status);
        IF NOT status.normal THEN
            EXIT fdp$write_record_definition;
        IFEND;
        RETURN;
      IFEND;

{ The line is longer than the 72 columns FORTRAN allows.  This can occur only
{ on the line that contains the "EQUIVALENCE" statement. Write two lines.
{ The first line has "EQUIVALENCE symbol_1,".  The second line has "symbol_2"
{ A comma character will always will be found before column 1.

      /find_word_break/
      FOR break_column := fortran_maximum_column DOWNTO 1 DO
        IF line_out (break_column, 1) = ',' THEN
          EXIT /find_word_break/;
        IFEND;
      FOREND /find_word_break/;

      amp$put_next (file_identifier, ^line_out, break_column, fba, status);
      IF NOT status.normal THEN
        EXIT fdp$write_record_definition;
      IFEND;

      new_line (1, fortran_start_column - 1) := '     -';
      new_line (fortran_start_column, line_length - break_column) :=
            line_out (break_column + 1, line_length - break_column);
      amp$put_next (file_identifier, ^new_line,
            fortran_start_column + line_length - break_column - 1, fba, status);
      IF NOT status.normal THEN
        EXIT fdp$write_record_definition;
      IFEND;

    PROCEND write_fortran_line;

?? OLDTITLE, EJECT ??

{
{  WRITE FORTRAN FORMAT RECORD.
{

{ Create character variable to hold entire record.
{ Programs will use this character variable to get/replace records.
{ It has the correct record length in characters.

      fdp$convert_to_fortran_name (form_processor, record_name);
      STRINGREP (temp_line, temp_line_length, p_form_definition^.program_record_length);
      STRINGREP (line_out, line_length, '      CHARACTER ', record_name (1, clp$trimmed_string_size
            (record_name)), '*', temp_line (2, temp_line_length - 1));
      write_fortran_line;


{ Create character array for equivalencing other variables.

      redefine_record_name (2, *) := record_name;
      redefine_record_name (1, 1) := 'X';
      fdp$convert_to_fortran_name (form_processor, redefine_record_name);
      STRINGREP (equivalence_string, equivalence_length, '      EQUIVALENCE (',
            redefine_record_name (1, clp$trimmed_string_size (redefine_record_name)), '(');
      STRINGREP (temp_line, temp_line_length, p_form_definition^.program_record_length);
      STRINGREP (line_out, line_length, '      CHARACTER ', redefine_record_name (1, clp$trimmed_string_size
            (redefine_record_name)), '(', temp_line (2, temp_line_length - 1), ')');
      write_fortran_line;

      STRINGREP (line_out, line_length, '      EQUIVALENCE (',
            record_name (1, clp$trimmed_string_size (record_name)), ',',
            redefine_record_name (1, clp$trimmed_string_size (redefine_record_name)), '(1))');
      write_fortran_line;

      FOR record_index := 1 TO UPPERBOUND (p_form_status^.p_form_record_definitions^) DO
        p_variable_record_definition := ^p_record_definitions^ [record_index];
        CASE p_variable_record_definition^.key OF

{  OUTPUT DEFINITION FOR A SIMPLE VARIABLE.

        = fdc$record_variable =
          p_form_variable_definition := ^p_form_variable_definitions^
                [p_variable_record_definition^.variable_index];
          variable_name := p_form_variable_definition^.name;
          fdp$convert_to_fortran_name (form_processor, variable_name);
          CASE p_form_variable_definition^.program_data_type OF

          = fdc$program_integer_type =
            STRINGREP (line_out, line_length, '      INTEGER ',
                  variable_name (1, clp$trimmed_string_size (variable_name)));

          = fdc$program_real_type =
            STRINGREP (line_out, line_length, '      REAL ', variable_name
                  (1, clp$trimmed_string_size (variable_name)));

          ELSE {fdc$program_character_type, fdc$program_upper_case_type}

{ Intermediate stringrep so can delete leading blank before integer.

            STRINGREP (temp_line, temp_line_length, p_form_variable_definition^.program_variable_length);
            STRINGREP (line_out, line_length, '      CHARACTER ',
                  variable_name (1, clp$trimmed_string_size (variable_name)),
                  '*', temp_line (2, temp_line_length - 1));
          CASEND;

          write_fortran_line;
          STRINGREP (temp_line, temp_line_length, p_form_variable_definition^.program_record_position);
          STRINGREP (line_out, line_length, equivalence_string (1, equivalence_length),
                temp_line (2, temp_line_length - 1), '),', variable_name
                (1, clp$trimmed_string_size (variable_name)), ')');
          write_fortran_line;

{  OUTPUT DEFINITION FOR A TABLE.

        = fdc$record_table =
          table_index := p_variable_record_definition^.table_index;
          p_form_table_definition := ^p_form_table_definitions^ [table_index];
          p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
                p_form_status^.p_form_module);
          STRINGREP (occurrences_string, occurrences_string_length,
                p_form_table_definition^.stored_occurrence);
          IF NOT fortran_form AND (p_form_table_definition^.table_variables.active_number > 1) THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$record_defn_not_written,
                  p_form_status^.p_form_definition^.form_name, status);
            RETURN;
          IFEND;
          FOR table_variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
            p_table_variable := ^p_table_variables^ [table_variable_index];
            p_form_variable_definition := ^p_form_variable_definitions^ [p_table_variable^.variable_index];
            variable_name := p_form_variable_definition^.name;
            fdp$convert_to_fortran_name (form_processor, variable_name);
            CASE p_form_variable_definition^.program_data_type OF

            = fdc$program_integer_type =
              STRINGREP (line_out, line_length, '      INTEGER ',
                    variable_name (1, clp$trimmed_string_size (variable_name)),
                    ' (', occurrences_string (2, occurrences_string_length - 1), ')');

            = fdc$program_real_type =
              STRINGREP (line_out, line_length, '      REAL ',
                    variable_name (1, clp$trimmed_string_size (variable_name)),
                    ' (', occurrences_string (2, occurrences_string_length - 1), ')');

            ELSE {fdc$program_character_type, fdc$program_upper_case_type

{ Intermediate stringrep so can delete leading blank before integer.

              STRINGREP (temp_line, temp_line_length, p_form_variable_definition^.program_variable_length);
              STRINGREP (line_out, line_length, '      CHARACTER ',
                    variable_name (1, clp$trimmed_string_size (variable_name)), '(', occurrences_string
                    (2, occurrences_string_length - 1), ')', '*', temp_line (2, temp_line_length - 1));

            CASEND;

            write_fortran_line;
            p_table_objects := fdp$ptr_table_objects (p_table_variable^.table_objects,
                  p_form_status^.p_form_module);
            p_table_object := ^p_table_objects^ [1];
            STRINGREP (temp_line, temp_line_length, p_table_object^.program_record_position);
            STRINGREP (line_out, line_length, equivalence_string (1, equivalence_length),
                  temp_line (2, temp_line_length - 1), '),', variable_name
                  (1, clp$trimmed_string_size (variable_name)), '(1))');
            write_fortran_line;
          FOREND;
        CASEND;
      FOREND;

    PROCEND write_fortran_record;

?? OLDTITLE ??
?? NEWTITLE := 'write_pascal_record', EJECT ??

    PROCEDURE write_pascal_record;

{  Write PASCAL record definition.

      #TRANSLATE (fdv$to_cybil, record_name, scratch_name);
      record_name := scratch_name;
      STRINGREP (line_out, line_length, '  TYPE');
      amp$put_next (file_identifier, ^line_out, line_length, fba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (line_out, line_length, '    ', record_name (1, clp$trimmed_string_size (record_name)),
            ' = record');
      amp$put_next (file_identifier, ^line_out, line_length, fba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      FOR record_index := 1 TO UPPERBOUND (p_form_status^.p_form_record_definitions^) DO
        p_variable_record_definition := ^p_record_definitions^ [record_index];
        CASE p_variable_record_definition^.key OF

{  Generate definition for a simple variable.

        = fdc$record_variable =
          p_form_variable_definition := ^p_form_variable_definitions^
                [p_variable_record_definition^.variable_index];
          variable_name := p_form_variable_definition^.name;
          #TRANSLATE (fdv$to_cybil, variable_name, scratch_name);
          variable_name := scratch_name;

          CASE p_form_variable_definition^.program_data_type OF

          = fdc$program_integer_type =
            STRINGREP (line_out, line_length, '      ', variable_name
                  (1, clp$trimmed_string_size (variable_name)), ': integer;');

          = fdc$program_real_type =
            STRINGREP (line_out, line_length, '      ', variable_name
                  (1, clp$trimmed_string_size (variable_name)), ': real;');

          ELSE {fdc$program_character_type, fdc$program_upper_case_type

{ Intermediate stringrep so can delete leading blank before integer.

            STRINGREP (temp_line, temp_line_length, p_form_variable_definition^.program_variable_length);
            STRINGREP (line_out, line_length, '      ', variable_name
                  (1, clp$trimmed_string_size (variable_name)), ': string (',
                  temp_line (2, temp_line_length - 1), ');');
          CASEND;

          amp$put_next (file_identifier, ^line_out, line_length, fba, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{  Generate definition  for a table.

        = fdc$record_table =
          table_index := p_variable_record_definition^.table_index;
          p_form_table_definition := ^p_form_table_definitions^ [table_index];
          p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
                p_form_status^.p_form_module);
          no_of_occurrences := p_form_table_definition^.stored_occurrence;
          IF fortran_form THEN

{ A FORTRAN form requires that every variable in a table is an array.

            FOR table_variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
              p_table_variable := ^p_table_variables^ [table_variable_index];
              p_form_variable_definition := ^p_form_variable_definitions^ [p_table_variable^.variable_index];
              variable_name := p_form_variable_definition^.name;
              #TRANSLATE (fdv$to_cybil, variable_name, scratch_name);
              variable_name := scratch_name;

              CASE p_form_variable_definition^.program_data_type OF

              = fdc$program_integer_type =
                STRINGREP (line_out, line_length, '      ', variable_name
                      (1, clp$trimmed_string_size (variable_name)),
                      ': array [1 ..', no_of_occurrences, '] of integer;');

              = fdc$program_real_type =
                STRINGREP (line_out, line_length, '      ', variable_name
                      (1, clp$trimmed_string_size (variable_name)),
                      ': array [1 ..', no_of_occurrences, '] of real;');

              ELSE {fdc$program_character_type, fdc$program_upper_case_type

{ Intermediate stringrep so can delete leading blank before integer.

                STRINGREP (temp_line, temp_line_length, p_form_variable_definition^.program_variable_length);
                STRINGREP (line_out, line_length, '      ', variable_name
                      (1, clp$trimmed_string_size (variable_name)), ': array [1 ..', no_of_occurrences,
                      '] of string(', temp_line (2, temp_line_length - 1), ');');
              CASEND;

              amp$put_next (file_identifier, ^line_out, line_length, fba, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            FOREND;

          ELSE { This is not a FORTRAN form. }

{ A table will be a record with one or more variables.
{ The record will occur one or more times.

            table_name := p_form_table_definition^.name;
            #TRANSLATE (fdv$to_cybil, table_name, scratch_name);
            table_name := scratch_name;
            STRINGREP (line_out, line_length, '      ', table_name (1, clp$trimmed_string_size (table_name)),
                  ': array [1 ..', no_of_occurrences, '] of record');
            amp$put_next (file_identifier, ^line_out, line_length, fba, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            FOR table_variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
              p_table_variable := ^p_table_variables^ [table_variable_index];
              p_form_variable_definition := ^p_form_variable_definitions^ [p_table_variable^.variable_index];
              variable_name := p_form_variable_definition^.name;
              #TRANSLATE (fdv$to_cybil, variable_name, scratch_name);
              variable_name := scratch_name;

              CASE p_form_variable_definition^.program_data_type OF

              = fdc$program_integer_type =
                STRINGREP (line_out, line_length, '        ',
                      variable_name (1, clp$trimmed_string_size (variable_name)),
                      ': integer;');

              = fdc$program_real_type =
                STRINGREP (line_out, line_length, '        ',
                      variable_name (1, clp$trimmed_string_size (variable_name)),
                      ': real;');

              ELSE {fdc$program_character_type, fdc$program_upper_case_type}

{ Intermediate stringrep so can delete leading blank before integer.

                STRINGREP (temp_line, temp_line_length, p_form_variable_definition^.program_variable_length);
                STRINGREP (line_out, line_length, '        ',
                      variable_name (1, clp$trimmed_string_size (variable_name)),
                      ': string (', temp_line (2, temp_line_length - 1), ');');
              CASEND;

              amp$put_next (file_identifier, ^line_out, line_length, fba, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            FOREND;

            STRINGREP (line_out, line_length, '      end;');
            amp$put_next (file_identifier, ^line_out, line_length, fba, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        CASEND;
      FOREND;

      STRINGREP (line_out, line_length, '    end;');
      amp$put_next (file_identifier, ^line_out, line_length, fba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    PROCEND write_pascal_record;

?? OLDTITLE ??
?? NEWTITLE := 'write_scl_record', EJECT ??

    PROCEDURE write_scl_record;


{  Write SCL record.

     #TRANSLATE (fdv$to_cybil, record_name, scratch_name);
      record_name := scratch_name (1, 27)  ;
      STRINGREP (line_out, line_length, '  TYPE');
      amp$put_next (file_identifier, ^line_out, line_length, fba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      STRINGREP (line_out, line_length, '    fdt#', record_name (1, clp$trimmed_string_size (record_name)),
            ' = RECORD');
      amp$put_next (file_identifier, ^line_out, line_length, fba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      FOR record_index := 1 TO UPPERBOUND (p_form_status^.p_form_record_definitions^) DO
        p_variable_record_definition := ^p_record_definitions^ [record_index];
        CASE p_variable_record_definition^.key OF

{  Output definition for a single variable.

        = fdc$record_variable =
          p_form_variable_definition := ^p_form_variable_definitions^
                [p_variable_record_definition^.variable_index];
          variable_name := p_form_variable_definition^.name;
          #TRANSLATE (fdv$to_cybil, variable_name, scratch_name);
          variable_name := scratch_name;
          CASE p_form_variable_definition^.program_data_type OF

          = fdc$program_integer_type =
            STRINGREP (line_out, line_length, '      ', variable_name
                  (1, clp$trimmed_string_size (variable_name)), ': INTEGER');

          = fdc$program_real_type =
            STRINGREP (line_out, line_length, '      ', variable_name
                  (1, clp$trimmed_string_size (variable_name)), ': REAL');

          ELSE {fdc$program_character_type, fdc$program_upper_case_type

{ Intermediate stringrep so can delete leading blank before integer.

            STRINGREP (temp_line, temp_line_length, p_form_variable_definition^.program_variable_length);
            STRINGREP (line_out, line_length, '      ', variable_name
                  (1, clp$trimmed_string_size (variable_name)), ': STRING 0 ..',
                  temp_line (2, temp_line_length - 1));
          CASEND;
          amp$put_next (file_identifier, ^line_out, line_length, fba, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{  Output definition for a table.

        = fdc$record_table =
          table_index := p_variable_record_definition^.table_index;
          p_form_table_definition := ^p_form_table_definitions^ [table_index];
          p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
                p_form_status^.p_form_module);
          no_of_occurrences := p_form_table_definition^.stored_occurrence;

{ A table will be a record with one or more variables.
{ The record will occur one or more times.

          table_name := p_form_table_definition^.name;
          #TRANSLATE (fdv$to_cybil, table_name, scratch_name);
          table_name := scratch_name;
          STRINGREP (line_out, line_length, '      ', table_name (1, clp$trimmed_string_size (table_name)),
                ': ARRAY 1 ..', no_of_occurrences, ' of RECORD');
          amp$put_next (file_identifier, ^line_out, line_length, fba, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          FOR table_variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
            p_table_variable := ^p_table_variables^ [table_variable_index];
            p_form_variable_definition := ^p_form_variable_definitions^ [p_table_variable^.variable_index];
            variable_name := p_form_variable_definition^.name;
            #TRANSLATE (fdv$to_cybil, variable_name, scratch_name);
            variable_name := scratch_name;
            CASE p_form_variable_definition^.program_data_type OF

            = fdc$program_integer_type =
              STRINGREP (line_out, line_length, '        ',
                    variable_name (1, clp$trimmed_string_size (variable_name)),
                    ': INTEGER');

            = fdc$program_real_type =
              STRINGREP (line_out, line_length, '        ',
                    variable_name (1, clp$trimmed_string_size (variable_name)),
                    ': REAL');

            ELSE {fdc$program_character_type, fdc$program_upper_case_type

{ Intermediate stringrep so can delete leading blank before integer.

              STRINGREP (temp_line, temp_line_length, p_form_variable_definition^.program_variable_length);
              STRINGREP (line_out, line_length, '        ',
                    variable_name (1, clp$trimmed_string_size (variable_name)),
                    ': STRING 0 ..', temp_line (2, temp_line_length - 1));
            CASEND;
            amp$put_next (file_identifier, ^line_out, line_length, fba, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND;

          STRINGREP (line_out, line_length, '      RECEND');
          amp$put_next (file_identifier, ^line_out, line_length, fba, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        CASEND;
      FOREND;

      STRINGREP (line_out, line_length, '    RECEND');
      amp$put_next (file_identifier, ^line_out, line_length, fba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (line_out, line_length, '  TYPEND');
      amp$put_next (file_identifier, ^line_out, line_length, fba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND write_scl_record;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;

{  CHECK AND EXIT WITH AN ERROR INDICATION IF ONE OF THE FOLLOWING : FORM HAS
{  NOT BEEN OPENED, FORM IS INCOMPLETE, FORM HAS ERRORS OR IT IS A
{  'DISPLAY ONLY' FORM (NO VARIABLES) .

    IF NOT p_form_definition^.form_ended THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_not_ended,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF p_form_definition^.form_has_errors THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_definition_errors,
            p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF (p_form_definition^.record_definitions.active_number = 0) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_has_no_variables,
            p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    p_form_variable_definitions := p_form_status^.p_form_variable_definitions;

{ Non COBOL processors cannot have variables with COBOL data type.

    CASE form_processor OF

    = fdc$ansi_fortran_processor, fdc$cdc_fortran_processor,
            fdc$cybil_processor, fdc$scl_processor, fdc$pascal_processor, fdc$unknown_processor =

      /search_for_cobol_data_type/
        FOR variable_index := 1 to p_form_definition^.form_variable_definitions.active_number DO
          IF p_form_variable_definitions^ [variable_index].program_data_type =
                fdc$program_cobol_type THEN
            osp$set_status_abnormal (fdc$format_display_identifier,
                  fde$invalid_cobol_data_type,
                   p_form_variable_definitions^ [variable_index].name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                   p_form_definition^.form_name,  status);
                RETURN;
          IFEND;
        FOREND /search_for_cobol_data_type/;

     ELSE {fdc$cobol_processor

     CASEND;

    fortran_form := ((p_form_definition^.processor = fdc$ansi_fortran_processor) OR
          (p_form_definition^.processor = fdc$cdc_fortran_processor) OR
          (p_form_definition^.processor = fdc$extended_fortran_processor));
    p_record_definitions := p_form_status^.p_form_record_definitions;
    p_form_table_definitions := p_form_status^.p_form_table_definitions;

{  Write deck header.

    IF (p_form_definition^.record_deck_name = '') THEN
      deck_name := p_form_definition^.form_name;
    ELSE
      deck_name := p_form_definition^.record_deck_name;
    IFEND;
    STRINGREP (line_out, line_length, '*DECK deck=', deck_name (1, clp$trimmed_string_size (deck_name)),
          ' expand=false');
    amp$put_next (file_identifier, ^line_out, line_length, fba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (p_form_definition^.record_name = '') THEN
      record_name := deck_name;
    ELSE
      record_name := p_form_definition^.record_name;
    IFEND;

    CASE form_processor OF
    = fdc$cybil_processor =
      write_cybil_record;

    = fdc$cobol_processor =
      write_cobol_record;

    = fdc$ansi_fortran_processor, fdc$cdc_fortran_processor,
            fdc$extended_fortran_processor =
      write_fortran_record;

    = fdc$pascal_processor =
      write_pascal_record;

    = fdc$scl_processor =
      write_scl_record;

    ELSE

{  Invalid processor.

      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_form_processor,
            p_form_definition^.form_name, status);

    CASEND;

  PROCEND fdp$write_record_definition;

?? TITLE := 'check_for_sliced_objects', EJECT ??

  PROCEDURE check_for_sliced_objects
    (    p_form_status: ^fdt$form_status;
         p_form_definition: ^fdt$form_definition;
         p_form_module: ^fdt$form_module;
         p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
         number_objects: fdt$number_objects;
         low_x_position: fdt$x_position;
         low_y_position: fdt$y_position;
         high_x_position: fdt$x_position;
         high_y_position: fdt$y_position;
     VAR status: ost$status);

    VAR
      end_object_x_position: fdt$x_position,
      end_object_y_position: fdt$y_position,
      name_exists: boolean,
      form_object_key: fdt$form_object_key,
      object_index: fdt$object_index,
      object_x_position: fdt$x_position,
      object_y_position: fdt$y_position,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_variable_definition: ^fdt$form_variable_definition,
      points_inside_mark: 0 .. 4,
      variable_index: fdt$variable_index;

    status.normal := TRUE;

  /check_area/
    FOR object_index := 1 TO number_objects DO
      p_form_object_definition := ^p_form_object_definitions^ [object_index];
      object_x_position := p_form_object_definition^.x_position;
      object_y_position := p_form_object_definition^.y_position;

      { Check if new object is inside box formed by existing object. }

      form_object_key := p_form_object_definition^.key;

      CASE form_object_key OF

      = fdc$form_box =
        end_object_x_position := object_x_position + p_form_object_definition^.box_width - 1;
        end_object_y_position := object_y_position + p_form_object_definition^.box_height - 1;

      = fdc$form_line =
        end_object_x_position := object_x_position + p_form_object_definition^.x_increment;
        end_object_y_position := object_y_position + p_form_object_definition^.y_increment;

      = fdc$form_variable_text =
        IF p_form_status^.design_form THEN
          IF p_form_object_definition^.name = p_form_status^.design_variable_name THEN
            CYCLE /check_area/;
          IFEND;
        IFEND;

        end_object_x_position := object_x_position + p_form_object_definition^.text_variable_width - 1;
        end_object_y_position := object_y_position;


      = fdc$form_variable_text_box =
        end_object_x_position := object_x_position + p_form_object_definition^.variable_box_width - 1;
        end_object_y_position := object_y_position + p_form_object_definition^.variable_box_height - 1;

      = fdc$form_constant_text =
        end_object_x_position := p_form_object_definition^.constant_text_width + object_x_position - 1;
        end_object_y_position := object_y_position;

      = fdc$form_constant_text_box =
        end_object_x_position := object_x_position + p_form_object_definition^.constant_box_width - 1;
        end_object_y_position := object_y_position + p_form_object_definition^.constant_box_height - 1;

      ELSE
        { Do nothing for these objects. }
        CYCLE /check_area/;

      CASEND;

      { Check to see if all points of object are inside marked area. }

      points_inside_mark := 0;

      { Check upper left corner.}

      IF ((object_x_position >= low_x_position) AND (object_y_position >= low_y_position) AND
            (object_x_position <= high_x_position) AND (object_y_position <= high_y_position)) THEN
        points_inside_mark := points_inside_mark + 1;
      IFEND;

      { Check lower left corner.}

      IF ((object_x_position >= low_x_position) AND (end_object_y_position >= low_y_position) AND
            (object_x_position <= high_x_position) AND (end_object_y_position <= high_y_position)) THEN
        points_inside_mark := points_inside_mark + 1;
      IFEND;

      { Check upper right corner.}

      IF ((end_object_x_position >= low_x_position) AND (object_y_position >= low_y_position) AND
            (end_object_x_position <= high_x_position) AND (object_y_position <= high_y_position)) THEN
        points_inside_mark := points_inside_mark + 1;
      IFEND;

      { Check lower right corner.}

      IF ((end_object_x_position >= low_x_position) AND (end_object_y_position >= low_y_position) AND
            (end_object_x_position <= high_x_position) AND (end_object_y_position <= high_y_position)) THEN
        points_inside_mark := points_inside_mark + 1;
      IFEND;

      IF (points_inside_mark = 4) THEN

        { All points of object are inside marked area. }

        CYCLE /check_area/;
      IFEND;

      { If some but not all points the of object are inside of mark, then mark slices object. }

      IF (points_inside_mark > 0) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$area_cuts_object, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (low_x_position), 10, FALSE,
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (low_y_position), 10, FALSE,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      { Does mark intersect object area? }

      IF ((object_x_position >= low_x_position) AND (object_y_position <= low_y_position) AND
            (end_object_x_position <= high_x_position) AND (end_object_y_position >= high_y_position)) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$area_cuts_object, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (low_x_position), 10, FALSE,
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (low_y_position), 10, FALSE,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      IF ((object_x_position <= low_x_position) AND (object_y_position >= low_y_position) AND
            (end_object_x_position >= high_x_position) AND (end_object_y_position <= high_y_position)) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$area_cuts_object, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (low_x_position), 10, FALSE,
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (low_y_position), 10, FALSE,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      IF form_object_key = fdc$form_box THEN
        IF ((object_x_position < low_x_position) AND (object_y_position < low_y_position) AND
              (end_object_x_position > high_x_position) AND (end_object_y_position > high_y_position)) THEN
          CYCLE /check_area/;
        IFEND;
      IFEND;

      { Check upper left corner.}

      IF ((object_x_position <= low_x_position) AND (object_y_position <= low_y_position) AND
            (end_object_x_position >= low_x_position) AND (end_object_y_position >= low_y_position)) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$area_cuts_object, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (low_x_position), 10, FALSE,
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (low_y_position), 10, FALSE,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      { Check lower left corner.}

      IF ((object_x_position <= low_x_position) AND (object_y_position <= high_y_position) AND
            (end_object_x_position >= low_x_position) AND (end_object_y_position >= high_y_position)) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$area_cuts_object, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (low_x_position), 10, FALSE,
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (low_y_position), 10, FALSE,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      { Check upper right corner.}

      IF ((object_x_position <= high_x_position) AND (object_y_position <= low_y_position) AND
            (end_object_x_position >= high_x_position) AND (end_object_y_position >= low_y_position)) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$area_cuts_object, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (low_x_position), 10, FALSE,
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (low_y_position), 10, FALSE,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      { Check lower right corner.}

      IF ((object_x_position <= high_x_position) AND (object_y_position <= high_y_position) AND
            (end_object_x_position >= high_x_position) AND (end_object_y_position >= high_y_position)) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$area_cuts_object, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (low_x_position), 10, FALSE,
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (low_y_position), 10, FALSE,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

    FOREND /check_area/;

  PROCEND check_for_sliced_objects;

MODEND fdm$design_form;
*DECK DECK=FDM$FORTRAN_ALIASES EXPAND=FALSE
      PROGRAM ALIAS

C PURPOSE:
C   This module simply exists to call header deck FDH$FORTAN_ALIASES.
C
C DESIGN:
C   All the processing for FORTRAN interfaces exist in module
C   FDM$COBOL_FORTRAN_REQUESTS.

*copyc fdh$fortran_aliases

      END
*DECK DECK=FDM$GENERATE_FORM_MODULE EXPAND=TRUE

?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Screen Formatting : Generate Form Module' ??
MODULE fdm$generate_form_module;

{ PURPOSE:
{   This module contains the procedures to generate the form definition language
{   and program types or variables for a form residing on an object code library.
{
{ DESIGN:
{   The form definition language is SCL. Attempt to generate as much as the form
{   language as possible in spite of errors.  This may be the only way
{   the user can recover a form that has been damaged in some way.
{   Try to avoid generating commands and parameters that represent defaults.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$page_widths
*copyc cyd$run_time_error_condition
*copyc fdc$basic_capability
*copyc fdc$integer_length
*copyc fdc$system_currency_sign
*copyc fdc$system_decimal_point
*copyc fdc$system_thousands_separator
*copyc fdt$form_definition
*copyc fdt$form_status
*copyc fdt$input_format_key_set
?? POP ??

*copyc amp$fetch
*copyc amp$put_next

*copyc clp$trimmed_string_size

*copyc i#move

*copyc fdp$close_form
*copyc fdp$convert_to_cobol_name
*copyc fdp$convert_to_fortran_name
*copyc fdp$create_form_status
*copyc fdp$get_form_attributes
*copyc fdp$get_form_names
*copyc fdp$get_form_objects
*copyc fdp$get_object_attributes
*copyc fdp$get_record_attributes
*copyc fdp$get_table_attributes
*copyc fdp$get_variable_attributes
*copyc fdp$ptr_displays
*copyc fdp$ptr_events
*copyc fdp$ptr_objects
*copyc fdp$ptr_record_definitions
*copyc fdp$ptr_tables
*copyc fdp$ptr_variables
*copyc fdp$write_record_definition

*copyc osp$establish_condition_handler
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal

*copyc pmp$continue_to_cause

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    max_command_line_size = 8192,
    min_page_width = 64;

    SECTION
    global_storage: READ;

  VAR
    display_attribute_set: fdt$display_attribute_set,
    file_attributes: array [1 .. 1] of amt$fetch_item,
    form_display_attribute_set: fdt$display_attribute_set,
    form_identifier: fdt$form_identifier,
    line: string (max_command_line_size),
    line_length: integer,
    object_display_attribute_set: fdt$display_attribute_set,
    page_width: amt$page_width;


?? OLDTITLE ??
?? NEWTITLE := '[XDCL] fdp$generate_form_module', EJECT ??
*copy fdh$generate_form_module

  PROCEDURE [XDCL] fdp$generate_form_module
    (    file_identifier: amt$file_identifier;
         form_name: ost$name;
     VAR form_module_p: ^fdt$form_module;
     VAR status: ost$status);

?? NEWTITLE := 'add_attributes', EJECT ??

    PROCEDURE add_attributes
      (    display_attribute_set: fdt$display_attribute_set;
           attribute_parameter: string ( * ));

      VAR
        attribute_present: boolean;

?? NEWTITLE := 'add_attribute_text', EJECT ??

{ PURPOSE:
{   This procedure starts or adds the text for a display attribute parameter.

      PROCEDURE add_attribute_text
        (    attribute: string ( * ));

        IF attribute_present THEN

{ Add to existing list of display attributes.

          STRINGREP (line, line_length, line (1, line_length), ', ', attribute);
        ELSE

{ Start list of display attributes.

          STRINGREP (line, line_length, line (1, line_length), ' ', attribute_parameter, '=(', attribute);
          attribute_present := TRUE;
        IFEND;

      PROCEND add_attribute_text;

?? OLDTITLE, EJECT ??

{ PURPOSE:
{   This procedure maps Screen Formatting ordinals for display attributes to
{   text for a command parameter.

      attribute_present := FALSE;
      IF fdc$inverse_video IN display_attribute_set THEN
        add_attribute_text ('inverse');
      IFEND;
      IF fdc$low_intensity IN display_attribute_set THEN
        add_attribute_text ('low_intensity');
      IFEND;
      IF fdc$high_intensity IN display_attribute_set THEN
        add_attribute_text ('high_intensity');
      IFEND;
      IF fdc$blink IN display_attribute_set THEN
        add_attribute_text ('blink');
      IFEND;
      IF fdc$underline IN display_attribute_set THEN
        add_attribute_text ('underline');
      IFEND;
      IF fdc$protect IN display_attribute_set THEN
        add_attribute_text ('protect');
      IFEND;
      IF fdc$hidden IN display_attribute_set THEN
        add_attribute_text ('hidden');
      IFEND;
      IF fdc$black_foreground IN display_attribute_set THEN
        add_attribute_text ('black_foreground');
      IFEND;
      IF fdc$black_background IN display_attribute_set THEN
        add_attribute_text ('black_background');
      IFEND;
      IF fdc$blue_foreground IN display_attribute_set THEN
        add_attribute_text ('blue_foreground');
      IFEND;
      IF fdc$blue_background IN display_attribute_set THEN
        add_attribute_text ('blue_background');
      IFEND;
      IF fdc$green_foreground IN display_attribute_set THEN
        add_attribute_text ('green_background');
      IFEND;
      IF fdc$green_background IN display_attribute_set THEN
        add_attribute_text ('green_background');
      IFEND;
      IF fdc$magenta_foreground IN display_attribute_set THEN
        add_attribute_text ('magenta_foreground');
      IFEND;
      IF fdc$magenta_background IN display_attribute_set THEN
        add_attribute_text ('magenta_background');
      IFEND;
      IF fdc$red_foreground IN display_attribute_set THEN
        add_attribute_text ('red_foreground');
      IFEND;
      IF fdc$red_background IN display_attribute_set THEN
        add_attribute_text ('red_background');
      IFEND;
      IF fdc$cyan_foreground IN display_attribute_set THEN
        add_attribute_text ('cyan_foreground');
      IFEND;
      IF fdc$cyan_background IN display_attribute_set THEN
        add_attribute_text ('cyan_background');
      IFEND;
      IF fdc$yellow_foreground IN display_attribute_set THEN
        add_attribute_text ('yellow_foreground');
      IFEND;
      IF fdc$yellow_background IN display_attribute_set THEN
        add_attribute_text ('yellow_background');
      IFEND;
      IF fdc$white_foreground IN display_attribute_set THEN
        add_attribute_text ('white_foreground');
      IFEND;
      IF fdc$white_background IN display_attribute_set THEN
        add_attribute_text ('white_background');
      IFEND;
      IF fdc$fine_line IN display_attribute_set THEN
        add_attribute_text ('fine_line');
      IFEND;
      IF fdc$medium_line IN display_attribute_set THEN
        add_attribute_text ('medium_line');
      IFEND;
      IF fdc$bold_line IN display_attribute_set THEN
        add_attribute_text ('bold_line');
      IFEND;
      IF fdc$fine_border IN display_attribute_set THEN
        add_attribute_text ('fine_border');
      IFEND;
      IF fdc$medium_border IN display_attribute_set THEN
        add_attribute_text ('medium_border');
      IFEND;
      IF fdc$bold_border IN display_attribute_set THEN
        add_attribute_text ('bold_border');
      IFEND;
      IF fdc$italic_display_attribute IN display_attribute_set THEN
        add_attribute_text ('italic');
      IFEND;
      IF fdc$title_display_attribute IN display_attribute_set THEN
        add_attribute_text ('title');
      IFEND;
      IF fdc$input_display_attribute IN display_attribute_set THEN
        add_attribute_text ('input');
      IFEND;
      IF fdc$error_display_attribute IN display_attribute_set THEN
        add_attribute_text ('error');
      IFEND;
      IF fdc$message_display_attribute IN display_attribute_set THEN
        add_attribute_text ('message');
      IFEND;
      IF fdc$display_left_to_right IN display_attribute_set THEN
        add_attribute_text ('display_left_to_right');
      IFEND;
      IF fdc$display_right_to_left IN display_attribute_set THEN
        add_attribute_text ('display_right_to_left');
      IFEND;
      IF fdc$push_input_character IN display_attribute_set THEN
        add_attribute_text ('push_input_character');
      IFEND;
      IF fdc$user_attribute_1 IN display_attribute_set THEN
        add_attribute_text ('user_attribute_1');
      IFEND;
      IF fdc$user_attribute_2 IN display_attribute_set THEN
        add_attribute_text ('user_attribute_2');
      IFEND;
      IF fdc$user_attribute_3 IN display_attribute_set THEN
        add_attribute_text ('user_attribute_3');
      IFEND;
      IF fdc$user_attribute_4 IN display_attribute_set THEN
        add_attribute_text ('user_attribute_4');
      IFEND;
      IF fdc$user_attribute_5 IN display_attribute_set THEN
        add_attribute_text ('user_attribute_5');
      IFEND;
      IF fdc$user_attribute_6 IN display_attribute_set THEN
        add_attribute_text ('user_attribute_6');
      IFEND;
      IF fdc$user_attribute_7 IN display_attribute_set THEN
        add_attribute_text ('user_attribute_7');
      IFEND;
      IF fdc$user_attribute_8 IN display_attribute_set THEN
        add_attribute_text ('user_attribute_8');
      IFEND;
      IF fdc$user_attribute_9 IN display_attribute_set THEN
        add_attribute_text ('user_attribute_9');
      IFEND;
      IF fdc$user_attribute_10 IN display_attribute_set THEN
        add_attribute_text ('user_attribute_10');
      IFEND;

{ If any display attributes were processed, end the list.

      IF attribute_present THEN
        STRINGREP (line, line_length, line (1, line_length), ')');
      IFEND;

    PROCEND add_attributes;

?? OLDTITLE ??
?? NEWTITLE := 'add_box', EJECT ??

{ PURPOSE:
{   This procedure does the add_box command.

    PROCEDURE add_box
      (    x_position: fdt$x_position;
           y_position: fdt$y_position;
       VAR status: ost$status);

      CONST
        object_definition_attribute = 1,
        object_name_attribute = 2,
        object_display_attribute = 3;

      VAR
        get_object_attributes: array [object_definition_attribute .. object_display_attribute] of
              fdt$get_object_attribute,
        get_object_definition: fdt$get_object_definition;

{ Get attributes.

      status.normal := TRUE;
      get_object_attributes [object_definition_attribute].key := fdc$get_object_definition;
      get_object_attributes [object_name_attribute].key := fdc$get_object_name;
      get_object_attributes [object_display_attribute].key := fdc$get_object_display;
      fdp$get_object_attributes (form_identifier, x_position, y_position, get_object_attributes, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

      get_object_definition := get_object_attributes [object_definition_attribute].get_object_definition;

      STRINGREP (line, line_length, 'ADD_BOX column=', x_position, ' line=', y_position, ' width=',
            get_object_definition.box_width, ' height=', get_object_definition.box_height);

{ Process NAME and OCCURRENCE parameters.

      IF get_object_attributes [object_name_attribute].get_value_status <> fdc$undefined_value THEN
        STRINGREP (line, line_length, line (1, line_length),
              ' name=', get_object_attributes [object_name_attribute].
              object_name (1, clp$trimmed_string_size (get_object_attributes [object_name_attribute].
              object_name)), ' occurrence=', get_object_attributes [object_name_attribute].occurrence);
      IFEND;

{ Remove display attributes common to the entire form.

      add_attributes (get_object_attributes [object_display_attribute].display_attribute -
            object_display_attribute_set, 'display');

      put_command_line (line (1, line_length));

    PROCEND add_box;

?? OLDTITLE ??
?? NEWTITLE := 'add_constant_text', EJECT ??

{ PURPOSE:
{   This procedure does the add_constant_text command.

    PROCEDURE add_constant_text
      (    x_position: fdt$x_position;
           y_position: fdt$y_position;
       VAR status: ost$status);

      CONST
        object_definition_attribute = 1,
        object_display_attribute = 2,
        object_name_attribute = 3;

      VAR
        get_object_attributes: array [object_definition_attribute .. object_name_attribute] of
              fdt$get_object_attribute,
        get_object_text: array [1 .. 1] of fdt$get_object_attribute,
        get_object_definition: fdt$get_object_definition;

      status.normal := TRUE;
      get_object_attributes [object_definition_attribute].key := fdc$get_object_definition;
      get_object_attributes [object_display_attribute].key := fdc$get_object_display;
      get_object_attributes [object_name_attribute].key := fdc$get_object_name;
      fdp$get_object_attributes (form_identifier, x_position, y_position, get_object_attributes, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

      get_object_definition := get_object_attributes [object_definition_attribute].get_object_definition;

      STRINGREP (line, line_length, 'ADD_CONSTANT_TEXT column=', x_position, ' line=', y_position);

{ Process TEXT parameter.

      IF get_object_definition.constant_text_length > 0 THEN
        get_object_text [1].key := fdc$get_object_text;
        PUSH get_object_text [1].p_text: [get_object_definition.constant_text_length];
        fdp$get_object_attributes (form_identifier, x_position, y_position, get_object_text, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

        STRINGREP (line, line_length, line (1, line_length), ' text=''');
        add_text (get_object_text [1].p_text^);
        STRINGREP (line, line_length, line (1, line_length), '''');

      ELSE { No text for object.}
        STRINGREP (line, line_length, line (1, line_length), ' text=''''');
      IFEND;

{ Process NAME and OCCURRENCE parameter.

      IF get_object_attributes [object_name_attribute].get_value_status <> fdc$undefined_value THEN
        STRINGREP (line, line_length, line (1, line_length),
              ' name=', get_object_attributes [object_name_attribute].
              object_name (1, clp$trimmed_string_size (get_object_attributes [object_name_attribute].
              object_name)), ' occurrence=', get_object_attributes [object_name_attribute].occurrence);
      IFEND;

{ Remove display attributes common to the entire form.

      add_attributes (get_object_attributes [object_display_attribute].display_attribute -
            object_display_attribute_set, 'display');

{ Process WIDTH parameter.

      IF get_object_definition.constant_text_length > 0 THEN
        IF ((get_object_definition.constant_text_width <> STRLENGTH (get_object_text [1].p_text^)) OR
              (get_object_text [1].p_text^ (STRLENGTH (get_object_text [1].p_text^)) = ' ') OR
              (get_object_text [1].p_text^ = '')) THEN
          STRINGREP (line, line_length, line (1, line_length), ' width=',
                get_object_definition.constant_text_width);
        IFEND;

      ELSE { No text specified for object, so specify the width of the object.}
        STRINGREP (line, line_length, line (1, line_length), ' width=',
              get_object_definition.constant_text_width);

      IFEND;

      put_command_line (line (1, line_length));

    PROCEND add_constant_text;

?? OLDTITLE ??
?? NEWTITLE := 'add_constant_text_box', EJECT ??

{ PURPOSE:
{   This procedure does the add_constant_text_box command.

    PROCEDURE add_constant_text_box
      (    x_position: fdt$x_position,
           y_position: fdt$y_position;
       VAR status: ost$status);

      CONST
        object_definition_attribute = 1,
        object_display_attribute = 2,
        object_name_attribute = 3;

      VAR
        get_object_attributes: array [object_definition_attribute .. object_name_attribute] of
              fdt$get_object_attribute,
        get_object_text: array [1 .. 1] of fdt$get_object_attribute,
        get_object_definition: fdt$get_object_definition,
        text_length: fdt$text_length;

{ Get object attributes.

      status.normal := TRUE;
      get_object_attributes [object_definition_attribute].key := fdc$get_object_definition;
      get_object_attributes [object_display_attribute].key := fdc$get_object_display;
      get_object_attributes [object_name_attribute].key := fdc$get_object_name;
      fdp$get_object_attributes (form_identifier, x_position, y_position, get_object_attributes, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

      get_object_definition := get_object_attributes [object_definition_attribute].get_object_definition;
      STRINGREP (line, line_length, 'ADD_CONSTANT_TEXT_BOX column=', x_position, ' line=', y_position,
            ' width=', get_object_definition.constant_box_width, ' height=',
            get_object_definition.constant_box_height);

{ Process TEXT parameter.

      text_length := get_object_definition.constant_box_text_length;
      IF text_length > 0 THEN
        get_object_text [1].key := fdc$get_object_text;
        PUSH get_object_text [1].p_text: [text_length];
        fdp$get_object_attributes (form_identifier, x_position, y_position, get_object_text, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

        STRINGREP (line, line_length, line (1, line_length), ' text=''');
        add_text (get_object_text [1].p_text^);
        STRINGREP (line, line_length, line (1, line_length), '''');

      ELSE {No text for object.}
        STRINGREP (line, line_length, line (1, line_length), ' text=''''');
      IFEND;

{ Process NAME and OCCURRENCE parameter.

      IF get_object_attributes [object_name_attribute].get_value_status <> fdc$undefined_value THEN
        STRINGREP (line, line_length, line (1, line_length),
              ' name=', get_object_attributes [object_name_attribute].
              object_name (1, clp$trimmed_string_size (get_object_attributes [object_name_attribute].
              object_name)), ' occurrence=', get_object_attributes [object_name_attribute].occurrence);
      IFEND;

{ Remove display attributes common to the entire form.

      add_attributes (get_object_attributes [object_display_attribute].display_attribute -
            object_display_attribute_set, 'display');

{ Process TEXT_FORMAT parameter.

      CASE get_object_attributes [object_definition_attribute].get_object_definition.
            constant_box_processing OF

      = fdc$center_characters =
        STRINGREP (line, line_length, line (1, line_length), ' text_format=center_characters');

      = fdc$wrap_characters =
        STRINGREP (line, line_length, line (1, line_length), ' text_format=wrap_characters');

      ELSE

{ Wrap words is the default. Do not output the default.

      CASEND;

      put_command_line (line (1, line_length));

    PROCEND add_constant_text_box;

?? OLDTITLE ??
?? NEWTITLE := 'add_display', EJECT ??

{ PURPOSE:
{   This procedure does the add_display command.

    PROCEDURE add_display
      (    display_attribute: fdt$display_attribute_set;
           display_name: ost$name);

      STRINGREP (line, line_length, 'ADD_DISPLAY', ' name=',
            display_name (1, clp$trimmed_string_size (display_name)));

{ If the specified display attributes are the same as the display attributes of
{ the form minus protection, then output all the specified displayed attributes. Otherwise
{ output only the display attributes that are different from the display
{ attributes of the form. Some display attributes must always be output.

      IF ((display_attribute - display_attribute_set) = $fdt$display_attribute_set []) THEN
        add_attributes (display_attribute, 'display');
      ELSE
        add_attributes (display_attribute - display_attribute_set, 'display');
      IFEND;

      put_command_line (line (1, line_length));

    PROCEND add_display;

?? OLDTITLE ??
?? NEWTITLE := 'add_event', EJECT ??

{ PURPOSE:
{   This procedure does the add_event command.

    PROCEDURE add_event
      (    get_form_attribute: fdt$get_form_attribute);

      VAR
        event_action_name: ost$name,
        event_trigger_name: ost$name;

?? NEWTITLE := 'set_event_action_name', EJECT ??

{ PURPOSE:
{   This procedure maps a Screen Formating event action ordinal to text for
{   the command.

      PROCEDURE set_event_action_name
        (    event_action: fdt$event_action;
         VAR event_action_name: ost$name);

        CASE event_action OF
        = fdc$return_program_normal =
          event_action_name := 'return_normal';
        = fdc$return_program_abnormal =
          event_action_name := 'return_abnormal';
        = fdc$page_table_forward =
          event_action_name := 'page_table_forward';
        = fdc$page_table_backward =
          event_action_name := 'page_table_backward';
        = fdc$scroll_table_forward =
          event_action_name := 'scroll_table_forward';
        = fdc$scroll_table_backward =
          event_action_name := 'scroll_table_backward';
        = fdc$display_help =
          event_action_name := 'display_help';
        = fdc$erase_help =
          event_action_name := 'erase_help';
        = fdc$execute_command =
          event_action_name := 'execute_command';
        = fdc$ignore_event =
          event_action_name := 'ignore';
        = fdc$tab_to_next_form_field =
          event_action_name := 'tab_next';
        = fdc$tab_to_previous_form_field =
          event_action_name := 'tab_previous';
        = fdc$scroll_variable_forward =
          event_action_name := 'scroll_variable_forward';
        = fdc$scroll_variable_backward =
          event_action_name := 'scroll_variable_backward';
        = fdc$page_variable_forward =
          event_action_name := 'page_variable_forward';
        = fdc$page_variable_backward =
          event_action_name := 'page_variable_backward';
        = fdc$page_variable_first =
          event_action_name := 'page_variable_first';
        = fdc$page_variable_last =
          event_action_name := 'page_variable_last';
        = fdc$page_table_first =
          event_action_name := 'page_table_first';
        = fdc$page_table_last =
          event_action_name := 'page_table_last';
        = fdc$insert_variable_line =
          event_action_name := 'insert_variable_line';
        = fdc$delete_variable_line =
          event_action_name := 'delete_variable_line';
        ELSE
          event_action_name := 'unknown';
        CASEND;
      PROCEND set_event_action_name;

?? OLDTITLE ??
?? NEWTITLE := 'set_event_trigger_name', EJECT ??

{ PURPOSE:
{   This procedure maps Screen Formatting ordinal for event trigger
{   to text for the command.

      PROCEDURE set_event_trigger_name
        (    event_trigger: fdt$event_trigger;
         VAR event_trigger_name: ost$name);

        CASE event_trigger OF
        = fdc$next =
          event_trigger_name := 'next';
        = fdc$help =
          event_trigger_name := 'help';
        = fdc$stop =
          event_trigger_name := 'stop';
        = fdc$back =
          event_trigger_name := 'back';
        = fdc$up =
          event_trigger_name := 'up';
        = fdc$down =
          event_trigger_name := 'down';
        = fdc$forward =
          event_trigger_name := 'forward';
        = fdc$backward =
          event_trigger_name := 'backward';
        = fdc$undo =
          event_trigger_name := 'undo';
        = fdc$redo =
          event_trigger_name := 'redo';
        = fdc$quit =
          event_trigger_name := 'quit';
        = fdc$exit =
          event_trigger_name := 'exit';
        = fdc$first =
          event_trigger_name := 'first';
        = fdc$last =
          event_trigger_name := 'last';
        = fdc$edit =
          event_trigger_name := 'edit';
        = fdc$data =
          event_trigger_name := 'data';
        = fdc$function_1 =
          event_trigger_name := 'f1';
        = fdc$function_2 =
          event_trigger_name := 'f2';
        = fdc$function_3 =
          event_trigger_name := 'f3';
        = fdc$function_4 =
          event_trigger_name := 'f4';
        = fdc$function_5 =
          event_trigger_name := 'f5';
        = fdc$function_6 =
          event_trigger_name := 'f6';
        = fdc$function_7 =
          event_trigger_name := 'f7';
        = fdc$function_8 =
          event_trigger_name := 'f8';
        = fdc$function_9 =
          event_trigger_name := 'f9';
        = fdc$function_10 =
          event_trigger_name := 'f10';
        = fdc$function_11 =
          event_trigger_name := 'f11';
        = fdc$function_12 =
          event_trigger_name := 'f12';
        = fdc$function_13 =
          event_trigger_name := 'f13';
        = fdc$function_14 =
          event_trigger_name := 'f14';
        = fdc$function_15 =
          event_trigger_name := 'f15';
        = fdc$function_16 =
          event_trigger_name := 'f16';
        = fdc$shift_next =
          event_trigger_name := 'shift_next';
        = fdc$shift_help =
          event_trigger_name := 'shift_help';
        = fdc$shift_stop =
          event_trigger_name := 'shift_stop';
        = fdc$shift_back =
          event_trigger_name := 'shift_back';
        = fdc$shift_up =
          event_trigger_name := 'shift_up';
        = fdc$shift_down =
          event_trigger_name := 'shift_down';
        = fdc$shift_forward =
          event_trigger_name := 'shift_forward';
        = fdc$shift_backward =
          event_trigger_name := 'shift_backward';
        = fdc$shift_edit =
          event_trigger_name := 'shift_edit';
        = fdc$shift_data =
          event_trigger_name := 'shift_data';
        = fdc$shift_function_1 =
          event_trigger_name := 'shift_f1';
        = fdc$shift_function_2 =
          event_trigger_name := 'shift_f2';
        = fdc$shift_function_3 =
          event_trigger_name := 'shift_f3';
        = fdc$shift_function_4 =
          event_trigger_name := 'shift_f4';
        = fdc$shift_function_5 =
          event_trigger_name := 'shift_f5';
        = fdc$shift_function_6 =
          event_trigger_name := 'shift_f6';
        = fdc$shift_function_7 =
          event_trigger_name := 'shift_f7';
        = fdc$shift_function_8 =
          event_trigger_name := 'shift_f8';
        = fdc$shift_function_9 =
          event_trigger_name := 'shift_f9';
        = fdc$shift_function_10 =
          event_trigger_name := 'shift_f10';
        = fdc$shift_function_11 =
          event_trigger_name := 'shift_f11';
        = fdc$shift_function_12 =
          event_trigger_name := 'shift_f12';
        = fdc$shift_function_13 =
          event_trigger_name := 'shift_f13';
        = fdc$shift_function_14 =
          event_trigger_name := 'shift_f14';
        = fdc$shift_function_15 =
          event_trigger_name := 'shift_f15';
        = fdc$shift_function_16 =
          event_trigger_name := 'shift_f16';
        = fdc$pick =
          event_trigger_name := 'pick';
        = fdc$insert_line =
          event_trigger_name := 'insert_line';
        = fdc$delete_line =
          event_trigger_name := 'delete_line';
        = fdc$home_cursor =
          event_trigger_name := 'home';
        = fdc$clear_screen =
          event_trigger_name := 'clear_screen';
        = fdc$time_out =
          event_trigger_name := 'time_out';
        = fdc$variable_trigger =
          event_trigger_name := 'variable_trigger';
        ELSE
        CASEND;

      PROCEND set_event_trigger_name;

?? OLDTITLE, EJECT ??

      set_event_trigger_name (get_form_attribute.event_trigger_v1, event_trigger_name);
      set_event_action_name (get_form_attribute.event_action_v1, event_action_name);
      STRINGREP (line, line_length, 'ADD_EVENT ', 'program_event=', get_form_attribute.
            event_name_v1 (1, clp$trimmed_string_size (get_form_attribute.event_name_v1)), ' terminal_event=',
            event_trigger_name (1, clp$trimmed_string_size (event_trigger_name)), ' action=',
            event_action_name (1, clp$trimmed_string_size (event_action_name)));

{ If no text is specified for event label, do not output label.

      IF get_form_attribute.event_label_v1 <> '' THEN
        STRINGREP (line, line_length, line (1, line_length), ' label=''');
        add_text (get_form_attribute.event_label_v1);
        STRINGREP (line, line_length, line (1, line_length), '''');
      IFEND;

{ If terminal event may be reassigned, do not output terminal_event_reassignment.

      IF NOT get_form_attribute.event_trigger_reassignment_v1 THEN
        STRINGREP (line, line_length, line (1, line_length), ' reassign_terminal_event=FALSE');
      IFEND;

      put_command_line (line (1, line_length));

    PROCEND add_event;
?? OLDTITLE ??
?? NEWTITLE := 'add_line', EJECT ??

{ PURPOSE:
{   This procedure does the add_line command.

    PROCEDURE add_line
      (    x_position: fdt$x_position,
           y_position: fdt$y_position;
       VAR status: ost$status);

      CONST
        object_definition_attribute = 1,
        object_display_attribute = 2,
        object_name_attribute = 3;

      VAR
        end_column: fdt$x_position,
        end_line: fdt$y_position,
        get_object_attributes: array [object_definition_attribute .. object_name_attribute] of
              fdt$get_object_attribute,
        get_object_definition: fdt$get_object_definition;

{ Get object attributes.

      status.normal := TRUE;
      get_object_attributes [object_definition_attribute].key := fdc$get_object_definition;
      get_object_attributes [object_display_attribute].key := fdc$get_object_display;
      get_object_attributes [object_name_attribute].key := fdc$get_object_name;
      fdp$get_object_attributes (form_identifier, x_position, y_position, get_object_attributes, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

      get_object_definition := get_object_attributes [object_definition_attribute].get_object_definition;

      STRINGREP (line, line_length, 'ADD_LINE start_column=', x_position, ' start_line=', y_position,
            ' end_column=', get_object_definition.x_increment + x_position, ' end_line=',
            get_object_definition.y_increment + y_position);

{ If NAME and OCCURRENCE parameter defined, output them.

      IF get_object_attributes [object_name_attribute].get_value_status <> fdc$undefined_value THEN
        STRINGREP (line, line_length, line (1, line_length),
              ' name=', get_object_attributes [object_name_attribute].
              object_name (1, clp$trimmed_string_size (get_object_attributes [object_name_attribute].
              object_name)), ' occurrence=', get_object_attributes [object_name_attribute].occurrence);
      IFEND;

{ Remove display attributes that apply to the entire form.

      add_attributes (get_object_attributes [object_display_attribute].display_attribute -
            object_display_attribute_set, 'display');

      put_command_line (line (1, line_length));

    PROCEND add_line;

?? OLDTITLE ??
?? NEWTITLE := 'add_table', EJECT ??

{ PURPOSE:
{   This procedure does the add_table command.

    PROCEDURE add_table
      (    table_name: ost$name);

      VAR
        get_table_attributes: array [1 .. 3] of fdt$get_table_attribute,
        number_table_variables: fdt$number_table_variables,
        get_table_attributes_p: ^array [1 .. * ] of fdt$get_table_attribute,
        stored_occurrence: fdt$occurrence,
        variable_index: fdt$number_table_variables,
        visible_occurrence: fdt$occurrence;

{ Get table attributes.

      get_table_attributes [1].key := fdc$get_number_table_variables;
      get_table_attributes [2].key := fdc$get_stored_occurrence;
      get_table_attributes [3].key := fdc$get_visible_occurrence;
      fdp$get_table_attributes (form_identifier, table_name, get_table_attributes, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

      number_table_variables := get_table_attributes [1].number_table_variables;
      stored_occurrence := get_table_attributes [2].stored_occurrence;

      IF get_table_attributes [3].get_value_status = fdc$undefined_value THEN
        visible_occurrence := get_table_attributes [2].stored_occurrence;
      ELSE
        visible_occurrence := get_table_attributes [3].visible_occurrence;
      IFEND;

{ Get variables associated with table.

      IF number_table_variables > 0 THEN
        PUSH get_table_attributes_p: [1 .. number_table_variables];
        FOR variable_index := 1 TO number_table_variables DO
          get_table_attributes_p^ [variable_index].key := fdc$get_next_table_variable;
        FOREND;

        fdp$get_table_attributes (form_identifier, table_name, get_table_attributes_p^, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;
      IFEND;

      STRINGREP (line, line_length, 'ADD_TABLE table_name=',
            table_name (1, clp$trimmed_string_size (table_name)));

{ Process VARIABLE_NAME parameter. Start list of variables.

      IF number_table_variables > 0 THEN
        STRINGREP (line, line_length, line (1, line_length), ' variable_name=(');

{ Add variable to list.

        FOR variable_index := 1 TO number_table_variables DO
          STRINGREP (line, line_length, line (1, line_length),
                get_table_attributes_p^ [variable_index].variable_name
                (1, clp$trimmed_string_size (get_table_attributes_p^ [variable_index].variable_name)), ' ');
        FOREND;

        STRINGREP (line, line_length, line (1, line_length), ')');
      IFEND;

{ Complete list of variables.

      STRINGREP (line, line_length, line (1, line_length), ' stored_occurrence =', stored_occurrence,
            ' visible_occurrence=', visible_occurrence);
      put_command_line (line (1, line_length));

    PROCEND add_table;

?? OLDTITLE ??
?? NEWTITLE := 'add_text', EJECT ??

{ PURPOSE:
{   This procedure processes text that may have a quote.
{ DESIGN:
{ If a quote appears in the text, the quote must be replaced with two quotes.

    PROCEDURE add_text
      (    text: string ( * ));

      VAR
        character_index: 1 .. max_command_line_size;

      FOR character_index := 1 TO clp$trimmed_string_size (text) DO
        line_length := line_length + 1;
        line (line_length, 1) := text (character_index, 1);

        IF text (character_index, 1) = '''' THEN
          line_length := line_length + 1;
          line (line_length, 1) := '''';
        IFEND;

      FOREND;

    PROCEND add_text;

?? OLDTITLE ??
?? NEWTITLE := 'add_variable', EJECT ??

{ PURPOSE:
{   This procedure does the add_variable command.

    PROCEDURE add_variable
      (    variable_name: ost$name);

      CONST
        io_mode_attribute = 1,
        program_data_attribute = 2,
        error_processing_attribute = 3,
        help_attribute = 4,
        length_attribute = 5,
        error_display_attribute = 6,
        user_entry_attribute = 7,
        comments_attribute = 8;

      VAR
        comment_length: fdt$comment_length,
        exponent_output_format: fdt$exponent_output_format,
        format: string (2),
        float_output_format: fdt$float_output_format,
        get_variable_attributes: array [io_mode_attribute .. comments_attribute] of
              fdt$get_variable_attribute,
        get_variable_attributes_p: ^array [1 .. * ] of fdt$get_variable_attribute,
        integer_output_format: fdt$integer_output_format,
        io_mode: fdt$io_mode,
        number_comments: fdt$number_comments,
        output_currency_format: fdt$output_currency_format,
        program_data_type: fdt$program_data_type,
        terminal_user_entry: fdt$terminal_user_entry,
        text_attribute: array [1 .. 1] of fdt$get_variable_attribute;

?? NEWTITLE := 'set_character_input', EJECT ??

{ PURPOSE:
{   This procedure does the set_character_input command.

      PROCEDURE set_character_input;

        VAR
          get_variable_attributes: array [1 .. 3] of fdt$get_variable_attribute,
          input_format_key: fdt$input_format_key,
          get_variable_attributes_p: ^array [1 .. * ] of fdt$get_variable_attribute,
          number_valid_strings: fdt$number_valid_strings,
          valid_string_length: fdt$valid_string_length;

{ Get attributes that apply to program character data type.

        get_variable_attributes [1].key := fdc$get_number_valid_strings;
        get_variable_attributes [2].key := fdc$get_string_compare_rules;
        get_variable_attributes [3].key := fdc$get_input_format;
        fdp$get_variable_attributes (form_identifier, variable_name, get_variable_attributes, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

{ Output only non default attributes.

        line_length := 0;
        IF get_variable_attributes [1].number_valid_strings > 0 THEN

{ Process valid values.

          STRINGREP (line, line_length, 'SET_CHARACTER_INPUT', ' variable_name=',
                variable_name (1, clp$trimmed_string_size (variable_name)), ' valid_value=(');
          PUSH get_variable_attributes_p: [1 .. get_variable_attributes [1].number_valid_strings];

{ Learn the space needed to obtain the valid string values.

          FOR number_valid_strings := 1 TO get_variable_attributes [1].number_valid_strings DO
            get_variable_attributes_p^ [number_valid_strings].key := fdc$get_valid_string_length;
          FOREND;

          fdp$get_variable_attributes (form_identifier, variable_name, get_variable_attributes_p^, status);
          IF NOT status.normal THEN
            EXIT fdp$generate_form_module;
          IFEND;

{ Obtain space for valid strings.

          FOR number_valid_strings := 1 TO get_variable_attributes [1].number_valid_strings DO
            valid_string_length := get_variable_attributes_p^ [number_valid_strings].valid_string_length;
            get_variable_attributes_p^ [number_valid_strings].key := fdc$get_next_valid_string;
            PUSH get_variable_attributes_p^ [number_valid_strings].p_valid_string: [valid_string_length];
          FOREND;

          fdp$get_variable_attributes (form_identifier, variable_name, get_variable_attributes_p^, status);
          IF NOT status.normal THEN
            EXIT fdp$generate_form_module;
          IFEND;

{ Start list of valid strings.

          STRINGREP (line, line_length, line (1, line_length), '''');
          add_text (get_variable_attributes_p^ [1].p_valid_string^);
          STRINGREP (line, line_length, line (1, line_length), '''');

{ Output list of valid strings.

          FOR number_valid_strings := 2 TO get_variable_attributes [1].number_valid_strings DO
            STRINGREP (line, line_length, line (1, line_length), ' ', '''');
            add_text (get_variable_attributes_p^ [number_valid_strings].p_valid_string^);
            STRINGREP (line, line_length, line (1, line_length), '''');
          FOREND;

{ Complete list of valid strings.

          STRINGREP (line, line_length, line (1, line_length), ')');
        IFEND;

{ Process COMPARE_TO_SUBSTRING parameter.

          IF line_length = 0 THEN
            STRINGREP (line, line_length, 'SET_CHARACTER_INPUT', ' variable_name=',
                  variable_name (1, clp$trimmed_string_size (variable_name)));
          IFEND;
          IF get_variable_attributes [2].compare_to_unique_substring THEN
            STRINGREP (line, line_length, line (1, line_length), ' compare_to_substring=true');
          ELSE
            STRINGREP (line, line_length, line (1, line_length), ' compare_to_substring=false');
          IFEND;

{ Process ENTRY_FORMAT parameter.

        IF get_variable_attributes [3].get_value_status <> fdc$undefined_value THEN

          CASE get_variable_attributes [3].input_format.key OF


          = fdc$alphabetic_input_format =

            IF line_length = 0 THEN
              STRINGREP (line, line_length, 'SET_CHARACTER_INPUT', ' variable_name=',
                    variable_name (1, clp$trimmed_string_size (variable_name)), ' entry_format=alphabetic');
            ELSE
              STRINGREP (line, line_length, line (1, line_length), ' entry_format=alphabetic');
            IFEND;

          = fdc$digits_input_format =
            IF line_length = 0 THEN
              STRINGREP (line, line_length, 'SET_CHARACTER_INPUT', ' variable_name=',
                    variable_name (1, clp$trimmed_string_size (variable_name)), ' entry_format=digits');
            ELSE
              STRINGREP (line, line_length, line (1, line_length), ' entry_format=digits');
            IFEND;

          = fdc$signed_input_format =
            IF line_length = 0 THEN
              STRINGREP (line, line_length, 'SET_CHARACTER_INPUT', ' variable_name=',
                    variable_name (1, clp$trimmed_string_size (variable_name)), ' entry_format=signed');
            ELSE
              STRINGREP (line, line_length, line (1, line_length), ' entry_format=signed');
            IFEND;

          ELSE {fdc$character_input_format}

{ Do not output the default.

          CASEND;
        IFEND;

        IF line_length > 0 THEN
          put_command_line (line (1, line_length));
        IFEND;

      PROCEND set_character_input;

?? OLDTITLE ??
?? NEWTITLE := 'set_cobol_data', EJECT ??

{ PURPOSE :
{   Procedure to create 'set_cobol_data' command.

      PROCEDURE set_cobol_data;

        VAR
          cobol_program_clause : fdt$cobol_program_clause,
          get_variable_attributes: array [1 .. 1] of
                fdt$get_variable_attribute,
          usage: fdt$usage,
          usage_string: string (15);

        status.normal := TRUE;
        line_length := 0;
        get_variable_attributes [1].key := fdc$get_cobol_program_clause;
        get_variable_attributes [1].p_cobol_program_clause :=
              ^cobol_program_clause;
        fdp$get_variable_attributes (form_identifier, variable_name,
              get_variable_attributes, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

{ Output SET_COBOL_DATA command.

        IF NOT ((get_variable_attributes[1].get_value_status =
                                      fdc$undefined_value) OR
                (get_variable_attributes[1].get_value_status =
                                      fdc$unprocessed_get_value)) THEN

{ Output PICTURE parameter.

          IF (cobol_program_clause.picture <> '') THEN
            STRINGREP(line, line_length, 'SET_COBOL_DATA', ' variable_name=',
                      variable_name(1, clp$trimmed_string_size(variable_name)),
                      ' picture=''',
                      cobol_program_clause.picture(1,clp$trimmed_string_size(
                      cobol_program_clause.picture)), '''');
          IFEND;

{ Output USAGE parameter.

         CASE cobol_program_clause.usage OF

         = fdc$binary_usage =
           usage_string := 'BINARY';
         = fdc$computational_usage =
           usage_string := 'COMPUTATIONAL';
         = fdc$comp_usage =
           usage_string := 'COMP';
         = fdc$computational_1_usage =
           usage_string := 'COMPUTATIONAL_1';
         = fdc$comp_1_usage=
           usage_string := 'COMP_1';
         = fdc$computational_2_usage =
           usage_string := 'COMPUTATIONAL_2';
         = fdc$comp_2_usage =
           usage_string := 'COMP_2';
         = fdc$computational_3_usage =
           usage_string := 'COMPUTATIONAL_3';
         = fdc$comp_3_usage =
           usage_string := 'COMP_3';
         = fdc$packed_decimal_usage =
           usage_string := 'PACKED_DECIMAL';
         ELSE

{ Do not output default for fdc$display_usage }
           usage_string := '';
         CASEND;
         IF usage_string  <> '' THEN
           IF line_length > 0 THEN
              STRINGREP(line, line_length, line (1,line_length), ' usage=',
                    usage_string (1, clp$trimmed_string_size(usage_string )));
           ELSE
             STRINGREP(line, line_length,'SET_COBOL_DATA', ' variable_name=',
                    variable_name(1, clp$trimmed_string_size(variable_name)), ' usage=',
                    usage_string (1, clp$trimmed_string_size(usage_string)));
           IFEND;
         IFEND;

         IF line_length > 0 THEN
           put_command_line (line (1,line_length));
         IFEND;
        IFEND;

      PROCEND set_cobol_data;

?? OLDTITLE ??
?? NEWTITLE := 'set_cobol_output', EJECT ??

{ PURPOSE :
{   Procedure to create 'set_cobol_output' command.

      PROCEDURE set_cobol_output;
        VAR
          cobol_display_clause : fdt$cobol_display_clause,
          get_variable_attributes: array [1 .. 1] of
                fdt$get_variable_attribute;

        status.normal := TRUE;
        line_length := 0;
        get_variable_attributes [1].key := fdc$get_cobol_display_clause;
        get_variable_attributes [1].p_cobol_display_clause :=
              ^cobol_display_clause;
        fdp$get_variable_attributes (form_identifier, variable_name,
              get_variable_attributes, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

{ Output SET_COBOL_OUTPUT command.

        IF NOT ((get_variable_attributes[1].get_value_status =
                                      fdc$undefined_value) OR
                (get_variable_attributes[1].get_value_status =
                                      fdc$unprocessed_get_value)) THEN

{ Output PICTURE parameter.

          IF (cobol_display_clause.picture <> '') THEN
            STRINGREP(line, line_length, 'SET_COBOL_OUTPUT', ' variable_name=',
                      variable_name(1, clp$trimmed_string_size(variable_name)),
                     ' picture=''',
                      cobol_display_clause.picture(1,clp$trimmed_string_size(
                      cobol_display_clause.picture)),'''');
            put_command_line (line (1,line_length));
          IFEND;
        IFEND;

      PROCEND set_cobol_output;

?? OLDTITLE ??
?? NEWTITLE := 'set_date_input', EJECT ??

{ PURPOSE:
{   This procedure does the set_date_input command.

      PROCEDURE set_date_input
        (    get_variable_attributes: array [1 .. 2] of fdt$get_variable_attribute);

        VAR
          format: string (5);


        CASE get_variable_attributes [2].input_format.key OF

        = fdc$dmy_format =
          format := 'dmy';

        = fdc$mdy_format =
          format := 'mdy';

        = fdc$ydm_format =
          format := 'ydm';

        = fdc$iso_date_format =
          format := 'isod';

        ELSE{fdc$month_dd_yyyy_format =
          format := 'month';
        CASEND;

        STRINGREP (line, line_length, 'SET_DATE_INPUT', ' variable_name=',
              variable_name (1, clp$trimmed_string_size (variable_name)), ' format=', format);

        put_command_line (line (1, line_length));

      PROCEND set_date_input;

?? OLDTITLE ??
?? NEWTITLE := 'set_date_output', EJECT ??

{ PURPOSE:
{   This procedure does the set_date_output command.

      PROCEDURE set_date_output
        (    format: string (*));


        STRINGREP (line, line_length, 'SET_DATE_OUTPUT', ' variable_name=',
              variable_name (1, clp$trimmed_string_size (variable_name)), ' format=', format);

        put_command_line (line (1, line_length));

      PROCEND set_date_output;

?? OLDTITLE ??
?? NEWTITLE := 'set_exponent_output', EJECT ??

{ PURPOSE:
{   This procedure does the set_exponent_output command.

      PROCEDURE set_exponent_output;

        STRINGREP (line, line_length, 'SET_EXPONENT_OUTPUT', ' variable_name=',
              variable_name (1, clp$trimmed_string_size (variable_name)), ' format=', format, ' width=',
              exponent_output_format.field_width, ' digits_right_of_decimal=',
              exponent_output_format.digits_right_decimal, ' digits_in_exponent=',
              exponent_output_format.digits_in_exponent);

{ Process SIGN parameter. Do not output the default: minus if negative.

        IF exponent_output_format.sign_treatment <> mlc$minus_if_negative THEN
          STRINGREP (line, line_length, line (1, line_length), ' sign=always_signed');
        IFEND;

{ Process SUPPRESS_ZERO parameter.  Do  not output the default:
{ suppress zero TRUE.

        IF NOT exponent_output_format.suppress_zero THEN
          STRINGREP (line, line_length, line (1, line_length), ' suppress_zero=false');
        IFEND;

        put_command_line (line (1, line_length));

      PROCEND set_exponent_output;

?? OLDTITLE ??
?? NEWTITLE := 'set_float_output', EJECT ??

{ PURPOSE:
{   This procedure does the set_float_output command.

      PROCEDURE set_float_output;

        STRINGREP (line, line_length, 'SET_FLOAT_OUTPUT', ' variable_name=',
              variable_name (1, clp$trimmed_string_size (variable_name)), ' format=', format(1), ' width=',
              float_output_format.field_width, ' digits_right_of_decimal = ',
              float_output_format.digits_right_decimal);

{ Process SIGN parameter.  Do not output the default: always signed.

        IF float_output_format.sign_treatment <> mlc$minus_if_negative THEN
          STRINGREP (line, line_length, line (1, line_length), ' sign=always_signed');
        IFEND;

{ Process SUPPRESS_ZERO parameter.  Do not output the default:
{ suppress zero TRUE.

        IF NOT float_output_format.suppress_zero THEN
          STRINGREP (line, line_length, line (1, line_length), ' suppress_zero=false');
        IFEND;

        put_command_line (line (1, line_length));

      PROCEND set_float_output;

?? OLDTITLE ??
?? NEWTITLE := 'set_integer_input', EJECT ??

{ PURPOSE:
{   This procedure does the set_integer_input command.

      PROCEDURE set_integer_input;

        VAR
          get_variable_attributes: array [1 .. 2] of fdt$get_variable_attribute,
          number_valid_integers: fdt$number_valid_integers,
          get_variable_attributes_p: ^array [1 .. * ] of fdt$get_variable_attribute;

{ Get attributes for integer program data type.

        get_variable_attributes [1].key := fdc$get_number_valid_integers;
        get_variable_attributes [2].key := fdc$get_input_format;
        fdp$get_variable_attributes (form_identifier, variable_name, get_variable_attributes, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

        IF (get_variable_attributes [2].get_value_status <> fdc$undefined_value) AND
              (get_variable_attributes [2].input_format.key IN $fdt$input_format_key_set [fdc$ydm_format,
              fdc$dmy_format, fdc$mdy_format, fdc$iso_date_format, fdc$month_dd_yyyy_format]) THEN
          set_date_input (get_variable_attributes);
          RETURN;
        IFEND;

{ Only output command and parameter if non defaults occur.

        line_length := 0;
        IF get_variable_attributes [1].number_valid_integers > 0 THEN

{ Get list  of valid integers.

          PUSH get_variable_attributes_p: [1 .. get_variable_attributes [1].number_valid_integers];
          FOR number_valid_integers := 1 TO get_variable_attributes [1].number_valid_integers DO
            get_variable_attributes_p^ [number_valid_integers].key := fdc$get_valid_integer_range;
          FOREND;

          fdp$get_variable_attributes (form_identifier, variable_name, get_variable_attributes_p^, status);
          IF NOT status.normal THEN
            EXIT fdp$generate_form_module;
          IFEND;

{ Start list of range of integer.


          IF get_variable_attributes_p^ [1].minimum_integer <>
                get_variable_attributes_p^ [1].maximum_integer THEN
            STRINGREP (line, line_length, 'SET_INTEGER_INPUT', ' variable_name= ',
                  variable_name (1, clp$trimmed_string_size (variable_name)), ' valid_value=(',
                  get_variable_attributes_p^ [1].minimum_integer, ' .. ',
                  get_variable_attributes_p^ [1].maximum_integer);
          ELSE
            STRINGREP (line, line_length, 'SET_INTEGER_INPUT', ' variable_name= ',
                  variable_name (1, clp$trimmed_string_size (variable_name)), ' valid_value=(',
                  get_variable_attributes_p^ [1].minimum_integer);
          IFEND;

{ Add to list of range of integer.

          FOR number_valid_integers := 2 TO get_variable_attributes [1].number_valid_integers DO
            IF get_variable_attributes_p^ [number_valid_integers].minimum_integer <>
                get_variable_attributes_p^ [number_valid_integers].maximum_integer THEN
              STRINGREP (line, line_length, line (1, line_length),
                    ' ', get_variable_attributes_p^ [number_valid_integers].minimum_integer, ' .. ',
                    get_variable_attributes_p^ [number_valid_integers].maximum_integer);
            ELSE
              STRINGREP (line, line_length, line (1, line_length),
                  ' ', get_variable_attributes_p^ [number_valid_integers].minimum_integer);
            IFEND;
          FOREND;

{ Complete list of range of integer.

          STRINGREP (line, line_length, line (1, line_length), ')');
        IFEND;

{ Process ENTRY_FORMAT parameter.

        IF get_variable_attributes [2].get_value_status <> fdc$undefined_value THEN

          CASE get_variable_attributes [2].input_format.key OF

          = fdc$digits_input_format =

            IF line_length = 0 THEN
              STRINGREP (line, line_length, 'SET_INTEGER_INPUT', ' variable_name= ',
                    variable_name (1, clp$trimmed_string_size (variable_name)), ' entry_format=digits');
            ELSE
              STRINGREP (line, line_length, line (1, line_length), ' entry_format=digits');
            IFEND;

          ELSE

{ Signed input is the default. Do not output the default.

          CASEND;
        IFEND;

        IF line_length > 0 THEN
          put_command_line (line (1, line_length));
        IFEND;

      PROCEND set_integer_input;

?? OLDTITLE ??
?? NEWTITLE := 'set_integer_output', EJECT ??

{ PURPOSE:
{   This procedure does the set_integer_output command.

      PROCEDURE set_integer_output;

        STRINGREP (line, line_length, 'SET_INTEGER_OUTPUT', ' variable_name=',
              variable_name (1, clp$trimmed_string_size (variable_name)), ' width=',
              integer_output_format.field_width);

{ Process MINIMUM_DIGITS parameter.

        IF integer_output_format.minimum_output_digits <> 0 THEN
          STRINGREP (line, line_length, line (1, line_length), ' minimum_digits=',
                integer_output_format.minimum_output_digits);
        IFEND;

{ Process SIGN parameter.

        IF integer_output_format.sign_treatment <> mlc$minus_if_negative THEN
          STRINGREP (line, line_length, line (1, line_length), ' sign=always_signed');
        IFEND;

        put_command_line (line (1, line_length));

      PROCEND set_integer_output;

?? OLDTITLE ??
?? NEWTITLE := 'set_money_input', EJECT ??

{ PURPOSE:
{   This procedure does the set_money_input command.

      PROCEDURE set_money_input;

        VAR
          get_variable_attributes: array [1 .. 1] of fdt$get_variable_attribute,
          input_currency_format: fdt$input_currency_format;

        get_variable_attributes [1].key := fdc$get_input_format;
        fdp$get_variable_attributes (form_identifier, variable_name, get_variable_attributes, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;


        CASE get_variable_attributes [1].input_format.key OF

        = fdc$currency_input_format =
          input_currency_format := get_variable_attributes [1].input_format.input_currency_format;

{ If form definition uses all the defaults, do not generate a command.

          IF ((input_currency_format.currency_sybmol <> fdc$system_currency_sign) OR
                (input_currency_format.thousands_separator <> fdc$system_thousands_separator) OR
                (input_currency_format.decimal_point <> fdc$system_decimal_point)) THEN
            STRINGREP (line, line_length, 'SET_MONEY_INPUT', ' variable_name=',
                  variable_name (1, clp$trimmed_string_size (variable_name)));

            IF input_currency_format.currency_sybmol <> fdc$system_currency_sign THEN
              STRINGREP (line, line_length, line (1, line_length), ' money_symbol=''',
                    input_currency_format.currency_sybmol {sic} , '''');
            IFEND;

            IF input_currency_format.thousands_separator <> fdc$system_thousands_separator THEN
              STRINGREP (line, line_length, line (1, line_length), ' thousands_separator=''',
                    input_currency_format.thousands_separator, '''');
            IFEND;

            IF input_currency_format.decimal_point <> fdc$system_decimal_point THEN
              STRINGREP (line, line_length, line (1, line_length), ' decimal_point=''',
                    input_currency_format.decimal_point, '''');
            IFEND;

            put_command_line (line (1, line_length));
          IFEND;

        ELSE
        CASEND;

      PROCEND set_money_input;

?? OLDTITLE ??
?? NEWTITLE := 'set_money_output', EJECT ??

{ PURPOSE:
{   This procedure does the set_money_output command.

      PROCEDURE set_money_output;

{ If form definition uses all the defaults, do not generate a command.

        IF ((output_currency_format.currency_sybmol <> fdc$system_currency_sign) OR
              (output_currency_format.thousands_separator <> fdc$system_thousands_separator) OR
              (output_currency_format.decimal_point <> fdc$system_decimal_point)) THEN
          STRINGREP (line, line_length, 'SET_MONEY_OUTPUT', ' variable_name=',
                variable_name (1, clp$trimmed_string_size (variable_name)));

          IF output_currency_format.currency_sybmol <> fdc$system_currency_sign THEN
            STRINGREP (line, line_length, line (1, line_length), ' money_symbol=''',
                  output_currency_format.currency_sybmol {sic} , '''');
          IFEND;

          IF output_currency_format.thousands_separator <> fdc$system_thousands_separator THEN
            STRINGREP (line, line_length, line (1, line_length), ' thousands_separator=''',
                  output_currency_format.thousands_separator, '''');
          IFEND;

          IF output_currency_format.decimal_point <> fdc$system_decimal_point THEN
            STRINGREP (line, line_length, line (1, line_length), ' decimal_point=''',
                  output_currency_format.decimal_point, '''');
          IFEND;

          put_command_line (line (1, line_length));
        IFEND;

      PROCEND set_money_output;

?? OLDTITLE ??
?? NEWTITLE := 'set_input', EJECT ??

{ PURPOSE:
{   This procedure makes changes to input processing.

      PROCEDURE set_input;


{ Process attributes that apply to program data type. Both integers and reals
{ can be used for money.

        CASE program_data_type OF

        = fdc$program_character_type, fdc$program_upper_case_type =
          set_character_input;

        = fdc$program_integer_type =
          set_integer_input;
          set_money_input;

        = fdc$program_real_type =
          set_real_input;
          set_money_input;

       ELSE { fdc$program_cobol_type
         set_money_input;
         set_cobol_data;
         set_character_input;
         set_integer_input;
         set_real_input;
        CASEND;

      PROCEND set_input;

?? OLDTITLE ??
?? NEWTITLE := 'set_output', EJECT ??

{ PURPOSE:
{   This procedure makes changes to output processing.

      PROCEDURE set_output;

        VAR
          get_variable_attributes: array [1 .. 1] of fdt$get_variable_attribute;

        get_variable_attributes [1].key := fdc$get_output_format;
        fdp$get_variable_attributes (form_identifier, variable_name, get_variable_attributes, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

        IF program_data_type = fdc$program_cobol_type THEN
          IF get_variable_attributes [1].output_format.key = fdc$currency_output_format THEN
            output_currency_format := get_variable_attributes [1].output_format.output_currency_format;
            set_money_output;
          IFEND;
          set_cobol_output;
          RETURN;
        IFEND;

        CASE get_variable_attributes [1].output_format.key OF

        = fdc$character_output_format =

{ Do nothing.  Character output format can not be changed.

        = fdc$currency_output_format =
          output_currency_format := get_variable_attributes [1].output_format.output_currency_format;
          set_money_output;

        = fdc$e_e_output_format =
          format := 'EE';
          exponent_output_format := get_variable_attributes [1].output_format.exponent_output_format;
          set_exponent_output;

        = fdc$g_e_output_format =
          format := 'GE';
          exponent_output_format := get_variable_attributes [1].output_format.exponent_output_format;
          set_exponent_output;

        = fdc$e_output_format =
          format := 'E';
          float_output_format := get_variable_attributes [1].output_format.float_output_format;
          set_float_output;

        = fdc$f_output_format =
          format := 'F';
          float_output_format := get_variable_attributes [1].output_format.float_output_format;
          set_float_output;

        = fdc$g_output_format =
          format := 'G';
          float_output_format := get_variable_attributes [1].output_format.float_output_format;
          set_float_output;

        = fdc$integer_output_format =
          integer_output_format := get_variable_attributes [1].output_format.integer_output_format;
          set_integer_output;

        = fdc$dmy_output_format =
          set_date_output ('dmy');

        = fdc$mdy_output_format =
          set_date_output ('mdy');

        = fdc$ydm_output_format =
          set_date_output ('ydm');

        = fdc$iso_output_format =
          set_date_output ('isod');

        = fdc$month_dd_yyyy_out_format =
          set_date_output ('month');

        ELSE
        CASEND;

      PROCEND set_output;

?? OLDTITLE ??
?? NEWTITLE := 'set_real_input', EJECT ??

{ PURPOSE:
{   This procedure does the set_real_input command.

      PROCEDURE set_real_input;

        VAR
          get_variable_attributes: array [1 .. 1] of fdt$get_variable_attribute,
          number_valid_reals: fdt$number_valid_reals,
          get_variable_attributes_p: ^array [1 .. * ] of fdt$get_variable_attribute;

        get_variable_attributes [1].key := fdc$get_number_valid_reals;
        fdp$get_variable_attributes (form_identifier, variable_name, get_variable_attributes, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

        IF get_variable_attributes [1].number_valid_reals < 1 THEN
          RETURN;
        IFEND;

{ Get space to receive valid reals.

        PUSH get_variable_attributes_p: [1 .. get_variable_attributes [1].number_valid_reals];
        FOR number_valid_reals := 1 TO get_variable_attributes [1].number_valid_reals DO
          get_variable_attributes_p^ [number_valid_reals].key := fdc$get_next_valid_real_range;
        FOREND;

{ Get valid reals.

        fdp$get_variable_attributes (form_identifier, variable_name, get_variable_attributes_p^, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

{ Start list of range of reals.

        IF get_variable_attributes_p^ [1].minimum_real <>
              get_variable_attributes_p^ [1].maximum_real THEN
          STRINGREP (line, line_length, 'SET_REAL_INPUT', ' variable_name= ',
                variable_name (1, clp$trimmed_string_size (variable_name)), ' valid_value=(',
                get_variable_attributes_p^ [1].minimum_real, ' .. ', get_variable_attributes_p^ [1].
                maximum_real);
        ELSE
          STRINGREP (line, line_length, 'SET_REAL_INPUT', ' variable_name= ',
                variable_name (1, clp$trimmed_string_size (variable_name)), ' valid_value=(',
                get_variable_attributes_p^ [1].minimum_real);
        IFEND;

{ Add to list of range of reals.

        FOR number_valid_reals := 2 TO get_variable_attributes [1].number_valid_reals DO
          IF get_variable_attributes_p^ [number_valid_reals].minimum_real <>
              get_variable_attributes_p^ [number_valid_reals].maximum_real THEN
            STRINGREP (line, line_length, line (1, line_length),
                  ' ', get_variable_attributes_p^ [number_valid_reals].minimum_real, ' .. ',
                  get_variable_attributes_p^ [number_valid_reals].maximum_real);
          ELSE
            STRINGREP (line, line_length, line (1, line_length),
                  ' ', get_variable_attributes_p^ [number_valid_reals].minimum_real);
          IFEND;
        FOREND;

{ Complete list of range of reals.

        STRINGREP (line, line_length, line (1, line_length), ')');

        put_command_line (line (1, line_length));

      PROCEND set_real_input;

?? OLDTITLE, EJECT ??

{ Get variable attributes.

      get_variable_attributes [io_mode_attribute].key := fdc$get_io_mode;
      get_variable_attributes [program_data_attribute].key := fdc$get_program_data_type;
      get_variable_attributes [error_processing_attribute].key := fdc$get_variable_error;
      get_variable_attributes [help_attribute].key := fdc$get_variable_help;
      get_variable_attributes [length_attribute].key := fdc$get_variable_length;
      get_variable_attributes [error_display_attribute].key := fdc$get_error_display;
      get_variable_attributes [user_entry_attribute].key := fdc$get_terminal_user_entry;
      get_variable_attributes [comments_attribute].key := fdc$get_number_var_comments;
      fdp$get_variable_attributes (form_identifier, variable_name, get_variable_attributes, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

{ Process VARIABLE_NAME parameter.

      STRINGREP (line, line_length, 'ADD_VARIABLE', ' variable_name=',
            variable_name (1, clp$trimmed_string_size (variable_name)));

{ Process IO_MODE parameter.

      CASE get_variable_attributes [io_mode_attribute].io_mode OF

      = fdc$program_input_output =
        STRINGREP (line, line_length, line (1, line_length), ' io_mode=program');

      = fdc$terminal_input =
        STRINGREP (line, line_length, line (1, line_length), ' io_mode=input');

      = fdc$terminal_output =
        STRINGREP (line, line_length, line (1, line_length), ' io_mode=output');

      ELSE

{ Input/output is the default.  Do not output the default.

      CASEND;

{ Process DATA_TYPE parameter.

      program_data_type := get_variable_attributes [program_data_attribute].program_data_type;

      CASE program_data_type OF

      = fdc$program_character_type =
        STRINGREP (line, line_length, line (1, line_length), ' data_type=character');

      = fdc$program_integer_type =
        STRINGREP (line, line_length, line (1, line_length), ' data_type=integer');

      = fdc$program_real_type =
        STRINGREP (line, line_length, line (1, line_length), ' data_type=real');

      = fdc$program_upper_case_type =
        STRINGREP (line, line_length, line (1, line_length), ' data_type=uppercase');

      = fdc$program_cobol_type =
        STRINGREP (line, line_length, line (1, line_length), ' data_type=cobol');
      ELSE
      CASEND;

{ Process ERROR_PROCESSING parameter.

      CASE get_variable_attributes [error_processing_attribute].variable_error.key OF

      = fdc$get_error_form =
        STRINGREP (line, line_length, line (1, line_length),
              ' error_processing=', get_variable_attributes [error_processing_attribute].variable_error.
              error_form (1, clp$trimmed_string_size (get_variable_attributes [error_processing_attribute].
              variable_error.error_form)));

      = fdc$get_error_message =
        PUSH text_attribute [1].p_error_message: [get_variable_attributes [error_processing_attribute].
              variable_error.error_message_length];
        text_attribute [1].key := fdc$get_var_error_message;
        fdp$get_variable_attributes (form_identifier, variable_name, text_attribute, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

        STRINGREP (line, line_length, line (1, line_length), ' error_processing=''');
        add_text (text_attribute [1].p_error_message^);
        STRINGREP (line, line_length, line (1, line_length), '''');

      = fdc$get_system_default_error =
        STRINGREP (line, line_length, line (1, line_length), ' error_processing=system');

      ELSE {fdc$get_no_error_response}

{ No error processing is the default.  Do not output the default.

      CASEND;

{ Process HELP_PROCESSING parameter.

      CASE get_variable_attributes [help_attribute].variable_help.key OF

      = fdc$get_help_form =
        STRINGREP (line, line_length, line (1, line_length),
              ' help_processing=', get_variable_attributes [help_attribute].
              variable_help.help_form (1, clp$trimmed_string_size
              (get_variable_attributes [help_attribute].variable_help.help_form)));

      = fdc$get_help_message =
        PUSH text_attribute [1].p_help_message: [get_variable_attributes [help_attribute].variable_help.
              help_message_length];
        text_attribute [1].key := fdc$get_var_help_message;
        fdp$get_variable_attributes (form_identifier, variable_name, text_attribute, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

        STRINGREP (line, line_length, line (1, line_length), ' help_processing=''');
        add_text (text_attribute [1].p_help_message^);
        STRINGREP (line, line_length, line (1, line_length), '''');

      = fdc$get_system_default_help =
        STRINGREP (line, line_length, line (1, line_length), ' help_processing=system');

      ELSE {fdc$get_no_help_response}

{ No help processing is the default.  Do  not output the default.

      CASEND;

{ Process LENGTH parameter. For the COBOL data type the PICTURE clause gives
{ length of the program variable.

      IF program_data_type <> fdc$program_cobol_type THEN
        STRINGREP (line, line_length, line (1, line_length),
              ' length=', get_variable_attributes [length_attribute].variable_length);
      IFEND;
{ Process ERROR_DISPLAY parameter.  Remove the defaults, the display
{ attributes of that apply to entire form.

      add_attributes (get_variable_attributes [error_display_attribute].display_attribute -
            object_display_attribute_set, 'error_display');

{ Process USER_ENTRY parameter.

      terminal_user_entry := get_variable_attributes [user_entry_attribute].terminal_user_entry;

{ The default is fdc$entry_optional.  Do not output the default.

      IF fdc$must_enter IN terminal_user_entry THEN
        STRINGREP (line, line_length, line (1, line_length), ' user_entry=must_enter');
      IFEND;

{ Process COMMENT parameter.

      IF get_variable_attributes [comments_attribute].number_var_comments > 0 THEN
        PUSH get_variable_attributes_p: [1 .. get_variable_attributes [comments_attribute].
              number_var_comments];

{ Learn the space needed to obtain the comments.

        FOR number_comments := 1 TO get_variable_attributes [comments_attribute].number_var_comments DO
          get_variable_attributes_p^ [number_comments].key := fdc$get_var_comment_length;
        FOREND;

        fdp$get_variable_attributes (form_identifier, variable_name, get_variable_attributes_p^, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

{ Obtain space for the comments.

        FOR number_comments := 1 TO get_variable_attributes [comments_attribute].number_var_comments DO
          comment_length := get_variable_attributes_p^ [number_comments].var_comment_length;
          get_variable_attributes_p^ [number_comments].key := fdc$get_next_var_comment;
          PUSH get_variable_attributes_p^ [number_comments].p_var_comment: [comment_length];
        FOREND;

        fdp$get_variable_attributes (form_identifier, variable_name, get_variable_attributes_p^, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

{ Start list of comments.

        STRINGREP (line, line_length, line (1, line_length), ' comment=(', '''');
        add_text (get_variable_attributes_p^ [1].p_var_comment^);
        STRINGREP (line, line_length, line (1, line_length), '''');

{ Output list of comments.

        FOR number_comments := 2 TO get_variable_attributes [comments_attribute].number_var_comments DO
          STRINGREP (line, line_length, line (1, line_length), ' ', '''');
          add_text (get_variable_attributes_p^ [number_comments].p_var_comment^);
          STRINGREP (line, line_length, line (1, line_length), '''');
        FOREND;

{ Complete list of comments.

        STRINGREP (line, line_length, line (1, line_length), ')');
      IFEND;

      put_command_line (line (1, line_length));

      set_input;
      set_output;

    PROCEND add_variable;

?? OLDTITLE ??
?? NEWTITLE := 'add_variable_text', EJECT ??

{ PURPOSE:
{   This procedure does the add_variable_text command.

    PROCEDURE add_variable_text
      (    x_position: fdt$x_position,
           y_position: fdt$y_position;
       VAR status: ost$status);

      CONST
        object_definition_attribute = 1,
        object_name_attribute = 2,
        object_display_attribute = 3;

      VAR
        get_object_attributes: array [object_definition_attribute .. object_display_attribute] of
              fdt$get_object_attribute,
        get_object_definition: fdt$get_object_definition,
        get_object_text: array [1 .. 1] of fdt$get_object_attribute;

{ Get attributes.

      status.normal := TRUE;
      get_object_attributes [object_definition_attribute].key := fdc$get_object_definition;
      get_object_attributes [object_name_attribute].key := fdc$get_object_name;
      get_object_attributes [object_display_attribute].key := fdc$get_object_display;
      fdp$get_object_attributes (form_identifier, x_position, y_position, get_object_attributes, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

      get_object_definition := get_object_attributes [object_definition_attribute].get_object_definition;

      STRINGREP (line, line_length, 'ADD_VARIABLE_TEXT', ' column=', x_position, ' line=', y_position);

{ Process TEXT parameter.

      IF get_object_definition.variable_text_length > 0 THEN
        PUSH get_object_text [1].p_text: [get_object_definition.variable_text_length];
        get_object_text [1].key := fdc$get_object_text;
        fdp$get_object_attributes (form_identifier, x_position, y_position, get_object_text, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

        STRINGREP (line, line_length, line (1, line_length), ' text=''');
        add_text (get_object_text [1].p_text^);
        STRINGREP (line, line_length, line (1, line_length), '''');

      ELSE {No text.}
        STRINGREP (line, line_length, line (1, line_length), ' text=''''');
      IFEND;

{ Process NAME and OCCURRENCE parameter.

      IF get_object_attributes [object_name_attribute].get_value_status <> fdc$undefined_value THEN
        STRINGREP (line, line_length, line (1, line_length),
              ' variable_name=', get_object_attributes [object_name_attribute].
              object_name (1, clp$trimmed_string_size (get_object_attributes [object_name_attribute].
              object_name)), ' occurrence=', get_object_attributes [object_name_attribute].occurrence);
      IFEND;

{ Process ATTRIBUTE parameter.  Remove the defaults, the display attributes of
{ the entire form.

      add_attributes (get_object_attributes [object_display_attribute].display_attribute -
            object_display_attribute_set, 'display');

{ Process WIDTH parameter. If the text specifies the length, do not output
{ width.

      IF get_object_definition.variable_text_length > 0 THEN
        IF ((get_object_definition.variable_text_width <> STRLENGTH (get_object_text [1].p_text^)) OR
              (get_object_text [1].p_text^ (STRLENGTH (get_object_text [1].p_text^)) = ' ') OR
              (get_object_text [1].p_text^ = '')) THEN
          STRINGREP (line, line_length, line (1, line_length), ' width=',
                get_object_definition.variable_text_width);
        IFEND;

      ELSE { No text, so use the width.}
        STRINGREP (line, line_length, line (1, line_length), ' width=',
              get_object_definition.variable_text_width);

      IFEND;

      put_command_line (line (1, line_length));

    PROCEND add_variable_text;

?? OLDTITLE ??
?? NEWTITLE := 'add_variable_text_box', EJECT ??

{ PURPOSE:
{   This procedure does the add_variable_text_box command.

    PROCEDURE add_variable_text_box
      (    x_position: fdt$x_position;
           y_position: fdt$y_position;
       VAR status: ost$status);

      CONST
        object_definition_attribute = 1,
        object_name_attribute = 2,
        object_display_attribute = 3;

      VAR
        get_object_attributes: array [object_definition_attribute .. object_display_attribute] of
              fdt$get_object_attribute,
        get_object_definition: fdt$get_object_definition,
        get_object_text: array [1 .. 1] of fdt$get_object_attribute;

      status.normal := TRUE;
      get_object_attributes [object_definition_attribute].key := fdc$get_object_definition;
      get_object_attributes [object_name_attribute].key := fdc$get_object_name;
      get_object_attributes [object_display_attribute].key := fdc$get_object_display;
      fdp$get_object_attributes (form_identifier, x_position, y_position, get_object_attributes, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

      get_object_definition := get_object_attributes [object_definition_attribute].get_object_definition;

      STRINGREP (line, line_length, 'ADD_VARIABLE_TEXT_BOX', ' column=', x_position, ' line=', y_position);

{ Process TEXT parameter.

      IF get_object_definition.variable_box_text_length > 0 THEN
        get_object_text [1].key := fdc$get_object_text;
        PUSH get_object_text [1].p_text: [get_object_definition.variable_box_text_length];
        fdp$get_object_attributes (form_identifier, x_position, y_position, get_object_text, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

        STRINGREP (line, line_length, line (1, line_length), ' text=''');
        add_text (get_object_text [1].p_text^);
        STRINGREP (line, line_length, line (1, line_length), '''');

      ELSE {Object has no text.}
        STRINGREP (line, line_length, line (1, line_length), ' text=''''');
      IFEND;

{ Process HEIGHT and WIDTH parameters.

      STRINGREP (line, line_length, line (1, line_length), ' width=',
            get_object_definition.variable_box_width, ' height=', get_object_definition.variable_box_height);

{ Process NAME and OCCURRENCE parameters.

      IF get_object_attributes [object_name_attribute].get_value_status <> fdc$undefined_value THEN
        STRINGREP (line, line_length, line (1, line_length),
              ' variable_name=', get_object_attributes [object_name_attribute].
              object_name (1, clp$trimmed_string_size (get_object_attributes [object_name_attribute].
              object_name)), ' occurrence=', get_object_attributes [object_name_attribute].occurrence);
      IFEND;

{ Process ATTRIBUTE parameter.  Remove the defaults: the display attributes of
{ the form.

      add_attributes (get_object_attributes [object_display_attribute].display_attribute -
            object_display_attribute_set, 'display');

{ Process TEXT_FORMAT parameter.

      CASE get_object_definition.variable_box_processing OF

      = fdc$center_characters =
        STRINGREP (line, line_length, line (1, line_length), ' text_format=center_characters');

      = fdc$wrap_characters =
        STRINGREP (line, line_length, line (1, line_length), ' text_format=wrap_characters');

      ELSE {fdc$wrap_words}

{ Wrap words is the default.  Do not output the default.

      CASEND;

      put_command_line (line (1, line_length));

    PROCEND add_variable_text_box;

?? OLDTITLE ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   This procedure process conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      CASE condition.selector OF

      = pmc$block_exit_processing =
        fdp$close_form (form_identifier, local_status);
        RETURN;
      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE ??
?? NEWTITLE := 'convert_name', EJECT ??

{ PURPOSE:
{   This procedure converts a name to a name valid for the form processor.

    PROCEDURE convert_name
      (    processor: fdt$form_processor;
       VAR name: ost$name);

       CASE processor OF
         = fdc$ansi_fortran_processor, fdc$cdc_fortran_processor,fdc$extended_fortran_processor =
           fdp$convert_to_fortran_name (processor, name);

         = fdc$cobol_processor =
           fdp$convert_to_cobol_name (name);
       ELSE
{  The existing name is valid. }
       CASEND;
    PROCEND convert_name;

?? OLDTITLE ??
?? NEWTITLE := 'generate_displays', EJECT ??

{ PURPOSE:
{   This procedure generates all the add_display commands.

    PROCEDURE generate_displays;

      VAR
        get_form_attributes: array [1 .. 1] of fdt$get_form_attribute,
        get_form_attributes_p: ^array [1 .. * ] of fdt$get_form_attribute,
        number_object_displays: fdt$number_object_displays;

      get_form_attributes [1].key := fdc$get_number_displays;
      fdp$get_form_attributes (form_identifier, get_form_attributes, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

      IF get_form_attributes [1].number_form_displays = 0 THEN
        RETURN;
      IFEND;

      PUSH get_form_attributes_p: [1 .. get_form_attributes [1].number_form_displays];

      FOR number_object_displays := LOWERBOUND (get_form_attributes_p^) TO
            UPPERBOUND (get_form_attributes_p^) DO
        get_form_attributes_p^ [number_object_displays].key := fdc$get_next_display;
      FOREND;

      fdp$get_form_attributes (form_identifier, get_form_attributes_p^, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

      FOR number_object_displays := LOWERBOUND (get_form_attributes_p^)
            TO UPPERBOUND (get_form_attributes_p^) DO
        add_display (get_form_attributes_p^ [number_object_displays].display_attribute,
              get_form_attributes_p^ [number_object_displays].display_name);
      FOREND;

    PROCEND generate_displays;

?? OLDTITLE ??
?? NEWTITLE := 'generate_events', EJECT ??

{ PURPOSE:
{   This procedure generates all the add_event commands.

    PROCEDURE generate_events;

      VAR
        get_form_attributes: array [1 .. 1] of fdt$get_form_attribute,
        get_form_attributes_p: ^array [1 .. * ] of fdt$get_form_attribute,
        form_names_p: ^fdt$form_names,
        number_events: fdt$number_events;

      get_form_attributes [1].key := fdc$get_number_events;
      fdp$get_form_attributes (form_identifier, get_form_attributes, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF get_form_attributes [1].number_events = 0 THEN
        RETURN;
      IFEND;

      PUSH get_form_attributes_p: [1 .. get_form_attributes [1].number_events];
      FOR number_events := LOWERBOUND (get_form_attributes_p^) TO UPPERBOUND (get_form_attributes_p^) DO
        get_form_attributes_p^ [number_events].key := fdc$get_next_event_v1;
      FOREND;

      fdp$get_form_attributes (form_identifier, get_form_attributes_p^, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

      FOR number_events := LOWERBOUND (get_form_attributes_p^) TO UPPERBOUND (get_form_attributes_p^) DO
        add_event (get_form_attributes_p^ [number_events]);
      FOREND;

    PROCEND generate_events;

?? OLDTITLE ??
?? NEWTITLE := 'generate_form', EJECT ??

{ PURPOSE:
{   This procedure generates the commands for a form.

    PROCEDURE generate_form;

      CONST
        form_name_attribute = 1,
        form_processor_attribute = 2,
        form_area_attribute = 3,
        form_display_attribute = 4,
        event_form_attribute = 5,
        form_help_attribute = 6,
        error_message_form_attribute = 7,
        invalid_data_attribute = 8,
        help_message_form_attribute = 9,
        hidden_editing_attribute = 10,
        comments_attribute = 11;

      VAR
        comment_length: fdt$comment_length,
        get_form_attributes: array [form_name_attribute .. comments_attribute] of fdt$get_form_attribute,
        get_form_attributes_p: ^array [1 .. * ] of fdt$get_form_attribute,
        get_record_attributes: array [1 .. 2] of fdt$get_record_attribute,
        help_message: array [1 .. 1] of fdt$get_form_attribute,
        help_message_length: fdt$help_message_length,
        name: ost$name,
        number_comments: fdt$number_comments;

{ Get form attributes in order to generate commands to define form.

      get_form_attributes [form_name_attribute].key := fdc$get_form_name;
      get_form_attributes [form_processor_attribute].key := fdc$get_form_processor;
      get_form_attributes [form_area_attribute].key := fdc$get_form_area;
      get_form_attributes [form_display_attribute].key := fdc$get_form_display_attribute;
      get_form_attributes [event_form_attribute].key := fdc$get_event_form;
      get_form_attributes [form_help_attribute].key := fdc$get_form_help;
      get_form_attributes [invalid_data_attribute].key := fdc$get_invalid_data_character;
      get_form_attributes [error_message_form_attribute].key := fdc$get_error_message_form;
      get_form_attributes [help_message_form_attribute].key := fdc$get_help_message_form;
      get_form_attributes [hidden_editing_attribute].key := fdc$get_hidden_editing;
      get_form_attributes [comments_attribute].key := fdc$get_number_form_comments;
      fdp$get_form_attributes (form_identifier, get_form_attributes, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

{ Process FORM_NAME parameter.

      name := get_form_attributes [form_name_attribute].form_name;
      STRINGREP (line, line_length, 'CREATE_FORM_MODULE form_name=',
            name (1, clp$trimmed_string_size (name)));
      put_command_line (line (1, line_length));

{ Process PROCESSOR parameter.

      STRINGREP (line, line_length, 'SET_FORM');

      CASE get_form_attributes [form_processor_attribute].form_processor OF

      = fdc$ansi_fortran_processor =
        STRINGREP (line, line_length, line (1, line_length), ' processor=ansi_fortran');

      = fdc$cdc_fortran_processor =
        STRINGREP (line, line_length, line (1, line_length), ' processor=cdc_fortran');

      = fdc$cybil_processor =
        STRINGREP (line, line_length, line (1, line_length), ' processor=cybil');

      = fdc$extended_fortran_processor =
        STRINGREP (line, line_length, line (1, line_length), ' processor=extended_fortran');

      = fdc$pascal_processor =
        STRINGREP (line, line_length, line (1, line_length), ' processor=pascal');

      = fdc$scl_processor =
        STRINGREP (line, line_length, line (1, line_length), ' processor=scl');

      = fdc$unknown_processor =
        STRINGREP (line, line_length, line (1, line_length), ' processor=unknown');

      ELSE {fdc$cobol_processor}

{ COBOL is the default.  Do not output the default.

      CASEND;

{ Process COLUMN, LINE, WIDTH, and HEIGHT parameters.  The default is the area
{ of
{ the terminal screen.  Do not generate a parameter for the default.

      IF get_form_attributes [form_area_attribute].form_area.key = fdc$defined_area THEN
        STRINGREP (line, line_length, line (1, line_length),
              ' column=', get_form_attributes [form_area_attribute].form_area.x_position, ' line= ',
              get_form_attributes [form_area_attribute].form_area.y_position, ' width=',
              get_form_attributes [form_area_attribute].form_area.width, ' height=',
              get_form_attributes [form_area_attribute].form_area.height);
      IFEND;

{ Process ATTRIBUTE parameter.

      form_display_attribute_set := get_form_attributes [form_display_attribute].form_display_attribute;
      display_attribute_set := form_display_attribute_set - $fdt$display_attribute_set
            [fdc$protect, fdc$fine_border, fdc$medium_border, fdc$bold_border];
      object_display_attribute_set := form_display_attribute_set - $fdt$display_attribute_set
            [fdc$fine_border, fdc$medium_border, fdc$bold_border];
      add_attributes (form_display_attribute_set - $fdt$display_attribute_set
            [fdc$protect, fdc$black_background, fdc$white_foreground, fdc$display_left_to_right],
            'display');

{ Process EVENT_FORM parameter.

      CASE get_form_attributes [event_form_attribute].event_form_definition.key OF

      = fdc$no_event_form =
        STRINGREP (line, line_length, line (1, line_length), ' event_form=none');

      = fdc$user_event_form =
        STRINGREP (line, line_length, line (1, line_length),
              ' event_form=', get_form_attributes [event_form_attribute].event_form_definition.
              event_form_name (1, clp$trimmed_string_size (get_form_attributes [event_form_attribute].
              event_form_definition.event_form_name)));

      ELSE {fdc$system_default_event_form}

{ System is the default. Do not output the default.

      CASEND;

{ Process HELP_PROCESSING parameter.

      CASE get_form_attributes [form_help_attribute].form_help.key OF

      = fdc$get_help_form =
        STRINGREP (line, line_length, line (1, line_length),
              ' help_processing=', get_form_attributes [form_help_attribute].
              form_help.help_form (1, clp$trimmed_string_size (get_form_attributes [form_help_attribute].
              form_help.help_form)));

      = fdc$get_system_default_help =
        STRINGREP (line, line_length, line (1, line_length), ' help_processing=system');

      = fdc$get_help_message =
        help_message_length := get_form_attributes [form_help_attribute].form_help.help_message_length;
        help_message [1].key := fdc$get_form_help_message;
        PUSH help_message [1].p_form_help_message: [help_message_length];
        fdp$get_form_attributes (form_identifier, help_message, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

        STRINGREP (line, line_length, line (1, line_length), ' help_processing=''');
        add_text (help_message [1].p_form_help_message^);
        STRINGREP (line, line_length, line (1, line_length), '''');

      ELSE {fdc$get_no_help_response}

{ No help is the default. Do not output the default.

      CASEND;

{ Process ERROR_MESSAGE_FORM parameter.

      IF get_form_attributes [error_message_form_attribute].error_message_form <> osc$null_name THEN
        STRINGREP (line, line_length, line (1, line_length),
              ' error_message_form=', get_form_attributes [error_message_form_attribute].
              error_message_form (1, clp$trimmed_string_size
              (get_form_attributes [error_message_form_attribute].error_message_form)));
      IFEND;


{ Process HELP_MESSAGE_FORM parameter.

      IF get_form_attributes [help_message_form_attribute].help_message_form <> osc$null_name THEN
        STRINGREP (line, line_length, line (1, line_length),
             ' help_message_form=', get_form_attributes [help_message_form_attribute].
              help_message_form (1, clp$trimmed_string_size
              (get_form_attributes [help_message_form_attribute].help_message_form)));
      IFEND;

{ Process VARIABLE_DECK_NAME parameter.

      get_record_attributes [1].key := fdc$get_record_deck_name;
      get_record_attributes [2].key := fdc$get_record_name;
      fdp$get_record_attributes (form_identifier, get_record_attributes, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

      IF get_record_attributes [1].get_value_status <> fdc$undefined_value THEN
        STRINGREP (line, line_length, line (1, line_length),
              ' variable_deck_name=', get_record_attributes [1].
              record_deck_name (1, clp$trimmed_string_size (get_record_attributes
              [1].record_deck_name)));
      IFEND;

      IF get_record_attributes [2].get_value_status <> fdc$undefined_value THEN
        IF get_record_attributes [1].get_value_status <> fdc$undefined_value THEN
          IF get_record_attributes [2].record_name <> get_record_attributes [1].record_deck_name THEN
            convert_name (get_form_attributes [form_processor_attribute].form_processor,
                  get_record_attributes [2].record_name);
            STRINGREP (line, line_length, line (1, line_length),
                  ' variable_record_name=', get_record_attributes [2].
                  record_name (1, clp$trimmed_string_size (get_record_attributes [2].record_name)));
          IFEND;
        ELSE

{ The deck name is not defined. If the record name equals the form name, the record name
{ uses the default.  Do not output the default for the record name.

          IF (name <> get_record_attributes [2].record_name) THEN

{ Convert the record name to a name valid for the form processor.  Old versions of forms
{ allowed a record name that was not valid for the processor.

            convert_name (get_form_attributes [form_processor_attribute].form_processor,
                  get_record_attributes [2].record_name);
            STRINGREP (line, line_length, line (1, line_length),
                  ' variable_record_name=', get_record_attributes [2].
                  record_name (1, clp$trimmed_string_size (get_record_attributes [2].record_name)));
          IFEND;
        IFEND;
      IFEND;

{ Process INVALID_DATA_CHARACTER parameter.

      IF get_form_attributes[invalid_data_attribute].
                           invalid_data_character.defined THEN
        STRINGREP(line,line_length,line(1,line_length),
                  ' invalid_data_character=''',
                  get_form_attributes[invalid_data_attribute].
                  invalid_data_character.character, '''');
      IFEND;

{ Process HIDDEN_EDITING parameter.

      IF get_form_attributes [hidden_editing_attribute].hidden_editing THEN
        STRINGREP (line, line_length, line (1, line_length), ' hidden_editing=TRUE');
      IFEND;

{  Process COMMENT parameter.

      IF get_form_attributes [comments_attribute].number_form_comments > 0 THEN
        PUSH get_form_attributes_p: [1 .. get_form_attributes [comments_attribute].number_form_comments];

{ Learn the space needed to obtain the comments.

        FOR number_comments := 1 TO get_form_attributes [comments_attribute].number_form_comments DO
          get_form_attributes_p^ [number_comments].key := fdc$get_form_comment_length;
        FOREND;

        fdp$get_form_attributes (form_identifier, get_form_attributes_p^, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

{ Obtain space for the comments.

        FOR number_comments := 1 TO get_form_attributes [comments_attribute].number_form_comments DO
          comment_length := get_form_attributes_p^ [number_comments].form_comment_length;
          get_form_attributes_p^ [number_comments].key := fdc$get_next_form_comment;
          PUSH get_form_attributes_p^ [number_comments].p_form_comment: [comment_length];
        FOREND;

        fdp$get_form_attributes (form_identifier, get_form_attributes_p^, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

{ Start list of comments.

        STRINGREP (line, line_length, line (1, line_length), ' comment=(', '''');
        add_text (get_form_attributes_p^ [1].p_form_comment^);
        STRINGREP (line, line_length, line (1, line_length), '''');

{ Output list of comments.

        FOR number_comments := 2 TO get_form_attributes [comments_attribute].number_form_comments DO
          STRINGREP (line, line_length, line (1, line_length), ' ', '''');
          add_text (get_form_attributes_p^ [number_comments].p_form_comment^);
          STRINGREP (line, line_length, line (1, line_length), '''');
        FOREND;

{ Complete list of comments.

        STRINGREP (line, line_length, line (1, line_length), ')');
      IFEND;

      put_command_line (line (1, line_length));

    PROCEND generate_form;

?? OLDTITLE ??
?? NEWTITLE := 'generate_objects', EJECT ??

{ PURPOSE:
{   This procedure generates commands for all the objects on the form.

    PROCEDURE generate_objects;

      VAR
        get_form_attributes: array [1 .. 1] of fdt$get_form_attribute,
        form_objects_p: ^fdt$form_objects,
        number_objects: fdt$number_objects,
        x_position: fdt$x_position,
        y_position: fdt$y_position;

{ Get number of objects on form to learn the space required to obtain the
{ objects.

      get_form_attributes [1].key := fdc$get_number_objects;
      fdp$get_form_attributes (form_identifier, get_form_attributes, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

      IF get_form_attributes [1].number_objects = 0 THEN
        RETURN;
      IFEND;

{ Get all the objects on the form.

      PUSH form_objects_p: [1 .. get_form_attributes [1].number_objects];
      fdp$get_form_objects (form_identifier, form_objects_p^, number_objects, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

{ Generate commands to add objects.

      FOR number_objects := LOWERBOUND (form_objects_p^) TO UPPERBOUND (form_objects_p^) DO
        x_position := form_objects_p^ [number_objects].x_position;
        y_position := form_objects_p^ [number_objects].y_position;

        CASE form_objects_p^ [number_objects].object OF

        = fdc$constant_text =
          add_constant_text (x_position, y_position, status);

        = fdc$constant_text_box =
          add_constant_text_box (x_position, y_position, status);

        = fdc$variable_text =
          add_variable_text (x_position, y_position, status);

        = fdc$variable_text_box =
          add_variable_text_box (x_position, y_position, status);

        = fdc$box =
          add_box (x_position, y_position, status);

        = fdc$line =
          add_line (x_position, y_position, status);

        ELSE {Ignore object.}
        CASEND;
      FOREND;

    PROCEND generate_objects;

?? OLDTITLE ??
?? NEWTITLE := 'generate_tables', EJECT ??

{ PURPOSE:
{   This procedure generates the add_table commands.

    PROCEDURE generate_tables;

      VAR
        get_form_attributes: array [1 .. 1] of fdt$get_form_attribute,
        form_names_p: ^fdt$form_names,
        number_names: fdt$number_names;

{ Get number of tables in form in order to learn the space required
{ to get the table names.

      get_form_attributes [1].key := fdc$get_number_tables;
      fdp$get_form_attributes (form_identifier, get_form_attributes, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

      IF get_form_attributes [1].number_tables = 0 THEN
        RETURN;
      IFEND;

{ Get the names of the tables on the form.

      PUSH form_names_p: [1 .. get_form_attributes [1].number_tables];
      fdp$get_form_names (form_identifier, $fdt$name_selections [fdc$select_table], form_names_p^,
            number_names, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

{ Generate the commands to add tables.

      FOR number_names := LOWERBOUND (form_names_p^) TO UPPERBOUND (form_names_p^) DO
        add_table (form_names_p^ [number_names].name);
      FOREND;

    PROCEND generate_tables;

?? OLDTITLE ??
?? NEWTITLE := 'generate_variables', EJECT ??

{ PURPOSE:
{   This procedure generates the add_variable commands.

    PROCEDURE generate_variables;

      VAR
        get_form_attributes: array [1 .. 1] of fdt$get_form_attribute,
        form_names_p: ^fdt$form_names,
        number_names: fdt$number_names;

{ Get number of variables in form in order to learn the space required
{ to get the variable names.

      get_form_attributes [1].key := fdc$get_number_variables;
      fdp$get_form_attributes (form_identifier, get_form_attributes, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

      IF get_form_attributes [1].number_variables = 0 THEN
        RETURN;
      IFEND;

{ Get the names of the variables on the form.

      PUSH form_names_p: [1 .. get_form_attributes [1].number_variables];
      fdp$get_form_names (form_identifier, $fdt$name_selections [fdc$select_variable], form_names_p^,
            number_names, status);
      IF NOT status.normal THEN
        EXIT fdp$generate_form_module;
      IFEND;

{ Generate the commands to add variables.

      FOR number_names := LOWERBOUND (form_names_p^) TO UPPERBOUND (form_names_p^) DO
        add_variable (form_names_p^ [number_names].name);
      FOREND;

    PROCEND generate_variables;

?? OLDTITLE ??
?? NEWTITLE := 'put_command_line', EJECT ??

{ PURPOSE:
{   This procedure write the command line or lines.

    PROCEDURE put_command_line
      (    line: string ( * ));

      CONST

{ The following constant adds space on the print line for continuation characters
{ ('..) - 3 characters, and quote mark inbedded in string ('') - 2 characters.

        added_text_length = 5,
        continuation = 6,
        indentation = 2;

      VAR
        command: string (max_command_line_size),
        command_size: integer,
        command_length: integer,
        command_line: string (max_command_line_size),
        indentation_string: string (10),
        terminate_string: string (2);

?? NEWTITLE := 'put_chunks', EJECT ??

{ PURPOSE:
{   This procedure process a command that requires more than one line.

      PROCEDURE put_chunks
        (    line: string ( * );
             length: 1 .. max_command_line_size;
             width: amt$page_width);

        VAR
          break_found: boolean,
          break_position: 0 .. max_command_line_size,
          concatenating_string: boolean,
          current_character_position: 0 .. max_command_line_size,
          current_length: 0 .. max_command_line_size,
          first_line: boolean,
          processing_string: boolean,
          remaining_text: 0 .. max_command_line_size,
          starting_position: 1 .. max_command_line_size;

        current_character_position := 0;
        processing_string := FALSE;
        break_position := 0;
        remaining_text := length;
        first_line := TRUE;
        starting_position := 1;
        concatenating_string := FALSE;

{ Do first/next line.

        WHILE remaining_text > 0 DO
          break_found := FALSE;
          IF remaining_text <= width THEN
            IF concatenating_string THEN
              STRINGREP (command_line, command_length, '//''', line (starting_position, remaining_text));
            ELSE
              STRINGREP (command_line, command_length, indentation_string (1, indentation + continuation),
                    line (starting_position, remaining_text));
            IFEND;
            put_line (command_line (1, command_length));
            RETURN;
          IFEND;

{ Find a good place to break line.

        /find_line_break/
          REPEAT
            current_character_position := current_character_position + 1;

{ Do not break a line inside a string if possible.

            IF line (current_character_position) = '''' THEN
              IF NOT processing_string THEN
                processing_string := TRUE;
                CYCLE /find_line_break/;
              IFEND;

{ Processing a string. Check for double quotes.

              IF ((current_character_position < length) AND (line (current_character_position + 1) = ''''))
                    THEN
                current_character_position := current_character_position + 1;
                CYCLE /find_line_break/;
              IFEND;

{ End of string found.

              processing_string := FALSE;
              CYCLE /find_line_break/;
            IFEND;

            IF ((NOT processing_string) AND (line (current_character_position) = ' ')) THEN
              break_found := TRUE;
              break_position := current_character_position;
            IFEND;
          UNTIL ((line (current_character_position) <> '''') AND
                (current_character_position - starting_position >= width));

{ Output line.

          IF break_found THEN
            IF NOT first_line AND (NOT concatenating_string) THEN
              WHILE line (starting_position) = ' ' DO
                starting_position := starting_position + 1;
              WHILEND;
            IFEND;

            current_length := break_position - starting_position;
            IF first_line THEN
              first_line := FALSE;
              STRINGREP (command_line, command_length, indentation_string (1, indentation),
                    line (starting_position, current_length), terminate_string);

            ELSE { This is not first line. }
              IF concatenating_string THEN
                STRINGREP (command_line, command_length, '//''', line (starting_position, current_length),
                      terminate_string);
              ELSE
                STRINGREP (command_line, command_length, indentation_string (1, indentation + continuation),
                      line (starting_position, current_length), terminate_string);
              IFEND;
            IFEND;

            put_line (command_line (1, command_length));
            starting_position := break_position;
            current_character_position := break_position;
            processing_string := FALSE;
            concatenating_string := FALSE;
            remaining_text := length - starting_position + 1;

          ELSE

{ A breaking point was not found. Concatenate string to next line.

            current_length := current_character_position - starting_position + 1;
            IF concatenating_string THEN
              STRINGREP (command_line, command_length, '//''', line (starting_position, current_length), '''',
                    terminate_string);
            ELSE
              concatenating_string := TRUE;
              IF first_line THEN
                first_line := FALSE;
                STRINGREP (command_line, command_length, indentation_string (1, indentation),
                      line (starting_position, current_length), '''', terminate_string);
              ELSE { This is not first line. }
                STRINGREP (command_line, command_length, indentation_string (1, indentation + continuation),
                      line (starting_position, current_length), '''', terminate_string);
                first_line := FALSE;
              IFEND;
            IFEND;

            put_line (command_line (1, command_length));
            starting_position := current_character_position + 1;
            remaining_text := length - starting_position + 1;
          IFEND;
        WHILEND;

      PROCEND put_chunks;

?? OLDTITLE ??
?? NEWTITLE := 'put_line', EJECT ??

      PROCEDURE [INLINE] put_line
        (    line: string ( * ));

        VAR
          file_byte_address: amt$file_byte_address;

        amp$put_next (file_identifier, ^line, clp$trimmed_string_size (line), file_byte_address, status);
        IF NOT status.normal THEN
          EXIT fdp$generate_form_module;
        IFEND;

      PROCEND put_line;

?? OLDTITLE, EJECT ??

      terminate_string := '..';
      indentation_string := ' ';
      command_size := STRLENGTH (line);

      IF command_size <= (page_width - indentation) THEN
        STRINGREP (command_line, command_length, indentation_string (1, indentation), line (1, command_size));
        put_line (command_line (1, command_length));
        RETURN;
      IFEND;

{ The command is longer than the page width of the file.  Break command into
{ chunks and output to line.

      put_chunks (line, command_size, (page_width - (indentation + continuation + added_text_length)));

    PROCEND put_command_line;

?? OLDTITLE, EJECT ??

    file_attributes [1].key := amc$page_width;
    amp$fetch (file_identifier, file_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF file_attributes [1].page_width < min_page_width THEN
      page_width := min_page_width;
    ELSEIF file_attributes [1].page_width > clc$wide_page_width THEN
      page_width := clc$wide_page_width;
    ELSE
      page_width := file_attributes [1].page_width;
    IFEND;

    fdp$open_form_module (form_module_p, form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^condition_handler, TRUE);

{ Generate SCL commands for form.

    generate_form;
    generate_displays;
    generate_events;
    generate_tables;
    generate_variables;
    generate_objects;

    STRINGREP (line, line_length, 'END_FORM_MODULE');
    put_command_line (line (1, line_length));

  PROCEND fdp$generate_form_module;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] fdp$generate_form_variable', EJECT ??
*copy fdh$generate_form_variable

  PROCEDURE [XDCL] fdp$generate_form_variable
    (    file_identifier: amt$file_identifier;
         form_name: ost$name;
     VAR form_module_p: ^fdt$form_module;
     VAR status: ost$status);

    VAR
      get_form_attributes: array [1 .. 1] of fdt$get_form_attribute,
      local_status: ost$status;

    fdp$open_form_module (form_module_p, form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_form_attributes [1].key := fdc$get_form_processor;
    fdp$get_form_attributes (form_identifier, get_form_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$write_record_definition (form_identifier, file_identifier, get_form_attributes [1].form_processor,
          status);
    IF ((NOT status.normal) AND (status.condition = fde$form_has_no_variables)) THEN
      osp$generate_error_message (status, local_status);
      status.normal := TRUE;
    IFEND;

  PROCEND fdp$generate_form_variable;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] fdp$open_form_module', EJECT ??
*copy fdh$open_form_module

  PROCEDURE [XDCL] fdp$open_form_module
    (VAR form_module_p: ^fdt$form_module;
     VAR form_identifier: fdt$form_identifier;
     VAR status: ost$status);

    VAR
      form_definition_p: ^fdt$form_definition,
      form_status_p: ^fdt$form_status,
      screen_formatting_version: integer;

?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    RESET form_module_p;
    i#move (^form_module_p^, ^screen_formatting_version, fdc$integer_length);
    IF (screen_formatting_version < fdc$basic_capability) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_requires_conversion, '', status);
      RETURN;
    IFEND;

    fdp$create_form_status (form_identifier, form_status_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Create pointers to frequently used data to obtain efficient  access during
{ form interaction with the terminal user.

    form_status_p^.p_form_module := form_module_p;
    NEXT form_definition_p IN form_module_p;
    form_status_p^.p_form_definition := form_definition_p;
    form_status_p^.p_form_variable_definitions := fdp$ptr_variables (form_status_p);
    form_status_p^.p_form_object_definitions := fdp$ptr_objects (form_status_p);
    form_status_p^.p_form_table_definitions := fdp$ptr_tables (form_status_p);
    form_status_p^.p_form_record_definitions := fdp$ptr_record_definitions (form_status_p);
    form_status_p^.p_event_definitions := fdp$ptr_events (form_status_p);
    form_status_p^.p_display_definitions := fdp$ptr_displays (form_status_p);
    form_status_p^.opened := TRUE;
    form_status_p^.opened_for_query_only := TRUE;

  PROCEND fdp$open_form_module;

MODEND fdm$generate_form_module;

*DECK DECK=FDM$GLOBAL_DATA EXPAND=TRUE

?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Screen Formatting:  Global Data' ??

MODULE fdm$global_data;

{ PURPOSE:
{   This module contains data commonly used by other Screen Formatting modules.
{ DESIGN:


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fdc$message_variable_name
*copyc fdt$event_trigger
*copyc fdt$display_attribute_set
*copyc fdt$screen_status
*copyc ost$name
?? POP ??

  VAR
    fdv$application_event_table: [XDCL, READ, STATIC] array [csc$f1 .. csc$sf16] of
          fdt$event_trigger := [fdc$function_1, fdc$shift_function_1, fdc$function_2, fdc$shift_function_2,
          fdc$function_3, fdc$shift_function_3, fdc$function_4, fdc$shift_function_4, fdc$function_5,
          fdc$shift_function_5, fdc$function_6, fdc$shift_function_6, fdc$function_7, fdc$shift_function_7,
          fdc$function_8, fdc$shift_function_8, fdc$function_9, fdc$shift_function_9, fdc$function_10,
          fdc$shift_function_10, fdc$function_11, fdc$shift_function_11, fdc$function_12,
          fdc$shift_function_12, fdc$function_13, fdc$shift_function_13, fdc$function_14,
          fdc$shift_function_14, fdc$function_15, fdc$shift_function_15, fdc$function_16,
          fdc$shift_function_16],
    fdv$background_colors: [XDCL, READ, STATIC] fdt$display_attribute_set :=
          [fdc$black_background, fdc$blue_background, fdc$green_background, fdc$magenta_background,
          fdc$red_background, fdc$cyan_background, fdc$yellow_background, fdc$white_background],
    fdv$colors: [XDCL, READ, STATIC] fdt$display_attribute_set :=
          [fdc$black_background, fdc$blue_background, fdc$green_background, fdc$magenta_background,
          fdc$red_background, fdc$cyan_background, fdc$yellow_background, fdc$white_background,
          fdc$black_foreground, fdc$blue_foreground, fdc$green_foreground, fdc$magenta_foreground,
          fdc$red_foreground, fdc$cyan_foreground, fdc$yellow_foreground, fdc$white_foreground],
    fdv$foreground_colors: [XDCL, READ, STATIC] fdt$display_attribute_set :=
          [fdc$black_foreground, fdc$blue_foreground, fdc$green_foreground, fdc$magenta_foreground,
          fdc$red_foreground, fdc$cyan_foreground, fdc$yellow_foreground, fdc$white_foreground],
    fdv$line_attributes: [XDCL, READ, STATIC] fdt$display_attribute_set :=
          [fdc$fine_line, fdc$medium_line, fdc$bold_line],
    fdv$line_widths: [XDCL, READ, STATIC] fdt$display_attribute_set :=
          [fdc$fine_line, fdc$medium_line, fdc$bold_line, fdc$fine_border, fdc$medium_border,
          fdc$bold_border],
    fdv$logical_display_attributes: [XDCL, READ, STATIC] fdt$display_attribute_set :=
          [fdc$italic_display_attribute, fdc$title_display_attribute, fdc$input_display_attribute,
          fdc$error_display_attribute, fdc$message_display_attribute],
    fdv$message_variable_name: [XDCL, READ, STATIC] ost$name := fdc$message_variable_name,
    fdv$object_display_directions: [XDCL, READ, STATIC] fdt$display_attribute_set :=
          [fdc$display_left_to_right, fdc$display_right_to_left],
    fdv$to_cobol: [XDCL, READ, STATIC] string (256) := '???????????????????????????????' CAT
            '? ????????????-??0123456789???????ABCDEFGHIJKLMNOPQRSTUVWXYZ????-?abcdefghijklmnopqrstuvwxyz' CAT
            '????????????????????????????????????????????????????????????????????????????????????' CAT
            '?????????????????????????????????????????????????',
    fdv$to_cybil: [XDCL, READ, STATIC] string (256) := '????????????????????????????????' CAT
            ' !"#$%&''()*+,_./0123456789:;<=>?@abcdefghijklmnopqrstuvwxyz[\]^_`abcdefghijklmnopqrstuvwxyz' CAT
            '????????????????????????????????????????????????????????????????????????????????????' CAT
            '?????????????????????????????????????????????????',
    fdv$to_fortran: [XDCL, READ, STATIC] string (256) := '???????????????????????????????' CAT
            ' ????????????????0123456789???????ABCDEFGHIJKLMNOPQRSTUVWXYZ??????abcdefghijklmnopqrstuvwxyz' CAT
            '????????????????????????????????????????????????????????????????????????????????????' CAT
            '?????????????????????????????????????????????????',
    fdv$to_extended_fortran: [XDCL, READ, STATIC] string (256) := '???????????????????????????????' CAT
            ' ????$????????_??0123456789???????ABCDEFGHIJKLMNOPQRSTUVWXYZ????_?abcdefghijklmnopqrstuvwxyz' CAT
            '????????????????????????????????????????????????????????????????????????????????????' CAT
            '?????????????????????????????????????????????????',
    fdv$to_scl: [XDCL, READ, STATIC] string (256) := '???????????????????????????????' CAT
          '? ????????????_??0123456789???????ABCDEFGHIJKLMNOPQRSTUVWXYZ' CAT
          '????-?abcdefghijklmnopqrstuvwxyz' CAT
          '??????????????????????????????????????????????????????????' CAT
          '??????????????????????????' CAT
          '?????????????????????????????????????????????????',
    fdv$screen_status: [XDCL] fdt$screen_status := [TRUE, 0, 0, 1, 1, FALSE, FALSE, 1, 1, ' ',
          [csc$timeout_event], ' ', FALSE, [1, 1, 1, 1, 1, fdc$form_event], FALSE, 1, FALSE, 1, 0, 0, NIL,
          NIL, NIL, 0, [1, [[1, 1], [1, 1], [1, 1], [1, 1]]], FALSE];
MODEND fdm$global_data;
*DECK DECK=FDM$MANAGE_FORMS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'Manage Forms' ??
MODULE fdm$manage_forms;
?? NEWTITLE := '  Type and procedure declarations' ??

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc fdc$maximum_x_position
*copyc fde$condition_identifiers
*copyc fdt$form_identifier
*copyc fdt$form_names
*copyc fdt$number_names
*copyc fdt$screen_variable_length
*copyc fdt$table_index
*copyc fdt$table_variable_index
*copyc fdt$variable_index
*copyc ost$name
*copyc ost$stack_frame_save_area
*copyc ost$status
?? POP ??

*copyc fdv$to_cobol
*copyc fdv$to_scl

*copyc clp$begin_utility
*copyc clp$create_procedure_variable
*copyc clp$delete_variable
*copyc clp$derive_type_spec_from_value
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc clp$make_boolean_value
*copyc clp$make_integer_value
*copyc clp$make_keyword_value
*copyc clp$make_name_value
*copyc clp$get_variable
*copyc clp$trimmed_string_size
*copyc clp$change_variable
*copyc fdp$add_form
*copyc fdp$change_table_size
*copyc fdp$close_form
*copyc fdp$combine_form
*copyc fdp$delete_form
*copyc fdp$get_form_attributes
*copyc fdp$get_form_names
*copyc fdp$get_integer_variable
*copyc fdp$get_next_event
*copyc fdp$get_next_changed_variable
*copyc fdp$get_next_input_error
*copyc fdp$get_next_output_error
*copyc fdp$get_number_of_occurrences
*copyc fdp$get_real_variable
*copyc fdp$get_screen_variable
*copyc fdp$get_string_variable
*copyc fdp$get_table_attributes
*copyc fdp$get_variable_attributes
*copyc fdp$open_form
*copyc fdp$pop_forms
*copyc fdp$position_form
*copyc fdp$push_forms
*copyc fdp$read_forms
*copyc fdp$replace_integer_variable
*copyc fdp$replace_real_variable
*copyc fdp$replace_string_variable
*copyc fdp$reset_form
*copyc fdp$reset_object_attribute
*copyc fdp$set_cursor_position
*copyc fdp$set_object_attribute
*copyc fdp$show_forms
*copyc fdp$tab_to_next_field
*copyc i#current_sequence_position
*copyc mlp$input_floating_number
*copyc mmp$create_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??


  CONST
    fdc$real_number_of_digits = 14;

  TYPE
    fdt$event = record
      event_name: ost$name,
      normal: boolean,
      position: fdt$event_position,
    recend,

    fdt$form_information = record
      added: boolean,
      form_identifier: fdt$form_identifier,
      form_processor: fdt$form_processor,
      form_variable_created: boolean,
      name: ost$name,
      number_of_fields: integer,
      p_tables: ^array [1 .. * ] of fdt$table_information,
      p_variables: ^array [1 .. * ] of fdt$variable_information,
      push_index: 0 .. fdc$maximum_form_identifier,
    recend,

    fdt$scl_variable_reference = string (128),

    fdt$table_information = record
      name: ost$name,
      occurrence: fdt$occurrence,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable_information,
    recend,

    fdt$table_variable_information = record
      p_variable_information: ^fdt$variable_information,
    recend,

    fdt$variable_information = record
      created: boolean,
      name: ost$name,
      occurrence: fdt$occurrence,
      program_data_type: fdt$program_data_type,
      table_member: boolean,
      variable_length: fdt$variable_length,
    recend,

    fdt$variable_creation = (fdc$form_variable, fdc$single, fdc$none),
    fdt$variable_evaluation = (fdc$automatic, fdc$manual);

  VAR
    fdv$event: fdt$event,
    fdv$form_index: fdt$form_identifier,
    fdv$p_form_list: ^array [1 .. * ] of fdt$form_information := NIL,
    fdv$high_form_index: 0 .. fdc$maximum_form_identifier := 0,
    fdv$push_index: 0 .. fdc$maximum_form_identifier := 0,
    fdv$real_type_qualifier: [READ, STATIC] clt$real_type_qualifier :=
          [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
          [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]],
    fdv$utility_name: [STATIC] ost$name := 'MANAGE_FORM',
    fdv$variable_creation: fdt$variable_creation,
    fdv$variable_evaluation: fdt$variable_evaluation,
    fdv$work_area: amt$segment_pointer;

?? TITLE := '  Task command and function lists', EJECT ??

  SECTION
    fds$sub_commands_and_functions: READ;

  {Read-only sub-command and function list for SCL}

{ table fdv$sub_commands t=c sn=fds$sub_commands_and_functions s=local
{ command (add_form                       ,addf) fdp$_add_form cm=local
{ command (change_table_size              ,chats) fdp$_change_table_size ..
{   cm=local
{ command (close_form                     ,clof) fdp$_close_form cm=local
{ command (combine_form, combine_forms    ,comf) fdp$_combine_form cm=local
{ command (create_form_module             ,crefm) fdp$_create_form_module   ..
{                   cm=xref
{ command (delete_form                    ,delf) fdp$_delete_form cm=local
{ command (get_form_variable, get_form_variables, getfv) ..
{   fdp$_get_form_variable cm =   local
{ command (get_next_changed_variable      ,getncv) ..
{   fdp$_get_next_changed_variable cm=local a=hidden
{ command (get_next_input_error           ,getnie) ..
{   fdp$_get_next_input_error cm=local a=hidden
{ command (get_next_output_error          ,getnoe) ..
{   fdp$_get_next_output_error cm=local a=hidden
{ command (open_form                      ,opef) fdp$_open_form cm=local
{ command (pop_form, pop_forms            ,popf) fdp$_pop_forms cm=local
{ command (position_form                  ,posf) fdp$_position_form cm=local
{ command (push_form, push_forms          ,pusf) fdp$_push_forms cm=local
{ command (quit                           ,qui) fdp$_quit cm=local
{ command (read_form, read_forms          ,reaf) fdp$_read_forms cm=local
{ command (replace_form_variable, replace_form_variables, repfv) ..
{   fdp$_replace_form_variable     cm=local
{ command (reset_form                     ,resf) fdp$_reset_form cm=local
{ command (set_cursor_position            ,setcp) fdp$_set_cursor_position  ..
{   cm=local
{ command (set_object_attribute, set_object_attributes         ,setoa) ..
{   fdp$_set_object_attribute cm=local
{ command (show_form, show_forms          ,shof) fdp$_show_forms cm=local
{ command (tab_to_next_field              ,tabtnf) fdp$_tab_to_next_field ..
{   cm=local a=hidden
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  fdv$sub_commands: [STATIC, READ, fds$sub_commands_and_functions]
      ^clt$command_table := ^fdv$sub_commands_entries,

  fdv$sub_commands_entries: [STATIC, READ,
      fds$sub_commands_and_functions] array [1 .. 52] of
      clt$command_table_entry := [
  {} ['ADDF                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^fdp$_add_form],
  {} ['ADD_FORM                       ', clc$nominal_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^fdp$_add_form],
  {} ['CHANGE_TABLE_SIZE              ', clc$nominal_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^fdp$_change_table_size],
  {} ['CHATS                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^fdp$_change_table_size],
  {} ['CLOF                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^fdp$_close_form],
  {} ['CLOSE_FORM                     ', clc$nominal_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^fdp$_close_form],
  {} ['COMBINE_FORM                   ', clc$nominal_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^fdp$_combine_form],
  {} ['COMBINE_FORMS                  ', clc$alias_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^fdp$_combine_form],
  {} ['COMF                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^fdp$_combine_form],
  {} ['CREATE_FORM_MODULE             ', clc$nominal_entry,
        clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
        ^fdp$_create_form_module],
  {} ['CREFM                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
        ^fdp$_create_form_module],
  {} ['DELETE_FORM                    ', clc$nominal_entry,
        clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
        ^fdp$_delete_form],
  {} ['DELF                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
        ^fdp$_delete_form],
  {} ['GETFV                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
        ^fdp$_get_form_variable],
  {} ['GETNCV                         ', clc$abbreviation_entry,
        clc$hidden_entry, 8, clc$automatically_log, clc$linked_call,
        ^fdp$_get_next_changed_variable],
  {} ['GETNIE                         ', clc$abbreviation_entry,
        clc$hidden_entry, 9, clc$automatically_log, clc$linked_call,
        ^fdp$_get_next_input_error],
  {} ['GETNOE                         ', clc$abbreviation_entry,
        clc$hidden_entry, 10, clc$automatically_log, clc$linked_call,
        ^fdp$_get_next_output_error],
  {} ['GET_FORM_VARIABLE              ', clc$nominal_entry,
        clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
        ^fdp$_get_form_variable],
  {} ['GET_FORM_VARIABLES             ', clc$alias_entry,
        clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
        ^fdp$_get_form_variable],
  {} ['GET_NEXT_CHANGED_VARIABLE      ', clc$nominal_entry,
        clc$hidden_entry, 8, clc$automatically_log, clc$linked_call,
        ^fdp$_get_next_changed_variable],
  {} ['GET_NEXT_INPUT_ERROR           ', clc$nominal_entry,
        clc$hidden_entry, 9, clc$automatically_log, clc$linked_call,
        ^fdp$_get_next_input_error],
  {} ['GET_NEXT_OUTPUT_ERROR          ', clc$nominal_entry,
        clc$hidden_entry, 10, clc$automatically_log, clc$linked_call,
        ^fdp$_get_next_output_error],
  {} ['OPEF                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 11, clc$automatically_log, clc$linked_call,
        ^fdp$_open_form],
  {} ['OPEN_FORM                      ', clc$nominal_entry,
        clc$normal_usage_entry, 11, clc$automatically_log, clc$linked_call,
        ^fdp$_open_form],
  {} ['POPF                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 12, clc$automatically_log, clc$linked_call,
        ^fdp$_pop_forms],
  {} ['POP_FORM                       ', clc$nominal_entry,
        clc$normal_usage_entry, 12, clc$automatically_log, clc$linked_call,
        ^fdp$_pop_forms],
  {} ['POP_FORMS                      ', clc$alias_entry,
        clc$normal_usage_entry, 12, clc$automatically_log, clc$linked_call,
        ^fdp$_pop_forms],
  {} ['POSF                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 13, clc$automatically_log, clc$linked_call,
        ^fdp$_position_form],
  {} ['POSITION_FORM                  ', clc$nominal_entry,
        clc$normal_usage_entry, 13, clc$automatically_log, clc$linked_call,
        ^fdp$_position_form],
  {} ['PUSF                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 14, clc$automatically_log, clc$linked_call,
        ^fdp$_push_forms],
  {} ['PUSH_FORM                      ', clc$nominal_entry,
        clc$normal_usage_entry, 14, clc$automatically_log, clc$linked_call,
        ^fdp$_push_forms],
  {} ['PUSH_FORMS                     ', clc$alias_entry,
        clc$normal_usage_entry, 14, clc$automatically_log, clc$linked_call,
        ^fdp$_push_forms],
  {} ['QUI                            ', clc$abbreviation_entry,
        clc$normal_usage_entry, 15, clc$automatically_log, clc$linked_call,
        ^fdp$_quit],
  {} ['QUIT                           ', clc$nominal_entry,
        clc$normal_usage_entry, 15, clc$automatically_log, clc$linked_call,
        ^fdp$_quit],
  {} ['READ_FORM                      ', clc$nominal_entry,
        clc$normal_usage_entry, 16, clc$automatically_log, clc$linked_call,
        ^fdp$_read_forms],
  {} ['READ_FORMS                     ', clc$alias_entry,
        clc$normal_usage_entry, 16, clc$automatically_log, clc$linked_call,
        ^fdp$_read_forms],
  {} ['REAF                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 16, clc$automatically_log, clc$linked_call,
        ^fdp$_read_forms],
  {} ['REPFV                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 17, clc$automatically_log, clc$linked_call,
        ^fdp$_replace_form_variable],
  {} ['REPLACE_FORM_VARIABLE          ', clc$nominal_entry,
        clc$normal_usage_entry, 17, clc$automatically_log, clc$linked_call,
        ^fdp$_replace_form_variable],
  {} ['REPLACE_FORM_VARIABLES         ', clc$alias_entry,
        clc$normal_usage_entry, 17, clc$automatically_log, clc$linked_call,
        ^fdp$_replace_form_variable],
  {} ['RESET_FORM                     ', clc$nominal_entry,
        clc$normal_usage_entry, 18, clc$automatically_log, clc$linked_call,
        ^fdp$_reset_form],
  {} ['RESF                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 18, clc$automatically_log, clc$linked_call,
        ^fdp$_reset_form],
  {} ['SETCP                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 19, clc$automatically_log, clc$linked_call,
        ^fdp$_set_cursor_position],
  {} ['SETOA                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 20, clc$automatically_log, clc$linked_call,
        ^fdp$_set_object_attribute],
  {} ['SET_CURSOR_POSITION            ', clc$nominal_entry,
        clc$normal_usage_entry, 19, clc$automatically_log, clc$linked_call,
        ^fdp$_set_cursor_position],
  {} ['SET_OBJECT_ATTRIBUTE           ', clc$nominal_entry,
        clc$normal_usage_entry, 20, clc$automatically_log, clc$linked_call,
        ^fdp$_set_object_attribute],
  {} ['SET_OBJECT_ATTRIBUTES          ', clc$alias_entry,
        clc$normal_usage_entry, 20, clc$automatically_log, clc$linked_call,
        ^fdp$_set_object_attribute],
  {} ['SHOF                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 21, clc$automatically_log, clc$linked_call,
        ^fdp$_show_forms],
  {} ['SHOW_FORM                      ', clc$nominal_entry,
        clc$normal_usage_entry, 21, clc$automatically_log, clc$linked_call,
        ^fdp$_show_forms],
  {} ['SHOW_FORMS                     ', clc$alias_entry,
        clc$normal_usage_entry, 21, clc$automatically_log, clc$linked_call,
        ^fdp$_show_forms],
  {} ['TABTNF                         ', clc$abbreviation_entry,
        clc$hidden_entry, 22, clc$automatically_log, clc$linked_call,
        ^fdp$_tab_to_next_field],
  {} ['TAB_TO_NEXT_FIELD              ', clc$nominal_entry,
        clc$hidden_entry, 22, clc$automatically_log, clc$linked_call,
        ^fdp$_tab_to_next_field]];

  PROCEDURE [XREF] fdp$_create_form_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??

{ table fdv$functions t=f sn=fds$sub_commands_and_functions s=local
{ function $event_name                    fdp$$event_name cm=local
{ function $event_normal                  fdp$$event_normal cm=local
{ function $event_position                fdp$$event_position cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    fdv$functions: [STATIC, READ, fds$sub_commands_and_functions]
          ^clt$function_processor_table := ^fdv$functions_entries,

    fdv$functions_entries: [STATIC, READ, fds$sub_commands_and_functions]
          array [1 .. 3] of clt$function_proc_table_entry := [
          {} ['$EVENT_NAME                    ', clc$nominal_entry,
          clc$normal_usage_entry, 1, clc$linked_call, ^fdp$$event_name],
          {} ['$EVENT_NORMAL                  ', clc$nominal_entry,
          clc$normal_usage_entry, 2, clc$linked_call, ^fdp$$event_normal],
          {} ['$EVENT_POSITION                ', clc$nominal_entry,
          clc$normal_usage_entry, 3, clc$linked_call, ^fdp$$event_position]];

?? POP ??

?? TITLE := '  [XDCL] fdp$_manage_forms', EJECT ??

  PROCEDURE [XDCL] fdp$_manage_forms
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf) manage_form, manage_forms (
{   variable_creation, vc: key
{       form_variable, single, none
{     keyend = form_variable
{   variable_evaluation, ve: key
{       automatic, manual
{     keyend = manual
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
        default_value: string (13),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (6),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 27, 13, 7, 51, 256],
    clc$command, 5, 3, 0, 0, 0, 0, 3, 'FDM$MANF'], [
    ['STATUS                         ',clc$nominal_entry, 3],
    ['VARIABLE_CREATION              ',clc$nominal_entry, 1],
    ['VARIABLE_EVALUATION            ',clc$nominal_entry, 2],
    ['VC                             ',clc$abbreviation_entry, 1],
    ['VE                             ',clc$abbreviation_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_default_parameter, 0, 13],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [3], [
    ['FORM_VARIABLE                  ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['SINGLE                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'form_variable'],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [2], [
    ['AUTOMATIC                      ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['MANUAL                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'manual'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$variable_creation = 1,
    p$variable_evaluation = 2,
    p$status = 3;

  VAR
    pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      local_status: ost$status,
      prompt_string: string (3),
      utility_attributes: array [1 .. 6] of clt$utility_attribute;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    status.normal := TRUE;
    prompt_string := 'mf';
    IF pvt [p$variable_evaluation].value^.keyword_value = 'MANUAL' THEN
      fdv$variable_evaluation := fdc$manual;
    ELSE
      fdv$variable_evaluation := fdc$automatic;
    IFEND;

    IF pvt [p$variable_creation].value^.keyword_value = 'FORM_VARIABLE' THEN
      fdv$variable_creation := fdc$form_variable;
    ELSEIF pvt [p$variable_creation].value^.keyword_value = 'SINGLE' THEN
      fdv$variable_creation := fdc$single;
    ELSE
      fdv$variable_creation := fdc$none;
    IFEND;


{ Command language procedures need a unknown amount of storage to do their
{ work.  Use a segment to provide this storage.

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential,
          fdv$work_area, status);

    IF NOT status.normal THEN
      osp$set_status_abnormal (fdc$format_display_identifier,
            fde$no_space_available, '', status);
      RETURN;
    IFEND;

    utility_attributes [1].key := clc$utility_command_search_mode;
    utility_attributes [1].command_search_mode := clc$global_command_search;
    utility_attributes [2].key := clc$utility_command_table;
    utility_attributes [2].command_table := fdv$sub_commands;
    utility_attributes [3].key := clc$utility_function_proc_table;
    utility_attributes [3].function_processor_table := fdv$functions;
    utility_attributes [4].key := clc$utility_prompt;
    utility_attributes [4].prompt.value := prompt_string;
    utility_attributes [4].prompt.size := 2;
    utility_attributes [5].key := clc$utility_termination_command;
    utility_attributes [5].termination_command := 'quit';
    utility_attributes [6].key := clc$utility_subcmnd_log_enabled;
    utility_attributes [6].subcommand_logging_enabled := TRUE;
    clp$begin_utility (fdv$utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_status.normal := TRUE;
    clp$include_file (clc$current_command_input, prompt_string, fdv$utility_name,
          status);

    local_status.normal := TRUE;
    clp$end_utility (fdv$utility_name, local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND fdp$_manage_forms;
?? TITLE := '  [XDCL] fdp$_add_form', EJECT ??

  PROCEDURE [XDCL] fdp$_add_form
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_addf) add_form, addf (
{   form_name, fn: data_name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 26, 16, 0, 34, 395],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'FDM$MANF_ADDF'], [
    ['FN                             ',clc$abbreviation_entry, 1],
    ['FORM_NAME                      ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$form_name = 1,
    p$status = 2;

  VAR
    pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      form_identifier: fdt$form_identifier;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_form_identifier (pvt [p$form_name].value^.data_name_value,
          form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$add_form (form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdv$p_form_list^ [fdv$form_index].added := TRUE;

  PROCEND fdp$_add_form;

?? TITLE := '  [XDCL] fdp$_change_table_size', EJECT ??

  PROCEDURE [XDCL] fdp$_change_table_size
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_chats) change_table_size, chats (
{   form_name, fn: data_name = $required
{   table_name, tn: data_name = $required
{   table_size, ts: integer = 1
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 26, 16, 2, 42, 774],
    clc$command, 7, 4, 2, 0, 0, 0, 4, 'FDM$MANF_CHATS'], [
    ['FN                             ',clc$abbreviation_entry, 1],
    ['FORM_NAME                      ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['TABLE_NAME                     ',clc$nominal_entry, 2],
    ['TABLE_SIZE                     ',clc$nominal_entry, 3],
    ['TN                             ',clc$abbreviation_entry, 2],
    ['TS                             ',clc$abbreviation_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]],
{ PARAMETER 2
    [[1, 0, clc$data_name_type]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10],
    '1'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$form_name = 1,
    p$table_name = 2,
    p$table_size = 3,
    p$status = 4;

  VAR
    pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      form_identifier: fdt$form_identifier,
      table_name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_form_identifier (pvt [p$form_name].value^.data_name_value,
          form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    convert_to_form_name (pvt [p$table_name].value^.data_name_value,
          fdv$p_form_list^ [fdv$form_index].form_processor, table_name);
    fdp$change_table_size (form_identifier, table_name, pvt [p$table_size].
          value^.integer_value.value, status);

  PROCEND fdp$_change_table_size;

?? TITLE := '  [XDCL] fdp$_close_form', EJECT ??

  PROCEDURE [XDCL] fdp$_close_form
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_clof) close_form, clof (
{   form_name, fn: data_name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 26, 16, 7, 2, 557],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'FDM$MANF_CLOF'], [
    ['FN                             ',clc$abbreviation_entry, 1],
    ['FORM_NAME                      ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$form_name = 1,
    p$status = 2;

  VAR
    pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      form_identifier: fdt$form_identifier;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_form_identifier (pvt [p$form_name].value^.data_name_value,
          form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$close_form (form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    delete_form_from_list (pvt [p$form_name].value^.data_name_value);

  PROCEND fdp$_close_form;

?? TITLE := '  [XDCL] fdp$_combine_form', EJECT ??

  PROCEDURE [XDCL] fdp$_combine_form
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_comf) combine_form, combine_forms, comf (
{   added_form_name, afn: data_name = $required
{   combine_form_name, cfn: data_name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 26, 16, 8, 53, 752],
    clc$command, 5, 3, 2, 0, 0, 0, 3, 'FDM$MANF_COMF'], [
    ['ADDED_FORM_NAME                ',clc$nominal_entry, 1],
    ['AFN                            ',clc$abbreviation_entry, 1],
    ['CFN                            ',clc$abbreviation_entry, 2],
    ['COMBINE_FORM_NAME              ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]],
{ PARAMETER 2
    [[1, 0, clc$data_name_type]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$added_form_name = 1,
    p$combine_form_name = 2,
    p$status = 3;

  VAR
    pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      added_form_identifier: fdt$form_identifier,
      combine_form_identifier: fdt$form_identifier;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_form_identifier (pvt [p$added_form_name].value^.data_name_value,
          added_form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_form_identifier (pvt [p$combine_form_name].value^.data_name_value,
          combine_form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$combine_form (added_form_identifier, combine_form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdv$p_form_list^ [fdv$form_index].added := TRUE;

  PROCEND fdp$_combine_form;

?? TITLE := '  [XDCL] fdp$_delete_form', EJECT ??

  PROCEDURE [XDCL] fdp$_delete_form
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_delf) delete_form, delf (
{   form_name, fn: data_name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 26, 16, 28, 58, 72],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'FDM$MANF_DELF'], [
    ['FN                             ',clc$abbreviation_entry, 1],
    ['FORM_NAME                      ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$form_name = 1,
    p$status = 2;

  VAR
    pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      form_identifier: fdt$form_identifier;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_form_identifier (pvt [p$form_name].value^.data_name_value,
          form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$delete_form (form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdv$p_form_list^ [fdv$form_index].added := FALSE;

  PROCEND fdp$_delete_form;

?? TITLE := '[XDCL] fdp$$event_name', EJECT ??

  PROCEDURE [XDCL] fdp$$event_name
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (fdm$$manf_event_name) $event_name

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [88, 9, 27, 11, 20, 38, 55],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'FDM$$MANF_EVENT_NAME']];

?? POP ??

    VAR
      event_name: ost$name,
      form_name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_form_name (fdv$event.position.form_identifier, form_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    convert_to_scl_name (fdv$event.event_name,
          fdv$p_form_list^ [fdv$form_index].form_processor, event_name);
    clp$make_name_value (event_name, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier,
            fde$no_space_available, '', status);
    IFEND;

  PROCEND fdp$$event_name;

?? TITLE := '[XDCL] fdp$$event_normal', EJECT ??

  PROCEDURE [XDCL] fdp$$event_normal
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);


{ FUNCTION (fdm$$manf_en) $event_normal

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [88, 9, 27, 11, 25, 9, 969],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'FDM$$MANF_EN']];

?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_boolean_value (fdv$event.normal, clc$true_false_boolean, work_area,
          result);
    IF result = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier,
            fde$no_space_available, '', status);
    IFEND;

  PROCEND fdp$$event_normal;

?? TITLE := '[XDCL] fdp$$event_position', EJECT ??

  PROCEDURE [XDCL] fdp$$event_position
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);


{ FUNCTION (fdm$$manf_ep) $event_position (
{   option: key
{       (character_position, cp)
{       (form_event, fe)
{       (form_name, fn)
{       (form_x_position, fxp)
{       (form_y_position, fyp)
{       (object_event, oe)
{       (object_name, on)
{       (object_type, ot)
{       (object_x_position, oxp)
{       (object_y_position, oyp)
{       (occurrence, o)
{       (screen_x_position, sxp)
{       (screen_y_position, syp)
{     keyend = $required
{   )

?? PUSH (LISTEXT := ON) ??

  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$keyword_type_qualifier,
        keyword_specs: array [1 .. 26] of clt$keyword_specification,
      recend,
    recend := [
    [1,
    [88, 9, 27, 11, 26, 5, 208],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'FDM$$MANF_EP'], [
    ['OPTION                         ',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, 969,
  clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [26], [
    ['CHARACTER_POSITION             ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['CP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['FE                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FN                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FORM_EVENT                     ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['FORM_NAME                      ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['FORM_X_POSITION                ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['FORM_Y_POSITION                ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['FXP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['FYP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['O                              ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
    ['OBJECT_EVENT                   ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['OBJECT_NAME                    ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['OBJECT_TYPE                    ', clc$nominal_entry, clc$normal_usage_entry, 8],
    ['OBJECT_X_POSITION              ', clc$nominal_entry, clc$normal_usage_entry, 9],
    ['OBJECT_Y_POSITION              ', clc$nominal_entry, clc$normal_usage_entry, 10],
    ['OCCURRENCE                     ', clc$nominal_entry, clc$normal_usage_entry, 11],
    ['OE                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['ON                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
    ['OT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
    ['OXP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
    ['OYP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
    ['SCREEN_X_POSITION              ', clc$nominal_entry, clc$normal_usage_entry, 12],
    ['SCREEN_Y_POSITION              ', clc$nominal_entry, clc$normal_usage_entry, 13],
    ['SXP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
    ['SYP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 13]]
    ]];

?? POP ??

  CONST
    p$option = 1;

  VAR
    pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      form_name: ost$name,
      name: ost$name,
      object_name: ost$name,
      object_type: fdt$object_definition_key;

    result := NIL;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    name := pvt [p$option].value^.name_value;
    IF name = 'CHARACTER_POSITION' THEN
      clp$make_integer_value (fdv$event.position.character_position, 10, FALSE,
            work_area, result);

    ELSEIF name = 'FORM_EVENT' THEN
      clp$make_boolean_value ((fdv$event.position.key = fdc$form_event),
            clc$true_false_boolean, work_area, result);

    ELSEIF name = 'FORM_NAME' THEN
      get_form_name (fdv$event.position.form_identifier, form_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$make_name_value (form_name, work_area, result);

    ELSEIF name = 'FORM_X_POSITION' THEN
      clp$make_integer_value (fdv$event.position.form_x_position, 10, FALSE,
            work_area, result);

    ELSEIF name = 'FORM_Y_POSITION' THEN
      clp$make_integer_value (fdv$event.position.form_y_position, 10, FALSE,
            work_area, result);

    ELSEIF name = 'OBJECT_EVENT' THEN
      clp$make_boolean_value ((fdv$event.position.key = fdc$object_event),
            clc$true_false_boolean, work_area, result);

    ELSEIF name = 'OBJECT_NAME' THEN
      convert_to_scl_name (fdv$event.position.object_name,
            fdv$p_form_list^ [fdv$form_index].form_processor, object_name);
      clp$make_name_value (object_name, work_area, result);

    ELSEIF name = 'OBJECT_TYPE' THEN
      object_type := fdv$event.position.object_definition_key;
      IF object_type = fdc$box THEN
        name := 'BOX';
      ELSEIF object_type = fdc$line THEN
        name := 'LINE';
      ELSEIF object_type = fdc$constant_text THEN
        name := 'CONSTANT_TEXT';
      ELSEIF object_type = fdc$constant_text_box THEN
        name := 'CONSTANT_TEXT_BOX';
      ELSEIF object_type = fdc$variable_text THEN
        name := 'VARIABLE_TEXT';
      ELSEIF object_type = fdc$variable_text_box THEN
        name := 'VARIABLE_TEXT_BOX';
      ELSE
        name := ' ';
      IFEND;

      clp$make_keyword_value (name, work_area, result);

    ELSEIF name = 'OBJECT_X_POSITION' THEN
      clp$make_integer_value (fdv$event.position.object_x_position, 10, FALSE,
            work_area, result);

    ELSEIF name = 'OBJECT_Y_POSITION' THEN
      clp$make_integer_value (fdv$event.position.object_y_position, 10, FALSE,
            work_area, result);

    ELSEIF name = 'OCCURRENCE' THEN
      IF fdv$event.position.key = fdc$object_event THEN
        clp$make_integer_value (fdv$event.position.object_occurrence, 10, FALSE,
              work_area, result);
      ELSE
        clp$make_integer_value (0, 10, FALSE, work_area, result);
      IFEND;

    ELSEIF name = 'SCREEN_X_POSITION' THEN
      clp$make_integer_value (fdv$event.position.screen_x_position, 10, FALSE,
            work_area, result);

    ELSEIF name = 'SCREEN_Y_POSITION' THEN
      clp$make_integer_value (fdv$event.position.screen_y_position, 10, FALSE,
            work_area, result);

    ELSE
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
            'function parameter', status);
      RETURN;
    IFEND;

    IF result = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier,
            fde$no_space_available, '', status);
    IFEND;

  PROCEND fdp$$event_position;

?? TITLE := '  [XDCL] fdp$_get_form_variable', EJECT ??

  PROCEDURE [XDCL] fdp$_get_form_variable
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_getfv) get_form_variable, get_form_variables, getfv (
{   form_name, fn: data_name = $required
{   variable_name, vn: data_name = $required
{   value, v: (VAR) any = $required
{   occurrence, o: integer 1..fdc$maximum_occurrence = 1
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 27, 13, 38, 12, 515],
    clc$command, 9, 5, 3, 0, 0, 1, 5, 'FDM$MANF_GETFV'], [
    ['FN                             ',clc$abbreviation_entry, 1],
    ['FORM_NAME                      ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OCCURRENCE                     ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['V                              ',clc$abbreviation_entry, 3],
    ['VALUE                          ',clc$nominal_entry, 3],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 2],
    ['VN                             ',clc$abbreviation_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 12,
  clc$required_parameter, 0, 0],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]],
{ PARAMETER 2
    [[1, 0, clc$data_name_type]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [-$clt$type_kinds [],
    FALSE, 0]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [1, fdc$maximum_occurrence, 10],
    '1'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$form_name = 1,
    p$variable_name = 2,
    p$value = 3,
    p$occurrence = 4,
    p$status = 5;

  VAR
    pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      data_value: clt$data_value,
      form_identifier: fdt$form_identifier,
      form_variable_name: ost$name,
      integer_value: integer,
      p_string_value: ^string ( * ),
      p_variable_information: ^fdt$variable_information,
      real_value: real,
      variable_status: fdt$variable_status;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_form_identifier (pvt [p$form_name].value^.data_name_value,
          form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    convert_to_form_name (pvt [p$variable_name].value^.data_name_value,
          fdv$p_form_list^ [fdv$form_index].form_processor, form_variable_name);

    find_variable_name (form_variable_name, p_variable_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    CASE p_variable_information^.program_data_type OF

    = fdc$program_integer_type =
      fdp$get_integer_variable (form_identifier, form_variable_name,
            pvt [p$occurrence].value^.integer_value.value, integer_value,
            variable_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF variable_status <> fdc$no_error THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
        RETURN;
      IFEND;

      data_value.kind := clc$integer;
      data_value.integer_value.radix := 10;
      data_value.integer_value.radix_specified := FALSE;
      data_value.integer_value.value := integer_value;

    = fdc$program_real_type =
      compute_scl_real(form_identifier, p_variable_information,
            pvt [p$occurrence].value^.integer_value.value, data_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    = fdc$program_character_type, fdc$program_upper_case_type =
      PUSH p_string_value: [p_variable_information^.variable_length];
      fdp$get_string_variable (form_identifier, form_variable_name,
            pvt [p$occurrence].value^.integer_value.value, p_string_value^,
            variable_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF variable_status <> fdc$no_error THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
        RETURN;
      IFEND;

      data_value.kind := clc$string;
      data_value.string_value := p_string_value;

    ELSE {fdc$program_cobol_type}
      osp$set_status_abnormal (fdc$format_display_identifier, fde$cobol_invalid_manage_form,
            pvt [p$variable_name].value^.data_name_value, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            pvt [p$form_name].value^.data_name_value, status);
      RETURN;
    CASEND;

    clp$change_variable (pvt [p$value].variable^, ^data_value, status);

  PROCEND fdp$_get_form_variable;

?? TITLE := '  [XDCL] fdp$_get_next_changed_variable', EJECT ??

  PROCEDURE [XDCL] fdp$_get_next_changed_variable
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_getncv) get_next_changed_variable, getncv (
{   form_name, fn: name = $required
{   variable_name, vn: (VAR) name = $required
{   occurrence, o: (VAR) integer = $optional
{   change_found, cf: (VAR) boolean = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 4, 28, 10, 7, 6, 328],
    clc$command, 9, 5, 3, 0, 0, 3, 5, 'FDM$MANF_GETNCV'], [
    ['CF                             ',clc$abbreviation_entry, 4],
    ['CHANGE_FOUND                   ',clc$nominal_entry, 4],
    ['FN                             ',clc$abbreviation_entry, 1],
    ['FORM_NAME                      ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OCCURRENCE                     ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 2],
    ['VN                             ',clc$abbreviation_entry, 2]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
{ PARAMETER 4
    [[1, 0, clc$boolean_type]],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$form_name = 1,
      p$variable_name = 2,
      p$occurrence = 3,
      p$change_found = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      change_found: boolean,
      form_identifier: fdt$form_identifier,
      occurrence: fdt$occurrence,
      value: ^clt$data_value,
      variable_name: ost$name,
      pointer: amt$segment_pointer;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_form_identifier (pvt [p$form_name].value^.data_name_value, form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$get_next_changed_variable (form_identifier, variable_name, occurrence, change_found, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Update VAR parameters.

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_boolean_value (change_found, clc$true_false_boolean, pointer.sequence_pointer, value);
    clp$change_variable (pvt [p$change_found].variable^, value, status);

    IF change_found THEN
      clp$make_name_value (variable_name, pointer.sequence_pointer, value);
      clp$change_variable (pvt [p$variable_name].variable^, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF pvt [p$occurrence].specified THEN
        clp$make_integer_value (occurrence, 10, FALSE, pointer.sequence_pointer, value);
        clp$change_variable (pvt [p$occurrence].variable^, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

  PROCEND fdp$_get_next_changed_variable;
?? TITLE := '  [XDCL] fdp$_get_next_input_error', EJECT ??

  PROCEDURE [XDCL] fdp$_get_next_input_error
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_getnie) get_next_input_error, getnie (
{   form_name,fn : name =$required
{   variable_name, vn: (VAR) name = $required
{   occurrence, o: (VAR) integer = $optional
{   variable_status, vs: (VAR) integer = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 4, 28, 10, 9, 51, 698],
    clc$command, 9, 5, 3, 0, 0, 3, 5, 'FDM$MANF_GETNIE'], [
    ['FN                             ',clc$abbreviation_entry, 1],
    ['FORM_NAME                      ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OCCURRENCE                     ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 2],
    ['VARIABLE_STATUS                ',clc$nominal_entry, 4],
    ['VN                             ',clc$abbreviation_entry, 2],
    ['VS                             ',clc$abbreviation_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$required_parameter, 0, 0],
{ PARAMETER 5
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$form_name = 1,
      p$variable_name = 2,
      p$occurrence = 3,
      p$variable_status = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      form_identifier: fdt$form_identifier,
      occurrence: fdt$occurrence,
      value: ^clt$data_value,
      variable_name: ost$name,
      variable_status: fdt$variable_status,
      pointer: amt$segment_pointer;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_form_identifier (pvt [p$form_name].value^.data_name_value,
          form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$get_next_input_error (form_identifier, variable_name, occurrence, variable_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Update VAR parameters.

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    clp$make_integer_value ($INTEGER (variable_status), 10, FALSE, pointer.sequence_pointer, value);
    clp$change_variable (pvt [p$variable_status].variable^, value, status);

    IF variable_status <> fdc$no_error THEN

{ Return information describing the variable error.

      clp$make_name_value (variable_name, pointer.sequence_pointer, value);
      clp$change_variable (pvt [p$variable_name].variable^, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF pvt [p$occurrence].specified THEN
        clp$make_integer_value (occurrence, 10, FALSE, pointer.sequence_pointer, value);
        clp$change_variable (pvt [p$occurrence].variable^, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

  PROCEND fdp$_get_next_input_error;
?? TITLE := '  [XDCL] fdp$_get_next_output_error', EJECT ??

  PROCEDURE [XDCL] fdp$_get_next_output_error
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_getnoe) get_next_output_error, getnoe (
{   form_name,fn : name =$required
{   variable_name, vn: (VAR) name = $required
{   occurrence, o: (VAR) integer = $optional
{   variable_status, vs: (VAR) integer = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 4, 28, 10, 11, 9, 192],
    clc$command, 9, 5, 3, 0, 0, 3, 5, 'FDM$MANF_GETNOE'], [
    ['FN                             ',clc$abbreviation_entry, 1],
    ['FORM_NAME                      ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OCCURRENCE                     ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 2],
    ['VARIABLE_STATUS                ',clc$nominal_entry, 4],
    ['VN                             ',clc$abbreviation_entry, 2],
    ['VS                             ',clc$abbreviation_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$required_parameter, 0, 0],
{ PARAMETER 5
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$form_name = 1,
      p$variable_name = 2,
      p$occurrence = 3,
      p$variable_status = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      form_identifier: fdt$form_identifier,
      occurrence: fdt$occurrence,
      value: ^clt$data_value,
      variable_name: ost$name,
      variable_status: fdt$variable_status,
      pointer: amt$segment_pointer;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_form_identifier (pvt [p$form_name].value^.data_name_value, form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$get_next_output_error (form_identifier, variable_name, occurrence, variable_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Update VAR parameters.

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_integer_value ($INTEGER (variable_status), 10, FALSE, pointer.sequence_pointer, value);
    clp$change_variable (pvt [p$variable_status].variable^, value, status);

    IF variable_status <> fdc$no_error THEN

{ Return information describing the variable error.

      clp$make_name_value (variable_name, pointer.sequence_pointer, value);
      clp$change_variable (pvt [p$variable_name].variable^, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF pvt [p$occurrence].specified THEN
        clp$make_integer_value (occurrence, 10, FALSE, pointer.sequence_pointer, value);
        clp$change_variable (pvt [p$occurrence].variable^, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

  PROCEND fdp$_get_next_output_error;
?? TITLE := '  [XDCL] fdp$_open_form', EJECT ??

  PROCEDURE [XDCL] fdp$_open_form
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_opef) open_form, opef (
{   form_name, fn: data_name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 26, 16, 32, 26, 235],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'FDM$MANF_OPEF'], [
    ['FN                             ',clc$abbreviation_entry, 1],
    ['FORM_NAME                      ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$form_name = 1,
    p$status = 2;

  VAR
    pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      form_identifier: fdt$form_identifier,
      form_is_open: boolean,
      form_name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    form_name := pvt [p$form_name].value^.data_name_value;

    add_form_to_list (form_name, form_is_open, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF form_is_open THEN
      RETURN;
    IFEND;

    fdp$open_form (form_name, form_identifier, status);
    IF NOT status.normal THEN
      delete_form_from_list (form_name);
      RETURN;
    IFEND;

    fdv$p_form_list^ [fdv$form_index].form_identifier := form_identifier;


    CASE fdv$variable_creation OF

    = fdc$form_variable =

{ Create one record variable for the entire form. Variables on the form
{ are fields within the record variable.

      create_form_variable (^fdv$p_form_list^ [fdv$form_index], status);

    = fdc$none =

{ Do not create any variables.

    = fdc$single =

{ Create one SCL variable for each variable on the form.

      create_single_variables (form_identifier, status);

    ELSE
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
            'invalid form creation', status);
    CASEND;

  PROCEND fdp$_open_form;

?? TITLE := '  [XDCL] fdp$_pop_forms', EJECT ??

  PROCEDURE [XDCL] fdp$_pop_forms
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_popf) pop_form, pop_forms, popf (
{   status)

?? PUSH (LISTEXT := ON) ??

  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,
      recend,
    recend := [
    [1,
    [88, 9, 27, 13, 38, 58, 307],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'FDM$MANF_POPF'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$status = 1;

  VAR
    pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      form_index: fdt$form_identifier;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$pop_forms (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF fdv$push_index > 0 THEN
      FOR form_index := 1 TO fdv$high_form_index DO
        IF fdv$p_form_list^ [form_index].push_index = fdv$push_index THEN
          fdv$p_form_list^ [form_index].push_index := 0;
        IFEND;
      FOREND;

      fdv$push_index := fdv$push_index - 1;
    IFEND;

  PROCEND fdp$_pop_forms;

?? TITLE := '  [XDCL] fdp$_position_form', EJECT ??

  PROCEDURE [XDCL] fdp$_position_form
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_posf) position_form, posf (
{   form_name, fn: data_name = $required
{   x_position, xp: integer 1..fdc$maximum_x_position = 1
{   y_position, yp: integer 1..fdc$maximum_y_position = 1
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 26, 16, 35, 2, 958],
    clc$command, 7, 4, 1, 0, 0, 0, 4, 'FDM$MANF_POSF'], [
    ['FN                             ',clc$abbreviation_entry, 1],
    ['FORM_NAME                      ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['XP                             ',clc$abbreviation_entry, 2],
    ['X_POSITION                     ',clc$nominal_entry, 2],
    ['YP                             ',clc$abbreviation_entry, 3],
    ['Y_POSITION                     ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, fdc$maximum_x_position, 10],
    '1'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, fdc$maximum_y_position, 10],
    '1'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$form_name = 1,
    p$x_position = 2,
    p$y_position = 3,
    p$status = 4;

  VAR
    pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      form_identifier: fdt$form_identifier;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_form_identifier (pvt [p$form_name].value^.data_name_value,
          form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$position_form (form_identifier, pvt [p$x_position].value^.integer_value.
          value, pvt [p$y_position].value^.integer_value.value, status);

  PROCEND fdp$_position_form;

?? TITLE := '  [XDCL] fdp$_push_forms', EJECT ??

  PROCEDURE [XDCL] fdp$_push_forms
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_pusf) push_form, push_forms, pusf (
{   status)

?? PUSH (LISTEXT := ON) ??

  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,
      recend,
    recend := [
    [1,
    [88, 9, 27, 13, 39, 30, 881],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'FDM$MANF_PUSF'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$status = 1;

  VAR
    pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      form_index: fdt$form_identifier;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$push_forms (status);
    IF fdv$push_index < fdc$maximum_form_identifier THEN
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      fdv$push_index := fdv$push_index + 1;
      FOR form_index := 1 TO fdv$high_form_index DO
        IF fdv$p_form_list^ [form_index].added AND
              (fdv$p_form_list^ [form_index].push_index = 0) THEN
          fdv$p_form_list^ [form_index].push_index := fdv$push_index;
        IFEND;
      FOREND;
    IFEND;

  PROCEND fdp$_push_forms;

?? TITLE := '  [XDCL] fdp$_quit', EJECT ??

  PROCEDURE [XDCL] fdp$_quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_qui) quit, qui (
{   status)

?? PUSH (LISTEXT := ON) ??

  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,
      recend,
    recend := [
    [1,
    [88, 9, 26, 16, 37, 55, 567],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'FDM$MANF_QUI'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$status = 1;

  VAR
    pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_include (fdv$utility_name, status);

  PROCEND fdp$_quit;

?? TITLE := '  [XDCL] fdp$_read_forms', EJECT ??

  PROCEDURE [XDCL] fdp$_read_forms
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_reaf) read_form, read_forms, reaf (
{   status)

?? PUSH (LISTEXT := ON) ??

  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,
      recend,
    recend := [
    [1,
    [88, 9, 27, 13, 40, 6, 318],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'FDM$MANF_REAF'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$status = 1;

  VAR
    pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      last_event: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF fdv$variable_evaluation = fdc$automatic THEN

{ Transfer values of SCL variables to Screen Formatting.

      replace_variables (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    fdp$read_forms (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$get_next_event (fdv$event.event_name, fdv$event.normal,
          fdv$event.position, last_event, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF ((fdv$variable_evaluation = fdc$automatic) AND fdv$event.normal) THEN

{ Transfer values the terminal user entered on the form to SCL variables.

      get_variables (status);
    IFEND;

  PROCEND fdp$_read_forms;

?? TITLE := '  [XDCL] fdp$_replace_form_variable', EJECT ??

  PROCEDURE [XDCL] fdp$_replace_form_variable
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_repfv) replace_form_variable, replace_form_variables, repfv (
{   form_name, fn: data_name = $required
{   variable_name, vn: data_name = $required
{   value, v: any = $required
{   occurrence, o: integer 1..fdc$maximum_occurrence = 1
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$union_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 27, 13, 41, 26, 957],
    clc$command, 9, 5, 3, 0, 0, 0, 5, 'FDM$MANF_REPFV'], [
    ['FN                             ',clc$abbreviation_entry, 1],
    ['FORM_NAME                      ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OCCURRENCE                     ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['V                              ',clc$abbreviation_entry, 3],
    ['VALUE                          ',clc$nominal_entry, 3],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 2],
    ['VN                             ',clc$abbreviation_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 12, clc$required_parameter,
  0, 0],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]],
{ PARAMETER 2
    [[1, 0, clc$data_name_type]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [-$clt$type_kinds [],
    FALSE, 0]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [1, fdc$maximum_occurrence, 10],
    '1'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$form_name = 1,
    p$variable_name = 2,
    p$value = 3,
    p$occurrence = 4,
    p$status = 5;

  VAR
    pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      form_identifier: fdt$form_identifier,
      form_variable_name: ost$name,
      real_value: real,
      variable_status: fdt$variable_status;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_form_identifier (pvt [p$form_name].value^.data_name_value,
          form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    convert_to_form_name (pvt [p$variable_name].value^.data_name_value,
          fdv$p_form_list^ [fdv$form_index].form_processor, form_variable_name);

    CASE pvt [p$value].value^.kind OF

    = clc$integer =
      fdp$replace_integer_variable (form_identifier, form_variable_name,
            pvt [p$occurrence].value^.integer_value.value,
            pvt [p$value].value^.integer_value.value, variable_status, status);

    = clc$real =

{ The command language uses double precision for real numbers.
{ Screen Formatting and CYBIL use single precision for real  numbers.  Use
{ the most significant part of the double precision command language real
{ for CYBIL.

      real_value := $REAL (pvt [p$value].value^.real_value.value);
      fdp$replace_real_variable (form_identifier, form_variable_name,
            pvt [p$occurrence].value^.integer_value.value, real_value,
            variable_status, status);

    = clc$string =
      fdp$replace_string_variable (form_identifier, form_variable_name,
            pvt [p$occurrence].value^.integer_value.value,
            pvt [p$value].value^.string_value^, variable_status, status);

    ELSE
      osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
      RETURN;
    CASEND;

    IF status.normal THEN
      IF variable_status <> fdc$no_error THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
      IFEND;
    IFEND;

  PROCEND fdp$_replace_form_variable;

?? TITLE := '  [XDCL] fdp$_reset_form', EJECT ??

  PROCEDURE [XDCL] fdp$_reset_form
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (fdm$manf_resf) reset_form, resf (
{   form_name, fn: data_name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 26, 16, 44, 23, 469],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'FDM$MANF_RESF'], [
    ['FN                             ',clc$abbreviation_entry, 1],
    ['FORM_NAME                      ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$form_name = 1,
    p$status = 2;

  VAR
    pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      form_identifier: fdt$form_identifier,
      form_processor: fdt$form_processor,
      p_form_information: ^fdt$form_information,
      p_variable_information: ^fdt$variable_information,
      p_variables: ^array [1 .. *] of fdt$variable_information,
      variable_index: fdt$variable_index;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_form_identifier (pvt [p$form_name].value^.data_name_value,
          form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$reset_form (form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF fdv$variable_evaluation = fdc$automatic THEN

{ Transfer initial values set in the form to SCL variables.

      p_form_information := ^fdv$p_form_list^ [fdv$form_index];
      p_variables := p_form_information^.p_variables;
      IF p_variables <> NIL THEN
        IF fdv$variable_creation = fdc$form_variable THEN
          get_form_variable (p_form_information, status);
        ELSE
          form_processor := p_form_information^.form_processor;
          FOR variable_index := 1 TO UPPERBOUND (p_variables^) DO
            p_variable_information := ^p_variables^ [variable_index];
            get_single_variable (p_variable_information,
                  p_variable_information^.occurrence, form_identifier,
                  form_processor, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND fdp$_reset_form;

?? TITLE := '  [XDCL] fdp$_set_cursor_position', EJECT ??

  PROCEDURE [XDCL] fdp$_set_cursor_position
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (fdm$manf_setcp) set_cursor_position, setcp (
{   form_name, fn: data_name = $required
{   object_name, on: data_name = $required
{   occurrence, o: integer 1..1000 = 1
{   character_position, cp: integer 1..4096 = 1
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 26, 16, 45, 47, 597],
    clc$command, 9, 5, 2, 0, 0, 0, 5, 'FDM$MANF_SETCP'], [
    ['CHARACTER_POSITION             ',clc$nominal_entry, 4],
    ['CP                             ',clc$abbreviation_entry, 4],
    ['FN                             ',clc$abbreviation_entry, 1],
    ['FORM_NAME                      ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OBJECT_NAME                    ',clc$nominal_entry, 2],
    ['OCCURRENCE                     ',clc$nominal_entry, 3],
    ['ON                             ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]],
{ PARAMETER 2
    [[1, 0, clc$data_name_type]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, 1000, 10],
    '1'],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [1, 4096, 10],
    '1'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$form_name = 1,
    p$object_name = 2,
    p$occurrence = 3,
    p$character_position = 4,
    p$status = 5;

  VAR
    pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      form_identifier: fdt$form_identifier,
      object_name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_form_identifier (pvt [p$form_name].value^.data_name_value,
          form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    convert_to_form_name (pvt [p$object_name].value^.data_name_value,
          fdv$p_form_list^ [fdv$form_index].form_processor, object_name);
    fdp$set_cursor_position (form_identifier, object_name,
          pvt [p$occurrence].value^.integer_value.value,
          pvt [p$character_position].value^.integer_value.value, status);

  PROCEND fdp$_set_cursor_position;

?? TITLE := '  [XDCL] fdp$_set_object_attribute', EJECT ??

  PROCEDURE [XDCL] fdp$_set_object_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_setoa) set_object_attribute, setoa (
{   form_name, fn: data_name = $required
{   object_name, on: data_name = $required
{   attribute, a: any of
{       key
{         initial
{       keyend
{       data_name
{     anyend = initial
{   occurrence, o: integer 1..fdc$maximum_occurrence = 1
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: 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,
        recend,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 26, 16, 47, 9, 686],
    clc$command, 9, 5, 2, 0, 0, 0, 5, 'FDM$MANF_SETOA'], [
    ['A                              ',clc$abbreviation_entry, 3],
    ['ATTRIBUTE                      ',clc$nominal_entry, 3],
    ['FN                             ',clc$abbreviation_entry, 1],
    ['FORM_NAME                      ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OBJECT_NAME                    ',clc$nominal_entry, 2],
    ['OCCURRENCE                     ',clc$nominal_entry, 4],
    ['ON                             ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 67,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$data_name_type]],
{ PARAMETER 2
    [[1, 0, clc$data_name_type]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$data_name_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['INITIAL                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$data_name_type]]
    ,
    'initial'],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [1, fdc$maximum_occurrence, 10],
    '1'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$form_name = 1,
    p$object_name = 2,
    p$attribute = 3,
    p$occurrence = 4,
    p$status = 5;

  VAR
    pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      attribute_name: ost$name,
      form_identifier: fdt$form_identifier,
      object_name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_form_identifier (pvt [p$form_name].value^.data_name_value,
          form_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    convert_to_form_name (pvt [p$object_name].value^.data_name_value,
          fdv$p_form_list^ [fdv$form_index].form_processor, object_name);
    IF pvt [p$attribute].value^.kind = clc$keyword THEN

{ On the INITIAL key word reset the object attributes to those specified
{ when the form was defined.

      fdp$reset_object_attribute (form_identifier, object_name,
            pvt [p$occurrence].value^.integer_value.value, status);
    ELSE

      convert_to_form_name (pvt [p$attribute].value^.data_name_value,
            fdv$p_form_list^ [fdv$form_index].form_processor, attribute_name);
      fdp$set_object_attribute (form_identifier, object_name,
            pvt [p$occurrence].value^.integer_value.value, attribute_name,
            status);
    IFEND;
  PROCEND fdp$_set_object_attribute;

?? TITLE := '  [XDCL] fdp$_show_forms', EJECT ??

  PROCEDURE [XDCL] fdp$_show_forms
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (fdm$manf_shof) show_form, show_forms, shof (
{   status)

?? PUSH (LISTEXT := ON) ??

  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,
      recend,
    recend := [
    [1,
    [88, 9, 27, 13, 36, 25, 610],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'FDM$MANF_SHOF'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$status = 1;

  VAR
    pvt: array [1 .. 1] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF fdv$variable_evaluation = fdc$automatic THEN

{ Transfer values of SCL variables to Screen Formatting variables.

      replace_variables (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    fdp$show_forms (status);

  PROCEND fdp$_show_forms;
?? TITLE := '  [XDCL] fdp$_tab_to_next_field', EJECT ??

  PROCEDURE [XDCL] fdp$_tab_to_next_field
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (fdm$manf_tabtnf) tab_to_next_field, tabtnf (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [89, 4, 28, 10, 16, 8, 901],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'FDM$MANF_TABTNF'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$tab_to_next_field (status);

  PROCEND fdp$_tab_to_next_field;
?? TITLE := '  add_form_to_list', EJECT ??

  PROCEDURE add_form_to_list
    (    form_name: ost$name;
     VAR form_is_open: boolean;
     VAR status: ost$status);

    CONST
      fdc$forms_to_expand = 7;

    VAR
      form_index: fdt$form_identifier,
      number_entries: 1 .. fdc$maximum_form_identifier,
      p_temporary_form_list: ^array [1 .. fdc$maximum_form_identifier] of
            fdt$form_information;

    form_is_open := FALSE;

{ If form is open, use current entry.

    FOR form_index := 1 TO fdv$high_form_index DO
      IF form_name = fdv$p_form_list^ [form_index].name THEN
        form_is_open := TRUE;
        fdv$form_index := form_index;
        RETURN;
      IFEND;
    FOREND;


    IF fdv$p_form_list = NIL THEN
      ALLOCATE fdv$p_form_list: [1 .. fdc$forms_to_expand];
      IF fdv$p_form_list = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$no_space_available, '', status);
        RETURN;
      IFEND;

      FOR form_index := 1 TO fdc$forms_to_expand DO
        fdv$p_form_list^ [form_index].name := ' ';
      FOREND;

      fdv$high_form_index := fdv$high_form_index + 1;
      fdv$p_form_list^ [fdv$high_form_index].added := FALSE;
      fdv$p_form_list^ [fdv$high_form_index].name := form_name;
      fdv$p_form_list^ [fdv$high_form_index].push_index := 0;
      fdv$p_form_list^ [fdv$high_form_index].p_variables := NIL;
      fdv$p_form_list^ [fdv$high_form_index].p_tables := NIL;
      fdv$p_form_list^ [fdv$high_form_index].form_variable_created := FALSE;
      fdv$form_index := fdv$high_form_index;
      RETURN;
    IFEND;

{ If any unused entry exits, assign it to form.

    number_entries := UPPERBOUND (fdv$p_form_list^);
    FOR form_index := 1 TO number_entries DO
      IF fdv$p_form_list^ [form_index].name = ' ' THEN
        fdv$form_index := form_index;
        fdv$p_form_list^ [form_index].added := FALSE;
        fdv$p_form_list^ [form_index].name := form_name;
        fdv$p_form_list^ [form_index].push_index := 0;
        fdv$p_form_list^ [form_index].p_variables := NIL;
        fdv$p_form_list^ [form_index].p_tables := NIL;
        fdv$p_form_list^ [form_index].form_variable_created := FALSE;
        IF form_index > fdv$high_form_index THEN
          fdv$high_form_index := form_index;
        IFEND;
        RETURN;
      IFEND;
    FOREND;

    IF fdv$high_form_index >= number_entries THEN
      IF (number_entries + fdc$forms_to_expand) >
            fdc$maximum_form_identifier THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$no_space_available, '', status);
        RETURN;
      IFEND;
    IFEND;

{ Expand the list for opened forms.

      p_temporary_form_list := fdv$p_form_list;
      ALLOCATE fdv$p_form_list: [1 .. number_entries + fdc$forms_to_expand];
      IF fdv$p_form_list = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$no_space_available, '', status);
        RETURN;
      IFEND;

      FOR form_index := 1 TO number_entries DO
        fdv$p_form_list^ [form_index] :=
              p_temporary_form_list^ [form_index];
      FOREND;

      FOR form_index := number_entries + 1 TO number_entries +
            fdc$forms_to_expand DO
        fdv$p_form_list^ [form_index].name := ' ';
      FOREND;

    fdv$high_form_index := fdv$high_form_index + 1;
    fdv$p_form_list^ [fdv$high_form_index].added := FALSE;
    fdv$p_form_list^ [fdv$high_form_index].name := form_name;
    fdv$p_form_list^ [fdv$high_form_index].push_index := 0;
    fdv$p_form_list^ [fdv$high_form_index].p_variables := NIL;
    fdv$p_form_list^ [fdv$high_form_index].p_tables := NIL;
    fdv$p_form_list^ [fdv$high_form_index].form_variable_created := FALSE;
    fdv$form_index := fdv$high_form_index;

  PROCEND add_form_to_list;

?? TITLE := '  compute_scl_real', EJECT ??

  PROCEDURE compute_scl_real
    (    form_identifier: fdt$form_identifier;
         p_variable_information: ^fdt$variable_information;
         occurrence: fdt$occurrence;
     VAR data_value: clt$data_value;
     VAR status: ost$status);

    VAR
      actual_text_length: mlt$string_length,
      character_found: boolean,
      error: mlt$error,
      non_space: [READ, STATIC] packed array [char] of boolean := [
            {---} REP 32 of TRUE,
            {- -} FALSE,
            {---} REP 223 of TRUE],
      real_value: real,
      scan_index: integer,
      screen_variable_length: fdt$screen_variable_length,
      start_index: integer,
      string_value: string (fdc$maximum_x_position + 1),
      variable_status: fdt$variable_status;

{ SCL supports only double precision real numbers.  Screen Formatting
{ currently only supports single precision real numbers. In order to
{ compare a number assigned value in SCL with a number assigned a value
{ in Screen Formatting, the text entered by the terminal user must
{ be converted to a double precision real number.

{ Get the real number from Screen Formatting to make sure the number is valid.

      fdp$get_real_variable (form_identifier, p_variable_information^.name,
            occurrence, real_value, variable_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF variable_status <> fdc$no_error THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
        RETURN;
      IFEND;

{ Convert the text entered by the terminal user to a double precision real number.

      fdp$get_screen_variable (form_identifier, p_variable_information^.name,
            occurrence, string_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      data_value.kind := clc$real;
      data_value.real_value.number_of_digits := fdc$real_number_of_digits;

{ Ignore leading spaces.

      screen_variable_length := fdc$maximum_x_position + 1;
      #SCAN (non_space, string_value, start_index, character_found);
      IF start_index > screen_variable_length THEN
        data_value.real_value.value := 0.0D1;
        RETURN;
      IFEND;

{ Spaces in middle of number are invalid so stop on blanks.

      mlp$input_floating_number (^string_value (start_index, *) ,
      screen_variable_length - start_index + 1, ^data_value.real_value.value,
            mlc$double_precision, mlc$stop_on_blank, actual_text_length, error);

  PROCEND compute_scl_real;

?? TITLE := '  compute_string_size', EJECT ??

  PROCEDURE [INLINE] compute_string_size
    (VAR value: clt$value);

    WHILE value.str.size > 0 DO
      IF value.str.value (value.str.size) = ' ' THEN
        value.str.size := value.str.size - 1;
      ELSE
        RETURN;
      IFEND;
    WHILEND;

  PROCEND compute_string_size;

?? TITLE := '  convert_to_form_name', EJECT ??

  PROCEDURE [INLINE] convert_to_form_name
    (    name: ost$name;
         form_processor: fdt$form_processor;
     VAR form_name: ost$name);

{ Allow forms with a COBOL processor to be used under the SCL interface.
{ The SCL interface allows users to quickly prototype applications.
{ Convert the SCL name to the name used on the form.

    IF form_processor = fdc$cobol_processor THEN
      #TRANSLATE (fdv$to_cobol, name, form_name);
    ELSE
      form_name := name;
    IFEND;

  PROCEND convert_to_form_name;

?? TITLE := '  convert_to_scl_name', EJECT ??

  PROCEDURE [INLINE] convert_to_scl_name
    (    name: ost$name;
         form_processor: fdt$form_processor;
     VAR scl_name: ost$name);


{ Allow forms with a COBOL processor to be used under the SCL interface.
{ The SCL interface allows users to quickly prototype applications.
{ Convert the name used on the form to an SCL name.

    IF form_processor = fdc$cobol_processor THEN
      #TRANSLATE (fdv$to_scl, name, scl_name);
    ELSE
      scl_name := name;
    IFEND;

  PROCEND convert_to_scl_name;

?? TITLE := '  create_form_variable', EJECT ??

  PROCEDURE create_form_variable
    (    p_form_information: ^fdt$form_information;
     VAR status: ost$status);

    VAR
      data_value: clt$data_value,
      field_index: integer,
      form_identifier: fdt$form_identifier,
      form_name: ost$name,
      form_processor: fdt$form_processor,
      get_form_attributes: array [1 .. 3] of fdt$get_form_attribute,
      number_of_fields: integer,
      number_tables: fdt$number_tables,
      number_variables: fdt$number_variables,
      occurrence: fdt$occurrence,
      p_array_values: ^array [ * ] of clt$data_value,
      p_data_value: ^clt$data_value,
      p_form_field_values: ^array [1 .. * ] of clt$field_value,
      p_table_data_values: ^array [1 .. * ] of clt$data_value,
      p_table_field_values: ^array [1 .. * ] of clt$field_value,
      p_table_array_values: ^array [1 .. * ] of ^clt$data_value,
      p_table_information: ^fdt$table_information,
      p_table_names: ^fdt$form_names,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable_information,
      p_tables: ^array [1 .. * ] of fdt$table_information,
      p_type_specification: ^clt$type_specification,
      p_variable_information: ^fdt$variable_information,
      p_variable_names: ^fdt$form_names,
      p_variables: ^array [1 .. * ] of fdt$variable_information,
      p_work_area: ^clt$work_area,
      program_data_type: fdt$program_data_type,
      scl_variable_name: ost$name,
      sequence_length: integer,
      table_index: fdt$table_index,
      table_variable_index: fdt$table_index,
      table_type_specification_size: clt$type_specification_size,
      total_sequence_length: integer,
      variable_index: fdt$variable_index,
      variable_length: integer,
      variable_name: ost$name,
      variable_number: fdt$number_names;

    form_identifier := p_form_information^.form_identifier;
    form_name := p_form_information^.name;

{ Get the information about variables and tables held by Screen Formatting.
{ This allows generation of SCL variables of the proper data type and length.

    get_form_attributes [1].key := fdc$get_number_variables;
    get_form_attributes [2].key := fdc$get_form_processor;
    get_form_attributes [3].key := fdc$get_number_tables;
    fdp$get_form_attributes (form_identifier, get_form_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    form_processor := get_form_attributes [2].form_processor;
    fdv$p_form_list^ [fdv$form_index].form_processor := form_processor;
    number_variables := get_form_attributes [1].number_variables;
    number_tables := get_form_attributes [3].number_tables;
    IF number_variables = 0 THEN
      RETURN;
    IFEND;

{ Get the attributes of the form variables from Screen Formatting and
{ store them for latter processing of the form.

    store_variables (form_identifier, number_variables, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_variables := fdv$p_form_list^ [fdv$form_index].p_variables;
    IF number_tables <> 0 THEN

{ Get the attributes of the form tables from Screen Formatting and
{ store them for latter processing of the form.

      store_tables (form_identifier, number_tables, p_variables, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    RESET fdv$work_area.sequence_pointer;
    total_sequence_length := #SIZE (fdv$work_area.sequence_pointer^);
    number_of_fields := number_tables;
    FOR variable_index := 1 TO number_variables DO
      IF NOT p_variables^ [variable_index].table_member THEN
        number_of_fields := number_of_fields + 1;
      IFEND;
    FOREND;
    p_form_information^.number_of_fields := number_of_fields;

{ Record  all fields in the form record.  Each table and  each variable that
{ does not belong to a table is a field for the form record.

    NEXT p_form_field_values: [1 .. number_of_fields] IN
          fdv$work_area.sequence_pointer;
    IF p_form_field_values = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier,
            fde$no_space_available, '', status);
      RETURN;
    IFEND;

    field_index := 0;
    data_value.kind := clc$record;
    data_value.field_values := p_form_field_values;
    p_tables := fdv$p_form_list^ [fdv$form_index].p_tables;

    IF p_tables <> NIL THEN

    /process_tables/
      FOR table_index := 1 TO UPPERBOUND (p_tables^) DO
        p_table_information := ^p_tables^ [table_index];
        convert_to_scl_name (p_table_information^.name, form_processor,
              scl_variable_name);
        p_table_variables := p_table_information^.p_table_variables;

{ A table is an array of records.

        NEXT p_data_value IN fdv$work_area.sequence_pointer;
        IF p_data_value = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier,
                fde$no_space_available, '', status);
          RETURN;
        IFEND;

        NEXT p_table_array_values: [1 .. p_table_information^.occurrence] IN
              fdv$work_area.sequence_pointer;
        IF p_table_array_values = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier,
                fde$no_space_available, '', status);
          RETURN;
        IFEND;

        p_data_value^.kind := clc$array;
        p_data_value^.array_value := p_table_array_values;
        field_index := field_index + 1;
        p_form_field_values^ [field_index].name := scl_variable_name;
        p_form_field_values^ [field_index].value := p_data_value;

        NEXT p_table_data_values: [1 .. p_table_information^.occurrence] IN
              fdv$work_area.sequence_pointer;
        IF p_table_data_values = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier,
                fde$no_space_available, '', status);
          RETURN;
        IFEND;

      /process_table_array/
        FOR occurrence := 1 TO p_table_information^.occurrence DO

{ The variables belonging to the table are fields.

          NEXT p_table_field_values: [1 .. UPPERBOUND (p_table_variables^)] IN
                fdv$work_area.sequence_pointer;
          IF p_table_field_values = NIL THEN
            osp$set_status_abnormal (fdc$format_display_identifier,
                  fde$no_space_available, '', status);
            RETURN;
          IFEND;

          p_table_array_values^ [occurrence] :=
                ^p_table_data_values^ [occurrence];
          p_table_data_values^ [occurrence].kind := clc$record;
          p_table_data_values^ [occurrence].field_values :=
                p_table_field_values;

        /process_table_variables/
          FOR table_variable_index := 1 TO UPPERBOUND (p_table_variables^) DO
            p_variable_information := p_table_variables^ [table_variable_index].
                  p_variable_information;
            convert_to_scl_name (p_variable_information^.name, form_processor,
                  scl_variable_name);

            NEXT p_data_value IN fdv$work_area.sequence_pointer;
            IF p_data_value = NIL THEN
              osp$set_status_abnormal (fdc$format_display_identifier,
                    fde$no_space_available, '', status);
              RETURN;
            IFEND;

            p_table_field_values^ [table_variable_index].name :=
                  scl_variable_name;
            p_table_field_values^ [table_variable_index].value := p_data_value;


{ Create the fields of the data_value.  Get the initial value of the
{ variable from Screen Formatting.

            get_data_value (form_identifier, p_variable_information, occurrence,
                  p_data_value^, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND /process_table_variables/;
        FOREND /process_table_array/;
      FOREND /process_tables/;
    IFEND;

{ Process variables that do not belong to a table.
{ Each variable is a field in the form record.

  /process_single_variables/
    FOR variable_index := 1 TO number_variables DO
      IF p_variables^ [variable_index].table_member THEN
        CYCLE /process_single_variables/;
      IFEND;

      convert_to_scl_name (p_variables^ [variable_index].name, form_processor,
            scl_variable_name);
      NEXT p_data_value IN fdv$work_area.sequence_pointer;
      IF p_data_value = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$no_space_available, '', status);
        RETURN;
      IFEND;

      field_index := field_index + 1;
      p_form_field_values^ [field_index].name := scl_variable_name;
      p_form_field_values^ [field_index].value := p_data_value;

{ Create the fields of the data_value.  Get the initial value of the
{ variable from Screen Formatting.

      get_data_value (form_identifier, ^p_variables^ [variable_index], 1,
            p_data_value^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND /process_single_variables/;

    sequence_length := i#current_sequence_position
          (fdv$work_area.sequence_pointer);
    RESET fdv$work_area.sequence_pointer;
    NEXT p_work_area: [[REP sequence_length OF cell]] IN
          fdv$work_area.sequence_pointer;
    NEXT p_work_area: [[REP (total_sequence_length - sequence_length) OF
          cell]] IN fdv$work_area.sequence_pointer;
    RESET p_work_area;
    clp$derive_type_spec_from_value (^data_value, p_work_area,
          p_type_specification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$create_procedure_variable (form_name, clc$local_scope, clc$read_write,
          clc$immediate_evaluation, p_type_specification, ^data_value, status);
    fdv$p_form_list^ [fdv$form_index].form_variable_created := status.normal;
    IF NOT status.normal THEN
      IF status.condition = cle$var_already_created THEN
        status.normal := TRUE;
        IF fdv$variable_evaluation = fdc$automatic THEN
          replace_form_variable (^fdv$p_form_list^ [fdv$form_index], status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND create_form_variable;

?? TITLE := '  create_single_variables', EJECT ??

  PROCEDURE create_single_variables
    (    form_identifier: fdt$form_identifier;
     VAR status: ost$status);

    VAR
      data_value: clt$data_value,
      form_processor: fdt$form_processor,
      get_form_attributes: array [1 .. 2] of fdt$get_form_attribute,
      number_of_occurrences: fdt$occurrence,
      number_variables: fdt$number_variables,
      occurrence: fdt$occurrence,
      p_array_values: ^array [1 .. * ] of ^clt$data_value,
      p_data_values: ^array [1 .. * ] of clt$data_value,
      p_form_information: ^fdt$form_information,
      p_type_specification: ^clt$type_specification,
      p_variable_information: ^fdt$variable_information,
      p_variables: ^array [1 .. * ] of fdt$variable_information,
      p_work_area: ^clt$work_area,
      scl_variable_name: ost$name,
      scl_variable_reference: fdt$scl_variable_reference,
      sequence_length: integer,
      string_length: integer,
      total_sequence_length: integer,
      variable_index: fdt$variable_index,
      variable_status: fdt$variable_status;

{ Get information about form variables from Screen Formatting.
{ This information gives the name, data type and data length for all variables.

    get_form_attributes [1].key := fdc$get_number_variables;
    get_form_attributes [2].key := fdc$get_form_processor;
    fdp$get_form_attributes (form_identifier, get_form_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    form_processor := get_form_attributes [2].form_processor;
    p_form_information := ^fdv$p_form_list^ [fdv$form_index];
    p_form_information^.form_processor := form_processor;
    number_variables := get_form_attributes [1].number_variables;
    IF number_variables = 0 THEN
      RETURN;
    IFEND;

{ Get the attributes of the form variables from Screen Formatting and
{ store them for latter processing of the form. These variables do not
{ belong to a table.

    store_variables (form_identifier, number_variables, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_variables := p_form_information^.p_variables;

  /create_variable/
    FOR variable_index := 1 TO UPPERBOUND (p_variables^) DO
      p_variable_information := ^p_form_information^.
            p_variables^ [variable_index];

      RESET fdv$work_area.sequence_pointer;
      total_sequence_length := #SIZE (fdv$work_area.sequence_pointer^);
      IF p_variable_information^.occurrence < 2 THEN

{ Create a variable with no indexing.

        get_data_value (form_identifier, p_variable_information, 1, data_value,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSE { An array type specification is required. }
        NEXT p_array_values: [1 .. p_variable_information^.occurrence] IN
              fdv$work_area.sequence_pointer;
        IF p_array_values = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier,
                fde$no_space_available, '', status);
          RETURN;
        IFEND;

        NEXT p_data_values: [1 .. p_variable_information^.occurrence] IN
              fdv$work_area.sequence_pointer;
        IF p_data_values = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier,
                fde$no_space_available, '', status);
          RETURN;
        IFEND;

        data_value.kind := clc$array;
        data_value.array_value := p_array_values;

        FOR occurrence := 1 TO p_variable_information^.occurrence DO
          get_data_value (form_identifier, p_variable_information, occurrence,
                p_data_values^ [occurrence], status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          p_array_values^ [occurrence] := ^p_data_values^ [occurrence];
        FOREND;
      IFEND;

      convert_to_scl_name (p_variable_information^.name, form_processor,
            scl_variable_name);
      sequence_length := i#current_sequence_position
            (fdv$work_area.sequence_pointer);
      RESET fdv$work_area.sequence_pointer;
      IF sequence_length > 0 THEN
        NEXT p_work_area: [[REP sequence_length OF cell]] IN
              fdv$work_area.sequence_pointer;
      IFEND;
      NEXT p_work_area: [[REP (total_sequence_length -
            i#current_sequence_position (fdv$work_area.sequence_pointer)) OF
            cell]] IN fdv$work_area.sequence_pointer;
      RESET p_work_area;
      clp$derive_type_spec_from_value (^data_value, p_work_area,
            p_type_specification, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$create_procedure_variable (scl_variable_name, clc$local_scope,
            clc$read_write, clc$immediate_evaluation, p_type_specification,
            ^data_value, status);
      p_variable_information^.created := status.normal;
      IF NOT status.normal THEN
        IF status.condition = cle$var_already_created THEN
          status.normal := TRUE;
          IF fdv$variable_evaluation = fdc$automatic THEN

{ Transfer value of SCL variable to Screen Formatting.

            replace_single_variable (p_variable_information, form_identifier,
                  form_processor, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    FOREND /create_variable/;

  PROCEND create_single_variables;

?? TITLE := '  delete_form_from_list', EJECT ??

  PROCEDURE delete_form_from_list
    (    form_name: ost$name);

    VAR
      form_index: fdt$form_identifier,
      local_status: ost$status,
      p_form_information: ^fdt$form_information,
      p_variables: ^array [1 .. * ] of fdt$variable_information,
      table_index: fdt$table_index,
      variable_index: fdt$variable_index,
      variable_name: ost$name;

    FOR form_index := 1 TO fdv$high_form_index DO
      p_form_information := ^fdv$p_form_list^ [form_index];
      IF form_name = p_form_information^.name THEN
        p_form_information^.name := ' ';
        p_form_information^.added := FALSE;
        p_form_information^.push_index := 0;
        p_variables := p_form_information^.p_variables;

        IF p_variables <> NIL THEN
          IF p_form_information^.form_variable_created THEN
            clp$delete_variable (form_name, local_status);
            IF p_form_information^.p_tables <> NIL THEN
              FOR table_index := LOWERBOUND (p_form_information^.p_tables^)
                    TO UPPERBOUND (p_form_information^.p_tables^) DO
                IF p_form_information^.p_tables^ [table_index].
                      p_table_variables <> NIL THEN
                  FREE p_form_information^.p_tables^ [table_index].
                        p_table_variables;
                IFEND;
              FOREND;
              FREE p_form_information^.p_tables;
            IFEND;
            FREE p_form_information^.p_variables;

          ELSE { Single variables were created. Delete each variable. }

            FOR variable_index := 1 TO UPPERBOUND (p_variables^) DO
              IF p_variables^ [variable_index].created THEN
                convert_to_scl_name (p_variables^ [variable_index].name,
                      p_form_information^.form_processor, variable_name);
                clp$delete_variable (variable_name, local_status);
              IFEND;
            FOREND;

            FREE p_form_information^.p_variables;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND delete_form_from_list;

?? TITLE := '  find_form_name', EJECT ??

  PROCEDURE [INLINE] find_variable_name
    (    name: ost$name;
     VAR p_variable_information: ^fdt$variable_information;
     VAR status: ost$status);

    VAR
      p_variables: ^array [1 .. * ] of fdt$variable_information,
      variable_index: fdt$variable_index;

    p_variables := fdv$p_form_list^ [fdv$form_index].p_variables;
    IF p_variables <> NIL THEN
      FOR variable_index := 1 TO UPPERBOUND (p_variables^) DO
        p_variable_information := ^p_variables^ [variable_index];
        IF name = p_variable_information^.name THEN
          status.normal := TRUE;
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    osp$set_status_abnormal (fdc$format_display_identifier,
          fde$unknown_variable_name, '', status);
    osp$append_status_parameter (osc$status_parameter_delimiter, name, status);

  PROCEND find_variable_name;

?? TITLE := '  get_data_value', EJECT ??

  PROCEDURE get_data_value
    (    form_identifier: fdt$form_identifier;
         p_variable_information: ^fdt$variable_information;
         occurrence: fdt$occurrence;
     VAR data_value: clt$data_value;
     VAR status: ost$status);

    VAR
      form_name: ost$name,
      ignore_status: ost$status,
      p_string_value: ^string ( * ),
      real_value: real,
      variable_status: fdt$variable_status;

{ Get value of variable from Screen Formatting.

    status.normal := TRUE;
    CASE p_variable_information^.program_data_type OF

    = fdc$program_character_type, fdc$program_upper_case_type =
      NEXT p_string_value: [p_variable_information^.variable_length] IN
            fdv$work_area.sequence_pointer;
      IF p_string_value = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$no_space_available, '', status);
        RETURN;
      IFEND;

      fdp$get_string_variable (form_identifier, p_variable_information^.name,
            occurrence, p_string_value^, variable_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF variable_status <> fdc$no_error THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
        RETURN;
      IFEND;

      data_value.kind := clc$string;
      data_value.string_value := p_string_value;

    = fdc$program_integer_type =
      fdp$get_integer_variable (form_identifier, p_variable_information^.name,
            occurrence, data_value.integer_value.value, variable_status,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF variable_status <> fdc$no_error THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
        RETURN;
      IFEND;

      data_value.kind := clc$integer;
      data_value.integer_value.radix := 10;
      data_value.integer_value.radix_specified := FALSE;

    = fdc$program_real_type =
      compute_scl_real(form_identifier, p_variable_information, occurrence,
            data_value, status);

    ELSE {fdc$program_cobol_type}
      osp$set_status_abnormal (fdc$format_display_identifier, fde$cobol_invalid_manage_form,
            p_variable_information^.name, status);
      get_form_name (form_identifier, form_name, ignore_status);
      osp$append_status_parameter (osc$status_parameter_delimiter, form_name, status);
    CASEND;

  PROCEND get_data_value;

?? TITLE := '  get_form_identifier', EJECT ??

  PROCEDURE [INLINE] get_form_identifier
    (    form_name: ost$name;
     VAR form_identifier: fdt$form_identifier;
     VAR status: ost$status);

    VAR
      form_index: fdt$form_identifier;

    FOR form_index := 1 TO fdv$high_form_index DO
      IF form_name = fdv$p_form_list^ [form_index].name THEN
        form_identifier := fdv$p_form_list^ [form_index].form_identifier;
        fdv$form_index := form_index;
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal (fdc$format_display_identifier, fde$form_closed,
          form_name, status);

  PROCEND get_form_identifier;

?? TITLE := '  get_form_name', EJECT ??

  PROCEDURE [INLINE] get_form_name
    (    form_identifier: fdt$form_identifier;
     VAR form_name: ost$name;
     VAR status: ost$status);

    VAR
      form_index: fdt$form_identifier;

    FOR form_index := 1 TO fdv$high_form_index DO
      IF form_identifier = fdv$p_form_list^ [form_index].form_identifier THEN
        form_name := fdv$p_form_list^ [form_index].name;
        fdv$form_index := form_index;
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal (fdc$format_display_identifier, fde$form_closed,
          form_name, status);

  PROCEND get_form_name;

?? TITLE := '  get_form_variable', EJECT ??

  PROCEDURE get_form_variable
    (    p_form_information: ^fdt$form_information;
     VAR status: ost$status);

    VAR
      data_value: clt$data_value,
      field_index: integer,
      form_identifier: fdt$form_identifier,
      form_processor: fdt$form_processor,
      occurrence: fdt$occurrence,
      p_array_values: ^array [ * ] of clt$data_value,
      p_data_value: ^clt$data_value,
      p_form_field_values: ^array [1 .. * ] of clt$field_value,
      p_table_data_values: ^array [1 .. * ] of clt$data_value,
      p_table_field_values: ^array [1 .. * ] of clt$field_value,
      p_table_array_values: ^array [1 .. * ] of ^clt$data_value,
      p_table_information: ^fdt$table_information,
      p_table_names: ^fdt$form_names,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable_information,
      p_tables: ^array [1 .. * ] of fdt$table_information,
      p_type_specification: ^clt$type_specification,
      p_variable_information: ^fdt$variable_information,
      p_variable_names: ^fdt$form_names,
      p_variables: ^array [1 .. * ] of fdt$variable_information,
      p_work_area: ^clt$work_area,
      program_data_type: fdt$program_data_type,
      scl_variable_name: ost$name,
      sequence_length: integer,
      string_length: integer,
      string_value: string (256),
      table_index: fdt$table_index,
      table_variable_index: fdt$table_index,
      table_type_specification_size: clt$type_specification_size,
      total_sequence_length: integer,
      variable_index: fdt$variable_index,
      variable_length: integer,
      variable_name: ost$name,
      variable_number: fdt$number_names;

{ Transfer Screen Formatting variables to SCL form record.

    RESET fdv$work_area.sequence_pointer;
    total_sequence_length := #SIZE (fdv$work_area.sequence_pointer^);

{ Get all fields in the form record.  Each table and  each variable that
{ does not belong to a table is a field for the form record.

    NEXT p_form_field_values: [1 .. p_form_information^.number_of_fields] IN
          fdv$work_area.sequence_pointer;
    IF p_form_field_values = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier,
            fde$no_space_available, '', status);
      RETURN;
    IFEND;

    field_index := 0;
    data_value.kind := clc$record;
    data_value.field_values := p_form_field_values;
    p_tables := p_form_information^.p_tables;
    p_variables := p_form_information^.p_variables;
    form_identifier := p_form_information^.form_identifier;
    form_processor := p_form_information^.form_processor;

    IF p_tables <> NIL THEN

    /process_tables/
      FOR table_index := 1 TO UPPERBOUND (p_tables^) DO
        p_table_information := ^p_tables^ [table_index];
        convert_to_scl_name (p_table_information^.name, form_processor,
              scl_variable_name);
        p_table_variables := p_table_information^.p_table_variables;

{ A table is an array of records.

        NEXT p_data_value IN fdv$work_area.sequence_pointer;
        IF p_data_value = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier,
                fde$no_space_available, '', status);
          RETURN;
        IFEND;

        NEXT p_table_array_values: [1 .. p_table_information^.occurrence] IN
              fdv$work_area.sequence_pointer;
        IF p_table_array_values = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier,
                fde$no_space_available, '', status);
          RETURN;
        IFEND;

        p_data_value^.kind := clc$array;
        p_data_value^.array_value := p_table_array_values;
        field_index := field_index + 1;
        p_form_field_values^ [field_index].name := scl_variable_name;
        p_form_field_values^ [field_index].value := p_data_value;

        NEXT p_table_data_values: [1 .. p_table_information^.occurrence] IN
              fdv$work_area.sequence_pointer;
        IF p_table_data_values = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier,
                fde$no_space_available, '', status);
          RETURN;
        IFEND;

      /process_table_array/
        FOR occurrence := 1 TO p_table_information^.occurrence DO

{ The variables belonging to the table are fields.

          NEXT p_table_field_values: [1 .. UPPERBOUND (p_table_variables^)] IN
                fdv$work_area.sequence_pointer;
          IF p_table_field_values = NIL THEN
            osp$set_status_abnormal (fdc$format_display_identifier,
                  fde$no_space_available, '', status);
            RETURN;
          IFEND;

          p_table_array_values^ [occurrence] :=
                ^p_table_data_values^ [occurrence];
          p_table_data_values^ [occurrence].kind := clc$record;
          p_table_data_values^ [occurrence].field_values :=
                p_table_field_values;

        /process_table_variables/
          FOR table_variable_index := 1 TO UPPERBOUND (p_table_variables^) DO
            p_variable_information := p_table_variables^ [table_variable_index].
                  p_variable_information;
            convert_to_scl_name (p_variable_information^.name, form_processor,
                  scl_variable_name);

            NEXT p_data_value IN fdv$work_area.sequence_pointer;
            IF p_data_value = NIL THEN
              osp$set_status_abnormal (fdc$format_display_identifier,
                    fde$no_space_available, '', status);
              RETURN;
            IFEND;

            p_table_field_values^ [table_variable_index].name :=
                  scl_variable_name;
            p_table_field_values^ [table_variable_index].value := p_data_value;


{ Get the current value of the data value from Screen Formatting.

            get_data_value (form_identifier, p_variable_information, occurrence,
                  p_data_value^, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND /process_table_variables/;
        FOREND /process_table_array/;
      FOREND /process_tables/;
    IFEND;

{ Process variables that do not belong to a table.
{ Each variable is a field in the form record.

  /process_single_variables/
    FOR variable_index := 1 TO UPPERBOUND (p_variables^) DO
      IF p_variables^ [variable_index].table_member THEN
        CYCLE /process_single_variables/;
      IFEND;

      convert_to_scl_name (p_variables^ [variable_index].name, form_processor,
            scl_variable_name);
      NEXT p_data_value IN fdv$work_area.sequence_pointer;
      IF p_data_value = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$no_space_available, '', status);
        RETURN;
      IFEND;

      field_index := field_index + 1;
      p_form_field_values^ [field_index].name := scl_variable_name;
      p_form_field_values^ [field_index].value := p_data_value;

{ Get the data value from Screen Formatting.

      get_data_value (form_identifier, ^p_variables^ [variable_index], 1,
            p_data_value^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND /process_single_variables/;

    sequence_length := i#current_sequence_position
          (fdv$work_area.sequence_pointer);
    RESET fdv$work_area.sequence_pointer;
    NEXT p_work_area: [[REP sequence_length OF cell]] IN
          fdv$work_area.sequence_pointer;
    NEXT p_work_area: [[REP (total_sequence_length - sequence_length) OF
          cell]] IN fdv$work_area.sequence_pointer;
    RESET p_work_area;
    clp$change_variable (p_form_information^.name, ^data_value, status);
  PROCEND get_form_variable;

?? TITLE := '  get_single_variable', EJECT ??

  PROCEDURE get_single_variable
    (    p_variable_information: ^fdt$variable_information;
         number_of_occurrences: fdt$occurrence;
         form_identifier: fdt$form_identifier;
         form_processor: fdt$form_processor;
     VAR status: ost$status);

    VAR
      data_value: clt$data_value,
      occurrence: fdt$occurrence,
      p_array_values: ^array [1 .. * ] of ^clt$data_value,
      p_data_values: ^array [1 .. * ] of clt$data_value,
      p_type_specification: ^clt$type_specification,
      p_work_area: ^clt$work_area,
      scl_variable_name: ost$name,
      scl_variable_reference: fdt$scl_variable_reference,
      sequence_length: integer,
      total_sequence_length: integer,
      variable_status: fdt$variable_status;

{ Transfer a variable from Screen Formatting to SCL.

    RESET fdv$work_area.sequence_pointer;
    total_sequence_length := #SIZE (fdv$work_area.sequence_pointer^);
    IF number_of_occurrences < 2 THEN

{ The variable has only 1 occurrence. Get value of variable from
{ Screen Formatting.

      get_data_value (form_identifier, p_variable_information, 1, data_value,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    ELSE

{ The variable is an array. Get the value of each occurrence of the variable.

      NEXT p_array_values: [1 .. number_of_occurrences] IN
            fdv$work_area.sequence_pointer;
      IF p_array_values = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$no_space_available, '', status);
        RETURN;
      IFEND;

      NEXT p_data_values: [1 .. number_of_occurrences] IN
            fdv$work_area.sequence_pointer;
      IF p_data_values = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$no_space_available, '', status);
        RETURN;
      IFEND;

      data_value.kind := clc$array;
      data_value.array_value := p_array_values;

      FOR occurrence := 1 TO number_of_occurrences DO
        get_data_value (form_identifier, p_variable_information, occurrence,
              p_data_values^ [occurrence], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        p_array_values^ [occurrence] := ^p_data_values^ [occurrence];
      FOREND;
    IFEND;

    convert_to_scl_name (p_variable_information^.name, form_processor,
          scl_variable_name);
    sequence_length := i#current_sequence_position
          (fdv$work_area.sequence_pointer);
    RESET fdv$work_area.sequence_pointer;
    IF sequence_length > 0 THEN
      NEXT p_work_area: [[REP sequence_length OF cell]] IN
            fdv$work_area.sequence_pointer;
    IFEND;
    NEXT p_work_area: [[REP (total_sequence_length -
          i#current_sequence_position (fdv$work_area.sequence_pointer)) OF
          cell]] IN fdv$work_area.sequence_pointer;
    RESET p_work_area;
    clp$change_variable (scl_variable_name, ^data_value, status);

  PROCEND get_single_variable;

?? TITLE := '  get_variables', EJECT ??

  PROCEDURE get_variables
    (VAR status: ost$status);

    VAR
      form_identifier: fdt$form_identifier,
      form_index: fdt$form_identifier,
      form_processor: fdt$form_processor,
      p_form_information: ^fdt$form_information,
      p_variable_information: ^fdt$variable_information,
      p_variables: ^array [1 .. * ] of fdt$variable_information,
      variable_index: fdt$variable_index;

  /update_active_forms/
    FOR form_index := 1 TO fdv$high_form_index DO
      p_form_information := ^fdv$p_form_list^ [form_index];
      IF p_form_information^.added AND (p_form_information^.push_index = 0) AND
            (p_form_information^.p_variables <> NIL) THEN
        form_identifier := p_form_information^.form_identifier;
        IF fdv$variable_creation = fdc$form_variable THEN

{ Transfer Screen Formatting variables to SCL form variable.

          get_form_variable (p_form_information, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE

{ Transfer Screen Formatting variables to SCL single variables.

          p_variables := p_form_information^.p_variables;
          form_identifier := p_form_information^.form_identifier;
          form_processor := p_form_information^.form_processor;
          FOR variable_index := 1 TO UPPERBOUND (p_variables^) DO
            p_variable_information := ^p_variables^ [variable_index];
            get_single_variable (p_variable_information,
                  p_variable_information^.occurrence, form_identifier,
                  form_processor, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND;
        IFEND;
      IFEND;
    FOREND /update_active_forms/;

  PROCEND get_variables;

?? TITLE := '  replace_data_value', EJECT ??

  PROCEDURE replace_data_value
    (    form_identifier: fdt$form_identifier;
         variable_name: ost$name;
         occurrence: fdt$occurrence;
     VAR data_value: clt$data_value;
     VAR status: ost$status);

    VAR
      p_string_value: ^string ( * ),
      real_value: real,
      variable_status: fdt$variable_status;

    status.normal := TRUE;
    CASE data_value.kind OF

    = clc$string =
      fdp$replace_string_variable (form_identifier, variable_name, occurrence,
            data_value.string_value^, variable_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF variable_status <> fdc$no_error THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
        RETURN;
      IFEND;

    = clc$integer =
      fdp$replace_integer_variable (form_identifier, variable_name, occurrence,
            data_value.integer_value.value, variable_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF variable_status <> fdc$no_error THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
        RETURN;
      IFEND;

    = clc$real =

{ SCL uses double precision real numbers while  CYBIL and Screen Formatting
{ use single precision real numbers.  Transfer only the most significant
{ part of the double precision number to Screen Formatting.

      real_value := $REAL (data_value.real_value.value);
      fdp$replace_real_variable (form_identifier, variable_name, occurrence,
            real_value, variable_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF variable_status <> fdc$no_error THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
        RETURN;
      IFEND;

    ELSE
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
            'invalid program_data_type', status);
    CASEND;

  PROCEND replace_data_value;

?? TITLE := '  replace_form_variable', EJECT ??

  PROCEDURE replace_form_variable
    (    p_form_information: ^fdt$form_information;
     VAR status: ost$status);

    VAR
      data_access_mode: clt$data_access_mode,
      data_value: clt$data_value,
      expression_eval_method: clt$expression_eval_method,
      field_index: integer,
      form_identifier: fdt$form_identifier,
      form_processor: fdt$form_processor,
      form_variable_name: ost$name,
      occurrence: fdt$occurrence,
      p_data_value: ^clt$data_value,
      p_form_field_values: ^array [1 .. * ] of clt$field_value,
      p_table_array_values: ^array [ * ] of ^clt$data_value,
      p_table_data_value: ^clt$data_value,
      p_table_field_values: ^array [1 .. * ] of clt$field_value,
      p_type_specification: ^clt$type_specification,
      table_variable_index: fdt$table_variable_index,
      variable_class: clt$variable_class;

{ Get SCL form record.

    RESET fdv$work_area.sequence_pointer;
    clp$get_variable (p_form_information^.name, fdv$work_area.sequence_pointer,
          variable_class, data_access_mode, expression_eval_method,
          p_type_specification, p_data_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_data_value = NIL THEN
      RETURN;
    IFEND;

    form_processor := p_form_information^.form_processor;
    form_identifier := p_form_information^.form_identifier;
    IF p_data_value^.kind <> clc$record THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
            'SCL returned unexpected data type', status);
      RETURN;
    IFEND;

{ Transfer values of record fields to Screen Formatting.

    p_form_field_values := p_data_value^.field_values;

  /process_form_fields/
    FOR field_index := LOWERBOUND (p_form_field_values^)
          TO UPPERBOUND (p_form_field_values^) DO
      p_data_value := p_form_field_values^ [field_index].value;
      CASE p_data_value^.kind OF

      = clc$string, clc$real, clc$integer =
        convert_to_form_name (p_form_field_values^ [field_index].name,
              form_processor, form_variable_name);
        replace_data_value (form_identifier, form_variable_name, 1,
              p_data_value^, status);

      = clc$array =

{ The field is a Screen Formatting table.
{ A Screen Formatting table is an array of records.  Each record has
{ one or more fields.

      /process_table_array/
        FOR occurrence := LOWERBOUND (p_data_value^.array_value^)
              TO UPPERBOUND (p_data_value^.array_value^) DO
          p_table_array_values := p_data_value^.array_value;
          p_table_data_value := p_table_array_values^ [occurrence];
          p_table_field_values := p_table_data_value^.field_values;

        /process_table_fields/
          FOR table_variable_index := LOWERBOUND (p_table_field_values^)
                TO UPPERBOUND (p_table_field_values^) DO

{ Convert the SCL name for a field to the name used by the processor of the
{ form.  This allows COBOL forms to be prototyped using SCL.

            convert_to_form_name (p_table_field_values^ [table_variable_index].name,
                  form_processor, form_variable_name);
            replace_data_value (form_identifier, form_variable_name, occurrence,
                  p_table_field_values^ [table_variable_index].value^, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND /process_table_fields/;
        FOREND /process_table_array/;

      ELSE
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$system_error, 'SCL returned unexpected data type', status);
        RETURN;

      CASEND;
    FOREND /process_form_fields/;
  PROCEND replace_form_variable;

?? TITLE := '  replace_single_variable', EJECT ??

  PROCEDURE replace_single_variable
    (    p_variable_information: ^fdt$variable_information;
         form_identifier: fdt$form_identifier;
         form_processor: fdt$form_processor;
     VAR status: ost$status);

    VAR
      data_access_mode: clt$data_access_mode,
      expression_eval_method: clt$expression_eval_method,
      occurrence: fdt$occurrence,
      p_array_data_value: ^clt$data_value,
      p_data_value: ^clt$data_value,
      p_type_specification: ^clt$type_specification,
      scl_variable_name: ost$name,
      variable_class: clt$variable_class;

    RESET fdv$work_area.sequence_pointer;

{ Use an SCL name rather than the form name for a variable.
{ This allows COBOL forms to be protyped through SCL.

    convert_to_scl_name (p_variable_information^.name, form_processor,
          scl_variable_name);

{ Get value of SCL variable and transfer it to Screen Formatting.

    clp$get_variable (scl_variable_name, fdv$work_area.sequence_pointer,
          variable_class, data_access_mode, expression_eval_method,
          p_type_specification, p_data_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_data_value = NIL THEN
      RETURN;
    IFEND;

    IF p_data_value^.kind <> clc$array THEN

{ Process a single occurrence of a variable.

      replace_data_value (form_identifier, p_variable_information^.name, 1,
            p_data_value^, status);
      RETURN;
    IFEND;

{ Process a variable that has more than one occurrence.

  /process_next_occurrence/
    FOR occurrence := LOWERBOUND (p_data_value^.array_value^)
          TO UPPERBOUND (p_data_value^.array_value^) DO
      p_array_data_value := p_data_value^.array_value^ [occurrence];
      replace_data_value (form_identifier, p_variable_information^.name,
            occurrence, p_array_data_value^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND /process_next_occurrence/;
  PROCEND replace_single_variable;

?? TITLE := '  replace_variables', EJECT ??

  PROCEDURE replace_variables
    (VAR status: ost$status);

    VAR
      form_identifier: fdt$form_identifier,
      form_index: fdt$form_identifier,
      form_processor: fdt$form_processor,
      p_form_information: ^fdt$form_information,
      p_variable_information: ^fdt$variable_information,
      p_variables: ^array [1 .. * ] of fdt$variable_information,
      variable_index: fdt$variable_index;

  /process_active_forms/
    FOR form_index := 1 TO fdv$high_form_index DO
      p_form_information := ^fdv$p_form_list^ [form_index];
      IF p_form_information^.added AND (p_form_information^.push_index = 0) AND
            (p_form_information^.p_variables <> NIL) THEN
        IF fdv$variable_creation = fdc$form_variable THEN

{ Transfer SCL form variable to Screen Formatting.

          replace_form_variable (p_form_information, status);

        ELSE

{ Transfer SCL single variables to Screen Formatting.

          p_variables := p_form_information^.p_variables;
          form_identifier := p_form_information^.form_identifier;
          form_processor := p_form_information^.form_processor;
          FOR variable_index := 1 TO UPPERBOUND (p_variables^) DO
            p_variable_information := ^p_variables^ [variable_index];
            replace_single_variable (p_variable_information, form_identifier,
                  form_processor, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND;
        IFEND;
      IFEND;
    FOREND /process_active_forms/;

  PROCEND replace_variables;

?? TITLE := '  store_tables', EJECT ??

  PROCEDURE store_tables
    (    form_identifier: fdt$form_identifier;
         number_tables: fdt$number_names;
         p_variables: ^array [1 .. * ] of fdt$variable_information;
     VAR status: ost$status);

    VAR
      get_table_attributes: array [1 .. 3] of fdt$get_table_attribute,
      number_names: fdt$number_names,
      number_table_variables: fdt$number_table_variables,
      p_get_table_attributes: ^array [1 .. * ] of fdt$get_table_attribute,
      p_table_information: ^fdt$table_information,
      p_table_names: ^fdt$form_names,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable_information,
      p_tables: ^array [1 .. * ] of fdt$table_information,
      table_index: fdt$table_index,
      table_name: ost$name,
      table_variable_index: fdt$table_variable_index,
      variable_index: fdt$variable_index;

{ Get the names of tables for the form.

    PUSH p_table_names: [1 .. number_tables];
    IF p_table_names = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier,
            fde$no_space_available, '', status);
      RETURN;
    IFEND;

    fdp$get_form_names (form_identifier, $fdt$name_selections
          [fdc$select_table], p_table_names^, number_names, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE p_tables: [1 .. number_names];
    IF p_tables = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier,
            fde$no_space_available, '', status);
      RETURN;
    IFEND;

    fdv$p_form_list^ [fdv$form_index].p_tables := p_tables;

{ Get information about the variables that belong to each table.

    FOR table_index := 1 TO number_names DO
      get_table_attributes [1].key := fdc$get_number_table_variables;
      get_table_attributes [2].key := fdc$get_stored_occurrence;
      get_table_attributes [3].key := fdc$get_number_table_variables;
      table_name := p_table_names^ [table_index].name;
      fdp$get_table_attributes (form_identifier, table_name,
            get_table_attributes, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      p_tables^ [table_index].name := table_name;
      p_tables^ [table_index].occurrence :=
            get_table_attributes [2].stored_occurrence;
      store_table_variables (form_identifier, table_name,
            get_table_attributes [3].number_table_variables,
            ^p_tables^ [table_index], p_variables, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;
  PROCEND store_tables;

?? TITLE := '  store_table_variables', EJECT ??

  PROCEDURE store_table_variables
    (    form_identifier: fdt$form_identifier;
         table_name: ost$name;
         number_table_variables: fdt$number_table_variables;
         p_table_information: ^fdt$table_information;
         p_variables: ^array [1 .. * ] of fdt$variable_information;
     VAR status: ost$status);

    VAR
      p_get_table_attributes: ^array [1 .. * ] of fdt$get_table_attribute,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable_information,
      p_tables: ^array [1 .. * ] of fdt$table_information,
      table_variable_index: fdt$table_variable_index,
      variable_index: fdt$variable_index;

    ALLOCATE p_table_information^.p_table_variables:
          [1 .. number_table_variables];
    IF p_table_information^.p_table_variables = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier,
            fde$no_space_available, '', status);
      RETURN;
    IFEND;

    FOR table_variable_index := 1 TO number_table_variables DO
      p_table_information^.p_table_variables^ [table_variable_index].
            p_variable_information := NIL;
    FOREND;

{ Get the attributes of tables.  Manage_forms must know the variables
{ associated with a table.

    PUSH p_get_table_attributes: [1 .. number_table_variables];
    IF p_get_table_attributes = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier,
            fde$no_space_available, '', status);
      RETURN;
    IFEND;

    FOR table_variable_index := 1 TO number_table_variables DO
      p_get_table_attributes^ [table_variable_index].key :=
            fdc$get_next_table_variable;
    FOREND;

    fdp$get_table_attributes (form_identifier, table_name,
          p_get_table_attributes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR table_variable_index := 1 TO number_table_variables DO

    /link_variables/
      FOR variable_index := 1 TO UPPERBOUND (p_variables^) DO
        IF (p_variables^ [variable_index].name =
              p_get_table_attributes^ [table_variable_index].variable_name) THEN
          p_table_information^.p_table_variables^ [table_variable_index].
                p_variable_information := ^p_variables^ [variable_index];
          EXIT /link_variables/;
        IFEND;
      FOREND /link_variables/;
    FOREND;
  PROCEND store_table_variables;

?? TITLE := '  store_variables', EJECT ??

  PROCEDURE store_variables
    (    form_identifier: fdt$form_identifier;
         number_variables: fdt$number_variables;
     VAR status: ost$status);

    VAR
      name_selections: fdt$name_selections,
      number_names: fdt$number_names,
      p_variable_information: ^fdt$variable_information,
      p_variable_names: ^fdt$form_names,
      p_variables: ^array [1 .. * ] of fdt$variable_information,
      variable_attributes: array [1 .. 2] of fdt$get_variable_attribute,
      variable_index: fdt$variable_index;

    PUSH p_variable_names: [1 .. number_variables];
    IF p_variable_names = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier,
            fde$no_space_available, '', status);
      RETURN;
    IFEND;

{ Get names of all variables on form.

    name_selections := $fdt$name_selections [fdc$select_variable];
    fdp$get_form_names (form_identifier, name_selections, p_variable_names^,
          number_names, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE fdv$p_form_list^ [fdv$form_index].p_variables: [1 .. number_names];
    p_variables := fdv$p_form_list^ [fdv$form_index].p_variables;
    IF p_variables = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier,
            fde$no_space_available, '', status);
      RETURN;
    IFEND;

{ Get attributes of variables.  Manage_forms will need the variable data type,
{ variable length, and number of occurrences.

    FOR variable_index := 1 TO number_names DO
      p_variable_information := ^p_variables^ [variable_index];
      p_variable_information^.name := p_variable_names^ [variable_index].name;
      variable_attributes [1].key := fdc$get_program_data_type;
      variable_attributes [2].key := fdc$get_variable_length;
      fdp$get_variable_attributes (form_identifier,
            p_variable_information^.name, variable_attributes, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


      p_variable_information^.program_data_type :=
            variable_attributes [1].program_data_type;
      p_variable_information^.variable_length :=
            variable_attributes [2].variable_length;
      fdp$get_number_of_occurrences (form_identifier,
            p_variable_information^.name, p_variable_information^.table_member,
            p_variable_information^.occurrence, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    FOREND;

  PROCEND store_variables;



MODEND fdm$manage_forms;

*DECK DECK=FDM$MESSAGE_FORM EXPAND=TRUE

FDM$MESSAGE_FORM                - panel module        - 11:23:21 11/17/87

*** BEGIN TEXT ENCODED FROM AN OBJECT LIBRARY BY REPLACE_MODULE_SOURCE ***
56312E31020000000027000000240000000100000024060000004B00000023000000010000002346
444D244D4553534147455F464F524D202020202020202020202020202020060000100046444D244D
4553534147455F464F524D2020202020202020202020202020200000100000000000000000000000
REPEAT  00000000000001EF
00000000000000000000000000000000000146444D244D4553534147455F464F524D202020202020
202020202020202020060231313A32333A3231000000000231312F31372F38370000000000000000
00001053435245454E20464F524D415454494E472056342E30202020202020202020202020202020
REPEAT  0000000000000005
202020000010B7000004B100000000000004B1000000000000000000000000000000000000000000
00000000000004202020202020202020202020202020202020202020202020202020202020200000
00000000000000000000000000000000000000024002081000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000000000000000000000005000500
0001E70000016300000001000000470000000000020001004D00030146444D244D4553534147455F
464F524D2020202020202020202020202020200000010000034A0000003D000000010000003D0001
00000000000000000000000000000000000000000001000003D1000000DD00000001000000DD0001
00000000000000010003020000000000000000000000000000000000000000000000000000000000
000055535F454E474C49534820202020202020202020202020202020202020202000000000000000
00000000000000000000000000000000000000000000000000202020202020202020202020202020
20202020202020202020202020202020000000000300000100202020202020202020202020202020
202020202020202020202020202020200001000004AE000000030000000100000003000120202020
20202020202020202020202020202020202020202020202020202001000000000000000100000100
004D0002000100000000000000074241434B20202020202020202020202020202020202020202020
20202020204261636B20202020202020202020202020202020202020202020202020202003000000
000000000E4657442020202020202020202020202020202020202020202020202020202046776420
2020202020202020202020202020202020202020202020202020200600000000000000114C415354
2020202020202020202020202020202020202020202020202020204C617374202020202020202020
20202020202020202020202020202020202026000000000000000F424B5720202020202020202020
202020202020202020202020202020202020426B7720202020202020202020202020202020202020
20202020202020202007000000000000001046495253542020202020202020202020202020202020
20202020202020202046697273742020202020202020202020202020202020202020202020202020
270240020010004D4553534147452020202020202020202020202020202020202020202020200001
000300020801000100000387004A01004A480000A6B0202020202020202020202020202020202020
REPEAT  0000000000000005
2020202020202020202020202020202000000000000000014800B04B005000200000B04B025011BD
0000B0470000C9005052B047000079DF000000000000016500000000400000000000024100000162
494E495449414C5F56414C554520202020202020202020202020016A0000034D4553534147452020
202020202020202020202020202020202020202020200002B0490000123801000100000000000100
000100000000010100000000083F01000000B0470003680E0000000000000100B000000000BF0000
B049000015AE4D5FB0490000150000000000000015DC2020B046000094C0595001FFFF0000010001
00000000000000000000000000000000000000000000000000000000000000000000000000000000
REPEAT  000000000000014A
0000000000000000000000000000000000000000000000000000000000000000
*** END OF TEXT ENCODED FROM AN OBJECT LIBRARY BY REPLACE_MODULE_SOURCE ***
*DECK DECK=FDM$MOVE_COBOL_DATA EXPAND=TRUE

?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE fdm$move_cobol_data;
?? NEWTITLE := 'NOS/VE Screen Formatter : Move COBOL data' ??

*copyc fdc$cobol_operations_max
*copyc fdc$decimal_currency_symbol
*copyc fdc$dollar_currency_symbol
*copyc fdc$pound_currency_symbol
*copyc fdc$thousands_currency_symbol
*copyc fde$condition_identifiers
*copyc fdt$cobol_currency_symbols
*copyc fdt$cobol_category
*copyc fdt$cobol_picture_symbols
*copyc fdt$cobol_usage
*copyc fdt$cobol_operation
*copyc fdt$cobol_cr_db_means
*copyc fdt$cobol_description
*copyc fdt$usage
*copyc fdc$maximum_picture_length
*copyc ost$status
*copyc osv$lower_to_upper

*copyc i#move
*copyc osp$append_status_integer
*copyc osp$set_status_abnormal

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

VAR
    fdv$cobol_currency_symbols: [XDCL] fdt$cobol_currency_symbols :=
          [fdc$dollar_currency_symbol, fdc$pound_currency_symbol, fdc$thousands_currency_symbol,
           fdc$decimal_currency_symbol];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] fdp$change_currency_symbols', EJECT ??
*copyc fdh$change_currency_symbols


  PROCEDURE [XDCL] fdp$change_currency_symbols
    (    primary_money_symbol: string (1);
         secondary_money_symbol: string (1);
         thousands_separator_symbol: string (1);
         decimal_symbol: string (1));

    fdv$cobol_currency_symbols.primary_money_symbol := primary_money_symbol (1);
    fdv$cobol_currency_symbols.secondary_money_symbol := secondary_money_symbol (1);
    fdv$cobol_currency_symbols.thousands_separator_symbol := thousands_separator_symbol (1);
    fdv$cobol_currency_symbols.decimal_symbol :=  decimal_symbol (1);

  PROCEND fdp$change_currency_symbols;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] fdp$move_cobol_data', EJECT ??
*copyc fdh$move_cobol_data

  PROCEDURE [XDCL] fdp$move_cobol_data
    (    source: fdt$cobol_description,
         source_address: ^STRING ( * );
         destination: fdt$cobol_description;
         destination_address: ^STRING ( * );
     VAR status: ost$status);

    TYPE
      ch = SET OF CHAR; { to be able to use literals for sets

    CONST
      bytes_for_integer = 8,
      bytes_for_single = 8,
      bytes_for_double = 16,
      item_index_min   = 0,
      item_index_max   = fdc$cobol_item_size_maximum,
      value_conversion_length = fdc$cobol_digits_maximum + 1;

    VAR

{ each loop, set to destination.operation_characters[oi], then scratch

      c: char,

{ destination index into "destination_address^"

      destination_index: item_index_min..item_index_max,
      leading_zero_c: char, { char indicating replacement of leading zeros
      leading_zeros: BOOLEAN, { iff we are suppressing leading zeros
      positive: BOOLEAN, { iff signed number is positive
      skip_leading_separate: BOOLEAN, { whether to skip leading separate sign
      temporary_source: STRING (value_conversion_length),
      ts: fdt$cobol_description, { temporary source description
      ts_address: ^STRING ( * ); { address of temporary source value

?? NEWTITLE :=  'initialize_ts', EJECT ??

    PROCEDURE initialize_ts;

{ Initialize a "temporary source" item as
{ PIC S9(18)V9(18) USAGE DISPLAY SIGN IS LEADING SEPARATE.


      temporary_source := '+000000000000000000000000000000000000';
      ts_address := ^temporary_source;
      ts.sign_index := 1; { Point to the "+"
      ts.sign_separate := TRUE; { SIGN IS SEPARATE
      ts.size := value_conversion_length;
      ts.significant_digits := 18; { 18 digits to left of the decimal point
      ts.number_digits := value_conversion_length - 1;
      ts.cobol_category := fdc$cobol_numeric_signed;
      ts.cobol_usage := fdc$cobol_usage_display; { USAGE IS DISPLAY
      ts.display_cr := FALSE; { Do not cause destination "CR" to be shown
      ts.display_db := FALSE; { Do not cause destination "DB" to be shown
      ts.move_operations := 2; { 2 operations when moving to this item
      ts.cobol_operations [1] := fdc$cobol_separate_sign; { Insert "+" or "-"
      ts.cobol_operations [2] := fdc$cobol_move; { Move 36 digits
      ts.operation_numbers [2] := value_conversion_length - 1;
    PROCEND initialize_ts;

?? OLDTITLE ??
?? NEWTITLE :=  'move_free_form_to_standard', EJECT ??

    PROCEDURE move_free_form_to_standard;

{ Extract value described by "source" into "ts", which is S9(18)V9(18),
{ setting "status"

      CONST
        dest_len = 36, { size of 9(18)V9(18)
        source_len = 255;

      VAR
        dest: STRING (dest_len),
        dest_idx: item_index_min..item_index_max,
        digits: SET OF CHAR,
        done: BOOLEAN,
        found_point: BOOLEAN,
        found_sign: BOOLEAN,
        i: item_index_min..item_index_max,
        ignore_chars: ch,
        legal_chars: ch,
        need_right_paren: BOOLEAN,
        num_fraction_digits: item_index_min..item_index_max,
        num_signif_digits: item_index_min..item_index_max,
        sign_means: fdt$cobol_cr_db_means,
        source_data: STRING (source_len),
        source_idx: item_index_min..item_index_max; {to last-used character

?? NEWTITLE :=  'get_c', EJECT ??

      PROCEDURE get_c
        (VAR c: char;
         VAR done: BOOLEAN);

        c := ' ';
        WHILE (source_idx < source_len) AND (c IN ignore_chars) DO
          source_idx := source_idx + 1;
          c := source_data (source_idx);
        WHILEND;
        IF c = ' ' THEN

{ Must have reached end of source

          done := TRUE; { Tell caller we reached end of source
        ELSEIF (c = '(') OR (c = ')') THEN

{ Any legal use of "(...)" has already been processed,
{ the the "(" and ")" removed from source.
{ Parentheses, when used, must surround all non-spaces.

          osp$set_status_abnormal (
           fdc$format_display_identifier, fde$cobol_nonblk_outside_paren, '',
           status);
          EXIT fdp$move_cobol_data;
        ELSE

{ Have a character within the source

          IF NOT (c IN legal_chars) THEN

{ ?  Is this needed else where?

            IF c = 'E' THEN

{ Scientific notation is not allowed.

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_no_scientific, '',
               status);
              EXIT fdp$move_cobol_data;

            ELSE

{ Only characters produced by numeric-edited may be entered,
{ plus "(" and ")", with lower case accepted.
{ These are digits, space, ".", "+", "-", "CR", "DB", "$",
{ "#", "*", "/", or ",".

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_illegal_char_entered, '',
               status);
              EXIT fdp$move_cobol_data;

            IFEND;
            done := TRUE;
          IFEND
        IFEND { Have a character within the source
      PROCEND get_c;

?? OLDTITLE ??
?? NEWTITLE :=  'handle_sign', EJECT ??

      PROCEDURE handle_sign;

        IF found_sign THEN

{ Have at least two sign symbols.
{ Can have only one sign ("+", "-", "CR", "DB", or "(...)")

          osp$set_status_abnormal (
           fdc$format_display_identifier, fde$cobol_two_signs_entered, '',
           status);
          EXIT fdp$move_cobol_data;

        ELSE

{ Found first sign symbol

          found_sign := TRUE;
          IF (c = '+') OR (c = '-') THEN

{ "+" or "-"

            IF  (source.cr_means = fdc$cobol_cr_set)
             OR (source.db_means = fdc$cobol_db_set) THEN

{ "+" and "-" are not allowed in this field now.
{ Use "CR" or "DB".

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_no_plus_or_minus_now, '',
               status);
              EXIT fdp$move_cobol_data;

            ELSEIF c = '+' THEN
              sign_means := fdc$cobol_positive
            ELSE { c = '-'
              sign_means := fdc$cobol_negative
            IFEND
          ELSEIF c = 'C' THEN
            source_idx := source_idx + 1;
            c := source_data (source_idx);
            IF c <> 'R' THEN

{ "C" must be followed by "R" to form "CR".

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_c_without_r, '', status);
              EXIT fdp$move_cobol_data;

            ELSEIF source.cr_means = fdc$cobol_cr_db_illegal THEN

{ CR and DB are not allowed for this field now.

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_no_cr_or_db_now, '',
               status);
              EXIT fdp$move_cobol_data;

            ELSE
              sign_means := source.cr_means;
            IFEND

{ c was 'C'

          ELSE

{ c = 'D'

            source_idx := source_idx + 1;
            c := source_data (source_idx);
            IF c <> 'B' THEN

{ "D" must be followed by "B" to form "DB".

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_d_without_b, '',
               status);
              EXIT fdp$move_cobol_data;

            ELSEIF source.db_means = fdc$cobol_cr_db_illegal THEN

{ CR and DB are not allowed for this field now.

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_no_cr_or_db_now, '',
               status);
              EXIT fdp$move_cobol_data;

            ELSE
              sign_means := source.db_means;
            IFEND

{ c was 'D'

          IFEND { Found first sign symbol
        IFEND
      PROCEND handle_sign;

?? OLDTITLE, EJECT ??

      IF source.size > source_len THEN

{ A USAGE IS FREE-FORM value cannot be longer than 255 characters.

        osp$set_status_abnormal (
         fdc$format_display_identifier, fde$cobol_usage_size_too_big, '', status);
        EXIT fdp$move_cobol_data;
      IFEND;

      source_data := source_address^;
      initialize_ts;
      dest := ' ';
      dest_idx := 0; { Index to last-filled character in dest

      FOR i := 1 TO source_len DO
        IF (source_data (i) >= 'a') AND (source_data (i) <= 'z') THEN
          source_data (i) :=
           $CHAR ($INTEGER (source_data  (i)) - $INTEGER ('a') + $INTEGER ('A'));
        IFEND
      FOREND { i} ;

      digits := $ch ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'];
      ignore_chars := $ch [' ', fdv$cobol_currency_symbols.thousands_separator_symbol, '/',
             fdv$cobol_currency_symbols.primary_money_symbol,
             fdv$cobol_currency_symbols.secondary_money_symbol, '*'];
      legal_chars := digits + $ch [fdv$cobol_currency_symbols.decimal_symbol, '+', '-',
             'C', 'D', '('];
      found_sign := FALSE;
      found_point := FALSE;
      need_right_paren := FALSE;
      num_signif_digits := 0;
      num_fraction_digits := 0;

{ Check for "(...)"

      done := FALSE;
      need_right_paren := FALSE;
      source_idx := 1;

      WHILE (source_idx < source_len) AND (source_data (source_idx) = ' ') DO
        source_idx := source_idx + 1;
      WHILEND;

      c := source_data (source_idx);
      IF c = '(' THEN
        source_data (source_idx) := ' '; { Remove "(" for later processing
        source_idx := source_len;

        WHILE (source_idx > 1) AND (source_data (source_idx) = ' ') DO
          source_idx := source_idx - 1;
        WHILEND;

        c := source_data (source_idx);

        IF c = ')' THEN

{ Have "(...)"

          found_sign := TRUE;
          sign_means := fdc$cobol_negative;
          IF  (source.cr_means = fdc$cobol_cr_set)
           OR (source.db_means = fdc$cobol_db_set) THEN

{ "+", "-", and "(...)" are not allowed in this field now.
{ Use "CR" OR "DB".

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_no_plus_or_minus_now, '',
             status);
            EXIT fdp$move_cobol_data;
            ;
          IFEND { "(...)" conflicts with CR/DB desires} ;
          source_data(source_idx) := ' '; { Now ignore trailing ")"

{ end: Have "(...)"

        ELSE

{ Right-most non-blank was not ")"
{ Parentheses, when used, must surround all non-spaces.

          osp$set_status_abnormal (
           fdc$format_display_identifier, fde$cobol_nonblk_outside_paren, '',
           status);
          EXIT fdp$move_cobol_data;

        IFEND { Right-most non-blank was not ")"} ;
        source_idx := 0; { Index to last-used character from source
        get_c (c, done);

{ end: Found "(..."

      ELSEIF c IN $ch ['+', '-', 'C', 'D', '('] THEN
        handle_sign;
        get_c (c, done);

{ end: c was sign character

      ELSE
        source_idx := 0; { Index to last-used character from source
        get_c (c, done);
      IFEND;

      WHILE NOT done DO
        IF c IN digits THEN
          IF ((num_fraction_digits + num_signif_digits) > 18) THEN

{ Cannot enter more than 18 digit positions.

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_too_many_digits, '', status);
              EXIT fdp$move_cobol_data;
          IFEND;

          dest_idx := dest_idx + 1;
          dest (dest_idx) := c;
          IF found_point THEN
           num_fraction_digits := num_fraction_digits + 1;
          ELSE
           num_signif_digits := num_signif_digits + 1;
          IFEND;

          get_c (c, done);

{ end: c IN digits

        ELSEIF c = fdv$cobol_currency_symbols.decimal_symbol THEN

{ Decimal point

          IF found_point THEN

{ Only a single decimal point may be entered.

            osp$set_status_abnormal (
             fdc$format_display_identifier, fde$cobol_two_points_entered, '',
             status);
            EXIT fdp$move_cobol_data;

          ELSE
            found_point := TRUE;
          IFEND;
          get_c (c, done);

{ end: c = fdv$cobol_currency_symbols.decimal_symbol

        ELSE

{ c must be '+', '-', 'C', or 'D'

          handle_sign;

{ Ensure remainder is spaces

          IF NOT done THEN
            WHILE source_idx < source_len DO

{ Still have more characters to look at

              source_idx := source_idx + 1;
              IF source_data (source_idx) <> ' ' THEN

{ non-blank to right of sign.
{ Only spaces can follow trailing "+", "-", "CR" or "DB".

                osp$set_status_abnormal (
                 fdc$format_display_identifier,fde$cobol_trailing_sign_nonblk, '',
                 status);
                EXIT fdp$move_cobol_data;

              IFEND { non-blank to right of sign
            WHILEND { Had more characters to look at} ;
            done := TRUE; { With terminal sign
          IFEND { was NOT done
        IFEND { c was sign
      WHILEND { NOT done} ;

      FOR i := 1 TO num_signif_digits + num_fraction_digits DO
        ts_address^ (19 - num_signif_digits + i) := dest (i);
      FOREND { i} ;

      IF found_sign THEN
        CASE sign_means OF
        = fdc$cobol_positive =
          ts_address^ (1) := '+';
        = fdc$cobol_negative =
          ts_address^ (1) := '-';
        = fdc$cobol_1_quadrillion =
          ts_address^ (2) := '1';
        = fdc$cobol_2_quadrillion =
          ts_address^ (2) := '2';
        = fdc$cobol_cr_set =
          ts.display_cr := TRUE;
        = fdc$cobol_db_set =
          ts.display_db := TRUE;
        ELSE
        CASEND { sign_means
      IFEND { found_sign

    PROCEND move_free_form_to_standard;

?? OLDTITLE ??
?? NEWTITLE :=  'move_binary_to_standard', EJECT ??

    PROCEDURE move_binary_to_standard { from "source" to "ts"} ;

      TYPE
        kludge_type = record
          case INTEGER of
          = 1 =
            r: real,
          = 2 =
            source: ARRAY [1 .. bytes_for_single] OF CHAR,
          = 3 =
            i: INTEGER,
          casend,
        recend { kludge_type} ;

      VAR
        digit: 0..9,
        integer_value: integer,
        kludge: kludge_type,
        tens: INTEGER,
        tens_index: 2 .. fdc$cobol_digits_maximum,
        test_value: integer,
        tsi: 2 .. value_conversion_length,
        tsi_max: 2 .. value_conversion_length;

{ The method is to first move the "binary" format value to a CYBIL
{ INTEGER.  Fortunately, CYBIL INTEGERs hold 18 decimal digits,
{ which is just what we need. See "move_standard_to_binary" for a
{ discussion of "binary" format.  Then digits are extracted from
{ the CYBIL INTEGER by division and truncation.  These digits are
{ inserted into the standard display value.

{ Set up ts: fdt$cobol_description for S9(18)V9(18) USAGE DISPLAY

      initialize_ts;

{ Handle the sign.

      test_value := 0;
      i#move (source_address, ^test_value, source.size);
      IF test_value < 0 THEN
        ts_address^ (1) := '-';
        test_value := -test_value;
      IFEND;

{ Move the "binary" format value to a CYBIL INTEGER.

      kludge.i := 0;
      i#move (^test_value, ^kludge.source [bytes_for_integer + 1 - source.size],
           source.size);

      integer_value := kludge.i;

{ Prepare the power of ten for the division
{ For example, if source.number_digits=5 we could have a
{ number as large as 99999 and we should start by dividing by 10000.

      tens := 1;
      FOR tens_index := 2 TO source.number_digits DO
        tens := tens * 10;
      FOREND;

{ Deposit all the digits into the destination
{ For example, if source.significant_digits=18 we would start at 2
{ and if source.significant_digits=1  we would start at 19.

      tsi := 20 - source.significant_digits;
      tsi_max := tsi - 1 + source.number_digits;

      /move_to_standard/
       FOR tsi := tsi TO tsi_max DO
          digit := integer_value DIV tens;
          integer_value := integer_value - (digit * tens);
          ts_address^ (tsi) := $CHAR ($INTEGER ('0') + digit);
          tens := tens DIV 10;
        FOREND /move_to_standard/;

    PROCEND move_binary_to_standard;

?? OLDTITLE ??
?? NEWTITLE :=  'move_single_to_standard', EJECT ??

    PROCEDURE move_single_to_standard { from "source" to "ts"} ;


      VAR
        digit: 0..9,
        f: real,
        integer_value: integer,
        negative: BOOLEAN,
        tsi: 2..value_conversion_length;

{ Set up ts: fdt$cobol_description for S9(18)V9(18) USAGE DISPLAY

      initialize_ts;

{ Set up the floating point number

      i#move (source_address, ^f, bytes_for_single);

{ Remember and strip sign

      negative := f < 0.0;
      IF negative THEN
        f := -f;
      IFEND;

{ Divide by 10.0^18, to put all meaningful digits to right of point

{ A simple method would be to divide the floating point value by 10.0^18
{ which puts all meaningful digits to the right of the decimal point,
{ followed by repeatedly multiplying by 10 and getting the most
{ significant digit by truncating.
{ The problem with this approach is that significance can be lost.
{ For example, converting 12.0 to floating point retains the exact
{ mathematical value of 12.0, but dividing by 10^n loses accuracy,
{ since 12 has factors other than 2 or 5.
{ The solution is to convert the INTEGER portion of the number
{ separately from the fraction portion.

{ First ensure that the INTEGER part will fit in a CYBIL INTEGER, which
{ fortunately agrees with COBOL'source 18 digit accuracy requirement.

      IF f >= 1000000000000000000.0 THEN

{ The INTEGER portion of a COMPUTATIONAL-1 or COMPUTATIONAL-2 value
{ must be less than 1,000,000,000,000,000,000.

        osp$set_status_abnormal (
         fdc$format_display_identifier, fde$cobol_float_too_big, '', status);
        EXIT fdp$move_cobol_data;

      IFEND;

      integer_value := $INTEGER (f); { Extract the INTEGER part of the source
      f := f - $REAL (integer_value); { Extract the fraction part of the source

{ Put the INTEGER part into the destination

      FOR tsi := 19 DOWNTO 2 DO
        digit := integer_value MOD 10;
        integer_value := integer_value DIV 10;
        ts_address^ (tsi) := $CHAR ($INTEGER ('0') + digit);
      FOREND;

{ Insert fraction digits into destination

      FOR tsi := 20 TO 37 DO
        f := f * 10.0;
        digit := $INTEGER (f);
        f := f - $REAL (digit);
        ts_address^ (tsi) := $CHAR ($INTEGER ('0') + digit);
      FOREND;

{ Apply sign, if necessary

      IF negative THEN
        ts_address^ (1) := '-';
      IFEND;

    PROCEND move_single_to_standard;

?? OLDTITLE ??
?? NEWTITLE :=  'move_double_to_standard', EJECT ??

    PROCEDURE move_double_to_standard { from "source" to "ts"} ;

      TYPE
        kludge_type = record
          case INTEGER of
          = 1 =
            r: real,
          = 2 =
            source: ARRAY [1 .. bytes_for_single] OF CHAR,
          casend,
        recend { kludge_type} ;

      VAR
        destination_index: 1 ..bytes_for_single,
        digit: 0..9,
        f: real,
        kludge: kludge_type,
        n: item_index_min..item_index_max,
        negative: BOOLEAN,
        source_index: 1 .. value_conversion_length,
        tsi: 2 .. value_conversion_length;

{ Set up ts: fdt$cobol_description for S9(18)V9(18) USAGE DISPLAY

      initialize_ts;

{ Set up the floating point number


      FOR destination_index := 1 TO bytes_for_single DO
        kludge.source [destination_index] := source_address^ (destination_index);
      FOREND ;
      f := kludge.r;

{ Remember and strip sign

      negative := f < 0.0;
      IF negative THEN
        f := -f;
      IFEND { negative} ;

{ Divide by 10.0^18, to put all meaningful digits to right of point

{ A simple method would be to divide the floating point value by 10.0^18
{ which puts all meaningful digits to the right of the decimal point,
{ followed by repeatedly multiplying by 10 and getting the most
{ significant digit by truncating.
{ The problem with this approach is that significance can be lost.
{ For example, converting 12.0 to floating point retains the exact
{ mathematical value of 12.0, but dividing by 10^n loses accuracy,
{ since 12 has factors other than 2 or 5.
{ The solution is to convert the INTEGER portion of the number
{ separately from the fraction portion.

{ First ensure that the INTEGER part will fit in a CYBIL INTEGER,
{ which fortunately agrees with COBOL'source 18 digit accuracy requirement.

      IF f >= 1000000000000000000.0 THEN

{ The INTEGER portion of a COMPUTATIONAL-1 or COMPUTATIONAL-2 value
{ must be less than 1,000,000,000,000,000,000.

        osp$set_status_abnormal (
         fdc$format_display_identifier, fde$cobol_float_too_big, '', status);
        EXIT fdp$move_cobol_data;
      IFEND;

      n := $INTEGER (f); { Extract the INTEGER part of the source
      f := f - $REAL (n); { Extract the fraction part of the source

{ Put the INTEGER part into the destination

      FOR tsi := 19 DOWNTO 2 DO
        digit := n MOD 10;
        n := n DIV 10;
        ts_address^ (tsi) := $CHAR ($INTEGER ('0') + digit);
      FOREND { tsi} ;

{ Insert fraction digits into destination

      FOR tsi := 20 TO value_conversion_length DO
        f := f * 10.0;
        digit := $INTEGER (f);
        f := f - $REAL (digit);
        ts_address^ (tsi) := $CHAR ($INTEGER ('0') + digit);
      FOREND { tsi} ;

{ Apply sign, if necessary

      IF negative THEN
        ts_address^ (1) := '-';
      IFEND;

    PROCEND move_double_to_standard;

?? OLDTITLE ??
?? NEWTITLE :=  'move_packed_to_standard', EJECT ??

    PROCEDURE move_packed_to_standard { from "source" to "ts"} ;

      VAR
        digit: 0 .. 15, { decimal digit extracted from source
        left: BOOLEAN, { iff left parcel is next to be filled
        left_parcel: INTEGER, { 4-bit parcel to go in left side of byte
        source_index: 1 .. value_conversion_length,
        tsi: 1 .. value_conversion_length,
        tsi_max: 1 .. value_conversion_length;

{ A PACKED-DECIMAL number has an associated PICTURE that determines
{ the total number of digits (source.number_digits), the number of significant
{ digits (source.significant_digits), and whether a sign is present
{ (source.sign_index<>0).
{ A PACKED-DECIMAL number is represented by putting each decimal digit
{ in its own 4-bit parcel.  A sign is indicated by certain values in
{ the right-most parcel.  An extra zero-value parcel may be added on
{ the left to make a whole number of bytes.

{ Set up ts: fdt$cobol_description for S9(18)V9(18) USAGE DISPLAY

      initialize_ts;

{ Deposit all the digits into the destination
{ For example, if source.significant_digits=18, we would start at 2
{          and if source.significant_digits=1,  we would start at 19.

      left := ((source.number_digits + source.sign_index) MOD 2) = 0;
      source_index := 1;
      tsi := 20 - source.significant_digits;
      tsi_max := tsi - 1 + source.number_digits;
      FOR tsi := tsi TO tsi_max DO
        IF left THEN
          digit := $INTEGER (source_address^ (source_index)) DIV 16
        ELSE
          digit := $INTEGER (source_address^ (source_index)) MOD 16;
          source_index := source_index + 1;
        IFEND;
        left := NOT left;
        ts_address^ (tsi) := $CHAR ($INTEGER ('0') + digit);
      FOREND { tsi} ;

      IF source.sign_index <> 0 THEN

{ Source has a sign parcel

        IF left THEN
          digit := $INTEGER (source_address^ (source_index)) DIV 16
        ELSE
          digit := $INTEGER (source_address^ (source_index)) MOD 16;
        IFEND;

        IF digit = 13 THEN
          ts_address^ (1) := '-';
        IFEND { sign parcel is negative
      IFEND { Source has a sign parcel
    PROCEND move_packed_to_standard;

?? OLDTITLE ??
?? NEWTITLE :=  'move_standard_to_standard', EJECT ??

    PROCEDURE move_standard_to_binary { from "ts" to "destination"} ;

      TYPE
        kludge_type = record
          case INTEGER of
          = 1 =
            r: real,
          = 2 =
            source: ARRAY [1 .. bytes_for_single] OF CHAR,
          = 3 =
            i: INTEGER,
          casend,
        recend;

      VAR
        kludge: kludge_type,
        integer_value: integer,
        tsi: 1 .. value_conversion_length,
        tsi_max: 1 .. value_conversion_length;

{ A "binary" number has an associated PICTURE that determines the
{ total number of digits (destination.number_digits) and the
{ number of significant digits (destination.significant_digits).
{ For example, S9(8)V99 would have destination.size=10 and
{ destination.significant_digits=8.  Take the INTEGER whose digits correspond
{ to the "binary" PICTURE.  For example, a source value of -123456789.1
{ would yield an INTEGER of -2345678910.  Represent this INTEGER
{ in binary.  Keep only the bytes on the right necessary to represent
{ the largest number fitting the "binary" PICTURE.  The COBOL/VE
{ Usage Manual on page 5-34 shows the indicated number of bytes
{ for each PICTURE size.

{ Add all the digits into the destination
{ For example, if destination.significant_digits=18, we would start at 2
{          and if destination.significant_digits=1,  we would start at 19.

      integer_value := 0;
      tsi := 20 - destination.significant_digits;
      tsi_max := tsi - 1 + destination.number_digits;
      FOR tsi := tsi TO tsi_max DO
        integer_value := integer_value * 10 + $INTEGER (ts_address^ (tsi)) - $INTEGER ('0');
      FOREND;

{ Apply sign, if called for

      IF (destination.sign_index = 1) AND (ts_address^ (1) = '-') THEN
        integer_value := -integer_value;
      IFEND { negative} ;

{ Map the final value to the destination.

      kludge.i := integer_value;
      i#move (^kludge.source [bytes_for_integer + 1 - destination.size],
            destination_address, destination.size);

    PROCEND move_standard_to_binary;

?? OLDTITLE ??
?? NEWTITLE :=  'move_standard_to_single', EJECT ??

    PROCEDURE move_standard_to_single { from "ts" to "destination"} ;

      TYPE
        kludge_type = record
          case INTEGER of
          = 1 =
            r: real,
          = 2 =
            source: ARRAY [1 .. bytes_for_single] OF CHAR,
          casend,
        recend { kludge_type} ;

      VAR
        digit: INTEGER,
        i: 2 .. value_conversion_length,
        f: real,
        kludge: kludge_type,
        r: real;


      f := 0.0;
      FOR i := 2 TO 19 DO
        digit := $INTEGER (ts_address^ (i)) - $INTEGER ('0');
        f := f * 10.0 + $REAL (digit);
      FOREND;

      r := 0.0;
      FOR i := 20 TO value_conversion_length DO
        digit := $INTEGER (ts_address^ (i)) - $INTEGER ('0');
        r := r * 10.0 + $REAL (digit);
      FOREND { i} ;
      f := f + (r / 1000000000000000000.0 { 10^18} );

{ Put the single-precision result into the destination

      IF ts_address^ (1) = '+' THEN
        kludge.r := f;
      ELSE
        kludge.r := -f;
      IFEND;

      i#move (^kludge.source [bytes_for_single + 1 - destination.size],
            destination_address, destination.size);
    PROCEND move_standard_to_single;

?? OLDTITLE ??
?? NEWTITLE :=  'move_standard_to_double', EJECT ??

    PROCEDURE move_standard_to_double { from "ts" to "destination"} ;

      TYPE
        kludge_type = record
          case INTEGER of
          = 1 =
            r: real,
          = 2 =
            source: ARRAY [1 .. bytes_for_single] OF CHAR,
          casend,
        recend { kludge_type} ;

      VAR
        digit: INTEGER,
        i: 1 .. value_conversion_length,
        f: real,
        kludge: kludge_type,
        r: real,
        source_index: 1 .. bytes_for_double;

      f := 0.0;
      FOR i := 2 TO 19 DO
        digit := $INTEGER (ts_address^ (i)) - $INTEGER ('0');
        f := f * 10.0 + $REAL (digit);
      FOREND { i} ;
      r := 0.0;
      FOR i := 20 TO 37 DO
        digit := $INTEGER (ts_address^ (i)) - $INTEGER ('0');
        r := r * 10.0 + $REAL (digit);
      FOREND { i} ;
      f := f + (r / 1000000000000000000.0 { 10^18} );

{ Put the double-precision result into the destination

    IF ts_address^ (1) = '+' THEN
      kludge.r := f;
    ELSE
      kludge.r := -f;
    IFEND;

    destination_index := 1;
    FOR source_index := 1 TO bytes_for_double DO
       destination_address^ (destination_index)
        := kludge.source [source_index];
       destination_index := destination_index + 1;
    FOREND {source_index};

    PROCEND move_standard_to_double;

?? OLDTITLE ??
?? NEWTITLE :=  'move_standard_to_packed', EJECT ??

    PROCEDURE move_standard_to_packed { from "ts" to "destination"} ;

      VAR
        destination_index: 1 .. fdc$cobol_digits_maximum,
        digit: 0 .. 15, { decimal digit extracted from source
        left: BOOLEAN, { iff left parcel is next to be filled
        left_parcel: INTEGER, { 4-bit parcel to go in left side of byte
        tsi: 1 .. value_conversion_length,
        tsi_max: 1 .. value_conversion_length;

{ A PACKED-DECIMAL number has an associated PICTURE that determines
{ the total number of digits (destination.number_digits), the
{ number of significant digits (destination.significant_digits), and
{ whether a sign is present (destination.sign_index<>0).
{ A PACKED-DECIMAL number is represented by putting each decimal digit
{ in its own 4-bit parcel.  A sign is indicated by certain values in
{ the right-most parcel.  An extra zero-value parcel may be added on
{ the left to make a whole number of bytes.
{
{ Space has already been reserved for the final result.

{ Deposit all the digits into the destination
{ For example, if destination.significant_digits=18, we would start at 2
{          and if destination.significant_digits=1,  we would start at 19.

      left :=
       ((destination.number_digits + destination.sign_index) MOD 2) = 0;
      left_parcel := 0;
      destination_index := 1;
      tsi := 20 - destination.significant_digits;
      tsi_max := tsi - 1 + destination.number_digits;
      FOR tsi := tsi TO tsi_max DO
        digit := $INTEGER (ts_address^ (tsi)) - $INTEGER ('0');
        IF left THEN
          left_parcel := digit
        ELSE
          destination_address^ (destination_index) :=
           $CHAR (left_parcel * 16 + digit);
          destination_index := destination_index + 1;
        IFEND;
        left := NOT left;
      FOREND { tsi} ;

      IF destination.sign_index <> 0 THEN

{ Destination needs a sign parcel

        IF ts_address^ (1) = '+' THEN
          digit := 12
        ELSE
          digit := 13;
        IFEND;
        destination_address^ (destination_index) :=
         $CHAR (left_parcel * 16 + digit);
      IFEND { Destination needed a sign parcel
    PROCEND move_standard_to_packed;

?? OLDTITLE ??
?? NEWTITLE :=  'move_display_to_display', EJECT ??

    PROCEDURE move_display_to_display
      (    ts: fdt$cobol_description,
           ts_address: ^STRING ( * );
           destination: fdt$cobol_description;
           destination_address: ^STRING ( * ));

{ Move the USAGE IS DISPLAY source item described by ts & ts_address
{  to the USAGE IS DISPLAY destination item described by destination
{ and destination_address

      VAR

{ each loop, set to destination.operation_characters[oi], then scratch

        c: char,
        destination_index: 1 .. item_index_max + 1,
        i: item_index_min..item_index_max, { scratch
        imax: item_index_min..item_index_max,
        leading_zero_c: char, { char indicating replacement of leading zeros
        leading_zeros: BOOLEAN, { iff we are suppressing leading zeros
        oi: 1 .. fdc$cobol_operations_max, { operation index
        op_code: fdt$cobol_operation, { operation to be done

{ index to "." in destination, else 0

        point_destination_index: item_index_min..item_index_max,
        positive: BOOLEAN, { iff signed number is positive
        source_index: -item_index_max .. item_index_max + 1,
        skip_leading_separate: BOOLEAN, { iff to skip leading separate sign
        zero: BOOLEAN; { iff inserted digits are all zero

?? NEWTITLE := 'get_digit', EJECT ??

      PROCEDURE get_digit

{ This procedure gets the next physical digit from the source,
{ properly skipping any separate sign, and properly extracting
{ the digit from an overpunch sign.
{ It is not a function because CYBIL does not let functions change
{ non-local variables such as "skip_leading_separate".

        (VAR source_index: -item_index_max .. item_index_max + 1;
         VAR digit: char); { The next physical digit

        VAR
          c: char; { Scratch variable


        c := ts_address^ (source_index); { Examine character from source

{ Check if we have a character containing a sign
{ Note that "skip_leading_separate" is true only when the source
{ has a leading separate sign and no digits have been moved yet.
{ We cannot simply check whether source_index = ts.sign_index because
{ we might have to skip leading source physical digits (Test 39).

        IF (source_index = ts.sign_index) OR skip_leading_separate THEN
          skip_leading_separate := FALSE;
          IF ts.sign_separate THEN
            source_index := source_index + 1;
            IF ts.sign_index = 1 THEN
              c := ts_address^ (source_index)
            ELSE
              c := '0'; { Must now be beyond actual digits
            IFEND;

{ end: sign is separate

          ELSE

{ overpunch sign

            IF (c >= '0') AND (c <= '9') THEN

{ Most likely case - leave c a digit

            ELSEIF c = '}' THEN
              c := '0'
            ELSEIF (c >= 'J') AND (c <= 'R') THEN
              c := $CHAR ($INTEGER (c) - $INTEGER ('J') + $INTEGER ('1'))
            ELSEIF (c >= 'j') AND (c <= 'r') THEN
              c := $CHAR ($INTEGER (c) - $INTEGER ('j') + $INTEGER ('1'))
            ELSEIF c = '{' THEN
              c := '0'
            ELSEIF (c >= 'A') AND (c <= 'I') THEN
              c := $CHAR ($INTEGER (c) - $INTEGER ('A') + $INTEGER ('1'))
            ELSEIF (c >= 'a') AND (c <= 'i') THEN
              c := $CHAR ($INTEGER (c) - $INTEGER ('a') + $INTEGER ('1'))
            ELSE

{ Sign of COBOL number does not have correct
{ overpunch representation.

              osp$set_status_abnormal (
               fdc$format_display_identifier, fde$cobol_bad_overpunch_sign, '',
               status);
              EXIT fdp$move_cobol_data;
            IFEND;
          IFEND { overpunch sign
        IFEND { sign} ;
        digit := c;
      PROCEND { get_digit} get_digit;

?? OLDTITLE ??
?? NEWTITLE :=  'set_prev_char', EJECT ??

      PROCEDURE set_prev_char;

        VAR
          pc: char;

{ Change the previous character, if necessary

        pc := '0';
        IF leading_zero_c = fdv$cobol_currency_symbols.primary_money_symbol THEN
          pc := fdv$cobol_currency_symbols.primary_money_symbol;
        ELSEIF leading_zero_c = fdv$cobol_currency_symbols.secondary_money_symbol THEN
          pc := fdv$cobol_currency_symbols.secondary_money_symbol;
        ELSEIF (leading_zero_c = '+') AND positive THEN
          pc := '+'
        ELSEIF (leading_zero_c = '+') { and negative} THEN
          pc := '-'
        ELSEIF (leading_zero_c = '-') AND positive THEN
          pc := ' '
        ELSEIF (leading_zero_c = '-') { and negative} THEN
          pc := '-';
        IFEND;
        IF pc <> '0' THEN

{ We know there is always a previous character,
{ due to fdc$cobol_set_leading_zeros.

          destination_address^ (destination_index - 1) := pc;
        IFEND;
        leading_zeros := FALSE;
      PROCEND set_prev_char;

?? OLDTITLE,  EJECT ??

      skip_leading_separate := FALSE;
      source_index :=
       ts.significant_digits - destination.significant_digits + 1;
      IF ts.sign_index = 0 THEN
        positive := TRUE { Source has no sign
      ELSE

{ source has a sign

        c := ts_address^ (ts.sign_index);
        IF ts.sign_separate THEN
          IF ts.sign_index = 1 THEN
            skip_leading_separate := TRUE;
          IFEND;
          IF c = '+' THEN
            positive := TRUE
          ELSEIF c = '-' THEN
            positive := FALSE
          ELSE

{ Expected source separate sign to be "+" OR "-",
{ but it was not.

            osp$set_status_abnormal (
             fdc$format_display_identifier,
             fde$cobol_bad_separate_sign, '', status);
            EXIT fdp$move_cobol_data;
          IFEND;

        ELSE

{ overpunch sign

          IF  ((c >= 'A') AND (c <= 'I'))
           OR (  c = '{'               )
           OR ((c >= '0') AND (c <= '9'))
           THEN
            positive := TRUE
          ELSEIF ((c >= 'J') AND (c <= 'R')) OR (c = '}') THEN
            positive := FALSE
          ELSE

{ Below should actually be
{ Expected source overpunch sign to be A..R, "{ " OR ")",
{ but it was not.

            osp$set_status_abnormal (
             fdc$format_display_identifier,
             fde$cobol_bad_overpunch_sign, '', status);
            EXIT fdp$move_cobol_data;
          IFEND;
        IFEND; { overpunch sign
      IFEND { source has a sign} ;

      point_destination_index := 0;
      zero := TRUE;
      destination_index := 1;
      leading_zeros := FALSE;
      destination_address^ := '';

      FOR oi := 1 TO destination.move_operations DO
        op_code := destination.cobol_operations [oi];
        c := destination.operation_characters [oi];
        CASE op_code OF
        = fdc$cobol_move =

{ Since this operation corresponds to "9" in a numeric-edited
{ picture, we do not want to blank out the destination field
{ if the destination digits are all zero.

          zero := FALSE;

          imax := destination.operation_numbers [oi];
          FOR i := 1 TO imax DO
            IF source_index <= 0 THEN
              c := '0'
            ELSEIF source_index <= ts.size THEN
              get_digit (source_index, c)
            ELSEIF (destination.cobol_category = fdc$cobol_numeric_signed)
             OR    (destination.cobol_category = fdc$cobol_numeric_unsigned)
             OR    (destination.cobol_category = fdc$cobol_numeric_edited)
             THEN
              c := '0'
            ELSE
              c := ' ';
            IFEND;
            destination_address^ (destination_index) := c;
            destination_index := destination_index + 1;
            source_index := source_index + 1;
          FOREND { i} ;
{ end: fdc$cobol_move} ;

        = fdc$cobol_move_float =

{ move <op_num> chars, floating <op_char>

          imax := destination.operation_numbers [oi];
          FOR i := 1 TO imax DO
            IF source_index <= 0 THEN
              c := '0'
            ELSEIF source_index <= ts.size THEN
              get_digit (source_index, c)
            ELSE
              c := '0';
            IFEND;

            IF c <> '0' THEN
              zero := FALSE; { Remember to not blank field
            IFEND;

            IF leading_zeros THEN
              IF c = '0' THEN
                IF leading_zero_c = '*' THEN
                  c := '*'
                ELSE
                  c := ' '
                IFEND
              ELSE
                set_prev_char; { Switch from suppressing zeros to not
              IFEND;
            IFEND;

            destination_address^ (destination_index) := c;
            destination_index := destination_index + 1;
            source_index := source_index + 1;
          FOREND { i} ;
{ end: fdc$cobol_move_float} ;

        = fdc$cobol_set_leading_zeros =
          leading_zeros := TRUE;
          leading_zero_c := c;
          IF leading_zero_c <> '*' THEN
            c := ' ';
          IFEND;
          IF  (leading_zero_c = '+')
           OR (leading_zero_c = '-')
           OR (leading_zero_c = fdv$cobol_currency_symbols.primary_money_symbol)
           OR (leading_zero_c = fdv$cobol_currency_symbols.secondary_money_symbol) THEN
            destination_address^ (destination_index) := c;
            destination_index := destination_index + 1;
          IFEND;

{ end: fdc$cobol_set_leading_zeros

        = fdc$cobol_overpunch_sign =

{ Since this operation corresponds to "9" in a numeric-edited
{ picture, we do not want to blank out the destination field
{ if the destination digits are all zero.

          zero := FALSE;

          IF source_index <= 0 THEN
            c := '0'
          ELSEIF source_index <= ts.size THEN
            get_digit (source_index, c)
          ELSE
            c := '0';
          IFEND;

          IF NOT positive THEN
            IF c = '0' THEN
              c := '}'
            ELSE
              c := $CHAR ($INTEGER (c) - $INTEGER ('0') + $INTEGER ('I'));
            IFEND
          IFEND { NOT positive} ;

          destination_address^ (destination_index) := c;
          destination_index := destination_index + 1;
          source_index := source_index + 1;
{ end: fdc$cobol_overpunch_sign} ;

        = fdc$cobol_separate_sign =

{ This code is generated for a signed numeric picture
{ with SIGN IS SEPARATE clause, or
{ for a numeric-edited picture with a single "+".

          IF positive THEN
            c := '+'
          ELSE
            c := '-';
          IFEND;
          destination_address^ (destination_index) := c;
          destination_index := destination_index + 1;
{ end: fdc$cobol_separate_sign} ;

        = fdc$cobol_insert =

{ If inserting decimal point, remember in case of "***.**"
{ and zero

          IF c = fdv$cobol_currency_symbols.decimal_symbol THEN
            point_destination_index := destination_index;
          IFEND { .} ;
          imax := destination.operation_numbers [oi];
          IF leading_zeros THEN
            IF leading_zero_c = '*' THEN
              c := '*'
            ELSE
              c := ' '
            IFEND
          IFEND;

          FOR i := 1 TO imax DO
            destination_address^ (destination_index) := c;
            destination_index := destination_index + 1;
          FOREND;

        = fdc$cobol_set_char_if_negative =

{ insert <op_char> if neg, else " "
{ For "CR",
{ if the source is negative or has "cr" set then
{    show "CR"
{ else
{    show "  "
{ Similarly for "DB".
{ For "+" or "-", consider only whether source is negative

          IF (c = 'C') OR (c = 'R') THEN
            IF positive AND NOT ts.display_cr THEN
              c := ' ';
            IFEND
          ELSEIF (c = 'D') OR (c = 'B') THEN
            IF positive AND NOT ts.display_db THEN
              c := ' ';
            IFEND
          ELSE
            IF positive THEN
              c := ' ';
            IFEND
          IFEND;
          destination_address^ (destination_index) := c;
          destination_index := destination_index + 1;

{ end: fdc$cobol_set_char_if_negative

        = fdc$cobol_stop_float =
          IF leading_zeros THEN
            set_prev_char; { and set leading_zeros := false
          IFEND
{ end: fdc$cobol_stop_float} ;
        ELSE
        CASEND { op_code
      FOREND { oi} ;

      IF zero THEN

{ All destination digits were zero, and the destination picture
{ did not have a "9", so clear destination field.

        IF leading_zero_c = '*' THEN
          c := '*'
        ELSE
          c := ' ';
        IFEND;
        FOR destination_index := destination_index - 1 DOWNTO 1 DO
          destination_address^ (destination_index) := c;
        FOREND { destination_index} ;
        IF (leading_zero_c = '*') AND (point_destination_index >= 1) THEN
          destination_address^ (point_destination_index) := fdv$cobol_currency_symbols.decimal_symbol;
        IFEND { e.g. ***.**
      IFEND; { zero

    PROCEND move_display_to_display;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    IF destination.cobol_category = fdc$cobol_free_form THEN

{ Any source to free-form destination.
{ Free form field cannot be destination of fdp$move_cobol_data.

      osp$set_status_abnormal (
       fdc$format_display_identifier, fde$cobol_free_form_not_dest, '', status);
      RETURN;
    IFEND;

    IF source.cobol_category <> fdc$cobol_free_form THEN
      IF source.size <> STRLENGTH (source_address^) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$cobol_source_invalid, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (source.size), 10, FALSE,
                status);
        osp$append_status_integer (osc$status_parameter_delimiter,
                $INTEGER (STRLENGTH (source_address^)), 10, FALSE, status);
        RETURN;
      IFEND;
    IFEND;

   IF destination.size  > STRLENGTH (destination_address^) THEN
      osp$set_status_abnormal (
       fdc$format_display_identifier, fde$cobol_destination_invalid, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (destination.size), 10, FALSE,
                status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                $INTEGER (STRLENGTH (destination_address^)), 10, FALSE, status);
      RETURN;
    IFEND;


{ The problem is to move a wide variety of source formats
{ to a wide variety.  We could have special-case code for
{ many conversions, such as COMP-1 to COMP-1, or COMP-1 to COMP-2.
{ We could have as many as 30 such conversion routines - a lot of work!
{ However the use of these routines - in Screen Formatting for use by
{ IM/SMART, and in DM/SQL for use by the COBOL interface -
{ is such that most of the conversions will be from and/or to
{ display.  So we simplify coding by converting non-display
{ source_data (source) to display temporary source_data (ts), if needed.
{ Then we convert the temporary source to the final destination (destination).

{ First ensure the source is in display form, described by "ts"

       IF source.cobol_category = fdc$cobol_free_form THEN
         move_free_form_to_standard
       ELSE

        CASE source.cobol_usage OF

        = fdc$cobol_usage_binary =
          move_binary_to_standard;

        = fdc$cobol_usage_single =
          move_single_to_standard;

        = fdc$cobol_usage_double =
          move_double_to_standard;

        = fdc$cobol_usage_packed =
          move_packed_to_standard;

        ELSE
          IF destination.cobol_usage <> fdc$cobol_usage_display THEN

{ moving display to non-display

           initialize_ts;
           move_display_to_display (source, source_address, ts, ts_address);
          ELSE

{ moving display to display
{ Copy the description from "source" to "ts"

           ts := source;

{ Copy the value from "source_address^" to "ts_address^"

          ts_address := source_address;
        IFEND;
      CASEND;
    IFEND;

{ Now move the display source to the final output, described by "destination"

    CASE destination.cobol_usage OF

    = fdc$cobol_usage_binary =
      move_standard_to_binary;

    = fdc$cobol_usage_single =
      move_standard_to_single;

    = fdc$cobol_usage_double =
      move_standard_to_double;

    = fdc$cobol_usage_packed =
      move_standard_to_packed;

    = fdc$cobol_usage_display =
      move_display_to_display
       (ts, ts_address, destination, destination_address);

    ELSE
    CASEND;

  PROCEND fdp$move_cobol_data;

MODEND fdm$move_cobol_data;

*DECK DECK=FDM$PASCAL_PROCEDURES EXPAND=FALSE

PROGRAM fdm$pascal_requests;

{
  PURPOSE:
    This module calls header deck for FDP$PASCAL_PROCEDURES.

  DESIGN:
    All the processing for PASCAL interfaces exist in module
    FDM$COBOL_FORTRAN_REQUESTS. The process for PASCAL is the same as for
    COBOL and FORTRAN.
}

*copyc fdh$pascal_procedures
BEGIN

END.
*DECK DECK=FDM$PROCESS_FORM EXPAND=TRUE

?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Screen Formatting: Process Form' ??
MODULE fdm$process_form;

{ PURPOSE:
{   This module creates, changes, and gets data about a form definition.
{
{ DESIGN:
{   Do not change a stored form definition if any changes are invalid.
{
{ NOTES:
{  All external procedures appear first in alphabetical order.  Then
{  procedures internal to this module appear in alphabetical order.


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc cyd$run_time_error_condition
*copyc fde$condition_identifiers
*copyc fdc$im_smart_capability
*copyc fdc$message_form_capability
*copyc fdc$reassign_event_capability
*copyc fdc$integer_length
*copyc fdc$real_length
*copyc fdc$screen_formatting_version
*copyc fdc$system_coordinate_system
*copyc fdc$system_design_variable_name
*copyc fdc$system_error_message
*copyc fdc$system_form_processor
*copyc fdc$system_help_message
*copyc fdc$system_record_type
*copyc fdt$error_header
*copyc fdt$error_input_conversion
*copyc fdt$error_invalid_value
*copyc fdt$error_no_table_variable
*copyc fdt$error_no_variable_def
*copyc fdt$error_no_variable_object
*copyc fdt$error_output_conversion
*copyc fdt$error_unequal_tbl_obj_width
*copyc fdt$comment_index
*copyc fdt$display_index
*copyc fdt$event_index
*copyc fdt$form_attribute_index
*copyc fdt$form_attributes
*copyc fdt$form_names
*copyc fdt$form_object_definition
*copyc fdt$form_object_key
*copyc fdt$form_objects
*copyc fdt$get_object_attributes
*copyc fdt$get_form_attributes
*copyc fdt$name_selections
*copyc fdt$number_errors
*copyc fdt$number_names
*copyc fdt$object_attributes
*copyc fdt$object_definition
*copyc fdt$table_attribute_index
*copyc fdt$table_attributes
*copyc fdt$table_variable_index
*copyc fdt$variable_index
*copyc ost$name
?? POP ??

*copyc fdv$colors

*copyc clp$validate_name
*copyc fdp$add_comment
*copyc fdp$add_object_to_form_image
*copyc fdp$allocate_object
*copyc fdp$check_object_inside_form
*copyc fdp$convert_to_program_variable
*copyc fdp$convert_to_screen_variable
*copyc fdp$convert_yymmdd_to_date_time
*copyc fdp$create_cobol_description
*copyc fdp$create_form_status
*copyc fdp$date_variable
*copyc fdp$find_change_form_definition
*copyc fdp$find_display_name
*copyc fdp$find_form_definition
*copyc fdp$find_form_status
*copyc fdp$find_object_definition
*copyc fdp$find_variable_definition
*copyc fdp$get_message
*copyc fdp$locate_added_variable_facts
*copyc fdp$move_to_program_variable
*copyc fdp$move_to_screen_variable
*copyc fdp$ptr_comments
*copyc fdp$ptr_displays
*copyc fdp$ptr_event_command
*copyc fdp$ptr_events
*copyc fdp$ptr_objects
*copyc fdp$ptr_record_definitions
*copyc fdp$ptr_tables
*copyc fdp$ptr_table_objects
*copyc fdp$ptr_table_variables
*copyc fdp$ptr_text
*copyc fdp$ptr_valid_reals
*copyc fdp$ptr_valid_strings
*copyc fdp$ptr_variable
*copyc fdp$ptr_variables
*copyc fdp$rel_comments
*copyc fdp$rel_displays
*copyc fdp$rel_event_command
*copyc fdp$rel_events
*copyc fdp$rel_objects
*copyc fdp$rel_tables
*copyc fdp$rel_table_objects
*copyc fdp$rel_table_variables
*copyc fdp$rel_text
*copyc fdp$rel_record_definitions
*copyc fdp$rel_variable
*copyc fdp$rel_variables
*copyc fdp$set_display_attributes
*copyc fdp$validate_cobol_data
*copyc fdp$validate_integer
*copyc fdp$validate_name
*copyc fdp$validate_real
*copyc fdp$validate_string
*copyc i#current_sequence_position
*copyc i#move
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc pmp$continue_to_cause
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    fdc$displays_to_expand = 3,
    fdc$events_to_expand = 8,
    fdc$initial_x_position = 1,
    fdc$initial_y_position = 1;

?? TITLE := 'fdp$change_form', EJECT ??
*copyc fdh$change_form

  PROCEDURE [XDCL] fdp$change_form
    (    form_identifier: fdt$form_identifier;
     VAR form_attributes: fdt$form_attributes;
     VAR status: ost$status);

    VAR
      form_attribute_index: fdt$form_attribute_index,
      new_form_definition: fdt$form_definition,
      p_form_status: ^fdt$form_status;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$change_form;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$change_form;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    FOR form_attribute_index := LOWERBOUND (form_attributes) TO UPPERBOUND (form_attributes) DO
      form_attributes [form_attribute_index].put_value_status := fdc$unprocessed_put_value;
    FOREND;

    fdp$find_change_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Use a copy of the stored form definition so that any invalid changes do not
{ affect it.

    new_form_definition := p_form_status^.p_form_definition^;
    change_form (p_form_status, ^new_form_definition, form_attributes, status);

{ Update stored form definition only when no errors occur.

    IF status.normal THEN
      p_form_status^.p_form_definition^ := new_form_definition;
    IFEND;
  PROCEND fdp$change_form;

?? TITLE := 'fdp$check_for_overlayed_objects', EJECT ??
*copyc fdh$check_for_overlayed_objects

  PROCEDURE [XDCL] fdp$check_for_overlayed_objects
    (    p_form_image: ^fdt$form_image;
         p_form_object_definition: ^fdt$form_object_definition;
         form_name: ost$name;
     VAR status: ost$status);

    VAR
      current_x_position: fdt$x_position,
      current_y_position: fdt$y_position,
      end_object_x_position: fdt$x_position,
      end_object_y_position: fdt$y_position,
      x_position: fdt$x_position,
      y_position: fdt$y_position;

{ More than one object cannot occupy the same area on the form.
{ Objects are recorded in the form image, a character array of the form area.

    status.normal := TRUE;
    x_position := p_form_object_definition^.x_position;
    y_position := p_form_object_definition^.y_position;

{ Determine type of object.  Then examine area occupied by object.

    CASE p_form_object_definition^.key OF

    = fdc$form_box =
      end_object_x_position := x_position + p_form_object_definition^.box_width - 1;
      end_object_y_position := y_position + p_form_object_definition^.box_height - 1;

{ Check top line of box.

      FOR current_x_position := x_position TO end_object_x_position DO
        IF p_form_image^ [y_position] (current_x_position, 1) <> ' ' THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$object_overlays, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (current_x_position), 10, FALSE,
                status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (y_position),
                10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, form_name, status);
          RETURN;
        IFEND;
      FOREND;

{ Check bottom line of box.

      FOR current_x_position := x_position TO end_object_x_position DO
        IF p_form_image^ [end_object_y_position] (current_x_position, 1) <> ' ' THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$object_overlays, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (current_x_position), 10, FALSE,
                status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (end_object_y_position), 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, form_name, status);
          RETURN;
        IFEND;
      FOREND;

{ Check left vertical line of box.

      FOR current_y_position := y_position + 1 TO end_object_y_position - 1 DO
        IF p_form_image^ [current_y_position] (x_position, 1) <> ' ' THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$object_overlays, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (x_position),
                10, FALSE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (current_y_position), 10, FALSE,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, form_name, status);
          RETURN;
        IFEND;
      FOREND;

{ Check left right vertical line of box.

      FOR current_y_position := y_position + 1 TO end_object_y_position - 1 DO
        IF p_form_image^ [current_y_position] (end_object_x_position, 1) <> ' ' THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$object_overlays, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (end_object_x_position), 10,
                FALSE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (current_y_position), 10, FALSE,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, form_name, status);
          RETURN;
        IFEND;
      FOREND;

    = fdc$form_line =
      IF (p_form_object_definition^.y_increment = 0) THEN

{ Check horizontal line.

        FOR current_x_position := x_position TO x_position + p_form_object_definition^.x_increment DO
          IF p_form_image^ [y_position] (current_x_position, 1) <> ' ' THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$object_overlays, '', status);
            osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (current_x_position), 10,
                  FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (y_position), 10, FALSE,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, form_name, status);
            RETURN;
          IFEND;
        FOREND;

      ELSE

{ Check vertical line.

        FOR current_y_position := y_position TO y_position + p_form_object_definition^.y_increment DO
          IF p_form_image^ [current_y_position] (x_position, 1) <> ' ' THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$object_overlays, '', status);
            osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (x_position), 10, FALSE,
                  status);
            osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (current_y_position), 10,
                  FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, form_name, status);
            RETURN;
          IFEND;
        FOREND;
      IFEND;

    = fdc$form_variable_text =
      FOR current_x_position := x_position TO x_position + p_form_object_definition^.text_variable_width -
            1 DO
        IF p_form_image^ [y_position] (current_x_position, 1) <> ' ' THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$object_overlays, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (current_x_position), 10, FALSE,
                status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (y_position),
                10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, form_name, status);
          RETURN;
        IFEND;
      FOREND;

    = fdc$form_variable_text_box =
      FOR current_y_position := y_position TO y_position + p_form_object_definition^.variable_box_height -
            1 DO
        FOR current_x_position := x_position TO x_position + p_form_object_definition^.variable_box_width -
              1 DO
          IF p_form_image^ [current_y_position] (current_x_position, 1) <> ' ' THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$object_overlays, '', status);
            osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (current_x_position), 10,
                  FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (current_y_position), 10,
                  FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, form_name, status);
            RETURN;
          IFEND;
        FOREND;
      FOREND;

    = fdc$form_constant_text =
      FOR current_x_position := x_position TO x_position + p_form_object_definition^.constant_text_width -
            1 DO
        IF p_form_image^ [y_position] (current_x_position, 1) <> ' ' THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$object_overlays, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (current_x_position), 10, FALSE,
                status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (y_position),
                10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, form_name, status);
          RETURN;
        IFEND;
      FOREND;

    = fdc$form_constant_text_box =
      FOR current_y_position := y_position TO y_position + p_form_object_definition^.constant_box_height -
            1 DO
        FOR current_x_position := x_position TO x_position + p_form_object_definition^.constant_box_width -
              1 DO
          IF p_form_image^ [current_y_position] (current_x_position, 1) <> ' ' THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$object_overlays, '', status);
            osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (current_x_position), 10,
                  FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (current_y_position), 10,
                  FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, form_name, status);
            RETURN;
          IFEND;
        FOREND;
      FOREND;

    ELSE { Ignore other objects.
    CASEND;

  PROCEND fdp$check_for_overlayed_objects;

?? TITLE := 'fdp$create_form', EJECT ??
*copyc fdh$create_form

  PROCEDURE [XDCL] fdp$create_form
    (VAR form_identifier: fdt$form_identifier;
     VAR form_attributes: fdt$form_attributes;
     VAR status: ost$status);

    VAR
      display_attribute_set: fdt$display_attribute_set,
      form_attribute_index: fdt$form_attribute_index,
      form_work_area: amt$segment_pointer,
      local_status: ost$status,
      p_form_definition: ^fdt$form_definition,
      p_form_image: ^fdt$form_image,
      p_form_module: ^fdt$form_module,
      p_form_status: ^fdt$form_status,
      x_position: fdt$x_position,
      y_position: fdt$y_position;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          clean_up;
          EXIT fdp$create_form;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          clean_up;
          EXIT fdp$create_form;
        IFEND;

      = pmc$block_exit_processing =
        handler_status.normal := TRUE;
        RETURN;
      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE ??
?? NEWTITLE := 'clean_up', EJECT ??

    PROCEDURE [INLINE] clean_up;

      IF form_work_area.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (p_form_status^.segment_pointer, local_status);
      IFEND;
      IF p_form_status <> NIL THEN
        p_form_status^.entry_used := FALSE;
      IFEND;
      IF p_form_image <> NIL THEN
        FREE p_form_image;
      IFEND;
    PROCEND clean_up;

?? OLDTITLE, EJECT ??

{ Initialize variables used in condition handler.

    form_work_area.kind := amc$sequence_pointer;
    form_work_area.sequence_pointer := NIL;
    p_form_image := NIL;
    p_form_status := NIL;
    osp$establish_condition_handler (^condition_handler, TRUE);

    FOR form_attribute_index := LOWERBOUND (form_attributes) TO UPPERBOUND (form_attributes) DO
      form_attributes [form_attribute_index].put_value_status := fdc$unprocessed_put_value;
    FOREND;

    fdp$create_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      clean_up;
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

{ The definition for the form will be placed in a sequence in a scratch segment.
{ All pointers in the sequence must  be  relative  pointers  so  that  the sequence
{ may later be saved in an object code library.

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, form_work_area, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
      clean_up;
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

    p_form_status^.segment_pointer := form_work_area;
    RESET p_form_status^.segment_pointer.sequence_pointer;
    p_form_status^.p_form_module := p_form_status^.segment_pointer.sequence_pointer;
    NEXT p_form_definition IN p_form_status^.p_form_module;
    IF p_form_definition = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
      clean_up;
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

{ Set intial values for form status.  Values in form status change as the
{ application program and terminal user interact with a form. Values in the
{ form definition do not change after the form definition is ended.

    p_form_status^.p_form_definition := p_form_definition;
    p_form_status^.defined_dynamically := TRUE;
    p_form_status^.design_display_attribute := $fdt$display_attribute_set [];
    p_form_status^.design_variable_name := fdc$system_design_variable_name;
    p_form_status^.p_display_definitions := NIL;
    p_form_status^.p_event_definitions := NIL;
    p_form_status^.p_form_image := NIL;
    p_form_status^.p_form_object_definitions := NIL;
    p_form_status^.p_form_table_definitions := NIL;
    p_form_status^.p_form_record_definitions := NIL;
    p_form_status^.p_form_variable_definitions := NIL;
    p_form_status^.validate_variable_values := FALSE;
    p_form_status^.fast_form_creation := FALSE;

{ Set form default attributes.

    p_form_definition^.coordinate_system := fdc$system_coordinate_system;
    p_form_definition^.comment_definitions.active_number := 0;
    p_form_definition^.comment_definitions.total_number := 0;
    p_form_definition^.display_attribute := $fdt$display_attribute_set
          [fdc$black_background, fdc$white_foreground, fdc$protect, fdc$display_left_to_right];
    p_form_definition^.display_definitions.active_number := 0;
    p_form_definition^.display_definitions.total_number := 0;
    p_form_definition^.error_message_form := osc$null_name;
    p_form_definition^.event_definitions.active_number := 0;
    p_form_definition^.event_definitions.total_number := 0;
    p_form_definition^.event_form_definition.key := fdc$no_event_form;
    p_form_definition^.first_input_object_defined := FALSE;
    p_form_definition^.form_area.key := fdc$screen_area;
    p_form_definition^.form_ended := FALSE;
    p_form_definition^.form_name := osc$null_name;
    p_form_definition^.form_version := 1;
    p_form_definition^.form_has_errors := TRUE;
    p_form_definition^.form_object_definitions.total_number := 0;
    p_form_definition^.form_object_definitions.active_number := 0;
    p_form_definition^.form_table_definitions.total_number := 0;
    p_form_definition^.form_table_definitions.active_number := 0;
    p_form_definition^.form_variable_definitions.total_number := 0;
    p_form_definition^.form_variable_definitions.active_number := 0;
    p_form_definition^.help_definition.key := fdc$no_help_response;
    p_form_definition^.help_message_form := osc$null_name;
    p_form_definition^.invalid_data_character.defined := FALSE;
    p_form_definition^.language := osc$default_natural_language;
    p_form_definition^.hidden_editing := FALSE;
    p_form_definition^.processor := fdc$system_form_processor;
    p_form_definition^.program_record_length := 0;
    p_form_definition^.record_deck_name := osc$null_name;
    p_form_definition^.record_definitions.active_number := 0;
    p_form_definition^.record_definitions.total_number := 0;
    p_form_definition^.record_name := osc$null_name;
    p_form_definition^.record_type := fdc$system_record_type;
    p_form_definition^.record_version := 1;
    p_form_definition^.screen_formatting_version := fdc$screen_formatting_version;
    p_form_definition^.screen_record_length := 0;

{ Set user application form attributes.

    change_form (p_form_status, p_form_definition, form_attributes, status);
    IF NOT status.normal THEN
      clean_up;
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

{ The form image is used to check for overlayed objects.
{ When an object is created, the character positions
{ occupied by the object are set non-space.

    IF NOT p_form_status^.fast_form_creation THEN
      ALLOCATE p_form_image;
      IF p_form_image = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        clean_up;
        RETURN;
      IFEND;

      p_form_status^.p_form_image := p_form_image;
      FOR y_position := 1 TO fdc$maximum_x_position DO
        p_form_image^ [y_position] := ' ';
      FOREND;
    IFEND;
  PROCEND fdp$create_form;

?? TITLE := 'fdp$edit_form', EJECT ??
*copyc fdh$edit_form

  PROCEDURE [XDCL] fdp$edit_form
    (    form_identifier: fdt$form_identifier;
     VAR status: ost$status);

    VAR
      current_x_position: fdt$x_position,
      current_y_position: fdt$y_position,
      end_object_x_position: fdt$x_position,
      end_object_y_position: fdt$y_position,
      object_index: fdt$object_index,
      p_form_image: ^fdt$form_image,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_status: ^fdt$form_status,
      x_position: fdt$x_position,
      y_position: fdt$y_position;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$edit_form;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$edit_form;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    p_form_image := NIL;
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_status^.p_form_definition^.form_ended := FALSE;
    IF p_form_status^.p_form_image <> NIL THEN
      RETURN;
    IFEND;

    IF p_form_status^.fast_form_creation THEN
      RETURN;
    IFEND;

{ The form image is used to check for overlayed objects.
{ When an object is created, the character positions
{ occupied by the object are set non-space.

    ALLOCATE p_form_image;
    IF p_form_image = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
      RETURN;
    IFEND;

    p_form_status^.p_form_image := p_form_image;
    FOR y_position := 1 TO fdc$maximum_y_position DO
      p_form_image^ [y_position] := ' ';
    FOREND;

{ Create character image from objects on form.

    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    FOR object_index := 1 TO p_form_status^.p_form_definition^.form_object_definitions.active_number DO
      fdp$add_object_to_form_image (p_form_image, ^p_form_object_definitions^ [object_index]);
    FOREND;

  PROCEND fdp$edit_form;

?? TITLE := 'fdp$end_form', EJECT ??
*copyc fdh$end_form

  PROCEDURE [XDCL] fdp$end_form
    (    form_identifier: fdt$form_identifier;
         p_sequence: ^SEQ ( * );
     VAR number_errors: fdt$number_errors;
     VAR p_errors: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      error_size: integer,
      number_objects: fdt$number_objects,
      number_variables: fdt$number_variables,
      object_errors: fdt$number_errors,
      p_form_definition: ^fdt$form_definition,
      p_form_module: ^fdt$form_module,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_status: ^fdt$form_status,
      p_form_table_definitions: ^array [1 .. * ] of fdt$form_table_definition,
      p_form_variable_definitions: ^array [1 .. * ] of fdt$form_variable_definition,
      variable_status: fdt$variable_status;

?? NEWTITLE := 'check_for_dangling_objects', EJECT ??

    PROCEDURE check_for_dangling_objects;

      { Search the object definitions to make sure that all variable objects are linked to variables.

      VAR
        object_index: fdt$object_index,
        p_form_object_definition: ^fdt$form_object_definition,
        p_error_header: ^fdt$error_header,
        p_error_no_variable_def: ^fdt$error_no_variable_def;

    /examine_objects/
      FOR object_index := 1 TO number_objects DO
        p_form_object_definition := ^p_form_object_definitions^ [object_index];
        CASE p_form_object_definition^.key OF

        = fdc$form_stored_variable =
          IF p_form_object_definition^.stored_variable_exists THEN
            CYCLE /examine_objects/;
          IFEND;

        = fdc$form_variable_text =
          IF p_form_object_definition^.text_variable_exists THEN
            CYCLE /examine_objects/;
          IFEND;

        = fdc$form_variable_text_box =
          IF p_form_object_definition^.variable_box_variable_exists THEN
            CYCLE /examine_objects/;
          IFEND;

        ELSE { Ignore object.
          CYCLE /examine_objects/;
        CASEND;

{ The object does not have a variable definition.

        IF p_errors <> NIL THEN
          NEXT p_error_header IN p_errors;
          IF p_error_header <> NIL THEN
            p_error_header^.key := fdc$no_variable_definition;
            NEXT p_error_no_variable_def IN p_errors;
            IF p_error_no_variable_def <> NIL THEN
              p_error_no_variable_def^.variable_name := p_form_object_definition^.name;
              p_error_no_variable_def^.occurrence := p_form_object_definition^.occurrence;
            IFEND;
          IFEND;
        IFEND;
        number_errors := number_errors + 1;
      FOREND /examine_objects/;

    PROCEND check_for_dangling_objects;

?? OLDTITLE ??
?? NEWTITLE := 'compute_form_area', EJECT ??

    PROCEDURE compute_form_area;

      VAR
        last_x_position: fdt$x_position,
        last_y_position: fdt$y_position,
        new_x_position: fdt$x_position,
        new_y_position: fdt$y_position,
        object_index: fdt$object_index,
        output_format_key: fdt$output_format_key,
        p_form_object_definition: ^fdt$form_object_definition,
        p_form_variable_definition: ^fdt$form_variable_definition,
        p_text: ^fdt$text,
        x_position: fdt$x_position,
        y_position: fdt$y_position;

      CASE p_form_definition^.form_area.key OF

      = fdc$defined_area =

{ The user has specified the area explicitly.

        p_form_definition^.width := p_form_definition^.form_area.width;
        p_form_definition^.height := p_form_definition^.form_area.height;
        p_form_definition^.x_position := p_form_definition^.form_area.x_position;
        p_form_definition^.y_position := p_form_definition^.form_area.y_position;
        p_form_status^.form_x_position := p_form_definition^.form_area.x_position;
        p_form_status^.form_y_position := p_form_definition^.form_area.y_position;

      = fdc$screen_area =

{ The user has specified the area implicitly. The area occupied by the objects
{ on the form determine the size of the screen the form needs for display.
{ Compute largest x, y positions used by objects on form. Use this as form size.

        p_form_definition^.x_position := fdc$initial_x_position;
        p_form_definition^.y_position := fdc$initial_y_position;

        IF p_form_object_definitions = NIL THEN
          p_form_definition^.width := 1;
          p_form_definition^.height := 1;
          RETURN;
        IFEND;

        last_x_position := 1;
        last_y_position := 1;
        FOR object_index := 1 TO p_form_definition^.form_object_definitions.active_number DO
          p_form_object_definition := ^p_form_object_definitions^ [object_index];
          x_position := p_form_object_definition^.x_position;
          y_position := p_form_object_definition^.y_position;
          CASE p_form_object_definition^.key OF

          = fdc$form_box =
            new_x_position := x_position + p_form_object_definition^.box_width - 1;
            IF new_x_position > last_x_position THEN
              last_x_position := new_x_position;
            IFEND;
            new_y_position := y_position + p_form_object_definition^.box_height - 1;
            IF new_y_position > last_y_position THEN
              last_y_position := new_y_position;
            IFEND;

          = fdc$form_constant_text =
            new_x_position := x_position + p_form_object_definition^.constant_text_width - 1;
            IF new_x_position > last_x_position THEN
              last_x_position := new_x_position;
            IFEND;
            IF y_position > last_y_position THEN
              last_y_position := y_position;
            IFEND;

          = fdc$form_constant_text_box =
            new_x_position := x_position + p_form_object_definition^.constant_box_width - 1;
            IF new_x_position > last_x_position THEN
              last_x_position := new_x_position;
            IFEND;
            new_y_position := y_position + p_form_object_definition^.constant_box_height - 1;
            IF new_y_position > last_y_position THEN
              last_y_position := new_y_position;
            IFEND;

          = fdc$form_table =
            new_x_position := p_form_object_definition^.table_width - 1 + x_position;
            new_y_position := p_form_object_definition^.table_height - 1 + y_position;
            IF new_x_position > last_x_position THEN
              last_x_position := new_x_position;
            IFEND;
            IF new_y_position > last_y_position THEN
              last_y_position := new_y_position;
            IFEND;

          = fdc$form_line =
            new_x_position := x_position + p_form_object_definition^.x_increment;
            IF new_x_position > last_x_position THEN
              last_x_position := new_x_position;
            IFEND;
            new_y_position := y_position + p_form_object_definition^.y_increment;
            IF new_y_position > last_y_position THEN
              last_y_position := new_y_position;
            IFEND;

          = fdc$form_variable_text =
            new_x_position := x_position + p_form_object_definition^.text_variable_width - 1;
            IF new_x_position > last_x_position THEN
              last_x_position := new_x_position;
            IFEND;

          = fdc$form_variable_text_box =
            new_x_position := x_position + p_form_object_definition^.variable_box_width - 1;
            IF new_x_position > last_x_position THEN
              last_x_position := new_x_position;
            IFEND;
            new_y_position := y_position + p_form_object_definition^.variable_box_height - 1;
            IF new_y_position > last_y_position THEN
              last_y_position := new_y_position;
            IFEND;

          ELSE { Ignore objects created by Screen Formatting internally.
          CASEND;
        FOREND;

        p_form_definition^.width := last_x_position;
        p_form_definition^.height := last_y_position;

      ELSE
      CASEND;
    PROCEND compute_form_area;

?? OLDTITLE ??
?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$end_form;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$end_form;
        IFEND;

      = pmc$block_exit_processing =
        handler_status.normal := TRUE;
        RETURN;
      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE ??
?? NEWTITLE := 'create_integer_output_format', EJECT ??

    PROCEDURE [INLINE] create_integer_output_format
      (    width: fdt$width;
       VAR output_format: fdt$output_format);

      CASE output_format.key OF

      = fdc$character_output_format, fdc$undefined_output_format =

{ Set default integer output format. Use minus sign if number is negative.
{ If number equals zero, output spaces.

        output_format.key := fdc$integer_output_format;
        output_format.integer_output_format.field_width := width;
        output_format.integer_output_format.sign_treatment := mlc$minus_if_negative;
        output_format.integer_output_format.minimum_output_digits := 0;

      ELSE { Ignore other output formats.
      CASEND;
    PROCEND create_integer_output_format;

?? OLDTITLE ??
?? NEWTITLE := 'create_real_output_format', EJECT ??

    PROCEDURE [INLINE] create_real_output_format
      (    width: fdt$width;
       VAR output_format: fdt$output_format);

      VAR
        n: integer;

      CASE output_format.key OF

      = fdc$character_output_format, fdc$undefined_output_format =

{ Set default real output format.  Use FORTRAN G format.
{ If number equals zero, output spaces.  Put decimal point in middle
{ of field.

        output_format.key := fdc$g_output_format;
        output_format.float_output_format.field_width := width;
        n := (width DIV 2) - 1;
        IF n < 0 THEN
          n := 0;
        IFEND;
        output_format.float_output_format.digits_right_decimal := n;
        output_format.float_output_format.sign_treatment := mlc$minus_if_negative;
        output_format.float_output_format.suppress_zero := TRUE;

      ELSE { Ignore other output formats.
      CASEND;
    PROCEND create_real_output_format;

?? OLDTITLE ??
?? NEWTITLE := 'create_stored_objects', EJECT ??

    PROCEDURE create_stored_objects;

      VAR
        name_exists: boolean,
        object_index: fdt$object_index,
        occurrence_exists: boolean,
        occurrence: fdt$occurrence,
        p_first_object_definition: ^fdt$form_object_definition,
        p_form_object_definition: ^fdt$form_object_definition,
        p_form_table_definition: ^fdt$form_table_definition,
        p_table_objects: ^array [1 .. * ] of fdt$table_object,
        p_table_variables: ^array [1 .. * ] of fdt$table_variable,
        p_table_variable: ^fdt$table_variable,
        stored_occurrence: fdt$occurrence,
        table_index: fdt$table_index,
        table_variable_index: fdt$table_variable_index,
        visible_occurrence: fdt$occurrence;

{ Create stored objects that the user did not specify during form definition.
{ Stored objects exist when a table has more stored objects than visible objects.

    /find_table/
      FOR table_index := 1 TO p_form_definition^.form_table_definitions.active_number DO
        p_form_table_definition := ^p_form_table_definitions^ [table_index];
        IF NOT p_form_table_definition^.visible_occurrence_defined THEN
          CYCLE /find_table/;
        IFEND;

        visible_occurrence := p_form_table_definition^.visible_occurrence;
        stored_occurrence := p_form_table_definition^.stored_occurrence;
        p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
              p_form_status^.p_form_module);
        IF p_table_variables = NIL THEN
          CYCLE /find_table/;
        IFEND;

        FOR table_variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
          p_table_variable := ^p_table_variables^ [table_variable_index];

{ The default value for all Screen Formatting created stored objects is the value of first occurrence.

          fdp$find_object_definition (p_table_variable^.name, 1, p_form_status^.p_form_object_definitions,
                p_form_definition^.form_object_definitions.active_number, p_first_object_definition,
                object_index, name_exists, occurrence_exists);
          IF name_exists AND occurrence_exists THEN

          /find_table_objects/
            FOR occurrence := visible_occurrence + 1 TO stored_occurrence DO
              p_table_variable := ^p_table_variables^ [table_variable_index];
              fdp$find_object_definition (p_table_variable^.name, occurrence,
                    p_form_status^.p_form_object_definitions, p_form_definition^.form_object_definitions.
                    active_number, p_form_object_definition, object_index, name_exists, occurrence_exists);
              IF ((NOT name_exists) OR (NOT occurrence_exists)) THEN
                fdp$allocate_object (p_form_status, p_form_object_definition, object_index, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                p_form_object_definition^ := p_first_object_definition^;
                p_form_object_definition^.occurrence := occurrence;
                p_form_object_definition^.key := fdc$form_stored_variable;
                p_form_object_definition^.stored_variable_text :=
                      p_first_object_definition^.text_variable_text;
              IFEND;
            FOREND /find_table_objects/;
          IFEND;
        FOREND;
      FOREND /find_table/;
    PROCEND create_stored_objects;

?? OLDTITLE ??
?? NEWTITLE := 'create_variable_display', EJECT ??

    PROCEDURE [INLINE] create_variable_display
      (    io_mode: fdt$io_mode;
       VAR variable_display_attributes: fdt$display_attribute_set);


      CASE io_mode OF

      = fdc$terminal_input =

{ The terminal user does not see what he/she types.  This is used for passwords.

        variable_display_attributes := variable_display_attributes - $fdt$display_attribute_set
              [fdc$protect] + $fdt$display_attribute_set [fdc$hidden];

      = fdc$terminal_input_output =

{ Input variables must not be protected.

        variable_display_attributes := variable_display_attributes - $fdt$display_attribute_set [fdc$protect];

      = fdc$terminal_output =

{ Output variables must be protected.

        variable_display_attributes := variable_display_attributes + $fdt$display_attribute_set [fdc$protect];

      ELSE { Ignore other io modes.
      CASEND;

    PROCEND create_variable_display;

?? OLDTITLE ??
?? NEWTITLE := 'create_variable_error', EJECT ??

{  PURPOSE:
{    This procedure sets defaults for displaying a variable when an error occurs.
{  DESIGN:
{    If no error attributes were set by the user, use Screen Formatting
{    default of inverse video.

    PROCEDURE [INLINE] create_variable_error
      (    p_form_variable_definition: {output} ^fdt$form_variable_definition);

          IF p_form_variable_definition^.error_displays = $fdt$display_attribute_set [] THEN
            CASE p_form_variable_definition^.io_mode OF

            = fdc$terminal_input, fdc$terminal_input_output =
              p_form_variable_definition^.error_displays := $fdt$display_attribute_set
                    [fdc$inverse_video, fdc$underline];

            = fdc$terminal_output =
              p_form_variable_definition^.error_displays := $fdt$display_attribute_set [fdc$inverse_video];

            ELSE { Ignore other io modes.
            CASEND;
          IFEND;

    PROCEND create_variable_error;

?? OLDTITLE ??
?? NEWTITLE := 'create_variable_format', EJECT ??

{  PURPOSE:
{    This procedure sets defaults for variable program and display formats.

    PROCEDURE create_variable_format
      (    p_form_variable_definition: {output} ^fdt$form_variable_definition;
           p_form_module: ^fdt$form_module);

      VAR
        cobol_description: fdt$cobol_description,
        ignore_status: ost$status,
        number: fdt$picture,
        number_length: integer,
        p_added_variable_definition: ^fdt$added_variable_definition,
        picture: fdt$picture,
        picture_length: integer;

      CASE p_form_variable_definition^.program_data_type OF

      = fdc$program_character_type, fdc$program_upper_case_type =

{ If the user did not define any program length use the length of the
{ object on the screen.

        IF p_form_variable_definition^.program_variable_length = 0 THEN
          p_form_variable_definition^.program_variable_length :=
                p_form_variable_definition^.screen_variable_length;
        IFEND;

{ The length of the record space for the object on the screen must be at least
{ as long as the length of the program variable.

        IF p_form_variable_definition^.program_variable_length >
              p_form_variable_definition^.screen_variable_length THEN
          p_form_variable_definition^.screen_variable_length :=
              p_form_variable_definition^.program_variable_length;
        IFEND;

      = fdc$program_real_type =
        create_real_output_format (p_form_variable_definition^.screen_variable_length,
              p_form_variable_definition^.output_format);

      = fdc$program_integer_type =
        create_integer_output_format (p_form_variable_definition^.screen_variable_length,
             p_form_variable_definition^.output_format);

      ELSE { fdc$program_cobol_type

        fdp$locate_added_variable_facts  (p_form_module, p_form_variable_definition,
             p_added_variable_definition);

{ If the user did not provide a COBOL definition, use a PICTURE clause with
{ alphanumeric characters as long as the length of the object on the screen.

        IF NOT p_added_variable_definition^.form_cobol_display_clause.defined THEN
          STRINGREP (number, number_length, p_form_variable_definition^.screen_variable_length);
          STRINGREP (picture, picture_length, 'X(', number (2, number_length - 1), ')');
          fdp$create_cobol_description (picture (1, picture_length),
                fdc$display_usage, cobol_description, ignore_status);

{ No errors can occur on this simple PICTURE clause.

          p_added_variable_definition^.form_cobol_display_clause.defined := TRUE;
           p_added_variable_definition^.form_cobol_display_clause.cobol_display_clause.picture :=
                picture (1, picture_length);
          p_added_variable_definition^.display_cobol_description := cobol_description;
        IFEND;

        IF NOT p_added_variable_definition^.form_cobol_program_clause.defined THEN

{ If the user did not define any program length use the length of the
{ object on the screen.

        IF p_form_variable_definition^.program_variable_length = 0 THEN
          p_form_variable_definition^.program_variable_length :=
                p_form_variable_definition^.screen_variable_length;
        IFEND;

          STRINGREP (number, number_length, p_form_variable_definition^.program_variable_length);
          STRINGREP (picture, picture_length, 'X(', number (2, number_length - 1), ')');
          fdp$create_cobol_description (picture (1, picture_length),
                fdc$display_usage, cobol_description, ignore_status);

{ No errors can occur on this simple PICTURE clause.

          p_added_variable_definition^.form_cobol_program_clause.defined := TRUE;
          p_added_variable_definition^.form_cobol_program_clause.cobol_program_clause.picture :=
                picture (1, picture_length);
          p_added_variable_definition^.form_cobol_program_clause.cobol_program_clause.usage :=
                fdc$display_usage;
          p_added_variable_definition^.program_cobol_description := cobol_description;
        IFEND;
      CASEND;

    PROCEND create_variable_format;

?? OLDTITLE ??
?? NEWTITLE := 'find_first_input_position', EJECT ??

    PROCEDURE find_first_input_position;

      VAR
        object_index: fdt$object_index,
        p_form_object_definition: ^fdt$form_object_definition;

      p_form_definition^.first_input_object_defined := FALSE;

{ Determine first position on the form to place the cursor by default.

    /find_input_object/
      FOR object_index := 1 TO p_form_definition^.form_object_definitions.active_number DO
        p_form_object_definition := ^p_form_object_definitions^ [object_index];
        CASE p_form_object_definition^.key OF

        = fdc$form_variable_text_box =
          IF p_form_object_definition^.variable_box_variable_exists THEN
            IF ((p_form_variable_definitions^ [p_form_object_definition^.variable_box_variable_index].
                  io_mode = fdc$terminal_input) OR (p_form_variable_definitions^
                  [p_form_object_definition^.variable_box_variable_index].io_mode =
                  fdc$terminal_input_output)) THEN
              p_form_definition^.first_input_object_defined := TRUE;
              p_form_definition^.first_input_object_index := object_index;
              EXIT /find_input_object/;
            IFEND;
          IFEND;

        = fdc$form_variable_text =
          IF p_form_object_definition^.text_variable_exists THEN
            IF ((p_form_variable_definitions^ [p_form_object_definition^.text_variable_index].io_mode =
                  fdc$terminal_input) OR (p_form_variable_definitions^
                  [p_form_object_definition^.text_variable_index].io_mode = fdc$terminal_input_output)) THEN
              p_form_definition^.first_input_object_defined := TRUE;
              p_form_definition^.first_input_object_index := object_index;
              EXIT /find_input_object/;
            IFEND;
          IFEND;

        ELSE { Ignore objects that are not variables.
        CASEND;
      FOREND /find_input_object/;
    PROCEND find_first_input_position;

?? OLDTITLE ??
?? NEWTITLE := 'generate_form_record', EJECT ??

    PROCEDURE generate_form_record;

      VAR
        form_processor: fdt$form_processor,
        object_index: fdt$object_index,
        occurrence: fdt$occurrence,
        p_form_object_definition: ^fdt$form_object_definition,
        p_form_table_definition: ^fdt$form_table_definition,
        p_form_variable_definition: ^fdt$form_variable_definition,
        p_record_definitions: ^array [1 .. * ] of fdt$variable_record_definition,
        p_table_object: ^fdt$table_object,
        p_table_objects: ^array [1 .. * ] of fdt$table_object,
        p_table_variables: ^array [1 .. * ] of fdt$table_variable,
        p_table_variable: ^fdt$table_variable,
        program_record_length: fdt$record_length,
        program_record_position: fdt$record_position,
        record_index: fdt$object_index,
        record_count: fdt$number_objects,
        screen_record_length: fdt$record_length,
        screen_record_position: fdt$record_position,
        screen_variable_length: fdt$screen_variable_length,
        program_variable_length: fdt$program_variable_length,
        table_index: fdt$table_index,
        table_variable_index: fdt$table_variable_index,
        variable_index: fdt$variable_index;

?? NEWTITLE := 'compute_program_record_position', EJECT ??

      PROCEDURE [INLINE] compute_program_record_position
        (VAR record_position: fdt$record_position);

        VAR
          byte_offset: 0 .. 7,
          byte_increment: 0 .. 7,
          program_data_type: fdt$program_data_type;

        get_compatible_data_type (p_form_variable_definition, p_form_module, program_data_type);
        CASE program_data_type OF

        = fdc$program_integer_type, fdc$program_real_type =

{ For real or integer data type, adjust record position to a word boundary.

          byte_offset := (program_record_position - 1) MOD 8;
          IF byte_offset <> 0 THEN
            byte_increment := 8 - byte_offset;
          ELSE
            byte_increment := 0;
          IFEND;
        ELSE

{ Other data types do not need adjustment to word boundary.

          byte_increment := 0;
        CASEND;

        record_position := program_record_position + byte_increment;
        program_record_position := program_record_position + program_variable_length + byte_increment;
        program_record_length := program_record_length + program_variable_length + byte_increment;

      PROCEND compute_program_record_position;

?? OLDTITLE ??
?? NEWTITLE := 'generate_cobol_table', EJECT ??

      PROCEDURE generate_cobol_table;

{ Generate record definitions. Determine record  size  to  allocate when form is displayed.
{ Each record of table contains one occurrence of each variable in the table.
{ COBOL and CYBIL record definitions are fully compatible in their data structures.

        VAR
          program_data_type: fdt$program_data_type,
          table_offset: 0 .. 7,
          table_word_aligned: boolean;

      /generate_tables/
        FOR table_index := 1 TO p_form_definition^.form_table_definitions.active_number DO
          p_form_table_definition := ^p_form_table_definitions^ [table_index];

          p_record_definitions^ [record_count].key := fdc$record_table;
          p_record_definitions^ [record_count].table_index := table_index;
          record_count := record_count + 1;
          p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
                p_form_module);
          table_word_aligned := FALSE;

        /generate_table_occurrences/
          FOR occurrence := 1 TO p_form_table_definition^.stored_occurrence DO

          /generate_table_variables/
            FOR table_variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
              p_table_variable := ^p_table_variables^ [table_variable_index];
              p_form_variable_definition := ^p_form_variable_definitions^ [p_table_variable^.variable_index];
              program_variable_length := p_form_variable_definition^.program_variable_length;
              p_table_objects := fdp$ptr_table_objects (p_table_variable^.table_objects, p_form_module);
              p_table_object := ^p_table_objects^ [occurrence];
              compute_program_record_position (p_table_object^.program_record_position);
              p_table_object^.screen_record_position := screen_record_position;
              screen_variable_length := p_form_variable_definition^.screen_variable_length;
              screen_record_position := screen_record_position + screen_variable_length;
              screen_record_length := screen_record_length + screen_variable_length;
              get_compatible_data_type (p_form_variable_definition, p_form_module, program_data_type);
              CASE program_data_type OF

              = fdc$program_integer_type, fdc$program_real_type =
                table_word_aligned := TRUE;

              ELSE {Other data types do not need adjustment to word boundary.
              CASEND;

            FOREND /generate_table_variables/;
          FOREND /generate_table_occurrences/;

          IF table_word_aligned THEN
            table_offset := (program_record_position - 1) MOD 8;
            IF table_offset <> 0 THEN
              program_record_position := program_record_position + 8 - table_offset;
              program_record_length := program_record_length + 8 - table_offset;
            IFEND;
          IFEND;

        FOREND /generate_tables/;

      PROCEND generate_cobol_table;

?? OLDTITLE ??
?? NEWTITLE := 'generate_fortran_table', EJECT ??

      PROCEDURE generate_fortran_table;

{ Generate record definitions. Determine record  size  to  allocate when form is displayed.
{ FORTRAN does not have a record data structure like COBOL and CYBIL.  Each element of an
{ array (DIMENSION statement) contains only one variable.

      /generate_tables/
        FOR table_index := 1 TO p_form_definition^.form_table_definitions.active_number DO
          p_form_table_definition := ^p_form_table_definitions^ [table_index];

          p_record_definitions^ [record_count].key := fdc$record_table;
          p_record_definitions^ [record_count].table_index := table_index;
          record_count := record_count + 1;
          p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
                p_form_module);

        /generate_table_variables/
          FOR table_variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
            p_table_variable := ^p_table_variables^ [table_variable_index];
            p_form_variable_definition := ^p_form_variable_definitions^ [p_table_variable^.variable_index];

          /generate_table_occurrences/
            FOR occurrence := 1 TO p_form_table_definition^.stored_occurrence DO
              program_variable_length := p_form_variable_definition^.program_variable_length;
              p_table_objects := fdp$ptr_table_objects (p_table_variable^.table_objects, p_form_module);
              p_table_object := ^p_table_objects^ [occurrence];
              compute_program_record_position (p_table_object^.program_record_position);
              p_table_object^.screen_record_position := screen_record_position;
              screen_variable_length := p_form_variable_definition^.screen_variable_length;
              screen_record_position := screen_record_position + screen_variable_length;
              screen_record_length := screen_record_length + screen_variable_length;
            FOREND /generate_table_occurrences/;
          FOREND /generate_table_variables/;
        FOREND /generate_tables/;
      PROCEND generate_fortran_table;

?? OLDTITLE, EJECT ??

{ Determine size of array for record definitions.
{ Count the number of tables and variables.

      record_count := p_form_definition^.form_table_definitions.active_number;

    /count_variables/
      FOR variable_index := 1 TO p_form_definition^.form_variable_definitions.active_number DO
        p_form_variable_definition := ^p_form_variable_definitions^ [variable_index];
        IF NOT p_form_variable_definition^.table_exists THEN
          record_count := record_count + 1;
        IFEND;
      FOREND /count_variables/;

{ Allocate space for record definitions. The upper bound of the array is
{ the number of tables plus the number of variables that  do not belong to
{ to a table.

      IF ((record_count = 0) OR (number_errors <> 0)) THEN
        fdp$rel_record_definitions (NIL, p_form_status);
        p_form_definition^.program_record_length := 0;
        p_form_definition^.screen_record_length := 0;
        RETURN;
      IFEND;

      form_processor := p_form_definition^.processor;
      program_record_length := 0;
      program_record_position := 1;
      screen_record_length := 0;
      screen_record_position := 1;

      NEXT p_record_definitions: [1 .. record_count] IN p_form_status^.p_form_module;
      IF p_record_definitions = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

      fdp$rel_record_definitions (p_record_definitions, p_form_status);
      p_form_definition^.record_definitions.active_number := record_count;
      record_count := 1;
      CASE form_processor OF

      = fdc$ansi_fortran_processor, fdc$cdc_fortran_processor,
              fdc$extended_fortran_processor =
        generate_fortran_table;

      ELSE

{ A COBOL table also works for CYBIL, PASCAL, SCL and UNKNOWN.

        generate_cobol_table;

      CASEND;

{ Set record length for program and screen records.

    /generate_variables/
      FOR variable_index := 1 TO p_form_definition^.form_variable_definitions.active_number DO
        p_form_variable_definition := ^p_form_variable_definitions^ [variable_index];

        IF NOT p_form_variable_definition^.table_exists THEN
          program_variable_length := p_form_variable_definition^.program_variable_length;
          compute_program_record_position (p_form_variable_definition^.program_record_position);
          p_form_variable_definition^.screen_record_position := screen_record_position;
          screen_variable_length := p_form_variable_definition^.screen_variable_length;
          screen_record_position := screen_record_position + screen_variable_length;
          screen_record_length := screen_record_length + screen_variable_length;
          p_record_definitions^ [record_count].key := fdc$record_variable;
          p_record_definitions^ [record_count].variable_index := variable_index;
          record_count := record_count + 1;
        IFEND;
      FOREND /generate_variables/;

      p_form_definition^.program_record_length := program_record_length;
      p_form_definition^.screen_record_length := screen_record_length;
    PROCEND generate_form_record;

?? OLDTITLE ??
?? NEWTITLE := 'get_compatible_data_type', EJECT ??

{  PURPOSE:
{    Map a COBOL data type to a basic Screen Formatting data type.
{  DESIGN:
{    COBOL computational-1 is mapped to real.
{    COBOL computational with length of an integer is mapped to integer.
{    Otherwise the COBOL type is mapped to character.

  PROCEDURE [INLINE] get_compatible_data_type
    (    p_form_variable_definition: ^fdt$form_variable_definition;
         p_form_module: ^fdt$form_module;
     VAR program_data_type: fdt$program_data_type);

  VAR
    p_added_variable_definition:^fdt$added_variable_definition;

  IF p_form_variable_definition^.program_data_type <> fdc$program_cobol_type THEN
    program_data_type := p_form_variable_definition^.program_data_type;
    RETURN;
  IFEND;

  fdp$locate_added_variable_facts  (p_form_module, p_form_variable_definition,
             p_added_variable_definition);
  CASE p_added_variable_definition^.program_cobol_description.cobol_usage OF

  = fdc$cobol_usage_single =
    program_data_type := fdc$program_real_type;

  = fdc$cobol_usage_binary =
    IF p_added_variable_definition^.program_cobol_description.size = fdc$integer_length THEN
      program_data_type := fdc$program_integer_type;
    ELSE
      program_data_type := fdc$program_character_type;
    IFEND;

  ELSE
    program_data_type := fdc$program_character_type;
  CASEND;

PROCEND get_compatible_data_type;

?? OLDTITLE ??
?? NEWTITLE := 'link_text_boxes', EJECT ??

    PROCEDURE link_text_boxes;

      VAR
        current_height: fdt$height,
        fragment_object_index: fdt$object_index,
        p_fragment_object_definition: ^fdt$form_object_definition,
        p_last_fragment: ^fdt$form_object_definition,
        p_text_box_object_definition: ^fdt$form_object_definition,
        text_box_object_index: fdt$object_index,
        text_box_x_position: fdt$x_position,
        text_box_y_position: fdt$y_position;

{ Text boxes consists of a number of objects.  These objects are called fragments.
{ Their is one fragment for each line of the text box.  The first fragment is called
{ the parent.  Linking the fragments makes processing easy during terminal user interaction
{ with the form since no searches are needed.

    /find_text_boxes/
      FOR text_box_object_index := 1 TO number_objects DO
        p_text_box_object_definition := ^p_form_object_definitions^ [text_box_object_index];
        CASE p_text_box_object_definition^.key OF

        = fdc$form_constant_text_box =

          IF p_text_box_object_definition^.constant_box_height = 1 THEN
            p_text_box_object_definition^.constant_box_fragment_index := 0;

          ELSE
            text_box_x_position := p_text_box_object_definition^.x_position;
            current_height := 2;
            text_box_y_position := p_text_box_object_definition^.y_position + 1;
            p_last_fragment := NIL;

          /find_constant_fragments/

            FOR fragment_object_index := text_box_object_index + 1 TO number_objects DO
              p_fragment_object_definition := ^p_form_object_definitions^ [fragment_object_index];
              IF p_fragment_object_definition^.key = fdc$form_text_box_fragment THEN
                IF p_fragment_object_definition^.x_position = text_box_x_position THEN
                  IF p_fragment_object_definition^.y_position = text_box_y_position THEN
                    p_fragment_object_definition^.parent_text_box_object_index := text_box_object_index;
                    p_fragment_object_definition^.display_attribute :=
                          p_text_box_object_definition^.display_attribute;
                    IF p_last_fragment <> NIL THEN
                      p_last_fragment^.next_fragment_object_index := fragment_object_index;
                    ELSE
                      p_text_box_object_definition^.constant_box_fragment_index := fragment_object_index;
                    IFEND;
                    IF current_height = p_text_box_object_definition^.constant_box_height THEN
                      p_fragment_object_definition^.next_fragment_object_index := 0;
                      EXIT /find_constant_fragments/;
                    IFEND;
                    current_height := current_height + 1;
                    text_box_y_position := text_box_y_position + 1;
                    p_last_fragment := p_fragment_object_definition;
                  IFEND;
                IFEND;
              IFEND;
            FOREND /find_constant_fragments/;
          IFEND;

        = fdc$form_variable_text_box =
          IF p_text_box_object_definition^.variable_box_height = 1 THEN
            p_text_box_object_definition^.variable_box_fragment_index := 0;

          ELSE
            text_box_x_position := p_text_box_object_definition^.x_position;
            current_height := 2;
            text_box_y_position := p_text_box_object_definition^.y_position + 1;
            p_last_fragment := NIL;

          /find_variable_fragments/
            FOR fragment_object_index := text_box_object_index + 1 TO number_objects DO
              p_fragment_object_definition := ^p_form_object_definitions^ [fragment_object_index];
              IF p_fragment_object_definition^.key = fdc$form_text_box_fragment THEN
                IF p_fragment_object_definition^.x_position = text_box_x_position THEN
                  IF p_fragment_object_definition^.y_position = text_box_y_position THEN
                    p_fragment_object_definition^.parent_text_box_object_index := text_box_object_index;
                    p_fragment_object_definition^.display_attribute :=
                          p_text_box_object_definition^.display_attribute;
                    IF p_last_fragment <> NIL THEN
                      p_last_fragment^.next_fragment_object_index := fragment_object_index;
                    ELSE
                      p_text_box_object_definition^.variable_box_fragment_index := fragment_object_index;
                    IFEND;
                    IF current_height = p_text_box_object_definition^.variable_box_height THEN
                      p_fragment_object_definition^.next_fragment_object_index := 0;
                      EXIT /find_variable_fragments/;
                    IFEND;
                    current_height := current_height + 1;
                    text_box_y_position := text_box_y_position + 1;
                    p_last_fragment := p_fragment_object_definition;
                  IFEND;
                IFEND;
              IFEND;
            FOREND /find_variable_fragments/;
          IFEND;
        ELSE
        CASEND;
      FOREND /find_text_boxes/;
    PROCEND link_text_boxes;

?? OLDTITLE ??
?? NEWTITLE := 'link_tables', EJECT ??

    PROCEDURE link_tables;

      VAR
        display_attribute_set: fdt$display_attribute_set,
        io_mode: fdt$io_mode,
        name_exists: boolean,
        object_index: fdt$object_index,
        object_width: integer,
        occurrence_exists: boolean,
        occurrence: fdt$occurrence,
        p_error_bad_table_object: ^fdt$error_unequal_tbl_obj_width,
        p_error_header: ^fdt$error_header,
        p_error_no_table_variable: ^fdt$error_no_table_variable,
        p_error_no_variable_object: ^fdt$error_no_variable_object,
        p_form_object_definition: ^fdt$form_object_definition,
        p_form_table_definition: ^fdt$form_table_definition,
        p_form_variable_definition: ^fdt$form_variable_definition,
        p_table_objects: ^array [1 .. * ] of fdt$table_object,
        p_table_variables: ^array [1 .. * ] of fdt$table_variable,
        p_table_variable: ^fdt$table_variable,
        stored_occurrence: fdt$occurrence,
        table_index: fdt$table_index,
        table_variable_index: fdt$table_variable_index,
        variable_index: fdt$variable_index,
        visible_occurrence: fdt$occurrence;

{ Link tables to variable definitions and form image objects. Linking makes processing
{ during terminal user interaction with the form very efficient.  No searching is needed.
{ Check that all required variable definitions have been made.
{ Set default values for attributes not specified by the user.

      FOR variable_index := 1 TO p_form_definition^.form_variable_definitions.active_number DO
        p_form_variable_definition := ^p_form_variable_definitions^ [variable_index];
        p_form_variable_definition^.object_exists := FALSE;
        p_form_variable_definition^.table_exists := FALSE;
      FOREND;

    /link_table_variables/
      FOR table_index := 1 TO p_form_definition^.form_table_definitions.active_number DO
        p_form_table_definition := ^p_form_table_definitions^ [table_index];

        IF NOT p_form_table_definition^.visible_occurrence_defined THEN
          p_form_table_definition^.visible_occurrence := p_form_table_definition^.stored_occurrence;
        IFEND;

        visible_occurrence := p_form_table_definition^.visible_occurrence;
        stored_occurrence := p_form_table_definition^.stored_occurrence;
        p_form_table_definition^.valid := TRUE;
        p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
              p_form_status^.p_form_module);
        IF p_table_variables = NIL THEN

{ No variable definitions exist for the table.

          IF p_errors <> NIL THEN
            NEXT p_error_header IN p_errors;
            IF p_error_header <> NIL THEN
              p_error_header^.key := fdc$no_table_variable;
              NEXT p_error_no_table_variable IN p_errors;
              IF p_error_no_table_variable <> NIL THEN
                p_error_no_table_variable^.table_name := p_form_table_definition^.name;
                p_error_no_table_variable^.variable_name := osc$null_name;
              IFEND;
            IFEND;
          IFEND;
          number_errors := number_errors + 1;
          p_form_table_definition^.valid := FALSE;
          CYCLE /link_table_variables/;
        IFEND;

      /find_table_variables/
        FOR table_variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
          p_table_variable := ^p_table_variables^ [table_variable_index];
          object_width := 0;

{ A variable definition must exist for a variable belonging to a table.

          fdp$find_variable_definition (p_table_variable^.name, p_form_variable_definitions, number_variables,
                p_form_variable_definition, variable_index, name_exists);
          IF NOT name_exists THEN

{ The variable definition does not exist for the  table.

            IF p_errors <> NIL THEN
              NEXT p_error_header IN p_errors;
              IF p_error_header <> NIL THEN
                p_error_header^.key := fdc$no_table_variable;
                NEXT p_error_no_table_variable IN p_errors;
                IF p_error_no_table_variable <> NIL THEN
                  p_error_no_table_variable^.table_name := p_form_table_definition^.name;
                  p_error_no_table_variable^.variable_name := p_table_variable^.name;
                IFEND;
              IFEND;
            IFEND;
            number_errors := number_errors + 1;
            p_form_table_definition^.valid := FALSE;
            CYCLE /find_table_variables/;
          IFEND;

          p_table_variable^.variable_exists := TRUE;
          p_table_variable^.variable_index := variable_index;
          p_form_variable_definition^.table_exists := TRUE;
          p_form_variable_definition^.table_index := table_index;
          io_mode := p_form_variable_definition^.io_mode;
          p_form_variable_definition^.valid := TRUE;
          create_variable_error (p_form_variable_definition);

{ Allocate space for occurrences of variable objects.

          NEXT p_table_objects: [1 .. stored_occurrence] IN p_form_status^.p_form_module;
          fdp$rel_table_objects (p_table_objects, p_form_module, p_table_variable^.table_objects);
          p_table_variable^.table_objects.active_number := stored_occurrence;
          IF p_table_objects = NIL THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
            RETURN;
          IFEND;

          FOR occurrence := 1 TO stored_occurrence DO
            p_table_objects^ [occurrence].object_exists := FALSE;
            p_table_objects^ [occurrence].object_index := 1;
          FOREND;

{ A variable that is used for input/output to the terminal screen must have
{ an associated object on the form image.

          IF io_mode <> fdc$program_input_output THEN

          /link_variable_occurrences/
            FOR occurrence := 1 TO visible_occurrence DO
              fdp$find_object_definition (p_table_variable^.name, occurrence, p_form_object_definitions,
                    number_objects, p_form_object_definition, object_index, name_exists, occurrence_exists);
              IF (name_exists AND occurrence_exists) THEN
                CASE p_form_object_definition^.key OF

                = fdc$form_variable_text =
                  p_table_objects^ [occurrence].object_exists := TRUE;
                  p_table_objects^ [occurrence].object_index := object_index;
                  p_form_object_definition^.text_variable_exists := TRUE;
                  p_form_object_definition^.text_variable_index := variable_index;
                  p_form_variable_definition^.screen_variable_length :=
                        p_form_object_definition^.text_variable_width;
                  IF (object_width = 0) THEN { First object_definition for this variable.
                    object_width := p_form_object_definition^.text_variable_width;
                  ELSE
                    IF (object_width <> p_form_object_definition^.text_variable_width) THEN

{ All objects for a table variable must have the same width.

                      IF p_errors <> NIL THEN
                        NEXT p_error_header IN p_errors;
                        IF p_error_header <> NIL THEN
                          p_error_header^.key := fdc$unequal_tbl_obj_width;
                          NEXT p_error_bad_table_object IN p_errors;
                          IF p_error_bad_table_object <> NIL THEN
                            p_error_bad_table_object^.table_name := p_form_table_definition^.name;
                            p_error_bad_table_object^.variable_name := p_table_variable^.name;
                            p_error_bad_table_object^.occurrence := occurrence;
                          IFEND;
                        IFEND;
                      IFEND;
                      number_errors := number_errors + 1;
                      p_form_table_definition^.valid := FALSE;
                      CYCLE /link_variable_occurrences/;
                    IFEND;
                  IFEND;

                  create_variable_format (p_form_variable_definition, p_form_module);
                  create_variable_display (io_mode, p_form_object_definition^.display_attribute);

                = fdc$form_variable_text_box =
                  p_table_objects^ [occurrence].object_exists := TRUE;
                  p_table_objects^ [occurrence].object_index := object_index;
                  p_form_object_definition^.variable_box_variable_exists := TRUE;
                  p_form_object_definition^.variable_box_variable_index := variable_index;
                  p_form_variable_definition^.screen_variable_length :=
                        p_form_object_definition^.variable_box_width *
                        p_form_object_definition^.variable_box_height;

                  create_variable_format (p_form_variable_definition, p_form_module);
                  create_variable_display (io_mode, p_form_object_definition^.display_attribute);

                = fdc$form_box, fdc$form_line, fdc$form_constant_text, fdc$form_constant_text_box,
                      fdc$form_table =
                  IF p_errors <> NIL THEN
                    NEXT p_error_header IN p_errors;
                    IF p_error_header <> NIL THEN
                      p_error_header^.key := fdc$no_variable_object;
                      NEXT p_error_no_variable_object IN p_errors;
                      IF p_error_no_variable_object <> NIL THEN
                        p_error_no_variable_object^.variable_name := p_form_variable_definition^.name;
                        p_error_no_variable_object^.occurrence := occurrence;
                      IFEND;
                    IFEND;
                  IFEND;
                  number_errors := number_errors + 1;
                  p_form_table_definition^.valid := FALSE;
                  p_form_variable_definition^.valid := FALSE;

                ELSE
                CASEND;

              ELSE

{ The variable does not have a matching image object.

                IF p_errors <> NIL THEN
                  NEXT p_error_header IN p_errors;
                  IF p_error_header <> NIL THEN
                    p_error_header^.key := fdc$no_variable_object;
                    NEXT p_error_no_variable_object IN p_errors;
                    IF p_error_no_variable_object <> NIL THEN
                      p_error_no_variable_object^.variable_name := p_form_variable_definition^.name;
                      p_error_no_variable_object^.occurrence := occurrence;
                    IFEND;
                  IFEND;
                IFEND;
                number_errors := number_errors + 1;
                p_form_table_definition^.valid := FALSE;
                p_form_variable_definition^.valid := FALSE;
              IFEND;
            FOREND /link_variable_occurrences/;

{ Link stored objects.

          /link_stored_occurrences/
            FOR occurrence := visible_occurrence + 1 TO stored_occurrence DO
              fdp$find_object_definition (p_table_variable^.name, occurrence, p_form_object_definitions,
                    number_objects, p_form_object_definition, object_index, name_exists, occurrence_exists);
              IF (name_exists AND occurrence_exists) THEN
                CASE p_form_object_definition^.key OF

                = fdc$form_stored_variable =
                  p_table_objects^ [occurrence].object_exists := TRUE;
                  p_table_objects^ [occurrence].object_index := object_index;
                  p_form_object_definition^.stored_variable_exists := TRUE;
                  p_form_object_definition^.stored_variable_index := variable_index;
                  create_variable_display (io_mode, p_form_object_definition^.display_attribute);

                ELSE

{ Invalid object.

                  IF p_errors <> NIL THEN
                    NEXT p_error_header IN p_errors;
                    IF p_error_header <> NIL THEN
                      p_error_header^.key := fdc$no_variable_object;
                      NEXT p_error_no_variable_object IN p_errors;
                      IF p_error_no_variable_object <> NIL THEN
                        p_error_no_variable_object^.variable_name := p_form_variable_definition^.name;
                        p_error_no_variable_object^.occurrence := occurrence;
                      IFEND;
                    IFEND;
                  IFEND;

                  number_errors := number_errors + 1;
                  p_form_table_definition^.valid := FALSE;
                  p_form_variable_definition^.valid := FALSE;
                CASEND;
              IFEND;
            FOREND /link_stored_occurrences/;
          IFEND;
        FOREND /find_table_variables/;
      FOREND /link_table_variables/;
    PROCEND link_tables;

?? OLDTITLE ??
?? NEWTITLE := 'link_variables', EJECT ??

    PROCEDURE link_variables;

      VAR
        display_attribute_set: fdt$display_attribute_set,
        io_mode: fdt$io_mode,
        name_exists: boolean,
        object_index: fdt$object_index,
        occurrence: fdt$occurrence,
        occurrence_exists: boolean,
        p_error_header: ^fdt$error_header,
        p_error_no_variable_object: ^fdt$error_no_variable_object,
        p_form_variable_definition: ^fdt$form_variable_definition,
        variable_index: fdt$variable_index;

    /process_variables/
      FOR variable_index := 1 TO number_variables DO
        p_form_variable_definition := ^p_form_variable_definitions^ [variable_index];

{ Variables belonging to a table are processed already.

        IF p_form_variable_definition^.table_exists THEN
          CYCLE /process_variables/;
        IFEND;

        io_mode := p_form_variable_definition^.io_mode;
        p_form_variable_definition^.valid := TRUE;
        create_variable_error (p_form_variable_definition);

{ A variable that does input/output to a terminal screen must have  a
{ a form image object.

        IF io_mode <> fdc$program_input_output THEN
          fdp$find_object_definition (p_form_variable_definition^.name, 1, p_form_object_definitions,
                number_objects, p_form_object_definition, object_index, name_exists, occurrence_exists);
          IF (name_exists AND occurrence_exists) THEN
            CASE p_form_object_definition^.key OF

            = fdc$form_variable_text =
              p_form_object_definition^.text_variable_exists := TRUE;
              p_form_object_definition^.text_variable_index := variable_index;
              p_form_variable_definition^.object_exists := TRUE;
              p_form_variable_definition^.object_index := object_index;
              p_form_variable_definition^.screen_variable_length :=
                    p_form_object_definition^.text_variable_width;
              create_variable_format (p_form_variable_definition, p_form_module);
              create_variable_display (io_mode, p_form_object_definition^.display_attribute);

            = fdc$form_variable_text_box =
              p_form_object_definition^.variable_box_variable_exists := TRUE;
              p_form_object_definition^.variable_box_variable_index := variable_index;
              p_form_variable_definition^.object_exists := TRUE;
              p_form_variable_definition^.object_index := object_index;
              p_form_variable_definition^.screen_variable_length :=
                    p_form_object_definition^.variable_box_width *
                    p_form_object_definition^.variable_box_height;
              create_variable_format (p_form_variable_definition, p_form_module);
              create_variable_display (io_mode, p_form_object_definition^.display_attribute);

            = fdc$form_box, fdc$form_line, fdc$form_constant_text, fdc$form_constant_text_box,
                  fdc$form_table =

{ These objects cannot have a variable definition.

              IF p_errors <> NIL THEN
                NEXT p_error_header IN p_errors;
                IF p_error_header <> NIL THEN
                  p_error_header^.key := fdc$no_variable_object;
                  NEXT p_error_no_variable_object IN p_errors;
                  IF p_error_no_variable_object <> NIL THEN
                    p_error_no_variable_object^.variable_name := p_form_variable_definition^.name;
                    p_error_no_variable_object^.occurrence := 1;
                  IFEND;
                IFEND;
              IFEND;
              number_errors := number_errors + 1;
              p_form_variable_definition^.valid := FALSE;

            ELSE
            CASEND;

          ELSE

{ The variable does not have a matching object.

            IF p_errors <> NIL THEN
              NEXT p_error_header IN p_errors;
              IF p_error_header <> NIL THEN
                p_error_header^.key := fdc$no_variable_object;
                NEXT p_error_no_variable_object IN p_errors;
                IF p_error_no_variable_object <> NIL THEN
                  p_error_no_variable_object^.variable_name := p_form_variable_definition^.name;
                  p_error_no_variable_object^.occurrence := 1;
                IFEND;
              IFEND;
            IFEND;
            number_errors := number_errors + 1;
            p_form_variable_definition^.valid := FALSE;
          IFEND;
        IFEND;
      FOREND /process_variables/;
    PROCEND link_variables;

?? OLDTITLE ??
?? NEWTITLE := 'sort_events', EJECT ??

    PROCEDURE sort_events;

      TYPE
        fdt$event_sort_array = array [fdc$next .. fdc$variable_trigger] of fdt$event_sort_record,
        fdt$event_sort_record = record
          event_exists: boolean,
          event_definition: fdt$event_definition,
        recend;

      VAR
        event_index: fdt$event_index,
        event_priorities: [READ] array [fdc$next .. fdc$variable_trigger] of fdt$event_trigger :=
              [fdc$next, fdc$shift_next, fdc$help, fdc$shift_help, fdc$stop, fdc$shift_stop, fdc$back,
              fdc$shift_back, fdc$up, fdc$shift_up, fdc$down, fdc$shift_down, fdc$forward, fdc$shift_forward,
              fdc$backward, fdc$shift_backward, fdc$undo, fdc$redo, fdc$quit, fdc$exit, fdc$first, fdc$last,
              fdc$edit, fdc$shift_edit, fdc$data, fdc$shift_data, fdc$function_1, fdc$shift_function_1,
              fdc$function_2, fdc$shift_function_2, fdc$function_3, fdc$shift_function_3, fdc$function_4,
              fdc$shift_function_4, fdc$function_5, fdc$shift_function_5, fdc$function_6,
              fdc$shift_function_6, fdc$function_7, fdc$shift_function_7, fdc$function_8,
              fdc$shift_function_8, fdc$function_9, fdc$shift_function_9, fdc$function_10,
              fdc$shift_function_10, fdc$function_11, fdc$shift_function_11, fdc$function_12,
              fdc$shift_function_12, fdc$function_13, fdc$shift_function_13, fdc$function_14,
              fdc$shift_function_14, fdc$function_15, fdc$shift_function_15, fdc$function_16,
              fdc$shift_function_16, fdc$pick, fdc$insert_line, fdc$delete_line, fdc$home_cursor,
              fdc$clear_screen, fdc$time_out, fdc$variable_trigger],

        event_priority: fdt$event_trigger,
        event_priority_index: fdt$event_trigger,
        event_trigger: fdt$event_trigger,
        p_event_definitions: ^array [1 .. * ] of fdt$event_definition,
        p_event_sort_array: ^fdt$event_sort_array;

{ Sort events in the order that they should be assigned when the form is opened.

      PUSH p_event_sort_array;
      FOR event_trigger := LOWERVALUE (fdt$event_trigger) TO UPPERVALUE (fdt$event_trigger) DO
        p_event_sort_array^ [event_trigger].event_exists := FALSE;
      FOREND;

      p_event_definitions := p_form_status^.p_event_definitions;

    /assign_event_priority/
      FOR event_index := 1 TO p_form_definition^.event_definitions.active_number DO
        event_trigger := p_event_definitions^ [event_index].event_trigger;
        FOR event_priority_index := LOWERVALUE (fdt$event_trigger) TO UPPERVALUE (fdt$event_trigger) DO
          IF event_priorities [event_priority_index] = event_trigger THEN
            event_priority := event_priorities [event_priority_index];
            p_event_sort_array^ [event_priority_index].event_definition := p_event_definitions^ [event_index];
            p_event_sort_array^ [event_priority_index].event_exists := TRUE;
            CYCLE /assign_event_priority/;
          IFEND;
        FOREND;
      FOREND /assign_event_priority/;

      event_index := 1;
      FOR event_trigger := LOWERVALUE (fdt$event_trigger) TO UPPERVALUE (fdt$event_trigger) DO
        IF p_event_sort_array^ [event_trigger].event_exists THEN
          p_event_definitions^ [event_index] := p_event_sort_array^ [event_trigger].event_definition;
          event_index := event_index + 1;
        IFEND;
      FOREND;
    PROCEND sort_events;

?? OLDTITLE ??
?? NEWTITLE := 'sort_objects', EJECT ??

    PROCEDURE sort_objects;

      VAR
        form_object_definition: fdt$form_object_definition,
        least_object_index: fdt$object_index,
        new_object_index: fdt$object_index,
        next_object_index: fdt$object_index,
        object_index: fdt$object_index,
        p_form_object_definition: ^fdt$form_object_definition,
        x_position: fdt$x_position,
        y_position: fdt$y_position;

{ Sort objects to make object display and tabbing
{ efficient during terminal user interaction with the form efficient.
{ Use a simple shell sort.

      new_object_index := 0;

    /choose_next_object/
      FOR object_index := 1 TO number_objects DO
        p_form_object_definition := ^p_form_object_definitions^ [object_index];
        CASE p_form_object_definition^.key OF

        = fdc$form_unused_object =
          CYCLE /choose_next_object/;

        = fdc$form_stored_variable =
          new_object_index := new_object_index + 1;
          p_form_object_definitions^ [object_index].stored_variable_exists := FALSE;
          p_form_object_definitions^ [new_object_index] := p_form_object_definitions^ [object_index];
          CYCLE /choose_next_object/;

        = fdc$form_variable_text =
          p_form_object_definitions^ [object_index].text_variable_exists := FALSE;

        = fdc$form_variable_text_box =
          p_form_object_definitions^ [object_index].variable_box_variable_exists := FALSE;

        ELSE { Other objects do not need to have variable exists set false.
        CASEND;

        y_position := p_form_object_definition^.y_position;
        x_position := p_form_object_definition^.x_position;
        least_object_index := object_index;

      /find_smallest_position/
        FOR next_object_index := object_index + 1 TO number_objects DO
          p_form_object_definition := ^p_form_object_definitions^ [next_object_index];
          CASE p_form_object_definition^.key OF

          = fdc$form_unused_object, fdc$form_stored_variable =

          ELSE
            IF p_form_object_definition^.y_position = y_position THEN
              IF p_form_object_definition^.x_position < x_position THEN
                x_position := p_form_object_definition^.x_position;
                least_object_index := next_object_index;
              IFEND;

            ELSEIF p_form_object_definition^.y_position < y_position THEN
              y_position := p_form_object_definition^.y_position;
              x_position := p_form_object_definition^.x_position;
              least_object_index := next_object_index;
            IFEND;
          CASEND;
        FOREND /find_smallest_position/;

        IF least_object_index <> object_index THEN
          form_object_definition := p_form_object_definitions^ [object_index];
          p_form_object_definitions^ [object_index] := p_form_object_definitions^ [least_object_index];
          p_form_object_definitions^ [least_object_index] := form_object_definition;
        IFEND;
        new_object_index := new_object_index + 1;
        p_form_object_definitions^ [new_object_index] := p_form_object_definitions^ [object_index];
      FOREND /choose_next_object/;
      number_objects := new_object_index;
    PROCEND sort_objects;

?? OLDTITLE ??
?? NEWTITLE := 'sort_record', EJECT ??


{ Purpose : Sort the various form_record components after creating the
{           form and before linking tables and variables.
{ Technique : the procedure sorts 3 different elements.
{             1) Form_variable_definitions are sorted
{                according to type (in the following order : integers,
{                reals, strings), and each type is sorted according to
{                variable name.
{             2) Form_table_definitions are sorted according to table name.
{             3) Table_variables are sorted according to type (in the
{                mentioned above order) and according to variable name
{                within each type.

    PROCEDURE sort_record;

      VAR
        base: integer,
        i: integer,
        j: integer,
        limit: integer,
        name_exists: boolean,
        num_int_vars: fdt$number_variables,
        num_real_vars: fdt$number_variables,
        num_string_vars: fdt$number_variables,
        num_tables: fdt$number_tables,
        num_tbl_vars: fdt$number_variables,
        num_vars: fdt$number_variables,
        p_form_table_definition: ^fdt$form_table_definition,
        p_form_variable_definition: ^fdt$form_variable_definition,
        p_table_variable: ^fdt$table_variable,
        p_table_variables: ^array [1 .. * ] of fdt$table_variable,
        p_vec_tbl_int: ^array [1 .. * ] of fdt$table_variable,
        p_vec_tbl_real: ^array [1 .. * ] of fdt$table_variable,
        p_vec_tbl_str: ^array [1 .. * ] of fdt$table_variable,
        p_vec_int_vars: ^array [1 .. * ] of fdt$form_variable_definition,
        p_vec_real_vars: ^array [1 .. * ] of fdt$form_variable_definition,
        p_vec_str_vars: ^array [1 .. * ] of fdt$form_variable_definition,
        program_data_type: fdt$program_data_type,
        table_index: fdt$table_index,
        table_variable_index: fdt$variable_index,
        temp_form_table_definition: fdt$form_table_definition,
        temp_table_variable: fdt$table_variable,
        temp_form_variable_definition: fdt$form_variable_definition,
        variable_index: fdt$variable_index;

{ Sort variable definitions according to variable name.

      PROCEDURE sort_variable_definitions
        (    p_vec: ^array [1 .. * ] of fdt$form_variable_definition;
             num_vars: fdt$number_variables);

        VAR
          temp: fdt$form_variable_definition;

        limit := num_vars;
        FOR j := 1 TO (num_vars - 1) DO
          limit := limit - 1;
          FOR i := 1 TO limit DO
            IF p_vec^ [i].name > p_vec^ [i + 1].name THEN
              temp := p_vec^ [i];
              p_vec^ [i] := p_vec^ [i + 1];
              p_vec^ [i + 1] := temp;
            IFEND;
          FOREND;
        FOREND;
        RETURN;
      PROCEND sort_variable_definitions;

{ Sort table definitions by table name.

      PROCEDURE sort_table_definitions
        (    p_vec: ^array [1 .. * ] of fdt$form_table_definition;
             num_tables: fdt$number_tables);

        VAR
          temp: fdt$form_table_definition;

        limit := num_tables;
        FOR j := 1 TO (num_tables - 1) DO
          limit := limit - 1;
          FOR i := 1 TO limit DO
            IF p_vec^ [i].name > p_vec^ [i + 1].name THEN
              temp := p_vec^ [i];
              p_vec^ [i] := p_vec^ [i + 1];
              p_vec^ [i + 1] := temp;
            IFEND;
          FOREND;
        FOREND;
        RETURN;
      PROCEND sort_table_definitions;

{ Sort table variables by variable name.

      PROCEDURE sort_table_variables
        (    p_vec: ^array [1 .. * ] of fdt$table_variable;
             num_vars: fdt$number_variables);

        VAR
          temp: fdt$table_variable;

        limit := num_vars;
        FOR j := 1 TO (num_vars - 1) DO
          limit := limit - 1;
          FOR i := 1 TO limit DO
            IF p_vec^ [i].name > p_vec^ [i + 1].name THEN
              temp := p_vec^ [i];
              p_vec^ [i] := p_vec^ [i + 1];
              p_vec^ [i + 1] := temp;
            IFEND;
          FOREND;
        FOREND;
        RETURN;
      PROCEND sort_table_variables;

      num_int_vars := 0;
      num_real_vars := 0;
      num_string_vars := 0;
      num_tables := p_form_definition^.form_table_definitions.active_number;
      num_vars := p_form_definition^.form_variable_definitions.active_number;
      IF (num_vars = 0) THEN
        RETURN;
      IFEND;

      PUSH p_vec_int_vars: [1 .. num_vars];
      PUSH p_vec_real_vars: [1 .. num_vars];
      PUSH p_vec_str_vars: [1 .. num_vars];

{ Sort variables.

      FOR variable_index := 1 TO num_vars DO
        p_form_variable_definition := ^p_form_variable_definitions^ [variable_index];

{ Sort variables into three groups.
{ 1) Integer variables
{ 2) Real variables
{ 3) String variables

        get_compatible_data_type (p_form_variable_definition, p_form_module, program_data_type);
        CASE program_data_type OF

        = fdc$program_integer_type =
          num_int_vars := num_int_vars + 1;
          p_vec_int_vars^ [num_int_vars] := p_form_variable_definition^;

        = fdc$program_real_type =
          num_real_vars := num_real_vars + 1;
          p_vec_real_vars^ [num_real_vars] := p_form_variable_definition^;

        ELSE {fdc$program_character_type, fdc$program_upper_case_type
          num_string_vars := num_string_vars + 1;
          p_vec_str_vars^ [num_string_vars] := p_form_variable_definition^;

        CASEND;
      FOREND;

{ Sort variables according to name.

      IF (num_int_vars > 1) THEN
        sort_variable_definitions (p_vec_int_vars, num_int_vars);
      IFEND;
      IF (num_real_vars > 1) THEN
        sort_variable_definitions (p_vec_real_vars, num_real_vars);
      IFEND;
      IF (num_string_vars > 1) THEN
        sort_variable_definitions (p_vec_str_vars, num_string_vars);
      IFEND;

{ Move the sorted variables back into the variable definition array.

      base := 0;

      i := 1;
      FOR variable_index := (base + 1) TO (base + num_int_vars) DO
        p_form_variable_definitions^ [variable_index] := p_vec_int_vars^ [i];
        i := i + 1;
      FOREND;
      base := base + num_int_vars;
      i := 1;
      FOR variable_index := (base + 1) TO (base + num_real_vars) DO
        p_form_variable_definitions^ [variable_index] := p_vec_real_vars^ [i];
        i := i + 1;
      FOREND;
      base := base + num_real_vars;
      i := 1;
      FOR variable_index := (base + 1) TO num_vars DO
        p_form_variable_definitions^ [variable_index] := p_vec_str_vars^ [i];
        i := i + 1;
      FOREND;

{ Sort tables.

      IF (num_tables = 0) THEN
        RETURN;
      IFEND;
      IF (num_tables > 1) THEN
        sort_table_definitions (p_form_table_definitions, num_tables);
      IFEND;

{ Sort table variables.
{ For each table, the variables are sorted into groups according to
{ variable type and variable name.

      PUSH p_vec_tbl_int: [1 .. num_vars];
      PUSH p_vec_tbl_real: [1 .. num_vars];
      PUSH p_vec_tbl_str: [1 .. num_vars];

    /table_loop/
      FOR table_index := 1 TO num_tables DO
        p_form_table_definition := ^p_form_table_definitions^ [table_index];
        num_tbl_vars := p_form_table_definition^.table_variables.active_number;
        IF (num_tbl_vars < 2) THEN
          CYCLE /table_loop/;
        IFEND;
        p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
              p_form_module);
        num_int_vars := 0;
        num_real_vars := 0;
        num_string_vars := 0;
        FOR table_variable_index := 1 TO num_tbl_vars DO
          p_table_variable := ^p_table_variables^ [table_variable_index];
          fdp$find_variable_definition (p_table_variable^.name, p_form_variable_definitions, num_vars,
                p_form_variable_definition, variable_index, name_exists);
          IF NOT name_exists THEN

{ The user did not specify a variable definition.  The record cannot be sorted.

            RETURN;
          IFEND;

{ Sort table variables according to data type.

          get_compatible_data_type (p_form_variable_definition, p_form_module, program_data_type);
          CASE program_data_type OF

          = fdc$program_integer_type =
            num_int_vars := num_int_vars + 1;
            p_vec_tbl_int^ [num_int_vars] := p_table_variable^;

          = fdc$program_real_type =
            num_real_vars := num_real_vars + 1;
            p_vec_tbl_real^ [num_real_vars] := p_table_variable^;

          ELSE {fdc$program_character_type, fdc$program_upper_case_type
            num_string_vars := num_string_vars + 1;
            p_vec_tbl_str^ [num_string_vars] := p_table_variable^;

          CASEND;
        FOREND;

{ Sort table variables according to variable name.

        IF (num_int_vars > 1) THEN
          sort_table_variables (p_vec_tbl_int, num_int_vars);
        IFEND;
        IF (num_real_vars > 1) THEN
          sort_table_variables (p_vec_tbl_real, num_real_vars);
        IFEND;
        IF (num_string_vars > 1) THEN
          sort_table_variables (p_vec_tbl_str, num_string_vars);
        IFEND;

{ Move sorted table variables back to the table variables array.

        base := 0;
        i := 1;
        FOR table_variable_index := (base + 1) TO (base + num_int_vars) DO
          p_table_variables^ [table_variable_index] := p_vec_tbl_int^ [i];
          i := i + 1;
        FOREND;
        base := base + num_int_vars;
        i := 1;
        FOR table_variable_index := (base + 1) TO (base + num_real_vars) DO
          p_table_variables^ [table_variable_index] := p_vec_tbl_real^ [i];
          i := i + 1;
        FOREND;
        base := base + num_real_vars;
        i := 1;
        FOR table_variable_index := (base + 1) TO (base + num_string_vars) DO
          p_table_variables^ [table_variable_index] := p_vec_tbl_str^ [i];
          i := i + 1;
        FOREND;
      FOREND /table_loop/;
      RETURN;
    PROCEND sort_record;

?? OLDTITLE ??
?? NEWTITLE := 'validate_variable_values', EJECT ??
    PROCEDURE validate_variable_values;

    VAR
      p_base_text: ^fdt$text,
      p_form_table_definition: ^fdt$form_table_definition,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_table_object: ^fdt$table_object,
      p_table_objects: ^array [1 .. *] of fdt$table_object,
      p_table_variable: ^fdt$table_variable,
      p_table_variables: ^array [1 .. *] of fdt$table_variable,
      table_index: fdt$table_index,
      table_object_index: fdt$object_index,
      table_variable_index: fdt$table_variable_index,
      variable_index: fdt$variable_index;

?? NEWTITLE := 'validate_object' ??

   PROCEDURE validate_object;

      VAR
        ignore_date_time: clt$date_time,
        integer_number: integer,
        p_error_header: ^fdt$error_header,
        p_error_input_conversion: ^fdt$error_input_conversion,
        p_error_output_conversion: ^fdt$error_output_conversion,
        p_error_invalid_value: ^fdt$error_invalid_value,
        p_program_variable: ^array [1 .. *] OF cell,
        p_screen_variable: ^fdt$text,
        p_text: ^fdt$text,
        p_valid_string: ^fdt$valid_string,
        program_data_type: fdt$program_data_type,
        program_variable_length: fdt$program_variable_length,
        real_number: real,
        screen_variable_length: fdt$text_length,
        variable_status: fdt$variable_status;

        CASE p_form_object_definition^.key OF

        = fdc$form_variable_text =
          p_text := fdp$ptr_text (p_form_object_definition^.text_variable_text,
                p_form_module);

        = fdc$form_variable_text_box =
          p_text := fdp$ptr_text (p_form_object_definition^.
                variable_box_text, p_form_module);

        = fdc$form_stored_variable =
          p_text := fdp$ptr_text (p_form_object_definition^.
                stored_variable_text, p_form_module);

        ELSE
          RETURN;
        CASEND;

        IF ((p_base_text <> NIL) AND (p_text^ = p_base_text^)) THEN
          RETURN;
        IFEND;

        p_base_text := p_text;

{ Validate that input and output formatting work for initial value of object.

        program_data_type := p_form_variable_definition^.program_data_type;
        program_variable_length := p_form_variable_definition^.program_variable_length;
        screen_variable_length := p_form_variable_definition^.screen_variable_length;
        PUSH p_program_variable: [1 .. program_variable_length];
        PUSH p_screen_variable: [screen_variable_length];
        p_screen_variable^ := p_text^;
        fdp$move_to_program_variable (p_form_status, p_form_variable_definition,
              p_screen_variable, p_program_variable, variable_status, status);
        IF (NOT status.normal OR (variable_status <> fdc$no_error)) THEN
          number_errors := number_errors + 1;
          p_form_variable_definition^.valid := FALSE;
          IF p_errors <> NIL THEN
            NEXT p_error_header IN p_errors;
            IF p_error_header <> NIL THEN
              p_error_header^.key := fdc$error_input_conversion;
              NEXT p_error_input_conversion IN p_errors;
              IF  p_error_input_conversion <> NIL THEN
                p_error_input_conversion^.variable_name :=
                      p_form_object_definition^.name;
                p_error_input_conversion^.occurrence :=
                      p_form_object_definition^.occurrence;
              IFEND;
            IFEND;
          IFEND;
          RETURN;
        IFEND;

        fdp$move_to_screen_variable (p_form_status, p_form_variable_definition,
              p_program_variable, p_screen_variable, variable_status, status);
        IF (NOT status.normal OR (variable_status <> fdc$no_error)) THEN
          number_errors := number_errors + 1;
          p_form_variable_definition^.valid := FALSE;
          IF p_errors <> NIL THEN
            NEXT p_error_header IN p_errors;
            IF p_error_header <> NIL THEN
              p_error_header^.key := fdc$error_output_conversion;
              NEXT p_error_output_conversion IN p_errors;
              IF  p_error_output_conversion <> NIL THEN
                p_error_output_conversion^.variable_name :=
                      p_form_object_definition^.name;
                p_error_output_conversion^.occurrence :=
                      p_form_object_definition^.occurrence;
              IFEND;
            IFEND;
          IFEND;
          RETURN;
        IFEND;

{ Do not validate value for object with must enter to allow
{ entry of such values as passwords.  The application does not want to show
{ the terminal user any password on the initial display.

        IF (fdc$must_enter IN
              p_form_variable_definition^.terminal_user_entry) THEN
          RETURN;
        IFEND;

{ Check initial value against specified valid values.

        CASE program_data_type OF

        = fdc$program_character_type, fdc$program_upper_case_type =
          fdp$validate_string (p_screen_variable, program_variable_length,
                p_form_variable_definition^.valid_strings, p_form_status,
                p_valid_string, variable_status);

        = fdc$program_integer_type =
          i#move (p_program_variable, ^integer_number, fdc$integer_length);
          IF fdp$date_variable (p_form_variable_definition) THEN
            fdp$convert_yymmdd_to_date_time (integer_number, ignore_date_time, variable_status);
          ELSE
          fdp$validate_integer (integer_number,  p_form_variable_definition^.
                valid_integer_ranges, p_form_status, variable_status);
          IFEND;

        = fdc$program_real_type =
          i#move (p_program_variable, ^real_number, fdc$real_length);
          fdp$validate_real (real_number,  p_form_variable_definition^.
                valid_real_ranges, p_form_status, variable_status);

       ELSE {fdc$program_cobol_type
         fdp$validate_cobol_data (p_form_status, p_form_variable_definition,
            p_program_variable, p_valid_string, variable_status);
       CASEND;

        IF (variable_status <> fdc$no_error) THEN
          number_errors := number_errors + 1;
          p_form_variable_definition^.valid := FALSE;
          IF p_errors <> NIL THEN
            NEXT p_error_header IN p_errors;
            IF p_error_header <> NIL THEN
              p_error_header^.key := fdc$error_invalid_value;
              NEXT p_error_invalid_value IN p_errors;
              IF  p_error_invalid_value <> NIL THEN
                p_error_invalid_value^.variable_name :=
                      p_form_object_definition^.name;
                p_error_invalid_value^.occurrence :=
                      p_form_object_definition^.occurrence;
              IFEND;
            IFEND;
          IFEND;
          RETURN;
        IFEND;
    PROCEND validate_object;

?? OLDTITLE, EJECT ??

    /get_next_variable/
      FOR variable_index := 1 TO number_variables DO
        p_form_variable_definition := ^p_form_variable_definitions^ [variable_index];

        IF p_form_variable_definition^.table_exists THEN
          CYCLE /get_next_variable/;
        IFEND;

        IF NOT p_form_variable_definition^.object_exists THEN
          CYCLE /get_next_variable/;
        IFEND;

        p_form_object_definition := ^p_form_object_definitions^
              [p_form_variable_definition^.object_index];
        p_base_text := NIL;
        validate_object;
      FOREND /get_next_variable/;

      /get_next_table/
      FOR table_index := 1 TO p_form_definition^.form_table_definitions.active_number DO
        p_form_table_definition := ^p_form_table_definitions^ [table_index];
        p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
              p_form_module);

        /get_next_table_variable/
        FOR table_variable_index := 1 TO p_form_table_definition^.
              table_variables.active_number DO
          p_table_variable := ^p_table_variables^ [table_variable_index];
          p_table_objects := fdp$ptr_table_objects (p_table_variable^.table_objects,
                p_form_module);
          IF NOT p_table_variable^.variable_exists THEN
            CYCLE /get_next_table_variable/;
          IFEND;

          p_form_variable_definition :=
                ^p_form_variable_definitions^ [p_table_variable^.variable_index];

{ Validate first object of table, then try to avoid validation of other objects
{ with the same text.

          p_table_object := ^p_table_objects^ [1];
          p_form_object_definition := ^p_form_object_definitions^
                [p_table_object^.object_index];
          p_base_text := NIL;
          validate_object;

          /get_next_object/
          FOR table_object_index := 2 TO p_form_table_definition^.stored_occurrence DO
            p_table_object := ^p_table_objects^ [table_object_index];
            IF NOT p_table_object^.object_exists THEN
              CYCLE /get_next_object/;
            IFEND;

            p_form_object_definition := ^p_form_object_definitions^
                  [p_table_object^.object_index];
            validate_object;
          FOREND /get_next_object/;
        FOREND /get_next_table_variable/;
      FOREND /get_next_table/;
    PROCEND validate_variable_values;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_change_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    number_errors := 0;
    p_errors := p_sequence;
    IF p_errors <> NIL THEN
      RESET p_errors;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    p_form_module := p_form_status^.p_form_module;
    p_form_table_definitions := p_form_status^.p_form_table_definitions;
    p_form_variable_definitions := p_form_status^.p_form_variable_definitions;

{ Create non-visible (stored objects) which the user has not created.

    create_stored_objects;

    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    number_objects := p_form_definition^.form_object_definitions.active_number;
    number_variables := p_form_definition^.form_variable_definitions.active_number;

{ Sort events in order of assignment to terminal keys.

    sort_events;

{ Sort record so that changes in object locations on the form do not change the
{ record definition.

    sort_record;

{ Sort objects on form top left to bottom right.
{ This makes display and tabbing efficient during form interactions.
{ Delete unused objects.
{ Set variable definition does not yet exist.

    sort_objects;
    p_form_definition^.form_object_definitions.active_number := number_objects;

{ Link objects belonging to text boxes.

    link_text_boxes;

{ Link tables to associated variables and objects on the  form.
{ Tables are linked to their variables to make processing efficient
{ for form interaction with a terminal user.

    link_tables;

{ Link variables that do not belong to tables to objects on the form.
{ Variables are linked to their object to make processing efficient
{ for form interaction with a terminal user.

    link_variables;

{ Record variable objects that do not have a variable definition.

    IF NOT p_form_status^.fast_form_creation THEN
      check_for_dangling_objects;
    IFEND;

{ Validate that initial values of variable text objects work with defined
{ input and ouput formats and have valid values.  This is a very time
{ consuming process so do it only if the user has specified it.

    IF p_form_status^.validate_variable_values THEN
      validate_variable_values;
    IFEND;

{ Compute the terminal screen area required to contain the form.

    compute_form_area;

{ Find first input variable.  The cursor is set here when the
{ form is first displayed.

    find_first_input_position;

{ Generate the record used to communicate with the application program
{ during form interaction.

    generate_form_record;

    IF number_errors = 0 THEN
      p_form_definition^.form_has_errors := FALSE;
    IFEND;

    p_form_definition^.form_ended := TRUE;

{ Set size of sequence of errors.

    IF p_sequence <> NIL THEN
      error_size := i#current_sequence_position (p_errors);
      RESET p_errors;
      IF error_size <> 0 THEN
        NEXT p_errors: [[REP error_size OF cell]] IN p_errors;
      IFEND;
    IFEND;

{ Free storage used for checking for overlayed form objects.
{ It is not used during terminal user interaction with the form.

    IF p_form_status^.p_form_image <> NIL THEN
      FREE p_form_status^.p_form_image;
    IFEND;

  PROCEND fdp$end_form;

?? TITLE := 'fdp$get_form_attributes', EJECT ??
*copyc fdh$get_form_attributes

  PROCEDURE [XDCL] fdp$get_form_attributes
    (    form_identifier: fdt$form_identifier;
     VAR get_form_attributes: fdt$get_form_attributes;
     VAR status: ost$status);

    VAR
      comment_index: fdt$comment_index,
      current_comment_index: fdt$comment_index,
      current_comment_length_index: fdt$comment_index,
      current_display_index: fdt$display_index,
      current_event_index: fdt$event_index,
      display_index: fdt$display_index,
      event_index: fdt$event_index,
      n: fdt$form_attribute_index,
      name_is_valid: boolean,
      number_comments: fdt$number_comments,
      number_displays: fdt$number_object_displays,
      number_events: fdt$number_events,
      number_objects: fdt$number_objects,
      number_tables: fdt$number_tables,
      number_variables: fdt$number_variables,
      object_index: fdt$object_index,
      p_comment: ^fdt$comment,
      p_comment_definitions: ^array [1 .. * ] of fdt$comment_definition,
      p_comment_definition: ^fdt$comment_definition,
      p_display_definition: ^fdt$display_definition,
      p_display_definitions: ^array [1 .. * ] of fdt$display_definition,
      p_event_command: ^fdt$event_command,
      p_event_definition: ^fdt$event_definition,
      p_form_definition: ^fdt$form_definition,
      p_form_module: ^fdt$form_module,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_status: ^fdt$form_status,
      p_help_message: ^fdt$help_message,
      table_index: fdt$table_index,
      variable_index: fdt$variable_index,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_form_attributes;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_form_attributes;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);

    FOR n := LOWERBOUND (get_form_attributes) TO UPPERBOUND (get_form_attributes) DO
      get_form_attributes [n].get_value_status := fdc$unprocessed_get_value;
    FOREND;

    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    p_form_module := p_form_status^.p_form_module;
    current_event_index := 1;
    current_comment_index := 1;
    current_comment_length_index := 1;
    current_display_index := 1;

    FOR n := LOWERBOUND (get_form_attributes) TO UPPERBOUND (get_form_attributes) DO

    /process_form_attributes/
      BEGIN
        CASE get_form_attributes [n].key OF

        = fdc$get_form_display_attribute =
          get_form_attributes [n].form_display_attribute := p_form_definition^.display_attribute;
          IF (p_form_definition^.display_attribute = $fdt$display_attribute_set
                [fdc$black_background, fdc$white_foreground, fdc$protect]) THEN
            get_form_attributes [n].get_value_status := fdc$system_default_value;
          ELSE
            get_form_attributes [n].get_value_status := fdc$user_defined_value;
          IFEND;

        = fdc$get_event_command =
          fdp$validate_name (get_form_attributes [n].event_command_name, p_form_definition^.processor,
                valid_name, name_is_valid);
          IF NOT name_is_valid THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_event_name,
                  get_form_attributes [n].event_command_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

        /find_event_command/
          FOR event_index := 1 TO p_form_definition^.event_definitions.active_number DO
            p_event_definition := ^p_form_status^.p_event_definitions^ [event_index];
            IF p_event_definition^.event_name = valid_name THEN
              p_event_command := fdp$ptr_event_command (p_event_definition^.command, p_form_module);
              IF p_event_command <> NIL THEN
                IF STRLENGTH (get_form_attributes [n].p_event_command^) >= STRLENGTH (p_event_command^) THEN
                  get_form_attributes [n].p_event_command^ := p_event_command^;
                  get_form_attributes [n].get_value_status := fdc$user_defined_value;
                  EXIT /process_form_attributes/;

                ELSE

{ The user did not allocate enough space for the command string.

                  osp$set_status_abnormal (fdc$format_display_identifier, fde$string_too_small, '', status);
                  RETURN;
                IFEND;

             ELSE

{ No command for event.

                get_form_attributes [n].get_value_status := fdc$undefined_value;
                EXIT /process_form_attributes/;
              IFEND;
            IFEND;
          FOREND /find_event_command/;

          osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_event_name,
                get_form_attributes [n].event_command_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;

        = fdc$get_event_form =
          get_form_attributes [n].event_form_definition := p_form_definition^.event_form_definition;
          CASE p_form_definition^.event_form_definition.key OF

          = fdc$user_event_form, fdc$system_default_event_form =
            get_form_attributes [n].get_value_status := fdc$user_defined_value;

          = fdc$no_event_form =
            get_form_attributes [n].get_value_status := fdc$system_default_value;


          ELSE { Invalid event key.
            osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, '', status);
            RETURN;

          CASEND;

        = fdc$get_event_form_identifier =
          IF p_form_status^.event_form_defined THEN
            get_form_attributes [n].event_form_identifier := p_form_status^.event_form_identifier;
            get_form_attributes [n].get_value_status := fdc$system_computed_value;
          ELSE
            get_form_attributes [n].get_value_status := fdc$undefined_value;
          IFEND;

        = fdc$get_form_area =
          get_form_attributes [n].form_area := p_form_definition^.form_area;
          IF p_form_definition^.form_area.key = fdc$screen_area THEN
            get_form_attributes [n].get_value_status := fdc$system_default_value;
          ELSE
            get_form_attributes [n].get_value_status := fdc$user_defined_value;
          IFEND;

        = fdc$get_form_comment_length =
          get_form_attributes [n].get_value_status := fdc$undefined_value;
          p_comment_definitions := fdp$ptr_comments (p_form_definition^.comment_definitions, p_form_module);

        /find_comment_length/
          FOR comment_index := current_comment_length_index TO p_form_definition^.comment_definitions.
                active_number DO
            p_comment_definition := ^p_comment_definitions^ [comment_index];
            current_comment_length_index := comment_index + 1;
            p_comment := #PTR (p_comment_definition^.p_comment, p_form_module^);
            get_form_attributes [n].form_comment_length := STRLENGTH (p_comment^);
            get_form_attributes [n].get_value_status := fdc$user_defined_value;
            EXIT /find_comment_length/;
          FOREND /find_comment_length/;

        = fdc$get_form_help =
          CASE p_form_definition^.help_definition.key OF

          = fdc$help_form =
            get_form_attributes [n].get_value_status := fdc$user_defined_value;
            get_form_attributes [n].form_help.key := fdc$get_help_form;
            get_form_attributes [n].form_help.help_form := p_form_definition^.help_definition.help_form;

          = fdc$help_message =
            get_form_attributes [n].get_value_status := fdc$user_defined_value;
            get_form_attributes [n].form_help.key := fdc$get_help_message;
            p_help_message := #PTR (p_form_definition^.help_definition.p_help_message, p_form_module^);
            get_form_attributes [n].form_help.help_message_length := STRLENGTH (p_help_message^);

          = fdc$no_help_response =
            get_form_attributes [n].get_value_status := fdc$user_defined_value;
            get_form_attributes [n].form_help.key := fdc$get_no_help_response;

          = fdc$system_default_help =
            get_form_attributes [n].get_value_status := fdc$system_default_value;
            get_form_attributes [n].form_help.key := fdc$get_system_default_help;
            get_form_attributes [n].form_help.help_message_length := fdc$message_variable_length;

          ELSE

{ Invalid help key.

            osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, '', status);
            RETURN;

          CASEND;

        = fdc$get_form_help_message =
          CASE p_form_definition^.help_definition.key OF

          = fdc$help_form =
            get_form_attributes [n].get_value_status := fdc$undefined_value;

          = fdc$help_message =
            p_help_message := #PTR (p_form_definition^.help_definition.p_help_message, p_form_module^);
            IF STRLENGTH (get_form_attributes [n].p_form_help_message^) >= STRLENGTH (p_help_message^) THEN
              get_form_attributes [n].p_form_help_message^ := p_help_message^;
              get_form_attributes [n].get_value_status := fdc$user_defined_value;

            ELSE

{ The user's area will not hold the help message.

              osp$set_status_abnormal (fdc$format_display_identifier, fde$string_too_small, '', status);
              RETURN;
            IFEND;

          = fdc$no_help_response =
            get_form_attributes [n].get_value_status := fdc$undefined_value;

          = fdc$system_default_help =
            IF STRLENGTH (get_form_attributes [n].p_form_help_message^) >=
                  fdc$message_variable_length THEN
              fdp$get_message (fde$system_help_message,
                    get_form_attributes [n].p_form_help_message^);
              get_form_attributes [n].get_value_status := fdc$system_default_value;

            ELSE

{ The user's area will not hold the help message.

              osp$set_status_abnormal (fdc$format_display_identifier, fde$string_too_small, '', status);
              RETURN;
            IFEND;
          CASEND;

        = fdc$get_form_language =
          get_form_attributes [n].form_language := p_form_definition^.language;
          IF p_form_definition^.language = osc$default_natural_language THEN
            get_form_attributes [n].get_value_status := fdc$system_default_value;
          ELSE
            get_form_attributes [n].get_value_status := fdc$user_defined_value;
          IFEND;

        = fdc$get_form_name =
          get_form_attributes [n].form_name := p_form_definition^.form_name;
          IF p_form_definition^.form_name = osc$null_name THEN
            get_form_attributes [n].get_value_status := fdc$system_default_value;
          ELSE
            get_form_attributes [n].get_value_status := fdc$user_defined_value;
          IFEND;

        = fdc$get_form_processor =
          get_form_attributes [n].form_processor := p_form_definition^.processor;
          IF p_form_definition^.processor = fdc$system_form_processor THEN
            get_form_attributes [n].get_value_status := fdc$system_default_value;
          ELSE
            get_form_attributes [n].get_value_status := fdc$user_defined_value;
          IFEND;

        = fdc$get_help_message_form =
          IF p_form_definition^.screen_formatting_version < fdc$message_form_capability THEN
            get_form_attributes [n].get_value_status := fdc$undefined_value;
            get_form_attributes [n].help_message_form := osc$null_name;
          ELSE
            get_form_attributes [n].help_message_form := p_form_definition^.help_message_form;
            IF p_form_definition^.help_message_form = osc$null_name THEN
              get_form_attributes [n].get_value_status := fdc$undefined_value;
            ELSE
              get_form_attributes [n].get_value_status := fdc$user_defined_value;
            IFEND;
           IFEND;

         = fdc$get_hidden_editing =
           get_form_attributes [n].hidden_editing := p_form_definition^.hidden_editing;
          IF p_form_definition^.hidden_editing THEN
            get_form_attributes [n].get_value_status := fdc$user_defined_value;
          ELSE
            get_form_attributes [n].get_value_status := fdc$system_default_value;
          IFEND;

        = fdc$get_invalid_data_character =
          IF p_form_definition^.screen_formatting_version < fdc$im_smart_capability THEN
            get_form_attributes [n].invalid_data_character.defined := FALSE;
            get_form_attributes [n].get_value_status := fdc$system_default_value;
          ELSE
            get_form_attributes [n].invalid_data_character := p_form_definition^.invalid_data_character;
            IF p_form_definition^.invalid_data_character.defined THEN
              get_form_attributes [n].get_value_status := fdc$user_defined_value;
            ELSE
              get_form_attributes [n].get_value_status := fdc$system_default_value;
            IFEND;
          IFEND;

        = fdc$get_message_form, fdc$get_error_message_form =
          get_form_attributes [n].error_message_form := p_form_definition^.error_message_form;
          IF p_form_definition^.error_message_form = osc$null_name THEN
            get_form_attributes [n].get_value_status := fdc$undefined_value;
          ELSE
            get_form_attributes [n].get_value_status := fdc$user_defined_value;
          IFEND;


        = fdc$get_next_event =
          get_form_attributes [n].get_value_status := fdc$undefined_value;

        /find_event/
          FOR event_index := current_event_index TO p_form_definition^.event_definitions.active_number DO
            p_event_definition := ^p_form_status^.p_event_definitions^ [event_index];
            current_event_index := event_index + 1;
            get_form_attributes [n].event_action := p_event_definition^.event_action;
            get_form_attributes [n].event_name := p_event_definition^.event_name;
            get_form_attributes [n].event_label := p_event_definition^.event_label;
            get_form_attributes [n].get_value_status := fdc$user_defined_value;
            IF p_form_status^.p_form_event_statuses = NIL THEN
              get_form_attributes [n].event_trigger := p_event_definition^.event_trigger;
            ELSE
              IF p_form_status^.p_form_event_statuses^ [event_index].event_exists THEN
                get_form_attributes [n].event_trigger := p_form_status^.p_form_event_statuses^ [event_index].
                      event_trigger;
              ELSE
                get_form_attributes [n].get_value_status := fdc$undefined_value;
              IFEND;
            IFEND;

            p_event_command := fdp$ptr_event_command (p_event_definition^.command, p_form_module);
            IF p_event_command <> NIL THEN
              get_form_attributes [n].event_command_length := STRLENGTH (p_event_command^);
            ELSE
              get_form_attributes [n].event_command_length := 0;
            IFEND;
            EXIT /find_event/;
          FOREND /find_event/;

        = fdc$get_next_event_v1 =
          get_form_attributes [n].get_value_status := fdc$undefined_value;

        /find_event_v1/
          FOR event_index := current_event_index TO p_form_definition^.event_definitions.active_number DO
            p_event_definition := ^p_form_status^.p_event_definitions^ [event_index];
            current_event_index := event_index + 1;
            get_form_attributes [n].event_action_v1 := p_event_definition^.event_action;
            get_form_attributes [n].event_name_v1 := p_event_definition^.event_name;
            get_form_attributes [n].event_label_v1 := p_event_definition^.event_label;
            IF p_form_definition^.screen_formatting_version < fdc$reassign_event_capability THEN
              get_form_attributes [n].event_trigger_reassignment_v1 := TRUE;
            ELSE
              get_form_attributes [n].event_trigger_reassignment_v1 :=
                    p_event_definition^.event_trigger_reassignment;
            IFEND;
            get_form_attributes [n].get_value_status := fdc$user_defined_value;
            IF p_form_status^.p_form_event_statuses = NIL THEN
              get_form_attributes [n].event_trigger_v1 := p_event_definition^.event_trigger;
            ELSE
              IF p_form_status^.p_form_event_statuses^ [event_index].event_exists THEN
                get_form_attributes [n].event_trigger_v1 :=
                      p_form_status^.p_form_event_statuses^ [event_index].event_trigger;
              ELSE
                get_form_attributes [n].get_value_status := fdc$undefined_value;
              IFEND;
            IFEND;
            p_event_command := fdp$ptr_event_command (p_event_definition^.command, p_form_module);
            IF p_event_command <> NIL THEN
              get_form_attributes [n].event_command_length_v1 := STRLENGTH (p_event_command^);
            ELSE
              get_form_attributes [n].event_command_length_v1 := 0;
            IFEND;
            EXIT /find_event_v1/;
          FOREND /find_event_v1/;

        = fdc$get_next_form_comment =
          get_form_attributes [n].get_value_status := fdc$undefined_value;
          p_comment_definitions := fdp$ptr_comments (p_form_definition^.comment_definitions, p_form_module);

        /find_comment/
          FOR comment_index := current_comment_index TO p_form_definition^.comment_definitions.
                active_number DO
            p_comment_definition := ^p_comment_definitions^ [comment_index];
            current_comment_index := comment_index + 1;
            p_comment := #PTR (p_comment_definition^.p_comment, p_form_module^);
            IF STRLENGTH (get_form_attributes [n].p_form_comment^) >= STRLENGTH (p_comment^) THEN
              get_form_attributes [n].p_form_comment^ := p_comment^;
              get_form_attributes [n].get_value_status := fdc$user_defined_value;
              EXIT /find_comment/;

            ELSE
              osp$set_status_abnormal (fdc$format_display_identifier, fde$string_too_small, '', status);
              RETURN;
            IFEND;
          FOREND /find_comment/;

        = fdc$get_next_display =
          get_form_attributes [n].get_value_status := fdc$undefined_value;
          p_display_definitions := fdp$ptr_displays (p_form_status);

        /find_display/
          FOR display_index := current_display_index TO p_form_definition^.display_definitions.
                active_number DO
            p_display_definition := ^p_form_status^.p_display_definitions^ [display_index];
            current_display_index := display_index + 1;
            get_form_attributes [n].display_name := p_display_definition^.name;
            get_form_attributes [n].display_attribute := p_display_definition^.attribute;
            get_form_attributes [n].get_value_status := fdc$user_defined_value;
            EXIT /find_display/;
          FOREND /find_display/;

        = fdc$get_number_events =
          get_form_attributes [n].number_events := p_form_definition^.event_definitions.active_number;
          get_form_attributes [n].get_value_status := fdc$user_defined_value;

        = fdc$get_number_form_comments =
          get_form_attributes [n].number_form_comments := p_form_definition^.comment_definitions.
                active_number;
          get_form_attributes [n].get_value_status := fdc$user_defined_value;

        = fdc$get_number_displays =
          get_form_attributes [n].number_form_displays := p_form_definition^.display_definitions.
                active_number;
          get_form_attributes [n].get_value_status := fdc$user_defined_value;

        = fdc$get_number_objects =
          p_form_object_definitions := p_form_status^.p_form_object_definitions;
          number_objects := 0;
          FOR object_index := 1 TO p_form_definition^.form_object_definitions.active_number DO
            CASE p_form_object_definitions^ [object_index].key OF

            = fdc$form_box, fdc$form_line, fdc$form_constant_text_box, fdc$form_constant_text, fdc$form_table,
                  fdc$form_variable_text, fdc$form_variable_text_box =
              number_objects := number_objects + 1;

            ELSE { This is an object that the user did not create.
            CASEND;
          FOREND;

          get_form_attributes [n].number_objects := number_objects;
          get_form_attributes [n].get_value_status := fdc$user_defined_value;

        = fdc$get_number_tables =
          get_form_attributes [n].number_tables := p_form_definition^.form_table_definitions.active_number;
          get_form_attributes [n].get_value_status := fdc$user_defined_value;

        = fdc$get_number_variables =
          get_form_attributes [n].number_variables := p_form_definition^.form_variable_definitions.
                active_number;
          get_form_attributes [n].get_value_status := fdc$user_defined_value;


        = fdc$get_unused_form_entry =
          get_form_attributes [n].get_value_status := fdc$undefined_value;

        ELSE

{ Invalid form attribute.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_form_attribute,
                p_form_definition^.form_name, status);
          RETURN;

        CASEND;
      END /process_form_attributes/;
    FOREND;
  PROCEND fdp$get_form_attributes;

?? TITLE := 'fdp$get_form_names', EJECT ??
*copyc fdh$get_form_names

  PROCEDURE [XDCL] fdp$get_form_names
    (    form_identifier: fdt$form_identifier;
         name_selections: fdt$name_selections;
     VAR form_names: fdt$form_names;
     VAR number_names: fdt$number_names;
     VAR status: ost$status);

    VAR
      n: integer,
      total_number_names: integer,
      p_form_definition: ^fdt$form_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_status: ^fdt$form_status;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_form_names;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_form_names;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    number_names := 0;
    total_number_names := UPPERBOUND (form_names);

    IF fdc$select_variable IN name_selections THEN

{ Return variable names in form.

      FOR n := 1 TO p_form_definition^.form_variable_definitions.active_number DO
        IF number_names < total_number_names THEN
          number_names := number_names + 1;
          form_names [number_names].name := p_form_status^.p_form_variable_definitions^ [n].name;
          form_names [number_names].name_selection := fdc$select_variable;

        ELSE

{ The user has not allocated enough space to hold all the form names.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$too_many_form_names,
                p_form_definition^.form_name, status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    IF fdc$select_table IN name_selections THEN

{ Return table names in

      FOR n := 1 TO p_form_definition^.form_table_definitions.active_number DO
        IF number_names < total_number_names THEN
          number_names := number_names + 1;
          form_names [number_names].name := p_form_status^.p_form_table_definitions^ [n].name;
          form_names [number_names].name_selection := fdc$select_table;

        ELSE

{ The user has not allocated enough space to hold all the form names.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$too_many_form_names,
                p_form_definition^.form_name, status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    IF fdc$select_object IN name_selections THEN

{ Return object names in form. Only return name of first occurrence of object.

      p_form_object_definitions := p_form_status^.p_form_object_definitions;

    /get_object_names/
      FOR n := 1 TO p_form_definition^.form_object_definitions.active_number DO
        IF p_form_object_definitions^ [n].name <> osc$null_name THEN
          IF p_form_object_definitions^ [n].occurrence = 1 THEN
            CASE p_form_object_definitions^ [n].key OF


            = fdc$form_text_box_fragment, fdc$form_table =
              CYCLE /get_object_names/;

            ELSE
              IF number_names < total_number_names THEN
                number_names := number_names + 1;
                form_names [number_names].name := p_form_object_definitions^ [n].name;
                form_names [number_names].name_selection := fdc$select_object;

              ELSE

{ The user has not allocated enough space to hold all the form names.

                osp$set_status_abnormal (fdc$format_display_identifier, fde$too_many_form_names,
                      p_form_definition^.form_name, status);
                RETURN;
              IFEND;
            CASEND;
          IFEND;
        IFEND;
      FOREND /get_object_names/;
    IFEND;
  PROCEND fdp$get_form_names;

?? TITLE := 'change_form', EJECT ??

  PROCEDURE change_form
    (    p_form_status: ^fdt$form_status;
         p_form_definition: ^fdt$form_definition;
     VAR form_attributes: fdt$form_attributes;
     VAR status: ost$status);

    VAR
      comment_index: fdt$comment_index,
      event_action: fdt$event_action,
      event_index: fdt$event_index,
      event_label: fdt$event_label_v1,
      event_name: ost$name,
      event_trigger: fdt$event_trigger,
      event_trigger_reassignment: boolean,
      j: fdt$event_index,
      n: fdt$form_attribute_index,
      name_exists: boolean,
      name_is_valid: boolean,
      object_display_colors: fdt$display_attribute_set,
      object_index: fdt$object_index,
      old_colors: fdt$display_attribute_set,
      new_colors: fdt$display_attribute_set,
      p_comment_definitions: ^array [1 .. * ] of fdt$comment_definition,
      p_display_definition: ^fdt$display_definition,
      p_event_command: ^fdt$event_command,
      p_event_definition: ^fdt$event_definition,
      p_event_definitions: ^array [1 .. * ] of fdt$event_definition,
      p_form_module: ^fdt$form_module,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_help_message: ^fdt$help_message,
      valid_label: ost$name,
      valid_name: ost$name,
      variable_index: fdt$variable_index;

?? NEWTITLE := 'add_event', EJECT ??

    PROCEDURE add_event;

      VAR
        p_command: ^fdt$event_command;

          fdp$validate_name (event_name, p_form_definition^.processor, valid_name,
                name_is_valid);
          IF NOT name_is_valid THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_event_name,
                  form_attributes [n].event_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            EXIT change_form;
          IFEND;

          p_event_definitions := p_form_status^.p_event_definitions;

        /find_duplicate_event/
          FOR event_index := 1 TO p_form_definition^.event_definitions.active_number DO
            p_event_definition := ^p_event_definitions^ [event_index];
            IF p_event_definition^.event_name = valid_name THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$event_name_exists,
                    form_attributes [n].event_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                    status);
              EXIT change_form;
            IFEND;

            IF p_event_definition^.event_trigger = event_trigger THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$event_trigger_exists,
                    p_form_definition^.form_name, status);
              EXIT change_form;
            IFEND;
          FOREND /find_duplicate_event/;

          allocate_event_definition (p_event_definition);
          IF NOT status.normal THEN
            EXIT change_form;
          IFEND;

          p_event_definition^.event_action := event_action;
          p_event_definition^.event_trigger := event_trigger;

{ Convert old event triggers to new event triggers.

          CASE p_event_definition^.event_trigger OF

          = fdc$quit =
            p_event_definition^.event_trigger := fdc$stop;

          = fdc$exit =
            p_event_definition^.event_trigger := fdc$shift_stop;

          = fdc$first =
            p_event_definition^.event_trigger := fdc$shift_backward;

          = fdc$last =
            p_event_definition^.event_trigger := fdc$shift_forward;

          ELSE { Event trigger needs no conversion.
          CASEND;

          p_event_definition^.event_name := valid_name;
          p_event_definition^.event_label := event_label;
          p_event_definition^.event_trigger_reassignment := event_trigger_reassignment;

          IF event_action = fdc$execute_command THEN
            IF (p_event_command = NIL) THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_address, '', status);
              p_form_definition^.event_definitions.active_number :=
                    p_form_definition^.event_definitions.active_number - 1;
               EXIT change_form;
            IFEND;

           NEXT p_command: [STRLENGTH (p_event_command^)] IN
                  p_form_status^.p_form_module;
            IF p_command <> NIL THEN
              p_command^ := p_event_command^;
              fdp$rel_event_command (p_command, p_form_module, p_event_definition^.command);

            ELSE

{ No space can be allocated for events.

           p_form_definition^.event_definitions.active_number :=
                    p_form_definition^.event_definitions.active_number - 1;
              osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
               EXIT change_form;
            IFEND;
          IFEND;

          form_attributes [n].put_value_status := fdc$put_value_accepted;

     PROCEND add_event;

?? OLDTITLE ??
?? NEWTITLE := 'allocate_display_definition', EJECT ??

    PROCEDURE allocate_display_definition
      (VAR display_definitions: fdt$display_definitions;
       VAR p_display_definition: ^fdt$display_definition);

      VAR
        i: fdt$display_index,
        number_object_displays: fdt$number_object_displays,
        p_new_display_definitions: ^array [1 .. * ] of fdt$display_definition,
        p_old_display_definitions: ^array [1 .. * ] of fdt$display_definition;

      p_old_display_definitions := p_form_status^.p_display_definitions;
      IF p_old_display_definitions = NIL THEN

{ Allocate the first array for display definitions.

        NEXT p_new_display_definitions: [1 .. fdc$displays_to_expand] IN p_form_status^.p_form_module;
        IF p_new_display_definitions = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
          RETURN;
        IFEND;

        p_display_definition := ^p_new_display_definitions^ [1];
        p_form_definition^.display_definitions.active_number := 1;
        fdp$rel_displays (p_new_display_definitions, p_form_status);
        RETURN;
      IFEND;

{ An array for displays exists. Try to use an inactive entry.

      number_object_displays := p_form_definition^.display_definitions.active_number;
      IF number_object_displays < p_form_definition^.display_definitions.total_number THEN
        number_object_displays := number_object_displays + 1;
        p_form_definition^.display_definitions.active_number := number_object_displays;
        p_display_definition := ^p_old_display_definitions^ [number_object_displays];
        RETURN;
      IFEND;

{ Expand the array for displays.

      NEXT p_new_display_definitions: [1 .. fdc$displays_to_expand + number_object_displays] IN
            p_form_status^.p_form_module;
      IF p_new_display_definitions = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

{ Copy old displays to new array.

      fdp$rel_displays (p_new_display_definitions, p_form_status);
      FOR i := 1 TO number_object_displays DO
        p_new_display_definitions^ [i] := p_old_display_definitions^ [i];
      FOREND;

      number_object_displays := number_object_displays + 1;
      p_display_definition := ^p_new_display_definitions^ [number_object_displays];
      p_form_definition^.display_definitions.active_number := number_object_displays;
    PROCEND allocate_display_definition;

?? OLDTITLE ??
?? NEWTITLE := 'allocate_event_definition', EJECT ??

    PROCEDURE allocate_event_definition
      (VAR p_event_definition: ^fdt$event_definition);

      VAR
        i: fdt$event_index,
        number_events: fdt$number_events,
        p_new_event_definitions: ^array [1 .. * ] of fdt$event_definition,
        p_old_event_definitions: ^array [1 .. * ] of fdt$event_definition;

      p_old_event_definitions := p_form_status^.p_event_definitions;
      IF p_old_event_definitions = NIL THEN

{ Allocate initial array for events.

        NEXT p_new_event_definitions: [1 .. fdc$events_to_expand] IN p_form_status^.p_form_module;
        IF p_new_event_definitions = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
          RETURN;
        IFEND;

        fdp$rel_events (p_new_event_definitions, p_form_status);
        p_event_definition := ^p_new_event_definitions^ [1];
        p_form_definition^.event_definitions.active_number := 1;
        RETURN;
      IFEND;

{ Try to find an inactive entry.

      number_events := p_form_definition^.event_definitions.active_number;
      IF number_events < p_form_definition^.event_definitions.total_number THEN
        number_events := number_events + 1;
        p_form_definition^.event_definitions.active_number := number_events;
        p_event_definition := ^p_old_event_definitions^ [number_events];
        RETURN;
      IFEND;

{ Expand the array for events.

      NEXT p_new_event_definitions: [1 .. fdc$events_to_expand + number_events] IN
            p_form_status^.p_form_module;
      IF p_new_event_definitions = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

      FOR i := 1 TO number_events DO
        p_new_event_definitions^ [i] := p_old_event_definitions^ [i];
      FOREND;

      fdp$rel_events (p_new_event_definitions, p_form_status);
      number_events := number_events + 1;
      p_form_definition^.event_definitions.active_number := number_events;
      p_event_definition := ^p_new_event_definitions^ [number_events];
    PROCEND allocate_event_definition;

?? OLDTITLE ??
?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT change_form;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT change_form;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE ??
?? NEWTITLE := 'find_event_name', EJECT ??

    PROCEDURE [INLINE] find_event_name
      (    event_name: ost$name;
           p_event_definitions: ^array [1 .. * ] of fdt$event_definition;
       VAR number_events: fdt$number_events;
       VAR p_event_definition: ^fdt$event_definition;
       VAR event_index: fdt$event_index;
       VAR name_exists: boolean);

      name_exists := FALSE;

    /find_event/
      FOR event_index := 1 TO number_events DO
        p_event_definition := ^p_event_definitions^ [event_index];
        IF p_event_definition^.event_name = event_name THEN
          name_exists := TRUE;
          EXIT /find_event/;
        IFEND;
      FOREND /find_event/;
    PROCEND find_event_name;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    p_form_module := p_form_status^.p_form_module;

  /change_form_attributes/
    FOR n := LOWERBOUND (form_attributes) TO UPPERBOUND (form_attributes) DO

    /process_form_attribute/
      BEGIN
        CASE form_attributes [n].key OF

        = fdc$add_event =
          event_name := form_attributes [n].event_name;
          event_label := form_attributes [n].event_label;
          event_trigger := form_attributes [n].event_trigger;
          event_action := form_attributes [n].event_action;
          event_trigger_reassignment := TRUE;
          IF event_action = fdc$execute_command THEN
            p_event_command := form_attributes [n].p_event_command;
          IFEND;
          add_event;

{ If status is set abnormal, an exit occurs to change_form.

        = fdc$add_event_v1 =
          event_name := form_attributes [n].event_name_v1;
          event_label := form_attributes [n].event_label_v1;
          event_trigger := form_attributes [n].event_trigger_v1;
          event_action := form_attributes [n].event_action_v1;
          event_trigger_reassignment := form_attributes [n].event_trigger_reassignment_v1;
          IF event_action = fdc$execute_command THEN
            p_event_command := form_attributes [n].p_event_command_v1;
          IFEND;
          add_event;

{ If status is set abnormal, an exit occurs to change_form.

        = fdc$add_form_comment =
          IF (form_attributes [n].p_form_comment = NIL) THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_address,
                  p_form_definition^.form_name, status);
            RETURN;
          IFEND;

          fdp$add_comment (p_form_status, p_form_definition, form_attributes [n].p_form_comment,
                p_form_definition^.comment_definitions, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          form_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$add_display_definition =
          fdp$validate_name (form_attributes [n].display_name, p_form_definition^.processor, valid_name,
                name_is_valid);
          IF NOT name_is_valid THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_display_name,
                  form_attributes [n].display_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          fdp$find_display_name (valid_name, p_form_status^.p_display_definitions,
                p_form_definition^.display_definitions.active_number, p_display_definition, name_exists);
          IF name_exists THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$display_name_exists,
                  form_attributes [n].display_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          allocate_display_definition (p_form_definition^.display_definitions, p_display_definition);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          p_display_definition^.name := valid_name;
          fdp$set_display_attributes (p_form_definition^.display_attribute,
                form_attributes [n].display_attribute, p_display_definition^.attribute);
          form_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$delete_all_displays =
          p_form_definition^.display_definitions.active_number := 0;
          form_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$delete_all_events =
          p_form_definition^.event_definitions.active_number := 0;
          form_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$delete_event =
          fdp$validate_name (form_attributes [n].name, p_form_definition^.processor, valid_name,
                name_is_valid);
          IF NOT name_is_valid THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_event_name,
                  form_attributes [n].name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          find_event_name (valid_name, p_form_status^.p_event_definitions,
                p_form_definition^.event_definitions.active_number, p_event_definition, event_index,
                name_exists);
          IF NOT name_exists THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_event_name,
                  form_attributes [n].name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          p_form_definition^.event_definitions.active_number :=
                p_form_definition^.event_definitions.active_number - 1;
          form_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$delete_form_comments =
          p_comment_definitions := fdp$ptr_comments (p_form_definition^.comment_definitions, p_form_module);
          IF p_comment_definitions = NIL THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$no_comments_to_delete,
                  p_form_definition^.form_name, status);
            RETURN;
          IFEND;

          fdp$rel_comments (NIL, p_form_module, p_form_definition^.comment_definitions);
          form_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$delete_display_definition =
          fdp$validate_name (form_attributes [n].display_name, p_form_definition^.processor, valid_name,
                name_is_valid);
          IF NOT name_is_valid THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_display_name,
                  form_attributes [n].display_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          fdp$find_display_name (valid_name, p_form_status^.p_display_definitions,
                p_form_definition^.display_definitions.active_number, p_display_definition, name_exists);
          IF NOT name_exists THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_display_name,
                  form_attributes [n].display_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          p_display_definition^ := p_form_status^.p_display_definitions^
                [p_form_definition^.display_definitions.active_number];
          p_form_definition^.display_definitions.active_number :=
                p_form_definition^.display_definitions.active_number - 1;
          form_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$design_display_attribute =
          p_form_status^.design_display_attribute := form_attributes [n].design_display_attribute;
          form_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$design_variable_name =
          fdp$validate_name (form_attributes [n].design_variable_name, p_form_definition^.processor,
                valid_name, name_is_valid);
          IF NOT name_is_valid THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_variable_name,
                  form_attributes [n].form_name, status);
            RETURN;
          IFEND;

          p_form_status^.design_variable_name := valid_name;
          form_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$event_form =
          CASE form_attributes [n].event_form_definition.key OF

          = fdc$no_event_form, fdc$system_default_event_form =
            p_form_definition^.event_form_definition.key := form_attributes [n].event_form_definition.key;
            form_attributes [n].put_value_status := fdc$put_value_accepted;

          = fdc$user_event_form =
            clp$validate_name (form_attributes [n].event_form_definition.event_form_name, valid_name,
                  name_is_valid);
            IF NOT name_is_valid THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_event_form_name,
                    p_form_definition^.form_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    form_attributes [n].event_form_definition.event_form_name, status);
              RETURN;
            IFEND;

            p_form_definition^.event_form_definition.key := fdc$user_event_form;
            p_form_definition^.event_form_definition.event_form_name := valid_name;
            form_attributes [n].put_value_status := fdc$put_value_accepted;

          ELSE

{ Invalid event form key.

            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_event_form_key,
                  p_form_definition^.form_name, status);
            RETURN;
          CASEND;

        = fdc$fast_form_creation =
          form_attributes [n].put_value_status := fdc$put_value_accepted;
          p_form_status^.fast_form_creation :=
                form_attributes [n].fast_form_creation;

        = fdc$form_area =
          CASE form_attributes [n].form_area.key OF

          = fdc$screen_area =
            p_form_definition^.form_area := form_attributes [n].form_area;
            form_attributes [n].put_value_status := fdc$put_value_accepted;

          = fdc$defined_area =
            IF ((form_attributes [n].form_area.x_position < 1) OR
                  (form_attributes [n].form_area.x_position > fdc$maximum_x_position)) THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_x_position, '', status);
              osp$append_status_integer (osc$status_parameter_delimiter,
                    $INTEGER (form_attributes [n].form_area.x_position), 10, FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                    status);
              RETURN;
            IFEND;

            IF ((form_attributes [n].form_area.y_position < 1) OR
                  (form_attributes [n].form_area.y_position > fdc$maximum_y_position)) THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_y_position, '', status);
              osp$append_status_integer (osc$status_parameter_delimiter,
                    $INTEGER (form_attributes [n].form_area.y_position), 10, FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                    status);
              RETURN;
            IFEND;

            IF ((form_attributes [n].form_area.width < 1) OR ((form_attributes [n].form_area.width +
                  form_attributes [n].form_area.x_position - 1) > fdc$maximum_x_position)) THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_width, '', status);
              osp$append_status_integer (osc$status_parameter_delimiter,
                    $INTEGER (form_attributes [n].form_area.width), 10, FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                    status);
              RETURN;
            IFEND;

            IF ((form_attributes [n].form_area.height < 1) OR
                  ((form_attributes [n].form_area.height + form_attributes [n].form_area.y_position - 1) >
                  fdc$maximum_y_position)) THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_height, '', status);
              osp$append_status_integer (osc$status_parameter_delimiter,
                    $INTEGER (form_attributes [n].form_area.height), 10, FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                    status);
              RETURN;
            IFEND;

{ Make sure all objects are inside form area.

            p_form_definition^.form_area := form_attributes [n].form_area;
            p_form_object_definitions := p_form_status^.p_form_object_definitions;

            FOR object_index := 1 TO p_form_definition^.form_object_definitions.active_number DO
              fdp$check_object_inside_form (p_form_definition^.form_area,
                    ^p_form_object_definitions^ [object_index], p_form_definition^.form_name, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            FOREND;

            form_attributes [n].put_value_status := fdc$put_value_accepted;

          ELSE

{ The form area key is invalid.

            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_form_area_key,
                  p_form_definition^.form_name, status);
            RETURN;
          CASEND;

        = fdc$form_display_attribute =
          old_colors := p_form_definition^.display_attribute * fdv$colors;
          fdp$set_display_attributes (p_form_definition^.display_attribute,
                form_attributes [n].form_display_attribute, p_form_definition^.display_attribute);
          p_form_definition^.display_attribute := p_form_definition^.display_attribute +
                $fdt$display_attribute_set [fdc$protect];
          form_attributes [n].put_value_status := fdc$put_value_accepted;
          new_colors := p_form_definition^.display_attribute * fdv$colors;
          IF new_colors = old_colors THEN
            CYCLE /change_form_attributes/;
          IFEND;

{ Change default colors of objects to match new color of form.

          p_form_object_definitions := p_form_status^.p_form_object_definitions;

        /change_object_display/
          FOR object_index := 1 TO p_form_definition^.form_object_definitions.active_number DO
            p_form_object_definition := ^p_form_object_definitions^ [object_index];
            IF p_form_object_definition^.key <> fdc$form_unused_object THEN
              object_display_colors := p_form_object_definition^.display_attribute * fdv$colors;
              IF object_display_colors = old_colors THEN
                p_form_object_definition^.display_attribute := (p_form_object_definition^.display_attribute -
                      fdv$colors) + new_colors;
              IFEND;
            IFEND;
          FOREND /change_object_display/;

        = fdc$form_help =
          CASE form_attributes [n].form_help.key OF

          = fdc$no_help_response, fdc$system_default_help =
            p_form_definition^.help_definition.key := form_attributes [n].form_help.key;
            form_attributes [n].put_value_status := fdc$put_value_accepted;

          = fdc$help_form =
            clp$validate_name (form_attributes [n].form_help.help_form, valid_name, name_is_valid);
            IF NOT name_is_valid THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_help_form_name,
                    form_attributes [n].form_help.help_form, status);
              RETURN;
            IFEND;

            p_form_definition^.help_definition.key := fdc$help_form;
            p_form_definition^.help_definition.help_form := valid_name;
            form_attributes [n].put_value_status := fdc$put_value_accepted;

          = fdc$help_message =
            IF (form_attributes [n].form_help.p_help_message = NIL) THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_address,
                    p_form_definition^.form_name, status);
              RETURN;
            IFEND;

            NEXT p_help_message: [STRLENGTH (form_attributes [n].form_help.p_help_message^)] IN
                  p_form_status^.p_form_module;
            IF p_help_message = NIL THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
              RETURN;
            IFEND;

            p_form_definition^.help_definition.key := fdc$help_message;
            p_form_definition^.help_definition.p_help_message := #REL (p_help_message, p_form_module^);
            p_help_message^ := form_attributes [n].form_help.p_help_message^;
            form_attributes [n].put_value_status := fdc$put_value_accepted;

          ELSE

{ Invalid help key.

            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_help_key,
                  p_form_definition^.form_name, status);
            RETURN;
          CASEND;

        = fdc$form_language =
          clp$validate_name (form_attributes [n].form_language, valid_name, name_is_valid);
          IF NOT name_is_valid THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_form_language,
                  form_attributes [n].form_language, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          p_form_definition^.language := valid_name;
          form_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$form_name =
          clp$validate_name (form_attributes [n].form_name, valid_name, name_is_valid);
          IF NOT name_is_valid THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_form_name,
                  form_attributes [n].form_name, status);
            RETURN;
          IFEND;

          p_form_definition^.form_name := valid_name;
          form_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$form_processor =
          CASE form_attributes [n].form_processor OF

          = fdc$ansi_fortran_processor, fdc$cdc_fortran_processor, fdc$cybil_processor,
                fdc$scl_processor, fdc$pascal_processor, fdc$unknown_processor,
                fdc$extended_fortran_processor =

{ A non COBOL processor cannot have any variables with a program COBOL data type.

          /search_for_cobol_data_type/
            FOR variable_index := 1 to p_form_definition^.form_variable_definitions.active_number DO
              IF p_form_status^.p_form_variable_definitions^ [variable_index].program_data_type =
                    fdc$program_cobol_type THEN
                osp$set_status_abnormal (fdc$format_display_identifier,
                       fde$invalid_cobol_data_type,
                       p_form_status^.p_form_variable_definitions^ [variable_index].name, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                       p_form_definition^.form_name,  status);
                RETURN;
              IFEND;
            FOREND /search_for_cobol_data_type/;

            p_form_definition^.processor := form_attributes [n].form_processor;
            form_attributes [n].put_value_status := fdc$put_value_accepted;

          = fdc$cobol_processor =
            p_form_definition^.processor := form_attributes [n].form_processor;
            form_attributes [n].put_value_status := fdc$put_value_accepted;

          ELSE
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_form_processor,
                  p_form_definition^.form_name, status);
            RETURN;
          CASEND;

        = fdc$help_message_form =
          IF form_attributes [n].help_message_form <> osc$null_name THEN
            clp$validate_name (form_attributes [n].help_message_form, valid_name, name_is_valid);
            IF NOT name_is_valid THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_message_form_name,
                    form_attributes [n].help_message_form, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                    status);
              RETURN;
            IFEND;
            p_form_definition^.help_message_form := valid_name;
          ELSE
            p_form_definition^.help_message_form := osc$null_name;
          IFEND;

          form_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$hidden_editing =
          p_form_definition^.hidden_editing := form_attributes [n].hidden_editing;
          form_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$invalid_data_character =
          form_attributes [n].put_value_status := fdc$put_value_accepted;
          p_form_definition^.invalid_data_character := form_attributes [n].invalid_data_character;

        = fdc$message_form, fdc$error_message_form =
          IF form_attributes [n].error_message_form <> osc$null_name THEN
            clp$validate_name (form_attributes [n].error_message_form, valid_name, name_is_valid);
            IF NOT name_is_valid THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_message_form_name,
                    form_attributes [n].error_message_form, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                    status);
              RETURN;
            IFEND;
            p_form_definition^.error_message_form := valid_name;
          ELSE
            p_form_definition^.error_message_form := osc$null_name;
          IFEND;

          form_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$unused_form_entry =
          form_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$validate_variable_values =
          form_attributes [n].put_value_status := fdc$put_value_accepted;
          p_form_status^.validate_variable_values :=
                form_attributes [n].validate_variable_values;
        ELSE

{ Invalid change form key.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_form_attribute,
                p_form_definition^.form_name, status);
          RETURN;

        CASEND;
      END /process_form_attribute/;
    FOREND /change_form_attributes/;

  PROCEND change_form;

MODEND fdm$process_form;
*DECK DECK=FDM$PROCESS_OBJECT EXPAND=TRUE

?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Screen Formatting: Create Form' ??
MODULE fdm$process_object;

{ PURPOSE:
{   This module creates, changes, and gets data about a form object definition.
{
{ DESIGN:
{   Do not make any changes to a stored form object definition if any of the
{   changes are invalid.
{
{ NOTES:
{  All external procedures appear first in alphabetical order.  Then all the
{  procedures internal to this module.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc cyd$run_time_error_condition
*copyc fde$condition_identifiers
*copyc fdc$system_design_variable_name
*copyc fdc$system_occurrence
*copyc fdt$form_identifier
*copyc fdt$form_object_definition
*copyc fdt$form_objects
*copyc fdt$get_object_attributes
*copyc fdt$number_objects
*copyc fdt$object_attributes
*copyc fdt$object_definition
*copyc fdt$object_attribute_index
*copyc ost$name
?? POP ??

*copyc fdv$background_colors
*copyc fdv$colors
*copyc fdv$foreground_colors
*copyc fdv$object_display_directions

*copyc fdp$check_for_overlayed_objects
*copyc fdp$find_change_form_definition
*copyc fdp$find_form_definition
*copyc fdp$find_object_definition
*copyc fdp$find_variable_definition
*copyc fdp$get_string_variable
*copyc fdp$locate_added_variable_facts
*copyc fdp$ptr_event_command
*copyc fdp$ptr_objects
*copyc fdp$ptr_text
*copyc fdp$rel_event_command
*copyc fdp$rel_events
*copyc fdp$rel_objects
*copyc fdp$rel_text
*copyc fdp$record_screen_change
*copyc fdp$replace_string_variable
*copyc fdp$validate_name
*copyc pmp$continue_to_cause
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    fdc$initial_x_position = 1,
    fdc$initial_y_position = 1,
    fdc$objects_to_expand = 20;

?? TITLE := 'fdp$add_object_to_form_image', EJECT ??
*copyc fdh$add_object_to_form_image

  PROCEDURE [XDCL] fdp$add_object_to_form_image
    (    p_form_image: ^fdt$form_image;
         p_form_object_definition: ^fdt$form_object_definition);

    VAR
      current_x_position: fdt$x_position,
      current_y_position: fdt$y_position,
      end_object_x_position: fdt$x_position,
      end_object_y_position: fdt$y_position,
      x_position: fdt$x_position,
      y_position: fdt$y_position;

    x_position := p_form_object_definition^.x_position;
    y_position := p_form_object_definition^.y_position;

{ Mark characters in form image occupied by object.  Other procedures check the
{ character image of the form to make sure that objects do not overlay each other.

    CASE p_form_object_definition^.key OF

    = fdc$form_box =
      end_object_x_position := x_position + p_form_object_definition^.box_width - 1;
      end_object_y_position := y_position + p_form_object_definition^.box_height - 1;

{ Create top and bottom line of box.

      FOR current_x_position := x_position TO end_object_x_position DO
        p_form_image^ [y_position] (current_x_position, 1) := '-';
        p_form_image^ [end_object_y_position] (current_x_position, 1) := '-';
      FOREND;


{ Create left and right vertical line of box.

      FOR current_y_position := y_position + 1 TO end_object_y_position - 1 DO
        p_form_image^ [current_y_position] (x_position, 1) := '|';
        p_form_image^ [current_y_position] (end_object_x_position, 1) := '|';
      FOREND;

    = fdc$form_line =
      IF (p_form_object_definition^.y_increment = 0) THEN

{ Create a horizontal line.

        FOR current_x_position := x_position TO x_position + p_form_object_definition^.x_increment DO
          p_form_image^ [y_position] (current_x_position, 1) := '-';
        FOREND;

      ELSE

{ Create a vertical line.

        FOR current_y_position := y_position TO y_position + p_form_object_definition^.y_increment DO
          p_form_image^ [current_y_position] (x_position, 1) := '|';
        FOREND;
      IFEND;

    = fdc$form_variable_text =
      FOR current_x_position := x_position TO x_position + p_form_object_definition^.text_variable_width -
            1 DO
        p_form_image^ [y_position] (current_x_position, 1) := 'v';
      FOREND;

    = fdc$form_variable_text_box =
      FOR current_y_position := y_position TO y_position + p_form_object_definition^.variable_box_height -
            1 DO
        FOR current_x_position := x_position TO x_position + p_form_object_definition^.variable_box_width -
              1 DO
          p_form_image^ [current_y_position] (current_x_position, 1) := 'v';
        FOREND;
      FOREND;

    = fdc$form_constant_text =
      FOR current_x_position := x_position TO x_position + p_form_object_definition^.constant_text_width -
            1 DO
        p_form_image^ [y_position] (current_x_position, 1) := 'c';
      FOREND;

    = fdc$form_constant_text_box =
      FOR current_y_position := y_position TO y_position + p_form_object_definition^.constant_box_height -
            1 DO
        FOR current_x_position := x_position TO x_position + p_form_object_definition^.constant_box_width -
              1 DO
          p_form_image^ [current_y_position] (current_x_position, 1) := 'c';
        FOREND;
      FOREND;

    ELSE { Ignore object. }
    CASEND;

  PROCEND fdp$add_object_to_form_image;

?? TITLE := 'fdp$allocate_object', EJECT ??

  PROCEDURE [XDCL] fdp$allocate_object
    (    p_form_status: ^fdt$form_status;
     VAR p_form_object_definition: ^fdt$form_object_definition;
     VAR object_index: fdt$object_index;
     VAR status: ost$status);

    VAR
      i: fdt$object_index,
      number_objects: fdt$number_objects,
      p_new_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_old_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_definition: ^fdt$form_definition;

?? OLDTITLE ??
?? NEWTITLE := 'allocate_form_object_statuses', EJECT ??

    PROCEDURE [INLINE] allocate_form_object_statuses;

      VAR
        n: fdt$object_index,
        p_new_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
        p_old_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status;

      p_old_form_object_statuses := p_form_status^.p_form_object_statuses;

{ Allocate object status to record the current dynamic data for a form object.
{ It contains data about the current display attributes and first character position displayed.
{ Program requests change the current display attributes and the first character position displayed.
{ Terminal user paging and scrolling commands change the first character position displayed.

      ALLOCATE p_new_form_object_statuses: [1 .. UPPERBOUND (p_form_status^.p_form_object_definitions^)];
      IF p_new_form_object_statuses = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

      p_form_status^.total_form_object_statuses := UPPERBOUND (p_form_status^.p_form_object_definitions^);
      p_form_status^.active_form_object_statuses := UPPERBOUND (p_form_status^.p_form_object_definitions^);

{ Copy old objects to new array.

      IF p_old_form_object_statuses <> NIL THEN
        FOR n := 1 TO UPPERBOUND (p_old_form_object_statuses^) DO
          p_new_form_object_statuses^ [n] := p_old_form_object_statuses^ [n];
        FOREND;

        FOR n := UPPERBOUND (p_old_form_object_statuses^) + 1 TO UPPERBOUND (p_new_form_object_statuses^) DO
          p_new_form_object_statuses^ [n].key := fdc$unused_identifier;
        FOREND;

        FREE p_old_form_object_statuses;
      IFEND;
      p_form_status^.p_form_object_statuses := p_new_form_object_statuses;
    PROCEND allocate_form_object_statuses;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    p_old_object_definitions := p_form_status^.p_form_object_definitions;
    p_form_definition := p_form_status^.p_form_definition;
    IF p_old_object_definitions = NIL THEN
      NEXT p_new_object_definitions: [1 .. fdc$objects_to_expand] IN p_form_status^.p_form_module;
      IF p_new_object_definitions = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

      fdp$rel_objects (p_new_object_definitions, p_form_status);
      p_form_object_definition := ^p_new_object_definitions^ [1];
      p_form_definition^.form_object_definitions.active_number := 1;
      object_index := 1;
      IF p_form_status^.opened THEN
        allocate_form_object_statuses;
      IFEND;
      RETURN;
    IFEND;

{ Try to find an inactive entry for new object.

    number_objects := p_form_definition^.form_object_definitions.active_number;
    IF number_objects < p_form_definition^.form_object_definitions.total_number THEN
      number_objects := number_objects + 1;
      p_form_definition^.form_object_definitions.active_number := number_objects;
      p_form_object_definition := ^p_old_object_definitions^ [number_objects];
      object_index := number_objects;
      RETURN;
    IFEND;

{ Expand the array for objects.  Minimize number of allocates by including a few extra entries.

    NEXT p_new_object_definitions: [1 .. fdc$objects_to_expand + number_objects] IN
          p_form_status^.p_form_module;
    IF p_new_object_definitions = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
      RETURN;
    IFEND;

{ Copy old objects to new array.

    FOR i := 1 TO number_objects DO
      p_new_object_definitions^ [i] := p_old_object_definitions^ [i];
    FOREND;

    fdp$rel_objects (p_new_object_definitions, p_form_status);
    number_objects := number_objects + 1;
    p_form_definition^.form_object_definitions.active_number := number_objects;
    p_form_object_definition := ^p_new_object_definitions^ [number_objects];
    object_index := number_objects;
    IF p_form_status^.opened THEN
      allocate_form_object_statuses;
    IFEND;
  PROCEND fdp$allocate_object;

?? TITLE := 'fdp$change_object', EJECT ??
*copyc fdh$change_object

  PROCEDURE [XDCL] fdp$change_object
    (    form_identifier: fdt$form_identifier;
         x_position: fdt$x_position;
         y_position: fdt$y_position;
     VAR object_attributes: fdt$object_attributes;
     VAR status: ost$status);

    VAR
      form_object_key: fdt$form_object_key,
      fragment_object_index: fdt$object_index,
      new_object_definition: fdt$form_object_definition,
      new_object_index: fdt$object_index,
      object_attribute_index: fdt$object_attribute_index,
      object_exists: boolean,
      occurrence: fdt$occurrence,
      old_object_definition: fdt$form_object_definition,
      old_object_index: fdt$object_index,
      p_form_definition: ^fdt$form_definition,
      p_form_module: ^fdt$form_module,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_form_status: ^fdt$form_status,
      p_new_object_definition: ^fdt$form_object_definition,
      p_old_object_definition: ^fdt$form_object_definition,
      p_text: ^fdt$text,
      screen_change: fdt$screen_change,
      variable_name: ost$name,
      text_length: fdt$text_length,
      variable_status: fdt$variable_status;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$change_object;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$change_object;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    FOR object_attribute_index := LOWERBOUND (object_attributes) TO UPPERBOUND (object_attributes) DO
      object_attributes [object_attribute_index].put_value_status := fdc$unprocessed_put_value;
    FOREND;

    fdp$find_change_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    find_form_object (p_form_status, x_position, y_position, p_form_object_definitions,
          p_form_definition^.form_object_definitions.active_number, p_old_object_definition,
          old_object_index, object_exists);
    IF NOT object_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_object_at_position, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (x_position), 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (y_position), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;


{ Work with a copy of the form object definition to prevent any invalid changes being made to it.

    old_object_definition := p_old_object_definition^;
    p_new_object_definition := p_old_object_definition;
    new_object_definition := p_new_object_definition^;
    change_object (p_form_status, p_form_definition, ^new_object_definition, object_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  The object must reside inside form.

    IF NOT p_form_status^.fast_form_creation THEN
      fdp$check_object_inside_form (p_form_definition^.form_area, ^new_object_definition,
            p_form_definition^.form_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Delete old object from the form character image to allow later checking of overlaying of other
{ objects.

    IF p_form_status^.p_form_image <> NIL THEN
      IF NOT (p_form_status^.design_form AND (old_object_definition.key = fdc$form_variable_text) AND
            (p_form_status^.design_variable_name = old_object_definition.name)) THEN
        delete_object_from_form_image (p_form_status^.p_form_image,
             ^old_object_definition);
      IFEND;
    IFEND;

{ The object cannot overlay any existing objects.

    IF p_form_status^.p_form_image <> NIL THEN
      fdp$check_for_overlayed_objects (p_form_status^.p_form_image, ^new_object_definition,
            p_form_definition^.form_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Record object in character image of form to allow easy checking of overlaying of objects.

    IF p_form_status^.p_form_image <> NIL THEN
      IF NOT (p_form_status^.design_form AND (old_object_definition.key =
            fdc$form_variable_text) AND
            (p_form_status^.design_variable_name = old_object_definition.name)) THEN
        fdp$add_object_to_form_image (p_form_status^.p_form_image, ^new_object_definition);
      IFEND;
    IFEND;

{ If all changes are valid, update the object in the form.

    CASE new_object_definition.key OF

    = fdc$form_constant_text_box =

{ Create new objects for constant text box.  The position, height, and width
{ of object fragments may have changed.

      fdp$allocate_object (p_form_status, p_new_object_definition,
            new_object_index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      p_new_object_definition^ := new_object_definition;
      fragment_object_index := 0;
      IF new_object_definition.constant_box_height > 1 THEN
        create_fragments (p_form_status, new_object_index,
              new_object_definition.constant_box_width,
              new_object_definition.constant_box_height,
              fragment_object_index, p_new_object_definition,
              p_form_object_definitions, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      p_new_object_definition^.constant_box_fragment_index := fragment_object_index;

{ Delete old objects for constant text box.

      fragment_object_index := old_object_definition.constant_box_fragment_index;
      WHILE fragment_object_index <> 0 DO
        delete_form_object (fragment_object_index, p_form_object_definitions);
        fragment_object_index :=  p_form_object_definitions^
              [fragment_object_index].next_fragment_object_index;
      WHILEND;
      delete_form_object (old_object_index, p_form_object_definitions);

    = fdc$form_variable_text_box =

{ Create new objects for variable text box.  The position, height, and width
{ of object fragments may have changed.

      fdp$allocate_object (p_form_status, p_new_object_definition,
            new_object_index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      p_new_object_definition^ := new_object_definition;
      fragment_object_index := 0;
      IF new_object_definition.variable_box_height > 1 THEN
        create_fragments (p_form_status, new_object_index,
              new_object_definition.variable_box_width,
              new_object_definition.variable_box_height,
              fragment_object_index, p_new_object_definition,
              p_form_object_definitions, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        p_new_object_definition^.variable_box_fragment_index := fragment_object_index;

{ Delete old objects.

      fragment_object_index := old_object_definition.variable_box_fragment_index;
      WHILE fragment_object_index <> 0 DO
        delete_form_object (fragment_object_index, p_form_object_definitions);
        fragment_object_index := p_form_object_definitions^
              [fragment_object_index].next_fragment_object_index;
      WHILEND;

        delete_form_object (old_object_index, p_form_object_definitions);
      IFEND;

    ELSE

{ Only one object is involved, so simply replace it.

      new_object_index := old_object_index;
      p_new_object_definition^ := new_object_definition;
    CASEND;

    IF NOT p_form_status^.design_form THEN
      RETURN;
    IFEND;

{ Delete any free text under an object, so that the free text will not appear if the
{ object is later deleted.  The free text also needs to be deleted so constant objects
{ are not latter created with the fdp$create_constant_text request.

    delete_free_text_under_object (form_identifier, p_new_object_definition^,
          p_form_definition, p_form_status, status);

{ Record screen changes for next screen update.

    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    form_object_key := old_object_definition.key;
    screen_change.key := fdc$delete_object;
    screen_change.object_form_identifier := form_identifier;
    screen_change.object_definition := old_object_definition;
    CASE form_object_key OF

    = fdc$form_constant_text_box =
      fragment_object_index := old_object_definition.constant_box_fragment_index;
      IF (p_form_status^.displayed_on_screen AND p_form_status^.added) THEN
        screen_change.object_index := old_object_index;
        fdp$record_screen_change (screen_change, status);
      ELSE
        p_form_object_statuses^ [old_object_index].key := fdc$unused_identifier;
      IFEND;

      WHILE fragment_object_index <> 0 DO
        IF (p_form_status^.displayed_on_screen AND p_form_status^.added) THEN
          screen_change.object_index := fragment_object_index;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          p_form_object_statuses^ [fragment_object_index].key := fdc$unused_identifier;
        IFEND;

        fragment_object_index := p_form_object_definitions^
              [fragment_object_index].next_fragment_object_index;
      WHILEND;

    = fdc$form_variable_text_box =
      fragment_object_index := old_object_definition.variable_box_fragment_index;
      IF (p_form_status^.displayed_on_screen AND p_form_status^.added) THEN
        screen_change.object_index := old_object_index;
        fdp$record_screen_change (screen_change, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        p_form_object_statuses^ [old_object_index].key := fdc$unused_identifier;
      IFEND;

      WHILE fragment_object_index <> 0 DO
        IF (p_form_status^.displayed_on_screen AND p_form_status^.added) THEN
          screen_change.object_index := fragment_object_index;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          p_form_object_statuses^ [fragment_object_index].key := fdc$unused_identifier;
        IFEND;
        fragment_object_index := p_form_object_definitions^
              [fragment_object_index].next_fragment_object_index;
      WHILEND;

    ELSE
      IF (p_form_status^.displayed_on_screen AND p_form_status^.added) THEN
        screen_change.object_index := old_object_index;
        fdp$record_screen_change (screen_change, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        p_form_object_statuses^ [old_object_index].key := fdc$unused_identifier;
      IFEND;
    CASEND;

    IF ((p_form_status^.added) AND (p_form_status^.displayed_on_screen)) THEN
      screen_change.key := fdc$add_object;
      screen_change.object_index := new_object_index;
      screen_change.object_definition := p_new_object_definition^;
      fdp$record_screen_change (screen_change, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    ELSE
      p_form_status^.p_form_object_statuses^ [new_object_index].
            display_attribute_set := p_new_object_definition^.display_attribute;
    IFEND;

  PROCEND fdp$change_object;

?? TITLE := 'fdp$change_stored_object', EJECT ??
*copyc fdh$change_stored_object

  PROCEDURE [XDCL] fdp$change_stored_object
    (    form_identifier: fdt$form_identifier;
         name: ost$name;
         occurrence: fdt$occurrence;
         text: fdt$text;
         display_attribute_set: fdt$display_attribute_set;
     VAR status: ost$status);

    VAR
      name_is_valid: boolean,
      object_index: fdt$object_index,
      object_name_exists: boolean,
      object_occurrence_exists: boolean,
      p_form_definition: ^fdt$form_definition,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_status: ^fdt$form_status,
      p_new_text: ^fdt$text,
      p_stored_text: ^fdt$text,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$change_stored_object;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$change_stored_object;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_change_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    fdp$validate_name (name, p_form_definition^.processor, valid_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_object_name, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF ((occurrence < 1) OR (occurrence > fdc$maximum_occurrence)) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_occurrence, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (occurrence), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    p_form_object_definitions := p_form_status^.p_form_object_definitions;

{ The object name and occurrence must exist.

    fdp$find_object_definition (valid_name, occurrence, p_form_object_definitions,
          p_form_definition^.form_object_definitions.active_number, p_form_object_definition, object_index,
          object_name_exists, object_occurrence_exists);
    IF NOT object_name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_object_name, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF NOT object_occurrence_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_occurrence, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (occurrence), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, valid_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    NEXT p_new_text: [STRLENGTH (text)] IN p_form_status^.p_form_module;
    IF p_new_text = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
      RETURN;
    IFEND;

{ Update initial text and display attributes for stored object.

    fdp$rel_text (p_new_text, p_form_status^.p_form_module, p_form_object_definition^.stored_variable_text);
    p_new_text^ := text;
    fdp$set_display_attributes (p_form_definition^.display_attribute, display_attribute_set,
          p_form_object_definition^.display_attribute);

  PROCEND fdp$change_stored_object;

?? TITLE := 'fdp$check_object_inside_form', EJECT ??
*copyc fdh$check_object_inside_form

  PROCEDURE [XDCL] fdp$check_object_inside_form
    (    form_area: fdt$form_area;
         p_form_object_definition: ^fdt$form_object_definition;
         form_name: ost$name;
     VAR status: ost$status);

    VAR
      highest_x_position: fdt$x_position,
      highest_y_position: fdt$y_position,
      x_position: fdt$x_position,
      y_position: fdt$y_position;

    status.normal := TRUE;
    IF form_area.key = fdc$defined_area THEN

{ If form area is the terminal screen area, no checks can be made.
{ Screen Formatting does not know what size the terminal screen is
{ until the application actually uses the form to interact with a
{ terminal user.

      x_position := p_form_object_definition^.x_position;
      y_position := p_form_object_definition^.y_position;

{ Compute the highest x and y positions.

      CASE p_form_object_definition^.key OF

      = fdc$form_box =
        highest_x_position := x_position + p_form_object_definition^.box_width - 1;
        highest_y_position := y_position + p_form_object_definition^.box_height - 1;


      = fdc$form_line =
        highest_x_position := x_position + p_form_object_definition^.x_increment;
        highest_y_position := y_position + p_form_object_definition^.y_increment;

      = fdc$form_variable_text =
        highest_x_position := p_form_object_definition^.text_variable_width + x_position - 1;
        highest_y_position := y_position;

      = fdc$form_variable_text_box =
        highest_x_position := x_position + p_form_object_definition^.variable_box_width - 1;
        highest_y_position := y_position + p_form_object_definition^.variable_box_height - 1;

      = fdc$form_constant_text =
        highest_x_position := p_form_object_definition^.constant_text_width + x_position - 1;
        highest_y_position := y_position;

      = fdc$form_constant_text_box =
        highest_x_position := x_position + p_form_object_definition^.constant_box_width - 1;
        highest_y_position := y_position + p_form_object_definition^.constant_box_height - 1;

      ELSE { Ignore object. }
        RETURN;
      CASEND;

      IF ((highest_x_position > form_area.width) OR (highest_y_position > form_area.height)) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$object_not_in_form, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (x_position), 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (y_position), 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, form_name, status);
      IFEND;
    IFEND;
  PROCEND fdp$check_object_inside_form;

?? TITLE := 'fdp$create_object', EJECT ??
*copyc fdh$create_object

  PROCEDURE [XDCL] fdp$create_object
    (    form_identifier: fdt$form_identifier;
         x_position: fdt$x_position;
         y_position: fdt$y_position;
         object_definition: fdt$object_definition;
     VAR object_attributes: fdt$object_attributes;
     VAR status: ost$status);

    VAR
      display_attribute_set: fdt$display_attribute_set,
      form_object_definition: fdt$form_object_definition,
      fragment_object_index: fdt$object_index,
      high_x_position: fdt$x_position,
      high_y_position: fdt$y_position,
      number_objects: fdt$number_objects,
      object_attribute_index: fdt$object_attribute_index,
      object_exists: boolean,
      object_index: fdt$object_index,
      occurrence: fdt$occurrence,
      p_form_definition: ^fdt$form_definition,
      p_form_module: ^fdt$form_module,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_status: ^fdt$form_status,
      p_text: ^fdt$text,
      screen_change: fdt$screen_change,
      text_length: fdt$text_length,
      variable_name: ost$name,
      variable_status: fdt$variable_status;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$create_object;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$create_object;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE ??
?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    FOR object_attribute_index := LOWERBOUND (object_attributes) TO UPPERBOUND (object_attributes) DO
      object_attributes [object_attribute_index].put_value_status := fdc$unprocessed_put_value;
    FOREND;

    fdp$find_change_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    IF ((x_position < 1) OR (x_position > fdc$maximum_x_position)) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_x_position, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (x_position), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF ((y_position < 1) OR (y_position > fdc$maximum_y_position)) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_y_position, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (y_position), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    number_objects := p_form_definition^.form_object_definitions.active_number;
    p_form_module := p_form_status^.p_form_module;

    fdp$set_display_attributes (p_form_definition^.display_attribute, $fdt$display_attribute_set
          [fdc$protect], form_object_definition.display_attribute);

{ Set generic default values for form object definition.

    form_object_definition.name := osc$null_name;
    form_object_definition.occurrence := 1;
    form_object_definition.x_position := x_position;
    form_object_definition.y_position := y_position;

{ Validate object definition according to type of object.
{ Set default values appropriate to type of object.

    CASE object_definition.key OF

    = fdc$box =
      IF ((object_definition.box_width < 1) OR (object_definition.box_width > fdc$maximum_x_position)) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_width, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (object_definition.box_width), 10,
              FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      IF ((object_definition.box_height < 1) OR (object_definition.box_height > fdc$maximum_y_position)) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_height, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (object_definition.box_height),
              10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      form_object_definition.key := fdc$form_box;
      form_object_definition.box_width := object_definition.box_width;
      form_object_definition.box_height := object_definition.box_height;
      form_object_definition.display_attribute := form_object_definition.display_attribute +
            $fdt$display_attribute_set [fdc$medium_line];

    = fdc$line =
      IF ((object_definition.x_increment < 0) OR (object_definition.x_increment > fdc$maximum_x_position))
            THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_x_increment, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (object_definition.x_increment),
              10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      IF ((object_definition.y_increment < 0) OR (object_definition.y_increment > fdc$maximum_y_position))
            THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_y_increment, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (object_definition.y_increment),
              10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      form_object_definition.key := fdc$form_line;
      form_object_definition.x_increment := object_definition.x_increment;
      form_object_definition.y_increment := object_definition.y_increment;
      form_object_definition.display_attribute := form_object_definition.display_attribute +
            $fdt$display_attribute_set [fdc$medium_line];

    = fdc$constant_text =
      IF ((object_definition.constant_text_width < 1) OR (object_definition.constant_text_width >
            fdc$maximum_x_position)) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_width, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (object_definition.constant_text_width), 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      IF object_definition.p_constant_text = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_text_for_object,
              p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      NEXT p_text: [STRLENGTH (object_definition.p_constant_text^)] IN p_form_status^.p_form_module;
      IF p_text = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

      form_object_definition.key := fdc$form_constant_text;
      p_text^ := object_definition.p_constant_text^;
      fdp$rel_text (p_text, p_form_module, form_object_definition.constant_text);
      form_object_definition.constant_text_width := object_definition.constant_text_width;

    = fdc$constant_text_box =
      IF ((object_definition.constant_box_width < 1) OR (object_definition.constant_box_width >
            fdc$maximum_x_position)) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_width, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (object_definition.constant_box_width), 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      IF ((object_definition.constant_box_height < 1) OR (object_definition.constant_box_height >
            fdc$maximum_y_position)) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_height, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (object_definition.constant_box_height), 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      CASE object_definition.constant_box_processing OF

      = fdc$wrap_characters, fdc$wrap_words =

      ELSE
        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_text_processing,
              p_form_definition^.form_name, status);
        RETURN;
      CASEND;

      form_object_definition.constant_box_processing := object_definition.constant_box_processing;
      IF object_definition.p_constant_box_text = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_text_for_object,
              p_form_definition^.form_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      NEXT p_text: [STRLENGTH (object_definition.p_constant_box_text^)] IN p_form_status^.p_form_module;
      IF p_text = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

      form_object_definition.key := fdc$form_constant_text_box;
      form_object_definition.constant_box_width := object_definition.constant_box_width;
      form_object_definition.constant_box_height := object_definition.constant_box_height;
      form_object_definition.constant_box_fragment_index := 0;
      p_text^ := object_definition.p_constant_box_text^;
      fdp$rel_text (p_text, p_form_module, form_object_definition.constant_box_text);

    = fdc$table =
      IF ((object_definition.table_width < 1) OR (object_definition.table_width > fdc$maximum_x_position))
            THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_width, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (object_definition.table_width),
              10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      IF ((object_definition.table_height < 1) OR (object_definition.table_height > fdc$maximum_y_position))
            THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_height, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (object_definition.table_height),
              10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      form_object_definition.key := fdc$form_table;
      form_object_definition.table_height := object_definition.table_height;
      form_object_definition.table_width := object_definition.table_width;

    = fdc$variable_text =
      IF ((object_definition.variable_text_width < 1) OR (object_definition.variable_text_width >
            fdc$maximum_x_position)) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_width, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (object_definition.variable_text_width), 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      IF object_definition.p_variable_text = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_text_for_object,
              p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      NEXT p_text: [STRLENGTH (object_definition.p_variable_text^)] IN p_form_status^.p_form_module;
      IF p_text = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

      form_object_definition.key := fdc$form_variable_text;
      form_object_definition.text_variable_exists := FALSE;
      form_object_definition.text_variable_width := object_definition.variable_text_width;
      p_text^ := object_definition.p_variable_text^;
      fdp$rel_text (p_text, p_form_module, form_object_definition.text_variable_text);

    = fdc$variable_text_box =
      IF ((object_definition.variable_box_width < 1) OR (object_definition.variable_box_width >
            fdc$maximum_x_position)) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_width, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (object_definition.variable_box_width), 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      IF ((object_definition.variable_box_height < 1) OR (object_definition.variable_box_height >
            fdc$maximum_y_position)) THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_height, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (object_definition.variable_box_height), 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      IF object_definition.p_variable_box_text = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_text_for_object,
              p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      CASE object_definition.variable_box_processing OF
      = fdc$wrap_characters, fdc$wrap_words =
      ELSE
        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_text_processing,
              p_form_definition^.form_name, status);
        RETURN;
      CASEND;

      NEXT p_text: [STRLENGTH (object_definition.p_variable_box_text^)] IN p_form_status^.p_form_module;
      IF p_text = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

      form_object_definition.key := fdc$form_variable_text_box;
      form_object_definition.variable_box_variable_exists := FALSE;
      form_object_definition.variable_box_width := object_definition.variable_box_width;
      form_object_definition.variable_box_height := object_definition.variable_box_height;
      form_object_definition.variable_box_processing := object_definition.variable_box_processing;
      form_object_definition.variable_box_fragment_index := 0;
      p_text^ := object_definition.p_variable_box_text^;
      fdp$rel_text (p_text, p_form_module, form_object_definition.variable_box_text);

    ELSE

{ Invalid object definition key.

      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_object_key,
            p_form_definition^.form_name, status);
      RETURN;
    CASEND;

{ Process object attributes.

    change_object (p_form_status, p_form_definition, ^form_object_definition, object_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ The object must reside inside the form.

    IF NOT p_form_status^.fast_form_creation THEN
      fdp$check_object_inside_form (p_form_definition^.form_area, ^form_object_definition,
            p_form_definition^.form_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ The object must not overlay any other objects.

    IF p_form_status^.p_form_image <> NIL THEN
      fdp$check_for_overlayed_objects (p_form_status^.p_form_image, ^form_object_definition,
            p_form_definition^.form_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ The object must be large enough to contain the output/Cobol formatting.

    CASE form_object_definition.key OF

    = fdc$form_variable_text =
      check_object_size (p_form_status, form_object_definition.name,
            form_object_definition.text_variable_width, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

   = fdc$form_variable_text_box =
     check_object_size (p_form_status, form_object_definition.name,
           form_object_definition.variable_box_width *
           form_object_definition.variable_box_height, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

   ELSE { Ignore other objects. }
   CASEND;

    fdp$allocate_object (p_form_status, p_form_object_definition, object_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;

{ The object definition is valid.  Update the form definition to include the object.

    p_form_object_definition^ := form_object_definition;

    IF p_form_status^.p_form_image <> NIL THEN
      IF NOT (p_form_status^.design_form AND
            (form_object_definition.key = fdc$form_variable_text) AND
            (p_form_status^.design_variable_name = form_object_definition.name)) THEN
        fdp$add_object_to_form_image (p_form_status^.p_form_image, ^form_object_definition);
      IFEND;
    IFEND;

    CASE form_object_definition.key OF

    = fdc$form_constant_text_box =
      fragment_object_index :=  0;
      IF form_object_definition.constant_box_height > 1 THEN
        create_fragments (p_form_status, object_index,
              form_object_definition.constant_box_width,
              form_object_definition.constant_box_height,
              fragment_object_index, p_form_object_definition,
              p_form_object_definitions, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      p_form_object_definition^.constant_box_fragment_index := fragment_object_index;

    = fdc$form_variable_text_box =
      fragment_object_index :=  0;
      IF form_object_definition.variable_box_height > 1 THEN
        create_fragments (p_form_status, object_index,
              form_object_definition.variable_box_width,
              form_object_definition.variable_box_height,
              fragment_object_index, p_form_object_definition,
              p_form_object_definitions, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      p_form_object_definition^.variable_box_fragment_index := fragment_object_index;

    ELSE
    CASEND;

    IF NOT p_form_status^.design_form THEN
      RETURN;
    IFEND;

    IF NOT p_form_status^.opened THEN
      RETURN;
    IFEND;

{ Delete any free text under an object, so that the free text will not appear if the
{ object is later deleted.  The free text also needs to be deleted so constant objects
{ are not latter created with the fdp$create_constant_text request.

    delete_free_text_under_object (form_identifier, p_form_object_definition^,
          p_form_definition, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Record changes for next screen update.

    IF (p_form_status^.displayed_on_screen AND p_form_status^.added) THEN
      screen_change.key := fdc$add_object;
      screen_change.object_form_identifier := form_identifier;
      screen_change.object_definition := p_form_object_definition^;
      screen_change.object_index := object_index;
      fdp$record_screen_change (screen_change, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    ELSE

{ Set attributes of object for correct display when the form is on the screen.

      CASE p_form_object_definition^.key OF

      = fdc$form_constant_text_box =
        p_form_status^.p_form_object_statuses^ [object_index].display_attribute_set :=
              p_form_object_definition^.display_attribute;
        fragment_object_index := p_form_object_definition^.constant_box_fragment_index;
        WHILE fragment_object_index <> 0 DO
          p_form_status^.p_form_object_statuses^ [object_index].display_attribute_set :=
                p_form_object_definition^.display_attribute;
          fragment_object_index :=  p_form_object_definitions^
                [fragment_object_index].next_fragment_object_index;
        WHILEND;

      = fdc$form_variable_text_box =
        p_form_status^.p_form_object_statuses^ [object_index].display_attribute_set :=
              p_form_object_definition^.display_attribute;
        fragment_object_index := p_form_object_definition^.variable_box_fragment_index;
        WHILE fragment_object_index <> 0 DO
          p_form_status^.p_form_object_statuses^ [object_index].display_attribute_set :=
                p_form_object_definition^.display_attribute;
          fragment_object_index :=  p_form_object_definitions^
                [fragment_object_index].next_fragment_object_index;
        WHILEND;

      ELSE { Only one object is affect by attribute.
        p_form_status^.p_form_object_statuses^ [object_index].display_attribute_set :=
              p_form_object_definition^.display_attribute;
      CASEND;
    IFEND;

  PROCEND fdp$create_object;

?? TITLE := 'fdp$create_stored_object', EJECT ??
*copyc fdh$create_stored_object

  PROCEDURE [XDCL] fdp$create_stored_object
    (    form_identifier: fdt$form_identifier;
         name: ost$name;
         occurrence: fdt$occurrence;
         text: fdt$text;
         display_attribute_set: fdt$display_attribute_set;
     VAR status: ost$status);

    VAR
      name_exists: boolean,
      name_is_valid: boolean,
      object_index: fdt$object_index,
      object_name_exists: boolean,
      object_occurrence_exists: boolean,
      p_form_definition: ^fdt$form_definition,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_status: ^fdt$form_status,
      p_new_text: ^fdt$text,
      p_stored_text: ^fdt$text,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$create_stored_object;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$create_stored_object;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_change_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    fdp$validate_name (name, p_form_definition^.processor, valid_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_object_name, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF ((occurrence < 1) OR (occurrence > fdc$maximum_occurrence)) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_occurrence, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (occurrence), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    find_object_name (valid_name, occurrence, p_form_object_definitions,
          p_form_definition^.form_object_definitions.active_number, p_form_object_definition, object_index,
          name_exists);
    IF name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$object_occurrence_exists, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (occurrence), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    NEXT p_new_text: [STRLENGTH (text)] IN p_form_status^.p_form_module;
    IF p_new_text = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
      RETURN;
    IFEND;

    fdp$allocate_object (p_form_status, p_form_object_definition, object_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_object_definition^.name := valid_name;
    p_form_object_definition^.occurrence := occurrence;
    p_form_object_definition^.x_position := 1;
    p_form_object_definition^.y_position := 1;
    p_form_object_definition^.key := fdc$form_stored_variable;
    fdp$rel_text (p_new_text, p_form_status^.p_form_module, p_form_object_definition^.stored_variable_text);
    p_new_text^ := text;
    fdp$set_display_attributes (p_form_definition^.display_attribute, display_attribute_set,
          p_form_object_definition^.display_attribute);

  PROCEND fdp$create_stored_object;

?? TITLE := 'fdp$delete_object', EJECT ??
*copyc fdh$delete_object

  PROCEDURE [XDCL] fdp$delete_object
    (    form_identifier: fdt$form_identifier;
         x_position: fdt$x_position;
         y_position: fdt$y_position;
     VAR status: ost$status);

    VAR
      form_object_key: fdt$form_object_key,
      fragment_object_index: fdt$object_index,
      fragment_y_position: fdt$y_position,
      height: fdt$height,
      local_status: ost$status,
      object_exists: boolean,
      object_index: fdt$object_index,
      p_form_definition: ^fdt$form_definition,
      p_form_image: ^fdt$form_image,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_form_status: ^fdt$form_status,
      screen_change: fdt$screen_change;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$delete_object;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$delete_object;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_change_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    find_form_object (p_form_status, x_position, y_position, p_form_object_definitions,
          p_form_definition^.form_object_definitions.active_number, p_form_object_definition, object_index,
          object_exists);
    IF NOT object_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_object_at_position, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (x_position), 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (y_position), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    p_form_image := p_form_status^.p_form_image;
    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    form_object_key := p_form_object_definition^.key;
    screen_change.key := fdc$delete_object;
    screen_change.object_form_identifier := form_identifier;
    CASE form_object_key OF

    = fdc$form_constant_text_box =
      screen_change.object_definition := p_form_object_definition^;
      fragment_object_index := p_form_object_definition^.constant_box_fragment_index;
      IF p_form_image <> NIL THEN
        delete_object_from_form_image (p_form_image, p_form_object_definition);
      IFEND;
      delete_form_object (object_index, p_form_object_definitions);
      IF p_form_status^.design_form THEN
        IF (p_form_status^.displayed_on_screen AND p_form_status^.added) THEN
          screen_change.object_definition := p_form_object_definition^;
          screen_change.object_index := object_index;
          fdp$record_screen_change (screen_change, local_status);
          IF NOT local_status.normal THEN
            status := local_status;
          IFEND;
        ELSE
          p_form_object_statuses^ [object_index].key := fdc$unused_identifier;
        IFEND;
      IFEND;

      WHILE fragment_object_index <> 0 DO
        delete_form_object (fragment_object_index, p_form_object_definitions);
        IF p_form_status^.design_form THEN
          IF (p_form_status^.displayed_on_screen AND p_form_status^.added) THEN
            screen_change.object_definition := p_form_object_definition^;
            screen_change.object_index := fragment_object_index;
            fdp$record_screen_change (screen_change, local_status);
            IF NOT local_status.normal THEN
              status := local_status;
            IFEND;
          ELSE
            p_form_object_statuses^ [fragment_object_index].key := fdc$unused_identifier;
          IFEND;
        IFEND;

        fragment_object_index := p_form_object_definitions^ [fragment_object_index].
              next_fragment_object_index;
      WHILEND;

    = fdc$form_variable_text_box =
      fragment_object_index := p_form_object_definition^.variable_box_fragment_index;
      screen_change.object_definition := p_form_object_definition^;
      IF p_form_image <> NIL THEN
        delete_object_from_form_image (p_form_image, p_form_object_definition);
      IFEND;
      delete_form_object (object_index, p_form_object_definitions);
      IF p_form_status^.design_form THEN
        IF (p_form_status^.displayed_on_screen AND p_form_status^.added) THEN
          screen_change.object_definition := p_form_object_definition^;
          screen_change.object_index := object_index;
          fdp$record_screen_change (screen_change, local_status);
          IF NOT local_status.normal THEN
            status := local_status;
          IFEND;
        ELSE
          p_form_object_statuses^ [object_index].key := fdc$unused_identifier;
        IFEND;
      IFEND;

      WHILE fragment_object_index <> 0 DO
        delete_form_object (fragment_object_index, p_form_object_definitions);
        IF p_form_status^.design_form THEN
          IF (p_form_status^.displayed_on_screen AND p_form_status^.added) THEN
            screen_change.object_definition := p_form_object_definition^;
            screen_change.object_index := fragment_object_index;
            fdp$record_screen_change (screen_change, local_status);
            IF NOT local_status.normal THEN
              status := local_status;
            IFEND;
          ELSE
            p_form_object_statuses^ [fragment_object_index].key := fdc$unused_identifier;
          IFEND;
        IFEND;
        fragment_object_index := p_form_object_definitions^ [fragment_object_index].
              next_fragment_object_index;
      WHILEND;
    ELSE
      IF p_form_image <> NIL THEN
        delete_object_from_form_image (p_form_image, p_form_object_definition);
      IFEND;
      delete_form_object (object_index, p_form_object_definitions);
      IF p_form_status^.design_form THEN
        IF (p_form_status^.displayed_on_screen AND p_form_status^.added) THEN
          screen_change.object_definition := p_form_object_definition^;
          screen_change.object_index := object_index;
          fdp$record_screen_change (screen_change, local_status);
          IF NOT local_status.normal THEN
            status := local_status;
          IFEND;
        ELSE
          p_form_object_statuses^ [object_index].key := fdc$unused_identifier;
        IFEND;
      IFEND;
    CASEND;
  PROCEND fdp$delete_object;

?? TITLE := 'fdp$delete_stored_object', EJECT ??
*copyc fdh$delete_stored_object

  PROCEDURE [XDCL] fdp$delete_stored_object
    (    form_identifier: fdt$form_identifier;
         name: ost$name;
         occurrence: fdt$occurrence;
     VAR status: ost$status);

    VAR
      name_is_valid: boolean,
      object_index: fdt$object_index,
      object_name_exists: boolean,
      object_occurrence_exists: boolean,
      p_form_definition: ^fdt$form_definition,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_status: ^fdt$form_status,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$delete_stored_object;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$delete_stored_object;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_change_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    fdp$validate_name (name, p_form_definition^.processor, valid_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_object_name, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF ((occurrence < 1) OR (occurrence > fdc$maximum_occurrence)) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_occurrence, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (occurrence), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    fdp$find_object_definition (valid_name, occurrence, p_form_status^.p_form_object_definitions,
          p_form_definition^.form_object_definitions.active_number, p_form_object_definition, object_index,
          object_name_exists, object_occurrence_exists);
    IF NOT object_name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_object_name, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF NOT object_occurrence_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_occurrence, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (occurrence), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    delete_form_object (object_index, p_form_status^.p_form_object_definitions);

  PROCEND fdp$delete_stored_object;

?? TITLE := 'fdp$get_form_objects', EJECT ??
*copyc fdh$get_form_objects

  PROCEDURE [XDCL] fdp$get_form_objects
    (    form_identifier: fdt$form_identifier;
     VAR form_objects: fdt$form_objects;
     VAR number_objects: fdt$number_objects;
     VAR status: ost$status);

    VAR
      n: integer,
      object_definition_key: fdt$object_definition_key,
      p_form_definition: ^fdt$form_definition,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_status: ^fdt$form_status,
      total_number_objects: fdt$number_objects;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_form_objects;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_form_objects;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    number_objects := 0;
    total_number_objects := UPPERBOUND (form_objects);
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    p_form_definition := p_form_status^.p_form_definition;

  /get_objects/
    FOR n := 1 TO p_form_definition^.form_object_definitions.active_number DO
      p_form_object_definition := ^p_form_object_definitions^ [n];
      CASE p_form_object_definition^.key OF

      = fdc$form_box =
        object_definition_key := fdc$box;

      = fdc$form_line =
        object_definition_key := fdc$line;

      = fdc$form_constant_text_box =
        object_definition_key := fdc$constant_text_box;

      = fdc$form_constant_text =
        object_definition_key := fdc$constant_text;

      = fdc$form_table =
        object_definition_key := fdc$table;

      = fdc$form_variable_text =
        object_definition_key := fdc$variable_text;

      = fdc$form_variable_text_box =
        object_definition_key := fdc$variable_text_box;

      ELSE { This is an object that the user did not create. }
        CYCLE /get_objects/;
      CASEND;

      IF number_objects > total_number_objects THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$too_many_form_objects,
              p_form_definition^.form_name, status);
        RETURN;
      IFEND;

      number_objects := number_objects + 1;
      form_objects [number_objects].x_position := p_form_object_definition^.x_position;
      form_objects [number_objects].y_position := p_form_object_definition^.y_position;
      form_objects [number_objects].name := p_form_object_definition^.name;
      form_objects [number_objects].occurrence := p_form_object_definition^.occurrence;
      form_objects [number_objects].object := object_definition_key;
    FOREND /get_objects/;
  PROCEND fdp$get_form_objects;

?? TITLE := 'fdp$get_object_attributes', EJECT ??
*copyc fdh$get_object_attributes

  PROCEDURE [XDCL] fdp$get_object_attributes
    (    form_identifier: fdt$form_identifier;
         x_position: fdt$x_position;
         y_position: fdt$y_position;
     VAR get_object_attributes: fdt$get_object_attributes;
     VAR status: ost$status);

    VAR
      n: fdt$object_attribute_index,
      form_object_key: fdt$form_object_key,
      object_exists: boolean,
      object_index: fdt$object_index,
      p_form_definition: ^fdt$form_definition,
      p_form_module: ^fdt$form_module,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_status: ^fdt$form_status,
      p_text: ^fdt$text,
      text_length: fdt$text_length;


?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_object_attributes;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_object_attributes;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);

    FOR n := LOWERBOUND (get_object_attributes) TO UPPERBOUND (get_object_attributes) DO
      get_object_attributes [n].get_value_status := fdc$unprocessed_get_value;
    FOREND;

    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    find_form_object (p_form_status, x_position, y_position, p_form_object_definitions,
          p_form_definition^.form_object_definitions.active_number, p_form_object_definition, object_index,
          object_exists);
    IF NOT object_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_object_at_position, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (x_position), 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (y_position), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    form_object_key := p_form_object_definition^.key;
    CASE form_object_key OF

    = fdc$form_text_box_fragment =

{ Use parent object for object consisting of a number of object fragments.
{ The first line of a text box is the parent.

      p_form_object_definition := ^p_form_object_definitions^
            [p_form_object_definition^.parent_text_box_object_index];
      form_object_key := p_form_object_definition^.key;
    ELSE { Ignore other objects.
    CASEND;

    p_form_module := p_form_status^.p_form_module;

  /return_object_attributes/
    FOR n := LOWERBOUND (get_object_attributes) TO UPPERBOUND (get_object_attributes) DO

      CASE get_object_attributes [n].key OF

      = fdc$get_object_definition =
        get_object_attributes [n].get_value_status := fdc$user_defined_value;
        CASE form_object_key OF

        = fdc$form_box =
          get_object_attributes [n].get_object_definition.key := fdc$box;
          get_object_attributes [n].get_object_definition.box_width := p_form_object_definition^.box_width;
          get_object_attributes [n].get_object_definition.box_height := p_form_object_definition^.box_height;

        = fdc$form_constant_text =
          get_object_attributes [n].get_object_definition.key := fdc$constant_text;
          get_object_attributes [n].get_object_definition.constant_text_width :=
                p_form_object_definition^.constant_text_width;
          p_text := fdp$ptr_text (p_form_object_definition^.constant_text, p_form_module);
          IF p_text <> NIL THEN
            get_object_attributes [n].get_object_definition.constant_text_length := STRLENGTH (p_text^);
          ELSE
            get_object_attributes [n].get_object_definition.constant_text_length := 0;
          IFEND;

        = fdc$form_constant_text_box =
          get_object_attributes [n].get_object_definition.key := fdc$constant_text_box;
          get_object_attributes [n].get_object_definition.constant_box_width :=
                p_form_object_definition^.constant_box_width;
          get_object_attributes [n].get_object_definition.constant_box_height :=
                p_form_object_definition^.constant_box_height;
          get_object_attributes [n].get_object_definition.constant_box_processing :=
                p_form_object_definition^.constant_box_processing;
          p_text := fdp$ptr_text (p_form_object_definition^.constant_box_text, p_form_module);
          IF p_text <> NIL THEN
            get_object_attributes [n].get_object_definition.constant_box_text_length := STRLENGTH (p_text^);
          ELSE
            get_object_attributes [n].get_object_definition.constant_box_text_length := 0;
          IFEND;

        = fdc$form_line =
          get_object_attributes [n].get_object_definition.x_increment :=
                p_form_object_definition^.x_increment;
          get_object_attributes [n].get_object_definition.y_increment :=
                p_form_object_definition^.y_increment;
          get_object_attributes [n].get_object_definition.key := fdc$line;

        = fdc$form_table =
          get_object_attributes [n].get_object_definition.key := fdc$table;
          get_object_attributes [n].get_object_definition.table_width :=
                p_form_object_definition^.table_width;
          get_object_attributes [n].get_object_definition.table_height :=
                p_form_object_definition^.table_height;

        = fdc$form_variable_text =
          get_object_attributes [n].get_object_definition.key := fdc$variable_text;
          get_object_attributes [n].get_object_definition.variable_text_width :=
                p_form_object_definition^.text_variable_width;
          p_text := fdp$ptr_text (p_form_object_definition^.text_variable_text, p_form_module);
          IF p_text <> NIL THEN
            get_object_attributes [n].get_object_definition.variable_text_length := STRLENGTH (p_text^);
          ELSE
            get_object_attributes [n].get_object_definition.variable_text_length := 0;
          IFEND;

        = fdc$form_variable_text_box =
          get_object_attributes [n].get_object_definition.key := fdc$variable_text_box;
          get_object_attributes [n].get_object_definition.variable_box_width :=
                p_form_object_definition^.variable_box_width;
          get_object_attributes [n].get_object_definition.variable_box_height :=
                p_form_object_definition^.variable_box_height;
          get_object_attributes [n].get_object_definition.variable_box_processing :=
                p_form_object_definition^.variable_box_processing;
          p_text := fdp$ptr_text (p_form_object_definition^.variable_box_text, p_form_module);
          IF p_text <> NIL THEN
            get_object_attributes [n].get_object_definition.variable_box_text_length := STRLENGTH (p_text^);
          ELSE
            get_object_attributes [n].get_object_definition.variable_box_text_length := 0;
          IFEND;

        ELSE

{ Invalid form object case.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, '', status);
          RETURN;
        CASEND;

      = fdc$get_object_display =
        get_object_attributes [n].display_attribute := p_form_object_definition^.display_attribute;
        IF p_form_object_definition^.display_attribute = p_form_definition^.display_attribute THEN
          get_object_attributes [n].get_value_status := fdc$system_computed_value;
        ELSE
          get_object_attributes [n].get_value_status := fdc$user_defined_value;
        IFEND;

      = fdc$get_object_name =
        IF p_form_object_definition^.name <> osc$null_name THEN
          get_object_attributes [n].object_name := p_form_object_definition^.name;
          get_object_attributes [n].occurrence := p_form_object_definition^.occurrence;
          get_object_attributes [n].get_value_status := fdc$user_defined_value;
        ELSE
          get_object_attributes [n].get_value_status := fdc$undefined_value;
        IFEND;

      = fdc$get_object_text =
        IF get_object_attributes [n].p_text = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_address,
                p_form_definition^.form_name, status);
          RETURN;
        IFEND;

        CASE form_object_key OF

        = fdc$form_box, fdc$form_line =
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_text_at_position, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (x_position),
                10, FALSE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (y_position),
                10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;

        = fdc$form_constant_text =
          p_text := fdp$ptr_text (p_form_object_definition^.constant_text, p_form_status^.p_form_module);
          IF STRLENGTH (get_object_attributes [n].p_text^) >= STRLENGTH (p_text^) THEN
            get_object_attributes [n].p_text^ := p_text^;
          ELSE
            osp$set_status_abnormal (fdc$format_display_identifier, fde$string_too_small, '', status);
            RETURN;
          IFEND;

        = fdc$form_constant_text_box =
          p_text := fdp$ptr_text (p_form_object_definition^.constant_box_text, p_form_status^.p_form_module);
          IF STRLENGTH (get_object_attributes [n].p_text^) >= STRLENGTH (p_text^) THEN
            get_object_attributes [n].p_text^ := p_text^;
          ELSE
            osp$set_status_abnormal (fdc$format_display_identifier, fde$string_too_small, '', status);
            RETURN;
          IFEND;

        = fdc$form_variable_text =
          p_text := fdp$ptr_text (p_form_object_definition^.text_variable_text, p_form_status^.p_form_module);
          IF STRLENGTH (get_object_attributes [n].p_text^) >= STRLENGTH (p_text^) THEN
            get_object_attributes [n].p_text^ := p_text^;
          ELSE
            osp$set_status_abnormal (fdc$format_display_identifier, fde$string_too_small, '', status);
            RETURN;
          IFEND;

        = fdc$form_variable_text_box =
          p_text := fdp$ptr_text (p_form_object_definition^.variable_box_text, p_form_status^.p_form_module);
          IF STRLENGTH (get_object_attributes [n].p_text^) >= STRLENGTH (p_text^) THEN
            get_object_attributes [n].p_text^ := p_text^;
          ELSE
            osp$set_status_abnormal (fdc$format_display_identifier, fde$string_too_small, '', status);
            RETURN;
          IFEND;

        ELSE

{ The object key is invalid.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, '', status);
          RETURN;
        CASEND;
        get_object_attributes [n].get_value_status := fdc$user_defined_value;

        = fdc$get_object_text_length =
        CASE form_object_key OF

        = fdc$form_constant_text =
          p_text := fdp$ptr_text (p_form_object_definition^.constant_text, p_form_status^.p_form_module);

        = fdc$form_constant_text_box =
          p_text := fdp$ptr_text (p_form_object_definition^.constant_box_text, p_form_status^.p_form_module);


        = fdc$form_variable_text =
          p_text := fdp$ptr_text (p_form_object_definition^.text_variable_text, p_form_status^.p_form_module);


        = fdc$form_variable_text_box =
          p_text := fdp$ptr_text (p_form_object_definition^.variable_box_text, p_form_status^.p_form_module);

        ELSE

{ The object has no text.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_text_at_position, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (x_position),
                10, FALSE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (y_position),
                10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;
        CASEND;

{ The object may have text.

          IF p_text <> NIL THEN
            get_object_attributes [n].text_length := STRLENGTH (p_text^);
          ELSE
            get_object_attributes [n].text_length := 0;
          IFEND;
          get_object_attributes [n].get_value_status := fdc$user_defined_value;

      = fdc$get_unused_object_entry =
        get_object_attributes [n].get_value_status := fdc$undefined_value;

      ELSE

{ Invalid object attribute.

        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_object_attribute,
              p_form_definition^.form_name, status);
        RETURN;

      CASEND;
    FOREND /return_object_attributes/;
  PROCEND fdp$get_object_attributes;

?? TITLE := 'fdp$get_stored_object', EJECT ??
*copyc fdh$get_stored_object

  PROCEDURE [XDCL] fdp$get_stored_object
    (    form_identifier: fdt$form_identifier;
         name: ost$name;
         occurrence: fdt$occurrence;
     VAR text: fdt$text;
     VAR text_length: fdt$text_length;
     VAR display_attribute_set: fdt$display_attribute_set;
     VAR status: ost$status);

    VAR
      name_is_valid: boolean,
      object_index: fdt$object_index,
      object_name_exists: boolean,
      object_occurrence_exists: boolean,
      p_form_definition: ^fdt$form_definition,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_status: ^fdt$form_status,
      p_stored_text: ^fdt$text,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_stored_object;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_stored_object;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    fdp$validate_name (name, p_form_definition^.processor, valid_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_object_name, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF ((occurrence < 1) OR (occurrence > fdc$maximum_occurrence)) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_occurrence, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (occurrence), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    fdp$find_object_definition (valid_name, occurrence, p_form_status^.
          p_form_object_definitions, p_form_definition^.form_object_definitions.active_number,
          p_form_object_definition, object_index, object_name_exists, object_occurrence_exists);
    IF NOT object_name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_object_name, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF NOT object_occurrence_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_occurrence, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (occurrence), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

{ Return text and display attributes to caller.

    p_stored_text := fdp$ptr_text (p_form_object_definition^.stored_variable_text,
          p_form_status^.p_form_module);
    text_length := STRLENGTH (p_stored_text^);
    text := p_stored_text^;
    display_attribute_set := p_form_object_definition^.display_attribute;
  PROCEND fdp$get_stored_object;

?? TITLE := 'fdp$set_display_attributes', EJECT ??
*copyc fdh$set_display_attributes

  PROCEDURE [XDCL] fdp$set_display_attributes
    (    form_display_attributes: fdt$display_attribute_set;
         object_display_attributes: fdt$display_attribute_set;
     VAR display_attribute_set: fdt$display_attribute_set);

    display_attribute_set := object_display_attributes;

{ If user did not specify a background color, use background color of form.

    IF ((object_display_attributes * fdv$background_colors) = $fdt$display_attribute_set []) THEN
      IF ((form_display_attributes * fdv$background_colors) <> $fdt$display_attribute_set []) THEN
        display_attribute_set := display_attribute_set + (form_display_attributes * fdv$background_colors);
      IFEND;
    IFEND;

{ If user did not specify a foreground color, use foreground color of form.

    IF ((object_display_attributes * fdv$foreground_colors) = $fdt$display_attribute_set []) THEN
      IF ((form_display_attributes * fdv$foreground_colors) <> $fdt$display_attribute_set []) THEN
        display_attribute_set := display_attribute_set + (form_display_attributes * fdv$foreground_colors);
      IFEND;
    IFEND;

{ If user did not specify display direction, use direction of form.

    IF ((object_display_attributes * fdv$object_display_directions) = $fdt$display_attribute_set []) THEN
      IF ((form_display_attributes * fdv$object_display_directions) <> $fdt$display_attribute_set []) THEN
        display_attribute_set := display_attribute_set + (form_display_attributes *
              fdv$object_display_directions);
      IFEND;
    IFEND;

  PROCEND fdp$set_display_attributes;

?? TITLE := 'change_object', EJECT ??

  PROCEDURE change_object
    (    p_form_status: ^fdt$form_status;
         p_form_definition: ^fdt$form_definition;
         p_form_object_definition: ^fdt$form_object_definition;
     VAR object_attributes: fdt$object_attributes;
     VAR status: ost$status);

    VAR
      n: fdt$object_attribute_index,
      name_is_valid: boolean,
      name_exists: boolean,
      new_array: boolean,
      object_index: fdt$object_index,
      p_duplicate_object_definition: ^fdt$form_object_definition,
      p_form_module: ^fdt$form_module,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_new_text: ^fdt$text,
      p_text: ^fdt$text,
      text_length: fdt$text_length,
      valid_name: ost$name,
      x_position: fdt$x_position,
      y_position: fdt$y_position;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT change_object;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT change_object;
        IFEND;

      = pmc$block_exit_processing =
        handler_status.normal := TRUE;
        RETURN;
      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    p_form_module := p_form_status^.p_form_module;
    x_position := p_form_object_definition^.x_position;
    y_position := p_form_object_definition^.y_position;

  /change_object_attributes/
    FOR n := LOWERBOUND (object_attributes) TO UPPERBOUND (object_attributes) DO
      CASE object_attributes [n].key OF

      = fdc$object_display =
        fdp$set_display_attributes (p_form_definition^.display_attribute,
              object_attributes [n].display_attribute, p_form_object_definition^.display_attribute);
        CASE p_form_object_definition^.key OF

        = fdc$form_variable_text_box, fdc$form_variable_text =

{ Do nothing.

        ELSE

{ Always protect constant text, lines and boxes.

          p_form_object_definition^.display_attribute := p_form_object_definition^.display_attribute +
                $fdt$display_attribute_set [fdc$protect];
        CASEND;

        object_attributes [n].put_value_status := fdc$put_value_accepted;

      = fdc$object_height =
        IF ((object_attributes [n].height < 1) OR (object_attributes [n].height > fdc$maximum_y_position))
              THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_height, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (object_attributes [n].height),
                10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;
        IFEND;

        CASE p_form_object_definition^.key OF

        = fdc$form_box =
          p_form_object_definition^.box_height := object_attributes [n].height;
          object_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$form_constant_text_box =
          p_form_object_definition^.constant_box_height := object_attributes [n].height;
          object_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$form_table =
          p_form_object_definition^.table_height := object_attributes [n].height;
          object_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$form_variable_text_box =
          check_object_size (p_form_status, p_form_object_definition^.name,
                object_attributes [n].height * p_form_object_definition^.variable_box_width,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          p_form_object_definition^.variable_box_height := object_attributes [n].height;
          object_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$form_constant_text, fdc$form_variable_text =
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_object_change, '', status);
          RETURN;

        ELSE

{ Invalid object definition key.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_object_key,
                p_form_definition^.form_name, status);
          RETURN;
        CASEND;

      = fdc$object_width =
        IF ((object_attributes [n].width < 1) OR (object_attributes [n].width > fdc$maximum_x_position)) THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_width, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (object_attributes [n].width),
                10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;
        IFEND;

        CASE p_form_object_definition^.key OF

        = fdc$form_box =
          p_form_object_definition^.box_width := object_attributes [n].width;
          object_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$form_constant_text =
          p_form_object_definition^.constant_text_width := object_attributes [n].width;
          object_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$form_constant_text_box =
          p_form_object_definition^.constant_box_width := object_attributes [n].width;
          object_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$form_table =
          p_form_object_definition^.table_width := object_attributes [n].width;
          object_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$form_variable_text =
          check_object_size (p_form_status, p_form_object_definition^.name,
                object_attributes [n].width, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          p_form_object_definition^.text_variable_width := object_attributes [n].width;
          object_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$form_variable_text_box =
          check_object_size (p_form_status, p_form_object_definition^.name,
                object_attributes [n].width * p_form_object_definition^.variable_box_height,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          p_form_object_definition^.variable_box_width := object_attributes [n].width;
          object_attributes [n].put_value_status := fdc$put_value_accepted;

        ELSE

{ Invalid object definition key.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
                p_form_definition^.form_name, status);
          RETURN;
        CASEND;

      = fdc$object_line_x_increment =
        IF ((object_attributes [n].x_increment < 0) OR (object_attributes [n].x_increment >
              fdc$maximum_x_position)) THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_x_increment, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                $INTEGER (object_attributes [n].x_increment), 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;
        IFEND;

        IF p_form_object_definition^.key = fdc$form_line THEN
          p_form_object_definition^.x_increment := object_attributes [n].x_increment;
          object_attributes [n].put_value_status := fdc$put_value_accepted;

        ELSE

{ The object is not a line whose x increment can be changed.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_object_change,
                p_form_definition^.form_name, status);
          RETURN;
        IFEND;

      = fdc$object_line_y_increment =
        IF ((object_attributes [n].y_increment < 0) OR (object_attributes [n].y_increment >
              fdc$maximum_y_position)) THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_y_increment, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                $INTEGER (object_attributes [n].y_increment), 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;
        IFEND;

        IF p_form_object_definition^.key = fdc$form_line THEN
          p_form_object_definition^.y_increment := object_attributes [n].y_increment;
          object_attributes [n].put_value_status := fdc$put_value_accepted;

        ELSE

{ The object is not a line whose y increment can be changed.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_object_change,
                p_form_definition^.form_name, status);
          RETURN;
        IFEND;

      = fdc$object_name =
        IF object_attributes [n].object_name = osc$null_name THEN
          p_form_object_definition^.name := osc$null_name;
          p_form_object_definition^.occurrence := 1;
          object_attributes [n].put_value_status := fdc$put_value_accepted;
          CYCLE /change_object_attributes/;
        IFEND;

        fdp$validate_name (object_attributes [n].object_name, p_form_definition^.processor, valid_name,
              name_is_valid);
        IF NOT name_is_valid THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_object_name,
                object_attributes [n].object_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;
        IFEND;

        IF ((object_attributes [n].occurrence < 1) OR (object_attributes [n].occurrence >
              fdc$maximum_occurrence)) THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_occurrence, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                $INTEGER (object_attributes [n].occurrence), 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, object_attributes [n].object_name,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;
        IFEND;

        find_object_name (valid_name, object_attributes [n].occurrence,
              p_form_status^.p_form_object_definitions, p_form_definition^.form_object_definitions.
              active_number, p_duplicate_object_definition, object_index, name_exists);
        IF name_exists THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$object_occurrence_exists, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                $INTEGER (object_attributes [n].occurrence), 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, object_attributes [n].object_name,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;
        IFEND;

        p_form_object_definition^.name := valid_name;
        p_form_object_definition^.occurrence := object_attributes [n].occurrence;
        object_attributes [n].put_value_status := fdc$put_value_accepted;

      = fdc$object_position =
        IF object_attributes [n].x_position > fdc$maximum_x_position THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_x_position, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                $INTEGER (object_attributes [n].x_position), 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;
        IFEND;

        IF object_attributes [n].y_position > fdc$maximum_y_position THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_y_position, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                $INTEGER (object_attributes [n].y_position), 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;
        IFEND;

        p_form_object_definition^.x_position := object_attributes [n].x_position;
        p_form_object_definition^.y_position := object_attributes [n].y_position;
        object_attributes [n].put_value_status := fdc$put_value_accepted;

      = fdc$object_text =
        IF object_attributes [n].p_text = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_text_for_object,
                p_form_definition^.form_name, status);
          RETURN;
        IFEND;

        p_text := object_attributes [n].p_text;
        text_length := STRLENGTH (p_text^);
        NEXT p_new_text: [text_length] IN p_form_status^.p_form_module;
        IF p_new_text = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
          RETURN;
        IFEND;

        p_new_text^ := p_text^;
        CASE p_form_object_definition^.key OF

        = fdc$form_constant_text =
          fdp$rel_text (p_new_text, p_form_module, p_form_object_definition^.constant_text);

        = fdc$form_constant_text_box =
          fdp$rel_text (p_new_text, p_form_module, p_form_object_definition^.constant_box_text);

        = fdc$form_variable_text =
          fdp$rel_text (p_new_text, p_form_module, p_form_object_definition^.text_variable_text);

        = fdc$form_variable_text_box =
          fdp$rel_text (p_new_text, p_form_module, p_form_object_definition^.variable_box_text);

        = fdc$form_box, fdc$form_line =

{ The object cannot have text changed with this request.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_object_change,
                p_form_definition^.form_name, status);
          RETURN;

        ELSE
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, '', status);
          RETURN;
        CASEND;
        object_attributes [n].put_value_status := fdc$put_value_accepted;

      = fdc$object_text_processing =
        CASE object_attributes [n].text_box_processing OF

        = fdc$wrap_characters, fdc$wrap_words =

        ELSE
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_text_processing,
                p_form_definition^.form_name, status);
          RETURN;
        CASEND;

        CASE p_form_object_definition^.key OF

        = fdc$form_constant_text_box =
          p_form_object_definition^.constant_box_processing := object_attributes [n].text_box_processing;

        = fdc$form_variable_text_box =
          p_form_object_definition^.variable_box_processing := object_attributes [n].text_box_processing;

        = fdc$form_variable_text, fdc$form_constant_text, fdc$form_box, fdc$form_line =
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_object_change, '', status);
          RETURN;

        ELSE

{ Invalid object definition key.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
                p_form_definition^.form_name, status);
          RETURN;
        CASEND;
        object_attributes [n].put_value_status := fdc$put_value_accepted;

      = fdc$unused_object_entry =
        object_attributes [n].put_value_status := fdc$put_value_accepted;

{ Do nothing.

      ELSE

{ Invalid object attribute.

        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_object_attribute,
              p_form_definition^.form_name, status);
        RETURN;

      CASEND;
    FOREND /change_object_attributes/;

  PROCEND change_object;

?? TITLE := 'check_object_size', EJECT ??

  PROCEDURE check_object_size
    (    p_form_status: ^fdt$form_status;
         object_name: ost$name;
         screen_variable_length: fdt$screen_variable_length;
     VAR status: ost$status);

    VAR
      name_exists: boolean,
      p_added_variable_definition: ^fdt$added_variable_definition,
      p_form_variable_definition: ^fdt$form_variable_definition,
      variable_index: fdt$variable_index;

    status.normal := TRUE;
    fdp$find_variable_definition (object_name,  p_form_status^.
          p_form_variable_definitions,  p_form_status^.p_form_definition^.
          form_variable_definitions.active_number,
          p_form_variable_definition, variable_index, name_exists);
    IF NOT name_exists THEN
      RETURN;
    IFEND;

    IF p_form_variable_definition^.program_data_type <> fdc$program_cobol_type THEN
      RETURN;
    IFEND;

    fdp$locate_added_variable_facts (p_form_status^.p_form_module,
          p_form_variable_definition, p_added_variable_definition);

    IF NOT p_added_variable_definition^.form_cobol_display_clause.defined THEN
      RETURN;
    IFEND;

    IF p_added_variable_definition^.display_cobol_description.size >
          screen_variable_length THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$object_size_coboL_mismatch, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            $INTEGER (p_added_variable_definition^.display_cobol_description.size), 10, FALSE,  status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            $INTEGER (screen_variable_length), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, object_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
           p_form_status^.p_form_definition^.form_name, status);
     IFEND;

    PROCEND check_object_size;

?? TITLE := 'create_fragments', EJECT ??

    PROCEDURE create_fragments
      (    p_form_status: ^fdt$form_status;
           object_index: fdt$object_index;
           width: fdt$width;
           height: fdt$height;
       VAR fragment_object_index: fdt$object_index;
       VAR p_form_object_definition: ^fdt$form_object_definition;
       VAR p_form_object_definitions: ^array [1 .. *] of fdt$form_object_definition;
       VAR status: ost$status);

      VAR
        fragment_index: fdt$object_index,
        p_fragment_object_definition: ^fdt$form_object_definition,
        p_fragment_object_indexes: ^array [1 .. * ] of fdt$object_index,
        p_last_object_definition: ^fdt$form_object_definition;

      PUSH p_fragment_object_indexes: [1 .. height];
      FOR fragment_index := 1 TO height - 1 DO
        fdp$allocate_object (p_form_status, p_fragment_object_definition, fragment_object_index, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        p_fragment_object_indexes^ [fragment_index] := fragment_object_index;
      FOREND;

      p_form_object_definitions := p_form_status^.p_form_object_definitions;
      p_form_object_definition  :=  ^p_form_object_definitions^ [object_index];

      FOR fragment_index := 1 TO height - 1 DO
        p_fragment_object_definition := ^p_form_object_definitions^
              [p_fragment_object_indexes^ [fragment_index]];
        p_fragment_object_definition^.key := fdc$form_text_box_fragment;
        p_fragment_object_definition^.x_position :=
              p_form_object_definition^.x_position;
        p_fragment_object_definition^.y_position :=
              p_form_object_definition^.y_position + fragment_index;
        p_fragment_object_definition^.name := p_form_object_definition^.name;
        p_fragment_object_definition^.occurrence := p_form_object_definition^.occurrence;
        p_fragment_object_definition^.display_attribute := p_form_object_definition^.display_attribute;
        p_fragment_object_definition^.fragment_width := width;
        p_fragment_object_definition^.parent_text_box_object_index := object_index;
        IF fragment_index > 1 THEN
          p_last_object_definition^.next_fragment_object_index := p_fragment_object_indexes^ [fragment_index];
        IFEND;
        p_last_object_definition := p_fragment_object_definition;
      FOREND;

      p_fragment_object_definition^.next_fragment_object_index := 0;
      fragment_object_index := p_fragment_object_indexes^ [1];
    PROCEND create_fragments;


?? TITLE := 'delete_form_object', EJECT ??

  PROCEDURE [INLINE] delete_form_object
    (    object_index: fdt$object_index;
         p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition);

    p_form_object_definitions^ [object_index].key := fdc$form_unused_object;
  PROCEND delete_form_object;

?? TITLE := 'delete_free_text_under_object', EJECT ??

  PROCEDURE delete_free_text_under_object
    (    form_identifier: fdt$form_identifier;
         form_object_definition: fdt$form_object_definition;
         p_form_definition: ^fdt$form_definition;
         p_form_status: ^fdt$form_status;
     VAR status: ost$status);

    VAR
      high_x_position: fdt$x_position,
      high_y_position: fdt$y_position,
      occurrence: fdt$occurrence,
      p_text: ^fdt$text,
      variable_name: ost$name,
      variable_status: fdt$variable_status;

{ Set characters under object to spaces, so that objects created
{ later can be placed here.

    PUSH p_text: [p_form_definition^.form_area.width];
    variable_name := p_form_status^.design_variable_name;
    CASE form_object_definition.key OF

    = fdc$form_box =

{ Delete free text under top line of box.

      fdp$get_string_variable (form_identifier, variable_name, form_object_definition.y_position, p_text^,
            variable_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      p_text^ (form_object_definition.x_position, form_object_definition.box_width) := ' ';
      fdp$replace_string_variable (form_identifier, variable_name, form_object_definition.y_position, p_text^,
            variable_status, status);

{ Delete free text under vertical lines of box.

      high_y_position := form_object_definition.y_position + form_object_definition.box_height - 1;
      high_x_position := form_object_definition.x_position + form_object_definition.box_width - 1;
      FOR occurrence := form_object_definition.y_position + 1 TO (high_y_position - 1) DO
        fdp$get_string_variable (form_identifier, variable_name, occurrence, p_text^, variable_status,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        p_text^ (form_object_definition.x_position, 1) := ' ';
        p_text^ (high_x_position, 1) := ' ';
        fdp$replace_string_variable (form_identifier, variable_name, occurrence, p_text^, variable_status,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

{ Delete free text under bottom line of box.

      fdp$get_string_variable (form_identifier, variable_name, high_y_position, p_text^, variable_status,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      p_text^ (form_object_definition.x_position, form_object_definition.box_width) := ' ';
      fdp$replace_string_variable (form_identifier, variable_name, high_y_position, p_text^, variable_status,
            status);

    = fdc$form_constant_text =
      fdp$get_string_variable (form_identifier, variable_name, form_object_definition.y_position, p_text^,
            variable_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      p_text^ (form_object_definition.x_position, form_object_definition.constant_text_width) := ' ';
      fdp$replace_string_variable (form_identifier, variable_name, form_object_definition.y_position, p_text^,
            variable_status, status);

    = fdc$form_constant_text_box =
      FOR occurrence := form_object_definition.y_position TO
            (form_object_definition.y_position + form_object_definition.constant_box_height - 1) DO
        fdp$get_string_variable (form_identifier, variable_name, occurrence, p_text^, variable_status,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        p_text^ (form_object_definition.x_position, form_object_definition.constant_box_width) := ' ';
        fdp$replace_string_variable (form_identifier, variable_name, occurrence, p_text^, variable_status,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

    = fdc$form_line =
      IF (form_object_definition.y_increment = 0) THEN

{ Delete free text for horizontal line.

        fdp$get_string_variable (form_identifier, variable_name, form_object_definition.y_position, p_text^,
              variable_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        p_text^ (form_object_definition.x_position, form_object_definition.x_increment + 1) := ' ';
        fdp$replace_string_variable (form_identifier, variable_name, form_object_definition.y_position,
              p_text^, variable_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSE

{ Delete free text for vertical line.

        high_y_position := form_object_definition.y_position + form_object_definition.y_increment;
        FOR occurrence := form_object_definition.y_position TO (high_y_position) DO
          fdp$get_string_variable (form_identifier, variable_name, occurrence, p_text^, variable_status,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          p_text^ (form_object_definition.x_position, 1) := ' ';
          fdp$replace_string_variable (form_identifier, variable_name, occurrence, p_text^, variable_status,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
      IFEND;

    ELSE { Ignore other objects. }
    CASEND;
  PROCEND delete_free_text_under_object;

?? TITLE := 'delete_object_from_form_image', EJECT ??

  PROCEDURE delete_object_from_form_image
    (    p_form_image: ^fdt$form_image;
         p_form_object_definition: ^fdt$form_object_definition);

    VAR
      current_x_position: fdt$x_position,
      current_y_position: fdt$y_position,
      end_object_x_position: fdt$x_position,
      end_object_y_position: fdt$y_position,
      x_position: fdt$x_position,
      y_position: fdt$y_position;

    x_position := p_form_object_definition^.x_position;
    y_position := p_form_object_definition^.y_position;

{ Set character image of form to spaces for area occupied by deleted object.

    CASE p_form_object_definition^.key OF

    = fdc$form_box =
      end_object_x_position := x_position + p_form_object_definition^.box_width - 1;
      end_object_y_position := y_position + p_form_object_definition^.box_height - 1;

{ Delete top line of box.

      p_form_image^ [y_position] (x_position, p_form_object_definition^.box_width) := ' ';

{ Delete bottom line of box.

      p_form_image^ [end_object_y_position] (x_position, p_form_object_definition^.box_width) := ' ';

{ Delete left vertical line of box.

      FOR current_y_position := y_position + 1 TO end_object_y_position - 1 DO
        p_form_image^ [current_y_position] (x_position, 1) := ' ';
      FOREND;

{ Delete left right vertical line of box.

      FOR current_y_position := y_position + 1 TO end_object_y_position - 1 DO
        p_form_image^ [current_y_position] (end_object_x_position, 1) := ' ';
      FOREND;

    = fdc$form_line =
      IF (p_form_object_definition^.y_increment = 0) THEN

{ Delete horizontal line.

        p_form_image^ [y_position] (x_position, p_form_object_definition^.x_increment + 1) := ' ';

      ELSE

{ Delete vertical line.

        FOR current_y_position := y_position TO y_position + p_form_object_definition^.y_increment DO
          p_form_image^ [current_y_position] (x_position, 1) := ' ';
        FOREND;
      IFEND;

    = fdc$form_variable_text =
      p_form_image^ [y_position] (x_position, p_form_object_definition^.text_variable_width) := ' ';

    = fdc$form_variable_text_box =
      FOR current_y_position := y_position TO y_position + p_form_object_definition^.variable_box_height -
            1 DO
        p_form_image^ [current_y_position] (x_position, p_form_object_definition^.variable_box_width) := ' ';
      FOREND;

    = fdc$form_constant_text =
      p_form_image^ [y_position] (x_position, p_form_object_definition^.constant_text_width) := ' ';

    = fdc$form_constant_text_box =
      FOR current_y_position := y_position TO y_position + p_form_object_definition^.constant_box_height -
            1 DO
        p_form_image^ [current_y_position] (x_position, p_form_object_definition^.constant_box_width) := ' ';
      FOREND;

    ELSE { Ignore other objects. }
    CASEND;

  PROCEND delete_object_from_form_image;

?? TITLE := 'find_form_object', EJECT ??

  PROCEDURE [INLINE] find_form_object
    (    p_form_status: ^fdt$form_status;
         x_position: fdt$x_position;
         y_position: fdt$y_position;
         p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition;
         number_objects: fdt$number_objects;
     VAR p_form_object_definition: ^fdt$form_object_definition;
     VAR object_index: fdt$object_index;
     VAR object_exists: boolean);

    VAR
      design_form: boolean;

    design_form := p_form_status^.design_form;
    object_exists := FALSE;

  /find_object/
    FOR object_index := 1 TO number_objects DO
      p_form_object_definition := ^p_form_object_definitions^ [object_index];
      IF ((p_form_object_definition^.key = fdc$form_unused_object) OR
           (p_form_object_definition^.key = fdc$form_stored_variable)) THEN
        CYCLE /find_object/;
      IFEND;

      IF ((x_position = p_form_object_definition^.x_position) AND
            (p_form_object_definition^.y_position = y_position)) THEN
        IF NOT design_form THEN
          object_exists := TRUE;
          EXIT /find_object/;
        ELSE

{ The variable that holds free text on the design form should not be considered as an object.

          IF p_form_object_definition^.name <> p_form_status^.design_variable_name THEN
            object_exists := TRUE;
            EXIT /find_object/;
          IFEND;
        IFEND;
      IFEND;
    FOREND /find_object/;
  PROCEND find_form_object;

?? TITLE := 'find_object_name', EJECT ??

  PROCEDURE [INLINE] find_object_name
    (    object_name: ost$name;
         object_occurrence: fdt$occurrence;
         p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition;
         number_objects: fdt$number_objects;
     VAR p_form_object_definition: ^fdt$form_object_definition;
     VAR object_index: fdt$object_index;
     VAR object_exists: boolean);

    object_exists := FALSE;

  /find_object/
    FOR object_index := 1 TO number_objects DO
      p_form_object_definition := ^p_form_object_definitions^ [object_index];
      IF p_form_object_definition^.key <> fdc$form_unused_object THEN
        IF object_name = p_form_object_definition^.name THEN
          IF object_occurrence = p_form_object_definition^.occurrence THEN
            object_exists := TRUE;
            EXIT /find_object/;
          IFEND;
        IFEND;
      IFEND;
    FOREND /find_object/;
  PROCEND find_object_name;

MODEND fdm$process_object;
*DECK DECK=FDM$PROCESS_PROGRAM_REQUESTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Screen Formating: Process Program Requests' ??
MODULE fdm$process_program_requests;

{ PURPOSE:
{   This module processes CYBIL application program requests that
{   interact with a terminal user through a previously defined form.
{
{ DESIGN:
{   Record data about the screen updates until a read or show call occurs.

?? LIBRARY := 'MLF$LIBRARY' ??

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc amk$base_keypoint_values
*copyc cyd$run_time_error_condition
*copyc fdc$im_smart_capability
*copyc fdc$integer_length
*copyc fdc$message_variable_length
*copyc fdc$real_length
*copyc fdc$screen_formatting_version
*copyc fdc$system_display_name
*copyc fdc$system_exponent_character
*copyc fde$condition_identifiers
*copyc fdk$screen_formatting_keypoints
*copyc fdt$current_form_identifier
*copyc fdt$display_index
*copyc fdt$event_index
*copyc fdt$event_position
*copyc fdt$form_object_definition
*copyc fdt$form_object_key
*copyc fdt$input_format
*copyc fdt$screen_change_index
*copyc fdt$valid_integer_index
*copyc fdt$valid_string_index
*copyc fdt$valid_real_index
*copyc fdt$variable_status
*copyc fdt$variable_value
*copyc fdt$work_area_length
*copy i#build_adaptable_array_ptr
*copyc lle$loader_status_conditions
*copyc ost$name
?? POP ??
*copyc fdv$colors
*copyc fdv$line_attributes
*copyc fdv$screen_status

*copyc clp$convert_date_time_to_string
*copyc clp$convert_string_to_date_time
*copyc clp$validate_date_time
*copyc clp$validate_name
*copyc fdp$change_currency_symbols
*copyc fdp$check_for_active_form
*copyc fdp$create_cobol_description
*copyc fdp$date_variable
*copyc fdp$delete_area
*copyc fdp$find_display_name
*copyc fdp$find_form_definition
*copyc fdp$find_form_status
*copyc fdp$find_object_definition
*copyc fdp$find_table_definition
*copyc fdp$find_variable_definition
*copyc fdp$locate_added_variable_facts
*copyc fdp$move_cobol_data
*copyc fdp$ptr_comments
*copyc fdp$ptr_displays
*copyc fdp$ptr_events
*copyc fdp$ptr_objects
*copyc fdp$ptr_screen_variable
*copyc fdp$ptr_table_objects
*copyc fdp$ptr_table_variables
*copyc fdp$ptr_tables
*copyc fdp$ptr_record_definitions
*copyc fdp$ptr_text
*copyc fdp$ptr_valid_integers
*copyc fdp$ptr_valid_reals
*copyc fdp$ptr_valid_strings
*copyc fdp$ptr_variable
*copyc fdp$ptr_variables
*copyc fdp$tab_to_next_variable
*copyc i#move
*copyc mlp$compare_bytes
*copyc mlp$input_floating_number
*copyc mlp$input_integer
*copyc mlp$move_bytes
*copyc mlp$output_floating_number
*copyc mlp$output_integer
*copyc mlp$scan_bytes
*copyc mlp$translate_bytes
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc pmp$this_is_a_leap_year
*copyc pmp$continue_to_cause
*copyc osp$establish_condition_handler
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    fdc$forms_to_expand = 7,
    fdc$screen_changes_to_expand = 10;

{ Date format strings.

  CONST
    fdc$dmy_format_string = 'd2/m2/y2',
    fdc$iso_format_string = 'isod',
    fdc$mdy_format_string = 'm2/d2/y2',
    fdc$month_format_string = 'month',
    fdc$ydm_format_string = 'y2/d2/m2';

?? TITLE := 'fdp$add_form', EJECT ??
*copyc fdh$add_form

  PROCEDURE [XDCL] fdp$add_form
    (    form_identifier: fdt$form_identifier;
     VAR status: ost$status);

    VAR
      event_form_identifier: fdt$form_identifier,
      form_added: boolean,
      local_status: ost$status,
      p_form_definition: ^fdt$form_definition,
      p_form_status: ^fdt$form_status,
      screen_change: fdt$screen_change;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$add_form;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$add_form;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_form_status^.added THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_already_added,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF p_form_status^.combined THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_already_combined,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF p_form_status^.push_count <> 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_pushed,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

{ Form must fit on terminal screen.

    p_form_definition := p_form_status^.p_form_definition;
    check_form_screen_fit (p_form_status^.form_x_position, p_form_status^.form_y_position,
          p_form_definition^.width, p_form_definition^.height, p_form_definition^.form_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Remove any duplicate screen changes.

    fdp$delete_screen_changes (form_identifier, form_added);

{ Record add of form to screen. The form will be displayed when the screen is updated.

    screen_change.key := fdc$add_form;
    screen_change.form_identifier := form_identifier;
    screen_change.form_x_position := p_form_status^.form_x_position;
    screen_change.form_y_position := p_form_status^.form_y_position;
    fdp$record_screen_change (screen_change, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_status^.added := TRUE;
    p_form_status^.push_count := 0;

{ Update form priority. Higher priority  forms  cover up lower
{ priority forms. The last added form is the highest priority form.

    p_form_status^.next_lower_form := fdv$screen_status.current_form_identifier;
    p_form_status^.next_higher_form := 0;
    IF fdv$screen_status.current_form_identifier <> 0 THEN
      fdv$screen_status.p_forms_status^ [fdv$screen_status.current_form_identifier].next_higher_form :=
            form_identifier;
    IFEND;

    fdv$screen_status.current_form_identifier := form_identifier;
    fdv$screen_status.compute_new_screen_size := TRUE;
    fdv$screen_status.last_cursor_position_valid := FALSE;

{ If an event form is associated with the added form, combine the event form with the added form.
{ The event form inherits the events of the added form so that any terminal user events on the
{ event form act in the same way as the added form.

    IF p_form_status^.event_form_defined THEN
      event_form_identifier := p_form_status^.event_form_identifier;
      fdp$combine_form (form_identifier, event_form_identifier, status);
      IF NOT status.normal THEN
        fdp$delete_form (form_identifier, local_status);
        RETURN;
      IFEND;
    IFEND;
  PROCEND fdp$add_form;

?? TITLE := 'fdp$change_table_size', EJECT ??
*copy fdh$change_table_size

  PROCEDURE [XDCL] fdp$change_table_size
    (    form_identifier: fdt$form_identifier;
         table_name: ost$name;
         table_size: fdt$table_size;
     VAR status: ost$status);

    VAR
      name_exists: boolean,
      object_index: fdt$object_index,
      p_form_definition: ^fdt$form_definition,
      p_form_module: ^fdt$form_module,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_form_status: ^fdt$form_status,
      p_form_table_definition: ^fdt$form_table_definition,
      p_table_object: ^fdt$table_object,
      p_table_objects: ^array [1 .. * ] of fdt$table_object,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable,
      screen_change: fdt$screen_change,
      table_index: fdt$table_index,
      table_object_index: fdt$object_index,
      table_variable_index: fdt$variable_index,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$change_table_size;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$change_table_size;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_form_status^.push_count <> 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_pushed,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    #translate (osv$lower_to_upper, table_name, valid_name);
    fdp$find_table_definition (valid_name, p_form_status^.p_form_table_definitions,
          p_form_definition^.form_table_definitions.active_number, p_form_table_definition, table_index,
          name_exists);
    IF NOT name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_table_name, table_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF ((table_size < 0) OR (table_size > p_form_table_definition^.stored_occurrence)) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_table_size, table_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    p_form_status^.p_form_table_statuses^ [table_index].last_active_occurrence := table_size;
    p_form_module := p_form_status^.p_form_module;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables, p_form_module);

{ Make objects visible or invisible.  Table size number of objects are made visible.
{ The remaining objects are made invisible.

    FOR table_variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
      p_table_objects := fdp$ptr_table_objects (p_table_variables^ [table_variable_index].table_objects,
            p_form_module);
      FOR table_object_index := 1 TO table_size DO
        p_table_object := ^p_table_objects^ [table_object_index];
        object_index := p_table_object^.object_index;
        p_form_object_definition := ^p_form_object_definitions^ [object_index];
        p_form_object_statuses^ [object_index].display_attribute_set :=
              p_form_object_definition^.display_attribute;
      FOREND;

      FOR table_object_index := 1 + table_size TO p_form_table_definition^.stored_occurrence DO
        p_table_object := ^p_table_objects^ [table_object_index];
        object_index := p_table_object^.object_index;
        p_form_object_definition := ^p_form_object_definitions^ [object_index];
        p_form_object_statuses^ [object_index].display_attribute_set :=
              (p_form_object_definition^.display_attribute * fdv$colors) +
              $fdt$display_attribute_set [fdc$protect, fdc$hidden];
      FOREND;
    FOREND;

    IF p_form_status^.displayed_on_screen AND (p_form_status^.added OR p_form_status^.combined) THEN
      screen_change.key := fdc$change_table_size;
      screen_change.table_form_identifier := form_identifier;
      screen_change.table_index := table_index;
      fdp$record_screen_change (screen_change, status);
    IFEND;
  PROCEND fdp$change_table_size;

?? TITLE := 'fdp$close_form', EJECT ??
*copy fdh$close_form

  PROCEDURE [XDCL] fdp$close_form
    (    form_identifier: fdt$form_identifier;
     VAR status: ost$status);

    VAR
      event_form_identifier: fdt$form_identifier,
      form_added: boolean,
      local_status: ost$status,
      p_form_status: ^fdt$form_status,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      screen_change: fdt$screen_change;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$close_form;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$close_form;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ A form owned by the system is in the process of being closed.
{ Screen Formatting needs to keep some data about the form until the screen is updated.

    IF ((NOT p_form_status^.opened) AND (p_form_status^.owned_by_system)) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_form_identifier, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (form_identifier), 10, FALSE,
            status);
      RETURN;
    IFEND;

{ A pushed form cannot be closed.

    IF p_form_status^.push_count <> 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_pushed,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

{ Remove any duplicate screen changes.

    fdp$delete_screen_changes (form_identifier, form_added);

    IF p_form_status^.displayed_on_screen THEN

{ Record close of form as a screen change. Keep a record of the form until the
{ screen is updated in order to know what forms are uncovered
{ by the closed form.

        screen_change.key := fdc$close_form;
        screen_change.close_form_identifier := form_identifier;
        fdp$record_screen_change (screen_change, local_status);
        fdv$screen_status.compute_new_screen_size := TRUE;
        IF ((fdv$screen_status.last_cursor_position_valid) AND
              (fdv$screen_status.last_cursor_form_identifier = form_identifier)) THEN
          fdv$screen_status.last_cursor_position_valid := FALSE;
        IFEND;

      ELSE

{ Form is not displayed on screen.  There is no need to record changes to
{ screen.

        IF p_form_status^.p_form_object_statuses <> NIL THEN
          FREE p_form_status^.p_form_object_statuses;
        IFEND;

        IF p_form_status^.defined_dynamically THEN
          mmp$delete_scratch_segment (p_form_status^.segment_pointer, local_status);
        IFEND;
    IFEND;

{ Free storage associated with the  form.

    IF p_form_status^.p_program_record <> NIL THEN
      FREE p_form_status^.p_program_record;
    IFEND;

    IF p_form_status^.p_screen_record <> NIL THEN
      FREE p_form_status^.p_screen_record;
    IFEND;

    IF p_form_status^.p_form_table_statuses <> NIL THEN
      FREE p_form_status^.p_form_table_statuses;
    IFEND;

    IF p_form_status^.p_form_event_statuses <> NIL THEN
      FREE p_form_status^.p_form_event_statuses;
    IFEND;

    IF p_form_status^.p_form_image <> NIL THEN
      FREE p_form_status^.p_form_image;
    IFEND;

{ Remove form from list recording priorities of forms.

    IF p_form_status^.added THEN
      update_form_priorities (p_form_status);
      p_form_status^.added := FALSE;
    IFEND;

    IF p_form_status^.combined THEN
      update_form_priorities (p_form_status);
      p_form_status^.combined := FALSE;
    IFEND;

{ Also close any associated event form.
{ Since the application program may have closed the event form
{ disregard errors on close.

    IF p_form_status^.event_form_defined THEN
      event_form_identifier := p_form_status^.event_form_identifier;
      fdp$close_form (event_form_identifier, local_status);
      p_form_status^.event_form_defined := FALSE;
    IFEND;

    p_form_status^.opened := FALSE;
    IF p_form_status^.displayed_on_screen THEN
      p_form_status^.owned_by_system := TRUE;
    ELSE
      p_form_status^.entry_used := FALSE;
    IFEND;

  PROCEND fdp$close_form;

?? TITLE := 'fdp$combine_form', EJECT ??
*copy fdh$combine_form

  PROCEDURE [XDCL] fdp$combine_form
    (    added_form_identifier: fdt$form_identifier;
         combine_form_identifier: fdt$form_identifier;
     VAR status: ost$status);

    VAR
      form_added: boolean,
      local_status: ost$status,
      p_added_form_status: ^fdt$form_status,
      p_form_definition: ^fdt$form_definition,
      p_combine_form_status: ^fdt$form_status,
      screen_change: fdt$screen_change;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$combine_form;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$combine_form;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_status (added_form_identifier, p_added_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$find_form_status (combine_form_identifier, p_combine_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_combine_form_status^.p_form_definition;
    IF p_combine_form_status^.added THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_already_added,
            p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF p_combine_form_status^.combined THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_already_combined,
            p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF NOT p_added_form_status^.added THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_not_added,
            p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF p_combine_form_status^.push_count <> 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_pushed, p_form_definition^.form_name,
            status);
      RETURN;
    IFEND;

{ Form must fit on terminal screen.

    check_form_screen_fit (p_combine_form_status^.form_x_position, p_combine_form_status^.form_y_position,
          p_form_definition^.width, p_form_definition^.height, p_form_definition^.form_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Remove any duplicate screen changes.

    fdp$delete_screen_changes (combine_form_identifier, form_added);

{ Record add of form to screen. The form will be displayed when the screen is updated.

    screen_change.key := fdc$add_form;
    screen_change.form_identifier := combine_form_identifier;
    screen_change.form_x_position := p_combine_form_status^.form_x_position;
    screen_change.form_y_position := p_combine_form_status^.form_y_position;
    fdp$record_screen_change (screen_change, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_combine_form_status^.combined := TRUE;
    p_combine_form_status^.combined_events := FALSE;
    p_combine_form_status^.added_form_identifier := added_form_identifier;
    p_combine_form_status^.push_count := 0;

{ Update form priority. Higher priority  forms  cover up lower
{ priority forms. The last added form is the highest priority form.

    p_combine_form_status^.next_lower_form := fdv$screen_status.current_form_identifier;
    p_combine_form_status^.next_higher_form := 0;
    IF fdv$screen_status.current_form_identifier <> 0 THEN
      fdv$screen_status.p_forms_status^ [fdv$screen_status.current_form_identifier].next_higher_form :=
            combine_form_identifier;
    IFEND;

    fdv$screen_status.current_form_identifier := combine_form_identifier;
    fdv$screen_status.compute_new_screen_size := TRUE;
    fdv$screen_status.last_cursor_position_valid := FALSE;

  PROCEND fdp$combine_form;

?? TITLE := 'fdp$combine_form_events', EJECT ??
*copy fdh$combine_form_events

  PROCEDURE [XDCL] fdp$combine_form_events
    (    added_form_identifier: fdt$form_identifier;
         combine_form_identifier: fdt$form_identifier;
     VAR status: ost$status);

    VAR
      form_added: boolean,
      local_status: ost$status,
      p_added_form_status: ^fdt$form_status,
      p_form_definition: ^fdt$form_definition,
      p_combine_form_status: ^fdt$form_status,
      screen_change: fdt$screen_change;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$combine_form_events;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$combine_form_events;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_status (added_form_identifier, p_added_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$find_form_status (combine_form_identifier, p_combine_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_combine_form_status^.p_form_definition;
    IF p_combine_form_status^.added THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_already_added,
            p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF p_combine_form_status^.combined THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_already_combined,
            p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF NOT p_added_form_status^.added THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_not_added,
            p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF p_combine_form_status^.push_count <> 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_pushed, p_form_definition^.form_name,
            status);
      RETURN;
    IFEND;

{ Form must fit on terminal screen.

    check_form_screen_fit (p_combine_form_status^.form_x_position, p_combine_form_status^.form_y_position,
          p_form_definition^.width, p_form_definition^.height, p_form_definition^.form_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Remove any duplicate screen changes.

    fdp$delete_screen_changes (combine_form_identifier, form_added);

{ Record add of form to screen. The form will be displayed when the screen is updated.

    screen_change.key := fdc$add_form;
    screen_change.form_identifier := combine_form_identifier;
    screen_change.form_x_position := p_combine_form_status^.form_x_position;
    screen_change.form_y_position := p_combine_form_status^.form_y_position;
    fdp$record_screen_change (screen_change, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_combine_form_status^.combined := TRUE;
    p_combine_form_status^.combined_events := TRUE;
    p_combine_form_status^.added_form_identifier := added_form_identifier;
    p_combine_form_status^.push_count := 0;

{ Update form priority. Higher priority  forms  cover up lower
{ priority forms. The last added form is the highest priority form.

    p_combine_form_status^.next_lower_form := fdv$screen_status.current_form_identifier;
    p_combine_form_status^.next_higher_form := 0;
    IF fdv$screen_status.current_form_identifier <> 0 THEN
      fdv$screen_status.p_forms_status^ [fdv$screen_status.current_form_identifier].next_higher_form :=
            combine_form_identifier;
    IFEND;

    fdv$screen_status.current_form_identifier := combine_form_identifier;
    fdv$screen_status.compute_new_screen_size := TRUE;
    fdv$screen_status.last_cursor_position_valid := FALSE;

  PROCEND fdp$combine_form_events;

?? TITLE := 'fdp$convert_to_program_value', EJECT ??
*copyc fdh$convert_to_program_value

  PROCEDURE [XDCL] fdp$convert_to_program_value
    (    form_identifier: fdt$form_identifier;
         variable_name: ost$name;
         p_text: ^fdt$text;
     VAR variable_value: fdt$variable_value;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    VAR
      name_exists: boolean,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_status: ^fdt$form_status,
      p_value: ^cell,
      valid_name: ost$name,
      variable_index: fdt$variable_index;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$convert_to_program_value;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$convert_to_program_value;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    variable_status := fdc$no_error;
    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    #TRANSLATE (osv$lower_to_upper, variable_name, valid_name);
    fdp$find_variable_definition (valid_name, p_form_status^.p_form_variable_definitions,
           p_form_status^.p_form_definition^.form_variable_definitions.active_number,
           p_form_variable_definition, variable_index, name_exists);
    IF NOT name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_variable_name,
            variable_name, status);
      osp$append_status_parameter( osc$status_parameter_delimiter, p_form_status^.
            p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    variable_value.program_data_type := p_form_variable_definition^.program_data_type;
    CASE variable_value.program_data_type OF

    = fdc$program_cobol_type =
      p_value := variable_value.p_cobol_data;
      variable_value.cobol_data_length := p_form_variable_definition^.program_variable_length;

    = fdc$program_character_type,  fdc$program_upper_case_type =
      p_value := variable_value.p_text;
      variable_value.text_length := STRLENGTH (p_text^);

    = fdc$program_integer_type =
      p_value := ^variable_value.integer_value;

    ELSE {fdc$program_real_type
      p_value := ^variable_value.real_value;

    CASEND;

    fdp$move_to_program_variable (p_form_status, p_form_variable_definition,
            p_text, p_value, variable_status, status);

  PROCEND fdp$convert_to_program_value;

?? TITLE := 'fdp$convert_to_program_variable', EJECT ??
*copy fdh$convert_to_program_variable

  PROCEDURE [XDCL] fdp$convert_to_program_variable
    (    program_data_type: fdt$program_data_type;
         p_program_variable: ^cell;
         program_variable_length: fdt$program_variable_length;
         input_format: fdt$input_format;
         p_screen_variable: ^fdt$text;
         screen_variable_length: fdt$text_length;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$convert_to_program_variable;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$convert_to_program_variable;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
?? NEWTITLE := 'convert_currency', EJECT ??

    PROCEDURE [INLINE] convert_currency
      (    program_data_type: fdt$program_data_type;
           p_program_variable: {output} ^cell;
       VAR integer_number: integer;
       VAR variable_status: fdt$variable_status);

       VAR
         real_number: real;

      variable_status := fdc$no_error;
      CASE program_data_type OF

        = fdc$program_real_type =
          real_number := $REAL(integer_number) / 100.0;
          i#move (^real_number, p_program_variable, fdc$real_length);

        = fdc$program_integer_type =
          i#move (^integer_number, p_program_variable, fdc$integer_length);

      ELSE
        variable_status := fdc$invalid_bdp_data;
      CASEND;
    PROCEND convert_currency;

?? OLDTITLE, EJECT ??
?? NEWTITLE := 'convert_date', EJECT ??

    PROCEDURE convert_date
      (    program_data_type: fdt$program_data_type;
           p_text: ^fdt$text;
           format: clt$date_time_form_string;
           p_program_variable: {output} ^cell;
       VAR variable_status: fdt$variable_status);

      VAR
        date_time: clt$date_time,
        ignore_character_found: boolean,
        local_status: ost$status,
        start_index: integer,
        yymmdd: integer;


      variable_status := fdc$no_error;
      CASE program_data_type OF

      = fdc$program_integer_type =
        #SCAN (non_space, p_text^, start_index, ignore_character_found);
        IF start_index > screen_variable_length THEN
          yymmdd := 0;
          i#move (^yymmdd, p_program_variable, fdc$integer_length);
          RETURN;
        IFEND;
        clp$convert_string_to_date_time (p_text^, format, date_time, local_status);
        IF NOT local_status.normal THEN
          variable_status := fdc$invalid_integer;
          RETURN;
        IFEND;
        IF (date_time.value.year > 99) THEN
          variable_status := fdc$invalid_integer;
        ELSE
          variable_status := fdc$no_error;
          yymmdd := (date_time.value.year * 10000) + (date_time.value.month * 100) + date_time.value.day;
          i#move (^yymmdd, p_program_variable, fdc$integer_length);
        IFEND;
      ELSE
        variable_status := fdc$invalid_integer;
      CASEND;

    PROCEND convert_date;

?? OLDTITLE, EJECT ??

    VAR
      actual_text_length: mlt$string_length,
      character_index: integer,
      character_found: boolean,
      decimal_point_found: boolean,
      error: mlt$error,
      integer_number: integer,
      leading_space_found: boolean,
      non_alphabetic: [READ, STATIC] packed array [char] of boolean := [
            {---} REP 65 of TRUE,
            {A..Z} REP 26 of FALSE,
            {---} REP 6 of TRUE,
            {a..z} REP 26 of FALSE,
            {---} REP 133 of TRUE],
      non_digit: [READ, STATIC] packed array [char] of boolean := [
            {---} REP 48 of TRUE,
            {0..9} REP 10 of FALSE,
            {---} REP 198 of TRUE],
      non_sign_digit: [READ, STATIC] packed array [char] of boolean := [
            {---} REP 43 of TRUE,
            { + } REP 1 of FALSE,
            {---} REP 1 of TRUE,
            { - } REP 1 of FALSE,
            {---} REP 2 of TRUE,
            {0..9} REP 10 of FALSE,
            {---} REP 199 of TRUE],
      non_space: [READ, STATIC] packed array [char] of boolean := [
            {---} REP 32 of TRUE,
            {- -} FALSE,
            {---} REP 223 of TRUE],
      p_integer_text: ^fdt$text,
      p_text: ^fdt$text,
      real_number: real,
      scan_index: integer,
      start_index: integer,
      text_index: integer,
      thousand_character_count: integer;

    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    variable_status := fdc$no_error;

{ Validate input format.

  /validate_format/
    BEGIN
      CASE input_format.key OF

      = fdc$alphabetic_input_format =

{ Ignore leading spaces.

        #SCAN (non_space, p_screen_variable^, start_index, character_found);
        IF start_index > screen_variable_length THEN
          EXIT /validate_format/;
        IFEND;

{ Characters must be A-Z, a-z.

        #SCAN (non_alphabetic, p_screen_variable^ (start_index, * ), character_index, character_found);
        IF ((start_index + character_index - 1) > screen_variable_length) THEN
          EXIT /validate_format/;
        IFEND;

{ Remaining characters must be spaces.

        #SCAN (non_space, p_screen_variable^ (start_index + character_index - 1, * ), character_index,
              character_found);
        IF character_found THEN
          variable_status := fdc$invalid_bdp_data;
          RETURN;
        IFEND;

      = fdc$character_input_format =

{ Do nothing.  All characters are valid.

      = fdc$digits_input_format =

{ Ignore leading spaces.

        #SCAN (non_space, p_screen_variable^, start_index, character_found);
        IF start_index > screen_variable_length THEN
          EXIT /validate_format/;
        IFEND;

{ Characters must be 0-9.

        #SCAN (non_digit, p_screen_variable^ (start_index, * ), character_index, character_found);
        IF ((start_index + character_index - 1) > screen_variable_length) THEN
          EXIT /validate_format/;
        IFEND;

{ Remaining characters must be spaces.

        #SCAN (non_space, p_screen_variable^ (start_index + character_index - 1, * ), character_index,
              character_found);
        IF character_found THEN
          variable_status := fdc$invalid_bdp_data;
          RETURN;
        IFEND;

      = fdc$signed_input_format =

{ Ignore leading spaces.

        #SCAN (non_space, p_screen_variable^, start_index, character_found);
        IF start_index > screen_variable_length THEN
          EXIT /validate_format/;
        IFEND;

{ Allow leading plus or minus.

        IF ((p_screen_variable^ (start_index) = '+') OR
           (p_screen_variable^ (start_index) = '-')) THEN
          start_index := start_index +1;
        IFEND;

{ Characters must be 0-9.

        #SCAN (non_digit, p_screen_variable^ (start_index, * ), character_index, character_found);
        IF ((start_index + character_index - 1) > screen_variable_length) THEN
          EXIT /validate_format/;
        IFEND;

{ Remaining characters must be spaces.

        #SCAN (non_space, p_screen_variable^ (start_index + character_index - 1, * ),
              character_index, character_found);
        IF character_found THEN
          variable_status := fdc$invalid_bdp_data;
          RETURN;
        IFEND;

      = fdc$real_input_format =

{ Allow math conversion procedures used later to detect errors.

      = fdc$currency_input_format =

{ Edit screen input text.  Remove currency symbol, thousands separator,
{ and decimal point. Because real numbers are approximations use
{ integer format initially.

      PUSH p_text: [screen_variable_length];
      p_text^ (1, *) := '';
      text_index := 0;
      leading_space_found := FALSE;
      decimal_point_found := FALSE;
      thousand_character_count := 0;

      /validate_currency/
        FOR scan_index := screen_variable_length DOWNTO 1 DO
          IF (p_screen_variable^ (scan_index, 1) = ' ') THEN
            IF text_index = 0 THEN

{ Ignore trailing spaces.

              CYCLE /validate_currency/;

            ELSEIF leading_space_found THEN

{ Ignore leading spaces.

              CYCLE /validate_currency/;

            ELSE
              leading_space_found := TRUE;
            IFEND;

{ Character is not a space.

          ELSEIF leading_space_found THEN

{ Currency format cannot have embedded spaces.

            variable_status := fdc$invalid_bdp_data;
            RETURN;

          ELSEIF (p_screen_variable^ (scan_index, 1) =
               input_format.input_currency_format.decimal_point) THEN

{ Terminal user may type x, x., x.y, x.yz for currency
{ where x, y, and z are digits.

            IF text_index = 0 THEN
              thousand_character_count := 0;
            ELSEIF text_index = 1 THEN
              decimal_point_found := TRUE;
              p_text^ (screen_variable_length - 1, 1) :=
                   p_text^ (screen_variable_length, 1);
              p_text^ (screen_variable_length, 1) := '0';
              text_index := 2;
              thousand_character_count := 0;
            ELSEIF text_index = 2 THEN
              thousand_character_count := 0;
              decimal_point_found := TRUE;
            ELSE
              variable_status := fdc$invalid_bdp_data;
              RETURN;
            IFEND;

          ELSEIF (p_screen_variable^ (scan_index, 1) =
               input_format.input_currency_format.thousands_separator) THEN
               IF thousand_character_count = 3 THEN
                 thousand_character_count := 0;
                 CYCLE /validate_currency/;
               ELSE
                 variable_status := fdc$invalid_bdp_data;
                 RETURN;
               IFEND;

          ELSEIF (p_screen_variable^ (scan_index, 1) =
               input_format.input_currency_format.currency_sybmol) THEN
            CYCLE /validate_currency/;

          ELSE

{ Math routine will find other invalid characters.

            text_index := text_index + 1;
            p_text^ (screen_variable_length - text_index +1, 1) :=
                 p_screen_variable^ (scan_index, 1);
            thousand_character_count := thousand_character_count + 1;
          IFEND;
        FOREND /validate_currency/;

      IF text_index = 0 THEN
        integer_number := 0;
        convert_currency (program_data_type, p_program_variable, integer_number,
              variable_status);
        RETURN;
      IFEND;


      IF NOT decimal_point_found THEN

{ User did not enter any cents.  Multiply amount entered by 100.

        PUSH p_integer_text: [text_index + 2];
        p_integer_text^ (text_index + 2 - 1, 2) := '00';
        p_integer_text^ (1, text_index) :=
             p_text^ (screen_variable_length - text_index + 1, text_index);
        mlp$input_integer(p_integer_text, STRLENGTH(p_integer_text^), ^integer_number,
              mlc$max_integer_length, mlc$signed_integer, mlc$stop_on_blank,
              actual_text_length, error);
      ELSE
        mlp$input_integer(p_text, screen_variable_length, ^integer_number,
              mlc$max_integer_length, mlc$signed_integer, mlc$stop_on_blank,
              actual_text_length, error);

      IFEND;
      CASE error OF

      = mle$no_error, mle$no_digits =
        convert_currency (program_data_type, p_program_variable, integer_number,
              variable_status);

      = mle$overflow =
        variable_status := fdc$overflow;

      ELSE
        variable_status := fdc$invalid_bdp_data;
      CASEND;
      RETURN;

      = fdc$ydm_format =
        convert_date (program_data_type, ^p_screen_variable^ (1,screen_variable_length),
              fdc$ydm_format_string, p_program_variable, variable_status);
        RETURN;

      = fdc$mdy_format =
        convert_date (program_data_type, ^p_screen_variable^ (1,screen_variable_length),
              fdc$mdy_format_string, p_program_variable, variable_status);
        RETURN;

      = fdc$dmy_format =
        convert_date (program_data_type, ^p_screen_variable^ (1,screen_variable_length),
              fdc$dmy_format_string, p_program_variable, variable_status);
        RETURN;

      = fdc$iso_date_format =
        convert_date (program_data_type, ^p_screen_variable^ (1,screen_variable_length),
              fdc$iso_format_string, p_program_variable, variable_status);
        RETURN;

      = fdc$month_dd_yyyy_format =
        convert_date (program_data_type, ^p_screen_variable^ (1,screen_variable_length),
              fdc$month_format_string, p_program_variable, variable_status);
        RETURN;

      ELSE
        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_input_format_key, '', status);
        RETURN;
      CASEND;
    END /validate_format/;

{ Convert screen character data to program data type.

    CASE program_data_type OF

    = fdc$program_character_type =
      mlp$move_bytes (p_screen_variable, screen_variable_length, p_program_variable, program_variable_length,
            error);

    = fdc$program_upper_case_type =
      mlp$translate_bytes (p_screen_variable, screen_variable_length, p_program_variable,
            program_variable_length, ^osv$lower_to_upper, error);

    = fdc$program_real_type =

{ Ignore leading spaces.

      #SCAN (non_space, p_screen_variable^, start_index, character_found);
      IF start_index > screen_variable_length THEN
        real_number := 0.0;
        i#move (^real_number, p_program_variable, fdc$real_length);
        RETURN;
      IFEND;

{ Spaces in middle of number are invalid so stop on blanks.

      mlp$input_floating_number (^p_screen_variable^ (start_index, *) ,
      screen_variable_length - start_index + 1, ^real_number,
            mlc$single_precision, mlc$stop_on_blank, actual_text_length, error);

      CASE error OF

      = mle$no_error, mle$no_digits =
        IF (actual_text_length < (screen_variable_length - start_index + 1)) THEN

{ Remaining characters must be spaces.

          #SCAN (non_space, p_screen_variable^ (start_index + actual_text_length, * ), character_index,
                character_found);
          IF character_found THEN
            variable_status := fdc$invalid_bdp_data;
            RETURN;
          IFEND;
        IFEND;
        i#move (^real_number, p_program_variable, fdc$real_length);

      = mle$invalid_bdp_data =
        variable_status := fdc$invalid_bdp_data;

      = mle$overflow =
        variable_status := fdc$overflow;

      ELSE
        variable_status := fdc$invalid_real;
      CASEND;

    = fdc$program_integer_type =

{ Ignore leading spaces.

      #SCAN (non_space, p_screen_variable^, start_index, character_found);
      IF start_index > screen_variable_length THEN
        integer_number := 0;
        i#move (^integer_number, p_program_variable, fdc$integer_length);
        RETURN;
      IFEND;

      mlp$input_integer (^p_screen_variable^ (start_index, *),
            screen_variable_length - start_index + 1, ^integer_number, mlc$max_integer_length,
            mlc$signed_integer, mlc$stop_on_blank, actual_text_length, error);
      CASE error OF

      = mle$no_error, mle$no_digits =
        IF (actual_text_length < (screen_variable_length - start_index + 1)) THEN

{ Remaining characters must be spaces.

          #SCAN (non_space, p_screen_variable^ (start_index + actual_text_length, * ), character_index,
                character_found);
          IF character_found THEN
            variable_status := fdc$invalid_bdp_data;
            RETURN;
          IFEND;
        IFEND;
        i#move (^integer_number, p_program_variable, fdc$integer_length);

      = mle$invalid_bdp_data =
        variable_status := fdc$invalid_bdp_data;

      = mle$loss_of_significance =
        variable_status := fdc$loss_of_significance;

      ELSE
        variable_status := fdc$invalid_integer;
      CASEND;

    ELSE


{ Invalid program data type.

     osp$set_status_abnormal (fdc$format_display_identifier, fde$program_data_type, '', status);
    CASEND;
  PROCEND fdp$convert_to_program_variable;

?? TITLE := 'fdp$convert_to_screen_value', EJECT ??
*copyc fdh$convert_to_screen_value

  PROCEDURE [XDCL] fdp$convert_to_screen_value
    (    form_identifier: fdt$form_identifier;
         variable_name: ost$name;
         variable_value: fdt$variable_value;
         p_text: {output} ^fdt$text;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    VAR
      name_exists: boolean,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_status: ^fdt$form_status,
      p_value: ^cell,
      valid_name: ost$name,
      variable_index: fdt$variable_index;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$convert_to_screen_value;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$convert_to_screen_value;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    variable_status := fdc$no_error;
    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    #TRANSLATE (osv$lower_to_upper, variable_name, valid_name);
    fdp$find_variable_definition (valid_name, p_form_status^.p_form_variable_definitions,
           p_form_status^.p_form_definition^.form_variable_definitions.active_number,
           p_form_variable_definition, variable_index, name_exists);
    IF NOT name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_variable_name,
            variable_name, status);
      osp$append_status_parameter( osc$status_parameter_delimiter, p_form_status^.
            p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    CASE variable_value.program_data_type OF

    = fdc$program_cobol_type =
      p_value := variable_value.p_cobol_data;

    = fdc$program_character_type,  fdc$program_upper_case_type =
      p_value := variable_value.p_text;

    = fdc$program_integer_type =
      p_value := ^variable_value.integer_value;

    ELSE {fdc$program_real_type
      p_value := ^variable_value.real_value;

    CASEND;

    fdp$move_to_screen_variable (p_form_status, p_form_variable_definition,
            p_value, p_text, variable_status, status);

  PROCEND fdp$convert_to_screen_value;

?? TITLE := 'fdp$convert_to_screen_variable', EJECT ??
*copyc fdh$convert_to_screen_variable

  PROCEDURE [XDCL] fdp$convert_to_screen_variable
    (    program_data_type: fdt$program_data_type;
         p_program_variable: ^cell;
         program_variable_length: fdt$program_variable_length;
         output_format: fdt$output_format;
         p_screen_variable: ^fdt$text;
         screen_variable_length: fdt$text_length;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    VAR
      end_of_text: boolean,
      error: mlt$error,
      integer_number: integer,
      invalid_string: boolean,
      minimum_index: fdt$text_length,
      p_text: ^fdt$text,
      real_number: real,
      scan_index: integer,
      screen_format: mlt$output_format,
      string_length: mlt$string_length,
      terminal_control_characters: [READ] packed array [char] of boolean :=
            [REP 30 of TRUE, REP 226 of FALSE],
      text_index: integer,
      thousand_character_count: integer;

?? NEWTITLE := 'add_character', EJECT ??
   PROCEDURE [INLINE] add_character
      (     character: string (1);
            separator: string (1);
            p_text: {output} ^fdt$text;
       VAR  text_index: integer;
       VAR separator_count: integer;
       VAR variable_status: fdt$variable_status);

       variable_status := fdc$no_error;
       separator_count := separator_count + 1;
       IF separator_count > 3 THEN
         separator_count := 1;
         IF separator <> ' ' THEN
           text_index := text_index - 1;
           IF text_index > 0 THEN
             p_text^ (text_index, 1) := separator;
           ELSE
             variable_status := fdc$loss_of_significance;
             RETURN;
           IFEND;
         IFEND;
       IFEND;

       text_index := text_index - 1;
       IF text_index > 0 THEN
         p_text^ (text_index, 1) := character;
       ELSE
         variable_status := fdc$loss_of_significance;
         RETURN;
       IFEND;

    PROCEND add_character;

?? OLDTITLE ??
?? NEWTITLE := 'check_error', EJECT ??

    PROCEDURE [INLINE] check_error;

      CASE error OF

      = mle$no_error =
        variable_status := fdc$no_error;

      = mle$loss_of_significance =
        variable_status := fdc$loss_of_significance;
        p_screen_variable^ := '*';

      = mle$infinite =
        variable_status := fdc$infinite;
        p_screen_variable^ := 'R';

      = mle$indefinite =
        variable_status := fdc$indefinite;
        p_screen_variable^ := 'I';

      = mle$bad_parameters =
        variable_status := fdc$output_format_bad;
        p_screen_variable^ := '*';

      ELSE
        variable_status := fdc$output_format_bad;
        p_screen_variable^ := '*';
      CASEND;

    PROCEND check_error;

?? OLDTITLE ??
?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$convert_to_screen_variable;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$convert_to_screen_variable;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE ??
?? NEWTITLE := 'convert_date_to_string', EJECT ??
    PROCEDURE convert_date_to_string
    (    yymmdd: integer;
         format: clt$date_time_form_string;
         p_screen_variable: ^fdt$text;
         screen_variable_length: fdt$text_length;
     VAR variable_status: fdt$variable_status);

     VAR
        date_string: ost$string,
        date_time: clt$date_time,
        local_status: ost$status;


      IF yymmdd = 0 THEN
        p_screen_variable^ (1, screen_variable_length) := ' ';
        RETURN;
      IFEND;
      fdp$convert_yymmdd_to_date_time (yymmdd, date_time, variable_status);
      IF variable_status <> fdc$no_error THEN
        p_screen_variable^ (1, screen_variable_length) := ' ';
        RETURN;
      IFEND;
      clp$convert_date_time_to_string (date_time, format, date_string, local_status);
      IF NOT local_status.normal THEN
        variable_status := fdc$invalid_integer;
        p_screen_variable^ (1, screen_variable_length) := ' ';
        RETURN;
      IFEND;
      p_screen_variable ^(1, screen_variable_length) := date_string.value (1, date_string.size);

    PROCEND convert_date_to_string;
?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    variable_status := fdc$no_error;

    CASE output_format.key OF

    = fdc$character_output_format =
      mlp$move_bytes (p_program_variable, program_variable_length, p_screen_variable, screen_variable_length,
            error);

{ Do not allow terminal control characters in output.  They may destroy form content.

      #SCAN (terminal_control_characters, p_screen_variable^, scan_index, invalid_string);
      IF invalid_string THEN
        variable_status := fdc$invalid_bdp_data;
        p_screen_variable^ (1, screen_variable_length) := ' ';
      IFEND;

    = fdc$ydm_output_format =

      i#move (p_program_variable, ^integer_number, program_variable_length);
      convert_date_to_string (integer_number, fdc$ydm_format_string, p_screen_variable,
            screen_variable_length, variable_status);

    = fdc$mdy_output_format =

      i#move (p_program_variable, ^integer_number, program_variable_length);
      convert_date_to_string (integer_number, fdc$mdy_format_string, p_screen_variable,
            screen_variable_length, variable_status);

    = fdc$dmy_output_format =

      i#move (p_program_variable, ^integer_number, program_variable_length);
      convert_date_to_string (integer_number, fdc$dmy_format_string, p_screen_variable,
            screen_variable_length, variable_status);

    = fdc$iso_output_format =

      i#move (p_program_variable, ^integer_number, program_variable_length);
      convert_date_to_string (integer_number, fdc$iso_format_string, p_screen_variable,
            screen_variable_length, variable_status);

    = fdc$month_dd_yyyy_out_format =

      i#move (p_program_variable, ^integer_number, program_variable_length);
      convert_date_to_string (integer_number, fdc$month_format_string, p_screen_variable,
            screen_variable_length, variable_status);

    = fdc$currency_output_format =

      CASE program_data_type OF

        = fdc$program_real_type =
          i#move (p_program_variable, ^real_number, program_variable_length);

        = fdc$program_integer_type =
          i#move (p_program_variable, ^integer_number, program_variable_length);
          real_number := $REAL (integer_number);
          real_number := real_number / 100.0;
      ELSE
        variable_status := fdc$output_format_bad;
        p_screen_variable^ := '*';
        RETURN;
      CASEND;

      IF (real_number = 0.0)  THEN
        IF output_format.output_currency_format.suppress_leading_zeros THEN

{ Suppress leading zeros really means display spaces when currency has
{ zero value.

          p_screen_variable^ (1, screen_variable_length) := ' ';
        ELSE

{ Display zero currency value in format $0.00

          p_screen_variable^ (1, screen_variable_length) := ' ';
          IF screen_variable_length > 3 THEN
            p_screen_variable^ (screen_variable_length - 1, 2) := '00';
            p_screen_variable^ (screen_variable_length - 2, 1) :=
                  output_format.output_currency_format.decimal_point;
            p_screen_variable^ (screen_variable_length - 3, 1) := '0';
            IF output_format.output_currency_format.currency_sybmol <> ' ' THEN
              IF screen_variable_length > 4 THEN
                p_screen_variable^ (screen_variable_length - 4, 1) :=
                     output_format.output_currency_format.currency_sybmol;
              ELSE
                variable_status := fdc$loss_of_significance;
                p_screen_variable^ := '*';
              IFEND;
            IFEND;
          ELSE {The object is not long enough to display the currency value.}
            variable_status := fdc$loss_of_significance;
            p_screen_variable^ := '*';
          IFEND;
        IFEND;
        RETURN;
      IFEND;

      PUSH p_text: [screen_variable_length];
      screen_format.justification := mlc$right_justify;
      screen_format.sign := output_format.output_currency_format.sign_treatment;
      screen_format.format := mlc$f_style;
      screen_format.scale_factor := 0;
      screen_format.width := output_format.output_currency_format.field_width;
      screen_format.digits := 2;
      screen_format.exponent_character := fdc$system_exponent_character;
      screen_format.exponent_style := 0;
      mlp$output_floating_number (^real_number, mlc$single_precision, p_text, screen_format,
            string_length, error);
      check_error;
      IF error <> mle$no_error THEN
        RETURN;
      IFEND;

{ Put in form definition for decimal point.

      p_screen_variable^ := p_text^;
      p_screen_variable^ (screen_variable_length - 2, 1) :=
           output_format.output_currency_format.decimal_point;

{ Put in thousands separator.

      thousand_character_count := 0;
      text_index := output_format.output_currency_format.field_width - 2;

      /format_currency/
        FOR scan_index :=
             output_format.output_currency_format.field_width - 3  DOWNTO 1 DO
          IF ((p_text^ (scan_index, 1) = ' ')  OR (p_text^ (scan_index, 1) = '-')) THEN
            EXIT /format_currency/;
          ELSE  { The character is a digit.}
            add_character (p_text^ (scan_index, 1),
                 output_format.output_currency_format.thousands_separator,
                 p_screen_variable, text_index, thousand_character_count, variable_status);
            IF variable_status <> fdc$no_error THEN
              p_screen_variable^ := '*';
              RETURN;
            IFEND;
          IFEND;
        FOREND /format_currency/;

{ Put in minus sign.

        IF (p_text^ (scan_index, 1) = '-') THEN
          text_index := text_index - 1;
          IF text_index > 0 THEN
            p_screen_variable^ (text_index, 1) := '-';
          ELSE
            variable_status := fdc$loss_of_significance;
            RETURN;
         IFEND;
       IFEND;

{ Put in currency symbol.

       IF output_format.output_currency_format.currency_sybmol <> ' ' THEN
         text_index := text_index - 1;
         IF text_index > 0 THEN
           p_screen_variable^ (text_index, 1) := output_format.output_currency_format.currency_sybmol;
         ELSE
           variable_status := fdc$loss_of_significance;
           RETURN;
         IFEND;
       IFEND;

    = fdc$integer_output_format =
      mlp$output_integer (p_program_variable, mlc$max_integer_length, mlc$signed_integer, p_screen_variable,
            output_format.integer_output_format.field_width, mlc$right_justify,
            output_format.integer_output_format.sign_treatment, string_length, error);
      check_error;
      IF error <> mle$no_error THEN
        RETURN;
      IFEND;

      IF output_format.integer_output_format.minimum_output_digits < 1 THEN
        i#move (p_program_variable, ^integer_number, program_variable_length);
        IF integer_number = 0 THEN
          p_screen_variable^ (1, screen_variable_length) := ' ';
          RETURN;
        IFEND;
      ELSE

{ Format output to obtain minimum number of digits.

        FOR scan_index := 1 TO
             output_format.integer_output_format.minimum_output_digits  DO
             text_index := screen_variable_length - scan_index + 1;
          IF p_screen_variable^ (text_index, 1) = ' ' THEN
            p_screen_variable^ (text_index, 1) := '0';

{ Shift minus or plus sign to left to obtain specified number of digits.

          ELSEIF p_screen_variable^ (text_index, 1) = '-' THEN
            IF (text_index > 1) THEN
              p_screen_variable^ (text_index - 1, 1) := '-';
              p_screen_variable^ (text_index, 1) := '0';
            ELSE
              error := mle$loss_of_significance;
              check_error;
              RETURN;
            IFEND;

          ELSEIF p_screen_variable^ (text_index, 1) = '+' THEN
            IF (text_index > 1) THEN
              p_screen_variable^ (text_index - 1, 1) := '+';
              p_screen_variable^ (text_index, 1) := '0';
            ELSE
              error := mle$loss_of_significance;
              check_error;
              RETURN;
            IFEND;
          IFEND;
        FOREND;
      IFEND;

    = fdc$f_output_format =
      IF output_format.float_output_format.suppress_zero THEN
        i#move (p_program_variable, ^real_number, program_variable_length);
        IF real_number = 0.0 THEN
          p_screen_variable^ (1, screen_variable_length) := ' ';
          RETURN;
        IFEND;
      IFEND;

      screen_format.justification := mlc$right_justify;
      screen_format.sign := output_format.float_output_format.sign_treatment;
      screen_format.format := mlc$f_style;
      screen_format.scale_factor := 0;
      screen_format.width := output_format.float_output_format.field_width;
      screen_format.digits := output_format.float_output_format.digits_right_decimal;
      screen_format.exponent_character := fdc$system_exponent_character;
      screen_format.exponent_style := 0;
      mlp$output_floating_number (p_program_variable, mlc$single_precision, p_screen_variable, screen_format,
            string_length, error);
      check_error;

    = fdc$e_output_format =
      IF output_format.float_output_format.suppress_zero THEN
        i#move (p_program_variable, ^real_number, program_variable_length);
        IF real_number = 0.0 THEN
          p_screen_variable^ (1, screen_variable_length) := ' ';
          RETURN;
        IFEND;
      IFEND;

      screen_format.justification := mlc$right_justify;
      screen_format.sign := output_format.float_output_format.sign_treatment;
      screen_format.format := mlc$e_style;
      screen_format.scale_factor := 0;
      screen_format.width := output_format.float_output_format.field_width;
      screen_format.digits := output_format.float_output_format.digits_right_decimal;
      screen_format.exponent_character := fdc$system_exponent_character;
      screen_format.exponent_style := 0;
      mlp$output_floating_number (p_program_variable, mlc$single_precision, p_screen_variable, screen_format,
            string_length, error);
      check_error;

    = fdc$g_output_format =
      IF output_format.float_output_format.suppress_zero THEN
        i#move (p_program_variable, ^real_number, program_variable_length);
        IF real_number = 0.0 THEN
          p_screen_variable^ (1, screen_variable_length) := ' ';
          RETURN;
        IFEND;
      IFEND;

      screen_format.justification := mlc$right_justify;
      screen_format.sign := output_format.float_output_format.sign_treatment;
      screen_format.format := mlc$g_style;
      screen_format.scale_factor := 0;
      screen_format.width := output_format.float_output_format.field_width;
      screen_format.digits := output_format.float_output_format.digits_right_decimal;
      screen_format.exponent_character := fdc$system_exponent_character;
      screen_format.exponent_style := 0;
      mlp$output_floating_number (p_program_variable, mlc$single_precision, p_screen_variable, screen_format,
            string_length, error);
      check_error;

    = fdc$e_e_output_format =
      IF output_format.exponent_output_format.suppress_zero THEN
        i#move (p_program_variable, ^real_number, program_variable_length);
        IF real_number = 0.0 THEN
          p_screen_variable^ (1, screen_variable_length) := ' ';
          RETURN;
        IFEND;
      IFEND;
      screen_format.justification := mlc$right_justify;
      screen_format.sign := output_format.exponent_output_format.sign_treatment;
      screen_format.format := mlc$e_style;
      screen_format.scale_factor := 0;
      screen_format.width := output_format.exponent_output_format.field_width;
      screen_format.digits := output_format.exponent_output_format.digits_right_decimal;
      screen_format.exponent_character := fdc$system_exponent_character;
      screen_format.exponent_style := output_format.exponent_output_format.digits_in_exponent;
      mlp$output_floating_number (p_program_variable, mlc$single_precision, p_screen_variable, screen_format,
            string_length, error);
      check_error;

    = fdc$g_e_output_format =
      screen_format.justification := mlc$right_justify;
      screen_format.sign := output_format.exponent_output_format.sign_treatment;
      screen_format.format := mlc$g_style;
      screen_format.scale_factor := 0;
      screen_format.width := output_format.exponent_output_format.field_width;
      screen_format.digits := output_format.exponent_output_format.digits_right_decimal;
      screen_format.exponent_character := fdc$system_exponent_character;
      screen_format.exponent_style := output_format.exponent_output_format.digits_in_exponent;
      mlp$output_floating_number (p_program_variable, mlc$single_precision, p_screen_variable, screen_format,
            string_length, error);
      check_error;

    ELSE

{ Invalid output format key.

     variable_status := fdc$invalid_bdp_data;
     p_screen_variable^ := '*';
    CASEND;

  PROCEND fdp$convert_to_screen_variable;

?? TITLE := 'fdp$convert_yymmdd_to_date_time', EJECT ??
*copyc fdh$convert_yymmdd_to_date_time

  PROCEDURE [XDCL] fdp$convert_yymmdd_to_date_time
    (    yymmdd: integer;
     VAR date_time: clt$date_time;
     VAR variable_status: fdt$variable_status);

    VAR
      day: integer,
      local_status: ost$status,
      month: integer,
      year: integer;


    variable_status := fdc$no_error;
    IF yymmdd = 0 THEN
      date_time.date_specified := FALSE;
      date_time.time_specified := FALSE;
      RETURN;
    IFEND;
    year := yymmdd DIV 10000;
    month := (yymmdd MOD 10000) DIV 100;
    day := yymmdd MOD 100;

    IF (year < 0) OR (year > 99) OR (month < 1) OR (month > 12) OR (day < 1) OR (day > 31) THEN
      variable_status := fdc$invalid_integer;
      RETURN;
    IFEND;

    date_time.value.year := year;
    date_time.value.month := month;
    date_time.value.day := day;
    date_time.value.hour := 0;
    date_time.value.minute := 0;
    date_time.value.second := 0;
    date_time.value.millisecond := 0;
    date_time.date_specified := TRUE;
    date_time.time_specified := TRUE;

    clp$validate_date_time (date_time, '', local_status);
    IF NOT local_status.normal THEN
      variable_status := fdc$invalid_integer;
    IFEND;

  PROCEND fdp$convert_yymmdd_to_date_time;

?? TITLE := 'fdp$create_form_status', EJECT ??
*copyc fdh$create_form_status

  PROCEDURE [XDCL] fdp$create_form_status
    (VAR form_identifier: fdt$form_identifier;
     VAR p_form_status: ^fdt$form_status;
     VAR status: ost$status);

    VAR
      i: fdt$form_identifier,
      j: fdt$form_identifier,
      local_status: ost$status,
      message_status: ost$status,
      p_status_message: ^ost$status_message,
      p_status_message_line_count: ^ost$status_message_line_count,
      p_status_message_line_size: ^ost$status_message_line_size,
      p_status_message_text: ^string ( * ),
      p_old_forms_status: ^fdt$forms_status,
      status_message: ost$status_message,
      status_message_line_size: [STATIC] ost$max_status_message_line := fdc$message_variable_length;

?? NEWTITLE := 'initialize_form_status', EJECT ??

    PROCEDURE initialize_form_status;

      p_form_status^.active_form_object_statuses := 0;
      p_form_status^.added := FALSE;
      p_form_status^.changed_variable_search.status := fdc$not_searched;
      p_form_status^.combined := FALSE;
      p_form_status^.design_form := FALSE;
      p_form_status^.displayed_on_screen := FALSE;
      p_form_status^.defined_dynamically := FALSE;
      p_form_status^.entry_used := TRUE;
      p_form_status^.events_active := FALSE;
      p_form_status^.field_number_defined := FALSE;
      p_form_status^.graphic_identifier_defined := FALSE;
      p_form_status^.input_error_search.status := fdc$not_searched;
      p_form_status^.invalid_data_character.defined := FALSE;
      p_form_status^.last_cursor_position_valid := FALSE;
      p_form_status^.mark_defined := FALSE;
      p_form_status^.event_form_defined := FALSE;
      p_form_status^.fast_form_creation := FALSE;
      p_form_status^.opened := FALSE;
      p_form_status^.opened_for_query_only := FALSE;
      p_form_status^.output_error_search.status := fdc$not_searched;
      p_form_status^.owned_by_system := FALSE;
      p_form_status^.p_form_event_statuses := NIL;
      p_form_status^.p_form_image := NIL;
      p_form_status^.p_form_object_statuses := NIL;
      p_form_status^.p_form_table_statuses := NIL;
      p_form_status^.p_program_record := NIL;
      p_form_status^.p_screen_record := NIL;
      p_form_status^.push_count := 0;
      p_form_status^.storage_allocated := FALSE;
      p_form_status^.total_form_object_statuses := 0;
    PROCEND initialize_form_status;

?? OLDTITLE ??

    status.normal := TRUE;
    IF fdv$screen_status.p_forms_status = NIL THEN

{ Create the initial array for form  status.

      ALLOCATE fdv$screen_status.p_forms_status: [1 .. fdc$forms_to_expand];
      IF fdv$screen_status.p_forms_status = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

      form_identifier := 1;
      p_form_status := ^fdv$screen_status.p_forms_status^ [1];
      FOR i := 2 TO fdc$forms_to_expand DO
        fdv$screen_status.p_forms_status^ [i].entry_used := FALSE;
      FOREND;

{ Allocate initial array for screen changes.

      ALLOCATE fdv$screen_status.p_screen_changes: [1 .. fdc$screen_changes_to_expand];
      IF fdv$screen_status.p_screen_changes = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;
      fdv$screen_status.number_screen_changes := 0;
      initialize_form_status;
    IFEND;

{ An array for form status exists. Try to use an existing record.

    FOR i := 1 TO UPPERBOUND (fdv$screen_status.p_forms_status^) DO
      IF (NOT fdv$screen_status.p_forms_status^ [i].entry_used) THEN
        form_identifier := i;
        p_form_status := ^fdv$screen_status.p_forms_status^ [i];
        initialize_form_status;
        RETURN;
      IFEND;
    FOREND;

{ No current records are inactive. Allocate a bigger array.

    p_old_forms_status := fdv$screen_status.p_forms_status;
    i := UPPERBOUND (fdv$screen_status.p_forms_status^);
    ALLOCATE fdv$screen_status.p_forms_status: [1 .. i + fdc$forms_to_expand];
    IF fdv$screen_status.p_forms_status = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
      fdv$screen_status.p_forms_status := p_old_forms_status;
      RETURN;
    IFEND;

{ Move form status to new array.

    FOR j := 1 TO i DO
      fdv$screen_status.p_forms_status^ [j] := p_old_forms_status^ [j];
    FOREND;

{ Assign an entry for the new form.

    i := i + 1;
    form_identifier := i;
    p_form_status := ^fdv$screen_status.p_forms_status^ [i];

{ Mark unused entries in new array.

    FOR j := (i + 1) TO UPPERBOUND (fdv$screen_status.p_forms_status^) DO
      fdv$screen_status.p_forms_status^ [j].entry_used := FALSE;
    FOREND;
    initialize_form_status;
  PROCEND fdp$create_form_status;

?? TITLE := 'fdp$delete_form', EJECT ??
*copyc fdh$delete_form

  PROCEDURE [XDCL] fdp$delete_form
    (    form_identifier: fdt$form_identifier;
     VAR status: ost$status);

    VAR
      current_form_identifier: fdt$current_form_identifier,
      event_form_identifier: fdt$form_identifier,
      form_added: boolean,
      local_status: ost$status,
      p_delete_form_status: ^fdt$form_status,
      p_form_status: ^fdt$form_status,
      screen_change: fdt$screen_change;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$delete_form;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$delete_form;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$check_for_active_form (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ A delete of a form may mean that the screen size of the terminal
{ may be made smaller. Screen Formatting tries to use the largest
{ characters on the terminal screen as possible.

    fdv$screen_status.compute_new_screen_size := TRUE;
    p_form_status^.added := FALSE;
    p_form_status^.combined := FALSE;

{ If cursor is positioned in deleted form, a new cursor position needs
{ to be computed on the next screen update.

    IF ((fdv$screen_status.last_cursor_position_valid) AND
          (fdv$screen_status.last_cursor_form_identifier = form_identifier)) THEN
      fdv$screen_status.last_cursor_position_valid := FALSE;
    IFEND;

{ Delete any associated event form.
{ Ignore errors since the user may have already deleted the event form.

    IF p_form_status^.event_form_defined THEN
      event_form_identifier := p_form_status^.event_form_identifier;
      fdp$delete_form (event_form_identifier, local_status);
    IFEND;

{ Remove form from list giving the priority of forms on the screen.

    update_form_priorities (p_form_status);
    fdp$delete_screen_changes (form_identifier, form_added);

    IF NOT form_added THEN

{ Record delete of form on screen.

      screen_change.key := fdc$delete_form;
      screen_change.form_identifier := form_identifier;
      screen_change.form_x_position := p_form_status^.form_x_position;
      screen_change.form_y_position := p_form_status^.form_y_position;
      fdp$record_screen_change (screen_change, status);
    IFEND;

{ Delete any forms combined with this form.

    current_form_identifier := fdv$screen_status.current_form_identifier;
    WHILE current_form_identifier <> 0 DO
      p_delete_form_status := ^fdv$screen_status.p_forms_status^ [current_form_identifier];
      IF p_delete_form_status^.entry_used THEN
        IF p_delete_form_status^.combined THEN
          IF p_delete_form_status^.added_form_identifier = form_identifier THEN
            fdp$delete_form (p_delete_form_status^.added_form_identifier, local_status);
          IFEND;
        IFEND;
      IFEND;
      current_form_identifier := p_delete_form_status^.next_lower_form;
    WHILEND;


  PROCEND fdp$delete_form;

?? TITLE := 'fdp$delete_screen_changes', EJECT ??
*copyc fdh$delete_screen_changes

  PROCEDURE [XDCL] fdp$delete_screen_changes
    (    form_identifier: fdt$form_identifier;
     VAR form_added: boolean);

    VAR
      n: integer,
      p_screen_change: ^fdt$screen_change;

    form_added := FALSE;

{ Delete any previous changes to the screen that now do not apply.

    FOR n := 1 TO fdv$screen_status.number_screen_changes DO
      p_screen_change := ^fdv$screen_status.p_screen_changes^ [n];
      CASE p_screen_change^.key OF

      = fdc$add_form =
        IF p_screen_change^.form_identifier = form_identifier THEN

{ An add and a delete of the same form with the same screen ordering on the
{ same screen update
{ should result in no screen changes.

          form_added := TRUE;
          p_screen_change^.key := fdc$no_screen_change;
        IFEND;

      = fdc$change_table_size =
        IF p_screen_change^.table_form_identifier = form_identifier THEN
          p_screen_change^.key := fdc$no_screen_change;
        IFEND;

      = fdc$delete_form =
        IF p_screen_change^.form_identifier = form_identifier THEN
          IF fdv$screen_status.p_forms_status^ [form_identifier].displayed_on_screen THEN
            p_screen_change^.key := fdc$erase_form;
          ELSE
            p_screen_change^.key := fdc$no_screen_change;
          IFEND;
        IFEND;

      = fdc$add_object, fdc$delete_object =
        IF p_screen_change^.object_form_identifier = form_identifier THEN
          p_screen_change^.key := fdc$no_screen_change;
        IFEND;

      = fdc$create_mark =
        IF p_screen_change^.create_mark_form_identifier = form_identifier THEN
          p_screen_change^.key := fdc$no_screen_change;
        IFEND;

      = fdc$delete_mark =
        IF p_screen_change^.delete_mark_form_identifier = form_identifier THEN
          p_screen_change^.key := fdc$no_screen_change;
        IFEND;

      = fdc$replace_variable =
        IF p_screen_change^.variable_form_identifier = form_identifier THEN
          p_screen_change^.key := fdc$no_screen_change;
        IFEND;

      = fdc$set_attribute =
        IF p_screen_change^.attribute_form_identifier = form_identifier THEN
          p_screen_change^.key := fdc$no_screen_change;
        IFEND;

      = fdc$set_cursor =
        IF p_screen_change^.cursor_form_identifier = form_identifier THEN
          p_screen_change^.key := fdc$no_screen_change;
        IFEND;

      ELSE { Ignore other screen changes.}
      CASEND;
    FOREND;
  PROCEND fdp$delete_screen_changes;

?? TITLE := 'fdp$get_integer_variable', EJECT ??
*copyc fdh$get_integer_variable

  PROCEDURE [XDCL] fdp$get_integer_variable
    (    form_identifier: fdt$form_identifier;
         name: ost$name;
         occurrence: fdt$occurrence;
     VAR variable: integer;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    VAR
      object_exists: boolean,
      object_index: fdt$object_index,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_status: ^fdt$form_status,
      p_program_record: ^cell,
      program_record_position: fdt$record_position,
      screen_record_position: fdt$record_position,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_integer_variable;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_integer_variable;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    #translate (osv$lower_to_upper, name, valid_name);
    find_record_variable (p_form_status, valid_name, occurrence, p_form_variable_definition, object_exists,
          object_index, program_record_position, screen_record_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT (p_form_variable_definition^.program_data_type = fdc$program_integer_type) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$wrong_variable_type, 'INTEGER', status);
      RETURN;
    IFEND;

    variable_status := p_form_status^.p_form_object_statuses^ [object_index].variable_input_status;
    IF variable_status = fdc$no_error THEN
      p_program_record := ^p_form_status^.p_program_record^ [program_record_position];
      i#move (p_program_record, ^variable, fdc$integer_length);
    IFEND;

  PROCEND fdp$get_integer_variable;

?? TITLE := 'fdp$get_next_changed_variable', EJECT ??
*copyc fdh$get_next_changed_variable

{ DESIGN:
{   Each variable object that has been changed by the terminal user is assigned an index corresponding to
{   instance of Read Forms that changed the field.  Indices that match the current index were changed by the
{   last execution of Read Forms.
{ NOTE:
{   Any field that the terminal user has typed in is flagged as 'changed' even if the contents were not
{   altered.  The check for an actual change is not made because of performance reasons.
{

  PROCEDURE [XDCL] fdp$get_next_changed_variable
    (    form_identifier: fdt$form_identifier;
     VAR variable_name: ost$name;
     VAR occurrence: fdt$occurrence;
     VAR change_found: boolean;
     VAR status: ost$status);

    VAR
      object_index: fdt$object_index,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_form_status: ^fdt$form_status,
      start_object_index: fdt$object_index;
?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_next_changed_variable;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_next_changed_variable;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    variable_name := '';
    change_found := FALSE;

    fdp$find_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_form_status^.push_count <> 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_pushed,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    CASE p_form_status^.changed_variable_search.status OF
    = fdc$searching =

{ Continue search after the last changed variable that was found.

      IF p_form_status^.changed_variable_search.object_index < UPPERBOUND (p_form_object_statuses^) THEN
        start_object_index := p_form_status^.changed_variable_search.object_index + 1;
      ELSE

{ Must be at the end of the object list.

        p_form_status^.changed_variable_search.status := fdc$search_completed;
        RETURN;
      IFEND;

    = fdc$not_searched =
      start_object_index := 1;

    ELSE  { fdc$search_completed

{ No changes left to find.

      RETURN;
    CASEND;

    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;

    FOR object_index := start_object_index TO UPPERBOUND (p_form_object_statuses^) DO
      CASE p_form_object_definitions^ [object_index].key OF
      = fdc$form_stored_variable, fdc$form_variable_text, fdc$form_variable_text_box =
        IF p_form_object_statuses^ [object_index].changed_by_read_forms_index =
              fdv$screen_status.read_forms_index THEN

{ Variable object was changed during the last execution of Read Forms.

          p_form_status^.changed_variable_search.status := fdc$searching;
          p_form_status^.changed_variable_search.object_index := object_index;
          variable_name := p_form_object_definitions^ [object_index].name;
          occurrence := p_form_object_definitions^ [object_index].occurrence;
          change_found := TRUE;
          RETURN;
        IFEND;
      ELSE
      CASEND;
    FOREND;

{ There are no more changes left to find.

    p_form_status^.changed_variable_search.status := fdc$search_completed;

  PROCEND fdp$get_next_changed_variable;
?? TITLE := 'fdp$get_next_event', EJECT ??
*copyc fdh$get_next_event

  PROCEDURE [XDCL] fdp$get_next_event
    (VAR event_name: ost$name;
     VAR event_normal: boolean;
     VAR event_position: fdt$event_position;
     VAR last_event: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_next_event;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_next_event;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    event_name := fdv$screen_status.event_name;
    event_normal := fdv$screen_status.event_normal;
    event_position := fdv$screen_status.event_position;
    last_event := TRUE;
  PROCEND fdp$get_next_event;

?? TITLE := 'fdp$get_next_input_error', EJECT ??
*copyc fdh$get_next_input_error

  PROCEDURE [XDCL] fdp$get_next_input_error
    (    form_identifier: fdt$form_identifier;
     VAR variable_name: ost$name;
     VAR occurrence: fdt$occurrence;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    VAR
      p_form_status: ^fdt$form_status,
      start_object_index: fdt$object_index;
?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_next_input_error;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_next_input_error;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    variable_name := '';
    variable_status := fdc$no_error;

    fdp$find_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_form_status^.push_count <> 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_pushed,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    CASE p_form_status^.input_error_search.status OF
    = fdc$searching =

{ Continue search after the last error found.

      IF p_form_status^.input_error_search.object_index < UPPERBOUND (p_form_status^.p_form_object_statuses^)
            THEN
        start_object_index := p_form_status^.input_error_search.object_index + 1;
      ELSE

{ Must be at end of object list.

        p_form_status^.input_error_search.status := fdc$search_completed;
        RETURN;
      IFEND;

    = fdc$not_searched =
      start_object_index := 1;
    = fdc$search_completed =

{ No errors left to find.

      RETURN;
    ELSE { fdc$search_not_allowed
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unexpected_call_to,
            'Get Next Input Error', status);

      RETURN;
    CASEND;

    find_next_input_error (p_form_status, start_object_index, variable_name, occurrence, variable_status);

  PROCEND fdp$get_next_input_error;
?? TITLE := 'fdp$get_next_output_error', EJECT ??
*copyc fdh$get_next_output_error

  PROCEDURE [XDCL] fdp$get_next_output_error
    (    form_identifier: fdt$form_identifier;
     VAR variable_name: ost$name;
     VAR occurrence: fdt$occurrence;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    VAR
      object_index: fdt$object_index,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_form_status: ^fdt$form_status,
      start_object_index: fdt$object_index;
?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_next_output_error;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_next_output_error;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    variable_name := '';
    variable_status := fdc$no_error;

    fdp$find_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_form_status^.push_count <> 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_pushed,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;

    CASE p_form_status^.output_error_search.status OF
    = fdc$searching =

{ Continue search after the last error found.

      IF p_form_status^.output_error_search.object_index < UPPERBOUND (p_form_object_statuses^) THEN
        start_object_index := p_form_status^.output_error_search.object_index + 1;
      ELSE

{ Must be at end of object list.

        p_form_status^.output_error_search.status := fdc$search_completed;
        RETURN;
      IFEND;

    = fdc$not_searched =
      start_object_index := 1;
    = fdc$search_completed =

{ No errors left to find.

      RETURN;
    ELSE { fdc$search_not_allowed
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unexpected_call_to,
            'Get Next Output Error', status);
      RETURN;
    CASEND;

    FOR object_index := start_object_index TO UPPERBOUND (p_form_object_statuses^) DO
      CASE p_form_object_definitions^ [object_index].key OF
      = fdc$form_stored_variable, fdc$form_variable_text, fdc$form_variable_text_box =
        IF p_form_object_statuses^ [object_index].variable_output_status <> fdc$no_error THEN
          p_form_status^.output_error_search.status := fdc$searching;
          p_form_status^.output_error_search.object_index := object_index;
          variable_name := p_form_object_definitions^ [object_index].name;
          occurrence := p_form_object_definitions^ [object_index].occurrence;
          variable_status := p_form_object_statuses^ [object_index].variable_output_status;
          RETURN;
        IFEND;
      ELSE
      CASEND;
    FOREND;

    p_form_status^.output_error_search.status := fdc$search_completed;

  PROCEND fdp$get_next_output_error;
?? TITLE := 'fdp$get_number_of_occurrences', EJECT ??
*copyc fdh$get_number_of_occurrences

  PROCEDURE [XDCL] fdp$get_number_of_occurrences
    (    form_identifier: fdt$form_identifier;
         variable_name: ost$name;
     VAR table_member: boolean;
     VAR occurrences: fdt$occurrence;
     VAR status: ost$status);

    VAR
      object_exists: boolean,
      object_index: fdt$object_index,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_status: ^fdt$form_status,
      program_record_position: fdt$record_position,
      screen_record_position: fdt$record_position,
      screen_variable_length: fdt$text_length,
      table_index: fdt$table_index,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_number_of_occurrences;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_number_of_occurrences;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;

    fdp$find_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    #translate (osv$lower_to_upper, variable_name, valid_name);
    find_record_variable (p_form_status, valid_name, 1, p_form_variable_definition, object_exists,
          object_index, program_record_position, screen_record_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_form_variable_definition^.table_exists THEN
      table_member := TRUE;
      table_index := p_form_variable_definition^.table_index;
      occurrences := p_form_status^.p_form_table_definitions^ [table_index].stored_occurrence;
    ELSE
      table_member := FALSE;
      occurrences := 1;
    IFEND;

  PROCEND fdp$get_number_of_occurrences;

?? TITLE := 'fdp$get_real_variable', EJECT ??
*copyc fdh$get_real_variable

  PROCEDURE [XDCL] fdp$get_real_variable
    (    form_identifier: fdt$form_identifier;
         name: ost$name;
         occurrence: fdt$occurrence;
     VAR variable: real;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    VAR
      object_exists: boolean,
      object_index: fdt$object_index,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_status: ^fdt$form_status,
      p_program_record: ^cell,
      program_record_position: fdt$record_position,
      screen_record_position: fdt$record_position,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_real_variable;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_real_variable;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    #translate (osv$lower_to_upper, name, valid_name);
    find_record_variable (p_form_status, valid_name, occurrence, p_form_variable_definition, object_exists,
          object_index, program_record_position, screen_record_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT (p_form_variable_definition^.program_data_type = fdc$program_real_type) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$wrong_variable_type, 'REAL', status);
      RETURN;
    IFEND;

    variable_status := p_form_status^.p_form_object_statuses^ [object_index].variable_input_status;
    IF variable_status = fdc$no_error THEN
      p_program_record := ^p_form_status^.p_program_record^ [program_record_position];
      i#move (p_program_record, ^variable, fdc$real_length);
    IFEND;

  PROCEND fdp$get_real_variable;

?? TITLE := 'fdp$get_record', EJECT ??
*copyc fdh$get_record

  PROCEDURE [XDCL] fdp$get_record
    (    form_identifier: fdt$form_identifier;
         p_work_area: ^cell;
         work_area_length: fdt$work_area_length;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    VAR
      ignore_occurrence: fdt$occurrence,
      ignore_variable_name: ost$name,
      p_form_status: ^fdt$form_status,
      p_program_record: ^array [1 .. * ] of cell,
      p_user_record: ^cell,
      program_record_position: fdt$record_position,
      record_offset: integer,
      user_offset: integer,
      user_record_length: integer,
      user_ring: integer,
      user_segment: integer;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_record;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_record;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Validate that user work area can  hold  the  record.

    IF p_form_status^.p_form_record_definitions = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_has_no_variables,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF work_area_length <> #SIZE (p_form_status^.p_program_record^) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$work_area_invalid,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    p_program_record := p_form_status^.p_program_record;

{ Check for any input errors.

    find_next_input_error (p_form_status, 1, ignore_variable_name, ignore_occurrence, variable_status);
    IF variable_status <> fdc$no_error THEN

{ Reset the search status so later calls to fdp$get_next_input_error will find the first error.

      p_form_status^.input_error_search.status := fdc$not_searched;
      RETURN;
    IFEND;

{ Move Screen Formatting record to user record.

    user_record_length := work_area_length;
    p_user_record := p_work_area;
    user_ring := #ring (p_work_area);
    user_segment := #segment (p_work_area);
    user_offset := #offset (p_work_area);
    record_offset := user_offset;
    program_record_position := 1;

    /move_record/
    WHILE TRUE DO
      p_user_record := #ADDRESS (user_ring, user_segment, record_offset);
      IF user_record_length > cyc$max_string_size THEN
        i#move (^p_program_record^ [program_record_position], p_user_record, cyc$max_string_size);
        record_offset := record_offset + cyc$max_string_size;
        program_record_position := program_record_position + cyc$max_string_size;
        user_record_length := user_record_length - cyc$max_string_size;
      ELSE
        i#move (^p_program_record^ [program_record_position], p_user_record, user_record_length);
        EXIT /move_record/;
      IFEND;
    WHILEND /move_record/;

  PROCEND fdp$get_record;

?? TITLE := 'fdp$get_screen_variable', EJECT ??
*copyc fdh$get_screen_variable

  PROCEDURE [XDCL] fdp$get_screen_variable
    (    form_identifier: fdt$form_identifier;
         name: ost$name;
         occurrence: fdt$occurrence;
     VAR screen_variable: fdt$text;
     VAR status: ost$status);

    VAR
      program_record_position: fdt$record_position,
      object_exists: boolean,
      object_index: fdt$object_index,
      p_form_object_status: ^fdt$form_object_status,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_status: ^fdt$form_status,
      p_screen_variable: ^fdt$text,
      screen_record_position: fdt$record_position,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_screen_variable;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_screen_variable;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    #TRANSLATE (osv$lower_to_upper, name, valid_name);
    find_record_variable (p_form_status, valid_name, occurrence, p_form_variable_definition, object_exists,
          object_index, program_record_position, screen_record_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_object_status := ^p_form_status^.p_form_object_statuses^ [object_index];
    p_form_object_status^.variable_input_status := fdc$no_error;
    fdp$ptr_screen_variable (p_form_status^.p_screen_record, screen_record_position,
          p_form_variable_definition^.screen_variable_length, p_screen_variable);
    screen_variable := p_screen_variable^;

  PROCEND fdp$get_screen_variable;
?? TITLE := 'fdp$get_string_variable', EJECT ??
*copyc fdh$get_string_variable

  PROCEDURE [XDCL] fdp$get_string_variable
    (    form_identifier: fdt$form_identifier;
         name: ost$name;
         occurrence: fdt$occurrence;
     VAR variable: fdt$text;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    VAR
      error: mlt$error,
      defined_variable_length: fdt$program_variable_length,
      object_exists: boolean,
      object_index: fdt$object_index,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_status: ^fdt$form_status,
      p_program_record: ^cell,
      program_record_position: fdt$record_position,
      program_variable_length: fdt$program_variable_length,
      screen_record_position: fdt$record_position,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_string_variable;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_string_variable;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    #translate (osv$lower_to_upper, name, valid_name);
    find_record_variable (p_form_status, valid_name, occurrence, p_form_variable_definition, object_exists,
          object_index, program_record_position, screen_record_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT ((p_form_variable_definition^.program_data_type = fdc$program_character_type) OR
          (p_form_variable_definition^.program_data_type = fdc$program_upper_case_type)) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$wrong_variable_type,
            'CHARACTER or UPPER_CASE', status);
      RETURN;
    IFEND;

    program_variable_length := STRLENGTH (variable);
    defined_variable_length := p_form_variable_definition^.program_variable_length;
    variable_status := p_form_status^.p_form_object_statuses^ [object_index].variable_input_status;
    IF variable_status = fdc$no_error THEN
      p_program_record := ^p_form_status^.p_program_record^ [program_record_position];
      mlp$move_bytes (p_program_record, defined_variable_length, ^variable, program_variable_length, error);
      IF defined_variable_length > program_variable_length THEN
        variable_status := fdc$variable_truncated;
      IFEND;
    IFEND;

  PROCEND fdp$get_string_variable;

?? TITLE := 'fdp$initialize_form_objects', EJECT ??
*copy fdh$initialize_form_objects

  PROCEDURE [XDCL] fdp$initialize_form_objects
    (    form_identifier: fdt$form_identifier;
         p_form_status: ^fdt$form_status;
         record_changes: boolean;
     VAR status: ost$status);

    VAR
      display_attribute_set: fdt$display_attribute_set,
      first_displayed_occurrence: fdt$occurrence,
      fragment_object_index: fdt$object_index,
      input: boolean,
      object_index: fdt$object_index,
      output: boolean,
      next_object_index: fdt$object_index,
      number_objects: fdt$number_objects,
      p_form_definition: ^fdt$form_definition,
      p_form_module: ^fdt$form_module,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_form_table_definitions: ^array [1 .. * ] of fdt$form_table_definition,
      p_form_table_statuses: ^array [1 .. * ] of fdt$table_status,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_variable_definitions: ^array [1 .. * ] of fdt$form_variable_definition,
      p_text: ^fdt$text;

    status.normal := TRUE;
    p_form_module := p_form_status^.p_form_module;
    number_objects := p_form_status^.p_form_definition^.form_object_definitions.active_number;
    p_form_definition := p_form_status^.p_form_definition;
    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    p_form_table_definitions := p_form_status^.p_form_table_definitions;
    p_form_table_statuses := p_form_status^.p_form_table_statuses;
    p_form_variable_definitions := p_form_status^.p_form_variable_definitions;

{ Initialize display attributes and data character position.

    FOR object_index := 1 TO number_objects DO
      p_form_object_definition := ^p_form_object_definitions^ [object_index];
      CASE p_form_object_definition^.key OF

      = fdc$form_box =
        IF record_changes THEN
          record_attribute_change (form_identifier, object_index,
                p_form_object_definition^.display_attribute,
                p_form_object_statuses^ [object_index].display_attribute_set, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        p_form_object_statuses^ [object_index].display_attribute_set :=
              p_form_object_definition^.display_attribute;

      = fdc$form_constant_text =
        IF record_changes THEN
          record_attribute_change (form_identifier, object_index,
                p_form_object_definition^.display_attribute,
                p_form_object_statuses^ [object_index].display_attribute_set, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          p_text := fdp$ptr_text (p_form_object_definition^.constant_text,
              p_form_status^.p_form_module);
          record_value_change (form_identifier, object_index, p_text, p_form_object_statuses, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        p_form_object_statuses^ [object_index].display_attribute_set :=
              p_form_object_definition^.display_attribute;
        p_form_object_statuses^ [object_index].character_position := 1;
        p_form_object_statuses^ [object_index].user_changed_field := FALSE;
        p_form_object_statuses^ [object_index].user_entered_field := TRUE;

      = fdc$form_constant_text_box =
        IF record_changes THEN
          record_attribute_change (form_identifier, object_index,
                p_form_object_definition^.display_attribute,
                p_form_object_statuses^ [object_index].display_attribute_set, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          p_text := fdp$ptr_text (p_form_object_definition^.constant_box_text,
              p_form_status^.p_form_module);
          record_value_change (form_identifier, object_index, p_text, p_form_object_statuses, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        p_form_object_statuses^ [object_index].display_attribute_set :=
              p_form_object_definition^.display_attribute;
        p_form_object_statuses^ [object_index].character_position := 1;
        p_form_object_statuses^ [object_index].user_changed_field := FALSE;
        p_form_object_statuses^ [object_index].user_entered_field := TRUE;

        fragment_object_index := p_form_object_definition^.constant_box_fragment_index;
        WHILE fragment_object_index <> 0 DO
          p_form_object_statuses^ [fragment_object_index].display_attribute_set :=
                p_form_object_definition^.display_attribute;
          p_form_object_statuses^ [fragment_object_index].character_position := 1;
          p_form_object_statuses^ [object_index].user_changed_field := FALSE;
        p_form_object_statuses^ [object_index].user_entered_field := TRUE;
          fragment_object_index := p_form_object_definitions^ [fragment_object_index].
                next_fragment_object_index;
        WHILEND;

      = fdc$form_line =
        IF record_changes THEN
          record_attribute_change (form_identifier, object_index,
                p_form_object_definition^.display_attribute,
                p_form_object_statuses^ [object_index].display_attribute_set, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        p_form_object_statuses^ [object_index].display_attribute_set :=
              p_form_object_definition^.display_attribute;

      = fdc$form_table =
        IF record_changes THEN
          record_attribute_change (form_identifier, object_index,
                p_form_object_definition^.display_attribute,
                p_form_object_statuses^ [object_index].display_attribute_set, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        p_form_object_statuses^ [object_index].display_attribute_set :=
              p_form_object_definition^.display_attribute;
        p_form_object_statuses^ [object_index].character_position := 1;
        p_form_object_statuses^ [object_index].user_changed_field := FALSE;
        p_form_object_statuses^ [object_index].user_entered_field := TRUE;

      = fdc$form_stored_variable =
        p_form_object_statuses^ [object_index].display_attribute_set :=
              p_form_object_definition^.display_attribute;
        p_form_object_statuses^ [object_index].user_changed_field := FALSE;
        p_form_object_statuses^ [object_index].user_entered_field := FALSE;
        p_form_object_statuses^ [object_index].character_position := 1;
        p_form_object_statuses^ [object_index].changed_by_read_forms_index := 0;

      = fdc$form_variable_text =
        p_form_object_statuses^ [object_index].display_attribute_set :=
              p_form_object_definition^.display_attribute;
        p_form_object_statuses^ [object_index].character_position := 1;
        p_form_object_statuses^ [object_index].user_changed_field := FALSE;
        p_form_object_statuses^ [object_index].user_entered_field := FALSE;
        p_form_object_statuses^ [object_index].changed_by_read_forms_index := 0;

      = fdc$form_variable_text_box =
        p_form_object_statuses^ [object_index].display_attribute_set :=
              p_form_object_definition^.display_attribute;
        p_form_object_statuses^ [object_index].character_position := 1;
        p_form_object_statuses^ [object_index].user_changed_field := FALSE;
        p_form_object_statuses^ [object_index].user_entered_field := FALSE;
        p_form_object_statuses^ [object_index].changed_by_read_forms_index := 0;

        fragment_object_index := p_form_object_definition^.variable_box_fragment_index;
        WHILE fragment_object_index <> 0 DO
          p_form_object_statuses^ [fragment_object_index].display_attribute_set :=
                p_form_object_definition^.display_attribute;
          p_form_object_statuses^ [fragment_object_index].character_position := 1;
          p_form_object_statuses^ [fragment_object_index].user_changed_field := FALSE;
          p_form_object_statuses^ [fragment_object_index].user_entered_field := FALSE;
          p_form_object_statuses^ [fragment_object_index].changed_by_read_forms_index := 0;
          fragment_object_index := p_form_object_definitions^ [fragment_object_index].
                next_fragment_object_index;
        WHILEND;

      ELSE

{ Ignore these objects.

      CASEND;
    FOREND;
  PROCEND fdp$initialize_form_objects;

?? TITLE := 'fdp$initialize_form_record', EJECT ??
*copy fdh$initialize_form_record

  PROCEDURE [XDCL] fdp$initialize_form_record
    (    form_identifier: fdt$form_identifier;
         p_form_status: ^fdt$form_status;
         record_change: boolean;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    VAR
      ignore_record_screen_change: boolean,
      initial_value: [READ, STATIC] string (1) := ' ',
      object_index: fdt$object_index,
      p_form_module: ^fdt$form_module,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_form_record_definitions: ^array [1 .. * ] of fdt$variable_record_definition,
      p_form_table_definition: ^fdt$form_table_definition,
      p_form_table_definitions: ^array [1 .. * ] of fdt$form_table_definition,
      p_form_table_statuses: ^array [1 .. * ] of fdt$table_status,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_old_screen_variable: ^fdt$text,
      p_program_record: ^array [1 .. * ] of cell,
      p_screen_variable: ^fdt$text,
      p_table_object: ^fdt$table_object,
      p_table_objects: ^array [1 .. * ] of fdt$table_object,
      p_table_variable: ^fdt$table_variable,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable,
      p_text: ^fdt$text,
      p_variable_record_definition: ^fdt$variable_record_definition,
      p_work_area: ^cell,
      program_data_type: fdt$program_data_type,
      program_record_position: fdt$record_position,
      record_index: fdt$variable_index,
      program_variable_length: fdt$program_variable_length,
      screen_change: fdt$screen_change,
      screen_variable_length: fdt$text_length,
      table_index: fdt$table_index,
      table_object_index: fdt$object_index,
      text_length: fdt$text_length,
      variable_index: fdt$variable_index;

    status.normal := TRUE;
    variable_status := fdc$no_error;
    p_form_record_definitions := p_form_status^.p_form_record_definitions;

    IF p_form_record_definitions = NIL THEN
      RETURN;
    IFEND;

    p_form_table_definitions := p_form_status^.p_form_table_definitions;
    p_form_table_statuses := p_form_status^.p_form_table_statuses;
    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    p_program_record := p_form_status^.p_program_record;
    p_form_module := p_form_status^.p_form_module;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;

  /initialize_record/
    FOR record_index := 1 TO UPPERBOUND (p_form_record_definitions^) DO
      p_variable_record_definition := ^p_form_record_definitions^ [record_index];
      CASE p_variable_record_definition^.key OF

{ Initialize table in record.

      = fdc$record_table =
        table_index := p_variable_record_definition^.table_index;
        p_form_table_definition := ^p_form_table_definitions^ [table_index];
        IF NOT p_form_table_definition^.valid THEN
          CYCLE /initialize_record/;
        IFEND;

        p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
              p_form_module);

        /initialize_table_variables/
        FOR variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
          p_table_variable := ^p_table_variables^ [variable_index];
          p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                [p_table_variable^.variable_index];
          program_variable_length := p_form_variable_definition^.program_variable_length;
          program_data_type := p_form_variable_definition^.program_data_type;
          screen_variable_length := p_form_variable_definition^.screen_variable_length;
          p_table_objects := fdp$ptr_table_objects (p_table_variable^.table_objects, p_form_module);

          /initialize_variable_objects/
          FOR table_object_index := 1 TO p_form_table_definition^.stored_occurrence DO
            p_table_object := ^p_table_objects^ [table_object_index];
            program_record_position := p_table_object^.program_record_position;

            IF p_table_object^.object_exists THEN
              object_index := p_table_object^.object_index;
              p_form_object_definition := ^p_form_object_definitions^ [object_index];
              CASE p_form_object_definition^.key OF

              = fdc$form_variable_text =
                p_text := fdp$ptr_text (p_form_object_definition^.text_variable_text, p_form_module);

              = fdc$form_variable_text_box =
                p_text := fdp$ptr_text (p_form_object_definition^.variable_box_text, p_form_module);

              = fdc$form_stored_variable =
                p_text := fdp$ptr_text (p_form_object_definition^.stored_variable_text, p_form_module);

              ELSE

{ Invalid object.

                osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'invalid object',
                      status);
                RETURN;
              CASEND;

            ELSE
              p_text := ^initial_value;
            IFEND;

            p_work_area := ^p_program_record^ [program_record_position];
            fdp$ptr_screen_variable (p_form_status^.p_screen_record,
                  p_table_object^.screen_record_position, screen_variable_length, p_screen_variable);

{ Save old value if a screen change needs to be recorded.

            IF (record_change AND (table_object_index <=
                  p_form_table_definition^.visible_occurrence)) THEN
              ALLOCATE p_old_screen_variable: [screen_variable_length];
              IF p_old_screen_variable = NIL THEN
                osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
                RETURN;
              IFEND;
              p_old_screen_variable^ := p_screen_variable^;
            IFEND;

            p_screen_variable^ := p_text^;
            fdp$move_to_program_variable (p_form_status, p_form_variable_definition,
                   p_screen_variable, p_work_area, p_form_object_statuses^ [object_index].
                   variable_input_status, status);
            fdp$move_to_screen_variable (p_form_status, p_form_variable_definition,
                  p_work_area, p_screen_variable, variable_status, status);
            p_form_object_statuses^ [object_index].variable_output_status := variable_status;
            IF variable_status <> fdc$no_error THEN

{ The invalid data character must be substituted even if the field is not currently visible.  Subsequent
{ updates may cause the field to displayed before the error is corrected.

              display_invalid_data_character (p_form_status,
                    p_form_variable_definition^.screen_variable_length, ignore_record_screen_change,
                    p_screen_variable^);
            IFEND;

            IF NOT record_change THEN
              CYCLE /initialize_variable_objects/;
            IFEND;

            IF (table_object_index > p_form_table_definition^.visible_occurrence) THEN
              CYCLE /initialize_variable_objects/;
            IFEND;

            IF ((p_old_screen_variable^ <> p_screen_variable^) OR
                 (p_form_table_statuses^ [table_index].first_displayed_occurrence <> 1) OR
                 (p_form_object_statuses^ [object_index].character_position <> 1)) THEN
              screen_change.key := fdc$replace_variable;
              screen_change.variable_form_identifier := form_identifier;
              screen_change.variable_object_index := object_index;
              screen_change.p_text := p_screen_variable;
              fdp$record_screen_change (screen_change, status);
              IF NOT status.normal THEN
                FREE p_old_screen_variable;
                RETURN;
              IFEND;
            IFEND;

            FREE p_old_screen_variable;

            IF ((p_form_object_definition^.display_attribute <>
                 p_form_object_statuses^ [object_index].display_attribute_set) OR
                (p_form_table_statuses^ [table_index].first_displayed_occurrence <> 1)) THEN
               screen_change.key := fdc$set_attribute;
               screen_change.attribute_form_identifier := form_identifier;
               screen_change.attribute_object_index := object_index;
               screen_change.attribute := p_form_object_definition^.display_attribute;
              fdp$record_screen_change (screen_change, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          FOREND /initialize_variable_objects/;
        FOREND /initialize_table_variables/;

{ Initialize variable that does not belong to a table.

      = fdc$record_variable =
        p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^ [
              p_variable_record_definition^.variable_index];
        IF NOT p_form_variable_definition^.object_exists THEN
          CYCLE /initialize_record/;
        IFEND;

        object_index := p_form_variable_definition^.object_index;
        p_form_object_definition := ^p_form_object_definitions^ [object_index];
        CASE p_form_object_definition^.key OF

        = fdc$form_variable_text =
          p_text := fdp$ptr_text (p_form_object_definition^.text_variable_text, p_form_module);

        = fdc$form_variable_text_box =
          p_text := fdp$ptr_text (p_form_object_definition^.variable_box_text, p_form_module);

        ELSE

{ Invalid object.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'invalid object', status);
          RETURN;
        CASEND;

        program_variable_length := p_form_variable_definition^.program_variable_length;
        screen_variable_length := p_form_variable_definition^.screen_variable_length;
        program_record_position := p_form_variable_definition^.program_record_position;
        program_data_type := p_form_variable_definition^.program_data_type;
        p_work_area := ^p_program_record^ [program_record_position];
        fdp$ptr_screen_variable (p_form_status^.p_screen_record,
              p_form_variable_definition^.screen_record_position, screen_variable_length, p_screen_variable);

{ Save old value if a screen change needs to be recorded.

        IF record_change THEN
          ALLOCATE p_old_screen_variable: [screen_variable_length];
          IF p_old_screen_variable = NIL THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
            RETURN;
          IFEND;
          p_old_screen_variable^ := p_screen_variable^;
        IFEND;

        p_screen_variable^ := p_text^;
        fdp$move_to_program_variable (p_form_status, p_form_variable_definition,
                   p_screen_variable, p_work_area, p_form_object_statuses^ [object_index].
                   variable_input_status, status);
        fdp$move_to_screen_variable (p_form_status, p_form_variable_definition,
                  p_work_area, p_screen_variable, variable_status, status);
        p_form_object_statuses^ [object_index].variable_output_status := variable_status;
        IF variable_status <> fdc$no_error THEN

{ The invalid data character must be substituted even if the field is not currently visible.  Subsequent
{ updates may cause the field to displayed before the error is corrected.

          display_invalid_data_character (p_form_status, p_form_variable_definition^.screen_variable_length,
                ignore_record_screen_change, p_screen_variable^);
        IFEND;

        IF NOT record_change THEN
          CYCLE /initialize_record/;
        IFEND;

        IF ((p_old_screen_variable^ <> p_screen_variable^) OR
            (p_form_object_statuses^ [object_index].character_position <> 1)) THEN
          screen_change.key := fdc$replace_variable;
          screen_change.variable_form_identifier := form_identifier;
          screen_change.variable_object_index := object_index;
          screen_change.p_text := p_screen_variable;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            FREE p_old_screen_variable;
            RETURN;
          IFEND;
        IFEND;

        FREE p_old_screen_variable;

        IF ((p_form_object_definition^.display_attribute <>
             p_form_object_statuses^ [object_index].display_attribute_set)) THEN
          screen_change.key := fdc$set_attribute;
          screen_change.attribute_form_identifier := form_identifier;
          screen_change.attribute_object_index := object_index;
          screen_change.attribute := p_form_object_definition^.display_attribute;
          fdp$record_screen_change (screen_change, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      ELSE

{ Invalid record definition key.

        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'invalid record definition',
              status);
        RETURN;
      CASEND;
    FOREND /initialize_record/;

{ Set tables to display first occurrence.

    FOR object_index := 1 TO p_form_status^.p_form_definition^.form_table_definitions.active_number DO
      p_form_table_statuses^ [object_index].first_displayed_occurrence := 1;
      p_form_table_statuses^ [object_index].last_active_occurrence :=
            p_form_table_definitions^ [object_index].stored_occurrence;
    FOREND;
  PROCEND fdp$initialize_form_record;

?? OLDTITLE ??
?? NEWTITLE := 'fdp$move_to_program_variable', EJECT ??
*copyc fdh$move_to_program_variable

  PROCEDURE [XDCL] fdp$move_to_program_variable
    (    p_form_status: ^fdt$form_status;
         p_form_variable_definition: ^fdt$form_variable_definition;
         p_screen_variable: ^fdt$text;
         p_program_variable:{output} ^cell;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    VAR
      cobol_description: fdt$cobol_description,
      cobol_status: ost$status,
      ignore_status: ost$status,
      p_added_variable_definition: ^fdt$added_variable_definition,
      p_program_variable_array: ^array [1 .. *] of cell,
      p_text: ^fdt$text,
      p_text_sequence: ^SEQ ( * );

    CASE p_form_variable_definition^.program_data_type OF

    = fdc$program_cobol_type =
      fdp$locate_added_variable_facts (p_form_status^.p_form_module,
            p_form_variable_definition, p_added_variable_definition);

{ Convert array of cells to string.

      i#build_adaptable_array_ptr (#RING (p_program_variable), #SEGMENT (p_program_variable),
            #OFFSET (p_program_variable), p_form_variable_definition^.program_variable_length,
            1, 1, #LOC (p_program_variable_array));
      p_text_sequence := #SEQ (p_program_variable_array^);
      RESET p_text_sequence;
      NEXT p_text: [p_form_variable_definition^.program_variable_length] IN p_text_sequence;

      IF p_form_variable_definition^.input_format.key = fdc$currency_input_format THEN
          fdp$change_currency_symbols (p_form_variable_definition^.input_format.
                input_currency_format.currency_sybmol,
                p_form_variable_definition^.input_format.
                input_currency_format.currency_sybmol, p_form_variable_definition^.input_format.
                input_currency_format.thousands_separator,
                p_form_variable_definition^.input_format.input_currency_format.decimal_point);
        ELSE
          fdp$change_currency_symbols (fdc$dollar_currency_symbol, fdc$pound_currency_symbol,
                fdc$thousands_currency_symbol, fdc$decimal_currency_symbol);
        IFEND;

      IF p_added_variable_definition^.program_cobol_description.cobol_usage <>
            fdc$cobol_usage_display  THEN

{ Allow terminal user to enter numeric data in a number of convenient ways through the free form.

        fdp$create_cobol_description ('', fdc$free_form_usage, cobol_description, ignore_status);
        CASE p_added_variable_definition^.display_cobol_description.cr_means OF
          = fdc$cobol_positive, fdc$cobol_negative =
          cobol_description.cr_means :=
                p_added_variable_definition^.display_cobol_description.cr_means;
          cobol_description.db_means :=
                p_added_variable_definition^.display_cobol_description.db_means;
        ELSE { CR/DB not valid input. }
        CASEND;

        fdp$move_cobol_data (cobol_description, p_screen_variable,
              p_added_variable_definition^.program_cobol_description, p_text, cobol_status);
      ELSE { COBOL usage is display.
        CASE p_added_variable_definition^.program_cobol_description.cobol_category OF

        = fdc$cobol_numeric_unsigned, fdc$cobol_numeric_signed, fdc$cobol_numeric_edited =
          fdp$create_cobol_description ('', fdc$free_form_usage, cobol_description, ignore_status);
          CASE p_added_variable_definition^.display_cobol_description.cr_means OF
            = fdc$cobol_positive, fdc$cobol_negative =
            cobol_description.cr_means :=
                  p_added_variable_definition^.display_cobol_description.cr_means;
            cobol_description.db_means :=
                  p_added_variable_definition^.display_cobol_description.db_means;
          ELSE { CR/DB not valid input. }
          CASEND;

          fdp$move_cobol_data (cobol_description, p_screen_variable,
                p_added_variable_definition^.program_cobol_description, p_text, cobol_status);
        ELSE
          fdp$move_cobol_data (p_added_variable_definition^.display_cobol_description, p_screen_variable,
                p_added_variable_definition^.program_cobol_description, p_text, cobol_status);
        CASEND;
      IFEND;

      IF cobol_status.normal THEN
        variable_status := fdc$no_error;
       ELSE
         convert_to_variable_status (cobol_status, variable_status, status);
      IFEND;

    ELSE { A non COBOL data type.
      fdp$convert_to_program_variable (p_form_variable_definition^.program_data_type,  p_program_variable,
            p_form_variable_definition^.program_variable_length, p_form_variable_definition^.input_format,
            p_screen_variable, STRLENGTH (p_screen_variable^), variable_status, status);
    CASEND;

  PROCEND fdp$move_to_program_variable;

?? OLDTITLE ??
?? NEWTITLE := 'fdp$move_to_screen_variable', EJECT ??
*copyc fdh$move_to_screen_variable

  PROCEDURE [XDCL] fdp$move_to_screen_variable
    (    p_form_status: ^fdt$form_status;
         p_form_variable_definition: ^fdt$form_variable_definition;
         p_program_variable: ^cell;
         p_screen_variable:{output} ^fdt$text;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

     VAR
      cobol_status: ost$status,
      p_added_variable_definition: ^fdt$added_variable_definition,
      p_program_variable_array: ^array [1 .. *] of cell,
      p_text: ^fdt$text,
      p_text_sequence: ^SEQ ( * );

     CASE p_form_variable_definition^.program_data_type OF

    = fdc$program_cobol_type =
      fdp$locate_added_variable_facts (p_form_status^.p_form_module,
            p_form_variable_definition, p_added_variable_definition);

{ Convert array of cells to string for fdp$move_cobol_data.

      i#build_adaptable_array_ptr (#RING (p_program_variable), #SEGMENT (p_program_variable),
            #OFFSET (p_program_variable), p_form_variable_definition^.program_variable_length,
            1, 1, #LOC (p_program_variable_array));
      p_text_sequence := #SEQ (p_program_variable_array^);
      RESET p_text_sequence;
      NEXT p_text: [p_form_variable_definition^.program_variable_length] IN p_text_sequence;

      IF p_form_variable_definition^.output_format.key = fdc$currency_output_format THEN
          fdp$change_currency_symbols (p_form_variable_definition^.output_format.
                output_currency_format.currency_sybmol,
                p_form_variable_definition^.output_format.
                output_currency_format.currency_sybmol, p_form_variable_definition^.output_format.
                output_currency_format.thousands_separator,
                p_form_variable_definition^.output_format.output_currency_format.decimal_point);
        ELSE
          fdp$change_currency_symbols (fdc$dollar_currency_symbol, fdc$pound_currency_symbol,
                fdc$thousands_currency_symbol, fdc$decimal_currency_symbol);
        IFEND;

      fdp$move_cobol_data (p_added_variable_definition^.program_cobol_description,
            p_text, p_added_variable_definition^.display_cobol_description,
            p_screen_variable, cobol_status);
      IF cobol_status.normal THEN
        variable_status := fdc$no_error;
       ELSE
         convert_to_variable_status (cobol_status, variable_status, status);
      IFEND;

    ELSE { Non COBOL data type.
      fdp$convert_to_screen_variable (p_form_variable_definition^.program_data_type, p_program_variable,
            p_form_variable_definition^.program_variable_length, p_form_variable_definition^.output_format,
            p_screen_variable, STRLENGTH (p_screen_variable^), variable_status, status);
    CASEND;

  PROCEND fdp$move_to_screen_variable;

?? TITLE := 'fdp$pop_forms', EJECT ??
*copyc fdh$pop_forms

  PROCEDURE [XDCL] fdp$pop_forms
    (VAR status: ost$status);

    VAR
      form_identifier: fdt$form_identifier,
      local_status: ost$status,
      p_form_status: ^fdt$form_status,
      screen_change: fdt$screen_change;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$pop_forms;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$pop_forms;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    IF fdv$screen_status.current_push_count <> 0 THEN
      FOR form_identifier := LOWERBOUND (fdv$screen_status.p_forms_status^)
            TO UPPERBOUND (fdv$screen_status.p_forms_status^) DO
        p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
        IF p_form_status^.entry_used THEN
          IF p_form_status^.opened THEN
            IF p_form_status^.added OR p_form_status^.combined THEN
              IF p_form_status^.push_count = fdv$screen_status.current_push_count THEN

{ Make previous set of pushed forms active.

                p_form_status^.push_count := 0;
                p_form_status^.events_active := TRUE;

              ELSE

{ Delete currently scheduled forms.

                IF p_form_status^.push_count = 0 THEN
                  fdp$delete_form (form_identifier, local_status);
                  IF NOT local_status.normal THEN
                    IF status.normal THEN
                      status := local_status;
                    IFEND;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND;

      fdv$screen_status.current_push_count := fdv$screen_status.current_push_count - 1;
      fdv$screen_status.last_cursor_position_valid := FALSE;

    ELSE

{ No forms are currently pushed.

      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_forms_to_pop, '', status);
    IFEND;
  PROCEND fdp$pop_forms;

?? TITLE := 'fdp$position_form', EJECT ??
*copyc fdh$position_form

  PROCEDURE [XDCL] fdp$position_form
    (    form_identifier: fdt$form_identifier;
         screen_x_position: fdt$x_position;
         screen_y_position: fdt$y_position;
     VAR status: ost$status);

    VAR
      added_form_identifier: fdt$form_identifier,
      combined: BOOLEAN,
      p_form_definition: ^fdt$form_definition,
      p_form_status: ^fdt$form_status,
      screen_change: fdt$screen_change;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$position_form;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$position_form;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_form_status^.push_count <> 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_pushed,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF ((p_form_status^.form_x_position = screen_x_position) AND
          (p_form_status^.form_y_position = screen_y_position)) THEN
      RETURN;
    IFEND;

{ Form must fit on terminal screen at new position.

    p_form_definition := p_form_status^.p_form_definition;
    check_form_screen_fit (screen_x_position, screen_y_position, p_form_definition^.width,
          p_form_definition^.height, p_form_definition^.form_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdv$screen_status.compute_new_screen_size := TRUE;
    IF NOT p_form_status^.displayed_on_screen THEN

{ Plot the initial display of the form at the specified position.
{ The priority of the form is not affected since the form is not displayed on the screen.

      p_form_status^.form_x_position := screen_x_position;
      p_form_status^.form_y_position := screen_y_position;
      RETURN;
    IFEND;

    combined := p_form_status^.combined;
    IF combined THEN
      added_form_identifier := p_form_status^.added_form_identifier;
    IFEND;

{ The form is currently displayed. Delete the form from the screen at the current position
{ and then add/combine the form  at new position. The form will now have the highest priority.

      fdp$delete_form (form_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      p_form_status^.form_x_position := screen_x_position;
      p_form_status^.form_y_position := screen_y_position;

      IF combined THEN
        fdp$combine_form (added_form_identifier, form_identifier, status);
      ELSE
        fdp$add_form (form_identifier, status);
      IFEND;
  PROCEND fdp$position_form;

?? TITLE := 'fdp$push_forms', EJECT ??
*copyc fdh$push_forms

  PROCEDURE [XDCL] fdp$push_forms
    (VAR status: ost$status);

    VAR
      form_pushed: boolean,
      form_identifier: fdt$form_identifier,
      p_form_status: ^fdt$form_status,
      screen_change: fdt$screen_change;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$push_forms;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$push_forms;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    form_pushed := FALSE;
    IF fdv$screen_status.p_forms_status = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_forms_to_push, '', status);
      RETURN;
    IFEND;
    fdv$screen_status.current_push_count := fdv$screen_status.current_push_count + 1;
    FOR form_identifier := LOWERBOUND (fdv$screen_status.p_forms_status^)
          TO UPPERBOUND (fdv$screen_status.p_forms_status^) DO
      p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
      IF p_form_status^.entry_used THEN
        IF p_form_status^.opened THEN
          IF p_form_status^.added OR p_form_status^.combined THEN
            IF p_form_status^.push_count = 0 THEN
              form_pushed := TRUE;
              p_form_status^.push_count := fdv$screen_status.current_push_count;
              p_form_status^.events_active := FALSE;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

    IF NOT form_pushed THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_forms_to_push, '', status);
      fdv$screen_status.current_push_count := fdv$screen_status.current_push_count - 1;
    IFEND;

  PROCEND fdp$push_forms;

?? TITLE := 'fdp$record_screen_change', EJECT ??
*copyc fdh$record_screen_change

  PROCEDURE [XDCL] fdp$record_screen_change
    (    screen_change: fdt$screen_change;
     VAR status: ost$status);

    VAR
      n: fdt$screen_change_index,
      p_new_screen_changes: ^fdt$screen_changes;

    status.normal := TRUE;

{ Try to use an existing free entry to record screen change.

    IF fdv$screen_status.number_screen_changes < UPPERBOUND (fdv$screen_status.p_screen_changes^) THEN
      fdv$screen_status.number_screen_changes := fdv$screen_status.number_screen_changes + 1;
      fdv$screen_status.p_screen_changes^ [fdv$screen_status.number_screen_changes] := screen_change;
      RETURN;
    IFEND;

{ Enlarge the array to hold screen changes.

    ALLOCATE p_new_screen_changes: [1 .. fdc$screen_changes_to_expand +
          fdv$screen_status.number_screen_changes];
    IF p_new_screen_changes <> NIL THEN

{ Copy current screen changes to new array.

      FOR n := 1 TO fdv$screen_status.number_screen_changes DO
        p_new_screen_changes^ [n] := fdv$screen_status.p_screen_changes^ [n];
      FOREND;
      FREE fdv$screen_status.p_screen_changes;

{ Add new screen change.

      fdv$screen_status.p_screen_changes := p_new_screen_changes;
      fdv$screen_status.number_screen_changes := fdv$screen_status.number_screen_changes + 1;
      fdv$screen_status.p_screen_changes^ [fdv$screen_status.number_screen_changes] := screen_change;

    ELSE { No space for screen changes. }
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
    IFEND;

  PROCEND fdp$record_screen_change;

?? TITLE := 'fdp$replace_integer_variable', EJECT ??
*copyc fdh$replace_integer_variable

  PROCEDURE [XDCL] fdp$replace_integer_variable
    (    form_identifier: fdt$form_identifier;
         name: ost$name;
         occurrence: fdt$occurrence;
         variable: integer;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    VAR
      error: mlt$error,
      compare: mlt$compare,
      new_value: fdt$variable_value,
      number_equal_bytes: mlt$string_length,
      object_exists: boolean,
      object_index: fdt$object_index,
      p_form_definition: ^fdt$form_definition,
      p_form_object_status: ^fdt$form_object_status,
      p_form_status: ^fdt$form_status,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_screen_variable: ^fdt$text,
      program_record_position: fdt$record_position,
      screen_change: fdt$screen_change,
      screen_record_position: fdt$record_position,
      screen_variable_length: fdt$text_length,
      valid: boolean,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$replace_integer_variable;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$replace_integer_variable;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    variable_status := fdc$no_error;
    fdp$find_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_form_status^.push_count <> 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_pushed,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    #translate (osv$lower_to_upper, name, valid_name);
    find_record_variable (p_form_status, valid_name, occurrence, p_form_variable_definition, object_exists,
          object_index, program_record_position, screen_record_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT (p_form_variable_definition^.program_data_type = fdc$program_integer_type) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$wrong_variable_type, 'INTEGER', status);
      RETURN;
    IFEND;

    p_form_object_status := ^p_form_status^.p_form_object_statuses^ [object_index];

{ Check to see if the new value is the same as the existing value.  Skip this check if the existing value has
{ output errors because the value on the screen may be different.

    IF ((p_form_object_status^.variable_output_status = fdc$no_error) AND
            (p_form_object_status^.variable_input_status = fdc$no_error)) THEN
      mlp$compare_bytes (^p_form_status^.p_program_record^ [program_record_position], fdc$integer_length,
            ^variable, fdc$integer_length, compare, number_equal_bytes, error);
      IF (compare = mlc$equal) THEN
        RETURN;
      IFEND;
    IFEND;

{ Input status is now obsolete.

    p_form_object_status^.variable_input_status := fdc$no_error;
    new_value.program_data_type := fdc$program_integer_type;
    new_value.integer_value := variable;
    replace_variable (p_form_status, form_identifier, new_value, p_form_variable_definition, object_index,
          object_exists, program_record_position, screen_record_position,
          p_form_object_status^.variable_output_status, status);
    IF NOT p_form_status^.invalid_data_character.defined THEN

{ Return the variable status to the caller if the Invalid Data Character is not defined.

      variable_status := p_form_object_status^.variable_output_status;
    IFEND;

    IF variable_status <> fdc$no_error THEN
      p_form_status^.output_error_search.status := fdc$not_searched;
    IFEND;

  PROCEND fdp$replace_integer_variable;

?? TITLE := 'fdp$replace_real_variable', EJECT ??
*copyc fdh$replace_real_variable

  PROCEDURE [XDCL] fdp$replace_real_variable
    (    form_identifier: fdt$form_identifier;
         name: ost$name;
         occurrence: fdt$occurrence;
         variable: real;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    VAR
      compare: mlt$compare,
      error: mlt$error,
      new_value: fdt$variable_value,
      number_equal_bytes: mlt$string_length,
      object_exists: boolean,
      object_index: fdt$object_index,
      p_form_object_status: ^fdt$form_object_status,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_status: ^fdt$form_status,
      p_screen_variable: ^fdt$text,
      program_record_position: fdt$record_position,
      program_variable_length: fdt$program_variable_length,
      screen_change: fdt$screen_change,
      screen_record_position: fdt$record_position,
      screen_variable_length: fdt$text_length,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$replace_real_variable;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$replace_real_variable;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    variable_status := fdc$no_error;
    fdp$find_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_form_status^.push_count <> 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_pushed,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    #translate (osv$lower_to_upper, name, valid_name);
    find_record_variable (p_form_status, valid_name, occurrence, p_form_variable_definition,
          object_exists, object_index, program_record_position, screen_record_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT (p_form_variable_definition^.program_data_type = fdc$program_real_type) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$wrong_variable_type, 'REAL', status);
      RETURN;
    IFEND;

    p_form_object_status := ^p_form_status^.p_form_object_statuses^ [object_index];

{ Check to see if the new value is the same as the existing value.  Skip this check if the existing value has
{ output errors because the value on the screen may be different.

    IF ((p_form_object_status^.variable_output_status = fdc$no_error) AND
            (p_form_object_status^.variable_input_status = fdc$no_error)) THEN
      mlp$compare_bytes (^p_form_status^.p_program_record^ [program_record_position], fdc$real_length,
            ^variable, fdc$real_length, compare, number_equal_bytes, error);
      IF (compare = mlc$equal) THEN
        RETURN;
      IFEND;
    IFEND;

{ Input status is now obsolete.

    p_form_object_status^.variable_input_status := fdc$no_error;
    new_value.program_data_type := fdc$program_real_type;
    new_value.real_value := variable;
    replace_variable (p_form_status, form_identifier, new_value, p_form_variable_definition, object_index,
          object_exists, program_record_position, screen_record_position,
          p_form_object_status^.variable_output_status, status);
    IF NOT p_form_status^.invalid_data_character.defined THEN

{ Return the variable status to the caller if the Invalid Data Character is not defined.

      variable_status := p_form_object_status^.variable_output_status;
    IFEND;

    IF variable_status <> fdc$no_error THEN
      p_form_status^.output_error_search.status := fdc$not_searched;
    IFEND;

  PROCEND fdp$replace_real_variable;

?? TITLE := 'fdp$replace_record', EJECT ??
*copyc fdh$replace_record

  PROCEDURE [XDCL] fdp$replace_record
    (    form_identifier: fdt$form_identifier;
         p_work_area: ^cell;
         work_area_length: fdt$work_area_length;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    VAR
      first_displayed_occurrence: fdt$occurrence,
      object_index: fdt$object_index,
      p_form_module: ^fdt$form_module,
      p_form_record_definitions: ^array [1 .. * ] of fdt$variable_record_definition,
      p_form_status: ^fdt$form_status,
      p_form_table_definition: ^fdt$form_table_definition,
      p_form_table_statuses: ^array [1 .. * ] of fdt$table_status,
      p_form_table_definitions: ^array [1 .. * ] of fdt$form_table_definition,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_program_record: ^array [1 .. * ] of cell,
      p_table_object: ^fdt$table_object,
      p_table_objects: ^array [1 .. * ] of fdt$table_object,
      p_table_variable: ^fdt$table_variable,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable,
      p_variable_record_definition: ^fdt$variable_record_definition,
      program_variable_length: fdt$program_variable_length,
      record_index: fdt$variable_index,
      record_position: fdt$record_position,
      screen_change: fdt$screen_change,
      screen_record_position: fdt$record_position,
      screen_variable_length: fdt$text_length,
      table_index: fdt$table_index,
      table_object_index: fdt$object_index,
      update_screen: boolean,
      user_offset: integer,
      user_ring: integer,
      user_segment: integer,
      variable_index: fdt$variable_index;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$replace_record;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$replace_record;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
?? NEWTITLE := 'process_variable', EJECT ??

{ PURPOSE:
{   Do the common processing for all variable data types.
{

    PROCEDURE process_variable;

      VAR
        compare: mlt$compare,
        error: mlt$error,
        new_value: fdt$variable_value,
        number_equal_bytes: mlt$string_length,
        p_form_object_status: ^fdt$form_object_status,
        p_program_variable: ^cell,
        p_program_variable_array: ^array [1 .. * ] of cell,
        p_text_sequence: ^SEQ ( * ),
        variable_offset: integer;


      p_form_object_status := ^p_form_status^.p_form_object_statuses^ [object_index];
      variable_offset := user_offset + record_position - 1;
      p_program_variable := #ADDRESS (user_ring, user_segment, variable_offset);

{ Check to see if the new value is the same as the existing value.  Skip this check if the existing value has
{ output errors because the value on the screen may be different.

      IF ((p_form_object_status^.variable_output_status = fdc$no_error) AND
            (p_form_object_status^.variable_input_status = fdc$no_error)) THEN
        mlp$compare_bytes (p_program_variable, program_variable_length, ^p_program_record^ [record_position],
              program_variable_length, compare, number_equal_bytes, error);
        IF (compare = mlc$equal) THEN
          RETURN;
        IFEND;
      IFEND;

{ Input status is now obsolete.

      p_form_object_status^.variable_input_status := fdc$no_error;
      p_program_variable := #ADDRESS (user_ring, user_segment, (user_offset + record_position - 1));
      new_value.program_data_type := p_form_variable_definition^.program_data_type;

      CASE p_form_variable_definition^.program_data_type OF
      = fdc$program_character_type, fdc$program_upper_case_type =
        i#build_adaptable_array_ptr (#RING (p_program_variable), #SEGMENT (p_program_variable),
              #OFFSET (p_program_variable), program_variable_length, 1, 1, #LOC (p_program_variable_array));
        p_text_sequence := #SEQ (p_program_variable_array^);
        RESET p_text_sequence;
        NEXT new_value.p_text: [program_variable_length] IN p_text_sequence;
        new_value.text_length := program_variable_length;

      = fdc$program_integer_type =
        i#move (p_program_variable, ^new_value.integer_value, program_variable_length);

      = fdc$program_real_type =
        i#move (p_program_variable, ^new_value.real_value, program_variable_length);

      ELSE { fdc$program_cobol_type
        new_value.cobol_data_length := program_variable_length;
        new_value.p_cobol_data := p_program_variable;
      CASEND;

      replace_variable (p_form_status, form_identifier, new_value, p_form_variable_definition, object_index,
            update_screen, record_position, screen_record_position,
            p_form_object_status^.variable_output_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (variable_status = fdc$no_error) AND
            (p_form_object_status^.variable_output_status <> fdc$no_error) THEN
        p_form_status^.output_error_search.status := fdc$not_searched;
        IF NOT p_form_status^.invalid_data_character.defined THEN

{ Return the variable status to the caller if the Invalid Data Character is not defined.

          variable_status := p_form_object_status^.variable_output_status;
        IFEND;
      IFEND;

    PROCEND process_variable;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;

    fdp$find_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_form_status^.push_count <> 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_pushed,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    p_form_record_definitions := p_form_status^.p_form_record_definitions;
    IF p_form_record_definitions = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_has_no_variables,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

{ The program record storage must map exactly to the record held by Screen Formatting.

    p_program_record := p_form_status^.p_program_record;
    IF work_area_length <> #SIZE (p_program_record^) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$work_area_invalid,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    variable_status := fdc$no_error;
    p_form_module := p_form_status^.p_form_module;
    p_form_table_definitions := p_form_status^.p_form_table_definitions;
    user_ring := #RING (p_work_area);
    user_segment := #SEGMENT (p_work_area);
    user_offset := #OFFSET (p_work_area);
    screen_change.key := fdc$replace_variable;
    screen_change.variable_form_identifier := form_identifier;
    p_form_status^.input_error_search.status := fdc$search_not_allowed;
    p_form_status^.output_error_search.status := fdc$search_completed;

{ Process all variables in the form record definition.

    FOR record_index := 1 TO UPPERBOUND (p_form_record_definitions^) DO
      p_variable_record_definition := ^p_form_record_definitions^ [record_index];
      CASE p_variable_record_definition^.key OF

      = fdc$record_table =
        table_index := p_variable_record_definition^.table_index;
        p_form_table_statuses := p_form_status^.p_form_table_statuses;
        first_displayed_occurrence := p_form_table_statuses^ [table_index].first_displayed_occurrence;
        p_form_table_definition := ^p_form_table_definitions^ [table_index];
        p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
              p_form_module);

      /process_variables_in_table/
        FOR variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
          p_table_variable := ^p_table_variables^ [variable_index];
          IF NOT p_table_variable^.variable_exists THEN
            CYCLE /process_variables_in_table/;
          IFEND;

          p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                [p_table_variable^.variable_index];
          program_variable_length := p_form_variable_definition^.program_variable_length;
          screen_variable_length := p_form_variable_definition^.screen_variable_length;
          p_table_objects := fdp$ptr_table_objects (p_table_variable^.table_objects, p_form_module);

        /process_variable_occurrences/
          FOR table_object_index := 1 TO p_form_table_definition^.stored_occurrence DO
            p_table_object := ^p_table_objects^ [table_object_index];
            IF NOT p_table_object^.object_exists THEN
              CYCLE /process_variable_occurrences/;
            IFEND;

            object_index := p_table_object^.object_index;
            record_position := p_table_object^.program_record_position;
            screen_record_position := p_table_object^.screen_record_position;
            update_screen := p_form_status^.displayed_on_screen AND
                  (p_form_status^.added OR p_form_status^.combined) AND
                  ((first_displayed_occurrence + p_form_table_definition^.visible_occurrence - 1) >=
                  table_object_index) AND (first_displayed_occurrence <= table_object_index);
            process_variable;
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND /process_variable_occurrences/;
        FOREND /process_variables_in_table/;

      = fdc$record_variable =

{ Process variable that is not a member of a table.

        p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^ [
              p_variable_record_definition^.variable_index];
        record_position := p_form_variable_definition^.program_record_position;
        program_variable_length := p_form_variable_definition^.program_variable_length;
        screen_variable_length := p_form_variable_definition^.screen_variable_length;
        object_index := p_form_variable_definition^.object_index;
        update_screen := p_form_status^.displayed_on_screen AND
              (p_form_status^.added OR p_form_status^.combined);
        screen_record_position := p_form_variable_definition^.screen_record_position;
        process_variable;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      CASEND;
    FOREND;

  PROCEND fdp$replace_record;

?? TITLE := 'fdp$replace_string_variable', EJECT ??
*copyc fdh$replace_string_variable

  PROCEDURE [XDCL] fdp$replace_string_variable
    (    form_identifier: fdt$form_identifier;
         name: ost$name;
         occurrence: fdt$occurrence;
         variable: fdt$text;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    VAR
      error: mlt$error,
      compare: mlt$compare,
      new_value: fdt$variable_value,
      number_equal_bytes: mlt$string_length,
      program_record_position: fdt$record_position,
      object_exists: boolean,
      object_index: fdt$object_index,
      p_form_object_status: ^fdt$form_object_status,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_status: ^fdt$form_status,
      p_text: ^fdt$text,
      program_variable_length: fdt$program_variable_length,
      screen_change: fdt$screen_change,
      screen_record_position: fdt$record_position,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$replace_string_variable;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$replace_string_variable;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    variable_status := fdc$no_error;
    fdp$find_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_form_status^.push_count <> 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_pushed,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    #TRANSLATE (osv$lower_to_upper, name, valid_name);
    find_record_variable (p_form_status, valid_name, occurrence, p_form_variable_definition, object_exists,
          object_index, program_record_position, screen_record_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE p_form_variable_definition^.program_data_type OF
    = fdc$program_character_type, fdc$program_upper_case_type =
    ELSE
      osp$set_status_abnormal (fdc$format_display_identifier, fde$wrong_variable_type,
            'CHARACTER or UPPER_CASE', status);
      RETURN;
    CASEND;

    p_form_object_status := ^p_form_status^.p_form_object_statuses^ [object_index];

{ Check to see if the new value is the same as the existing value.  Skip this check if the existing value has
{ output errors because the value on the screen may be different.

    IF ((p_form_object_status^.variable_output_status = fdc$no_error) AND
            (p_form_object_status^.variable_input_status = fdc$no_error)) THEN
      mlp$compare_bytes (^p_form_status^.p_program_record^ [program_record_position],
            p_form_variable_definition^.program_variable_length, ^variable,
            STRLENGTH (variable), compare, number_equal_bytes, error);
      IF (compare = mlc$equal) THEN
        RETURN;
      IFEND;
    IFEND;

{ Input status is now obsolete.

    p_form_object_status^.variable_input_status := fdc$no_error;
    new_value.program_data_type := p_form_variable_definition^.program_data_type;
    new_value.p_text := ^variable;
    new_value.text_length := STRLENGTH (variable);
    replace_variable (p_form_status, form_identifier, new_value, p_form_variable_definition, object_index,
          object_exists, program_record_position, screen_record_position,
          p_form_object_status^.variable_output_status, status);
    IF NOT p_form_status^.invalid_data_character.defined THEN

{ Return the variable status to the caller if the Invalid Data Character is not defined.

      variable_status := p_form_object_status^.variable_output_status;
    IFEND;
    IF variable_status <> fdc$no_error THEN
      p_form_status^.output_error_search.status := fdc$not_searched;
    IFEND;

  PROCEND fdp$replace_string_variable;

?? TITLE := 'fdp$reset_form', EJECT ??
*copyc fdh$reset_form

  PROCEDURE [XDCL] fdp$reset_form
    (    form_identifier: fdt$form_identifier;
     VAR status: ost$status);

    VAR
      p_form_status: ^fdt$form_status,
      record_changes: boolean,
      variable_status: fdt$variable_status;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$reset_form;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$reset_form;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_form_status^.push_count <> 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_pushed,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    p_form_status^.last_cursor_position_valid := FALSE;

{ Set all variables to initial values and display attributes.
{ If the form is displayed on the screen and currently added, then record the screen changes.

    record_changes := p_form_status^.displayed_on_screen AND
            (p_form_status^.added OR p_form_status^.combined);
    fdp$initialize_form_record (form_identifier, p_form_status, record_changes,
            variable_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Set initial object attributes and character positions.

    fdp$initialize_form_objects (form_identifier, p_form_status, record_changes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_form_status^.design_form THEN
      fdp$delete_area (form_identifier, 1, 1, p_form_status^.p_form_definition^.width,
            p_form_status^.p_form_definition^.height, status);
      RETURN;
    IFEND;

    IF ((fdv$screen_status.last_cursor_position_valid) AND
          (fdv$screen_status.last_cursor_form_identifier = form_identifier)) THEN
      fdv$screen_status.last_cursor_position_valid := FALSE;
    IFEND;

  PROCEND fdp$reset_form;

?? TITLE := 'fdp$reset_object_attribute', EJECT ??
*copyc fdh$reset_object_attribute

  PROCEDURE [XDCL] fdp$reset_object_attribute
    (    form_identifier: fdt$form_identifier;
         object_name: ost$name;
         occurrence: fdt$occurrence;
     VAR status: ost$status);

    VAR
      form_object_key: fdt$form_object_key,
      object_name_exists: boolean,
      object_occurrence_exists: boolean,
      object_index: fdt$object_index,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_status: ^fdt$form_status,
      p_form_variable_definition: ^fdt$form_variable_definition,
      screen_change: fdt$screen_change,
      valid_object_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$reset_object_attribute;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$reset_object_attribute;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$check_for_active_form (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    #translate (osv$lower_to_upper, object_name, valid_object_name);
    fdp$find_object_definition (valid_object_name, occurrence, p_form_status^.p_form_object_definitions,
          p_form_status^.p_form_definition^.form_object_definitions.active_number, p_form_object_definition,
          object_index, object_name_exists, object_occurrence_exists);
    IF NOT object_name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_object_name, object_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF NOT object_occurrence_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_occurrence, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (occurrence), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, object_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF (p_form_object_definition^.display_attribute =
          p_form_status^.p_form_object_statuses^ [object_index].display_attribute_set) THEN
      RETURN;
    IFEND;

    p_form_status^.p_form_object_statuses^ [object_index].display_attribute_set :=
          p_form_object_definition^.display_attribute;

    IF p_form_status^.displayed_on_screen THEN
      screen_change.key := fdc$set_attribute;
      screen_change.attribute_form_identifier := form_identifier;
      screen_change.attribute := p_form_object_definition^.display_attribute;
      screen_change.attribute_object_index := object_index;
      fdp$record_screen_change (screen_change, status);
    IFEND;

  PROCEND fdp$reset_object_attribute;

?? TITLE := 'fdp$set_cursor_position', EJECT ??
*copyc fdh$set_cursor_position

  PROCEDURE [XDCL] fdp$set_cursor_position
    (    form_identifier: fdt$form_identifier;
         object_name: ost$name;
         occurrence: fdt$occurrence;
         character_position: fdt$character_position;
     VAR status: ost$status);

    VAR
      name_is_valid: boolean,
      object_index: fdt$object_index,
      object_name_exists: boolean,
      object_occurrence_exists: boolean,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_module: ^fdt$form_module,
      p_form_status: ^fdt$form_status,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_variable_definitions: ^array [1 .. * ] of fdt$form_variable_definition,
      p_text: ^fdt$text,
      screen_change: fdt$screen_change,
      valid_object_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$set_cursor_position;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$set_cursor_position;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE ??
?? NEWTITLE := 'cursor_outside_table', EJECT ??

    PROCEDURE cursor_inside_table;
      status.normal := TRUE;
      IF p_form_variable_definition^.table_exists THEN
        IF occurrence > p_form_status^.p_form_table_statuses^ [p_form_variable_definition^.table_index].
              last_active_occurrence THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_occurrence, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (occurrence), 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, object_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                p_form_status^.p_form_definition^.form_name, status);
        IFEND;
      IFEND;
    PROCEND cursor_inside_table;

?? OLDTITLE ??
?? NEWTITLE := 'set_invalid_position', EJECT ??

    PROCEDURE [INLINE]  set_invalid_position;
        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_character_position, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (character_position), 10, FALSE,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, object_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              p_form_status^.p_form_definition^.form_name, status);
    PROCEND set_invalid_position;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$check_for_active_form (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    #translate (osv$lower_to_upper, object_name, valid_object_name);
    fdp$find_object_definition (valid_object_name, occurrence, p_form_status^.p_form_object_definitions,
          p_form_status^.p_form_definition^.form_object_definitions.active_number, p_form_object_definition,
          object_index, object_name_exists, object_occurrence_exists);

    IF NOT object_name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_object_name, object_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF NOT object_occurrence_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_occurrence, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (occurrence), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, object_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    p_form_variable_definitions := p_form_status^.p_form_variable_definitions;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    screen_change.key := fdc$set_cursor;
    screen_change.cursor_form_identifier := form_identifier;
    screen_change.cursor_character_position := character_position;
    screen_change.cursor_object_index := object_index;

{ The cursor position must lie inside the data for an object.

    CASE p_form_object_definition^.key OF

    = fdc$form_constant_text =
      IF character_position > p_form_object_definition^.constant_text_width THEN
        set_invalid_position;
        RETURN;
      IFEND;

    = fdc$form_constant_text_box =
      IF (character_position > (p_form_object_definition^.constant_box_height *
            p_form_object_definition^.constant_box_width)) THEN
        set_invalid_position;
        RETURN;
      IFEND;

    = fdc$form_variable_text_box =
      IF p_form_object_definition^.variable_box_variable_exists THEN
        p_form_variable_definition := ^p_form_variable_definitions^
              [p_form_object_definition^.variable_box_variable_index];
        cursor_inside_table;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF ((p_form_variable_definition^.program_data_type = fdc$program_real_type) OR
              (p_form_variable_definition^.program_data_type = fdc$program_integer_type)) THEN
          IF character_position > p_form_variable_definition^.screen_variable_length THEN
            set_invalid_position;
            RETURN;
          IFEND;

        ELSE { The data type is character.}
          IF character_position > p_form_variable_definition^.program_variable_length THEN
            set_invalid_position;
            RETURN;
          IFEND;
        IFEND;

      ELSE

{ No variable defined.

        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_object_variable_defined,
              valid_object_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              p_form_status^.p_form_definition^.form_name, status);
        RETURN;
      IFEND;

    = fdc$form_variable_text =
      IF p_form_object_definition^.text_variable_exists THEN
        p_form_variable_definition := ^p_form_variable_definitions^
              [p_form_object_definition^.text_variable_index];
        cursor_inside_table;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF ((p_form_variable_definition^.program_data_type = fdc$program_real_type) OR
              (p_form_variable_definition^.program_data_type = fdc$program_integer_type)) THEN
          IF character_position > p_form_variable_definition^.screen_variable_length THEN
            set_invalid_position;
            RETURN;
          IFEND;

        ELSE { The data type is character.}
          IF character_position > p_form_variable_definition^.program_variable_length THEN
            set_invalid_position;
            RETURN;
          IFEND;
        IFEND;

      ELSE

{ No variable defined.

        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_object_variable_defined,
              valid_object_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              p_form_status^.p_form_definition^.form_name, status);
        RETURN;
      IFEND;

    = fdc$form_stored_variable =
      IF p_form_object_definition^.stored_variable_exists THEN
        p_form_variable_definition := ^p_form_variable_definitions^
              [p_form_object_definition^.stored_variable_index];
        cursor_inside_table;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF ((p_form_variable_definition^.program_data_type = fdc$program_real_type) OR
              (p_form_variable_definition^.program_data_type = fdc$program_integer_type)) THEN
          IF character_position > p_form_variable_definition^.screen_variable_length THEN
            set_invalid_position;
            RETURN;
          IFEND;

        ELSE { The data type is character.}
          IF character_position > p_form_variable_definition^.program_variable_length THEN
            set_invalid_position;
            RETURN;
          IFEND;
        IFEND;

      ELSE

{ No variable defined.

        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_object_variable_defined,
              valid_object_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              p_form_status^.p_form_definition^.form_name, status);
        RETURN;
      IFEND;

    = fdc$form_box, fdc$form_line =
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_object_variable_defined,
            valid_object_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;

    ELSE

{ Invalid object definition key.

      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'invalid object', status);
      RETURN;
    CASEND;
    fdp$record_screen_change (screen_change, status);

  PROCEND fdp$set_cursor_position;

?? TITLE := 'fdp$set_object_attribute', EJECT ??
*copyc fdh$set_object_attribute

  PROCEDURE [XDCL] fdp$set_object_attribute
    (    form_identifier: fdt$form_identifier;
         object_name: ost$name;
         occurrence: fdt$occurrence;
         attribute: ost$name;
     VAR status: ost$status);

    VAR
      name_exists: boolean,
      object_index: fdt$object_index,
      object_occurrence_exists: boolean,
      p_display_definition: ^fdt$display_definition,
      p_form_definition: ^fdt$form_definition,
      p_form_status: ^fdt$form_status,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      screen_change: fdt$screen_change,
      valid_attribute_name: ost$name,
      valid_object_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$set_object_attribute;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$set_object_attribute;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$check_for_active_form (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    #translate (osv$lower_to_upper, object_name, valid_object_name);

    #translate (osv$lower_to_upper, object_name, valid_object_name);
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    fdp$find_object_definition (valid_object_name, occurrence, p_form_object_definitions,
          p_form_definition^.form_object_definitions.active_number, p_form_object_definition, object_index,
          name_exists, object_occurrence_exists);
    IF NOT name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_object_name, object_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    IF NOT object_occurrence_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_occurrence, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (occurrence), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, object_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    #translate (osv$lower_to_upper, attribute, valid_attribute_name);
    fdp$find_display_name (valid_attribute_name, p_form_status^.p_display_definitions,
          p_form_definition^.display_definitions.active_number, p_display_definition, name_exists);
    IF NOT name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_display_name, valid_attribute_name,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    screen_change.key := fdc$set_attribute;
    screen_change.attribute_form_identifier := form_identifier;
    screen_change.attribute_object_index := object_index;

    CASE p_form_object_definition^.key OF

    = fdc$form_box, fdc$form_line =

{ Graphics must have line attribute and protection.

      screen_change.attribute := p_display_definition^.attribute + $fdt$display_attribute_set [fdc$protect];
      IF ((screen_change.attribute * fdv$line_attributes) = $fdt$display_attribute_set []) THEN
        screen_change.attribute := screen_change.attribute +
              (p_form_object_definition^.display_attribute * fdv$line_attributes);
      IFEND;

    = fdc$form_constant_text_box, fdc$form_constant_text =

{ Always protect constant text.

      screen_change.attribute := p_display_definition^.attribute + $fdt$display_attribute_set [fdc$protect];

    ELSE
      screen_change.attribute := p_display_definition^.attribute;
    CASEND;

    IF (p_form_status^.p_form_object_statuses^ [object_index].display_attribute_set =
          screen_change.attribute) THEN
      RETURN;
    IFEND;

    p_form_status^.p_form_object_statuses^ [object_index].display_attribute_set := screen_change.attribute;
    IF p_form_status^.displayed_on_screen THEN
      fdp$record_screen_change (screen_change, status);
    IFEND;

  PROCEND fdp$set_object_attribute;

?? TITLE := 'fdp$validate_cobol_data', EJECT ??
*copyc fdh$validate_cobol_data

  PROCEDURE [XDCL] fdp$validate_cobol_data
    (    p_form_status: ^fdt$form_status;
         p_form_variable_definition: ^fdt$form_variable_definition;
         p_program_variable: ^cell;
     VAR p_valid_string: ^fdt$valid_string;
     VAR variable_status: fdt$variable_status);

    TYPE
      data_converter = record
        case integer of
        = 1 =
          integer_cells: array [1 .. fdc$integer_length] of cell,
        = 2 =
          integer_number: integer,
        casend,
      recend;

    VAR
      data: data_converter,
      p_added_variable_definition: ^fdt$added_variable_definition,
      p_program_variable_array: ^array [1 .. *] of cell,
      p_text: ^fdt$text,
      p_text_sequence: ^SEQ ( * ),
      real_number: real;

    variable_status := fdc$no_error;
    p_valid_string := NIL;
    fdp$locate_added_variable_facts (p_form_status^.p_form_module,
          p_form_variable_definition, p_added_variable_definition);

    CASE p_added_variable_definition^.
          program_cobol_description.cobol_usage OF

    = fdc$cobol_usage_binary =
      data.integer_number := 0;
      i#move (p_program_variable,
            ^data.integer_cells [fdc$integer_length -
            p_form_variable_definition^.program_variable_length + 1],
            p_form_variable_definition^.program_variable_length);
      fdp$validate_integer (data.integer_number, p_form_variable_definition^.
            valid_integer_ranges, p_form_status,  variable_status);

    = fdc$cobol_usage_single =
      i#move (p_program_variable, ^real_number, p_form_variable_definition^.program_variable_length);
      fdp$validate_real (real_number, p_form_variable_definition^.valid_real_ranges, p_form_status,
            variable_status);

    = fdc$cobol_usage_display =
      CASE p_added_variable_definition^.program_cobol_description.cobol_category OF

      = fdc$cobol_alphanumeric, fdc$cobol_alphabetic =

{ Convert array of cells to string.

        i#build_adaptable_array_ptr (#RING (p_program_variable), #SEGMENT (p_program_variable),
              #OFFSET (p_program_variable), p_form_variable_definition^.program_variable_length,
              1, 1, #LOC (p_program_variable_array));
        p_text_sequence := #SEQ (p_program_variable_array^);
        RESET p_text_sequence;
        NEXT p_text: [p_form_variable_definition^.program_variable_length] IN p_text_sequence;
          fdp$validate_string (p_text, p_form_variable_definition^.program_variable_length,
                p_form_variable_definition^.valid_strings,
                p_form_status, p_valid_string, variable_status);

      ELSE { Other categories cannot be validated.
      CASEND;

    ELSE { Other usages cannot be validated.
    CASEND;
  PROCEND fdp$validate_cobol_data;

?? TITLE := 'fdp$validate_integer', EJECT ??

  PROCEDURE [XDCL] fdp$validate_integer
    (    integer_number: integer;
         valid_integer_ranges: fdt$valid_integer_ranges;
         p_form_status: ^fdt$form_status;
     VAR variable_status: fdt$variable_status);

    VAR
      n: fdt$valid_integer_index,
      p_valid_integer_range: ^fdt$valid_integer_range,
      p_valid_integer_ranges: ^array [1 .. * ] of fdt$valid_integer_range;

    IF valid_integer_ranges.active_number = 0 THEN

{ No valid integers were defined. All integers are valid.

      variable_status := fdc$no_error;
      RETURN;
    IFEND;

    p_valid_integer_ranges := fdp$ptr_valid_integers (valid_integer_ranges, p_form_status^.p_form_module);
    variable_status := fdc$invalid_integer;

  /find_integer/
    FOR n := 1 TO valid_integer_ranges.active_number DO
      p_valid_integer_range := ^p_valid_integer_ranges^ [n];
      IF integer_number >= p_valid_integer_range^.minimum_integer THEN
        IF integer_number <= p_valid_integer_range^.maximum_integer THEN
          variable_status := fdc$no_error;
          EXIT /find_integer/;
        IFEND;
      IFEND;
    FOREND /find_integer/;

  PROCEND fdp$validate_integer;

?? TITLE := 'fdp$validate_real', EJECT ??

  PROCEDURE [XDCL] fdp$validate_real
    (    real_number: real;
         valid_real_ranges: fdt$valid_real_ranges;
         p_form_status: ^fdt$form_status;
     VAR variable_status: fdt$variable_status);

    VAR
      n: fdt$valid_real_index,
      p_valid_real_range: ^fdt$valid_real_range,
      p_valid_real_ranges: ^array [1 .. * ] of fdt$valid_real_range;

    IF valid_real_ranges.active_number = 0 THEN

{ No valid real numbers were defined. All real valid numbers are valid.

      variable_status := fdc$no_error;
      RETURN;
    IFEND;

    p_valid_real_ranges := fdp$ptr_valid_reals (valid_real_ranges, p_form_status^.p_form_module);
    variable_status := fdc$invalid_real;

  /find_real/
    FOR n := 1 TO valid_real_ranges.active_number DO
      p_valid_real_range := ^p_valid_real_ranges^ [n];
      IF real_number >= p_valid_real_range^.minimum_real THEN
        IF real_number <= p_valid_real_range^.maximum_real THEN
          variable_status := fdc$no_error;
          EXIT /find_real/;
        IFEND;
      IFEND;
    FOREND /find_real/;

  PROCEND fdp$validate_real;

?? TITLE := 'fdp$validate_string', EJECT ??

  PROCEDURE [XDCL] fdp$validate_string
    (    p_text: ^fdt$text;
         text_length: fdt$text_length;
         valid_strings: fdt$valid_strings;
         p_form_status: ^fdt$form_status;
     VAR p_valid_string: ^fdt$valid_string;
     VAR variable_status: fdt$variable_status);

    VAR
      compare_length: fdt$text_length,
      n: fdt$valid_string_index,
      p_duplicate_string: ^fdt$valid_string,
      p_valid_strings: ^array [1 .. * ] of fdt$valid_string_definition,
      valid_string_length: fdt$text_length;

    IF valid_strings.active_number = 0 THEN

{ No strings to compare. All strings are valid.

      variable_status := fdc$no_error;
      p_valid_string := NIL;
      RETURN;
    IFEND;

    p_valid_strings := fdp$ptr_valid_strings (valid_strings, p_form_status^.p_form_module);

    compare_length := text_length;
    IF valid_strings.compare_to_unique_substring THEN

    /determine_compare_length/
      FOR compare_length := text_length DOWNTO 1 DO
        IF (p_text^ (compare_length, 1) <> ' ') THEN
          EXIT /determine_compare_length/;
        IFEND;
      FOREND /determine_compare_length/;
    IFEND;

   variable_status := fdc$invalid_string;

  /find_string/
    FOR n := 1 TO valid_strings.active_number DO
      p_valid_string := #PTR (p_valid_strings^ [n].p_valid_string, p_form_status^.p_form_module^);

      IF compare_length > STRLENGTH (p_valid_string^) THEN
        valid_string_length := STRLENGTH (p_valid_string^);
      ELSE
        valid_string_length := compare_length;
      IFEND;

      IF (p_text^ (1, compare_length) = p_valid_string^ (1, valid_string_length)) THEN
        variable_status := fdc$no_error;
        EXIT /find_string/;
      IFEND;
    FOREND /find_string/;

    IF NOT valid_strings.compare_to_unique_substring THEN
      RETURN;
    IFEND;

{ Only one valid string must match the terminal user input.

  /check_duplicate_string/
    FOR n := n + 1 TO valid_strings.active_number DO
      p_duplicate_string := #PTR (p_valid_strings^ [n].p_valid_string, p_form_status^.p_form_module^);

      IF compare_length > STRLENGTH (p_duplicate_string^) THEN
        valid_string_length := STRLENGTH (p_duplicate_string^);
      ELSE
        valid_string_length := compare_length;
      IFEND;

      IF (p_text^ (1, compare_length) = p_duplicate_string^ (1, valid_string_length)) THEN
        variable_status := fdc$invalid_string;
        EXIT /check_duplicate_string/;
      IFEND;
    FOREND /check_duplicate_string/;

  PROCEND fdp$validate_string;

?? TITLE := 'fdp$validate_variable', EJECT ??
*copyc fdh$validate_variable

  PROCEDURE [XDCL] fdp$validate_variable
    (    form_identifier: fdt$form_identifier;
         variable_name: ost$name;
         variable_value: fdt$variable_value;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    VAR
      ignore_date_time: clt$date_time,
      name_exists: boolean,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_status: ^fdt$form_status,
      p_valid_string: ^fdt$valid_string,
      valid_name: ost$name,
      variable_index: fdt$variable_index;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$validate_variable;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$validate_variable;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    variable_status := fdc$no_error;
    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    #TRANSLATE (osv$lower_to_upper, variable_name, valid_name);
    fdp$find_variable_definition (valid_name, p_form_status^.p_form_variable_definitions,
           p_form_status^.p_form_definition^.form_variable_definitions.active_number,
           p_form_variable_definition, variable_index,name_exists);
    IF NOT name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_variable_name,
            variable_name, status);
      osp$append_status_parameter( osc$status_parameter_delimiter, p_form_status^.
            p_form_definition^.form_name, status);
      RETURN;
    IFEND;

{ Do not validate value for variable with must enter to allow
{ entry of such values as passwords.  The application does not want to show
{ the terminal user any password on the initial display.

    IF (fdc$must_enter IN p_form_variable_definition^.terminal_user_entry) THEN
      RETURN;
    IFEND;

{ Check initial value against specified valid values.

    CASE variable_value.program_data_type OF

    = fdc$program_cobol_type =
      fdp$validate_cobol_data (p_form_status, p_form_variable_definition,
              variable_value.p_cobol_data, p_valid_string, variable_status);

    = fdc$program_character_type,  fdc$program_upper_case_type =
      fdp$validate_string (variable_value.p_text, variable_value.text_length,
              p_form_variable_definition^.valid_strings, p_form_status,
              p_valid_string, variable_status);

    = fdc$program_integer_type =
      IF fdp$date_variable(p_form_variable_definition) THEN
        fdp$convert_yymmdd_to_date_time (variable_value.integer_value, ignore_date_time, variable_status);
      ELSE
      fdp$validate_integer (variable_value.integer_value, p_form_variable_definition^.
              valid_integer_ranges, p_form_status, variable_status);
      IFEND;

    = fdc$program_real_type =
      fdp$validate_real (variable_value.real_value, p_form_variable_definition^.
              valid_real_ranges, p_form_status, variable_status);

    ELSE
      osp$set_status_abnormal (fdc$format_display_identifier, fde$program_data_type,
            p_form_status^.p_form_definition^.form_name, status);
    CASEND;

  PROCEND fdp$validate_variable;

?? TITLE := 'check_form_screen_fit', EJECT ??

  PROCEDURE [INLINE] check_form_screen_fit
    (    x_position: fdt$x_position;
         y_position: fdt$y_position;
         width: fdt$width;
         height: fdt$height;
         form_name: ost$name;
     VAR status: ost$status);

    VAR
      dimension_index: integer;

      FOR dimension_index := 1 TO fdv$screen_status.screen_dimensions.sets_of_dimensions DO
        IF (((x_position + width - 1) <= fdv$screen_status.screen_dimensions.
              screen_dimensions [dimension_index].x_screen_dimension) AND
              ((y_position + height - 1) <= fdv$screen_status.screen_dimensions.
              screen_dimensions [dimension_index].y_screen_dimension)) THEN
          status.normal := TRUE;
          RETURN;
        IFEND;
      FOREND;

      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_too_large_for_screen, form_name,
            status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (x_position), 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (y_position), 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (width), 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (height), 10, FALSE, status);
  PROCEND check_form_screen_fit;

?? OLDTITLE ??
?? NEWTITLE := 'convert_to_variable_status', EJECT ??

  PROCEDURE convert_to_variable_status
    (    cobol_status: ost$status;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    status.normal := TRUE;
    CASE  cobol_status.condition OF
    = fde$cobol_nonblk_outside_paren =
      variable_status := fdc$nonblk_outside_parentheses;
    = fde$cobol_no_scientific =
      variable_status := fdc$no_scientific_notation;
    = fde$cobol_illegal_char_entered =
      variable_status := fdc$invalid_character_entered;
    = fde$cobol_two_signs_entered =
      variable_status := fdc$too_many_signs;
    = fde$cobol_no_plus_or_minus_now =
      variable_status := fdc$no_plus_or_minus_now;
    = fde$cobol_c_without_r =
      variable_status := fdc$c_without_r;
    = fde$cobol_no_cr_or_db_now =
      variable_status := fdc$no_cr_or_db_now;
    = fde$cobol_d_without_b =
      variable_status := fdc$d_without_b;
    = fde$cobol_too_many_digits =
      variable_status := fdc$gr_18_digits;
    = fde$cobol_two_points_entered =
      variable_status := fdc$too_many_decimal_points;
    = fde$cobol_trailing_sign_nonblk =
      variable_status := fdc$nonblk_after_trailing_sign;
    = fde$cobol_float_too_big =
      variable_status := fdc$floating_number_too_big;
    = fde$cobol_bad_overpunch_sign =
      variable_status := fdc$invalid_overpunch_sign;
    = fde$cobol_bad_separate_sign =
      variable_status := fdc$invalid_separate_sign;
    = fde$cobol_destination_invalid =
      variable_status := fdc$output_format_bad;
    = fde$cobol_source_invalid =
      variable_status := fdc$variable_truncated;
    ELSE
      status := cobol_status;
    CASEND;

  PROCEND convert_to_variable_status;

?? TITLE := 'display_invalid_data_character', EJECT ??

{ PURPOSE:
{   This procedure converts the characters in a screen variable to the invalid data character, if it has been
{   defined for the variable.
{
{ DESIGN:
{   Forms created prior to FDC$IM_SMART_CAPABILITY will not display an invalid data Character.
{   Set UPDATE_SCREEN to FALSE if the invalid data character is not defined so that the screen value will
{   remain unchanged.
{
{ NOTE:
{   The caller of this procedure determines if the variable has errors.

  PROCEDURE [INLINE] display_invalid_data_character
    (    p_form_status: ^fdt$form_status;
         screen_variable_length: fdt$text_length;
     VAR update_screen: boolean;
     VAR screen_variable: fdt$text);

    VAR
      character_index: fdt$text_length;


    IF p_form_status^.invalid_data_character.defined THEN
      FOR character_index := 1 TO screen_variable_length DO
        screen_variable (character_index) := p_form_status^.invalid_data_character.character;
      FOREND;
    ELSE

{ Do not update the value on the screen.

      update_screen := FALSE;
    IFEND;

  PROCEND display_invalid_data_character;
?? TITLE := 'find_next_input_error', EJECT ??

{ PURPOSE:
{   This procedure finds the next variable with an input error in the form.
{
{ NOTE:
{   A value of FDC$NO_ERROR for VARIABLE_STATUS is returned if there are no more errors in the form.

  PROCEDURE find_next_input_error
    (    p_form_status: ^fdt$form_status;
         start_object_index: fdt$object_index;
     VAR variable_name: ost$name;
     VAR occurrence: fdt$occurrence;
     VAR variable_status: fdt$variable_status);

    VAR
      object_index: fdt$object_index,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status;


    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    variable_status := fdc$no_error;

    FOR object_index := start_object_index TO UPPERBOUND (p_form_object_statuses^) DO
      CASE p_form_object_definitions^ [object_index].key OF
      = fdc$form_stored_variable, fdc$form_variable_text, fdc$form_variable_text_box =
        IF p_form_object_statuses^ [object_index].variable_input_status <> fdc$no_error THEN

{ Found next input error.

          p_form_status^.input_error_search.status := fdc$searching;
          p_form_status^.input_error_search.object_index := object_index;
          variable_name := p_form_object_definitions^ [object_index].name;
          occurrence := p_form_object_definitions^ [object_index].occurrence;
          variable_status := p_form_object_statuses^ [object_index].variable_input_status;
          RETURN;
        IFEND;
      ELSE
      CASEND;
    FOREND;

    p_form_status^.input_error_search.status := fdc$search_completed;

  PROCEND find_next_input_error;
?? TITLE := 'find_record_variable', EJECT ??

  PROCEDURE find_record_variable
    (    p_form_status: ^fdt$form_status;
         name: ost$name;
         occurrence: fdt$occurrence;
     VAR p_form_variable_definition: ^fdt$form_variable_definition;
     VAR object_exists: boolean;
     VAR object_index: fdt$object_index;
     VAR program_record_position: fdt$record_position;
     VAR screen_record_position: fdt$record_position;
     VAR status: ost$status);

    VAR
      first_displayed_occurrence: fdt$occurrence,
      name_exists: boolean,
      p_form_module: ^fdt$form_module,
      p_form_table_definition: ^fdt$form_table_definition,
      p_form_table_definitions: ^array [1 .. * ] of fdt$form_table_definition,
      p_form_table_statuses: ^array [1 .. * ] of fdt$table_status,
      p_form_variable_definitions: ^array [1 .. * ] of fdt$form_variable_definition,
      p_record_definitions: ^array [1 .. * ] of fdt$variable_record_definition,
      p_table_object: ^fdt$table_object,
      p_table_objects: ^array [1 .. * ] of fdt$table_object,
      p_table_variable: ^fdt$table_variable,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable,
      p_variable_record_definition: ^fdt$variable_record_definition,
      record_index: fdt$object_index,
      table_index: fdt$table_index,
      table_object_index: fdt$object_index,
      table_variable_index: fdt$variable_index;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT find_record_variable;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT find_record_variable;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    object_exists := FALSE;
    name_exists := FALSE;
    p_form_variable_definitions := p_form_status^.p_form_variable_definitions;
    p_form_table_definitions := p_form_status^.p_form_table_definitions;
    p_form_table_statuses := p_form_status^.p_form_table_statuses;
    p_form_module := p_form_status^.p_form_module;
    p_record_definitions := p_form_status^.p_form_record_definitions;
    IF p_record_definitions = NIL THEN
      osp$set_status_condition (fde$unknown_occurrence, status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (occurrence), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            p_form_status^.p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    FOR record_index := LOWERBOUND (p_record_definitions^) TO UPPERBOUND (p_record_definitions^) DO
      p_variable_record_definition := ^p_record_definitions^ [record_index];
      CASE p_variable_record_definition^.key OF

      = fdc$record_table =
        table_index := p_variable_record_definition^.table_index;
        p_form_table_definition := ^p_form_table_definitions^ [table_index];
        p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
              p_form_module);
        FOR table_variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
          p_table_variable := ^p_table_variables^ [table_variable_index];
          p_form_variable_definition := ^p_form_variable_definitions^ [p_table_variable^.variable_index];

          IF p_form_variable_definition^.name = name THEN
            name_exists := TRUE;
            IF (occurrence > p_form_table_definition^.stored_occurrence) OR (occurrence < 1) THEN
              osp$set_status_condition (fde$unknown_occurrence, status);
              osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (occurrence), 10, FALSE,
                    status);
              osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    p_form_status^.p_form_definition^.form_name, status);
              RETURN;
            IFEND;

            p_table_objects := fdp$ptr_table_objects (p_table_variable^.table_objects, p_form_module);
            p_table_object := ^p_table_objects^ [occurrence];
            program_record_position := p_table_object^.program_record_position;
            screen_record_position := p_table_object^.screen_record_position;
            first_displayed_occurrence := p_form_table_statuses^ [table_index].first_displayed_occurrence;
            object_index := p_table_objects^ [occurrence].object_index;
            IF (p_form_status^.displayed_on_screen AND (p_form_status^.added OR p_form_status^.combined)) THEN
              IF ((first_displayed_occurrence + p_form_table_definition^.visible_occurrence - 1) >=
                    occurrence) AND (first_displayed_occurrence <= occurrence) THEN
                object_exists := TRUE;
              IFEND;
            IFEND;
            RETURN;

          IFEND;
        FOREND;

      = fdc$record_variable =
        p_form_variable_definition := ^p_form_variable_definitions^
              [p_variable_record_definition^.variable_index];
        IF p_form_variable_definition^.name = name THEN
          name_exists := TRUE;
          IF occurrence <> 1 THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_occurrence, '', status);
            osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (occurrence), 10, FALSE,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  p_form_status^.p_form_definition^.form_name, status);
            RETURN;
          IFEND;

          program_record_position := p_form_variable_definition^.program_record_position;
          screen_record_position := p_form_variable_definition^.screen_record_position;
          object_index := p_form_variable_definition^.object_index;
          IF (p_form_status^.displayed_on_screen AND (p_form_status^.added OR p_form_status^.combined)) THEN
            object_exists := TRUE;
          IFEND;
          RETURN;
        IFEND;

      ELSE

{ Invalid record definition key.

        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'invalid record definition',
              status);
        RETURN;
      CASEND;
    FOREND;

    IF name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_occurrence, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (occurrence), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            p_form_status^.p_form_definition^.form_name, status);

    ELSE

{ Variable name does not exist.

      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_variable_name, '', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            p_form_status^.p_form_definition^.form_name, status);
    IFEND;
  PROCEND find_record_variable;


?? TITLE := 'record_attribute_change', EJECT ??
  PROCEDURE record_attribute_change
    (    form_identifier: fdt$form_identifier;
         object_index: fdt$object_index;
         new_display_attribute_set: fdt$display_attribute_set;
         old_display_attribute_set: fdt$display_attribute_set;
     VAR status: ost$status);

     VAR
       screen_change: fdt$screen_change;

     status.normal := TRUE;
     IF old_display_attribute_set = new_display_attribute_set THEN
       RETURN;
     IFEND;

     screen_change.key := fdc$set_attribute;
     screen_change.attribute_form_identifier := form_identifier;
     screen_change.attribute_object_index := object_index;
     screen_change.attribute := new_display_attribute_set;
     fdp$record_screen_change (screen_change, status);

  PROCEND record_attribute_change;

?? TITLE := 'record_value_change', EJECT ??
  PROCEDURE record_value_change
    (    form_identifier: fdt$form_identifier;
         object_index: fdt$object_index;
         p_text: ^fdt$text;
         p_form_object_statuses: ^array [1 .. *] of fdt$form_object_status;
     VAR status: ost$status);

     VAR
       screen_change: fdt$screen_change;

     status.normal := TRUE;
     IF p_form_object_statuses^ [object_index].character_position = 1 THEN
       RETURN;
     IFEND;

     screen_change.key := fdc$replace_variable;
     screen_change.variable_form_identifier := form_identifier;
     screen_change.variable_object_index := object_index;
     screen_change.p_text := p_text;
     fdp$record_screen_change (screen_change, status);

  PROCEND record_value_change;

?? OLDTITLE ??
?? NEWTITLE := 'replace_variable', EJECT ??

{ PURPOSE:
{   This procedure validates and replaces values supplied by the application for
{   Screen Formatting variables.  The program and screen records are updated
{   according to the results of the validation.

  PROCEDURE replace_variable
    (    p_form_status: ^fdt$form_status;
         form_identifier: fdt$form_identifier;
         new_value: fdt$variable_value;
         p_form_variable_definition: ^fdt$form_variable_definition;
         object_index: fdt$object_index;
         update_screen: boolean;
         program_record_position: fdt$record_position;
         screen_record_position: fdt$record_position;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

    VAR
      error: mlt$error,
      p_form_object_status: ^fdt$form_object_status,
      p_screen_variable: ^fdt$text,
      p_valid_string: ^fdt$valid_string,
      record_screen_change: boolean,
      screen_change: fdt$screen_change;

?? NEWTITLE := 'process_character_type', EJECT ??

    PROCEDURE process_character_type;

      fdp$validate_string (new_value.p_text, new_value.text_length,
            p_form_variable_definition^.valid_strings,
            p_form_status, p_valid_string, variable_status);
      IF variable_status <> fdc$no_error THEN
        IF fdc$must_enter IN p_form_variable_definition^.terminal_user_entry THEN
          p_form_object_status^.user_entered_field := FALSE;
          variable_status := fdc$no_error;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      fdp$convert_to_screen_variable (p_form_variable_definition^.program_data_type, new_value.p_text,
            new_value.text_length, p_form_variable_definition^.output_format,
            p_screen_variable, p_form_variable_definition^.screen_variable_length,
            variable_status, status);
      IF NOT status.normal THEN
        EXIT replace_variable;
      IFEND;
      IF variable_status <> fdc$no_error THEN
        RETURN;
      IFEND;
      mlp$move_bytes (new_value.p_text, new_value.text_length, ^p_form_status^.p_program_record^
            [program_record_position], p_form_variable_definition^.program_variable_length, error);

    PROCEND process_character_type;

?? OLDTITLE, EJECT ??
?? NEWTITLE := 'process_cobol_type', EJECT ??

    PROCEDURE process_cobol_type;

      fdp$validate_cobol_data (p_form_status, p_form_variable_definition,
            new_value.p_cobol_data, p_valid_string, variable_status);
      IF variable_status <> fdc$no_error THEN
        IF fdc$must_enter IN p_form_variable_definition^.terminal_user_entry THEN
          p_form_object_status^.user_entered_field := FALSE;
          variable_status := fdc$no_error;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      fdp$move_to_screen_variable (p_form_status, p_form_variable_definition,
            new_value.p_cobol_data, p_screen_variable, variable_status, status);
      IF NOT status.normal THEN
        EXIT replace_variable;
      IFEND;

      IF variable_status <> fdc$no_error THEN
        RETURN;
      IFEND;

      mlp$move_bytes (new_value.p_cobol_data, new_value.text_length, ^p_form_status^.p_program_record^
            [program_record_position], p_form_variable_definition^.program_variable_length, error);

    PROCEND process_cobol_type;

?? OLDTITLE, EJECT ??
?? NEWTITLE := 'process_integer_type', EJECT ??

    PROCEDURE process_integer_type;

      VAR
        ignore_date_time: clt$date_time;


      IF fdp$date_variable(p_form_variable_definition) THEN
        fdp$convert_yymmdd_to_date_time (new_value.integer_value, ignore_date_time, variable_status);
      ELSE
      fdp$validate_integer (new_value.integer_value,
            p_form_variable_definition^.valid_integer_ranges, p_form_status, variable_status);
      IFEND;
      IF variable_status <> fdc$no_error THEN
        IF fdc$must_enter IN p_form_variable_definition^.terminal_user_entry THEN
          p_form_object_status^.user_entered_field := FALSE;
          variable_status := fdc$no_error;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      fdp$convert_to_screen_variable (p_form_variable_definition^.program_data_type, ^new_value.integer_value,
            p_form_variable_definition^.program_variable_length, p_form_variable_definition^.output_format,
            p_screen_variable, p_form_variable_definition^.screen_variable_length,
            variable_status, status);
      IF NOT status.normal THEN
        EXIT replace_variable;
      IFEND;
      IF variable_status <> fdc$no_error THEN
        RETURN;
      IFEND;

      i#move (^new_value.integer_value, ^p_form_status^.p_program_record^ [program_record_position],
            fdc$integer_length);

    PROCEND process_integer_type;

?? OLDTITLE, EJECT ??
?? NEWTITLE := 'process_real_type', EJECT ??

    PROCEDURE process_real_type;

      fdp$validate_real (new_value.real_value, p_form_variable_definition^.valid_real_ranges,
            p_form_status, variable_status);
      IF variable_status <> fdc$no_error THEN
        IF fdc$must_enter IN p_form_variable_definition^.terminal_user_entry THEN
          p_form_object_status^.user_entered_field := FALSE;
          variable_status := fdc$no_error;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      fdp$convert_to_screen_variable (p_form_variable_definition^.program_data_type, ^new_value.real_value,
            p_form_variable_definition^.program_variable_length, p_form_variable_definition^.output_format,
            p_screen_variable, p_form_variable_definition^.screen_variable_length,
            variable_status, status);
      IF NOT status.normal THEN
        EXIT replace_variable;
      IFEND;
      IF variable_status <> fdc$no_error THEN
        RETURN;
      IFEND;

      i#move (^new_value.real_value, ^p_form_status^.p_program_record^ [program_record_position],
            fdc$real_length);

    PROCEND process_real_type;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'process_upper_case_type', EJECT ??

    PROCEDURE process_upper_case_type;

      fdp$validate_string (new_value.p_text, new_value.text_length,
              p_form_variable_definition^.valid_strings,
              p_form_status, p_valid_string, variable_status);
      IF variable_status <> fdc$no_error THEN
        IF fdc$must_enter IN p_form_variable_definition^.terminal_user_entry THEN
          p_form_object_status^.user_entered_field := FALSE;
          variable_status := fdc$no_error;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      fdp$convert_to_screen_variable (p_form_variable_definition^.program_data_type, new_value.p_text,
            new_value.text_length, p_form_variable_definition^.output_format,
            p_screen_variable, p_form_variable_definition^.screen_variable_length,
            variable_status, status);
      IF NOT status.normal THEN
        EXIT replace_variable;
      IFEND;
      IF variable_status <> fdc$no_error THEN
        RETURN;
      IFEND;

{ The program data must be translated to uppercase, so that if the terminal
{ user does not enter any data the program will get the data in upper case.

      mlp$translate_bytes (new_value.p_text, new_value.text_length, ^p_form_status^.
            p_program_record^ [program_record_position],
            p_form_variable_definition^.program_variable_length, ^osv$lower_to_upper, error);

    PROCEND process_upper_case_type;

?? OLDTITLE, EJECT ??

    p_form_object_status := ^p_form_status^.p_form_object_statuses^ [object_index];
    p_form_object_status^.variable_input_status := fdc$no_error;
    fdp$ptr_screen_variable (p_form_status^.p_screen_record, screen_record_position,
          p_form_variable_definition^.screen_variable_length, p_screen_variable);

    CASE p_form_variable_definition^.program_data_type OF

    = fdc$program_character_type =
      process_character_type;

    = fdc$program_cobol_type =
      process_cobol_type;

    = fdc$program_integer_type =
      process_integer_type;

    = fdc$program_real_type =
      process_real_type;

    = fdc$program_upper_case_type =
      process_upper_case_type;

    ELSE

{ Invalid program data type.

      osp$set_status_abnormal (fdc$format_display_identifier, fde$program_data_type, '', status);
      RETURN;
    CASEND;

    record_screen_change := update_screen;
    IF variable_status <> fdc$no_error THEN

{ The invalid data character must be substituted even if the field is not currently visible.  Subsequent
{ updates may cause the field to be displayed before the error is corrected.

      display_invalid_data_character (p_form_status, p_form_variable_definition^.screen_variable_length,
            record_screen_change, p_screen_variable^);
    IFEND;

    IF record_screen_change THEN
      screen_change.key := fdc$replace_variable;
      screen_change.variable_form_identifier := form_identifier;
      screen_change.variable_object_index := object_index;
      screen_change.p_text := p_screen_variable;
      fdp$record_screen_change (screen_change, status);
    IFEND;

  PROCEND replace_variable;
?? TITLE := 'update_form_priorities', EJECT ??

  PROCEDURE [INLINE] update_form_priorities
    (    p_form_status: ^fdt$form_status);

    IF p_form_status^.next_higher_form <> 0 THEN
      fdv$screen_status.p_forms_status^ [p_form_status^.next_higher_form].next_lower_form :=
            p_form_status^.next_lower_form;

    ELSE

{ The highest priority form is being deleted.
{ Update pointer to highest priority form.

      fdv$screen_status.current_form_identifier := p_form_status^.next_lower_form;
    IFEND;
    IF p_form_status^.next_lower_form <> 0 THEN
      fdv$screen_status.p_forms_status^ [p_form_status^.next_lower_form].next_higher_form :=
            p_form_status^.next_higher_form;
    IFEND;
  PROCEND update_form_priorities;

MODEND fdm$process_program_requests;
*DECK DECK=FDM$PROCESS_RECORD EXPAND=TRUE

?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Screen Formatting: Process Record' ??
MODULE fdm$process_record;

{ PURPOSE:
{   This module creates, changes, and gets data about a form record definition.
{
{ DESIGN:
{   Do not make any changes to a form record definition if any of the chanages are invalid.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc cyd$run_time_error_condition
*copyc fde$condition_identifiers
*copyc fdc$system_record_type
*copyc fdt$form_definition
*copyc fdt$form_identifier
*copyc fdt$form_module
*copyc fdt$form_status
*copyc fdt$form_table_definition
*copyc fdt$form_variable_definition
*copyc fdt$get_record_attributes
*copyc fdt$record_attribute_index
*copyc fdt$record_attributes
*copyc fdt$record_definition_key
*copyc fdt$table_index
*copyc fdt$table_variable_index
*copyc fdt$table_variable
*copyc fdt$table_variables
*copyc fdt$variable_index
*copyc fdt$variable_record_definition
*copyc ost$name
?? POP ??

*copyc clp$validate_name
*copyc fdp$find_change_form_definition
*copyc fdp$find_form_definition
*copyc fdp$find_table_definition
*copyc fdp$ptr_record_definitions
*copyc fdp$validate_name
*copyc pmp$continue_to_cause
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal

?? TITLE := 'fdp$change_form_record', EJECT ??
*copyc fdh$change_form_record

  PROCEDURE [XDCL] fdp$change_form_record
    (    form_identifier: fdt$form_identifier;
     VAR record_attributes: fdt$record_attributes;
     VAR status: ost$status);

    VAR
      n: fdt$record_attribute_index,
      name_exists: boolean,
      name_is_valid: boolean,
      p_form_definition: ^fdt$form_definition,
      p_form_status: ^fdt$form_status,
      p_form_table_definition: ^fdt$form_table_definition,
      table_index: fdt$table_index,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$change_form_record;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$change_form_record;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_change_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR n := LOWERBOUND (record_attributes) TO UPPERBOUND (record_attributes) DO
      record_attributes [n].put_value_status := fdc$unprocessed_put_value;
    FOREND;

    p_form_definition := p_form_status^.p_form_definition;

  /process_record_attributes/
    FOR n := LOWERBOUND (record_attributes) TO UPPERBOUND (record_attributes) DO

      CASE record_attributes [n].key OF

      = fdc$record_deck_name =
        IF record_attributes [n].record_deck_name = ' ' THEN
          p_form_definition^.record_deck_name := '';
          record_attributes [n].put_value_status := fdc$put_value_accepted;
        ELSE
          clp$validate_name (record_attributes [n].record_deck_name, valid_name, name_is_valid);
          IF NOT name_is_valid THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_deck_name,
                  record_attributes [n].record_deck_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  p_form_definition^.form_name, status);
            RETURN;
          IFEND;
          p_form_definition^.record_deck_name := valid_name;
          record_attributes [n].put_value_status := fdc$put_value_accepted;
        IFEND;

      = fdc$record_name =
        IF record_attributes [n].record_name = ' ' THEN
          p_form_definition^.record_name := ' ';
          record_attributes [n].put_value_status := fdc$put_value_accepted;

        ELSE
          fdp$validate_name (record_attributes [n].record_name, p_form_definition^.processor, valid_name,
                name_is_valid);
          IF NOT name_is_valid THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_record_name,
                  record_attributes [n].record_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  p_form_definition^.form_name, status);
            RETURN;
          IFEND;
          p_form_definition^.record_name := valid_name;
          record_attributes [n].put_value_status := fdc$put_value_accepted;
        IFEND;

      = fdc$record_type =
        IF ((record_attributes [n].record_type = fdc$program_data_type_record) OR
              (record_attributes [n].record_type = fdc$character_record)) THEN
          p_form_definition^.record_type := record_attributes [n].record_type;
          record_attributes [n].put_value_status := fdc$put_value_accepted;

        ELSE
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_record_type,
                record_attributes [n].table_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;
        IFEND;

      = fdc$table_access =
        fdp$validate_name (record_attributes [n].table_name, p_form_definition^.processor, valid_name,
              name_is_valid);
        IF NOT name_is_valid THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_table_name,
                record_attributes [n].table_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;
        IFEND;

        fdp$find_table_definition (valid_name, p_form_status^.p_form_table_definitions,
              p_form_definition^.form_table_definitions.active_number, p_form_table_definition, table_index,
              name_exists);
        IF NOT name_exists THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_table_name,
                record_attributes [n].table_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;
        IFEND;

        p_form_table_definition^.access_all_occurrences := record_attributes [n].access_all_occurrences;
        record_attributes [n].put_value_status := fdc$put_value_accepted;

      = fdc$unused_record_entry =
        record_attributes [n].put_value_status := fdc$put_value_accepted;

      ELSE

{ The record attribute is invalid.

        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_record_attribute,
              p_form_definition^.form_name, status);
        RETURN;

      CASEND;
    FOREND /process_record_attributes/;

  PROCEND fdp$change_form_record;

?? TITLE := 'fdp$get_record_attributes', EJECT ??
*copyc fdh$get_record_attributes

  PROCEDURE [XDCL] fdp$get_record_attributes
    (    form_identifier: fdt$form_identifier;
     VAR get_record_attributes: fdt$get_record_attributes;
     VAR status: ost$status);

    VAR
      current_name_index: fdt$variable_index,
      j: fdt$variable_index,
      n: fdt$record_attribute_index,
      name_exists: boolean,
      name_is_valid: boolean,
      p_form_definition: ^fdt$form_definition,
      p_form_module: ^fdt$form_module,
      p_form_status: ^fdt$form_status,
      p_form_table_definition: ^fdt$form_table_definition,
      p_form_table_definitions: ^array [1 .. * ] of fdt$form_table_definition,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_variable_definitions: ^array [1 .. * ] of fdt$form_variable_definition,
      p_record_definitions: ^array [1 .. * ] of fdt$variable_record_definition,
      p_table_variable: ^fdt$table_variable,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable,
      p_variable_record_definition: ^fdt$variable_record_definition,
      record_definition_key: fdt$record_definition_key,
      table_index: fdt$table_index,
      table_variable_index: fdt$table_variable_index,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_record_attributes;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_record_attributes;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    FOR n := LOWERBOUND (get_record_attributes) TO UPPERBOUND (get_record_attributes) DO
      get_record_attributes [n].get_value_status := fdc$unprocessed_get_value;
    FOREND;

    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_name_index := 1;
    p_record_definitions := p_form_status^.p_form_record_definitions;
    p_form_definition := p_form_status^.p_form_definition;
    p_form_module := p_form_status^.p_form_module;
    p_form_variable_definitions := p_form_status^.p_form_variable_definitions;
    p_form_table_definitions := p_form_status^.p_form_table_definitions;
    FOR n := LOWERBOUND (get_record_attributes) TO UPPERBOUND (get_record_attributes) DO

    /process_record_attributes/
      BEGIN
        CASE get_record_attributes [n].key OF

        = fdc$get_record_deck_name =
          get_record_attributes [n].record_deck_name := p_form_definition^.record_deck_name;
          IF p_form_definition^.record_deck_name = osc$null_name THEN
            get_record_attributes [n].get_value_status := fdc$undefined_value;
          ELSE
            get_record_attributes [n].get_value_status := fdc$user_defined_value;
          IFEND;

        = fdc$get_record_length =
          get_record_attributes [n].record_length := p_form_definition^.program_record_length;
          get_record_attributes [n].get_value_status := fdc$system_computed_value;

        = fdc$get_record_name =
          IF p_form_definition^.record_name = osc$null_name THEN
            get_record_attributes [n].get_value_status := fdc$undefined_value;
          ELSE
            get_record_attributes [n].record_name := p_form_definition^.record_name;
            get_record_attributes [n].get_value_status := fdc$user_defined_value;
          IFEND;

        = fdc$get_record_type =
          get_record_attributes [n].record_type := p_form_definition^.record_type;
          IF p_form_definition^.record_type = fdc$system_record_type THEN
            get_record_attributes [n].get_value_status := fdc$system_default_value;
          ELSE
            get_record_attributes [n].get_value_status := fdc$user_defined_value;
          IFEND;

        = fdc$get_table_access =
          fdp$validate_name (get_record_attributes [n].table_name, p_form_definition^.processor, valid_name,
                name_is_valid);
          IF NOT name_is_valid THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_table_name,
                  get_record_attributes [n].table_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          fdp$find_table_definition (valid_name, p_form_status^.p_form_table_definitions,
                p_form_definition^.form_table_definitions.active_number, p_form_table_definition, table_index,
                name_exists);
          IF NOT name_exists THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_table_name,
                  get_record_attributes [n].table_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          get_record_attributes [n].access_all_occurrences := p_form_table_definition^.access_all_occurrences;

        = fdc$get_unused_record_entry =
          get_record_attributes [n].get_value_status := fdc$undefined_value;

        ELSE

{ Invalid record attribute.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_record_attribute,
                p_form_definition^.form_name, status);
          RETURN;
        CASEND;
      END /process_record_attributes/;
    FOREND;

  PROCEND fdp$get_record_attributes;

MODEND fdm$process_record;
*DECK DECK=FDM$PROCESS_SCREEN_INPUT_OUTPUT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Screen Formatting : Process Screen Input Output' ??
MODULE fdm$process_screen_input_output;

{ PURPOSE:
{   This module process requests to do terminal input and output.
{
{ DESIGN:
{   The Screen Manager is called to do terminal input and output.

?? LIBRARY := 'TUF$LIBRARY' ??

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc amk$base_keypoint_values
*copyc cle$ecc_lexical
*copyc cse$condition_codes
*copyc cst$event_name_identifier
*copyc cst$event_type
*copyc cst$key_type
*copyc cst$string
*copyc csv$vector
*copyc cyd$run_time_error_condition
*copyc fdc$basic_capability
*copyc fdc$im_smart_capability
*copyc fdc$message_form_capability
*copyc fdc$reassign_event_capability
*copyc fdc$validation_capability
*copyc fdc$integer_length
*copyc fdc$new_line_character
*copyc fdc$message_form_name
*copyc fdc$message_variable_name
*copyc fdc$real_length
*copyc fdc$system_design_table_name
*copyc fdc$system_display_name
*copyc fde$condition_identifiers
*copyc fdk$screen_formatting_keypoints
*copyc fdt$display_index
*copyc fdt$event_index
*copyc fdt$event_menu
*copyc fdt$event_position
*copyc fdt$form_attributes
*copyc fdt$form_object_definition
*copyc fdt$form_object_key
*copyc fdt$message_text
*copyc fdt$number_errors
*copyc fdt$object_definition
*copyc fdt$object_attribute
*copyc fdt$screen_change_index
*copyc fdt$screen_to_form_event
*copyc fdt$screen_variable_length
*copyc fdt$table_attribute
*copyc fdt$valid_integer_index
*copyc fdt$valid_real_index
*copyc fdt$valid_string_index
*copyc fdt$variable_attribute
*copyc fdt$variable_status
*copyc fdt$work_area_length
*copyc ife$error_codes
*copyc jme$transaction_job_disconnect
*copyc lle$loader_status_conditions
*copyc ost$name
?? POP ??

*copyc fdv$application_event_table
*copyc fdv$screen_status
*copyc fdv$colors
*copyc fdv$message_variable_name

*copyc clp$find_form
*copyc clp$validate_name

*copyc fdp$add_form
*copyc fdp$change_form
*copyc fdp$close_form
*copyc fdp$convert_yymmdd_to_date_time
*copyc fdp$create_form
*copyc fdp$create_form_status
*copyc fdp$create_event_form
*copyc fdp$create_message_form
*copyc fdp$create_object
*copyc fdp$create_table
*copyc fdp$create_variable
*copyc fdp$date_variable
*copyc fdp$delete_screen_changes
*copyc fdp$end_form
*copyc fdp$find_display_name
*copyc fdp$find_form_definition
*copyc fdp$find_form_status
*copyc fdp$find_object_definition
*copyc fdp$get_message
*copyc fdp$initialize_form_objects
*copyc fdp$initialize_form_record
*copyc fdp$move_to_program_variable
*copyc fdp$ptr_displays
*copyc fdp$ptr_events
*copyc fdp$ptr_objects
*copyc fdp$ptr_record_definitions
*copyc fdp$ptr_screen_variable
*copyc fdp$ptr_table_objects
*copyc fdp$ptr_table_variables
*copyc fdp$ptr_tables
*copyc fdp$ptr_text
*copyc fdp$ptr_valid_integers
*copyc fdp$ptr_valid_reals
*copyc fdp$ptr_valid_strings
*copyc fdp$ptr_variable
*copyc fdp$ptr_variables
*copyc fdp$record_screen_change
*copyc fdp$replace_string_variable
*copyc fdp$reset_object_attribute
*copyc fdp$set_cursor_position
*copyc fdp$set_object_attribute
*copyc fdp$validate_cobol_data
*copyc fdp$validate_integer
*copyc fdp$validate_real
*copyc fdp$validate_string

*copyc i#move
*copyc mlp$move_bytes
*copyc mmp$delete_scratch_segment
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_condition
*copyc osp$get_status_condition_string
*copyc osp$set_status_abnormal

*copyc pmp$continue_to_cause
*copyc pmp$exit

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    fdc$forms_to_expand = 7,
    fdc$hidden_editing_multiplier = 2,
    fdc$screen_changes_to_expand = 10;

  TYPE
    fdt$data_position = (fdc$top_of_box, fdc$bottom_of_box, fdc$shift_characters,
          fdc$page_data_first, fdc$page_data_last, fdc$page_data_forward,
          fdc$page_data_backward, fdc$scroll_data_forward, fdc$scroll_data_backward,
          fdc$current_data_position),

    fdt$target_position = record
      case key: fdt$data_position of
      = fdc$top_of_box, fdc$bottom_of_box, fdc$scroll_data_forward, fdc$scroll_data_backward =
        data_index: fdt$text_length,
      = fdc$shift_characters =
        shift: integer,
      = fdc$page_data_first, fdc$page_data_last, fdc$page_data_forward,
              fdc$page_data_backward, fdc$current_data_position =
        ,
      casend
    recend;

  VAR
    record_separator: [READ, STATIC] string (1) := $CHAR(30),
    screen_event_table: [READ, STATIC] array [csc$insert_line .. csc$clear] of fdt$event_trigger :=
          [fdc$insert_line, fdc$delete_line, fdc$home_cursor, fdc$clear_screen],
    standard_event_table: [READ, STATIC] array [csc$next .. csc$sh_undo] of fdt$event_trigger :=
          [fdc$next, fdc$shift_next, fdc$help, fdc$shift_help, fdc$stop, fdc$shift_stop, fdc$back,
          fdc$shift_back, fdc$up, fdc$shift_up, fdc$down, fdc$shift_down, fdc$forward, fdc$shift_forward,
          fdc$backward, fdc$shift_backward, fdc$edit, fdc$shift_edit, fdc$data, fdc$shift_data, fdc$undo,
          fdc$undo];

?? TITLE := 'fdp$change_screen', EJECT ??
*copyc fdh$change_screen

  PROCEDURE [XDCL] fdp$change_screen
    (VAR status: ost$status);

    VAR
      current_form_identifier: fdt$next_form_identifier,
      cursor_character_position: fdt$character_position,
      display_attribute_set: fdt$display_attribute_set,
      end_character_position: cst$character_position,
      field_number: cst$field_number,
      form_identifier: fdt$form_identifier,
      form_name: ost$name,
      local_status: ost$status,
      n: integer,
      next_object_index: fdt$object_index,
      object_index: fdt$object_index,
      output_character_position: cst$character_position,
      output_line_position: cst$line_number,
      p_form_definition: ^fdt$form_definition,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_form_status: ^fdt$form_status,
      p_form_table_definition: ^fdt$form_table_definition,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_screen_change: ^fdt$screen_change,
      p_screen_text: ^fdt$text,
      p_table_objects: ^array [1 .. * ] of fdt$table_object,
      p_table_variable: ^fdt$table_variable,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable,
      screen_visible_length: fdt$screen_variable_length,
      shift: integer,
      start_character_position: cst$character_position,
      table_index: fdt$table_index,
      table_shifted: boolean,
      target_position: fdt$target_position,
      terminal_status: ost$status,
      variable_index: fdt$variable_index;

?? NEWTITLE := 'clean_up', EJECT ??

    PROCEDURE [INLINE] clean_up;

      fdv$screen_status.number_screen_changes := 0;
      EXIT fdp$change_screen;
    PROCEND clean_up;

?? OLDTITLE ??
?? NEWTITLE := 'compute_new_screen_size', EJECT ??

    PROCEDURE compute_new_screen_size;

      VAR
        actual_screen_height: cst$line_number,
        actual_screen_width: cst$visible_character_position,
        dimensions_accepted: boolean,
        form_x_position: fdt$x_position,
        form_y_position: fdt$y_position,
        new_screen_height: fdt$height,
        new_screen_width: fdt$width,
        p_event_form_status: ^fdt$form_status,
        screen_height: fdt$height,
        screen_width: fdt$width;

      current_form_identifier := fdv$screen_status.current_form_identifier;
      new_screen_width := 1;
      new_screen_height := 1;

      /compute_screen_size/
        REPEAT
          p_form_status := ^fdv$screen_status.p_forms_status^ [current_form_identifier];
          IF (p_form_status^.added OR p_form_status^.combined) THEN
            p_form_definition := p_form_status^.p_form_definition;
            form_x_position := p_form_status^.form_x_position;
            form_y_position := p_form_status^.form_y_position;
            screen_height := form_y_position + p_form_definition^.height - 1;
            screen_width := form_x_position + p_form_definition^.width - 1;

            IF screen_width > new_screen_width THEN
              new_screen_width := screen_width;
              form_name := p_form_definition^.form_name;
            IFEND;

            IF screen_height > new_screen_height THEN
              new_screen_height := screen_height;
              form_name := p_form_definition^.form_name;
            IFEND;

          IFEND;
          current_form_identifier := p_form_status^.next_lower_form;
        UNTIL current_form_identifier = 0;

        IF ((fdv$screen_status.current_screen_width = new_screen_width) AND
              (fdv$screen_status.current_screen_height = new_screen_height)) THEN
          RETURN;
        IFEND;

        csv$vector.change_device_dimensions^ (new_screen_width, new_screen_height, dimensions_accepted,
              terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          clean_up;
        IFEND;

        csv$vector.get_device_dimensions^ (actual_screen_width, actual_screen_height, terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          clean_up;
        IFEND;

        fdv$screen_status.current_screen_width := actual_screen_width;
        fdv$screen_status.current_screen_height := actual_screen_height;
        IF ((actual_screen_width < new_screen_width) OR (actual_screen_height < new_screen_height)) THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$form_too_large_for_screen, ' ', status);
          clean_up;
        IFEND;

      current_form_identifier := fdv$screen_status.current_form_identifier;
      /reposition_event_form/
        REPEAT
          p_form_status := ^fdv$screen_status.p_forms_status^ [current_form_identifier];
          IF (p_form_status^.added OR p_form_status^.combined) THEN
            IF p_form_status^.event_form_defined THEN
              p_event_form_status := ^fdv$screen_status.p_forms_status^
                    [p_form_status^.event_form_identifier];
              IF NOT p_event_form_status^.displayed_on_screen THEN
                p_event_form_status^.form_y_position := actual_screen_height -
                      p_event_form_status^.p_form_definition^.height + 1;
              IFEND;
            IFEND;
          IFEND;
          current_form_identifier := p_form_status^.next_lower_form;
        UNTIL current_form_identifier = 0;

      PROCEND compute_new_screen_size;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    IF fdv$screen_status.compute_new_screen_size THEN
      fdv$screen_status.compute_new_screen_size := FALSE;
      IF fdv$screen_status.current_form_identifier <> 0 THEN

{ Forms have been added, deleted, or positioned.  Compute new screen
{ size needed to contain all forms.

        compute_new_screen_size;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

{ Update screen from list of changes to forms.

    FOR n := 1 TO fdv$screen_status.number_screen_changes DO
      p_screen_change := ^fdv$screen_status.p_screen_changes^ [n];
      CASE p_screen_change^.key OF

      = fdc$add_form =
        p_form_status := ^fdv$screen_status.p_forms_status^ [p_screen_change^.form_identifier];
        create_screen_objects (p_form_status, status);
        IF NOT status.normal THEN
          delete_screen_objects (p_form_status, local_status);
          clean_up;
        IFEND;

        fdv$screen_status.number_active_forms := fdv$screen_status.number_active_forms + 1;
        p_form_status^.displayed_on_screen := TRUE;
        p_form_status^.events_active := TRUE;

      = fdc$change_table_size =
        p_form_status := ^fdv$screen_status.p_forms_status^ [p_screen_change^.table_form_identifier];
        shift_table (p_form_status, ^p_form_status^.p_form_table_definitions^ [p_screen_change^.table_index],
              p_screen_change^.table_index, 0, 0, status);
        IF NOT status.normal THEN
          delete_screen_objects (p_form_status, local_status);
          clean_up;
        IFEND;

      = fdc$close_form =
        p_form_status := ^fdv$screen_status.p_forms_status^ [p_screen_change^.close_form_identifier];
        IF p_form_status^.displayed_on_screen THEN
          fdv$screen_status.number_active_forms := fdv$screen_status.number_active_forms - 1;
          delete_screen_objects (p_form_status, local_status);
          p_form_status^.displayed_on_screen := FALSE;
        IFEND;

        IF p_form_status^.p_form_object_statuses <> NIL THEN
          FREE p_form_status^.p_form_object_statuses;
        IFEND;
        IF p_form_status^.defined_dynamically THEN
          mmp$delete_scratch_segment (p_form_status^.segment_pointer, local_status);
        IFEND;
        p_form_status^.entry_used := FALSE;

      = fdc$create_mark =
        p_form_status := ^fdv$screen_status.p_forms_status^ [p_screen_change^.create_mark_form_identifier];
        field_number := p_form_status^.p_form_object_statuses^ [p_screen_change^.create_mark_object_index].
              field_number;
        start_character_position := p_screen_change^.start_x_position;
        end_character_position := p_screen_change^.end_x_position;
        csv$vector.mark^ (field_number, start_character_position, 1, end_character_position, 1,
              csc$character_marking, terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          clean_up;
        IFEND;

      = fdc$delete_form, fdc$erase_form =
        p_form_status := ^fdv$screen_status.p_forms_status^ [p_screen_change^.form_identifier];
        fdv$screen_status.number_active_forms := fdv$screen_status.number_active_forms - 1;
        p_form_status^.displayed_on_screen := FALSE;
        delete_screen_objects (p_form_status, status);
        IF NOT status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          clean_up;
        IFEND;

      = fdc$delete_mark =
        p_form_status := ^fdv$screen_status.p_forms_status^ [p_screen_change^.create_mark_form_identifier];
        csv$vector.mark^ (p_form_status^.p_form_object_statuses^ [p_screen_change^.
              delete_mark_object_index]. field_number, 1, 1, 1, 1, csc$unmark, terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          clean_up;
        IFEND;

    = fdc$format_text_box =
      p_form_status := ^fdv$screen_status.p_forms_status^ [p_screen_change^.format_text_form_identifier];
      target_position.key := fdc$current_data_position;
      object_index := p_screen_change^.format_text_object_index;
      p_form_object_definition := ^p_form_status^.p_form_object_definitions^ [object_index];
      format_screen_text (p_screen_change^.p_format_text, p_form_status, object_index,
            p_form_object_definition^.variable_box_fragment_index,
            p_form_object_definition^.variable_box_processing,
            p_form_object_definition^.variable_box_width,
            p_form_object_definition^.variable_box_height,
            target_position, status);

      = fdc$no_screen_change =

{ Do nothing. Some more recent change eliminated the change.

      = fdc$open_form =

{ Do nothing at this time. When part of Screen Formatting runs on
{ a micro downline load form.

      = fdc$replace_variable =
        p_form_status := ^fdv$screen_status.p_forms_status^ [p_screen_change^.variable_form_identifier];
        object_index := p_screen_change^.variable_object_index;
        p_form_object_definition := ^p_form_status^.p_form_object_definitions^ [object_index];

        CASE p_form_object_definition^.key OF

        = fdc$form_constant_text =
          target_position.key := fdc$current_data_position;
          replace_screen_variable (p_screen_change^.p_text, object_index, object_index,
                p_form_object_definition^.constant_text_width, p_form_status, target_position, status);
          IF NOT status.normal THEN
            clean_up;
          IFEND;

        = fdc$form_constant_text_box =
          target_position.key := fdc$current_data_position;
          format_screen_text (p_screen_change^.p_text, p_form_status, object_index,
                p_form_object_definition^.constant_box_fragment_index,
                p_form_object_definition^.constant_box_processing,
                p_form_object_definition^.constant_box_width, p_form_object_definition^.constant_box_height,
                target_position, status);
          IF NOT status.normal THEN
            clean_up;
          IFEND;

        = fdc$form_variable_text_box =
          next_object_index := p_form_object_definition^.variable_box_fragment_index;
          target_position.key := fdc$current_data_position;
          format_screen_text (p_screen_change^.p_text, p_form_status, object_index, next_object_index,
                p_form_object_definition^.variable_box_processing,
                p_form_object_definition^.variable_box_width, p_form_object_definition^.variable_box_height,
                target_position, status);
          IF NOT status.normal THEN
            clean_up;
          IFEND;

        = fdc$form_variable_text =
          p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                [p_form_object_definition^.text_variable_index];
          IF p_form_variable_definition^.table_exists THEN
            table_index := p_form_variable_definition^.table_index;
            IF p_form_status^.p_form_table_statuses^ [table_index].
                  first_displayed_occurrence <> 1 THEN

{ The table has been scrolled.  Find place to replace variable.

              p_form_table_definition := ^p_form_status^.p_form_table_definitions^ [table_index];
              p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
                  p_form_status^.p_form_module);

            /find_table_variable/
              FOR variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
                p_table_variable := ^p_table_variables^ [variable_index];
                IF p_table_variable^.name = p_form_object_definition^.name THEN
                  EXIT /find_table_variable/;
                IFEND;
              FOREND /find_table_variable/;

              p_table_objects := fdp$ptr_table_objects (p_table_variable^.table_objects,
                    p_form_status^.p_form_module);
              object_index := p_table_objects^ [p_form_object_definition^.occurrence -
                    p_form_status^.p_form_table_statuses^ [table_index].first_displayed_occurrence +
                    1].object_index;
              p_form_object_definition := ^p_form_status^.p_form_object_definitions^ [object_index];
            IFEND;
          IFEND;

          target_position.key := fdc$current_data_position;
          replace_screen_variable (p_screen_change^.p_text, object_index,
                p_screen_change^.variable_object_index,
                p_form_object_definition^.text_variable_width,
                p_form_status, target_position, status);
          IF NOT status.normal THEN
              clean_up;
          IFEND;

        = fdc$form_stored_variable =
          p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                [p_form_object_definition^.stored_variable_index];
          table_index := p_form_variable_definition^.table_index;
          p_form_table_definition := ^p_form_status^.p_form_table_definitions^ [table_index];
          p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
                p_form_status^.p_form_module);

        /find_variable/
          FOR variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
            p_table_variable := ^p_table_variables^ [variable_index];
            IF p_table_variable^.name = p_form_object_definition^.name THEN
              EXIT /find_variable/;
            IFEND;
          FOREND /find_variable/;

          p_table_objects := fdp$ptr_table_objects (p_table_variable^.table_objects,
                p_form_status^.p_form_module);
          object_index := p_table_objects^ [p_form_object_definition^.occurrence -
                p_form_status^.p_form_table_statuses^ [table_index].first_displayed_occurrence +
                1].object_index;
          p_form_object_definition := ^p_form_status^.p_form_object_definitions^ [object_index];
          target_position.key := fdc$current_data_position;
          replace_screen_variable (p_screen_change^.p_text, object_index,
                p_screen_change^.variable_object_index, p_form_object_definition^.text_variable_width,
                p_form_status, target_position, status);
          IF NOT status.normal THEN
            clean_up;
          IFEND;

        ELSE
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
                'invalid object for screen change', status);
          clean_up;
        CASEND;

      = fdc$reset_event_variable =

{ This action removes the highlight from a event menu variable.  The event menu
{ variable was highlighted when the terminal user pressed the associated
{ key. This change was scheduled during the last read_forms request.  Since the
{ last read_forms request the application may have deleted the event menu form.

        form_identifier := p_screen_change^.attribute_form_identifier;
        p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
        IF (p_form_status^.entry_used AND p_form_status^.displayed_on_screen) THEN
          p_form_object_statuses := p_form_status^.p_form_object_statuses;
          p_form_object_definitions := p_form_status^.p_form_object_definitions;
          object_index := p_screen_change^.attribute_object_index;
          p_form_object_definition := ^p_form_object_definitions^ [object_index];
          p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                [p_form_object_definition^.text_variable_index];
          put_text_attribute (p_form_object_statuses^ [object_index].field_number,
                p_screen_change^.attribute, p_form_variable_definition^.io_mode, local_status);
        IFEND;

      = fdc$set_attribute =
        form_identifier := p_screen_change^.attribute_form_identifier;
        p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
        p_form_object_statuses := p_form_status^.p_form_object_statuses;
        p_form_object_definitions := p_form_status^.p_form_object_definitions;
        object_index := p_screen_change^.attribute_object_index;
        p_form_object_definition := ^p_form_object_definitions^ [object_index];

        CASE p_form_object_definition^.key OF

        = fdc$form_box, fdc$form_line =
          put_graphic_attribute (p_form_object_statuses^ [object_index].graphic_identifier,
                p_screen_change^.attribute, status);
          IF NOT status.normal THEN
            clean_up;
          IFEND;

        = fdc$form_constant_text_box =
          display_attribute_set := p_screen_change^.attribute;
          put_text_attribute (p_form_object_statuses^ [object_index].field_number, display_attribute_set,
                fdc$terminal_output, status);
          IF NOT status.normal THEN
            clean_up;
          IFEND;

          object_index := p_form_object_definition^.constant_box_fragment_index;
          WHILE object_index <> 0 DO
            put_text_attribute (p_form_object_statuses^ [object_index].field_number, display_attribute_set,
                  fdc$terminal_output, status);
            IF NOT status.normal THEN
              clean_up;
            IFEND;
            object_index := p_form_object_definitions^ [object_index].next_fragment_object_index;
          WHILEND;

        = fdc$form_stored_variable =
          p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                [p_form_object_definition^.stored_variable_index];

{ If the variable is a member of a table, the table may be shifted to make the
{ variable visible to the terminal user.

          set_attribute (p_form_status, p_form_variable_definition, p_screen_change^.attribute, object_index,
                p_form_object_definition, table_shifted, status);
          IF NOT status.normal THEN
            clean_up;
          IFEND;

          IF table_shifted THEN

{ Delete any changes done while  shifting the table.

            delete_replace_variable (p_form_status, form_identifier, p_form_variable_definition^.table_index,
                  n);
          IFEND;

        = fdc$form_variable_text_box =
          p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                [p_form_object_definition^.variable_box_variable_index];
          field_number := p_form_object_statuses^ [object_index].field_number;
          display_attribute_set := p_screen_change^.attribute;
          put_text_attribute (p_form_object_statuses^ [object_index].field_number, display_attribute_set,
                p_form_variable_definition^.io_mode, status);
          IF NOT status.normal THEN
            clean_up;
          IFEND;

          object_index := p_form_object_definition^.variable_box_fragment_index;
          WHILE object_index <> 0 DO
            put_text_attribute (p_form_object_statuses^ [object_index].field_number, display_attribute_set,
                  p_form_variable_definition^.io_mode, status);
            IF NOT status.normal THEN
              clean_up;
            IFEND;
            object_index := p_form_object_definitions^ [object_index].next_fragment_object_index;
          WHILEND;

        = fdc$form_variable_text =
          p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                [p_form_object_definition^.text_variable_index];

{ If the variable is a member of a table, the table may be shifted to make
{ the variable visible to the terminal user.

          set_attribute (p_form_status, p_form_variable_definition, p_screen_change^.attribute, object_index,
                p_form_object_definition, table_shifted, status);
          IF NOT status.normal THEN
            clean_up;
          IFEND;

          IF table_shifted THEN

{ Delete any changes done while shifting the table.

            delete_replace_variable (p_form_status, form_identifier, p_form_variable_definition^.table_index,
                  n);
          IFEND;

        = fdc$form_constant_text =
          put_text_attribute (p_form_object_statuses^ [object_index].field_number, p_screen_change^.attribute,
                fdc$terminal_output, status);
          IF NOT status.normal THEN
            clean_up;
          IFEND;

        ELSE
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
                'invalid object for screen change', status);
          clean_up;
        CASEND;

      = fdc$add_object =
        p_form_status := ^fdv$screen_status.p_forms_status^ [p_screen_change^.object_form_identifier];
        add_screen_object (p_form_status, p_screen_change^.object_definition, p_screen_change^.object_index,
              status);
        IF NOT status.normal THEN
          clean_up;
        IFEND;

      = fdc$delete_object =
        p_form_status := ^fdv$screen_status.p_forms_status^ [p_screen_change^.object_form_identifier];
        p_form_object_statuses := p_form_status^.p_form_object_statuses;
        object_index := p_screen_change^.object_index;
        CASE p_form_object_statuses^ [object_index].key OF

        = fdc$graphic_identifier =
          csv$vector.delete_graphic^ (p_form_object_statuses^ [object_index].graphic_identifier,
                terminal_status);

        = fdc$field_identifier =
          csv$vector.delete_field^ (p_form_object_statuses^ [object_index].field_number, terminal_status);

        ELSE
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
                'invalid object status key', terminal_status);
        CASEND;

        p_form_object_statuses^ [object_index].key := fdc$unused_identifier;
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          clean_up;
        IFEND;

      = fdc$set_cursor =
        form_identifier := p_screen_change^.cursor_form_identifier;
        p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
        p_form_object_statuses := p_form_status^.p_form_object_statuses;
        p_form_object_definitions := p_form_status^.p_form_object_definitions;
        object_index := p_screen_change^.cursor_object_index;
        p_form_object_definition := ^p_form_object_definitions^ [object_index];
        cursor_character_position := p_screen_change^.cursor_character_position;
        CASE p_form_object_definition^.key OF

        = fdc$form_constant_text =
          screen_visible_length := p_form_object_definition^.constant_text_width;
          compute_cursor_shift (screen_visible_length,
                p_form_object_statuses^ [object_index].character_position, cursor_character_position, shift);
          IF shift <> 0 THEN

{ Shift the variable to make the cursor position visible to the terminal user.

            p_screen_text := fdp$ptr_text (p_form_object_definition^.constant_text,
                  p_form_status^.p_form_module);
            target_position.key := fdc$shift_characters;
            target_position.shift := shift;
            replace_screen_variable (p_screen_text, object_index, object_index, screen_visible_length,
                  p_form_status, target_position, status);
            IF NOT status.normal THEN
              clean_up;
            IFEND;
          IFEND;

          cursor_character_position := cursor_character_position -
                p_form_object_statuses^ [object_index].character_position + 1;
          csv$vector.position_cursor^ (p_form_status^.p_form_object_statuses^
                [object_index].field_number, cursor_character_position, 1,
                output_character_position, output_line_position, terminal_status);
          IF NOT terminal_status.normal THEN
            fdp$convert_terminal_status (terminal_status, status);
            clean_up;
          IFEND;

          fdv$screen_status.cursor_set := TRUE;

        = fdc$form_constant_text_box =
          p_screen_text := fdp$ptr_text (p_form_object_definition^.constant_box_text,
                p_form_status^.p_form_module);
          set_text_box_cursor_position (p_form_status, p_screen_text, object_index,
                p_form_object_definition^.constant_box_fragment_index,
                p_form_object_definition^.constant_box_processing,
                p_form_object_definition^.constant_box_width, p_form_object_definition^.constant_box_height,
                cursor_character_position, status);
          IF NOT status.normal THEN
            clean_up;
          IFEND;

          fdv$screen_status.cursor_set := TRUE;

        = fdc$form_stored_variable =
          p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                [p_form_object_definition^.stored_variable_index];

{ If the variable is a member of a table, the table may be shifted to make
{ the variable visible to the terminal user.

          set_table_cursor_position (p_form_status, p_form_variable_definition, p_form_object_definition,
                object_index, cursor_character_position, table_shifted, status);
          IF NOT status.normal THEN
            clean_up;
          IFEND;
          fdv$screen_status.cursor_set := TRUE;

          IF table_shifted THEN

{ Delete any changes done while shifting the table.

            delete_replace_variable (p_form_status, form_identifier, p_form_variable_definition^.table_index,
                  n);
          IFEND;

        = fdc$form_variable_text =
          p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                [p_form_object_definition^.text_variable_index];
          IF p_form_variable_definition^.table_exists THEN
            set_table_cursor_position (p_form_status, p_form_variable_definition, p_form_object_definition,
                  object_index, cursor_character_position, table_shifted, status);
            IF NOT status.normal THEN
              clean_up;
            IFEND;
            fdv$screen_status.cursor_set := TRUE;

            IF table_shifted THEN

{ Delete any changes done while shifting the table.

              delete_replace_variable (p_form_status, form_identifier,
                    p_form_variable_definition^.table_index, n);
            IFEND;

          ELSE

{ The object does not belong to a table.

            screen_visible_length := p_form_object_definition^.text_variable_width;
            compute_cursor_shift (screen_visible_length,
                  p_form_object_statuses^ [object_index].character_position, cursor_character_position,
                  shift);
            IF shift <> 0 THEN

{ Shift the variable to make the cursor position visible to the terminal user.

              fdp$ptr_screen_variable (p_form_status^.p_screen_record,
                    p_form_variable_definition^.screen_record_position, p_form_variable_definition^.
                    screen_variable_length, p_screen_text);
              target_position.key := fdc$shift_characters;
              target_position.shift := shift;
              replace_screen_variable (p_screen_text, object_index, object_index, screen_visible_length,
                    p_form_status, target_position, status);
              IF NOT status.normal THEN
                clean_up;
              IFEND;

            IFEND;

            cursor_character_position := cursor_character_position -
                  p_form_object_statuses^ [object_index].character_position + 1;
            csv$vector.position_cursor^ (p_form_status^.p_form_object_statuses^
                  [object_index].field_number, cursor_character_position, 1,
                  output_character_position, output_line_position, terminal_status);
            IF NOT terminal_status.normal THEN
              fdp$convert_terminal_status (terminal_status, status);
              clean_up;
            IFEND;
            fdv$screen_status.cursor_set := TRUE;
          IFEND;

        = fdc$form_variable_text_box =
          p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                [p_form_object_definition^.variable_box_variable_index];
          fdp$ptr_screen_variable (p_form_status^.p_screen_record,
                p_form_variable_definition^.screen_record_position, p_form_variable_definition^.
                screen_variable_length, p_screen_text);
          set_text_box_cursor_position (p_form_status, p_screen_text, object_index,
                p_form_object_definition^.variable_box_fragment_index,
                p_form_object_definition^.variable_box_processing,
                p_form_object_definition^.variable_box_width, p_form_object_definition^.variable_box_height,
                cursor_character_position, status);
          IF NOT status.normal THEN
            clean_up;
          IFEND;
          fdv$screen_status.cursor_set := TRUE;

        ELSE
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
                'invalid object for screen change', status);
          clean_up;
        CASEND;

      ELSE
        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'invalid screen change',
              status);
        clean_up;
      CASEND;
    FOREND;

    clean_up;
  PROCEND fdp$change_screen;

?? TITLE := 'fdp$convert_terminal_status', EJECT ??
*copyc fdh$convert_terminal_status

  PROCEDURE [XDCL] fdp$convert_terminal_status
    (    terminal_status: ost$status;
     VAR new_status: ost$status);

    VAR
      status: ost$status,
      str_rec: ost$string;

    CASE terminal_status.condition OF

    = ife$connection_break_disconnect, ife$job_disconnect_interactive, ife$job_disconnect_batch,
      jme$transaction_job_disconnect =
      osp$set_status_abnormal (fdc$format_display_identifier, fde$terminal_disconnected, '', new_status);

    = lle$entry_point_not_found, cle$improper_name, cse$undefined_terminal_model=
      osp$set_status_abnormal (fdc$format_display_identifier, fde$terminal_not_identified, '', new_status);

    = ife$terminate_break_received =
      pmp$exit (terminal_status);

    ELSE
      osp$get_status_condition_string (terminal_status.condition, str_rec, status);
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, str_rec.
            value (1, str_rec.size), new_status);
    CASEND;

  PROCEND fdp$convert_terminal_status;

?? TITLE := 'fdp$create_design_form', EJECT ??
*copyc fdh$create_design_form

  PROCEDURE [XDCL] fdp$create_design_form
    (VAR form_identifier: fdt$form_identifier;
     VAR form_attributes: fdt$form_attributes;
     VAR status: ost$status);

    VAR
      design_form_attributes: array [1 .. 1] of fdt$form_attribute,
      form_height: fdt$height,
      form_width: fdt$width,
      form_x_position: fdt$x_position,
      form_y_position: fdt$y_position,
      p_errors: ^SEQ ( * ),
      p_initial_value: ^fdt$text,
      local_status: ost$status,
      number_of_characters: cst$visible_character_position,
      number_of_lines: cst$line_number,
      number_errors: fdt$number_errors,
      object_definition: fdt$object_definition,
      object_attributes: array [1 .. 2] of fdt$object_attribute,
      p_form_definition: ^fdt$form_definition,
      p_form_status: ^fdt$form_status,
      table_attributes: array [1 .. 3] of fdt$table_attribute,
      table_name: ost$name,
      terminal_status: ost$status,
      variable_attributes: array [1 .. 2] of fdt$variable_attribute,
      variable_name: ost$name,
      x_position: fdt$x_position,
      y_position: fdt$y_position;

?? NEWTITLE := 'condition_handler', EJECT ??

  PROCEDURE condition_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         stack_frame_save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    CASE condition.selector OF

    = pmc$system_conditions =
      IF (condition.system_conditions * $pmt$system_conditions
            [pmc$instruction_specification, pmc$address_specification,
            pmc$access_violation, pmc$invalid_segment_ring_0, pmc$divide_fault,
            pmc$arithmetic_overflow, pmc$exponent_overflow,
            pmc$exponent_underflow, pmc$fp_significance_loss,
            pmc$fp_indefinite, pmc$arithmetic_significance,
            pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$create_design_form;
      IFEND;

    = pmc$user_defined_condition =
      IF condition.user_condition_name = cye$run_time_condition THEN
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$bad_data_value, '', status);
        EXIT fdp$create_design_form;
      IFEND;

    ELSE
      ;
    CASEND;
    pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
  PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$create_form (form_identifier, form_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$find_form_definition (form_identifier, p_form_status, status);
    p_form_definition := p_form_status^.p_form_definition;
    table_name := fdc$system_design_table_name;
    variable_name := p_form_status^.design_variable_name;
    CASE p_form_definition^.form_area.key OF

    = fdc$defined_area =
      form_x_position := p_form_definition^.form_area.x_position;
      form_y_position := p_form_definition^.form_area.y_position;
      form_width := p_form_definition^.form_area.width;
      form_height := p_form_definition^.form_area.height;

    = fdc$screen_area =
      form_x_position := 1;
      form_y_position := 1;
      IF NOT fdv$screen_status.screen_mode_active THEN
        csv$vector.change_capability_level^ (csc$screen_level, terminal_status);
        IF ((NOT terminal_status.normal) AND (terminal_status.condition <> cse$redundant_screen_level)) THEN
          fdp$convert_terminal_status (terminal_status, status);
          fdp$close_form (form_identifier, local_status);
          RETURN;
        IFEND;
        fdv$screen_status.screen_mode_active := TRUE;
      IFEND;

{ The design form has the current dimensions of the terminal. }
{ Its dimensions cannot be changed. }

      csv$vector.get_device_dimensions^ (number_of_characters, number_of_lines, terminal_status);
      IF NOT terminal_status.normal THEN
        fdp$convert_terminal_status (terminal_status, status);
        fdp$close_form (form_identifier, local_status);
        RETURN;
      IFEND;

      form_width := number_of_characters;
      form_height := number_of_lines;
      design_form_attributes [1].key := fdc$form_area;
      design_form_attributes [1].form_area.key := fdc$defined_area;
      design_form_attributes [1].form_area.x_position := 1;
      design_form_attributes [1].form_area.y_position := 1;
      design_form_attributes [1].form_area.width := number_of_characters;
      design_form_attributes [1].form_area.height := number_of_lines;
      fdp$change_form (form_identifier, design_form_attributes, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
             'create design form create table failed', status);
        fdp$close_form (form_identifier, local_status);
      IFEND;
    ELSE
    CASEND;

{ Create a table that covers the screen.  The table has one variable. }
{ The variable allows programs to get and replace free text on the design form. }

    table_attributes [1].key := fdc$stored_occurrence;
    table_attributes [1].stored_occurrence := form_height;
    table_attributes [2].key := fdc$visible_occurrence;
    table_attributes [2].visible_occurrence := form_height;
    table_attributes [3].key := fdc$add_table_variable;
    table_attributes [3].variable_name := variable_name;
    fdp$create_table (form_identifier, table_name, table_attributes, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
           'create design form create table failed', status);
      fdp$close_form (form_identifier, local_status);
      RETURN;
    IFEND;

    variable_attributes [1].key := fdc$variable_length;
    variable_attributes [1].variable_length := form_width;
    variable_attributes [2].key := fdc$program_data_type;
    variable_attributes [2].program_data_type := fdc$program_character_type;
    fdp$create_variable (form_identifier, variable_name, variable_attributes, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
           'create design form create variable failed', status);
      fdp$close_form (form_identifier, local_status);
      RETURN;
    IFEND;

{ Create text objects for the screen table. }

    p_form_status^.design_form := TRUE;
    object_definition.key := fdc$variable_text;
    object_definition.variable_text_width := form_width;
    PUSH p_initial_value: [form_width];
    p_initial_value^ := ' ';
    object_definition.p_variable_text := p_initial_value;
    object_attributes [1].key := fdc$object_name;
    object_attributes [1].object_name := variable_name;
    object_attributes [2].key := fdc$object_display;
    object_attributes [2].display_attribute := $fdt$display_attribute_set [];

    FOR y_position := 1 TO form_height DO
      object_attributes [1].occurrence := y_position;
      fdp$create_object (form_identifier, 1, y_position, object_definition, object_attributes, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
             'create design form create object failed', status);
        fdp$close_form (form_identifier, local_status);
        RETURN;
      IFEND;
    FOREND;

    fdp$end_form (form_identifier, NIL, number_errors, p_errors, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
           'create design form end form failed', status);
      fdp$close_form (form_identifier, local_status);
      RETURN;
    IFEND;

    IF number_errors <> 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
           'create design form end form failed', status);
      fdp$close_form (form_identifier, local_status);
    IFEND;

    ALLOCATE p_form_status^.p_form_image;
    IF p_form_status^.p_form_image = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available,'',status);
      RETURN;
    IFEND;

    FOR y_position := 1 to fdc$maximum_y_position DO
      p_form_status^.p_form_image^ [y_position] := ' ';
    FOREND;

  PROCEND fdp$create_design_form;
?? TITLE := 'fdp$create_form_events', EJECT ??
*copyc fdh$create_form_events

  PROCEDURE [XDCL] fdp$create_form_events
    (    form_identifier: fdt$form_identifier;
         display_attribute_set: fdt$display_attribute_set;
     VAR status: ost$status);

    TYPE
      fdt$event_trigger_set = set of fdt$event_trigger;

    TYPE
      fdt$shift_event_map = record
        case shift_trigger_exists: boolean of
        = FALSE =
          event_trigger: fdt$event_trigger,
        = TRUE =
          unshifted_event_trigger: fdt$event_trigger,
        casend,
      recend;

    VAR
      application_trigger_exists: boolean,
      application_trigger_set: [READ] set of fdt$event_trigger :=
            [fdc$function_1, fdc$function_2, fdc$function_3, fdc$function_4, fdc$function_5, fdc$function_6,
            fdc$function_7, fdc$function_8, fdc$function_9, fdc$function_10, fdc$function_11, fdc$function_12,
            fdc$function_13, fdc$function_14, fdc$function_15, fdc$function_16, fdc$shift_function_1,
            fdc$shift_function_2, fdc$shift_function_3, fdc$shift_function_4, fdc$shift_function_5,
            fdc$shift_function_6, fdc$shift_function_7, fdc$shift_function_8, fdc$shift_function_9,
            fdc$shift_function_10, fdc$shift_function_11, fdc$shift_function_12, fdc$shift_function_13,
            fdc$shift_function_14, fdc$shift_function_15, fdc$shift_function_16],
      event_index: fdt$event_index,
      event_form_identifier: fdt$form_identifier,
      event_trigger: fdt$event_trigger,
      form_attributes: array [1 .. 4] of fdt$form_attribute,
      local_status: ost$status,
      n: integer,
      next_event_trigger: fdt$event_trigger,
      number_application_events: integer,
      number_events: integer,
      p_event_definition: ^fdt$event_definition,
      p_event_definitions: ^array [1 .. * ] of fdt$event_definition,
      p_event_menus: ^array [1 .. * ] of fdt$event_menu,
      p_form_definition: ^fdt$form_definition,
      p_form_event_statuses: ^array [1 .. * ] of fdt$form_event_status,
      p_form_status: ^fdt$form_status,
      preferred_triggers: [READ] array [1 .. 32] of fdt$event_trigger :=
            [fdc$function_1, fdc$function_2, fdc$function_3, fdc$function_4, fdc$function_5, fdc$function_6,
            fdc$function_7, fdc$function_8, fdc$shift_function_1, fdc$shift_function_2, fdc$shift_function_3,
            fdc$shift_function_4, fdc$shift_function_5, fdc$shift_function_6, fdc$shift_function_7,
            fdc$shift_function_8, fdc$function_9, fdc$function_10, fdc$function_11, fdc$function_12,
            fdc$function_13, fdc$function_14, fdc$function_15, fdc$function_16, fdc$shift_function_9,
            fdc$shift_function_10, fdc$shift_function_11, fdc$shift_function_12, fdc$shift_function_13,
            fdc$shift_function_14, fdc$shift_function_15, fdc$shift_function_16],
      shift_event_maps: [READ] array [fdc$next .. fdc$variable_trigger] of fdt$shift_event_map :=
            [[FALSE, fdc$next], [FALSE, fdc$help], [FALSE, fdc$stop], [FALSE, fdc$back], [FALSE, fdc$up],
            [FALSE, fdc$down], [FALSE, fdc$forward], [FALSE, fdc$backward], [FALSE, fdc$undo],
            [FALSE, fdc$redo], [FALSE, fdc$quit], [FALSE, fdc$exit], [FALSE, fdc$first], [FALSE, fdc$last],
            [FALSE, fdc$edit], [FALSE, fdc$data], [FALSE, fdc$function_1], [FALSE, fdc$function_2],
            [FALSE, fdc$function_3], [FALSE, fdc$function_4], [FALSE, fdc$function_5],
            [FALSE, fdc$function_6], [FALSE, fdc$function_7], [FALSE, fdc$function_8],
            [FALSE, fdc$function_9], [FALSE, fdc$function_10], [FALSE, fdc$function_11],
            [FALSE, fdc$function_12], [FALSE, fdc$function_13], [FALSE, fdc$function_14],
            [FALSE, fdc$function_15], [FALSE, fdc$function_16], [TRUE, fdc$next], [TRUE, fdc$help],
            [TRUE, fdc$stop], [TRUE, fdc$back], [TRUE, fdc$up], [TRUE, fdc$down], [TRUE, fdc$forward],
            [TRUE, fdc$backward], [TRUE, fdc$edit], [TRUE, fdc$data], [TRUE, fdc$function_1],
            [TRUE, fdc$function_2], [TRUE, fdc$function_3], [TRUE, fdc$function_4], [TRUE, fdc$function_5],
            [TRUE, fdc$function_6], [TRUE, fdc$function_7], [TRUE, fdc$function_8], [TRUE, fdc$function_9],
            [TRUE, fdc$function_10], [TRUE, fdc$function_11], [TRUE, fdc$function_12],
            [TRUE, fdc$function_13], [TRUE, fdc$function_14], [TRUE, fdc$function_15],
            [TRUE, fdc$function_16], [FALSE, fdc$pick], [FALSE, fdc$insert_line], [FALSE, fdc$delete_line],
            [FALSE, fdc$home_cursor], [FALSE, fdc$clear_screen], [FALSE, fdc$time_out],
            [FALSE, fdc$variable_trigger]],
      shifted_preferred_triggers: [READ] array [1 .. 16] of fdt$event_trigger :=
            [fdc$shift_function_1, fdc$shift_function_2, fdc$shift_function_3, fdc$shift_function_4,
            fdc$shift_function_5, fdc$shift_function_6, fdc$shift_function_7, fdc$shift_function_8,
            fdc$shift_function_9, fdc$shift_function_10, fdc$shift_function_11, fdc$shift_function_12,
            fdc$shift_function_13, fdc$shift_function_14, fdc$shift_function_15, fdc$shift_function_16],
      standard_trigger_set: [READ] set of fdt$event_trigger :=
            [fdc$help, fdc$stop, fdc$shift_stop, fdc$back, fdc$forward, fdc$shift_forward, fdc$backward,
            fdc$shift_backward, fdc$undo, fdc$undo],
      unshifted_preferred_triggers: [READ] array [1 .. 16] of fdt$event_trigger :=
            [fdc$function_1, fdc$function_2, fdc$function_3, fdc$function_4, fdc$function_5, fdc$function_6,
            fdc$function_7, fdc$function_8, fdc$function_9, fdc$function_10, fdc$function_11, fdc$function_12,
            fdc$function_13, fdc$function_14, fdc$function_15, fdc$function_16];

?? NEWTITLE := 'assign_trigger', EJECT ??

    PROCEDURE assign_trigger;

?? NEWTITLE := 'store_assignment', EJECT ??

      PROCEDURE [INLINE] store_assignment;

        fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_used := TRUE;
        p_form_event_statuses^ [event_index].event_exists := TRUE;
        event_trigger := fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_trigger;
        p_form_event_statuses^ [event_index].event_trigger := event_trigger;
        IF event_trigger IN application_trigger_set THEN
          application_trigger_exists := TRUE;
        IFEND;

      PROCEND store_assignment;

?? OLDTITLE, EJECT ??

{ First try to use the event trigger defined by the application during form
{ definition that
{ corresponds to the Terminal Definition key.

      IF (fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_exists AND
            (NOT fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_used)) THEN
        IF (fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_trigger = event_trigger) THEN
          store_assignment;
          RETURN;

{ The terminal definition has reassigned the function key.

        ELSEIF reassign_trigger(event_index) THEN
          store_assignment;
          RETURN;
        IFEND;
      IFEND;

{ If event trigger does not exist on terminal then assign event trigger from
{ list of terminal triggers in priority order.
{ Try to minimize the number of terminal keys used.

      IF NOT reassign_trigger(event_index) THEN
        RETURN;
      IFEND;

      FOR n := LOWERBOUND (preferred_triggers) TO UPPERBOUND (preferred_triggers) DO
        event_trigger := preferred_triggers [n];
        IF (fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_exists AND
              (NOT fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_used)) THEN
          store_assignment;
          RETURN;
        IFEND;
      FOREND;
    PROCEND assign_trigger;

?? OLDTITLE, EJECT ??
?? NEWTITLE := 'assign_trigger_pair', EJECT ??

    PROCEDURE assign_trigger_pair;

      VAR
        trial_event_trigger: fdt$event_trigger,
        shifted_event_trigger: fdt$event_trigger;

?? NEWTITLE := 'store_assignment', EJECT ??

      PROCEDURE [INLINE] store_assignment;

        fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_used := TRUE;
        fdv$screen_status.p_screen_event_statuses^ [next_event_trigger].event_used := TRUE;
        p_form_event_statuses^ [event_index].event_exists := TRUE;
        event_trigger := fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_trigger;
        p_form_event_statuses^ [event_index].event_trigger := event_trigger;
        p_form_event_statuses^ [event_index + 1].event_exists := TRUE;
        next_event_trigger := fdv$screen_status.p_screen_event_statuses^ [next_event_trigger].event_trigger;
        p_form_event_statuses^ [event_index + 1].event_trigger := next_event_trigger;
        IF event_trigger IN application_trigger_set THEN
          application_trigger_exists := TRUE;
        IFEND;

      PROCEND store_assignment;

?? OLDTITLE, EJECT ??

{ First try to use the event trigger defined by the application during form
{ definition that
{ corresponds to the Terminal Definition key.


      IF (fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_exists AND
            (NOT fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_used) AND
            fdv$screen_status.p_screen_event_statuses^ [next_event_trigger].event_exists AND
            (NOT fdv$screen_status.p_screen_event_statuses^ [next_event_trigger].event_used)) THEN
        IF (fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_trigger =  event_trigger) AND
              (fdv$screen_status.p_screen_event_statuses^ [next_event_trigger].event_trigger =
              next_event_trigger) THEN

{ The triggers exist on the terminal.

            store_assignment;
            RETURN;

{ The triggers do not exist on the terminal.  Assign only if user says reassignment is valid.

        ELSEIF (reassign_trigger(event_index) AND reassign_trigger(event_index+1)) THEN
          store_assignment;
            RETURN;
        IFEND;
      IFEND;

{ If event trigger does not exist on terminal then assign trigger
{ form terminal in given priority order.
{ Try to minimize the number of terminal keys used.

      IF NOT reassign_trigger(event_index) THEN
        RETURN;
      IFEND;

      FOR n := LOWERBOUND (shifted_preferred_triggers) TO UPPERBOUND (shifted_preferred_triggers) DO
        trial_event_trigger := unshifted_preferred_triggers [n];
        shifted_event_trigger := shifted_preferred_triggers [n];
        IF (fdv$screen_status.p_screen_event_statuses^ [trial_event_trigger].event_exists AND
              NOT fdv$screen_status.p_screen_event_statuses^ [trial_event_trigger].event_used AND
              fdv$screen_status.p_screen_event_statuses^ [shifted_event_trigger].event_exists AND
              NOT fdv$screen_status.p_screen_event_statuses^ [shifted_event_trigger].event_used) THEN
          fdv$screen_status.p_screen_event_statuses^ [trial_event_trigger].event_used := TRUE;
          fdv$screen_status.p_screen_event_statuses^ [shifted_event_trigger].event_used := TRUE;
          p_form_event_statuses^ [event_index].event_exists := TRUE;
          trial_event_trigger := fdv$screen_status.p_screen_event_statuses^ [trial_event_trigger].
                event_trigger;
          p_form_event_statuses^ [event_index].event_trigger := trial_event_trigger;
          p_form_event_statuses^ [event_index + 1].event_exists := TRUE;
          shifted_event_trigger := fdv$screen_status.p_screen_event_statuses^ [shifted_event_trigger].
                event_trigger;
          p_form_event_statuses^ [event_index + 1].event_trigger := shifted_event_trigger;
          application_trigger_exists := TRUE;
          RETURN;
        IFEND;
      FOREND;

{ The events could not be paired on a single key.

      assign_trigger;
    PROCEND assign_trigger_pair;

?? OLDTITLE, EJECT ??
?? NEWTITLE := 'reassign_trigger', EJECT ??

    FUNCTION reassign_trigger(event_index:fdt$event_index): boolean;

      IF p_form_definition^.screen_formatting_version < fdc$reassign_event_capability THEN
        reassign_trigger := TRUE;
      ELSE
        reassign_trigger := p_event_definitions^ [event_index].event_trigger_reassignment;
      IFEND;

    FUNCEND reassign_trigger;


?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    IF fdv$screen_status.p_screen_event_statuses = NIL THEN

{ Get terminal event definitions from the Screen Manager.

      fdp$get_screen_events (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Assign like event triggers of different forms to the same terminal key.

    p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
    application_trigger_exists := FALSE;
    p_form_definition := p_form_status^.p_form_definition;
    p_form_event_statuses := p_form_status^.p_form_event_statuses;
    p_event_definitions := p_form_status^.p_event_definitions;

    FOR event_trigger := LOWERBOUND (fdv$screen_status.p_screen_event_statuses^)
          TO UPPERBOUND (fdv$screen_status.p_screen_event_statuses^) DO
      fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_used := FALSE;
    FOREND;

    number_events := p_form_definition^.event_definitions.active_number;
    FOR event_index := 1 TO number_events DO
      p_form_event_statuses^ [event_index].event_exists := FALSE;
    FOREND;

{ Assign standard triggers.  Any standard triggers not used by the form are
{ available for
{ assignment to other events.

  /assign_standard_triggers/
    FOR event_index := 1 TO number_events DO
      event_trigger := p_event_definitions^ [event_index].event_trigger;
      IF NOT (event_trigger IN standard_trigger_set) THEN
        CYCLE /assign_standard_triggers/;
      IFEND;

      IF (fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_exists AND
            NOT fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_used) THEN
        IF(fdv$screen_status.p_screen_event_statuses^ [event_trigger].
              event_trigger <> event_trigger) THEN

{ The standard trigger has been assigned to a terminal application function
{ key. The standard trigger
{ does not exist on the terminal.

          IF reassign_trigger(event_index) THEN
            next_event_trigger := fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_trigger;
            fdv$screen_status.p_screen_event_statuses^ [next_event_trigger].event_used := TRUE;
            fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_used := TRUE;
            p_form_event_statuses^ [event_index].event_exists := TRUE;
            p_form_event_statuses^ [event_index].event_trigger := next_event_trigger;
            application_trigger_exists := TRUE;
          IFEND;

        ELSE

{ The standard trigger exists on the terminal.

          fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_used := TRUE;
          p_form_event_statuses^ [event_index].event_exists := TRUE;
          p_form_event_statuses^ [event_index].event_trigger := event_trigger;
        IFEND;
      IFEND;
    FOREND /assign_standard_triggers/;

{ Create event triggers the form requires.
{ The event triggers are sorted in high to low priority assignment order.
{ Ignore events that cannot be assigned on terminal.  The  application program
{ has assigned a priority to the terminal events and will interact with
{ the terminal up to the capability of the terminal.

  /assign_event_trigger/
    FOR event_index := 1 TO number_events DO
      IF p_form_event_statuses^ [event_index].event_exists THEN
        CYCLE /assign_event_trigger/;
      IFEND;

{ Attempt to pair unshifted and shifted triggers.

      event_trigger := p_event_definitions^ [event_index].event_trigger;
      IF ((event_index + 1) <= number_events) THEN
        next_event_trigger := p_event_definitions^ [event_index + 1].event_trigger;
        IF (shift_event_maps [next_event_trigger].shift_trigger_exists) AND
              (shift_event_maps [next_event_trigger].unshifted_event_trigger = event_trigger) THEN
          assign_trigger_pair;
          CYCLE /assign_event_trigger/;
        IFEND;
      IFEND;

      assign_trigger;
    FOREND /assign_event_trigger/;

    IF ((application_trigger_exists) AND (p_form_definition^.event_form_definition.key =
          fdc$system_default_event_form)) THEN
      number_application_events := 0;

{ Create screen formatting default event form.

      FOR event_index := 1 TO number_events DO
        IF p_form_event_statuses^ [event_index].event_exists THEN
          number_application_events := number_application_events + 1;
        IFEND;
      FOREND;

      PUSH p_event_menus: [1 .. number_application_events];
      number_application_events := 0;
      FOR event_index := 1 TO number_events DO
        p_event_definition := ^p_event_definitions^ [event_index];
        IF p_form_event_statuses^ [event_index].event_exists THEN
          number_application_events := number_application_events + 1;
          p_event_menus^ [number_application_events].event_trigger :=
                p_form_event_statuses^ [event_index].event_trigger;
          p_event_menus^ [number_application_events].event_name := p_event_definition^.event_name;
          p_event_menus^ [number_application_events].event_label := p_event_definition^.event_label;
        IFEND;
      FOREND;

      form_attributes [1].key := fdc$add_display_definition;
      form_attributes [1].display_name := fdc$system_display_name;
      form_attributes [1].display_attribute := $fdt$display_attribute_set
            [fdc$low_intensity, fdc$inverse_video];
      form_attributes [2].key := fdc$form_display_attribute;
      form_attributes [2].form_display_attribute := display_attribute_set -
            $fdt$display_attribute_set [fdc$fine_border, fdc$medium_border, fdc$bold_border];
      form_attributes [3].key := fdc$form_processor;
      form_attributes [3].form_processor := p_form_definition^.processor;
      form_attributes [4].key := fdc$fast_form_creation;
      form_attributes [4].fast_form_creation := TRUE;
      fdp$create_event_form (p_event_menus^, form_attributes, event_form_identifier, status);
      p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
      p_form_status^.event_form_identifier := event_form_identifier;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fdp$open_form (osc$null_name, event_form_identifier, status);
      IF NOT status.normal THEN
        fdp$close_form (event_form_identifier, local_status);
        RETURN;
      IFEND;
      p_form_status^.event_form_defined := TRUE;
    IFEND;
  PROCEND fdp$create_form_events;

?? TITLE := 'fdp$find_next_object', EJECT ??
*copyc fdh$find_next_object

{ DESIGN:
{   This procedure searches the object definitions until the first one beyond the specified position is
{   encountered.  The object definitions are ordered by location.
{

  PROCEDURE [XDCL] fdp$find_next_object
    (    x_position: fdt$x_position;
         y_position: fdt$y_position;
         p_form_status: ^fdt$form_status;
     VAR object_index: fdt$object_index);

    VAR
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition;

    p_form_object_definitions := p_form_status^.p_form_object_definitions;

{ All form objects are sorted by form location.  Look for next object.

    FOR object_index := 1 TO p_form_status^.p_form_definition^.form_object_definitions.active_number DO
      p_form_object_definition := ^p_form_object_definitions^ [object_index];
      CASE p_form_object_definition^.key OF

      = fdc$form_variable_text, fdc$form_text_box_fragment, fdc$form_variable_text_box =
        IF ((p_form_object_definition^.y_position = y_position) AND
              (p_form_object_definition^.x_position > x_position)) THEN

{ Found the next object on the same terminal line.

          RETURN;
        IFEND;

        IF p_form_object_definition^.y_position > y_position THEN

{ Found the next object on a following terminal line.

          RETURN;
        IFEND;

      ELSE

{ Ignore objects that are not variables and objects that do not have an x, y position.

      CASEND;
    FOREND;

{ No objects follow the specified position.  Start search from the beginning of the form.

    object_index := 1;

  PROCEND fdp$find_next_object;

?? TITLE := 'fdp$get_screen_events', EJECT ??
*copyc fdh$get_screen_events

  PROCEDURE [XDCL] fdp$get_screen_events
    (VAR status: ost$status);

    VAR
      application_function: cst$application_functions,
      device_attributes: array [1 .. 1] of cst$device_attribute,
      event_trigger: fdt$event_trigger,
      event_identifier: cst$event_name_identifier,
      form_to_screen_events: [READ, STATIC] array [fdc$next .. fdc$variable_trigger] of
            fdt$screen_to_form_event := [[FALSE, csc$standard_function, csc$next],
            [FALSE, csc$standard_function, csc$help], [FALSE, csc$standard_function, csc$stop],
            [FALSE, csc$standard_function, csc$back], [FALSE, csc$standard_function, csc$up],
            [FALSE, csc$standard_function, csc$down], [FALSE, csc$standard_function, csc$forward],
            [FALSE, csc$standard_function, csc$backward], [FALSE, csc$standard_function, csc$undo],
            [TRUE, csc$standard_function, csc$sh_undo], [FALSE, csc$unused_entry] {fdc$quit} ,
            [TRUE, csc$unused_entry]
            {fdc$exit} , [TRUE, csc$unused_entry] {fdc$first} , [TRUE, csc$unused_entry] {fdc$last} ,
            [FALSE, csc$standard_function, csc$edit], [FALSE, csc$standard_function, csc$data],
            [FALSE, csc$application_function, csc$f1], [FALSE, csc$application_function, csc$f2],
            [FALSE, csc$application_function, csc$f3], [FALSE, csc$application_function, csc$f4],
            [FALSE, csc$application_function, csc$f5], [FALSE, csc$application_function, csc$f6],
            [FALSE, csc$application_function, csc$f7], [FALSE, csc$application_function, csc$f8],
            [FALSE, csc$application_function, csc$f9], [FALSE, csc$application_function, csc$f10],
            [FALSE, csc$application_function, csc$f11], [FALSE, csc$application_function, csc$f12],
            [FALSE, csc$application_function, csc$f13], [FALSE, csc$application_function, csc$f14],
            [FALSE, csc$application_function, csc$f15], [FALSE, csc$application_function, csc$f16],
            [TRUE, csc$standard_function, csc$sh_next], [TRUE, csc$standard_function, csc$sh_help],
            [TRUE, csc$standard_function, csc$sh_stop], [TRUE, csc$standard_function, csc$sh_back],
            [TRUE, csc$standard_function, csc$sh_up], [TRUE, csc$standard_function, csc$sh_down],
            [TRUE, csc$standard_function, csc$sh_forward], [TRUE, csc$standard_function, csc$sh_backward],
            [TRUE, csc$standard_function, csc$sh_edit], [TRUE, csc$standard_function, csc$sh_data],
            [TRUE, csc$application_function, csc$sf1], [TRUE, csc$application_function, csc$sf2],
            [TRUE, csc$application_function, csc$sf3], [TRUE, csc$application_function, csc$sf4],
            [TRUE, csc$application_function, csc$sf5], [TRUE, csc$application_function, csc$sf6],
            [TRUE, csc$application_function, csc$sf7], [TRUE, csc$application_function, csc$sf8],
            [TRUE, csc$application_function, csc$sf9], [TRUE, csc$application_function, csc$sf10],
            [TRUE, csc$application_function, csc$sf11], [TRUE, csc$application_function, csc$sf12],
            [TRUE, csc$application_function, csc$sf13], [TRUE, csc$application_function, csc$sf14],
            [TRUE, csc$application_function, csc$sf15], [TRUE, csc$application_function, csc$sf16],
            [FALSE, csc$unused_entry], [FALSE, csc$screen_function, csc$insert_line],
            [FALSE, csc$screen_function, csc$delete_line], [FALSE, csc$screen_function, csc$home],
            [FALSE, csc$screen_function, csc$clear], [FALSE, csc$unused_entry], [FALSE, csc$unused_entry]],
      mapped: boolean,
      menu_type: cst$key_type,
      key_label_length: 0 .. osc$max_name_size,
      terminal_status: ost$status;

    status.normal := TRUE;
    ALLOCATE fdv$screen_status.p_screen_event_statuses;
    IF fdv$screen_status.p_screen_event_statuses = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
      RETURN;
    IFEND;

    FOR event_trigger := LOWERBOUND (fdv$screen_status.p_screen_event_statuses^)
          TO UPPERBOUND (fdv$screen_status.p_screen_event_statuses^) DO
      fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_exists := FALSE;
      fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_used := FALSE;
    FOREND;

{ Set terminal to screen mode.

    IF NOT fdv$screen_status.screen_mode_active THEN
      csv$vector.change_capability_level^ (csc$screen_level, terminal_status);
      IF ((NOT terminal_status.normal) AND (terminal_status.condition <> cse$redundant_screen_level)) THEN
        fdp$convert_terminal_status (terminal_status, status);
        FREE fdv$screen_status.p_screen_event_statuses;
        RETURN;
      IFEND;
      fdv$screen_status.screen_mode_active := TRUE;
    IFEND;

{ Screen Formatting gets only changes made by the terminal user to text.

    csv$vector.change_changed_text_mode^ (TRUE, terminal_status);
    IF NOT terminal_status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
      FREE fdv$screen_status.p_screen_event_statuses;
      RETURN;
    IFEND;

{ Determine event triggers that are available on the terminal for latter
{ assignment to forms events.

  /get_screen_events/
    FOR event_trigger := LOWERBOUND (fdv$screen_status.p_screen_event_statuses^)
          TO UPPERBOUND (fdv$screen_status.p_screen_event_statuses^) DO

      event_identifier.event_type := csc$field_event;
      menu_type := form_to_screen_events [event_trigger].event_type;
      CASE menu_type OF

      = csc$standard_function =
        event_identifier.field_event.event_type := csc$field_standard_function;
        event_identifier.field_event.standard_function := form_to_screen_events [event_trigger].
              standard_function;

{ Get label for terminal key. The terminal user recognizes the key by seeing
{ the label on the event form.

        csv$vector.get_event_name^ (event_identifier, fdv$screen_status.p_screen_event_statuses^
             [event_trigger].event_label, key_label_length, terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          FREE fdv$screen_status.p_screen_event_statuses;
          RETURN;
        IFEND;

        fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_trigger := event_trigger;
        IF key_label_length = 0 THEN
          fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_label := osc$null_name;
          CYCLE /get_screen_events/;
        IFEND;

        fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_exists := TRUE;

{ A standard function key may be mapped to an application function key if the
{ standard function
{ key does not exist on the terminal.  If the standard key is mapped to an
{ application function key,
{ the application function key will not be available for assignment.

        csv$vector.get_event_mapping^ (event_identifier.field_event.standard_function,
              application_function, mapped, terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          FREE fdv$screen_status.p_screen_event_statuses;
          RETURN;
        IFEND;
        IF mapped THEN
          fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_trigger :=
                fdv$application_event_table [application_function];
        IFEND;

      = csc$application_function =

        event_identifier.field_event.event_type := csc$field_application_function;
        event_identifier.field_event.application_function :=
              form_to_screen_events [event_trigger].application_function;
        csv$vector.get_event_name^ (event_identifier, fdv$screen_status.p_screen_event_statuses^
             [event_trigger].event_label, key_label_length, terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          FREE fdv$screen_status.p_screen_event_statuses;
          RETURN;
        IFEND;

        fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_exists := (key_label_length <> 0);
        fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_trigger := event_trigger;
        IF key_label_length = 0 THEN
          fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_label := osc$null_name;
        IFEND;

      = csc$screen_function =
        event_identifier.field_event.event_type := csc$field_screen;
        event_identifier.field_event.screen_event := form_to_screen_events [event_trigger].screen_function;
        csv$vector.get_event_name^ (event_identifier, fdv$screen_status.p_screen_event_statuses^
             [event_trigger].event_label, key_label_length, terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          FREE fdv$screen_status.p_screen_event_statuses;
          RETURN;
        IFEND;
        fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_exists := (key_label_length <> 0);
        fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_trigger := event_trigger;
        IF key_label_length = 0 THEN
          fdv$screen_status.p_screen_event_statuses^ [event_trigger].event_label := osc$null_name;
        IFEND;
      ELSE { Ignore any other menu types. }
      CASEND;
    FOREND /get_screen_events/;

{ Get screen sizes in order to determine if a form will fit on screen.

    device_attributes [1].key := csc$da_screen_dimensions;
    csv$vector.get_device_attributes^ (device_attributes, terminal_status);
    IF NOT terminal_status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
      FREE fdv$screen_status.p_screen_event_statuses;
      RETURN;
    IFEND;
    fdv$screen_status.screen_dimensions := device_attributes [1].screen_dimensions;

  PROCEND fdp$get_screen_events;

?? TITLE := 'fdp$get_screen_input', EJECT ??
*copyc fdh$get_screen_input

  PROCEDURE [XDCL] fdp$get_screen_input
    (VAR event_name: ost$name;
     VAR event_normal: boolean;
     VAR event_position: fdt$event_position;
     VAR status: ost$status);

    VAR
      active_number_objects: fdt$number_objects,
      bad_key_displayed: boolean,
      character_position: cst$character_position,
      current_form_identifier: fdt$current_form_identifier,
      event_action: fdt$event_action,
      event_defined: boolean,
      event_highlighted: boolean,
      event_on_message_form: boolean,
      event_recognized: boolean,
      event_trigger: fdt$event_trigger,
      field_number: cst$field_number,
      first_stored_occurrence: integer,
      flush_events: boolean,
      form_identifier: fdt$next_form_identifier,
      form_object: boolean,
      highlight_event_change: fdt$screen_change,
      line_number: cst$line_number,
      local_status: ost$status,
      next_object_index: fdt$object_index,
      message_form_added: boolean,
      message_text: fdt$message_text,
      object_exists: boolean,
      object_index: fdt$object_index,
      occurrence_shift: integer,
      output_character_position: cst$character_position,
      output_line_position: cst$line_number,
      p_form_definition: ^fdt$form_definition,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_object_statuses:  ^array [1 .. * ] of fdt$form_object_status,
      p_form_table_definition: ^fdt$form_table_definition,
      p_form_table_status: ^fdt$form_status,
      p_form_status: ^fdt$form_status,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_parent_object_definition: ^fdt$form_object_definition,
      p_record_form_status: ^fdt$form_status,
      p_text: ^fdt$text,
      parent_object_index: fdt$object_index,
      position: integer,
      reset_event_change: fdt$screen_change,
      screen_record_position: fdt$record_position,
      screen_visible_length: fdt$screen_variable_length,
      shift: integer,
      table_index: fdt$table_index,
      target_position: fdt$target_position,
      terminal_status: ost$status,
      text_length: fdt$text_length,
      variable_index: fdt$variable_index;

?? NEWTITLE := 'compute_event_highlight', EJECT ??

{ PURPOSE:
{   This procedure computes the highlight for the event executed by the terminal user.
{   Two screen changes are computed. One has the attributes to highlight the event.
{   The other screen change is the attributes to reset the event to initial attributes.

  PROCEDURE compute_event_highlight;

    VAR
      added_form_identifier: fdt$form_identifier,
      display_name: ost$name,
      name_exists: boolean,
      object_occurrence_exists: boolean,
      p_display_definition: ^fdt$display_definition,
      p_event_form_status: ^fdt$form_status,
      p_event_form_object_definition: ^fdt$form_object_definition;


    event_highlighted := FALSE;
    IF NOT event_defined THEN
      RETURN;
    IFEND;

    IF p_form_status^.combined  THEN
      added_form_identifier := p_form_status^.added_form_identifier;
    ELSE
      added_form_identifier := form_identifier;
    IFEND;

    IF NOT fdv$screen_status.p_forms_status^ [added_form_identifier].event_form_defined THEN
      RETURN;
    IFEND;

{ If the application has defined an event form, the object for the event may not exist
{ or the display name for the attribute may not exist.  If the event form does not use
{ the standard conventions, do not highlight the  event pressed by the terminal user.

    highlight_event_change.attribute_form_identifier := fdv$screen_status.p_forms_status^
          [added_form_identifier].event_form_identifier;
    p_event_form_status := ^fdv$screen_status.p_forms_status^ [highlight_event_change.
          attribute_form_identifier];
    highlight_event_change.key := fdc$set_attribute;
    fdp$find_object_definition (event_name, 1, p_event_form_status^.p_form_object_definitions,
          p_event_form_status^.p_form_definition^.form_object_definitions.active_number,
          p_event_form_object_definition, highlight_event_change.attribute_object_index, name_exists,
          object_occurrence_exists);
    IF (NOT name_exists) OR (NOT object_occurrence_exists) THEN
      RETURN;
    IFEND;

    display_name := fdc$system_display_name;
    fdp$find_display_name (display_name, p_event_form_status^.p_display_definitions,
          p_event_form_status^.p_form_definition^.display_definitions.active_number,
          p_display_definition, name_exists);
    IF NOT name_exists THEN
      RETURN;
    IFEND;


    highlight_event_change.attribute := p_display_definition^.attribute;
    reset_event_change := highlight_event_change;
    reset_event_change.key :=fdc$reset_event_variable;
    reset_event_change.attribute := p_event_form_object_definition^.display_attribute;
    event_highlighted := TRUE;

  PROCEND compute_event_highlight;

?? OLDTITLE ??
?? NEWTITLE := 'find_screen_identifier', EJECT ??

{ PURPOSE:
{   This procedure maps Screen Manager field identifier to Screen Formatting
{   form identifier and object index. It determines whether the event occurred on
{   a form area containing no object or on an object.

  PROCEDURE find_screen_identifier;

    VAR
      p_form_object_status: ^fdt$form_object_status;

    form_identifier := fdv$screen_status.current_form_identifier;
    form_object := FALSE;
    object_exists := FALSE;

    WHILE form_identifier <> 0 DO
      p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
      IF p_form_status^.displayed_on_screen THEN
        p_form_object_statuses := p_form_status^.p_form_object_statuses;
        IF p_form_status^.field_number = field_number THEN

{ The object is the form itself.

          form_object := TRUE;
          RETURN;
        IFEND;

        IF p_form_object_statuses <> NIL THEN
          FOR object_index := LOWERBOUND (p_form_object_statuses^) TO UPPERBOUND (p_form_object_statuses^) DO
            p_form_object_status := ^p_form_object_statuses^ [object_index];
            CASE p_form_object_status^.key OF

            = fdc$field_identifier =
              IF p_form_object_status^.field_number = field_number THEN
                object_exists := TRUE;
                RETURN;
              IFEND;

            ELSE
            CASEND;
          FOREND;
        IFEND;
      IFEND;
      form_identifier := p_form_status^.next_lower_form;
    WHILEND;
  PROCEND find_screen_identifier;

?? OLDTITLE ??
?? NEWTITLE := 'find_table_to_page', EJECT ??

{ PURPOSE:
{   This procedure finds the table to page/scroll. When only one table exists on
{   a form, the cursor does not need to be positioned on the table.

  PROCEDURE find_table_to_page;

    VAR
      added_form_identifier: fdt$form_identifier,
      current_form_identifier: fdt$current_form_identifier,
      p_current_form_status: ^fdt$form_status;


{ Find the added (base) form.

    IF p_form_status^.combined THEN
      added_form_identifier := p_form_status^.added_form_identifier;
    ELSE
      added_form_identifier := form_identifier;
    IFEND;

{ Only one table must exist for added form and all forms combined with added form.
{ If no tables exist or more than one table exists the event must be ignored.

     p_current_form_status := ^fdv$screen_status.p_forms_status^ [added_form_identifier];
     IF (p_current_form_status^.p_form_definition^.form_table_definitions.active_number > 1) THEN
       event_defined := FALSE;
       RETURN;
     IFEND;

     p_form_table_definition := NIL;
     IF (p_current_form_status^.p_form_definition^.form_table_definitions.active_number = 1) THEN
       p_form_table_definition := ^p_current_form_status^.p_form_table_definitions^ [1];
       p_form_table_status := p_current_form_status;
     IFEND;

{ Examine forms combined with added form.

    current_form_identifier := fdv$screen_status.current_form_identifier;
    WHILE current_form_identifier <> 0 DO
      p_current_form_status := ^fdv$screen_status.p_forms_status^ [current_form_identifier];
      IF p_current_form_status^.entry_used THEN
        IF p_current_form_status^.combined AND
             (p_current_form_status^.added_form_identifier = added_form_identifier) THEN
          IF (p_current_form_status^.p_form_definition^.form_table_definitions.active_number > 1) THEN
            event_defined := FALSE;
            RETURN;
          IFEND;

          IF (p_current_form_status^.p_form_definition^.form_table_definitions.active_number = 1) THEN
            IF (p_form_table_definition = NIL) THEN
              p_form_table_definition := ^p_current_form_status^.p_form_table_definitions^ [1];
              p_form_table_status := p_current_form_status;
            ELSE
              event_defined := FALSE;
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
      current_form_identifier := p_current_form_status^.next_lower_form;
    WHILEND;

    event_defined :=  p_form_table_definition <> NIL;

  PROCEND find_table_to_page;

?? OLDTITLE ??
?? NEWTITLE := 'get_screen_variables', EJECT ??

{ PURPOSE:
{   This procedure moves data changed by the terminal user to Screen Formatting storage.

  PROCEDURE get_screen_variables;


    VAR
      end_of_changes: boolean,
      hidden_editing: boolean,
      visible_screen_length: fdt$screen_variable_length;

?? NEWTITLE := 'get_terminal-data', EJECT ??

    PROCEDURE get_terminal_data;


      VAR
        data_string_length: cst$data_string_length,
        end_of_line: boolean,
        end_of_text: boolean,
        first_displayed_occurrence: fdt$occurrence,
        object_name_exists: boolean,
        object_occurrence_exists: boolean,
        p_data_string: ^cst$data_string,
        p_status_object_definition: ^fdt$form_object_definition,
        p_table_objects: ^array [1 .. * ] of fdt$table_object,
        p_table_variable: ^fdt$table_variable,
        p_table_variables: ^array [1 .. * ] of fdt$table_variable,
        status_object_index: fdt$object_index,
        text_length: fdt$text_length,
        variable_name: ost$name,
        visible_record_position: fdt$record_position;

?? NEWTITLE := 'update_data', EJECT ??

      PROCEDURE update_data;

        VAR
          data_index: fdt$text_length,
          data_length: fdt$text_length,
          data_length_change: integer,
          formatted_data_length: fdt$text_length,
          fragment_object_index: fdt$object_index,
          local_status: ost$status,
          move_length: integer,
          p_data: ^fdt$text,
          p_save_data: ^fdt$text,
          p_user_data: ^cst$data_string,
          record_position: fdt$record_position,
          save_move_length: fdt$record_position,
          screen_change: fdt$screen_change,
          user_data_length: cst$data_string_length,
          visible_length: fdt$text_length;

?? NEWTITLE := 'update_text_pointers', EJECT ??

{ PURPOSE:
{   This procedure updates the pointers that describe how the data for an object is formatted.
{   For each object, the pointers specifies the first character of text mapped into the
{   object and the number of characters. If a terminal user deletes or inserts characters, the
{   character position for each subsequent object needs adjustment by the data length change
{   induced by the deletes and inserts.

        PROCEDURE update_text_pointers;

          VAR
            last_position: fdt$text_length;

          IF (p_form_object_definition^.key = fdc$form_variable_text_box) THEN
            fragment_object_index := p_form_object_definitions^ [object_index].variable_box_fragment_index;
          ELSE { fdc$form_text_box_fragment }
            fragment_object_index := p_form_object_definitions^ [object_index].next_fragment_object_index;
          IFEND;

          p_form_object_statuses^ [object_index].data_length := formatted_data_length;
          last_position := p_form_object_statuses^ [object_index].character_position +
                p_form_object_statuses^ [object_index].data_length;
          WHILE fragment_object_index <> 0 DO
            IF ((p_form_object_statuses^ [fragment_object_index].character_position + data_length_change) <=
                  p_form_variable_definition^.screen_variable_length) THEN
              p_form_object_statuses^ [fragment_object_index].character_position := last_position;
            ELSE
              p_form_object_statuses^ [fragment_object_index].character_position :=
                    p_form_variable_definition^.screen_variable_length;
            IFEND;

{ Change data length if data length exceeds length of variable.

            IF (p_form_object_statuses^ [fragment_object_index].character_position - 1 +
                  p_form_object_statuses^ [fragment_object_index].data_length >
                  p_form_variable_definition^.screen_variable_length) THEN
              p_form_object_statuses^ [fragment_object_index].data_length :=
                    p_form_variable_definition^.screen_variable_length -
                    p_form_object_statuses^ [fragment_object_index].character_position + 1;
            IFEND;

            last_position := p_form_object_statuses^ [fragment_object_index].character_position +
                  p_form_object_statuses^ [fragment_object_index].data_length;
            fragment_object_index := p_form_object_definitions^ [fragment_object_index].
                  next_fragment_object_index;
          WHILEND;

{ Delete all previous scheduled screen changes due to insertion or deletions of characters in
{ variable text box.

          delete_format_screen_change (form_identifier, parent_object_index);

{ Schedule a form update to show the terminal user how the data was affected by
{ the deletion or insertion of characters. For example, the deletion of a character may
{ mean previously hidden data becomes visible.

          screen_change.key := fdc$format_text_box;
          screen_change.format_text_form_identifier := form_identifier;
          screen_change.format_text_object_index := parent_object_index;
          fdp$ptr_screen_variable (p_form_status^.p_screen_record,
                p_form_variable_definition^.screen_record_position,
                p_form_variable_definition^.screen_variable_length, screen_change.p_format_text);
          fdp$record_screen_change (screen_change, local_status);

        PROCEND update_text_pointers;

?? OLDTITLE, EJECT ??

        CASE p_form_object_definition^.key OF

        = fdc$form_variable_text =

{ If hidden editing is in effect, the Screen Manager field length equals the screen variable
{ length (program data length). Otherwise, the Screen Manager field length equals the object
{ width.

          IF hidden_editing THEN
            PUSH p_user_data: [p_form_variable_definition^.screen_variable_length];
          ELSE
            PUSH p_user_data: [visible_screen_length];
          IFEND;
          csv$vector.get_text^ (p_user_data^, user_data_length, end_of_line, end_of_text, terminal_status);
          IF NOT terminal_status.normal THEN
            fdp$convert_terminal_status (terminal_status, status);
            RETURN;
          IFEND;

          IF hidden_editing THEN
            text_length := p_form_variable_definition^.screen_variable_length -
                  p_form_object_statuses^ [object_index].character_position + 1;
          ELSE
            text_length := visible_screen_length;
          IFEND;
          fdp$ptr_screen_variable (p_form_status^.p_screen_record, visible_record_position, text_length,
                p_data);
          p_data^ (1, text_length) := p_user_data^ (1, user_data_length);

        = fdc$form_variable_text_box, fdc$form_text_box_fragment =

{ If hidden editing is in effect, the Screen Manager field length equals the twice the
{ visible width of the object.  Otherwise the Screen Manager field length equals
{ the visible width of the object.

          IF hidden_editing THEN
            PUSH p_user_data: [p_parent_object_definition^.variable_box_width *
                  fdc$hidden_editing_multiplier];
          ELSE
            PUSH p_user_data: [visible_screen_length];
          IFEND;

          csv$vector.get_text^ (p_user_data^, user_data_length, end_of_line, end_of_text, terminal_status);
          IF NOT terminal_status.normal THEN
            fdp$convert_terminal_status (terminal_status, status);
            RETURN;
          IFEND;

          text_length := p_form_variable_definition^.screen_variable_length -
                p_form_object_statuses^ [object_index].character_position + 1;
          fdp$ptr_screen_variable (p_form_status^.p_screen_record, visible_record_position, text_length,
                p_data);

{ Compute the change in length.  Deleted characters cause a negative change in length.
{ Inserted characters cause a positive change in length.

          data_length := p_form_object_statuses^ [object_index].data_length;
          record_position := p_form_object_statuses^ [object_index].character_position;
          IF p_parent_object_definition^.variable_box_processing = fdc$wrap_words THEN

{ Trailing blanks for word wrap should be removed before computing the change in length.
{ The formatting procedure previously computed the data length of a line of text for the object
{ by using one trailing blank.

          /find_end_of_data/
            FOR data_index := user_data_length DOWNTO 1 DO
              IF p_user_data^ (data_index, 1) <> ' ' THEN
                EXIT /find_end_of_data/;
              IFEND;
            FOREND /find_end_of_data/;

            IF user_data_length = 0 THEN

{ The terminal user did a clear to end of line.

              formatted_data_length := 0;
            ELSEIF data_index = user_data_length THEN

{ The line was completely full.  The formatting procedure could not end the line with a blank.

              formatted_data_length := user_data_length;
            ELSE

{ Account for the trailing blank specified by the formatting procedure.

              formatted_data_length := data_index + 1;
            IFEND;
          ELSE { fdc$character_wrap
            IF hidden_editing THEN
              formatted_data_length := user_data_length;
            ELSE
              formatted_data_length := visible_screen_length;
              p_user_data^ (user_data_length + 1, * ) := ' ';
            IFEND;
          IFEND;

          data_length_change := formatted_data_length - data_length;
          IF (data_length_change = 0) THEN

{ The terminal user did not change the data length.  Simply replace the data.

            p_data^ (1, formatted_data_length) := p_user_data^ (1, formatted_data_length);

          ELSE

{ The terminal user deleted or inserted some data.  Replace the data for the changed object.

            IF ((record_position - 1 + formatted_data_length) >
                  p_form_variable_definition^.screen_variable_length) THEN

{ The terminal user data goes over the end of the end of the record.

              move_length := p_form_variable_definition^.screen_variable_length - record_position + 1;
              p_data^ (1, move_length) := p_user_data^ (1, move_length);
              formatted_data_length := move_length;
              update_text_pointers;
              RETURN;
            IFEND;

{ If the change lies in the middle of the record, save the data beyond the change.

            save_move_length := p_form_variable_definition^.screen_variable_length -
                  (record_position - 1 + data_length);
            IF save_move_length >= 0 THEN

              PUSH p_save_data: [save_move_length];
              p_save_data^ := p_data^ (data_length + 1, save_move_length);

{ Shift the screen formatting data right for a delete of a character(s).  Shift the screen formatting
{ data to the left for an insert of a character(s).

              move_length := p_form_variable_definition^.screen_variable_length -
                    (record_position - 1 + formatted_data_length);
              IF move_length >= 0 THEN
                p_data^ (formatted_data_length + 1, move_length) := p_save_data^;
              IFEND;
            IFEND;

{ Move the terminal user data into the space created by the above shift.

            p_data^ (1, formatted_data_length) := p_user_data^ (1, formatted_data_length);

{ Update the pointers describing the first character and number of characters mapped into the object.

            update_text_pointers;
          IFEND;
        CASEND;

      PROCEND update_data;

?? OLDTITLE, EJECT ??

      IF p_form_variable_definition^.table_exists THEN
        table_index := p_form_variable_definition^.table_index;
        p_form_table_definition := ^p_form_status^.p_form_table_definitions^ [table_index];
        first_displayed_occurrence := p_form_status^.p_form_table_statuses^ [table_index].
              first_displayed_occurrence;
        variable_name := p_form_variable_definition^.name;
        p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
              p_form_status^.p_form_module);

      /find_variable/
        FOR variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
          p_table_variable := ^p_table_variables^ [variable_index];
          IF p_table_variable^.name = variable_name THEN
            p_table_objects := fdp$ptr_table_objects (p_table_variable^.table_objects,
                  p_form_status^.p_form_module);
            IF first_displayed_occurrence = 1 THEN
              visible_record_position := p_table_objects^ [p_parent_object_definition^.occurrence].
                    screen_record_position + p_form_object_statuses^ [object_index].character_position - 1;
              p_form_object_statuses^ [parent_object_index].changed_by_read_forms_index :=
                    fdv$screen_status.read_forms_index;
              p_form_object_statuses^ [parent_object_index].user_changed_field := TRUE;
              p_form_object_statuses^ [parent_object_index].user_entered_field := TRUE;

            ELSE

{ The table was scrolled. Another occurrence occupies the visible occurrence.

              fdp$find_object_definition (variable_name, p_parent_object_definition^.occurrence +
                    first_displayed_occurrence - 1, p_form_status^.p_form_object_definitions,
                    p_form_status^.p_form_definition^.form_object_definitions.active_number,
                    p_status_object_definition, status_object_index, object_name_exists,
                    object_occurrence_exists);
              IF object_name_exists AND object_occurrence_exists THEN
                visible_record_position := p_table_objects^ [p_parent_object_definition^.occurrence +
                      first_displayed_occurrence - 1].screen_record_position +
                      p_form_object_statuses^ [status_object_index].character_position - 1;
                p_form_object_statuses^ [status_object_index].changed_by_read_forms_index :=
                      fdv$screen_status.read_forms_index;
                p_form_object_statuses^ [status_object_index].user_changed_field := TRUE;
                p_form_object_statuses^ [status_object_index].user_entered_field := TRUE;
                object_index := status_object_index;
              ELSE
                osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'get terminal data',
                      status);
                RETURN;
              IFEND;
            IFEND;
          IFEND;

        FOREND /find_variable/;

      ELSE

{ Variable is not member of a table.

        visible_record_position := p_form_variable_definition^.screen_record_position +
              p_form_object_statuses^ [object_index].character_position - 1;
        p_form_object_statuses^ [parent_object_index].changed_by_read_forms_index :=
              fdv$screen_status.read_forms_index;
        p_form_object_statuses^ [parent_object_index].user_changed_field := TRUE;
        p_form_object_statuses^ [parent_object_index].user_entered_field := TRUE;
      IFEND;

      update_data;

    PROCEND get_terminal_data;

?? OLDTITLE, EJECT ??

    REPEAT

    /get_terminal_user_changes/
      BEGIN

{ Screen Formatting uses the Screen Manager change text mode.  That is,
{ the Screen Formatting gets only changes made by the terminal user to the
{ screen.

        csv$vector.get_io_position^ (field_number, line_number, end_of_changes, terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          RETURN;
        IFEND;

        IF end_of_changes THEN
          RETURN;
        IFEND;

{ Translate Screen Manager field number to Screen Formatting form and form object.

        find_screen_identifier;
        IF NOT object_exists THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'field number not found',
                status);
          RETURN;
        IFEND;

        p_form_object_definitions := p_form_status^.p_form_object_definitions;
        p_form_object_definition := ^p_form_object_definitions^ [object_index];
        p_form_object_statuses := p_form_status^.p_form_object_statuses;
        hidden_editing := p_form_status^.p_form_definition^.hidden_editing;

        CASE p_form_object_definition^.key OF

        = fdc$form_variable_text =
          p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                [p_form_object_definition^.text_variable_index];
          visible_screen_length := p_form_object_definition^.text_variable_width;
          p_parent_object_definition := p_form_object_definition;
          parent_object_index := object_index;
          get_terminal_data;
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        = fdc$form_variable_text_box =
          p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                [p_form_object_definition^.variable_box_variable_index];
          visible_screen_length := p_form_object_definition^.variable_box_width;
          p_parent_object_definition := p_form_object_definition;
          parent_object_index := object_index;
          get_terminal_data;
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        ELSE {fdc$form_text_box_fragment}

          parent_object_index := p_form_object_definition^.parent_text_box_object_index;
          p_parent_object_definition := ^p_form_object_definitions^ [parent_object_index];
          visible_screen_length := p_parent_object_definition^.variable_box_width;
          p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^ [
                p_parent_object_definition^.variable_box_variable_index];
          get_terminal_data;
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        CASEND;

      END /get_terminal_user_changes/;
    UNTIL end_of_changes;

  PROCEND get_screen_variables;


?? OLDTITLE ??
?? NEWTITLE := 'highlight_event', EJECT ??

{ PURPOSE:
{   This procedure highlights the event executed by the terminal user.
{   The object on the form menu is immediately highlighted.  The reset of
{   of the object attribute is scheduled for the next screen update.

  PROCEDURE highlight_event;

    compute_event_highlight;
    IF NOT event_highlighted  THEN
      RETURN;
    IFEND;

    fdp$record_screen_change (highlight_event_change, local_status);
    fdp$change_screen (local_status);

{ Update the screen immediately so that the terminal user sees the highlighted function key
{ while the application program is processing the event.

    csv$vector.update_device^ (local_status);

{ Schedule the reset of the object attribute for the next screen update.  This usually occurs
{ on the next read or show forms call.

    fdp$record_screen_change (reset_event_change, local_status);

  PROCEND highlight_event;

?? OLDTITLE ??
?? NEWTITLE := 'process_screen_form_event', EJECT ??

{ PURPOSE:
{   This procedure processes events that occurred on no object within a form.

    PROCEDURE process_screen_form_event;

      event_position.form_identifier := form_identifier;
      event_position.form_x_position := fdv$screen_status.event_identifier.
            field_event_character_position;
      event_position.form_y_position := fdv$screen_status.event_identifier.
            field_event_line_number;
      event_position.screen_x_position := p_form_status^.form_x_position +
            event_position.form_x_position - 1;
      event_position.screen_y_position := p_form_status^.form_y_position +
            event_position.form_y_position - 1;
      event_position.key := fdc$form_event;

      fdv$screen_status.last_cursor_position_valid := TRUE;
      fdv$screen_status.last_cursor_form_identifier := form_identifier;

      p_form_status^.last_cursor_position_valid := TRUE;
      p_form_status^.last_cursor_form_x_position :=
            event_position.form_x_position;
      p_form_status^.last_cursor_form_y_position :=
            event_position.form_y_position;
      p_form_object_definitions := p_form_status^.p_form_object_definitions;
      p_form_definition := p_form_status^.p_form_definition;
      translate_screen_event;
      IF NOT event_defined THEN
        RETURN;
      IFEND;

      CASE event_action OF

      = fdc$return_program_normal, fdc$return_program_abnormal,
            fdc$ignore_event =

{ The above events will be processed later.

      = fdc$display_help =
        display_form_help (p_form_status, status);

      = fdc$erase_help =
        erase_message_form (status);

      = fdc$page_table_backward =
        find_table_to_page;
        IF event_defined THEN
          occurrence_shift := -p_form_table_definition^.visible_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$page_table_forward =
        find_table_to_page;
        IF event_defined THEN
          occurrence_shift := p_form_table_definition^.visible_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$page_table_first =
        find_table_to_page;
        IF event_defined THEN

{ Specify maximum shift.  Shift_table will compute actual shift need.

          occurrence_shift := -p_form_table_definition^.stored_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$page_table_last =
        find_table_to_page;
        IF event_defined THEN

{ Specify maximum shift.  Shift_table will compute actual shifted needed.

          occurrence_shift := p_form_table_definition^.stored_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$tab_to_next_form_field =
        IF p_form_status^.p_form_definition^.form_object_definitions.
              active_number > 0 THEN
          fdp$find_next_object (fdv$screen_status.event_position.
                form_x_position, fdv$screen_status.event_position.
                form_y_position, p_form_status, object_index);
          fdp$tab_to_next_variable (p_form_status, object_index, status);
        IFEND;

      = fdc$tab_to_previous_form_field =
        IF p_form_status^.p_form_definition^.form_object_definitions.
              active_number > 0 THEN
          find_previous_object (fdv$screen_status.event_position.
                form_x_position, fdv$screen_status.event_position.
                form_y_position, p_form_status, object_index);
          tab_to_previous_variable (p_form_status, object_index, status);
        IFEND;

      ELSE
        event_defined := FALSE;
      CASEND;

    PROCEND process_screen_form_event;

?? OLDTITLE ??
?? NEWTITLE := 'process_screen_object_event' , EJECT??

{ PURPOSE:
{   This procedure processes events that occurred on an object within a form.
{   Determine object and its location. Perform specified action on object.

  PROCEDURE process_screen_object_event;

  VAR
    p_save_data: ^fdt$text,
    start_move_position: fdt$text_length;

    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    p_form_object_definition := ^p_form_object_definitions^ [object_index];
    fdv$screen_status.last_cursor_position_valid := TRUE;
    fdv$screen_status.last_cursor_form_identifier := form_identifier;
    p_form_status^.last_cursor_position_valid := TRUE;
    p_form_status^.last_cursor_form_x_position :=
          p_form_object_definition^.x_position +
          fdv$screen_status.event_identifier.field_event_character_position -
          1;
    p_form_status^.last_cursor_form_y_position :=
          p_form_object_definition^.y_position +
          fdv$screen_status.event_identifier.field_event_line_number - 1;

    event_position.form_identifier := form_identifier;
    event_position.key := fdc$object_event;
    event_position.form_identifier := form_identifier;
    event_position.object_name := p_form_object_definition^.name;
    event_position.object_occurrence := p_form_object_definition^.occurrence;
    event_position.screen_x_position := p_form_status^.form_x_position +
          p_form_object_definition^.x_position - 1 +
          fdv$screen_status.event_identifier.field_event_character_position -
          1;
    event_position.screen_y_position := p_form_status^.form_y_position +
          p_form_object_definition^.y_position - 1 +
          fdv$screen_status.event_identifier.field_event_line_number - 1;
    event_position.form_x_position := p_form_object_definition^.x_position +
          fdv$screen_status.event_identifier.field_event_character_position -
          1;
    event_position.form_y_position := p_form_object_definition^.y_position +
          fdv$screen_status.event_identifier.field_event_line_number - 1;
    event_position.object_x_position := p_form_object_definition^.x_position;
    event_position.object_y_position := p_form_object_definition^.y_position;
    translate_screen_event;
    IF NOT event_defined THEN
      RETURN;
    IFEND;

    position := fdv$screen_status.event_identifier.
          field_event_character_position;

    CASE p_form_object_definition^.key OF

    = fdc$form_box =
      event_position.object_definition_key := fdc$box;
      CASE event_action OF

      = fdc$return_program_normal, fdc$return_program_abnormal,
            fdc$ignore_event =

      = fdc$display_help =
        display_form_help (p_form_status, status);

      = fdc$erase_help =
        erase_message_form (status);

      = fdc$page_table_backward =
        find_table_to_page;
        IF event_defined THEN
          occurrence_shift := -p_form_table_definition^.visible_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$page_table_forward =
        find_table_to_page;
        IF event_defined THEN
          occurrence_shift := p_form_table_definition^.visible_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$page_table_first =
        find_table_to_page;
        IF event_defined THEN

{ Specify maximum shift.  Shift_table will compute actual shift need.

          occurrence_shift := -p_form_table_definition^.stored_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$page_table_last =
        find_table_to_page;
        IF event_defined THEN

{ Specify maximum shift.  Shift_table will compute actual shifted needed.

          occurrence_shift := p_form_table_definition^.stored_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      ELSE
        event_defined := FALSE;
      CASEND;

    = fdc$form_line =
      event_position.object_definition_key := fdc$line;
      CASE event_action OF

      = fdc$return_program_normal, fdc$return_program_abnormal,
            fdc$ignore_event =

      = fdc$display_help =
        display_form_help (p_form_status, status);

      = fdc$erase_help =
        erase_message_form (status);

      ELSE
        event_defined := FALSE;
      CASEND;

    = fdc$form_constant_text =
      event_position.object_definition_key := fdc$constant_text;
      screen_visible_length := p_form_object_definition^.constant_text_width;
      p_text := fdp$ptr_text (p_form_object_definition^.constant_text,
            p_form_status^.p_form_module);
      CASE event_action OF

      = fdc$return_program_normal, fdc$return_program_abnormal,
            fdc$ignore_event =

      = fdc$display_help =
        display_form_help (p_form_status, status);

      = fdc$erase_help =
        erase_message_form (status);

      = fdc$page_variable_backward =
        target_position.key := fdc$page_data_backward;
        shift_text_line (target_position, p_text, object_index, screen_visible_length,
              p_form_status, fdv$screen_status.event_identifier.
              field_event_character_position, status);

      = fdc$page_variable_first =
        target_position.key := fdc$page_data_first;
        shift_text_line (target_position, p_text, object_index, screen_visible_length,
              p_form_status, fdv$screen_status.event_identifier.
              field_event_character_position, status);

      = fdc$page_variable_forward =
        target_position.key := fdc$page_data_forward;
        shift_text_line (target_position, p_text, object_index, screen_visible_length,
              p_form_status, fdv$screen_status.event_identifier.
              field_event_character_position, status);

      = fdc$page_variable_last =
        target_position.key := fdc$page_data_last;
        shift_text_line (target_position, p_text, object_index, screen_visible_length,
              p_form_status, fdv$screen_status.event_identifier.
              field_event_character_position, status);

      = fdc$page_table_backward =
        find_table_to_page;
        IF event_defined THEN
          occurrence_shift := -p_form_table_definition^.visible_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$page_table_forward =
        find_table_to_page;
        IF event_defined THEN
          occurrence_shift := p_form_table_definition^.visible_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$page_table_first =
        find_table_to_page;
        IF event_defined THEN

{ Specify maximum shift.  Shift_table will compute actual shift need.

          occurrence_shift := -p_form_table_definition^.stored_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$page_table_last =
        find_table_to_page;
        IF event_defined THEN

{ Specify maximum shift.  Shift_table will compute actual shifted needed.

          occurrence_shift := p_form_table_definition^.stored_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$scroll_variable_backward =
        target_position.key := fdc$scroll_data_backward;
        target_position.data_index := fdv$screen_status.event_identifier.
              field_event_character_position + p_form_status^.p_form_object_statuses^ [object_index].
              character_position - 1;
        shift_text_line (target_position, p_text, object_index, screen_visible_length,
              p_form_status, fdv$screen_status.event_identifier.
              field_event_character_position, status);

      = fdc$scroll_variable_forward =
        target_position.key := fdc$scroll_data_forward;
        target_position.data_index := fdv$screen_status.event_identifier.
              field_event_character_position + p_form_status^.p_form_object_statuses^ [object_index].
              character_position - 1;
        shift_text_line (target_position, p_text, object_index, screen_visible_length,
              p_form_status, fdv$screen_status.event_identifier.
              field_event_character_position, status);

      = fdc$tab_to_next_form_field =
        IF p_form_status^.p_form_definition^.form_object_definitions.
              active_number > 0 THEN
          fdp$find_next_object (fdv$screen_status.event_position.
                form_x_position, fdv$screen_status.event_position.
                form_y_position, p_form_status, object_index);
          fdp$tab_to_next_variable (p_form_status, object_index, status);
        IFEND;

      = fdc$tab_to_previous_form_field =
        IF p_form_status^.p_form_definition^.form_object_definitions.
              active_number > 0 THEN
          find_previous_object (fdv$screen_status.event_position.
                form_x_position, fdv$screen_status.event_position.
                form_y_position, p_form_status, object_index);
          tab_to_previous_variable (p_form_status, object_index, status);
        IFEND;

      ELSE
        event_defined := FALSE;
      CASEND;

    = fdc$form_constant_text_box =
      event_position.object_definition_key := fdc$constant_text_box;
      screen_visible_length := p_form_object_definition^.constant_box_width *
            p_form_object_definition^.constant_box_height;
      p_text := fdp$ptr_text (p_form_object_definition^.constant_box_text,
            p_form_status^.p_form_module);
      next_object_index := p_form_object_definition^.
            constant_box_fragment_index;
      CASE event_action OF

      = fdc$return_program_normal, fdc$return_program_abnormal,
            fdc$ignore_event =

      = fdc$display_help =
        display_form_help (p_form_status, status);

      = fdc$erase_help =
        erase_message_form (status);

      = fdc$page_table_backward =
        find_table_to_page;
        IF event_defined THEN
          occurrence_shift := -p_form_table_definition^.visible_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$page_table_forward =
        find_table_to_page;
        IF event_defined THEN
          occurrence_shift := p_form_table_definition^.visible_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$page_table_first =
        find_table_to_page;
        IF event_defined THEN

{ Specify maximum shift.  Shift_table will compute actual shift need.

          occurrence_shift := -p_form_table_definition^.stored_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$page_table_last =
        find_table_to_page;
        IF event_defined THEN

{ Specify maximum shift.  Shift_table will compute actual shifted needed.

          occurrence_shift := p_form_table_definition^.stored_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$page_variable_backward =
        target_position.key := fdc$page_data_backward;
        shift_text_box (p_text, p_form_status, object_index, next_object_index,
              p_form_object_definition^.constant_box_processing,
              p_form_object_definition^.constant_box_width,
              p_form_object_definition^.constant_box_height, object_index,
              fdv$screen_status.event_identifier.
              field_event_character_position, target_position, status);

      = fdc$page_variable_first =
        target_position.key := fdc$page_data_first;
        shift_text_box (p_text, p_form_status, object_index, next_object_index,
              p_form_object_definition^.constant_box_processing,
              p_form_object_definition^.constant_box_width,
              p_form_object_definition^.constant_box_height, object_index,
              fdv$screen_status.event_identifier.
              field_event_character_position, target_position, status);

      = fdc$page_variable_forward =
        target_position.key := fdc$page_data_forward;
        shift_text_box (p_text, p_form_status, object_index, next_object_index,
              p_form_object_definition^.constant_box_processing,
              p_form_object_definition^.constant_box_width,
              p_form_object_definition^.constant_box_height, object_index,
              fdv$screen_status.event_identifier.
              field_event_character_position, target_position, status);

      = fdc$page_variable_last =
        target_position.key := fdc$page_data_last;
        shift_text_box (p_text, p_form_status, object_index, next_object_index,
              p_form_object_definition^.constant_box_processing,
              p_form_object_definition^.constant_box_width,
              p_form_object_definition^.constant_box_height, object_index,
              fdv$screen_status.event_identifier.
              field_event_character_position, target_position, status);

      = fdc$scroll_variable_backward =
        target_position.key := fdc$scroll_data_backward;
        target_position.data_index := fdv$screen_status.event_identifier.
              field_event_character_position + p_form_status^.p_form_object_statuses^ [object_index].
              character_position - 1;
        shift_text_box (p_text, p_form_status, object_index, next_object_index,
              p_form_object_definition^.constant_box_processing,
              p_form_object_definition^.constant_box_width,
              p_form_object_definition^.constant_box_height, object_index,
              fdv$screen_status.event_identifier.
              field_event_character_position, target_position, status);

      = fdc$scroll_variable_forward =
        target_position.key := fdc$scroll_data_forward;
        target_position.data_index := fdv$screen_status.event_identifier.
              field_event_character_position + p_form_status^.p_form_object_statuses^ [object_index].
              character_position - 1;
        shift_text_box (p_text, p_form_status, object_index, next_object_index,
              p_form_object_definition^.constant_box_processing,
              p_form_object_definition^.constant_box_width,
              p_form_object_definition^.constant_box_height, object_index,
              fdv$screen_status.event_identifier.
              field_event_character_position, target_position, status);

      = fdc$tab_to_next_form_field =
        IF p_form_status^.p_form_definition^.form_object_definitions.
              active_number > 0 THEN
          fdp$find_next_object (fdv$screen_status.event_position.
                form_x_position, fdv$screen_status.event_position.
                form_y_position, p_form_status, object_index);
          fdp$tab_to_next_variable (p_form_status, object_index, status);
        IFEND;

      = fdc$tab_to_previous_form_field =
        IF p_form_status^.p_form_definition^.form_object_definitions.
              active_number > 0 THEN
          find_previous_object (fdv$screen_status.event_position.
                form_x_position, fdv$screen_status.event_position.
                form_y_position, p_form_status, object_index);
          tab_to_previous_variable (p_form_status, object_index, status);
        IFEND;

      ELSE
        event_defined := FALSE;
      CASEND;

    = fdc$form_text_box_fragment =
      parent_object_index := p_form_object_definition^.
            parent_text_box_object_index;
      p_parent_object_definition := ^p_form_object_definitions^
            [parent_object_index];
      event_position.object_x_position := p_parent_object_definition^.
            x_position;
      event_position.object_y_position := p_parent_object_definition^.
            y_position;
      CASE p_form_object_definitions^ [parent_object_index].key OF

      = fdc$form_variable_text_box =
        p_form_variable_definition := ^p_form_status^.
              p_form_variable_definitions^ [p_parent_object_definition^.
              variable_box_variable_index];
        IF p_form_variable_definition^.table_exists THEN
          event_position.object_occurrence :=
                event_position.object_occurrence +
                p_form_status^.p_form_table_statuses^ [
                p_form_variable_definition^.table_index].
                first_displayed_occurrence - 1;
        IFEND;

        event_position.object_definition_key := fdc$variable_text_box;
        event_position.character_position :=
              fdv$screen_status.event_identifier.
              field_event_character_position +
              p_form_status^.p_form_object_statuses^ [parent_object_index].
              character_position - 1 + ((p_form_object_definition^.y_position -
              p_parent_object_definition^.y_position) *
              p_parent_object_definition^.variable_box_width);
        variable_index := p_parent_object_definition^.
              variable_box_variable_index;
        p_form_variable_definition := ^p_form_status^.
              p_form_variable_definitions^ [variable_index];
        screen_visible_length := p_parent_object_definition^.
              variable_box_width * p_parent_object_definition^.
              variable_box_height;
        fdp$ptr_screen_variable (p_form_status^.p_screen_record,
              p_form_variable_definition^.screen_record_position,
              p_form_variable_definition^.screen_variable_length, p_text);
        next_object_index := p_parent_object_definition^.
              variable_box_fragment_index;
        CASE event_action OF

        = fdc$return_program_normal, fdc$return_program_abnormal,
              fdc$ignore_event =

{ The above events will be processed later.

        = fdc$delete_variable_line =

{ Shift the screen record data to the left to remove the deleted line.  Then reformat the
{ screen variable in the text box.

       start_move_position := p_form_object_statuses^ [object_index].character_position +
             p_form_object_statuses^ [object_index].data_length;
       text_length := p_form_variable_definition^.screen_variable_length - start_move_position + 1;
       PUSH p_save_data: [text_length];
       p_save_data^ := p_text^ (start_move_position, text_length);
       p_text^ (p_form_object_statuses^ [object_index].character_position, *) :=  p_save_data^;
       p_form_object_statuses^ [parent_object_index].user_changed_field := TRUE;
       p_form_object_statuses^ [parent_object_index].user_entered_field := TRUE;
       target_position.key := fdc$current_data_position;
       format_screen_text (p_text, p_form_status, parent_object_index, next_object_index,
             p_parent_object_definition^.variable_box_processing,
             p_parent_object_definition^.variable_box_width,
             p_parent_object_definition^.variable_box_height, target_position, status);

{ Delete any scheduled screen changes due to insertion or deletions of characters in
{ variable text box.

        delete_format_screen_change (form_identifier, parent_object_index);

{ Set the cursor back to where the terminal user had left it.  Other processing moved the cursor.

        csv$vector.position_cursor^ (p_form_object_statuses^ [object_index].field_number,
             fdv$screen_status.event_identifier.field_event_character_position, 1,
             output_character_position, output_line_position, terminal_status);


        = fdc$display_help =
          display_variable_help (p_form_status, form_identifier,
                p_form_variable_definition, event_position.object_occurrence,
                status);

        = fdc$erase_help =
          erase_message_form (status);

        = fdc$insert_variable_line =

       start_move_position := p_form_object_statuses^ [object_index].character_position;
       text_length := p_form_variable_definition^.screen_variable_length - start_move_position + 1;
       PUSH p_save_data: [text_length];
       p_save_data^ := p_text^ (start_move_position, text_length);
       IF p_parent_object_definition^.variable_box_processing = fdc$wrap_words THEN

{ For a text box with with word wrap, place a record separator in the data.  At this time
{ we cannot determine how the words will be broken into lines. Later formatting will generate
{ a blank line upon seeing the record separator.

         p_text^ (start_move_position, 1) := record_separator;
         IF ((p_form_object_statuses^ [object_index].character_position + 1) <
               p_form_variable_definition^.screen_variable_length) THEN
           p_text^ (p_form_object_statuses^ [object_index].character_position + 1, text_length - 1)
                 := p_save_data^;
         IFEND;

       ELSE {fdc$wrap_characters}

{ For a text box with character, wrap we simply put a line of blanks in the data.

         p_text^ (start_move_position, p_parent_object_definition^.variable_box_width) := '';
         IF ((start_move_position + p_parent_object_definition^.variable_box_width) <
               p_form_variable_definition^.screen_variable_length) THEN
           p_text^ (start_move_position + p_parent_object_definition^.variable_box_width,
                 text_length - p_parent_object_definition^.variable_box_width) :=  p_save_data^;
         IFEND;
       IFEND;
       p_form_object_statuses^ [parent_object_index].user_changed_field := TRUE;
       p_form_object_statuses^ [parent_object_index].user_entered_field := TRUE;
       target_position.key := fdc$current_data_position;
       format_screen_text (p_text, p_form_status, parent_object_index, next_object_index,
             p_parent_object_definition^.variable_box_processing,
             p_parent_object_definition^.variable_box_width,
             p_parent_object_definition^.variable_box_height, target_position, status);

{ Delete any scheduled screen changes due to insertion or deletions of characters in
{ variable text box.

        delete_format_screen_change (form_identifier, parent_object_index);

{ Set the cursor back to where the terminal user had left it.  Other processing moved the cursor.

       csv$vector.position_cursor^ (p_form_object_statuses^ [object_index].field_number,
             fdv$screen_status.event_identifier.field_event_character_position, 1,
             output_character_position, output_line_position, terminal_status);

        = fdc$page_table_backward =
          find_table_to_page;
          IF event_defined THEN
            occurrence_shift := -p_form_table_definition^.visible_occurrence;
            page_table (p_form_table_status, p_form_table_definition, 1,
                  occurrence_shift, p_form_status^.field_number,
                  event_position.form_x_position,
                  event_position.form_y_position, status);
          IFEND;

        = fdc$page_table_forward =
          find_table_to_page;
          IF event_defined THEN
            occurrence_shift := p_form_table_definition^.visible_occurrence;
            page_table (p_form_table_status, p_form_table_definition, 1,
                  occurrence_shift, p_form_status^.field_number,
                  event_position.form_x_position,
                  event_position.form_y_position, status);
          IFEND;

        = fdc$page_table_first =
          find_table_to_page;
          IF event_defined THEN

{ Specify maximum shift.  Shift_table will compute actual shift need.

            occurrence_shift := -p_form_table_definition^.stored_occurrence;
            page_table (p_form_table_status, p_form_table_definition, 1,
                  occurrence_shift, p_form_status^.field_number,
                  event_position.form_x_position,
                  event_position.form_y_position, status);
          IFEND;

        = fdc$page_table_last =
          find_table_to_page;
          IF event_defined THEN

{ Specify maximum shift.  Shift_table will compute actual shifted needed.

            occurrence_shift := p_form_table_definition^.stored_occurrence;
            page_table (p_form_table_status, p_form_table_definition, 1,
                  occurrence_shift, p_form_status^.field_number,
                  event_position.form_x_position,
                  event_position.form_y_position, status);
          IFEND;

        = fdc$page_variable_backward =
          target_position.key := fdc$page_data_backward;
          shift_variable (p_form_status, p_form_variable_definition,
                parent_object_index, object_index, screen_visible_length,
                target_position, status);


        = fdc$page_variable_first =
          target_position.key := fdc$page_data_first;
          shift_variable (p_form_status, p_form_variable_definition,
                parent_object_index, object_index, screen_visible_length,
                target_position, status);

        = fdc$page_variable_forward =
          target_position.key := fdc$page_data_forward;
          shift_variable (p_form_status, p_form_variable_definition,
                parent_object_index, object_index, screen_visible_length,
                target_position, status);

        = fdc$page_variable_last =
          target_position.key := fdc$page_data_last;
          shift_variable (p_form_status, p_form_variable_definition,
                parent_object_index, object_index, screen_visible_length,
                target_position, status);

        = fdc$scroll_variable_backward =
          target_position.key := fdc$scroll_data_backward;
          target_position.data_index := fdv$screen_status.event_identifier.
              field_event_character_position + p_form_status^.p_form_object_statuses^ [object_index].
              character_position - 1;
          shift_variable (p_form_status, p_form_variable_definition,
                parent_object_index, object_index, screen_visible_length,
                target_position, status);

        = fdc$scroll_variable_forward =
          target_position.data_index := fdv$screen_status.event_identifier.
              field_event_character_position + p_form_status^.p_form_object_statuses^ [object_index].
              character_position - 1;
          target_position.key := fdc$scroll_data_forward;
          shift_variable (p_form_status, p_form_variable_definition,
                parent_object_index, object_index, screen_visible_length,
                target_position, status);

        = fdc$tab_to_next_form_field =
          object_index := object_index + 1;
          fdp$tab_to_next_variable (p_form_status, object_index, status);

        = fdc$tab_to_previous_form_field =
          IF fdv$screen_status.event_identifier.
                field_event_character_position = 1 THEN
            object_index := object_index - 1;
          IFEND;
          tab_to_previous_variable (p_form_status, object_index, status);

        ELSE
          event_defined := FALSE;
        CASEND;

      = fdc$form_constant_text_box =
        event_position.object_definition_key := fdc$constant_text_box;
        screen_visible_length := p_parent_object_definition^.
              constant_box_width * p_parent_object_definition^.
              constant_box_height;
        p_text := fdp$ptr_text (p_parent_object_definition^.constant_box_text,
              p_form_status^.p_form_module);
        next_object_index := p_parent_object_definition^.
              constant_box_fragment_index;
        CASE event_action OF

        = fdc$return_program_normal, fdc$return_program_abnormal,
              fdc$ignore_event =

        = fdc$display_help =
          display_form_help (p_form_status, status);

        = fdc$erase_help =
          erase_message_form (status);

        = fdc$page_table_backward =
          find_table_to_page;
          IF event_defined THEN
            occurrence_shift := -p_form_table_definition^.visible_occurrence;
            page_table (p_form_table_status, p_form_table_definition, 1,
                  occurrence_shift, p_form_status^.field_number,
                  event_position.form_x_position,
                  event_position.form_y_position, status);
          IFEND;

        = fdc$page_table_forward =
          find_table_to_page;
          IF event_defined THEN
            occurrence_shift := p_form_table_definition^.visible_occurrence;
            page_table (p_form_table_status, p_form_table_definition, 1,
                  occurrence_shift, p_form_status^.field_number,
                  event_position.form_x_position,
                  event_position.form_y_position, status);
          IFEND;

        = fdc$page_table_first =
          find_table_to_page;
          IF event_defined THEN

{ Specify maximum shift.  Shift_table will compute actual shift need.

            occurrence_shift := -p_form_table_definition^.stored_occurrence;
            page_table (p_form_table_status, p_form_table_definition, 1,
                  occurrence_shift, p_form_status^.field_number,
                  event_position.form_x_position,
                  event_position.form_y_position, status);
          IFEND;

        = fdc$page_table_last =
          find_table_to_page;
          IF event_defined THEN

{ Specify maximum shift.  Shift_table will compute actual shifted needed.

            occurrence_shift := p_form_table_definition^.stored_occurrence;
            page_table (p_form_table_status, p_form_table_definition, 1,
                  occurrence_shift, p_form_status^.field_number,
                  event_position.form_x_position,
                  event_position.form_y_position, status);
          IFEND;

        = fdc$page_variable_backward =
          target_position.key := fdc$scroll_data_backward;
          target_position.data_index := fdv$screen_status.event_identifier.
              field_event_character_position + p_form_status^.p_form_object_statuses^ [object_index].
              character_position - 1;
          shift_text_box (p_text, p_form_status, parent_object_index,
                next_object_index, p_parent_object_definition^.
                constant_box_processing, p_parent_object_definition^.
                constant_box_width, p_parent_object_definition^.
                constant_box_height, object_index,
                fdv$screen_status.event_identifier.
                field_event_character_position, target_position, status);

        = fdc$page_variable_first =
          target_position.key := fdc$page_data_first;
          shift_text_box (p_text, p_form_status, parent_object_index,
                next_object_index, p_parent_object_definition^.
                constant_box_processing, p_parent_object_definition^.
                constant_box_width, p_parent_object_definition^.
                constant_box_height, object_index,
                fdv$screen_status.event_identifier.
                field_event_character_position, target_position, status);

        = fdc$page_variable_forward =
          target_position.key := fdc$page_data_forward;
          shift_text_box (p_text, p_form_status, parent_object_index,
                next_object_index, p_parent_object_definition^.
                constant_box_processing, p_parent_object_definition^.
                constant_box_width, p_parent_object_definition^.
                constant_box_height, object_index,
                fdv$screen_status.event_identifier.
                field_event_character_position, target_position, status);

        = fdc$page_variable_last =
          target_position.key := fdc$page_data_last;
          shift_text_box (p_text, p_form_status, parent_object_index,
                next_object_index, p_parent_object_definition^.
                constant_box_processing, p_parent_object_definition^.
                constant_box_width, p_parent_object_definition^.
                constant_box_height, object_index,
                fdv$screen_status.event_identifier.
                field_event_character_position, target_position, status);

        = fdc$scroll_variable_backward =
          target_position.key := fdc$scroll_data_backward;
          target_position.data_index := fdv$screen_status.event_identifier.
              field_event_character_position + p_form_status^.p_form_object_statuses^ [object_index].
              character_position - 1;
          shift_text_box (p_text, p_form_status, parent_object_index,
                next_object_index, p_parent_object_definition^.
                constant_box_processing, p_parent_object_definition^.
                constant_box_width, p_parent_object_definition^.
                constant_box_height, object_index,
                fdv$screen_status.event_identifier.
                field_event_character_position, target_position, status);

        = fdc$scroll_variable_forward =
          target_position.key := fdc$scroll_data_forward;
          target_position.data_index := fdv$screen_status.event_identifier.
              field_event_character_position + p_form_status^.p_form_object_statuses^ [object_index].
              character_position - 1;
          shift_text_box (p_text, p_form_status, parent_object_index,
                next_object_index, p_parent_object_definition^.
                constant_box_processing, p_parent_object_definition^.
                constant_box_width, p_parent_object_definition^.
                constant_box_height, object_index,
                fdv$screen_status.event_identifier.
                field_event_character_position, target_position, status);

        = fdc$tab_to_next_form_field =
          IF p_form_status^.p_form_definition^.form_object_definitions.
                active_number > 0 THEN
            fdp$find_next_object (fdv$screen_status.event_position.
                  form_x_position, fdv$screen_status.event_position.
                  form_y_position, p_form_status, object_index);
            fdp$tab_to_next_variable (p_form_status, object_index, status);
          IFEND;

        = fdc$tab_to_previous_form_field =
          IF p_form_status^.p_form_definition^.form_object_definitions.
                active_number > 0 THEN
            find_previous_object (fdv$screen_status.event_position.
                  form_x_position, fdv$screen_status.event_position.
                  form_y_position, p_form_status, object_index);
            tab_to_previous_variable (p_form_status, object_index, status);
          IFEND;

        ELSE
          event_defined := FALSE;
        CASEND;

      ELSE
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$system_error, 'invalid parent object ', status);
      CASEND;

    = fdc$form_variable_text =
      event_position.object_definition_key := fdc$variable_text;
      variable_index := p_form_object_definition^.text_variable_index;
      p_form_variable_definition := ^p_form_status^.
            p_form_variable_definitions^ [variable_index];
      screen_visible_length := p_form_object_definition^.text_variable_width;
      p_form_variable_definition := ^p_form_status^.
            p_form_variable_definitions^ [variable_index];

      CASE event_action OF

      = fdc$return_program_normal, fdc$return_program_abnormal =
        event_position.character_position :=
              fdv$screen_status.event_identifier.
              field_event_character_position +
              p_form_status^.p_form_object_statuses^ [object_index].
              character_position - 1;
        p_form_variable_definition := ^p_form_status^.
              p_form_variable_definitions^ [p_form_object_definition^.
              text_variable_index];

        IF p_form_variable_definition^.table_exists THEN
          event_position.object_occurrence :=
                event_position.object_occurrence +
                p_form_status^.p_form_table_statuses^ [
                p_form_variable_definition^.table_index].
                first_displayed_occurrence - 1;
        IFEND;

      = fdc$display_help =
        display_variable_help (p_form_status, form_identifier,
              p_form_variable_definition, event_position.object_occurrence,
              status);

      = fdc$erase_help =
        erase_message_form (status);

      = fdc$ignore_event =

{ Do nothing at this time.

      = fdc$page_table_backward =
        IF p_form_variable_definition^.table_exists THEN
          table_index := p_form_variable_definition^.table_index;
          p_form_table_definition := ^p_form_status^.
                p_form_table_definitions^ [table_index];
          occurrence_shift := -p_form_table_definition^.visible_occurrence;
          page_table (p_form_status, p_form_table_definition, table_index,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        ELSE
          find_table_to_page;
          IF event_defined THEN
            occurrence_shift := -p_form_table_definition^.visible_occurrence;
            page_table (p_form_table_status, p_form_table_definition, 1,
                  occurrence_shift, p_form_status^.field_number,
                  event_position.form_x_position,
                  event_position.form_y_position, status);
          IFEND;
        IFEND;

      = fdc$page_table_forward =
        IF p_form_variable_definition^.table_exists THEN
          table_index := p_form_variable_definition^.table_index;
          p_form_table_definition := ^p_form_status^.
                p_form_table_definitions^ [table_index];
          occurrence_shift := p_form_table_definition^.visible_occurrence;
          page_table (p_form_status, p_form_table_definition, table_index,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        ELSE
          find_table_to_page;
          IF event_defined THEN
            occurrence_shift := p_form_table_definition^.visible_occurrence;
            page_table (p_form_table_status, p_form_table_definition, 1,
                  occurrence_shift, p_form_status^.field_number,
                  event_position.form_x_position,
                  event_position.form_y_position, status);
          IFEND;
        IFEND;

      = fdc$page_table_first =
        IF p_form_variable_definition^.table_exists THEN
          table_index := p_form_variable_definition^.table_index;
          p_form_table_definition := ^p_form_status^.
                p_form_table_definitions^ [table_index];

{ Specify maximum shift.  Shift_table will compute actual shift need.

          occurrence_shift := -p_form_table_definition^.stored_occurrence;
          page_table (p_form_status, p_form_table_definition, table_index,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        ELSE
          find_table_to_page;
          IF event_defined THEN
            occurrence_shift := -p_form_table_definition^.stored_occurrence;
            page_table (p_form_table_status, p_form_table_definition, 1,
                  occurrence_shift, p_form_status^.field_number,
                  event_position.form_x_position,
                  event_position.form_y_position, status);
          IFEND;
        IFEND;

      = fdc$page_table_last =
        IF p_form_variable_definition^.table_exists THEN
          table_index := p_form_variable_definition^.table_index;
          p_form_table_definition := ^p_form_status^.
                p_form_table_definitions^ [table_index];

{ Specify maximum shift.  Shift_table will compute actual shifted needed.

          occurrence_shift := p_form_table_definition^.stored_occurrence;
          page_table (p_form_status, p_form_table_definition, table_index,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        ELSE
          find_table_to_page;
          IF event_defined THEN
            occurrence_shift := p_form_table_definition^.stored_occurrence;
            page_table (p_form_table_status, p_form_table_definition, 1,
                  occurrence_shift, p_form_status^.field_number,
                  event_position.form_x_position,
                  event_position.form_y_position, status);
          IFEND;
        IFEND;

      = fdc$scroll_table_backward =
        IF p_form_variable_definition^.table_exists THEN
          table_index := p_form_variable_definition^.table_index;
          p_form_table_definition := ^p_form_status^.
                p_form_table_definitions^ [table_index];
          occurrence_shift := -(p_form_table_definition^.visible_occurrence -
                p_form_object_definition^.occurrence);
          shift_table (p_form_status, p_form_table_definition, table_index,
                occurrence_shift, 0, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          csv$vector.position_cursor^ (p_form_status^.
                p_form_object_statuses^ [object_index].field_number, position,
                1, output_character_position, output_line_position,
                terminal_status);
          IF NOT terminal_status.normal THEN
            fdp$convert_terminal_status (terminal_status, status);
            RETURN;
          IFEND;
        IFEND;

      = fdc$scroll_table_forward =
        IF p_form_variable_definition^.table_exists THEN
          table_index := p_form_variable_definition^.table_index;
          p_form_table_definition := ^p_form_status^.
                p_form_table_definitions^ [table_index];
          occurrence_shift := p_form_object_definition^.occurrence - 1;
          shift_table (p_form_status, p_form_table_definition, table_index,
                occurrence_shift, 0, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          csv$vector.position_cursor^ (p_form_status^.
                p_form_object_statuses^ [object_index].field_number, position,
                1, output_character_position, output_line_position,
                terminal_status);
          IF NOT terminal_status.normal THEN
            fdp$convert_terminal_status (terminal_status, status);
          IFEND;
        IFEND;

      = fdc$page_variable_backward =
        target_position.key := fdc$page_data_backward;
        shift_variable (p_form_status, p_form_variable_definition,
              object_index, object_index, screen_visible_length, target_position,
              status);

      = fdc$page_variable_first =
        target_position.key := fdc$page_data_first;
        shift_variable (p_form_status, p_form_variable_definition,
              object_index, object_index, screen_visible_length, target_position,
              status);


      = fdc$page_variable_forward =
        target_position.key := fdc$page_data_forward;
        shift_variable (p_form_status, p_form_variable_definition,
              object_index, object_index, screen_visible_length, target_position,
              status);

      = fdc$page_variable_last =
        target_position.key := fdc$page_data_last;
        shift_variable (p_form_status, p_form_variable_definition,
              object_index, object_index, screen_visible_length, target_position,
              status);

      = fdc$scroll_variable_backward =
        target_position.key := fdc$scroll_data_backward;
        target_position.data_index := fdv$screen_status.event_identifier.
              field_event_character_position + p_form_status^.p_form_object_statuses^ [object_index].
              character_position - 1;
        shift_variable (p_form_status, p_form_variable_definition,
              object_index, object_index, screen_visible_length, target_position,
              status);

      = fdc$scroll_variable_forward =
        target_position.key := fdc$scroll_data_forward;
        target_position.data_index := fdv$screen_status.event_identifier.
              field_event_character_position + p_form_status^.p_form_object_statuses^ [object_index].
              character_position - 1;
        shift_variable (p_form_status, p_form_variable_definition,
              object_index, object_index, screen_visible_length, target_position,
              status);

      = fdc$tab_to_next_form_field =
        object_index := object_index + 1;
        fdp$tab_to_next_variable (p_form_status, object_index, status);

      = fdc$tab_to_previous_form_field =
        IF fdv$screen_status.event_identifier.field_event_character_position =
              1 THEN
          object_index := object_index - 1;
        IFEND;
        tab_to_previous_variable (p_form_status, object_index, status);

      ELSE
        event_defined := FALSE;
      CASEND;

    = fdc$form_variable_text_box =
      event_position.object_definition_key := fdc$variable_text_box;
      variable_index := p_form_object_definition^.variable_box_variable_index;
      p_form_variable_definition := ^p_form_status^.
            p_form_variable_definitions^ [variable_index];
      screen_visible_length := p_form_object_definition^.variable_box_width *
            p_form_object_definition^.variable_box_height;
      fdp$ptr_screen_variable (p_form_status^.p_screen_record,
            p_form_variable_definition^.screen_record_position,
            p_form_variable_definition^.screen_variable_length, p_text);
      next_object_index := p_form_object_definition^.
            variable_box_fragment_index;

      CASE event_action OF

     = fdc$return_program_normal, fdc$return_program_abnormal =
        event_position.character_position :=
              fdv$screen_status.event_identifier.
              field_event_character_position +
              p_form_status^.p_form_object_statuses^ [object_index].
              character_position - 1;

      = fdc$display_help =
        display_variable_help (p_form_status, form_identifier,
              p_form_variable_definition, event_position.object_occurrence,
              status);

      = fdc$erase_help =
        erase_message_form (status);

      = fdc$delete_variable_line =

{ Shift the screen record data to the left to remove the deleted line.  Then reformat the
{ screen variable in the text box.

       start_move_position := p_form_object_statuses^ [object_index].character_position +
             p_form_object_statuses^ [object_index].data_length;
       text_length := p_form_variable_definition^.screen_variable_length - start_move_position + 1;
       PUSH p_save_data: [text_length];
       p_save_data^ := p_text^ (start_move_position, text_length);
       p_form_object_statuses^ [object_index].user_changed_field := TRUE;
       p_form_object_statuses^ [object_index].user_entered_field := TRUE;
       p_text^ (p_form_object_statuses^ [object_index].character_position, *) :=  p_save_data^;
       target_position.key := fdc$current_data_position;
       format_screen_text (p_text, p_form_status, object_index, next_object_index,
             p_form_object_definition^.variable_box_processing,
             p_form_object_definition^.variable_box_width,
             p_form_object_definition^.variable_box_height, target_position, status);

{ Delete any scheduled screen changes due to insertion or deletions of characters in
{ variable text box.

        delete_format_screen_change (form_identifier, object_index);

{ Set the cursor back to where the terminal user had left it.  Other processing moved the cursor.

        csv$vector.position_cursor^ (p_form_object_statuses^ [object_index].field_number,
             fdv$screen_status.event_identifier.field_event_character_position, 1,
             output_character_position, output_line_position, terminal_status);


      = fdc$ignore_event =

{ Do nothing at this time. This event will be handled later.

      = fdc$insert_variable_line =

{ For a text box with with word wrap, place a record separator in the data.  At this time
{ we cannot determine how the words will be broken into lines. Later formatting will generate
{ a blank line upon seeing the record separator.

       start_move_position := p_form_object_statuses^ [object_index].character_position;
       text_length := p_form_variable_definition^.screen_variable_length - start_move_position + 1;
       PUSH p_save_data: [text_length];
       p_save_data^ := p_text^ (start_move_position, text_length);
       IF p_form_object_definition^.variable_box_processing = fdc$wrap_words THEN
         p_text^ (start_move_position, 1) := record_separator;
         IF ((p_form_object_statuses^ [object_index].character_position + 1) <
               p_form_variable_definition^.screen_variable_length) THEN
           p_text^ (p_form_object_statuses^ [object_index].character_position + 1, text_length - 1)
                 :=  p_save_data^;
         IFEND;
       ELSE {fdc$wrap_characters}
         p_text^ (start_move_position, p_form_object_definition^.variable_box_width) := '';
         IF ((start_move_position + p_form_object_definition^.variable_box_width) <
               p_form_variable_definition^.screen_variable_length) THEN
           p_text^ (start_move_position + p_form_object_definition^.variable_box_width,
               text_length - p_form_object_definition^.variable_box_width) :=  p_save_data^;
         IFEND;
       IFEND;
       p_form_object_statuses^ [object_index].user_changed_field := TRUE;
       p_form_object_statuses^ [object_index].user_entered_field := TRUE;
       target_position.key := fdc$current_data_position;
       format_screen_text (p_text, p_form_status, object_index, next_object_index,
             p_form_object_definition^.variable_box_processing,
             p_form_object_definition^.variable_box_width,
             p_form_object_definition^.variable_box_height, target_position, status);

{ Delete any scheduled screen changes due to insertion or deletions of characters in
{ variable text box.

        delete_format_screen_change (form_identifier, object_index);

{ Set the cursor back to where the terminal user had left it.  Other processing moved the cursor.

       csv$vector.position_cursor^ (p_form_object_statuses^ [object_index].field_number,
             fdv$screen_status.event_identifier.field_event_character_position, 1,
             output_character_position, output_line_position, terminal_status);

      = fdc$page_table_backward =
        find_table_to_page;
        IF event_defined THEN
          occurrence_shift := -p_form_table_definition^.visible_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$page_table_forward =
        find_table_to_page;
        IF event_defined THEN
          occurrence_shift := p_form_table_definition^.visible_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$page_table_first =
        find_table_to_page;
        IF event_defined THEN

{ Specify maximum shift.  Shift_table will compute actual shift need.

          occurrence_shift := -p_form_table_definition^.stored_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$page_table_last =
        find_table_to_page;
        IF event_defined THEN

{ Specify maximum shift.  Shift_table will compute actual shifted needed.

          occurrence_shift := p_form_table_definition^.stored_occurrence;
          page_table (p_form_table_status, p_form_table_definition, 1,
                occurrence_shift, p_form_status^.field_number,
                event_position.form_x_position, event_position.form_y_position,
                status);
        IFEND;

      = fdc$page_variable_backward =
        target_position.key := fdc$page_data_backward;
        shift_variable (p_form_status, p_form_variable_definition,
              object_index, object_index, screen_visible_length, target_position,
              status);

      = fdc$page_variable_first =
        target_position.key := fdc$page_data_first;
        shift_variable (p_form_status, p_form_variable_definition,
              object_index, object_index, screen_visible_length, target_position,
              status);

      = fdc$page_variable_forward =
        target_position.key := fdc$page_data_forward;
        shift_variable (p_form_status, p_form_variable_definition,
              object_index, object_index, screen_visible_length, target_position,
              status);

      = fdc$page_variable_last =
        target_position.key := fdc$page_data_last;
        shift_variable (p_form_status, p_form_variable_definition,
              object_index, object_index, screen_visible_length, target_position,
              status);

      = fdc$scroll_variable_backward =
        target_position.key := fdc$scroll_data_backward;
        target_position.data_index := fdv$screen_status.event_identifier.
              field_event_character_position + p_form_status^.p_form_object_statuses^ [object_index].
              character_position - 1;
        shift_variable (p_form_status, p_form_variable_definition,
              object_index, object_index, screen_visible_length, target_position,
              status);

      = fdc$scroll_variable_forward =
        target_position.key := fdc$scroll_data_forward;
        target_position.data_index := fdv$screen_status.event_identifier.
              field_event_character_position + p_form_status^.p_form_object_statuses^ [object_index].
              character_position - 1;
        shift_variable (p_form_status, p_form_variable_definition,
              object_index, object_index, screen_visible_length, target_position,
              status);

      = fdc$tab_to_next_form_field =
        object_index := object_index + 1;
        fdp$tab_to_next_variable (p_form_status, object_index, status);

      = fdc$tab_to_previous_form_field =
        IF fdv$screen_status.event_identifier.field_event_character_position =
              1 THEN
          object_index := object_index - 1;
        IFEND;
        tab_to_previous_variable (p_form_status, object_index, status);

      ELSE
        event_defined := FALSE;
      CASEND;

    ELSE

{ Invalid object definition key.

      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
            'invalid object definition key ', status);
    CASEND;
  PROCEND process_screen_object_event;

?? OLDTITLE ??
?? NEWTITLE := 'process_screen_page_event', EJECT ??

{ PURPOSE:
{   This procedure process events that occurred on no form or
{   on graphic objects on a form. Determine the event position.  Perform the
{   specified action.

  PROCEDURE process_screen_page_event;

?? NEWTITLE := 'find_screen_object', EJECT ??

{ PURPOSE:
{   This procedure finds graphic objects on a form. The Screen Manager returns a page
{   event when the event occurs on a graphic object.

  PROCEDURE find_screen_object;

    VAR
      object_x_position: fdt$x_position,
      object_y_position: fdt$x_position;

    event_position.screen_x_position := fdv$screen_status.event_identifier.page_event_x_position;
    event_position.screen_y_position := fdv$screen_status.event_identifier.page_event_y_position;
    form_identifier := fdv$screen_status.current_form_identifier;

    WHILE form_identifier <> 0 DO
      p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
      IF p_form_status^.displayed_on_screen THEN
        p_form_definition := p_form_status^.p_form_definition;

{ Look on all forms top to bottom residing on terminal screen for object.

       IF event_position.screen_x_position >= p_form_status^.form_x_position THEN
         IF event_position.screen_y_position >= p_form_status^.form_y_position THEN
            IF event_position.screen_x_position <= p_form_status^.form_x_position + p_form_definition^.width -
                  1 THEN
              IF event_position.screen_y_position <= p_form_status^.form_y_position +
                  p_form_definition^.height - 1 THEN

{ Object is inside form. Find particular object.

                p_form_object_definitions := p_form_status^.p_form_object_definitions;
                fdv$screen_status.last_cursor_position_valid := TRUE;
                fdv$screen_status.last_cursor_form_identifier := form_identifier;
                p_form_status^.last_cursor_position_valid := TRUE;
                p_form_status^.last_cursor_form_x_position := event_position.screen_x_position -
                      p_form_status^.form_x_position + 1;
                p_form_status^.last_cursor_form_y_position := event_position.screen_y_position -
                    p_form_status^.form_y_position + 1;

                event_position.form_identifier := form_identifier;
                event_position.form_x_position := p_form_status^.last_cursor_form_x_position;
                event_position.form_y_position := p_form_status^.last_cursor_form_y_position;

              /check_form_objects/
                FOR object_index := p_form_status^.p_form_definition^.form_object_definitions.
                      active_number DOWNTO 1 DO
                  p_form_object_definition := ^p_form_object_definitions^ [object_index];
                  object_x_position := p_form_object_definition^.x_position + p_form_status^.form_x_position -
                          1;
                  object_y_position := p_form_object_definition^.y_position + p_form_status^.form_y_position -
                          1;
                  IF event_position.screen_x_position >= object_x_position THEN
                    IF event_position.screen_y_position >= object_y_position THEN
                      CASE p_form_object_definition^.key OF

                      = fdc$form_box =
                        IF event_position.screen_x_position <= object_x_position +
                                p_form_object_definition^.box_width - 1 THEN
                          IF ((event_position.screen_y_position = object_y_position) OR
                                (event_position.screen_y_position = object_y_position +
                                p_form_object_definition^.box_height - 1)) THEN
                            event_position.key := fdc$object_event;
                            event_position.object_x_position := p_form_object_definition^.x_position;
                            event_position.object_y_position := p_form_object_definition^.y_position;
                            event_position.object_name := p_form_object_definition^.name;
                            event_position.object_occurrence := p_form_object_definition^.occurrence;
                            event_position.object_definition_key := fdc$box;
                            object_exists := TRUE;
                            RETURN;
                         IFEND;
                        IFEND;

                        IF ((event_position.screen_x_position = object_x_position) OR
                              (event_position.screen_x_position = object_x_position +
                              p_form_object_definition^.box_width - 1)) THEN
                          IF event_position.screen_y_position <= object_y_position +
                                p_form_object_definition^.box_height - 1 THEN
                            event_position.key := fdc$object_event;
                            event_position.object_x_position := p_form_object_definition^.x_position;
                            event_position.object_y_position := p_form_object_definition^.y_position;
                            event_position.object_name := p_form_object_definition^.name;
                            event_position.object_occurrence := p_form_object_definition^.occurrence;
                            event_position.object_definition_key := fdc$box;
                            object_exists := TRUE;
                            RETURN;
                          IFEND;
                        IFEND;

                      = fdc$form_line =
                        IF event_position.screen_x_position <= object_x_position +
                              p_form_object_definition^.x_increment THEN
                          IF event_position.screen_y_position <= object_y_position +
                              p_form_object_definition^.y_increment THEN
                            event_position.key := fdc$object_event;
                            event_position.object_x_position := p_form_object_definition^.x_position;
                            event_position.object_y_position := p_form_object_definition^.y_position;
                            event_position.object_name := p_form_object_definition^.name;
                            event_position.object_occurrence := p_form_object_definition^.occurrence;
                            event_position.object_definition_key := fdc$line;
                            object_exists := TRUE;
                            RETURN;
                          IFEND;
                        IFEND;

                      ELSE
                      CASEND;
                    IFEND;
                  IFEND;
                FOREND /check_form_objects/;

{ The event occurred on the form, but not on any form object.

                object_exists := TRUE;
                event_position.key := fdc$form_event;
                RETURN;
              IFEND;
            IFEND;
         IFEND;
        IFEND;
      IFEND;
      form_identifier := p_form_status^.next_lower_form;
    WHILEND;
  PROCEND find_screen_object;

?? OLDTITLE, EJECT ??

{ Any event on a graphic object is considered a page event.
{ Find the the form and object based on the screen (page) location.

    find_screen_object;
    IF NOT object_exists THEN
      RETURN;
    IFEND;

    IF NOT p_form_status^.events_active THEN
      RETURN;
    IFEND;

    translate_screen_event;
    IF NOT event_defined THEN
      RETURN;
    IFEND;

    CASE event_action OF

    = fdc$return_program_normal, fdc$return_program_abnormal,
          fdc$ignore_event =

{ The above events will be processed later.

    = fdc$display_help =
      display_form_help (p_form_status, status);

    = fdc$erase_help =
      erase_message_form (status);

    = fdc$page_table_backward =
      find_table_to_page;
      IF event_defined THEN
        occurrence_shift := -p_form_table_definition^.visible_occurrence;
        page_table (p_form_table_status,
              p_form_table_definition, 1, occurrence_shift,
              p_form_status^.field_number, event_position.form_x_position,
              event_position.form_y_position, status);
      IFEND;

    = fdc$page_table_forward =
      find_table_to_page;
      IF event_defined THEN
        occurrence_shift := p_form_table_definition^.visible_occurrence;
        page_table (p_form_table_status, p_form_table_definition, 1,
              occurrence_shift, p_form_status^.field_number,
              event_position.form_x_position, event_position.form_y_position,
              status);
      IFEND;

    = fdc$page_table_first =
      find_table_to_page;
      IF event_defined THEN

{ Specify maximum shift.  Shift_table will compute actual shift need.

        occurrence_shift := -p_form_table_definition^.stored_occurrence;
        page_table (p_form_table_status, p_form_table_definition, 1,
              occurrence_shift, p_form_status^.field_number,
              event_position.form_x_position, event_position.form_y_position,
              status);
      IFEND;

    = fdc$page_table_last =
      find_table_to_page;
      IF event_defined THEN

{ Specify maximum shift.  Shift_table will compute actual shifted needed.


        occurrence_shift := p_form_table_definition^.stored_occurrence;
        page_table (p_form_table_status, p_form_table_definition, 1,
              occurrence_shift, p_form_status^.field_number,
              event_position.form_x_position, event_position.form_y_position,
              status);
      IFEND;

    = fdc$tab_to_next_form_field =
      IF p_form_status^.p_form_definition^.form_object_definitions.
            active_number > 0 THEN
        fdp$find_next_object (fdv$screen_status.event_position.form_x_position,
              fdv$screen_status.event_position.form_y_position, p_form_status,
              object_index);
        fdp$tab_to_next_variable (p_form_status, object_index, status);
      IFEND;

    = fdc$tab_to_previous_form_field =
      IF p_form_status^.p_form_definition^.form_object_definitions.
            active_number > 0 THEN
        find_previous_object (fdv$screen_status.event_position.form_x_position,
              fdv$screen_status.event_position.form_y_position, p_form_status,
              object_index);
        tab_to_previous_variable (p_form_status, object_index, status);
      IFEND;

    ELSE
      event_defined := FALSE;
    CASEND;

  PROCEND process_screen_page_event;

?? OLDTITLE ??
?? NEWTITLE := 'translate_screen_event', EJECT ??

{ PURPOSE:
{   This procedure maps the Screen Manager event to the Screen Formatting event.
{ DESIGN:
{   Event_recognized and event_defined are FALSE on entry.

  PROCEDURE translate_screen_event;

    VAR
      event_index: fdt$event_index,
      p_event_definition: ^fdt$event_definition,
      p_event_form_status: ^fdt$form_status;

    IF NOT p_form_status^.events_active THEN
      RETURN;
    IFEND;

{ Translate Screen Manager event to Screen Formatting event trigger.

    CASE fdv$screen_status.event_identifier.event_type OF

    = csc$timeout_event =
      event_recognized := TRUE;
      event_trigger := fdc$time_out;

    = csc$page_event =
      CASE fdv$screen_status.event_identifier.page_event.event_type OF

      = csc$locate =
        event_recognized := TRUE;
        event_trigger := fdc$pick;

      = csc$page_standard_function =
        event_recognized := TRUE;
        event_trigger := standard_event_table [fdv$screen_status.event_identifier.page_event.
              standard_function];

      = csc$page_application_function =
        event_recognized := TRUE;
        event_trigger := fdv$application_event_table [fdv$screen_status.event_identifier.page_event.
              application_function];

      = csc$page_screen =
        event_recognized := TRUE;
        event_trigger := screen_event_table [fdv$screen_status.event_identifier.page_event.screen_event];

      ELSE
        RETURN;
      CASEND;

    = csc$field_event =
      CASE fdv$screen_status.event_identifier.field_event.event_type OF

      = csc$pick =
        event_recognized := TRUE;
        event_trigger := fdc$pick;

      = csc$field_screen =
        event_recognized := TRUE;
        event_trigger := screen_event_table [fdv$screen_status.event_identifier.field_event.screen_event];

      = csc$field_standard_function =
        event_recognized := TRUE;
        event_trigger := standard_event_table [fdv$screen_status.event_identifier.field_event.
              standard_function];

      = csc$field_application_function =
        event_recognized := TRUE;
        event_trigger := fdv$application_event_table [fdv$screen_status.event_identifier.field_event.
              application_function];

      ELSE { Event is not recognized.
        RETURN;
      CASEND;
    ELSE { Event is not recognized.
      RETURN;
    CASEND;

    IF p_form_status^.added THEN

{ Translate Screen Formatting event trigger to application program event name.
{ Use only event definitions of added form.

      FOR event_index := 1 TO p_form_status^.p_form_definition^.event_definitions.active_number DO
        p_event_definition := ^p_form_status^.p_event_definitions^ [event_index];
        IF (p_form_status^.p_form_event_statuses^ [event_index].event_exists AND
              (p_form_status^.p_form_event_statuses^ [event_index].event_trigger =
              event_trigger)) THEN
          event_action := p_event_definition^.event_action;
          event_name := p_event_definition^.event_name;
          event_defined := TRUE;
          RETURN;
        IFEND;
      FOREND;

    ELSE

{ This is a combined form.

      p_event_form_status := ^fdv$screen_status.p_forms_status^ [p_form_status^.added_form_identifier];

      IF p_form_status^.combined_events THEN

{ Use event definitions of combined form and added form.  The event definition of
{ the combined form is used if present; otherwise the event of the added form
{ is used.  Translate Screen Formatting event trigger to
{ application program event name.

        FOR event_index := 1 TO p_form_status^.p_form_definition^.event_definitions.active_number DO
          p_event_definition := ^p_form_status^.p_event_definitions^ [event_index];
          IF (p_form_status^.p_form_event_statuses^ [event_index].event_exists AND
                (p_form_status^.p_form_event_statuses^ [event_index].event_trigger =
                      event_trigger)) THEN
            event_action := p_event_definition^.event_action;
            event_name := p_event_definition^.event_name;
            event_defined := TRUE;
            RETURN;
          IFEND;
        FOREND;

        FOR event_index := 1 TO p_event_form_status^.p_form_definition^.event_definitions.active_number DO
          p_event_definition := ^p_event_form_status^.p_event_definitions^ [event_index];
          IF (p_event_form_status^.p_form_event_statuses^ [event_index].event_exists AND
                (p_event_form_status^.p_form_event_statuses^ [event_index].event_trigger =
                      event_trigger)) THEN
            event_action := p_event_definition^.event_action;
            event_name := p_event_definition^.event_name;
            event_defined := TRUE;
            RETURN;
          IFEND;
        FOREND;

      ELSE

{ The events are not combined.  Use the events of the added form.

        FOR event_index := 1 TO p_event_form_status^.p_form_definition^.event_definitions.active_number DO
          p_event_definition := ^p_event_form_status^.p_event_definitions^ [event_index];
          IF (p_event_form_status^.p_form_event_statuses^ [event_index].event_exists AND
                (p_event_form_status^.p_form_event_statuses^ [event_index].event_trigger =
                      event_trigger)) THEN
            event_action := p_event_definition^.event_action;
            event_name := p_event_definition^.event_name;
            event_defined := TRUE;
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    IFEND;

  PROCEND translate_screen_event;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    bad_key_displayed := FALSE;
    event_highlighted := FALSE;

    REPEAT
      flush_events := TRUE;

{ Do not flush buffer on most page events. For example, do not lose the
{ carriage return for the home key. On a clear screen event, the
{ Screen Manager has already cleared the screen, just remove the
{ the following events to make the application behave well.

      CASE fdv$screen_status.event_identifier.event_type OF

      = csc$page_event =
        CASE fdv$screen_status.event_identifier.page_event.event_type OF

        = csc$page_screen =
          IF fdv$screen_status.event_identifier.page_event.screen_event <> csc$clear THEN
            flush_events := FALSE;
          IFEND;

        ELSE
        CASEND;

      = csc$field_event =
        CASE fdv$screen_status.event_identifier.field_event.event_type OF

        = csc$field_screen =
          IF fdv$screen_status.event_identifier.field_event.screen_event <> csc$clear THEN
            flush_events := FALSE;
          IFEND;

        ELSE
        CASEND;

      ELSE
      CASEND;

      IF flush_events THEN
        csv$vector.flush_events^ (terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          erase_message_form (local_status);
          RETURN;
        IFEND;
      IFEND;

      csv$vector.get_event^ (fdv$screen_status.event_identifier, terminal_status);
      IF NOT terminal_status.normal THEN
        fdp$convert_terminal_status (terminal_status, status);
        erase_message_form (local_status);
        RETURN;
      IFEND;

{ Update Screen Formatting screen data associated with all forms on the screen.
{ Updating program data about a form depends on the action specified with the
{ terminal user event.

      get_screen_variables;
      IF NOT status.normal THEN
        erase_message_form (local_status);
        RETURN;
      IFEND;

      event_defined := FALSE;
      event_on_message_form := FALSE;
      event_recognized := FALSE;
      form_object := FALSE;
      object_exists := FALSE;

{ All normal program, abnormal program, and ignore events will be processed
{ at the end of this CASE statement.


      CASE fdv$screen_status.event_identifier.event_type OF

      = csc$page_event =
        process_screen_page_event;

      = csc$field_event =
        field_number := fdv$screen_status.event_identifier.field_event_field_number;
        find_screen_identifier;
        IF p_form_status^.events_active THEN
          IF form_object THEN

{ The event occurred on an area of the form that contained no object.

            process_screen_form_event;


          ELSEIF object_exists THEN

{ The event occurred on a form area that contained an object.

            process_screen_object_event;

          IFEND;
        IFEND;

      = csc$timeout_event =
        erase_message_form (local_status);
        event_normal := FALSE;
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$terminal_timed_out, ' ', status);
        RETURN;

      ELSE { Invalid event type. }
        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'invalid event ', status);
      CASEND;

      IF NOT status.normal THEN
        erase_message_form (local_status);
        RETURN;
      IFEND;

      event_on_message_form :=
        (fdv$screen_status.message_form_displayed AND
        (fdv$screen_status.message_form_identifier = form_identifier));

    /process_program_return/
      BEGIN
        IF NOT event_defined THEN
          IF (event_recognized AND ((event_trigger = fdc$clear_screen)
                OR (event_trigger = fdc$home_cursor))) THEN
            erase_message_form (local_status);
            bad_key_displayed := FALSE;
            EXIT /process_program_return/;
          IFEND;

          IF NOT bad_key_displayed THEN
            erase_message_form (local_status);
            fdp$get_message (fde$system_bad_key_message, message_text);
            display_message_text (^message_text, osc$null_name, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            bad_key_displayed := TRUE;
          ELSE

{ Terminal user is confused.  The user depressed another bad key.
{ Remove bad key message.

            erase_message_form (local_status);
            bad_key_displayed := FALSE;
          IFEND;
          EXIT /process_program_return/;
        IFEND;

{ Event is defined.  Remove any previous bad key pressed message.

        IF bad_key_displayed THEN
          bad_key_displayed := FALSE;
          erase_message_form (local_status);
        IFEND;

        CASE event_action OF

        = fdc$return_program_normal =
          erase_message_form (local_status);
          IF event_on_message_form THEN
            EXIT /process_program_return/;
          IFEND;

{ Update the program records of combined forms where the event occurred.

          IF p_form_status^.combined THEN
            form_identifier := p_form_status^.added_form_identifier;
            p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
          IFEND;

          update_program_record (p_form_status, form_identifier, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF fdv$screen_status.message_form_displayed  THEN
            EXIT /process_program_return/;
          IFEND;

          current_form_identifier := fdv$screen_status.current_form_identifier;
          WHILE current_form_identifier <> 0 DO
            p_record_form_status := ^fdv$screen_status.p_forms_status^ [current_form_identifier];
            IF p_record_form_status^.entry_used THEN
              IF (p_record_form_status^.combined AND (p_record_form_status^.added_form_identifier =
                    form_identifier)) THEN
                update_program_record (p_record_form_status, current_form_identifier, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                IF fdv$screen_status.message_form_displayed  THEN
                  EXIT /process_program_return/;
                IFEND;
              IFEND;
            IFEND;
            current_form_identifier := p_record_form_status^.next_lower_form;
          WHILEND;

{ Highlight event executed by terminal user on event menu form.

          highlight_event;
          event_normal := TRUE;
          RETURN;

        = fdc$return_program_abnormal =
          erase_message_form (local_status);
          IF event_on_message_form THEN
            EXIT /process_program_return/;
          IFEND;

{ Highlight event executed by terminal user on event menu form.

          highlight_event;
          event_normal := FALSE;
          RETURN;

        = fdc$ignore_event =
          erase_message_form (local_status);

{ Ignore this event and accept another event from the terminal user.
{ Set the cursor position because the Screen Manager assumes Screen Formatting maintains cursor.

          IF form_object OR object_exists THEN
            character_position := event_position.form_x_position;
            line_number := event_position.form_y_position;
            csv$vector.position_cursor^ (p_form_status^.field_number,
                  character_position, line_number,
                  output_character_position, output_line_position,
                  local_status);
          IFEND;
        ELSE

{ A page, scroll, or tab event occurred.
{ Leave error and help forms displayed while terminal user pages, scrolls, and tabs.

        CASEND;
      END /process_program_return/;

{ Process more events from terminal user.  Current event is processed by Screen Formatting
{ and not the application program. Highlight event pressed by terminal user.

      compute_event_highlight;
      IF event_highlighted THEN
        fdp$record_screen_change (highlight_event_change, local_status);
      IFEND;

      fdp$change_screen (local_status);
      fdv$screen_status.cursor_set := FALSE;
      IF event_highlighted THEN
        csv$vector.update_device^ (local_status);
        fdp$record_screen_change (reset_event_change, local_status);
        fdp$change_screen (local_status);
        event_highlighted := FALSE;
      IFEND;

    UNTIL FALSE;

  PROCEND fdp$get_screen_input;

?? TITLE := 'fdp$open_form', EJECT ??
*copyc fdh$open_form

  PROCEDURE [XDCL] fdp$open_form
    (    form_name: ost$name;
     VAR form_identifier: fdt$form_identifier;
     VAR status: ost$status);

    VAR
      dynamic_form: boolean,
      name_is_valid: boolean,
      p_form_definition: ^fdt$form_definition,
      p_form_module: ^fdt$form_module,
      p_form_status: ^fdt$form_status,
      screen_change: fdt$screen_change,
      screen_formatting_version: integer,
      valid_name: ost$name,
      variable_status: fdt$variable_status;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$open_form;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$open_form;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE ??
?? NEWTITLE := 'free_form_storge', EJECT ??

    PROCEDURE free_form_storage;

      IF p_form_status^.p_form_event_statuses <> NIL THEN
        FREE p_form_status^.p_form_event_statuses;
      IFEND;

      IF p_form_status^.p_screen_record <> NIL THEN
        FREE p_form_status^.p_screen_record;
      IFEND;

      IF p_form_status^.p_program_record <> NIL THEN
        FREE p_form_status^.p_program_record;
      IFEND;

      IF p_form_status^.p_form_object_statuses <> NIL THEN
        FREE p_form_status^.p_form_object_statuses;
      IFEND;

      IF p_form_status^.p_form_table_statuses <> NIL THEN
        FREE p_form_status^.p_form_table_statuses;
      IFEND;
    PROCEND free_form_storage;

?? OLDTITLE ??
?? NEWTITLE := 'allocate_form_storage', EJECT ??

    PROCEDURE allocate_form_storage;

      VAR
        object_index: fdt$object_index,
        p_form_definition: ^fdt$form_definition,
        p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status;


      status.normal := TRUE;
      free_form_storage;
      p_form_definition := p_form_status^.p_form_definition;
      IF p_form_definition^.screen_record_length <> 0 THEN

{ Allocate space for screen variable text. This is text the terminal user types in as
{ characters.

        ALLOCATE p_form_status^.p_screen_record: [1 .. p_form_definition^.screen_record_length];
        IF p_form_status^.p_screen_record = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
          RETURN;
        IFEND;

{ Allocate space for holding the record transfers to and from the
{ program. This record holds the data in program data types of real, integer, and character.

        ALLOCATE p_form_status^.p_program_record: [1 .. p_form_definition^.program_record_length];
        IF p_form_status^.p_program_record = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
          RETURN;
        IFEND;
      IFEND;

{ Allocate array for object status.
{ Object status holds the current display attributes and first displayed character for an object.
{ This information is used for scrolling and paging.

      IF p_form_definition^.form_object_definitions.active_number > 0 THEN
        ALLOCATE p_form_status^.p_form_object_statuses: [1 .. p_form_definition^.form_object_definitions.
              total_number];
        IF p_form_status^.p_form_object_statuses = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
          RETURN;
        IFEND;

        p_form_status^.active_form_object_statuses := p_form_definition^.form_object_definitions.total_number;
        p_form_status^.total_form_object_statuses := p_form_status^.active_form_object_statuses;
        p_form_object_statuses := p_form_status^.p_form_object_statuses;
        FOR object_index := 1 TO UPPERBOUND (p_form_object_statuses^) DO
          p_form_object_statuses^ [object_index].key := fdc$unused_identifier;
        FOREND;
      IFEND;

      IF p_form_definition^.form_table_definitions.active_number > 0 THEN

{ Allocate space to hold the current status for tables.
{ This records the first displayed occurrence of a table.
{ This information is used for scrolling and paging.

        ALLOCATE p_form_status^.p_form_table_statuses: [1 .. p_form_definition^.form_table_definitions.
              active_number];
        IF p_form_status^.p_form_table_statuses = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
          RETURN;
        IFEND;
      IFEND;

      IF p_form_definition^.event_definitions.active_number > 0 THEN

{ Allocate space to hold the currently assigned mapping of terminal function keys
{ to form events.

        ALLOCATE p_form_status^.p_form_event_statuses: [1 .. p_form_definition^.event_definitions.
              active_number];
        IF p_form_status^.p_form_event_statuses = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
          RETURN;
        IFEND;
      IFEND;
      p_form_status^.storage_allocated := TRUE;
    PROCEND allocate_form_storage;

?? OLDTITLE ??
?? NEWTITLE := 'initialize_form', EJECT ??

    PROCEDURE initialize_form;

    VAR
      local_status: ost$status;

      p_form_status^.form_x_position := p_form_definition^.x_position;
      p_form_status^.form_y_position := p_form_definition^.y_position;

      allocate_form_storage;
      IF NOT status.normal THEN
        free_form_storage;
        p_form_status^.entry_used := FALSE;
        RETURN;
      IFEND;

      IF p_form_definition^.screen_formatting_version >= fdc$im_smart_capability THEN
        p_form_status^.invalid_data_character := p_form_definition^.invalid_data_character;
      ELSE
        p_form_status^.invalid_data_character.defined := FALSE;
      IFEND;

{ Move initial values of variables to screen and program record for form.

      fdp$initialize_form_record (form_identifier, p_form_status, FALSE, variable_status, status);
      IF NOT status.normal THEN
        free_form_storage;
        p_form_status^.entry_used := FALSE;
        RETURN;
      IFEND;

{ Set initial display attributes for form objects.

      fdp$initialize_form_objects (form_identifier, p_form_status, FALSE, local_status);

{ Assign terminal function keys to program events.

      fdp$create_form_events (form_identifier, p_form_definition^.display_attribute, status);
      p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
      IF NOT status.normal THEN
        free_form_storage;
        p_form_status^.entry_used := FALSE;
        RETURN;
      IFEND;

      screen_change.key := fdc$open_form;
      screen_change.open_form_identifier := form_identifier;
      fdp$record_screen_change (screen_change, status);
      IF NOT status.normal THEN
        free_form_storage;
        p_form_status^.entry_used := FALSE;
        RETURN;
      IFEND;
      p_form_status^.opened := TRUE;
    PROCEND initialize_form;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    IF fdv$screen_status.p_forms_status <> NIL THEN

{ If user specifies a null form name, then the form identifier specifies the form to open.

      IF form_name = osc$null_name THEN
        IF ((form_identifier > 0) AND (form_identifier <= UPPERBOUND (fdv$screen_status.p_forms_status^)))
              THEN
          p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
          IF (p_form_status^.entry_used AND p_form_status^.defined_dynamically AND
                NOT p_form_status^.owned_by_system) THEN
            p_form_definition := p_form_status^.p_form_definition;
            IF p_form_definition^.form_ended THEN
              IF NOT p_form_status^.opened THEN
                initialize_form;
                RETURN;
              ELSE
                osp$set_status_abnormal (fdc$format_display_identifier, fde$form_already_open, form_name,
                      status);
                RETURN;
              IFEND;
            ELSE
              osp$set_status_abnormal (fdc$format_display_identifier, fde$form_not_ended, form_name, status);
              RETURN;
            IFEND;
          ELSE
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_form_identifier, '', status);
            osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (form_identifier), 10, FALSE,
                  status);
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_form_identifier, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (form_identifier), 10, FALSE,
                status);
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    clp$validate_name (form_name, valid_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_form_name, form_name, status);
      RETURN;
    IFEND;

{ Search dynamically created forms for form name.
{ These forms are in memory, not in a library.

    IF fdv$screen_status.p_forms_status <> NIL THEN

    /find_dynamic_form/
      FOR form_identifier := LOWERBOUND (fdv$screen_status.p_forms_status^)
            TO UPPERBOUND (fdv$screen_status.p_forms_status^) DO
        p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
        IF (p_form_status^.entry_used AND p_form_status^.defined_dynamically AND
              NOT p_form_status^.owned_by_system) THEN
          p_form_definition := p_form_status^.p_form_definition;
          IF p_form_definition^.form_ended THEN
            IF valid_name = p_form_definition^.form_name THEN
              IF NOT p_form_status^.opened THEN
                initialize_form;
                RETURN;
              ELSE
                osp$set_status_abnormal (fdc$format_display_identifier, fde$form_already_open, form_name,
                      status);
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND /find_dynamic_form/;
    IFEND;

{ Search forms in command list for form name.

    clp$find_form (valid_name, p_form_module, status);
    IF ((NOT status.normal) OR (p_form_module = NIL)) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_form_name, form_name, status);
      RETURN;
    IFEND;

    RESET p_form_module;
    i#move (^p_form_module^, ^screen_formatting_version, fdc$integer_length);
    IF (screen_formatting_version < fdc$basic_capability) THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$form_requires_conversion, form_name,
            status);
      RETURN;
    IFEND;

    fdp$create_form_status (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Create pointers to often used arrays to make access efficient during
{ form interaction with the terminal user.

    p_form_status^.p_form_module := p_form_module;
    NEXT p_form_definition IN p_form_module;
    p_form_status^.p_form_definition := p_form_definition;
    p_form_status^.p_form_variable_definitions := fdp$ptr_variables (p_form_status);
    p_form_status^.p_form_object_definitions := fdp$ptr_objects (p_form_status);
    p_form_status^.p_form_table_definitions := fdp$ptr_tables (p_form_status);
    p_form_status^.p_form_record_definitions := fdp$ptr_record_definitions (p_form_status);
    p_form_status^.p_event_definitions := fdp$ptr_events (p_form_status);
    p_form_status^.p_display_definitions := fdp$ptr_displays (p_form_status);
    initialize_form;
  PROCEND fdp$open_form;


?? TITLE := 'fdp$read_forms', EJECT ??
*copyc fdh$read_forms

  PROCEDURE [XDCL] fdp$read_forms
    (VAR status: ost$status);

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$read_forms;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$read_forms;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
?? NEWTITLE := 'process_active_forms', EJECT ??

{ PURPOSE:
{   This procedure performs the pre-processing that is required for each active form.
{
{ NOTES:
{   At least one event must be active for terminal user input.

    PROCEDURE [INLINE] process_active_forms;

      VAR
        current_form_identifier: fdt$current_form_identifier,
        event_found: boolean,
        event_index: fdt$event_index,
        p_form_status: ^fdt$form_status,
        p_form_event_statuses: ^array [1 .. * ] of fdt$form_event_status,
        reset_read_forms_index: boolean;


      event_found := FALSE;
      IF fdv$screen_status.read_forms_index < fdc$maximum_read_forms_index THEN
        fdv$screen_status.read_forms_index := fdv$screen_status.read_forms_index + 1;
        reset_read_forms_index := FALSE;
      ELSE
        fdv$screen_status.read_forms_index := 1;
        reset_read_forms_index := TRUE;
      IFEND;

      IF fdv$screen_status.current_form_identifier <> 0 THEN
        current_form_identifier := fdv$screen_status.current_form_identifier;

        REPEAT
          p_form_status := ^fdv$screen_status.p_forms_status^ [current_form_identifier];
          IF p_form_status^.push_count = 0 THEN
            p_form_status^.changed_variable_search.status := fdc$not_searched;
            p_form_status^.input_error_search.status := fdc$not_searched;
            p_form_status^.output_error_search.status := fdc$search_not_allowed;
            IF p_form_status^.events_active THEN
              p_form_event_statuses := p_form_status^.p_form_event_statuses;
              IF (NOT event_found) AND (p_form_event_statuses <> NIL) THEN

              /find_event/
                FOR event_index := LOWERBOUND (p_form_event_statuses^)
                      TO UPPERBOUND (p_form_event_statuses^) DO
                  IF p_form_event_statuses^ [event_index].event_exists THEN
                    event_found := TRUE;
                    EXIT /find_event/;
                  IFEND;
                FOREND /find_event/;
              IFEND;
            IFEND;
          IFEND;
          IF reset_read_forms_index THEN
            reset_read_forms_indices (current_form_identifier);
          IFEND;
          current_form_identifier := p_form_status^.next_lower_form;
        UNTIL current_form_identifier = 0;

      IFEND;

      IF NOT event_found THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_events_active, '', status);
      IFEND;

    PROCEND process_active_forms;
?? OLDTITLE ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    IF fdv$screen_status.p_forms_status = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_forms_to_read, '', status);
      RETURN;
    IFEND;

{ Send all screen changes to the Screen Manager.

    fdp$change_screen (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF fdv$screen_status.number_active_forms = 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_forms_to_read, '', status);
      RETURN;
    IFEND;

{ Do pre-processing for all active forms.

    process_active_forms;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$set_screen_cursor (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Process the data entry of the terminal user.

    fdp$get_screen_input (fdv$screen_status.event_name, fdv$screen_status.event_normal,
          fdv$screen_status.event_position, status);

  PROCEND fdp$read_forms;

?? TITLE := 'fdp$set_line_mode', EJECT ??
*copy fdh$set_line_mode

  PROCEDURE [XDCL] fdp$set_line_mode
    (VAR status: ost$status);

    VAR
      form_identifier: fdt$form_identifier,
      local_status: ost$status,
      p_form_status: ^fdt$form_status;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$set_line_mode;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$set_line_mode;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
?? NEWTITLE := 'initialize_screen_status', EJECT ??

  PROCEDURE initialize_screen_status
    (VAR status: ost$status);

    IF fdv$screen_status.p_screen_changes <> NIL THEN
      FREE fdv$screen_status.p_screen_changes;
    IFEND;

    IF fdv$screen_status.p_screen_event_statuses <> NIL THEN
      FREE fdv$screen_status.p_screen_event_statuses;
    IFEND;

   fdv$screen_status.compute_new_screen_size := TRUE;
   fdv$screen_status.current_form_identifier := 0;
   fdv$screen_status.current_push_count := 0;
   fdv$screen_status.current_screen_height := 1;
   fdv$screen_status.current_screen_width := 1;
   fdv$screen_status.cursor_set := FALSE;
   fdv$screen_status.error_attribute_displayed := FALSE;
   fdv$screen_status.last_cursor_position_valid := FALSE;
   fdv$screen_status.message_form_displayed := FALSE;
   fdv$screen_status.number_active_forms := 0;
   fdv$screen_status.number_screen_changes := 0;
   fdv$screen_status.read_forms_index := 1;
   fdv$screen_status.screen_mode_active := FALSE;

   csv$vector.change_capability_level^ (csc$line_level, status);
   status.normal := TRUE;
  PROCEND initialize_screen_status;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    IF fdv$screen_status.p_forms_status = NIL THEN
      initialize_screen_status (status);
      RETURN;
    IFEND;

{ Deallocate resources held by all forms.

    /free_form_resources/
    FOR form_identifier := LOWERBOUND (fdv$screen_status.p_forms_status^)
        TO UPPERBOUND (fdv$screen_status.p_forms_status^) DO
      p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
      IF NOT (p_form_status^.entry_used AND p_form_status^.opened) THEN
        CYCLE /free_form_resources/;
      IFEND;

      IF p_form_status^.p_form_object_statuses <> NIL THEN
        FREE p_form_status^.p_form_object_statuses;
      IFEND;

      IF p_form_status^.defined_dynamically THEN
        mmp$delete_scratch_segment (p_form_status^.segment_pointer, local_status);
      IFEND;

      IF p_form_status^.p_program_record <> NIL THEN
        FREE p_form_status^.p_program_record;
      IFEND;

      IF p_form_status^.p_screen_record <> NIL THEN
        FREE p_form_status^.p_screen_record;
      IFEND;

      IF p_form_status^.p_form_table_statuses <> NIL THEN
        FREE p_form_status^.p_form_table_statuses;
      IFEND;

      IF p_form_status^.p_form_event_statuses <> NIL THEN
        FREE p_form_status^.p_form_event_statuses;
      IFEND;

      IF p_form_status^.p_form_image <> NIL THEN
        FREE p_form_status^.p_form_image;
      IFEND;

    FOREND /free_form_resources/;

    FREE fdv$screen_status.p_forms_status;
    initialize_screen_status (status);
  PROCEND fdp$set_line_mode;
?? TITLE := 'fdp$set_screen_cursor', EJECT ??
*copyc fdh$set_screen_cursor

  PROCEDURE [XDCL] fdp$set_screen_cursor
    (VAR status: ost$status);

    VAR
      character_position: cst$character_position,
      current_form_identifier: fdt$current_form_identifier,
      field_number: cst$field_number,
      line_number: cst$line_number,
      p_form_definition: ^fdt$form_definition,
      p_form_status: ^fdt$form_status,
      terminal_status: ost$status;

    status.normal := TRUE;
    IF fdv$screen_status.cursor_set THEN

{ The application program set the cursor position. Do nothing else.

      fdv$screen_status.cursor_set := FALSE;

    ELSEIF fdv$screen_status.last_cursor_position_valid THEN
      p_form_status := ^fdv$screen_status.p_forms_status^ [fdv$screen_status.last_cursor_form_identifier];
      IF p_form_status^.design_form THEN

{ Position the cursor on the last event position for a design form.

        csv$vector.position_cursor^ (p_form_status^.field_number, p_form_status^
             .last_cursor_form_x_position, p_form_status^.last_cursor_form_y_position,
             character_position, line_number, terminal_status);

      ELSE

{ The form is not a design form.
{ Position cursor on first input variable if one exists.

        p_form_definition := p_form_status^.p_form_definition;
        IF p_form_definition^.first_input_object_defined THEN
          field_number := p_form_status^.p_form_object_statuses^
                [p_form_definition^.first_input_object_index].field_number;
          csv$vector.position_cursor^ (field_number, 1, 1, character_position, line_number,
                terminal_status);
        ELSE

{ If no input or input/output variable exists position the cursor on the upper
{ left corner of the form.

          csv$vector.position_cursor^ (p_form_status^.field_number, 1, 1, character_position,
                line_number, terminal_status);
        IFEND;
      IFEND;

{ Forms have been added or deleted.  Place the cursor on the highest priority
{ form.

    ELSEIF fdv$screen_status.current_form_identifier <> 0 THEN
      current_form_identifier := fdv$screen_status.current_form_identifier;

    /find_cursor/
      BEGIN
        REPEAT
          p_form_status := ^fdv$screen_status.p_forms_status^ [current_form_identifier];
          IF p_form_status^.events_active THEN
            IF p_form_status^.added OR p_form_status^.combined THEN
              IF p_form_status^.design_form AND
                    p_form_status^.last_cursor_position_valid THEN
                csv$vector.position_cursor^ (p_form_status^.field_number, p_form_status^
                      .last_cursor_form_x_position, p_form_status^.last_cursor_form_y_position,
                      character_position, line_number, terminal_status);
                EXIT /find_cursor/;
              IFEND;

              p_form_definition := p_form_status^.p_form_definition;
              IF p_form_definition^.first_input_object_defined THEN
                field_number := p_form_status^.p_form_object_statuses^
                      [p_form_definition^.first_input_object_index].field_number;
                csv$vector.position_cursor^ (field_number, 1, 1, character_position, line_number,
                      terminal_status);
                EXIT /find_cursor/;
              IFEND;

              IF p_form_status^.p_event_definitions <> NIL THEN
                csv$vector.position_cursor^ (p_form_status^.field_number, 1, 1, character_position,
                      line_number, terminal_status);
                EXIT /find_cursor/;
              IFEND;
            IFEND;
          IFEND;
          current_form_identifier := p_form_status^.next_lower_form;
        UNTIL current_form_identifier = 0;
      END /find_cursor/;
    IFEND;

  PROCEND fdp$set_screen_cursor;

?? TITLE := 'fdp$show_forms', EJECT ??
*copyc fdh$show_forms

  PROCEDURE [XDCL] fdp$show_forms
    (VAR status: ost$status);

    VAR
      terminal_status: ost$status;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$show_forms;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$show_forms;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;

    IF fdv$screen_status.p_forms_status = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_forms_to_show, '', status);
      RETURN;
    IFEND;

{ Send terminal screen changes to Screen Manager.

    fdp$change_screen (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF fdv$screen_status.number_active_forms = 0 THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$no_forms_to_show, '', status);
      RETURN;
    IFEND;

{ Display all changes to the screen.  No input is expected from the
{ terminal user.

    fdp$set_screen_cursor (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fdp$update_screen (status);

  PROCEND fdp$show_forms;

?? TITLE := 'fdp$tab_to_next_field', EJECT ??
*copyc fdh$tab_to_next_field

  PROCEDURE [XDCL] fdp$tab_to_next_field
    (VAR status: ost$status);

    VAR
      form_status: fdt$form_status,
      object_index: fdt$object_index,
      p_form_status: ^fdt$form_status;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$tab_to_next_field;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$tab_to_next_field;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    IF (fdv$screen_status.p_forms_status = NIL) OR (fdv$screen_status.number_active_forms = 0) THEN
      osp$set_status_condition (fde$no_forms_are_scheduled, status);
      RETURN;
    IFEND;

    fdp$find_form_status (fdv$screen_status.event_position.form_identifier, p_form_status, status);
    IF NOT status.normal THEN

{ The form that the last event was entered from is now closed.  Leave cursor alone.  This is not an error
{ condition.

      RETURN;
    IFEND;

    IF (NOT (p_form_status^.added OR p_form_status^.combined)) OR (NOT p_form_status^.displayed_on_screen) OR
            (p_form_status^.p_form_definition^.form_object_definitions.active_number < 1) THEN

{ Either the form that the last event was entered from is no longer on the screen or it has no objects.
{ Leave cursor alone.  This is not an error condition.

      RETURN;
    IFEND;

    fdp$find_next_object (fdv$screen_status.event_position.form_x_position,
         fdv$screen_status.event_position.form_y_position, p_form_status, object_index);

    fdp$tab_to_next_variable (p_form_status, object_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND fdp$tab_to_next_field;

?? TITLE := 'fdp$tab_to_next_variable', EJECT ??
*copyc fdh$tab_to_next_variable

  PROCEDURE [XDCL] fdp$tab_to_next_variable
    (    p_form_status: ^fdt$form_status;
         object_index: fdt$object_index;
     VAR status: ost$status);

    VAR
      end_object_index: fdt$object_index,
      ignore_character_position: cst$character_position,
      ignore_line_number: cst$line_number,
      next_object_index: fdt$object_index,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_variable_definitions: ^array [1 .. * ] of fdt$form_variable_definition,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_parent_object_definition: ^fdt$form_object_definition,
      start_object_index: fdt$object_index,
      terminal_status: ost$status;

?? NEWTITLE := 'check_variable', EJECT ??

{ PURPOSE:
{   This procedure verifies that the variable field is a valid input field and positions the cursor to it.
{ NOTES:
{   The field must be an input field and it must not be covered by another form.
{

    PROCEDURE [INLINE] check_variable;

      IF ((p_form_variable_definition^.io_mode = fdc$terminal_input) OR
            (p_form_variable_definition^.io_mode = fdc$terminal_input_output)) AND
            (NOT (fdc$protect IN
            p_form_status^.p_form_object_statuses^ [next_object_index].display_attribute_set)) AND
            (NOT location_covered_by_form (p_form_status, p_form_object_definition^.x_position +
            p_form_status^.form_x_position - 1, p_form_object_definition^.y_position +
            p_form_status^.form_y_position - 1)) THEN
        csv$vector.position_cursor^ (p_form_status^.p_form_object_statuses^ [next_object_index].field_number,
              1, 1, ignore_character_position, ignore_line_number, terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
        IFEND;
        fdv$screen_status.cursor_set := TRUE;
        EXIT fdp$tab_to_next_variable;
      IFEND;

    PROCEND check_variable;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'search_object_definitions', EJECT ??

{ PURPOSE:
{   This procedure finds the next input variable in the form.
{ DESIGN:
{   The procedure searches the object definitions which are ordered by location.
{ NOTES:
{   Tabbing can only occur to a variable that has an input or input/output mode.

    PROCEDURE [INLINE] search_object_definitions;

      FOR next_object_index := start_object_index TO end_object_index DO
        p_form_object_definition := ^p_form_object_definitions^ [next_object_index];
        CASE p_form_object_definition^.key OF

        = fdc$form_variable_text =
          p_form_variable_definition := ^p_form_variable_definitions^
                [p_form_object_definition^.text_variable_index];
          check_variable;

{ If the variable checks out, a non-local EXIT is performed and control does not return here.

        = fdc$form_variable_text_box =
          p_form_variable_definition := ^p_form_variable_definitions^
                [p_form_object_definition^.variable_box_variable_index];
          check_variable;

{ If the variable checks out, a non-local EXIT is performed and control does not return here.

        = fdc$form_text_box_fragment =
          p_parent_object_definition := ^p_form_object_definitions^
                [p_form_object_definition^.parent_text_box_object_index];
          IF (p_parent_object_definition^.key = fdc$form_variable_text_box) THEN
            p_form_variable_definition := ^p_form_variable_definitions^
                  [p_parent_object_definition^.variable_box_variable_index];
            check_variable;

{ If the variable checks out, a non-local EXIT is performed and control does not return here.

          IFEND;
        ELSE

{ Other objects are ignored.

        CASEND;
      FOREND;

    PROCEND search_object_definitions;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    p_form_variable_definitions := p_form_status^.p_form_variable_definitions;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;

    end_object_index := p_form_status^.p_form_definition^.form_object_definitions.active_number;
    IF object_index <= end_object_index THEN
      start_object_index := object_index;
      search_object_definitions;

{ If the next variable is found, a non-local EXIT is performed and control does not return here.

      end_object_index := start_object_index;
    IFEND;

{ Wrap around to beginning of form and then try to find an input field.

    start_object_index := 1;
    search_object_definitions;

{ No input variable was found in the form.  The cursor position is not changed and no error is generated.

  PROCEND fdp$tab_to_next_variable;

?? TITLE := 'fdp$update_screen', EJECT ??
*copyc fdh$update_screen

  PROCEDURE [XDCL] fdp$update_screen
    (VAR status: ost$status);

    VAR
      terminal_status: ost$status;

    status.normal := TRUE;
    csv$vector.update_device^ (terminal_status);
    IF NOT status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
    IFEND;

  PROCEND fdp$update_screen;

?? TITLE := 'add_screen_constant_text_box', EJECT ??

  PROCEDURE add_screen_constant_text_box
    (    x_position: fdt$x_position;
         y_position: fdt$y_position;
         object_index: fdt$object_index;
         p_form_status: ^fdt$form_status;
     VAR status: ost$status);

    VAR
      boundary_processing: cst$boundary_processing,
      current_y_position: fdt$y_position,
      data_characters: cst$character_position,
      display_attribute_set: fdt$display_attribute_set,
      field_number: cst$field_number,
      fragment_object_index: fdt$object_index,
      next_object_index: fdt$object_index,
      p_text: ^fdt$text,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      screen_visible_length: fdt$screen_variable_length,
      target_position: fdt$target_position,
      terminal_status: ost$status,
      visible_characters: cst$visible_character_position;

    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    p_form_object_definition := ^p_form_object_definitions^ [object_index];
    boundary_processing.boundary_type := csc$clip;

{ Create first line of text box.

    visible_characters := p_form_object_definition^.constant_box_width;

{ If form uses hidden editing create Screen Manager field with twice the width of the
{ object.  Otherwise, create a field with the width of the object.

    IF p_form_status^.p_form_definition^.hidden_editing THEN
      data_characters := p_form_object_definition^.constant_box_width *
            fdc$hidden_editing_multiplier;
      IF (data_characters > csc$max_string) THEN
        data_characters := csc$max_string;
      IFEND;
    ELSE
      data_characters := p_form_object_definition^.constant_box_width;
    IFEND;
    csv$vector.create_field^ (x_position, y_position, visible_characters, 1, data_characters,
          1, FALSE, TRUE, csc$no_justification, boundary_processing, field_number,
          terminal_status);
    IF NOT terminal_status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
      RETURN;
    IFEND;

    display_attribute_set := p_form_object_definition^.display_attribute;
    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    p_form_object_statuses^ [object_index].display_attribute_set := display_attribute_set;
    p_form_object_statuses^ [object_index].key := fdc$field_identifier;
    p_form_object_statuses^ [object_index].field_number := field_number;
    p_form_object_statuses^ [object_index].character_position := 1;
    p_form_object_statuses^ [object_index].data_length := data_characters;
    put_text_attribute (field_number, display_attribute_set, fdc$terminal_output, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Create second, third, and so on lines of text box.  These lines are called fragments.
{ Objects for these lines are linked to the first line.
{ The first line is called the parent.

    fragment_object_index := p_form_object_definition^.constant_box_fragment_index;
    current_y_position := y_position;
    WHILE fragment_object_index <> 0 DO
      current_y_position := current_y_position + 1;
      csv$vector.create_field^ (x_position, current_y_position, visible_characters, 1, data_characters,
            1, FALSE, TRUE, csc$no_justification, boundary_processing, field_number, terminal_status);
      IF NOT terminal_status.normal THEN
        fdp$convert_terminal_status (terminal_status, status);
        RETURN;
      IFEND;

      p_form_object_statuses^ [fragment_object_index].display_attribute_set := display_attribute_set;
      p_form_object_statuses^ [fragment_object_index].key := fdc$field_identifier;
      p_form_object_statuses^ [fragment_object_index].field_number := field_number;
      p_form_object_statuses^ [fragment_object_index].character_position := 1;
      put_text_attribute (field_number, display_attribute_set, fdc$terminal_output, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fragment_object_index := p_form_object_definitions^ [fragment_object_index].next_fragment_object_index;
      WHILEND;

    next_object_index := p_form_object_definition^.constant_box_fragment_index;
    p_text := fdp$ptr_text (p_form_object_definition^.constant_box_text, p_form_status^.p_form_module);
    target_position.key := fdc$page_data_first;
    format_screen_text (p_text, p_form_status, object_index, next_object_index,
          p_form_object_definition^.constant_box_processing, p_form_object_definition^.constant_box_width,
          p_form_object_definition^.constant_box_height, target_position, status);
  PROCEND add_screen_constant_text_box;

?? TITLE := 'add_screen_object', EJECT ??

  PROCEDURE add_screen_object
    (    p_form_status: ^fdt$form_status;
         object_definition: fdt$form_object_definition;
         object_index: fdt$object_index;
     VAR status: ost$status);

    VAR
      boundary_processing: cst$boundary_processing,
      character_index: cst$character_position,
      data_characters: cst$character_position,
      field_number: cst$field_number,
      graphic_identifier: cst$graphic_identifier,
      p_form_definition: ^fdt$form_definition,
      p_form_module: ^fdt$form_module,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_text: ^fdt$text,
      target_position: fdt$target_position,
      terminal_status: ost$status,
      visible_characters: cst$visible_character_position,
      x_position: cst$x_position,
      y_position: cst$y_position;

    status.normal := TRUE;
    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    p_form_module := p_form_status^.p_form_module;
    p_form_definition := p_form_status^.p_form_definition;
    p_form_object_definition := ^p_form_status^.p_form_object_definitions^ [object_index];
    x_position := object_definition.x_position + p_form_status^.form_x_position - 1;
    y_position := object_definition.y_position + p_form_status^.form_y_position - 1;
    CASE object_definition.key OF

    = fdc$form_box =
      create_screen_box (x_position, y_position, object_definition.box_width, object_definition.box_height,
            p_form_object_definition^.display_attribute, graphic_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      p_form_object_statuses^ [object_index].key := fdc$graphic_identifier;
      p_form_object_statuses^ [object_index].graphic_identifier := graphic_identifier;
      p_form_object_statuses^ [object_index].display_attribute_set := object_definition.display_attribute;

    = fdc$form_line =
      create_screen_line (x_position, y_position, object_definition.x_increment,
            object_definition.y_increment, p_form_object_definition^.display_attribute, graphic_identifier,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      p_form_object_statuses^ [object_index].key := fdc$graphic_identifier;
      p_form_object_statuses^ [object_index].graphic_identifier := graphic_identifier;
      p_form_object_statuses^ [object_index].display_attribute_set := object_definition.display_attribute;

    = fdc$form_constant_text_box =
      p_form_object_definition := ^p_form_object_definitions^ [object_index];
      add_screen_constant_text_box (x_position, y_position, object_index, p_form_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    = fdc$form_constant_text =
      p_text := fdp$ptr_text (object_definition.constant_text, p_form_module);
      visible_characters := object_definition.constant_text_width;
      IF p_form_status^.p_form_definition^.hidden_editing THEN
          data_characters := STRLENGTH (p_text^);
        ELSE
          data_characters := visible_characters;
      IFEND;

      boundary_processing.boundary_type := csc$clip;
      csv$vector.create_field^ (x_position, y_position, visible_characters, 1, data_characters, 1,
            FALSE, TRUE, csc$no_justification, boundary_processing, field_number, terminal_status);
      IF NOT terminal_status.normal THEN
        fdp$convert_terminal_status (terminal_status, status);
        RETURN;
      IFEND;

      p_form_object_statuses^ [object_index].key := fdc$field_identifier;
      p_form_object_statuses^ [object_index].field_number := field_number;
      p_form_object_statuses^ [object_index].character_position := 1;
      p_form_object_statuses^ [object_index].data_length := data_characters;
      target_position.key := fdc$current_data_position;
      replace_screen_variable (p_text, object_index, object_index, visible_characters,
            p_form_status, target_position, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      p_form_object_statuses^ [object_index].display_attribute_set := object_definition.display_attribute;
      put_text_attribute (field_number, object_definition.display_attribute, fdc$terminal_output, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    = fdc$form_stored_variable =

{ Do nothing.  A stored variable has no screen representation.

    ELSE { fdc$form_text_box_fragment }

{ Do nothing now.  This object is created when the associated constant or variable text box
{ is processed.

    CASEND;
  PROCEND add_screen_object;

?? TITLE := 'compute_cursor_shift', EJECT ??

  PROCEDURE [INLINE] compute_cursor_shift
    (    width: fdt$width;
         first_character_position: fdt$character_position;
         cursor_character_position: fdt$character_position;
     VAR shift: integer);

    VAR
      last_character_position: integer;

    last_character_position := first_character_position + width - 1;

{ Determine shift to make character position visibile.

    IF cursor_character_position < first_character_position THEN

{ Scroll text backward.

        shift := cursor_character_position - first_character_position;

    ELSEIF cursor_character_position > last_character_position THEN

{ Scroll text forward.

      shift := cursor_character_position - first_character_position;

    ELSE

{ The text cursor character is visible.  No shift is necessary.

      shift := 0;
    IFEND;
  PROCEND compute_cursor_shift;


?? TITLE := 'compute_forward_scroll', EJECT ??

?? TITLE := 'create_screen_box', EJECT ??

  PROCEDURE create_screen_box
    (    x_position: cst$x_position;
         y_position: cst$y_position;
         box_width: fdt$width;
         box_height: fdt$height;
         display_attribute_set: fdt$display_attribute_set;
     VAR graphic_identifier: cst$graphic_identifier;
     VAR status: ost$status);

    VAR
      box_coordinates: array [1 .. 5] of cst$xy_coordinate,
      intersection_types: array [1 .. 4] of cst$intersection_type,
      terminal_status: ost$status,
      xy_coordinates: array [1 .. 4] of cst$xy_coordinate;

    status.normal := TRUE;

    { Create vertical and horizontal lines for box.

    box_coordinates [1].x := x_position;
    box_coordinates [1].y := y_position;
    box_coordinates [2].x := box_width + x_position - 1;
    box_coordinates [2].y := y_position;
    box_coordinates [3].x := box_coordinates [2].x;
    box_coordinates [3].y := y_position + box_height - 1;
    box_coordinates [4].x := x_position;
    box_coordinates [4].y := box_coordinates [3].y;
    box_coordinates [5].x := x_position;
    box_coordinates [5].y := y_position;

    csv$vector.poly_hv_line^ (box_coordinates, graphic_identifier, terminal_status);
    IF NOT terminal_status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
      RETURN;
    IFEND;

    put_graphic_attribute (graphic_identifier, display_attribute_set, status);
    IF NOT status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
      RETURN;
    IFEND;

{ Create intersections for vertical and horizontal lines of box.

    intersection_types [1] := csc$upper_left;
    intersection_types [2] := csc$upper_right;
    intersection_types [3] := csc$lower_right;
    intersection_types [4] := csc$lower_left;
    xy_coordinates [1].x := x_position;
    xy_coordinates [1].y := y_position;
    xy_coordinates [2].y := y_position;
    xy_coordinates [2].x := x_position + box_width - 1;
    xy_coordinates [3].y := y_position + box_height - 1;
    xy_coordinates [3].x := x_position + box_width - 1;
    xy_coordinates [4].y := y_position + box_height - 1;
    xy_coordinates [4].x := x_position;
    csv$vector.poly_intersect^ (graphic_identifier, xy_coordinates, intersection_types, terminal_status);
    IF NOT terminal_status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
    IFEND;

  PROCEND create_screen_box;

?? TITLE := 'create_screen_line', EJECT ??

  PROCEDURE create_screen_line
    (    x_position: cst$x_position;
         y_position: cst$x_position;
         x_increment: fdt$x_increment;
         y_increment: fdt$y_increment;
         display_attribute_set: fdt$display_attribute_set;
     VAR graphic_identifier: cst$graphic_identifier;
     VAR status: ost$status);

    VAR
      line_coordinates: array [1 .. 2] of cst$xy_coordinate,
      terminal_status: ost$status;

    status.normal := TRUE;
    line_coordinates [1].x := x_position;
    line_coordinates [1].y := y_position;
    line_coordinates [2].x := x_position + x_increment;
    line_coordinates [2].y := y_position + y_increment;

    csv$vector.poly_hv_line^ (line_coordinates, graphic_identifier, terminal_status);
    IF NOT terminal_status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
      RETURN;
    IFEND;

    put_graphic_attribute (graphic_identifier, display_attribute_set, status);

  PROCEND create_screen_line;

?? TITLE := 'create_screen_objects', EJECT ??

{ PURPOSE:
{   This procedure creates objects required by the form.

  PROCEDURE create_screen_objects
    (    p_form_status: ^fdt$form_status;
     VAR status: ost$status);

    VAR
      boundary_processing: cst$boundary_processing,
      character_index: cst$character_position,
      end_of_text: boolean,
      data_characters: cst$character_position,
      display_attribute_set: fdt$display_attribute_set,
      field_justification: cst$field_justification,
      field_number: cst$field_number,
      first_displayed_occurrence: fdt$occurrence,
      form_x_position: fdt$x_position,
      form_y_position: fdt$y_position,
      fragment_object_index: fdt$object_index,
      graphic_identifier: cst$graphic_identifier,
      input: boolean,
      io_mode: fdt$io_mode,
      next_object_index: fdt$object_index,
      number_objects: fdt$number_objects,
      object_index: fdt$object_index,
      output: boolean,
      p_form_definition: ^fdt$form_definition,
      p_form_module: ^fdt$form_module,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_record_definitions: ^array [1 .. * ] of fdt$variable_record_definition,
      p_form_table_definition: ^fdt$form_table_definition,
      p_form_table_definitions: ^array [1 .. * ] of fdt$form_table_definition,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_variable_definitions: ^array [1 .. * ] of fdt$form_variable_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_screen_variable: ^fdt$text,
      p_table_object: ^fdt$table_object,
      p_table_objects: ^array [1 .. * ] of fdt$table_object,
      p_form_table_statuses: ^array [1 .. * ] of fdt$table_status,
      p_screen_text: ^fdt$text,
      p_table_variable: ^fdt$table_variable,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable,
      p_text: ^fdt$text,
      p_variable_record_definition: ^fdt$variable_record_definition,
      record_index: fdt$variable_index,
      screen_visible_length: fdt$screen_variable_length,
      stored_characters: cst$character_position,
      stored_lines: cst$line_number,
      table_object_index: fdt$object_index,
      target_position: fdt$target_position,
      terminal_status: ost$status,
      variable_index: fdt$variable_index,
      visible_characters: cst$visible_character_position,
      visible_lines: cst$line_number,
      x_position: cst$x_position,
      y_position: cst$y_position;

    status.normal := TRUE;

{ Create field for entire form.  Fields for form objects will overlay this field.
{ This field causes the form to be opaque.  Any screen data lying underneath the
{ form must be covered up.

    p_form_definition := p_form_status^.p_form_definition;
    form_x_position := p_form_status^.form_x_position;
    form_y_position := p_form_status^.form_y_position;

    CASE p_form_definition^.form_area.key OF

    = fdc$defined_area =
      visible_lines := p_form_definition^.height;
      visible_characters := p_form_definition^.width;
      stored_lines := visible_lines;
      stored_characters := visible_characters;

    ELSE { fdc$screen_area }
      visible_lines := fdv$screen_status.current_screen_height;
      visible_characters := fdv$screen_status.current_screen_width;
      stored_lines := visible_lines;
      stored_characters := visible_characters;

    CASEND;

    boundary_processing.boundary_type := csc$clip;
    csv$vector.create_field^ (form_x_position, form_y_position, visible_characters, visible_lines,
          stored_characters, stored_lines, FALSE, TRUE, csc$no_justification, boundary_processing,
          field_number, terminal_status);
    IF NOT terminal_status.normal THEN
      CASE terminal_status.condition OF

      = cse$field_beyond_page_boundary, cse$field_off_screen =
        osp$set_status_abnormal (fdc$format_display_identifier, fde$form_too_large_for_screen,
              p_form_definition^.form_name, status);
        RETURN;
      ELSE
        fdp$convert_terminal_status (terminal_status, status);
        RETURN;
      CASEND;
    IFEND;
    p_form_status^.field_number_defined := TRUE;
    p_form_status^.field_number := field_number;

{ Specify form colors.

    display_attribute_set := p_form_definition^.display_attribute *
          fdv$colors + $fdt$display_attribute_set [fdc$protect];
    put_text_attribute (field_number, display_attribute_set, fdc$terminal_output, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Create form border by drawing a box.

    IF (NOT p_form_status^.design_form AND
           ((fdc$fine_border IN p_form_definition^.display_attribute) OR
           (fdc$medium_border IN p_form_definition^.display_attribute) OR
           (fdc$bold_border IN p_form_definition^.display_attribute))) THEN
      create_screen_box (form_x_position, form_y_position, stored_characters, stored_lines,
            p_form_definition^.display_attribute, graphic_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      p_form_status^.graphic_identifier := graphic_identifier;
      p_form_status^.graphic_identifier_defined := TRUE;
    IFEND;

    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    IF p_form_object_definitions = NIL THEN
      RETURN;
    IFEND;

{ Create objects on screen for form objects.

    p_form_module := p_form_status^.p_form_module;
    number_objects := p_form_status^.p_form_definition^.form_object_definitions.active_number;
    p_form_variable_definitions := p_form_status^.p_form_variable_definitions;
    p_form_object_statuses := p_form_status^.p_form_object_statuses;

    FOR object_index := 1 TO number_objects DO
      p_form_object_definition := ^p_form_object_definitions^ [object_index];
      CASE p_form_object_definition^.key OF

      = fdc$form_box =
        x_position := p_form_object_definition^.x_position + form_x_position - 1;
        y_position := p_form_object_definition^.y_position + form_y_position - 1;
        create_screen_box (x_position, y_position, p_form_object_definition^.box_width,
              p_form_object_definition^.box_height, p_form_object_statuses^ [object_index].
              display_attribute_set, graphic_identifier, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        p_form_object_statuses^ [object_index].key := fdc$graphic_identifier;
        p_form_object_statuses^ [object_index].graphic_identifier := graphic_identifier;

      = fdc$form_constant_text =
        x_position := p_form_object_definition^.x_position + form_x_position - 1;
        y_position := p_form_object_definition^.y_position + form_y_position - 1;
        visible_characters := p_form_object_definition^.constant_text_width;
        p_text := fdp$ptr_text (p_form_object_definition^.constant_text, p_form_module);

        IF p_form_status^.p_form_definition^.hidden_editing THEN
          data_characters := STRLENGTH (p_text^);
        ELSE
          data_characters := visible_characters;
        IFEND;

        boundary_processing.boundary_type := csc$clip;
        csv$vector.create_field^ (x_position, y_position, visible_characters, 1, data_characters, 1,
              FALSE, TRUE, csc$no_justification, boundary_processing, field_number, terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          RETURN;
        IFEND;

        p_form_object_statuses^ [object_index].key := fdc$field_identifier;
        p_form_object_statuses^ [object_index].field_number := field_number;
        csv$vector.change_io_position^ (field_number, 1, terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          RETURN;
        IFEND;

        IF STRLENGTH (p_text^) > visible_characters THEN
          p_screen_text := ^p_text^ (1, visible_characters);
        ELSE
          p_screen_text := p_text;
        IFEND;
        csv$vector.put_text^ (p_screen_text, TRUE, end_of_text, terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          RETURN;
        IFEND;

        put_text_attribute (field_number, p_form_object_statuses^ [object_index].display_attribute_set,
              fdc$terminal_output, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = fdc$form_constant_text_box =
        x_position := p_form_object_definition^.x_position + form_x_position - 1;
        y_position := p_form_object_definition^.y_position + form_y_position - 1;
        add_screen_constant_text_box (x_position, y_position, object_index, p_form_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = fdc$form_line =
        x_position := p_form_object_definition^.x_position + form_x_position - 1;
        y_position := p_form_object_definition^.y_position + form_y_position - 1;
        create_screen_line (x_position, y_position, p_form_object_definition^.x_increment,
              p_form_object_definition^.y_increment, p_form_object_statuses^ [object_index].
              display_attribute_set, graphic_identifier, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        p_form_object_statuses^ [object_index].key := fdc$graphic_identifier;
        p_form_object_statuses^ [object_index].graphic_identifier := graphic_identifier;

      = fdc$form_stored_variable =
        p_form_object_statuses^ [object_index].key := fdc$unused_identifier;

{ Do nothing.  A stored object has no screen representation.

      = fdc$form_table =
        x_position := p_form_object_definition^.x_position + form_x_position - 1;
        y_position := p_form_object_definition^.y_position + form_y_position - 1;
        boundary_processing.boundary_type := csc$clip;
        visible_characters := p_form_object_definition^.table_width;
        visible_lines := p_form_object_definition^.table_height;
        csv$vector.create_field^ (x_position, y_position, visible_characters, visible_lines,
              visible_characters, visible_lines, FALSE, TRUE, csc$no_justification,
              boundary_processing, field_number, terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          RETURN;
        IFEND;

        p_form_object_statuses^ [object_index].key := fdc$field_identifier;
        p_form_object_statuses^ [object_index].field_number := field_number;
        put_text_attribute (field_number, p_form_object_statuses^ [object_index].display_attribute_set,
              fdc$terminal_output, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = fdc$form_text_box_fragment =

{ Do nothing now. These objects are processing when the associated constant or
{ variable text box is processed.

      = fdc$form_variable_text =
        x_position := p_form_object_definition^.x_position + form_x_position - 1;
        y_position := p_form_object_definition^.y_position + form_y_position - 1;
        IF p_form_object_definition^.text_variable_exists THEN
          p_form_variable_definition := ^p_form_variable_definitions^
                [p_form_object_definition^.text_variable_index];

          io_mode := p_form_variable_definition^.io_mode;
          CASE p_form_variable_definition^.io_mode OF

          = fdc$terminal_input =
            input := TRUE;
            output := FALSE;

          = fdc$terminal_input_output =
            input := TRUE;
            output := TRUE;

          ELSE {fdc$terminal_output}
            input := FALSE;
            output := TRUE;
          CASEND;

        ELSE

{ Variable does not exist.

          input := FALSE;
          output := TRUE;
          io_mode := fdc$terminal_output;
        IFEND;

        boundary_processing.boundary_type := csc$clip;
        visible_characters := p_form_object_definition^.text_variable_width;
        IF p_form_definition^.hidden_editing THEN
          data_characters := p_form_variable_definition^.screen_variable_length;
        ELSE
          data_characters := visible_characters;
        IFEND;

        csv$vector.create_field^ (x_position, y_position, visible_characters, 1, data_characters, 1,
              input, output, csc$no_justification, boundary_processing, field_number, terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          RETURN;
        IFEND;

        p_form_object_statuses^ [object_index].key := fdc$field_identifier;
        p_form_object_statuses^ [object_index].field_number := field_number;
        put_text_attribute (field_number, p_form_object_statuses^ [object_index].display_attribute_set,
              io_mode, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = fdc$form_variable_text_box =
        x_position := p_form_object_definition^.x_position + form_x_position - 1;
        y_position := p_form_object_definition^.y_position + form_y_position - 1;
        display_attribute_set := p_form_object_statuses^ [object_index].display_attribute_set;

        IF p_form_object_definition^.variable_box_variable_exists THEN
          p_form_variable_definition := ^p_form_variable_definitions^
                [p_form_object_definition^.variable_box_variable_index];
          io_mode := p_form_variable_definition^.io_mode;
          CASE p_form_variable_definition^.io_mode OF

          = fdc$terminal_input =
            input := TRUE;
            output := FALSE;

          = fdc$terminal_input_output =
            input := TRUE;
            output := TRUE;

          ELSE { fdc$terminal_output }
            input := FALSE;
            output := TRUE;
          CASEND;

        ELSE

{ The variable has not been defined. Make the variable a constant.

          input := FALSE;
          output := TRUE;
          io_mode := fdc$terminal_output;
        IFEND;

        boundary_processing.boundary_type := csc$clip;
        visible_characters := p_form_object_definition^.variable_box_width;
        IF p_form_status^.p_form_definition^.hidden_editing THEN
          data_characters := fdc$hidden_editing_multiplier * visible_characters;
        ELSE
          data_characters := visible_characters;
        IFEND;
        csv$vector.create_field^ (x_position, y_position, visible_characters, 1, data_characters,
              1, input, output, csc$no_justification, boundary_processing, field_number,
              terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          RETURN;
        IFEND;

        p_form_object_statuses^ [object_index].key := fdc$field_identifier;
        p_form_object_statuses^ [object_index].field_number := field_number;
        put_text_attribute (field_number, display_attribute_set, io_mode, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        fragment_object_index := p_form_object_definition^.variable_box_fragment_index;
        WHILE fragment_object_index <> 0 DO
          y_position := y_position + 1;
          csv$vector.create_field^ (x_position, y_position, visible_characters, 1, data_characters,
                1, input, output, csc$no_justification, boundary_processing, field_number, terminal_status);
          IF NOT terminal_status.normal THEN
            fdp$convert_terminal_status (terminal_status, status);
            RETURN;
          IFEND;

          p_form_object_statuses^ [fragment_object_index].key := fdc$field_identifier;
          p_form_object_statuses^ [fragment_object_index].field_number := field_number;
          put_text_attribute (field_number, display_attribute_set, io_mode, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          fragment_object_index := p_form_object_definitions^ [fragment_object_index].
                next_fragment_object_index;
        WHILEND;

      ELSE { fdc$form_unused_object }
      CASEND;
    FOREND;

    IF (p_form_status^.design_form AND
           ((fdc$fine_border IN p_form_definition^.display_attribute) OR
           (fdc$medium_border IN p_form_definition^.display_attribute) OR
           (fdc$bold_border IN p_form_definition^.display_attribute))) THEN
      create_screen_box (form_x_position, form_y_position, stored_characters, stored_lines,
            p_form_definition^.display_attribute, graphic_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      p_form_status^.graphic_identifier := graphic_identifier;
      p_form_status^.graphic_identifier_defined := TRUE;
    IFEND;

{ Put data from form record into variable form objects.

    p_form_record_definitions := p_form_status^.p_form_record_definitions;
    IF p_form_record_definitions = NIL THEN
      RETURN;
    IFEND;

    p_form_table_definitions := p_form_status^.p_form_table_definitions;
    p_form_table_statuses := p_form_status^.p_form_table_statuses;
    target_position.key := fdc$page_data_first;

  /create_screen_text/
    FOR record_index := 1 TO UPPERBOUND (p_form_record_definitions^) DO
      p_variable_record_definition := ^p_form_record_definitions^ [record_index];
      CASE p_variable_record_definition^.key OF

      = fdc$record_table =
        p_form_table_definition := ^p_form_table_definitions^ [p_variable_record_definition^.table_index];
        IF NOT p_form_table_definition^.valid THEN
          CYCLE /create_screen_text/;
        IFEND;

        first_displayed_occurrence := p_form_table_statuses^ [p_variable_record_definition^.table_index].
              first_displayed_occurrence;
        p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
              p_form_module);
        IF p_table_variables <> NIL THEN
          FOR variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
            p_table_variable := ^p_table_variables^ [variable_index];
            p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                  [p_table_variable^.variable_index];
            p_table_objects := fdp$ptr_table_objects (p_table_variable^.table_objects, p_form_module);

          /create_table_object_text/
            FOR table_object_index := 1 TO p_form_table_definition^.visible_occurrence DO
              p_table_object := ^p_table_objects^ [table_object_index + first_displayed_occurrence - 1];
              IF NOT p_table_object^.object_exists THEN
                CYCLE /create_table_object_text/;
              IFEND;

              object_index := p_table_objects^ [table_object_index].object_index;
              p_form_object_definition := ^p_form_object_definitions^ [object_index];
              CASE p_form_object_definition^.key OF

              = fdc$form_variable_text_box =
                next_object_index := p_form_object_definition^.variable_box_fragment_index;
                fdp$ptr_screen_variable (p_form_status^.p_screen_record,
                      p_table_object^.screen_record_position, p_form_variable_definition^.
                      screen_variable_length, p_screen_variable);
                format_screen_text (p_screen_variable, p_form_status, object_index, next_object_index,
                      p_form_object_definition^.variable_box_processing,
                      p_form_object_definition^.variable_box_width,
                      p_form_object_definition^.variable_box_height, target_position, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

              = fdc$form_variable_text =
                fdp$ptr_screen_variable (p_form_status^.p_screen_record,
                      p_table_object^.screen_record_position, p_form_object_definition^.
                      text_variable_width, p_screen_variable);
                replace_screen_variable (p_screen_variable, object_index, object_index,
                      p_form_object_definition^.text_variable_width, p_form_status,
                      target_position, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              ELSE
              CASEND;
            FOREND /create_table_object_text/;
          FOREND;
        IFEND;

      = fdc$record_variable =
        p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^ [
              p_variable_record_definition^.variable_index];
        IF NOT p_form_variable_definition^.object_exists THEN
          CYCLE /create_screen_text/;
        IFEND;

        object_index := p_form_variable_definition^.object_index;
        p_form_object_definition := ^p_form_object_definitions^ [object_index];
        CASE p_form_object_definition^.key OF

        = fdc$form_variable_text_box =
          next_object_index := p_form_object_definition^.variable_box_fragment_index;
          fdp$ptr_screen_variable (p_form_status^.p_screen_record,
                p_form_variable_definition^.screen_record_position, p_form_variable_definition^.
                screen_variable_length, p_screen_variable);
          format_screen_text (p_screen_variable, p_form_status, object_index, next_object_index,
                p_form_object_definition^.variable_box_processing,
                p_form_object_definition^.variable_box_width, p_form_object_definition^.variable_box_height,
                target_position, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        ELSE { fdc$form_variable_text }
          fdp$ptr_screen_variable (p_form_status^.p_screen_record,
                p_form_variable_definition^.screen_record_position, p_form_variable_definition^.
                screen_variable_length, p_screen_variable);
          replace_screen_variable (p_screen_variable, object_index, object_index,
                p_form_object_definition^.text_variable_width, p_form_status, target_position, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        CASEND;

      ELSE

{ Invalid record definition key.

        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
              'invalid record definition key', status);
      CASEND;
    FOREND /create_screen_text/;

  PROCEND create_screen_objects;

?? TITLE := 'delete_format_screen_change', EJECT ??

{ PURPOSE:
{   This procedure deletes unnecessary formatting of text box screen changes.  The caller of this
{   procedure has already done the formatting. A format text box screen change is scheduled
{   whenever the terminal user inserts or deletes characters in a text box.

  PROCEDURE delete_format_screen_change
    (    form_identifier: fdt$form_identifier;
         object_index: fdt$object_index);

  VAR
    screen_change: integer;

    FOR screen_change := 1 TO fdv$screen_status.number_screen_changes DO

{ Delete all scheduled formatting.  The terminal user may have done more than one
{ add/delete character actions.

      IF ((fdv$screen_status.p_screen_changes^ [screen_change].key = fdc$format_text_box) AND
            (fdv$screen_status.p_screen_changes^ [screen_change].format_text_form_identifier =
            form_identifier) AND (fdv$screen_status.p_screen_changes^ [screen_change].
            format_text_object_index = object_index)) THEN
        fdv$screen_status.p_screen_changes^ [screen_change].key := fdc$no_screen_change;
      IFEND;
    FOREND;

  PROCEND delete_format_screen_change;

?? TITLE := 'delete_replace_variable', EJECT ??

  PROCEDURE delete_replace_variable
    (    p_form_status: ^fdt$form_status;
         form_identifier: fdt$form_identifier;
         table_index: fdt$table_index;
         screen_change_index: integer);

    VAR
      m: integer,
      p_screen_change: ^fdt$screen_change,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_variable_definitions: ^array [1 .. * ] of fdt$form_variable_definition;

    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    p_form_variable_definitions := p_form_status^.p_form_variable_definitions;

    FOR m := screen_change_index + 1 TO fdv$screen_status.number_screen_changes DO
      p_screen_change := ^fdv$screen_status.p_screen_changes^ [m];
      IF p_screen_change^.key = fdc$replace_variable THEN
        IF p_screen_change^.variable_form_identifier = form_identifier THEN
          p_form_object_definition := ^p_form_object_definitions^ [p_screen_change^.variable_object_index];
          CASE p_form_object_definition^.key OF

          = fdc$form_stored_variable =
            IF p_form_variable_definitions^ [p_form_object_definition^.stored_variable_index].
                  table_exists THEN
              IF p_form_variable_definitions^ [p_form_object_definition^.stored_variable_index].table_index =
                    table_index THEN
                p_screen_change^.key := fdc$no_screen_change;
              IFEND;
            IFEND;

          = fdc$form_variable_text =
            IF p_form_variable_definitions^ [p_form_object_definition^.text_variable_index].table_exists THEN
              IF p_form_variable_definitions^ [p_form_object_definition^.text_variable_index].table_index =
                    table_index THEN
                p_screen_change^.key := fdc$no_screen_change;
              IFEND;
            IFEND;

          = fdc$form_variable_text_box =
            IF p_form_variable_definitions^ [p_form_object_definition^.variable_box_variable_index].
                  table_exists THEN
              IF p_form_variable_definitions^ [p_form_object_definition^.variable_box_variable_index].
                    table_index = table_index THEN
                p_screen_change^.key := fdc$no_screen_change;
              IFEND;
            IFEND;
          ELSE
          CASEND;
        IFEND;
      IFEND;
    FOREND;
  PROCEND delete_replace_variable;

?? TITLE := 'delete_screen_objects', EJECT ??

  PROCEDURE [INLINE] delete_screen_objects
    (    p_form_status: ^fdt$form_status;
     VAR status: ost$status);

    VAR
      object_index: fdt$object_index,
      p_form_object_status: ^fdt$form_object_status,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      terminal_status: ost$status;

    status.normal := TRUE;
    IF p_form_status^.field_number_defined THEN

{ Delete field containing form.

      p_form_status^.field_number_defined := FALSE;
      csv$vector.delete_field^ (p_form_status^.field_number, terminal_status);
      IF NOT terminal_status.normal THEN
        fdp$convert_terminal_status (terminal_status, status);
        RETURN;
      IFEND;

      IF p_form_status^.graphic_identifier_defined THEN

{ Delete box around form.

        p_form_status^.graphic_identifier_defined := FALSE;
        csv$vector.delete_graphic^ (p_form_status^.graphic_identifier, terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          RETURN;
        IFEND;
      IFEND;
    IFEND;

{ Delete objects on form.

    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    FOR object_index := 1 TO p_form_status^.active_form_object_statuses DO
      p_form_object_status := ^p_form_object_statuses^ [object_index];
      CASE p_form_object_status^.key OF

      = fdc$field_identifier =
        csv$vector.delete_field^ (p_form_object_status^.field_number, terminal_status);
        p_form_object_status^.key := fdc$unused_identifier;
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          RETURN;
        IFEND;

      = fdc$graphic_identifier =
        csv$vector.delete_graphic^ (p_form_object_status^.graphic_identifier, terminal_status);
        p_form_object_status^.key := fdc$unused_identifier;
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
          RETURN;
        IFEND;

      ELSE { Ignore other status keys. }
      CASEND;
    FOREND;
  PROCEND delete_screen_objects;

?? TITLE := 'display_form_help', EJECT ??

  PROCEDURE display_form_help
    (    p_form_status: ^fdt$form_status;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      message_text: fdt$message_text,
      p_text: ^fdt$text;

{ Erase any current message form.

    erase_message_form (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE p_form_status^.p_form_definition^.help_definition.key OF

    = fdc$help_form =
      fdp$open_form (p_form_status^.p_form_definition^.help_definition.help_form,
            fdv$screen_status.message_form_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      fdv$screen_status.message_form_displayed := TRUE;

      fdp$add_form (fdv$screen_status.message_form_identifier, status);
      IF NOT status.normal THEN
        erase_message_form (local_status);
        RETURN;
      IFEND;


    = fdc$no_help_response =

{ Do nothing. The application program will handle the help.

    = fdc$system_default_help =
      IF p_form_status^.p_form_definition^.screen_formatting_version < fdc$validation_capability THEN
        RETURN;
      IFEND;

      fdp$get_message (fde$system_help_message, message_text);
      IF p_form_status^.p_form_definition^.screen_formatting_version < fdc$message_form_capability THEN
        display_message_text (^message_text, osc$null_name, status);
      ELSE
        display_message_text (^message_text,
              p_form_status^.p_form_definition^.help_message_form, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fdp$set_cursor_position (fdv$screen_status.message_form_identifier, fdv$message_variable_name, 1, 1,
            status);

    = fdc$help_message =
      p_text := #PTR (p_form_status^.p_form_definition^.help_definition.p_help_message,
            p_form_status^.p_form_module^);
      IF p_form_status^.p_form_definition^.screen_formatting_version < fdc$message_form_capability THEN
        display_message_text (p_text, osc$null_name, status);
      ELSE
        display_message_text (p_text,
              p_form_status^.p_form_definition^.help_message_form, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fdp$set_cursor_position (fdv$screen_status.message_form_identifier, fdv$message_variable_name, 1, 1,
            status);

    ELSE
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'bad form help definition',
            status);
    CASEND;

  PROCEND display_form_help;

?? TITLE := 'display_message_text', EJECT ??

  PROCEDURE display_message_text
    (    p_text: ^fdt$text;
         message_form_name: ost$name;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      variable_status: fdt$variable_status;

    IF message_form_name = osc$null_name THEN

{ Use default message form.
{ If default message form exists in command list, use it.
{ Otherwise, create a message form.

      fdp$open_form (fdc$message_form_name, fdv$screen_status.message_form_identifier, status);
      IF NOT status.normal THEN
        fdp$create_message_form (fdv$screen_status.message_form_identifier, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Set form as displayed so that created form resources will be deallocated.

        fdv$screen_status.message_form_displayed := TRUE;
        fdp$open_form (osc$null_name, fdv$screen_status.message_form_identifier, status);
        IF NOT status.normal THEN
          erase_message_form (local_status);
          RETURN;
        IFEND;
      IFEND;

    ELSE { Use form specified in form definition. }

      fdp$open_form (message_form_name, fdv$screen_status.message_form_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    fdv$screen_status.message_form_displayed := TRUE;
    fdp$add_form (fdv$screen_status.message_form_identifier, status);
    IF NOT status.normal THEN
      erase_message_form (local_status);
      RETURN;
    IFEND;

    fdp$replace_string_variable (fdv$screen_status.message_form_identifier, fdv$message_variable_name, 1,
          p_text^, variable_status, status);
    IF NOT status.normal THEN
      erase_message_form (local_status);
      RETURN;
    IFEND;

  PROCEND display_message_text;

?? TITLE := 'display_variable_error', EJECT ??

  PROCEDURE display_variable_error
    (    p_form_status: ^fdt$form_status;
         form_identifier: fdt$form_identifier;
         p_form_variable_definition: ^fdt$form_variable_definition;
         object_index: fdt$object_index;
         occurrence: fdt$occurrence;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      message_text: fdt$message_text,
      p_text: ^fdt$text,
      screen_change: fdt$screen_change;

{ Set up to display error display attribute for variable.  Note that some
{ error definitions for the variable will not use the error display attribute.

    screen_change.key := fdc$set_attribute;
    screen_change.attribute_form_identifier := form_identifier;
    screen_change.attribute_object_index := object_index;
    screen_change.attribute := p_form_status^.p_form_object_definitions^ [object_index].display_attribute +
          p_form_variable_definition^.error_displays;

{ Response to terminal user error using variable definition for error processing.

    CASE p_form_variable_definition^.error_definition.key OF

{ Display an error form.

    = fdc$error_form =
      fdp$open_form (p_form_variable_definition^.error_definition.error_form,
            fdv$screen_status.message_form_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      fdv$screen_status.message_form_displayed := TRUE;

      fdp$add_form (fdv$screen_status.message_form_identifier, status);
      IF NOT status.normal THEN
        erase_message_form (local_status);
        RETURN;
      IFEND;

{ Display variable with error attribute.

      fdp$record_screen_change (screen_change, status);
      IF NOT status.normal THEN
        erase_message_form (local_status);
        RETURN;
      IFEND;

      p_form_status^.p_form_object_statuses^ [object_index].display_attribute_set := screen_change.attribute;
      fdv$screen_status.error_attribute_displayed := TRUE;
      fdv$screen_status.error_identifier := form_identifier;
      fdv$screen_status.error_name := p_form_variable_definition^.name;
      fdv$screen_status.error_occurrence := occurrence;

      fdp$set_cursor_position (form_identifier, p_form_variable_definition^.name, occurrence, 1, status);
      IF NOT status.normal THEN
        erase_message_form (local_status);
        RETURN;
      IFEND;

    = fdc$no_error_response =

{ Do nothing. The application program will handle the error.

    = fdc$system_default_error =
      IF p_form_status^.p_form_definition^.screen_formatting_version < fdc$validation_capability THEN
        RETURN;
      IFEND;

{ Display default error form with default error message.

      fdp$get_message(fde$system_error_message, message_text);
      display_message_text (^message_text,
            p_form_status^.p_form_definition^.error_message_form, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Display variable with error attribute.

      fdp$record_screen_change (screen_change, status);
      IF NOT status.normal THEN
        erase_message_form (local_status);
        RETURN;
      IFEND;

      p_form_status^.p_form_object_statuses^ [object_index].display_attribute_set := screen_change.attribute;
      fdv$screen_status.error_attribute_displayed := TRUE;
      fdv$screen_status.error_identifier := form_identifier;
      fdv$screen_status.error_name := p_form_variable_definition^.name;
      fdv$screen_status.error_occurrence := occurrence;

      fdp$set_cursor_position (form_identifier, p_form_variable_definition^.name, occurrence, 1, status);
      IF NOT status.normal THEN
        erase_message_form (local_status);
        RETURN;
      IFEND;

    = fdc$error_message =

{ Display default error form with error message defined form variable.

      p_text := #PTR (p_form_variable_definition^.error_definition.p_error_message,
            p_form_status^.p_form_module^);
      display_message_text (p_text,
            p_form_status^.p_form_definition^.error_message_form, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Display variable with error attribute.

      fdp$record_screen_change (screen_change, status);
      IF NOT status.normal THEN
        erase_message_form (local_status);
        RETURN;
      IFEND;
      p_form_status^.p_form_object_statuses^ [object_index].display_attribute_set := screen_change.attribute;
      fdv$screen_status.error_attribute_displayed := TRUE;
      fdv$screen_status.error_identifier := form_identifier;
      fdv$screen_status.error_name := p_form_variable_definition^.name;
      fdv$screen_status.error_occurrence := occurrence;

      fdp$set_cursor_position (form_identifier, p_form_variable_definition^.name, occurrence, 1, status);
      IF NOT status.normal THEN
        erase_message_form (local_status);
        RETURN;
      IFEND;

    ELSE
      osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'bad variable definition',
            status);
    CASEND;
  PROCEND display_variable_error;

?? TITLE := 'display_variable_help', EJECT ??

  PROCEDURE display_variable_help
    (    p_form_status: ^fdt$form_status;
         form_identifier: fdt$form_identifier;
         p_form_variable_definition: ^fdt$form_variable_definition;
         occurrence: fdt$occurrence;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      message_text: fdt$message_text,
      p_text: ^fdt$text;


{ Delete any previous help or error forms.

    erase_message_form (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Provide help specified in the variable definition.

    CASE p_form_variable_definition^.help_definition.key OF

    = fdc$help_form =

{ Display form user specified in the variable definition.

      fdp$open_form (p_form_variable_definition^.help_definition.help_form,
            fdv$screen_status.message_form_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      fdv$screen_status.message_form_displayed := TRUE;

      fdp$add_form (fdv$screen_status.message_form_identifier, status);
      IF NOT status.normal THEN
        erase_message_form (local_status);
        RETURN;
      IFEND;

      fdp$set_cursor_position (form_identifier, p_form_variable_definition^.name, occurrence, 1, status);
      IF NOT status.normal THEN
        erase_message_form (local_status);
        RETURN;
      IFEND;

    = fdc$no_help_response =
      display_form_help (p_form_status, status);

    = fdc$system_default_help =
      IF p_form_status^.p_form_definition^.screen_formatting_version < fdc$validation_capability THEN
        RETURN;
      IFEND;

{ Display default help message in the default message form.

      fdp$get_message (fde$system_help_message, message_text);
      IF p_form_status^.p_form_definition^.screen_formatting_version < fdc$message_form_capability THEN
        display_message_text (^message_text, osc$null_name, status);
      ELSE
        display_message_text (^message_text,
              p_form_status^.p_form_definition^.help_message_form, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fdp$set_cursor_position (form_identifier, p_form_variable_definition^.name, occurrence, 1, status);
      IF NOT status.normal THEN
        erase_message_form (local_status);
        RETURN;
      IFEND;

    = fdc$help_message =

{ Display help message specified by the user in the variable definition.

      p_text := #PTR (p_form_variable_definition^.help_definition.p_help_message,
            p_form_status^.p_form_module^);
      IF p_form_status^.p_form_definition^.screen_formatting_version < fdc$message_form_capability THEN
        display_message_text (p_text, osc$null_name, status);
      ELSE
        display_message_text (p_text,
              p_form_status^.p_form_definition^.help_message_form, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fdp$set_cursor_position (form_identifier, p_form_variable_definition^.name, occurrence, 1, status);
      IF NOT status.normal THEN
        erase_message_form (local_status);
        RETURN;
      IFEND;

    ELSE
    CASEND;
  PROCEND display_variable_help;

?? TITLE := 'erase_message_form', EJECT ??

  PROCEDURE erase_message_form
    (VAR status: ost$status);


    VAR
      local_status: ost$status;

    status.normal := TRUE;
    IF fdv$screen_status.message_form_displayed THEN

{ Delete message form.

      fdv$screen_status.message_form_displayed := FALSE;
      fdp$close_form (fdv$screen_status.message_form_identifier, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, 'close of message form',
              status);
        RETURN;
      IFEND;

      IF fdv$screen_status.error_attribute_displayed THEN

{ Remove error display attribute.

        fdv$screen_status.error_attribute_displayed := FALSE;
        fdp$reset_object_attribute (fdv$screen_status.error_identifier, fdv$screen_status.error_name,
              fdv$screen_status.error_occurrence, local_status);
      IFEND;
    IFEND;
  PROCEND erase_message_form;

?? TITLE := 'find_previous_object', EJECT ??

{ PURPOSE:
{   This procedure finds the previous object on the screen from the specified position.
{ DESIGN:
{   This procedure searches the object definitions until the first one before the specified position is
{   encountered.  The object definitions are ordered by location.
{

  PROCEDURE [INLINE] find_previous_object
    (    x_position: fdt$x_position;
         y_position: fdt$y_position;
         p_form_status: ^fdt$form_status;
     VAR object_index: fdt$object_index);

    VAR
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition;

    p_form_object_definitions := p_form_status^.p_form_object_definitions;

{ All objects are sorted by form location.  Look for the previous object.

    FOR object_index := p_form_status^.p_form_definition^.form_object_definitions.active_number DOWNTO 1 DO
      p_form_object_definition := ^p_form_object_definitions^ [object_index];
      CASE p_form_object_definition^.key OF

        = fdc$form_variable_text, fdc$form_text_box_fragment, fdc$form_variable_text_box =
        IF ((p_form_object_definition^.y_position = y_position) AND
              (p_form_object_definition^.x_position < x_position)) THEN

{ Found the previous object on the same terminal line.

          RETURN;
        IFEND;

        IF p_form_object_definition^.y_position < y_position THEN

{ Found the previous object on a previous terminal line.

          RETURN;
        IFEND;

      ELSE

{ Ignore objects that are not variables and objects that do not have an x, y position.

      CASEND;
    FOREND;

{ No objects precede the specified position.  Start search from the end of the form.

    object_index := p_form_status^.p_form_definition^.form_object_definitions.active_number;

  PROCEND find_previous_object;

?? OLDTITLE ??
?? TITLE := 'format_screen_text', EJECT ??

{ PURPOSE:
{   This procedure transfers text for variable and constant text box objects to
{   the Screen Manager.

  PROCEDURE format_screen_text
    (    p_text: ^fdt$text;
         p_form_status: ^fdt$form_status;
         object_index: fdt$object_index;
         next_object_index: fdt$object_index;
         text_box_processing: fdt$text_box_processing;
         width: fdt$width;
         height: fdt$height;
         target_position: fdt$target_position;
     VAR status: ost$status);

    VAR
      fragment_object_index: fdt$object_index,
      next_fragment_object_index: fdt$object_index,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      space: [READ, STATIC] string (1) := ' ';

?? NEWTITLE := 'output_screen_text', EJECT ??

    PROCEDURE output_screen_text
      (    field_number: cst$field_number;
           p_output_text: ^fdt$text);

      VAR
        end_of_text: boolean,
        terminal_status: ost$status;

      csv$vector.change_io_position^ (field_number, 1, terminal_status);
      IF NOT terminal_status.normal THEN
        fdp$convert_terminal_status (terminal_status, status);
        RETURN;
      IFEND;

      csv$vector.put_text^ (p_output_text, TRUE, end_of_text, terminal_status);
      IF NOT terminal_status.normal THEN
        fdp$convert_terminal_status (terminal_status, status);
      IFEND;

    PROCEND output_screen_text;

?? OLDTITLE ??
?? NEWTITLE := 'wrap_characters', EJECT ??

{ PURPOSE:
{   This procedure wraps characters into a text box.

    PROCEDURE wrap_characters;

      VAR
        end_text_index: fdt$text_length,
        formatted_width: fdt$width,
        p_screen_text: ^fdt$text,
        position: integer,
        screen_visible_length: fdt$screen_variable_length,
        shift: integer,
        start_text_index: integer,
        text_length: fdt$text_length;

{ Compute shift needed to reformat the text. First specify the maximum shift needed.  Later
{ processing will insure that the shift does not cause the data to be outside the limits
{ of the text box. For example, a shift might cause the starting position to be less than one
{ or greater than area for text in the object.

      screen_visible_length := height * width;
      CASE target_position.key OF

      = fdc$page_data_first =

{ Specify the maximum shift need to move the first character of the text to the first character of
{ the object.

        shift := - STRLENGTH (p_text^);

      = fdc$page_data_last =

{ Specify the maximum shift need to move the last character of the text to the last character
{ of the object.

        shift := STRLENGTH (p_text^);

      = fdc$page_data_forward =

{ Shift the data forward by the visible area of the object.

        shift := screen_visible_length;

      = fdc$page_data_backward =

{ Shift the data backward by the visible area of the object.

        shift := -screen_visible_length;

      = fdc$scroll_data_forward =

{ Move the character under the cursor to the first character position of the object.

        shift := target_position.data_index - p_form_object_statuses^ [object_index].character_position;

      = fdc$scroll_data_backward =

{ Move the character under the cursor to the last character position of the object.

        shift := p_form_object_statuses^ [object_index].character_position + screen_visible_length - 1 -
              target_position.data_index;
        shift := -shift;

      = fdc$current_data_position =
        shift := 0;

      = fdc$shift_characters =
        shift := target_position.shift;

      ELSE { fdc$top_of_box, fdc$bottom_of_box do not apply.}
        shift := 0;
      CASEND;

{ Make sure the shift lies within the range of the text.

      position := p_form_object_statuses^ [object_index].character_position + shift;
      IF position < 1 THEN
        start_text_index := 1;
      ELSE
        start_text_index := position;
      IFEND;

{ The text length may be less than the size of the object.
{ If text is less than the size of the object, set starting index to show all of text.
{ If the terminal user alters the text, the changes must lie within the text.

      text_length := STRLENGTH (p_text^);
      IF ((start_text_index + screen_visible_length - 1) > text_length) THEN
        start_text_index := text_length - screen_visible_length + 1;
      IFEND;
      IF start_text_index < 1 THEN
        start_text_index := 1;
      IFEND;

      next_fragment_object_index := next_object_index;

{ Break the text into lines (fragments) for the object.

    /break_text_into_objects/
      WHILE TRUE DO
        IF (start_text_index > text_length) THEN
          next_fragment_object_index := fragment_object_index;
          EXIT /break_text_into_objects/;
        IFEND;

        IF ((start_text_index + width - 1) > text_length) THEN

{ This is last line of characters in the object.

          formatted_width := text_length - start_text_index + 1;
          p_screen_text := ^p_text^ (start_text_index, formatted_width);
          p_form_object_statuses^ [fragment_object_index].character_position := start_text_index;
          p_form_object_statuses^ [fragment_object_index].data_length := formatted_width;
          output_screen_text (p_form_status^.p_form_object_statuses^ [fragment_object_index].field_number,
                p_screen_text);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          EXIT /break_text_into_objects/;
        IFEND;

{ Output next line of text to first/next object fragment.

        p_screen_text := ^p_text^ (start_text_index, width);
        p_form_object_statuses^ [fragment_object_index].character_position := start_text_index;
        p_form_object_statuses^ [fragment_object_index].data_length := width;
        output_screen_text (p_form_status^.p_form_object_statuses^ [fragment_object_index].field_number,
              p_screen_text);
        ;
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF next_fragment_object_index = 0 THEN
          EXIT /break_text_into_objects/;
        IFEND;

{ Get next line of text and the next object fragment.

        start_text_index := start_text_index + width;
        fragment_object_index := next_fragment_object_index;
        next_fragment_object_index := p_form_object_definitions^ [fragment_object_index].
              next_fragment_object_index;
      WHILEND /break_text_into_objects/;

{ All of text has been processed. Space fill any remaining objects in the text box.

      start_text_index := start_text_index + formatted_width;
      p_screen_text := ^space;
      fragment_object_index := next_fragment_object_index;
      WHILE fragment_object_index <> 0 DO
        p_form_object_statuses^ [fragment_object_index].character_position := start_text_index;
        p_form_object_statuses^ [fragment_object_index].data_length := 0;
        output_screen_text (p_form_status^.p_form_object_statuses^ [fragment_object_index].field_number,
              p_screen_text);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        fragment_object_index := p_form_object_definitions^ [fragment_object_index].
              next_fragment_object_index;
      WHILEND;

    PROCEND wrap_characters;

?? OLDTITLE ??
?? NEWTITLE := 'wrap_words', EJECT ??

{ PURPOSE:
{   This procedure wraps words into a text box.

    PROCEDURE wrap_words;

      TYPE
        fdt$character_processing = (fdc$process_word_delimiter, fdc$process_new_line, fdc$process_new_record,
              fdc$process_next_character),
        fdt$line_processing = (fdc$get_next_character, fdc$start_next_line, fdc$remove_leading_spaces,
              fdc$record_line, fdc$process_last_line, fdc$line_processing_complete),
        fdt$line_splits = record
          position: fdt$text_length,
          length: fdt$text_length,
        recend,
        fdt$box_processing = (fdc$box_space_available, fdc$box_space_full);

      VAR
        box_processing: fdt$box_processing,
        character_processing: fdt$character_processing,
        end_word_index: integer,
        line_count: 0 .. fdc$maximum_y_position,
        line_processing: fdt$line_processing,
        line_text_count: 0 .. fdc$maximum_x_position,
        p_line_splits: ^array [1 .. * ] of fdt$line_splits,
        position: integer,
        start_line_index: integer,
        text_index: integer,
        text_count: integer,
        word_ended: boolean,
        word_started: boolean,
        word_wrap_target_position: fdt$target_position;

?? OLDTITLE ??
?? NEWTITLE := 'fill_line', EJECT ??

{ PURPOSE:
{   This procedure gets text characters  and moves the characters to lines of
{   the object. This procedure uses a state tree to determine what processing needs
{   to be done. Each call can change only one state.

      PROCEDURE fill_line;

        CASE line_processing OF

{ Get the next character of text for a line in a text box.

        = fdc$get_next_character, fdc$remove_leading_spaces =
          IF text_count >= width THEN

{ Formatted text is at end of object line.  On the next call record the line;

            line_processing := fdc$record_line;
            RETURN;
          IFEND;

{ Get next character to format in current line.


          IF text_index >= STRLENGTH (p_text^) THEN

{ Last character of data was processed, so on next call process the last line.

            line_processing := fdc$process_last_line;
            RETURN;
          IFEND;

          text_index := text_index + 1;
          get_character (p_text^ (text_index, 1), character_processing);

{ Determine what to do with the character.

          CASE character_processing OF

          = fdc$process_next_character =
            IF line_processing = fdc$remove_leading_spaces THEN

{ Processing has started a new line for the text box. We want to remove leading spaces.
{ We have found the first non space character on the line.  Now start the
{ gathering of characters for the line.

              start_line_index := text_index;
              line_processing := fdc$get_next_character;
              text_count := 0;
            IFEND;

            word_started := TRUE;
            text_count := text_count + 1;

          = fdc$process_word_delimiter =
            IF word_started THEN

{ If possible, break lines after the word delimiter. Including the delimiter with the
{ last work on the line helps to prevent later insertions and deletions to cause
{ words to run together.

              word_ended := TRUE;
              end_word_index := text_index;
            IFEND;

            text_count := text_count + 1;

          ELSE {fdc$process_new_record, fdc$process_new_line

{ A terminal user insert line action causes a new record character to be inserted in the text.
{ Now we want to show the terminal user a line of spaces.

            line_processing := fdc$start_next_line;

{ Complete the current line.

            line_text_count := text_index - start_line_index + 1;
            record_line;

{ If the current line had any data, then add a new blank line for the insert line or new line.
{ Otherwise we already have a blank line.

            IF text_count <> 0 THEN
              start_line_index := text_index;
              line_text_count := 1;
              record_line;
            IFEND;
            start_line_index := text_index + 1;

          CASEND;

        = fdc$record_line =

{ If possible, break the line at the end of the last word.

          line_processing := fdc$start_next_line;
          IF word_ended THEN
            line_text_count := end_word_index - start_line_index + 1;
            text_index := end_word_index;
          ELSE { The word occupies the entire width of the text box.
            line_text_count := text_index - start_line_index + 1;
          IFEND;

{ Record line can change the line_processing state.  All the specified text may have been
{ collected and processing is nearly complete.

          record_line;
          start_line_index := text_index + 1;

        = fdc$process_last_line =
          line_processing := fdc$line_processing_complete;
          IF text_count > 0 THEN
            IF word_ended THEN
              line_text_count := end_word_index - start_line_index + 1;
              text_index := end_word_index;
            ELSE
              line_text_count := text_index - start_line_index + 1;
            IFEND;
            record_line;
          IFEND;

        ELSE {fdc$start_next_line}
          word_ended := FALSE;
          word_started := FALSE;
          text_count := 0;
          line_processing := fdc$remove_leading_spaces;

        CASEND;
      PROCEND fill_line;

?? OLDTITLE ??
?? NEWTITLE := 'get_character', EJECT ??

{ PURPOSE:
{   This procedure determines the processing required for a character.

      PROCEDURE get_character
        (    next_character: string (1);
         VAR character_processing: fdt$character_processing);

        IF next_character = space THEN
          character_processing := fdc$process_word_delimiter;
        ELSEIF next_character = fdc$new_line_character THEN
          character_processing := fdc$process_new_line;
        ELSEIF next_character = record_separator THEN
          character_processing := fdc$process_new_record;
        ELSE
          character_processing := fdc$process_next_character;
        IFEND;
      PROCEND get_character;

?? OLDTITLE ??
?? NEWTITLE := 'record_line', EJECT ??

{ PURPOSE:
{   This procedure records how text is broken up into lines for the object.  This procedure
{   may also determine the desired text has been placed in the object and now processing
{   is complete. The processing atttemps to keep the object backed by corresponding
{   characters of text.  We want to avoid having the terminal user type into an object
{   that cannot be mapped into the text.

      PROCEDURE record_line;

        VAR
          push_index: 1 .. fdc$maximum_y_position;


?? NEWTITLE := 'test_for_last_line', EJECT ??

{ PURPOSE:
{   This procedure determines if a full object contains the specified data character in
{   the desired target position. If so, then processing is done.

        PROCEDURE test_for_last_line;

          CASE word_wrap_target_position.key OF
          = fdc$top_of_box =
            IF ((p_line_splits^ [1].position >= word_wrap_target_position.data_index) AND
                  (word_wrap_target_position.data_index < p_line_splits^ [1].position +
                  p_line_splits^ [1].length)) THEN
              line_processing := fdc$line_processing_complete;
            IFEND;

          ELSE {fdc$bottom_of_box}
            IF (word_wrap_target_position.data_index < (p_line_splits^ [height].
                  position + p_line_splits^ [height].length)) THEN
              line_processing := fdc$line_processing_complete;
            IFEND;
          CASEND;
        PROCEND test_for_last_line;

?? OLDTITLE ??

        CASE box_processing OF

        = fdc$box_space_available =

{ Add a line of text to the object.
{ We want to fill the object with text if possible.

          line_count := line_count + 1;
          p_line_splits^ [line_count].position := start_line_index;
          p_line_splits^ [line_count].length := line_text_count;
          IF line_count = height THEN
            box_processing := fdc$box_space_full;
            test_for_last_line;
          IFEND;


        ELSE { fdc$box_space_full }

{ Push lines up in the object and then put the new line at the end.

          FOR push_index := 2 TO height DO
            p_line_splits^ [push_index - 1].position := p_line_splits^ [push_index].position;
            p_line_splits^ [push_index - 1].length := p_line_splits^ [push_index].length;
          FOREND;

          p_line_splits^ [height].position := start_line_index;
          p_line_splits^ [height].length := line_text_count;

{ When the object is full, test to see if the object contains the desired data at the
{ desired position.

          test_for_last_line;

        CASEND;

      PROCEND record_line;

?? OLDTITLE ??
?? NEWTITLE := 'write_text_box', EJECT ??

{ PURPOSE:
{   This procedure picks up text to write out to the terminal.  The width of the
{   text written to the terminal manager must equal the width of the object.  When
{   the terminal user types into the visible area of the object, the terminal user
{   believes he/she is replacing characters.  If the text length were less than the width
{   of the object, the terminal user would see spaces to separate words, but the end of the
{   input is the last typed character on the line.

      PROCEDURE write_text_box;

        VAR
          current_line: 0 .. fdc$maximum_y_position,
          last_position: fdt$text_length,
          p_screen_text: ^fdt$text;

        PUSH p_screen_text: [width];
        IF line_count > 0 THEN
          p_screen_text^ := p_text^ (p_line_splits^ [1].position, p_line_splits^ [1].length);
          p_form_object_statuses^ [fragment_object_index].character_position := p_line_splits^ [1].position;
          p_form_object_statuses^ [fragment_object_index].data_length := p_line_splits^ [1].length;

        ELSE { Space fill rest of text box.
          p_screen_text^ := '';
          p_form_object_statuses^ [fragment_object_index].character_position := 1;
          p_form_object_statuses^ [fragment_object_index].data_length := 0;
        IFEND;

        output_screen_text (p_form_status^.p_form_object_statuses^ [fragment_object_index].field_number,
              p_screen_text);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        last_position := p_form_object_statuses^ [fragment_object_index].character_position +
              p_form_object_statuses^ [fragment_object_index].data_length - 1;
        current_line := 1;
        fragment_object_index := next_object_index;

        WHILE fragment_object_index <> 0 DO
          IF current_line < line_count THEN
            current_line := current_line + 1;
            p_screen_text^ := p_text^ (p_line_splits^ [current_line].position,
                  p_line_splits^ [current_line].length);
            p_form_object_statuses^ [fragment_object_index].character_position :=
                  p_line_splits^ [current_line].position;
            p_form_object_statuses^ [fragment_object_index].data_length :=
                  p_line_splits^ [current_line].length;
            last_position := p_form_object_statuses^ [fragment_object_index].character_position +
                  p_form_object_statuses^ [fragment_object_index].data_length - 1;

          ELSE { Space fill rest of text box.
            p_screen_text^ := '';
            p_form_object_statuses^ [fragment_object_index].character_position := last_position;
            p_form_object_statuses^ [fragment_object_index].data_length := 0;
          IFEND;

          output_screen_text (p_form_status^.p_form_object_statuses^ [fragment_object_index].field_number,
                p_screen_text);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          fragment_object_index := p_form_object_definitions^ [fragment_object_index].
                next_fragment_object_index;
        WHILEND;

      PROCEND write_text_box;

?? OLDTITLE, EJECT ??

      word_wrap_target_position := target_position;

      CASE target_position.key OF

      = fdc$page_data_first =

{ Move the first character of text to the top of the object.

        word_wrap_target_position.key := fdc$top_of_box;
        word_wrap_target_position.data_index := 1;

      = fdc$page_data_last =

{ Move the last character of text to the bottom of the object.

        word_wrap_target_position.key := fdc$bottom_of_box;
        word_wrap_target_position.data_index := STRLENGTH (p_text^);
        ;

      = fdc$page_data_forward =

{ Move first character of the next page to top of object.  The first character of the next page
{ is the last character of this page + 1;

        word_wrap_target_position.key := fdc$top_of_box;
        word_wrap_target_position.data_index := p_form_object_statuses^ [object_index].character_position +
              p_form_object_statuses^ [object_index].data_length;
        next_fragment_object_index := next_object_index;

      /find_last_character_in_box/
        WHILE next_fragment_object_index <> 0 DO
          word_wrap_target_position.data_index := p_form_object_statuses^ [next_fragment_object_index].
                character_position + p_form_object_statuses^ [next_fragment_object_index].data_length;
          next_fragment_object_index := p_form_object_definitions^ [next_fragment_object_index].
                next_fragment_object_index;
        WHILEND /find_last_character_in_box/;

      = fdc$page_data_backward =

{ Move first character of the object - 1 to bottom of the object.

        word_wrap_target_position.key := fdc$bottom_of_box;
        IF p_form_object_statuses^ [object_index].character_position > 1 THEN
          word_wrap_target_position.data_index := p_form_object_statuses^ [object_index].character_position -
                1;
        ELSE
          word_wrap_target_position.data_index := 1;
        IFEND;

      = fdc$scroll_data_forward =
        word_wrap_target_position.key := fdc$top_of_box;

      = fdc$scroll_data_backward =
        word_wrap_target_position.key := fdc$bottom_of_box;

      = fdc$current_data_position =
        word_wrap_target_position.key := fdc$top_of_box;
        word_wrap_target_position.data_index := p_form_object_statuses^ [object_index].character_position;

      = fdc$shift_characters =
        word_wrap_target_position.key := fdc$top_of_box;
        position := p_form_object_statuses^ [object_index].character_position + target_position.shift;
        IF position < 1 THEN
          position := 1;
        IFEND;
        IF position > STRLENGTH (p_text^) THEN
          position := STRLENGTH (p_text^) + 1;
        IFEND;
        word_wrap_target_position.data_index := position;
      ELSE { fdc$top_of_box, fdc$bottom_of_box are already setup.}
      CASEND;

      line_processing := fdc$start_next_line;
      start_line_index := 1;
      text_index := 0;
      PUSH p_line_splits: [1 .. height];
      line_count := 0;
      box_processing := fdc$box_space_available;

      REPEAT

{ Each cycle may change no more than one line processing state.

        fill_line;
      UNTIL line_processing = fdc$line_processing_complete;
      write_text_box;
    PROCEND wrap_words;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    fragment_object_index := object_index;

    CASE text_box_processing OF

    = fdc$wrap_characters =
      wrap_characters;

    ELSE {fdc$wrap_words}
      wrap_words;

    CASEND;

  PROCEND format_screen_text;

?? NEWTITLE := 'location_covered_by_form', EJECT ??

{ PURPOSE:
{   This function verifies that the specified location is not covered by another form.
{ NOTE:
{   The only forms that need to be checkes are those 'higher' than the form containing the object.

  FUNCTION location_covered_by_form
    (    p_form_status: ^fdt$form_status;
         x_position: fdt$x_position;
         y_position: fdt$y_position): boolean;

    VAR
      form_area: fdt$form_area,
      form_identifier: fdt$form_identifier,
      p_new_form_status: ^fdt$form_status;

    location_covered_by_form := FALSE;
    p_new_form_status := p_form_status;
    WHILE (p_new_form_status^.next_higher_form <> 0) DO
      p_new_form_status := ^fdv$screen_status.p_forms_status^ [p_new_form_status^.next_higher_form];
      form_area := p_new_form_status^.p_form_definition^.form_area;
      IF form_area.key = fdc$defined_area THEN
        IF (x_position >= p_new_form_status^.form_x_position) AND
              (x_position <= (p_new_form_status^.form_x_position + form_area.width - 1)) AND
              (y_position >= p_new_form_status^.form_y_position) AND
              (y_position <= (p_new_form_status^.form_y_position + form_area.height - 1)) THEN
          location_covered_by_form := TRUE;
          RETURN;
        IFEND;
      ELSE

{ The entire screen is covered by the form.

        location_covered_by_form := TRUE;
        RETURN;
      IFEND;
    WHILEND;

  FUNCEND location_covered_by_form;


?? OLDTITLE ??
?? TITLE := 'page_table', EJECT ??

  PROCEDURE page_table
    (    p_form_status: ^fdt$form_status;
         p_form_table_definition: ^fdt$form_table_definition;
         table_index: fdt$table_index;
         occurrence_shift: integer;
         field_number: cst$field_number;
         cursor_character_position: cst$character_position;
         cursor_line_number: cst$line_number;
     VAR status: ost$status);

    VAR
      character_position: cst$character_position,
      line_number: cst$line_number,
      terminal_status: ost$status;

    status.normal := TRUE;
    shift_table (p_form_status, p_form_table_definition, table_index, occurrence_shift, 0, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    csv$vector.position_cursor^ (field_number, cursor_character_position, cursor_line_number,
          character_position, line_number, terminal_status);
    IF NOT terminal_status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
    IFEND;

  PROCEND page_table;

?? OLDTITLE ??
?? TITLE := 'put_graphic_attribute', EJECT ??

  PROCEDURE put_graphic_attribute
    (    graphic_identifier: cst$graphic_identifier;
         display_attribute_set: fdt$display_attribute_set;
     VAR status: ost$status);

    VAR
      attribute_set: cst$attribute_set,
      display_attribute: fdt$display_attribute,
      terminal_status: ost$status;

    status.normal := TRUE;
    IF (display_attribute_set <> $fdt$display_attribute_set []) THEN
      attribute_set := $cst$attribute_set [];
      FOR display_attribute := LOWERVALUE (fdt$display_attribute) TO UPPERVALUE (fdt$display_attribute) DO
        IF display_attribute IN display_attribute_set THEN

{ Translate Screen Formatting display attributes to Screen Manager display
{ attributes.

          CASE display_attribute OF

          = fdc$black_foreground =
            attribute_set := attribute_set + $cst$attribute_set [csc$f_black];

          = fdc$black_background =
            attribute_set := attribute_set + $cst$attribute_set [csc$b_black];

          = fdc$blue_foreground =
            attribute_set := attribute_set + $cst$attribute_set [csc$f_blue];

          = fdc$blue_background =
            attribute_set := attribute_set + $cst$attribute_set [csc$b_blue];

          = fdc$green_foreground =
            attribute_set := attribute_set + $cst$attribute_set [csc$f_green];

          = fdc$green_background =
            attribute_set := attribute_set + $cst$attribute_set [csc$b_green];

          = fdc$magenta_foreground =
            attribute_set := attribute_set + $cst$attribute_set [csc$f_magenta];

          = fdc$magenta_background =
            attribute_set := attribute_set + $cst$attribute_set [csc$b_magenta];

          = fdc$red_foreground =
            attribute_set := attribute_set + $cst$attribute_set [csc$f_red];

          = fdc$red_background =
            attribute_set := attribute_set + $cst$attribute_set [csc$b_red];

          = fdc$cyan_foreground =
            attribute_set := attribute_set + $cst$attribute_set [csc$f_cyan];

          = fdc$cyan_background =
            attribute_set := attribute_set + $cst$attribute_set [csc$b_cyan];

          = fdc$yellow_foreground =
            attribute_set := attribute_set + $cst$attribute_set [csc$f_yellow];

          = fdc$yellow_background =
            attribute_set := attribute_set + $cst$attribute_set [csc$b_yellow];

          = fdc$white_foreground =
            attribute_set := attribute_set + $cst$attribute_set [csc$f_white];

          = fdc$white_background =
            attribute_set := attribute_set + $cst$attribute_set [csc$b_white];

          = fdc$fine_line, fdc$fine_border =
            attribute_set := attribute_set + $cst$attribute_set [csc$line_fine];

          = fdc$medium_line, fdc$medium_border =
            attribute_set := attribute_set + $cst$attribute_set [csc$line_medium];

          = fdc$bold_line, fdc$bold_border =
            attribute_set := attribute_set + $cst$attribute_set [csc$line_bold];

          = fdc$protect =
            attribute_set := attribute_set + $cst$attribute_set [csc$protected];

          = fdc$inverse_video =
            attribute_set := attribute_set + $cst$attribute_set [csc$p_inverse];

          = fdc$low_intensity =
            attribute_set := attribute_set + $cst$attribute_set [csc$p_alternate_intensity];

          = fdc$high_intensity =
            attribute_set := attribute_set + $cst$attribute_set [csc$p_alternate_intensity];

          = fdc$blink =
            attribute_set := attribute_set + $cst$attribute_set [csc$p_blink];

          ELSE { Display attribute does not apply to graphic. }
          CASEND;
        IFEND;
      FOREND;

      attribute_set := attribute_set + $cst$attribute_set [csc$protected];
      csv$vector.change_graphic_attributes^ (graphic_identifier, attribute_set, terminal_status);
      IF NOT terminal_status.normal THEN
        fdp$convert_terminal_status (terminal_status, status);
      IFEND;
    IFEND;
  PROCEND put_graphic_attribute;

?? TITLE := 'put_text_attribute', EJECT ??

  PROCEDURE put_text_attribute
    (    field_number: cst$field_number;
         display_attribute_set: fdt$display_attribute_set;
         io_mode: fdt$io_mode;
     VAR status: ost$status);

    VAR
      attribute_set: cst$attribute_set,
      field_attributes: array [1 .. 1] of cst$field_attribute,
      display_attribute: fdt$display_attribute,
      terminal_status: ost$status;

    status.normal := TRUE;
    attribute_set := $cst$attribute_set [];
    FOR display_attribute := LOWERVALUE (fdt$display_attribute) TO UPPERVALUE (fdt$display_attribute) DO
      IF display_attribute IN display_attribute_set THEN

{ Translate Screen Formatting display attributes to Screen Manager display
{ attributes.

        CASE display_attribute OF

        = fdc$black_foreground =
          attribute_set := attribute_set + $cst$attribute_set [csc$f_black];

        = fdc$black_background =
          attribute_set := attribute_set + $cst$attribute_set [csc$b_black];

        = fdc$blue_foreground =
          attribute_set := attribute_set + $cst$attribute_set [csc$f_blue];

        = fdc$blue_background =
          attribute_set := attribute_set + $cst$attribute_set [csc$b_blue];

        = fdc$green_foreground =
          attribute_set := attribute_set + $cst$attribute_set [csc$f_green];

        = fdc$green_background =
          attribute_set := attribute_set + $cst$attribute_set [csc$b_green];

        = fdc$magenta_foreground =
          attribute_set := attribute_set + $cst$attribute_set [csc$f_magenta];

        = fdc$magenta_background =
          attribute_set := attribute_set + $cst$attribute_set [csc$b_magenta];

        = fdc$red_foreground =
          attribute_set := attribute_set + $cst$attribute_set [csc$f_red];

        = fdc$red_background =
          attribute_set := attribute_set + $cst$attribute_set [csc$b_red];

        = fdc$cyan_foreground =
          attribute_set := attribute_set + $cst$attribute_set [csc$f_cyan];

        = fdc$cyan_background =
          attribute_set := attribute_set + $cst$attribute_set [csc$b_cyan];

        = fdc$yellow_foreground =
          attribute_set := attribute_set + $cst$attribute_set [csc$f_yellow];

        = fdc$yellow_background =
          attribute_set := attribute_set + $cst$attribute_set [csc$b_yellow];

        = fdc$white_foreground =
          attribute_set := attribute_set + $cst$attribute_set [csc$f_white];

        = fdc$white_background =
          attribute_set := attribute_set + $cst$attribute_set [csc$b_white];

        = fdc$protect =
          attribute_set := attribute_set + $cst$attribute_set [csc$protected];

        = fdc$hidden =
          attribute_set := attribute_set + $cst$attribute_set [csc$hidden];

        = fdc$inverse_video =
          attribute_set := attribute_set + $cst$attribute_set [csc$p_inverse];

        = fdc$low_intensity =
          attribute_set := attribute_set + $cst$attribute_set [csc$p_alternate_intensity];

        = fdc$high_intensity =
          attribute_set := attribute_set + $cst$attribute_set [csc$p_alternate_intensity];

        = fdc$blink =
          attribute_set := attribute_set + $cst$attribute_set [csc$p_blink];

        = fdc$underline =
          attribute_set := attribute_set + $cst$attribute_set [csc$p_underline];

        = fdc$italic_display_attribute =
          attribute_set := attribute_set + $cst$attribute_set [csc$l_italic];

        = fdc$title_display_attribute =
          attribute_set := attribute_set + $cst$attribute_set [csc$l_title];

        = fdc$input_display_attribute =
          attribute_set := attribute_set + $cst$attribute_set [csc$l_input];

        = fdc$error_display_attribute =
          attribute_set := attribute_set + $cst$attribute_set [csc$l_error];

        = fdc$message_display_attribute =
          attribute_set := attribute_set + $cst$attribute_set [csc$l_message];

        = fdc$display_left_to_right =
          csv$vector.change_field_direction^ (field_number, csc$direction_left_to_right, terminal_status);
          IF NOT terminal_status.normal THEN
            fdp$convert_terminal_status (terminal_status, status);
            RETURN;
          IFEND;

        = fdc$display_right_to_left =
          csv$vector.change_field_direction^ (field_number, csc$direction_right_to_left, terminal_status);
          IF NOT terminal_status.normal THEN
            fdp$convert_terminal_status (terminal_status, status);
            RETURN;
          IFEND;


        ELSE { Attribute does not apply. }
        CASEND;
      IFEND;
    FOREND;

    CASE io_mode OF

    = fdc$terminal_input, fdc$terminal_input_output =
      field_attributes [1].key := csc$fld_input;
      IF fdc$protect IN display_attribute_set THEN
        field_attributes [1].input := FALSE;
      ELSE
        field_attributes [1].input := TRUE;
      IFEND;
      csv$vector.change_field_attributes^ (field_number, field_attributes, terminal_status);
      IF NOT terminal_status.normal THEN
        fdp$convert_terminal_status (terminal_status, status);
      IFEND;
    ELSE
    CASEND;

    csv$vector.change_text_attributes^ (field_number, attribute_set, terminal_status);
    IF NOT terminal_status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
    IFEND;
  PROCEND put_text_attribute;

?? TITLE := 'replace_screen_variable ', EJECT ??

{ PURPOSE:
{   This procedure transfers text for variable and constant text objects to the Screen Manager.

  PROCEDURE replace_screen_variable
    (    p_text: ^fdt$text;
         field_object_index: fdt$object_index;
         status_object_index: fdt$object_index;
         screen_visible_length: fdt$screen_variable_length;
         p_form_status: ^fdt$form_status;
         target_position: fdt$target_position;
     VAR status: ost$status);

    VAR
      end_of_text: boolean,
      formatted_text_length: integer,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_screen_text: ^fdt$text,
      position: integer,
      shift: integer,
      terminal_status: ost$status,
      text_length: fdt$text_length;

    status.normal := TRUE;
    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    csv$vector.change_io_position^ (p_form_status^.p_form_object_statuses^ [field_object_index].
          field_number, 1, terminal_status);
    IF NOT terminal_status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
      RETURN;
    IFEND;

      CASE target_position.key OF

    = fdc$page_data_first =

{ Use maximun shift needed to put first character of data in first character position of object.

      shift := - STRLENGTH(p_text^);

    = fdc$page_data_last =

{ Use maximun shift needed to put last character of data in last character position of object.

      shift := STRLENGTH(p_text^);

    = fdc$page_data_forward =

{ Shift data forward the size of the object.

      shift := screen_visible_length;

    = fdc$page_data_backward =

{ Shift data backward the size of the object.

      shift := - screen_visible_length;
    = fdc$scroll_data_forward =

{ Compute shift needed to move character under cursor to first position in object.

      shift := target_position.data_index - p_form_object_statuses^ [field_object_index].character_position;

   = fdc$scroll_data_backward =

{ Compute shift needed to move character under cursor to last position in object.

      shift := p_form_object_statuses^ [field_object_index].character_position + screen_visible_length
              - 1 - target_position.data_index;
      shift := -shift;

    = fdc$current_data_position =
      shift := 0;

    = fdc$shift_characters =
      shift := target_position.shift;

    ELSE { fdc$top_of_box, fdc$bottom_of_box do not apply.}
      shift := 0;
    CASEND;

    position := p_form_object_statuses^ [status_object_index].character_position + shift;

{ If shift is past the first character of the text, set to display first character of text.

    IF position < 1 THEN
      position := 1;
    IFEND;


{ If first displayed character position puts the end of the text outside the visible screen
{ area, set the first displayed character position so that end of text is displayed.

    text_length := STRLENGTH (p_text^);
    IF ((position + screen_visible_length - 1) > text_length) THEN
      position := text_length - screen_visible_length + 1;
    IFEND;
    IF position < 1 THEN
      position := 1;
    IFEND;

    p_form_object_statuses^ [status_object_index].character_position := position;
    formatted_text_length := text_length - position + 1;

{ If hidden editing is specified, give the Screen Manager all of the text the terminal user
{ can edit. The text the terminal user may edit is less than the Screen Manager field length
{ when the text is not at position 1. Screen Formatting cannot resize the Screen Manager field
{ since changes the field priority.  That is a partially hidden field may become completely
{ visibile. When the text the user can modify is shorter than the Screen Manager field length
{ an insert character followed by a delete character will restore the last character.
{ If hidden editing is not specified,
{  give the Screen Manager no more text than the visible length of text object on the screen.

    IF NOT p_form_status^.p_form_definition^.hidden_editing THEN
      IF text_length > screen_visible_length THEN
        formatted_text_length := screen_visible_length;
      IFEND;
    IFEND;

    p_form_object_statuses^ [status_object_index].data_length := formatted_text_length;
    p_screen_text := ^p_text^ (position, formatted_text_length);
    csv$vector.put_text^ (p_screen_text, TRUE, end_of_text, terminal_status);
    IF NOT terminal_status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
    IFEND;

  PROCEND replace_screen_variable;

?? TITLE := 'reset_read_forms_indices', EJECT ??

{ PURPOSE:
{   This procedure resets the read forms index of all variable objects in the form.
{

  PROCEDURE [INLINE] reset_read_forms_indices
    (    form_identifier: fdt$form_identifier);

    VAR
      object_index: fdt$object_index,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_form_status: ^fdt$form_status;

    p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    p_form_object_statuses := p_form_status^.p_form_object_statuses;

    FOR object_index := 1 TO UPPERBOUND (p_form_object_statuses^) DO
      CASE p_form_object_definitions^ [object_index].key OF
      = fdc$form_stored_variable, fdc$form_variable_text, fdc$form_variable_text_box =
        p_form_object_statuses^ [object_index].changed_by_read_forms_index := 0;
      ELSE
      CASEND;
    FOREND;

  PROCEND reset_read_forms_indices;

?? TITLE := 'set_attribute', EJECT ??

  PROCEDURE set_attribute
    (    p_form_status: ^fdt$form_status;
         p_form_variable_definition: ^fdt$form_variable_definition;
         display_attribute_set: fdt$display_attribute_set;
         object_index: fdt$object_index;
         p_form_object_definition: ^fdt$form_object_definition;
     VAR table_shifted: boolean;
     VAR status: ost$status);

    VAR
      first_displayed_occurrence: fdt$occurrence,
      first_stored_occurrence: integer,
      last_displayed_occurrence: fdt$occurrence,
      occurrence_shift: integer,
      p_form_module: ^fdt$form_module,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_form_table_definition: ^fdt$form_table_definition,
      p_table_object: ^fdt$table_object,
      p_table_objects: ^array [1 .. * ] of fdt$table_object,
      p_table_variable: ^fdt$table_variable,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable,
      table_index: fdt$table_index,
      variable_index: fdt$variable_index;

    table_shifted := FALSE;
    status.normal := TRUE;
    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    IF NOT p_form_variable_definition^.table_exists THEN

{ The variable does not belong to a table.

      put_text_attribute (p_form_object_statuses^ [object_index].field_number, display_attribute_set,
            p_form_variable_definition^.io_mode, status);
      RETURN;
    IFEND;

{ The variable is a member of a table.

    table_index := p_form_variable_definition^.table_index;
    p_form_table_definition := ^p_form_status^.p_form_table_definitions^ [table_index];
    first_displayed_occurrence := p_form_status^.p_form_table_statuses^ [table_index].
          first_displayed_occurrence;
    last_displayed_occurrence := first_displayed_occurrence + p_form_table_definition^.visible_occurrence - 1;
    IF ((p_form_object_definition^.occurrence < first_displayed_occurrence) OR
          (p_form_object_definition^.occurrence > last_displayed_occurrence)) THEN
      first_stored_occurrence := p_form_object_definition^.occurrence -
            (p_form_table_definition^.visible_occurrence DIV 2);
      occurrence_shift := first_stored_occurrence - first_displayed_occurrence;
      shift_table (p_form_status, p_form_table_definition, table_index, occurrence_shift, 0, status);
      first_displayed_occurrence := p_form_status^.p_form_table_statuses^ [table_index].
            first_displayed_occurrence;
      table_shifted := TRUE;
    ELSE

{ Do not shift the variables in the table when the object is visible so that
{ the screen changes to
{ the terminal user are minimized.

      p_form_module := p_form_status^.p_form_module;
      p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables, p_form_module);

    /find_variable/
      FOR variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
        p_table_variable := ^p_table_variables^ [variable_index];
        IF p_table_variable^.name = p_form_object_definition^.name THEN
          EXIT /find_variable/;
        IFEND;
      FOREND /find_variable/;

      p_table_objects := fdp$ptr_table_objects (p_table_variable^.table_objects, p_form_module);
      p_table_object := ^p_table_objects^ [p_form_object_definition^.occurrence - first_displayed_occurrence +
            1];
      put_text_attribute (p_form_object_statuses^ [p_table_object^.object_index].field_number,
            display_attribute_set, p_form_variable_definition^.io_mode, status);
    IFEND;
  PROCEND set_attribute;

?? TITLE := 'set_table_cursor_position', EJECT ??

  PROCEDURE set_table_cursor_position
    (    p_form_status: ^fdt$form_status;
         p_form_variable_definition: ^fdt$form_variable_definition;
         p_form_object_definition: ^fdt$form_object_definition;
     VAR cursor_object_index: fdt$object_index;
     VAR cursor_character_position: fdt$character_position;
     VAR table_shifted: boolean;
     VAR status: ost$status);

    VAR
      character_position: cst$character_position,
      first_displayed_occurrence: fdt$occurrence,
      first_object_index: fdt$object_index,
      first_stored_occurrence: integer,
      last_displayed_occurrence: fdt$occurrence,
      line_number: cst$line_number,
      object_index: fdt$object_index,
      occurrence_shift: integer,
      p_first_object_definition: ^fdt$form_object_definition,
      p_form_module: ^fdt$form_module,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_form_table_definition: ^fdt$form_table_definition,
      p_table_object: ^fdt$table_object,
      p_table_objects: ^array [1 .. * ] of fdt$table_object,
      p_table_variable: ^fdt$table_variable,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable,
      table_index: fdt$table_index,
      terminal_status: ost$status,
      variable_index: fdt$variable_index,
      variable_name: ost$name,
      variable_shift: integer,
      width: fdt$width;

?? NEWTITLE := 'set_invalid_cursor_position', EJECT??
    PROCEDURE set_invalid_cursor_position;
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_occurrence, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            $INTEGER (p_form_object_definition^.occurrence), 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            p_form_object_definition^.name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            p_form_status^.p_form_definition^.form_name, status);
    PROCEND set_invalid_cursor_position;

?? OLDTITLE, EJECT ??

{ Shift table object occurrences to make cursor object visible.
{ Shift text for variable object to make cursor character position visible.

    status.normal := TRUE;
    table_shifted := FALSE;
    table_index := p_form_variable_definition^.table_index;
    variable_name := p_form_variable_definition^.name;
    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    p_form_table_definition := ^p_form_status^.p_form_table_definitions^ [table_index];

{ The user may change the table size after setting the cursor position.
{ Check to make sure the cursor is within the active size of the table.

    IF p_form_object_definition^.occurrence >
          p_form_status^.p_form_table_statuses^[table_index].last_active_occurrence THEN
      set_invalid_cursor_position;
      RETURN;
    IFEND;

    first_displayed_occurrence := p_form_status^.p_form_table_statuses^ [table_index].
          first_displayed_occurrence;
    first_stored_occurrence := first_displayed_occurrence;
    last_displayed_occurrence := first_displayed_occurrence + p_form_table_definition^.visible_occurrence - 1;
    p_form_module := p_form_status^.p_form_module;
    p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables, p_form_module);

{ Find objects for variable definition.

  /find_variable/
    FOR variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
      p_table_variable := ^p_table_variables^ [variable_index];
      IF p_table_variable^.name = variable_name THEN
        EXIT /find_variable/;
      IFEND;
    FOREND /find_variable/;

    p_table_objects := fdp$ptr_table_objects (p_table_variable^.table_objects, p_form_module);
    first_object_index := p_table_objects^ [1].object_index;
    p_first_object_definition := ^p_form_status^.p_form_object_definitions^ [first_object_index];
    width := p_first_object_definition^.text_variable_width;
    compute_cursor_shift (width,
          p_form_object_statuses^ [cursor_object_index].character_position, cursor_character_position,
          variable_shift);
    IF variable_shift <> 0 THEN
      table_shifted := TRUE;

{ The variables must be shifted left or right to make the cursor visible to the
{ terminal user.

      occurrence_shift := 0;
    IFEND;
    IF ((p_form_object_definition^.occurrence < first_displayed_occurrence) OR
          (p_form_object_definition^.occurrence > last_displayed_occurrence)) THEN
      table_shifted := TRUE;

{ The table occurrences must be be shifted forward or backward to make the
{ cursor visible to the
{ terminal user.

      first_stored_occurrence := p_form_object_definition^.occurrence -
            (p_form_table_definition^.visible_occurrence DIV 2);
      occurrence_shift := first_stored_occurrence - first_displayed_occurrence;
    IFEND;
    IF table_shifted THEN
      shift_table (p_form_status, p_form_table_definition, table_index, occurrence_shift, variable_shift,
            status);
      first_stored_occurrence := p_form_status^.p_form_table_statuses^ [table_index].
            first_displayed_occurrence;
    IFEND;
    cursor_object_index := p_table_objects^ [p_form_object_definition^.occurrence - first_stored_occurrence +
          1].object_index;
    cursor_character_position := cursor_character_position -
          p_form_object_statuses^ [cursor_object_index].character_position + 1;
    csv$vector.position_cursor^ (p_form_status^.p_form_object_statuses^ [cursor_object_index].
          field_number, cursor_character_position, 1, character_position, line_number, terminal_status);
    IF NOT terminal_status.normal THEN
      set_invalid_cursor_position;
    IFEND;

  PROCEND set_table_cursor_position;

?? TITLE := 'set_text_box_cursor_position', EJECT ??

  PROCEDURE set_text_box_cursor_position
    (    p_form_status: ^fdt$form_status;
         p_text: ^fdt$text;
         object_index: fdt$object_index;
         next_object_index: fdt$object_index;
         text_box_processing: fdt$text_box_processing;
         width: fdt$width;
         height: fdt$height;
         cursor_character_position: fdt$character_position;
     VAR status: ost$status);

    VAR
      character_position: cst$character_position,
      cursor_object_index: fdt$object_index,
      current_object_index: fdt$object_index,
      first_displayed_character: integer,
      first_stored_character: integer,
      last_displayed_character: integer,
      line_number: cst$line_number,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      target_position: fdt$target_position,
      terminal_status: ost$status,
      screen_visible_length: fdt$text_length,
      shift: integer;

{ If cursor position is visible, then do not shift the data in the
{ text box.  Otherwise try to shift the cursor position to the
{ middle of the text box.

    status.normal := TRUE;
    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    first_stored_character := p_form_status^.p_form_object_statuses^ [object_index].character_position;
    first_displayed_character := first_stored_character;
    screen_visible_length := width * height;
    last_displayed_character := first_displayed_character + screen_visible_length - 1;
    IF ((cursor_character_position < first_displayed_character) OR
          (cursor_character_position > last_displayed_character)) THEN

{ Cursor is not visible.
{ Shift stored data to make cursor visible.  Try to put cursor in middle of text box.

      first_stored_character := cursor_character_position - (screen_visible_length DIV 2);
      target_position.key := fdc$shift_characters;
      target_position.shift := first_stored_character - p_form_object_statuses^
            [object_index].character_position;
      format_screen_text (p_text, p_form_status, object_index, next_object_index, text_box_processing, width,
            height, target_position, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Find object that contains the cursor position.

    cursor_object_index := object_index;
    last_displayed_character := p_form_object_statuses^ [object_index].character_position + width - 1;
    current_object_index := next_object_index;

  /find_fragment/
    WHILE current_object_index <> 0 DO
      IF last_displayed_character >= cursor_character_position THEN
        EXIT /find_fragment/;
      IFEND;

      last_displayed_character := last_displayed_character + width;
      cursor_object_index := current_object_index;
      current_object_index := p_form_object_definitions^ [current_object_index].next_fragment_object_index;
    WHILEND /find_fragment/;

    character_position := width - (last_displayed_character - cursor_character_position);
    csv$vector.position_cursor^ (p_form_object_statuses^ [cursor_object_index].field_number,
          character_position, 1, character_position, line_number, terminal_status);
    IF NOT terminal_status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
    IFEND;

  PROCEND set_text_box_cursor_position;


?? TITLE := 'shift_table', EJECT ??

  PROCEDURE shift_table
    (    p_form_status: ^fdt$form_status;
         p_form_table_definition: ^fdt$form_table_definition;
         table_index: fdt$table_index;
         occurrence_shift: integer;
         variable_shift: integer;
     VAR status: ost$status);

    VAR
      next_object_index: fdt$object_index,
      object_index: fdt$object_index,
      occurrence: integer,
      p_form_module: ^fdt$form_module,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_variable_definitions: ^array [1 .. * ] of fdt$form_variable_definition,
      p_screen_record: ^array [1 .. *] of cell,
      p_screen_variable: ^fdt$text,
      p_table_object: ^fdt$table_object,
      p_table_objects: ^array [1 .. * ] of fdt$table_object,
      p_table_variable: ^fdt$table_variable,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable,
      position: integer,
      record_position: fdt$record_position,
      screen_variable_length: fdt$text_length,
      screen_visible_length: fdt$text_length,
      status_object_index: fdt$object_index,
      table_object_index: fdt$object_index,
      target_position: fdt$target_position,
      variable_index: fdt$variable_index,
      screen_object_index: fdt$object_index;

    status.normal := TRUE;

{ Compute first displayed variable occurrence. The first displayed occurrence
{ must not be less than
{ 1.  The last displayed occurrence must not be greater than the number of
{ stored occurrences
{ in the table.

    occurrence := p_form_status^.p_form_table_statuses^ [table_index].first_displayed_occurrence +
          occurrence_shift;
    IF occurrence < 1 THEN
      occurrence := 1;
    ELSEIF (occurrence + p_form_table_definition^.visible_occurrence - 1) >
          p_form_status^.p_form_table_statuses^ [table_index].last_active_occurrence THEN
      occurrence := p_form_status^.p_form_table_statuses^ [table_index].last_active_occurrence -
            p_form_table_definition^.visible_occurrence + 1;
      IF occurrence < 1 THEN
        occurrence := 1;
      IFEND;
    IFEND;

    target_position.key := fdc$shift_characters;
    target_position.shift := variable_shift;
    p_form_status^.p_form_table_statuses^ [table_index].first_displayed_occurrence := occurrence;
    p_form_variable_definitions := p_form_status^.p_form_variable_definitions;
    p_form_module := p_form_status^.p_form_module;
    p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables, p_form_module);
    p_screen_record := p_form_status^.p_screen_record;
    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;


{ Shift text for all objects for all variables in the table.

  /get_next_variable/
    FOR variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
      p_table_variable := ^p_table_variables^ [variable_index];
      p_table_objects := fdp$ptr_table_objects (p_table_variable^.table_objects, p_form_module);
      p_form_variable_definition := ^p_form_variable_definitions^ [p_table_variable^.variable_index];
      screen_variable_length := p_form_variable_definition^.screen_variable_length;
      screen_object_index := 1;

    /shift_object/
      FOR table_object_index := 1 TO p_form_table_definition^.visible_occurrence DO

{ Get object definition for visible object.

        p_table_object := ^p_table_objects^ [table_object_index];
        object_index := p_table_object^.object_index;
        p_form_object_definition := ^p_form_object_definitions^ [object_index];

{ Get stored text to display in visible object.

        p_table_object := ^p_table_objects^ [occurrence + table_object_index - 1];
        status_object_index := p_table_object^.object_index;
        fdp$ptr_screen_variable (p_screen_record,
                p_table_object^.screen_record_position, screen_variable_length, p_screen_variable);
        CASE p_form_object_definition^.key OF

        = fdc$form_variable_text_box =
          next_object_index := p_form_object_definition^.variable_box_fragment_index;
          format_screen_text (p_screen_variable, p_form_status, object_index, next_object_index,
                p_form_object_definition^.variable_box_processing,
                p_form_object_definition^.variable_box_width, p_form_object_definition^.variable_box_height,
                target_position, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        = fdc$form_variable_text =
          target_position.key := fdc$shift_characters;
          target_position.shift := variable_shift;
          replace_screen_variable (p_screen_variable, object_index, object_index,
                p_form_object_definition^.text_variable_width, p_form_status, target_position, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ The text from the stored object may have different display attributes than
{ the visible object.
{ Use attributes of stored object for visible object.

          put_text_attribute (p_form_object_statuses^ [object_index].
                field_number, p_form_object_statuses^ [status_object_index].display_attribute_set,
                p_form_variable_definition^.io_mode, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
        CASEND;
      FOREND /shift_object/;

{ Update current character position for all stored, non-visible occurrences of
{ variable objects.

      IF variable_shift <> 0 THEN
        record_position := p_form_object_statuses^ [object_index].character_position;
        FOR table_object_index := p_form_table_definition^.visible_occurrence +
              1 TO p_form_table_definition^.stored_occurrence DO
          p_form_object_statuses^ [p_table_objects^ [table_object_index].object_index].character_position :=
                record_position;
        FOREND;
      IFEND;
    FOREND /get_next_variable/;

  PROCEND shift_table;

?? TITLE := 'shift_table_variable', EJECT ??

  PROCEDURE shift_table_variable
    (    p_form_status: ^fdt$form_status;
         p_form_variable_definition: ^fdt$form_variable_definition;
         target_position: fdt$target_position;
     VAR status: ost$status);

    VAR
      next_object_index: fdt$object_index,
      object_index: fdt$object_index,
      occurrence: fdt$occurrence,
      p_form_module: ^fdt$form_module,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_table_definition: ^fdt$form_table_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_screen_record: ^array [1 .. *] of cell,
      p_screen_variable: ^fdt$text,
      p_table_object: ^fdt$table_object,
      p_table_objects: ^array [1 .. * ] of fdt$table_object,
      p_table_variable: ^fdt$table_variable,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable,
      position: integer,
      record_position: fdt$record_position,
      screen_variable_length: fdt$text_length,
      screen_visible_length: fdt$text_length,
      status_object_index: fdt$object_index,
      table_index: fdt$table_index,
      table_object_index: fdt$object_index,
      variable_index: fdt$variable_index,
      variable_name: ost$name;

    status.normal := TRUE;
    table_index := p_form_variable_definition^.table_index;
    variable_name := p_form_variable_definition^.name;
    p_form_table_definition := ^p_form_status^.p_form_table_definitions^ [table_index];
    p_form_module := p_form_status^.p_form_module;
    p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables, p_form_module);
    p_screen_record := p_form_status^.p_screen_record;
    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    occurrence := p_form_status^.p_form_table_statuses^ [table_index].first_displayed_occurrence;

{ Find the variable in the table definition to locate the objects related to
{ the variable definition.

  /find_variable/
    FOR variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
      p_table_variable := ^p_table_variables^ [variable_index];
      IF (p_table_variable^.name = variable_name) THEN
        EXIT /find_variable/;
      IFEND;
    FOREND /find_variable/;

    p_table_objects := fdp$ptr_table_objects (p_table_variable^.table_objects, p_form_module);
    screen_variable_length := p_form_variable_definition^.screen_variable_length;

{  Shift all the text in all the visible screen objects related to the variable.

  /shift_variable/
    FOR table_object_index := 1 TO p_form_table_definition^.visible_occurrence DO
      p_table_object := ^p_table_objects^ [table_object_index];

{ Get the visible object definition.

      object_index := p_table_object^.object_index;
      p_form_object_definition := ^p_form_object_definitions^ [object_index];

{ Get the stored text to be displayed in the visible object definition.

      p_table_object := ^p_table_objects^ [occurrence + table_object_index - 1];
      fdp$ptr_screen_variable (p_screen_record,
              p_table_object^.screen_record_position, screen_variable_length, p_screen_variable);
      CASE p_form_object_definition^.key OF

      = fdc$form_variable_text_box =
        next_object_index := p_form_object_definition^.variable_box_fragment_index;
        format_screen_text (p_screen_variable, p_form_status, object_index, next_object_index,
              p_form_object_definition^.variable_box_processing, p_form_object_definition^.variable_box_width,
              p_form_object_definition^.variable_box_height, target_position, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = fdc$form_variable_text =
        replace_screen_variable (p_screen_variable, object_index, object_index,
              p_form_object_definition^.text_variable_width, p_form_status, target_position, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSE
      CASEND;
    FOREND /shift_variable/;

{ Update current character position for all stored, non-visible occurrences of
{ the objects for the variable. The terminal user may later page to see these objects.

    IF target_position.key = fdc$shift_characters THEN
      record_position := p_form_object_statuses^ [object_index].character_position;
      FOR table_object_index := p_form_table_definition^.visible_occurrence +
            1 TO p_form_table_definition^.stored_occurrence DO
        p_form_object_statuses^ [p_table_objects^ [table_object_index].object_index].character_position :=
              record_position;
      FOREND;
    IFEND;
  PROCEND shift_table_variable;

?? TITLE := 'shift_text_box', EJECT ??

  PROCEDURE shift_text_box
    (    p_text: ^fdt$text;
         p_form_status: ^fdt$form_status;
         parent_object_index: fdt$object_index;
         next_object_index: fdt$object_index;
         text_box_processing: fdt$text_box_processing;
         width: fdt$width;
         height: fdt$height;
         cursor_object_index: fdt$object_index;
         character_position: cst$character_position;
         target_position: fdt$target_position;
     VAR status: ost$status);

    VAR
      form_identifier: fdt$form_identifier,
      line_number: cst$line_number,
      output_character_position: cst$character_position,
      terminal_status: ost$status;

    format_screen_text (p_text, p_form_status, parent_object_index, next_object_index, text_box_processing,
          width, height, target_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Delete any previous scheduled formatting due to insertion or deletions of characters.

    form_identifier :=  1 + ((#OFFSET (p_form_status) - #OFFSET (fdv$screen_status.p_forms_status))
          DIV #SIZE (fdt$form_status));
    delete_format_screen_change (form_identifier, parent_object_index);

{ Screen Formatting has moved the cursor. Reposition the cursor to where the terminal user
{ caused the event.

    csv$vector.position_cursor^ (p_form_status^.p_form_object_statuses^ [cursor_object_index].
          field_number, character_position, 1, output_character_position, line_number, terminal_status);
    IF NOT terminal_status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
    IFEND;
  PROCEND shift_text_box;

?? TITLE := 'shift_text_line', EJECT ??

  PROCEDURE shift_text_line
    (    target_position: fdt$target_position;
         p_text: ^fdt$text;
         object_index: fdt$object_index;
         screen_visible_length: fdt$text_length;
         p_form_status: ^fdt$form_status;
         character_position: cst$character_position;
     VAR status: ost$status);

    VAR
      line_number: cst$line_number,
      output_character_position: cst$character_position,
      terminal_status: ost$status;

    replace_screen_variable (p_text, object_index, object_index, screen_visible_length,
          p_form_status, target_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    csv$vector.position_cursor^ (p_form_status^.p_form_object_statuses^ [object_index].field_number,
          character_position, 1, output_character_position, line_number, terminal_status);
    IF NOT terminal_status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
    IFEND;

  PROCEND shift_text_line;

?? TITLE := 'shift_variable', EJECT ??
{ PURPOSE:
{   This procedure shifts a variable.  The shift may be caused by either paging or scrolling
{   events.  The procedure handles a variable that is not a member of a table and a
{   variable that is a member of a table.  Both variable text and variable text box objects are
{   handled.

  PROCEDURE shift_variable
    (    p_form_status: ^fdt$form_status;
         p_form_variable_definition: ^fdt$form_variable_definition;
         object_index: fdt$object_index;
         cursor_object_index: fdt$object_index;
         screen_visible_length: fdt$screen_variable_length;
         target_position: fdt$target_position;
     VAR status: ost$status);

    VAR
      character_position: cst$character_position,
      line_number: cst$line_number,
      p_form_object_definition: ^fdt$form_object_definition,
      p_text: ^fdt$text,
      terminal_status: ost$status;

    IF NOT p_form_variable_definition^.table_exists THEN

{ This is a variable that does not belong to a table.

     fdp$ptr_screen_variable (p_form_status^.p_screen_record,
           p_form_variable_definition^.screen_record_position,
           p_form_variable_definition^.screen_variable_length, p_text);
     p_form_object_definition := ^p_form_status^.p_form_object_definitions^ [object_index];
     IF p_form_object_definition^.key = fdc$form_variable_text THEN
       shift_text_line (target_position, p_text, object_index, screen_visible_length, p_form_status,
             fdv$screen_status.event_identifier.field_event_character_position, status);
     ELSE
       shift_text_box (p_text, p_form_status, object_index,
             p_form_object_definition^.variable_box_fragment_index,
             p_form_object_definition^.variable_box_processing,
             p_form_object_definition^.variable_box_width,
             p_form_object_definition^.variable_box_height, cursor_object_index,
             fdv$screen_status.event_identifier.field_event_character_position,
             target_position, status);
      IFEND;
      RETURN;
    IFEND;

{ This is a table variable, find the associated object list and scroll all of them.

    shift_table_variable (p_form_status, p_form_variable_definition, target_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    csv$vector.position_cursor^ (p_form_status^.p_form_object_statuses^ [cursor_object_index].
          field_number, fdv$screen_status.event_identifier.field_event_character_position, 1,
          character_position, line_number, terminal_status);
    IF NOT terminal_status.normal THEN
      fdp$convert_terminal_status (terminal_status, status);
    IFEND;

  PROCEND shift_variable;

?? TITLE := 'tab_to_previous_variable', EJECT ??

{ PURPOSE:
{   This procedure positions the cursor to first variable field previous to it on the terminal screen.
{

  PROCEDURE [XDCL] tab_to_previous_variable
    (    p_form_status: ^fdt$form_status;
         object_index: fdt$object_index;
     VAR status: ost$status);

    VAR
      end_object_index: fdt$object_index,
      ignore_character_position: cst$character_position,
      ignore_line_number: cst$line_number,
      next_object_index: fdt$object_index,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_variable_definitions: ^array [1 .. * ] of fdt$form_variable_definition,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_parent_object_definition: ^fdt$form_object_definition,
      start_object_index: fdt$object_index,
      terminal_status: ost$status;

?? NEWTITLE := 'check_variable', EJECT ??

{ PURPOSE:
{   This procedure verifies that the variable field is a valid input field and positions the cursor to it.
{ NOTES:
{   The field must be an input field and it must not be covered by another form.

    PROCEDURE [INLINE] check_variable;

      IF ((p_form_variable_definition^.io_mode = fdc$terminal_input) OR
            (p_form_variable_definition^.io_mode = fdc$terminal_input_output)) AND
            (NOT (fdc$protect IN
            p_form_status^.p_form_object_statuses^ [next_object_index].display_attribute_set)) AND
            (NOT location_covered_by_form (p_form_status, p_form_object_definition^.x_position +
            p_form_status^.form_x_position - 1, p_form_object_definition^.y_position +
            p_form_status^.form_y_position - 1)) THEN
        csv$vector.position_cursor^ (p_form_status^.p_form_object_statuses^ [next_object_index].field_number,
              1, 1, ignore_character_position, ignore_line_number, terminal_status);
        IF NOT terminal_status.normal THEN
          fdp$convert_terminal_status (terminal_status, status);
        IFEND;
        fdv$screen_status.cursor_set := TRUE;
        EXIT tab_to_previous_variable;
      IFEND;

    PROCEND check_variable;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'search_object_definitions', EJECT ??

{ PURPOSE:
{   This procedure finds the previous input variable in the form.
{ DESIGN:
{   The procedure searches the object definitions which are ordered by location.
{ NOTES:
{   Tabbing can only occur to a variable that has an input or input/output mode.

    PROCEDURE [INLINE] search_object_definitions;


      FOR next_object_index := start_object_index DOWNTO end_object_index DO
        p_form_object_definition := ^p_form_object_definitions^ [next_object_index];
        CASE p_form_object_definition^.key OF

        = fdc$form_variable_text =
          p_form_variable_definition := ^p_form_variable_definitions^
                [p_form_object_definition^.text_variable_index];
          check_variable;

{ If the variable checks out, a non-local EXIT is performed and control does not return here.

        = fdc$form_variable_text_box =
          p_form_variable_definition := ^p_form_variable_definitions^
                [p_form_object_definition^.variable_box_variable_index];
          check_variable;

{ If the variable checks out, a non-local EXIT is performed and control does not return here.

        = fdc$form_text_box_fragment =
          p_parent_object_definition := ^p_form_object_definitions^
                [p_form_object_definition^.parent_text_box_object_index];
          IF (p_parent_object_definition^.key = fdc$form_variable_text_box) THEN
            p_form_variable_definition := ^p_form_variable_definitions^
                  [p_parent_object_definition^.variable_box_variable_index];
            check_variable;

{ If the variable checks out, a non-local EXIT is performed and control does not return here.

          IFEND;
        ELSE

{ Other objects are ignored.

        CASEND;
      FOREND;

    PROCEND search_object_definitions;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    p_form_variable_definitions := p_form_status^.p_form_variable_definitions;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;

    end_object_index := 1;
    IF object_index <= p_form_status^.p_form_definition^.form_object_definitions.active_number THEN
      start_object_index := object_index;
      search_object_definitions;

{ If the previous variable is found, a non-local EXIT is performed and control does not return here.

      end_object_index := start_object_index;
    IFEND;

{ Wrap around to end of form and then try to find an input field.

    start_object_index := p_form_status^.p_form_definition^.form_object_definitions.active_number;
    search_object_definitions;

{ No input variable was found in the form.  The cursor position is not changed and no error is generated.

  PROCEND tab_to_previous_variable;

?? TITLE := 'update_program_record', EJECT ??

  PROCEDURE update_program_record
    (    p_form_status: ^fdt$form_status;
         form_identifier: fdt$form_identifier;
     VAR status: ost$status);

    VAR
      object_index: fdt$object_index,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_object_definitions: ^array [1 .. * ] of fdt$form_object_definition,
      p_form_object_status: ^fdt$form_object_status,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_form_table_definitions: ^array [1 .. * ] of fdt$form_table_definition,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_variable_definitions: ^array [1 .. * ] of fdt$form_variable_definition,
      variable_status: fdt$variable_status;

    status.normal := TRUE;
    variable_status := fdc$no_error;
    p_form_variable_definitions := p_form_status^.p_form_variable_definitions;
    p_form_object_definitions := p_form_status^.p_form_object_definitions;
    p_form_object_statuses := p_form_status^.p_form_object_statuses;
    IF p_form_object_statuses = NIL THEN
      RETURN;
    IFEND;

  /find_record_changes/
    FOR object_index := LOWERBOUND (p_form_object_statuses^) TO UPPERBOUND (p_form_object_statuses^) DO
      p_form_object_status := ^p_form_object_statuses^ [object_index];
      CASE p_form_object_status^.key OF

      = fdc$field_identifier, fdc$unused_identifier =
        IF NOT p_form_object_status^.user_changed_field THEN
          CYCLE /find_record_changes/;
        IFEND;

        p_form_object_definition := ^p_form_object_definitions^ [object_index];
        CASE p_form_object_definition^.key OF

        = fdc$form_variable_text =
          IF p_form_object_definition^.text_variable_exists THEN
            p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                  [p_form_object_definition^.text_variable_index];
            update_variable (p_form_status, form_identifier, p_form_variable_definition,
                  p_form_object_definition, object_index, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF fdv$screen_status.message_form_displayed THEN
              RETURN;
            IFEND;
          IFEND;
          p_form_object_status^.user_changed_field := FALSE;

        = fdc$form_stored_variable =
          IF p_form_object_definition^.stored_variable_exists THEN
            p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                  [p_form_object_definition^.stored_variable_index];
            update_variable (p_form_status, form_identifier, p_form_variable_definition,
                  p_form_object_definition, object_index, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF fdv$screen_status.message_form_displayed THEN
              RETURN;
            IFEND;
          IFEND;
          p_form_object_status^.user_changed_field := FALSE;

        = fdc$form_variable_text_box =
          IF p_form_object_definition^.variable_box_variable_exists THEN
            p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                  [p_form_object_definition^.variable_box_variable_index];
            update_variable (p_form_status, form_identifier, p_form_variable_definition,
                  p_form_object_definition, object_index, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF fdv$screen_status.message_form_displayed THEN
              RETURN;
            IFEND;
          IFEND;
          p_form_object_status^.user_changed_field := FALSE;

        ELSE { Ignore other object definitions. }
        CASEND;
      ELSE { Ignore other status identifiers. }
      CASEND;
    FOREND /find_record_changes/;

  /check_must_enter/
    FOR object_index := LOWERBOUND (p_form_object_statuses^) TO UPPERBOUND (p_form_object_statuses^) DO
      p_form_object_status := ^p_form_object_statuses^ [object_index];
      CASE p_form_object_status^.key OF

      = fdc$field_identifier, fdc$unused_identifier =
        IF p_form_object_status^.user_entered_field THEN
          CYCLE /check_must_enter/;
        IFEND;

        p_form_object_definition := ^p_form_object_definitions^ [object_index];
        CASE p_form_object_definition^.key OF

        = fdc$form_variable_text =
          IF p_form_object_definition^.text_variable_exists THEN
            p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                  [p_form_object_definition^.text_variable_index];
            IF fdc$must_enter IN p_form_variable_definition^.terminal_user_entry THEN
              display_variable_error (p_form_status, form_identifier,
                    p_form_variable_definition, object_index, p_form_object_definition^.occurrence,
                    status);
              RETURN;
            IFEND;
          IFEND;

        = fdc$form_stored_variable =
          IF p_form_object_definition^.stored_variable_exists THEN
            p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                  [p_form_object_definition^.stored_variable_index];
            IF fdc$must_enter IN p_form_variable_definition^.terminal_user_entry THEN
              display_variable_error (p_form_status, form_identifier,
                    p_form_variable_definition, object_index, p_form_object_definition^.occurrence,
                    status);
              RETURN;
            IFEND;
          IFEND;

        = fdc$form_variable_text_box =
          IF p_form_object_definition^.variable_box_variable_exists THEN
            p_form_variable_definition := ^p_form_status^.p_form_variable_definitions^
                  [p_form_object_definition^.variable_box_variable_index];
            IF fdc$must_enter IN p_form_variable_definition^.terminal_user_entry THEN
              display_variable_error (p_form_status, form_identifier,
                    p_form_variable_definition, object_index, p_form_object_definition^.occurrence,
                    status);
              RETURN;
            IFEND;
          IFEND;

        ELSE { Ignore other object definitions. }
        CASEND;
      ELSE { Ignore other status identifiers. }
      CASEND;
    FOREND /check_must_enter/;

  PROCEND update_program_record;

?? TITLE := 'update_variable', EJECT ??

  PROCEDURE update_variable
    (    p_form_status: ^fdt$form_status;
         form_identifier: fdt$form_identifier;
         p_form_variable_definition: ^fdt$form_variable_definition;
         p_form_object_definition: ^fdt$form_object_definition;
         object_index: fdt$object_index;
     VAR status: ost$status);

    VAR
      error: mlt$error,
      ignore_date_time: clt$date_time,
      integer_number: integer,
      p_form_table_definition: ^fdt$form_table_definition,
      p_formatted_screen_variable: ^fdt$text,
      p_program_variable: ^cell,
      p_screen_variable: ^fdt$text,
      p_table_objects: ^array [1 .. * ] of fdt$table_object,
      p_table_variable: ^fdt$table_variable,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable,
      p_text: ^fdt$text,
      p_valid_string: ^fdt$valid_string,
      previous_character_space: boolean,
      program_record_position: fdt$record_position,
      program_variable_length: fdt$program_variable_length,
      real_number: real,
      screen_index: fdt$text_length,
      screen_record_position: fdt$record_position,
      screen_variable_length: fdt$text_length,
      separator_index: fdt$text_length,
      table_index: fdt$table_index,
      variable_index: fdt$variable_index,
      variable_name: ost$name,
      variable_status: fdt$variable_status;

    status.normal := TRUE;
    variable_status := fdc$no_error;
    program_variable_length := p_form_variable_definition^.program_variable_length;
    screen_variable_length := p_form_variable_definition^.screen_variable_length;

{ Determine variable position in screen record and program record.

    IF p_form_variable_definition^.table_exists THEN
      table_index := p_form_variable_definition^.table_index;
      p_form_table_definition := ^p_form_status^.p_form_table_definitions^ [table_index];
      variable_name := p_form_variable_definition^.name;
      p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
            p_form_status^.p_form_module);

    /find_variable/
      FOR variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
        p_table_variable := ^p_table_variables^ [variable_index];
        IF p_table_variable^.name = variable_name THEN
          p_table_objects := fdp$ptr_table_objects (p_table_variable^.table_objects,
                p_form_status^.p_form_module);
          program_record_position := p_table_objects^ [p_form_object_definition^.occurrence].
                program_record_position;
          screen_record_position := p_table_objects^ [p_form_object_definition^.occurrence].
                screen_record_position;
          EXIT /find_variable/;
        IFEND;
      FOREND /find_variable/;

    ELSE

{ The variable is not a member of a table.

      program_record_position := p_form_variable_definition^.program_record_position;
      screen_record_position := p_form_variable_definition^.screen_record_position;
    IFEND;

    fdp$ptr_screen_variable (p_form_status^.p_screen_record,
          screen_record_position, screen_variable_length, p_screen_variable);

{ Remove the record separator from a variable text box with word wrap for data transfered to
{ the application program.  The record separator was used to insert a line of spaces.
{ Keep the record separator in the screen variable so the terminal user can still see the
{ inserted line.  Also remove extra spaces.  The terminal user's editing tends to
{ cause extra spaces at the end of a line.

    IF ((p_form_object_definition^.key = fdc$form_variable_text_box) AND
          (p_form_object_definition^.variable_box_processing = fdc$wrap_words)) THEN
      screen_index := 0;
      PUSH p_formatted_screen_variable: [screen_variable_length];
      previous_character_space := FALSE;
      /format_program_data/
        FOR separator_index := 1 TO screen_variable_length DO
          IF p_screen_variable^ (separator_index, 1) <> record_separator THEN
            IF (p_screen_variable^ (separator_index, 1) = ' ') THEN
              IF previous_character_space THEN
                CYCLE /format_program_data/;
              IFEND;
              previous_character_space := TRUE;
              screen_index := screen_index + 1;
              p_formatted_screen_variable^ (screen_index, 1) := p_screen_variable^
                    (separator_index, 1);
              CYCLE /format_program_data/;
            IFEND;
            previous_character_space := FALSE;
            screen_index := screen_index + 1;
            p_formatted_screen_variable^ (screen_index, 1) := p_screen_variable^ (separator_index, 1);
          IFEND;
        FOREND /format_program_data/;

{ Space fill to end of screen variable.

      IF screen_index < separator_index THEN
        p_formatted_screen_variable^ (screen_index + 1, *) := '';
      IFEND;
      p_screen_variable := p_formatted_screen_variable;
    IFEND;

{ Convert character screen data to program data type.

    p_program_variable := ^p_form_status^.p_program_record^ [program_record_position];
    fdp$move_to_program_variable (p_form_status, p_form_variable_definition,
          p_screen_variable, p_program_variable, variable_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    p_form_status^.p_form_object_statuses^ [object_index].variable_input_status := variable_status;

{ The output status is now obsolete.

    p_form_status^.p_form_object_statuses^ [object_index].variable_output_status := fdc$no_error;

{ If character data entered by terminal user could not be converted to
{ program data type, display error message (if error message exists).

    IF variable_status <> fdc$no_error THEN
      display_variable_error (p_form_status, form_identifier, p_form_variable_definition, object_index,
            p_form_object_definition^.occurrence, status);
      RETURN;
    IFEND;

{ Check terminal user input for valid values.

    CASE p_form_variable_definition^.program_data_type OF

    = fdc$program_character_type, fdc$program_upper_case_type =
      fdp$ptr_screen_variable (p_form_status^.p_program_record,
            program_record_position, program_variable_length, p_text);
      fdp$validate_string (p_text, program_variable_length, p_form_variable_definition^.valid_strings,
            p_form_status, p_valid_string, variable_status);
      IF variable_status <> fdc$no_error THEN
        p_form_status^.p_form_object_statuses^ [object_index].variable_input_status := variable_status;
        display_variable_error (p_form_status, form_identifier, p_form_variable_definition, object_index,
              p_form_object_definition^.occurrence, status);
        RETURN;

      ELSE
        IF p_valid_string <> NIL THEN
          mlp$move_bytes (p_valid_string, STRLENGTH (p_valid_string^), p_program_variable,
                program_variable_length, error);
        IFEND;
      IFEND;

    = fdc$program_integer_type =
      i#move (p_program_variable, ^integer_number, fdc$integer_length);
      IF fdp$date_variable(p_form_variable_definition) THEN
        fdp$convert_yymmdd_to_date_time (integer_number, ignore_date_time, variable_status);
        IF (integer_number = 0) AND (fdc$must_enter IN p_form_variable_definition^.terminal_user_entry) THEN
          variable_status := fdc$invalid_integer;
        IFEND;
      ELSE
      fdp$validate_integer (integer_number, p_form_variable_definition^.valid_integer_ranges, p_form_status,
            variable_status);
      IFEND;
      IF variable_status <> fdc$no_error THEN
        p_form_status^.p_form_object_statuses^ [object_index].variable_input_status := variable_status;
        display_variable_error (p_form_status, form_identifier, p_form_variable_definition, object_index,
              p_form_object_definition^.occurrence, status);
        RETURN;
      IFEND;

    = fdc$program_real_type =
      i#move (p_program_variable, ^real_number, fdc$real_length);
      fdp$validate_real (real_number, p_form_variable_definition^.valid_real_ranges, p_form_status,
            variable_status);
      IF variable_status <> fdc$no_error THEN
        p_form_status^.p_form_object_statuses^ [object_index].variable_input_status := variable_status;
        display_variable_error (p_form_status, form_identifier, p_form_variable_definition, object_index,
              p_form_object_definition^.occurrence, status);
        RETURN;
      IFEND;

    ELSE {fdc$program_cobol_type

      fdp$validate_cobol_data (p_form_status, p_form_variable_definition,
            p_program_variable, p_valid_string, variable_status);
      IF variable_status <> fdc$no_error THEN
        p_form_status^.p_form_object_statuses^ [object_index].variable_input_status := variable_status;
        display_variable_error (p_form_status, form_identifier, p_form_variable_definition, object_index,
              p_form_object_definition^.occurrence, status);
        RETURN;

      ELSE {No error for variable_status
        IF p_valid_string <> NIL THEN
          mlp$move_bytes (p_valid_string, STRLENGTH (p_valid_string^), p_program_variable,
                program_variable_length, error);
        IFEND;
      IFEND;
    CASEND;

  PROCEND update_variable;

MODEND fdm$process_screen_input_output;
*DECK DECK=FDM$PROCESS_TABLE EXPAND=TRUE

?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Screen Formatting: Process Table' ??
MODULE fdm$process_table;

{ PURPOSE:
{   This module creates, changes, gets data about a form table definition.
{
{ DESIGN:
{   Do not make any changes to a form table definitions if any of the changes
{   are not valid.
{
{ NOTES:
{   All external procedures appear first in alphabetical order.  Then all
{   procedures used by this module.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc cyd$run_time_error_condition
*copyc fdc$system_occurrence
*copyc fde$condition_identifiers
*copyc fdt$form_definition
*copyc fdt$form_identifier
*copyc fdt$form_module
*copyc fdt$form_object_definition
*copyc fdt$form_status
*copyc fdt$form_table_definition
*copyc fdt$form_variable_definition
*copyc fdt$get_table_attributes
*copyc fdt$number_table_variables
*copyc fdt$number_tables
*copyc fdt$table_attribute_index
*copyc fdt$table_attributes
*copyc fdt$table_index
*copyc fdt$table_variable_index
*copyc fdt$table_variable
*copyc fdt$table_variables
*copyc fdt$variable_index
*copyc ost$name
?? POP ??

*copyc fdp$find_change_form_definition
*copyc fdp$find_form_definition
*copyc fdp$find_table_definition
*copyc fdp$find_variable_definition
*copyc fdp$ptr_table_variables
*copyc fdp$rel_table_objects
*copyc fdp$rel_table_variables
*copyc fdp$rel_tables
*copyc fdp$validate_name
*copyc pmp$continue_to_cause
*copyc osp$append_status_parameter
*copyc osp$append_status_integer
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    fdc$tables_to_expand = 2,
    fdc$table_variables_to_expand = 4;

?? TITLE := 'fdp$change_table', EJECT ??
*copyc fdh$change_table

  PROCEDURE [XDCL] fdp$change_table
    (    form_identifier: fdt$form_identifier;
         table_name: ost$name;
     VAR table_attributes: fdt$table_attributes;
     VAR status: ost$status);

    VAR
      name_exists: boolean,
      name_is_valid: boolean,
      form_table_definition: fdt$form_table_definition,
      p_form_definition: ^fdt$form_definition,
      p_form_status: ^fdt$form_status,
      p_form_table_definition: ^fdt$form_table_definition,
      table_index: fdt$table_index,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$change_table;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$change_table;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    FOR table_index := LOWERBOUND (table_attributes) TO UPPERBOUND (table_attributes) DO
      table_attributes [table_index].put_value_status := fdc$unprocessed_put_value;
    FOREND;

    fdp$find_change_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    fdp$validate_name (table_name, p_form_definition^.processor, valid_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_table_name, table_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    fdp$find_table_definition (valid_name, p_form_status^.p_form_table_definitions,
          p_form_definition^.form_table_definitions.active_number, p_form_table_definition, table_index,
          name_exists);
    IF NOT name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_table_name, table_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

{ Work on copy of table definition so that no bad changes occur to stored table definition.

    form_table_definition := p_form_table_definition^;
    change_table (p_form_status, ^form_table_definition, table_attributes, status);

{ If all changes are good, then update stored table definition.

    IF status.normal THEN
      p_form_table_definition^ := form_table_definition;
    IFEND;

  PROCEND fdp$change_table;

?? TITLE := 'fdp$create_table', EJECT ??
*copyc fdh$create_table

  PROCEDURE [XDCL] fdp$create_table
    (    form_identifier: fdt$form_identifier;
         table_name: ost$name;
     VAR table_attributes: fdt$table_attributes;
     VAR status: ost$status);

    VAR
      form_table_definition: fdt$form_table_definition,
      name_exists: boolean,
      name_is_valid: boolean,
      p_form_definition: ^fdt$form_definition,
      p_form_status: ^fdt$form_status,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_table_definition: ^fdt$form_table_definition,
      p_form_variable_definition: ^fdt$form_variable_definition,
      table_index: fdt$table_index,
      valid_name: ost$name,
      variable_index: fdt$variable_index;

?? NEWTITLE := 'allocate_table', EJECT ??

    PROCEDURE [INLINE] allocate_table
      (VAR p_form_table_definition: ^fdt$form_table_definition);

      VAR
        i: fdt$table_index,
        number_tables: fdt$number_tables,
        p_new_table_definitions: ^array [1 .. * ] of fdt$form_table_definition,
        p_old_table_definitions: ^array [1 .. * ] of fdt$form_table_definition;

      p_old_table_definitions := p_form_status^.p_form_table_definitions;
      IF p_old_table_definitions = NIL THEN
        NEXT p_new_table_definitions: [1 .. fdc$tables_to_expand] IN p_form_status^.p_form_module;
        IF p_new_table_definitions = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
          RETURN;
        IFEND;

        fdp$rel_tables (p_new_table_definitions, p_form_status);
        p_form_table_definition := ^p_new_table_definitions^ [1];
        p_form_definition^.form_table_definitions.active_number := 1;
        RETURN;
      IFEND;

{ An array for tables exists. Try to find an inactive entry.
{ Minimize number of allocations for table space.

      number_tables := p_form_definition^.form_table_definitions.active_number;
      IF number_tables < p_form_definition^.form_table_definitions.total_number THEN
        number_tables := number_tables + 1;
        p_form_definition^.form_table_definitions.active_number := number_tables;
        p_form_table_definition := ^p_old_table_definitions^ [number_tables];
        RETURN;
      IFEND;

{ Expand the array for tables.

      NEXT p_new_table_definitions: [1 .. fdc$tables_to_expand + number_tables] IN
            p_form_status^.p_form_module;
      IF p_new_table_definitions = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

{ Copy old tables to new array.

      FOR i := 1 TO number_tables DO
        p_new_table_definitions^ [i] := p_old_table_definitions^ [i];
      FOREND;

      fdp$rel_tables (p_new_table_definitions, p_form_status);
      number_tables := number_tables + 1;
      p_form_definition^.form_table_definitions.active_number := number_tables;
      p_form_table_definition := ^p_new_table_definitions^ [number_tables];
    PROCEND allocate_table;

?? OLDTITLE ??
?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$create_table;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$create_table;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    FOR table_index := LOWERBOUND (table_attributes) TO UPPERBOUND (table_attributes) DO
      table_attributes [table_index].put_value_status := fdc$unprocessed_put_value;
    FOREND;

    fdp$find_change_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    fdp$validate_name (table_name, p_form_definition^.processor, valid_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_table_name, table_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

{ The new table name must not currently exist as a table name or a variable name.

    fdp$find_table_definition (valid_name, p_form_status^.p_form_table_definitions,
          p_form_definition^.form_table_definitions.active_number, p_form_table_definition, table_index,
          name_exists);
    IF name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$table_name_exists, table_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    fdp$find_variable_definition (valid_name, p_form_status^.p_form_variable_definitions,
          p_form_definition^.form_variable_definitions.active_number, p_form_variable_definition,
          variable_index, name_exists);
    IF name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$table_name_exists, table_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

{ Set table definition default values.

    form_table_definition.access_all_occurrences := FALSE;
    form_table_definition.name := valid_name;
    form_table_definition.stored_occurrence := fdc$system_occurrence;
    form_table_definition.table_variables.total_number := 0;
    form_table_definition.table_variables.active_number := 0;
    form_table_definition.valid := FALSE;
    form_table_definition.visible_occurrence_defined := FALSE;
    change_table (p_form_status, ^form_table_definition, table_attributes, status);

{ All attributes must be valid to create a table.

    IF status.normal THEN
      allocate_table (p_form_table_definition);
      IF status.normal THEN
        p_form_table_definition^ := form_table_definition;
      IFEND;
    IFEND;
  PROCEND fdp$create_table;

?? TITLE := 'fdp$delete_table', EJECT ??
*copyc fdh$delete_table

  PROCEDURE [XDCL] fdp$delete_table
    (    form_identifier: fdt$form_identifier;
         table_name: ost$name;
     VAR status: ost$status);

    VAR
      name_exists: boolean,
      name_is_valid: boolean,
      p_form_definition: ^fdt$form_definition,
      p_form_status: ^fdt$form_status,
      p_form_table_definition: ^fdt$form_table_definition,
      p_form_table_definitions: ^array [1 .. * ] of fdt$form_table_definition,
      table_index: fdt$table_index,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$delete_table;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$delete_table;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_change_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    fdp$validate_name (table_name, p_form_definition^.processor, valid_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_table_name, table_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    p_form_table_definitions := p_form_status^.p_form_table_definitions;
    fdp$find_table_definition (valid_name, p_form_table_definitions,
          p_form_definition^.form_table_definitions.active_number, p_form_table_definition, table_index,
          name_exists);
    IF NOT name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_table_name, table_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

{ Move last table definition to position occupied by deleted terminal definition.
{ Then decrease number of active terminal definitions to exclude the last terminal defininition.

    p_form_table_definitions^ [table_index] := p_form_table_definitions^
          [p_form_definition^.form_table_definitions.active_number];
    p_form_definition^.form_table_definitions.active_number :=
          p_form_definition^.form_table_definitions.active_number - 1;

  PROCEND fdp$delete_table;

?? TITLE := 'fdp$get_table_attributes', EJECT ??
*copyc fdh$get_table_attributes

  PROCEDURE [XDCL] fdp$get_table_attributes
    (    form_identifier: fdt$form_identifier;
         table_name: ost$name;
     VAR get_table_attributes: fdt$get_table_attributes;
     VAR status: ost$status);

    VAR
      j: fdt$table_index,
      n: fdt$table_attribute_index,
      name_is_valid: boolean,
      name_exists: boolean,
      number_table_variables: fdt$number_table_variables,
      p_form_definition: ^fdt$form_definition,
      p_form_module: ^fdt$form_module,
      p_form_status: ^fdt$form_status,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_table_definition: ^fdt$form_table_definition,
      p_table_variable: ^fdt$table_variable,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable,
      table_index: fdt$table_index,
      valid_name: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_table_attributes;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_table_attributes;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    FOR n := LOWERBOUND (get_table_attributes) TO UPPERBOUND (get_table_attributes) DO
      get_table_attributes [n].get_value_status := fdc$unprocessed_get_value;
    FOREND;

    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    fdp$validate_name (table_name, p_form_definition^.processor, valid_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_table_name, table_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    fdp$find_table_definition (valid_name, p_form_status^.p_form_table_definitions,
          p_form_definition^.form_table_definitions.active_number, p_form_table_definition, table_index,
          name_exists);
    IF NOT name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_table_name, table_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    p_form_module := p_form_status^.p_form_module;
    table_index := 1;
    p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables, p_form_module);

  /return_table_attributes/
    FOR n := LOWERBOUND (get_table_attributes) TO UPPERBOUND (get_table_attributes) DO
      CASE get_table_attributes [n].key OF

      = fdc$get_next_table_variable =
        get_table_attributes [n].get_value_status := fdc$undefined_value;

      /get_table_variable/
        FOR j := table_index TO p_form_table_definition^.table_variables.active_number DO
          get_table_attributes [n].variable_name := p_table_variables^ [j].name;
          get_table_attributes [n].get_value_status := fdc$user_defined_value;
          table_index := j + 1;
          EXIT /get_table_variable/;
        FOREND /get_table_variable/;

      = fdc$get_number_table_variables =
        get_table_attributes [n].get_value_status := fdc$user_defined_value;
        get_table_attributes [n].number_table_variables := p_form_table_definition^.table_variables.
              active_number;

      = fdc$get_stored_occurrence =
        get_table_attributes [n].stored_occurrence := p_form_table_definition^.stored_occurrence;
        IF p_form_table_definition^.stored_occurrence = fdc$system_occurrence THEN
          get_table_attributes [n].get_value_status := fdc$system_default_value;
        ELSE
          get_table_attributes [n].get_value_status := fdc$user_defined_value;
        IFEND;

      = fdc$get_unused_table_entry =
        get_table_attributes [n].get_value_status := fdc$undefined_value;

      = fdc$get_visible_occurrence =
        IF p_form_table_definition^.visible_occurrence_defined THEN
          get_table_attributes [n].visible_occurrence := p_form_table_definition^.visible_occurrence;
          get_table_attributes [n].get_value_status := fdc$user_defined_value;
        ELSE
          get_table_attributes [n].get_value_status := fdc$undefined_value;
        IFEND;

      ELSE

{ Invalid table attribute.

        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_table_attribute,
              p_form_definition^.form_name, status);
        RETURN;

      CASEND;
    FOREND /return_table_attributes/;
  PROCEND fdp$get_table_attributes;

?? TITLE := 'change_table', EJECT ??

  PROCEDURE change_table
    (    p_form_status: ^fdt$form_status;
         p_form_table_definition: ^fdt$form_table_definition;
     VAR table_attributes: fdt$table_attributes;
     VAR status: ost$status);

    VAR
      j: fdt$table_variable_index,
      n: fdt$table_attribute_index,
      name_exists: boolean,
      name_is_valid: boolean,
      valid_name: ost$name,
      p_duplicate_table_definition: ^fdt$form_table_definition,
      p_form_definition: ^fdt$form_definition,
      p_form_module: ^fdt$form_module,
      p_form_table_definitions: ^array [1 .. * ] of fdt$form_table_definition,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_table_variable: ^fdt$table_variable,
      p_table_variables: ^array [1 .. * ] of fdt$table_variable,
      table_index: fdt$table_index,
      table_name: ost$name,
      table_variable_index: fdt$table_variable_index;

?? NEWTITLE := 'allocate_table_variable', EJECT ??

    PROCEDURE [INLINE] allocate_table_variable
      (VAR table_variables: fdt$table_variables;
       VAR p_table_variable: ^fdt$table_variable);

      VAR
        i: fdt$table_variable_index,
        number_table_variables: fdt$number_table_variables,
        p_form_module: ^fdt$form_module,
        p_new_table_variables: ^array [1 .. * ] of fdt$table_variable,
        p_old_table_variables: ^array [1 .. * ] of fdt$table_variable;

      p_form_module := p_form_status^.p_form_module;
      p_old_table_variables := fdp$ptr_table_variables (table_variables, p_form_module);
      IF p_old_table_variables = NIL THEN
        NEXT p_new_table_variables: [1 .. fdc$table_variables_to_expand] IN p_form_status^.p_form_module;
        IF p_new_table_variables = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
          RETURN;
        IFEND;

        fdp$rel_table_variables (p_new_table_variables, p_form_module, table_variables);
        p_table_variable := ^p_new_table_variables^ [1];
        table_variables.active_number := 1;
        RETURN;
      IFEND;

{ An array for variables exists. Try to find an inactive entry.

      number_table_variables := table_variables.active_number;
      IF number_table_variables < table_variables.total_number THEN
        number_table_variables := number_table_variables + 1;
        table_variables.active_number := number_table_variables;
        p_table_variable := ^p_old_table_variables^ [number_table_variables];
        RETURN;
      IFEND;

{ Expand the array for table variables.

      NEXT p_new_table_variables: [1 .. fdc$table_variables_to_expand + number_table_variables] IN
            p_form_status^.p_form_module;
      IF p_new_table_variables = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

{ Copy old variables to new array.

      FOR i := 1 TO number_table_variables DO
        p_new_table_variables^ [i] := p_old_table_variables^ [i];
      FOREND;

      fdp$rel_table_variables (p_new_table_variables, p_form_module, table_variables);
      number_table_variables := number_table_variables + 1;
      table_variables.active_number := number_table_variables;
      p_table_variable := ^p_new_table_variables^ [number_table_variables];
    PROCEND allocate_table_variable;

?? OLDTITLE, EJECT ??
?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT change_table;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT change_table;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    p_form_definition := p_form_status^.p_form_definition;
    p_form_module := p_form_status^.p_form_module;
    table_name := p_form_table_definition^.name;

  /change_table_attributes/
    FOR n := LOWERBOUND (table_attributes) TO UPPERBOUND (table_attributes) DO

    /process_table_attribute/
      BEGIN
        ;
        CASE table_attributes [n].key OF

        = fdc$add_table_variable =
          fdp$validate_name (table_attributes [n].variable_name, p_form_definition^.processor, valid_name,
                name_is_valid);
          IF NOT name_is_valid THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_variable_name,
                  table_attributes [n].variable_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

{ Make sure there are no duplicate table_variable names. Loop through previous defined tables, and
{ then check the current table which is not yet allocated.

          p_form_table_definitions := p_form_status^.p_form_table_definitions;
          FOR table_index := 1 TO p_form_definition^.form_table_definitions.active_number DO
            IF (p_form_table_definitions^ [table_index].table_variables.active_number > 0) THEN
              p_table_variables := fdp$ptr_table_variables (p_form_table_definitions^ [table_index].
                    table_variables, p_form_module);
              FOR table_variable_index := 1 TO p_form_table_definitions^ [table_index].table_variables.
                    active_number DO
                IF (valid_name = p_table_variables^ [table_variable_index].name) THEN
                  osp$set_status_abnormal (fdc$format_display_identifier, fde$variable_name_exists,
                        table_attributes [n].variable_name, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                        status);
                  RETURN;
                IFEND;
              FOREND; { Table-variable loop. }
            IFEND;
          FOREND; { Table loop. }

          IF (p_form_table_definition^.table_variables.active_number > 0) THEN
            p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
                  p_form_module);
            FOR table_variable_index := 1 TO p_form_table_definition^.table_variables.active_number DO
              IF (valid_name = p_table_variables^ [table_variable_index].name) THEN
                osp$set_status_abnormal (fdc$format_display_identifier, fde$variable_name_exists,
                      table_attributes [n].variable_name, status);
                osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                      status);
                RETURN;
              IFEND;
            FOREND;
          IFEND;

          allocate_table_variable (p_form_table_definition^.table_variables, p_table_variable);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          p_table_variable^.name := valid_name;
          p_table_variable^.variable_exists := FALSE;
          fdp$rel_table_objects (NIL, p_form_module, p_table_variable^.table_objects);
          table_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$delete_table_variable =
          fdp$validate_name (table_attributes [n].variable_name, p_form_definition^.processor, valid_name,
                name_is_valid);
          IF NOT name_is_valid THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_variable_name,
                  table_attributes [n].variable_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          p_table_variables := fdp$ptr_table_variables (p_form_table_definition^.table_variables,
                p_form_module);

        /find_table_variable/
          FOR j := 1 TO p_form_table_definition^.table_variables.active_number DO
            p_table_variable := ^p_table_variables^ [j];
            IF p_table_variable^.name = valid_name THEN
              p_table_variable^ := p_table_variables^ [p_form_table_definition^.table_variables.
                    active_number];
              p_form_table_definition^.table_variables.active_number :=
                    p_form_table_definition^.table_variables.active_number - 1;
              table_attributes [n].put_value_status := fdc$put_value_accepted;
              EXIT /process_table_attribute/;
            IFEND;
          FOREND /find_table_variable/;

{ The variable to delete could not be found.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_variable_name,
                table_attributes [n].variable_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;

        = fdc$new_table_name =
          fdp$validate_name (table_attributes [n].new_table_name, p_form_definition^.processor, valid_name,
                name_is_valid);
          IF NOT name_is_valid THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_table_name,
                  table_attributes [n].new_table_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
            table_name := valid_name;
          IFEND;

          fdp$find_table_definition (valid_name, p_form_status^.p_form_table_definitions,
                p_form_definition^.form_table_definitions.active_number, p_duplicate_table_definition,
                table_index, name_exists);
          IF name_exists THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$table_name_exists,
                  table_attributes [n].new_table_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          p_form_table_definition^.name := valid_name;
          table_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$stored_occurrence =
          IF ((table_attributes [n].stored_occurrence < 1) OR
                (table_attributes [n].stored_occurrence > fdc$maximum_occurrence)) THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_occurrence, '', status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  $INTEGER (table_attributes [n].stored_occurrence), 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, table_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          p_form_table_definition^.stored_occurrence := table_attributes [n].stored_occurrence;
          table_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$unused_table_entry =
          table_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$visible_occurrence =
          IF ((table_attributes [n].visible_occurrence < 1) OR
                (table_attributes [n].visible_occurrence > fdc$maximum_occurrence)) THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_occurrence, '', status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  $INTEGER (table_attributes [n].visible_occurrence), 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, table_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          p_form_table_definition^.visible_occurrence_defined := TRUE;
          p_form_table_definition^.visible_occurrence := table_attributes [n].visible_occurrence;
          table_attributes [n].put_value_status := fdc$put_value_accepted;

        ELSE

{ Invalid table attribute.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_table_attribute,
                p_form_definition^.form_name, status);
          RETURN;

        CASEND;
      END /process_table_attribute/;
    FOREND /change_table_attributes/;

  PROCEND change_table;


MODEND fdm$process_table;
*DECK DECK=FDM$PROCESS_VARIABLE EXPAND=TRUE

?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Screen Formatting: Process Variable' ??
MODULE fdm$process_variable;

{ PURPOSE:
{   This module creates, changes, and gets data about a form variable definition.
{
{ DESIGN:
{   All changes to a variable definition must be valid before the stored variable
{   definition is changed.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc cyd$run_time_error_condition
*copyc fde$condition_identifiers
*copyc fdc$im_smart_capability
*copyc fdc$integer_length
*copyc fdc$real_length
*copyc fdc$system_input_format
*copyc fdc$system_io_mode
*copyc fdc$system_occurrence
*copyc fdc$system_unknown_entry
*copyc fdc$message_variable_length
*copyc fdt$comment_index
*copyc fdt$form_object_definition
*copyc fdt$form_objects
*copyc fdt$get_variable_attributes
*copyc fdt$object_attributes
*copyc fdt$object_definition
*copyc fdt$table_variable_index
*copyc fdt$valid_integer_index
*copyc fdt$valid_real_index
*copyc fdt$valid_string_index
*copyc fdt$variable_attribute_index
*copyc fdt$variable_attributes
*copyc ost$name
?? POP ??

*copyc clp$validate_name
*copyc fdp$add_comment
*copyc fdp$change_currency_symbols
*copyc fdp$create_cobol_description
*copyc fdp$find_change_form_definition
*copyc fdp$find_form_definition
*copyc fdp$find_object_definition
*copyc fdp$find_table_definition
*copyc fdp$find_variable_definition
*copyc fdp$get_message
*copyc fdp$locate_added_variable_facts
*copyc fdp$locate_variable_comments
*copyc fdp$ptr_comments
*copyc fdp$ptr_text
*copyc fdp$ptr_valid_integers
*copyc fdp$ptr_valid_reals
*copyc fdp$ptr_valid_strings
*copyc fdp$ptr_variable
*copyc fdp$ptr_variables
*copyc fdp$rel_comments
*copyc fdp$rel_text
*copyc fdp$rel_valid_integers
*copyc fdp$rel_valid_reals
*copyc fdp$rel_valid_strings
*copyc fdp$rel_variable
*copyc fdp$rel_variables
*copyc fdp$validate_name
*copyc i#move
*copyc pmp$continue_to_cause
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    fdc$valid_ranges_to_expand = 2,
    fdc$valid_strings_to_expand = 5,
    fdc$variables_to_expand = 7;

?? TITLE := 'fdp$change_variable', EJECT ??
*copyc fdh$change_variable

  PROCEDURE [XDCL] fdp$change_variable
    (    form_identifier: fdt$form_identifier;
         variable_name: ost$name;
     VAR variable_attributes: fdt$variable_attributes;
     VAR status: ost$status);

    VAR
      additional_definitions: fdt$additional_definitions,
      name_exists: boolean,
      name_is_valid: boolean,
      form_variable_definition: fdt$form_variable_definition,
      p_form_definition: ^fdt$form_definition,
      p_form_status: ^fdt$form_status,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_new_added_variable_definition:^fdt$added_variable_definition,
      p_new_sequence: ^SEQ (*),
      p_old_added_variable_definition:^fdt$added_variable_definition,
      p_old_sequence: ^SEQ (*),
      valid_name: ost$name,
      variable_index: fdt$variable_index;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$change_variable;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$change_variable;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);

    FOR variable_index := LOWERBOUND (variable_attributes) TO UPPERBOUND (variable_attributes) DO
      variable_attributes [variable_index].put_value_status := fdc$unprocessed_put_value;
    FOREND;

    fdp$find_change_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    fdp$validate_name (variable_name, p_form_definition^.processor, valid_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_variable_name, variable_name,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    fdp$find_variable_definition (valid_name, p_form_status^.p_form_variable_definitions,
          p_form_definition^.form_variable_definitions.active_number, p_form_variable_definition,
          variable_index, name_exists);
    IF NOT name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_variable_name, variable_name,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

{ Makes changes to copy of variable definition.
{ All changes must be valid before any changes are made to original version.
{ Copy the additional area of form variable definition so that changes do not affect
{ the orginal.

    form_variable_definition := p_form_variable_definition^;
    NEXT p_new_sequence: [[REP #SIZE(fdt$added_variable_definition) OF cell]] IN
          p_form_status^.p_form_module;
    IF p_new_sequence = NIL THEN
      osp$set_status_condition (fde$no_space_available, status);
      RETURN;
    IFEND;

    RESET p_new_sequence;
    NEXT p_new_added_variable_definition IN p_new_sequence;
    form_variable_definition.additional_variable_facts.additional_definitions :=
          #REL (p_new_sequence, p_form_status^.p_form_module^);
    fdp$locate_added_variable_facts (p_form_status^.p_form_module, p_form_variable_definition,
          p_old_added_variable_definition);
    p_new_added_variable_definition^ := p_old_added_variable_definition^;

    change_variable (p_form_status, p_form_definition, ^form_variable_definition, variable_attributes,
          status);
    IF status.normal THEN

{ The changes are all good. Move the new form variable definition to the old one.
{ The new variable definition points to the new additional area for the form variable definition.

      p_form_variable_definition^ := form_variable_definition;
    IFEND;

  PROCEND fdp$change_variable;

?? TITLE := 'fdp$create_variable', EJECT ??
*copyc fdh$create_variable

  PROCEDURE [XDCL] fdp$create_variable
    (    form_identifier: fdt$form_identifier;
         variable_name: ost$name;
     VAR variable_attributes: fdt$variable_attributes;
     VAR status: ost$status);

    VAR
      additional_definitions: fdt$additional_definitions,
      display_attribute_set: fdt$display_attribute_set,
      form_variable_definition: fdt$form_variable_definition,
      name_exists: boolean,
      name_is_valid: boolean,
      p_added_variable_definition: ^fdt$added_variable_definition,
      p_form_definition: ^fdt$form_definition,
      p_form_object_definition: ^fdt$form_object_definition,
      p_form_status: ^fdt$form_status,
      p_form_table_definition: ^fdt$form_table_definition,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_sequence: ^SEQ ( * ),
      table_index: fdt$table_index,
      valid_name: ost$name,
      variable_index: fdt$variable_index;

?? NEWTITLE := 'allocate_variable', EJECT ??

    PROCEDURE allocate_variable
      (VAR p_form_variable_definition: ^fdt$form_variable_definition);

      VAR
        i: fdt$variable_index,
        number_variables: fdt$number_variables,
        p_new_variable_definitions: ^array [1 .. * ] of fdt$form_variable_definition,
        p_old_variable_definitions: ^array [1 .. * ] of fdt$form_variable_definition;

      status.normal := TRUE;
      p_old_variable_definitions := p_form_status^.p_form_variable_definitions;
      IF p_old_variable_definitions = NIL THEN
        NEXT p_new_variable_definitions: [1 .. fdc$variables_to_expand] IN p_form_status^.p_form_module;
        IF p_new_variable_definitions = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
          RETURN;
        IFEND;

        fdp$rel_variables (p_new_variable_definitions, p_form_status);
        p_form_variable_definition := ^p_new_variable_definitions^ [1];
        p_form_definition^.form_variable_definitions.active_number := 1;
        RETURN;
      IFEND;

{ Minimize allocates/deallocates of tables.
{ An array for variables exists. Try to find an inactive entry.

      number_variables := p_form_definition^.form_variable_definitions.active_number;
      IF number_variables < p_form_definition^.form_variable_definitions.total_number THEN
        number_variables := number_variables + 1;
        p_form_definition^.form_variable_definitions.active_number := number_variables;
        p_form_variable_definition := ^p_old_variable_definitions^ [number_variables];
        RETURN;

      IFEND;

{ Expand the array for variables.

      NEXT p_new_variable_definitions: [1 .. fdc$variables_to_expand + number_variables] IN
            p_form_status^.p_form_module;
      IF p_new_variable_definitions = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

{ Copy old variables to new array.

      FOR i := 1 TO number_variables DO
        p_new_variable_definitions^ [i] := p_old_variable_definitions^ [i];
      FOREND;

      fdp$rel_variables (p_new_variable_definitions, p_form_status);
      number_variables := number_variables + 1;
      p_form_definition^.form_variable_definitions.active_number := number_variables;
      p_form_variable_definition := ^p_new_variable_definitions^ [number_variables];

    PROCEND allocate_variable;

?? OLDTITLE ??
?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$create_variable;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$create_variable;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;

{ Initialize all attributes as unprocessed so that user can determine what
{ attributes were processed when an abnormal condition occurs.

    FOR variable_index := LOWERBOUND (variable_attributes) TO UPPERBOUND (variable_attributes) DO
      variable_attributes [variable_index].put_value_status := fdc$unprocessed_put_value;
    FOREND;

    fdp$find_change_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    fdp$validate_name (variable_name, p_form_definition^.processor, valid_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_variable_name, variable_name,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

{ The new variable name must not currently exist as a variable or table name.

    fdp$find_variable_definition (valid_name, p_form_status^.p_form_variable_definitions,
          p_form_definition^.form_variable_definitions.active_number, p_form_variable_definition,
          variable_index, name_exists);
    IF name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$variable_name_exists, variable_name,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    fdp$find_table_definition (valid_name, p_form_status^.p_form_table_definitions,
          p_form_definition^.form_table_definitions.active_number, p_form_table_definition, table_index,
          name_exists);
    IF name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$variable_name_exists, variable_name,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

{ Set default definitions for the variable.

    form_variable_definition.error_displays := $fdt$display_attribute_set [fdc$inverse_video];
    form_variable_definition.error_definition.key := fdc$no_error_response;
    form_variable_definition.help_definition.key := fdc$no_help_response;
    form_variable_definition.input_format.key := fdc$system_input_format;
    form_variable_definition.io_mode := fdc$system_io_mode;
    form_variable_definition.name := valid_name;
    form_variable_definition.object_exists := FALSE;
    form_variable_definition.output_format.key := fdc$character_output_format;
    form_variable_definition.program_data_type := fdc$program_upper_case_type;
    form_variable_definition.program_variable_length := 0;
    form_variable_definition.process_as_event := FALSE;
    form_variable_definition.table_exists := FALSE;
    form_variable_definition.terminal_user_entry := $fdt$terminal_user_entry [fdc$entry_optional];
    form_variable_definition.screen_variable_length := 0;
    form_variable_definition.unknown_entry_character := fdc$system_unknown_entry;
    form_variable_definition.valid := FALSE;
    form_variable_definition.valid_integer_ranges.total_number := 0;
    form_variable_definition.valid_integer_ranges.active_number := 0;
    form_variable_definition.valid_real_ranges.total_number := 0;
    form_variable_definition.valid_real_ranges.active_number := 0;
    form_variable_definition.valid_strings.total_number := 0;
    form_variable_definition.valid_strings.active_number := 0;
    form_variable_definition.valid_strings.compare_in_upper_case := FALSE;
    form_variable_definition.valid_strings.compare_to_unique_substring := FALSE;

{ Initialize additional area of data for form variable definition. The additional
{ area contains data for supporting COBOL PICTURE, USAGE, and SIGN clauses introduced
{ by the IM_SMART_ENHANCEMENT feature.  Form definitions with a version less than
{ fdc$im_smart_capability do not have an additional area for the form variable definition.
{ The comment field of the form variable definition is replaced by a pointer to
{ to the additional area. The additional area also contains data previously contained in
{ in the comment field.

    NEXT p_sequence: [[REP #SIZE(fdt$added_variable_definition) OF cell]] IN
          p_form_status^.p_form_module;
    IF p_sequence = NIL THEN
      osp$set_status_abnormal (fdc$format_display_identifier,
           fde$no_space_available, '', status);
      RETURN;
    IFEND;

    RESET p_sequence;
    NEXT p_added_variable_definition IN p_sequence;
    form_variable_definition.additional_variable_facts.additional_definitions :=
          #REL(p_sequence, p_form_status^.p_form_module^);
    p_added_variable_definition^.comment_definitions.active_number := 0;
    p_added_variable_definition^.comment_definitions.total_number := 0;
    p_added_variable_definition^.form_cobol_display_clause.defined := FALSE;
    p_added_variable_definition^.form_cobol_program_clause.defined := FALSE;

{ Set user definitions for the variable.

    change_variable (p_form_status, p_form_definition, ^form_variable_definition, variable_attributes,
          status);

{ If all attributes for the variable are valid, then save the new variable definition.
{ Otherwise, no new variable definition exists.  Before the form is saved on a object code library
{the form is copied.  The copy removes all unused space due to bad definitions.

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    allocate_variable (p_form_variable_definition);
    IF status.normal THEN
      p_form_variable_definition^ := form_variable_definition;
    IFEND;
  PROCEND fdp$create_variable;

?? TITLE := 'fdp$delete_variable', EJECT ??
*copyc fdh$delete_variable

  PROCEDURE [XDCL] fdp$delete_variable
    (    form_identifier: fdt$form_identifier;
         variable_name: ost$name;
     VAR status: ost$status);

    VAR
      name_exists: boolean,
      name_is_valid: boolean,
      p_form_definition: ^fdt$form_definition,
      p_form_status: ^fdt$form_status,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_form_variable_definitions: ^array [1 .. * ] of fdt$form_variable_definition,
      valid_name: ost$name,
      variable_index: fdt$variable_index;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$delete_variable;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$delete_variable;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    fdp$find_change_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    p_form_variable_definitions := p_form_status^.p_form_variable_definitions;
    fdp$validate_name (variable_name, p_form_definition^.processor, valid_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_variable_name, variable_name,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    p_form_variable_definitions := p_form_status^.p_form_variable_definitions;
    fdp$find_variable_definition (valid_name, p_form_variable_definitions,
          p_form_definition^.form_variable_definitions.active_number, p_form_variable_definition,
          variable_index, name_exists);
    IF NOT name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_variable_name, variable_name,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

{ Delete variable by moving last defined variable to location occupied by deleted variable
{ and reducing the number of active variables by one.

    p_form_variable_definitions^ [variable_index] := p_form_variable_definitions^
          [p_form_definition^.form_variable_definitions.active_number];
    p_form_definition^.form_variable_definitions.active_number :=
          p_form_definition^.form_variable_definitions.active_number - 1;

  PROCEND fdp$delete_variable;

?? TITLE := 'fdp$get_variable_attributes', EJECT ??
*copyc fdh$get_variable_attributes

  PROCEDURE [XDCL] fdp$get_variable_attributes
    (    form_identifier: fdt$form_identifier;
         variable_name: ost$name;
     VAR get_variable_attributes: fdt$get_variable_attributes;
     VAR status: ost$status);

    VAR
      additional_definitions:  fdt$additional_definitions,
      comment_definitions: fdt$comment_definitions,
      comment_index: fdt$comment_index,
      current_comment_index: fdt$comment_index,
      current_comment_length_index: fdt$comment_index,
      current_integer_index: fdt$valid_integer_index,
      current_real_index: fdt$valid_real_index,
      current_string_index: fdt$valid_string_index,
      current_string_length_index: fdt$valid_string_index,
      initial_value_key: fdt$program_data_type,
      n: fdt$variable_attribute_index,
      name_exists: boolean,
      name_is_valid: boolean,
      number_display: fdt$number_object_displays,
      number_valid_integers: fdt$number_valid_integers,
      number_valid_reals: fdt$number_valid_reals,
      number_valid_strings: fdt$number_valid_strings,
      number_var_comments: fdt$number_comments,
      p_added_variable_definition: ^fdt$added_variable_definition,
      p_comment: ^fdt$comment,
      p_comment_definition: ^fdt$comment_definition,
      p_comment_definitions: ^array [1 .. * ] of fdt$comment_definition,
      p_error_message: ^fdt$error_message,
      p_form_definition: ^fdt$form_definition,
      p_form_module: ^fdt$form_module,
      p_form_status: ^fdt$form_status,
      p_form_variable_definition: ^fdt$form_variable_definition,
      p_help_message: ^fdt$help_message,
      p_sequence: ^SEQ (*),
      p_text: ^fdt$text,
      p_valid_integer_range: ^fdt$valid_integer_range,
      p_valid_integer_ranges: ^array [1 .. * ] of fdt$valid_integer_range,
      p_valid_real_range: ^fdt$valid_real_range,
      p_valid_real_ranges: ^array [1 .. * ] of fdt$valid_real_range,
      p_valid_string_definition: ^fdt$valid_string_definition,
      p_valid_string: ^fdt$valid_string,
      p_valid_strings: ^array [1 .. * ] of fdt$valid_string_definition,
      valid_integer_index: fdt$valid_integer_index,
      valid_name: ost$name,
      valid_real_index: fdt$valid_real_index,
      valid_string_index: fdt$valid_string_index,
      variable_index: fdt$variable_index;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_variable_attributes;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT fdp$get_variable_attributes;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;

{ Initialize all attributes as unprocessed so user can determined processed attributes
{ if an abnormal condition occurs.

    FOR n := LOWERBOUND (get_variable_attributes) TO UPPERBOUND (get_variable_attributes) DO
      get_variable_attributes [n].get_value_status := fdc$unprocessed_get_value;
    FOREND;

    fdp$find_form_definition (form_identifier, p_form_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_form_definition := p_form_status^.p_form_definition;
    fdp$validate_name (variable_name, p_form_definition^.processor, valid_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_variable_name, variable_name,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    fdp$find_variable_definition (valid_name, p_form_status^.p_form_variable_definitions,
          p_form_definition^.form_variable_definitions.active_number, p_form_variable_definition,
          variable_index, name_exists);
    IF NOT name_exists THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_variable_name, variable_name,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
      RETURN;
    IFEND;

    p_form_module := p_form_status^.p_form_module;
    fdp$locate_variable_comments (p_form_status, p_form_variable_definition, comment_definitions);
    p_valid_integer_ranges := fdp$ptr_valid_integers (p_form_variable_definition^.valid_integer_ranges,
          p_form_module);
    p_valid_real_ranges := fdp$ptr_valid_reals (p_form_variable_definition^.valid_real_ranges, p_form_module);
    p_valid_strings := fdp$ptr_valid_strings (p_form_variable_definition^.valid_strings, p_form_module);
    p_comment_definitions := fdp$ptr_comments (comment_definitions, p_form_module);
    current_comment_index := 1;
    current_comment_length_index := 1;
    current_integer_index := 1;
    current_real_index := 1;
    current_string_index := 1;
    current_string_length_index := 1;

  /process_variable_attributes/
    FOR n := LOWERBOUND (get_variable_attributes) TO UPPERBOUND (get_variable_attributes) DO
      CASE get_variable_attributes [n].key OF

      = fdc$get_cobol_display_clause =
        get_variable_attributes [n].get_value_status := fdc$undefined_value;
        IF p_form_definition^.screen_formatting_version < fdc$im_smart_capability THEN
          CYCLE /process_variable_attributes/;
        IFEND;

        fdp$locate_added_variable_facts (p_form_module, p_form_variable_definition,
             p_added_variable_definition);
        IF NOT p_added_variable_definition^.form_cobol_display_clause.defined THEN
          CYCLE /process_variable_attributes/;
        IFEND;

        IF (get_variable_attributes [n].p_cobol_display_clause = NIL) THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_address,
                p_form_definition^.form_name, status);
          RETURN;
        IFEND;

        get_variable_attributes [n].p_cobol_display_clause^ :=  p_added_variable_definition^.
              form_cobol_display_clause.cobol_display_clause;
        get_variable_attributes [n].get_value_status := fdc$user_defined_value;

      = fdc$get_cobol_program_clause =
        get_variable_attributes [n].get_value_status := fdc$undefined_value;
        IF p_form_definition^.screen_formatting_version < fdc$im_smart_capability THEN
          CYCLE /process_variable_attributes/;
        IFEND;

        fdp$locate_added_variable_facts (p_form_module, p_form_variable_definition,
             p_added_variable_definition);
        IF NOT p_added_variable_definition^.form_cobol_program_clause.defined THEN
           CYCLE /process_variable_attributes/;
        IFEND;

        IF (get_variable_attributes [n].p_cobol_program_clause = NIL) THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_address,
                p_form_definition^.form_name, status);
          RETURN;
        IFEND;

        get_variable_attributes [n].p_cobol_program_clause^ :=  p_added_variable_definition^.
              form_cobol_program_clause.cobol_program_clause;
        get_variable_attributes [n].get_value_status := fdc$user_defined_value;

      = fdc$get_input_format =
        get_variable_attributes [n].input_format := p_form_variable_definition^.input_format;
        IF p_form_variable_definition^.input_format.key = fdc$system_input_format THEN
          get_variable_attributes [n].get_value_status := fdc$system_default_value;
        ELSE
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
        IFEND;

      = fdc$get_io_mode =
        get_variable_attributes [n].io_mode := p_form_variable_definition^.io_mode;
        IF p_form_variable_definition^.io_mode = fdc$system_io_mode THEN
          get_variable_attributes [n].get_value_status := fdc$system_default_value;
        ELSE
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
        IFEND;

      = fdc$get_error_display =
        get_variable_attributes [n].display_attribute := p_form_variable_definition^.error_displays;
        IF p_form_variable_definition^.error_displays = $fdt$display_attribute_set [] THEN
          get_variable_attributes [n].get_value_status := fdc$undefined_value;
        ELSEIF p_form_variable_definition^.error_displays = $fdt$display_attribute_set
              [fdc$inverse_video] THEN
          get_variable_attributes [n].get_value_status := fdc$system_default_value;
        ELSE
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
        IFEND;

      = fdc$get_next_valid_real_range =
        get_variable_attributes [n].get_value_status := fdc$undefined_value;

      /get_valid_real/
        FOR valid_real_index := current_real_index TO p_form_variable_definition^.valid_real_ranges.
              active_number DO
          p_valid_real_range := ^p_valid_real_ranges^ [valid_real_index];
          current_real_index := valid_real_index + 1;
          get_variable_attributes [n].minimum_real := p_valid_real_range^.minimum_real;
          get_variable_attributes [n].maximum_real := p_valid_real_range^.maximum_real;
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
          EXIT /get_valid_real/;
        FOREND /get_valid_real/;

      = fdc$get_next_valid_string =
        IF (get_variable_attributes [n].p_valid_string = NIL) THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_address,
                p_form_definition^.form_name, status);
          RETURN;
        IFEND;

        get_variable_attributes [n].get_value_status := fdc$undefined_value;

      /get_string/
        FOR valid_string_index := current_string_index TO p_form_variable_definition^.valid_strings.
              active_number DO
          p_valid_string_definition := ^p_valid_strings^ [valid_string_index];
          current_string_index := valid_string_index + 1;
          p_valid_string := #PTR (p_valid_string_definition^.p_valid_string, p_form_module^);
          IF STRLENGTH (get_variable_attributes [n].p_valid_string^) >= STRLENGTH (p_valid_string^) THEN
            get_variable_attributes [n].p_valid_string^ := p_valid_string^;
            get_variable_attributes [n].get_value_status := fdc$user_defined_value;
            EXIT /get_string/;

          ELSE

{ The user did not an area large enough to contain the valid string.

            osp$set_status_abnormal (fdc$format_display_identifier, fde$string_too_small, '', status);
            RETURN;
          IFEND;
        FOREND /get_string/;

      = fdc$get_next_var_comment =
        IF (get_variable_attributes [n].p_var_comment = NIL) THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_address,
                p_form_definition^.form_name, status);
          RETURN;
        IFEND;

        get_variable_attributes [n].get_value_status := fdc$undefined_value;

      /get_comment/
        FOR comment_index := current_comment_index TO comment_definitions.
              active_number DO
          p_comment_definition := ^p_comment_definitions^ [comment_index];
          current_comment_index := comment_index + 1;
          p_comment := #PTR (p_comment_definition^.p_comment, p_form_module^);
          IF STRLENGTH (get_variable_attributes [n].p_var_comment^) >= STRLENGTH (p_comment^) THEN
            get_variable_attributes [n].p_var_comment^ := p_comment^;
            get_variable_attributes [n].get_value_status := fdc$user_defined_value;
            EXIT /get_comment/;

          ELSE

{ The user did not specify an area large enough to contain the comment.

            osp$set_status_abnormal (fdc$format_display_identifier, fde$string_too_small, '', status);
            RETURN;
          IFEND;
        FOREND /get_comment/;

      = fdc$get_number_valid_integers =
        get_variable_attributes [n].get_value_status := fdc$user_defined_value;
        get_variable_attributes [n].number_valid_integers :=
              p_form_variable_definition^.valid_integer_ranges.active_number;

      = fdc$get_number_valid_reals =
        get_variable_attributes [n].get_value_status := fdc$user_defined_value;
        get_variable_attributes [n].number_valid_integers :=
              p_form_variable_definition^.valid_real_ranges.active_number;

      = fdc$get_number_valid_strings =
        get_variable_attributes [n].get_value_status := fdc$user_defined_value;
        get_variable_attributes [n].number_valid_strings :=
              p_form_variable_definition^.valid_strings.active_number;

      = fdc$get_number_var_comments =
        get_variable_attributes [n].get_value_status := fdc$user_defined_value;
        get_variable_attributes [n].number_var_comments := comment_definitions.
              active_number;

      = fdc$get_output_format =

        IF p_form_variable_definition^.output_format.key = fdc$undefined_output_format THEN
          get_variable_attributes [n].get_value_status := fdc$undefined_value;
        ELSE
          get_variable_attributes [n].output_format := p_form_variable_definition^.output_format;
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
        IFEND;

      = fdc$get_process_as_event =
        get_variable_attributes [n].process_as_event := p_form_variable_definition^.process_as_event;
        IF p_form_variable_definition^.process_as_event = FALSE THEN
          get_variable_attributes [n].get_value_status := fdc$system_default_value;
        ELSE
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
        IFEND;

      = fdc$get_program_data_type =
        get_variable_attributes [n].program_data_type := p_form_variable_definition^.program_data_type;
        IF p_form_variable_definition^.program_data_type <> fdc$program_upper_case_type THEN
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
        ELSE
          get_variable_attributes [n].get_value_status := fdc$system_default_value;
        IFEND;

      = fdc$get_string_compare_rules =
        get_variable_attributes [n].compare_in_upper_case :=
              p_form_variable_definition^.valid_strings.compare_in_upper_case;
        get_variable_attributes [n].compare_to_unique_substring :=
              p_form_variable_definition^.valid_strings.compare_to_unique_substring;
        IF ((NOT p_form_variable_definition^.valid_strings.compare_in_upper_case) AND
              (NOT p_form_variable_definition^.valid_strings.compare_to_unique_substring)) THEN
          get_variable_attributes [n].get_value_status := fdc$system_default_value;
        ELSE
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
        IFEND;

      = fdc$get_terminal_user_entry =
        get_variable_attributes [n].terminal_user_entry := p_form_variable_definition^.terminal_user_entry;
        IF p_form_variable_definition^.terminal_user_entry = $fdt$terminal_user_entry
              [fdc$entry_optional] THEN
          get_variable_attributes [n].get_value_status := fdc$system_default_value;
        ELSE
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
        IFEND;

      = fdc$get_unknown_entry_character =
        get_variable_attributes [n].unknown_entry_character :=
              p_form_variable_definition^.unknown_entry_character;
        IF p_form_variable_definition^.unknown_entry_character = fdc$system_unknown_entry THEN
          get_variable_attributes [n].get_value_status := fdc$system_default_value;
        ELSE
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
        IFEND;

      = fdc$get_unused_variable_entry =
        get_variable_attributes [n].get_value_status := fdc$undefined_value;

      = fdc$get_valid_integer_range =
        get_variable_attributes [n].get_value_status := fdc$undefined_value;

      /get_valid_integer/
        FOR valid_integer_index := current_integer_index TO p_form_variable_definition^.valid_integer_ranges.
              active_number DO
          p_valid_integer_range := ^p_valid_integer_ranges^ [valid_integer_index];
          current_integer_index := valid_integer_index + 1;
          get_variable_attributes [n].minimum_integer := p_valid_integer_range^.minimum_integer;
          get_variable_attributes [n].maximum_integer := p_valid_integer_range^.maximum_integer;
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
          EXIT /get_valid_integer/;
        FOREND /get_valid_integer/;

      = fdc$get_valid_string_length =
        get_variable_attributes [n].get_value_status := fdc$undefined_value;

      /get_string_length/
        FOR valid_string_index := current_string_length_index TO p_form_variable_definition^.valid_strings.
              active_number DO
          p_valid_string_definition := ^p_valid_strings^ [valid_string_index];
          current_string_length_index := valid_string_index + 1;
          p_valid_string := #PTR (p_valid_string_definition^.p_valid_string, p_form_module^);
          get_variable_attributes [n].valid_string_length := STRLENGTH (p_valid_string^);
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
          EXIT /get_string_length/;
        FOREND /get_string_length/;

      = fdc$get_var_comment_length =
        get_variable_attributes [n].get_value_status := fdc$undefined_value;

      /get_comment_length/
        FOR comment_index := current_comment_length_index TO comment_definitions.
              active_number DO
          p_comment_definition := ^p_comment_definitions^ [comment_index];
          current_comment_length_index := comment_index + 1;
          p_comment := #PTR (p_comment_definition^.p_comment, p_form_module^);
          get_variable_attributes [n].var_comment_length := STRLENGTH (p_comment^);

          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
          EXIT /get_comment_length/;
        FOREND /get_comment_length/;

      = fdc$get_var_error_message =
         CASE p_form_variable_definition^.error_definition.key OF
         = fdc$error_message =
           IF (get_variable_attributes [n].p_error_message = NIL) THEN
             osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_address, '', status);
             RETURN;
           IFEND;

            p_error_message := #PTR (p_form_variable_definition^.error_definition.p_error_message,
                p_form_module^);
            IF STRLENGTH (get_variable_attributes [n].p_error_message^) >= STRLENGTH (p_error_message^) THEN
              get_variable_attributes [n].p_error_message^ := p_error_message^;
              get_variable_attributes [n].get_value_status := fdc$user_defined_value;

            ELSE

{ The user's area will not hold the error message.

              osp$set_status_abnormal (fdc$format_display_identifier, fde$string_too_small, '', status);
              RETURN;
            IFEND;

          = fdc$system_default_error =
            IF (get_variable_attributes [n].p_error_message = NIL) THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_address, '', status);
              RETURN;
            IFEND;

            IF STRLENGTH (get_variable_attributes [n].p_error_message^) >=
                  fdc$message_variable_length THEN
              fdp$get_message (fde$system_error_message,
                    get_variable_attributes [n].p_error_message^);
              get_variable_attributes [n].get_value_status := fdc$system_default_value;

            ELSE

{ The user's area will not hold the error message.

              osp$set_status_abnormal (fdc$format_display_identifier, fde$string_too_small, '', status);
              RETURN;
            IFEND;

           ELSE

{ The user did not specify an error message.

          get_variable_attributes [n].get_value_status := fdc$undefined_value;
          CASEND;

      = fdc$get_var_help_message =
        CASE p_form_variable_definition^.help_definition.key OF

          = fdc$help_message =
            IF (get_variable_attributes [n].p_help_message = NIL) THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_address, '', status);
              RETURN;
            IFEND;

            p_help_message := #PTR (p_form_variable_definition^.help_definition.p_help_message,
                  p_form_module^);
            IF STRLENGTH (get_variable_attributes [n].p_help_message^) >= STRLENGTH (p_help_message^) THEN
              get_variable_attributes [n].p_help_message^ := p_help_message^;
              get_variable_attributes [n].get_value_status := fdc$user_defined_value;

            ELSE

{ The user's area will not hold the help message.

              osp$set_status_abnormal (fdc$format_display_identifier, fde$string_too_small, '', status);
              RETURN;
            IFEND;

          = fdc$system_default_help =
            IF (get_variable_attributes [n].p_help_message = NIL) THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_address, '', status);
              RETURN;
            IFEND;

            IF STRLENGTH (get_variable_attributes [n].p_help_message^) >=
                  fdc$message_variable_length THEN
              fdp$get_message (fde$system_help_message,
                    get_variable_attributes [n].p_help_message^);
              get_variable_attributes [n].get_value_status := fdc$system_default_value;

            ELSE

{ The user's area will not hold the help message.

              osp$set_status_abnormal (fdc$format_display_identifier, fde$string_too_small, '', status);
              RETURN;
            IFEND;

           ELSE

{ The user did not specify a help message.

          get_variable_attributes [n].get_value_status := fdc$undefined_value;
          CASEND;

      = fdc$get_variable_error =
        CASE p_form_variable_definition^.error_definition.key OF

        = fdc$no_error_response =
          get_variable_attributes [n].variable_error.key := fdc$get_no_error_response;
          get_variable_attributes [n].get_value_status := fdc$system_default_value;

        = fdc$error_form =
          get_variable_attributes [n].variable_error.key := fdc$get_error_form;
          get_variable_attributes [n].variable_error.error_form :=
                p_form_variable_definition^.error_definition.error_form;
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;

        = fdc$error_message =
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
          get_variable_attributes [n].variable_error.key := fdc$get_error_message;
          p_error_message := #PTR (p_form_variable_definition^.error_definition.p_error_message,
                p_form_module^);
          get_variable_attributes [n].variable_error.error_message_length := STRLENGTH (p_error_message^);

        = fdc$system_default_error =
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
          get_variable_attributes [n].variable_error.key := fdc$get_system_default_error;
          get_variable_attributes [n].variable_error.error_message_length :=
               fdc$message_variable_length;

        ELSE

{ Invalid error processing case.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_error_key,
                p_form_definition^.form_name, status);
          RETURN;
        CASEND;

      = fdc$get_variable_help =
        CASE p_form_variable_definition^.help_definition.key OF

        = fdc$no_help_response =
          get_variable_attributes [n].variable_help.key := fdc$get_no_help_response;
          get_variable_attributes [n].get_value_status := fdc$system_default_value;

        = fdc$help_form =
          get_variable_attributes [n].variable_help.key := fdc$get_help_form;
          get_variable_attributes [n].variable_help.help_form :=
                p_form_variable_definition^.help_definition.help_form;
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;


        = fdc$help_message =
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
          get_variable_attributes [n].variable_help.key := fdc$get_help_message;
          p_help_message := #PTR (p_form_variable_definition^.help_definition.p_help_message, p_form_module^);
          get_variable_attributes [n].variable_help.help_message_length := STRLENGTH (p_help_message^);

        = fdc$system_default_help =
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
          get_variable_attributes [n].variable_help.key := fdc$get_system_default_help;
          get_variable_attributes [n].variable_help.help_message_length :=
                fdc$message_variable_length;

        ELSE

{ Invalid help processing case.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error, '', status);
          RETURN;
        CASEND;

      = fdc$get_variable_length =
        IF p_form_variable_definition^.program_variable_length = 0 THEN
          get_variable_attributes [n].get_value_status := fdc$undefined_value;
        ELSE
          get_variable_attributes [n].variable_length := p_form_variable_definition^.program_variable_length;
          get_variable_attributes [n].get_value_status := fdc$user_defined_value;
        IFEND;

      ELSE

{ Invalid attribute.

        osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_variable_attribute,
              p_form_definition^.form_name, status);
        RETURN;

      CASEND;
    FOREND /process_variable_attributes/;

  PROCEND fdp$get_variable_attributes;

?? TITLE := 'change_variable', EJECT ??

  PROCEDURE change_variable
    (    p_form_status: ^fdt$form_status;
         p_form_definition: ^fdt$form_definition;
         p_form_variable_definition: ^fdt$form_variable_definition;
     VAR variable_attributes: fdt$variable_attributes;
     VAR status: ost$status);

    VAR
      additional_definitions:  fdt$additional_definitions,
      cobol_clause_changed: boolean,
      cobol_description: fdt$cobol_description,
      comment_index: fdt$comment_index,
      b_edit_character: [READ] packed array [char] of boolean := [
          {---} REP  66 of FALSE,
          {B  } REP   1 of TRUE,
          {---} REP  31 of FALSE,
          {b  } REP   1 of TRUE,
          {---} REP 157 of FALSE],
      error_key: fdt$error_key,
      help_key: fdt$help_key,
      initial_value_key: fdt$program_data_type,
      n: fdt$variable_attribute_index,
      name_exists: boolean,
      name_is_valid: boolean,
      new_array: boolean,
      output_format_key: fdt$output_format_key,
      p_added_variable_definition: ^fdt$added_variable_definition,
      p_duplicate_variable: ^fdt$form_variable_definition,
      p_error_message: ^fdt$error_message,
      p_form_module: ^fdt$form_module,
      p_form_table_definition: ^fdt$form_table_definition,
      p_help_message: ^fdt$help_message,
      p_comment_definitions: ^array [1 .. * ] of fdt$comment_definition,
      p_new_valid_string: ^fdt$valid_string,
      p_sequence: ^SEQ (*),
      p_text: ^fdt$text,
      p_valid_integer_range: ^fdt$valid_integer_range,
      p_valid_integer_ranges: ^array [1 .. * ] of fdt$valid_integer_range,
      p_valid_string: ^fdt$valid_string,
      p_valid_strings: ^array [1 .. * ] of fdt$valid_string_definition,
      p_valid_string_definition: ^fdt$valid_string_definition,
      p_valid_real_range: ^fdt$valid_real_range,
      p_valid_real_ranges: ^array [1 .. * ] of fdt$valid_real_range,
      real_length: integer,
      real_string: string (10),
      scan_found_character: boolean,
      scan_index: integer,
      table_index: fdt$table_index,
      valid_integer_index: fdt$valid_integer_index,
      valid_name: ost$name,
      valid_real_index: fdt$valid_real_index,
      valid_string_index: fdt$valid_string_index,
      variable_index: fdt$variable_index;

?? NEWTITLE := 'allocate_valid_integer', EJECT ??

    PROCEDURE allocate_valid_integer
      (VAR valid_integer_ranges: fdt$valid_integer_ranges;
       VAR p_valid_integer_range: ^fdt$valid_integer_range);

      VAR
        i: fdt$valid_integer_index,
        number_valid_integers: fdt$number_valid_integers,
        p_new_valid_integers: ^array [1 .. * ] of fdt$valid_integer_range,
        p_old_valid_integers: ^array [1 .. * ] of fdt$valid_integer_range;

      p_old_valid_integers := fdp$ptr_valid_integers (valid_integer_ranges, p_form_module);
      IF p_old_valid_integers = NIL THEN
        NEXT p_new_valid_integers: [1 .. fdc$valid_ranges_to_expand] IN p_form_status^.p_form_module;
        IF p_new_valid_integers = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
          RETURN;
        IFEND;

        fdp$rel_valid_integers (p_new_valid_integers, p_form_module, valid_integer_ranges);
        p_valid_integer_range := ^p_new_valid_integers^ [1];
        valid_integer_ranges.active_number := 1;
        RETURN;
      IFEND;

{ Minimize allocates/deallocates of tables.
{ Entries have already been allocated. Try to find an inactive entry.

      number_valid_integers := valid_integer_ranges.active_number;

      IF number_valid_integers < valid_integer_ranges.total_number THEN
        number_valid_integers := number_valid_integers + 1;
        valid_integer_ranges.active_number := number_valid_integers;
        p_valid_integer_range := ^p_old_valid_integers^ [number_valid_integers];
        RETURN;
      IFEND;

{ Expand the array for valid integers.

      NEXT p_new_valid_integers: [1 .. number_valid_integers + fdc$valid_ranges_to_expand] IN
            p_form_status^.p_form_module;
      IF p_new_valid_integers = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

{ Copy old entries to new array.

      FOR i := 1 TO number_valid_integers DO
        p_new_valid_integers^ [i] := p_old_valid_integers^ [i];
      FOREND;

      fdp$rel_valid_integers (p_new_valid_integers, p_form_module, valid_integer_ranges);
      number_valid_integers := number_valid_integers + 1;
      valid_integer_ranges.active_number := number_valid_integers;
      p_valid_integer_range := ^p_new_valid_integers^ [number_valid_integers];
    PROCEND allocate_valid_integer;

?? OLDTITLE ??
?? NEWTITLE := 'allocate_valid_real', EJECT ??

    PROCEDURE allocate_valid_real
      (VAR valid_real_ranges: fdt$valid_real_ranges;
       VAR p_valid_real_range: ^fdt$valid_real_range);

      VAR
        i: fdt$valid_real_index,
        number_valid_reals: fdt$number_valid_reals,
        p_new_valid_reals: ^array [1 .. * ] of fdt$valid_real_range,
        p_old_valid_reals: ^array [1 .. * ] of fdt$valid_real_range;

      p_old_valid_reals := fdp$ptr_valid_reals (valid_real_ranges, p_form_module);
      IF p_old_valid_reals = NIL THEN
        NEXT p_new_valid_reals: [1 .. fdc$valid_ranges_to_expand] IN p_form_status^.p_form_module;
        IF p_new_valid_reals = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
          RETURN;
        IFEND;

        fdp$rel_valid_reals (p_new_valid_reals, p_form_module, valid_real_ranges);
        p_valid_real_range := ^p_new_valid_reals^ [1];
        valid_real_ranges.active_number := 1;
        RETURN;
      IFEND;

{ Minimize allocates/deallocates of tables.
{ Entries have already been allocated. Try to find an inactive entry.

      number_valid_reals := valid_real_ranges.active_number;
      IF number_valid_reals < valid_real_ranges.total_number THEN
        number_valid_reals := number_valid_reals + 1;
        valid_real_ranges.active_number := number_valid_reals;
        p_valid_real_range := ^p_old_valid_reals^ [number_valid_reals];
        RETURN;
      IFEND;

{ Expand the array for valid reals.

      NEXT p_new_valid_reals: [1 .. number_valid_reals + fdc$valid_ranges_to_expand] IN
            p_form_status^.p_form_module;
      IF p_new_valid_reals = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

      FOR i := 1 TO number_valid_reals DO
        p_new_valid_reals^ [i] := p_old_valid_reals^ [i];
      FOREND;

      fdp$rel_valid_reals (p_new_valid_reals, p_form_module, valid_real_ranges);
      number_valid_reals := number_valid_reals + 1;
      valid_real_ranges.active_number := number_valid_reals;
      p_valid_real_range := ^p_new_valid_reals^ [number_valid_reals];
    PROCEND allocate_valid_real;

?? OLDTITLE ??
?? NEWTITLE := 'allocate_valid_string', EJECT ??

    PROCEDURE allocate_valid_string
      (VAR valid_strings: fdt$valid_strings;
       VAR p_valid_string_definition: ^fdt$valid_string_definition);

      VAR
        n: fdt$valid_string_index,
        number_valid_strings: fdt$number_valid_strings,
        p_new_valid_strings: ^array [1 .. * ] of fdt$valid_string_definition,
        p_old_valid_strings: ^array [1 .. * ] of fdt$valid_string_definition;

      p_old_valid_strings := fdp$ptr_valid_strings (valid_strings, p_form_module);
      IF p_old_valid_strings = NIL THEN
        NEXT p_new_valid_strings: [1 .. fdc$valid_strings_to_expand] IN p_form_status^.p_form_module;
        IF p_new_valid_strings = NIL THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
          RETURN;
        IFEND;

        fdp$rel_valid_strings (p_new_valid_strings, p_form_module, valid_strings);
        p_valid_string_definition := ^p_new_valid_strings^ [1];
        valid_strings.active_number := 1;
        RETURN;
      IFEND;

{ Entries have already been allocated. Try to find an inactive entry.

      number_valid_strings := valid_strings.active_number;
      IF number_valid_strings < valid_strings.total_number THEN
        number_valid_strings := number_valid_strings + 1;
        valid_strings.active_number := number_valid_strings;
        p_valid_string_definition := ^p_old_valid_strings^ [number_valid_strings];
        RETURN;
      IFEND;

{ Expand the array for valid strings.

      NEXT p_new_valid_strings: [1 .. number_valid_strings + fdc$valid_strings_to_expand] IN
            p_form_status^.p_form_module;
      IF p_new_valid_strings = NIL THEN
        osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
        RETURN;
      IFEND;

      FOR n := 1 TO number_valid_strings DO
        p_new_valid_strings^ [n] := p_old_valid_strings^ [n];
      FOREND;

      fdp$rel_valid_strings (p_new_valid_strings, p_form_module, valid_strings);
      number_valid_strings := number_valid_strings + 1;
      valid_strings.active_number := number_valid_strings;
      p_valid_string_definition := ^p_new_valid_strings^ [number_valid_strings];
    PROCEND allocate_valid_string;

?? OLDTITLE ??
?? NEWTITLE := 'check_object_size', EJECT ??

  PROCEDURE check_object_size
    (    p_form_status: ^fdt$form_status;
         cobol_size: 0 .. fdc$cobol_item_size_maximum;
         variable_name: ost$name;
     VAR status: ost$status);

    VAR
      object_index: fdt$object_index,
      object_name_exists: boolean,
      object_occurrence_exists: boolean,
      p_form_object_definition: ^fdt$form_object_definition,
      screen_variable_length: fdt$screen_variable_length;

    status.normal := TRUE;
    fdp$find_object_definition (variable_name, 1, p_form_status^.p_form_object_definitions,
          p_form_status^.p_form_definition^.form_object_definitions.active_number,
          p_form_object_definition, object_index, object_name_exists,
          object_occurrence_exists);
    IF NOT object_name_exists THEN
      RETURN;
    IFEND;

    CASE p_form_object_definition^.key OF

    = fdc$form_variable_text =
      screen_variable_length := p_form_object_definition^.text_variable_width;

    = fdc$form_variable_text_box =
      screen_variable_length := p_form_object_definition^.variable_box_width *
            p_form_object_definition^.variable_box_height;
    ELSE
      RETURN;
    CASEND;

    IF cobol_size > screen_variable_length THEN
      osp$set_status_abnormal (fdc$format_display_identifier, fde$object_size_coboL_mismatch, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            $INTEGER (cobol_size), 10, FALSE,  status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (screen_variable_length),
            10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, variable_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
           p_form_status^.p_form_definition^.form_name, status);
    IFEND;

    PROCEND check_object_size;

?? OLDTITLE ??
?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = pmc$system_conditions =
        IF (condition.system_conditions * $pmt$system_conditions
              [pmc$instruction_specification, pmc$address_specification, pmc$access_violation,
              pmc$invalid_segment_ring_0, pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
              pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
              pmc$arithmetic_significance, pmc$invalid_bdp_data]) <> $pmt$system_conditions [] THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT change_variable;
        IFEND;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          osp$set_status_abnormal (fdc$format_display_identifier, fde$bad_data_value, '', status);
          EXIT change_variable;
        IFEND;

      ELSE
        ;
      CASEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;

?? OLDTITLE ??
?? NEWTITLE := 'convert_cobol_status', EJECT ??

{ PURPOSE:
{   This procedure converts a status from fdp$create_cobol_description
{   to a Screen Formatting status.
{ DESIGN:
{   To help the user locate errors more easily, the name of the variable and
{   and the name of the form is added to the cobol status message.
{ NOTES:
{   This procedure never returns to its caller.  It always exits change_variable.

   PROCEDURE convert_cobol_status;

     VAR
       status_condition_code: ost$status_condition_code;

     CASE status.condition OF
     = fde$cobol_too_many_digits =
       status_condition_code := fde$too_many_digits;
     = fde$cobol_bad_picture =
       status_condition_code := fde$invalid_picture;
     = fde$cobol_binary_means_numeric =
       status_condition_code := fde$binary_requires_numeric;
     = fde$cobol_comp_1_means_no_pic =
       status_condition_code := fde$picture_invalid_for_comp_1;
     = fde$cobol_comp_2_means_no_pic =
       status_condition_code := fde$picture_invalid_for_comp_2;
     = fde$cobol_CR_DB_must_be_right =
       status_condition_code := fde$cr_db_must_be_rightmost;
     = fde$cobol_float_must_be_left =
       status_condition_code := fde$floating_symbols_invalid;
     = fde$cobol_illegal_pic_char =
       status_condition_code := fde$invalid_picture_character;
     = fde$cobol_insert_left_of_float =
       status_condition_code := fde$insertion_symbols_invalid;
     = fde$cobol_item_too_big =
       status_condition_code := fde$picture_item_too_big;
     = fde$cobol_no_multiple_points =
       status_condition_code := fde$too_many_decimal_points;
     = fde$cobol_no_rep_after_point =
       status_condition_code := fde$no_repetition_after_point;
     = fde$cobol_no_rep_for_cr_db =
       status_condition_code := fde$no_repetition_for_cr_db;
     = fde$cobol_nondigit_rep_count =
       status_condition_code := fde$nondigit_repetition;
     = fde$cobol_not_both_v_and_p =
       status_condition_code := fde$v_and_p_invalid;
     = fde$cobol_not_9p9 =
       status_condition_code := fde$p_between_9_invalid;
     = fde$cobol_not_p9p =
       status_condition_code := fde$9_between_p_invalid;
     = fde$cobol_packed_means_num_pic =
       status_condition_code := fde$packed_requires_numeric;
     = fde$cobol_right_flt_means_all =
       status_condition_code := fde$invalid_right_floating;
     = fde$cobol_s_must_be_first =
       status_condition_code := fde$s_must_be_first;
     = fde$cobol_sign_needs_s =
       status_condition_code := fde$picture_requires_sign;
     = fde$cobol_too_many_vs =
       status_condition_code := fde$too_many_vs;
     = fde$cobol_two_signs =
       status_condition_code := fde$too_many_sign_symbols;
    = fde$cobol_two_floating =
      status_condition_code := fde$too_many_floating_symbols;
     = fde$cobol_unbal_parens =
       status_condition_code := fde$unbalanced_parentheses;
     = fde$cobol_unknown_usage =
       status_condition_code := fde$invalid_usage;
     = fde$cobol_wrong_sign_vs_usage =
       status_condition_code := fde$invalid_sign_for_usage;
     = fde$cobol_p_not_supported =
       status_condition_code := fde$p_invalid_for_picture;
     ELSE
       osp$set_status_abnormal (fdc$format_display_identifier, fde$system_error,
            'Unknown status from fdp$create_cobol_definition', status);
       EXIT change_variable;
     CASEND;

     osp$set_status_abnormal (fdc$format_display_identifier, status_condition_code,
            p_form_variable_definition^.name, status);
     osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
           status);
     EXIT change_variable;

   PROCEND convert_cobol_status;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^condition_handler, FALSE);
    status.normal := TRUE;
    cobol_clause_changed := FALSE;
    p_form_module := p_form_status^.p_form_module;

  /process_variable_attributes/
    FOR n := LOWERBOUND (variable_attributes) TO UPPERBOUND (variable_attributes) DO

    /process_variable_attribute/
      BEGIN
        CASE variable_attributes [n].key OF

        = fdc$add_valid_integer_range =
          IF variable_attributes [n].minimum_integer > variable_attributes [n].maximum_integer THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_integer_range, '', status);
            osp$append_status_integer (osc$status_parameter_delimiter, variable_attributes [n].
                  minimum_integer, 10, FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter, variable_attributes [n].
                  maximum_integer, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_variable_definition^.name,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          p_valid_integer_ranges := fdp$ptr_valid_integers (p_form_variable_definition^.valid_integer_ranges,
                p_form_module);

{ The ranges of valid integers must not overlap.

        /check_integer_range_overlap/
          FOR valid_integer_index := 1 TO p_form_variable_definition^.valid_integer_ranges.active_number DO
            p_valid_integer_range := ^p_valid_integer_ranges^ [valid_integer_index];
            IF variable_attributes [n].maximum_integer < p_valid_integer_range^.minimum_integer THEN
              CYCLE /check_integer_range_overlap/;
            IFEND;

            IF variable_attributes [n].minimum_integer > p_valid_integer_range^.maximum_integer THEN
              CYCLE /check_integer_range_overlap/;
            IFEND;

            osp$set_status_abnormal (fdc$format_display_identifier, fde$range_overlap, '', status);
            osp$append_status_integer (osc$status_parameter_delimiter, variable_attributes [n].
                  minimum_integer, 10, FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter, variable_attributes [n].
                  maximum_integer, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_variable_definition^.name,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          FOREND /check_integer_range_overlap/;

{ The new range is valid.

          allocate_valid_integer (p_form_variable_definition^.valid_integer_ranges, p_valid_integer_range);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          p_valid_integer_range^.minimum_integer := variable_attributes [n].minimum_integer;
          p_valid_integer_range^.maximum_integer := variable_attributes [n].maximum_integer;
          variable_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$add_valid_real_range =
          IF variable_attributes [n].minimum_real > variable_attributes [n].maximum_real THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_real_range, '', status);
            STRINGREP (real_string, real_length, variable_attributes [n].minimum_real: 10);
            osp$append_status_parameter (osc$status_parameter_delimiter, real_string, status);
            STRINGREP (real_string, real_length, variable_attributes [n].maximum_real: 10);
            osp$append_status_parameter (osc$status_parameter_delimiter, real_string, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_variable_definition^.name,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          p_valid_real_ranges := fdp$ptr_valid_reals (p_form_variable_definition^.valid_real_ranges,
                p_form_module);

{ The range of reals must not overlap.

        /check_real_range_overlap/
          FOR valid_real_index := 1 TO p_form_variable_definition^.valid_real_ranges.active_number DO
            p_valid_real_range := ^p_valid_real_ranges^ [valid_real_index];
            IF variable_attributes [n].maximum_real < p_valid_real_range^.minimum_real THEN
              CYCLE /check_real_range_overlap/;
            IFEND;

            IF variable_attributes [n].minimum_real > p_valid_real_range^.maximum_real THEN
              CYCLE /check_real_range_overlap/;
            IFEND;

            osp$set_status_abnormal (fdc$format_display_identifier, fde$range_overlap, '', status);
            STRINGREP (real_string, real_length, variable_attributes [n].minimum_real: 10);
            osp$append_status_parameter (osc$status_parameter_delimiter, real_string, status);
            STRINGREP (real_string, real_length, variable_attributes [n].maximum_real: 10);
            osp$append_status_parameter (osc$status_parameter_delimiter, real_string, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_variable_definition^.name,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          FOREND /check_real_range_overlap/;

{ The new real range is valid.

          allocate_valid_real (p_form_variable_definition^.valid_real_ranges, p_valid_real_range);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          p_valid_real_range^.minimum_real := variable_attributes [n].minimum_real;
          p_valid_real_range^.maximum_real := variable_attributes [n].maximum_real;
          variable_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$add_valid_string =
          IF (variable_attributes [n].p_valid_string = NIL) THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_address, '', status);
            RETURN;
          IFEND;

          NEXT p_new_valid_string: [STRLENGTH (variable_attributes [n].p_valid_string^)] IN
                p_form_status^.p_form_module;

          IF p_new_valid_string <> NIL THEN
            IF p_form_variable_definition^.valid_strings.compare_in_upper_case THEN
              #TRANSLATE (osv$lower_to_upper, variable_attributes [n].p_valid_string^, p_new_valid_string^);
            ELSE
              p_new_valid_string^ := variable_attributes [n].p_valid_string^;
            IFEND;

            p_valid_strings := fdp$ptr_valid_strings (p_form_variable_definition^.valid_strings,
                  p_form_module);

{ The added string must be unique.

          /check_duplicate_valid_string/
            FOR valid_string_index := 1 TO p_form_variable_definition^.valid_strings.active_number DO
              p_valid_string_definition := ^p_valid_strings^ [valid_string_index];
              p_valid_string := #PTR (p_valid_string_definition^.p_valid_string, p_form_module^);
              IF p_valid_string^ = p_new_valid_string^ THEN
                osp$set_status_abnormal (fdc$format_display_identifier, fde$valid_string_exists,
                      variable_attributes [n].p_valid_string^, status);
                osp$append_status_parameter (osc$status_parameter_delimiter, p_form_variable_definition^.name,
                      status);
                osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                      status);
                RETURN;
              IFEND;
            FOREND /check_duplicate_valid_string/;

{ The added valid string is unique.

            allocate_valid_string (p_form_variable_definition^.valid_strings, p_valid_string_definition);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            p_valid_string_definition^.p_valid_string := #REL (p_new_valid_string, p_form_module^);
            variable_attributes [n].put_value_status := fdc$put_value_accepted;

          ELSE

{ No space could be allocated for added valid string.

            osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
            RETURN;
          IFEND;

        = fdc$add_var_comment =
          IF (variable_attributes [n].p_var_comment = NIL) THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_address, '', status);
            RETURN;
          IFEND;

          fdp$locate_added_variable_facts (p_form_module, p_form_variable_definition,
                p_added_variable_definition);
          fdp$add_comment (p_form_status, p_form_definition, variable_attributes [n].p_var_comment,
                p_added_variable_definition^.comment_definitions, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          variable_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$cobol_display_clause=
          IF p_form_definition^.processor <> fdc$cobol_processor THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_cobol_data_type,
                p_form_variable_definition^.name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                status);
            RETURN;
          IFEND;

          IF p_form_definition^.processor <> fdc$cobol_processor THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_cobol_data_type,
                p_form_variable_definition^.name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                status);
            RETURN;
          IFEND;

          IF p_form_variable_definition^.output_format.key = fdc$currency_output_format THEN
            fdp$change_currency_symbols (p_form_variable_definition^.output_format.
                  output_currency_format.currency_sybmol,
                  p_form_variable_definition^.output_format.
                  output_currency_format.currency_sybmol, p_form_variable_definition^.output_format.
                  output_currency_format.thousands_separator,
                  p_form_variable_definition^.output_format.output_currency_format.decimal_point);
          ELSE
            fdp$change_currency_symbols (fdc$dollar_currency_symbol, fdc$pound_currency_symbol,
                  fdc$thousands_currency_symbol, fdc$decimal_currency_symbol);
          IFEND;

          fdp$create_cobol_description (variable_attributes [n].p_cobol_display_clause^.
                 picture, fdc$display_usage, cobol_description, status);
          IF NOT status.normal THEN
            convert_cobol_status;
            RETURN;
          IFEND;

          fdp$locate_added_variable_facts (p_form_module, p_form_variable_definition,
               p_added_variable_definition);
          CASE cobol_description.cobol_category OF

{ Alphanumeric edited or signed numeric clauses are not allowed.

          = fdc$cobol_alphanumeric_edited, fdc$cobol_numeric_signed =
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_cobol_category,
                p_form_variable_definition^.name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                status);
            RETURN;

{ A display alphabetic PICTURE clause cannot have a "B" editing character.

         = fdc$cobol_alphabetic =
           #SCAN (b_edit_character, variable_attributes [n].p_cobol_program_clause^.
                 picture, scan_index, scan_found_character);
            IF scan_found_character THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$b_invalid_for_picture,
                  p_form_variable_definition^.name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
              RETURN;
            IFEND;

          ELSE
          CASEND;

         check_object_size (p_form_status, cobol_description.size,
                p_form_variable_definition^.name, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;

          #TRANSLATE (osv$lower_to_upper, variable_attributes [n].p_cobol_display_clause^.
                picture, p_added_variable_definition^.form_cobol_display_clause.
                cobol_display_clause.picture);
          p_added_variable_definition^.form_cobol_display_clause.defined := TRUE;
          p_form_variable_definition^.program_data_type := fdc$program_cobol_type;
          p_added_variable_definition^.display_cobol_description := cobol_description;
          cobol_clause_changed := TRUE;
          variable_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$cobol_program_clause=
          IF p_form_definition^.processor <> fdc$cobol_processor THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_cobol_data_type,
                p_form_variable_definition^.name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                status);
            RETURN;
          IFEND;

          IF p_form_variable_definition^.input_format.key = fdc$currency_input_format THEN
            fdp$change_currency_symbols (p_form_variable_definition^.input_format.
                  input_currency_format.currency_sybmol,
                  p_form_variable_definition^.input_format.
                  input_currency_format.currency_sybmol, p_form_variable_definition^.input_format.
                  input_currency_format.thousands_separator,
                  p_form_variable_definition^.input_format.input_currency_format.decimal_point);
          ELSE
            fdp$change_currency_symbols (fdc$dollar_currency_symbol, fdc$pound_currency_symbol,
                  fdc$thousands_currency_symbol, fdc$decimal_currency_symbol);
          IFEND;

          fdp$create_cobol_description (variable_attributes [n].p_cobol_program_clause^.
                 picture, variable_attributes [n].p_cobol_program_clause^.usage,
                 cobol_description, status);
          IF NOT status.normal THEN
            convert_cobol_status;
            RETURN;
          IFEND;

          fdp$locate_added_variable_facts (p_form_module, p_form_variable_definition,
               p_added_variable_definition);

          CASE cobol_description.cobol_category OF

{ Edited data cannot be manipulated in the COBOL program.

          = fdc$cobol_numeric_edited, fdc$cobol_alphanumeric_edited =
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_cobol_category,
                p_form_variable_definition^.name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                status);
            RETURN;

{ A program alphabetic PICTURE clause cannot have a "B" editing character.

          = fdc$cobol_alphabetic =
            #SCAN (b_edit_character, variable_attributes [n].p_cobol_program_clause^.
                 picture, scan_index, scan_found_character);

            IF scan_found_character THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$b_invalid_for_picture,
                  p_form_variable_definition^.name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
              RETURN;
            IFEND;
          ELSE { All other categories are valid.}
          CASEND;

          p_added_variable_definition^.form_cobol_program_clause.defined := TRUE;
          p_form_variable_definition^.program_data_type := fdc$program_cobol_type;
          p_form_variable_definition^.program_variable_length := cobol_description.size;
          p_added_variable_definition^.form_cobol_program_clause.
                cobol_program_clause.usage := variable_attributes [n].
                p_cobol_program_clause^.usage;
          #TRANSLATE (osv$lower_to_upper, variable_attributes [n].p_cobol_program_clause^.
                picture, p_added_variable_definition^.form_cobol_program_clause.
                cobol_program_clause.picture);
          p_added_variable_definition^.program_cobol_description := cobol_description;
          cobol_clause_changed := TRUE;
          variable_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$delete_valid_integer_range =
          p_valid_integer_ranges := fdp$ptr_valid_integers (p_form_variable_definition^.valid_integer_ranges,
                p_form_module);
          FOR valid_integer_index := 1 TO p_form_variable_definition^.valid_integer_ranges.active_number DO
            p_valid_integer_range := ^p_valid_integer_ranges^ [valid_integer_index];
            IF p_valid_integer_range^.minimum_integer = variable_attributes [n].minimum_integer THEN
              IF p_valid_integer_range^.maximum_integer = variable_attributes [n].maximum_integer THEN
                p_valid_integer_range^ := p_valid_integer_ranges^
                      [p_form_variable_definition^.valid_integer_ranges.active_number];
                p_form_variable_definition^.valid_integer_ranges.active_number :=
                      p_form_variable_definition^.valid_integer_ranges.active_number - 1;
                variable_attributes [n].put_value_status := fdc$put_value_accepted;
                EXIT /process_variable_attribute/;
              IFEND;
            IFEND;
          FOREND;

{ The specified integer range was not created.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_integer_range, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, variable_attributes [n].minimum_integer,
                10, FALSE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, variable_attributes [n].maximum_integer,
                10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_variable_definition^.name,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;

        = fdc$delete_valid_real_range =
          p_valid_real_ranges := fdp$ptr_valid_reals (p_form_variable_definition^.valid_real_ranges,
                p_form_module);
          FOR valid_real_index := 1 TO p_form_variable_definition^.valid_real_ranges.active_number DO
            p_valid_real_range := ^p_valid_real_ranges^ [valid_real_index];
            IF p_valid_real_range^.minimum_real = variable_attributes [n].minimum_real THEN
              IF p_valid_real_range^.maximum_real = variable_attributes [n].maximum_real THEN
                p_valid_real_range^ := p_valid_real_ranges^ [p_form_variable_definition^.valid_real_ranges.
                      active_number];
                p_form_variable_definition^.valid_real_ranges.active_number :=
                      p_form_variable_definition^.valid_real_ranges.active_number - 1;
                variable_attributes [n].put_value_status := fdc$put_value_accepted;
                EXIT /process_variable_attribute/;
              IFEND;
            IFEND;
          FOREND;

{ The specified real range was not created.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_real_range, '', status);
          STRINGREP (real_string, real_length, variable_attributes [n].minimum_real: 10);
          osp$append_status_parameter (osc$status_parameter_delimiter, real_string, status);
          STRINGREP (real_string, real_length, variable_attributes [n].maximum_real: 10);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_variable_definition^.name,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;

        = fdc$delete_valid_string =
          IF (variable_attributes [n].p_valid_string = NIL) THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_address,
                  p_form_definition^.form_name, status);
            RETURN;
          IFEND;

          p_valid_strings := fdp$ptr_valid_strings (p_form_variable_definition^.valid_strings, p_form_module);
          FOR valid_string_index := 1 TO p_form_variable_definition^.valid_strings.active_number DO
            p_valid_string_definition := ^p_valid_strings^ [valid_string_index];
            p_valid_string := #PTR (p_valid_string_definition^.p_valid_string, p_form_module^);
            IF p_valid_string^ = variable_attributes [n].p_valid_string^ THEN
              p_valid_string_definition^ := p_valid_strings^ [p_form_variable_definition^.valid_strings.
                    active_number];
              p_form_variable_definition^.valid_strings.active_number :=
                    p_form_variable_definition^.valid_strings.active_number - 1;
              variable_attributes [n].put_value_status := fdc$put_value_accepted;
              EXIT /process_variable_attribute/;
            IFEND;
          FOREND;

{ The specified valid string was not created.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$unknown_valid_string,
                p_form_variable_definition^.name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name, status);
          RETURN;

        = fdc$delete_var_comments =
          fdp$locate_added_variable_facts (p_form_module, p_form_variable_definition,
               p_added_variable_definition);
          p_comment_definitions := fdp$ptr_comments (p_added_variable_definition^.comment_definitions,
                p_form_module);
          IF p_comment_definitions = NIL THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$no_comments_to_delete,
                  p_form_variable_definition^.name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          fdp$rel_comments (NIL, p_form_module, p_added_variable_definition^.comment_definitions);
          variable_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$error_display =
          p_form_variable_definition^.error_displays := variable_attributes [n].display_attribute;
          variable_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$program_data_type =
          CASE variable_attributes [n].program_data_type OF

          = fdc$program_real_type =
            IF p_form_definition^.processor = fdc$cobol_processor THEN
              fdp$locate_added_variable_facts (p_form_module, p_form_variable_definition,
                    p_added_variable_definition);
              p_added_variable_definition^.form_cobol_program_clause.defined := FALSE;
              p_added_variable_definition^.form_cobol_display_clause.defined := FALSE;
            IFEND;

            p_form_variable_definition^.program_data_type := fdc$program_real_type;
            p_form_variable_definition^.program_variable_length := fdc$real_length;

          = fdc$program_integer_type =
            IF p_form_definition^.processor = fdc$cobol_processor THEN
              fdp$locate_added_variable_facts (p_form_module, p_form_variable_definition,
                    p_added_variable_definition);
              p_added_variable_definition^.form_cobol_program_clause.defined := FALSE;
              p_added_variable_definition^.form_cobol_display_clause.defined := FALSE;
            IFEND;

            p_form_variable_definition^.program_data_type := fdc$program_integer_type;
            p_form_variable_definition^.program_variable_length := fdc$integer_length;

          = fdc$program_character_type, fdc$program_upper_case_type =
            IF p_form_definition^.processor = fdc$cobol_processor THEN
              fdp$locate_added_variable_facts (p_form_module, p_form_variable_definition,
                    p_added_variable_definition);
              p_added_variable_definition^.form_cobol_program_clause.defined := FALSE;
              p_added_variable_definition^.form_cobol_display_clause.defined := FALSE;
            IFEND;

            p_form_variable_definition^.program_data_type := variable_attributes [n].program_data_type;

          = fdc$program_cobol_type =
            p_form_variable_definition^.program_data_type := variable_attributes [n].program_data_type;

          ELSE

{ Invalid initial value key.

            osp$set_status_abnormal (fdc$format_display_identifier, fde$program_data_type,
                  p_form_definition^.form_name, status);
            RETURN;
          CASEND;
          variable_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$input_format =
            IF ((p_form_variable_definition^.program_data_type =
                  fdc$program_cobol_type) AND
                  (variable_attributes [n].input_format.key <> fdc$currency_input_format)) THEN
              osp$set_status_abnormal (fdc$format_display_identifier,
                    fde$input_format_invalid_cobol,
                    p_form_definition^.form_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  p_form_variable_definition^.name,
                  status);
              RETURN;
            IFEND;

          CASE variable_attributes [n].input_format.key OF

          = fdc$alphabetic_input_format, fdc$character_input_format, fdc$real_input_format,
                fdc$dmy_format, fdc$mdy_format, fdc$month_dd_yyyy_format, fdc$iso_date_format, fdc$ydm_format,
                fdc$signed_input_format, fdc$digits_input_format, fdc$currency_input_format =
            p_form_variable_definition^.input_format := variable_attributes [n].input_format;
            variable_attributes [n].put_value_status := fdc$put_value_accepted;

          ELSE
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_input_format_key,
                  p_form_variable_definition^.name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          CASEND;

        = fdc$io_mode =

          CASE variable_attributes [n].io_mode OF

          = fdc$program_input_output, fdc$terminal_input, fdc$terminal_input_output, fdc$terminal_output =
            p_form_variable_definition^.io_mode := variable_attributes [n].io_mode;
            variable_attributes [n].put_value_status := fdc$put_value_accepted;
            IF p_form_variable_definition^.io_mode = fdc$program_input_output THEN
              p_form_variable_definition^.screen_variable_length := 0;
            IFEND;

          ELSE
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_mode,
                  p_form_variable_definition^.name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          CASEND;

        = fdc$new_variable_name =
          fdp$validate_name (variable_attributes [n].new_variable_name, p_form_definition^.processor,
                valid_name, name_is_valid);
          IF NOT name_is_valid THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_variable_name,
                  variable_attributes [n].new_variable_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          fdp$find_variable_definition (valid_name, p_form_status^.p_form_variable_definitions,
                p_form_definition^.form_variable_definitions.active_number, p_duplicate_variable,
                variable_index, name_exists);
          IF name_exists THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$variable_name_exists,
                  variable_attributes [n].new_variable_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          fdp$find_table_definition (valid_name, p_form_status^.p_form_table_definitions,
                p_form_definition^.form_table_definitions.active_number, p_form_table_definition, table_index,
                name_exists);
          IF name_exists THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$variable_name_exists,
                  variable_attributes [n].new_variable_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          p_form_variable_definition^.name := valid_name;
          variable_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$output_format =
          IF ((p_form_variable_definition^.program_data_type =
                fdc$program_cobol_type) AND
                  (variable_attributes [n].output_format.key <> fdc$currency_output_format)) THEN
            osp$set_status_abnormal (fdc$format_display_identifier,
                  fde$output_format_invalid_cobol,
                  p_form_definition^.form_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  p_form_variable_definition^.name,
                  status);
            RETURN;
          IFEND;

{ Compute visual area on form needed to display variable in output format.

          output_format_key := variable_attributes [n].output_format.key;
          CASE output_format_key OF

          = fdc$character_output_format, fdc$currency_output_format =

{ Do nothing.

          = fdc$ydm_output_format =
            p_form_variable_definition^.screen_variable_length := 8;

          = fdc$mdy_output_format =
            p_form_variable_definition^.screen_variable_length := 8;

          = fdc$dmy_output_format =
            p_form_variable_definition^.screen_variable_length := 8;

          = fdc$iso_output_format =
            p_form_variable_definition^.screen_variable_length := 10;

          = fdc$month_dd_yyyy_out_format =
            p_form_variable_definition^.screen_variable_length := 18;

          = fdc$integer_output_format =
            p_form_variable_definition^.screen_variable_length :=
                  variable_attributes [n].output_format.integer_output_format.field_width;

          = fdc$f_output_format, fdc$e_output_format, fdc$g_output_format =
            p_form_variable_definition^.screen_variable_length :=
                  variable_attributes [n].output_format.float_output_format.field_width;

          = fdc$e_e_output_format, fdc$g_e_output_format =
            p_form_variable_definition^.screen_variable_length :=
                  variable_attributes [n].output_format.exponent_output_format.field_width;

          ELSE

{ Invalid output format key.

            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_output_format_key,
                  p_form_definition^.form_name, status);
            RETURN;
          CASEND;

          p_form_variable_definition^.output_format := variable_attributes [n].output_format;
          variable_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$process_as_event =
          osp$set_status_abnormal (fdc$format_display_identifier, fde$feature_not_implemented,
                p_form_definition^.form_name, status);
          RETURN;

        = fdc$string_compare_rules =
          p_form_variable_definition^.valid_strings.compare_in_upper_case :=
                variable_attributes [n].compare_in_upper_case;
          p_form_variable_definition^.valid_strings.compare_to_unique_substring :=
                variable_attributes [n].compare_to_unique_substring;
          variable_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$terminal_user_entry =
          p_form_variable_definition^.terminal_user_entry := variable_attributes [n].terminal_user_entry;
          variable_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$unused_variable_entry =
          variable_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$variable_error =
          error_key := variable_attributes [n].variable_error.key;
          CASE error_key OF

          = fdc$no_error_response, fdc$system_default_error =
            p_form_variable_definition^.error_definition.key := variable_attributes [n].variable_error.key;

          = fdc$error_form =
            clp$validate_name (variable_attributes [n].variable_error.error_form, valid_name, name_is_valid);
            IF NOT name_is_valid THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_error_form_name,
                    variable_attributes [n].variable_error.error_form, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                    status);
              RETURN;
            IFEND;

            p_form_variable_definition^.error_definition.key := fdc$error_form;
            p_form_variable_definition^.error_definition.error_form := valid_name;

          = fdc$error_message =
            IF (variable_attributes [n].variable_error.p_error_message = NIL) THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_address,
                    p_form_definition^.form_name, status);
              RETURN;
            IFEND;

            NEXT p_error_message: [STRLENGTH (variable_attributes [n].variable_error.p_error_message^)] IN
                  p_form_status^.p_form_module;
            IF p_error_message = NIL THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
              RETURN;
            IFEND;

            p_form_variable_definition^.error_definition.key := fdc$error_message;
            p_form_variable_definition^.error_definition.p_error_message :=
                  #REL (p_error_message, p_form_module^);
            p_error_message^ := variable_attributes [n].variable_error.p_error_message^;

          ELSE

{ Invalid error key.

            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_error_key,
                  p_form_definition^.form_name, status);
            RETURN;
          CASEND;
          variable_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$variable_help =
          help_key := variable_attributes [n].variable_help.key;
          CASE help_key OF

          = fdc$no_help_response, fdc$system_default_help =
            p_form_variable_definition^.help_definition.key := variable_attributes [n].variable_help.key;

          = fdc$help_form =
            clp$validate_name (variable_attributes [n].variable_help.help_form, valid_name, name_is_valid);
            IF NOT name_is_valid THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_help_form_name,
                    variable_attributes [n].variable_help.help_form, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                    status);
              RETURN;
            IFEND;

            p_form_variable_definition^.help_definition.key := fdc$help_form;
            p_form_variable_definition^.help_definition.help_form := valid_name;

          = fdc$help_message =
            IF (variable_attributes [n].variable_help.p_help_message = NIL) THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_address,
                    p_form_definition^.form_name, status);
              RETURN;
            IFEND;

            NEXT p_help_message: [STRLENGTH (variable_attributes [n].variable_help.p_help_message^)] IN
                  p_form_status^.p_form_module;
            IF p_help_message = NIL THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$no_space_available, '', status);
              RETURN;
            IFEND;

            p_form_variable_definition^.help_definition.key := fdc$help_message;
            p_form_variable_definition^.help_definition.p_help_message :=
                  #REL (p_help_message, p_form_module^);
            p_help_message^ := variable_attributes [n].variable_help.p_help_message^;

          ELSE

{ Invalid help.

            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_help_key,
                  p_form_definition^.form_name, status);
            RETURN;
          CASEND;
          variable_attributes [n].put_value_status := fdc$put_value_accepted;

        = fdc$variable_length =
          CASE p_form_variable_definition^.program_data_type OF

          = fdc$program_real_type =
            IF variable_attributes [n].variable_length <> fdc$real_length THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_variable_length,
                    p_form_variable_definition^.name, status);
              osp$append_status_integer (osc$status_parameter_delimiter,
                    $INTEGER (variable_attributes [n].variable_length), 10, FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                    status);
              RETURN;
            IFEND;

          = fdc$program_integer_type =
            IF variable_attributes [n].variable_length <> fdc$integer_length THEN
              osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_variable_length,
                    p_form_variable_definition^.name, status);
              osp$append_status_integer (osc$status_parameter_delimiter,
                    $INTEGER (variable_attributes [n].variable_length), 10, FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                    status);
              RETURN;
            IFEND;

          ELSE { Character data type. }
          CASEND;

          IF ((variable_attributes [n].variable_length < 1) OR
                (variable_attributes [n].variable_length > fdc$maximum_variable_length)) THEN
            osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_variable_length,
                  p_form_variable_definition^.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  $INTEGER (variable_attributes [n].variable_length), 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
                  status);
            RETURN;
          IFEND;

          p_form_variable_definition^.program_variable_length := variable_attributes [n].variable_length;
          variable_attributes [n].put_value_status := fdc$put_value_accepted;

        ELSE

{ Invalid change variable attribute key.

          osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_variable_attribute,
                p_form_definition^.form_name, status);
          RETURN;

        CASEND;
      END /process_variable_attribute/;

    FOREND /process_variable_attributes/;


{ Check consistency of COBOL program and display clauses.

    IF NOT cobol_clause_changed THEN
      RETURN;
    IFEND;


    fdp$locate_added_variable_facts (p_form_module, p_form_variable_definition,
          p_added_variable_definition);

    IF ((NOT p_added_variable_definition^.form_cobol_program_clause.defined) OR
          (NOT p_added_variable_definition^.form_cobol_display_clause.defined)) THEN
      RETURN;
    IFEND;

    CASE p_added_variable_definition^.display_cobol_description.cobol_category OF


{ A numeric display clause cannot have a alphabetic or alphanumeric program clause.

    = fdc$cobol_numeric_unsigned, fdc$cobol_numeric_edited =
      CASE p_added_variable_definition^.program_cobol_description.cobol_category OF
      = fdc$cobol_alphabetic, fdc$cobol_alphanumeric =
        osp$set_status_abnormal (fdc$format_display_identifier, fde$incompatible_display_clause,
            p_form_variable_definition^.name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
              status);
        RETURN;
      ELSE
      CASEND;

    = fdc$cobol_alphabetic =

{ An alphabetic display clause cannot have a numeric program clause.

      CASE p_added_variable_definition^.program_cobol_description.cobol_category OF

      = fdc$cobol_numeric_signed, fdc$cobol_numeric_unsigned =
        osp$set_status_abnormal (fdc$format_display_identifier, fde$incompatible_program_clause,
              p_form_variable_definition^.name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
              status);
        RETURN;
       ELSE { Other categories are compatible. }
       CASEND;

{ An alphanumeric display clause cannot have a numeric program clause.

    = fdc$cobol_alphanumeric =
      CASE p_added_variable_definition^.program_cobol_description.cobol_category OF

      = fdc$cobol_numeric_signed, fdc$cobol_numeric_unsigned =
        osp$set_status_abnormal (fdc$format_display_identifier, fde$incompatible_program_clause,
              p_form_variable_definition^.name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_form_definition^.form_name,
              status);
        RETURN;
      ELSE { Other categories are compatible. }
      CASEND;

    ELSE { Other categories are compatible. }
    CASEND;

  PROCEND change_variable;

MODEND fdm$process_variable;
*DECK DECK=FDP$ADD_COMMENT EXPAND=FALSE

  PROCEDURE [INLINE] fdp$add_comment
    (    p_form_status: ^fdt$form_status;
         p_form_definition: ^fdt$form_definition;
         p_comment: ^fdt$comment;
     VAR comment_definitions: fdt$comment_definitions;
     VAR status: ost$status);

    CONST
      comments_to_expand = 1;

    VAR
      i: fdt$comment_index,
      number_comments: fdt$number_comments,
      p_new_comment_definitions: ^array [1 .. * ] of fdt$comment_definition,
      p_old_comment_definitions: ^array [1 .. * ] of fdt$comment_definition,
      p_stored_comment: ^fdt$comment;

    status.normal := TRUE;
    p_old_comment_definitions := fdp$ptr_comments
          (comment_definitions, p_form_status^.p_form_module);
    NEXT p_stored_comment: [STRLENGTH (p_comment^)] IN
          p_form_status^.p_form_module;
    IF p_stored_comment <> NIL THEN
      p_stored_comment^ := p_comment^;
      IF p_old_comment_definitions = NIL THEN
        NEXT p_new_comment_definitions: [1 .. comments_to_expand] IN
              p_form_status^.p_form_module;
        IF p_new_comment_definitions <> NIL THEN
          fdp$rel_comments (p_new_comment_definitions,
                p_form_status^.p_form_module, comment_definitions);
          p_new_comment_definitions^ [1].p_comment :=
                #REL (p_stored_comment, p_form_status^.p_form_module^);
          comment_definitions.active_number := 1;
        ELSE
          osp$set_status_abnormal (fdc$format_display_identifier,
                fde$no_space_available, '', status);
        IFEND;
        RETURN;
      IFEND;

      { Try to use an inactive entry. }

      number_comments := comment_definitions.active_number;
      IF number_comments < comment_definitions.total_number THEN
        number_comments := number_comments + 1;
        comment_definitions.active_number := number_comments;
        p_old_comment_definitions^ [number_comments].
              p_comment := #REL (p_stored_comment,
              p_form_status^.p_form_module^);
        RETURN;
      IFEND;

      { Expand the array for comments. }

      NEXT p_new_comment_definitions: [1 .. comments_to_expand +
            number_comments] IN p_form_status^.p_form_module;
      IF p_new_comment_definitions <> NIL THEN

        { Copy old comments to new array. }

        FOR i := 1 TO number_comments DO
          p_new_comment_definitions^ [i] := p_old_comment_definitions^ [i];
        FOREND;

        fdp$rel_comments (p_new_comment_definitions,
              p_form_status^.p_form_module, comment_definitions);
        number_comments := number_comments + 1;
        comment_definitions.active_number := number_comments;
        p_new_comment_definitions^ [number_comments].
              p_comment := #REL (p_stored_comment,
              p_form_status^.p_form_module^);
      ELSE
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$no_space_available, 'allocating comments', status);
      IFEND;
    ELSE { No space for storing comment. }
      osp$set_status_abnormal (fdc$format_display_identifier,
            fde$no_space_available, 'allocating comments', status);
    IFEND;
  PROCEND fdp$add_comment;

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdp$ptr_comments
*copyc fdp$rel_comments
*copyc fdt$comment
*copyc fdt$comment_definition
*copyc fdt$comment_definitions
*copyc fdt$comment_index
*copyc fdt$form_definition
*copyc fdt$form_status
*copyc fdt$number_comments
*copyc osp$set_status_abnormal
*copyc ost$status
?? POP ??


*DECK DECK=FDP$ADD_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$add_form (form_identifier: fdt$form_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc fde$condition_identifiers
*copyc fdt$form_identifier
?? POP ??
*DECK DECK=FDP$ADD_OBJECT_TO_FORM_IMAGE EXPAND=FALSE

  PROCEDURE [XREF] fdp$add_object_to_form_image
    (    p_form_image: ^fdt$form_image;
         p_form_object_definition: ^fdt$form_object_definition);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_image
*copyc fdt$form_object_definition
?? POP ??


*DECK DECK=FDP$ALLOCATE_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] fdp$allocate_object
    (    p_form_status: ^fdt$form_status;
     VAR p_form_object_definition: ^fdt$form_object_definition;
     VAR object_index: fdt$object_index;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_object_definition
*copyc fdt$form_status
*copyc fdt$object_index
*copyc ost$status
?? POP ??

*DECK DECK=FDP$BEGIN_CREATE_FORM_MODULE EXPAND=FALSE
  PROCEDURE [XREF] fdp$begin_create_form_module
    (    form_name: ost$name;
     VAR form_identifier: fdt$form_identifier;
     VAR create_module: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$form_identifier
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=FDP$CHANGE_CURRENCY_SYMBOLS EXPAND=FALSE

  PROCEDURE [XREF] fdp$change_currency_symbols
    (    primary_money_symbol: string (1);
         secondary_money_symbol: string (1);
         thousands_separator_symbol: string (1);
         decimal_symbol: string (1));

?? PUSH (LISTEXT := ON) ??
*copyc fdc$dollar_currency_symbol
*copyc fdc$pound_currency_symbol
*copyc fdc$thousands_currency_symbol
*copyc fdc$decimal_currency_symbol
?? POP ??

*DECK DECK=FDP$CHANGE_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$change_form (form_identifier:
  fdt$form_identifier;
    VAR form_attributes: fdt$form_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$form_attributes
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$CHANGE_FORM_RECORD EXPAND=FALSE
 PROCEDURE [XREF] fdp$change_form_record (form_identifier: fdt$form_identifier;
    VAR record_attributes: fdt$record_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$record_attributes
*copyc fde$condition_identifiers
*copyc ost$status
?? POP ??
*DECK DECK=FDP$CHANGE_OBJECT EXPAND=FALSE
 PROCEDURE [XREF] fdp$change_object (form_identifier: fdt$form_identifier;
        x_position: fdt$x_position;
        y_position: fdt$y_position;
    VAR object_attributes: fdt$object_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$x_position
*copyc fdt$y_position
*copyc fdt$object_attributes
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$CHANGE_SCREEN EXPAND=FALSE

  PROCEDURE [XREF] fdp$change_screen
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=FDP$CHANGE_STORED_OBJECT EXPAND=FALSE
  PROCEDURE [XREF] fdp$change_stored_object
    (    form_identifier: fdt$form_identifier;
         name: ost$name;
         occurrence: fdt$occurrence;
         text: fdt$text;
         display_attribute_set: fdt$display_attribute_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$display_attribute_set
*copyc fdt$form_identifier
*copyc fdt$occurrence
*copyc fdt$text
*copyc fde$condition_identifiers
*copyc ost$name
*copyc ost$status
?? POP ??

*DECK DECK=FDP$CHANGE_TABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$change_table (form_identifier: fdt$form_identifier;
        table_name: ost$name;
    VAR table_attributes: fdt$table_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$table_attributes
*copyc ost$name
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$CHANGE_TABLE_SIZE EXPAND=FALSE

  PROCEDURE [XREF] fdp$change_table_size
    (    form_identifier: fdt$form_identifier;
         table_name: ost$name;
         table_size: fdt$table_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$form_identifier
*copyc fdt$table_size
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=FDP$CHANGE_VARIABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$change_variable (form_identifier:
  fdt$form_identifier;
        variable_name: ost$name;
    VAR variable_attributes: fdt$variable_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$variable_attributes
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$CHECK_FOR_ACTIVE_FORM EXPAND=FALSE

  PROCEDURE [INLINE] fdp$check_for_active_form
    (    form_identifier: fdt$form_identifier;
     VAR p_form_status: ^fdt$form_status;
     VAR status: ost$status);

    fdp$find_form_status (form_identifier, p_form_status, status);
    IF status.normal THEN
      IF p_form_status^.added OR p_form_status^.combined THEN
        IF p_form_status^.push_count <> 0 THEN
          osp$set_status_abnormal (fdc$format_display_identifier,
                fde$form_pushed, p_form_status^.p_form_definition^.form_name,
                status);
        IFEND;

      ELSE { The form is not currently added. Some operations on the form }
        {are not valid. }
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$form_not_scheduled, p_form_status^.p_form_definition^.
              form_name, status);
      IFEND;
    IFEND;
  PROCEND fdp$check_for_active_form;

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdp$find_form_status
*copyc fdt$form_identifier
*copyc fdt$form_status
*copyc ost$status
*copyc osp$set_status_abnormal
?? POP ??
*DECK DECK=FDP$CHECK_FOR_OVERLAYED_OBJECTS EXPAND=FALSE
  PROCEDURE [XREF] fdp$check_for_overlayed_objects
    (    p_form_image: ^fdt$form_image;
         p_form_object_definition: ^fdt$form_object_definition;
         form_name: ost$name;
     VAR status: ost$status);

*copyc fdt$form_image
*copyc fdt$form_object_definition
*copyc ost$name
*copyc ost$status
*DECK DECK=FDP$CHECK_OBJECT_INSIDE_FORM EXPAND=FALSE

  PROCEDURE [XREF] fdp$check_object_inside_form
    (    form_area: fdt$form_area;
         p_form_object_definition: ^fdt$form_object_definition;
         form_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_area
*copyc fdt$form_object_definition
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=FDP$CLOSE_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$close_form (form_identifier: fdt$form_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$COMBINE_FORM EXPAND=FALSE

  PROCEDURE [XREF] fdp$combine_form
    (    added_form_identifier: fdt$form_identifier;
         combine_form_identifier: fdt$form_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$form_identifier
*copyc ost$status
?? POP ??
*DECK DECK=FDP$COMBINE_FORM_EVENTS EXPAND=FALSE

  PROCEDURE [XREF] fdp$combine_form_events
    (    added_form_identifier: fdt$form_identifier;
         combine_form_identifier: fdt$form_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$form_identifier
*copyc ost$status
?? POP ??
*DECK DECK=FDP$CONVERT_TERMINAL_STATUS EXPAND=FALSE
 PROCEDURE [XREF] fdp$convert_terminal_status (terminal_status: ost$status;
    VAR new_status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=FDP$CONVERT_TO_COBOL_NAME EXPAND=FALSE

  PROCEDURE [INLINE] fdp$convert_to_cobol_name
    (VAR name: ost$name);

    TYPE
      char_set = set of char;

    VAR
      bad_character: char_set,
      found_bad_character: boolean,
      n: 1 .. 31,
      string_index: 1 .. 31,
      string_length: 1 .. 31,
      scratch_name: ost$name;

    #TRANSLATE (fdv$to_cobol, name, scratch_name);

    found_bad_character := TRUE;
    name := scratch_name;
    bad_character := $char_set ['?'];
    WHILE found_bad_character DO
      #SCAN (bad_character, scratch_name, string_index, found_bad_character);
      IF found_bad_character THEN
        name (string_index, * ) := scratch_name (string_index + 1, * );
        scratch_name := name;
      IFEND;
    WHILEND;

    IF name (1, 1) = '-' THEN
      name (1, * ) := scratch_name (2, * );
    IFEND;

    name (31, * ) := ' ';
    string_length := clp$trimmed_string_size (name);
    WHILE (name (string_length, 1) = '-') DO
      name (string_length, * ) := '  ';
      IF string_length <> 1 THEN
        string_length := string_length - 1;
      IFEND;
    WHILEND;

  PROCEND fdp$convert_to_cobol_name;

?? PUSH (LISTEXT := ON) ??
*copyc fdv$to_cobol
*copyc ost$name
*copyc clp$trimmed_string_size
?? POP ??
*DECK DECK=FDP$CONVERT_TO_FORTRAN_NAME EXPAND=FALSE

  PROCEDURE [INLINE] fdp$convert_to_fortran_name
    (    form_processor: fdt$form_processor;
     VAR name: ost$name);

    TYPE
      char_set = set of char;

    VAR
      bad_character: char_set,
      found_bad_character: boolean,
      string_index: 1 .. 31,
      scratch_name: ost$name;

    IF form_processor = fdc$extended_fortran_processor THEN
      #TRANSLATE (fdv$to_extended_fortran, name, scratch_name);
    ELSE
      #TRANSLATE (fdv$to_fortran, name, scratch_name);
    IFEND;

    found_bad_character := TRUE;
    name := scratch_name;
    bad_character := $char_set ['?'];
    WHILE found_bad_character DO
      #SCAN (bad_character, scratch_name, string_index, found_bad_character);
      IF found_bad_character THEN
        name (string_index, * ) := scratch_name (string_index + 1, * );
        scratch_name := name;
      IFEND;
    WHILEND;

    CASE form_processor OF
    = fdc$ansi_fortran_processor =
      name := scratch_name (1, 6);

    = fdc$cdc_fortran_processor =
      name := scratch_name (1, 7);

    ELSE {fdc$extended_fortran_processor}
    CASEND;

  PROCEND fdp$convert_to_fortran_name;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_processor
*copyc fdv$to_extended_fortran
*copyc fdv$to_fortran
*copyc ost$name
?? POP ??
*DECK DECK=FDP$CONVERT_TO_PROGRAM_VALUE EXPAND=FALSE
PROCEDURE [XREF] fdp$convert_to_program_value
    (    form_identifier: fdt$form_identifier;
         variable_name: ost$name;
         p_text: ^fdt$text;
     VAR variable_value: fdt$variable_value;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$form_identifier
*copyc fdt$text
*copyc fdt$variable_status
*copyc fdt$variable_value
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=FDP$CONVERT_TO_PROGRAM_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] fdp$convert_to_program_variable
    (    program_data_type: fdt$program_data_type;
         p_program_variable: {output} ^cell;
         program_variable_length: fdt$program_variable_length;
         input_format: fdt$input_format;
         p_screen_variable: ^fdt$text;
         screen_variable_length: fdt$text_length;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$input_format
*copyc fdt$program_data_type
*copyc fdt$program_variable_length
*copyc fdt$text
*copyc fdt$text_length
*copyc fdt$variable_status
*copyc ost$status
?? POP ??
*DECK DECK=FDP$CONVERT_TO_SCREEN_VALUE EXPAND=FALSE
PROCEDURE [XREF] fdp$convert_to_screen_value
    (    form_identifier: fdt$form_identifier;
         variable_name: ost$name;
         variable_value: fdt$variable_value;
         p_text: {output} ^fdt$text;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$form_identifier
*copyc fdt$text
*copyc fdt$variable_status
*copyc fdt$variable_value
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=FDP$CONVERT_TO_SCREEN_VARIABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$convert_to_screen_variable (program_data_type:
  fdt$program_data_type;
        p_program_variable: ^cell;
        program_variable_length: fdt$program_variable_length;
        output_format: fdt$output_format;
        p_screen_variable: ^fdt$text;
        screen_variable_length: fdt$text_length;
    VAR variable_status: fdt$variable_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$program_data_type
*copyc fdt$program_variable_length
*copyc fdt$output_format
*copyc fdt$text
*copyc fdt$text_length
*copyc fdt$variable_status
*copyc ost$status
?? POP ??
*DECK DECK=FDP$CONVERT_YYMMDD_TO_DATE_TIME EXPAND=FALSE

  PROCEDURE [XREF] fdp$convert_yymmdd_to_date_time
    (    yymmdd: integer;
     VAR date_time: clt$date_time;
     VAR variable_status: fdt$variable_status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$date_time
*copyc fdt$variable_status
?? POP ??
*DECK DECK=FDP$COPY_AREA EXPAND=FALSE
 PROCEDURE [XREF] fdp$copy_area (form_identifier: fdt$form_identifier;
        from_x_position: fdt$x_position;
        from_y_position: fdt$y_position;
        width: fdt$width;
        height: fdt$height;
        to_x_position: fdt$x_position;
        to_y_position: fdt$y_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$x_position
*copyc fdt$y_position
*copyc fdt$width
*copyc fdt$height
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$COPY_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$copy_form (from_form_identifier: fdt$form_identifier;
    VAR to_form_identifier: fdt$form_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$CREATE_COBOL_DESCRIPTION EXPAND=FALSE

  PROCEDURE [XREF] fdp$create_cobol_description
    (    cobol_picture_symbols: fdt$cobol_picture_symbols;
         usage: fdt$usage;
     VAR cobol_description: fdt$cobol_description;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$cobol_description
*copyc fdt$cobol_picture_symbols
*copyc fdt$usage
*copyc ost$status
?? POP ??

*DECK DECK=FDP$CREATE_CONSTANT_TEXT EXPAND=FALSE
 PROCEDURE [XREF] fdp$create_constant_text (design_form_identifier:
  fdt$form_identifier;
        target_form_identifier: fdt$form_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$CREATE_DESIGN_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$create_design_form (VAR form_identifier:
  fdt$form_identifier;
    VAR form_attributes: fdt$form_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$form_attributes
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$CREATE_DESIGN_TEXT EXPAND=FALSE
 PROCEDURE [XREF] fdp$create_design_text (target_form_identifier:
  fdt$form_identifier;
        design_form_identifier: fdt$form_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??

*DECK DECK=FDP$CREATE_EVENT_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$create_event_form (event_menus: array [1 .. * ] OF
  fdt$event_menu;
    VAR form_attributes: fdt$form_attributes;
    VAR form_identifier: fdt$form_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$event_menu
*copyc fdt$form_attributes
*copyc fdt$form_identifier
*copyc ost$status
?? POP ??
*DECK DECK=FDP$CREATE_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$create_form (VAR form_identifier: fdt$form_identifier;
    VAR form_attributes: fdt$form_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$form_attributes
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??

*DECK DECK=FDP$CREATE_FORM_EVENTS EXPAND=FALSE

  PROCEDURE [XREF] fdp$create_form_events
    (    form_identifier: fdt$form_identifier;
         display_attribute_set: fdt$display_attribute_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$display_attribute_set
*copyc fdt$form_identifier
*copyc ost$status
?? POP ??
*DECK DECK=FDP$CREATE_FORM_STATUS EXPAND=FALSE
 PROCEDURE [XREF] fdp$create_form_status (VAR form_identifier:
  fdt$form_identifier;
    VAR p_form_status: ^fdt$form_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$object_definition_key
*copyc fdt$form_status
*copyc ost$status
*copyc fde$condition_identifiers
*copyc cst$event_identifier
?? POP ??
*DECK DECK=FDP$CREATE_MARK EXPAND=FALSE
 PROCEDURE [XREF] fdp$create_mark (form_identifier: fdt$form_identifier;
        start_x_position: fdt$x_position;
        start_y_position: fdt$y_position;
        end_x_position: fdt$x_position;
        end_y_position: fdt$y_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$x_position
*copyc fdt$y_position
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$CREATE_MESSAGE_FORM EXPAND=FALSE

  PROCEDURE [XREF] fdp$create_message_form
    (VAR form_identifier: fdt$form_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$form_identifier
*copyc ost$status
?? POP ??
*DECK DECK=FDP$CREATE_OBJECT EXPAND=FALSE
 PROCEDURE [XREF] fdp$create_object (form_identifier: fdt$form_identifier;
        x_position: fdt$x_position;
        y_position: fdt$y_position;
        object_definition: fdt$object_definition;
    VAR object_attributes: fdt$object_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$x_position
*copyc fdt$y_position
*copyc fdt$object_definition
*copyc fdt$object_attributes
*copyc fde$condition_identifiers
*copyc ost$status
?? POP ??
*DECK DECK=FDP$CREATE_STORED_OBJECT EXPAND=FALSE
  PROCEDURE [XREF] fdp$create_stored_object
    (    form_identifier: fdt$form_identifier;
         name: ost$name;
         occurrence: fdt$occurrence;
         text: fdt$text;
         display_attribute_set: fdt$display_attribute_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$display_attribute_set
*copyc fdt$form_identifier
*copyc fdt$occurrence
*copyc fdt$text
*copyc fde$condition_identifiers
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=FDP$CREATE_TABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$create_table (form_identifier: fdt$form_identifier;
        table_name: ost$name;
    VAR table_attributes: fdt$table_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc fdt$form_identifier
*copyc fdt$table_attributes
*copyc fde$condition_identifiers
*copyc ost$name
?? POP ??

*DECK DECK=FDP$CREATE_VARIABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$create_variable (form_identifier: fdt$form_identifier;
        variable_name: ost$name;
    VAR variable_attributes: fdt$variable_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc fdt$form_identifier
*copyc fdt$variable_attributes
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$DATE_VARIABLE EXPAND=FALSE

  FUNCTION [INLINE] fdp$date_variable
    (    p_form_variable_definition: ^fdt$form_variable_definition): boolean;

?? PUSH (LISTEXT := ON) ??

    fdp$date_variable := (p_form_variable_definition <> NIL) AND
          (p_form_variable_definition^.output_format.key IN $output_format_key_set
          [fdc$ydm_output_format, fdc$dmy_output_format, fdc$mdy_output_format, fdc$iso_output_format,
          fdc$month_dd_yyyy_out_format]) OR (p_form_variable_definition^.input_format.key IN
          $fdt$input_format_key_set [fdc$ydm_format, fdc$dmy_format, fdc$mdy_format, fdc$iso_date_format,
          fdc$month_dd_yyyy_format]);

  FUNCEND fdp$date_variable;

  TYPE
    output_format_key_set = set of fdt$output_format_key;

*copyc fdt$form_variable_definition
*copyc fdt$input_format_key_set
*copyc fdt$output_format_key
?? POP ??
*DECK DECK=FDP$DELETE_AREA EXPAND=FALSE
 PROCEDURE [XREF] fdp$delete_area (form_identifier: fdt$form_identifier;
        x_position: fdt$x_position;
        y_position: fdt$y_position;
        width: fdt$width;
        height: fdt$height;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$x_position
*copyc fdt$y_position
*copyc fdt$width
*copyc fdt$height
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$DELETE_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$delete_form (form_identifier: fdt$form_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc fdt$form_identifier
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$DELETE_MARK EXPAND=FALSE
 PROCEDURE [XREF] fdp$delete_mark (form_identifier: fdt$form_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$DELETE_OBJECT EXPAND=FALSE
 PROCEDURE [XREF] fdp$delete_object (form_identifier: fdt$form_identifier;
        x_position: fdt$x_position;
        y_position: fdt$y_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$x_position
*copyc fdt$y_position
*copyc fde$condition_identifiers
*copyc ost$status
?? POP ??
*DECK DECK=FDP$DELETE_SCREEN_CHANGES EXPAND=FALSE

  PROCEDURE [XREF] fdp$delete_screen_changes
    (    form_identifier: fdt$form_identifier;
     VAR form_added: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
?? POP ??
*DECK DECK=FDP$DELETE_STORED_OBJECT EXPAND=FALSE
  PROCEDURE [XREF] fdp$delete_stored_object
    (    form_identifier: fdt$form_identifier;
         name: ost$name;
         occurrence: fdt$occurrence;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$occurrence
*copyc fde$condition_identifiers
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=FDP$DELETE_TABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$delete_table (form_identifier: fdt$form_identifier;
        table_name: ost$name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc ost$name
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$DELETE_VARIABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$delete_variable (form_identifier: fdt$form_identifier;
        variable_name: ost$name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc ost$name
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$EDIT_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$edit_form (form_identifier: fdt$form_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$END_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$end_form (form_identifier: fdt$form_identifier;
        p_sequence: ^SEQ ( * );
    VAR number_errors: fdt$number_errors;
    VAR p_errors: ^SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc fde$condition_identifiers
*copyc fdt$error_header
*copyc fdt$error_input_conversion
*copyc fdt$error_invalid_value
*copyc fdt$error_no_table_object
*copyc fdt$error_no_table_variable
*copyc fdt$error_no_variable_def
*copyc fdt$error_no_variable_object
*copyc fdt$error_output_conversion
*copyc fdt$error_unequal_tbl_obj_width
*copyc fdt$form_identifier
*copyc fdt$number_errors
?? POP ??






*DECK DECK=FDP$FIND_CHANGE_FORM_DEFINITION EXPAND=FALSE

  PROCEDURE [INLINE] fdp$find_change_form_definition
    (    form_identifier: fdt$form_identifier;
     VAR p_form_status: ^fdt$form_status;
     VAR status: ost$status);

    VAR
      fdv$screen_status: [XREF] fdt$screen_status;

    status.normal := TRUE;
    IF ((form_identifier > 0) AND (form_identifier <=
          UPPERBOUND (fdv$screen_status.p_forms_status^))) THEN
      p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
      IF p_form_status^.entry_used THEN
        IF p_form_status^.defined_dynamically THEN
          IF NOT p_form_status^.design_form AND
             p_form_status^.p_form_definition^.form_ended THEN
            osp$set_status_abnormal (fdc$format_display_identifier,
                  fde$cannot_change_form, p_form_status^.p_form_definition^.
                  form_name, status);
          IFEND;

        ELSE { The form was not dynamically created. }
          osp$set_status_abnormal (fdc$format_display_identifier,
                fde$cannot_change_form, p_form_status^.p_form_definition^.
                form_name, status);
        IFEND;

      ELSE { The form identifier is not assigned. }
        osp$set_status_abnormal (fdc$format_display_identifier,
              fde$invalid_form_identifier, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (form_identifier), 10, FALSE, status);
      IFEND;

    ELSE { The form identifier is out of bounds. }
      osp$set_status_abnormal (fdc$format_display_identifier,
            fde$invalid_form_identifier, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            $INTEGER (form_identifier), 10, FALSE, status);
    IFEND;

  PROCEND fdp$find_change_form_definition;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$screen_status
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$status
?? POP ??
*DECK DECK=FDP$FIND_DISPLAY_NAME EXPAND=FALSE
 PROCEDURE [INLINE] fdp$find_display_name (display_name: ost$name;
        p_display_definitions: ^array [1 .. * ] OF fdt$display_definition;
        active_number: fdt$number_object_displays;
    VAR p_display_definition: ^fdt$display_definition;
    VAR name_exists: boolean);

    VAR
      n: fdt$display_index;

    name_exists := FALSE;
    /find_display/
    FOR n := 1 TO active_number DO
      p_display_definition := ^p_display_definitions^ [n];
      IF p_display_definition^.name = display_name THEN
        name_exists := TRUE;
        EXIT /find_display/;
      IFEND;
    FOREND /find_display/;
  PROCEND fdp$find_display_name;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$display_index
*copyc ost$name
*copyc fdt$display_definition
*copyc fdt$number_object_displays
?? POP ??
*DECK DECK=FDP$FIND_FORM_DEFINITION EXPAND=FALSE

  PROCEDURE [INLINE] fdp$find_form_definition
    (    form_identifier: fdt$form_identifier;
     VAR p_form_status: ^fdt$form_status;
     VAR status: ost$status);

    VAR
      fdv$screen_status: [XREF] fdt$screen_status;

    IF fdv$screen_status.p_forms_status <> NIL THEN
      IF (form_identifier > 0) AND (form_identifier <= UPPERBOUND (fdv$screen_status.p_forms_status^)) THEN
        p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
        IF p_form_status^.entry_used THEN
          status.normal := TRUE;
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_form_identifier, '', status);
    osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (form_identifier), 10, FALSE, status);

  PROCEND fdp$find_form_definition;

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$form_identifier
*copyc fdt$screen_status
*copyc fdt$form_status
*copyc osp$set_status_abnormal
*copyc osp$append_status_integer
*copyc ost$status
?? POP ??
*DECK DECK=FDP$FIND_FORM_STATUS EXPAND=FALSE
  PROCEDURE [INLINE] fdp$find_form_status
    (    form_identifier: fdt$form_identifier;
     VAR p_form_status: ^fdt$form_status;
     VAR status: ost$status);

    VAR
      fdv$screen_status: [XREF] fdt$screen_status;

    IF fdv$screen_status.p_forms_status <> NIL THEN
      IF (form_identifier > 0) AND (form_identifier <= UPPERBOUND (fdv$screen_status.p_forms_status^)) THEN
        p_form_status := ^fdv$screen_status.p_forms_status^ [form_identifier];
        IF (p_form_status^.entry_used AND p_form_status^.opened AND
               (NOT p_form_status^.owned_by_system) AND
               (NOT p_form_status^.opened_for_query_only)) THEN
          status.normal := TRUE;
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    osp$set_status_abnormal (fdc$format_display_identifier, fde$invalid_form_identifier, '', status);
    osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (form_identifier), 10, FALSE, status);

  PROCEND fdp$find_form_status;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$form_status
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc fdt$screen_status
*copyc osp$append_status_integer
*copyc fde$condition_identifiers
?? POP ??

*DECK DECK=FDP$FIND_NEXT_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] fdp$find_next_object
    (    x_position: fdt$x_position;
         y_position: fdt$y_position;
         p_form_status: ^fdt$form_status;
     VAR object_index: fdt$object_index);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$object_index
*copyc fdt$form_status
*copyc fdt$x_position
*copyc fdt$y_position
?? POP ??
*DECK DECK=FDP$FIND_OBJECT_DEFINITION EXPAND=FALSE
 PROCEDURE [INLINE] fdp$find_object_definition (object_name: ost$name;
        occurrence: fdt$occurrence;
        p_form_object_definitions: ^array [1 .. * ] OF
      fdt$form_object_definition;
        active_number: fdt$number_objects;
    VAR p_form_object_definition: ^fdt$form_object_definition;
    VAR object_index: fdt$object_index;
    VAR object_name_exists: boolean;
    VAR object_occurrence_exists: boolean);

?? PUSH (LISTEXT := ON) ??
    object_name_exists := FALSE;
    object_occurrence_exists := FALSE;
  /find_object/
    FOR object_index := 1 TO active_number DO
      p_form_object_definition := ^p_form_object_definitions^ [object_index];
      IF p_form_object_definition^.key <> fdc$form_unused_object THEN
        IF p_form_object_definition^.name = object_name THEN
          object_name_exists := TRUE;
          IF p_form_object_definition^.occurrence = occurrence THEN
            object_occurrence_exists := TRUE;
            EXIT /find_object/;
          IFEND;
        IFEND;
      IFEND;
    FOREND /find_object/;
  PROCEND fdp$find_object_definition;
*copyc fdt$occurrence
*copyc fdt$form_object_definition
*copyc fdt$number_objects
*copyc fdt$object_index
*copyc ost$name
*copyc fdt$object_definition_key
?? POP ??
*DECK DECK=FDP$FIND_TABLE_DEFINITION EXPAND=FALSE

  PROCEDURE [INLINE] fdp$find_table_definition
    (    table_name: ost$name;
         p_form_table_definitions: ^array [1 .. * ] of
          fdt$form_table_definition;
         number_tables: fdt$number_tables;
     VAR p_form_table_definition: ^fdt$form_table_definition;
     VAR table_index: fdt$table_index;
     VAR table_exists: boolean);

    table_exists := FALSE;

  /find_table/
    FOR table_index := 1 TO number_tables DO
      p_form_table_definition := ^p_form_table_definitions^ [table_index];
      IF p_form_table_definition^.name = table_name THEN
        table_exists := TRUE;
        EXIT /find_table/;
      IFEND;
    FOREND /find_table/;
  PROCEND fdp$find_table_definition;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_table_definition
*copyc fdt$number_tables
*copyc fdt$table_index
*copyc ost$name
?? POP ??
*DECK DECK=FDP$FIND_VARIABLE_DEFINITION EXPAND=FALSE
PROCEDURE [INLINE] fdp$find_variable_definition (variable_name: ost$name;
      p_form_variable_definitions: ^array [1 .. * ] OF fdt$form_variable_definition;
      number_variables: fdt$number_variables;
  VAR p_form_variable_definition: ^fdt$form_variable_definition;
  VAR variable_index: fdt$variable_index;
  VAR variable_exists: boolean);
?? PUSH (LISTEXT := ON) ??

  variable_exists := FALSE;
  /find_variable/
  FOR variable_index := 1 TO number_variables DO
    p_form_variable_definition := ^p_form_variable_definitions^ [variable_index];
    IF p_form_variable_definition^.name = variable_name THEN
      variable_exists := TRUE;
      EXIT /find_variable/;
    IFEND;
  FOREND /find_variable/;
PROCEND fdp$find_variable_definition;
*copyc fdt$form_variable_definition
*copyc ost$name
*copyc fdt$number_variables
*copyc fdt$variable_index
?? POP ??


*DECK DECK=FDP$FORTRAN_ALIASES EXPAND=FALSE
C$    EXTERNAL (ALIAS='FDP$XADD_FORM',LANG=FTN), FDADD
C$    EXTERNAL (ALIAS='FDP$XCHANGE_TABLE_SIZE',LANG=FTN),FDCHAT
C$    EXTERNAL (ALIAS='FDP$XCLOSE_FORM',LANG=FTN),FDCLOS
C$    EXTERNAL (ALIAS='FDP$XCOMBINE_FORM',LANG=FTN),FDCOM
C$    EXTERNAL (ALIAS='FDP$XDELETE_FORM',LANG=FTN),FDDEL
C$    EXTERNAL (ALIAS='FDP$XGET_INTEGER_VARIABLE',LANG=FTN),FDGETI
C$    EXTERNAL (ALIAS='FDP$XGET_NEXT_CHANGED_VARIABLE',LANG=FTN),FDGNCV
C$    EXTERNAL (ALIAS='FDP$XGET_NEXT_EVENT',LANG=FTN),FDGETE
C$    EXTERNAL (ALIAS='FDP$XGET_NEXT_INPUT_ERROR',LANG=FTN),FDGNIE
C$    EXTERNAL (ALIAS='FDP$XGET_NEXT_OUTPUT_ERROR',LANG=FTN),FDGNOE
C$    EXTERNAL (ALIAS='FDP$XGET_REAL_VARIABLE',LANG=FTN),FDGETR
C$    EXTERNAL (ALIAS='FDP$XGET_RECORD',LANG=FTN),FDGET
C$    EXTERNAL (ALIAS='FDP$XGET_STRING_VARIABLE',LANG=FTN),FDGETS
C$    EXTERNAL (ALIAS='FDP$XOPEN_FORM',LANG=FTN),FDOPEN
C$    EXTERNAL (ALIAS='FDP$XPOP_FORMS',LANG=FTN),FDPOP
C$    EXTERNAL (ALIAS='FDP$XPOSITION_FORM',LANG=FTN),FDPOS
C$    EXTERNAL (ALIAS='FDP$XPUSH_FORMS',LANG=FTN),FDPUSH
C$    EXTERNAL (ALIAS='FDP$XREAD_FORMS',LANG=FTN),FDREAD
C$    EXTERNAL (ALIAS='FDP$XREPLACE_INTEGER_VARIABLE',LANG=FTN),FDREPI
C$    EXTERNAL (ALIAS='FDP$XREPLACE_REAL_VARIABLE',LANG=FTN),FDREPR
C$    EXTERNAL (ALIAS='FDP$XREPLACE_RECORD',LANG=FTN),FDREP
C$    EXTERNAL (ALIAS='FDP$XREPLACE_STRING_VARIABLE',LANG=FTN),FDREPS
C$    EXTERNAL (ALIAS='FDP$XRESET_FORM',LANG=FTN),FDRESF
C$    EXTERNAL (ALIAS='FDP$XRESET_OBJECT_ATTRIBUTE',LANG=FTN),FDRESO
C$    EXTERNAL (ALIAS='FDP$XSET_CURSOR_POSITION',LANG=FTN),FDSETC
C$    EXTERNAL (ALIAS='FDP$XSET_LINE_MODE',LANG=FTN),FDSETL
C$    EXTERNAL (ALIAS='FDP$XSET_OBJECT_ATTRIBUTE',LANG=FTN),FDSETO
C$    EXTERNAL (ALIAS='FDP$XSHOW_FORMS',LANG=FTN),FDSHOW
C$    EXTERNAL (ALIAS='FDP$XTAB_TO_NEXT_FIELD',LANG=FTN),FDTABN

*DECK DECK=FDP$GENERATE_FORM_MODULE EXPAND=FALSE

  PROCEDURE [XREF] fdp$generate_form_module
    (    file_id: amt$file_identifier;
         form_name: ost$name;
     VAR form_module_p: ^fdt$form_module;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc fdt$form_module
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=FDP$GENERATE_FORM_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] fdp$generate_form_variable
    (    file_id: amt$file_identifier;
         form_name: ost$name;
     VAR form_module_p: ^fdt$form_module;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc fde$condition_identifiers
*copyc fdt$form_module
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=FDP$GET_FORM_ATTRIBUTES EXPAND=FALSE
 PROCEDURE [XREF] fdp$get_form_attributes (form_identifier: fdt$form_identifier;
    VAR get_form_attributes: fdt$get_form_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$get_form_attributes
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$GET_FORM_NAMES EXPAND=FALSE
 PROCEDURE [XREF] fdp$get_form_names (form_identifier: fdt$form_identifier;
        name_selections: fdt$name_selections;
    VAR form_names: fdt$form_names;
    VAR number_names: fdt$number_names;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$name_selections
*copyc fdt$form_names
*copyc fdt$number_names
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$GET_FORM_OBJECTS EXPAND=FALSE
 PROCEDURE [XREF] fdp$get_form_objects (form_identifier: fdt$form_identifier;
    VAR form_objects: fdt$form_objects;
    VAR number_objects: fdt$number_objects;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$form_objects
*copyc fdt$number_objects
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$GET_INTEGER_VARIABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$get_integer_variable (form_identifier:
  fdt$form_identifier;
        name: ost$name;
        occurrence: fdt$occurrence;
    VAR variable: integer;
    VAR variable_status: fdt$variable_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$occurrence
*copyc fdt$variable_status
*copyc ost$status
*copyc fde$condition_identifiers
*copyc ost$name
?? POP ??
*DECK DECK=FDP$GET_MESSAGE EXPAND=FALSE
  PROCEDURE [INLINE] fdp$get_message
    (    status_condition_code: ost$status_condition_code;
     VAR message_text: fdt$message_text);

    VAR
      local_status: ost$status,
      message_status: ost$status,
      status_message: ost$status_message,
      status_message_line_count_p: ^ost$status_message_line_count,
      status_message_line_size_p: ^ost$status_message_line_size,
      status_message_p: ^ost$status_message,
      status_message_text_p: ^string ( * );

    osp$set_status_abnormal (fdc$format_display_identifier,
          status_condition_code, '', message_status);
    osp$format_message (message_status, osc$brief_message_level,
          fdc$message_variable_length, status_message, local_status);
    IF local_status.normal THEN
      status_message_p := ^status_message;
      NEXT status_message_line_count_p IN status_message_p;
      NEXT status_message_line_size_p IN status_message_p;
      NEXT status_message_text_p: [status_message_line_size_p^] IN
            status_message_p;
      message_text := status_message_text_p^;
    ELSE
      message_text := '';
    IFEND;

  PROCEND fdp$get_message;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$message_text
*copyc fde$condition_identifiers
*copyc osp$format_message
*copyc osp$set_status_abnormal
?? POP ??
*DECK DECK=FDP$GET_NEXT_CHANGED_VARIABLE EXPAND=FALSE
  PROCEDURE [XREF] fdp$get_next_changed_variable
    (    form_identifier: fdt$form_identifier;
     VAR variable_name: ost$name;
     VAR occurrence: fdt$occurrence;
     VAR change_found: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$form_identifier
*copyc fdt$occurrence
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=FDP$GET_NEXT_EVENT EXPAND=FALSE
 PROCEDURE [XREF] fdp$get_next_event (VAR event_name: ost$name;
    VAR event_normal: boolean;
    VAR event_position: fdt$event_position;
    VAR last_event: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$event_position
*copyc ost$name
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$GET_NEXT_INPUT_ERROR EXPAND=FALSE
  PROCEDURE [XREF] fdp$get_next_input_error
    (    form_identifier: fdt$form_identifier;
     VAR variable_name: ost$name;
     VAR occurrence: fdt$occurrence;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$form_identifier
*copyc fdt$occurrence
*copyc fdt$variable_status
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=FDP$GET_NEXT_OUTPUT_ERROR EXPAND=FALSE
  PROCEDURE [XREF] fdp$get_next_output_error
    (    form_identifier: fdt$form_identifier;
     VAR variable_name: ost$name;
     VAR occurrence: fdt$occurrence;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$form_identifier
*copyc fdt$occurrence
*copyc fdt$variable_status
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=FDP$GET_NUMBER_OF_OCCURRENCES EXPAND=FALSE

  PROCEDURE [XREF] fdp$get_number_of_occurrences
    (    form_identifier: fdt$form_identifier;
         variable_name: ost$name;
     VAR table_member: boolean;
     VAR occurrences: fdt$occurrence;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc ost$name
*copyc fdt$occurrence
*copyc ost$status
?? POP ??
*DECK DECK=FDP$GET_OBJECT_ATTRIBUTES EXPAND=FALSE
 PROCEDURE [XREF] fdp$get_object_attributes (form_identifier:
  fdt$form_identifier;
        x_position: fdt$x_position;
        y_position: fdt$y_position;
    VAR get_object_attributes: fdt$get_object_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$x_position
*copyc fdt$y_position
*copyc fdt$get_object_attributes
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$GET_REAL_VARIABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$get_real_variable (form_identifier: fdt$form_identifier;
        name: ost$name;
        occurrence: fdt$occurrence;
    VAR variable: real;
    VAR variable_status: fdt$variable_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc ost$name
*copyc fdt$variable_status
*copyc fdt$occurrence
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$GET_RECORD EXPAND=FALSE
 PROCEDURE [XREF] fdp$get_record (form_identifier: fdt$form_identifier;
        p_work_area: ^cell;
        work_area_length: fdt$work_area_length;
    VAR variable_status: fdt$variable_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$work_area_length
*copyc fdt$variable_status
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$GET_RECORD_ATTRIBUTES EXPAND=FALSE
 PROCEDURE [XREF] fdp$get_record_attributes (form_identifier:
  fdt$form_identifier;
    VAR get_record_attributes: fdt$get_record_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$get_record_attributes
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$GET_SCREEN_EVENTS EXPAND=FALSE
PROCEDURE [XREF] fdp$get_screen_events (var status: ost$status);
?? push(listext := on) ??
*copyc ost$status
?? POP ??
*DECK DECK=FDP$GET_SCREEN_INPUT EXPAND=FALSE

  PROCEDURE [XREF] fdp$get_screen_input
    (VAR event_name: ost$name;
     VAR event_normal: boolean;
     VAR event_position: fdt$event_position;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$event_position
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=FDP$GET_SCREEN_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] fdp$get_screen_variable
    (    form_identifier: fdt$form_identifier;
         name: ost$name;
         occurrence: fdt$occurrence;
     VAR screen_variable: fdt$text;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc ost$name
*copyc fdt$occurrence
*copyc fdt$text
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$GET_STORED_OBJECT EXPAND=FALSE
 PROCEDURE [XREF] fdp$get_stored_object (form_identifier: fdt$form_identifier;
        name: ost$name;
        occurrence: fdt$occurrence;
    VAR text: fdt$text;
    VAR text_length: fdt$text_length;
    VAR display_attribute_set: fdt$display_attribute_set;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$display_attribute_set
*copyc fdt$form_identifier
*copyc fdt$occurrence
*copyc fdt$text
*copyc fdt$text_length
*copyc fde$condition_identifiers
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=FDP$GET_STRING_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] fdp$get_string_variable
    (    form_identifier: fdt$form_identifier;
         name: ost$name;
         occurrence: fdt$occurrence;
     VAR variable: fdt$text;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc ost$name
*copyc fdt$occurrence
*copyc fdt$text
*copyc fdt$variable_status
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$GET_TABLE_ATTRIBUTES EXPAND=FALSE
 PROCEDURE [XREF] fdp$get_table_attributes (form_identifier:
  fdt$form_identifier;
        table_name: ost$name;
    VAR get_table_attributes: fdt$get_table_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$get_table_attributes
*copyc ost$name
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$GET_VARIABLE_ATTRIBUTES EXPAND=FALSE
 PROCEDURE [XREF] fdp$get_variable_attributes (form_identifier:
  fdt$form_identifier;
        variable_name: ost$name;
    VAR get_variable_attributes: fdt$get_variable_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$get_variable_attributes
*copyc ost$name
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$INITIALIZE_FORM_OBJECTS EXPAND=FALSE
  PROCEDURE [XREF] fdp$initialize_form_objects
    (    form_identifier: fdt$form_identifier;
         p_form_status: ^fdt$form_status;
         record_changes: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$form_identifier
*copyc fdt$form_status
*copyc ost$status
?? POP ??
*DECK DECK=FDP$INITIALIZE_FORM_RECORD EXPAND=FALSE
  PROCEDURE [XREF] fdp$initialize_form_record
    (    form_identifier: fdt$form_identifier;
         p_form_status: ^fdt$form_status;
         record_change: boolean;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$form_identifier
*copyc fdt$form_status
*copyc fdt$variable_status
*copyc ost$status
?? POP ??
*DECK DECK=FDP$LOCATE_ADDED_VARIABLE_FACTS EXPAND=FALSE
  PROCEDURE [INLINE] fdp$locate_added_variable_facts
    (    p_form_module: ^fdt$form_module;
         p_form_variable_definition: ^fdt$form_variable_definition;
     VAR p_added_variable_definition: ^fdt$added_variable_definition);

    VAR
      p_sequence: ^SEQ (*);

          p_sequence := #PTR (p_form_variable_definition^.additional_variable_facts.
                additional_definitions, p_form_module^);
          RESET p_sequence;
          NEXT p_added_variable_definition IN p_sequence;

  PROCEND fdp$locate_added_variable_facts;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$added_variable_definition
*copyc fdt$form_module
*copyc fdt$form_variable_definition
?? POP ??
*DECK DECK=FDP$LOCATE_VARIABLE_COMMENTS EXPAND=FALSE
  PROCEDURE fdp$locate_variable_comments
    (    p_form_status: ^fdt$form_status;
         p_form_variable_definition: ^fdt$form_variable_definition;
     VAR comment_definitions: fdt$comment_definitions);

    VAR
      p_added_variable_definition: ^fdt$added_variable_definition,
      p_sequence: ^SEQ ( * );

    IF p_form_status^.p_form_definition^.screen_formatting_version < fdc$im_smart_capability THEN
      i#move (^p_form_variable_definition^.additional_variable_facts, ^comment_definitions,
            #SIZE (comment_definitions));
    ELSE
      p_sequence := #PTR (p_form_variable_definition^.additional_variable_facts.additional_definitions,
           p_form_status^.p_form_module^);
      RESET p_sequence;
      NEXT p_added_variable_definition IN p_sequence;
      comment_definitions := p_added_variable_definition^.comment_definitions;
    IFEND;
  PROCEND fdp$locate_variable_comments;
?? PUSH (LISTEXT := ON) ??
*copyc fdt$added_variable_definition
*copyc fdt$comment_definitions
*copyc fdt$form_status
*copyc fdt$form_variable_definition
?? POP ??
*DECK DECK=FDP$MAKE_COBOL_DESCRIPTION EXPAND=FALSE
PROCEDURE [XREF] fdp$make_cobol_description
  (    cobol_picture_symbols: fdt$cobol_picture_symbols;
       cobol_usage_keyword:   fdt$cobol_usage_keyword;
       sign:     boolean;
       leading:  boolean;
       separate:  boolean;
   VAR cobol_description: fdt$cobol_description;
   VAR status:   ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$cobol_description
*copyc fdt$cobol_picture_symbols
*copyc fdt$cobol_usage_keyword
*copyc ost$status
?? POP ??

*DECK DECK=FDP$MOVE_AREA EXPAND=FALSE
 PROCEDURE [XREF] fdp$move_area (form_identifier: fdt$form_identifier;
        from_x_position: fdt$x_position;
        from_y_position: fdt$y_position;
        width: fdt$width;
        height: fdt$height;
        to_x_position: fdt$x_position;
        to_y_position: fdt$y_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$x_position
*copyc fdt$y_position
*copyc fdt$width
*copyc fdt$height
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$MOVE_COBOL_DATA EXPAND=FALSE
  PROCEDURE [XREF] fdp$move_cobol_data
    (    source_cobol_description: fdt$cobol_description;
         source_data_p: ^string ( * );
         destination_cobol_description: fdt$cobol_description;
         destination_data_p: ^string ( * );
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$cobol_description
*copyc ost$status
?? POP ??
*DECK DECK=FDP$MOVE_TO_PROGRAM_VARIABLE EXPAND=FALSE
  PROCEDURE [XREF] fdp$move_to_program_variable
    (    p_form_status: ^fdt$form_status;
         p_form_variable_definition: ^fdt$form_variable_definition;
         p_screen_variable: ^fdt$text;
         p_program_variable:{output} ^cell;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_status
*copyc fdt$form_variable_definition
*copyc fdt$text
*copyc fdt$variable_status
*copyc ost$status
?? POP ??

*DECK DECK=FDP$MOVE_TO_SCREEN_VARIABLE EXPAND=FALSE
  PROCEDURE [XREF] fdp$move_to_screen_variable
    (    p_form_status: ^fdt$form_status;
         p_form_variable_definition: ^fdt$form_variable_definition;
         p_program_variable: ^cell;
         p_screen_variable:{output} ^fdt$text;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_status
*copyc fdt$form_variable_definition
*copyc fdt$text
*copyc fdt$variable_status
*copyc ost$status
?? POP ??
*DECK DECK=FDP$OPEN_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$open_form (form_name: ost$name;
    VAR form_identifier: {input/output} fdt$form_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc fdt$form_identifier
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$OPEN_FORM_MODULE EXPAND=FALSE
 PROCEDURE [XREF] fdp$open_form_module
   (VAR form_module_p: {input/output}^fdt$form_module;
    VAR form_identifier: fdt$form_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$form_module
*copyc fdt$form_identifier
*copyc ost$status
?? POP ??
*DECK DECK=FDP$PASCAL_PROCEDURES EXPAND=FALSE

PROCEDURE fdp$xadd_form (
  VAR form_identifier: integer;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xchange_table_size (
  VAR form_identifier: integer;
      table_name: string;
  VAR table_size: integer;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xclose_form (
  VAR form_identifier: integer;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xdelete_form (
  VAR form_identifier: integer;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xget_integer_variable (
  VAR form_identifier: integer;
      variable_name: string;
  VAR occurrence: integer;
  VAR variable: integer;
  VAR variable_status: integer;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xget_next_changed_variable (
  VAR form_identifier: integer;
      variable_name: string;
  VAR occurrence: integer;
      change_found: string;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xget_next_event (
      event_name: string;
      event_normal: string;
  VAR screen_x_position: integer;
  VAR screen_y_position: integer;
  VAR form_identifier: integer;
  VAR form_x_position: integer;
  VAR form_y_position: integer;
  VAR event_type: integer;
      object_name: string;
  VAR object_occurrence: integer;
  VAR character_position: integer;
  VAR object_type: integer;
  VAR object_x_position: integer;
  VAR object_y_position: integer;
      last_event: string;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xget_real_variable (
  VAR form_identifier: integer;
      variable_name: string;
  VAR occurrence: integer;
  VAR variable: real;
  VAR variable_status: integer;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xget_string_variable (
  VAR form_identifier: integer;
      variable_name: string;
  VAR occurrence: integer;
      variable: string;
  VAR variable_status: integer;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xopen_form (
      form_name: string;
  VAR form_identifier: integer;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xpop_forms (
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xposition_form (
  VAR form_identifier: integer;
  VAR screen_x_position: integer;
  VAR screen_y_position: integer;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xpush_forms (
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xread_forms (
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xreplace_integer_variable (
  VAR form_identifier: integer;
      variable_name: string;
  VAR occurrence: integer;
  VAR variable: integer;
  VAR variable_status: integer;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xreplace_real_variable (
  VAR form_identifier: integer;
      variable_name: string;
  VAR occurrence: integer;
  VAR variable: real;
  VAR variable_status: integer;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xreplace_string_variable (
  VAR form_identifier: integer;
      variable_name: string;
  VAR occurrence: integer;
      variable: string;
  VAR variable_status: integer;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xreset_form (
  VAR form_identifier: integer;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xreset_object_attribute (
  VAR form_identifier: integer;
      object_name: string;
  VAR occurrence: integer;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xset_cursor_position (
  VAR form_identifier: integer;
      object_name: string;
  VAR occurrence: integer;
  VAR character_position: integer;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xset_line_mode (
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xset_object_attribute (
 VAR  form_identifier: integer;
      object_name: string;
  VAR occurrence: integer;
      attribute_name: string;
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xshow_forms (
  VAR status: integer);
  CYBIL_EXTERNAL;

PROCEDURE fdp$xtab_to_next_field (
  VAR status: integer);
  CYBIL_EXTERNAL;
*DECK DECK=FDP$POP_FORMS EXPAND=FALSE
 PROCEDURE [XREF] fdp$pop_forms (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$POSITION_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$position_form (form_identifier: fdt$form_identifier;
        screen_x_position: fdt$x_position;
        screen_y_position: fdt$y_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$x_position
*copyc fdt$y_position
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$PTR_COMMENTS EXPAND=FALSE
 FUNCTION [INLINE] fdp$ptr_comments (comment_definitions:
    fdt$comment_definitions;
        p_form_module: ^fdt$form_module): ^array [1 .. * ] OF
      fdt$comment_definition;

    IF comment_definitions.total_number = 0 THEN
      fdp$ptr_comments := NIL;
    ELSE
      fdp$ptr_comments := #PTR (comment_definitions.p_comment_definitions,
            p_form_module^);
    IFEND;
  FUNCEND fdp$ptr_comments;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$comment_definitions
*copyc fdt$comment_definition
?? POP ??
*DECK DECK=FDP$PTR_DISPLAYS EXPAND=FALSE
 FUNCTION [INLINE] fdp$ptr_displays (p_form_status: ^fdt$form_status): ^array [1
  .. * ] OF fdt$display_definition;

    IF p_form_status^.p_form_definition^.display_definitions.total_number = 0
          THEN
      fdp$ptr_displays := NIL;
    ELSE
      fdp$ptr_displays := #PTR (p_form_status^.p_form_definition^.
            display_definitions.p_display_definitions, p_form_status^.
            p_form_module^);
    IFEND;
  FUNCEND fdp$ptr_displays;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$display_definition
*copyc fdt$object_definition_key
*copyc fdt$form_status
?? POP ??
*DECK DECK=FDP$PTR_EVENTS EXPAND=FALSE
 FUNCTION [INLINE] fdp$ptr_events (p_form_status: ^fdt$form_status): ^array [1
  .. * ] OF fdt$event_definition;

    IF p_form_status^.p_form_definition^.event_definitions.total_number = 0
          THEN
      fdp$ptr_events := NIL;
    ELSE
      fdp$ptr_events := #PTR (p_form_status^.p_form_definition^.
            event_definitions.p_event_definitions, p_form_status^.
            p_form_module^);
    IFEND;
  FUNCEND fdp$ptr_events;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_status
*copyc fdt$event_definition
*copyc fdt$object_definition_key
?? POP ??
*DECK DECK=FDP$PTR_EVENT_COMMAND EXPAND=FALSE
 FUNCTION [INLINE] fdp$ptr_event_command (command: fdt$command,
        p_form_module: ^fdt$form_module): ^fdt$event_command;

    IF NOT command.command_exists THEN
      fdp$ptr_event_command := NIL;
    ELSE
      fdp$ptr_event_command := #PTR (command.p_command, p_form_module^);
    IFEND;
  FUNCEND fdp$ptr_event_command;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_module
?? POP ??
*copyc fdt$command

*copyc fdt$event_command
*DECK DECK=FDP$PTR_OBJECTS EXPAND=FALSE
 FUNCTION [INLINE] fdp$ptr_objects (p_form_status: ^fdt$form_status): ^array [1
  .. * ] OF fdt$form_object_definition;

    IF p_form_status^.p_form_definition^.form_object_definitions.total_number =
          0 THEN
      fdp$ptr_objects := NIL;
    ELSE
      fdp$ptr_objects := #PTR (p_form_status^.p_form_definition^.
            form_object_definitions.p_form_object_definitions, p_form_status^.
            p_form_module^);
    IFEND;
  FUNCEND fdp$ptr_objects;

?? PUSH (LISTEXT := ON) ??
*copyc fdp$ptr_objects
*copyc fdt$form_status
*copyc fdt$form_object_definition
*copyc fdt$object_definition_key
?? POP ??
*DECK DECK=FDP$PTR_RECORD_DEFINITIONS EXPAND=FALSE
 FUNCTION [INLINE] fdp$ptr_record_definitions (p_form_status: ^fdt$form_status):
  ^ array [1 .. * ] OF fdt$variable_record_definition;

    IF p_form_status^.p_form_definition^.record_definitions.total_number = 0
          THEN
      fdp$ptr_record_definitions := NIL;
    ELSE
      fdp$ptr_record_definitions := #PTR (p_form_status^.p_form_definition^.
            record_definitions.p_record_definitions, p_form_status^.
            p_form_module^);
    IFEND;
  FUNCEND fdp$ptr_record_definitions;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_status
*copyc fdt$variable_record_definition
*copyc fdt$object_definition_key
?? POP ??
*DECK DECK=FDP$PTR_SCREEN_VARIABLE EXPAND=FALSE

  PROCEDURE [INLINE] fdp$ptr_screen_variable
    (    p_screen_record: ^array [1 .. * ] of cell;
         screen_record_position: fdt$record_length;
         screen_variable_length: fdt$record_length;
     VAR p_screen_variable: ^string ( * ));

    VAR
      p_screen_sequence: ^SEQ ( * ),
      p_variable: ^array [1 .. * ] of cell;

    p_screen_sequence := #SEQ (p_screen_record^);
    RESET p_screen_sequence;
    IF screen_record_position > 1 THEN
      NEXT p_variable: [1 .. screen_record_position - 1] IN p_screen_sequence;
    IFEND;
    NEXT p_screen_variable: [screen_variable_length] IN p_screen_sequence;

  PROCEND fdp$ptr_screen_variable;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$record_length
?? POP ??
*DECK DECK=FDP$PTR_TABLES EXPAND=FALSE
 FUNCTION [INLINE] fdp$ptr_tables (p_form_status: ^fdt$form_status): ^array [1
  .. * ] OF fdt$form_table_definition;

    IF p_form_status^.p_form_definition^.form_table_definitions.total_number =
          0 THEN
      fdp$ptr_tables := NIL;
    ELSE
      fdp$ptr_tables := #PTR (p_form_status^.p_form_definition^.
            form_table_definitions.p_form_table_definitions, p_form_status^.
            p_form_module^);
    IFEND;
  FUNCEND fdp$ptr_tables;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_status
*copyc fdt$object_definition_key
*copyc fdt$form_table_definition
?? POP ??
*DECK DECK=FDP$PTR_TABLE_OBJECTS EXPAND=FALSE
 FUNCTION fdp$ptr_table_objects (table_objects: fdt$table_objects;
        p_form_module: ^fdt$form_module): ^array [1 .. * ] OF fdt$table_object;

    IF table_objects.total_number = 0 THEN
      fdp$ptr_table_objects := NIL;
    ELSE
      fdp$ptr_table_objects := #PTR (table_objects.p_table_objects,
            p_form_module^);
    IFEND;
  FUNCEND fdp$ptr_table_objects;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$table_objects
*copyc fdt$form_module
*copyc fdt$record_position
*copyc fdt$table_object
*copyc fdc$maximum_record_length
?? POP ??
*DECK DECK=FDP$PTR_TABLE_VARIABLES EXPAND=FALSE
 FUNCTION [INLINE] fdp$ptr_table_variables (table_variables:
    fdt$table_variables;
        p_form_module: ^fdt$form_module): ^array [1 .. * ] OF
      fdt$table_variable;

    IF table_variables.total_number = 0 THEN
      fdp$ptr_table_variables := NIL;
    ELSE
      fdp$ptr_table_variables := #PTR (table_variables.p_table_variables,
            p_form_module^);
    IFEND;
  FUNCEND fdp$ptr_table_variables;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$table_variables
*copyc fdt$form_module
*copyc fdt$table_variable
*copyc fdc$maximum_record_length
*copyc fdc$maximum_variables
?? POP ??
*DECK DECK=FDP$PTR_TEXT EXPAND=FALSE
 FUNCTION [INLINE] fdp$ptr_text (text_pointer: fdt$text_pointer,
        p_form_module: ^fdt$form_module): ^fdt$text;

    IF NOT text_pointer.text_exists THEN
      fdp$ptr_text := NIL;
    ELSE
      fdp$ptr_text := #PTR (text_pointer.p_text, p_form_module^);
    IFEND;
  FUNCEND fdp$ptr_text;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$text_pointer
*copyc fdt$form_module
*copyc fdt$text
?? POP ??
*DECK DECK=FDP$PTR_VALID_INTEGERS EXPAND=FALSE
 FUNCTION [INLINE] fdp$ptr_valid_integers (valid_integer_ranges:
    fdt$valid_integer_ranges;
        p_form_module: ^fdt$form_module): ^array [1 .. * ] OF
      fdt$valid_integer_range;

    IF valid_integer_ranges.total_number = 0 THEN
      fdp$ptr_valid_integers := NIL;
    ELSE
      fdp$ptr_valid_integers := #PTR (valid_integer_ranges.
            p_valid_integer_ranges, p_form_module^);
    IFEND;
  FUNCEND fdp$ptr_valid_integers;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$valid_integer_ranges
*copyc fdt$valid_integer_range
*copyc fdt$form_module
?? POP ??
*DECK DECK=FDP$PTR_VALID_REALS EXPAND=FALSE
 FUNCTION [INLINE] fdp$ptr_valid_reals (valid_real_ranges:
    fdt$valid_real_ranges;
        p_form_module: ^fdt$form_module): ^array [1 .. * ] OF
      fdt$valid_real_range;

    IF valid_real_ranges.total_number = 0 THEN
      fdp$ptr_valid_reals := NIL;
    ELSE
      fdp$ptr_valid_reals := #PTR (valid_real_ranges.p_valid_real_ranges,
            p_form_module^);
    IFEND;
  FUNCEND fdp$ptr_valid_reals;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$valid_real_ranges
*copyc fdt$form_module
*copyc fdt$valid_real_range
?? POP ??
*DECK DECK=FDP$PTR_VALID_STRINGS EXPAND=FALSE
 FUNCTION [INLINE] fdp$ptr_valid_strings (valid_strings: fdt$valid_strings;
        p_form_module: ^fdt$form_module): ^array [1 .. * ] OF
      fdt$valid_string_definition;

    IF valid_strings.total_number = 0 THEN
      fdp$ptr_valid_strings := NIL;
    ELSE
      fdp$ptr_valid_strings := #PTR (valid_strings.p_valid_strings,
            p_form_module^);
    IFEND;
  FUNCEND fdp$ptr_valid_strings;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$valid_strings
*copyc fdt$form_module
*copyc fdt$valid_string_definition
?? POP ??
*DECK DECK=FDP$PTR_VARIABLE EXPAND=FALSE
 FUNCTION [INLINE] fdp$ptr_variable (variable_pointer: fdt$variable_pointer;
        p_form_module: ^fdt$form_module): ^fdt$form_variable_definition;

    IF NOT variable_pointer.variable_exists THEN
      fdp$ptr_variable := NIL;
    ELSE
      fdp$ptr_variable := #PTR (variable_pointer.p_form_variable_definition,
            p_form_module^);
    IFEND;
  FUNCEND fdp$ptr_variable;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$variable_pointer
*copyc fdt$form_module
*copyc fdt$form_variable_definition
?? POP ??
*DECK DECK=FDP$PTR_VARIABLES EXPAND=FALSE
 FUNCTION [INLINE] fdp$ptr_variables (p_form_status: ^fdt$form_status): ^array
      [1 .. * ] OF fdt$form_variable_definition;

    IF p_form_status^.p_form_definition^.form_variable_definitions.total_number
          = 0 THEN
      fdp$ptr_variables := NIL;
    ELSE
      fdp$ptr_variables := #PTR (p_form_status^.p_form_definition^.
            form_variable_definitions.p_form_variable_definitions,
            p_form_status^.p_form_module^);
    IFEND;
  FUNCEND fdp$ptr_variables;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_status
*copyc fdt$form_variable_definition
*copyc fdt$object_definition_key
?? POP ??
*DECK DECK=FDP$PUSH_FORMS EXPAND=FALSE
 PROCEDURE [XREF] fdp$push_forms (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$READ_FORMS EXPAND=FALSE
 PROCEDURE [XREF] fdp$read_forms (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$RECORD_SCREEN_CHANGE EXPAND=FALSE
 PROCEDURE [XREF] fdp$record_screen_change (screen_change: fdt$screen_change;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$screen_change
*copyc ost$status
*copyc fdc$maximum_variables
*copyc fdt$object_definition_key
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$REL_COMMENTS EXPAND=FALSE
 PROCEDURE [INLINE] fdp$rel_comments (p_comment_definitions: ^array [1 .. * ] OF
    fdt$comment_definition;
        p_form_module: ^fdt$form_module;
    VAR comment_definitions: fdt$comment_definitions);

    IF p_comment_definitions = NIL THEN
      comment_definitions.total_number := 0;
      comment_definitions.active_number := 0;
    ELSE
      comment_definitions.p_comment_definitions := #REL (p_comment_definitions,
            p_form_module^);
      comment_definitions.total_number := UPPERBOUND (p_comment_definitions^);
    IFEND;
  PROCEND fdp$rel_comments;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$comment_definition
*copyc fdt$form_module
*copyc fdt$comment_definitions
?? POP ??
*DECK DECK=FDP$REL_DISPLAYS EXPAND=FALSE
 PROCEDURE [INLINE] fdp$rel_displays (p_display_definitions: ^array [1 .. * ] OF
    fdt$display_definition;
        p_form_status: ^fdt$form_status);

    p_form_status^.p_display_definitions := p_display_definitions;
    IF p_display_definitions = NIL THEN
      p_form_status^.p_form_definition^.display_definitions.total_number := 0;
      p_form_status^.p_form_definition^.display_definitions.active_number := 0;
    ELSE
      p_form_status^.p_form_definition^.display_definitions.
            p_display_definitions := #REL (p_display_definitions,
            p_form_status^.p_form_module^);
      p_form_status^.p_form_definition^.display_definitions.total_number :=
            UPPERBOUND (p_display_definitions^);
    IFEND;
  PROCEND fdp$rel_displays;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$display_definition
*copyc fdt$object_definition_key
*copyc fdt$form_status
?? POP ??
*DECK DECK=FDP$REL_EVENTS EXPAND=FALSE
 PROCEDURE [INLINE] fdp$rel_events (p_event_definitions: ^array [1 .. * ] OF
    fdt$event_definition;
        p_form_status: ^fdt$form_status);

    p_form_status^.p_event_definitions := p_event_definitions;
    IF p_event_definitions = NIL THEN
      p_form_status^.p_form_definition^.event_definitions.total_number := 0;
      p_form_status^.p_form_definition^.event_definitions.active_number := 0;
    ELSE
      p_form_status^.p_form_definition^.event_definitions.p_event_definitions
            := #REL (p_event_definitions, p_form_status^.p_form_module^);
      p_form_status^.p_form_definition^.event_definitions.total_number :=
            UPPERBOUND (p_event_definitions^);
    IFEND;
  PROCEND fdp$rel_events;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$event_definition
*copyc fdt$form_status
*copyc fdt$object_definition_key
?? POP ??
*DECK DECK=FDP$REL_EVENT_COMMAND EXPAND=FALSE
 PROCEDURE [INLINE] fdp$rel_event_command (p_command: ^fdt$event_command;
        p_form_module: ^fdt$form_module;
    VAR command: fdt$command);

    IF p_command = NIL THEN
      command.command_exists := FALSE;
    ELSE
      command.command_exists := TRUE;
      command.p_command := #REL (p_command, p_form_module^);
    IFEND;
  PROCEND fdp$rel_event_command;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$event_command
*copyc fdt$form_module
*copyc fdt$command
?? POP ??
*DECK DECK=FDP$REL_OBJECTS EXPAND=FALSE
 PROCEDURE [INLINE] fdp$rel_objects (p_form_object_definitions: ^array [1 .. * ]
  OF fdt$form_object_definition;
        p_form_status: ^fdt$form_status);

    p_form_status^.p_form_object_definitions := p_form_object_definitions;
    IF p_form_object_definitions = NIL THEN
      p_form_status^.p_form_definition^.form_object_definitions.total_number :=
            0;
      p_form_status^.p_form_definition^.form_object_definitions.active_number :=
            0;
    ELSE
      p_form_status^.p_form_definition^.form_object_definitions.
            p_form_object_definitions := #REL (p_form_object_definitions,
            p_form_status^.p_form_module^);
      p_form_status^.p_form_definition^.form_object_definitions.total_number :=
            UPPERBOUND (p_form_object_definitions^);
    IFEND;
  PROCEND fdp$rel_objects;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_object_definition
*copyc fdt$object_definition_key
*copyc fdt$form_status
?? POP ??
*DECK DECK=FDP$REL_RECORD_DEFINITIONS EXPAND=FALSE
 PROCEDURE [INLINE] fdp$rel_record_definitions (p_record_definitions: ^array [1
  .. * ] OF fdt$variable_record_definition;
        p_form_status: ^fdt$form_status);

    p_form_status^.p_form_record_definitions := p_record_definitions;
    IF p_record_definitions = NIL THEN
      p_form_status^.p_form_definition^.record_definitions.total_number := 0;
      p_form_status^.p_form_definition^.record_definitions.active_number := 0;
    ELSE
      p_form_status^.p_form_definition^.record_definitions.p_record_definitions
            := #REL (p_record_definitions, p_form_status^.p_form_module^);
      p_form_status^.p_form_definition^.record_definitions.total_number :=
            UPPERBOUND (p_record_definitions^);
    IFEND;
  PROCEND fdp$rel_record_definitions;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$variable_record_definition
*copyc fdt$object_definition_key
*copyc fdt$form_status
?? POP ??
*DECK DECK=FDP$REL_TABLES EXPAND=FALSE
 PROCEDURE [INLINE] fdp$rel_tables (p_form_table_definitions: ^array [1 .. * ]
  OF fdt$form_table_definition;
        p_form_status: ^fdt$form_status);

    p_form_status^.p_form_table_definitions := p_form_table_definitions;
    IF p_form_table_definitions = NIL THEN
      p_form_status^.p_form_definition^.form_table_definitions.total_number :=
            0;
      p_form_status^.p_form_definition^.form_table_definitions.active_number :=
            0;
    ELSE
      p_form_status^.p_form_definition^.form_table_definitions.
            p_form_table_definitions := #REL (p_form_table_definitions,
            p_form_status^.p_form_module^);
      p_form_status^.p_form_definition^.form_table_definitions.total_number :=
            UPPERBOUND (p_form_table_definitions^);
    IFEND;
  PROCEND fdp$rel_tables;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_table_definition
*copyc fdt$object_definition_key
*copyc fdt$form_status
?? POP ??
*DECK DECK=FDP$REL_TABLE_OBJECTS EXPAND=FALSE
 PROCEDURE [INLINE] fdp$rel_table_objects (p_table_objects: ^array [1 .. * ] OF
    fdt$table_object;
        p_form_module: ^fdt$form_module;
    VAR table_objects: fdt$table_objects);

    IF p_table_objects = NIL THEN
      table_objects.total_number := 0;
      table_objects.active_number := 0;
    ELSE
      table_objects.p_table_objects := #REL (p_table_objects, p_form_module^);
      table_objects.total_number := UPPERBOUND (p_table_objects^);
    IFEND;
  PROCEND fdp$rel_table_objects;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$table_object
*copyc fdt$form_module
*copyc fdt$table_objects
*copyc fdt$object_definition_key
*copyc fdc$maximum_record_length
*copyc fdc$maximum_variables
?? POP ??
*DECK DECK=FDP$REL_TABLE_VARIABLES EXPAND=FALSE
 PROCEDURE [INLINE] fdp$rel_table_variables (p_table_variables: ^array [1 .. * ]
  OF fdt$table_variable;
        p_form_module: ^fdt$form_module;
    VAR table_variables: fdt$table_variables);

    IF p_table_variables = NIL THEN
      table_variables.total_number := 0;
      table_variables.active_number := 0;
    ELSE
      table_variables.p_table_variables := #REL (p_table_variables,
            p_form_module^);
      table_variables.total_number := UPPERBOUND (p_table_variables^);
    IFEND;
  PROCEND fdp$rel_table_variables;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$table_variable
*copyc fdt$form_module
*copyc fdt$table_variables
*copyc fdc$maximum_record_length
*copyc fdc$maximum_variables
?? POP ??
*DECK DECK=FDP$REL_TEXT EXPAND=FALSE
 PROCEDURE fdp$rel_text (p_text: ^fdt$text;
        p_form_module: ^fdt$form_module;
    VAR text_pointer: fdt$text_pointer);

    IF p_text = NIL THEN
      text_pointer.text_exists := FALSE;
    ELSE
      text_pointer.p_text := #REL (p_text, p_form_module^);
      text_pointer.text_exists := TRUE;
    IFEND;
  PROCEND fdp$rel_text;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$text
*copyc fdt$form_module
*copyc fdt$text_pointer
?? POP ??
*DECK DECK=FDP$REL_VALID_INTEGERS EXPAND=FALSE
 PROCEDURE [INLINE] fdp$rel_valid_integers (p_valid_integer_ranges: ^array [1 ..
  * ] OF fdt$valid_integer_range;
        p_form_module: ^fdt$form_module;
    VAR valid_integer_ranges: fdt$valid_integer_ranges);

    IF p_valid_integer_ranges = NIL THEN
      valid_integer_ranges.total_number := 0;
      valid_integer_ranges.active_number := 0;
    ELSE
      valid_integer_ranges.p_valid_integer_ranges := #REL
            (p_valid_integer_ranges, p_form_module^);
      valid_integer_ranges.total_number := UPPERBOUND
            (p_valid_integer_ranges^);
    IFEND;
  PROCEND fdp$rel_valid_integers;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$valid_integer_range
*copyc fdt$form_module
*copyc fdt$valid_integer_ranges
?? POP ??
*DECK DECK=FDP$REL_VALID_REALS EXPAND=FALSE
 PROCEDURE [INLINE] fdp$rel_valid_reals (p_valid_real_ranges: ^array [1 .. * ]
  OF fdt$valid_real_range;
        p_form_module: ^fdt$form_module;
    VAR valid_real_ranges: fdt$valid_real_ranges);

    IF p_valid_real_ranges = NIL THEN
      valid_real_ranges.total_number := 0;
      valid_real_ranges.active_number := 0;
    ELSE
      valid_real_ranges.p_valid_real_ranges := #REL (p_valid_real_ranges,
            p_form_module^);
      valid_real_ranges.total_number := UPPERBOUND (p_valid_real_ranges^);
    IFEND;
  PROCEND fdp$rel_valid_reals;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$valid_real_range
*copyc fdt$form_module
*copyc fdt$valid_real_ranges
?? POP ??
*DECK DECK=FDP$REL_VALID_STRINGS EXPAND=FALSE
 PROCEDURE [INLINE] fdp$rel_valid_strings (p_valid_strings: ^array [1 .. * ] OF
    fdt$valid_string_definition;
        p_form_module: ^fdt$form_module;
    VAR valid_strings: fdt$valid_strings);

    IF p_valid_strings = NIL THEN
      valid_strings.total_number := 0;
      valid_strings.active_number := 0;
    ELSE
      valid_strings.p_valid_strings := #REL (p_valid_strings, p_form_module^);
      valid_strings.total_number := UPPERBOUND (p_valid_strings^);
    IFEND;
  PROCEND fdp$rel_valid_strings;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$valid_string_definition
*copyc fdt$form_module
*copyc fdt$valid_strings
?? POP ??
*DECK DECK=FDP$REL_VARIABLE EXPAND=FALSE
 PROCEDURE [INLINE] fdp$rel_variable (p_form_variable_definition:
      ^fdt$form_variable_definition;
        p_form_module: ^fdt$form_module;
    VAR variable_pointer: fdt$variable_pointer);

    IF p_form_variable_definition = NIL THEN
      variable_pointer.variable_exists := FALSE;
    ELSE
      variable_pointer.p_form_variable_definition := #REL
            (p_form_variable_definition, p_form_module^);
    IFEND;
  PROCEND fdp$rel_variable;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_variable_definition
*copyc fdt$form_module
*copyc fdt$variable_pointer
?? POP ??
*DECK DECK=FDP$REL_VARIABLES EXPAND=FALSE
 PROCEDURE [INLINE] fdp$rel_variables (p_form_variable_definitions: ^array [1 ..
  * ] OF fdt$form_variable_definition;
        p_form_status: ^fdt$form_status);

    p_form_status^.p_form_variable_definitions := p_form_variable_definitions;
    IF p_form_variable_definitions = NIL THEN
      p_form_status^.p_form_definition^.form_variable_definitions.total_number
            := 0;
      p_form_status^.p_form_definition^.form_variable_definitions.active_number
            := 0;
    ELSE
      p_form_status^.p_form_definition^.form_variable_definitions.
            p_form_variable_definitions := #REL (p_form_variable_definitions,
            p_form_status^.p_form_module^);
      p_form_status^.p_form_definition^.form_variable_definitions.total_number
            := UPPERBOUND (p_form_variable_definitions^);
    IFEND;
  PROCEND fdp$rel_variables;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$object_definition_key
*copyc fdt$form_variable_definition
*copyc fdt$form_status
?? POP ??
*DECK DECK=FDP$REPLACE_INTEGER_VARIABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$replace_integer_variable (form_identifier:
  fdt$form_identifier;
        name: ost$name;
        occurrence: fdt$occurrence;
        variable: integer;
    VAR variable_status: fdt$variable_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc ost$name
*copyc fdt$occurrence
*copyc fdt$variable_status
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$REPLACE_REAL_VARIABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$replace_real_variable (form_identifier:
  fdt$form_identifier;
        name: ost$name;
        occurrence: fdt$occurrence;
        variable: real;
    VAR variable_status: fdt$variable_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$occurrence
*copyc fdt$variable_status
*copyc ost$name
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$REPLACE_RECORD EXPAND=FALSE
 PROCEDURE [XREF] fdp$replace_record (form_identifier: fdt$form_identifier;
        p_work_area: ^cell;
        work_area_length: fdt$work_area_length;
    VAR variable_status: fdt$variable_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$work_area_length
*copyc fdt$variable_status
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$REPLACE_STRING_VARIABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$replace_string_variable (form_identifier:
  fdt$form_identifier;
        name: ost$name;
        occurrence: fdt$occurrence;
        variable: fdt$text;
    VAR variable_status: fdt$variable_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc ost$name
*copyc fdt$occurrence
*copyc fdt$text
*copyc fdt$variable_status
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$RESET_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$reset_form (form_identifier: fdt$form_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$RESET_OBJECT_ATTRIBUTE EXPAND=FALSE
 PROCEDURE [XREF] fdp$reset_object_attribute (form_identifier:
  fdt$form_identifier;
        object_name: ost$name;
        occurrence: fdt$occurrence;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$occurrence
*copyc ost$status
*copyc ost$name
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$SET_CURSOR_POSITION EXPAND=FALSE
  PROCEDURE [XREF] fdp$set_cursor_position
    (    form_identifier: fdt$form_identifier;
         object_name: ost$name;
         occurrence: fdt$occurrence;
         character_position: fdt$character_position;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$character_position
*copyc fdt$form_identifier
*copyc fdt$occurrence
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=FDP$SET_DISPLAY_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] fdp$set_display_attributes
    (    form_display_attributes: fdt$display_attribute_set;
         object_display_attributes: fdt$display_attribute_set;
     VAR display_attribute_set: fdt$display_attribute_set);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$display_attribute_set
?? POP ??
*DECK DECK=FDP$SET_LINE_MODE EXPAND=FALSE
  PROCEDURE [XREF] fdp$set_line_mode
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$SET_OBJECT_ATTRIBUTE EXPAND=FALSE
 PROCEDURE [XREF] fdp$set_object_attribute (form_identifier:
  fdt$form_identifier;
        object_name: ost$name;
        occurrence: fdt$occurrence;
        attribute: ost$name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc fdt$form_identifier
*copyc fdt$occurrence
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$SET_SCREEN_CURSOR EXPAND=FALSE

  PROCEDURE [XREF] fdp$set_screen_cursor
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=FDP$SHOW_FORMS EXPAND=FALSE
 PROCEDURE [XREF] fdp$show_forms (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$TAB_TO_NEXT_FIELD EXPAND=FALSE
  PROCEDURE [XREF] fdp$tab_to_next_field
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=FDP$TAB_TO_NEXT_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] fdp$tab_to_next_variable
    (    p_form_status: ^fdt$form_status;
         object_index: fdt$object_index;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_status
*copyc fdt$object_index
*copyc ost$status
?? POP ??
*DECK DECK=FDP$UPDATE_SCREEN EXPAND=FALSE

  PROCEDURE [XREF] fdp$update_screen
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=FDP$VALIDATE_COBOL_DATA EXPAND=FALSE
PROCEDURE [XREF] fdp$validate_cobol_data
    (    p_form_status: ^fdt$form_status;
         p_form_variable_definition: ^fdt$form_variable_definition;
         p_program_variable: ^cell;
     VAR p_valid_string: ^fdt$valid_string;
     VAR variable_status: fdt$variable_status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_status
*copyc fdt$form_variable_definition
*copyc fdt$valid_string
*copyc fdt$variable_status
?? POP ??
*DECK DECK=FDP$VALIDATE_INTEGER EXPAND=FALSE

  PROCEDURE [XREF] fdp$validate_integer
    (    integer_number: integer;
         valid_integer_ranges: fdt$valid_integer_ranges;
         p_form_status: ^fdt$form_status;
     VAR variable_status: fdt$variable_status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_status
*copyc fdt$valid_integer_ranges
*copyc fdt$variable_status
?? POP ??
*DECK DECK=FDP$VALIDATE_NAME EXPAND=FALSE
 PROCEDURE fdp$validate_name (potential_name: string ( * <=
    osc$max_name_size);
        form_processor: fdt$form_processor;
    VAR validated_name: ost$name;
    VAR name_is_valid: boolean);

   TYPE
      char_set = set of char;

    VAR
      name_size: ost$name_size,
      non_fortran_chars: char_set,
      scan_index: integer;

    CASE form_processor OF

    = fdc$ansi_fortran_processor =
{ An ANSI FORTRAN name must be 1-6 characters. }
{ The first character must be a letter. }
{ Characters 2-6 must be a letter or a digit. }

      name_size := clp$trimmed_string_size (potential_name);
      IF ((name_size < 1) OR (name_size > 6)) THEN
        name_is_valid := FALSE;
        EXIT fdp$validate_name;
       IFEND;

      #scan (clv$letter_char, potential_name (1, 1), scan_index,name_is_valid);
      IF name_is_valid THEN
        #scan (clv$non_letter_or_digit,potential_name (2, name_size - 1),
            scan_index,name_is_valid);
        name_is_valid := NOT name_is_valid;
        #translate (osv$lower_to_upper, potential_name, validated_name);
      IFEND;

    = fdc$cobol_processor =
{ A COBOL name must be 1-30 characters. }
{ The first and last characters cannot be a hypen. }
{ The name must contain at least one letter. }
      name_size := clp$trimmed_string_size (potential_name);
      IF NOT ((name_size > 0) AND (name_size < 31) AND
          (potential_name (1) <> '-') AND
          (potential_name (name_size) <> '-')) THEN
        name_is_valid := FALSE;
        EXIT fdp$validate_name;
      IFEND;

      #scan (clv$non_cobol_name_char, potential_name (1, name_size),
          scan_index, name_is_valid);
      name_is_valid := NOT name_is_valid;
      IF name_is_valid THEN
        #scan (clv$letter_char, potential_name (1, name_size), scan_index, name_is_valid);
        #translate (osv$lower_to_upper, potential_name, validated_name);
      IFEND;

    = fdc$cybil_processor, fdc$scl_processor, fdc$pascal_processor =
      clp$validate_name (potential_name, validated_name, name_is_valid);

    = fdc$CDC_fortran_processor =
{ A CDC FORTRAN name must be 1-7 characters. }
{ The first character must be a letter. }
{ Characters 2-7 must be a letter or a digit. }

      name_size := clp$trimmed_string_size (potential_name);
      IF ((name_size < 1) OR (name_size > 7)) THEN
        name_is_valid := FALSE;
        EXIT fdp$validate_name;
       IFEND;

      #scan (clv$letter_char, potential_name (1, 1), scan_index,name_is_valid);
      IF name_is_valid THEN
        #scan (clv$non_letter_or_digit,potential_name (2, name_size - 1),
            scan_index,name_is_valid);
        name_is_valid := NOT name_is_valid;
        #translate (osv$lower_to_upper, potential_name, validated_name);
      IFEND;

    = fdc$extended_fortran_processor =

{ An extended FORTRAN name must be 1-31 letters, digits, dollar signs, or underscores
{ beginning with a letter.

      #translate (osv$lower_to_upper, potential_name, validated_name);
      #scan (clv$letter_char, potential_name (1, 1), scan_index,name_is_valid);
      IF name_is_valid THEN
        non_fortran_chars := -$char_set ['$', '_', '0', '1', '2', '3', '4', '5',
              '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H',
              'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U',
              'V', 'W', 'X', 'Y', 'Z',];
        #SCAN (non_fortran_chars, validated_name, scan_index,  name_is_valid);
        name_is_valid := validated_name (scan_index, * ) = '';
      IFEND;

    = fdc$unknown_processor =
      name_size := clp$trimmed_string_size (potential_name);
      IF ((name_size < 1) OR (name_size > osc$max_name_size)) THEN
        name_is_valid := FALSE;
        EXIT fdp$validate_name;
       IFEND;

      #translate (osv$lower_to_upper, potential_name, validated_name);

    ELSE
      name_is_valid := FALSE;
    CASEND;

  PROCEND fdp$validate_name;

?? PUSH (LISTEXT := ON) ??
*copyc clp$trimmed_string_size
*copyc clp$validate_name
*copyc fdt$form_processor
*copyc ost$name
*copyc clv$letter_char
*copyc osv$lower_to_upper
*copyc clv$non_cobol_name_char
*copyc clv$non_letter_or_digit
?? POP ??
*DECK DECK=FDP$VALIDATE_REAL EXPAND=FALSE
  PROCEDURE [XREF] fdp$validate_real
    (    real_number: real;
         valid_real_ranges: fdt$valid_real_ranges;
         p_form_status: ^fdt$form_status;
     VAR variable_status: fdt$variable_status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_status
*copyc fdt$valid_real_ranges
*copyc fdt$variable_status
?? POP ??
*DECK DECK=FDP$VALIDATE_STRING EXPAND=FALSE
  PROCEDURE [XREF] fdp$validate_string
    (    p_text: ^fdt$text;
         text_length: fdt$text_length;
         valid_strings: fdt$valid_strings;
         p_form_status: ^fdt$form_status;
     VAR p_valid_string: ^fdt$valid_string;
     VAR variable_status: fdt$variable_status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_status
*copyc fdt$valid_string
*copyc fdt$valid_strings
*copyc fdt$variable_status
*copyc fdt$text
*copyc fdt$text_length
?? POP ??

*DECK DECK=FDP$VALIDATE_VARIABLE EXPAND=FALSE
PROCEDURE [XREF] fdp$validate_variable
    (    form_identifier: fdt$form_identifier;
         variable_name: ost$name;
         variable_value: fdt$variable_value;
     VAR variable_status: fdt$variable_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fde$condition_identifiers
*copyc fdt$form_identifier
*copyc fdt$variable_status
*copyc fdt$variable_value
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=FDP$WRITE_FORM_DEFINITION EXPAND=FALSE
 PROCEDURE [XREF] fdp$write_form_definition (form_identifier:
  fdt$form_identifier;
    VAR p_form_module: ^SEQ (*);
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$WRITE_RECORD_DEFINITION EXPAND=FALSE
 PROCEDURE [XREF] fdp$write_record_definition (form_identifier:
  fdt$form_identifier;
        file_identifier: amt$file_identifier;
        form_processor: fdt$form_processor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fdt$form_identifier
*copyc fdt$form_processor
*copyc amt$file_identifier
*copyc ost$status
*copyc fde$condition_identifiers
?? POP ??
*DECK DECK=FDP$XADD_FORM EXPAND=FALSE

  PROCEDURE [XREF] fdp$xadd_form
    (VAR form_identifier: integer;
     VAR status: integer);

*DECK DECK=FDP$XCHANGE_TABLE_SIZE EXPAND=FALSE

  PROCEDURE [XREF] fdp$xchange_table_size
    (VAR form_identifier: integer;
     VAR table_name: string ( * );
     VAR table_size: integer;
     VAR status: integer);

*DECK DECK=FDP$XCLOSE_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$xclose_form (VAR form_identifier: integer;
    VAR status: integer);
*DECK DECK=FDP$XCOMBINE_FORM EXPAND=FALSE

  PROCEDURE [XREF] fdp$xcombine_form
    (VAR added_form_identifier: integer;
     VAR combine_form_identifier: integer;
     VAR status: integer);

*DECK DECK=FDP$XDELETE_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$xdelete_form (VAR form_identifier: integer;
    VAR status: integer);
*DECK DECK=FDP$XGET_INTEGER_VARIABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$xget_integer_variable (VAR form_identifier: integer;
    VAR variable_name: string ( * );
    VAR variable_occurrence: integer;
    VAR variable: integer;
    VAR variable_status: integer;
    VAR status: integer);
*DECK DECK=FDP$XGET_NEXT_CHANGED_VARIABLE EXPAND=FALSE
  PROCEDURE [XREF] fdp$xget_next_changed_variable
    (VAR form_idenifier: integer;
     VAR variable_name: string ( * );
     VAR occurrence: integer;
     VAR change_found: string (1);
     VAR status: integer);
*DECK DECK=FDP$XGET_NEXT_EVENT EXPAND=FALSE
 PROCEDURE [XREF] fdp$get_next_event (VAR event_name: string (31);
    VAR event_normal: string (1);
    VAR screen_x_position: integer;
    VAR screen_y_position: integer;
    VAR form_identifier: integer;
    VAR form_x_position: integer;
    VAR form_y_position: integer;
    VAR event_type: integer:
    VAR object_name: string (31);
    VAR object_occurrence: integer;
    VAR character_position: integer;
    VAR object_type: integer;
    VAR object_x_position: integer;
    VAR object_y_position: integer;
    VAR last_event: string (1);
    VAR status: integer);
*DECK DECK=FDP$XGET_NEXT_INPUT_ERROR EXPAND=FALSE
  PROCEDURE [XREF] fdp$xget_next_input_error
    (VAR form_idenifier: integer;
     VAR variable_name: string ( * );
     VAR occurrence: integer;
     VAR variable_status: integer;
     VAR status: integer);
*DECK DECK=FDP$XGET_NEXT_OUTPUT_ERROR EXPAND=FALSE
  PROCEDURE [XREF] fdp$xget_next_output_error
    (VAR form_idenifier: integer;
     VAR variable_name: string ( * );
     VAR occurrence: integer;
     VAR variable_status: integer;
     VAR status: integer);
*DECK DECK=FDP$XGET_REAL_VARIABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$xget_real_variable (VAR form_identifier: integer;
    VAR variable_name: string ( * );
    VAR variable_occurrence: integer;
    VAR variable: real;
    VAR variable_status: integer;
    VAR status: integer);
*DECK DECK=FDP$XGET_RECORD EXPAND=FALSE
 PROCEDURE [XREF] fdp$xget_record (VAR form_idenifier: integer;
    VAR work_area: string (*);
    VAR variable_status: integer;
    VAR status: integer);
*DECK DECK=FDP$XGET_STRING_VARIABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$xget_string_variable (VAR form_identifier: integer;
    VAR variable_name: string ( * );
    VAR variable_occurrence: integer;
    VAR variable: string (*);
    VAR variable_status: integer;
    VAR status: integer);
*DECK DECK=FDP$XOPEN_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$xopen_form (VAR form_name: string (*);
    VAR form_identifier: integer;
    VAR status: integer);
*DECK DECK=FDP$XPOP_FORMS EXPAND=FALSE
 PROCEDURE [XREF] fdp$xpop_forms (VAR status: integer);

*DECK DECK=FDP$XPOSITION_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$xposition_form (VAR form_identifier: integer;
    VAR screen_x_position: integer;
    VAR screen_y_position: integer;
    VAR status: integer);
*DECK DECK=FDP$XPUSH_FORMS EXPAND=FALSE
 PROCEDURE [XREF] fdp$xpush_forms (VAR status: integer);
*DECK DECK=FDP$XREAD_FORMS EXPAND=FALSE
 PROCEDURE [XREF] fdp$xread_forms (VAR status: integer);
*DECK DECK=FDP$XREPLACE_INTEGER_VARIABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$xreplace_integer_variable (VAR form_identifier: integer;
    VAR variable_name: string ( * );
    VAR variable_occurrence: integer;
    VAR variable: integer;
    VAR variable_status: integer;
    VAR status: integer);
*DECK DECK=FDP$XREPLACE_REAL_VARIABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$xreplace_real_variable (VAR form_identifier: integer;
    VAR variable_name: string ( * );
    VAR variable_occurrence: integer;
    VAR variable: real;
    VAR variable_status: integer;
    VAR status: integer);
*DECK DECK=FDP$XREPLACE_RECORD EXPAND=FALSE
 PROCEDURE [XREF] fdp$xreplace_record (VAR form_identifier: integer;
    VAR work_area: string (*);
    VAR variable_status: integer;
    VAR status: integer);
*DECK DECK=FDP$XREPLACE_STRING_VARIABLE EXPAND=FALSE
 PROCEDURE [XREF] fdp$xreplace_string_variable (VAR form_identifier: integer;
    VAR variable_name: string ( * );
    VAR variable_occurrence: integer;
    VAR variable: string (*);
    VAR variable_status: integer;
    VAR status: integer);
*DECK DECK=FDP$XRESET_FORM EXPAND=FALSE
 PROCEDURE [XREF] fdp$xreset_form (VAR form_identifier: integer;
    VAR status: integer);
*DECK DECK=FDP$XRESET_OBJECT_ATTRIBUTE EXPAND=FALSE
 PROCEDURE [XREF] fdp$xreset_object_attribute (VAR form_identifier: integer;
    VAR object_name: string ( * );
    VAR object_occurrence: integer;
    VAR status: integer);
*DECK DECK=FDP$XSET_CURSOR_POSITION EXPAND=FALSE
 PROCEDURE [XREF] fdp$xset_cursor_position (VAR form_identifier: integer;
    VAR object_name: ost$name;
    VAR object_occurrence: integer;
    VAR object_character_position: integer;
    VAR status: integer);
*DECK DECK=FDP$XSET_LINE_MODE EXPAND=FALSE
 PROCEDURE [XREF] fdp$xset_line_mode (VAR status: integer);
*DECK DECK=FDP$XSET_OBJECT_ATTRIBUTE EXPAND=FALSE
 PROCEDURE [XREF] fdp$xset_object_attribute (VAR form_identifier: integer;
    VAR object_name: string ( * );
    VAR object_occurrence: integer;
    VAR attribute_name: string ( * );
    VAR status: integer);
*DECK DECK=FDP$XSHOW_FORMS EXPAND=FALSE
 PROCEDURE [XREF] fdp$xshow_forms (VAR status: integer);

*DECK DECK=FDP$XTAB_TO_NEXT_FIELD EXPAND=FALSE
  PROCEDURE [XREF] fdp$xtab_to_next_field
    (VAR status: integer);
*DECK DECK=FDT$ADDED_VARIABLE_DEFINITION EXPAND=FALSE

  TYPE

    fdt$added_variable_definition = record
      comment_definitions: fdt$comment_definitions,
      form_cobol_program_clause: fdt$form_cobol_program_clause,
      form_cobol_display_clause: fdt$form_cobol_display_clause,
      display_cobol_description: fdt$cobol_description,
      program_cobol_description: fdt$cobol_description,
      future_expansion: string(32),
    recend;

*copyc fdt$cobol_description
*copyc fdt$comment_definitions
*copyc fdt$form_cobol_display_clause
*copyc fdt$form_cobol_program_clause
*DECK DECK=FDT$ADDITIONAL_DEFINITIONS EXPAND=FALSE

  TYPE
    fdt$additional_definitions = REL (fdt$form_module) ^SEQ ( * );

*copyc fdt$form_module
*DECK DECK=FDT$ADDITIONAL_VARIABLE_FACTS EXPAND=FALSE


{ The size of fdt$additional_variable_facts must equal the size of fdt$comment _definitions.
{ On forms with a version greater-equal to fdc$im_smart_capability, the comment definitions is
{ replaced by a pointer to a sequence containing additional data about a
{ variable.

  TYPE
    fdt$additional_variable_facts = record
      filler: string (8),
      additional_definitions: fdt$additional_definitions,
    recend;

*copyc fdt$additional_definitions
*copyc fdt$comment_definitions
*DECK DECK=FDT$CHANGE_FORM_KEY EXPAND=FALSE
 TYPE
    fdt$change_form_key = (fdc$add_display_definition, fdc$add_event,
      fdc$add_form_comment, fdc$delete_all_displays, fdc$delete_all_events,
      fdc$delete_display_definition, fdc$delete_event,
      fdc$delete_form_comments, fdc$design_display_attribute,
      fdc$design_variable_name, fdc$event_form, fdc$form_area,
      fdc$form_display_attribute, fdc$form_help, fdc$form_language,
      fdc$form_name, fdc$form_processor, fdc$message_form,
      fdc$unused_form_entry, fdc$validate_variable_values,
      fdc$invalid_data_character,fdc$error_message_form,
      fdc$help_message_form, fdc$hidden_editing,
      fdc$fast_form_creation, fdc$add_event_v1);
*DECK DECK=FDT$CHANGE_OBJECT_KEY EXPAND=FALSE
 TYPE
    fdt$change_object_key = (fdc$object_name, fdc$object_display,
      fdc$object_position, fdc$unused_object_entry, fdc$object_width,
      fdc$object_height, fdc$object_text, fdc$object_line_x_increment,
      fdc$object_line_y_increment, fdc$object_text_processing);
*DECK DECK=FDT$CHANGE_RECORD_KEY EXPAND=FALSE
 TYPE
    fdt$change_record_key = (fdc$record_deck_name, fdc$record_name,
      fdc$record_type, fdc$table_access, fdc$unused_record_entry);
*DECK DECK=FDT$CHANGE_TABLE_KEY EXPAND=FALSE
 TYPE
    fdt$change_table_key = (fdc$add_table_variable, fdc$delete_table_variable,
      fdc$new_table_name, fdc$stored_occurrence, fdc$unused_table_entry,
      fdc$visible_occurrence);
*DECK DECK=FDT$CHANGE_VARIABLE_KEY EXPAND=FALSE
 TYPE
    fdt$change_variable_key = (fdc$error_display,
      fdc$output_format, fdc$input_format, fdc$io_mode,
      fdc$terminal_user_entry, fdc$variable_length, fdc$add_valid_real_range,
      fdc$delete_valid_real_range, fdc$add_valid_integer_range,
      fdc$delete_valid_integer_range, fdc$add_valid_string,
      fdc$delete_valid_string, fdc$variable_help, fdc$variable_error,
      fdc$add_var_comment, fdc$delete_var_comments, fdc$unused_variable_entry,
      fdc$new_variable_name, fdc$process_as_event, fdc$unknown_entry_character,
      fdc$string_compare_rules,fdc$program_data_type,
      fdc$cobol_display_clause, fdc$cobol_program_clause);
*DECK DECK=FDT$CHARACTER_POSITION EXPAND=FALSE
 TYPE
    fdt$character_position = 1 .. fdc$max_character_position;

*copyc fdc$max_character_position
*DECK DECK=FDT$COBOL_CATEGORY EXPAND=FALSE
TYPE

   fdt$cobol_category = (
      fdc$cobol_numeric_unsigned,
      fdc$cobol_numeric_signed,
      fdc$cobol_alphanumeric,
      fdc$cobol_alphabetic,
      fdc$cobol_numeric_edited,
      fdc$cobol_alphanumeric_edited,
      fdc$cobol_free_form);
*DECK DECK=FDT$COBOL_CLAUSE EXPAND=FALSE

*DECK DECK=FDT$COBOL_CR_DB_MEANS EXPAND=FALSE
TYPE
   fdt$cobol_cr_db_means = (
      fdc$cobol_positive,                              {Value is set positive}
      fdc$cobol_negative,                              {Value is set negative}
      fdc$cobol_1_quadrillion,       {1,000,000,000,000,000 is added to value}
      fdc$cobol_2_quadrillion,       {2,000,000,000,000,000 is added to value}
      fdc$cobol_cr_set,                                      {cr field is set}
      fdc$cobol_db_set,                                      {db field is set}
      fdc$cobol_cr_db_illegal);                    {"CR" and "DB" are illegal}
*DECK DECK=FDT$COBOL_CURRENCY_SYMBOLS EXPAND=FALSE

  TYPE
    fdt$cobol_currency_symbols = record
      primary_money_symbol: char,
      secondary_money_symbol: char,
      thousands_separator_symbol: char,
      decimal_symbol: char,
    recend;
*DECK DECK=FDT$COBOL_DESCRIPTION EXPAND=FALSE

  TYPE
    fdt$cobol_description = record
      cobol_category: fdt$cobol_category,
      cobol_operations: array [1 .. fdc$cobol_operations_max] of
            fdt$cobol_operation,
      cobol_usage: fdt$cobol_usage,
      cr_means: fdt$cobol_cr_db_means, {How "CR" is handled in FREE-FORM}
      db_means: fdt$cobol_cr_db_means, {How "DB" is handled in FREE-FORM}
      display_cr: boolean, {true in source causes destination "CR" to be shown}
      display_db: boolean, {true in source causes destination "DB" to be shown}
      move_operations: integer, {No. of operations for moving DISPLAY into
            {this item}
      number_digits: 0 .. fdc$cobol_digits_maximum,
      operation_characters: array [1 .. fdc$cobol_operations_max] of char,
      operation_numbers: array [1 .. fdc$cobol_operations_max] of
            0 .. fdc$cobol_item_size_maximum,
      sign_index: integer, {0 means no sign, else index to sep or overpunch}
      sign_separate: boolean, {iff separate sign, else overpunch sign}
      significant_digits: -fdc$cobol_digits_maximum .. fdc$cobol_digits_maximum,
      size: 0 .. fdc$cobol_item_size_maximum,
    recend;

*copyc fdc$cobol_digits_maximum
*copyc fdc$cobol_operations_max
*copyc fdc$cobol_item_size_maximum
*copyc fdt$cobol_category
*copyc fdt$cobol_cr_db_means
*copyc fdt$cobol_operation
*copyc fdt$cobol_usage
*DECK DECK=FDT$COBOL_DISPLAY_CLAUSE EXPAND=FALSE

  TYPE
    fdt$cobol_display_clause = record
      picture: fdt$picture,
    recend;

*copyc fdt$picture

*DECK DECK=FDT$COBOL_OPERATION EXPAND=FALSE
TYPE
   fdt$cobol_operation = (
      fdc$cobol_insert,               {insert <op_num> copies of <op_char>}
      fdc$cobol_move,             {move <op_num> chars from source to dest}
      fdc$cobol_move_float,       {move <op_num> chars, floating <op_char>}
      fdc$cobol_overpunch_sign,     {move 1 digit and apply overpunch sign}
      fdc$cobol_separate_sign,        {insert "+" or "-" depending on sign}
      fdc$cobol_set_char_if_negative,   {insert <op_char> if neg, else " "}
      fdc$cobol_set_leading_zeros,                {"leading_zeros" := true}
      fdc$cobol_stop_float);     {stop floating at [implied] decimal point}
*DECK DECK=FDT$COBOL_PICTURE_SYMBOLS EXPAND=FALSE
TYPE
  fdt$cobol_picture_symbols = string (* <= fdc$maximum_picture_length);

*copyc fdc$maximum_picture_length

*DECK DECK=FDT$COBOL_PROGRAM_CLAUSE EXPAND=FALSE

  TYPE
    fdt$cobol_program_clause = record
      picture: fdt$picture,
      usage: fdt$usage,
    recend;

*copyc fdt$picture
*copyc fdt$usage
*DECK DECK=FDT$COBOL_USAGE EXPAND=FALSE
TYPE
   fdt$cobol_usage = (
      fdc$cobol_usage_binary,   {COMPUTATIONAL,  or COMP,  or BINARY}
      fdc$cobol_usage_display,
      fdc$cobol_usage_double,   {COMPUTATIONAL-2 or COMP-2}
      fdc$cobol_usage_packed,   {COMPUTATIONAL-3 or COMP-3 or PACKED-DECIMAL}
      fdc$cobol_usage_single);  {COMPUTATIONAL-1 or COMP-1}
*DECK DECK=FDT$COBOL_USAGE_KEYWORD EXPAND=FALSE
TYPE
  fdt$cobol_usage_keyword = (fdc$binary_usage, fdc$computational_usage, fdc$comp_usage,
       fdc$computational_1_usage, fdc$comp_1_usage, fdc$computational_2_usage,
       fdc$comp_2_usage, fdc$computational_3_usage, fdc$comp_3_usage,
        fdc$packed_decimal_usage, fdc$display_usage, fdc$free_form_usage);
*DECK DECK=FDT$COMMAND EXPAND=FALSE
 TYPE
    fdt$command = record
      command_exists: boolean,
      p_command: REL (fdt$form_module) ^fdt$event_command,
    recend;

*copyc fdt$form_module
*copyc fdt$event_command
*DECK DECK=FDT$COMMENT EXPAND=FALSE
 TYPE
    fdt$comment = string ( * <= fdc$maximum_comment_length);

*copyc fdc$maximum_comment_length
*DECK DECK=FDT$COMMENT_DEFINITION EXPAND=FALSE
 TYPE
    fdt$comment_definition = record
      p_comment: REL (fdt$form_module) ^fdt$comment,
    recend;

*copyc fdt$form_module
*copyc fdt$comment
*DECK DECK=FDT$COMMENT_DEFINITIONS EXPAND=FALSE
 TYPE
    fdt$comment_definitions = record
      total_number: fdt$number_comments,
      active_number: fdt$number_comments,
      p_comment_definitions: REL (fdt$form_module) ^array [1 .. * ] of
        fdt$comment_definition,
    recend;

*copyc fdt$number_comments
*copyc fdt$form_module
*copyc fdt$comment_definition
*DECK DECK=FDT$COMMENT_INDEX EXPAND=FALSE
 TYPE
    fdt$comment_index = 1 .. fdc$maximum_comments;

*copyc fdc$maximum_comments
*DECK DECK=FDT$COMMENT_LENGTH EXPAND=FALSE
 TYPE
    fdt$comment_length = 0 .. fdc$maximum_comment_length;

*copyc fdc$maximum_comment_length
*DECK DECK=FDT$COORDINATE_SYSTEM EXPAND=FALSE
 TYPE
    fdt$coordinate_system = (fdc$character_system, fdc$unit_system);
*DECK DECK=FDT$CURRENT_FORM_IDENTIFIER EXPAND=FALSE
 TYPE
    fdt$current_form_identifier = 0 .. fdc$maximum_form_identifier;

*copyc fdc$maximum_form_identifier
*DECK DECK=FDT$DIGITS_IN_EXPONENT EXPAND=FALSE
 TYPE
    fdt$digits_in_exponent = mlt$exponent_style;

*copyc mlt$exponent_style
*copyc mlt$sign_treatment
*DECK DECK=FDT$DIGITS_RIGHT_DECIMAL EXPAND=FALSE
 TYPE
    fdt$digits_right_decimal = 0 .. 19;

*DECK DECK=FDT$DISPLAY_ATTRIBUTE EXPAND=FALSE

  TYPE
    fdt$display_attribute = (fdc$inverse_video, fdc$low_intensity,
          fdc$high_intensity, fdc$blink, fdc$underline, fdc$protect,
          fdc$hidden, fdc$black_foreground, fdc$black_background,
          fdc$blue_foreground, fdc$blue_background, fdc$green_foreground,
          fdc$green_background, fdc$magenta_foreground, fdc$magenta_background,
          fdc$red_foreground, fdc$red_background, fdc$cyan_foreground,
          fdc$cyan_background, fdc$yellow_foreground, fdc$yellow_background,
          fdc$white_foreground, fdc$white_background, fdc$fine_line,
          fdc$medium_line, fdc$bold_line, fdc$fine_border, fdc$medium_border,
          fdc$bold_border, fdc$italic_display_attribute,
          fdc$title_display_attribute, fdc$input_display_attribute,
          fdc$error_display_attribute, fdc$message_display_attribute,
          fdc$display_left_to_right, fdc$display_right_to_left,
          fdc$push_input_character, fdc$user_attribute_1, fdc$user_attribute_2,
          fdc$user_attribute_3, fdc$user_attribute_4, fdc$user_attribute_5,
          fdc$user_attribute_6, fdc$user_attribute_7, fdc$user_attribute_8,
          fdc$user_attribute_9, fdc$user_attribute_10);

*DECK DECK=FDT$DISPLAY_ATTRIBUTE_SET EXPAND=FALSE
 TYPE
    fdt$display_attribute_set = set of fdt$display_attribute;

*copyc fdt$display_attribute
*DECK DECK=FDT$DISPLAY_DEFINITION EXPAND=FALSE
 TYPE
    fdt$display_definition = record
      attribute: fdt$display_attribute_set,
      name: ost$name,
    recend;

*copyc fdt$display_attribute_set
*copyc ost$name
*DECK DECK=FDT$DISPLAY_DEFINITIONS EXPAND=FALSE
 TYPE
    fdt$display_definitions = record
      total_number: fdt$number_object_displays,
      active_number: fdt$number_object_displays,
      p_display_definitions: REL (fdt$form_module) ^array [1 .. * ] of
        fdt$display_definition,
    recend;

*copyc fdt$number_object_displays
*copyc fdt$form_module
*copyc fdt$display_definition
*DECK DECK=FDT$DISPLAY_INDEX EXPAND=FALSE
 TYPE
    fdt$display_index = 1 .. fdc$maximum_object_displays;

*copyc fdc$maximum_object_displays
*DECK DECK=FDT$ERROR_DEFINITION EXPAND=FALSE
 TYPE
    fdt$error_definition = record
      case key: fdt$error_key of


      = fdc$error_form =
        error_form: ost$name,

      = fdc$error_message =
        p_error_message: ^fdt$error_message,

      = fdc$no_error_response =
        ,
      = fdc$system_default_error =
        ,
      casend
    recend;

*copyc ost$name
*copyc fdt$error_message
*copyc fdt$error_key
*DECK DECK=FDT$ERROR_HEADER EXPAND=FALSE
 TYPE
    fdt$error_header = record
      case key: fdt$form_definition_error_key of
      = fdc$no_variable_object, fdc$no_table_object, fdc$no_table_variable,
        fdc$unequal_tbl_obj_width, fdc$no_variable_definition,
        fdc$error_input_conversion, fdc$error_output_conversion,
        fdc$error_invalid_value =
        ,
      casend
    recend;

*copyc fdt$form_definition_error_key
*DECK DECK=FDT$ERROR_INPUT_CONVERSION EXPAND=FALSE
 TYPE
    fdt$error_input_conversion = record
      occurrence: fdt$occurrence,
      variable_name: ost$name,
    recend;

*copyc fdt$occurrence
*copyc ost$name
*DECK DECK=FDT$ERROR_INVALID_VALUE EXPAND=FALSE
 TYPE
    fdt$error_invalid_value = record
      occurrence: fdt$occurrence,
      variable_name: ost$name,
    recend;

*copyc fdt$occurrence
*copyc ost$name
*DECK DECK=FDT$ERROR_KEY EXPAND=FALSE
 TYPE
    fdt$error_key = (fdc$error_form, fdc$error_message, fdc$no_error_response,
      fdc$system_default_error);
*DECK DECK=FDT$ERROR_MESSAGE EXPAND=FALSE
 TYPE
    fdt$error_message = string ( * <= fdc$maximum_error_length);

*copyc fdc$maximum_error_length
*DECK DECK=FDT$ERROR_MESSAGE_LENGTH EXPAND=FALSE
 TYPE
    fdt$error_message_length = 0 .. fdc$maximum_error_length;

*copyc fdc$maximum_error_length
*DECK DECK=FDT$ERROR_NO_TABLE_OBJECT EXPAND=FALSE
 TYPE
    fdt$error_no_table_object = record
      occurrence: fdt$occurrence,
      table_name: ost$name,
      variable_name: ost$name,
    recend;

*copyc ost$name
*copyc fdt$occurrence
*DECK DECK=FDT$ERROR_NO_TABLE_VARIABLE EXPAND=FALSE
 TYPE
    fdt$error_no_table_variable = record
      table_name: ost$name,
      variable_name: ost$name,
    recend;

*copyc ost$name
*DECK DECK=FDT$ERROR_NO_VARIABLE_DEF EXPAND=FALSE
 TYPE
    fdt$error_no_variable_def = record
      occurrence: fdt$occurrence,
      variable_name: ost$name,
    recend;

*copyc fdt$occurrence
*copyc ost$name
*DECK DECK=FDT$ERROR_NO_VARIABLE_OBJECT EXPAND=FALSE
 TYPE
    fdt$error_no_variable_object = record
      occurrence: fdt$occurrence,
      variable_name: ost$name,
    recend;

*copyc fdt$occurrence
*copyc ost$name
*DECK DECK=FDT$ERROR_OUTPUT_CONVERSION EXPAND=FALSE
 TYPE
    fdt$error_output_conversion = record
      occurrence: fdt$occurrence,
      variable_name: ost$name,
    recend;

*copyc fdt$occurrence
*copyc ost$name
*DECK DECK=FDT$ERROR_UNEQUAL_TBL_OBJ_WIDTH EXPAND=FALSE
  TYPE
     fdt$error_unequal_tbl_obj_width = record
       table_name : ost$name,
       variable_name : ost$name,
       occurrence : fdt$occurrence,
     recend;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc fdt$occurrence
?? POP ??
*DECK DECK=FDT$EVENT_ACTION EXPAND=FALSE
 TYPE
    fdt$event_action = (fdc$return_program_normal, fdc$return_program_abnormal,
      fdc$page_table_forward, fdc$page_table_backward,
      fdc$scroll_table_forward, fdc$scroll_table_backward, fdc$display_help,
      fdc$erase_help, fdc$execute_command, fdc$ignore_event,
      fdc$tab_to_next_form_field, fdc$tab_to_previous_form_field,
      fdc$scroll_variable_forward, fdc$scroll_variable_backward,
      fdc$page_variable_forward, fdc$page_variable_backward,
      fdc$page_variable_first, fdc$page_variable_last,
      fdc$page_table_first, fdc$page_table_last, fdc$insert_variable_line,
      fdc$delete_variable_line);
*DECK DECK=FDT$EVENT_COMMAND EXPAND=FALSE
 TYPE
    fdt$event_command = string ( * );
*DECK DECK=FDT$EVENT_DEFINITION EXPAND=FALSE
 TYPE
{ Event Definitions. }

    fdt$event_definition = record
      command: fdt$command,
      event_action: fdt$event_action,
      event_name: ost$name,
{     event_label: ost$name,
{ The reassign event capability changed event label to the following fields:
{ event_label, event_trigger_reassignment, and filler.  Only the first six
{ characters of the old event_label were used.  If the screen formatting version
{ is less than fdc$reassign_event_capability, the old definition is used; otherwise
{ the new definition is used. For old definitions, event_trigger_reassigment
{ is assumed true.
      event_label: fdt$event_label_v1,
      event_trigger_reassignment: boolean,
      filler: string (24),
      event_trigger: fdt$event_trigger
    recend;

*copyc fdt$command
*copyc fdt$event_action
*copyc fdt$event_label_v1
*copyc fdt$event_trigger
*copyc ost$name
*DECK DECK=FDT$EVENT_DEFINITIONS EXPAND=FALSE
 TYPE
    fdt$event_definitions = record
      active_number: fdt$number_events,
      total_number: fdt$number_events,
      p_event_definitions: REL (fdt$form_module) ^array [1 .. * ] of
        fdt$event_definition,
    recend;

*copyc fdt$number_events
*copyc fdt$form_module
*copyc fdt$event_definition
*DECK DECK=FDT$EVENT_FORM_DEFINITION EXPAND=FALSE
 TYPE
    fdt$event_form_definition = record
      case key: fdt$event_form_key of
      = fdc$no_event_form =
        ,
      = fdc$system_default_event_form =
        ,
      = fdc$user_event_form =
        event_form_name: ost$name,
      casend
    recend;

*copyc fdt$event_form_key
*copyc ost$name
*DECK DECK=FDT$EVENT_FORM_KEY EXPAND=FALSE
 TYPE
    fdt$event_form_key = (fdc$no_event_form, fdc$system_default_event_form,
      fdc$user_event_form);
*DECK DECK=FDT$EVENT_INDEX EXPAND=FALSE
 TYPE
    fdt$event_index = 1 .. fdc$maximum_events;

*copyc fdc$maximum_events
*DECK DECK=FDT$EVENT_LABEL EXPAND=FALSE
 TYPE
    fdt$event_label = ost$name;
*DECK DECK=FDT$EVENT_LABEL_V1 EXPAND=FALSE

 TYPE
    fdt$event_label_v1 = string(6);
*DECK DECK=FDT$EVENT_MENU EXPAND=FALSE
 TYPE
    fdt$event_menu = record
      event_label: fdt$event_label,
      event_name: ost$name,
      event_trigger: fdt$event_trigger,
    recend;

*copyc fdt$event_label
*copyc fdt$event_trigger
*copyc ost$name
*DECK DECK=FDT$EVENT_POSITION EXPAND=FALSE
 TYPE
    fdt$event_position = record
      form_identifier: fdt$form_identifier,
      form_x_position: fdt$x_position,
      form_y_position: fdt$y_position,
      screen_x_position: fdt$x_position,
      screen_y_position: fdt$y_position,

      case key: fdt$event_position_key of

      = fdc$form_event =
        ,

      = fdc$object_event =
        object_name: ost$name,
        object_occurrence: fdt$occurrence,
        object_x_position: fdt$x_position,
        object_y_position: fdt$y_position,
        case object_definition_key: fdt$object_definition_key of

        = fdc$box,fdc$constant_text,fdc$constant_text_box,
          fdc$line,fdc$table =
          ,

        = fdc$variable_text, fdc$variable_text_box =
          character_position: fdt$character_position,
        casend
      casend
    recend;

*copyc fdt$character_position
*copyc fdt$event_position_key
*copyc fdt$form_identifier
*copyc fdt$object_definition_key
*copyc fdt$occurrence
*copyc fdt$x_position
*copyc fdt$y_position

*DECK DECK=FDT$EVENT_POSITION_KEY EXPAND=FALSE
 TYPE
    fdt$event_position_key = (fdc$form_event, fdc$object_event,
      fdc$screen_event);
*DECK DECK=FDT$EVENT_TRIGGER EXPAND=FALSE

  TYPE
    fdt$event_trigger = (fdc$next, fdc$help, fdc$stop, fdc$back, fdc$up,
          fdc$down, fdc$forward, fdc$backward, fdc$undo, fdc$redo, fdc$quit,
          fdc$exit, fdc$first, fdc$last, fdc$edit, fdc$data, fdc$function_1,
          fdc$function_2, fdc$function_3, fdc$function_4, fdc$function_5,
          fdc$function_6, fdc$function_7, fdc$function_8, fdc$function_9,
          fdc$function_10, fdc$function_11, fdc$function_12, fdc$function_13,
          fdc$function_14, fdc$function_15, fdc$function_16, fdc$shift_next,
          fdc$shift_help, fdc$shift_stop, fdc$shift_back, fdc$shift_up,
          fdc$shift_down, fdc$shift_forward, fdc$shift_backward,
          fdc$shift_edit, fdc$shift_data, fdc$shift_function_1,
          fdc$shift_function_2, fdc$shift_function_3, fdc$shift_function_4,
          fdc$shift_function_5, fdc$shift_function_6, fdc$shift_function_7,
          fdc$shift_function_8, fdc$shift_function_9, fdc$shift_function_10,
          fdc$shift_function_11, fdc$shift_function_12, fdc$shift_function_13,
          fdc$shift_function_14, fdc$shift_function_15, fdc$shift_function_16,
          fdc$pick, fdc$insert_line, fdc$delete_line, fdc$home_cursor,
          fdc$clear_screen, fdc$time_out, fdc$variable_trigger);

*DECK DECK=FDT$EXPONENT_OUTPUT_FORMAT EXPAND=FALSE
 TYPE
    fdt$exponent_output_format = record
      field_width: fdt$real_field_width, { w FORTRAN descriptor }
      digits_in_exponent: fdt$digits_in_exponent, { e FORTRAN descriptor }
      digits_right_decimal: fdt$digits_right_decimal, { d FORTRAN descriptor}
      sign_treatment: fdt$sign_treatment,
      suppress_zero: boolean, {TRUE to display zero as blanks. }
    recend;

*copyc fdt$real_field_width
*copyc fdt$digits_in_exponent
*copyc fdt$digits_right_decimal
*copyc fdt$sign_treatment
*DECK DECK=FDT$FLOAT_OUTPUT_FORMAT EXPAND=FALSE
 TYPE
    fdt$float_output_format = record
      digits_right_decimal: fdt$digits_right_decimal, {d FORTRAN
      {descriptor }
      field_width: fdt$real_field_width, { w FORTRAN descriptor }
      sign_treatment: fdt$sign_treatment,
      suppress_zero: boolean, {TRUE to display zero as blanks. }
    recend;

*copyc fdt$digits_right_decimal
*copyc fdt$real_field_width
*copyc fdt$sign_treatment
*DECK DECK=FDT$FORMS_STATUS EXPAND=FALSE
 TYPE
    fdt$forms_status = array [1 .. * ] of fdt$form_status;

*copyc fdt$form_status
*DECK DECK=FDT$FORM_AREA EXPAND=FALSE
 TYPE
    fdt$form_area = record
      case key: fdt$form_area_key of

      = fdc$defined_area =
        x_position: fdt$x_position,
        y_position: fdt$y_position,
        width: fdt$width,
        height: fdt$height,

      = fdc$screen_area =
        ,

      casend
    recend;

*copyc fdt$form_area_key
*copyc fdt$x_position
*copyc fdt$y_position
*copyc fdt$width
*copyc fdt$height
*DECK DECK=FDT$FORM_AREA_KEY EXPAND=FALSE
 TYPE
    fdt$form_area_key = (fdc$defined_area, fdc$screen_area);
*DECK DECK=FDT$FORM_ATTRIBUTE EXPAND=FALSE
 TYPE
{ Form Attributes }

    fdt$form_attribute = record
      put_value_status: fdt$put_value_status {output} ,
      case key: fdt$change_form_key {input} of {input}

      = fdc$add_event =
        event_name: ost$name,
        event_label: ost$name,
        event_trigger: fdt$event_trigger,
        case event_action: fdt$event_action of
        = fdc$execute_command =
        p_event_command: ^fdt$event_command,
        casend,

     = fdc$add_event_v1 =
        event_name_v1: ost$name,
        event_label_v1: fdt$event_label_v1,
        event_trigger_v1: fdt$event_trigger,
        event_trigger_reassignment_v1: boolean,
        case event_action_v1: fdt$event_action of
        = fdc$execute_command =
        p_event_command_v1: ^fdt$event_command,
        casend,

      = fdc$add_form_comment =
        p_form_comment: ^fdt$comment,

      = fdc$add_display_definition =
        display_attribute: fdt$display_attribute_set,
        display_name: ost$name,

      = fdc$delete_all_displays =
        ,

      = fdc$delete_all_events =
        ,

      = fdc$delete_event, fdc$delete_display_definition =
        name: ost$name,

      = fdc$delete_form_comments =
        ,

      = fdc$design_display_attribute =
        design_display_attribute: fdt$display_attribute_set,

      = fdc$design_variable_name =
        design_variable_name: ost$name,

      = fdc$error_message_form =
        error_message_form: ost$name,

      = fdc$event_form =
        event_form_definition: fdt$event_form_definition,

      = fdc$fast_form_creation =
        fast_form_creation: boolean,

      = fdc$form_area =
        form_area: fdt$form_area,

      = fdc$form_display_attribute =
        form_display_attribute: fdt$display_attribute_set,

      = fdc$form_help =
        form_help: fdt$help_definition,

      = fdc$form_language =
        form_language: ost$natural_language,

      = fdc$form_name =
        form_name: ost$name,

      = fdc$form_processor =
        form_processor: fdt$form_processor,

      = fdc$help_message_form =
        help_message_form: ost$name,

      = fdc$hidden_editing =
        hidden_editing: boolean,

      = fdc$invalid_data_character =
        invalid_data_character: fdt$invalid_data_character,

      = fdc$message_form = {Same as fdc$error_message_form}
        message_form: ost$name,

      = fdc$unused_form_entry =
        ,

      = fdc$validate_variable_values =
        validate_variable_values: boolean,

      casend
    recend;

*copyc fdt$change_form_key
*copyc fdt$comment
*copyc fdt$display_attribute_set
*copyc fdt$event_action
*copyc fdt$event_command
*copyc fdt$event_form_definition
*copyc fdt$event_label_v1
*copyc fdt$event_trigger
*copyc fdt$form_area
*copyc fdt$form_processor
*copyc fdt$help_definition
*copyc fdt$invalid_data_character
*copyc fdt$put_value_status

*copyc ost$natural_language
*copyc ost$name
*DECK DECK=FDT$FORM_ATTRIBUTES EXPAND=FALSE
 TYPE
    fdt$form_attributes = array [1 .. * ] of fdt$form_attribute;

*copyc fdt$form_attribute
*DECK DECK=FDT$FORM_ATTRIBUTE_INDEX EXPAND=FALSE
 TYPE
    fdt$form_attribute_index = 1 .. fdc$maximum_form_attributes;

*copyc fdc$maximum_form_attributes
*DECK DECK=FDT$FORM_COBOL_CLAUSE EXPAND=FALSE

  TYPE
    fdt$form_cobol_clause = record
      case defined: boolean of
      = TRUE =
        cobol_clause: fdt$cobol_clause,
      = FALSE =
        ,
      casend,
    recend;

*copyc fdt$cobol_clause
*DECK DECK=FDT$FORM_COBOL_DISPLAY_CLAUSE EXPAND=FALSE

  TYPE
    fdt$form_cobol_display_clause = record
      case defined: boolean of
      = TRUE =
        cobol_display_clause: fdt$cobol_display_clause,
      = FALSE =
        ,
      casend,
    recend;

*copyc fdt$cobol_display_clause
*DECK DECK=FDT$FORM_COBOL_PROGRAM_CLAUSE EXPAND=FALSE

  TYPE
    fdt$form_cobol_program_clause = record
      case defined: boolean of
      = TRUE =
        cobol_program_clause: fdt$cobol_program_clause,
      = FALSE =
        ,
      casend,
    recend;

*copyc fdt$cobol_program_clause
*DECK DECK=FDT$FORM_DEFINITION EXPAND=FALSE
 TYPE
    fdt$form_definition = record
      screen_formatting_version: integer, {This must be the first field}
      {in the record. }
{     character_set: ost$name,
{ The field CHARACTER_SET is replaced by INVALID_DATA_CHARACTER.
      invalid_data_character: fdt$invalid_data_character,
      comment_definitions: fdt$comment_definitions,
      coordinate_system: fdt$coordinate_system,
      display_attribute: fdt$display_attribute_set,
      display_definitions: fdt$display_definitions,
      event_form_definition: fdt$event_form_definition,
      event_definitions: fdt$event_definitions,
      first_input_object_defined: boolean,
      first_input_object_index: fdt$object_index, { Used to set first cursor }
      {position. }
      form_area: fdt$form_area,
      form_ended: boolean,
      form_name: ost$name,
      form_has_errors: boolean,
      form_object_definitions: fdt$form_object_definitions,
      form_table_definitions: fdt$form_table_definitions,
      form_variable_definitions: fdt$form_variable_definitions,
      form_version: integer,
      height: fdt$visible_height, {Required height to contain form.}
      help_definition: fdt$saved_help_definition,
      language: ost$natural_language,
      help_message_form: ost$name,
      hidden_editing: boolean,
      error_message_form: ost$name,
      module_length: ost$segment_length,
      processor: fdt$form_processor,
      program_record_length: fdt$record_length,
      record_deck_name: ost$name,
      record_definitions: fdt$record_definitions,
      record_name: ost$name,
      record_type: fdt$record_type,
      record_version: integer,
      screen_record_length: fdt$record_length,
      width: fdt$visible_width, {Required width to contain form.}
      x_position: fdt$x_position,
      y_position: fdt$y_position,
    recend;

*copyc fdt$comment_definitions
*copyc fdt$coordinate_system
*copyc fdt$display_attribute_set
*copyc fdt$display_definitions
*copyc fdt$event_definitions
*copyc fdt$event_form_definition
*copyc fdt$form_area
*copyc fdt$form_object_definitions
*copyc fdt$form_processor
*copyc fdt$form_table_definitions
*copyc fdt$form_variable_definitions
*copyc fdt$invalid_data_character
*copyc fdt$object_index
*copyc fdt$record_definitions
*copyc fdt$record_length
*copyc fdt$record_type
*copyc fdt$saved_help_definition
*copyc fdt$visible_height
*copyc fdt$visible_width
*copyc fdt$x_position
*copyc fdt$y_position
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$natural_language
*DECK DECK=FDT$FORM_DEFINITION_ERROR_KEY EXPAND=FALSE
 TYPE
    fdt$form_definition_error_key = (fdc$no_table_object,
      fdc$no_table_variable, fdc$no_variable_object,
      fdc$unequal_tbl_obj_width,
      fdc$no_variable_definition, fdc$error_input_conversion,
      fdc$error_output_conversion, fdc$error_invalid_value);
*DECK DECK=FDT$FORM_EVENT_STATUS EXPAND=FALSE
 TYPE
    fdt$form_event_status = record
      event_exists: boolean,
      event_trigger: fdt$event_trigger,
    recend;

*copyc fdt$event_trigger
*DECK DECK=FDT$FORM_IDENTIFIER EXPAND=FALSE
 TYPE
    fdt$form_identifier = 1 .. fdc$maximum_form_identifier;

*copyc fdc$maximum_form_identifier
*DECK DECK=FDT$FORM_IMAGE EXPAND=FALSE
TYPE
   fdt$form_image = array [1 .. fdc$maximum_y_position] OF
        STRING (fdc$maximum_x_position);

*copyc fdc$maximum_x_position
*copyc fdc$maximum_y_position
*DECK DECK=FDT$FORM_MODULE EXPAND=FALSE
 TYPE
    fdt$form_module = SEQ ( * );
*DECK DECK=FDT$FORM_NAME EXPAND=FALSE
 TYPE
    fdt$form_name = record
      name: ost$name,
      name_selection: fdt$name_selection,
    recend;

*copyc ost$name
*copyc fdt$name_selection
*DECK DECK=FDT$FORM_NAMES EXPAND=FALSE
 TYPE
    fdt$form_names = array [1 .. * ] of fdt$form_name;

*copyc fdt$form_name
*DECK DECK=FDT$FORM_OBJECT EXPAND=FALSE
 TYPE
    fdt$form_object = record
      name: ost$name,
      object: fdt$object_definition_key,
      occurrence: fdt$occurrence,
      x_position: fdt$x_position,
      y_position: fdt$y_position,
    recend;

*copyc ost$name
*copyc fdt$object_definition_key
*copyc fdt$occurrence
*copyc fdt$x_position
*copyc fdt$y_position
*DECK DECK=FDT$FORM_OBJECTS EXPAND=FALSE
 TYPE
    fdt$form_objects = array [1 .. * ] of fdt$form_object;

*copyc fdt$form_object
*DECK DECK=FDT$FORM_OBJECT_DEFINITION EXPAND=FALSE
 TYPE
    fdt$form_object_definition = record
      display_attribute: fdt$display_attribute_set,
      name: ost$name,
      occurrence: fdt$occurrence,
      x_position: fdt$x_position,
      y_position: fdt$y_position,

      case key: fdt$form_object_key of

      = fdc$form_box =
        box_height: fdt$height,
        box_width: fdt$width,


      = fdc$form_constant_text =
        constant_text: fdt$text_pointer,
        constant_text_width: fdt$width,

      = fdc$form_constant_text_box =
        constant_box_height: fdt$height,
        constant_box_fragment_index: fdt$object_index,
        constant_box_processing: fdt$text_box_processing,
        constant_box_text: fdt$text_pointer,
        constant_box_width: fdt$width,

      = fdc$form_line =
        x_increment: fdt$x_increment,
        y_increment: fdt$y_increment,

      = fdc$form_stored_variable =
        stored_variable_exists: boolean,
        stored_variable_index: fdt$variable_index,
        stored_variable_text: fdt$text_pointer,

      = fdc$form_table =
        table_height: fdt$height,
        table_width: fdt$width,

      = fdc$form_text_box_fragment =
        fragment_width: fdt$width,
        next_fragment_object_index: fdt$object_index,
        parent_text_box_object_index: fdt$object_index,

      = fdc$form_unused_object =
         ,

      = fdc$form_variable_text =
        text_variable_exists: boolean,
        text_variable_index: fdt$variable_index,
        text_variable_text: fdt$text_pointer,
        text_variable_width: fdt$width,


      = fdc$form_variable_text_box =
        variable_box_fragment_index: fdt$object_index,
        variable_box_height: fdt$height,
        variable_box_processing: fdt$text_box_processing,
        variable_box_text: fdt$text_pointer,
        variable_box_variable_exists: boolean,
        variable_box_variable_index: fdt$variable_index,
        variable_box_width: fdt$width,

      casend
    recend;

*copyc fdt$display_attribute_set
*copyc fdt$form_object_key
*copyc fdt$height
*copyc fdt$object_definition_key
*copyc fdt$object_index
*copyc fdt$occurrence
*copyc fdt$text_pointer
*copyc fdt$text_box_processing
*copyc fdt$text_pointer
*copyc fdt$variable_index
*copyc fdt$width
*copyc fdt$x_increment
*copyc fdt$y_increment
*copyc fdt$x_position
*copyc fdt$y_position
*copyc ost$name

*DECK DECK=FDT$FORM_OBJECT_DEFINITIONS EXPAND=FALSE
 TYPE
    fdt$form_object_definitions = record
      active_number: fdt$number_objects,
      p_form_object_definitions: REL (fdt$form_module) ^array [1 .. * ] of
        fdt$form_object_definition,
      total_number: fdt$number_objects,
    recend;

*copyc fdt$number_objects
*copyc fdt$form_module
*copyc fdt$form_object_definition
*DECK DECK=FDT$FORM_OBJECT_KEY EXPAND=FALSE
 TYPE
    fdt$form_object_key = (fdc$form_box, fdc$form_constant_text,
      fdc$form_constant_text_box, fdc$form_line, fdc$form_stored_variable,
      fdc$form_table, fdc$form_text_box_fragment, fdc$form_unused_object,
      fdc$form_variable_text, fdc$form_variable_text_box);
*DECK DECK=FDT$FORM_OBJECT_STATUS EXPAND=FALSE

  TYPE
    fdt$form_object_status = record
      display_attribute_set: fdt$display_attribute_set,
      case key: fdt$form_object_status_key of

      = fdc$graphic_identifier =
        graphic_identifier: cst$graphic_identifier,

      = fdc$field_identifier, fdc$unused_identifier =
        changed_by_read_forms_index: fdt$read_forms_index,
        character_position: fdt$text_length,
        data_length: fdt$text_length,
        field_number: cst$field_number,
        user_changed_field: boolean,
        user_entered_field: boolean,
        variable_output_status: fdt$variable_status,
        variable_input_status: fdt$variable_status,

      casend
    recend;

*copyc fdt$display_attribute_set
*copyc fdt$form_object_status_key
*copyc fdt$read_forms_index
*copyc fdt$variable_length
*copyc fdt$variable_status
*copyc cst$graphic_identifier
*copyc cst$field_number
*DECK DECK=FDT$FORM_OBJECT_STATUS_KEY EXPAND=FALSE
 TYPE
    fdt$form_object_status_key = (fdc$field_identifier,
      fdc$graphic_identifier,fdc$unused_identifier);
*DECK DECK=FDT$FORM_PROCESSOR EXPAND=FALSE
 TYPE
    fdt$form_processor = (fdc$ansi_fortran_processor,
      fdc$cdc_fortran_processor, fdc$cobol_processor, fdc$cybil_processor,
      fdc$scl_processor, fdc$pascal_processor, fdc$unknown_processor,
      fdc$extended_fortran_processor);
*DECK DECK=FDT$FORM_STATUS EXPAND=FALSE

  TYPE
    fdt$form_status = record
      active_form_object_statuses: fdt$number_objects,
      added: boolean,
      added_form_identifier: fdt$form_identifier,
      changed_variable_search: fdt$variable_search,
      combined: boolean,
      combined_events: boolean,
      defined_dynamically: boolean,
      design_display_attribute: fdt$display_attribute_set,
      design_form: boolean,
      display_on_screen: boolean,
      displayed_on_screen: boolean,
      design_variable_name: ost$name,
      entry_used: boolean,
      events_active: boolean,
      event_form_defined: boolean,
      event_form_identifier: fdt$form_identifier,
      fast_form_creation: boolean,
      field_number: cst$field_number,
      field_number_defined: boolean,
      form_x_position: fdt$x_position,
      form_y_position: fdt$y_position,
      graphic_identifier: cst$graphic_identifier,
      graphic_identifier_defined: boolean,
      input_error_search: fdt$variable_search,
      invalid_data_character: fdt$invalid_data_character,
      last_cursor_position_valid: boolean,
      last_cursor_form_x_position: fdt$x_position,
      last_cursor_form_y_position: fdt$y_position,
      mark_defined: boolean,
      mark_end_x_position: fdt$x_position,
      mark_end_y_position: fdt$y_position,
      mark_start_x_position: fdt$x_position,
      mark_start_y_position: fdt$y_position,
      next_higher_form: fdt$next_form_identifier,
      next_lower_form: fdt$next_form_identifier,
      opened: boolean,
      opened_for_query_only: boolean,
      output_error_search: fdt$variable_search,
      owned_by_system: boolean,
      p_display_definitions: ^array [1 .. * ] of fdt$display_definition,
      p_event_definitions: ^array [1 .. * ] of fdt$event_definition,
      p_form_definition: ^fdt$form_definition,
      p_form_event_statuses: ^array [1 .. * ] of fdt$form_event_status,
      p_form_image: ^fdt$form_image,
      p_form_module: ^fdt$form_module,
      p_form_object_definitions: ^array [1 .. * ] of
            fdt$form_object_definition,
      p_form_object_statuses: ^array [1 .. * ] of fdt$form_object_status,
      p_form_record_definitions: ^array [1 .. * ] of
            fdt$variable_record_definition,
      p_form_table_definitions: ^array [1 .. * ] of fdt$form_table_definition,
      p_form_table_statuses: ^array [1 .. * ] of fdt$table_status,
      p_form_variable_definitions: ^array [1 .. * ] of
            fdt$form_variable_definition,
      p_program_record: ^array [1 .. * ] of cell,
      p_screen_record: ^array [1 .. *] of cell,
      push_count: fdt$push_count,
      segment_pointer: amt$segment_pointer,
      storage_allocated: boolean,
      total_form_object_statuses: fdt$number_objects,
      validate_variable_values: boolean,
    recend;

*copyc amt$segment_pointer

*copyc cst$field_number
*copyc cst$graphic_identifier

*copyc fdt$display_attribute_set
*copyc fdt$display_definition
*copyc fdt$event_definition
*copyc fdt$form_definition
*copyc fdt$form_event_status
*copyc fdt$form_identifier
*copyc fdt$form_image
*copyc fdt$form_object_definition
*copyc fdt$form_object_status
*copyc fdt$form_module
*copyc fdt$form_table_definition
*copyc fdt$form_variable_definition
*copyc fdt$invalid_data_character
*copyc fdt$next_form_identifier
*copyc fdt$number_objects
*copyc fdt$push_count
*copyc fdt$table_status
*copyc fdt$variable_record_definition
*copyc fdt$variable_search
*copyc fdt$x_position
*copyc fdt$y_position

*copyc ost$heap
*copyc ost$name
*copyc ost$status
*copyc osd$virtual_address
*DECK DECK=FDT$FORM_TABLE_DEFINITION EXPAND=FALSE
 TYPE
    fdt$form_table_definition = record
      access_all_occurrences: boolean,
      name: ost$name,
      record_position: fdt$record_position,
      stored_occurrence: fdt$occurrence,
      table_variables: fdt$table_variables,
      valid: boolean,
      visible_occurrence: fdt$occurrence,
      visible_occurrence_defined: boolean,
    recend;

*copyc ost$name
*copyc fdt$record_position
*copyc fdt$occurrence
*copyc fdt$table_variables
*DECK DECK=FDT$FORM_TABLE_DEFINITIONS EXPAND=FALSE
 TYPE
    fdt$form_table_definitions = record
      active_number: fdt$number_tables,
      p_form_table_definitions: REL (fdt$form_module) ^array [1 .. * ] of
        fdt$form_table_definition,
      total_number: fdt$number_tables,
    recend;

*copyc fdt$number_tables
*copyc fdt$form_module
*copyc fdt$form_table_definition
*DECK DECK=FDT$FORM_VARIABLE_DEFINITION EXPAND=FALSE
 TYPE
    fdt$form_variable_definition = record

{ Forms that havea version greater-equal to fdc$im_smart_capability have
{ the field comment_definitions replaced by the field additional_variable_facts.
{     comment_definitions: fdt$comment_definitions,

      additional_variable_facts: fdt$additional_variable_facts,
      error_definition: fdt$saved_error_definition,
      error_displays: fdt$display_attribute_set,
      help_definition: fdt$saved_help_definition,
      input_format: fdt$input_format,
      io_mode: fdt$io_mode,
      name: ost$name,
      output_format: fdt$output_format,
      object_exists: boolean,
      object_index: fdt$object_index,
      process_as_event: boolean,
      program_data_type: fdt$program_data_type,
      program_record_position: fdt$record_position,
      program_variable_length: fdt$program_variable_length,
      screen_record_position: fdt$record_position,
      screen_variable_length: fdt$screen_variable_length,
      table_exists: boolean,
      table_index: fdt$table_index,
      terminal_user_entry: fdt$terminal_user_entry,
      unknown_entry_character: string (1),
      valid: boolean,
      valid_integer_ranges: fdt$valid_integer_ranges,
      valid_real_ranges: fdt$valid_real_ranges,
      valid_strings: fdt$valid_strings,
    recend;

*copyc fdt$additional_variable_facts
*copyc fdt$comment_definitions
*copyc fdt$display_attribute_set
*copyc fdt$input_format
*copyc fdt$io_mode
*copyc fdt$object_index
*copyc fdt$output_format
*copyc fdt$program_data_type
*copyc fdt$program_variable_length
*copyc fdt$record_position
*copyc fdt$saved_error_definition
*copyc fdt$saved_help_definition
*copyc fdt$screen_variable_length
*copyc fdt$table_index
*copyc fdt$terminal_user_entry
*copyc fdt$valid_integer_ranges
*copyc fdt$valid_real_ranges
*copyc fdt$valid_strings
*copyc ost$name
*DECK DECK=FDT$FORM_VARIABLE_DEFINITIONS EXPAND=FALSE
 TYPE
    fdt$form_variable_definitions = record
      active_number: fdt$number_variables,
      p_form_variable_definitions: REL (fdt$form_module) ^array [1 .. * ] of
        fdt$form_variable_definition,
      total_number: fdt$number_variables,
    recend;

*copyc fdt$form_module
*copyc fdt$form_variable_definition
*copyc fdt$number_variables
*DECK DECK=FDT$GET_ERROR_DEFINITION EXPAND=FALSE
 TYPE
    fdt$get_error_definition = record
      case key: fdt$get_error_key of

      = fdc$get_error_form =
        error_form: ost$name,

      = fdc$get_error_message, fdc$get_system_default_error =
        error_message_length: fdt$error_message_length,

      = fdc$get_no_error_response =
        ,

      casend
    recend;

*copyc fdt$get_error_key
*copyc ost$name
*copyc fdt$error_message_length
*DECK DECK=FDT$GET_ERROR_KEY EXPAND=FALSE
 TYPE
    fdt$get_error_key = (fdc$get_error_form, fdc$get_error_message,
      fdc$get_no_error_response, fdc$get_system_default_error);
*DECK DECK=FDT$GET_FORM_ATTRIBUTE EXPAND=FALSE
 TYPE
    fdt$get_form_attribute = record
      get_value_status: fdt$get_value_status,
      {output}
      case key: {input} fdt$get_form_key of

      = fdc$get_error_message_form =
        error_message_form: {output} ost$name,

      = fdc$get_event_command =
        event_command_name: {input} ost$name,
        p_event_command: {output} ^fdt$event_command,

      = fdc$get_event_form =
        event_form_definition: {output} fdt$event_form_definition,

      = fdc$get_event_form_identifier =
        event_form_identifier: {output} fdt$form_identifier,

      = fdc$get_form_area =
        form_area: {output} fdt$form_area,

      = fdc$get_form_comment_length =
        form_comment_length: {output}  fdt$comment_length,

      = fdc$get_form_display_attribute =
        form_display_attribute: {output}  fdt$display_attribute_set,

      = fdc$get_form_help =
        form_help: {output} fdt$get_help_definition,

      = fdc$get_form_help_message =
        p_form_help_message: {input} ^fdt$help_message,

      = fdc$get_form_language =
        form_language: {output} ost$natural_language,

      = fdc$get_form_name =
        form_name: {output} ost$name,

      = fdc$get_form_processor =
        form_processor: {output} fdt$form_processor,

      = fdc$get_help_message_form =
        help_message_form: {output} ost$name,

      = fdc$get_hidden_editing =
        hidden_editing: {output} boolean,

      = fdc$get_invalid_data_character =
        invalid_data_character: {output} fdt$invalid_data_character,

      = fdc$get_message_form = {Same as fdc$get_error_message_form}
        message_form: {output} ost$name,

      = fdc$get_next_event =
        event_action: {output} fdt$event_action,
        event_label: {output} ost$name,
        event_name: {output} ost$name,
        event_command_length: {output} integer,
        event_trigger: {output} fdt$event_trigger,

      = fdc$get_next_event_v1 =
        event_action_v1: {output} fdt$event_action,
        event_label_v1: {output} fdt$event_label_v1,
        event_name_v1: {output} ost$name,
        event_command_length_v1: {output} integer,
        event_trigger_v1: {output} fdt$event_trigger,
        event_trigger_reassignment_v1: {output} boolean,

      = fdc$get_next_form_comment =
        p_form_comment: {input} ^fdt$comment,

      = fdc$get_next_display =
        display_attribute: {output} fdt$display_attribute_set,
        display_name: {output} ost$name,

      = fdc$get_number_events =
        number_events: {output} fdt$number_events,

      = fdc$get_number_form_comments =
        number_form_comments: {output} fdt$number_comments,

      = fdc$get_number_displays =
        number_form_displays: {output} fdt$number_object_displays,

      = fdc$get_number_objects =
        number_objects: {output} fdt$number_objects,

      = fdc$get_number_tables =
        number_tables: {output} fdt$number_tables,

      = fdc$get_number_variables =
        number_variables: {output} fdt$number_variables,

      = fdc$get_unused_form_entry =
        ,

      casend
    recend;

*copyc fdt$comment
*copyc fdt$comment_length
*copyc fdt$event_action
*copyc fdt$event_command
*copyc fdt$event_label_v1
*copyc fdt$event_form_definition
*copyc fdt$event_trigger
*copyc fdt$display_attribute_set
*copyc fdt$form_area
*copyc fdt$form_identifier
*copyc fdt$form_processor
*copyc fdt$get_form_key
*copyc fdt$get_help_definition
*copyc fdt$get_value_status
*copyc fdt$invalid_data_character
*copyc fdt$help_message
*copyc fdt$number_comments
*copyc fdt$number_events
*copyc fdt$number_object_displays
*copyc fdt$number_objects
*copyc fdt$number_tables
*copyc fdt$number_variables
*copyc ost$name
*copyc ost$natural_language
*DECK DECK=FDT$GET_FORM_ATTRIBUTES EXPAND=FALSE
 TYPE
    fdt$get_form_attributes = array [1 .. * ] of fdt$get_form_attribute;

*copyc fdt$get_form_attribute
*DECK DECK=FDT$GET_FORM_KEY EXPAND=FALSE
 TYPE
    fdt$get_form_key = (fdc$get_event_command, fdc$get_event_form,
      fdc$get_event_form_identifier, fdc$get_form_area,
      fdc$get_form_comment_length, fdc$get_form_display_attribute,
      fdc$get_form_help, fdc$get_form_help_message, fdc$get_form_language,
      fdc$get_form_name, fdc$get_form_processor, fdc$get_message_form,
      fdc$get_next_display, fdc$get_next_event, fdc$get_next_form_comment,
      fdc$get_number_displays, fdc$get_number_events,
      fdc$get_number_form_comments, fdc$get_number_objects,
      fdc$get_number_tables, fdc$get_number_variables,
      fdc$get_unused_form_entry, fdc$get_invalid_data_character,
      fdc$get_error_message_form, fdc$get_help_message_form,
      fdc$get_hidden_editing, fdc$get_next_event_v1);
*DECK DECK=FDT$GET_HELP_DEFINITION EXPAND=FALSE
 TYPE
    fdt$get_help_definition = record
      case key: fdt$get_help_key of

      = fdc$get_help_form =
        help_form: ost$name,

      = fdc$get_help_message, fdc$get_system_default_help =
        help_message_length: fdt$help_message_length,

      = fdc$get_no_help_response =
        ,

      casend
    recend;

*copyc fdt$get_help_key
*copyc ost$name
*copyc fdt$help_message_length
*DECK DECK=FDT$GET_HELP_KEY EXPAND=FALSE
 TYPE
    fdt$get_help_key = (fdc$get_help_form, fdc$get_help_message,
      fdc$get_no_help_response, fdc$get_system_default_help);
*DECK DECK=FDT$GET_OBJECT_ATTRIBUTE EXPAND=FALSE
 TYPE
    fdt$get_object_attribute = record
      get_value_status: fdt$get_value_status {output} ,
      case key: {input} fdt$get_object_key of

      = fdc$get_object_definition =
        get_object_definition: {output} fdt$get_object_definition,

      = fdc$get_object_display =
        display_attribute: {output} fdt$display_attribute_set,

      = fdc$get_object_name =
        object_name: {output} ost$name,
        occurrence: {output} fdt$occurrence,

      = fdc$get_object_text =
        p_text: {input} ^fdt$text,

      = fdc$get_object_text_length =
        text_length: {output} fdt$text_length,

      = fdc$get_unused_object_entry =
        ,

      casend
    recend;

*copyc fdt$get_value_status
*copyc fdt$get_object_key
*copyc fdt$get_object_definition
*copyc fdt$display_attribute_set
*copyc fdt$occurrence
*copyc ost$name
*copyc fdt$text

*DECK DECK=FDT$GET_OBJECT_ATTRIBUTES EXPAND=FALSE
 TYPE
    fdt$get_object_attributes = array [1 .. * ] of fdt$get_object_attribute;

*copyc fdt$get_object_attribute
*DECK DECK=FDT$GET_OBJECT_DEFINITION EXPAND=FALSE
 TYPE
    fdt$get_object_definition = record
      case key: {input} fdt$object_definition_key of

      = fdc$box =
        box_width: {output} fdt$width,
        box_height: {output} fdt$height,

      = fdc$line =
        x_increment: {output} fdt$x_increment,
        y_increment: {output} fdt$y_increment,

      = fdc$constant_text =
        constant_text_width: {output} fdt$width,
        constant_text_length: {output} fdt$text_length,

      = fdc$constant_text_box =
        constant_box_height: {output} fdt$height,
        constant_box_processing: {output} fdt$text_box_processing,
        constant_box_width: {output} fdt$width,
        constant_box_text_length: {output} fdt$text_length,

      = fdc$table =
        table_height: {output} fdt$height,
        table_width: {output} fdt$width,

      = fdc$variable_text_box =
        variable_box_height: {output} fdt$height,
        variable_box_processing: {output} fdt$text_box_processing,
        variable_box_text_length: {output} fdt$text_length,
        variable_box_width: {output} fdt$width,

      = fdc$variable_text =
        variable_text_length: {output} fdt$text_length,
        variable_text_width: {output} fdt$width,

      casend
    recend;

*copyc fdt$object_definition_key
*copyc fdt$width
*copyc fdt$height
*copyc fdt$x_increment
*copyc fdt$y_increment
*copyc fdt$text_length
*copyc fdt$text_box_processing
*DECK DECK=FDT$GET_OBJECT_KEY EXPAND=FALSE
 TYPE
    fdt$get_object_key = (fdc$get_object_definition, fdc$get_object_display,
      fdc$get_object_name, fdc$get_object_text, fdc$get_object_text_length,
      fdc$get_unused_object_entry);
*DECK DECK=FDT$GET_RECORD_ATTRIBUTE EXPAND=FALSE
 TYPE
    fdt$get_record_attribute = record
      get_value_status {output} : fdt$get_value_status,
      case key {input} fdt$get_record_key of

      = fdc$get_record_deck_name =
        record_deck_name: {output} ost$name,

      = fdc$get_record_length =
        record_length {output} : fdt$record_length,

      = fdc$get_record_name =
        record_name {output} : ost$name,

      = fdc$get_record_type =
        record_type {output} : fdt$record_type,

      = fdc$get_table_access =
        table_name {input} : ost$name,
        access_all_occurrences {output} : boolean,

      = fdc$get_unused_record_entry =
        ,

      casend
    recend;

*copyc fdt$get_value_status
*copyc fdt$get_record_key
*copyc fdt$number_variables
*copyc ost$name
*copyc fdt$occurrence
*copyc fdt$program_data_type
*copyc fdt$record_position
*copyc fdt$record_length
*copyc fdt$record_type
*DECK DECK=FDT$GET_RECORD_ATTRIBUTES EXPAND=FALSE
 TYPE
    fdt$get_record_attributes = array [1 .. * ] of fdt$get_record_attribute;

*copyc fdt$get_record_attribute
*DECK DECK=FDT$GET_RECORD_KEY EXPAND=FALSE
 TYPE
    fdt$get_record_key = (fdc$get_number_record_variable,
      fdc$get_record_deck_name, fdc$get_record_definition,
      fdc$get_record_length, fdc$get_record_name, fdc$get_record_type,
      fdc$get_record_variable_names, fdc$get_table_access,
      fdc$get_unused_record_entry);
*DECK DECK=FDT$GET_TABLE_ATTRIBUTE EXPAND=FALSE
 TYPE
    fdt$get_table_attribute = record
      get_value_status: {output} fdt$get_value_status,
      case key: {input} fdt$get_table_key of

      = fdc$get_next_table_variable =
        variable_name: {output} ost$name,

      = fdc$get_number_table_variables =
        number_table_variables: {output} fdt$number_table_variables,

      = fdc$get_stored_occurrence =
        stored_occurrence: {output} fdt$occurrence,

      = fdc$get_unused_table_entry =
        ,

      = fdc$get_visible_occurrence =
        visible_occurrence: {output} fdt$occurrence,

      casend
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$get_value_status
*copyc fdt$get_table_key
*copyc ost$name
*copyc fdt$number_table_variables
*copyc fdt$occurrence
?? POP ??
*DECK DECK=FDT$GET_TABLE_ATTRIBUTES EXPAND=FALSE
 TYPE
    fdt$get_table_attributes = array [1 .. * ] of fdt$get_table_attribute;

*copyc fdt$get_table_attribute
*DECK DECK=FDT$GET_TABLE_KEY EXPAND=FALSE
 TYPE
    fdt$get_table_key = (fdc$get_next_table_variable,
      fdc$get_number_table_variables, fdc$get_stored_occurrence,
      fdc$get_unused_table_entry, fdc$get_visible_occurrence);
*DECK DECK=FDT$GET_VALUE_STATUS EXPAND=FALSE
 TYPE
    fdt$get_value_status = (fdc$system_computed_value,
      fdc$system_default_value, fdc$undefined_value, fdc$unprocessed_get_value,
      fdc$user_defined_value);
*DECK DECK=FDT$GET_VARIABLE_ATTRIBUTE EXPAND=FALSE
 TYPE
    fdt$get_variable_attribute = record
      get_value_status: {output} fdt$get_value_status,
      case key: {input} fdt$get_variable_key of

      = fdc$get_cobol_display_clause =
        p_cobol_display_clause: ^fdt$cobol_display_clause,

      = fdc$get_cobol_program_clause =
        p_cobol_program_clause: ^fdt$cobol_program_clause,

      = fdc$get_error_display =
        display_attribute: {output} fdt$display_attribute_set,

      = fdc$get_input_format =
        input_format: {output} fdt$input_format,

      = fdc$get_io_mode =
        io_mode: {output} fdt$io_mode,

      = fdc$get_next_valid_real_range =
        minimum_real: {output} real,
        maximum_real: {output} real,

      = fdc$get_next_valid_string =
        p_valid_string: {input} ^fdt$valid_string,

      = fdc$get_next_var_comment =
        p_var_comment: {input} ^fdt$comment,

      = fdc$get_number_valid_integers =
        number_valid_integers: {output} fdt$number_valid_integers,

      = fdc$get_number_valid_reals =
        number_valid_reals: {output} fdt$number_valid_reals,

      = fdc$get_number_valid_strings =
        number_valid_strings: {output} fdt$number_valid_strings,

      = fdc$get_number_var_comments =
        number_var_comments: {output} fdt$number_comments,

      = fdc$get_output_format =
        output_format: {output} fdt$output_format,

      = fdc$get_process_as_event =
        process_as_event: {output} boolean,

      = fdc$get_program_data_type =
        program_data_type: {output} fdt$program_data_type,

      = fdc$get_string_compare_rules =
        compare_in_upper_case: {output} boolean,
        compare_to_unique_substring: {output} boolean,

      = fdc$get_terminal_user_entry =
        terminal_user_entry: {output} fdt$terminal_user_entry,

      = fdc$get_unknown_entry_character =
        unknown_entry_character: {output} string (1),

      = fdc$get_unused_variable_entry =
        ,

      = fdc$get_valid_integer_range =
        minimum_integer: {output} integer,
        maximum_integer: {output} integer,

      = fdc$get_valid_string_length =
        valid_string_length: {output} fdt$valid_string_length,

      = fdc$get_var_comment_length =
        var_comment_length: {output} fdt$comment_length,

      = fdc$get_var_error_message =
        p_error_message: {input} ^fdt$error_message,

      = fdc$get_var_help_message =
        p_help_message: {input} ^fdt$help_message,

      = fdc$get_variable_error =
        variable_error: {output} fdt$get_error_definition,

      = fdc$get_variable_help =
        variable_help: {output} fdt$get_help_definition,

      = fdc$get_variable_length =
        variable_length: {output} fdt$variable_length,

      casend
    recend;

*copyc fdt$cobol_display_clause
*copyc fdt$cobol_program_clause
*copyc fdt$get_value_status
*copyc fdt$get_variable_key
*copyc fdt$get_variable_attributes
*copyc fdt$input_format
*copyc fdt$io_mode
*copyc fdt$display_attribute_set
*copyc fdt$valid_string
*copyc fdt$comment
*copyc fdt$number_valid_integers
*copyc fdt$number_valid_reals
*copyc fdt$number_valid_strings
*copyc fdt$number_comments
*copyc fdt$output_format
*copyc fdt$program_data_type
*copyc fdt$terminal_user_entry
*copyc fdt$valid_string_length
*copyc fdt$comment_length
*copyc fdt$error_message
*copyc fdt$help_message
*copyc fdt$get_error_definition
*copyc fdt$get_help_definition
*copyc fdt$variable_length
*DECK DECK=FDT$GET_VARIABLE_ATTRIBUTES EXPAND=FALSE
 TYPE
    fdt$get_variable_attributes = array [1 .. * ] of
      fdt$get_variable_attribute;

*copyc fdt$get_variable_attribute
*DECK DECK=FDT$GET_VARIABLE_KEY EXPAND=FALSE
 TYPE
    fdt$get_variable_key = (fdc$get_error_display, fdc$get_input_format,
      fdc$get_io_mode, fdc$get_next_valid_real_range,
      fdc$get_next_valid_string, fdc$get_next_var_comment,
      fdc$get_number_valid_integers, fdc$get_number_valid_reals,
      fdc$get_number_valid_strings, fdc$get_number_var_comments,
      fdc$get_output_format, fdc$get_process_as_event,
      fdc$get_program_data_type, fdc$get_string_compare_rules,
      fdc$get_terminal_user_entry, fdc$get_unknown_entry_character,
      fdc$get_unused_variable_entry, fdc$get_valid_integer_range,
      fdc$get_valid_string_length, fdc$get_var_comment_length,
      fdc$get_var_error_message, fdc$get_var_help_message,
      fdc$get_variable_help, fdc$get_variable_error, fdc$get_variable_length,
      fdc$get_cobol_display_clause, fdc$get_cobol_program_clause);
*DECK DECK=FDT$HEIGHT EXPAND=FALSE
 TYPE
    fdt$height = 1 .. fdc$maximum_y_position;

*copyc fdc$maximum_y_position
*DECK DECK=FDT$HELP_DEFINITION EXPAND=FALSE
 TYPE
    fdt$help_definition = record
      case key: fdt$help_key of

      = fdc$help_form =
        help_form: ost$name,

      = fdc$help_message =
        p_help_message: ^fdt$help_message,

      = fdc$no_help_response, fdc$system_default_help =
        ,

      casend
    recend;

*copyc fdt$help_key
*copyc ost$name
*copyc fdt$help_message
*DECK DECK=FDT$HELP_KEY EXPAND=FALSE
 TYPE
    fdt$help_key = (fdc$help_form, fdc$help_message, fdc$no_help_response,
      fdc$system_default_help);
*DECK DECK=FDT$HELP_MESSAGE EXPAND=FALSE
 TYPE
    fdt$help_message = string ( * <= fdc$maximum_help_length);

*copyc fdc$maximum_help_length
*DECK DECK=FDT$HELP_MESSAGE_LENGTH EXPAND=FALSE
 TYPE
    fdt$help_message_length = 0 .. fdc$maximum_help_length;

*copyc fdc$maximum_help_length
*DECK DECK=FDT$INPUT_CURRENCY_FORMAT EXPAND=FALSE
 TYPE
    fdt$input_currency_format = record
      currency_sybmol: string (1),
      thousands_separator: string (1),
      decimal_point: string (1),
    recend;
*DECK DECK=FDT$INPUT_FORMAT EXPAND=FALSE
 TYPE
    fdt$input_format = record
      case key: fdt$input_format_key of

      = fdc$character_input_format, fdc$alphabetic_input_format,
        fdc$digits_input_format, fdc$real_input_format,
          fdc$signed_input_format, fdc$ydm_format, fdc$mdy_format,
          fdc$dmy_format, fdc$iso_date_format, fdc$month_dd_yyyy_format,
          fdc$undefined_input_format =
        ,
      = fdc$currency_input_format =
        input_currency_format: fdt$input_currency_format,
      casend
    recend;

*copyc fdt$input_format_key
*copyc fdt$input_currency_format
*DECK DECK=FDT$INPUT_FORMAT_KEY EXPAND=FALSE
 TYPE
    fdt$input_format_key = (fdc$alphabetic_input_format,
      fdc$character_input_format, fdc$currency_input_format,
      fdc$digits_input_format, fdc$dmy_format, fdc$mdy_format,
      fdc$month_dd_yyyy_format,fdc$iso_date_format, fdc$real_input_format,
      fdc$signed_input_format, fdc$ydm_format,
      fdc$undefined_input_format);
*DECK DECK=FDT$INPUT_FORMAT_KEY_SET EXPAND=FALSE

  TYPE
    fdt$input_format_key_set = set of fdt$input_format_key;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$input_format_key
?? POP ??

*DECK DECK=FDT$INTEGER_FIELD_WIDTH EXPAND=FALSE
 TYPE
    fdt$integer_field_width = 1 .. 19;

*DECK DECK=FDT$INTEGER_OUTPUT_FORMAT EXPAND=FALSE
 TYPE
    fdt$integer_output_format = record
      field_width: fdt$integer_field_width, {w FORTRAN descriptor}
      minimum_output_digits: fdt$minimum_output_digits, {m FORTRAN descriptor}
      sign_treatment: fdt$sign_treatment,
    recend;

*copyc fdt$integer_field_width
*copyc fdt$minimum_output_digits
*copyc fdt$sign_treatment
*DECK DECK=FDT$INVALID_DATA_CHARACTER EXPAND=FALSE
  TYPE
    fdt$invalid_data_character = record
      filler: string (29),
      case defined: boolean of
      = TRUE =
        character: string (1),
      = FALSE =
        ,
      casend,
    recend;

*DECK DECK=FDT$IO_MODE EXPAND=FALSE
 TYPE
    fdt$io_mode = (fdc$program_input_output {no io to terminal} ,
      fdc$terminal_input, fdc$terminal_input_output, fdc$terminal_output);
*DECK DECK=FDT$MESSAGE_TEXT EXPAND=FALSE
 TYPE
    fdt$message_text = string (fdc$message_variable_length);

*copyc fdc$message_variable_length
*DECK DECK=FDT$MINIMUM_OUTPUT_DIGITS EXPAND=FALSE
 TYPE
    fdt$minimum_output_digits = 0 .. 19;

*DECK DECK=FDT$NAME_SELECTION EXPAND=FALSE
 TYPE
    fdt$name_selection = (fdc$select_object, fdc$select_table,
      fdc$select_variable);
*DECK DECK=FDT$NAME_SELECTIONS EXPAND=FALSE
 TYPE
    fdt$name_selections = set of fdt$name_selection;

*copyc fdt$name_selection
*DECK DECK=FDT$NEXT_FORM_IDENTIFIER EXPAND=FALSE
 TYPE
    fdt$next_form_identifier = 0 .. fdc$maximum_form_identifier;

*copyc fdc$maximum_form_identifier
*DECK DECK=FDT$NUMBER_COMMENTS EXPAND=FALSE
 TYPE
    fdt$number_comments = 0 .. fdc$maximum_comments;

*copyc fdc$maximum_comments
*DECK DECK=FDT$NUMBER_ERRORS EXPAND=FALSE
 TYPE
    fdt$number_errors = integer;

*DECK DECK=FDT$NUMBER_EVENTS EXPAND=FALSE
 TYPE
    fdt$number_events = 0 .. fdc$maximum_events;

*copyc fdc$maximum_events
*DECK DECK=FDT$NUMBER_FORMS EXPAND=FALSE
 TYPE
    fdt$number_forms = 0 .. fdc$maximum_form_identifier;

*copyc fdc$maximum_form_identifier
*DECK DECK=FDT$NUMBER_NAMES EXPAND=FALSE
 TYPE
    fdt$number_names = integer;

*DECK DECK=FDT$NUMBER_OBJECTS EXPAND=FALSE
 TYPE
    fdt$number_objects = 0 .. fdc$maximum_objects;

*copyc fdc$maximum_objects
*DECK DECK=FDT$NUMBER_OBJECT_DISPLAYS EXPAND=FALSE
 TYPE
    fdt$number_object_displays = 0 .. fdc$maximum_object_displays;

*copyc fdc$maximum_object_displays
*DECK DECK=FDT$NUMBER_RECORD_VARIABLES EXPAND=FALSE
 TYPE
    fdt$number_record_variables = 0 .. fdc$maximum_objects;

*copyc fdc$maximum_objects
*DECK DECK=FDT$NUMBER_SCREEN_CHANGES EXPAND=FALSE
 TYPE
    fdt$number_screen_changes = 0 .. fdc$maximum_screen_changes;

*copyc fdc$maximum_screen_changes
*DECK DECK=FDT$NUMBER_TABLES EXPAND=FALSE
 TYPE
    fdt$number_tables = 0 .. fdc$maximum_tables;

*copyc fdc$maximum_tables
*DECK DECK=FDT$NUMBER_TABLE_VARIABLES EXPAND=FALSE
 TYPE
    fdt$number_table_variables = 0 .. fdc$maximum_table_variables;

*copyc fdc$maximum_table_variables
*DECK DECK=FDT$NUMBER_VALID_INTEGERS EXPAND=FALSE
 TYPE
    fdt$number_valid_integers = 0 .. fdc$maximum_valid_ranges;

*copyc fdc$maximum_valid_ranges
*DECK DECK=FDT$NUMBER_VALID_REALS EXPAND=FALSE
 TYPE
    fdt$number_valid_reals = 0 .. fdc$maximum_valid_ranges;

*copyc fdc$maximum_valid_ranges
*DECK DECK=FDT$NUMBER_VALID_STRINGS EXPAND=FALSE
 TYPE
    fdt$number_valid_strings = 0 .. fdc$maximum_valid_strings;

*copyc fdc$maximum_valid_strings
*DECK DECK=FDT$NUMBER_VARIABLES EXPAND=FALSE
 TYPE
    fdt$number_variables = 0 .. fdc$maximum_variables;

*copyc fdc$maximum_variables
*DECK DECK=FDT$OBJECT_ATTRIBUTE EXPAND=FALSE
 TYPE
    fdt$object_attribute = record
      put_value_status: {output} fdt$put_value_status ,
      case key: {input} fdt$change_object_key of

      = fdc$object_display =
        display_attribute: {input} fdt$display_attribute_set,

      = fdc$object_height =
        height: {input} fdt$height,

      = fdc$object_line_x_increment =
        x_increment: {input} fdt$x_increment,

      = fdc$object_line_y_increment =
        y_increment: {input} fdt$y_increment,

      = fdc$object_name =
        object_name: {input} ost$name,
        occurrence: {input} fdt$occurrence,

      = fdc$object_position =
        x_position: {input} fdt$x_position,
        y_position: {input} fdt$y_position,

      = fdc$object_text =
        p_text: {input} ^fdt$text,

      = fdc$object_text_processing =
        text_box_processing: {input} fdt$text_box_processing,

      = fdc$object_width =
        width: {input} fdt$width,

      = fdc$unused_object_entry =
        ,

      casend
    recend;

*copyc fdt$put_value_status
*copyc fdt$change_object_key
*copyc fdt$display_attribute_set
*copyc fdt$height
*copyc fdt$width
*copyc fdt$x_increment
*copyc fdt$y_increment
*copyc fdt$occurrence
*copyc fdt$x_position
*copyc fdt$y_position
*copyc fdt$text
*copyc fdt$text_box_processing
*copyc ost$name

*DECK DECK=FDT$OBJECT_ATTRIBUTES EXPAND=FALSE
 TYPE
    fdt$object_attributes = array [1 .. * ] of fdt$object_attribute;

*copyc fdt$object_attribute
*DECK DECK=FDT$OBJECT_ATTRIBUTE_INDEX EXPAND=FALSE
 TYPE
    fdt$object_attribute_index = 1 .. fdc$maximum_object_attributes;

*copyc fdc$maximum_object_attributes
*DECK DECK=FDT$OBJECT_DEFINITION EXPAND=FALSE
 TYPE

    fdt$object_definition = record
      case key: {input} fdt$object_definition_key of {input}

      = fdc$box =
        box_width: fdt$width,
        box_height: fdt$height,

      = fdc$constant_text =
        constant_text_width: fdt$width,
        p_constant_text: ^fdt$text,

      = fdc$constant_text_box =
        constant_box_height: fdt$height,
        constant_box_processing: fdt$text_box_processing,
        constant_box_width: fdt$width,
        p_constant_box_text: ^fdt$text,

      = fdc$line =
        x_increment: fdt$x_increment,
        y_increment: fdt$y_increment,

      = fdc$table =
        table_width: fdt$width,
        table_height: fdt$height,

      = fdc$variable_text =
        p_variable_text: ^fdt$text,
        variable_text_width: fdt$width,

      = fdc$variable_text_box =
        p_variable_box_text: ^fdt$text,
        variable_box_height: fdt$height,
        variable_box_processing: fdt$text_box_processing,
        variable_box_width: fdt$width,

      casend
    recend;

*copyc fdt$object_definition_key
*copyc fdt$text
*copyc fdt$width
*copyc fdt$height
*copyc fdt$x_increment
*copyc fdt$y_increment
*copyc fdt$text_length
*copyc fdt$text_box_processing
*DECK DECK=FDT$OBJECT_DEFINITION_KEY EXPAND=FALSE
 TYPE
    fdt$object_definition_key = (fdc$box, fdc$constant_text,
      fdc$constant_text_box, fdc$line, fdc$table, fdc$variable_text,
      fdc$variable_text_box);
*DECK DECK=FDT$OBJECT_EVENT_POSITION EXPAND=FALSE
 TYPE
    fdt$object_event_position = record
      form_identifier: fdt$form_identifier,
      object_name: ost$name,
      occurrence: fdt$occurrence,
      case key: fdt$object_definition_key of

      = fdc$box, fdc$line, fdc$constant_text, fdc$constant_text_box =
        { The x, y positions are relative to the form. }
        form_x_position: fdt$x_position,
        form_y_position: fdt$y_position,

      = fdc$variable_text, fdc$variable_text_box =
        character_position: fdt$character_position,

      casend
    recend;

*copyc fdt$form_identifier
*copyc ost$name
*copyc fdt$occurrence
*copyc fdt$object_definition_key
*copyc fdt$x_position
*copyc fdt$y_position
*copyc fdt$character_position
*DECK DECK=FDT$OBJECT_INDEX EXPAND=FALSE
 TYPE
    fdt$object_index = 0 .. fdc$maximum_objects;

*copyc fdc$maximum_objects
*DECK DECK=FDT$OCCURRENCE EXPAND=FALSE
 TYPE
    fdt$occurrence = 1 .. fdc$maximum_occurrence;

*copyc fdc$maximum_occurrence
*DECK DECK=FDT$OUTPUT_CURRENCY_FORMAT EXPAND=FALSE
 TYPE
    fdt$output_currency_format = record
      currency_sybmol: string (1),
      thousands_separator: string (1),
      decimal_point: string (1),

{ Field_width, sign_treatment, and suppress_leading_zeros
{ are not used for fdc$program_cobol_type.

      field_width: fdt$text_length,
      sign_treatment: fdt$sign_treatment,
      suppress_leading_zeros: boolean {TRUE to suppress} ,
    recend;

*copyc fdt$text_length
*copyc fdt$sign_treatment
*DECK DECK=FDT$OUTPUT_FORMAT EXPAND=FALSE
 TYPE
    fdt$output_format = record
      case key: fdt$output_format_key of

      = fdc$character_output_format =
        ,

      = fdc$currency_output_format =
        output_currency_format: fdt$output_currency_format,

      = fdc$dmy_output_format =
        { Uses an 8 character field, dd/mm/yy }
        ,

      = fdc$e_e_output_format, fdc$g_e_output_format =
        exponent_output_format: fdt$exponent_output_format,

      = fdc$f_output_format, fdc$e_output_format, fdc$g_output_format =
        float_output_format: fdt$float_output_format,

      = fdc$integer_output_format =
        integer_output_format: fdt$integer_output_format,

      = fdc$iso_output_format =
        { Uses a 10 character field, yyyy-mm-dd }
        ,

      = fdc$mdy_output_format =
        { Uses an 8 character field, mm/dd/yy }
        ,

      = fdc$month_dd_yyyy_out_format =
        { Uses a 18 character field, monthxxxx dd, yyyy }
        ,

      = fdc$undefined_output_format =
        ,

      = fdc$ydm_output_format =
        { Uses an 8 character field, yy/dd/mm }
        ,

      casend
    recend;

*copyc fdt$output_format_key
*copyc fdt$output_currency_format
*copyc fdt$exponent_output_format
*copyc fdt$float_output_format
*copyc fdt$integer_output_format
*DECK DECK=FDT$OUTPUT_FORMAT_KEY EXPAND=FALSE
 TYPE
    fdt$output_format_key = (fdc$character_output_format,
      fdc$currency_output_format, fdc$dmy_output_format, fdc$e_e_output_format,
      fdc$e_output_format, fdc$f_output_format, fdc$g_e_output_format,
      fdc$g_output_format, fdc$iso_output_format, fdc$mdy_output_format,
      fdc$month_dd_yyyy_out_format, fdc$integer_output_format,
      fdc$undefined_output_format, fdc$ydm_output_format);
*DECK DECK=FDT$PICTURE EXPAND=FALSE

  TYPE
    fdt$picture = string (fdc$maximum_picture_length);

*copyc fdc$maximum_picture_length
*DECK DECK=FDT$PROGRAM_DATA_TYPE EXPAND=FALSE
 TYPE
    fdt$program_data_type = (fdc$program_character_type,
      fdc$program_integer_type, fdc$program_real_type,
      fdc$program_upper_case_type, fdc$program_cobol_type);
*DECK DECK=FDT$PROGRAM_VARIABLE_LENGTH EXPAND=FALSE
 TYPE
    fdt$program_variable_length = 0 .. fdc$maximum_variable_length;

*copyc fdc$maximum_variable_length
*DECK DECK=FDT$PUSH_COUNT EXPAND=FALSE
 TYPE
    fdt$push_count = 0 .. fdc$maximum_pushes;

*copyc fdc$maximum_pushes
*DECK DECK=FDT$PUT_VALUE_STATUS EXPAND=FALSE
 TYPE
    fdt$put_value_status = (fdc$put_value_accepted, fdc$unprocessed_put_value);
*DECK DECK=FDT$READ_FORMS_INDEX EXPAND=FALSE
  TYPE
    fdt$read_forms_index = 0 .. fdc$maximum_read_forms_index;

*copyc fdc$maximum_read_forms_index
*DECK DECK=FDT$REAL_FIELD_WIDTH EXPAND=FALSE
 TYPE
    fdt$real_field_width = 1 .. 19;

*DECK DECK=FDT$RECORD_ATTRIBUTE EXPAND=FALSE
 TYPE
    fdt$record_attribute = record
      put_value_status: {output} fdt$put_value_status ,
      case key:  {input} fdt$change_record_key of

      = fdc$record_deck_name =
        record_deck_name: {input} ost$name,

      = fdc$record_name =
        record_name: {input} ost$name,

      = fdc$record_type =
        record_type: {input} fdt$record_type,

      = fdc$table_access =
        table_name: {input} ost$name,
        access_all_occurrences: {input} boolean,

      = fdc$unused_record_entry =
        ,

      casend
    recend;

*copyc fdt$put_value_status
*copyc fdt$change_record_key
*copyc ost$name
*copyc fdt$record_type
*DECK DECK=FDT$RECORD_ATTRIBUTES EXPAND=FALSE
 TYPE
    fdt$record_attributes = array [1 .. * ] of fdt$record_attribute;

*copyc fdt$record_attribute
*DECK DECK=FDT$RECORD_ATTRIBUTE_INDEX EXPAND=FALSE
 TYPE
    fdt$record_attribute_index = integer;
*DECK DECK=FDT$RECORD_DEFINITIONS EXPAND=FALSE
 TYPE
    fdt$record_definitions = record
      active_number: fdt$number_record_variables,
      p_record_definitions: REL (fdt$form_module) ^array [1 .. * ] of
        fdt$variable_record_definition,
      total_number: fdt$number_record_variables,
    recend;

*copyc fdt$number_record_variables
*copyc fdt$form_module
*copyc fdt$variable_record_definition
*DECK DECK=FDT$RECORD_DEFINITION_KEY EXPAND=FALSE
 TYPE
    fdt$record_definition_key = (fdc$record_table, fdc$record_variable);
*DECK DECK=FDT$RECORD_INDEX EXPAND=FALSE
 TYPE
    fdt$record_index = integer;
*DECK DECK=FDT$RECORD_LENGTH EXPAND=FALSE
 TYPE
    fdt$record_length = 0 .. fdc$maximum_record_length;

*copyc fdc$maximum_record_length
*DECK DECK=FDT$RECORD_POSITION EXPAND=FALSE
 TYPE
    fdt$record_position = 1 .. fdc$maximum_record_length;

*copyc fdc$maximum_record_length
*DECK DECK=FDT$RECORD_TYPE EXPAND=FALSE
 TYPE
    fdt$record_type = (fdc$character_record, fdc$program_data_type_record);
*DECK DECK=FDT$SAVED_ERROR_DEFINITION EXPAND=FALSE

  TYPE
    fdt$saved_error_definition = record
      case key: fdt$error_key of

      = fdc$error_form =
        error_form: ost$name,

      = fdc$error_message =
        p_error_message: REL (fdt$form_module) ^fdt$error_message,

      = fdc$no_error_response, fdc$system_default_error =
        ,

      casend
    recend;

*copyc fdt$error_key
*copyc fdt$error_message
*copyc fdt$form_module
*copyc ost$name
*DECK DECK=FDT$SAVED_HELP_DEFINITION EXPAND=FALSE

  TYPE
    fdt$saved_help_definition = record
      case key: fdt$help_key of

      = fdc$help_form =
        help_form: ost$name,

      = fdc$help_message =
        p_help_message: REL (fdt$form_module) ^fdt$help_message,

      = fdc$no_help_response, fdc$system_default_help =
        ,

      casend
    recend;

*copyc fdt$help_key
*copyc fdt$help_message
*copyc fdt$form_module
*copyc ost$name
*DECK DECK=FDT$SCREEN_CHANGE EXPAND=FALSE

  TYPE
    fdt$screen_change = record
      case key: fdt$screen_change_key of

      = fdc$add_form, fdc$delete_form, fdc$erase_form =
        form_identifier: fdt$form_identifier,
        form_x_position: fdt$x_position,
        form_y_position: fdt$y_position,

      = fdc$add_object, fdc$delete_object =
        object_form_identifier: fdt$form_identifier,
        object_definition: fdt$form_object_definition,
        object_index: fdt$object_index,

      = fdc$change_table_size =
        table_form_identifier: fdt$form_identifier,
        table_index: fdt$table_index,

      = fdc$close_form =
        close_form_identifier: fdt$form_identifier,

      = fdc$create_mark =
        create_mark_form_identifier: fdt$form_identifier,
        start_x_position: fdt$x_position,
        start_y_position: fdt$y_position,
        end_x_position: fdt$x_position,
        end_y_position: fdt$y_position,
        create_mark_object_index: fdt$object_index,
        mark_object: boolean,

      = fdc$delete_mark =
        delete_mark_form_identifier: fdt$form_identifier,
        delete_mark_object_index: fdt$object_index,
        delete_mark_object: boolean,
        delete_mark_attributes: fdt$display_attribute_set,

      = fdc$format_text_box =
        format_text_form_identifier: fdt$form_identifier,
        format_text_object_index: fdt$object_index,
        p_format_text: ^fdt$text,

      = fdc$no_screen_change =
        ,

      = fdc$open_form =
        open_form_identifier: fdt$form_identifier,

      = fdc$push_forms, fdc$pop_forms =
        ,

      = fdc$replace_variable =
        variable_form_identifier: fdt$form_identifier,
        variable_object_index: fdt$object_index,
        p_text: ^fdt$text,

      = fdc$set_attribute, fdc$reset_event_variable =
        attribute_form_identifier: fdt$form_identifier,
        attribute_object_index: fdt$object_index,
        attribute: fdt$display_attribute_set,

      = fdc$set_cursor =
        cursor_form_identifier: fdt$form_identifier,
        cursor_object_index: fdt$object_index,
        cursor_character_position: fdt$character_position,

      casend
    recend;

*copyc fdt$character_position
*copyc fdt$display_attribute_set
*copyc fdt$form_identifier
*copyc fdt$form_object_definition
*copyc fdt$object_index
*copyc fdt$screen_change_key
*copyc fdt$table_index
*copyc fdt$x_position
*copyc fdt$y_position
*DECK DECK=FDT$SCREEN_CHANGES EXPAND=FALSE
 TYPE
    fdt$screen_changes = array [1 .. * ] of fdt$screen_change;

*copyc fdt$screen_change
*DECK DECK=FDT$SCREEN_CHANGE_INDEX EXPAND=FALSE
 TYPE
    fdt$screen_change_index = 1 .. fdc$maximum_screen_changes;

*copyc fdc$maximum_screen_changes
*DECK DECK=FDT$SCREEN_CHANGE_KEY EXPAND=FALSE

  TYPE
    fdt$screen_change_key = (fdc$add_form, fdc$add_object, fdc$close_form,
          fdc$create_mark, fdc$delete_form, fdc$delete_mark, fdc$delete_object,
          fdc$erase_form, fdc$no_screen_change, fdc$open_form, fdc$pop_forms,
          fdc$push_forms, fdc$replace_variable, fdc$set_attribute,
          fdc$set_cursor, fdc$change_table_size, fdc$reset_event_variable,
          fdc$format_text_box);

*DECK DECK=FDT$SCREEN_EVENT_STATUS EXPAND=FALSE
 TYPE
    fdt$screen_event_status = record
      event_exists: boolean,
      event_label: ost$name,
      event_trigger: fdt$event_trigger,
      event_used: boolean,
    recend;

*copyc fdt$event_trigger
*copyc ost$name
*DECK DECK=FDT$SCREEN_STATUS EXPAND=FALSE

  TYPE
    fdt$screen_status = record
      compute_new_screen_size: boolean,
      current_form_identifier: fdt$current_form_identifier,
      current_push_count: fdt$push_count,
      current_screen_height: fdt$height,
      current_screen_width: fdt$width,
      cursor_set: boolean,
      error_attribute_displayed: boolean,
      error_identifier: fdt$form_identifier,
      error_occurrence: fdt$occurrence,
      error_name: ost$name,
      event_identifier: cst$event_identifier,
      event_name: ost$name,
      event_normal: boolean,
      event_position: fdt$event_position,
      last_cursor_position_valid: boolean,
      last_cursor_form_identifier: fdt$form_identifier,
      message_form_displayed: boolean,
      message_form_identifier: fdt$form_identifier,
      number_active_forms: fdt$number_forms,
      number_screen_changes: fdt$number_screen_changes,
      p_forms_status: ^fdt$forms_status,
      p_screen_changes: ^fdt$screen_changes,
      p_screen_event_statuses: ^array [fdc$next .. fdc$clear_screen] of
            fdt$screen_event_status,
      read_forms_index: fdt$read_forms_index,
      screen_dimensions: cst$screen_dimensions,
      screen_mode_active: boolean,
    recend;

*copyc cst$event_identifier
*copyc cst$screen_dimensions
*copyc fdt$current_form_identifier
*copyc fdt$event_position
*copyc fdt$height
*copyc fdt$push_count
*copyc fdt$number_forms
*copyc fdt$number_screen_changes
*copyc fdt$form_identifier
*copyc fdt$forms_status
*copyc fdt$read_forms_index
*copyc fdt$screen_changes
*copyc fdt$screen_event_status
*copyc fdt$width
*copyc ost$name
*DECK DECK=FDT$SCREEN_TO_FORM_EVENT EXPAND=FALSE
 TYPE
    fdt$screen_to_form_event = record
      shifted: boolean,
      case event_type: cst$key_type of
      = csc$standard_function =
        standard_function: cst$standard_functions,
      = csc$application_function =
        application_function: cst$application_functions,
      = csc$screen_function =
        screen_function: cst$screen_events,
      = csc$unused_entry =
        ,
      casend,
    recend;

*copyc cst$application_functions
*copyc cst$key_type
*copyc cst$screen_events
*copyc cst$standard_functions
*DECK DECK=FDT$SCREEN_VARIABLE_LENGTH EXPAND=FALSE

  TYPE
    fdt$screen_variable_length = 0 .. 65535;

*DECK DECK=FDT$SIGN_TREATMENT EXPAND=FALSE
 TYPE
    fdt$sign_treatment = mlt$sign_treatment;

*copyc mlt$sign_treatment
*DECK DECK=FDT$TABLE_AREA EXPAND=FALSE
 TYPE
    fdt$table_area = record
      case key: fdt$table_area_key of

      = fdc$defined_table_area =
        x_position: fdt$x_position,
        y_position: fdt$y_position,
        width: fdt$width,
        height: fdt$height,

      = fdc$undefined_table_area =
        ,

      casend
    recend;

*copyc fdt$table_area_key
*copyc fdt$height
*copyc fdt$width
*copyc fdt$x_position
*copyc fdt$y_position
*DECK DECK=FDT$TABLE_AREA_KEY EXPAND=FALSE
 TYPE
    fdt$table_area_key = (fdc$defined_table_area, fdc$undefined_table_area);
*DECK DECK=FDT$TABLE_ATTRIBUTE EXPAND=FALSE
 TYPE
    fdt$table_attribute = record
      put_value_status: {output} fdt$put_value_status ,
      case key: {input} fdt$change_table_key of

      = fdc$add_table_variable, fdc$delete_table_variable =
        variable_name: {input} ost$name,

      = fdc$new_table_name =
        new_table_name: {input} ost$name,

      = fdc$stored_occurrence =
        stored_occurrence: {input} fdt$occurrence,

      = fdc$unused_table_entry =
        ,

      = fdc$visible_occurrence =
        visible_occurrence: {input} fdt$occurrence,

      casend
    recend;

*copyc fdt$change_table_key
*copyc fdt$occurrence
*copyc fdt$put_value_status
*copyc ost$name
*DECK DECK=FDT$TABLE_ATTRIBUTES EXPAND=FALSE
 TYPE
    fdt$table_attributes = array [1 .. * ] of fdt$table_attribute;

*copyc fdt$table_attribute
*DECK DECK=FDT$TABLE_ATTRIBUTE_INDEX EXPAND=FALSE
 TYPE
    fdt$table_attribute_index = integer;
*DECK DECK=FDT$TABLE_INDEX EXPAND=FALSE
 TYPE
    fdt$table_index = 1 .. fdc$maximum_tables;

*copyc fdc$maximum_tables
*DECK DECK=FDT$TABLE_OBJECT EXPAND=FALSE
  TYPE
    fdt$table_object = record
      object_exists: boolean,
      object_index: fdt$object_index,
      program_record_position: fdt$record_position,
      screen_record_position: fdt$record_position,
    recend;

*copyc fdt$object_index
*copyc fdt$record_position
*DECK DECK=FDT$TABLE_OBJECTS EXPAND=FALSE
 TYPE
    fdt$table_objects = record
      active_number: fdt$number_objects,
      p_table_objects: REL (fdt$form_module) ^array [1 .. * ] of
        fdt$table_object,
      total_number: fdt$number_objects,
    recend;

*copyc fdt$form_module
*copyc fdt$number_objects
*copyc fdt$table_object
*DECK DECK=FDT$TABLE_SIZE EXPAND=FALSE

  TYPE
    fdt$table_size = 0 .. fdc$maximum_occurrence;

*copyc fdc$maximum_occurrence
*DECK DECK=FDT$TABLE_STATUS EXPAND=FALSE

  TYPE
    fdt$table_status = record
      first_displayed_occurrence: fdt$occurrence,
      last_active_occurrence: fdt$table_size,
    recend;

*copyc fdt$occurrence
*copyc fdt$table_size
*DECK DECK=FDT$TABLE_VARIABLE EXPAND=FALSE
 TYPE
    fdt$table_variable = record
      name: ost$name,
      table_objects: fdt$table_objects,
      variable_exists: boolean,
      variable_index: fdt$variable_index,
    recend;

*copyc fdt$table_objects
*copyc fdt$variable_index
*copyc ost$name
*DECK DECK=FDT$TABLE_VARIABLES EXPAND=FALSE
 TYPE
    fdt$table_variables = record
      active_number: fdt$number_table_variables,
      p_table_variables: REL (fdt$form_module) ^array [1 .. * ] of
        fdt$table_variable,
      total_number: fdt$number_table_variables,
    recend;

*copyc fdt$form_module
*copyc fdt$number_table_variables
*copyc fdt$table_variable
*DECK DECK=FDT$TABLE_VARIABLE_INDEX EXPAND=FALSE
 TYPE
    fdt$table_variable_index = 1 .. fdc$maximum_table_variables;

*copyc fdc$maximum_table_variables
*DECK DECK=FDT$TERMINAL_USER_ENTRY EXPAND=FALSE
 TYPE
    fdt$terminal_user_entry = set of (fdc$entry_optional,
      fdc$must_enter,fdc$may_enter_unknown, fdc$must_fill);
*DECK DECK=FDT$TEXT EXPAND=FALSE
 TYPE
    fdt$text = string ( * <= fdc$maximum_text_length);

*copyc fdc$maximum_text_length

*DECK DECK=FDT$TEXT_BOX_PROCESSING EXPAND=FALSE
 TYPE
    fdt$text_box_processing = (fdc$center_characters, fdc$wrap_characters,
      fdc$wrap_words);
*DECK DECK=FDT$TEXT_LENGTH EXPAND=FALSE
 TYPE
    fdt$text_length = 0 .. fdc$maximum_text_length;

*copyc fdc$maximum_text_length
*DECK DECK=FDT$TEXT_POINTER EXPAND=FALSE
 TYPE
    fdt$text_pointer = record
      p_text: REL (fdt$form_module) ^fdt$text,
      text_exists: boolean,
    recend;

*copyc fdt$form_module
*copyc fdt$text
*DECK DECK=FDT$USAGE EXPAND=FALSE

TYPE
  fdt$usage = (fdc$binary_usage, fdc$computational_usage, fdc$comp_usage,
       fdc$computational_1_usage, fdc$comp_1_usage, fdc$computational_2_usage,
       fdc$comp_2_usage, fdc$computational_3_usage, fdc$comp_3_usage,
        fdc$packed_decimal_usage, fdc$display_usage, fdc$free_form_usage);
*DECK DECK=FDT$VALID_INTEGER_INDEX EXPAND=FALSE
 TYPE
    fdt$valid_integer_index = 1 .. fdc$maximum_valid_ranges;

*copyc fdc$maximum_valid_ranges
*DECK DECK=FDT$VALID_INTEGER_RANGE EXPAND=FALSE
 TYPE
    fdt$valid_integer_range = record
      minimum_integer: integer,
      maximum_integer: integer,
    recend;
*DECK DECK=FDT$VALID_INTEGER_RANGES EXPAND=FALSE
 TYPE
    fdt$valid_integer_ranges = record
      active_number: fdt$number_valid_integers,
      p_valid_integer_ranges: REL (fdt$form_module) ^array [1 .. * ] of
        fdt$valid_integer_range,
      total_number: fdt$number_valid_integers,
    recend;

*copyc fdt$form_module
*copyc fdt$number_valid_integers
*copyc fdt$valid_integer_range
*DECK DECK=FDT$VALID_REAL_INDEX EXPAND=FALSE
 TYPE
    fdt$valid_real_index = 1 .. fdc$maximum_valid_ranges;

*copyc fdc$maximum_valid_ranges
*DECK DECK=FDT$VALID_REAL_RANGE EXPAND=FALSE
 TYPE
    fdt$valid_real_range = record
      maximum_real: real,
      minimum_real: real,
    recend;
*DECK DECK=FDT$VALID_REAL_RANGES EXPAND=FALSE
 TYPE
    fdt$valid_real_ranges = record
      active_number: fdt$number_valid_reals,
      p_valid_real_ranges: REL (fdt$form_module) ^array [1 .. * ] of
        fdt$valid_real_range,
      total_number: fdt$number_valid_reals,
    recend;

*copyc fdt$form_module
*copyc fdt$number_valid_reals
*copyc fdt$valid_real_range
*DECK DECK=FDT$VALID_STRING EXPAND=FALSE
 TYPE
    fdt$valid_string = string ( * <= fdc$maximum_valid_string);

*copyc fdc$maximum_valid_string
*DECK DECK=FDT$VALID_STRINGS EXPAND=FALSE
 TYPE
    fdt$valid_strings = record
      active_number: fdt$number_valid_strings,
      compare_in_upper_case: boolean,
      compare_to_unique_substring: boolean,
      p_valid_strings: REL (fdt$form_module) ^array [1 .. * ] of
        fdt$valid_string_definition,
      total_number: fdt$number_valid_strings,
    recend;

*copyc fdt$form_module
*copyc fdt$number_valid_strings
*copyc fdt$valid_string_definition
*DECK DECK=FDT$VALID_STRING_DEFINITION EXPAND=FALSE
 TYPE
    fdt$valid_string_definition = record
      p_valid_string: REL (fdt$form_module) ^fdt$valid_string,
    recend;

*copyc fdt$form_module
*copyc fdt$valid_string
*DECK DECK=FDT$VALID_STRING_INDEX EXPAND=FALSE
 TYPE
    fdt$valid_string_index = 1 .. fdc$maximum_valid_strings;

*copyc fdc$maximum_valid_strings
*DECK DECK=FDT$VALID_STRING_LENGTH EXPAND=FALSE
 TYPE
    fdt$valid_string_length = 0 .. fdc$maximum_valid_string;

*copyc fdc$maximum_valid_string
*DECK DECK=FDT$VARIABLE_ATTRIBUTE EXPAND=FALSE
 TYPE

    fdt$variable_attribute = record
      put_value_status: {output} fdt$put_value_status ,
      case key: {input} fdt$change_variable_key {input} of

      = fdc$add_valid_integer_range, fdc$delete_valid_integer_range =
        maximum_integer: integer,
        minimum_integer: integer,

      = fdc$add_valid_real_range, fdc$delete_valid_real_range =
        maximum_real: real,
        minimum_real: real,

      = fdc$add_valid_string, fdc$delete_valid_string =
        p_valid_string: ^fdt$valid_string,

      = fdc$add_var_comment =
        p_var_comment: ^fdt$comment,

      = fdc$cobol_display_clause =
        p_cobol_display_clause: ^fdt$cobol_display_clause,

      = fdc$cobol_program_clause =
        p_cobol_program_clause: ^fdt$cobol_program_clause,

      = fdc$delete_var_comments =
        ,

      = fdc$input_format =
        input_format: fdt$input_format,

      = fdc$io_mode =
        io_mode: fdt$io_mode,

      = fdc$new_variable_name =
        new_variable_name: ost$name,

      = fdc$error_display =
        display_attribute: fdt$display_attribute_set,

      = fdc$output_format =
        output_format: fdt$output_format,

      = fdc$program_data_type =
        program_data_type: fdt$program_data_type,

      = fdc$process_as_event =
        process_as_event: boolean, { If true, the value of the variable is
        {treated as an }
        { event rather than a data item to be transferred to and from    a
        {program. }

      = fdc$string_compare_rules =
        compare_in_upper_case: boolean,
        compare_to_unique_substring: boolean,

      = fdc$terminal_user_entry =
        terminal_user_entry: fdt$terminal_user_entry,

      = fdc$unknown_entry_character =
        unknown_entry_character: string (1),

      = fdc$unused_variable_entry =
        ,

      = fdc$variable_error =
        variable_error: fdt$error_definition,

      = fdc$variable_help =
        variable_help: fdt$help_definition,

      = fdc$variable_length =
        variable_length: fdt$variable_length,
      casend
    recend;

*copyc fdt$change_variable_key
*copyc fdt$cobol_display_clause
*copyc fdt$cobol_program_clause
*copyc fdt$comment
*copyc fdt$display_attribute_set
*copyc fdt$error_definition
*copyc fdt$help_definition
*copyc fdt$input_format
*copyc fdt$io_mode
*copyc fdt$output_format
*copyc fdt$program_data_type
*copyc fdt$put_value_status
*copyc fdt$terminal_user_entry
*copyc fdt$valid_string
*copyc fdt$variable_length
*copyc ost$name
*DECK DECK=FDT$VARIABLE_ATTRIBUTES EXPAND=FALSE
 TYPE
    fdt$variable_attributes = array [1 .. * ] of fdt$variable_attribute;

*copyc fdt$variable_attribute
*DECK DECK=FDT$VARIABLE_ATTRIBUTE_INDEX EXPAND=FALSE
 TYPE
    fdt$variable_attribute_index = integer;
*DECK DECK=FDT$VARIABLE_INDEX EXPAND=FALSE
 TYPE
    fdt$variable_index = 1 .. fdc$maximum_variables;

*copyc fdc$maximum_variables
*DECK DECK=FDT$VARIABLE_LENGTH EXPAND=FALSE
 TYPE
    fdt$variable_length = 1 .. fdc$maximum_variable_length;

*copyc fdc$maximum_variable_length
*DECK DECK=FDT$VARIABLE_POINTER EXPAND=FALSE
 TYPE
    fdt$variable_pointer = record
      p_form_variable_definition: REL (fdt$form_module)
        ^fdt$form_variable_definition,
      variable_exists: boolean,
    recend;

*copyc fdt$form_module
*copyc fdt$form_variable_definition
*DECK DECK=FDT$VARIABLE_RECORD_DEFINITION EXPAND=FALSE
 TYPE
    fdt$variable_record_definition = record
      case key: fdt$record_definition_key of

      = fdc$record_table =
        table_index: fdt$table_index,

      = fdc$record_variable =
        variable_index: fdt$variable_index,
      casend
    recend;

*copyc fdt$record_definition_key
*copyc fdt$table_index
*copyc fdt$variable_index
*DECK DECK=FDT$VARIABLE_SEARCH EXPAND=FALSE
  TYPE
    fdt$variable_search = record
      case status: fdt$variable_search_status of
      = fdc$found_first_error, fdc$searching =
        object_index: fdt$object_index,
      = fdc$not_searched, fdc$search_completed, fdc$search_not_allowed =
        ,
      casend,
    recend;

*copyc fdt$object_index
*copyc fdt$variable_search_status
*DECK DECK=FDT$VARIABLE_SEARCH_STATUS EXPAND=FALSE
  TYPE
    fdt$variable_search_status = (fdc$not_searched, fdc$found_first_error,
          fdc$searching, fdc$search_completed, fdc$search_not_allowed);

*DECK DECK=FDT$VARIABLE_STATUS EXPAND=FALSE
 TYPE
    fdt$variable_status = (fdc$no_error, fdc$invalid_string, fdc$invalid_real,
      fdc$invalid_integer, fdc$unknown_user_value, fdc$invalid_bdp_data,
      fdc$no_digits, fdc$loss_of_significance, fdc$variable_not_filled,
      fdc$overflow, fdc$underflow, fdc$indefinite, fdc$infinite,
      fdc$variable_not_entered, fdc$output_format_bad, fdc$variable_truncated,
      fdc$gr_18_digits,
      fdc$invalid_overpunch_sign, fdc$invalid_separate_sign,
      fdc$c_without_r,  fdc$d_without_b,  fdc$floating_number_too_big,
      fdc$invalid_character_entered, fdc$no_cr_or_db_now,
      fdc$no_plus_or_minus_now,  fdc$no_scientific_notation,
      fdc$nonblk_outside_parentheses, fdc$nonblk_after_trailing_sign,
      fdc$too_many_decimal_points, fdc$too_many_signs);
*DECK DECK=FDT$VARIABLE_VALUE EXPAND=FALSE
  TYPE
    fdt$variable_value = record
      case program_data_type: fdt$program_data_type of
      = fdc$program_character_type, fdc$program_upper_case_type =
        p_text: ^fdt$text,
        text_length: fdt$text_length,
      = fdc$program_cobol_type =
        p_cobol_data: ^cell,
        cobol_data_length: fdt$program_variable_length,
      = fdc$program_integer_type =
        integer_value: integer,
      = fdc$program_real_type =
        real_value: real,
      casend
    recend;

*copyc fdt$program_variable_length
*copyc fdt$program_data_type
*copyc fdt$text
*copyc fdt$text_length
*DECK DECK=FDT$VISIBLE_HEIGHT EXPAND=FALSE
 TYPE
    fdt$visible_height = 1 .. fdc$maximum_y_position;

*copyc fdc$maximum_y_position
*DECK DECK=FDT$VISIBLE_WIDTH EXPAND=FALSE
 TYPE
    fdt$visible_width = 1 .. fdc$maximum_x_position;

*copyc fdc$maximum_x_position
*DECK DECK=FDT$WIDTH EXPAND=FALSE
 TYPE
    fdt$width = 1 .. fdc$maximum_x_position;

*copyc fdc$maximum_x_position
*DECK DECK=FDT$WORK_AREA_LENGTH EXPAND=FALSE
 TYPE
    fdt$work_area_length = 1 .. fdc$maximum_record_length;

*copyc fdc$maximum_record_length
*DECK DECK=FDT$X_INCREMENT EXPAND=FALSE
 TYPE
    fdt$x_increment = 0 .. fdc$maximum_x_position - 1;

*copyc fdc$maximum_x_position
*DECK DECK=FDT$X_POSITION EXPAND=FALSE
 TYPE
    fdt$x_position = 1 .. fdc$maximum_x_position;

*copyc fdc$maximum_x_position
*DECK DECK=FDT$Y_INCREMENT EXPAND=FALSE
 TYPE
    fdt$y_increment = 0 .. fdc$maximum_y_position - 1;

*copyc fdc$maximum_y_position
*DECK DECK=FDT$Y_POSITION EXPAND=FALSE
 TYPE
    fdt$y_position = 1 .. fdc$maximum_y_position;

*copyc fdc$maximum_y_position
*DECK DECK=FDV$APPLICATION_EVENT_TABLE EXPAND=FALSE

  VAR
    fdv$application_event_table: [XREF, READ, STATIC] array
          [csc$f1 .. csc$sf16] of fdt$event_trigger;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$event_trigger
*copyc cst$application_functions
?? POP ??
*DECK DECK=FDV$BACKGROUND_COLORS EXPAND=FALSE

  VAR
    fdv$background_colors: [XREF, READ, STATIC] fdt$display_attribute_set;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$display_attribute_set
?? POP ??
*DECK DECK=FDV$COBOL_CURRENCY_SYMBOLS EXPAND=FALSE

  VAR
    fdv$cobol_currency_symbols: [XREF] fdt$cobol_currency_symbols;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$cobol_currency_symbols
?? POP ??
*DECK DECK=FDV$COLORS EXPAND=FALSE

  VAR
    fdv$colors: [XREF, READ, STATIC] fdt$display_attribute_set;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$display_attribute_set
?? POP ??
*DECK DECK=FDV$FOREGROUND_COLORS EXPAND=FALSE

  VAR
    fdv$foreground_colors: [XREF, READ, STATIC] fdt$display_attribute_set;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$display_attribute_set
?? POP ??
*DECK DECK=FDV$LINE_ATTRIBUTES EXPAND=FALSE

  VAR
    fdv$line_attributes: [XREF, READ, STATIC] fdt$display_attribute_set;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$display_attribute_set
?? POP ??
*DECK DECK=FDV$LINE_WIDTHS EXPAND=FALSE

  VAR
    fdv$line_widths: [XREF, READ, STATIC] fdt$display_attribute_set;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$display_attribute_set
?? POP ??
*DECK DECK=FDV$LOGICAL_DISPLAY_ATTRIBUTES EXPAND=FALSE

  VAR
    fdv$logical_display_attributes: [XREF, READ, STATIC]
          fdt$display_attribute_set;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$display_attribute_set
?? POP ??
*DECK DECK=FDV$MESSAGE_VARIABLE_NAME EXPAND=FALSE

  VAR
    fdv$message_variable_name: [XREF, READ, STATIC] ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=FDV$OBJECT_DISPLAY_DIRECTIONS EXPAND=FALSE

  VAR
    fdv$object_display_directions: [XREF, READ, STATIC]
          fdt$display_attribute_set;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$display_attribute_set
?? POP ??
*DECK DECK=FDV$SCREEN_STATUS EXPAND=FALSE

  VAR
    fdv$screen_status: [XREF] fdt$screen_status;

?? PUSH (LISTEXT := ON) ??
*copyc fdt$screen_status
?? POP ??
*DECK DECK=FDV$SYSTEM_BAD_KEY_MESSAGE EXPAND=FALSE
*DECK DECK=FDV$SYSTEM_ERROR_MESSAGE EXPAND=FALSE
*DECK DECK=FDV$SYSTEM_HELP_MESSAGE EXPAND=FALSE
*DECK DECK=FDV$TO_COBOL EXPAND=FALSE

  VAR
    fdv$to_cobol: [XREF, READ, STATIC] string(256);

*DECK DECK=FDV$TO_CYBIL EXPAND=FALSE

  VAR
    fdv$to_cybil: [XREF, READ, STATIC] string(256);
*DECK DECK=FDV$TO_EXTENDED_FORTRAN EXPAND=FALSE

  VAR
    fdv$to_extended_fortran: [XREF, READ, STATIC] string(256);
*DECK DECK=FDV$TO_FORTRAN EXPAND=FALSE

  VAR
    fdv$to_fortran: [XREF, READ, STATIC] string(256);
*DECK DECK=FDV$TO_SCL EXPAND=FALSE

  VAR
    fdv$to_scl: [XREF, READ, STATIC] string(256);
*DECK DECK=FIP#ARRAY_UPPER_BOUND_IN_SEQ EXPAND=FALSE
  FUNCTION [INLINE] fip#array_upper_bound_in_seq
    (    seq_beg_p: ^SEQ ( * );
         seq_end_p: ^SEQ ( * );
         element_size: integer): integer;

?? PUSH (LISTEXT := ON) ??

    VAR
      fwa_p: fit#sequence_converter,
      lwa_p: fit#sequence_converter;

    fwa_p.s_p := seq_beg_p;
    lwa_p.s_p := seq_end_p;
    fip#array_upper_bound_in_seq := (lwa_p.s.nextt - fwa_p.s.nextt) DIV
          element_size;

  FUNCEND fip#array_upper_bound_in_seq;
*copyc fit#sequence_converter
?? POP ??
*DECK DECK=FIP#CREATE_SCRATCH_SEQUENCE EXPAND=FALSE
  PROCEDURE [INLINE] fip#create_scratch_sequence
    (VAR seq_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

{Return SEQ_P to a random access scratch segment.

    VAR
      scratch_segment: amt$segment_pointer;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random,
          scratch_segment, status);
    IF status.normal THEN
      seq_p := scratch_segment.sequence_pointer;
    IFEND;

  PROCEND fip#create_scratch_sequence;
*copyc ost$status
*copyc mmp$create_scratch_segment
?? POP ??


*DECK DECK=FIP#MOVE EXPAND=FALSE
  PROCEDURE [INLINE] fip#move
    (    source_p: ^cell;
         destination_p: ^cell;
         length: 0 .. 7fffffff(16));

?? PUSH (LISTEXT := ON) ??

{Copy SOURCE(1,LENGTH) to DESTINATION(1,LENGTH)
{
{NOTES
{. like I#MOVE, except no test for LENGTH > 0.
{. use FIP#MOVE_SHORT when you know LENGTH <= 255.

    VAR
      str1_p: ^string (65535),
      str2_p: ^string (65535);

?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??
    str1_p := source_p;
    str2_p := destination_p;
    str2_p^ (1, length) := str1_p^ (1, length);
    #SPOIL (str2_p^);
?? POP ??

  PROCEND fip#move;
?? POP ??
*DECK DECK=FIT#SEQUENCE_CONVERTER EXPAND=FALSE
  TYPE
    fit#sequence_converter = record
      case integer of
      = 0 =
        s_p: ^SEQ ( * ),
      = 1 =
        s: cyt$sequence_pointer,
      = 2 =
        pva: ost$pva,
      casend,
    recend;

*copyc cyd$cybil_structure_definitions
*DECK DECK=FMC$CURRENT_REVISION_LEVEL EXPAND=FALSE
  CONST
    fmc$current_revision_level = 2;

*DECK DECK=FMC$CYCLE_TABLE_ALLOCATION_SIZE EXPAND=FALSE

{ The number of cycle_descriptions allocated per cycle_description_unit.

  CONST
    fmc$cycle_table_allocation_size = 30;

*DECK DECK=FMC$ENTRY_ASSIGNED EXPAND=FALSE

  CONST
    fmc$entry_assigned = 'A',
    fmc$entry_free = ' ';
*DECK DECK=FMC$MAXIMUM_FILE_LABEL_SIZE EXPAND=FALSE
{This value represents the size of the compressed file label if all the
{attributes have non-default values and a job routing label of maximum size
{exists for the file.

  CONST
    fmc$maximum_file_label_size = 2211 + jmc$maximum_system_label_length;

*copyc jmc$maximum_system_label_length
*DECK DECK=FMC$NUMBER_OF_INIT_CYCLE_DESCS EXPAND=FALSE
{ This constant is chosen such that the initial cdu ends just exceeding a page
{ boundary.
  CONST
    fmc$number_of_init_cycle_descs = 55;
*DECK DECK=FMC$NUMBER_OF_INIT_PATH_DESCS EXPAND=FALSE
{ This constant is chosen such that the initial pdu ends just exceeding a page
{ boundary.
  CONST
    fmc$number_of_init_path_descs = 250;
*DECK DECK=FMC$PATH_TABLE_ALLOCATION_SIZE EXPAND=FALSE

{ The number of path_descriptions_entries allocated per path_description_unit.

  CONST
    fmc$path_table_allocation_size = 100;

*DECK DECK=FMC$PDE_UNIQUE_IDENTIFIER EXPAND=FALSE

  CONST
    fmc$pde_unique_identifier = 0EE(16); { 238(10) }
*DECK DECK=FMC$STATISTICS_MAX_PATH_DEPTH EXPAND=FALSE

  CONST
    fmc$statistics_max_path_depth = 15;
*DECK DECK=FMC$TEST_JR_CONSTANTS EXPAND=FALSE
{ This decks exists to allow testing of job recovery endcases.
{ FIle manager places imbedded calls to syp$hang_if_job_jrt_set to
{ force hangs in file system code.
{ To test do:
{ From the console do: setsa allow_jr_test 1
{ Within the job do: set_job_recovery_test job <the number below>

  CONST
    {File system range 200 .. 255
    { Permanent files 200 .. 229,  File Manager 230 .. 255
    { In fmp$record_open_cycle_info just after the call to mmp$open_file_segment
    { Any open file will test this.
    fmc$tjr_open_lnt = 230,

    { In fmp$delete_path_description just after calling pfp$return_permanent_fil
    { but before removing file from path table.  Test via detach_file
    fmc$tjr_return = 232,

    { Hang in either recover_all_files or recover_server_files
    fmc$tjr_recover_all_files = 233,

    { Abort during job recovery or server job recovery
    fmc$tjr_recovery_abort = 234;

*DECK DECK=FMC$UNIQUE_LABEL_ID EXPAND=FALSE

  CONST
    fmc$unique_label_id = '%';

*DECK DECK=FMD$INFO EXPAND=FALSE
 TYPE
    fmt$p_info = ^SEQ ( * ),

    fmt$p_lfn = ^amt$local_file_name,

    fmt$p_lfn_list = ^array [1 .. * ] of amt$local_file_name,

    fmt$p_number_of_lfns = ^fmt$number_of_lfns,

    fmt$number_of_lfns = 0 .. 10000000;

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
?? POP ??
*DECK DECK=FMD$VOLUME_INFO EXPAND=FALSE
 TYPE
    fmt$volume_information = array [1 .. * ] of fmt$volume_info,

    fmt$volume_info = record
      item_returned {output} : boolean,
      case key {input} : fmt$volume_info_keys of
      = fmc$number_of_volumes =
        number_of_volumes {output} : amt$volume_number,
      = fmc$volume =
        requested_volume_number {input} : amt$volume_number,
        volume {output} : rmt$volume_descriptor,
      = fmc$tape_density =
        tape_density {output} : rmt$density,
      = fmc$tape_class =
        tape_class {output} : rmt$tape_class,
      = fmc$write_ring =
        write_ring {output} : rmt$write_ring,
      casend,
    recend,

    fmt$volume_info_keys = (fmc$number_of_volumes, fmc$volume, fmc$tape_density,
      fmc$tape_class, fmc$write_ring);

?? PUSH (LISTEXT := ON) ??
*copyc rmd$tape_declarations
*copyc rmd$volume_declarations
*copyc amd$information
?? POP ??
*DECK DECK=FME$ECC_VALIDATION_ERRORS EXPAND=FALSE
*copyc amc$condition_code_limits

  CONST
{ The exception conditions in the range fmc$min_ecc_validation ..
{ fmc$max_ecc_validation are detected during the execution of
{ validated file_management_requests.

    fmc$min_ecc_program_action = amc$min_ecc_validation + 7000,
    fmc$max_ecc_program_action = fmc$min_ecc_program_action + 999;
*DECK DECK=FME$FILE_MANAGEMENT_ERRORS EXPAND=FALSE
*copyc fme$ecc_validation_errors
?? NEWTITLE := 'file management errors:  ''AM'' 7000 .. 7999', EJECT ??

?? FMT (FORMAT := OFF) ??


  CONST
    fmc$min_ecc_fil_mgmt_validation = fmc$min_ecc_program_action,

    fme$not_all_pfs_recovered = fmc$min_ecc_fil_mgmt_validation + 4,
    {F +P1 permanent file(s) not recovered in job.}

    fme$not_all_files_recovered = fmc$min_ecc_fil_mgmt_validation + 5,
    {F +P1 local file(s) not recovered in job.}

    fme$tape_files_not_recovered = fmc$min_ecc_fil_mgmt_validation + 6,
    {W +P1 tape file(s) not recovered in job.}

    fme$tape_resource_not_recovered = fmc$min_ecc_fil_mgmt_validation + 7,
    {W +P1 tape resource(s) not recovered in job.}

    fme$multiple_job_recoveries = fmc$min_ecc_fil_mgmt_validation + 8,
    {E Job recovery condition arose in the middle of job recovery.}

    fme$no_preserved_attributes = fmc$min_ecc_fil_mgmt_validation + 9,
    {E No preserved attributes were found for the file: +P1.}

    fme$no_cycle_description = fmc$min_ecc_fil_mgmt_validation + 12,
    {E There is no cycle description for the requested file.}

    fme$invalid_path_handle = fmc$min_ecc_fil_mgmt_validation + 13,
    {E An invalid path_handle was passed to file_management.}

    fme$obsolete_path_handle = fmc$min_ecc_fil_mgmt_validation + 14,
    {E An obsolete path_handle was passed to file_management.}

    fme$reattach_detached_file = fmc$min_ecc_fil_mgmt_validation + 15,
    {E A file was detached by an asynchronous task in the middle of this..
    { request.}

    fme$path_handle_not_resolved = fmc$min_ecc_fil_mgmt_validation + 16,
    {E System Error - resolved path_handle expected in +P1.}

    fme$wait_for_open_lock = fmc$min_ecc_fil_mgmt_validation + 17,
    {E An asynchronous task is in the process of opening this file.}

    fme$pt_locked_by_current_task = fmc$min_ecc_fil_mgmt_validation + 18,
    {E The path table is already locked by the current task.}

    fme$system_error = fmc$min_ecc_fil_mgmt_validation + 900,
    {F An error internal to the file system has occurred +P1 +P2 +P3 +P4 +P5}

    fmc$max_ecc_fil_mgmt_validation = fmc$min_ecc_fil_mgmt_validation + 999;

*copyc amc$condition_code_limits
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=FMH$ADD_TO_FILE_DESCRIPTION EXPAND=FALSE
{
{   The purpose of the procedure is to establish values for file attributes
{ which were left undefined by the task.  This procedure is provided to
{ implement an add_to_file request from a file access procedure (fap).
{ Using this procedure the fap is able to provide more pertinent default
{ values than the Basic Access Method has provided.  Attributes explicitly
{ specified by the task cannot be changed by this procedure.
{   This procedure may be called repeatedly during the open processing within
{ the fap.
{   The effect of this procedure is to initialize the preserved attribute
{ values.  This procedure will only succeed if called during the open
{ operation of a new file.
{}
{     FMP$ADD_TO_FILE_DESCRIPTION (LOCAL_FILE_NAME, FILE_ATTRIBUTES,
{         STATIC_LABEL, STATUS)
{}
{ LOCAL_FILE_NAME: (input) This parameter specifies the local file name
{   of the file for which the file attribute values are to be added
{   to the file description.
{
{ FILE_ATTRIBUTES: (input) This parameter specifies the attributes values
{   to be added to the file description.
{
{ STATIC_LABEL: (output) This parameter returns the static label with the
{   new attribute values added.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=FMH$ATTACH_FILE EXPAND=FALSE
{}
{ COMMON DECK FMH$ATTACH_FILE }
{}
{   The purpose of this request is to attach a permanent file.  The local file
{ name specified by local file name will be associated with the permanent file
{ specified by SFID and APFID until an FMP$RETURN_FILE request is issued for the
{ local file name.
{
{     FMP$ATTACH_FILE (LOCAL_FILE_NAME, GLOBAL_FILE_NAME, SFID, APFID,
{                    USAGE_SELECTIONS, SHARE_SELECTIONS, APPLICATION_INFO,
{                    VALIDATION_RING, PASSWORD_PROTECTED, IMPLICIT_ATTACH,
{                    P_FILE_LABEL, EVALUATED_FILE_REFERENCE, STATUS)
{
{ LOCAL_FILE_NAME: (input) This parameter specifies the local file name
{      that is to be associated with the permanent file.
{
{ GLOBAL_FILE_NAME: (input) This parameter specifies the unique external name
{       assigned to the permanent file.
{
{ INTERNAL_CYCLE_NAME: (input) This parameter specifies the unique internal name
{       assigned to the permanent file.
{
{ SFID: (input) This parameter specifies the system file identifier that was
{       assigned to the permanent file.
{
{ APFID: (input) This parameter specifies the attached permanent file
{       identifier that was assigned to the permanent file.
{
{ USAGE_SELECTIONS: (input) This parameter specifies how the permanent file
{       may be used when referenced by local file name.
{
{ SHARE_SELECTIONS: (input) This parameter specifies how the permanent file
{       may be shared by other instances of attach.
{
{ APPLICATION_INFO: (input) This parameter specifies the application info that
{       is associated with this attachment of the permanent file.
{
{ VALIDATION_RING: (input) This parameter specifies the ring number to be
{       used in validating that the requested usage is allowed for the file.
{
{ PASSWORD_PROTECTED: (input) This parameter indicates whether the file has
{       password protection.
{
{ IMPLICIT_ATTACH: (input) This parameter indicates whether the file
{       attachment is implicit.
{
{ P_FILE_LABEL: (input) This parameter specifies the file label to be
{       associated with this attachment of the permanent file.
{
{ EVALUATED_FILE_REFERENCE: (input/output) This parameter identifies the file to
{      be attached.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=FMH$CHANGE_FILE_ATTRIBUTES EXPAND=FALSE
{
{ COMMON DECK FMHCFA }
{
{   The purpose of this procedure is to alter certain file attributes for a
{ file which has previously been created (i.e. an old file.)
{   When a file is created (i.e. when it is initially opened) file
{ attributes provided by the creator are preserved with the file.
{ This procedure can change a subset of the preserved attributes
{ on permanent or temporary files.  A permanent file must not currently
{ be attached to another job and the global share mode must be NONE.
{}
{    FMP$CHANGE_FILE_ATTRIBUTES (LOCAL_FILE_NAME, VALIDATION_RING,
{        FILE_ATTRIBUTES, STATUS)
{
{  LOCAL_FILE_NAME: (input) This parameter specifies the local name
{    of the file for which attributes are to be changed.
{
{  VALIDATION_RING: (input) This parameter specifies the validation
{    ring to be used in ring validation.
{
{  FILE_ATTRIBUTES: (input) This parameter is an array of attributes
{    specifying which attributes are to be changed and the new values.
{
{  STATUS: (output) This parameter returns the request status.
{
*DECK DECK=FMH$CHANGE_RECORDED_CYCLE_NUM EXPAND=FALSE
{
{   The purpose of this procedure is to change the cycle_number of a "cycle
{ object" within the file system's "path description table".
{   It is assumed that Permanent File Management has already verified that
{ the path is a valid permanent file and that the new_cycle_number is not
{ already in use.
{
{       FMP$CHANGE_RECORDED_CYCLE_NUM (PATH_ELEMENTS, CYCLE_REFERENCE,
{         NEW_CYCLE_NUMBER, STATUS)
{
{ PATH_ELEMENTS: (input) This parameter specifies the path_elements
{       used to reference the entry to be changed.
{
{ CYCLE_REFERENCE: (input) This parameter specifies the cycle number
{       of the node to be changed.
{
{ NEW_CYCLE_NUMBER: (input) This parameter specifies the new cycle number for
{       the node.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=FMH$CHANGE_RECORDED_FILE_NAME EXPAND=FALSE
{
{   The purpose of this procedure is to change the "node name" of a "named
{ object" within the file system's "path description table".
{   It is assummed that Permanent File Management has already verified that
{ the path is a valid permanent file path and that the new_file_name is not
{ already in use.
{
{       FMP$CHANGE_RECORDED_FILE_NAME (PATH_ELEMENTS,
{         NEW_FILE_NAME, STATUS)
{
{ PATH_ELEMENTS: (input) This parameter specifies the path_elements
{       used to reference the entry to be changed.
{
{ NEW_FILE_NAME: (input) This parameter specifies the new name for the node.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=FMH$CREATE_JOB_FILE_ENTRY EXPAND=FALSE

{  The purpose of this request is to create a job file table
{ entry initializing the entry and establishing the proper
{ device attributes.
{
{       FMP$CREATE_JOB_FILE_ENTRY (ATTRIBUTES, CALLER_RING, REQUEST_DESCRIPTOR,
{         GLOBAL_FILE_NAME, JFID, SFID, STATUS)
{
{ ATTRIBUTES: (input) This parameter specifies a set of hardware
{       and software attributes to be associated with the file.
{
{ CALLER_RING: (input) This parameter specifies the caller ring.
{
{ REQUEST_DESCRIPTOR: (input) This parameter specifies the request descriptor.
{
{ GLOBAL_FILE_NAME: (output) This parameter specifies the global
{       file name which has been assigned to the file.
{
{ JFID: (output) This parameter specifies the job_file_identifier
{       which has been assigned.
{
{ SFID: (output) This parameter specifies the system_file_identifier
{       which has been assigned the file by device management.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=FMH$DELETE_PATH_DESCRIPTION EXPAND=FALSE
{
{   The purpose of this procedure is to attempt to delete a
{ path_description_entry if it meets deletion requirements and to continue to
{ delete parent path_description_entries that meet deletion requirements.
{ Deletion requirements are that delete_allowed be true, and the
{ active_participation_count equal to 0.
{
{       FMP$DELETE_PATH_DESCRIPTION (PATH_HANDLE, IMPLICIT_DETACH,
{         RETURN_PERMANENT_FILE, DETACHMENT_OPTIONS, STATUS)
{
{ PATH_HANDLE: (input)  This parameter specifies the path_handle to use to find
{       the path_description_entry to delete.
{
{ IMPLICIT_DETACH: (input)  This parameter specifies whether or not the the
{       deletion is for an implicit detach or not.
{
{ RETURN_PERMANENT_FILE: (input)  This parameter specifies whether or not a
{       detachment of an attached permanent file is required.
{
{ DETACHMENT_OPTIONS: (input)  This parameter specifies the detachment options
{       to be followed when the path description is deleted.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=FMH$END_OPEN_PROCESSING EXPAND=FALSE
{
{   The purpose  of this request is to store the label into the permanent file
{ catalog for an attached or newly created permanent file.  If no label exists
{ or  the  file is not a permanent file then an error status is returned.  The
{ label consists of both static file attributes for the file, and optionally a
{ job management file label.
{
{       FMP$END_OPEN_PROCESSING (LOCAL_FILE_NAME, WRITE_LABEL, STATUS)
{
{ LOCAL_FILE_NAME: (input) This parameter specifies the local name of the file
{       whose label is to be flushed.
{
{ WRITE_LABEL: (input) This parameter is not used.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: lne$ln_lnt_entry_not_found
{                   fme$system_error
{
{       IDENTIFIER: amc$access_method_id
{
*DECK DECK=FMH$FETCH_SYSTEM_LABEL_SIZE EXPAND=FALSE
{
{   The purpose  of  this  procedure  is to return the size of the label for a
{ permanent file.  This is not the  same  label  that  is  used  for  internal
{ interfaces  between  the  local file manager and the permanent file manager,
{ but rather is a label of a different format that  can  be  returned  to  the
{ permanent  file  utilities.   This label size may then be used to allocate a
{ sequence of a sufficient size that can be given to FMP$FETCH_SYSTEM_LABEL.
{
{       FMP$FETCH_SYSTEM_LABEL_SIZE (LOCAL_FILE_NAME, LABEL_SIZE, STATUS)
{
{ LOCAL_FILE_NAME: (input) This parameter specifies  the  local  name  of  the
{       permanent file whose permanent file utility label is to be returned.
{
{ LABEL_SIZE:  (output)  This parameter returns the size of the permanent file
{       utility label in bytes.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: cle$improper_name
{                   lne$ln_lnt_entry_not_found
{                   lne$no_preserved_attributes
{
{       IDENTIFIER: amc$access_method_id
{
*DECK DECK=FMH$FILE_COMMAND EXPAND=FALSE
{}
{ COMMON DECK FMHFILC }
{}
{   The purpose of this request is to associate file attributes resulting
{ from a file command (i.e. SET_FILE_ATTRIBUTES) with a local file name.
{ The attributes are added to end of a linked list which is pointed to from
{ the local name table entry.
{}
{     FMP$FILE_COMMAND (LOCAL_FILE_NAME, FILE_CMD_RING, FILE_ATTRIBUTES,
{         STATUS)
{}
{ LOCAL_FILE_NAME: (input) This parameter specifies the local file name
{   the file attributes are to be associated with.
{
{ FILE_CMD_RING: (input) This parameter specifies the ring number to be
{   used for user ring validation.
{
{ FILE_ATTRIBUTES: (input) This parameter specifies the file attribute
{   values to be associated with the local file name.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=FMH$FILE_IS_OPEN EXPAND=FALSE
{
{     The purpose of this request is to determine where a specified file is
{  open in the requesting job.
{
{     FMP$FILE_IS_OPEN (LOCAL_FILE_NAME):BOOLEAN
{
{ LOCAL_FILE_NAME: (input) This parameter specifies the file.
{
{
*DECK DECK=FMH$FILE_LABEL_FUNCTIONS EXPAND=FALSE
{
{ PURPOSE:
{   This module allows the storing and retrieving of the static_label attributes
{ in the system_file_label.
{
{        FMP$PUT_LABEL_ATTRIBUTES (STATIC_LABEL_ATTRIBUTES, SYSTEM_FILE_LABEL,
{              STATUS)
{
{ STATIC_LABEL_ATTRIBUTES: (input) This parameter specifies the record
{        containing the attributes to be stored.
{
{ SYSTEM_FILE_LABEL: (output) This parameter specifies the record in which
{        the static_label attributes are to be stored.
{
{ STATUS: (output) This parameter returns the request status.
{
{        FMP$GET_LABEL_ATTRIBUTES (SYSTEM_FILE_LABEL, STATIC_LABEL_ATTRIBUTES,
{              STATUS)
{
{ SYSTEM_FILE_LABEL: (input) This parameter specifies the record containing
{        the static_label attributes to be retrieved.
{
{ STATIC_LABEL_ATTRIBUTES: (output) This parameter specifies the record which
{        will contain the retrieved attributes.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=FMH$GET_ATTACHMENT_VALUES_IN_CD EXPAND=FALSE
{
{   The purpose of this procedure is to get attachment information that
{ has been stored in a cycle_description.
{
{      FMP$GET_ATTACHMENT_VALUES_IN_CD (CYCLE_DESCRIPTION,
{        ATTACHMENT_VALUES, STATUS)
{
{ CYCLE_DESCRIPTION: (input) This parameter specifies a pointer to the
{      cycle_description.
{
{ ATTACHMENT_VALUES: (input,output) This parameter specifies the record which
{      will contain the attachment values and has been passed in with the
{      fields set which are to be returned.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=FMH$GET_FILE_ATTRIBUTES EXPAND=FALSE
{the purpose of this request is to merge a series of attribute
{tables and return to the caller a composite set of attributes
{based on a defined heirarcharcial merge.
{
{
{   FMP$GET_FILE_ATTRIBUTES (LOCAL_NAME, REQUEST_DESCRIPTOR,
{                            LABEL_DESCRIPTOR, FILE_DESCRIPTOR,
{                            NEW_FILE_DESCRIPTOR, SYSTEM_ATTRIBUTES,
{                            POSITION_INFO, STATUS)
{
{
{ LOCAL_NAME (input): this parameter describes the local name by which
{                     this file will be identified.
{
{ REQUEST_DESCRIPTOR (input): this parameter describes the attribute set
{                             of request.
{
{ LABEL_DESCRIPTOR (input): this parameter describes the attribute set
{                           of label information.
{
{ FILE_DESCRIPTOR (input): this parameter describes the attribute set of
{                          file_information.
{
{ NEW_FILE_DESCRIPTOR (input): this parameter describes the attribute set of
{                              new_file_information.
{
{ SYSTEM_ATTRIBUTES (output): this parameter describes the composite table
{                             of merged attributes.
{
{ POSITION_INFO (output): this parameter describes a pointer to a table
{                         of file position information.
{
{ STATUS (output): this parameter describes request status.
*DECK DECK=FMH$GET_JL_POINTER EXPAND=FALSE
{}
{ COMMON DECK FMHGJLP }
{}
{   The purpose of this request is to retrieve a sequence pointer to
{ job management information associated with a local file name.
{ If a local name table entry does not exist for the specified local file name
{ then an entry will be created.
{}
{     FMP$GET_JL_POINTER (LOCAL_FILE_NAME, APPEND, JL_PTR, STATUS)
{}
{ LOCAL_FILE_NAME: (input) This parameter specifies the local file name
{   for which the jl_ptr is to be retrieved.
{
{ APPEND: (input) This parameter is a boolean value specifying whether
{   the existing size sequence is to be returned or the maximum allowable.
{   The maximum size sequence is based on a job management constant.
{
{ JL_PTR: (output) This parameter returns a sequence pointer for the
{   job management information associated with the specified local file
{   name.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=FMH$GET_OPEN_INFORMATION EXPAND=FALSE

{
{   The purpose of this request is to retrieve all the information which is
{ available for a particular file cycle.
{   One is not required to retrieve all the possible information for the file.
{ In fact, one is encouraged to retrieve only that information which is actually
{ required.  All the output parameters except user_defined_attribute_size accept
{ a NIL pointer to indicate that the parameter is not to be returned.  Refer to
{ the description of the catalog_information parameter for an additional caution.
{
{       FMP$GET_OPEN_INFORMATION (FILE_IDENTIFIER, ATTACHMENT_INFORMATION,
{         CATALOG_INFORMATION, CYCLE_ATTRIBUTE_SOURCES,
{         CYCLE_ATTRIBUTE_VALUES, INSTANCE_INFORMATION,
{         RESOLVED_FILE_REFERENCE, USER_DEFINED_ATTRIBUTES,
{         USER_DEFINED_ATTRIBUTE_SIZE, STATUS)
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the file access
{       identifier established when the file was opened.
{
{ ATTACHMENT_INFORMATION: (output)  This parameter specifies information about
{       the attachment of the file to the job.
{
{ CATALOG_INFORMATION: (output)  This parameter specifies file and file-cycle
{       catalog registration information.  If a non-NIL value is specified,
{       a catalog access will occur to retrieve this information; therefore,
{       there is a significant cost associated with returning this particular
{       parameter.
{
{ CYCLE_ATTRIBUTE_SOURCES: (output)  This parameter specifies the origination
{       of the values of all of the file-cycle attributes.
{
{ CYCLE_ATTRIBUTE_VALUES: (output)  This parameter specifies the values of all
{       of the file-cycle attributes.
{
{ INSTANCE_INFORMATION: (output)  This parameter specifies information which
{       may be unique to an instance of open of a file.  This information
{       includes the values of file-cycle attributes which were overridden
{       using the fsp$open_file request which established this instance of
{       open and the values of "attachment" options specified either by the
{       fsp$open_file request or an amp$store request.  If an attribute was
{       not overridden by the fsp$open_file request, the permanent value of
{       the attribute will be returned.
{
{ RESOLVED_FILE_REFERENCE: (output)  This parameter specifies the complete
{       path name of the file cycle, including the open position, if
{       specified.
{
{ USER_DEFINED_ATTRIBUTES: (output)  This parameter specifies the values of
{       all the user-defined attributes of the file.  The caller is
{       responsible for providing an area large enough to contain the sequence
{       of user-defined attributes.  If the area provided is not large enough,
{       abnormal status will be returned; in addition the request will return
{       the actual size of the area which will be required in the parameter
{       user_defined_attribute_size.  This will allow the caller to repeat the
{       request successfully.  If a NIL value is provided for this parameter,
{       no user-defined attributes will be returned.
{
{       Each user-defined attribute in the sequence consists of a header of
{       type fst$user_attribute_descriptor followed by the value of the
{       attribute.  One performs a NEXT for the header, determines the type of
{       user-defined attribute which follows and then does another NEXT to
{       obtain the attribute value; this continues until a NIL pointer is
{       returned by the NEXT or a header is found in which the
{       user_attribute_name field is equal to osc$null_name.
{
{       The user-defined-attribute sequence is RESET by this request.
{
{ USER_DEFINED_ATTRIBUTE_SIZE: (output)  This parameter specifies the exact
{       size of the user-defined attribute information.  This parameter is
{       initialized whether or not this request terminates normally.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_id.
{       IDENTIFIER: amc$access_method_id.
{
{

*DECK DECK=FMH$GET_PATH_TABLE_CYCLE_INFO EXPAND=FALSE
{
{   This procedure returns cycle information for a specific cycle from the
{ path table cycle description.  If $high_cycle, $low_cycle are specified
{ then the cycle number will be resolved in the path table, but not
{ the catalog.  If the cycle is omitted, $high_cycle is assumed.
{
{       FMP$GET_PATH_TABLE_CYCLE_INFO (EVALUATED_FILE_REFERENCE,
{         INHIBIT_PATH_TABBLE_LOCK, PATH_TABLE_CYCLE_INFO,
{         STATUS)
{
{ EVALUATED_FILE_REFERENCE: (input) This parameter specifies the evaluated
{         file reference.
{
{ INHIBIT_PATH_TABLE_LOCK: (input) This parameter specifies whether or not
{         the path table should be locked. FALSE indicates that the path table
{          will be locked.
{
{  PATH_TABLE_CYCLE_INFO: (output) This parameter returns the information from
{          the path table.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=FMH$IMPLICIT_DETACH_REQUIRED EXPAND=FALSE
{
{   The purpose of this request is to set the implicit_detach_required
{ field in a cycle_description to TRUE.  This will cause implicit detach to
{ occur on close or return.
{
{       FMP$IMPLICIT_DETACH_REQUIRED (PATH_HANDLE_NAME, STATUS)
{
{ PATH_HANDLE_NAME: (input) This parameter specifies the path_handle_name of
{       the cycle for which an implicit detach is required.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=FMH$IMPLICIT_RETURN_FILE EXPAND=FALSE
{}
{ COMMON DECK FMHIRF }
{}
{   The purpose of this request is to return a file that has been implicitly
{ attached in order that it might be reattached with different file
{ attributes.
{}
{     FMP$IMPLICIT_RETURN_FILE (LOCAL_FILE_NAME, STATUS)
{}
{ LOCAL_FILE_NAME: (input) This parameter specifies the local file name of
{   the file to be implicitly returned.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=FMH$IS_FILE_ATTACHED EXPAND=FALSE
{
{   The purpose of this request is to determine whether a specified file is
{ attached to the requesting job.
{
{       FMP$IS_FILE_ATTACHED (PATH_HANDLE, ATTACHED, STATUS)
{
{ PATH_HANDLE: (input) This parameter specifies the file.
{
{ ATTACHED: (output) This parameter specifies whether the file is attached.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=FMH$LN_OPEN_CHAPTER EXPAND=FALSE
{}
{ COMMON DECK FMHLNOC }
{}
{  The purpose of this request is to establish a named file
{entry in the local name table. If the file already exists
{then a call to mmp$open_segment is issued. If the file does
{not exist a call to create_job_file is issued prior to the
{mmp$open_segment.
{
{
{
{     FMP$LN_OPEN_CHAPTER (LOCAL_FILE_NAME, CHAPTER_NUMBER, VALIDATION_RING,
{               SEGMENT_ATTRIBUTES, POINTER_KIND, SEGMENT_POINTER,
{               STATUS)
{
{
{ LOCAL_FILE_NAME (input): this parameter specifies the local file name
{                     to be associated with the file.
{
{ CHAPTER_NUMBER (input): this parameter specifies the chapter
{                         number to associate with this instance of
{                         the file.
{
{ VALIDATION_RING (input): this parameter is used to validate access
{                          by the user of the file.
{
{ SEGMENT_ATTRIBUTES (input): this parameter specifies a set of hardware
{                             and software attributes to associate with
{                             the file.
{
{ POINTER_KIND (input): this parameter specifies the type of pointer
{                       (cell, heap, seq) to be returned.
{
{ SEGMENT_POINTER (output): this parameter returns the requested
{                          pointer.
{
{ STATUS (output): this parameter returns the request status.
*DECK DECK=FMH$LOCATE_CD_VIA_PATH_HANDLE EXPAND=FALSE
{
{   The purpose of this procedure is to validate a path_handle and return
{ a pointer to a cycle_description.  If the path_handle is not valid or
{ if the object pointed to by the path_handle is not a cycle_object, then
{ the pointer returned will be NIL and status will be abnormal.  If the the
{ path_handle points to valid cycle_object but their is no cycle_description
{ then a cycle_description will be created if create is true.
{   Note that this procedure leaves the cycle_description locked and it is the
{ the responsibility of the caller to unlock it when done.
{
{      FMP$LOCATE_CD_VIA_PATH_HANDLE (PATH_HANDLE, CREATE, CYCLE_DESCRIPTION,
{        STATUS)
{
{ PATH_HANDLE: (input) This parameter specifies the cycle_object for which
{   the pointer to a cycle_description is desired.
{
{ CREATE: (input) This parameter specifies whether a cycle_description should
{   be created if the cycle_object does not have one yet.
{
{ CYCLE_DESCRIPTION: (output) This parameter returns a pointer to a
{   cycle_description if one exists or is created. Otherwise, NIL is returned.
{
{ STATUS: (output) This parameter specifies the request status.  An abnormal
{   status will be returned if the path_handle is invalid or if the object
{   pointed to by the path_handle is not a cycle_object.
*DECK DECK=FMH$PATH_DESCRIPTION_ENTRY EXPAND=FALSE
{
{    The purpose of this deck is to document the purpose of each of
{ the components of the fmt$path_description_entry record.
{ Each referenced file or catalog path is described by one or more
{ of these records.
{    A path name is registered when SCL evaluates a file expression or
{ when a file is attached (temporary or permanent file).  Registering
{ a path causes one or more entries to be created in a tree structure.
{ Each entry in the tree is defined by the type
{ fmt$path_desription_entry.  An entry is created for each component
{ of the path. Note that the tree structure does not reflect catalog
{ heirarchies.
{    Entries are managed to avoid duplication.  For example if the
{ following paths were registered, there would only be one entry
{ each for NVE and AJL in the tree but there would be two entries
{ named 'X' in the tree because the parental path for each X is
{ different.
{
{      :NVE.AJL.X
{      :NVE.AJL.Y.X
{
{    fmt$path_description_entry:
{      active_path_participation_count:
{        Counts the number of times this node name appears as
{        the immediate parental name of an active path.  If this
{        count is zero, delete_allowed is true, and the last
{        path description is that of a file being detached, this
{        node will be deleted as a result of the detach.
{      attached_access_modes:
{      attached_share_modes:
{        The attached access and share modes define the permitted
{        capability provided the process which opens the cycle
{        to which this node points.  There may be multiple nodes
{        pointing to the same cycle object; each node may be
{        authorized for a different subset of the initial permitted
{        modes of access and share for the job.
{      cumulative_parental_path_size:
{        Counts the characters including ':' and '.' which are
{        required to express the file path up to this node. Since
{        the cycle object points back to the parental node name,
{        path names are re-constructed from right to left and this
{        makes that reconstuction simpler.
{      path_depth:
{        Counts the depth of this node in a set of path elements.  This
{        allows for reconstructing a path.
{      entry_assignment:
{        Points to a single character whose value indicates whether
{        this entry is assigned to an active path or available for
{        reuse.  It is used in conjunction with entry_assignment_
{        counter to validate a path_handle for this
{        node.
{      entry_assignment_counter:
{        When each entry is assigned a global variable which counts
{        the total number of entries assigned is incremented.  The
{        current value of this counter is stored in this component
{        of each assigned entry.  This value is encoded in the
{        path_handle of this entry for validation
{        purposes.
{      parental_path_entry:
{        This points to the entry elsewhere in the tree which
{        represents the parental node in the file path.
{        From the cycle object one can reconstruct the resolved
{        path name by following this chain back to the family
{        node, i.e. the end.
{      delete_allowed:
{        Indicates whether the path_handle for this
{        node has been handed to SCL. The lifetime of a path alias
{        which has been given to SCL cannot easily be determined.
{        Therefore, if this boolean is FALSE the entry cannot be
{        deleted.
{        If TRUE and if the active_path_participation_count is zero,
{        the node can be deleted. The attach_file and create_file
{        program interfaces always resolve the path prior to
{        registering a path in this tree.  If a program attaches or
{        creates a file and if the file path was not provided to the
{        program by SCL's clp$get_value or clp$convert_string_to_file
{        interfaces, then there are no dangling aliases to this
{        node which prevent us from deleting the entry when all
{        its child nodes are deleted.  This allows us to tidy-up
{        from the otherwise disastrous effects of BACKUP and
{        RESTORE on the size of this tree.
{      case entry_type:
{      = fmc$named_object =
{        This node is a named element of a file or catalog path.
{        parental_tree_entry:
{          This points to the parent tree node.  Note that this is not
{          necessarily the same node as the parental_path node.  It is
{          necessary to remember this in order to delete nodes.
{        left_subtree:
{          Entries to the left of this node have hashes whose
{          numerical value is less than the hashed value of this
{          entry's randomized_node_name.
{        right_subtree:
{          Entries to the right of this node have hashes whose
{          numerical value is greater than the hashed value of this
{          entry's randomized_node_name.
{        path_node_name:
{          This is the name of the node used when reconstructing the
{          file or catalog path name of which this node is a part.
{        randomized_node_name:
{          This is the hash of the node name or the hash of the
{          node name and the name of the immediate parental node,
{          depending upon whether or not there are other nodes in
{          the tree with the same name and a different parent.
{        highest_cycle:
{          If this node is the name of a file object, this points
{          to a list of cycle objects of this file sorted in
{          descending order.
{        next_cycle_alias_entry:
{          This is a pointer to the next alias entry if this named object is
{          not the only alias for a cycle object.  The first alias for a
{          cycle is pointed to by the first_cycle_alias_entry in the the
{          cycle object.
{      = fmc$file_cycle_object =
{        A cycle object is created when a unique file cycle path is
{        resolved.  This object identifies the "attachment" of the
{        file cycle to this job.  A cycle is physically attached
{        only once to a job; however, the same cycle may be logically
{        attached multiple times.  The access and share modes stored
{        in the cycle object are those authorized for the job.  The
{        access and share modes stored in named objects which point
{        to the same cycle object document "nested attaches" whose
{        access and share must be a subset of the initial attachment.
{        There is one and only one path_handle for a cycle
{        object.
{        cycle_number:
{          Numeric value of cycle portion of a resolved path name.
{        next_lower_cycle:
{          Points to an additional cycle of the same file with a
{          lower cycle number that may have been referenced within
{          the job.
{        next_higher_cycle:
{          Points to an additional cycle of the same file with a
{          higher cycle number that may have been referenced within
{          the job.
{        first_cycle_alias_entry:
{          Points to a named object that is an alias for this
{          cycle object.  If there are other alias entries for this
{          cycle object they will be pointed to from the named object by
{          next_cycle_alias_entry.
{        explicit_detach_allowed:
{          Indicates whether or not an explicit detach will be allowed.  It is
{          primarily used by SCL to prevent detaching a cycle within a block
{          structure.  This prevents the cycle from being detached and then
{          re-attached with different access or share modes.
{        implicit_detach_required:
{          Indicates that the file was implicitly attached by fsp$open_file
{          and must be detached on the last instance of fsp$close_file.
{        hide:
{          Indicates whether or not the cycle should be hidden.
{        scope:
{        block_identifier:
{        cycle_attachment_options:
{          This is a pointer to the default cycle attachment options that
{          will be used on an open.  It points to an adaptable sequence.
{        cycle_description:
{          This points to the data structure used by BAM to support
{          access to an attached file.
{
*DECK DECK=FMH$PUT_JL_POINTER EXPAND=FALSE
{}
{ COMMON DECK FMHPJP }
{
{   The purpose of this request is to associate job management information
{ with a local file name.  If requested the system label will also be
{ stored.
{}
{     FMP$PUT_JL_POINTER (LOCAL_FILE_NAME, WRITE_LABEL, JL_PTR, STATUS)
{}
{ LOCAL_FILE_NAME: (input) This parameter specifies the local file name
{   the job management information is to be associated with.
{
{ WRITE_LABEL: (input) This parameter specifies whether the System Label
{   is to be written.  The initial generation of System Label information
{   has to occur before the representative file is initially opened.  The
{   initial OPEN on the file will cause the generated System Label
{   information to be written to the System Label.  Under this described
{   circumstance this parameter should be set to FALSE. For any further
{   updates or additions to the System Label this parameter should be
{   set to TRUE, for if it is set to FALSE the System Label will not
{   be updated.
{
{ JL_PTR: (input) This parameter is a sequence pointer to job management
{   information.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=FMH$RECOVER_JOB_FILES EXPAND=FALSE
{   The purpose of this procedure is to "recover" files following a system crash.
{ This process attempts to leave the file manager tables (path_table,
{ and job_file_table, tape resource tables),
{ the permanent file tables (attached permanent file table,
{ queued catalog table) and set manager tables (job set table, active set table)
{ in a consistant state.
{ . Any permanent file attached at the time of the system failure needs to
{    be reattached.  This is because device management has lost knowledge of
{    those files that are attached on a system wide basis.  Thus the
{    system_file_identifier is incorrect.
{ . If a permanent or tape file is not recovered memory manager is notified
{    to invalidate and inhibit reference to the segment if it was open.
{ . Catalog previously attached must be removed from the job_file_table.
{ . Tape files will be removed, since there is no way of determining the
{    physical position of the tape.
{ . An attempt is made to reclaim tape resources that were in effect before
{   the system failure.  If a fatal reserve error occurs, the job will not recover.
{ . An attempt will be made to detect and report inconsistancies in the
{    tables, such as already locked entries, or the existence of two tables
{    that contain inconsistant entries (for example mis-match between permanent
{    files and file manager).  Often these errors (particularly locked entries)
{    may indicate that the interrupt occurred in the file system, and the
{    process did not rollback/cleanup properly.
{    If the error is in an individual file entry processing will continue,
{    and normal job termination is possible.
{
{ . This revision does NOT deal with:
{    - Catalog changes
{    - File damaged attributes
{    - Updating and correcting of eoi
{    - What to do with the task file table, and open files
{      If we get rid of the global file information during this, and close
{        wants to update GFI.
{    - Use of statistics to report occurences, etc.
{    - Use of condition handling to rollback
{    - Verification that all job_file_table entries have been "recovered"
{    - When removing a mounted tape, it might be nice to inform the operator.
{
{  This assumes:
{  - There has been no permanent file activity prior to this point in the job
{    since the system crash.
{  - While this process is executing there will be no other task attempting
{    access to the tables.  The determination of whether this is
{    the job monitor task is made OUTSIDE of this procedure.
{    The suspension of the non job monitor tasks is done outside of this
{    routine.
{  - All rollback in file manager, in ALL tasks has completed at this
{    time.
{  - Permanent file recovery, validation, and reconciliation has already run.
{
{   FMP$RECOVER_JOB_FILES (STATUS)
{
{  STATUS: (output) This parameter returns the request status.
{     The conditions:
{
{     ose$job_severely_damaged
{       indicates that the job recovery process detected something of severe
{       enough magnitude that the tables could not even be read.
{
{     ose$path_table_locked
{       indicates that an error has occurred in file manager, and that
{       rollback has not worked correctly.
{
{       Normal job termination may NOT be done to clean this up.
{       IF some permanent files were already reattched and this severe
{         condition is detected, these files will not be detached.  Subsequent
{         attaches will (eventually) see that this job is NOT found, and
{         delete the entry in the catalog, on cycle busy.  Subsequent
{         PF recoveries will also delete this "dead" jobs attachment to the
{         file.
{
{     When the following conditions occur normal job termination may proceed:
{
{     pfe$not_all_pfs_recovered, fme$not_all_pfs_recovered
{       indicates that not all permanent files were
{       reattachable.  The tables are left in a consistant state, however,
{       and normal job termination may be completed.
{     fme$tape_files_not_recovered indicates that the job was using tape
{       files at the time of the system failure.
{       The previous errors takes precedence over the occurrence of
{       this error.
{     fme$Not_all_files_recovered
{       indicates that a file of indeterminate type could not be reattached.
{       Example:  path table locked
{                 (or should this be a severely damaged ?)
{     fme$tape_resource_not_recovered
{       Indicates a fatal error occurred when attempting to reclaim tape
{       resources that were a result of a RESERVE_RESOURCE command.
{       The error fme$tape_files_not_recovered takes precedence over this.
{
{     fme$multiple_job_recoveries
{       Indicates that the job recovery condition occurred while in the
{       middle of this recovery.
*DECK DECK=FMH$RECOVER_SERVER_FILES EXPAND=FALSE
{
{   The purpose of this procedure is to "recover" files for a
{ particular server following a server timeout or client recovery,
{ and subsequent re-activation.
{ The process attempts to leave the following tables in a consistant state:
{ ---- CLIENT ------------------------------- SERVER ----------
{ memory manager segment descriptor table
{      extended
{ file manager tables (path_table,
{     and cycle table) and
{ device manager system file table
{                                       attached permanent file table
{                                       device manager system file table
{
{ . This process takes place on the first reference to the server by any task
{    in the job after the server becomes active.  The server becomes active
{    after system recovery.
{ . Any server file attached at the time of the server timeout needs to
{    be 'recovered'.  This is because device management on the server has
{    re-attached the file and the
{    remote system_file_identifier in the server descriptor in the
{    system file table of the client is incorrect.
{ . If a server file is not recovered, memory manager is notified
{    to terminate reference to the segment if it was open.
{ . An attempt will be made to detect and report inconsistancies in the
{    tables, such as already locked entries, or the existence of two tables
{    that contain inconsistant entries (for example mis-match between permanent
{    files and file manager).
{    If the error is in an individual file entry processing will continue,
{    and the file is left in a terminated state.
{
{ . This revision does NOT deal with:
{    - File damaged attributes
{    - Updating and correcting of eoi
{    - Use of statistics to report occurences, etc.
{
{  This assumes:
{  - While this process is executing there will be no other task attempting
{    server job  recovery.  A file server job recovery lock controls
{    multiple tasks.  The path table lock is used to prevent access to the
{    path table while this process is occuring.
{  - File server is active and requests can be made to the server.
{  - The file server processing has verified that this job exists on the
{    server and has initiated the attached permanent file setup.
{  - The file server processing will complete the permanent file server
{    job recovery process when done. This process is responsible for
{    removing files known by permanent files but known in the file manager
{    table.
{
{   FMP$RECOVER_SERVER_FILES (SERVER_MAINFRAME_ID, STATUS)
{
{  SERVER_MAINFRAME_ID: (input) This parameter specifies the server mainframe
{     to perform server job recovery on.
{
{  STATUS: (output) This parameter returns the request status.
{     The conditions:
{
{     pfe$not_all_pfs_recovered
{       indicates that not all permanent files were
{       reattachable.  The tables are left in a consistant state, however,
{       and normal job execution may continue.
*DECK DECK=FMH$REQUEST_MASS_STORAGE EXPAND=FALSE
{
{   The purpose of  this request is to assign a file to a mass storage device.
{ This request is optional since all new files are assigned to mass storage by
{ default.   The file must not already be assigned to a different device.  The
{ assignment applies  to  all  tasks  within  the  job  making  this  request.
{ Subsequent calls to this interface are not cumulative.
{
{       FMP$REQUEST_MASS_STORAGE (LOCAL_FILE_NAME, CLASS, ORDINAL,
{         ALLOCATION_SPEC, ST
{
{
{ LOCAL_FILE_NAME:  (input)  This  parameter specifies the local name of a new
{       file which is to be associated with mass storage.
{
{ CLASS: (input) This parameter specifies  the  characteristics  of  the  mass
{       storage  device  to  be  assigned to the file.  It is represented by a
{       letter (A->M) whose meaning is  specified  by  an  installation.   The
{       class  of  a  particular  mass  storage  device  is a logical property
{       assigned by the installation to the device when it is  configured.   A
{       mass storage device may be affiliated with more than one class.  Class
{       as a concept is not directly related to the concepts of family or mass
{       storage  sets  nor  is  the  use  of  the  class  parameter subject to
{       validation constraint.  However, when a list of candidate mass storage
{       volumes  qualified  by family, set and validation constraints has been
{       prepared  by  the  system,  class  can  be  used  to  specify  a  more
{       restrictive  subset  of  this  list.   For example, class A could mean
{       highspeed, high storage cost;  class  B  could  mean  'highspeed,  low
{       storage cost'.
{
{ ORDINAL:  (input)  This  parameter  specifies  which volume from the list of
{       candidate mass storage volumes is to  be  initially  assigned  to  the
{       file.   During the volume selection process, all candidate volumes are
{       ordered from 1 to N (N is the number of candidates).   This  parameter
{       (mod  N)  allows  the  user to spread files over different volumes for
{       reasons of performance, reliability, etc.
{
{ ALLOCATION_SPEC: (input) This parameter specifies the amount  of  contiguous
{       mass  storage  space,  in  bytes, which is to be allocated to the file
{       each time additional space is needed.  The system will use  the  value
{       of  this  parameter  as a guide in selecting the quantum of allocation
{       for this file.  The actual allocation_size for the file may be more or
{       less than the specified value due to the characteristics of the device
{       determined by CLASS and ORDINAL.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: amc$access_method_id
{
*DECK DECK=FMH$REQUEST_TAPE EXPAND=FALSE
{}
{ COMMON DECK FMHTAPE }
{}
{   The purpose of this request is to associate a device class of magnetic
{ tape device with a local file name.  It also associates operator
{ information with the local file name.
{}
{     FMP$REQUEST_TAPE (LOCAL_FILE_NAME, CLASS, DENSITY, WRITE_RING,
{         VOLUME_LIST, STATUS)
{}
{ LOCAL_FILE_NAME: (input) This parameter specifies the local file name
{   to be associated with a device class of magnetic tape.
{
{ CLASS: (input) This parameter specifies whether the class of tape
{   drive should be 7 track or 9 track.
{
{ DENSITY: (input) This parameter specifies the desired tape density.
{
{ WRITE_RING: (input) This parameter specifies if a write protect ring
{   is to be present on each volume mounted for this tape file.
{
{ VOLUME_LIST: (input) This parameter specifies a list of volume names to
{   be associated with this tape file.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=FMH$REQUEST_TERMINAL EXPAND=FALSE
{}
{ COMMON DECK FMHRQTC }
{}
{   The purpose of this request is to set a local file's device class
{ to identify it as a terminal device and to associate any requested
{ terminal attributes with the file.  If there is not currently a local
{ name table entry for this local file name then an entry will be created.
{ If terminal attributes are already associated with the specified local
{ file name then the new attributes are linked to the original list.
{}
{     FMP$REQUEST_TERMINAL (LOCAL_FILE_NAME, TERMINAL_ATTRIBUTES, STATUS)
{}
{ LOCAL_FILE_NAME: (input) This parameter specifies the local file name
{   that is to be associated with the terminal device class.
{
{ TERMINAL_ATTRIBUTES: (input) This parameter specifies the terminal
{   attributes that are to be associated with this local file name.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=FMH$SET_ATTACHMENT_VALUES_IN_CD EXPAND=FALSE
{
{   The purpose of this procedure is to set attachment information that
{ is to be stored in a cycle_description.
{
{      FMP$SET_ATTACHMENT_VALUES_IN_CD (CYCLE_DESCRIPTION,
{        ATTACHMENT_VALUES, STATUS)
{
{ CYCLE_DESCRIPTION: (input) This parameter specifies a pointer to the
{      cycle_description.
{
{ ATTACHMENT_VALUES: (input,output) This parameter specifies the record which
{      contains the attachment values and has been passed in with the
{      fields set which are to be stored.
{
{ STATUS: (output) This parameter returns the request status.
{

*DECK DECK=FMH$STORE_FILE_ATTRIBUTES EXPAND=FALSE

{}
{   The purpose of this request is to move elements from an array of}
{ of file attributes to a record of file attributes.}
{}
{      FMP$STORE_FILE_ATTRIBUTES ( FILE_ATTRIBUTES, SOURCE, SFA, STATUS)}
{}
{ FILE_ATTRIBUTES: (input) This parameter specifies the array of file}
{      attributes.}
{}
{ SOURCE: (input) This parameter specifies the source of the file attributes.}
{}
{ SFA: (output) This parameter specifies the record of file attributes}
{      that is being updated.}
{}
{ STATUS: (output) This parameter specifies the request status}
{}
*DECK DECK=FMH$STORE_SYSTEM_LABEL EXPAND=FALSE
{
{   The purpose  of  this procedure is to store a permanent file utility label
{ for a particular attached or newly created permanent file.  This stores  the
{ label  both  in  the  permanent  file  catalog  and job locally.  If a label
{ already exists for the file, it will be replaced, and the caller  must  have
{ control  permission to the permanent file.  This label must have been gotten
{ with the FMP$FETCH_SYSTEM_LABEL interface and must not  have  been  modified
{ since the fetch.
{
{       FMP$STORE_SYSTEM_LABEL (LOCAL_FILE_NAME, LABEL, STATUS)
{
{ LOCAL_FILE_NAME:  (input)  This  parameter  specifies the local name for the
{       permanent file.
{
{ LABEL: (input) This parameter specifies a sequence that contains  the  label
{       to be stored.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: cle$improper_name
{                   lne$ln_lnt_entry_not_found
{                   lne$incorrect_label_size
{                   lne$invalid_label_data
{                   lne$invalid_label_name
{                   lne$incompatible_label
{
{       IDENTIFIER: amc$access_method_id
{
*DECK DECK=FMH$TERMINATE_SERVER_FILES EXPAND=FALSE
{
{    The purpose of this procedure is to "terminate" files server files for a
{ particular server.  This procedure changes the access state so that the memory
{ manager prevents access to the terminated file.  The only thing that may be
{ done with a terminated server file is to detach it.
{
{       FMP$TERMINATE_SERVER_FILES (SERVER_MAINFRAME_ID, STATUS)
{
{  SERVER_MAINFRAME_ID: (input)  This parameter specifies the server mainframe
{        to terminate access too.
{
{  STATUS: (output) This parameter returns the request status.
{
*DECK DECK=FMH$VALIDATE_ACCESS EXPAND=FALSE

{  The purpose of this request is to validate a callers
{ access to a job file entry.
{
{     FMP$VALIDATE_ACCESS (JFID, VALIDATION_RING, RING_ATTRIBUTES,
{       ACCESS_MODE, STATUS)
{
{ JFID: (input) This parameter specifies the job file table entry
{      ordinal assigned at creation time.
{
{ VALIDATION_RING: (input) This parameter specifies the validation
{      ring of the caller.
{
{ RING_ATTRIBUTES: (input) This parameter specifies the proposed
{      ring attributes to be used for an instance of usage of a
{      file. the proposed ring attributes must be of lesser or
{      equal priviledge than the ring attributes preserved with
{      the file.
{
{ ACCESS_MODE: (input) This parameter specifies the intent of the
{      accessor of the file.
{
{ STATUS: (output) This parameter specifies request status.
*DECK DECK=FMH$VALIDATE_PF_ACCESS EXPAND=FALSE
{}
{ COMMON DECK FMHVPFA }
{}
{   The purpose of this request is to perform ring validation for permanent
{ files.
{}
{     FMP$VALIDATE_PF_ACCESS (P_FILE_LABEL, USAGE_SELECTIONS,
{         VALIDATION_RING, STATUS)
{}
{ P_FILE_LABEL: (input) This parameter specifies the permanent file label
{   which contains static attributes associated with the permanent file
{   by permanent file management.
{
{ USAGE_SELECTIONS: (input) This parameter specifies the requested access
{   mode.
{
{ VALIDATION_RING: (input) This parameter specifies the ring number to be
{   used for ring validation.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=FMI$GET_RING_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [INLINE] fmi$get_ring_attributes (
        p_file_label: {input} fmt$p_file_label;
    VAR cycle_formerly_opened_info: fmt$cycle_formerly_opened_info;
    VAR status: ost$status);

    VAR
      local_p_file_label: fmt$p_file_label,
      p_label_header: ^fmt$static_label_header;

    IF p_file_label = NIL THEN
      cycle_formerly_opened_info.cycle_previously_opened := FALSE;
      status.normal := TRUE;
    ELSEIF #SIZE (fmt$static_label_header) <= #SIZE (p_file_label^) THEN
      local_p_file_label := p_file_label;
      RESET local_p_file_label;
      NEXT p_label_header IN local_p_file_label;
      IF (p_label_header <> NIL) AND
            (p_label_header^.unique_character = fmc$unique_label_id) THEN
        cycle_formerly_opened_info.cycle_previously_opened := p_label_header^.
              file_previously_opened;
        IF p_label_header^.file_previously_opened THEN
          cycle_formerly_opened_info.ring_attributes := p_label_header^.
                ring_attributes;
          cycle_formerly_opened_info.ring_attributes_source := p_label_header^.
                ring_attributes_source;
        IFEND;
        status.normal := TRUE;
      ELSE
        osp$set_status_abnormal (amc$access_method_id,
              ame$damaged_file_attributes, 'Bad unique_character.', status);
      IFEND;
    ELSE
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, 'Label too small.', status);
    IFEND;
  PROCEND fmi$get_ring_attributes;

?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc fmc$unique_label_id
*copyc fmt$cycle_formerly_opened_info
*copyc fmt$file_label
*copyc fmt$static_label_header
*copyc osp$set_status_abnormal
*copyc ost$status
?? POP ??
*DECK DECK=FMI$PUT_JOB_ROUTING_LABEL EXPAND=FALSE
    PROCEDURE [INLINE] fmi$put_job_routing_label (job_label_size:
          jmt$system_label_info_length;
          route_info: ^SEQ ( * );
      VAR cycle_description: ^fmt$cycle_description;
      VAR status: ost$status);

      ALLOCATE cycle_description^.job_routing_label: [[REP job_label_size
            OF cell]] IN osv$job_pageable_heap^;
      IF cycle_description^.job_routing_label = NIL THEN
        osp$set_status_abnormal (amc$access_method_id, ose$job_pageable_full,
              'JOB PAGEABLE FULL in put_job_routing_label', status);
        RETURN;
      IFEND;
      cycle_description^.job_routing_label^ := route_info^;
      cycle_description^.job_routing_label_length := job_label_size;

    PROCEND fmi$put_job_routing_label;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_label_info_length
*copyc fmt$cycle_description
*copyc ose$heap_full_exceptions
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc osv$job_pageable_heap
?? POP ??

*DECK DECK=FMI$PUT_LABEL_IN_LNT EXPAND=FALSE

  PROCEDURE [INLINE] fmi$put_label_in_lnt (
        checksum_present: boolean;
        p_file_label_header: ^fmt$static_label_header;
    VAR p_file_label: fmt$p_file_label;
    VAR cycle_description: ^fmt$cycle_description;
    VAR status: ost$status);

    VAR
      adjusted_size: integer,
      header: ^fmt$static_label_header,
      label_size: integer,
      p_static_label: ^SEQ ( * ),
      start_of_label: ^cell;

    IF checksum_present THEN
      label_size := #SIZE (p_file_label^) - p_file_label_header^.
            job_routing_label_size - #SIZE (integer);
      NEXT start_of_label IN p_file_label;
      { move the pointer in the p_file_label to the beginning of the job_label }
      adjusted_size := label_size - #SIZE (start_of_label^);
      NEXT p_static_label: [[REP adjusted_size OF cell]] IN p_file_label;
    ELSE
      label_size := #SIZE (p_file_label^) - p_file_label_header^.
            job_routing_label_size;
      start_of_label := p_file_label;
    IFEND;

    IF cycle_description^.system_file_label.static_label <> NIL THEN
      FREE cycle_description^.system_file_label.static_label IN
            osv$job_pageable_heap^;
    IFEND;

    ALLOCATE cycle_description^.system_file_label.static_label:
          [[REP label_size OF cell]] IN osv$job_pageable_heap^;
    IF cycle_description^.system_file_label.static_label = NIL THEN
      osp$set_status_abnormal (amc$access_method_id, ose$job_pageable_full,
            'JOB PAGEABLE FULL in fmp$attach', status);
    ELSE
      i#move (start_of_label, cycle_description^.system_file_label.
            static_label, label_size);
      RESET cycle_description^.system_file_label.static_label;
      NEXT header IN cycle_description^.system_file_label.static_label;
      header^.revision_level := fmc$current_revision_level;
    IFEND;
  PROCEND fmi$put_label_in_lnt;

?? PUSH (LISTEXT := ON) ??
*copyc fmt$cycle_description
*copyc fmt$file_label
*copyc fmt$static_label_header
*copyc ose$heap_full_exceptions
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc osv$job_pageable_heap
?? POP ??

*DECK DECK=FMI$VALIDATE_RING_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [INLINE] fmi$validate_ring_attributes (
        cycle_formerly_opened_info: fmt$cycle_formerly_opened_info;
        usage_selections: pft$usage_selections;
        validation_ring: ost$valid_ring;
    VAR valid_ring: boolean);

    IF cycle_formerly_opened_info.cycle_previously_opened AND
          (cycle_formerly_opened_info.ring_attributes_source <>
          amc$undefined_attribute) THEN
      IF ($pft$usage_selections [pfc$append, pfc$modify, pfc$shorten] *
            usage_selections) <> $pft$usage_selections [] THEN
        valid_ring := (validation_ring <= cycle_formerly_opened_info.
              ring_attributes.r1);
      ELSEIF pfc$read IN usage_selections THEN
        valid_ring := (validation_ring <= cycle_formerly_opened_info.
              ring_attributes.r2);
      ELSEIF pfc$execute IN usage_selections THEN
        valid_ring := (validation_ring <= cycle_formerly_opened_info.
              ring_attributes.r3);
      ELSE {null access requested}
        valid_ring := TRUE;
      IFEND;
    ELSE
      valid_ring := TRUE;
    IFEND;
  PROCEND fmi$validate_ring_attributes;

?? PUSH (LISTEXT := ON) ??
*copyc fmt$cycle_formerly_opened_info
*copyc osd$virtual_address
*copyc pfd$permanent_file_attributes
?? POP ??
*DECK DECK=FMK$KEYPOINTS EXPAND=FALSE
{ This deck defines constants for use with keypoints in FMM procedures.}
{COMMON DECK FMDKEY}

  CONST

    fmk$attach_file = fmk$base + 1,
    {E 'fmp$attach_file' }
    {X 'fmp$attach_file' }

    fmk$return_file = fmk$base + 2,
    {E 'fmp$return_file' }
    {X 'fmp$return_file' }

    fmk$process_pt_request = fmk$base + 3;
    {E 'fmp$process_pt_request' }
    {X 'fmp$process_pt_request' }

?? PUSH (LISTEXT := ON) ??
*copyc OSK$KEYPOINTS
?? POP ??
*DECK DECK=FMM$CLOSE_FILE EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE File_Management : Close File' ??

MODULE fmm$close_file;

{
{ PURPOSE:
{   This module contains the interface that performs the necessary ring 2
{ operations for closing a file.
{
?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc bat$task_file_table
*copyc fst$file_access_options
?? POP ??
*copyc clp$check_name_for_path_handle
*copyc fmp$lock_path_table
*copyc fmp$return_file
*copyc fmp$unlock_path_table
*copyc mmp$close_segment
*copyc osp$decrement_locked_variable
*copyc osp$generate_log_message

*copyc fsv$evaluated_file_reference
?? OLDTITLE ??

?? NEWTITLE := '[XDCL, #GATE] fmp$close_file', EJECT ??
  PROCEDURE [XDCL, #GATE] fmp$close_file
    (    file_instance: ^bat$task_file_entry;
     VAR status: ost$status);

    VAR
      access_mode: fst$file_access_option,
      cl_path_handle: clt$path_handle,
      error: boolean,
      evaluated_file_reference: fst$evaluated_file_reference,
      file_pva: mmt$segment_pointer,
      ignore_status: ost$status,
      instance_access_modes: fst$file_access_options,
      open_count: integer;

{ The path table is locked to serialize access to the global file information.

    fmp$lock_path_table (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    open_count := 0;
    IF file_instance^.global_file_information <> NIL THEN
      osp$decrement_locked_variable (file_instance^.global_file_information^.open_count,
            1, open_count, error);

      #unchecked_conversion (file_instance^.instance_attributes.dynamic_label.
            access_mode, instance_access_modes);
      {Avoid decrementing multiple times should we retry due to file access condition
      file_instance^.instance_attributes.dynamic_label.access_mode := $pft$usage_selections [];
      FOR access_mode := LOWERVALUE (fst$file_access_option) TO UPPERVALUE
            (fst$file_access_option) DO
        IF (access_mode IN instance_access_modes) AND
           (file_instance^.global_file_information <> NIL) AND
           (file_instance^.global_file_information^.opened_access_modes [access_mode] > 0) THEN
          file_instance^.global_file_information^.opened_access_modes
                [access_mode] := file_instance^.global_file_information^.
                opened_access_modes [access_mode] - 1;
        IFEND;
        IF NOT (access_mode IN file_instance^.instance_attributes.dynamic_label.open_share_modes) AND
               (file_instance^.global_file_information <> NIL) AND
               (file_instance^.global_file_information^.prevented_open_access_modes [access_mode] > 0) THEN
          file_instance^.global_file_information^.prevented_open_access_modes
                [access_mode] := file_instance^.global_file_information^.
                prevented_open_access_modes [access_mode] - 1;
        IFEND;
      FOREND;

  { Remember the current address for use by next private_read open for $ASIS
  { or new global open asis with no other instances of open.

      IF file_instance^.private_read_information <> NIL THEN
        file_instance^.global_file_information^.asis_open_address :=
              file_instance^.private_read_information^.
              positioning_info.record_info.current_byte_address;
        file_instance^.global_file_information^.asis_bor_address :=
              file_instance^.private_read_information^.positioning_info.
              record_info.bor_address;
        file_instance^.global_file_information^.asis_file_position :=
              file_instance^.private_read_information^.positioning_info.
              record_info.file_position;
      ELSE
        file_instance^.global_file_information^.asis_open_address :=
              file_instance^.global_file_information^.
              positioning_info.record_info.current_byte_address;
        file_instance^.global_file_information^.asis_bor_address :=
              file_instance^.global_file_information^.positioning_info.
              record_info.bor_address;
        file_instance^.global_file_information^.asis_file_position :=
              file_instance^.global_file_information^.positioning_info.
              record_info.file_position;
      IFEND;
    IFEND;

    CASE file_instance^.device_class OF
    = rmc$mass_storage_device =
      IF file_instance^.file_pva <> NIL THEN
        file_pva.kind := mmc$cell_pointer;
        file_pva.cell_pointer := file_instance^.file_pva;
        mmp$close_segment (file_pva, 1, status);
        file_instance^.file_pva := NIL;
        IF NOT status.normal THEN
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log,
                pmc$system_log], status, ignore_status);
          fmp$unlock_path_table;
          RETURN;
        IFEND;
      IFEND;
    ELSE
      ;
    CASEND;

    fmp$unlock_path_table;

    IF open_count <= 0 THEN
      IF file_instance^.system_file_label^.descriptive_label.permanent_file
            THEN
        clp$check_name_for_path_handle (file_instance^.local_file_name,
              cl_path_handle);
        {change to call fmp$get_path_elements if status is nolonger ignored}
        evaluated_file_reference := fsv$evaluated_file_reference;
        evaluated_file_reference.path_handle_info.path_handle_present := TRUE;
        evaluated_file_reference.path_handle_info.path_handle := cl_path_handle.regular_handle;
        fmp$return_file (evaluated_file_reference, {implicit_detach} TRUE, {detachment_options} NIL,status);
      ELSEIF (file_instance^.instance_attributes.dynamic_label.
            return_option = amc$return_at_close) THEN
        clp$check_name_for_path_handle (file_instance^.local_file_name,
              cl_path_handle);
        {change to call fmp$get_path_elements if status is nolonger ignored}
        evaluated_file_reference := fsv$evaluated_file_reference;
        evaluated_file_reference.path_handle_info.path_handle_present := TRUE;
        evaluated_file_reference.path_handle_info.path_handle := cl_path_handle.regular_handle;
        fmp$return_file (evaluated_file_reference, {implicit_detach} FALSE, {detachment_options} NIL, status);
      IFEND;
    IFEND;

  PROCEND fmp$close_file;
MODEND fmm$close_file;
*DECK DECK=FMM$CYCLE_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : File Management : Cycle Manager' ??

MODULE fmm$cycle_manager;

{  PURPOSE:  This deck contains procedures which access and manipulate
{            information related to cycles.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc ame$lfn_program_actions
*copyc ame$ring_validation_errors
*copyc amt$file_byte_address
*copyc amt$local_file_name
*copyc ame$put_validation_errors
*copyc amt$ring_attributes
*copyc bat$block_header
*copyc bat$global_file_information
*copyc bat$instance_attributes
*copyc bat$tape_descriptor
*copyc cle$ecc_file_reference
*copyc cyc$max_string_size
*copyc dme$tape_errors
*copyc dmt$chapter_number
*copyc fmc$current_revision_level
*copyc fmc$entry_assigned
*copyc fmt$file_attribute_keys
*copyc fsc$local
*copyc fmc$test_jr_constants
*copyc fmc$unique_label_id
*copyc fme$file_management_errors
*copyc fmi$put_job_routing_label
*copyc fmi$validate_ring_attributes
*copyc fmk$keypoints
*copyc fmt$cd_attachment_options
*copyc fmt$cycle_formerly_opened_info
*copyc fmt$mass_storage_request_info
*copyc fmt$open_cleanup_work_list
*copyc fmt$path_description_unit
*copyc fmt$path_handle
*copyc fmt$path_table_cycle_info
*copyc fmt$pf_attachment_info
*copyc fmt$removable_media_req_info
*copyc fmt$static_label_header
*copyc fse$attach_validation_errors
*copyc fse$system_conditions
*copyc fst$detachment_options
*copyc fst$mass_storage_device_info
*copyc fst$path_handle_name
*copyc fst$transfer_size
*copyc gft$file_kind
*copyc ift$connection_attributes
*copyc jmc$system_family
*copyc jmt$system_label_info_length
*copyc ost$caller_identifier
*copyc ost$status
*copyc rmc$maximum_density
*copyc pfe$error_condition_codes
*copyc rme$request_command_exceptions
*copyc rme$request_mass_storage
*copyc rmt$allocation_size
*copyc rmt$device_class
*copyc rmt$mass_storage_class
*copyc rmt$recorded_vsn
*copyc rmt$tape_reservation
?? POP ??

*copyc amp$return
*copyc avp$get_capability
*copyc avp$system_administrator
*copyc bap$fetch_tape_validation
*copyc bap$set_evaluated_file_abnormal
*copyc bap$validate_compatibility
*copyc clp$construct_path_handle_name
*copyc clp$convert_file_ref_to_string
*copyc clp$return_connected_file
*copyc clp$validate_local_file_name
*copyc cmp$class_in_volume
*copyc dmp$close_tape_volume
*copyc dmp$create_file_entry
*copyc dmp$destroy_file
*copyc dmp$get_tape_volume_information
*copyc dmp$get_tape_volume_list
*copyc dmp$replace_tape_vsn_list
*copyc fmp$catalog_set_file_attributes
*copyc dmp$set_file_limit
*copyc fmp$create_cycle_description
*copyc fmp$delete_path_description
*copyc fmp$evaluate_path
*copyc fmp$expand_file_label
*copyc fmp$get_cycle_description
*copyc fmp$get_path_string
*copyc fmp$is_file_attached
*copyc fmp$locate_cd_via_path_handle
*copyc fmp$lock_path_table
*copyc fmp$process_pt_request
*copyc fmp$put_label_attributes
*copyc fmp$unlock_path_table
*copyc fmp$verify_attribute_limits
*copyc fmv$default_detachment_options
*copyc fsp$path_element
*copyc fsp$set_evaluated_file_abnormal
*copyc i#build_adaptable_seq_pointer
*copyc i#current_sequence_position
*copyc i#move
*copyc ifp$invoke_pause_utility
*copyc iop$create_rvl_entry
*copyc iop$delete_rvl_entry
*copyc iop$delete_rvl_entries_via_ssn
*copyc jmp$is_xterm_job
*copyc jmp$system_job
*copyc mmp$get_segment_length
*copyc mmp$open_file_segment
*copyc nap$se_return_file
*copyc nlp$cancel_switch_offer
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$decrement_locked_variable
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$establish_condition_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$fetch_locked_variable
*copyc osp$file_access_condition
*copyc osp$generate_log_message
*copyc osp$generate_unique_binary_name
*copyc osp$set_locked_variable
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$system_error
*copyc osv$initial_exception_context
*copyc pfp$begin_system_authority
*copyc pfp$check_device_availability
*copyc pfp$end_system_authority
*copyc pfp$return_permanent_file
*copyc pfp$save_file_label
*copyc pmp$continue_to_cause
*copyc pmp$get_user_identification
*copyc pmp$get_job_names
*copyc pmp$wait
*copyc rfp$delete_connection
*copyc rmp$clear_explicit_reserve
*copyc sfp$get_job_limit
*copyc syp$hang_if_job_jrt_set
*copyc syp$pop_inhibit_job_recovery
*copyc syp$push_inhibit_job_recovery

*copyc amv$aam_file_organizations
*copyc amv$device_class_names
*copyc dmv$null_sfid
*copyc fmv$initial_cdu_pointer
*copyc fmv$global_file_information
*copyc fmv$static_label_header
*copyc fmv$system_file_attributes
*copyc fmv$tape_attachment_information
*copyc fmv$tape_descriptor
*copyc jmv$executing_within_system_job
*copyc mmv$max_segment_length
*copyc mmv$preset_conversion_table
*copyc osv$job_pageable_heap
*copyc osv$task_shared_heap
*copyc osv$task_private_heap
*copyc sfv$dynamic_file_space_limits
*copyc rmv$null_device_set
*copyc rmv$requested_volume_attributes

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    one_second = 1000 {milliseconds};

  CONST
    dm_file_class_index = 1,
    dm_clear_space_index = 3,
    dm_file_limit_index = 4,
    dm_volume_overflow_index = 7,
    dm_owner = 8,
    dm_preset_value_index = 9,
    dm_allocation_size_index = 10,
    dm_initial_volume_index = 11,
    dm_transfer_size_index = 12;

  VAR
    dm_file_attributes: [STATIC, READ, oss$job_paged_literal] array
          [dm_file_class_index .. dm_transfer_size_index] of dmt$new_file_attribute := [
    {   } [dmc$class, rmc$msc_user_temporary_files],
    {   } [dmc$class_ordinal, dmc$default_class_ordinal],
    {   } [dmc$clear_space, FALSE],
    {   } [dmc$file_limit, amc$file_byte_limit],
    {   } [dmc$locked_file, [FALSE]],
    {   } [dmc$master_volume_required, FALSE],
    {   } [dmc$overflow, TRUE],
    {   } [dmc$owner, sfc$temp_file_space_limit],
    {   } [dmc$preset_value, 0],
    {   } [dmc$requested_allocation_size, dmc$unspecified_allocation_size],
    {   } [dmc$requested_volume, [rmc$unspecified_vsn, osc$null_name]],
    {   } [dmc$requested_transfer_size, dmc$unspecified_transfer_size]];

  CONST
    mm_ring_numbers_index = 1,
    mm_access_control_index = 2,
    mm_software_attributes_index = 3,
    mm_transfer_size_index = 4;

  VAR
    execute_access: [STATIC, READ, oss$job_paged_literal]
          pft$usage_selections := [pfc$execute],
    null_set: [STATIC, READ, oss$job_paged_literal] pft$usage_selections := [],
    read_access: [STATIC, READ, oss$job_paged_literal]
          pft$usage_selections := [pfc$read],
    write_access: [STATIC, READ, oss$job_paged_literal]
          pft$usage_selections := [pfc$append, pfc$modify, pfc$shorten];

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$attach_file', EJECT ??
*copy fmh$attach_file

  PROCEDURE [XDCL, #GATE] fmp$attach_file
    (    local_file_name: amt$local_file_name;
         global_file_name: ost$binary_unique_name;
         internal_cycle_name: ost$binary_unique_name;
         sfid: dmt$system_file_id;
         usage_mode: pft$usage_selections;
         share_mode: pft$share_selections;
         validation_ring: ost$valid_ring;
         file_space_limit_kind: sft$file_space_limit_kind;
         p_file_label: fmt$p_file_label;
         p_pf_attachment_info: ^fmt$pf_attachment_info;
         device_class: rmt$device_class;
         p_removable_media_req_info: {input} ^fmt$removable_media_req_info;
         p_volume_list: {input} ^rmt$volume_list;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR status: ost$status);

    CONST
      checksum_present = TRUE,
      expand_label = TRUE;

    VAR
      cycle_description: ^fmt$cycle_description,
      cycle_formerly_opened_info: fmt$cycle_formerly_opened_info,
      expanded_label: bat$static_label_attributes,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      ignore_process_pt_results: bat$process_pt_results,
      job_label: ^SEQ ( * ),
      job_label_size: jmt$system_label_info_length,
      last_path_element: ^fst$path_element_string,
      p_file_label_header: ^fmt$static_label_header,
      process_pt_work_list: bat$process_pt_work_list,
      ring_attributes: amt$ring_attributes,
      ring_attributes_source: amt$attribute_source,
      static_label_header: ^fmt$static_label_header,
      tape_descriptor: ^bat$tape_descriptor,
      tape_validation: boolean,
      valid_ring: boolean;

?? OLDTITLE ??
?? NEWTITLE := '  attach_file_handler', EJECT ??
  PROCEDURE attach_file_handler
    (    condition: pmt$condition;
         p_condition_info: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR condition_status: ost$status);

    VAR
      ignore_status: ost$status;

    CASE condition.selector OF
    = ifc$interactive_condition =
      CASE condition.interactive_condition OF
      = ifc$pause_break, ifc$job_reconnect =
        ifp$invoke_pause_utility (ignore_status);
      = ifc$terminate_break =
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
              ignore_status);
        EXIT fmp$attach_file;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;
    ELSE
      pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
    CASEND;
  PROCEND attach_file_handler;

    #keypoint (osk$entry, 0, fmk$attach_file);
    status.normal := TRUE;

  /begin_end/
    BEGIN
      IF p_file_label <> NIL THEN
        fmp$expand_file_label (p_file_label, expand_label, job_label, job_label_size,
              cycle_formerly_opened_info.ring_attributes, cycle_formerly_opened_info.ring_attributes_source,
              cycle_formerly_opened_info.cycle_previously_opened, expanded_label, status);
        IF NOT status.normal THEN
          EXIT /begin_end/;
        IFEND;

        fmi$validate_ring_attributes (cycle_formerly_opened_info, usage_mode, validation_ring, valid_ring);
        IF NOT valid_ring THEN
          osp$set_status_abnormal (amc$access_method_id, ame$ring_validation_error, '', status);
          EXIT /begin_end/;
        IFEND;
      IFEND;

      process_pt_work_list := $bat$process_pt_work_list [bac$record_path, bac$resolve_path,
            bac$return_cycle_description, bac$create_cycle_description, bac$inhibit_locking_pt];
      fmp$process_pt_request (process_pt_work_list, local_file_name, evaluated_file_reference,
            cycle_description, ignore_process_pt_results, status);
      IF NOT status.normal THEN
        EXIT /begin_end/;
      ELSEIF cycle_description = NIL THEN
        osp$set_status_abnormal (amc$access_method_id, fme$no_cycle_description, '', status);
        EXIT /begin_end/;
      IFEND;

      verify_device_assignment (evaluated_file_reference, device_class, cycle_description, status);
      IF NOT status.normal THEN
        EXIT /begin_end/;
      IFEND;

      assign_device_class (device_class, cycle_description);
      cycle_description^.system_file_id := sfid;

      IF fsp$path_element (^evaluated_file_reference, 1)^ <> fsc$local THEN
        cycle_description^.system_file_label.descriptive_label.permanent_file := TRUE;
        cycle_description^.system_file_label.descriptive_label.application_info :=
               p_pf_attachment_info^.application_info;
        cycle_description^.system_file_label.descriptive_label.global_share_mode := share_mode;
        cycle_description^.system_file_label.descriptive_label.global_access_mode := usage_mode;
        cycle_description^.system_file_label.descriptive_label.global_file_name := global_file_name;
        cycle_description^.system_file_label.descriptive_label.internal_cycle_name := internal_cycle_name;
        cycle_description^.file_space_limit_kind := file_space_limit_kind;
        cycle_description^.permanent_file := TRUE;
        cycle_description^.apfid := p_pf_attachment_info^.apfid;
        #UNCHECKED_CONVERSION (usage_mode, cycle_description^.attached_access_modes);
        #UNCHECKED_CONVERSION (share_mode, cycle_description^.attached_share_modes);
        cycle_description^.global_file_information^.implicit_detach_inhibited := FALSE;
        IF p_pf_attachment_info^.implicit_attach AND (NOT jmv$executing_within_system_job) THEN
          last_path_element := fsp$path_element (^evaluated_file_reference,
                evaluated_file_reference.number_of_path_elements);
          IF (fsp$path_element(^evaluated_file_reference, 1)^ = '$SYSTEM') AND
                ((last_path_element^ = 'BOUND_PRODUCT') OR (last_path_element^ = 'TERMINAL_DEFINITIONS')) AND
                (usage_mode = $pft$usage_selections [pfc$read, pfc$execute]) AND
                (share_mode = $pft$usage_selections [pfc$read, pfc$execute]) THEN
            cycle_description^.global_file_information^.implicit_detach_inhibited := TRUE;
          IFEND;
        IFEND;
        cycle_description^.password_protected := p_pf_attachment_info^.password_protected;
        cycle_description^.system_file_label_catalogued := FALSE;
        IF p_file_label <> NIL THEN
          cycle_description^.system_file_label.file_previously_opened :=
                cycle_formerly_opened_info.cycle_previously_opened;
          put_label_in_cd (p_file_label, cycle_description,
                evaluated_file_reference.path_handle_info.path_handle, status);
          IF NOT status.normal THEN
            EXIT /begin_end/;
          IFEND;
          IF job_label_size <> 0 THEN
            fmi$put_job_routing_label (job_label_size, job_label, cycle_description, status);
            IF NOT status.normal THEN
              EXIT /begin_end/;
            IFEND;
          IFEND;
          cycle_description^.system_file_label_catalogued := TRUE;
        IFEND;
      IFEND;

      IF device_class = rmc$magnetic_tape_device THEN
        cycle_description^.global_file_information^.device_dependent_info.device_class :=
              rmc$magnetic_tape_device;
        IF fsp$path_element (^evaluated_file_reference, 1)^ = fsc$local THEN
          cycle_description^.system_file_label.descriptive_label.global_share_mode := share_mode;
          cycle_description^.system_file_label.descriptive_label.global_access_mode := usage_mode;
          #UNCHECKED_CONVERSION (usage_mode, cycle_description^.attached_access_modes);
          #UNCHECKED_CONVERSION (share_mode, cycle_description^.attached_share_modes);
        IFEND;
        ALLOCATE cycle_description^.global_file_information^.device_dependent_info.tape_descriptor:
              [[REP (#SIZE (bat$tape_descriptor)) OF cell]] IN osv$task_shared_heap^;
        RESET cycle_description^.global_file_information^.device_dependent_info.tape_descriptor;
        NEXT tape_descriptor IN cycle_description^.global_file_information^.
              device_dependent_info.tape_descriptor;
        tape_descriptor^ := fmv$tape_descriptor;
        tape_descriptor^.requested_density := p_removable_media_req_info^.density;
        tape_descriptor^.tape_attachment_information := fmv$tape_attachment_information;
        tape_descriptor^.tape_label_attr_command_info := fmv$tape_attachment_information;

        IF status.normal THEN
          REPEAT
            iop$create_rvl_entry (sfid, p_removable_media_req_info^.density, global_file_name,
                  evaluated_file_reference.path_handle_info.path_handle, rmv$requested_volume_attributes,
                  p_volume_list^, p_removable_media_req_info^.write_ring, status);
            IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
              pmp$wait (one_second, one_second);
            IFEND;
          UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
          IF status.normal THEN
            cycle_description^.system_file_label.descriptive_label.internal_cycle_name :=
                  cycle_description^.system_file_label.descriptive_label.global_file_name;
          IFEND;
        IFEND;
      IFEND;

    END /begin_end/;

    #keypoint (osk$exit, 0, fmk$attach_file);
  PROCEND fmp$attach_file;

?? TITLE := 'PROCEDURE [XDCL] fmp$catalog_system_file_label', EJECT ??

  PROCEDURE [XDCL] fmp$catalog_system_file_label
    (    system_file_label: ^fmt$system_file_label;
         job_routing_label: ^SEQ ( * );
         job_routing_label_length: jmt$system_label_info_length;
         apfid: pft$attached_permanent_file_id;
         required_permission: pft$permit_options;
     VAR status: ost$status);

    VAR
      i: integer,
      label_header: ^fmt$static_label_header,
      label_pointer: ^SEQ ( * ),
      label_size: integer,
      rest_of_static_label: ^SEQ ( * ),
      route_info: ^SEQ ( * ),
      static_label_header: ^fmt$static_label_header,
      static_label_size: integer;

    status.normal := TRUE;

    IF system_file_label^.static_label = NIL THEN
      label_size := #SIZE (fmt$static_label_header) +
            job_routing_label_length;
      PUSH label_pointer: [[REP label_size OF cell]];

      RESET label_pointer;
      NEXT label_header IN label_pointer;
      label_header^ := fmv$static_label_header;
      label_header^.job_routing_label_size := job_routing_label_length;
      label_header^.file_previously_opened :=
            system_file_label^.file_previously_opened;
    ELSE { system_file_label^.static_label <> NIL }
      static_label_size := #SIZE (system_file_label^.static_label^);
      label_size := static_label_size + job_routing_label_length;
      PUSH label_pointer: [[REP label_size OF cell]];

      RESET label_pointer;
      RESET system_file_label^.static_label;
      i#move (system_file_label^.static_label, label_pointer,
            static_label_size);
      NEXT label_header IN label_pointer;
      label_header^.file_previously_opened :=
            system_file_label^.file_previously_opened;
      label_header^.job_routing_label_size := job_routing_label_length;

      IF (job_routing_label_length <> 0) AND (static_label_size  > #SIZE (fmt$static_label_header)) THEN

{ There is more of the static label to NEXT over, to get to the end.

        label_size := label_size - (#SIZE (fmt$static_label_header) +
              job_routing_label_length);
        NEXT rest_of_static_label: [[REP label_size OF cell]] IN
              label_pointer;
      IFEND;
    IFEND;

    IF job_routing_label <> NIL THEN
      NEXT route_info: [[REP job_routing_label_length OF cell]] IN
            label_pointer;
      route_info^ := job_routing_label^;
    IFEND;

    pfp$save_file_label (apfid, label_pointer, required_permission, status);
  PROCEND fmp$catalog_system_file_label;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$cleanup_open', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$cleanup_open
    (    path_handle: fmt$path_handle;
     VAR work_list: {i/o} fmt$open_cleanup_work_list);
    VAR
      cycle_description: ^fmt$cycle_description,
      error: boolean,
      open_count: integer,
      ignore_status: ost$status;

    fmp$locate_cd_via_path_handle (path_handle, TRUE {lock_path_table},
          cycle_description, ignore_status);
    IF NOT ignore_status.normal THEN
      RETURN;
    IFEND;

    IF (fmc$decrement_open_count IN work_list) AND
          (cycle_description^.global_file_information <> NIL) THEN
      work_list := work_list - $fmt$open_cleanup_work_list [fmc$decrement_open_count];
      osp$decrement_locked_variable (cycle_description^.global_file_information^.
            open_count, 1, open_count, error);
    IFEND;

    IF fmc$free_static_label IN work_list THEN
      work_list := work_list - $fmt$open_cleanup_work_list [fmc$free_static_label];
      IF cycle_description^.attached_file AND
            (cycle_description^.system_file_label.static_label <> NIL) THEN
        FREE cycle_description^.system_file_label.static_label IN
              osv$job_pageable_heap^;
      IFEND;
    IFEND;

    IF (fmc$clear_open_lock IN work_list) AND
          (cycle_description^.global_file_information <> NIL) THEN
      work_list := work_list - $fmt$open_cleanup_work_list [fmc$clear_open_lock];
      osp$clear_job_signature_lock (cycle_description^.global_file_information^.open_lock);
    IFEND;

    fmp$unlock_path_table;
  PROCEND fmp$cleanup_open;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$detach_all_tape_files', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$detach_all_tape_files;

    VAR
      ignore_status: ost$status,
      index: integer,
      local_status: ost$status,
      previous_last_tape_list_entry: fst$path_handle_name,
      tape_file_list: array [1 .. 5] of fst$path_handle_name;

    PROCEDURE get_tape_file_list
      (VAR tape_file_list: array [1 .. *] of fst$path_handle_name);

      VAR
        cdu: ^fmt$cycle_description_unit,
        entry: integer,
        tape_file_list_index: integer;

      FOR tape_file_list_index := 1 TO UPPERBOUND (tape_file_list) DO
        tape_file_list [tape_file_list_index] := osc$null_name;
      FOREND;
      tape_file_list_index := 0;

      fmp$lock_path_table (local_status);
      IF NOT local_status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], local_status,
              ignore_status);
        RETURN;
      IFEND;

      cdu := fmv$initial_cdu_pointer;

    /get_tape_list/
      WHILE cdu <> NIL DO
        FOR entry := 1 TO #SIZE (cdu^.entry_assignment^) DO
          IF (cdu^.entry_assignment^ (entry) = fmc$entry_assigned) AND
                (((cdu^.entries^ [entry].attached_file) AND
                (cdu^.entries^ [entry].device_class = rmc$magnetic_tape_device))) THEN
            tape_file_list_index := tape_file_list_index + 1;
            clp$construct_path_handle_name (cdu^.entries^ [entry].path_handle,
                  tape_file_list [tape_file_list_index]);
            IF tape_file_list_index >= UPPERBOUND (tape_file_list) THEN
              EXIT /get_tape_list/;
            IFEND;
          IFEND;
        FOREND;
        cdu := cdu^.next_cycle_description_unit;
      WHILEND /get_tape_list/;

      fmp$unlock_path_table;

    PROCEND get_tape_file_list;

    previous_last_tape_list_entry := 'LAST_TAPE_ENTRY?';
    REPEAT
      get_tape_file_list (tape_file_list);
      IF tape_file_list [1] = osc$null_name THEN
        RETURN;
      IFEND;
      index := 1;
      WHILE (index <= UPPERBOUND (tape_file_list)) AND (tape_file_list [index] <> osc$null_name) DO
        amp$return (tape_file_list [index], local_status);
        IF NOT local_status.normal THEN
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], local_status,
                ignore_status);
        IFEND;
        index := index + 1;
      WHILEND;
      IF tape_file_list [UPPERBOUND (tape_file_list)] = previous_last_tape_list_entry THEN
        osp$set_status_abnormal (amc$access_method_id, fme$system_error,
              ' Unable to detach tape files in FMP$DETACH_ALL_TAPE_FILES', local_status);
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], local_status,
              ignore_status);
        RETURN;
      IFEND;
      previous_last_tape_list_entry := tape_file_list [UPPERBOUND (tape_file_list)];
    UNTIL (tape_file_list [UPPERBOUND (tape_file_list)] = osc$null_name);

  PROCEND fmp$detach_all_tape_files;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$end_new_open_processing', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$end_new_open_processing
    (    path_handle: fmt$path_handle;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      label_header: ^fmt$static_label_header;

    status.normal := TRUE;

    fmp$locate_cd_via_path_handle (path_handle, TRUE {lock_path_table},
          cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /path_table_locked/
    BEGIN
      IF cycle_description^.attached_file THEN
        cycle_description^.system_file_label.file_previously_opened := TRUE;
        IF ((cycle_description^.device_class = rmc$mass_storage_device) OR
              (cycle_description^.device_class = rmc$magnetic_tape_device)) AND
              cycle_description^.permanent_file THEN
          fmp$catalog_system_file_label (^cycle_description^.system_file_label,
              cycle_description^.job_routing_label,
              cycle_description^.job_routing_label_length,
              cycle_description^.apfid, pfc$append, status);
          IF status.normal THEN
            cycle_description^.system_file_label_catalogued := TRUE;
          ELSE
            cycle_description^.system_file_label.file_previously_opened := FALSE;
            EXIT /path_table_locked/;
          IFEND;
        IFEND;
        IF cycle_description^.system_file_label.static_label <> NIL THEN
          RESET cycle_description^.system_file_label.static_label;
          NEXT label_header IN cycle_description^.system_file_label.static_label;
          label_header^.file_previously_opened := TRUE;
          RESET cycle_description^.system_file_label.static_label;
        IFEND;
      IFEND; {attached_file}
    END /path_table_locked/;

    fmp$unlock_path_table;
  PROCEND fmp$end_new_open_processing;

?? TITLE := 'FUNCTION [XDCL, #GATE] fmp$file_is_open', EJECT ??
*copy fmh$file_is_open

  FUNCTION [XDCL, #GATE] fmp$file_is_open
    (    local_file_name: amt$local_file_name): boolean;

    VAR
      local_status: ost$status,
      cycle_description: ^fmt$cycle_description,
      open_count: integer;

    local_status.normal := TRUE;
    fmp$file_is_open := FALSE;

    fmp$get_cycle_description (local_file_name, cycle_description, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    osp$fetch_locked_variable (cycle_description^.global_file_information^.
          open_count, open_count);
    IF open_count <> 0 THEN
      fmp$file_is_open := TRUE;
    IFEND;

    fmp$unlock_path_table;
  FUNCEND fmp$file_is_open;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$get_device_class', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$get_device_class
    (    path_handle: fmt$path_handle;
     VAR device_assigned: boolean;
     VAR device_class: rmt$device_class;
     VAR status: ost$status);

    CONST
      lock_path_table = TRUE;

    VAR
      cycle_description: ^fmt$cycle_description;

    status.normal := TRUE;

    fmp$locate_cd_via_path_handle (path_handle, lock_path_table, cycle_description, status);
    IF status.normal THEN
      IF cycle_description^.attached_file THEN
        device_assigned := TRUE;
        device_class := cycle_description^.device_class;
      IFEND;
      fmp$unlock_path_table;
    IFEND;

  PROCEND fmp$get_device_class;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$get_device_class_and_sfid', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$get_device_class_and_sfid
    (    file: fst$file_reference;
     VAR device_class: rmt$device_class;
     VAR sfid: dmt$system_file_id;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description;

    status.normal := TRUE;
    device_class := rmc$mass_storage_device;
    sfid := dmv$null_sfid;

    fmp$get_cycle_description (file, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_description^.attached_file THEN
      device_class := cycle_description^.device_class;
      CASE cycle_description^.device_class OF
      = rmc$magnetic_tape_device, rmc$mass_storage_device =
        sfid := cycle_description^.system_file_id;
      ELSE
      CASEND;
    ELSE
      osp$set_status_abnormal (amc$access_method_id, fme$system_error,
            ' NOT a local or attached file', status);
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$get_device_class_and_sfid;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$get_jl_pointer', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$get_jl_pointer
    (    file: fst$file_reference;
         append: boolean;
     VAR jl_ptr: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      jl_size: 0 .. 80000000(16),
      cycle_description: ^fmt$cycle_description,
      header: ^fmt$static_label_header,
      new_job_routing_label: ^SEQ( * ),
      pva_ptr: ^cell;

    status.normal := TRUE;

  /begin_end/
    BEGIN
      fmp$get_cycle_description (file, cycle_description, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT (cycle_description^.attached_file AND
            (cycle_description^.device_class = rmc$mass_storage_device)) THEN
        osp$set_status_abnormal (amc$access_method_id, fme$system_error,
              ' not an attached MS file in fmp$get_jl_pointer',
              status);
        EXIT /begin_end/;
      IFEND;

      IF append THEN
        IF cycle_description^.job_routing_label = NIL THEN
          ALLOCATE cycle_description^.job_routing_label:
                [[REP jmc$maximum_system_label_info OF cell]] IN
                osv$job_pageable_heap^;

          cycle_description^.job_routing_label_length :=
                jmc$maximum_system_label_info;
        ELSEIF cycle_description^.job_routing_label_length <
              jmc$maximum_system_label_info THEN
          ALLOCATE new_job_routing_label:
                [[REP jmc$maximum_system_label_info OF cell]] IN
                osv$job_pageable_heap^;
          i#move (cycle_description^.job_routing_label, new_job_routing_label,
                cycle_description^.job_routing_label_length);
          FREE cycle_description^.job_routing_label IN osv$job_pageable_heap^;
          cycle_description^.job_routing_label := new_job_routing_label;
          cycle_description^.job_routing_label_length :=
                jmc$maximum_system_label_info;
        IFEND;
      ELSEIF cycle_description^.job_routing_label = NIL THEN
        osp$set_status_abnormal (amc$access_method_id, fme$system_error,
              ' job_routing_label NIL in fmp$get_jl_pointer',
              status);
        EXIT /begin_end/;
      IFEND;

      IF NOT cycle_description^.permanent_file AND
            (cycle_description^.system_file_label.static_label <> NIL) THEN

{ store job_routing_label size in static_label header for use by
{ fmp$store_system_label

        RESET cycle_description^.system_file_label.static_label;
        NEXT header IN cycle_description^.system_file_label.static_label;
        IF header = NIL THEN
          osp$set_status_abnormal (amc$access_method_id,
                ame$damaged_file_attributes, ' in fmp$get_jl_pointer',
                status);
          EXIT /begin_end/;
        IFEND;
        header^.job_routing_label_size := cycle_description^.
          job_routing_label_length;
      IFEND;

      pva_ptr := cycle_description^.job_routing_label;

      jl_size := cycle_description^.job_routing_label_length;

      i#build_adaptable_seq_pointer (#RING (pva_ptr), #SEGMENT (pva_ptr),
            #OFFSET (pva_ptr), jl_size, 0, jl_ptr);
    END /begin_end/;

    fmp$unlock_path_table;
  PROCEND fmp$get_jl_pointer;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$get_system_file_id', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$get_system_file_id
    (    file: fst$file_reference;
     VAR system_file_id: dmt$system_file_id;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description;

    status.normal := TRUE;

    fmp$get_cycle_description (file, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_description^.attached_file THEN
      CASE cycle_description^.device_class OF
      = rmc$magnetic_tape_device, rmc$mass_storage_device =
        system_file_id := cycle_description^.system_file_id;
      ELSE
        osp$set_status_abnormal (amc$access_method_id, fme$system_error,
              ' Improper device class', status);
      CASEND;
    ELSE
      osp$set_status_abnormal (amc$access_method_id, fme$system_error,
            ' NOT an attached file', status);
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$get_system_file_id;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$get_path_table_cycle_info', EJECT ??
*copy fmh$get_path_table_cycle_info
{This routine is only called for permanent files.

  PROCEDURE [XDCL, #GATE] fmp$get_path_table_cycle_info
    (    inhibit_locking_pt: boolean;
     VAR {i/o} evaluated_file_reference: fst$evaluated_file_reference;
     VAR cycle_info: fmt$path_table_cycle_info;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      header_pointer: ^fmt$static_label_header,
      i: integer,
      ignore_process_pt_results: bat$process_pt_results,
      ignore_status: ost$status,
      process_pt_work_list: bat$process_pt_work_list;

    status.normal := TRUE;

    cycle_info.path_registered := FALSE;
    cycle_info.cycle_device_info.device_assigned := FALSE;
    cycle_info.cycle_attachment_info.cycle_attached := FALSE;
    cycle_description := NIL;
    cycle_info.cycle_device_info.cycle_formerly_opened_info.
          cycle_previously_opened := FALSE;

    {
    { bac$resolve_pf_in_pt is here for the file server, to resolve to the
    { cycle that bam knows about before going to the server mainframe.
    {
    process_pt_work_list := $bat$process_pt_work_list
          [bac$resolve_path, bac$return_cycle_description, bac$resolve_pf_in_pt];
    IF inhibit_locking_pt THEN
      { must have been called by attach or create and they set the lock }
      { if the catalogs are going to be locked also }
      process_pt_work_list := process_pt_work_list +
            $bat$process_pt_work_list [bac$inhibit_locking_pt];
    IFEND;
    fmp$process_pt_request (process_pt_work_list, osc$null_name,
          evaluated_file_reference, cycle_description,
          ignore_process_pt_results, status);

    IF cycle_description <> NIL THEN

    /get_path_table_cycle_info/
      BEGIN
        cycle_info.path_registered := TRUE;
        cycle_info.cycle_number := evaluated_file_reference.cycle_reference.
              cycle_number;

        cycle_info.setfa_access_modes.selector := fsc$permitted_access_modes;
        IF cycle_description^.dynamic_setfa_entries <> NIL THEN

          IF cycle_description^.dynamic_setfa_entries^.access_modes_specified THEN
            cycle_info.setfa_access_modes.selector :=
                  fsc$specific_access_modes;
            #UNCHECKED_CONVERSION (cycle_description^.
                  dynamic_setfa_entries^.access_modes,
                  cycle_info.setfa_access_modes.value);
          IFEND;
        IFEND;
        IF cycle_description^.attached_file THEN
          IF cycle_description^.permanent_file THEN
            pfp$check_device_availability (cycle_description^.apfid, status);
            IF NOT status.normal THEN
              EXIT /get_path_table_cycle_info/;
            IFEND;
          IFEND;
          cycle_info.cycle_attachment_info.cycle_attached := TRUE;
          cycle_info.cycle_attachment_info.password_protected :=
                cycle_description^.password_protected;
          cycle_info.cycle_attachment_info.allowed_access :=
                cycle_description^.attached_access_modes;
          IF cycle_description^.device_class = rmc$magnetic_tape_device THEN
            cycle_info.cycle_attachment_info.required_sharing := $fst$file_access_options [];
          ELSE
            cycle_info.cycle_attachment_info.required_sharing :=
                  cycle_description^.attached_share_modes;
          IFEND;
          osp$fetch_locked_variable (cycle_description^.global_file_information^.open_count,
                cycle_info.cycle_attachment_info.open_count);
          cycle_info.cycle_device_info.device_assigned := TRUE;
          cycle_info.cycle_device_info.device_class :=
                cycle_description^.device_class;
          IF cycle_description^.system_file_label.file_previously_opened THEN
            IF cycle_description^.system_file_label.static_label = NIL THEN
              cycle_info.cycle_device_info.cycle_formerly_opened_info.
                    cycle_previously_opened := TRUE;
              cycle_info.cycle_device_info.cycle_formerly_opened_info.
                    ring_attributes := fmv$system_file_attributes.static_label.
                    ring_attributes;
              cycle_info.cycle_device_info.cycle_formerly_opened_info.
                    ring_attributes_source := fmv$system_file_attributes.
                    static_label.ring_attributes_source;
              EXIT /get_path_table_cycle_info/;
            IFEND;
            RESET cycle_description^.system_file_label.static_label;
            NEXT header_pointer IN cycle_description^.system_file_label.
                  static_label;
            IF header_pointer = NIL THEN
              osp$set_status_abnormal (amc$access_method_id, fme$system_error,
                    '- header_pointer NIL in fmp$get_path_table_cycle_info',
                    status);
              EXIT /get_path_table_cycle_info/;
            IFEND;
            IF header_pointer^.file_previously_opened THEN
              cycle_info.cycle_device_info.cycle_formerly_opened_info.
                    cycle_previously_opened := TRUE;
              cycle_info.cycle_device_info.cycle_formerly_opened_info.
                    ring_attributes := header_pointer^.ring_attributes;
              cycle_info.cycle_device_info.cycle_formerly_opened_info.
                    ring_attributes_source := header_pointer^.
                    ring_attributes_source;
            IFEND;
          IFEND;
        ELSE
          cycle_info.cycle_device_info.cycle_formerly_opened_info.
                cycle_previously_opened := FALSE;
        IFEND;

      END /get_path_table_cycle_info/;

      IF NOT inhibit_locking_pt THEN
        fmp$unlock_path_table;
      IFEND;

    IFEND; {cycle_description <> NIL}

  PROCEND fmp$get_path_table_cycle_info;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$job_exit', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$job_exit;

    VAR
      cdu: ^fmt$cycle_description_unit,
      context: ^ost$ecp_exception_context,
      density: rmt$density,
      entry: integer,
      make_another_pass: boolean,
      pass: 1 .. 2,
      path_handle_name: fst$path_handle_name,
      reservation: rmt$tape_reservation,
      status: ost$status,
      volume_down: boolean;

    syp$push_inhibit_job_recovery;

    osp$establish_condition_handler (^job_exit_condition_handler, FALSE);

    status.normal := TRUE;
    make_another_pass := FALSE;
    PUSH context;

  /detach_all_files/
    BEGIN
      FOR pass := 1 TO 2 DO
       cdu := fmv$initial_cdu_pointer;
        WHILE cdu <> NIL DO
          FOR entry := 1 TO #SIZE (cdu^.entry_assignment^) DO
            IF cdu^.entry_assignment^ (entry) = fmc$entry_assigned THEN
              IF cdu^.entries ^[entry].attached_file THEN
                context^ := osv$initial_exception_context;
                REPEAT
                  return_file_at_job_exit (^cdu^.entries^ [entry], status);
                  IF osp$file_access_condition (status) THEN
                    IF pass = 1 THEN
                      make_another_pass := TRUE;
                    ELSE
                      context^.condition_status := status;
                      clp$construct_path_handle_name (cdu^.entries^[entry].path_handle, path_handle_name);
                      context^.file.selector := osc$ecp_file_reference;
                      context^.file.file_reference := ^path_handle_name;
                      osp$enforce_exception_policies (context^);
                      status := context^.condition_status;
                    IFEND;
                  ELSE
                    cdu^.entry_assignment^ (entry) := fmc$entry_free;
                  IFEND;
                UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (pass = 1) OR
                      (NOT context^.wait);
              ELSE
                cdu^.entry_assignment^ (entry) := fmc$entry_free;
              IFEND; {attached_file}
            IFEND; {entry_assigned}
          FOREND;
          cdu := cdu^.next_cycle_description_unit;
        WHILEND;
        IF pass = 1 THEN
          { perform explicit release of tape resource

          FOR density := rmc$800 to rmc$maximum_density DO
           reservation [density] := UPPERVALUE (reservation [density]);
          FOREND;
          rmp$clear_explicit_reserve (reservation, status);
          REPEAT
            iop$delete_rvl_entries_via_ssn(status);
            IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
              pmp$wait (one_second, one_second);
            IFEND;
          UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
        IFEND;
        IF NOT make_another_pass THEN
          EXIT /detach_all_files/;
        IFEND;
      FOREND;
    END /detach_all_files/;

    osp$disestablish_cond_handler;
    syp$pop_inhibit_job_recovery;
  PROCEND fmp$job_exit;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$ln_open_chapter', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$ln_open_chapter
    (    local_file_name: amt$local_file_name;
         chapter_number: dmt$chapter_number;
         validation_ring: ost$valid_ring;
         segment_attributes: ^array [ * ] of mmt$attribute_descriptor;
         pointer_kind: mmt$segment_pointer_kind;
     VAR segment_pointer: mmt$segment_pointer;
     VAR status: ost$status);

    CONST
      only_ms_files_supported = 'Only MS files are supported by fmp$ln_open_chapter';

    VAR
      cycle_description: ^fmt$cycle_description,
      evaluated_file_reference: fst$evaluated_file_reference,
      ignore_file_registered: boolean,
      ignore_process_pt_results: bat$process_pt_results;

    status.normal := TRUE;

  /begin_end/
    BEGIN
      fmp$evaluate_path (local_file_name, $bat$process_pt_work_list [bac$resolve_path,
            bac$resolve_to_catalog, bac$return_cycle_description],
            evaluated_file_reference, cycle_description, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF cycle_description = NIL THEN
        IF fsp$path_element (^evaluated_file_reference, 1)^ = fsc$local THEN
          fmp$process_pt_request ($bat$process_pt_work_list [bac$record_path, bac$resolve_path,
                bac$create_cycle_description, bac$return_cycle_description], osc$null_name,
                evaluated_file_reference, cycle_description, ignore_process_pt_results, status);
          IF NOT status.normal OR (cycle_description = NIL) THEN
            IF status.normal THEN
              osp$set_status_abnormal (amc$access_method_id, fme$no_cycle_description, '', status);
            IFEND;
            RETURN;
          IFEND;
          assign_device_class (rmc$mass_storage_device, cycle_description);
          create_temporary_file (NIL, {mass_storage_attributes} NIL, segment_attributes, cycle_description,
                status);
          IF NOT status.normal THEN
            EXIT /begin_end/;
          IFEND;
        ELSE {NOT temporary file}
          osp$set_status_abnormal (amc$access_method_id, fme$system_error,
                'Permanent files must be attached before calling fmp$ln_open_chapter', status);
          RETURN;
        IFEND;
      ELSEIF cycle_description^.attached_file THEN
        IF cycle_description^.device_class <> rmc$mass_storage_device THEN
          osp$set_status_abnormal (amc$access_method_id, fme$system_error,
                only_ms_files_supported, status);
          EXIT /begin_end/;
        IFEND;
      ELSE
        osp$set_status_abnormal (amc$access_method_id, fme$system_error,
              'File must be attached if cycle_description exists in fmp$ln_open_chapter', status);
        EXIT /begin_end/;
      IFEND;

      mmp$open_file_segment (cycle_description^.system_file_id, segment_attributes, pointer_kind,
            validation_ring, cycle_description^.file_space_limit_kind, segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /begin_end/;
      IFEND;

      cycle_description^.global_file_information^.eoi_set := FALSE;
      cycle_description^.system_file_label.file_previously_opened := TRUE;
    END /begin_end/;

    fmp$unlock_path_table;
  PROCEND fmp$ln_open_chapter;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$put_jl_pointer', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$put_jl_pointer
    (    file: fst$file_reference;
         write_label: boolean;
         jl_ptr: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      jl: ^cell,
      required_permission: pft$permit_options,
      volume_down: boolean;


    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      IF status.normal THEN
        osp$set_status_from_condition (amc$access_method_id, condition, sfsa_p,
              status, ignore_status);
      IFEND;
    PROCEND condition_handler;

    VAR
      context: ^ost$ecp_exception_context;

    status.normal := TRUE;
    context := NIL;

  /begin_end/
    BEGIN
      fmp$get_cycle_description (file, cycle_description, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT (cycle_description^.attached_file AND
            (cycle_description^.device_class = rmc$mass_storage_device)) THEN
        osp$set_status_abnormal (amc$access_method_id, fme$system_error,
              ' not an attached MS file in fmp$put_jl_pointer',
              status);
        EXIT /begin_end/;
      IFEND;

      IF cycle_description^.job_routing_label = NIL THEN
        osp$set_status_abnormal (amc$access_method_id, fme$system_error,
              'jrl NIL in fmp$put_jl_pointer', status);
        EXIT /begin_end/;
      IFEND;

      cycle_description^.job_routing_label_length :=
            i#current_sequence_position (jl_ptr);
      jl := jl_ptr;
      i#build_adaptable_seq_pointer (#RING (jl), #SEGMENT (jl), #OFFSET (jl),
            cycle_description^.job_routing_label_length,
            cycle_description^.job_routing_label_length,
            cycle_description^.job_routing_label);

      IF write_label AND cycle_description^.permanent_file THEN
        osp$establish_block_exit_hndlr (^condition_handler);
        pfp$begin_system_authority;
        IF cycle_description^.system_file_label.file_previously_opened THEN
          required_permission := pfc$control;
        ELSEIF fsc$append IN cycle_description^.attached_access_modes THEN
          required_permission := pfc$append;
        ELSE
          osp$set_status_condition (pfe$unknown_permanent_file, status);
          osp$append_status_file (osc$status_parameter_delimiter, file, status);
          EXIT /begin_end/
        IFEND;
        REPEAT
          fmp$catalog_system_file_label (^cycle_description^.system_file_label,
              cycle_description^.job_routing_label,
              cycle_description^.job_routing_label_length,
              cycle_description^.apfid, required_permission, status);
          IF NOT status.normal THEN
            IF context = NIL THEN
              PUSH context;
              context^ := osv$initial_exception_context;
            IFEND;
            context^.condition_status := status;
            osp$enforce_exception_policies (context^);
            status := context^.condition_status;
          IFEND;
        UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
        pfp$end_system_authority;
        osp$disestablish_cond_handler;
        IF status.normal THEN
          cycle_description^.system_file_label_catalogued := TRUE;
        IFEND;
      IFEND;
    END /begin_end/;

    fmp$unlock_path_table;
  PROCEND fmp$put_jl_pointer;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$record_open_cycle_info', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$record_open_cycle_info
    (    path_handle: fmt$path_handle;
         validation_ring: ost$valid_ring;
         access_level: amt$access_level;
         preserved_attributes: bat$static_label_attributes;
         instance_attributes: bat$instance_attributes;
         cd_attachment_options: fmt$cd_attachment_options;
         open_count: integer;
         device_class: rmt$device_class;
     VAR open_cleanup_work_list: {i/o} fmt$open_cleanup_work_list;
     VAR global_file_information: ^bat$global_file_information;
     VAR segment_pointer: ^cell;
     VAR system_file_label: ^fmt$system_file_label;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      cycle_description: ^fmt$cycle_description,
      eoi: amt$file_byte_address,
      fetch_status: ost$status,
      fetched_eoi: ost$segment_length,
      label_header: ^fmt$static_label_header,
      limit: sft$limit,
      mm_segment_pointer: mmt$segment_pointer,
      path: fst$path,
      path_size: fst$path_size,
      segment_attributes: ^array [1 .. *] of mmt$attribute_descriptor,
      segment_ring: ost$valid_ring;

    #CALLER_ID (caller_id);
    status.normal := TRUE;

  /begin_end/
    BEGIN
      fmp$locate_cd_via_path_handle (path_handle, TRUE {lock_path_table},
            cycle_description, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF cycle_description^.attached_file THEN
        IF device_class = rmc$mass_storage_device THEN
          PUSH segment_attributes: [mm_ring_numbers_index .. mm_transfer_size_index];
          establish_segment_attributes (access_level, validation_ring, instance_attributes.static_label,
                instance_attributes.dynamic_label.access_mode, cd_attachment_options, segment_attributes,
                segment_ring);
          IF (open_count = 1) AND (preserved_attributes.file_limit_source <>
                fmv$system_file_attributes.static_label.file_limit_source) AND
                (preserved_attributes.file_limit <> fmv$system_file_attributes.static_label.file_limit) THEN
            dmp$set_file_limit (cycle_description^.system_file_id, preserved_attributes.file_limit, status);
            IF NOT status.normal THEN
              EXIT /begin_end/;
            IFEND;
          IFEND;
        IFEND;
      ELSE
        assign_device_class (device_class, cycle_description);
        IF device_class = rmc$mass_storage_device THEN
          PUSH segment_attributes: [mm_ring_numbers_index .. mm_transfer_size_index];
          establish_segment_attributes (access_level, validation_ring, instance_attributes.static_label,
                instance_attributes.dynamic_label.access_mode, cd_attachment_options, segment_attributes,
                segment_ring);
          create_temporary_file (^preserved_attributes, {mass_storage_attributes} NIL, NIL, cycle_description,
                status);
          IF NOT status.normal THEN
            cycle_description^.attached_file := FALSE;
            EXIT /begin_end/;
          IFEND;
        IFEND;
      IFEND;

      IF open_count = 1 THEN
        { preserve global file information
        { maximum amount of data that may be written in a block }
        cycle_description^.global_file_information^.max_data_size :=
              preserved_attributes.max_block_length;
        { total size of a block - header to header }
        cycle_description^.global_file_information^.max_block_size :=
              cycle_description^.global_file_information^.max_data_size +
              #SIZE (bat$block_header);
        { adjust total block size to word boundary if necessary }
        IF cycle_description^.global_file_information^.max_block_size MOD 8 <>
              0 THEN
          cycle_description^.global_file_information^.max_block_size :=
                (((cycle_description^.global_file_information^.
                max_block_size DIV 8) * 8) + 8);
        IFEND;

        cycle_description^.global_file_information^.min_block_length :=
              preserved_attributes.min_block_length;
        cycle_description^.global_file_information^.max_record_length :=
              preserved_attributes.max_record_length;
        cycle_description^.global_file_information^.file_limit :=
              preserved_attributes.file_limit;
        cycle_description^.global_file_information^.padding_character :=
              preserved_attributes.padding_character;
        cycle_description^.global_file_information^.
              record_delimiting_character := preserved_attributes.
              record_delimiting_character;
      IFEND;

      global_file_information := cycle_description^.global_file_information;

      IF NOT cycle_description^.system_file_label.file_previously_opened THEN

{ File_previously_opened is set to TRUE in bap$end_new_open_processing when
{ the label is saved after the open has finished.

        fmp$put_label_attributes (preserved_attributes,
              cycle_description^.system_file_label);
        IF (cycle_description^.system_file_label.static_label <> NIL) THEN
          open_cleanup_work_list := open_cleanup_work_list +
                $fmt$open_cleanup_work_list [fmc$free_static_label];
          RESET cycle_description^.system_file_label.static_label;
          NEXT label_header IN cycle_description^.system_file_label.
                static_label;
          IF cycle_description^.device_class = rmc$mass_storage_device THEN
            label_header^.job_routing_label_size :=
                  cycle_description^.job_routing_label_length;
          ELSE
            label_header^.job_routing_label_size := 0;
          IFEND;
        IFEND;
      IFEND;

      IF cycle_description^.device_class = rmc$mass_storage_device THEN

        IF sfv$dynamic_file_space_limits AND (cycle_description^.file_space_limit_kind <> sfc$no_limit) AND
               (pfc$append IN instance_attributes.dynamic_label.access_mode) THEN
          IF cycle_description^.file_space_limit_kind = sfc$perm_file_space_limit THEN
            sfp$get_job_limit (avc$pfs_limit_name, limit, status);
          ELSE {temp file space limit}
            sfp$get_job_limit (avc$tfs_limit_name, limit, status);
          IFEND;
          IF status.normal THEN
            IF limit.accumulator >= limit.job_abort_limit THEN
              fmp$get_path_string (path_handle, {lock_path_table} FALSE, path, path_size, {ignore} status);
              osp$set_status_abnormal ('AV', ame$file_space_limit_exceeded, '', status);
              osp$append_status_file (osc$status_parameter_delimiter, path (1, path_size), status);
              IF cycle_description^.file_space_limit_kind = sfc$perm_file_space_limit THEN
                osp$append_status_parameter (osc$status_parameter_delimiter, 'Permanent', status);
              ELSE {temp file space limit}
                osp$append_status_parameter (osc$status_parameter_delimiter, 'Temporary', status);
              IFEND;
              EXIT /begin_end/;
            IFEND;
          ELSE
            status.normal := TRUE;
          IFEND;
        IFEND;

        mmp$open_file_segment (cycle_description^.system_file_id, segment_attributes, mmc$cell_pointer,
               segment_ring, cycle_description^.file_space_limit_kind, mm_segment_pointer, status);
        syp$hang_if_job_jrt_set (fmc$tjr_open_lnt);
        IF NOT status.normal THEN
          EXIT /begin_end/;
        IFEND;

        segment_pointer := mm_segment_pointer.cell_pointer;

        { For mass storage, eoi_set controls whether eoi is retrieved from
        { memory management or global_file_information.
        { We are assuming that if the last open was for record access
        { (eoi_set=TRUE) then the gfi.eoi is correct, otherwise go to memory
        {  management and get eoi.
        IF NOT cycle_description^.global_file_information^.eoi_set THEN
          mmp$get_segment_length (mm_segment_pointer.cell_pointer,
                caller_id.ring, fetched_eoi, fetch_status);
          eoi := fetched_eoi;
          IF fetch_status.normal THEN
            global_file_information^.eoi_byte_address := eoi;
          ELSE
            status := fetch_status;
            EXIT /begin_end/;
          IFEND;
        IFEND;
        { set eoi_set to reflect whether this open was for record_access
        cycle_description^.global_file_information^.eoi_set :=
              ((access_level <> amc$segment) AND
              NOT (instance_attributes.static_label.file_organization IN
              amv$aam_file_organizations));

      ELSEIF cycle_description^.device_class = rmc$magnetic_tape_device THEN
        segment_pointer := NIL;
        IF NOT global_file_information^.eoi_set THEN
          global_file_information^.eoi_set := TRUE;
          global_file_information^.eoi_byte_address := mmv$max_segment_length;
        IFEND;
      ELSE
        segment_pointer := NIL;
      IFEND;

      system_file_label := ^cycle_description^.system_file_label;

    END /begin_end/;

    fmp$unlock_path_table;
  PROCEND fmp$record_open_cycle_info;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$request_mass_storage', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$request_mass_storage
    (    allocation_size: rmt$allocation_size;
         estimated_file_size: amt$file_byte_address;
         file_class: rmt$mass_storage_class;
         initial_volume: rmt$recorded_vsn;
         transfer_size: fst$transfer_size;
         volume_overflow_allowed: boolean;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      ignore_cd_created: boolean,
      mass_storage_attributes: ^fst$mass_storage_device_info;

    status.normal := TRUE;

    fmp$create_cycle_description ({return_cycle_description=} TRUE, evaluated_file_reference,
          ignore_cd_created, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /path_table_locked/
    BEGIN
      verify_device_assignment (evaluated_file_reference,
            rmc$mass_storage_device, cycle_description, status);
      IF NOT status.normal THEN
        EXIT /path_table_locked/;
      IFEND;

      assign_device_class (rmc$mass_storage_device, cycle_description);

      PUSH mass_storage_attributes;

      mass_storage_attributes^.bytes_allocated := estimated_file_size;
      mass_storage_attributes^.resides_online := TRUE;
      mass_storage_attributes^.allocation_unit_size := allocation_size;
      mass_storage_attributes^.mass_storage_class := file_class;
      mass_storage_attributes^.initial_volume := initial_volume;
      mass_storage_attributes^.transfer_size := transfer_size;
      mass_storage_attributes^.volume_overflow_allowed := volume_overflow_allowed;

      create_temporary_file ({preserved_attributes} NIL, mass_storage_attributes, {segment_attributes} NIL,
            cycle_description, status);
    END /path_table_locked/;

    fmp$unlock_path_table;
  PROCEND fmp$request_mass_storage;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$request_null_device', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$request_null_device
    (    null_device_class: rmt$device_class;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR status: ost$status);

    VAR
      attached: boolean,
      cycle_description: ^fmt$cycle_description,
      ignore_cd_created: boolean;

    status.normal := TRUE;
    IF NOT ((null_device_class = rmc$null_device) OR (null_device_class IN rmv$null_device_set)) THEN
      osp$set_status_abnormal (amc$access_method_id, fme$system_error,
            'Non NULL device class passed to fmp$request_null_device.', status);
      RETURN;
    IFEND;

    IF fsp$path_element (^evaluated_file_reference, 1)^ <> fsc$local THEN
      osp$set_status_abnormal (amc$access_method_id,
            cle$only_permitted_on_loc_file, '', status);
      RETURN;
    IFEND;

    IF evaluated_file_reference.path_handle_info.path_handle_present THEN
      fmp$is_file_attached (evaluated_file_reference.path_handle_info.path_handle, attached, status);
      IF NOT status.normal THEN
        RETURN;
      ELSEIF attached THEN
        evaluated_file_reference.cycle_reference.specification := fsc$next_cycle;
        evaluated_file_reference.path_handle_info.path_handle_present := FALSE;
      IFEND;
    IFEND;

    fmp$create_cycle_description ({return_cycle_description=} TRUE, evaluated_file_reference,
          ignore_cd_created, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /path_table_locked/
    BEGIN
      verify_device_assignment (evaluated_file_reference, null_device_class,
            cycle_description, status);
      IF NOT status.normal THEN
        EXIT /path_table_locked/;
      IFEND;

      assign_device_class (null_device_class, cycle_description);
      osp$generate_unique_binary_name (cycle_description^.system_file_label.descriptive_label.
            global_file_name, status);
      IF status.normal THEN
        cycle_description^.system_file_label.descriptive_label.internal_cycle_name :=
              cycle_description^.system_file_label.descriptive_label.global_file_name;
      IFEND;
    END /path_table_locked/;

    fmp$unlock_path_table;
  PROCEND fmp$request_null_device;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$request_terminal', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$request_terminal
    (    terminal_file_name_loc: ^amt$local_file_name;
         terminal_attributes: ^ift$connection_attributes;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR status: ost$status);

    VAR
      attached: boolean,
      cycle_description: ^fmt$cycle_description,
      ignore_cd_created: boolean;

    status.normal := TRUE;

    IF fsp$path_element (^evaluated_file_reference, 1)^ <> fsc$local THEN
      osp$set_status_abnormal (amc$access_method_id,
            cle$only_permitted_on_loc_file, '', status);
      RETURN;
    IFEND;

    IF evaluated_file_reference.path_handle_info.path_handle_present THEN
      fmp$is_file_attached (evaluated_file_reference.path_handle_info.path_handle, attached, status);
      IF NOT status.normal THEN
        RETURN;
      ELSEIF attached THEN
        evaluated_file_reference.cycle_reference.specification := fsc$next_cycle;
        evaluated_file_reference.path_handle_info.path_handle_present := FALSE;
      IFEND;
    IFEND;

    fmp$create_cycle_description ({return_cycle_description=} TRUE, evaluated_file_reference,
          ignore_cd_created, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /path_table_locked/
    BEGIN
      IF (cycle_description <> NIL) AND ((cycle_description^.
            static_setfa_entries <> NIL) OR (cycle_description^.
            dynamic_setfa_entries <> NIL)) THEN
        bap$set_evaluated_file_abnormal (evaluated_file_reference,
           ame$file_known, 'fmp$request_terminal', '', status);
        EXIT /path_table_locked/;
      IFEND;

      verify_device_assignment (evaluated_file_reference, rmc$terminal_device,
            cycle_description, status);
      IF NOT status.normal THEN
        EXIT /path_table_locked/;
      IFEND;

      assign_device_class (rmc$terminal_device, cycle_description);

      IF terminal_file_name_loc <> NIL THEN
        cycle_description^.terminal_file_name := terminal_file_name_loc^;
      IFEND;

      IF terminal_attributes <> NIL THEN
        ALLOCATE cycle_description^.terminal_request: [1 .. UPPERBOUND (terminal_attributes^)] IN
              osv$job_pageable_heap^;

        cycle_description^.terminal_request^ := terminal_attributes^;
      IFEND;

    END /path_table_locked/;

    fmp$unlock_path_table;
  PROCEND fmp$request_terminal;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$return_file', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$return_file
    (    evaluated_file_reference: fst$evaluated_file_reference;
         implicit_detach: boolean;
         detachment_options: ^fst$detachment_options;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      log_device_file: boolean,
      open_count: integer,
      path_handle_name: fst$path_handle_name;

    #keypoint (osk$entry, 0, fmk$return_file);
    status.normal := TRUE;
    log_device_file := FALSE;

    fmp$locate_cd_via_path_handle (evaluated_file_reference.path_handle_info.
           path_handle, TRUE {lock_path_table},
           cycle_description, status);
    IF NOT status.normal THEN
      IF NOT implicit_detach THEN
        fsp$set_evaluated_file_abnormal (evaluated_file_reference,
              ame$file_not_known,
              amc$return_req, '', status);
      ELSE
        status.normal := TRUE; {an asyncronous task detached the file
      IFEND;
      RETURN;
    IFEND;

  /path_table_locked/
    BEGIN
      IF cycle_description^.attached_file THEN
        osp$fetch_locked_variable (cycle_description^.global_file_information^.
              open_count, open_count);

        IF (open_count = 0) AND (NOT implicit_detach) THEN
          CASE cycle_description^.device_class OF
          = rmc$connected_file_device =
            clp$construct_path_handle_name (evaluated_file_reference.
                  path_handle_info.path_handle, path_handle_name);
            clp$return_connected_file (path_handle_name);
          = rmc$log_device =
            log_device_file := TRUE;
            fsp$set_evaluated_file_abnormal (evaluated_file_reference,
                  ame$file_not_closed, amc$return_req, '', status);
          = rmc$network_device =
            return_network_file (cycle_description, status);
          = rmc$rhfam_device =
            clp$construct_path_handle_name (evaluated_file_reference.
                  path_handle_info.path_handle, path_handle_name);
            rfp$delete_connection (path_handle_name, status);
            status.normal := TRUE; {ignore status
          ELSE
          CASEND;
        IFEND;
      IFEND;

      IF NOT log_device_file THEN
        fmp$delete_path_description (evaluated_file_reference, implicit_detach, {return_permanent_file} TRUE,
              detachment_options, status);
      IFEND;

    END /path_table_locked/;

    fmp$unlock_path_table;

    #keypoint (osk$exit, 0, fmk$return_file);
  PROCEND fmp$return_file;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$set_attachment_options', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$set_attachment_options
    (    file: fst$file_reference;
         attachment_options: fmt$cd_attachment_options;
         p_volume_list: {input} ^rmt$volume_list;
     VAR status: ost$status);

    VAR
      attach_index: integer,
      current_volume_number: amt$volume_number,
      current_vsns: rmt$volume_descriptor,
      cycle_description: ^fmt$cycle_description,
      density: rmt$density,
      device_class: rmt$device_class,
      evaluated_file_reference: fst$evaluated_file_reference,
      label_type: amt$label_type,
      local_attachment_options: fmt$cd_attachment_options,
      number_of_volumes: amt$volume_number,
      p_stored_volume_list: ^rmt$volume_list,
      parameter_name: ost$name,
      requested_volume_attributes: iot$requested_volume_attributes,
      stored_index: integer,
      valid_volume_list: boolean,
      volume_overflow_allowed: boolean,
      write_ring: rmt$write_ring;

    status.normal := TRUE;

    cycle_description := NIL;
    fmp$evaluate_path (file, $bat$process_pt_work_list [bac$resolve_path, bac$resolve_to_catalog,
          bac$return_cycle_description], evaluated_file_reference, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_description^.device_class <> rmc$magnetic_tape_device THEN
      IF attachment_options.external_vsn_specified THEN
        parameter_name := 'EXTERNAL_VSN';
      ELSEIF attachment_options.recorded_vsn_specified THEN
        parameter_name := 'RECORDED_VSN';
      ELSEIF attachment_options.volume_overflow_allowed_spec THEN
        parameter_name := 'VOLUME_OVERFLOW_ALLOWED';
      ELSE
        parameter_name := osc$null_name;
      IFEND;
      IF parameter_name <> osc$null_name THEN
        bap$set_evaluated_file_abnormal (evaluated_file_reference, fse$invalid_attachment_spec,
              'ATTACH_FILE', parameter_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              amv$device_class_names [cycle_description^.device_class].name (1,
              amv$device_class_names [cycle_description^.device_class].size), status);
      IFEND;
    IFEND;

    IF cycle_description^.device_class <> rmc$mass_storage_device THEN
      IF attachment_options.free_behind_specified THEN
        parameter_name := 'FREE_BEHIND';
      ELSEIF attachment_options.job_write_concurrency_specified THEN
        parameter_name := 'JOB_WRITE_CONCURRENCY';
      ELSEIF attachment_options.private_read_specified THEN
        parameter_name := 'PRIVATE_READ';
      ELSEIF attachment_options.sequential_access_specified THEN
        parameter_name := 'SEQUENTIAL_ACCESS';
      ELSEIF attachment_options.transfer_size_specified THEN
        parameter_name := 'TRANSFER_SIZE';
      ELSE
        parameter_name := osc$null_name;
      IFEND;
      IF parameter_name <> osc$null_name THEN
        bap$set_evaluated_file_abnormal (evaluated_file_reference, fse$invalid_attachment_spec,
              'ATTACH_FILE', parameter_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              amv$device_class_names [cycle_description^.device_class].name (1,
              amv$device_class_names [cycle_description^.device_class].size), status);
      IFEND;
    IFEND;

    IF status.normal AND (p_volume_list <> NIL) THEN
      valid_volume_list := FALSE;
      dmp$get_tape_volume_information (cycle_description^.system_file_id, number_of_volumes,
            current_volume_number, current_vsns, density, write_ring, requested_volume_attributes,
            volume_overflow_allowed, label_type, status);
      IF status.normal THEN
        PUSH p_stored_volume_list: [1 .. number_of_volumes];
        dmp$get_tape_volume_list (cycle_description^.system_file_id, p_stored_volume_list, status);
        IF status.normal THEN
          /validate_volume_list/
          FOR attach_index := 1 TO UPPERBOUND (p_stored_volume_list^) DO
            IF (attach_index + UPPERBOUND (p_volume_list^) - 1) > UPPERBOUND (p_stored_volume_list^) THEN
              EXIT /validate_volume_list/;
            IFEND;
            IF (p_volume_list^ [1].external_vsn = p_stored_volume_list^ [attach_index].external_vsn) AND
                  (p_volume_list^ [1].recorded_vsn = p_stored_volume_list^ [attach_index].recorded_vsn) THEN
              /validate_remaining_volumes/
              FOR stored_index := 2 TO UPPERBOUND (p_volume_list^) DO
                IF (p_volume_list^ [stored_index].external_vsn <>
                      p_stored_volume_list^ [attach_index + stored_index - 1].external_vsn) OR
                      (p_volume_list^ [stored_index].recorded_vsn <>
                      p_stored_volume_list^ [attach_index + stored_index - 1].recorded_vsn) THEN
                  EXIT /validate_volume_list/;
                IFEND;
              FOREND /validate_remaining_volumes/;
              valid_volume_list := TRUE;

              { Only allow volume overflow if the last volume is included.

              volume_overflow_allowed := volume_overflow_allowed AND
                    ((attach_index + UPPERBOUND (p_volume_list^) - 1) = UPPERBOUND (p_stored_volume_list^));
              EXIT /validate_volume_list/;
            IFEND;
          FOREND /validate_volume_list/;
          IF NOT valid_volume_list THEN
            bap$set_evaluated_file_abnormal (evaluated_file_reference, fse$invalid_volume_list,
                  'ATTACH_FILE', '', status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      IF cycle_description^.cd_attachment_options = NIL THEN
        ALLOCATE cycle_description^.cd_attachment_options IN osv$job_pageable_heap^;
        cycle_description^.cd_attachment_options^ := attachment_options;
        IF (cycle_description^.attached_access_modes *
              $fst$file_access_options [fsc$append, fsc$shorten, fsc$modify]) =
              $fst$file_access_options [] THEN
          cycle_description^.cd_attachment_options^.job_write_concurrency_specified := FALSE;
        IFEND;
      ELSE
        local_attachment_options := cycle_description^.cd_attachment_options^;
        parameter_name := osc$null_name;
        IF attachment_options.free_behind_specified THEN
          IF NOT local_attachment_options.free_behind_specified THEN
            local_attachment_options.free_behind_specified := TRUE;
            local_attachment_options.free_behind := attachment_options.free_behind;
          ELSEIF attachment_options.free_behind <> local_attachment_options.free_behind THEN
            parameter_name := 'FREE_BEHIND';
          IFEND;
        IFEND;
        IF attachment_options.job_write_concurrency_specified AND (cycle_description^.attached_access_modes *
              $fst$file_access_options [fsc$append, fsc$shorten, fsc$modify] <>
              $fst$file_access_options []) THEN
          IF NOT local_attachment_options.job_write_concurrency_specified THEN
            local_attachment_options.job_write_concurrency_specified := TRUE;
            local_attachment_options.job_write_concurrency := attachment_options.job_write_concurrency;
          ELSEIF attachment_options.job_write_concurrency <>
                local_attachment_options.job_write_concurrency THEN
            parameter_name := 'JOB_WRITE_CONCURRENCY';
          IFEND;
        IFEND;
        IF attachment_options.private_read_specified THEN
          IF NOT local_attachment_options.private_read_specified THEN
            local_attachment_options.private_read_specified := TRUE;
            local_attachment_options.private_read := attachment_options.private_read;
          ELSEIF attachment_options.private_read <> local_attachment_options.private_read THEN
            parameter_name := 'PRIVATE_READ';
          IFEND;
        IFEND;
        IF attachment_options.sequential_access_specified THEN
          IF NOT local_attachment_options.sequential_access_specified THEN
            local_attachment_options.sequential_access_specified := TRUE;
            local_attachment_options.sequential_access := attachment_options.sequential_access;
          ELSEIF attachment_options.sequential_access <> local_attachment_options.sequential_access THEN
            parameter_name := 'SEQUENTIAL_ACCESS';
          IFEND;
        IFEND;
        IF attachment_options.transfer_size_specified THEN
          IF (NOT local_attachment_options.transfer_size_specified) THEN
            local_attachment_options.transfer_size_specified := TRUE;
            local_attachment_options.transfer_size := attachment_options.transfer_size;
          ELSEIF attachment_options.transfer_size <> local_attachment_options.transfer_size THEN
            parameter_name := 'TRANSFER_SIZE';
          IFEND;
        IFEND;
        IF attachment_options.volume_overflow_allowed_spec THEN
          IF NOT local_attachment_options.volume_overflow_allowed_spec THEN
            local_attachment_options.volume_overflow_allowed_spec := TRUE;
            local_attachment_options.volume_overflow_allowed := attachment_options.volume_overflow_allowed;
          ELSEIF attachment_options.volume_overflow_allowed <>
                local_attachment_options.volume_overflow_allowed THEN
            parameter_name := 'VOLUME_OVERFLOW_ALLOWED';
          IFEND;
        IFEND;
        IF parameter_name <> osc$null_name THEN
          bap$set_evaluated_file_abnormal (evaluated_file_reference, fse$redundant_attachment_spec,
                'ATTACH_FILE', parameter_name, status);
        ELSE
          cycle_description^.cd_attachment_options^ := local_attachment_options;
        IFEND;
      IFEND;
      IF status.normal AND (cycle_description^.device_class = rmc$magnetic_tape_device) THEN
        IF p_volume_list <> NIL THEN
          dmp$replace_tape_vsn_list (cycle_description^.system_file_id, p_volume_list,
                volume_overflow_allowed, status);
          IF status.normal THEN
            REPEAT
              iop$delete_rvl_entry (cycle_description^.system_file_id, status);
              IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
                pmp$wait (one_second, one_second);
              IFEND;
            UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
          IFEND;
          IF status.normal THEN
            REPEAT
              iop$create_rvl_entry (cycle_description^.system_file_id, density,
                    cycle_description^.system_file_label.descriptive_label.global_file_name,
                    evaluated_file_reference.path_handle_info.path_handle, rmv$requested_volume_attributes,
                    p_volume_list^, write_ring, status);
              IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
                pmp$wait (one_second, one_second);
              IFEND;
            UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
          IFEND;
          IF status.normal THEN
            cycle_description^.system_file_label.descriptive_label.internal_cycle_name :=
                  cycle_description^.system_file_label.descriptive_label.global_file_name;
          IFEND;
        ELSEIF attachment_options.volume_overflow_allowed_spec THEN
          dmp$replace_tape_vsn_list (cycle_description^.system_file_id, {p_volume_list} NIL,
                attachment_options.volume_overflow_allowed, status);
        IFEND;
      IFEND;
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$set_attachment_options;

?? TITLE := 'PROCEDURE [INLINE] assign_device_class', EJECT ??

  PROCEDURE [INLINE] assign_device_class
    (    device_class: rmt$device_class;
         cycle_description: {i^/o^} ^fmt$cycle_description);

    IF cycle_description^.attached_file THEN
      RETURN;
    IFEND;

    cycle_description^.attached_file := TRUE;
    cycle_description^.system_file_label.static_label := NIL;
    cycle_description^.system_file_label.file_previously_opened := FALSE;
    cycle_description^.system_file_label.descriptive_label :=
          fmv$system_file_attributes.descriptive_label;
    cycle_description^.device_class := device_class;

    CASE cycle_description^.device_class OF
    = rmc$magnetic_tape_device =
      cycle_description^.file_space_limit_kind := sfc$no_limit;
      cycle_description^.job_routing_label := NIL;
      cycle_description^.job_routing_label_length := 0;
      cycle_description^.permanent_file := FALSE;
      cycle_description^.system_file_id := dmv$null_sfid;

    = rmc$mass_storage_device =
      cycle_description^.file_space_limit_kind := sfc$temp_file_space_limit;
      cycle_description^.job_routing_label := NIL;
      cycle_description^.job_routing_label_length := 0;
      cycle_description^.permanent_file := FALSE;
      cycle_description^.system_file_id := dmv$null_sfid;

    = rmc$terminal_device =
      cycle_description^.terminal_request := NIL;
      cycle_description^.terminal_command := NIL;
      cycle_description^.terminal_file_name := osc$null_name;

    ELSE
    CASEND;
  PROCEND assign_device_class;

?? TITLE := 'PROCEDURE [INLINE] create_temporary_file', EJECT ??

  PROCEDURE [INLINE] create_temporary_file
    (    preserved_attributes: ^bat$static_label_attributes;
         request_descriptor: ^fst$mass_storage_device_info;
         segment_attributes: ^array [ * ] of mmt$attribute_descriptor;
     VAR cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      engineering_operation: boolean,
      entry_available: boolean,
      i: integer,
      file_attributes: array [dm_file_class_index .. dm_transfer_size_index]
            of dmt$new_file_attribute,
      file_class: string(1),
      file_share_selections: pft$share_selections,
      file_type: gft$file_kind,
      file_usage: pft$usage_selections;

    #caller_id(caller_id);
    status.normal := TRUE;

    file_type := gfc$fk_job_local_file;
    file_usage := - $pft$usage_selections [];
    file_share_selections := $pft$share_selections [];
    file_attributes := dm_file_attributes;

    IF jmp$system_job () THEN
      file_attributes [dm_file_class_index].class := rmc$msc_system_critical_files;
    IFEND;

    IF preserved_attributes <> NIL THEN
      file_attributes [dm_clear_space_index].required := preserved_attributes^.clear_space;
      file_attributes [dm_preset_value_index].preset_value := preserved_attributes^.preset_value;
      file_attributes [dm_file_limit_index].limit := preserved_attributes^.file_limit;
    ELSEIF segment_attributes <> NIL THEN
      FOR i := LOWERBOUND (segment_attributes^) TO UPPERBOUND (segment_attributes^) DO
        CASE segment_attributes^ [i].keyword OF
        = mmc$kw_clear_space =
          file_attributes [dm_clear_space_index].required := segment_attributes^ [i].clear_space;
        = mmc$kw_max_segment_length =
          file_attributes [dm_file_limit_index].limit := segment_attributes^ [i].max_length;
        = mmc$kw_preset_value =
          file_attributes [dm_preset_value_index].preset_value :=
                mmv$preset_conversion_table [segment_attributes^ [i].preset_value];
        ELSE
        CASEND;
      FOREND;
    IFEND;

    IF request_descriptor <> NIL THEN
      file_attributes [dm_volume_overflow_index].overflow_allowed :=
            request_descriptor^.volume_overflow_allowed;
      file_attributes [dm_initial_volume_index].requested_volume.recorded_vsn :=
            request_descriptor^.initial_volume;

      IF request_descriptor^.allocation_unit_size <> rmc$unspecified_allocation_size THEN
        file_attributes [dm_allocation_size_index].requested_allocation_size :=
              request_descriptor^.allocation_unit_size;
      IFEND;

      IF request_descriptor^.transfer_size < LOWERVALUE(dmt$transfer_size) THEN
        file_attributes [dm_transfer_size_index].requested_transfer_size := LOWERVALUE(dmt$transfer_size);
      ELSEIF request_descriptor^.transfer_size > UPPERVALUE(dmt$transfer_size) THEN
        file_attributes [dm_transfer_size_index].requested_transfer_size := UPPERVALUE(dmt$transfer_size);
      ELSE
        file_attributes [dm_transfer_size_index].requested_transfer_size := request_descriptor^.transfer_size;
      IFEND;

      IF request_descriptor^.mass_storage_class <> rmc$unspecified_file_class THEN
        file_attributes [dm_file_class_index].class := request_descriptor^.mass_storage_class;
      ELSEIF request_descriptor^.initial_volume <> rmc$unspecified_vsn THEN
        avp$get_capability (avc$engineering_operation, avc$user, engineering_operation, status);
        status.normal := TRUE;
        IF (engineering_operation OR jmp$system_job () OR avp$system_administrator () OR
              (caller_id.ring <= osc$tsrv_ring)) THEN
          file_attributes [dm_file_class_index].class := rmc$unspecified_file_class;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      dmp$create_file_entry (file_type, file_usage, file_share_selections,
            dmc$minimum_file_share_his, ^file_attributes, {byte_address} 0, {assign_volume} TRUE,
            cycle_description^.system_file_label.descriptive_label.global_file_name,
            cycle_description^.system_file_id, status);
    IFEND;

    IF status.normal THEN
      cycle_description^.system_file_label.descriptive_label.internal_cycle_name :=
            cycle_description^.system_file_label.descriptive_label.global_file_name;
    ELSE
      IF status.condition = dme$file_class_not_valid THEN
        file_class := file_attributes [dm_file_class_index].class;
        osp$set_status_abnormal (rmc$resource_management_id, rme$file_class_not_valid,
              request_descriptor^.initial_volume, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, file_class, status);
      ELSEIF status.condition = dme$unable_to_create_fdt_entry THEN
        osp$set_status_condition (fse$temp_files_limit_reached, status);
      IFEND;
    IFEND;

  PROCEND create_temporary_file;

?? TITLE := 'PROCEDURE [INLINE] establish_segment_attributes', EJECT ??

  PROCEDURE [INLINE] establish_segment_attributes
    (    access_level: amt$access_level;
         validation_ring: ost$valid_ring;
         instance_static_attributes: bat$instance_static_attributes;
         access_mode: pft$usage_selections;
         cd_attachment_options: fmt$cd_attachment_options;
         segment_attributes: {i^/o^} ^array [1 .. *] of mmt$attribute_descriptor;
     VAR ring: ost$valid_ring);

    IF (NOT (instance_static_attributes.file_organization IN amv$aam_file_organizations))
          AND cd_attachment_options.transfer_size_specified THEN
      segment_attributes^ [mm_transfer_size_index].keyword := mmc$kw_ps_transfer_size;
      segment_attributes^ [mm_transfer_size_index].ps_transfer_size := cd_attachment_options.transfer_size;
    ELSE
      segment_attributes^ [mm_transfer_size_index].keyword := mmc$kw_null_keyword;
    IFEND;

    segment_attributes^ [mm_ring_numbers_index].keyword := mmc$kw_ring_numbers;
    CASE access_level OF
    = amc$segment =
      segment_attributes^ [mm_ring_numbers_index].r1 := instance_static_attributes.ring_attributes.r1;
      segment_attributes^ [mm_ring_numbers_index].r2 := instance_static_attributes.ring_attributes.r2;
      ring := validation_ring;

    = amc$record =
      IF instance_static_attributes.file_organization IN amv$aam_file_organizations THEN
        segment_attributes^ [mm_ring_numbers_index].r1 := 4;
        segment_attributes^ [mm_ring_numbers_index].r2 := 4;
        ring := 4;
      ELSE
        segment_attributes^ [mm_ring_numbers_index].r1 := 3;
        segment_attributes^ [mm_ring_numbers_index].r2 := 3;
        ring := 3;
      IFEND;

    = amc$physical =
      segment_attributes^ [mm_ring_numbers_index].r1 := validation_ring;
      segment_attributes^ [mm_ring_numbers_index].r2 := validation_ring;
      ring := validation_ring;

    ELSE
      ;
    CASEND;

    segment_attributes^ [mm_access_control_index].keyword := mmc$kw_segment_access_control;
    segment_attributes^ [mm_access_control_index].access_control.cache_bypass := FALSE;
    segment_attributes^ [mm_access_control_index].access_control.execute_privilege :=
          osc$non_executable;
    segment_attributes^ [mm_access_control_index].access_control.read_privilege := osc$non_readable;
    segment_attributes^ [mm_access_control_index].access_control.write_privilege := osc$non_writable;
    IF read_access <= access_mode THEN
      segment_attributes^ [mm_access_control_index].access_control.read_privilege :=
            osc$read_uncontrolled;
    IFEND;
    IF (write_access * access_mode) <> null_set THEN
      segment_attributes^ [mm_access_control_index].access_control.write_privilege :=
            osc$write_uncontrolled;
      IF access_level = amc$record THEN
        segment_attributes^ [mm_access_control_index].access_control.read_privilege :=
              osc$read_uncontrolled;
      IFEND;
    IFEND;
    IF execute_access <= access_mode THEN
      segment_attributes^ [mm_access_control_index].access_control.execute_privilege :=
            osc$non_privileged;
    IFEND;

    segment_attributes^ [mm_software_attributes_index].keyword := mmc$kw_software_attributes;
    segment_attributes^ [mm_software_attributes_index].software_attri_set := $mmt$software_attribute_set
          [];
    IF NOT (pfc$append IN access_mode) THEN
      segment_attributes^ [mm_software_attributes_index].software_attri_set :=
            segment_attributes^ [mm_software_attributes_index].software_attri_set +
            $mmt$software_attribute_set [mmc$sa_no_append];
    IFEND;
    IF NOT (instance_static_attributes.file_organization IN amv$aam_file_organizations) THEN
      IF NOT cd_attachment_options.sequential_access_specified THEN
        IF access_level = amc$record THEN
          segment_attributes^ [mm_software_attributes_index].software_attri_set :=
                segment_attributes^ [mm_software_attributes_index].software_attri_set +
                $mmt$software_attribute_set [mmc$sa_read_transfer_unit];
         IFEND;
      ELSEIF cd_attachment_options.sequential_access THEN
        segment_attributes^ [mm_software_attributes_index].software_attri_set :=
              segment_attributes^ [mm_software_attributes_index].software_attri_set +
              $mmt$software_attribute_set [mmc$sa_read_transfer_unit];
      IFEND;
      IF NOT cd_attachment_options.free_behind_specified THEN
        IF (access_level = amc$record) AND
              (instance_static_attributes.block_type = amc$system_specified) THEN
          segment_attributes^ [mm_software_attributes_index].software_attri_set :=
                  segment_attributes^ [mm_software_attributes_index].software_attri_set +
                  $mmt$software_attribute_set [mmc$sa_free_behind];
        IFEND;
      ELSEIF cd_attachment_options.free_behind THEN
        segment_attributes^ [mm_software_attributes_index].software_attri_set :=
                segment_attributes^ [mm_software_attributes_index].software_attri_set +
                $mmt$software_attribute_set [mmc$sa_free_behind];
      IFEND;
    IFEND;

  PROCEND establish_segment_attributes;

?? TITLE := 'PROCEDURE job_exit_condition_handler', EJECT ??

{ PURPOSE:
{   This procedure handles those conditions that occur during job exit.

  PROCEDURE job_exit_condition_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    VAR
      continue: boolean;

    handler_status.normal := TRUE;

    CASE condition.selector OF
    = pmc$system_conditions, mmc$segment_access_condition,
          pmc$user_defined_condition =
      continue := TRUE;
    ELSE
      continue := FALSE;
    CASEND;

    IF continue THEN
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    IFEND;
  PROCEND job_exit_condition_handler;

?? TITLE := 'PROCEDURE put_label_in_cd', EJECT ??

  PROCEDURE put_label_in_cd
    (    p_file_label: fmt$p_file_label;
         cycle_description: ^fmt$cycle_description;
         path_handle: fmt$path_handle;
     VAR status: ost$status);

    VAR
      label_size: integer,
      local_p_file_label: fmt$p_file_label,
      label_header: ^fmt$static_label_header;

    status.normal := TRUE;

    local_p_file_label := p_file_label;
    RESET local_p_file_label;
    NEXT label_header IN local_p_file_label;
    IF label_header^.unique_character = fmc$unique_label_id THEN
      IF label_header^.highest_attribute_present > 0 THEN
        IF label_header^.revision_level <> fmc$current_revision_level THEN
          bap$validate_compatibility (local_p_file_label, label_header,
                path_handle, FALSE, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        label_size := #SIZE (p_file_label^) -
              label_header^.job_routing_label_size;
        IF cycle_description^.system_file_label.static_label <> NIL THEN
          FREE cycle_description^.system_file_label.static_label IN
                osv$job_pageable_heap^;
        IFEND;
        ALLOCATE cycle_description^.system_file_label.static_label:
              [[REP label_size OF cell]] IN osv$job_pageable_heap^;
        i#move (local_p_file_label, cycle_description^.system_file_label.
              static_label, label_size);
        RESET cycle_description^.system_file_label.static_label;
        NEXT label_header IN cycle_description^.system_file_label.static_label;
        label_header^.revision_level := fmc$current_revision_level;
        IF label_header^.revision_level <> fmc$current_revision_level THEN
          fmp$verify_attribute_limits (cycle_description^.system_file_label.
                static_label, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      ELSE { highest_attribute_present = 0  (default label) }
        cycle_description^.system_file_label.static_label := NIL;
      IFEND;
    ELSE { unique_character <> % }
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, 'put_label_in_cd', status);
    IFEND;
  PROCEND put_label_in_cd;

?? TITLE := 'PROCEDURE return_network_file', EJECT ??

  PROCEDURE return_network_file
    (    cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

    VAR
      switch_complete: boolean;

    status.normal := TRUE;

    IF (cycle_description^.global_file_information^.device_dependent_info.
          network_global_file_information^.file_state = nac$normal) OR
          (cycle_description^.global_file_information^.device_dependent_info.
          network_global_file_information^.file_state = nac$nominal_normal) THEN
      nap$se_return_file (cycle_description^.global_file_information^.
            device_dependent_info.network_connection_id, status);
    ELSEIF cycle_description^.global_file_information^.device_dependent_info.
          network_global_file_information^.file_state =
          nac$simulated_connection_broken THEN
      nap$se_return_file (cycle_description^.global_file_information^.
            device_dependent_info.network_global_file_information^.
            backup_connection_id, status);
    ELSEIF (cycle_description^.global_file_information^.
          device_dependent_info.network_global_file_information^.file_state =
          nac$switch_offered) OR (cycle_description^.
          global_file_information^.device_dependent_info.
          network_global_file_information^.file_state =
          nac$nominal_conn_switch_offer) THEN
      nlp$cancel_switch_offer (cycle_description^.global_file_information^.
            device_dependent_info.network_global_file_information^.
            backup_connection_id, switch_complete, status);
      IF NOT status.normal THEN
        osp$system_error ('nlp$cancel_switch_offer failed', ^status);
        {! DEBUG}
      IFEND;
      IF NOT switch_complete THEN
        nap$se_return_file (cycle_description^.global_file_information^.
              device_dependent_info.network_global_file_information^.
              backup_connection_id, status);
      IFEND;
    IFEND;

    FREE cycle_description^.global_file_information^.device_dependent_info.
         network_global_file_information IN osv$task_shared_heap^;
  PROCEND return_network_file;

?? TITLE := 'PROCEDURE [INLINE] return_file_at_job_exit', EJECT ??

  PROCEDURE [INLINE] return_file_at_job_exit
    (    cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

    VAR
      detachment_options: fmt$detachment_options,
      path_handle_name: fst$path_handle_name,
      usage_selections: pft$usage_selections;

    status.normal := TRUE;

    CASE cycle_description^.device_class OF
    = rmc$magnetic_tape_device =
      IF cycle_description^.permanent_file THEN
        IF (cycle_description^.static_setfa_entries <> NIL) AND
              (NOT cycle_description^.system_file_label.file_previously_opened) THEN
          fmp$catalog_set_file_attributes (cycle_description, status);
          IF osp$file_access_condition (status) THEN {ignore any other status}
            RETURN;
          IFEND;
        IFEND;

        #UNCHECKED_CONVERSION (cycle_description^.attached_access_modes, usage_selections);
        pfp$return_permanent_file (cycle_description^.apfid, cycle_description^.system_file_id,
              cycle_description^.device_class, usage_selections, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        detachment_options := fmv$default_detachment_options;
        detachment_options.device_class := rmc$magnetic_tape_device;
        detachment_options.physical_unload := TRUE;
        dmp$close_tape_volume (cycle_description^.system_file_id, detachment_options, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    = rmc$mass_storage_device =
      IF cycle_description^.permanent_file THEN
        IF (cycle_description^.static_setfa_entries <> NIL) AND
            (NOT cycle_description^.system_file_label.file_previously_opened)
            THEN
          fmp$catalog_set_file_attributes (cycle_description, status);
          IF osp$file_access_condition (status) THEN {ignore any other status.
            RETURN;
          IFEND;
        IFEND;

        #UNCHECKED_CONVERSION (cycle_description^.attached_access_modes, usage_selections);
        pfp$return_permanent_file (cycle_description^.apfid, cycle_description^.system_file_id,
              cycle_description^.device_class, usage_selections, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        IF (cycle_description^.system_file_id.residence = gfc$tr_job) THEN
          dmp$destroy_file (cycle_description^.system_file_id,
                cycle_description^.file_space_limit_kind, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;

    = rmc$null_device =

    = rmc$network_device =
      return_network_file (cycle_description, status);
    = rmc$rhfam_device =
      clp$construct_path_handle_name
             (cycle_description^.path_handle, path_handle_name);
      rfp$delete_connection (path_handle_name, status);
    ELSE { terminal
      ;
    CASEND;
  PROCEND return_file_at_job_exit;

?? TITLE := 'PROCEDURE [INLINE] verify_device_assignment', EJECT ??

  PROCEDURE [INLINE] verify_device_assignment
    (    evaluated_file_reference: fst$evaluated_file_reference;
         required_device_class: rmt$device_class;
         cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

    status.normal := TRUE;

    IF cycle_description^.attached_file THEN
      IF cycle_description^.device_class <> required_device_class THEN
        bap$set_evaluated_file_abnormal (evaluated_file_reference,
              rme$device_assignment_conflict, 'FMM$CYCLE_MANAGER',
              amv$device_class_names [ cycle_description^.device_class ].name ( 1,
              amv$device_class_names [ cycle_description^.device_class ].size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              amv$device_class_names [ required_device_class ].name ( 1,
              amv$device_class_names [ required_device_class ].size), status);
      ELSE
        bap$set_evaluated_file_abnormal (evaluated_file_reference,
              rme$redundant_device_assignment, 'FMM$CYCLE_MANAGER',
              amv$device_class_names [ cycle_description^.device_class ].name ( 1,
              amv$device_class_names [ cycle_description^.device_class ].size), status);
      IFEND;
    ELSE
      RETURN;
    IFEND;

  PROCEND verify_device_assignment;

?? OLDTITLE ??

MODEND fmm$cycle_manager;
*DECK DECK=FMM$EVALUATE_PATH EXPAND=TRUE
*copyc osd$default_pragmats

?? TITLE := 'NOS/VE : Basic Access Methods : Path evaluator' ??

MODULE fmm$evaluate_path;

{ PURPOSE: Resolve the given file path and return information about the path.


?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc fme$file_management_errors
*copyc fsc$local
*copyc fst$path_element_size
*copyc fst$path_size
*copyc fsv$evaluated_file_reference
*copyc ost$name
*copyc pfe$error_condition_codes
?? POP ??
*copyc clp$check_name_for_path_handle
*copyc clp$evaluate_file_reference
*copyc clp$trimmed_string_size
*copyc clp$validate_name
*copyc fsp$path_element
*copyc fmp$process_pt_request
*copyc osp$set_status_abnormal

  PROCEDURE [INLINE] validate_local_file_name (potential_name:
    fst$file_reference;
    VAR local_file_name: amt$local_file_name;
    VAR path_handle: fmt$path_handle;
    VAR name_is_path_handle: boolean;
    VAR name_is_valid: boolean;
    VAR cl_path_handle: clt$path_handle);

    VAR
      name_size: fst$path_size;

    name_size := STRLENGTH (potential_name);
    WHILE (name_size > 1) AND (potential_name (name_size) = ' ') DO
      name_size := name_size - 1;
    WHILEND;
    name_is_path_handle := FALSE;
    IF name_size > STRLENGTH (amt$local_file_name) THEN
      name_is_valid := FALSE;
    ELSE
      clp$validate_name (potential_name (1, name_size), local_file_name,
            name_is_valid);
      IF name_is_valid THEN
        clp$check_name_for_path_handle (local_file_name, cl_path_handle);
        IF cl_path_handle.kind = clc$regular_path_handle THEN
          name_is_path_handle  := TRUE;
          path_handle := cl_path_handle.regular_handle;
        IFEND;
      IFEND;
    IFEND;

  PROCEND validate_local_file_name;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$evaluate_path', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$evaluate_path
    (    file: fst$file_reference;
         process_pt_work_list: bat$process_pt_work_list;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

    VAR
      cl_path_handle: clt$path_handle,
      file_reference_parsing_options : clt$file_ref_parsing_options,
      name_is_path_handle: boolean,
      name_is_valid: boolean,
      name_size: fst$path_element_size,
      path_handle: fmt$path_handle,
      process_pt_results: bat$process_pt_results,
      validated_name: amt$local_file_name;

    status.normal := TRUE;

    evaluated_file_reference := fsv$evaluated_file_reference;

    validate_local_file_name (file, validated_name, path_handle,
          name_is_path_handle, name_is_valid, cl_path_handle);
    IF name_is_path_handle THEN
      evaluated_file_reference.path_handle_info.path_handle := path_handle;
      evaluated_file_reference.path_handle_info.path_handle_present := TRUE;
    ELSE
      IF (NOT name_is_valid) OR (cl_path_handle.kind = clc$command_file_handle) THEN
        IF NOT (bac$create_cycle_description IN process_pt_work_list) THEN
          file_reference_parsing_options := $clt$file_ref_parsing_options [clc$command_file_ref_allowed];
        ELSE
          file_reference_parsing_options := $clt$file_ref_parsing_options [];
        IFEND;
        clp$evaluate_file_reference (file, file_reference_parsing_options, FALSE,
              evaluated_file_reference, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE { name is valid }
        evaluated_file_reference.path_structure (1) := $char (fsc$local_size);
        evaluated_file_reference.path_structure (2, fsc$local_size) := fsc$local;
        name_size := clp$trimmed_string_size (validated_name);
        evaluated_file_reference.path_structure (fsc$local_size + 2) := $char (name_size);
        evaluated_file_reference.path_structure (fsc$local_size + 3, name_size) := validated_name;
        evaluated_file_reference.path_structure_size := fsc$local_size +
              name_size + 2;
        evaluated_file_reference.number_of_path_elements := 2;
      IFEND;
    IFEND;

    fmp$process_pt_request (process_pt_work_list, osc$null_name,
          evaluated_file_reference, cycle_description, process_pt_results,
          status);
    IF (cycle_description = NIL) AND (bac$return_cycle_description IN process_pt_work_list) AND
          (status.normal OR (status.condition = pfe$unknown_permanent_file) OR
          (status.condition = fme$obsolete_path_handle)) THEN
      osp$set_status_abnormal (amc$access_method_id, fme$no_cycle_description, '', status);
    IFEND;

  PROCEND fmp$evaluate_path;
MODEND fmm$evaluate_path;

*DECK DECK=FMM$EXPAND_FILE_LABEL EXPAND=TRUE
*copyc osd$default_pragmats

MODULE fmm$expand_file_label;

{    This module expands a label, if it is in the V1 sequence format,
{ into the record format of bat$static_label_attributes.  It also
{ returns the values of the file's ring_attributes and the pointer to
{ the job routing label if one exists.

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc bat$static_label_attributes
*copyc fmc$unique_label_id
*copyc fmt$basic_file_label
*copyc fmt$file_attribute_keys
*copyc fmt$file_label
*copyc fmt$static_label_item
*copyc fmt$static_label_header
*copyc fmt$label_headers
*copyc fmv$system_file_attributes
*copyc jmt$system_label_info_length
*copyc osp$set_status_abnormal
*copyc ost$status
?? POP ??

?? TITLE := '[XDCL] fmp$expand_file_label', EJECT ??

  PROCEDURE [XDCL] fmp$expand_file_label (file_label_p:
    fmt$p_file_label;
        expand_label: boolean;
    VAR job_label: ^SEQ ( * );
    VAR job_label_size: jmt$system_label_info_length;
    VAR ring_attributes: amt$ring_attributes;
    VAR ring_attributes_source: amt$attribute_source;
    VAR file_previously_opened: boolean;
    VAR expanded_label: bat$static_label_attributes;
    VAR status: ost$status);

    VAR
      p_file_label: ^SEQ ( * ),
      job_label_header: ^fmt$job_label_header,
      label_header: ^fmt$static_label_header,
      static_info: ^fmt$basic_file_label,
      static_label: ^SEQ ( * ),
      static_label_size: integer,
      v1_header: ^fmt$static_bam_label_header;

    p_file_label := file_label_p; {assign seq ptr to local variable}

    job_label := NIL;
    RESET p_file_label;
    static_label_size := #SIZE (p_file_label^) - #SIZE (fmt$static_label_header);
    NEXT label_header IN p_file_label;
    IF (label_header <> NIL) AND (label_header^.unique_character = fmc$unique_label_id) THEN
      file_previously_opened := label_header^.file_previously_opened;
      IF file_previously_opened THEN
        ring_attributes := label_header^.ring_attributes;
        ring_attributes_source := label_header^.ring_attributes_source;
      ELSE
        ring_attributes := fmv$system_file_attributes.static_label.
              ring_attributes;
        ring_attributes_source := fmv$system_file_attributes.static_label.
              ring_attributes_source;
      IFEND;
      job_label_size := label_header^.job_routing_label_size;
      IF job_label_size > 0 THEN
        static_label_size := static_label_size - job_label_size;
        IF static_label_size > 0 THEN
          NEXT static_label: [[REP static_label_size OF cell]] IN p_file_label;
          IF static_label = NIL THEN
            osp$set_status_abnormal (amc$access_method_id,
                  ame$damaged_file_attributes,
                  'STATIC LABEL is NIL in fmp$expand_file_label', status);
            RETURN;
          IFEND;
        IFEND;
        NEXT job_label: [[REP job_label_size OF cell]] IN p_file_label;
        IF job_label = NIL THEN
          osp$set_status_abnormal (amc$access_method_id,
                ame$damaged_file_attributes,
                'JOB LABEL is NIL in fmp$expand_file_label', status);
          RETURN;
        IFEND;
      IFEND;
    ELSE { possible v1 label }
      RESET p_file_label;
      NEXT v1_header IN p_file_label;
      IF v1_header = NIL THEN
        osp$set_status_abnormal (amc$access_method_id,
              ame$damaged_file_attributes,
              'V1_HEADER is NIL in fmp$expand_file_label', status);
        RETURN;
      IFEND;
      IF v1_header^.name <> 'BAM_STATIC_LABEL' THEN
        osp$set_status_abnormal (amc$access_method_id,
              ame$damaged_file_attributes,
              'INVALID STATIC LABEL NAME DETECTED in fmp$expand_file_label',
              status);
        RETURN;
      ELSE
        NEXT static_info IN p_file_label;
        IF static_info = NIL THEN
          osp$set_status_abnormal (amc$access_method_id,
                ame$damaged_file_attributes,
                'STATIC_INFO is NIL in fmp$expand_file_label', status);
          RETURN;
        IFEND;
        IF expand_label THEN
          fmp$expand_v1_label (static_info, expanded_label, file_previously_opened,
                status);
          ring_attributes := expanded_label.ring_attributes;
          ring_attributes_source := expanded_label.ring_attributes_source;
        ELSE
          file_previously_opened := static_info^. existing_file;
          ring_attributes := static_info^. ring_attributes;
          ring_attributes_source := static_info^. ring_attributes_source;
        IFEND;
      IFEND;
      NEXT job_label_header IN p_file_label;
      IF job_label_header^.name <> 'BAM_JOB_LABEL' THEN
        osp$set_status_abnormal (amc$access_method_id,
              ame$damaged_file_attributes,
              'INVALID JOB LABEL NAME DETECTED in fmp$expand_file_label',
              status);
        RETURN;
      IFEND;
      job_label_size := job_label_header^.size;
      IF job_label_size > 0 THEN
        NEXT job_label: [[REP job_label_size OF cell]] IN p_file_label;
      IFEND;
    IFEND;

  PROCEND fmp$expand_file_label;

  PROCEDURE [XDCL] fmp$expand_v1_label (v1_label: ^fmt$basic_file_label;
    VAR expanded_label: bat$static_label_attributes;
    VAR file_previously_opened: boolean;
    VAR status: ost$status);

    expanded_label := fmv$system_file_attributes.static_label;
    file_previously_opened := v1_label^.existing_file;
    expanded_label.block_type := v1_label^.block_type;
    expanded_label.block_type_source := v1_label^.block_type_source;
    expanded_label.character_conversion := v1_label^.character_conversion;
    expanded_label.character_conversion_source := v1_label^.
          character_conversion_source;
    expanded_label.clear_space := v1_label^.clear_space;
    expanded_label.clear_space_source := v1_label^.clear_space_source;
    expanded_label.file_access_procedure := v1_label^.
          file_access_procedure;
    expanded_label.file_access_procedure_source := v1_label^.
          file_access_procedure_source;
    expanded_label.file_contents := v1_label^.file_contents;
    expanded_label.file_contents_source := v1_label^.file_contents_source;
    expanded_label.file_limit := v1_label^.file_limit;
    expanded_label.file_limit_source := v1_label^.file_limit_source;
    expanded_label.file_organization := v1_label^.file_organization;
    expanded_label.file_organization_source := v1_label^.
          file_organization_source;
    expanded_label.file_processor := v1_label^.file_processor;
    expanded_label.file_processor_source := v1_label^.
          file_processor_source;
    expanded_label.file_structure := v1_label^.file_structure;
    expanded_label.file_structure_source := v1_label^.
          file_structure_source;
    expanded_label.forced_write := v1_label^.forced_write;
    expanded_label.forced_write_source := v1_label^.forced_write_source;
    expanded_label.internal_code := v1_label^.internal_code;
    expanded_label.internal_code_source := v1_label^.internal_code_source;
    expanded_label.label_type := v1_label^.label_type;
    expanded_label.label_type_source := v1_label^.label_type_source;
    IF (v1_label^.line_number.length < LOWERVALUE (amt$line_number_length)) OR
          (v1_label^.line_number.length > UPPERVALUE (amt$line_number_length)) THEN
      expanded_label.line_number.length := fmv$system_file_attributes.
            static_label.line_number.length;
    ELSE
      expanded_label.line_number.length := v1_label^.line_number.length;
    IFEND;
    IF (v1_label^.line_number.location < LOWERVALUE (amt$line_number_location))
          OR (v1_label^.line_number.location > UPPERVALUE (amt$line_number_location)) THEN
      expanded_label.line_number.location := fmv$system_file_attributes.
            static_label.line_number.location;
    ELSE
      expanded_label.line_number.location := v1_label^.line_number.location;
    IFEND;
    expanded_label.line_number_source := v1_label^.line_number_source;
    expanded_label.max_block_length := v1_label^.max_block_length;
    expanded_label.max_block_length_source := v1_label^.
          max_block_length_source;
    expanded_label.max_record_length := v1_label^.max_record_length;
    expanded_label.max_record_length_source := v1_label^.
          max_record_length_source;
    expanded_label.min_block_length := v1_label^.min_block_length;
    expanded_label.min_block_length_source := v1_label^.
          min_block_length_source;
    expanded_label.min_record_length := v1_label^.min_record_length;
    expanded_label.min_record_length_source := v1_label^.
          min_record_length_source;
    expanded_label.padding_character := v1_label^.padding_character;
    expanded_label.padding_character_source := v1_label^.
          padding_character_source;
    expanded_label.page_format := v1_label^.page_format;
    expanded_label.page_format_source := v1_label^.page_format_source;
    expanded_label.page_length := v1_label^.page_length;
    expanded_label.page_length_source := v1_label^.page_length_source;
    expanded_label.page_width := v1_label^.page_width;
    expanded_label.page_width_source := v1_label^.page_width_source;
    expanded_label.preset_value := v1_label^.preset_value;
    expanded_label.preset_value_source := v1_label^.preset_value_source;
    expanded_label.record_type := v1_label^.record_type;
    expanded_label.record_type_source := v1_label^.record_type_source;
    expanded_label.ring_attributes := v1_label^.ring_attributes;
    expanded_label.ring_attributes_source := v1_label^.
          ring_attributes_source;
    IF (v1_label^.statement_identifier.length < LOWERVALUE
          (amt$statement_id_length)) OR (v1_label^.statement_identifier.length
          > UPPERVALUE (amt$statement_id_length)) THEN
      expanded_label.statement_identifier.length := fmv$system_file_attributes.
            static_label.statement_identifier.length;
    ELSE
      expanded_label.statement_identifier.length := v1_label^.statement_identifier.length;
    IFEND;
    IF (v1_label^.statement_identifier.location < LOWERVALUE
          (amt$statement_id_location)) OR (v1_label^.statement_identifier.
          location > UPPERVALUE (amt$statement_id_location)) THEN
      expanded_label.statement_identifier.location := fmv$system_file_attributes.
            static_label.statement_identifier.location;
    ELSE
      expanded_label.statement_identifier.location := v1_label^.statement_identifier.location;
    IFEND;
    expanded_label.statement_identifier_source := v1_label^.
          statement_identifier_source;
    expanded_label.user_info := v1_label^.user_info;
    expanded_label.user_info_source := v1_label^.user_info_source;
    expanded_label.vertical_print_density := v1_label^.
          vertical_print_density;
    expanded_label.vertical_print_density_source := v1_label^.
          vertical_print_density_source;
    IF (v1_label^.average_record_length < LOWERVALUE (amt$average_record_length))
          OR (v1_label^.average_record_length > UPPERVALUE (amt$average_record_length)) THEN
      expanded_label.average_record_length := fmv$system_file_attributes.
            static_label.average_record_length;
    ELSE
      expanded_label.average_record_length := v1_label^.
            average_record_length;
    IFEND;
    expanded_label.average_record_length_source := v1_label^.
          average_record_length_source;
    expanded_label.collate_table := v1_label^.collate_table;
    expanded_label.collate_table_source := v1_label^.collate_table_source;
    expanded_label.collate_table_name := v1_label^.collate_table_name;
    expanded_label.collate_table_name_source := v1_label^.
          collate_table_name_source;
    expanded_label.data_padding := v1_label^.data_padding;
    expanded_label.data_padding_source := v1_label^.data_padding_source;
    expanded_label.embedded_key := v1_label^.embedded_key;
    expanded_label.embedded_key_source := v1_label^.embedded_key_source;
    expanded_label.estimated_record_count := v1_label^.
          estimated_record_count;
    expanded_label.estimated_record_count_source := v1_label^.
          estimated_record_count_source;
    expanded_label.index_levels := v1_label^.index_levels;
    expanded_label.index_levels_source := v1_label^.index_levels_source;
    expanded_label.index_padding := v1_label^.index_padding;
    expanded_label.index_padding_source := v1_label^.index_padding_source;
    IF (v1_label^.key_length < LOWERVALUE (amt$key_length)) OR
          (v1_label^.key_length > UPPERVALUE (amt$key_length)) THEN
      expanded_label.key_length := fmv$system_file_attributes.static_label.
            key_length;
    ELSE
      expanded_label.key_length := v1_label^.key_length;
    IFEND;
    expanded_label.key_length_source := v1_label^.key_length_source;
    expanded_label.key_position := v1_label^.key_position;
    expanded_label.key_position_source := v1_label^.key_position_source;
    expanded_label.key_type := v1_label^.key_type;
    expanded_label.key_type_source := v1_label^.key_type_source;
    IF (v1_label^.record_limit < LOWERVALUE (amt$record_limit)) OR
          (v1_label^.record_limit > UPPERVALUE (amt$record_limit)) THEN
      expanded_label.record_limit := fmv$system_file_attributes.static_label.
            record_limit;
    ELSE
      expanded_label.record_limit := v1_label^.record_limit;
    IFEND;
    expanded_label.record_limit_source := v1_label^.record_limit_source;
    IF (v1_label^.records_per_block < LOWERVALUE (amt$records_per_block)) OR
          (v1_label^.records_per_block > UPPERVALUE (amt$records_per_block)) THEN
      expanded_label.records_per_block := fmv$system_file_attributes.
            static_label.records_per_block;
    ELSE
      expanded_label.records_per_block := v1_label^.records_per_block;
    IFEND;
    expanded_label.records_per_block_source := v1_label^.
          records_per_block_source;

  PROCEND fmp$expand_v1_label;

MODEND fmm$expand_file_label;
*DECK DECK=FMM$FILE_ATTRIBUTE_MANAGER EXPAND=TRUE
*copy osd$default_pragmats

?? TITLE := 'BASIC ACCESS METHODS, ATTRIBUTE MANAGER' ??
?? NEWTITLE := 'FILE ATTRIBUTE MANAGER' ??
MODULE fmm$file_attribute_manager;
?? PUSH (LISTEXT := ON) ??

{ COMMON DECKS

*copyc amd$open_declarations
*copyc amd$operation_declarations
*copyc ame$attribute_validation_errors
*copyc ame$improper_file_id
*copyc ame$lfn_program_actions
*copyc ame$ring_validation_errors
*copyc amt$add_to_attributes
*copyc amt$file_organization_set
*copyc amt$loading_factor
*copyc amt$lock_expiration_time
*copyc amt$log_residence
*copyc amt$logging_options
*copyc cle$ecc_lexical
*copyc clt$file
*copyc dmt$system_file_id
*copyc fmc$maximum_file_label_size
*copyc fme$file_management_errors
*copyc fmk$keypoints
*copyc fmt$file_attribute_keys
*copyc fmt$cd_attachment_options
*copyc fmt$file_label
*copyc fmt$label_headers
*copyc fmt$open_cleanup_work_list
*copyc fmt$static_label_header
*copyc fsc$local
*copyc fst$goi_object_information
*copyc fst$retention
*copyc fse$get_info_validation_errors
*copyc fse$open_validation_errors
*copyc jmt$system_label_info_length
*copyc osc$base_exception
*copyc ose$heap_full_exceptions
*copyc oss$job_pageable
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc ost$segment_access_control
*copyc osv$job_pageable_heap
*copyc pfd$attached_permanent_file_id
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc rmt$device_class
?? POP ??

{ XREF DECKS

*copyc amp$set_file_instance_abnormal
*copyc avp$ring_min
*copyc bap$set_evaluated_file_abnormal
*copyc bap$validate_file_identifier
*copyc clp$check_name_for_path_handle
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_integer_to_string
*copyc dmp$fetch_eoi
*copyc dmp$get_tape_volume_information
*copyc dmp$set_file_limit
*copyc fmp$catalog_system_file_label
*copyc fmp$extract_dynamic_setfa_attrs
*copyc fmp$get_cycle_description
*copyc fmp$get_label_attributes
*copyc fmp$locate_cd_via_path_handle
*copyc fmp$locate_cycle_description
*copyc fmp$merge_setfa_entries
*copyc fmp$put_label_attributes
*copyc fmp$unlock_path_table
*copyc fsp$adjust_tape_defaults
*copyc fsp$convert_file_contents
*copyc fsp$convert_to_old_contents
*copyc fsp$expand_file_label
*copyc fsp$path_element
*copyc fsp$set_evaluated_file_abnormal
*copyc i#move
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$fetch_locked_variable
*copyc osp$increment_locked_variable
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_condition
*copyc osp$test_sig_lock
*copyc pfi$convert_cycle_reference
*copyc pfp$compute_checksum
*copyc pfp$convert_fs_to_pft$path
*copyc pfp$r3_get_object_information
*copyc pfp$r3_save_released_file_label
*copyc pfp$save_file_label

*copyc amv$aam_file_organizations
*copyc fmv$global_file_information
*copyc fmv$static_label_header
*copyc fmv$system_file_attributes
*copyc mmv$max_segment_length

  VAR
    chafa_information_request: [READ, oss$job_paged_literal] fst$goi_information_request :=
          [[fsc$specific_depth, 1], [fsc$goi_file_label, fsc$goi_job_environment_info, fsc$goi_cycle_info]];

  VAR
    null_cd_attachment_options: [READ, oss$job_paged_literal] fmt$cd_attachment_options :=
          [FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 0];

  VAR
    fmv$default_file_attributes: [oss$job_pageable, XDCL, #GATE] ^bat$static_label_attributes := NIL;

  VAR
    fmv$default_new_retention: [oss$job_pageable, XDCL, #GATE] ^fst$retention := NIL;

  VAR
    write_access: [STATIC, READ, oss$job_paged_literal] pft$usage_selections :=
          [pfc$append, pfc$modify, pfc$shorten],
    read_access: [STATIC, READ, oss$job_paged_literal] pft$usage_selections := [pfc$read],
    execute_access: [STATIC, READ, oss$job_paged_literal] pft$usage_selections := [pfc$execute],
    null_set: [STATIC, READ, oss$job_paged_literal] pft$usage_selections := [];

?? TITLE := '[XDCL] fmp$get_cd_info' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$get_cd_info
    (    evaluated_file_reference: fst$evaluated_file_reference;
         increment_open_count: boolean;
         lock_path_table: boolean;
     VAR open_cleanup_work_list: {i/o} fmt$open_cleanup_work_list;
     VAR static_label: bat$static_label_attributes;
     VAR dynamic_label: bat$dynamic_label_attributes;
     VAR descriptive_label: bat$descriptive_file_attributes;
     VAR global_file_information: bat$global_file_information;
     VAR local_file: boolean;
     VAR attached_file: boolean;
     VAR file_previously_opened: boolean;
     VAR device_assigned: boolean;
     VAR device_class: rmt$device_class;
     VAR cd_attachment_options: fmt$cd_attachment_options;
     VAR status: ost$status);

?? NEWTITLE := 'merge_setfa_tape_attributes', EJECT ??

    PROCEDURE merge_setfa_tape_attributes
      (    setfa_label: bat$static_label_attributes;
       VAR static_label: {input, output} bat$static_label_attributes);

      IF setfa_label.block_type_source = amc$file_command THEN
        static_label.block_type := setfa_label.block_type;
        static_label.block_type_source := amc$file_command;
      ELSE
        static_label.block_type_source := amc$access_method_default;
      IFEND;
      IF setfa_label.character_conversion_source = amc$file_command THEN
        static_label.character_conversion := setfa_label.character_conversion;
        static_label.character_conversion_source := amc$file_command;
      ELSE
        static_label.character_conversion_source := amc$access_method_default;
      IFEND;
      IF setfa_label.internal_code_source = amc$file_command THEN
        static_label.internal_code := setfa_label.internal_code;
        static_label.internal_code_source := amc$file_command;
      ELSE
        static_label.internal_code_source := amc$access_method_default;
      IFEND;
      IF setfa_label.max_block_length_source = amc$file_command THEN
        static_label.max_block_length := setfa_label.max_block_length;
        static_label.max_block_length_source := amc$file_command;
      ELSE
        static_label.max_block_length_source := amc$access_method_default;
      IFEND;
      IF setfa_label.max_record_length_source = amc$file_command THEN
        static_label.max_record_length := setfa_label.max_record_length;
        static_label.max_record_length_source := amc$file_command;
      ELSE
        static_label.max_record_length_source := amc$access_method_default;
      IFEND;
      IF setfa_label.padding_character_source = amc$file_command THEN
        static_label.padding_character := setfa_label.padding_character;
        static_label.padding_character_source := amc$file_command;
      ELSE
        static_label.padding_character_source := amc$access_method_default;
      IFEND;
      IF setfa_label.record_type_source = amc$file_command THEN
        static_label.record_type := setfa_label.record_type;
        static_label.record_type_source := amc$file_command;
      ELSE
        static_label.record_type_source := amc$access_method_default;
      IFEND;

    PROCEND merge_setfa_tape_attributes;

?? TITLE := 'reset_tape_attribute_sources', EJECT ??

    PROCEDURE reset_tape_attribute_sources
      (VAR static_label: bat$static_label_attributes);

      static_label.block_type_source := amc$access_method_default;
      static_label.character_conversion_source := amc$access_method_default;
      static_label.internal_code_source := amc$access_method_default;
      static_label.max_block_length_source := amc$access_method_default;
      static_label.max_record_length_source := amc$access_method_default;
      static_label.padding_character_source := amc$access_method_default;
      static_label.record_type_source := amc$access_method_default;

    PROCEND reset_tape_attribute_sources;
?? OLDTITLE, EJECT ??
    VAR
      cycle_description: ^fmt$cycle_description,
      current_volume_number: amt$volume_number,
      current_vsns: rmt$volume_descriptor,
      density: rmt$density,
      eoi: amt$file_byte_address,
      file_label: ^SEQ ( * ),
      ignore_file_previously_opened: boolean,
      ignore_status: ost$status,
      label_type: amt$label_type,
      lock_status: ost$signature_lock_status,
      max_information_size: integer,
      number_of_volumes: amt$volume_number,
      object: ^fst$goi_object,
      object_information: ^SEQ ( * ),
      requested_volume_attributes: iot$requested_volume_attributes,
      setfa_label: bat$static_label_attributes,
      sfid: dmt$system_file_id,
      validated_name: ost$name,
      volume_overflow_allowed: boolean,
      write_ring: rmt$write_ring;

    status.normal := TRUE;
    local_file := FALSE;
    attached_file := FALSE;
    file_previously_opened := FALSE;
    device_assigned := FALSE;
    device_class := rmc$mass_storage_device;
    dynamic_label := fmv$system_file_attributes.dynamic_label;
    descriptive_label := fmv$system_file_attributes.descriptive_label;
    cd_attachment_options := null_cd_attachment_options;

    fmp$locate_cd_via_path_handle (evaluated_file_reference.path_handle_info.path_handle, lock_path_table,
          cycle_description, status);

    IF NOT status.normal THEN
      IF increment_open_count THEN
        osp$set_status_condition (fme$reattach_detached_file, status);
      ELSE
        IF fmv$default_file_attributes = NIL THEN
          static_label := fmv$system_file_attributes.static_label;
        ELSE
          static_label := fmv$default_file_attributes^;
        IFEND;
        global_file_information := fmv$global_file_information;
        status.normal := TRUE;
      IFEND;
      fmp$unlock_path_table;
      RETURN;
    IFEND;

  /get_cd_info/
    BEGIN
      local_file := TRUE;

      global_file_information := cycle_description^.global_file_information^;
      IF increment_open_count THEN
        osp$test_sig_lock (cycle_description^.global_file_information^.open_lock, lock_status);
        IF lock_status = osc$sls_locked_by_current_task THEN
          fsp$set_evaluated_file_abnormal (evaluated_file_reference, fse$open_already_in_progress,
                amc$open_req, '', status);
          EXIT /get_cd_info/;
        ELSEIF lock_status = osc$sls_locked_by_another_task THEN
          osp$set_status_condition (fme$wait_for_open_lock, status);
          EXIT /get_cd_info/;
        IFEND;
        osp$set_job_signature_lock (cycle_description^.global_file_information^.open_lock);
        osp$increment_locked_variable (cycle_description^.global_file_information^.open_count, 0,
              global_file_information.open_count);
        open_cleanup_work_list := open_cleanup_work_list + $fmt$open_cleanup_work_list
              [fmc$clear_open_lock, fmc$decrement_open_count];
      ELSE
        osp$fetch_locked_variable (cycle_description^.global_file_information^.open_count,
              global_file_information.open_count);
      IFEND;

      IF cycle_description^.cd_attachment_options <> NIL THEN
        cd_attachment_options := cycle_description^.cd_attachment_options^;
      IFEND;
      IF cycle_description^.attached_file THEN
        attached_file := TRUE;
        file_label := cycle_description^.system_file_label.static_label;
        file_previously_opened := cycle_description^.system_file_label.file_previously_opened;
        descriptive_label.application_info := cycle_description^.system_file_label.descriptive_label.
              application_info;
        descriptive_label.global_access_mode := cycle_description^.system_file_label.descriptive_label.
              global_access_mode;
        descriptive_label.global_file_name := cycle_description^.system_file_label.descriptive_label.
              global_file_name;
        descriptive_label.global_share_mode := cycle_description^.system_file_label.descriptive_label.
              global_share_mode;
        descriptive_label.internal_cycle_name := cycle_description^.system_file_label.descriptive_label.
              internal_cycle_name;
        IF (cycle_description^.device_class = rmc$mass_storage_device) THEN
          descriptive_label.permanent_file := cycle_description^.permanent_file;
        IFEND;
        device_assigned := TRUE;
        device_class := cycle_description^.device_class;
      ELSE
        file_label := NIL;
      IFEND;

      IF (cycle_description^.attached_file) AND ((cycle_description^.device_class =
            rmc$magnetic_tape_device) OR (cycle_description^.device_class = rmc$mass_storage_device)) AND
            (NOT global_file_information.eoi_set) THEN
        IF cycle_description^.device_class = rmc$magnetic_tape_device THEN
          global_file_information.eoi_byte_address := mmv$max_segment_length;
        ELSE
          dmp$fetch_eoi (cycle_description^.system_file_id, eoi, status);
          IF NOT status.normal THEN
            EXIT /get_cd_info/;
          IFEND;
          global_file_information.eoi_byte_address := eoi;
        IFEND;
      IFEND;

      IF cycle_description^.dynamic_setfa_entries <> NIL THEN
        fmp$extract_dynamic_setfa_attrs (cycle_description^.dynamic_setfa_entries, dynamic_label);
      IFEND;

      IF cycle_description^.static_setfa_entries = NIL THEN
        fsp$expand_file_label (file_label, static_label, ignore_file_previously_opened, status);
        IF (device_class = rmc$magnetic_tape_device) AND file_previously_opened THEN
          reset_tape_attribute_sources (static_label);
        IFEND;
      ELSE
        IF file_label = NIL THEN
          IF (NOT file_previously_opened) OR (device_class = rmc$magnetic_tape_device) THEN
            fsp$expand_file_label (cycle_description^.static_setfa_entries, static_label,
                  ignore_file_previously_opened, status);
          ELSE
            IF fmv$default_file_attributes = NIL THEN
              static_label := fmv$system_file_attributes.static_label;
            ELSE
              static_label := fmv$default_file_attributes^;
            IFEND;
          IFEND;
        ELSE
          IF (device_class = rmc$magnetic_tape_device) AND file_previously_opened THEN
            fsp$expand_file_label (cycle_description^.static_setfa_entries, setfa_label,
                  ignore_file_previously_opened, status);
            IF NOT status.normal THEN
              EXIT /get_cd_info/;
            IFEND;
            fsp$expand_file_label (file_label, static_label, ignore_file_previously_opened, status);
            IF NOT status.normal THEN
              EXIT /get_cd_info/;
            IFEND;
            merge_setfa_tape_attributes (setfa_label, static_label);
          ELSE
            max_information_size := #SIZE (fst$goi_object_information) + #SIZE (fst$goi_object) +
                  #SIZE (cycle_description^.static_setfa_entries^) + #SIZE (file_label^);
            PUSH object_information: [[REP max_information_size OF cell]];
            NEXT object IN object_information;
            IF object = NIL THEN
              osp$set_status_condition (pfe$info_full, status);
              EXIT /get_cd_info/;
            IFEND;
            object^.object_type := fsc$goi_cycle_object;
            object^.file_label := file_label;
            fmp$merge_setfa_entries (cycle_description^.static_setfa_entries, object, object_information,
                  status);
            IF NOT status.normal THEN
              EXIT /get_cd_info/;
            IFEND;
            fsp$expand_file_label (object^.file_label, static_label, ignore_file_previously_opened, status);
          IFEND;
        IFEND;
      IFEND;

{ The following check will change the default max_block_length if the file is
{ a magnetic tape file on cartridge tape.  The check is here so an OPEN will store
{ the new default in the static label (via perserved_attributes).

      IF (cycle_description^.device_class = rmc$magnetic_tape_device) AND
            (NOT file_previously_opened) AND cycle_description^.attached_file THEN
        dmp$get_tape_volume_information (cycle_description^.system_file_id, number_of_volumes,
              current_volume_number, current_vsns, density, write_ring, requested_volume_attributes,
              volume_overflow_allowed, label_type, status);
        IF NOT status.normal THEN
          EXIT /get_cd_info/;
        IFEND;
        fsp$adjust_tape_defaults (density, static_label);
      IFEND;

    END /get_cd_info/;

    fmp$unlock_path_table;

  PROCEND fmp$get_cd_info;
?? TITLE := '[XDCL] fmp$get_global_file_information' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$get_global_file_information
    (    evaluated_file_reference: fst$evaluated_file_reference;
     VAR global_file_information: bat$global_file_information;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      local_evaluated_file_reference: fst$evaluated_file_reference;

    local_evaluated_file_reference := evaluated_file_reference;
    fmp$locate_cycle_description (local_evaluated_file_reference, cycle_description, status);

    IF status.normal THEN
      global_file_information := cycle_description^.global_file_information^;
      fmp$unlock_path_table;
    IFEND;
  PROCEND fmp$get_global_file_information;

?? TITLE := '[XDCL] fmp$change_default_file_attribs' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$change_default_file_attribs
    (    attributes: ^amt$file_attributes;
         new_retention: ^fst$retention;
         reset_system_defaults: boolean;
     VAR status: ost$status);


    VAR
      i: integer;

    IF reset_system_defaults THEN
      IF fmv$default_file_attributes <> NIL THEN
        FREE fmv$default_file_attributes IN osv$job_pageable_heap^;
      IFEND;
      IF fmv$default_new_retention <> NIL THEN
        FREE fmv$default_new_retention IN osv$job_pageable_heap^;
      IFEND;
    IFEND;

    IF new_retention <> NIL THEN
      IF fmv$default_new_retention = NIL THEN
        ALLOCATE fmv$default_new_retention IN osv$job_pageable_heap^;
      IFEND;
      fmv$default_new_retention^ := new_retention^;
    IFEND;

    IF attributes = NIL THEN
      RETURN;
    IFEND;

    IF fmv$default_file_attributes = NIL THEN
      ALLOCATE fmv$default_file_attributes IN osv$job_pageable_heap^;
      fmv$default_file_attributes^ := fmv$system_file_attributes.static_label;
    IFEND;

    FOR i := LOWERBOUND (attributes^) TO UPPERBOUND (attributes^) DO
      CASE attributes^ [i].key OF
      = amc$lock_expiration_time =
        fmv$default_file_attributes^.lock_expiration_time := attributes^ [i].lock_expiration_time;
        fmv$default_file_attributes^.lock_expiration_time_source := amc$access_method_default;

      = amc$page_length =
        fmv$default_file_attributes^.page_length := attributes^ [i].page_length;
        fmv$default_file_attributes^.page_length_source := amc$access_method_default;

      = amc$page_width =
        fmv$default_file_attributes^.page_width := attributes^ [i].page_width;
        fmv$default_file_attributes^.page_width_source := amc$access_method_default;

      = amc$record_type =
        fmv$default_file_attributes^.record_type := attributes^ [i].record_type;
        fmv$default_file_attributes^.record_type_source := amc$access_method_default;
      CASEND;
    FOREND;

  PROCEND fmp$change_default_file_attribs;

?? TITLE := '[XDCL] fmp$change_file_attributes' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$change_file_attributes
    (    file_attributes: amt$file_attributes;
         evaluated_file_reference: fst$evaluated_file_reference;
         execution_ring: ost$valid_ring;
     VAR open_changed_file: boolean;
     VAR status: ost$status);

    VAR
      changed_file_label: ^SEQ ( * ),
      checksum_p: ^pft$checksum,
      combined_keyword_specified: boolean,
      converted_file_contents: amt$file_contents,
      cycle_description: ^fmt$cycle_description,
      cycle_selector: pft$cycle_selector,
      file_contents_specified: boolean,
      file_previously_opened: boolean,
      file_structure_specified: boolean,
      i: integer,
      information_request: fst$goi_information_request,
      job_routing_label: ^SEQ ( * ),
      label_header: ^fmt$static_label_header,
      local_open_changed_file: boolean,
      local_status: ost$status,
      local_system_file_label: fmt$system_file_label,
      object_information: ^fst$goi_object_information,
      object_info_sequence: ^SEQ ( * ),
      object_info_seq_size: ost$positive_integers,
      old_label_header: ^fmt$static_label_header,
      old_static_label_size: ost$non_negative_integers,
      open_count: integer,
      password_selector: pft$password_selector,
      path_string: fst$path,
      path_string_size: fst$path_size,
      pf_path: ^pft$path,
      physical_file_label_size: ost$non_negative_integers,
      seq_pointer: ^SEQ ( * ),
      specified_file_structure: amt$file_structure,
      split_file_contents: amt$file_contents,
      split_file_structure: amt$file_structure,
      start_of_label_p: ^SEQ ( * ),
      static_file_label: bat$static_label_attributes,
      static_label_size: ost$non_negative_integers,
      text: ost$name,
      warning_status: ost$status;

?? NEWTITLE := 'generate_changed_file_label', EJECT ??
    PROCEDURE [INLINE] generate_changed_file_label
      (VAR changed_file_label: ^SEQ ( * );
       VAR checksum_p: ^pft$checksum;
       VAR start_of_label_p: ^SEQ ( * ));

      ALLOCATE changed_file_label: [[REP physical_file_label_size OF cell]] IN osv$job_pageable_heap^;
      RESET changed_file_label;
      NEXT checksum_p IN changed_file_label;
      IF local_system_file_label.static_label = NIL THEN
        NEXT label_header IN changed_file_label;
        label_header^ := fmv$static_label_header;
        RESET changed_file_label to label_header;
        NEXT start_of_label_p: [[REP static_label_size OF cell]] IN changed_file_label;
      ELSE
        NEXT start_of_label_p: [[REP static_label_size OF cell]] IN changed_file_label;
        i#move (local_system_file_label.static_label, start_of_label_p, static_label_size);
        FREE local_system_file_label.static_label IN osv$job_pageable_heap^;
      IFEND;

    PROCEND generate_changed_file_label;
?? OLDTITLE ??

    open_changed_file := FALSE;
    status.normal := TRUE;
    warning_status.normal := TRUE;

    local_open_changed_file := FALSE;

    object_info_seq_size := #SIZE (fst$goi_object_information) + fsc$max_path_size + #SIZE (fst$goi_object) +
          #SIZE (fst$job_environment_information) + fmc$maximum_file_label_size;
    PUSH object_info_sequence: [[REP object_info_seq_size OF cell]];
    RESET object_info_sequence;

    information_request := chafa_information_request;
    pfp$r3_get_object_information (evaluated_file_reference, information_request, NIL, object_info_sequence,
          status);
    IF NOT status.normal THEN
      IF (status.condition = pfe$unknown_cycle) OR (status.condition = pfe$unknown_item) OR
            (status.condition = ame$file_not_known) THEN
        fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_not_known,
              amc$change_file_attributes_cmd, '', status);
      IFEND;
      RETURN;
    IFEND;

    RESET object_info_sequence;
    NEXT object_information IN object_info_sequence;
    IF object_information = NIL THEN
      fsp$set_evaluated_file_abnormal (evaluated_file_reference, fme$system_error,
            amc$change_file_attributes_cmd, '- object information sequence is damaged', status);
      RETURN;
    ELSEIF object_information^.object = NIL THEN
      fsp$set_evaluated_file_abnormal (evaluated_file_reference, fme$system_error,
            amc$change_file_attributes_cmd, '- object pointer is NIL', status);
      RETURN;
    ELSEIF object_information^.object^.file_label = NIL THEN
      fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$not_old_file,
            amc$change_file_attributes_cmd, '', status);
      RETURN;
    IFEND;

    fsp$expand_file_label (object_information^.object^.file_label, static_file_label,
          file_previously_opened, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT file_previously_opened THEN
      fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$not_old_file,
            amc$change_file_attributes_cmd, '', status);
      RETURN;
    IFEND;

    IF object_information^.object^.job_environment_information <> NIL THEN
      IF (object_information^.object^.job_environment_information^.cycle_attached) AND
            (object_information^.object^.job_environment_information^.attached_share_modes <>
            $fst$file_access_options []) THEN
        fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_share_selection,
              amc$change_file_attributes_cmd, '', status);
        RETURN;
      IFEND;
      IF object_information^.object^.job_environment_information^.concurrent_open_count <> 0 THEN
        fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_not_closed,
              amc$change_file_attributes_cmd, '', status);
        RETURN;
      IFEND;
    IFEND;

    IF (object_information^.object^.cycle_information <> NIL) AND
          (object_information^.object^.cycle_information^.mainframe_usage_concurrency <>
          $fst$mainframe_usage_concurrency []) AND (object_information^.object^.job_environment_information
          = NIL) THEN  { file is attached by another job }
      clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} FALSE, path_string,
            path_string_size, local_status);
      osp$set_status_abnormal ('PF', pfe$cycle_busy, path_string (1, path_string_size), status);
      osp$append_status_integer (osc$status_parameter_delimiter, object_information^.object^.cycle_number,
            10, FALSE, status);
      RETURN;
    IFEND;

    IF (execution_ring > static_file_label.ring_attributes.r1) AND
          (avp$ring_min () > static_file_label.ring_attributes.r1) THEN
      fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$ring_validation_error,
            amc$change_file_attributes_cmd, '', status);
      RETURN;
    IFEND;

    text := osc$null_name;
    FOR i := LOWERBOUND (file_attributes) TO UPPERBOUND (file_attributes) DO
      CASE file_attributes [i].key OF
      = amc$file_limit =
        IF file_attributes [i].file_limit <= static_file_label.file_limit THEN
          text := 'FILE LIMIT';
        IFEND;
      = amc$record_limit =
        IF file_attributes [i].record_limit <= static_file_label.record_limit THEN
          text := 'RECORD LIMIT';
        IFEND;
      ELSE
      CASEND;

      IF text <> osc$null_name THEN
        IF status.normal THEN
          fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_new_attrib_value,
                amc$change_file_attributes_cmd, text, status);
        ELSE
          osp$append_status_parameter (',', text, status);
        IFEND;
        text := osc$null_name;
      IFEND;
    FOREND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_contents_specified := FALSE;
    file_structure_specified := FALSE;

    FOR i := LOWERBOUND (file_attributes) TO UPPERBOUND (file_attributes) DO
      CASE file_attributes [i].key OF
      = amc$file_contents =
        file_contents_specified := TRUE;
        fsp$convert_to_old_contents (file_attributes [i].file_contents, split_file_contents,
              split_file_structure);
        combined_keyword_specified := (split_file_structure <> fsc$unknown_contents) OR
              (split_file_contents = fsc$unknown_contents) OR (split_file_contents = fsc$source_map);
        static_file_label.file_contents_source := amc$change_file_attributes;

      = amc$file_limit =
        static_file_label.file_limit := file_attributes [i].file_limit;
        static_file_label.file_limit_source := amc$change_file_attributes;

      = amc$file_access_procedure =
        static_file_label.file_access_procedure := file_attributes [i].file_access_procedure;
        IF static_file_label.file_access_procedure = osc$null_name THEN
          static_file_label.file_access_procedure_source := amc$undefined_attribute;
        ELSE
          static_file_label.file_access_procedure_source := amc$change_file_attributes;
        IFEND;

      = amc$file_processor =
        static_file_label.file_processor := file_attributes [i].file_processor;
        static_file_label.file_processor_source := amc$change_file_attributes;

      = amc$file_structure =
        file_structure_specified := TRUE;
        specified_file_structure := file_attributes [i].file_structure;
        static_file_label.file_structure_source := amc$change_file_attributes;

      = amc$forced_write =
        static_file_label.forced_write := file_attributes [i].forced_write;
        static_file_label.forced_write_source := amc$change_file_attributes;

      = amc$line_number =
        static_file_label.line_number := file_attributes [i].line_number;
        static_file_label.line_number_source := amc$change_file_attributes;

      = amc$loading_factor =
        static_file_label.loading_factor := file_attributes [i].loading_factor;
        static_file_label.loading_factor_source := amc$change_file_attributes;

      = amc$lock_expiration_time =
        static_file_label.lock_expiration_time := file_attributes [i].lock_expiration_time;
        static_file_label.lock_expiration_time_source := amc$change_file_attributes;

      = amc$logging_options =
        static_file_label.logging_options := file_attributes [i].logging_options;
        static_file_label.logging_options_source := amc$change_file_attributes;
        local_open_changed_file := TRUE;

      = amc$log_residence =
        IF file_attributes [i].log_residence <> NIL THEN
          static_file_label.log_residence := file_attributes [i].log_residence^;
          IF static_file_label.log_residence = osc$null_name THEN
            static_file_label.log_residence_source := amc$undefined_attribute;
          ELSE
            static_file_label.log_residence_source := amc$change_file_attributes;
          IFEND;
          local_open_changed_file := TRUE;
        IFEND;

      = amc$ring_attributes =
        static_file_label.ring_attributes := file_attributes [i].ring_attributes;
        static_file_label.ring_attributes_source := amc$change_file_attributes;

      = amc$record_limit =
        static_file_label.record_limit := file_attributes [i].record_limit;
        static_file_label.record_limit_source := amc$change_file_attributes;

      = amc$statement_identifier =
        static_file_label.statement_identifier := file_attributes [i].statement_identifier;
        static_file_label.statement_identifier_source := amc$change_file_attributes;

      = amc$user_info =
        static_file_label.user_info := file_attributes [i].user_info;
        static_file_label.user_info_source := amc$change_file_attributes;

      ELSE
      CASEND;

    FOREND;

{ For reasons of compatibility, the specified keyword is split into the original file_contents and
{ file_structure components for storage in the file label; the single value of file_contents changes both
{ the file_contents and file_structure components in the label.  If an old value is specified for
{ file_contents (legible, list, object, screen) or file_structure (data, library, form, scl_include, etc.)
{ and the current values of file_contents and file_structure in the file_label represent one of the new
{ keywords, then the current values in the label are treated as a unit by the new value of file_contents
{ and/or file_structure; if the other parameter is not specified, the corresponding label field is set to
{ unknown.

    IF file_contents_specified THEN
      IF combined_keyword_specified OR NOT file_structure_specified THEN
        fsp$convert_file_contents (static_file_label.file_contents, static_file_label.file_structure,
              converted_file_contents, local_status);
        IF file_structure_specified OR NOT (((split_file_contents = fsc$unknown_contents) AND
              (split_file_structure = fsc$unknown_contents) AND
              (static_file_label.file_structure = fsc$data)) OR
              ((split_file_contents = fsc$list) AND (converted_file_contents = fsc$unknown_contents))) THEN
          IF combined_keyword_specified THEN
            IF file_structure_specified AND (specified_file_structure <> split_file_structure) THEN
              IF ((split_file_contents = fsc$list) AND (specified_file_structure = fsc$unknown_contents)) OR
                    ((split_file_contents = fsc$unknown_contents) AND (specified_file_structure = fsc$data))
                    THEN
                IF (NOT local_status.normal) AND (static_file_label.file_structure <>
                      specified_file_structure) THEN
                  bap$set_evaluated_file_abnormal (evaluated_file_reference, fse$file_structure_replaced,
                        '', static_file_label.file_structure, warning_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, specified_file_structure,
                        warning_status);
                IFEND;
                static_file_label.file_structure := specified_file_structure;
              ELSE
                bap$set_evaluated_file_abnormal (evaluated_file_reference, fse$file_structure_discarded, '',
                      specified_file_structure, warning_status);
                static_file_label.file_structure := split_file_structure;
              IFEND;
            ELSE
              IF (NOT local_status.normal) AND (static_file_label.file_structure <> split_file_structure)
                    THEN
                bap$set_evaluated_file_abnormal (evaluated_file_reference, fse$file_structure_replaced, '',
                      static_file_label.file_structure, warning_status);
                osp$append_status_parameter (osc$status_parameter_delimiter, split_file_structure,
                      warning_status);
              IFEND;
              static_file_label.file_structure := split_file_structure;
            IFEND;
          ELSEIF local_status.normal THEN
            fsp$convert_file_contents (split_file_contents, static_file_label.file_structure,
                  converted_file_contents, local_status);
            IF NOT local_status.normal THEN
              static_file_label.file_structure := fsc$unknown_contents;
            IFEND;
          IFEND;
        IFEND;
      ELSEIF file_structure_specified THEN
        static_file_label.file_structure := specified_file_structure;
      IFEND;
      static_file_label.file_contents := split_file_contents;
    ELSEIF file_structure_specified THEN
      fsp$convert_file_contents (static_file_label.file_contents, specified_file_structure,
            converted_file_contents, local_status);
      IF NOT local_status.normal AND (static_file_label.file_contents <> fsc$unknown_contents) THEN
        fsp$convert_file_contents (static_file_label.file_contents, static_file_label.file_structure,
              converted_file_contents, local_status);
        IF local_status.normal THEN
          bap$set_evaluated_file_abnormal (evaluated_file_reference, fse$file_contents_replaced, '',
                converted_file_contents, warning_status);
          static_file_label.file_contents := fsc$unknown_contents;
        IFEND;
      IFEND;
      static_file_label.file_structure := specified_file_structure;
    IFEND;

{ Save label

    local_system_file_label.file_previously_opened := file_previously_opened;
    local_system_file_label.static_label := NIL;
    fmp$put_label_attributes (static_file_label, local_system_file_label);
    IF local_system_file_label.static_label = NIL THEN
      static_label_size := #SIZE (fmt$static_label_header);
    ELSE
      RESET local_system_file_label.static_label;
      static_label_size := #SIZE (local_system_file_label.static_label^);
      NEXT label_header IN local_system_file_label.static_label;
    IFEND;

    IF object_information^.object^.cycle_device_class = rmc$mass_storage_device THEN

{ Check for a job routing label in the old label.

      RESET object_information^.object^.file_label;
      NEXT old_label_header IN object_information^.object^.file_label;
      IF (old_label_header^.job_routing_label_size > 0) AND
            (fsp$path_element (^evaluated_file_reference, 1)^ <> fsc$local) THEN

{ Append the job routing label of the old label to the new label.

        old_static_label_size := #SIZE (object_information^.object^.file_label^) -
              #SIZE (fmt$static_label_header) - old_label_header^.job_routing_label_size;
        IF old_static_label_size > 0 THEN
          NEXT seq_pointer: [[REP old_static_label_size OF cell]] IN
                object_information^.object^.file_label;
        IFEND;
        NEXT job_routing_label: [[REP old_label_header^.job_routing_label_size OF cell]] IN
              object_information^.object^.file_label;

        physical_file_label_size := #SIZE (pft$checksum) + static_label_size +
              old_label_header^.job_routing_label_size;
        generate_changed_file_label (changed_file_label, checksum_p, start_of_label_p);
        label_header^.job_routing_label_size := old_label_header^.job_routing_label_size;
        NEXT seq_pointer: [[REP label_header^.job_routing_label_size OF cell]] IN changed_file_label;
        seq_pointer^ := job_routing_label^;
      ELSE
        physical_file_label_size := #SIZE (pft$checksum) + static_label_size;
        generate_changed_file_label (changed_file_label, checksum_p, start_of_label_p);
      IFEND;
    ELSE
      label_header^.job_routing_label_size := 0;
      physical_file_label_size := #SIZE (pft$checksum) + static_label_size;
      generate_changed_file_label (changed_file_label, checksum_p, start_of_label_p);
    IFEND;

    pfp$compute_checksum (start_of_label_p, physical_file_label_size - #SIZE (pft$checksum),
          checksum_p^);

    IF fsp$path_element (^evaluated_file_reference, 1)^ = fsc$local THEN
      fmp$locate_cd_via_path_handle (evaluated_file_reference.path_handle_info.path_handle,
            {lock_path_table} TRUE, cycle_description, status);
      IF NOT status.normal THEN
        FREE changed_file_label IN osv$job_pageable_heap^;
        RETURN;
      IFEND;

      IF cycle_description^.system_file_label.static_label <> NIL THEN
        FREE cycle_description^.system_file_label.static_label IN osv$job_pageable_heap^;
      IFEND;
      cycle_description^.system_file_label.static_label := start_of_label_p;
      fmp$unlock_path_table;
    ELSE {permanent file}
      IF (object_information^.object^.job_environment_information <> NIL) AND
            object_information^.object^.job_environment_information^.cycle_attached THEN
        fmp$get_cycle_description (object_information^.resolved_path^, cycle_description, status);
        IF NOT status.normal THEN
          FREE changed_file_label IN osv$job_pageable_heap^;
          RETURN;
        IFEND;

        pfp$save_file_label (cycle_description^.apfid, start_of_label_p, pfc$control, status);
        IF NOT status.normal THEN
          FREE changed_file_label IN osv$job_pageable_heap^;
          fmp$unlock_path_table;
          RETURN;
        IFEND;

        IF cycle_description^.system_file_label.static_label <> NIL THEN
          FREE cycle_description^.system_file_label.static_label IN osv$job_pageable_heap^;
        IFEND;
        cycle_description^.system_file_label.static_label := start_of_label_p;
        fmp$unlock_path_table;
      ELSE { not attached }
        PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
        pfp$convert_fs_to_pft$path (evaluated_file_reference, pf_path^);
        pfi$convert_cycle_reference (evaluated_file_reference.cycle_reference, cycle_selector, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        password_selector.password_specified := pfc$default_password_option;
        pfp$r3_save_released_file_label (pf_path^, cycle_selector, TRUE {update_cycle_statistics},
              password_selector, changed_file_label, status);
        IF NOT status.normal THEN
          FREE changed_file_label IN osv$job_pageable_heap^;
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    open_changed_file := local_open_changed_file AND (static_file_label.file_organization IN
          amv$aam_file_organizations);

    IF status.normal AND NOT warning_status.normal THEN
      status := warning_status;
    IFEND;

  PROCEND fmp$change_file_attributes;

?? TITLE := '[XDCL] fmp$add_to_file_description' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$add_to_file_description
    (    file_identifier: amt$file_identifier;
         file_attributes: amt$add_to_attributes;
     VAR status: ost$status);

    TYPE
      fmt$attribute_set = set of amt$attribute_source;

    VAR
      attribute_validation_status: ost$status,
      bam_file_organizations: amt$file_organization_set,
      cl_path_handle: clt$path_handle,
      cycle_description: ^fmt$cycle_description,
      i: integer,
      i_string: ost$string,
      improper_attribute_key: boolean,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      file_limit_specified: boolean,
      label_header: ^fmt$static_label_header,
      one: amt$collate_table,
      p_cell: ^cell,
      precedence_set: fmt$attribute_set,
      ptr1: ^string (50000),
      ptr2: ^string (50000),
      system_file_label: bat$static_label_attributes,
      text: ost$name,
      two: amt$collate_table;

    status.normal := TRUE;
    attribute_validation_status.normal := TRUE;
    improper_attribute_key := FALSE;
    file_limit_specified := TRUE;

    bap$validate_file_identifier (file_identifier, file_instance, file_id_is_valid);
    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id, 'AMP$ADD_TO_FILE_DESCRIPTION',
            status);
      RETURN;
    IFEND;

    clp$check_name_for_path_handle (file_instance^.local_file_name, cl_path_handle);

    fmp$locate_cd_via_path_handle (cl_path_handle.regular_handle, {lock_path_table} TRUE, cycle_description,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT cycle_description^.attached_file THEN
      fmp$unlock_path_table;
      amp$set_file_instance_abnormal (file_identifier, ame$not_old_file, amc$add_to_file_description_req, '',
            status);
      RETURN;
    IFEND;

    IF cycle_description^.system_file_label.file_previously_opened THEN
      fmp$unlock_path_table;
      amp$set_file_instance_abnormal (file_identifier, ame$not_open_new, amc$add_to_file_description_req, '',
            status);
      RETURN;
    IFEND;

    fmp$get_label_attributes (^cycle_description^.system_file_label, system_file_label, status);

    bam_file_organizations := $amt$file_organization_set [amc$sequential, amc$byte_addressable];
    precedence_set := $fmt$attribute_set [amc$access_method_default, amc$undefined_attribute];
    text := osc$null_name;

    FOR i := 1 TO UPPERBOUND (file_attributes) DO
      CASE file_attributes [i].key OF

      = amc$character_conversion =

        IF (system_file_label.character_conversion_source IN precedence_set) THEN
          system_file_label.character_conversion := file_attributes [i].character_conversion;
          system_file_label.character_conversion_source := amc$add_to_file_description;
        ELSE
          text := 'CHARACTER_CONVERSION';
        IFEND;


      = amc$file_contents =

        IF (system_file_label.file_contents_source IN precedence_set) THEN
          system_file_label.file_contents := file_attributes [i].file_contents;
          system_file_label.file_contents_source := amc$add_to_file_description;
        ELSE
          text := 'FILE_CONTENTS';
        IFEND;

      = amc$file_limit =

        IF (system_file_label.file_limit_source IN precedence_set) THEN
          system_file_label.file_limit := file_attributes [i].file_limit;
          system_file_label.file_limit_source := amc$add_to_file_description;
          file_limit_specified := TRUE;
        ELSE
          text := 'FILE_LIMIT';
        IFEND;

      = amc$file_processor =

        IF (system_file_label.file_processor_source IN precedence_set) THEN
          system_file_label.file_processor := file_attributes [i].file_processor;
          system_file_label.file_processor_source := amc$add_to_file_description;
        ELSE
          text := 'FILE_PROCESSOR';
        IFEND;

      = amc$file_structure =

        IF (system_file_label.file_structure_source IN precedence_set) THEN
          system_file_label.file_structure := file_attributes [i].file_structure;
          system_file_label.file_structure_source := amc$add_to_file_description;
        ELSE
          text := 'FILE_STRUCTURE';
        IFEND;

      = amc$forced_write =

        IF (system_file_label.forced_write_source IN precedence_set) THEN
          system_file_label.forced_write := file_attributes [i].forced_write;
          system_file_label.forced_write_source := amc$add_to_file_description;
        ELSE
          text := 'FORCED_WRITE';
        IFEND;

      = amc$internal_code =

        IF (system_file_label.internal_code_source IN precedence_set) THEN
          system_file_label.internal_code := file_attributes [i].internal_code;
          system_file_label.internal_code_source := amc$add_to_file_description;
        ELSE
          text := 'INTERNAL_CODE';
        IFEND;

      = amc$line_number =

        IF (system_file_label.line_number_source IN precedence_set) THEN
          system_file_label.line_number := file_attributes [i].line_number;
          system_file_label.line_number_source := amc$add_to_file_description;
        ELSE
          text := 'LINE_NUMBER';
        IFEND;

      = amc$max_block_length =

        IF NOT (system_file_label.file_organization IN bam_file_organizations) THEN
          IF (system_file_label.max_block_length_source IN precedence_set) THEN
            system_file_label.max_block_length := file_attributes [i].max_block_length;
            system_file_label.max_block_length_source := amc$add_to_file_description;
          ELSE
            text := 'MAX_BLOCK_LENGTH';
          IFEND;
        ELSE
          improper_attribute_key := TRUE;
        IFEND;

      = amc$max_record_length =

        IF NOT (system_file_label.file_organization IN bam_file_organizations) THEN
          IF (system_file_label.max_record_length_source IN precedence_set) THEN
            system_file_label.max_record_length := file_attributes [i].max_record_length;
            system_file_label.max_record_length_source := amc$add_to_file_description;
          ELSE
            text := 'MAX_RECORD_LENGTH';
          IFEND;
        ELSE
          improper_attribute_key := TRUE;
        IFEND;

      = amc$min_block_length =

        IF (system_file_label.min_block_length_source IN precedence_set) THEN
          system_file_label.min_block_length := file_attributes [i].min_block_length;
          system_file_label.min_block_length_source := amc$add_to_file_description;
        ELSE
          text := 'MIN_BLOCK_LENGTH';
        IFEND;

      = amc$min_record_length =

        IF (system_file_label.min_record_length_source IN precedence_set) THEN
          system_file_label.min_record_length := file_attributes [i].min_record_length;
          system_file_label.min_record_length_source := amc$add_to_file_description;
        ELSE
          text := 'MIN_RECORD_LENGTH';
        IFEND;

      = amc$null_attribute =

        ;

      = amc$padding_character =

        IF (system_file_label.padding_character_source IN precedence_set) THEN
          system_file_label.padding_character := file_attributes [i].padding_character;
          system_file_label.padding_character_source := amc$add_to_file_description;
        ELSE
          text := 'PADDING_CHARACTER';
        IFEND;

      = amc$page_format =

        IF (system_file_label.page_format_source IN precedence_set) THEN
          system_file_label.page_format := file_attributes [i].page_format;
          system_file_label.page_format_source := amc$add_to_file_description;
        ELSE
          text := 'PAGE_FORMAT';
        IFEND;

      = amc$page_length =

        IF (system_file_label.page_length_source IN precedence_set) THEN
          system_file_label.page_length := file_attributes [i].page_length;
          system_file_label.page_length_source := amc$add_to_file_description;
        ELSE
          text := 'PAGE_LENGTH';
        IFEND;

      = amc$page_width =

        IF (system_file_label.page_width_source IN precedence_set) THEN
          system_file_label.page_width := file_attributes [i].page_width;
          system_file_label.page_width_source := amc$add_to_file_description;
        ELSE
          text := 'PAGE_WIDTH';
        IFEND;


      = amc$record_type =

        IF NOT (system_file_label.file_organization IN bam_file_organizations) THEN
          IF (system_file_label.record_type_source IN precedence_set) THEN
            system_file_label.record_type := file_attributes [i].record_type;
            system_file_label.record_type_source := amc$add_to_file_description;
          ELSE
            text := 'RECORD_TYPE';
          IFEND;
        ELSE
          improper_attribute_key := TRUE;
        IFEND;

      = amc$statement_identifier =

        IF (system_file_label.statement_identifier_source IN precedence_set) THEN
          system_file_label.statement_identifier := file_attributes [i].statement_identifier;
          system_file_label.statement_identifier_source := amc$add_to_file_description;
        ELSE
          text := 'STATEMENT_IDENTIFIER';
        IFEND;


      = amc$user_info =

        IF (system_file_label.user_info_source IN precedence_set) THEN
          system_file_label.user_info := file_attributes [i].user_info;
          system_file_label.user_info_source := amc$add_to_file_description;
        ELSE
          text := 'USER_INFO';
        IFEND;

      = amc$vertical_print_density =

        IF (system_file_label.vertical_print_density_source IN precedence_set) THEN
          system_file_label.vertical_print_density := file_attributes [i].vertical_print_density;
          system_file_label.vertical_print_density_source := amc$add_to_file_description;
        ELSE
          text := 'VERTICAL_PRINT_DENSITY';
        IFEND;


{ The following attributes are only used to describe files which
{ are accessed with the Advanced Access Method(AAM).  The
{ documentation of the AAM attributes are found in the AAM ERS.


      = amc$average_record_length =

        IF (system_file_label.average_record_length_source IN precedence_set) THEN
          system_file_label.average_record_length := file_attributes [i].average_record_length;
          system_file_label.average_record_length_source := amc$add_to_file_description;
        ELSE
          text := 'AVERAGE_RECORD_LENGTH';
        IFEND;

      = amc$collate_table =

        IF (file_attributes [i].collate_table = NIL) THEN
          clp$convert_integer_to_string (i, 10, FALSE, i_string, status);
          fmp$unlock_path_table;
          amp$set_file_instance_abnormal (file_identifier, ame$improper_file_attrib_value,
                amc$add_to_file_description_req, 'FILE_ATTRIBUTES', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, i_string.value (1, i_string.size),
                status);
          RETURN;
        IFEND;

        IF (system_file_label.collate_table_source IN precedence_set) THEN
          system_file_label.collate_table := file_attributes [i].collate_table^;
          system_file_label.collate_table_source := amc$add_to_file_description;
        ELSE
          one := system_file_label.collate_table;
          two := file_attributes [i].collate_table^;
          p_cell := ^one;
          ptr1 := p_cell;
          p_cell := ^two;
          ptr2 := p_cell;
          IF (ptr1^ (1, #SIZE (one)) <> ptr2^ (1, #SIZE (two))) THEN
            text := 'COLLATE_TABLE';
          IFEND;
        IFEND;

      = amc$data_padding =

        IF (system_file_label.data_padding_source IN precedence_set) THEN
          system_file_label.data_padding := file_attributes [i].data_padding;
          system_file_label.data_padding_source := amc$add_to_file_description;
        ELSE
          text := 'DATA_PADDING';
        IFEND;

      = amc$embedded_key =

        IF (system_file_label.embedded_key_source IN precedence_set) THEN
          system_file_label.embedded_key := file_attributes [i].embedded_key;
          system_file_label.embedded_key_source := amc$add_to_file_description;
        ELSE
          text := 'EMBEDDED_KEY';
        IFEND;

      = amc$estimated_record_count =

        IF (system_file_label.estimated_record_count_source IN precedence_set) THEN
          system_file_label.estimated_record_count := file_attributes [i].estimated_record_count;
          system_file_label.estimated_record_count_source := amc$add_to_file_description;
        ELSE
          text := 'ESTIMATED_RECORD_COUNT';
        IFEND;

      = amc$index_levels =

        IF (system_file_label.index_levels_source IN precedence_set) THEN
          system_file_label.index_levels := file_attributes [i].index_levels;
          system_file_label.index_levels_source := amc$add_to_file_description;
        ELSE
          text := 'INDEX_LEVELS';
        IFEND;

      = amc$index_padding =

        IF (system_file_label.index_padding_source IN precedence_set) THEN
          system_file_label.index_padding := file_attributes [i].index_padding;
          system_file_label.index_padding_source := amc$add_to_file_description;
        ELSE
          text := 'INDEX_PADDING';
        IFEND;

      = amc$key_length =

        IF (system_file_label.key_length_source IN precedence_set) THEN
          system_file_label.key_length := file_attributes [i].key_length;
          system_file_label.key_length_source := amc$add_to_file_description;
        ELSE
          text := 'KEY_LENGTH';
        IFEND;

      = amc$key_position =

        IF (system_file_label.key_position_source IN precedence_set) THEN
          system_file_label.key_position := file_attributes [i].key_position;
          system_file_label.key_position_source := amc$add_to_file_description;
        ELSE
          text := 'KEY_POSITION';
        IFEND;

      = amc$key_type =

        IF (system_file_label.key_type_source IN precedence_set) THEN
          system_file_label.key_type := file_attributes [i].key_type;
          system_file_label.key_type_source := amc$add_to_file_description;
        ELSE
          text := 'KEY_TYPE';
        IFEND;

      = amc$log_residence =

        IF (system_file_label.log_residence_source IN precedence_set) THEN
          IF file_attributes [i].log_residence <> NIL THEN
            system_file_label.log_residence := file_attributes [i].log_residence^;
            system_file_label.log_residence_source := amc$add_to_file_description;
          IFEND;
        ELSE
          text := 'LOG_RESIDENCE';
        IFEND;

      = amc$record_limit =

        IF (system_file_label.record_limit_source IN precedence_set) THEN
          system_file_label.record_limit := file_attributes [i].record_limit;
          system_file_label.record_limit_source := amc$add_to_file_description;
        ELSE
          text := 'RECORD_LIMIT';
        IFEND;

      = amc$records_per_block =

        IF (system_file_label.records_per_block_source IN precedence_set) THEN
          system_file_label.records_per_block := file_attributes [i].records_per_block;
          system_file_label.records_per_block_source := amc$add_to_file_description;
        ELSE
          text := 'RECORDS_PER_BLOCK';
        IFEND;

      ELSE
        improper_attribute_key := TRUE;
      CASEND;

      IF improper_attribute_key THEN
        clp$convert_integer_to_string (i, 10, FALSE, i_string, status);
        fmp$unlock_path_table;
        amp$set_file_instance_abnormal (file_identifier, ame$improper_file_attrib_key,
              amc$add_to_file_description_req, 'FILE_ATTRIBUTES', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, i_string.value (1, i_string.size),
              status);
        RETURN;
      IFEND;

      IF text <> osc$null_name THEN
        IF attribute_validation_status.normal THEN
          fmp$unlock_path_table;
          amp$set_file_instance_abnormal (file_identifier, ame$attrib_already_defined,
                amc$add_to_file_description_req, text, attribute_validation_status);
        ELSE
          osp$append_status_parameter (',', text, attribute_validation_status);
        IFEND;
        text := osc$null_name;
      IFEND;
    FOREND;
    IF NOT attribute_validation_status.normal THEN
      status := attribute_validation_status;
      RETURN;
    IFEND;

    IF file_limit_specified AND (cycle_description^.device_class = rmc$mass_storage_device) THEN
      dmp$set_file_limit (cycle_description^.system_file_id, system_file_label.file_limit, status);
      IF NOT status.normal THEN
        fmp$unlock_path_table;
        RETURN;
      IFEND;
    IFEND;

    IF cycle_description^.system_file_label.static_label <> NIL THEN
      RESET cycle_description^.system_file_label.static_label;
      NEXT label_header IN cycle_description^.system_file_label.static_label;
      system_file_label.ring_attributes_source := label_header^.ring_attributes_source;
      system_file_label.ring_attributes := label_header^.ring_attributes;
      FREE cycle_description^.system_file_label.static_label IN osv$job_pageable_heap^;
    IFEND;

{   The call to fmp$put_label_attributes is preceded by setting
{ file_previously_opened to TRUE so that fmp$put_label_attributes will place
{ the ring_attributes in the static_label.  File_previously_opened is then set
{ back to FALSE, and is later set to TRUE in bap$end_new_open_processing when
{ the label is saved after the open has finished.
{   The fact that the static_label has a value of TRUE for
{ file_previously_opened is not a problem because all routines that check
{ file_previously_opened look at the value in the system_file_label.

    cycle_description^.system_file_label.file_previously_opened := TRUE;
    fmp$put_label_attributes (system_file_label, cycle_description^.system_file_label);
    cycle_description^.system_file_label.file_previously_opened := FALSE;
    IF (cycle_description^.system_file_label.static_label <> NIL) THEN
      RESET cycle_description^.system_file_label.static_label;
      NEXT label_header IN cycle_description^.system_file_label.static_label;
      IF cycle_description^.device_class = rmc$mass_storage_device THEN
        label_header^.job_routing_label_size := cycle_description^.job_routing_label_length;
      ELSE
        label_header^.job_routing_label_size := 0;
      IFEND;
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$add_to_file_description;

?? TITLE := 'extract_dynamic_attributes', EJECT ??

  PROCEDURE extract_dynamic_attributes
    (    job_environment_information_p: ^fst$job_environment_information;
     VAR dynamic_label: {input/output} bat$dynamic_label_attributes);

    IF job_environment_information_p <> NIL THEN
      IF job_environment_information_p^.attachment_options_sources.access_modes_source = amc$file_command THEN
        #UNCHECKED_CONVERSION (job_environment_information_p^.setfa_access_modes, dynamic_label.access_mode);
      IFEND;

      IF job_environment_information_p^.attachment_options_sources.error_exit_name_source =
            amc$file_command THEN
        dynamic_label.error_exit_name := job_environment_information_p^.error_exit_procedure_name;
        dynamic_label.error_exit_name_source := amc$file_command;
      IFEND;

      IF job_environment_information_p^.attachment_options_sources.error_limit_source = amc$file_command THEN
        dynamic_label.error_limit := job_environment_information_p^.error_limit;
        dynamic_label.error_limit_source := amc$file_command;
      IFEND;

      IF job_environment_information_p^.attachment_options_sources.label_exit_name_source =
            amc$file_command THEN
        dynamic_label.label_exit_name := job_environment_information_p^.label_exit_procedure_name;
        dynamic_label.label_exit_name_source := amc$file_command;
      IFEND;

      IF job_environment_information_p^.attachment_options_sources.message_control_source =
            amc$file_command THEN
        dynamic_label.message_control := job_environment_information_p^.message_control;
        dynamic_label.message_control_source := amc$file_command;
      IFEND;

      IF job_environment_information_p^.attachment_options_sources.open_position_source =
            amc$file_command THEN
        dynamic_label.open_position := job_environment_information_p^.open_position;
        dynamic_label.open_position_source := amc$file_command;
      IFEND;
    IFEND;

  PROCEND extract_dynamic_attributes;
MODEND fmm$file_attribute_manager;
*DECK DECK=FMM$FILE_LABEL_FUNCTIONS EXPAND=TRUE
*copyc osd$default_pragmats
MODULE fmm$file_label_functions;

*copyc fmh$file_label_functions
?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
*copyc ame$attribute_validation_errors
*copyc ame$lfn_program_actions
*copyc amt$file_reference
*copyc bat$static_label_attributes
*copyc fmc$unique_label_id
*copyc fmt$cycle_description
*copyc fmt$file_attribute_keys
*copyc fmt$static_label_header
*copyc fmt$static_label_item
*copyc fmt$system_file_label
*copyc ose$heap_full_exceptions
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc i#current_sequence_position
*copyc i#move
*copyc fsp$expand_file_label
*copyc osp$set_status_abnormal

*copyc fmv$default_file_attributes
*copyc fmv$static_label_header
*copyc fmv$system_file_attributes
*copyc osv$job_pageable_heap

  TYPE
    fmt$file_source = set of amt$attribute_source;

  VAR
    space_selector: [STATIC, READ, oss$job_paged_literal] packed array
      [0 .. 255] of boolean := [REP 32 of FALSE, TRUE, REP 223 of FALSE],
    unspecified_sources: [STATIC, READ, oss$job_paged_literal] fmt$file_source := $fmt$file_source
      [amc$undefined_attribute, amc$access_method_default];


?? TITLE := '[XDCL] fmp$put_label_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$put_label_attributes (static_label_attributes:
    bat$static_label_attributes;
    VAR system_file_label: fmt$system_file_label);

    VAR
      i: integer,
      seq_size,
      static_label_size: integer,
      stack_seq: ^SEQ ( * ),
      header: ^fmt$static_label_header,
      p_cell: ^cell,
      p_specified_string: ^string (64000),
      p_default_string: ^string (64000),
      default_file_attributes: bat$static_label_attributes,
      attribute_key: fmt$file_attribute_keys,
      static_label_item: ^fmt$static_label_item,
      name_index: 1 .. 32,
      path_index: 1 .. 257,
      ignore_found: boolean,
      str: ^string ( * );

    PROCEDURE [INLINE] put_entry_point_reference (name: pmt$program_name;
          path: amt$file_reference);

      #SCAN (space_selector, name, name_index, ignore_found);
      static_label_item^.entry_point_name_length := name_index - 1;
      #SCAN (space_selector, path, path_index, ignore_found);
      static_label_item^.entry_point_path_length := path_index - 1;
      NEXT str: [static_label_item^.entry_point_name_length] IN stack_seq;
      str^ (1, static_label_item^.entry_point_name_length) := name;
      IF path_index > 1 THEN
        NEXT str: [static_label_item^.entry_point_path_length] IN stack_seq;
        str^ (1, static_label_item^.entry_point_path_length) := path;
      IFEND;
    PROCEND put_entry_point_reference;

    PROCEDURE [INLINE] put_name (name: pmt$program_name);

      #SCAN (space_selector, name, name_index, ignore_found);
      static_label_item^.name_length := name_index - 1;
      NEXT str: [static_label_item^.name_length] IN stack_seq;
      str^ (1, static_label_item^.name_length) := name;
    PROCEND put_name;

    p_cell := ^static_label_attributes;
    p_specified_string := p_cell;
    IF fmv$default_file_attributes = NIL THEN
      p_cell := ^fmv$system_file_attributes.static_label;
    ELSE
      p_cell := fmv$default_file_attributes;
    IFEND;
    p_default_string := p_cell;
    IF p_specified_string^ (1, #SIZE (bat$static_label_attributes)) <>
          p_default_string^ (1, #SIZE (bat$static_label_attributes)) THEN
      seq_size := (#SIZE(amt$entry_point_reference) * fmc$highest_current_attribute)
            + #SIZE(fmt$static_label_header);
      PUSH stack_seq: [[REP seq_size OF cell]];
      RESET stack_seq;
      NEXT header IN stack_seq;
      header^ := fmv$static_label_header;
      IF fmv$default_file_attributes = NIL THEN
        default_file_attributes := fmv$system_file_attributes.static_label;
      ELSE
        default_file_attributes := fmv$default_file_attributes^;
      IFEND;
      FOR attribute_key := LOWERBOUND (header^. attribute_present) TO
          fmc$highest_current_attribute DO
        CASE attribute_key OF
        = fmc$block_type =
          IF NOT(static_label_attributes.block_type_source IN
                unspecified_sources) OR (static_label_attributes.block_type <>
                default_file_attributes.block_type) THEN
            header^.attribute_present [fmc$block_type] := TRUE;
            header^.highest_attribute_present := fmc$block_type;
            NEXT static_label_item: [fmc$block_type] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  block_type_source;
            static_label_item^.block_type := static_label_attributes.
                  block_type;
          IFEND;
        = fmc$character_conversion =
          IF NOT(static_label_attributes.character_conversion_source IN
                unspecified_sources) OR (static_label_attributes.character_conversion <>
                default_file_attributes.character_conversion) THEN
            header^.attribute_present [fmc$character_conversion] := TRUE;
            header^.highest_attribute_present := fmc$character_conversion;
            NEXT static_label_item: [fmc$character_conversion] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  character_conversion_source;
            static_label_item^.character_conversion := static_label_attributes.
                  character_conversion;
          IFEND;
        = fmc$clear_space =
          IF NOT(static_label_attributes.clear_space_source IN
                unspecified_sources) OR (static_label_attributes.clear_space <>
                default_file_attributes.clear_space) THEN
            header^.attribute_present [fmc$clear_space] := TRUE;
            header^.highest_attribute_present := fmc$clear_space;
            NEXT static_label_item: [fmc$clear_space] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  clear_space_source;
            static_label_item^.clear_space := static_label_attributes.
                  clear_space;
          IFEND;
        = fmc$file_access_procedure =
          IF NOT(static_label_attributes.file_access_procedure_source IN
                unspecified_sources) OR (static_label_attributes.file_access_procedure <>
                default_file_attributes.file_access_procedure) THEN
            header^.attribute_present [fmc$file_access_procedure] := TRUE;
            header^.highest_attribute_present := fmc$file_access_procedure;
            NEXT static_label_item: [fmc$file_access_procedure] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  file_access_procedure_source;
            put_entry_point_reference (static_label_attributes.
                  file_access_procedure, osc$null_name);
          IFEND;
        = fmc$file_contents =
          IF NOT(static_label_attributes.file_contents_source IN
                unspecified_sources) OR (static_label_attributes.file_contents <>
                default_file_attributes.file_contents) THEN
            header^.attribute_present [fmc$file_contents] := TRUE;
            header^.highest_attribute_present := fmc$file_contents;
            NEXT static_label_item: [fmc$file_contents] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  file_contents_source;
            put_name (static_label_attributes.file_contents);
          IFEND;
        = fmc$file_limit =
          IF NOT(static_label_attributes.file_limit_source IN
                unspecified_sources) OR (static_label_attributes.file_limit <>
                default_file_attributes.file_limit) THEN
            header^.attribute_present [fmc$file_limit] := TRUE;
            header^.highest_attribute_present := fmc$file_limit;
            NEXT static_label_item: [fmc$file_limit] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  file_limit_source;
            static_label_item^.integer_value := static_label_attributes.
                  file_limit;
          IFEND;
        = fmc$file_organization =
          IF NOT(static_label_attributes.file_organization_source IN
                unspecified_sources) OR (static_label_attributes.file_organization <>
                default_file_attributes.file_organization) THEN
            header^.attribute_present [fmc$file_organization] := TRUE;
            header^.highest_attribute_present := fmc$file_organization;
            NEXT static_label_item: [fmc$file_organization] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  file_organization_source;
            static_label_item^.file_organization := static_label_attributes.
                  file_organization;
          IFEND;
        = fmc$file_processor =
          IF NOT(static_label_attributes.file_processor_source IN
                unspecified_sources) OR (static_label_attributes.file_processor <>
                default_file_attributes.file_processor) THEN
            header^.attribute_present [fmc$file_processor] := TRUE;
            header^.highest_attribute_present := fmc$file_processor;
            NEXT static_label_item: [fmc$file_processor] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  file_processor_source;
            put_name (static_label_attributes.file_processor);
          IFEND;
        = fmc$file_structure =
          IF NOT(static_label_attributes.file_structure_source IN
                unspecified_sources) OR (static_label_attributes.file_structure <>
                default_file_attributes.file_structure) THEN
            header^.attribute_present [fmc$file_structure] := TRUE;
            header^.highest_attribute_present := fmc$file_structure;
            NEXT static_label_item: [fmc$file_structure] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  file_structure_source;
            put_name (static_label_attributes.file_structure);
          IFEND;
        = fmc$forced_write =
          IF NOT(static_label_attributes.forced_write_source IN
                unspecified_sources) OR (static_label_attributes.forced_write <>
                default_file_attributes.forced_write) THEN
            header^.attribute_present [fmc$forced_write] := TRUE;
            header^.highest_attribute_present := fmc$forced_write;
            NEXT static_label_item: [fmc$forced_write] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  forced_write_source;
            static_label_item^.forced_write := static_label_attributes.
                  forced_write;
          IFEND;
        = fmc$internal_code =
          IF NOT(static_label_attributes.internal_code_source IN
                unspecified_sources) OR (static_label_attributes.internal_code <>
                default_file_attributes.internal_code) THEN
            header^.attribute_present [fmc$internal_code] := TRUE;
            header^.highest_attribute_present := fmc$internal_code;
            NEXT static_label_item: [fmc$internal_code] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  internal_code_source;
            static_label_item^.internal_code := static_label_attributes.
                  internal_code;
          IFEND;
        = fmc$label_type =
          IF NOT(static_label_attributes.label_type_source IN
                unspecified_sources) OR (static_label_attributes.label_type <>
                default_file_attributes.label_type) THEN
            header^.attribute_present [fmc$label_type] := TRUE;
            header^.highest_attribute_present := fmc$label_type;
            NEXT static_label_item: [fmc$label_type] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  label_type_source;
            static_label_item^.label_type := static_label_attributes.
                  label_type;
          IFEND;
        = fmc$line_number =
          IF NOT(static_label_attributes.line_number_source IN
                unspecified_sources) OR (static_label_attributes.line_number <>
                default_file_attributes.line_number) THEN
            header^.attribute_present [fmc$line_number] := TRUE;
            header^.highest_attribute_present := fmc$line_number;
            NEXT static_label_item: [fmc$line_number] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  line_number_source;
            static_label_item^.line_number := static_label_attributes.
                  line_number;
          IFEND;
        = fmc$max_block_length =
          IF NOT(static_label_attributes.max_block_length_source IN
                unspecified_sources) OR (static_label_attributes.max_block_length <>
                default_file_attributes.max_block_length) THEN
            header^.attribute_present [fmc$max_block_length] := TRUE;
            header^.highest_attribute_present := fmc$max_block_length;
            NEXT static_label_item: [fmc$max_block_length] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  max_block_length_source;
            static_label_item^.integer_value := static_label_attributes.
                  max_block_length;
          IFEND;
        = fmc$max_record_length =
          IF NOT(static_label_attributes.max_record_length_source IN
                unspecified_sources) OR (static_label_attributes.max_record_length <>
                default_file_attributes.max_record_length) THEN
            header^.attribute_present [fmc$max_record_length] := TRUE;
            header^.highest_attribute_present := fmc$max_record_length;
            NEXT static_label_item: [fmc$max_record_length] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  max_record_length_source;
            static_label_item^.integer_value := static_label_attributes.
                  max_record_length;
          IFEND;
        = fmc$min_block_length =
          IF NOT(static_label_attributes.min_block_length_source IN
                unspecified_sources) OR (static_label_attributes.min_block_length <>
                default_file_attributes.min_block_length) THEN
            header^.attribute_present [fmc$min_block_length] := TRUE;
            header^.highest_attribute_present := fmc$min_block_length;
            NEXT static_label_item: [fmc$min_block_length] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  min_block_length_source;
            static_label_item^.integer_value := static_label_attributes.
                  min_block_length;
          IFEND;
        = fmc$min_record_length =
          IF NOT(static_label_attributes.min_record_length_source IN
                unspecified_sources) OR (static_label_attributes.min_record_length <>
                default_file_attributes.min_record_length) THEN
            header^.attribute_present [fmc$min_record_length] := TRUE;
            header^.highest_attribute_present := fmc$min_record_length;
            NEXT static_label_item: [fmc$min_record_length] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  min_record_length_source;
            static_label_item^.integer_value := static_label_attributes.
                  min_record_length;
          IFEND;
        = fmc$padding_character =
          IF NOT(static_label_attributes.padding_character_source IN
                unspecified_sources) OR (static_label_attributes.padding_character <>
                default_file_attributes.padding_character) THEN
            header^.attribute_present [fmc$padding_character] := TRUE;
            header^.highest_attribute_present := fmc$padding_character;
            NEXT static_label_item: [fmc$padding_character] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  padding_character_source;
            static_label_item^.padding_character := static_label_attributes.
                  padding_character;
          IFEND;
        = fmc$page_format =
          IF NOT(static_label_attributes.page_format_source IN
                unspecified_sources) OR (static_label_attributes.page_format <>
                default_file_attributes.page_format) THEN
            header^.attribute_present [fmc$page_format] := TRUE;
            header^.highest_attribute_present := fmc$page_format;
            NEXT static_label_item: [fmc$page_format] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  page_format_source;
            static_label_item^.page_format := static_label_attributes.
                  page_format;
          IFEND;
        = fmc$page_length =
          IF NOT(static_label_attributes.page_length_source IN
                unspecified_sources) OR (static_label_attributes.page_length <>
                default_file_attributes.page_length) THEN
            header^.attribute_present [fmc$page_length] := TRUE;
            header^.highest_attribute_present := fmc$page_length;
            NEXT static_label_item: [fmc$page_length] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  page_length_source;
            static_label_item^.integer_value := static_label_attributes.
                  page_length;
          IFEND;
        = fmc$page_width =
          IF NOT(static_label_attributes.page_width_source IN
                unspecified_sources) OR (static_label_attributes.page_width <>
                default_file_attributes.page_width) THEN
            header^.attribute_present [fmc$page_width] := TRUE;
            header^.highest_attribute_present := fmc$page_width;
            NEXT static_label_item: [fmc$page_width] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  page_width_source;
            static_label_item^.integer_value := static_label_attributes.
                  page_width;
          IFEND;
        = fmc$preset_value =
          IF NOT(static_label_attributes.preset_value_source IN
                unspecified_sources) OR (static_label_attributes.preset_value <>
                default_file_attributes.preset_value) THEN
            header^.attribute_present [fmc$preset_value] := TRUE;
            header^.highest_attribute_present := fmc$preset_value;
            NEXT static_label_item: [fmc$preset_value] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  preset_value_source;
            static_label_item^.integer_value := static_label_attributes.
                  preset_value;
          IFEND;
        = fmc$record_delimiting_character =
          IF NOT(static_label_attributes.record_delimiting_char_source IN
                unspecified_sources) OR (static_label_attributes.record_delimiting_character <>
                default_file_attributes.record_delimiting_character) THEN
            header^.attribute_present [fmc$record_delimiting_character] := TRUE;
            header^.highest_attribute_present := fmc$record_delimiting_character;
            NEXT static_label_item: [fmc$record_delimiting_character] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  record_delimiting_char_source;
            static_label_item^.record_delimiting_character := static_label_attributes.
                  record_delimiting_character;
          IFEND;
        = fmc$record_type =
          IF NOT(static_label_attributes.record_type_source IN
                unspecified_sources) OR (static_label_attributes.record_type <>
                default_file_attributes.record_type) THEN
            header^.attribute_present [fmc$record_type] := TRUE;
            header^.highest_attribute_present := fmc$record_type;
            NEXT static_label_item: [fmc$record_type] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  record_type_source;
            static_label_item^.record_type := static_label_attributes.
                  record_type;
          IFEND;
        = fmc$ring_attributes =
          IF NOT(static_label_attributes.ring_attributes_source IN
                unspecified_sources) OR (static_label_attributes.ring_attributes <>
                default_file_attributes.ring_attributes) THEN
            header^.attribute_present [fmc$ring_attributes] := TRUE;
            header^.highest_attribute_present := fmc$ring_attributes;
          IFEND;
          { ring_attributes are stored in the header - see below, after FOR loop }
        = fmc$statement_identifier =
          IF NOT(static_label_attributes.statement_identifier_source IN
                unspecified_sources) OR (static_label_attributes.statement_identifier <>
                default_file_attributes.statement_identifier) THEN
            header^.attribute_present [fmc$statement_identifier] := TRUE;
            header^.highest_attribute_present := fmc$statement_identifier;
            NEXT static_label_item: [fmc$statement_identifier] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  statement_identifier_source;
            static_label_item^.statement_identifier := static_label_attributes.
                  statement_identifier;
          IFEND;
        = fmc$user_info =
          IF NOT(static_label_attributes.user_info_source IN
                unspecified_sources) OR (static_label_attributes.user_info <>
                default_file_attributes.user_info) THEN
            header^.attribute_present [fmc$user_info] := TRUE;
            header^.highest_attribute_present := fmc$user_info;
            NEXT static_label_item: [fmc$user_info] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  user_info_source;
            static_label_item^.user_info_present := TRUE;
            NEXT str: [32] IN stack_seq;
            str^ (1, 32) := static_label_attributes.user_info;
          IFEND;
        = fmc$vertical_print_density =
          IF NOT(static_label_attributes.vertical_print_density_source IN
                unspecified_sources) OR (static_label_attributes.vertical_print_density <>
                default_file_attributes.vertical_print_density) THEN
            header^.attribute_present [fmc$vertical_print_density] := TRUE;
            header^.highest_attribute_present := fmc$vertical_print_density;
            NEXT static_label_item: [fmc$vertical_print_density] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  vertical_print_density_source;
            static_label_item^.integer_value := static_label_attributes.
                  vertical_print_density;
          IFEND;
        = fmc$average_record_length =
          IF NOT(static_label_attributes.average_record_length_source IN
                unspecified_sources) OR (static_label_attributes.average_record_length <>
                default_file_attributes.average_record_length) THEN
            header^.attribute_present [fmc$average_record_length] := TRUE;
            header^.highest_attribute_present := fmc$average_record_length;
            NEXT static_label_item: [fmc$average_record_length] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  average_record_length_source;
            static_label_item^.integer_value := static_label_attributes.
                  average_record_length;
          IFEND;
        = fmc$collate_table =
          p_cell := ^static_label_attributes.collate_table;
          p_specified_string := p_cell;
          p_cell := ^default_file_attributes.collate_table;
          p_default_string := p_cell;
          IF NOT(static_label_attributes.collate_table_source IN
                unspecified_sources) OR (p_specified_string^ (1, #SIZE (amt$collate_table)) <>
                p_default_string^ (1, #SIZE (amt$collate_table))) THEN
            header^.attribute_present [fmc$collate_table] := TRUE;
            header^.highest_attribute_present := fmc$collate_table;
            NEXT static_label_item: [fmc$collate_table] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  collate_table_source;
            static_label_item^.collate_table := static_label_attributes.
                  collate_table;
          IFEND;
        = fmc$collate_table_name =
          IF NOT(static_label_attributes.collate_table_name_source IN
                unspecified_sources) OR (static_label_attributes.collate_table_name <>
                default_file_attributes.collate_table_name) THEN
            header^.attribute_present [fmc$collate_table_name] := TRUE;
            header^.highest_attribute_present := fmc$collate_table_name;
            NEXT static_label_item: [fmc$collate_table_name] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  collate_table_name_source;
            put_entry_point_reference (static_label_attributes.collate_table_name,
                  osc$null_name);
          IFEND;
        = fmc$compression_procedure_name =
          IF NOT(static_label_attributes.compression_proc_name_source IN
                unspecified_sources) OR (static_label_attributes.
                compression_procedure_name <> fmv$system_file_attributes.
                static_label.compression_procedure_name) THEN
            header^.attribute_present [fmc$compression_procedure_name] :=
                  TRUE;
            header^.highest_attribute_present := fmc$compression_procedure_name;
            NEXT static_label_item: [fmc$compression_procedure_name] IN
                  stack_seq;
            static_label_item^.source := static_label_attributes.
                  compression_proc_name_source;
            put_entry_point_reference (static_label_attributes.
                  compression_procedure_name.name, static_label_attributes.
                  compression_procedure_name.object_library);
          IFEND;
        = fmc$data_padding =
          IF NOT(static_label_attributes.data_padding_source IN
                unspecified_sources) OR (static_label_attributes.data_padding <>
                default_file_attributes.data_padding) THEN
            header^.attribute_present [fmc$data_padding] := TRUE;
            header^.highest_attribute_present := fmc$data_padding;
            NEXT static_label_item: [fmc$data_padding] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  data_padding_source;
            static_label_item^.data_padding := static_label_attributes.
                  data_padding;
          IFEND;
        = fmc$dynamic_home_block_space =
          IF NOT(static_label_attributes.dynamic_home_block_space_source IN
                unspecified_sources) OR (static_label_attributes.
                dynamic_home_block_space <> fmv$system_file_attributes.
                static_label.dynamic_home_block_space) THEN
            header^.attribute_present [fmc$dynamic_home_block_space] := TRUE;
            header^.highest_attribute_present := fmc$dynamic_home_block_space;
            NEXT static_label_item: [fmc$dynamic_home_block_space] IN
                  stack_seq;
            static_label_item^.source := static_label_attributes.
                  dynamic_home_block_space_source;
            static_label_item^.dynamic_home_block_space :=
                  static_label_attributes.dynamic_home_block_space;
          IFEND;
        = fmc$embedded_key =
          IF NOT(static_label_attributes.embedded_key_source IN
                unspecified_sources) OR (static_label_attributes.embedded_key <>
                default_file_attributes.embedded_key) THEN
            header^.attribute_present [fmc$embedded_key] := TRUE;
            header^.highest_attribute_present := fmc$embedded_key;
            NEXT static_label_item: [fmc$embedded_key] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  embedded_key_source;
            static_label_item^.embedded_key := static_label_attributes.
                  embedded_key;
          IFEND;
        = fmc$estimated_record_count =
          IF NOT(static_label_attributes.estimated_record_count_source IN
                unspecified_sources) OR (static_label_attributes.estimated_record_count <>
                default_file_attributes.estimated_record_count) THEN
            header^.attribute_present [fmc$estimated_record_count] := TRUE;
            header^.highest_attribute_present := fmc$estimated_record_count;
            NEXT static_label_item: [fmc$estimated_record_count] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  estimated_record_count_source;
            static_label_item^.integer_value := static_label_attributes.
                  estimated_record_count;
          IFEND;
        = fmc$hashing_procedure_name =
          IF NOT(static_label_attributes.hashing_procedure_name_source IN
                unspecified_sources) OR (static_label_attributes.hashing_procedure_name <>
                default_file_attributes.hashing_procedure_name) THEN
            header^.attribute_present [fmc$hashing_procedure_name] := TRUE;
            header^.highest_attribute_present := fmc$hashing_procedure_name;
            NEXT static_label_item: [fmc$hashing_procedure_name] IN
                  stack_seq;
            static_label_item^.source := static_label_attributes.
                  hashing_procedure_name_source;
            put_entry_point_reference (static_label_attributes.
                  hashing_procedure_name.name, static_label_attributes.
                  hashing_procedure_name.object_library);
          IFEND;
        = fmc$index_levels =
          IF NOT(static_label_attributes.index_levels_source IN
                unspecified_sources) OR (static_label_attributes.index_levels <>
                default_file_attributes.index_levels) THEN
            header^.attribute_present [fmc$index_levels] := TRUE;
            header^.highest_attribute_present := fmc$index_levels;
            NEXT static_label_item: [fmc$index_levels] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  index_levels_source;
            static_label_item^.integer_value := static_label_attributes.
                  index_levels;
          IFEND;
        = fmc$index_padding =
          IF NOT(static_label_attributes.index_padding_source IN
                unspecified_sources) OR (static_label_attributes.index_padding <>
                default_file_attributes.index_padding) THEN
            header^.attribute_present [fmc$index_padding] := TRUE;
            header^.highest_attribute_present := fmc$index_padding;
            NEXT static_label_item: [fmc$index_padding] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  index_padding_source;
            static_label_item^.index_padding := static_label_attributes.
                  index_padding;
          IFEND;
        = fmc$initial_home_block_count =
          IF NOT(static_label_attributes.initial_home_block_count_source IN
                unspecified_sources) OR (static_label_attributes.
                initial_home_block_count <> fmv$system_file_attributes.
                static_label.initial_home_block_count) THEN
            header^.attribute_present [fmc$initial_home_block_count] := TRUE;
            header^.highest_attribute_present := fmc$initial_home_block_count;
            NEXT static_label_item: [fmc$initial_home_block_count] IN
                  stack_seq;
            static_label_item^.source := static_label_attributes.
                  initial_home_block_count_source;
            static_label_item^.integer_value :=
                  static_label_attributes.initial_home_block_count;
          IFEND;
        = fmc$key_length =
          IF NOT(static_label_attributes.key_length_source IN
                unspecified_sources) OR (static_label_attributes.key_length <>
                default_file_attributes.key_length) THEN
            header^.attribute_present [fmc$key_length] := TRUE;
            header^.highest_attribute_present := fmc$key_length;
            NEXT static_label_item: [fmc$key_length] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  key_length_source;
            static_label_item^.integer_value := static_label_attributes.
                  key_length;
          IFEND;
        = fmc$key_position =
          IF NOT(static_label_attributes.key_position_source IN
                unspecified_sources) OR (static_label_attributes.key_position <>
                default_file_attributes.key_position) THEN
            header^.attribute_present [fmc$key_position] := TRUE;
            header^.highest_attribute_present := fmc$key_position;
            NEXT static_label_item: [fmc$key_position] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  key_position_source;
            static_label_item^.integer_value := static_label_attributes.
                  key_position;
          IFEND;
        = fmc$key_type =
          IF NOT(static_label_attributes.key_type_source IN
                unspecified_sources) OR (static_label_attributes.key_type <>
                default_file_attributes.key_type) THEN
            header^.attribute_present [fmc$key_type] := TRUE;
            header^.highest_attribute_present := fmc$key_type;
            NEXT static_label_item: [fmc$key_type] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  key_type_source;
            static_label_item^.key_type := static_label_attributes.
                  key_type;
          IFEND;
        = fmc$loading_factor =
          IF NOT(static_label_attributes.loading_factor_source IN
                unspecified_sources) OR (static_label_attributes.loading_factor <>
                default_file_attributes.loading_factor) THEN
            header^.attribute_present [fmc$loading_factor] := TRUE;
            header^.highest_attribute_present := fmc$loading_factor;
            NEXT static_label_item: [fmc$loading_factor] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  loading_factor_source;
            static_label_item^.loading_factor := static_label_attributes.
                  loading_factor;
          IFEND;
        = fmc$lock_expiration_time =
          IF NOT(static_label_attributes.lock_expiration_time_source IN
                unspecified_sources) OR (static_label_attributes.lock_expiration_time <>
                default_file_attributes.lock_expiration_time) THEN
            header^.attribute_present [fmc$lock_expiration_time] := TRUE;
            header^.highest_attribute_present := fmc$lock_expiration_time;
            NEXT static_label_item: [fmc$lock_expiration_time] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  lock_expiration_time_source;
            static_label_item^.integer_value := static_label_attributes.
                  lock_expiration_time;
          IFEND;
        = fmc$logging_options =
          IF NOT(static_label_attributes.logging_options_source IN
                unspecified_sources) OR (static_label_attributes.logging_options <>
                default_file_attributes.logging_options) THEN
            header^.attribute_present [fmc$logging_options] := TRUE;
            header^.highest_attribute_present := fmc$logging_options;
            NEXT static_label_item: [fmc$logging_options] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  logging_options_source;
            static_label_item^.logging_options := static_label_attributes.
                  logging_options;
          IFEND;
        = fmc$log_residence =
          IF NOT(static_label_attributes.log_residence_source IN
                unspecified_sources) OR (static_label_attributes.log_residence <>
                default_file_attributes.log_residence) THEN
            header^.attribute_present [fmc$log_residence] := TRUE;
            header^.highest_attribute_present := fmc$log_residence;
            NEXT static_label_item: [fmc$log_residence] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  log_residence_source;
            #SCAN (space_selector, static_label_attributes.log_residence,
                  path_index, ignore_found);
            static_label_item^.path_length := path_index - 1;
            NEXT str: [static_label_item^.path_length] IN stack_seq;
            str^ (1, static_label_item^.path_length) :=
                  static_label_attributes.log_residence;
          IFEND;
        = fmc$record_limit =
          IF NOT(static_label_attributes.record_limit_source IN
                unspecified_sources) OR (static_label_attributes.record_limit <>
                default_file_attributes.record_limit) THEN
            header^.attribute_present [fmc$record_limit] := TRUE;
            header^.highest_attribute_present := fmc$record_limit;
            NEXT static_label_item: [fmc$record_limit] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  record_limit_source;
            static_label_item^.integer_value := static_label_attributes.
                  record_limit;
          IFEND;
        = fmc$records_per_block =
          IF NOT(static_label_attributes.records_per_block_source IN
                unspecified_sources) OR (static_label_attributes.records_per_block <>
                default_file_attributes.records_per_block) THEN
            header^.attribute_present [fmc$records_per_block] := TRUE;
            header^.highest_attribute_present := fmc$records_per_block;
            NEXT static_label_item: [fmc$records_per_block] IN stack_seq;
            static_label_item^.source := static_label_attributes.
                  records_per_block_source;
            static_label_item^.integer_value := static_label_attributes.
                  records_per_block;
          IFEND;
        ELSE
        CASEND;
      FOREND;
      IF header^.highest_attribute_present <> 0 THEN
        header^.file_previously_opened := system_file_label.file_previously_opened;
        header^.ring_attributes_source := static_label_attributes.ring_attributes_source;
        header^.ring_attributes := static_label_attributes.ring_attributes;
        static_label_size := i#current_sequence_position (stack_seq);
        ALLOCATE system_file_label.static_label: [[REP static_label_size
              OF cell]] IN osv$job_pageable_heap^;
        RESET stack_seq;
        RESET system_file_label.static_label;
        i#move (stack_seq, system_file_label.static_label,
              static_label_size);
      IFEND;
    ELSE { default file }
      system_file_label.static_label := NIL;
    IFEND;

  PROCEND fmp$put_label_attributes;


?? TITLE := '[XDCL] fmp$get_label_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$get_label_attributes (system_file_label:
    ^fmt$system_file_label;
    VAR static_label_attributes: bat$static_label_attributes;
    VAR status: ost$status);

    VAR
      file_previously_opened: boolean;

    status.normal := TRUE;

    IF system_file_label^.static_label <> NIL THEN
      fsp$expand_file_label (system_file_label^.static_label, static_label_attributes, file_previously_opened,
            status);
    ELSE
      IF fmv$default_file_attributes = NIL THEN
        static_label_attributes := fmv$system_file_attributes.static_label;
      ELSE
        static_label_attributes := fmv$default_file_attributes^;
      IFEND;
    IFEND;

  PROCEND fmp$get_label_attributes;

MODEND fmm$file_label_functions;

*DECK DECK=FMM$GET_INFO EXPAND=TRUE
?? RIGHT := 110 ??
MODULE fmm$get_info;
{ The routine fmp$get_files_volume_info returns information on the device
{ residency of a file.

?? PUSH (LISTEXT := ON) ??
*copyc clp$validate_local_file_name
*copyc dmp$get_server_fmd
*copyc dmp$get_stored_fmd
*copyc dmp$get_stored_fmd_header_info
*copyc dmp$get_stored_fmd_size
*copyc dmp$get_stored_fmd_volume_list
*copyc dmp$get_tape_volume_information
*copyc dmp$get_tape_volume_list
*copyc dmt$error_condition_codes
*copyc dmt$stored_fmd
*copyc dmt$stored_fmd_size
*copyc fme$file_management_errors
*copyc fmp$get_device_class_and_sfid
*copyc gft$system_file_identifier
*copyc osp$set_status_abnormal
*copyc rmd$volume_declarations
*copyc syp$pop_inhibit_job_recovery
*copyc syp$push_inhibit_job_recovery
?? POP ??
?? TITLE := '  Information Declarations', EJECT ??
*copyc fmd$volume_info

?? TITLE := '  fmp$get_files_volume_info', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$get_files_volume_info
    (    file: fst$file_reference;
     VAR volume_information: fmt$volume_information;
     VAR status: ost$status);

    VAR
      device_class: rmt$device_class,
      current_volume: amt$volume_number,
      current_vsns: rmt$volume_descriptor,
      density: rmt$density,
      i: integer,
      label_type: amt$label_type,
      num_of_volumes: amt$volume_number,
      number_of_volumes: integer,
      p_vsn_array: ^rmt$volume_list,
      requested_volume_attributes: iot$requested_volume_attributes,
      sfid: gft$system_file_identifier,
      volume_overflow_allowed: boolean,
      write_ring: rmt$write_ring;

    fmp$get_device_class_and_sfid (file, device_class, sfid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE device_class OF
    = rmc$mass_storage_device =
      syp$push_inhibit_job_recovery;
      PUSH p_vsn_array: [1 .. 4];
      get_ms_vsn_list (sfid, number_of_volumes, p_vsn_array, status);
      IF status.normal AND (number_of_volumes > UPPERBOUND (p_vsn_array^)) THEN
        PUSH p_vsn_array: [1 .. number_of_volumes];
        get_ms_vsn_list (sfid, number_of_volumes, p_vsn_array, status);
      IFEND;
      syp$pop_inhibit_job_recovery;
    = rmc$magnetic_tape_device =
      dmp$get_tape_volume_information (sfid, num_of_volumes, current_volume, current_vsns,
            density, write_ring, requested_volume_attributes, volume_overflow_allowed,
            label_type, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      number_of_volumes := num_of_volumes;
      PUSH p_vsn_array: [1 .. number_of_volumes];
      dmp$get_tape_volume_list (sfid, p_vsn_array, status);
    ELSE
      {null and terminal }
      number_of_volumes := 0;
    CASEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := LOWERBOUND (volume_information) TO UPPERBOUND (volume_information) DO
      CASE volume_information [i].key OF
      = fmc$number_of_volumes, fmc$volume =
        IF number_of_volumes <= 0 THEN
          volume_information [i].item_returned := FALSE;
        ELSE
          CASE volume_information [i].key OF
          = fmc$number_of_volumes =
            volume_information [i].item_returned := TRUE;
            volume_information [i].number_of_volumes := number_of_volumes;
          = fmc$volume =
            IF (volume_information [i].requested_volume_number < 1) OR (volume_information [i].
                  requested_volume_number > number_of_volumes) THEN
              volume_information [i].item_returned := FALSE;
            ELSE
              volume_information [i].item_returned := TRUE;
              volume_information [i].volume := p_vsn_array^ [volume_information [i].
                    requested_volume_number];
            IFEND;
          ELSE
          CASEND;
        IFEND;

      = fmc$tape_density, fmc$tape_class, fmc$write_ring =
        IF device_class = rmc$magnetic_tape_device THEN
          volume_information [i].item_returned := TRUE;
          CASE volume_information [i].key OF
          = fmc$tape_density =
            volume_information [i].tape_density := density;
          = fmc$tape_class =
            IF density = rmc$38000 THEN
              volume_information [i].tape_class := rmc$mt18;
            ELSE
              volume_information [i].tape_class := rmc$mt9;
            IFEND;
          = fmc$write_ring =
            volume_information [i].write_ring := write_ring;
          ELSE
          CASEND;
        ELSE  { unexpected device class
          volume_information [i].item_returned := FALSE;
        IFEND;
      ELSE { unknown item
        volume_information [i].item_returned := FALSE;
      CASEND;
    FOREND;
  PROCEND fmp$get_files_volume_info;

?? TITLE := '  get_ms_vsn_list', EJECT ??

  PROCEDURE get_ms_vsn_list
    (    sfid: gft$system_file_identifier;
     VAR vsn_count: integer;
     VAR p_vsn_list: ^rmt$volume_list;
     VAR status: ost$status);

    VAR
      fmd_header: pft$fmd_header,
      p_local_volume_list: ^pft$volume_list,
      p_stored_fmd: ^dmt$stored_fmd,
      stored_fmd_size: dmt$stored_fmd_size,
      subfile_index: dmt$subfile_index;

    vsn_count := 0;

    dmp$get_stored_fmd_size (sfid, stored_fmd_size, status);
    IF status.normal THEN
      PUSH p_stored_fmd: [[REP stored_fmd_size OF cell]];
      dmp$get_stored_fmd (sfid, p_stored_fmd^, status);
    ELSEIF status.condition = dme$unexpected_server_file THEN
      PUSH p_stored_fmd: [[REP (#SIZE (dmt$stored_ms_fmd_header) + #SIZE (dmt$stored_ms_fmd_subfile) *
            UPPERBOUND (p_vsn_list^)) OF cell]];
      dmp$get_server_fmd (sfid, p_stored_fmd^, stored_fmd_size, status);
      IF NOT status.normal AND (status.condition = dme$fmd_too_small) THEN
        PUSH p_stored_fmd: [[REP stored_fmd_size OF cell]];
        dmp$get_server_fmd (sfid, p_stored_fmd^, stored_fmd_size, status);
      IFEND;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$get_stored_fmd_header_info (p_stored_fmd, fmd_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    vsn_count := fmd_header.number_of_subfiles;

    IF vsn_count > UPPERBOUND (p_vsn_list^) THEN
      RETURN;
    IFEND;

    IF vsn_count > 0 THEN
      PUSH p_local_volume_list: [1 .. vsn_count];

      dmp$get_stored_fmd_volume_list (p_stored_fmd, p_local_volume_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      FOR subfile_index := 1 TO vsn_count DO
        p_vsn_list^ [subfile_index].external_vsn := p_local_volume_list^ [subfile_index];
        p_vsn_list^ [subfile_index].recorded_vsn := p_local_volume_list^ [subfile_index];
      FOREND;
    IFEND;
  PROCEND get_ms_vsn_list;

MODEND fmm$get_info;
*DECK DECK=FMM$GET_LAST_ANSI_FILE_ACCESS EXPAND=TRUE
*DECK DECK=FMM$GET_NEXT_ANSI_FILE_POSITION EXPAND=TRUE
*DECK DECK=FMM$GET_OPEN_INFORMATION EXPAND=TRUE
?? RIGHT := 110 ??
MODULE fmm$get_open_information;
*copyc osd$default_pragmats
?? NEWTITLE := 'MODULE fmm$get_open_information' ??
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
?? NEWTITLE := 'Decks global definitions' ??
?? EJECT ??
*copyc amc$condition_code_limits
*copyc ame$attribute_validation_errors
*copyc ame$improper_file_id
*copyc ame$ring_validation_errors
*copyc bat$task_file_table
*copyc fmc$unique_label_id
*copyc fmt$file_attribute_keys
*copyc fmt$static_label_header
*copyc fmt$static_label_item
*copyc fse$get_info_validation_errors
*copyc fst$attachment_information
*copyc fst$catalog_information
*copyc fst$cycle_attribute_sources
*copyc fst$cycle_attribute_values
*copyc fst$open_instance_information
*copyc fst$path
*copyc fst$resolved_file_reference
*copyc fst$user_attribute_descriptor
*copyc fst$user_defined_attribute_size
*copyc pmt$program_name
?? POP ??

*copyc i#move
*copyc amp$set_file_instance_abnormal
*copyc bap$get_default_attributes
*copyc bap$validate_file_identifier
*copyc clp$check_name_for_path_handle
*copyc clp$trimmed_string_size
*copyc fmp$get_resolved_file_reference
*copyc iip$get_page_length_width
*copyc osp$append_status_parameter
*copyc osp$fetch_locked_variable
*copyc osp$set_status_abnormal

*copyc clv$standard_files
*copyc fsv$evaluated_file_reference
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE fsp$convert_to_old_contents' ??
?? EJECT ??
*copyc fsp$convert_to_old_contents
?? TITLE := 'PROCEDURE fsp$convert_to_new_contents' ??
?? EJECT ??
*copyc fsp$convert_to_new_contents

?? TITLE := 'PROCEDURE fmp$get_open_information' ??
?? EJECT ??
*copyc fmh$get_open_information
*copyc amt$file_identifier
*copyc osd$integer_limits
*copyc ost$status

?? EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$get_open_information (file_identifier: amt$file_identifier;
        attachment_information: ^SEQ ( * );
        catalog_information: ^SEQ ( * );
        cycle_attribute_sources: ^SEQ ( * );
        cycle_attribute_values: ^SEQ ( * );
        instance_information: ^SEQ ( * );
        resolved_file_reference: ^SEQ ( * );
        user_defined_attributes: ^SEQ ( * );
    VAR user_defined_attribute_size: ost$non_negative_integers;
    VAR status: ost$status);

    VAR
      attachment_info_requested: boolean,
      attachment_information_rec: fst$attachment_information,
      attachment_information_seq: ^SEQ ( * ),
      attribute_key: fmt$file_attribute_keys,
      attribute_sources_requested: boolean,
      attribute_values_requested: boolean,
      catalog_info_requested: boolean,
      catalog_information_rec: fst$catalog_information,
      catalog_information_seq: ^SEQ ( * ),
      cl_path_handle: clt$path_handle,
      cycle_attribute_sources_rec: fst$cycle_attribute_sources,
      cycle_attribute_sources_seq: ^SEQ ( * ),
      cycle_attribute_values_rec: fst$cycle_attribute_values,
      cycle_attribute_values_seq: ^SEQ ( * ),
      file_contents_truncated: boolean,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      header: ^fmt$static_label_header,
      instance_info_requested: boolean,
      instance_information_rec: fst$open_instance_information,
      instance_information_seq: ^SEQ ( * ),
      oldest_target_file_instance: ^bat$task_file_entry,
      p_evaluated_file_reference: ^fst$evaluated_file_reference,
      resolved_file_reference_rec: fst$resolved_file_reference,
      resolved_file_reference_seq: ^SEQ ( * ),
      resolved_reference_requested: boolean,
      static_file_contents: amt$file_contents,
      static_file_structure: amt$file_structure,
      static_label: ^SEQ ( * ),
      static_label_item: ^fmt$static_label_item,
      status_text: string (osc$max_string_size),
      status_text_size: integer,
      str: ^string ( * ),
      target_file_identifier: amt$file_identifier,
      target_file_instance: ^bat$task_file_entry, { currently known last target of 'file_instance' }
      terminal_attributes: array [1 .. 2] of ift$terminal_attribute,
      tape_descriptor: ^bat$tape_descriptor,
      tape_descriptor_sequence_ptr: ^SEQ ( * ),
      user_defined_info_requested: boolean;

?? NEWTITLE := '  PROCEDURE set_status_damaged_attributes' ??
?? EJECT ??

    PROCEDURE set_status_damaged_attributes (error_number: ost$non_negative_integers;
      VAR status: ost$status);

      VAR
        status_text: string (osc$max_string_size),
        text_length: integer;

      STRINGREP (status_text, text_length, 'detected damaged label error #', error_number,
        ' in fmm$get_open_information');
      amp$set_file_instance_abnormal (file_identifier, fse$get_file_info_internal,
            fsc$get_open_information_req, status_text (1, text_length), status);

    PROCEND set_status_damaged_attributes;

?? TITLE := '  PROCEDURE set_status_bad_data_mapping' ??
?? EJECT ??

    PROCEDURE set_status_bad_data_mapping (error_text: string ( * );
      VAR status: ost$status);

      VAR
        status_text: string (130),
        text_length: integer;

      STRINGREP (status_text, text_length, 'Detected error in fmm$get_open_information - ',
        'bad data mapping of ', error_text);
      amp$set_file_instance_abnormal (file_identifier, fse$get_file_info_internal,
            fsc$get_open_information_req, status_text (1, text_length), status);

    PROCEND set_status_bad_data_mapping;

?? TITLE := '  PROCEDURE get_entry_point_reference' ??
?? EJECT ??

    PROCEDURE [INLINE] get_entry_point_reference (VAR name: pmt$program_name;
      VAR path: fst$path;
      VAR status: ost$status);
      NEXT str: [static_label_item^.entry_point_name_length] IN static_label;
      IF str = NIL THEN
        set_status_damaged_attributes (1, status);
        RETURN;
      IFEND;
      name := str^;
      IF static_label_item^.entry_point_path_length > 0 THEN
        NEXT str: [static_label_item^.entry_point_path_length] IN static_label;
        IF str = NIL THEN
          set_status_damaged_attributes (2, status);
          RETURN;
        IFEND;
        path := str^;
      IFEND;
    PROCEND get_entry_point_reference;

?? TITLE := '  PROCEDURE get_name' ??
?? EJECT ??

    PROCEDURE [INLINE] get_name (VAR name: pmt$program_name;
      VAR status: ost$status);

      NEXT str: [static_label_item^.name_length] IN static_label;
      IF str = NIL THEN
        set_status_damaged_attributes (3, status);
        RETURN;
      IFEND;
      name := str^;
    PROCEND get_name;
?? OLDTITLE ??

    status.normal := TRUE;

    file_contents_truncated := FALSE;

    attribute_values_requested := (cycle_attribute_values <> NIL);
    attribute_sources_requested := (cycle_attribute_sources <> NIL);
    catalog_info_requested := (catalog_information <> NIL);
    attachment_info_requested := (attachment_information <> NIL);
    instance_info_requested := (instance_information <> NIL);
    resolved_reference_requested := (resolved_file_reference <> NIL);
    user_defined_info_requested := (user_defined_attributes <> NIL);
    user_defined_attribute_size := 0;

    bap$validate_file_identifier (file_identifier, file_instance, file_id_is_valid);
    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id, 'FSP$GET_OPEN_INFORMATION',
            status);
      RETURN;
    IFEND;
    oldest_target_file_instance := file_instance;

{  Check if the file is the subject of a file connection, if so find the oldest target file.

  /find_ultimate_target/
    WHILE (oldest_target_file_instance^.device_class = rmc$connected_file_device) AND
          oldest_target_file_instance^.first_target.defined DO

      target_file_identifier := oldest_target_file_instance^.first_target.file_identifier;
      target_file_instance := NIL;

{  Look for the last target file of file_instance.

    /find_oldest_target/
      WHILE TRUE DO
        bap$validate_file_identifier (target_file_identifier, target_file_instance, file_id_is_valid);
        IF NOT file_id_is_valid THEN
          osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id, 'FMP$GET_OPEN_INFORMATION',
                status);
          RETURN;
        IFEND;

        IF target_file_instance^.next_target.defined THEN
          target_file_identifier := target_file_instance^.next_target.file_identifier;
        ELSE
          EXIT /find_oldest_target/; {oldest target has been found}
        IFEND;
      WHILEND /find_oldest_target/;

{  If target_file_instance is not NIL, then it is the last target.  Then it must be check whether it
{  is also the subject of a connected file.

      IF (target_file_instance <> NIL) AND (target_file_instance^.local_file_name <>
            clv$standard_files [clc$sf_null_file].path_handle_name) THEN
        oldest_target_file_instance := target_file_instance;
      ELSE
        EXIT /find_ultimate_target/;
      IFEND;
    WHILEND /find_ultimate_target/;

    IF attachment_info_requested THEN
      osp$fetch_locked_variable (file_instance^.global_file_information^.open_count,
            attachment_information_rec.usage_information.concurrent_open_count);
      #unchecked_conversion (file_instance^.system_file_label^.descriptive_label.global_access_mode,
            attachment_information_rec.administration_information.attached_access_modes);
      #unchecked_conversion (file_instance^.system_file_label^.descriptive_label.global_share_mode,
            attachment_information_rec.administration_information.attached_share_modes);
      attachment_information_rec.usage_information.private_read :=
            (file_instance^.private_read_information <> NIL);
    IFEND;

    IF instance_info_requested THEN
      #unchecked_conversion (file_instance^.instance_attributes.dynamic_label.access_mode,
            instance_information_rec.attachment_information.access_modes);
      #unchecked_conversion (file_instance^.instance_attributes.dynamic_label.open_share_modes,
            instance_information_rec.attachment_information.open_share_modes);
      instance_information_rec.attachment_information.open_position := file_instance^.instance_attributes.
            dynamic_label.open_position;
      instance_information_rec.attachment_information.private_read :=
            (file_instance^.private_read_information <> NIL);
    IFEND;

    IF attribute_values_requested OR attribute_sources_requested OR catalog_info_requested OR
          user_defined_info_requested THEN

      bap$get_default_attributes (^catalog_information_rec, ^cycle_attribute_sources_rec,
            ^cycle_attribute_values_rec, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


      IF catalog_info_requested THEN
        catalog_information_rec.cycle_registration.size := oldest_target_file_instance^.
              global_file_information^.eoi_byte_address;
        catalog_information_rec.cycle_registration.residence.device_class := file_instance^.device_class;
      IFEND;


      static_label := oldest_target_file_instance^.system_file_label^.static_label;

      IF static_label <> NIL THEN
        RESET static_label;
        NEXT header IN static_label;
        IF (header = NIL) OR (header^.unique_character <> fmc$unique_label_id) THEN
          set_status_damaged_attributes (4, status);
          RETURN;
        IFEND;
        IF header^.file_previously_opened THEN
          catalog_information_rec.cycle_registration.ring_attributes := header^.ring_attributes;
        IFEND;
        IF header^.highest_attribute_present > 0 THEN
          fsp$convert_to_old_contents (cycle_attribute_values_rec.file_contents, static_file_contents,
                static_file_structure);

          FOR attribute_key := LOWERBOUND (header^.attribute_present) TO header^.highest_attribute_present DO
            CASE attribute_key OF
            = fmc$average_record_length =
              IF header^.attribute_present [fmc$average_record_length] THEN
                NEXT static_label_item: [fmc$average_record_length] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (5, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.average_record_length := static_label_item^.source;
                cycle_attribute_values_rec.average_record_length := static_label_item^.integer_value;
              IFEND;
            = fmc$block_type =
              IF header^.attribute_present [fmc$block_type] THEN
                NEXT static_label_item: [fmc$block_type] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (6, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.block_type := static_label_item^.source;
                cycle_attribute_values_rec.block_type := static_label_item^.block_type;
              IFEND;
            = fmc$character_conversion =
              IF header^.attribute_present [fmc$character_conversion] THEN
                NEXT static_label_item: [fmc$character_conversion] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (7, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.character_conversion := static_label_item^.source;
                cycle_attribute_values_rec.character_conversion := static_label_item^.character_conversion;
              IFEND;
            = fmc$clear_space =
              IF header^.attribute_present [fmc$clear_space] THEN
                NEXT static_label_item: [fmc$clear_space] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (8, status);
                  RETURN;
                IFEND;
                catalog_information_rec.cycle_registration.erase_at_deletion := static_label_item^.
                      clear_space;
              IFEND;
            = fmc$collate_table =
              IF header^.attribute_present [fmc$collate_table] THEN
                NEXT static_label_item: [fmc$collate_table] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (9, status);
                  RETURN;
                IFEND;
              IFEND;
            = fmc$collate_table_name =
              IF header^.attribute_present [fmc$collate_table_name] THEN
                NEXT static_label_item: [fmc$collate_table_name] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (10, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.collate_table_name := static_label_item^.source;
                get_entry_point_reference (cycle_attribute_values_rec.collate_table_name.entry_point,
                      cycle_attribute_values_rec.collate_table_name.object_library, status);
                IF NOT status.normal THEN
                  set_status_damaged_attributes (11, status);
                  RETURN;
                IFEND;
              IFEND;
            = fmc$compression_procedure_name =
              IF header^.attribute_present [fmc$compression_procedure_name] THEN
                NEXT static_label_item: [fmc$compression_procedure_name] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (12, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.compression_procedure_name := static_label_item^.source;
                get_entry_point_reference (cycle_attribute_values_rec.compression_procedure_name.entry_point,
                      cycle_attribute_values_rec.compression_procedure_name.object_library, status);
                IF NOT status.normal THEN
                  set_status_damaged_attributes (13, status);
                  RETURN;
                IFEND;
              IFEND;
            = fmc$data_padding =
              IF header^.attribute_present [fmc$data_padding] THEN
                NEXT static_label_item: [fmc$data_padding] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (14, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.data_padding := static_label_item^.source;
                cycle_attribute_values_rec.data_padding := static_label_item^.data_padding;
              IFEND;
            = fmc$dynamic_home_block_space =
              IF header^.attribute_present [fmc$dynamic_home_block_space] THEN
                NEXT static_label_item: [fmc$dynamic_home_block_space] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (15, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.dynamic_home_block_space := static_label_item^.source;
                cycle_attribute_values_rec.dynamic_home_block_space := static_label_item^.
                      dynamic_home_block_space;
              IFEND;
            = fmc$embedded_key =
              IF header^.attribute_present [fmc$embedded_key] THEN
                NEXT static_label_item: [fmc$embedded_key] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (16, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.embedded_key := static_label_item^.source;
                cycle_attribute_values_rec.embedded_key := static_label_item^.embedded_key;
              IFEND;
            = fmc$estimated_record_count =
              IF header^.attribute_present [fmc$estimated_record_count] THEN
                NEXT static_label_item: [fmc$estimated_record_count] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (17, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.estimated_record_count := static_label_item^.source;
                cycle_attribute_values_rec.estimated_record_count := static_label_item^.integer_value;
              IFEND;
            = fmc$file_access_procedure =
              IF header^.attribute_present [fmc$file_access_procedure] THEN
                NEXT static_label_item: [fmc$file_access_procedure] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (18, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.file_access_procedure_name := static_label_item^.source;
                get_entry_point_reference (cycle_attribute_values_rec.file_access_procedure_name.entry_point,
                      cycle_attribute_values_rec.file_access_procedure_name.object_library, status);
                IF NOT status.normal THEN
                  set_status_damaged_attributes (19, status);
                  RETURN;
                IFEND;
              IFEND;
            = fmc$file_contents =
              IF header^.attribute_present [fmc$file_contents] THEN
                NEXT static_label_item: [fmc$file_contents] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (20, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.file_contents := static_label_item^.source;
                get_name (static_file_contents, status);
                IF NOT status.normal THEN
                  set_status_damaged_attributes (21, status);
                  RETURN;
                IFEND;
              IFEND;
            = fmc$file_limit =
              IF header^.attribute_present [fmc$file_limit] THEN
                NEXT static_label_item: [fmc$file_limit] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (22, status);
                  RETURN;
                IFEND;
                catalog_information_rec.cycle_registration.size_limit := static_label_item^.integer_value;
              IFEND;
            = fmc$file_organization =
              IF header^.attribute_present [fmc$file_organization] THEN
                NEXT static_label_item: [fmc$file_organization] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (23, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.file_organization := static_label_item^.source;
                cycle_attribute_values_rec.file_organization := static_label_item^.file_organization;
              IFEND;
            = fmc$file_processor =
              IF header^.attribute_present [fmc$file_processor] THEN
                NEXT static_label_item: [fmc$file_processor] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (24, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.file_processor := static_label_item^.source;
                get_name (cycle_attribute_values_rec.file_processor, status);
                IF NOT status.normal THEN
                  set_status_damaged_attributes (25, status);
                  RETURN;
                IFEND;
              IFEND;
            = fmc$file_structure =
              IF header^.attribute_present [fmc$file_structure] THEN
                NEXT static_label_item: [fmc$file_structure] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (26, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.file_contents := static_label_item^.source;
                get_name (static_file_structure, status);
                IF NOT status.normal THEN
                  set_status_damaged_attributes (27, status);
                  RETURN;
                IFEND;
              IFEND;
            = fmc$forced_write =
              IF header^.attribute_present [fmc$forced_write] THEN
                NEXT static_label_item: [fmc$forced_write] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (28, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.forced_write := static_label_item^.source;
                cycle_attribute_values_rec.forced_write := static_label_item^.forced_write;
              IFEND;
            = fmc$hashing_procedure_name =
              IF header^.attribute_present [fmc$hashing_procedure_name] THEN
                NEXT static_label_item: [fmc$hashing_procedure_name] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (29, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.hashing_procedure_name := static_label_item^.source;
                get_entry_point_reference (cycle_attribute_values_rec.hashing_procedure_name.entry_point,
                      cycle_attribute_values_rec.hashing_procedure_name.object_library, status);
                IF NOT status.normal THEN
                  set_status_damaged_attributes (30, status);
                  RETURN;
                IFEND;
              IFEND;
            = fmc$index_levels =
              IF header^.attribute_present [fmc$index_levels] THEN
                NEXT static_label_item: [fmc$index_levels] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (31, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.index_levels := static_label_item^.source;
                cycle_attribute_values_rec.index_levels := static_label_item^.integer_value;
              IFEND;
            = fmc$index_padding =
              IF header^.attribute_present [fmc$index_padding] THEN
                NEXT static_label_item: [fmc$index_padding] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (32, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.index_padding := static_label_item^.source;
                cycle_attribute_values_rec.index_padding := static_label_item^.index_padding;
              IFEND;
            = fmc$initial_home_block_count =
              IF header^.attribute_present [fmc$initial_home_block_count] THEN
                NEXT static_label_item: [fmc$initial_home_block_count] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (33, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.initial_home_block_count := static_label_item^.source;
                cycle_attribute_values_rec.initial_home_block_count := static_label_item^.integer_value;
              IFEND;
            = fmc$internal_code =
              IF header^.attribute_present [fmc$internal_code] THEN
                NEXT static_label_item: [fmc$internal_code] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (34, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.internal_code := static_label_item^.source;
                cycle_attribute_values_rec.internal_code := static_label_item^.internal_code;
              IFEND;
            = fmc$key_length =
              IF header^.attribute_present [fmc$key_length] THEN
                NEXT static_label_item: [fmc$key_length] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (35, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.key_length := static_label_item^.source;
                cycle_attribute_values_rec.key_length := static_label_item^.integer_value;
              IFEND;
            = fmc$key_position =
              IF header^.attribute_present [fmc$key_position] THEN
                NEXT static_label_item: [fmc$key_position] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (36, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.key_position := static_label_item^.source;
                cycle_attribute_values_rec.key_position := static_label_item^.integer_value;
              IFEND;
            = fmc$key_type =
              IF header^.attribute_present [fmc$key_type] THEN
                NEXT static_label_item: [fmc$key_type] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (37, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.key_type := static_label_item^.source;
                cycle_attribute_values_rec.key_type := static_label_item^.key_type;
              IFEND;
            = fmc$label_type =
              IF header^.attribute_present [fmc$label_type] THEN
                NEXT static_label_item: [fmc$label_type] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (38, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.file_label_type := static_label_item^.source;
                cycle_attribute_values_rec.file_label_type := static_label_item^.label_type;
              IFEND;
            = fmc$line_number =
              IF header^.attribute_present [fmc$line_number] THEN
                NEXT static_label_item: [fmc$line_number] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (39, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.line_number := static_label_item^.source;
                cycle_attribute_values_rec.line_number := static_label_item^.line_number;
              IFEND;
            = fmc$loading_factor =
              IF header^.attribute_present [fmc$loading_factor] THEN
                NEXT static_label_item: [fmc$loading_factor] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (40, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.loading_factor := static_label_item^.source;
                cycle_attribute_values_rec.loading_factor := static_label_item^.loading_factor;
              IFEND;
            = fmc$lock_expiration_time =
              IF header^.attribute_present [fmc$lock_expiration_time] THEN
                NEXT static_label_item: [fmc$lock_expiration_time] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (41, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.lock_expiration_time := static_label_item^.source;
                cycle_attribute_values_rec.lock_expiration_time := static_label_item^.integer_value;
              IFEND;
            = fmc$logging_options =
              IF header^.attribute_present [fmc$logging_options] THEN
                NEXT static_label_item: [fmc$logging_options] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (42, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.logging_options := static_label_item^.source;
                cycle_attribute_values_rec.logging_options := static_label_item^.logging_options;
              IFEND;
            = fmc$log_residence =
              IF header^.attribute_present [fmc$log_residence] THEN
                NEXT static_label_item: [fmc$log_residence] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (43, status);
                  RETURN;
                IFEND;
                NEXT str: [static_label_item^.path_length] IN static_label;
                IF str = NIL THEN
                  set_status_damaged_attributes (44, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.log_residence := static_label_item^.source;
                cycle_attribute_values_rec.log_residence := str^;
              IFEND;
            = fmc$max_block_length =
              IF header^.attribute_present [fmc$max_block_length] THEN
                NEXT static_label_item: [fmc$max_block_length] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (45, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.max_block_length := static_label_item^.source;
                cycle_attribute_values_rec.max_block_length := static_label_item^.integer_value;
              IFEND;
            = fmc$max_record_length =
              IF header^.attribute_present [fmc$max_record_length] THEN
                NEXT static_label_item: [fmc$max_record_length] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (46, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.max_record_length := static_label_item^.source;
                cycle_attribute_values_rec.max_record_length := static_label_item^.integer_value;
              IFEND;
            = fmc$min_block_length =
              IF header^.attribute_present [fmc$min_block_length] THEN
                NEXT static_label_item: [fmc$min_block_length] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (47, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.min_block_length := static_label_item^.source;
                cycle_attribute_values_rec.min_block_length := static_label_item^.integer_value;
              IFEND;
            = fmc$min_record_length =
              IF header^.attribute_present [fmc$min_record_length] THEN
                NEXT static_label_item: [fmc$min_record_length] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (48, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.min_record_length := static_label_item^.source;
                cycle_attribute_values_rec.min_record_length := static_label_item^.integer_value;
              IFEND;
            = fmc$padding_character =
              IF header^.attribute_present [fmc$padding_character] THEN
                NEXT static_label_item: [fmc$padding_character] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (49, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.padding_character := static_label_item^.source;
                cycle_attribute_values_rec.padding_character := static_label_item^.padding_character;
              IFEND;
            = fmc$page_format =
              IF header^.attribute_present [fmc$page_format] THEN
                NEXT static_label_item: [fmc$page_format] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (50, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.page_format := static_label_item^.source;
                cycle_attribute_values_rec.page_format := static_label_item^.page_format;
              IFEND;
            = fmc$page_length =
              IF header^.attribute_present [fmc$page_length] THEN
                NEXT static_label_item: [fmc$page_length] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (51, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.page_length := static_label_item^.source;
                cycle_attribute_values_rec.page_length := static_label_item^.integer_value;
              IFEND;
            = fmc$page_width =
              IF header^.attribute_present [fmc$page_width] THEN
                NEXT static_label_item: [fmc$page_width] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (52, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.page_width := static_label_item^.source;
                cycle_attribute_values_rec.page_width := static_label_item^.integer_value;
              IFEND;
            = fmc$preset_value =
              IF header^.attribute_present [fmc$preset_value] THEN
                NEXT static_label_item: [fmc$preset_value] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (53, status);
                  RETURN;
                IFEND;
                catalog_information_rec.cycle_registration.preset_value := static_label_item^.integer_value;
              IFEND;
            = fmc$record_delimiting_character =
              IF header^.attribute_present [fmc$record_delimiting_character] THEN
                NEXT static_label_item: [fmc$record_delimiting_character] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (54, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.record_delimiting_character := static_label_item^.source;
                cycle_attribute_values_rec.record_delimiting_character := static_label_item^.
                      record_delimiting_character;
              IFEND;
            = fmc$record_limit =
              IF header^.attribute_present [fmc$record_limit] THEN
                NEXT static_label_item: [fmc$record_limit] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (55, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.record_limit := static_label_item^.source;
                cycle_attribute_values_rec.record_limit := static_label_item^.integer_value;
              IFEND;
            = fmc$records_per_block =
              IF header^.attribute_present [fmc$records_per_block] THEN
                NEXT static_label_item: [fmc$records_per_block] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (56, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.records_per_block := static_label_item^.source;
                cycle_attribute_values_rec.records_per_block := static_label_item^.integer_value;
              IFEND;
            = fmc$record_type =
              IF header^.attribute_present [fmc$record_type] THEN
                NEXT static_label_item: [fmc$record_type] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (57, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.record_type := static_label_item^.source;
                cycle_attribute_values_rec.record_type := static_label_item^.record_type;
              IFEND;
            = fmc$ring_attributes =
              { processed above prior to FOR            loop }
              ;
            = fmc$statement_identifier =
              IF header^.attribute_present [fmc$statement_identifier] THEN
                NEXT static_label_item: [fmc$statement_identifier] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (58, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.statement_identifier := static_label_item^.source;
                cycle_attribute_values_rec.statement_identifier := static_label_item^.statement_identifier;
              IFEND;
            = fmc$user_info =
              IF header^.attribute_present [fmc$user_info] THEN
                NEXT static_label_item: [fmc$user_info] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (59, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.user_information := static_label_item^.source;
                IF static_label_item^.user_info_present THEN
                  NEXT str: [32] IN static_label;
                  IF str = NIL THEN
                    set_status_damaged_attributes (60, status);
                    RETURN;
                  IFEND;
                  cycle_attribute_values_rec.user_information := str^;
                IFEND;
              IFEND;
            = fmc$vertical_print_density =
              IF header^.attribute_present [fmc$vertical_print_density] THEN
                NEXT static_label_item: [fmc$vertical_print_density] IN static_label;
                IF static_label_item = NIL THEN
                  set_status_damaged_attributes (61, status);
                  RETURN;
                IFEND;
                cycle_attribute_sources_rec.vertical_print_density := static_label_item^.source;
                cycle_attribute_values_rec.vertical_print_density := static_label_item^.integer_value;
              IFEND;
            ELSE
            CASEND;
          FOREND;
          IF attribute_values_requested THEN
            fsp$convert_to_new_contents (static_file_contents, static_file_structure,
                  cycle_attribute_values_rec.file_contents, file_contents_truncated);
          IFEND;
        IFEND; {highest_attribute_present > 0}
      IFEND; {static_label_size <> 0}

      IF (oldest_target_file_instance^.device_class = rmc$terminal_device) AND attribute_values_requested AND
            ((cycle_attribute_sources_rec.page_length = amc$access_method_default) OR
            (cycle_attribute_sources_rec.page_width = amc$access_method_default)) THEN
        clp$check_name_for_path_handle (oldest_target_file_instance^.local_file_name, cl_path_handle);
        iip$get_page_length_width (cl_path_handle.regular_handle, terminal_attributes, status);
        IF cycle_attribute_sources_rec.page_length = amc$access_method_default THEN
          IF terminal_attributes [1].page_length = 0 THEN
            cycle_attribute_values_rec.page_length := UPPERVALUE (amt$page_length);
          ELSE
            cycle_attribute_values_rec.page_length := terminal_attributes [1].page_length;
          IFEND;
        IFEND;
        IF cycle_attribute_sources_rec.page_width = amc$access_method_default THEN
          IF terminal_attributes [2].page_width = 0 THEN
            cycle_attribute_values_rec.page_width := UPPERVALUE (amt$page_width);
          ELSE
            cycle_attribute_values_rec.page_width := terminal_attributes [2].page_width;
          IFEND;
        IFEND;
      IFEND; {terminal_device

      IF oldest_target_file_instance^.global_file_information^.device_dependent_info.device_class =
            rmc$magnetic_tape_device THEN
        tape_descriptor_sequence_ptr := oldest_target_file_instance^.global_file_information^.
              device_dependent_info.tape_descriptor;
        RESET tape_descriptor_sequence_ptr;
        NEXT tape_descriptor IN tape_descriptor_sequence_ptr;
        cycle_attribute_values_rec.block_type := tape_descriptor^.tape_attachment_information.block_type;
        cycle_attribute_values_rec.character_conversion := tape_descriptor^.tape_attachment_information.
              character_conversion;
        cycle_attribute_values_rec.internal_code := tape_descriptor^.tape_attachment_information.
              character_set;
        cycle_attribute_values_rec.max_block_length := tape_descriptor^.tape_attachment_information.
              max_block_length;
        cycle_attribute_values_rec.max_record_length := tape_descriptor^.tape_attachment_information.
              max_record_length;
        cycle_attribute_values_rec.padding_character := tape_descriptor^.tape_attachment_information.
              padding_character;
        cycle_attribute_values_rec.record_type := tape_descriptor^.tape_attachment_information.record_type;
      IFEND; {magnetic_tape_device

    IFEND; {catalog_info, file_attribute_values, file_attribute_sources}

    IF resolved_reference_requested THEN
      clp$check_name_for_path_handle (file_instance^.local_file_name, cl_path_handle);
      IF (file_instance^.instance_attributes.dynamic_label.open_position_source = amc$file_reference) OR
            (file_instance^.instance_attributes.dynamic_label.open_position_source = amc$open_request) THEN
         cl_path_handle.regular_handle.open_position.specified := TRUE;
         cl_path_handle.regular_handle.open_position.value := file_instance^.instance_attributes.
               dynamic_label.open_position;
      ELSE
         cl_path_handle.regular_handle.open_position.specified := FALSE;
      IFEND;
      PUSH p_evaluated_file_reference;
      p_evaluated_file_reference^ := fsv$evaluated_file_reference;
      p_evaluated_file_reference^.path_handle_info.path_handle := cl_path_handle.regular_handle;
      p_evaluated_file_reference^.path_handle_info.path_handle_present := TRUE;
      fmp$get_resolved_file_reference (p_evaluated_file_reference^, resolved_file_reference_rec, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF attachment_info_requested THEN
      attachment_information_seq := attachment_information;
      RESET attachment_information_seq;
      IF #SIZE (attachment_information_seq^) <= #SIZE (attachment_information_rec) THEN
        i#move (^attachment_information_rec, attachment_information_seq, #SIZE (attachment_information_seq^));
      ELSE
        set_status_bad_data_mapping ('attachment_information', status);
        RETURN;
      IFEND;
    IFEND;

    IF catalog_info_requested THEN
      catalog_information_seq := catalog_information;
      RESET catalog_information_seq;
      IF #SIZE (catalog_information_seq^) <= #SIZE (catalog_information_rec) THEN
        i#move (^catalog_information_rec, catalog_information_seq, #SIZE (catalog_information_seq^));
      ELSE
        set_status_bad_data_mapping ('catalog_information', status);
        RETURN;
      IFEND;
    IFEND;

    IF attribute_sources_requested THEN
      cycle_attribute_sources_seq := cycle_attribute_sources;
      RESET cycle_attribute_sources_seq;
      IF #SIZE (cycle_attribute_sources_seq^) <= #SIZE (cycle_attribute_sources_rec) THEN
        i#move (^cycle_attribute_sources_rec, cycle_attribute_sources_seq, #SIZE
              (cycle_attribute_sources_seq^));
      ELSE
        set_status_bad_data_mapping ('cycle_attribute_sources', status);
        RETURN;
      IFEND;
    IFEND;

    IF attribute_values_requested THEN
      cycle_attribute_values_seq := cycle_attribute_values;
      RESET cycle_attribute_values_seq;
      IF #SIZE (cycle_attribute_values_seq^) <= #SIZE (cycle_attribute_values_rec) THEN
        i#move (^cycle_attribute_values_rec, cycle_attribute_values_seq, #SIZE (cycle_attribute_values_seq^));
      ELSE
        set_status_bad_data_mapping ('cycle_attribute_values', status);
        RETURN;
      IFEND;
    IFEND;

    IF instance_info_requested THEN
      instance_information_seq := instance_information;
      RESET instance_information_seq;
      IF #SIZE (instance_information_seq^) <= #SIZE (instance_information_rec) THEN
        i#move (^instance_information_rec, instance_information_seq, #SIZE (instance_information_seq^));
      ELSE
        set_status_bad_data_mapping ('instance_information', status);
        RETURN;
      IFEND;
    IFEND;

    IF resolved_reference_requested THEN
      resolved_file_reference_seq := resolved_file_reference;
      RESET resolved_file_reference_seq;
      IF #SIZE (resolved_file_reference_seq^) <= #SIZE (resolved_file_reference_rec) THEN
        i#move (^resolved_file_reference_rec, resolved_file_reference_seq, #SIZE
              (resolved_file_reference_seq^));
      ELSE
 { commented out because of AAM referencing but not using.
 {      set_status_bad_data_mapping ('resolved_file_reference', status);
 {      RETURN;
      IFEND;
    IFEND;

    IF file_contents_truncated THEN
      amp$set_file_instance_abnormal (file_identifier, fse$file_contents_truncated,
          fsc$get_open_information_req,
          static_file_contents(1, clp$trimmed_string_size (static_file_contents)), status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
          static_file_structure(1, clp$trimmed_string_size (static_file_structure)), status);
    IFEND;

  PROCEND fmp$get_open_information;
?? OLDTITLE ??

MODEND fmm$get_open_information;
*DECK DECK=FMM$GET_TAPE_LABEL_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File Management : Tape Label Attributes Retrieval' ??
MODULE fmm$get_tape_label_attributes;

{ PURPOSE:
{   This module contains the procedures that will either get the tape label
{   attributes of the last ansi file accessed or those that will be applied to
{   the next ansi file.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$device_class_validation
*copyc ame$tape_program_actions
*copyc fme$file_management_errors
*copyc fst$ansi_eof1_label
*copyc fst$ansi_hdr1_label
*copyc fst$ansi_hdr2_label
*copyc fst$ansi_vol1_label
*copyc fst$attachment_options
*copyc fst$evaluated_file_reference
*copyc fst$tape_attribute_source
*copyc fst$tla_returned_attributes
*copyc ost$status
?? POP ??

*copyc bap$after_trailer_labels
*copyc bap$merge_tape_attributes
*copyc bap$next_position_is_bos
*copyc bap$set_evaluated_file_abnormal
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_string_to_integer
*copyc fmp$adjust_file_set_pos_values
*copyc fmp$locate_cycle_description
*copyc fmp$lock_path_table
*copyc fmp$unlock_path_table
*copyc fsp$default_tape_label_attrib
*copyc fsp$expand_file_label
*copyc fsp$file_trailer_labels
*copyc fsp$locate_tape_label
*copyc fsp$path_element
*copyc fsp$version_two_tape_label
*copyc fsp$ve_wrote_ansi_file
*copyc i#move
*copyc osp$set_status_abnormal
*copyc pmp$get_user_identification

?? TITLE := 'fmp$get_tape_label_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$get_tape_label_attributes
    (    evaluated_file_reference: fst$evaluated_file_reference;
         source: fst$tape_attribute_source;
         rma_or_ring_privileged: boolean;
     VAR attributes {input, output} : fst$attachment_options;
     VAR returned_attributes: fst$tla_returned_attributes;
     VAR status: ost$status);

?? NEWTITLE := '  get_last_access_labels', EJECT ??

    PROCEDURE [INLINE] get_last_access_labels
      (VAR header_labels: ^SEQ ( * );
       VAR trailer_labels: ^SEQ ( * );
       VAR vol1_p: ^fst$ansi_vol1_label;
       VAR hdr1_p: ^fst$ansi_hdr1_label;
       VAR hdr2_p: ^fst$ansi_hdr2_label);

      VAR
        label_identifier: fst$tape_label_identifier,
        label_locator: fst$tape_label_locator;

      IF rma_or_ring_privileged THEN
        header_labels := tape_descriptor_p^.last_accessed.unsecured_header_labels;
        trailer_labels := tape_descriptor_p^.last_accessed.unsecured_trailer_labels;
      ELSE
        header_labels := tape_descriptor_p^.last_accessed.secured_header_labels;
        trailer_labels := tape_descriptor_p^.last_accessed.secured_trailer_labels;
      IFEND;

      IF header_labels = NIL THEN
        vol1_p := NIL;
        hdr1_p := NIL;
        hdr2_p := NIL;
        RETURN;
      IFEND;

      label_identifier.location_method := fsc$tape_label_locate_by_kind;
      label_identifier.label_kind := fsc$ansi_vol1_label_kind;
      fsp$locate_tape_label (header_labels, label_identifier, label_locator);
      IF label_locator.label_found THEN
        NEXT vol1_p IN label_locator.label_block;
      ELSE
        vol1_p := NIL;
      IFEND;

      label_identifier.label_kind := fsc$ansi_hdr1_label_kind;
      fsp$locate_tape_label (header_labels, label_identifier, label_locator);
      IF label_locator.label_found THEN
        NEXT hdr1_p IN label_locator.label_block;
      ELSE
        hdr1_p := NIL;
      IFEND;

      label_identifier.label_kind := fsc$ansi_hdr2_label_kind;
      fsp$locate_tape_label (header_labels, label_identifier, label_locator);
      IF label_locator.label_found THEN
        NEXT hdr2_p IN label_locator.label_block;
      ELSE
        hdr2_p := NIL;
      IFEND;

    PROCEND get_last_access_labels;
?? OLDTITLE ??
?? NEWTITLE := '  get_next_position_labels', EJECT ??

    PROCEDURE get_next_position_labels
      (VAR header_labels: ^SEQ ( * );
       VAR trailer_labels: ^SEQ ( * );
       VAR vol1_p: ^fst$ansi_vol1_label;
       VAR hdr1_p: ^fst$ansi_hdr1_label;
       VAR hdr2_p: ^fst$ansi_hdr2_label;
       VAR status: ost$status);

?? NEWTITLE := '    build_hdr1_block', EJECT ??

      PROCEDURE [INLINE] build_hdr1_block
        (VAR hdr1_p: ^fst$ansi_hdr1_label;
         VAR status: ost$status);

        VAR
          next_position_fsn: 0 .. 9999;

        NEXT hdr1_p IN header_labels;

        IF merged_attributes.file_identifier_source <> fsc$tape_label_attr_default THEN
          hdr1_p^.file_identifier := merged_attributes.file_identifier;
        ELSEIF (NOT bap$next_position_is_bos (merged_attributes.file_set_position, tape_descriptor_p,
              last_accessed_file_identifier, last_accessed_generation_number.value)) AND
              (last_accessed_file_identifier <> ' ') THEN
          hdr1_p^.file_identifier := last_accessed_file_identifier;
        ELSE
          hdr1_p^.file_identifier := fsp$path_element (^evaluated_file_reference,
                evaluated_file_reference.number_of_path_elements) ^;
        IFEND;

        IF bap$next_position_is_bos (merged_attributes.file_set_position, tape_descriptor_p,
              last_accessed_file_identifier, last_accessed_generation_number.value) THEN
          IF merged_attributes.file_set_identifier_source <> fsc$tape_label_attr_default THEN
            hdr1_p^.file_set_identifier := merged_attributes.file_set_identifier;
          ELSEIF initial_vol1_p <> NIL THEN
            IF (tape_descriptor_p^.next_position.file_section_number > 1) THEN
              IF initial_hdr1_p <> NIL THEN
                hdr1_p^.file_set_identifier := initial_hdr1_p^.file_set_identifier;
              IFEND;
            ELSE
              hdr1_p^.file_set_identifier := initial_vol1_p^.volume_identifier;
            IFEND;
          IFEND;
        ELSEIF initial_hdr1_p <> NIL THEN
          hdr1_p^.file_set_identifier := initial_hdr1_p^.file_set_identifier;
        IFEND;

        clp$convert_integer_to_rjstring (tape_descriptor_p^.next_position.file_section_number, 10, FALSE, '0',
              hdr1_p^.file_section_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        next_position_fsn := 0;
        IF cycle_description^.global_file_information^.open_count <> 0 THEN
          next_position_fsn := tape_descriptor_p^.next_position.file_sequence_number;
        ELSEIF (merged_attributes.file_set_position.position = fsc$tape_beginning_of_set) OR
              (last_accessed_hdr1_p = NIL) THEN
          next_position_fsn := 1;
        ELSE
          CASE merged_attributes.file_set_position.position OF
          = fsc$tape_end_of_set =
            IF tape_descriptor_p^.labeled_volume_position = bac$lvp_end_of_file_set THEN
              next_position_fsn := tape_descriptor_p^.next_position.file_sequence_number;
            IFEND;
          = fsc$tape_current_file =
            IF bap$after_trailer_labels (tape_descriptor_p^.labeled_volume_position) THEN
              next_position_fsn := tape_descriptor_p^.next_position.file_sequence_number - 1;
            ELSE
              next_position_fsn := tape_descriptor_p^.next_position.file_sequence_number;
            IFEND;
          = fsc$tape_file_sequence_pos =
            IF (bap$after_trailer_labels (tape_descriptor_p^.labeled_volume_position) AND
                  ((tape_descriptor_p^.next_position.file_sequence_number - 1) =
                  merged_attributes.file_set_position.file_sequence_number)) OR
                  (tape_descriptor_p^.next_position.file_sequence_number =
                  merged_attributes.file_set_position.file_sequence_number) THEN
              next_position_fsn := merged_attributes.file_set_position.file_sequence_number;
            IFEND;
          = fsc$tape_next_file =
            IF bap$after_trailer_labels (tape_descriptor_p^.labeled_volume_position) THEN
              next_position_fsn := tape_descriptor_p^.next_position.file_sequence_number;
            ELSE
              next_position_fsn := tape_descriptor_p^.next_position.file_sequence_number + 1;
            IFEND;
          = fsc$tape_file_identifier_pos =
            IF (merged_attributes.file_set_position.file_identifier =
                  last_accessed_file_identifier) AND (merged_attributes.file_set_position.
                  generation_number = last_accessed_generation_number.value) THEN
              IF bap$after_trailer_labels (tape_descriptor_p^.labeled_volume_position) THEN
                next_position_fsn := tape_descriptor_p^.next_position.file_sequence_number - 1;
              ELSE
                next_position_fsn := tape_descriptor_p^.next_position.file_sequence_number;
              IFEND;
            IFEND;
          ELSE
          CASEND;
        IFEND;
        IF next_position_fsn = 0 THEN
          hdr1_p^.file_sequence_number := ' ';
        ELSE
          clp$convert_integer_to_rjstring (next_position_fsn, 10, FALSE, '0', hdr1_p^.file_sequence_number,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF merged_attributes.generation_number_source <> fsc$tape_label_attr_default THEN
          clp$convert_integer_to_rjstring (merged_attributes.generation_number, 10, FALSE, '0',
                hdr1_p^.generation_number, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSEIF (NOT bap$next_position_is_bos (merged_attributes.file_set_position, tape_descriptor_p,
              last_accessed_file_identifier, last_accessed_generation_number.value)) AND
              (last_accessed_hdr1_p <> NIL) THEN
          hdr1_p^.generation_number := last_accessed_hdr1_p^.generation_number;
        IFEND;

        IF merged_attributes.generation_version_num_source <> fsc$tape_label_attr_default THEN
          clp$convert_integer_to_rjstring (merged_attributes.generation_version_number, 10, FALSE, '0',
                hdr1_p^.generation_version_number, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSEIF (NOT bap$next_position_is_bos (merged_attributes.file_set_position, tape_descriptor_p,
              last_accessed_file_identifier, last_accessed_generation_number.value)) AND
              (last_accessed_hdr1_p <> NIL) THEN
          hdr1_p^.generation_version_number := last_accessed_hdr1_p^.generation_version_number;
        IFEND;

        IF merged_attributes.creation_date_source <> fsc$tape_label_attr_default THEN
          IF merged_attributes.creation_date (1, 1) = '2' THEN
            hdr1_p^.creation_date (1, 1) := merged_attributes.creation_date (2, 1);
          IFEND;
          hdr1_p^.creation_date (2, 5) := merged_attributes.creation_date (3, 5);
        IFEND;

        IF merged_attributes.expiration_date_source <> fsc$tape_label_attr_default THEN
          IF merged_attributes.expiration_date (1, 1) = '2' THEN
            hdr1_p^.expiration_date (1, 1) := merged_attributes.expiration_date (2, 1);
          IFEND;
          hdr1_p^.expiration_date (2, 5) := merged_attributes.expiration_date (3, 5);
        IFEND;

        IF rma_or_ring_privileged THEN
          IF (merged_attributes.file_accessibility_source <> fsc$tape_label_attr_default) AND
                bap$next_position_is_bos (merged_attributes.file_set_position, tape_descriptor_p,
                last_accessed_file_identifier, last_accessed_generation_number.value) AND
                ((initial_hdr1_p = NIL) OR (initial_hdr1_p^.accessibility = ' ')) THEN
            hdr1_p^.accessibility := merged_attributes.file_accessibility;
          ELSEIF initial_hdr1_p <> NIL THEN
            hdr1_p^.accessibility := initial_hdr1_p^.accessibility;
          IFEND;
        ELSE
          hdr1_p^.accessibility := ' ';
        IFEND;

        IF (initial_hdr1_p <> NIL) AND fsp$ve_wrote_ansi_file (initial_hdr1_p^.system_code) THEN
          hdr1_p^.system_code := initial_hdr1_p^.system_code;
        IFEND;

      PROCEND build_hdr1_block;
?? OLDTITLE ??
?? NEWTITLE := '    build_hdr2_block', EJECT ??

      PROCEDURE [INLINE] build_hdr2_block
        (VAR hdr2_p: ^fst$ansi_hdr2_label;
         VAR status: ost$status);

        VAR
          block_length: string (8),
          initial_hdr2_p: ^fst$ansi_hdr2_label,
          initial_sequence_header_p: ^fst$tape_label_sequence_header,
          last_accessed_hdr2_p: ^fst$ansi_hdr2_label,
          record_length: string (8);

        NEXT hdr2_p IN header_labels;

        label_identifier.location_method := fsc$tape_label_locate_by_kind;
        label_identifier.label_kind := fsc$ansi_hdr2_label_kind;
        fsp$locate_tape_label (last_accessed_labels, label_identifier, label_locator);
        IF label_locator.label_found THEN
          NEXT last_accessed_hdr2_p IN label_locator.label_block;
        ELSE
          last_accessed_hdr2_p := NIL;
        IFEND;
        fsp$locate_tape_label (tape_descriptor_p^.initial_volume.header_labels, label_identifier,
              label_locator);
        IF label_locator.label_found THEN
          NEXT initial_hdr2_p IN label_locator.label_block;
        ELSE
          initial_hdr2_p := NIL;
        IFEND;

        CASE merged_attributes.record_type OF
        = amc$ansi_fixed =
          hdr2_p^.record_format := 'F';
        = amc$ansi_spanned =
          hdr2_p^.record_format := 'S';
        = amc$ansi_variable =
          hdr2_p^.record_format := 'D';
        ELSE
        CASEND;

        clp$convert_integer_to_rjstring (merged_attributes.max_block_length, 10, FALSE, '0', block_length,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        hdr2_p^.block_length := block_length (4, 5);
        hdr2_p^.ve_block_length_ext := block_length (1, 3);

        IF hdr2_p^.record_format = 'D' THEN
          hdr2_p^.record_length := '99999';
          hdr2_p^.ve_record_length_ext := '000';
        ELSEIF hdr2_p^.record_format = 'S' THEN
          hdr2_p^.record_length := '00000';
          hdr2_p^.ve_record_length_ext := '000';
        ELSE
          clp$convert_integer_to_rjstring (merged_attributes.max_record_length, 10, FALSE, '0', record_length,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          hdr2_p^.record_length := record_length (4, 5);
          hdr2_p^.ve_record_length_ext := record_length (1, 3);
        IFEND;

        IF merged_attributes.block_type = amc$system_specified THEN
          hdr2_p^.ve_block_type := 'SS';
        ELSE
          hdr2_p^.ve_block_type := 'US';
        IFEND;

        CASE merged_attributes.record_type OF
        = amc$variable =
          hdr2_p^.ve_record_type := 'V';
        = amc$undefined =
          hdr2_p^.ve_record_type := 'U';
        = amc$ansi_fixed =
          hdr2_p^.ve_record_type := 'F';
        = amc$ansi_spanned =
          hdr2_p^.ve_record_type := 'S';
        = amc$ansi_variable =
          hdr2_p^.ve_record_type := 'D';
        ELSE
        CASEND;

        hdr2_p^.ve_padding_character := merged_attributes.padding_character;

        IF (bap$next_position_is_bos (merged_attributes.file_set_position, tape_descriptor_p,
              last_accessed_file_identifier, last_accessed_generation_number.value) OR
              (tape_descriptor_p^.file_label_type = amc$unlabeled)) AND
              (merged_attributes.character_set_source <> fsc$tape_label_attr_default) THEN
          header_labels_seq_hdr^.character_set := merged_attributes.character_set;
        ELSEIF tape_descriptor_p^.initial_volume.header_labels <> NIL THEN
          RESET tape_descriptor_p^.initial_volume.header_labels;
          NEXT initial_sequence_header_p IN tape_descriptor_p^.initial_volume.header_labels;
          header_labels_seq_hdr^.character_set := initial_sequence_header_p^.character_set;
        IFEND;
        IF header_labels_seq_hdr^.character_set = amc$ascii THEN
          hdr2_p^.ve_character_set := 'A';
        ELSE
          hdr2_p^.ve_character_set := 'E';
        IFEND;

        IF merged_attributes.character_conversion THEN
          hdr2_p^.ve_character_conversion := 'T';
        ELSE
          hdr2_p^.ve_character_conversion := 'F';
        IFEND;

      PROCEND build_hdr2_block;
?? OLDTITLE ??
?? NEWTITLE := '    build_vol1_block', EJECT ??

      PROCEDURE [INLINE] build_vol1_block
        (VAR vol1_p: ^fst$ansi_vol1_label;
         VAR status: ost$status);

        VAR
          last_accessed_vol1_p: ^fst$ansi_vol1_label;

        NEXT vol1_p IN header_labels;
        IF initial_vol1_p <> NIL THEN
          vol1_p^ := initial_vol1_p^;
          label_identifier.location_method := fsc$tape_label_locate_by_kind;
          label_identifier.label_kind := fsc$ansi_vol1_label_kind;
          fsp$locate_tape_label (last_accessed_labels, label_identifier, label_locator);
          IF label_locator.label_found THEN
            NEXT last_accessed_vol1_p IN label_locator.label_block;
            vol1_p^.volume_identifier := last_accessed_vol1_p^.volume_identifier;
          IFEND;

          IF rma_or_ring_privileged THEN
            pmp$get_user_identification (user_id, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF bap$next_position_is_bos (merged_attributes.file_set_position, tape_descriptor_p,
                  last_accessed_file_identifier, last_accessed_generation_number.value) AND
                  (initial_vol1_p^.accessibility = ' ') THEN
              IF merged_attributes.volume_accessibility_source = fsc$tape_label_attr_default THEN
                IF ((initial_hdr1_p <> NIL) AND (fsp$version_two_tape_label (initial_hdr1_p^.system_code) OR
                      (NOT fsp$ve_wrote_ansi_file (initial_hdr1_p^.system_code) AND
                      tape_descriptor_p^.initial_volume.classification.labeled.blank))) OR
                      ((initial_hdr1_p = NIL) AND (tape_descriptor_p^.initial_volume.classification.labeled.
                      blank OR fsp$version_two_tape_label (initial_vol1_p^.implementation_identifier))) THEN
                  IF (initial_vol1_p^.owner_identifier = ' ') OR (initial_vol1_p^.owner_identifier =
                        user_id.user (1, 14)) THEN
                    vol1_p^.accessibility := 'A';
                  IFEND;
                IFEND;
              ELSE
                vol1_p^.accessibility := merged_attributes.volume_accessibility;
              IFEND;
            IFEND;

            IF bap$next_position_is_bos (merged_attributes.file_set_position, tape_descriptor_p,
                  last_accessed_file_identifier, last_accessed_generation_number.value) AND
                  (initial_vol1_p^.owner_identifier = ' ') THEN
              IF ((initial_hdr1_p <> NIL) AND (vol1_p^.accessibility = 'A') AND
                    (fsp$version_two_tape_label (initial_hdr1_p^.system_code) OR
                    (NOT fsp$ve_wrote_ansi_file (initial_hdr1_p^.system_code) AND
                    tape_descriptor_p^.initial_volume.classification.labeled.blank))) OR
                    ((initial_hdr1_p = NIL) AND (tape_descriptor_p^.initial_volume.classification.labeled.
                    blank OR fsp$version_two_tape_label (initial_vol1_p^.implementation_identifier))) THEN
                IF merged_attributes.removable_media_group_source <> fsc$tape_label_attr_default THEN
                  vol1_p^.owner_identifier (1, 1) := '&';
                  vol1_p^.owner_identifier (2, 13) := merged_attributes.removable_media_group;
                ELSE
                  vol1_p^.owner_identifier := user_id.user (1, 14);
                IFEND;
              ELSEIF merged_attributes.owner_identifier_source <> fsc$tape_label_attr_default THEN
                vol1_p^.owner_identifier := merged_attributes.owner_identifier;
              IFEND;
            IFEND;
          ELSE { not rma_or_ring_privileged }
            vol1_p^.accessibility := ' ';
            vol1_p^.owner_identifier := ' ';
          IFEND;
        ELSE { tape labels have not yet been read }
          IF rma_or_ring_privileged THEN
            IF merged_attributes.volume_accessibility_source <> fsc$tape_label_attr_default THEN
              vol1_p^.accessibility := merged_attributes.volume_accessibility;
            IFEND;
            IF merged_attributes.owner_identifier_source <> fsc$tape_label_attr_default THEN
              vol1_p^.owner_identifier := merged_attributes.owner_identifier;
            ELSEIF merged_attributes.removable_media_group_source <> fsc$tape_label_attr_default THEN
              vol1_p^.owner_identifier (1, 1) := '&';
              vol1_p^.owner_identifier (2, 13) := merged_attributes.removable_media_group;
            IFEND;
          ELSE { not rma_or_ring_privileged }
            vol1_p^.accessibility := ' ';
          IFEND;

          IF merged_attributes.system_code_source <> fsc$tape_label_attr_default THEN
            vol1_p^.label_standard_version := merged_attributes.label_standard_version;
          IFEND;
        IFEND;

      PROCEND build_vol1_block;
?? OLDTITLE, EJECT ??

      VAR
        block_descriptor: ^fst$tape_label_block_descriptor,
        block_number: fst$tape_label_count,
        eof1_p: ^fst$ansi_eof1_label,
        eof2_p: ^fst$ansi_eof2_label,
        header_labels_seq_hdr: ^fst$tape_label_sequence_header,
        initial_hdr1_p: ^fst$ansi_hdr1_label,
        initial_vol1_p: ^fst$ansi_vol1_label,
        label_identifier: fst$tape_label_identifier,
        label_locator: fst$tape_label_locator,
        last_accessed_file_identifier: string (17),
        last_accessed_generation_number: clt$integer,
        last_accessed_hdr1_p: ^fst$ansi_hdr1_label,
        last_accessed_hdr2_p: ^fst$ansi_hdr2_label,
        last_accessed_labels: ^SEQ ( * ),
        trailer_labels_seq_hdr: ^fst$tape_label_sequence_header,
        user_id: ost$user_identification;

      RESET header_labels;
      NEXT header_labels_seq_hdr IN header_labels;

      IF rma_or_ring_privileged THEN
        last_accessed_labels := tape_descriptor_p^.last_accessed.unsecured_header_labels;
      ELSE
        last_accessed_labels := tape_descriptor_p^.last_accessed.secured_header_labels;
      IFEND;

{ Build header labels

      label_identifier.location_method := fsc$tape_label_locate_by_kind;
      label_identifier.label_kind := fsc$ansi_vol1_label_kind;
      fsp$locate_tape_label (tape_descriptor_p^.initial_volume.header_labels, label_identifier,
            label_locator);
      IF label_locator.label_found THEN
        NEXT initial_vol1_p IN label_locator.label_block;
      ELSE
        initial_vol1_p := NIL;
      IFEND;

      label_identifier.label_kind := fsc$ansi_hdr1_label_kind;
      fsp$locate_tape_label (tape_descriptor_p^.initial_volume.header_labels, label_identifier,
            label_locator);
      IF label_locator.label_found THEN
        NEXT initial_hdr1_p IN label_locator.label_block;
      ELSE
        initial_hdr1_p := NIL;
      IFEND;

      label_identifier.location_method := fsc$tape_label_locate_by_kind;
      label_identifier.label_kind := fsc$ansi_hdr1_label_kind;
      fsp$locate_tape_label (last_accessed_labels, label_identifier, label_locator);
      IF label_locator.label_found THEN
        NEXT last_accessed_hdr1_p IN label_locator.label_block;
        last_accessed_file_identifier := last_accessed_hdr1_p^.file_identifier;
        IF last_accessed_hdr1_p^.generation_number <> ' ' THEN
          clp$convert_string_to_integer (last_accessed_hdr1_p^.generation_number,
                last_accessed_generation_number, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          last_accessed_generation_number.value := 1;
        IFEND;
      ELSE
        last_accessed_hdr1_p := NIL;
        last_accessed_file_identifier := ' ';
        last_accessed_generation_number.value := 1;
      IFEND;

      fmp$adjust_file_set_pos_values (merged_attributes);

{ Adjust max block length value

      IF merged_attributes.block_type = amc$system_specified THEN
        IF tape_descriptor_p^.requested_density = rmc$38000 THEN
          merged_attributes.max_block_length := 32640;
        ELSE
          merged_attributes.max_block_length := 4128;
        IFEND;
      IFEND;

{ It is assumed that the header labels returned by fsp$default_tape_label_attrib includes a
{ VOL1, HDR1, HDR2, and a single tapemark, in sequence.

      FOR block_number := 1 TO header_labels_seq_hdr^.label_count - 1 DO
        NEXT block_descriptor IN header_labels;
        CASE block_descriptor^.normal_label_kind OF
        = fsc$ansi_vol1_label_kind =
          build_vol1_block (vol1_p, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        = fsc$ansi_hdr1_label_kind =
          build_hdr1_block (hdr1_p, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        = fsc$ansi_hdr2_label_kind =
          build_hdr2_block (hdr2_p, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
        CASEND;
      FOREND;

{ Build trailer labels

      RESET trailer_labels;
      NEXT trailer_labels_seq_hdr IN trailer_labels;
      trailer_labels_seq_hdr^.character_set := header_labels_seq_hdr^.character_set;

      label_identifier.location_method := fsc$tape_label_locate_by_kind;
      label_identifier.label_kind := fsc$ansi_eof1_label_kind;
      fsp$locate_tape_label (trailer_labels, label_identifier, label_locator);
      IF label_locator.label_found THEN
        NEXT eof1_p IN label_locator.label_block;
      IFEND;

      label_identifier.label_kind := fsc$ansi_eof2_label_kind;
      fsp$locate_tape_label (trailer_labels, label_identifier, label_locator);
      IF label_locator.label_found THEN
        NEXT eof2_p IN label_locator.label_block;
      IFEND;

      eof1_p^ := hdr1_p^;
      eof2_p^ := hdr2_p^;
      IF cycle_description^.global_file_information^.open_count <> 0 THEN
        IF last_accessed_hdr1_p <> NIL THEN
          eof1_p^ := last_accessed_hdr1_p^;
        IFEND;

        label_identifier.label_kind := fsc$ansi_hdr2_label_kind;
        fsp$locate_tape_label (last_accessed_labels, label_identifier, label_locator);
        IF label_locator.label_found THEN
          NEXT last_accessed_hdr2_p IN label_locator.label_block;
          eof2_p^ := last_accessed_hdr2_p^;
        IFEND;
      IFEND;

      eof1_p^.label_identifier := 'EOF';
      eof2_p^.label_identifier := 'EOF';

    PROCEND get_next_position_labels;
?? OLDTITLE, EJECT ??

    VAR
      attachment_option: fst$file_attachment_choices,
      cycle_description: ^fmt$cycle_description,
      default_attributes: array [1 .. 2] of fst$attachment_option,
      eof1_eov1_p: ^fst$ansi_eof1_label,
      hdr1_p: ^fst$ansi_hdr1_label,
      hdr2_p: ^fst$ansi_hdr2_label,
      ignore_file_previously_opened: boolean,
      int: clt$integer,
      header_labels: ^SEQ ( * ),
      label_identifier: fst$tape_label_identifier,
      label_locator: fst$tape_label_locator,
      last_accessed_hdr1_p: ^fst$ansi_hdr1_label, {used by get_next_position_labels and figuring by_name fsn}
      length: string (8),
      local_evaluated_file_reference: fst$evaluated_file_reference,
      merged_attributes: fst$tape_attachment_information,
      path_table_locked: boolean,
      returned_default_attributes: fst$tla_returned_attributes,
      sequence_header: ^fst$tape_label_sequence_header,
      setfa_attributes: bat$static_label_attributes,
      tape_descriptor_p: ^bat$tape_descriptor,
      trailer_labels: ^SEQ ( * ),
      use_hdr1_fsn: boolean,
      vol1_p: ^fst$ansi_vol1_label;

    status.normal := TRUE;
    local_evaluated_file_reference := evaluated_file_reference;
    fmp$locate_cycle_description (local_evaluated_file_reference, cycle_description, status);

    path_table_locked := status.normal;
    IF NOT status.normal THEN
      IF status.condition = fme$no_cycle_description THEN
        cycle_description := NIL;
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

  /get_attributes/
    BEGIN
      IF (cycle_description = NIL) OR NOT cycle_description^.attached_file THEN
        bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_attachment_required,
              'FSP$GET_TAPE_LABEL_ATTRIBUTES', '', status);
        EXIT /get_attributes/;
      IFEND;

      IF cycle_description^.device_class <> rmc$magnetic_tape_device THEN
        bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_device_class,
              'FSP$GET_TAPE_LABEL_ATTRIBUTES', 'MASS_STORAGE/NULL/TERMINAL', status);
        EXIT /get_attributes/;
      IFEND;

      returned_attributes := $fst$tla_returned_attributes [];

      IF cycle_description^.global_file_information^.device_dependent_info.tape_descriptor <> NIL THEN
        RESET cycle_description^.global_file_information^.device_dependent_info.tape_descriptor;
        NEXT tape_descriptor_p IN cycle_description^.global_file_information^.device_dependent_info.
              tape_descriptor;
        IF tape_descriptor_p = NIL THEN
          osp$set_status_abnormal ('FM', fme$system_error, ' NIL tape_descriptor IN fmp$get_attributes',
                status);
          EXIT /get_attributes/;
        IFEND;

        IF cycle_description^.global_file_information^.open_count = 0 THEN
          merged_attributes := tape_descriptor_p^.tape_label_attr_command_info;
          IF cycle_description^.static_setfa_entries <> NIL THEN
            fsp$expand_file_label (cycle_description^.static_setfa_entries, setfa_attributes,
                  ignore_file_previously_opened, status);
            IF NOT status.normal THEN
              EXIT /get_attributes/;
            IFEND;
            bap$merge_tape_attributes (NIL, NIL, merged_attributes, setfa_attributes);
          IFEND;
        ELSE
          merged_attributes := tape_descriptor_p^.tape_attachment_information;
        IFEND;

        IF source = fsc$tla_last_ansi_file_accessed THEN
          get_last_access_labels (header_labels, trailer_labels, vol1_p, hdr1_p, hdr2_p);
          IF (header_labels = NIL) AND (trailer_labels = NIL) THEN
            EXIT /get_attributes/;
          IFEND;
        ELSE { fsc$tla_next_position }
          default_attributes [1].selector := fsc$tape_attachment;
          default_attributes [1].tape_attachment.selector := fsc$tape_header_labels;
          PUSH default_attributes [1].tape_attachment.tape_header_labels:
                [[REP 1 OF fst$tape_label_sequence_header, REP 4 OF fst$tape_label_block_descriptor,
                REP 1 OF fst$ansi_vol1_label, REP 1 OF fst$ansi_hdr1_label, REP 1 OF fst$ansi_hdr2_label]];
          default_attributes [2].selector := fsc$tape_attachment;
          default_attributes [2].tape_attachment.selector := fsc$tape_trailer_labels;
          PUSH default_attributes [2].tape_attachment.tape_trailer_labels:
                [[REP 1 OF fst$tape_label_sequence_header, REP 4 OF fst$tape_label_block_descriptor,
                REP 1 OF fst$ansi_eof1_label, REP 1 OF fst$ansi_eof2_label]];
          fsp$default_tape_label_attrib (fsc$tla_system_default, default_attributes,
                returned_default_attributes, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          header_labels := default_attributes [1].tape_attachment.tape_header_labels;
          trailer_labels := default_attributes [2].tape_attachment.tape_trailer_labels;

          get_next_position_labels (header_labels, trailer_labels, vol1_p, hdr1_p, hdr2_p, status);
          IF NOT status.normal THEN
            EXIT /get_attributes/;
          IFEND;
        IFEND;

        FOR attachment_option := 1 TO UPPERBOUND (attributes) DO
          IF attributes [attachment_option].selector = fsc$tape_attachment THEN
            CASE attributes [attachment_option].tape_attachment.selector OF
            = fsc$tape_block_count =
              IF trailer_labels <> NIL THEN
                RESET trailer_labels;
                NEXT sequence_header IN trailer_labels;
                label_identifier.location_method := fsc$tape_label_locate_by_kind;
                IF fsp$file_trailer_labels (sequence_header^.label_kinds) THEN
                  label_identifier.label_kind := fsc$ansi_eof1_label_kind;
                ELSE
                  label_identifier.label_kind := fsc$ansi_eov1_label_kind;
                IFEND;
                fsp$locate_tape_label (trailer_labels, label_identifier, label_locator);
                IF label_locator.label_found THEN
                  NEXT eof1_eov1_p IN label_locator.label_block;
                  IF eof1_eov1_p^.block_count <> ' ' THEN
                    clp$convert_string_to_integer (eof1_eov1_p^.block_count, int, status);
                    IF NOT status.normal THEN
                      EXIT /get_attributes/;
                    IFEND;
                    attributes [attachment_option].tape_attachment.tape_block_count := int.value;
                    returned_attributes := returned_attributes + $fst$tla_returned_attributes
                          [attributes [attachment_option].tape_attachment.selector];
                  IFEND;
                IFEND;
              IFEND;

            = fsc$tape_block_type =
              IF hdr1_p <> NIL THEN
                IF fsp$ve_wrote_ansi_file (hdr1_p^.system_code) THEN
                  IF (hdr2_p <> NIL) AND (hdr2_p^.ve_block_type <> ' ') THEN
                    IF hdr2_p^.ve_block_type = 'SS' THEN
                      attributes [attachment_option].tape_attachment.tape_block_type := amc$system_specified;
                    ELSE { US }
                      attributes [attachment_option].tape_attachment.tape_block_type := amc$user_specified;
                    IFEND;
                    returned_attributes := returned_attributes + $fst$tla_returned_attributes
                          [attributes [attachment_option].tape_attachment.selector];
                  IFEND;
                ELSE
                  attributes [attachment_option].tape_attachment.tape_block_type := amc$user_specified;
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                IFEND;
              ELSEIF hdr2_p <> NIL THEN
                attributes [attachment_option].tape_attachment.tape_block_type := amc$user_specified;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;
              IF NOT (fsc$tape_block_type IN returned_attributes) AND
                    (source = fsc$tla_last_ansi_file_accessed) AND
                    (cycle_description^.global_file_information^.open_count > 0) THEN
                attributes [attachment_option].tape_attachment.tape_block_type :=
                      merged_attributes.block_type;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_buffer_offset =
              IF (hdr2_p <> NIL) AND (hdr2_p^.buffer_offset_length <> ' ') THEN
                clp$convert_string_to_integer (hdr2_p^.buffer_offset_length, int, status);
                IF NOT status.normal THEN
                  EXIT /get_attributes/;
                IFEND;
                attributes [attachment_option].tape_attachment.tape_buffer_offset := int.value;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_character_conversion =
              IF (hdr1_p <> NIL) AND fsp$ve_wrote_ansi_file (hdr1_p^.system_code) AND (hdr2_p <> NIL) AND
                    (hdr2_p^.ve_character_conversion <> ' ') THEN
                attributes [attachment_option].tape_attachment.tape_character_conversion :=
                      hdr2_p^.ve_character_conversion = 'T';
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              ELSEIF (source = fsc$tla_last_ansi_file_accessed) AND
                    (cycle_description^.global_file_information^.open_count > 0) THEN
                attributes [attachment_option].tape_attachment.tape_character_conversion :=
                      merged_attributes.character_conversion;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_character_set =
              IF (hdr2_p <> NIL) AND (hdr2_p^.ve_character_set <> ' ') THEN
                IF hdr2_p^.ve_character_set = 'A' THEN
                  attributes [attachment_option].tape_attachment.tape_character_set := amc$ascii;
                ELSE
                  attributes [attachment_option].tape_attachment.tape_character_set := amc$ebcdic;
                IFEND;
              ELSE
                NEXT sequence_header IN header_labels;
                attributes [attachment_option].tape_attachment.tape_character_set :=
                      sequence_header^.character_set;
              IFEND;
              returned_attributes := returned_attributes + $fst$tla_returned_attributes
                    [attributes [attachment_option].tape_attachment.selector];

            = fsc$tape_creation_date =
              IF (hdr1_p <> NIL) AND (hdr1_p^.creation_date <> ' ') THEN
                IF hdr1_p^.creation_date (1, 1) = ' ' THEN
                  attributes [attachment_option].tape_attachment.tape_creation_date (1, 2) := '19';
                ELSE
                  attributes [attachment_option].tape_attachment.tape_creation_date (1, 1) := '2';
                  attributes [attachment_option].tape_attachment.tape_creation_date (2, 1) :=
                        hdr1_p^.creation_date (1, 1);
                IFEND;
                attributes [attachment_option].tape_attachment.tape_creation_date (3, 5) :=
                      hdr1_p^.creation_date (2, 5);
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_expiration_date =
              IF (hdr1_p <> NIL) AND (hdr1_p^.expiration_date <> ' ') THEN
                IF hdr1_p^.expiration_date (1, 1) = ' ' THEN
                  IF hdr1_p^.expiration_date (2, 5) = '00000' THEN
                    attributes [attachment_option].tape_attachment.tape_expiration_date (1, 2) := '  ';
                  ELSE
                    attributes [attachment_option].tape_attachment.tape_expiration_date (1, 2) := '19';
                  IFEND;
                  attributes [attachment_option].tape_attachment.tape_expiration_date (3, 5) :=
                        hdr1_p^.expiration_date (2, 5);
                ELSE
                  attributes [attachment_option].tape_attachment.tape_expiration_date (1, 1) := '2';
                  attributes [attachment_option].tape_attachment.tape_expiration_date (2, 6) :=
                        hdr1_p^.expiration_date (1, 6);
                IFEND;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_file_accessibility =
              IF rma_or_ring_privileged THEN
                IF hdr1_p <> NIL THEN
                  attributes [attachment_option].tape_attachment.tape_file_accessibility :=
                        hdr1_p^.accessibility;
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                IFEND;
              ELSE
                bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$security_conflict, '',
                      'FILE_ACCESSIBILITY', status);
                EXIT /get_attributes/;
              IFEND;

            = fsc$tape_file_identifier =
              IF hdr1_p <> NIL THEN
                attributes [attachment_option].tape_attachment.tape_file_identifier :=
                      hdr1_p^.file_identifier;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_file_section_number =
              IF hdr1_p <> NIL THEN
                clp$convert_string_to_integer (hdr1_p^.file_section_number, int, status);
                IF NOT status.normal THEN
                  EXIT /get_attributes/;
                IFEND;
                attributes [attachment_option].tape_attachment.tape_file_section_number := int.value;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_file_sequence_number =
              IF source = fsc$tla_last_ansi_file_accessed THEN
                IF hdr1_p <> NIL THEN
                  IF hdr1_p^.file_sequence_number <> ' ' THEN
                    clp$convert_string_to_integer (hdr1_p^.file_sequence_number, int, status);
                    IF NOT status.normal THEN
                      EXIT /get_attributes/;
                    IFEND;
                    use_hdr1_fsn := (tape_descriptor_p^.next_position.file_sequence_number - int.value) <= 1;
                  ELSE
                    use_hdr1_fsn := FALSE;
                  IFEND;
                  IF use_hdr1_fsn THEN
                    attributes [attachment_option].tape_attachment.tape_file_sequence_number := int.value;
                  ELSEIF bap$after_trailer_labels (tape_descriptor_p^.labeled_volume_position) AND
                        (tape_descriptor_p^.next_position.file_sequence_number > 1) THEN
                    attributes [attachment_option].tape_attachment.tape_file_sequence_number :=
                          tape_descriptor_p^.next_position.file_sequence_number - 1;
                  ELSE
                    attributes [attachment_option].tape_attachment.tape_file_sequence_number :=
                          tape_descriptor_p^.next_position.file_sequence_number;
                  IFEND;
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                IFEND;
              ELSE { next_position }
                IF hdr1_p^.file_sequence_number <> ' ' THEN
                  clp$convert_string_to_integer (hdr1_p^.file_sequence_number, int, status);
                  IF NOT status.normal THEN
                    EXIT /get_attributes/;
                  IFEND;
                  attributes [attachment_option].tape_attachment.tape_file_sequence_number := int.value;
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                IFEND;
              IFEND;

            = fsc$tape_file_set_identifier =
              IF hdr1_p <> NIL THEN
                attributes [attachment_option].tape_attachment.tape_file_set_identifier :=
                      hdr1_p^.file_set_identifier;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_file_set_position =
              IF source = fsc$tla_next_position THEN
                attributes [attachment_option].tape_attachment.tape_file_set_position :=
                      merged_attributes.file_set_position;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_generation_number =
              IF (hdr1_p <> NIL) AND (hdr1_p^.generation_number <> ' ') THEN
                clp$convert_string_to_integer (hdr1_p^.generation_number, int, status);
                IF NOT status.normal THEN
                  EXIT /get_attributes/;
                IFEND;
                attributes [attachment_option].tape_attachment.tape_generation_number := int.value;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_generation_version_num =
              IF (hdr1_p <> NIL) AND (hdr1_p^.generation_version_number <> ' ') THEN
                clp$convert_string_to_integer (hdr1_p^.generation_version_number, int, status);
                IF NOT status.normal THEN
                  EXIT /get_attributes/;
                IFEND;
                attributes [attachment_option].tape_attachment.tape_generation_version_num := int.value;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_header_labels =
              IF (attributes [attachment_option].tape_attachment.tape_header_labels <> NIL) AND
                    (header_labels <> NIL) THEN
                IF #SIZE (attributes [attachment_option].tape_attachment.tape_header_labels^) >=
                      #SIZE (header_labels^) THEN
                  i#move (header_labels, attributes [attachment_option].tape_attachment.
                        tape_header_labels, #SIZE (header_labels^));
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                ELSEIF #SIZE (attributes [attachment_option].tape_attachment.tape_header_labels^) >=
                      #SIZE (fst$tape_label_sequence_header) THEN
                  i#move (header_labels, attributes [attachment_option].tape_attachment.
                        tape_header_labels, #SIZE (fst$tape_label_sequence_header));
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                  bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$only_seq_header_returned,
                        'FSP$GET_TAPE_LABEL_ATTRIBUTES', 'HEADER', status);
                ELSE
                  bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$label_sequence_too_small,
                        'FSP$GET_TAPE_LABEL_ATTRIBUTES', 'HEADER', status);
                IFEND;
              IFEND;

            = fsc$tape_implementation_id =
              IF hdr1_p <> NIL THEN
                attributes [attachment_option].tape_attachment.tape_implementation_id := hdr1_p^.system_code;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_label_standard_version =
              IF (vol1_p <> NIL) AND (vol1_p^.label_standard_version <> ' ') THEN
                clp$convert_string_to_integer (vol1_p^.label_standard_version, int, status);
                IF NOT status.normal THEN
                  EXIT /get_attributes/;
                IFEND;
                attributes [attachment_option].tape_attachment.tape_label_standard_version := int.value;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_max_block_length =
              IF (hdr1_p <> NIL) AND (hdr2_p <> NIL) THEN
                IF fsp$ve_wrote_ansi_file (hdr1_p^.system_code) AND (hdr2_p^.ve_block_length_ext <> ' ') THEN
                  length (1, 3) := hdr2_p^.ve_block_length_ext;
                  length (4, 5) := hdr2_p^.block_length;
                  clp$convert_string_to_integer (length, int, status);
                  IF NOT status.normal THEN
                    EXIT /get_attributes/;
                  IFEND;
                  IF int.value <> 0 THEN
                    attributes [attachment_option].tape_attachment.tape_max_block_length := int.value;
                    returned_attributes := returned_attributes + $fst$tla_returned_attributes
                          [attributes [attachment_option].tape_attachment.selector];
                  IFEND;
                ELSEIF (hdr2_p^.block_length <> ' ') AND (hdr2_p^.block_length <> '00000') THEN
                  clp$convert_string_to_integer (hdr2_p^.block_length, int, status);
                  IF NOT status.normal THEN
                    EXIT /get_attributes/;
                  IFEND;
                  attributes [attachment_option].tape_attachment.tape_max_block_length := int.value;
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                IFEND;
              IFEND;
              IF NOT (fsc$tape_max_block_length IN returned_attributes) AND
                    (source = fsc$tla_last_ansi_file_accessed) AND
                    (cycle_description^.global_file_information^.open_count > 0) THEN
                attributes [attachment_option].tape_attachment.tape_max_block_length :=
                      merged_attributes.max_block_length;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_max_record_length =
              IF (hdr1_p <> NIL) AND (hdr2_p <> NIL) THEN
                IF fsp$ve_wrote_ansi_file (hdr1_p^.system_code) AND (hdr2_p^.ve_record_length_ext <> ' ') THEN
                  length (1, 3) := hdr2_p^.ve_record_length_ext;
                  length (4, 5) := hdr2_p^.record_length;
                  clp$convert_string_to_integer (length, int, status);
                  IF NOT status.normal THEN
                    EXIT /get_attributes/;
                  IFEND;
                  attributes [attachment_option].tape_attachment.tape_max_record_length := int.value;
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                ELSEIF hdr2_p^.record_length <> ' ' THEN
                  clp$convert_string_to_integer (hdr2_p^.record_length, int, status);
                  IF NOT status.normal THEN
                    EXIT /get_attributes/;
                  IFEND;
                  attributes [attachment_option].tape_attachment.tape_max_record_length := int.value;
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                IFEND;
              IFEND;
              IF NOT (fsc$tape_max_record_length IN returned_attributes) AND
                    (source = fsc$tla_last_ansi_file_accessed) AND
                    (cycle_description^.global_file_information^.open_count > 0) THEN
                attributes [attachment_option].tape_attachment.tape_max_record_length :=
                      merged_attributes.max_record_length;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_null_attachment_option =
              ;

            = fsc$tape_owner_identification =
              IF rma_or_ring_privileged THEN
                IF (vol1_p <> NIL) AND ((hdr1_p = NIL) OR (NOT fsp$ve_wrote_ansi_file
                      (hdr1_p^.system_code)) OR (vol1_p^.accessibility <> 'A') OR
                      (vol1_p^.owner_identifier (1, 1) <> '&')) THEN
                  attributes [attachment_option].tape_attachment.tape_owner_identification :=
                        vol1_p^.owner_identifier;
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                IFEND;
              ELSE
                bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$security_conflict, '',
                      'OWNER_IDENTIFICATION', status);
                EXIT /get_attributes/;
              IFEND;

            = fsc$tape_padding_character =
              IF (hdr1_p <> NIL) AND fsp$ve_wrote_ansi_file (hdr1_p^.system_code) AND (hdr2_p <> NIL) THEN
                attributes [attachment_option].tape_attachment.tape_padding_character :=
                      hdr2_p^.ve_padding_character (1);
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              ELSEIF (source = fsc$tla_last_ansi_file_accessed) AND
                    (cycle_description^.global_file_information^.open_count > 0) THEN
                attributes [attachment_option].tape_attachment.tape_padding_character :=
                      merged_attributes.padding_character;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_record_type =
              IF (hdr1_p <> NIL) AND fsp$ve_wrote_ansi_file (hdr1_p^.system_code) THEN
                IF (hdr2_p <> NIL) AND (hdr2_p^.ve_record_type <> ' ') THEN
                  IF hdr2_p^.ve_record_type = 'V' THEN
                    attributes [attachment_option].tape_attachment.tape_record_type := amc$variable;
                  ELSEIF hdr2_p^.ve_record_type = 'U' THEN
                    attributes [attachment_option].tape_attachment.tape_record_type := amc$undefined;
                  ELSEIF hdr2_p^.ve_record_type = 'F' THEN
                    attributes [attachment_option].tape_attachment.tape_record_type := amc$ansi_fixed;
                  ELSEIF hdr2_p^.ve_record_type = 'S' THEN
                    attributes [attachment_option].tape_attachment.tape_record_type := amc$ansi_spanned;
                  ELSEIF hdr2_p^.ve_record_type = 'D' THEN
                    attributes [attachment_option].tape_attachment.tape_record_type := amc$ansi_variable;
                  IFEND;
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                IFEND;
              ELSEIF (hdr2_p <> NIL) AND (hdr2_p^.record_format <> ' ') THEN
                IF hdr2_p^.record_format = 'F' THEN
                  attributes [attachment_option].tape_attachment.tape_record_type := amc$ansi_fixed;
                ELSEIF hdr2_p^.record_format = 'S' THEN
                  attributes [attachment_option].tape_attachment.tape_record_type := amc$ansi_spanned;
                ELSEIF hdr2_p^.record_format = 'D' THEN
                  attributes [attachment_option].tape_attachment.tape_record_type := amc$ansi_variable;
                ELSE
                  attributes [attachment_option].tape_attachment.tape_record_type := amc$undefined;
                IFEND;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;
              IF NOT (fsc$tape_record_type IN returned_attributes) AND
                    (source = fsc$tla_last_ansi_file_accessed) AND
                    (cycle_description^.global_file_information^.open_count > 0) THEN
                attributes [attachment_option].tape_attachment.tape_record_type :=
                      merged_attributes.record_type;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_removable_media_group =
              IF rma_or_ring_privileged THEN
                IF (vol1_p <> NIL) AND (hdr1_p <> NIL) AND fsp$ve_wrote_ansi_file (hdr1_p^.system_code) AND
                      (vol1_p^.accessibility = 'A') AND (vol1_p^.owner_identifier (1, 1) = '&') THEN
                  attributes [attachment_option].tape_attachment.tape_removable_media_group :=
                        vol1_p^.owner_identifier (2, * );
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                IFEND;
              ELSE
                bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$security_conflict, '',
                      'REMOVABLE_MEDIA_GROUP', status);
                EXIT /get_attributes/;
              IFEND;

            = fsc$tape_rewrite_labels =
              IF source = fsc$tla_next_position THEN
                attributes [attachment_option].tape_attachment.tape_rewrite_labels :=
                      merged_attributes.rewrite_labels;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_trailer_labels =
              IF (attributes [attachment_option].tape_attachment.tape_trailer_labels <> NIL) AND
                    (trailer_labels <> NIL) THEN
                IF #SIZE (attributes [attachment_option].tape_attachment.tape_trailer_labels^) >=
                      #SIZE (trailer_labels^) THEN
                  i#move (trailer_labels, attributes [attachment_option].tape_attachment.
                        tape_trailer_labels, #SIZE (trailer_labels^));
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                ELSEIF #SIZE (attributes [attachment_option].tape_attachment.tape_trailer_labels^) >=
                      #SIZE (fst$tape_label_sequence_header) THEN
                  i#move (trailer_labels, attributes [attachment_option].tape_attachment.
                        tape_trailer_labels, #SIZE (fst$tape_label_sequence_header));
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                  bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$only_seq_header_returned,
                        'FSP$GET_TAPE_LABEL_ATTRIBUTES', 'TRAILER', status);
                ELSE
                  bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$label_sequence_too_small,
                        'FSP$GET_TAPE_LABEL_ATTRIBUTES', 'TRAILER', status);
                IFEND;
              IFEND;

            = fsc$tape_volume_accessibility =
              IF rma_or_ring_privileged THEN
                IF vol1_p <> NIL THEN
                  attributes [attachment_option].tape_attachment.tape_volume_accessibility :=
                        vol1_p^.accessibility;
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                IFEND;
              ELSE
                bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$security_conflict, '',
                      'VOLUME_ACCESSIBILITY', status);
                EXIT /get_attributes/;
              IFEND;

            ELSE
              ;
            CASEND;

          IFEND;
        FOREND;
      IFEND; { tape_descriptor <> NIL }

    END /get_attributes/;

    IF path_table_locked THEN
      fmp$unlock_path_table;
    IFEND;

  PROCEND fmp$get_tape_label_attributes;
MODEND fmm$get_tape_label_attributes;
*DECK DECK=FMM$GET_TAPE_LABEL_CMD_ATTRIB EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File Management : Tape Label Attributes Retrieval' ??
MODULE fmm$get_tape_label_cmd_attrib;

{ PURPOSE:
{   This module contains the procedure that gets the tape label attributes
{   defined by the CHATLA command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$device_class_validation
*copyc ame$tape_program_actions
*copyc fme$file_management_errors
*copyc fst$attachment_options
*copyc fst$evaluated_file_reference
*copyc fst$tla_returned_attributes
*copyc ost$status
?? POP ??
*copyc bap$set_evaluated_file_abnormal
*copyc fmp$adjust_file_set_pos_values
*copyc fmp$locate_cycle_description
*copyc fmp$unlock_path_table
*copyc osp$set_status_abnormal

?? TITLE := 'fmp$get_tape_label_cmd_attrib', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$get_tape_label_cmd_attrib
    (    evaluated_file_reference: fst$evaluated_file_reference;
         rma_or_ring_privileged: boolean;
     VAR attributes {input, output} : fst$attachment_options;
     VAR returned_attributes: fst$tla_returned_attributes;
     VAR status: ost$status);

    VAR
      attachment_option: fst$file_attachment_choices,
      cmd_info: fst$tape_attachment_information,
      cycle_description: ^fmt$cycle_description,
      local_evaluated_file_reference: fst$evaluated_file_reference,
      path_table_locked: boolean,
      tape_descriptor_p: ^bat$tape_descriptor;

    status.normal := TRUE;
    local_evaluated_file_reference := evaluated_file_reference;
    fmp$locate_cycle_description (local_evaluated_file_reference, cycle_description, status);

    path_table_locked := status.normal;
    IF NOT status.normal THEN
      IF status.condition = fme$no_cycle_description THEN
        cycle_description := NIL;
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

  /get_tape_label_cmd_attrib/
    BEGIN
      IF (cycle_description = NIL) OR NOT cycle_description^.attached_file THEN
        bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_attachment_required,
              'FSP$GET_TAPE_LABEL_ATTRIBUTES', '', status);
        EXIT /get_tape_label_cmd_attrib/;
      IFEND;

      IF cycle_description^.device_class <> rmc$magnetic_tape_device THEN
        bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_device_class,
              'FSP$GET_TAPE_LABEL_ATTRIBUTES', 'MASS_STORAGE/NULL/TERMINAL', status);
        EXIT /get_tape_label_cmd_attrib/;
      IFEND;

      returned_attributes := $fst$tla_returned_attributes [];

      IF cycle_description^.global_file_information^.device_dependent_info.tape_descriptor <> NIL THEN
        RESET cycle_description^.global_file_information^.device_dependent_info.tape_descriptor;
        NEXT tape_descriptor_p IN cycle_description^.global_file_information^.device_dependent_info.
              tape_descriptor;
        IF tape_descriptor_p = NIL THEN
          osp$set_status_abnormal ('FM', fme$system_error,
                ' NIL tape_descriptor IN fmp$get_tape_label_cmd_attrib', status);
          EXIT /get_tape_label_cmd_attrib/;
        IFEND;

        IF cycle_description^.global_file_information^.open_count = 0 THEN
          cmd_info := tape_descriptor_p^.tape_label_attr_command_info;
        ELSE
          cmd_info := tape_descriptor_p^.tape_attachment_information;
        IFEND;
        fmp$adjust_file_set_pos_values (cmd_info);

        FOR attachment_option := 1 TO UPPERBOUND (attributes) DO
          IF attributes [attachment_option].selector = fsc$tape_attachment THEN
            CASE attributes [attachment_option].tape_attachment.selector OF
            = fsc$tape_block_type =
              IF cmd_info.block_type_source = fsc$tape_label_attr_command THEN
                attributes [attachment_option].tape_attachment.tape_block_type := cmd_info.block_type;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_character_conversion =
              IF cmd_info.character_conversion_source = fsc$tape_label_attr_command THEN
                attributes [attachment_option].tape_attachment.tape_character_conversion :=
                      cmd_info.character_conversion;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_character_set =
              IF cmd_info.character_set_source = fsc$tape_label_attr_command THEN
                attributes [attachment_option].tape_attachment.tape_character_set := cmd_info.character_set;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_creation_date =
              IF cmd_info.creation_date_source = fsc$tape_label_attr_command THEN
                attributes [attachment_option].tape_attachment.tape_creation_date := cmd_info.creation_date;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_expiration_date =
              IF cmd_info.expiration_date_source = fsc$tape_label_attr_command THEN
                attributes [attachment_option].tape_attachment.tape_expiration_date :=
                      cmd_info.expiration_date;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_file_accessibility =
{             IF rma_or_ring_privileged THEN
                IF cmd_info.file_accessibility_source = fsc$tape_label_attr_command THEN
                  attributes [attachment_option].tape_attachment.tape_file_accessibility :=
                        cmd_info.file_accessibility;
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                IFEND;
{             ELSE
{               bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$security_conflict, '',
{                     'FILE_ACCESSIBILITY', status);
{               EXIT /get_tape_label_cmd_attrib/;
{             IFEND;

            = fsc$tape_file_identifier =
              IF cmd_info.file_identifier_source = fsc$tape_label_attr_command THEN
                attributes [attachment_option].tape_attachment.tape_file_identifier :=
                      cmd_info.file_identifier;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_file_sequence_number =
              IF cmd_info.file_sequence_number_source = fsc$tape_label_attr_command THEN
                attributes [attachment_option].tape_attachment.tape_file_sequence_number :=
                      cmd_info.file_sequence_number;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_file_set_identifier =
              IF cmd_info.file_set_identifier_source = fsc$tape_label_attr_command THEN
                attributes [attachment_option].tape_attachment.tape_file_set_identifier :=
                      cmd_info.file_set_identifier;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_file_set_position =
              IF cmd_info.file_set_position_source = fsc$tape_label_attr_command THEN
                attributes [attachment_option].tape_attachment.tape_file_set_position :=
                      cmd_info.file_set_position;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_generation_number =
              IF cmd_info.generation_number_source = fsc$tape_label_attr_command THEN
                attributes [attachment_option].tape_attachment.tape_generation_number :=
                      cmd_info.generation_number;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_generation_version_num =
              IF cmd_info.generation_version_num_source = fsc$tape_label_attr_command THEN
                attributes [attachment_option].tape_attachment.tape_generation_version_num :=
                      cmd_info.generation_version_number;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_max_block_length =
              IF cmd_info.max_block_length_source = fsc$tape_label_attr_command THEN
                attributes [attachment_option].tape_attachment.tape_max_block_length :=
                      cmd_info.max_block_length;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_max_record_length =
              IF cmd_info.max_record_length_source = fsc$tape_label_attr_command THEN
                attributes [attachment_option].tape_attachment.tape_max_record_length :=
                      cmd_info.max_record_length;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_owner_identification =
              IF rma_or_ring_privileged THEN
                IF cmd_info.owner_identifier_source = fsc$tape_label_attr_command THEN
                  attributes [attachment_option].tape_attachment.tape_owner_identification :=
                        cmd_info.owner_identifier;
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                IFEND;
              ELSE
                bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$security_conflict, '',
                      'OWNER_IDENTIFICATION', status);
                EXIT /get_tape_label_cmd_attrib/;
              IFEND;

            = fsc$tape_padding_character =
              IF cmd_info.padding_character_source = fsc$tape_label_attr_command THEN
                attributes [attachment_option].tape_attachment.tape_padding_character :=
                      cmd_info.padding_character;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_record_type =
              IF cmd_info.record_type_source = fsc$tape_label_attr_command THEN
                attributes [attachment_option].tape_attachment.tape_record_type := cmd_info.record_type;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_removable_media_group =
              IF rma_or_ring_privileged THEN
                IF cmd_info.removable_media_group_source = fsc$tape_label_attr_command THEN
                  attributes [attachment_option].tape_attachment.tape_removable_media_group :=
                        cmd_info.removable_media_group;
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                IFEND;
              ELSE
                bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$security_conflict, '',
                      'REMOVABLE_MEDIA_GROUP', status);
                EXIT /get_tape_label_cmd_attrib/;
              IFEND;

            = fsc$tape_rewrite_labels =
              IF cmd_info.rewrite_labels_source = fsc$tape_label_attr_command THEN
                attributes [attachment_option].tape_attachment.tape_rewrite_labels := cmd_info.rewrite_labels;
                returned_attributes := returned_attributes + $fst$tla_returned_attributes
                      [attributes [attachment_option].tape_attachment.selector];
              IFEND;

            = fsc$tape_volume_accessibility =
              IF rma_or_ring_privileged THEN
                IF cmd_info.volume_accessibility_source = fsc$tape_label_attr_command THEN
                  attributes [attachment_option].tape_attachment.tape_volume_accessibility :=
                        cmd_info.volume_accessibility;
                  returned_attributes := returned_attributes + $fst$tla_returned_attributes
                        [attributes [attachment_option].tape_attachment.selector];
                IFEND;
              ELSE
                bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$security_conflict, '',
                      'VOLUME_ACCESSIBILITY', status);
                EXIT /get_tape_label_cmd_attrib/;
              IFEND;

            ELSE { unimplemented attribute }
              ;
            CASEND;

          IFEND;
        FOREND;
      IFEND; { tape_descriptor <> NIL }

    END /get_tape_label_cmd_attrib/;

    IF path_table_locked THEN
      fmp$unlock_path_table;
    IFEND;

  PROCEND fmp$get_tape_label_cmd_attrib;
MODEND fmm$get_tape_label_cmd_attrib;
*DECK DECK=FMM$GET_TERMINAL_ATTRIBUTES EXPAND=TRUE
MODULE fmm$get_terminal_attributes;

{MODULE DECK BAMGTA}
*copyc OSD$DEFAULT_PRAGMATS
?? PUSH (LISTEXT := ON) ??
*copyc bak$bap_procedure_keypoints
*copyc fmp$get_cycle_description
*copyc fmp$unlock_path_table
*copyc ife$error_codes
*copyc ift$get_connection_attributes
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
*copyc oss$task_private
*copyc pmp$get_job_mode
?? POP ??
?? SET (LIST := ON) ??

  PROCEDURE [XDCL] fmp$get_terminal_attributes (file: fst$file_reference;
    VAR connection_attributes: ift$get_connection_attributes;
    VAR status: ost$status);

    VAR
      attribute_loc: ^ift$connection_attributes,
      cycle_description: ^fmt$cycle_description,
      i: integer,
      j: integer;

    status.normal := TRUE;

  { Set the attribute source of all entries to 'undefined'.

    FOR i := LOWERBOUND (connection_attributes) TO UPPERBOUND
          (connection_attributes) DO
      connection_attributes [i].source := ifc$undefined_attribute;
    FOREND;

  { Get the connection attributes from the path description entry for the file.

  /get_attributes/
    BEGIN

      attribute_loc := NIL;
      fmp$get_cycle_description (file, cycle_description, status);
      IF NOT status.normal THEN
        EXIT /get_attributes/;
      IFEND;

    /path_table_locked/
      BEGIN

        IF (cycle_description <> NIL) AND cycle_description^.attached_file AND
              (cycle_description^.device_class = rmc$terminal_device) THEN
        { RMP$REQUEST_TERMINAL created the file.
          IF cycle_description^.terminal_request <> NIL THEN
          { Attributes were specified on the request terminal call.
            attribute_loc := cycle_description^.terminal_request;
          IFEND;
        ELSE
          osp$set_status_abnormal (ifc$interactive_facility_id, ife$file_name_not_terminal,
                '', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, file,
                status);
          EXIT /path_table_locked/;
        IFEND;

      { Get the BAM attributes if they are specified.

        IF attribute_loc <> NIL THEN
        /get_bam_connection_attributes/
          FOR i := 1 TO UPPERBOUND (connection_attributes) DO

            FOR j := 1 TO UPPERBOUND (attribute_loc^) DO

              IF attribute_loc^ [j].key = connection_attributes [i].key THEN

                connection_attributes [i].source := ifc$request_terminal_request;

                CASE connection_attributes [i].key OF
                = ifc$attention_character_action =
                  connection_attributes [i].attention_character_action :=
                        attribute_loc^ [j].attention_character_action;
                = ifc$break_key_action =
                  connection_attributes [i].break_key_action :=
                        attribute_loc^ [j].break_key_action;
                = ifc$end_of_information =
                  connection_attributes [i].end_of_information :=
                        attribute_loc^ [j].end_of_information;
                = ifc$input_block_size =
                  connection_attributes [i].input_block_size := attribute_loc^ [j].
                        input_block_size;
                = ifc$input_editing_mode =
                  connection_attributes [i].input_editing_mode := attribute_loc^ [j].
                        input_editing_mode;
                = ifc$input_timeout =
                  connection_attributes [i].input_timeout := attribute_loc^ [j].input_timeout;
                = ifc$input_timeout_length =
                  connection_attributes [i].input_timeout_length := attribute_loc^ [j].
                        input_timeout_length;
                = ifc$input_timeout_purge =
                  connection_attributes [i].input_timeout_purge := attribute_loc^ [j].
                        input_timeout_purge;
                = ifc$input_output_mode =
                  connection_attributes [i].input_output_mode := attribute_loc^ [j].
                        input_output_mode;
                = ifc$partial_char_forwarding =
                  connection_attributes [i].partial_character_forwarding := attribute_loc^ [j].
                        partial_character_forwarding;
                = ifc$prompt_file =
                  connection_attributes [i].prompt_file := attribute_loc^ [j].prompt_file;
                = ifc$prompt_file_identifier =
                  connection_attributes [i].prompt_file_identifier := attribute_loc^ [j].
                        prompt_file_identifier;
                = ifc$prompt_string =
                  connection_attributes [i].prompt_string := attribute_loc^ [j].prompt_string;
                = ifc$store_backspace_character =
                  connection_attributes [i].store_backspace_character := attribute_loc^ [j].
                        store_backspace_character;
                = ifc$store_nuls_dels =
                  connection_attributes [i].store_nuls_dels := attribute_loc^ [j].store_nuls_dels;
                = ifc$trans_character_mode =
                  connection_attributes [i].trans_character_mode := attribute_loc^ [j].
                        trans_character_mode;
                = ifc$trans_forward_character =
                  connection_attributes [i].trans_forward_character := attribute_loc^ [j].
                        trans_forward_character;
                = ifc$trans_length_mode =
                  connection_attributes [i].trans_length_mode := attribute_loc^ [j].
                        trans_length_mode;
                = ifc$trans_timeout_mode =
                  connection_attributes [i].trans_timeout_mode := attribute_loc^ [j].
                        trans_timeout_mode;
                = ifc$trans_message_length =
                  connection_attributes [i].trans_message_length := attribute_loc^ [j].
                        trans_message_length;
                = ifc$trans_terminate_character =
                  connection_attributes [i].trans_terminate_character := attribute_loc^ [j].
                        trans_terminate_character;
                = ifc$trans_protocol_mode =
                  connection_attributes [i].trans_protocol_mode := attribute_loc^ [j].
                        trans_protocol_mode;
                ELSE
                  {}
                CASEND;

                CYCLE /get_bam_connection_attributes/;

              IFEND;
            FOREND;

          FOREND /get_bam_connection_attributes/;
        IFEND; { attribute_loc <> NIL }

      END /path_table_locked/;
      fmp$unlock_path_table;

    END /get_attributes/;

  PROCEND fmp$get_terminal_attributes;
MODEND fmm$get_terminal_attributes;
*DECK DECK=FMM$JOB_RECOVERY EXPAND=TRUE
*copyc osd$default_pragmats
?? RIGHT := 110 ??
??
NEWTITLE := 'NOS/VE File Manager: Job Recovery' ??
MODULE fmm$job_recovery;
?? NEWTITLE := 'Global Declarations' ??
{
{  This module contains the driving procedure for recovery of files
{  following a system crash in which jobs are recovered.
{

  CONST
    one_second = 1000 {milliseconds};

  VAR
    fmv$fatal_tape_reserve_error: [XDCL] boolean := FALSE,
    fmv$recovered_pf_count: [XDCL]  0 .. 0ffffff(16) := 0,
    fmv$trimmed_pf_count: [XDCL] 0 .. 0ffffff(16) := 0,
    fmv$trimmed_tape_count: [XDCL] 0 .. 0ffffff(16) := 0,
    fmv$trimmed_file_count: [XDCL] 0 .. 0ffffff(16) := 0;

?? PUSH (LISTEXT := ON) ??
*copyc clp$construct_path_handle_name
*copyc dfe$error_condition_codes
*copyc dfv$file_server_debug_enabled
*copyc dme$tape_errors
*copyc dmp$detach_server_file
*copyc dmp$get_tape_volume_information
*copyc dmp$get_tape_volume_list
*copyc fmc$entry_assigned
*copyc fmc$test_jr_constants
*copyc fmp$get_path_string
*copyc fmp$lock_path_table
*copyc fmp$unlock_path_table
*copyc nac$null_connection_id
*copyc fme$file_management_errors
*copyc fmk$keypoints
*copyc fmt$cycle_description
*copyc fmt$cycle_description_unit
*copyc fmv$initial_cdu_pointer
*copyc fmv$path_table_lock
*copyc rmv$requested_volume_attributes
*copyc iop$create_rvl_entry
*copyc iop$set_sfid_in_rvl
*copyc ose$job_recovery_exceptions
*copyc osp$append_status_integer
*copyc osp$initialize_signature_lock
*copyc osp$log_job_recovery_message
*copyc osp$log_job_recovery_status
*copyc osp$recoverable_system_error
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc osp$test_sig_lock
*copyc osp$test_signature_lock
*copyc oss$job_paged_literal
*copyc osv$job_pageable_heap
*copyc pmp$convert_binary_unique_name
*copyc pmp$get_pseudo_mainframe_id
*copyc pfe$internal_error_conditions
*copyc pfp$catalog_access_retry_wait
*copyc pfp$check_apfid_location
*copyc pfp$complete_job_recovery
*copyc pfp$initialize_job_recovery
*copyc pfp$reattach_permanent_file
*copyc pfp$reattach_reserved_cycles
*copyc pfp$relink_server_file
*copyc pfp$return_permanent_file
*copyc pfp$terminate_server_apfid
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_microsecond_clock
*copyc rmp$recover_job_tape_table
*copyc stp$recover_jobs_sets
*copyc syp$hang_if_job_jrt_set
*copyc syv$debug_job_recovery
  { DAH kludge

  PROCEDURE [XREF] syp$clear_job_recovery_test (t: zzzz;
        option: 0 .. 255);

  TYPE
    zzzz = (job, system);

*copyc syp$change_access_state
*copyc syp$invalidate_open_sfid
*copyc syp$pop_inhibit_job_recovery
*copyc syp$push_inhibit_job_recovery
*copyc syp$replace_sfid
?? POP ??
?? TITLE := ' FMP$RECOVER_JOB_FILES', EJECT ??
*copyc fmh$recover_job_files
?? EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$recover_job_files (VAR status: ost$status);


    PROCEDURE recovery_abort_handler (condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      { This procedure is established to catch unexpected conditions during the
      { job file recovery. If this condition is invoked the status of
      { ose$job_severely_damaged will be returned.

      VAR
        display_status: ost$status,
        condition_status: ost$status,
        construction_status: ost$status,
        ignored_status: ost$status;

      handler_status.normal := TRUE;
      { DISPLAY THE REASON FOR THE CONDITION
      osp$log_job_recovery_message (' Condition occurred in fmp$recover_job_files', display_status);
      osp$set_status_from_condition (amc$access_method_id, condition, save_area, condition_status,
            construction_status);
      IF construction_status.normal THEN
        osp$log_job_recovery_status (condition_status, display_status);
      ELSE
        osp$log_job_recovery_status (construction_status, display_status);
      IFEND;
{
{     System unstep condition must be ignored since it causes job recovery to fail.
{
      IF (condition.selector = pmc$user_defined_condition) AND
            (condition.user_condition_name = 'SYSTEM_UNSTEP_RESUME') THEN
        RETURN;
      IFEND;
      osp$set_status_abnormal (amc$access_method_id, ose$job_severely_damaged, ' Condition handler invoked',
            status);
      IF (condition.selector = pmc$user_defined_condition) AND (condition.user_condition_name =
        'OSC$JOB_RECOVERY') THEN
        {Stop previous recovery attempt, allows current to continue
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        osp$set_status_abnormal (amc$access_method_id, fme$multiple_job_recoveries, '', status);
      IFEND;
      pmp$disestablish_cond_handler (abort_conditions, ignored_status);
      EXIT fmp$recover_job_files;
    PROCEND recovery_abort_handler;


    VAR
      abort_conditions: [STATIC, READ, oss$job_paged_literal] pmt$condition := [pmc$condition_combination,
        [pmc$system_conditions, {pmc$block_exit_processing,} pmc$user_defined_condition,
        mmc$segment_access_condition]],
      abort_descriptor_area: pmt$established_handler;
{  The block_exit condition is currenltly commented out because it causes
{  an unending recursive condition on the EXIT statement in the condition
{  handler.  Processing for the block_exit condition needs to be added.

?? EJECT ??

    VAR
      job_severely_damaged: boolean,
      display_status: ost$status,
      ignored_status: ost$status,
      mainframe_id: pmt$binary_mainframe_id,
      recover_all_files_status: ost$status,
      reservation_status: ost$status,
      pf_completion_status: ost$status;

    pmp$establish_condition_handler (abort_conditions, ^recovery_abort_handler, ^abort_descriptor_area,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fmv$fatal_tape_reserve_error := FALSE;
    fmv$trimmed_pf_count := 0;
    fmv$trimmed_tape_count := 0;
    fmv$trimmed_file_count := 0;
    fmv$recovered_pf_count := 0;
    pmp$get_pseudo_mainframe_id (mainframe_id);

    stp$recover_jobs_sets (status);
    job_severely_damaged := NOT status.normal;

    IF NOT job_severely_damaged THEN
      check_path_table_lock (status);
      job_severely_damaged := NOT status.normal;
    IFEND;

    IF NOT job_severely_damaged THEN
      pfp$initialize_job_recovery (pfc$attached_pf_in_job_recovery, status);
      job_severely_damaged := (NOT status.normal) AND (status.condition = ose$job_severely_damaged);
    IFEND;

    IF NOT job_severely_damaged THEN
      recover_all_files (mainframe_id, recover_all_files_status);
      job_severely_damaged := (NOT recover_all_files_status.normal) AND (recover_all_files_status.condition =
            ose$job_severely_damaged);
    IFEND;

    IF NOT job_severely_damaged THEN
      pfp$complete_job_recovery (mainframe_id, pf_completion_status);
      IF status.normal THEN
        IF pf_completion_status.normal THEN
          status := recover_all_files_status;
        ELSE
          osp$log_job_recovery_status (recover_all_files_status, display_status);
          status := pf_completion_status;
        IFEND;
      ELSE
        osp$log_job_recovery_status (recover_all_files_status, display_status);
        osp$log_job_recovery_status (pf_completion_status, display_status);
      IFEND;
      job_severely_damaged := (NOT pf_completion_status.normal) AND (pf_completion_status.condition =
            ose$job_severely_damaged);
    IFEND;

    IF NOT job_severely_damaged THEN
      IF fmv$fatal_tape_reserve_error THEN
        osp$set_status_abnormal (amc$access_method_id, fme$tape_resource_not_recovered,
              '', reservation_status);
      ELSE
        reservation_status.normal := TRUE;
      IFEND;
      IF status.normal THEN
        status := reservation_status;
      ELSE
        osp$log_job_recovery_status (reservation_status, display_status);
      IFEND;
    IFEND;

    pmp$disestablish_cond_handler (abort_conditions, ignored_status);

  PROCEND fmp$recover_job_files;
?? TITLE := 'PROCEDURE check_path_table_lock', EJECT ??

  PROCEDURE check_path_table_lock (VAR status: ost$status);

{  This routine verifies that there are NO file manager global locks set.
{ The occurrence of a global lock set, will indicate that an error has
{ occurred in file manager, and that Rollback has not worked correctly.

    VAR
      lock_status: ost$signature_lock_status,
      local_status: ost$status;

    status.normal := TRUE;
    osp$test_signature_lock (fmv$path_table_lock, lock_status, local_status);
    IF lock_status <> osc$sls_not_locked THEN
      osp$set_status_abnormal (amc$access_method_id, ose$path_table_locked,
        ' Path Table locked: task_id:', status);
      osp$append_status_integer (osc$status_parameter_delimiter, fmv$path_table_lock.lock_id, 16, FALSE,
            status);
      RETURN;
    IFEND;

  PROCEND check_path_table_lock;
?? TITLE := '  RECOVER_ALL_FILES ', EJECT ??

  PROCEDURE recover_all_files (mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

{  This procedure assumes that the path_table can be read, and that
{  the permanent file manager may read its tables.
{  This traverses the path table, removing any tapes, and attempts
{    reattaching any permanent file.
{  Errors as they occur are logged, and a summary status condition is returned.
{

    CONST
      return_ring = 2;

    VAR
      cdu: ^fmt$cycle_description_unit,
      current_volume_number: amt$volume_number,
      current_vsns: rmt$volume_descriptor,
      cycle_description: ^fmt$cycle_description,
      density: rmt$density,
      display_status: ost$status,
      display_string: string (180),
      file_status: ost$status,
      i: integer,
      ignored_status: ost$status,
      job_has_tapes_assigned: boolean,
      label_type: amt$label_type,
      length: integer,
      local_status: ost$status,
      new_sfid: dmt$system_file_id,
      number_of_volumes: amt$volume_number,
      old_sfid: dmt$system_file_id,
      p_volume_list: ^rmt$volume_list,
      path_handle: fmt$path_handle,
      path_handle_name: fst$path_handle_name,
      pf_reattached: boolean,
      requested_volume_attributes: iot$requested_volume_attributes,
      share_selections: pft$share_selections,
      tape_class: rmt$tape_class,
      usage_selections: pft$usage_selections,
      volume_overflow_allowed: boolean,
      write_ring: rmt$write_ring;

    status.normal := TRUE;
    cdu := fmv$initial_cdu_pointer;
    rmp$recover_job_tape_table (job_has_tapes_assigned, fmv$fatal_tape_reserve_error);

    WHILE (cdu <> NIL) DO

    /loop_through_cdu/
      FOR i := 1 TO #SIZE(cdu^.entry_assignment^) DO
        IF (cdu^.entry_assignment^ (i) = fmc$entry_assigned) THEN
          cycle_description := ^cdu^.entries^ [i];
          IF cycle_description^.attached_file THEN
            CASE cycle_description^.device_class OF
            = rmc$magnetic_tape_device =
              IF cycle_description^.permanent_file THEN
                #UNCHECKED_CONVERSION (cycle_description^.attached_access_modes, usage_selections);
                #UNCHECKED_CONVERSION (cycle_description^.attached_share_modes, share_selections);
                syp$push_inhibit_job_recovery;
              /reattach_permanent_file_1/
                WHILE TRUE DO
                  pfp$reattach_permanent_file (cycle_description^.apfid, cycle_description^.device_class,
                        cycle_description^.system_file_label.descriptive_label.internal_cycle_name,
                        mainframe_id, usage_selections, share_selections, new_sfid, file_status);
                  IF file_status.normal OR (file_status.condition <> pfe$catalog_access_retry) THEN
                    EXIT /reattach_permanent_file_1/;
                  ELSE
                    syp$pop_inhibit_job_recovery;
                    pfp$catalog_access_retry_wait ('PFP$REATTACH_PERMANENT_FILE');
                    syp$push_inhibit_job_recovery;
                  IFEND;
                WHILEND /reattach_permanent_file_1/;
                pf_reattached := file_status.normal;
                IF NOT file_status.normal THEN
                  STRINGREP (display_string, length, 'Unable to recover an attached tape file.');
                  osp$log_job_recovery_message (display_string (1, length), display_status);
                  osp$log_job_recovery_status (file_status, display_status);
                  cycle_description^.attached_file := FALSE;
                  fmv$trimmed_pf_count := fmv$trimmed_pf_count + 1;
                  CYCLE /loop_through_cdu/;
                IFEND;
                syp$pop_inhibit_job_recovery;
              IFEND;

              IF NOT fmv$fatal_tape_reserve_error THEN
                dmp$get_tape_volume_information (cycle_description^.system_file_id, number_of_volumes,
                      current_volume_number, current_vsns, density, write_ring, requested_volume_attributes,
                      volume_overflow_allowed, label_type, file_status);
                IF file_status.normal THEN
                  PUSH p_volume_list: [1 .. number_of_volumes];
                  dmp$get_tape_volume_list (cycle_description^.system_file_id, p_volume_list, file_status);
                  IF file_status.normal THEN
                    REPEAT
                      iop$create_rvl_entry (cycle_description^.system_file_id, density,
                            cycle_description^.system_file_label.descriptive_label.internal_cycle_name,
                            cycle_description^.path_handle, requested_volume_attributes,
                            p_volume_list^, write_ring, file_status);
                      IF NOT file_status.normal AND
                            (file_status.condition = dme$unable_to_lock_tape_table) THEN
                        pmp$wait (one_second, one_second);
                      IFEND;
                    UNTIL file_status.normal OR (file_status.condition <> dme$unable_to_lock_tape_table);
                  IFEND;
                IFEND;
              IFEND;

              IF fmv$fatal_tape_reserve_error OR job_has_tapes_assigned OR
                    NOT file_status.normal THEN

{ Currently a job will not recover if tapes were assigned at the time of the system failure.

                fmv$trimmed_tape_count := fmv$trimmed_tape_count + 1;
                STRINGREP (display_string, length, ' Deleting a tape file ');
                osp$log_job_recovery_message (display_string (1, length), display_status);
              IFEND;
            = rmc$mass_storage_device =
              IF cycle_description^.permanent_file THEN
                #UNCHECKED_CONVERSION (cycle_description^.attached_access_modes, usage_selections);
                #UNCHECKED_CONVERSION (cycle_description^.attached_share_modes, share_selections);
                syp$push_inhibit_job_recovery;
              /reattach_permanent_file_2/
                WHILE TRUE DO
                  pfp$reattach_permanent_file (cycle_description^.apfid, cycle_description^.device_class,
                        cycle_description^.system_file_label.descriptive_label.internal_cycle_name,
                        mainframe_id, usage_selections, share_selections, new_sfid, file_status);
                  IF file_status.normal OR (file_status.condition <> pfe$catalog_access_retry) THEN
                    EXIT /reattach_permanent_file_2/;
                  ELSE
                    syp$pop_inhibit_job_recovery;
                    pfp$catalog_access_retry_wait ('PFP$REATTACH_PERMANENT_FILE');
                    syp$push_inhibit_job_recovery;
                  IFEND;
                WHILEND /reattach_permanent_file_2/;
                pf_reattached := file_status.normal;
                old_sfid := cycle_description^.system_file_id;
                IF file_status.normal THEN
                  IF cycle_description^.apfid.family_location = pfc$local_mainframe THEN
                    syp$replace_sfid (old_sfid, new_sfid, mmc$sas_allow_access, file_status);
                  ELSE { Server mainframe - inhibit access until server job recovery
                    syp$replace_sfid (old_sfid, new_sfid, mmc$sas_inhibit_access, file_status);
                  IFEND;
                ELSE
                  syp$invalidate_open_sfid (old_sfid, ignored_status);
                IFEND;
                IF file_status.normal THEN
                  cycle_description^.system_file_id := new_sfid;
                  fmv$recovered_pf_count := fmv$recovered_pf_count + 1;
                ELSE
                  STRINGREP (display_string, length, ' Unable to recover an attached file ');
                  osp$log_job_recovery_message (display_string (1, length), display_status);
                  osp$log_job_recovery_status (file_status, display_status);
                  IF pf_reattached THEN
                    osp$log_job_recovery_message (' Detaching reattached permanent file', display_status);
                    pfp$return_permanent_file (cycle_description^.apfid, new_sfid,
                          cycle_description^.device_class, usage_selections, ignored_status);
                    osp$log_job_recovery_status (ignored_status, display_status);
                  IFEND;
                  cycle_description^.attached_file := FALSE;
                  fmv$trimmed_pf_count := fmv$trimmed_pf_count + 1;
                IFEND;
                syp$pop_inhibit_job_recovery;
                IF (fmv$recovered_pf_count = 5) THEN
                  { Test job recovery conditions within job recovery
                  IF (fmc$tjr_recover_all_files IN syv$test_jr_job) THEN
                    syp$clear_job_recovery_test (job, fmc$tjr_recover_all_files);
                    WHILE TRUE DO
                      pmp$wait (one_second, one_second);
                    WHILEND;
                  IFEND;
                  IF fmc$tjr_recovery_abort IN syv$test_jr_job THEN
                    { Induce segment condition
                    cycle_description := NIL;
                    cycle_description^.attached_file := FALSE;
                  IFEND;
                IFEND;
              IFEND;
            = rmc$network_device =
              cycle_description^.global_file_information^.device_dependent_info.
                    network_connection_id := nac$null_connection_id;
              IF cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.file_state = nac$switch_offered THEN
                cycle_description^.global_file_information^.device_dependent_info.
                      network_global_file_information^.file_state := nac$system_recovery_switched;
              ELSEIF cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.file_state = nac$nominal_conn_switch_offer THEN
                cycle_description^.global_file_information^.device_dependent_info.
                      network_global_file_information^.file_state := nac$system_recovery_switchd_nom;
              ELSE
                cycle_description^.global_file_information^.device_dependent_info.
                      network_global_file_information^.file_state := nac$system_recovery;
              IFEND;
              IF NOT cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.connect.valid_start_down_time THEN
                pmp$get_microsecond_clock (cycle_description^.global_file_information^.
                      device_dependent_info.network_global_file_information^.connect.start_down_time,
                      ignored_status);
                cycle_description^.global_file_information^.device_dependent_info.
                    network_global_file_information^.connect.valid_start_down_time := TRUE;
              IFEND;
            ELSE
            CASEND;
          IFEND;
        IFEND; {entry assigned}
      FOREND /loop_through_cdu/;
      cdu := cdu^.next_cycle_description_unit;
    WHILEND;

    IF fmv$trimmed_pf_count > 0 THEN
      osp$set_status_abnormal (amc$access_method_id, fme$not_all_pfs_recovered, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, fmv$trimmed_pf_count, 10, FALSE, status);
    ELSEIF fmv$trimmed_tape_count > 0 THEN
      osp$set_status_abnormal (amc$access_method_id, fme$tape_files_not_recovered, '  ', status);
      osp$append_status_integer (osc$status_parameter_delimiter, fmv$trimmed_tape_count, 10, FALSE, status);
    ELSEIF fmv$trimmed_file_count > 0 THEN
      osp$set_status_abnormal (amc$access_method_id, fme$not_all_files_recovered, '  ', status);
      osp$append_status_integer (osc$status_parameter_delimiter, fmv$trimmed_file_count, 10, FALSE, status);
    IFEND;

    IF status.normal THEN
      pfp$reattach_reserved_cycles (mainframe_id, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (amc$access_method_id, fme$not_all_pfs_recovered, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, {Unknown} 1, 10, FALSE, status);
      IFEND;
    IFEND;

  PROCEND recover_all_files;
?? TITLE := ' fmp$recover_server_files', EJECT ??
*copyc fmh$recover_server_files
?? EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$recover_server_files
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);


    PROCEDURE recovery_abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

{ This procedure is established to catch unexpected conditions during the
{ server job file recovery. If this condition is invoked the status of
{ ose$job_severely_damaged will be returned.  The job will
{ propably go to the nether region.

      VAR
        display_status: ost$status,
        condition_status: ost$status,
        construction_status: ost$status,
        ignored_status: ost$status;

      handler_status.normal := TRUE;
      { DISPLAY THE REASON FOR THE CONDITION
      osp$log_job_recovery_message (' Condition occurred in fmp$recover_server_files', display_status);
      osp$set_status_from_condition (amc$access_method_id, condition, save_area, condition_status,
            construction_status);
      IF construction_status.normal THEN
        osp$log_job_recovery_status (condition_status, display_status);
      ELSE
        osp$log_job_recovery_status (construction_status, display_status);
      IFEND;
      osp$set_status_abnormal (amc$access_method_id, ose$job_severely_damaged, ' Condition handler invoked',
            status);
      pmp$disestablish_cond_handler (abort_conditions, ignored_status);
      IF lock_status.normal THEN
        fmp$unlock_path_table;
      IFEND;
      EXIT fmp$recover_server_files;
    PROCEND recovery_abort_handler;


    VAR
      abort_conditions: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
            [pmc$condition_combination, [pmc$system_conditions,
            {pmc$block_exit_processing,} pmc$user_defined_condition, mmc$segment_access_condition]],
      abort_descriptor_area: pmt$established_handler;

{  The block_exit condition is currenltly commented out because it causes
{  an unending recursive condition on the EXIT statement in the condition
{  handler.  Processing for the block_exit condition needs to be added.

?? EJECT ??

    VAR
      ignored_status: ost$status,
      lock_status: ost$status;

    lock_status.normal := TRUE;
{   osp$test_sig_lock (fmv$path_table_lock, lock_status);
{   IF lock_status <> osc$sls_locked_by_current_task THEN
       { The above IF check is a KLUDGE because of the sequence
       { fmp$process_pt_request (locks table)
       {   pfp$resolve_path
       {      server job recovery
       {        fmp$recover_server_files
       { In this sequence the path table is readable despite the lock.
      fmp$lock_path_table (lock_status);
{   IFEND;
    pmp$establish_condition_handler (abort_conditions, ^recovery_abort_handler, ^abort_descriptor_area,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fmv$trimmed_pf_count := 0;
    fmv$recovered_pf_count := 0;

    recover_all_server_files (server_mainframe_id, status);
    pmp$disestablish_cond_handler (abort_conditions, ignored_status);
    IF lock_status.normal THEN
      fmp$unlock_path_table;
    IFEND;
  PROCEND fmp$recover_server_files;
?? TITLE := '  RECOVER_ALL_SERVER_FILES ', EJECT ??

  PROCEDURE recover_all_server_files
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

    VAR
      correct_mainframe: boolean,
      cdu: ^fmt$cycle_description_unit,
      cycle_description: ^fmt$cycle_description,
      display_status: ost$status,
      file_status: ost$status,
      gfn_name: ost$name,
      i: integer,
      length: integer,
      new_sfid: dmt$system_file_id,
      path_string: fst$path,
      path_size: fst$path_size;

    status.normal := TRUE;
    cdu := fmv$initial_cdu_pointer;

  /loop_though_all_cdus/
    WHILE (cdu <> NIL) DO

    /loop_through_cdu/
      FOR i := 1 TO #SIZE (cdu^.entry_assignment^) DO
        IF (cdu^.entry_assignment^ (i) = fmc$entry_assigned) THEN
          cycle_description := ^cdu^.entries^ [i];
          IF cycle_description^.attached_file AND cycle_description^.permanent_file THEN
            pfp$check_apfid_location (server_mainframe_id, cycle_description^.apfid, correct_mainframe);
            IF correct_mainframe THEN
              syp$push_inhibit_job_recovery;
              pfp$relink_server_file (cycle_description^.apfid,
                    cycle_description^.system_file_label.descriptive_label.internal_cycle_name,
                    cycle_description^.system_file_id, cycle_description^.device_class,
                    cycle_description^.apfid, new_sfid, file_status);
              { No matter what replace the apfid and sfid.
              { Permanent files will return the appropriate sfid in normal and abnormal cases.
              { Should the 're-attach' fail, depend on server cleanup to detach the file on the server.
              IF cycle_description^.device_class = rmc$mass_storage_device THEN
                IF file_status.normal THEN
                  syp$change_access_state (cycle_description^.system_file_id, mmc$sas_allow_access, status);
                  cycle_description^.system_file_id := new_sfid;
                  fmv$recovered_pf_count := fmv$recovered_pf_count + 1;
                ELSE
                  cycle_description^.system_file_id := new_sfid;
                  pmp$convert_binary_unique_name (
                        cycle_description^.system_file_label.descriptive_label.internal_cycle_name,
                        gfn_name, display_status);
                  STRINGREP (path_string, length, 'Unable to recover server file.', gfn_name);
                  osp$log_job_recovery_message (path_string (1, length), display_status);
                  osp$log_job_recovery_status (file_status, display_status);
                  path_string := 'dog';
                  path_size := 3;
                  fmp$get_path_string (cycle_description^.path_handle, {lock_path_table} FALSE,
                        path_string, path_size, display_status);
                  osp$log_job_recovery_message (path_string (1, path_size), display_status);
                  IF (file_status.condition = dfe$server_not_active) OR
                        (file_status.condition =  dfe$server_has_terminated) THEN
                    { The state of the server has changed since this process started.
                    { Allow higher code to wait, or terminate server access.
                    syp$pop_inhibit_job_recovery;
                    RETURN;
                  IFEND;
                  syp$change_access_state (cycle_description^.system_file_id, mmc$sas_terminate_access,
                        status);
                  IF dfv$file_server_debug_enabled AND syv$debug_job_recovery THEN
                    osp$recoverable_system_error ('Could not relink server file.', ^file_status);
                  IFEND;
                  fmv$trimmed_pf_count := fmv$trimmed_pf_count + 1;
                IFEND;
                IF NOT status.normal THEN
                  { This procedure should never have failed.
                  IF dfv$file_server_debug_enabled THEN
                    osp$recoverable_system_error ('Could not change access state.', ^status);
                  IFEND;
                  osp$log_job_recovery_message ('Unable to change attached server file access state.',
                        display_status);
                  osp$log_job_recovery_status (status, display_status);
                IFEND;
              IFEND;
              syp$pop_inhibit_job_recovery;

              IF (fmv$recovered_pf_count = 5) THEN
                { Test job recovery conditions within job recovery
                IF (fmc$tjr_recover_all_files IN syv$test_jr_job) THEN
                  syp$clear_job_recovery_test (job, fmc$tjr_recover_all_files);

                /hang_forever/
                  WHILE TRUE DO
                    pmp$wait (one_second, one_second);
                  WHILEND /hang_forever/;
                IFEND;
                IF fmc$tjr_recovery_abort IN syv$test_jr_job THEN
                  { Induce segment condition
                  cycle_description := NIL;
                  cycle_description^.attached_file := FALSE;
                IFEND;
              IFEND; { fmv$recovered_pf_count = 5}

            IFEND; { Permanent file }
          IFEND; { Correct mainframe}
        IFEND; { Entry assigned }
      FOREND /loop_through_cdu/;
      cdu := cdu^.next_cycle_description_unit;
    WHILEND /loop_though_all_cdus/;

    IF fmv$trimmed_pf_count > 0 THEN
      osp$set_status_abnormal (amc$access_method_id, fme$not_all_pfs_recovered, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, fmv$trimmed_pf_count, 10, FALSE, status);
    IFEND;
  PROCEND recover_all_server_files;
?? TITLE := ' fmp$terminate_server_files', EJECT ??
*copyc fmh$terminate_server_files
?? EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$terminate_server_files
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

    VAR
      correct_mainframe: boolean,
      cdu: ^fmt$cycle_description_unit,
      cycle_description: ^fmt$cycle_description,
      display_status: ost$status,
      gfn_name: ost$name,
      i: integer,
      ignore_attached_for_write: boolean,
      ignore_eoi: amt$file_byte_address,
      ignore_server_sfid: gft$system_file_identifier,
      ignore_status: ost$status,
      length: integer,
      lock_status: ost$status,
      path_string: fst$path,
      path_size: fst$path_size;

    { fmv$trimmed_pf_count is provided solely for debugging.
    fmv$trimmed_pf_count := 0;
    lock_status.normal := TRUE;
{   osp$test_sig_lock (fmv$path_table_lock, lock_status);
{   IF lock_status <> osc$sls_locked_by_current_task THEN
      fmp$lock_path_table (lock_status);
{   IFEND;
    status.normal := TRUE;
    cdu := fmv$initial_cdu_pointer;

  /loop_though_all_cdus/
    WHILE (cdu <> NIL) DO

    /loop_through_cdu/
      FOR i := 1 TO #SIZE (cdu^.entry_assignment^) DO
        IF (cdu^.entry_assignment^ (i) = fmc$entry_assigned) THEN
          cycle_description := ^cdu^.entries^ [i];
          IF cycle_description^.attached_file AND (cycle_description^.device_class =
                rmc$mass_storage_device) AND cycle_description^.permanent_file THEN
            pfp$check_apfid_location (server_mainframe_id, cycle_description^.apfid, correct_mainframe);
            IF correct_mainframe THEN
              pfp$terminate_server_apfid (cycle_description^.apfid);
              syp$change_access_state (cycle_description^.system_file_id, mmc$sas_terminate_access, status);
              IF dfv$file_server_debug_enabled AND (NOT status.normal) THEN
                osp$recoverable_system_error (' Could not replace server sfid', ^status);
              IFEND;
{ Clean up the "dangling" file_descriptor_entry.
              dmp$detach_server_file (cycle_description^.system_file_id, {flush_pages=} FALSE,
                    {unconditional_detach=} TRUE, ignore_attached_for_write, ignore_eoi, ignore_server_sfid,
                    ignore_status);
              pmp$convert_binary_unique_name (
                    cycle_description^.system_file_label.descriptive_label.internal_cycle_name,
                    gfn_name, display_status);
              STRINGREP (path_string, length, 'Terminating  server file ', gfn_name);
              osp$log_job_recovery_message (path_string (1, length), display_status);
              fmv$trimmed_pf_count := fmv$trimmed_pf_count + 1;
              path_string := 'dog';
              path_size := 3;
              fmp$get_path_string (cycle_description^.path_handle, { Lock_path_table} FALSE,
                  path_string, path_size, display_status);
              osp$log_job_recovery_message (path_string (1, path_size), display_status);
            IFEND; { Permanent file }
          IFEND; { Correct mainframe}
        IFEND; { Entry assigned }
      FOREND /loop_through_cdu/;
      cdu := cdu^.next_cycle_description_unit;
    WHILEND /loop_though_all_cdus/;

    IF lock_status.normal THEN
      fmp$unlock_path_table;
    IFEND;
  PROCEND fmp$terminate_server_files;

MODEND fmm$job_recovery;

*DECK DECK=FMM$OBTAIN_ELEMENT_NAME EXPAND=TRUE
*copyc osd$default_pragmats

MODULE fmm$obtain_element_name;

*copyc dmp$convert_sfid_to_lun
*copyc cmp$get_element_name_via_lun
*copyc fmp$get_system_file_id

*copyc amt$local_file_name
*copyc cmt$element_name
*copyc ost$status
*copyc dmt$system_file_id
*copyc iot$logical_unit
?? EJECT ??


  PROCEDURE [XDCL, #GATE] fmp$obtain_element_name (
        lfn: amt$local_file_name;
    VAR element_name: cmt$element_name;
    VAR status: ost$status);

    VAR
      sfid: dmt$system_file_id,
      lun: iot$logical_unit;

    status.normal := TRUE;

    fmp$get_system_file_id (lfn, sfid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$convert_sfid_to_lun (sfid, lun, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmp$get_element_name_via_lun (lun, element_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND fmp$obtain_element_name;

MODEND fmm$obtain_element_name;
*DECK DECK=FMM$PATH_TABLE_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : File Management : Path Table Manager' ??

MODULE fmm$path_table_manager;

{  PURPOSE:
{    This module is responsible for all processing of the
{    file systems path_table.  All procedures which directly manage the
{    tree are located here to isolate knowledge of how the tree is managed
{    from those processes which act upon an individual node.
{
{  DESIGN:
{    The path_table is a binary tree.
{
{    All searches, additions and deletions of nodes (path_description_entry's)
{    or their associated cycle_objects (also path_description_entry's)
{    require that the entire path_table be locked for the duration.
{
{    Additions of nodes to the table will be done based on a provided
{    path_element array and cycle_number if the node will be a cycle_object.
{    Upon addition to the path_table, a path_handle containing an offset
{    into the segment containing the path_table and a unique
{    assignment_counter for use in validation when re-entering the path_table
{    later will be passed back.
{
{    All searchs and additions will begin at the root of the tree
{    (fmv$path_table_entry_point).
{
{    All procedures merely updating an already created entry will search
{    based on the path_handle passed back when the entry was created.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$lfn_program_actions
*copyc ame$put_program_actions
*copyc ame$ring_validation_errors
*copyc amt$local_file_name
*copyc bat$process_pt_results
*copyc bat$process_pt_work_list
*copyc bat$static_label_attributes
*copyc clc$standard_file_names
*copyc cle$ecc_file_reference
*copyc cyc$max_string_size
*copyc cyt$string_index
*copyc fmc$cycle_table_allocation_size
*copyc fmc$entry_assigned
*copyc fmc$number_of_init_cycle_descs
*copyc fmc$number_of_init_path_descs
*copyc fmc$path_table_allocation_size
*copyc fmc$pde_unique_identifier
*copyc fmc$statistics_max_path_depth
*copyc fmc$test_jr_constants
*copyc fme$file_management_errors
*copyc fmk$keypoints
*copyc fmt$cycle_description
*copyc fmt$cycle_description_unit
*copyc fmt$detachment_options
*copyc fmt$global_file_entries
*copyc fmt$path_description_entry
*copyc fmt$path_description_unit
*copyc fmt$path_handle
*copyc fmt$static_label_header
*copyc fsc$local
*copyc fsc$max_path_elements
*copyc fsc$maximum_cycle_number
*copyc fse$path_exception_conditions
*copyc fst$cycle_number
*copyc fst$cycle_reference
*copyc fst$detachment_options
*copyc fst$evaluated_file_reference
*copyc fst$goi_information_request
*copyc fst$goi_object_information
*copyc fst$path
*copyc fst$path_element
*copyc fst$path_index
*copyc fst$path_resolution
*copyc fst$resolved_file_reference
*copyc mme$condition_codes
*copyc osd$integer_limits
*copyc osd$random_name
*copyc osd$virtual_address
*copyc osk$keypoint_class_codes
*copyc oss$task_shared
*copyc ost$signature_lock
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$password_selector
*copyc pfe$error_condition_codes
*copyc pfe$get_object_info_errors
*copyc pfe$internal_error_conditions
?? POP ??

*copyc avp$ring_min
*copyc bap$free_tape_label_sequences
*copyc bap$set_evaluated_file_abnormal
*copyc bap$set_file_reference_abnormal
*copyc clp$construct_path_handle_name
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_integer_to_string
*copyc clp$trimmed_string_size
*copyc clp$validate_local_file_name
*copyc clp$validate_new_file_name
*copyc dmp$close_tape_volume
*copyc dmp$destroy_file
*copyc dmp$fetch_eoi
*copyc dmp$get_stored_fmd
*copyc dmp$get_stored_fmd_header_info
*copyc dmp$setup_tape_init_in_progress
*copyc fmp$catalog_set_file_attributes
*copyc fmp$free_terminal_request
*copyc fmp$get_attached_tape_info
*copyc fmp$locate_pde_via_path_handle
*copyc fmp$merge_setfa_entries

  PROCEDURE hide_xrefs_copied_by_inlines;

{fmp$lock_path_table & fmp$unlock_path_table

*copyc fmv$path_table_lock

{fmp$get_list_of_connected_files

*copyc fmp$get_path_string
  PROCEND hide_xrefs_copied_by_inlines;
*copyc fmp$lock_path_table
*copyc fmp$unlock_path_table
*copyc fmp$get_list_of_connected_files
*copyc fsp$path_element
*copyc fsp$set_evaluated_file_abnormal
*copyc i#move
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$fetch_locked_variable
*copyc osp$file_access_condition
*copyc osp$randomize_name
*copyc osp$recoverable_system_error
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$system_error
*copyc osp$test_sig_lock
*copyc pfp$convert_fs_to_pft$path
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_attached_device_info
*copyc pfp$resolve_path
*copyc pfp$return_permanent_file

*copyc clv$local_catalog_handle_name
*copyc clv$open_position_designator
*copyc dmv$initialize_tape_volume
*copyc fmv$entry_assigned_free_select
*copyc fmv$global_file_information
*copyc fmv$static_label_header
*copyc fmv$system_file_attributes
*copyc fsv$default_job_environ_info
*copyc fsv$evaluated_file_reference
*copyc osv$task_shared_heap
*copyc osv$job_pageable_heap
*copyc pfv$cycle_info_requests
*copyc pfv$file_info_requests
*copyc pfv$null_unique_name
*copyc syv$test_jr_job
*copyc syp$hang_if_job_jrt_set
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

*copy fmh$path_description_entry

  VAR

{ Place cycle_description_unit at beginning of module to reduce page faults.
{ The size of fmv$initial_cdu_entries should just exceed a page boundary.
{ Initial cycle_description_unit entries.

    fmv$initial_cdu_entries: [XDCL {xdcl'd for test_harness} , oss$job_pageable] array
          [1 .. fmc$number_of_init_cycle_descs] of fmt$cycle_description,

{ Initial global_file_information entries.

    fmv$initial_global_file_entries: [XDCL {xdcl'd for test_harness} , oss$task_shared] array
          [1 .. fmc$number_of_init_cycle_descs] of bat$global_file_information,

{
{  All path table global variables are to be referenced only when the
{  path table is locked.
{

    fmv$path_table_lock: [XDCL, oss$job_pageable] ost$signature_lock := [0],

{
{  The following variables are used for the path table's initial construction.
{

{ Pointer to the initial cycle_description_unit.

    fmv$initial_cdu_pointer: [XDCL, #GATE {gated for BAM$DISPLAY_TABLES & FMM$JOB_RECOVERY} ,
          oss$job_pageable] ^fmt$cycle_description_unit := NIL,

{ Initial cycle_description_unit.

    fmv$initial_cdu: [XDCL {xdcl'd for test_harness} , oss$job_pageable] fmt$cycle_description_unit :=
          [NIL, NIL, 0, NIL, NIL],

{ Initial cycle_description_unit entry_assignment string.

    fmv$init_cdu_entry_assignment: [oss$job_pageable] string (fmc$number_of_init_cycle_descs) :=
          fmc$entry_free,


{ Pointer to the initial path_description_unit.

    fmv$initial_pdu_pointer: [XDCL, #GATE {gated for BAM$DISPLAY_TABLES} ,
          oss$job_pageable] ^fmt$path_description_unit := NIL,

{ Initial path_description_unit.

    fmv$initial_pdu: [XDCL {xdcl'd for test_harness} , oss$job_pageable] fmt$path_description_unit :=
          [NIL, 0, 0, NIL, NIL],

{ Initial path_description_unit entry_assignment string.

    fmv$init_pdu_entry_assignment: [oss$job_pageable] string (fmc$number_of_init_path_descs) :=
          fmc$entry_free,


{
{   The following variables are used for seaching through the path table tree.
{
{ pointer to first entry in first path_description_unit
{ All searched through path table start here

    fmv$path_table_entry_point: [XDCL, #GATE {gated for BAM$DISPLAY_TABLES} ,
          oss$job_pageable] ^fmt$path_description_entry := NIL,

{ Pointer to $LOCAL path_description_entry.

    fmv$local_pde: [oss$job_pageable] ^fmt$path_description_entry := NIL,

{
{  The following variables are used for validating a path handle.
{

    fmv$highest_pdu_offset: [XDCL, #GATE {gated for BAM$DISPLAY_TABLES} , oss$job_pageable]
          ost$segment_offset := 0,

{ Unique counter for path_description_entries.
{ Incremented for each pde assigned in a job.

    fmv$pde_assignment_counter: [XDCL, #GATE {gated for BAM$DISPLAY_TABLES} , oss$job_pageable]
          fmt$pde_assignment_counter := 0,

{
{  The following variables are used for gathering statistics.
{  They are gated for use by bam$display_tables.
{

    fmv$named_objects_created: [XDCL, #GATE, oss$job_pageable] ost$non_negative_integers := 0,
    fmv$named_objects_deleted: [XDCL, #GATE, oss$job_pageable] ost$non_negative_integers := 0,
    fmv$cycle_objects_created: [XDCL, #GATE, oss$job_pageable] ost$non_negative_integers := 0,
    fmv$cycle_objects_deleted: [XDCL, #GATE, oss$job_pageable] ost$non_negative_integers := 0,
    fmv$max_active_objects: [XDCL, #GATE, oss$job_pageable] ost$non_negative_integers := 0,
    fmv$max_path_depth: [XDCL, #GATE, oss$job_pageable] ost$non_negative_integers := 0,
    fmv$path_depth_entries: [XDCL, #GATE, oss$job_pageable] array [1 .. fmc$statistics_max_path_depth] of
          ost$non_negative_integers := [REP fmc$statistics_max_path_depth of 0],

{ Place path_description_unit at end of variable declaration to reduce page faults:
{   1: because the beginning of this table and the preceding variables will be referenced together.
{   2: so that the end of the path table just excess a page boundary, such that following variables
{      will be on their own page.
{ Initial path_description_unit entries.

    fmv$initial_pdu_entries: [XDCL {xdcl'd for test_harness} , oss$job_pageable] array
          [1 .. fmc$number_of_init_path_descs] of fmt$path_description_entry,

{
{  The following variables are used for speed and convenience.
{

    fmv$local_node_name: [READ, oss$job_pageable] fst$path_element := [fsc$local_size, fsc$local],

    fmv$default_detachment_options: [XDCL, #GATE, READ, oss$job_paged_literal] fmt$detachment_options :=
          [rmc$mass_storage_device],

    fmv$default_pde: [READ, oss$job_paged_literal] fmt$path_description_entry := [fmc$pde_unique_identifier, 0
          {cumulative_parental_path_size} , 1 {path_depth} , NIL {entry_assignment} , NIL {pdu_pointer} , 0
          {entry_assignment_counter} , NIL {parental_path_entry} , FALSE {path_handle_name_externalized} ,
          fmc$named_object {entry_type} , NIL {parental_tree_entry} , NIL {right_subtree} ,
          NIL {left_subtree}, [0, osc$null_name] {path_node_name} , 0 {randomized_node_name} , NIL
          {highest_cycle} , NIL {next_cycle_alias_entry} , 0 {active_path_participation_count} ],

    fmv$resolved_file_reference: [READ, oss$job_paged_literal] fst$resolved_file_reference := [
          {path} '',
          {catalog_path_size} 0,
          {complete_path_size} 0,
          {cycle_number} [1, 0],
          {cycle_path_size} 0,
          {family_name} [1, 0],
          {family_path_size} 0,
          {file_name} [1, 0],
          {file_path_size} 0,
          {last_catalog_name} [1, 0],
          {master_catalog_name} [1, 0],
          {master_catalog_path_size} 0,
          {number_of_path_elements} 0,
          {open_position} [1, 0],
          {permanent_file} FALSE],

    initial_catalog_object: [oss$job_paged_literal, READ] fst$goi_object :=
          [fsc$goi_catalog_object, fsc$local, * , NIL, NIL, NIL, NIL, NIL, NIL],

    initial_cycle_object: [oss$job_paged_literal, READ] fst$goi_object :=
          [fsc$goi_cycle_object, 1, *, rmc$mass_storage_device, NIL, NIL, NIL, NIL, FALSE,
          NIL, NIL],

    initial_file_object: [oss$job_paged_literal, READ] fst$goi_object :=
          [fsc$goi_file_object, * , NIL, NIL, NIL, NIL, osc$null_name, NIL];

  CONST
    fmc$local_offset = 8; { Offset of name size character + $local }


?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$change_recorded_cycle_num', EJECT ??

*copy fmh$change_recorded_cycle_num

  PROCEDURE [XDCL, #GATE] fmp$change_recorded_cycle_num
    (    evaluated_file_reference: fst$evaluated_file_reference;
         new_cycle: fst$cycle_number;
     VAR status: ost$status);

    VAR
      found: boolean,
      l_evaluated_file_reference: fst$evaluated_file_reference,

{ note: efr must by VAR on call to locate_entry_via_path

      cycle_object: ^fmt$path_description_entry,
      path: fst$path,
      path_size: fst$path_size,
      pde: ^fmt$path_description_entry;

    status.normal := TRUE;
    l_evaluated_file_reference := evaluated_file_reference;

    locate_entry_via_path ($bat$process_pt_work_list [], l_evaluated_file_reference, found, pde, status);

    IF status.normal AND found AND (pde^.entry_type = fmc$file_cycle_object) AND
          (pde^.cycle_number <> new_cycle) THEN
      cycle_object := pde^.parental_path_entry^.highest_cycle;
      locate_cycle (new_cycle, cycle_object);
      IF (cycle_object = NIL) OR (cycle_object^.cycle_description = NIL) THEN
        IF (cycle_object <> NIL) THEN
          extract_cycle_object (cycle_object);
          release_object (cycle_object);
        IFEND;
        extract_cycle_object (pde);
        pde^.cycle_number := new_cycle;
        insert_cycle_object (pde);
      ELSE
        l_evaluated_file_reference.cycle_reference.specification := fsc$cycle_omitted;
        clp$convert_file_ref_to_string (l_evaluated_file_reference, FALSE, path, path_size, status);
        osp$set_status_abnormal (amc$access_method_id, pfe$duplicate_cycle, path (1, path_size), status);
        osp$append_status_integer (osc$status_parameter_delimiter, new_cycle, 10, FALSE, status);
      IFEND;

    IFEND;

  PROCEND fmp$change_recorded_cycle_num;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$change_recorded_file_name', EJECT ??

*copy fmh$change_recorded_file_name

  PROCEDURE [XDCL, #GATE] fmp$change_recorded_file_name
    (    evaluated_file_reference: fst$evaluated_file_reference;
         new_file_name: fst$path_element;
     VAR status: ost$status);

    VAR
      found: boolean,
      l_evaluated_file_reference: fst$evaluated_file_reference,

{ note: efr must by VAR on call to locate_entry_via_path

      randomized_node_name: ost$randomized_name,
      cycle_object: ^fmt$path_description_entry,
      new_pde: ^fmt$path_description_entry,
      old_pde: ^fmt$path_description_entry;

    status.normal := TRUE;
    l_evaluated_file_reference := evaluated_file_reference;
    l_evaluated_file_reference.cycle_reference.specification := fsc$cycle_omitted;

    locate_entry_via_path ($bat$process_pt_work_list [], l_evaluated_file_reference, found, old_pde, status);

    IF status.normal AND found AND (old_pde^.path_node_name <> new_file_name) THEN

{ Remove node logically but not physically

      extract_named_object (old_pde);

{ Create a new named object in the path_table by connecting the
{ object extracted above to the proper NIL node located below.
{ Assumption, that permanent files will already have ensured the
{ name is not a duplicate.

{ Locate the position to insert the
{ old_pde with the new_file_name.

      locate_named_object (new_file_name, old_pde^.parental_path_entry, {create=} FALSE, found, new_pde);

      IF found THEN

{ New_file_name is already in the path table.

        cycle_object := new_pde^.highest_cycle;
        get_high_cycle (cycle_object);
        IF cycle_object = NIL THEN

{ New_file_name is not registered, so it can be deleted.

          cycle_object := new_pde^.highest_cycle;

{ Delete all cycle objects.

          WHILE cycle_object <> NIL DO
            extract_cycle_object (cycle_object);
            release_object (cycle_object);
            cycle_object := new_pde^.highest_cycle;
          WHILEND;

{ And then delete the named object.

          extract_named_object (new_pde);
          release_object (new_pde);

{ Locate the position to insert the
{ old_pde with the new_file_name.

          locate_named_object (new_file_name, old_pde^.parental_path_entry, {create=} FALSE, found, new_pde);
        ELSE {cycle_object <> NIL}

{ Reconnect the extracted pde before returning.

          locate_named_object (old_pde^.path_node_name, old_pde^.parental_path_entry, {create=} FALSE, found,
                new_pde);
          IF old_pde^.randomized_node_name < new_pde^.randomized_node_name THEN
            new_pde^.left_subtree := old_pde;
          ELSE
            new_pde^.right_subtree := old_pde;
          IFEND;
          old_pde^.parental_tree_entry := new_pde;
          osp$set_status_abnormal (amc$access_method_id, pfe$name_already_used, new_file_name.value, status);
        IFEND;
      IFEND; {found}

{ Reconnect old_pde to end of search path (new_pde^.)

      IF status.normal THEN
        osp$randomize_name (new_file_name.value, randomized_node_name);
        IF randomized_node_name < new_pde^.randomized_node_name THEN
          new_pde^.left_subtree := old_pde;
        ELSE
          new_pde^.right_subtree := old_pde;
        IFEND;
        old_pde^.parental_tree_entry := new_pde;
        old_pde^.path_node_name := new_file_name;
        old_pde^.randomized_node_name := randomized_node_name;
        cycle_object := old_pde^.highest_cycle;
        WHILE cycle_object <> NIL DO
          cycle_object^.cumulative_parental_path_size := old_pde^.cumulative_parental_path_size +
                new_file_name.size + 1;
          cycle_object := cycle_object^.next_lower_cycle;
        WHILEND;
      IFEND;

    IFEND; {status.normal & found  -  original path}

  PROCEND fmp$change_recorded_file_name;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$complete_pf_object_info', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$complete_pf_object_info
    (    evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
         password_selector: pft$password_selector;
         validation_ring: ost$valid_ring;
         p_object: ^fst$goi_object;
     VAR p_object_information: ^SEQ ( * );
     VAR all_protected_info_returned: boolean;
     VAR status: ost$status);

    VAR
      found: boolean,
      local_evaluated_file_reference: fst$evaluated_file_reference,
      pde: ^fmt$path_description_entry;

{ The boolean parameter, all_protected_info_returned, is only relevant for
{ password validation.

    status.normal := TRUE;
    all_protected_info_returned := FALSE;

    IF p_object <> NIL THEN
      fmp$lock_path_table (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    /path_table_locked/
      BEGIN
        local_evaluated_file_reference := evaluated_file_reference;
        locate_entry_via_path ($bat$process_pt_work_list [], local_evaluated_file_reference, found, pde,
              status);
        IF NOT status.normal OR NOT found THEN
          EXIT /path_table_locked/;
        IFEND;

{ The pde passed to complete_object must be the parent of the requested object.

        IF pde^.entry_type = fmc$file_cycle_object THEN
          pde := pde^.parental_path_entry;
        IFEND;

        IF p_object^.object_type <> fsc$goi_cycle_object THEN
          pde := pde^.parental_path_entry;
        IFEND;

        complete_object (pde, information_request.object_information_requests, password_selector,
              validation_ring, p_object, all_protected_info_returned, p_object_information, status);
      END /path_table_locked/;

      fmp$unlock_path_table;

    IFEND; {p_object <> NIL}

  PROCEND fmp$complete_pf_object_info;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$create_cycle_description', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$create_cycle_description
    (    return_cycle_description: boolean;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR cycle_description_created: boolean;
     VAR cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

{  fmp$create_cycle_description assumes that if it is called for a permanent file
{  that the evaluate_file_reference is already resolved. If a permanent file is not
{  resolved, a fme$no_cycle_description error will be returned.

    VAR
      found_or_created: boolean,
      pde: ^fmt$path_description_entry;

    status.normal := TRUE;
    cycle_description_created := FALSE;
    cycle_description := NIL;

    fmp$lock_path_table (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    locate_entry_via_path ($bat$process_pt_work_list [bac$record_path, bac$resolve_path],
          evaluated_file_reference, found_or_created, pde, status);
    IF status.normal AND found_or_created AND (pde^.entry_type = fmc$file_cycle_object) THEN
      IF (pde^.cycle_description = NIL) THEN
        create_cycle_description_entry (pde, pde^.cycle_description, status);
        cycle_description_created := status.normal;
      IFEND;
    ELSEIF status.normal THEN
      osp$set_status_condition (fme$no_cycle_description, status);
    IFEND;

    IF status.normal AND return_cycle_description THEN
      cycle_description := pde^.cycle_description;
    ELSE
      fmp$unlock_path_table;
    IFEND;

  PROCEND fmp$create_cycle_description;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$delete_path_description', EJECT ??

*copy fmh$delete_path_description

  PROCEDURE [XDCL, #GATE] fmp$delete_path_description
    (    evaluated_file_reference: fst$evaluated_file_reference;
         implicit_detach: boolean;
         return_permanent_file: boolean;
         detachment_options: ^fst$detachment_options;
     VAR status: ost$status);

    VAR
      alias_pde: ^fmt$path_description_entry,
      cycle_description: ^fmt$cycle_description,
      cycle_pde: ^fmt$path_description_entry,
      delete_alias: boolean,
      delete_path: boolean,
      detachment_options_record: fmt$detachment_options,
      lock_status: ost$status,
      next_lower_alias: ^fmt$path_description_entry,
      open_count: integer,
      p_tape_descriptor: ^bat$tape_descriptor,
      parent_pde: ^fmt$path_description_entry,
      pde: ^fmt$path_description_entry,
      pf_specified_having_one_alias: boolean,
      save_setfa: boolean,
      system_file_label: fmt$system_file_label,
      temp_static_label: bat$static_label_attributes,
      usage_selections: pft$usage_selections;

    status.normal := TRUE;
    delete_alias := FALSE;
    delete_path := FALSE;
    open_count := 0;
    save_setfa := FALSE;
    pf_specified_having_one_alias := FALSE;

    get_detachment_options (detachment_options, detachment_options_record);

{ only caller is fmp$return_file and it sets fmv$path_table_lock and
{ syp$push_inhibit_job_recovery and clears cycle_description.lock

  /delete/
    BEGIN
      fmp$locate_pde_via_path_handle (evaluated_file_reference.path_handle_info.path_handle, pde, status);
      IF NOT status.normal THEN
        EXIT /delete/;
      IFEND;

      alias_pde := pde;

{ Resolved?

      IF pde^.entry_type = fmc$file_cycle_object THEN

{ Doing implicit detach for close?

        IF implicit_detach THEN

{ Any aliases?

          IF (pde^.first_cycle_alias_entry <> NIL) THEN

{ We do not implicitly detach files which have aliases.

            EXIT /delete/;
          IFEND;
          delete_path := TRUE;

{ More than one alias?

        ELSEIF (pde^.first_cycle_alias_entry <> NIL) AND (pde^.first_cycle_alias_entry^.
              next_cycle_alias_entry <> NIL) THEN

{ Delete the most recent alias

          alias_pde := pde^.first_cycle_alias_entry^.next_cycle_alias_entry;
          WHILE alias_pde^.next_cycle_alias_entry <> NIL DO
            alias_pde := alias_pde^.next_cycle_alias_entry;
          WHILEND;
          delete_alias := TRUE;
        ELSE { 1 or no aliases }

{ delete the only alias if there is one and delete the path

          alias_pde := pde^.first_cycle_alias_entry;
          pf_specified_having_one_alias := (alias_pde <> NIL);
          delete_alias := pf_specified_having_one_alias;
          delete_path := TRUE;
        IFEND;
      ELSE { not resolved }

{ Doing implicit detach for close?

        IF (NOT pde_is_alias (pde)) OR implicit_detach THEN

{ An alias or resolved path must always be passed to
{ fmp$delete_path_description.  All routines that implicitly attach
{ the file must pass a resolved path.

          osp$set_status_abnormal (amc$access_method_id, fme$path_handle_not_resolved,
                'FMP$DELETE_PATH_DESCRIPTION', status);
          EXIT /delete/;
        IFEND;
        pde := pde^.highest_cycle;
        delete_alias := TRUE;
        delete_path := (pde^.first_cycle_alias_entry^.next_cycle_alias_entry = NIL);
      IFEND;

{pde will always be a cycle object here.

      IF pde^.cycle_description <> NIL THEN
        osp$fetch_locked_variable (pde^.cycle_description^.global_file_information^.open_count, open_count);
      IFEND;

      IF delete_path THEN

{ If deleting a path then base DELETED on ability to delete the
{ path and not on the alias.
{ delete the cycle description and global_file_information
{ even if cycle object cannot be deleted

        IF open_count = 0 THEN
          IF pde^.cycle_description <> NIL THEN
            cycle_description := pde^.cycle_description;
            IF cycle_description^.attached_file THEN
              IF (cycle_description^.device_class = rmc$magnetic_tape_device) OR
                    (cycle_description^.device_class = rmc$mass_storage_device) THEN
                IF cycle_description^.permanent_file THEN
                  IF return_permanent_file THEN
                    IF implicit_detach AND
                         (cycle_description^.global_file_information^.implicit_detach_inhibited) THEN
                      EXIT /delete/;
                    IFEND;
                    IF (NOT cycle_description^.system_file_label.file_previously_opened) AND
                          (cycle_description^.static_setfa_entries <> NIL) THEN
                      IF implicit_detach THEN
                        save_setfa := TRUE;
                      ELSE
                        fmp$catalog_set_file_attributes (cycle_description, status);
                      IFEND;
                    IFEND;
                    IF implicit_detach AND (cycle_description^.dynamic_setfa_entries <> NIL) THEN
                      save_setfa := TRUE;
                    IFEND; {setfa check
                    #UNCHECKED_CONVERSION (cycle_description^.attached_access_modes, usage_selections);
                    pfp$return_permanent_file (cycle_description^.apfid, cycle_description^.system_file_id,
                          cycle_description^.device_class, usage_selections, status);
                    IF NOT status.normal THEN
                      IF status.condition = mme$io_write_error THEN
                        fsp$set_evaluated_file_abnormal (evaluated_file_reference,
                              ame$unrecovered_write_error, amc$return_req,
                              'The file should be copied and the original purged before logging out.',
                              status);
                      ELSEIF osp$file_access_condition (status) THEN
                        EXIT /delete/;
                      IFEND;
                    IFEND;
                    syp$hang_if_job_jrt_set (fmc$tjr_return);
                  IFEND;
                ELSE {temporary file}
                  IF (cycle_description^.device_class = rmc$mass_storage_device) AND
                        (cycle_description^.system_file_id.residence = gfc$tr_job) THEN
                    dmp$destroy_file (cycle_description^.system_file_id,
                          cycle_description^.file_space_limit_kind, status);
                    IF NOT status.normal THEN
                      EXIT /delete/;
                    IFEND;
                  IFEND;
                IFEND;
                IF cycle_description^.device_class = rmc$magnetic_tape_device THEN

{ The path table is unlocked here to prevent lock conflicts if an interrupt should occur during dismount.

                  fmp$unlock_path_table;
                  dmp$close_tape_volume (cycle_description^.system_file_id, detachment_options_record,
                        status);
                  fmp$lock_path_table (lock_status);
                  IF NOT status.normal THEN
                    EXIT /delete/;
                  IFEND;
                  IF dmv$initialize_tape_volume.in_progress THEN
                    dmp$setup_tape_init_in_progress ({in_progress} FALSE, {element_name} osc$null_name,
                          {logical_unit} 0);
                  IFEND;
                IFEND;
                IF cycle_description^.job_routing_label <> NIL THEN
                  FREE cycle_description^.job_routing_label IN osv$job_pageable_heap^;
                IFEND;
              ELSEIF cycle_description^.device_class = rmc$terminal_device THEN
                fmp$free_terminal_request (cycle_description);
              IFEND;
              IF cycle_description^.system_file_label.static_label <> NIL THEN
                FREE cycle_description^.system_file_label.static_label IN osv$job_pageable_heap^;
              IFEND;
              cycle_description^.attached_file := FALSE;
            IFEND; {attached_file
            IF cycle_description^.cd_attachment_options <> NIL THEN
              FREE cycle_description^.cd_attachment_options IN osv$job_pageable_heap^;
            IFEND;
            IF save_setfa THEN
              EXIT /delete/;
            IFEND;
            IF cycle_description^.static_setfa_entries <> NIL THEN
              FREE cycle_description^.static_setfa_entries IN osv$job_pageable_heap^;
            IFEND;
            IF cycle_description^.dynamic_setfa_entries <> NIL THEN
              FREE cycle_description^.dynamic_setfa_entries IN osv$job_pageable_heap^;
            IFEND;
            IF cycle_description^.device_class = rmc$magnetic_tape_device THEN
              IF cycle_description^.global_file_information^.device_dependent_info.tape_descriptor <> NIL THEN
                RESET cycle_description^.global_file_information^.device_dependent_info.tape_descriptor;
                NEXT p_tape_descriptor IN
                      cycle_description^.global_file_information^.device_dependent_info.tape_descriptor;
                bap$free_tape_label_sequences ({free_initial_volume_sequence} TRUE, p_tape_descriptor);

                FREE cycle_description^.global_file_information^.device_dependent_info.tape_descriptor IN
                      osv$task_shared_heap^;
              IFEND;
            IFEND;
            cycle_description^.entry_assignment^ := fmc$entry_free;
            pde^.cycle_description := NIL;
          IFEND; {cycle_description <> NIL
          IF delete_alias THEN
            extract_named_object (alias_pde);

{ use actual pointer to alias instead of local_pointer so that
{ the actual pointer is set to NIL by release_object

            release_object (pde^.first_cycle_alias_entry);
          IFEND;
          parent_pde := pde^.parental_path_entry;
          IF NOT pde^.path_handle_name_externalized THEN
            extract_cycle_object (pde);
            release_object (pde);
          IFEND;
          pde := parent_pde;
          WHILE (pde <> NIL) AND (pde^.active_path_participation_count = 0) DO
            parent_pde := pde^.parental_path_entry;
            IF NOT pde^.path_handle_name_externalized THEN
              extract_named_object (pde);
              release_object (pde);
            IFEND;
            pde := parent_pde;
          WHILEND;
          EXIT /delete/;
        ELSE
          IF (NOT delete_alias) AND (NOT implicit_detach) THEN
            fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_not_closed, amc$return_req,
                  ' ', status);
            EXIT /delete/;
          IFEND;
        IFEND;
      IFEND;

      IF delete_alias THEN
        IF NOT (pf_specified_having_one_alias AND (open_count > 0)) THEN

{       Do not delete the alias if a permanent file path was
{ specified,
{       only one alias exists and the file is open.

          IF pde^.first_cycle_alias_entry = alias_pde THEN
            pde^.first_cycle_alias_entry := alias_pde^.next_cycle_alias_entry;
          ELSE

{ find next lower 'older' alias

            next_lower_alias := pde^.first_cycle_alias_entry;

{ Shouldn't have to check for nil since alias_pde must be found

            WHILE next_lower_alias^.next_cycle_alias_entry <> alias_pde DO
              next_lower_alias := next_lower_alias^.next_cycle_alias_entry;
            WHILEND;

{ reconnect remaining aliases

            next_lower_alias^.next_cycle_alias_entry := alias_pde^.next_cycle_alias_entry;
          IFEND;

{ delete the alias

          extract_named_object (alias_pde);
          release_object (alias_pde);
        ELSE
          IF NOT implicit_detach THEN
            fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_not_closed, amc$return_req,
                  ' ', status);
          IFEND;
          EXIT /delete/;
        IFEND;
      IFEND;

    END /delete/;

  PROCEND fmp$delete_path_description;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$get_$local_object_info', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to get the requested information about a
{   $local catalog, file, or cycle.

  PROCEDURE [XDCL, #GATE] fmp$get_$local_object_info
    (    evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
         password_selector: pft$password_selector;
         validation_ring: ost$valid_ring;
         p_object_info: {output^} ^fst$goi_object_information;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      found_or_created: boolean,
      local_evaluated_file_reference: fst$evaluated_file_reference,
      p_object: ^fst$goi_object,
      path: fst$path,
      path_node_name: fst$path_element,
      path_size: fst$path_size,
      path_status: ost$status,
      pde: ^fmt$path_description_entry,
      password_validated: boolean;

?? NEWTITLE := 'store_resolved_path', EJECT ??

    PROCEDURE [INLINE] store_resolved_path;

      NEXT p_object_info^.resolved_path: [path_size] IN p_object_information;
      IF p_object_info^.resolved_path = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;
      p_object_info^.resolved_path^ := path (1, path_size);

    PROCEND store_resolved_path;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    path_status.normal := TRUE;

    fmp$lock_path_table (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /path_table_locked/
    BEGIN
      IF evaluated_file_reference.number_of_path_elements = 1 THEN
        path := ':' CAT fsc$local;
        path_size := fsc$local_size + 1;
        IF information_request.object_information_requests = $fst$goi_object_info_requests [] THEN
          EXIT /path_table_locked/;
        IFEND;

        IF (password_selector.password_specified = pfc$specific_password_option) AND
              (password_selector.password <> osc$null_name) THEN
          osp$set_status_condition (pfe$catalogs_have_no_password, status);
          EXIT /path_table_locked/;
        IFEND;

        NEXT p_object IN p_object_information;
        IF p_object = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          EXIT /path_table_locked/;
        IFEND;

        get_$local_catalog_object_info (information_request.object_information_requests, validation_ring,
              p_object, p_object_information, status);

      ELSEIF information_request.object_information_requests * pfv$file_info_requests <>
            $fst$goi_object_info_requests [] THEN
        path_node_name.size := $INTEGER (evaluated_file_reference.path_structure (fmc$local_offset));
        path_node_name.value := evaluated_file_reference.path_structure
              (fmc$local_offset + 1, path_node_name.size);
        locate_named_object (path_node_name, fmv$local_pde, {create =} FALSE, found_or_created, pde);
        IF (NOT found_or_created) OR (pde^.highest_cycle = NIL) THEN
          bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_not_known,
                'PFP$GET_OBJECT_INFORMATION', '', status);
          fmp$unlock_path_table;
          RETURN;
        IFEND;

        NEXT p_object IN p_object_information;
        IF p_object = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          EXIT /path_table_locked/;
        IFEND;

        IF (password_selector.password_specified = pfc$specific_password_option) AND
              (password_selector.password <> osc$null_name) THEN
          osp$set_status_condition (fse$local_files_have_no_pw, status);
          osp$append_status_file (osc$status_parameter_delimiter, path (1, path_size), status);
          password_validated := FALSE;
        ELSE
          password_validated := TRUE;
        IFEND;

        get_$local_file_object_info (evaluated_file_reference.cycle_reference,
              information_request.object_information_requests, validation_ring, password_validated, p_object,
              pde, p_object_information, status);

        recreate_path_string (pde, path, path_size, path_status);

      ELSEIF information_request.object_information_requests * pfv$cycle_info_requests <>
            $fst$goi_object_info_requests [] THEN
        local_evaluated_file_reference := evaluated_file_reference;
        locate_entry_via_path ($bat$process_pt_work_list [bac$resolve_path], local_evaluated_file_reference,
              found_or_created, pde, status);
        IF (NOT status.normal) OR (NOT found_or_created) OR (pde^.cycle_description = NIL) THEN
          bap$set_evaluated_file_abnormal (local_evaluated_file_reference, ame$file_not_known,
                'PFP$GET_OBJECT_INFORMATION', '', status);
          fmp$unlock_path_table;
          RETURN;
        IFEND;

        NEXT p_object IN p_object_information;
        IF p_object = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          EXIT /path_table_locked/;
        IFEND;

        IF (password_selector.password_specified = pfc$specific_password_option) AND
              (password_selector.password <> osc$null_name) THEN
          osp$set_status_condition (fse$local_files_have_no_pw, status);
          osp$append_status_file (osc$status_parameter_delimiter, path (1, path_size), status);
          password_validated := FALSE;
        ELSE
          password_validated := TRUE;
        IFEND;

        get_$local_cycle_object_info (pde, information_request.object_information_requests, validation_ring,
              password_validated, p_object, p_object_information, status);

        recreate_path_string (pde, path, path_size, path_status);

      ELSE
        p_object := NIL;
        clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position =} FALSE, path,
              path_size, path_status);
      IFEND;

      IF status.normal THEN
        p_object_info^.object := p_object;
      ELSEIF status.condition = ame$ring_validation_error THEN
        p_object_info^.object := p_object;
        osp$append_status_file (osc$status_parameter_delimiter, path (1, path_size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'PFP$GET_OBJECT_INFORMATION', status);
      IFEND;
    END /path_table_locked/;

    IF path_status.normal THEN
      store_resolved_path;
    ELSEIF status.normal THEN
      status := path_status;
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$get_$local_object_info;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$get_list_of_$local_files', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$get_list_of_$local_files
    (VAR info: pft$p_info;
     VAR status: ost$status);

    VAR
      outer_record_type: ^pft$info_record_type,
      outer_record_size: ^pft$info_record_body_size,
      directory: pft$p_directory_array,
      directory_record_type: ^pft$info_record_type,
      directory_record_size: ^pft$info_record_body_size,
      directory_entry: pft$p_directory_array_entry,
      info_record: pft$p_info_record,
      cycle_object: ^fmt$path_description_entry,
      pdu: ^fmt$path_description_unit,
      pde: ^fmt$path_description_entry,
      saved_info: pft$p_info,
      entry: integer,
      entry_count: integer;

    saved_info := info;
    NEXT outer_record_type IN info;
    outer_record_type^ := pfc$multi_item_info_record;
    NEXT outer_record_size IN info;
    NEXT directory_record_type IN info;
    directory_record_type^ := pfc$directory_array_record;
    NEXT directory_record_size IN info;
    entry_count := 0;

    fmp$lock_path_table (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /get_list_of_$local/
    BEGIN

{ Get pointer to the first entry in the first path_description_unit.

      IF fmv$initial_pdu_pointer <> NIL THEN
        pdu := fmv$initial_pdu_pointer;
      ELSE
        EXIT /get_list_of_$local/;
      IFEND;

      WHILE pdu <> NIL DO

{ Look at every assigned entry in a path_description_unit.

        FOR entry := 1 TO #SIZE (pdu^.entry_assignment^) DO
          IF pdu^.entry_assignment^ (entry) = fmc$entry_assigned THEN
            pde := ^pdu^.entries^ [entry];
            IF pde^.entry_type = fmc$named_object THEN
              IF pde^.parental_path_entry <> NIL THEN
                IF pde^.parental_path_entry^.path_node_name.value = fsc$local THEN
                  cycle_object := pde^.highest_cycle;
                  get_high_cycle (cycle_object);
                  IF (cycle_object <> NIL) AND cycle_object^.cycle_description^.attached_file THEN
                    NEXT directory_entry IN info;
                    directory_entry^.name := pde^.path_node_name.value;
                    directory_entry^.name_type := pfc$file_name;
                    directory_entry^.info_offset := 0;
                    entry_count := entry_count + 1;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        FOREND;

{ move on to next unit if pointer is not NIL

        pdu := pdu^.next_path_description_unit;
      WHILEND;
    END /get_list_of_$local/;

    fmp$unlock_path_table;

    directory_record_size^ := #SIZE (pft$directory_array_entry) * entry_count;
    outer_record_size^ := #SIZE (pft$info_record_type) + #SIZE (pft$info_record_body_size) +
          directory_record_size^;

    info := saved_info;
    pfp$find_next_info_record (info, info_record, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pfp$find_directory_array (info_record, directory, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sort_directory (directory);

  PROCEND fmp$get_list_of_$local_files;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$get_path_elements', EJECT ??

{*copy fmh$get_path_elements

  PROCEDURE [XDCL, #GATE] fmp$get_path_elements
    (    path_handle: fmt$path_handle;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

    VAR
      pde: ^fmt$path_description_entry;

    status.normal := TRUE;

    evaluated_file_reference := fsv$evaluated_file_reference;

    fmp$lock_path_table (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /get_elements/
    BEGIN
      fmp$locate_pde_via_path_handle (path_handle, pde, status);
      IF NOT status.normal THEN
        EXIT /get_elements/;
      IFEND;

      evaluated_file_reference.path_handle_info.path_handle := path_handle;
      evaluated_file_reference.path_handle_info.path_handle_present := TRUE;

      IF pde_is_alias (pde) THEN
        pde := pde^.highest_cycle;

{ Change path_handle to match the path being returned.

        evaluated_file_reference.path_handle_info.path_handle.segment_offset := #OFFSET (pde);
        evaluated_file_reference.path_handle_info.path_handle.assignment_counter :=
              pde^.entry_assignment_counter;
      IFEND;

      recreate_path_elements (pde, evaluated_file_reference);
    END /get_elements/;

    fmp$unlock_path_table;

  PROCEND fmp$get_path_elements;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$get_path_string', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$get_path_string
    (    path_handle: fmt$path_handle;
         lock_path_table: boolean;
     VAR path: fst$path;
     VAR path_size: fst$path_size;
     VAR status: ost$status);

    VAR
      pde: ^fmt$path_description_entry;

    status.normal := TRUE;
    path := '';
    path_size := 0;

    IF lock_path_table THEN
      fmp$lock_path_table (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  /get_string/
    BEGIN
      fmp$locate_pde_via_path_handle (path_handle, pde, status);
      IF NOT status.normal THEN
        EXIT /get_string/;
      IFEND;

      IF pde_is_alias (pde) THEN
        pde := pde^.highest_cycle;
      IFEND;

      recreate_path_string (pde, path, path_size, status);
    END /get_string/;

    IF lock_path_table THEN
      fmp$unlock_path_table;
    IFEND;

  PROCEND fmp$get_path_string;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$get_resolved_file_reference', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$get_resolved_file_reference
    (VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR resolved_file_reference: fst$resolved_file_reference;
     VAR status: ost$status);

    CONST
      get_resolved_file_reference = 'FMP$GET_RESOLVED_FILE_REFERENCE';

    VAR
      cycle_string: ost$string,
      found_or_created: boolean,
      last_catalog_pde: ^fmt$path_description_entry,
      master_catalog_pde: ^fmt$path_description_entry,
      pde: ^fmt$path_description_entry;

    status.normal := TRUE;

    resolved_file_reference := fmv$resolved_file_reference;

    fmp$lock_path_table (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /path_table_locked/
    BEGIN
      locate_entry_via_path ($bat$process_pt_work_list [bac$record_path, bac$resolve_path,
            bac$resolve_to_catalog], evaluated_file_reference, found_or_created, pde, status);
      IF NOT status.normal THEN
        EXIT /path_table_locked/;
      ELSEIF NOT found_or_created THEN
        IF (evaluated_file_reference.number_of_path_elements = 1) AND
              (fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local) THEN
          osp$set_status_abnormal (amc$access_method_id, pfe$name_not_permanent_file,
                fsp$path_element (^evaluated_file_reference, 1) ^, status);
          EXIT /path_table_locked/;
        ELSE
          osp$set_status_abnormal (amc$access_method_id, fme$system_error,
                '- NOT found_or_created in ' CAT get_resolved_file_reference, status);
          EXIT /path_table_locked/;
        IFEND;
      IFEND;

{ Note: path depth is the same in last element and it's cycle objects

      resolved_file_reference.number_of_path_elements := pde^.path_depth;

      IF pde^.entry_type = fmc$file_cycle_object THEN
        clp$convert_integer_to_string (pde^.cycle_number, 10, FALSE, cycle_string, status);
        IF NOT status.normal THEN
          EXIT /path_table_locked/;
        IFEND;

        IF (pde^.cumulative_parental_path_size + cycle_string.size + 1) > fsc$max_path_size THEN
          osp$set_status_abnormal (amc$access_method_id, cle$file_reference_too_long,
                get_resolved_file_reference, status);
          EXIT /path_table_locked/;
        IFEND;

        resolved_file_reference.file_path_size := pde^.cumulative_parental_path_size;
        resolved_file_reference.cycle_path_size := resolved_file_reference.file_path_size +
              cycle_string.size + 1;

{ The following code builds the resolved file reference starting
{ from the cycle_number and works its way back to the family_name.
{ The open_position, if specified, is appended after the path has been built.

{ Cycle_number

        resolved_file_reference.cycle_number.index := resolved_file_reference.file_path_size + 2;
        resolved_file_reference.cycle_number.size := cycle_string.size;
        resolved_file_reference.path (resolved_file_reference.cycle_number.index,
              resolved_file_reference.cycle_number.size) := cycle_string.
              value (1, resolved_file_reference.cycle_number.size);

        pde := pde^.parental_path_entry;
        IF (pde = NIL) OR (pde^.parental_path_entry = NIL) THEN
          osp$set_status_abnormal (amc$access_method_id, fme$system_error,
                '- path too short in ' CAT get_resolved_file_reference, status);
          EXIT /path_table_locked/;
        IFEND;

        resolved_file_reference.catalog_path_size := pde^.cumulative_parental_path_size;

{ Delimiter

        resolved_file_reference.path (resolved_file_reference.file_path_size + 1, 1) := '.';

{ File name

        resolved_file_reference.file_name.index := resolved_file_reference.catalog_path_size + 2;
        resolved_file_reference.file_name.size := pde^.path_node_name.size;
        resolved_file_reference.path (resolved_file_reference.file_name.index,
              resolved_file_reference.file_name.size) := pde^.path_node_name.value;

        pde := pde^.parental_path_entry;

{ Delimiter

        resolved_file_reference.path (resolved_file_reference.catalog_path_size + 1, 1) := '.';
      ELSEIF (evaluated_file_reference.path_resolution = fsc$catalog_path) THEN
        resolved_file_reference.catalog_path_size := pde^.cumulative_parental_path_size +
              pde^.path_node_name.size + 1;
        resolved_file_reference.cycle_path_size := resolved_file_reference.catalog_path_size;
        resolved_file_reference.file_path_size := resolved_file_reference.catalog_path_size;
      ELSE
        osp$set_status_abnormal (amc$access_method_id, fme$system_error,
              '- path not resolved in ' CAT get_resolved_file_reference, status);
        EXIT /path_table_locked/;
      IFEND;

{ Last catalog name

      resolved_file_reference.last_catalog_name.index := pde^.cumulative_parental_path_size + 2;
      resolved_file_reference.last_catalog_name.size := pde^.path_node_name.size;
      resolved_file_reference.path (resolved_file_reference.last_catalog_name.index,
            resolved_file_reference.last_catalog_name.size) := pde^.path_node_name.value;

{ All remaining catalog names

      last_catalog_pde := pde;
      master_catalog_pde := last_catalog_pde;
      WHILE pde^.parental_path_entry <> NIL DO
        master_catalog_pde := pde;
        resolved_file_reference.path (pde^.cumulative_parental_path_size + 1, 1) := '.';
        pde := pde^.parental_path_entry;
        resolved_file_reference.path (pde^.cumulative_parental_path_size + 2, pde^.path_node_name.size) :=
              pde^.path_node_name.value;
      WHILEND;
      resolved_file_reference.path (1, 1) := ':';

      resolved_file_reference.permanent_file := (pde^.path_node_name.value (1,
            pde^.path_node_name.size) <> fsc$local);

{ Master & Family catalog names

      IF resolved_file_reference.permanent_file THEN
        IF (pde <> master_catalog_pde) THEN
          IF master_catalog_pde = last_catalog_pde THEN
            resolved_file_reference.master_catalog_name := resolved_file_reference.last_catalog_name;
            resolved_file_reference.master_catalog_path_size := resolved_file_reference.catalog_path_size;
          ELSE
            resolved_file_reference.master_catalog_name.size := master_catalog_pde^.path_node_name.size;
            resolved_file_reference.master_catalog_name.index :=
                  master_catalog_pde^.cumulative_parental_path_size + 2;
            resolved_file_reference.master_catalog_path_size :=
                  master_catalog_pde^.cumulative_parental_path_size +
                  resolved_file_reference.master_catalog_name.size + 1;
          IFEND;
        ELSE
          resolved_file_reference.master_catalog_path_size := pde^.path_node_name.size + 1;
        IFEND;
        resolved_file_reference.family_name.size := pde^.path_node_name.size;
        resolved_file_reference.family_name.index := 2;
        resolved_file_reference.family_path_size := resolved_file_reference.family_name.size + 1;
      ELSE
        IF (master_catalog_pde <> last_catalog_pde) OR (pde <> master_catalog_pde) THEN
          osp$set_status_abnormal (amc$access_method_id, fme$system_error,
                '- local path too long in ' CAT get_resolved_file_reference, status);
          EXIT /path_table_locked/;
        IFEND;
        resolved_file_reference.master_catalog_name := resolved_file_reference.last_catalog_name;
        resolved_file_reference.master_catalog_path_size := resolved_file_reference.catalog_path_size;
        resolved_file_reference.family_name := resolved_file_reference.master_catalog_name;
        resolved_file_reference.family_path_size := resolved_file_reference.master_catalog_path_size;
      IFEND;

{ Open_position

      IF evaluated_file_reference.path_handle_info.path_handle.open_position.specified AND
            (evaluated_file_reference.path_resolution <> fsc$catalog_path) THEN
        resolved_file_reference.open_position.size := clv$open_position_designator
              [evaluated_file_reference.path_handle_info.path_handle.open_position.value].size;
        IF resolved_file_reference.cycle_path_size + resolved_file_reference.open_position.size + 1 >
              fsc$max_path_size THEN
          osp$set_status_abnormal (amc$access_method_id, cle$file_reference_too_long,
                get_resolved_file_reference, status);
          EXIT /path_table_locked/;
        IFEND;
        resolved_file_reference.open_position.index := resolved_file_reference.cycle_path_size + 2;
        resolved_file_reference.path (resolved_file_reference.cycle_path_size + 1, 1) := '.';
        resolved_file_reference.path (resolved_file_reference.open_position.index,
              resolved_file_reference.open_position.size) := clv$open_position_designator [
              evaluated_file_reference.path_handle_info.path_handle.open_position.value].
              value (1, resolved_file_reference.open_position.size);
        resolved_file_reference.complete_path_size := resolved_file_reference.cycle_path_size +
              resolved_file_reference.open_position.size + 1;
      ELSE
        resolved_file_reference.complete_path_size := resolved_file_reference.cycle_path_size;
      IFEND;

    END /path_table_locked/;

    fmp$unlock_path_table;

  PROCEND fmp$get_resolved_file_reference;

?? TITLE := 'PROCEDURE [XDCL] fmp$get_setfa_values_for_object', EJECT ??

  PROCEDURE [XDCL] fmp$get_setfa_values_for_object
    (    evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
         validation_ring: ost$valid_ring;
         p_object: ^fst$goi_object;
     VAR p_object_information: ^SEQ ( * );
     VAR setfa_values_found: boolean;
     VAR status: ost$status);

    VAR
      all_protected_info_returned: boolean,
      cycle_pde: ^fmt$path_description_entry,
      found: boolean,
      local_evaluated_file_reference: fst$evaluated_file_reference,
      password_selector: pft$password_selector,
      pde: ^fmt$path_description_entry;

    status.normal := TRUE;

    IF p_object <> NIL THEN
      fmp$lock_path_table (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    /path_table_locked/
      BEGIN
        local_evaluated_file_reference := evaluated_file_reference;
        locate_entry_via_path ($bat$process_pt_work_list [], local_evaluated_file_reference, found, pde,
              status);
        IF NOT status.normal OR NOT found THEN
          setfa_values_found := FALSE;
          EXIT /path_table_locked/;
        IFEND;

        IF pde^.entry_type = fmc$named_object THEN
          cycle_pde := pde^.highest_cycle;
          get_high_cycle (cycle_pde);
        ELSE
          cycle_pde := pde;
        IFEND;

        setfa_values_found := (cycle_pde <> NIL) AND (cycle_pde^.cycle_description <> NIL) AND
              ((cycle_pde^.cycle_description^.static_setfa_entries <> NIL) OR
              (cycle_pde^.cycle_description^.dynamic_setfa_entries <> NIL));
        IF NOT setfa_values_found THEN
          EXIT /path_table_locked/;
        IFEND;

        initialize_cycle_object (p_object);
        p_object^.cycle_number := cycle_pde^.cycle_number;
        pde := cycle_pde^.parental_path_entry;

        all_protected_info_returned := TRUE;

{ The value of password_selector is irrelevant in this case since a validation
{ error could not have occurred.

        complete_object (pde, information_request.object_information_requests, password_selector,
              validation_ring, p_object, all_protected_info_returned, p_object_information, status);
        setfa_values_found := status.normal;
      END /path_table_locked/;

      fmp$unlock_path_table;
    IFEND; {p_object <> NIL}

  PROCEND fmp$get_setfa_values_for_object;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$initialize_path_table', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$initialize_path_table;

{ This must be the first procedure called that references the path_table
{ during job initialization.
{ This procedure will initialize the first path_description_entry of the first
{ path_description_unit to $LOCAL.  This procedure will also initialize all
{ job specific pointers to the first path_description_unit.
{ This procedure is called by JMP$JOB_BEGIN.

    VAR
      local_catalog_path_handle: fmt$path_handle;

{ Initialize the first path_description_unit pointers and statistics.

    fmv$initial_pdu.entry_assignment := ^fmv$init_pdu_entry_assignment;
    fmv$initial_pdu.entries := ^fmv$initial_pdu_entries;
    fmv$highest_pdu_offset := #OFFSET (fmv$initial_pdu.entries) +
          (#SIZE (fmt$path_description_entry) * (fmc$number_of_init_path_descs - 1)) + 1;
    fmv$initial_pdu_pointer := ^fmv$initial_pdu;
    fmv$path_table_entry_point := ^fmv$initial_pdu_entries [1];

{ Assign the first path_description_entry to $LOCAL.

    increment_assignment_counter;
    fmv$initial_pdu.entry_assignment^ (1) := fmc$entry_assigned;
    fmv$initial_pdu.total_count := 1;
    fmv$initial_pdu.current_count := 1;
    fmv$named_objects_created := 1;
    fmv$max_active_objects := 1;

{ Initialize job pointer to the $LOCAL path_description_entry.

    fmv$local_pde := fmv$path_table_entry_point;

{ Initialize the $LOCAL path_description_entry.

    fmv$local_pde^.unique_identifier := fmc$pde_unique_identifier;
    fmv$local_pde^.cumulative_parental_path_size := 0;
    fmv$local_pde^.path_depth := 1;
    fmv$local_pde^.entry_assignment := ^fmv$initial_pdu.entry_assignment^ (1,1);
    fmv$local_pde^.pdu_pointer := ^fmv$initial_pdu;
    fmv$local_pde^.entry_assignment_counter := fmv$pde_assignment_counter;
    fmv$local_pde^.parental_path_entry := NIL;
    fmv$local_pde^.path_handle_name_externalized := TRUE; { Don't ever let $LOCAL be deleted }
    fmv$local_pde^.entry_type := fmc$named_object;
    fmv$local_pde^.parental_tree_entry := NIL;
    fmv$local_pde^.left_subtree := NIL;
    fmv$local_pde^.right_subtree := NIL;
    fmv$local_pde^.path_node_name := fmv$local_node_name;
    osp$randomize_name (fmv$local_node_name.value, fmv$local_pde^.randomized_node_name);
    fmv$local_pde^.highest_cycle := NIL;
    fmv$local_pde^.next_cycle_alias_entry := NIL;
    fmv$local_pde^.active_path_participation_count := 0;

{ set up path handle name for $local

    local_catalog_path_handle.segment_offset := #OFFSET (fmv$local_pde);
    local_catalog_path_handle.assignment_counter := fmv$local_pde^.entry_assignment_counter;
    local_catalog_path_handle.open_position.specified := FALSE;
    clp$construct_path_handle_name (local_catalog_path_handle, clv$local_catalog_handle_name);

{ Initialize first cycle description

    fmv$initial_cdu.global_file_entries_pointer := ^fmv$initial_global_file_entries;
    fmv$initial_cdu.entry_assignment := ^fmv$init_cdu_entry_assignment;
    fmv$initial_cdu.entries := ^fmv$initial_cdu_entries;
    fmv$initial_cdu_pointer := ^fmv$initial_cdu;

  PROCEND fmp$initialize_path_table;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$is_file_attached', EJECT ??

*copy fmh$is_file_attached

  PROCEDURE [XDCL, #GATE] fmp$is_file_attached
    (    path_handle: fmt$path_handle;
     VAR attached: boolean;
     VAR status: ost$status);

    VAR
      pde: ^fmt$path_description_entry;

    status.normal := TRUE;
    attached := FALSE;

    fmp$lock_path_table (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fmp$locate_pde_via_path_handle (path_handle, pde, status);
    IF status.normal THEN
      IF pde^.entry_type = fmc$file_cycle_object THEN
        attached := (pde^.cycle_description <> NIL) AND pde^.cycle_description^.attached_file;
      IFEND;
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$is_file_attached;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$is_file_registered', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$is_file_registered
    (    path_handle: fmt$path_handle;
     VAR attached: boolean;
     VAR status: ost$status);

    VAR
      pde: ^fmt$path_description_entry;

    status.normal := TRUE;
    attached := FALSE;

    fmp$lock_path_table (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fmp$locate_pde_via_path_handle (path_handle, pde, status);
    IF status.normal THEN
      IF pde^.entry_type = fmc$file_cycle_object THEN
        attached := pde^.cycle_description <> NIL;
      IFEND;
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$is_file_registered;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$locate_cd_via_path_handle', EJECT ??

*copy fmh$locate_cd_via_path_handle

  PROCEDURE [XDCL, #GATE] fmp$locate_cd_via_path_handle
    (    path_handle: fmt$path_handle;
         lock_path_table: boolean;
     VAR cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

    VAR
      pde: ^fmt$path_description_entry;

    status.normal := TRUE;
    cycle_description := NIL;

    IF lock_path_table THEN
      fmp$lock_path_table (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    fmp$locate_pde_via_path_handle (path_handle, pde, status);
    IF status.normal THEN
      IF pde^.entry_type = fmc$file_cycle_object THEN
        IF (pde^.cycle_description <> NIL) THEN
          cycle_description := pde^.cycle_description;
        IFEND;
      ELSE
        IF pde_is_alias (pde) THEN
          IF (pde^.highest_cycle^.cycle_description <> NIL) THEN
            cycle_description := pde^.highest_cycle^.cycle_description;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF cycle_description = NIL THEN
      osp$set_status_condition (fme$no_cycle_description, status);
      IF lock_path_table THEN
        fmp$unlock_path_table;
      IFEND;
    IFEND;

  PROCEND fmp$locate_cd_via_path_handle;

?? TITLE := 'PROCEDURE [XDCL] fmp$locate_cycle_description', EJECT ??

  PROCEDURE [XDCL] fmp$locate_cycle_description
    (VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

    VAR
      found: boolean,
      pde: ^fmt$path_description_entry;

    status.normal := TRUE;
    cycle_description := NIL;

    fmp$lock_path_table (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    locate_entry_via_path ($bat$process_pt_work_list [bac$resolve_path, bac$resolve_to_catalog],
          evaluated_file_reference, found, pde, status);
    IF status.normal AND found AND (pde^.entry_type = fmc$file_cycle_object) AND
          (pde^.cycle_description <> NIL) THEN
      cycle_description := pde^.cycle_description;
      RETURN; {The path table should remain locked because the cycle description is being returned.
    ELSEIF status.normal OR (status.condition = pfe$unknown_permanent_file) THEN
      osp$set_status_condition (fme$no_cycle_description, status);
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$locate_cycle_description;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$process_pt_request', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$process_pt_request
    (    process_pt_work_list: bat$process_pt_work_list;
         local_file_name: amt$local_file_name;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR cycle_description: ^fmt$cycle_description;
     VAR process_pt_results: bat$process_pt_results;
     VAR status: ost$status);

?? NEWTITLE := 'PROCEDURE assign_alias_to_file', EJECT ??

    PROCEDURE assign_alias_to_file
      (    local_file_name: amt$local_file_name;
           path_pde: {i/o} ^fmt$path_description_entry;
       VAR status: ost$status);

      VAR
        alias_found_or_created: boolean,
        alias_path_node_name: fst$path_element,
        alias_pde: ^fmt$path_description_entry,
        cycle_object: ^fmt$path_description_entry,
        temp_alias_pde: ^fmt$path_description_entry,
        temp_path_handle: fmt$path_handle;

      IF (path_pde = NIL) OR (path_pde^.entry_type <> fmc$file_cycle_object) THEN
        osp$set_status_abnormal (amc$access_method_id, fme$system_error,
              'Entry not a cycle_object in fmp$process_pt_request', status);
        RETURN;
      IFEND;

{ Record the local_file_name as ':$local.local_file_name'

      alias_path_node_name.value := local_file_name;
      alias_path_node_name.size := clp$trimmed_string_size (local_file_name);
      locate_named_object (alias_path_node_name, fmv$local_pde, {create=} TRUE, alias_found_or_created,
            alias_pde);

{ Check for pfe$lfn_in_use

      IF alias_pde^.highest_cycle <> NIL THEN
        cycle_object := alias_pde^.highest_cycle;
        get_high_cycle (cycle_object);
        IF cycle_object = NIL THEN
          cycle_object := alias_pde^.highest_cycle;

{ Delete all cycle objects.

          WHILE cycle_object <> NIL DO
            extract_cycle_object (cycle_object);
            release_object (cycle_object);
            cycle_object := alias_pde^.highest_cycle;
          WHILEND;
        ELSE
          osp$set_status_abnormal (amc$access_method_id, pfe$lfn_in_use, local_file_name, status);

{ Note: path_resolution is already set to fsc$unresolved_path

          RETURN;
        IFEND;
      IFEND;

{ Link alias to the path's cycle_object.

      alias_pde^.highest_cycle := path_pde;
      alias_pde^.next_cycle_alias_entry := NIL;
      IF path_pde^.first_cycle_alias_entry = NIL THEN
        path_pde^.first_cycle_alias_entry := alias_pde;
      ELSE

{ Reconstruct pointers between alias_pde's from first to last.
{ Set temp_alias_pde to the first_alias.

        temp_alias_pde := path_pde^.first_cycle_alias_entry;
        WHILE temp_alias_pde^.next_cycle_alias_entry <> NIL DO
          temp_alias_pde := temp_alias_pde^.next_cycle_alias_entry;
        WHILEND;
        temp_alias_pde^.next_cycle_alias_entry := alias_pde;
      IFEND;

    PROCEND assign_alias_to_file;
?? OLDTITLE ??

    VAR
      found_or_created: boolean,
      pde: ^fmt$path_description_entry;

    #KEYPOINT (osk$entry, 0, fmk$process_pt_request);

    status.normal := TRUE;
    cycle_description := NIL;
    IF bac$resolve_path IN process_pt_work_list THEN
      evaluated_file_reference.path_resolution := fsc$unresolved_path;
    IFEND;
    process_pt_results := $bat$process_pt_results [];

    IF NOT (bac$inhibit_locking_pt IN process_pt_work_list) THEN
      fmp$lock_path_table (status);
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, fmk$process_pt_request);
        RETURN;
      IFEND;
    IFEND;

  /path_table_locked/
    BEGIN

{ Record path.

      locate_entry_via_path (process_pt_work_list, evaluated_file_reference, found_or_created, pde, status);
      IF (NOT status.normal) OR (NOT found_or_created) THEN
        EXIT /path_table_locked/;
      IFEND;

      IF (bac$externalize_path_handle IN process_pt_work_list) AND
            (NOT pde^.path_handle_name_externalized) THEN
        pde^.path_handle_name_externalized := TRUE;
      IFEND;

      IF local_file_name <> osc$null_name THEN
        assign_alias_to_file (local_file_name, pde, status);
        IF NOT status.normal THEN
          EXIT /path_table_locked/;
        IFEND;
      IFEND;

{ Return/create cycle description.

      IF pde^.entry_type = fmc$file_cycle_object THEN
        IF pde^.cycle_description = NIL THEN
          IF bac$create_cycle_description IN process_pt_work_list THEN
            create_cycle_description_entry (pde, pde^.cycle_description, status);
            IF NOT status.normal THEN
              EXIT /path_table_locked/;
            IFEND;
            process_pt_results := process_pt_results + $bat$process_pt_results
                  [bac$cycle_description_created, bac$cycle_description_exists];
          IFEND;
        ELSE
          process_pt_results := process_pt_results + $bat$process_pt_results [bac$cycle_description_exists];
        IFEND;
        IF bac$return_cycle_description IN process_pt_work_list THEN
          cycle_description := pde^.cycle_description;
        IFEND;
      IFEND;

    END /path_table_locked/;

    IF (cycle_description = NIL) AND (NOT (bac$inhibit_locking_pt IN process_pt_work_list)) THEN
      fmp$unlock_path_table;
    IFEND;

    #KEYPOINT (osk$exit, 0, fmk$process_pt_request);

  PROCEND fmp$process_pt_request;

?? TITLE := 'PROCEDURE [XDCL] fmp$setup_job_environment_info', EJECT ??

  PROCEDURE [XDCL] fmp$setup_job_environment_info
    (    cycle_description_p: {input^} ^fmt$cycle_description;
         path_handle_p: ^fmt$path_handle;
         job_environment_information_p: {output^}
               ^fst$job_environment_information;
     VAR object_information_p: ^SEQ ( * ));

    VAR
      access_mode: fst$file_access_option,
      density: rmt$density,
      local_object_information_p: ^SEQ ( * ),
      local_status: ost$status,
      object_info_p: ^fst$goi_object_information,
      removable_media_group: ost$name,
      subject_path_handle_name: fst$path_handle_name;

    job_environment_information_p^ := fsv$default_job_environ_info;

    IF cycle_description_p^.attached_file THEN
      #UNCHECKED_CONVERSION (cycle_description_p^.system_file_label.descriptive_label.global_access_mode,
            job_environment_information_p^.attached_access_modes);
      #UNCHECKED_CONVERSION (cycle_description_p^.system_file_label.descriptive_label.global_share_mode,
            job_environment_information_p^.attached_share_modes);
      IF cycle_description_p^.device_class = rmc$magnetic_tape_device THEN
        fmp$get_attached_tape_info (cycle_description_p^.system_file_id, job_environment_information_p^.
              volume_list, job_environment_information_p^.volume_number, job_environment_information_p^.
              volume_overflow_allowed, density, removable_media_group,
              object_information_p, local_status);
      IFEND;
    IFEND;

    IF (cycle_description_p^.cd_attachment_options <> NIL) THEN
      IF cycle_description_p^.cd_attachment_options^.
            free_behind_specified THEN
        job_environment_information_p^.mass_storage_free_behind :=
              cycle_description_p^.cd_attachment_options^.free_behind;
        job_environment_information_p^.specified_attachment_options :=
              job_environment_information_p^.specified_attachment_options + $fst$specified_attach_options
              [fsc$free_behind_ao];
      IFEND;
      IF cycle_description_p^.cd_attachment_options^.
            job_write_concurrency_specified THEN
        job_environment_information_p^.job_write_concurrency :=
              cycle_description_p^.cd_attachment_options^.
              job_write_concurrency;
        job_environment_information_p^.specified_attachment_options :=
              job_environment_information_p^.specified_attachment_options + $fst$specified_attach_options
              [fsc$job_write_concurrency_ao];
      IFEND;
      IF cycle_description_p^.cd_attachment_options^.
            sequential_access_specified THEN
        job_environment_information_p^.mass_storage_sequential_access :=
              cycle_description_p^.cd_attachment_options^.sequential_access;
        job_environment_information_p^.specified_attachment_options :=
              job_environment_information_p^.specified_attachment_options + $fst$specified_attach_options
              [fsc$sequential_access_ao];
      IFEND;
      IF cycle_description_p^.cd_attachment_options^.
            transfer_size_specified THEN
        job_environment_information_p^.transfer_size :=
              cycle_description_p^.cd_attachment_options^.transfer_size;
        job_environment_information_p^.specified_attachment_options :=
              job_environment_information_p^.specified_attachment_options + $fst$specified_attach_options
              [fsc$transfer_size_ao];
      IFEND;
      IF (cycle_description_p^.cd_attachment_options^.private_read_specified)
            THEN
        job_environment_information_p^.private_read.specified_on_attach :=
              TRUE;
        job_environment_information_p^.private_read.value :=
              cycle_description_p^.cd_attachment_options^.private_read;
      IFEND;
    IFEND;

    job_environment_information_p^.concurrent_open_count :=
          cycle_description_p^.global_file_information^.open_count;

    IF path_handle_p <> NIL THEN
      clp$construct_path_handle_name (path_handle_p^, subject_path_handle_name);
      fmp$get_list_of_connected_files (subject_path_handle_name, job_environment_information_p^.
            connected_files, object_information_p);
    IFEND;

    job_environment_information_p^.cycle_attached :=
          cycle_description_p^.attached_file;
    job_environment_information_p^.job_file_address :=
          cycle_description_p^.global_file_information^.positioning_info.
          record_info.current_byte_address;
    job_environment_information_p^.job_file_position :=
          cycle_description_p^.global_file_information^.positioning_info.
          record_info.file_position;

    FOR access_mode := LOWERVALUE (fst$file_access_option) TO
          UPPERVALUE (fst$file_access_option) DO
      IF cycle_description_p^.global_file_information^.
            prevented_open_access_modes [access_mode] <> 0 THEN
        job_environment_information_p^.prevented_open_access_modes :=
              job_environment_information_p^.prevented_open_access_modes +
              $fst$file_access_options [access_mode];
      IFEND;
    FOREND;

    IF cycle_description_p^.dynamic_setfa_entries <> NIL THEN
      IF cycle_description_p^.dynamic_setfa_entries^.access_modes_specified THEN
        job_environment_information_p^.setfa_access_modes :=
              cycle_description_p^.dynamic_setfa_entries^.access_modes;
        job_environment_information_p^.attachment_options_sources.access_modes_source :=
              amc$file_command;
      IFEND;

      IF cycle_description_p^.dynamic_setfa_entries^.error_exit_name_specified THEN
        job_environment_information_p^.error_exit_procedure_name :=
              cycle_description_p^.dynamic_setfa_entries^.error_exit_name;
        job_environment_information_p^.attachment_options_sources.error_exit_name_source :=
              amc$file_command;
      IFEND;
      IF cycle_description_p^.dynamic_setfa_entries^.error_limit_specified THEN
        job_environment_information_p^.error_limit :=
              cycle_description_p^.dynamic_setfa_entries^.error_limit;
        job_environment_information_p^.attachment_options_sources.error_limit_source :=
              amc$file_command;
      IFEND;
      IF cycle_description_p^.dynamic_setfa_entries^.label_exit_name_specified THEN
        job_environment_information_p^.label_exit_procedure_name :=
              cycle_description_p^.dynamic_setfa_entries^.label_exit_name;
        job_environment_information_p^.attachment_options_sources.label_exit_name_source :=
              amc$file_command;
      IFEND;
      IF cycle_description_p^.dynamic_setfa_entries^.message_control_specified THEN
        job_environment_information_p^.message_control :=
              cycle_description_p^.dynamic_setfa_entries^.message_control;
        job_environment_information_p^.attachment_options_sources.message_control_source :=
              amc$file_command;
      IFEND;
      IF cycle_description_p^.path_handle.open_position.specified THEN
        job_environment_information_p^.open_position :=
              cycle_description_p^.path_handle.open_position.value;
        job_environment_information_p^.attachment_options_sources.open_position_source :=
              amc$file_reference;
      ELSEIF cycle_description_p^.dynamic_setfa_entries^.open_position_specified THEN
        job_environment_information_p^.open_position :=
              cycle_description_p^.dynamic_setfa_entries^.open_position;
        job_environment_information_p^.attachment_options_sources.open_position_source :=
              amc$file_command;
      IFEND;
    IFEND;

  PROCEND fmp$setup_job_environment_info;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$unlock_path_table_at_tskend', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$unlock_path_table_at_tskend;

    VAR
      lock_status: ost$signature_lock_status;

    osp$test_sig_lock (fmv$path_table_lock, lock_status);
    IF lock_status = osc$sls_locked_by_current_task THEN
      fmp$unlock_path_table;
      osp$recoverable_system_error ('FMV$PATH_TABLE_LOCK is already set ' CAT 'by the current task.', NIL);
    IFEND;

  PROCEND fmp$unlock_path_table_at_tskend;

?? TITLE := 'PROCEDURE allocate_cycle_description_unit', EJECT ??

  PROCEDURE allocate_cycle_description_unit
    (VAR {input,output} cdu: ^fmt$cycle_description_unit);

{ PURPOSE: This procedure will allocate a cycle_description_unit,
{          initialize its entry_assignment string, and links it to
{          the previous cycle_description_unit.

    VAR
      entries_seq: ^SEQ ( * ),
      old_cdu: ^fmt$cycle_description_unit;

    old_cdu := cdu;

    ALLOCATE entries_seq: [[REP 1 OF fmt$cycle_description_unit, REP fmc$cycle_table_allocation_size OF char,
          REP fmc$cycle_table_allocation_size OF fmt$cycle_description]] IN osv$job_pageable_heap^;

    RESET entries_seq;
    NEXT cdu IN entries_seq;
    IF cdu = NIL THEN
      osp$system_error ('NEXT of cdu resulted in NIL', NIL);
    IFEND;
    NEXT cdu^.entry_assignment: [fmc$cycle_table_allocation_size] IN entries_seq;
    IF cdu^.entry_assignment = NIL THEN
      osp$system_error ('NEXT of cdu^.entry_assignment resulted in NIL', NIL);
    IFEND;
    NEXT cdu^.entries: [1 .. fmc$cycle_table_allocation_size] IN entries_seq;
    IF cdu^.entries = NIL THEN
      osp$system_error ('NEXT of cdu^.entries resulted in NIL on entries', NIL);
    IFEND;

    ALLOCATE cdu^.global_file_entries_pointer: [1 .. fmc$cycle_table_allocation_size] IN
          osv$task_shared_heap^;

    old_cdu^.next_cycle_description_unit := cdu;
    cdu^.next_cycle_description_unit := NIL;
    cdu^.total_count := 0;

{ CYBIL will blank fill a string, so the following assignment is ok
{ as long as fmc$entry_free is a blank.

    cdu^.entry_assignment^ := fmc$entry_free;

  PROCEND allocate_cycle_description_unit;

?? TITLE := 'PROCEDURE allocate_path_description_unit', EJECT ??

  PROCEDURE allocate_path_description_unit
    (VAR {input,output} pdu: ^fmt$path_description_unit);

{ Purpose: This procedure is used to allocate another unit of
{          path_description_entries if the existing ones have no more
{          unassigned entries.  A pointer to the new pdu is returned.

    VAR
      entries_seq: ^SEQ ( * ),
      new_highest_pdu_offset: ost$segment_offset,
      old_pdu: ^fmt$path_description_unit;

    old_pdu := pdu;

    ALLOCATE entries_seq: [[REP 1 OF fmt$path_description_unit, REP fmc$path_table_allocation_size OF char,
          REP fmc$path_table_allocation_size OF fmt$path_description_entry]] IN osv$job_pageable_heap^;

    RESET entries_seq;
    NEXT pdu IN entries_seq;
    IF pdu = NIL THEN
      osp$system_error ('NEXT of pdu resulted in NIL', NIL);
    IFEND;
    NEXT pdu^.entry_assignment: [fmc$path_table_allocation_size] IN entries_seq;
    IF pdu^.entry_assignment = NIL THEN
      osp$system_error ('NEXT of pdu^.entry_assignment resulted in NIL', NIL);
    IFEND;
    NEXT pdu^.entries: [1 .. fmc$path_table_allocation_size] IN entries_seq;
    IF pdu^.entries = NIL THEN
      osp$system_error ('NEXT of pdu^.entries resulted in NIL', NIL);
    IFEND;

    old_pdu^.next_path_description_unit := pdu;

    pdu^.total_count := 0;
    pdu^.current_count := 0;
    pdu^.next_path_description_unit := NIL;

{ CYBIL will blank fill a string, so the following assignment is ok
{ as long as fmc$entry_free is a blank.

    pdu^.entry_assignment^ := fmc$entry_free;


{ update statistics

    new_highest_pdu_offset := #OFFSET (pdu^.entries) + (#SIZE (fmt$path_description_entry) *
          (fmc$path_table_allocation_size - 1)) + 1;
    IF new_highest_pdu_offset > fmv$highest_pdu_offset THEN
      fmv$highest_pdu_offset := new_highest_pdu_offset;
    IFEND;

  PROCEND allocate_path_description_unit;

?? TITLE := 'PROCEDURE complete_object', EJECT ??

  PROCEDURE complete_object
    (    pde: ^fmt$path_description_entry;
         object_info_requests: fst$goi_object_info_requests;
         password_selector: pft$password_selector;
         validation_ring: ost$valid_ring;
         p_object: ^fst$goi_object;
     VAR all_protected_info_returned: boolean;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      current_pde: ^fmt$path_description_entry,
      found: boolean,
      header: ^fmt$static_label_header,
      label_size: ost$non_negative_integers,
      local_status: ost$status,
      object_list_index: ost$positive_integers,
      path: fst$path,
      path_node_name: fst$path_element,
      path_size: fst$path_size;

    all_protected_info_returned := TRUE;

    CASE p_object^.object_type OF
    = fsc$goi_catalog_object =
      IF p_object^.subcatalog_and_file_object_list <> NIL THEN
        path_node_name.value := p_object^.catalog_name;
        path_node_name.size := clp$trimmed_string_size (p_object^.catalog_name);
        locate_named_object (path_node_name, pde, {create =} FALSE, found, current_pde);
        IF found THEN
          FOR object_list_index := 1 TO UPPERBOUND (p_object^.subcatalog_and_file_object_list^) DO
            complete_object (current_pde, object_info_requests, password_selector, validation_ring,
                  ^p_object^.subcatalog_and_file_object_list^ [object_list_index],
                  all_protected_info_returned, p_object_information, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND;
        IFEND;
      IFEND;

    = fsc$goi_file_object =
      IF p_object^.cycle_object_list <> NIL THEN
        path_node_name.value := p_object^.file_name;
        path_node_name.size := clp$trimmed_string_size (p_object^.file_name);
        locate_named_object (path_node_name, pde, {create =} FALSE, found, current_pde);
        IF found THEN
          FOR object_list_index := 1 TO UPPERBOUND (p_object^.cycle_object_list^) DO
            complete_object (current_pde, object_info_requests, password_selector, validation_ring,
                  ^p_object^.cycle_object_list^ [object_list_index], all_protected_info_returned,
                  p_object_information, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND;
        IFEND;
      IFEND;

    = fsc$goi_cycle_object =
      current_pde := pde^.highest_cycle;
      locate_cycle (p_object^.cycle_number, current_pde);
      IF (current_pde <> NIL) AND (current_pde^.cycle_description <> NIL) THEN
        IF (fsc$goi_cycle_size IN object_info_requests) AND current_pde^.cycle_description^.
              attached_file AND (current_pde^.cycle_description^.device_class = rmc$mass_storage_device) AND
              current_pde^.cycle_description^.permanent_file AND
              ($fst$file_access_options [fsc$append, fsc$shorten, fsc$modify] *
              current_pde^.cycle_description^.attached_access_modes <> $fst$file_access_options []) AND
              current_pde^.cycle_description^.global_file_information^.eoi_set THEN
          IF p_object^.cycle_size = NIL THEN
            NEXT p_object^.cycle_size IN p_object_information;
            IF p_object^.cycle_size = NIL THEN
              osp$set_status_condition (pfe$info_full, status);
              RETURN;
            IFEND;
          IFEND;
          p_object^.cycle_size^ := current_pde^.cycle_description^.global_file_information^.eoi_byte_address;
        IFEND;
        IF (fsc$goi_file_label IN object_info_requests) OR (fsc$goi_job_environment_info IN
              object_info_requests) THEN
          IF p_object^.validation_error THEN
            IF current_pde^.cycle_description^.attached_file THEN
              IF (password_selector.password_specified = pfc$default_password_option) THEN
                IF current_pde^.cycle_description^.system_file_label.file_previously_opened THEN
                  validate_ring_access (validation_ring, current_pde^.cycle_description^.system_file_label.
                        static_label, status);
                  IF NOT status.normal THEN
                    all_protected_info_returned := FALSE;
                    RETURN;
                  ELSE
                    p_object^.validation_error := FALSE;
                  IFEND;
                ELSE
                  p_object^.validation_error := FALSE;
                IFEND;
              ELSE
                all_protected_info_returned := FALSE;
                RETURN;
              IFEND;
            ELSE
              all_protected_info_returned := FALSE;
            IFEND;
          IFEND;

          IF all_protected_info_returned AND (fsc$goi_file_label IN object_info_requests) THEN
            IF current_pde^.cycle_description^.static_setfa_entries = NIL THEN
              IF current_pde^.cycle_description^.attached_file THEN
                IF current_pde^.cycle_description^.system_file_label.static_label = NIL THEN
                  label_size := #SIZE (fmt$static_label_header);
                  NEXT p_object^.file_label: [[REP label_size OF cell]] IN p_object_information;
                  IF p_object^.file_label = NIL THEN
                    osp$set_status_condition (pfe$info_full, status);
                    RETURN;
                  IFEND;
                  i#move (^fmv$static_label_header, p_object^.file_label, label_size);
                  IF NOT current_pde^.cycle_description^.system_file_label.file_previously_opened THEN
                    RESET p_object^.file_label;
                    NEXT header IN p_object^.file_label;
                    header^.file_previously_opened := FALSE;
                  IFEND;
                ELSE
                  label_size := #SIZE (current_pde^.cycle_description^.system_file_label.static_label^);
                  NEXT p_object^.file_label: [[REP label_size OF cell]] IN p_object_information;
                  IF p_object^.file_label = NIL THEN
                    osp$set_status_condition (pfe$info_full, status);
                    RETURN;
                  IFEND;
                  i#move (current_pde^.cycle_description^.system_file_label.static_label,
                        p_object^.file_label, label_size);
                IFEND;
              IFEND; { attached_file }
            ELSE { preserved_attribute were specified on a SETFA }
              IF (current_pde^.cycle_description^.attached_file AND
                    NOT current_pde^.cycle_description^.system_file_label.file_previously_opened AND
                    (current_pde^.cycle_description^.system_file_label.static_label = NIL)) OR
                    (NOT current_pde^.cycle_description^.attached_file AND (p_object^.file_label = NIL)) THEN
                label_size := #SIZE (current_pde^.cycle_description^.static_setfa_entries^);
                NEXT p_object^.file_label: [[REP label_size OF cell]] IN p_object_information;
                IF p_object^.file_label = NIL THEN
                  osp$set_status_condition (pfe$info_full, status);
                  RETURN;
                IFEND;
                i#move (current_pde^.cycle_description^.static_setfa_entries, p_object^.file_label,
                      label_size);
              ELSE
                IF current_pde^.cycle_description^.attached_file AND
                      (current_pde^.cycle_description^.system_file_label.static_label <> NIL) THEN
                  IF current_pde^.cycle_description^.system_file_label.file_previously_opened THEN
                    label_size := #SIZE (current_pde^.cycle_description^.system_file_label.static_label^);
                    NEXT p_object^.file_label: [[REP label_size OF cell]] IN p_object_information;
                    IF p_object^.file_label = NIL THEN
                      osp$set_status_condition (pfe$info_full, status);
                      RETURN;
                    IFEND;
                    i#move (current_pde^.cycle_description^.system_file_label.static_label,
                          p_object^.file_label, label_size);
                  ELSE
                    p_object^.file_label := current_pde^.cycle_description^.system_file_label.static_label;
                  IFEND;
                IFEND;
                fmp$merge_setfa_entries (current_pde^.cycle_description^.static_setfa_entries, p_object,
                      p_object_information, status);
                IF NOT status.normal THEN
                  p_object^.file_label := NIL;
                  RETURN;
                IFEND;
              IFEND;
            IFEND; { static_setfa_entries = NIL }
          IFEND; { file_label requested }

          IF (fsc$goi_job_environment_info IN object_info_requests) THEN
            IF (current_pde^.cycle_description^.dynamic_setfa_entries <> NIL) OR
                  all_protected_info_returned THEN
              IF current_pde^.cycle_description^.attached_file THEN
                validate_ring_access (validation_ring, current_pde^.cycle_description^.system_file_label.
                      static_label, status);
              ELSE
                validate_default_ring_access (validation_ring, status);
              IFEND;
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              NEXT p_object^.job_environment_information IN p_object_information;
              IF p_object^.job_environment_information = NIL THEN
                osp$set_status_condition (pfe$info_full, status);
              ELSE
                fmp$setup_job_environment_info (current_pde^.cycle_description, {path_handle_p} NIL,
                      p_object^.job_environment_information, p_object_information);
              IFEND;
            IFEND;
          IFEND;

        IFEND; {file_label or job_environment_info requested}
      ELSE
        all_protected_info_returned := FALSE;
      IFEND;

    ELSE
    CASEND;

  PROCEND complete_object;

?? TITLE := 'PROCEDURE create_cycle_description_entry', EJECT ??

  PROCEDURE create_cycle_description_entry
    (    pde: ^fmt$path_description_entry;
     VAR cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

{ PURPOSE: This procedure searches the already allocated
{          cycle_description_units in order starting with the first to
{          have been allocated until it finds a free entry.  If no
{          free entries are found then another cycle_description_unit
{          will be allocated.  The entry found will be initialized.

    VAR
      cdu: ^fmt$cycle_description_unit,
      found: boolean,
      validated_name: amt$local_file_name,
      valid_name: boolean,
      index: 1 .. cyc$max_string_size + 1;

    status.normal := TRUE;
    cycle_description := NIL;

    IF pdes_first_element_is_$local (pde) THEN

{ Validate a temporary file name before creating a cycle_description
{ for it to ensure an invalid name is not used for an actual file.

      clp$validate_new_file_name (pde^.parental_path_entry^.path_node_name.value, validated_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal (amc$access_method_id, pfe$bad_permanent_file_name, validated_name, status);
        RETURN;
      IFEND;
    IFEND;

    cdu := fmv$initial_cdu_pointer;

{ Always start search from first cycle_description_unit and
{ search all units before allocating more.

    WHILE cycle_description = NIL DO
      #SCAN (fmv$entry_free_selector, cdu^.entry_assignment^, index, found);
      IF found THEN
        cdu^.total_count := cdu^.total_count + 1;
        cdu^.entry_assignment^ (index) := fmc$entry_assigned;
        cycle_description := ^cdu^.entries^ [index];
        cycle_description^.entry_assignment := ^cdu^.entry_assignment^ (index,1);
        cycle_description^.path_handle.segment_offset := #OFFSET (pde);
        cycle_description^.path_handle.assignment_counter := pde^.entry_assignment_counter;
        cycle_description^.path_handle.open_position.specified := FALSE;
        cycle_description^.global_file_information := ^cdu^.global_file_entries_pointer^ [index];
        cycle_description^.global_file_information^ := fmv$global_file_information;
        cycle_description^.static_setfa_entries := NIL;
        cycle_description^.dynamic_setfa_entries := NIL;
        cycle_description^.cd_attachment_options := NIL;
        cycle_description^.attached_file := FALSE;
      ELSEIF cdu^.next_cycle_description_unit <> NIL THEN
        cdu := cdu^.next_cycle_description_unit;
      ELSE
        allocate_cycle_description_unit (cdu);
      IFEND;
    WHILEND;

  PROCEND create_cycle_description_entry;

?? TITLE := 'PROCEDURE [INLINE] create_cycle_object', EJECT ??

  PROCEDURE [INLINE] create_cycle_object
    (    cycle_number: fst$cycle_number;
         parent_path_node: ^fmt$path_description_entry;
     VAR cycle_object: ^fmt$path_description_entry);

{ PURPOSE: Search assignment strings in allocated pdu's in order for an
{          unassigned entry.  Initializes the entry once found.

    VAR
      active_objects: ost$non_negative_integers,
      index: 1 .. cyc$max_string_size + 1,
      pdu: ^fmt$path_description_unit,
      found: boolean;

    found := FALSE;

    cycle_object := NIL;

{ Start at the root of path_table.
{ Note: It is not possible for the incoming PDU to be NIL since at least
{   one named_object must always be created first.

    pdu := fmv$initial_pdu_pointer;

{ Search assignment strings in order for an unassigned entry.

    REPEAT

{ The pdu should probably be locked for scan and until entry assigned.

      IF pdu^.current_count < #SIZE (pdu^.entry_assignment^) THEN
        #SCAN (fmv$entry_free_selector, pdu^.entry_assignment^, index, found);
      ELSE
        found := FALSE;
      IFEND;
      IF found THEN
        increment_assignment_counter;
        pdu^.entry_assignment^ (index) := fmc$entry_assigned;
        pdu^.total_count := pdu^.total_count + 1;
        pdu^.current_count := pdu^.current_count + 1;
        fmv$cycle_objects_created := fmv$cycle_objects_created + 1;
        active_objects := fmv$cycle_objects_created + fmv$named_objects_created - fmv$cycle_objects_deleted -
              fmv$named_objects_deleted;
        IF active_objects > fmv$max_active_objects THEN
          fmv$max_active_objects := active_objects;
        IFEND;
        cycle_object := ^pdu^.entries^ [index];

{ Initialize the cycle_object.

        cycle_object^.unique_identifier := fmc$pde_unique_identifier;
        cycle_object^.cumulative_parental_path_size := parent_path_node^.cumulative_parental_path_size +
              parent_path_node^.path_node_name.size + 1; { +1 is for period }
        cycle_object^.path_depth := parent_path_node^.path_depth;
        cycle_object^.entry_assignment := ^pdu^.entry_assignment^ (index,1);
        cycle_object^.pdu_pointer := pdu;
        cycle_object^.entry_assignment_counter := fmv$pde_assignment_counter;
        cycle_object^.parental_path_entry := parent_path_node;
        cycle_object^.path_handle_name_externalized := FALSE;
        cycle_object^.entry_type := fmc$file_cycle_object;
        cycle_object^.cycle_number := cycle_number;
        cycle_object^.first_cycle_alias_entry := NIL;
        cycle_object^.cycle_description := NIL;
        cycle_object^.parental_path_entry^.active_path_participation_count :=
              cycle_object^.parental_path_entry^.active_path_participation_count + 1;
        insert_cycle_object (cycle_object);

      ELSEIF pdu^.next_path_description_unit <> NIL THEN
        pdu := pdu^.next_path_description_unit;

      ELSE
        allocate_path_description_unit (pdu);
      IFEND;
    UNTIL cycle_object <> NIL;

  PROCEND create_cycle_object;

?? TITLE := 'PROCEDURE [INLINE] create_named_object', EJECT ??

  PROCEDURE [INLINE] create_named_object
    (    parent_path_node: ^fmt$path_description_entry;
         parent_tree_node: ^fmt$path_description_entry;
         path_node_name: fst$path_element;
         randomized_node_name: ost$randomized_name;
     VAR node: ^fmt$path_description_entry);

{ PURPOSE: Search assignment strings in allocated pdu's in order for an
{          unassigned entry.  Initialize the entry once found.

    VAR
      active_objects: ost$non_negative_integers,
      index: 1 .. cyc$max_string_size + 1,
      pdu: ^fmt$path_description_unit,
      found: boolean;

    found := FALSE;

    node := NIL;

    pdu := fmv$initial_pdu_pointer;

    REPEAT

{ The pdu should probably be locked for scan and until entry assigned.

      IF pdu^.current_count < #SIZE (pdu^.entry_assignment^) THEN
        #SCAN (fmv$entry_free_selector, pdu^.entry_assignment^, index, found);
      ELSE
        found := FALSE;
      IFEND;
      IF found THEN
        increment_assignment_counter;
        pdu^.entry_assignment^ (index) := fmc$entry_assigned;
        pdu^.total_count := pdu^.total_count + 1;
        pdu^.current_count := pdu^.current_count + 1;
        fmv$named_objects_created := fmv$named_objects_created + 1;
        active_objects := fmv$cycle_objects_created + fmv$named_objects_created - fmv$cycle_objects_deleted -
              fmv$named_objects_deleted;
        IF active_objects > fmv$max_active_objects THEN
          fmv$max_active_objects := active_objects;
        IFEND;
        node := ^pdu^.entries^ [index];

{ Initialize the node.

        node^.active_path_participation_count := 0;
        node^.unique_identifier := fmc$pde_unique_identifier;
        IF parent_path_node <> NIL THEN
          node^.cumulative_parental_path_size := parent_path_node^.cumulative_parental_path_size +
                parent_path_node^.path_node_name.size + 1;

{ +1 is for period, or colon

          node^.path_depth := parent_path_node^.path_depth + 1;
          parent_path_node^.active_path_participation_count :=
                parent_path_node^.active_path_participation_count + 1;
        ELSE { If no parent then it must be first element in path }
          node^.cumulative_parental_path_size := 0;
          node^.path_depth := 1;
        IFEND;
        node^.entry_assignment := ^pdu^.entry_assignment^ (index,1);
        node^.pdu_pointer := pdu;
        node^.entry_assignment_counter := fmv$pde_assignment_counter;
        node^.parental_path_entry := parent_path_node;
        node^.path_handle_name_externalized := FALSE;
        node^.entry_type := fmc$named_object;
        node^.parental_tree_entry := parent_tree_node;
        node^.left_subtree := NIL;
        node^.right_subtree := NIL;
        node^.path_node_name := path_node_name;
        node^.randomized_node_name := randomized_node_name;
        node^.highest_cycle := NIL;
        node^.next_cycle_alias_entry := NIL;
        IF parent_tree_node <> NIL THEN

{ Connect parental_tree_entry to the new subtree entry

          IF randomized_node_name < parent_tree_node^.randomized_node_name THEN
            node^.parental_tree_entry^.left_subtree := node;
          ELSE
            node^.parental_tree_entry^.right_subtree := node;
          IFEND;
        IFEND;
      ELSEIF pdu^.next_path_description_unit <> NIL THEN
        pdu := pdu^.next_path_description_unit;
      ELSE
        allocate_path_description_unit (pdu);
      IFEND;
    UNTIL node <> NIL;

  PROCEND create_named_object;

?? TITLE := 'PROCEDURE [INLINE] extract_cycle_object', EJECT ??

  PROCEDURE [INLINE] extract_cycle_object
    (VAR cycle_object: ^fmt$path_description_entry);

{ PURPOSE: This procedure extracts a cycle_object from a linked list
{          of cycle_objects.  The named_object is updated to reflect
{          the removal.


    IF cycle_object = cycle_object^.parental_path_entry^.highest_cycle THEN
      cycle_object^.parental_path_entry^.highest_cycle := cycle_object^.next_lower_cycle;
    IFEND;

    IF cycle_object^.next_lower_cycle <> NIL THEN
      cycle_object^.next_lower_cycle^.next_higher_cycle := cycle_object^.next_higher_cycle;
    IFEND;

    IF cycle_object^.next_higher_cycle <> NIL THEN
      cycle_object^.next_higher_cycle^.next_lower_cycle := cycle_object^.next_lower_cycle;
    IFEND;

  PROCEND extract_cycle_object;

?? TITLE := 'PROCEDURE [INLINE] extract_named_object', EJECT ??

  PROCEDURE [INLINE] extract_named_object
    (    pde: ^fmt$path_description_entry);

{ PURPOSE: This procedure uncouples a named_object entry from the binary
{          tree and re-constructs the tree without it.  The named_object
{          entry is left intact, just uncoupled.

    VAR
      parent_pde: ^fmt$path_description_entry,
      right_pde: ^fmt$path_description_entry,
      left_pde: ^fmt$path_description_entry,
      temp_pde: ^fmt$path_description_entry;

    left_pde := pde^.left_subtree;
    right_pde := pde^.right_subtree;
    parent_pde := pde^.parental_tree_entry;

  /extract/
    BEGIN

{ Determine if there are no descendants

      IF (left_pde = NIL) AND (right_pde = NIL) THEN
        IF parent_pde <> NIL THEN
          IF parent_pde^.left_subtree = pde THEN
            parent_pde^.left_subtree := NIL;
          ELSE
            parent_pde^.right_subtree := NIL;
          IFEND;
        IFEND;
        EXIT /extract/;
      IFEND;

{ Determine if there is more than one descendants

      IF (left_pde <> NIL) AND (right_pde <> NIL) THEN
        temp_pde := left_pde;

{ Find rightmost node with NIL right_subtree pointer below left
{ subtree
{ of node to be deleted.

        WHILE temp_pde^.right_subtree <> NIL DO
          temp_pde := temp_pde^.right_subtree;
        WHILEND;

        IF parent_pde <> NIL THEN

{ Hook left_pde to parent.

          IF parent_pde^.left_subtree = pde THEN
            parent_pde^.left_subtree := left_pde;
          ELSE
            parent_pde^.right_subtree := left_pde;
          IFEND;
        IFEND;
        left_pde^.parental_tree_entry := parent_pde;

{ Hook right bottom node of left_pde to right_pde.

        right_pde^.parental_tree_entry := temp_pde;
        temp_pde^.right_subtree := right_pde;

        EXIT /extract/;
      IFEND;

{ Only one descendant.

      IF left_pde <> NIL THEN
        IF parent_pde <> NIL THEN

{ Hook left_pde to parent.

          IF parent_pde^.left_subtree = pde THEN
            parent_pde^.left_subtree := left_pde;
          ELSE
            parent_pde^.right_subtree := left_pde;
          IFEND;
        IFEND;
        left_pde^.parental_tree_entry := parent_pde;
      ELSE { right_pde <> NIL }
        IF parent_pde <> NIL THEN

{ Hook right_pde to parent.

          IF parent_pde^.right_subtree = pde THEN
            parent_pde^.right_subtree := right_pde;
          ELSE
            parent_pde^.left_subtree := right_pde;
          IFEND;
        IFEND;
        right_pde^.parental_tree_entry := parent_pde;
      IFEND;

    END /extract/;

    pde^.parental_tree_entry := NIL;
    pde^.left_subtree := NIL;
    pde^.right_subtree := NIL;

  PROCEND extract_named_object;

?? TITLE := 'PROCEDURE [INLINE] get_detachment_options', EJECT ??

    PROCEDURE [INLINE] get_detachment_options
      (    detachment_options: ^fst$detachment_options;
       VAR detachment_options_record: fmt$detachment_options);

      VAR
        detachment_option_index: integer;

      detachment_options_record.device_class := rmc$mass_storage_device;
      IF detachment_options <> NIL THEN
        FOR detachment_option_index := 1 TO UPPERBOUND (detachment_options^) DO
          CASE detachment_options^ [detachment_option_index].selector OF
          = fsc$do_unload_volume =
            detachment_options_record.device_class := rmc$magnetic_tape_device;
            detachment_options_record.physical_unload :=
                  detachment_options^ [detachment_option_index].unload_volume;
          = fsc$do_null_detachment_option =
            ;
          ELSE
          CASEND;
        FOREND;
      IFEND;
    PROCEND get_detachment_options;

?? TITLE := 'PROCEDURE get_$local_catalog_object_info', EJECT ??

  PROCEDURE get_$local_catalog_object_info
    (    object_information_requests: fst$goi_object_info_requests;
         validation_ring: ost$valid_ring;
         p_object: {output^} ^fst$goi_object;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      cycle_pde: ^fmt$path_description_entry,
      cycle_reference: fst$cycle_reference,
      file_count: ost$non_negative_integers,
      file_index: ost$positive_integers,
      pde: ^fmt$path_description_entry,
      pdu: ^fmt$path_description_unit,
      pdu_entry: integer;

    status.normal := TRUE;

    p_object^ := initial_catalog_object;

    IF fsc$goi_file_object_list IN object_information_requests THEN

{ Get the requested information for every file in the $LOCAL catalog, except aliases.

      IF fmv$initial_pdu_pointer <> NIL THEN
        pdu := fmv$initial_pdu_pointer;
        file_count := 0;
        WHILE pdu <> NIL DO
          FOR pdu_entry := 1 TO #SIZE (pdu^.entry_assignment^) DO
            IF pdu^.entry_assignment^ (pdu_entry) = fmc$entry_assigned THEN
              pde := ^pdu^.entries^ [pdu_entry];

{ Calculate the number of temporary files in order to know how much space to allocate for the
{ file_object_list array.

              IF (pde^.entry_type = fmc$named_object) AND (pde^.parental_path_entry = fmv$local_pde) AND
                    (pde^.highest_cycle <> NIL) THEN
                IF NOT pde_is_alias (pde) THEN
                  cycle_pde := pde^.highest_cycle;
                  get_high_cycle (cycle_pde);
                  IF cycle_pde <> NIL THEN
                    file_count := file_count + 1;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          FOREND;
          pdu := pdu^.next_path_description_unit;
        WHILEND;

        NEXT p_object^.subcatalog_and_file_object_list: [1 .. file_count] IN p_object_information;
        pdu := fmv$initial_pdu_pointer;
        file_index := 1;
        WHILE (pdu <> NIL) AND (file_index <= file_count) DO
          FOR pdu_entry := 1 TO #SIZE (pdu^.entry_assignment^) DO
            IF pdu^.entry_assignment^ (pdu_entry) = fmc$entry_assigned THEN
              pde := ^pdu^.entries^ [pdu_entry];
              IF (pde^.entry_type = fmc$named_object) AND (pde^.parental_path_entry = fmv$local_pde) AND
                    (pde^.highest_cycle <> NIL) THEN
                IF NOT pde_is_alias (pde) THEN
                  cycle_pde := pde^.highest_cycle;
                  get_high_cycle (cycle_pde);
                  IF cycle_pde <> NIL THEN
                    cycle_reference.specification := fsc$high_cycle;
                    get_$local_file_object_info (cycle_reference, object_information_requests,
                          validation_ring, {password_validated =} TRUE,
                          ^p_object^.subcatalog_and_file_object_list^ [file_index], pde, p_object_information,
                          status);
                    file_index := file_index + 1;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          FOREND;
          pdu := pdu^.next_path_description_unit;
        WHILEND;

      IFEND; { fmv$initial_pdu_pointer <> NIL }
    IFEND;

  PROCEND get_$local_catalog_object_info;

?? TITLE := 'PROCEDURE get_$local_cycle_object_info', EJECT ??

  PROCEDURE get_$local_cycle_object_info
    (    cycle_pde: ^fmt$path_description_entry;
         object_info_requests: fst$goi_object_info_requests;
         validation_ring: ost$valid_ring;
         password_validated: boolean;
         p_object: ^fst$goi_object;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      eoi: amt$file_byte_address,
      header: ^fmt$static_label_header,
      label_size: ost$non_negative_integers,
      path_handle_p: ^fmt$path_handle;

    status.normal := TRUE;

    initialize_cycle_object (p_object);
    p_object^.cycle_number := cycle_pde^.cycle_number;

    IF cycle_pde^.cycle_description <> NIL THEN
      IF cycle_pde^.cycle_description^.attached_file THEN
        p_object^.cycle_global_file_name :=
              cycle_pde^.cycle_description^.system_file_label.descriptive_label.internal_cycle_name;
        p_object^.cycle_device_class := cycle_pde^.cycle_description^.device_class;

        IF fsc$goi_cycle_device_info IN object_info_requests THEN
          pfp$get_attached_device_info ({temporary_file} TRUE, {served_family} FALSE,
                {served_family_locator} NIL, cycle_pde^.cycle_description, p_object,
                p_object_information, eoi, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;

      IF (fsc$goi_cycle_size IN object_info_requests) AND (p_object^.cycle_device_class =
            rmc$mass_storage_device) THEN
        NEXT p_object^.cycle_size IN p_object_information;
        IF p_object^.cycle_size = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          RETURN;
        IFEND;
        IF cycle_pde^.cycle_description^.global_file_information^.eoi_set THEN
          p_object^.cycle_size^ := cycle_pde^.cycle_description^.global_file_information^.eoi_byte_address;
        ELSEIF cycle_pde^.cycle_description^.attached_file THEN
            dmp$fetch_eoi (cycle_pde^.cycle_description^.system_file_id, p_object^.cycle_size^, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          p_object^.cycle_size^ := 0;
        IFEND;
      IFEND;

      IF ((fsc$goi_file_label IN object_info_requests) OR (fsc$goi_job_environment_info IN
            object_info_requests)) AND password_validated THEN
        IF cycle_pde^.cycle_description^.attached_file AND cycle_pde^.cycle_description^.system_file_label.
              file_previously_opened THEN
          validate_ring_access (validation_ring, cycle_pde^.cycle_description^.system_file_label.static_label,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF fsc$goi_file_label IN object_info_requests THEN
          IF cycle_pde^.cycle_description^.attached_file THEN
            IF NOT cycle_pde^.cycle_description^.system_file_label.file_previously_opened AND
                  (cycle_pde^.cycle_description^.static_setfa_entries <> NIL) THEN
              p_object^.file_label := cycle_pde^.cycle_description^.system_file_label.static_label;
              fmp$merge_setfa_entries (cycle_pde^.cycle_description^.static_setfa_entries, p_object,
                    p_object_information, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

            ELSEIF cycle_pde^.cycle_description^.system_file_label.static_label <> NIL THEN
              label_size := #SIZE (cycle_pde^.cycle_description^.system_file_label.static_label^);
              NEXT p_object^.file_label: [[REP label_size OF cell]] IN p_object_information;
              IF p_object^.file_label = NIL THEN
                osp$set_status_condition (pfe$info_full, status);
                RETURN;
              IFEND;
              i#move (cycle_pde^.cycle_description^.system_file_label.static_label, p_object^.file_label,
                    label_size);

            ELSE
              label_size := #SIZE (fmt$static_label_header);
              NEXT p_object^.file_label: [[REP label_size OF cell]] IN p_object_information;
              IF p_object^.file_label = NIL THEN
                osp$set_status_condition (pfe$info_full, status);
                RETURN;
              IFEND;

              i#move (^fmv$static_label_header, p_object^.file_label, label_size);
              IF NOT cycle_pde^.cycle_description^.system_file_label.file_previously_opened THEN
                RESET p_object^.file_label;
                NEXT header IN p_object^.file_label;
                header^.file_previously_opened := FALSE;
              IFEND;
            IFEND;

          ELSEIF cycle_pde^.cycle_description^.static_setfa_entries <> NIL THEN
            label_size := #SIZE (cycle_pde^.cycle_description^.static_setfa_entries^);
            NEXT p_object^.file_label: [[REP label_size OF cell]] IN p_object_information;
            IF p_object^.file_label = NIL THEN
              osp$set_status_condition (pfe$info_full, status);
              RETURN;
            IFEND;
            i#move (cycle_pde^.cycle_description^.static_setfa_entries, p_object^.file_label, label_size);
          IFEND;
        IFEND; { file_label in object_info_requests }

        IF (fsc$goi_job_environment_info IN object_info_requests) AND
              (cycle_pde^.cycle_description^.attached_file OR (cycle_pde^.cycle_description^.
              dynamic_setfa_entries <> NIL)) THEN
          NEXT p_object^.job_environment_information IN p_object_information;
          IF p_object^.job_environment_information = NIL THEN
            osp$set_status_condition (pfe$info_full, status);
          ELSE
            IF cycle_pde^.cycle_description^.device_class = rmc$connected_file_device THEN
              PUSH path_handle_p;
              path_handle_p^.segment_offset := #OFFSET (cycle_pde);
              path_handle_p^.assignment_counter := cycle_pde^.entry_assignment_counter;
              path_handle_p^.open_position.specified := FALSE;
            ELSE
              path_handle_p := NIL;
            IFEND;
            fmp$setup_job_environment_info (cycle_pde^.cycle_description, path_handle_p,
                  p_object^.job_environment_information, p_object_information);
          IFEND;
        IFEND; { job_environment_info in object_info_requests }
      IFEND;
    IFEND; { cycle_description <> NIL }

  PROCEND get_$local_cycle_object_info;

?? TITLE := 'PROCEDURE get_$local_file_object_info', EJECT ??

  PROCEDURE get_$local_file_object_info
    (    cycle_reference: fst$cycle_reference;
         object_info_requests: fst$goi_object_info_requests;
         validation_ring: ost$valid_ring;
         password_validated: boolean;
         p_object: ^fst$goi_object;
     VAR pde: {i/o} ^fmt$path_description_entry;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      cycle_count: ost$non_negative_integers,
      cycle_index: ost$positive_integers,
      cycle_pde: ^fmt$path_description_entry,
      local_pde: ^fmt$path_description_entry,
      path: fst$path,
      path_size: fst$path_size;

    status.normal := TRUE;

    p_object^ := initial_file_object;
    p_object^.file_name := pde^.path_node_name.value;

    IF fsc$goi_cycle_object_list IN object_info_requests THEN

{ Get information for all cycles.

      cycle_pde := pde^.highest_cycle;
      cycle_count := 0;
      WHILE cycle_pde <> NIL DO
        IF cycle_pde^.cycle_description <> NIL THEN
          cycle_count := cycle_count + 1;
        IFEND;
        cycle_pde := cycle_pde^.next_lower_cycle;
      WHILEND;

      IF cycle_count > 0 THEN
        NEXT p_object^.cycle_object_list: [1 .. cycle_count] IN p_object_information;
        IF p_object^.cycle_object_list = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
        ELSE
          cycle_pde := pde^.highest_cycle;
          cycle_index := 1;
          WHILE (cycle_pde <> NIL) AND (cycle_index <= cycle_count) DO
            IF cycle_pde^.cycle_description <> NIL THEN
              get_$local_cycle_object_info (cycle_pde, object_info_requests, validation_ring,
                    password_validated, ^p_object^.cycle_object_list^ [cycle_index], p_object_information,
                    status);
              cycle_index := cycle_index + 1;
            IFEND;
            cycle_pde := cycle_pde^.next_lower_cycle;
          WHILEND;
        IFEND;
      IFEND;

    ELSEIF pfv$cycle_info_requests * object_info_requests <> $fst$goi_object_info_requests [] THEN

{ Get information for the highest cycle.

      cycle_pde := pde^.highest_cycle;
      CASE cycle_reference.specification OF
      = fsc$cycle_omitted, fsc$high_cycle =
        get_high_cycle (cycle_pde);
      = fsc$low_cycle =
        get_low_cycle (cycle_pde);
      = fsc$cycle_number =
        locate_cycle (cycle_reference.cycle_number, cycle_pde);
      = fsc$next_cycle =
        get_high_cycle (cycle_pde);
        IF (cycle_pde = NIL) OR cycle_pde^.cycle_description^.attached_file THEN
          recreate_path_string (pde, path, path_size, status);
          IF status.normal THEN
            bap$set_file_reference_abnormal (path (1, path_size), ame$file_not_known,
                  'PFP$GET_OBJECT_INFORMATION', '', status);
          IFEND;
          RETURN;
        IFEND;
      ELSE
      CASEND;

      IF (cycle_pde <> NIL) AND (cycle_pde^.cycle_description <> NIL) THEN
        IF cycle_pde^.cycle_description^.attached_file THEN
          NEXT p_object^.cycle_object_list: [1 .. 1] IN p_object_information;
          IF p_object^.cycle_object_list = NIL THEN
            osp$set_status_condition (pfe$info_full, status);
          ELSE
            get_$local_cycle_object_info (cycle_pde, object_info_requests, validation_ring,
                  password_validated, ^p_object^.cycle_object_list^ [1], p_object_information, status);
          IFEND;
        ELSEIF (object_info_requests * $fst$goi_object_info_requests [fsc$goi_file_label,
              fsc$goi_job_environment_info]) <> $fst$goi_object_info_requests [] THEN

{ A SETFA or REQUEST command is outstanding for an unregistered file so the previously created file_object is
{ irrelevant and should be replaced with a cycle object.

          get_$local_cycle_object_info (cycle_pde, object_info_requests, validation_ring,
                password_validated, p_object, p_object_information, status);
        ELSE
          recreate_path_string (pde, path, path_size, status);
          IF status.normal THEN
            bap$set_file_reference_abnormal (path (1, path_size), ame$file_not_known,
                  'PFP$GET_OBJECT_INFORMATION', '', status);
          IFEND;
          RETURN;
        IFEND;
        pde := cycle_pde;
      ELSE
        recreate_path_string (pde, path, path_size, status);
        IF status.normal THEN
          bap$set_file_reference_abnormal (path (1, path_size), ame$file_not_known,
                'PFP$GET_OBJECT_INFORMATION', '', status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND get_$local_file_object_info;

?? TITLE := 'PROCEDURE [INLINE] increment_assignment_counter', EJECT ??

  PROCEDURE [INLINE] increment_assignment_counter;

    IF fmv$pde_assignment_counter >= UPPERVALUE (fmt$pde_assignment_counter) THEN
      fmv$pde_assignment_counter := LOWERVALUE (fmt$pde_assignment_counter) + 1;
    ELSE
      fmv$pde_assignment_counter := fmv$pde_assignment_counter + 1;
    IFEND;

  PROCEND increment_assignment_counter;

?? TITLE := 'PROCEDURE [INLINE] insert_cycle_object', EJECT ??

  PROCEDURE [INLINE] insert_cycle_object
    (    cycle_object: ^fmt$path_description_entry);

{ PURPOSE: This procedure takes a cycle_object and inserts it in the
{          proper place in a linked list of cycle_objects.  The named
{          object is updated to reflect the addition.

    VAR
      next_lower_cycle: ^fmt$path_description_entry,
      next_higher_cycle: ^fmt$path_description_entry;

    IF cycle_object^.parental_path_entry^.highest_cycle <> NIL THEN
      IF cycle_object^.parental_path_entry^.highest_cycle^.cycle_number < cycle_object^.cycle_number THEN

{ Make cycle_object the new highest_cycle.

        cycle_object^.next_lower_cycle := cycle_object^.parental_path_entry^.highest_cycle;
        cycle_object^.parental_path_entry^.highest_cycle^.next_higher_cycle := cycle_object;
        cycle_object^.parental_path_entry^.highest_cycle := cycle_object;
        cycle_object^.next_higher_cycle := NIL;
      ELSE
        next_lower_cycle := cycle_object^.parental_path_entry^.highest_cycle^.next_lower_cycle;
        next_higher_cycle := cycle_object^.parental_path_entry^.highest_cycle;

{ Find insertion point.

        WHILE (next_lower_cycle <> NIL) AND (next_lower_cycle^.cycle_number > cycle_object^.cycle_number) DO
          next_higher_cycle := next_lower_cycle;
          next_lower_cycle := next_lower_cycle^.next_lower_cycle;
        WHILEND;

{ Change cycle_object to point to next higher and lower cycles.

        cycle_object^.next_lower_cycle := next_lower_cycle;
        cycle_object^.next_higher_cycle := next_higher_cycle;

{ Change higher and lower to point to inserted cycle_object.

        IF next_lower_cycle <> NIL THEN
          next_lower_cycle^.next_higher_cycle := cycle_object;
        IFEND;
        IF next_higher_cycle <> NIL THEN
          next_higher_cycle^.next_lower_cycle := cycle_object;
        IFEND;
      IFEND;
    ELSE { no existing cycles }
      cycle_object^.parental_path_entry^.highest_cycle := cycle_object;
      cycle_object^.next_lower_cycle := NIL;
      cycle_object^.next_higher_cycle := NIL;
    IFEND;

  PROCEND insert_cycle_object;

?? TITLE := 'PROCEDURE get_high_cycle', EJECT ??

  PROCEDURE [INLINE] get_high_cycle
    (VAR cycle_pde: ^fmt$path_description_entry);

    WHILE (cycle_pde <> NIL) AND (cycle_pde^.cycle_description = NIL) DO
      cycle_pde := cycle_pde^.next_lower_cycle;
    WHILEND;

  PROCEND get_high_cycle;

?? TITLE := 'PROCEDURE get_low_cycle', EJECT ??

  PROCEDURE [INLINE] get_low_cycle
    (VAR cycle_pde: ^fmt$path_description_entry);

    IF cycle_pde <> NIL THEN

{ move to bottom of linked list of cycles

      WHILE cycle_pde^.next_lower_cycle <> NIL DO
        cycle_pde := cycle_pde^.next_lower_cycle;
      WHILEND;

      WHILE (cycle_pde <> NIL) AND (cycle_pde^.cycle_description = NIL) DO
        cycle_pde := cycle_pde^.next_higher_cycle;
      WHILEND;
    IFEND;

  PROCEND get_low_cycle;

?? TITLE := 'PROCEDURE get_path_cycle', EJECT ??

  PROCEDURE get_path_cycle
    (    resolve_to_catalog: boolean;
         resolve_pf_in_pt: boolean;
         local_path: boolean;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR cycle_pde: {i/o} ^fmt$path_description_entry;
     VAR status: ost$status);

*copy fsh$resolve_path

    VAR
      p_path: ^pft$path,
      pf_path_resolution: fst$path_resolution;

    status.normal := TRUE;

    IF evaluated_file_reference.number_of_path_elements = 1 THEN
      IF local_path THEN
        IF evaluated_file_reference.cycle_reference.specification = fsc$cycle_omitted THEN
          evaluated_file_reference.path_resolution := fsc$catalog_path;
        ELSE
          osp$set_status_abnormal (amc$access_method_id, fse$catalogs_do_not_have_cycles, fsc$local, status);
        IFEND;
      ELSE { permanent_file }
        osp$set_status_abnormal (amc$access_method_id, pfe$path_too_short,
              fsp$path_element (^evaluated_file_reference, 1) ^, status);
        osp$append_status_integer (osc$status_parameter_delimiter, 2, 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'path', status);
      IFEND;
      cycle_pde := NIL;
      RETURN;
    IFEND;

    IF local_path OR ((NOT resolve_to_catalog) AND resolve_pf_in_pt) THEN
      IF cycle_pde = NIL THEN { no high cycle to start from }
        IF local_path THEN
          IF evaluated_file_reference.cycle_reference.specification <> fsc$cycle_number THEN
            evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
            evaluated_file_reference.cycle_reference.cycle_number := 1;
          IFEND;
        IFEND;
      ELSE
        resolve_in_path_table (local_path, evaluated_file_reference, cycle_pde, status);
      IFEND;

    ELSE { permanent_file }
      IF resolve_to_catalog THEN
        PUSH p_path: [1 .. evaluated_file_reference.number_of_path_elements];
        pfp$convert_fs_to_pft$path (evaluated_file_reference, p_path^);
        pfp$resolve_path (p_path^, evaluated_file_reference.cycle_reference, pf_path_resolution, status);
        IF status.normal THEN
          evaluated_file_reference.path_resolution := pf_path_resolution;
        IFEND;
      IFEND; {resolve to catalog

{     set cycle_pde back to NIL so that a new cycle_object will
{     be created if bac$record_path IN process_pt_work_list

      cycle_pde := NIL;
    IFEND; {local file or resolve_pf_in_pt}

  PROCEND get_path_cycle;

?? TITLE := 'PROCEDURE initialize_cycle_object', EJECT ??

  PROCEDURE [INLINE] initialize_cycle_object
    (    p_object: ^fst$goi_object);

    p_object^ := initial_cycle_object;
    p_object^.cycle_global_file_name := pfv$null_unique_name;

  PROCEND initialize_cycle_object;

?? TITLE := 'PROCEDURE locate_cycle', EJECT ??

  PROCEDURE [INLINE] locate_cycle
    (    cycle_number: fst$cycle_number;
     VAR cycle_pde: ^fmt$path_description_entry);

    WHILE (cycle_pde <> NIL) AND (cycle_pde^.cycle_number <> cycle_number) DO
      cycle_pde := cycle_pde^.next_lower_cycle;
    WHILEND;

  PROCEND locate_cycle;

?? TITLE := 'PROCEDURE locate_entry_via_path', EJECT ??

  PROCEDURE locate_entry_via_path
    (    process_pt_work_list: bat$process_pt_work_list;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR found_or_created: boolean;
     VAR path_description_entry: ^fmt$path_description_entry;
     VAR status: ost$status);

{ PURPOSE: This procedure will follow a path, creating the path nodes as
{          it goes if creation is specified.

    VAR
      element_index: fst$path_index,
      element_offset: fst$path_index,
      element_size: 1 .. fsc$max_path_element_size,
      local_cycle: ^fmt$path_description_entry,
      local_file_name: amt$local_file_name,
      local_path: boolean,
      local_pde_is_alias: boolean,
      next_pde: ^fmt$path_description_entry,
      path_node_name: fst$path_element,
      potential_alias: amt$local_file_name,
      resolve_path: boolean,
      starting_element: fst$path_index;

    status.normal := TRUE;

    path_description_entry := NIL;
    local_cycle := NIL;
    found_or_created := FALSE;

    resolve_path := bac$resolve_path IN process_pt_work_list;

{ Check for a valid evaluated_file_reference.  Either a path_handle must be present OR the number of path
{ elements must be nonzero.

    IF evaluated_file_reference.path_handle_info.path_handle_present THEN
      fmp$locate_pde_via_path_handle (evaluated_file_reference.path_handle_info.path_handle,
            path_description_entry, status);
      IF NOT status.normal THEN

{ Reinitialize the path_handle_info. Set path_handle_present := FALSE & set path_handle to defaults.

        evaluated_file_reference.path_handle_info := fsv$evaluated_file_reference.path_handle_info;
        IF (status.condition = fme$obsolete_path_handle) AND
              (evaluated_file_reference.number_of_path_elements > 0) THEN

{ Attempt to reference the path via the path_structure.

          status.normal := TRUE;
        ELSE
          RETURN;
        IFEND;
      ELSE {status.normal = TRUE

{ Cross validate the path_handle and path_structure.
{ Either: 1) The path depths must equal. OR
{         2) The path depth of structure must be 0. OR
{         3) The path structure must an alias of the file the path_handle represents.

        IF (path_description_entry^.path_depth <> evaluated_file_reference.number_of_path_elements) THEN
          IF (path_description_entry^.entry_type = fmc$file_cycle_object) AND
                (path_description_entry^.first_cycle_alias_entry <> NIL) AND
                (evaluated_file_reference.number_of_path_elements = 2) THEN
            IF fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local THEN
              potential_alias := fsp$path_element (^evaluated_file_reference, 2) ^;
              next_pde := path_description_entry^.first_cycle_alias_entry;
              WHILE (next_pde <> NIL) AND (evaluated_file_reference.number_of_path_elements = 2) DO
                IF next_pde^.path_node_name.value = potential_alias THEN
                  evaluated_file_reference.number_of_path_elements := 0;
                ELSE
                  next_pde := next_pde^.next_cycle_alias_entry;
                IFEND;
              WHILEND;
            IFEND;
          IFEND;
          IF evaluated_file_reference.number_of_path_elements = 0 THEN
            recreate_path_elements (path_description_entry, evaluated_file_reference);
          ELSE
            osp$set_status_abnormal (amc$access_method_id, fme$system_error,
                  ' - mismatched evaluated_file_reference and path_handle', status);
            RETURN;
          IFEND;
        IFEND; {path_depth <> number_of_path_elements.
        found_or_created := TRUE;
        IF path_description_entry^.entry_type = fmc$file_cycle_object THEN
          evaluated_file_reference.path_resolution := fsc$cycle_path;
          local_path := (fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local);
          RETURN;
        IFEND;
      IFEND;
    ELSEIF evaluated_file_reference.number_of_path_elements <= 0 THEN
      osp$set_status_abnormal (amc$access_method_id, fme$system_error,
            ' - uninitialized evaluated_file_reference ', status);
      RETURN;
    IFEND;

    local_path := (fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local);

{ Do local file validation.

    IF local_path THEN
      IF evaluated_file_reference.number_of_path_elements = 2 THEN
        IF fsp$path_element (^evaluated_file_reference, 2) ^ = clc$null_file THEN
          IF (path_description_entry = NIL) OR (path_description_entry^.entry_type <> fmc$file_cycle_object)
                THEN
            resolve_path := TRUE;
          IFEND;
        IFEND;
      ELSEIF evaluated_file_reference.number_of_path_elements > 2 THEN
        osp$set_status_abnormal (amc$access_method_id, fse$local_subcatalog_illegal,
              fsp$path_element (^evaluated_file_reference, 2) ^, status);
        evaluated_file_reference.path_resolution := fsc$path_resolution_error;
        RETURN;
      IFEND;
    IFEND;

{ Find or create the path elements.

    IF path_description_entry = NIL THEN
      IF local_path THEN
        next_pde := fmv$local_pde;
        element_offset := fmc$local_offset;
        starting_element := 2;
      ELSE
        next_pde := NIL;
        element_offset := 1;
        starting_element := 1;
      IFEND;

      FOR element_index := starting_element TO evaluated_file_reference.number_of_path_elements DO
        element_size := $INTEGER (evaluated_file_reference.path_structure (element_offset));
        path_node_name.value := evaluated_file_reference.path_structure (element_offset + 1, element_size);
        path_node_name.size := element_size;

        locate_named_object (path_node_name, {parent=} next_pde, bac$record_path IN process_pt_work_list,
              found_or_created, next_pde);
        IF NOT found_or_created THEN
          evaluated_file_reference.path_resolution := fsc$path_resolution_error;
          RETURN;
        IFEND;

        element_offset := element_offset + element_size + 1;
      FOREND;

      path_description_entry := next_pde;
      evaluated_file_reference.path_handle_info.path_handle.segment_offset :=
            #OFFSET (path_description_entry);
      evaluated_file_reference.path_handle_info.path_handle.assignment_counter :=
            path_description_entry^.entry_assignment_counter;
      evaluated_file_reference.path_handle_info.path_handle_present := TRUE;

{ Update statistics.

      IF path_description_entry^.path_depth > fmv$max_path_depth THEN
        fmv$max_path_depth := path_description_entry^.path_depth
      IFEND;
      IF path_description_entry^.path_depth <= fmc$statistics_max_path_depth THEN
        fmv$path_depth_entries [path_description_entry^.path_depth] :=
              fmv$path_depth_entries [path_description_entry^.path_depth] + 1;
      ELSE
        fmv$path_depth_entries [fmc$statistics_max_path_depth] :=
              fmv$path_depth_entries [fmc$statistics_max_path_depth] + 1;
      IFEND;

    IFEND; { path_description_entry = NIL }

{ Resolve.

    local_pde_is_alias := pde_is_alias (path_description_entry);
    IF local_pde_is_alias THEN
      IF NOT (bac$leave_aliases_unresolved IN process_pt_work_list) THEN
        local_cycle := path_description_entry^.highest_cycle;
        recreate_path_elements (local_cycle, evaluated_file_reference);
      ELSE
        evaluated_file_reference.cycle_reference.specification := fsc$cycle_omitted;
      IFEND;
    ELSEIF resolve_path AND (evaluated_file_reference.cycle_reference.specification <> fsc$cycle_number) THEN
      local_cycle := path_description_entry^.highest_cycle;
      get_high_cycle (local_cycle); {find the highest cycle description.
      IF local_path OR (bac$record_path IN process_pt_work_list) OR (local_cycle <> NIL) THEN

{ Do not resolve a permanent file unless either a cycle_description exists OR record_path was specified.

        get_path_cycle (bac$resolve_to_catalog IN process_pt_work_list,
              bac$resolve_pf_in_pt IN process_pt_work_list, local_path, evaluated_file_reference, local_cycle,
              status);
        IF NOT status.normal THEN
          evaluated_file_reference.path_resolution := fsc$path_resolution_error;
          RETURN;
        IFEND;
      ELSE

{ Note: path_resolution is already set to fsc$unresolved_path.

        RETURN;
      IFEND;
    IFEND;

{ Update VAR parameters - path_handle, path_resolution, path_description_entry, found & created.

    IF evaluated_file_reference.cycle_reference.specification = fsc$cycle_number THEN
      IF local_cycle = NIL THEN

{ Look for local_cycle to match cycle_number.

        local_cycle := path_description_entry^.highest_cycle;
        locate_cycle (evaluated_file_reference.cycle_reference.cycle_number, local_cycle);
      IFEND;
      IF local_cycle <> NIL THEN
        found_or_created := TRUE;
        evaluated_file_reference.path_resolution := fsc$cycle_path;
      ELSEIF bac$record_path IN process_pt_work_list THEN
        create_cycle_object (evaluated_file_reference.cycle_reference.cycle_number, path_description_entry,
              local_cycle);
        found_or_created := TRUE;
        evaluated_file_reference.path_resolution := fsc$new_cycle_path;
      ELSE
        found_or_created := FALSE;

{ Note: path_resolution is already set to fsc$unresolved_path

        RETURN;
      IFEND;
      IF local_cycle <> NIL THEN
        path_description_entry := local_cycle;
        evaluated_file_reference.path_handle_info.path_handle.segment_offset :=
              #OFFSET (path_description_entry);
        evaluated_file_reference.path_handle_info.path_handle.assignment_counter :=
              path_description_entry^.entry_assignment_counter;
        evaluated_file_reference.path_handle_info.path_handle_present := TRUE;
      IFEND;
    IFEND;

  PROCEND locate_entry_via_path;

?? TITLE := 'PROCEDURE [INLINE] locate_named_object', EJECT ??

  PROCEDURE [INLINE] locate_named_object
    (    path_node_name: fst$path_element;
         parental_path_entry: ^fmt$path_description_entry;
         create: boolean;
     VAR found_or_created: boolean;
     VAR pde: ^fmt$path_description_entry);

    VAR
      randomized_node_name: ost$randomized_name,
      parental_tree_entry: ^fmt$path_description_entry,
      node: ^fmt$path_description_entry;

{ Start search from offset of node passed into procedure.

    node := fmv$path_table_entry_point;
    parental_tree_entry := NIL;

    osp$randomize_name (path_node_name.value, randomized_node_name);

  /locate_object/
    BEGIN

      WHILE node <> NIL DO
        IF (randomized_node_name = node^.randomized_node_name) AND (path_node_name = node^.path_node_name) AND
              (parental_path_entry = node^.parental_path_entry) THEN
          pde := node;
          found_or_created := TRUE;
          EXIT /locate_object/;
        IFEND;
        IF randomized_node_name < node^.randomized_node_name THEN

{ Go left

          parental_tree_entry := node;
          node := node^.left_subtree;
        ELSE { >= } { includes collisions }

{ Go right

          parental_tree_entry := node;
          node := node^.right_subtree;
        IFEND;
      WHILEND;

{ Only gets to here if a named_object was not found.

      IF create THEN
        create_named_object (parental_path_entry, parental_tree_entry, path_node_name, randomized_node_name,
              pde);
        found_or_created := TRUE;
      ELSE

{ A named_object has not been found or created so return a pointer
{ to the last named_object to which the named_object would be
{ attached if it had been created.  This allows changes to attach
{ an already existing pde to this node.

        pde := parental_tree_entry;
        found_or_created := FALSE;
      IFEND;

    END /locate_object/;

  PROCEND locate_named_object;

?? TITLE := 'FUNCTION [INLINE] pde_is_alias', EJECT ??

  FUNCTION [INLINE] pde_is_alias
    (    pde: ^fmt$path_description_entry): boolean;

    pde_is_alias := (pde^.entry_type = fmc$named_object) AND (pde^.highest_cycle <> NIL) AND
          (pde^.highest_cycle^.parental_path_entry <> pde);

  FUNCEND pde_is_alias;

?? TITLE := 'FUNCTION [INLINE] pdes_first_element_is_$local', EJECT ??

  FUNCTION [INLINE] pdes_first_element_is_$local
    (    pde: ^fmt$path_description_entry): boolean;

    VAR
      temp_pde: ^fmt$path_description_entry;

    temp_pde := pde;
    WHILE temp_pde^.parental_path_entry <> NIL DO
      temp_pde := temp_pde^.parental_path_entry;
    WHILEND;
    pdes_first_element_is_$local := (temp_pde^.path_node_name = fmv$local_node_name);

  FUNCEND pdes_first_element_is_$local;

?? TITLE := 'PROCEDURE [INLINE] recreate_path_elements', EJECT ??

  PROCEDURE [INLINE] recreate_path_elements
    (    starting_pde: ^fmt$path_description_entry;
     VAR evaluated_file_reference: fst$evaluated_file_reference);

{ PURPOSE: Given a path_description_entry, recreate a path to that node.
{          An array of path elements and a cycle_reference is returned.

    VAR
      cycle_string: ost$string,
      element_offset: fst$path_index,
      pde: ^fmt$path_description_entry;

    pde := starting_pde;

{ Fill in cycle number if file cycle object.
{ Note: path depth is the same in last element and it's cycle objects

    evaluated_file_reference.number_of_path_elements := pde^.path_depth;

{ Fill in cycle number if file cycle object.

    IF pde^.entry_type = fmc$file_cycle_object THEN
      evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
      evaluated_file_reference.cycle_reference.cycle_number := pde^.cycle_number;

{ Move up the tree.

      pde := pde^.parental_path_entry;
    IFEND;

{ calculate the size of the path elements part of path

    evaluated_file_reference.path_structure_size := pde^.cumulative_parental_path_size + 1 +
          pde^.path_node_name.size;

{ Fill in each path element name from last to first.

    REPEAT
      element_offset := pde^.cumulative_parental_path_size + 1;

{ fill in path_structure

      evaluated_file_reference.path_structure (element_offset) := $CHAR (pde^.path_node_name.size);
      evaluated_file_reference.path_structure (element_offset + 1, pde^.path_node_name.size) :=
            pde^.path_node_name.value;

{ move pde to parental path entry

      pde := pde^.parental_path_entry;
    UNTIL pde = NIL;

  PROCEND recreate_path_elements;

?? TITLE := 'PROCEDURE [INLINE] recreate_path_string', EJECT ??

  PROCEDURE [INLINE] recreate_path_string
    (    starting_pde: ^fmt$path_description_entry;
     VAR path: fst$path;
     VAR path_size: fst$path_size;
     VAR status: ost$status);

{ PURPOSE: Given a path_description_entry, recreate a path to that node.
{          A string containing the path is returned.

    VAR
      cycle_string: ost$string,
      element_offset: fst$path_index,
      pde: ^fmt$path_description_entry;

    status.normal := TRUE;
    pde := starting_pde;
    path := osc$null_name;
    path_size := 0;

{ Note: path depth is the same in last element and it's cycle objects

{ Fill in cycle number if file cycle object.

    IF pde^.entry_type = fmc$file_cycle_object THEN
      clp$convert_integer_to_string (pde^.cycle_number, 10, FALSE, cycle_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      path_size := pde^.cumulative_parental_path_size + cycle_string.size + 1;
      IF path_size > fsc$max_path_size THEN
        path_size := 0;
        osp$set_status_abnormal (amc$access_method_id, cle$file_reference_too_long, 'recreate_path_string',
              status);
        RETURN;
      IFEND;
      path (pde^.cumulative_parental_path_size + 1, 1) := '.';
      path (pde^.cumulative_parental_path_size + 2, cycle_string.size) := cycle_string.value;

{ Move up the tree.

      pde := pde^.parental_path_entry;
    ELSE
      path_size := pde^.cumulative_parental_path_size + pde^.path_node_name.size + 1;
    IFEND;

{ Fill in each path element name from last to first.

    REPEAT
      element_offset := pde^.cumulative_parental_path_size + 1;

{ fill in element delimiter

      path (element_offset, 1) := '.';

{ fill in element name

      path (element_offset + 1, pde^.path_node_name.size) := pde^.path_node_name.value;

{ move pde to parental path entry

      pde := pde^.parental_path_entry;
    UNTIL pde = NIL;
    path (1, 1) := ':';

  PROCEND recreate_path_string;

?? TITLE := 'PROCEDURE [INLINE] release_object', EJECT ??

  PROCEDURE release_object
    (VAR pde: ^fmt$path_description_entry);

{ PURPOSE: This procedure frees any object entry.

    VAR
      entry_assignment_pointer: ^string (1);

    IF pde^.entry_type = fmc$named_object THEN
      fmv$named_objects_deleted := fmv$named_objects_deleted + 1;
    ELSE { cycle_object }
      fmv$cycle_objects_deleted := fmv$cycle_objects_deleted + 1;
    IFEND;
    IF pde^.parental_path_entry <> NIL THEN
      pde^.parental_path_entry^.active_path_participation_count :=
            pde^.parental_path_entry^.active_path_participation_count - 1;
    IFEND;
    pde^.pdu_pointer^.current_count := pde^.pdu_pointer^.current_count - 1;
    pde^.entry_assignment^ := fmc$entry_free;
    entry_assignment_pointer := pde^.entry_assignment;
    pde^ := fmv$default_pde;
    pde^.entry_assignment := entry_assignment_pointer;
    pde := NIL;

  PROCEND release_object;

?? TITLE := 'PROCEDURE resolve_in_path_table', EJECT ??

  PROCEDURE resolve_in_path_table
    (    local_path: boolean;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR cycle_pde: {i/o} ^fmt$path_description_entry;
     VAR status: ost$status);

    VAR
      path: fst$path,
      path_size: fst$path_size;

    CASE evaluated_file_reference.cycle_reference.specification OF
    = fsc$cycle_omitted, fsc$high_cycle =
      get_high_cycle (cycle_pde);
      IF (cycle_pde <> NIL) THEN
        evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
        evaluated_file_reference.cycle_reference.cycle_number := cycle_pde^.cycle_number;
      ELSE
        IF (evaluated_file_reference.cycle_reference.specification = fsc$high_cycle) THEN

{ this should be changed to put out and error is create is true

          evaluated_file_reference.cycle_reference.specification := fsc$cycle_omitted;
        ELSEIF local_path THEN
          evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
          evaluated_file_reference.cycle_reference.cycle_number := 1;
        IFEND;
      IFEND;

    = fsc$low_cycle =
      get_low_cycle (cycle_pde);
      IF (cycle_pde <> NIL) THEN
        evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
        evaluated_file_reference.cycle_reference.cycle_number := cycle_pde^.cycle_number;
      ELSE

{ this should be changed to put out and error is create is true

        evaluated_file_reference.cycle_reference.specification := fsc$cycle_omitted;
      IFEND;

    = fsc$next_cycle =
      get_high_cycle (cycle_pde);
      IF cycle_pde <> NIL THEN
        IF cycle_pde^.cycle_number + 1 < fsc$maximum_cycle_number THEN
          evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
          evaluated_file_reference.cycle_reference.cycle_number := cycle_pde^.cycle_number + 1;

{set cycle_pde back to NIL so that a new cycle_object will
{be created if bac$record_path IN process_pt_work_list

          cycle_pde := NIL;
        ELSE

{set cycle_pde back to parent named object so cycle not in path

          cycle_pde := cycle_pde^.parental_path_entry;
          recreate_path_string (cycle_pde, path, path_size, status);
          osp$set_status_abnormal (amc$access_method_id, pfe$cycle_overflow, path (1, path_size), status);
        IFEND;
      ELSE
        evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
        evaluated_file_reference.cycle_reference.cycle_number := 1;
      IFEND;

    = fsc$cycle_number =
      locate_cycle (evaluated_file_reference.cycle_reference.cycle_number, cycle_pde);

    ELSE
      osp$set_status_condition (pfe$bad_cycle_option, status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            $INTEGER (evaluated_file_reference.cycle_reference.specification), 10, FALSE, status);
    CASEND;

  PROCEND resolve_in_path_table;

?? TITLE := 'sort_directory', EJECT ??

  PROCEDURE sort_directory
    (    directory: pft$p_directory_array);

    VAR
      gap: integer,
      start: integer,
      current: integer,
      swap: pft$directory_array_entry;

{ Use shell sort technique.

    gap := UPPERBOUND (directory^);
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := 1 TO UPPERBOUND (directory^) - gap DO
        current := start;
        WHILE (current > 0) AND (directory^ [current].name > directory^ [current + gap].name) DO
          swap := directory^ [current];
          directory^ [current] := directory^ [current + gap];
          directory^ [current + gap] := swap;
          current := current - gap;
        WHILEND;
      FOREND;
    WHILEND;

  PROCEND sort_directory;

?? TITLE := 'PROCEDURE validate_default_ring_access', EJECT ??

  PROCEDURE [INLINE] validate_default_ring_access
    (    validation_ring: ost$valid_ring;
     VAR status: ost$status);

    IF (validation_ring > fmv$system_file_attributes.static_label.ring_attributes.r3) AND
          (avp$ring_min () > fmv$system_file_attributes.static_label.ring_attributes.r3) THEN
      osp$set_status_condition (ame$ring_validation_error, status);
    IFEND;

  PROCEND validate_default_ring_access;

?? TITLE := 'PROCEDURE validate_ring_access', EJECT ??

  PROCEDURE [INLINE] validate_ring_access
    (    validation_ring: ost$valid_ring;
         static_label: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      header: ^fmt$static_label_header,
      local_static_label: ^SEQ ( * );

    status.normal := TRUE;
    local_static_label := static_label;

    IF local_static_label <> NIL THEN
      RESET local_static_label;
      NEXT header IN local_static_label;
      IF (header <> NIL) AND (header^.file_previously_opened) AND
            (validation_ring > header^.ring_attributes.r3) AND (avp$ring_min () >
            header^.ring_attributes.r3) THEN
        osp$set_status_condition (ame$ring_validation_error, status);
      IFEND;
    ELSE
      validate_default_ring_access (validation_ring, status);
    IFEND;

  PROCEND validate_ring_access;

?? OLDTITLE ??

MODEND fmm$path_table_manager;
*DECK DECK=FMM$PF_UTILITY_LABEL EXPAND=TRUE
?? RIGHT := 110 ??
MODULE fmm$pf_utility_label;
{
{   This module contains those interfaces that build and restore the label as
{ passed to the permanent file utilities and the permanent file transfer
{ facility.  This is different than the label passed to the permanent
{ file manager, as it contains checksums to validate the data.
{   The label is an adaptable sequence and the format for the sequence is:
{       checksum of label
{       fmt$static_label_header
{       if static_label_size > 0 then
{         fmt$static_label_item
{       if job_label_size > 0 then
{         bat$route_descriptor
{
?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc ame$ring_validation_errors
*copyc fmc$current_revision_level
*copyc fmc$unique_label_id
*copyc fme$file_management_errors
*copyc fmk$keypoints
*copyc fmt$basic_file_label
*copyc fmt$file_attribute_keys
*copyc fmt$label_headers
*copyc osd$virtual_address
*copyc ose$heap_full_exceptions
?? POP ??
*copyc avp$system_administrator
*copyc bap$validate_compatibility
*copyc clp$validate_name
*copyc fmi$put_job_routing_label
*copyc fmi$put_label_in_lnt
*copyc fmp$catalog_system_file_label
*copyc fmp$expand_v1_label
*copyc fmp$get_cycle_description
*copyc fmp$get_path_string
*copyc fmp$put_label_attributes
*copyc fmp$unlock_path_table
*copyc fmp$verify_attribute_limits
*copyc fmv$system_file_attributes
*copyc fmv$static_label_header
*copyc i#move
*copyc jmp$system_job
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osv$initial_exception_context
*copyc osv$job_pageable_heap
*copyc pfp$compute_checksum

?? TITLE := 'fmp$fetch_system_label', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$fetch_system_label (local_file_name:
    amt$local_file_name;
    VAR label: SEQ ( * );
    VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      i: integer,
      job_label: ^SEQ ( * ),
      job_label_size: jmt$system_label_info_length,
      p_checksum: ^integer,
      p_label: ^SEQ ( * ),
      start_of_label: ^cell,
      static_label: ^SEQ ( * ),
      static_label_header: ^fmt$static_label_header,
      static_label_size: integer,
      total_label_size: 0 .. 7fffffff(16);

    status.normal := TRUE;

    fmp$get_cycle_description (local_file_name, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /begin_end/
    BEGIN
      total_label_size := 0;
      get_label_size (cycle_description, job_label_size, total_label_size,
            status);
      IF NOT status.normal THEN
        EXIT /begin_end/;
      IFEND;

      p_label := ^label;
      RESET p_label;
      NEXT p_checksum IN p_label;
      IF cycle_description^.system_file_label.static_label <> NIL THEN
        static_label_size := total_label_size - #SIZE (integer) -
              job_label_size;
        NEXT static_label: [[REP static_label_size OF cell]] IN p_label;
        IF static_label = NIL THEN
          osp$set_status_abnormal (amc$access_method_id, fme$system_error,
                ' - the label container passed to fmp$fetch_system_label is too small to hold the file label',
                status);
          EXIT /begin_end/;
        IFEND;
        static_label^ := cycle_description^.system_file_label.
              static_label^;
      ELSE
        NEXT static_label_header IN p_label;
        static_label_header^ := fmv$static_label_header;
        static_label_header^.job_routing_label_size := job_label_size;
        static_label_header^.file_previously_opened := cycle_description^.
              system_file_label.file_previously_opened;
      IFEND;

      IF job_label_size > 0 THEN
        NEXT job_label: [[REP job_label_size OF cell]] IN p_label;
        job_label^ := cycle_description^.job_routing_label^;
      IFEND;

      RESET p_label;
      NEXT p_checksum IN p_label;
      NEXT start_of_label IN p_label;
      pfp$compute_checksum (start_of_label, total_label_size - #SIZE (integer),
            p_checksum^);

    END /begin_end/;
    fmp$unlock_path_table;

  PROCEND fmp$fetch_system_label;

?? TITLE := 'fmp$fetch_system_label_size', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$fetch_system_label_size (local_file_name:
    amt$local_file_name;
    VAR label_size: 0 .. 7fffffff(16);
    VAR status: ost$status);

{ This procedure fetches the size of the label as given to the pf backup
{ utility and permanent file transfer facility.

    VAR
      cycle_description: ^fmt$cycle_description,
      job_label_size: jmt$system_label_info_length;

    status.normal := TRUE;

  /begin_end/
    BEGIN
      label_size := 0;

      fmp$get_cycle_description (local_file_name, cycle_description, status);
      IF NOT status.normal THEN
        EXIT /begin_end/;
      IFEND;

      IF cycle_description = NIL THEN
        osp$set_status_abnormal (amc$access_method_id, fme$no_preserved_attributes,
              ' file is not attached - fmp$fetch_system_label_size', status);
        EXIT /begin_end/;
      IFEND;
      get_label_size (cycle_description, job_label_size, label_size,
            status);
      fmp$unlock_path_table;
    END /begin_end/;

  PROCEND fmp$fetch_system_label_size;

?? TITLE := 'fmp$store_system_label', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$store_system_label
    (   local_file_name: amt$local_file_name;
        validation_ring: ost$valid_ring;
        label: SEQ ( * );
    VAR status: ost$status);

    CONST
      checksum_present = TRUE;

    VAR
      context: ^ost$ecp_exception_context,
      cycle_description: ^fmt$cycle_description,
      expanded_static_label: bat$static_label_attributes,
      file_path: fst$path,
      file_path_size: fst$path_size,
      file_returned: boolean,
      ignore_status: ost$status,
      job_label_header: fmt$job_label_header,
      job_label_size: jmt$system_label_info_length,
      p_file_label_header: ^fmt$static_label_header,
      p_job_label: ^SEQ ( * ),
      p_label: ^SEQ ( * ),
      p_stored_checksum: ^integer,
      static_label_header: ^fmt$static_label_header,
      valid_checksum: boolean,
      v1_header: fmt$static_bam_label_header,
      v1_file_previously_opened: boolean;

    status.normal := TRUE;
    context := NIL;

  /begin_end/
    BEGIN
      fmp$get_cycle_description (local_file_name, cycle_description, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF cycle_description = NIL THEN
        osp$set_status_abnormal (amc$access_method_id, fme$system_error,
              ' file is not attached in fmp$store_system_label', status);
        RETURN;
      IFEND;

      fmp$validate_system_label (label, validation_ring, valid_checksum, status);
      IF NOT status.normal THEN
        EXIT /begin_end/;
      IFEND;

      p_label := ^label;
      RESET p_label;
      IF valid_checksum THEN
        NEXT p_stored_checksum IN p_label;
        NEXT p_file_label_header IN p_label;
        job_label_size := p_file_label_header^.job_routing_label_size;
        IF p_file_label_header^.highest_attribute_present > 0 THEN
          IF p_file_label_header^.revision_level <> fmc$current_revision_level THEN
            bap$validate_compatibility (p_label, p_file_label_header, cycle_description^.path_handle,
                  checksum_present, status);
            IF NOT status.normal THEN
              EXIT /begin_end/;
            IFEND;
          IFEND;

          RESET p_label;
          NEXT p_stored_checksum IN p_label;
          fmi$put_label_in_lnt (checksum_present, p_file_label_header, p_label, cycle_description,
                status);
          IF NOT status.normal THEN
            EXIT /begin_end/;
          IFEND;

          fmp$verify_attribute_limits (cycle_description^. system_file_label.static_label, status);
          IF NOT status.normal THEN
            EXIT /begin_end/;
          IFEND;

          IF job_label_size > 0 THEN
            NEXT p_job_label: [[REP job_label_size OF cell]] IN p_label;
          IFEND;
        ELSE { highest attribute present = 0 }
          cycle_description^.system_file_label.static_label := NIL;
        IFEND;

        cycle_description^.system_file_label.file_previously_opened :=
              p_file_label_header^.file_previously_opened;
      ELSE { possible v1 label }
        RESET p_label;
        get_static_label_header (p_label, v1_header, status);
        IF NOT status.normal THEN
          EXIT /begin_end/;
        IFEND;

        IF v1_header.size > 0 THEN
          get_expanded_static_label (p_label, expanded_static_label,
                v1_file_previously_opened, status);
          IF NOT status.normal THEN
            EXIT /begin_end/;
          IFEND;

          cycle_description^.system_file_label.file_previously_opened :=
                v1_file_previously_opened;
          fmp$put_label_attributes (expanded_static_label,
                cycle_description^.system_file_label);
        IFEND;

        get_job_label_header (p_label, job_label_header, status);
        IF NOT status.normal THEN
          EXIT /begin_end/;
        IFEND;

        job_label_size := job_label_header.size;
        IF job_label_size > 0 THEN
          get_job_label (p_label, job_label_header.size, p_job_label, status);
          IF NOT status.normal THEN
            EXIT /begin_end/;
          IFEND;
        IFEND;

        RESET cycle_description^.system_file_label.static_label;
        NEXT p_file_label_header IN cycle_description^.system_file_label.
              static_label;
        p_file_label_header^.job_routing_label_size := job_label_size;
      IFEND;

      IF cycle_description^.attached_file AND (cycle_description^.device_class =
            rmc$mass_storage_device) THEN
        IF cycle_description^.job_routing_label <> NIL THEN
          FREE cycle_description^.job_routing_label IN
                osv$job_pageable_heap^;
          cycle_description^.job_routing_label := NIL;
        IFEND;
        cycle_description^.job_routing_label_length := 0;

        IF job_label_size > 0 THEN
          fmi$put_job_routing_label (job_label_size, p_job_label,
                cycle_description, status);
          IF NOT status.normal THEN
            EXIT /begin_end/;
          IFEND;
        IFEND;

        IF cycle_description^.permanent_file THEN
          IF (cycle_description^.system_file_label.static_label <> NIL) OR
                cycle_description^.system_file_label.file_previously_opened OR
                (cycle_description^.job_routing_label <> NIL) THEN
            REPEAT
              fmp$catalog_system_file_label (^cycle_description^.
                    system_file_label, cycle_description^.job_routing_label,
                    cycle_description^.job_routing_label_length,
                    cycle_description^.apfid, pfc$append, status);
              IF NOT status.normal THEN
                IF context = NIL THEN
                  PUSH context;
                  context^ := osv$initial_exception_context;
                IFEND;
                context^.condition_status := status;
                osp$enforce_exception_policies (context^);
                status := context^.condition_status;
              IFEND;
            UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
            IF status.normal THEN
              cycle_description^.system_file_label_catalogued := TRUE;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    END /begin_end/;

    fmp$unlock_path_table;
  PROCEND fmp$store_system_label;

?? TITLE := 'fmp$validate_system_label', EJECT ??

  PROCEDURE [XDCL] fmp$validate_system_label
    (    label: SEQ ( * );
         validation_ring: ost$valid_ring;
     VAR valid_checksum: boolean;
     VAR status: ost$status);

    VAR
      computed_checksum: pft$checksum,
      p_file_label_header: ^fmt$static_label_header,
      p_local_label: ^fmt$file_label,
      p_stored_checksum: ^pft$checksum;

    status.normal := TRUE;
    valid_checksum := FALSE;

    p_local_label := ^label;
    RESET p_local_label;
    NEXT p_stored_checksum IN p_local_label;
    IF p_stored_checksum = NIL THEN
      osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes, 'static label checksum',
            status);
      RETURN;
    IFEND;

    NEXT p_file_label_header IN p_local_label;
    IF p_file_label_header = NIL THEN
      osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes, 'p_file_label_header',
            status);
      RETURN;
    IFEND;

    pfp$compute_checksum (p_file_label_header, #SIZE (label) - #SIZE (pft$checksum), computed_checksum);
    IF computed_checksum = p_stored_checksum^ THEN
      valid_checksum := TRUE;
      IF p_file_label_header^.unique_character = fmc$unique_label_id THEN

{ Make sure the job has sufficient privilege to restore the file.  The system
{ job or the system administrator can restore all files.  Other jobs must
{ have minimum ring privilege equal to or less than R1 of the file to be
{ restored.

        IF p_file_label_header^.file_previously_opened AND
              (validation_ring > p_file_label_header^.ring_attributes.r1) THEN
          osp$set_status_condition (ame$ring_validation_error, status);
          RETURN;
        IFEND;

      ELSE { unique character <> fmc$unique_label_id }
        osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes, 'static label', status);
        RETURN;
      IFEND;
    IFEND;
  PROCEND fmp$validate_system_label;

?? TITLE := 'get_expanded_static_label', EJECT ??

  PROCEDURE [INLINE] get_expanded_static_label (VAR p_label: ^SEQ ( * );
    VAR expanded_static_label: bat$static_label_attributes;
    VAR file_previously_opened: boolean;
    VAR status: ost$status);

    VAR
      computed_checksum: integer,
      p_stored_checksum: ^integer,
      v1_label: ^fmt$basic_file_label;

    NEXT v1_label IN p_label;
    IF v1_label = NIL THEN
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, ' static label ', status);
      RETURN;
    IFEND;

    fmp$expand_v1_label (v1_label, expanded_static_label,
          file_previously_opened, status);

    NEXT p_stored_checksum IN p_label;
    IF p_stored_checksum = NIL THEN
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, ' static label checksum ', status);
      RETURN;
    IFEND;

    pfp$compute_checksum (#LOC (v1_label^), #SIZE (v1_label^),
          computed_checksum);
    IF computed_checksum <> p_stored_checksum^ THEN
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, ' static label ', status);
      RETURN;
    IFEND;

    status.normal := TRUE;
  PROCEND get_expanded_static_label;

?? TITLE := 'get_job_label', EJECT ??

  PROCEDURE [INLINE] get_job_label (VAR p_label: ^SEQ ( * );
        job_label_size: fmt$label_section_size;
    VAR p_job_label: ^SEQ ( * );
    VAR status: ost$status);

    VAR
      computed_checksum: integer,
      p_stored_checksum: ^integer;

    NEXT p_job_label: [[REP job_label_size OF cell]] IN p_label;
    IF p_job_label = NIL THEN
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, ' job label ', status);
      RETURN;
    IFEND;

    NEXT p_stored_checksum IN p_label;
    IF p_stored_checksum = NIL THEN
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, ' job label checksum ', status);
      RETURN;
    IFEND;

    pfp$compute_checksum (#LOC (p_job_label^), #SIZE (p_job_label^),
          computed_checksum);
    IF computed_checksum <> p_stored_checksum^ THEN
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, ' job label ', status);
      RETURN;
    IFEND;

    status.normal := TRUE;
  PROCEND get_job_label;

?? TITLE := 'get_job_label_header', EJECT ??

  PROCEDURE [INLINE] get_job_label_header (VAR p_label: ^SEQ ( * );
    VAR job_label_header: fmt$job_label_header;
    VAR status: ost$status);

    CONST
      current_version = 1;

    VAR
      computed_checksum: integer,
      p_job_label_header: ^fmt$job_label_header,
      p_stored_checksum: ^integer;

    NEXT p_job_label_header IN p_label;
    IF p_job_label_header = NIL THEN
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, ' job label header', status);
      RETURN;
    IFEND;

    NEXT p_stored_checksum IN p_label;
    IF p_stored_checksum = NIL THEN
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, ' job label header checksum', status);
      RETURN;
    IFEND;

    pfp$compute_checksum (#LOC (p_job_label_header^), #SIZE
          (p_job_label_header^), computed_checksum);
    IF computed_checksum <> p_stored_checksum^ THEN
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, ' job label header', status);
      RETURN;
    IFEND;

    IF p_job_label_header^.name <> 'BAM_JOB_LABEL' THEN
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, ' job label header', status);
      RETURN;
    IFEND;

    IF p_job_label_header^.version <> current_version THEN
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, ' job label header', status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    job_label_header := p_job_label_header^;
  PROCEND get_job_label_header;

?? TITLE := 'get_label_size', EJECT ??

  PROCEDURE [INLINE] get_label_size (cycle_description:
    ^fmt$cycle_description;
    VAR job_label_size: jmt$system_label_info_length;
    VAR label_size: 0 .. 7fffffff(16);
    VAR status: ost$status);

{ Given an lnt entry this routine returns the size of the label as returned to
{ the caller.

    CONST
      checksum_size = 8;

    VAR
      permanent_file: boolean;

    status.normal := TRUE;
    label_size := 0;
    IF NOT cycle_description^.attached_file THEN
      osp$set_status_abnormal (amc$access_method_id,
            fme$no_preserved_attributes, ' file not attached ', status);
      RETURN;
    IFEND;

    IF (cycle_description^.permanent_file) AND
          (NOT cycle_description^.system_file_label_catalogued) THEN
      osp$set_status_abnormal (amc$access_method_id,
            fme$no_preserved_attributes, ' system file label NOT catalogued ',
            status);
      RETURN;
    ELSE
      IF cycle_description^.system_file_label.static_label <> NIL THEN
        label_size := #SIZE (cycle_description^.system_file_label.
              static_label^) + checksum_size;
      ELSE
        label_size := #SIZE (fmt$static_label_header) + checksum_size;
      IFEND;
    IFEND;

    IF (cycle_description^.device_class <> rmc$mass_storage_device) OR
          (cycle_description^.job_routing_label = NIL) THEN
      job_label_size := 0;
    ELSE
      job_label_size := #SIZE (cycle_description^.job_routing_label^);
      label_size := label_size + job_label_size;
    IFEND;
  PROCEND get_label_size;

?? TITLE := 'get_static_label_header', EJECT ??

  PROCEDURE [INLINE] get_static_label_header (VAR p_label: ^SEQ ( * );
    VAR static_label_header: fmt$static_bam_label_header;
    VAR status: ost$status);

    CONST
      current_version = 1;

    VAR
      computed_checksum: integer,
      p_stored_checksum: ^integer,
      p_static_label_header: ^fmt$static_bam_label_header;

    NEXT p_static_label_header IN p_label;
    IF p_static_label_header = NIL THEN
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, ' p_static_label_header', status);
      RETURN;
    IFEND;

    NEXT p_stored_checksum IN p_label;
    IF p_stored_checksum = NIL THEN
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, 'p_stored_checksum label header ',
            status);
      RETURN;
    IFEND;

    pfp$compute_checksum (#LOC (p_static_label_header^), #SIZE
          (p_static_label_header^), computed_checksum);
    IF computed_checksum <> p_stored_checksum^ THEN
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, ' static label header', status);
      RETURN;
    IFEND;

    IF p_static_label_header^.name <> 'BAM_STATIC_LABEL' THEN
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, ' bam_static_label', status);
      RETURN;
    IFEND;

    IF p_static_label_header^.version <> current_version THEN
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, ' static label header', status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    static_label_header := p_static_label_header^;
  PROCEND get_static_label_header;


MODEND fmm$pf_utility_label;
*DECK DECK=FMM$ROLLBACK_EXAMPLE EXPAND=TRUE
MODULE fmm$rollback_example;
?? RIGHT := 110 ??
{  This discusses rollback as it relates to active_job_recovery.
{  1. What is rollback?
{    Rollback refers to the process of backing out of a process
{    following a system failure, and to allow retrying of that operation.
{    More specifically in the file system it involves
{    leaving both the mainframe and the job tables in a consistant state,
{    specifically sfid's (system file id) of
{    a permanent file or catalog will be wrong.  The file manager ONLY
{    has to rollback those operations involving permanent files, as this
{    the only case where the mainframe and job tables can be out of sync.
{
{    The code involving permanent files or catalogs can not continue without
{    rollback since the segments associated with catalogs would be gone.
{    Following a system crash the system wide tables are re-initialized
{    but the job tables are retained.  The rollback process must undo
{    what was ever going on by backing out of the operation.  Table locks
{    must be cleared, etc.  The rollback must proceed such that
{    the fmp$recover_job_files process may execute and not worry about
{    entries locked, or half updated tables.  After the fmp$recover_job_files
{    executes, the processing continues to the ring 3 (or above caller)
{    who must be allowed to retry the operation.
{    For example assume the follwing structure.
{    PROCEDURE [XDCL, #GATE] pfp$r3_attach ...  (RING 3)
{
{       REPEAT
{          pfp$r2_attach (...
{       UNTIL status.normal OR (status.condition <> ose$job_recovery_condition);
{
{
{        PROCEDURE [XDCL] pfp$r2_attach (....   (RING 2)
{           This must establish a condition handler to
{            rollback in case of a job recovery condition occuring
{
{    If the job recovery condition arises while pfp$r2_attach is executing
{    it must be prepared to back out of what it was doing.
{    Upon return from pfp$r2_attach, and prior to pfp$r3_attach
{    executing the fmp$recover_job_files procedure is executed.
{    A few notes on condition handlers:
{    .  If a condition_handler returns abnormal status the
{       task aborts
{    .  IF a condition occurs, and any where in the calling sequence
{       (within the current ring) there is a condition handler it will get
{       immediate control.
{    .  If the current handler calls pmp$continue_to_cause and there
{       are no more handlers, control will return to this handler.
{    . If there is NO condition handler what will happen on the job
{       recovery condition. DAVE ?????????????????????
{
{ 2.  WHAT needs to rollback?
{     FM - As stated above those file manager operatations involving
{     permanent files will need a condition handler and rollback.
{        - fmp$attach_file
{        - return_attached_file
{     DAVE- Will the other FM operations need a condition handler that
{       will allow the processing to continue unaltered.????????
{     PF - all permanent file operations will need a rollback.
{        - Those operations that are catalog only, will only really
{          need to retry the operation.  The catalog changes will be lost
{          or not.  How will you know if the catalog changes were
{          completed or not????
{          Can we asume if the catalog is closed that the change was complete??
{        - Those operations involving permanent files will need to undo
{          the file manager operation and the attached_pf_table.
{          -  pfp$r2_attach
{          -  pfp$r2_define, pfp$r2_define_data
{          -  pfp$return_permanent_file
{          -  pfp$save_file_label
{      DF - File server
{       The file server queues are not recovered. Any request that is referencing
{       data structures in server wired must be prepared to rollback.
{       Most of the rollback for server could depend on users effectively
{       waiting for server_not_active.
{
{ 3. SCHEDULING
{   Rollback is probably alot of work.
{
{ 4. ROLLBACK TECHNIQUES
{   This discusses some general principals of rolling back.
{   . A general model for rollback is sort of a state table
{     (decision table).  Since the number of rules in a decision table
{     is 2 ** number_of_conditions, a goal should be to keep the number
{     of conditions that have to be rolled back to a minimum.
{     Also try to keep the conditions independant.  IF each condition
{     can be undone regardless of the state of neighboring conditions
{     the number of rules approaches the number of conditions.
{   . The number of conditions can be kept down by:
{      -Use a local copy of the table entry being updated.  Make the update
{       of the actual table in one step. See the example of setting
{       lint_entry.record_state.  The table is thus always in a known
{       state. That is, you know if the update has completed or not,
{       The record itself could be queuried.  If needed the procedure
{       keeps a copy of the entry as it was prior to any updating.
{      -Do not repeat code, either force the code to all flow through the
{       same path, or put the code in  a procedure.
{   . When the condition occurs the condition handler must determine the
{     the "state" of the code at the time of the crash.  This may be done by
{       - Dynamically determining the condition state:
{         example osp$test_signature_lock (see below)
{       - Keep track of state by use of state variable available in the
{         condition handler.
{        If this technique is employed #SPOIL should be done on the state
{         variable to force it to be written to memory.
{       - See example below of determining whether a procedure has been
{         called or not.
{
{  5.RANDOM NOTES:
{   . Rollback should follow normal structured programming rules.  That is
{     put the condition handler in the procedure that is establishing the
{     state that needs to be done.
{     Example:
{       pfp$r2_attach
{         fmp$attach_file
{           fmp$process_pt_request
{              Put condition handler in here to undo any table locks
{              osp$set_signature_lock
{     The problem with this is that the fmp$process_pt_request is a shared
{       interface between interfaces requiring rollback and those that do not.
{       While the PF calling sequence will want to return and retry at
{       the outermost level teh non-pf caller will want an immediate retry.
{       Example:
{         REPEAT
{           fmp$process_pt_request  (...., status);
{         UNTIL (status.normal) OR (status.condition = ose$job_recovery_complete
{
{    . On interfaces that are designed to undo an operation, provide
{      as much verification of the call as possible.
{      Example fmp$undo_attach_file  (lfn, apfid, gfn, sfid,...
{           Where apfid, gfn, and sfid are really only used to verify
{           the caller.
{
{   . You can NOT always assume a cybil assignment (:=) statement
{     always complete or not.  Where the structure is > 256 bytes the
{     assignement loops, so the possibility of a half updated record
{     exists.  Boolean,s pointers, and ordinals will probably either complete
{     or not.
{
{   . An operation that takes in a "work list" should also probably return
{     a work result if the operation is one that needs to be rolled back.
{     An example of this might be fmp$locate_lnt_entry
{
{   . Its OK to loose a few allocated chunks of memory.
{
{    . There are probably two classes of permanent file requests.
{      i. Those that can be restarted without any work.
{         An example of this is display_catalog
{      ii. Those that are not restartable.
{         An example of this is attach_file.
{       Those requests that are restartable should just be able to
{         pass back ose$volume_unavailable since most callers are
{        prepared to wait and retry.
{
{ 6. QUESTIONS.
{  A.   If the code was executing in ring 2, and no condition handler was
{    established, does that code continue executing??
{    Upon return to its outer ring caller, fmp$recover_job_files would
{    be invoked.  (DAVE is that ^ sentence true????????????)
{       (or must must there be a condition handler which does nothing
{       but return NORMAL status so the task will resume executing as is.
{    It would be easiest if ring 2 code without condition handlers could
{    just continue executing.
{  B.  If the process had just completed a catalog operation, and was now
{    doing something that assumed that catalog operation was done
{    We cannot say anything about the catalog operation.  In a system
{    crash recovery will write unlocked modified pages from the image file.
{    If we are not recovering with an image file we can not say anything
{    about the catalog, since we do not wait for the write_modified pages
{    on the unlock.


?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc osp$establish_condition_handler
*copyc pmp$establish_condition_handler
*copyc pmp$continue_to_cause
*copyc osp$set_status_abnormal
*copyc pmt$program_parameters
*copyc clp$put_job_output
*copyc ost$wait
*copyc ost$signature_lock

  PROCEDURE osp$set_signature_lock (VAR lock: ost$signature_lock;
        wait: ost$wait;
    VAR status: ost$status);
    status.normal := TRUE;
    lock.lock_id := 1;
    RETURN;
  PROCEND osp$set_signature_lock;

  PROCEDURE osp$clear_signature_lock (VAR lock: ost$signature_lock;
    VAR status: ost$status);
    status.normal := TRUE;
    lock.lock_id := 0;
    RETURN;
  PROCEND osp$clear_signature_lock;


  PROCEDURE fmp$locate_lint_entry (VAR lint_entry: ^lint_record);

  PROCEND;


  PROCEDURE osp$test_signature_lock (VAR lock: ost$signature_lock;
    VAR lock_status: ost$signature_lock_status;
    VAR status: ost$status);
    status.normal := TRUE;
    IF lock.lock_id = 0 THEN
      lock_status := osc$sls_not_locked;
    ELSEIF lock.lock_id = 1 THEN
      lock_status := osc$sls_locked_by_current_task;
    ELSE
      lock_status := osc$sls_locked_by_another_task;
    IFEND;
  PROCEND osp$test_signature_lock;
*copyc pmp$cause_condition

  CONST
    ose$not_initiated_yet = 567,
    ose$job_recovery_condition = 569,
    ose$processing_started = 568;

?? POP ??

?? EJECT ??

  TYPE
    lint_record  = record
      case record_state: (free_record, record_update_in_progress,
        normal_record) of
      = record_update_in_progress, normal_record =
        lint_field_1: integer,
        lint_field_2: string (256),
        lint_field_3: string (256),
        line_field_4: integer,
      = free_record =
        ,
      casend,
    recend;

  CONST
    job_recovery_condition = 'JOB_RECOVERY                   ';

  VAR
    lock1,
    lock3,
    lock2: ost$signature_lock := [0];


?? TITLE := '*** fmp$gizmo ***', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$gizmo (p: pmt$program_parameters;
    VAR status: ost$status);

    VAR
      lint_entry: ^lint_record,
      lint_record_update_started: boolean,
      lint_entry_as_it_was: lint_record,
      fmp$gizmo_child_status: ost$status,
      local_status: ost$status,
      lock_one_set: boolean,
      conds: pmt$condition,
      ed: pmt$established_handler;

?? NEWTITLE := '   *** rollback_gizmo ***', EJECT ??

    PROCEDURE rollback_gizmo (condition: pmt$condition;
          cd: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR ch_status: ost$status);

      VAR
        lock_status: ost$signature_lock_status,
        ignored_status: ost$status;

      ch_status.normal := TRUE;

{     Cleanup all "states" sets in fmp$gizmo
{
{  Note comment on window on boolean lock_one_set
      IF lock_one_set THEN
        clp$put_job_output (' clear lock 1', ignored_status);
        osp$clear_signature_lock (lock1, ignored_status);
      IFEND;

{
{ 1. This is an example of dynamically determining the state of the procedures
{  processing.
      osp$test_signature_lock (lock2, lock_status, ignored_status);
      IF lock_status = osc$sls_locked_by_current_task THEN
        clp$put_job_output (' clear lock 2', ignored_status);
        osp$clear_signature_lock (lock2, status);
      ELSE
        clp$put_job_output (' dont clear lock 2', ignored_status);
      IFEND;

      osp$test_signature_lock (lock3, lock_status, ignored_status);
      IF lock_status = osc$sls_locked_by_current_task THEN
        clp$put_job_output (' clear lock 3', ignored_status);
        osp$clear_signature_lock (lock3, status);
      ELSE
        clp$put_job_output (' dont clear lock 3', ignored_status);
      IFEND;

{
{ 2. This is an example of using the status condition of a child
{      procedure to determine what needs to be done.  This assumes
{      the child has cleaned up after itself.
      IF fmp$gizmo_child_status.normal THEN
        { fmp$gizmo_child completed successfully
        { undo fmp$gizmo_child (There should be an opposite procedure
        { to call.
      ELSE
        CASE fmp$gizmo_child_status.condition OF
        = ose$not_initiated_yet =
          { fmp$gizmo_child has not been called yet
        = ose$processing_started =
          { JOB RECOVERY ERROR
          { fmp$gizmo_child job recovery condition should handle this
        = ose$job_recovery_condition =
          { The fmp$gizmo_child has detected and rolled back the condition
          { All is OK
        ELSE
          { Another error occurred in fmp$gizmo_child (eg. lfn_in_use)
          { act based on that error
        CASEND;
      IFEND;

{ 3. Demonstrate use of the tri-state record state and use
{    of saving the old record as it was.
      IF lint_record_update_started THEN
        CASE lint_entry^.record_state OF
        = record_update_in_progress =
          lint_entry^ := lint_entry_as_it_was;
        = free_record =
          { Record update not started
        = normal_record =
          { Record update has been completed!
          { Use normal cleanup procedures
        CASEND;
      IFEND;


{
{  Set this status now so that the caller may either retry this operator, or
{ the callers condition handler may know that this procedure has rolled back.
      osp$set_status_abnormal ('FM', ose$job_recovery_condition, 'fmp$gizmo',
            status);
      pmp$continue_to_cause (pmc$inhibit_standard_procedure, ignored_status);
      EXIT fmp$gizmo;
    PROCEND rollback_gizmo;
?? OLDTITLE ??
?? EJECT ??
{  Set up "states" prior to establishing a condition handler
    lock_one_set := FALSE;
    local_status.normal := TRUE;
    lint_record_update_started := FALSE;
    fmp$gizmo_child_status.normal := FALSE;
    fmp$gizmo_child_status.condition := ose$not_initiated_yet;
    #SPOIL (local_status.normal, lint_record_update_started,
          fmp$gizmo_child_status, fmp$gizmo_child_status);

{  Establish condition handler
    conds.selector := pmc$user_defined_condition;
    conds.user_condition_name := job_recovery_condition;
    pmp$establish_condition_handler (conds, ^rollback_gizmo, ^ed,
          local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

{  set this procedures condition to indicate work has started
    #SPOIL (status);
    status.condition := ose$processing_started;
    status.normal := FALSE;
    #SPOIL (status);

{  Begin procedure work, using local_status
    osp$set_signature_lock (lock1, osc$wait, local_status);
{ eeek! a window! This is an example to why the following techniques are better
{  - Dynamically determining the state (Example osp$test_signature_lock)
{  - Using the status.condition field to allow the child to set " complete"
{     (as in fmp$gizmo_child example
    #SPOIL (lock_one_set);
    lock_one_set := TRUE;
    #SPOIL (lock_one_set);

    osp$set_signature_lock (lock2, osc$wait, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

{ emulate lock 3 set by another task
    lock3.lock_id := 20;

    fmp$gizmo_child (fmp$gizmo_child_status);

    fmp$locate_lint_entry (lint_entry);
    lint_record_update_started := TRUE;
    lint_entry_as_it_was := lint_entry^;
    lint_entry^.record_state := record_update_in_progress;
    lint_entry^.lint_field_1 := 12;
    lint_entry^.lint_field_2 := ' If you can imagine it';

    { Make the final update in one step that will either complete
    { or NOT (as opposed to half updated
    lint_entry^.record_state := normal_record;


{  pmp$cause_condition used for testing only
{    pmp$cause_condition (job_recovery_condition, NIL, local_status);
    status := local_status;
  PROCEND fmp$gizmo;
?? EJECT ??

  PROCEDURE fmp$gizmo_child (VAR status: ost$status);

{ 1. Set up states
{ Set any "Grandchildren status to ose$not_initiated_yet

{ 2. Establish handler for job recovery condition
{ This condition handler should roll back and return the status condition
{ ose$Job_recovery_condition
{ pmp$establish_condition_handler (rollback_fmp$gizmo_child

{ 3.Set status to starting
    status.condition := ose$processing_started;
    status.normal := FALSE;

{ 4.
{ DO PROCEDURE SUBPROCESSING

{ 5. Complete
    status.normal := TRUE;
  PROCEND fmp$gizmo_child;

?? TITLE := ' ANOTHER EXAMPLE ', EJECT ??
?? EJECT ??
  PROCEDURE [XDCL, #GATE] dfp$rollback_example
    (VAR status: ost$status);


{ PURPOSE:
{   This condition handler is used around the code that is referencing file server wire
{   the case of job recovery.  The file server queues are kept in server wired and the queue definition is not
{   recovered.  If the job is recovered while it is doing dfp$begin_remote_procedur_call
{   the condition handler will perform a non-local exit with an abnormal status of
{   DFE$SERVER_NOT_ACTIVE - almost all callers are prepared for this.
{

    PROCEDURE job_recovery_condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        display_status: ost$status;

      IF (condition.selector = pmc$user_defined_condition) AND (condition.user_condition_name =
            'OSC$JOB_RECOVERY') THEN
        osp$set_status_abnormal ('DF', 123 {dfe$server_not_active} , ' job recovery - begin_rpc  ',
              status);
        EXIT dfp$rollback_example;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IF NOT handler_status.normal THEN
        RETURN;
      IFEND;

    PROCEND job_recovery_condition_handler;


    osp$establish_condition_handler (^job_recovery_condition_handler, FALSE);

    { Do other stuff as required.



  PROCEND dfp$rollback_example;

MODEND fmm$rollback_example;
*DECK DECK=FMM$SETFA_PROCESSING EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File System : SETFA Processing' ??
MODULE fmm$setfa_processing;

{ PURPOSE:
{   This module contains the procedures that process SETFA information.

?? NEWTITLE := 'Global Declaration Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$attribute_validation_errors
*copyc amt$entry_point_reference
*copyc amt$file_attributes
*copyc amt$file_reference
*copyc fmc$current_revision_level
*copyc fmc$unique_label_id
*copyc fme$file_management_errors
*copyc fmt$cycle_description
*copyc fmt$file_attribute_keys
*copyc fmt$static_label_header
*copyc fmt$static_label_item
*copyc fse$get_info_validation_errors
*copyc fst$goi_object
*copyc fst$goi_object_information
*copyc fst$job_environment_information
*copyc fst$goi_object_info_requests
*copyc fst$open_position
*copyc oss$job_paged_literal
*copyc pfe$internal_error_conditions
?? POP ??
*copyc bap$merge_dynamic_attr_source
*copyc bap$set_file_reference_abnormal
*copyc fmp$catalog_system_file_label
*copyc fmp$evaluate_path
*copyc fmp$extract_dynamic_setfa_attrs
*copyc fmp$setup_job_environment_info
*copyc fmp$unlock_path_table
*copyc fsp$convert_file_contents
*copyc fsp$convert_to_old_contents
*copyc i#current_sequence_position
*copyc i#move
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc fmv$static_label_header
*copyc fmv$system_file_attributes
*copyc osv$job_pageable_heap

  CONST
    last_attribute_key = 76;

  TYPE
    char_set = set of char;

  VAR
    default_dynamic_setfa_entries: [STATIC, READ, oss$job_paged_literal] fst$setfa_attachment_options :=
          [FALSE, * , FALSE, * , FALSE, * , FALSE, * , FALSE, * , FALSE, * ],

    space_selector: [STATIC, READ, oss$job_paged_literal] char_set := [' '];

  VAR
    file_label_key: [STATIC, READ, oss$job_paged_literal] array [1 .. last_attribute_key] of
          fmt$file_attribute_keys := [

    {amc$access_level .............. = 001} amc$max_attribute,
          {amc$access_mode ............... = 002} amc$max_attribute,
          {amc$application_info .......... = 003} amc$max_attribute,
          {amc$average_record_length ..... = 004} fmc$average_record_length,
          {amc$block_type ................ = 005} fmc$block_type,
          {amc$character_conversion ...... = 006} fmc$character_conversion,
          {amc$clear_space ............... = 007} fmc$clear_space,
          {amc$collate_table ............. = 008} fmc$collate_table,
          {amc$collate_table_name ........ = 009} fmc$collate_table_name,
          {............................... = 010} amc$max_attribute,
          {............................... = 011} amc$max_attribute,
          {amc$data_padding .............. = 012} fmc$data_padding,
          {amc$embedded_key .............. = 013} fmc$embedded_key,
          {amc$error_exit_name ........... = 014} amc$max_attribute,
          {amc$error_exit_procedure ...... = 015} amc$max_attribute,
          {amc$error_limit ............... = 016} amc$max_attribute,
          {amc$error_options ............. = 017} amc$max_attribute,
          {amc$estimated_record_count .... = 018} fmc$estimated_record_count,
          {amc$file_access_procedure ..... = 019} fmc$file_access_procedure,
          {amc$file_contents ............. = 020} fmc$file_contents,
          {amc$file_length ............... = 021} amc$max_attribute,
          {amc$file_limit ................ = 022} fmc$file_limit,
          {............................... = 023} amc$max_attribute,
          {amc$file_organization ......... = 024} fmc$file_organization,
          {amc$file_processor ............ = 025} fmc$file_processor,
          {amc$file_structure ............ = 026} fmc$file_structure,
          {amc$forced_write .............. = 027} fmc$forced_write,
          {amc$global_access_mode ........ = 028} amc$max_attribute,
          {amc$global_file_address ....... = 029} amc$max_attribute,
          {amc$global_file_position ...... = 030} amc$max_attribute,
          {amc$global_file_name .......... = 031} amc$max_attribute,
          {amc$global_share_mode ......... = 032} amc$max_attribute,
          {amc$index_levels .............. = 033} fmc$index_levels,
          {amc$index_padding ............. = 034} fmc$index_padding,
          {amc$internal_code ............. = 035} fmc$internal_code,
          {amc$key_length ................ = 036} fmc$key_length,
          {amc$key_position .............. = 037} fmc$key_position,
          {amc$key_type .................. = 038} fmc$key_type,
          {amc$label_exit_name ........... = 039} amc$max_attribute,
          {amc$label_exit_procedure ...... = 040} amc$max_attribute,
          {amc$label_options ............. = 041} amc$max_attribute,
          {amc$label_type ................ = 042} fmc$label_type,
          {............................... = 043} amc$max_attribute,
          {amc$line_number ............... = 044} fmc$line_number,
          {amc$max_block_length .......... = 045} fmc$max_block_length,
          {amc$max_record_length ......... = 046} fmc$max_record_length,
          {amc$message_control ........... = 047} amc$max_attribute,
          {amc$min_block_length .......... = 048} fmc$min_block_length,
          {amc$min_record_length ......... = 049} fmc$min_record_length,
          {amc$null_attribute ............ = 050} amc$max_attribute,
          {amc$open_position ............. = 051} amc$max_attribute,
          {amc$padding_character ......... = 052} fmc$padding_character,
          {amc$page_format ............... = 053} fmc$page_format,
          {amc$page_length ............... = 054} fmc$page_length,
          {amc$page_width ................ = 055} fmc$page_width,
          {amc$permanent_file ............ = 056} amc$max_attribute,
          {amc$preset_value .............. = 057} fmc$preset_value,
          {............................... = 058} amc$max_attribute,
          {amc$record_limit .............. = 059} fmc$record_limit,
          {amc$record_type ............... = 060} fmc$record_type,
          {amc$records_per_block ......... = 061} fmc$records_per_block,
          {amc$return_option ............. = 062} amc$max_attribute,
          {amc$ring_attributes ........... = 063} fmc$ring_attributes,
          {amc$statement_identifier ...... = 064} fmc$statement_identifier,
          {............................... = 065} amc$max_attribute,
          {amc$user_info ................. = 066} fmc$user_info,
          {amc$vertical_print_density .... = 067} fmc$vertical_print_density,
          {amc$compression_procedure_name  = 068} fmc$compression_procedure_name,
          {amc$dynamic_home_block_space .. = 069} fmc$dynamic_home_block_space,
          {amc$hashing_procedure_name .... = 070} fmc$hashing_procedure_name,
          {amc$initial_home_block_count .. = 071} fmc$initial_home_block_count,
          {amc$loading_factor ............ = 072} fmc$loading_factor,
          {amc$lock_expiration_time ...... = 073} fmc$lock_expiration_time,
          {amc$logging_options ........... = 074} fmc$logging_options,
          {amc$log_residence ............. = 075} fmc$log_residence,
          {............................... = xxx} amc$max_attribute];

?? TITLE := 'PROCEDURE [XDCL] fmp$catalog_set_file_attributes', EJECT ??

  PROCEDURE [XDCL] fmp$catalog_set_file_attributes
    (    cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

    VAR
      system_file_label: fmt$system_file_label;

{ This routine is only called if cycle_description^.system_file_label.
{ file_previously_opened = FALSE.

    status.normal := TRUE;

    system_file_label.file_previously_opened := FALSE;
    system_file_label.static_label := cycle_description^.static_setfa_entries;

    IF (system_file_label.static_label <> NIL) OR (cycle_description^.job_routing_label <> NIL) THEN
      fmp$catalog_system_file_label (^system_file_label, cycle_description^.job_routing_label,
            cycle_description^.job_routing_label_length, cycle_description^.apfid, pfc$append, status);
    IFEND;
  PROCEND fmp$catalog_set_file_attributes;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$file_command', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$file_command
    (    file: fst$file_reference;
         file_attributes: ^amt$file_attributes;
     VAR status: ost$status);

    TYPE
      file_attribute_keys = set of amt$file_attribute_keys,
      fmt$entry_kind = (fmc$setfa_entry, fmc$label_entry);

    VAR
      attribute_index: amt$file_attribute_keys,
      converted_file_contents: amt$file_contents,
      current_file_structure_p: ^string ( * ),
      cycle_description: ^fmt$cycle_description,
      existing_str: ^string ( * ),
      header: ^fmt$static_label_header,
      ignore_evaluated_file_reference: fst$evaluated_file_reference,
      ignore_found: boolean,
      ignore_path_handle: fmt$path_handle,
      item: ^fmt$static_label_item,
      label_index: fmt$file_attribute_keys,
      label_item_replaced: boolean,
      new_setfa_label: ^SEQ ( * ),
      previous_file_contents_p: ^string ( * ),
      path_index: 1 .. amc$max_path_name_size + 1,
      ring_attributes_specified: boolean,
      setfa_header: ^fmt$static_label_header,
      setfa_label_size: integer,
      sorted_attributes: ^amt$file_attributes,
      specified_file_structure_p: ^amt$file_structure,
      split_file_contents: amt$file_contents,
      split_file_structure: amt$file_structure,
      static_setfa_item: ^fmt$static_label_item,
      store_split_file_structure: boolean,
      str: ^string ( * ),
      warning_status: ost$status;

?? NEWTITLE := 'get_current_file_structure', EJECT ??

    PROCEDURE get_current_file_structure
      (VAR current_file_structure_p: ^string ( * ));

      VAR
        attribute: ^fmt$static_label_item,
        local_index: 1 .. amc$max_attribute + 1,
        local_setfa_sequence_p: ^SEQ ( * ),
        str: ^string ( * );

      current_file_structure_p := NIL;
      local_setfa_sequence_p := cycle_description^.static_setfa_entries;
      local_index := label_index + 1;
      WHILE local_index <= fmc$file_structure DO
        IF header^.attribute_present [local_index] THEN
          NEXT attribute: [local_index] IN local_setfa_sequence_p;
          IF attribute = NIL THEN
            RETURN;
          IFEND;
          IF local_index = fmc$file_processor THEN
            NEXT str: [attribute^.name_length] IN local_setfa_sequence_p;
          ELSEIF local_index = fmc$file_structure THEN
            NEXT str: [attribute^.name_length] IN local_setfa_sequence_p;
            current_file_structure_p := str;
          IFEND;
        IFEND;
        local_index := local_index + 1;
      WHILEND;

    PROCEND get_current_file_structure;

?? TITLE := 'process_attributes', EJECT ??

{ PURPOSE:
{   The purpose of this request is to store the specified dynamic attributes in
{   the cycle_description and calculate the size of the sequence needed to store
{   the specified static attributes.

    PROCEDURE process_attributes
      (    cycle_description: ^fmt$cycle_description;
       VAR attributes: ^amt$file_attributes;
       VAR setfa_label_size: integer;
       VAR ring_attributes_specified: boolean);

      PROCEDURE [INLINE] fsp$determine_static_attr_size
        (    key: amt$file_attribute_keys;
         VAR size: integer);

        CASE key OF
        = amc$block_type, amc$character_conversion, amc$clear_space, amc$file_organization, amc$forced_write,
              amc$internal_code, amc$label_type, amc$padding_character, amc$page_format, amc$record_type,
              amc$data_padding, amc$dynamic_home_block_space, amc$embedded_key, amc$index_padding,
              amc$key_type, amc$loading_factor, amc$logging_options =
          size := size + #SIZE (amt$attribute_source) + #SIZE (fmt$file_attribute_keys) +
                #SIZE (amt$block_type);

        = amc$file_contents =

{ Extra space might be needed if the specified file_contents is split into the original file_contents and
{ file_structure components for storage in the label.

          size := size + (2 * (#SIZE (amt$attribute_source) + #SIZE (fmt$file_attribute_keys) +
                1 + #SIZE (ost$name)));

        = amc$file_processor =
          size := size + #SIZE (amt$attribute_source) + #SIZE (fmt$file_attribute_keys) +
                1 + #SIZE (ost$name);

        = amc$file_structure =
          size := size + #SIZE (amt$attribute_source) + #SIZE (fmt$file_attribute_keys) +
                1 + #SIZE (ost$name);
          specified_file_structure_p := ^file_attributes^ [attribute_index].file_structure;

        = amc$line_number, amc$statement_identifier =
          size := size + #SIZE (amt$attribute_source) + #SIZE (fmt$file_attribute_keys) +
                #SIZE (amt$line_number);

        = amc$collate_table_name, amc$compression_procedure_name, amc$file_access_procedure,
              amc$hashing_procedure_name =
          size := size + #SIZE (amt$attribute_source) + #SIZE (fmt$file_attribute_keys) +
                3 + #SIZE (amt$entry_point_reference);

        = amc$log_residence =
          size := size + #SIZE (amt$attribute_source) + #SIZE (fmt$file_attribute_keys) +
                2 + #SIZE (amt$log_residence);

        = amc$user_info =
          size := size + #SIZE (amt$attribute_source) + #SIZE (fmt$file_attribute_keys) +
                1 + #SIZE (amt$user_info);

        ELSE
          size := size + #SIZE (amt$attribute_source) + #SIZE (fmt$file_attribute_keys) + #SIZE (integer);
        CASEND;

      PROCEND fsp$determine_static_attr_size;

      PROCEDURE [INLINE] initialize_dynamic_entries;

        IF cycle_description^.dynamic_setfa_entries = NIL THEN
          ALLOCATE cycle_description^.dynamic_setfa_entries IN osv$job_pageable_heap^;
          cycle_description^.dynamic_setfa_entries^ := default_dynamic_setfa_entries;
        IFEND;
      PROCEND initialize_dynamic_entries;

      VAR
        setfa_attribute_keys: file_attribute_keys;

      setfa_label_size := 0;
      setfa_attribute_keys := $file_attribute_keys [];
      ring_attributes_specified := FALSE;
      specified_file_structure_p := NIL;

      FOR attribute_index := UPPERBOUND (attributes^) DOWNTO 1 DO
        IF attributes^ [attribute_index].key IN setfa_attribute_keys THEN
          attributes^ [attribute_index].key := amc$null_attribute;
        ELSE
          setfa_attribute_keys := setfa_attribute_keys + $file_attribute_keys
                [attributes^ [attribute_index].key];
          CASE attributes^ [attribute_index].key OF
          = amc$access_mode =
            initialize_dynamic_entries;
            cycle_description^.dynamic_setfa_entries^.access_modes_specified := TRUE;
            #UNCHECKED_CONVERSION (attributes^ [attribute_index].access_mode,
                  cycle_description^.dynamic_setfa_entries^.access_modes);

          = amc$error_exit_name =
            initialize_dynamic_entries;
            cycle_description^.dynamic_setfa_entries^.error_exit_name_specified := TRUE;
            cycle_description^.dynamic_setfa_entries^.error_exit_name :=
                  attributes^ [attribute_index].error_exit_name;

          = amc$error_limit =
            initialize_dynamic_entries;
            cycle_description^.dynamic_setfa_entries^.error_limit_specified := TRUE;
            cycle_description^.dynamic_setfa_entries^.error_limit := attributes^ [attribute_index].
                  error_limit;

          = amc$label_exit_name =
            initialize_dynamic_entries;
            cycle_description^.dynamic_setfa_entries^.label_exit_name_specified := TRUE;
            cycle_description^.dynamic_setfa_entries^.label_exit_name :=
                  attributes^ [attribute_index].label_exit_name;

          = amc$message_control =
            initialize_dynamic_entries;
            cycle_description^.dynamic_setfa_entries^.message_control_specified := TRUE;
            cycle_description^.dynamic_setfa_entries^.message_control :=
                  attributes^ [attribute_index].message_control;

          = amc$open_position =
            initialize_dynamic_entries;
            cycle_description^.dynamic_setfa_entries^.open_position_specified := TRUE;
            cycle_description^.dynamic_setfa_entries^.open_position :=
                  attributes^ [attribute_index].open_position;

          = amc$ring_attributes =
            ring_attributes_specified := TRUE;

          ELSE

{ Calculate the size of the space needed in the sequence to store the static attributes specified by a SETFA.

            fsp$determine_static_attr_size (attributes^ [attribute_index].key, setfa_label_size);
          CASEND;
        IFEND;
      FOREND;

    PROCEND process_attributes;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'set_system_error_status', EJECT ??

    PROCEDURE set_system_error_status
      (    attribute: string ( * );
       VAR status: ost$status);

      VAR
        status_text: string (osc$max_string_size),
        text_length: integer;

      STRINGREP (status_text, text_length, 'Nexting of ', attribute,
            ' in SETFA_ENTRIES resulted in a NIL pointer in FMP$FILE_COMMAND');
      osp$set_status_abnormal (amc$access_method_id, fme$system_error, status_text (1, text_length), status);

    PROCEND set_system_error_status;
?? OLDTITLE ??
?? NEWTITLE := 'sort_setfa_entries', EJECT ??

{ PURPOSE:
{   The purpose of this request is to sort the file_attributes in ascending
{   order, by file_attribute keys.

    PROCEDURE sort_setfa_entries
      (    sorted_attributes: {input/output} ^amt$file_attributes);

      VAR
        current: integer,
        gap: integer,
        start: integer,
        swap: amt$file_item,
        swap_values: boolean;

{ Use shell sort technique.

      gap := UPPERBOUND (sorted_attributes^);
      WHILE gap > 1 DO
        gap := 2 * (gap DIV 4) + 1;
        FOR start := 1 TO (UPPERBOUND (sorted_attributes^) - gap) DO
          current := start;
          swap_values := TRUE;
          WHILE (current > 0) AND swap_values DO
            swap_values := file_label_key [sorted_attributes^ [current].key] >
                  file_label_key [sorted_attributes^ [current + gap].key];
            IF swap_values THEN
              swap := sorted_attributes^ [current];
              sorted_attributes^ [current] := sorted_attributes^ [current + gap];
              sorted_attributes^ [current + gap] := swap;
              current := current - gap;
            IFEND;
          WHILEND;
        FOREND;
      WHILEND;

    PROCEND sort_setfa_entries;
?? OLDTITLE ??
?? NEWTITLE := 'store_static_entry', EJECT ??

{ PURPOSE:
{   The purpose of this request is to store a static attribute into a temporary
{   label that has the same format as the file label.

    PROCEDURE store_static_entry
      (    key: fmt$file_attribute_keys;
           entry_kind: fmt$entry_kind;
       VAR status: ost$status);

      VAR
        conversion_status: ost$status,
        file_contents: amt$file_contents,
        file_structure: amt$file_structure,
        name_index: 1 .. osc$max_name_size + 1;

?? NEWTITLE := 'put_entry_point_reference', EJECT ??

      PROCEDURE [INLINE] put_entry_point_reference
        (    name: pmt$program_name;
             path: amt$file_reference);

        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF name <> osc$null_name THEN
          #SCAN (space_selector, name, name_index, ignore_found);
          static_setfa_item^.entry_point_name_length := name_index - 1;
          NEXT str: [static_setfa_item^.entry_point_name_length] IN new_setfa_label;
          str^ (1, static_setfa_item^.entry_point_name_length) := name;
        ELSE
          static_setfa_item^.entry_point_name_length := 1;
          NEXT str: [static_setfa_item^.entry_point_name_length] IN new_setfa_label;
          str^ (1, static_setfa_item^.entry_point_name_length) := ' ';
        IFEND;

        #SCAN (space_selector, path, path_index, ignore_found);
        static_setfa_item^.entry_point_path_length := path_index - 1;
        IF path_index > 1 THEN
          NEXT str: [static_setfa_item^.entry_point_path_length] IN new_setfa_label;
          str^ (1, static_setfa_item^.entry_point_path_length) := path;
        IFEND;

        IF key = label_index THEN { non-default value is currently stored }
          NEXT str: [item^.entry_point_name_length] IN cycle_description^.static_setfa_entries;
          IF str = NIL THEN
            set_system_error_status ('ENTRY_POINT NAME', status);
          ELSEIF item^.entry_point_path_length > 0 THEN
            NEXT str: [item^.entry_point_path_length] IN cycle_description^.static_setfa_entries;
            IF str = NIL THEN
              set_system_error_status ('ENTRY_POINT PATH', status);
            IFEND;
          IFEND;
        IFEND;

      PROCEND put_entry_point_reference;

?? TITLE := 'put_name', EJECT ??

      PROCEDURE [INLINE] put_name
        (    name: pmt$program_name);

        #SCAN (space_selector, name, name_index, ignore_found);
        static_setfa_item^.name_length := name_index - 1;
        NEXT str: [static_setfa_item^.name_length] IN new_setfa_label;
        str^ (1, static_setfa_item^.name_length) := name;
        IF key = label_index THEN
          NEXT str: [item^.name_length] IN cycle_description^.static_setfa_entries;
          IF str = NIL THEN
            set_system_error_status ('NAME', status);
          IFEND;
        IFEND;
      PROCEND put_name;

?? OLDTITLE, EJECT ??

      CASE key OF
      = fmc$block_type =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.block_type := sorted_attributes^ [attribute_index].block_type;
        ELSE
          static_setfa_item^.block_type := item^.block_type;
        IFEND;
      = fmc$character_conversion =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.character_conversion := sorted_attributes^ [attribute_index].
                character_conversion;
        ELSE
          static_setfa_item^.character_conversion := item^.character_conversion;
        IFEND;
      = fmc$clear_space =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.clear_space := sorted_attributes^ [attribute_index].clear_space;
        ELSE
          static_setfa_item^.clear_space := item^.clear_space;
        IFEND;
      = fmc$file_access_procedure =
        IF entry_kind = fmc$setfa_entry THEN
          put_entry_point_reference (sorted_attributes^ [attribute_index].file_access_procedure,
                osc$null_name);
        ELSE
          NEXT static_setfa_item: [key] IN new_setfa_label;
          static_setfa_item^.entry_point_name_length := item^.entry_point_name_length;
          NEXT str: [static_setfa_item^.entry_point_name_length] IN new_setfa_label;
          NEXT existing_str: [item^.entry_point_name_length] IN cycle_description^.static_setfa_entries;
          IF existing_str = NIL THEN
            set_system_error_status ('FILE_ACCESS_PROCEDURE entry_point_name', status);
            RETURN;
          IFEND;
          str^ (1, static_setfa_item^.entry_point_name_length) :=
                existing_str^ (1, item^.entry_point_name_length);
          static_setfa_item^.entry_point_path_length := item^.entry_point_path_length;
          IF static_setfa_item^.entry_point_path_length > 0 THEN
            NEXT str: [static_setfa_item^.entry_point_path_length] IN new_setfa_label;
            NEXT existing_str: [item^.entry_point_path_length] IN cycle_description^.static_setfa_entries;
            IF existing_str = NIL THEN
              set_system_error_status ('FILE_ACCESS_PROCEDURE entry_point_path', status);
              RETURN;
            IFEND;
            str^ (1, static_setfa_item^.entry_point_path_length) :=
                  existing_str^ (1, item^.entry_point_path_length);
          IFEND;
        IFEND;
      = fmc$file_contents =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN

{ For reasons of compatibility, the new keyword is split into the original file_contents and file_structure
{ components for storage in the setfa label; the single value of FC changes both the FC and FS components.
{ If an old value is specified for FC (legible, list, object, screen) or FS (data, library, form, etc.) and
{ previously specified values of FC and FS in the setfa label represent one of the new keywords, then these
{ values are treated as a unit by the new value of FC and/or FS; if the other parameter is not specified,
{ the corresponding label field is set to unknown.

          fsp$convert_to_old_contents (sorted_attributes^ [attribute_index].file_contents,
                split_file_contents, split_file_structure);
          IF (specified_file_structure_p = NIL) OR NOT (((split_file_contents = fsc$list) AND
                (specified_file_structure_p^ = fsc$unknown_contents)) OR
                ((sorted_attributes^ [attribute_index].file_contents = fsc$unknown_contents) AND
                (specified_file_structure_p^ = fsc$data))) THEN
            store_split_file_structure := (split_file_structure <> fsc$unknown_contents) OR
                  (split_file_contents = fsc$unknown_contents) OR (split_file_contents = fsc$source_map);
          IFEND;
          put_name (split_file_contents);
          IF key = label_index THEN

{ The original file_contents value was replaced and it needs to be kept around for later use in determining
{ if a previously defined file_structure needs to be replaced with UNKNOWN.

            previous_file_contents_p := str;
          IFEND;
          IF store_split_file_structure THEN

{ A keyword value was specified.  If the original values of file_contents and file_structure are not valid
{ keyword combinations, the original file_structure value will be replaced and a warning status returned.

            get_current_file_structure (current_file_structure_p);
            IF current_file_structure_p <> NIL THEN
              file_structure := current_file_structure_p^;
              IF previous_file_contents_p <> NIL THEN
                file_contents := previous_file_contents_p^;
                fsp$convert_file_contents (file_contents, file_structure, converted_file_contents,
                      conversion_status);
              IFEND;
              IF (NOT conversion_status.normal OR (previous_file_contents_p = NIL)) AND
                    (split_file_structure <> file_structure) THEN
                bap$set_file_reference_abnormal (file, fse$file_structure_replaced, '',
                      current_file_structure_p^, warning_status);
                osp$append_status_parameter (osc$status_parameter_delimiter, split_file_structure,
                      warning_status);
              IFEND;
              IF ((file_structure = fsc$data) AND (sorted_attributes^ [attribute_index].file_contents =
                    fsc$unknown_contents)) OR ((split_file_contents = fsc$list) AND
                    (converted_file_contents = fsc$unknown_contents)) THEN
                store_split_file_structure := FALSE;
                previous_file_contents_p := NIL;
              IFEND;
            IFEND;
          IFEND;
        ELSE
          NEXT existing_str: [item^.name_length] IN cycle_description^.static_setfa_entries;
          IF existing_str = NIL THEN
            set_system_error_status ('FILE_CONTENTS', status);
            RETURN;
          IFEND;

        /determine_file_contents/
          BEGIN
            IF specified_file_structure_p <> NIL THEN
              file_contents := existing_str^;
              file_structure := specified_file_structure_p^;
              fsp$convert_file_contents (file_contents, file_structure, converted_file_contents,
                    conversion_status);
              IF (NOT conversion_status.normal) AND (existing_str^ <> fsc$unknown_contents) THEN
                get_current_file_structure (current_file_structure_p);
                IF current_file_structure_p <> NIL THEN
                  file_structure := current_file_structure_p^;
                  fsp$convert_file_contents (file_contents, file_structure, converted_file_contents,
                        conversion_status);
                  IF conversion_status.normal THEN
                    static_setfa_item^.name_length := 7;
                    NEXT str: [static_setfa_item^.name_length] IN new_setfa_label;
                    str^ (1, static_setfa_item^.name_length) := fsc$unknown_contents;
                    bap$set_file_reference_abnormal (file, fse$file_contents_replaced, '',
                          converted_file_contents, warning_status);
                    EXIT /determine_file_contents/;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
            static_setfa_item^.name_length := item^.name_length;
            NEXT str: [static_setfa_item^.name_length] IN new_setfa_label;
            str^ (1, static_setfa_item^.name_length) := existing_str^ (1, item^.name_length);
          END /determine_file_contents/;
        IFEND;
      = fmc$file_limit =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].file_limit;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      = fmc$file_organization =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.file_organization := sorted_attributes^ [attribute_index].file_organization;
        ELSE
          static_setfa_item^.file_organization := item^.file_organization;
        IFEND;
      = fmc$file_processor =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          put_name (sorted_attributes^ [attribute_index].file_processor);
        ELSE
          static_setfa_item^.name_length := item^.name_length;
          NEXT str: [static_setfa_item^.name_length] IN new_setfa_label;
          NEXT existing_str: [item^.name_length] IN cycle_description^.static_setfa_entries;
          IF existing_str = NIL THEN
            set_system_error_status ('FILE_PROCESSOR', status);
            RETURN;
          IFEND;
          str^ (1, static_setfa_item^.name_length) := existing_str^ (1, item^.name_length);
        IFEND;
      = fmc$file_structure =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF store_split_file_structure THEN
          put_name (split_file_structure);
          store_split_file_structure := FALSE;
          IF (specified_file_structure_p <> NIL) AND (specified_file_structure_p^ <> split_file_structure)
                THEN
            bap$set_file_reference_abnormal (file, fse$file_structure_discarded, '',
                  sorted_attributes^ [attribute_index].file_structure, warning_status);
          IFEND;
        ELSE
          IF entry_kind = fmc$setfa_entry THEN
            put_name (sorted_attributes^ [attribute_index].file_structure);
          ELSE
            NEXT existing_str: [item^.name_length] IN cycle_description^.static_setfa_entries;
            IF existing_str = NIL THEN
              set_system_error_status ('FILE_STRUCTURE', status);
              RETURN;
            IFEND;

          /determine_file_structure/
            BEGIN
              IF previous_file_contents_p <> NIL THEN { file_contents was specified }
                file_contents := previous_file_contents_p^;
                file_structure := existing_str^;
                fsp$convert_file_contents (file_contents, file_structure, converted_file_contents,
                      conversion_status);
                IF conversion_status.normal THEN
                  fsp$convert_file_contents (split_file_contents, file_structure, converted_file_contents,
                        conversion_status);
                  IF NOT conversion_status.normal THEN
                    static_setfa_item^.name_length := 7;
                    NEXT str: [static_setfa_item^.name_length] IN new_setfa_label;
                    str^ (1, static_setfa_item^.name_length) := fsc$unknown_contents;
                    EXIT /determine_file_structure/;
                  IFEND;
                IFEND;
              IFEND;
              static_setfa_item^.name_length := item^.name_length;
              NEXT str: [static_setfa_item^.name_length] IN new_setfa_label;
              str^ (1, static_setfa_item^.name_length) := existing_str^ (1, item^.name_length);
            END /determine_file_structure/;
          IFEND;
        IFEND;
      = fmc$forced_write =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.forced_write := sorted_attributes^ [attribute_index].forced_write;
        ELSE
          static_setfa_item^.forced_write := item^.forced_write;
        IFEND;
      = fmc$internal_code =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.internal_code := sorted_attributes^ [attribute_index].internal_code;
        ELSE
          static_setfa_item^.internal_code := item^.internal_code;
        IFEND;
      = fmc$label_type =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.label_type := sorted_attributes^ [attribute_index].label_type;
        ELSE
          static_setfa_item^.label_type := item^.label_type;
        IFEND;
      = fmc$line_number =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.line_number := sorted_attributes^ [attribute_index].line_number;
        ELSE
          static_setfa_item^.line_number := item^.line_number;
        IFEND;
      = fmc$max_block_length =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].max_block_length;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      = fmc$max_record_length =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].max_record_length;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      = fmc$min_block_length =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].min_block_length;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      = fmc$min_record_length =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].min_record_length;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      = fmc$padding_character =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.padding_character := sorted_attributes^ [attribute_index].padding_character;
        ELSE
          static_setfa_item^.padding_character := item^.padding_character;
        IFEND;
      = fmc$page_format =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.page_format := sorted_attributes^ [attribute_index].page_format;
        ELSE
          static_setfa_item^.page_format := item^.page_format;
        IFEND;
      = fmc$page_length =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].page_length;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      = fmc$page_width =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].page_width;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      = fmc$preset_value =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].preset_value;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      = fmc$record_type =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.record_type := sorted_attributes^ [attribute_index].record_type;
        ELSE
          static_setfa_item^.record_type := item^.record_type;
        IFEND;
      = fmc$statement_identifier =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.statement_identifier := sorted_attributes^ [attribute_index].
                statement_identifier;
        ELSE
          static_setfa_item^.statement_identifier := item^.statement_identifier;
        IFEND;
      = fmc$user_info =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        static_setfa_item^.user_info_present := TRUE;
        NEXT str: [#SIZE (amt$user_info)] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          str^ (1, #SIZE (amt$user_info)) := sorted_attributes^ [attribute_index].user_info;
        ELSE
          NEXT existing_str: [#SIZE (amt$user_info)] IN cycle_description^.static_setfa_entries;
          IF existing_str = NIL THEN
            set_system_error_status ('USER_INFO', status);
            RETURN;
          IFEND;
          str^ (1, #SIZE (amt$user_info)) := existing_str^ (1, #SIZE (amt$user_info));
        IFEND;
      = fmc$vertical_print_density =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].vertical_print_density;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      = fmc$average_record_length =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].average_record_length;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      = fmc$collate_table_name =
        IF entry_kind = fmc$setfa_entry THEN
          put_entry_point_reference (sorted_attributes^ [attribute_index].collate_table_name, osc$null_name);
        ELSE
          NEXT static_setfa_item: [key] IN new_setfa_label;
          static_setfa_item^.entry_point_name_length := item^.entry_point_name_length;
          NEXT str: [static_setfa_item^.entry_point_name_length] IN new_setfa_label;
          NEXT existing_str: [item^.entry_point_name_length] IN cycle_description^.static_setfa_entries;
          IF existing_str = NIL THEN
            set_system_error_status ('COLLATE_TABLE_NAME entry_point_name ', status);
            RETURN;
          IFEND;
          str^ (1, static_setfa_item^.entry_point_name_length) :=
                existing_str^ (1, item^.entry_point_name_length);
          static_setfa_item^.entry_point_path_length := item^.entry_point_path_length;
          IF static_setfa_item^.entry_point_path_length > 0 THEN
            NEXT str: [static_setfa_item^.entry_point_path_length] IN new_setfa_label;
            NEXT existing_str: [item^.entry_point_path_length] IN cycle_description^.static_setfa_entries;
            IF existing_str = NIL THEN
              set_system_error_status ('COLLATE_TABLE_NAME entry_point_path', status);
              RETURN;
            IFEND;
            str^ (1, static_setfa_item^.entry_point_path_length) :=
                  existing_str^ (1, item^.entry_point_path_length);
          IFEND;
        IFEND;
      = fmc$compression_procedure_name =
        IF entry_kind = fmc$setfa_entry THEN
          IF sorted_attributes^ [attribute_index].compression_procedure_name <> NIL THEN
            put_entry_point_reference (sorted_attributes^ [attribute_index].compression_procedure_name^.name,
                  sorted_attributes^ [attribute_index].compression_procedure_name^.object_library);
          IFEND;
        ELSE
          NEXT static_setfa_item: [key] IN new_setfa_label;
          static_setfa_item^.entry_point_name_length := item^.entry_point_name_length;
          NEXT str: [static_setfa_item^.entry_point_name_length] IN new_setfa_label;
          NEXT existing_str: [item^.entry_point_name_length] IN cycle_description^.static_setfa_entries;
          IF existing_str = NIL THEN
            set_system_error_status ('COMPRESSION_PROCEDURE_NAME entry_point_name', status);
            RETURN;
          IFEND;
          str^ (1, static_setfa_item^.entry_point_name_length) :=
                existing_str^ (1, item^.entry_point_name_length);
          static_setfa_item^.entry_point_path_length := item^.entry_point_path_length;
          IF static_setfa_item^.entry_point_path_length > 0 THEN
            NEXT str: [static_setfa_item^.entry_point_path_length] IN new_setfa_label;
            NEXT existing_str: [item^.entry_point_path_length] IN cycle_description^.static_setfa_entries;
            IF existing_str = NIL THEN
              set_system_error_status ('COMPRESSION_PROCEDURE_NAME entry_point_path', status);
              RETURN;
            IFEND;
            str^ (1, static_setfa_item^.entry_point_path_length) :=
                  existing_str^ (1, item^.entry_point_path_length);
          IFEND;
        IFEND;
      = fmc$data_padding =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.data_padding := sorted_attributes^ [attribute_index].data_padding;
        ELSE
          static_setfa_item^.data_padding := item^.data_padding;
        IFEND;
      = fmc$dynamic_home_block_space =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.dynamic_home_block_space := sorted_attributes^ [attribute_index].
                dynamic_home_block_space;
        ELSE
          static_setfa_item^.dynamic_home_block_space := item^.dynamic_home_block_space;
        IFEND;
      = fmc$embedded_key =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.embedded_key := sorted_attributes^ [attribute_index].embedded_key;
        ELSE
          static_setfa_item^.embedded_key := item^.embedded_key;
        IFEND;
      = fmc$estimated_record_count =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].estimated_record_count;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      = fmc$hashing_procedure_name =
        IF entry_kind = fmc$setfa_entry THEN
          IF sorted_attributes^ [attribute_index].hashing_procedure_name <> NIL THEN
            put_entry_point_reference (sorted_attributes^ [attribute_index].hashing_procedure_name^.name,
                  sorted_attributes^ [attribute_index].hashing_procedure_name^.object_library);
          IFEND;
        ELSE
          NEXT static_setfa_item: [key] IN new_setfa_label;
          static_setfa_item^.entry_point_name_length := item^.entry_point_name_length;
          NEXT str: [static_setfa_item^.entry_point_name_length] IN new_setfa_label;
          NEXT existing_str: [item^.entry_point_name_length] IN cycle_description^.static_setfa_entries;
          IF existing_str = NIL THEN
            set_system_error_status ('HASHING_PROCEDURE_NAME entry_point_name', status);
            RETURN;
          IFEND;
          str^ (1, static_setfa_item^.entry_point_name_length) :=
                existing_str^ (1, item^.entry_point_name_length);
          static_setfa_item^.entry_point_path_length := item^.entry_point_path_length;
          IF static_setfa_item^.entry_point_path_length > 0 THEN
            NEXT str: [static_setfa_item^.entry_point_path_length] IN new_setfa_label;
            NEXT existing_str: [item^.entry_point_path_length] IN cycle_description^.static_setfa_entries;
            IF existing_str = NIL THEN
              set_system_error_status ('HASHING_PROCEDURE_NAME entry_point_path', status);
              RETURN;
            IFEND;
            str^ (1, static_setfa_item^.entry_point_path_length) :=
                  existing_str^ (1, item^.entry_point_path_length);
          IFEND;
        IFEND;
      = fmc$index_levels =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].index_levels;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      = fmc$index_padding =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.index_padding := sorted_attributes^ [attribute_index].index_padding;
        ELSE
          static_setfa_item^.index_padding := item^.index_padding;
        IFEND;
      = fmc$initial_home_block_count =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].initial_home_block_count;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      = fmc$key_length =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].key_length;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      = fmc$key_position =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].key_position;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      = fmc$key_type =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.key_type := sorted_attributes^ [attribute_index].key_type;
        ELSE
          static_setfa_item^.key_type := item^.key_type;
        IFEND;
      = fmc$loading_factor =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.loading_factor := sorted_attributes^ [attribute_index].loading_factor;
        ELSE
          static_setfa_item^.loading_factor := item^.loading_factor;
        IFEND;
      = fmc$lock_expiration_time =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].lock_expiration_time;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      = fmc$logging_options =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.logging_options := sorted_attributes^ [attribute_index].logging_options;
        ELSE
          static_setfa_item^.logging_options := item^.logging_options;
        IFEND;
      = fmc$log_residence =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          IF sorted_attributes^ [attribute_index].log_residence <> NIL THEN
            #SCAN (space_selector, sorted_attributes^ [attribute_index].log_residence^, path_index,
                  ignore_found);
            static_setfa_item^.path_length := path_index - 1;
            NEXT str: [static_setfa_item^.path_length] IN new_setfa_label;
            str^ (1, static_setfa_item^.path_length) := sorted_attributes^ [attribute_index].log_residence^;
          IFEND;
        ELSE
          static_setfa_item^.path_length := item^.path_length;
          NEXT str: [static_setfa_item^.path_length] IN new_setfa_label;
          NEXT existing_str: [item^.path_length] IN cycle_description^.static_setfa_entries;
          IF existing_str = NIL THEN
            set_system_error_status ('LOG_RESIDENCE path', status);
            RETURN;
          IFEND;
          str^ (1, static_setfa_item^.path_length) := existing_str^ (1, item^.path_length);
        IFEND;
      = fmc$record_limit =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].record_limit;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      = fmc$records_per_block =
        NEXT static_setfa_item: [key] IN new_setfa_label;
        IF entry_kind = fmc$setfa_entry THEN
          static_setfa_item^.integer_value := sorted_attributes^ [attribute_index].records_per_block;
        ELSE
          static_setfa_item^.integer_value := item^.integer_value;
        IFEND;
      ELSE
        RETURN;
      CASEND;
      IF status.normal THEN
        setfa_header^.attribute_present [key] := TRUE;
        setfa_header^.highest_attribute_present := key;
        static_setfa_item^.source := amc$file_command;
      IFEND;

    PROCEND store_static_entry;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    warning_status.normal := TRUE;

    IF file_attributes <> NIL THEN
      fmp$evaluate_path (file, $bat$process_pt_work_list [bac$resolve_path, bac$resolve_to_catalog,
            bac$record_path, bac$create_cycle_description, bac$return_cycle_description],
            ignore_evaluated_file_reference, cycle_description, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    /process_setfa_command/
      BEGIN
        PUSH sorted_attributes: [1 .. UPPERBOUND (file_attributes^)];
        sorted_attributes^ := file_attributes^;
        process_attributes (cycle_description, sorted_attributes, setfa_label_size,
              ring_attributes_specified);
        IF (cycle_description^.attached_file AND cycle_description^.system_file_label.
              file_previously_opened AND (cycle_description^.device_class <> rmc$magnetic_tape_device)) OR
              ((setfa_label_size = 0) AND NOT ring_attributes_specified) THEN
          EXIT /process_setfa_command/;
        IFEND;

        sort_setfa_entries (sorted_attributes);

        store_split_file_structure := FALSE;

        IF cycle_description^.static_setfa_entries = NIL THEN
          setfa_label_size := setfa_label_size + #SIZE (fmt$static_label_header);
          PUSH new_setfa_label: [[REP setfa_label_size OF cell]];
          NEXT setfa_header IN new_setfa_label;
          setfa_header^ := fmv$static_label_header;
          setfa_header^.file_previously_opened := FALSE;
          attribute_index := LOWERBOUND (sorted_attributes^);
        ELSE
          setfa_label_size := setfa_label_size + #SIZE (cycle_description^.static_setfa_entries^);
          PUSH new_setfa_label: [[REP setfa_label_size OF cell]];
          NEXT setfa_header IN new_setfa_label;
          setfa_header^ := fmv$static_label_header;
          setfa_header^.file_previously_opened := FALSE;

          RESET cycle_description^.static_setfa_entries;
          NEXT header IN cycle_description^.static_setfa_entries;
          IF header = NIL THEN
            set_system_error_status ('HEADER', status);
            EXIT /process_setfa_command/;
          IFEND;

          previous_file_contents_p := NIL;
          attribute_index := 1;
          FOR label_index := LOWERBOUND (header^.attribute_present) TO header^.highest_attribute_present DO
            IF header^.attribute_present [label_index] THEN
              NEXT item: [label_index] IN cycle_description^.static_setfa_entries;
              IF item = NIL THEN
                set_system_error_status ('ITEM', status);
                EXIT /process_setfa_command/;
              IFEND;
              label_item_replaced := FALSE;
              WHILE (attribute_index <= UPPERBOUND (sorted_attributes^)) AND
                    (file_label_key [sorted_attributes^ [attribute_index].key] <= label_index) DO
                IF store_split_file_structure AND (specified_file_structure_p = NIL) AND
                      (file_label_key [sorted_attributes^ [attribute_index].key] > fmc$file_structure) THEN
                  store_static_entry (fmc$file_structure, fmc$setfa_entry, status);
                  IF NOT status.normal THEN
                    EXIT /process_setfa_command/;
                  IFEND;
                IFEND;
                store_static_entry (file_label_key [sorted_attributes^ [attribute_index].key],
                      fmc$setfa_entry, status);
                IF NOT status.normal THEN
                  EXIT /process_setfa_command/;
                IFEND;
                label_item_replaced := file_label_key [sorted_attributes^ [attribute_index].key] =
                      label_index;
                attribute_index := attribute_index + 1;
              WHILEND;

              IF store_split_file_structure AND (specified_file_structure_p = NIL) AND
                    (label_index > fmc$file_structure) THEN
                store_static_entry (fmc$file_structure, fmc$setfa_entry, status);
                IF NOT status.normal THEN
                  EXIT /process_setfa_command/;
                IFEND;
              IFEND;

              IF NOT label_item_replaced THEN
                store_static_entry (label_index, fmc$label_entry, status);
                IF NOT status.normal THEN
                  EXIT /process_setfa_command/;
                IFEND;
              IFEND;
            IFEND;
          FOREND;

        IFEND;

{ The variable label_index should be initialized to a value beyond the scope of the current valid
{ file_attribute keys so that the check for "key = label_index" in PUT_NAME and PUT_ENTRY_POINT_REFERENCE
{ in STORE_STATIC_ENTRY is always false.

        label_index := amc$max_attribute;
        WHILE (attribute_index <= UPPERBOUND (sorted_attributes^)) AND
              (file_label_key [sorted_attributes^ [attribute_index].key] < amc$max_attribute) DO
          IF store_split_file_structure AND (specified_file_structure_p = NIL) AND
                (file_label_key [sorted_attributes^ [attribute_index].key] > fmc$file_structure) THEN
            store_static_entry (fmc$file_structure, fmc$setfa_entry, status);
            IF NOT status.normal THEN
              EXIT /process_setfa_command/;
            IFEND;
          IFEND;
          store_static_entry (file_label_key [sorted_attributes^ [attribute_index].key],
                fmc$setfa_entry, status);
          IF NOT status.normal THEN
            EXIT /process_setfa_command/;
          IFEND;
          attribute_index := attribute_index + 1;
        WHILEND;

{ The following IF statement is necessary for the case where file_contents is the only attribute
{ specified or no attributes with keys greater than the file_structure key is specified.

        IF store_split_file_structure THEN
          store_static_entry (fmc$file_structure, fmc$setfa_entry, status);
          IF NOT status.normal THEN
            EXIT /process_setfa_command/;
          IFEND;
        IFEND;

        setfa_label_size := i#current_sequence_position (new_setfa_label);
        ALLOCATE cycle_description^.static_setfa_entries: [[REP setfa_label_size OF cell]] IN
              osv$job_pageable_heap^;
        RESET new_setfa_label;
        RESET cycle_description^.static_setfa_entries;
        i#move (new_setfa_label, cycle_description^.static_setfa_entries, setfa_label_size);

        IF status.normal AND NOT warning_status.normal THEN
          status := warning_status;
        IFEND;

      END /process_setfa_command/;
      fmp$unlock_path_table;
    IFEND; { file_attributes <> NIL }

  PROCEND fmp$file_command;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$get_setfa_dynamic_attrs', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$get_setfa_dynamic_attrs
    (    file: fst$file_reference;
     VAR attached_permanent_file: boolean;
     VAR attached_share_modes: fst$file_access_options;
     VAR setfa_specified: boolean;
     VAR dynamic_attributes: fst$setfa_attachment_options;
     VAR status: ost$status);

    CONST
      command_file_reference_allowed = TRUE;

    VAR
      cycle_description: ^fmt$cycle_description,
      evaluated_file_reference: fst$evaluated_file_reference,
      index: integer;

    status.normal := TRUE;
    attached_permanent_file := FALSE;
    attached_share_modes := $fst$file_access_options [];
    setfa_specified := FALSE;
    dynamic_attributes := default_dynamic_setfa_entries;

    fmp$evaluate_path (file, $bat$process_pt_work_list [bac$resolve_path, bac$resolve_to_catalog,
          bac$return_cycle_description], evaluated_file_reference, cycle_description, status);
    IF NOT status.normal THEN
      status.normal := TRUE;
      RETURN;
    IFEND;

    IF cycle_description^.attached_file AND (cycle_description^.device_class = rmc$mass_storage_device) AND
          cycle_description^.permanent_file THEN
      attached_permanent_file := TRUE;
      attached_share_modes := cycle_description^.attached_share_modes;
    IFEND;

    IF cycle_description^.dynamic_setfa_entries <> NIL THEN
      setfa_specified := TRUE;
      dynamic_attributes := cycle_description^.dynamic_setfa_entries^;
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$get_setfa_dynamic_attrs;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$merge_setfa_entries', EJECT ??

{ PURPOSE:
{   This procedure merges attributes that were specified on a SETFA command or
{   the bap$file_command program_interface, with the label of a file that has
{   not been previously opened.
{
{ DESIGN:
{   NEXT through the sequence containing the static attributes specified on
{   a SETFA and merge the values and sources into the file label.
{
{ NOTE:
{   This procedure assumes that it will be called only when
{   there are static_setfa_entries to be merged, implying that the
{   "static_setfa_entries" parameter should never be NIL.

  PROCEDURE [XDCL, #GATE] fmp$merge_setfa_entries
    (    static_setfa_entries: ^SEQ ( * );
         object_p: {input/output} ^fst$goi_object;
     VAR object_information_p: {input/output} ^SEQ ( * );
     VAR status: ost$status);

    VAR
      entry_point_path: ^string ( * <= amc$max_path_name_size),
      final_attribute: 0 .. amc$max_attribute,
      index: fmt$file_attribute_keys,
      item: ^fmt$static_label_item,
      label_header: ^fmt$static_label_header,
      label_size: integer,
      local_file_label: ^SEQ ( * ),
      local_setfa_entries: ^SEQ ( * ),
      max_label_size: integer,
      merged_label: ^SEQ ( * ),
      merged_label_header: ^fmt$static_label_header,
      merged_label_item: ^fmt$static_label_item,
      merged_label_str: ^string ( * <= amc$max_path_name_size),
      str: ^string ( * <= amc$max_path_name_size),
      setfa_header: ^fmt$static_label_header;

?? NEWTITLE := 'set_system_error_status', EJECT ??

    PROCEDURE set_system_error_status
      (    text: string ( * );
       VAR status: ost$status);

      VAR
        status_text: string (osc$max_string_size),
        text_length: integer;

      STRINGREP (status_text, text_length, 'Nexting of ', text,
            ' in SETFA_ENTRIES resulted in a NIL pointer in FMP$MERGE_SETFA_ENTRIES');
      osp$set_status_abnormal (amc$access_method_id, fme$system_error, status_text (1, text_length), status);

    PROCEND set_system_error_status;
?? OLDTITLE ??
?? NEWTITLE := 'set_damaged_attribute_status', EJECT ??

    PROCEDURE set_damaged_attribute_status
      (    text: string ( * );
       VAR status: ost$status);

      VAR
        status_text: string (osc$max_string_size),
        text_length: integer;

      STRINGREP (status_text, text_length, 'Nexting of ', text,
            ' in LABEL resulted in a NIL pointer in FMP$MERGE_SETFA_ENTRIES');
      osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
            status_text (1, text_length), status);

    PROCEND set_damaged_attribute_status;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    IF object_p <> NIL THEN
      IF object_p^.file_label = NIL THEN

{ It is assumed that this procedure would never be called for a temporary file
{ that has been previously opened, and that permanent files always have a label
{ if they have been opened.

        label_size := #SIZE (static_setfa_entries^);
        NEXT object_p^.file_label: [[REP label_size OF cell]] IN object_information_p;
        IF object_p^.file_label = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          RETURN;
        IFEND;
        i#move (static_setfa_entries, object_p^.file_label, label_size);
      ELSE
        local_file_label := object_p^.file_label;
        RESET local_file_label;
        NEXT label_header IN local_file_label;
        IF label_header = NIL THEN
          set_damaged_attribute_status ('LABEL_HEADER', status);
          RETURN;
        IFEND;
        IF label_header^.file_previously_opened THEN
          RETURN;
        IFEND;

        max_label_size := #SIZE (local_file_label^) + #SIZE (static_setfa_entries^) -
              #SIZE (fmt$static_label_header);
        PUSH merged_label: [[REP max_label_size OF cell]];
        RESET merged_label;
        NEXT merged_label_header IN merged_label;
        merged_label_header^ := fmv$static_label_header;
        merged_label_header^.file_previously_opened := FALSE;

        local_setfa_entries := static_setfa_entries;
        RESET local_setfa_entries;
        NEXT setfa_header IN local_setfa_entries;
        IF setfa_header = NIL THEN
          set_system_error_status ('HEADER', status);
          RETURN;
        IFEND;
        IF label_header^.highest_attribute_present <= setfa_header^.highest_attribute_present THEN
          final_attribute := setfa_header^.highest_attribute_present;
        ELSE
          final_attribute := label_header^.highest_attribute_present;
        IFEND;
        FOR index := fmc$average_record_length TO final_attribute DO
          CASE index OF
          = fmc$file_contents, fmc$file_processor, fmc$file_structure =
            IF label_header^.attribute_present [index] THEN
              NEXT item: [index] IN local_file_label;
              IF item = NIL THEN
                set_damaged_attribute_status ('NAME ITEM', status);
                RETURN;
              IFEND;

              NEXT str: [item^.name_length] IN local_file_label;
              IF str = NIL THEN
                set_damaged_attribute_status ('NAME string', status);
                RETURN;
              IFEND;
            IFEND;

            IF setfa_header^.attribute_present [index] THEN
              NEXT item: [index] IN local_setfa_entries;
              IF item = NIL THEN
                set_system_error_status ('NAME ITEM', status);
                RETURN;
              IFEND;
              NEXT merged_label_item: [index] IN merged_label;
              i#move (item, merged_label_item, #SIZE (merged_label_item^));
              NEXT str: [item^.name_length] IN local_setfa_entries;
              IF str = NIL THEN
                set_system_error_status ('NAME string', status);
                RETURN;
              IFEND;
              NEXT merged_label_str: [merged_label_item^.name_length] IN merged_label;
              merged_label_str^ := str^;
              merged_label_header^.attribute_present [index] := TRUE;
              merged_label_header^.highest_attribute_present := index;
            ELSEIF label_header^.attribute_present [index] THEN
              NEXT merged_label_item: [index] IN merged_label;
              i#move (item, merged_label_item, #SIZE (merged_label_item^));
              NEXT merged_label_str: [merged_label_item^.name_length] IN merged_label;
              merged_label_str^ := str^;
              merged_label_header^.attribute_present [index] := TRUE;
              merged_label_header^.highest_attribute_present := index;
            IFEND;

          = fmc$compression_procedure_name, fmc$hashing_procedure_name, fmc$file_access_procedure,
                fmc$collate_table_name =
            IF label_header^.attribute_present [index] THEN
              NEXT item: [index] IN local_file_label;
              IF item = NIL THEN
                set_damaged_attribute_status ('ENTRY_POINT ITEM', status);
                RETURN;
              IFEND;

              NEXT str: [item^.entry_point_name_length] IN local_file_label;
              IF str = NIL THEN
                set_damaged_attribute_status ('ENTRY_POINT NAME', status);
                RETURN;
              IFEND;
              IF item^.entry_point_path_length > 0 THEN
                NEXT entry_point_path: [item^.entry_point_path_length] IN local_file_label;
                IF entry_point_path = NIL THEN
                  set_damaged_attribute_status ('ENTRY_POINT PATH', status);
                  RETURN;
                IFEND;
              IFEND;
            IFEND;

            IF setfa_header^.attribute_present [index] THEN
              NEXT item: [index] IN local_setfa_entries;
              IF item = NIL THEN
                set_system_error_status ('ENTRY_POINT ITEM', status);
                RETURN;
              IFEND;
              NEXT merged_label_item: [index] IN merged_label;
              i#move (item, merged_label_item, #SIZE (merged_label_item^));
              NEXT str: [item^.entry_point_name_length] IN local_setfa_entries;
              IF str = NIL THEN
                set_system_error_status ('ENTRY_POINT NAME', status);
                RETURN;
              IFEND;
              NEXT merged_label_str: [merged_label_item^.entry_point_name_length] IN merged_label;
              merged_label_str^ := str^;
              IF merged_label_item^.entry_point_path_length > 0 THEN
                NEXT entry_point_path: [item^.entry_point_path_length] IN local_setfa_entries;
                IF entry_point_path = NIL THEN
                  set_system_error_status ('ENTRY_POINT PATH', status);
                  RETURN;
                IFEND;
                NEXT merged_label_str: [merged_label_item^.entry_point_path_length] IN merged_label;
                merged_label_str^ := entry_point_path^;
              IFEND;
              merged_label_header^.attribute_present [index] := TRUE;
              merged_label_header^.highest_attribute_present := index;
            ELSEIF label_header^.attribute_present [index] THEN
              NEXT merged_label_item: [index] IN merged_label;
              i#move (item, merged_label_item, #SIZE (merged_label_item^));
              NEXT merged_label_str: [merged_label_item^.entry_point_name_length] IN merged_label;
              merged_label_str^ := str^;
              IF merged_label_item^.entry_point_path_length > 0 THEN
                NEXT merged_label_str: [merged_label_item^.entry_point_path_length] IN merged_label;
                merged_label_str^ := entry_point_path^;
              IFEND;
              merged_label_header^.attribute_present [index] := TRUE;
              merged_label_header^.highest_attribute_present := index;
            IFEND;

          = fmc$user_info =
            IF label_header^.attribute_present [index] THEN
              NEXT item: [index] IN local_file_label;
              IF item = NIL THEN
                set_damaged_attribute_status ('USER_INFO ITEM', status);
                RETURN;
              IFEND;

              IF item^.user_info_present THEN
                NEXT str: [#SIZE (amt$user_info)] IN local_file_label;
                IF str = NIL THEN
                  set_damaged_attribute_status ('USER_INFO STRING', status);
                  RETURN;
                IFEND;
              IFEND;
            IFEND;

            IF setfa_header^.attribute_present [index] THEN
              NEXT item: [index] IN local_setfa_entries;
              IF item = NIL THEN
                set_system_error_status ('USER_INFO ITEM', status);
                RETURN;
              IFEND;
              NEXT merged_label_item: [index] IN merged_label;
              i#move (item, merged_label_item, #SIZE (merged_label_item^));
              IF item^.user_info_present THEN
                NEXT str: [#SIZE (amt$user_info)] IN local_setfa_entries;
                IF str = NIL THEN
                  set_system_error_status ('USER_INFO STRING', status);
                  RETURN;
                IFEND;
                NEXT merged_label_str: [#SIZE (amt$user_info)] IN merged_label;
                merged_label_str^ := str^;
              IFEND;
              merged_label_header^.attribute_present [index] := TRUE;
              merged_label_header^.highest_attribute_present := index;
            ELSEIF label_header^.attribute_present [index] THEN
              NEXT merged_label_item: [index] IN merged_label;
              i#move (item, merged_label_item, #SIZE (merged_label_item^));
              IF item^.user_info_present THEN
                NEXT merged_label_str: [#SIZE (amt$user_info)] IN merged_label;
                merged_label_str^ := str^;
              IFEND;
              merged_label_header^.attribute_present [index] := TRUE;
              merged_label_header^.highest_attribute_present := index;
            IFEND;

          = fmc$log_residence =
            IF label_header^.attribute_present [index] THEN
              NEXT item: [index] IN local_file_label;
              IF item = NIL THEN
                set_damaged_attribute_status ('LOG_RESIDENCE ITEM', status);
                RETURN;
              IFEND;

              NEXT str: [item^.path_length] IN local_file_label;
              IF str = NIL THEN
                set_damaged_attribute_status ('LOG_RESIDENCE STRING', status);
                RETURN;
              IFEND;
            IFEND;

            IF setfa_header^.attribute_present [index] THEN
              NEXT item: [index] IN local_setfa_entries;
              IF item = NIL THEN
                set_system_error_status ('LOG_RESIDENCE ITEM', status);
                RETURN;
              IFEND;
              NEXT merged_label_item: [index] IN merged_label;
              i#move (item, merged_label_item, #SIZE (merged_label_item^));
              NEXT str: [item^.path_length] IN local_setfa_entries;
              IF str = NIL THEN
                set_system_error_status ('LOG_RESIDENCE STRING', status);
                RETURN;
              IFEND;
              NEXT merged_label_str: [merged_label_item^.path_length] IN merged_label;
              merged_label_str^ := str^;
              merged_label_header^.attribute_present [index] := TRUE;
              merged_label_header^.highest_attribute_present := index;
            ELSEIF label_header^.attribute_present [index] THEN
              NEXT merged_label_item: [index] IN merged_label;
              i#move (item, merged_label_item, #SIZE (merged_label_item^));
              NEXT merged_label_str: [merged_label_item^.path_length] IN merged_label;
              merged_label_str^ := str^;
              merged_label_header^.attribute_present [index] := TRUE;
              merged_label_header^.highest_attribute_present := index;
            IFEND;

          ELSE
            IF label_header^.attribute_present [index] THEN
              NEXT item: [index] IN local_file_label;
              IF item = NIL THEN
                set_damaged_attribute_status ('ITEM', status);
                RETURN;
              IFEND;
            IFEND;
            IF setfa_header^.attribute_present [index] THEN
              NEXT item: [index] IN local_setfa_entries;
              IF item = NIL THEN
                set_system_error_status ('ITEM', status);
                RETURN;
              IFEND;
              NEXT merged_label_item: [index] IN merged_label;
              i#move (item, merged_label_item, #SIZE (merged_label_item^));
              merged_label_header^.attribute_present [index] := TRUE;
              merged_label_header^.highest_attribute_present := index;
            ELSEIF label_header^.attribute_present [index] THEN
              NEXT merged_label_item: [index] IN merged_label;
              i#move (item, merged_label_item, #SIZE (merged_label_item^));
              merged_label_header^.attribute_present [index] := TRUE;
              merged_label_header^.highest_attribute_present := index;
            IFEND;

          CASEND;
        FOREND;

        label_size := i#current_sequence_position (merged_label);
        NEXT object_p^.file_label: [[REP label_size OF cell]] IN object_information_p;
        IF object_p^.file_label = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          RETURN;
        IFEND;
        i#move (merged_label, object_p^.file_label, label_size);
      IFEND; { object_p^.file_label = NIL }
    IFEND; { object_p <> NIL }

  PROCEND fmp$merge_setfa_entries;
MODEND fmm$setfa_processing;
*DECK DECK=FMM$SL_REWIND_FILE_COMMAND EXPAND=TRUE
*copyc osd$default_pragmats

MODULE fmm$sl_rewind_file_command;

?? PUSH (LISTEXT := ON) ??
*copyc amd$operation_declarations
*copyc ame$device_class_validation
*copyc ame$lfn_program_actions
*copyc amt$local_file_name
*copyc bat$tape_descriptor
*copyc cle$ecc_expression_result
*copyc fme$file_management_errors
*copyc fst$attachment_options
*copyc fst$file_attachment_choices
*copyc fst$tape_attachment_information
*copyc oss$job_paged_literal
*copyc ost$status
*copyc ost$string

*copyc amp$set_local_name_abnormal
*copyc fmp$get_cycle_description
*copyc fmp$unlock_path_table
*copyc osp$append_status_parameter
*copyc osp$fetch_locked_variable
*copyc osp$set_status_abnormal
*copyc rmp$log_debug_message
?? POP ??

  PROCEDURE [XDCL, #GATE] fmp$sl_rewind_file_command (
        local_file_name: amt$local_file_name;
    VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      cycle_description: ^fmt$cycle_description,
      open_count: integer,
      p_tape_descriptor: ^bat$tape_descriptor;

    fmp$get_cycle_description (local_file_name, cycle_description, status);
    IF NOT status.normal THEN
      IF status.condition = fme$no_cycle_description THEN
        status.normal := TRUE;
      IFEND;
      RETURN;
    IFEND;

    /set_rewind_file_command/
    BEGIN
      IF cycle_description^.global_file_information <> NIL THEN
        osp$fetch_locked_variable (cycle_description^.
              global_file_information^.open_count, open_count);
        IF open_count <> 0 THEN
          amp$set_local_name_abnormal (local_file_name, ame$file_not_closed,
               amc$rewind_files_cmd, 'BAP$SL_REWIND_FILE_COMMAND', status);
          EXIT /set_rewind_file_command/;
        IFEND;

        IF (cycle_description^.global_file_information^.device_dependent_info.device_class =
             rmc$magnetic_tape_device) AND
             (cycle_description^.global_file_information^.device_dependent_info.tape_descriptor <> NIL)
             THEN
          RESET cycle_description^.global_file_information^.device_dependent_info.tape_descriptor;
          NEXT p_tape_descriptor IN cycle_description^.global_file_information^.device_dependent_info.
               tape_descriptor;

          rmp$log_debug_message ('FMM$SL_REWIND_FILE_COMMAND setting rewind_file_command to TRUE');
          p_tape_descriptor^.rewind_file_command := TRUE;
        IFEND;
      IFEND;

    END /set_rewind_file_command/;

    fmp$unlock_path_table;

  PROCEND fmp$sl_rewind_file_command;

MODEND fmm$sl_rewind_file_command;
*DECK DECK=FMM$STORE_FETCH_TAPE_ATTACHMENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := '  NOS/VE Store and Fetch Tape Attachment.' ??
MODULE fmm$store_fetch_tape_attachment;

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc bat$tape_descriptor
*copyc fst$attachment_options
*copyc fst$file_attachment_choices
*copyc fst$tape_attachment_information
*copyc ost$status
?? POP ??
*copyc osv$task_private_heap

?? NEWTITLE := 'fmp$store_tape_attachment', EJECT ??
  PROCEDURE [XDCL, #GATE] fmp$store_tape_attachment (
        tape_attachments: fst$attachment_options;
        tape_attachment_info_source: fst$tape_attach_info_source;
        tape_attachment_info: ^fst$tape_attachment_information;
    VAR status: ost$status);

    VAR
      index: integer;

    status.normal := TRUE;

    FOR index := LOWERBOUND (tape_attachments) TO UPPERBOUND (tape_attachments) DO
      IF (tape_attachments [index].selector = fsc$tape_attachment) THEN
        CASE tape_attachments [index].tape_attachment.selector OF

        = fsc$tape_block_type =
          tape_attachment_info^.block_type :=
               tape_attachments [index].tape_attachment.tape_block_type;
          tape_attachment_info^.block_type_source := tape_attachment_info_source;

        = fsc$tape_buffer_offset =
          tape_attachment_info^.buffer_offset :=
               tape_attachments [index].tape_attachment.tape_buffer_offset;
          tape_attachment_info^.buffer_offset_source := tape_attachment_info_source;

        = fsc$tape_character_conversion =
          tape_attachment_info^.character_conversion :=
               tape_attachments [index].tape_attachment.tape_character_conversion;
          tape_attachment_info^.character_conversion_source := tape_attachment_info_source;

        = fsc$tape_character_set =
          tape_attachment_info^.character_set :=
               tape_attachments [index].tape_attachment.tape_character_set;
          tape_attachment_info^.character_set_source := tape_attachment_info_source;

        = fsc$tape_creation_date =
          tape_attachment_info^.creation_date :=
               tape_attachments [index].tape_attachment.tape_creation_date;
          tape_attachment_info^.creation_date_source := tape_attachment_info_source;

        = fsc$tape_expiration_date =
          tape_attachment_info^.expiration_date :=
               tape_attachments [index].tape_attachment.tape_expiration_date;
          tape_attachment_info^.expiration_date_source := tape_attachment_info_source;

        = fsc$tape_file_accessibility =
          tape_attachment_info^.file_accessibility :=
               tape_attachments [index].tape_attachment.tape_file_accessibility;
          tape_attachment_info^.file_accessibility_source := tape_attachment_info_source;

        = fsc$tape_file_identifier =
          tape_attachment_info^.file_identifier :=
               tape_attachments [index].tape_attachment.tape_file_identifier;
          tape_attachment_info^.file_identifier_source := tape_attachment_info_source;

        = fsc$tape_file_sequence_number =
          tape_attachment_info^.file_sequence_number :=
               tape_attachments [index].tape_attachment.tape_file_sequence_number;
          tape_attachment_info^.file_sequence_number_source := tape_attachment_info_source;

        = fsc$tape_file_set_identifier =
          tape_attachment_info^.file_set_identifier :=
               tape_attachments [index].tape_attachment.tape_file_set_identifier;
          tape_attachment_info^.file_set_identifier_source := tape_attachment_info_source;

        = fsc$tape_file_set_position =
          tape_attachment_info^.file_set_position :=
               tape_attachments [index].tape_attachment.tape_file_set_position;
          tape_attachment_info^.file_set_position_source := tape_attachment_info_source;

        = fsc$tape_generation_number =
          tape_attachment_info^.generation_number :=
               tape_attachments [index].tape_attachment.tape_generation_number;
          tape_attachment_info^.generation_number_source := tape_attachment_info_source;

        = fsc$tape_generation_version_num =
          tape_attachment_info^.generation_version_number :=
               tape_attachments [index].tape_attachment.tape_generation_version_num;
          tape_attachment_info^.generation_version_num_source := tape_attachment_info_source;

        = fsc$tape_max_block_length =
          tape_attachment_info^.max_block_length :=
               tape_attachments [index].tape_attachment.tape_max_block_length;
          tape_attachment_info^.max_block_length_source := tape_attachment_info_source;

        = fsc$tape_max_record_length =
          tape_attachment_info^.max_record_length :=
               tape_attachments [index].tape_attachment.tape_max_record_length;
          tape_attachment_info^.max_record_length_source := tape_attachment_info_source;

        = fsc$tape_owner_identification =
          tape_attachment_info^.owner_identifier :=
               tape_attachments [index].tape_attachment.tape_owner_identification;
          tape_attachment_info^.owner_identifier_source := tape_attachment_info_source;

        = fsc$tape_padding_character =
          tape_attachment_info^.padding_character :=
               tape_attachments [index].tape_attachment.tape_padding_character;
          tape_attachment_info^.padding_character_source := tape_attachment_info_source;

        = fsc$tape_record_type =
          tape_attachment_info^.record_type :=
               tape_attachments [index].tape_attachment.tape_record_type;
          tape_attachment_info^.record_type_source := tape_attachment_info_source;

        = fsc$tape_removable_media_group =
          tape_attachment_info^.removable_media_group :=
               tape_attachments [index].tape_attachment.tape_removable_media_group;
          tape_attachment_info^.removable_media_group_source := tape_attachment_info_source;

        = fsc$tape_rewrite_labels =
          tape_attachment_info^.rewrite_labels :=
               tape_attachments [index].tape_attachment.tape_rewrite_labels;
          tape_attachment_info^.rewrite_labels_source := tape_attachment_info_source;

        = fsc$tape_volume_accessibility =
          tape_attachment_info^.volume_accessibility :=
               tape_attachments [index].tape_attachment.tape_volume_accessibility;
          tape_attachment_info^.volume_accessibility_source := tape_attachment_info_source;

        = fsc$tape_volume_initialization =
          tape_attachment_info^.volume_initialization := TRUE;
          tape_attachment_info^.tape_volume_initialization :=
                tape_attachments [index].tape_attachment.tape_volume_initialization^;
          IF tape_attachment_info^.tape_volume_initialization.blank_label_group <> NIL THEN
            ALLOCATE tape_attachment_info^.tape_volume_initialization.blank_label_group:
                  [[REP #SIZE (tape_attachments [index].tape_attachment.tape_volume_initialization^.
                  blank_label_group^) OF cell]] IN osv$task_private_heap^;
            tape_attachment_info^.tape_volume_initialization.blank_label_group^ := tape_attachments [index].
                  tape_attachment.tape_volume_initialization^.blank_label_group^;
          IFEND;

        = fsc$tape_null_attachment_option =
          ;

        ELSE
          ;

        CASEND;

      IFEND;
    FOREND;

  PROCEND fmp$store_tape_attachment;
?? OLDTITLE ??
?? NEWTITLE := 'fmp$fetch_tape_attachment', EJECT ??
  PROCEDURE [XDCL, #GATE] fmp$fetch_tape_attachment (
        tape_attachment_info: ^fst$tape_attachment_information;
    VAR tape_attachments: fst$tape_attachment_information;
    VAR status: ost$status);

    status.normal := TRUE;

    tape_attachments := tape_attachment_info^;

  PROCEND fmp$fetch_tape_attachment;
?? OLDTITLE ??
MODEND fmm$store_fetch_tape_attachment;
*DECK DECK=FMM$STORE_FETCH_TAPE_LABEL_ATTR EXPAND=TRUE
*copyc osd$default_pragmats

MODULE fmm$store_fetch_tape_label_attr;

*copyc ame$device_class_validation
*copyc ame$lfn_program_actions
*copyc ame$tape_program_actions
*copyc bat$tape_descriptor
*copyc cle$ecc_expression_result
*copyc fme$file_management_errors
*copyc fsc$local
*copyc fst$attachment_options
*copyc fst$file_attachment_choices
*copyc fst$tape_attachment_information
*copyc oss$job_paged_literal
*copyc ost$status
*copyc ost$string
*copyc fmp$fetch_tape_attachment
*copyc fmp$locate_cycle_description
*copyc fmp$store_tape_attachment
*copyc fmp$unlock_path_table
*copyc fsp$path_element
*copyc fsp$set_evaluated_file_abnormal
*copyc osp$append_status_parameter
*copyc osp$fetch_locked_variable
*copyc osp$set_status_abnormal
*copyc pmp$change_legible_date_format

  PROCEDURE [XDCL, #GATE] fmp$store_tape_label_attributes (
        evaluated_file_reference: fst$evaluated_file_reference;
        tape_attachments: fst$attachment_options;
        supplied_file_set_pos_fields: fst$supplied_file_set_positions;
        tape_attachment_info_source: fst$tape_attach_info_source;
    VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      local_evaluated_file_reference: fst$evaluated_file_reference,
      open_count: integer,
      p_tape_descriptor: ^bat$tape_descriptor,
      p_tape_attachment_info: ^fst$tape_attachment_information,
      path_table_locked: boolean;

    local_evaluated_file_reference := evaluated_file_reference;
    fmp$locate_cycle_description (local_evaluated_file_reference, cycle_description, status);

    path_table_locked := status.normal;
    IF NOT status.normal THEN
      IF status.condition = fme$no_cycle_description THEN
        cycle_description := NIL;
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    /store_fetch_tape_label_attr/
    BEGIN

      IF cycle_description <> NIL THEN
        IF cycle_description^.device_class <> rmc$magnetic_tape_device THEN
          fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_device_class,
               fmc$change_tape_label_attr_cmd, 'MASS_STORAGE/NULL/TERMINAL', status);
          EXIT /store_fetch_tape_label_attr/;
        IFEND;
      ELSE
        IF fsp$path_element (^evaluated_file_reference, 1)^ = fsc$local THEN
          fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_not_known,
               fmc$change_tape_label_attr_cmd, 'CHANGE_TAPE_LABEL_ATTRIBUTES', status);
          EXIT /store_fetch_tape_label_attr/;
        ELSE
          fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_attachment_required,
               fmc$change_tape_label_attr_cmd, 'CHANGE_TAPE_LABEL_ATTRIBUTES', status);
          EXIT /store_fetch_tape_label_attr/;
        IFEND;
      IFEND;

      IF cycle_description^.global_file_information <> NIL THEN
        osp$fetch_locked_variable (cycle_description^.
              global_file_information^.open_count, open_count);
        IF open_count <> 0 THEN
          fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_not_closed,
               fmc$change_tape_label_attr_cmd, 'CHANGE_TAPE_LABEL_ATTRIBUTES', status);
          EXIT /store_fetch_tape_label_attr/;
        IFEND;
        IF (cycle_description^.device_class = rmc$magnetic_tape_device) AND
              (cycle_description^.global_file_information^.device_dependent_info.tape_descriptor <> NIL) THEN
          RESET cycle_description^.global_file_information^.device_dependent_info.tape_descriptor;
          NEXT p_tape_descriptor IN cycle_description^.global_file_information^.device_dependent_info.
               tape_descriptor;
          IF (tape_attachment_info_source = fsc$tape_label_attr_command) OR
                (tape_attachment_info_source = fsc$tape_label_attr_default) THEN
            p_tape_attachment_info := ^p_tape_descriptor^.tape_label_attr_command_info;
          ELSE
            p_tape_attachment_info := ^p_tape_descriptor^.tape_attachment_information;
          IFEND;
          p_tape_attachment_info^.supplied_file_set_pos_fields :=
                p_tape_attachment_info^.supplied_file_set_pos_fields + supplied_file_set_pos_fields;
          fmp$store_tape_attachment (tape_attachments, tape_attachment_info_source, p_tape_attachment_info,
              status);
        IFEND;
      IFEND;

    END /store_fetch_tape_label_attr/;

    IF path_table_locked THEN
      fmp$unlock_path_table;
    IFEND;

  PROCEND fmp$store_tape_label_attributes;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$fetch_tape_label_attributes (
        evaluated_file_reference: fst$evaluated_file_reference;
    VAR tape_attachments: fst$tape_attachment_information;
    VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      index: integer,
      local_evaluated_file_reference: fst$evaluated_file_reference,
      p_tape_attachment_info: ^fst$tape_attachment_information,
      p_tape_descriptor: ^bat$tape_descriptor,
      path_table_locked: boolean;

    local_evaluated_file_reference := evaluated_file_reference;
    fmp$locate_cycle_description (local_evaluated_file_reference, cycle_description, status);

    path_table_locked := status.normal;
    IF NOT status.normal THEN
      IF status.condition = fme$no_cycle_description THEN
        cycle_description := NIL;
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    /fetch_tape_label_attributes/
    BEGIN
      IF cycle_description <> NIL THEN
        IF cycle_description^.device_class <> rmc$magnetic_tape_device THEN
          fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_device_class,
               fmc$display_tape_label_attr_cmd, 'MASS_STORAGE/NULL/TERMINAL', status);
          EXIT /fetch_tape_label_attributes/;
        IFEND;
      ELSE
        IF fsp$path_element (^evaluated_file_reference, 1)^ = fsc$local THEN
          fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_not_known,
               fmc$display_tape_label_attr_cmd, 'DISPLAY_TAPE_LABEL_ATTRIBUTES', status);
          EXIT /fetch_tape_label_attributes/;
        ELSE
          fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_attachment_required,
               fmc$display_tape_label_attr_cmd, 'DISPLAY_TAPE_LABEL_ATTRIBUTES', status);
          EXIT /fetch_tape_label_attributes/;
        IFEND;
      IFEND;

      IF (cycle_description^.global_file_information <> NIL) AND
            (cycle_description^.device_class = rmc$magnetic_tape_device) AND
            (cycle_description^.global_file_information^.device_dependent_info.tape_descriptor <> NIL) THEN
        RESET cycle_description^.global_file_information^.device_dependent_info.tape_descriptor;
        NEXT p_tape_descriptor IN cycle_description^.global_file_information^.device_dependent_info.
             tape_descriptor;
        p_tape_attachment_info := ^p_tape_descriptor^.tape_label_attr_command_info;
        fmp$fetch_tape_attachment (p_tape_attachment_info, tape_attachments, status);
      IFEND;

    END /fetch_tape_label_attributes/;

    IF path_table_locked THEN
      fmp$unlock_path_table;
    IFEND;

  PROCEND fmp$fetch_tape_label_attributes;

?? EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$fetch_tape_attachment_info (
        evaluated_file_reference: fst$evaluated_file_reference;
    VAR tape_attachments: fst$tape_attachment_information;
    VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      index: integer,
      local_evaluated_file_reference: fst$evaluated_file_reference,
      p_tape_descriptor: ^bat$tape_descriptor,
      p_tape_attachment_info: ^fst$tape_attachment_information,
      path_table_locked: boolean;

    local_evaluated_file_reference := evaluated_file_reference;
    fmp$locate_cycle_description (local_evaluated_file_reference, cycle_description, status);

    path_table_locked := status.normal;
    IF NOT status.normal THEN
      IF status.condition = fme$no_cycle_description THEN
        cycle_description := NIL;
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    /fetch_tape_attachment_info/
    BEGIN

      IF cycle_description <> NIL THEN
        IF cycle_description^.device_class <> rmc$magnetic_tape_device THEN
          fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_device_class,
               fmc$display_tape_label_attr_cmd, 'MASS_STORAGE/NULL/TERMINAL', status);
          EXIT /fetch_tape_attachment_info/;
        IFEND;
      ELSE
        IF fsp$path_element (^evaluated_file_reference, 1)^ = fsc$local THEN
          fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_not_known,
               fmc$display_tape_label_attr_cmd, 'DISPLAY_TAPE_LABEL_ATTRIBUTES', status);
          EXIT /fetch_tape_attachment_info/;
        ELSE
          fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_attachment_required,
               fmc$display_tape_label_attr_cmd, 'DISPLAY_TAPE_LABEL_ATTRIBUTES', status);
          EXIT /fetch_tape_attachment_info/;
        IFEND;
      IFEND;

      IF (cycle_description^.global_file_information <> NIL) AND
            (cycle_description^.device_class = rmc$magnetic_tape_device) AND
            (cycle_description^.global_file_information^.device_dependent_info.tape_descriptor <> NIL) THEN
        RESET cycle_description^.global_file_information^.device_dependent_info.tape_descriptor;
        NEXT p_tape_descriptor IN cycle_description^.global_file_information^.device_dependent_info.
             tape_descriptor;
        p_tape_attachment_info := ^p_tape_descriptor^.tape_attachment_information;
        fmp$fetch_tape_attachment (p_tape_attachment_info, tape_attachments, status);
      IFEND;

    END /fetch_tape_attachment_info/;

    IF path_table_locked THEN
      fmp$unlock_path_table;
    IFEND;

  PROCEND fmp$fetch_tape_attachment_info;

MODEND fmm$store_fetch_tape_label_attr;
*DECK DECK=FMM$TABLES EXPAND=TRUE
?? RIGHT := 110 ??
MODULE fmm$tables;
?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
?? POP ??

?? TITLE := 'NOS/VE :  File Management' ??
?? NEWTITLE := '  [XDCL] COMMON VARIABLE DECLARATIONS', EJECT ??
{}
{   This module contains static variables for basic access method routines.}
{}

  VAR
    {Selector for fmc$entry_free used for #SCAN }
    fmv$entry_free_selector: [XDCL, READ, #GATE, oss$job_paged_literal] packed array [0 .. 255] of boolean :=
          [REP 32 of FALSE, TRUE, REP 223 of FALSE];

  VAR
    {Selector for fmc$entry_assigned used for #SCAN }
    fmv$entry_assigned_selector: [XDCL, READ, #GATE, oss$job_paged_literal] packed array [0 .. 255] of
          boolean := [REP 65 of FALSE, TRUE, REP 190 of FALSE];

MODEND fmm$tables;

*DECK DECK=FMM$TAPE_RESOURCE_MGMT EXPAND=TRUE
*DECK DECK=FMM$VERIFY_ATTRIBUTE_LIMITS EXPAND=TRUE
*copyc osd$default_pragmats
MODULE fmm$verify_attribute_limits;

{
{ PURPOSE:
{    This module contains a procedure that verifies that the values of file
{ attributes defined as integer subranges and whose source is undefined, are
{ within the currently defined limits.
{
{ DESIGN:
{    The file label is searched for those attributes defined as integer
{ subranges and whose sources are undefined.  If their values are not within the
{ defined limits of their TYPEs the values are changed to the current default.
{
{        FMP$VERIFY_ATTRIBUTE_LIMITS (STATIC_LABEL, STATUS)
{
{ STATIC_LABEL: (input) This parameter specifies the pointer to the label
{        of the file whose attributes are to verified.
{
{ STATUS: (output) This parameter returns the request status.
{
?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc fmt$file_attribute_keys
*copyc fmt$file_label
*copyc fmt$static_label_header
*copyc fmt$static_label_item
*copyc fmv$system_file_attributes
*copyc osp$set_status_abnormal
?? POP ??

?? TITLE := '[XDCL] fmp$verify_attribute_limits', EJECT ??

  PROCEDURE [XDCL] fmp$verify_attribute_limits (static_label: ^SEQ ( * );
    VAR status: ost$status);

    VAR
      attribute_key: fmt$file_attribute_keys,
      label_header: ^fmt$static_label_header,
      p_static_label: ^SEQ ( * ),
      static_label_item: ^fmt$static_label_item,
      str: ^string ( * );

    p_static_label := static_label; {make a local copy of sequence pointer}
    RESET p_static_label;
    NEXT label_header IN p_static_label;

    FOR attribute_key := fmc$ring_attributes TO label_header^.
          highest_attribute_present DO
      IF label_header^.attribute_present [attribute_key] THEN
        CASE attribute_key OF
        = fmc$average_record_length =
          NEXT static_label_item: [fmc$average_record_length] IN
                p_static_label;
          IF static_label_item = NIL THEN
            osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              'average_record_length NIL in fmp$verify_attribute_limits', status);
            RETURN;
          IFEND;
          IF static_label_item^.source = amc$undefined_attribute THEN
            IF (static_label_item^.integer_value < LOWERVALUE
                  (amt$average_record_length)) OR (static_label_item^.
                  integer_value > UPPERVALUE (amt$average_record_length)) THEN
              static_label_item^.integer_value := fmv$system_file_attributes.
                    static_label.average_record_length;
            IFEND;
          IFEND;
        = fmc$key_length =
          NEXT static_label_item: [fmc$key_length] IN
                p_static_label;
          IF static_label_item = NIL THEN
            osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              'key_length NIL in fmp$verify_attribute_limits', status);
            RETURN;
          IFEND;
          IF static_label_item^.source = amc$undefined_attribute THEN
            IF (static_label_item^.integer_value < LOWERVALUE (amt$key_length))
                  OR (static_label_item^.integer_value > UPPERVALUE
                  (amt$key_length)) THEN
              static_label_item^.integer_value := fmv$system_file_attributes.
                    static_label.key_length;
            IFEND;
          IFEND;
        = fmc$line_number =
          NEXT static_label_item: [fmc$line_number] IN
                p_static_label;
          IF static_label_item = NIL THEN
            osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              'line_number NIL in fmp$verify_attribute_limits', status);
            RETURN;
          IFEND;
          IF static_label_item^.source = amc$undefined_attribute THEN
            IF (static_label_item^.line_number.length < LOWERVALUE
                  (amt$line_number_length)) OR (static_label_item^.
                  line_number.length > UPPERVALUE (amt$line_number_length)) THEN
              static_label_item^.line_number.length := fmv$system_file_attributes.
                    static_label.line_number.length;
            IFEND;
            IF (static_label_item^.line_number.location < LOWERVALUE
                  (amt$line_number_location)) OR (static_label_item^.
                  line_number.location > UPPERVALUE (amt$line_number_location)) THEN
              static_label_item^.line_number.location := fmv$system_file_attributes.
                    static_label.line_number.location;
            IFEND;
          IFEND;
        = fmc$record_limit =
          NEXT static_label_item: [fmc$record_limit] IN
                p_static_label;
          IF static_label_item = NIL THEN
            osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              'record_limit NIL in fmp$verify_attribute_limits', status);
            RETURN;
          IFEND;
          IF static_label_item^.source = amc$undefined_attribute THEN
            IF (static_label_item^.integer_value < LOWERVALUE (amt$record_limit))
                  OR (static_label_item^.integer_value > UPPERVALUE
                  (amt$record_limit)) THEN
              static_label_item^.integer_value := fmv$system_file_attributes.
                    static_label.record_limit;
            IFEND;
          IFEND;
        = fmc$records_per_block =
          NEXT static_label_item: [fmc$records_per_block] IN
                p_static_label;
          IF static_label_item = NIL THEN
            osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              'records_per_block NIL in fmp$verify_attribute_limits', status);
            RETURN;
          IFEND;
          IF static_label_item^.source = amc$undefined_attribute THEN
            IF (static_label_item^.integer_value < LOWERVALUE
                  (amt$records_per_block)) OR (static_label_item^.
                  integer_value > UPPERVALUE (amt$records_per_block)) THEN
              static_label_item^.integer_value := fmv$system_file_attributes.
                    static_label.records_per_block;
            IFEND;
          IFEND;
        = fmc$statement_identifier =
          NEXT static_label_item: [fmc$statement_identifier] IN
                p_static_label;
          IF static_label_item = NIL THEN
            osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              'statement_identifier NIL in fmp$verify_attribute_limits', status);
            RETURN;
          IFEND;
          IF static_label_item^.source = amc$undefined_attribute THEN
            IF (static_label_item^.statement_identifier.length < LOWERVALUE
                  (amt$statement_id_length)) OR (static_label_item^.
                  statement_identifier.length > UPPERVALUE
                  (amt$statement_id_length)) THEN
              static_label_item^.statement_identifier.length :=
                    fmv$system_file_attributes.static_label.statement_identifier.length;
            IFEND;
            IF (static_label_item^.statement_identifier.location < LOWERVALUE
                  (amt$statement_id_location)) OR (static_label_item^.
                  statement_identifier.location > UPPERVALUE
                  (amt$statement_id_location)) THEN
              static_label_item^.statement_identifier.location :=
                    fmv$system_file_attributes.static_label.statement_identifier.location;
            IFEND;
          IFEND;
        = fmc$collate_table_name, fmc$compression_procedure_name,
          fmc$file_access_procedure, fmc$hashing_procedure_name =
          NEXT static_label_item: [attribute_key] IN
                p_static_label;
          IF static_label_item = NIL THEN
            osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              'name NIL in fmp$verify_attribute_limits', status);
            RETURN;
          IFEND;
          NEXT str: [static_label_item^.entry_point_name_length] IN p_static_label;
          IF str = NIL THEN
            osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              'str NIL in fmp$verify_attribute_limits for entry_point_name', status);
            RETURN;
          IFEND;
          IF static_label_item^.entry_point_path_length > 0 THEN
            NEXT str: [static_label_item^.entry_point_path_length] IN p_static_label;
            IF str = NIL THEN
              osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                'str NIL in fmp$verify_attribute_limits for entry_point_path', status);
              RETURN;
            IFEND;
          IFEND;
        = fmc$file_contents, fmc$file_processor, fmc$file_structure =
          NEXT static_label_item: [attribute_key] IN
                p_static_label;
          IF static_label_item = NIL THEN
            osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              'entry point reference NIL in fmp$verify_attribute_limits', status);
            RETURN;
          IFEND;
          NEXT str: [static_label_item^.name_length] IN p_static_label;
          IF str = NIL THEN
            osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              'get_name str NIL in fmp$verify_attribute_limits', status);
            RETURN;
          IFEND;
        = fmc$log_residence =
          NEXT static_label_item: [fmc$log_residence] IN p_static_label;
          IF static_label_item = NIL THEN
            osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              'log_residence NIL in fmp$verify_attribute_limits', status);
            RETURN;
          IFEND;
          NEXT str: [static_label_item^.path_length] IN p_static_label;
          IF str = NIL THEN
            osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              'log_residence str NIL in fmp$verify_attribute_limits', status);
            RETURN;
          IFEND;
        = fmc$ring_attributes =
          ;
        = fmc$user_info =
          NEXT static_label_item: [fmc$user_info] IN p_static_label;
          IF static_label_item = NIL THEN
            osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              'user_info NIL in fmp$verify_attribute_limits', status);
            RETURN;
          IFEND;
          IF static_label_item^.user_info_present THEN
            NEXT str: [32] IN p_static_label;
          IFEND;
        ELSE
          NEXT static_label_item: [attribute_key] IN p_static_label;
          IF static_label_item = NIL THEN
            osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
                  'item NIL in fmp$verify_attribute_limits', status);
            RETURN;
          IFEND;
        CASEND;
      IFEND;
    FOREND;
  PROCEND fmp$verify_attribute_limits;
MODEND fmm$verify_attribute_limits;

*DECK DECK=FMP$ADD_TO_FILE_DESCRIPTION EXPAND=FALSE

{ COMMON DECK FMXATFD }

  PROCEDURE [XREF] fmp$add_to_file_description
    (    file_identifier: amt$file_identifier;
         file_attributes: amt$add_to_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$add_to_attributes
*copyc amt$file_identifier
*copyc bat$system_file_attributes
*copyc ost$status
?? POP ??
*DECK DECK=FMP$ADJUST_FILE_SET_POS_VALUES EXPAND=FALSE

  PROCEDURE [INLINE] fmp$adjust_file_set_pos_values
    (VAR tape_attachment: fst$tape_attachment_information);

?? PUSH (LISTEXT := ON) ??
    IF tape_attachment.file_set_position_source = fsc$tape_label_attr_command THEN
      CASE tape_attachment.file_set_position.position OF
      = fsc$tape_file_identifier_pos =
        IF fsc$fsp_file_identifier IN tape_attachment.supplied_file_set_pos_fields THEN
          IF tape_attachment.file_identifier_source = fsc$tape_label_attr_default THEN
            tape_attachment.file_identifier := tape_attachment.file_set_position.
                  file_identifier;
          IFEND;
        ELSE
          tape_attachment.file_set_position.file_identifier := tape_attachment.
                file_identifier;
        IFEND;
        IF fsc$fsp_generation_number IN tape_attachment.supplied_file_set_pos_fields THEN
          IF tape_attachment.generation_number_source = fsc$tape_label_attr_default THEN
            tape_attachment.generation_number := tape_attachment.file_set_position.
                  generation_number;
          IFEND;
        ELSE
          tape_attachment.file_set_position.generation_number := tape_attachment.
                generation_number;
        IFEND;
      = fsc$tape_file_sequence_pos =
        IF NOT (fsc$fsp_file_sequence_number IN tape_attachment.supplied_file_set_pos_fields) THEN
          tape_attachment.file_set_position.file_sequence_number := tape_attachment.
                file_sequence_number;
        IFEND;
      ELSE
      CASEND;
    IFEND;

  PROCEND fmp$adjust_file_set_pos_values;

*copyc fst$tape_attachment_information
?? POP ??
*DECK DECK=FMP$ATTACH_FILE EXPAND=FALSE

  PROCEDURE [XREF] fmp$attach_file
    (    local_file_name: amt$local_file_name;
         global_file_name: ost$binary_unique_name;
         internal_cycle_name: ost$binary_unique_name;
         sfid: dmt$system_file_id;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
         validation_ring: ost$valid_ring;
         file_space_limit_kind: sft$file_space_limit_kind;
         p_file_label: fmt$p_file_label;
         p_pf_attachment_info: ^fmt$pf_attachment_info;
         device_class: rmt$device_class;
         p_removable_media_req_info: {input} ^fmt$removable_media_req_info;
         p_volume_list: {input} ^rmt$volume_list;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$ring_validation_errors
*copyc amt$local_file_name
*copyc dmt$system_file_id
*copyc fme$file_management_errors
*copyc fmt$file_label
*copyc fmt$pf_attachment_info
*copyc fmt$removable_media_req_info
*copyc fst$evaluated_file_reference
*copyc osd$unique_name
*copyc osd$virtual_address
*copyc ost$status
*copyc rmt$device_class
*copyc rmt$volume_list
*copyc sft$file_space_limit_kind
?? POP ??
*DECK DECK=FMP$CATALOG_SET_FILE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] fmp$catalog_set_file_attributes
    (    cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$cycle_description
*copyc ost$status
?? POP ??
*DECK DECK=FMP$CATALOG_SYSTEM_FILE_LABEL EXPAND=FALSE

  PROCEDURE [XREF] fmp$catalog_system_file_label (system_file_label:
        ^fmt$system_file_label;
        job_routing_label: ^SEQ ( * );
        job_routing_label_length: jmt$system_label_info_length;
        apfid: pft$attached_permanent_file_id;
        required_permission: pft$permit_options;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$system_file_label
*copyc jmt$system_label_info_length
*copyc pfd$attached_permanent_file_id
*copyc pfd$permanent_file_attributes
*copyc ost$status
?? POP ??
*DECK DECK=FMP$CHANGE_DEFAULT_FILE_ATTRIBS EXPAND=FALSE

  PROCEDURE [XREF] fmp$change_default_file_attribs
    (    attributes: ^amt$file_attributes;
         new_retention: ^fst$retention;
         reset_system_defaults: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_attributes
*copyc fst$retention
*copyc ost$status
?? POP ??
*DECK DECK=FMP$CHANGE_FILE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] fmp$change_file_attributes
    (    file_attributes: amt$file_attributes;
         evaluated_file_reference: fst$evaluated_file_reference;
         execution_ring: ost$valid_ring;
     VAR open_changed_file: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_attributes
*copyc fst$evaluated_file_reference
*copyc osd$virtual_address
*copyc ost$status
?? POP ??

*DECK DECK=FMP$CHANGE_RECORDED_CYCLE_NUM EXPAND=FALSE

  PROCEDURE [XREF] fmp$change_recorded_cycle_num (
        evaluated_file_reference: fst$evaluated_file_reference;
        new_cycle: fst$cycle_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc fst$cycle_number
*copyc ost$status
*copyc fme$file_management_errors
?? POP ??
*DECK DECK=FMP$CHANGE_RECORDED_FILE_NAME EXPAND=FALSE

  PROCEDURE [XREF] fmp$change_recorded_file_name (
        evaluated_file_reference: fst$evaluated_file_reference;
        new_file_name: fst$path_element;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc fst$path_element
*copyc ost$status
*copyc fme$file_management_errors
?? POP ??
*DECK DECK=FMP$CLEANUP_OPEN EXPAND=FALSE

  PROCEDURE [XREF] fmp$cleanup_open
    (    path_handle: fmt$path_handle;
     VAR work_list: fmt$open_cleanup_work_list);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$open_cleanup_work_list
*copyc fmt$path_handle
?? POP ??

*DECK DECK=FMP$CLEAR_SWITCH_OFFER EXPAND=FALSE

  PROCEDURE [XREF] fmp$clear_switch_offer (
        file: fst$file_reference;
        switch_offer_complete: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$CLOSE_FILE EXPAND=FALSE

  PROCEDURE [XREF] fmp$close_file
    (    file_instance: ^bat$task_file_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc bat$task_file_table
*copyc ost$status
?? POP ??
*DECK DECK=FMP$COMPLETE_PF_OBJECT_INFO EXPAND=FALSE

  PROCEDURE [XREF] fmp$complete_pf_object_info
    (    evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
         password_selector: pft$password_selector;
         validation_ring: ost$valid_ring;
         p_object: {output^} ^fst$goi_object;
     VAR p_local_object_information: ^SEQ ( * );
     VAR all_protected_info_returned: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc fst$goi_information_request
*copyc fst$goi_object
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$password_selector
?? POP ??
*DECK DECK=FMP$CONVERT_STATUS EXPAND=FALSE

  PROCEDURE [XREF] fmp$convert_status (
        file: fst$file_reference;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$CREATE_CYCLE_DESCRIPTION EXPAND=FALSE

  PROCEDURE [XREF] fmp$create_cycle_description
    (    return_cycle_description: boolean;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR cycle_description_created: boolean;
     VAR cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$cycle_description
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=FMP$CREATE_NETWORK_FILE EXPAND=FALSE

  PROCEDURE [XREF] fmp$create_network_file (
        file: fst$file_reference;
        connection_id: nat$connection_id;
        connection_state: nat$connection_state;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc nat$connection_id
*copyc nat$connection_state
*copyc ost$status
?? POP ??
*DECK DECK=FMP$CREATE_RHFAM_FILE EXPAND=FALSE

  PROCEDURE [XREF] fmp$create_rhfam_file (
        file: fst$file_reference;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$DECREMENT_OPEN_COUNT EXPAND=FALSE

  PROCEDURE [XREF] fmp$decrement_open_count
    (    path_handle: fmt$path_handle);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_handle
?? POP ??
*DECK DECK=FMP$DELETE_PATH_DESCRIPTION EXPAND=FALSE

  PROCEDURE [XREF] fmp$delete_path_description
    (    evaluated_file_reference: fst$evaluated_file_reference;
         implicit_detach: boolean;
         return_permanent_file: boolean;
         detachment_options: ^fst$detachment_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$detachment_options
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=FMP$DETACH_ALL_TAPE_FILES EXPAND=FALSE

  PROCEDURE [XREF] fmp$detach_all_tape_files;

*DECK DECK=FMP$DISCONNECT_FOR_CLONE EXPAND=FALSE
  PROCEDURE [XREF] fmp$disconnect_for_clone
    (    file: fst$file_reference;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=FMP$END_NEW_OPEN_PROCESSING EXPAND=FALSE

  PROCEDURE [XREF] fmp$end_new_open_processing
    (    path_handle: fmt$path_handle;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_handle
*copyc ost$status
?? POP ??

*DECK DECK=FMP$EVALUATE_PATH EXPAND=FALSE

  PROCEDURE [XREF] fmp$evaluate_path
    (    file: fst$file_reference;
         process_pt_work_list: bat$process_pt_work_list;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc bat$process_pt_work_list
*copyc fmt$cycle_description
*copyc fst$evaluated_file_reference
*copyc fst$file_reference
*copyc ost$status
?? POP ??

*DECK DECK=FMP$EXPAND_FILE_LABEL EXPAND=FALSE

  PROCEDURE [XREF] fmp$expand_file_label (p_file_label: fmt$p_file_label;
        expand_label: boolean;
    VAR job_label: ^SEQ ( * );
    VAR job_label_size: jmt$system_label_info_length;
    VAR ring_attributes: amt$ring_attributes;
    VAR ring_attributes_source: amt$attribute_source;
    VAR file_previously_opened: boolean;
    VAR expanded_label: bat$static_label_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$file_label
*copyc jmt$system_label_info_length
*copyc bat$static_label_attributes
*copyc ost$status
?? POP ??
*DECK DECK=FMP$EXPAND_V1_LABEL EXPAND=FALSE

  PROCEDURE [XREF] fmp$expand_v1_label (v1_label: ^fmt$basic_file_label;
    VAR expanded_label: bat$static_label_attributes;
    VAR file_previously_opened: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc bat$static_label_attributes
*copyc fmt$basic_file_label
*copyc ost$status
?? POP ??

*DECK DECK=FMP$EXTRACT_DYNAMIC_SETFA_ATTRS EXPAND=FALSE

  PROCEDURE [INLINE] fmp$extract_dynamic_setfa_attrs
    (    dynamic_setfa_entries: ^fst$setfa_attachment_options;
     VAR dynamic_attributes: bat$dynamic_label_attributes);

?? PUSH (LISTEXT := ON) ??
    IF dynamic_setfa_entries^.access_modes_specified THEN
      #UNCHECKED_CONVERSION (dynamic_setfa_entries^.access_modes,
            dynamic_attributes.access_mode);
      dynamic_attributes.access_mode_source := amc$file_command;
    IFEND;
    IF dynamic_setfa_entries^.error_exit_name_specified THEN
      dynamic_attributes.error_exit_name := dynamic_setfa_entries^.error_exit_name;
      dynamic_attributes.error_exit_name_source := amc$file_command;
    IFEND;
    IF dynamic_setfa_entries^.error_limit_specified THEN
      dynamic_attributes.error_limit := dynamic_setfa_entries^.error_limit;
      dynamic_attributes.error_limit_source := amc$file_command;
    IFEND;
    IF dynamic_setfa_entries^.label_exit_name_specified THEN
      dynamic_attributes.label_exit_name := dynamic_setfa_entries^.label_exit_name;
      dynamic_attributes.label_exit_name_source := amc$file_command;
    IFEND;
    IF dynamic_setfa_entries^.message_control_specified THEN
      dynamic_attributes.message_control := dynamic_setfa_entries^.message_control;
      dynamic_attributes.message_control_source := amc$file_command;
    IFEND;
    IF dynamic_setfa_entries^.open_position_specified THEN
      dynamic_attributes.open_position := dynamic_setfa_entries^.open_position;
      dynamic_attributes.open_position_source := amc$file_command;
    IFEND;

  PROCEND fmp$extract_dynamic_setfa_attrs;

*copyc bat$dynamic_label_attributes
*copyc fst$setfa_attachment_options
?? POP ??

*DECK DECK=FMP$FETCH_SYSTEM_LABEL EXPAND=FALSE

{ COMMON DECK FMXFSL }

  PROCEDURE [XREF] fmp$fetch_system_label (local_file_name:
    amt$local_file_name;
    VAR label: SEQ ( * );
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc AMT$LOCAL_FILE_NAME
?? POP ??
*DECK DECK=FMP$FETCH_SYSTEM_LABEL_SIZE EXPAND=FALSE
{ COMMON DECK FMXFSLS}

  PROCEDURE [XREF] fmp$fetch_system_label_size (local_file_name:
    amt$local_file_name;
    VAR label_size: 0 .. 7fffffff(16);
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$FETCH_TAPE_ATTACHMENT EXPAND=FALSE

  PROCEDURE [XREF] fmp$fetch_tape_attachment (
        tape_attachment_info: ^fst$tape_attachment_information;
    VAR tape_attachments: fst$tape_attachment_information;
    VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc fst$tape_attachment_information
*copyc ost$status
?? POP ??
*DECK DECK=FMP$FETCH_TAPE_ATTACHMENT_INFO EXPAND=FALSE

  PROCEDURE [XREF] fmp$fetch_tape_attachment_info
    (    evaluated_file_reference: fst$evaluated_file_reference;
     VAR tape_attachments: fst$tape_attachment_information;
     VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc fst$evaluated_file_reference
*copyc fst$tape_attachment_information
?? POP ??
*DECK DECK=FMP$FETCH_TAPE_LABEL_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] fmp$fetch_tape_label_attributes
    (    evaluated_file_reference: fst$evaluated_file_reference;
     VAR tape_attachments: fst$tape_attachment_information;
     VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc fst$evaluated_file_reference
*copyc fst$tape_attachment_information
?? POP ??
*DECK DECK=FMP$FILE_COMMAND EXPAND=FALSE

{ COMMON DECK FMXFILC }

  PROCEDURE [XREF] fmp$file_command (file: fst$file_reference;
        file_attributes: ^amt$file_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc AMT$FILE_ATTRIBUTES
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$FILE_IS_OPEN EXPAND=FALSE
  { [XDCL, #GATE] is located in fmm$cycle_manager. }
  FUNCTION [XREF]  fmp$file_is_open (lfn: amt$local_file_name): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
?? POP ??
*DECK DECK=FMP$FREE_TERMINAL_REQUEST EXPAND=FALSE

  PROCEDURE [INLINE] fmp$free_terminal_request
    (VAR cycle_description: ^fmt$cycle_description);

    VAR
      next_terminal_command: ^bat$terminal_cmd_list,
      terminal_command: ^bat$terminal_cmd_list;

    terminal_command := cycle_description^.terminal_command;
    WHILE terminal_command <> NIL DO
      next_terminal_command := terminal_command^.next_cmd;
      FREE terminal_command IN osv$job_pageable_heap^;
      terminal_command := next_terminal_command;
    WHILEND;
    IF cycle_description^.terminal_request <> NIL THEN
      FREE cycle_description^.terminal_request IN osv$job_pageable_heap^;
    IFEND;

  PROCEND fmp$free_terminal_request;

?? PUSH (LISTEXT := ON) ??
*copyc fmt$cycle_description
*copyc osv$job_pageable_heap
?? POP ??
*DECK DECK=FMP$GET_$LOCAL_OBJECT_INFO EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_$local_object_info
    (    evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
         password_selector: pft$password_selector;
         validation_ring: ost$valid_ring;
         p_object_info: {output^} ^fst$goi_object_information;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc fst$goi_information_request
*copyc fst$goi_object_information
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$password_selector
?? POP ??
*DECK DECK=FMP$GET_ATTACHED_TAPE_INFO EXPAND=FALSE

  PROCEDURE [INLINE] fmp$get_attached_tape_info
    (    system_file_id: dmt$system_file_id;
     VAR volume_list_p: ^rmt$volume_list;
     VAR volume_number: amt$volume_number;
     VAR volume_overflow_allowed: boolean;
     VAR density: rmt$density;
     VAR removable_media_group: ost$name;
     VAR object_information_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      current_vsns: rmt$volume_descriptor,
      label_type: amt$label_type,
      number_of_volumes: amt$volume_number,
      requested_volume_attributes: iot$requested_volume_attributes,
      write_ring: rmt$write_ring;

    dmp$get_tape_volume_information (system_file_id, number_of_volumes, volume_number,
          current_vsns, density, write_ring, requested_volume_attributes, volume_overflow_allowed,
          label_type, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    removable_media_group := requested_volume_attributes.removable_media_group;
    NEXT volume_list_p: [1 .. number_of_volumes] IN object_information_p;
    IF volume_list_p = NIL THEN
      osp$set_status_condition (pfe$info_full, status);
      RETURN;
    IFEND;

    dmp$get_tape_volume_list (system_file_id, volume_list_p, status);

  PROCEND fmp$get_attached_tape_info;

*copyc amt$label_type
*copyc amt$volume_number
*copyc dmt$system_file_id
*copyc ost$name
*copyc ost$status
*copyc pfe$internal_error_conditions
*copyc rmt$density
*copyc rmt$volume_descriptor
*copyc rmt$volume_list
*copyc rmt$write_ring

*copyc dmp$get_tape_volume_information
*copyc dmp$get_tape_volume_list
*copyc osp$set_status_condition
?? POP ??
*DECK DECK=FMP$GET_ATTACHMENT_VALUES_IN_CD EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_attachment_values_in_cd (
        cycle_description: ^fmt$cycle_description;
    VAR attachment_values: fmt$attachment_values;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$cycle_description
*copyc fmt$attachment_values
*copyc ost$status
?? POP ??

*DECK DECK=FMP$GET_CD_INFO EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_cd_info
    (   evaluated_file_reference: fst$evaluated_file_reference;
        increment_open_count: boolean;
        lock_path_table: boolean;
    VAR open_cleanup_work_list: {i/o} fmt$open_cleanup_work_list;
    VAR static_label: bat$static_label_attributes;
    VAR dynamic_label: bat$dynamic_label_attributes;
    VAR descriptive_label: bat$descriptive_file_attributes;
    VAR global_file_information: bat$global_file_information;
    VAR local_file: boolean;
    VAR attached_file: boolean;
    VAR file_previously_opened: boolean;
    VAR device_assigned: boolean;
    VAR device_class: rmt$device_class;
    VAR cd_attachment_options: fmt$cd_attachment_options;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc bat$dynamic_label_attributes
*copyc bat$descriptive_file_attributes
*copyc bat$global_file_information
*copyc bat$static_label_attributes
*copyc fmt$cd_attachment_options
*copyc fmt$open_cleanup_work_list
*copyc fst$evaluated_file_reference
*copyc rmt$device_class
*copyc ost$status
?? POP ??




*DECK DECK=FMP$GET_CONNECTION_IDENTIFIER EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_connection_identifier (file: fst$file_reference;
    VAR connection_id: nat$connection_id;
    VAR switch_offer_pending: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc nat$connection_id
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$GET_CONNECT_TIME_INTERVAL EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_connect_time_interval
    (    file: fst$file_reference;
     VAR connect_time: ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc osd$integer_limits
*copyc ost$status
?? POP ??
*DECK DECK=FMP$GET_CYCLE_DESCRIPTION EXPAND=FALSE

  PROCEDURE [INLINE] fmp$get_cycle_description
    (    file: fst$file_reference;
     VAR cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      evaluated_file_reference: fst$evaluated_file_reference;

    status.normal := TRUE;
    cycle_description := NIL;

    fmp$evaluate_path (file, $bat$process_pt_work_list [bac$resolve_path,
          bac$resolve_to_catalog, bac$return_cycle_description],
          evaluated_file_reference, cycle_description, status);

  PROCEND fmp$get_cycle_description;
*copyc fmp$evaluate_path
?? POP ??

*DECK DECK=FMP$GET_DEVICE_CLASS EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_device_class
    (    path_handle: fmt$path_handle;
     VAR device_assigned: boolean;
     VAR device_class: rmt$device_class;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_handle
*copyc ost$status
*copyc rmt$device_class
?? POP ??
*DECK DECK=FMP$GET_DEVICE_CLASS_AND_SFID EXPAND=FALSE

{ This routine was created specifically for fmp$get_files_volume_info

  PROCEDURE [XREF] fmp$get_device_class_and_sfid
    (    file: fst$file_reference;
     VAR device_class: rmt$device_class;
     VAR sfid: dmt$system_file_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc fst$file_reference
*copyc ost$status
*copyc rmt$device_class
?? POP ??
*DECK DECK=FMP$GET_FILES_VOLUME_INFO EXPAND=FALSE
  PROCEDURE [XREF] fmp$get_files_volume_info (file: fst$file_reference;
    VAR volume_information: fmt$volume_information;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc fmd$volume_info
*copyc ost$status
?? POP ??
*DECK DECK=FMP$GET_GLOBAL_FILE_INFORMATION EXPAND=FALSE
  PROCEDURE [XREF] fmp$get_global_file_information
    (    evaluated_file_reference: fst$evaluated_file_reference;
     VAR global_file_information: bat$global_file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc bat$global_file_information
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=FMP$GET_JFT_ENTRY_LIST EXPAND=FALSE
  PROCEDURE [XREF] fmp$get_jft_entry_list (VAR p_info: fmt$p_info;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc fmd$info
*copyc ost$status
?? POP ??
*DECK DECK=FMP$GET_JL_POINTER2 EXPAND=FALSE
{ COMMON DECK FMXGJP }

  PROCEDURE [XREF] fmp$get_jl_pointer (file: fst$file_reference;
        append: boolean;
    VAR jl_pointer: ^SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$GET_LABEL_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_label_attributes (system_file_label:
    ^fmt$system_file_label;
    VAR static_label_attributes: bat$static_label_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc FMT$SYSTEM_FILE_LABEL
*copyc BAT$STATIC_LABEL_ATTRIBUTES
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$GET_LABEL_HEADER_INFO EXPAND=FALSE

  PROCEDURE [INLINE] fmp$get_label_header_info
    (    system_file_label_p: {input^} ^fmt$system_file_label;
     VAR ring_attributes: amt$ring_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      static_label_p: ^SEQ ( * ),
      static_label_header_p: ^fmt$static_label_header;

    IF system_file_label_p^.static_label <> NIL THEN
      static_label_p := system_file_label_p^.static_label;
      RESET static_label_p;
      NEXT static_label_header_p IN static_label_p;
      IF static_label_header_p^.unique_character <> fmc$unique_label_id THEN
        osp$set_status_abnormal (amc$access_method_id,
              ame$damaged_file_attributes, ('Invalid static file label' CAT
              'detected in fmp$get_label_header_info.'), status);
        RETURN;
      IFEND;
      IF static_label_header_p^.file_previously_opened THEN
        ring_attributes := static_label_header_p^.ring_attributes;
        RETURN;
      IFEND;
    IFEND;

    ring_attributes := fmv$system_file_attributes.static_label.ring_attributes;
    status.normal := TRUE;
  PROCEND fmp$get_label_header_info;

*copyc ame$attribute_validation_errors
*copyc amt$ring_attributes
*copyc fmc$unique_label_id
*copyc fmt$static_label_header
*copyc fmt$system_file_label
*copyc fmv$system_file_attributes
*copyc osp$set_status_abnormal
*copyc ost$status
?? POP ??
*DECK DECK=FMP$GET_LAST_ANSI_FILE_ACCESS EXPAND=FALSE
*DECK DECK=FMP$GET_LFN_LIST EXPAND=FALSE
PROCEDURE [XREF] fmp$get_lfn_list (p_info: fmt$p_info;
 file_selection_criteria: fmt$lfn_selection_criteria;
 VAR status: ost$status);
*DECK DECK=FMP$GET_LIST_OF_$LOCAL_FILES EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_list_of_$local_files
    (VAR info: pft$p_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
?? POP ??
*DECK DECK=FMP$GET_LIST_OF_CONNECTED_FILES EXPAND=FALSE

  PROCEDURE [INLINE] fmp$get_list_of_connected_files
    (    subject_path_handle_name: fst$path_handle_name;
     VAR target_files: ^fst$target_file_list;
     VAR object_information_p: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??

    VAR
      active_target_index: ost$non_negative_integers,
      active_targets_p: ^fst$target_file_list,
      connected_file: ^clt$connected_file_subject,
      file_reference_size: fst$path_size,
      path_handle: clt$path_handle,
      status: ost$status,
      target_index: ost$positive_integers;

    target_files := NIL;

    clp$find_connected_file (subject_path_handle_name, connected_file);

    IF (connected_file <> NIL) AND (connected_file^.targets <> NIL) THEN
      active_target_index := 0;
      PUSH active_targets_p: [1 .. UPPERBOUND (connected_file^.targets^)];
      FOR target_index := 1 TO UPPERBOUND (connected_file^.targets^) DO
        IF connected_file^.targets^ [target_index].connection_active THEN
          active_target_index := active_target_index + 1;
          clp$check_name_for_path_handle (connected_file^.targets^ [target_index].path_handle_name,
                path_handle);
          fmp$get_path_string (path_handle.regular_handle, {lock_path_table} FALSE,
                active_targets_p^ [active_target_index], file_reference_size, status);
          IF status.normal THEN
            IF connected_file^.targets^ [target_index].open_position.specified THEN
              active_targets_p^ [active_target_index] (file_reference_size + 1, 1) := '.';
              active_targets_p^ [active_target_index] (file_reference_size + 2, *) :=
                    clv$open_positions [connected_file^.targets^ [target_index].open_position.value];
            IFEND;
          IFEND;
        IFEND;
      FOREND;

      IF active_target_index > 0 THEN
        NEXT target_files: [1 .. active_target_index] IN object_information_p;
        IF target_files <> NIL THEN
          i#move (active_targets_p, target_files, #SIZE (target_files^));
        IFEND;
      IFEND;
    IFEND;

  PROCEND fmp$get_list_of_connected_files;

*copyc fst$file_reference
*copyc fst$path_size
*copyc fst$target_file_list
*copyc osd$integer_limits

*copyc clp$check_name_for_path_handle
*copyc clp$find_connected_file
*copyc fmp$get_path_string
*copyc i#move

*copyc clv$open_positions
?? POP ??
*DECK DECK=FMP$GET_NEXT_ANSI_FILE_POSITION EXPAND=FALSE
*DECK DECK=FMP$GET_OPEN_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_open_information (file_identifier:
    amt$file_identifier;
        attachment_information: ^SEQ ( * );
        catalog_information: ^SEQ ( * );
        cycle_attribute_sources: ^SEQ ( * );
        cycle_attribute_values: ^SEQ ( * );
        instance_information: ^SEQ ( * );
        resolved_file_reference: ^SEQ ( * );
        user_defined_attributes: ^SEQ ( * );
    VAR user_defined_attribute_size: ost$non_negative_integers;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc osd$integer_limits
*copyc ost$status
?? POP ??
*DECK DECK=FMP$GET_PATH_ELEMENTS EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_path_elements
    (    path_handle: fmt$path_handle;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_handle
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=FMP$GET_PATH_HANDLE EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_path_handle (
        return_path_elements_for_alias: boolean;
    VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
    VAR found: boolean;
    VAR path_handle: fmt$path_handle;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc fmt$path_handle
*copyc ost$status
?? POP ??

*DECK DECK=FMP$GET_PATH_STRING EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_path_string
    (    path_handle: fmt$path_handle;
         lock_path_table: boolean;
     VAR path: fst$path;
     VAR path_size: fst$path_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_handle
*copyc fst$path
*copyc fst$path_size
*copyc ost$status
?? POP ??
*DECK DECK=FMP$GET_PATH_TABLE_CYCLE_INFO EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_path_table_cycle_info (
        inhibit_lock_pt: boolean;
    VAR fst$evaluated_file_reference: {i/o} fst$evaluated_file_reference;
    VAR cycle_info: fmt$path_table_cycle_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc fmt$path_table_cycle_info
*copyc ost$status
?? POP ??
*DECK DECK=FMP$GET_RESOLVED_FILE_REFERENCE EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_resolved_file_reference
    (VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR resolved_file_reference: fst$resolved_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc fst$resolved_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=FMP$GET_SELECTED_LFNS EXPAND=FALSE
  PROCEDURE [XREF] fmp$get_selected_lfns (selection_criteria:
    amt$selection_criteria;
    VAR p_info: fmt$p_info;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc fmd$info
*copyc amt$display_lnt_options
*copyc ost$status
?? POP ??
*DECK DECK=FMP$GET_SETFA_DYNAMIC_ATTRS EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_setfa_dynamic_attrs
    (    file: fst$file_reference;
     VAR attached_permanent_file: boolean;
     VAR attached_share_modes: fst$file_access_options;
     VAR setfa_specified: boolean;
     VAR dynamic_attributes: fst$setfa_attachment_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$setfa_attachment_options
*copyc fst$file_access_options
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=FMP$GET_SETFA_VALUES_FOR_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_setfa_values_for_object
    (    evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
         validation_ring: ost$valid_ring;
         p_object: {output^} ^fst$goi_object;
     VAR p_object_information: ^SEQ ( * );
     VAR setfa_found: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc fst$goi_information_request
*copyc fst$goi_object
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=FMP$GET_SYSTEM_FILE_ID EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_system_file_id (file: fst$file_reference;
    VAR sfid: dmt$system_file_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=FMP$GET_TAPE_LABEL_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_tape_label_attributes
    (    evaluated_file_reference: fst$evaluated_file_reference;
         source: fst$tape_attribute_source;
         rma_or_ring_privileged: boolean;
     VAR attributes {input, output} : fst$attachment_options;
     VAR returned_attributes: fst$tla_returned_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$attachment_options
*copyc fst$evaluated_file_reference
*copyc fst$tape_attribute_source
*copyc fst$tla_returned_attributes
?? POP ??
*DECK DECK=FMP$GET_TAPE_LABEL_CMD_ATTRIB EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_tape_label_cmd_attrib
    (    evaluated_file_reference: fst$evaluated_file_reference;
         rma_or_ring_privileged: boolean;
     VAR attributes {input, output} : fst$attachment_options;
     VAR returned_attributes: fst$tla_returned_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$attachment_options
*copyc fst$evaluated_file_reference
*copyc fst$tla_returned_attributes
?? POP ??
*DECK DECK=FMP$GET_TERMINAL_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] fmp$get_terminal_attributes (file: fst$file_reference;
    VAR terminal_attributes: ift$get_connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ift$get_connection_attributes
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$INITIALIZE_PATH_TABLE EXPAND=FALSE

  PROCEDURE [XREF] fmp$initialize_path_table;
*DECK DECK=FMP$IS_FILE_ATTACHED EXPAND=FALSE

  PROCEDURE [XREF] fmp$is_file_attached (path_handle:
        fmt$path_handle;
    VAR attached: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_handle
*copyc ost$status
?? POP ??
*DECK DECK=FMP$IS_FILE_REGISTERED EXPAND=FALSE

  PROCEDURE [XREF] fmp$is_file_registered (path_handle:
        fmt$path_handle;
    VAR registered: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_handle
*copyc ost$status
?? POP ??
*DECK DECK=FMP$JOB_EXIT EXPAND=FALSE

{COMMON DECK FMP$JOB_EXIT}

  PROCEDURE [XREF] fmp$job_exit;
*DECK DECK=FMP$LN_GET_LABEL_ATTRIBUTES EXPAND=FALSE

{ COMMON DECK FMXGLA }

  PROCEDURE [XREF] fmp$ln_get_label_attributes (local_file_name:
    amt$local_file_name;
    VAR attributes: bat$system_file_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc BAT$SYSTEM_FILE_ATTRIBUTES
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$LN_OPEN_CHAPTER EXPAND=FALSE

{ COMMON DECK FMXLNOC }

  PROCEDURE [XREF] fmp$ln_open_chapter (local_file_name: amt$local_file_name;
        chapter_number: dmt$chapter_number;
        validation_ring: ost$valid_ring;
        segment_attributes: ^array [ * ] OF mmt$attribute_descriptor;
        pointer_kind: mmt$segment_pointer_kind;
    VAR segment_pointer: mmt$segment_pointer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc DMT$CHAPTER_NUMBER
*copyc OSD$VIRTUAL_ADDRESS
*copyc MMT$ATTRIBUTE_KEYWORD
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$LN_RENAME EXPAND=FALSE

{ COMMON DECK FMXLNRN }

  PROCEDURE [XREF] fmp$ln_rename (old_file_name: amt$local_file_name;
        new_file_name: amt$local_file_name;
        validation_ring: ost$valid_ring;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$LOCATE_CD_VIA_PATH_HANDLE EXPAND=FALSE

  PROCEDURE [XREF] fmp$locate_cd_via_path_handle
    (    path_handle: fmt$path_handle;
         lock_path_table: boolean;
     VAR cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_handle
*copyc fmt$cycle_description
*copyc ost$status
?? POP ??
*DECK DECK=FMP$LOCATE_CYCLE_DESCRIPTION EXPAND=FALSE

  PROCEDURE [XREF] fmp$locate_cycle_description
    (VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$cycle_description
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??

*DECK DECK=FMP$LOCATE_PDE_VIA_PATH_HANDLE EXPAND=FALSE

  PROCEDURE [INLINE] fmp$locate_pde_via_path_handle (path_handle:
        fmt$path_handle;
    VAR pde: ^fmt$path_description_entry;
    VAR status: ost$status);

    { PURPOSE: This procedure attempts to validate a path_handle and
    {          return a pointer to its path_description_entry.

    IF (path_handle.segment_offset > fmv$highest_pdu_offset)
          OR (path_handle.segment_offset < 0)
          OR (path_handle.assignment_counter > fmv$pde_assignment_counter)
          OR (path_handle.assignment_counter <= 0) THEN
      osp$set_status_condition (fme$invalid_path_handle, status);
      pde := NIL;
      RETURN;
    IFEND;

    pde := #address (#ring(fmv$initial_pdu_pointer),
      #segment(fmv$initial_pdu_pointer),
      path_handle.segment_offset);

    { Validate entry_assignment pointer before dereferencing. }
    IF (pde^.unique_identifier <> fmc$pde_unique_identifier)
       OR (#ring(pde^.entry_assignment) <> #ring(fmv$initial_pdu_pointer))
       OR (#segment(pde^.entry_assignment) <>
       #segment(fmv$initial_pdu_pointer)) THEN
      osp$set_status_condition (fme$invalid_path_handle, status);
      pde := NIL;
      RETURN;
    IFEND;

    IF (pde^.entry_assignment_counter <> path_handle.assignment_counter)
         OR (pde^.entry_assignment^ <> fmc$entry_assigned) THEN
      osp$set_status_condition (fme$obsolete_path_handle, status);
      pde := NIL;
      RETURN;
    IFEND;

  PROCEND fmp$locate_pde_via_path_handle;

?? PUSH (LISTEXT := ON) ??
*copyc fmc$entry_assigned
*copyc fmc$pde_unique_identifier
*copyc fme$file_management_errors
*copyc fmt$path_description_entry
*copyc fmt$path_handle
*copyc osp$set_status_condition
*copyc ost$status
?? POP ??

*DECK DECK=FMP$LOCK_PATH_TABLE EXPAND=FALSE

  PROCEDURE [INLINE] fmp$lock_path_table
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
    VAR
      lock_status: ost$signature_lock_status;

    status.normal := TRUE;

    osp$test_signature_lock (fmv$path_table_lock, lock_status, status);
    IF lock_status = osc$sls_locked_by_current_task THEN
      osp$set_status_condition (fme$pt_locked_by_current_task, status);
    ELSE
      osp$set_job_signature_lock (fmv$path_table_lock);
    IFEND;

  PROCEND fmp$lock_path_table;

*copyc fme$file_management_errors
*copyc fmv$path_table_lock
*copyc osp$set_job_signature_lock
*copyc osp$set_status_condition
*copyc osp$test_signature_lock
?? POP ??

*DECK DECK=FMP$LOGICALLY_POSITION_TAPE EXPAND=FALSE

{ COMMON DECK FMXLPT }

  PROCEDURE [XREF] fmp$logically_position_tape (local_file_name:
    amt$local_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$MERGE_FILE_CMD_LIST EXPAND=FALSE
*DECK DECK=FMP$MERGE_SETFA_ENTRIES EXPAND=FALSE

  PROCEDURE [XREF] fmp$merge_setfa_entries
    (    static_setfa_entries: ^SEQ ( * );
         object_p: {input/output} ^fst$goi_object;
     VAR object_information_p: {input/output} ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$cycle_description
*copyc fst$goi_object
*copyc ost$status
?? POP ??
*DECK DECK=FMP$OBTAIN_ELEMENT_NAME EXPAND=FALSE

  PROCEDURE [XREF] fmp$obtain_element_name (
        lfn: amt$local_file_name;
    VAR element_name: cmt$element_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=FMP$OPEN_NETWORK_FILE EXPAND=FALSE

  PROCEDURE [XREF] fmp$open_network_file (
        file: fst$file_reference;
        file_identifier: amt$file_identifier;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc amt$file_identifier
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=FMP$PROCESS_DISCONNECT EXPAND=FALSE

  PROCEDURE [XREF] fmp$process_disconnect
    (    file: fst$file_reference;
         connection_id: nat$connection_id);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc nat$connection_id
?? POP ??

*DECK DECK=FMP$PROCESS_PT_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] fmp$process_pt_request (
        process_pt_work_list: bat$process_pt_work_list;
        local_file_name: amt$local_file_name;
    VAR evaluated_file_reference: fst$evaluated_file_reference;
    VAR cycle_description: ^fmt$cycle_description;
    VAR process_pt_results: bat$process_pt_results;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc bat$process_pt_work_list
*copyc bat$process_pt_results
*copyc fme$file_management_errors
*copyc fmt$cycle_description
*copyc ost$status
?? POP ??
*DECK DECK=FMP$PUT_JL_POINTER EXPAND=FALSE

{ COMMON DECK FMXPJP

  PROCEDURE [XREF] fmp$put_jl_pointer (file: fst$file_reference;
        write_label: boolean;
        jl_pointer: ^SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$PUT_LABEL_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] fmp$put_label_attributes
    (    static_file_attributes: bat$static_label_attributes;
     VAR system_file_label: fmt$system_file_label);

?? PUSH (LISTEXT := ON) ??
*copyc bat$static_label_attributes
*copyc fmt$system_file_label
?? POP ??
*DECK DECK=FMP$RECORD_NOMINAL_DISCONNECT EXPAND=FALSE

  PROCEDURE [XREF] fmp$record_nominal_disconnect (
        file: fst$file_reference;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$RECORD_OPEN_CYCLE_INFO EXPAND=FALSE

  PROCEDURE [XREF] fmp$record_open_cycle_info
    (   path_handle: fmt$path_handle;
        validation_ring: ost$valid_ring;
        access_level: amt$access_level;
        preserved_attributes: bat$static_label_attributes;
        instance_attributes: bat$instance_attributes;
        cd_attachment_options: fmt$cd_attachment_options;
        open_count: integer;
        device_class: rmt$device_class;
    VAR open_cleanup_work_list: {i/o} fmt$open_cleanup_work_list;
    VAR global_file_information: ^bat$global_file_information;
    VAR segment_pointer: ^cell;
    VAR system_file_label: ^fmt$system_file_label;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc bat$global_file_information
*copyc bat$instance_attributes
*copyc bat$instance_attributes
*copyc bat$static_label_attributes
*copyc dmt$chapter_number
*copyc fmt$cd_attachment_options
*copyc fmt$open_cleanup_work_list
*copyc fmt$path_handle
*copyc fmt$system_file_label
*copyc mmt$attribute_keyword
*copyc osd$virtual_address
*copyc ost$status
*copyc rmt$device_class
?? POP ??
*DECK DECK=FMP$RECOVER_JOB_FILES EXPAND=FALSE
 PROCEDURE [XREF] fmp$recover_job_files (VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=FMP$RECOVER_SERVER_FILES EXPAND=FALSE

  PROCEDURE [XREF] fmp$recover_server_files
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=FMP$REGISTER_NOMINAL_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] fmp$register_nominal_connection (
        file: fst$file_reference;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$RELEASE_LOCAL_FILE EXPAND=FALSE

  PROCEDURE [XREF] fmp$release_local_file (VAR cycle_description:
    ^fmt$cycle_description);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$cycle_description
?? POP ??

*DECK DECK=FMP$RELEASE_RESOURCE EXPAND=FALSE
*DECK DECK=FMP$REMOVE_CONNECTION_ID EXPAND=FALSE

  PROCEDURE [XREF] fmp$remove_connection_id (
        file: fst$file_reference;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=FMP$REPORT_MEDIA_ERROR EXPAND=FALSE
 PROCEDURE [XREF] fmp$report_media_error (unit_status: iot$unit_status_table;
    VAR status: ost$status);
*copyc cmt$controller_port_number
*copyc cmt$channel_type
*DECK DECK=FMP$REQUEST_MASS_STORAGE EXPAND=FALSE

  PROCEDURE [XREF] fmp$request_mass_storage
    (    allocation_size: rmt$allocation_size;
         estimated_file_size: amt$file_byte_address;
         file_class: rmt$mass_storage_class;
         initial_volume: rmt$recorded_vsn;
         transfer_size: fst$transfer_size;
         volume_overflow_allowed: boolean;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc fst$evaluated_file_reference
*copyc fst$transfer_size
*copyc ost$status
*copyc rmc$unspecified_file_size
*copyc rmc$unspecified_transfer_size
*copyc rmt$allocation_size
*copyc rmt$mass_storage_class
*copyc rmt$recorded_vsn
?? POP ??

*DECK DECK=FMP$REQUEST_NULL_DEVICE EXPAND=FALSE

  PROCEDURE [XREF] fmp$request_null_device
    (    null_device_class: rmt$device_class;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc ost$status
*copyc rmt$device_class
?? POP ??
*DECK DECK=FMP$REQUEST_TAPE EXPAND=FALSE

  PROCEDURE [XREF] fmp$request_tape
    (    density: rmt$density;
         write_ring: rmt$write_ring;
         volume_list: rmt$volume_list;
         removable_media_group: ost$name;
         volume_overflow_allowed: boolean;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc rmd$tape_declarations
*copyc rmd$volume_declarations
*copyc rmc$condition_code_limits
*copyc rme$class_validation_errors
*copyc rme$request_tape
*copyc rmt$write_ring
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=FMP$REQUEST_TERMINAL EXPAND=FALSE

  PROCEDURE [XREF] fmp$request_terminal
    (    terminal_file_name_loc: ^amt$local_file_name;
         terminal_attributes: ^ift$connection_attributes;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc fst$evaluated_file_reference
*copyc ift$connection_attributes
*copyc ost$status
?? POP ??
*DECK DECK=FMP$RESERVE_RESOURCE EXPAND=FALSE
*DECK DECK=FMP$RETURN_FILE EXPAND=FALSE

  PROCEDURE [XREF] fmp$return_file
    (    evaluated_file_reference: fst$evaluated_file_reference;
         implicit_detach: boolean;
         detachment_options: ^fst$detachment_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$detachment_options
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=FMP$SETUP_JOB_ENVIRONMENT_INFO EXPAND=FALSE

  PROCEDURE [XREF] fmp$setup_job_environment_info
    (    cycle_description_p: {input^} ^fmt$cycle_description;
         path_handle_p: ^fmt$path_handle;
         job_environment_information_p: {output^}
               ^fst$job_environment_information;
     VAR object_information_p: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc fmt$cycle_description
*copyc fmt$path_handle
*copyc fst$job_environment_information
?? POP ??

*DECK DECK=FMP$SET_ATTACHMENT_OPTIONS EXPAND=FALSE

  PROCEDURE [XREF] fmp$set_attachment_options
    (    file: fst$file_reference;
         attachment_options: fmt$cd_attachment_options;
         p_volume_list: {input} ^rmt$volume_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$cd_attachment_options
*copyc fst$file_reference
*copyc ost$status
*copyc rmt$volume_list
?? POP ??
*DECK DECK=FMP$SET_ATTACHMENT_VALUES_IN_CD EXPAND=FALSE

  PROCEDURE [XREF] fmp$set_attachment_values_in_cd (
        cycle_description: ^fmt$cycle_description;
    VAR attachment_values: fmt$attachment_values;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$cycle_description
*copyc fmt$attachment_values
*copyc ost$status
?? POP ??


*DECK DECK=FMP$SET_SWITCH_OFFER EXPAND=FALSE

  PROCEDURE [XREF] fmp$set_switch_offer (
        file: fst$file_reference;
        timesharing_connection_switch: boolean;
    VAR application_name: nat$application_name;
    VAR connection_id: nat$connection_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc nat$application_name
*copyc nat$connection_id
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$SIMULATE_CONNECTION_BROKEN EXPAND=FALSE

  PROCEDURE [XREF] fmp$simulate_connection_broken (
        file: fst$file_reference;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$SL_REWIND_FILE_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] fmp$sl_rewind_file_command (
        local_file_name: amt$local_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$STORE_CONNECTION_ID EXPAND=FALSE

  PROCEDURE [XREF] fmp$store_connection_id (
        file: fst$file_reference;
        connection_id: nat$connection_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc nat$connection_id
*copyc ost$status
?? POP ??
*DECK DECK=FMP$STORE_SYSTEM_LABEL EXPAND=FALSE

  PROCEDURE [XREF] fmp$store_system_label
    (   local_file_name: amt$local_file_name;
        validation_ring: ost$valid_ring;
        label: SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc ame$ring_validation_errors
*copyc amt$local_file_name
*copyc fme$file_management_errors
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=FMP$STORE_TAPE_ATTACHMENT EXPAND=FALSE

  PROCEDURE [XREF] fmp$store_tape_attachment (
        tape_attachments: fst$attachment_options;
        tape_attachment_info_source: fst$tape_attach_info_source;
        tape_attachment_info: ^fst$tape_attachment_information;
    VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc fst$attachment_options
*copyc ost$status
?? POP ??
*DECK DECK=FMP$STORE_TAPE_LABEL_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] fmp$store_tape_label_attributes
    (    evaluated_file_reference: fst$evaluated_file_reference;
         tape_attachments: fst$attachment_options;
         supplied_file_set_pos_fields: fst$supplied_file_set_positions;
         tape_attachment_info_source: fst$tape_attach_info_source;
     VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc fst$attachment_options
*copyc fst$evaluated_file_reference
*copyc fst$supplied_file_set_positions
?? POP ??
*DECK DECK=FMP$TERMINATE_SERVER_FILES EXPAND=FALSE

  PROCEDURE [XREF] fmp$terminate_server_files
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$binary_mainframe_id
?? POP ??

*DECK DECK=FMP$UNLOCK_PATH_TABLE EXPAND=FALSE

  PROCEDURE [INLINE] fmp$unlock_path_table;

?? PUSH (LISTEXT := ON) ??

    osp$clear_job_signature_lock (fmv$path_table_lock);

  PROCEND fmp$unlock_path_table;

*copyc fmv$path_table_lock
*copyc osp$clear_job_signature_lock
?? POP ??
*DECK DECK=FMP$UNLOCK_PATH_TABLE_AT_TSKEND EXPAND=FALSE

  PROCEDURE [XREF] fmp$unlock_path_table_at_tskend;

*DECK DECK=FMP$UNSIMULATE_CONNECTION_BROKE EXPAND=FALSE

  PROCEDURE [XREF] fmp$unsimulate_connection_broke (
        file: fst$file_reference;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc OST$STATUS
?? POP ??
*DECK DECK=FMP$VALIDATE_SYSTEM_LABEL EXPAND=FALSE

  PROCEDURE [XREF] fmp$validate_system_label
    (    label: SEQ ( * );
         validation_ring: ost$valid_ring;
     VAR valid_checksum: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc ame$ring_validation_errors
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=FMP$VERIFY_ATTRIBUTE_LIMITS EXPAND=FALSE

  PROCEDURE [XREF] fmp$verify_attribute_limits (static_label: ^SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=FMT#FILE_ATTRIBUTE_KEYS_SET EXPAND=FALSE
  TYPE
    fmt#file_attribute_keys_set = set of fmt$file_attribute_keys;

*copyc fmt$file_attribute_keys
*DECK DECK=FMT$BASIC_FILE_LABEL EXPAND=FALSE
 TYPE
    fmt$basic_file_label = record
      existing_file: boolean,
      creation_access_level: amt$access_level,
      creation_access_level_source: amt$attribute_source,
      block_type: amt$block_type,
      block_type_source: amt$attribute_source,
      character_conversion: boolean,
      character_conversion_source: amt$attribute_source,
      clear_space: ost$clear_file_space,
      clear_space_source: amt$attribute_source,
      file_access_procedure: pmt$program_name,
      file_access_procedure_source: amt$attribute_source,
      file_contents: amt$file_contents,
      file_contents_source: amt$attribute_source,
      file_limit: amt$file_limit,
      file_limit_source: amt$attribute_source,
      file_organization: amt$file_organization,
      file_organization_source: amt$attribute_source,
      file_processor: amt$file_processor,
      file_processor_source: amt$attribute_source,
      file_structure: amt$file_structure,
      file_structure_source: amt$attribute_source,
      forced_write: amt$forced_write,
      forced_write_source: amt$attribute_source,
      internal_code: amt$internal_code,
      internal_code_source: amt$attribute_source,
      label_type: amt$label_type,
      label_type_source: amt$attribute_source,
      line_number: amt$line_number,
      line_number_source: amt$attribute_source,
      max_block_length: bat$v1_max_block_length,
      max_block_length_source: amt$attribute_source,
      max_record_length: amt$max_record_length,
      max_record_length_source: amt$attribute_source,
      min_block_length: amt$min_block_length,
      min_block_length_source: amt$attribute_source,
      min_record_length: amt$min_record_length,
      min_record_length_source: amt$attribute_source,
      padding_character: amt$padding_character,
      padding_character_source: amt$attribute_source,
      page_format: amt$page_format,
      page_format_source: amt$attribute_source,
      page_length: amt$page_length,
      page_length_source: amt$attribute_source,
      page_width: amt$page_width,
      page_width_source: amt$attribute_source,
      preset_value: amt$preset_value,
      preset_value_source: amt$attribute_source,
      record_type: amt$record_type,
      record_type_source: amt$attribute_source,
      ring_attributes: amt$ring_attributes,
      ring_attributes_source: amt$attribute_source,
      statement_identifier: amt$statement_identifier,
      statement_identifier_source: amt$attribute_source,
      user_info: amt$user_info,
      user_info_source: amt$attribute_source,
      vertical_print_density: amt$vertical_print_density,
      vertical_print_density_source: amt$attribute_source,
{}
{ The following attributes are only used to describe files which}
{ are accessed with the Advanced Access Mehtod (AAM).  The}
{ documentation of the AAM attributes are found in the AAM ERS.}
{}
      average_record_length: amt$average_record_length,
      average_record_length_source: amt$attribute_source,
      collate_table: amt$collate_table,
      collate_table_source: amt$attribute_source,
      collate_table_name: pmt$program_name,
      collate_table_name_source: amt$attribute_source,
      data_padding: amt$data_padding,
      data_padding_source: amt$attribute_source,
      embedded_key: boolean,
      embedded_key_source: amt$attribute_source,
      estimated_record_count: amt$estimated_record_count,
      estimated_record_count_source: amt$attribute_source,
      index_levels: amt$index_levels,
      index_levels_source: amt$attribute_source,
      index_padding: amt$index_padding,
      index_padding_source: amt$attribute_source,
      key_length: amt$key_length,
      key_length_source: amt$attribute_source,
      key_position: amt$key_position,
      key_position_source: amt$attribute_source,
      key_type: amt$key_type,
      key_type_source: amt$attribute_source,
      record_limit: amt$record_limit,
      record_limit_source: amt$attribute_source,
      records_per_block: amt$records_per_block,
      records_per_block_source: amt$attribute_source,
    recend;


?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_attributes
*copyc ost$clear_file_space
*copyc amd$file_attributes
*copyc bat$v1_max_block_length
*copyc amt$max_record_length
*copyc amt$statement_identifier
*copyc amd$open_declarations
?? POP ??
*DECK DECK=FMT$CD_ATTACHMENT_OPTIONS EXPAND=FALSE

  TYPE
    fmt$cd_attachment_options = record
      external_vsn_specified: boolean,
      free_behind_specified: boolean,
      free_behind: boolean,
      job_write_concurrency_specified: boolean,
      job_write_concurrency: boolean,
      private_read_specified: boolean,
      private_read: boolean,
      recorded_vsn_specified: boolean,
      sequential_access_specified: boolean,
      sequential_access: boolean,
      volume_overflow_allowed_spec: boolean,
      volume_overflow_allowed: boolean,
      transfer_size_specified: boolean,
      transfer_size: fst$transfer_size,
    recend;

*copyc fst$transfer_size
*DECK DECK=FMT$CYCLE_ATTACHMENT_INFO EXPAND=FALSE

  TYPE
    fmt$cycle_attachment_info = record
      case cycle_attached: boolean of
      = FALSE =
        ,
      = TRUE =
        password_protected: boolean,
        allowed_access: fst$file_access_options,
        required_sharing: fst$file_access_options,
        open_count: integer,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_access_options
?? POP ??
*DECK DECK=FMT$CYCLE_DESCRIPTION EXPAND=FALSE

  TYPE
    fmt$cycle_description = record
      entry_assignment: ^string (1),
      path_handle: fmt$path_handle,
      global_file_information: ^bat$global_file_information,
      static_setfa_entries: ^SEQ ( * ),
      dynamic_setfa_entries: ^fst$setfa_attachment_options,
      cd_attachment_options: ^fmt$cd_attachment_options,
      case attached_file: boolean of
      = TRUE =
        system_file_label: fmt$system_file_label,
        case device_class: rmt$device_class of
        = rmc$connected_file_device =
          ,
        = rmc$interstate_link_device =
          ,
        = rmc$local_queue_device =
          ,
        = rmc$log_device =
          ,
        = rmc$magnetic_tape_device, rmc$mass_storage_device =
          file_space_limit_kind: sft$file_space_limit_kind,
          job_routing_label: ^SEQ ( * ),
          job_routing_label_length: jmt$system_label_info_length,
          system_file_id: dmt$system_file_id,
          case permanent_file: boolean of
          = TRUE =
            apfid: pft$attached_permanent_file_id,
            attached_access_modes: fst$file_access_options,
            attached_share_modes: fst$file_access_options,
            password_protected: boolean,
            system_file_label_catalogued: boolean,
          = FALSE =
            ,
          casend,
        = rmc$memory_resident_device =
          ,
        = rmc$network_device =
          ,
        = rmc$null_device =
          ,
        = rmc$pipeline_device =
          ,
        = rmc$rhfam_device =
          ,
        = rmc$terminal_device =
          terminal_request: ^ift$connection_attributes,
          terminal_command: ^bat$terminal_cmd_list,
          terminal_file_name: amt$local_file_name,
        casend,
      = FALSE =
        ,
      casend,
    recend;

*copyc amt$local_file_name
*copyc bat$global_file_information
*copyc bat$terminal_cmd_list
*copyc dmt$system_file_id
*copyc fmt$cd_attachment_options
*copyc fmt$path_handle
*copyc fmt$system_file_label
*copyc fst$file_access_options
*copyc fst$setfa_attachment_options
*copyc ift$connection_attributes
*copyc jmt$system_label_info_length
*copyc pfd$attached_permanent_file_id
*copyc rmt$device_class
*copyc sft$file_space_limit_kind
*DECK DECK=FMT$CYCLE_DESCRIPTION_UNIT EXPAND=FALSE
  TYPE
    fmt$cycle_description_unit = record
      global_file_entries_pointer: ^fmt$global_file_entries,
        { pointer to the corresponding global file information array }
      next_cycle_description_unit: ^fmt$cycle_description_unit,
      total_count: ost$non_negative_integers,
        { record of total number of assignments ever made to this cdu }
      entry_assignment: ^string ( * ),
      entries: ^fmt$cycle_descriptions,
    recend,

    fmt$cycle_descriptions = array [ 1 .. * ] of
      fmt$cycle_description;

*copyc osd$integer_limits
*copyc fmt$cycle_description
*copyc fmt$global_file_entries
*DECK DECK=FMT$CYCLE_DEVICE_INFO EXPAND=FALSE

  TYPE
    fmt$cycle_device_info = record
      case device_assigned: boolean of
      = FALSE =
        ,
      = TRUE =
        device_class: rmt$device_class,
        cycle_formerly_opened_info: fmt$cycle_formerly_opened_info,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc fmt$cycle_formerly_opened_info
*copyc rmt$device_class
?? POP ??
*DECK DECK=FMT$CYCLE_FORMERLY_OPENED_INFO EXPAND=FALSE

  TYPE
    fmt$cycle_formerly_opened_info = record
      case cycle_previously_opened: boolean of
      = FALSE =
        ,
      = TRUE =
        ring_attributes: amt$ring_attributes,
        ring_attributes_source: amt$attribute_source,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
*copyc amt$ring_attributes
?? POP ??
*DECK DECK=FMT$DETACHMENT_OPTIONS EXPAND=FALSE

  TYPE
    fmt$detachment_options = record
      case device_class: rmt$device_class of
      = rmc$connected_file_device =
        ,
      = rmc$interstate_link_device =
        ,
      = rmc$local_queue_device =
        ,
      = rmc$log_device =
        ,
      = rmc$magnetic_tape_device =
        physical_unload: boolean,
      = rmc$mass_storage_device =
        ,
      = rmc$memory_resident_device =
        ,
      = rmc$network_device =
        ,
      = rmc$null_device =
        ,
      = rmc$pipeline_device =
        ,
      = rmc$rhfam_device =
        ,
      = rmc$terminal_device =
        ,
      casend,
    recend;

*copyc rmt$device_class
*DECK DECK=FMT$FILE_ATTRIBUTE_KEYS EXPAND=FALSE
 CONST
    fmc$ring_attributes = 1,
    fmc$average_record_length = 2,
    fmc$block_type = 3,
    fmc$character_conversion = 4,
    fmc$clear_space = 5,
    fmc$collate_table = 6,
    fmc$collate_table_name = 7,
    fmc$compression_procedure_name = 8,
    fmc$data_padding = 9,
    fmc$dynamic_home_block_space = 10,
    fmc$embedded_key = 11,
    fmc$estimated_record_count = 12,
    fmc$file_access_procedure = 13,
    fmc$file_contents = 14,
    fmc$file_limit = 15,
    fmc$file_organization = 16,
    fmc$file_processor = 17,
    fmc$file_structure = 18,
    fmc$forced_write = 19,
    fmc$hashing_procedure_name = 20,
    fmc$index_levels = 21,
    fmc$index_padding = 22,
    fmc$initial_home_block_count = 23,
    fmc$internal_code = 24,
    fmc$key_length = 25,
    fmc$key_position = 26,
    fmc$key_type = 27,
    fmc$label_type = 28,
    fmc$line_number = 29,
    fmc$loading_factor = 30,
    fmc$lock_expiration_time = 31,
    fmc$logging_options = 32,
    fmc$log_residence = 33,
    fmc$max_block_length = 34,
    fmc$max_record_length = 35,
    fmc$min_block_length = 36,
    fmc$min_record_length = 37,
    fmc$padding_character = 38,
    fmc$page_format = 39,
    fmc$page_length = 40,
    fmc$page_width = 41,
    fmc$preset_value = 42,
    fmc$record_limit = 43,
    fmc$record_type = 44,
    fmc$records_per_block = 45,
    fmc$statement_identifier = 46,
    fmc$user_info = 47,
    fmc$vertical_print_density = 48,
    fmc$record_delimiting_character = 49,

    fmc$highest_current_attribute = 49;


  TYPE
    fmt$file_attribute_keys = 1 .. amc$max_attribute;

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
?? POP ??
*DECK DECK=FMT$FILE_LABEL EXPAND=FALSE

{ FMDFLBL - File label definitions

  TYPE
    fmt$file_label = SEQ ( * ),

    fmt$p_file_label = ^fmt$file_label;
*DECK DECK=FMT$GLOBAL_FILE_ENTRIES EXPAND=FALSE

  TYPE
    { This type defines an array of bat$global_file_information }
    { to correspond to the array of cycle_description in }
    { fmt$cycle_description unit.}
    fmt$global_file_entries = array [ 1 .. * ] of bat$global_file_information;

?? PUSH (LISTEXT := ON) ??
*copyc bat$global_file_information
?? POP ??
*DECK DECK=FMT$LABEL_HEADERS EXPAND=FALSE


  CONST
    fmc$max_file_editions = 64,
    fmc$max_label_size = 0ffff(16),
    fmc$max_section_size = 2048;


  TYPE
    fmt$static_bam_label_header = record
      name: fmt$label_name,
      size: fmt$label_section_size,
      version: fmt$label_version,
    recend;

  TYPE
    fmt$dynamic_bam_label_header = record
      name: fmt$label_name,
      size: fmt$label_section_size,
      version: fmt$label_version,
    recend;

  TYPE
    fmt$job_label_header = record
      name: fmt$label_name,
      size: fmt$label_section_size,
      version: fmt$label_version,
    recend;

  TYPE
    fmt$label_name = ost$name,
    fmt$label_version = 1 .. fmc$max_file_editions,
    fmt$label_section_size = 0 .. fmc$max_section_size;

?? PUSH (LISTEXT := ON) ??
*copyc OST$NAME
?? POP ??
*DECK DECK=FMT$MASS_STORAGE_REQUEST_INFO EXPAND=FALSE

  TYPE
    fmt$mass_storage_request_info = record
      allocation_size: rmt$allocation_size,
      estimated_file_size: amt$file_byte_address,
      initial_volume: rmt$recorded_vsn,
      maintenance_job: boolean,
      mass_storage_class: dmt$class_member,
      shared_queue: pft$shared_queue,
      transfer_size: fst$transfer_size,
      user_privilege: rmt$user_privilege,
      volume_overflow_allowed: boolean,
    recend;

*copyc amt$file_byte_address
*copyc dmt$class
*copyc fst$transfer_size
*copyc pft$shared_queue
*copyc rmc$mass_storage_class
*copyc rmc$unspecified_file_size
*copyc rmc$unspecified_transfer_size
*copyc rmc$unspecified_vsn
*copyc rmt$allocation_size
*copyc rmt$recorded_vsn
*copyc rmt$user_privilege
*DECK DECK=FMT$OPEN_CLEANUP_WORK_LIST EXPAND=FALSE

  TYPE
    fmt$open_cleanup_work_list = set of (fmc$clear_open_lock,
          fmc$decrement_open_count, fmc$free_static_label);
*DECK DECK=FMT$OPTIONAL_FILE_LABEL EXPAND=FALSE
 TYPE
    fmt$optional_file_label = SEQ ( * );

{ The first item in the sequence is the fmt$optional_label_directory.}
{ For each file_attribute_key whose corresponding entry in the }
{ optional_label_directory is 'TRUE' there follows in the sequence the}
{ 'source' and 'value' of the attribute.  These pairs are NEXTed in the}
{}
{ An attribute (source,value) is stored in the optional_file_label only}
{ if its source is not amc$undefined_attribute.}
{}
*DECK DECK=FMT$OPTIONAL_LABEL_DIRECTORY EXPAND=FALSE
 TYPE
    fmt$optional_label_directory = record
      header: fmt$static_bam_label_header,
      attribute_present: packed array [1 .. 127 {amt$file_attribute_keys} ] of
        boolean,
      highest_attribute_present: amt$file_attribute_keys,
      job_routing_label_present: boolean,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_attribute_keys
*copyc fmt$label_headers
?? POP ??
*DECK DECK=FMT$OPTIONAL_LABEL_ITEM EXPAND=FALSE
 TYPE
    fmt$optional_label_item = BOUND record
      source: amt$attribute_source,
      case key: amt$file_attribute_keys of
      = amc$average_record_length =
        average_record_length: amt$average_record_length,
      = amc$collate_table =
        collate_table: amt$collate_table,
      = amc$collate_table_name, amc$compression_procedure_name,
        amc$file_access_procedure, amc$hashing_procedure_name =
        entry_point_name_length: 1 .. osc$max_name_size,
        entry_point_path_length: 0 .. amc$max_path_name_size,
      = amc$data_padding =
        data_padding: amt$data_padding,
      = amc$dynamic_home_block_space =
        dynamic_home_block_space: amt$dynamic_home_block_space,
      = amc$embedded_key =
        embedded_key: boolean,
      = amc$estimated_record_count =
        estimated_record_count: amt$estimated_record_count,
      = amc$file_contents, amc$file_processor, amc$file_structure =
        name_length: 1 .. osc$max_name_size,
      = amc$index_levels =
        index_levels: amt$index_levels,
      = amc$index_padding =
        index_padding: amt$index_padding,
      = amc$initial_home_block_count =
        initial_home_block_count: amt$initial_home_block_count,
      = amc$key_length =
        key_length: amt$key_length,
      = amc$key_position =
        key_position: amt$key_position,
      = amc$key_type =
        key_type: amt$key_type,
      = amc$loading_factor =
        loading_factor: amt$loading_factor,
      = amc$lock_expiration_time =
        lock_expiration_time: amt$lock_expiration_time,
      = amc$logging_options =
        logging_options: amt$logging_options,
      = amc$log_residence =
        path_length: 1 .. amc$max_path_name_size,
      = amc$record_limit =
        record_limit: amt$record_limit,
      = amc$records_per_block =
        records_per_block: amt$records_per_block,
      = amc$user_info =
        user_info_length: 1 .. cyc$max_string_size,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
*copyc amt$compression_procedure_name
*copyc amt$data_padding
*copyc amt$dynamic_home_block_space
*copyc amt$file_attribute_keys
*copyc amt$hashing_procedure_name
*copyc amt$index_levels
*copyc amt$index_padding
*copyc amt$initial_home_block_count
*copyc amt$key_length
*copyc amt$key_position
*copyc amt$key_type
*copyc amt$loading_factor
*copyc amt$lock_expiration_time
*copyc amt$logging_options
*copyc amt$log_residence
*copyc amt$path_name
*copyc amt$records_per_block
*copyc cyd$string
*copyc ost$name
?? POP ??
*DECK DECK=FMT$PATH_DESCRIPTION_ENTRY EXPAND=FALSE
  TYPE
    fmt$path_description_entry = record
      unique_identifier: 0 .. 0ff(16), { EE(16), 238(10) }
      cumulative_parental_path_size: fst$path_size,
      path_depth: 1 .. fsc$max_path_elements,
      entry_assignment: ^string (1),
      pdu_pointer: ^fmt$path_description_unit,
      entry_assignment_counter: fmt$pde_assignment_counter,
      parental_path_entry: ^fmt$path_description_entry,
      path_handle_name_externalized: boolean,
      case entry_type: fmt$path_element_type of
      = fmc$named_object =
        parental_tree_entry: ^fmt$path_description_entry,
        left_subtree: ^fmt$path_description_entry,
        right_subtree: ^fmt$path_description_entry,
        path_node_name: fst$path_element,
        randomized_node_name: ost$randomized_name,
        highest_cycle: ^fmt$path_description_entry,
        next_cycle_alias_entry: ^fmt$path_description_entry,
        active_path_participation_count: 0 .. fsc$maximum_cycle_number,
      = fmc$file_cycle_object =
        cycle_number: fst$cycle_number,
        next_lower_cycle: ^fmt$path_description_entry,
        next_higher_cycle: ^fmt$path_description_entry,
        first_cycle_alias_entry: ^fmt$path_description_entry,
        cycle_description: ^fmt$cycle_description,
      casend,
    recend;

*copyc fmt$cycle_description
*copyc fmt$path_description_entry
*copyc fmt$path_description_unit
*copyc fmt$path_element_type
*copyc fmt$path_handle
*copyc fmt$pde_assignment_counter
*copyc fsc$max_path_elements
*copyc fsc$maximum_cycle_number
*copyc fst$cycle_number
*copyc fst$path_element
*copyc fst$path_size
*copyc osd$random_name
*DECK DECK=FMT$PATH_DESCRIPTION_UNIT EXPAND=FALSE

  TYPE
    fmt$path_description_unit = record
      next_path_description_unit: ^fmt$path_description_unit,
        { searches will always start with the oldest pdu }
        { ie. root of tree }
      total_count: ost$non_negative_integers,
        { record of total number of assignments ever made to this pdu }
      current_count: ost$non_negative_integers,
        { record of total number of active entries currently in this pdu }
      entry_assignment: ^string ( * ),
      entries: ^fmt$path_description_entries,
    recend,

    fmt$path_description_entries = array [ 1 .. * ] of
      fmt$path_description_entry;

*copyc osd$integer_limits
*copyc fmt$path_description_entry
*DECK DECK=FMT$PATH_ELEMENT_TYPE EXPAND=FALSE
  TYPE
    fmt$path_element_type = (fmc$named_object, fmc$file_cycle_object);
*DECK DECK=FMT$PATH_HANDLE EXPAND=FALSE

  TYPE
    fmt$path_handle = record
      segment_offset: ost$segment_length,
      assignment_counter: fmt$pde_assignment_counter,
      open_position: fst$open_position,
    recend;

*copyc fmt$pde_assignment_counter
*copyc fst$open_position
*copyc osd$virtual_address
*DECK DECK=FMT$PATH_HANDLE_OFFSET_NIBBLES EXPAND=FALSE


  TYPE
    fmt$path_handle_offset_nibbles = record
      case boolean of
      = TRUE =
        segment_offset: ost$segment_length,
      = FALSE =
        nibble: packed array [1 .. 8] of 0 .. 0F(16),
      casend,
    recend;

*copyc osd$virtual_address
*DECK DECK=FMT$PATH_TABLE_CYCLE_INFO EXPAND=FALSE

  TYPE
    fmt$path_table_cycle_info = record
      case path_registered: boolean of
      = FALSE =
        ,
      = TRUE =
        cycle_number: fst$cycle_number,
        cycle_device_info: fmt$cycle_device_info,
        cycle_attachment_info: fmt$cycle_attachment_info,
        setfa_access_modes: fst$access_modes,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc fmt$cycle_attachment_info
*copyc fmt$cycle_device_info
*copyc fst$access_modes
*copyc fst$cycle_number
?? POP ??

*DECK DECK=FMT$PDE_ASSIGNMENT_COUNTER EXPAND=FALSE

  TYPE
    fmt$pde_assignment_counter = 0 .. 0ffffff(16);

*DECK DECK=FMT$PF_ATTACHMENT_INFO EXPAND=FALSE

  TYPE
    fmt$pf_attachment_info = record
      apfid: pft$attached_permanent_file_id,
      application_info: pft$application_info,
      implicit_attach: boolean,
      password_protected: boolean,
    recend;

*copyc pfd$attached_permanent_file_id
*copyc pfd$permanent_file_attributes
*DECK DECK=FMT$REMOVABLE_MEDIA_REQ_INFO EXPAND=FALSE

  TYPE
    fmt$removable_media_req_info = record
      density: rmt$density,
      removable_media_group: ost$name,
      volume_overflow_allowed: boolean,
      write_ring: rmt$write_ring,
    recend;

*copyc ost$name
*copyc rmt$density
*copyc rmt$write_ring
*DECK DECK=FMT$REVISION_LEVEL EXPAND=FALSE
 TYPE
    fmt$revision_level = 1 .. 0ffff(16);

*copyc fmc$current_revision_level
*DECK DECK=FMT$STATIC_LABEL_HEADER EXPAND=FALSE
 TYPE
    fmt$static_label_header = record
      unique_character: char,
      revision_level: fmt$revision_level,
      highest_attribute_present: 0 .. amc$max_attribute,
      highest_attribute_supported: amt$file_attribute_keys,
      job_routing_label_size: jmt$system_label_info_length,
      default_revision_level: fmt$revision_level,
      user_attribute_length: fmt$user_attribute_length,
      filler: fmt$filler,
      attribute_present: packed array [1 .. amc$max_attribute] of boolean,
      CASE file_previously_opened: boolean OF
      = TRUE =
        ring_attributes: amt$ring_attributes,
        ring_attributes_source: amt$attribute_source,
      = FALSE =
        ,
      CASEND,
    recend;

 TYPE
    fmt$filler = string (13);

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
*copyc amt$file_attribute_keys
*copyc amt$ring_attributes
*copyc fmc$unique_label_id
*copyc fmt$file_attribute_keys
*copyc fmt$revision_level
*copyc fmt$user_attribute_length
*copyc jmt$system_label_info_length
?? POP ??
*DECK DECK=FMT$STATIC_LABEL_ITEM EXPAND=FALSE
 TYPE
    fmt$static_label_item = BOUND record
      source: amt$attribute_source,
      case key: fmt$file_attribute_keys of
      = fmc$ring_attributes =
        ring_attributes: amt$ring_attributes,
      = fmc$block_type =
        block_type: amt$block_type,
      = fmc$character_conversion =
        character_conversion: boolean,
      = fmc$clear_space =
        clear_space: ost$clear_file_space,
      = fmc$file_contents, fmc$file_processor, fmc$file_structure =
        name_length: 1 .. osc$max_name_size,
      = fmc$file_limit, fmc$max_block_length, fmc$max_record_length, fmc$min_block_length,
        fmc$min_record_length, fmc$page_length, fmc$page_width, fmc$preset_value,
        fmc$vertical_print_density, fmc$average_record_length, fmc$estimated_record_count,
        fmc$index_levels, fmc$initial_home_block_count, fmc$key_length, fmc$key_position,
        fmc$lock_expiration_time, fmc$record_limit, fmc$records_per_block =
        integer_value: integer,
      = fmc$file_organization =
        file_organization: amt$file_organization,
      = fmc$forced_write =
        forced_write: amt$forced_write,
      = fmc$internal_code =
        internal_code: amt$internal_code,
      = fmc$label_type =
        label_type: amt$label_type,
      = fmc$line_number =
        line_number: amt$line_number,
      = fmc$padding_character =
        padding_character: amt$padding_character,
      = fmc$page_format =
        page_format: amt$page_format,
      = fmc$record_type =
        record_type: amt$record_type,
      = fmc$record_delimiting_character =
        record_delimiting_character: char,
      = fmc$statement_identifier =
        statement_identifier: amt$statement_identifier,
      = fmc$collate_table =
        collate_table: amt$collate_table,
      = fmc$compression_procedure_name, fmc$hashing_procedure_name,
        fmc$file_access_procedure, fmc$collate_table_name =
        entry_point_name_length: 1 .. osc$max_name_size,
        entry_point_path_length: 0 .. amc$max_path_name_size,
      = fmc$data_padding =
        data_padding: amt$data_padding,
      = fmc$dynamic_home_block_space =
        dynamic_home_block_space: amt$dynamic_home_block_space,
      = fmc$embedded_key =
        embedded_key: boolean,
      = fmc$index_padding =
        index_padding: amt$index_padding,
      = fmc$key_type =
        key_type: amt$key_type,
      = fmc$loading_factor =
        loading_factor: amt$loading_factor,
      = fmc$logging_options =
        logging_options: amt$logging_options,
      = fmc$log_residence =
        path_length: 1 .. amc$max_path_name_size,
      = fmc$user_info =
        user_info_present: boolean,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ost$clear_file_space
*copyc amd$open_declarations
*copyc amt$statement_identifier
*copyc amt$compression_procedure_name
*copyc amt$data_padding
*copyc amt$dynamic_home_block_space
*copyc amt$file_attribute_keys
*copyc amt$hashing_procedure_name
*copyc amt$index_padding
*copyc amt$key_type
*copyc amt$loading_factor
*copyc amt$logging_options
*copyc amt$log_residence
*copyc amt$path_name
*copyc fmt$file_attribute_keys
*copyc ost$name
?? POP ??
*DECK DECK=FMT$SYSTEM_FILE_LABEL EXPAND=FALSE
 TYPE
    fmt$system_file_label = record
      file_previously_opened: boolean,
      static_label: ^SEQ ( * ),
      descriptive_label: bat$descriptive_file_attributes,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc bat$descriptive_file_attributes
?? POP ??

{ The first item in the sequence is the fmt$static_label_header,
{ which contains the fmt$static_label_directory.  For each
{ file_attribute_key whose corresponding entry in the static_label_directory
{ is 'TRUE' there follows in the sequence the 'source' and 'value' of the
{ attribute.  These pairs are NEXTed in the sequence.
{}
{ An attribute (source,value) is stored in the static_label only if its
{ source is not amc$undefined_attribute or amc$access_method_default.
{}
*DECK DECK=FMT$TAPE_INIT_INFO EXPAND=FALSE

  CONST
    fmc$active_tape_limit = 16;

  TYPE
    fmt$tape_limit = 1 .. fmc$active_tape_limit;

  TYPE
    fmt$tape_init_info = array [1 .. fmc$active_tape_limit] of
      fmt$tape_init_record,

    fmt$tape_init_record = record
      sfid: dmt$system_file_id,
      lfn: amt$local_file_name,
    recend;

  TYPE
    fmt$tape_buffer_data = array [*] of integer;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc amt$local_file_name
?? POP ??
*DECK DECK=FMT$TAPE_TRANSFER_INFO EXPAND=FALSE

{ COMMON DECK FMDTTI }

  CONST
    fmc$number_of_tapes = 16;

  TYPE
    fmt$tape_transfer_info = array [1 .. fmc$number_of_tapes] of
      fmt$tape_transfer_entry;

  TYPE
    fmt$tape_transfer_entry = record
      sfid: dmt$system_file_id,
      vsn: rmt$external_vsn,
      flag1: boolean,
      flag2: boolean,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc RMD$VOLUME_DECLARATIONS
?? POP ??
*DECK DECK=FMT$USER_ATTRIBUTE_LENGTH EXPAND=FALSE

  TYPE
    fmt$user_attribute_length = 0 .. 0ffffff(16);

*DECK DECK=FMV$ATTACHMENT_VALUES EXPAND=FALSE

  VAR
    fmv$attachment_values: [XDCL, oss$job_pageable] fmt$attachment_values :=
      [
        {attached_file} FALSE,
        {attached_access_modes_set} FALSE,
        {attached_access_modes} $fst$file_access_options [],
        {attached_share_modes_set} FALSE,
        {attached_share_modes} $fst$file_access_options [],
        {explicit_detach_allowed_set} FALSE,
        {explicit_detach_allowed} TRUE,
        {implicit_detach_required_set} FALSE,
        {implicit_detach_required} FALSE,
        {hide_attachment_set} FALSE,
        {hide_attachment} FALSE,
        {scope_set} FALSE,
        {scope} fsc$job_scope,
        {block_handle_set} FALSE,
        {block_handle.segment_offset}
        {block_handle.assignment_counter} [0,0]
        {recend} ];

?? PUSH (LISTEXT := ON) ??
*copyc fmt$attachment_values
*copyc fst$attachment_options
*copyc fst$attachment_scope
*copyc osv$job_pageable_heap
?? POP ??
*DECK DECK=FMV$DEFAULT_DETACHMENT_OPTIONS EXPAND=FALSE

  VAR
    fmv$default_detachment_options: [oss$job_paged_literal, XREF, READ]
      fmt$detachment_options;

?? PUSH (LISTEXT := ON) ??
*copyc fmt$detachment_options
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=FMV$DEFAULT_FILE_ATTRIBUTES EXPAND=FALSE

  VAR
    fmv$default_file_attributes: [XREF, oss$job_pageable] ^bat$static_label_attributes;

  VAR
    fmv$default_new_retention: [XREF, oss$job_pageable] ^fst$retention;

?? PUSH (LISTEXT := ON) ??
*copyc bat$static_label_attributes
*copyc fst$retention
*copyc oss$job_pageable
?? POP ??
*DECK DECK=FMV$ENTRY_ASSIGNED_FREE_SELECT EXPAND=FALSE

  VAR
    {Selector for fmc$entry_free used for #SCAN }
    fmv$entry_free_selector: [XREF] packed array [0 .. 255] of boolean;

  VAR
    {Selector for fmc$entry_assigned used for #SCAN }
    fmv$entry_assigned_selector: [XREF] packed array [0 .. 255] of boolean;
*DECK DECK=FMV$GLOBAL_FILE_INFORMATION EXPAND=FALSE

{ COMMON DECK FMXGFI }

  VAR
    fmv$global_file_information: [oss$job_paged_literal, XREF, READ]
      bat$global_file_information;

?? PUSH (LISTEXT := ON) ??
*copyc BAT$GLOBAL_FILE_INFORMATION
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=FMV$HIGHEST_PDU_OFFSET EXPAND=FALSE

  VAR
    { Highest allocated pde offset.  Used for path handle validation.}
    fmv$highest_pdu_offset: [XREF, READ] ost$segment_offset;

*copyc osd$virtual_address
*DECK DECK=FMV$INITIAL_CDU_POINTER EXPAND=FALSE

  VAR
    { Pointer to first allocated cycle_description_unit. }
    { XDCL is in fmm$path_table_manager; oss$job_pageable. }
    fmv$initial_cdu_pointer: [XREF, READ]
      ^fmt$cycle_description_unit;

?? PUSH (LISTEXT := ON) ??
*copyc fmt$cycle_description_unit
?? POP ??
*DECK DECK=FMV$INITIAL_PDU_POINTER EXPAND=FALSE

  VAR
    { XDCL is in fmm$path_table_manager; oss$job_pageable. }
    { Points to first allocated path_description_unit. }
    { Used when looking for a free entry. }
    fmv$initial_pdu_pointer: [XREF, READ]
      ^fmt$path_description_unit;

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_description_unit
?? POP ??
*DECK DECK=FMV$PATH_TABLE_ENTRY_POINT EXPAND=FALSE

  VAR
    { XDCL is in fmm$path_table_manager; oss$job_pageable. }
    { Pointer to first entry in first path_description_unit. }
    { All searched through path table start here. }
    fmv$path_table_entry_point: [XREF, READ]
      ^fmt$path_description_entry;

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_description_entry
?? POP ??
*DECK DECK=FMV$PATH_TABLE_LOCK EXPAND=FALSE


  VAR
    fmv$path_table_lock:  [XREF] ost$signature_lock;

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??
*DECK DECK=FMV$PATH_TABLE_STATISTICS EXPAND=FALSE

  VAR
    { Statistics gathering variables }
    fmv$named_objects_created: [XREF, READ] ost$non_negative_integers,
    fmv$named_objects_deleted: [XREF, READ] ost$non_negative_integers,
    fmv$cycle_objects_created: [XREF, READ] ost$non_negative_integers,
    fmv$cycle_objects_deleted: [XREF, READ] ost$non_negative_integers,
    fmv$max_active_objects: [XREF, READ] ost$non_negative_integers,
    fmv$max_path_depth: [XREF, READ] ost$non_negative_integers,
    fmv$path_depth_entries: [XREF, READ] array
          [1 .. fmc$statistics_max_path_depth] of ost$non_negative_integers;

*copyc osd$integer_limits
*copyc fmc$statistics_max_path_depth
*DECK DECK=FMV$PDE_ASSIGNMENT_COUNTER EXPAND=FALSE

  VAR
    { Unique counter for path_description_entries. }
    { Incremented for each pde assigned in a job. }
    fmv$pde_assignment_counter: [XREF, READ] fmt$pde_assignment_counter;

?? PUSH (LISTEXT := ON) ??
*copyc fmt$pde_assignment_counter
?? POP ??
*DECK DECK=FMV$STATIC_LABEL_HEADER EXPAND=FALSE

  VAR
    fmv$static_label_header: [XREF, READ, oss$job_paged_literal]
          fmt$static_label_header;

?? PUSH (LISTEXT := ON) ??
*copyc fmt$static_label_header
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=FMV$SYSTEM_FILE_ATTRIBUTES EXPAND=FALSE

{ COMMON DECK FMXSFA }

  VAR
    fmv$system_file_attributes: [XREF, READ, oss$job_paged_literal]
      bat$system_file_attributes;

?? PUSH (LISTEXT := ON) ??
*copyc BAT$SYSTEM_FILE_ATTRIBUTES
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=FMV$TAPE_ATTACHMENT_INFORMATION EXPAND=FALSE

  VAR
    fmv$tape_attachment_information: [oss$job_paged_literal, XREF, READ]
      fst$tape_attachment_information;

?? PUSH (LISTEXT := ON) ??
*copyc fst$tape_attachment_information
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=FMV$TAPE_DESCRIPTOR EXPAND=FALSE

  VAR
    fmv$tape_descriptor: [oss$job_paged_literal, XREF, READ]
      bat$tape_descriptor;

?? PUSH (LISTEXT := ON) ??
*copyc bat$tape_descriptor
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=FMX$CLOSE_VOLUME EXPAND=FALSE

{ COMMON DECK FMX$CLOSE_TAPE_VOLUME }

  PROCEDURE [XREF] fmp$close_tape_volume (local_file_name: amt$local_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=FSC$COMPILING_FOR_TEST_HARNESS EXPAND=FALSE

  ?VAR
*IF ($variable(fsv$test_harness, declared) = 'LOCAL') AND fsv$test_harness
    fsc$compiling_for_test_harness: boolean := TRUE ?;
*ELSE
    fsc$compiling_for_test_harness: boolean := FALSE ?;
*IFEND

*DECK DECK=FSC$CONDITION_CODE_LIMITS EXPAND=FALSE


  CONST
*IF $true(osv$unix)
    fsc$min_ecc = (($INTEGER ('F') * 100(16)) + $INTEGER ('S')) * 10000(16),
*ELSE
    fsc$min_ecc = (($INTEGER ('F') * 100(16)) + $INTEGER ('S')) * 1000000(16),
*IFEND
    fsc$min_ecc_validation = fsc$min_ecc,
    fsc$max_ecc_validation = fsc$min_ecc_validation + 49;


*DECK DECK=FSC$COPF_INPUT_ATTACHMENT_SIZE EXPAND=FALSE

{ Number of attachment options specified by fsv$copf_input_file_attachment.

  CONST
    fsc$copf_input_attachment_size = 4;

*DECK DECK=FSC$COPF_OUTPUT_ATTACHMENT_SIZE EXPAND=FALSE

{ Number of attachment options specified by fsv$copf_output_file_attachment.

  CONST
    fsc$copf_output_attachment_size = 6;

*DECK DECK=FSC$FILE_ACCESS_CONDITIONS_MAX EXPAND=FALSE

  CONST
    fsc$file_access_conditions_max = 9;
*DECK DECK=FSC$FILE_CONTENTS EXPAND=FALSE

{ The following are NOS/VE system conventions for referring to the}
{ contents of a file:

?? FMT (FORMAT := OFF) ??
 CONST
    fsc$ascii_log                   = 'ASCII_LOG                      ',
    fsc$binary_log                  = 'BINARY_LOG                     ',
    fsc$data                        = 'DATA                           ',
    fsc$file_backup                 = 'FILE_BACKUP                    ',
    fsc$legible_data                = 'LEGIBLE_DATA                   ',
    fsc$legible_library             = 'LEGIBLE_LIBRARY                ',
    fsc$legible_scl_include         = 'LEGIBLE_SCL_INCLUDE            ',
    fsc$legible_scl_job             = 'LEGIBLE_SCL_JOB                ',
    fsc$legible_scl_procedure       = 'LEGIBLE_SCL_PROCEDURE          ',
    fsc$list                        = 'LIST                           ',
    fsc$object_data                 = 'OBJECT_DATA                    ',
    fsc$object_library              = 'OBJECT_LIBRARY                 ',
    fsc$screen_form                 = 'SCREEN_FORM                    ',
    fsc$source_map                  = 'SOURCE_MAP                     ',
    fsc$unknown_contents            = 'UNKNOWN                        ';
?? FMT (FORMAT := ON) ??

*DECK DECK=FSC$FILE_PROCESSOR EXPAND=FALSE

{ The following are NOS/VE system conventions for referring to the}
{ processor of a file:

?? FMT (FORMAT := OFF) ??
 CONST
    fsc$unknown_processor           = 'UNKNOWN                        ',
    fsc$Ada                         = 'ADA                            ',
    fsc$apl                         = 'APL                            ',
    fsc$assembler                   = 'ASSEMBLER                      ',
    fsc$basic                       = 'BASIC                          ',
    fsc$c                           = 'C                              ',
    fsc$cobol                       = 'COBOL                          ',
    fsc$cybil                       = 'CYBIL                          ',
    fsc$debugger                    = 'DEBUGGER                       ',
    fsc$decrypt_file                = 'DECRYPT_FILE                   ',
    fsc$fortran                     = 'FORTRAN                        ',
    fsc$lisp                        = 'LISP                           ',
    fsc$pascal                      = 'PASCAL                         ',
    fsc$pli                         = 'PLI                            ',
    fsc$ppu_assembler               = 'PPU_ASSEMBLER                  ',
    fsc$prolog                      = 'PROLOG                         ',
    fsc$scl                         = 'SCL                            ',
    fsc$scu                         = 'SCU                            ',
    fsc$vx                          = 'VX                             ';
?? FMT (FORMAT := ON) ??

*DECK DECK=FSC$FILE_SYSTEM_ID EXPAND=FALSE
 CONST
    fsc$file_system_id = 'FS';
*DECK DECK=FSC$INTERNAL_CONDITIONS_MAX EXPAND=FALSE

  CONST
    fsc$internal_conditions_max = 18;
*DECK DECK=FSC$LOCAL EXPAND=FALSE

  CONST
    fsc$local = '$LOCAL',
    fsc$local_size = 6;
*DECK DECK=FSC$LONGEST_WAIT_TIME EXPAND=FALSE
 CONST
*IF NOT $true(osv$unix)
    fsc$longest_wait_time = 0ffffffff(16);
*ELSE
    fsc$longest_wait_time = 7fffffff(16);
*IFEND
*DECK DECK=FSC$MAXIMUM_COPY_FILE_PUSH EXPAND=FALSE
{deck - FSC$MAXIMUM_COPY_FILE_PUSH}
  CONST
    fsc$maximum_copy_file_push = 4000(16); {16k bytes}
*DECK DECK=FSC$MAXIMUM_CYCLE_NUMBER EXPAND=FALSE
 CONST
    fsc$maximum_cycle_number = 65535;
*DECK DECK=FSC$MAX_ATTACH_CHOICE EXPAND=FALSE
const
    fsc$max_attach_choice = 255;
*DECK DECK=FSC$MAX_CYCLE_ATTRIBUTE EXPAND=FALSE
 CONST
    fsc$max_cycle_attribute = 255;
*DECK DECK=FSC$MAX_DETACH_CHOICE EXPAND=FALSE

  CONST
    fsc$max_detach_choice = 255;
*DECK DECK=FSC$MAX_DEVICE_ATTRIBUTE EXPAND=FALSE

  CONST
    fsc$max_device_attribute = 255;

*DECK DECK=FSC$MAX_FILE_ATTRIBUTE EXPAND=FALSE

  CONST
    fsc$max_file_attribute = 255;
*DECK DECK=FSC$MAX_FILE_CHANGE EXPAND=FALSE

  CONST
    fsc$max_file_change = 255;
*DECK DECK=FSC$MAX_PATH_ELEMENTS EXPAND=FALSE

  CONST
    fsc$max_path_elements = fsc$max_path_size DIV 2;

*copyc fsc$max_path_size
*DECK DECK=FSC$MAX_PATH_ELEMENT_SIZE EXPAND=FALSE

  CONST
*IF NOT $true(osv$unix)
    fsc$max_path_element_size = osc$max_name_size;

*copyc ost$name
*ELSE
    fsc$max_path_element_size = 255;
*IFEND
*DECK DECK=FSC$MAX_PATH_SIZE EXPAND=FALSE

  CONST
*IF NOT $true(osv$unix)
    fsc$max_path_size = 512;
*ELSE
    fsc$max_path_size = 1023;
*IFEND
*DECK DECK=FSC$MAX_TAPE_ATTACH_CHOICE EXPAND=FALSE

  CONST
    fsc$max_tape_attach_choice = 255;
*DECK DECK=FSC$MAX_TAPE_LABELS EXPAND=FALSE
  CONST
    fsc$max_tape_labels = 128;
*DECK DECK=FSC$MAX_TAPE_LABEL_BLOCK_TYPE EXPAND=FALSE
  CONST
    fsc$max_tape_label_block_type = 255;
*DECK DECK=FSC$MAX_TAPE_LABEL_LENGTH EXPAND=FALSE
  CONST
    fsc$max_tape_label_length = 4128;
*DECK DECK=FSC$MAX_TAPE_LABEL_LOC_METHOD EXPAND=FALSE
  CONST
    fsc$max_tape_label_loc_method = 255;
*DECK DECK=FSC$MAX_TAPE_SECURITY_OPERATION EXPAND=FALSE
  CONST
    fsc$max_tape_security_operation = 255;

*DECK DECK=FSC$MAX_TEMP_FILE_PATH_SIZE EXPAND=FALSE

  CONST
    fsc$max_temp_file_path_size = 63;
*DECK DECK=FSC$MAX_USER_ATTRIB_SEQUENCE EXPAND=TRUE

  CONST
    fsc$max_user_attrib_sequence = 65535;
*DECK DECK=FSC$MIN_TAPE_LABEL_LENGTH EXPAND=FALSE
  CONST
    fsc$min_tape_label_length = 80;
*DECK DECK=FSC$VERSION_ONE_VE_IDENTIFIER EXPAND=FALSE

  CONST
    fsc$version_one_ve_identifier = 'NOS/VE V1.0  ';

*DECK DECK=FSC$VERSION_TWO_VE_IDENTIFIER EXPAND=FALSE

  CONST
    fsc$version_two_ve_identifier = 'NOS/VE V2.0  ';

*DECK DECK=FSC$WAIT_CATALOG_MISSING EXPAND=FALSE
*DECK DECK=FSC$WAIT_CATALOG_UNAVAILABLE EXPAND=FALSE
*DECK DECK=FSC$WAIT_CYCLE_BUSY EXPAND=FALSE
  CONST
    fsc$wait_cycle_busy = 'WAIT_CYCLE_BUSY                ';

*DECK DECK=FSC$WAIT_DATA_RESTORATION EXPAND=FALSE
  CONST
    fsc$wait_data_restoration = 'WAIT_DATA_RESTORATION          ';

*DECK DECK=FSC$WAIT_FILE_MISSING EXPAND=FALSE
*DECK DECK=FSC$WAIT_FILE_UNAVAILABLE EXPAND=FALSE
*DECK DECK=FSC$WAIT_FOR_RETRIEVAL EXPAND=FALSE
  CONST
    fsc$wait_for_retrieval = 'WAIT_FOR_RETRIEVAL             ';

*DECK DECK=FSC$WAIT_FOR_SPACE EXPAND=FALSE
  CONST
    fsc$wait_for_space = 'WAIT_FOR_SPACE             ';

*DECK DECK=FSC$WAIT_MSG_MODULE_NAME EXPAND=FALSE
  CONST
    fsc$wait_msg_module_name = 'FSM$WAIT_MESSAGES              ';

*DECK DECK=FSC$WAIT_SERVER_INACTIVE EXPAND=FALSE
  CONST
    fsc$wait_server_inactive = 'WAIT_SERVER_INACTIVE           ';

*DECK DECK=FSC$WAIT_UNDEFINED_CONDITION EXPAND=FALSE
  CONST
    fsc$wait_undefined_condition = 'WAIT_UNDEFINED_CONDITION       ';
*DECK DECK=FSC$WAIT_VOLUME_MISSING EXPAND=FALSE
  CONST
    fsc$wait_volume_missing = 'WAIT_VOLUME_MISSING            ';

*DECK DECK=FSC$WAIT_VOLUME_UNAVAILABLE EXPAND=FALSE
  CONST
    fsc$wait_volume_unavailable = 'WAIT_VOLUME_UNAVAILABLE        ';

*DECK DECK=FSD$ANSI_LABEL_IDENTIFIERS EXPAND=FALSE
  CONST
    fsc$ansi_eof_label_identifier = 'EOF',
    fsc$ansi_eov_label_identifier = 'EOV',
    fsc$ansi_hdr_label_identifier = 'HDR',
    fsc$ansi_uhl_label_identifier = 'UHL',
    fsc$ansi_utl_label_identifier = 'UTL',
    fsc$ansi_uvl_label_identifier = 'UVL',
    fsc$ansi_vol_label_identifier = 'VOL';
*DECK DECK=FSE$ATTACH_VALIDATION_ERRORS EXPAND=FALSE
*copyc fsc$condition_code_limits
?? NEWTITLE := 'attach validation                : ''FS''  10 .. 19', EJECT ??

?? FMT (FORMAT := OFF) ??

      { fse$attach_validation_errors }

   CONST
     fsc$min_ecc_attach_validation   = fsc$min_ecc_validation + 10,

     fse$redundant_attachment_choice = fsc$min_ecc_attach_validation + 0,
         {E File +F1 : +P8 and +P9 cannot both be specified for the same..
         { instance of open.}

     fse$invalid_attachment_spec = fsc$min_ecc_attach_validation + 2,
         {E File +F1 : +P8 is not allowed on the ATTACH_FILE command..
         { for a file with a device class of +P9.}

     fse$invalid_volume_list = fsc$min_ecc_attach_validation + 3,
         {E File +F1 : The volume list specified on the ATTACH_FILE..
         { command is inconsistent with the volume list of the file.}

     fse$redundant_attachment_spec = fsc$min_ecc_attach_validation + 5,
         {E File +F1 : The specification of +P8 is inconsistent with..
         { a previous specification of the ATTACH_FILE command.}

     fse$tape_attach_limit_exceeded = fsc$min_ecc_attach_validation + 7,
         {E File +F1 : exceeds the limit of +P2 tape files which may..
         { be attached concurrently by a job.}
         {+N3 Use detach_file to reduce the number of attached tape..
         { files.}

     fsc$max_ecc_attach_validation   = fsc$min_ecc_attach_validation + 9;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=FSE$CLOSE_VALIDATION_ERRORS EXPAND=FALSE
*copyc fsc$condition_code_limits
?? NEWTITLE := 'close validation                 : ''FS''  40 .. 49', EJECT ??

?? FMT (FORMAT := OFF) ??

      { fse$close_validation_errors }

   CONST
     fsc$min_ecc_close_validation   = fsc$min_ecc_validation + 40,

     fse$close_of_target_not_allowed= fsc$min_ecc_close_validation + 0,
         {E File +F1 cannot be closed because it is the target of a file..
         { connection.}

     fsc$max_ecc_close_validation    = fsc$min_ecc_close_validation + 9;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=FSE$CONDITION_CODES EXPAND=FALSE
?? NEWTITLE := 'File System Conditions' ??
*copyc FSC$CONDITION_CODE_LIMITS
*copyc FSE$ATTACH_VALIDATION_ERRORS
*copyc FSE$OPEN_VALIDATION_ERRORS
*copyc FSE$CLOSE_VALIDATION_ERRORS
*copyc FSE$COPY_VALIDATION_ERRORS
*copyc FSE$GET_INFO_VALIDATION_ERRORS
*copyc FSE$PATH_EXCEPTION_CONDITIONS
*copyc FSE$SYSTEM_CONDITIONS
?? OLDTITLE ??

*DECK DECK=FSE$COPY_VALIDATION_ERRORS EXPAND=FALSE
*copyc FSC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'fse$copy_validation_errors       : ''FS'' 50 .. 99', EJECT ??

?? FMT (FORMAT := OFF) ??

     { fse$copy_validation_errors }

   CONST
     fsc$min_ecc_copy_validation     = fsc$min_ecc_validation + 50,

     fse$copy_internal_error         = fsc$min_ecc_copy_validation + 0,
         {E FSP$COPY_FILE internal system error has occurred: +P8.}

     fse$input_file_at_eoi           = fsc$min_ecc_copy_validation + 4,
         {E The input file, +F1, is positioned at end of information.}

     fse$conflicting_file_contents   = fsc$min_ecc_copy_validation + 8,
         {E File contents and/or file structure of the input file, +F1,..
         { conflicts with that of the output file, +F9.}

     fse$statement_idents_unequal    = fsc$min_ecc_copy_validation + 10,
         {E Statement identifier +P8 of the input file, +F1, and the..
         { output file, +F9, are unequal.}

     fse$line_numbers_unequal        = fsc$min_ecc_copy_validation + 12,
         {E Line number +P8 of the input file, +F1, and the output file,..
         { +F9, are unequal.}

     fse$output_record_truncated     = fsc$min_ecc_copy_validation + 14,
         {W One or more records of the output file, +F1, were truncated.}

     fse$empty_input_file            = fsc$min_ecc_copy_validation + 16,
         {E The input file, +F1, is empty.}

     fse$insufficient_record_length  = fsc$min_ecc_copy_validation + 20,
         {E +F1 has insufficient maximum record/block length to..
         { perform requested copy.}

     fse$conflicting_file_addresses  = fsc$min_ecc_copy_validation + 22,
         {E Byte addressable files +F1 and +F9 are not positioned at the..
         { same byte address.}

     fse$improper_fo_for_copy        = fsc$min_ecc_copy_validation + 24,
         {E If +F1 has byte addressable file organization, then..
         { so must file +F9.}

     fse$copy_device_conflict        = fsc$min_ecc_copy_validation + 26,
         {E Byte addressable file +F1 does not reside on mass storage.}

     fse$conflicting_block_types     = fsc$min_ecc_copy_validation + 28,
         {E Byte addressable files +F1 and +F9 do not have the same..
         { block_type.}

     fse$conflicting_record_types    = fsc$min_ecc_copy_validation + 30,
         {E Byte addressable files +F1 and +F9 do not have the same..
         { record type.}

     fse$fap_names_not_identical     = fsc$min_ecc_copy_validation + 32,
         {E Byte addressable files +F1 and +F9 do not have the same..
         { file access procedure name.}

     fse$record_lengths_unequal      = fsc$min_ecc_copy_validation + 34,
         {E Fixed length byte addressable files +F1 and +F9 do not..
         { have the same maximum record length.}

     fse$block_lengths_unequal       = fsc$min_ecc_copy_validation + 36,
         {E Fixed length byte addressable files +F1 and +F9 do not..
         { have the same maximum block length.}

     fse$size_exceeds_output_limits  = fsc$min_ecc_copy_validation + 37,
         {E A byte addressable file cannot be copied if the size of..
         { the input file, +F1, is larger than the size limit of..
         { the output file, +F9.}

     fse$padding_characters_unequal  = fsc$min_ecc_copy_validation + 38,
         {E Fixed length byte addressable files +F1 and +F9 do not..
         { have the same padding character.}

     fse$trailing_characters_unequal  = fsc$min_ecc_copy_validation + 39,
         {E Trailing character delimited/byte addressable files +F1 and +F9..
         { do not have the same trailing character.}

     fse$from_list_input_unsupported = fsc$min_ecc_copy_validation + 40,
         {E If the input file, +F1, has undefined record type and system..
         { specified blocking, then it cannot have file contents of list.}

     fse$to_list_output_unsupported  = fsc$min_ecc_copy_validation + 42,
         {E If the output file, +F1, has undefined record type and system..
         { specified blocking, then it cannot have file contents of list.}

     fse$to_list_input_unsupported   = fsc$min_ecc_copy_validation + 44,
         {E If the input file, +F1, has undefined record type and system..
         { specified blocking, then the output file, +F9, cannot have file..
         { contents of list.}

     fse$output_structure_truncated  = fsc$min_ecc_copy_validation + 46,
         {W The FILE_STRUCTURE of the output file, +F1, has been truncated..
         { as a result of FSP$COPY_FILE. ..
         {+N  ORIGINAL FILE_CONTENTS  = "+P8". ..
         {+N  ORIGINAL FILE_STRUCTURE = "+P9".}

     fsc$max_ecc_copy_validation     = fsc$min_ecc_copy_validation + 49;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=FSE$CREATE_VALIDATION_ERRORS EXPAND=FALSE
*copyc fsc$condition_code_limits
?? NEWTITLE := 'create validation                : ''FS''  120 .. 129', EJECT ??

?? FMT (FORMAT := OFF) ??

  CONST
    fsc$min_ecc_create_validation   = fsc$min_ecc_validation + 120,

    fse$improper_device_class_value = fsc$min_ecc_create_validation + 0,
     {E File +F1 : DEVICE_CLASS parameter of +P2 is improper.}

    fse$improper_rem_media_group    = fsc$min_ecc_create_validation + 1,
     {E File +F1 : REMOVABLE_MEDIA_GROUP parameter of +P2 is improper.}

    fsc$max_ecc_create_validation   = fsc$min_ecc_create_validation + 129;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=FSE$GET_INFO_VALIDATION_ERRORS EXPAND=FALSE
*copyc FSC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'fse$get_info_validation_errors   : ''FS'' 100 .. 119', EJECT ??

?? FMT (FORMAT := OFF) ??

     { fse$get_info_validation_errors }

   CONST
     fsc$min_ecc_get_info_validation = fsc$min_ecc_validation + 100,

     fse$get_file_info_internal      = fsc$min_ecc_get_info_validation + 0,
         {E File information retrieval - internal system error has..
         { occurred: +P8.}

     fse$file_contents_replaced      = fsc$min_ecc_get_info_validation + 1,
         {W File +F1: The current value of the FILE_CONTENTS attribute, +P8,..
         { has been replaced with the value UNKNOWN.

     fse$file_contents_truncated     = fsc$min_ecc_get_info_validation + 2,
         {W File +F1: The current value of the FILE_CONTENTS attribute has..
         { been truncated as a result of the merging of FILE_CONTENTS and..
         { FILE_STRUCTURE in +P2. ..
         {+N  ORIGINAL FILE_CONTENTS  = "+P8". ..
         {+N  ORIGINAL FILE_STRUCTURE = "+P9".}

     fse$file_structure_discarded    = fsc$min_ecc_get_info_validation + 3,
         {W File +F1: The specified value of the FILE_STRUCTURE attribute,..
         { +P8, has been discarded.

     fse$file_structure_replaced     = fsc$min_ecc_get_info_validation + 4,
         {W File +F1: The current value of the FILE_STRUCTURE attribute, +P8,..
         { has been replaced with the value +P9.

     fse$insufficient_sequence_size  = fsc$min_ecc_get_info_validation + 5,
         {E The +P8 sequence passed to +P2 for the file, +F1, is insufficient..
         { in size for the requested operation.}

     fse$attributes_not_defined      = fsc$min_ecc_get_info_validation + 7,
         {E None of the requested attributes is defined for +F1.}

     fse$attribute_not_available     = fsc$min_ecc_get_info_validation + 9,
         {E The requested attribute, +P1, is not available because you are..
         { not the owner of file, +F2.}

     fse$file_contents_not_converted = fsc$min_ecc_get_info_validation + 11,
         {E FILE_CONTENTS, +P8, and FILE_STRUCTURE, +P9, could not be..
         { converted to a supported keyword value.

     fse$file_structure_ignored      = fsc$min_ecc_get_info_validation + 12,
         {W The specified value for FILE_STRUCTURE, +P8, was ignored.

     fsc$max_ecc_get_info_validation = fsc$min_ecc_get_info_validation + 19;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=FSE$OPEN_VALIDATION_ERRORS EXPAND=FALSE
*copyc fsc$condition_code_limits
?? NEWTITLE := 'fsp$open_file validation         : ''FS'' 0 .. 9', EJECT ??

?? FMT (FORMAT := OFF) ??

      { fse$open_validation_errors }

   CONST
     fsc$min_ecc_attrib_validation   = fsc$min_ecc_validation + 0,

     fse$cannot_open_catalogs        = fsc$min_ecc_attrib_validation + 1,
         {E +P1 cannot be opened - only files can be opened.}

     fse$device_class_conflict = fsc$min_ecc_attrib_validation + 2,
         {E File +F1 has a device class of +P8 which conflicts with the..
         { allowed device classes.}

     fse$concurrent_access_conflict  = fsc$min_ecc_attrib_validation + 3,
         {E File +F1 : An outstanding instance of open authorizes access for ..
         { +P8 which conflicts with the specified access modes of +P9.}

     fse$concurrent_share_conflict   = fsc$min_ecc_attrib_validation + 5,
         {E File +F1 : The specified open share modes of +P8 do not include..
         { the access_modes of +P9 specified by outstanding instances of open.}

     fse$redundant_attach_conflict   = fsc$min_ecc_attrib_validation + 6,
         {E File +F1 is already attached to this job for access modes and..
         { required share modes which conflict with the specified modes of..
         { access or share.}

     fse$open_already_in_progress    = fsc$min_ecc_attrib_validation + 7,
         {E File +F1 is already in the process of being opened by this task.}

     fse$improper_private_read       = fsc$min_ecc_attrib_validation + 8,
         {E File +F1 : Specifying private_read as true is improper for this..
         { instance of open because the access_mode is not READ or..
         { (READ, EXECUTE).}

     fsc$max_ecc_attrib_validation   = fsc$min_ecc_attrib_validation + 9;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=FSE$PATH_EXCEPTION_CONDITIONS EXPAND=FALSE
*copyc fsc$condition_code_limits
?? NEWTITLE := 'FS Path Exception Condition Codes : ''FS'' 30 .. 39', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    fsc$min_path_ecc = fsc$min_ecc_validation + 30,
    fsc$max_path_ecc = fsc$min_path_ecc + 9,

    fse$catalogs_do_not_have_cycles = fsc$min_path_ecc + 1,
    {E A cycle reference was specified for catalog "+F", but catalogs do not}
    { have cycles.}

    fse$illegal_alias_name = fsc$min_path_ecc + 2,
    {E +F is not an allowed value for an LFN +P1.}

    fse$local_files_have_no_pw = fsc$min_path_ecc + 3,
    {E A password was specified for file +F, but $LOCAL files cannot have}
    { passwords.}

    fse$local_subcatalog_illegal = fsc$min_path_ecc + 4,
    {E $LOCAL cannot have subcatalogs.}

    fse$system_master_catalog = fsc$min_path_ecc + 7;
    {W The system master catalog was specified.}

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=FSE$SYSTEM_CONDITIONS EXPAND=FALSE
*copyc fsc$condition_code_limits
?? NEWTITLE := 'FS System Condition Codes : ''FS'' 20 .. 29', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    fsc$min_system_ecc = fsc$min_ecc_validation + 20,
    fsc$max_system_ecc = fsc$min_system_ecc + 9,

    fse$system_error = fsc$min_system_ecc,
    {E An unrecoverable error internal to the fs system has occurred.}
    {  +P1 +P2 +P3 +P4 +P5 +P6 +P7 +P8 +P9}

    fse$temp_files_limit_reached = fsc$min_system_ecc + 1;
    {E The maximum number of temporary files allowed has been reached.  Some}
    { temporary files should be deleted before continuing.}

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??

*DECK DECK=FSE$VXVE_EXCEPTION_CONDITIONS EXPAND=FALSE
*copyc fsc$condition_code_limits
*copyc fsc$file_system_id
?? NEWTITLE := 'FS VX/VE Condition Codes : ''FS'' 4990 .. 4999', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    fsc$min_vxve_ecc = fsc$min_ecc_validation + 4990,
    fsc$max_vxve_ecc = fsc$min_vxve_ecc + 9,

    fse$unallowed_future_date_time = fsc$min_vxve_ecc;
    {E The +P1 parameter specifies a future date or time.}

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=FSH$ANALYZE_FILE_EXPIRATION EXPAND=FALSE
{
{    The purpose of this procedure is to analyze the value of an ANSI
{ expiration date to determine whether it is prior to or equal to today's date.
{ If it is, the file is considered expired.
{
{       FSP$ANALYZE_FILE_EXPIRATION ( EXPIRATION_DATE, FILE_IS_EXPIRED, STATUS)
{
{
{
{    EXPIRATION_DATE: (input)  This parameter specifies a date whose syntax is
{          that defined by the American National Standard for Information
{          Systems (ANSI) X3.27-1987 standard File Structure and Labeling of
{          Magnetic Tapes for Information Interchange.
{
{    FILE_IS_EXPIRED: (output)  This parameter identifies whether or not the
{          specified expiration date is the same as, earlier than, or later
{          than today's date.
{
{          The value TRUE is returned, if the expiration date is prior to or
{          equal to today's date.
{
{          The value FALSE is returned, if the expiration date is after today's
{          date.
{
{    STATUS:  (output) This parameter specifies the status of the request.
{
*DECK DECK=FSH$CHANGE_CATALOG_FLUSH_OPTION EXPAND=FALSE
{   The purpose of this request is to control the subsequent flushing of
{ catalogs within the requesting job.
{
{       FSP$CHANGE_CATALOG_FLUSH_OPTION (FLUSH_CATALOGS, STATUS)
{
{ FLUSH_CATALOGS: (input)  This parameter specifies whether or not pages of a
{       modified catalog are to be written out after the catalog is updated.
{
{       If TRUE is specified, modified catalog pages are forced to mass storage
{       immediately after the catalog transaction is completed; however, the
{       task that requested the catalog update is given control back before the
{       catalog I/O completes.  If the catalog is again referenced before the
{       I/O completes, the new accessor waits for any pages that are being
{       written out, if those pages are referenced by the new accessor.
{
{       If FALSE is specified, modified catalog pages are not forced to mass
{       storage immediately after the catalog transaction is completed.
{       Catalog pages are kept in the SHARED_DEVICE_FILE queue.  The duration
{       of time that modified catalog pages will remain in memory is tunable.
{
{       It is recommended that a site select TRUE for catalog flushing.
{       However, if the site has an Uninterruptable Power Supply (UPS), catalog
{       flushing may be turned off at the site's discretion, if the performance
{       of catalog access is a problem.  If a site turns off catalog flushing,
{       the value of the MINIMUM_SIZE attribute of the SHARED_DEVICE_FILE queue
{       should be set to 0 (the default) to ensure that all modified catalog
{       pages are ultimately recorded on mass storage.
{
{       If an application makes repetitive updates to the same catalog,
{       performance may be improved by turning off catalog flushing prior to
{       beginning the sequence of updates.  Once the update sequence is
{       completed, it is strongly recommended that the catalog be flushed using
{       FSP$FLUSH_CATALOG.  If a catalog becomes inconsistent on mass storage
{       and NOS/VE's memory image is lost, an entire catalog subtree may become
{       lost or inaccessible.
{
{ Status: (output)  This parameter specifies the request status.
{
*DECK DECK=FSH$CHANGE_CYCLE_DAMAGE EXPAND=FALSE
{       FSP$CHANGE_CYCLE_DAMAGE
{
{   The purpose of this procedure is to change the damage symptoms for an
{ existing file cycle.
{
{   Any change to or from a set which does not contain one of the following
{ damage symptoms, (fsc$catalog_path_missing, fsc$file_label_damaged,
{ fsc$media_missing, fsc$respf_modification_mismatch), is allowed, including
{ the NULL set.  The requestor must have control permission to the file.
{
{       FSP$CHANGE_CYCLE_DAMAGE (FILE, PASSWORD, NEW_DAMAGE_SYMPTOMS, STATUS)
{
{ FILE: (input) This parameter specifies the name of the file cycle whose
{       damage symptoms are to be modified.  The cycle reference must be
{       capable of being resolved to an existing cycle or an abnormal status
{       will be returned; therefore, this parameter may not specify a $NEXT
{       cycle reference.
{
{ PASSWORD: (input) This parameter specifies the password of the file.  If the
{       file is not password protected, then osc$null_name must be specified.
{
{ NEW_DAMAGE_SYMPTOMS: (input) This parameter specifies the new damage
{       symptoms for the file cycle specified by the file parameter.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=FSH$CHANGE_CYCLE_DATE_TIME EXPAND=FALSE
{       FSP$CHANGE_CYCLE_DATE_TIME
{
{   The purpose of this procedure is to change the access date and time and/or
{ the modification date and time for an existing file cycle.
{
{       FSP$CHANGE_CYCLE_DATE_TIME (FILE, PASSWORD, NEW_ACCESS_DATE_TIME,
{                                   NEW_MODIFICATION_DATE_TIME, STATUS)
{
{ FILE: (input) This parameter specifies the name of the file cycle whose
{       access date and time and/or modification date and time is to be
{       changed.  The cycle reference must be capable of being resolved to an
{       existing cycle or an abnormal status will be returned; therefore, this
{       parameter must not specify a $NEXT cycle reference.
{
{ PASSWORD: (input) This parameter specifies the password of the file.  If the
{       file is not password protected, then osc$null_name must be specified.
{
{ NEW_ACCESS_DATE_TIME: (input) This parameter specifies the new access date
{       and time for the file cycle.  If the value, NIL, is specified, then no
{       change to the access date and time is made.  A future date or time
{       must not be specified.  The requestor must have permission to the file.
{
{ NEW_MODIFICATION_DATE_TIME: (input) This parameter specifies the new
{       modification date and time for the file cycle.  If the value, NIL, is
{       specified, then no change to the modification date and time is made.
{       A future date or time must not be specified.  The requestor must have
{       one or more of the following forms of permission to the file:
{       (control, cycle, shorten, modify, or append).
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS: fse$unallowable_future_date_time
{                   pfe$unknown_cycle
{                   pfe$usage_not_allowed
{
*DECK DECK=FSH$CHANGE_FILE EXPAND=FALSE
{
{    The purpose of this request is to alter the permanent file name, cycle
{ number, password, log selection, retention period, charge attributes, damage
{ conditions, retrieve option, shared queue, site archive option, site backup
{ option and site release option associated with a permanent file.  The
{ permanent file name, password, log selection and charge identifications are
{ attributes which are common to all cycles of a permanent file.  The cycle
{ number, retention period, damage conditions, retrieve option, shared queue,
{ site archive option, site backup option and site release option are
{ attributes which are unique for each cycle of a permanent file.
{
{    This request can only be issued by a user with CONTROL permission.
{
{       FSP$CHANGE_FILE (FILE, PASSWORD, CHANGE_LIST, STATUS)
{
{ FILE: (input)  This parameter specifies the name of the file cycle whose
{       attributes are to be changed.  The cycle reference must be capable of
{       being resolved to an existing cycle or an abnormal status will be
{       returned; therefore, this parameter must not specify a $NEXT cycle
{       reference.
{
{ PASSWORD: (input)  This parameter specifies a password that must match the
{       password registered with the file.  If a blank password is specified,
{       it will only match if no password was registered with the file.
{
{ FILE_CHANGES: (input)  This parameter specifies an array of change
{       descriptors.  Each change descriptor specifies which attribute is to be
{       changed and what the new value of the attribute is to be.  The
{       attributes that can be changed are:  permanent file name, cycle number,
{       password, log selection, retention period, charge attributes, damage
{       conditions, retrieve option, shared queue, site archive option, site
{       backup option and site release option.  If a charge change is
{       specified, the account and project of the job making the request will
{       be used as the new ones to be charged for the file.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$bad_change_type
{                    pfe$bad_cycle_number
{                    pfe$bad_cycle_option
{                    pfe$bad_family_name
{                    pfe$bad_log_option
{                    pfe$bad_master_catalog_name
{                    pfe$bad_nth_subcatalog_name
{                    pfe$bad_password
{                    pfe$bad_permanent_file_name
{                    pfe$bad_permanent_file_name
{                    pfe$bad_retention_period
{                    pfe$catalog_full
{                    pfe$change_requires_privilege
{                    pfe$duplicate_cycle
{                    pfe$incorrect_damage_condition
{                    pfe$incorrect_password
{                    pfe$name_already_permanent_file
{                    pfe$name_already_subcatalog
{                    pfe$name_already_used
{                    pfe$name_not_permanent_file
{                    pfe$no_site_option_validation
{                    pfe$nth_name_not_subcatalog
{                    pfe$path_too_short
{                    pfe$pf_system_error
{                    pfe$unknown_cycle
{                    pfe$unknown_family
{                    pfe$unknown_master_catalog
{                    pfe$unknown_nth_subcatalog
{                    pfe$unknown_permanent_file
{                    pfe$usage_not_permitted
{
{        IDENTIFIER: pfc$permanent_file_manager_id
{
*DECK DECK=FSH$CHANGE_SEGMENT_NUMBER EXPAND=FALSE
{
{   The purpose of this request is to associate a previously opened file with a
{ different segment number than the one assigned by fsp$open_file.
{
{   The following assumptions prevail when using this interface:
{
{    1.  The proposed segment number is not currently a valid segment in the
{        task's address space.
{
{    2.  The file has previously been opened by the task and the
{        file_identifier from that open has been passed to this request.
{
{    3.  All of the access constraints imposed on the instance of open will be
{        carried forth to the new segment number.
{
{    4.  The validation_ring must be <= to the ring of the caller of the
{        fsp$open_file request which originated this instance of open and must
{        be >= the ring of the caller of this request.
{
{    5.  The segment number originally assigned to the instance of open of this
{        file will be freed.
{
{    6.  The SEGMENT_POINTER will be initialized exactly the way it would have
{        been had the task called AMP$GET_SEGMENT_POINTER directly.  In fact,
{        subsequent calls to AMP$GET_SEGMENT_POINTER will return the newly
{        assigned segment number in the pointer.  The VALIDATION_RING will be
{        used to initialize the PVA.RING portion of the SEGMENT_POINTER.
{
{    7.  All future requests such as AMP$SET_SEGMENT_EOI and
{        AMP$SET_SEGMENT_POSITION will require the SEGMENT_POINTER as input.
{
{    8.  If there is a FILE_ACCESS_PROCEDURE associated with the file which is
{        the object of this request the FAP may fail if it accesses a stale
{        segment pointer.
{
{    9.  This request is valid only for mass storage files.
{
{
{       FSP$CHANGE_SEGMENT_NUMBER (FILE_IDENTIFIER, NEW_SEGMENT_NUMBER,
{         VALIDATION_RING, POINTER_KIND, SEGMENT_POINTER, STATUS)
{
{  FILE_IDENTIFIER: (input)  This parameter specifies the file access
{        identifier established when the file whose segment number is to be
{        changed was opened.
{
{  NEW_SEGMENT_NUMBER: (input)  This parameter specifies the proposed new
{        number for the segment in this task's address space.
{
{  VALIDATION_RING: (input)  This parameter specifies the ring number to be
{        used to validate the change in the segment number for this instance of
{        open.
{
{  POINTER_KIND: (input)  This parameter specifies the kind of pointer to be
{        returned by this request.
{
{  SEGMENT_POINTER: (output)  This parameter specifies a segment pointer
{        containing the new segment number.  The kind of pointer is determined
{        by the POINTER_KIND parameter.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITION:
{                  ame$improper_device_class
{                  ame$improper_file_id
{                  ame$ring_validation_error
{                  ame$improper_pointer_kind
{                  ame$read_of_empty_segment
{                  ame$write_of_empty_segment
*DECK DECK=FSH$CLASSIFY_TAPE_LABEL EXPAND=FALSE
{
{    The purpose of this request is to classify a raw tape label.  If the label
{ is valid, the label identifier (characters 1 thru 3), label number
{ (character 4), label kind (an ordinal) and the character set (ASCII or EBCDIC)
{ are returned.
{
{       FSP$CLASSIFY_FILE_LABEL (LABEL_STRING, LABEL_CLASSIFICATION)
{
{ LABEL_STRING: (input)  This parameter specifies an adaptable string which
{       contains the raw label.
{
{ LABEL_CLASSIFICATION: (output)  This parameter specifies the classification
{       that is returned for the label.
{
*DECK DECK=FSH$CLOSE_FILE EXPAND=FALSE
{
{   The purpose of this request is to terminate file access. The
{ file_identifier is invalidated by this request.
{   If the file had been initially attached to the job by a previous
{ fsp$open_file request, then this request will detach the file if the last
{ instance of open of the file is being closed.
{   For a file associated with tape, the file and volume are terminated
{ according to convention, if the preceding operation was an output to the
{ tape. If the label_type is amc$labelled, the standard ANSI EOF label
{ and two tapemarks are written; then the tape volume is positioned by close
{ between the two tapemarks. For an amc$unlabelled file, two
{ tapemarks are written to terminate the file and volume; then the volume
{ is positioned by close prior to the two tapemarks.
{
{       FSP$CLOSE_FILE (FILE_IDENTIFIER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ STATUS: (output) This parameter specifies the request status
{       CONDITION:  ame$improper_file_id,
{                   ame$ring_validation_error,
{                   ame$unrecovered_write_error.
{       IDENTIFIER: fsc$file_system_id.
{

*DECK DECK=FSH$CONVERT_FILE_CONTENTS EXPAND=FALSE
{   The purpose of this request is to convert the individual FILE_CONTENTS and
{ FILE_STRUCTURE fields returned by AMP$FETCH and AMP$GET_FILE_ATTRIBUTES into
{ a single name that can be used as input to FSP$OPEN_FILE.
{
{   The following mappings of FILE_CONTENTS and FILE_STRUCTURE are supported.
{ Any other values of FILE_CONTENTS and FILE_STRUCTURE return abnormal status.
{
{           FILE_          FILE_            CONVERTED_
{           CONTENTS       STRUCTURE        FILE_CONTENTS
{           -----------------------------------------------------
{           ASCII_LOG      DATA             ASCII_LOGG
{           BINARY_LOG     DATA             BINARY_LOG
{           UNKNOWN        DATA             DATA
{           FILE_BACKUP    DATA             FILE_BACKUP
{           LEGIBLE        DATA             LEGIBLE_DATA
{           LEGIBLE        UNKNOWN          LEGIBLE_DATA
{           LEGIBLE        LIBRARY          LEGIBLE_LIBRARY
{           LEGIBLE        SCL_INCLUDE      LEGIBLE_SCL_INCLUDERE
{           LEGIBLE        SCL_JOB          LEGIBLE_SCL_JOB
{           LEGIBLE        SCL_PROCEDURE    LEGIBLE_SCL_PROCEDURE
{           LIST           DATA             LIST
{           LIST           UNKNOWN          LIST
{           OBJECT         DATA             OBJECT_DATA
{           OBJECT         LIBRARY          OBJECT_LIBRARY
{           SCREEN         FORM             SCREEN_FORM
{           SOURCE_MAP     UNKNOWN          SOURCE_MAP
{           UNKNOWN        UNKNOWN          UNKNOWN
{           <name>         UNKNOWN          <name>
{
{ FILE_CONTENTS: (input)  This parameter specifies the value of FILE_CONTENTS
{       provided by AMP$FETCH or AMP$GET_FILE_ATTRIBUTES.
{
{ FILE_STRUCTURE: (input)  This parameter specifies the value of FILE_STRUCTURE
{       provided by AMP$FETCH or AMP$GET_FILE_ATTRIBUTES.
{
{ CONVERTED_FILE_CONTENTS: (output)  This parameter specifies the value of
{       FILE_CONTENTS derived from the individual FILE_CONTENTS and
{       FILE_STRUCTURE parameters.  This value may be used as input to
{       FSP$OPEN_FILE, the CHANGE_FILE_ATTRIBUTES command or the
{       SET_FILE_ATTRIBUTES command.
{
{ STATUS: (output) This parameter specifies the request status.  If you obtain
{ the values of FILE_CONTENTS and FILE_STRUCTURE from either AMP$FETCH or
{ AMP$GET_FILE_ATTRIBUTES, this request should never return
{ FSE$FILE_STRUCTURE_IGNORED.  However, if the values are obtained from a user
{ or you supply your own values, the (WARNING) status
{ FSE$FILE_STRUCTURE_IGNORED may be returned.  If FSE$FILE_STRUCTURE_IGNORED
{ is returned, a value is also returned for the CONVERTED_FILE_CONTENTS
{ parameter; you may ignore this abnormal status at your discretion.
{
{          Conditions:
{                     FSE$FILE_STRUCTURE_IGNORED
{                     FSE$FILE_CONTENTS_NOT_CONVERTED
*DECK DECK=FSH$COPY_DATA_AND_CLOSE_FILES EXPAND=FALSE
{
{   The purpose of this request is to copy one file to another.
{   The copy terminates when end of information (EOI) is reached on the
{ input file or if the input file is an unlabelled tape file, the copy
{ terminates when a tapemark is encountered on the input file.  If an
{ unlabelled tape contains data followed by a single tapemark then more
{ data followed by another single tapemark, etc., this request must be issued
{ once for each data set terminated by a tapemark in order to obtain a
{ complete copy of the information on the input file.  This request does not
{ copy single tapemarks; however a tape volume is always terminated according
{ to convention.
{
{
{     FSP$COPY_DATA_AND_CLOSE_FILES (INPUT_FID, OUTPUT_FID, CONTROL_INFO, STATUS)
{
{ INPUT_FID: (input) This parameter specifies the file_identifier returned by
{     FSP$OPEN_AND_GET_TYPE_OF_COPY.
{
{ OUTPUT_FID: (input) This parameter specifies the file_identifier returned by
{     FSP$OPEN_AND_GET_TYPE_OF_COPY.
{
{ CONTROL_INFO: (input) This parameter specifies the control information returned by
{     FSP$OPEN_AND_GET_TYPE_OF_COPY.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{                   aae$altkey_part_negative_pos,
{                   aae$cant_copy_several_nfs_to_1,
{                   aae$cant_replace_main_file,
{                   aae$copying_attributes_only,
{                   aae$copying_ek_to_non_ek,
{                   aae$copying_non_ek_to_ek,
{                   aae$main_file_will_be_used,
{                   aae$merge_with_emb_key_chg,
{                   aae$partial_copy_occurred,
{                   ame$input_after_eoi,
{                   ame$put_beyond_file_limit,
{                   ame$unrecovered_read_error,
{                   ame$unrecovered_write_error,
{                   fse$copy_internal_error,
{                   fse$empty_input_file,
{                   fse$output_record_truncated,
{                   pfe$pf_system_error;
{
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=FSH$COPY_FILE EXPAND=FALSE
{
{   The purpose of this request is to copy one file to another.
{   If file attributes are not explicitly specified for the output file,
{ the output file will inherit the attributes of the input file (except
{ for the ring attributes which default to the ring of the caller of
{ this request).
{   The copy terminates when end of information (EOI) is reached on the
{ input file or if the input file is an unlabelled tape file, the copy
{ terminates when a tapemark is encountered on the input file.  If an
{ unlabelled tape contains data followed by a single tapemark then more
{ data followed by another single tapemark, etc., this request must be issued
{ once for each data set terminated by a tapemark in order to obtain a
{ complete copy of the information on the input file.  This request does not
{ copy single tapemarks; however a tape volume is always terminated according
{ to convention.
{   The open position ($BOI, $ASIS, $EOI) of the input and output files may be
{ specified by suffixing the file path with the open position, e.g.
{ $user.x.$eoi.
{
{   The attachment of the input file to the job by this request will have the
{ following specifications:
{     Access_and_share_modes first choice:
{           access modes: (fsc$read)
{           share modes:  (fsc$read, fsc$execute)
{     Open_share_modes first choice: (fsc$read, fsc$execute)
{     Open_share_modes second choice: ALL, with the condition that some
{           instance of open within the same task specified a subset of
{           (fsc$read, fsc$execute) for Open_share_modes.
{
{   The attachment of the output file to the job by this request will have the
{ following specifications:
{     Access_and_share_modes first choice:
{           access modes: (fsc$append, fsc$shorten)
{           share modes:  no sharing
{     Access_and_share_modes second choice:
{           access modes: (fsc$append)
{           share modes:  no sharing
{     Open_share_modes first choice: no sharing
{     Open_share_modes second choice: ALL
{
{   The parameters input_attribute_validation and output_attribute_validation
{ are provided to ensure that both files, if previously created, conform to
{ the requirements of the caller.
{   The parameter output_creation_attributes is only used if the output file
{ is created as a result of the copy operation.  Attributes specified with this
{ parameter, are passed to fsp$open_file as mandated_creation_attributes.
{ Refer
{ to the discussion of fsp$open_file.
{
{     FSP$COPY_FILE (INPUT, OUTPUT, INPUT_ATTRIBUTE_VALIDATION,
{       OUTPUT_ATTRIBUTE_VALIDATION, OUTPUT_CREATION_ATTRIBUTES, STATUS)
{
{ INPUT: (input) This parameter specifies the name of the file from which
{     data is to be copied.
{
{ OUTPUT: (input) This parameter specifies the name of the file to which
{     data is to be copied.
{
{ INPUT_ATTRIBUTE_VALIDATION: (input) This parameter specifies the desired
{       attribute values of the input file.  Values of attributes specified
{       by this parameter are compared with those in effect for the input file;
{       an ame$attribute_validation_error abnormal status will be returned if
{       the values specified do not match those of the input file.
{
{       This parameter allows alternatives to be specified for each attribute
{       to be validated.  To specify an alternative value for an attribute,
{       simply provide another record in the array giving the alternate,
{       acceptable value.   Alternatives are processed in the order given.
{       If an alternative matches the value of the corresponding file
{       attribute, subsequent validation specifications of the attribute are
{       ignored.
{
{ OUTPUT_ATTRIBUTE_VALIDATION: (input) This parameter specifies the desired
{       attribute values of the output file.  Values of attributes specified
{       by this parameter are compared with those in effect for the output
{       file;
{       an ame$attribute_validation_error abnormal status will be returned if
{       the values specified do not match those of the output file.
{
{       This parameter allows alternatives to be specified for each attribute
{       to be validated.  To specify an alternative value for an attribute,
{       simply provide another record in the array giving the alternate,
{       acceptable value.   Alternatives are processed in the order given.
{       If an alternative matches the value of the corresponding file
{       attribute, subsequent validation specifications of the attribute are
{       ignored.
{
{ OUTPUT_CREATION_ATTRIBUTES: (input) This parameter specifies file attribute
{       values which will be mandated for the output file, if it is created
{       by this request.  If the output file was previously created, this
{       parameter will be ignored.  Attribute values specified using this
{       parameter have greater precedence than those of the input file or
{       any other command or request which may be used to specify attributes
{       for the output file.  A value of NIL for this parameter implies that
{       no mandated creation attributes are provided for the output file.
{       in this case all attributes will default to the values of the
{       corresponding attributes of the input file.  If the same attribute
{       is specified multiple times in the array, the last specification
{       is used.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{                   aae$altkey_part_negative_pos,
{                   aae$cant_copy_several_nfs_to_1,
{                   aae$cant_replace_main_file,
{                   aae$copying_attributes_only,
{                   aae$copying_ek_to_non_ek,
{                   aae$copying_non_ek_to_ek,
{                   aae$main_file_will_be_used,
{                   aae$merge_with_emb_key_chg,
{                   aae$partial_copy_occurred,
{                   ame$attribute_validation_error,
{                   ame$concurrent_open_limit,
{                   ame$concurrent_tape_limit,
{                   ame$conflicting_block_types,
{                   ame$conflicting_file_access,
{                   ame$damaged_file_attributes,
{                   ame$file_not_known,
{                   ame$input_after_eoi,
{                   ame$local_file_limit,
{                   ame$mbl_less_than_mibl,
{                   ame$mbl_less_than_mrl,
{                   ame$multiple_open_of_tape,
{                   ame$no_permission_for_access,
{                   ame$non_ANSI_blocking,
{                   ame$put_beyond_file_limit,
{                   ame$record_exceeds_mbl,
{                   ame$ring_validation_error,
{                   ame$terminal_task_limit,
{                   ame$unable_to_load_collate_tabl,
{                   ame$unable_to_load_error_exit,
{                   ame$unable_to_load_fap,
{                   ame$unrecovered_read_error,
{                   ame$unrecovered_write_error,
{                   cle$improper_name,
{                   fse$block_lengths_unequal,
{                   fse$concurrent_access_conflict,
{                   fse$concurrent_share_conflict,
{                   fse$conflicting_block_types,
{                   fse$conflicting_file_addresses,
{                   fse$conflicting_file_contents,
{                   fse$conflicting_record_types,
{                   fse$copy_device_conflict,
{                   fse$copy_internal_error,
{                   fse$empty_input_file,
{                   fse$fap_names_not_identical,
{                   fse$from_list_input_unsupported,
{                   fse$improper_fo_for_copy,
{                   fse$input_and_output_same_file,
{                   fse$input_file_at_eoi,
{                   fse$insufficient_record_length,
{                   fse$line_numbers_unequal,
{                   fse$output_record_truncated,
{                   fse$padding_characters_unequal,
{                   fse$record_lengths_unequal,
{                   fse$redundant_access_choice,
{                   fse$size_exceeds_output_limits,
{                   fse$statement_idents_unequal,
{                   fse$to_list_input_unsupported,
{                   fse$to_list_output_unsupported,
{                   pfe$cycle_busy,
{                   pfe$cycle_overflow,
{                   pfe$cycle_underflow,
{                   pfe$duplicate_cycle,
{                   pfe$incorrect_password,
{                   pfe$invalid_ring_access,
{                   pfe$lfn_in_use,
{                   pfe$name_already_subcatalog,
{                   pfe$name_not_permanent_file,
{                   pfe$nth_name_not_subcatalog,
{                   pfe$path_too_short,
{                   pfe$pf_system_error,
{                   pfe$sharing_not_permitted,
{                   pfe$undefined_data,
{                   pfe$unknown_cycle,
{                   pfe$unknown_family,
{                   pfe$unknown_master_catalog,
{                   pfe$unknown_nth_subcatalog,
{                   pfe$unknown_permanent_file,
{                   pfe$usage_not_permitted;
{
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=FSH$DEFAULT_TAPE_LABEL_ATTRIB EXPAND=FALSE
{
{   The purpose of this request is to return default tape label attribute
{ values.
{
{       FSP$DEFAULT_TAPE_LABEL_ATTRIB (SOURCE, ATTRIBUTES, RETURNED_ATTRIBUTES,
{         STATUS)
{
{ SOURCE: (input)  This parameter identifies the source of the default
{       attributes that are to be returned.
{
{ ATTRIBUTES: (input, output)  On input, this parameter specifies the identity
{       of the attributes whose values are requested and the order in which the
{       attributes are to be returned within the specified array.  On output,
{       the values of individual attributes are returned in the corresponding
{       fields of the variant records supplied in the array.
{
{ RETURNED_ATTRIBUTES: (output)  This parameter identifies those requested
{      attributes for which a default value was returned.  If an attribute has
{      no default value, the corresponding record in the ATTRIBUTES parameter
{      is not modified and the attribute is not included in the
{      RETURNED_ATTRIBUTES set.
{
{      REMOVABLE_MEDIA_GROUP has no default value.
{
{      FILE_IDENTIFIER defaults to the name of the tape file; therefore no
{      value can be returned by this request.  However, a value is available
{      for a specific magnetic tape file via the FSP$GET_TAPE_LABEL_ATTRIBUTES
{      request.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=FSH$DETACH_FILE EXPAND=FALSE
{
{   The purpose of this request is to detach a file from the job.  For a
{ temporary file, this request also deletes the registration of the file in the
{ temporary catalog.
{
{   This request requires that there be no outstanding instances of open of the
{ file within the job.  Otherwise, this request will be rejected.
{
{   If the file is an attached permanent file, the attachment of the file to
{ the job ends with this request.  The space that the permanent file occupies
{ is unaffected by this request.
{
{   If the file is a temporary mass storage file, the file information is
{ destroyed, i.e.  the mass storage space once assigned to the file is returned
{ to the system.
{
{   If the file is a magnetic tape file, the tape volume assigned to file, if
{ any, is detached from the job.  Information on the tape volume(s) accessed by
{ the job is unaffected by this request.  If detachment_options are not
{ specified, the volume is dismounted from the tape drive.  If the
{ fsc$do_unload_volume detachment_option is specified, the detachment of the
{ volume from the tape drive is based on the value specified by this option.
{
{       FSP$DETACH_FILE (FILE, DETACHMENT_OPTIONS, STATUS)
{
{ FILE: (input)  This parameter specifies the path name of the file to be
{       detached.  The value specified is evaluated by this request as an SCL
{       <file expression>.  Refer to the discussion of <file expression> in the
{       NOS/VE Command Interface ERS.
{
{ DETACHMENT_OPTIONS: (input)  This parameter specifies the detachment options
{       to be used for the detachment of the file.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$file_not_closed,
{                   ame$file_not_known.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=FSH$FILE_HEADER_LABELS EXPAND=FALSE
{
{    This function returns a boolean value.  The value TRUE is returned if any
{ of the following values are in the LABEL_GROUP:  fsc$ansi_hdr1_label_kind,
{ fsc$ansi_hdr2_label_kind, fsc$ansi_hdrn_label_kind, and
{ fsc$ansi_uhla_label_kind; otherwise, FALSE is returned.
{
{       FSP$FILE_HEADER_LABELS (LABEL_GROUP)
{
{ LABEL_GROUP: (input)  This parameter specifies the set of ANSI label kinds
{       that are to be analyzed.
{
*DECK DECK=FSH$FILE_TRAILER_LABELS EXPAND=FALSE
{
{    This function returns a boolean value.  The value TRUE is returned if any
{ of the following values are in the LABEL_GROUP:  fsc$ansi_eof1_label_kind,
{ fsc$ansi_eof2_label_kind, fsc$ansi_eofn_label_kind, and
{ fsc$ansi_utla_label_kind; otherwise, FALSE is returned.
{
{       FSP$FILE_TRAILER_LABELS (LABEL_GROUP)
{
{ LABEL_GROUP: (input)  This parameter specifies the set of ANSI label kinds
{       that are to be analyzed.
{
*DECK DECK=FSH$FLUSH_CATALOG EXPAND=FALSE
{   The purpose of this procedure is to force the image of a modified catalog
{ to mass storage.  Ordinarily, catalog flushing is performed automatically by
{ the system after each catalog modification (object creation, change or
{ deletion).  However, if catalog flushing is turned off by calling
{ FSP$CHANGE_CATALOG_FLUSH_OPTION, this request is recommended to ensure a
{ consistent catalog image is recorded on mass storage.
{
{       FSP$FLUSH_CATALOG (CATALOG_OBJECT, STATUS)
{
{ CATALOG_OBJECT: (input)  This parameter specifies the identity of an object
{       whose parental catalog is to be force written to mass storage.  An
{       object may be a subcatalog, file, or cycle.  The caller must have
{       CONTROL, CYCLE, or WRITE permission to the object identified in the
{       reference.  The intent is that you identify an object that you just
{       created or modified.  For example, if you turned off catalog flushing
{       prior to creating several files in a catalog, you may specify the name
{       of any of the files you created.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=FSH$GET_FILE_ATTRIBUTES EXPAND=FALSE
{
{   The purpose of this request is to retrieve values of specific file cycle
{ attributes.  The cycle attribute values are returned in the same form
{ required by fsp$open_file; therefore one may use this request to "clone" a
{ file from another one.
{
{   This interface may be used to retrieve values of specific user-defined
{ attributes.  However, the name and type of each user-defined attribute must
{ be input.  If the ring of the caller is greater than the R1 value of the
{ file's ring attributes, values of privileged, user-defined attributes cannot
{ be returned; an ame$ring_validation_error abnormal status will be returned
{ instead.  If a user-defined attribute of type file, sequence or string is
{ requested, the variable into which the value is to be stored must be greater
{ than or equal to the actual size of the user-defined attribute or
{ fse$variable_too_short abnormal status will be returned.
{
{       FSP$GET_FILE_ATTRIBUTES (FILE, FILE_CYCLE_ATTRIBUTES, STATUS)
{
{ FILE: (input)  This parameter specifies the file whose attributes are to
{       returned.
{
{ FILE_CYCLE_ATTRIBUTES: (input, output)  This parameter specifies one or more
{       file-cycle attributes whose value is sought.
{
{       For each user-defined attribute sought, the name, selector and "value"
{       components of the corresponding record in this array must be
{       initialized; the latter must be initialized to point to a CYBIL
{       variable of the correct type.  The privileged_attribute component will
{       be initialized by this request.  If the name and or type of the
{       user-defined attributes are not known in advance, then one may use the
{       request fsp$get_file_information to retrieve all user-defined
{       attributes without having to know their names and types.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_attrib_key,
{                   ame$file_not_known,
{                   fse$improper_user_attrib_type,
{                   fse$unknown_user_attribute,
{                   fse$variable_too_short.
{
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=FSH$GET_FILE_INFORMATION EXPAND=FALSE
{
{   The purpose of this request is to retrieve all the information which is
{ available for a particular file cycle.  One is not required to retrieve all
{ the possible information for the file.  In fact, one is encouraged to
{ retrieve only that information which is actually required.  All the output
{ parameters except user_defined_attribute_size accept a NIL pointer to
{ indicate that the parameter is not to be returned.  Refer to the description
{ of the catalog_information parameter for an additional caution.
{
{       FSP$GET_FILE_INFORMATION (FILE, ATTACHMENT_INFORMATION,
{         CATALOG_INFORMATION, CYCLE_ATTRIBUTE_SOURCES,
{         CYCLE_ATTRIBUTE_VALUES, RESOLVED_FILE_REFERENCE,
{         USER_DEFINED_ATTRIBUTES, USER_DEFINED_ATTRIBUTE_SIZE, STATUS)
{
{ FILE: (input)  This parameter specifies the file about which information is
{       sought.
{
{ ATTACHMENT_INFORMATION: (output)  This parameter specifies information about
{       the attachment of the file to the job.
{
{ CATALOG_INFORMATION: (output)  This parameter specifies file and file-cycle
{       catalog registration information.  If a non-NIL value is specified, a
{       catalog access will occur to retrieve this information; therefore,
{       there is a significant cost associated with returning this particular
{       parameter.
{
{ CYCLE_ATTRIBUTE_SOURCES: (output)  This parameter specifies the origination
{       of the values of all of the file-cycle attributes.
{
{ CYCLE_ATTRIBUTE_VALUES: (output)  This parameter specifies the values of all
{       of the file-cycle attributes.
{
{ RESOLVED_FILE_REFERENCE: (output)  This parameter specifies the complete
{       path name of the file cycle, including the open position, if
{       specified.
{
{ USER_DEFINED_ATTRIBUTES: (output)  This parameter specifies the values of
{       all the user-defined attributes of the file.  The caller is
{       responsible for providing an area large enough to contain the sequence
{       of user-defined attributes.  If the area provided is not large enough,
{       abnormal status will be returned; in addition the request will return
{       the actual size of the area which will be required in the parameter
{       user_defined_attribute_size.  This will allow the caller to repeat the
{       request successfully.  If a NIL value is provided for this parameter,
{       no user-defined attributes will be returned.
{
{       Each user-defined attribute in the sequence consists of a header of
{       type fst$user_attribute_descriptor followed by the value of the
{       attribute.  One performs a NEXT for the header, determines the type of
{       user-defined attribute which follows and then does another NEXT to
{       obtain the attribute value; this continues until a NIL pointer is
{       returned by the NEXT or a header is found in which the
{       user_attribute_name field is equal to osc$null_name.
{
{       If the caller of this interface is not within the write bracket of the
{       file, then only the names of privileged user attributes are returned;
{       the type of the attribute in this case is fsc$null_type.
{
{ USER_DEFINED_ATTRIBUTE_SIZE: (output)  This parameter specifies the exact
{       size of the user-defined attribute information.  This parameter is
{       initialized whether or not this request terminates and whether or not
{       the value of the user_defined_attributes parameter is NIL.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{                   ame$file_not_known,
{                   ame$ring_validation_error,
{                   ame$improper_file_id.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=FSH$GET_OPEN_ATTRIBUTES EXPAND=FALSE
{
{   The purpose of this request is to retrieve values of specific file cycle
{ attributes.  The cycle attribute values are returned in the same form
{ required by fsp$open_file; therefore one may use this request to "clone" a
{ file from another one.
{
{   This interface may be used to retrieve values of specific user-defined
{ attributes.  However, the name and type of each user-defined attribute must
{ be input.  If the ring of the caller is greater than the R1 value of the
{ file's ring attributes, values of privileged, user-defined attributes cannot
{ be returned; an ame$ring_validation_error abnormal status will be returned
{ instead.  If a user-defined attribute of type file, sequence or string is
{ requested, the variable into which the value is to be stored must be greater
{ than or equal to the actual size of the user-defined attribute or
{ fse$variable_too_short abnormal status will be returned.
{
{   It is possible to override the values of file organization, record type,
{ block type and ring attributes using the fsp$open_file request.  However,
{ this request returns only the permanent values of these attributes.  Use
{ the fsp$get_open_information interface if values of overridden attributes
{ are sought.
{
{       FSP$GET_OPEN_ATTRIBUTES (FILE_IDENTIFIER, FILE_CYCLE_ATTRIBUTES,
{         STATUS)
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the file access
{       identifier established when the file was opened.
{
{ FILE_CYCLE_ATTRIBUTES:  (input-output) This parameter specifies one or more
{       file-cycle attributes whose value is sought.  If a user-defined
{       attribute of type fsc$string_type is requested, the size of the string
{       variable provided as input must be greater than or equal to the size
{       of the value of the attribute or abnormal status will be returned.
{
{       For each user-defined attribute sought, the name, selector and "value"
{       components of the corresponding record in this array must be
{       initialized; the latter must be initialized to point to a CYBIL
{       variable of the correct type.  The privileged_attribute component will
{       be initialized by this request.  If the name and or type of the
{       user-defined attributes are not known in advance, then one may use the
{       request fsp$get_file_information to retrieve all user-defined
{       attributes without having to know their names and types.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_attrib_key,
{                   ame$improper_file_id,
{                   fse$improper_user_attrib_type,
{                   fse$unknown_user_attribute,
{                   fse$variable_too_short.
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=FSH$GET_OPEN_INFORMATION EXPAND=FALSE
{
{   The purpose of this request is to retrieve all the information which is
{ available for a particular file cycle.
{   One is not required to retrieve all the possible information for the file.
{ In fact, one is encouraged to retrieve only that information which is actually
{ required.  All the output parameters except user_defined_attribute_size accept
{ a NIL pointer to indicate that the parameter is not to be returned.  Refer to
{ the description of the catalog_information parameter for an additional caution.
{
{       FSP$GET_OPEN_INFORMATION (FILE_IDENTIFIER, ATTACHMENT_INFORMATION,
{         CATALOG_INFORMATION, CYCLE_ATTRIBUTE_SOURCES,
{         CYCLE_ATTRIBUTE_VALUES, INSTANCE_INFORMATION,
{         RESOLVED_FILE_REFERENCE, USER_DEFINED_ATTRIBUTES,
{         USER_DEFINED_ATTRIBUTE_SIZE, STATUS)
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the file access
{       identifier established when the file was opened.
{
{ ATTACHMENT_INFORMATION: (output)  This parameter specifies information about
{       the attachment of the file to the job.
{
{ CATALOG_INFORMATION: (output)  This parameter specifies file and file-cycle
{       catalog registration information.  If a non-NIL value is specified,
{       a catalog access will occur to retrieve this information; therefore,
{       there is a significant cost associated with returning this particular
{       parameter.
{
{ CYCLE_ATTRIBUTE_SOURCES: (output)  This parameter specifies the origination
{       of the values of all of the file-cycle attributes.
{
{ CYCLE_ATTRIBUTE_VALUES: (output)  This parameter specifies the values of all
{       of the file-cycle attributes.
{
{ INSTANCE_INFORMATION: (output)  This parameter specifies information which
{       may be unique to an instance of open of a file.  This information
{       includes the values of file-cycle attributes which were overridden
{       using the fsp$open_file request which established this instance of
{       open and the values of "attachment" options specified either by the
{       fsp$open_file request or an amp$store request.  If an attribute was
{       not overridden by the fsp$open_file request, the permanent value of
{       the attribute will be returned.
{
{ RESOLVED_FILE_REFERENCE: (output)  This parameter specifies the complete
{       path name of the file cycle, including the open position, if
{       specified.
{
{ USER_DEFINED_ATTRIBUTES: (output)  This parameter specifies the values of
{       all the user-defined attributes of the file.  The caller is
{       responsible for providing an area large enough to contain the sequence
{       of user-defined attributes.  If the area provided is not large enough,
{       abnormal status will be returned; in addition the request will return
{       the actual size of the area which will be required in the parameter
{       user_defined_attribute_size.  This will allow the caller to repeat the
{       request successfully.  If a NIL value is provided for this parameter,
{       no user-defined attributes will be returned.
{
{       Each user-defined attribute in the sequence consists of a header of
{       type fst$user_attribute_descriptor followed by the value of the
{       attribute.  One performs a NEXT for the header, determines the type of
{       user-defined attribute which follows and then does another NEXT to
{       obtain the attribute value; this continues until a NIL pointer is
{       returned by the NEXT or a header is found in which the
{       user_attribute_name field is equal to osc$null_name.
{
{       If the caller of this interface is not within the write bracket of the
{       file, then only the names of privileged user attributes are returned;
{       the type of the attribute in this case is fsc$null_type.
{
{ USER_DEFINED_ATTRIBUTE_SIZE: (output)  This parameter specifies the exact
{       size of the user-defined attribute information.  This parameter is
{       initialized whether or not this request terminates normally.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  ame$ring_validation_error,
{                   ame$improper_file_id.
{       IDENTIFIER: amc$access_method_id.
{
{
*DECK DECK=FSH$GET_TAPE_LABEL_ATTRIBUTES EXPAND=FALSE
{
{   The purpose of this request is to return tape label attributes for a
{ magnetic tape file.  The attribute values are returned in a format that
{ allows them to be input to the FILE_ATTACHMENT parameter of a subsequent
{ FSP$OPEN_FILE request.
{
{   If the file is not currently attached to the requesting job or is not a
{ magnetic tape file, abnormal status is returned.
{
{   It is possible that not all attributes are defined for a particular SOURCE.
{ Refer to the discussion of the RETURNED_ATTRIBUTES for more information.
{
{       FSP$GET_TAPE_LABEL_ATTRIBUTES (FILE_REFERENCE, SOURCE, ATTRIBUTES,
{         RETURNED_ATTRIBUTES, STATUS)
{
{ FILE: (input)  This parameter specifies the name of the magnetic tape file
{       whose label attributes are to be returned.
{
{ SOURCE: (input)  This parameter specifies the source of the attribute values
{       that are to be returned.  Three options are supported:
{       FSC$TLA_LAST_ANSI_FILE_ACCESSED, FSC$TLA_EXPLICIT_SPECIFICATION, and
{       FSC$TLA_NEXT_POSITION.
{
{       Abnormal status is returned if the FILE_LABEL_TYPE is <> amc$labeled
{       and either FSC$TLA_LAST_ANSI_FILE_ACCESSED or FSC$TLA_NEXT_POSITION is
{       selected.
{
{       1.  The option FSC$TLA_LAST_ANSI_FILE_ACCESSED returns values defined
{           in the last ANSI file read from or written to the tape file.  If no
{           ANSI file has been previously accessed for the current attachment
{           of the file to the requesting job, the ATTRIBUTES parameter is not
{           modified and no attributes are included in the RETURNED_ATTRIBUTES
{           set.  If this request is issued while a labeled tape file is open,
{           the information contained in the header labels of the currently
{           opened ANSI file is returned.
{
{           You may obtain the most recently accessed (read or written) ANSI
{           header or trailer label group by requesting the HEADER_LABELS or
{           TRAILER_LABELS fields, respectively.
{
{       1.a A header label group always includes a file header label group and
{           may include a volume header label group.  A header label group is
{           read or written by NOS/VE whenever an ANSI file is opened or when
{           the current ANSI file is positioned to the beginning of each
{           volume.
{
{           A volume header label group is returned only if the volume is
{           positioned beyond loadpoint and before the second ANSI file on a
{           volume.  This is true for each volume in the volume set.  However,
{           the content of the volume header label group changes as each new
{           volume of a multi-volume file is accessed.  For example, the
{           VOLUME_IDENTIFIER field of the VOL1 label changes to reflect the
{           identity of the last volume mounted and the FILE_SECTION_NUMBER
{           increments by one for each volume the file spans.
{
{           The OWNER_IDENTIFICATION and VOLUME_ACCESSIBILITY fields of the
{           VOL1 label and the FILE_ACCESSIBILITY field of the HDR1 label are
{           secure fields.  Unless the program is executing with
{           REMOVABLE_MEDIA_ADMINISTRATION privilege these fields are set to
{           blanks (' ').
{
{           HEADER_LABELS returns all available header labels, including
{           system-defined labels (VOL1, HDR1, and HDR2), site-defined labels
{           (VOL2..VOL9 and HDR3..HDR9), and user-defined labels (UVL1..UVL9
{           and UHLx, where x is an ANSI a-character).
{
{       1.b A trailer label group includes either an end of file label group or
{           an end of volume label group.  An end of volume label group is
{           included if an ANSI file is currently open, it spans multiple
{           volumes, and the FILE_SECTION_NUMBER is > 1; otherwise, an end of
{           file label group is included.  A trailer label group is read by
{           NOS/VE when the logical position is at end of information or end of
{           volume.  A file trailer label group is written whenever a volume
{           has been previously written upon and the physical volume position
{           is reversed (by a rewind, backward skip, etc.) or the file is
{           closed.  A volume trailer label group is written whenever the
{           current volume cannot hold all of the data to be written.
{
{           TRAILER_LABELS returns all available ANSI trailer labels, including
{           system-defined labels (EOV1, EOV2, EOF1 and EOF2), site-defined
{           labels (EOV3..EOV9 and EOF3..EOF9), and user-defined labels
{           (UTL1..UTLx, where x is an ANSI a-character).
{
{           The FILE_ACCESSIBILITY field of the EOF1 or EOV1 label is a secure
{           field.  Unless the program is executing with
{           REMOVABLE_MEDIA_ADMINISTRATION privilege the value ' ' is returned
{           for FILE_ACCESSIBILITY within either of these labels.
{
{       1.c One can monitor the switching of volumes on an ANSI file by
{           sampling the VOLUME_NUMBER provided by AMP$FETCH_ACCESS_INFORMATION
{           after accessing a record or performing a positioning operation.
{
{       1.d The FILE_SET_POSITION and REWRITE_LABEL attributes are undefined
{           for this option and no value is returned.
{
{       2.  The option FSC$TLA_EXPLICIT_SPECIFICATION returns values defined by
{           the CHANGE_TAPE_LABEL_ATTRIBUTES (CHATLA) command for the current
{           attachment of the file.  If the file is currently open, the values
{           returned are the result of the merging of attributes specified on
{           FSP$OPEN_FILE with those specified by the CHATLA command, with the
{           the FSP$OPEN_FILE specifications taking precedence.  If an
{           attribute has not been specified by a CHATLA command or
{           FSP$OPEN_FILE, no value is returned by the ATTRIBUTES parameter
{           and the attribute is not included in the RETURNED_ATTRIBUTES set.
{
{           The following attributes are not supported by this option and no
{           value is returned:  BUFFER_OFFSET, FILE_SECTION_NUMBER,
{           IMPLEMENTATION_IDENTIFIER, LABEL_STANDARD_VERSION, HEADER_LABELS,
{           and TRAILER_LABELS.
{
{           Because tape attachment options specified in the FILE_ATTACHMENT
{           parameter of FSP$OPEN_FILE supercede any specification by the
{           CHANGE_TAPE_LABEL_ATTRIBUTES (CHATLA) command, a program that
{           specifies a tape label attribute via FSP$OPEN_FILE prevents a user
{           from influencing the value of the attribute.  While this capability
{           is necessary, the result may be too inflexible in some situations.
{           Prior to opening the file, you may use the
{           FSC$TLA_EXPLICIT_SPECIFICATION option of this request to obtain any
{           attribute values provided by a CHATLA command.  You may then choose
{           to accept values provided by a CHATLA command and pass them along
{           to FSP$OPEN_FILE or provide your own specification.
{
{       3.  The option FSC$TLA_NEXT_POSITION returns values that are to be
{           applied to the next ANSI file to be accessed in the magnetic tape
{           file.  If no ANSI file has been previously accessed and no CHATLA
{           command has been previously executed for the file within the
{           requesting job, system default values are returned.
{
{       3a.  With the exception of BLOCK_TYPE, CHARACTER_CONVERSION,
{            CHARACTER_SET, CREATION_DATE, EXPIRATION_DATE, FILE_SET_POSITION,
{            MAXIMUM_BLOCK_LENGTH, MAXIMUM_RECORD_LENGTH, PADDING_CHARACTER,
{            RECORD_TYPE, and REWRITE_LABELS, the values of the attributes
{            returned are a result of merging the attributes of the last ANSI
{            file accessed with any CHATLA specification for the current
{            attachment; the latter specification takes precedence.  If there
{            is no CHATLA specification for BLOCK_TYPE, CHARACTER_CONVERSION,
{            CHARACTER_SET, CREATION_DATE, EXPIRATION_DATE, FILE_SET_POSITION,
{            MAXIMUM_BLOCK_LENGTH, MAXIMUM_RECORD_LENGTH, PADDING_CHARACTER,
{            RECORD_TYPE, or REWRITE_LABELS, system default values are returned.
{
{            The values of the following attributes are controlled by the
{            system; values returned are those that would be written if the
{            next position requires labels to be written to the volume:
{            BUFFER_OFFSET, FILE_SECTION_NUMBER, IMPLEMENTATION_IDENTIFIER,
{            LABEL_STANDARD_VERSION.
{
{       3b.  With the exception of the REWRITE_LABELS and FILE_SET_POSITION
{            attributes, the values returned are those that would be recorded
{            in the label of the next ANSI file written, if one is written.
{
{       3c.  The value returned for the FILE_SET_POSITION attribute defines the
{            manner in which the volume set is to be positioned prior to
{            accessing the next ANSI file.
{
{       3d.  If the FILE_SET_POSITION value is FSC$TAPE_FILE_IDENTIFIER_POS,
{            the FILE_IDENTIFIER and GENERATION_NUMBER returned in the
{            TAPE_FILE_SET_POSITION field identify the ANSI file to which the
{            tape file will be positioned as a result of the next call to
{            FSP$OPEN_FILE (in the absence of a positioning specification by
{            the program).
{
{       3e.  If the FILE_SET_POSITION attribute is requested and the file set
{            position value is FSC$TAPE_FILE_SEQUENCE_POS, the
{            FILE_SEQUENCE_NUMBER field returned in the TAPE_FILE_SET_POSITION
{            record identifies the ordinal file position that will be attained
{            at the the next call to FSP$OPEN_FILE (in the absence of a
{            positioning specification by the program).
{
{       3f.  If the FILE_SEQUENCE_NUMBER attribute is requested, the value
{            returned (if one is returned) is derived from the
{            FILE_SET_POSITION attribute.
{
{            If the FILE_SET_POSITION is FSC$TAPE_FILE_SEQUENCE_POS, the value
{            specified by the FILE_SEQUENCE_NUMBER field of FILE_SET_POSITION
{            is returned.
{
{            If the FILE_SET_POSITION is not FSC$TAPE_FILE_SEQUENCE_POS, the
{            value of the FILE_SEQUENCE_NUMBER attribute can be predicted when
{            the FILE_SET_POSITION is FSC$BEGINNING_OF_SET, FSC$CURRENT_FILE,
{            or FSC$TAPE_NEXT_FILE.  The value 1 is returned for
{            FSC$BEGINNING_OF_SET.  The ordinal value of the last ANSI file
{            (the current value) is returned for FSC$CURRENT_FILE.  The current
{            value + 1 is returned for FSC$TAPE_NEXT_FILE.
{
{            If the FILE_SET_POSITION is FSC$TAPE_END_OF_SET and the volume is
{            already positioned at end of set, the ordinal value of the next
{            file to be written is returned.
{
{            If the FILE_SET_POSITION is FSC$TAPE_FILE_IDENTIFIER_POS, a value
{            is returned only when the file_identifier and generation_number of
{            the last_accessed file match the next_position values of
{            file_identifier and generation_number.
{
{ ATTRIBUTES: (input, output)  On input, this parameter specifies the identity
{       of the attributes whose values are requested and the order in which the
{       attributes are returned.  On output, this parameter specifies the value
{       of each of the attributes that were requested, if a value is returned.
{
{       If no value is returned for an attribute, the corresponding input
{       record is not modified by this request.  This allows you to use this
{       request to merge tape label attributes in a convenient way.  For
{       example, if you wanted to copy one labeled file to another and use the
{       attributes of the input file as the default attributes of the output
{       file, you would make two requests and use the same ATTRIBUTES array for
{       both requests.  The first request is for the input file; specify
{       FSC$TLA_LAST_ANSI_FILE_ACCESSED.  The second request is for the output
{       file; specify FSC$TLA_EXPLICIT_SPECIFICATION.  This allows the command
{       user to specify alternative attributes for the output file via the
{       CHANGE_TAPE_LABEL_ATTRIBUTES command.  Any value specified by a CHATLA
{       command for the output file replaces the value obtained from the input
{       file; ATTRIBUTES not specified by a CHATLA are retained.  Refer to the
{       RETURNED_ATTRIBUTES parameter for further discussion.
{
{       The FST$ATTACHMENT_OPTION type is used by this parameter to make it
{       easier to use this request prior to calling FSP$OPEN_FILE.  For this
{       reason, this request ignores records in the input array that are not of
{       type FSC$TAPE_ATTACHMENT.
{
{       The secure attributes FILE_ACCESSIBILITY, OWNER_IDENTIFIER,
{       REMOVABLE_MEDIA_GROUP, and VOLUME_ACCESSIBILITY may only be requested
{       by a program executing under the SYSTEM_OPERATOR_UTILITY with the
{       REMOVABLE_MEDIA_ADMINISTRATION capability active; otherwise, abnormal
{       status is returned.
{
{       The HEADER_LABELS and TRAILER_LABELS are returned in a sequence.  The
{       caller allocates the sequence and this request initializes the sequence
{       with the label group.  The size of a label group may vary according to
{       vendor.  The ANSI X3.27 1987 File Structure and Labeling of Magnetic
{       Tapes for Information Interchange standard defines the possibility of
{       84 labels in a label group, each 80 characters in length.  However,
{       some vendors may write labels longer than 80 characters.  NOS/VE
{       accepts individual labels of up to 4128 bytes in length.
{
{       The label group sequence begins with a record of type
{       FST$TAPE_LABEL_SEQUENCE_HEADER.  The caller's sequence must be at least
{       the size of this record or abnormal status is returned.  If the caller's
{       sequence is smaller than the size of the label group, but >=
{       #SIZE(FST$TAPE_LABEL_SEQUENCE_HEADER), abnormal status is returned and
{       only the header record is stored in the sequence.  The field
{       SEQUENCE_SIZE in the header returns the size of the label group
{       in bytes.  This allows the caller to reallocate a sequence of the
{       necessary size and successfully reissue the request.
{
{       Processing of label records in the sequence may occur according to the
{       following algorithm.  The result of the algorithm is to obtain pointers
{       to the VOL1 and HDR1 labels:
{
{       NEXT sequence_header IN label_group;
{       IF fsc$ansi_vol1_label_kind IN sequence_header^.label_kinds THEN
{         label_identifier.location_method := fsc$tape_label_locate_by_kind;
{         label_identifier.label_kind := fsc$ansi_vol1_label_kind;
{         fsp$locate_tape_label (label_group, label_identifier, label_locator);
{         IF label_locator.label_found THEN
{           RESET label_locator.label_block;
{           NEXT vol1_label IN label_locator.label_block;
{         ELSE
{           vol1_label := NIL;
{         IFEND;
{       IFEND;
{       IF fsc$ansi_hdr1_label_kind IN sequence_header^.label_kinds THEN
{         label_identifier.location_method := fsc$tape_label_locate_by_kind;
{         label_identifier.label_kind := fsc$ansi_hdr1_label_kind;
{         fsp$locate_tape_label (label_group, label_identifier, label_locator);
{         IF label_locator.label_found THEN
{           RESET label_locator.label_block;
{           NEXT hdr1_label IN label_locator.label_block;
{         ELSE
{           hdr1_label := NIL;
{         IFEND;
{       IFEND;
{
{       For each label returned, the "TRANSFER_LENGTH" field of the
{       FST$TAPE_LABEL_BLOCK_DESCRIPTOR record indicates the length of the ANSI
{       label directly following the header in the sequence.  If the label was
{       greater than 4128 bytes in length the label is truncated and only the
{       first 4128 bytes of the label are returned.  If the label block could
{       not be read without error, the LABEL_BLOCK_TYPE field of the
{       FST$TAPE_LABEL_BLOCK_DESCRIPTOR record is set to
{       FSC$ERRONEOUS_TAPE_LABEL_BLOCK, and the ERRONEOUS_LABEL_FAILURE_MODES
{       field identifies the fault symptom.
{
{       The caller's sequence pointer is not updated by this request;
{       therefore, the pointer points to a record of type
{       FST$TAPE_LABEL_SEQUENCE_HEADER at the completion of a normal request.
{
{ RETURNED_ATTRIBUTES: (output)  This parameter specifies the identity of each
{       of the attributes for which a value was returned in the ATTRIBUTES
{       parameter.
{
{       If an attribute has no value or it is not defined for the SOURCE
{       specified, the corresponding record in the ATTRIBUTES parameter is not
{       modified and the attribute is not included in the RETURNED_ATTRIBUTES
{       set.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=FSH$HEADER_LABELS EXPAND=FALSE
{
{    This function returns a boolean value.  The value TRUE is returned if any
{ of the following values are in the LABEL_GROUP:  fsc$ansi_hdr1_label_kind,
{ fsc$ansi_hdr2_label_kind, fsc$ansi_hdrn_label_kind, fsc$ansi_uhla_label_kind,
{ fsc$ansi_uvln_label_kind, fsc$ansi_vol1_label_kind, and
{ fsc$ansi_voln_label_kind; otherwise, FALSE is returned.
{
{       FSP$HEADER_LABELS (LABEL_GROUP)
{
{ LABEL_GROUP: (input)  This parameter specifies the set of ANSI label kinds
{       that are to be analyzed.
{
*DECK DECK=FSH$LOCATE_TAPE_LABEL EXPAND=FALSE
{
{    The purpose of this procedure is to locate a specific kind of ANSI tape
{ label within a sequence of ANSI labels returned by
{ FSP$GET_TAPE_LABEL_ATTRIBUTES.
{
{       FSP$LOCATE_TAPE_LABEL ( LABEL_SEQUENCE, LABEL_IDENTIFIER,
{             LABEL_LOCATOR)
{
{ label_sequence: (input)  This parameter specifies a pointer to a sequence of
{       ANSI labels and other blocks from a tape volume.  Refer to the
{       documentation of FSP$GET_TAPE_LABEL_ATTRIBUTES for a complete
{       description of the organization and contents of an ANSI label sequence.
{       The sequence may contain an fsc$erroneous_tape_label_block (a block
{       read with error), an fsc$non_tape_label_block (a data block), an
{       fsc$normal_tape_label_block (an ANSI label), an
{       fsc$null_tape_label_block (a block that is not to be written), and an
{       fsc$tapemark_tape_label_block (a record that represents a tapemark on
{       the tape).
{
{ label_identifier: (input)  This parameter specifies which ANSI label or other
{       block is to be returned and how it is to be found.  Several searching
{       options are provided:
{
{    fsc$tape_label_locate_by_index:  This method of searching allows one to
{          identify a block in the sequence by number rather than by name.  Any
{          block in the sequence may be referenced using this search method.
{
{    fsc$tape_label_locate_by_kind:  This method of searching allows one to
{          identify an ANSI label by an ordinal constant identifier.  Only
{          fsc$normal_tape_label_block blocks may be referenced using this
{          searching method.
{
{    fsc$tape_label_locate_by_ident:  This method of searching allows one to
{          identify an ANSI label by name (label_identifer) and number
{          (label_number).  For example, VOL is a label_identifier and 1 is a
{          label_number; the search is conducted for a VOL1 label.  This is the
{          easiest search method to use when you are trying to find an optional
{          label such as HDR3..HDR9, etc.
{
{ label_locator: (output)  This parameter specifies the result of the search
{       for a particular block in the LABEL_SEQUENCE.
{
{       label_found:  Indicates whether or not the sought after block was
{             found.
{
{       label_block:  Provides a pointer to the block in the label_sequence.
{             When you determine what kind of block this is by looking at the
{             label_block_descriptor, you may NEXT the appropriate TYPE of
{             record using this sequence pointer.  A number of predefined CYBIL
{             records are provided to simplify your access to specific fiels
{             within each kind of ANSI label;
{
{             fst$ansi_eof1_label fst$ansi_eof2_label fst$ansi_eofn_label
{             fst$ansi_eov1_label fst$ansi_eov2_label fst$ansi_eovn_label
{             fst$ansi_hdr1_label fst$ansi_hdr2_label fst$ansi_hdrn_label
{             fst$ansi_uhla_label fst$ansi_utla_label fst$ansi_uvln_label
{             fst$ansi_vol1_label fst$ansi_voln_label
{
{       label_block_descriptor:  Identifies the kind of block that was found
{             and returns information necessary to properly reference the
{             block.
{
{       label_index:  Identifies the ordinal position of this block in the
{             sequence.
{
*DECK DECK=FSH$OPEN_AND_GET_TYPE_OF_COPY EXPAND=FALSE
{
{   The purpose of this request is to open the specified input and
{ output files and determine the type of copy that will be performed.
{   If file attributes are not explicitly specified for the output file,
{ the output file will inherit the attributes of the input file (except
{ for the ring attributes which default to the ring of the caller of
{ this request).
{   The open position ($BOI, $ASIS, $EOI) of the input and output files may be
{ specified by suffixing the file path with the open position,
{ e.g. $user.x.$eoi.
{   The parameters input_file_attachment and output_file_attachment are
{ provided to allow specification of how attachment of the file is to occur.
{ See FSH$SUBSYSTEM_COPF_FILE for specification of these file attachment
{ parameters.
{   The parameters input_attribute_validation and output_attribute_validation
{ are provided to ensure that both files, if previously created, conform to
{ the requirements of the caller.
{   The parameter output_creation_attributes is only used if the output file
{ is created as a result of the copy operation.  Attributes specified with this
{ parameter, are passed to fsp$open_file as mandated_creation_attributes.
{ Refer to the discussion of fsp$open_file.
{
{     FSP$OPEN_AND_GET_TYPE_OF_COPY (INPUT, OUTPUT, INPUT_FILE_ATTACHMENT,
{       OUTPUT_FILE_ATTACHMENT, INPUT_ATTRIBUTE_VALIDATION,
{       OUTPUT_ATTRIBUTE_VALIDATION, OUTPUT_CREATION_ATTRIBUTES,
{       INPUT_FID, OUTPUT_FID, CONTROL_INFO, STATUS)
{
{ INPUT: (input)  This parameter specifies the name of the file from which
{       data is to be copied.  The open position provided in the file
{       expression is overridden by the value of the open position specified by
{       the INPUT_FILE_ATTACHMENT parameter.
{
{ OUTPUT: (input)  This parameter specifies the name of the file to which data
{       is to be copied.  The open position provided in the file expression is
{       overridden by the value of the open position specified by the
{       OUTPUT_FILE_ATTACHMENT parameter.
{
{ INPUT_FILE_ATTACHMENT: (input)  This parameter specifies the attachment
{       options to be in effect for the input file.  Refer to the documentation
{       of the FILE_ATTACHMENT parameter of FSP$SUBSYSTEM_COPY_FILE for further
{       information.
{
{ OUTPUT_FILE_ATTACHMENT: (input)  This parameter specifies the attachment
{       options to be in effect for the output file.  Refer to the
{       documentation of the FILE_ATTACHMENT parameter of
{       FSP$SUBSYSTEM_COPY_FILE for further information.
{
{ INPUT_ATTRIBUTE_VALIDATION: (input)  This parameter specifies the required
{       attribute values of the input file.  Refer to the description of the
{       ATTRIBUTE_VALIDATION parameter of FSP$OPEN_FILE for more information.
{
{ OUTPUT_ATTRIBUTE_VALIDATION: (input)  This parameter specifies the required
{       attribute values of the output file.  Refer to the description of the
{       ATTRIBUTE_VALIDATION parameter of FSP$OPEN_FILE for more information.
{
{ OUTPUT_CREATION_ATTRIBUTES: (input)  This parameter specifies file attribute
{       values which are mandated for the output file, if it is created by this
{       request.  Refer to the description of the MANDATED_CREATION_ATTRIBUTES
{       parameter of FSP$OPEN_FILE for more information.
{
{ INPUT_FID: (output) This parameter returns the file_identifier of
{       input file if the file is open.
{
{ OUTPUT_FID: (output) This parameter returns the file_identifier of
{       output file if the file is open.
{
{ CONTROL_INFO: (output) This parameter returns the required information
{       need to pass to FSP$COPY_DATA_AND_CLOSE_FILES if the caller
{       wishes to use that routine.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{                   aae$altkey_part_negative_pos,
{                   aae$cant_copy_several_nfs_to_1,
{                   aae$cant_replace_main_file,
{                   aae$copying_attributes_only,
{                   aae$copying_ek_to_non_ek,
{                   aae$copying_non_ek_to_ek,
{                   aae$main_file_will_be_used,
{                   aae$merge_with_emb_key_chg,
{                   aae$partial_copy_occurred,
{                   ame$attribute_validation_error,
{                   ame$concurrent_open_limit,
{                   ame$concurrent_tape_limit,
{                   ame$conflicting_file_access,
{                   ame$damaged_file_attributes,
{                   ame$file_not_known,
{                   ame$local_file_limit,
{                   ame$mbl_less_than_mibl,
{                   ame$mbl_less_than_mrl,
{                   ame$multiple_open_of_tape,
{                   ame$no_permission_for_access,
{                   ame$non_ANSI_blocking,
{                   ame$record_exceeds_mbl,
{                   ame$ring_validation_error,
{                   ame$terminal_task_limit,
{                   ame$unable_to_load_collate_tabl,
{                   ame$unable_to_load_error_exit,
{                   ame$unable_to_load_fap,
{                   cle$improper_name,
{                   fse$block_lengths_unequal,
{                   fse$concurrent_access_conflict,
{                   fse$concurrent_share_conflict,
{                   fse$conflicting_block_types,
{                   fse$conflicting_file_addresses,
{                   fse$conflicting_file_contents,
{                   fse$conflicting_record_types,
{                   fse$copy_device_conflict,
{                   fse$copy_internal_error,
{                   fse$empty_input_file,
{                   fse$fap_names_not_identical,
{                   fse$from_list_input_unsupported,
{                   fse$improper_fo_for_copy,
{                   fse$input_and_output_same_file,
{                   fse$input_file_at_eoi,
{                   fse$insufficient_record_length,
{                   fse$line_numbers_unequal,
{                   fse$padding_characters_unequal,
{                   fse$record_lengths_unequal,
{                   fse$redundant_access_choice,
{                   fse$size_exceeds_output_limits,
{                   fse$statement_idents_unequal,
{                   fse$to_list_input_unsupported,
{                   fse$to_list_output_unsupported,
{                   pfe$cycle_busy,
{                   pfe$cycle_overflow,
{                   pfe$cycle_underflow,
{                   pfe$duplicate_cycle,
{                   pfe$incorrect_password,
{                   pfe$invalid_ring_access,
{                   pfe$lfn_in_use,
{                   pfe$name_already_subcatalog,
{                   pfe$name_not_permanent_file,
{                   pfe$nth_name_not_subcatalog,
{                   pfe$path_too_short,
{                   pfe$pf_system_error,
{                   pfe$sharing_not_permitted,
{                   pfe$undefined_data,
{                   pfe$unknown_cycle,
{                   pfe$unknown_family,
{                   pfe$unknown_master_catalog,
{                   pfe$unknown_nth_subcatalog,
{                   pfe$unknown_permanent_file,
{                   pfe$usage_not_permitted;
{
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=FSH$OPEN_FILE EXPAND=FALSE
{
{   The purpose of this request is to prepare a file for access.  If the file
{ does not exist and other pre-conditions are met, this request will create the
{ file; refer to the discussion of the FILE parameter below.
{
{   This request validates the caller's ability to access the file.  The caller
{ of this request must have sufficient ring privilege and must be permitted to
{ access the file according to the file's access-control list or this request
{ is rejected.
{
{   This request returns a file_identifier.  If the same file is opened more
{ than once, each instance of open of that file is assigned a unique
{ file_identifier.  The file_identifier is the 'key' by which file access
{ requests are associated with a particular instance of open of a file.
{
{   The file_identifier is invalidated by an fsp$close_file request.  If the
{ task fails to close its files, they are automatically closed by the system
{ when the task terminates.  The use of fsp$close_file is recommended, but is
{ not required.  More efficient utilization of system resources results when
{ the file is explicitly closed.  Furthermore, the system writes all modified
{ pages of a permanent file to mass storage when the file is closed; closing a
{ file explicitly gives the task the opportunity to detect and process any
{ abnormal status that may result from the operation.
{
{   When a file is opened, it may be opened at $BOI, $EOI, or it may inherit
{ the position attained by the last accessor of the file (see the Read/Write
{ Concurrency section of the ERS for further information concerning treatment
{ of $ASIS).  The open position may be specified using the FILE_ATTACHMENT
{ parameter of this request or by appending an open position suffix ($BOI,
{ $EOI, or $ASIS) to the value of the FILE parameter of this request.  If the
{ open position is specified using both the FILE parameter and the
{ FILE_ATTACHMENT parameter, the FILE_ATTACHMENT parameter specification is
{ used.
{
{   This request provides parameters to define the attributes of a file that is
{ to be created or initially opened by this request:
{ DEFAULT_CREATION_ATTRIBUTES and MANDATED_CREATION_ATTRIBUTES.  The
{ ATTRIBUTE_VALIDATION and ATTRIBUTE_OVERRIDE parameters are available for use
{ regardless of whether or not the file is created or initially opened by this
{ request.
{
{   If the propagate_highest_cycle registration attribute (not currently
{ implemented) of the file is TRUE and an additional cycle of a file is created
{ or initially opened by this request, the DEFAULT_CREATION_ATTRIBUTES
{ parameter is ignored; the attribute values default to those of the highest
{ cycle of the file.  However, the MANDATED_CREATION_ATTRIBUTES,
{ ATTRIBUTE_VALIDATION, and ATTRIBUTE_OVERRIDE parameters are still processed.
{
{   The maximum size of a mass storage file is limited to 2.147 gigabytes
{ (2**31 bytes).
{
{       FSP$OPEN_FILE (FILE, ACCESS_LEVEL, FILE_ATTACHMENT,
{         DEFAULT_CREATION_ATTRIBUTES, MANDATED_CREATION_ATTRIBUTES,
{         ATTRIBUTE_VALIDATION, ATTRIBUTE_OVERRIDE, FILE_IDENTIFIER, STATUS)
{
{ FILE: (input)  This parameter specifies the path name of the file to be
{       opened.  The value specified is evaluated by this request as an SCL
{       <file expression>.  Refer to the discussion of <file expression> in the
{       NOS/VE Command Interface ERS.  A file cycle is created as a result of
{       this request, if any of the following conditions hold.  A mass storage
{       file must be opened for access that includes fsc$append for creation to
{       occur, in addition to one of the following being true:
{
{         1.  The CREATE_FILE file_attachment option is TRUE and either the
{             cycle reference is omitted and no cycle exists, the cycle
{             reference is $HIGH or $LOW and no cycle exists, or a specific
{             cycle is referenced and it does not exist.
{
{         2.  The cycle reference is $NEXT and the CREATE_FILE file_attachment
{             option is TRUE or omitted; a cycle one greater than the current
{             highest cycle is created.
{
{         3.  The CREATE_FILE file_attachment option is omitted, the cycle
{             reference is a specific cycle and the cycle does not exist.
{
{         4.  The CREATE_FILE file_attachment option is omitted, the cycle
{             reference is omitted and no cycle exists.
{
{             If the cycle reference is either $HIGH or $LOW and the
{             CREATE_FILE option of the file_attachment parameter is FALSE or
{             omitted, no cycle is created, regardless of the access_modes
{             specified.
{
{ ACCESS_LEVEL: (input)  This parameter specifies the means by which the file
{       is accessed.  Specification of amc$record access_level implies the task
{       will access the file using GET and/or PUT requests.  Record access is
{       required if the file organization is indexed-sequential, system-key or
{       direct-access or if the file's device class is other than mass storage.
{       Specification of amc$segment access_level implies the task intends to
{       access the file as memory using machine instructions.  An initialized
{       pointer to the segment can be obtained by issuing a subsequent
{       amp$get_segment_pointer request.  Segment access is only supported for
{       mass storage files.
{
{ FILE_ATTACHMENT: (input)  This parameter specifies the attachment options to
{       be in effect for this instance of open.  If the file is not already
{       attached to the job, this request effects the attachment.  If the
{       attachment to the job originates with this request, the file is
{       automatically detached by the fsp$close_file request for the last
{       instance of open of the file within the job.  A value of NIL for this
{       parameter specifies no attachment options are provided.
{
{       This parameter supports multiple specification of options
{       fsc$access_and_share_modes and fsc$open_share_modes as described below.
{       If other attachment options are specified multiple times in the array,
{       only the first specification is used.
{
{    fsc$access_and_share_modes:
{
{          It is recommended that the task specify only the access_modes that
{          are required by the task's access; this may promote sharing of the
{          file, improving both the performance and the usability of the
{          system.
{
{          NOS/VE validates all attachments of a file against the file's
{          access-control list and against the modes of sharing authorized by
{          other jobs that currently have the file attached.
{
{          The values of access_modes and share_modes that are authorized
{          depend upon whether or not this request creates the file or attaches
{          it to the requesting job.
{
{          If the file cycle is created by this request:
{
{          - The fsc$specific_access_modes option of access_modes causes the
{          file to be attached for the modes of access that were specified.
{
{          - The fsc$permitted_access_modes option of access_modes causes the
{          file to be attached for all modes of access because CYCLE permission
{          authorizes all modes of access to the creator of a cycle.
{
{          - The fsc$specific_share_modes option of share_modes causes the file
{          to be attached for the modes of sharing specified regardless of the
{          share_requirement in the access-control list because CYCLE
{          permission preempts any share requirement in the file's
{          access-control list.
{
{          - The fsc$required_share_modes option of share_modes causes the file
{          to be attached for exclusive access because CYCLE permission
{          dictates no sharing requirement and preempts any share requirement
{          in the file's access-control list.
{
{          - The fsc$determine_from_access_modes option of share_modes causes
{          the cycle to be attached for no sharing if the access_modes include
{          fsc$append, fsc$modify, or fsc$shorten; otherwise, the file is
{          attached for the share modes of fsc$read and fsc$execute.
{
{          If the file cycle exists and is not currently attached to the job:
{
{          - The fsc$specific_access_modes option of access_modes causes the
{          cycle to be attached for the specified modes of access.
{
{          - The fsc$permitted_access_modes option of access_modes causes the
{          cycle to be attached for those modes of access authorized by the
{          file's access-control list as qualified by the share requirements of
{          other jobs that have the cycle attached and the value of the
{          validation_ring attachment option.
{
{          - The fsc$specific_share_modes option of share_modes causes the
{          cycle to be attached for the specified modes of sharing; but the
{          proposed modes of sharing must include the share requirement in the
{          file's access-control list and include the union of access modes
{          specified by other jobs that have the cycle attached.
{
{          - The fsc$required_share_modes option of share_modes causes the
{          cycle to be attached for the modes of sharing consisting of the
{          union of the share requirement in the file's access-control list and
{          the outstanding access modes specified by other jobs that have the
{          cycle attached.  After the file is opened, the program may need to
{          validate that it can tolerate the modes of sharing that are imposed
{          by this option; the amp$fetch interface may be used to obtain the
{          required share modes (global_share_modes).
{
{          - The fsc$determine_from_access_modes option of share_modes causes
{          the cycle to be attached for no sharing if the access_modes include
{          fsc$append, fsc$modify, or fsc$shorten; otherwise, the file is
{          attached for the share modes of fsc$read and fsc$execute.
{
{          If the file cycle is already attached to the job:
{
{          - The fsc$specific_access_modes option of access_modes causes the
{          modes of access specified to be used.
{
{          - The fsc$permitted_access_modes option of access_modes causes the
{          modes of access specified by the attachment of the cycle to the job
{          to be used as qualified by the open_share_modes in effect and the
{          validation_ring attachment option.
{
{          - The fsc$specific_share_modes option of share_modes must specify
{          share modes that include the modes of sharing specified by the
{          attachment of the cycle to the job.
{
{          - The fsc$required_share_modes option causes the share_modes
{          specified by the attachment of the cycle to the job, i.e.  the
{          global_share_modes, to be used.  The program may need to validate
{          after the open that it can tolerate the modes of sharing that are
{          imposed by this option; the amp$fetch interface may be used to
{          obtain the global_share_modes.
{
{          - The fsc$determine_from_access_modes option of share_modes causes
{          the share modes to be determined from the access_modes specified.
{          If the access_modes include fsc$append, fsc$modify, or fsc$shorten,
{          then no sharing is allowed; otherwise, fsc$read and fsc$execute are
{          chosen.
{
{          If more than one record of type fsc$access_and_share_modes is
{          specified, the first record is considered to be the "preferred" one
{          and the remaining records of this type are considered to be
{          alternate specifications in the order in which they are provided in
{          the array.  The alternate specifications are processed only in the
{          event that the preferred alternative is not authorized.
{
{          Access to a cycle is only authorized if the user is permitted for
{          all the access modes specified, the task is executing in the correct
{          ring for the requested access, and the requested share modes include
{          both the minimum requirement defined in the access-control list and
{          the access modes of any other jobs that have the file attached.
{
{    fsc$allowed_exceptions:  This option determines whether or not the
{          existence of certain exception conditions are reported to the task.
{          This option not only affects the processing of exception conditions
{          by FSP$OPEN_FILE but also affects requests associated with the
{          instance of open including FSP$CLOSE_FILE and record access requests
{          (e.g.  AMP$GET_NEXT, AMP$PUT_NEXT).  Once the file is successfully
{          opened for segment access, exception conditions that occur during
{          the task's segment access are reported and handled using NOS/VE's
{          condition-handling process.
{
{          Allowed exception conditions fall into one of two categories:  1)
{          those exception conditions that identify possible inconsistencies in
{          the file's attributes or data and 2) those that temporarily block
{          access to the file.  The category 1 conditions are identified by the
{          field DAMAGE_SYMPTOMS.  The category 2 conditions are identified by
{          the field ACCESS_CONDITIONS.
{
{          If the ALLOWED_EXCEPTIONS option is explicitly specified and the
{          detected condition is in neither the DAMAGE_SYMPTOMS set nor the
{          ACCESS_CONDITIONS set, the request terminates with abnormal status
{          as soon as the condition is detected.  The request is completely
{          retracted.
{
{          If the allowed exception is in the DAMAGE_SYMPTOMS set, the
{          condition is ignored by FSP$OPEN_FILE and other requests associated
{          with the instance of open.
{
{          If the allowed exception is in the ACCESS_CONDITIONS set:
{
{          - FSP$OPEN_FILE waits for the duration of time identified in the
{          WAIT_FOR_ATTACHMENT option for the condition to clear.  If at the
{          expiration of the wait time the condition remains set, abnormal
{          status is returned.
{
{          - Record access requests, segment accessors, and FSP$CLOSE_FILE wait
{          indefinitely for the condition to clear.
{
{          If the task does not want to wait under any circumstance, a null set
{          should be specified for ACCESS_CONDITIONS and DAMAGE_SYMPTOMS.
{
{          The value specified for this option when the file is initially
{          attached to the job must be specified by all subsequent instances of
{          open within the job until the file is detached from the job.
{
{          If this option is omitted:
{
{          - For conditions in the ACCESS_CONDITIONS set, FSP$OPEN_FILE waits
{          for the duration of time specified by the WAIT_FOR_ATTACHMENT
{          option; other requests and segment accessors wait indefinitely.
{
{          - For conditions in the DAMAGE_SYMPTOMS set, abnormal status is
{          returned.
{
{    fsc$create_file:  The value TRUE authorizes both the registration and the
{          initial opening of the file.
{
{          The value FALSE prevents file and or cycle registration and initial
{          opening of the cycle.  The specification of FALSE is recommended in
{          those situations where pre-existence of the file is assumed or
{          required.  Specifying the value FALSE removes the need to use some
{          other request to validate the existence of the file prior to opening
{          it or the need to parse the FILE parameter in advance to detect the
{          use of the '$NEXT' cycle reference in situations where cycle
{          pre-existence is mandatory.
{
{          This request does not support creation of non-mass storage files.
{          Because of this, the fsc$create_file option is ignored for files
{          assigned to device classes other than mass storage.
{
{          If you intend to append to an existing cycle, ensure that you
{          specify FALSE for this option; otherwise, this request may cause
{          creation of a cycle in certain situations.  Refer to the FILE
{          parameter discussion.
{
{    fsc$delete_data:  If the value TRUE is specified and the following
{          conditions hold, the data in the file is discarded as a result of
{          the open; otherwise, any data previously written to the file is
{          unaffected by this request:
{
{             1.  The file must either already be attached to the job for
{                 exclusive access (share modes is a null set) or become
{                 attached to the job for exclusive access as a result of this
{                 request.
{
{             2.  The access modes specified (or determined by default) for the
{                 instance of open must include fsc$shorten access.
{
{             3.  The file must not be currently open within the job.
{
{             4.  The open position specified (or determined by default) is
{                 $BOI.
{
{    fsc$error_exit_procedure_name:  fsc$error_exit_procedure:  Specification
{          of error_exit_procedure_name and error_exit_procedure are mutually
{          exclusive if the value specified for error_exit_procedure_name is
{          not osc$null_name.
{
{    fsc$exception_detection:  This option specifies whether or not any
{          optional detection of exception conditions is to be performed while
{          the file is attached.  Detection of the following conditions is
{          optional:
{
{          FSC$MEDIA_IMAGE_INCONSISTENT - If a mass storage file is attached
{          for write access and detection of this condition is requested, the
{          system takes precautions to detect the possible loss of modified
{          pages from the central memory image during a system interruption.
{          If this detection is requested and there is the possibility that
{          modified pages of the file have been lost, the condition is reported
{          the next time the file is attached.  For complete protection, the
{          task must preallocate the file's mass storage space using the
{          mmp$preallocate_file_space request; otherwise, allocation
{          information could be lost, if the central memory image cannot be
{          maintained or recovered.
{
{    fsc$free_behind:  This option specifies whether or not pages previously
{          read into memory from a mass storage file are to be discarded when
{          the position of the accessor changes to a different transfer unit.
{
{    fsc$open_share_modes:  This option is used to control sharing of a file
{          within the job.  When specified by the first of several concurrent
{          instances of open, this option constrains the access modes of
{          subsequent concurrent instances of open.
{
{          If more than one open_share_modes is specified, the first one is
{          considered to be the "preferred" one and the remaining ones are
{          considered to be alternatives.  If there are no outstanding
{          instances of open, the preferred open share modes specification is
{          used to constrain the access modes allowed to subsequent, concurrent
{          instances of open.  The alternatives are considered only when there
{          is another instance of open outstanding and the preferred open share
{          modes does not include the modes of access specified by other
{          concurrent instances of open.
{
{    fsc$open_position:  This option specifies the position at which the file
{          is opened.  If specified, the value supercedes the open position
{          specified in the FILE parameter expression.
{
{    fsc$password:  This option specifies a password to be compared with the
{          value of the file's password in the catalog.  An attachment is
{          permitted only if the values are identical.  If the file is created
{          as a result of this request, the specified password is stored in the
{          catalog and used to authenticate future attachments of the file.
{
{    fsc$private_read:  This option specifies whether or not file access should
{          be private.  If the value TRUE is specified, a reader does not
{          affect the position of nonprivate accessors (i.e.  those instances
{          of open that specified FALSE for this option).  A writer can never
{          be considered a private reader.  If private_read is specified on
{          both the fsp$open_file request and an ATTACH_FILE command, the
{          fsp$open_file specification is used.  The default value of
{          private_read is determined solely by the access_modes in effect for
{          the instance of open; if the access_modes do not include write,
{          private_read defaults to TRUE; otherwise, the default is FALSE.
{
{    fsc$sequential_access:  This option specifies that access to a file opened
{          for either record or segment access is performed in a sequential
{          manner.  This implies the intent to read mass storage data at the
{          device rate.
{
{    fsc$tape_attachment:  This option specifies how a labeled tape file is to
{          be accessed.
{
{    fsc$tape_error_options:  This option specifies how media failure recovery
{          is to be performed.
{
{    fsc$transfer_size:  This option specifies the minimum amount of data that
{          is read from a mass storage file when sequential access is specified
{          or detected.
{
{    fsc$validation_ring:  This option specifies the ring to be used for access
{          validation.  This option is recommended for use by a subsystem that
{          executes in a more privileged ring than its caller; the caller's
{          ring may be used to validate the attachment.  Thus the caller is not
{          able to misuse the privilege of the subsystem to attach files to
{          which the caller would otherwise not have access.
{
{          If specified, the file or file cycle is created as a result of this
{          request, and the ring_attributes are not specified using the
{          default_creation_attributes or mandated_creation_attributes
{          parameters, the ring_attributes default to the validation_ring
{          specified.
{
{    fsc$wait_for_attachment:  This option specifies whether or not the caller
{          wants to wait for the file to be attached to the job.  If the file
{          is already attached to the job, this option is ignored.  If the
{          caller specifies the osc$wait choice, a wait duration must also be
{          provided.
{
{ DEFAULT_CREATION_ATTRIBUTES: (input)  This parameter specifies the value to
{       be given to a file attribute in the absence of a specification for that
{       attribute by a SET_FILE_ATTRIBUTES command and the
{       MANDATED_CREATION_ATTRIBUTES parameter of this request.  If FILE was
{       previously opened, this parameter is ignored.  A value of NIL for this
{       parameter specifies no default creation attributes are provided.  If
{       the same attribute is specified multiple times in the array, the last
{       specification is used.
{
{ MANDATED_CREATION_ATTRIBUTES: (input)  This parameter specifies file
{       attribute values that must be defined, if the file is initially opened
{       by this request.  If the FILE was previously opened, this parameter is
{       ignored.  Attribute values specified using this parameter have greater
{       precedence than those specified using the DEFAULT_CREATION_ATTRIBUTES
{       parameter of this request and the SET_FILE_ATTRIBUTES command.  A value
{       of NIL for this parameter specifies no mandated creation attributes are
{       provided.  If the same attribute is specified multiple times in the
{       array, the last specification is used.
{
{ ATTRIBUTE_VALIDATION: (input)  This parameter specifies the desired attribute
{       values of the file.  Values of attributes specified by this parameter
{       are compared with those in effect for the FILE.  An
{       ame$attribute_validation_error abnormal status is returned if none of
{       values specified by this parameter match the file's attribute value.
{
{       This parameter allows alternatives to be specified for each attribute
{       to be validated.  To specify an alternative value for an attribute,
{       simply provide another record in the array.  Alternatives are processed
{       in the order given.  Once an alternative is found that matches the
{       value of the corresponding file attribute, subsequent alternatives are
{       ignored.
{
{ ATTRIBUTE_OVERRIDE: (input)  This parameter specifies an attribute value to
{       be used only for this instance of open of the file or file cycle.  Only
{       record type, block type, file organization and ring attributes can be
{       overridden.  Only a ring 3 caller can override attributes for a file or
{       file cycle to be written upon.  Ring attributes may only be overridden
{       by a ring 3 caller whose requested access does not include fsc$append,
{       fsc$modify or fsc$shorten.  If the same attribute is specified multiple
{       times in the array, the last specification is used.
{
{ FILE_IDENTIFIER: (output)  This parameter specifies the identity of the
{       instance of open of the file created by this request.
{
{ STATUS: (ouput) This parameter specifies the request status.
{       CONDITION:
{                   ame$attribute_validation_error
{                   ame$concurrent_open_limit
{                   ame$concurrent_tape_limit
{                   ame$conflicting_file_access
{                   ame$damaged_file_attributes
{                   ame$file_not_known
{                   ame$fo_access_level_conflict
{                   ame$fo_device_class_conflict
{                   ame$improper_access_level
{                   ame$improper_append_open
{                   ame$improper_file_attrib_key
{                   ame$improper_file_attrib_value
{                   ame$improper_fo_override
{                   ame$improper_override_access
{                   ame$improper_record_override
{                   ame$improper_ss_block_override
{                   ame$improper_us_block_override
{                   ame$improper_write_override
{                   ame$incompatible_file_connect
{                   ame$keyed_file_fap_missing
{                   ame$local_file_limit
{                   ame$mbl_less_than_mibl
{                   ame$mbl_less_than_mrl
{                   ame$multiple_open_of_tape
{                   ame$new_file_requires_append
{                   ame$no_permission_for_access
{                   ame$no_write_ring.
{                   ame$non_ANSI_blocking
{                   ame$not_physical_access_device
{                   ame$not_virtual_memory_device
{                   ame$null_access_mode
{                   ame$ring_validation_error
{                   ame$terminal_task_limit
{                   ame$unable_to_load_collate_tabl
{                   ame$unable_to_load_error_exit
{                   ame$unable_to_load_fap
{                   ame$unable_to_load_label_exit
{                   fse$concurrent_access_conflict
{                   fse$redundant_access_choice
{                   fse$concurrent_share_conflict
{                   pfe$cycle_overflow
{                   pfe$cycle_underflow
{                   pfe$cycles_media_missing
{                   pfe$duplicate_cycle
{                   pfe$incorrect_password
{                   pfe$invalid_ring_access
{                   pfe$lfn_in_use
{                   pfe$name_already_subcatalog
{                   pfe$name_not_permanent_file
{                   pfe$nth_name_not_subcatalog
{                   pfe$path_too_short
{                   pfe$pf_system_error
{                   pfe$respf_modification_mismatch
{                   pfe$sharing_not_permitted
{                   pfe$undefined_data
{                   pfe$unknown_cycle
{                   pfe$unknown_family
{                   pfe$unknown_master_catalog
{                   pfe$unknown_nth_subcatalog
{                   pfe$unknown_permanent_file
{                   pfe$usage_not_permitted
{       IDENTIFIER: fsc$file_system_id.
{
*DECK DECK=FSH$RESOLVE_FILE_REFERENCE EXPAND=FALSE
{
{   The purpose of this procedure is to evaluate a file reference and to return
{ a string representation of the file reference that includes a cycle number,
{ if applicable.  If the file expression omits the cycle reference or the cycle
{ reference is specified generically ($HIGH, $LOW, or $NEXT), the cycle number
{ is determined (resolved) by referencing the file's cycle list in the catalog
{ entry.
{
{       FSP$RESOLVE_FILE_REFERENCE (FILE_REFERENCE, RESOLVED_FILE_REFERENCE,
{         RESOLVED_FILE_REFERENCE_SIZE, STATUS)
{
{ FILE_REFERENCE: (input)  This parameter specifies the file expression to be
{       evaluated and resolved.
{
{ RESOLVED_FILE_REFERENCE: (output)  This parameter specifies the evaluated and
{       resolved file reference.
{
{ RESOLVED_FILE_REFERENCE_SIZE: (output)  This parameter specifies the number
{       of non blank characters in the resolved file reference.
{
{ STATUS: (output) This parameter specifies the request status.
*DECK DECK=FSH$RESOLVE_PATH EXPAND=FALSE
{       FSP$RESOLVE_PATH
{
{   The purpose of this procedure is to resolve the path it is given such that
{ the caller can determine whether the path designates an object that exists --
{ if so, whether it is a catalog or a file; and if it is file, which specific
{ cycle is being referenced.
{
{   The resolution of the PATH_ELEMENTS/CYCLE_REFERENCE combination is
{ determined according to the following rules.
{
{     For $local files:
{
{       1. If there is only one entry in the PATH_ELEMENTS array, then if
{          CYCLE_REFERENCE.SPECIFICATION =
{
{          (a) FSC$CYCLE_OMITTED - return:
{                  PATH_RESOLUTION              as FSC$CATALOG_PATH
{          (b) FSC$HIGH_CYCLE, FSC$LOW_CYCLE, FSC$NEXT_CYCLE or
{              FSC$CYCLE_NUMBER - return:
{                  abnormal status (fse$catalogs_do_not_have_cycles)
{
{       2. If there are more than two entries in the PATH_ELEMENTS array,
{          return abnormal status (fse$local_subcatalog_illegal).
{
{       3. If the last entry of the PATH_ELEMENTS array designates an object
{          that does not exist, then if CYCLE_REFERENCE.SPECIFICATION =
{
{          (a) FSC$CYCLE_OMITTED - return:
{                  CYCLE_REFERENCE.CYCLE_NUMBER as 1
{                  PATH_RESOLUTION              as FSC$PATH_DOES_NOT_EXIST
{          (b) FSC$HIGH_CYCLE or FSC$LOW_CYCLE - return:
{                  abnormal status (pfe$unknown_permanent_file)
{          (c) FSC$NEXT_CYCLE - return:
{                  CYCLE_REFERENCE.CYCLE_NUMBER as 1
{                  PATH_RESOLUTION              as FSC$NEW_FILE_PATH
{          (d) FSC$CYCLE_NUMBER - return:
{                  PATH_RESOLUTION              as FSC$NEW_FILE_PATH
{
{       4. If the last entry of the PATH_ELEMENTS array designates a file,
{          then if CYCLE_REFERENCE.SPECIFICATION =
{
{          (a) FSC$CYCLE_OMITTED or FSC$HIGH_CYCLE - return:
{                  CYCLE_REFERENCE.CYCLE_NUMBER as the number of the file's
{                                               currently highest cycle
{                  PATH_RESOLUTION              as FSC$CYCLE_PATH
{          (b) FSC$LOW_CYCLE - return:
{                  CYCLE_REFERENCE.CYCLE_NUMBER as the number of the file's
{                                               currently lowest cycle
{                  PATH_RESOLUTION              as FSC$CYCLE_PATH
{          (c) FSC$NEXT_CYCLE - return:
{                  CYCLE_REFERENCE.CYCLE_NUMBER as the number of the file's
{                                               currently highest cycle + 1
{                  PATH_RESOLUTION              as FSC$NEW_CYCLE_PATH
{          (d) FSC$CYCLE_NUMBER, and the cycle exists - return:
{                  PATH_RESOLUTION              as FSC$CYCLE_PATH
{          (e) FSC$CYCLE_NUMBER, and the cycle does not exist - return:
{                  PATH_RESOLUTION              as FSC$NEW_CYCLE_PATH
{
{     For non $local files:
{
{       1. If the PATH_ELEMENTS array consists of a single element, return
{          abnormal status (pfe$path_too_short).
{
{       2. If any but the last entry of the PATH_ELEMENTS array designates
{          an object that does not exist, return appropriate abnormal status.
{
{       3. If the last entry of the PATH_ELEMENTS array designates an object
{          that does not exist, then if CYCLE_REFERENCE.SPECIFICATION =
{
{          (a) FSC$CYCLE_OMITTED - return:
{                  CYCLE_REFERENCE.CYCLE_NUMBER as 1
{                  PATH_RESOLUTION              as FSC$PATH_DOES_NOT_EXIST
{          (b) FSC$HIGH_CYCLE or FSC$LOW_CYCLE - return:
{                  abnormal status (pfe$unknown_permanent_file)
{          (c) FSC$NEXT_CYCLE - return:
{                  CYCLE_REFERENCE.CYCLE_NUMBER as 1
{                  PATH_RESOLUTION              as FSC$NEW_FILE_PATH
{          (d) FSC$CYCLE_NUMBER - return:
{                  PATH_RESOLUTION              as FSC$NEW_FILE_PATH
{
{       4. If the last entry of the PATH_ELEMENTS array designates a
{          catalog, then if CYCLE_REFERENCE.SPECIFICATION =
{
{          (a) FSC$CYCLE_OMITTED - return:
{                  PATH_RESOLUTION              as FSC$CATALOG_PATH
{          (b) FSC$HIGH_CYCLE, FSC$LOW_CYCLE, FSC$NEXT_CYCLE or
{              FSC$CYCLE_NUMBER - return:
{                  abnormal status (fse$catalogs_do_not_have_cycles)
{
{       5. If the last entry of the PATH_ELEMENTS array designates a file,
{          then if CYCLE_REFERENCE.SPECIFICATION =
{
{          (a) FSC$CYCLE_OMITTED or FSC$HIGH_CYCLE - return:
{                  CYCLE_REFERENCE.CYCLE_NUMBER as the number of the file's
{                                               currently highest cycle
{                  PATH_RESOLUTION              as FSC$CYCLE_PATH
{          (b) FSC$LOW_CYCLE - return:
{                  CYCLE_REFERENCE.CYCLE_NUMBER as the number of the file's
{                                               currently lowest cycle
{                  PATH_RESOLUTION              as FSC$CYCLE_PATH
{          (c) FSC$NEXT_CYCLE - return:
{                  CYCLE_REFERENCE.CYCLE_NUMBER as the number of the file's
{                                               currently highest cycle + 1
{                  PATH_RESOLUTION              as FSC$NEW_CYCLE_PATH
{          (d) FSC$CYCLE_NUMBER, and the cycle exists - return:
{                  PATH_RESOLUTION              as FSC$CYCLE_PATH
{          (e) FSC$CYCLE_NUMBER, and the cycle does not exist - return:
{                  PATH_RESOLUTION              as FSC$NEW_CYCLE_PATH
{
{
{ FSP$RESOLVE_PATH (PATH_ELEMENTS, CYCLE_REFERENCE, PATH_RESOLUTION, STATUS)
{
{ PATH_ELEMENTS: (input) This parameter specifies the element names of the
{       path to be resolved.
{
{ CYCLE_REFERENCE: (i/o) This parameter specifies the cycle reference to
{       resolve, as input, and the resolved cycle reference, as output.
{
{ PATH_RESOLUTION: (output) This parameter specifies the resolution of the
{       PATH_ELEMENTS/CYCLE_REFERENCE.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=FSH$SUBSYSTEM_COPY_FILE EXPAND=FALSE
{
{   The purpose of this request is to copy one file to another.
{
{   The function of this interface is identical to fsp$copy_file with the
{ exception that this interface allows the caller to specify the conditions
{ under which the input and output files are to be attached to the job.  Use of
{ this interface has the following advantages over the use of fsp$copy_file:
{
{   1.  The input and or the output file may be shared with a writer during the
{       copy operation (use ACCESS_AND_SHARE_MODES and OPEN_SHARE_MODES
{       options).
{
{   2.  If either the input or the output file is password protected, the copy
{       operation may be performed without having to attach the files
{       beforehand (use the PASSWORD option).
{
{   3.  If your program is executing in a more privileged (lesser numbered)
{       ring, you may request that the copy operation be validated using your
{       caller's ring privilege (use the VALIDATION_RING option).
{
{   4.  By specifying FALSE for PRIVATE_READ and using the OPEN_POSITION option
{       for the input file and or the output file, it is possible to copy all
{       or part of the input file to the beginning, middle, or end of the
{       output file.  If you use the amc$open_no_positioning ($ASIS)
{       OPEN_POSITION, the position in either file must be established prior to
{       calling this request; refer to AMP$GET_NEXT and
{       AMP$SET_SEGMENT_POSITION.
{
{   The caller of this interface is responsible for the consequences of its
{ use.  Unless you have a requirement to specify attachment options for the
{ input file and or the output file, you should use fsp$copy_file.
{
{   This interface requires that the input file's access_modes include read
{ access and the output file's access_modes include shorten and or append
{ access.  Failure to include this minimal access may cause an access violation
{ during the copy operation.
{
{   The copy operation may have an undesirable effect on other instances of
{ open of either the input file or the output file unless you take certain
{ precautions.  Refer to the discussion of the INPUT_FILE_ATTACHMENT and
{ OUTPUT_FILE_ATTACHMENT parameters for more information.
{
{       FSP$SUBSYSTEM_COPY_FILE (INPUT, OUTPUT, INPUT_FILE_ATTACHMENT,
{         OUTPUT_FILE_ATTACHMENT, INPUT_ATTRIBUTE_VALIDATION,
{         OUTPUT_ATTRIBUTE_VALIDATION, OUTPUT_CREATION_ATTRIBUTES, STATUS)
{
{ INPUT: (input)  This parameter specifies the name of the file from which data
{       is to be copied.  The open position provided in the file expression is
{       overridden by the value of the open position specified by the
{       INPUT_FILE_ATTACHMENT parameter.
{
{ OUTPUT: (input)  This parameter specifies the name of the file to which data
{       is to be copied.  The open position provided in the file expression is
{       overridden by the value of the open position specified by the
{       OUTPUT_FILE_ATTACHMENT parameter.
{
{ INPUT_FILE_ATTACHMENT: (input)  This parameter specifies the attachment
{       options to be in effect for the input file.  Refer to the documentation
{       of the FILE_ATTACHMENT parameter of FSP$OPEN_FILE for further
{       information.
{
{       It is recommended that you specify the following values for the input
{       file unless your application requires otherwise:
{
{       ACCESS_AND_SHARE_MODES - access_modes:  read; share_modes:  (read
{       execute)
{
{       CREATE_FILE - false
{
{       DELETE_DATA - false (This will be the default if left unspecified)
{
{       OPEN_SHARE_MODES - (read execute).  This ensures that the file cannot
{       be modifed during the copy operation but allows concurrent readers.
{
{       PRIVATE_READ- true, if the access modes do not include write access.
{       This ensures that the copy operation does not affect nonprivate readers
{       of the input file.  Otherwise, do not specify PRIVATE_READ.
{
{       If the OPEN_SHARE_MODES are not explicitly specified,
{       FSP$SUBSYSTEM_COPY_FILE provides a default of:
{
{       1st record:  (read execute)
{
{       2nd record:  ALL.  However, by default, the implementation of ALL does
{       not share the file for write access with another job.  By default, the
{       implementation of ALL does not share the file for write access within
{       the requesting job unless the writer's instance of open is in the same
{       task and prevents other tasks from opening the file for write access.
{
{       Because OPEN_SHARE_MODES are always specified when opening the input
{       file, the JOB_WRITE_CONCURRENCY parameter of the ATTACH_FILE command
{       has no effect on the input file of this request.
{
{ OUTPUT_FILE_ATTACHMENT: (input)  This parameter specifies the attachment
{       options to be in effect for the output file.  Refer to the
{       documentation of the FILE_ATTACHMENT parameter of FSP$OPEN_FILE for
{       further information.
{
{       It is recommended that you specify the following values for the output
{       file unless your application requires otherwise:
{
{       ACCESS_AND_SHARE_MODES
{
{       1st record:  access_modes:  (append shorten) share_modes:  (none)
{
{       2nd record:  access_modes:  (append) share_modes:  (none)
{
{       CREATE_FILE - do not specify.  This will have the same effect as
{       specifying CREATE_FILE=FALSE for permanent files with a cycle
{       specification of $LOW or $HIGH, and CREATE_FILE=TRUE for all other
{       cases.
{
{       DELETE_DATA - true
{
{       OPEN_SHARE_MODES
{
{       1st record:  (none)
{
{       2nd record:  (all)
{
{       PRIVATE_READ - false (This will be the default if left unspecified)
{
{
{ INPUT_ATTRIBUTE_VALIDATION: (input)  This parameter specifies the required
{       attribute values of the input file.  Refer to the description of the
{       ATTRIBUTE_VALIDATION parameter of FSP$OPEN_FILE for more information.
{
{ OUTPUT_ATTRIBUTE_VALIDATION: (input)  This parameter specifies the required
{       attribute values of the output file.  Refer to the description of the
{       ATTRIBUTE_VALIDATION parameter of FSP$OPEN_FILE for more information.
{
{ OUTPUT_CREATION_ATTRIBUTES: (input)  This parameter specifies file attribute
{       values which are mandated for the output file, if it is created by this
{       request.  Refer to the description of the MANDATED_CREATION_ATTRIBUTES
{       parameter of FSP$OPEN_FILE for more information.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION: Only the conditions not in common with fsp$copy_file are
{                  included below:
{
{       IDENTIFIER: amc$access_method_id.
{
*DECK DECK=FSH$TRAILER_LABELS EXPAND=FALSE
{
{    This function returns a boolean value.  The value TRUE is returned if any
{ of the following values are in the LABEL_GROUP:  fsc$ansi_eof1_label_kind,
{ fsc$ansi_eof2_label_kind, fsc$ansi_eofn_label_kind, fsc$ansi_utla_label_kind,
{ fsc$ansi_eov1_label_kind, fsc$ansi_eov2_label_kind, and
{ fsc$ansi_eovn_label_kind; otherwise, FALSE is returned.
{
{       FSP$TRAILER_LABELS (LABEL_GROUP)
{
{ LABEL_GROUP: (input)  This parameter specifies the set of ANSI label kinds
{       that are to be analyzed.
{
*DECK DECK=FSH$VALIDATE_FILE_IDENTIFIER EXPAND=FALSE
{
{    The purpose of this request is to validate a file_identifier.
{
{       FSP$VALIDATE_FILE_IDENTIFIER (FILE_IDENTIFIER, FILE_ID_IS_VALID)
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the file access identifier
{       established when the file was opened.
{
{ FILE_ID_ID_VALID: (output)  A value of TRUE is returned in this parameter if
{       the file identifier is valid and a value of FALSE is returned if the
{       file identifier is invalid.
{
*DECK DECK=FSH$VERSION_ONE_TAPE_LABEL EXPAND=FALSE
{
{    This function returns a boolean result.  This function returns TRUE, if
{ the IMPLEMENTATION_IDENTIFIER is 'NOS/VE V1.0'; otherwise, FALSE is returned.
{
{    FSP$VERSION_ONE_TAPE_LABEL ( IMPLEMENTATION_IDENTIFIER)
{
{ IMPLEMENTATION_IDENTIFIER: (input)  This parameter specifies the value of the
{     HDR1 implementation identifier field.  This field is used to identify the
{     vendor that wrote the ANSI file.  NOS/VE also uses this field to
{     determine the security policy for a file set.
{
*DECK DECK=FSH$VERSION_TWO_TAPE_LABEL EXPAND=FALSE
{
{    This function returns a boolean result.  This function returns TRUE, if
{ the IMPLEMENTATION_IDENTIFIER is 'NOS/VE V2.0'; otherwise, FALSE is returned.
{
{    FSP$VERSION_TWO_TAPE_LABEL ( IMPLEMENTATION_IDENTIFIER)
{
{ IMPLEMENTATION_IDENTIFIER: (input)  This parameter specifies the value of the
{     HDR1 implementation identifier field.  This field is used to identify the
{     vendor that wrote the ANSI file.  NOS/VE also uses this field to
{     determine the security policy for a file set.
{
*DECK DECK=FSH$VE_WROTE_ANSI_FILE EXPAND=FALSE
{
{    This function returns a boolean result.  This function returns TRUE, if
{ the IMPLEMENTATION_IDENTIFIER begins with 'NOS/VE V'; otherwise, FALSE is
{ returned.
{
{       FSP$VE_WROTE_ANSI_FILE ( IMPLEMENTATION_IDENTIFIER)
{
{ IMPLEMENTATION_IDENTIFIER: (input)  This parameter specifies the value of the
{       HDR1 implementation identifier field.  This field is used to identify
{       the vendor that wrote the ANSI file.  NOS/VE also uses this field to
{       determine the security policy for a file set.
{
*DECK DECK=FSH$VOLUME_HEADER_LABELS EXPAND=FALSE
{
{    This function returns a boolean value.  The value TRUE is returned if any
{ of the following values are in the LABEL_GROUP:  fsc$ansi_uvln_label_kind,
{ fsc$ansi_vol1_label_kind, and fsc$ansi_voln_label_kind; otherwise, FALSE is
{ returned.
{
{       FSP$VOLUME_HEADER_LABELS (LABEL_GROUP)
{
{ LABEL_GROUP: (input)  This parameter specifies the set of ANSI label kinds
{       that are to be analyzed.
{
*DECK DECK=FSH$VOLUME_TRAILER_LABELS EXPAND=FALSE
{
{    This function returns a boolean value.  The value TRUE is returned if any
{ of the following values are in the LABEL_GROUP:  fsc$ansi_eov1_label_kind,
{ fsc$ansi_eov2_label_kind, fsc$ansi_eovn_label_kind; otherwise, FALSE is
{ returned.
{
{       FSP$VOLUME_TRAILER_LABELS (LABEL_GROUP)
{
{ LABEL_GROUP: (input)  This parameter specifies the set of ANSI label kinds
{       that are to be analyzed.
{
*DECK DECK=FSK$KEYPOINTS EXPAND=FALSE
{ This deck contains all of the file system keypoint constants.

  CONST

    { Entry/eXit class keypoints }

    fsk$change_cycle_damage = fsk$base,
    {E 'fsp$change_cycle_damage' }
    {X 'fsp$change_cycle_damage' }

    fsk$change_cycle_date_time = fsk$base + 1,
    {E 'fsp$change_cycle_date_time' 'callring' I20}
    {X 'fsp$change_cycle_date_time' }

    fsk$open_file = fsk$base + 2,
    {E 'fsp$open_file' }
    {X 'fsp$open_file' }

    fsk$create_file = fsk$base + 3,
    {E 'fsp$create_file' }
    {X 'fsp$create_file' }

    { Unusual class keypoints }

    fsk$invalid_cycle_specification = fsk$base,
    {U 'invalid cycle specification'}

    fsk$invalid_share_mode_selector = fsk$base + 1;
    {U 'invalid share mode selector'}

    { Debug class keypoints }

?? PUSH (LISTEXT := ON) ??
*copyc amk$base_keypoint_values
?? POP ??
*DECK DECK=FSM#EXPAND_FILE_LABEL EXPAND=TRUE
MODULE fsm#expand_file_label;
?? RIGHT := 90 ??

{FSP#EXPAND_FILE_LABEL   returns requested file attributes from a file label

?? NEWTITLE := 'Global Declarations Referenced By This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fmt#file_attribute_keys_set

*copyc fmc$unique_label_id
*copyc ame$attribute_validation_errors
*copyc amt$file_reference
*copyc amt$path_name
*copyc bat$static_label_attributes
*copyc fmt$file_attribute_keys
*copyc fmt$static_label_header
*copyc fmt$static_label_item
*copyc ost$halfword
*copyc ost$name_reference
?? POP ??
*copyc fip#move

*copyc fsp$convert_to_old_contents
*copyc osp$set_status_abnormal
*copyc pmp$load

?? TITLE := '[xdcl] FSP#EXPAND_FILE_LABEL', EJECT ??

  PROCEDURE [XDCL] fsp#expand_file_label
    (    file_label_p: ^SEQ ( * );
         requested_label_atts: fmt#file_attribute_keys_set;
     VAR label_atts: bat$static_label_attributes;
     VAR file_previously_opened: boolean;
     VAR status: ost$status);

{Return the REQUESTED_LABEL_ATTRIBUTES in FILE_LABEL.
{
{The FILE_LABEL sequence is next-ed for each existing attribute. If the
{attribute is a requested one, it is set into LABEL_ATTS.  This process
{is repeated until all requested file attributes have been found.
{
{NOTES
{ . For faster execution, no ELSE is used in the CASE statements involving
{   the FMT$FILE_ATTRIBUTE_KEYS selector.  This means if a new file attribute
{   key is added, this code must be updated. Even an ELSE would not get away
{   from this problem should a new file attribute key be added, as there would
{   still be no way of knowing how many bytes to skip in the label for the
{   new attribute.

    VAR {!?Kludge so can preset string pointers to non-nil value.?!
      null_string: [READ] string (0) := '';

    VAR
      attribute_key: fmt$file_attribute_keys,
      header_p: ^fmt$static_label_header,
      label_item_p: ^fmt$static_label_item,
      name_p: ^ost$name_reference,
      path_p: ^amt$file_reference,
      present_label_atts_n: integer,
      reassign_file_contents: boolean,
      split_file_contents: amt$file_contents,
      split_file_structure: amt$file_structure,
      static_label_p: ^SEQ ( * );

?? NEWTITLE := 'GET_ENTRY_POINT_REFERENCE', EJECT ??

    PROCEDURE [INLINE] get_entry_point_reference
      (VAR name_p: ^ost$name_reference;
       VAR path_p: ^amt$file_reference);

      NEXT name_p: [label_item_p^.entry_point_name_length] IN static_label_p;
      IF (label_item_p <> NIL) AND (label_item_p^.entry_point_path_length > 0) THEN
        NEXT path_p: [label_item_p^.entry_point_path_length] IN static_label_p;
      IFEND;

    PROCEND get_entry_point_reference;
?? TITLE := 'GET_NAME', EJECT ??

    PROCEDURE [INLINE] get_name
      (VAR name_p: ^ost$name_reference);

      IF (label_item_p <> NIL) THEN
        NEXT name_p: [label_item_p^.name_length] IN static_label_p;
      IFEND;

    PROCEND get_name;
?? TITLE := 'SET_RETRIEVABLE_LABEL_ATTS', EJECT ??

    PROCEDURE [INLINE] set_retrievable_label_atts
      (    requested_label_atts: fmt#file_attribute_keys_set;
       VAR present_label_atts_n: integer);

{Return how many requested label attributes are in this file label.
{Ring attributes does not count, as returned outside of file label.

      present_label_atts_n := 0;
      FOR attribute_key := LOWERBOUND (header_p^.attribute_present) TO header_p^.
            highest_attribute_present DO
        IF (header_p^.attribute_present [attribute_key]) AND
              (attribute_key IN requested_label_atts) THEN
          present_label_atts_n := present_label_atts_n + 1;
        IFEND;
      FOREND;
      IF (fmc$ring_attributes IN requested_label_atts) THEN
        present_label_atts_n := present_label_atts_n - 1;
      IFEND;

    PROCEND set_retrievable_label_atts;
?? TITLE := 'SET_STATUS_DAMAGED_ATTRIBUTES', EJECT ??

    PROCEDURE set_status_damaged_attributes
      (    attribute_index: 1 .. fmc$highest_current_attribute + 5;
       VAR status: ost$status);

      VAR
        status_text: string (osc$max_string_size),
        text_length: integer;

      STRINGREP (status_text, text_length, 'Nexting of attribute # ', attribute_index,
            ' in LABEL resulted in a NIL pointer in P#EXPAND_FILE_LABEL');
      osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
            status_text (1, text_length), status);

    PROCEND set_status_damaged_attributes;
?? OLDTITLE ??
?? EJECT ?? {fsp#expand_file_label

    VAR {!?Kludge to get FMV$SYSTEM_FILE_ATTRIBUTES ?!
      var_addr: pmt$loaded_address,
      v#system_file_attributes: [STATIC] bat$static_label_attributes,
      first_time: [STATIC] boolean := TRUE;

    status.normal := TRUE;

    IF first_time THEN
      pmp$load ('FMV$SYSTEM_FILE_ATTRIBUTES     ', pmc$data_address, var_addr, status);
      fip#move (var_addr.pointer_to_data, ^v#system_file_attributes,
            #SIZE (v#system_file_attributes));
      first_time := FALSE;
    IFEND;
    label_atts := v#system_file_attributes;

    IF file_label_p = NIL THEN
      file_previously_opened := FALSE;
      RETURN; {----->
    IFEND;

    static_label_p := file_label_p;
    RESET static_label_p;
    NEXT header_p IN static_label_p;
    IF header_p = NIL THEN
      set_status_damaged_attributes (fmc$highest_current_attribute + 4, status);
      RETURN; {----->
    IFEND;
    IF header_p^.unique_character <> fmc$unique_label_id THEN
      set_status_damaged_attributes (fmc$highest_current_attribute + 5, status);
      RETURN; {----->
    IFEND;
    file_previously_opened := header_p^.file_previously_opened;
    IF header_p^.file_previously_opened THEN
      label_atts.ring_attributes_source := header_p^.ring_attributes_source;
      label_atts.ring_attributes := header_p^.ring_attributes;
    IFEND;

    IF header_p^.highest_attribute_present = 0 THEN
      RETURN; {----->
    IFEND;
    reassign_file_contents := FALSE;
    set_retrievable_label_atts (requested_label_atts, present_label_atts_n);
    IF present_label_atts_n = 0 THEN
      RETURN; {----->
    IFEND;
    name_p := ^null_string; {!?need better value?!
    path_p := ^null_string;

  /get_attributes/
    FOR attribute_key := LOWERBOUND (header_p^.attribute_present) TO header_p^.
          highest_attribute_present DO

      IF header_p^.attribute_present [attribute_key] THEN
        CASE attribute_key OF

        = fmc$average_record_length =
          NEXT label_item_p: [fmc$average_record_length] IN static_label_p;

        = fmc$block_type =
          NEXT label_item_p: [fmc$block_type] IN static_label_p;

        = fmc$character_conversion =
          NEXT label_item_p: [fmc$character_conversion] IN static_label_p;

        = fmc$clear_space =
          NEXT label_item_p: [fmc$clear_space] IN static_label_p;

        = fmc$collate_table =
          NEXT label_item_p: [fmc$collate_table] IN static_label_p;

        = fmc$collate_table_name =
          NEXT label_item_p: [fmc$collate_table_name] IN static_label_p;
          get_entry_point_reference (name_p, path_p);

        = fmc$compression_procedure_name =
          NEXT label_item_p: [fmc$compression_procedure_name] IN static_label_p;
          get_entry_point_reference (name_p, path_p);

        = fmc$data_padding =
          NEXT label_item_p: [fmc$data_padding] IN static_label_p;

        = fmc$dynamic_home_block_space =
          NEXT label_item_p: [fmc$dynamic_home_block_space] IN static_label_p;

        = fmc$embedded_key =
          NEXT label_item_p: [fmc$embedded_key] IN static_label_p;

        = fmc$estimated_record_count =
          NEXT label_item_p: [fmc$estimated_record_count] IN static_label_p;

        = fmc$file_access_procedure =
          NEXT label_item_p: [fmc$file_access_procedure] IN static_label_p;
          get_entry_point_reference (name_p, path_p);

        = fmc$file_contents =
          NEXT label_item_p: [fmc$file_contents] IN static_label_p;
          get_name (name_p);

        = fmc$file_limit =
          NEXT label_item_p: [fmc$file_limit] IN static_label_p;

        = fmc$file_organization =
          NEXT label_item_p: [fmc$file_organization] IN static_label_p;

        = fmc$file_processor =
          NEXT label_item_p: [fmc$file_processor] IN static_label_p;
          get_name (name_p);

        = fmc$file_structure =
          NEXT label_item_p: [fmc$file_structure] IN static_label_p;
          get_name (name_p);

        = fmc$forced_write =
          NEXT label_item_p: [fmc$forced_write] IN static_label_p;

        = fmc$hashing_procedure_name =
          NEXT label_item_p: [fmc$hashing_procedure_name] IN static_label_p;
          get_entry_point_reference (name_p, path_p);

        = fmc$index_levels =
          NEXT label_item_p: [fmc$index_levels] IN static_label_p;

        = fmc$index_padding =
          NEXT label_item_p: [fmc$index_padding] IN static_label_p;

        = fmc$initial_home_block_count =
          NEXT label_item_p: [fmc$initial_home_block_count] IN static_label_p;

        = fmc$internal_code =
          NEXT label_item_p: [fmc$internal_code] IN static_label_p;

        = fmc$key_length =
          NEXT label_item_p: [fmc$key_length] IN static_label_p;

        = fmc$key_position =
          NEXT label_item_p: [fmc$key_position] IN static_label_p;

        = fmc$key_type =
          NEXT label_item_p: [fmc$key_type] IN static_label_p;

        = fmc$label_type =
          NEXT label_item_p: [fmc$label_type] IN static_label_p;

        = fmc$line_number =
          NEXT label_item_p: [fmc$line_number] IN static_label_p;

        = fmc$loading_factor =
          NEXT label_item_p: [fmc$loading_factor] IN static_label_p;

        = fmc$lock_expiration_time =
          NEXT label_item_p: [fmc$lock_expiration_time] IN static_label_p;

        = fmc$log_residence =
          NEXT label_item_p: [fmc$log_residence] IN static_label_p;
          IF label_item_p <> NIL THEN
            NEXT path_p: [label_item_p^.path_length] IN static_label_p;
          IFEND;

        = fmc$logging_options =
          NEXT label_item_p: [fmc$logging_options] IN static_label_p;

        = fmc$max_block_length =
          NEXT label_item_p: [fmc$max_block_length] IN static_label_p;

        = fmc$max_record_length =
          NEXT label_item_p: [fmc$max_record_length] IN static_label_p;

        = fmc$min_block_length =
          NEXT label_item_p: [fmc$min_block_length] IN static_label_p;

        = fmc$min_record_length =
          NEXT label_item_p: [fmc$min_record_length] IN static_label_p;

        = fmc$padding_character =
          NEXT label_item_p: [fmc$padding_character] IN static_label_p;

        = fmc$page_format =
          NEXT label_item_p: [fmc$page_format] IN static_label_p;

        = fmc$page_length =
          NEXT label_item_p: [fmc$page_length] IN static_label_p;

        = fmc$page_width =
          NEXT label_item_p: [fmc$page_width] IN static_label_p;

        = fmc$preset_value =
          NEXT label_item_p: [fmc$preset_value] IN static_label_p;

        = fmc$record_delimiting_character =
          NEXT label_item_p: [fmc$record_delimiting_character] IN static_label_p;

        = fmc$record_limit =
          NEXT label_item_p: [fmc$record_limit] IN static_label_p;

        = fmc$record_type =
          NEXT label_item_p: [fmc$record_type] IN static_label_p;

        = fmc$records_per_block =
          NEXT label_item_p: [fmc$records_per_block] IN static_label_p;

        = fmc$ring_attributes = {processed above prior to FOR loop
          CYCLE /get_attributes/; {----->

        = fmc$statement_identifier =
          NEXT label_item_p: [fmc$statement_identifier] IN static_label_p;

        = fmc$user_info =
          NEXT label_item_p: [fmc$user_info] IN static_label_p;
          IF (label_item_p <> NIL) AND (label_item_p^.user_info_present) THEN
            NEXT path_p: [32] IN static_label_p;
          IFEND;

        = fmc$vertical_print_density =
          NEXT label_item_p: [fmc$vertical_print_density] IN static_label_p;

        CASEND;

        IF (label_item_p = NIL) OR (name_p = NIL) OR (path_p = NIL) THEN
          set_status_damaged_attributes (attribute_key, status);
          RETURN; {----->
        IFEND;

        IF attribute_key IN requested_label_atts THEN

          CASE attribute_key OF

          = fmc$average_record_length =
            label_atts.average_record_length_source := label_item_p^.source;
            label_atts.average_record_length := label_item_p^.integer_value;

          = fmc$block_type =
            label_atts.block_type_source := label_item_p^.source;
            label_atts.block_type := label_item_p^.block_type;

          = fmc$character_conversion =
            label_atts.character_conversion_source := label_item_p^.source;
            label_atts.character_conversion := label_item_p^.character_conversion;

          = fmc$clear_space =
            label_atts.clear_space_source := label_item_p^.source;
            label_atts.clear_space := label_item_p^.clear_space;

          = fmc$collate_table =
            label_atts.collate_table_source := label_item_p^.source;
            label_atts.collate_table := label_item_p^.collate_table;

          = fmc$collate_table_name =
            label_atts.collate_table_name_source := label_item_p^.source;
            label_atts.collate_table_name := name_p^;

          = fmc$compression_procedure_name =
            label_atts.compression_proc_name_source := label_item_p^.source;
            label_atts.compression_procedure_name.name := name_p^;
            label_atts.compression_procedure_name.object_library := path_p^;

          = fmc$data_padding =
            label_atts.data_padding_source := label_item_p^.source;
            label_atts.data_padding := label_item_p^.data_padding;

          = fmc$dynamic_home_block_space =
            label_atts.dynamic_home_block_space_source := label_item_p^.source;
            label_atts.dynamic_home_block_space := label_item_p^.dynamic_home_block_space;

          = fmc$embedded_key =
            label_atts.embedded_key_source := label_item_p^.source;
            label_atts.embedded_key := label_item_p^.embedded_key;

          = fmc$estimated_record_count =
            label_atts.estimated_record_count_source := label_item_p^.source;
            label_atts.estimated_record_count := label_item_p^.integer_value;

          = fmc$file_access_procedure =
            label_atts.file_access_procedure_source := label_item_p^.source;
            label_atts.file_access_procedure := name_p^;

          = fmc$file_contents =
            label_atts.file_contents_source := label_item_p^.source;
            label_atts.file_contents := name_p^;
            fsp$convert_to_old_contents (label_atts.file_contents, split_file_contents,
                  split_file_structure);
            reassign_file_contents := split_file_structure <> fsc$unknown_contents;

          = fmc$file_limit =
            label_atts.file_limit_source := label_item_p^.source;
            label_atts.file_limit := label_item_p^.integer_value;

          = fmc$file_organization =
            label_atts.file_organization_source := label_item_p^.source;
            label_atts.file_organization := label_item_p^.file_organization;

          = fmc$file_processor =
            label_atts.file_processor_source := label_item_p^.source;
            label_atts.file_processor := name_p^;

          = fmc$file_structure =
            label_atts.file_structure_source := label_item_p^.source;
            label_atts.file_structure := name_p^;

          = fmc$forced_write =
            label_atts.forced_write_source := label_item_p^.source;
            label_atts.forced_write := label_item_p^.forced_write;

          = fmc$hashing_procedure_name =
            label_atts.hashing_procedure_name_source := label_item_p^.source;
            label_atts.hashing_procedure_name.name := name_p^;
            label_atts.hashing_procedure_name.object_library := path_p^;

          = fmc$index_levels =
            label_atts.index_levels_source := label_item_p^.source;
            label_atts.index_levels := label_item_p^.integer_value;

          = fmc$index_padding =
            label_atts.index_padding_source := label_item_p^.source;
            label_atts.index_padding := label_item_p^.index_padding;

          = fmc$initial_home_block_count =
            label_atts.initial_home_block_count_source := label_item_p^.source;
            label_atts.initial_home_block_count := label_item_p^.integer_value;

          = fmc$internal_code =
            label_atts.internal_code_source := label_item_p^.source;
            label_atts.internal_code := label_item_p^.internal_code;

          = fmc$key_length =
            label_atts.key_length_source := label_item_p^.source;
            label_atts.key_length := label_item_p^.integer_value;

          = fmc$key_position =
            label_atts.key_position_source := label_item_p^.source;
            label_atts.key_position := label_item_p^.integer_value;

          = fmc$key_type =
            label_atts.key_type_source := label_item_p^.source;
            label_atts.key_type := label_item_p^.key_type;

          = fmc$label_type =
            label_atts.label_type_source := label_item_p^.source;
            label_atts.label_type := label_item_p^.label_type;

          = fmc$line_number =
            IF (label_item_p^.line_number.length >=
                  LOWERVALUE (amt$line_number_length)) AND
                  (label_item_p^.line_number.length <=
                  UPPERVALUE (amt$line_number_length)) AND
                  (label_item_p^.line_number.location >=
                  LOWERVALUE (amt$line_number_location)) AND
                  (label_item_p^.line_number.location <=
                  UPPERVALUE (amt$line_number_location)) THEN
              label_atts.line_number_source := label_item_p^.source;
              label_atts.line_number := label_item_p^.line_number;
            IFEND;

          = fmc$loading_factor =
            label_atts.loading_factor_source := label_item_p^.source;
            label_atts.loading_factor := label_item_p^.loading_factor;

          = fmc$lock_expiration_time =
            label_atts.lock_expiration_time_source := label_item_p^.source;
            label_atts.lock_expiration_time := label_item_p^.integer_value;

          = fmc$log_residence =
            label_atts.log_residence_source := label_item_p^.source;
            label_atts.log_residence := path_p^;

          = fmc$logging_options =
            label_atts.logging_options_source := label_item_p^.source;
            label_atts.logging_options := label_item_p^.logging_options;

          = fmc$max_block_length =
            label_atts.max_block_length_source := label_item_p^.source;
            label_atts.max_block_length := label_item_p^.integer_value;

          = fmc$max_record_length =
            label_atts.max_record_length_source := label_item_p^.source;
            label_atts.max_record_length := label_item_p^.integer_value;

          = fmc$min_block_length =
            label_atts.min_block_length_source := label_item_p^.source;
            label_atts.min_block_length := label_item_p^.integer_value;

          = fmc$min_record_length =
            label_atts.min_record_length_source := label_item_p^.source;
            label_atts.min_record_length := label_item_p^.integer_value;

          = fmc$padding_character =
            label_atts.padding_character_source := label_item_p^.source;
            label_atts.padding_character := label_item_p^.padding_character;

          = fmc$page_format =
            label_atts.page_format_source := label_item_p^.source;
            label_atts.page_format := label_item_p^.page_format;

          = fmc$page_length =
            label_atts.page_length_source := label_item_p^.source;
            label_atts.page_length := label_item_p^.integer_value;

          = fmc$page_width =
            label_atts.page_width_source := label_item_p^.source;
            label_atts.page_width := label_item_p^.integer_value;

          = fmc$preset_value =
            label_atts.preset_value_source := label_item_p^.source;
            label_atts.preset_value := label_item_p^.integer_value;

          = fmc$record_delimiting_character =
            label_atts.record_delimiting_char_source := label_item_p^.source;
            label_atts.record_delimiting_character :=
                  label_item_p^.record_delimiting_character;

          = fmc$record_limit =
            label_atts.record_limit_source := label_item_p^.source;
            label_atts.record_limit := label_item_p^.integer_value;

          = fmc$record_type =
            label_atts.record_type_source := label_item_p^.source;
            label_atts.record_type := label_item_p^.record_type;

          = fmc$records_per_block =
            label_atts.records_per_block_source := label_item_p^.source;
            label_atts.records_per_block := label_item_p^.integer_value;

          = fmc$ring_attributes = {processed above prior to this loop

          = fmc$statement_identifier =
            IF (label_item_p^.statement_identifier.length >=
                  LOWERVALUE (amt$statement_id_length)) AND
                  (label_item_p^.statement_identifier.length <=
                  UPPERVALUE (amt$statement_id_length)) AND
                  (label_item_p^.statement_identifier.location >=
                  LOWERVALUE (amt$statement_id_location)) AND
                  (label_item_p^.statement_identifier.location <=
                  UPPERVALUE (amt$statement_id_location)) THEN
              label_atts.statement_identifier_source := label_item_p^.source;
              label_atts.statement_identifier := label_item_p^.statement_identifier;
            IFEND;

          = fmc$user_info =
            label_atts.user_info_source := label_item_p^.source;
            IF label_item_p^.user_info_present THEN
              label_atts.user_info := path_p^;
            IFEND;

          = fmc$vertical_print_density =
            label_atts.vertical_print_density_source := label_item_p^.source;
            label_atts.vertical_print_density := label_item_p^.integer_value;

          CASEND;

          present_label_atts_n := present_label_atts_n - 1;
          IF present_label_atts_n = 0 THEN {Need anymore?
            EXIT /get_attributes/; {----->
          IFEND;

        IFEND; {attribute_key in requested_label_atts
      IFEND; {attribute_present in header
    FOREND /get_attributes/;

    IF reassign_file_contents AND NOT ((split_file_contents = fsc$list) AND
          (split_file_structure = fsc$data) AND (label_atts.file_structure =
          fsc$unknown_contents)) THEN
      label_atts.file_contents := split_file_contents;
      label_atts.file_structure := split_file_structure;
      label_atts.file_structure_source := label_atts.file_contents_source;
    IFEND;

  PROCEND fsp#expand_file_label;
?? OLDTITLE ??
MODEND fsm#expand_file_label;
*DECK DECK=FSM$CLOSE_FILE EXPAND=TRUE
?? RIGHT := 110 ??
MODULE fsm$close_file;
?? TITLE := 'NOS/VE :  Basic Access Method : Close File' ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc amk$access_method
*copyc amt$fap_declarations
?? POP ??
*copyc amp$set_file_instance_abnormal
*copyc amp$terminate_file
*copyc bap$close
*copyc bap$mark_fap_layer_closed
*copyc bap$validate_file_identifier
*copyc osp$copy_local_status_to_status
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$set_status_abnormal

*copyc osv$initial_exception_context

?? TITLE := 'PROCEDURE [XDCL, #GATE] amp$close', EJECT ??
*copyc amh$also
*copyc amh$close

  PROCEDURE [XDCL, #GATE] amp$close
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

    status.normal := TRUE;
    fsp$close_file (file_identifier, status);

  PROCEND amp$close;

?? TITLE := 'PROCEDURE [XDCL, #GATE, INLINE] fsp$close_file', EJECT ??
*copyc amh$also
*copyc fsh$close_file
?? EJECT ??

  PROCEDURE [XDCL, #GATE, INLINE] fsp$close_file
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

    CONST
      interface_name = 'FSP$CLOSE_FILE',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      context: ^ost$ecp_exception_context,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;

    status.normal := TRUE;
    bam_status.normal := TRUE;
    context := NIL;

    #KEYPOINT (osk$entry, 0, amk$close);
*copy bai$validate_file_identifier

    IF file_id_is_valid THEN
      IF file_instance^.fap_control_information.first_fap.layer_closed = FALSE THEN
        amp$terminate_file (file_identifier, file_instance^);
        bap$mark_fap_layer_closed (file_identifier, fap_layer_number, bam_status);
        IF bam_status.normal THEN
          call_block.operation := amc$close_req;
*copy bai$call_fap_control
          IF osp$file_access_condition (bam_status) THEN
            IF context = NIL THEN
              PUSH context;
              context^ := osv$initial_exception_context;
              context^.file.selector := osc$ecp_file_identifier;
              context^.file.file_identifier := file_identifier;
            IFEND;
            REPEAT
              context^.condition_status := bam_status;
              osp$enforce_exception_policies (context^);
              bam_status := context^.condition_status;
              IF context^.wait THEN
*copy bai$call_fap_control
              IFEND;
            UNTIL bam_status.normal OR (NOT context^.wait);
          IFEND;
        ELSE
          amp$set_file_instance_abnormal (file_identifier, bam_status.condition, amc$close_req,
                bam_status.text.value, status);
        IFEND;
      ELSE {fap layers never called during the open process}
        bap$close (file_identifier, bam_status);
        IF osp$file_access_condition (bam_status) THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_file_identifier;
            context^.file.file_identifier := file_identifier;
          IFEND;
          REPEAT
            context^.condition_status := bam_status;
            osp$enforce_exception_policies (context^);
            bam_status := context^.condition_status;
            IF context^.wait THEN
              bap$close (file_identifier, bam_status);
            IFEND;
          UNTIL bam_status.normal OR (NOT context^.wait);
        IFEND;
      IFEND;
      osp$copy_local_status_to_status (bam_status, status);
    ELSE
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id, interface_name, status);
    IFEND;

    #KEYPOINT (osk$exit, 0, amk$close);

  PROCEND fsp$close_file;
MODEND fsm$close_file;



*DECK DECK=FSM$CONVERT_FILE_CONTENTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File System : File Contents Conversion' ??
MODULE fsm$convert_file_contents;

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc amd$file_contents
*copyc amd$file_structure
*copyc fsc$file_contents
*copyc fse$get_info_validation_errors
*copyc ost$status

*copyc clp$trimmed_string_size
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
?? POP ??
?? OLDTITLE ??

?? NEWTITLE := 'PROCEDURE [XDCL, #GATE] fsp$convert_file_contents', EJECT ??
*copy fsh$convert_file_contents

  PROCEDURE [XDCL, #GATE] fsp$convert_file_contents
    (    file_contents: amt$file_contents;
         file_structure: amt$file_structure;
     VAR converted_file_contents: amt$file_contents;
     VAR status: ost$status);

    VAR
      file_contents_size: 1 .. osc$max_name_size + 1,
      file_structure_size: 1 .. osc$max_name_size + 1;

    status.normal := TRUE;

    IF (file_contents = 'UNKNOWN') AND (file_structure =
          'UNKNOWN') THEN
      converted_file_contents := fsc$unknown_contents;
    ELSEIF (file_contents = 'LIST') AND
          (file_structure = 'DATA') THEN
      converted_file_contents := fsc$list;
    ELSEIF (file_contents = 'LEGIBLE') AND ((file_structure =
          'DATA') OR (file_structure = 'UNKNOWN')) THEN
      converted_file_contents := fsc$legible_data;
    ELSEIF (file_contents = 'LEGIBLE') AND (file_structure =
          'LIBRARY') THEN
      converted_file_contents := fsc$legible_library;
    ELSEIF (file_contents = 'LEGIBLE') AND (file_structure =
          'SCL_PROCEDURE') THEN
      converted_file_contents := fsc$legible_scl_procedure;
    ELSEIF (file_contents = 'LEGIBLE') AND (file_structure =
          'SCL_INCLUDE') THEN
      converted_file_contents := fsc$legible_scl_include;
    ELSEIF (file_contents = 'LEGIBLE') AND (file_structure =
          'SCL_JOB') THEN
      converted_file_contents := fsc$legible_scl_job;
    ELSEIF (file_contents = 'OBJECT') AND (file_structure =
          'LIBRARY') THEN
      converted_file_contents := fsc$object_library;
    ELSEIF (file_contents = 'OBJECT') AND (file_structure =
          'DATA') THEN
      converted_file_contents := fsc$object_data;
    ELSEIF (file_contents = 'ASCII_LOG') AND (file_structure =
          'DATA') THEN
      converted_file_contents := fsc$ascii_log;
    ELSEIF (file_contents = 'BINARY_LOG') AND (file_structure =
          'DATA') THEN
      converted_file_contents := fsc$binary_log;
    ELSEIF (file_contents = 'FILE_BACKUP') AND (file_structure =
          'DATA') THEN
      converted_file_contents := fsc$file_backup;
    ELSEIF (file_contents = 'SCREEN') AND (file_structure =
          'FORM') THEN
      converted_file_contents := fsc$screen_form;
    ELSEIF (file_contents = 'UNKNOWN') AND (file_structure = 'DATA') THEN
      converted_file_contents := fsc$data;
    ELSEIF (file_contents <> 'UNKNOWN') AND (file_structure = 'UNKNOWN') THEN
      converted_file_contents := file_contents;
    ELSEIF (file_contents = fsc$list) OR (file_contents = fsc$legible_data) OR
          (file_contents = fsc$legible_library) OR (file_contents = fsc$legible_scl_procedure) OR
          (file_contents = fsc$legible_scl_include) OR (file_contents = fsc$legible_scl_job) OR
          (file_contents = fsc$object_library) OR (file_contents = fsc$object_data) OR
          (file_contents = fsc$ascii_log) OR (file_contents = fsc$binary_log) OR
          (file_contents = fsc$file_backup) OR (file_contents = fsc$screen_form) THEN
      converted_file_contents := file_contents;
      osp$set_status_abnormal (amc$access_method_id, fse$file_structure_ignored, '', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            file_structure (1, clp$trimmed_string_size (file_structure)), status);
    ELSE
      osp$set_status_abnormal (amc$access_method_id, fse$file_contents_not_converted,
            file_contents (1, clp$trimmed_string_size (file_contents)), status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            file_structure (1, clp$trimmed_string_size (file_structure)), status);
    IFEND;

  PROCEND fsp$convert_file_contents;
MODEND fsm$convert_file_contents;
*DECK DECK=FSM$COPY_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Basic Access Methods : Copy File' ??
MODULE fsm$copy_file;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$access_validation_errors
*copyc ame$lfn_program_actions
*copyc ame$put_validation_errors
*copyc ame$unimplemented_request
*copyc amk$access_method
*copyc amt$file_identifier
*copyc bat$d_record_rcw
*copyc cle$ecc_lexical
*copyc fse$copy_validation_errors
*copyc fsc$maximum_copy_file_push
*copyc fst$attachment_options
*copyc fst$file_cycle_attributes
*copyc fst$file_reference
*copyc fst$copy_control_information
*copyc fst$copy_types
*copyc osd$integer_limits
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc ost$status
?? POP ??

*copyc amp$fetch
*copyc amp$fetch_access_information
*copyc amp$get_next
*copyc amp$get_partial
*copyc amp$put_next
*copyc amp$put_partial
*copyc amp$write_end_partition
*copyc bap$byte_move
*copyc bap$delete_data
*copyc bap$get_default_attributes
*copyc bap$v_to_t_record_conversion
*copyc clp$check_name_for_path_handle
*copyc clp$include_line
*copyc clp$trimmed_string_size
*copyc clp$validate_name
*copyc fsc$copf_input_attachment_size
*copyc fsc$copf_output_attachment_size
*copyc fsp$close_file
*copyc fsp$contents_is_legible
*copyc fsp$get_open_information
*copyc fsp$open_file
*copyc fsp$set_file_reference_abnormal
*copyc i#move
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$establish_block_exit_hndlr
*copyc osp$file_access_condition
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pmp$log

*copyc amv$aam_file_organizations
*copyc amv$nil_file_identifier
*copyc amv$record_type_names
*copyc bav$last_tft_entry
*copyc bav$task_file_table
*copyc bav$tft_entry_assignment
*copyc osv$initial_exception_context

?? TITLE := 'Declarations Defined This Module', EJECT ??
  CONST
    input_access_mode_selection = 1;

  VAR
    fsv$copf_input_file_attachment: [XDCL, #GATE, READ, oss$job_paged_literal]
          array [1 .. fsc$copf_input_attachment_size] of fst$attachment_option := [
      {} [fsc$access_and_share_modes,
      {}       [fsc$specific_access_modes, $fst$file_access_options [fsc$read]],
      {}       [fsc$specific_share_modes, $fst$file_access_options [fsc$read, fsc$execute]]],
      {} [fsc$create_file, FALSE],
      {} [fsc$private_read, TRUE],
      {} [fsc$sequential_access, TRUE]],

    fsv$copf_output_file_attachment: [XDCL, #GATE, READ, oss$job_paged_literal]
          array [1 .. fsc$copf_output_attachment_size] of fst$attachment_option := [
      {} [fsc$access_and_share_modes,
      {}       [fsc$specific_access_modes, $fst$file_access_options [fsc$append, fsc$shorten]],
      {}       [fsc$specific_share_modes, $fst$file_access_options []]],
      {} [fsc$access_and_share_modes,
      {}       [fsc$specific_access_modes, $fst$file_access_options [fsc$append]],
      {}       [fsc$specific_share_modes, $fst$file_access_options []]],
      {} [fsc$open_share_modes, $fst$file_access_options []],
      {} [fsc$open_share_modes, -$fst$file_access_options []],
      {} [fsc$sequential_access, TRUE],
      {} [fsc$delete_data, TRUE]];

?? TITLE := 'PROCEDURE [XDCL, #GATE] amp$copy_file', EJECT ??
*copyc amh$copy_file
?? EJECT ??

  PROCEDURE [XDCL, #GATE] amp$copy_file
    (    input_file: amt$local_file_name;
         output_file: amt$local_file_name;
     VAR status: ost$status);

    CONST
      local_reference = ':$LOCAL.',
      local_reference_size = 8;

    VAR
      cl_path_handle: clt$path_handle,
      input_file_reference: string (local_reference_size + osc$max_name_size),
      lfn: amt$local_file_name,
      output_file_reference: string (local_reference_size + osc$max_name_size),
      valid_name: boolean;

    status.normal := TRUE;

{ Prefix local_file_name with ':$LOCAL.' to prevent the local_file_name from being treated as a
{ file variable.
    clp$validate_name (input_file, lfn, valid_name);
    IF NOT valid_name THEN
      osp$set_status_abnormal (amc$access_method_id, cle$improper_name, input_file, status);
      RETURN;
    IFEND;
    clp$check_name_for_path_handle (lfn, cl_path_handle);
    IF cl_path_handle.kind = clc$not_a_path_handle THEN
      input_file_reference := local_reference;
      input_file_reference (local_reference_size + 1, osc$max_name_size) := lfn;
    ELSE
      input_file_reference := lfn;
    IFEND;

{ Prefix local_file_name with ':$LOCAL.' to prevent the local_file_name from being treated as a
{ file variable.
    clp$validate_name (output_file, lfn, valid_name);
    IF NOT valid_name THEN
      osp$set_status_abnormal (amc$access_method_id, cle$improper_name, output_file, status);
      RETURN;
    IFEND;
    clp$check_name_for_path_handle (lfn, cl_path_handle);
    IF cl_path_handle.kind = clc$not_a_path_handle THEN
      output_file_reference := local_reference;
      output_file_reference (local_reference_size + 1, osc$max_name_size) := lfn;
    ELSE
      output_file_reference := lfn;
    IFEND;

    fsp$copy_file (input_file_reference, output_file_reference, NIL, NIL, NIL, status);

  PROCEND amp$copy_file;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fsp$copy_file', EJECT ??
*copyc fsh$copy_file
?? EJECT ??

  PROCEDURE [XDCL, #GATE] fsp$copy_file
    (    input: fst$file_reference;
         output: fst$file_reference;
         input_attribute_validation: ^fst$file_cycle_attributes;
         output_attribute_validation: ^fst$file_cycle_attributes;
         output_creation_attributes: ^fst$file_cycle_attributes;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      input_file_attachment: ^fst$attachment_options;

    #KEYPOINT (osk$entry, 0, amk$copy_file);

    #CALLER_ID (caller_id);

    IF caller_id.ring > osc$tsrv_ring THEN
      input_file_attachment := ^fsv$copf_input_file_attachment;
    ELSE
{
{ The following is necessary to submit an executable file - SUBMIT_JOB runs in ring 3}
{
      PUSH input_file_attachment: [1 .. fsc$copf_input_attachment_size + 1];
      i#move (^fsv$copf_input_file_attachment, input_file_attachment,
            #SIZE (fsv$copf_input_file_attachment));
      input_file_attachment^ [fsc$copf_input_attachment_size + 1] :=
            fsv$copf_input_file_attachment [input_access_mode_selection];
      input_file_attachment^ [fsc$copf_input_attachment_size + 1].access_modes.value :=
            $fst$file_access_options [fsc$execute];
    IFEND;
    fsp$subsystem_copy_file (input, output, input_file_attachment, ^fsv$copf_output_file_attachment,
          input_attribute_validation, output_attribute_validation, output_creation_attributes, status);

    #KEYPOINT (osk$exit, 0, amk$copy_file);

  PROCEND fsp$copy_file;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fsp$subsystem_copy_file', EJECT ??
*copyc fsh$subsystem_copy_file
?? EJECT ??

  PROCEDURE [XDCL, #GATE] fsp$subsystem_copy_file
    (    input: fst$file_reference;
         output: fst$file_reference;
         input_file_attachment: ^fst$attachment_options;
         output_file_attachment: ^fst$attachment_options;
         input_attribute_validation: ^fst$file_cycle_attributes;
         output_attribute_validation: ^fst$file_cycle_attributes;
         output_creation_attributes: ^fst$file_cycle_attributes;
     VAR status: ost$status);

    VAR
      input_fid: amt$file_identifier,
      output_fid: amt$file_identifier,
      control_information: fst$copy_control_information,
      job_log: pmt$ascii_logset,
      ignore_status: ost$status,
      local_status: ost$status;

?? NEWTITLE := '  PROCEDURE abort_handler ' ??
?? EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      clean_up;

    PROCEND abort_handler;


?? TITLE := '  PROCEDURE cleanup ' ??
?? EJECT ??

    PROCEDURE [INLINE] clean_up;

      VAR
        clean_up_status: ost$status;

      IF input_fid <> amv$nil_file_identifier THEN
        fsp$close_file (input_fid, clean_up_status);
        input_fid := amv$nil_file_identifier;
        #SPOIL (input_fid);
      IFEND;
      IF output_fid <> amv$nil_file_identifier THEN
        fsp$close_file (output_fid, clean_up_status);
        output_fid := amv$nil_file_identifier;
        #SPOIL (output_fid);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    local_status.normal := TRUE;
    input_fid := amv$nil_file_identifier;
    #SPOIL (input_fid);
    output_fid := amv$nil_file_identifier;
    #SPOIL (output_fid);
    osp$establish_block_exit_hndlr (^abort_handler);
    fsp$open_and_get_type_of_copy (input, output, input_file_attachment, output_file_attachment,
          input_attribute_validation, output_attribute_validation, output_creation_attributes, input_fid,
          output_fid, control_information, status);
    IF (NOT status.normal) AND (status.condition <> fse$output_structure_truncated) THEN
      clean_up;
    ELSE
      fsp$copy_data_and_close_files (input_fid, output_fid, control_information, local_status);
      input_fid := amv$nil_file_identifier;
      #SPOIL (input_fid);
      output_fid := amv$nil_file_identifier;
      #SPOIL (output_fid);
      IF NOT local_status.normal THEN
        IF NOT status.normal THEN
          job_log := $pmt$ascii_logset [pmc$job_log];
          osp$generate_log_message (job_log, status, ignore_status);
        IFEND;
        status := local_status;
      IFEND;
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND fsp$subsystem_copy_file;

?? TITLE := 'PROCEDURE change_to_public_lock_file', EJECT??
  PROCEDURE change_to_public_lock_file
    (    file_identifier: amt$file_identifier);

    CONST
      maintain_lock_file_table = 11; { This is AAM's value.

    VAR
      call_block: amt$call_block,
      fap_layer_number: amt$fap_layer_number,
      local_status: ost$status,
      lock_file_path: fst$path,
      lock_file_path_p: ^fst$path,
      lock_file_private_p: ^boolean,
      lock_file_residence: array [1 .. 1] of amt$access_info;

    lock_file_residence [1].key := amc$lock_file_residence;
    lock_file_residence [1].lock_file_path := ^lock_file_path;
    amp$fetch_access_information (file_identifier, lock_file_residence, local_status);
    IF (NOT local_status.normal) OR (NOT lock_file_residence [1].item_returned) OR
          (lock_file_residence [1].lock_file_scope <> amc$private_lock_file) THEN
      RETURN;
    IFEND;

    call_block.operation := amc$user_defined_access_request;
    call_block.user_defined_access_request.request_identifier := maintain_lock_file_table;
    PUSH call_block.user_defined_access_request.request_parameters:
          [[REP (#SIZE(fst$path) + #SIZE(boolean)) OF cell]];
    RESET call_block.user_defined_access_request.request_parameters;
    NEXT lock_file_path_p IN call_block.user_defined_access_request.request_parameters;
    lock_file_path_p^ := '$SYSTEM.AAM.AAF$LOCK_FILE';
    NEXT lock_file_private_p IN call_block.user_defined_access_request.request_parameters;
    lock_file_private_p^ := FALSE;
    IF bav$task_file_table^ [file_identifier.ordinal].fap_control_information.fap_array = NIL THEN
      bav$task_file_table^ [file_identifier.ordinal].fap_control_information.first_fap.
            access_method^ (file_identifier, call_block, fap_layer_number, local_status);
    ELSE
      fap_layer_number := UPPERBOUND (bav$task_file_table^ [file_identifier.ordinal].fap_control_information.
            fap_array^);
      bav$task_file_table^ [file_identifier.ordinal].fap_control_information.fap_array^ [fap_layer_number].
            access_method^ (file_identifier, call_block, fap_layer_number, local_status);
    IFEND;

  PROCEND change_to_public_lock_file;

?? TITLE := 'PROCEDURE fsp$open_and_get_type_of_copy' ??
?? EJECT ??
*copyc fsh$open_and_get_type_of_copy
?? EJECT ??

  PROCEDURE [XDCL, #GATE] fsp$open_and_get_type_of_copy
    (    input: fst$file_reference;
         output: fst$file_reference;
         input_file_attachment: ^fst$attachment_options;
         output_file_attachment: ^fst$attachment_options;
         input_attribute_validation: ^fst$file_cycle_attributes;
         output_attribute_validation: ^fst$file_cycle_attributes;
         output_creation_attributes: ^fst$file_cycle_attributes;
     VAR input_fid: amt$file_identifier;
     VAR output_fid: amt$file_identifier;
     VAR control_information: fst$copy_control_information;
     VAR status: ost$status);

    CONST
      number_of_open_attributes = fsc$highest_current_attribute - 2;

    {total number of cycle attributes on fsp$open_file (47) minus
    {fsc$ring_attributes - this is not inherited from the input file by design.
    {fsc$null_attribute - this is only a specification attribute on fsp$open_file.

    TYPE
   {  record_type_set = set of amt$record_type,  **delete if not referenced**
      attribute_information = record
        force_input_defaults: boolean,
        case adjust_default: boolean of
          =TRUE=
           block_type: amt$block_type,
           record_type: amt$record_type,
          =FALSE=,
        casend,
      recend;

    VAR
      input_cycle_attribute_sources: fst$cycle_attribute_sources,
      input_cycle_attribute_values: fst$cycle_attribute_values,
      input_file_access_info: array [1 .. 1] of amt$access_info,
      input_file_attachment_options: ^fst$attachment_options,
      input_file_catalog_info: fst$catalog_information,
      input_file_cpn: amt$compression_procedure_name,
      input_file_hpn: amt$hashing_procedure_name,
      input_file_instance_info: fst$open_instance_information,
      input_file_user_def_attr_size: fst$user_defined_attribute_size,
      input_initial_byte_address: amt$file_byte_address,
      output_cycle_attribute_values: fst$cycle_attribute_values,
      output_default_creation_attr: array [1 .. number_of_open_attributes] of fst$file_cycle_attribute,
      output_default_creation_ptr: ^fst$file_cycle_attributes,
      output_file_access_info: array [1 .. 1] of amt$access_info,
      output_file_attachment_info: fst$attachment_information,
      output_file_attachment_options: ^fst$attachment_options,
      output_file_catalog_info: fst$catalog_information,
      output_file_instance_info: fst$open_instance_information,
      output_file_user_def_attr_size: fst$user_defined_attribute_size,
      output_initial_byte_address: amt$file_byte_address;


?? NEWTITLE := '  PROCEDURE set_status_internal_error' ??
?? EJECT ??

    PROCEDURE set_status_internal_error
      (    error_number: ost$non_negative_integers;
       VAR status: ost$status);

      VAR
        status_text: string (osc$max_string_size),
        text_length: integer;

      STRINGREP (status_text, text_length, 'detected error #', error_number,
            ' in fsp$open_and_get_type_of_copy');
      fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
            path (1, control_information.input_resolved_file_reference.cycle_path_size),
            fse$copy_internal_error, fsc$copy_file_req, status_text (1, text_length), status);

    PROCEND set_status_internal_error;

?? TITLE := '  FUNCTION task_has_exclusive_write_access', EJECT ??
    FUNCTION task_has_exclusive_write_access
      (    file_identifier: amt$file_identifier): boolean;

      VAR
        fid_ordinal: amt$file_id_ordinal;

      task_has_exclusive_write_access := FALSE;
      FOR fid_ordinal := bav$last_tft_entry DOWNTO 1 DO
        IF (bav$tft_entry_assignment^ (fid_ordinal, 1) = fmc$entry_assigned) AND
              (bav$task_file_table^ [fid_ordinal].local_file_name =
              bav$task_file_table^ [file_identifier.ordinal].local_file_name) AND
              (bav$task_file_table^ [fid_ordinal].instance_attributes.dynamic_label.
              open_share_modes <= $fst$file_access_options [fsc$read, fsc$execute]) THEN
          task_has_exclusive_write_access := TRUE;
          RETURN;
        IFEND;
      FOREND;

    FUNCEND task_has_exclusive_write_access;

?? TITLE := '  PROCEDURE set_output_default_creation_att' ??
?? EJECT ??

    PROCEDURE set_output_default_creation_att
      (    device_dependent_info: attribute_information;
       VAR output_default_creation_ptr: ^fst$file_cycle_attributes;
       VAR status: ost$status);

      VAR
        attribute_count: ost$non_negative_integers,
        default_catalog_info: fst$catalog_information,
        default_cycle_attribute_values: fst$cycle_attribute_values,
        i: ost$non_negative_integers,
        temporary_sequence_pointer: ^SEQ ( * );

      { PURPOSE:  This procedure carries the input file's attributes over to the output file's
      {default creation attributes and saves label space by only specifying those
      {attributes which are different from the systems default attributes or those
      {attributes which are by default undefined but have a source value other than default.
      {The exceptions to this policy are the 7 attributes that may vary from one file to the
      {next on a multi-file tape.  These must be explicitly specified so that the attributes
      {of the mass-storage input file may influence the default attributes used for a tape file.
      {When put_label is modified to save label space this routine can be deleted
      {and the fsp$get_open_attributes can be called and the parameter directly passed
      {to fsp$open_file as the default creation attributes.  But undefined attributes
      {will still have to be treated as a special case.

      bap$get_default_attributes (^default_catalog_info, NIL, ^default_cycle_attribute_values, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      attribute_count := 0;
      IF input_cycle_attribute_sources.average_record_length <> amc$undefined_attribute THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$average_record_length;
        output_default_creation_attr [attribute_count].average_record_length :=
              input_cycle_attribute_values.average_record_length;
      IFEND;
      IF device_dependent_info.force_input_defaults AND device_dependent_info.adjust_default THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$block_type;
        output_default_creation_attr [attribute_count].block_type := device_dependent_info.block_type;
      ELSEIF (default_cycle_attribute_values.block_type <> input_cycle_attribute_values.block_type) OR
            device_dependent_info.force_input_defaults THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$block_type;
        output_default_creation_attr [attribute_count].block_type := input_cycle_attribute_values.block_type;
      IFEND;
      IF (default_cycle_attribute_values.character_conversion <>
            input_cycle_attribute_values.character_conversion) OR
            device_dependent_info.force_input_defaults THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$character_conversion;
        output_default_creation_attr [attribute_count].character_conversion :=
              input_cycle_attribute_values.character_conversion;
      IFEND;
      IF input_cycle_attribute_sources.collate_table_name <> amc$undefined_attribute THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$collate_table_name;
        output_default_creation_attr [attribute_count].collate_table_name :=
              ^input_cycle_attribute_values.collate_table_name;
      IFEND;
      IF input_cycle_attribute_sources.compression_procedure_name <> amc$undefined_attribute THEN
        input_file_cpn.name := input_cycle_attribute_values.compression_procedure_name.entry_point;
        input_file_cpn.object_library := input_cycle_attribute_values.compression_procedure_name.
              object_library;
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$compression_procedure_name;
        output_default_creation_attr [attribute_count].compression_procedure_name := ^input_file_cpn;
      IFEND;
      IF default_cycle_attribute_values.data_padding <> input_cycle_attribute_values.data_padding THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$data_padding;
        output_default_creation_attr [attribute_count].data_padding :=
              input_cycle_attribute_values.data_padding;
      IFEND;
      IF default_cycle_attribute_values.dynamic_home_block_space <>
            input_cycle_attribute_values.dynamic_home_block_space THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$dynamic_home_block_space;
        output_default_creation_attr [attribute_count].dynamic_home_block_space :=
              input_cycle_attribute_values.dynamic_home_block_space;
      IFEND;
      IF default_cycle_attribute_values.embedded_key <> input_cycle_attribute_values.embedded_key THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$embedded_key;
        output_default_creation_attr [attribute_count].embedded_key :=
              input_cycle_attribute_values.embedded_key;
      IFEND;
      IF default_catalog_info.cycle_registration.erase_at_deletion <>
            input_file_catalog_info.cycle_registration.erase_at_deletion THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$erase_at_deletion;
        output_default_creation_attr [attribute_count].erase_at_deletion :=
              input_file_catalog_info.cycle_registration.erase_at_deletion;
      IFEND;
      IF input_cycle_attribute_sources.estimated_record_count <> amc$undefined_attribute THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$estimated_record_count;
        output_default_creation_attr [attribute_count].estimated_record_count :=
              input_cycle_attribute_values.estimated_record_count;
      IFEND;
      IF input_cycle_attribute_sources.file_access_procedure_name <> amc$undefined_attribute THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$file_access_procedure_name;
        output_default_creation_attr [attribute_count].file_access_procedure_name :=
              ^input_cycle_attribute_values.file_access_procedure_name;
      IFEND;
      IF (default_cycle_attribute_values.file_contents <> input_cycle_attribute_values.file_contents) OR
            (default_cycle_attribute_values.file_processor <> input_cycle_attribute_values.file_processor)
            THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$file_contents_and_processor;
        output_default_creation_attr [attribute_count].file_contents :=
              input_cycle_attribute_values.file_contents;
        output_default_creation_attr [attribute_count].file_processor :=
              input_cycle_attribute_values.file_processor;
      IFEND;
      IF default_cycle_attribute_values.file_label_type <> input_cycle_attribute_values.file_label_type THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$file_label_type;
        output_default_creation_attr [attribute_count].file_label_type :=
              input_cycle_attribute_values.file_label_type;
      IFEND;
      IF default_catalog_info.cycle_registration.size_limit <>
            input_file_catalog_info.cycle_registration.size_limit THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$file_limit;
        output_default_creation_attr [attribute_count].file_limit :=
              input_file_catalog_info.cycle_registration.size_limit;
      IFEND;
      IF default_cycle_attribute_values.file_organization <>
            input_cycle_attribute_values.file_organization THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$file_organization;
        output_default_creation_attr [attribute_count].file_organization :=
              input_cycle_attribute_values.file_organization;
      IFEND;
      IF default_cycle_attribute_values.forced_write <> input_cycle_attribute_values.forced_write THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$forced_write;
        output_default_creation_attr [attribute_count].forced_write :=
              input_cycle_attribute_values.forced_write;
      IFEND;
      IF input_cycle_attribute_sources.hashing_procedure_name <> amc$undefined_attribute THEN
        input_file_hpn.name := input_cycle_attribute_values.hashing_procedure_name.entry_point;
        input_file_hpn.object_library := input_cycle_attribute_values.hashing_procedure_name.object_library;
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$hashing_procedure_name;
        output_default_creation_attr [attribute_count].hashing_procedure_name := ^input_file_hpn;
      IFEND;
      IF default_cycle_attribute_values.index_levels <> input_cycle_attribute_values.index_levels THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$index_levels;
        output_default_creation_attr [attribute_count].index_levels :=
              input_cycle_attribute_values.index_levels;
      IFEND;
      IF default_cycle_attribute_values.index_padding <> input_cycle_attribute_values.index_padding THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$index_padding;
        output_default_creation_attr [attribute_count].index_padding :=
              input_cycle_attribute_values.index_padding;
      IFEND;
{ Treat initial_home_block_count as undefined because that is how AAM treats it.
      IF (input_cycle_attribute_sources.initial_home_block_count <> amc$access_method_default) THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$initial_home_block_count;
        output_default_creation_attr [attribute_count].initial_home_block_count :=
              input_cycle_attribute_values.initial_home_block_count;
      IFEND;
      IF (default_cycle_attribute_values.internal_code <> input_cycle_attribute_values.internal_code) OR
            device_dependent_info.force_input_defaults THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$internal_code;
        output_default_creation_attr [attribute_count].internal_code :=
              input_cycle_attribute_values.internal_code;
      IFEND;
      IF input_cycle_attribute_sources.key_length <> amc$undefined_attribute THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$key_length;
        output_default_creation_attr [attribute_count].key_length := input_cycle_attribute_values.key_length;
      IFEND;
      IF default_cycle_attribute_values.key_position <> input_cycle_attribute_values.key_position THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$key_position;
        output_default_creation_attr [attribute_count].key_position :=
              input_cycle_attribute_values.key_position;
      IFEND;
      IF default_cycle_attribute_values.key_type <> input_cycle_attribute_values.key_type THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$key_type;
        output_default_creation_attr [attribute_count].key_type := input_cycle_attribute_values.key_type;
      IFEND;
      IF input_cycle_attribute_sources.line_number <> amc$undefined_attribute THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$line_number;
        output_default_creation_attr [attribute_count].line_number :=
              input_cycle_attribute_values.line_number;
      IFEND;
      IF default_cycle_attribute_values.loading_factor <> input_cycle_attribute_values.loading_factor THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$loading_factor;
        output_default_creation_attr [attribute_count].loading_factor :=
              input_cycle_attribute_values.loading_factor;
      IFEND;
      IF default_cycle_attribute_values.lock_expiration_time <>
            input_cycle_attribute_values.lock_expiration_time THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$lock_expiration_time;
        output_default_creation_attr [attribute_count].lock_expiration_time :=
              input_cycle_attribute_values.lock_expiration_time;
      IFEND;
      IF input_cycle_attribute_sources.log_residence <> amc$undefined_attribute THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$log_residence;
        output_default_creation_attr [attribute_count].log_residence :=
              ^input_cycle_attribute_values.log_residence;
      IFEND;
      IF input_cycle_attribute_sources.logging_options <> amc$undefined_attribute THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$logging_options;
        output_default_creation_attr [attribute_count].logging_options :=
              input_cycle_attribute_values.logging_options;
      IFEND;
{ The following check for amc$access_method_default is because AAM and BAM have different default values.
      IF (default_cycle_attribute_values.max_block_length <> input_cycle_attribute_values.max_block_length) OR
            (input_cycle_attribute_sources.max_block_length <> amc$access_method_default) OR
            device_dependent_info.force_input_defaults THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$max_block_length;
        output_default_creation_attr [attribute_count].max_block_length :=
              input_cycle_attribute_values.max_block_length;
      IFEND;
{ The following check for amc$access_method_default is because AAM requires a max_record_length be specified.
      IF (default_cycle_attribute_values.max_record_length <>
            input_cycle_attribute_values.max_record_length) OR
            (input_cycle_attribute_sources.max_record_length <> amc$access_method_default) OR
            device_dependent_info.force_input_defaults THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$max_record_length;
        output_default_creation_attr [attribute_count].max_record_length :=
              input_cycle_attribute_values.max_record_length;
      IFEND;
      IF default_cycle_attribute_values.min_block_length <> input_cycle_attribute_values.min_block_length THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$min_block_length;
        output_default_creation_attr [attribute_count].min_block_length :=
              input_cycle_attribute_values.min_block_length;
      IFEND;
      IF default_cycle_attribute_values.min_record_length <>
            input_cycle_attribute_values.min_record_length THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$min_record_length;
        output_default_creation_attr [attribute_count].min_record_length :=
              input_cycle_attribute_values.min_record_length;
      IFEND;
      IF (default_cycle_attribute_values.padding_character <>
            input_cycle_attribute_values.padding_character) OR
            device_dependent_info.force_input_defaults THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$padding_character;
        output_default_creation_attr [attribute_count].padding_character :=
              input_cycle_attribute_values.padding_character;
      IFEND;
      IF default_cycle_attribute_values.page_format <> input_cycle_attribute_values.page_format THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$page_format;
        output_default_creation_attr [attribute_count].page_format :=
              input_cycle_attribute_values.page_format;
      IFEND;
      IF default_cycle_attribute_values.page_length <> input_cycle_attribute_values.page_length THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$page_length;
        output_default_creation_attr [attribute_count].page_length :=
              input_cycle_attribute_values.page_length;
      IFEND;
      IF default_cycle_attribute_values.page_width <> input_cycle_attribute_values.page_width THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$page_width;
        output_default_creation_attr [attribute_count].page_width := input_cycle_attribute_values.page_width;
      IFEND;
      IF default_catalog_info.cycle_registration.preset_value <>
            input_file_catalog_info.cycle_registration.preset_value THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$preset_value;
        output_default_creation_attr [attribute_count].preset_value :=
              input_file_catalog_info.cycle_registration.preset_value;
      IFEND;
      IF default_cycle_attribute_values.record_delimiting_character <>
            input_cycle_attribute_values.record_delimiting_character THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$record_delimiting_character;
        output_default_creation_attr [attribute_count].record_delimiting_character :=
              input_cycle_attribute_values.record_delimiting_character;
      IFEND;
      IF input_cycle_attribute_sources.record_limit <> amc$undefined_attribute THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$record_limit;
        output_default_creation_attr [attribute_count].record_limit :=
              input_cycle_attribute_values.record_limit;
      IFEND;
{ The following is because AAM and BAM have different default values.
      IF device_dependent_info.force_input_defaults AND device_dependent_info.adjust_default THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$record_type;
        output_default_creation_attr [attribute_count].record_type :=
              device_dependent_info.record_type;
      ELSEIF ((NOT (input_cycle_attribute_values.file_organization IN amv$aam_file_organizations)) AND
            (input_cycle_attribute_values.record_type <> default_cycle_attribute_values.record_type)) OR
            ((input_cycle_attribute_values.file_organization IN amv$aam_file_organizations) AND
            (input_cycle_attribute_values.record_type <> amc$undefined)) OR
            device_dependent_info.force_input_defaults THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$record_type;
        output_default_creation_attr [attribute_count].record_type :=
              input_cycle_attribute_values.record_type;
      IFEND;
      IF input_cycle_attribute_sources.records_per_block <> amc$undefined_attribute THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$records_per_block;
        output_default_creation_attr [attribute_count].records_per_block :=
              input_cycle_attribute_values.records_per_block;
      IFEND;
      IF input_cycle_attribute_sources.statement_identifier <> amc$undefined_attribute THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$statement_identifier;
        output_default_creation_attr [attribute_count].statement_identifier :=
              input_cycle_attribute_values.statement_identifier;
      IFEND;
      IF default_cycle_attribute_values.user_information <>
            input_cycle_attribute_values.user_information THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$user_information;
        output_default_creation_attr [attribute_count].user_information :=
              input_cycle_attribute_values.user_information;
      IFEND;
      IF default_cycle_attribute_values.vertical_print_density <>
            input_cycle_attribute_values.vertical_print_density THEN
        attribute_count := attribute_count + 1;
        output_default_creation_attr [attribute_count].selector := fsc$vertical_print_density;
        output_default_creation_attr [attribute_count].vertical_print_density :=
              input_cycle_attribute_values.vertical_print_density;
      IFEND;

      IF attribute_count = 0 THEN
        output_default_creation_ptr := NIL;
      ELSE
        temporary_sequence_pointer := #SEQ (output_default_creation_attr);
        RESET temporary_sequence_pointer;
        NEXT output_default_creation_ptr: [1 .. attribute_count] IN temporary_sequence_pointer;
      IFEND;

    PROCEND set_output_default_creation_att;

?? TITLE := '  PROCEDURE validate_line_identifiers' ??
?? EJECT ??

    PROCEDURE validate_line_identifiers
      (VAR status: ost$status);

{ PURPOSE:
{   This procedure validates line number and statement identifier lengths and
{   and locations.  It is called when both the input and output file have
{   file_contents that are considered "LEGIBLE".

      IF input_cycle_attribute_values.line_number <> output_cycle_attribute_values.line_number THEN
        IF (input_cycle_attribute_values.line_number.length <>
              output_cycle_attribute_values.line_number.length) AND
              (input_cycle_attribute_values.line_number.location <>
              output_cycle_attribute_values.line_number.location) THEN
          fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                path (1, control_information.input_resolved_file_reference.cycle_path_size),
                fse$line_numbers_unequal, fsc$copy_file_req, 'length and location', status);
          osp$append_status_file (osc$status_parameter_delimiter,
                control_information.output_resolved_file_reference.
                path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
        ELSEIF input_cycle_attribute_values.line_number.length <>
              output_cycle_attribute_values.line_number.length THEN
          fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                path (1, control_information.input_resolved_file_reference.cycle_path_size),
                fse$line_numbers_unequal, fsc$copy_file_req, 'length', status);
          osp$append_status_file (osc$status_parameter_delimiter,
                control_information.output_resolved_file_reference.
                path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
        ELSE
          fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                path (1, control_information.input_resolved_file_reference.cycle_path_size),
                fse$line_numbers_unequal, fsc$copy_file_req, 'location', status);
          osp$append_status_file (osc$status_parameter_delimiter,
                control_information.output_resolved_file_reference.
                path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
        IFEND;
      ELSEIF input_cycle_attribute_values.statement_identifier <>
            output_cycle_attribute_values.statement_identifier THEN
        IF (input_cycle_attribute_values.statement_identifier.length <>
              output_cycle_attribute_values.statement_identifier.length) AND
              (input_cycle_attribute_values.statement_identifier.location <>
              output_cycle_attribute_values.statement_identifier.location) THEN
          fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                path (1, control_information.input_resolved_file_reference.cycle_path_size),
                fse$statement_idents_unequal, fsc$copy_file_req, 'length and location', status);
          osp$append_status_file (osc$status_parameter_delimiter,
                control_information.output_resolved_file_reference.
                path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
        ELSEIF input_cycle_attribute_values.statement_identifier.length <>
              output_cycle_attribute_values.statement_identifier.length THEN
          fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                path (1, control_information.input_resolved_file_reference.cycle_path_size),
                fse$statement_idents_unequal, fsc$copy_file_req, 'length', status);
          osp$append_status_file (osc$status_parameter_delimiter,
                control_information.output_resolved_file_reference.
                path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
        ELSE
          fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                path (1, control_information.input_resolved_file_reference.cycle_path_size),
                fse$statement_idents_unequal, fsc$copy_file_req, 'location', status);
          osp$append_status_file (osc$status_parameter_delimiter,
                control_information.output_resolved_file_reference.
                path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
        IFEND;
      IFEND;

    PROCEND validate_line_identifiers;

?? TITLE := '  PROCEDURE get_type_of_copy' ??
?? EJECT ??

    PROCEDURE get_type_of_copy
      (VAR type_of_copy: fst$copy_types;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status,
        input_is_legible: boolean,
        output_is_legible: boolean;


      { PURPOSE:  This procedure determines the type of copy that will be performed
      {by fsp$copy_data_and_close_files


      type_of_copy := fsc$error_move;
      input_is_legible := fsp$contents_is_legible (input_cycle_attribute_values.file_contents);
      output_is_legible := fsp$contents_is_legible (output_cycle_attribute_values.file_contents);


      CASE input_cycle_attribute_values.file_organization OF
      = amc$sequential =

        CASE output_cycle_attribute_values.file_organization OF
        = amc$sequential =

          IF (input_file_catalog_info.cycle_registration.residence.device_class = rmc$magnetic_tape_device) OR
                (output_file_catalog_info.cycle_registration.residence.device_class =
                rmc$magnetic_tape_device) THEN
            type_of_copy := fsc$record_move;
          ELSE
            IF output_cycle_attribute_values.file_contents = fsc$list THEN
              IF (output_cycle_attribute_values.record_type = amc$undefined) AND
                    (output_cycle_attribute_values.block_type = amc$system_specified) THEN
                fsp$set_file_reference_abnormal (control_information.output_resolved_file_reference.
                      path (1, control_information.output_resolved_file_reference.cycle_path_size),
                      fse$to_list_output_unsupported, fsc$copy_file_req, '', status);
              ELSEIF (input_cycle_attribute_values.record_type = amc$undefined) AND
                    (input_cycle_attribute_values.block_type = amc$system_specified) THEN
                fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                      path (1, control_information.input_resolved_file_reference.cycle_path_size),
                      fse$to_list_input_unsupported, fsc$copy_file_req, '', status);
                osp$append_status_file (osc$status_parameter_delimiter,
                      control_information.output_resolved_file_reference.
                      path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
              ELSEIF input_cycle_attribute_values.file_contents = fsc$list THEN
                type_of_copy := fsc$record_move;
              ELSEIF input_is_legible OR
                    (input_cycle_attribute_values.file_contents = fsc$data) OR
                    (input_cycle_attribute_values.file_contents = fsc$unknown_contents) THEN
                type_of_copy := fsc$legible_to_list_move;
              ELSE
                fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                      path (1, control_information.input_resolved_file_reference.cycle_path_size),
                      fse$conflicting_file_contents, fsc$copy_file_req, '', status);
                osp$append_status_file (osc$status_parameter_delimiter,
                      control_information.output_resolved_file_reference.
                      path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
              IFEND;
            ELSEIF (output_is_legible OR
                  (output_cycle_attribute_values.file_contents = fsc$data) OR
                  (output_cycle_attribute_values.file_contents = fsc$unknown_contents)) AND
                  (input_cycle_attribute_values.file_contents = fsc$list) THEN
              IF (input_cycle_attribute_values.record_type = amc$undefined) AND
                    (input_cycle_attribute_values.block_type = amc$system_specified) THEN
                fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                      path (1, control_information.input_resolved_file_reference.cycle_path_size),
                      fse$from_list_input_unsupported, fsc$copy_file_req, '', status);
              ELSE
                type_of_copy := fsc$list_to_legible_move;
              IFEND;
            ELSEIF (output_cycle_attribute_values.file_contents =
                  input_cycle_attribute_values.file_contents) OR
                  (output_cycle_attribute_values.file_contents = fsc$unknown_contents) OR
                  (input_cycle_attribute_values.file_contents = fsc$unknown_contents) OR
                  (input_is_legible AND (output_is_legible OR
                  (output_cycle_attribute_values.file_contents = fsc$data))) OR
                  (output_is_legible AND (input_is_legible OR
                  (input_cycle_attribute_values.file_contents = fsc$data))) THEN
              IF output_is_legible AND input_is_legible THEN
                validate_line_identifiers (status);
              IFEND;
              IF status.normal THEN
                IF (input_cycle_attribute_values.record_type = amc$undefined) AND
                      (input_cycle_attribute_values.block_type = amc$system_specified) THEN
                  type_of_copy := fsc$undefined_ss_move;
                ELSE
                  type_of_copy := fsc$record_move;
                IFEND;
              IFEND;
            ELSE
              fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                    path (1, control_information.input_resolved_file_reference.cycle_path_size),
                    fse$conflicting_file_contents, fsc$copy_file_req, '', status);
              osp$append_status_file (osc$status_parameter_delimiter,
                    control_information.output_resolved_file_reference.
                    path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
            IFEND; {IF FC = ?}

            IF status.normal THEN
              IF (input_cycle_attribute_values.block_type = output_cycle_attribute_values.block_type) AND
                    (input_cycle_attribute_values.file_access_procedure_name =
                    output_cycle_attribute_values.file_access_procedure_name) AND
                    (input_file_catalog_info.cycle_registration.residence.device_class =
                    rmc$mass_storage_device) AND (output_file_catalog_info.cycle_registration.residence.
                    device_class = rmc$mass_storage_device) AND (input_file_catalog_info.cycle_registration.
                    size <= output_file_catalog_info.cycle_registration.size_limit) AND
                    (input_initial_byte_address = 0) AND (output_initial_byte_address = 0) AND
                    (fsc$shorten IN output_file_instance_info.attachment_information.access_modes) THEN
                IF (input_cycle_attribute_values.record_type = output_cycle_attribute_values.record_type) AND
                      (input_cycle_attribute_values.file_contents =
                      output_cycle_attribute_values.file_contents) THEN
                  CASE input_cycle_attribute_values.record_type OF
                  = amc$variable =
                    type_of_copy := fsc$byte_move;
                  = amc$ansi_fixed =
                    IF (input_cycle_attribute_values.max_record_length =
                          output_cycle_attribute_values.max_record_length) AND
                          (input_cycle_attribute_values.padding_character =
                          output_cycle_attribute_values.padding_character) THEN
                      type_of_copy := fsc$byte_move;
                    IFEND;
                  = amc$undefined =
                    IF (input_cycle_attribute_values.block_type <> amc$user_specified) OR
                          (input_cycle_attribute_values.max_block_length =
                          output_cycle_attribute_values.max_block_length) THEN
                      type_of_copy := fsc$byte_move;
                    IFEND;
                  = amc$trailing_char_delimited =
                    IF input_cycle_attribute_values.record_delimiting_character =
                          output_cycle_attribute_values.record_delimiting_character THEN
                      type_of_copy := fsc$byte_move;
                    IFEND;
                  ELSE
                    set_status_internal_error (1, status);
                    type_of_copy := fsc$error_move;
                  CASEND;
                ELSEIF (input_cycle_attribute_values.record_type = amc$variable) AND
                      (output_cycle_attribute_values.record_type = amc$trailing_char_delimited) AND
                      (input_cycle_attribute_values.block_type = amc$system_specified) AND
                      (input_cycle_attribute_values.file_access_procedure_name.entry_point = '') AND
                      (type_of_copy = fsc$record_move) THEN
                  type_of_copy := fsc$v_to_t_record_conversion;
                IFEND;
              IFEND;
            IFEND; { IF status.normal }
          IFEND; { IF tape }

        = amc$byte_addressable =
          fsp$set_file_reference_abnormal (control_information.output_resolved_file_reference.
                path (1, control_information.output_resolved_file_reference.cycle_path_size),
                fse$improper_fo_for_copy, fsc$copy_file_req, '', status);
          osp$append_status_file (osc$status_parameter_delimiter,
                control_information.input_resolved_file_reference.
                path (1, control_information.input_resolved_file_reference.cycle_path_size), status);

        = amc$indexed_sequential, amc$direct_access, amc$system_key =
          IF (input_file_catalog_info.cycle_registration.residence.device_class = rmc$magnetic_tape_device)
                THEN
            type_of_copy := fsc$record_move;
          ELSE
            IF (output_is_legible OR
                  (output_cycle_attribute_values.file_contents = fsc$data) OR
                  (output_cycle_attribute_values.file_contents = fsc$unknown_contents)) AND
                  (input_cycle_attribute_values.file_contents = fsc$list) THEN
              IF (input_cycle_attribute_values.record_type = amc$undefined) AND
                    (input_cycle_attribute_values.block_type = amc$system_specified) THEN
                fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                      path (1, control_information.input_resolved_file_reference.cycle_path_size),
                      fse$from_list_input_unsupported, fsc$copy_file_req, '', status);
              ELSE
                type_of_copy := fsc$list_to_legible_move;
              IFEND;
            ELSEIF (output_cycle_attribute_values.file_contents =
                  input_cycle_attribute_values.file_contents) OR
                  (output_cycle_attribute_values.file_contents = fsc$unknown_contents) OR
                  (input_cycle_attribute_values.file_contents = fsc$unknown_contents) OR
                  (input_is_legible AND (output_is_legible OR
                  (output_cycle_attribute_values.file_contents = fsc$data))) OR
                  (output_is_legible AND (input_is_legible OR
                  (input_cycle_attribute_values.file_contents = fsc$data))) THEN
              IF output_is_legible AND input_is_legible THEN
                validate_line_identifiers (status);
              IFEND;
              IF status.normal THEN
                type_of_copy := fsc$record_move;
              IFEND;
            ELSE
              fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                    path (1, control_information.input_resolved_file_reference.cycle_path_size),
                    fse$conflicting_file_contents, fsc$copy_file_req, '', status);
              osp$append_status_file (osc$status_parameter_delimiter,
                    control_information.output_resolved_file_reference.
                    path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
            IFEND; {IF FC = ?}
          IFEND; { IF tape }

        ELSE {all file_organizations (seq, byte_add, isam, da, sys_key) have been cased}
        CASEND;

      = amc$byte_addressable =

        CASE output_cycle_attribute_values.file_organization OF
        = amc$byte_addressable =
          IF input_cycle_attribute_values.block_type <> output_cycle_attribute_values.block_type THEN
            fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                  path (1, control_information.input_resolved_file_reference.cycle_path_size),
                  fse$conflicting_block_types, fsc$copy_file_req, '', status);
            osp$append_status_file (osc$status_parameter_delimiter,
                  control_information.output_resolved_file_reference.
                  path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
          ELSEIF input_cycle_attribute_values.file_access_procedure_name <>
                output_cycle_attribute_values.file_access_procedure_name THEN
            fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                  path (1, control_information.input_resolved_file_reference.cycle_path_size),
                  fse$fap_names_not_identical, fsc$copy_file_req, '', status);
            osp$append_status_file (osc$status_parameter_delimiter,
                  control_information.output_resolved_file_reference.
                  path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
          ELSEIF input_cycle_attribute_values.file_contents <>
                output_cycle_attribute_values.file_contents THEN
            fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                  path (1, control_information.input_resolved_file_reference.cycle_path_size),
                  fse$conflicting_file_contents, fsc$copy_file_req, '', status);
            osp$append_status_file (osc$status_parameter_delimiter,
                  control_information.output_resolved_file_reference.
                  path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
          ELSEIF input_cycle_attribute_values.record_type <> output_cycle_attribute_values.record_type THEN
            fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                  path (1, control_information.input_resolved_file_reference.cycle_path_size),
                  fse$conflicting_record_types, fsc$copy_file_req, '', status);
            osp$append_status_file (osc$status_parameter_delimiter,
                  control_information.output_resolved_file_reference.
                  path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
          ELSEIF input_file_catalog_info.cycle_registration.residence.device_class <>
                rmc$mass_storage_device THEN
            fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                  path (1, control_information.input_resolved_file_reference.cycle_path_size),
                  fse$copy_device_conflict, fsc$copy_file_req, '', status);
          ELSEIF output_file_catalog_info.cycle_registration.residence.device_class <>
                rmc$mass_storage_device THEN
            fsp$set_file_reference_abnormal (control_information.output_resolved_file_reference.
                  path (1, control_information.output_resolved_file_reference.cycle_path_size),
                  fse$copy_device_conflict, fsc$copy_file_req, '', status);
          ELSEIF input_file_catalog_info.cycle_registration.size >
                output_file_catalog_info.cycle_registration.size_limit THEN
            fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                  path (1, control_information.input_resolved_file_reference.cycle_path_size),
                  fse$size_exceeds_output_limits, fsc$copy_file_req, '', status);
            osp$append_status_file (osc$status_parameter_delimiter,
                  control_information.output_resolved_file_reference.
                  path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
          ELSEIF input_initial_byte_address <> output_initial_byte_address THEN
            fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                  path (1, control_information.input_resolved_file_reference.cycle_path_size),
                  fse$conflicting_file_addresses, fsc$copy_file_req, '', status);
            osp$append_status_file (osc$status_parameter_delimiter,
                  control_information.output_resolved_file_reference.
                  path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
          ELSEIF NOT (fsc$shorten IN output_file_instance_info.attachment_information.access_modes) THEN
            fsp$set_file_reference_abnormal (control_information.output_resolved_file_reference.
                  path (1, control_information.output_resolved_file_reference.cycle_path_size),
                  ame$improper_access_attempt, fsc$copy_file_req, ' SHORTEN ', status);
          ELSE
            CASE input_cycle_attribute_values.record_type OF
            = amc$variable =
              type_of_copy := fsc$byte_move;
            = amc$ansi_fixed =
              IF input_cycle_attribute_values.max_record_length <>
                    output_cycle_attribute_values.max_record_length THEN
                fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                      path (1, control_information.input_resolved_file_reference.cycle_path_size),
                      fse$record_lengths_unequal, fsc$copy_file_req, '', status);
                osp$append_status_file (osc$status_parameter_delimiter,
                      control_information.output_resolved_file_reference.
                      path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
              ELSEIF input_cycle_attribute_values.padding_character <>
                    output_cycle_attribute_values.padding_character THEN
                fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                      path (1, control_information.input_resolved_file_reference.cycle_path_size),
                      fse$padding_characters_unequal, fsc$copy_file_req, '', status);
                osp$append_status_file (osc$status_parameter_delimiter,
                      control_information.output_resolved_file_reference.
                      path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
              ELSE
                type_of_copy := fsc$byte_move;
              IFEND;
            = amc$undefined =
              IF (input_cycle_attribute_values.block_type = amc$user_specified) AND
                    (input_cycle_attribute_values.max_block_length <>
                    output_cycle_attribute_values.max_block_length) THEN
                fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                      path (1, control_information.input_resolved_file_reference.cycle_path_size),
                      fse$block_lengths_unequal, fsc$copy_file_req, '', status);
                osp$append_status_file (osc$status_parameter_delimiter,
                      control_information.output_resolved_file_reference.
                      path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
              ELSE
                type_of_copy := fsc$byte_move;
              IFEND;
            = amc$trailing_char_delimited =
              IF input_cycle_attribute_values.record_delimiting_character <>
                    output_cycle_attribute_values.record_delimiting_character THEN
                fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                      path (1, control_information.input_resolved_file_reference.cycle_path_size),
                      fse$trailing_characters_unequal, fsc$copy_file_req, '', status);
                osp$append_status_file (osc$status_parameter_delimiter,
                      control_information.output_resolved_file_reference.
                      path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
              ELSE
                type_of_copy := fsc$byte_move;
              IFEND;
            ELSE
              set_status_internal_error (2, status);
              type_of_copy := fsc$error_move;
            CASEND;
          IFEND;

        = amc$sequential =
          fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                path (1, control_information.input_resolved_file_reference.cycle_path_size),
                fse$improper_fo_for_copy, fsc$copy_file_req, '', status);
          osp$append_status_file (osc$status_parameter_delimiter,
                control_information.output_resolved_file_reference.
                path (1, control_information.output_resolved_file_reference.cycle_path_size), status);

        = amc$indexed_sequential, amc$direct_access, amc$system_key =
          fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                path (1, control_information.input_resolved_file_reference.cycle_path_size),
                fse$improper_fo_for_copy, fsc$copy_file_req, '', status);
          osp$append_status_file (osc$status_parameter_delimiter,
                control_information.output_resolved_file_reference.
                path (1, control_information.output_resolved_file_reference.cycle_path_size), status);

        ELSE {all file_organizations (seq, byte_add, isam, da, sys_key) have been cased}
        CASEND;

      = amc$indexed_sequential, amc$direct_access, amc$system_key =

        CASE output_cycle_attribute_values.file_organization OF
        = amc$indexed_sequential, amc$direct_access, amc$system_key =
          IF NOT ((output_cycle_attribute_values.file_contents =
                  input_cycle_attribute_values.file_contents) OR
                  (output_cycle_attribute_values.file_contents = fsc$unknown_contents) OR
                  (input_cycle_attribute_values.file_contents = fsc$unknown_contents) OR
                  (input_is_legible AND (output_is_legible OR
                  (output_cycle_attribute_values.file_contents = fsc$data))) OR
                  (output_is_legible AND (input_is_legible OR
                  (input_cycle_attribute_values.file_contents = fsc$data)))) THEN
            fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                  path (1, control_information.input_resolved_file_reference.cycle_path_size),
                  fse$conflicting_file_contents, fsc$copy_file_req, '', status);
            osp$append_status_file (osc$status_parameter_delimiter,
                  control_information.output_resolved_file_reference.
                  path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
          ELSE
            IF output_is_legible AND input_is_legible THEN
              validate_line_identifiers (status);
            IFEND;
            IF status.normal THEN
              IF (input_file_catalog_info.cycle_registration.residence.device_class <>
                    rmc$mass_storage_device) OR (output_file_catalog_info.cycle_registration.residence.
                    device_class <> rmc$mass_storage_device) THEN
                type_of_copy := fsc$record_move;
              ELSE
                type_of_copy := fsc$copy_keyed_file_move;
                IF (input_cycle_attribute_values.compression_procedure_name =
                      output_cycle_attribute_values.compression_procedure_name) AND
                      (input_cycle_attribute_values.hashing_procedure_name =
                      output_cycle_attribute_values.hashing_procedure_name) AND
                      (input_cycle_attribute_values.collate_table_name =
                      output_cycle_attribute_values.collate_table_name) AND
                      (input_cycle_attribute_values.embedded_key = output_cycle_attribute_values.
                      embedded_key) AND (input_cycle_attribute_values.file_access_procedure_name =
                      output_cycle_attribute_values.file_access_procedure_name) AND
                      (input_cycle_attribute_values.file_contents =
                      output_cycle_attribute_values.file_contents) AND
                      (input_cycle_attribute_values.file_organization =
                      output_cycle_attribute_values.file_organization) AND
                      (input_cycle_attribute_values.initial_home_block_count =
                      output_cycle_attribute_values.initial_home_block_count) AND
                      (input_cycle_attribute_values.key_length = output_cycle_attribute_values.key_length) AND
                      (input_cycle_attribute_values.key_position = output_cycle_attribute_values.
                      key_position) AND (input_cycle_attribute_values.key_type =
                      output_cycle_attribute_values.key_type) AND (input_cycle_attribute_values.
                      max_block_length = output_cycle_attribute_values.max_block_length) AND
                      (input_cycle_attribute_values.max_record_length =
                      output_cycle_attribute_values.max_record_length) AND
                      (input_cycle_attribute_values.min_record_length =
                      output_cycle_attribute_values.min_record_length) AND
                      (input_cycle_attribute_values.record_type = output_cycle_attribute_values.record_type)
                      AND (input_cycle_attribute_values.records_per_block =
                      output_cycle_attribute_values.records_per_block) AND
                      (input_file_catalog_info.cycle_registration.size <=
                      output_file_catalog_info.cycle_registration.size_limit) AND
                      (input_file_instance_info.attachment_information.open_position = amc$open_at_boi) AND
                      (output_file_instance_info.attachment_information.open_position = amc$open_at_boi) AND
                      (output_file_instance_info.attachment_information.open_share_modes =
                      $fst$file_access_options []) AND (fsc$shorten IN
                      output_file_instance_info.attachment_information.access_modes) THEN
                  type_of_copy := fsc$byte_move;
                IFEND;
              IFEND; {device_class}
            IFEND;
          IFEND;

        = amc$sequential =
          IF (output_file_catalog_info.cycle_registration.residence.device_class = rmc$magnetic_tape_device)
                THEN
            type_of_copy := fsc$record_move;
          ELSE
            IF output_cycle_attribute_values.file_contents = fsc$list THEN
              IF (output_cycle_attribute_values.record_type = amc$undefined) AND
                    (output_cycle_attribute_values.block_type = amc$system_specified) THEN
                fsp$set_file_reference_abnormal (control_information.output_resolved_file_reference.
                      path (1, control_information.output_resolved_file_reference.cycle_path_size),
                      fse$to_list_output_unsupported, fsc$copy_file_req, '', status);
              ELSEIF input_is_legible OR
                    (input_cycle_attribute_values.file_contents = fsc$data) OR
                    (input_cycle_attribute_values.file_contents = fsc$unknown_contents) THEN
                type_of_copy := fsc$legible_to_list_move;
              ELSE
                fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                      path (1, control_information.input_resolved_file_reference.cycle_path_size),
                      fse$conflicting_file_contents, fsc$copy_file_req, '', status);
                osp$append_status_file (osc$status_parameter_delimiter,
                      control_information.output_resolved_file_reference.
                      path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
              IFEND;
            ELSEIF (output_cycle_attribute_values.file_contents =
                  input_cycle_attribute_values.file_contents) OR
                  (output_cycle_attribute_values.file_contents = fsc$unknown_contents) OR
                  (input_cycle_attribute_values.file_contents = fsc$unknown_contents) OR
                  (input_is_legible AND (output_is_legible OR
                  (output_cycle_attribute_values.file_contents = fsc$data))) OR
                  (output_is_legible AND (input_is_legible OR
                  (input_cycle_attribute_values.file_contents = fsc$data))) THEN
              IF output_is_legible AND input_is_legible THEN
                validate_line_identifiers (status);
              IFEND;
              IF status.normal THEN
                type_of_copy := fsc$record_move;
              IFEND;
            ELSE
              fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                    path (1, control_information.input_resolved_file_reference.cycle_path_size),
                    fse$conflicting_file_contents, fsc$copy_file_req, '', status);
              osp$append_status_file (osc$status_parameter_delimiter,
                    control_information.output_resolved_file_reference.
                    path (1, control_information.output_resolved_file_reference.cycle_path_size), status);
            IFEND; {IF FC = ?}
          IFEND; { IF tape }

        = amc$byte_addressable =
          fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                path (1, control_information.input_resolved_file_reference.cycle_path_size),
                fse$improper_fo_for_copy, fsc$copy_file_req, '', status);
          osp$append_status_file (osc$status_parameter_delimiter,
                control_information.output_resolved_file_reference.
                path (1, control_information.output_resolved_file_reference.cycle_path_size), status);

        ELSE {all file_organizations (seq, byte_add, isam, da, sys_key) have been cased}
        CASEND;

      ELSE {all file_organizations (seq, byte_add, isam, da, sys_key) have been cased}
      CASEND;

      IF NOT status.normal THEN
        IF type_of_copy <> fsc$error_move THEN
          pmp$log (' FSP$COPY_FILE did not recognize error_move in get_type_of_copy', ignore_status);
        IFEND;
        type_of_copy := fsc$error_move;
        RETURN;
      ELSEIF type_of_copy = fsc$error_move THEN
        set_status_internal_error (3, status);
        RETURN;
      IFEND;

    PROCEND get_type_of_copy;

?? TITLE := '  PROCEDURE calculate_record_info ' ??
?? EJECT ??

    PROCEDURE calculate_record_info
      (VAR control_information: fst$copy_control_information;
       VAR status: ost$status);

      FUNCTION minimum_record_length
        (    input_record_length: integer;
             output_record_length: integer): amt$working_storage_length;

        IF input_record_length < output_record_length THEN
          minimum_record_length := input_record_length;
        ELSE
          minimum_record_length := output_record_length;
        IFEND;
      FUNCEND minimum_record_length;

      CONST
        minimum_sequential_wsl = 100(16); {256 bytes}

      VAR
        required_input_record_length: amt$max_record_length,
        required_output_record_length: amt$max_record_length;

      { PURPOSE:  This procedure determines the necessary information for a       }
      {record_move, list_to_legible_move, legible_to_list_move, undefined_ss_move.}


      control_information.input_file_device_class := input_file_catalog_info.cycle_registration.residence.
            device_class;

      IF control_information.type_of_copy = fsc$legible_to_list_move THEN
        control_information.page_format := output_cycle_attribute_values.page_format;
        control_information.page_length := output_cycle_attribute_values.page_length;
      IFEND;

      IF (output_cycle_attribute_values.record_type = amc$variable) AND
            (output_cycle_attribute_values.file_organization = amc$sequential) THEN
        control_information.output_can_be_partitioned := TRUE;
      ELSE
        control_information.output_can_be_partitioned := FALSE;
      IFEND;

      control_information.output_record_length_is_fixed := FALSE;
      control_information.push_overflow := FALSE;

{  The size of the record header of an ansi_variable file is subtracted from the max_block_length, because
{  the maximum amount of data that can be placed in an ansi_variable block is the max_block_size minus the
{  header size and the calculation of working_storage length and output_record_length is based on the
{  maximum amount of data that can be placed in a record/block.
      IF input_cycle_attribute_values.record_type = amc$ansi_variable THEN
         input_cycle_attribute_values.max_block_length :=
               input_cycle_attribute_values.max_block_length - #SIZE (bat$d_record_rcw);
      IFEND;
      IF output_cycle_attribute_values.record_type = amc$ansi_variable THEN
         output_cycle_attribute_values.max_block_length :=
               output_cycle_attribute_values.max_block_length - #SIZE (bat$d_record_rcw);
      IFEND;

      {See table in ERS for a table of the determination of Working_storage_length}
      IF (input_cycle_attribute_values.file_organization = amc$sequential) AND
            (output_cycle_attribute_values.file_organization = amc$sequential) THEN
        {For a fixed to fixed copy, a working storage area greater than the minimum of the
        {maxrl/maxbl of both files is wasted space. (ie. either truncated of never used.)
        IF (output_cycle_attribute_values.block_type = amc$user_specified) AND
              ((output_cycle_attribute_values.record_type = amc$undefined) OR
              (output_cycle_attribute_values.record_type = amc$ansi_variable)) THEN
          control_information.output_record_length := output_cycle_attribute_values.max_block_length;
          control_information.output_record_length_is_fixed := TRUE;
          IF (input_cycle_attribute_values.block_type = amc$user_specified) AND
                ((input_cycle_attribute_values.record_type = amc$undefined) OR
                (input_cycle_attribute_values.record_type = amc$ansi_variable)) THEN
            control_information.working_storage_length := minimum_record_length
                  (input_cycle_attribute_values.max_block_length,
                  output_cycle_attribute_values.max_block_length);
          ELSEIF input_cycle_attribute_values.record_type = amc$ansi_fixed THEN
            control_information.working_storage_length := minimum_record_length
                  (input_cycle_attribute_values.max_record_length,
                  output_cycle_attribute_values.max_block_length);
          ELSE
            control_information.working_storage_length := output_cycle_attribute_values.max_block_length;
          IFEND;
        ELSEIF output_cycle_attribute_values.record_type = amc$ansi_fixed THEN
          control_information.output_record_length := output_cycle_attribute_values.max_record_length;
          control_information.output_record_length_is_fixed := TRUE;
          IF (input_cycle_attribute_values.block_type = amc$user_specified) AND
                ((input_cycle_attribute_values.record_type = amc$undefined) OR
                (input_cycle_attribute_values.record_type = amc$ansi_variable)) THEN
            control_information.working_storage_length := minimum_record_length
                  (input_cycle_attribute_values.max_block_length,
                  output_cycle_attribute_values.max_record_length);
          ELSEIF input_cycle_attribute_values.record_type = amc$ansi_fixed THEN
            control_information.working_storage_length := minimum_record_length
                  (input_cycle_attribute_values.max_record_length,
                  output_cycle_attribute_values.max_record_length);
          ELSE
            control_information.working_storage_length := output_cycle_attribute_values.max_record_length;
          IFEND;
        ELSEIF (input_cycle_attribute_values.record_type = amc$undefined) AND
              (input_cycle_attribute_values.block_type = amc$system_specified) THEN
          control_information.output_record_length := output_cycle_attribute_values.max_record_length;
          control_information.output_record_length_is_fixed := TRUE;
          control_information.working_storage_length := output_cycle_attribute_values.max_record_length;
        ELSEIF input_cycle_attribute_values.record_type = amc$ansi_fixed THEN
          control_information.working_storage_length := input_cycle_attribute_values.max_record_length;
        ELSE
          control_information.working_storage_length := input_cycle_attribute_values.max_block_length;
        IFEND;
        {The following allows a single get_next and put_next per record if possible when converting.
        IF (control_information.type_of_copy = fsc$list_to_legible_move) OR
              (control_information.type_of_copy = fsc$legible_to_list_move) THEN
          control_information.working_storage_length := control_information.working_storage_length + 1;
        IFEND;

        {The restriction of a maximum push allows for large records without requiring a large
        {working storage area being pushed onto the stack.
        {This is not appropriate for keyed files because they don't support partial gets and puts.
        {The limit for indexed sequential files as of 7/13/86 is a maxrl of approximately 65k.
        {For rt=u bt=us and device_class=rmc$magnetic_tape_device direct i/o can be done on
        {Long record tapes if the working storage area is not restricted, begins on a word
        {boundary (which is true for PUSH and the Scratch segment, and ends on a word boundary.
        {
        IF (input_cycle_attribute_values.record_type = amc$undefined) AND
              (input_cycle_attribute_values.block_type = amc$user_specified) AND
              (input_file_catalog_info.cycle_registration.residence.device_class = rmc$magnetic_tape_device)
              THEN
          control_information.working_storage_length := control_information.working_storage_length +
                ((8 - (control_information.working_storage_length MOD 8)) MOD 8);
        ELSEIF control_information.working_storage_length > fsc$maximum_copy_file_push THEN
          control_information.working_storage_length := fsc$maximum_copy_file_push;
          control_information.push_overflow := TRUE;
        ELSE
          IF (NOT control_information.output_record_length_is_fixed) AND
                (control_information.working_storage_length < minimum_sequential_wsl) THEN
            control_information.working_storage_length := minimum_sequential_wsl;
          IFEND;
        IFEND;
      ELSEIF (input_cycle_attribute_values.file_organization IN amv$aam_file_organizations) AND
            (output_cycle_attribute_values.file_organization = amc$sequential) THEN
        {The case of input file with rt=u bt=ss is not specified because push_overflow is false,
        {therefore output_record_length is irrelevant.
        IF (output_cycle_attribute_values.block_type = amc$user_specified) AND
              ((output_cycle_attribute_values.record_type = amc$undefined) OR
              (output_cycle_attribute_values.record_type = amc$ansi_variable)) THEN
          control_information.output_record_length := output_cycle_attribute_values.max_block_length;
          control_information.output_record_length_is_fixed := TRUE;
        ELSEIF output_cycle_attribute_values.record_type = amc$ansi_fixed THEN
          control_information.output_record_length := output_cycle_attribute_values.max_record_length;
          control_information.output_record_length_is_fixed := TRUE;
        IFEND;
        IF input_cycle_attribute_values.embedded_key THEN
          control_information.working_storage_length := input_cycle_attribute_values.max_record_length;
        ELSE
          control_information.working_storage_length := input_cycle_attribute_values.max_record_length +
                input_cycle_attribute_values.key_length;
        IFEND;
        {The get of an ISAM file MUST be COMPLETE, therefore one is added for legible to list}
        IF (control_information.type_of_copy = fsc$legible_to_list_move) THEN
          control_information.working_storage_length := control_information.working_storage_length + 1;
        IFEND;
      ELSEIF (input_cycle_attribute_values.file_organization = amc$sequential) AND
            (output_cycle_attribute_values.file_organization IN amv$aam_file_organizations) THEN
        IF output_cycle_attribute_values.embedded_key THEN
          control_information.output_record_length := output_cycle_attribute_values.max_record_length;
        ELSE
          control_information.output_record_length := output_cycle_attribute_values.max_record_length +
                output_cycle_attribute_values.key_length;
        IFEND;
        control_information.output_record_length_is_fixed := TRUE;
        control_information.working_storage_length := control_information.output_record_length;
        { The working storage length is increase by one because the format effector is tossed out}
        IF (control_information.type_of_copy = fsc$list_to_legible_move) THEN
          control_information.working_storage_length := control_information.working_storage_length + 1;
        IFEND;
      ELSEIF (input_cycle_attribute_values.file_organization IN amv$aam_file_organizations) AND
            (output_cycle_attribute_values.file_organization IN amv$aam_file_organizations) THEN
{ This is the case where one of the AAM files is the target of a file connection.
        IF output_cycle_attribute_values.embedded_key THEN
          control_information.output_record_length := output_cycle_attribute_values.max_record_length;
        ELSE
          control_information.output_record_length := output_cycle_attribute_values.max_record_length +
                output_cycle_attribute_values.key_length;
        IFEND;
        control_information.output_record_length_is_fixed := TRUE;
        IF input_cycle_attribute_values.embedded_key THEN
          control_information.working_storage_length := input_cycle_attribute_values.max_record_length;
        ELSE
          control_information.working_storage_length := input_cycle_attribute_values.max_record_length +
                input_cycle_attribute_values.key_length;
        IFEND;
      ELSE
        set_status_internal_error (4, status);
      IFEND;

      {  The following lines make sure that the maxrl is large enough for the requested copy. }
      CASE control_information.type_of_copy OF
      = fsc$record_move, fsc$undefined_ss_move =
        required_input_record_length := 1;
        required_output_record_length := 1;
      = fsc$legible_to_list_move =
        required_input_record_length := 1;
        required_output_record_length := 2;
      = fsc$list_to_legible_move =
        required_input_record_length := 2;
        required_output_record_length := 1;
      ELSE
        set_status_internal_error (5, status);
        RETURN;
      CASEND;

      IF control_information.output_record_length_is_fixed AND
            (control_information.output_record_length < required_output_record_length) THEN
        fsp$set_file_reference_abnormal (control_information.output_resolved_file_reference.
              path (1, control_information.output_resolved_file_reference.cycle_path_size),
              fse$insufficient_record_length, fsc$copy_file_req, '', status);
        RETURN;
      ELSEIF ((input_cycle_attribute_values.record_type = amc$ansi_fixed) AND
            (input_cycle_attribute_values.max_record_length < required_input_record_length)) OR
            ((input_cycle_attribute_values.block_type = amc$user_specified) AND
            ((input_cycle_attribute_values.record_type = amc$undefined) OR
            (input_cycle_attribute_values.record_type = amc$ansi_variable)) AND
            (input_cycle_attribute_values.max_block_length < required_input_record_length)) THEN
        fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
              path (1, control_information.input_resolved_file_reference.cycle_path_size),
              fse$insufficient_record_length, fsc$copy_file_req, '', status);
        RETURN;
      IFEND;

      IF (control_information.working_storage_length < required_input_record_length) OR
            (control_information.working_storage_length < required_output_record_length) THEN
        set_status_internal_error (6, status);
        RETURN;
      IFEND;

    PROCEND calculate_record_info;

?? TITLE := '  PROCEDURE delete_data ' ??
?? EJECT ??

    PROCEDURE delete_data
      (    output: fst$file_reference;
       VAR {input, output} output_fid: amt$file_identifier;
       VAR {input, output} type_of_copy: fst$copy_types;
       VAR status: ost$status);

      VAR
        new_output_attachment_options: ^fst$attachment_options,
        new_output_attribute_validation: array [1 .. 12] of fst$file_cycle_attribute;

      status.normal := TRUE;

      IF (type_of_copy = fsc$byte_move) OR (NOT (output_cycle_attribute_values.file_organization IN
            amv$aam_file_organizations)) THEN
        bap$delete_data (output_fid, status);
        IF NOT status.normal THEN
          type_of_copy := fsc$error_move;
          RETURN;
        IFEND;
      ELSEIF type_of_copy <> fsc$copy_keyed_file_move THEN
        {If a copy_keyed_files is performed, the output file will be deleted in copy_keyed_file.}
        new_output_attribute_validation [1].selector := fsc$block_type;
        new_output_attribute_validation [1].block_type := output_cycle_attribute_values.block_type;
        new_output_attribute_validation [2].selector := fsc$embedded_key;
        new_output_attribute_validation [2].embedded_key := output_cycle_attribute_values.embedded_key;
        new_output_attribute_validation [3].selector := fsc$file_contents_and_processor;
        new_output_attribute_validation [3].file_contents := output_cycle_attribute_values.file_contents;
        new_output_attribute_validation [3].file_processor := output_cycle_attribute_values.file_processor;
        new_output_attribute_validation [4].selector := fsc$file_organization;
        new_output_attribute_validation [4].file_organization :=
              output_cycle_attribute_values.file_organization;
        new_output_attribute_validation [5].selector := fsc$key_length;
        new_output_attribute_validation [5].key_length := output_cycle_attribute_values.key_length;
        new_output_attribute_validation [6].selector := fsc$line_number;
        new_output_attribute_validation [6].line_number := output_cycle_attribute_values.line_number;
        new_output_attribute_validation [7].selector := fsc$max_block_length;
        new_output_attribute_validation [7].max_block_length :=
              output_cycle_attribute_values.max_block_length;
        new_output_attribute_validation [8].selector := fsc$max_record_length;
        new_output_attribute_validation [8].max_record_length :=
              output_cycle_attribute_values.max_record_length;
        new_output_attribute_validation [9].selector := fsc$page_format;
        new_output_attribute_validation [9].page_format := output_cycle_attribute_values.page_format;
        new_output_attribute_validation [10].selector := fsc$page_length;
        new_output_attribute_validation [10].page_length := output_cycle_attribute_values.page_length;
        new_output_attribute_validation [11].selector := fsc$record_type;
        new_output_attribute_validation [11].record_type := output_cycle_attribute_values.record_type;
        new_output_attribute_validation [12].selector := fsc$statement_identifier;
        new_output_attribute_validation [12].statement_identifier :=
              output_cycle_attribute_values.statement_identifier;
        PUSH new_output_attachment_options: [1 .. UPPERBOUND (output_file_attachment^) + 1];
        i#move (output_file_attachment, new_output_attachment_options, #SIZE (output_file_attachment^));
        new_output_attachment_options^ [UPPERBOUND (new_output_attachment_options^)].selector :=
              fsc$create_file;
        new_output_attachment_options^ [UPPERBOUND (new_output_attachment_options^)].create_file := FALSE;
        fsp$close_file (output_fid, status);
        output_fid := amv$nil_file_identifier;
        #SPOIL (output_fid);
        IF NOT status.normal THEN
          type_of_copy := fsc$error_move;
          RETURN;
        IFEND;
        fsp$open_file (output, amc$record, new_output_attachment_options, NIL, NIL,
              ^new_output_attribute_validation, NIL, output_fid, status);
        IF NOT status.normal THEN
          type_of_copy := fsc$error_move;
          RETURN;
        IFEND;
      IFEND;

    PROCEND delete_data;

?? OLDTITLE ??
?? EJECT ??

    CONST
      tfa_bt = 1,
      tfa_cc = 2,
      tfa_ic = 3,
      tfa_maxbl = 4,
      tfa_maxrl = 5,
      tfa_pc = 6,
      tfa_rt = 7;

    TYPE
      attachment_options = set of fst$file_attachment_choices;

    VAR
      allowed_device_classes: fst$device_classes,
      attachment_count: integer,
      delete_data_index: integer,
      delete_output_data: boolean,
      device_dependent_info: attribute_information,
      file_contents_text: ost$string,
      file_contents_truncation_status: ost$status,
      new_default_bt: amt$block_type,
      new_default_rt: amt$record_type,
      option: integer,
      output_file_contents_truncated: boolean,
      specified_options: attachment_options,
      tape_file_attributes: array [tfa_bt .. tfa_rt] of amt$fetch_item;

  /open_and_get_type_of_copy/
    BEGIN

      allowed_device_classes:=-$fst$device_classes[];
      input_fid := amv$nil_file_identifier;
      #SPOIL (input_fid);
      output_fid := amv$nil_file_identifier;
      #SPOIL (output_fid);
      control_information.type_of_copy := fsc$error_move;
      file_contents_truncation_status.normal := TRUE;
      output_file_contents_truncated := FALSE;
      specified_options:=  $attachment_options[];
      status.normal := TRUE;

      IF input_file_attachment <> NIL THEN
         attachment_count:= UPPERBOUND (input_file_attachment^);
         FOR option:= 1 to attachment_count DO
           CASE  input_file_attachment^[option].selector of
             = fsc$open_share_modes =
               specified_options:= specified_options + $attachment_options[fsc$open_share_modes];
           ELSE
           CASEND;
         FOREND;
      ELSE
        attachment_count := 0;
      IFEND;
      IF NOT (fsc$open_share_modes IN specified_options) THEN
        PUSH input_file_attachment_options: [1 .. attachment_count + 2];
        IF attachment_count > 0 THEN
          i#move (input_file_attachment, input_file_attachment_options, #SIZE (input_file_attachment^));
        IFEND;
        input_file_attachment_options^ [attachment_count + 1].selector := fsc$open_share_modes;
        input_file_attachment_options^ [attachment_count + 1].open_share_modes :=
              $fst$file_access_options [fsc$read, fsc$execute];
        input_file_attachment_options^ [attachment_count + 2].selector := fsc$open_share_modes;
        input_file_attachment_options^ [attachment_count + 2].open_share_modes :=
              -$fst$file_access_options [];
      ELSE
        input_file_attachment_options := input_file_attachment;
      IFEND;

      fsp$open_file (input, amc$record, input_file_attachment_options, NIL, NIL, input_attribute_validation,
            NIL, input_fid, status);
      IF NOT status.normal THEN
        IF status.condition = ame$new_file_requires_append THEN
          fsp$set_file_reference_abnormal (input, fse$empty_input_file, fsc$copy_file_req, '', status);
        IFEND;
        RETURN;
      IFEND;

      fsp$get_open_information (input_fid, NIL, ^input_file_catalog_info, ^input_cycle_attribute_sources,
            ^input_cycle_attribute_values, ^input_file_instance_info,
            ^control_information.input_resolved_file_reference, NIL, input_file_user_def_attr_size, status);

      IF NOT status.normal THEN
        IF status.condition = fse$file_contents_truncated THEN
          file_contents_truncation_status := status;
          status.normal := TRUE;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      IF (input_file_catalog_info.cycle_registration.size = 0) AND
            (input_file_catalog_info.cycle_registration.residence.device_class = rmc$mass_storage_device) THEN
        fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
              path (1, control_information.input_resolved_file_reference.cycle_path_size),
              fse$empty_input_file, fsc$copy_file_req, '', status);
        RETURN;
      IFEND;

      IF (input_file_catalog_info.cycle_registration.residence.device_class <> rmc$magnetic_tape_device) AND
            (input_file_catalog_info.cycle_registration.residence.device_class <> rmc$null_device) AND
            (NOT (input_file_instance_info.attachment_information.open_share_modes <=
            $fst$file_access_options [fsc$read, fsc$execute])) AND
            NOT (fsc$open_share_modes IN specified_options) THEN
        IF NOT task_has_exclusive_write_access (input_fid) THEN
          fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                path (1, control_information.input_resolved_file_reference.cycle_path_size),
                fse$concurrent_share_conflict, fsc$copy_file_req, 'READ, EXECUTE', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'APPEND, SHORTEN, and/or MODIFY',
                status);
          RETURN;
        IFEND;
      IFEND;

      IF input_file_instance_info.attachment_information.open_position = amc$open_at_eoi THEN
        fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
              path (1, control_information.input_resolved_file_reference.cycle_path_size),
              fse$input_file_at_eoi, fsc$copy_file_req, '', status);
        RETURN;
      IFEND;

      device_dependent_info.adjust_default := FALSE;

      {Current byte address is used in determining whether a byte_move can be done}
      IF input_file_catalog_info.cycle_registration.residence.device_class = rmc$mass_storage_device THEN
        IF input_cycle_attribute_values.file_organization IN amv$aam_file_organizations THEN
          input_initial_byte_address := 0;
        ELSE
          input_file_access_info [1].key := amc$current_byte_address;
          amp$fetch_access_information (input_fid, input_file_access_info, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF (input_file_access_info [1].current_byte_address =
                input_file_catalog_info.cycle_registration.size) THEN
            fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                  path (1, control_information.input_resolved_file_reference.cycle_path_size),
                  fse$input_file_at_eoi, fsc$copy_file_req, '', status);
            RETURN;
          IFEND;
          input_initial_byte_address := input_file_access_info [1].current_byte_address;
        IFEND;
        allowed_device_classes := -$fst$device_classes[fsc$magnetic_tape_device];
        { SS/F and SS/T block and record combinations are supported on disk but not tape files.
        { Map these combinations to ones that are acceptable for a tape file should the output
        { file turn out to be a tape file; set up allowed device classes to prevent opening a
        { tape file.
        IF (input_cycle_attribute_values.block_type = amc$system_specified) THEN
          IF input_cycle_attribute_values.record_type = amc$ansi_fixed THEN
            device_dependent_info.adjust_default := TRUE;
            new_default_rt := amc$ansi_fixed;
            new_default_bt := amc$user_specified;
          ELSEIF input_cycle_attribute_values.record_type = amc$trailing_char_delimited THEN
            device_dependent_info.adjust_default := TRUE;
            new_default_rt := amc$variable;
            new_default_bt := amc$system_specified;
          IFEND;
        IFEND;
      ELSEIF input_file_catalog_info.cycle_registration.residence.device_class = rmc$magnetic_tape_device THEN

        tape_file_attributes [tfa_bt].key := amc$block_type;
        tape_file_attributes [tfa_cc].key := amc$character_conversion;
        tape_file_attributes [tfa_ic].key := amc$internal_code;
        tape_file_attributes [tfa_maxbl].key := amc$max_block_length;
        tape_file_attributes [tfa_maxrl].key := amc$max_record_length;
        tape_file_attributes [tfa_pc].key := amc$padding_character;
        tape_file_attributes [tfa_rt].key := amc$record_type;

        amp$fetch (input_fid, tape_file_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        input_cycle_attribute_values.block_type := tape_file_attributes [tfa_bt].block_type;
        input_cycle_attribute_sources.block_type := tape_file_attributes [tfa_bt].source;

        input_cycle_attribute_values.character_conversion :=
              tape_file_attributes [tfa_cc].character_conversion;
        input_cycle_attribute_sources.character_conversion := tape_file_attributes [tfa_cc].source;

        input_cycle_attribute_values.internal_code := tape_file_attributes [tfa_ic].internal_code;
        input_cycle_attribute_sources.internal_code := tape_file_attributes [tfa_ic].source;

        input_cycle_attribute_values.max_block_length := tape_file_attributes [tfa_maxbl].max_block_length;
        input_cycle_attribute_sources.max_block_length := tape_file_attributes [tfa_maxbl].source;

        input_cycle_attribute_values.max_record_length := tape_file_attributes [tfa_maxrl].max_record_length;
        input_cycle_attribute_sources.max_record_length := tape_file_attributes [tfa_maxrl].source;

        input_cycle_attribute_values.padding_character := tape_file_attributes [tfa_pc].padding_character;
        input_cycle_attribute_sources.padding_character := tape_file_attributes [tfa_pc].source;

        input_cycle_attribute_values.record_type := tape_file_attributes [tfa_rt].record_type;
        input_cycle_attribute_sources.record_type := tape_file_attributes [tfa_rt].source;

        { US/D, US/S, and US/V block and record combinations are supported on tape but not disk files.
        { Map these combinations to ones that are acceptable for a disk file should the output
        { file turn out to be a disk file; set up allowed device classes to prevent opening a
        { disk file.
        IF (input_cycle_attribute_values.block_type = amc$user_specified) THEN
          IF (input_cycle_attribute_values.record_type = amc$ansi_variable) OR
             (input_cycle_attribute_values.record_type = amc$ansi_spanned) OR
             (input_cycle_attribute_values.record_type = amc$variable) THEN
            device_dependent_info.adjust_default := TRUE;
            new_default_rt := amc$variable;
            new_default_bt := amc$system_specified;
            allowed_device_classes := -$fst$device_classes[fsc$mass_storage_device];
          IFEND;
        IFEND;
      IFEND;

      device_dependent_info.force_input_defaults := FALSE;
      set_output_default_creation_att (device_dependent_info, output_default_creation_ptr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      specified_options:=  $attachment_options[];
      delete_output_data:=FALSE;

      IF output_file_attachment <> NIL THEN
        attachment_count := UPPERBOUND (output_file_attachment^);
        FOR option := 1 to attachment_count DO
          CASE  output_file_attachment^[option].selector of
            = fsc$allowed_device_classes =
              specified_options := specified_options + $attachment_options[fsc$allowed_device_classes];
            = fsc$delete_data =
              delete_data_index := option;
              specified_options := specified_options + $attachment_options[fsc$delete_data];
              delete_output_data := output_file_attachment^[option].delete_data;
          ELSE
          CASEND;
        FOREND;
      ELSE
       attachment_count := 0;
      IFEND;
      { If allowed_device_classes was not specified by the caller and there would be
      { a conflict in record/block types when copying disk to tape or vice versa,
      { use allowed_device_classes to cause the open to fail, adjust the
      { default record/block type, and retry the open attempt.
      IF (allowed_device_classes <> -$fst$device_classes[]) AND
         NOT (fsc$allowed_device_classes IN specified_options) THEN
         PUSH output_file_attachment_options: [1 .. (attachment_count+1)];
         IF attachment_count > 0 THEN
           i#move (output_file_attachment, output_file_attachment_options, #SIZE (output_file_attachment^));
         IFEND;
         output_file_attachment_options^[attachment_count+1].selector := fsc$allowed_device_classes;
         output_file_attachment_options^[attachment_count+1].allowed_device_classes := allowed_device_classes;
      ELSEIF delete_output_data THEN
        PUSH output_file_attachment_options: [1 .. attachment_count];
        output_file_attachment_options^ := output_file_attachment^;
      ELSE
        output_file_attachment_options := output_file_attachment;
      IFEND;

      IF delete_output_data THEN
        { Defer the data deletion until after the open as a consideration to AAM.
        output_file_attachment_options^ [delete_data_index].delete_data := FALSE;
      IFEND;

      fsp$open_file (output, amc$record, output_file_attachment_options, output_default_creation_ptr,
            output_creation_attributes, output_attribute_validation, NIL, output_fid, status);
      IF NOT status.normal THEN
        IF (status.condition = fse$device_class_conflict) AND
           (allowed_device_classes <> -$fst$device_classes[]) AND
           NOT (fsc$allowed_device_classes IN specified_options) THEN
          { We are either copying tape->disk or disk->tape and there is
          { a possibility that the record/block type defaults are not appropriate.
          { Adjust them to affect the first instance of open of a new file.
          device_dependent_info.force_input_defaults := TRUE;
          IF device_dependent_info.adjust_default THEN
            device_dependent_info.block_type := new_default_bt;
            device_dependent_info.record_type := new_default_rt;
          IFEND;
          set_output_default_creation_att (device_dependent_info, output_default_creation_ptr, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          {Allow the open to succeed independent of device class.
          output_file_attachment_options^[attachment_count+1].selector:=fsc$null_attachment_option;
          fsp$open_file (output, amc$record, output_file_attachment_options, output_default_creation_ptr,
            output_creation_attributes, output_attribute_validation, NIL, output_fid, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          RETURN;
        IFEND;
      IFEND; {open succeeded; continue}

      fsp$get_open_information (output_fid, ^output_file_attachment_info, ^output_file_catalog_info, NIL,
            ^output_cycle_attribute_values, ^output_file_instance_info,
            ^control_information.output_resolved_file_reference, NIL, output_file_user_def_attr_size,
            status);
      IF NOT status.normal THEN
        IF status.condition = fse$file_contents_truncated THEN
          output_file_contents_truncated := TRUE;
          status.normal := TRUE;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      {Current byte address is used in determining whether a byte_move can be done}
      IF (input_file_catalog_info.cycle_registration.residence.device_class = rmc$mass_storage_device) AND
            (output_file_catalog_info.cycle_registration.residence.device_class = rmc$mass_storage_device)
            THEN
        IF output_cycle_attribute_values.file_organization IN amv$aam_file_organizations THEN
          output_initial_byte_address := 0;
        ELSE
          output_file_access_info [1].key := amc$current_byte_address;
          amp$fetch_access_information (output_fid, output_file_access_info, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          output_initial_byte_address := output_file_access_info [1].current_byte_address;
        IFEND;
      IFEND;

      IF output_file_catalog_info.cycle_registration.residence.device_class = rmc$magnetic_tape_device THEN

        tape_file_attributes [tfa_bt].key := amc$block_type;
        tape_file_attributes [tfa_cc].key := amc$character_conversion;
        tape_file_attributes [tfa_ic].key := amc$internal_code;
        tape_file_attributes [tfa_maxbl].key := amc$max_block_length;
        tape_file_attributes [tfa_maxrl].key := amc$max_record_length;
        tape_file_attributes [tfa_pc].key := amc$padding_character;
        tape_file_attributes [tfa_rt].key := amc$record_type;

        amp$fetch (output_fid, tape_file_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        output_cycle_attribute_values.block_type := tape_file_attributes [tfa_bt].block_type;
        output_cycle_attribute_values.character_conversion :=
              tape_file_attributes [tfa_cc].character_conversion;
        output_cycle_attribute_values.internal_code := tape_file_attributes [tfa_ic].internal_code;
        output_cycle_attribute_values.max_block_length := tape_file_attributes [tfa_maxbl].max_block_length;
        output_cycle_attribute_values.max_record_length := tape_file_attributes [tfa_maxrl].max_record_length;
        output_cycle_attribute_values.padding_character := tape_file_attributes [tfa_pc].padding_character;
        output_cycle_attribute_values.record_type := tape_file_attributes [tfa_rt].record_type;

      IFEND;

      get_type_of_copy (control_information.type_of_copy, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (control_information.type_of_copy = fsc$byte_move) OR
            (control_information.type_of_copy = fsc$v_to_t_record_conversion) THEN
        control_information.initial_byte_address := input_initial_byte_address;
        control_information.input_file_size := input_file_catalog_info.cycle_registration.size;

{ byte_move implies that the input and output file_organizations are the same.

        control_information.input_and_output_are_aam_files := (input_cycle_attribute_values.file_organization
              IN amv$aam_file_organizations);
      ELSEIF control_information.type_of_copy <> fsc$copy_keyed_file_move THEN
        calculate_record_info (control_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      {The following was added so that copy_file only deletes the output file if necessary.}
      {These restrictions (except size > 0) come from bam$open_file in its determination}
      {of whether to delete the data.  Keyed files recreate the header on the open if}
      {bam$open_file deletes the data.}
      IF delete_output_data AND
            (output_file_catalog_info.cycle_registration.residence.device_class = rmc$mass_storage_device) AND
            (output_file_catalog_info.cycle_registration.size > 0) AND
            (output_file_attachment_info.usage_information.concurrent_open_count = 1) AND
            (output_file_instance_info.attachment_information.open_position = amc$open_at_boi) AND
            (fsc$shorten IN output_file_instance_info.attachment_information.access_modes) AND
            (output_file_attachment_info.administration_information.attached_share_modes =
            $fst$file_access_options []) THEN
        delete_data (control_information.output_resolved_file_reference.
              path (1, control_information.output_resolved_file_reference.complete_path_size),
              output_fid, control_information.type_of_copy, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF (NOT file_contents_truncation_status.normal) AND (NOT output_file_contents_truncated) AND
            (input_cycle_attribute_values.file_contents = output_cycle_attribute_values.file_contents) THEN
        status := file_contents_truncation_status;
        status.condition := fse$output_structure_truncated;
      IFEND;

    END /open_and_get_type_of_copy/;

  PROCEND fsp$open_and_get_type_of_copy;

?? TITLE := 'PROCEDURE fsp$copy_data_and_close_files' ??
?? EJECT ??
*copyc fsh$copy_data_and_close_files
?? EJECT ??

  PROCEDURE [XDCL, #GATE] fsp$copy_data_and_close_files
    (    input_fid: amt$file_identifier;
         output_fid: amt$file_identifier;
         control_information: fst$copy_control_information;
     VAR status: ost$status);

    CONST
      maximum_byte_move_data_block = 80000(16),   {512K  =  524288
      {number of bytes that will be moved before an interrupt will be acknowledged}
      page_eject = '1', {page_eject carriage control}
      line_feed = ' ', {line_feed carriage control}
      triple_space = '-'; {triple_space carriage control}

    VAR
      p_scratch_segment: amt$segment_pointer;

?? NEWTITLE := '  PROCEDURE abort_handler ' ??
?? EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      delete_scratch_segment;

    PROCEND abort_handler;

?? TITLE := '  PROCEDURE delete_scratch_segment' ??
?? EJECT ??

    PROCEDURE [INLINE] delete_scratch_segment;

      VAR
        local_status: ost$status,
        ignore_status: ost$status;

      IF p_scratch_segment.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (p_scratch_segment, local_status); {a NIL pointer is returned.}
        IF NOT local_status.normal THEN
          IF NOT status.normal THEN
            osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
          ELSE
            status := local_status;
          IFEND;
        IFEND;
      IFEND;

    PROCEND delete_scratch_segment;

?? TITLE := '  PROCEDURE set_status_internal_error' ??
?? EJECT ??

    PROCEDURE set_status_internal_error
      (    error_number: ost$non_negative_integers;
       VAR status: ost$status);

      VAR
        status_text: string (osc$max_string_size),
        text_length: integer;

      STRINGREP (status_text, text_length, 'detected error #', error_number,
            ' in fsp$copy_data_and_close_files');
      fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
            path (1, control_information.input_resolved_file_reference.cycle_path_size),
            fse$copy_internal_error, fsc$copy_file_req, status_text (1, text_length), status);

    PROCEND set_status_internal_error;

?? TITLE := '  PROCEDURE close_files' ??
?? EJECT ??

    PROCEDURE close_files
      (VAR status: ost$status);

      VAR
        close_status: ost$status;

      fsp$close_file (input_fid, close_status);
      IF (NOT close_status.normal) AND status.normal THEN
        status := close_status;
      IFEND;
      fsp$close_file (output_fid, close_status);
      IF (NOT close_status.normal) AND status.normal THEN
        status := close_status;
      IFEND;

    PROCEND close_files;
?? TITLE := '  PROCEDURE perform_v_to_t_conversion ' ??
?? EJECT ??

    PROCEDURE perform_v_to_t_conversion
      (    control_information: fst$copy_control_information;
       VAR status: ost$status);

      VAR
        context: ^ost$ecp_exception_context,
        last_move: boolean,
        file_size_source: amt$file_byte_address,
        current_byte_source: amt$file_byte_address,
        current_byte_destination: amt$file_byte_address;

      status.normal := TRUE;
      context := NIL;
      current_byte_source := control_information.initial_byte_address;
      current_byte_destination := current_byte_source;
      file_size_source := control_information.input_file_size;
      last_move := FALSE;

{ call bap$v_to_t_record_conversion to convert the file.

      WHILE (NOT last_move) AND status.normal DO
        REPEAT
          bap$v_to_t_record_conversion (input_fid, output_fid, file_size_source, current_byte_source,
                current_byte_destination, last_move, status);
          IF NOT status.normal THEN
            IF context = NIL THEN
              PUSH context;
              context^ := osv$initial_exception_context;
              context^.file.selector := osc$ecp_file_identifier;
            IFEND;
            context^.condition_status := status;
            context^.file.file_identifier := input_fid;
            osp$enforce_exception_policies (context^);
            IF context^.condition_status.normal THEN
              context^.file.file_identifier := output_fid;
              osp$enforce_exception_policies (context^);
              status := context^.condition_status;
            ELSE
              status := context^.condition_status;
            IFEND;
          IFEND;
        UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
      WHILEND;

    PROCEND perform_v_to_t_conversion;
?? TITLE := '  PROCEDURE perform_byte_move ' ??
?? EJECT ??

    PROCEDURE perform_byte_move
      (    control_information: fst$copy_control_information;
       VAR status: ost$status);

      VAR
        context: ^ost$ecp_exception_context,
        number_of_bytes_to_move: amt$file_byte_address,
        current_byte_address: amt$file_byte_address,
        last_move: boolean;

      status.normal := TRUE;
      context := NIL;
      current_byte_address := control_information.initial_byte_address;

      last_move := (current_byte_address >= control_information.input_file_size);
      number_of_bytes_to_move := maximum_byte_move_data_block;

      WHILE (NOT last_move) AND status.normal DO
        IF (current_byte_address + number_of_bytes_to_move) >= control_information.input_file_size THEN
          number_of_bytes_to_move := control_information.input_file_size - current_byte_address;
          last_move := TRUE;
        IFEND;
        REPEAT
          bap$byte_move (input_fid, output_fid, number_of_bytes_to_move, last_move, current_byte_address,
                status);
          IF NOT status.normal THEN
            IF context = NIL THEN
              PUSH context;
              context^ := osv$initial_exception_context;
              context^.file.selector := osc$ecp_file_identifier;
            IFEND;
            context^.condition_status := status;
            context^.file.file_identifier := input_fid;
            osp$enforce_exception_policies (context^);
            IF context^.condition_status.normal THEN
              context^.file.file_identifier := output_fid;
              osp$enforce_exception_policies (context^);
              status := context^.condition_status;
            ELSE
              status := context^.condition_status;
            IFEND;
          IFEND;
        UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
      WHILEND;

      IF control_information.input_and_output_are_aam_files THEN
        change_to_public_lock_file (output_fid);
      IFEND;

    PROCEND perform_byte_move;

?? TITLE := '  PROCEDURE perform_copy_keyed_file_move' ??
?? EJECT ??

    PROCEDURE perform_copy_keyed_file_move
      (    control_information: fst$copy_control_information;
       VAR status: ost$status);

      CONST
        command_part_1 = '$system.copy_keyed_file input=',
        command_part_1_size = 30,
        command_part_2 = ' output=',
        command_part_2_size = 8;

      VAR
        copy_keyed_file_command_ptr: ^string ( * ),
        command_index: integer;

      close_files (status);
      IF status.normal THEN
        PUSH copy_keyed_file_command_ptr: [command_part_1_size + command_part_2_size +
              control_information.input_resolved_file_reference.complete_path_size +
              control_information.output_resolved_file_reference.complete_path_size];
        copy_keyed_file_command_ptr^ (1, command_part_1_size) := command_part_1;
        command_index := command_part_1_size + 1;
        copy_keyed_file_command_ptr^ (command_index, control_information.input_resolved_file_reference.
              complete_path_size) := control_information.input_resolved_file_reference.
              path (1, control_information.input_resolved_file_reference.complete_path_size);
        command_index := command_index + control_information.input_resolved_file_reference.complete_path_size;
        copy_keyed_file_command_ptr^ (command_index, command_part_2_size) := command_part_2;
        command_index := command_index + command_part_2_size;
        copy_keyed_file_command_ptr^ (command_index, control_information.output_resolved_file_reference.
              complete_path_size) := control_information.output_resolved_file_reference.
              path (1, control_information.output_resolved_file_reference.complete_path_size);
        clp$include_line (copy_keyed_file_command_ptr^, FALSE, osc$null_name, status);
      IFEND;

    PROCEND perform_copy_keyed_file_move;

?? TITLE := '  PROCEDURE perform_record_move ' ??
?? EJECT ??

    PROCEDURE perform_record_move
      (    control_information: fst$copy_control_information;
           working_storage_area: ^array [1 .. * ] of char;
       VAR status: ost$status);

      VAR
        ignore_byte_address: amt$file_byte_address,
        file_position: amt$file_position,
        current_record_length: amt$max_record_length,
        transfer_count: amt$transfer_count,
        truncation: boolean,
        first_loop: boolean;

      file_position := amc$boi;
      truncation := FALSE;
      first_loop := TRUE;

      REPEAT
        CASE file_position OF
        = amc$boi, amc$eor, amc$bop, amc$eop =
          amp$get_next (input_fid, working_storage_area, control_information.working_storage_length,
                transfer_count, ignore_byte_address, file_position, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF first_loop THEN
            first_loop := FALSE;
            IF file_position = amc$eoi THEN
              IF control_information.input_file_device_class = rmc$magnetic_tape_device THEN
                fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                      path (1, control_information.input_resolved_file_reference.cycle_path_size),
                      ame$input_after_eoi, fsc$copy_file_req, '', status);
              ELSE
                fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                      path (1, control_information.input_resolved_file_reference.cycle_path_size),
                      fse$empty_input_file, fsc$copy_file_req, '', status);
              IFEND;
            IFEND;
          IFEND; {first_loop}
          CASE file_position OF
          = amc$mid_record =
            IF control_information.output_record_length_is_fixed AND
                  (transfer_count >= control_information.output_record_length) THEN
              truncation := TRUE;
              file_position := amc$eor;
              amp$put_next (output_fid, working_storage_area, control_information.output_record_length,
                    ignore_byte_address, status);
            ELSE
              amp$put_partial (output_fid, working_storage_area, transfer_count, ignore_byte_address,
                    amc$start, status);
            IFEND;
          = amc$eor =
            IF control_information.output_record_length_is_fixed AND
                  (transfer_count > control_information.output_record_length) THEN
              truncation := TRUE;
              amp$put_next (output_fid, working_storage_area, control_information.output_record_length,
                    ignore_byte_address, status);
            ELSE
              amp$put_next (output_fid, working_storage_area, transfer_count, ignore_byte_address, status);
            IFEND;
          = amc$eop =
            IF control_information.output_can_be_partitioned THEN
              amp$write_end_partition (output_fid, status);
            IFEND;
          = amc$eoi =
          ELSE
            set_status_internal_error (7, status);
          CASEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        = amc$mid_record =
          amp$get_partial (input_fid, working_storage_area, control_information.working_storage_length,
                current_record_length, transfer_count, ignore_byte_address, file_position, amc$no_skip,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF control_information.output_record_length_is_fixed AND
                (current_record_length > control_information.output_record_length) THEN
            truncation := TRUE;
            file_position := amc$eor;
            {The following line causes copy_file to truncate output record.}
            {This is needed because to rt=u bt=us a put will error rather               than truncate}
            transfer_count := transfer_count - (current_record_length -
                  control_information.output_record_length);
          IFEND;
          CASE file_position OF
          = amc$mid_record =
            amp$put_partial (output_fid, working_storage_area, transfer_count, ignore_byte_address,
                  amc$continue, status);
          = amc$eor =
            amp$put_partial (output_fid, working_storage_area, transfer_count, ignore_byte_address,
                  amc$terminate, status);
          ELSE
            set_status_internal_error (8, status);
          CASEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        = amc$eoi =
        ELSE { a file position error would have occurred in inner case statements if at all. }
        CASEND;

      UNTIL file_position = amc$eoi;

      IF truncation THEN
        fsp$set_file_reference_abnormal (control_information.output_resolved_file_reference.
              path (1, control_information.output_resolved_file_reference.cycle_path_size),
              fse$output_record_truncated, fsc$copy_file_req, '', status);
      IFEND;

    PROCEND perform_record_move;
?? TITLE := '  PROCEDURE perform_legible_to_list_move' ??
?? EJECT ??

    PROCEDURE perform_legible_to_list_move
      (    control_information: fst$copy_control_information;
           working_storage_area: ^array [1 .. * ] of char;
       VAR status: ost$status);

      VAR
        ignore_byte_address: amt$file_byte_address,
        file_position: amt$file_position,
        current_record_length: amt$max_record_length,
        transfer_count: amt$transfer_count,
        truncation: boolean,
        page_control: char,
        line_number: ost$non_negative_integers,
        first_loop: boolean;

      CASE control_information.page_format OF
      = amc$burstable_form, amc$non_burstable_form =
        page_control := page_eject;
      ELSE
        page_control := line_feed;
      CASEND;

      file_position := amc$boi;
      truncation := FALSE;
      first_loop := TRUE;

      REPEAT
        CASE file_position OF
        = amc$boi, amc$eor, amc$bop, amc$eop =
          amp$get_next (input_fid, ^working_storage_area^ [2], control_information.working_storage_length - 1,
                transfer_count, ignore_byte_address, file_position, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF first_loop THEN
            first_loop := FALSE;
            IF file_position = amc$eoi THEN
              IF control_information.input_file_device_class = rmc$magnetic_tape_device THEN
                fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                      path (1, control_information.input_resolved_file_reference.cycle_path_size),
                      ame$input_after_eoi, fsc$copy_file_req, '', status);
              ELSE
                fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                      path (1, control_information.input_resolved_file_reference.cycle_path_size),
                      fse$empty_input_file, fsc$copy_file_req, '', status);
              IFEND;
            IFEND;
            line_number := 1;
            CASE control_information.page_format OF
            = amc$burstable_form, amc$non_burstable_form =
              working_storage_area^ [1] := page_eject;
            = amc$continuous_form =
              working_storage_area^ [1] := triple_space;
            ELSE
              working_storage_area^ [1] := line_feed;
            CASEND;
          ELSE {first_loop}
            IF line_number = control_information.page_length THEN
              line_number := 1;
              working_storage_area^ [1] := page_control;
            ELSE
              line_number := line_number + 1;
              working_storage_area^ [1] := line_feed;
            IFEND;
          IFEND; {first_loop}
          transfer_count := transfer_count + 1; {Adjust for format effector}
          CASE file_position OF
          = amc$mid_record =
            IF control_information.output_record_length_is_fixed AND
                  (transfer_count >= control_information.output_record_length) THEN
              truncation := TRUE;
              file_position := amc$eor;
              amp$put_next (output_fid, working_storage_area, control_information.output_record_length,
                    ignore_byte_address, status);
            ELSE
              amp$put_partial (output_fid, working_storage_area, transfer_count, ignore_byte_address,
                    amc$start, status);
            IFEND;
          = amc$eor =
            IF control_information.output_record_length_is_fixed AND
                  (transfer_count > control_information.output_record_length) THEN
              truncation := TRUE;
              amp$put_next (output_fid, working_storage_area, control_information.output_record_length,
                    ignore_byte_address, status);
            ELSE
              amp$put_next (output_fid, working_storage_area, transfer_count, ignore_byte_address, status);
            IFEND;
          = amc$eop =
            IF control_information.output_can_be_partitioned THEN
              amp$write_end_partition (output_fid, status);
            IFEND;
          = amc$eoi =
          ELSE
            set_status_internal_error (9, status);
          CASEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        = amc$mid_record =
          amp$get_partial (input_fid, working_storage_area, control_information.working_storage_length,
                current_record_length, transfer_count, ignore_byte_address, file_position, amc$no_skip,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          current_record_length := current_record_length + 1; {Adjust for format effector}
          IF control_information.output_record_length_is_fixed AND
                (current_record_length > control_information.output_record_length) THEN
            truncation := TRUE;
            file_position := amc$eor;
            {The following line causes copy_file to truncate output record.}
            {This is needed because to rt=u bt=us a put will error rather               than truncate}
            transfer_count := transfer_count - (current_record_length -
                  control_information.output_record_length);
          IFEND;
          CASE file_position OF
          = amc$mid_record =
            amp$put_partial (output_fid, working_storage_area, transfer_count, ignore_byte_address,
                  amc$continue, status);
          = amc$eor =
            amp$put_partial (output_fid, working_storage_area, transfer_count, ignore_byte_address,
                  amc$terminate, status);
          ELSE
            set_status_internal_error (10, status);
          CASEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        = amc$eoi =
        ELSE { a file position error would have occurred in inner case statements if at all. }
        CASEND;

      UNTIL file_position = amc$eoi;

      IF truncation THEN
        fsp$set_file_reference_abnormal (control_information.output_resolved_file_reference.
              path (1, control_information.output_resolved_file_reference.cycle_path_size),
              fse$output_record_truncated, fsc$copy_file_req, '', status);
      IFEND;

    PROCEND perform_legible_to_list_move;
?? TITLE := '  PROCEDURE perform_list_to_legible_move' ??
?? EJECT ??

    PROCEDURE perform_list_to_legible_move
      (    control_information: fst$copy_control_information;
           working_storage_area: ^array [1 .. * ] of char;
       VAR status: ost$status);

      VAR
        ignore_byte_address: amt$file_byte_address,
        file_position: amt$file_position,
        current_record_length: amt$max_record_length,
        transfer_count: amt$transfer_count,
        truncation: boolean,
        first_loop: boolean;

      file_position := amc$boi;
      truncation := FALSE;
      first_loop := TRUE;

      REPEAT
        CASE file_position OF
        = amc$boi, amc$eor, amc$bop, amc$eop =
          amp$get_next (input_fid, working_storage_area, control_information.working_storage_length,
                transfer_count, ignore_byte_address, file_position, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF first_loop THEN
            first_loop := FALSE;
            IF file_position = amc$eoi THEN
              IF control_information.input_file_device_class = rmc$magnetic_tape_device THEN
                fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                      path (1, control_information.input_resolved_file_reference.cycle_path_size),
                      ame$input_after_eoi, fsc$copy_file_req, '', status);
              ELSE
                fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                      path (1, control_information.input_resolved_file_reference.cycle_path_size),
                      fse$empty_input_file, fsc$copy_file_req, '', status);
              IFEND;
            IFEND;
          IFEND; {first_loop}
          IF transfer_count > 0 THEN
            transfer_count := transfer_count - 1; {Adjust for loss of format effector}
          IFEND;
          CASE file_position OF
          = amc$mid_record =
            IF control_information.output_record_length_is_fixed AND
                  (transfer_count >= control_information.output_record_length) THEN
              truncation := TRUE;
              file_position := amc$eor;
              amp$put_next (output_fid, ^working_storage_area^ [2], control_information.output_record_length,
                    ignore_byte_address, status);
            ELSE
              amp$put_partial (output_fid, ^working_storage_area^ [2], transfer_count, ignore_byte_address,
                    amc$start, status);
            IFEND;
          = amc$eor =
            IF control_information.output_record_length_is_fixed AND
                  (transfer_count > control_information.output_record_length) THEN
              truncation := TRUE;
              amp$put_next (output_fid, ^working_storage_area^ [2], control_information.output_record_length,
                    ignore_byte_address, status);
            ELSE
              amp$put_next (output_fid, ^working_storage_area^ [2], transfer_count, ignore_byte_address,
                    status);
            IFEND;
          = amc$eop =
            IF control_information.output_can_be_partitioned THEN
              amp$write_end_partition (output_fid, status);
            IFEND;
          = amc$eoi =
          ELSE
            set_status_internal_error (11, status);
          CASEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        = amc$mid_record =
          amp$get_partial (input_fid, working_storage_area, control_information.working_storage_length,
                current_record_length, transfer_count, ignore_byte_address, file_position, amc$no_skip,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          current_record_length := current_record_length - 1; {Adjusted for loss of format effector}
          IF control_information.output_record_length_is_fixed AND
                (current_record_length > control_information.output_record_length) THEN
            truncation := TRUE;
            file_position := amc$eor;
            {The following line causes copy_file to truncate output record.}
            {This is needed because to rt=u bt=us a put will error rather         than truncate}
            transfer_count := transfer_count - (current_record_length -
                  control_information.output_record_length);
          IFEND;
          CASE file_position OF
          = amc$mid_record =
            amp$put_partial (output_fid, working_storage_area, transfer_count, ignore_byte_address,
                  amc$continue, status);
          = amc$eor =
            amp$put_partial (output_fid, working_storage_area, transfer_count, ignore_byte_address,
                  amc$terminate, status);
          ELSE
            set_status_internal_error (12, status);
          CASEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        = amc$eoi =
        ELSE { a file position error would have occurred in inner case statements if at all. }
        CASEND;

      UNTIL file_position = amc$eoi;

      IF truncation THEN
        fsp$set_file_reference_abnormal (control_information.output_resolved_file_reference.
              path (1, control_information.output_resolved_file_reference.cycle_path_size),
              fse$output_record_truncated, fsc$copy_file_req, '', status);
      IFEND;

    PROCEND perform_list_to_legible_move;
?? TITLE := '  PROCEDURE perform_undefined_ss_move' ??
?? EJECT ??

    PROCEDURE perform_undefined_ss_move
      (    control_information: fst$copy_control_information;
           working_storage_area: ^array [1 .. * ] of char;
       VAR status: ost$status);

      VAR
        ignore_byte_address: amt$file_byte_address,
        file_position: amt$file_position,
        current_record_length: amt$max_record_length,
        transfer_count: amt$transfer_count;

      amp$get_next (input_fid, working_storage_area, control_information.working_storage_length,
            transfer_count, ignore_byte_address, file_position, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF file_position = amc$eoi THEN
        IF control_information.input_file_device_class = rmc$magnetic_tape_device THEN
          fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                path (1, control_information.input_resolved_file_reference.cycle_path_size),
                ame$input_after_eoi, fsc$copy_file_req, '', status);
        ELSE
          fsp$set_file_reference_abnormal (control_information.input_resolved_file_reference.
                path (1, control_information.input_resolved_file_reference.cycle_path_size),
                fse$empty_input_file, fsc$copy_file_req, '', status);
        IFEND;
      IFEND;

      IF NOT control_information.push_overflow THEN
        WHILE file_position <> amc$eoi DO
          amp$put_next (output_fid, working_storage_area, transfer_count, ignore_byte_address, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          amp$get_next (input_fid, working_storage_area, control_information.working_storage_length,
                transfer_count, ignore_byte_address, file_position, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        WHILEND;
      ELSE
        current_record_length := 0;
        WHILE file_position <> amc$eoi DO
          IF current_record_length = 0 THEN
            amp$put_partial (output_fid, working_storage_area, transfer_count, ignore_byte_address, amc$start,
                  status);
          ELSE
            amp$put_partial (output_fid, working_storage_area, transfer_count, ignore_byte_address,
                  amc$continue, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          current_record_length := current_record_length + transfer_count;
          IF current_record_length = control_information.output_record_length THEN
            amp$get_next (input_fid, working_storage_area, control_information.working_storage_length,
                  transfer_count, ignore_byte_address, file_position, status);
            current_record_length := 0;
          ELSEIF (current_record_length + control_information.working_storage_length) >=
                control_information.output_record_length THEN
            amp$get_next (input_fid, working_storage_area, control_information.output_record_length -
                  current_record_length, transfer_count, ignore_byte_address, file_position, status);
          ELSE
            amp$get_next (input_fid, working_storage_area, control_information.working_storage_length,
                  transfer_count, ignore_byte_address, file_position, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        WHILEND;
      IFEND;

    PROCEND perform_undefined_ss_move;
?? OLDTITLE ??
?? EJECT ??

    VAR
      working_storage_area: ^array [1 .. * ] of char;

  /copy_data_and_close_files/
    BEGIN

      status.normal := TRUE;

      CASE control_information.type_of_copy OF
      = fsc$v_to_t_record_conversion =
        perform_v_to_t_conversion (control_information, status);
      = fsc$byte_move =
        perform_byte_move (control_information, status);
      = fsc$copy_keyed_file_move =
        perform_copy_keyed_file_move (control_information, status);
      = fsc$record_move, fsc$legible_to_list_move, fsc$list_to_legible_move, fsc$undefined_ss_move =
        IF control_information.working_storage_length <= fsc$maximum_copy_file_push THEN
          PUSH working_storage_area: [1 .. control_information.working_storage_length];
          CASE control_information.type_of_copy OF
          = fsc$record_move =
            perform_record_move (control_information, working_storage_area, status);
          = fsc$legible_to_list_move =
            perform_legible_to_list_move (control_information, working_storage_area, status);
          = fsc$list_to_legible_move =
            perform_list_to_legible_move (control_information, working_storage_area, status);
          = fsc$undefined_ss_move =
            perform_undefined_ss_move (control_information, working_storage_area, status);
          ELSE {impossible to go through ELSE}
          CASEND;
        ELSE {use scratch segment when wsl > fsc$maximum_copy_file_push}
          {A scratch segment is used because push is limited to the task's stack size; this}
          {is important in the case of LRT where maxbl can be 2 megabytes or even greater.}

        /use_scratch_segment/
          BEGIN
            p_scratch_segment.sequence_pointer := NIL;
            osp$establish_block_exit_hndlr (^abort_handler);
            mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, p_scratch_segment, status);
            IF NOT status.normal THEN
              EXIT /use_scratch_segment/;
            IFEND;
            RESET p_scratch_segment.sequence_pointer;
            NEXT working_storage_area: [1 .. control_information.working_storage_length] IN
                  p_scratch_segment.sequence_pointer;
            IF working_storage_area = NIL THEN {User not validated for file that large, but}
              set_status_internal_error (13, status); {this should have been caught in open}
              EXIT /use_scratch_segment/;
            IFEND;
            CASE control_information.type_of_copy OF
            = fsc$record_move =
              perform_record_move (control_information, working_storage_area, status);
            = fsc$legible_to_list_move =
              perform_legible_to_list_move (control_information, working_storage_area, status);
            = fsc$list_to_legible_move =
              perform_list_to_legible_move (control_information, working_storage_area, status);
            = fsc$undefined_ss_move =
              perform_undefined_ss_move (control_information, working_storage_area, status);
            ELSE {impossible to go through ELSE}
            CASEND;
          END /use_scratch_segment/;
          delete_scratch_segment;
          osp$disestablish_cond_handler;
        IFEND;
      ELSE
        set_status_internal_error (14, status);
      CASEND;

      IF (control_information.type_of_copy <> fsc$copy_keyed_file_move) THEN
        close_files (status);
      IFEND;
    END /copy_data_and_close_files/;

  PROCEND fsp$copy_data_and_close_files;

?? OLDTITLE ??

MODEND fsm$copy_file;
*DECK DECK=FSM$CREATE_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : File System : Create File' ??
MODULE fsm$create_file;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fsk$keypoints
*copyc fst$file_reference
?? POP ??
*copyc bap$create_file
*copyc fsp$evaluate_file_for_creation
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition

*copyc osv$initial_exception_context

?? TITLE := 'PROCEDURE [XDCL, #GATE] fsp$create_file', EJECT ??

  PROCEDURE [XDCL, #GATE] fsp$create_file
    (    file: fst$file_reference;
         attachment_options: ^fst$attachment_options;
         cycle_attributes: ^fst$file_cycle_attributes;
         device_attributes: ^fst$device_attributes;
         file_attributes: ^fst$file_attributes;
     VAR resolved_path: fst$path;
     VAR status: ost$status);

    CONST
      command_file_reference_allowed = TRUE;

    VAR
      context: ^ost$ecp_exception_context,
      evaluated_file_reference: fst$evaluated_file_reference,
      local_status: ost$status;

    #KEYPOINT (osk$entry, 0, fsk$create_file);
    local_status.normal := TRUE;
    status.normal := TRUE;
    context := NIL;

  /create_file/
    BEGIN
      fsp$evaluate_file_for_creation (file, NOT command_file_reference_allowed,
            evaluated_file_reference, local_status);
      IF NOT local_status.normal THEN
        EXIT /create_file/;
      IFEND;

      REPEAT
        bap$create_file (attachment_options, cycle_attributes, file_attributes, device_attributes,
              evaluated_file_reference, resolved_path, local_status);
        IF osp$file_access_condition (local_status) THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_evaluated_file_ref;
            context^.file.evaluated_file_reference := evaluated_file_reference;
          IFEND;
          context^.condition_status := local_status;
          osp$enforce_exception_policies (context^);
          local_status := context^.condition_status;
        IFEND;
      UNTIL local_status.normal OR (NOT osp$file_access_condition (local_status)) OR (NOT context^.wait);
    END /create_file/;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, fsk$create_file);

  PROCEND fsp$create_file;

MODEND fsm$create_file;
*DECK DECK=FSM$DEFAULT_TAPE_LABEL_ATTRIB EXPAND=TRUE
?? RIGHT := 110 ??

MODULE fsm$default_tape_label_attrib;

?? PUSH (LISTEXT := ON) ??
*copyc ame$tape_program_actions
*copyc fst$ansi_eof1_label
*copyc fst$ansi_eof2_label
*copyc fst$ansi_hdr1_label
*copyc fst$ansi_hdr2_label
*copyc fst$ansi_vol1_label
*copyc fst$attachment_options
*copyc fst$tape_label_sequence_header
*copyc fst$tape_label_block_descriptor
*copyc fst$tla_default_source
*copyc fst$tla_returned_attributes
*copyc osd$integer_limits
*copyc ost$status
?? POP ??
*copyc bap$set_file_reference_abnormal
*copyc pmp$get_date
*copyc fmv$tape_attachment_information

  VAR
    attributes_without_defaults: [READ, oss$job_paged_literal] fst$tla_returned_attributes :=
          [fsc$tape_file_identifier, fsc$tape_null_attachment_option, fsc$tape_removable_media_group,
          fsc$tape_label_standard_version, fsc$tape_implementation_id, fsc$tape_file_section_number],

    eof1_label_default: [READ, oss$job_paged_literal] fst$ansi_eof1_label := [
      {label_identifier}          'EOF',
      {label_number}              '1',
      {file_identifier}           ' ',
      {file_set_identifier}       ' ',
      {file_section_number}       '0001',
      {file_sequence_number}      '0001',
      {generation_number}         '0001',
      {generation_version_number} '00',
      {creation_date}             ' ',
      {expiration_date}           ' ',
      {accessibility}             ' ',
      {block_count}               '000000',
      {system_code}               ' ',
      {reserved_to_ansi}          ' '],

    eof2_label_default: [READ, oss$job_paged_literal] fst$ansi_eof2_label := [TRUE,
      {label_identifier}          'EOF',
      {label_number}              '2',
      {record_format}             ' ',
      {block_length}              '00000',
      {record_length}             '00000',
      {ve_block_type}             'SS',
      {ve_record_type}            'V',
      {ve_block_length_ext}       '000',
      {ve_record_length_ext}      '000',
      {ve_padding_character}      ' ',
      {ve_character_set}          'A',
      {ve_character_conversion}   'F',
      {ve_reserved}               ' ',
      {buffer_offset_length}      '00',
      {reserved_to_ansi}          ' '],

    hdr1_label_default: [READ, oss$job_paged_literal] fst$ansi_hdr1_label := [
      {label_identifier}          'HDR',
      {label_number}              '1',
      {file_identifier}           ' ',
      {file_set_identifier}       ' ',
      {file_section_number}       '0001',
      {file_sequence_number}      '0001',
      {generation_number}         '0001',
      {generation_version_number} '00',
      {creation_date}             ' ',
      {expiration_date}           ' ',
      {accessibility}             ' ',
      {block_count}               '000000',
      {system_code}               'NOS/VE V2.0',
      {reserved_to_ansi}          ' '],

    hdr2_label_default: [READ, oss$job_paged_literal] fst$ansi_hdr2_label := [TRUE,
      {label_identifier}          'HDR',
      {label_number}              '2',
      {record_format}             ' ',
      {block_length}              '00000',
      {record_length}             '00000',
      {ve_block_type}             'SS',
      {ve_record_type}            'V',
      {ve_block_length_ext}       '000',
      {ve_record_length_ext}      '000',
      {ve_padding_character}      ' ',
      {ve_character_set}          'A',
      {ve_character_conversion}   'F',
      {ve_reserved}               ' ',
      {buffer_offset_length}      '00',
      {reserved_to_ansi}          ' '],

    vol1_label_default: [READ, oss$job_paged_literal] fst$ansi_vol1_label := [
      {label_identifier}          'VOL',
      {label_number}              '1',
      {volume_identifier}         ' ',
      {accessibility}             'A',
      {reserved_to_ansi1}         ' ',
      {implementation_identifier} 'NOS/VE V2.0',
      {owner_identifier}          ' ',
      {reserved_to_ansi2}         ' ',
      {label_standard_version}    '4'];

?? TITLE := 'PROCEDURE fsp$default_tape_label_attrib', EJECT ??
*copy fsh$default_tape_label_attrib

  PROCEDURE [XDCL, #GATE] fsp$default_tape_label_attrib
    (    source: fst$tla_default_source;
     VAR attributes: fst$attachment_options;
     VAR returned_attributes: fst$tla_returned_attributes;
     VAR status: ost$status);

?? NEWTITLE := 'next_block_descriptor', EJECT ??
    PROCEDURE [INLINE] next_block_descriptor
      (    label_kind: fst$ansi_label_kind);

      CONST
        normal_label_size = 80;

      NEXT label_block_descriptor IN label_sequence;
      label_block_descriptor^.label_block_type := fsc$normal_tape_label_block;
      label_block_descriptor^.normal_label_actual_length := normal_label_size;
      label_block_descriptor^.normal_label_character_set := amc$ascii;
      label_block_descriptor^.normal_label_kind := label_kind;
      label_block_descriptor^.normal_label_transfer_length := normal_label_size;

    PROCEND next_block_descriptor;
?? OLDTITLE, EJECT ??

    VAR
      date: ost$date,
      default_attributes: fst$tape_attachment_information,
      eof1_block: ^fst$ansi_eof1_label,
      eof2_block: ^fst$ansi_eof2_label,
      hdr1_block: ^fst$ansi_hdr1_label,
      hdr2_block: ^fst$ansi_hdr2_label,
      header_labels_sequence_size: ost$positive_integers,
      index: ost$positive_integers,
      label_block_descriptor: ^fst$tape_label_block_descriptor,
      label_sequence: ^SEQ ( * ),
      label_sequence_header: ^fst$tape_label_sequence_header,
      return_attribute: boolean,
      trailer_labels_sequence_size: ost$positive_integers,
      vol1_block: ^fst$ansi_vol1_label;

    status.normal := TRUE;

    returned_attributes := $fst$tla_returned_attributes [];

    IF source = fsc$tla_system_default THEN
      default_attributes := fmv$tape_attachment_information;
    ELSE
      RETURN;
    IFEND;

    FOR index := 1 TO UPPERBOUND (attributes) DO
      IF attributes [index].selector = fsc$tape_attachment THEN
        return_attribute := TRUE;
        CASE attributes [index].tape_attachment.selector OF
        = fsc$tape_block_type =
          attributes [index].tape_attachment.tape_block_type := default_attributes.block_type;

        = fsc$tape_buffer_offset =
          attributes [index].tape_attachment.tape_buffer_offset := default_attributes.buffer_offset;

        = fsc$tape_character_conversion =
          attributes [index].tape_attachment.tape_character_conversion :=
                default_attributes.character_conversion;

        = fsc$tape_character_set =
          attributes [index].tape_attachment.tape_character_set := default_attributes.character_set;

        = fsc$tape_creation_date =
          pmp$get_date (osc$ordinal_date, date, status);
          attributes [index].tape_attachment.tape_creation_date := date.ordinal;

        = fsc$tape_expiration_date =
          pmp$get_date (osc$ordinal_date, date, status);
          attributes [index].tape_attachment.tape_expiration_date := date.ordinal;

        = fsc$tape_file_accessibility =
          attributes [index].tape_attachment.tape_file_accessibility := default_attributes.file_accessibility;

        = fsc$tape_file_sequence_number =
          attributes [index].tape_attachment.tape_file_sequence_number :=
                default_attributes.file_sequence_number;

        = fsc$tape_file_set_identifier =
          attributes [index].tape_attachment.tape_file_set_identifier :=
                default_attributes.file_set_identifier;

        = fsc$tape_file_set_position =
          attributes [index].tape_attachment.tape_file_set_position := default_attributes.file_set_position;

        = fsc$tape_generation_number =
          attributes [index].tape_attachment.tape_generation_number := default_attributes.generation_number;

        = fsc$tape_generation_version_num =
          attributes [index].tape_attachment.tape_generation_version_num :=
                default_attributes.generation_version_number;

        = fsc$tape_header_labels =
          IF attributes [index].tape_attachment.tape_header_labels <> NIL THEN
            label_sequence := attributes [index].tape_attachment.tape_header_labels;
            RESET label_sequence;
            header_labels_sequence_size := #SIZE (fst$tape_label_sequence_header) +
                  (4 * #SIZE (fst$tape_label_block_descriptor)) + #SIZE (fst$ansi_vol1_label) +
                  #SIZE (fst$ansi_hdr1_label) + #SIZE (fst$ansi_hdr2_label);
            IF #SIZE (label_sequence^) >= header_labels_sequence_size THEN
              NEXT label_sequence_header IN label_sequence;
              label_sequence_header^.character_set := amc$ascii;
              label_sequence_header^.label_kinds := $fst$ansi_label_kinds [fsc$ansi_vol1_label_kind,
                    fsc$ansi_hdr1_label_kind, fsc$ansi_hdr2_label_kind];
              label_sequence_header^.sequence_size := header_labels_sequence_size;
              label_sequence_header^.label_count := 4;

              next_block_descriptor (fsc$ansi_vol1_label_kind);
              NEXT vol1_block IN label_sequence;
              vol1_block^ := vol1_label_default;

              next_block_descriptor (fsc$ansi_hdr1_label_kind);
              NEXT hdr1_block IN label_sequence;
              hdr1_block^ := hdr1_label_default;
              pmp$get_date (osc$ordinal_date, date, status);
              IF date.ordinal (1, 2) <> '19' THEN
                hdr1_block^.creation_date (1, 1) := date.ordinal (2, 1);
                hdr1_block^.expiration_date (1, 1) := date.ordinal (2, 1);
              IFEND;
              hdr1_block^.creation_date (2, 5) := date.ordinal (3, 5);
              hdr1_block^.expiration_date (2, 5) := date.ordinal (3, 5);

              next_block_descriptor (fsc$ansi_hdr2_label_kind);
              NEXT hdr2_block IN label_sequence;
              hdr2_block^ := hdr2_label_default;

              NEXT label_block_descriptor IN label_sequence;
              label_block_descriptor^.label_block_type := fsc$tapemark_tape_label_block;
            ELSE
              IF #SIZE (label_sequence^) >= #SIZE (fst$tape_label_sequence_header) THEN
                NEXT label_sequence_header IN label_sequence;
                label_sequence_header^.character_set := amc$ascii;
                label_sequence_header^.label_kinds := $fst$ansi_label_kinds [];
                label_sequence_header^.sequence_size := header_labels_sequence_size;
                label_sequence_header^.label_count := 0;
                bap$set_file_reference_abnormal ('DEFAULTS', ame$only_seq_header_returned,
                      'FSP$DEFAULT_TAPE_LABEL_ATTRIB', 'HEADER', status);
              ELSE
                bap$set_file_reference_abnormal ('DEFAULTS', ame$label_sequence_too_small,
                      'FSP$DEFAULT_TAPE_LABEL_ATTRIB', 'HEADER', status);
                return_attribute := FALSE;
              IFEND;
            IFEND;
          ELSE
            return_attribute := FALSE;
          IFEND;

        = fsc$tape_max_block_length =
          attributes [index].tape_attachment.tape_max_block_length := default_attributes.max_block_length;

        = fsc$tape_max_record_length =
          attributes [index].tape_attachment.tape_max_record_length := default_attributes.max_record_length;

        = fsc$tape_owner_identification =
          attributes [index].tape_attachment.tape_owner_identification := default_attributes.owner_identifier;

        = fsc$tape_padding_character =
          attributes [index].tape_attachment.tape_padding_character := default_attributes.padding_character;

        = fsc$tape_record_type =
          attributes [index].tape_attachment.tape_record_type := default_attributes.record_type;

        = fsc$tape_rewrite_labels =
          attributes [index].tape_attachment.tape_rewrite_labels := default_attributes.rewrite_labels;

        = fsc$tape_trailer_labels =
          IF attributes [index].tape_attachment.tape_trailer_labels <> NIL THEN
            label_sequence := attributes [index].tape_attachment.tape_trailer_labels;
            RESET label_sequence;
            trailer_labels_sequence_size := #SIZE (fst$tape_label_sequence_header) +
                  (4 * #SIZE (fst$tape_label_block_descriptor)) + #SIZE (fst$ansi_eof1_label) +
                  #SIZE (fst$ansi_eof2_label);
            IF #SIZE (label_sequence^) >= trailer_labels_sequence_size THEN
              NEXT label_sequence_header IN label_sequence;
              label_sequence_header^.character_set := amc$ascii;
              label_sequence_header^.label_kinds := $fst$ansi_label_kinds [fsc$ansi_eof1_label_kind,
                    fsc$ansi_eof2_label_kind];
              label_sequence_header^.sequence_size := trailer_labels_sequence_size;
              label_sequence_header^.label_count := 4;

              NEXT label_block_descriptor IN label_sequence;
              label_block_descriptor^.label_block_type := fsc$tapemark_tape_label_block;

              next_block_descriptor (fsc$ansi_eof1_label_kind);
              NEXT eof1_block IN label_sequence;
              eof1_block^ := eof1_label_default;
              pmp$get_date (osc$ordinal_date, date, status);
              IF date.ordinal (1, 2) <> '19' THEN
                eof1_block^.creation_date (1, 1) := date.ordinal (2, 1);
                eof1_block^.expiration_date (1, 1) := date.ordinal (2, 1);
              IFEND;
              eof1_block^.creation_date (2, 5) := date.ordinal (3, 5);
              eof1_block^.expiration_date (2, 5) := date.ordinal (3, 5);

              next_block_descriptor (fsc$ansi_eof2_label_kind);
              NEXT eof2_block IN label_sequence;
              eof2_block^ := eof2_label_default;

              NEXT label_block_descriptor IN label_sequence;
              label_block_descriptor^.label_block_type := fsc$tapemark_tape_label_block;
            ELSE
              IF #SIZE (label_sequence^) >= #SIZE (fst$tape_label_sequence_header) THEN
                NEXT label_sequence_header IN label_sequence;
                label_sequence_header^.character_set := amc$ascii;
                label_sequence_header^.label_kinds := $fst$ansi_label_kinds [];
                label_sequence_header^.sequence_size := trailer_labels_sequence_size;
                label_sequence_header^.label_count := 0;
                bap$set_file_reference_abnormal ('DEFAULTS', ame$only_seq_header_returned,
                      'FSP$DEFAULT_TAPE_LABEL_ATTRIB', 'TRAILER', status);
              ELSE
                bap$set_file_reference_abnormal ('DEFAULTS', ame$label_sequence_too_small,
                      'FSP$DEFAULT_TAPE_LABEL_ATTRIB', 'TRAILER', status);
                return_attribute := FALSE;
              IFEND;
            IFEND;
          ELSE
            return_attribute := FALSE;
          IFEND;

        = fsc$tape_volume_accessibility =
          attributes [index].tape_attachment.tape_volume_accessibility :=
                default_attributes.volume_accessibility;

        ELSE
          return_attribute := FALSE;
        CASEND;

        IF return_attribute THEN
          returned_attributes := returned_attributes + $fst$tla_returned_attributes
                [attributes [index].tape_attachment.selector];
        IFEND;
      IFEND;
    FOREND;

  PROCEND fsp$default_tape_label_attrib;
MODEND fsm$default_tape_label_attrib;

*DECK DECK=FSM$DETACH_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : File System : Detach File' ??
MODULE fsm$detach_file;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc ame$lfn_program_actions
*copyc ame$attribute_validation_errors
*copyc fst$detachment_options
*copyc fst$file_reference
*copyc oss$job_paged_literal
?? POP ??
*copyc bap$delete_art_entry
*copyc bap$return
*copyc bap$set_evaluated_file_abnormal
*copyc clp$evaluate_file_reference
*copyc clp$validate_local_file_name
*copyc fsv$evaluated_file_reference
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osv$initial_exception_context

  VAR
    detachment_option_names: [STATIC, READ, oss$job_paged_literal] array
          [fsc$do_unload_volume .. fsc$do_unload_volume] of ost$name := [
          {fsc$do_unload_volume ........... = 002} 'UNLOAD_VOLUME                '];

?? TITLE := 'PROCEDURE validate_detachment_options', EJECT ??

    PROCEDURE validate_detachment_options
      (    evaluated_file_reference: fst$evaluated_file_reference;
           detachment_options: ^fst$detachment_options;
       VAR status: ost$status);

      CONST
        detach_file_request = 'FSP$DETACH_FILE',
        detachment_options_parameter = 'DETACHMENT_OPTIONS';

      VAR
        detachment_option_index: integer,
        detachment_option_name: ost$name;

      status.normal := TRUE;

      FOR detachment_option_index := 1 TO UPPERBOUND (detachment_options^) DO
        detachment_option_name := osc$null_name;
        CASE detachment_options^ [detachment_option_index].selector OF
        = fsc$do_unload_volume =
          IF (detachment_options^ [detachment_option_index].unload_volume < LOWERVALUE (boolean)) OR
                (detachment_options^ [detachment_option_index].unload_volume > UPPERVALUE (boolean)) THEN
            detachment_option_name := detachment_option_names [fsc$do_unload_volume];
          IFEND;
        = fsc$do_null_detachment_option =
          ;
        ELSE
          bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_file_attrib_key,
                detach_file_request, detachment_options_parameter, status);
          osp$append_status_integer (osc$status_parameter_delimiter, detachment_option_index, {radix} 10,
                {include_radix} FALSE, status);
        CASEND;
        IF status.normal AND (detachment_option_name <> osc$null_name) THEN
          bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$improper_file_attrib_value,
                detach_file_request, detachment_options_parameter, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, detachment_option_name, status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

    PROCEND validate_detachment_options;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fsp$detach_file', EJECT ??

  PROCEDURE [XDCL, #GATE] fsp$detach_file
    (    file: fst$file_reference;
         detachment_options: ^fst$detachment_options;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context,
      evaluated_file_reference: fst$evaluated_file_reference,
      ignore_status: ost$status,
      local_detachment_options: ^fst$detachment_options,
      local_file_name: amt$local_file_name,
      local_status: ost$status,
      name_is_path_handle: boolean,
      name_is_valid: boolean,
      path_handle: fmt$path_handle;

    local_status.normal := TRUE;
    context := NIL;
    status.normal := TRUE;

  /detach_file/
    BEGIN
      clp$validate_local_file_name (file, local_file_name, path_handle, name_is_path_handle, name_is_valid);
      IF name_is_path_handle THEN

{       The call to clp$validate_local_file_name and this path_handle check is
{       here because clp$evaluate_file_reference returns the full path for an
{       alias path handle.

        evaluated_file_reference := fsv$evaluated_file_reference;
        evaluated_file_reference.path_handle_info.path_handle_present := TRUE;
        evaluated_file_reference.path_handle_info.path_handle := path_handle;
      ELSE
        clp$evaluate_file_reference (file, $clt$file_ref_parsing_options [clc$use_$local_as_working_cat],
              {resolve_cycle_number} FALSE, evaluated_file_reference, status);
        IF NOT status.normal THEN
          EXIT /detach_file/;
        IFEND;
      IFEND;

      IF detachment_options <> NIL THEN
        PUSH local_detachment_options: [1 .. UPPERBOUND (detachment_options^)];
        local_detachment_options^ := detachment_options^;
        validate_detachment_options (evaluated_file_reference, local_detachment_options, status);
        IF NOT status.normal THEN
          EXIT /detach_file/;
        IFEND;
      ELSE
        local_detachment_options := NIL;
      IFEND;

     REPEAT
        bap$return (evaluated_file_reference, local_detachment_options, status);
        IF osp$file_access_condition (status) THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_evaluated_file_ref;
            context^.file.evaluated_file_reference := evaluated_file_reference;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
      IF (status.normal OR (status.condition = ame$file_not_known)) AND name_is_valid THEN
        bap$delete_art_entry (local_file_name, ignore_status);
      IFEND;

    END /detach_file/;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND fsp$detach_file;

MODEND fsm$detach_file;
*DECK DECK=FSM$EXPAND_FILE_LABEL EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File System : File Label Expansion' ??
MODULE fsm$expand_file_label;

{ PURPOSE:
{   This module contains the procedure that expands a compressed file label.
{
{ DESIGN:
{   First assign default values to the attributes by a record assignment and
{   then NEXT through the sequence to retrieve the non-default attribute values.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc amt$file_reference
*copyc amt$path_name
*copyc bat$static_label_attributes
*copyc fmc$unique_label_id
*copyc fmt$file_attribute_keys
*copyc fmt$static_label_header
*copyc fmt$static_label_item
?? POP ??
*copyc bap$get_default_file_attribs
*copyc fsp$convert_to_old_contents
*copyc osp$set_status_abnormal
?? OLDTITLE ??

?? NEWTITLE := 'PROCEDURE [XDCL, #GATE] fsp$expand_file_label', EJECT ??

  PROCEDURE [XDCL, #GATE] fsp$expand_file_label
    (    file_label: ^SEQ ( * );
     VAR static_label_attributes: bat$static_label_attributes;
     VAR file_previously_opened: boolean;
     VAR status: ost$status);

    VAR
      attribute_key: fmt$file_attribute_keys,
      default_new_retention: fst$retention,
      default_new_retention_specified: boolean,
      header: ^fmt$static_label_header,
      ignore_found: boolean,
      ignore_path: amt$path_name,
      split_file_contents: amt$file_contents,
      split_file_structure: amt$file_structure,
      reassign_file_contents: boolean,
      static_label: ^SEQ ( * ),
      static_label_item: ^fmt$static_label_item,
      str: ^string ( * );

?? NEWTITLE := 'PROCEDURE set_status_damaged_attributes', EJECT ??
    PROCEDURE set_status_damaged_attributes
      (    attribute_index: 1 .. fmc$highest_current_attribute + 5;
       VAR status: ost$status);

      VAR
        status_text: string (osc$max_string_size),
        text_length: integer;

      STRINGREP (status_text, text_length, 'Nexting of attribute # ', attribute_index,
            ' in LABEL resulted in a NIL pointer in FSP$EXPAND_FILE_LABEL');
      osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
            status_text (1, text_length), status);

    PROCEND set_status_damaged_attributes;
?? OLDTITLE ??

?? NEWTITLE := 'PROCEDURE [INLINE] get_entry_point_reference', EJECT ??
    PROCEDURE [INLINE] get_entry_point_reference
      (VAR name: pmt$program_name;
       VAR path: amt$file_reference;
       VAR status: ost$status);

      NEXT str: [static_label_item^.entry_point_name_length] IN static_label;
      IF str = NIL THEN
        set_status_damaged_attributes (fmc$highest_current_attribute + 1, status);
        RETURN;
      IFEND;
      name := str^;
      IF static_label_item^.entry_point_path_length > 0 THEN
        NEXT str: [static_label_item^.entry_point_path_length] IN static_label;
        IF str = NIL THEN
          set_status_damaged_attributes (fmc$highest_current_attribute + 2, status);
          RETURN;
        IFEND;
        path := str^;
      IFEND;
    PROCEND get_entry_point_reference;
?? OLDTITLE ??

?? NEWTITLE := 'PROCEDURE [INLINE] get_name', EJECT ??
    PROCEDURE [INLINE] get_name
      (VAR name: pmt$program_name;
       VAR status: ost$status);

      NEXT str: [static_label_item^.name_length] IN static_label;
      IF str = NIL THEN
        set_status_damaged_attributes (fmc$highest_current_attribute + 3, status);
        RETURN;
      IFEND;
      name := str^;

    PROCEND get_name;
?? OLDTITLE ??

    status.normal := TRUE;
    bap$get_default_file_attribs (static_label_attributes, default_new_retention_specified,
          default_new_retention, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF file_label = NIL THEN
      file_previously_opened := FALSE;
    ELSE
      static_label := file_label;
      RESET static_label;
      NEXT header IN static_label;
      IF header = NIL THEN
        set_status_damaged_attributes (fmc$highest_current_attribute + 4, status);
        RETURN;
      IFEND;
      IF header^.unique_character <> fmc$unique_label_id THEN
        set_status_damaged_attributes (fmc$highest_current_attribute + 5, status);
        RETURN;
      IFEND;
      file_previously_opened := header^.file_previously_opened;
      IF header^.file_previously_opened THEN
        static_label_attributes.ring_attributes_source := header^.ring_attributes_source;
        static_label_attributes.ring_attributes := header^.ring_attributes;
      IFEND;
      IF header^.highest_attribute_present > 0 THEN
        reassign_file_contents := FALSE;
        FOR attribute_key := LOWERBOUND (header^.attribute_present) TO header^.highest_attribute_present DO
          CASE attribute_key OF
          = fmc$block_type =
            IF header^.attribute_present [fmc$block_type] THEN
              NEXT static_label_item: [fmc$block_type] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$block_type, status);
                RETURN;
              IFEND;
              static_label_attributes.block_type_source := static_label_item^.source;
              static_label_attributes.block_type := static_label_item^.block_type;
            IFEND;
          = fmc$character_conversion =
            IF header^.attribute_present [fmc$character_conversion] THEN
              NEXT static_label_item: [fmc$character_conversion] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$character_conversion, status);
                RETURN;
              IFEND;
              static_label_attributes.character_conversion_source := static_label_item^.source;
              static_label_attributes.character_conversion := static_label_item^.character_conversion;
            IFEND;
          = fmc$clear_space =
            IF header^.attribute_present [fmc$clear_space] THEN
              NEXT static_label_item: [fmc$clear_space] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$clear_space, status);
                RETURN;
              IFEND;
              static_label_attributes.clear_space_source := static_label_item^.source;
              static_label_attributes.clear_space := static_label_item^.clear_space;
            IFEND;
          = fmc$file_access_procedure =
            IF header^.attribute_present [fmc$file_access_procedure] THEN
              NEXT static_label_item: [fmc$file_access_procedure] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$file_access_procedure, status);
                RETURN;
              IFEND;
              static_label_attributes.file_access_procedure_source := static_label_item^.source;
              get_entry_point_reference (static_label_attributes.file_access_procedure, ignore_path, status);
            IFEND;
          = fmc$file_contents =
            IF header^.attribute_present [fmc$file_contents] THEN
              NEXT static_label_item: [fmc$file_contents] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$file_contents, status);
                RETURN;
              IFEND;
              static_label_attributes.file_contents_source := static_label_item^.source;
              get_name (static_label_attributes.file_contents, status);
              fsp$convert_to_old_contents (static_label_attributes.file_contents, split_file_contents,
                    split_file_structure);
              reassign_file_contents := split_file_structure <> fsc$unknown_contents;
            IFEND;
          = fmc$file_limit =
            IF header^.attribute_present [fmc$file_limit] THEN
              NEXT static_label_item: [fmc$file_limit] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$file_limit, status);
                RETURN;
              IFEND;
              static_label_attributes.file_limit_source := static_label_item^.source;
              static_label_attributes.file_limit := static_label_item^.integer_value;
            IFEND;
          = fmc$file_organization =
            IF header^.attribute_present [fmc$file_organization] THEN
              NEXT static_label_item: [fmc$file_organization] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$file_organization, status);
                RETURN;
              IFEND;
              static_label_attributes.file_organization_source := static_label_item^.source;
              static_label_attributes.file_organization := static_label_item^.file_organization;
            IFEND;
          = fmc$file_processor =
            IF header^.attribute_present [fmc$file_processor] THEN
              NEXT static_label_item: [fmc$file_processor] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$file_processor, status);
                RETURN;
              IFEND;
              static_label_attributes.file_processor_source := static_label_item^.source;
              get_name (static_label_attributes.file_processor, status);
            IFEND;
          = fmc$file_structure =
            IF header^.attribute_present [fmc$file_structure] THEN
              NEXT static_label_item: [fmc$file_structure] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$file_structure, status);
                RETURN;
              IFEND;
              static_label_attributes.file_structure_source := static_label_item^.source;
              get_name (static_label_attributes.file_structure, status);
            IFEND;
          = fmc$forced_write =
            IF header^.attribute_present [fmc$forced_write] THEN
              NEXT static_label_item: [fmc$forced_write] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$forced_write, status);
                RETURN;
              IFEND;
              static_label_attributes.forced_write_source := static_label_item^.source;
              static_label_attributes.forced_write := static_label_item^.forced_write;
            IFEND;
          = fmc$internal_code =
            IF header^.attribute_present [fmc$internal_code] THEN
              NEXT static_label_item: [fmc$internal_code] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$internal_code, status);
                RETURN;
              IFEND;
              static_label_attributes.internal_code_source := static_label_item^.source;
              static_label_attributes.internal_code := static_label_item^.internal_code;
            IFEND;
          = fmc$label_type =
            IF header^.attribute_present [fmc$label_type] THEN
              NEXT static_label_item: [fmc$label_type] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$label_type, status);
                RETURN;
              IFEND;
              static_label_attributes.label_type_source := static_label_item^.source;
              static_label_attributes.label_type := static_label_item^.label_type;
            IFEND;
          = fmc$line_number =
            IF header^.attribute_present [fmc$line_number] THEN
              NEXT static_label_item: [fmc$line_number] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$line_number, status);
                RETURN;
              IFEND;
              IF (static_label_item^.line_number.length >= LOWERVALUE (amt$line_number_length)) AND
                    (static_label_item^.line_number.length <= UPPERVALUE (amt$line_number_length)) AND
                    (static_label_item^.line_number.location >= LOWERVALUE (amt$line_number_location)) AND
                    (static_label_item^.line_number.location <= UPPERVALUE (amt$line_number_location)) THEN
                static_label_attributes.line_number_source := static_label_item^.source;
                static_label_attributes.line_number := static_label_item^.line_number;
              IFEND;
            IFEND;
          = fmc$max_block_length =
            IF header^.attribute_present [fmc$max_block_length] THEN
              NEXT static_label_item: [fmc$max_block_length] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$max_block_length, status);
                RETURN;
              IFEND;
              static_label_attributes.max_block_length_source := static_label_item^.source;
              static_label_attributes.max_block_length := static_label_item^.integer_value;
            IFEND;
          = fmc$max_record_length =
            IF header^.attribute_present [fmc$max_record_length] THEN
              NEXT static_label_item: [fmc$max_record_length] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$max_record_length, status);
                RETURN;
              IFEND;
              static_label_attributes.max_record_length_source := static_label_item^.source;
              static_label_attributes.max_record_length := static_label_item^.integer_value;
            IFEND;
          = fmc$min_block_length =
            IF header^.attribute_present [fmc$min_block_length] THEN
              NEXT static_label_item: [fmc$min_block_length] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$min_block_length, status);
                RETURN;
              IFEND;
              static_label_attributes.min_block_length_source := static_label_item^.source;
              static_label_attributes.min_block_length := static_label_item^.integer_value;
            IFEND;
          = fmc$min_record_length =
            IF header^.attribute_present [fmc$min_record_length] THEN
              NEXT static_label_item: [fmc$min_record_length] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$min_record_length, status);
                RETURN;
              IFEND;
              static_label_attributes.min_record_length_source := static_label_item^.source;
              static_label_attributes.min_record_length := static_label_item^.integer_value;
            IFEND;
          = fmc$padding_character =
            IF header^.attribute_present [fmc$padding_character] THEN
              NEXT static_label_item: [fmc$padding_character] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$padding_character, status);
                RETURN;
              IFEND;
              static_label_attributes.padding_character_source := static_label_item^.source;
              static_label_attributes.padding_character := static_label_item^.padding_character;
            IFEND;
          = fmc$page_format =
            IF header^.attribute_present [fmc$page_format] THEN
              NEXT static_label_item: [fmc$page_format] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$page_format, status);
                RETURN;
              IFEND;
              static_label_attributes.page_format_source := static_label_item^.source;
              static_label_attributes.page_format := static_label_item^.page_format;
            IFEND;
          = fmc$page_length =
            IF header^.attribute_present [fmc$page_length] THEN
              NEXT static_label_item: [fmc$page_length] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$page_length, status);
                RETURN;
              IFEND;
              static_label_attributes.page_length_source := static_label_item^.source;
              static_label_attributes.page_length := static_label_item^.integer_value;
            IFEND;
          = fmc$page_width =
            IF header^.attribute_present [fmc$page_width] THEN
              NEXT static_label_item: [fmc$page_width] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$page_width, status);
                RETURN;
              IFEND;
              static_label_attributes.page_width_source := static_label_item^.source;
              static_label_attributes.page_width := static_label_item^.integer_value;
            IFEND;
          = fmc$preset_value =
            IF header^.attribute_present [fmc$preset_value] THEN
              NEXT static_label_item: [fmc$preset_value] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$preset_value, status);
                RETURN;
              IFEND;
              static_label_attributes.preset_value_source := static_label_item^.source;
              static_label_attributes.preset_value := static_label_item^.integer_value;
            IFEND;
          = fmc$record_delimiting_character =
            IF header^.attribute_present [fmc$record_delimiting_character] THEN
              NEXT static_label_item: [fmc$record_delimiting_character] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$record_delimiting_character, status);
                RETURN;
              IFEND;
              static_label_attributes.record_delimiting_char_source := static_label_item^.source;
              static_label_attributes.record_delimiting_character :=
                    static_label_item^.record_delimiting_character;
            IFEND;
          = fmc$record_type =
            IF header^.attribute_present [fmc$record_type] THEN
              NEXT static_label_item: [fmc$record_type] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$record_type, status);
                RETURN;
              IFEND;
              static_label_attributes.record_type_source := static_label_item^.source;
              static_label_attributes.record_type := static_label_item^.record_type;
            IFEND;
          = fmc$ring_attributes =

{ processed above prior to FOR loop

            ;
          = fmc$statement_identifier =
            IF header^.attribute_present [fmc$statement_identifier] THEN
              NEXT static_label_item: [fmc$statement_identifier] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$statement_identifier, status);
                RETURN;
              IFEND;
              IF (static_label_item^.statement_identifier.length >= LOWERVALUE (amt$statement_id_length)) AND
                    (static_label_item^.statement_identifier.length <=
                    UPPERVALUE (amt$statement_id_length)) AND (static_label_item^.statement_identifier.
                    location >= LOWERVALUE (amt$statement_id_location)) AND
                    (static_label_item^.statement_identifier.location <=
                    UPPERVALUE (amt$statement_id_location)) THEN
                static_label_attributes.statement_identifier_source := static_label_item^.source;
                static_label_attributes.statement_identifier := static_label_item^.statement_identifier;
              IFEND;
            IFEND;
          = fmc$user_info =
            IF header^.attribute_present [fmc$user_info] THEN
              NEXT static_label_item: [fmc$user_info] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$user_info, status);
                RETURN;
              IFEND;
              static_label_attributes.user_info_source := static_label_item^.source;
              IF static_label_item^.user_info_present THEN
                NEXT str: [32] IN static_label;
                IF str = NIL THEN
                  set_status_damaged_attributes (fmc$user_info, status);
                  RETURN;
                IFEND;
                static_label_attributes.user_info := str^;
              IFEND;
            IFEND;
          = fmc$vertical_print_density =
            IF header^.attribute_present [fmc$vertical_print_density] THEN
              NEXT static_label_item: [fmc$vertical_print_density] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$vertical_print_density, status);
                RETURN;
              IFEND;
              static_label_attributes.vertical_print_density_source := static_label_item^.source;
              static_label_attributes.vertical_print_density := static_label_item^.integer_value;
            IFEND;
          = fmc$average_record_length =
            IF header^.attribute_present [fmc$average_record_length] THEN
              NEXT static_label_item: [fmc$average_record_length] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$average_record_length, status);
                RETURN;
              IFEND;
              static_label_attributes.average_record_length_source := static_label_item^.source;
              static_label_attributes.average_record_length := static_label_item^.integer_value;
            IFEND;
          = fmc$collate_table =
            IF header^.attribute_present [fmc$collate_table] THEN
              NEXT static_label_item: [fmc$collate_table] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$collate_table, status);
                RETURN;
              IFEND;
              static_label_attributes.collate_table_source := static_label_item^.source;
              static_label_attributes.collate_table := static_label_item^.collate_table;
            IFEND;
          = fmc$collate_table_name =
            IF header^.attribute_present [fmc$collate_table_name] THEN
              NEXT static_label_item: [fmc$collate_table_name] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$collate_table_name, status);
                RETURN;
              IFEND;
              static_label_attributes.collate_table_name_source := static_label_item^.source;
              get_entry_point_reference (static_label_attributes.collate_table_name, ignore_path, status);
            IFEND;
          = fmc$compression_procedure_name =
            IF header^.attribute_present [fmc$compression_procedure_name] THEN
              NEXT static_label_item: [fmc$compression_procedure_name] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$compression_procedure_name, status);
                RETURN;
              IFEND;
              static_label_attributes.compression_proc_name_source := static_label_item^.source;
              get_entry_point_reference (static_label_attributes.compression_procedure_name.name,
                    static_label_attributes.compression_procedure_name.object_library, status);
            IFEND;
          = fmc$data_padding =
            IF header^.attribute_present [fmc$data_padding] THEN
              NEXT static_label_item: [fmc$data_padding] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$data_padding, status);
                RETURN;
              IFEND;
              static_label_attributes.data_padding_source := static_label_item^.source;
              static_label_attributes.data_padding := static_label_item^.data_padding;
            IFEND;
          = fmc$dynamic_home_block_space =
            IF header^.attribute_present [fmc$dynamic_home_block_space] THEN
              NEXT static_label_item: [fmc$dynamic_home_block_space] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$dynamic_home_block_space, status);
                RETURN;
              IFEND;
              static_label_attributes.dynamic_home_block_space_source := static_label_item^.source;
              static_label_attributes.dynamic_home_block_space := static_label_item^.dynamic_home_block_space;
            IFEND;
          = fmc$embedded_key =
            IF header^.attribute_present [fmc$embedded_key] THEN
              NEXT static_label_item: [fmc$embedded_key] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$embedded_key, status);
                RETURN;
              IFEND;
              static_label_attributes.embedded_key_source := static_label_item^.source;
              static_label_attributes.embedded_key := static_label_item^.embedded_key;
            IFEND;
          = fmc$estimated_record_count =
            IF header^.attribute_present [fmc$estimated_record_count] THEN
              NEXT static_label_item: [fmc$estimated_record_count] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$estimated_record_count, status);
                RETURN;
              IFEND;
              static_label_attributes.estimated_record_count_source := static_label_item^.source;
              static_label_attributes.estimated_record_count := static_label_item^.integer_value;
            IFEND;
          = fmc$hashing_procedure_name =
            IF header^.attribute_present [fmc$hashing_procedure_name] THEN
              NEXT static_label_item: [fmc$hashing_procedure_name] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$hashing_procedure_name, status);
                RETURN;
              IFEND;
              static_label_attributes.hashing_procedure_name_source := static_label_item^.source;
              get_entry_point_reference (static_label_attributes.hashing_procedure_name.name,
                    static_label_attributes.hashing_procedure_name.object_library, status);
            IFEND;
          = fmc$index_levels =
            IF header^.attribute_present [fmc$index_levels] THEN
              NEXT static_label_item: [fmc$index_levels] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$index_levels, status);
                RETURN;
              IFEND;
              static_label_attributes.index_levels_source := static_label_item^.source;
              static_label_attributes.index_levels := static_label_item^.integer_value;
            IFEND;
          = fmc$index_padding =
            IF header^.attribute_present [fmc$index_padding] THEN
              NEXT static_label_item: [fmc$index_padding] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$index_padding, status);
                RETURN;
              IFEND;
              static_label_attributes.index_padding_source := static_label_item^.source;
              static_label_attributes.index_padding := static_label_item^.index_padding;
            IFEND;
          = fmc$initial_home_block_count =
            IF header^.attribute_present [fmc$initial_home_block_count] THEN
              NEXT static_label_item: [fmc$initial_home_block_count] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$initial_home_block_count, status);
                RETURN;
              IFEND;
              static_label_attributes.initial_home_block_count_source := static_label_item^.source;
              static_label_attributes.initial_home_block_count := static_label_item^.integer_value;
            IFEND;
          = fmc$key_length =
            IF header^.attribute_present [fmc$key_length] THEN
              NEXT static_label_item: [fmc$key_length] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$key_length, status);
                RETURN;
              IFEND;
              static_label_attributes.key_length_source := static_label_item^.source;
              static_label_attributes.key_length := static_label_item^.integer_value;
            IFEND;
          = fmc$key_position =
            IF header^.attribute_present [fmc$key_position] THEN
              NEXT static_label_item: [fmc$key_position] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$key_position, status);
                RETURN;
              IFEND;
              static_label_attributes.key_position_source := static_label_item^.source;
              static_label_attributes.key_position := static_label_item^.integer_value;
            IFEND;
          = fmc$key_type =
            IF header^.attribute_present [fmc$key_type] THEN
              NEXT static_label_item: [fmc$key_type] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$key_type, status);
                RETURN;
              IFEND;
              static_label_attributes.key_type_source := static_label_item^.source;
              static_label_attributes.key_type := static_label_item^.key_type;
            IFEND;
          = fmc$loading_factor =
            IF header^.attribute_present [fmc$loading_factor] THEN
              NEXT static_label_item: [fmc$loading_factor] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$loading_factor, status);
                RETURN;
              IFEND;
              static_label_attributes.loading_factor_source := static_label_item^.source;
              static_label_attributes.loading_factor := static_label_item^.loading_factor;
            IFEND;
          = fmc$lock_expiration_time =
            IF header^.attribute_present [fmc$lock_expiration_time] THEN
              NEXT static_label_item: [fmc$lock_expiration_time] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$lock_expiration_time, status);
                RETURN;
              IFEND;
              static_label_attributes.lock_expiration_time_source := static_label_item^.source;
              static_label_attributes.lock_expiration_time := static_label_item^.integer_value;
            IFEND;
          = fmc$logging_options =
            IF header^.attribute_present [fmc$logging_options] THEN
              NEXT static_label_item: [fmc$logging_options] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$logging_options, status);
                RETURN;
              IFEND;
              static_label_attributes.logging_options_source := static_label_item^.source;
              static_label_attributes.logging_options := static_label_item^.logging_options;
            IFEND;
          = fmc$log_residence =
            IF header^.attribute_present [fmc$log_residence] THEN
              NEXT static_label_item: [fmc$log_residence] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$log_residence, status);
                RETURN;
              IFEND;
              NEXT str: [static_label_item^.path_length] IN static_label;
              IF str = NIL THEN
                set_status_damaged_attributes (fmc$log_residence, status);
                RETURN;
              IFEND;
              static_label_attributes.log_residence_source := static_label_item^.source;
              static_label_attributes.log_residence := str^;
            IFEND;
          = fmc$record_limit =
            IF header^.attribute_present [fmc$record_limit] THEN
              NEXT static_label_item: [fmc$record_limit] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$record_limit, status);
                RETURN;
              IFEND;
              static_label_attributes.record_limit_source := static_label_item^.source;
              static_label_attributes.record_limit := static_label_item^.integer_value;
            IFEND;
          = fmc$records_per_block =
            IF header^.attribute_present [fmc$records_per_block] THEN
              NEXT static_label_item: [fmc$records_per_block] IN static_label;
              IF static_label_item = NIL THEN
                set_status_damaged_attributes (fmc$records_per_block, status);
                RETURN;
              IFEND;
              static_label_attributes.records_per_block_source := static_label_item^.source;
              static_label_attributes.records_per_block := static_label_item^.integer_value;
            IFEND;
          ELSE
          CASEND;
        FOREND;
        IF reassign_file_contents AND NOT ((split_file_contents = fsc$list) AND
              (split_file_structure = fsc$data) AND (static_label_attributes.file_structure =
              fsc$unknown_contents)) THEN
          static_label_attributes.file_contents := split_file_contents;
          static_label_attributes.file_structure := split_file_structure;
          static_label_attributes.file_structure_source := static_label_attributes.file_contents_source;
        IFEND;
      IFEND;
    IFEND;

  PROCEND fsp$expand_file_label;
MODEND fsm$expand_file_label;
*DECK DECK=FSM$FILE_ACCESS_CONDITIONS EXPAND=TRUE
*DECK DECK=FSM$GET_TAPE_LABEL_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File System : Tape Label Attributes Retrieval' ??
MODULE fsm$get_tape_label_attributes;

{ PURPOSE:
{   This module contains the 2DD interface for getting the tape label
{   attributes.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fst$attachment_options
*copyc fst$file_reference
*copyc fst$tape_attribute_source
*copyc fst$tla_returned_attributes
*copyc ost$status
?? POP ??
*copyc clp$evaluate_file_reference
*copyc bap$get_tape_label_attributes

?? TITLE := 'fsp$get_tape_label_attributes', EJECT ??
*copy fsh$get_tape_label_attributes

  PROCEDURE [XDCL, #GATE] fsp$get_tape_label_attributes
    (    file: fst$file_reference;
         source: fst$tape_attribute_source;
     VAR attributes {input, output} : fst$attachment_options;
     VAR returned_attributes: fst$tla_returned_attributes;
     VAR status: ost$status);

    VAR
      evaluated_file_reference: fst$evaluated_file_reference;

    status.normal := TRUE;

    clp$evaluate_file_reference (file, $clt$file_ref_parsing_options [], {resolve_cycle_number} FALSE,
          evaluated_file_reference, status);
    IF status.normal THEN
      bap$get_tape_label_attributes (evaluated_file_reference, source, attributes, returned_attributes,
            status);
    IFEND;

  PROCEND fsp$get_tape_label_attributes;
MODEND fsm$get_tape_label_attributes;
*DECK DECK=FSM$HELP_MESSAGES EXPAND=TRUE
~"CREATE_MESSAGE_MODULE FSM$WAIT_MESSAGES$US_ENGLISH
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_CYCLE_BUSY
Wait - Cycle Busy
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_DATA_RESTORATION
Wait - Data Restoration
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_FOR_RETRIEVAL
Wait - Retrieving File
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_FOR_SPACE
Wait - Class ~P1 Space
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_SERVER_INACTIVE
Wait - Server Inactive
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_UNDEFINED_CONDITION
Wait - Undefined Condition
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_VOLUME_MISSING
Wait - Volume ~P1 Missing
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_VOLUME_UNAVAILABLE
Wait - Volume ~P1 Unavailable
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
*DECK DECK=FSM$OPEN_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Basic Access Methods : Open File' ??
MODULE fsm$open_file;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$access_level
*copyc amt$fap_declarations
*copyc amt$file_identifier
*copyc fme$file_management_errors
*copyc fsc$local
*copyc fse$open_validation_errors
*copyc fsk$keypoints
*copyc fst$file_reference
*copyc jmt$job_mode
*copyc osc$data_retrieval_req_cond
*copyc osd$exception_policies
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc pfe$external_archive_conditions
?? POP ??
*copyc bap$close
*copyc bap$end_new_open_processing
*copyc bap$free_static_label
*copyc bap$mark_fap_layer_open
*copyc bap$open_file
*copyc bap$return
*copyc clp$convert_cyc_ref_to_cyc_sel
*copyc clp$convert_file_ref_to_string
*copyc clp$evaluate_file_reference
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$convert_fs_structure_to_pf
*copyc fsp$path_element
*copyc fsp$resolve_file_reference
*copyc fsp$set_evaluated_file_abnormal
*copyc osp$await_activity_completion
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$file_access_condition
*copyc osp$generate_log_message
*copyc pfp$purge
*copyc pfp$retrieve_archived_file
*copyc pmp$cause_condition
*copyc pmp$get_job_mode

*copyc bav$task_file_table
*copyc osv$initial_exception_context
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    max_volumes_per_file = 500;

  VAR
    amv$nil_file_identifier: [XDCL, #GATE, READ, oss$job_paged_literal] amt$file_identifier := [0, 1];

?? OLDTITLE ??
*copyc amh$also
*copyc fsh$open_file
?? NEWTITLE := 'PROCEDURE [XDCL, #GATE] fsp$open_file', EJECT ??

  PROCEDURE [XDCL, #GATE] fsp$open_file
    (    file: fst$file_reference;
         access_level: amt$access_level;
         file_attachment: ^fst$attachment_options;
         default_creation_attributes: ^fst$file_cycle_attributes;
         mandated_creation_attributes: ^fst$file_cycle_attributes;
         attribute_validation: ^fst$file_cycle_attributes;
         attribute_override: ^fst$file_cycle_attributes;
     VAR file_identifier: amt$file_identifier;
     VAR status: ost$status);

    CONST
      fap_layer_number = 0;

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      local_file_identifier: amt$file_identifier;

?? NEWTITLE := '  PROCEDURE block_exit_handler ', EJECT ??

    PROCEDURE block_exit_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF (local_file_identifier <> amv$nil_file_identifier) THEN
        clean_up;
      IFEND;

    PROCEND block_exit_handler;
?? OLDTITLE ??
?? NEWTITLE := '  PROCEDURE clean_up ', EJECT ??

    PROCEDURE clean_up;

      VAR
        clean_up_status: ost$status,
        context: ost$ecp_exception_context,
        cycle_selector: clt$cycle_selector,
        initial_open: boolean,
        open_created_temporary_file: boolean,
        pf_path: ^pft$path;

{ Call to pfp$purge should occur before call to fsp$close_file so that
{ the file is deleted before access is allowed to other users.

      IF (fsp$path_element (^evaluated_file_reference, 1) ^ <> fsc$local) AND
            bav$task_file_table^ [local_file_identifier.ordinal].open_actions.open_created_file THEN
        PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
        fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);
        clp$convert_cyc_ref_to_cyc_sel (evaluated_file_reference.cycle_reference, cycle_selector);
        context := osv$initial_exception_context;
        get_attachment_options (file_attachment, context);
        pfp$purge (pf_path^, cycle_selector.value, context.password, clean_up_status);
      IFEND;

      open_created_temporary_file := (fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local) AND
            bav$task_file_table^ [local_file_identifier.ordinal].open_actions.open_created_file;

      IF bav$task_file_table^ [local_file_identifier.ordinal].initial_open THEN
        { discard label
        bap$free_static_label (evaluated_file_reference.path_handle_info.path_handle);
{ We should retrieve the static label for a permanent file that isn't
{ being returned.  The following example currently fails:
{ cref $user.x; setfa $user.x fc=george; detf $user.x; attf $user.x
{ open $user.x - failing open
{ open $user.x - successful open but setfa is lost.
        initial_open := TRUE;
      IFEND;

      fsp$close_file (local_file_identifier, clean_up_status);

      IF initial_open THEN
{ Force close to occur on a creation open, this is to prevent
{ the situation of file_previously_open=FALSE & open_count=1; this
{ would cause open to loop forever, because open would believe that
{ an asynchronous open was in progress.
        bap$close (local_file_identifier, clean_up_status);
      IFEND;
      IF open_created_temporary_file THEN
        bap$return (evaluated_file_reference, {detachment_options} NIL, clean_up_status);
      IFEND;
    PROCEND clean_up;

?? OLDTITLE, EJECT ??

    VAR
      archive_cycle_number: pft$cycle_number,
      call_block: amt$call_block,
      contains_data: boolean,
      context: ^ost$ecp_exception_context,
      local_status: ost$status,
      raised_conditions: fst$file_access_conditions,
      time_since_last_retrieval: 0 .. fsc$longest_wait_time;

    #KEYPOINT (osk$entry, 0, fsk$open_file);
    status.normal := TRUE;
    local_status.normal := TRUE;
    context := NIL;
    file_identifier := amv$nil_file_identifier;
    local_file_identifier := amv$nil_file_identifier;
    #SPOIL (local_file_identifier);
    raised_conditions := $fst$file_access_conditions [];
    time_since_last_retrieval := 0;

?? EJECT ??
    clp$evaluate_file_reference (file, $clt$file_ref_parsing_options [clc$use_$local_as_working_cat],
          {resolve_cycle_number=} FALSE, evaluated_file_reference, local_status);
    IF local_status.normal THEN
      osp$establish_block_exit_hndlr (^block_exit_handler);

      REPEAT
        {evaluated_file_reference is only updated when the open is successful.
        bap$open_file (access_level, file_attachment, default_creation_attributes,
              mandated_creation_attributes, attribute_validation, attribute_override,
              evaluated_file_reference, contains_data, local_file_identifier, archive_cycle_number,
              local_status);

        IF local_status.normal THEN
          IF (context <> NIL) THEN
            context^ := osv$initial_exception_context;
          IFEND;
        ELSE
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.caller_will_retrieve_file := TRUE;
          IFEND;
          process_abnormal_status (archive_cycle_number, file_attachment, evaluated_file_reference,
               local_status, time_since_last_retrieval, context^);
        IFEND;
      UNTIL local_status.normal OR ((context <> NIL) AND (NOT context^.wait));

      IF local_status.normal THEN
        bap$mark_fap_layer_open (local_file_identifier, fap_layer_number, local_status);
        IF local_status.normal THEN
          call_block.operation := amc$open_req;
          call_block.open.access_level := access_level;
          call_block.open.local_file_name := bav$task_file_table^ [local_file_identifier.ordinal].
                local_file_name;
          call_block.open.contains_data := contains_data;
          call_block.open.existing_file := NOT bav$task_file_table^ [local_file_identifier.ordinal].
                initial_open;

          bav$task_file_table^ [local_file_identifier.ordinal].fap_control_information.first_fap.
                access_method^ (local_file_identifier, call_block, fap_layer_number, local_status);
          IF local_status.normal AND bav$task_file_table^ [local_file_identifier.ordinal].initial_open THEN
            REPEAT
              bap$end_new_open_processing (evaluated_file_reference.path_handle_info.path_handle,
                    local_status);
              IF NOT local_status.normal THEN
                IF context = NIL THEN
                  PUSH context;
                  context^ := osv$initial_exception_context;
                  context^.raised_conditions := $fst$file_access_conditions [];
                IFEND;
                process_abnormal_status (archive_cycle_number, file_attachment, evaluated_file_reference,
                      local_status, time_since_last_retrieval, context^);
              IFEND;
            UNTIL local_status.normal OR ( (context <> NIL) AND (NOT context^.wait) );
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF local_status.normal THEN
      file_identifier := local_file_identifier;
    ELSE
      status := local_status;
      IF (local_file_identifier <> amv$nil_file_identifier) THEN
        clean_up;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    #KEYPOINT (osk$exit, 0, fsk$open_file);

  PROCEND fsp$open_file;

?? NEWTITLE := 'GET_ATTACHMENT_OPTIONS', EJECT ??

  PROCEDURE get_attachment_options
    (    file_attachment: ^fst$attachment_options;
     VAR context: ost$ecp_exception_context);

{ DESIGN: Prior to R1.5.3, the default policy was to wait for all conditions
{         except cycle busy.  However, the new policy is to have the default
{         influenced by job mode.  If the caller is a batch job, we now wait
{         indefinitely for all conditions.  If the caller is an interactive job,
{         we invoke the default condition handler to let the interactive user
{         decide the wait policy.

    VAR
      allowed_conditions_defaulted: boolean,
      index: integer,
      job_mode: jmt$job_mode,
      local_status: ost$status,
      wait_defaulted: boolean;

    allowed_conditions_defaulted := TRUE;
    wait_defaulted := TRUE;

    context.password := osc$null_name;
    context.allowed_access_conditions := -$fst$file_access_conditions [fsc$cycle_busy];
    context.wait := TRUE;
    context.wait_time := fsc$longest_wait_time;

    pmp$get_job_mode (job_mode, local_status);
    IF local_status.normal AND (job_mode = jmc$batch) THEN
      context.allowed_access_conditions := -$fst$file_access_conditions [];
    IFEND;

    IF file_attachment <> NIL THEN
      FOR index := LOWERBOUND (file_attachment^) TO UPPERBOUND (file_attachment^) DO
        CASE file_attachment^ [index].selector OF
        = fsc$allowed_exceptions =
          context.allowed_access_conditions := file_attachment^ [index].allowed_exceptions.access_conditions;
          allowed_conditions_defaulted := FALSE;
        = fsc$password =
          context.password := file_attachment^ [index].password;
        = fsc$wait_for_attachment =
          context.wait := file_attachment^ [index].wait_for_attachment.wait = osc$wait;
          IF context.wait THEN
            context.wait_time := file_attachment^ [index].wait_for_attachment.wait_time;
          IFEND;
          wait_defaulted := FALSE;
        ELSE
        CASEND;
      FOREND;
      IF allowed_conditions_defaulted AND (NOT wait_defaulted) AND context.wait THEN
        context.allowed_access_conditions := -$fst$file_access_conditions [];
      IFEND;
    IFEND;
  PROCEND get_attachment_options;

?? OLDTITLE ??
?? NEWTITLE := 'PROCESS_ABNORMAL_STATUS', EJECT ??

  PROCEDURE process_abnormal_status
    (    archive_cycle_number: pft$cycle_number;
         file_attachment: ^fst$attachment_options;
         evaluated_file_reference: fst$evaluated_file_reference;
     VAR status {input, output} : ost$status;
     VAR time_since_last_retrieval {input, output} : 0 .. fsc$longest_wait_time;
     VAR context {input, output} : ost$ecp_exception_context);

{ DESIGN: This procedure may be called repetitively and may process different
{         abnormal conditions.  CONTEXT.RAISED_CONDITIONS is a control variable that
{         determines whether the condition is new or not.  If new, we raise the
{         condition.  If we wait for the condition, this procedure is reentered
{         at the polling frequency until either the condition clears or the
{         CONTEXT.WAIT_TIME is exhausted.
{
{         It is possible (but conflicting) for a program to specify a non null
{         set for ALLOWED_EXCEPTIONS.FILE_ACCESS_CONDITIONS and to specify
{         no wait for WAIT_FOR_ATTACHMENT; this is implemented as a no wait.

    CONST
      five_minutes = 300000;

    VAR
      local_status: ost$status,
      pf_path: ^pft$path,
      ready_index: integer,
      wait_list: array [1 .. 1] of ost$activity;

?? EJECT ??

    IF osp$file_access_condition (status) THEN

      context.condition_status := status;

      IF context.raised_conditions = $fst$file_access_conditions [] THEN
        get_attachment_options (file_attachment, context);
        context.file.selector := osc$ecp_evaluated_file_ref;
        context.file.evaluated_file_reference := evaluated_file_reference;
      IFEND;

      IF context.wait THEN
        IF status.condition = pfe$cycle_data_resides_offline THEN
          IF NOT (fsc$data_retrieval_required IN context.raised_conditions) THEN
            pmp$cause_condition (osc$data_retrieval_req_cond, ^context {input, output}, local_status);
            IF local_status.normal THEN
              context.raised_conditions := context.raised_conditions + $fst$file_access_conditions
                   [fsc$data_retrieval_required]
            IFEND;
          IFEND;
          IF ((time_since_last_retrieval = 0) OR (time_since_last_retrieval >= five_minutes)) THEN
            PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
            fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);
            pfp$retrieve_archived_file (pf_path^, archive_cycle_number, context.password, osc$nowait,
                  local_status);

            context.wait := local_status.normal;

            IF NOT local_status.normal THEN
              status := local_status;
              RETURN;
            IFEND;

            time_since_last_retrieval := 0;
          IFEND;
        IFEND;

        osp$enforce_exception_policies (context);
        status := context.condition_status;
        time_since_last_retrieval := time_since_last_retrieval + context.elapsed_wait_time;
      IFEND;
    ELSE {Not a long term wait condition controlled by file_access_conditions}
      CASE status.condition OF
      = fme$reattach_detached_file, fme$wait_for_open_lock, pfe$tape_attached_on_client =
        { The preceding conditions are transient conditions requiring a short wait}
        wait_list [1].activity := osc$await_time;
        wait_list [1].milliseconds := 5000;
        osp$await_activity_completion (wait_list, ready_index, local_status);
        context.wait := TRUE;

      ELSE
        context.wait := FALSE;
      CASEND;
    IFEND;
  PROCEND process_abnormal_status;
?? OLDTITLE ??
MODEND fsm$open_file;


*DECK DECK=FSM$RESOLVE_FILE_REFERENCE EXPAND=TRUE
?? RIGHT := 110 ??
MODULE fsm$resolve_file_reference;
?? NEWTITLE := 'NOS/VE : File System', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc fst$goi_object_information
*copyc fst$path
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc clp$convert_file_ref_to_string
*copyc clp$evaluate_file_reference
*copyc clp$trimmed_string_size
*copyc pfp$r3_get_object_information

?? NEWTITLE := 'fsp$resolve_file_reference', EJECT ??
  PROCEDURE [XDCL, #GATE] fsp$resolve_file_reference
    (    file_reference: fst$file_reference;
     VAR resolved_file_reference: fst$path;
     VAR resolved_file_reference_size: fst$path_size;
     VAR status: ost$status);

    VAR
      resolved_cycle_request: [READ, oss$job_paged_literal] fst$goi_information_request :=
            [[fsc$specific_depth, 1], [fsc$goi_cycle_identity]];

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      information_request: fst$goi_information_request,
      object_info_sequence: ^SEQ ( * ),
      object_info_sequence_size: ost$positive_integers,
      object_information: ^fst$goi_object_information;

    clp$evaluate_file_reference (file_reference, $clt$file_ref_parsing_options [],
         {resolve_cycle_number} TRUE, evaluated_file_reference, status);
    IF status.normal THEN
      IF evaluated_file_reference.cycle_reference.specification = fsc$cycle_omitted THEN
        information_request := resolved_cycle_request;
        object_info_sequence_size := #SIZE (fst$goi_object_information) + fsc$max_path_size +
              #SIZE (fst$goi_object);
        PUSH object_info_sequence: [[REP object_info_sequence_size OF cell]];
        pfp$r3_get_object_information (evaluated_file_reference, information_request, NIL,
              object_info_sequence, status);
        IF status.normal THEN
          RESET object_info_sequence;
          NEXT object_information IN object_info_sequence;
          resolved_file_reference := object_information^.resolved_path^;
          resolved_file_reference_size := clp$trimmed_string_size (resolved_file_reference);
        IFEND;
      ELSE
        clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} FALSE,
              resolved_file_reference, resolved_file_reference_size, status);
      IFEND;
    IFEND;

  PROCEND fsp$resolve_file_reference;
MODEND fsm$resolve_file_reference;
*DECK DECK=FSM$SET_EVALUATED_FILE_ABNORMAL EXPAND=TRUE
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE : Basic Access Methods : Set Evaluated File Abnormal' ??

MODULE fsm$set_evaluated_file_abnormal;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc amd$operation_declarations
*copyc bac$unused_request_table_entry
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc clp$convert_file_ref_to_string
*copyc clp$trimmed_string_size
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal

*copyc bav$request_name_table_ptr

  CONST
    error_size = 4,
    error_text = '____';

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$set_evaluated_file_abnormal', EJECT ??

  PROCEDURE [XDCL, #GATE] bap$set_evaluated_file_abnormal
    (    evaluated_file_reference: fst$evaluated_file_reference;
         condition: ost$status_condition;
         request_name: string ( * <= osc$max_name_size);
         text: string ( * <= osc$max_string_size );
     VAR status: ost$status);


    VAR
      local_status: ost$status,
      path: fst$path,
      path_size: fst$path_size;

{FILE NAME
    clp$convert_file_ref_to_string (evaluated_file_reference,
          {include_open_position} FALSE, path, path_size, local_status);
    IF (NOT local_status.normal) OR (path_size = 0) THEN
      path := error_text;
      path_size := error_size;
    IFEND;

    bap$set_file_reference_abnormal (path (1, path_size), condition,
          request_name, text, status);

  PROCEND bap$set_evaluated_file_abnormal;

?? TITLE := 'PROCEDURE [XDCL, #GATE] bap$set_file_reference_abnormal', EJECT ??

  PROCEDURE [XDCL, #GATE, INLINE] bap$set_file_reference_abnormal
    (    file: fst$file_reference;
         condition: ost$status_condition;
         request_name: string ( * <= osc$max_name_size);
         text: string ( * <= osc$max_string_size );
     VAR status: ost$status);

    VAR
      status_text: string (osc$max_string_size),
      status_text_index: ost$string_index,
      text_length: ost$string_size;

    osp$set_status_abnormal (amc$access_method_id, condition, '', status);

{FILE NAME
    osp$append_status_file (osc$status_parameter_delimiter, file, status);

{REQUEST NAME
    IF request_name = osc$null_name THEN
      text_length := error_size;
      status_text (1, text_length) := error_text;
    ELSE
      text_length := clp$trimmed_string_size (request_name);
      IF text_length > osc$max_name_size THEN
        text_length := osc$max_name_size;
      IFEND;
      status_text (1, text_length) := request_name (1, text_length);
    IFEND;

{Fill in null parameters for access level, file organization, record type,
{block type, & the error position}
    status_text_index := text_length + 1;
    status_text (status_text_index) := osc$status_parameter_delimiter;
    status_text (status_text_index + 1) := osc$status_parameter_delimiter;
    status_text (status_text_index + 2) := osc$status_parameter_delimiter;
    status_text (status_text_index + 3) := osc$status_parameter_delimiter;
    status_text (status_text_index + 4) := osc$status_parameter_delimiter;

{TEXT
    status_text_index := status_text_index + 5;
    status_text (status_text_index) := osc$status_parameter_delimiter;
    text_length := clp$trimmed_string_size (text);
    IF text_length > (osc$max_string_size - status_text_index) THEN
      text_length := (osc$max_string_size - status_text_index);
    IFEND;
    status_text (status_text_index + 1, text_length) := text (1, text_length);

    osp$append_status_parameter (osc$status_parameter_delimiter,
          status_text (1, status_text_index + text_length), status);

  PROCEND bap$set_file_reference_abnormal;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fsp$append_stat_evaluated_file', EJECT ??

  PROCEDURE [XDCL, #GATE] fsp$append_stat_evaluated_file
    (    delimiter: char;
         evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: {i/o} ost$status);

    VAR
      local_status: ost$status,
      path: fst$path,
      path_size: fst$path_size;

    clp$convert_file_ref_to_string (evaluated_file_reference,
          {include_open_position} FALSE, path, path_size, local_status);
    IF (NOT local_status.normal) OR (path_size = 0) THEN
      path := error_text;
      path_size := error_size;
    IFEND;

    osp$append_status_file (delimiter, path (1, path_size), status);

  PROCEND fsp$append_stat_evaluated_file;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fsp$set_evaluated_file_abnormal', EJECT ??

  PROCEDURE [XDCL, #GATE] fsp$set_evaluated_file_abnormal
    (    evaluated_file_reference: fst$evaluated_file_reference;
         condition: ost$status_condition;
         request_code: amt$last_operation;
         text: string ( * <= osc$max_string_size );
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      path: fst$path,
      path_size: fst$path_size,
      request_name: ost$name;

    clp$convert_file_ref_to_string (evaluated_file_reference,
          {include_open_position} FALSE, path, path_size, local_status);
    IF (NOT local_status.normal) OR (path_size = 0) THEN
      path := error_text;
      path_size := error_size;
    IFEND;

    IF (request_code >= LOWERBOUND (bav$request_name_table_ptr^)) AND
          (request_code <= UPPERBOUND (bav$request_name_table_ptr^)) AND
          (bav$request_name_table_ptr^ [request_code].name <>
          bac$unused_request_table_entry) THEN
      request_name := bav$request_name_table_ptr^ [request_code].name;
    ELSE
      request_name := osc$null_name;
    IFEND;

    bap$set_file_reference_abnormal (path (1, path_size), condition,
          request_name, text, status);

  PROCEND fsp$set_evaluated_file_abnormal;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fsp$set_file_reference_abnormal', EJECT ??

  PROCEDURE [XDCL, #GATE] fsp$set_file_reference_abnormal
    (    file: fst$file_reference;
         condition: ost$status_condition;
         request_code: amt$last_operation;
         text: string ( * <= osc$max_string_size );
     VAR status: ost$status);

    VAR
      request_name: ost$name;

    IF (request_code >= LOWERBOUND (bav$request_name_table_ptr^)) AND
          (request_code <= UPPERBOUND (bav$request_name_table_ptr^)) AND
          (bav$request_name_table_ptr^ [request_code].name <>
          bac$unused_request_table_entry) THEN
      request_name := bav$request_name_table_ptr^ [request_code].name;
    ELSE
      request_name := osc$null_name;
    IFEND;

    bap$set_file_reference_abnormal (file, condition, request_name, text,
          status);

  PROCEND fsp$set_file_reference_abnormal;

?? OLDTITLE ??

MODEND fsm$set_evaluated_file_abnormal;

*DECK DECK=FSM$TABLES EXPAND=TRUE
?? RIGHT := 110 ??
MODULE fsm$tables;
?? TITLE := 'NOS/VE :  Basic Access Method', EJECT ??
?? NEWTITLE := '  [XDCL] COMMON VARIABLE DECLARATIONS' ??
?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
?? NEWTITLE := '[XDCL, #GATE] fsv$evaluated_file_reference', EJECT ??

  VAR
    fsv$evaluated_file_reference: [XDCL, #GATE, READ, oss$job_paged_literal]
          fst$evaluated_file_reference := ['', 0, 0, FALSE,
          [fsc$cycle_omitted], [FALSE, [0, 0, [FALSE]]], fsc$unresolved_path];

?? OLDTITLE ??

MODEND fsm$tables;

*DECK DECK=FSM$TAPE_LABEL_INTERFACES_2DD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE File System : Tape Label Classification' ??
MODULE fsm$tape_label_interfaces_2dd;

{ PURPOSE:
{   This module contains 2DD interfaces for accessing raw tape labels.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$internal_code
*copyc fsc$min_tape_label_length
*copyc fst$ansi_label_number
*copyc fst$ansi_label_identifier
*copyc fst$ansi_label_kinds
*copyc fst$tape_label_block_descriptor
*copyc fst$tape_label_classification
*copyc fst$tape_label_count
*copyc fst$tape_label_identifier
*copyc fst$tape_label_location_method
*copyc fst$tape_label_locator
*copyc fst$tape_label_sequence_header
*copyc oss$job_paged_literal
?? POP ??
*copyc clp$convert_string_to_date_time
*copyc clp$date_time_compare
*copyc osp$translate_bytes
*copyc pmp$get_compact_date_time

?? TITLE := 'fsp$analyze_file_expiration', EJECT ??
  PROCEDURE [XDCL, #GATE] fsp$analyze_file_expiration
    (    expiration_date: string (6);
     VAR file_is_expired: boolean;
     VAR status: ost$status);

    VAR
      current_date_time: clt$date_time,
      expiration_date_time: clt$date_time,
      expiration_string: string (7);

    IF expiration_date (2, 5) = '00000' THEN
      file_is_expired := TRUE;
      status.normal := TRUE;
    ELSE
      IF expiration_date (1, 1) = ' ' THEN
        expiration_string (1, 2) := '19';
        expiration_string (3, 5) := expiration_date (2, 5);
      ELSE
        expiration_string (1, 1):= '2';
        expiration_string (2, 6) := expiration_date (1, 6);
      IFEND;
      clp$convert_string_to_date_time (expiration_string, 'Y4J3',
            expiration_date_time, status);
      IF status.normal THEN
        expiration_date_time.date_specified := TRUE;
        expiration_date_time.time_specified := FALSE;
        pmp$get_compact_date_time (current_date_time.value, status);
        IF status.normal THEN
          current_date_time.date_specified := TRUE;
          current_date_time.time_specified := FALSE;
          CASE clp$date_time_compare (expiration_date_time,
                current_date_time) OF
          = clc$equal, clc$right_is_greater =
            file_is_expired := TRUE;
          ELSE
            file_is_expired := FALSE;
          CASEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND fsp$analyze_file_expiration;

?? TITLE := 'fsp$classify_tape_label', EJECT ??
*copy fsh$classify_tape_label

  PROCEDURE [XDCL, #GATE] fsp$classify_tape_label
    (    label_string: string ( * );
     VAR label_classification: fst$tape_label_classification);

    CONST
      max_label_identifiers = 7;

    VAR
      valid_label_identifiers: [oss$job_paged_literal, READ] array [1 .. max_label_identifiers] of
            fst$ansi_label_identifier := ['EOF', 'EOV', 'HDR', 'UHL', 'UTL', 'UVL', 'VOL'];

    VAR
      character_set: amt$internal_code,
      label_identifier: fst$ansi_label_identifier,
      label_identifier_index: 1 .. max_label_identifiers,
      label_number: fst$ansi_label_number,
      os_error: ost$error,
      translated_identifier_number: string (4),
      untranslated_identifier_number: string (4),
      valid_label_identifier: boolean,
      valid_label_number: boolean;

    label_classification.valid_label := FALSE;

    IF #SIZE (label_string) < fsc$min_tape_label_length THEN
      RETURN;
    IFEND;

    untranslated_identifier_number := label_string (1, 4);
    osp$translate_bytes (#LOC (untranslated_identifier_number), 4,
          #LOC (translated_identifier_number), 4, ^osv$ebcdic_to_ascii, os_error);

  /match_label_identifier_number/
    FOR label_identifier_index := LOWERBOUND (valid_label_identifiers)
          TO UPPERBOUND (valid_label_identifiers) DO
      valid_label_identifier := FALSE;
      IF untranslated_identifier_number (1, 3) = valid_label_identifiers [label_identifier_index] THEN
        valid_label_identifier := TRUE;
        character_set := amc$ascii;
        label_identifier := untranslated_identifier_number (1, 3);
        label_number := untranslated_identifier_number (4, 1);
      ELSEIF translated_identifier_number (1, 3) = valid_label_identifiers [label_identifier_index] THEN
        valid_label_identifier := TRUE;
        character_set := amc$ebcdic;
        label_identifier := translated_identifier_number (1, 3);
        label_number := translated_identifier_number (4, 1);
      IFEND;
      IF valid_label_identifier THEN
        IF (label_identifier = 'UHL') OR (label_identifier = 'UTL') THEN
          valid_label_number := ((label_number >= '1') AND (label_number <= '9')) OR
                ((label_number >= 'A') AND (label_number <= 'Z'));
        ELSE
          valid_label_number := (label_number >= '1') AND (label_number <= '9');
        IFEND;
        IF valid_label_number THEN
          label_classification.valid_label := TRUE;
          label_classification.character_set := character_set;
          label_classification.label_number := label_number;
          label_classification.label_identifier := label_identifier;
          IF label_identifier = 'EOF' THEN
            IF label_number = '1' THEN
              label_classification.label_kind := fsc$ansi_eof1_label_kind;
            ELSEIF label_number = '2' THEN
              label_classification.label_kind := fsc$ansi_eof2_label_kind;
            ELSE
              label_classification.label_kind := fsc$ansi_eofn_label_kind;
            IFEND;
          ELSEIF label_identifier = 'EOV' THEN
            IF label_number = '1' THEN
              label_classification.label_kind := fsc$ansi_eov1_label_kind;
            ELSEIF label_number = '2' THEN
              label_classification.label_kind := fsc$ansi_eov2_label_kind;
            ELSE
              label_classification.label_kind := fsc$ansi_eovn_label_kind;
            IFEND;
          ELSEIF label_identifier = 'HDR' THEN
            IF label_number = '1' THEN
              label_classification.label_kind := fsc$ansi_hdr1_label_kind;
            ELSEIF label_number = '2' THEN
              label_classification.label_kind := fsc$ansi_hdr2_label_kind;
            ELSE
              label_classification.label_kind := fsc$ansi_hdrn_label_kind;
            IFEND;
          ELSEIF label_identifier = 'VOL' THEN
            IF label_number = '1' THEN
              label_classification.label_kind := fsc$ansi_vol1_label_kind;
            ELSE
              label_classification.label_kind := fsc$ansi_voln_label_kind;
            IFEND;
          ELSEIF label_identifier = 'UHL' THEN
            label_classification.label_kind := fsc$ansi_uhla_label_kind;
          ELSEIF label_identifier = 'UTL' THEN
            label_classification.label_kind := fsc$ansi_utla_label_kind;
          ELSEIF label_identifier = 'UVL' THEN
            label_classification.label_kind := fsc$ansi_uvln_label_kind;
          IFEND;
        IFEND;
        EXIT /match_label_identifier_number/;
      IFEND;
    FOREND /match_label_identifier_number/;

  PROCEND fsp$classify_tape_label;

?? TITLE := 'fsp$locate_tape_label', EJECT ??
*copy fsh$locate_tape_label

  PROCEDURE [XDCL, #GATE] fsp$locate_tape_label
    (    label_sequence: ^SEQ ( * );
         label_identifier: fst$tape_label_identifier;
     VAR label_locator: fst$tape_label_locator);

    VAR
      label_index: fst$tape_label_count,
      p_label_block: ^SEQ ( * ),
      p_label_sequence: ^SEQ ( * ),
      p_label_sequence_header: ^fst$tape_label_sequence_header,
      p_label_string: ^string ( * ),
      p_tape_label_block_descriptor: ^fst$tape_label_block_descriptor,
      search_index: fst$tape_label_count;

    p_label_sequence := label_sequence;
    label_locator.label_found := FALSE;
    label_index := 0;

    IF p_label_sequence = NIL THEN
      RETURN;
    IFEND;

    RESET p_label_sequence;
    NEXT p_label_sequence_header IN p_label_sequence;
    IF p_label_sequence_header = NIL THEN
      RETURN;
    IFEND;

    IF p_label_sequence_header^.label_count = 0 THEN
      RETURN;
    IFEND;

    IF (label_identifier.location_method = fsc$tape_label_locate_by_index) AND
          ((label_identifier.label_index = 0) OR
          (label_identifier.label_index > p_label_sequence_header^.label_count)) THEN
      RETURN;
    IFEND;

  /scan_label_sequence/
    FOR search_index := 1 TO p_label_sequence_header^.label_count DO
      NEXT p_tape_label_block_descriptor IN p_label_sequence;
      IF p_tape_label_block_descriptor = NIL THEN
        EXIT /scan_label_sequence/;
      IFEND;

    /locate_label_block/
      BEGIN
        p_label_block := NIL;
        CASE p_tape_label_block_descriptor^.label_block_type OF
          = fsc$erroneous_tape_label_block =
            label_index := label_index + 1;
            IF p_tape_label_block_descriptor^.erroneous_label_transfer_length > 0 THEN
              NEXT p_label_block:
                    [[REP p_tape_label_block_descriptor^.erroneous_label_transfer_length OF CELL]]
                    IN p_label_sequence;
              IF p_label_sequence = NIL THEN
                EXIT /scan_label_sequence/;
              IFEND;
            IFEND;

          = fsc$non_tape_label_block =
            label_index := label_index + 1;
            IF p_tape_label_block_descriptor^.non_label_transfer_length > 0 THEN
              NEXT p_label_block:
                    [[REP p_tape_label_block_descriptor^.non_label_transfer_length OF CELL]]
                    IN p_label_sequence;
              IF p_label_sequence = NIL THEN
                EXIT /scan_label_sequence/;
              IFEND;
            IFEND;

          = fsc$normal_tape_label_block =
            label_index := label_index + 1;
            IF p_tape_label_block_descriptor^.normal_label_transfer_length > 0 THEN
              NEXT p_label_block:
                    [[REP p_tape_label_block_descriptor^.normal_label_transfer_length OF CELL]]
                    IN p_label_sequence;
              IF p_label_sequence = NIL THEN
                EXIT /scan_label_sequence/;
              IFEND;
            IFEND;

            IF label_identifier.location_method = fsc$tape_label_locate_by_kind THEN
              IF p_tape_label_block_descriptor^.normal_label_kind = label_identifier.label_kind THEN
                label_locator.label_found := TRUE;
                label_locator.label_block_descriptor := p_tape_label_block_descriptor;
                RESET p_label_block;
                label_locator.label_block := p_label_block;
                label_locator.label_index := label_index;
                EXIT /scan_label_sequence/;
              IFEND;
            ELSEIF label_identifier.location_method = fsc$tape_label_locate_by_ident THEN
              IF p_label_block <> NIL THEN
                NEXT p_label_string: [p_tape_label_block_descriptor^.normal_label_transfer_length]
                      IN p_label_block;
                IF p_label_string = NIL THEN
                  EXIT /scan_label_sequence/;
                IFEND;
                IF (p_label_string^ (1,3) = label_identifier.label_identifier) AND
                      (p_label_string^ (4,1) = label_identifier.label_number) THEN
                  label_locator.label_found := TRUE;
                  label_locator.label_block_descriptor := p_tape_label_block_descriptor;
                  RESET p_label_block;
                  label_locator.label_block := p_label_block;
                  label_locator.label_index := label_index;
                  EXIT /scan_label_sequence/;
                ELSE
                  CYCLE /scan_label_sequence/;
                IFEND;
              IFEND;
            IFEND;

          = fsc$null_tape_label_block =
            IF p_tape_label_block_descriptor^.null_label_transfer_length > 0 THEN
              NEXT p_label_block: [[REP p_tape_label_block_descriptor^.null_label_transfer_length OF CELL]] IN
                    p_label_sequence;
              IF p_label_block = NIL THEN
                EXIT /scan_label_sequence/;
              IFEND;
            IFEND;
            CYCLE /scan_label_sequence/;

          = fsc$tapemark_tape_label_block =
            label_index := label_index + 1;

        CASEND;

        IF (label_identifier.location_method = fsc$tape_label_locate_by_index) AND
              (label_index = label_identifier.label_index) THEN
          label_locator.label_found := TRUE;
          label_locator.label_block_descriptor := p_tape_label_block_descriptor;
          RESET p_label_block;
          label_locator.label_block := p_label_block;
          label_locator.label_index := label_index;
          EXIT /scan_label_sequence/;
        IFEND;

      END /locate_label_block/;

    FOREND /scan_label_sequence/;

  PROCEND fsp$locate_tape_label;

MODEND fsm$tape_label_interfaces_2dd;
*DECK DECK=FSM$TEST_HARNESS_COMMANDS EXPAND=TRUE

 table fsv$test_harness_cmnds type=command section_name=oss$job_paged_literal scope=xdcl ..
       m=fsm$test_harness_commands
 command (attach_file, attf) clp$attach_command xref
 command (change_catalog_entry, chace) clp$change_command xref
 command (change_family_name, chafn) fsp$th_change_family_command xref
 command (change_file_attributes, change_file_attribute, chafa) clp$change_file_attr_command xref
 command (compare_file, comf) clp$compare_command xref
 command (copy_file, copf) clp$copy_command xref
 command (create_catalog, crec) clp$define_catalog_command xref
 command (create_catalog_permit, crecp) clp$permit_catalog_command xref
 command (create_file, cref) clp$define_command xref
 command (create_file_permit, crefp) clp$permit_command xref
 command (delete_catalog, delc) clp$purge_catalog_command xref
 command (delete_catalog_permit, delcp) clp$delete_cat_permit_command xref
 command (delete_file, delf) clp$purge_command xref
 command (delete_file_permit, delfp) clp$delete_permit_command xref
 command (detach_file, detach_files, detf) clp$return_command xref
 command (display_catalog, disc) clp$display_catalog_command xref
 command (display_catalog_entry, disce) clp$display_file_command xref
 command (display_file_attributes, display_file_attribute, disfa) clp$display_file_attb_command xref
 command (rewind_file, rewind_files, rewf) clp$rewind_command xref
 command (set_file_attributes, set_file_attribute, setfa) clp$file_command xref
 command (set_job_recovery_test          ,setjrt) fsp$th_set_job_recovery_test xref
 command (known_point, kp) fsp$th_known_point xref
 command (bap$task_termination_cleanup, task_termination) fsp$th_task_cleanup xref
 command (job_exit) fsp$th_job_cleanup xref
 command (define_master_catalog, defmc)  fsp$th_defmc_command xref
 command (purge_master_catalog, purmc)  fsp$th_purmc_command  xref
 command recover_job_files fsp$th_recover_job_file_command xref
 command recover_files fsp$th_recover_files_command xref
 command (system_test_utility, systu) ttp$system_test_utility load
 command (set_administator_status, setas) fsp$th_set_admin_status_command xref
 command (set_job_number, setjn) fsp$th_set_job_number xref
 command (set_task_number, settn) fsp$th_set_task_number xref
 command (set_user_id, setui) fsp$th_set_user_id xref
 command (quit, qui) fsp$th_quit_command xref
 command (validate_catalog, valc) fsp$th_validate_catalog xref
 tablend


*DECK DECK=FSM$TEST_HARNESS_FS_SUPPORT EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'FS test harness support' ??
MODULE fsm$test_harness_fs_support;

{
{ This module contains support code for the FS test harness
{ in the following groups:
{   1. variables,
{   2. loader,
{   3. os,
{   4. device manager,
{   5. memory manager,
{   6. conversion to real bam,
{   7. miscellaneous,
{   8. accounting/validation,
{   9. set manager,
{  10. interactive,
{  11. logging,
{  12. tape (required and non-essential),
{  13. command language,
{  14. commands and functions.
{


*copyc clc$compiling_for_test_harness
*copyc fsc$compiling_for_test_harness

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc avt$password
*copyc dmt$chapter_number
*copyc dmt$error_condition_codes
*copyc dmt$file_share_history
*copyc dmt$locked_file
*copyc dmt$new_file_attribute
*copyc dmt$reconcile_locator
*copyc dmt$segment_file_information
*copyc dmt$stored_fmd
*copyc dmt$stored_fmd_size
*copyc dpt$window_id
*copyc fsc$local
*copyc fst$attachment_options
*copyc ift$terminal_attributes
*copyc iit$connection_description
*copyc jme$queued_file_conditions
*copyc jmt$job_class_set
*copyc jmt$job_count_range
*copyc jmt$job_status_count
*copyc jmt$job_status_options
*copyc jmt$job_status_results
*copyc mmt$attribute_keyword
*copyc mmt$lus_declarations
*copyc oss$job_pageable
*copyc oss$job_paged_literal
*copyc oss$mainframe_pageable
*copyc ost$heap
*copyc osv$mainframe_pageable_heap
*copyc pfd$catalog_alarm_table
*copyc pfd$queued_catalog_table
*copyc pfd$root
*copyc pfd$share_selector
*copyc pfd$usage_selector
*copyc pmt$initialization_value
*copyc pud$cycle_reference
*copyc pue$error_condition_codes
*copyc pus$literals
*copyc ste$error_condition_codes
*copyc amt$display_tft_options
*copyc iot$io_id
*copyc iot$tape_io_status
*copyc iot$tape_block_count
*copyc iot$tape_block_count
*copyc iot$io_id
*copyc iot$write_tape_description
*copyc cmt$element_name
*copyc cmt$logical_pp_table
*copyc cmt$logical_unit_table
*copyc dmt$mainframe_allocation_table
*copyc dmt$file_descriptor_entry
*copyc ost$cpu_state_table
*copyc syt$value_kinds
*copyc ttt$states
*copyc iot$read_tape_description
*copyc dmt$active_volume_table
*copyc oss$mainframe_wired
?? POP ??
*copyc amp$#copy_file
*copyc amp$close
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$set_segment_eoi
*copyc i#move
*copyc amp$#close
*copyc amp$#get_file_attributes
*copyc amp$#get_partial
*copyc amp$#get_segment_pointer
*copyc amp$#open
*copyc amp$#set_segment_eoi
*copyc bap$task_termination_cleanup
*copyc bap$validate_file_identifier
*copyc clp$convert_cyc_ref_to_cyc_sel
*copyc clp$end_scan_command_file
*copyc clp$get_fs_path_elements
*copyc clp$get_value
*copyc clp$pop_parameters
*copyc clp$push_parameters
*copyc clp$scan_argument_list
*copyc clp$scan_parameter_list
*copyc fmp$get_system_file_id
*copyc fmp$job_exit
*copyc fmp$recover_job_files
*copyc fsp$convert_fs_structure_to_pf
*copyc ifp$fap_control_ring_3
*copyc osp$append_status_parameter
*copyc osp$get_set_name
*copyc osp$set_status_abnormal
*copyc pfp$change_family_name
*copyc pfp$define_master_catalog
*copyc pfp$overhaul_catalog
*copyc pfp$overhaul_set
*copyc pfp$process_job_end
*copyc pfp$purge_master_catalog
*copyc pmp$load


  PROCEDURE [XREF] display
    (    display_line: string ( * <= 256));


  PROCEDURE [XREF] display_integer
    (    descriptor: string ( * <= 128);
         number: integer);


  PROCEDURE [XREF] display_integer_to_log
    (    descriptor: string ( * <= 128);
         number: integer);


  PROCEDURE [XREF] display_job_information
    (    display_current_job: boolean;
         display_current_task: boolean);


  PROCEDURE [XREF] display_status
    (    status: ost$status);


  PROCEDURE [XREF] display_status_to_log
    (    status: ost$status);


  PROCEDURE [XREF] display_to_log
    (    display_line: string ( * <= 256));


  PROCEDURE [XREF] set_job_terminated
    (    job_id: integer);


  PROCEDURE [XREF] set_task_terminated
    (    task_id: pmt$task_id);


  PROCEDURE [XREF] switch_jobs
    (    next_job_id: integer;
     VAR next_job_active: boolean);


  PROCEDURE [XREF] switch_tasks
    (    next_task_id: pmt$task_id;
     VAR next_task_active: boolean);



  VAR
    pfv$p_catalog_alarm_table: [XREF] pft$p_catalog_alarm_table;

  VAR
    pfv$p_newest_queued_catalog: [XREF] pft$p_queued_catalog;

  VAR
    pfv$p_queued_catalog_table: [XREF] pft$p_queued_catalog_table;

  VAR
    max_number_of_jobs: [XREF] integer,
    max_number_of_tasks: [XREF] pmt$task_id;

  ?IF NOT clc$compiling_for_test_harness THEN
    VAR
      userbam_utility_name: [XREF] ost$name;
  ?IFEND

?? TITLE := 'Stubbed variables', EJECT ??

  VAR
    lgv$global_log_ctl: [XDCL, #GATE, oss$mainframe_pageable] array [pmt$global_logs] of
          lgt$log_control_descriptor := [
          {pmc$account_log} [ * , 0, 0, 0, NIL, NIL],
          {pmc$engineering_log} [ * , 0, 0, 0, NIL, NIL],
          {pmc$job_history_log} [ * , 0, 0, 0, NIL, NIL],
          {pmc$statistic_log} [ * , 0, 0, 0, NIL, NIL],
          {pmc$system_log} [ * , 0, 0, 0, NIL, NIL]];

  VAR
    lgv$local_log_ctl: [XDCL, #GATE, oss$job_pageable] array [pmt$logs] of lgt$log_control_descriptor := [
          {pmc$job_account_log} [ * , 0, 0, 0, NIL, NIL],
          {pmc$job_statistic_log} [ * , 0, 0, 0, NIL, NIL],
          {pmc$account_log} [ * , 0, 0, 0, NIL, NIL],
          {pmc$engineering_log} [ * , 0, 0, 0, NIL, NIL],
          {pmc$job_history_log} [ * , 0, 0, 0, NIL, NIL],
          {pmc$statistic_log} [ * , 0, 0, 0, NIL, NIL],
          {pmc$system_log} [ * , 0, 0, 0, NIL, NIL],
          {pmc$job_log} [ * , 0, 0, 0, NIL, NIL]];


  VAR
    mmv$max_segment_length: [XDCL] integer := 99999744;

  VAR
    syv$inhibit_job_recovery: integer := 0;

  VAR
    syv$test_jr_job: [XDCL] syt$test_jr_set := $syt$test_jr_set [];

  TYPE
    syt$test_jr_set = set of 0 .. 255;

  VAR
    syv$test_jr_system: [XDCL] syt$test_jr_set := $syt$test_jr_set [];

  VAR
    fmv$system_path_table_size: [XDCL] integer := 40,
    fmv$system_cycle_table_size: [XDCL] integer := 12;

  VAR
    dfv$file_server_info_enabled: [XDCL] boolean := FALSE;

  VAR
    osv$system_family_name: [XDCL] ost$name := '$SYSTEM                        ';

  VAR
    mmv$preset_conversion_table: [XDCL] array [pmt$initialization_value]
        of integer;

  VAR
    iiv$connection_desc_ptr: [XDCL,#GATE] ^iit$connection_description := NIL;

  VAR
    iiv$network_identifier: [XDCL, #GATE] iit$network_identifier := iic$dsiaf_network;

  VAR
    dump_to_pf: [XDCL] boolean := FALSE,
    syv$job_template_ptr_array: [XDCL, #GATE] ^array [1 .. * ] of ^cell := NIL;

  VAR
    dmv$p_active_volume_table: [XDCL, STATIC, #GATE, oss$mainframe_wired] ^dmt$active_volume_table;

  ?IF NOT clc$compiling_for_test_harness THEN

    VAR
      clv$value_descriptors: [XDCL, READ, oss$job_paged_literal] array
            [clc$variable_reference .. clc$status_value] of string (8) := ['VARIABLE', 'FILE', 'NAME',
            'STRING', 'REAL', 'INTEGER', 'BOOLEAN', 'STATUS'];

  ?IFEND

  CONST
    fmd_header = 'PF_CATALOG_STORED_FMD          ';

  TYPE
    zzzz = (job, system);

  VAR
    current_user_id: ost$user_identification := ['GLS', 'NVE3'];

  VAR
    global_system_administrator: [XDCL] boolean := FALSE,
    global_family_administrator: [XDCL] boolean := TRUE;

  VAR
    global_file_entry_index: integer := 1;

  VAR
    pf_root_created: boolean := FALSE;

  VAR
    p_pf_root: ^pft$root := NIL;

  VAR
    real_terminal_connected: [STATIC] boolean := FALSE,
    real_terminal_input_file_id: [STATIC] amt$file_identifier,
    real_terminal_output_file_id: [STATIC] amt$file_identifier,
    real_terminal_command_file_id: [STATIC] amt$file_identifier;

  VAR
    segment_to_real_file_table: [STATIC] array [1 .. 100] of record
      segment_number: ost$segment,
      eoi: amt$file_byte_address,
      sfid: dmt$system_file_id,
      real_file_id: amt$file_identifier,
    recend := [REP 100 of [0, 0, [1, dmc$mainframe_job_file, 12], [2, 2]]];

  VAR
    file_usage_table: [STATIC] array [1 .. 100] of record
      eoi: amt$file_byte_address,
      file_usage: dmt$usage_count,
    recend := [REP 100 of [0, 0]];

  VAR
    last_real_file_name: [XDCL] amt$local_file_name;

?? TITLE := 'Loader stubs ', EJECT ??

  PROCEDURE [XDCL] lop$load_entry_point
    (    name: pmt$program_name;
         reference_ring: ost$valid_ring;
         reference_global_key: ost$key_lock_value;
         kind: pmt$loaded_address_kind;
     VAR address: pmt$loaded_address;
     VAR status {control} : ost$status);

    display (' lop$load_entry_point  LOADING');
    pmp$load (name, kind, address, status);
  PROCEND lop$load_entry_point;
?? TITLE := 'Os stubs ', EJECT ??

  PROCEDURE [XDCL] osp$generate_unique_binary_name
    (VAR name: ost$binary_unique_name;
     VAR status: ost$status);

    VAR
      sequence_number: [STATIC] integer := 1;

    {display (' osp$generate_unique_binary_name stub');
    status.normal := TRUE;
    name.processor.serial_number := 101;
    name.processor.model_number := pmc$cpu_model_p3;
    name.year := 1984;
    name.month := 6;
    name.day := 7;
    name.hour := 1;
    name.minute := 1;
    name.second := 1;
    name.sequence_number := sequence_number;
    sequence_number := sequence_number + 1;
  PROCEND osp$generate_unique_binary_name;
?? SKIP := 5 ??

  PROCEDURE [XDCL] osp$initialize_signature_lock
    (VAR lock: ost$signature_lock;
     VAR status: ost$status);
  PROCEND osp$initialize_signature_lock;
?? SKIP := 5 ??

  PROCEDURE [XDCL] osp$test_signature_lock
    (VAR lock: ost$signature_lock;
     VAR lock_status: ost$signature_lock_status;
     VAR status: ost$status);

    status.normal := TRUE;
    IF lock.lock_id = 0 THEN
      lock_status := osc$sls_not_locked;
    ELSE
      lock_status := osc$sls_locked_by_current_task;
    IFEND;
    {display (' osp$test_signature_lock stub');
  PROCEND osp$test_signature_lock;
?? SKIP := 5 ??

  PROCEDURE [XDCL] osp$clear_signature_lock
    (VAR lock: ost$signature_lock;
     VAR status: ost$status);

    status.normal := TRUE;
    IF lock.lock_id <> 12 THEN
      display (' lock not set ');
      osp$set_status_abnormal ('GS', 333000, 'LOCK NOT SET', status);
    IFEND;
    lock.lock_id := 0;
    {display (' osp$clear_signature_lock stub');
  PROCEND osp$clear_signature_lock;
?? SKIP := 5 ??

  PROCEDURE [XDCL] osp$recoverable_system_error
    (    error_message: string ( * );
         p_status: ^ost$status);

    display (' osp$recoverable_system_error');
    display (error_message);
    IF p_status <> NIL THEN
      display_status (p_status^);
    IFEND;
  PROCEND osp$recoverable_system_error;
?? SKIP := 5 ??


  PROCEDURE [XDCL] pmp$log_ascii
    (    text: pmt$log_msg_text;
         log: pmt$ascii_logset;
         origin: pmt$log_msg_origin;
     VAR status: ost$status);

    display (' pmp$log_ascii');
    display (text);
    status.normal := TRUE;
  PROCEND pmp$log_ascii;

?? SKIP := 5 ??


  PROCEDURE [XDCL] pmp$get_user_identification
    (VAR user_identification: ost$user_identification;
     VAR status: ost$status);

    status.normal := TRUE;
    user_identification := current_user_id;
  PROCEND pmp$get_user_identification;
?? SKIP := 5 ??

  PROCEDURE [XDCL] dpp$put_critical_message
    (    text: string ( * );
     VAR status: ost$status);

    display (' dpp$put_critical_message');
    display (text);
    status.normal := TRUE;
  PROCEND dpp$put_critical_message;
?? SKIP := 5 ??

  PROCEDURE [XDCL] syp$cycle;

    display ('syp$cycle');
  PROCEND syp$cycle;
?? TITLE := 'Device manager stubs', EJECT ??

  PROCEDURE [XDCL] dmp$close_segment_access_file
    (    pva: ^cell;
     VAR status: ost$status);

    VAR
      file_id: amt$file_identifier;

    remove_segment_number (#SEGMENT (pva), file_id);
    amp$#close (file_id, status);
  PROCEND dmp$close_segment_access_file;
?? SKIP := 5 ??

  PROCEDURE [XDCL] dmp$fetch_segment_file_info
    (    sfid: dmt$system_file_id;
         chapter: dmt$chapter_number;
     VAR file_info: dmt$segment_file_info;
     VAR status: ost$status);

    file_info.usage_count := file_usage_table [sfid.file_entry_index].file_usage;
    status.normal := TRUE;
  PROCEND dmp$fetch_segment_file_info;
?? SKIP := 5 ??

  PROCEDURE [XDCL] dmp$open_file_for_segment_acces
    (    sfid: dmt$system_file_id;
         p_seg_attributes: ^array [ * ] OF mmt$attribute_descriptor;
     VAR segment_pointer: mmt$segment_pointer;
     VAR status: ost$status);

    open_segment (sfid, file_usage_table [sfid.file_entry_index].eoi, segment_pointer, status);
  PROCEND dmp$open_file_for_segment_acces;
?? SKIP := 5 ??

  PROCEDURE [XDCL] dmp$create_file_entry
    (    file_type: dmt$file_type;
         file_usage: pft$usage_selections;
         file_share_selections: pft$share_selections;
         file_share_history: dmt$file_share_history;
         p_file_attribute: ^array [ * ] OF dmt$new_file_attribute;
         byte_address: amt$file_byte_address;
         assign_volume: boolean;
     VAR global_file_name: dmt$global_file_name;
     VAR system_file_id: dmt$system_file_id;
     VAR status: ost$status);

    osp$generate_unique_binary_name (global_file_name, status);
    system_file_id.file_entry_index := global_file_entry_index;
    display_integer (' dmp$create_file_entry jjj', system_file_id.file_entry_index);
    global_file_entry_index := global_file_entry_index + 1;
    system_file_id.computer_system_residence := dmc$mainframe_job_file;
    system_file_id.file_hash := 12;
    file_usage_table [system_file_id.file_entry_index].file_usage := 1;

  PROCEND dmp$create_file_entry;
?? SKIP := 5 ??

  PROCEDURE [XDCL] dmp$destroy_file
    (VAR system_file_id: dmt$system_file_id;
     VAR status: ost$status);

    VAR
      command_string: ost$name;

    status.normal := TRUE;
    display_integer (' dmp$destroy_file jjj', system_file_id.file_entry_index);
{    build_name ('$system.detach_file,jjj', system_file_id.file_entry_index, command_string); display ('
    {dmp$destroy_file stub');
{    {display (command_string);
{    clp$scan_command_line (command_string, status);
{    display_status (status);
{    global_file_entry_index := global_file_entry_index - 1;

  PROCEND dmp$destroy_file;
?? SKIP := 5 ??

  PROCEDURE [XDCL] dmp$fetch_eoi
    (    sfid: dmt$system_file_id;
     VAR eoi: amt$file_byte_address;
     VAR status: ost$status);

    display (' dmp$fetch_eoi stub');
    eoi := file_usage_table [sfid.file_entry_index].eoi;
    status.normal := TRUE;
  PROCEND dmp$fetch_eoi;
?? SKIP := 5 ??

  PROCEDURE [XDCL] dmp$set_eoi
    (    sfid: dmt$system_file_id;
         eoi: amt$file_byte_address;
     VAR status: ost$status);

    display (' dmp$set_eoi stub');
    file_usage_table [sfid.file_entry_index].eoi := eoi;
    status.normal := TRUE;
    {display (' exit dmp$set_eoi');
  PROCEND dmp$set_eoi;
?? SKIP := 5 ??
{ DEVICE MANAGEMENT STUBS
{   FMD FORMAT:
{      FMD_HEADER: SFID


  PROCEDURE [XDCL] dmp$attach_file
    (    global_file_name: dmt$global_file_name;
         file_type: dmt$file_type;
         stored_fmd: dmt$stored_fmd;
         file_usage: pft$usage_selections;
         file_share_selections: pft$share_selections;
         file_history: dmt$file_share_history;
         file_limit: amt$file_limit;
         locked_file: dmt$locked_file;
     VAR system_file_id: dmt$system_file_id;
     VAR status: ost$status);

    VAR
      p_fmd: ^dmt$stored_fmd,
      p_fmd_header: ^ost$name,
      p_sfid: ^dmt$system_file_id;

    p_fmd := ^stored_fmd;

    RESET p_fmd;
    NEXT p_fmd_header IN p_fmd;
    IF p_fmd_header = NIL THEN
      display (' NIL p_fmd_header IN dmp$attach_file');
    ELSEIF p_fmd_header^ <> fmd_header THEN
      display (' Unexpected fmd header');
      display (p_fmd_header^);
    IFEND;
    NEXT p_sfid IN p_fmd;
    system_file_id := p_sfid^;
    display_integer (' dmp$attach_file jjj', system_file_id.file_entry_index);
    file_usage_table [system_file_id.file_entry_index].file_usage :=
          file_usage_table [system_file_id.file_entry_index].file_usage + 1;

    status.normal := TRUE;
  PROCEND dmp$attach_file;
?? SKIP := 5 ??

  PROCEDURE [XDCL] dmp$destroy_permanent_file
    (    global_file_name: dmt$global_file_name;
         stored_fmd: dmt$stored_fmd;
     VAR status: ost$status);

    status.normal := TRUE;
  PROCEND dmp$destroy_permanent_file;
?? SKIP := 4 ??


  PROCEDURE [XDCL] dmp$detach_file
    (    system_file_id: dmt$system_file_id;
         flush_pages: boolean;
     VAR file_modified: boolean;
     VAR fmd_modified: boolean;
     VAR status: ost$status);

    display_integer (' dmp$detach_file jjj', system_file_id.file_entry_index);
    file_usage_table [system_file_id.file_entry_index].file_usage :=
          file_usage_table [system_file_id.file_entry_index].file_usage - 1;
    fmd_modified := FALSE;
    file_modified := FALSE;
    status.normal := TRUE;
  PROCEND dmp$detach_file;
?? SKIP := 4 ??

  PROCEDURE [XDCL] dmp$delete_file_descriptor
    (    system_file_id: dmt$system_file_id;
     VAR status: ost$status);


    IF file_usage_table [system_file_id.file_entry_index].file_usage > 0 THEN
      display_integer (' dmp$delete_file_descriptor did not delete  jjj', system_file_id.file_entry_index);
      osp$set_status_abnormal ('DM', dme$file_descriptor_not_deleted, ' file in use', status);
    ELSE
      display_integer (' dmp$delete_file_descriptor deleted  jjj', system_file_id.file_entry_index);
      status.normal := TRUE;
    IFEND;


  PROCEND dmp$delete_file_descriptor;
?? SKIP := 4 ??


  PROCEDURE [XDCL] dmp$get_stored_fmd
    (    system_file_id: dmt$system_file_id;
     VAR stored_fmd: dmt$stored_fmd;
     VAR status: ost$status);

    VAR
      p_fmd: ^dmt$stored_fmd,
      p_fmd_header: ^ost$name,
      p_sfid: ^dmt$system_file_id;

    p_fmd := ^stored_fmd;
    RESET p_fmd;
    NEXT p_fmd_header IN p_fmd;
    p_fmd_header^ := fmd_header;
    NEXT p_sfid IN p_fmd;
    p_sfid^ := system_file_id;

    status.normal := TRUE;
  PROCEND dmp$get_stored_fmd;
?? SKIP := 4 ??

  PROCEDURE [XDCL] dmp$get_stored_fmd_size
    (    system_file_id: dmt$system_file_id;
     VAR size_of_stored_fmd: dmt$stored_fmd_size;
     VAR status: ost$status);

    status.normal := TRUE;
    size_of_stored_fmd := 31 {#SIZE (ost$name)CY BUG} + #SIZE (dmt$system_file_id);
  PROCEND dmp$get_stored_fmd_size;
?? SKIP := 5 ??

  PROCEDURE [XDCL] dmp$build_sorted_dfl
    (    set_name: stt$set_name;
     VAR reconcile_locator: dmt$reconcile_locator;
     VAR status: ost$status);

    status.normal := TRUE;
  PROCEND dmp$build_sorted_dfl;
?? SKIP := 5 ??

  PROCEDURE [XDCL] dmp$reconcile_fmd
    (    reconcile_locator: dmt$reconcile_locator;
         global_file_name: dmt$global_file_name;
         stored_fmd: dmt$stored_fmd;
         purge_file: boolean;
     VAR stored_fmd_size: dmt$stored_fmd_size;
     VAR status: ost$status);

    VAR
      reconcile_count: [STATIC] integer := 0;

    reconcile_count := reconcile_count + 1;
    IF (reconcile_count = 3) OR (reconcile_count = 7) THEN
      osp$set_status_abnormal ('GS', 333000, 'unable to reconcile', status);
    ELSE
      IF reconcile_count > 10 THEN
        reconcile_count := 0;
      IFEND;
    IFEND;
    status.normal := TRUE;
  PROCEND dmp$reconcile_fmd;
?? SKIP := 5 ??

  PROCEDURE [XDCL] dmp$get_reconciled_fmd
    (    reconcile_locator: dmt$reconcile_locator;
         global_file_name: dmt$global_file_name;
         old_stored_fmd: dmt$stored_fmd;
     VAR new_stored_fmd: dmt$stored_fmd;
     VAR status: ost$status);

    new_stored_fmd := old_stored_fmd;
    status.normal := TRUE;
  PROCEND dmp$get_reconciled_fmd;
?? SKIP := 5 ??

  PROCEDURE [XDCL] dmp$release_sorted_dfl
    (    reconcile_locator: dmt$reconcile_locator;
     VAR status: ost$status);

    status.normal := TRUE;
  PROCEND dmp$release_sorted_dfl;
?? SKIP := 4 ??

  PROCEDURE [XDCL] dmp$device_file_list_update
    (    reconcile_locator: dmt$reconcile_locator;
     VAR status: ost$status);

    status.normal := TRUE;
  PROCEND dmp$device_file_list_update;


?? TITLE := 'Memory manager stubs', EJECT ??

  PROCEDURE [XDCL] mmp$open_file_segment
    (    sfid: dmt$system_file_id;
         seg_attributes_p: ^array [ * ] OF mmt$attribute_descriptor;
         pointer_kind: mmt$segment_pointer_kind;
         validation_ring_number: ost$valid_ring;
         chapter_number: dmt$chapter_number;
     VAR pointer: mmt$segment_pointer;
     VAR status: ost$status);



    VAR
      bam_pointer: amt$segment_pointer,
      file_name: ost$name,
      eoi: amt$file_length,
      display_string: string (31);

    {display (' mmp$open_file_segment stub');
    build_name ('jjj', sfid.file_entry_index, file_name);
{   get_file_length (file_name, eoi, status);
    last_real_file_name := file_name;

    open_segment (sfid, file_usage_table [sfid.file_entry_index].eoi, pointer, status);

  PROCEND mmp$open_file_segment;

  PROCEDURE get_file_length
    (    lfn: amt$local_file_name;
     VAR file_length: amt$file_length;
     VAR status: ost$status);

    VAR
      contains_data: boolean,
      existing_file: boolean,
      local_file: boolean,
      p_file_attributes: ^amt$get_attributes;

    PUSH p_file_attributes: [1 .. 1];
    p_file_attributes^ [1].key := amc$file_length;
    amp$#get_file_attributes (lfn, p_file_attributes^, local_file, existing_file, contains_data, status);
    IF status.normal THEN
      IF (NOT existing_file) OR (NOT contains_data) THEN
        file_length := 0;
      ELSE
        file_length := p_file_attributes^ [1].file_length;
      IFEND;
      display_integer (' user file length :', file_length);
    IFEND;
  PROCEND get_file_length;
?? SKIP := 5 ??

  PROCEDURE [XDCL] mmp$close_segment
    (VAR pointer: mmt$segment_pointer;
         validation_ring_number: ost$valid_ring;
     VAR status: ost$status);

    {display (' mmp$close_segment stub');

    VAR
      file_id: amt$file_identifier;

{  map segment number into REAL file identifier and real amp$#close
    display (' close segment');
    remove_segment_number (#SEGMENT (pointer.cell_pointer), file_id);
    amp$#close (file_id, status);
  PROCEND mmp$close_segment;
?? SKIP := 5 ??

  PROCEDURE [XDCL] mmp$set_segment_length
    (    pva: ^cell;
         validation_ring_number: ost$valid_ring;
         segment_length: ost$segment_length;
     VAR status: ost$status);

    {display (' mmp$set_segment_length stub');
    {map segment number into REAL           file id, and real amp$set_segment_eoi

    VAR
      j: integer,
      i: integer;

    status.normal := TRUE;
    FOR i := 1 TO 100 DO
      IF #SEGMENT (pva) = segment_to_real_file_table [i].segment_number THEN
        segment_to_real_file_table [i].eoi := segment_length;
        j := segment_to_real_file_table [i].sfid.file_entry_index;
        file_usage_table [j].eoi := segment_length;
{       store_eoi (pva, segment_length, segment_to_real_file_table [i].real_file_id);
        RETURN;
      IFEND;
    FOREND;
    display (' unable to find segment');
  PROCEND mmp$set_segment_length;

  PROCEDURE store_eoi
    (    pva: ^cell;
         segment_length: ost$segment_length;
         file_id: amt$file_identifier);

    VAR
      status: ost$status,
      bam_pointer: amt$segment_pointer;

    bam_pointer.kind := amc$cell_pointer;
    bam_pointer.cell_pointer := #ADDRESS (#RING (pva), #SEGMENT (pva), segment_length);
    amp$#set_segment_eoi (file_id, bam_pointer, status);
    IF NOT status.normal THEN
      display_status (status);
    IFEND;
  PROCEND store_eoi;
?? SKIP := 5 ??

  PROCEDURE [XDCL] mmp$get_segment_length
    (    pva: ^cell;
         validation_ring_number: ost$valid_ring;
     VAR segment_length: ost$segment_length;
     VAR status: ost$status);

    VAR
      i: integer;

    status.normal := TRUE;
    display (' mmp$get_segment_length');
    segment_length := 0;

    status.normal := TRUE;
    FOR i := 1 TO 100 DO
      IF #SEGMENT (pva) = segment_to_real_file_table [i].segment_number THEN
        segment_length := segment_to_real_file_table [i].eoi;
        RETURN;
      IFEND;
    FOREND;
    display (' unable to find segment');
  PROCEND mmp$get_segment_length;
?? SKIP := 5 ??

  PROCEDURE [XDCL] mmp$write_modified_pages
    (    pva: ^cell;
         length: ost$byte_count;
         waitopt: ost$wait;
     VAR status: ost$status);

    status.normal := TRUE; {no need to really do this }
    {display (' mmp$write_modified           pages stub');
  PROCEND mmp$write_modified_pages;
?? SKIP := 5 ??

  PROCEDURE [XDCL] mmp$lock_segment
    (    p: ^cell;
         access: mmt$lus_lock_type;
         wait: ost$wait;
     VAR status: ost$status);

    IF access = mmc$lus_lock_for_read THEN
      display (' mmp$lock_segment mmc$lus_lock_for_read');
    ELSE
      display (' mmp$lock_segment mmc$lus_lock_for_write');
    IFEND;

    status.normal := TRUE;
  PROCEND mmp$lock_segment;
?? SKIP := 5 ??



  PROCEDURE [XDCL] mmp$unlock_segment
    (    p: ^cell;
         page_disposition: mmt$lus_page_disposition;
         wait: ost$wait;
     VAR status: ost$status);

    status.normal := TRUE;
  PROCEND mmp$unlock_segment;
?? TITLE := 'Conversion to real bam routines. ', EJECT ??

  PROCEDURE open_segment
    (    sfid: dmt$system_file_id;
         eoi: amt$file_byte_address;
     VAR pointer: mmt$segment_pointer;
     VAR status: ost$status);

    VAR
      bam_pointer: amt$segment_pointer,
      file_name: ost$name,
      file_id: amt$file_identifier,
      display_string: string (31);

    build_name ('jjj', sfid.file_entry_index, file_name);
    display_string := ' Open real file name :';
    display_string (22, * ) := file_name;
    display (display_string);
{    clp$put_job_command_response (display_string, status); display (' amp$#open users file');
    amp$#open (file_name, amc$segment, NIL, file_id, status);
    IF status.normal THEN
      {display (' amp$#get_segment_pointer');
      amp$#get_segment_pointer (file_id, amc$cell_pointer, bam_pointer, status);
      IF status.normal THEN
        pointer.kind := mmc$cell_pointer;
        pointer.cell_pointer := bam_pointer.cell_pointer;
        store_segment_number (#SEGMENT (bam_pointer.cell_pointer), sfid, eoi, file_id);
      ELSE
        {display_status (status);
      IFEND;
    IFEND;
  PROCEND open_segment;
?? SKIP := 5 ??

  PROCEDURE build_name
    (    name_start: string ( * ),
         name_end: integer;
     VAR name: ost$name);

    VAR
      number_length: integer,
      working_string: string (29);

    name := '';
    working_string := '';
    STRINGREP (working_string, number_length, name_end);
    name := name_start;
    name ((STRLENGTH (name_start) + 1), * ) := working_string (2, number_length);
{    display (name);
  PROCEND build_name;

?? SKIP := 5 ??

  PROCEDURE store_segment_number
    (    segment_number: ost$segment;
         sfid: dmt$system_file_id;
         eoi: amt$file_byte_address;
         file_id: amt$file_identifier);

    VAR
      i: integer;

    FOR i := 1 TO 100 DO
      IF segment_to_real_file_table [i].segment_number = 0 THEN
        segment_to_real_file_table [i].segment_number := segment_number;
        segment_to_real_file_table [i].real_file_id := file_id;
        segment_to_real_file_table [i].sfid := sfid;
        segment_to_real_file_table [i].eoi := eoi;
        RETURN;
      IFEND;
    FOREND;
    display (' No file id slots !!!!!!!!!!!!!!!!');
  PROCEND store_segment_number;
?? SKIP := 5 ??

  PROCEDURE remove_segment_number
    (    segment_number: ost$segment;
     VAR file_id: amt$file_identifier);

    VAR
      i: integer;

    FOR i := 1 TO 100 DO
      IF segment_number = segment_to_real_file_table [i].segment_number THEN
        file_id := segment_to_real_file_table [i].real_file_id;
        segment_to_real_file_table [i].segment_number := 0;
        RETURN;
      IFEND;
    FOREND;
    display (' unable to find segment');
  PROCEND remove_segment_number;

?? TITLE := 'Miscellaneous stubs', EJECT ??


  PROCEDURE [XDCL] syp$push_inhibit_job_recovery;

    {display (' syp$push_inhibit_job_recovery');
    syv$inhibit_job_recovery := syv$inhibit_job_recovery + 1;

  PROCEND syp$push_inhibit_job_recovery;

?? SKIP := 5 ??

  PROCEDURE [XDCL] syp$pop_inhibit_job_recovery;

    {display ('syp$pop_inhibit_job_recovery');
    IF syv$inhibit_job_recovery <= 0 THEN
      display ('*** BUG pop called without push');
    ELSE
      syv$inhibit_job_recovery := syv$inhibit_job_recovery - 1;
    IFEND;
  PROCEND syp$pop_inhibit_job_recovery;
?? SKIP := 5 ??

  PROCEDURE [XDCL] syp$invalidate_open_sfid
    (    sfid: dmt$system_file_id;
     VAR status: ost$status);

    status.normal := TRUE;
  PROCEND syp$invalidate_open_sfid;

?? SKIP := 5 ??

  PROCEDURE [XDCL] syp$clear_job_recovery_test
    (    t: zzzz;
         option: 0 .. 255);

    IF t = job THEN
      syv$test_jr_job := syv$test_jr_job - $syt$test_jr_set [option];
    ELSE
      syv$test_jr_system := syv$test_jr_system - $syt$test_jr_set [option];
    IFEND;
  PROCEND syp$clear_job_recovery_test;


?? SKIP := 5 ??

  PROCEDURE [XDCL] syp$replace_sfid
    (    old_sfid: dmt$system_file_id;
         new_sfid: dmt$system_file_id;
     VAR status: ost$status);

    status.normal := TRUE;
  PROCEND syp$replace_sfid;
?? SKIP := 5 ??

  FUNCTION [XDCL] jmp$job_file_fap
    (    local_file_name: amt$local_file_name): amt$fap_pointer;

    { display (' jmp$job_file_fap ');
    jmp$job_file_fap := NIL;
  FUNCEND jmp$job_file_fap;
?? SKIP := 5 ??
?? TITLE := 'Accounting / validation stubs ', EJECT ??

  PROCEDURE [XDCL] avp$get_user_set
    (    user_id: ost$user_identification;
     VAR set_name: stt$set_name;
     VAR status: ost$status);

    osp$get_set_name (user_id.family, set_name, status);
  PROCEND avp$get_user_set;
?? SKIP := 5 ??

  FUNCTION [XDCL] avp$ring_min: ost$ring;

    avp$ring_min := 11;
  FUNCEND avp$ring_min;
?? SKIP := 5 ??
?? TITLE := 'Set manager stubs ', EJECT ??

?? SKIP := 5 ??

  PROCEDURE [XDCL] stp$recover_jobs_sets
    (VAR status: ost$status);

    status.normal := TRUE;
  PROCEND stp$recover_jobs_sets;
?? SKIP := 5 ??

  PROCEDURE [XDCL] stp$get_set_owner
    (    set_name: stt$set_name;
     VAR set_owner: ost$user_identification;
     VAR status: ost$status);

    set_owner.family := '$SYSTEM';
    set_owner.user := '$SYSTEM';
    status.normal := TRUE;
  PROCEND stp$get_set_owner;
?? SKIP := 5 ??

  PROCEDURE [XDCL] stp$get_pf_root
    (    set_name: stt$set_name;
     VAR pf_root_size: pft$root_size;
     VAR pf_root: pft$root;
     VAR status: ost$status);

    VAR
      p_root_container: ^pft$root,
      p_local_pf_root: ^pft$root;

    IF pf_root_created THEN
      pf_root_size := #SIZE (p_pf_root^);
      p_root_container := ^pf_root;
      RESET p_root_container;
      NEXT p_local_pf_root: [[REP pf_root_size OF cell]] IN p_root_container;
      p_local_pf_root^ := p_pf_root^;
    ELSE
      osp$set_status_abnormal ('ST', ste$pf_root_not_stored, 'NVESET', status);
    IFEND;
  PROCEND stp$get_pf_root;
?? SKIP := 5 ??

  PROCEDURE [XDCL] stp$get_pf_root_size
    (    set_name: stt$set_name;
     VAR pf_root_size: pft$root_size;
     VAR status: ost$status);

    IF pf_root_created THEN
      pf_root_size := #SIZE (p_pf_root^);
    ELSE
      osp$set_status_abnormal ('ST', ste$pf_root_not_stored, 'NVESET', status);
    IFEND;
  PROCEND stp$get_pf_root_size;
?? SKIP := 5 ??

  PROCEDURE [XDCL] stp$store_pf_root
    (    set_name: stt$set_name;
         pf_root: pft$root;
     VAR status: ost$status);

    pf_root_created := TRUE;
    ALLOCATE p_pf_root: [[REP #SIZE (pf_root) OF cell]] IN osv$mainframe_pageable_heap^;
    p_pf_root^ := pf_root;
    status.normal := TRUE;
  PROCEND stp$store_pf_root;
?? SKIP := 5 ??

  PROCEDURE [XDCL] avp$login_user
    (    user_name: ost$user_name;
         family_name: ost$family_name;
         password: avt$password;
         job_class: jmt$job_class;
     VAR account: avt$account_name;
     VAR project: avt$project_name;
     VAR status: ost$status);

    account := 'DUM_ACCOUNT';
    project := 'DUMMY_PROJECT';
    status.normal := TRUE;
  PROCEND avp$login_user;

  PROCEDURE [XDCL] ofp$enable_stop_key;

  PROCEND ofp$enable_stop_key;


  PROCEDURE [XDCL] jmp$set_job_class_limits
    (    job_class_set: jmt$job_class_set;
         class_limit_value: jmt$job_count_range;
     VAR status: ost$status);

    status.normal := TRUE;
  PROCEND jmp$set_job_class_limits;


  PROCEDURE [XDCL] jmp$get_job_status
    (    job_status_options: ^jmt$job_status_options;
         job_status_results: ^jmt$job_status_results;
     VAR number_of_jobs_found: jmt$job_status_count;
     VAR status: ost$status);

    number_of_jobs_found := 0;
    osp$set_status_abnormal ('JM', jme$no_jobs_were_found, '', status);
  PROCEND jmp$get_job_status;

?? TITLE := 'Interactive stubs', EJECT ??

  PROCEDURE [XDCL] ifp$mark_attributes_change
    (    change_source: ift$connection_attribute_source;
     VAR status: ost$status);

    status.normal := TRUE;
  PROCEND ifp$mark_attributes_change;
?? SKIP := 5 ??

  PROCEDURE [XDCL] ifp$fap_control
    (    file_id: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      converted_call_block: amt$call_block,
      converted_operation: amt$fap_operation,
      file_id_valid: boolean,
      real_file_id: amt$file_identifier,
      real_terminal_output_file: amt$local_file_name,
      real_terminal_input_file: amt$local_file_name,
      real_terminal_command_file: amt$local_file_name;

    IF NOT real_terminal_connected THEN
      real_terminal_input_file := 'GARYS_INPUT_TERMINAL';
      display_to_log ('opening GARYS_INPUT_TERMINAL');
      amp$#open (real_terminal_input_file, amc$record, NIL, real_terminal_input_file_id, status);

      real_terminal_output_file := 'GARYS_OUTPUT_TERMINAL';
      display_to_log ('opening GARYS_OUTPUT_TERMINAL');
      amp$#open (real_terminal_output_file, amc$record, NIL, real_terminal_output_file_id, status);

      real_terminal_input_file := 'GARYS_COMMAND_TERMINAL';
      display_to_log ('opening GARYS_COMMAND_TERMINAL');
      amp$#open (real_terminal_input_file, amc$record, NIL, real_terminal_command_file_id, status);
      real_terminal_connected := TRUE;
    IFEND;

    display_to_log (' ifp$fap_control');
    convert_fake_to_real_fid (file_id, real_file_id, file_id_valid);
    display_integer_to_log (' original operation', call_block.operation);
    converted_operation := call_block.operation;
    converted_call_block := call_block;
    converted_call_block.operation := converted_operation;
    display_integer_to_log (' converted operation', converted_operation);

    CASE converted_operation OF
    = amc$open_req =
      display_to_log (' open request - NOT calling interactive');
    = amc$close_req =
      display_to_log (' close request - NOT calling interactive');
    ELSE
      display_to_log (' ifp$fap_control_ring_3');
      ifp$fap_control_ring_3 (real_file_id, converted_call_block, layer_number, status);
      display_status (status);
    CASEND;
  PROCEND ifp$fap_control;

?? SKIP := 5 ??

  PROCEDURE convert_fake_to_real_fid
    (    fake_file_id: amt$file_identifier;
     VAR real_file_id: amt$file_identifier;
     VAR file_id_valid: boolean);

    VAR
      lfn: amt$local_file_name,
      file_instance: ^bat$task_file_entry;

    bap$validate_file_identifier (fake_file_id, file_instance, file_id_valid);
    IF file_id_valid THEN
      lfn := file_instance^.local_file_name;
      display_to_log (lfn);
      IF lfn = 'INPUT' THEN
        real_file_id := real_terminal_input_file_id;
      ELSEIF lfn = 'COMMAND' THEN
        real_file_id := real_terminal_command_file_id;
      ELSEIF lfn = 'OUTPUT' THEN
        real_file_id := real_terminal_output_file_id;
      ELSE
        display_to_log (' unexpected lfn ');
        real_file_id := real_terminal_output_file_id;
      IFEND;
    ELSE
      real_file_id := real_terminal_output_file_id;
      display_to_log (' invalid file identifier');
    IFEND;
  PROCEND convert_fake_to_real_fid;
?? SKIP := 10 ??

  PROCEDURE [XDCL] ifp$get_page_length_width
    (    terminal_file_name: amt$local_file_name;
     VAR page_length_width: array [1 .. 2] of ift$terminal_attribute;
     VAR status: ost$status);

    page_length_width [1].key := ifc$page_length;
    page_length_width [1].page_length := 80;
    page_length_width [2].key := ifc$page_width;
    page_length_width [2].page_width := 24;

  PROCEND ifp$get_page_length_width;

?? SKIP := 3 ??

  PROCEDURE [XDCL, #GATE] ifp$store_term_conn_attributes
    (    file_identifier: amt$file_identifier;
         terminal_attributes: ift$connection_attributes;
     VAR status: ost$status);

    VAR
      i: integer,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      real_file_id: amt$file_identifier,
      store_attributes: ^ift$connection_attributes;

    call_block.operation := ifc$store_terminal_req;

    PUSH store_attributes: [LOWERBOUND (terminal_attributes) .. UPPERBOUND
          (terminal_attributes)];
    FOR i := 1 TO UPPERBOUND (terminal_attributes) DO
      CASE terminal_attributes [i].key OF
      = ifc$prompt_file_identifier =
        convert_fake_to_real_fid (terminal_attributes [i].prompt_file_identifier,
              real_file_id, file_id_is_valid);
        store_attributes^ [i].key := ifc$prompt_file_identifier;
        store_attributes^ [i].prompt_file_identifier := real_file_id;

      = ifc$prompt_string =
        store_attributes^ [i] := terminal_attributes [i];
      ELSE
        display_to_log (' unsupported terminal key');
        store_attributes^ [i].key := ifc$null_connection_attribute;
      CASEND;
    FOREND;
    call_block.store_terminal.terminal_attributes := store_attributes;
    convert_fake_to_real_fid (file_identifier, real_file_id, file_id_is_valid);
    display_to_log (' ifp$fap_control_ring_3 store');
    ifp$fap_control_ring_3 (real_file_id, call_block, {layer_number =} 0, status);
    display_status_to_log (status);
    display_to_log (' fake ifp$store_term_conn_attributes');
    status.normal := TRUE;
  PROCEND ifp$store_term_conn_attributes;

?? TITLE := 'Logging stubs', EJECT ??

  PROCEDURE [XDCL, #GATE] lgp$get_global_log_description
    (    global_log: pmt$global_logs;
     VAR log_cycle: lgt$log_cycle;
     VAR previous_length: lgt$length_of_log_entry;
     VAR base_offset: ^SEQ ( * );
     VAR write_offset: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      global_log_lcd_p: ^lgt$log_control_descriptor,
      old_te: 0 .. 3;

    status.normal := TRUE;

    global_log_lcd_p := ^lgv$global_log_ctl [global_log];

    log_cycle := global_log_lcd_p^.log_cycle;
    previous_length := global_log_lcd_p^.previous_length;
    base_offset := global_log_lcd_p^.base_offset;
    write_offset := global_log_lcd_p^.write_offset;

  PROCEND lgp$get_global_log_description;
?? SKIP := 3 ??

  PROCEDURE [XDCL, #GATE] lgp$get_local_log_description
    (    local_log: pmt$logs;
     VAR log_cycle: lgt$log_cycle;
     VAR previous_length: lgt$length_of_log_entry;
     VAR base_offset: ^SEQ ( * );
     VAR write_offset: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      local_log_lcd_p: ^lgt$log_control_descriptor,
      old_te: 0 .. 3;

    status.normal := TRUE;

    local_log_lcd_p := ^lgv$local_log_ctl [local_log];

    log_cycle := local_log_lcd_p^.log_cycle;
    previous_length := local_log_lcd_p^.previous_length;
    base_offset := local_log_lcd_p^.base_offset;
    write_offset := local_log_lcd_p^.write_offset;

  PROCEND lgp$get_local_log_description;
?? SKIP := 3 ??



  PROCEDURE [XDCL] lgp$get_entry_from_global_log
    (    global_log: pmt$global_logs;
         log_cycle: lgt$log_cycle;
     VAR log_address: ^SEQ ( * );
     VAR previous_length: lgt$length_of_log_entry;
     VAR current_length: lgt$length_of_log_entry;
     VAR entry: string ( * );
     VAR status: ost$status);

    osp$set_status_abnormal ('GS', 333000, ' unable to read log', status);

  PROCEND lgp$get_entry_from_global_log;



?? SKIP := 3 ??

  PROCEDURE [XDCL] lgp$get_entry_from_local_log
    (    local_log: pmt$logs;
         log_cycle: lgt$log_cycle;
     VAR log_address: ^SEQ ( * );
     VAR previous_length: lgt$length_of_log_entry;
     VAR current_length: lgt$length_of_log_entry;
     VAR entry: string ( * );
     VAR status: ost$status);


    osp$set_status_abnormal ('GS', 333000, ' unable to read log', status);

  PROCEND lgp$get_entry_from_local_log;
?? TITLE := 'Tape stubs ' ??
?? NEWTITLE := 'Required', EJECT ??

  PROCEDURE [XDCL] dmp$job_tape_table_recovery
    (VAR any_tapes: boolean;
     VAR status: ost$status);

    {display (' dmp$job_tape_table_recovery stub');
    any_tapes := FALSE;
    status.normal := TRUE;
  PROCEND dmp$job_tape_table_recovery;
?? SKIP := 5 ??
  PROCEDURE [XDCL] dmp$assign_tape_volume (sfid: dmt$system_file_id;
        path_handle_name: fst$path_handle_name;
        label_type: amt$label_type;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

?? TITLE := 'Non essential', EJECT ??

  PROCEDURE [XDCL] dmp$release_tape
    (    rel_req: rmt$release_tape_request;
     VAR status: ost$status);

    {display (' dmp$release_tape stub');
    status.normal := TRUE;
  PROCEND dmp$release_tape;
?? SKIP := 5 ??

  PROCEDURE [XDCL] dmp$close_tape_volume
    (    sfid: dmt$system_file_id;
     VAR status: ost$status);

    osp$set_status_abnormal ('GS', 330000, 'unsupported tape request', status);
  PROCEND dmp$close_tape_volume;

  PROCEDURE [XDCL] dmp$create_tape_file_sfid
    (    p_removable_media_req_info: ^fmt$removable_media_req_info;
         p_volume_list: ^rmt$volume_list;
     VAR system_file_id: gft$system_file_identifier;
     VAR status: ost$status);

    osp$set_status_abnormal ('GS', 330000, 'unsupported tape request', status);
  PROCEND dmp$create_tape_file_sfid;

  PROCEDURE [XDCL] dmp$reset_tape_volume
    (    sfid: dmt$system_file_id;
     VAR status: ost$status);

    osp$set_status_abnormal ('GS', 330000, 'unsupported tape request', status);
  PROCEND dmp$reset_tape_volume;

  PROCEDURE [XDCL] fmp$logically_position_tape
    (    local_file_name: amt$local_file_name;
     VAR status: ost$status);

    osp$set_status_abnormal ('GS', 330000, 'unsupported tape request', status);
  PROCEND fmp$logically_position_tape;

  PROCEDURE [XDCL] fmp$release_resource
    (    release_request: rmt$release_tape_request;
     VAR status: ost$status);

    osp$set_status_abnormal ('GS', 330000, 'unsupported tape request', status);
  PROCEND fmp$release_resource;

  PROCEDURE [XDCL] fmp$reserve_resource
    (    reserve_request: rmt$reserve_tape_request;
     VAR status: ost$status);

    osp$set_status_abnormal ('GS', 330000, 'unsupported tape request', status);
  PROCEND fmp$reserve_resource;

?? OLDTITLE ??
?? TITLE := 'Command language stubs', EJECT ??

  ?IF NOT clc$compiling_for_test_harness THEN

    PROCEDURE [XDCL] clp$convert_cycle_to_string
      (    cycle_selector: clt$cycle_selector;
       VAR cycle_string: ost$string);

      cycle_string.size := 22;
      cycle_string.value := 'gls lazy in bam$stubs';
    PROCEND clp$convert_cycle_to_string;
?? SKIP := 5 ??

    PROCEDURE [XDCL] clp$get_ultimate_connection
      (    lfn: amt$local_file_name;
       VAR ultimate_lfn: amt$local_file_name;
       VAR status: ost$status);

      display (' clp$get_ultimiate_connection stub');
      status.normal := TRUE;
      ultimate_lfn := lfn;
    PROCEND clp$get_ultimate_connection;
?? SKIP := 5 ??

    PROCEDURE [XDCL] clp$return_connected_file
      (    local_file_name: amt$local_file_name);

    PROCEND clp$return_connected_file;
?? SKIP := 5 ??

    PROCEDURE [XDCL] clp$return_local_file
      (    local_file_name: amt$local_file_name);

    PROCEND clp$return_local_file;
?? SKIP := 5 ??

    PROCEDURE [XDCL] osp$generate_log_message
      (    logs: pmt$ascii_logset;
           message_status: ost$status;
       VAR status: ost$status);

      display ('osp$generate_log_message');
      display_status (message_status);
      status.normal := TRUE;
    PROCEND osp$generate_log_message;
  ?IFEND
?? TITLE := 'Commands and functions' ??
?? NEWTITLE := 'fsp$th_set_job_number', EJECT ??

  PROCEDURE [XDCL] fsp$th_set_job_number
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    ?IF NOT clc$compiling_for_test_harness THEN

{  pdt set_job_number (job, j: integer  = 2
{     status)

?? PUSH (LISTEXT := ON) ??

      VAR
        set_job_number: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
              [^set_job_number_names, ^set_job_number_params];

      VAR
        set_job_number_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
              clt$parameter_name_descriptor := [['JOB', 1], ['J', 1], ['STATUS', 2]];

      VAR
        set_job_number_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
              clt$parameter_descriptor := [

{ JOB J }
        [[clc$optional_with_default, ^set_job_number_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
              [NIL, clc$integer_value, -9223372036854775806, 9223372036854775807]],

{ STATUS }
        [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
              [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

      VAR
        set_job_number_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '2';

?? POP ??

      VAR
        value: clt$value,
        next_job_active: boolean,
        next_job: integer;


      clp$scan_parameter_list (parameter_list, set_job_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$get_value ('JOB', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      next_job := value.int.value;

      IF (next_job < 1) OR (next_job > max_number_of_jobs) THEN
        display ('*** WARNING - THE SELECTED JOB IS AN INCORRECT JOB NUMBER ****');
      ELSE
        switch_jobs (next_job, next_job_active);
        IF NOT next_job_active THEN
          display ('*** WARNING - THE SELECTED JOB HAS BEEN TERMINATED ALREADY ****');
        IFEND;
      IFEND;

      display_job_information (TRUE, TRUE);

    ?IFEND

  PROCEND fsp$th_set_job_number;
?? TITLE := 'fsp$th_set_task_number', EJECT ??

  PROCEDURE [XDCL] fsp$th_set_task_number
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    ?IF NOT clc$compiling_for_test_harness THEN

{  pdt set_task_number (task, j: integer = 2
{     status)

?? PUSH (LISTEXT := ON) ??

      VAR
        set_task_number: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
              [^set_task_number_names, ^set_task_number_params];

      VAR
        set_task_number_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
              clt$parameter_name_descriptor := [['TASK', 1], ['J', 1], ['STATUS', 2]];

      VAR
        set_task_number_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
              clt$parameter_descriptor := [

{ TASK J }
        [[clc$optional_with_default, ^set_task_number_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
              [NIL, clc$integer_value, -9223372036854775806, 9223372036854775807]],

{ STATUS }
        [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
              [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

      VAR
        set_task_number_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '2';

?? POP ??

      VAR
        value: clt$value,
        next_task_active: boolean,
        next_task: integer;


      clp$scan_parameter_list (parameter_list, set_task_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$get_value ('TASK', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      next_task := value.int.value;

      IF (next_task < 1) OR (next_task > max_number_of_tasks) THEN
        display (' **** WARNING - SELECTED TASK NUMBER IS INCORRECT ***');
      ELSE
        switch_tasks (next_task, next_task_active);
        IF NOT next_task_active THEN
          display (' **** WARNING - SELECTED TASK ALREADY TERMINATED ***');
        IFEND;
      IFEND;

      display_job_information (FALSE, TRUE);

    ?IFEND

  PROCEND fsp$th_set_task_number;
?? TITLE := 'fsp$th_set_user_id', EJECT ??

  PROCEDURE [XDCL] fsp$th_set_user_id
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      p_user_path: ^pft$path,
      path_container: clt$path_container;


    crack_user_path (parameter_list, path_container, p_user_path, status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;
    current_user_id.family := p_user_path^ [1];
    current_user_id.user := p_user_path^ [2];

  PROCEND fsp$th_set_user_id;
?? TITLE := 'fsp$th_known_point', EJECT ??

  PROCEDURE [XDCL] fsp$th_known_point
    (    pl: clt$parameter_list;
     VAR status: ost$status);

    { setb kp m=bam$stubs p=known_point bo=78(16)

    VAR
      i: integer;

    i := 77;
    i := 123;
    i := 444;
    i := 5678;
  PROCEND fsp$th_known_point;
?? TITLE := 'fsp$th_set_job_recovery_test', EJECT ??

  PROCEDURE [XDCL] fsp$th_set_job_recovery_test
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PDT setjrt_pdt (environment,e: key job, system, clear_job, clear_system =
{job
{      option: integer 0 .. 255 = $required)

?? PUSH (LISTEXT := ON) ??

    VAR
      setjrt_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^setjrt_pdt_names, ^setjrt_pdt_params];

    VAR
      setjrt_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['ENVIRONMENT', 1], ['E', 1], ['OPTION', 2]];

    VAR
      setjrt_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ ENVIRONMENT E }
      [[clc$optional_with_default, ^setjrt_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [^setjrt_pdt_kv1, clc$keyword_value]],

{ OPTION }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 255]]];

    VAR
      setjrt_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := ['JOB',
            'SYSTEM', 'CLEAR_JOB', 'CLEAR_SYSTEM'];

    VAR
      setjrt_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'job';

?? POP ??

    VAR
      clear: boolean,
      t: (job, system),
      value: clt$value;

    clp$scan_parameter_list (parameter_list, setjrt_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('ENVIRONMENT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.name.value = 'JOB' THEN
      t := job;
      clear := FALSE;
    ELSEIF value.name.value = 'CLEAR_JOB' THEN
      t := job;
      clear := TRUE;
    ELSEIF value.name.value = 'CLEAR_SYSTEM' THEN
      t := system;
      clear := TRUE;
    ELSE
      t := system;
      clear := FALSE;
    IFEND;

    clp$get_value ('OPTION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF clear THEN
      IF t = job THEN
        syv$test_jr_job := syv$test_jr_job - $syt$test_jr_set [value.int.value];
      ELSE
        syv$test_jr_system := syv$test_jr_system - $syt$test_jr_set [value.int.value];
      IFEND;
    ELSE
      IF t = job THEN
        syv$test_jr_job := syv$test_jr_job + $syt$test_jr_set [value.int.value];
      ELSE
        syv$test_jr_system := syv$test_jr_system + $syt$test_jr_set [value.int.value];
      IFEND;

    IFEND;

  PROCEND fsp$th_set_job_recovery_test;
?? TITLE := 'fsp$th_change_family_command', EJECT ??

  PROCEDURE [XDCL] fsp$th_change_family_command
    (    pl: clt$parameter_list;
     VAR status: ost$status);

    VAR
      new_value: clt$value,
      set_name: stt$set_name,
      value: clt$value;

{ pdt chafn_pdt (family_name, fn: name = $required
{   new_family_name, nfn: name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      chafn_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^chafn_pdt_names, ^chafn_pdt_params];

    VAR
      chafn_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
            clt$parameter_name_descriptor := [['FAMILY_NAME', 1], ['FN', 1], ['NEW_FAMILY_NAME', 2],
            ['NFN', 2], ['STATUS', 3]];

    VAR
      chafn_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ FAMILY_NAME FN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ NEW_FAMILY_NAME NFN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??
    clp$scan_parameter_list (pl, chafn_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_value ('FAMILY_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_value ('NEW_FAMILY_NAME', 1, 1, clc$low, new_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$get_set_name (value.name.value, set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$change_family_name (set_name, value.name.value, new_value.name.value, status);

  PROCEND fsp$th_change_family_command;

?? TITLE := 'fsp$th_set_admin_status_command', EJECT ??

  PROCEDURE [XDCL] fsp$th_set_admin_status_command
    (    pl: clt$parameter_list;
     VAR status: ost$status);

{ PDT chadn_pdt (admin, a: key of system, family, none = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      chadn_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^chadn_pdt_names, ^chadn_pdt_params];

    VAR
      chadn_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['ADMIN', 1], ['A', 1], ['STATUS', 2]];

    VAR
      chadn_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ ADMIN A }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^chadn_pdt_kv1, clc$keyword_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      chadn_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := ['OF', 'SYSTEM',
            'FAMILY', 'NONE'];

?? POP ??

    VAR
      value: clt$value;

    clp$scan_parameter_list (pl, chadn_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_value ('ADMIN', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.name.value = 'SYSTEM' THEN
      global_system_administrator := TRUE;
      global_family_administrator := FALSE;
    ELSEIF value.name.value = 'FAMILY' THEN
      global_system_administrator := FALSE;
      global_family_administrator := TRUE;
    ELSE
      global_system_administrator := FALSE;
      global_family_administrator := FALSE;
    IFEND;

  PROCEND fsp$th_set_admin_status_command;

?? TITLE := 'fsp$th_recover_files_command', EJECT ??

  PROCEDURE [XDCL] fsp$th_recover_files_command
    (    pl: clt$parameter_list;
     VAR status: ost$status);



{    PDT recover_files (initialization, i: boolean
{      all_catalogs, ac: boolean = true
{      recover_purged_files, rpf: boolean = false
{      validate, v: boolean = true
{      reorganize: boolean = true
{      reconciliation: boolean = true
{      status)

?? PUSH (LISTEXT := ON) ??

    VAR
      recover_files: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^recover_files_names, ^recover_files_params];

    VAR
      recover_files_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 11] of
            clt$parameter_name_descriptor := [['INITIALIZATION', 1], ['I', 1], ['ALL_CATALOGS', 2], ['AC', 2],
            ['RECOVER_PURGED_FILES', 3], ['RPF', 3], ['VALIDATE', 4], ['V', 4], ['REORGANIZE', 5],
            ['RECONCILIATION', 6], ['STATUS', 7]];

    VAR
      recover_files_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 7] of clt$parameter_descriptor := [

{ INITIALIZATION I }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ ALL_CATALOGS AC }
      [[clc$optional_with_default, ^recover_files_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$boolean_value]],

{ RECOVER_PURGED_FILES RPF }
      [[clc$optional_with_default, ^recover_files_dv3], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$boolean_value]],

{ VALIDATE V }
      [[clc$optional_with_default, ^recover_files_dv4], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$boolean_value]],

{ REORGANIZE }
      [[clc$optional_with_default, ^recover_files_dv5], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$boolean_value]],

{ RECONCILIATION }
      [[clc$optional_with_default, ^recover_files_dv6], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$boolean_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      recover_files_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

    VAR
      recover_files_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';

    VAR
      recover_files_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

    VAR
      recover_files_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

    VAR
      recover_files_dv6: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

?? POP ??

    VAR
      dm_file: integer,
      ignored_status: ost$status,
      initialization: boolean,
      user_id: ost$user_identification,
      recovery_count: [STATIC] integer := 0,
      reorganization_selections: pft$set_overhaul_choices,
      set_name: stt$set_name,
      value: clt$value;

    clp$scan_parameter_list (pl, recover_files, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('INITIALIZATION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind = clc$unknown_value THEN
      { default based on recovery number
      initialization := (recovery_count = 0);
    ELSE
      initialization := value.bool.value;
    IFEND;

    recovery_count := recovery_count + 1;
    IF initialization THEN
      display (' Initialization recovery');
      reorganization_selections := $pft$set_overhaul_choices [];
    ELSE
      clp$get_value ('ALL_CATALOGS', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.bool.value THEN
        reorganization_selections := reorganization_selections + $pft$set_overhaul_choices [pfc$all_catalogs];
      IFEND;

      clp$get_value ('RECOVER_PURGED_FILES', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.bool.value THEN
        reorganization_selections := reorganization_selections +
              $pft$set_overhaul_choices [pfc$recover_purged_files];
      IFEND;

      clp$get_value ('VALIDATE', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.bool.value THEN
        reorganization_selections := reorganization_selections + $pft$set_overhaul_choices
              [pfc$validate_files];
      IFEND;

      clp$get_value ('REORGANIZE', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.bool.value THEN
        reorganization_selections := reorganization_selections +
              $pft$set_overhaul_choices [pfc$reorganize_catalogs];
      IFEND;

      clp$get_value ('RECONCILIATION', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.bool.value THEN
        reorganization_selections := reorganization_selections +
              $pft$set_overhaul_choices [pfc$reconcile_files];
      IFEND;
    IFEND;

    FOR dm_file := 1 TO 100 DO
      file_usage_table [dm_file].file_usage := 0;
    FOREND;
    setup_job_pointers;
    global_system_administrator := TRUE;
    global_family_administrator := FALSE;
    pmp$get_user_identification (user_id, status);
    osp$get_set_name (user_id.family, set_name, status);
    pfp$overhaul_set (set_name, reorganization_selections, status);
    global_system_administrator := FALSE;
    global_family_administrator := FALSE;
  PROCEND fsp$th_recover_files_command;
?? TITLE := 'fsp$th_recover_job_file_command', EJECT ??

  PROCEDURE [XDCL] fsp$th_recover_job_file_command
    (    pl: clt$parameter_list;
     VAR status: ost$status);

{ THIS ONLY RECOVERS THE CURRENT JOB
{ A Prior call to recover files should have been made to go through the system pf recovery

{  PDT recover_job_files (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      recover_job_files: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^recover_job_files_names, ^recover_job_files_params];

    VAR
      recover_job_files_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      recover_job_files_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
            clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    clp$scan_parameter_list (pl, recover_job_files, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display (' fmp$recover_job_files');
    fmp$recover_job_files (status);
  PROCEND fsp$th_recover_job_file_command;
?? TITLE := 'fsp$th_defmc_command', EJECT ??

  PROCEDURE [XDCL] fsp$th_defmc_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


    VAR
      path_container: clt$path_container,
      p_path: ^pft$path,
      user_id: ost$user_identification,
      set_name: stt$set_name,
      local_status: ost$status,
      charge_id: pft$charge_id;

    crack_user_path (parameter_list, path_container, p_path, status);
    IF status.normal THEN
      charge_id.account := '  ';
      charge_id.project := ' ';
      global_system_administrator := TRUE;
      global_family_administrator := FALSE;
      pmp$get_user_identification (user_id, status);
      osp$get_set_name (user_id.family, set_name, status);
      IF status.normal THEN
        pfp$define_master_catalog (set_name, p_path^ [pfc$family_name_index],
              p_path^ [pfc$master_catalog_name_index], charge_id, status);
      IFEND;
    IFEND;
    global_system_administrator := FALSE;
    global_family_administrator := FALSE;
  PROCEND fsp$th_defmc_command;
?? TITLE := 'fsp$th_purmc_command', EJECT ??

  PROCEDURE [XDCL] fsp$th_purmc_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


    VAR
      path_container: clt$path_container,
      p_path: ^pft$path,
      user_id: ost$user_identification,
      set_name: stt$set_name,
      local_status: ost$status,
      charge_id: pft$charge_id;

    crack_user_path (parameter_list, path_container, p_path, status);
    IF status.normal THEN
      charge_id.account := '  ';
      charge_id.project := ' ';
      global_system_administrator := TRUE;
      global_family_administrator := FALSE;
      pmp$get_user_identification (user_id, status);
      osp$get_set_name (user_id.family, set_name, status);
      IF status.normal THEN
        pfp$purge_master_catalog (set_name, p_path^ [pfc$family_name_index],
              p_path^ [pfc$master_catalog_name_index], status);
      IFEND;
    IFEND;
    global_system_administrator := FALSE;
    global_family_administrator := FALSE;
  PROCEND fsp$th_purmc_command;

?? TITLE := 'fsp$th_validate_catalog', EJECT ??

  PROCEDURE [XDCL] fsp$th_validate_catalog
    (    params: pmt$program_parameters;
     VAR status: ost$status);

{ PDT VALIDATE_CATALOG_PDT (
{     CATALOG, C: FILE = $REQUIRED
{     VALIDATE_SUBCATALOGS, VALIDATE_SUBCATALOG, VS: BOOLEAN = FALSE
{     STATUS: VAR OF STATUS)

?? PUSH (LISTEXT := ON) ??

    VAR
      validate_catalog_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^validate_catalog_pdt_names, ^validate_catalog_pdt_params];

    VAR
      validate_catalog_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
            clt$parameter_name_descriptor := [['CATALOG', 1], ['C', 1], ['VALIDATE_SUBCATALOGS', 2],
            ['VALIDATE_SUBCATALOG', 2], ['VS', 2], ['STATUS', 3]];

    VAR
      validate_catalog_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
            clt$parameter_descriptor := [

{ CATALOG C }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ VALIDATE_SUBCATALOGS VALIDATE_SUBCATALOG VS }
      [[clc$optional_with_default, ^validate_catalog_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$boolean_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      validate_catalog_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'FALSE';

?? POP ??

    VAR
      overhaul_selections: pft$catalog_overhaul_choices,
      p_path: ^pft$path,
      path_container: clt$path_container,
      value: clt$value;

    clp$scan_parameter_list (params, validate_catalog_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_catalog ('CATALOG', path_container, p_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('VALIDATE_SUBCATALOGS', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.bool.value THEN
      overhaul_selections := $pft$catalog_overhaul_choices [pfc$all_catalogs, pfc$validate_files];
      pfp$overhaul_catalog (p_path^, overhaul_selections, status);
    ELSE
      overhaul_selections := $pft$catalog_overhaul_choices [pfc$validate_files];
      pfp$overhaul_catalog (p_path^, overhaul_selections, status);
    IFEND;
  PROCEND fsp$th_validate_catalog;
?? TITLE := 'fsp$th_task_cleanup', EJECT ??

  PROCEDURE [XDCL] fsp$th_task_cleanup
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    ?IF NOT clc$compiling_for_test_harness THEN

{ pdt task_termination_pdt ()

?? PUSH (LISTEXT := ON) ??

      VAR
        task_termination_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??

      clp$scan_parameter_list (parameter_list, task_termination_pdt, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      bap$task_termination_cleanup;
      set_task_terminated (0);

    ?IFEND

  PROCEND fsp$th_task_cleanup;
?? TITLE := 'fsp$th_job_cleanup', EJECT ??

  PROCEDURE [XDCL] fsp$th_job_cleanup
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    ?IF NOT clc$compiling_for_test_harness THEN

{ pdt job_termination_pdt ()

?? PUSH (LISTEXT := ON) ??

      VAR
        job_termination_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??


      clp$scan_parameter_list (parameter_list, job_termination_pdt, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display (' fmp$job_exit ');
      fmp$job_exit;

      display (' pfp$process_job_end ');
      pfp$process_job_end;
      set_job_terminated (0)

    ?IFEND

  PROCEND fsp$th_job_cleanup;
?? TITLE := 'fsp$th_quit_command', EJECT ??

  PROCEDURE [XDCL] fsp$th_quit_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    ?IF NOT clc$compiling_for_test_harness THEN

{ pdt task_termination_pdt ()

?? PUSH (LISTEXT := ON) ??

      VAR
        task_termination_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??

      clp$scan_parameter_list (parameter_list, task_termination_pdt, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$end_scan_command_file (userbam_utility_name, status);

    ?IFEND

  PROCEND fsp$th_quit_command;
?? TITLE := 'fsp$$th_real_file_name', EJECT ??

  PROCEDURE [XDCL] fsp$$th_real_file_name
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR returned_value: clt$value;
     VAR status: ost$status);

    VAR
      rfn_adt: [STATIC, READ, cls$adt] array [1 .. 1] of clt$argument_descriptor := [
            {1} [[clc$required], [^keywords_rfn, clc$name_value, 1, 31]]],

      keywords_rfn: [STATIC, READ, cls$adt_names_and_defaults] array [1 .. 1] of ost$name := ['LFN'],

      rfn_avt: array [1 .. 1] of clt$value,

      ws: string (30),
      scr: integer,
      sfid: dmt$system_file_id,
      lfn: amt$local_file_name,
      file_name: ost$name,
      value: clt$value;

    clp$scan_argument_list (function_name, argument_list, ^rfn_adt, ^rfn_avt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    value := rfn_avt [1];

    lfn := value.name.value;
    fmp$get_system_file_id (lfn, sfid, status);
    IF NOT status.normal THEN
{         display ('unable to fetch sfid: $RFN');
{         display_status (status);
      RETURN;
    IFEND;

    file_name := 'jjj';
    STRINGREP (ws, scr, sfid.file_entry_index);
    file_name (4, * ) := ws (2, scr - 1);

    returned_value.descriptor := 'NAME';
    returned_value.kind := clc$name_value;
    returned_value.name.value := file_name;
    returned_value.name.size := STRLENGTH (returned_value.name.value);

  PROCEND fsp$$th_real_file_name;
?? OLDTITLE ??
?? TITLE := 'crack_user_path', EJECT ??

  PROCEDURE crack_user_path
    (    parameter_list: clt$parameter_list;
     VAR path_container: clt$path_container;
     VAR p_path: ^pft$path;
     VAR status: ost$status);

{ pdt user_path_pdt (
{ user,u:file=$required
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      user_path_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^user_path_pdt_names, ^user_path_pdt_params];

    VAR
      user_path_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['USER', 1], ['U', 1], ['STATUS', 2]];

    VAR
      user_path_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ USER U }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    clp$scan_parameter_list (parameter_list, user_path_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_catalog ('USER', path_container, p_path, status);
    IF status.normal AND (p_path <> NIL) AND (UPPERBOUND (p_path^) > pfc$master_catalog_name_index) THEN
      osp$set_status_abnormal ('UB', 333000, ' Path to long for user', status);
    IFEND;
  PROCEND crack_user_path;
?? TITLE := 'setup_job_pointers', EJECT ??

  PROCEDURE [XDCL] setup_job_pointers;

    ?IF fsc$compiling_for_test_harness THEN
      pfv$p_catalog_alarm_table := NIL;
      pfv$p_newest_queued_catalog := NIL;
      pfv$p_queued_catalog_table := NIL;
    ?IFEND

  PROCEND setup_job_pointers;
?? TITLE := 'set_current_user_id', EJECT ??

  PROCEDURE [XDCL] set_current_user_id;

    VAR
      rec_length: amt$max_record_length,
      fid: amt$file_identifier,
      fpos: amt$file_position,
      tc: amt$transfer_count,
      wsa: ^cell,
      wsl: amt$working_storage_length,
      ba: amt$file_byte_address,
      user_name: ost$name,

      p_user_string: ^ost$string,
      path_container: clt$path_container,
      p_user_path: ^pft$path,
      status: ost$status,
      parameter_list: ^clt$parameter_list;


    amp$#open ('USER_NAME                      ', amc$record, NIL, fid, status);
    IF status.normal THEN
      wsa := ^user_name;
      user_name := ' ';
      amp$#get_partial (fid, wsa, 31, rec_length, tc, ba, fpos, amc$no_skip, status);
      IF status.normal THEN
        current_user_id.family := 'NVE3';
        current_user_id.user := user_name;
        RETURN;
      IFEND;
    IFEND;

    PUSH parameter_list: [[REP 1 OF ost$string]];
    RESET parameter_list;
    NEXT p_user_string IN parameter_list;
    p_user_string^.size := 10;
    p_user_string^.value := ' $USER';
    clp$push_parameters (status);
    IF NOT status.normal THEN
      display_status (status);
      RETURN;
    IFEND;
    crack_user_path (parameter_list^, path_container, p_user_path, status);
    IF NOT status.normal THEN
      display_status (status);
      RETURN;
    IFEND;
    clp$pop_parameters (status);
    IF NOT status.normal THEN
      display_status (status);
      RETURN;
    IFEND;
    current_user_id.family := p_user_path^ [1];
    current_user_id.user := p_user_path^ [2];
  PROCEND set_current_user_id;

?? TITLE := 'clp$get_file_command', EJECT ??
{ The exporting and importing of files between the FS test harness environment
{ and the real file system is available.

{ Only V record, SS blocking can be ported.
{ This combination supports text output from displays and also
{ backup_file format.
{ Attributes are not transferred, so if you need the attributes (for example
{ command_libraries) backup the file first, use get_file, and then restore.
{ Only files named with a lfn (on both sides) can be ported.
{
{ Both the from and to parameters are required.
{ GET_FILE
{   Brings a file from the real file system into the userbam world.
{   FROM - lfn of real file
{     If you need to bring over a permanent file, just attach it before entering
{     userbam and specify an lfn on the attach_file command.
{   TO -lfn of userbam file to create
{

  PROCEDURE [XDCL] clp$get_file_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{ PDT get_file_pdt (
{   from, f : NAME = $required
{   to, t : name = $REQUIRED
{   STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    get_file_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^get_file_pdt_names,
      ^get_file_pdt_params];

  VAR
    get_file_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['FROM', 1], ['F', 1], ['TO', 2], ['T', 2], ['STATUS', 3]];

  VAR
    get_file_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ FROM F }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ TO T }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
    VAR
      fid: amt$file_identifier,
      file_length: amt$file_length,
      from_real_lfn: amt$local_file_name,
      to_real_lfn: amt$local_file_name,
      to_userbam_lfn: amt$local_file_name,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, get_file_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('TO', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display (' get_file stub');
    to_userbam_lfn := value.name.value;
    { open the userbam file so it looks like a V record access file, and
    {so that the 'real' file name   is assigned.
    display (' open to_userbam_lfn');
    display (to_userbam_lfn);
    amp$open (to_userbam_lfn, amc$record, NIL, fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    amp$close (fid, status);
    fetch_real_file_name (to_userbam_lfn, to_real_lfn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('FROM', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    from_real_lfn := value.name.value;

    get_real_file_length (from_real_lfn, file_length, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { copy the data into the file
    display (' copy_bytes');
    copy_bytes (from_real_lfn, to_real_lfn, file_length, status);
    display_status (status);

    set_userbam_eoi (to_userbam_lfn, file_length, status);


  PROCEND clp$get_file_command;

?? TITLE := 'clp$replace_file_command', EJECT ??
{ REPLACE_FILE
{   Replace a file from the userbam world to the real file system, for later use.
{   FROM - lfn of userbam file to replace
{   TO - lfn of real file
{
{ No verification is made if the file exists or not, so be careful with
{ replace_file not to overwrite an existing file.

  PROCEDURE [XDCL] clp$replace_file_command (parameter_list:
    clt$parameter_list;
    VAR status: ost$status);


{ PDT replace_file_pdt (
{   from, f : name = $REQUIRED
{   to, t : NAME  = $REQUIRED
{   STATUS)

?? PUSH (LISTEXT := ON) ??

    VAR
      replace_file_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table
        := [^replace_file_pdt_names, ^replace_file_pdt_params];

    VAR
      replace_file_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array
        [1 .. 5] of clt$parameter_name_descriptor := [['FROM', 1], ['F', 1],
        ['TO', 2], ['T', 2], ['STATUS', 3]];

    VAR
      replace_file_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 ..
        3] of clt$parameter_descriptor := [

{ FROM F }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$name_value, 1, osc$max_name_size]],

{ TO T }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      fid: amt$file_identifier,
      file_length: amt$file_length,
      from_real_lfn: amt$local_file_name,
      from_userbam_lfn: amt$local_file_name,
      to_real_lfn: amt$local_file_name,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, replace_file_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('FROM', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    from_userbam_lfn := value.name.value;
    display (' replace_file ');
    display (from_userbam_lfn);
    fetch_real_file_name (from_userbam_lfn, from_real_lfn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display (from_real_lfn);

    clp$get_value ('TO', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    to_real_lfn := value.name.value;
    display (' TO :');
    display (to_real_lfn);

    { open the real file so it looks like a V  record access file
    display (' open to  real lfn ');
    amp$#open (to_real_lfn, amc$record, NIL, fid, status);
    IF NOT status.normal THEN
      display_status (status);
      RETURN;
    IFEND;
    amp$#close (fid, status);

    display (' get userbam file length');
    get_userbam_file_length (from_userbam_lfn, file_length, status);
    display_integer (' from userbam lfn length: ', file_length);
    IF NOT status.normal THEN
      display_status (status);
      RETURN;
    IFEND;

    { copy the data into the file
    copy_bytes (from_real_lfn, to_real_lfn, file_length, status);

    display (' replace_file completed');
    display_status (status);

  PROCEND clp$replace_file_command;

?? TITLE := 'copy_bytes', EJECT ??
  PROCEDURE copy_bytes (from_real_lfn: amt$local_file_name;
        to_real_lfn: amt$local_file_name;
        length: amt$file_length;
    VAR status: ost$status);

    VAR
      from_fid: amt$file_identifier,
      from_segment_pointer: amt$segment_pointer,
      to_fid: amt$file_identifier,
      to_segment_pointer: amt$segment_pointer;


    display (' copy bytes');
    display (' open from ');
    amp$#open (from_real_lfn, amc$segment, NIL, from_fid, status);
    IF NOT status.normal THEN
      display_status (status);
      RETURN;
    IFEND;
    amp$#get_segment_pointer (from_fid, amc$cell_pointer, from_segment_pointer,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display (' open to ');
    amp$#open (to_real_lfn, amc$segment, NIL, to_fid, status);
    IF NOT status.normal THEN
      display_status (status);
      RETURN;
    IFEND;
    amp$#get_segment_pointer (to_fid, amc$cell_pointer, to_segment_pointer,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display_integer (' i#move ', length);
    i#move (from_segment_pointer.cell_pointer, to_segment_pointer.cell_pointer,
          length);

    to_segment_pointer.cell_pointer := #address (#ring (to_segment_pointer.
          cell_pointer), #segment (to_segment_pointer.cell_pointer),
          length);
    display (' set to segment eoi');
    amp$#set_segment_eoi (to_fid, to_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display (' closing files ');
    amp$#close (to_fid, status);
    amp$#close (from_fid, status);
  PROCEND copy_bytes;
?? TITLE := 'fetch_real_file_name', EJECT ??

  PROCEDURE fetch_real_file_name (userbam_lfn: amt$local_file_name;
    VAR real_lfn: amt$local_file_name;
    VAR status: ost$status);

    VAR
      sfid: dmt$system_file_id;

    fmp$get_system_file_id (userbam_lfn, sfid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    build_name ('jjj', sfid.file_entry_index, real_lfn);
  PROCEND fetch_real_file_name;

?? TITLE := 'get_real_file_length', EJECT ??

  PROCEDURE get_real_file_length (lfn: amt$local_file_name;
    VAR file_length: amt$file_length;
    VAR status: ost$status);

    VAR
      contains_data: boolean,
      existing_file: boolean,
      local_file: boolean,
      p_file_attributes: ^amt$get_attributes;

    PUSH p_file_attributes: [1 .. 1];
    p_file_attributes^ [1].key := amc$file_length;
    amp$#get_file_attributes (lfn, p_file_attributes^, local_file,
          existing_file, contains_data, status);
    IF status.normal THEN
      IF existing_file AND contains_data THEN
        file_length := p_file_attributes^ [1].file_length;
      ELSE
        file_length := 0;
      IFEND;
      display_integer (' real file length :', file_length);
    IFEND;
  PROCEND get_real_file_length;

?? TITLE := 'get_userbam_file_length', EJECT ??

  PROCEDURE get_userbam_file_length (lfn: amt$local_file_name;
    VAR file_length: amt$file_length;
    VAR status: ost$status);

    VAR
      contains_data: boolean,
      existing_file: boolean,
      local_file: boolean,
      p_file_attributes: ^amt$get_attributes;

    PUSH p_file_attributes: [1 .. 1];
    p_file_attributes^ [1].key := amc$file_length;
    display (' amp$get_file_attributes ');
    amp$get_file_attributes (lfn, p_file_attributes^, local_file,
          existing_file, contains_data, status);
    IF status.normal THEN
      IF existing_file AND contains_data THEN
        file_length := p_file_attributes^ [1].file_length;
      ELSE
        file_length := 0;
      IFEND;
      display_integer (' userbam file length :', file_length);
    IFEND;
    display_status (status);
  PROCEND get_userbam_file_length;

?? TITLE := 'set_real_eoi', EJECT ??

  PROCEDURE set_real_eoi (real_lfn: amt$local_file_name;
    VAR file_length: amt$file_length;
    VAR status: ost$status);

    VAR
      fid: amt$file_identifier,
      segment_pointer: amt$segment_pointer;

    display (' set real eoi');
    amp$#open (real_lfn, amc$segment, NIL, fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$#get_segment_pointer (fid, amc$cell_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    segment_pointer.cell_pointer := #address (#ring (segment_pointer.
          cell_pointer), #segment (segment_pointer.cell_pointer), file_length);
    amp$#set_segment_eoi (fid, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    amp$#close (fid, status);

  PROCEND set_real_eoi;

?? TITLE := 'set_userbam_eoi', EJECT ??

  PROCEDURE set_userbam_eoi (userbam_lfn: amt$local_file_name;
    VAR file_length: amt$file_length;
    VAR status: ost$status);

    VAR
      fid: amt$file_identifier,
      segment_pointer: amt$segment_pointer;

    display (' set userbam eoi');
    amp$open (userbam_lfn, amc$segment, NIL, fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (fid, amc$cell_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    segment_pointer.cell_pointer := #address (#ring (segment_pointer.
          cell_pointer), #segment (segment_pointer.cell_pointer), file_length);
    amp$set_segment_eoi (fid, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    amp$close (fid, status);

  PROCEND set_userbam_eoi;

?? TITLE := 'nap$se_return_file', EJECT ??

  PROCEDURE [XDCL] nap$se_return_file (connection_id: nat$connection_id;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND nap$se_return_file;

?? TITLE :='nlp$cancel_switch_offer', EJECT ??

  PROCEDURE [XDCL] nlp$cancel_switch_offer (connection_id: nat$connection_id;
    VAR switch_complete: boolean;
    VAR status: ost$status);

    switch_complete := TRUE;
    status.normal := TRUE;

  PROCEND nlp$cancel_switch_offer;

?? TITLE := 'rfp$delete_connection', EJECT ??

  PROCEDURE [XDCL] rfp$delete_connection (local_file_name: amt$local_file_name;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND rfp$delete_connection;

?? TITLE := 'dmp$dev_mgmt_table_update', EJECT ??

  PROCEDURE [XDCL] dmp$dev_mgmt_table_update;

  PROCEND dmp$dev_mgmt_table_update;

?? TITLE := 'syp$invoke_system_debugger', EJECT ??

  PROCEDURE [XDCL] syp$invoke_system_debugger
    (    text: string (*);
         id: dpt$window_id;
     VAR status: ost$status);

    status.normal := TRUE;

  PROCEND syp$invoke_system_debugger;

?? TITLE := 'fmp$fetch_tape_label_attributes', EJECT ??

  PROCEDURE [XDCL] fmp$fetch_tape_label_attributes (local_file_name: amt$local_file_name;
    VAR tape_attachments: fst$tape_attachment_information;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND fmp$fetch_tape_label_attributes;

?? TITLE := 'fmp$store_tape_attachment', EJECT ??

  PROCEDURE [XDCL] fmp$store_tape_attachment (tape_attachments: fst$attachment_options;
      tape_attachment_info_source: fst$tape_attach_info_source;
      tape_attachment_info: ^fst$tape_attachment_information;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND fmp$store_tape_attachment;

?? TITLE := 'iip$search_connection_desc', EJECT ??

  PROCEDURE [XDCL] iip$search_connection_desc (session_file: amt$local_file_name;
    VAR connection_desc_ptr: ^iit$connection_description);

  PROCEND iip$search_connection_desc;

?? TITLE := 'iip$st_initialize_connection', EJECT ??

  PROCEDURE [XDCL] iip$st_initialize_connection (terminal_file_name:
    amt$local_file_name;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND iip$st_initialize_connection;

?? TITLE := 'iip$st_get_terminal_attributes', EJECT ??

  PROCEDURE [XDCL] iip$st_get_terminal_attributes (file_name: amt$local_file_name;
    VAR terminal_attributes: ift$terminal_attributes;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND iip$st_get_terminal_attributes;

?? TITLE := 'pup$crack_catalog ', EJECT ??

  PROCEDURE [XDCL] pup$crack_catalog (parameter_name: string ( * );
    VAR path_container: clt$path_container;
    VAR p_path: ^pft$path;
    VAR status: ost$status);

{ The purpose of this routine is to crack a reference of the type
{     < catalog>
{ Callers are responsible for validating the length of the path returned.
{ No file position or cycle selector may be specified.
{

    VAR
      cycle_selector: pft$cycle_selector,
      cycle_selector_specified: boolean,
      value: clt$value;

    clp$get_value (parameter_name, 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind = clc$unknown_value THEN
      p_path := NIL;
      RETURN;
    IFEND;
    crack_path (value, parameter_name, pfc$family_name_index, $put$cycle_reference_selections
          [puc$cycle_omitted], path_container, p_path, cycle_selector_specified, cycle_selector, status);
  PROCEND pup$crack_catalog;

?? TITLE := '    crack_path ', EJECT ??

  PROCEDURE crack_path (value: clt$value;
        parameter_name: string ( * );
        minimum_path_length: pft$array_index;
        allowed_cycle_references: put$cycle_reference_selections;
    VAR path_container: clt$path_container;
    VAR p_path: ^pft$path;
    VAR cycle_selector_specified: boolean;
    VAR cycle_selector: pft$cycle_selector;
    VAR status: ost$status);


    VAR
      cl_cycle_selector: clt$cycle_selector,
      evaluated_file_reference: fst$evaluated_file_reference,
      path_handle: fmt$path_handle,
      p_path_container: ^clt$path_container;

    status.normal := TRUE;
    clp$get_fs_path_elements (value.file.local_file_name, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_path_container := ^path_container;
    RESET p_path_container;
    NEXT p_path: [1 .. evaluated_file_reference.number_of_path_elements] IN p_path_container;
    fsp$convert_fs_structure_to_pf (evaluated_file_reference, p_path);

    IF p_path^ [1] = fsc$local THEN
      osp$set_status_abnormal (puc$pf_utility_id, cle$not_permitted_on_loc_file, 'backup or restore', status);
    ELSE
      IF (UPPERBOUND (p_path^)) < minimum_path_length THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$path_too_short, parameter_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_path^ [1], status);
      ELSEIF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_file_position, parameter_name, status);
      ELSE
        clp$convert_cyc_ref_to_cyc_sel (evaluated_file_reference.cycle_reference, cl_cycle_selector);
        verify_cycle_selection (parameter_name, allowed_cycle_references, cl_cycle_selector, status);
        IF status.normal THEN
          cycle_selector_specified := cl_cycle_selector.specification <> clc$cycle_omitted;
          IF cycle_selector_specified THEN
            cycle_selector := cl_cycle_selector.value;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND crack_path;

?? TITLE := '    verify_cycle_selection ', EJECT ??

  PROCEDURE verify_cycle_selection (parameter_name: string ( * );
        allowed_cycle_selections: put$cycle_reference_selections;
        specified_cycle_selection: clt$cycle_selector;
    VAR status: ost$status);

    VAR
      cycle_selector: put$cycle_reference_options,
      cycle_selector_name_table: [STATIC, READ, pus$literals] array [put$cycle_reference_options] of ost$name
        := [' NO CYCLE REFERENCE', ' $LOW', ' $HIGH', ' A SPECIFIC CYCLE NUMBER', ' $NEXT', ' $NEXT_LOW'],
      check_set: put$cycle_reference_selections,
      delimiter: char,
      first_element: boolean,
      pu_cycle_selector: put$cycle_reference_options;

    status.normal := TRUE;
    IF allowed_cycle_selections = $put$cycle_reference_selections [] THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$bad_cycle_selections, parameter_name, status);
      RETURN;
    IFEND;
    convert_cycle_selector (specified_cycle_selection, pu_cycle_selector);
    IF NOT (pu_cycle_selector IN allowed_cycle_selections) THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$incorrect_cycle_reference, cycle_selector_name_table
            [pu_cycle_selector], status);
      delimiter := osc$status_parameter_delimiter;
      osp$append_status_parameter (delimiter, parameter_name, status);
      check_set := $put$cycle_reference_selections [];
      first_element := TRUE;
      FOR cycle_selector := LOWERVALUE (put$cycle_reference_options) TO UPPERVALUE
            (put$cycle_reference_options) DO
        IF cycle_selector IN allowed_cycle_selections THEN
          check_set := check_set + $put$cycle_reference_selections [cycle_selector];
          IF (check_set = allowed_cycle_selections) AND (NOT first_element) THEN
            delimiter := osc$status_parameter_delimiter;
            osp$append_status_parameter (delimiter, ' or ', status);
          IFEND;
          first_element := FALSE;
          osp$append_status_parameter (delimiter, cycle_selector_name_table [cycle_selector], status);
          delimiter := ',';
        IFEND;
      FOREND;
    IFEND;
  PROCEND verify_cycle_selection;

?? TITLE := '    convert_cycle_selector ', EJECT ??

  PROCEDURE convert_cycle_selector (cl_cycle_selector: clt$cycle_selector;
    VAR pu_cycle_selector: put$cycle_reference_options);

    CASE cl_cycle_selector.specification OF
    = clc$cycle_omitted =
      pu_cycle_selector := puc$cycle_omitted;
    = clc$cycle_specified =
      CASE cl_cycle_selector.value.cycle_option OF
      = pfc$lowest_cycle =
        pu_cycle_selector := puc$lowest_cycle;
      = pfc$highest_cycle =
        pu_cycle_selector := puc$highest_cycle;
      = pfc$specific_cycle =
        pu_cycle_selector := puc$specific_cycle;
      ELSE
      CASEND;
    = clc$cycle_next_highest =
      pu_cycle_selector := puc$next_highest_cycle;
    = clc$cycle_next_lowest =
      pu_cycle_selector := puc$next_lowest_cycle;
    ELSE
    CASEND;
  PROCEND convert_cycle_selector;

  PROCEDURE [XDCL] amp$crack_display_tft_options (parameter_name: string ( * );
    VAR display_options: amt$display_tft_option_list;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] amp$display_file_id_list (file_id_list: array [1 .. * ] OF
    amt$file_identifier;
        display_options: amt$display_tft_option_list;
        list_file: amt$local_file_name;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] amp$display_full_tft (display_options:
    amt$display_tft_option_list;
        list_file: amt$local_file_name;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] amp$display_jft_command (parameter_list:
    clt$parameter_list;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] amp$display_lnt_command (parameter_list:
    clt$parameter_list;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] amp$display_local_files_command (parameter_list:
    clt$parameter_list;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] amp$display_tft_command (parameter_list:
    clt$parameter_list;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] bap$advance_tape_volume (sfid: dmt$system_file_id;
        extend_volume_list: boolean;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] bap$assign_tape_volume (sfid: dmt$system_file_id;
        path_handle_name: fst$path_handle_name;
        label_type: amt$label_type;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] bap$await_tape_io_completion (sfid: dmt$system_file_id;
        io_id: iot$io_id;
        data_wait: boolean;
        last_buffer_pva: ^cell;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] bap$backspace_tape (sfid: dmt$system_file_id;
        count: iot$tape_block_count;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

 PROCEDURE [XDCL] bap$erase_tape (sfid: dmt$system_file_id;
        block_length: amt$max_block_length;
        number_of_erases: integer;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

 PROCEDURE [XDCL] bap$fetch_tape_capabilities (sfid: dmt$system_file_id;
    VAR maximum_block_length: amt$max_block_length;
    VAR max_blocks_per_physical_call: iot$tape_block_count;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] bap$forspace_tape (sfid: dmt$system_file_id;
        count: iot$tape_block_count;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] bap$read_tape (sfid: dmt$system_file_id;
        max_block_size: iot$tape_block_length;
        block_description: ^iot$read_tape_description;
        block_count: iot$tape_block_count;
        perform_media_error_recovery: boolean;
    VAR io_id: iot$io_id;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] bap$reset_tape_volume (sfid: dmt$system_file_id;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] bap$rewind_tape (sfid: dmt$system_file_id;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] bap$skip_tapemark_backward (sfid: dmt$system_file_id;
        count: iot$tape_block_count;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] bap$skip_tapemark_forward (sfid: dmt$system_file_id;
        count: iot$tape_block_count;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] bap$tape_request_status (sfid: dmt$system_file_id;
        io_id: iot$io_id;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] bap$write_tape (sfid: dmt$system_file_id;
        block_description: ^iot$write_tape_description;
        block_count: iot$tape_block_count;
        perform_media_error_recovery: boolean;
    VAR io_id: iot$io_id;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] bap$write_tapemark (sfid: dmt$system_file_id;
    VAR tape_status: iot$tape_io_status;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  VAR
    bav$force_direct_tape_io: [XDCL] boolean;

  VAR
    bav$max_allowed_tape_block_size: [XDCL] integer;
  VAR
    bav$max_bytes_per_tape_io: [XDCL] integer;
  VAR
    bav$max_indirect_tape_block: [XDCL] integer;
  VAR
    bav$use_assign_pages_for_tape: [XDCL] boolean;

  PROCEDURE [XDCL] cmp$get_element_name_via_lun (logical_unit_number: iot$logical_unit;
    VAR element_name: cmt$element_name;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;


{ COMMON DECK CMXLPPT }

  VAR
    cmv$logical_pp_table_p: [XDCL] ^cmt$logical_pp_table;


{ COMMON DECK CMXLUT }

  VAR
    cmv$logical_unit_table: [XDCL] ^cmt$logical_unit_table;

{dmxcsl}
{        convert sfid to lun xref

  PROCEDURE [XDCL] dmp$convert_sfid_to_lun ALIAS 'dmxcsl' (sfid:
    dmt$system_file_id;
    VAR lun: iot$logical_unit;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

 PROCEDURE [XDCL] dmp$get_mat_pointer (avt_index: dmt$active_volume_table_index;
    VAR p_mat: ^dmt$mainframe_allocation_table);

  PROCEND;

  PROCEDURE [XDCL] dmp$unconditional_get_fde ALIAS 'dmxugfd' (p_fdt_root:
    ^dmt$file_table_root;
        system_file_id: dmt$system_file_id;
    VAR p_file_descriptor_entry: ^dmt$file_descriptor_entry;
    VAR able_to_locate_fde: boolean);

  PROCEND;

  VAR
    mtv$cst0: [XDCL] ost$state_tables;


  PROCEDURE [XDCL] syp$crack_command (pdt: array [1 .. * ] OF syt$parameter_descriptor;
        text: string ( * );
    VAR pvt: array [1 .. * ] OF syt$parameter_value;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;


  PROCEDURE [XDCL] ttp$set_test_state (state: ttt$states;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND;

  PROCEDURE [XDCL] verify_access (access_type: (syc$readable, syc$writeable);
        cell_pp: ^^cell;
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND verify_access;

  PROCEDURE [XDCL] write_output_line (s: string ( * );
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND write_output_line;

  PROCEDURE [XDCL] convert_bytes (p: ^packed array [1 .. 1000] OF 0 .. 0f(16);
        length: integer;
    VAR msg: string ( * );
        add_to_eol: boolean);

  PROCEND convert_bytes;

  PROCEDURE [XDCL, #GATE] osp$output_debug_text (s: ^string ( * );
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND osp$output_debug_text;

  PROCEDURE [XDCL] ttp$attach_or_create_file_req (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEND ttp$attach_or_create_file_req;

  PROCEDURE [XDCL] ttp$attach_request (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEND ttp$attach_request;

  PROCEDURE [XDCL] ttp$close_volume (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEND ttp$close_volume;

  PROCEDURE [XDCL] ttp$compare_legible_files (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEND ttp$compare_legible_files;

  PROCEDURE [XDCL] ttp$define_request (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEND ttp$define_request;

  PROCEDURE [XDCL] ttp$erase_tape_block (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEND ttp$erase_tape_block;

  PROCEDURE [XDCL] ttp$get_label (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEND ttp$get_label;

  PROCEDURE [XDCL] ttp$process_change_term_conn (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEND ttp$process_change_term_conn;

  PROCEDURE [XDCL] ttp$process_display_term_conn (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEND ttp$process_display_term_conn;

  PROCEDURE [XDCL] ttp$purge_request (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEND ttp$purge_request;

  PROCEDURE [XDCL] ttp$request_terminal (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEND ttp$request_terminal;

  PROCEDURE [XDCL] ttp$verify_fsp_attrs (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEND ttp$verify_fsp_attrs;

  PROCEDURE [XDCL, #GATE] osp$output_debug_heading (s: ^string ( * );
    VAR status: ost$status);

    status.normal := TRUE;

  PROCEND osp$output_debug_heading;

MODEND fsm$test_harness_fs_support;

*DECK DECK=FSM$TEST_HARNESS_FUNCTIONS EXPAND=TRUE

 table fsv$test_harness_fnctns type=function section_name=oss$job_paged_literal scope=xdcl ..
       m=fsm$test_harness_functions
 function $file                          clp$$file xref
 function ($real_file_name, $rfn)        fsp$$th_real_file_name xref
 tablend

*DECK DECK=FSM$VALIDATE_ATTACHMENTS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOSVE Basic Access Method : Validate Attachments' ??

MODULE fsm$validate_attachments;

?? NEWTITLE := 'Global Declarations', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc clt$file
*copyc fsc$longest_wait_time
*copyc fst$attachment_options
*copyc fst$file_reference
*copyc fst$status_reporting_procedure
?? POP ??
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_file_ref
*copyc clp$only_validate_name
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc pmp$change_legible_date_format
*copyc rmp$validate_ansi_string

*copyc amv$message_control

?? TITLE := '[XDCL] fsv$attachment_names', EJECT ??

  VAR
    fsv$attachment_names: [XDCL, READ, oss$job_paged_literal] ^array [1 .. * ] of ost$name :=
          ^attachment_names,

    attachment_names: [STATIC, READ, oss$job_paged_literal] array
          [fsc$access_and_share_modes .. fsc$allowed_device_classes] of ost$name := [

          {fsc$access_and_share_modes .... = 001} 'ACCESS_AND_SHARE_MODES       ',
          {fsc$allowed_exceptions ........ = 002} 'ALLOWED_EXCEPTIONS           ',
          {fsc$create_file ............... = 003} 'CREATE_FILE                  ',
          {fsc$delete_data ............... = 004} 'DELETE_DATA                  ',
          {fsc$error_exit_procedure ...... = 005} 'ERROR_EXIT_PROCEDURE         ',
          {fsc$error_exit_procedure_name . = 006} 'ERROR_EXIT_PROCEDURE_NAME    ',
          {fsc$error_limit ............... = 007} 'ERROR_LIMIT                  ',
          {fsc$explicit_detach_allowed ... = 008} 'EXPLICIT_DETACH_ALLOWED      ',
          {fsc$file_server_options ....... = 009} 'FILE_SERVER_OPTIONS          ',
          {fsc$hide_attachment ........... = 010} 'HIDE_ATTACHMENT              ',
          {fsc$label_exit_procedure ...... = 011} 'LABEL_EXIT_PROCEDURE         ',
          {fsc$label_exit_procedure_name . = 012} 'LABEL_EXIT_PROCEDURE_NAME    ',
          {fsc$message_control ........... = 013} 'MESSAGE_CONTROL              ',
          {fsc$null_attachment_option .... = 014} 'NULL_ATTACHMENT_OPTION       ',
          {fsc$open_position ............. = 015} 'OPEN_POSITION                ',
          {fsc$open_share_modes .......... = 016} 'OPEN_SHARE_MODES             ',
          {fsc$password .................. = 017} 'PASSWORD                     ',
          {fsc$private_read .............. = 018} 'PRIVATE_READ                 ',
          {fsc$scope ..................... = 019} 'SCOPE                        ',
          {fsc$sequential_access ......... = 020} 'SEQUENTIAL_ACCESS            ',
          {fsc$tape_attachment ........... = 021} 'TAPE_ATTACHMENT              ',
          {fsc$tape_error_options ........ = 022} 'TAPE_ERROR_OPTIONS           ',
          {fsc$transfer_size ............. = 023} 'TRANSFER_SIZE                ',
          {fsc$validation_ring ........... = 024} 'VALIDATION_RING              ',
          {fsc$wait_for_attachment ....... = 025} 'WAIT_FOR_ATTACHMENT          ',
          {fsc$free_behind ............... = 026} 'FREE_BEHIND                  ',
          {fsc$exception_detection........ = 027} 'EXCEPTION_DETECTION          ',
          {fsc$allowed_device_classes..... = 028} 'ALLOWED_DEVICE_CLASSES       '];

?? TITLE := '[XDCL] fsp$validate_attachments', EJECT ??

  PROCEDURE [XDCL] fsp$validate_attachments
    (    attachments: ^fst$attachment_options;
         status_reporting_procedure_ptr: fst$status_reporting_procedure;
     VAR status: ost$status);

    VAR
      attachment_key_is_good: boolean,
      attachment_value_is_good: boolean,
      fsv$allowed_device_classes: [STATIC, READ, oss$job_paged_literal] fst$device_classes :=
            -$fst$device_classes[],
      fsv$file_access_options: [STATIC, READ, oss$job_paged_literal] fst$file_access_options :=
            [fsc$execute, fsc$read, fsc$append, fsc$modify, fsc$shorten],
      fsv$cycle_damage_symptoms: [STATIC, READ, oss$job_paged_literal] fst$cycle_damage_symptoms :=
            -$fst$cycle_damage_symptoms [],
      fsv$file_access_conditions: [STATIC, READ, oss$job_paged_literal] fst$file_access_conditions :=
            -$fst$file_access_conditions [],
      i: integer,
      i_string: ost$string,
      ignore_file: fst$parsed_file_reference,
      ignore_status: ost$status;

    status.normal := TRUE;
    IF attachments = NIL THEN
      RETURN;
    IFEND;

    FOR i := 1 TO UPPERBOUND (attachments^) DO
      attachment_key_is_good := TRUE;
      attachment_value_is_good := TRUE;
      CASE attachments^ [i].selector OF
      = fsc$access_and_share_modes =
        IF (attachments^ [i].access_modes.selector < LOWERVALUE (fst$access_mode_choices)) OR
              (attachments^ [i].access_modes.selector > UPPERVALUE (fst$access_mode_choices)) THEN
          attachment_value_is_good := FALSE;
        ELSE
          IF attachments^ [i].access_modes.selector = fsc$specific_access_modes THEN
            attachment_value_is_good := (attachments^ [i].access_modes.value <= fsv$file_access_options) AND
                  (attachments^ [i].access_modes.value <> $fst$file_access_options []);
          IFEND;
        IFEND;
        IF (attachments^ [i].share_modes.selector < LOWERVALUE (fst$share_mode_choices)) OR
              (attachments^ [i].share_modes.selector > UPPERVALUE (fst$share_mode_choices)) THEN
          attachment_value_is_good := FALSE;
        ELSE
          IF attachments^ [i].share_modes.selector = fsc$specific_share_modes THEN
            attachment_value_is_good := (attachments^ [i].share_modes.value <= fsv$file_access_options);
          IFEND;
        IFEND;
      = fsc$allowed_device_classes =
        attachment_value_is_good :=
              (attachments^ [i].allowed_device_classes <= fsv$allowed_device_classes);
      = fsc$allowed_exceptions =
        attachment_value_is_good :=
              (attachments^ [i].allowed_exceptions.access_conditions <= fsv$file_access_conditions) AND
              (attachments^ [i].allowed_exceptions.damage_symptoms <= fsv$cycle_damage_symptoms);
      = fsc$exception_detection =
        attachment_value_is_good :=
              (attachments^ [i].exception_detection <= fsv$cycle_damage_symptoms);
      = fsc$tape_attachment =
        fsp$validate_tape_attachment (attachments^ [i].tape_attachment, attachment_key_is_good);
      = fsc$create_file =
        attachment_value_is_good := (attachments^ [i].create_file >= LOWERVALUE (boolean)) AND
              (attachments^ [i].create_file <= UPPERVALUE (boolean));
      = fsc$delete_data =
        attachment_value_is_good := (attachments^ [i].delete_data >= LOWERVALUE (boolean)) AND
              (attachments^ [i].delete_data <= UPPERVALUE (boolean));
      = fsc$error_exit_procedure =
        ;
      = fsc$error_exit_procedure_name =
        IF attachments^ [i].error_exit_procedure_name <> NIL THEN
          IF attachments^ [i].error_exit_procedure_name^.entry_point <> osc$null_name THEN
            clp$only_validate_name (attachments^ [i].error_exit_procedure_name^.entry_point,
                  attachment_value_is_good);
            IF attachments^ [i].error_exit_procedure_name^.object_library <> osc$null_name THEN
              clp$convert_string_to_file_ref (attachments^ [i].error_exit_procedure_name^.object_library,
                    ignore_file, status);
              attachment_value_is_good := status.normal;
            IFEND;
          IFEND;
        IFEND;
      = fsc$error_limit =
        attachment_value_is_good := (attachments^ [i].error_limit >= LOWERVALUE (amt$error_limit)) AND
              (attachments^ [i].error_limit <= UPPERVALUE (amt$error_limit));
      = fsc$explicit_detach_allowed =
        ;
      = fsc$free_behind =
        ;
      = fsc$hide_attachment =
        ;
      = fsc$label_exit_procedure =
        ;
      = fsc$label_exit_procedure_name =
        IF attachments^ [i].label_exit_procedure_name <> NIL THEN
          IF attachments^ [i].label_exit_procedure_name^.entry_point <> osc$null_name THEN
            clp$only_validate_name (attachments^ [i].label_exit_procedure_name^.entry_point,
                  attachment_value_is_good);
            IF attachments^ [i].label_exit_procedure_name^.object_library <> osc$null_name THEN
              clp$convert_string_to_file_ref (attachments^ [i].label_exit_procedure_name^.object_library,
                    ignore_file, status);
              attachment_value_is_good := status.normal;
            IFEND;
          IFEND;
        IFEND;
      = fsc$message_control =
        attachment_value_is_good := (attachments^ [i].message_control <= amv$message_control);
      = fsc$null_attachment_option =
        ;
      = fsc$open_position =
        attachment_value_is_good := (attachments^ [i].open_position >= LOWERVALUE (amt$open_position)) AND
              (attachments^ [i].open_position <= UPPERVALUE (amt$open_position));
      = fsc$open_share_modes =
        attachment_value_is_good := (attachments^ [i].open_share_modes <= fsv$file_access_options);
      = fsc$password =
        IF attachments^ [i].password <> osc$null_name THEN
          clp$only_validate_name (attachments^ [i].password, attachment_value_is_good);
        IFEND;
      = fsc$private_read =
        ;
      = fsc$scope =
        ;
      = fsc$sequential_access =
        ;
      = fsc$tape_error_options =
        IF (attachments^ [i].tape_error_options.error_action < LOWERVALUE (amt$tape_error_action)) OR
              (attachments^ [i].tape_error_options.error_action > UPPERVALUE (amt$tape_error_action)) THEN
          attachment_value_is_good := FALSE;
        ELSE
          attachment_value_is_good := (attachments^ [i].tape_error_options.
                perform_failure_recovery >= LOWERVALUE (boolean)) AND
                (attachments^ [i].tape_error_options.perform_failure_recovery <= UPPERVALUE (boolean))
        IFEND;
      = fsc$transfer_size =
        attachment_value_is_good := (attachments^ [i].transfer_size >= LOWERVALUE (fst$transfer_size)) AND
              (attachments^ [i].transfer_size <= UPPERVALUE (fst$transfer_size));
      = fsc$validation_ring =
        attachment_value_is_good := (attachments^ [i].validation_ring >= LOWERVALUE (ost$ring)) AND
              (attachments^ [i].validation_ring <= UPPERVALUE (ost$ring));
      = fsc$wait_for_attachment =
        IF (attachments^ [i].wait_for_attachment.wait < LOWERVALUE (ost$wait)) OR
              (attachments^ [i].wait_for_attachment.wait > UPPERVALUE (ost$wait)) THEN
          attachment_value_is_good := FALSE;
        ELSE
          IF attachments^ [i].wait_for_attachment.wait = osc$wait THEN
            attachment_value_is_good := (attachments^ [i].wait_for_attachment.wait_time >= 0) AND
                  (attachments^ [i].wait_for_attachment.wait_time <= fsc$longest_wait_time);
          IFEND;
        IFEND;

      ELSE
        attachment_key_is_good := FALSE;
      CASEND;

      IF NOT attachment_key_is_good THEN
        clp$convert_integer_to_string (i, 10, FALSE, i_string, ignore_status);
        IF status.normal OR (status.condition <> ame$improper_file_attrib_key) THEN
          status_reporting_procedure_ptr^ (ame$improper_file_attrib_key, 'FILE_ATTACHMENT', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, i_string.value (1, i_string.size),
                status);
        ELSE
          osp$append_status_parameter (',', i_string.value (1, i_string.size), status);
        IFEND;
      ELSEIF NOT attachment_value_is_good THEN
        IF status.normal THEN
          status_reporting_procedure_ptr^ (ame$improper_file_attrib_value, 'FILE_ATTACHMENT', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                fsv$attachment_names^ [attachments^ [i].selector], status);
        ELSEIF status.condition = ame$improper_file_attrib_value THEN
          osp$append_status_parameter (',', fsv$attachment_names^ [attachments^ [i].selector], status);
        IFEND;
      IFEND;
    FOREND;

  PROCEND fsp$validate_attachments;
?? EJECT ??

  PROCEDURE fsp$validate_tape_attachment
    (    tape_attachment: fst$tape_attachment;
     VAR attachment_key_is_good: boolean);


    attachment_key_is_good := TRUE;

    CASE tape_attachment.selector OF

    = fsc$tape_block_type, fsc$tape_buffer_offset, fsc$tape_character_conversion, fsc$tape_character_set,
      fsc$tape_creation_date, fsc$tape_expiration_date, fsc$tape_file_accessibility, fsc$tape_file_identifier,
      fsc$tape_file_sequence_number, fsc$tape_file_set_identifier, fsc$tape_file_set_position,
      fsc$tape_generation_number, fsc$tape_generation_version_num, fsc$tape_implementation_id,
      fsc$tape_label_standard_version, fsc$tape_max_block_length, fsc$tape_max_record_length,
      fsc$tape_owner_identification, fsc$tape_padding_character, fsc$tape_record_type,
      fsc$tape_removable_media_group, fsc$tape_rewrite_labels, fsc$tape_volume_accessibility,
      fsc$tape_header_labels, fsc$tape_trailer_labels, fsc$tape_file_section_number, fsc$tape_block_count,
      fsc$tape_volume_initialization, fsc$tape_null_attachment_option =
      ;

    ELSE
      attachment_key_is_good := FALSE;

    CASEND;

  PROCEND fsp$validate_tape_attachment;
?? OLDTITLE ??
MODEND fsm$validate_attachments;
*DECK DECK=FSM$VALIDATE_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Basic Access Method : Validate Attributes' ??

MODULE fsm$validate_attributes;

?? NEWTITLE := 'Global Declarations', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc ame$ring_validation_errors
*copyc amk$access_method
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_file_ref
*copyc clp$only_validate_name
*copyc clp$verify_time_increment
*copyc osp$append_status_parameter
*copyc oss$job_paged_literal
*copyc pmp$compute_date_time
*copyc pmp$get_compact_date_time
*copyc pmp$verify_compact_date
*copyc pmp$verify_compact_time
?? POP ??
*copyc fst$file_cycle_attributes
*copyc fst$status_reporting_procedure

?? TITLE := '[XDCL] fsv$attribute_names', EJECT ??

  VAR
    fsv$attribute_names: [XDCL, READ, oss$job_paged_literal] ^array [1 .. * ] of ost$name :=
          ^fs_attribute_names,

    fs_attribute_names: [STATIC, READ, oss$job_paged_literal] array [1 .. 53] of ost$name := [

      {fsc$average_record_length ..... = 001} 'AVERAGE_RECORD_LENGTH          ',
      {fsc$block_type ................ = 002} 'BLOCK_TYPE                     ',
      {fsc$character_conversion ...... = 003} 'CHARACTER_CONVERSION           ',
      {fsc$collate_table_name ........ = 004} 'COLLATE_TABLE_NAME             ',
      {fsc$compression_procedure_name  = 005} 'COMPRESSION_PROCEDURE_NAME     ',
      {fsc$data_padding .............. = 006} 'DATA_PADDING                   ',
      {fsc$dynamic_home_block_space .. = 007} 'DYNAMIC_HOME_BLOCK_SPACE       ',
      {fsc$embedded_key .............. = 008} 'EMBEDDED_KEY                   ',
      {fsc$erase_at_deletion ......... = 009} 'ERASE_AT_DELETION              ',
      {fsc$estimated_record_count .... = 010} 'ESTIMATED_RECORD_COUNT         ',
      {fsc$file_access_procedure_name. = 011} 'FILE_ACCESS_PROCEDURE_NAME     ',
      {fsc$file_contents_and_processor = 012} 'FILE_CONTENTS_AND_PROCESSOR    ',
      {fsc$file_label_type ........... = 013} 'FILE_LABEL_TYPE                ',
      {fsc$file_limit ................ = 014} 'FILE_LIMIT                     ',
      {fsc$file_organization ......... = 015} 'FILE_ORGANIZATION              ',
      {fsc$forced_write .............. = 016} 'FORCED_WRITE                   ',
      {fsc$hashing_procedure_name .... = 017} 'HASHING_PROCEDURE_NAME         ',
      {fsc$index_levels .............. = 018} 'INDEX_LEVELS                   ',
      {fsc$index_padding ............. = 019} 'INDEX_PADDING                  ',
      {fsc$initial_home_block_count .. = 020} 'INITIAL_HOME_BLOCK_COUNT       ',
      {fsc$internal_code ............. = 021} 'INTERNAL_CODE                  ',
      {fsc$key_length ................ = 022} 'KEY_LENGTH                     ',
      {fsc$key_position .............. = 023} 'KEY_POSITION                   ',
      {fsc$key_type .................. = 024} 'KEY_TYPE                       ',
      {fsc$line_number ............... = 025} 'LINE_NUMBER                    ',
      {fsc$loading_factor ............ = 026} 'LOADING_FACTOR                 ',
      {fsc$lock_expiration_time ...... = 027} 'LOCK_EXPIRATION_TIME           ',
      {fsc$logging_options ........... = 028} 'LOGGING_OPTIONS                ',
      {fsc$log_residence ............. = 029} 'LOG_RESIDENCE                  ',
      {fsc$max_block_length .......... = 030} 'MAX_BLOCK_LENGTH               ',
      {fsc$max_record_length ......... = 031} 'MAX_RECORD_LENGTH              ',
      {fsc$min_block_length .......... = 032} 'MIN_BLOCK_LENGTH               ',
      {fsc$min_record_length ......... = 033} 'MIN_RECORD_LENGTH              ',
      {fsc$null_attribute ............ = 034} 'NULL_ATTRIBUTE                 ',
      {fsc$padding_character ......... = 035} 'PADDING_CHARACTER              ',
      {fsc$page_format ............... = 036} 'PAGE_FORMAT                    ',
      {fsc$page_length ............... = 037} 'PAGE_LENGTH                    ',
      {fsc$page_width ................ = 038} 'PAGE_WIDTH                     ',
      {fsc$preset_value .............. = 039} 'PRESET_VALUE                   ',
      {fsc$record_delimiting_character = 041} 'RECORD_DELIMITING_CHARACTER    ',
      {fsc$record_limit .............. = 040} 'RECORD_LIMIT                   ',
      {fsc$record_type ............... = 042} 'RECORD_TYPE                    ',
      {fsc$records_per_block ......... = 043} 'RECORDS_PER_BLOCK              ',
      {fsc$ring_attributes ........... = 044} 'RING_ATTRIBUTES                ',
      {fsc$statement_identifier ...... = 045} 'STATEMENT_IDENTIFIER           ',
      {fsc$user_attributes ........... = 046} 'USER_ATTRIBUTES                ',
      {fsc$vertical_print_density .... = 047} 'VERTICAL_PRINT_DENSITY         ',
      {fsc$user_information .......... = 048} 'USER_INFORMATION               ',
      {fsc$retention ................. = 049} 'RETENTION                      ',
      {fsc$retreive_option ........... = 050} 'RETRIEVE_OPTION                ',
      {fsc$site_backup_option ........ = 051} 'SITE_BACKUP_OPTION             ',
      {fsc$site_archive_option ....... = 052} 'SITE_ARCHIVE_OPTION            ',
      {fsc$site_release_option ....... = 053} 'SITE_RELEASE_OPTION            '];

  PROCEDURE [INLINE] validate_file_contents (potential_name: amt$file_contents;
    VAR name_is_valid: boolean);

    TYPE
      char_set = set of char;

    VAR
      ignore_scan_found_char: boolean,
      non_name_chars: char_set,
      scan_index: 1 .. osc$max_name_size + 1,
      scan_after_mark_index: 1 .. osc$max_name_size + 1;

    CASE potential_name (1) OF
    = '#', '$', '@', 'A' .. 'Z', 'a' .. 'z', '[', '\', ']', '^', '_', '`', '{',
          '|', '}', '~' =
      non_name_chars := - $char_set ['#', '$', '0', '1', '2', '3', '4', '5',
            '6', '7', '8', '9', '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H',
            'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U',
            'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h',
            'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u',
            'v', 'w', 'x', 'y', 'z', '[', '\', ']', '^', '_', '`', '{', '|',
            '}', '~'];
      #scan (non_name_chars, potential_name, scan_index,
            ignore_scan_found_char);
      IF (scan_index < STRLENGTH(potential_name)) AND (potential_name (scan_index, 1) = $char(200)) THEN
        #scan (non_name_chars, potential_name ((scan_index + 1), *), scan_after_mark_index,
              ignore_scan_found_char);
        IF scan_after_mark_index > 1 THEN
          scan_index := scan_index + scan_after_mark_index;
        IFEND;
      IFEND;
      name_is_valid := potential_name (scan_index, * ) = '';
    ELSE
      name_is_valid := FALSE;
    CASEND;

  PROCEND validate_file_contents;
*copyc osv$lower_to_upper
*copyc amd$file_contents
*copyc ost$name

?? TITLE := '[XDCL] fsp$validate_attributes', EJECT ??

  PROCEDURE [XDCL] fsp$validate_attributes
    (    attributes: ^fst$file_cycle_attributes;
         status_text: string ( * );
         status_reporting_procedure_ptr: fst$status_reporting_procedure;
     VAR status: ost$status);

    VAR
      attribute_key_is_good: boolean,
      attribute_value_is_good: boolean,
      date_time: ost$date_time,
      expiration_date: ost$date_time,
      fsv$logging_options: [STATIC, READ, oss$job_paged_literal]
        amt$logging_options := [amc$enable_parcels, amc$enable_media_recovery,
        amc$enable_request_recovery],
      i: integer,
      i_string: ost$string,
      ignore_file: fst$parsed_file_reference,
      ignore_status: ost$status;

    status.normal := TRUE;
    IF attributes = NIL THEN
      RETURN;
    IFEND;

    FOR i := 1 TO UPPERBOUND (attributes^) DO
      attribute_key_is_good := TRUE;
      attribute_value_is_good := TRUE;
      CASE attributes^ [i].selector OF
      = fsc$average_record_length =
          attribute_value_is_good := (attributes^ [i].average_record_length >=
          LOWERVALUE (amt$average_record_length)) AND (attributes^ [i].
          average_record_length <= UPPERVALUE (amt$average_record_length));
      = fsc$block_type =
        attribute_value_is_good := (attributes^ [i].block_type >=
          LOWERVALUE (amt$block_type)) AND (attributes^ [i].block_type <=
          UPPERVALUE (amt$block_type));
      = fsc$character_conversion =
        attribute_value_is_good := (attributes^ [i].character_conversion >=
          LOWERVALUE (boolean)) AND (attributes^ [i].character_conversion <=
          UPPERVALUE (boolean));
      = fsc$collate_table_name =
        IF attributes^ [i].collate_table_name <> NIL THEN
          IF attributes^ [i].collate_table_name^.entry_point <> osc$null_name THEN
            clp$only_validate_name (attributes^ [i].collate_table_name^.entry_point,
                  attribute_value_is_good);
            IF attributes^ [i].collate_table_name^.object_library <> osc$null_name THEN
              clp$convert_string_to_file_ref (attributes^ [i].collate_table_name^.object_library,
                    ignore_file, status);
              attribute_value_is_good := status.normal;
            IFEND;
          IFEND;
        ELSE
          attribute_value_is_good := FALSE;
        IFEND;
      = fsc$compression_procedure_name =
        IF attributes^ [i].compression_procedure_name <> NIL THEN
          IF attributes^ [i].compression_procedure_name^.name <>
                osc$null_name THEN
            clp$only_validate_name (attributes^ [i].compression_procedure_name^.name,
                  attribute_value_is_good);
            IF attributes^ [i].compression_procedure_name^.object_library
                  <> osc$null_name THEN
              clp$convert_string_to_file_ref (attributes^ [i].
                compression_procedure_name^.object_library, ignore_file, status);
              attribute_value_is_good := status.normal;
            IFEND;
          IFEND;
        ELSE
          attribute_value_is_good := FALSE;
        IFEND;
      = fsc$data_padding =
        attribute_value_is_good := (attributes^ [i].data_padding >= LOWERVALUE
          (amt$data_padding)) AND (attributes^ [i].data_padding <= UPPERVALUE
          (amt$data_padding));
      = fsc$dynamic_home_block_space =
        attribute_value_is_good := (attributes^ [i].dynamic_home_block_space >=
          LOWERVALUE (boolean)) AND (attributes^ [i].dynamic_home_block_space <=
          UPPERVALUE (boolean));
      = fsc$embedded_key =
        attribute_value_is_good := (attributes^ [i].embedded_key >= LOWERVALUE
          (boolean)) AND (attributes^ [i].embedded_key <= UPPERVALUE (boolean));
      = fsc$erase_at_deletion =
        attribute_value_is_good := (attributes^ [i].erase_at_deletion >= LOWERVALUE
          (boolean)) AND (attributes^ [i].erase_at_deletion <= UPPERVALUE (boolean));
      = fsc$estimated_record_count =
        ;
      = fsc$file_access_procedure_name =
        IF attributes^ [i].file_access_procedure_name <> NIL THEN
          IF attributes^ [i].file_access_procedure_name^.entry_point <> osc$null_name THEN
            clp$only_validate_name (attributes^ [i].file_access_procedure_name^.entry_point,
                  attribute_value_is_good);
            IF attributes^ [i].file_access_procedure_name^.object_library <> osc$null_name THEN
              clp$convert_string_to_file_ref (attributes^ [i].file_access_procedure_name^.object_library,
                    ignore_file, status);
              attribute_value_is_good := status.normal;
            IFEND;
          IFEND;
        ELSE
          attribute_value_is_good := FALSE;
        IFEND;
      = fsc$file_contents_and_processor =
        IF attributes^ [i].file_contents <> osc$null_name THEN
          validate_file_contents (attributes^ [i].file_contents, attribute_value_is_good);
        IFEND;
        IF attributes^ [i].file_processor <> osc$null_name THEN
          clp$only_validate_name (attributes^ [i].file_processor, attribute_value_is_good);
        IFEND;
      = fsc$file_label_type =
        attribute_value_is_good := (attributes^ [i].file_label_type >= LOWERVALUE
          (amt$file_label_type)) AND (attributes^ [i].file_label_type <=
          UPPERVALUE (amt$file_label_type));
      = fsc$file_limit =
        attribute_value_is_good := (attributes^ [i].file_limit >= LOWERVALUE
          (amt$file_limit)) AND (attributes^ [i].file_limit <= UPPERVALUE
          (amt$file_limit));
      = fsc$file_organization =
        attribute_value_is_good := (attributes^ [i].file_organization >=
          LOWERVALUE (amt$file_organization)) AND (attributes^ [i].
          file_organization <= UPPERVALUE (amt$file_organization));
      = fsc$forced_write =
        attribute_value_is_good := (attributes^ [i].forced_write >= LOWERVALUE
          (amt$forced_write)) AND (attributes^ [i].forced_write <= UPPERVALUE
          (amt$forced_write));
      = fsc$hashing_procedure_name =
        IF attributes^ [i].hashing_procedure_name <> NIL THEN
          IF attributes^ [i].hashing_procedure_name^.name <> osc$null_name THEN
            clp$only_validate_name (attributes^ [i].hashing_procedure_name^.name,
                  attribute_value_is_good);
            IF attributes^ [i].hashing_procedure_name^.object_library <>
                  osc$null_name THEN
              clp$convert_string_to_file_ref (attributes^ [i].hashing_procedure_name^.
                object_library, ignore_file, status);
              attribute_value_is_good := status.normal;
            IFEND;
          IFEND;
        ELSE
          attribute_value_is_good := FALSE;
        IFEND;
      = fsc$index_levels =
        attribute_value_is_good := (attributes^ [i].index_levels >= LOWERVALUE
          (amt$index_levels)) AND (attributes^ [i].index_levels <= UPPERVALUE
          (amt$index_levels));
      = fsc$index_padding =
        attribute_value_is_good := (attributes^ [i].index_padding >= LOWERVALUE
          (amt$index_padding)) AND (attributes^ [i].index_padding <= UPPERVALUE
          ( amt$index_padding));
      = fsc$initial_home_block_count =
        attribute_value_is_good := (attributes^ [i].initial_home_block_count >=
          LOWERVALUE (amt$initial_home_block_count)) AND (attributes^ [i].
          initial_home_block_count <= UPPERVALUE (amt$initial_home_block_count));
      = fsc$internal_code =
        attribute_value_is_good := (attributes^ [i].internal_code >= LOWERVALUE
          (amt$internal_code)) AND (attributes^ [i].internal_code <= UPPERVALUE
          (amt$internal_code));
      = fsc$key_length =
        attribute_value_is_good := (attributes^ [i].key_length >= LOWERVALUE
          (amt$key_length)) AND (attributes^ [i].key_length <= UPPERVALUE
          (amt$key_length));
      = fsc$key_position =
        attribute_value_is_good := (attributes^ [i].key_position >= LOWERVALUE
          (amt$key_position)) AND (attributes^ [i].key_position <= UPPERVALUE
          (amt$key_position));
      = fsc$key_type =
        attribute_value_is_good := (attributes^ [i].key_type >= LOWERVALUE
          (amt$key_type)) AND (attributes^ [i].key_type <= UPPERVALUE
          (amt$key_type));
      = fsc$line_number =
        attribute_value_is_good := (attributes^ [i].line_number.length >=
          LOWERVALUE (amt$line_number_length)) AND (attributes^ [i].
          line_number.length <= UPPERVALUE (amt$line_number_length))
          AND (attributes^ [i].line_number.location >= LOWERVALUE
          (amt$line_number_location)) AND (attributes^ [i].line_number.location
          <= UPPERVALUE (amt$line_number_location));
      = fsc$loading_factor =
        attribute_value_is_good := (attributes^ [i].loading_factor >= LOWERVALUE
          (amt$loading_factor)) AND (attributes^ [i].loading_factor <= UPPERVALUE
          (amt$loading_factor));
      = fsc$lock_expiration_time =
        attribute_value_is_good := (attributes^ [i].lock_expiration_time >=
          LOWERVALUE (amt$lock_expiration_time)) AND (attributes^ [i].lock_expiration_time
          <= UPPERVALUE (amt$lock_expiration_time));
      = fsc$log_residence =
        IF attributes^ [i].log_residence <> NIL THEN
          IF attributes^ [i].log_residence^ <> osc$null_name THEN
            clp$convert_string_to_file_ref (attributes ^[i].log_residence^,
                  ignore_file, status);
            attribute_value_is_good := status.normal;
          IFEND;
        ELSE
          attribute_value_is_good := FALSE;
        IFEND;
      = fsc$logging_options =
        attribute_value_is_good := (attributes^ [i].logging_options <= fsv$logging_options);
      = fsc$max_block_length =
        attribute_value_is_good := (attributes^ [i].max_block_length >=
          LOWERVALUE (amt$max_block_length)) AND (attributes^ [i].
          max_block_length <= UPPERVALUE (amt$max_block_length));
      = fsc$max_record_length =
        attribute_value_is_good := (attributes^ [i].max_record_length >=
          LOWERVALUE (amt$max_record_length)) AND (attributes^ [i].
          max_record_length <= UPPERVALUE (amt$max_record_length));
      = fsc$min_block_length =
        attribute_value_is_good := (attributes^ [i].min_block_length >=
          LOWERVALUE (amt$min_block_length)) AND (attributes^ [i].
          min_block_length <= UPPERVALUE (amt$min_block_length));
      = fsc$min_record_length =
        attribute_value_is_good := (attributes^ [i].min_record_length >=
          LOWERVALUE (amt$min_record_length)) AND (attributes^ [i].
          min_record_length <= UPPERVALUE (amt$min_record_length));
      = fsc$null_attribute =
        ;
      = fsc$padding_character =
        ;
      = fsc$page_format =
        attribute_value_is_good := (attributes^ [i].page_format >= LOWERVALUE
          (amt$page_format)) AND (attributes^ [i].page_format <= UPPERVALUE
          (amt$page_format));
      = fsc$page_length =
        attribute_value_is_good := (attributes^ [i].page_length >= LOWERVALUE
          (amt$page_length)) AND (attributes^ [i].page_length <= UPPERVALUE
          (amt$page_length));
      = fsc$page_width =
        attribute_value_is_good := (attributes^ [i].page_width >= LOWERVALUE
          (amt$page_width)) AND (attributes^ [i].page_width <= UPPERVALUE
          (amt$page_width));
      = fsc$preset_value =
        ;
      = fsc$record_delimiting_character =
        ;
      = fsc$record_limit =
        attribute_value_is_good := (attributes^ [i].record_limit >= LOWERVALUE
          (amt$record_limit)) AND (attributes^ [i].record_limit <= UPPERVALUE
          (amt$record_limit));
      = fsc$record_type =
        attribute_value_is_good := (attributes^ [i].record_type >= LOWERVALUE
          (amt$record_type)) AND (attributes^ [i].record_type <= UPPERVALUE
          (amt$record_type));
      = fsc$records_per_block =
        attribute_value_is_good := (attributes^ [i].records_per_block >= LOWERVALUE
          (amt$records_per_block)) AND (attributes^ [i].records_per_block <= UPPERVALUE
          (amt$records_per_block));
      = fsc$ring_attributes =
        IF NOT ((1 <= attributes^ [i].ring_attributes.r1) AND (attributes^ [i].ring_attributes.r1 <=
              attributes^ [i].ring_attributes.r2) AND (attributes^ [i].ring_attributes.r2 <= attributes^ [i].
              ring_attributes.r3) AND (attributes^ [i].ring_attributes.r3 <= 13)) THEN
          attribute_value_is_good := FALSE;
        IFEND;
      = fsc$statement_identifier =
        attribute_value_is_good := (attributes^ [i].statement_identifier.length >=
           LOWERVALUE (amt$statement_id_length)) AND (attributes^ [i].statement_identifier.length <=
           UPPERVALUE (amt$statement_id_length)) AND (attributes^ [i].statement_identifier.location >=
           LOWERVALUE (amt$statement_id_location)) AND (attributes^ [i].statement_identifier.location <=
           UPPERVALUE (amt$statement_id_location));
      = fsc$user_attribute =
        IF attributes^ [i].user_attribute.name <> osc$null_name THEN
          clp$only_validate_name (attributes^ [i].user_attribute.name,
                attribute_value_is_good);
        IFEND;
        attribute_value_is_good := (attributes^ [i].user_attribute.selector >=
          LOWERVALUE (fst$user_attribute_type)) AND (attributes^ [i].user_attribute.selector <=
          UPPERVALUE (fst$user_attribute_type));
      = fsc$user_information =
        ;
      = fsc$vertical_print_density =
        attribute_value_is_good := (attributes^ [i].vertical_print_density >=
          LOWERVALUE (amt$vertical_print_density)) AND (attributes^ [i].vertical_print_density <=
          UPPERVALUE (amt$vertical_print_density));
      = fsc$retention =
        CASE attributes^ [i].retention.selector OF
        = fsc$retention_day_increment =
          attribute_value_is_good :=
                ((attributes^ [i].retention.day_increment >= LOWERVALUE(pft$retention)) AND
                (attributes^ [i].retention.day_increment <= UPPERVALUE(pft$retention)));
        = fsc$retention_time_increment =
          clp$verify_time_increment (attributes^ [i].retention.time_increment, status);
          IF status.normal THEN
            pmp$get_compact_date_time (date_time, ignore_status);
            pmp$compute_date_time (date_time, attributes^ [i].retention.time_increment, expiration_date,
                  status);
          IFEND;
          attribute_value_is_good := status.normal;
        = fsc$retention_expiration_date =
          pmp$verify_compact_date (attributes^ [i].retention.expiration_date, status);
          IF status.normal THEN
            pmp$verify_compact_time (attributes^ [i].retention.expiration_date, status);
          IFEND;
          attribute_value_is_good := status.normal;
        ELSE
          attribute_value_is_good := FALSE;
        CASEND;
      = fsc$retrieve_option =
        attribute_value_is_good :=
              (((attributes^ [i].retrieve_option >= LOWERVALUE(pft$retrieve_option)) AND
              (attributes^ [i].retrieve_option <= UPPERVALUE(pft$retrieve_option))));
      = fsc$site_backup_option =
        attribute_value_is_good :=
              (((attributes^ [i].site_backup_option >= LOWERVALUE(pft$site_backup_option)) AND
              (attributes^ [i].site_backup_option <= UPPERVALUE(pft$site_backup_option))));
      = fsc$site_archive_option =
        attribute_value_is_good :=
              (((attributes^ [i].site_archive_option >= LOWERVALUE(pft$site_archive_option)) AND
              (attributes^ [i].site_archive_option <= UPPERVALUE(pft$site_archive_option))));
      = fsc$site_release_option =
        attribute_value_is_good :=
              (((attributes^ [i].site_release_option >= LOWERVALUE(pft$site_release_option)) AND
              (attributes^ [i].site_release_option <= UPPERVALUE(pft$site_release_option))));
      ELSE
        attribute_key_is_good := FALSE;
      CASEND;

      IF NOT attribute_key_is_good THEN
        clp$convert_integer_to_string (i, 10, FALSE, i_string, ignore_status);
        IF status.normal OR (status.condition <> ame$improper_file_attrib_key) THEN
          status_reporting_procedure_ptr^ (ame$improper_file_attrib_key,
                status_text, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                i_string.value (1, i_string.size), status);
        ELSE
          osp$append_status_parameter (',', i_string.value (1, i_string.size), status);
        IFEND;
      ELSEIF NOT attribute_value_is_good THEN
        IF status.normal THEN
          status_reporting_procedure_ptr^ (ame$improper_file_attrib_value,
                status_text, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                fsv$attribute_names^ [attributes^ [i].selector], status);
        ELSEIF status.condition = ame$improper_file_attrib_value THEN
          osp$append_status_parameter (',', fsv$attribute_names^ [attributes^ [i].selector], status);
        IFEND;
      IFEND;
    FOREND;

  PROCEND fsp$validate_attributes;

MODEND fsm$validate_attributes;
*DECK DECK=FSM$VALIDATE_FILE_IDENTIFIER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Basic Access Methods : Validate File Identifier' ??
MODULE fsm$validate_file_identifier;

{ PURPOSE:
{   The purpose of this module is to provide an interface that validates
{   a file_identifier.

?? NEWTITLE := 'Global Declarations Referenced By This Module', EJECT ??
*copyc bap$validate_file_identifier
?? OLDTITLE ??
*copyc fsh$validate_file_identifier
?? NEWTITLE := '[XDCL, #GATE] fsp$validate_file_identifier', EJECT ??

  PROCEDURE [XDCL, #GATE] fsp$validate_file_identifier
    (    file_identifier: amt$file_identifier;
     VAR file_id_is_valid: boolean);

    VAR
      file_instance: ^bat$task_file_entry;

    bap$validate_file_identifier (file_identifier, file_instance, file_id_is_valid);

  PROCEND fsp$validate_file_identifier;
?? OLDTITLE ??
MODEND fsm$validate_file_identifier;
*DECK DECK=FSP#EXPAND_FILE_LABEL EXPAND=FALSE
  PROCEDURE [XREF] fsp#expand_file_label {FSM#EXPAND_FILE_LABEL
    (    file_label_p: ^SEQ ( * );
         requested_label_atts: fmt#file_attribute_keys_set;
     VAR label_atts: bat$static_label_attributes;
     VAR file_previously_opened: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt#file_attribute_keys_set

*copyc bat$static_label_attributes
*copyc ost$status
?? POP ??
*DECK DECK=FSP$ADJUST_TAPE_DEFAULTS EXPAND=FALSE

  PROCEDURE [INLINE] fsp$adjust_tape_defaults
    (    tape_density: rmt$density;
     VAR static_label_attributes: bat$static_label_attributes);

    IF static_label_attributes.label_type_source = amc$access_method_default THEN
      static_label_attributes.label_type := amc$labelled;
    IFEND;

    IF (static_label_attributes.max_block_length_source = amc$access_method_default) AND
          (tape_density = rmc$38000) THEN
      static_label_attributes.max_block_length := 32640;
    IFEND;

  PROCEND fsp$adjust_tape_defaults;

?? PUSH (LISTEXT := ON) ??
*copyc bat$static_label_attributes
*copyc rmt$density
?? POP ??
*DECK DECK=FSP$ANALYZE_FILE_EXPIRATION EXPAND=FALSE
  PROCEDURE [XREF] fsp$analyze_file_expiration
    (    expiration_date: string (6);
     VAR file_is_expired: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=FSP$APPEND_STAT_EVALUATED_FILE EXPAND=FALSE

  PROCEDURE [XREF] fsp$append_stat_evaluated_file
    (    delimiter: char;
         evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: {i/o} ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc osc$status_parameter_delimiter
*copyc ost$status
?? POP ??
*DECK DECK=FSP$BUILD_FILE_REF_FROM_ELEMS EXPAND=FALSE

  PROCEDURE [INLINE] fsp$build_file_ref_from_elems
    (    path_elements: ^pft$path;
     VAR file_reference: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      element_size: ost$name_size,
      first_blank: integer,
      index: fst$number_of_path_elements,
      position: fst$path_size,
      result: boolean;

    status.normal := TRUE;
    file_reference := ':';
    #scan (pfv$space_character, path_elements^ [1], first_blank, {ignore} result);
    element_size := first_blank - 1;
    file_reference (2, element_size) := path_elements^ [1] (1, element_size);
    position := 1 + element_size;
    FOR index := 2 TO UPPERBOUND (path_elements^) DO
      #scan (pfv$space_character, path_elements^ [index], first_blank, {ignore} result);
      element_size := first_blank - 1;
      IF (position + 1 + element_size) <= fsc$max_path_size THEN
        file_reference (position + 1) := '.';
        file_reference (position + 2, element_size) :=
              path_elements^ [index] (1, element_size);
        position := position + 1 + element_size;
      ELSE
        osp$set_status_condition (cle$file_reference_too_long, status);
      IFEND;
    FOREND;
  PROCEND fsp$build_file_ref_from_elems;

*copyc cle$ecc_file_reference
*copyc clp$trimmed_string_size
*copyc fst$file_reference
*copyc fst$number_of_path_elements
*copyc fst$path_size
*copyc ost$name
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pfd$permanent_file_definitions
*copyc pfv$space_character
?? POP ??
*DECK DECK=FSP$CHANGE_CATALOG_FLUSH_OPTION EXPAND=FALSE

  PROCEDURE [XREF] fsp$change_catalog_flush_option
    (    flush_catalogs: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=FSP$CHANGE_CYCLE_DAMAGE EXPAND=FALSE

  PROCEDURE [XREF] fsp$change_cycle_damage
    (    file: fst$file_reference;
         password: pft$password;
         new_damage_symptoms: fst$cycle_damage_symptoms;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$cycle_damage_symptoms
*copyc fst$file_reference
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=FSP$CHANGE_CYCLE_DATE_TIME EXPAND=FALSE

  PROCEDURE [XREF] fsp$change_cycle_date_time
    (    file: fst$file_reference;
         password: pft$password;
         p_new_access_date_time: ^fst$date_time;
         p_new_modification_date_time: ^fst$date_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fse$vxve_exception_conditions
*copyc fst$date_time
*copyc fst$file_reference
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=FSP$CHANGE_FILE EXPAND=FALSE

  PROCEDURE [XREF] fsp$change_file
    (    file: fst$file_reference;
         password: pft$password;
         file_changes: ^fst$file_changes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$cycle_damage_symptoms
*copyc fst$file_changes
*copyc fst$file_reference
*copyc fst$retention
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pft$retrieve_option
*copyc pft$shared_queue
*copyc pft$site_archive_option
*copyc pft$site_backup_option
*copyc pft$site_release_option
?? POP ??
*DECK DECK=FSP$CHANGE_SEGMENT_NUMBER EXPAND=FALSE

  PROCEDURE [XREF] fsp$change_segment_number
    (    file_identifier: amt$file_identifier;
         new_segment_number: ost$segment;
         validation_ring: ost$valid_ring;
         pointer_kind: amt$pointer_kind;
     VAR segment_pointer: amt$segment_pointer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$access_validation_errors
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc ame$ring_validation_errors
*copyc ame$segment_validation_errors
*copyc amt$file_identifier
*copyc amt$segment_pointer
*copyc osd$virtual_address
*copyc ost$status

?? POP ??
*DECK DECK=FSP$CLASSIFY_TAPE_LABEL EXPAND=FALSE

  PROCEDURE [XREF] fsp$classify_tape_label
    (    label_string: string ( * );
     VAR label_classification: fst$tape_label_classification);

?? PUSH (LISTEXT := ON) ??
*copyc fst$tape_label_classification
?? POP ??
*DECK DECK=FSP$CLOSE_FILE EXPAND=FALSE

  PROCEDURE [XREF] fsp$close_file (file_identifier:
    amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc ame$put_program_actions
*copyc ame$ring_validation_errors
*ELSE
*copyc ame$condition_codes
*IFEND
*copyc amt$file_identifier
*copyc ost$status
?? POP ??





*DECK DECK=FSP$CONTENTS_IS_LEGIBLE EXPAND=FALSE
*copyc amd$file_contents
*copyc fsc$file_contents

  FUNCTION [INLINE] fsp$contents_is_legible
    (    file_contents: amt$file_contents): boolean;


    fsp$contents_is_legible := (file_contents = fsc$legible_data) OR
          (file_contents = fsc$legible_scl_procedure) OR
          (file_contents = fsc$legible_scl_include) OR
          (file_contents = fsc$legible_scl_job);

  FUNCEND fsp$contents_is_legible;

*DECK DECK=FSP$CONVERT_DEVICE_CLASS_TO_FS EXPAND=FALSE

  PROCEDURE [INLINE] fsp$convert_device_class_to_fs
    (    rm_device_class: rmt$device_class;
     VAR fs_device_class: fst$device_class);

?? PUSH (LISTEXT := ON) ??

    CASE rm_device_class OF
    = rmc$connected_file_device =
      fs_device_class := fsc$connected_file_device;
    = rmc$interstate_link_device =
      fs_device_class := fsc$interstate_link_device;
    = rmc$local_queue_device =
      fs_device_class := fsc$local_queue_device;
    = rmc$log_device =
      fs_device_class := fsc$log_device;
    = rmc$magnetic_tape_device =
      fs_device_class := fsc$magnetic_tape_device;
    = rmc$mass_storage_device =
      fs_device_class := fsc$mass_storage_device;
    = rmc$memory_resident_device =
      fs_device_class := fsc$memory_resident_device;
    = rmc$network_device =
      fs_device_class := fsc$network_device;
    = rmc$null_device =
      fs_device_class := fsc$null_device;
    = rmc$pipeline_device =
      fs_device_class := fsc$pipeline_device;
    = rmc$rhfam_device =
      fs_device_class := fsc$rhfam_device;
    = rmc$terminal_device =
      fs_device_class := fsc$terminal_device;
    ELSE
      fs_device_class := fsc$mass_storage_device;
    CASEND;

  PROCEND fsp$convert_device_class_to_fs;

*copyc fst$device_class
*copyc rmt$device_class
?? POP ??
*DECK DECK=FSP$CONVERT_FILE_CONTENTS EXPAND=FALSE

  PROCEDURE [XREF] fsp$convert_file_contents
    (    file_contents: amt$file_contents;
         file_structure: amt$file_structure;
     VAR converted_file_contents: amt$file_contents;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_contents
*copyc amd$file_structure
*copyc ost$status
?? POP ??
*DECK DECK=FSP$CONVERT_FS_STRUCTURE_TO_PF EXPAND=FALSE

  PROCEDURE  fsp$convert_fs_structure_to_pf
    (    evaluated_file_reference: fst$evaluated_file_reference;
     VAR pf_path_elements: ^pft$path);

?? PUSH (LISTEXT := ON) ??

    VAR
      i: fst$number_of_path_elements,
      path_element_size: fst$path_element_size,
      path_index: fst$path_index;

    path_index := 1;
    FOR i := 1 TO evaluated_file_reference.number_of_path_elements DO
      path_element_size := $INTEGER (evaluated_file_reference.
            path_structure (path_index));
      pf_path_elements^ [i] := evaluated_file_reference.
            path_structure (path_index + 1, path_element_size);
      path_index := path_index + path_element_size + 1;
    FOREND;

  PROCEND fsp$convert_fs_structure_to_pf;

*copyc fst$evaluated_file_reference
*copyc fst$number_of_path_elements
*copyc fst$path_element_size
*copyc fst$path_index
*copyc pfd$permanent_file_definitions
?? POP ??

*DECK DECK=FSP$CONVERT_STATUS_CONDITION EXPAND=FALSE
*DECK DECK=FSP$CONVERT_TO_NEW_CONTENTS EXPAND=FALSE
*copyc amd$file_contents
*copyc amd$file_structure
*copyc fsc$file_contents
*copyc clp$trimmed_string_size

  PROCEDURE [INLINE] fsp$convert_to_new_contents
    (    static_file_contents: amt$file_contents;
         static_file_structure: amt$file_structure;
     VAR new_file_contents: amt$file_contents;
     VAR file_contents_truncated: boolean);

    VAR
      file_contents_size: 1 .. osc$max_name_size + 1,
      file_structure_size: 1 .. osc$max_name_size + 1;


    file_contents_truncated := FALSE;

    IF (static_file_contents = 'UNKNOWN') AND (static_file_structure =
          'UNKNOWN') THEN
      new_file_contents := fsc$unknown_contents;
    ELSEIF (static_file_contents = 'LIST') AND
          ((static_file_structure = 'DATA') OR (static_file_structure =
          'UNKNOWN')) THEN
      new_file_contents := fsc$list;
    ELSEIF (static_file_contents = 'LEGIBLE') AND ((static_file_structure =
          'DATA') OR (static_file_structure = 'UNKNOWN')) THEN
      new_file_contents := fsc$legible_data;
    ELSEIF (static_file_contents = 'LEGIBLE') AND (static_file_structure =
          'LIBRARY') THEN
      new_file_contents := fsc$legible_library;
    ELSEIF (static_file_contents = 'LEGIBLE') AND (static_file_structure =
          'SCL_PROCEDURE') THEN
      new_file_contents := fsc$legible_scl_procedure;
    ELSEIF (static_file_contents = 'LEGIBLE') AND (static_file_structure =
          'SCL_INCLUDE') THEN
      new_file_contents := fsc$legible_scl_include;
    ELSEIF (static_file_contents = 'LEGIBLE') AND (static_file_structure =
          'SCL_JOB') THEN
      new_file_contents := fsc$legible_scl_job;
    ELSEIF (static_file_contents = 'OBJECT') AND (static_file_structure =
          'LIBRARY') THEN
      new_file_contents := fsc$object_library;
    ELSEIF (static_file_contents = 'OBJECT') AND (static_file_structure =
          'DATA') THEN
      new_file_contents := fsc$object_data;
    ELSEIF (static_file_contents = 'ASCII_LOG') AND (static_file_structure =
          'DATA') THEN
      new_file_contents := fsc$ascii_log;
    ELSEIF (static_file_contents = 'BINARY_LOG') AND (static_file_structure =
          'DATA') THEN
      new_file_contents := fsc$binary_log;
    ELSEIF (static_file_contents = 'UNKNOWN') AND (static_file_structure =
          'DATA') THEN
      new_file_contents := fsc$data;
    ELSEIF (static_file_contents = 'FILE_BACKUP') AND (static_file_structure =
          'DATA') THEN
      new_file_contents := fsc$file_backup;
    ELSEIF (static_file_contents = 'SCREEN') AND (static_file_structure =
          'FORM') THEN
      new_file_contents := fsc$screen_form;
    ELSE
      file_contents_size := clp$trimmed_string_size (static_file_contents);
      file_structure_size := clp$trimmed_string_size (static_file_structure);
      file_contents_truncated := ((file_contents_size + file_structure_size +
            1) > STRLENGTH (new_file_contents)) AND (static_file_structure <>
            'UNKNOWN');

      new_file_contents := static_file_contents;
      IF ((file_contents_size + 1) < STRLENGTH (new_file_contents)) AND
            (static_file_structure <> 'UNKNOWN') THEN
        new_file_contents ((file_contents_size + 1), 1) := $CHAR (200);
        new_file_contents ((file_contents_size + 2), * ) :=
              static_file_structure;
      IFEND;
    IFEND;

  PROCEND fsp$convert_to_new_contents;
*DECK DECK=FSP$CONVERT_TO_OLD_CONTENTS EXPAND=FALSE
*copyc amd$file_contents
*copyc amd$file_structure
*copyc fsc$file_contents
*copyc ost$name

  PROCEDURE [INLINE] fsp$convert_to_old_contents
    (    new_file_contents: amt$file_contents;
     VAR static_file_contents: amt$file_contents;
     VAR static_file_structure: amt$file_structure);

    TYPE
      ch = set of char;

    VAR
      found: boolean,
      mark_index: 1 .. osc$max_name_size + 1,
      mark: ch;


    IF new_file_contents = fsc$unknown_contents THEN
      static_file_contents := fsc$unknown_contents;
      static_file_structure := fsc$unknown_contents;
    ELSEIF new_file_contents = fsc$list THEN
      static_file_contents := fsc$list;
      static_file_structure := 'DATA';
    ELSEIF new_file_contents = fsc$object_library THEN
      static_file_contents := 'OBJECT';
      static_file_structure := 'LIBRARY';
    ELSEIF new_file_contents = fsc$legible_data THEN
      static_file_contents := 'LEGIBLE';
      static_file_structure := 'DATA';
    ELSEIF new_file_contents = fsc$legible_scl_procedure THEN
      static_file_contents := 'LEGIBLE';
      static_file_structure := 'SCL_PROCEDURE';
    ELSEIF new_file_contents = fsc$legible_scl_include THEN
      static_file_contents := 'LEGIBLE';
      static_file_structure := 'SCL_INCLUDE';
    ELSEIF new_file_contents = fsc$legible_scl_job THEN
      static_file_contents := 'LEGIBLE';
      static_file_structure := 'SCL_JOB';
    ELSEIF new_file_contents = fsc$legible_library THEN
      static_file_contents := 'LEGIBLE';
      static_file_structure := 'LIBRARY';
    ELSEIF new_file_contents = fsc$object_data THEN
      static_file_contents := 'OBJECT';
      static_file_structure := 'DATA';
    ELSEIF new_file_contents = fsc$ascii_log THEN
      static_file_contents := fsc$ascii_log;
      static_file_structure := 'DATA';
    ELSEIF new_file_contents = fsc$binary_log THEN
      static_file_contents := fsc$binary_log;
      static_file_structure := 'DATA';
    ELSEIF new_file_contents = fsc$data THEN
      static_file_contents := fsc$unknown_contents;
      static_file_structure := fsc$data;
    ELSEIF new_file_contents = fsc$file_backup THEN
      static_file_contents := fsc$file_backup;
      static_file_structure := 'DATA';
    ELSEIF new_file_contents = fsc$screen_form THEN
      static_file_contents := 'SCREEN';
      static_file_structure := 'FORM';
    ELSEIF new_file_contents = fsc$source_map THEN
      static_file_contents := 'SOURCE_MAP';
      static_file_structure := 'UNKNOWN';
    ELSE
      mark := $ch [$CHAR (200)];
      #SCAN (mark, new_file_contents, mark_index, found);
      IF found THEN
        static_file_contents := new_file_contents (1, mark_index - 1);
        static_file_structure := new_file_contents (mark_index + 1, * )
      ELSE
        static_file_contents := new_file_contents;
        static_file_structure := fsc$unknown_contents;
      IFEND;
    IFEND;

  PROCEND fsp$convert_to_old_contents;
*DECK DECK=FSP$COPY_DATA_AND_CLOSE_FILES EXPAND=FALSE

  PROCEDURE [XREF] fsp$copy_data_and_close_files (input_fid:
    amt$file_identifier;
        output_fid: amt$file_identifier;
        control_info: fst$copy_control_information;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc fst$copy_control_information
*copyc ost$status
*copyc amc$condition_code_limits
*copyc ame$access_validation_errors
*copyc ame$get_program_actions
*copyc ame$lfn_program_actions
*copyc ame$open_validation_errors
*copyc ame$put_program_actions
*copyc ame$put_validation_errors
*copyc ame$ring_validation_errors
*copyc ame$unimplemented_request
*copyc fse$copy_validation_errors
?? POP ??
*DECK DECK=FSP$COPY_FILE EXPAND=FALSE
 PROCEDURE [XREF] fsp$copy_file (input: fst$file_reference;
        output: fst$file_reference;
        input_attribute_validation: ^fst$file_cycle_attributes;
        output_attribute_validation: ^fst$file_cycle_attributes;
        output_creation_attributes: ^fst$file_cycle_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$access_validation_errors
*copyc ame$get_program_actions
*copyc ame$lfn_program_actions
*copyc ame$open_validation_errors
*copyc ame$put_program_actions
*copyc ame$put_validation_errors
*copyc ame$ring_validation_errors
*copyc ame$unimplemented_request
*copyc fse$copy_validation_errors
*copyc fse$open_validation_errors
*copyc fst$file_cycle_attributes
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=FSP$CREATE_FILE EXPAND=FALSE

  PROCEDURE [XREF] fsp$create_file
    (    file: fst$file_reference;
         attachment_options: ^fst$attachment_options;
         cycle_attributes: ^fst$file_cycle_attributes;
         device_attributes: ^fst$device_attributes;
         file_attributes: ^fst$file_attributes;
     VAR resolved_path: fst$path;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fse$attach_validation_errors
*copyc fst$attachment_options
*copyc fst$device_attributes
*copyc fst$file_attributes
*copyc fst$file_cycle_attributes
*copyc fst$file_reference
*copyc ost$status
*copyc pfe$error_condition_codes
*copyc rme$request_mass_storage
?? POP ??
*DECK DECK=FSP$DEFAULT_FILE_CLASS EXPAND=FALSE
  FUNCTION [INLINE] fsp$default_file_class
    (    pf_path: pft$path): rmt$mass_storage_class;

?? PUSH (LISTEXT := ON) ??
    IF pf_path [pfc$family_name_index] = fsc$local THEN
      IF jmp$system_job () THEN
        fsp$default_file_class := rmc$msc_system_critical_files;
      ELSE
        fsp$default_file_class := rmc$msc_user_temporary_files;
      IFEND;
    ELSEIF jmp$system_job () OR (pf_path [pfc$master_catalog_name_index] = '$SYSTEM') THEN
      fsp$default_file_class := rmc$msc_system_permanent_files;
    ELSE
      fsp$default_file_class := rmc$msc_user_permanent_files;
    IFEND;

  FUNCEND fsp$default_file_class;

*copyc fsc$local
*copyc jmp$system_job
*copyc pfd$permanent_file_definitions
*copyc rmt$mass_storage_class
?? POP ??
*DECK DECK=FSP$DEFAULT_TAPE_LABEL_ATTRIB EXPAND=FALSE

  PROCEDURE [XREF] fsp$default_tape_label_attrib
    (    source: fst$tla_default_source;
     VAR attributes: fst$attachment_options;
     VAR returned_attributes: fst$tla_returned_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$attachment_options
*copyc fst$tla_default_source
*copyc fst$tla_returned_attributes
*copyc ost$status
?? POP ??

*DECK DECK=FSP$DETACH_FILE EXPAND=FALSE

  PROCEDURE [XREF] fsp$detach_file
    (    file: fst$file_reference;
         detachment_options: ^fst$detachment_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$lfn_program_actions
*copyc ame$ring_validation_errors
*copyc fst$detachment_options
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=FSP$DETERMINE_ACCESS_MODES EXPAND=FALSE

  PROCEDURE [INLINE] fsp$determine_access_modes
    (    job_environment_information_p: ^fst$job_environment_information;
         file_object_p: ^fst$goi_object;
     VAR access_modes: pft$usage_selections;
     VAR access_modes_source: amc$undefined_attribute .. amc$access_method_default);

?? PUSH (LISTEXT := ON) ??
    VAR
      status: ost$status,
      usage_option: pft$usage_options,
      usage_selections: pft$usage_selections;

    IF job_environment_information_p <> NIL THEN
      IF (job_environment_information_p^.attachment_options_sources.access_modes_source =
            amc$file_command) OR (job_environment_information_p^.attachment_options_sources.
            access_modes_source = amc$file_request) THEN
        #UNCHECKED_CONVERSION (job_environment_information_p^.setfa_access_modes, access_modes);
        access_modes_source := job_environment_information_p^.attachment_options_sources.access_modes_source;
        RETURN;
      ELSEIF job_environment_information_p^.cycle_attached THEN
        #UNCHECKED_CONVERSION (job_environment_information_p^.attached_access_modes, access_modes);
        access_modes_source := job_environment_information_p^.attachment_options_sources.access_modes_source;
        RETURN;
      IFEND;
    IFEND;

    IF (file_object_p <> NIL) AND (file_object_p^.applicable_file_permit <> NIL) THEN
      access_modes := $pft$usage_selections [];
      FOR usage_option := LOWERVALUE (pft$usage_options) TO UPPERVALUE (pft$usage_options) DO
        IF usage_option IN file_object_p^.applicable_file_permit^.usage_permissions THEN
          access_modes := access_modes + $pft$usage_selections [usage_option];
        IFEND;
      FOREND;
      access_modes_source := fmv$system_file_attributes.dynamic_label.access_mode_source;
    ELSE
      access_modes := fmv$system_file_attributes.dynamic_label.access_mode;
      access_modes_source := fmv$system_file_attributes.dynamic_label.access_mode_source;
    IFEND;

  PROCEND fsp$determine_access_modes;

*copyc amd$file_attributes
*copyc fmv$system_file_attributes
*copyc fst$goi_object
*copyc fst$job_environment_information
*copyc pfd$permanent_file_attributes
?? POP ??
*DECK DECK=FSP$DETERMINE_GLOBAL_ACCESS EXPAND=FALSE

  PROCEDURE [INLINE] fsp$determine_global_access
    (    ring_of_execution: ost$valid_ring;
         job_environment_information_p: ^fst$job_environment_information;
         file_object_p: ^fst$goi_object;
         cycle_object_p: ^fst$goi_object;
         ring_attributes: amt$ring_attributes;
     VAR global_access_modes: pft$usage_selections);

?? PUSH (LISTEXT := ON) ??
    VAR
      allowed_access_modes: fst$file_access_options,
      usage_option: pft$usage_options,
      usage_selections: pft$usage_selections;

{ Determine global access modes.

    IF (job_environment_information_p <> NIL) AND job_environment_information_p^.cycle_attached THEN
      allowed_access_modes := job_environment_information_p^.attached_access_modes -
            job_environment_information_p^.prevented_open_access_modes;
      #UNCHECKED_CONVERSION (allowed_access_modes, global_access_modes);
    ELSEIF (file_object_p <> NIL) AND (file_object_p^.applicable_file_permit <> NIL) THEN
      global_access_modes := $pft$usage_selections [];
      FOR usage_option := LOWERVALUE (pft$usage_options) TO UPPERVALUE (pft$usage_options) DO
        IF usage_option IN file_object_p^.applicable_file_permit^.usage_permissions THEN
          global_access_modes := global_access_modes + $pft$usage_selections [usage_option];
        IFEND;
      FOREND;
      IF (cycle_object_p <> NIL) AND (cycle_object_p^.cycle_information <> NIL) THEN
        global_access_modes := global_access_modes -
              cycle_object_p^.cycle_information^.prevented_access_modes;
      IFEND;
      IF ring_of_execution > ring_attributes.r3 THEN
        global_access_modes := $pft$usage_selections [];
      ELSEIF ring_of_execution > ring_attributes.r2 THEN
        global_access_modes := global_access_modes * $pft$usage_selections
              [pfc$execute];
      ELSEIF ring_of_execution > ring_attributes.r1 THEN
        global_access_modes := global_access_modes * $pft$usage_selections
              [pfc$read, pfc$execute];
      IFEND;
    ELSE
      global_access_modes := fmv$system_file_attributes.descriptive_label.global_access_mode;
    IFEND;

  PROCEND fsp$determine_global_access;

*copyc amt$ring_attributes
*copyc fmv$system_file_attributes
*copyc fst$file_access_options
*copyc fst$goi_object
*copyc fst$job_environment_information
*copyc osd$virtual_address
*copyc pfd$permanent_file_attributes
?? POP ??
*DECK DECK=FSP$DTM_STRUCTURE_FROM_CONTENTS EXPAND=FALSE
*copyc amd$file_contents
*copyc amd$file_structure

  PROCEDURE [INLINE] fsp$dtm_structure_from_contents
    (    file_contents: amt$file_contents;
     VAR file_structure: amt$file_structure);


    IF (file_contents = 'LEGIBLE') OR (file_contents = 'LIST') OR
          (file_contents = 'OBJECT') OR (file_contents = 'ASCII_LOG') OR
          (file_contents = 'BINARY_LOG') OR (file_contents = 'FILE_BACKUP')
          THEN
      file_structure := 'DATA';
    ELSEIF (file_contents = 'SCREEN') THEN
      file_structure := 'FORM';
    ELSE
      file_structure := 'UNKNOWN';
    IFEND;

  PROCEND fsp$dtm_structure_from_contents;
*DECK DECK=FSP$EVALUATE_FILE_FOR_CREATION EXPAND=FALSE

  PROCEDURE [INLINE] fsp$evaluate_file_for_creation
    (    file: fst$file_reference;
         command_file_reference_allowed: boolean;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
    CONST
      resolve_cycle_number = TRUE;

    VAR
      ignore_process_pt_results: bat$process_pt_results;

    clp$evaluate_file_reference (file, $clt$file_ref_parsing_options [], NOT resolve_cycle_number,
          evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local) AND
          (evaluated_file_reference.cycle_reference.specification <> fsc$cycle_number) THEN
      bap$process_pt_request ($bat$process_pt_work_list [bac$resolve_path],
            osc$null_name, evaluated_file_reference, ignore_process_pt_results,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND fsp$evaluate_file_for_creation;

*copyc fsc$local
*copyc fst$evaluated_file_reference
*copyc fst$file_reference
*copyc ost$status

*copyc bap$process_pt_request
*copyc clp$evaluate_file_reference
*copyc fsp$path_element
?? POP ??
*DECK DECK=FSP$EVALUATE_FILE_REFERENCE EXPAND=FALSE

  PROCEDURE [INLINE] fsp$evaluate_file_reference
    (    file: fst$file_reference;
         command_file_reference_allowed: boolean;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
    VAR
      file_reference_parsing_options: clt$file_ref_parsing_options,
      ignore_process_pt_results: bat$process_pt_results;

    status.normal := TRUE;

    IF command_file_reference_allowed THEN
      file_reference_parsing_options := $clt$file_ref_parsing_options
            [clc$use_$local_as_working_cat, clc$command_file_ref_allowed];
    ELSE
      file_reference_parsing_options := $clt$file_ref_parsing_options
            [clc$use_$local_as_working_cat];
    IFEND;
    clp$evaluate_file_reference (file, file_reference_parsing_options,
          {resolve_cycle_number=} FALSE, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Return permanent file path if alias and resolve if registered.
    IF (fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local) THEN
      bap$process_pt_request ($bat$process_pt_work_list [bac$resolve_path],
            osc$null_name, evaluated_file_reference, ignore_process_pt_results,
            status);
    IFEND;

  PROCEND fsp$evaluate_file_reference;

*copyc fsc$local
*copyc fst$evaluated_file_reference
*copyc fst$file_reference
*copyc ost$status

*copyc bap$process_pt_request
*copyc clp$evaluate_file_reference
*copyc fsp$path_element
?? POP ??
*DECK DECK=FSP$EXPAND_FILE_LABEL EXPAND=FALSE

  PROCEDURE [XREF] fsp$expand_file_label
    (    file_label: ^SEQ ( * );
     VAR static_label_attributes: bat$static_label_attributes;
     VAR file_previously_opened: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc bat$static_label_attributes
*copyc ost$status
?? POP ??
*DECK DECK=FSP$FILE_ACCESS_CONDITION EXPAND=FALSE
*DECK DECK=FSP$FILE_HEADER_LABELS EXPAND=FALSE
  FUNCTION [INLINE] fsp$file_header_labels
    (    label_group: fst$ansi_label_kinds): boolean;

    fsp$file_header_labels := (label_group *
          $fst$ansi_label_kinds [fsc$ansi_hdr1_label_kind,
          fsc$ansi_hdr2_label_kind, fsc$ansi_hdrn_label_kind,
          fsc$ansi_uhla_label_kind]) <> $fst$ansi_label_kinds [];

  FUNCEND fsp$file_header_labels;

?? PUSH (LISTEXT := ON) ??
*copyc fst$ansi_label_kinds
?? POP ??

*DECK DECK=FSP$FILE_IS_$JOB_LOG EXPAND=FALSE

  FUNCTION [INLINE] fsp$file_is_$job_log
    (file: ^fst$file_reference) : boolean;

    CONST
      job_log_path_length = 16;

    fsp$file_is_$job_log := (file <> NIL) AND (STRLENGTH (file^) >=
          job_log_path_length) AND (file^ (1, job_log_path_length) =
          ':$LOCAL.$JOB_LOG');

  FUNCEND fsp$file_is_$job_log;

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
?? POP ??
*DECK DECK=FSP$FILE_TRAILER_LABELS EXPAND=FALSE
  FUNCTION [INLINE] fsp$file_trailer_labels
    (    label_group: fst$ansi_label_kinds): boolean;

    fsp$file_trailer_labels := (label_group *
          $fst$ansi_label_kinds [fsc$ansi_eof1_label_kind,
          fsc$ansi_eof2_label_kind, fsc$ansi_eofn_label_kind,
          fsc$ansi_utla_label_kind]) <> $fst$ansi_label_kinds [];

  FUNCEND fsp$file_trailer_labels;

?? PUSH (LISTEXT := ON) ??
*copyc fst$ansi_label_kinds
?? POP ??



*DECK DECK=FSP$FIND_ACCESS_CONDITION_ENTRY EXPAND=FALSE
*DECK DECK=FSP$FLUSH_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] fsp$flush_catalog
    (    catalog_object: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=FSP$GET_ACCESS_CONDITION_ENTRY EXPAND=FALSE
*DECK DECK=FSP$GET_FILE_ATTRIBUTES EXPAND=FALSE
 PROCEDURE fsp$get_file_attributes (file: fst$file_reference;
    VAR file_cycle_attributes {input, output} : fst$file_cycle_attributes;
    VAR status: ost$status);

{ Content of proc will be code which will externalize the types of the
{ formal parameters.}
{ The system will provide gated interfaces which return the information in one
{ or more sequences.}

  PROCEND fsp$get_file_attributes;

?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$attribute_validation_errors
*copyc ame$improper_file_id
*copyc ame$ring_validation_errors
*copyc fst$file_cycle_attributes
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=FSP$GET_FILE_INFORMATION EXPAND=FALSE
 PROCEDURE fsp$get_file_information (file: fst$file_reference;
        attachment_information: ^fst$attachment_information;
        catalog_information: ^fst$catalog_information;
        cycle_attribute_sources: ^fst$cycle_attribute_sources;
        cycle_attribute_values: ^fst$cycle_attribute_values;
        resolved_file_reference: ^fst$resolved_file_reference;
        user_defined_attributes: ^SEQ ( * );
    VAR user_defined_attribute_size: fst$user_defined_attribute_size;
    VAR status: ost$status);

{ Content of proc will be code which will externalize the types of the
{ formal parameters.}
{ The system will provide gated interfaces which return the information in one
{ or more sequences.}

  PROCEND fsp$get_file_information;

?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$attribute_validation_errors
*copyc ame$improper_file_id
*copyc ame$ring_validation_errors
*copyc fst$attachment_information
*copyc fst$catalog_information
*copyc fst$cycle_attribute_sources
*copyc fst$cycle_attribute_values
*copyc fst$file_reference
*copyc fst$resolved_file_reference
*copyc fst$user_attribute_descriptor
*copyc fst$user_defined_attribute_size
*copyc ost$status
?? POP ??
*DECK DECK=FSP$GET_OPEN_ATTRIBUTES EXPAND=FALSE
 PROCEDURE fsp$get_open_attributes (file_identifier:
    amt$file_identifier;
    VAR file_cycle_attributes {input, output} : fst$file_cycle_attributes;
    VAR status: ost$status);

{ Content of proc will be code which will externalize the types of the
{ formal parameters.}
{ The system will provide gated interfaces which return the information in one
{ or more sequences.}

  PROCEND fsp$get_open_attributes;

?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$attribute_validation_errors
*copyc ame$improper_file_id
*copyc ame$ring_validation_errors
*copyc amt$file_identifier
*copyc fst$file_cycle_attributes
*copyc ost$status
?? POP ??
*DECK DECK=FSP$GET_OPEN_INFORMATION EXPAND=FALSE

  PROCEDURE fsp$get_open_information (file_identifier: amt$file_identifier;
*IF $true(osv$unix)
    VAR device_class: rmt$device_class);
*ELSE
        attachment_information: ^fst$attachment_information;
        catalog_information: ^fst$catalog_information;
        cycle_attribute_sources: ^fst$cycle_attribute_sources;
        cycle_attribute_values: ^fst$cycle_attribute_values;
        instance_information: ^fst$open_instance_information;
        resolved_file_reference: ^fst$resolved_file_reference;
        user_defined_attributes: ^SEQ ( * );
    VAR user_defined_attribute_size: fst$user_defined_attribute_size;
    VAR status: ost$status);
*IFEND

?? PUSH (LISTEXT := ON) ??
*block
*copyc bap$get_open_information
*copyc amp$set_file_instance_abnormal
*blockend
?? POP ??

    VAR
*IF $true(osv$unix)
      terminal_device: ost_c_boolean;
*ELSE
      attachment_information_seq: ^SEQ ( * ),
      catalog_information_seq: ^SEQ ( * ),
      cycle_attribute_sources_seq: ^SEQ ( * ),
      cycle_attribute_values_seq: ^SEQ ( * ),
      instance_information_seq: ^SEQ ( * ),
      resolved_file_reference_seq: ^SEQ ( * ),
      user_defined_attr_size_int: ost$non_negative_integers;
*IFEND

*IF $true(osv$unix)
    rmp_isatty (file_identifier, terminal_device);
    CASE terminal_device OF
    = 0 =
      device_class := rmc$mass_storage_device;
    ELSE
      device_class := rmc$terminal_device;
    CASEND;
*ELSE
    status.normal := TRUE;


    IF attachment_information <> NIL THEN
      attachment_information_seq := #seq (attachment_information^);
    ELSE
      attachment_information_seq := NIL;
    IFEND;

    IF catalog_information <> NIL THEN
      catalog_information_seq := #seq (catalog_information^);
    ELSE
      catalog_information_seq := NIL;
    IFEND;

    IF cycle_attribute_sources <> NIL THEN
      cycle_attribute_sources_seq := #seq (cycle_attribute_sources^);
    ELSE
      cycle_attribute_sources_seq := NIL;
    IFEND;

    IF cycle_attribute_values <> NIL THEN
      cycle_attribute_values_seq := #seq (cycle_attribute_values^);
    ELSE
      cycle_attribute_values_seq := NIL;
    IFEND;

    IF instance_information <> NIL THEN
      instance_information_seq := #seq (instance_information^);
    ELSE
      instance_information_seq := NIL;
    IFEND;

    IF resolved_file_reference <> NIL THEN
      resolved_file_reference_seq := #seq (resolved_file_reference^);
    ELSE
      resolved_file_reference_seq := NIL;
    IFEND;

    bap$get_open_information (file_identifier, attachment_information_seq,
          catalog_information_seq, cycle_attribute_sources_seq,
          cycle_attribute_values_seq, instance_information_seq,
          resolved_file_reference_seq, user_defined_attributes,
          user_defined_attr_size_int, status);
    IF (NOT status.normal) AND
      (status.condition <> fse$file_contents_truncated) THEN
      RETURN;
    IFEND;

    IF user_defined_attr_size_int <= UPPERVALUE (user_defined_attribute_size)
          THEN
      user_defined_attribute_size := user_defined_attr_size_int;
    ELSE
      amp$set_file_instance_abnormal (file_identifier,
            fse$get_file_info_internal, fsc$get_open_information_req, 'user_de'
        CAT 'fined_attribute_size exceeds maximum allowed by fsp$get_open_info'
        CAT 'rmation', status);
    IFEND;
*IFEND

  PROCEND fsp$get_open_information;

?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc amc$condition_code_limits
*copyc ame$attribute_validation_errors
*copyc ame$improper_file_id
*copyc ame$ring_validation_errors
*IFEND
*copyc amt$file_identifier
*IF $true(osv$unix)
*copyc rmt$device_class
*copyc rmp_isatty
*ELSE
*copyc fse$get_info_validation_errors
*copyc fst$attachment_information
*copyc fst$catalog_information
*copyc fst$cycle_attribute_sources
*copyc fst$cycle_attribute_values
*copyc fst$open_instance_information
*copyc fst$resolved_file_reference
*copyc fst$user_attribute_descriptor
*copyc fst$user_defined_attribute_size
*copyc osd$integer_limits
*copyc ost$status
*IFEND
?? POP ??
*DECK DECK=FSP$GET_SIGNIFICANT_PATH_STRING EXPAND=FALSE
*DECK DECK=FSP$GET_TAPE_LABEL_ATTRIBUTES EXPAND=FALSE
  PROCEDURE [XREF] fsp$get_tape_label_attributes
    (    file: fst$file_reference;
         source: fst$tape_attribute_source;
     VAR attributes {input,output} : fst$attachment_options;
     VAR returned_attributes: fst$tla_returned_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$device_class_validation
*copyc ame$tape_program_actions
*copyc fst$attachment_options
*copyc fst$file_reference
*copyc fst$tape_attribute_source
*copyc fst$tla_returned_attributes
*copyc ost$status
?? POP ??
*DECK DECK=FSP$HEADER_LABELS EXPAND=FALSE
  FUNCTION [INLINE] fsp$header_labels
    (    label_group: fst$ansi_label_kinds): boolean;

    fsp$header_labels := fsp$file_header_labels (label_group) OR
          fsp$volume_header_labels (label_group)

  FUNCEND fsp$header_labels;

?? PUSH (LISTEXT := ON) ??
*copyc fsp$file_header_labels
*copyc fsp$volume_header_labels
?? POP ??
*DECK DECK=FSP$LOCATE_TAPE_LABEL EXPAND=FALSE

  PROCEDURE [XREF] fsp$locate_tape_label
    (    label_sequence: ^SEQ ( * );
         label_identifier: fst$tape_label_identifier;
     VAR label_locator: fst$tape_label_locator);

?? PUSH (LISTEXT := ON) ??
*copyc ame$tape_program_actions
*copyc fst$ansi_eof1_label
*copyc fst$ansi_eof2_label
*copyc fst$ansi_eofn_label
*copyc fst$ansi_eov1_label
*copyc fst$ansi_eov2_label
*copyc fst$ansi_eovn_label
*copyc fst$ansi_hdr1_label
*copyc fst$ansi_hdr2_label
*copyc fst$ansi_hdrn_label
*copyc fst$ansi_uhla_label
*copyc fst$ansi_utla_label
*copyc fst$ansi_uvln_label
*copyc fst$ansi_vol1_label
*copyc fst$ansi_voln_label
*copyc fst$tape_label_identifier
*copyc fst$tape_label_locator
?? POP ??
*DECK DECK=FSP$OPEN_AND_GET_TYPE_OF_COPY EXPAND=FALSE

  PROCEDURE [XREF] fsp$open_and_get_type_of_copy
    (    input: fst$file_reference;
         output: fst$file_reference;
         input_file_attachment: ^fst$attachment_options;
         output_file_attachment: ^fst$attachment_options;
         input_attribute_validation: ^fst$file_cycle_attributes;
         output_attribute_validation: ^fst$file_cycle_attributes;
         output_creation_attributes: ^fst$file_cycle_attributes;
     VAR input_fid: amt$file_identifier;
     VAR output_fid: amt$file_identifier;
     VAR control_info: fst$copy_control_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc amt$file_identifier
*copyc fst$attachment_options
*copyc fst$copy_control_information
*copyc fst$file_cycle_attributes
*copyc ost$status
*copyc amc$condition_code_limits
*copyc ame$access_validation_errors
*copyc ame$lfn_program_actions
*copyc ame$open_validation_errors
*copyc ame$ring_validation_errors
*copyc ame$unimplemented_request
*copyc fse$copy_validation_errors
*copyc fse$open_validation_errors
?? POP ??
*DECK DECK=FSP$OPEN_FILE EXPAND=FALSE

 PROCEDURE [XREF] fsp$open_file (file: fst$file_reference;
        access_level: amt$access_level;
        file_attachment: ^fst$attachment_options;
*IF NOT $true(osv$unix)
        default_creation_attributes: ^fst$file_cycle_attributes;
        mandated_creation_attributes: ^fst$file_cycle_attributes;
        attribute_validation: ^fst$file_cycle_attributes;
        attribute_override: ^fst$file_cycle_attributes;
*IFEND
    VAR file_identifier: amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc amc$condition_code_limits
*copyc ame$label_validation_errors
*copyc ame$lfn_program_actions
*copyc ame$open_validation_errors
*copyc ame$ring_validation_errors
*ELSE
*copyc amc$ecc_range
*copyc ame$improper_access_level
*copyc ame$improper_file_attrib_key
*copyc ame$improper_file_attrib_value
*copyc ame$no_permission_for_access
*copyc ose$unix_system_error
*IFEND
*copyc amt$access_level
*copyc amt$file_identifier
*IF NOT $true(osv$unix)
*copyc amt$local_file_name
*IFEND
*copyc fse$attach_validation_errors
*copyc fse$open_validation_errors
*IF NOT $true(osv$unix)
*copyc fst$file_cycle_attributes
*IFEND
*copyc fst$file_reference
*copyc fst$attachment_options
*copyc ost$status
*copyc pfe$error_condition_codes
?? POP ??





*DECK DECK=FSP$PATH_ELEMENT EXPAND=FALSE
  FUNCTION [INLINE] fsp$path_element
    (    p_evaluated_file_reference: ^fst$evaluated_file_reference;
         element_number: fst$number_of_path_elements):
     ^fst$path_element_string;

?? PUSH (LISTEXT := ON) ??

    VAR
      i: fst$number_of_path_elements,
      path_index: fst$path_index;

    path_index := 2;
    FOR i := 1 TO element_number - 1 DO
      path_index := path_index + $INTEGER (p_evaluated_file_reference^.
            path_structure (path_index - 1)) + 1;
    FOREND;
    fsp$path_element := ^p_evaluated_file_reference^.
          path_structure (path_index, $INTEGER (p_evaluated_file_reference^.
          path_structure (path_index - 1)));

  FUNCEND fsp$path_element;

*copyc fst$evaluated_file_reference
*copyc fst$number_of_path_elements
*copyc fst$path_element_size
*copyc fst$path_element_string
*copyc fst$path_index
*copyc pfd$permanent_file_definitions
?? POP ??

*DECK DECK=FSP$RESOLVE_FILE_REFERENCE EXPAND=FALSE

  PROCEDURE [XREF] fsp$resolve_file_reference
    (    file_reference: fst$file_reference;
     VAR resolved_file_reference: fst$path;
     VAR resolved_file_reference_size: fst$path_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc fst$path
*copyc fst$path_size
*copyc ost$status
?? POP ??
*DECK DECK=FSP$RESOLVE_PATH EXPAND=FALSE

  PROCEDURE [XREF] fsp$resolve_path (
    VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fse$path_exception_conditions
*copyc fst$evaluated_file_reference
*copyc ost$status
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=FSP$SET_EVALUATED_FILE_ABNORMAL EXPAND=FALSE

  PROCEDURE [XREF] fsp$set_evaluated_file_abnormal
    (    evaluated_file_reference: fst$evaluated_file_reference;
         exception_condition: ost$status_condition;
         request_code: amt$last_operation;
         text: string ( * <= osc$max_string_size );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amd$operation_declarations
*copyc fst$evaluated_file_reference
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=FSP$SET_FILE_REFERENCE_ABNORMAL EXPAND=FALSE

  PROCEDURE [XREF] fsp$set_file_reference_abnormal
    (    file: fst$file_reference;
         exception_condition: ost$status_condition;
         request_code: amt$last_operation;
         text: string ( * <= osc$max_string_size );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amd$operation_declarations
*copyc fst$file_reference
*copyc ost$status
*copyc ost$string
?? POP ??

*DECK DECK=FSP$STRICTLY_NULL_DEVICE EXPAND=FALSE
  FUNCTION [INLINE] fsp$strictly_null_device
    (device_class: rmt$device_class;
     file_name: ost$name): boolean;

?? PUSH (LISTEXT := ON) ??

    fsp$strictly_null_device := (device_class = rmc$null_device) AND ((NOT jmp$system_job ()) OR
          ((file_name <> 'INPUT') AND (file_name <> 'OUTPUT') AND (file_name <> 'COMMAND') AND
          (file_name <> 'DISPLAY_A') AND (file_name <> 'DISPLAY_B')));

  FUNCEND fsp$strictly_null_device;

*copyc jmp$system_job
*copyc ost$name
*copyc rmt$device_class
?? POP ??
*DECK DECK=FSP$SUBSYSTEM_COPY_FILE EXPAND=FALSE

  PROCEDURE [XREF] fsp$subsystem_copy_file
    (    input: fst$file_reference;
         output: fst$file_reference;
         input_file_attachment: ^fst$attachment_options;
         output_file_attachment: ^fst$attachment_options;
         input_attribute_validation: ^fst$file_cycle_attributes;
         output_attribute_validation: ^fst$file_cycle_attributes;
         output_creation_attributes: ^fst$file_cycle_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$access_validation_errors
*copyc ame$copy_validation_errors
*copyc ame$get_program_actions
*copyc ame$lfn_program_actions
*copyc ame$open_validation_errors
*copyc ame$put_program_actions
*copyc ame$put_validation_errors
*copyc ame$ring_validation_errors
*copyc ame$unimplemented_request
*copyc fse$copy_validation_errors
*copyc fst$attachment_options
*copyc fst$file_cycle_attributes
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=FSP$TRAILER_LABELS EXPAND=FALSE
  FUNCTION [INLINE] fsp$trailer_labels
    (    label_group: fst$ansi_label_kinds): boolean;

    fsp$trailer_labels := fsp$file_trailer_labels (label_group) OR
          fsp$volume_trailer_labels (label_group)

  FUNCEND fsp$trailer_labels;

?? PUSH (LISTEXT := ON) ??
*copyc fsp$file_trailer_labels
*copyc fsp$volume_trailer_labels
?? POP ??
*DECK DECK=FSP$VALIDATE_ATTACHMENTS EXPAND=FALSE

  PROCEDURE [XREF] fsp$validate_attachments
    (    attachments: ^fst$attachment_options;
         status_reporting_procedure_ptr: fst$status_reporting_procedure;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$attachment_options
*copyc fst$status_reporting_procedure
*copyc ost$status
?? POP ??
*DECK DECK=FSP$VALIDATE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] fsp$validate_attributes
    (    attributes: ^fst$file_cycle_attributes;
         status_text: string ( * );
         status_reporting_procedure_ptr: fst$status_reporting_procedure;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_cycle_attributes
*copyc fst$status_reporting_procedure
*copyc ost$status
?? POP ??
*DECK DECK=FSP$VALIDATE_FILE_IDENTIFIER EXPAND=FALSE

  PROCEDURE [XREF] fsp$validate_file_identifier
    (    file_identifier: amt$file_identifier;
     VAR file_id_is_valid: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
?? POP ??
*DECK DECK=FSP$VALIDATE_STRING EXPAND=FALSE
*DECK DECK=FSP$VERSION_ONE_TAPE_LABEL EXPAND=FALSE
  FUNCTION [INLINE] fsp$version_one_tape_label
    (    implementation_identifier: string (13)): boolean;

    fsp$version_one_tape_label := (implementation_identifier =
          fsc$version_one_ve_identifier);

  FUNCEND fsp$version_one_tape_label;

?? PUSH (LISTEXT := ON) ??
*copyc fsc$version_one_ve_identifier
?? POP ??
*DECK DECK=FSP$VERSION_TWO_TAPE_LABEL EXPAND=FALSE
  FUNCTION [INLINE] fsp$version_two_tape_label
    (    implementation_identifier: string (13)): boolean;

    fsp$version_two_tape_label := (implementation_identifier =
          fsc$version_two_ve_identifier);

  FUNCEND fsp$version_two_tape_label;

?? PUSH (LISTEXT := ON) ??
*copyc fsc$version_two_ve_identifier
?? POP ??
*DECK DECK=FSP$VE_WROTE_ANSI_FILE EXPAND=FALSE
  FUNCTION [INLINE] fsp$ve_wrote_ansi_file
    (    implementation_identifier: string (13)): boolean;

    VAR
      ve_wrote_it: string (8);

    ve_wrote_it := fsc$version_two_ve_identifier;
    fsp$ve_wrote_ansi_file := implementation_identifier (1, 8) = ve_wrote_it;

  FUNCEND fsp$ve_wrote_ansi_file;

?? PUSH (LISTEXT := ON) ??
*copyc fsc$version_two_ve_identifier
?? POP ??
*DECK DECK=FSP$VOLUME_HEADER_LABELS EXPAND=FALSE
  FUNCTION [INLINE] fsp$volume_header_labels
    (    label_group: fst$ansi_label_kinds): boolean;

    fsp$volume_header_labels := (label_group *
          $fst$ansi_label_kinds [fsc$ansi_uvln_label_kind,
          fsc$ansi_vol1_label_kind, fsc$ansi_voln_label_kind]) <>
          $fst$ansi_label_kinds [];

  FUNCEND fsp$volume_header_labels;

?? PUSH (LISTEXT := ON) ??
*copyc fst$ansi_label_kinds
?? POP ??




*DECK DECK=FSP$VOLUME_TRAILER_LABELS EXPAND=FALSE
  FUNCTION [INLINE] fsp$volume_trailer_labels
    (    label_group: fst$ansi_label_kinds): boolean;

    fsp$volume_trailer_labels := (label_group *
          $fst$ansi_label_kinds [fsc$ansi_eov1_label_kind,
          fsc$ansi_eov2_label_kind, fsc$ansi_eovn_label_kind]) <>
          $fst$ansi_label_kinds [];

  FUNCEND fsp$volume_trailer_labels;

?? PUSH (LISTEXT := ON) ??
*copyc fst$ansi_label_kinds
?? POP ??



*DECK DECK=FST$ACCESS_CONDITION_ENTRY EXPAND=FALSE
  TYPE
    fst$access_condition_entry = record
      file_access_condition: fst$file_access_condition,
      user_defined_condition: ost$name,
      polling_interval: integer,
      status_condition: ost$status_condition_code,
      wait_message_name: ost$name,
    recend;

*copyc ame$put_program_actions
*copyc dfe$error_condition_codes
*copyc fst$file_access_condition
*copyc ioe$st_errors
*copyc mme$condition_codes
*copyc ost$name
*copyc ost$status_condition_code
*copyc pfe$error_condition_codes
*copyc ste$error_condition_codes
*DECK DECK=FST$ACCESS_MODES EXPAND=FALSE
 TYPE

    fst$access_modes = record
      case selector: fst$access_mode_choices of
      = fsc$permitted_access_modes =
        ,
      = fsc$specific_access_modes =
        value: fst$file_access_options,
      casend
    recend;

*copyc fst$access_mode_choices
*copyc fst$file_access_options



*DECK DECK=FST$ACCESS_MODE_CHOICES EXPAND=FALSE
 TYPE

    fst$access_mode_choices = (fsc$permitted_access_modes,
      fsc$specific_access_modes);
*DECK DECK=FST$ANSI_EOF1_LABEL EXPAND=FALSE

 TYPE
{
{   The ANSI EOF1 label contains the following fields:
{
{   CP         Field Name             Content
{  1 ..  3  Label Identifier          'EOF'
{     4     Label Number              '1'
{  5 .. 21  File Identifier           alpha-numeric
{ 22 .. 27  File-set Identifier       alpha-numeric
{ 28 .. 31  File Section Number       numeric
{ 32 .. 35  File Sequence Number      numeric
{ 36 .. 39  Generation Number         numeric
{ 40 .. 41  Generation Version Number numeric
{ 42 .. 47  Creation Date             ' yyddd'
{ 48 .. 53  Expiration Date           ' yyddd'
{    54     Accessibility             alpha-numeric
{ 55 .. 60  Block Count               numeric
{ 61 .. 73  System Code               alpha-numeric
{ 74 .. 80  Reserved to ANSI          '       '
{
    fst$ansi_eof1_label = record
      label_identifier: string (3),
      label_number: string (1),
      file_identifier: string (17),
      file_set_identifier: string (6),
      file_section_number: string (4),
      file_sequence_number: string (4),
      generation_number: string (4),
      generation_version_number: string (2),
      creation_date: string (6),
      expiration_date: string (6),
      accessibility: string (1),
      block_count: string (6),
      system_code: string (13),
      reserved_to_ansi: string (7),
    recend;
*DECK DECK=FST$ANSI_EOF2_LABEL EXPAND=FALSE

 TYPE
{
{   The ANSI EOF2 label contains the following fields:
{
{   CP         Field Name               Content
{  1 ..  3  Label Identifier            'EOF'
{     4     Label Number                '2'
{     5     Record Format               'F' 'D' or 'S'
{  6 .. 10  Block Length                numeric
{ 11 .. 15  Record Length               numeric
{
{ 16 .. 50  Reserved to Implementors
{ 16 .. 17  NOS/VE Block Type           'US' or 'SS'
{    18     NOS/VE Record Type          'F' 'U' or 'V'
{ 19 .. 21  NOS/VE Block Length Ext.    numeric
{           (Most Significant Digits of Block Length)
{ 22 .. 24  NOS/VE Record Length Ext.   numeric
{           (Most Significant Digits of Record Length)
{    25     NOS/VE Padding Character    alpha-numeric
{    26     NOS/VE Character Set        'A' or 'E'
{           ('A' for ASCII, 'E' for EBCDIC)
{    27     NOS/VE Character Conversion 'T' or 'F'
{           ('T' for TRUE, 'F' for FALSE)
{ 28 .. 50  Reserved for NOS/VE         '       '
{
{ 51 .. 52  Buffer Offset Length        numeric
{ 53 .. 80  Reserved to ANSI            '       '
{
    fst$ansi_eof2_label = record
      CASE boolean OF
      = TRUE =
      label_identifier: string (3),
      label_number: string (1),
      record_format: string (1),
      block_length: string (5),
      record_length: string (5),

{ Reserved to implementors:
      ve_block_type: string (2),
      ve_record_type: string (1),
      ve_block_length_ext: string (3),
      ve_record_length_ext: string (3),
      ve_padding_character: string (1),
      ve_character_set: string (1),
      ve_character_conversion: string (1),
      ve_reserved: string (23),

      buffer_offset_length: string (2),
      reserved_to_ansi: string (28),
      = FALSE =
      label_string: string (80),
      CASEND,
    recend;
*DECK DECK=FST$ANSI_EOFN_LABEL EXPAND=FALSE

 TYPE
{
{   The ANSI EOF3 thru EOF9 labels contain the following fields:
{
{   CP         Field Name             Content
{ 1 .. 3    Label Identifier          'EOF'
{   4       Label Number              '3' .. '9'
{ 5 .. 80   Reserved to Implementors  alpha-numeric
{
    fst$ansi_eofn_label = record
      label_identifier: string (3),
      label_number: string (1),
      reserved_to_implementors: string(76),
    recend;
*DECK DECK=FST$ANSI_EOV1_LABEL EXPAND=FALSE

 TYPE
{
{   The ANSI EOV1 label contains the following fields:
{
{   CP         Field Name             Content
{  1 ..  3  Label Identifier          'EOV'
{     4     Label Number              '1'
{  5 .. 21   File Identifier           alpha-numeric
{ 22 .. 27  File-set Identifier       alpha-numeric
{ 28 .. 31  File Section Number       numeric
{ 32 .. 35  File Sequence Number      numeric
{ 36 .. 39  Generation Number         numeric
{ 40 .. 41  Generation Version Number numeric
{ 42 .. 47  Creation Date             ' yyddd'
{ 48 .. 53  Expiration Date           ' yyddd'
{    54     Accessibility             alpha-numeric
{ 55 .. 60  Block Count               numeric
{ 61 .. 73  System Code               alpha-numeric
{ 74 .. 80  Reserved to ANSI          '       '
{
    fst$ansi_eov1_label = record
      label_identifier: string (3),
      label_number: string (1),
      file_identifier: string (17),
      file_set_identifier: string (6),
      file_section_number: string (4),
      file_sequence_number: string (4),
      generation_number: string (4),
      generation_version_number: string (2),
      creation_date: string (6),
      expiration_date: string (6),
      accessibility: string (1),
      block_count: string (6),
      system_code: string (13),
      reserved_to_ansi: string (7),
    recend;
*DECK DECK=FST$ANSI_EOV2_LABEL EXPAND=FALSE

 TYPE
{
{   The ANSI EOV2 label contains the following fields:
{
{   CP         Field Name               Content
{  1 ..  3  Label Identifier            'EOV'
{     4     Label Number                '2'
{     5     Record Format               'F' 'D' or 'S'
{  6 .. 10  Block Length                numeric
{ 11 .. 15  Record Length               numeric
{
{ 16 .. 50  Reserved to Implementors
{ 16 .. 17  NOS/VE Block Type           'US' or 'SS'
{    18     NOS/VE Record Type          'F' 'U' or 'V'
{ 19 .. 21  NOS/VE Block Length Ext.    numeric
{           (Most Significant Digits of Block Length)
{ 22 .. 24  NOS/VE Record Length Ext.   numeric
{           (Most Significant Digits of Record Length)
{    25     NOS/VE Padding Character    alpha-numeric
{    26     NOS/VE Character Set        'A' or 'E'
{           ('A' for ASCII, 'E' for EBCDIC)
{    27     NOS/VE Character Conversion 'T' or 'F'
{           ('T' for TRUE, 'F' for FALSE)
{ 28 .. 50  Reserved for NOS/VE         '       '
{
{ 51 .. 52  Buffer Offset Length        numeric
{ 53 .. 80  Reserved to ANSI            '       '
{
    fst$ansi_eov2_label = record
      CASE boolean OF
      = TRUE =
      label_identifier: string (3),
      label_number: string (1),
      record_format: string (1),
      block_length: string (5),
      record_length: string (5),

{ Reserved to implementors:
      ve_block_type: string (2),
      ve_record_type: string (1),
      ve_block_length_ext: string (3),
      ve_record_length_ext: string (3),
      ve_padding_character: string (1),
      ve_character_set: string (1),
      ve_character_conversion: string (1),
      ve_reserved: string (23),

      buffer_offset_length: string (2),
      reserved_to_ansi: string (28),
      = FALSE =
      label_string: string (80),
      CASEND,
    recend;
*DECK DECK=FST$ANSI_EOVN_LABEL EXPAND=FALSE

 TYPE
{
{   The ANSI EOV3 thru EOV9 labels contain the following fields:
{
{   CP         Field Name             Content
{ 1 .. 3    Label Identifier          'EOV'
{   4       Label Number              '3' .. '9'
{ 5 .. 80   Reserved to Implementors  alpha-numeric
{
    fst$ansi_eovn_label = record
      label_identifier: string (3),
      label_number: string (1),
      reserved_to_implementors: string(76),
    recend;
*DECK DECK=FST$ANSI_HDR1_LABEL EXPAND=FALSE
 TYPE
{
{   The ANSI HDR1 label contains the following fields:
{
{   CP         Field Name             Content
{ 1 .. 3    Label Identifier          'HDR'
{   4       Label Number              '1'
{ 5 .. 21   File Identifier           alpha-numeric
{ 22 .. 27  File-set Identifier       alpha-numeric
{ 28 .. 31  File Section Number       numeric
{ 32 .. 35  File Sequence Number      numeric
{ 36 .. 39  Generation Number         numeric
{ 40 .. 41  Generation Version Number numeric
{ 42 .. 47  Creation Date             ' yyddd'
{ 48 .. 53  Expiration Date           ' yyddd'
{    54     Accessibility             alpha-numeric
{ 55 .. 60  Block Count               '000000'
{ 61 .. 73  System Code               alpha-numeric
{ 74 .. 80  Reserved to ANSI          '       '
{
    fst$ansi_hdr1_label = record
      label_identifier: string (3),
      label_number: string (1),
      file_identifier: string (17),
      file_set_identifier: string (6),
      file_section_number: string (4),
      file_sequence_number: string (4),
      generation_number: string (4),
      generation_version_number: string (2),
      creation_date: string (6),
      expiration_date: string (6),
      accessibility: string (1),
      block_count: string (6),
      system_code: string (13),
      reserved_to_ansi: string (7),
    recend;
*DECK DECK=FST$ANSI_HDR2_LABEL EXPAND=FALSE

 TYPE
{
{   The ANSI HDR2 label contains the following fields:
{
{   CP         Field Name               Content
{  1 ..  3  Label Identifier            'HDR'
{     4     Label Number                '2'
{     5     Record Format               'F' 'D' or 'S'
{  6 .. 10  Block Length                numeric
{ 11 .. 15  Record Length               numeric
{
{ 16 .. 50  Reserved to Implementors
{ 16 .. 17  NOS/VE Block Type           'US' or 'SS'
{    18     NOS/VE Record Type          'F' 'U' or 'V'
{ 19 .. 21  NOS/VE Block Length Ext.    numeric
{           (Most Significant Digits of Block Length)
{ 22 .. 24  NOS/VE Record Length Ext.   numeric
{           (Most Significant Digits of Record Length)
{    25     NOS/VE Padding Character    alpha-numeric
{    26     NOS/VE Character Set        'A' or 'E'
{           ('A' for ASCII, 'E' for EBCDIC)
{    27     NOS/VE Character Conversion 'T' or 'F'
{           ('T' for TRUE, 'F' for FALSE)
{ 28 .. 50  Reserved for NOS/VE         '       '
{
{ 51 .. 52  Buffer Offset Length        numeric
{ 53 .. 80  Reserved to ANSI            '       '
{
    fst$ansi_hdr2_label = record
      CASE boolean OF
      = TRUE =
      label_identifier: string (3),
      label_number: string (1),
      record_format: string (1),
      block_length: string (5),
      record_length: string (5),

{ Reserved to implementors:
      ve_block_type: string (2),
      ve_record_type: string (1),
      ve_block_length_ext: string (3),
      ve_record_length_ext: string (3),
      ve_padding_character: string (1),
      ve_character_set: string (1),
      ve_character_conversion: string (1),
      ve_reserved: string (23),

      buffer_offset_length: string (2),
      reserved_to_ansi: string (28),
      = FALSE =
      label_string: string (80),
      CASEND,
    recend;
*DECK DECK=FST$ANSI_HDRN_LABEL EXPAND=FALSE

 TYPE
{
{   The ANSI HDR3 thru HDR9 labels contain the following fields:
{
{   CP         Field Name             Content
{ 1 .. 3    Label Identifier          'HDR'
{   4       Label Number              '3' .. '9'
{ 5 .. 80   Reserved to Implementors  alpha-numeric
{
    fst$ansi_hdrn_label = record
      label_identifier: string (3),
      label_number: string (1),
      reserved_to_implementors: string(76),
    recend;
*DECK DECK=FST$ANSI_LABEL_IDENTIFIER EXPAND=FALSE
  TYPE
    fst$ansi_label_identifier = string (3);

*copyc fsd$ansi_label_identifiers
*DECK DECK=FST$ANSI_LABEL_INFORMATION EXPAND=FALSE

 TYPE
    fst$ansi_label_information = record

      { HDR1 label information

      file_identifier: string (17) {Left-justified, blank-filled} ,
      file_set_identifier: string (6) {Left-justified, blank-filled} ,
      file_section_number: 0 .. 9999,
      file_sequence_number: 0 .. 9999,
      generation_number: 0 .. 9999,
      generation_version_number: 0 .. 99,
      creation_date: ost$ordinal_date,
      expiration_date: ost$ordinal_date,
      accessibility: string (1),
      block_count: 0 .. 999999,
      implementation_identifier: string(13) {Left-justified, blank-filled},

      { HDR2 label information

      record_format: string(1),
      block_length: 0 .. 99999,
      record_length: 0 .. 99999,
      buffer_offset_length: 0 .. 99,

    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ost$date
?? POP ??

*DECK DECK=FST$ANSI_LABEL_KIND EXPAND=FALSE
  TYPE
    fst$ansi_label_kind = (fsc$ansi_eof1_label_kind, fsc$ansi_eof2_label_kind,
          fsc$ansi_eofn_label_kind, fsc$ansi_eov1_label_kind,
          fsc$ansi_eov2_label_kind, fsc$ansi_eovn_label_kind,
          fsc$ansi_hdr1_label_kind, fsc$ansi_hdr2_label_kind,
          fsc$ansi_hdrn_label_kind, fsc$ansi_uhla_label_kind,
          fsc$ansi_utla_label_kind, fsc$ansi_uvln_label_kind,
          fsc$ansi_vol1_label_kind, fsc$ansi_voln_label_kind);
*DECK DECK=FST$ANSI_LABEL_KINDS EXPAND=FALSE

  TYPE
    fst$ansi_label_kinds = set of fst$ansi_label_kind;

*copyc fst$ansi_label_kind
*DECK DECK=FST$ANSI_LABEL_NUMBER EXPAND=FALSE
  TYPE
    fst$ansi_label_number = string (1);
*DECK DECK=FST$ANSI_UHLA_LABEL EXPAND=FALSE

 TYPE
{
{   The ANSI UHLA labels contain the following fields:
{
{   CP         Field Name             Content
{ 1 .. 3    Label Identifier          'UHL'
{   4       Label Number              alpha-numeric
{ 5 .. 80   Reserved to Applications  alpha-numeric
{
    fst$ansi_uhla_label = record
      label_identifier: string (3),
      label_number: string (1),
      reserved_to_applications: string(76),
    recend;
*DECK DECK=FST$ANSI_UTLA_LABEL EXPAND=FALSE

 TYPE
{
{   The ANSI UTLA labels contain the following fields:
{
{   CP         Field Name             Content
{ 1 .. 3    Label Identifier          'UTL'
{   4       Label Number              alpha-numeric
{ 5 .. 80   Reserved to Applications  alpha-numeric
{
    fst$ansi_utla_label = record
      label_identifier: string (3),
      label_number: string (1),
      reserved_to_applications: string(76),
    recend;
*DECK DECK=FST$ANSI_UVLN_LABEL EXPAND=FALSE

 TYPE
{
{   The ANSI UVL1 thru UVL9 labels contain the following fields:
{
{   CP         Field Name             Content
{ 1 .. 3    Label Identifier          'UVL'
{   4       Label Number              '1' .. '9'
{ 5 .. 80   Reserved to Installations alpha-numeric
{
    fst$ansi_uvln_label = record
      label_identifier: string (3),
      label_number: string (1),
      reserved_to_installations: string(76),
    recend;
*DECK DECK=FST$ANSI_VOL1_LABEL EXPAND=FALSE

 TYPE
{
{   The ANSI VOL1 label contains the following fields:
{
{   CP         Field Name             Content
{ 1 .. 3    Label Identifier          'VOL'
{   4       Label Number              '1'
{ 5 .. 10   Volume Identifier         alpha-numeric
{    11     Accessibility             alpha-numeric
{ 12 .. 24  Reserved to ANSI          '       '
{ 25 .. 37  Implementation Identifier alpha-numeric
{ 38 .. 51  Owner Identifier          alpha-numeric
{ 52 .. 79  Reserved to ANSI          '       '
{    80     Label Standard Version    numeric
{
    fst$ansi_vol1_label = record
      label_identifier: string (3),
      label_number: string (1),
      volume_identifier: string (6),
      accessibility: string (1),
      reserved_to_ansi1: string (13),
      implementation_identifier: string(13),
      owner_identifier: string (14),
      reserved_to_ansi2: string (28),
      label_standard_version: string (1),
    recend;
*DECK DECK=FST$ANSI_VOLN_LABEL EXPAND=FALSE

 TYPE
{
{   The ANSI VOL2 thru VOL9 labels contain the following fields:
{
{   CP         Field Name             Content
{ 1 .. 3    Label Identifier          'VOL'
{   4       Label Number              '2' .. '9'
{ 5 .. 80   Reserved to Implementors  alpha-numeric
{
    fst$ansi_voln_label = record
      label_identifier: string (3),
      label_number: string (1),
      reserved_to_implementors: string(76),
    recend;
*DECK DECK=FST$APPLICATION_INFORMATION EXPAND=FALSE
 TYPE
    fst$application_information = string (osc$max_name_size);

*copyc ost$name
*DECK DECK=FST$ARCHIVE_INFORMATION EXPAND=FALSE

  TYPE
    fst$archive_information = record
      archive_entry: pft$archive_array_entry,
      amd: ^pft$amd,
    recend;

*copyc pfd$archive_definitions
*copyc pfd$catalog_info
*DECK DECK=FST$ARCHIVE_INFORMATION_LIST EXPAND=FALSE

  TYPE
    fst$archive_information_list = array [1 .. * ] of fst$archive_information;

*copyc fst$archive_information
*DECK DECK=FST$ATTACHMENT_ADMINISTRATION EXPAND=FALSE
 TYPE
    fst$attachment_administration  = record
      attached_access_modes: fst$file_access_options,
      attached_share_modes: fst$file_access_options,
      attachment_hidden: boolean,
      explicit_detachment_allowed: boolean,
      scope: fst$attachment_scope,
    recend;

*copyc fst$attachment_scope
*copyc fst$file_access_options
*DECK DECK=FST$ATTACHMENT_COUNT EXPAND=FALSE
 TYPE
    fst$attachment_count = integer;
*DECK DECK=FST$ATTACHMENT_INFORMATION EXPAND=FALSE
 TYPE
    fst$attachment_information = record
      case file_attached: boolean of
      = TRUE =
        administration_information: fst$attachment_administration,
        usage_information: fst$attachment_usage,
      = FALSE =
        ,
      casend,
    recend;

*copyc fst$attachment_administration
*copyc fst$attachment_usage
*DECK DECK=FST$ATTACHMENT_OPTION EXPAND=FALSE

 TYPE
    fst$attachment_option = record

      case selector: fst$file_attachment_choices of
{
{ When an attachment option of type pmt$entry_point_reference
{ is selected, the caller of the request must provide a program variable
{ of type pmt$entry_point_reference and initialize this record to point
{ to the initialized program variable.  The value of the parameter will be
{ obtained from the address provided.
{
      = fsc$access_and_share_modes =
        access_modes: fst$access_modes,
        share_modes: fst$share_modes,
      = fsc$allowed_device_classes =
        allowed_device_classes: fst$device_classes,
      = fsc$allowed_exceptions =
        allowed_exceptions: fst$exception_conditions,
      = fsc$create_file =
        create_file: boolean,
      = fsc$delete_data =
        delete_data: boolean,
      = fsc$error_exit_procedure =
        error_exit_procedure: amt$error_exit_procedure,
      = fsc$error_exit_procedure_name =
        error_exit_procedure_name: ^pmt$entry_point_reference,
      = fsc$error_limit {Advanced Access Method files only} =
        error_limit: amt$error_limit,
      = fsc$exception_detection =
        exception_detection: fst$cycle_damage_symptoms,
      = fsc$explicit_detach_allowed {fsp$attach_file only} =
        explicit_detach_allowed: boolean,
      = fsc$file_server_options =
        file_server_options: fst$file_server_options,
      = fsc$free_behind =
        free_behind: boolean,
      = fsc$hide_attachment =
        hide_attachment: boolean,
      = fsc$label_exit_procedure =
        label_exit_procedure: amt$label_exit_procedure,
      = fsc$label_exit_procedure_name =
        label_exit_procedure_name: ^pmt$entry_point_reference,
      = fsc$message_control {Advanced Access Method files only} =
        message_control: amt$message_control,
      = fsc$null_attachment_option =
        ,
      = fsc$open_position =
        open_position: amt$open_position,
      = fsc$open_share_modes =
        open_share_modes: fst$file_access_options,
      = fsc$password =
        password: ost$name,
      = fsc$private_read =
        private_read: boolean,
      = fsc$scope {fsp$attach_file only} =
        scope: fst$attachment_scope,
      = fsc$sequential_access =
        sequential_access: boolean,
      = fsc$tape_attachment =
        tape_attachment: fst$tape_attachment,
      = fsc$tape_error_options =
        tape_error_options: amt$tape_error_options,
      = fsc$transfer_size =
        transfer_size: fst$transfer_size,
      = fsc$validation_ring =
        validation_ring: ost$ring,
      = fsc$wait_for_attachment =
        wait_for_attachment: fst$wait_for_attachment,
      casend,
    recend;

*copyc amt$error_exit_procedure
*copyc amt$error_limit
*copyc amt$label_exit_procedure
*copyc amt$message_control
*copyc amt$open_position
*copyc amt$tape_error_options
*copyc fst$access_modes
*copyc fst$attachment_scope
*copyc fst$device_classes
*copyc fst$exception_conditions
*copyc fst$file_access_options
*copyc fst$file_attachment_choices
*copyc fst$file_server_options
*copyc fst$share_modes
*copyc fst$tape_attachment
*copyc fst$transfer_size
*copyc fst$wait_for_attachment
*copyc osd$virtual_address
*copyc pmt$entry_point_reference
*copyc pmt$processor_attributes

*DECK DECK=FST$ATTACHMENT_OPTIONS EXPAND=FALSE
 TYPE
    fst$attachment_options = array [1 .. * ] of fst$attachment_option;

*copyc fst$attachment_option
*DECK DECK=FST$ATTACHMENT_OPTIONS_SOURCES EXPAND=FALSE

  TYPE
    fst$attachment_options_sources = record
      access_modes_source: amt$attribute_source,
      error_exit_name_source: amt$attribute_source,
      error_limit_source: amt$attribute_source,
      label_exit_name_source: amt$attribute_source,
      message_control_source: amt$attribute_source,
      open_position_source: amt$attribute_source,
    recend;

*copyc amd$file_attributes
*DECK DECK=FST$ATTACHMENT_SCOPE EXPAND=FALSE
 TYPE
    fst$attachment_scope = (fsc$system_scope, fsc$job_scope, fsc$proc_scope,
      fsc$utility_scope, fsc$task_scope, fsc$local_scope);
*DECK DECK=FST$ATTACHMENT_USAGE EXPAND=FALSE

  TYPE
    fst$attachment_usage = record
      ansi_hdr1_label: fst$ansi_hdr1_label,
      concurrent_open_count: fst$open_count,
      concurrent_open_access_modes: fst$file_access_options,
      current_file_address: amt$file_byte_address,
      error_exit_procedure_name: pmt$entry_point_reference,
      error_limit: amt$error_limit,
      label_exit_procedure_name: pmt$entry_point_reference,
      message_control: amt$message_control,
      open_position: amt$open_position,
      prevented_open_access_modes: fst$file_access_options,
      private_read: boolean,
      record_position: amt$file_position,
      required_open_share_modes: fst$file_access_options,
      sequential_access: boolean,
      tape_error_options: amt$tape_error_options,
      transfer_size: fst$transfer_size,
    recend;

*copyc amt$error_limit
*copyc amt$file_byte_address
*copyc amt$file_position
*copyc amt$message_control
*copyc amt$open_position
*copyc amt$tape_error_options
*copyc fst$ansi_hdr1_label
*copyc fst$file_access_options
*copyc fst$open_count
*copyc fst$transfer_size
*copyc pmt$entry_point_reference
*copyc pmt$processor_attributes
*DECK DECK=FST$ATTRIBUTE_OVERRIDE_INFO EXPAND=FALSE
 TYPE
    fst$attribute_override_info = record
      block_type: amt$block_type,
      file_organization: amt$file_organization,
      record_type: amt$record_type,
      ring_attributes: amt$ring_attributes,
    recend;

*copyc amt$block_type
*copyc amt$file_organization
*copyc amt$record_type
*copyc amt$ring_attributes
*DECK DECK=FST$BACKUP_INFORMATION EXPAND=FALSE

  TYPE
    fst$backup_information = record
      backup_system_defined_name: ost$binary_unique_name,
      date_time: ost$date_time,
      initial_vsn_of_backup_media: rmt$volume_descriptor,
      number_of_backups: integer,
    recend;

*copyc osd$unique_name
*copyc ost$date_time
*copyc rmd$volume_declarations
*DECK DECK=FST$CATALOG_DEPTH EXPAND=FALSE

  TYPE
    fst$catalog_depth = record
      case depth_specification: fst$depth_specification of
      = fsc$entire_subtree =
        ,
      = fsc$specific_depth =
        depth: fst$path_element_index,
      casend,
    recend;

*copyc fst$depth_specification
*copyc fst$path_element_index
*DECK DECK=FST$CATALOG_INFORMATION EXPAND=FALSE

  TYPE
    fst$catalog_information = record
      case file_registered_in_catalog: boolean of
      = TRUE =
        file_registration: fst$file_registration_info,
        case cycle_registered_in_catalog: boolean of
        = TRUE =
          cycle_registration: fst$cycle_registration_info,
        = FALSE =
          ,
        casend,

      = FALSE =
        ,
      casend,
    recend;

*copyc fst$cycle_registration_info
*copyc fst$file_registration_info
*DECK DECK=FST$CONTROL_MODE EXPAND=FALSE
 TYPE
    fst$control_mode = (fsc$change_delete_control, fsc$creation_control,
      fsc$display_control, fsc$permit_control);
*DECK DECK=FST$CONTROL_MODES EXPAND=FALSE
 TYPE
    fst$control_modes = set of fst$control_mode;

*copyc fst$control_mode
*DECK DECK=FST$COPY_CONTROL_INFORMATION EXPAND=FALSE

  TYPE
    fst$copy_control_information = record
      input_resolved_file_reference: fst$resolved_file_reference,
      output_resolved_file_reference: fst$resolved_file_reference,
      case type_of_copy: fst$copy_types of
      = fsc$error_move =
        ,
      = fsc$byte_move, fsc$v_to_t_record_conversion =
        input_file_size: amt$file_byte_address,
        initial_byte_address: amt$file_byte_address,
        input_and_output_are_aam_files: boolean,
      = fsc$record_move, fsc$legible_to_list_move, fsc$list_to_legible_move,
        fsc$undefined_ss_move =
        input_file_device_class: rmt$device_class,
        output_can_be_partitioned: boolean,
        working_storage_length: amt$working_storage_length,
        output_record_length: amt$max_record_length,
        output_record_length_is_fixed: boolean,
        push_overflow: boolean,
        case fst$copy_types of
        = fsc$legible_to_list_move =
          page_format: amt$page_format,
          page_length: amt$page_length,
        casend,
      = fsc$copy_keyed_file_move =
      casend,
    recend;

*copyc amt$file_byte_address
*copyc amt$working_storage_length
*copyc amt$max_record_length
*copyc amt$page_format
*copyc amt$page_length
*copyc fst$copy_types
*copyc fst$resolved_file_reference
*copyc rmt$device_class
*DECK DECK=FST$COPY_TYPES EXPAND=FALSE
 TYPE
    fst$copy_types = (fsc$error_move, fsc$byte_move, fsc$record_move,
      fsc$legible_to_list_move, fsc$list_to_legible_move,
      fsc$undefined_ss_move, fsc$copy_keyed_file_move,
      fsc$v_to_t_record_conversion);
*DECK DECK=FST$CYCLE_ATTRIBUTE_CHOICES EXPAND=FALSE
 CONST

    fsc$average_record_length {Advanced Access Method files only} = 1,
    fsc$block_type = 2,
    fsc$character_conversion = 3,
    fsc$collate_table_name {Advanced Access Method files only} = 4,
    fsc$compression_procedure_name {Advanced Access Method files only} = 5,
    fsc$data_padding {Advanced Access Method files only} = 6,
    fsc$dynamic_home_block_space {Advanced Access Method files only} = 7,
    fsc$embedded_key {Advanced Access Method files only} = 8,
    fsc$erase_at_deletion = 9,
    fsc$estimated_record_count {Advanced Access Method files only} = 10,
    fsc$file_access_procedure_name = 11,
    fsc$file_contents_and_processor = 12,
    fsc$file_label_type = 13,
    fsc$file_limit = 14,
    fsc$file_organization = 15,
    fsc$forced_write = 16,
    fsc$hashing_procedure_name {Advanced Access Method files only} = 17,
    fsc$index_levels {Advanced Access Method files only} = 18,
    fsc$index_padding {Advanced Access Method files only} = 19,
    fsc$initial_home_block_count {Advanced Access Method files only} = 20,
    fsc$internal_code = 21,
    fsc$key_length {Advanced Access Method files only} = 22,
    fsc$key_position {Advanced Access Method files only} = 23,
    fsc$key_type {Advanced Access Method files only} = 24,
    fsc$line_number = 25,
    fsc$loading_factor {Advanced Access Method files only} = 26,
    fsc$lock_expiration_time {Advanced Access Method files only} = 27,
    fsc$log_residence {Advanced Access Method files only} = 28,
    fsc$logging_options {Advanced Access Method files only} = 29,
    fsc$max_block_length = 30,
    fsc$max_record_length = 31,
    fsc$min_block_length = 32,
    fsc$min_record_length = 33,
    fsc$null_attribute = 34,
    fsc$padding_character = 35,
    fsc$page_format = 36,
    fsc$page_length = 37,
    fsc$page_width = 38,
    fsc$preset_value = 39,
    fsc$record_delimiting_character = 40,
    fsc$record_limit {Advanced Access Method files only} = 41,
    fsc$record_type = 42,
    fsc$records_per_block {Advanced Access Method files only} = 43,
    fsc$ring_attributes = 44,
    fsc$statement_identifier = 45,
    fsc$user_attribute = 46,
    fsc$vertical_print_density = 47,
    fsc$user_information = 48,
    fsc$retention = 49,
    fsc$retrieve_option = 50,
    fsc$site_backup_option = 51,
    fsc$site_archive_option = 52,
    fsc$site_release_option = 53,

    fsc$highest_current_attribute = 53;

  TYPE
    fst$cycle_attribute_choices = 1 .. fsc$max_cycle_attribute;

*copyc fsc$max_cycle_attribute
*DECK DECK=FST$CYCLE_ATTRIBUTE_SOURCES EXPAND=FALSE

  TYPE
    fst$cycle_attribute_sources = record
      average_record_length: amt$attribute_source,
      block_type: amt$attribute_source,
      character_conversion: amt$attribute_source,
      collate_table_name: amt$attribute_source,
      compression_procedure_name: amt$attribute_source,
      data_padding: amt$attribute_source,
      dynamic_home_block_space: amt$attribute_source,
      embedded_key: amt$attribute_source,
      estimated_record_count: amt$attribute_source,
      file_access_procedure_name: amt$attribute_source,
      file_contents: amt$attribute_source,
      file_processor: amt$attribute_source,
      file_label_type: amt$attribute_source,
      file_organization: amt$attribute_source,
      forced_write: amt$attribute_source,
      hashing_procedure_name: amt$attribute_source,
      index_levels: amt$attribute_source,
      index_padding: amt$attribute_source,
      initial_home_block_count: amt$attribute_source,
      internal_code: amt$attribute_source,
      key_length: amt$attribute_source,
      key_position: amt$attribute_source,
      key_type: amt$attribute_source,
      line_number: amt$attribute_source,
      loading_factor: amt$attribute_source,
      lock_expiration_time: amt$attribute_source,
      log_residence: amt$attribute_source,
      logging_options: amt$attribute_source,
      max_block_length: amt$attribute_source,
      max_record_length: amt$attribute_source,
      min_block_length: amt$attribute_source,
      min_record_length: amt$attribute_source,
      padding_character: amt$attribute_source,
      page_format: amt$attribute_source,
      page_length: amt$attribute_source,
      page_width: amt$attribute_source,
      record_delimiting_character: amt$attribute_source,
      record_limit: amt$attribute_source,
      record_type: amt$attribute_source,
      records_per_block: amt$attribute_source,
      statement_identifier: amt$attribute_source,
      user_information: amt$attribute_source,
      vertical_print_density: amt$attribute_source,
    recend;

*copyc amt$attribute_source
*DECK DECK=FST$CYCLE_ATTRIBUTE_VALUES EXPAND=FALSE

  TYPE
    fst$cycle_attribute_values = record
      average_record_length: amt$average_record_length,
      block_type: amt$block_type,
      character_conversion: boolean,
      collate_table_name: pmt$entry_point_reference,
      compression_procedure_name: pmt$entry_point_reference,
      data_padding: amt$data_padding,
      dynamic_home_block_space: amt$dynamic_home_block_space,
      embedded_key: boolean,
      estimated_record_count: amt$estimated_record_count,
      file_access_procedure_name: pmt$entry_point_reference,
      file_contents: amt$file_contents,
      file_processor: amt$file_processor,
      file_label_type: amt$file_label_type,
      file_organization: amt$file_organization,
      forced_write: amt$forced_write,
      hashing_procedure_name: pmt$entry_point_reference,
      index_levels: amt$index_levels,
      index_padding: amt$index_padding,
      initial_home_block_count: amt$initial_home_block_count,
      internal_code: amt$internal_code,
      key_length: amt$key_length,
      key_position: amt$key_position,
      key_type: amt$key_type,
      line_number: amt$line_number,
      loading_factor: amt$loading_factor,
      lock_expiration_time: amt$lock_expiration_time,
      log_residence: fst$path,
      logging_options: amt$logging_options,
      max_block_length: amt$max_block_length,
      max_record_length: amt$max_record_length,
      min_block_length: amt$min_block_length,
      min_record_length: amt$min_record_length,
      padding_character: amt$padding_character,
      page_format: amt$page_format,
      page_length: amt$page_length,
      page_width: amt$page_width,
      record_delimiting_character: char,
      record_limit: amt$record_limit,
      record_type: amt$record_type,
      records_per_block: amt$records_per_block,
      statement_identifier: amt$statement_identifier,
      user_information: amt$user_info,
      vertical_print_density: amt$vertical_print_density,
    recend;

*copyc amd$file_contents
*copyc amd$file_processor
*copyc amt$average_record_length
*copyc amt$block_type
*copyc amt$collate_table
*copyc amt$data_padding
*copyc amt$dynamic_home_block_space
*copyc amt$estimated_record_count
*copyc amt$file_label_type
*copyc amt$file_organization
*copyc amt$forced_write
*copyc amt$index_levels
*copyc amt$index_padding
*copyc amt$initial_home_block_count
*copyc amt$internal_code
*copyc amt$key_length
*copyc amt$key_position
*copyc amt$key_type
*copyc amt$line_number
*copyc amt$loading_factor
*copyc amt$lock_expiration_time
*copyc amt$logging_options
*copyc amt$max_block_length
*copyc amt$max_record_length
*copyc amt$min_block_length
*copyc amt$min_record_length
*copyc amt$padding_character
*copyc amt$page_format
*copyc amt$page_length
*copyc amt$page_width
*copyc amt$record_limit
*copyc amt$record_type
*copyc amt$records_per_block
*copyc amt$statement_identifier
*copyc amt$user_info
*copyc amt$vertical_print_density
*copyc fsc$file_contents
*copyc fsc$file_processor
*copyc fst$cycle_attribute_choices
*copyc pmt$entry_point_reference
*DECK DECK=FST$CYCLE_DAMAGE_SYMPTOM EXPAND=FALSE
  TYPE

    fst$cycle_damage_symptom = (

{ fst$cycle_damage_symptom defines values for conditions that identify a
{ possible inconsistency of data and/or catalog information and that may
{ require manual attention. Generally, these first 49 conditions must be
{ cleared mannually or explicitly acknowledged in order to attach the file;
{ however, once cleared or acknowledged, file access is not restricted or
{ blocked.
{

?? FMT (FORMAT := OFF) ??
          fsc$reserved_damage_symptom_0,       fsc$reserved_damage_symptom_1,
          fsc$reserved_damage_symptom_2,       fsc$media_image_inconsistent,
          fsc$reserved_damage_symptom_4,       fsc$respf_modification_mismatch,
          fsc$cycle_restored,                  fsc$reserved_damage_symptom_7,
          fsc$parent_catalog_restored,         fsc$reserved_damage_symptom_9,
          fsc$reserved_damage_symptom_10,      fsc$reserved_damage_symptom_11,
          fsc$reserved_damage_symptom_12,      fsc$reserved_damage_symptom_13,
          fsc$reserved_damage_symptom_14,      fsc$reserved_damage_symptom_15,
          fsc$reserved_damage_symptom_16,      fsc$reserved_damage_symptom_17,
          fsc$reserved_damage_symptom_18,      fsc$reserved_damage_symptom_19,
          fsc$reserved_damage_symptom_20,      fsc$reserved_damage_symptom_21,
          fsc$reserved_damage_symptom_22,      fsc$reserved_damage_symptom_23,
          fsc$reserved_damage_symptom_24,      fsc$reserved_damage_symptom_25,
          fsc$reserved_damage_symptom_26,      fsc$reserved_damage_symptom_27,
          fsc$reserved_damage_symptom_28,      fsc$reserved_damage_symptom_29,
          fsc$reserved_damage_symptom_30,      fsc$reserved_damage_symptom_31,
          fsc$reserved_damage_symptom_32,      fsc$reserved_damage_symptom_33,
          fsc$reserved_damage_symptom_34,      fsc$reserved_damage_symptom_35,
          fsc$reserved_damage_symptom_36,      fsc$reserved_damage_symptom_37,
          fsc$reserved_damage_symptom_38,      fsc$reserved_damage_symptom_39,
          fsc$reserved_damage_symptom_40,      fsc$reserved_damage_symptom_41,
          fsc$reserved_damage_symptom_42,      fsc$reserved_damage_symptom_43,
          fsc$reserved_damage_symptom_44,      fsc$reserved_damage_symptom_45,
          fsc$reserved_damage_symptom_46,      fsc$reserved_damage_symptom_47,
          fsc$reserved_damage_symptom_48
?? FMT (FORMAT:=ON) ??
    );

{ Old constant used by ARM$PROGRAM_INTERFACE_PROCESSOR - ARCHIVE_VE

  CONST
    fsc$archive_retrieval_problem = fsc$reserved_damage_symptom_9;
*DECK DECK=FST$CYCLE_DAMAGE_SYMPTOMS EXPAND=FALSE
  TYPE
    fst$cycle_damage_symptoms = set of fst$cycle_damage_symptom;

*copyc fst$cycle_damage_symptom
*DECK DECK=FST$CYCLE_LIMIT_ENFORCEMENT EXPAND=FALSE
 TYPE
    fst$cycle_limit_enforcement = (fsc$delete_after_file_backup,
      fsc$delete_at_cycle_creation);
*DECK DECK=FST$CYCLE_NUMBER EXPAND=FALSE

  TYPE
    fst$cycle_number = 1 .. fsc$maximum_cycle_number;

*copyc fsc$maximum_cycle_number
*DECK DECK=FST$CYCLE_REFERENCE EXPAND=FALSE

  TYPE
    fst$cycle_reference = record
      case specification: fst$cycle_specification of
      = fsc$cycle_omitted, fsc$high_cycle, fsc$low_cycle, fsc$next_cycle =
        ,
      = fsc$cycle_number =
        cycle_number: fst$cycle_number,
      casend,
    recend;

*copyc fst$cycle_number
*copyc fst$cycle_specification
*DECK DECK=FST$CYCLE_REGISTRATION_INFO EXPAND=FALSE
 TYPE
    fst$cycle_registration_info = record
      attribute_definition_complete: boolean,
      creation_date_time: ost$date_time,
      cycle_number: fst$cycle_number,
      cumulative_attachment_count: fst$attachment_count,
      current_attachment_count: fst$attachment_count,
      damage_symptoms: fst$cycle_damage_symptoms,
      erase_at_deletion: boolean,
      last_attachment_date_time: ost$date_time,
      last_modification_date_time: ost$date_time,
      last_system_backup: fst$backup_information,
      last_user_backup: fst$backup_information,
      preset_value: amt$preset_value,
      residence: fst$cycle_residence_information,
      ring_attributes: amt$ring_attributes,
      size: amt$file_byte_address,
      size_limit: amt$file_byte_address,
      system_defined_name: ost$binary_unique_name,
    recend;

*copyc amt$file_byte_address
*copyc amt$preset_value
*copyc amt$ring_attributes
*copyc fst$attachment_count
*copyc fst$backup_information
*copyc fst$cycle_damage_symptoms
*copyc fst$cycle_number
*copyc fst$cycle_residence_information
*copyc fst$file_access_options
*copyc osd$unique_name
*copyc ost$date_time
*DECK DECK=FST$CYCLE_RESIDENCE_INFORMATION EXPAND=FALSE

  TYPE

    fst$cycle_residence_information = record
      case device_class: rmt$device_class of
      = rmc$magnetic_tape_device =
        magnetic_tape: fst$magnetic_tape_information,
      = rmc$mass_storage_device =
        mass_storage: fst$mass_storage_information,
      = rmc$connected_file_device, rmc$interstate_link_device,
        rmc$local_queue_device, rmc$log_device, rmc$network_device,
          rmc$null_device, rmc$pipeline_device, rmc$rhfam_device,
          rmc$terminal_device =
        ,
      casend,
    recend;

*copyc fst$magnetic_tape_information
*copyc fst$mass_storage_information
*copyc rmt$device_class
*DECK DECK=FST$CYCLE_SPECIFICATION EXPAND=FALSE

  TYPE
    fst$cycle_specification = (fsc$cycle_omitted, fsc$high_cycle,
      fsc$low_cycle, fsc$next_cycle, fsc$cycle_number);

*DECK DECK=FST$DATE_TIME EXPAND=FALSE

  TYPE
    fst$date_time = record
      case value_specified: boolean of
      = FALSE =
        , { The current date and time will be used. }
      = TRUE =
        date_time: ost$date_time,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
?? POP ??
*DECK DECK=FST$DEPTH_SPECIFICATION EXPAND=FALSE

  TYPE
    fst$depth_specification = (fsc$entire_subtree, fsc$specific_depth);

*DECK DECK=FST$DETACHMENT_OPTION EXPAND=FALSE

 TYPE
    fst$detachment_option = record
      case selector: fst$file_detachment_choices of
      = fsc$do_unload_volume =
        unload_volume: boolean,
      = fsc$do_null_detachment_option =
        ,
      casend,
    recend;

*copyc fst$file_detachment_choices
*DECK DECK=FST$DETACHMENT_OPTIONS EXPAND=FALSE

  TYPE
    fst$detachment_options = array [1 .. * ] of fst$detachment_option;

*copyc fst$detachment_option
*DECK DECK=FST$DEVICE_ATTRIBUTE EXPAND=FALSE

  TYPE
    fst$device_attribute = record
      case selector: fst$device_attribute_choices of
      = fsc$allocation_size =
        allocation_size: rmt$allocation_size,
      = fsc$density =
        density: rmt$density,
      = fsc$device_class =
        device_class: fst$device_class,
      = fsc$estimated_file_size =
        estimated_file_size: amt$file_byte_address,
      = fsc$initial_volume =
        initial_volume: rmt$recorded_vsn,
      = fsc$mass_storage_class =
        mass_storage_class: rmt$mass_storage_class,
      = fsc$null_device_attribute =
        ,
      = fsc$removable_media_group =
        removable_media_group: ost$name,
      = fsc$requested_transfer_size =
        requested_transfer_size: fst$transfer_size,
      = fsc$shared_queue =
        shared_queue: ost$name,
      = fsc$volume_list =
        volume_list: ^rmt$volume_list,
      = fsc$volume_overflow_allowed =
        volume_overflow_allowed: boolean,
      casend,
    recend;

*copyc amt$file_byte_address
*copyc fst$device_attribute_choices
*copyc fst$device_class
*copyc fst$transfer_size
*copyc ost$name
*copyc rmt$allocation_size
*copyc rmt$density
*copyc rmt$mass_storage_class
*copyc rmt$recorded_vsn
*copyc rmt$volume_list
*DECK DECK=FST$DEVICE_ATTRIBUTES EXPAND=FALSE

  TYPE
    fst$device_attributes = array [1 .. * ] of fst$device_attribute;

*copyc fst$device_attribute
*DECK DECK=FST$DEVICE_ATTRIBUTE_CHOICES EXPAND=FALSE

  CONST
    fsc$allocation_size = 1,
    fsc$density = 2,
    fsc$device_class = 3,
    fsc$estimated_file_size = 4,
    fsc$initial_volume = 5,
    fsc$mass_storage_class = 6,
    fsc$removable_media_group = 7,
    fsc$volume_list = 8,
    fsc$requested_transfer_size = 9,
    fsc$volume_overflow_allowed = 10,
    fsc$shared_queue = 11,
    fsc$null_device_attribute = 12;

  TYPE
    fst$device_attribute_choices = 1 .. fsc$max_device_attribute;

*copyc fsc$max_device_attribute
*DECK DECK=FST$DEVICE_CLASS EXPAND=FALSE

  TYPE
    fst$device_class = (fsc$connected_file_device,
          fsc$interstate_link_device, fsc$local_queue_device,
          fsc$log_device, fsc$magnetic_tape_device,
          fsc$mass_storage_device, fsc$memory_resident_device,
          fsc$network_device, fsc$null_device, fsc$pipeline_device,
          fsc$rhfam_device, fsc$terminal_device,
          fsc$masstor_7990_device, fsc$optical_disk_device,
          fsc$reserved_device_class_14, fsc$reserved_device_class_15,
          fsc$reserved_device_class_16, fsc$reserved_device_class_17,
          fsc$reserved_device_class_18, fsc$reserved_device_class_19,
          fsc$reserved_device_class_20, fsc$reserved_device_class_21,
          fsc$reserved_device_class_22, fsc$reserved_device_class_23,
          fsc$reserved_device_class_24, fsc$reserved_device_class_25,
          fsc$reserved_device_class_26, fsc$reserved_device_class_27,
          fsc$reserved_device_class_28, fsc$reserved_device_class_29,
          fsc$reserved_device_class_30, fsc$reserved_device_class_31,
          fsc$reserved_device_class_32, fsc$reserved_device_class_33,
          fsc$reserved_device_class_34, fsc$reserved_device_class_35,
          fsc$reserved_device_class_36, fsc$reserved_device_class_37,
          fsc$reserved_device_class_38, fsc$reserved_device_class_39,
          fsc$rem_media_appl_a_device, fsc$rem_media_appl_b_device,
          fsc$rem_media_appl_c_device, fsc$rem_media_appl_d_device,
          fsc$rem_media_appl_e_device, fsc$rem_media_appl_f_device,
          fsc$rem_media_appl_g_device, fsc$rem_media_appl_h_device,
          fsc$rem_media_site_a_device, fsc$rem_media_site_b_device,
          fsc$rem_media_site_c_device, fsc$rem_media_site_d_device,
          fsc$rem_media_site_e_device, fsc$rem_media_site_f_device,
          fsc$rem_media_site_g_device, fsc$rem_media_site_h_device);
*DECK DECK=FST$DEVICE_CLASSES EXPAND=FALSE

 TYPE
    fst$device_classes = set of fst$device_class;

*copyc fst$device_class
*DECK DECK=FST$DEVICE_INFORMATION EXPAND=FALSE

  TYPE
    fst$device_information = record
      case rmt$device_class of
      = rmc$connected_file_device, rmc$interstate_link_device,
            rmc$local_queue_device, rmc$log_device =
        ,
      = rmc$magnetic_tape_device =
        magnetic_tape_device_info: fst$magnetic_tape_device_info,
      = rmc$mass_storage_device =
        mass_storage_device_info: fst$mass_storage_device_info,
      = rmc$memory_resident_device, rmc$network_device, rmc$null_device,
            rmc$pipeline_device, rmc$rhfam_device, rmc$terminal_device =
        ,
      casend,
    recend;

*copyc fst$magnetic_tape_device_info
*copyc fst$mass_storage_device_info
*copyc rmt$device_class
*DECK DECK=FST$EVALUATED_FILE_REFERENCE EXPAND=FALSE

  TYPE
    fst$evaluated_file_reference = record
      { Path_structure has the integer length of the following path element
      {   in place of the delimiter.
      path_structure: string (fsc$max_path_size),
      path_structure_size: 0 .. fsc$max_path_size,
      number_of_path_elements: fst$number_of_path_elements,
*IF NOT $true(osv$unix)
      multiple_reference_specified: boolean,
      cycle_reference: fst$cycle_reference,
      { Open_position has been moved to path_handle.open_position in
      {   path_handle_info.
      path_handle_info: fst$path_handle_info,
      case path_resolution: fst$path_resolution of
      = fsc$path_resolution_error .. fsc$cycle_path =
        ,
      = fsc$command_file_path =
        block_handle: clt$block_handle,
      casend,
*ELSE
      command_file_path: record
        case found: boolean of
        = TRUE =
          block_handle: clt$block_handle,
        = FALSE =
          ,
        casend,
      recend,
      case standard_file: boolean of
      = TRUE =
        unix_standard_file: clt$standard_file,
      = FALSE =
        ,
      casend,
*IFEND
    recend;

*copyc clt$block_handle
*copyc fsc$max_path_size
*copyc fst$cycle_reference
*copyc fst$number_of_path_elements
*IF NOT $true(osv$unix)
*copyc fst$open_position
*copyc fst$path_resolution
*copyc fst$path_handle_info
*ELSE
*copyc clt$standard_file
*IFEND
*DECK DECK=FST$EXCEPTION_CONDITIONS EXPAND=FALSE
  TYPE
    fst$exception_conditions = record
      damage_symptoms: fst$cycle_damage_symptoms,
      access_conditions: fst$file_access_conditions
    recend;

*copyc fst$cycle_damage_symptoms
*copyc fst$file_access_conditions
*DECK DECK=FST$FILE_ACCESS_CONDITION EXPAND=FALSE

  TYPE

    fst$file_access_condition = (

{ fst$file_access_condition defines values for conditions that temporarily
{ prevent access to a file.  These values do not imply loss of data or catalog
{ information.  Generally, these conditions are cleared automatically by the
{ system; waiting for the condition to be cleared is advised but not required.
{

?? FMT (FORMAT := OFF) ??
          fsc$null_file_access_condition,   fsc$reserved_access_cond_1,
          fsc$reserved_access_cond_2,       fsc$reserved_access_cond_3,
          fsc$catalog_media_missing,        fsc$reserved_access_cond_5,
          fsc$catalog_volume_unavailable,   fsc$reserved_access_cond_7,
          fsc$cycle_busy,                   fsc$reserved_access_cond_9,
          fsc$reserved_access_cond_10,      fsc$reserved_access_cond_11,
          fsc$reserved_access_cond_12,      fsc$reserved_access_cond_13,
          fsc$reserved_access_cond_14,      fsc$reserved_access_cond_15,
          fsc$data_restoration_required,    fsc$reserved_access_cond_17,
          fsc$data_retrieval_required,      fsc$reserved_access_cond_19,
          fsc$reserved_access_cond_20,      fsc$reserved_access_cond_21,
          fsc$reserved_access_cond_22,      fsc$reserved_access_cond_23,
          fsc$file_server_inactive,         fsc$reserved_access_cond_25,
          fsc$reserved_access_cond_26,      fsc$reserved_access_cond_27,
          fsc$reserved_access_cond_28,      fsc$reserved_access_cond_29,
          fsc$reserved_access_cond_30,      fsc$reserved_access_cond_31,
          fsc$media_missing,                fsc$reserved_access_cond_33,
          fsc$reserved_access_cond_34,      fsc$reserved_access_cond_35,
          fsc$reserved_access_cond_36,      fsc$reserved_access_cond_37,
          fsc$reserved_access_cond_38,      fsc$reserved_access_cond_39,
          fsc$reserved_access_cond_40,      fsc$reserved_access_cond_41,
          fsc$reserved_access_cond_42,      fsc$reserved_access_cond_43,
          fsc$space_unavailable,            fsc$reserved_access_cond_45,
          fsc$volume_unavailable,           fsc$reserved_access_cond_47,
          fsc$reserved_access_cond_48,      fsc$reserved_access_cond_49,
          fsc$reserved_access_cond_50,      fsc$reserved_access_cond_51,
          fsc$reserved_access_cond_52,      fsc$reserved_access_cond_53,
          fsc$reserved_access_cond_54,      fsc$reserved_access_cond_55
?? FMT (FORMAT:=ON) ??
    );

*DECK DECK=FST$FILE_ACCESS_CONDITIONS EXPAND=FALSE

  TYPE

    fst$file_access_conditions = set of fst$file_access_condition;

*copyc fst$file_access_condition
*DECK DECK=FST$FILE_ACCESS_OPTION EXPAND=FALSE
 TYPE
    fst$file_access_option = (fsc$read, fsc$shorten, fsc$append, fsc$modify,
      fsc$execute);
*DECK DECK=FST$FILE_ACCESS_OPTIONS EXPAND=FALSE
 TYPE
    fst$file_access_options = set of fst$file_access_option;

*copyc fst$file_access_option
*DECK DECK=FST$FILE_ATTACHMENT_CHOICES EXPAND=FALSE

  CONST
    fsc$access_and_share_modes = 1,
    fsc$allowed_exceptions = 2,
    fsc$create_file = 3,
    fsc$delete_data = 4,
    fsc$error_exit_procedure = 5,
    fsc$error_exit_procedure_name = 6,
    fsc$error_limit {Advanced Access Method files only} = 7,
    fsc$explicit_detach_allowed = 8,
    fsc$file_server_options = 9,
    fsc$hide_attachment = 10,
    fsc$label_exit_procedure = 11,
    fsc$label_exit_procedure_name = 12,
    fsc$message_control {Advanced Access Method files only} = 13,
    fsc$null_attachment_option = 14,
    fsc$open_position = 15,
    fsc$open_share_modes = 16,
    fsc$password = 17,
    fsc$private_read = 18,
    fsc$scope = 19,
    fsc$sequential_access = 20,
    fsc$tape_attachment = 21,
    fsc$tape_error_options = 22,
    fsc$transfer_size = 23,
    fsc$validation_ring = 24,
    fsc$wait_for_attachment = 25,
    fsc$free_behind = 26,
    fsc$exception_detection = 27,
    fsc$allowed_device_classes = 28;

  TYPE
    fst$file_attachment_choices = 1 .. fsc$max_attach_choice;

*copyc fsc$max_attach_choice
*DECK DECK=FST$FILE_ATTRIBUTE EXPAND=FALSE

  TYPE
    fst$file_attribute = record
      case selector: fst$file_attribute_choices of
      = fsc$attachment_logging =
        attachment_logging: boolean,
      = fsc$file_password =
        file_password: ost$name,
      = fsc$null_file_attribute =
        ,
      casend,
    recend;

*copyc fst$file_attribute_choices
*copyc ost$name
*DECK DECK=FST$FILE_ATTRIBUTES EXPAND=FALSE

  TYPE
    fst$file_attributes = array [1 .. * ] of fst$file_attribute;

*copyc fst$file_attribute
*DECK DECK=FST$FILE_ATTRIBUTE_CHOICES EXPAND=FALSE

  CONST
    fsc$attachment_logging = 1,
    fsc$file_password = 2,
    fsc$null_file_attribute = 3;

  TYPE
    fst$file_attribute_choices = 1 .. fsc$max_file_attribute;

*copyc fsc$max_file_attribute
*DECK DECK=FST$FILE_CHANGE EXPAND=FALSE

  TYPE
    fst$file_change = record
      case selector: fst$file_change_choices of
      = fsc$charge_change =
        ,
      = fsc$cycle_number_change =
        cycle_number: pft$cycle_number,
      = fsc$delete_damage_change =
        delete_damage_condition: fst$cycle_damage_symptoms,
      = fsc$log_change =
        log: pft$log,
      = fsc$null_file_change =
        ,
      = fsc$password_change =
        password: pft$password,
      = fsc$pf_name_change =
        pfn: pft$name,
      = fsc$retention_change =
        retention: fst$retention,
      = fsc$retrieve_option_change =
        retrieve_option: pft$retrieve_option,
      = fsc$shared_queue_change =
        shared_queue: ost$name,
      = fsc$site_archive_option_change =
        site_archive_option: pft$site_archive_option,
      = fsc$site_backup_option_change =
        site_backup_option: pft$site_backup_option,
      = fsc$site_release_option_change =
        site_release_option: pft$site_release_option,
      casend,
    recend;

*copyc fst$cycle_damage_symptoms
*copyc fst$file_change_choices
*copyc fst$retention
*copyc ost$name
*copyc pfd$permanent_file_definitions
*copyc pft$retrieve_option
*copyc pft$site_archive_option
*copyc pft$site_backup_option
*copyc pft$site_release_option
*DECK DECK=FST$FILE_CHANGES EXPAND=FALSE

  TYPE
    fst$file_changes = array [1 .. * ] of fst$file_change;

*copyc fst$file_change
*DECK DECK=FST$FILE_CHANGE_CHOICES EXPAND=FALSE

  CONST
    fsc$charge_change = 1,
    fsc$cycle_number_change = 2,
    fsc$delete_damage_change = 3,
    fsc$log_change = 4,
    fsc$null_file_change = 5,
    fsc$password_change = 6,
    fsc$pf_name_change = 7,
    fsc$retention_change =  8,
    fsc$retrieve_option_change = 9,
    fsc$shared_queue_change = 10,
    fsc$site_archive_option_change = 11,
    fsc$site_backup_option_change = 12,
    fsc$site_release_option_change = 13;

  TYPE
    fst$file_change_choices = 1 .. fsc$max_file_change;

*copyc fsc$max_file_change
*DECK DECK=FST$FILE_CYCLE_ATTRIBUTE EXPAND=FALSE
 TYPE
    fst$file_cycle_attribute = record
{
{ The caller of the interfaces which use this record must initialize
{ all the relevant fields of this record prior to making the request.
{
{ When a file_attribute of type pmt$entry_point_reference or fst$path
{ is selected, the caller of the request must provide a program variable
{ of the necessary type and initialize this record to point
{ to the initialized program variable.  The value of the attribute will be
{ obtained from or stored into the address provided, depending upon the
{ program request used.  A NIL pointer will be ignored.
{
{ Several of the attributes have components which are defined by the type
{ pmt$entry_point_reference.  When osc$null_name is specified for the
{ entry_point field of pmt$entry_point_reference in the context of attribute
{ definition, its presence implies that no name has been specified and that
{ no processing of the corresponding attribute will occur.  When osc$null_name
{ is specified for the entry_point field of pmt$entry_point_reference in the
{ context of attribute validation, its presence implies that no non-null value
{ of the attribute is permitted.  Similarly, a null string ('') will have the
{ same effect for the object_library field of pmt$entry_point_reference as
{ osc$null_name does for the entry_point field.

      case selector: fst$cycle_attribute_choices of

      = fsc$average_record_length {Advanced Access Method files only} =
        average_record_length: amt$average_record_length,
      = fsc$block_type =
        block_type: amt$block_type,
      = fsc$character_conversion =
        character_conversion: boolean,
      = fsc$collate_table_name {Advanced Access Method files only} =
        collate_table_name: ^pmt$entry_point_reference,
      = fsc$compression_procedure_name {Advanced Access Method files only} =
        compression_procedure_name: ^amt$compression_procedure_name,
      = fsc$data_padding {Advanced Access Method files only} =
        data_padding: amt$data_padding,
      = fsc$dynamic_home_block_space {Advanced Access Method files only} =
        dynamic_home_block_space: amt$dynamic_home_block_space,
      = fsc$embedded_key {Advanced Access Method files only} =
        embedded_key: boolean,
      = fsc$erase_at_deletion =
        erase_at_deletion: boolean,
      = fsc$estimated_record_count {Advanced Access Method files only} =
        estimated_record_count: amt$estimated_record_count,
      = fsc$file_access_procedure_name =
        file_access_procedure_name: ^pmt$entry_point_reference,
      = fsc$file_contents_and_processor =
        { The file_contents and file_processor specifications have been
        { grouped to facilitate attribute validation which may involve
        { allowing only certain pairs of content and processor.  The
        { value osc$null_name may be used in either the attribute definition
        { or validation context to indicate a "don't care" state.

        file_contents: amt$file_contents,
        file_processor: amt$file_processor,
      = fsc$file_label_type =
        file_label_type: amt$file_label_type,
      = fsc$file_limit =
        file_limit: amt$file_limit,
      = fsc$file_organization =
        file_organization: amt$file_organization,
      = fsc$forced_write =
        forced_write: amt$forced_write,
      = fsc$hashing_procedure_name {Advanced Access Method files only} =
        hashing_procedure_name: ^amt$hashing_procedure_name,
      = fsc$index_levels {Advanced Access Method files only} =
        index_levels: amt$index_levels,
      = fsc$index_padding {Advanced Access Method files only} =
        index_padding: amt$index_padding,
      = fsc$initial_home_block_count {Advanced Access Method files only} =
        initial_home_block_count: amt$initial_home_block_count,
      = fsc$internal_code =
        internal_code: amt$internal_code,
      = fsc$key_length {Advanced Access Method files only} =
        key_length: amt$key_length,
      = fsc$key_position {Advanced Access Method files only} =
        key_position: amt$key_position,
      = fsc$key_type {Advanced Access Method files only} =
        key_type: amt$key_type,
      = fsc$line_number =
        line_number: amt$line_number,
      = fsc$loading_factor {Advanced Access Method files only} =
        loading_factor: amt$loading_factor,
      = fsc$lock_expiration_time {Advanced Access Method files only} =
        lock_expiration_time: amt$lock_expiration_time,
      = fsc$log_residence {Advanced Access Method files only} =
        log_residence: ^amt$log_residence,
      = fsc$logging_options {Advanced Access Method files only} =
        logging_options: amt$logging_options,
      = fsc$max_block_length =
        max_block_length: amt$max_block_length,
      = fsc$max_record_length =
        max_record_length: amt$max_record_length,
      = fsc$min_block_length =
        min_block_length: amt$min_block_length,
      = fsc$min_record_length =
        min_record_length: amt$min_record_length,
      = fsc$null_attribute =
        ,
      = fsc$padding_character =
        padding_character: amt$padding_character,
      = fsc$page_format =
        page_format: amt$page_format,
      = fsc$page_length =
        page_length: amt$page_length,
      = fsc$page_width =
        page_width: amt$page_width,
      = fsc$preset_value =
        preset_value: amt$preset_value,
      = fsc$record_delimiting_character =
        record_delimiting_character: char,
      = fsc$record_limit {Advanced Access Method files only} =
        record_limit: amt$record_limit,
      = fsc$record_type =
        record_type: amt$record_type,
      = fsc$records_per_block {Advanced Access Method files only} =
        records_per_block: amt$records_per_block,
      = fsc$ring_attributes =
        ring_attributes: amt$ring_attributes,
      = fsc$statement_identifier =
        statement_identifier: amt$statement_identifier,
      = fsc$user_attribute =
        user_attribute: fst$user_defined_attribute,
      = fsc$user_information =
        user_information: amt$user_info,
      = fsc$vertical_print_density =
        vertical_print_density: amt$vertical_print_density,
      = fsc$retention =
        retention: fst$retention,
      = fsc$retrieve_option =
        retrieve_option: pft$retrieve_option,
      = fsc$site_backup_option =
        site_backup_option: pft$site_backup_option,
      = fsc$site_archive_option =
        site_archive_option: pft$site_archive_option,
      = fsc$site_release_option =
        site_release_option: pft$site_release_option,
      casend,
    recend;

*copyc amd$file_contents
*copyc amd$file_processor
*copyc amt$average_record_length
*copyc amt$block_type
*copyc amt$collate_table
*copyc amt$compression_procedure_name
*copyc amt$data_padding
*copyc amt$dynamic_home_block_space
*copyc amt$estimated_record_count
*copyc amt$file_label_type
*copyc amt$file_limit
*copyc amt$file_organization
*copyc amt$forced_write
*copyc amt$hashing_procedure_name
*copyc amt$index_levels
*copyc amt$index_padding
*copyc amt$initial_home_block_count
*copyc amt$internal_code
*copyc amt$key_length
*copyc amt$key_position
*copyc amt$key_type
*copyc amt$line_number
*copyc amt$loading_factor
*copyc amt$lock_expiration_time
*copyc amt$log_residence
*copyc amt$logging_options
*copyc amt$max_block_length
*copyc amt$max_record_length
*copyc amt$min_block_length
*copyc amt$min_record_length
*copyc amt$padding_character
*copyc amt$page_format
*copyc amt$page_length
*copyc amt$page_width
*copyc amt$preset_value
*copyc amt$record_limit
*copyc amt$record_type
*copyc amt$records_per_block
*copyc amt$ring_attributes
*copyc amt$statement_identifier
*copyc amt$user_info
*copyc amt$vertical_print_density
*copyc fsc$file_contents
*copyc fsc$file_processor
*copyc fst$cycle_attribute_choices
*copyc fst$retention
*copyc fst$user_defined_attribute
*copyc pft$retrieve_option
*copyc pft$site_archive_option
*copyc pft$site_backup_option
*copyc pft$site_release_option
*copyc pmt$entry_point_reference
*DECK DECK=FST$FILE_CYCLE_ATTRIBUTES EXPAND=FALSE
  TYPE
    fst$file_cycle_attributes = array [1 .. * ] of fst$file_cycle_attribute;

*copyc fst$file_cycle_attribute
*DECK DECK=FST$FILE_DETACHMENT_CHOICES EXPAND=FALSE

  CONST
    fsc$do_null_detachment_option = 1,
    fsc$do_unload_volume = 2;

  TYPE
    fst$file_detachment_choices = 1 .. fsc$max_detach_choice;

*copyc fsc$max_detach_choice
*DECK DECK=FST$FILE_REFERENCE EXPAND=FALSE

  TYPE
    fst$file_reference = string ( * <= fsc$max_path_size);

*copyc fsc$max_path_size
*DECK DECK=FST$FILE_REGISTRATION_INFO EXPAND=FALSE
 TYPE
    fst$file_registration_info = record
      account: avt$account_name,
      application_information: fst$application_information,
      concurrent_cycle_limit: fst$cycle_number,
      cycle_limit_enforcement: fst$cycle_limit_enforcement,
      expiration_date: ost$date_time,
      file_hidden: boolean,
      highest_cycle_number: fst$cycle_number,
      library_privilege: fst$library_privilege,
      log_file_access: boolean,
      lowest_cycle_number: fst$cycle_number,
      number_of_cycles: fst$cycle_number,
      password_expiration: ost$date_time,
      permanent_file: boolean,
      permitted_access_modes: fst$file_access_options,
      permitted_control_modes: fst$control_modes,
      project: avt$project_name,
      propagate_highest_cycle: boolean,
      require_explicit_deletion: boolean,
      required_share_modes: fst$file_access_options,
      system_defined_name: ost$binary_unique_name,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc fst$application_information
*copyc fst$control_modes
*copyc fst$cycle_limit_enforcement
*copyc fst$cycle_number
*copyc fst$file_access_options
*copyc fst$library_privilege
*copyc fst$resolved_file_reference
*copyc osd$unique_name
*copyc ost$date_time
*copyc ost$name
*DECK DECK=FST$FILE_SERVER_OPTIONS EXPAND=FALSE
 TYPE
    fst$file_server_options = record
      allow_other_mainframe_writer: boolean,
      reserved_for_future_use: string (16) {' '}
    recend;
*DECK DECK=FST$GOI_CATALOG_INFORMATION EXPAND=FALSE

  TYPE
    fst$goi_catalog_information = record
      account: avt$account_name,
      {
      { The following field contains the date & time the catalog was created or
      { restored, whichever occurred more recently. The millisecond subfield is
      { invalid.
      {
      creation_date_time: ost$date_time,
      project: avt$project_name,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc ost$date_time
*DECK DECK=FST$GOI_CYCLE_INFORMATION EXPAND=FALSE

  TYPE
    fst$goi_cycle_information = record
      creation_date_time: ost$date_time,
      damage_symptoms: fst$cycle_damage_symptoms,
      data_modification_date_time: ost$date_time,
      expiration_date_time: ost$date_time,
      last_access_date_time: ost$date_time,
      last_modification_date_time: ost$date_time,
      lifetime_attachment_count: ost$non_negative_integers,
      mainframe_usage_concurrency: fst$mainframe_usage_concurrency,
      mainframe_write_concurrency: fst$mainframe_write_concurrency,
      outstanding_access_modes: pft$usage_selections,
      prevented_access_modes: pft$usage_selections,
      retrieve_option: pft$retrieve_option,
      site_backup_option: pft$site_backup_option,
      site_archive_option: pft$site_archive_option,
      site_release_option: pft$site_release_option,
    recend;

*copyc fst$cycle_damage_symptoms
*copyc fst$mainframe_usage_concurrency
*copyc fst$mainframe_write_concurrency
*copyc osd$integer_limits
*copyc ost$date_time
*copyc pfd$permanent_file_attributes
*copyc pft$site_backup_option
*copyc pft$site_archive_option
*copyc pft$site_release_option
*copyc pft$retrieve_option
*DECK DECK=FST$GOI_FILE_INFORMATION EXPAND=FALSE

  TYPE
    fst$goi_file_information = record
      account: avt$account_name,
      logging_selection: ^pft$log,
      project: avt$project_name,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc pfd$permanent_file_definitions
*DECK DECK=FST$GOI_INFORMATION_REQUEST EXPAND=FALSE

  TYPE
    fst$goi_information_request = record
      catalog_depth: fst$catalog_depth,
      object_information_requests: fst$goi_object_info_requests,
    recend;

*copyc fst$catalog_depth
*copyc fst$goi_object_info_requests
*DECK DECK=FST$GOI_OBJECT EXPAND=FALSE

  TYPE
    fst$goi_object = record
      case object_type: fst$goi_object_type of
      = fsc$goi_catalog_object =
        catalog_name: pft$name,
        catalog_global_file_name: ost$binary_unique_name,
        applicable_catalog_permit: ^pft$permit_array_entry,
        catalog_device_information: ^fst$device_information,
        catalog_information: ^fst$goi_catalog_information,
        catalog_permits: ^pft$permit_array,
        catalog_size: ^amt$file_byte_address,
        subcatalog_and_file_object_list: ^fst$goi_object_list,
      = fsc$goi_file_object =
        file_name: pft$name,
        applicable_file_permit: ^pft$permit_array_entry,
        file_information: ^fst$goi_file_information,
        file_log: ^pft$log_array,
        file_permits: ^pft$permit_array,
        password: pft$password,
        cycle_object_list: ^fst$goi_object_list,
      = fsc$goi_cycle_object =
        cycle_number: fst$cycle_number,
        cycle_global_file_name: ost$binary_unique_name,
        cycle_device_class: rmt$device_class,
        archive_information_list: ^fst$archive_information_list,
        cycle_device_information: ^fst$device_information,
        cycle_information: ^fst$goi_cycle_information,
        cycle_size: ^amt$file_byte_address,
        validation_error: boolean,
        file_label: ^SEQ ( * ),
        job_environment_information: ^fst$job_environment_information,
      casend,
    recend;

*copyc amt$file_byte_address
*copyc fst$archive_information_list
*copyc fst$cycle_number
*copyc fst$device_information
*copyc fst$goi_catalog_information
*copyc fst$goi_cycle_information
*copyc fst$goi_file_information
*copyc fst$goi_object_list
*copyc fst$goi_object_type
*copyc fst$job_environment_information
*copyc ost$binary_unique_name
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc rmt$device_class
*DECK DECK=FST$GOI_OBJECT_INFORMATION EXPAND=FALSE

  TYPE
    fst$goi_object_information = record
      set_name: ost$name,
      resolved_path: ^fst$file_reference,
      object: ^fst$goi_object,
    recend;

*copyc fst$file_reference
*copyc fst$goi_object
*copyc ost$name
*DECK DECK=FST$GOI_OBJECT_INFO_REQUEST EXPAND=FALSE

  TYPE
    fst$goi_object_info_request = (fsc$goi_object_info_request_0,
          fsc$goi_object_info_request_1, fsc$goi_object_info_request_2,
          fsc$goi_object_info_request_3, fsc$goi_object_info_request_4,
          fsc$goi_object_info_request_5, fsc$goi_object_info_request_6,
          fsc$goi_object_info_request_7, fsc$goi_object_info_request_8,
          fsc$goi_object_info_request_9, fsc$goi_object_info_request_10,
          fsc$goi_object_info_request_11, fsc$goi_object_info_request_12,
          fsc$goi_object_info_request_13, fsc$goi_object_info_request_14,
          fsc$goi_object_info_request_15, fsc$goi_object_info_request_16,
          fsc$goi_object_info_request_17, fsc$goi_object_info_request_18,
          fsc$goi_object_info_request_19, fsc$goi_object_info_request_20,
          fsc$goi_object_info_request_21, fsc$goi_object_info_request_22,
          fsc$goi_object_info_request_23, fsc$goi_object_info_request_24,
          fsc$goi_object_info_request_25, fsc$goi_object_info_request_26,
          fsc$goi_object_info_request_27, fsc$goi_object_info_request_28,
          fsc$goi_object_info_request_29, fsc$goi_object_info_request_30,
          fsc$goi_object_info_request_31);

  CONST
    fsc$goi_set_name                = fsc$goi_object_info_request_0,

    { If a catalog depth greater than one is specified, then selection of
    { fsc$goi_catalog_identity also implies, for all but the first depth, the
    { selection of fsc$goi_catalog_object_list for the parent catalog of each
    { catalog encountered.

    fsc$goi_catalog_identity        = fsc$goi_object_info_request_2,

    { Selection of any of the identifiers in the following three groups also
    { implies the selection of fsc$goi_catalog_identity.

    fsc$goi_applicable_cat_permit   = fsc$goi_object_info_request_3,
    fsc$goi_catalog_device_info     = fsc$goi_object_info_request_4,
    fsc$goi_catalog_info            = fsc$goi_object_info_request_5,
    fsc$goi_catalog_permits         = fsc$goi_object_info_request_6,
    fsc$goi_catalog_size            = fsc$goi_object_info_request_7,

    { Selection of fsc$goi_catalog_object_list also implies the selection of
    { fsc$goi_catalog_identity for each of the catalogs in the list.

    fsc$goi_catalog_object_list     = fsc$goi_object_info_request_10,

    { Selection of fsc$goi_file_object_list also implies the selection of
    { fsc$goi_file_identity for each of the files in the list.

    fsc$goi_file_object_list        = fsc$goi_object_info_request_11,

    { If a catalog depth greater than one is specified, then selection
    { of fsc$goi_file_identity also implies the selection of
    { fsc$goi_file_object_list for the parent catalog of each file encountered.

    fsc$goi_file_identity           = fsc$goi_object_info_request_12,

    { Selection of any of the identifiers in the following two groups also
    { implies the selection of fsc$goi_file_identity.

    fsc$goi_applicable_file_permit  = fsc$goi_object_info_request_13,
    fsc$goi_file_info               = fsc$goi_object_info_request_14,
    fsc$goi_file_log                = fsc$goi_object_info_request_15,
    fsc$goi_file_permits            = fsc$goi_object_info_request_16,

    { If fsc$goi_cycle_object_list is explicitly selected, then it also
    { implies the selection of fsg$goi_file_object_list and information
    { will be returned for every cycle of each file encountered.  If
    { fsc$goi_cycle_object_list is implicitly selected, then it also implies
    { the selection of fsg$goi_file_identity and information will only be
    { returned for the specified cycle or, if no cycle is specified, for the
    { highest cycle of each file encountered.  In either case, selection
    { of fsc$goi_cycle_object_list also implies the selection of
    { fsc$goi_cycle_identity for each of the cycles in the list.

    fsc$goi_cycle_object_list       = fsc$goi_object_info_request_20,

    { Selection of fsc$goi_cycle_identity also implies the selection of
    { fsc$goi_cycle_object_list for the parent file of each cycle encountered.

    fsc$goi_cycle_identity          = fsc$goi_object_info_request_21,

    { Selection of any of the identifiers in the following group also implies
    { the selection of fsc$goi_cycle_identity.

    fsc$goi_archive_info            = fsc$goi_object_info_request_22,
    fsc$goi_cycle_device_info       = fsc$goi_object_info_request_23,
    fsc$goi_cycle_info              = fsc$goi_object_info_request_24,
    fsc$goi_cycle_size              = fsc$goi_object_info_request_25,
    fsc$goi_file_label              = fsc$goi_object_info_request_26,
    fsc$goi_job_environment_info    = fsc$goi_object_info_request_27;
*DECK DECK=FST$GOI_OBJECT_INFO_REQUESTS EXPAND=FALSE

  TYPE
    fst$goi_object_info_requests = set of fst$goi_object_info_request;

*copyc fst$goi_object_info_request
*DECK DECK=FST$GOI_OBJECT_LIST EXPAND=FALSE

  TYPE
    fst$goi_object_list = array [1 .. * ] of fst$goi_object;

*copyc fst$goi_object
*DECK DECK=FST$GOI_OBJECT_TYPE EXPAND=FALSE

  TYPE
    fst$goi_object_type = (fsc$goi_catalog_object, fsc$goi_file_object,
          fsc$goi_cycle_object);

*DECK DECK=FST$GOI_VALIDATION_CRITERIA EXPAND=FALSE

  TYPE
    fst$goi_validation_criteria =
          array [1 .. * ] of fst$goi_validation_criterion;

*copyc fst$goi_validation_criterion
*DECK DECK=FST$GOI_VALIDATION_CRITERION EXPAND=FALSE

  TYPE
    fst$goi_validation_criterion = record
      case validation_selection: {input} fst$goi_validation_selection of
      = fsc$goi_password =
        password: {input} pft$name,
      = fsc$goi_validation_ring =
        validation_ring: {input} ost$valid_ring,
      = fsc$goi_subject_permit =
        subject_permit: {input, output} pft$permit_array_entry,
      casend,
    recend;

*copyc fst$goi_validation_selection
*copyc osd$virtual_address
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*DECK DECK=FST$GOI_VALIDATION_SELECTION EXPAND=FALSE

  TYPE
    fst$goi_validation_selection = (fsc$goi_password, fsc$goi_validation_ring,
          fsc$goi_subject_permit);

*DECK DECK=FST$JOB_ENVIRONMENT_INFORMATION EXPAND=FALSE

  TYPE
    fst$job_environment_information = record
      attached_access_modes: fst$file_access_options,
      attached_share_modes: fst$file_access_options,
      concurrent_open_count: ost$non_negative_integers,
      connected_files: ^fst$target_file_list,
      cycle_attached: boolean,
      error_exit_procedure_name: pmt$program_name,
      error_limit: amt$error_limit,
      job_file_address: amt$file_byte_address,
      job_file_position: amt$file_position,
      job_write_concurrency: boolean,
      label_exit_procedure_name: pmt$program_name,
      mass_storage_free_behind: boolean,
      mass_storage_sequential_access: boolean,
      message_control: amt$message_control,
      open_position: amt$open_position,
      prevented_open_access_modes: fst$file_access_options,
      private_read: fst$private_read,
      setfa_access_modes: fst$file_access_options,
      specified_attachment_options: fst$specified_attach_options,
      transfer_size: fst$transfer_size,
      volume_list: ^rmt$volume_list,
      volume_number: amt$volume_number,
      volume_overflow_allowed: boolean,
      attachment_options_sources: fst$attachment_options_sources,
    recend;

*copyc amt$error_limit
*copyc amt$file_byte_address
*copyc amt$file_position
*copyc amt$message_control
*copyc amt$open_position
*copyc amt$volume_number
*copyc fst$attachment_options_sources
*copyc fst$file_access_options
*copyc fst$path
*copyc fst$private_read
*copyc fst$specified_attach_options
*copyc fst$target_file_list
*copyc fst$transfer_size
*copyc osd$integer_limits
*copyc pmt$program_name
*copyc rmt$volume_list
*DECK DECK=FST$LIBRARY_PRIVILEGE EXPAND=FALSE
 CONST
?? FMT (FORMAT := OFF) ??
    fsc$lp_application              = 'APPLICATION                    ',
    fsc$lp_object                   = 'OBJECT                         ';
?? fmt(format:=on )??

    TYPE
      fst$library_privilege = ost$name;

*copyc ost$name
*DECK DECK=FST$MAGNETIC_TAPE_DEVICE_INFO EXPAND=FALSE

  TYPE
    fst$magnetic_tape_device_info = record
      density: rmt$density,
      removable_media_group: ost$name,
      volume_list: ^rmt$volume_list,
      volume_overflow_allowed: boolean,
    recend;

*copyc ost$name
*copyc rmt$density
*copyc rmt$volume_list
*DECK DECK=FST$MAGNETIC_TAPE_INFORMATION EXPAND=FALSE
 TYPE
    fst$magnetic_tape_information = record
      class: rmt$tape_class,
      density: rmt$density,
      initial_vsn: rmt$volume_descriptor,
      number_of_volumes: amt$volume_number,
      volume_set_labelled: boolean,
      volume_set_overflow_allowed: boolean,
      write_ring: rmt$write_ring,
    recend;

*copyc amt$volume_number
*copyc rmt$density
*copyc rmt$tape_class
*copyc rmt$volume_descriptor
*copyc rmt$write_ring
*DECK DECK=FST$MAINFRAME_USAGE_CONCURRENCY EXPAND=FALSE

  TYPE
    fst$mainframe_usage_concurrency = set of fst$mf_usage_concurrency_scope;

*copyc fst$mf_usage_concurrency_scope
*DECK DECK=FST$MAINFRAME_WRITE_CONCURRENCY EXPAND=FALSE

  TYPE
    fst$mainframe_write_concurrency = (fsc$not_attached_for_write,
          fsc$shared_memory, fsc$shared_mass_storage);

*DECK DECK=FST$MASS_STORAGE_DEVICE_INFO EXPAND=FALSE
{ The OBJECT_CONDITION field may be set to one of the following conditions:

{   - fsc$null_file_access_condition:  Indicates that there is no exception
{     condition in effect for the object.

{   - fsc$data_retrieval_required:  Indicates that the cycle is in a
{     PFE$DATA_RETRIEVAL_REQUIRED condition because the file was released
{     from mass storage.

{   - fsc$data_restoration_required: Indicates that the cycle is in an
{     PFE$UNDEFINED_DATA condition.  This is usually the result of the
{     restoration of catalogs without subsequent restoration of the data.

{   - fsc$catalog_media_missing, fsc$catalog_volume_unavailable:  Indicates
{     that access to a catalog object is blocked by a missing volume or a
{     failed volume, respectively.  Refer to the discussion below about the
{     VOLUME_CONDITION_LIST.

{   - fsc$media_missing, fsc$volume_unavailable:  Indicates that access to a
{     cycle object is blocked by a missing volume or a failed volume,
{     respectively.  Refer to the discussion below about the
{     VOLUME_CONDITION_LIST.

{ The VOLUME_CONDITION_LIST and the related OBJECT_CONDITION field are
{ initialized as follows:

{   - If any of the volumes are not in the active configuration (i.e.  were
{     not activated at the last deadstart or ACTIVATE_SET), the
{     OBJECT_CONDITION field is set to FSC$MEDIA_MISSING for a cycle object
{     and FSC$CATALOG_MEDIA_MISSING for a catalog object.

{   - If none of the volumes are inactive but at least one active volume has
{     failed or is not accessible, the OBJECT_CONDITION field is set to
{     FSC$VOLUME_UNAVAILABLE for a cycle object and
{     FSC$CATALOG_VOUME_UNAVAILABLE for a catalog object.

{   - Each volume in the VOLUME_LIST below has a corresponding entry in the
{     VOLUME_CONDITION_LIST array.  An array entry is set to one of three
{     possible conditions:

{         fsc$null_file_access_condition - The volume is online and active.

{         fsc$media_missing - The volume is not in the active configuration.

{         fsc$volume_unavailable - The volume is inaccessible due to hardware
{         failure.


  TYPE
    fst$mass_storage_device_info = record
      bytes_allocated: amt$file_byte_address,
      object_condition: fst$file_access_condition,
      shared_queue: ost$name,
      case resides_online: boolean of
      = FALSE =
        ,
      = TRUE =
        allocation_unit_size: amt$file_byte_address,
        initial_volume: rmt$recorded_vsn,
        mass_storage_class: rmt$mass_storage_class,
        transfer_size: fst$transfer_size,
        volume_condition_list: ^fst$volume_condition_list,
        volume_list: ^rmt$volume_list,
        volume_overflow_allowed: boolean,
      casend,
    recend;

*copyc amt$file_byte_address
*copyc fst$volume_condition_list
*copyc fst$transfer_size
*copyc ost$name
*copyc rmt$mass_storage_class
*copyc rmt$recorded_vsn
*copyc rmt$volume_list
*DECK DECK=FST$MASS_STORAGE_EXCEPTIONS EXPAND=FALSE
*DECK DECK=FST$MASS_STORAGE_INFORMATION EXPAND=FALSE
 TYPE
    fst$mass_storage_information = record
      actual_allocation_size: amt$file_byte_address,
      initial_vsn: rmt$volume_descriptor,
      number_of_volumes: amt$volume_number,
      physical_space_assigned: amt$file_byte_address,
      requested_allocation_size: amt$file_byte_address,
      transfer_size: fst$transfer_size,
      volume_overflow_allowed: boolean,
    recend;

*copyc amt$file_byte_address
*copyc amt$volume_number
*copyc fst$transfer_size
*copyc rmt$volume_descriptor
*DECK DECK=FST$MF_USAGE_CONCURRENCY_SCOPE EXPAND=FALSE

  TYPE
    fst$mf_usage_concurrency_scope = (fsc$attached_on_this_mainframe,
          fsc$attached_on_other_mainframe);

*DECK DECK=FST$NUMBER_OF_PATH_ELEMENTS EXPAND=FALSE

  TYPE
    fst$number_of_path_elements = 0 .. fsc$max_path_elements;

*copyc fsc$max_path_elements
*DECK DECK=FST$OLD_CYCLE_DAMAGE_SYMPTOM EXPAND=FALSE
*DECK DECK=FST$OPEN_ATTACHMENT_INFORMATION EXPAND=FALSE

 TYPE
    fst$open_attachment_information = record
      access_modes: fst$file_access_options,
      error_exit_procedure: amt$error_exit_procedure,
      error_exit_procedure_name: pmt$entry_point_reference,
      error_limit: amt$error_limit,
      label_exit_procedure: amt$label_exit_procedure,
      label_exit_procedure_name: pmt$entry_point_reference,
      message_control: amt$message_control,
      open_position: amt$open_position,
      open_share_modes: fst$file_access_options,
      private_read: boolean,
      sequential_access: boolean,
      share_modes: fst$file_access_options,
      tape_error_options: amt$tape_error_options,
      transfer_size: fst$transfer_size,
    recend;

*copyc amt$error_exit_procedure
*copyc amt$error_limit
*copyc amt$label_exit_procedure
*copyc amt$message_control
*copyc amt$open_position
*copyc amt$tape_error_options
*copyc fst$file_access_options
*copyc fst$transfer_size
*copyc pmt$entry_point_reference
*copyc pmt$processor_attributes
*DECK DECK=FST$OPEN_COUNT EXPAND=FALSE
*copyc ost$signature_lock

  TYPE
    fst$open_count = integer;
*DECK DECK=FST$OPEN_INSTANCE_INFORMATION EXPAND=FALSE
 TYPE
    fst$open_instance_information = record
      access_level: amt$access_level,
      attachment_information: fst$open_attachment_information,
      attribute_override: fst$attribute_override_info,
      input_device_classes: rmt$device_classes,
      instance_of_open_created_file: boolean,
      instance_of_open_deleted_data: boolean,
      output_device_classes: rmt$device_classes,
    recend;

*copyc amt$access_level
*copyc fst$attribute_override_info
*copyc fst$open_attachment_information
*copyc rmt$device_classes










*DECK DECK=FST$OPEN_POSITION EXPAND=FALSE

  TYPE
    fst$open_position = record
      case specified: boolean of
      = FALSE =
        ,
      = TRUE =
        value: amt$open_position,
      casend,
    recend;

*copyc amt$open_position
*DECK DECK=FST$PARSED_FILE_REFERENCE EXPAND=FALSE
{
{ A FST$PARSED_FILE_REFERENCE provides a breakdown of a file reference.  The
{ path field is a container for the maximum-sized file reference in the form of
{ a string.
{
{ The remaining fields define a substring within the path field for particular
{ path elements.  Depending upon the context in which this type is used, not
{ all of the path elements may be defined.  A missing path element will be
{ identified by a null string, i.e.  the index will be set to one (1) and the
{ size will be set to zero (0).
{
{ The information provided by these fields is best described by example:
{
{ Assume the path is:  :NVE.AJL.BAM.SOURCE_LIBRARY.$HIGH.$ASIS
{
{ complete_path provides ->        :NVE.AJL.BAM.SOURCE_LIBRARY.$HIGH.$ASIS
{ cycle_path provides ->           :NVE.AJL.BAM.SOURCE_LIBRARY.$HIGH
{ file_path provides ->            :NVE.AJL.BAM.SOURCE_LIBRARY
{ catalog_path provides ->         :NVE.AJL.BAM
{ first_name provides ->           NVE
{ last_name provides ->            SOURCE_LIBRARY
{ cycle_reference provides ->      $HIGH
{ open_position provides ->        $ASIS
{ number_of_path_elements ->       4
{
{ Assume the path is:  $LOCAL.JUNK.1.$ASIS
{
{ complete_path provides ->        :$LOCAL.JUNK.1.$ASIS
{ cycle_path provides ->           :$LOCAL.JUNK.1
{ file_path provides ->            :$LOCAL.JUNK
{ catalog_path provides ->         :$LOCAL
{ first_name provides ->           $LOCAL
{ last_name provides ->            JUNK
{ cycle_reference provides ->      1
{ open_position provides ->        $ASIS
{ number_of_path_elements ->       2
{
{ Assume the path is:  :$SOURCE.$UP.OBJECT_LIBRARY
{
{ complete_path provides ->        :$SOURCE.$UP.OBJECT_LIBRARY
{ cycle_path provides ->           :$SOURCE.$UP.OBJECT_LIBRARY
{ file_path provides ->            :$SOURCE.$UP.OBJECT_LIBRARY
{ catalog_path provides ->         :$SOURCE.$UP
{ first_name provides ->           $SOURCE
{ last_name provides ->            OBJECT_LIBRARY
{ cycle_reference provides ->      null string
{ open_position provides ->        null string
{ number_of_path_elements ->       3
{

  TYPE
    fst$parsed_file_reference = record
      path: fst$path,
      catalog_path_size: fst$path_size,
      complete_path_size: fst$path_size,
      cycle_path_size: fst$path_size,
      cycle_reference: fst$path_element_substring,
      file_path_size: fst$path_size,
      first_name: fst$path_element_substring,
      last_name: fst$path_element_substring,
      number_of_path_elements: fst$number_of_path_elements,
      open_position: fst$path_element_substring,
    recend;

*copyc fst$number_of_path_elements
*copyc fst$path
*copyc fst$path_size
*copyc fst$path_element_substring
*DECK DECK=FST$PATH EXPAND=FALSE

  TYPE
    fst$path = string (fsc$max_path_size);

*copyc fsc$max_path_size
*DECK DECK=FST$PATH_ELEMENT EXPAND=FALSE

  TYPE
    fst$path_element = record
      size: fst$path_element_size,
      value: fst$path_element_name,
    recend;

*copyc fst$path_element_name
*copyc fst$path_element_size
*DECK DECK=FST$PATH_ELEMENT_INDEX EXPAND=FALSE

  TYPE
    fst$path_element_index = 1 .. fsc$max_path_elements;

*copyc fsc$max_path_elements
*DECK DECK=FST$PATH_ELEMENT_NAME EXPAND=FALSE

  TYPE
    fst$path_element_name = string (fsc$max_path_element_size);

*copyc fsc$max_path_element_size
*DECK DECK=FST$PATH_ELEMENT_SIZE EXPAND=FALSE

  TYPE
    fst$path_element_size = 0 .. fsc$max_path_element_size;

*copyc fsc$max_path_element_size
*DECK DECK=FST$PATH_ELEMENT_STRING EXPAND=FALSE

  TYPE
    fst$path_element_string = string ( * <= fsc$max_path_size);

*copyc fsc$max_path_size
*DECK DECK=FST$PATH_ELEMENT_SUBSTRING EXPAND=FALSE

 TYPE
    fst$path_element_substring = record
      index: fst$path_index,
      size: fst$path_element_size,
    recend;

*copyc fst$path_index
*copyc fst$path_element_size

*DECK DECK=FST$PATH_HANDLE_INFO EXPAND=FALSE

  TYPE
    fst$path_handle_info = record
      path_handle_present: boolean,
      path_handle: fmt$path_handle,
    recend;

*copyc fmt$path_handle



*DECK DECK=FST$PATH_HANDLE_NAME EXPAND=FALSE

  TYPE
    fst$path_handle_name = ost$name;

*copyc ost$name
*DECK DECK=FST$PATH_INDEX EXPAND=FALSE
 TYPE
    fst$path_index = 1 .. fsc$max_path_size + 1;

*copyc fsc$max_path_size
*DECK DECK=FST$PATH_RESOLUTION EXPAND=FALSE

  TYPE
    fst$path_resolution = (fsc$path_resolution_error, fsc$unresolved_path,
      fsc$path_does_not_exist, fsc$new_file_path, fsc$new_cycle_path,
      fsc$catalog_path, fsc$cycle_path, fsc$command_file_path);

*DECK DECK=FST$PATH_SIZE EXPAND=FALSE
 TYPE
    fst$path_size = 0 .. fsc$max_path_size;

*copyc fsc$max_path_size
*DECK DECK=FST$PATH_TABLE_EXPANSION_LIMIT EXPAND=FALSE

  TYPE
    fst$path_table_expansion_limit = (fsc$disbt_pde, fsc$disbt_cd,
          fsc$disbt_all);

*DECK DECK=FST$PRIVATE_READ EXPAND=FALSE

  TYPE
    fst$private_read = record
      CASE specified_on_attach: boolean OF
      = TRUE =
        value: boolean,
      = FALSE =
        ,
      CASEND
    recend;
*DECK DECK=FST$RESOLVED_FILE_REFERENCE EXPAND=FALSE

 TYPE

{      The PATH field is a container for the maximum-sized file reference
{      in the form of a string.
{
{      The PERMANENT_FILE field is set to TRUE if the file is a permanent
{      file and FALSE for a temporary file.
{
{      The fields CATALOG_PATH_SIZE, COMPLETE_PATH_SIZE, CYCLE_PATH_SIZE,
{      FAMILY_PATH_SIZE, FILE_PATH_SIZE, and MASTER_CATALOG_PATH_SIZE
{      define the lengths of substrings of the field PATH beginning with the
{      first character of the PATH.
{
{      The remaining fields define substrings of the PATH field that start
{      and end in variable locations within the PATH.  Each of these
{      fields is defined by an INDEX and a SIZE.
{
{      A missing field of the PATH is identified by an INDEX of 1 and a
{      SIZE of 0 (zero).  When this type is used in the context of AMP$FETCH,
{      the only field that may be missing is OPEN_POSITION.  The
{      OPEN_POSITION field is only defined when provided in the file
{      reference passed to the corresponding call to FSP$OPEN_FILE.
{
{      The information provided by these fields is best described by the
{      following examples:
{
{      EXAMPLE 1
{      Assume the PATH field contains:   ':NVE.AJL.BAM.SOURCE_LIBRARY.12.$ASIS'
{
{      The substring reference:          Refers to the substring:
{      ---------------------------------------------------------------------
{      path(1, complete_path_size)       ':NVE.AJL.BAM.SOURCE_LIBRARY.12.$ASIS'
{      path(1, cycle_path_size)          ':NVE.AJL.BAM.SOURCE_LIBRARY.12'
{      path(1, file_path_size)           ':NVE.AJL.BAM.SOURCE_LIBRARY'
{      path(1, catalog_path_size)        ':NVE.AJL.BAM'
{      path(1, master_catalog_path_size) ':NVE.AJL'
{      path(1, family_path_size)         ':NVE'
{      path(family_name.index,
{           family_name.size)            'NVE'
{      path(master_catalog_name.index,
{           master_catalog_name.size)    'AJL'
{      path(last_catalog_name.index,
{           last_catalog_name.size)      'BAM'
{      path(file_name.index,
{           file_name.size)              'SOURCE_LIBRARY'
{      path(cycle_number.index,
{           cycle_number.size)           '12'
{      path(open_position.index
{           open_position.size)          '$ASIS'
{
{                                        Also returned:
{      number_of_path_elements           4
{      permanent_file                    TRUE
{
{      EXAMPLE 2
{      Assume the PATH field contains:   '$LOCAL.JUNK.1'
{
{      The substring reference:          Refers to the substring:
{      ---------------------------------------------------------------------
{      path(1, complete_path_size)       ':$LOCAL.JUNK.1'
{      path(1, cycle_path_size)          ':$LOCAL.JUNK.1'
{      path(1, file_path_size)           ':$LOCAL.JUNK'
{      path(1, catalog_path_size)        ':$LOCAL'
{      path(1, master_catalog_path_size) ':$LOCAL'
{      path(1, family_path_size)         ':$LOCAL'
{      path(family_name.index,
{           family_name.size)            '$LOCAL'
{      path(master_catalog_name.index,
{           master_catalog_name.size)    '$LOCAL'
{      path(last_catalog_name.index,
{           last_catalog_name.size)      '$LOCAL'
{      path(file_name.index,
{           file_name.size)              'JUNK'
{      path(cycle_number.index,
{           cycle_number.size)           '1'
{      path(open_position.index
{           open_position.size)          ''
{
{                                        Also returned:
{      number_of_path_elements           2
{      permanent_file                    FALSE

    fst$resolved_file_reference = record
      path: fst$path,
      catalog_path_size: fst$path_size,
      complete_path_size: fst$path_size,
      cycle_number: fst$path_element_substring,
      cycle_path_size: fst$path_size,
      family_name: fst$path_element_substring,
      family_path_size: fst$path_size,
      file_name: fst$path_element_substring,
      file_path_size: fst$path_size,
      last_catalog_name: fst$path_element_substring,
      master_catalog_name: fst$path_element_substring,
      master_catalog_path_size: fst$path_size,
      number_of_path_elements: fst$number_of_path_elements,
      open_position: fst$path_element_substring,
      permanent_file: boolean,
    recend;

*copyc fst$number_of_path_elements
*copyc fst$path
*copyc fst$path_size
*copyc fst$path_element_substring
*DECK DECK=FST$RETENTION EXPAND=FALSE

 TYPE
    fst$retention = record
      case selector: fst$retention_attribute_type of
      = fsc$retention_day_increment =
        day_increment: pft$retention,
      = fsc$retention_time_increment =
        time_increment: pmt$time_increment,
      = fsc$retention_expiration_date =
        expiration_date: ost$date_time,
      casend,
    recend;

*copyc fst$retention_attribute_type
*copyc ost$date_time
*copyc pfd$permanent_file_definitions
*copyc pmt$time_increment
*DECK DECK=FST$RETENTION_ATTRIBUTE_TYPE EXPAND=FALSE

  TYPE
    fst$retention_attribute_type = (fsc$retention_day_increment,
          fsc$retention_time_increment, fsc$retention_expiration_date);
*DECK DECK=FST$ROLLBACK_PROCEDURE EXPAND=FALSE

TYPE
  fst$rollback_procedure = ^procedure (condition_status: ost$status);

*copyc ost$status
*DECK DECK=FST$SETFA_ATTACHMENT_OPTIONS EXPAND=FALSE

  TYPE
    fst$setfa_attachment_options = record
      access_modes_specified: boolean,
      access_modes: fst$file_access_options,
      error_exit_name_specified: boolean,
      error_exit_name: pmt$program_name,
      error_limit_specified: boolean,
      error_limit: amt$error_limit,
      label_exit_name_specified: boolean,
      label_exit_name: pmt$program_name,
      message_control_specified: boolean,
      message_control: amt$message_control,
      open_position_specified: boolean,
      open_position: amt$open_position,
    recend;

*copyc amt$error_limit
*copyc amt$message_control
*copyc amt$open_position
*copyc fst$file_access_options
*copyc pmt$program_name
*DECK DECK=FST$SHARE_MODES EXPAND=FALSE
 TYPE

    fst$share_modes = record
      case selector: fst$share_mode_choices of
      = fsc$determine_from_access_modes, fsc$required_share_modes =
        ,
      = fsc$specific_share_modes =
        value: fst$file_access_options,
      casend
    recend;

*copyc fst$share_mode_choices
*copyc fst$file_access_options
*DECK DECK=FST$SHARE_MODE_CHOICES EXPAND=FALSE
 TYPE

    fst$share_mode_choices = (fsc$determine_from_access_modes,
      fsc$required_share_modes, fsc$specific_share_modes);
*DECK DECK=FST$SPECIFIED_ATTACH_OPTION EXPAND=FALSE

  TYPE
    fst$specified_attach_option = (fsc$free_behind_ao,
      fsc$job_write_concurrency_ao, fsc$sequential_access_ao,
      fsc$transfer_size_ao);
*DECK DECK=FST$SPECIFIED_ATTACH_OPTIONS EXPAND=FALSE

  TYPE
    fst$specified_attach_options = set of fst$specified_attach_option;

*copyc fst$specified_attach_option
*DECK DECK=FST$STATUS_REPORTING_PROCEDURE EXPAND=FALSE


  TYPE
    fst$status_reporting_procedure = ^procedure
           (    condition: ost$status_condition;
                text: string ( * );
            VAR status: ost$status);

*copyc ost$status


*DECK DECK=FST$SUPPLIED_FILE_SET_POSITIONS EXPAND=FALSE

  TYPE
    fst$supplied_file_set_position = (fsc$fsp_file_identifier,
          fsc$fsp_generation_number, fsc$fsp_file_sequence_number),

    fst$supplied_file_set_positions = set of fst$supplied_file_set_position;
*DECK DECK=FST$TAPE_ATTACHMENT EXPAND=FALSE

 TYPE
    fst$tape_attachment = RECORD
      CASE selector {input} : fst$tape_attachment_choices OF {input}
      = fsc$tape_block_count =
        {Not applicable to FSP$OPEN_FILE; for FSP$GET_TAPE_LABEL_ATTRIBUTES only
        tape_block_count: 0 .. 999999,
      = fsc$tape_block_type =
        tape_block_type: amt$block_type,
      = fsc$tape_buffer_offset =
        tape_buffer_offset: 0 .. amc$maximum_block,
      = fsc$tape_character_conversion =
        tape_character_conversion: boolean,
      = fsc$tape_character_set =
        tape_character_set: amt$internal_code,
      = fsc$tape_creation_date =
        tape_creation_date: ost$ordinal_date,
      = fsc$tape_expiration_date =
        tape_expiration_date: ost$ordinal_date,
      = fsc$tape_file_accessibility =
        tape_file_accessibility: string (1),
      = fsc$tape_file_identifier =
        {Identifies an ANSI file by name among others on the file set.}
        tape_file_identifier: string (17) {Left-justified, blank-filled} ,
      = fsc$tape_file_section_number =
        {Not applicable to FSP$OPEN_FILE; for FSP$GET_TAPE_LABEL_ATTRIBUTES only
        tape_file_section_number: 1 .. 9999,
      = fsc$tape_file_sequence_number =
        {Identifies an ANSI file by number among others on the file set.}
        tape_file_sequence_number: 1 .. 9999,
      = fsc$tape_file_set_identifier =
        {Unique identification of the files on a volume set}
        tape_file_set_identifier: string (6) {Left-justified, blank-filled} ,
      = fsc$tape_file_set_position =
        {Specifies the position on this file set.}
        tape_file_set_position: fst$tape_file_set_position,
      = fsc$tape_generation_number =
        tape_generation_number: 1 .. 9999,
      = fsc$tape_generation_version_num =
        tape_generation_version_num: 0 .. 99,
      = fsc$tape_header_labels =
        {Not applicable to FSP$OPEN_FILE}
        {Caller provides sequence; FSP$GET_TAPE_LABEL_ATTRIBUTES initializes it}
        tape_header_labels: ^SEQ(*),
      = fsc$tape_implementation_id =
        {Removable_media_operation privilege required by FSP$OPEN_FILE}
        {Tape_volume_initialization must also be specified.}
        tape_implementation_id: string(13),
      = fsc$tape_label_standard_version =
        {Removable_media_operation privilege required by FSP$OPEN_FILE}
        {Tape_volume_initialization must also be specified.}
        tape_label_standard_version: 0 .. 9,
      = fsc$tape_max_block_length =
        tape_max_block_length: amt$max_block_length,
      = fsc$tape_max_record_length =
        tape_max_record_length: amt$max_record_length,
      = fsc$tape_null_attachment_option =
        ,
      = fsc$tape_owner_identification =
        tape_owner_identification: string (14),
      = fsc$tape_padding_character =
        tape_padding_character: amt$padding_character,
      = fsc$tape_record_type =
        tape_record_type: amt$record_type,
      = fsc$tape_removable_media_group =
        tape_removable_media_group: string (13),
      = fsc$tape_rewrite_labels =
        tape_rewrite_labels: boolean,
      = fsc$tape_trailer_labels =
        {Not applicable to FSP$OPEN_FILE}
        {Caller provides sequence; FSP$GET_TAPE_LABEL_ATTRIBUTES initializes it}
        tape_trailer_labels: ^SEQ(*),
      = fsc$tape_volume_accessibility =
        tape_volume_accessibility: string (1),
      = fsc$tape_volume_initialization =
        {Removable_media_operation privilege required.}
        tape_volume_initialization: ^fst$tape_volume_initialization,
      CASEND,
    RECEND;

*copyc amt$block_type
*copyc amt$internal_code
*copyc amc$maximum_block
*copyc amt$max_block_length
*copyc amt$max_record_length
*copyc amt$padding_character
*copyc amt$record_type
*copyc fst$tape_attachment_choices
*copyc fst$tape_file_set_position
*copyc fst$tape_volume_initialization
*copyc ost$date





*DECK DECK=FST$TAPE_ATTACHMENT_CHOICES EXPAND=FALSE

 CONST
    fsc$tape_block_type = 1,
    fsc$tape_buffer_offset = 2,
    fsc$tape_character_conversion = 3,
    fsc$tape_character_set = 4,
    fsc$tape_creation_date = 5,
    fsc$tape_expiration_date = 6,
    fsc$tape_file_accessibility = 7,
    fsc$tape_file_identifier = 8,
    fsc$tape_file_sequence_number = 9,
    fsc$tape_file_set_identifier = 10,
    fsc$tape_file_set_position = 11,
    fsc$tape_generation_number = 12,
    fsc$tape_generation_version_num = 13,
    fsc$tape_max_block_length = 14,
    fsc$tape_max_record_length = 15,
    fsc$tape_null_attachment_option = 16,
    fsc$tape_padding_character = 17,
    fsc$tape_record_type = 18,
    fsc$tape_rewrite_labels = 19,
    fsc$tape_removable_media_group = 20,
    fsc$tape_volume_accessibility = 21,
    fsc$tape_owner_identification = 22,
    fsc$tape_label_standard_version = 23,
    fsc$tape_implementation_id = 24,
    fsc$tape_header_labels = 25,
    fsc$tape_trailer_labels = 26,
    fsc$tape_file_section_number = 27,
    fsc$tape_block_count = 28,
    fsc$tape_volume_initialization = 29;

  TYPE
    fst$tape_attachment_choices = 1 .. fsc$max_tape_attach_choice;

*copyc fsc$max_tape_attach_choice
*DECK DECK=FST$TAPE_ATTACHMENT_INFORMATION EXPAND=FALSE

 TYPE
    fst$tape_attachment_information = RECORD

      block_type: amt$block_type,
      block_type_source: fst$tape_attach_info_source,
      buffer_offset: 0 .. amc$maximum_block,
      buffer_offset_source: fst$tape_attach_info_source,
      character_conversion: boolean,
      character_conversion_source: fst$tape_attach_info_source,
      character_set: amt$internal_code,
      character_set_source: fst$tape_attach_info_source,
      creation_date: ost$ordinal_date,
      creation_date_source: fst$tape_attach_info_source,
      expiration_date: ost$ordinal_date,
      expiration_date_source: fst$tape_attach_info_source,
      file_accessibility: string (1),
      file_accessibility_source: fst$tape_attach_info_source,
      file_identifier: string (17) {Left-justified, blank-filled} ,
      file_identifier_source: fst$tape_attach_info_source,
      file_section_number: 1 .. 9999,
      file_section_number_source: fst$tape_attach_info_source,
      file_sequence_number: 1 .. 9999,
      file_sequence_number_source: fst$tape_attach_info_source,
      file_set_identifier: string (6) {Left-justified, blank-filled} ,
      file_set_identifier_source: fst$tape_attach_info_source,
      file_set_position: fst$tape_file_set_position,
      file_set_position_source: fst$tape_attach_info_source,
      generation_number: 1 .. 9999,
      generation_number_source: fst$tape_attach_info_source,
      generation_version_number: 0 .. 99,
      generation_version_num_source: fst$tape_attach_info_source,
      label_standard_version: string(1),
      label_standard_version_source: fst$tape_attach_info_source,
      max_block_length: amt$max_block_length,
      max_block_length_source: fst$tape_attach_info_source,
      max_record_length: amt$max_record_length,
      max_record_length_source: fst$tape_attach_info_source,
      owner_identifier: string(14),
      owner_identifier_source: fst$tape_attach_info_source,
      padding_character: amt$padding_character,
      padding_character_source: fst$tape_attach_info_source,
      record_type: amt$record_type,
      record_type_source: fst$tape_attach_info_source,
      removable_media_group: string (13),
      removable_media_group_source: fst$tape_attach_info_source,
      rewrite_labels: boolean,
      rewrite_labels_source: fst$tape_attach_info_source,
      supplied_file_set_pos_fields: fst$supplied_file_set_positions,
      system_code: string(13),
      system_code_source: fst$tape_attach_info_source,
      volume_accessibility: string (1),
      volume_accessibility_source: fst$tape_attach_info_source,
      CASE volume_initialization: boolean OF
        = TRUE =
          tape_volume_initialization: fst$tape_volume_initialization,
        = FALSE =,
      CASEND,
    RECEND;

*copyc amt$block_type
*copyc amt$internal_code
*copyc amc$maximum_block
*copyc amt$max_block_length
*copyc amt$max_record_length
*copyc amt$padding_character
*copyc amt$record_type
*copyc fst$supplied_file_set_positions
*copyc fst$tape_attachment_choices
*copyc fst$tape_attach_info_source
*copyc fst$tape_file_set_position
*copyc fst$tape_volume_initialization
*copyc ost$date


*DECK DECK=FST$TAPE_ATTACHMENT_INFORM_REQ EXPAND=FALSE
*DECK DECK=FST$TAPE_ATTACH_INFO_SOURCE EXPAND=FALSE
  TYPE

    fst$tape_attach_info_source = (fsc$tape_label_attr_default,
          fsc$tape_label_attr_command, fsc$tape_open_tape_attachment,
          fsc$tape_vol1_label, fsc$tape_hdr1_label, fsc$tape_hdr2_label,
          fsc$tape_undefined_attribute, fsc$tape_local_file_information,
          fsc$tape_change_file_attributes, fsc$tape_open_request,
          fsc$tape_file_reference, fsc$tape_file_command,
          fsc$tape_file_request, fsc$tape_add_to_file_desc,
          fsc$tape_access_method_default, fsc$tape_store_request);

*DECK DECK=FST$TAPE_ATTRIBUTE_SOURCE EXPAND=FALSE
  TYPE
    fst$tape_attribute_source = (fsc$tla_last_ansi_file_accessed,
          fsc$tla_explicit_specification, fsc$tla_next_position,
          fsc$tla_reserved_3, fsc$tla_reserved_4, fsc$tla_reserved_5,
          fsc$tla_reserved_6, fsc$tla_reserved_7);
*DECK DECK=FST$TAPE_BLOCK_LENGTH EXPAND=FALSE
  TYPE
    fst$tape_block_length = 0 .. amc$maximum_block;

*copyc amc$maximum_block
*DECK DECK=FST$TAPE_FILE_SET_POSITION EXPAND=FALSE

  TYPE
    fst$tape_file_set_position = record
      case position: fst$tape_file_set_pos_choices of
      = fsc$tape_beginning_of_set =
        ,
      = fsc$tape_current_file =
        ,
      = fsc$tape_end_of_set =
        ,
      = fsc$tape_file_identifier_pos =
        file_identifier: string (17) {Left-justified, blank-filled} ,
        generation_number: 1 .. 9999,
      = fsc$tape_file_sequence_pos =
        file_sequence_number: 1 .. 9999,
      = fsc$tape_next_file =
        ,
      casend,
    recend;

*copyc fst$tape_file_set_pos_choices
*DECK DECK=FST$TAPE_FILE_SET_POS_CHOICES EXPAND=FALSE

  TYPE
    fst$tape_file_set_pos_choices = (fsc$tape_beginning_of_set,
          fsc$tape_current_file, fsc$tape_end_of_set,
          fsc$tape_file_identifier_pos, fsc$tape_file_sequence_pos,
          fsc$tape_next_file);

*DECK DECK=FST$TAPE_LABEL_BLOCK_DESCRIPTOR EXPAND=FALSE
  TYPE
    fst$tape_label_block_descriptor = record
      case label_block_type: fst$tape_label_block_type of
      = fsc$erroneous_tape_label_block =
        erroneous_label_actual_length: fst$tape_block_length,
        erroneous_label_transfer_length: fst$tape_label_length,
        erroneous_label_failure_modes: amt$tape_failure_modes,
      = fsc$non_tape_label_block =
        non_label_actual_length: fst$tape_block_length,
        non_label_transfer_length: fst$tape_label_length,
      = fsc$normal_tape_label_block =
        normal_label_actual_length: fst$tape_block_length,
        normal_label_character_set: amt$internal_code,
        normal_label_kind: fst$ansi_label_kind,
        normal_label_transfer_length: fst$tape_label_length,
      = fsc$null_tape_label_block =
        null_label_actual_length: fst$tape_block_length,
        null_label_character_set: amt$internal_code,
        null_label_kind: fst$ansi_label_kind,
        null_label_transfer_length: fst$tape_label_length,
      = fsc$tapemark_tape_label_block =
        ,
      casend,
    recend;

*copyc amc$maximum_block
*copyc amt$internal_code
*copyc amt$tape_failure_modes
*copyc fst$ansi_label_identifier
*copyc fst$ansi_label_kind
*copyc fst$ansi_label_number
*copyc fst$tape_block_length
*copyc fst$tape_label_block_type
*copyc fst$tape_label_length
*DECK DECK=FST$TAPE_LABEL_BLOCK_TYPE EXPAND=FALSE
  CONST
    fsc$erroneous_tape_label_block = 1,
    fsc$non_tape_label_block = 2,
    fsc$normal_tape_label_block = 3,
    fsc$null_tape_label_block = 4,
    fsc$tapemark_tape_label_block = 5;

  TYPE
    fst$tape_label_block_type = 1 .. fsc$max_tape_label_block_type;

*copyc fsc$max_tape_label_block_type
*DECK DECK=FST$TAPE_LABEL_CLASSIFICATION EXPAND=FALSE
  TYPE
    fst$tape_label_classification = record
      case valid_label: boolean of
      = TRUE =
        character_set: amt$internal_code,
        label_kind: fst$ansi_label_kind,
        label_number: fst$ansi_label_number,
        label_identifier: fst$ansi_label_identifier,
      = FALSE =
        ,
      casend,
    recend;

*copyc amt$internal_code
*copyc fst$ansi_label_kind
*copyc fst$ansi_label_identifier
*copyc fst$ansi_label_number
*DECK DECK=FST$TAPE_LABEL_COUNT EXPAND=FALSE
  TYPE
    fst$tape_label_count = 0 .. fsc$max_tape_labels;

*copyc fsc$max_tape_labels
*DECK DECK=FST$TAPE_LABEL_IDENTIFIER EXPAND=FALSE
  TYPE
    fst$tape_label_identifier = record
      case location_method: fst$tape_label_location_method of
      = fsc$tape_label_locate_by_index =
        label_index: fst$tape_label_count,
      = fsc$tape_label_locate_by_kind =
        label_kind: fst$ansi_label_kind,
      = fsc$tape_label_locate_by_ident =
        label_identifier: fst$ansi_label_identifier,
        label_number: fst$ansi_label_number,
      casend,
    recend;

*copyc fst$ansi_label_identifier
*copyc fst$ansi_label_kind
*copyc fst$ansi_label_number
*copyc fst$tape_label_count
*copyc fst$tape_label_location_method
*DECK DECK=FST$TAPE_LABEL_LENGTH EXPAND=FALSE
  TYPE
    fst$tape_label_length = 0 .. fsc$max_tape_label_length;

*copyc fsc$max_tape_label_length
*DECK DECK=FST$TAPE_LABEL_LOCATION_METHOD EXPAND=FALSE
  CONST
    fsc$tape_label_locate_by_ident = 1,
    fsc$tape_label_locate_by_index = 2,
    fsc$tape_label_locate_by_kind = 3;

  TYPE
    fst$tape_label_location_method = 1 .. fsc$max_tape_label_loc_method;

*copyc fsc$max_tape_label_loc_method
*DECK DECK=FST$TAPE_LABEL_LOCATOR EXPAND=FALSE
  TYPE
    fst$tape_label_locator = record
      case label_found: boolean of
      = FALSE =
        ,
      = TRUE =
        label_block: ^SEQ ( * ),
        label_block_descriptor: ^fst$tape_label_block_descriptor,
        label_index: fst$tape_label_count,
      casend,
    recend;

*copyc fst$tape_label_block_descriptor
*copyc fst$tape_label_count
*DECK DECK=FST$TAPE_LABEL_SEQUENCE_HEADER EXPAND=FALSE
  TYPE
    fst$tape_label_sequence_header = record
      character_set: amt$internal_code,
      label_kinds: fst$ansi_label_kinds,
      sequence_size: ost$positive_integers,
      label_count: fst$tape_label_count,
    recend;

*copyc amt$internal_code
*copyc fst$ansi_label_kinds
*copyc fst$tape_label_count
*copyc osd$integer_limits
*DECK DECK=FST$TAPE_SECURITY_CALL_BLOCK EXPAND=FALSE
{ This deck is externalized to OSF$SUBSYSTEM_INTERFACE.
{ All changes should be forward compatible, if at all possible.

  TYPE
    fst$tape_security_call_block = record
      case operation: fst$tape_security_operation of
      = fsc$ts_authorize_access_method =
        authorize_access_method: fst$ts_authorize_access_method,
      = fsc$ts_authorize_file_access =
        authorize_file_access: fst$ts_authorize_file_access,
      = fsc$ts_authorize_file_reuse =
        authorize_file_reuse: fst$ts_authorize_file_reuse,
      = fsc$ts_authorize_file_set_mount =
        authorize_file_set_mount: fst$ts_authorize_file_set_mount,
      = fsc$ts_authorize_file_set_reuse =
        authorize_file_set_reuse: fst$ts_authorize_file_set_reuse,
      = fsc$ts_authorize_section_read =
        authorize_section_read: fst$ts_authorize_section_read,
      = fsc$ts_authorize_section_write =
        authorize_section_write: fst$ts_authorize_section_write,
      = fsc$ts_authorize_volume_reuse =
        authorize_volume_reuse: fst$ts_authorize_volume_reuse,
      = fsc$ts_secure_header_labels =
        secure_header_labels: fst$ts_secure_header_labels,
      = fsc$ts_secure_trailer_labels =
        secure_trailer_labels: fst$ts_secure_trailer_labels,
      = fsc$ts_validate_header_labels =
        validate_header_labels: fst$ts_validate_header_labels,
      = fsc$ts_validate_trailer_labels =
        validate_trailer_labels: fst$ts_validate_trailer_labels,
      casend,
    recend;

*copy fst$tape_security_operation
*copy fst$ts_authorize_access_method
*copy fst$ts_authorize_file_access
*copy fst$ts_authorize_file_reuse
*copy fst$ts_authorize_file_set_mount
*copy fst$ts_authorize_file_set_reuse
*copy fst$ts_authorize_section_read
*copy fst$ts_authorize_section_write
*copy fst$ts_authorize_volume_reuse
*copy fst$ts_secure_header_labels
*copy fst$ts_secure_trailer_labels
*copy fst$ts_validate_header_labels
*copy fst$ts_validate_trailer_labels
*DECK DECK=FST$TAPE_SECURITY_OPERATION EXPAND=FALSE
  CONST

    fsc$ts_authorize_access_method = 0,
    fsc$ts_authorize_file_access = 1,
    fsc$ts_authorize_file_reuse = 2,
    fsc$ts_authorize_file_set_mount = 3,
    fsc$ts_authorize_file_set_reuse = 4,
    fsc$ts_authorize_section_read = 5,
    fsc$ts_authorize_section_write = 6,
    fsc$ts_authorize_volume_reuse = 7,
    fsc$ts_secure_header_labels = 8,
    fsc$ts_secure_trailer_labels = 9,
    fsc$ts_validate_header_labels = 10,
    fsc$ts_validate_trailer_labels = 11;

  TYPE
    fst$tape_security_operation = 0 .. fsc$max_tape_security_operation;

*copyc fsc$max_tape_security_operation
*DECK DECK=FST$TAPE_VOLUME_INITIALIZATION EXPAND=FALSE
  TYPE
    fst$tape_volume_initialization = record
      blank_label_group: ^SEQ ( * ),
      element: ost$name,
      volume_confirmation: fst$volume_confirmation_options,
    recend;

*copyc ost$name
*copyc fst$volume_confirmation_options
*DECK DECK=FST$TARGET_FILE_LIST EXPAND=FALSE

  TYPE
    fst$target_file_list = array [1 .. *] of fst$path;

*copyc fst$path
*DECK DECK=FST$TEMPORARY_FILE_PATH EXPAND=FALSE

  TYPE
    fst$temporary_file_path = string (fsc$max_temp_file_path_size);

*copyc fsc$max_temp_file_path_size
*DECK DECK=FST$TLA_DEFAULT_SOURCE EXPAND=FALSE
  TYPE
    fst$tla_default_source = (fsc$tla_system_default,
          fsc$tla_reserved_default_1, fsc$tla_reserved_default_2,
          fsc$tla_reserved_default_3, fsc$tla_reserved_default_4,
          fsc$tla_reserved_default_5, fsc$tla_reserved_default_6,
          fsc$tla_reserved_default_7);

*DECK DECK=FST$TLA_RETURNED_ATTRIBUTES EXPAND=FALSE
  TYPE
    fst$tla_returned_attributes = set of fst$tape_attachment_choices;

*copyc fst$tape_attachment_choices
*DECK DECK=FST$TRANSFER_SIZE EXPAND=FALSE
 TYPE
    fst$transfer_size = ost$segment_length;

*copyc osd$virtual_address
*DECK DECK=FST$TS_AUTHORIZE_ACCESS_METHOD EXPAND=FALSE
  TYPE
    fst$ts_authorize_access_method = record
      access_method {input} : amt$file_label_type,
      enforce_tape_security {input} : boolean,
    recend;

*copyc amt$file_label_type
*DECK DECK=FST$TS_AUTHORIZE_FILE_ACCESS EXPAND=FALSE
  TYPE
    fst$ts_authorize_file_access = record
      enforce_tape_security {input} : boolean,
      header_labels {input} : ^SEQ ( * ),
      proposed_access {input} : fst$file_access_options,
      proposed_access_defaulted {input} : boolean,
      authorized_access {output} : ^fst$file_access_options,
    recend;

*copyc fst$file_access_options
*DECK DECK=FST$TS_AUTHORIZE_FILE_REUSE EXPAND=FALSE
  TYPE
    fst$ts_authorize_file_reuse = record
      enforce_tape_security {input} : boolean,
      initial_volume_classification {input} : rmt$tape_volume_classification,
      initial_volume_header_labels {input} : ^SEQ ( * ),
      original_header_labels {input} : ^SEQ ( * ),
      proposed_header_labels {input} : ^SEQ ( * ),
    recend;

*copyc rmt$tape_volume_classification
*DECK DECK=FST$TS_AUTHORIZE_FILE_SECTION EXPAND=FALSE
*DECK DECK=FST$TS_AUTHORIZE_FILE_SET_MOUNT EXPAND=FALSE
  TYPE
    fst$ts_authorize_file_set_mount = record
      access_method: amt$file_label_type,
      enforce_tape_security {input} : boolean,
      header_labels {input} : ^SEQ ( * ),
      proposed_access {input} : fst$file_access_options,
      proposed_access_defaulted {input} : boolean,
      volume_classification {input} : rmt$tape_volume_classification,
      authorized_access {output} : ^fst$file_access_options,
      file_set_access {output} : ^fst$file_access_options,
    recend;

*copyc amt$file_label_type
*copyc fst$file_access_options
*copyc rmt$tape_volume_classification
*DECK DECK=FST$TS_AUTHORIZE_FILE_SET_REUSE EXPAND=FALSE
  TYPE
    fst$ts_authorize_file_set_reuse = record
      enforce_tape_security {input} : boolean,
      initial_volume_classification {input} : rmt$tape_volume_classification,
      initial_volume_header_labels {input} : ^SEQ ( * ),
      proposed_access {input} : fst$file_access_options,
      proposed_access_defaulted {input} : boolean,
      proposed_header_labels {input} : ^SEQ ( * ),
      proposed_volume_classification {input} : rmt$tape_volume_classification,
      authorized_access {output} : ^fst$file_access_options,
      file_set_access {output} : ^fst$file_access_options,
    recend;

*copyc fst$file_access_options
*copyc rmt$tape_volume_classification
*DECK DECK=FST$TS_AUTHORIZE_OBJECT_REUSE EXPAND=FALSE
*DECK DECK=FST$TS_AUTHORIZE_SECTION_READ EXPAND=TRUE
  TYPE
    fst$ts_authorize_section_read = record
      enforce_tape_security {input} : boolean,
      current_header_labels {input} : ^SEQ ( * ),
      current_volume_classification {input} : rmt$tape_volume_classification,
      file_section_number {input} : 1 .. 9999,
      file_sequence_number: {input} 1 .. 9999,
      initial_volume_classification {input} : rmt$tape_volume_classification,
      initial_volume_header_labels {input} : ^SEQ ( * ),
    recend;

*copyc rmt$tape_volume_classification
*DECK DECK=FST$TS_AUTHORIZE_SECTION_WRITE EXPAND=TRUE
  TYPE
    fst$ts_authorize_section_write = record
      enforce_tape_security {input} : boolean,
      current_header_labels {input} : ^SEQ ( * ),
      initial_volume_classification {input} : rmt$tape_volume_classification,
      initial_volume_header_labels {input} : ^SEQ ( * ),
    recend;

*copyc rmt$tape_volume_classification
*DECK DECK=FST$TS_AUTHORIZE_VOLUME_ACCESS EXPAND=FALSE
*DECK DECK=FST$TS_AUTHORIZE_VOLUME_MOUNT EXPAND=TRUE
*DECK DECK=FST$TS_AUTHORIZE_VOLUME_REUSE EXPAND=FALSE
  TYPE
    fst$ts_authorize_volume_reuse = record
      current_header_labels {input} : ^SEQ ( * ),
      enforce_tape_security {input} : boolean,
      proposed_file_label_type {input} : amt$file_label_type,
      proposed_blank_labels {input} : ^SEQ ( * ),
    recend;

*copyc amt$file_label_type
*DECK DECK=FST$TS_SECURE_HEADER_LABELS EXPAND=FALSE
  TYPE
    fst$ts_secure_header_labels = record
      header_labels {input, output} : ^SEQ ( * ),
    recend;

*DECK DECK=FST$TS_SECURE_TRAILER_LABELS EXPAND=FALSE
  TYPE
    fst$ts_secure_trailer_labels = record
      trailer_labels {input,output} : ^SEQ ( * ),
    recend;

*DECK DECK=FST$TS_VALIDATE_HEADER_LABELS EXPAND=FALSE
  TYPE
    fst$ts_validate_header_labels = record
      header_labels {input, output} : ^SEQ ( * ),
    recend;

*DECK DECK=FST$TS_VALIDATE_TRAILER_LABELS EXPAND=FALSE
  TYPE
    fst$ts_validate_trailer_labels = record
      trailer_labels {input, output} : ^SEQ ( * ),
    recend;

*DECK DECK=FST$USER_ATTRIBUTE_DESCRIPTOR EXPAND=FALSE
 TYPE
    fst$user_attribute_descriptor = record
      name: ost$name,
      privileged_attribute: boolean,

      case attribute_type: fst$user_attribute_type of

      = fsc$boolean_type, fsc$date_time_type, fsc$integer_type, fsc$name_type,
        fsc$real_type, fsc$status_type, fsc$time_increment_type =
        { Do a NEXT of a variable of the type boolean, clt$date_time,
        {integer, ost$name, real, ost$status or pmt$time_increment,
        {respectively.
        ,

      = fsc$entry_point_reference_type =
        { An attribute of type entry point reference has a two-part value.
        {One first does a NEXT of a variable of type pmt$program_name
        {and then a NEXT of a variable of type string whose size is
        {library_path_size.

        library_path_size: fst$path_size,

      = fsc$file_type =
        { Do a NEXT of a variable of type string whose size is file_path_size.

        file_path_size: fst$path_size,

      = fsc$string_type =
        { Do a NEXT of a variable of type string whose size is string_size.

        string_size: 0 .. fsc$max_user_attrib_sequence,
      casend,
    recend;

*copyc clt$date_time
*copyc fsc$max_user_attrib_sequence
*copyc fst$path_size
*copyc fst$user_attribute_type
*copyc ost$name
*copyc ost$status
*copyc pmt$entry_point_reference
*copyc pmt$time_increment
*DECK DECK=FST$USER_ATTRIBUTE_TYPE EXPAND=FALSE
 TYPE
    fst$user_attribute_type = (fsc$boolean_type, fsc$date_time_type,
      fsc$entry_point_reference_type, fsc$file_type, fsc$integer_type,
      fsc$name_type, fsc$null_type, fsc$real_type, fsc$sequence_type,
      fsc$status_type, fsc$string_type, fsc$time_increment_type);
*DECK DECK=FST$USER_DEFINED_ATTRIBUTE EXPAND=FALSE
 TYPE
    fst$user_defined_attribute = record

      name: ost$name,
      privileged_attribute: boolean,

{ When a user attribute of any type is to be created, changed or queried,
{ the caller of the request must provide a program variable of the necessary
{ type and initialize this record to point to the initialized program variable.
{ The value of the attribute will be obtained from or stored into the address
{ provided, depending upon the program request used.
{
      case selector: fst$user_attribute_type of
      = fsc$boolean_type =
        boolean_value: ^boolean,
      = fsc$date_time_type =
        date_time: ^clt$date_time,
      = fsc$entry_point_reference_type =
        entry_point_reference_value: ^pmt$entry_point_reference,
      = fsc$file_type =
        file_value: ^fst$file_reference,
      = fsc$integer_type =
        integer_value: ^integer,
      = fsc$name_type =
        name_value: ^ost$name,
      = fsc$null_type =
        ,
      = fsc$real_type =
        real_value: ^real,
      = fsc$sequence_type =
        sequence_value: ^SEQ ( * ),
      = fsc$status_type =
        status_value: ^ost$status,
      = fsc$string_type =
        string_value: ^string ( * ),
      = fsc$time_increment_type =
        time_increment_value: ^pmt$time_increment,
      casend,
    recend;

*copyc clt$date_time
*copyc fst$file_reference
*copyc fst$user_attribute_type
*copyc ost$name
*copyc ost$status
*copyc pmt$entry_point_reference
*copyc pmt$time_increment
*DECK DECK=FST$USER_DEFINED_ATTRIBUTE_SIZE EXPAND=FALSE

  TYPE
    fst$user_defined_attribute_size = 0 .. fsc$max_user_attrib_sequence;

*copyc fsc$max_user_attrib_sequence
*DECK DECK=FST$VOLUME_CONDITION_LIST EXPAND=FALSE
  TYPE
    fst$volume_condition_list = array [ * ] of fst$file_access_condition;

*copyc fst$file_access_condition
*DECK DECK=FST$VOLUME_CONFIRMATION_OPTION EXPAND=FALSE
  TYPE
    fst$volume_confirmation_option = (fsc$confirm_expired_volume,
          fsc$confirm_unexpired_volume, fsc$confirm_unlabeled_volume,
          fsc$confirm_unreadable_volume);

*DECK DECK=FST$VOLUME_CONFIRMATION_OPTIONS EXPAND=FALSE
  TYPE
    fst$volume_confirmation_options = set of fst$volume_confirmation_option;

*copyc fst$volume_confirmation_option
*DECK DECK=FST$WAIT_FOR_ATTACHMENT EXPAND=FALSE

  TYPE
    fst$wait_for_attachment = record
      case wait: ost$wait of
      = osc$nowait =
        ,
      = osc$wait =
        { wait time is expressed in milliseconds}
        wait_time: 1 .. fsc$longest_wait_time,
      casend,
    recend;

*copyc fsc$longest_wait_time
*copyc ost$wait
*DECK DECK=FSV$ATTACHMENT_NAMES EXPAND=FALSE

  VAR
    fsv$attachment_names: [XREF, READ, oss$job_paged_literal] ^array [1 .. *] of
          ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
*copyc ost$name
?? POP ??
*DECK DECK=FSV$ATTRIBUTE_NAMES EXPAND=FALSE

  VAR
    fsv$attribute_names: [XREF, READ, oss$job_paged_literal] ^array [1 .. *] of
          ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
*copyc ost$name
?? POP ??
*DECK DECK=FSV$CONDITION_MAPPING_TABLE EXPAND=FALSE
*DECK DECK=FSV$COPF_INPUT_FILE_ATTACHMENT EXPAND=FALSE

{ The attachment options specified by fsp$copy_file when calling
{ fsp$subsystem_copy_file.

  VAR
    fsv$copf_input_file_attachment: [XREF, READ,
          oss$job_paged_literal] array [1 .. fsc$copf_input_attachment_size] of
          fst$attachment_option;

?? PUSH (LISTEXT := ON) ??
*copyc fsc$copf_input_attachment_size
*copyc fst$attachment_option
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=FSV$COPF_OUTPUT_FILE_ATTACHMENT EXPAND=FALSE

{ The attachment options specified by fsp$copy_file when calling
{ fsp$subsystem_copy_file.

  VAR
    fsv$copf_output_file_attachment: [XREF, READ, oss$job_paged_literal]
          array [1 .. fsc$copf_output_attachment_size] of
          fst$attachment_option;

?? PUSH (LISTEXT := ON) ??
*copyc fsc$copf_output_attachment_size
*copyc fst$attachment_option
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=FSV$DEFAULT_JOB_ENVIRON_INFO EXPAND=FALSE

  VAR
    fsv$default_job_environ_info: [XREF] fst$job_environment_information;

?? PUSH (LISTEXT := ON) ??
*copyc fst$job_environment_information
?? POP ??
*DECK DECK=FSV$EVALUATED_FILE_REFERENCE EXPAND=FALSE

  VAR
    fsv$evaluated_file_reference: [XREF, READ]
      fst$evaluated_file_reference;
      { XDCL is in bam$tables; oss$job_page_literal. }
      { Contains default values for initialization. }

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
?? POP ??



*DECK DECK=FSV$FILE_ACCESS_CONDITIONS EXPAND=FALSE
*DECK DECK=FSV$TEST_HARNESS_CMNDS EXPAND=FALSE

  VAR
    fsv$test_harness_cmnds: [XREF, READ] ^clt$command_table;

?? PUSH (LISTEXT := ON) ??
*copyc clt$command_table
?? POP ??
*DECK DECK=FSV$TEST_HARNESS_FNCTNS EXPAND=FALSE

  VAR
    fsv$test_harness_fnctns: [XREF, READ] ^clt$function_table;

?? PUSH (LISTEXT := ON) ??
*copyc clt$function_table
?? POP ??
*DECK DECK=FUNMC EXPAND=FALSE
          SPACE  3
*
*  NAME: FUNMC
*
*  PURPOSE:  THIS MACRO IS USED TO FUNCTION THE MAINTENANCE CHANNEL.
*
*  INPUT:
*         ELE = DIRECT CELL CONTAINING CONNECT CODE AND THE ELEMENT TYPE.
*         FC  = MAINTENANCE CHANNEL FUNCTION CODE.
*

 FUNMC    MACRO  ELE,FC
          LOCAL  LFC
 MAXFC    EQU    17B         MAXIMUM FUNCTION CODE VALUE.

*         TEST FOR VALID FUNCTION CODE.

 IF1      IFGE   FC,0
 IF2      IFLE   FC,MAXFC
 LFC      SET    FC*16
 IF2      ELSE
          ERR    FUNCTION CODE NOT IN RANGE.
 IF2      ENDIF
 IF1      ELSE
          ERR    FUNCTION CODE NOT IN RANGE.
 IF1      ENDIF

          LDD    ELE
          ADC    LFC
          FAN    MCHNL
          ENDM
*DECK DECK=GFC$CONSTANTS EXPAND=FALSE

{ Define constants used for calculating addresses of FDE entries.
{   The FDE array is in mainframe wired or job fixed at a large address defined
{   by GFC$FDE_TABLE_BASE. Each entry is GFC$FDE_SIZE bytes long. NOTE that the actual
{   CYBIL type definition must be exactly this size. There is a check in
{   SYM$DEADSTART_INITIALIZATION to verify this size.

  CONST
    gfc$fde_table_base = 7f00000(16), {133169152 (Big and 0 mod 16384)}
    gfc$fde_control_table_base = gfc$fde_table_base - 16384,
    gfc$fde_size = 104;   {Must be 0 mod 8 and >= than actual FDE size


*DECK DECK=GFC$MONITOR_INTERLOCKS EXPAND=FALSE

{ This constant controls whether the GFP$ rotines actually set/clear the
{ monitor interlock field in the FDE. Until 4 CPU design is complete, interlocking
{ of FDEs is not required because all serailization is done at the entry to monitor.

  CONST
    gfc$monitor_interlocks = FALSE;
*DECK DECK=GFH$ASSIGN_FDE EXPAND=FALSE
{
{ This procedure is used to assign a new FDE entry. It searchs the FDE array in job
{ fixed or mainframe wired (depending on table residency) and returns an SFID & pointer
{ to the first available entry found. On return from this procedure the entry is NOT locked
{ for the task that assigned it.
{
{ Most fields in the newly assigned FDE are initialized to a default value. See the module
{ GFM$FILE_TABLE_MANAGER for a definition of the values.
{
{
{     GFP$ASSIGN_FDE (RESIDENCE, SEGMENT_NUMBER, SFID, FDE_P)
{
{
{ RESIDENCE: (INPUT) Specifies whether the FDE should be assigned in job fixed or
{             mainframe wired.
{ SEGMENT_NUMBER: (INPUT) If residence is GFC$TR_NULL, then this parameter specifies
{            an alternate segment number for the job fixed segment.
{ SFID:      (OUTPUT) The SFID of entry assigned is returned here. The SFID.HASH
{             field in the SFID and FDE is initially set to ZERO by this procedure. The
{             caller is responsible for changing these fields.
{ FDE_P:     (OUTPUT) This parameter contains a pointer to the FDE assigned. The FDE
{             is NOT locked for task the created it.

*DECK DECK=GFH$FREE_FDE EXPAND=FALSE
{
{ This procedure is used to free an FDE entry. Before calling this procedure,
{ all memory assigned to the file should be freed. All tables subordinate to he FDE
{ should be freed. The FDE cannot be accessed after being freed.
{
{ Before calling this procedure, the FDE entry should be unlocked with gfp$unlock_fde if it is
{ locked.
{
{     GFP$FREE_FDE (FDE_P)
{
{ FDE_P: (INPUT) This parameter contains a pointer to the entry being freed.
{
*DECK DECK=GFH$REASSIGN_FDE EXPAND=FALSE

{
{ This procedure is used in job begin to recreate the cloned template FDEs. In the original cloning
{ process, copies of the FDEs were made. During LOGIN of subsequent jobs, it is necessary to recreate
{ the identical FDEs with the same hash and index.
{
{ Most fields in the newly assigned FDE are set to the same value as in the original FDE.
{ The MEDIA is reset to transient segment and EOI is set to zero.
{
{
{     GFP$REASSIGN_FDE (SFID, OLD_FDE_P)
{
{
{ SFID:  (INPUT) This parameter specifies the SFID of the entry to be created.
{          A system error occurs if the entry is already in use for another file.
{ OLD_FDE_P: (INPUT) This parameter is a pointer to a copy of the FDE in the
{         cloned template.

*DECK DECK=GFH$SCAN_ALL_FDES EXPAND=FALSE
{
{ This procedure is used to generate FDE pointers to all FDE entries that are in use.
{ Note that the entry is NOT interlocked by this request.
{     Example:    gfp$scan_all_fdes (gfc$tr_system, state, fde_p)
{                 WHILE fde_p <> NIL DO
{                   xxx;
{                   gfp$scan_all_fdes (gfc$tr_null_residence, state, fde_p)
{                 WHILEND;
{
{
{    GFP$SCAN_ALL_FDES (RESIDENCE, STATE, FDE_P)
{
{
{ RESIDENCE: (INPUT)  On the FIRST call to this proc, this parameter indicates whether to
{      scan global or job FDEs. Subsequent calls (in the loop) should specify
{      gfc$tr_null_residence.
{
{ STATE: (INPUT/OUTPUT) Private state variable for the procedure.
{
{ FDE_P: (OUTPUT) Pointer to next FDE. NIL indicates end of scan.
*DECK DECK=GFM$FILE_TABLE_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Global File Management : Assign and Free FDE Entries' ??
MODULE gfm$file_table_manager;
{
{ PURPOSE:
{   This module contains procedures for assigning and freeing file descriptor table entries.
{
{ DESIGN:
{   File descriptors are kept in either mainframe wired or in job fixed. They are kept in
{   an array at a large offset; they are NOT part of the heap. The address of the array and
{   structures used to manage the array are defined in GFC$CONSTANTS.
{   The tables used to manage FDEs are kept in mainframe/wired/job fixed at offset
{   GFC$FDE_CONTROL_TABLE_BASE. A multi-level index structure is used to manage assignment
{   of entries.
{    o A packed array of 65535 booleans (organized as array [0 .. 1023] of words) is used
{      to manage assignment of indivual FDEs. If bit <n> of the array is FALSE, then
{      FDE number <n> is free; if bit <n> is TRUE then FDE number <n> is assigned.
{    o In order to improve search time to find an available entry, a second level
{      index (packed array [0 .. 1023] of booleans) is kept to indicate which words in
{      the lower level table have available entries. If bit <m> of this array is FALSE then
{      word <m> of the lower level table contains free entries.
{    o A first level index is maintained to indicate which words in the second level
{      index have free entries.
{    o A free entry can be located by examining 3 words; first level index word, second level index
{      word, in_use word. A hardware instruction (CNIF - convert_integer_to_float) is used
{      that will give the bit number of the first "zero" bit in a word.
{
{
{ NOTE:
{    o The table structure will support assignment of up to 262K entries. Only 65K are
{      currently used because  SFID.INDEX is only 2 bytes. Increasing this to 3 bytes
{      would cause incompatibilities.
{
{    o Create an SCL variable GFC$TEST_HARNESS to compile a standalone
{      version of this module that can be used for testing.
{

  CONST
    gfc$debug = TRUE;

?? NEWTITLE := 'Global Declarations Referenced by this MODULE', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dpp$put_critical_message
*copyc gfc$constants
*copyc gft$file_descriptor_control
*copyc gft$file_descriptor_entry
*copyc gft$file_desc_entry_p
*copyc gft$system_file_identifier
*copyc lgp$add_entry_to_system_log
*copyc mmp$assign_mass_storage
*copyc mmp$create_scratch_segment
*copyc mmp$free_pages
*copyc oss$mainframe_paged_literal
*copyc ost$status_identifier
*copyc ost$status_condition_number
*copyc ost$time
*copyc ost$heap
?? POP ??

*if $variable(gfc$test_harness declared) <> 'UNKNOWN'
{!!! start harness          * * * * * TEST HARNESS VERSION * * * * * }

*copyc clp$put_job_output
*copyc i#program_error

  PROCEDURE osp$fatal_system_error
    (    s: string ( * );
         p: ^ost$status);

    i#program_error;
  PROCEND osp$fatal_system_error;

  PROCEDURE osp$set_mainframe_sig_lock
    (VAR lock: ost$signature_lock);

    IF lock.lock_id = 0 THEN
      lock.lock_id := 1;
    ELSE
      i#program_error;
    IFEND;
  PROCEND osp$set_mainframe_sig_lock;

  PROCEDURE osp$clear_mainframe_sig_lock
    (VAR lock: ost$signature_lock);

    IF lock.lock_id = 1 THEN
      lock.lock_id := 0;
    ELSE
      i#program_error;
    IFEND;
  PROCEND osp$clear_mainframe_sig_lock;

  VAR
    verify_free_entries: boolean := FALSE,
    free_ok: integer,
    offset_freed: integer,
    pages_freed: integer,
    table_seg: integer,
    osv$page_size: integer,
    zzz_first_index_to_free: integer,
    zzz_last_index_to_free: integer;

{!! end test harness version}

*else
*copyc osp$clear_mainframe_sig_lock
*copyc osp$fatal_system_error
*copyc osp$system_error
*copyc osp$set_mainframe_sig_lock

*copyc osv$page_size
*ifend
?? OLDTITLE ??
?? NEWTITLE := 'FDE Initialization value', EJECT ??
{
{ The following table defines the initial value of a newly assigned FDE. Callers
{ of gfp$assign_fde may depend on values defined in this table. Values in the table
{ specified as "*" normally are filled in by the caller.
{
{


?? FMT (FORMAT := OFF) ??

  VAR
    initial_fde_entry: [READ, oss$mainframe_paged_literal] gft$file_descriptor_entry :=

         [*,                                      {job_lock - not locked
          [FALSE, 0],                             {monitor_interlock
          [FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE], {flags}
 {*}      [0, osc$cyber_180_model_unknown, 1980, 1, 1, 0, 0, 0, 0, 0], {global_file_name
          NIL,                                    {file hash thread
          0,                                      {attached_in_write_count
          0,                                      {attach_count
          0,                                      {open_count
          gfc$fk_unnamed_file,                    {file_kind
          *, {Random 1 .. 250}                    {file_hash
          [0, FALSE, [0, 0]],                     {segment_lock
          0,                                      {asti
          0,                                      {eoi_byte_address
          mmc$eoi_rounded,                        {eoi_state
          16384,                                  {allocation_unit_size
          16384,                                  {transfer_unit_size
          7fffffff(16),                           {file_limit  (!! is this right)
          gfc$qs_job_working_set,                 {queue_status
          0,                                      {queue_ordinal
          pmc$initialize_to_zero,                 {preset_value
          0,                                      {time last modified
          0,                                      {last_segment_number
          [0, 0],                                 {global_task_id
          0,                                      {stack_for_ring
          gfc$fm_transient_segment];              {media


?? FMT (FORMAT := ON) ??

?? OLDTITLE ??
?? NEWTITLE := 'BUILT-IN LIKE FUNCTIONS - min, max', EJECT ??

  FUNCTION [INLINE] max
    (    i: integer;
         j: integer): integer;

    IF i > j THEN
      max := i;
    ELSE
      max := j;
    IFEND;

  FUNCEND max;
?? SKIP := 4 ??

  FUNCTION [INLINE] min
    (    i: integer;
         j: integer): integer;

    IF i < j THEN
      min := i;
    ELSE
      min := j;
    IFEND;

  FUNCEND min;
?? OLDTITLE ??
?? NEWTITLE := 'free_unused_pages', EJECT ??
{
{ This routine is called to free pages assigned to file descriptors that have been freed.
{ Since file descriptors reside in wired/fixed memory, aging will never free the
{ unused pages; the only way pages get freed is to explicitly issue a MMP$FREE_PAGES
{ request to free them.
{

  PROCEDURE [INLINE] free_unused_pages
    (    control_p: ^gft$file_descriptor_control;
         free_word_index: 0 .. 1023);

    VAR
      address_to_free: ^cell,
      b64: bool64,
      end_page: integer,
      first_fde_index_to_free: gft$file_descriptor_index,
      last_fde_index_to_free: gft$file_descriptor_index,
      low_bit_index: integer,
      low_word_index: integer,
      high_bit_index: integer,
      high_word_index: integer,
      max_words_to_search: integer,
      pages_to_free: integer,
      start_page: integer,
      status: ost$status,
      stop: integer,
      word: integer,
      words_p: ^array [0 .. gfc$max_level_2_index] of integer;


{ Calculate number of IN_USE words to search for free entries. The maximum number is
{ determined by the page size and FDE size. It is necessary to search multiple words because
{ more than 64 FDEs may fit in a word.

    max_words_to_search := ((osv$page_size DIV gfc$fde_size) DIV 64) + 1;


{ Calculate the FDE index of the last FDE entry that is in use that has
{ an FDE.INDEX lower than the one just freed. Make sure not to run off the bottom
{ of the array. Terminate the search after checking a few words worth of bits;
{ exact number determined by <max_words_to_search>. Theres no since freeing
{ pages that have already been freed. NOTE: there's no tricky way to find the last "1"
{ bit in a word; keep shifting the word right until it is ODD.

    words_p := #LOC (control_p^.in_use);
    low_word_index := free_word_index - 1;
    stop := max (0, free_word_index - max_words_to_search + 1);
    WHILE (low_word_index >= stop) AND (words_p^ [low_word_index] = 0) DO
      low_word_index := low_word_index - 1;
    WHILEND;
    low_bit_index := 64;
    IF low_word_index >= stop THEN
      word := words_p^ [low_word_index];
      WHILE #SHIFT (#SHIFT (word, -1), 1) = word DO
        word := #SHIFT (word, -1);
        low_bit_index := low_bit_index - 1;
      WHILEND;
    IFEND;
    first_fde_index_to_free := low_bit_index + low_word_index * 64;


{ Calculate the FDE index of the first FDE entry that is in use that has
{ and FDE.INDEX higher than the one just freed. Make sure not to run off the top
{ of the array. Terminate the search after checking a few words worth of bits;
{ exact number determined by <max_words_to_search>.

    high_word_index := free_word_index + 1;
    stop := min (UPPERBOUND (words_p^), free_word_index + max_words_to_search - 1);
    WHILE (high_word_index <= stop) AND (words_p^ [high_word_index] = 0) DO
      high_word_index := high_word_index + 1;
    WHILEND;
    IF high_word_index > stop THEN
      high_bit_index := 0;
    ELSE
      word := -(words_p^ [high_word_index] + 1);
      #UNCHECKED_CONVERSION (word, b64);
      high_bit_index := find_zero_bit (b64);
    IFEND;
    last_fde_index_to_free := high_bit_index + high_word_index * 64 - 1;


{ Calculate addresses to be freed. Round starting and ending address to page boundaries.
{ Dont actually issue the monitor request to free pages unless there are really pages
{ to be freed.

    start_page := gfc$fde_size * first_fde_index_to_free;
    start_page := (start_page + osv$page_size - 1) DIV osv$page_size;

    end_page := gfc$fde_size * (last_fde_index_to_free + 1);
    end_page := end_page DIV osv$page_size;

    pages_to_free := end_page - start_page;

*if $variable(gfc$test_harness declared) <> 'UNKNOWN'
    {!!! start test harness code}
    IF verify_free_entries THEN
      IF words_p^ [free_word_index] <> 0 THEN
        i#program_error;
      IFEND;
      IF zzz_first_index_to_free <> first_fde_index_to_free THEN
        i#program_error;
      IFEND;
      IF zzz_last_index_to_free <> last_fde_index_to_free THEN
        i#program_error;
      IFEND;
      pages_freed := pages_to_free;
      offset_freed := start_page * osv$page_size;
    IFEND;

    pages_to_free := 0; {!!! dont actually issue the mmp$free_pages request}
    {!!! end test harness code
*ifend

    IF pages_to_free > 0 THEN
      address_to_free := #ADDRESS (1, #SEGMENT (control_p), gfc$fde_table_base + start_page * osv$page_size);
      mmp$free_pages (address_to_free, pages_to_free * osv$page_size, osc$wait, status);
    IFEND;

  PROCEND free_unused_pages;
?? OLDTITLE ??
?? TITLE := 'find_zero_bit', EJECT ??
{
{ This tricky little routine returns the bit number of the first "zero" bit in a 64-bit word
{ (or in this case a packed array of 64 booleans). The algorithm uses trick CYBIL code to convert
{ the word to an integer, then convert the integer to a REAL. The exponent portion of
{ the REAL gives the bit number of the first "zero" bit.


  FUNCTION [INLINE] find_zero_bit
    (    s64: bool64): 0 .. 63;

    VAR
      int: integer,
      r: real,
      trick: record
        case boolean of
        = FALSE =
          int: integer,
        = TRUE =
          fill: 0 .. 255,
          bit: 0 .. 255,
        casend,
      recend,
      zero_bit: integer;


{ If the integer is positive, then the first zero bit must be bit 0.

    #UNCHECKED_CONVERSION (s64, int);
    IF int >= 0 THEN
      zero_bit := 0;

{ Otherwise, convert the integer to REAL and get the bit number from the exponent. Note that the bits
{ in the integer are complemented ((-int-1) changes 1's to 0's and 0's to 1's) before converting to
{ real because the exponent actually give the first "one" bit.

    ELSE
      r := $REAL (-int - 1);
      #UNCHECKED_CONVERSION (r, trick.int);
      zero_bit := 64 - trick.bit;
    IFEND;

    find_zero_bit := zero_bit;

  FUNCEND find_zero_bit;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] gfp$assign_fde', EJECT ??

*copyc gfh$assign_fde

  PROCEDURE [XDCL] gfp$assign_fde
    (    residence: gft$table_residence;
         segment_number: ost$segment;
     VAR sfid: gft$system_file_identifier;
     VAR fde_p: gft$file_desc_entry_p);

    VAR
      control_p: ^gft$file_descriptor_control,
      file_entry_index: gft$file_descriptor_index,
      level1: 0 .. 63,
      level2: 0 .. 63,
      seg: ost$segment,
      trick_int: integer,
      zinuse: 0 .. 63;


{ Get a pointer to the control structures for the FDEs. This pointer may be either
{ a pointer to job fixed or to mainframe wired.

    IF residence = gfc$tr_job THEN
      seg := osc$segnum_job_fixed_heap;
    ELSEIF residence = gfc$tr_system THEN
      seg := osc$segnum_mainframe_wired;
    ELSE
      seg := segment_number;
    IFEND;

    control_p := #ADDRESS (1, seg, gfc$fde_control_table_base);


{ Lock the tables to prevent other users from assigning FDEs.

    osp$set_mainframe_sig_lock (control_p^.lock);


{ Scan the level 1 index to find the first level 2 table that has free entries.

    level1 := find_zero_bit (control_p^.index1);


{ If the level 1 index is greater than 15, then tables are full. (Although the table structure will support
{ more entries, it would require an SFID.INDEX > 65K. This breaks compatibility).

    IF level1 > 15 THEN
      fde_p := NIL;
    ELSE

{ Scan reset of the indices to find the index of the FDE to be assigned.

      level2 := find_zero_bit (control_p^.index2 [level1]);
      zinuse := find_zero_bit (control_p^.in_use [level2 + 64 * level1]);


{ Mark the entry as assigned. If the array entry containing the IN_USE bit for the entry just assigned
{ is full (all entries in the block assigned), mark the level 2 index as full. If the array entry
{ containing the level 2 bit is full, mark the level 1 table as full.

      control_p^.in_use [level2 + 64 * level1] [zinuse] := TRUE;

      #UNCHECKED_CONVERSION (control_p^.in_use [level2 + 64 * level1], trick_int);
      IF trick_int = -1 THEN
        control_p^.index2 [level1] [level2] := TRUE;
        #UNCHECKED_CONVERSION (control_p^.index2 [level1], trick_int);
        IF trick_int = -1 THEN
          control_p^.index1 [level1] := TRUE;
        IFEND;
      IFEND;


{ Create the SFID  and FDE_P for the entry just assigned. Note that the hash field must be initialized by the
{ caller.

      file_entry_index := ((level1 * 64) + level2) * 64 + zinuse;
      sfid.file_entry_index := file_entry_index;
      IF residence = gfc$tr_system THEN
        sfid.residence := gfc$tr_system;
      ELSE
        sfid.residence := gfc$tr_job;
      IFEND;
      fde_p := #ADDRESS (1, #SEGMENT (control_p), gfc$fde_table_base + gfc$fde_size * file_entry_index);


{ Initialize the table entry with the default FDE value.

      fde_p^ := initial_fde_entry;
      fde_p^.file_hash := (#free_running_clock (0) MOD 249) + 1;
      sfid.file_hash := fde_p^.file_hash;
    IFEND;

    osp$clear_mainframe_sig_lock (control_p^.lock);

  PROCEND gfp$assign_fde;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] gfp$free_fde', EJECT ??

*copyc gfh$free_fde

  PROCEDURE [XDCL] gfp$free_fde
    (    fde_p: gft$file_desc_entry_p;
         sfid:  gft$system_file_identifier);

    VAR
      control_p: ^gft$file_descriptor_control,
      gtid_int: integer,
      i: gft$file_descriptor_index,
      identifier: ost$status_identifier,
      int: integer,
      l: integer,
      level1: 0 .. 63,
      level2: 0 .. 63,
      log_Status: ost$status,
      logtime: ost$time,
      number: ost$status_condition_number,
      s: string(60),
      xcb_p: ^ost$execution_control_block,
      zinuse: 0 .. 63;


{ Verify that the FDE_P is valid.

    IF (#SEGMENT (fde_p) <> 1) AND (#SEGMENT (fde_p) <> 3) THEN
      osp$system_error ('GF - Bad FDE_P on FREE', NIL);
    IFEND;
    int := (#OFFSET (fde_p) - gfc$fde_table_base) DIV gfc$fde_size;
    IF (int < 0) OR (int > 65535) OR ((int * gfc$fde_size + gfc$fde_table_base) <> #OFFSET (fde_p)) THEN
      osp$system_error ('GF - Bad FDE_P on FREE', NIL);
    IFEND;
    IF fde_p^.job_lock.locked THEN
      osp$system_error ('GF - freed locked FDE', NIL);
    IFEND;
    IF fde_p^.asti <> 0 THEN
      osp$system_error ('GF - freed FDE with asti <> 0', NIL);
    IFEND;


{ Calculate the indexes to the index levels.

    i := (#OFFSET (fde_p) - gfc$fde_table_base) DIV gfc$fde_size;
    zinuse := i MOD 64;
    i := i DIV 64;
    level2 := i MOD 64;
    i := i DIV 64;
    level1 := i MOD 64;


{ Halt if we attempt to free an FDE with an open_count > 0.

    IF fde_p^.open_count > 0 THEN
      IF sfid.residence = gfc$tr_job THEN
       identifier := 'DM';
       number := 0;
       STRINGREP (s, l, ' DM: DISCARDING A FILE WITH OPEN COUNT > 0 ',
         fde_p, ' ', identifier, number);
       lgp$add_entry_to_system_log (pmc$msg_origin_system, s, logtime, log_status);

       dpp$put_critical_message (s, log_status);
       ELSE
       osp$system_error ('GF - open_count > 0 during FREE_FDE', NIL);
       IFEND;
    IFEND;

{ Get a pointer to the control structures for the FDEs. This pointer may be either
{ a pointer to job fixed or to mainframe wired.

    control_p := #ADDRESS (1, #SEGMENT (fde_p), gfc$fde_control_table_base);


{ Lock the tables to prevent other users from assigning FDEs.

    osp$set_mainframe_sig_lock (control_p^.lock);


{ Set each index level to indicate free entries. Its faster to mark each level to
{ show free entries than to actually check

    control_p^.in_use [level2 + 64 * level1] [zinuse] := FALSE;
    control_p^.index2 [level1] [level2] := FALSE;
    control_p^.index1 [level1] := FALSE;


{ Change the file hash in the FDE being freed to cause errors if an attempt is made to
{ reference the entry again. NOTE that the job_lock is not cleared and will contain the GTID
{ of the task that freed the entry until the entry is reused.

    fde_p^.file_hash := gfc$null_file_hash;


{ If the word containing the 'in_use' bit for the entry just freed is all zeros, attempt to
{ free unused pages.

    #UNCHECKED_CONVERSION (control_p^.in_use [level2 + 64 * level1], int);
    IF int = 0 THEN
      free_unused_pages (control_p, level2 + 64 * level1);
    IFEND;

    osp$clear_mainframe_sig_lock (control_p^.lock);

  PROCEND gfp$free_fde;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] gfp$initialize', EJECT ??
{
{ This procedure should be called earily in deadstart. The primary function of this call is to
{ verify that compile time constants are correct. CYBIL does not have the language
{ constructs that would allow this type of checking to be done at compile time.
{ If constants are incorrect, deadstart is aborted with a nice message.
{

  PROCEDURE [XDCL] gfp$initialize;

    IF #SIZE (gft$file_descriptor_entry) > gfc$fde_size THEN
      osp$fatal_system_error ('GF - FDE size is incorrect', NIL);
    IFEND;

  PROCEND gfp$initialize;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] gfp$reassign_fde', EJECT ??

*copyc gfh$reassign_fde

  PROCEDURE [XDCL] gfp$reassign_fde
    (    sfid: gft$system_file_identifier;
         old_fde_p: gft$file_desc_entry_p);

    VAR
      control_p: ^gft$file_descriptor_control,
      fde_p: gft$file_desc_entry_p,
      ignore_status: ost$status;


{ Get a pointer to the control structures for the job FDEs.

    control_p := #ADDRESS (1, osc$segnum_job_fixed_heap, gfc$fde_control_table_base);


{ Validate the SFID. (Note: code doesn't currently set level1 or level2 indexes as INUSE so don't allow
{ file_entry_index > 62).

    IF (sfid.residence <> gfc$tr_job) OR (sfid.file_entry_index > 62) THEN
      osp$system_error ('GF - invalid SFID on recreate', NIL);
    IFEND;

{ If the fde entry is already in use, verify that it is for a previous open of the file.
{ If an asti is already assigned, hang the job.  Some unexpected condition has occurred.
{ If disk space has already been assigned, hang the job if this is not the same file.

    IF control_p^.in_use_bits [sfid.file_entry_index] THEN
      fde_p := #ADDRESS (1, #SEGMENT (control_p), gfc$fde_table_base + gfc$fde_size * sfid.file_entry_index);
      IF (fde_p^.asti <> 0) THEN
        osp$system_error ('Bad clone--asti assigned.', NIL);
      ELSEIF fde_p^.media <> gfc$fm_transient_segment THEN
        IF (old_fde_p^.global_file_name <> fde_p^.global_file_name) THEN
          osp$system_error ('Bad clone--fde in use.', NIL);
        ELSE

{ Disk space has already been assigned for this file; the segment is open more than once.

          RETURN;
        IFEND;
      IFEND;
    ELSE {fde not in use yet

{ Mark the entry as 'INUSE'.

      control_p^.in_use_bits [sfid.file_entry_index] := TRUE;
      fde_p := #ADDRESS (1, #SEGMENT (control_p), gfc$fde_table_base + gfc$fde_size * sfid.file_entry_index);
    IFEND;


{ Initialize the table entry with the default FDE value.

      fde_p^ := old_fde_p^;
      fde_p^.media := gfc$fm_transient_segment;
      fde_p^.eoi_byte_address := 0;
      fde_p^.asti := 0;
      IF fde_p^.file_kind = gfc$fk_job_local_file THEN
        mmp$assign_mass_storage (0, sfid, 0, ignore_status);
      IFEND;

  PROCEND gfp$reassign_fde;

?? OLDTITLE ??

*if $variable(gfc$test_harness declared) <> 'UNKNOWN'
?? NEWTITLE := 'TEST HARNESS', EJECT ??

  PROCEDURE error
    (    i: integer;
         sfid: gft$system_file_identifier);

    VAR
      s: string (80),
      status: ost$status,
      sl: integer;

    STRINGREP (s, sl, 'Expected ', i, ', found ', sfid.file_entry_index);
    clp$put_job_output (s (1, sl), status);
    i#program_error;

  PROCEND error;

  VAR
    fde_p: array [0 .. 66000] of gft$locked_file_desc_entry_p;

  PROGRAM gfp$test_table_manager
    (    params: SEQ ( * );
     VAR status: ost$status);

    VAR
      bits_p: ^packed array [0 .. 65535] of boolean,
      control_p: ^gft$file_descriptor_control,
      word_p: ^array [0 .. 1100] of integer,
      max_words_to_search: integer,
      residence: gft$table_residence,
      p: amt$segment_pointer,
      sfid: gft$system_file_identifier,
      scr_fde_p: gft$locked_file_desc_entry_p,
      low_index,
      high_index,
      free_index,
      stop,
      i,
      j,
      k,
      index: integer;


    osv$page_size := 4096;
    gfp$initialize;
    mmp$create_scratch_segment (amc$cell_pointer, mmc$as_random, p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    table_seg := #SEGMENT (p.cell_pointer);
    control_p := #ADDRESS (1, table_seg, gfc$fde_control_table_base);

    FOR j := 1 TO 4 DO
      FOR i := 0 TO 65535 DO
        gfp$assign_fde (gfc$tr_job, sfid, fde_p [i]);
        IF (sfid.file_entry_index <> i) OR (fde_p [i] = NIL) THEN
          error (i, sfid);
        IFEND;
      FOREND;

      gfp$assign_fde (gfc$tr_job, sfid, scr_fde_p);
      IF scr_fde_p <> NIL THEN
        error (0, sfid);
      IFEND;

      scr_fde_p := fde_p [12345];
      gfp$free_fde (scr_fde_p);
      gfp$assign_fde (gfc$tr_job, sfid, scr_fde_p);

      IF (sfid.file_entry_index <> 12345) OR (scr_fde_p <> fde_p [12345]) THEN
        error (12345, sfid);
      IFEND;

      FOR i := 1 TO 100000 DO
        k := #FREE_RUNNING_CLOCK (0) MOD 65536;
        scr_fde_p := fde_p [k];
        gfp$free_fde (scr_fde_p);
        gfp$assign_fde (gfc$tr_job, sfid, scr_fde_p);
        IF (sfid.file_entry_index <> k) OR (scr_fde_p <> fde_p [k]) THEN
          error (k, sfid);
        IFEND;
        gfp$assign_fde (gfc$tr_job, sfid, scr_fde_p);
        IF scr_fde_p <> NIL THEN
          error (0, sfid);
        IFEND;
      FOREND;

      IF j = 2 THEN
        FOR i := 65535 DOWNTO 0 DO
          gfp$free_fde (fde_p [i]);
        FOREND;
      ELSE
        FOR i := 0 TO 65535 DO
          gfp$free_fde (fde_p [i]);
        FOREND;
      IFEND;
    FOREND;

    max_words_to_search := ((osv$page_size DIV gfc$fde_size) DIV 64) + 1;
    bits_p := #LOC (control_p^.in_use);
    word_p := #LOC (control_p^.in_use);
    low_index := 0;
    verify_free_entries := TRUE;
    REPEAT
      free_index := ((low_index + 63) DIV 64) * 64;
      FOR k := 0 TO max_words_to_search DO
        high_index := min (65535, free_index + k * 64 + 64 * (max_words_to_search + 1));
        stop := min (65536, free_index + k * 64 + 64);
        WHILE high_index >= stop DO
          test_free (control_p, low_index, free_index + k * 64, high_index, max_words_to_search);
          bits_p^ [high_index] := TRUE;
          high_index := high_index - 1;
        WHILEND;
        j := stop DIV 64;
        FOR i := j TO j + max_words_to_search + 1 DO
          word_p^ [i] := 0;
        FOREND;
      FOREND;
      IF low_index = 2000 THEN {test end points only
        low_index := 60000;
      IFEND;
      bits_p^ [low_index] := TRUE;
      low_index := low_index + 1;
    UNTIL low_index = 65536 - 64;

  PROCEND gfp$test_table_manager;

  PROCEDURE [INLINE] test_free
    (    p: ^cell;
         low_index,
         free_index,
         high_index,
         max_words_to_search: integer);

    VAR
      status: ost$status,
      s: string (100),
      sl: integer;

    zzz_first_index_to_free := max (low_index, (free_index DIV 64) * 64 - (max_words_to_search - 1) * 64);
    zzz_last_index_to_free := min (high_index, (free_index DIV 64) * 64 + max_words_to_search * 64 - 1);

    free_unused_pages (p, free_index DIV 64);
    free_ok := free_ok + 1;

  PROCEND test_free;

?? OLDTITLE ??
*ifend
MODEND gfm$file_table_manager
*DECK DECK=GFP$ASSIGN_FDE EXPAND=FALSE


     PROCEDURE [XREF] gfp$assign_fde
       (    residence: gft$table_residence;
            segment_number: ost$segment;
        VAR sfid: gft$system_file_identifier;
        VAR fde_p: gft$file_desc_entry_p);

?? PUSH (LISTEXT := ON) ??
*copyc gft$file_desc_entry_p
*copyc gft$system_file_identifier
*copyc osd$virtual_address
?? POP ??
*DECK DECK=GFP$CLEAR_SIGNATURE_LOCK EXPAND=FALSE
  PROCEDURE [INLINE] gfp$clear_signature_lock
    (VAR lock: gft$signature_lock);

?? PUSH (LISTEXT := ON) ??

      VAR
        task_id: ost$global_task_id,
        xcb_p: ^ost$execution_control_block;

      xcb_p := #ADDRESS (1, osc$segnum_job_fixed_heap,
            #READ_REGISTER (osc$pr_base_constant));
      task_id := xcb_p^.global_task_id;

      IF lock.gtid <> task_id THEN
        osp$system_error ('GF - FDE not locked', NIL);
      IFEND;

      IF lock.count > 0 THEN
        lock.count := lock.count - 1;
      ELSE
        lock.gtid.seqno := 0;
        #spoil (lock);
        lock.locked := FALSE;
        xcb_p^.system_table_lock_count := xcb_p^.system_table_lock_count - 256;

        IF xcb_p^.stlc_allocation AND (xcb_p^.system_table_lock_count < 256) THEN
          xcb_p^.stlc_allocation := FALSE;
          osp$mfh_for_segment_manager;
        IFEND;

        IF (xcb_p^.system_table_lock_count <= 0) AND (xcb_p^.system_give_up_cpu) THEN
          syp$cycle_for_lock (tmc$cyc_clear_sys_lock, #LOC (lock));
        IFEND;
      IFEND;

  PROCEND gfp$clear_signature_lock;
*copyc gft$signature_lock
*copyc osc$processor_defined_registers
*copyc osp$mfh_for_segment_manager
*copyc ost$execution_control_block
*copyc ost$heap
*copyc osp$system_error
*copyc syp$cycle_for_lock
?? POP ??
*DECK DECK=GFP$FETCH_PAGE_STATUS EXPAND=FALSE

PROCEDURE [XREF] gfp$fetch_page_status
  (    fde_p: gft$locked_file_desc_entry_p;
       offset: ost$segment_offset;
   VAR page_status: gft$page_status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$locked_file_desc_entry_p
*copyc gft$page_status
*copyc ost$hardware_subranges
?? POP ??
*DECK DECK=GFP$FREE_FDE EXPAND=FALSE


   PROCEDURE [XREF] gfp$free_fde
     (    fde_p: gft$file_desc_entry_p;
          sfid: gft$system_file_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc gft$file_desc_entry_p
*copyc gft$system_file_identifier
?? POP ??
*DECK DECK=GFP$GET_EOI_FROM_FDE EXPAND=FALSE

  FUNCTION [UNSAFE, INLINE] gfp$get_eoi_from_fde
     (     fde_p: gft$file_desc_entry_p): amt$file_byte_address;

?? PUSH (LISTEXT := ON) ??
    VAR
      request_block: mmt$rb_set_get_segment_length;

    IF (fde_p^.eoi_state = mmc$eoi_uncertain) OR (fde_p^.stack_for_ring <> 0) THEN
      request_block.request_code := syc$rc_set_get_segment_length;
      request_block.subfunction_code := mmc$sf_get_segment_length_fde_p;
      request_block.fde_p := fde_p;
      i#call_monitor (#loc (request_block), #size (request_block));
      gfp$get_eoi_from_fde := request_block.segment_length;
    ELSE
      gfp$get_eoi_from_fde := fde_p^.eoi_byte_address;
    IFEND;

  FUNCEND gfp$get_eoi_from_fde;

*copyc mmt$rb_set_get_segment_length
*copyc gft$file_desc_entry_p
*copyc i#call_monitor
?? POP ??
*DECK DECK=GFP$GET_FDE_P EXPAND=FALSE

  PROCEDURE [INLINE] gfp$get_fde_p (sfid: gft$system_file_identifier;
    VAR fde_p: gft$file_desc_entry_p);


?? PUSH (LISTEXT := ON) ??
    VAR
      seg: 0 .. 4095;

    seg := 1;
    IF sfid.residence <> gfc$tr_system THEN
      IF sfid.residence = gfc$tr_job THEN
        seg := 3;
      ELSE
        seg := 0;
      IFEND;
    IFEND;
    fde_p := #address (1, seg, gfc$fde_table_base + gfc$fde_size * sfid.file_entry_index);
    IF (seg = 0) OR (sfid.file_hash <> fde_p^.file_hash) THEN
      fde_p := NIL;
    IFEND;

  PROCEND gfp$get_fde_p;

*copyc gfc$constants
*copyc gft$file_desc_entry_p
*copyc gft$file_descriptor_index
*copyc gft$system_file_identifier
?? POP ??
*DECK DECK=GFP$GET_FDE_P_FROM_IMAGE EXPAND=FALSE

  PROCEDURE [INLINE] gfp$get_fde_p_from_image
    (    sfid: gft$system_file_identifier;
         image_segment_number: ost$segment;
     VAR fde_p: gft$file_desc_entry_p);

?? PUSH (LISTEXT := ON) ??
    VAR
      offset: integer;


{ WARNING: This procedure does NOT check file_hash!
{ Locking the FDE is not necessary, because recovery occurs on a system which
{ has only one active task.

    IF sfid.residence <> gfc$tr_system THEN
      fde_p := NIL;
    ELSE
      offset := gfc$fde_table_base + gfc$fde_size * sfid.file_entry_index;
      fde_p := #address (1, image_segment_number, offset);
    IFEND;

  PROCEND gfp$get_fde_p_from_image;

*copyc gfc$constants
*copyc gft$file_desc_entry_p
*copyc gft$system_file_identifier
*copyc osd$virtual_address
?? POP ??
*DECK DECK=GFP$GET_LOCKED_FDE_P EXPAND=FALSE

  PROCEDURE [INLINE] gfp$get_locked_fde_p (sfid: gft$system_file_identifier;
    VAR fde_p: gft$file_desc_entry_p);


?? PUSH (LISTEXT := ON) ??

   gfp$get_fde_p (sfid, fde_p);
   IF fde_p <> NIL THEN
     gfp$set_signature_lock (fde_p^.job_lock);
   IFEND;

  PROCEND gfp$get_locked_fde_p;


*copyc gfp$get_fde_p
*copyc gfp$set_signature_lock
*copyc gft$file_desc_entry_p
*copyc gft$locked_file_desc_entry_p
*copyc gft$system_file_identifier
?? POP ??
*DECK DECK=GFP$GET_SEGMENT_SFID EXPAND=FALSE

  PROCEDURE [INLINE] gfp$get_segment_sfid
    (    pva: ^cell;
     VAR sfid: gft$system_file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
    VAR
      sdte_p: ^mmt$segment_descriptor,
      sdtxe_p: ^mmt$segment_descriptor_extended,
      segment_number: ost$segment,
      xcb_p: ^ost$execution_control_block;


    status.normal := TRUE;
    segment_number := #segment (pva);
    pmp$find_executing_task_xcb (xcb_p);

    IF segment_number > xcb_p^.xp.segment_table_length THEN
      IF segment_number > 4095 THEN
        osp$set_status_abnormal ('MM', mme$segment_number_too_big, '', status);
      ELSE
        osp$set_status_abnormal ('MM', mme$segment_number_not_in_use, '', status);
      IFEND;
      RETURN;
    IFEND;

    sdte_p := mmp$get_sdt_entry_p (xcb_p, segment_number);
    IF sdte_p^.ste.vl = osc$vl_invalid_entry THEN
      osp$set_status_abnormal ('MM', mme$segment_number_not_in_use, '', status);
      RETURN;
    IFEND;

    sdtxe_p := mmp$get_sdtx_entry_p (xcb_p, segment_number);
    sfid := sdtxe_p^.sfid;

  PROCEND gfp$get_segment_sfid;

*copyc gft$system_file_identifier
*copyc mme$condition_codes
*copyc mmp$get_sdt_entry_p
*copyc mmp$get_sdtx_entry_p
*copyc osd$virtual_address
*copyc osp$set_status_abnormal
*copyc ost$execution_control_block
*copyc ost$status
*copyc pmp$find_executing_task_xcb
?? POP ??
*DECK DECK=GFP$GET_SFID_FROM_FDE_P EXPAND=FALSE

  PROCEDURE [INLINE] gfp$get_sfid_from_fde_p
    (    fde_p: gft$locked_file_desc_entry_p;
     VAR sfid: gft$system_file_identifier);

?? PUSH (LISTEXT := ON) ??
    VAR
      segnum: ost$segment,
      xsfid: gft$system_file_identifier;

    xsfid.file_hash := fde_p^.file_hash;
    xsfid.file_entry_index := ((#OFFSET (fde_p)) - gfc$fde_table_base) DIV gfc$fde_size;
    segnum := #SEGMENT (fde_p);
    IF segnum = 1 THEN
      xsfid.residence := gfc$tr_system;
    ELSE
      xsfid.residence := gfc$tr_job;
    IFEND;

    sfid := xsfid;

  PROCEND gfp$get_sfid_from_fde_p;

*copyc osd$virtual_address
?? POP ??
*DECK DECK=GFP$LOCK_FDE EXPAND=FALSE


  PROCEDURE [INLINE] gfp$lock_fde (fde_p: gft$file_desc_entry_p);


?? PUSH (LISTEXT := ON) ??

   gfp$set_signature_lock (fde_p^.job_lock);
  PROCEND gfp$lock_fde;


*copyc gfp$set_signature_lock
*copyc gft$file_desc_entry_p
?? POP ??
*DECK DECK=GFP$MTR_CONVERT_JOB_MODE_FDE_P EXPAND=FALSE

  FUNCTION [INLINE] gfp$mtr_convert_job_mode_fde_p (xfde_p: gft$file_desc_entry_p;
        cst_p: ^ost$cpu_state_table): gft$file_desc_entry_p;
?? PUSH (LISTEXT := ON) ??
    VAR
      fde_p: gft$file_desc_entry_p;

    fde_p := xfde_p;
    IF #segment (fde_p) <> 1 THEN
      fde_p := #address (1, #segment (cst_p^.xcb_p), #offset (fde_p));
    IFEND;
    gfp$mtr_convert_job_mode_fde_p := fde_p;

  FUNCEND gfp$mtr_convert_job_mode_fde_p;
?? POP ??
*DECK DECK=GFP$MTR_GET_FDE_P EXPAND=FALSE

  PROCEDURE [INLINE] gfp$mtr_get_fde_p (sfid: gft$system_file_identifier;
        ijle_p: ^jmt$initiated_job_list_entry;
    VAR fde_p: gft$file_desc_entry_p);


?? PUSH (LISTEXT := ON) ??
    VAR
      hash: integer,
      seg: 0 .. 4095,
      offset: integer,
      residence: gft$table_residence;

    residence := sfid.residence;
    hash := sfid.file_hash;
    offset := gfc$fde_table_base + gfc$fde_size * sfid.file_entry_index;
    seg := 1;
    IF residence <> gfc$tr_system THEN
      IF residence = gfc$tr_job THEN
        seg := ijle_p^.ajl_ordinal + mtc$job_fixed_segment;
      ELSE
        hash := 4096;      {Force mismatch on HASH to cause error}
        offset := 4096;    {There is always a valid page at this address}
      IFEND;
    IFEND;
    fde_p := #address (1, seg, offset);
    IF sfid.file_hash <> fde_p^.file_hash THEN
      i#program_error;
    IFEND;

  PROCEND gfp$mtr_get_fde_p;

*copyc gfc$constants
*copyc gft$file_desc_entry_p
*copyc gft$file_descriptor_index
*copyc gft$system_file_identifier
*copyc i#program_error
*copyc jmt$initiated_job_list_entry
*copyc mtc$job_fixed_segment
?? POP ??
*DECK DECK=GFP$MTR_GET_LOCKED_FDE_P EXPAND=FALSE

  PROCEDURE [INLINE] gfp$mtr_get_locked_fde_p (sfid: gft$system_file_identifier;
        ijle_p: ^jmt$initiated_job_list_entry;
    VAR fde_p: gft$locked_file_desc_entry_p);


?? PUSH (LISTEXT := ON) ??

   gfp$mtr_get_fde_p (sfid, ijle_p, fde_p);
   IF gfc$monitor_interlocks THEN
     mtp$set_interlock (fde_p^.monitor_lock);
   IFEND;

  PROCEND gfp$mtr_get_locked_fde_p;


*copyc gfc$monitor_interlocks
*copyc gfp$mtr_get_fde_p
*copyc gft$locked_file_desc_entry_p
*copyc gft$system_file_identifier
*copyc jmt$initiated_job_list_entry
*copyc mtp$set_interlock
?? POP ??
*DECK DECK=GFP$MTR_GET_SFID_FROM_FDE_P EXPAND=FALSE

  PROCEDURE [INLINE] gfp$mtr_get_sfid_from_fde_p
    (    fde_p: gft$locked_file_desc_entry_p;
     VAR sfid: gft$system_file_identifier;
     VAR ijl_ordinal: jmt$ijl_ordinal);
?? PUSH (LISTEXT := ON) ??
    VAR
      segnum: ost$segment,
      xijl_ordinal: jmt$ijl_ordinal,
      xsfid: gft$system_file_identifier;

    xsfid.file_hash := fde_p^.file_hash;
    xsfid.file_entry_index := ((#OFFSET (fde_p)) - gfc$fde_table_base) DIV gfc$fde_size;
    segnum := #SEGMENT (fde_p);
    IF segnum = 1 THEN
      xsfid.residence := gfc$tr_system;
      xijl_ordinal := jmv$null_ijl_ordinal;
    ELSE
      xsfid.residence := gfc$tr_job;
      xijl_ordinal := jmv$ajl_p^ [segnum - mtc$job_fixed_segment].ijl_ordinal;
    IFEND;

    sfid := xsfid;
    ijl_ordinal := xijl_ordinal;

  PROCEND gfp$mtr_get_sfid_from_fde_p;

*copyc jmv$null_ijl_ordinal
*copyc jmv$ajl_p
?? POP ??

*DECK DECK=GFP$MTR_SCAN_ALL_FDES EXPAND=FALSE
  PROCEDURE [INLINE] gfp$mtr_scan_all_fdes
    (    residence: gft$table_residence;
         ijle_p: ^jmt$initiated_job_list_entry;
     VAR state: gft$scan_all_fdes_state;
     VAR fde_p: gft$file_desc_entry_p);

?? PUSH (LISTEXT := ON) ??
   VAR
     index: integer,
     rma: integer,
     seg: integer;
{!!!!#### use new CYBIL intrinsic when upgrade to 1.88.20
   IF residence <> gfc$tr_null_residence THEN
     IF residence = gfc$tr_system THEN
       state.control_p := #ADDRESS (1, osc$segnum_mainframe_wired, gfc$fde_control_table_base);
     ELSE
       state.control_p := #ADDRESS (1, ijle_p^.ajl_ordinal + mtc$job_fixed_segment,
           gfc$fde_control_table_base);
     IFEND;
     index := UPPERBOUND (state.control_p^.in_use_words);
     i#real_memory_address (#LOC (state.control_p^.in_use_words [index]), rma);
     WHILE (rma < 0) OR (state.control_p^.in_use_words [index] = 0) DO
       index := index - 1;
       i#real_memory_address (#LOC (state.control_p^.in_use_words [index]), rma);
     WHILEND;
     state.current_index := index * 64 + 64;
   IFEND;

   index := state.current_index;
   REPEAT
     index := index - 1;
   UNTIL  (index < 0) OR state.control_p^.in_use_bits [index];
   IF index < 0 THEN
     fde_p := NIL;
   ELSE
     seg := #SEGMENT (state.control_p);
     fde_p := #ADDRESS (1, seg, gfc$fde_size * index + gfc$fde_table_base);
     state.current_index := index;
   IFEND;
 PROCEND gfp$mtr_scan_all_fdes;

*copyc gfc$constants
*copyc gft$file_descriptor_control
*copyc gft$file_desc_entry_p
*copyc gft$table_residence
*copyc gft$scan_all_fdes_state
*copyc i#real_memory_address
*copyc jmt$initiated_job_list_entry
*copyc mtc$job_fixed_segment
*copyc ost$heap
?? POP ??
*DECK DECK=GFP$MTR_UNLOCK_FDE_P EXPAND=FALSE

  PROCEDURE [INLINE] gfp$mtr_unlock_fde_p (fde_p: gft$locked_file_desc_entry_p);


?? PUSH (LISTEXT := ON) ??
    IF gfc$monitor_interlocks THEN
      mtp$clear_interlock (fde_p^.monitor_lock);
    IFEND;

  PROCEND gfp$mtr_unlock_fde_p;


*copyc gfc$monitor_interlocks
*copyc gft$locked_file_desc_entry_p
*copyc mtp$clear_interlock
?? POP ??
*DECK DECK=GFP$REASSIGN_FDE EXPAND=FALSE

     PROCEDURE [XREF] gfp$reassign_fde
       (    sfid: gft$system_file_identifier;
            old_fde_p: gft$file_desc_entry_p);

?? PUSH (LISTEXT := ON) ??
*copyc gft$file_desc_entry_p
*copyc gft$system_file_identifier
?? POP ??
*DECK DECK=GFP$SCAN_ALL_FDES EXPAND=FALSE
  PROCEDURE [INLINE] gfp$scan_all_fdes
    (    residence: gft$table_residence;
     VAR state: gft$scan_all_fdes_state;
     VAR fde_p: gft$file_desc_entry_p);

?? PUSH (LISTEXT := ON) ??
   VAR
     index: integer,
     rma: integer,
     seg: integer;
{!!!!#### use new CYBIL intrinsic
   IF residence <> gfc$tr_null_residence THEN
     IF residence = gfc$tr_system THEN
       seg := osc$segnum_mainframe_wired;
     ELSE
       seg := osc$segnum_job_fixed_heap;
     IFEND;
     state.control_p := #ADDRESS (1, seg, gfc$fde_control_table_base);
     index := UPPERBOUND (state.control_p^.in_use_words);
     i#real_memory_address (#LOC (state.control_p^.in_use_words [index]), rma);
     WHILE (rma < 0) OR (state.control_p^.in_use_words [index] = 0) DO
       index := index - 1;
       i#real_memory_address (#LOC (state.control_p^.in_use_words [index]), rma);
     WHILEND;
     state.current_index := index * 64 + 64;
   IFEND;

   index := state.current_index;
   REPEAT
     index := index - 1;
   UNTIL  (index < 0) OR state.control_p^.in_use_bits [index];
   IF index < 0 THEN
     fde_p := NIL;
   ELSE
     seg := #SEGMENT (state.control_p);
     fde_p := #ADDRESS (1, seg, gfc$fde_size * index + gfc$fde_table_base);
     state.current_index := index;
   IFEND;
 PROCEND gfp$scan_all_fdes;

*copyc gfc$constants
*copyc gft$file_descriptor_control
*copyc gft$file_desc_entry_p
*copyc gft$table_residence
*copyc gft$scan_all_fdes_state
*copyc i#real_memory_address
*copyc ost$heap
?? POP ??
*DECK DECK=GFP$SCAN_ALL_FDES_IN_IMAGE EXPAND=FALSE


  PROCEDURE [INLINE] gfp$scan_all_fdes_in_image
    (    image_segment_number: ost$segment;
     VAR state: gft$scan_all_fdes_state;
     VAR fde_p: gft$file_desc_entry_p);

?? PUSH (LISTEXT := ON) ??
   VAR
     index: integer,
     rma: integer,
     seg: integer;

   IF image_segment_number <> 0 THEN
     state.control_p := #ADDRESS (1, image_segment_number, gfc$fde_control_table_base);
     index := UPPERBOUND (state.control_p^.in_use_words);
     WHILE (state.control_p^.in_use_words [index] = 0) DO
       index := index - 1;
     WHILEND;
     state.current_index := index * 64 + 64;
   IFEND;

   index := state.current_index;
   REPEAT
     index := index - 1;
   UNTIL  (index < 0) OR state.control_p^.in_use_bits [index];
   IF index < 0 THEN
     fde_p := NIL;
   ELSE
     seg := #SEGMENT (state.control_p);
     fde_p := #ADDRESS (1, seg, gfc$fde_size * index + gfc$fde_table_base);
     state.current_index := index;
   IFEND;
 PROCEND gfp$scan_all_fdes_in_image;

*copyc gfc$constants
*copyc gft$file_descriptor_control
*copyc gft$file_desc_entry_p
*copyc gft$scan_all_fdes_state
*copyc i#real_memory_address
*copyc ost$heap
?? POP ??
*DECK DECK=GFP$SET_SIGNATURE_LOCK EXPAND=FALSE

  PROCEDURE [INLINE] gfp$set_signature_lock
    (VAR lock: gft$signature_lock);

?? PUSH (LISTEXT := ON) ??

      VAR
        already_locked: boolean,
        cnv: RECORD
          CASE boolean OF
          = FALSE =
            i: integer,
          = TRUE =
            fill: 0 .. 0FFFF(16),
            p: ^cell,
          CASEND,
        RECEND,
        cycle_rb: tmt$rb_cycle,
        task_id: ost$global_task_id,
        xcb_p: ^ost$execution_control_block;

      xcb_p := #ADDRESS (1, osc$segnum_job_fixed_heap,
            #READ_REGISTER (osc$pr_base_constant));
      task_id := xcb_p^.global_task_id;

      IF lock.locked AND (lock.gtid = task_id) THEN
        lock.count := lock.count + 1;
        lock.p_register_2 := #read_register (64);      {!!!### debug code}
      ELSE
        WHILE TRUE DO
          xcb_p^.system_table_lock_count := xcb_p^.system_table_lock_count + 256;
          #TEST_SET (lock.locked, already_locked);
          IF NOT already_locked THEN
            lock.gtid := task_id;
            lock.p_register := #read_register (64);      {!!!### debug code}
            RETURN;
          IFEND;
          xcb_p^.system_table_lock_count := xcb_p^.system_table_lock_count - 256;
          cycle_rb.reqcode := syc$rc_cycle;
          cycle_rb.code := tmc$cyc_set_fde_lock;
          cycle_rb.lock_value := lock.gtid.index * 256 + lock.gtid.seqno;
          cnv.i := #read_register (64);
          cycle_rb.p1 := cnv.p;
          cycle_rb.p2 := #LOC (lock);
          i#call_monitor (#LOC (cycle_rb), #SIZE (cycle_rb));
        WHILEND;
      IFEND;

  PROCEND gfp$set_signature_lock;
*copyc gft$signature_lock
*copyc osc$processor_defined_registers
*copyc ost$execution_control_block
*copyc ost$heap
*copyc osp$system_error
*copyc tmt$rb_cycle
?? POP ??
*DECK DECK=GFP$UNLOCK_FDE_P EXPAND=FALSE

  PROCEDURE [INLINE] gfp$unlock_fde_p (fde_p: gft$locked_file_desc_entry_p);


?? PUSH (LISTEXT := ON) ??
    gfp$clear_signature_lock (fde_p^.job_lock);

  PROCEND gfp$unlock_fde_p;


*copyc gfp$clear_signature_lock
*copyc gft$locked_file_desc_entry_p
?? POP ??
*DECK DECK=GFP$VERIFY_GET_FDE_P EXPAND=FALSE


  PROCEDURE [INLINE] gfp$verify_get_fde_p (sfid: gft$system_file_identifier;
    VAR fde_p: gft$file_desc_entry_p;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    status.normal := TRUE;
    gfp$get_fde_p (sfid, fde_p);
    IF fde_p = NIL THEN
      osp$set_status_condition (dme$invalid_sfid, status);
    IFEND;

  PROCEND gfp$verify_get_fde_p;

*copyc gfp$get_fde_p
*copyc dmt$error_condition_codes
*copyc osp$set_status_condition
*copyc ost$status
?? POP ??
*DECK DECK=GFP$VERIFY_GET_LOCKED_FDE_P EXPAND=FALSE


  PROCEDURE [INLINE] gfp$verify_get_locked_fde_p (sfid: gft$system_file_identifier;
    VAR fde_p: gft$file_desc_entry_p;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

   gfp$verify_get_fde_p (sfid, fde_p, status);
   IF status.normal THEN
     gfp$set_signature_lock (fde_p^.job_lock);
   IFEND;

  PROCEND gfp$verify_get_locked_fde_p;


*copyc gfp$verify_get_fde_p
*copyc gfp$set_signature_lock
*copyc gft$file_desc_entry_p
*copyc gft$system_file_identifier
?? POP ??
*DECK DECK=GFT$ALLOCATION_UNIT_SIZE EXPAND=FALSE

{ Define the maximum allowed size (in bytes) for an allocation unit.

  TYPE
    gft$allocation_unit_size = 0 .. 1000000;
*DECK DECK=GFT$ATTACH_COUNT EXPAND=FALSE

{ Define maximum number of jobs that can have a file attached simultaneously.

  TYPE
    gft$attach_count = 0 .. 65535;

*DECK DECK=GFT$FILE_DESCRIPTOR_CONTROL EXPAND=FALSE

{ The following definition is used to manage the file descriptor entry array.

  TYPE
    gft$file_descriptor_control = RECORD
      lock: ost$signature_lock,
      index1: bool64,
      index2: array [0 .. gfc$max_level_1_index] of bool64,
      CASE 0 .. 2 OF
      = 0 =
        in_use: array [0 .. gfc$max_level_2_index] of bool64,
      = 1 =
        in_use_bits: packed array [0 .. gfc$max_level_2_bit_index] of boolean,
      = 2 =
        in_use_words: array [0 .. gfc$max_level_2_index] of integer,
      CASEND,
    RECEND,

    bool64 = packed array [0 .. 63] of boolean;

  CONST
    gfc$max_level_1_index = 15,
    gfc$max_level_2_index = 1023,
    gfc$max_level_2_bit_index = 65535;



*copyc ost$signature_lock
*DECK DECK=GFT$FILE_DESCRIPTOR_ENTRY EXPAND=FALSE

{ File Decription Table Entry (FDE)
{ NOTE global_file_name may be moved to another table. It will contain an array
{   that define gfn/sfid pairs.

  TYPE
    gft$file_descriptor_entry = RECORD
      job_lock: gft$signature_lock,
      monitor_lock: mtt$monitor_interlock,
      flags: gft$fde_flags,
      global_file_name: ost$binary_unique_name,           {?????}
      file_hash_thread: ^gft$file_descriptor_entry,
      attached_in_write_count: gft$attach_count,
      attach_count: gft$attach_count,
      open_count: gft$open_count,
      file_kind: gft$file_kind,
      file_hash: 0 .. 255,
      segment_lock: gft$segment_lock_info,
      asti: mmt$ast_index,
      eoi_byte_address: amt$file_byte_address,
      eoi_state: mmt$eoi_state,
      allocation_unit_size: gft$allocation_unit_size,
      transfer_unit_size: gft$transfer_unit_size,
      file_limit: amt$file_limit,
      queue_status: gft$queue_status,
      queue_ordinal: mmt$page_frame_queue_id,
      preset_value: pmt$initialization_value,
      time_last_modified: ost$free_running_clock,
      last_segment_number: ost$segment,         { Stack or last reference.
      global_task_id: ost$global_task_id,       { Stack or last GTID that assigned ASID.
      stack_for_ring: 0 .. 15,                  {    used mainly for stack mgmt

      CASE media: gft$file_media OF
      = gfc$fm_mass_storage_file =
        disk_file_descriptor_p: ost$valid_relative_pointer,

      = gfc$fm_served_file =
        served_file_descriptor_p: ost$valid_relative_pointer,

      CASEND,
    RECEND,

    gft$fde_flags = PACKED RECORD
      eoi_modified: boolean,
      wire_eoi_page: boolean,
      active_shadow_file: boolean,
      global_template_file: boolean,
      fde_spare_4: boolean,
      fde_spare_5: boolean,
      fde_spare_6: boolean,
      fde_spare_7: boolean,
    RECEND;

*copyc amt$file_byte_address
*copyc amt$file_limit
*copyc gft$allocation_unit_size
*copyc gft$attach_count
*copyc gft$transfer_unit_size
*copyc gft$file_descriptor_index
*copyc gft$file_kind
*copyc gft$file_media
*copyc gft$signature_lock
*copyc gft$open_count
*copyc gft$queue_status
*copyc gft$segment_lock_info
*copyc gft$transfer_unit_size
*copyc mmt$ast_index
*copyc mmt$eoi_state
*copyc mmt$page_frame_queue_id
*copyc mtt$monitor_interlock
*copyc osd$virtual_address
*copyc ost$binary_unique_name
*copyc ost$free_running_clock
*copyc ost$global_task_id
*copyc ost$signature_lock
*copyc pmt$initialization_value
*DECK DECK=GFT$FILE_DESCRIPTOR_INDEX EXPAND=FALSE

  TYPE
    gft$file_descriptor_index = 0 .. 65535;
*DECK DECK=GFT$FILE_DESC_ENTRY_P EXPAND=FALSE

  TYPE
    gft$file_desc_entry_p = ^gft$file_descriptor_entry;

*copyc gft$file_descriptor_entry
*DECK DECK=GFT$FILE_KIND EXPAND=FALSE

{
{ !!!! WARNING - The order of ordinals in this type CANNOT be changed for file
{                compatibility reasons. Although there is plenty of room to
{                grow, the size of this type is also restricted to 1 byte for
{                file compatibility reasons.
{

  TYPE
    gft$file_kind = (
      gfc$fk_job_permanent_file,   {Permanent files.
      gfc$fk_device_file,             {Device Files
      gfc$fk_save_2,                  {Reserved for future use.
      gfc$fk_save_3,                  {Reserved for future use.
      gfc$fk_catalog,                 {Permanent file catalogs.
            { - - - dividing line between perm and temp files - - - }
      gfc$fk_job_local_file,          {BAM named job local files.
      gfc$fk_unnamed_file,            {File tables exist in Job Fixed.
      gfc$fk_global_unnamed,          {File tables exist in mainframe wired.
      gfc$fk_monitor_only_unnamed);   {Files that are accessible in monitor ONLY.

  TYPE
    gft$file_kind_set = set of gft$file_kind;

  CONST
    gfc$fk_first_temporary_file = gfc$fk_job_local_file,
    gfc$fk_last_permanent_file = gfc$fk_catalog;
*DECK DECK=GFT$FILE_MEDIA EXPAND=FALSE

  TYPE
    gft$file_media = (gfc$fm_transient_segment, gfc$fm_mass_storage_file,
       gfc$fm_served_file);


*DECK DECK=GFT$JOB_SIGNATURE_LOCK EXPAND=FALSE

  TYPE
    gft$job_signature_lock = RECORD
      locked:  boolean,
      count: 0 .. 255,
      gtid: ost$global_task_id,
      p_register: integer,            {!!!!##### debug only}
    RECEND;

*copyc ost$global_task_id
*DECK DECK=GFT$LOCKED_FILE_DESC_ENTRY_P EXPAND=FALSE

  TYPE
    gft$locked_file_desc_entry_p = ^gft$file_descriptor_entry;

*copyc gft$file_descriptor_entry
*DECK DECK=GFT$OPEN_COUNT EXPAND=FALSE

{ Define maximum number of instances of segment access OPENs for a file.

  TYPE
    gft$open_count = 0 .. 0ffffffff(16);

*DECK DECK=GFT$PAGE_STATUS EXPAND=FALSE

{ Define page status values returned from GFP$FETCH_PAGE_STATUS.


TYPE
  gft$page_status = (
      gfc$ps_page_doesnt_exist,
      gfc$ps_page_on_disk,
      gfc$ps_page_on_server,
      gfc$ps_job_mode_work_required,
      gfc$ps_temp_reject,
      gfc$ps_volume_unavailable,
      gfc$ps_account_limit_exceeded,
      gfc$ps_server_terminated,
      gfc$ps_server_allocate_required);



*DECK DECK=GFT$QUEUE_STATUS EXPAND=FALSE

{ This parameter specifies where to keep pages of permanent files.
{      gfc$qs_global_shared -  pages ALWAYS in global queues
{      gfc$qs_job_working_set - pages ALWAYS in job working set
{      gfc$qs_job_shared - pages in shared queue only if file is attached by multiple
{                          jobs. File must be attach only for READ access.


  TYPE
    gft$queue_status = (gfc$qs_global_shared, gfc$qs_job_shared, gfc$qs_job_working_set);

*DECK DECK=GFT$SCAN_ALL_FDES_STATE EXPAND=FALSE

{ The following type is used to hold STATE information for the GFP$SCAN_ALL_FDES procedure.

  TYPE
    gft$scan_all_fdes_state = RECORD
      control_p: ^gft$file_descriptor_control,
      current_index: integer, {Must be integer}
    RECEND;

*copyc gft$file_descriptor_control
*copyc gft$file_descriptor_index
*DECK DECK=GFT$SEGMENT_LOCK_INFO EXPAND=FALSE

  TYPE
    gft$segment_lock_info = RECORD
      locked_for_read: gft$open_count,
      locked_for_write: boolean,
      task_queue: tmt$task_queue_link,
    RECEND;

*copyc gft$open_count
*copyc tmt$task_queue_link
*DECK DECK=GFT$SIGNATURE_LOCK EXPAND=FALSE

  TYPE
    gft$signature_lock = RECORD
      locked:  boolean,
      count: 0 .. 255,
      gtid: ost$global_task_id,
      p_register: integer,              {!!!!##### debug only}
      p_register_2: integer,            {!!!!##### debug only}
    RECEND;

*copyc ost$global_task_id
*DECK DECK=GFT$SYSTEM_FILE_IDENTIFIER EXPAND=FALSE

   TYPE
    gft$system_file_identifier = RECORD
      file_entry_index: gft$file_descriptor_index,
      residence: gft$table_residence,
      file_hash: 0 .. 255,
    recend;

  CONST
    gfc$null_file_hash = 255;

*copyc gft$file_descriptor_index
*copyc gft$table_residence
*DECK DECK=GFT$TABLE_RESIDENCE EXPAND=FALSE

   TYPE
     gft$table_residence = (gfc$tr_null_residence, gfc$tr_system, gfc$tr_job, gfc$tr_system_wait_recovery);

*DECK DECK=GFT$TRANSFER_UNIT_SIZE EXPAND=FALSE

{ Define transfer unit size (in bytes).

  TYPE
    gft$transfer_unit_size = 0 .. 10000000;
*DECK DECK=GFT$TRICK_POINTER EXPAND=FALSE

{ This type declaration is used to perform 'trick' pointer conversion.

    TYPE
      gft$trick_pointer = RECORD
      CASE boolean OF
      = FALSE =
        p: ^cell,
      = TRUE =
        pva: RECORD
          ringseg: 0 .. 0ffff(16),
          offset: 0 .. 0ffffffff(16),
        RECEND,
      CASEND,
    RECEND;


*DECK DECK=GFV$NULL_SFID EXPAND=FALSE

  VAR
    gfv$null_sfid: [XREF, READ, OSS$MAINFRAME_WIRED_LITERAL] gft$system_file_identifier;

*copyc gft$system_file_identifier
*copyc oss$mainframe_wired_literal
*DECK DECK=HYD EXPAND=TRUE
          IDENT  HYD
          CIPPU
          MEMSEL 8
          TITLE  HYD
          COMMENT *SMD* LVL=02
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 CONTYP   EQU    12           CONTROLLER TYPE
                               = 2, FOR 7154 CONTROLLER
                               = 3, FOR 7155-1 CONTROLLER
                               = 4, FOR 7155-1X CONTROLLER
                               = 5, FOR 7155-4X CONTROLLER, 170 CHANNEL
                               = 7, FOR 7155-4X CONTROLLER, 180 CHANNEL
                               = 10, FOR ISD SUBSYSTEM
                               = 12, FOR HYDRA
*copyc IODMAC1 "{RECORD DEFINITION MACROS}
*copyc IODMAC2 "{LOAD/STORE MACROS}
*copyc IODMAC3 "{GENERAL MACROS}
*copyc IODMAC4 "{GENERAL MACROS}
          SPACE  6
 TIMER    MACRO  TM
 TT1      IFEQ   TIMES,1
          LDN    1
          STDL   WC
          LOADR  TIMAD
          CRML   TM,WC
 TT1      ENDIF
          ENDM
          SPACE  6
 TIMER2   MACRO  TM
 TT2      IFEQ   TIMES2,1
          LDN    1
          STDL   WC
          LOADR  TIMAD
          CRML   TM,WC
 TT2      ENDIF
          ENDM
          EJECT
* INTERFACE ERROR CODES.
          SPACE  6
 E101     EQU    401B        PP REQUEST QUEUE LOCKWORD TIMEOUT
 E102     EQU    402B        UNIT REQUEST QUEUE LOCKWORD TIMEOUT
 E103     EQU    403B        UNIT LOCKWORD TIMEOUT
 E104     EQU    404B        CHANNEL LOCKWORD TIMEOUT
 E105     EQU    405B        BUFFER POOL LOCKWORD TIMEOUT
 E106     EQU    406B        UNIT HARDWARE RESERVE TIMEOUT
 E107     EQU    407B        CONTROLLER HARDWARE RESERVE TIMEOUT
 E201     EQU    1001B       RMA OF CHANNEL RESERVATION TABLE NOT
                             A WORD BOUNDARY
 E202     EQU    1002B       RMA OF UNIT ACTIVITY MASK NOT A
                             WORD BOUNDARY
 E203     EQU    1003B       RMA OF PP COMMUNICATION BUFFER NOT A
                             WORD BOUNDARY
 E204     EQU    1004B       RESERVED FIELD OF THE PP COMMUNICATION
                             BUFFER DESCRIPTOR IS NOT ZERO
 E205     EQU    1005B       RESERVED FIELD OF THE PP REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 E206     EQU    1006B       RMA OF NEXT PP NOT A WORD BOUNDARY
 E207     EQU    1007B       RESERVED FIELD OF THE PP RESPONSE
                             BUFFER DESCRIPTOR IS NOT ZERO
 E208     EQU    1010B       LOGICAL UNIT OF UNIT DESCRIPTOR NOT
                             IN SEQUENCE OR NOT IN RANGE
 E209     EQU    1011B       RMA OF UNIT INTERFACE TABLE NOT A
                             WORD BOUNDARY
 E20A     EQU    1012B       INVALID CHANNEL NUMBER SPECIFIED
                             IN UNIT DESCRIPTOR
 E20B     EQU    1013B       COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS OR NOT LONG ENOUGH
 E20C     EQU    1014B       RESERVED FIELD AFTER NUMBER OF
                             UNITS IS NOT ZERO
 E20D     EQU    1015B       RESERVED FIELD OF IN POINTER
                             IS NOT ZERO
 E20E     EQU    1016B       RESERVED FIELD OF OUT POINTER
                             IS NOT ZERO
 E20F     EQU    1017B       RESERVED FIELD OF LIMIT POINTER
                             IS NOT ZERO
 E210     EQU    1020B       INVALID PHYSICAL UNIT NUMBER
 E211     EQU    1021B       RMA OF INTERRUPT WORD NOT A WORD
                             BOUNDARY
 E212     EQU    1022B       RMA OF CHANNEL TABLE NOT A WORD
                             BOUNDARY
 E301     EQU    1401B       LOGICAL UNIT NUMBER NOT EQUAL TO LOGICAL
                             UNIT OF UNIT DESCRIPTOR
 E302     EQU    1402B       RMA OF UNIT COMMUNICATION BUFFER
                             NOT A WORD BOUNDARY
 E303     EQU    1403B       A RESERVED FIELD OF THE UNIT COMMUNICATION BUFFER
                             DESCRIPTOR IS NOT ZERO
 E304     EQU    1404B       RMA OF NEXT UNIT REQUEST
                             NOT A WORD BOUNDARY
 E305     EQU    1405B       RESERVED FIELD OF UNIT REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 E306     EQU    1406B       INVALID UNIT TYPE
 E307     EQU    1407B       UNIT COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF CM WORDS
 E308     EQU    1410B       UNIT COMMUNICATION BUFFER IS TOO SMALL
 E401     EQU    2001B       RMA OF NEXT REQUEST NOT A WORD BOUNDARY
 E402     EQU    2002B       REQUEST LENGTH NOT A MULTIPLE
                             OF EIGHT BYTES
 E403     EQU    2003B       REQUEST LENGTH IS LESS THAN FORTY BYTES
 E404     EQU    2004B       LOGICAL UNIT NUMBER NOT EQUAL TO LOGICAL
                             UNIT IN UNIT INTERFACE TABLE
 E405     EQU    2005B       RESERVED LINKAGE FIELD IS NOT ZERO
 E406     EQU    2006B       INVALID RECOVERY/INTERRUPT SELECTIONS
 E407     EQU    2007B       INVALID PRIORITY SELECTION
 E408     EQU    2010B       INVALID SECONDARY ADDRESS
 E501     EQU    2401B       INVALID COMMAND CODE
 E502     EQU    2402B       INVALID FLAG SELECTION
 E503     EQU    2403B       INVALID FUNCTION
 E504     EQU    2404B       FUNCTION NOT SUPPORTED BY HARDWARE
 E505     EQU    2405B       INVALID LENGTH SPECIFICATION
                             IN COMMAND
 E506     EQU    2406B       INVALID ADDRESS SPECIFICATION
                             IN COMMAND
 E507     EQU    2407B       INVALID LENGTH SPECIFICATION IN
                             INDIRECT LIST
 E508     EQU    2410B       INVALID ADDRESS SPECIFICATION
                             IN INDIRECT LIST
 E509     EQU    2411B       PP COMMAND NOT ALLOWED IN REQUEST
                             TO A UNIT
 E50A     EQU    2412B       INVALID SEQUENCE OF COMMANDS
 E50B     EQU    2413B       INVALID PARAMETER SPECIFICATION
                             (POOL READ OR COMPARE SWAP COMMANDS)
          EJECT
 HARDW    EQU    1           = 1, TO RUN ON THE HARDWARE,
                             .NE. 1 TO RUN ON THE SIMULATOR
 PAT      EQU    1           =1, TO PATCH THE PP
 ERRTST   EQU    0           =1, TO TEST ERROR HANDLING CODE
 STREAM   EQU    1           = 1, TO STREAM REQUESTS
 VALID    EQU    0           = 1, TO VALIDATE CP TABLES
 TIMES    EQU    0           = 1, TO GATHER TIMINGS
 TIMES2   EQU    0           = 1, TO GATHER TIMINGS
 TRACE    EQU    0           = 1, TO TRACE FUNCTIONS
 CMSE     EQU    0           = 1, TO RUN WITH CMSE


* EQUATES

 DC       EQU    22          DISK CHANNEL
 SBYTE8   EQU    1024        NUMBER OF 16-BIT BYTES PER SECTOR
 CNTRY    EQU    3           NUMBER OF ATTEMPTS TO LOAD THE ADAPTER
 COSTRY   EQU    3           NUMBER OF ATTEMPTS TO LOAD COS
 RVTRY    EQU    10          LIMIT OF RECOVERED ERRORS PER REQUEST
 NRTRY    EQU    3           NUMBER OF ATTEMPTS TO RECOVER NOT READY
 C.CHCNT  EQU    37          NUMBER OF REQUESTS TO PROCESS BEFORE
                             CLEARING CHANNEL LOCK
 DHYDRA   EQU    0           INTERNAL DEVICE CODE

* ISI CHANNEL ADAPTER FUNCTION CODES.

 F.MC     EQU    0           MASTER CLEAR
 F.RDCR   EQU    400B        READ CONTROL REGISTER
 F.WTCR   EQU    401B        WRITE CONTROL REGISTER
 F.RDMR   EQU    1000B       READ MASK REGISTER
 F.WTMR   EQU    1001B       WRITE MASK REGISTER
 F.RDES   EQU    1400B       READ ERROR STATUS
 F.RDOS   EQU    2000B       READ OPERATIONAL STATUS
 F.RIS    EQU    2400B       REQUEST IDLE STATUS
 F.RDT    EQU    3000B       READ T REGISTER
 F.WTT    EQU    3001B       WRITE T REGISTER
 F.RDTS   EQU    3400B       READ TEST SEED
 F.WTTS   EQU    3401B       WRITE TEST SEED
 F.CSH    EQU    4000B       CLEAR SELECT HOLD
 F.SSH    EQU    4001B       SET SELECT HOLD
 F.CCS    EQU    4400B       CLEAR COMMAND SEQUENCE
 F.SCS    EQU    4401B       SET COMMAND SEQUENCE
 F.FSO    EQU    5000B       FORCE SYNC OUT
 F.SPM    EQU    5400B       SET PP MODE
 F.CDM    EQU    6000B       CLEAR DMA MODE
 F.SDM    EQU    6001B       SET DMA MODE
 F.CEM    EQU    6400B       CLEAR ECHO MODE
 F.SEM    EQU    6401B       SET ECHO MODE
 F.CT     EQU    7000B       CLEAR T REGISTERS
          SPACE  6
* FUNCTION WORD BIT DEFINITIONS

 T.SEL    EQU    400B        SELECT A CONTROLLER
 T.PO     EQU    200B        PRIORITY OVERRIDE
 T.BMR    EQU    40B         BROADCAST MASTER RESET
 T.NI     EQU    1000B       NON-INTERLOCKED TRANSFER
 T.TER    EQU    2000B       TERMINATE
 T.ZFI    EQU    4000B       ZERO FILL INHIBIT
 T.CA     EQU    10000B      CLEAR ATTENTION
 T.DATA   EQU    20000B      DATA / FUNCTION
 T.SR     EQU    40000B      SELECTIVE RESET
 T.OUT    EQU    100000B     WRITE / READ DIRECTION OF INFORMATION
          SPACE  3
* FUNCTION WORDS TO CONTROLLER.

 W.CMND   EQU    T.OUT+T.ZFI   WRITE A COMMAND TO COMMAND BLOCK 0
 W.STAT   EQU    200B+T.ZFI   READ HYDRA STATUS BLOCK
 W.DST    EQU    220B+T.ZFI   READ DEVICE STATUS BLOCK
 W.HOST   EQU    377B+T.ZFI   READ HYDRA HOST ID
 W.SEC    EQU    360B+T.ZFI   READ HYDRA SECTOR SIZE
 W.ATD    EQU    T.OUT+207B+T.ZFI  WRITE ATTENTION DELAY
 W.DOP    EQU    T.OUT+210B+T.ZFI  WRITE DEVICE OPERATING MODE
 W.READ   EQU    T.DATA+T.NI+T.ZFI  READ DATA
 W.READT  EQU    W.READ+T.TER  READ DATA AND TERMINATE
 W.WRITE  EQU    T.OUT+W.READ  WRITE DATA
 W.WRITT  EQU    W.WRITE+T.TER  WRITE DATA AND TERMINATE
 W.RESET  EQU    T.SR+T.CA+T.ZFI   SELECTIVE RESET
 W.RDI    EQU    T.DATA+T.TER+T.ZFI  READ DATA IN INTERLOCKED MODE
                             USED TO READ ERROR REGISTER IMAGE, ERROR LOG
 W.RCMND  EQU    0+T.ZFI       READ COMMAND BLOCK 0
 W.RCMND7 EQU    W.RCMND+7 READ WORD 7 OF COMMAND BLOCK 0
 W.CA     EQU    T.CA+T.ZFI  CLEAR ATTENTION
          SPACE  6
* COMMANDS TO THE CONTROLLER.
* TO BE PUT IN THE COMMAND BLOCK.

 R.REL    EQU    1           READ ERROR LOG
 R.RERI   EQU    2           READ ERROR REGISTER IMAGE
 R.PDOWN  EQU    22B         POWER DOWN SPINDLE
 R.PUP    EQU    23B         POWER UP SPINDLE
 R.WRITE  EQU    40B         WRITE SPECIFIED
 R.WDE    EQU    50B         WRITE DATA AND ECC
 R.READ   EQU    60B         READ SPECIFIED
 R.RDE    EQU    63B         READ DATA AND ECC
 R.SD     EQU    70B         SALVAGE DATA
 R.WB     EQU    112B        WRITE BUFFER
 R.RB     EQU    114B        READ BUFFER
 R.CFS    EQU    115B        CLEAR FAULT STATUS
 R.EEL    EQU    122B        ERASE ERROR LOG
 R.LOM    EQU    123B        LOAD OPERATING MODE
 R.LAD    EQU    124B        LOAD ATTENTION DELAY PARAMETERS
 R.DIAG2  EQU    160B        RUN LEVEL II DIAGNOSTICS
 R.DIAG   EQU    172B        RUN LEVEL I DIAGNOSTICS
                             (LEVEL II DIAGNOSTIC COMMAND 7A)
 R.DIAGS  EQU    170B        RUN DIAGNOSTIC COMMAND 78
 R.DIAGW  EQU    171B        RUN DIAGNOSTIC COMMAND 79
          EJECT
* CONFIGURED UNITS.

 UN       RECORD PACKED

* WORD 1

 UNUSED   SUBRANGE 0,77777B
 LOCK     BOOLEAN            NONZERO IF UNIT IS LOCKED BY THIS PP

* WORD 2

 CTST     BOOLEAN            NONZERO IF THE CONFIDENCE TEST WAS STARTED
 FILL     SUBRANGE 0,7
 CHIX     SUBRANGE 0,77B     INDEX TO CHANT TABLE
 CM       SUBRANGE 0,7       CONTROLLER NUMBER
 UNIT     SUBRANGE 0,7       UNIT NUMBER

* WORD 3

 LUN      PPWORD             LOGICAL UNIT NUMBER

* WORD 4

 UIT      STRUCT 6           RMA OF UNIT INTERFACE TABLE (REFORMATTED)

* WORD 7

 CB       STRUCT 6           RMA OF UNIT COMMUNICATION BUFFER (REFORMATTED)

* WORD 10

 RCNT     PPWORD             COMMAND COUNTER (INCREMENTED FOR EACH COMMAND
                             SENT TO HYDRA)
                             USED TO TIMEOUT A COMMAND ON DUAL ACCESS
                             SS+/SS/P.RCNT HAS LATEST COMMAND COUNTER VALUE

* WORD 11

 ELAPT    PPWORD             ELAPSED TIME FOR OUTSTANDING COMMAND

* WORD 12 - 13

 QSTRT    STRUCT 4           START OF QUEUE ( UIT + 4)



          MGEN   N.CHIX
 M.CHIX   EQU    MASK$
          MGEN   N.CM
 M.CM     EQU    MASK$
          MASKP  CM
 K.CM     EQU    MSK
          MASKP  UNIT
 K.UNIT   EQU    MSK
          MASKP  CTST
 K.CTST   EQU    MSK

 UN       RECEND
          SPACE  10
* CONFIGURED CHANNELS.

 CH       RECORD PACKED

* WORD 1

 CHAN     PPWORD             CHANNEL NUMBER

* WORD 2

 FILL1    BOOLEAN
 PORT     BOOLEAN            PORT B IF SET
 FILL2    SUBRANGE 0,37777B

* WORD 3

 LOCK     PPWORD             ADDRESS OF CHANNEL LOCK FLAG

* WORD 4
 ATTN     PPWORD             ATTENTION BITS FROM CHANNEL

* WORD 5
 DOWN     PPWORD             NONZERO IF CHANNEL IS DOWN




          MASKP  PORT
 K.PORT   EQU    MSK

 CH       RECEND
          SPACE  10
* T REGISTER VALUES.

 TR       RECORD PACKED

* WORD 1

 LEN      PPWORD             LENGTH IN BYTES

* WORDS 2 AND 3

 RMA      STRUCT 4           REAL MEMORY ADDRESS

 TR       RECEND
          SPACE  10
* SS TABLE DEFINITIONS. INFORMATION SAVED FOR EACH UNIT.

 SS       RECORD PACKED

* WORD 1

 FILL1    SUBRANGE 0,777B
 INIT     BOOLEAN            NONZERO IF SS ENTRY HAS BEEN INITIALIZED
 FNC      BOOLEAN            FUNCTION CODE  READ = 0
                                            WRITE = 1
 FRST     BOOLEAN            = 0, IF FIRST TIME THROUGH UNCMND
 SEEK     BOOLEAN            NONZERO IF SEEK HAS BEEN ISSUED
 CUR      BOOLEAN            CURRENT REQUEST HAS BEEN SELECTED (IF SET)
 DV       SUBRANGE 0,3       DEVICE TYPE

* WORD 2

 RCNT     PPWORD             COMMAND COUNTER

* WORD 3

 TOVAL    PPWORD             TIMEOUT VALUE IN SECONDS FOR OUTSTANDING COMMAND

* WORDS 4 - 7 = COMMAND BLOCK WORDS 4 - 7.

 NSEC     PPWORD             NUMBER OF SECTORS TO END OF CYLINDER
*
 PCYL     PPWORD             CYLINDER ADDRESS
*
 PTRK     SUBRANGE 0,377B    TRACK ADDRESS
 PSEC     SUBRANGE 0,377B    SECTOR ADDRESS
*
 CER      BOOLEAN            COMMAND EXECUTE REQUEST FLAG (SET BY PP,
                             CLEARED BY CONTROLLER)
 FUNC     SUBRANGE 0,77777B  COMMAND CODE
*

* WORD 8 - END = SAVED INFORMATION PER UNIT.

 CMND     PPWORD             NONZERO IF OUTSTANDING COMMAND
                             =1, IF READ / WRITE SPECIFIED
                             =2, IF SALVAGE DATA
                             =3, IF POWER UP SPINDLE
                             =4, IF READ ERROR LOG
                             =5, IF READ ERROR REGISTER IMAGE
                             =6, IF RUN LEVEL I DIAGNOSTICS
                             =7, IF RUN LEVEL II DIAGNOSTIC COMMAND 78
                             =8, IF READ BUFFER
                             =9, IF WRITE BUFFER
                             =10, IF LOAD OPERATING MODE
                             =11, IF LOAD ATTENTION DELAY PARAMETERS
                             =12, IF READ ERROR LOG IN NORMAL REQUEST COMPLETION
                             =13, IF RUN LEVEL II DIAGNOSTIC COMMAND 79
                             =14, IF RUN LEVEL II DIAGNOSTICS
                             =15, IF WRITE CONFIDENCE TEST
                             =16, IF READ CONFIDENCE TEST
                             =17, IF WRITE TO CONTROLLER BUFFER
                             =18, IF READ FROM CONTROLLER BUFFER

 QP       STRUCT 4           CURRENT QUEUE POINTER
 CYL      PPWORD             CYLINDER ADDRESS
 TRACK    SUBRANGE 0,377B    TRACK ADDRESS
 SECTOR   SUBRANGE 0,377B    SECTOR ADDRESS
 REQ      STRUCT 4           CURRENT REQUEST (UNFORMATTED RMA)
 PVA      STRUCT 6           PVA OF CURRENT REQUEST

 CML      PPWORD             INDEX TO CMLIST
 CI       PPWORD             INDEX TO CMWORK TABLE
 LASTC    PPWORD             OFFSET OF COMMAND IN REQUEST
 NUMCM    PPWORD             NUMBER OF COMMANDS LEFT TO PROCESS IN
                             THIS REQUEST
 LISTL    PPWORD             NUMBER OF CM WORDS IN ADDRESS-LENGTH PAIR LIST.
                             (INCLUDES THE NUMBER OF WORDS WHICH HAVENT
                             BEEN READ FROM CM.)
 TOTAL    STRUCT 4           TOTAL CM WORDS LEFT TO TRANSFER BEFORE TERMINATING
 FCOMRQ   STRUCT 4           FIRST COMPLETED REQUEST (RMA)
 CURRQ    STRUCT 4           CURRENT REQUEST (RMA).  DELRQ DELINKS FCOMRQ
                             THROUGH CURRQ
 CURRQ2   STRUCT 4           REQUEST TO BE STARTED DURING ERROR RECOVERY.
                             IT IS EITHER THE SAME AS PRERQ, OR THE NEXT ONE
                             IN THE CHAIN.  ALSO, IT IS EITHER THE SAME AS CURRQ,
                             OR THE ONE BEFORE CURRQ IN THE CHAIN.
 PRERQ    STRUCT 4           LAST REQUEST IN WHICH A RESPONSE WAS SENT DURING
                             STREAMING, SO THAT, DURING ERROR RECOVERY, THESE
                             REQUESTS CAN BE DELINKED.  NOT VALID UNLESS
                             NCOMRQ > 1.
 NCOMRQ   PPWORD             NUMBER OF COMPLETED REQUESTS WHICH HAVE SENT RESPONSES
 NCOMW    PPWORD             NUMBER OF COMPLETED REQUESTS WHICH HAVE NOT SENT
                             RESPONSES
 SWFLG    PPWORD             NONZERO IF A STREAMING REQUEST SWITCH WAS MADE
                             BITS 0 AND 1 WORK TOGETHER TO REPRESENT
                             STREAMING FLAGS FOR THE LAST 2 REQUESTS
 CURTRK   PPWORD             CURRENT TRACK
 CURSEC   PPWORD             CURRENT SECTOR
 RECOV    PPWORD             NONZERO IF IN RECOVERY

 WTA      BOOLEAN            SET WHEN WAITING FOR ATTENTION DURING ERROR RECOVERY
 MCTRY    SUBRANGE 0,7       CHANNEL MASTER CLEAR RETRY COUNTER
 SRTRY    SUBRANGE 0,7       SELECTIVE RESET RETRY COUNTER
 ERI      SUBRANGE 0,7       READ ERROR REGISTER IMAGE RETRY COUNTER
 ELOG     SUBRANGE 0,7       READ ERROR LOG RETRY COUNTER
 NR       SUBRANGE 0,7       NOT READY RETRY COUNT

 RESET    BOOLEAN            NONZERO IF SELECTIVE RESET WAS ISSUED
 CONF     BOOLEAN            NONZERO IF RUNNING THE CONFIDENCE TEST
 FILL3    SUBRANGE 0,377B
 RVCNT    SUBRANGE 0,77B     COUNT OF RECOVERED ERRORS PER REQUEST

 IRSET    BOOLEAN            NONZERO IF INITIAL SELECTIVE RESET HAS BEEN ISSUED
 CPERR    BOOLEAN            NONZERO IF THERE WAS A COMPARE ERROR IN
                             THE CONFIDENCE TEST
 CWRITE   BOOLEAN            NONZERO IF WRITE PORTION OF THE CONFIDENCE TEST
 FILL4    SUBRANGE 0,1777B
 STV      SUBRANGE 0,7       INDEX TO TABLE OF DATA PATTERNS FOR THE
                             CONFIDENCE TEST
          ALIGN  0,64
 NMED     PPWORD             NUMBER OF MEDIA ERRORS IN CONFIDENCE TEST
 NMEDL    EQU    3           NUMBER OF ACCEPTED MEDIA ERRORS IN CONFIDENCE CYLINDER
 MEDERR   STRUCT 2*4         SECTOR OFFSET OF MEDIA ERRORS ENCOUNTERED (LENGTH = NMEDL+1)


* CURRENT REQUEST.  MUST BE ALIGNED ON A WORD BOUNDARY.

          ALIGN  0,64
 RQ       STRUCT 40          REQUEST

 CIL      EQU    4           LENGTH OF CMWORK TABLE
 CMLIST   STRUCT 8*CIL       CURRENT DATA ADDRESS OR CURRENT COMMAND
 CMWORK   STRUCT CIL*2       ORIGINALLY EQUAL TO THE BYTE LENGTHS FROM CMLIST

* RESPONSE.

 RS       STRUCT 320         RESPONSE


          MGEN   N.CUR
 M.CUR    EQU    MASK$
          MGEN   N.SEEK
 M.SEEK   EQU    MASK$
          MASKP  SEEK
 K.SEEK   EQU    MSK
          MASKP  FNC
 K.FNC    EQU    MSK
          MASKP  FRST
 K.FRST   EQU    MSK
          MASKP  CUR
 K.CUR    EQU    MSK
          MASKP  INIT
 K.INIT   EQU    MSK
          MGEN   N.DV
 M.DV     EQU    MASK$
          MASKP  CER
 K.CER    EQU    MSK
          MGEN   N.TRACK
 M.TRACK  EQU    MASK$
          MGEN   N.SECTOR
 M.SECTOR EQU    MASK$
          MASKP  WTA
 K.WTA    EQU    MSK
          MASKP  MCTRY
 K.MCTRY  EQU    MSK
          MGEN   N.MCTRY
 M.MCTRY  EQU    MASK$
          MASKP  SRTRY
 K.SRTRY  EQU    MSK
          MGEN   N.SRTRY
 M.SRTRY  EQU    MASK$
          MASKP  ERI
 K.ERI    EQU    MSK
          MGEN   N.ERI
 M.ERI    EQU    MASK$
          MASKP  ELOG
 K.ELOG   EQU    MSK
          MGEN   N.ELOG
 M.ELOG   EQU    MASK$
          MASKP  NR
 K.NR     EQU    MSK
          MGEN   N.NR
 M.NR     EQU    MASK$
          MASKP  RESET
 K.RESET  EQU    MSK
          MASKP  CONF
 K.CONF   EQU    MSK
          MASKP  RVCNT
 K.RVCNT  EQU    MSK
          MGEN   N.RVCNT
 M.RVCNT  EQU    MASK$
          MASKP  IRSET
 K.IRSET  EQU    MSK
          MASKP  CWRITE
 K.CWRITE EQU    MSK
          MASKP  CPERR
 K.CPERR  EQU    MSK
          MASKP  STV
 K.STV    EQU    MSK
          MGEN   N.STV
 M.STV    EQU    MASK$

 SS       RECEND

          ERRPL  C.SS-64-1
          SPACE  6
* PP TABLE.

 PT       RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 PART     PPWORD             PARTNER PP NUMBER
 PIT      RMA                PP INTERFACE TABLE ADDRESS (RMA)
 PITPVA   STRUCT 24          PP INTERFACE TABLE ADDRESS (PVA)

 PT       RECEND
          SPACE  6
* PP INTERFACE TABLE
 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
 ACTIVE   BOOLEAN            ACTIVE_CHECK FLAG.  WHEN SET, THE PP
                             MUST CLEAR IT.
 IDLE     BOOLEAN            IDLE REQUEST
 RESUME   BOOLEAN            RESUME REQUEST
 IDSTAT   BOOLEAN            IDLE_STATUS. IF SET, THE PP IS SOFTWARE IDLED.
 FILL1    SUBRANGE 0,3777B
 LOCKF    BOOLEAN            THIS LOCK FLAG MUST BE SET BEFORE CHANGING ANYTHING
                              IN THIS CM WORD.
          ALIGN  0,64
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER
          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)
          ALIGN  32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER




          MASKP  ACTIVE
 K.ACTIVE EQU    MSK
          MASKP  IDLE
 K.IDLE   EQU    MSK
          MASKP  RESUME
 K.RESUME EQU    MSK
          MASKP  IDSTAT
 K.IDSTAT EQU    MSK
          MASKP  LOCKF
 K.LOCKF  EQU    MSK
 K.ACTION EQU    K.ACTIVE+K.IDLE+K.RESUME

 PIT      RECEND
          SPACE  6
* UNIT DESCRIPTORS.

 UD       RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 PORT     SUBRANGE 0,3       PORT B IS SET
 CNTRLR   SUBRANGE 0,77B     CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)




          MGEN   N.CHAN
 M.CHAN   EQU    MASK$

 UD       RECEND
          SPACE  6
* UNIT INTERFACE TABLE

 UIT      RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
                               = 400B, 844-4X
                               = 401B, 885-1X
                               = 402B, 885-42
 QCNT     PPWORD             QUEUE COUNT
*
          ALIGN  16,64
 UBUFL    PPWORD             UNIT COMMUNICATION BUFFER LENGTH
 UBUF     RMA                UNIT COMMUNICATION BUFFER (RMA)
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

          MASKP  DSABLE
 K.DSABLE EQU    MSK

 UIT      RECEND
          SPACE  6
* PP REQUESTS.

 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS
                               0 - ATTEMPT RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
          ALIGN  0,64
 SWIT     BOOLEAN            SWITCH TO NEXT REQUEST
 FILL     SUBRANGE 0,37B
 MAUS     SUBRANGE 0,1777B   NUMBER OF SECTORS IN THIS REQUEST
          ALIGN  16,64
 CYL      PPWORD             CYLINDER ADDRESS
 TRACK    PPWORD             TRACK ADDRESS
 SECTOR   PPWORD             SECTOR ADDRESS
 CMND     INTEGER            COMMAND SEQUENCE


          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$
          MGEN   N.MAUS
 M.MAUS   EQU    MASK$

 RQ       RECEND
          SPACE  6
* PP COMMAND.

 CM       RECORD PACKED

 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$

 CM       RECEND
          SPACE  6
* COMMAND CODES.

 C.ACK    EQU    0           ACKNOWLEDGE
 C.STOP   EQU    1           STOP UNIT
 C.SELU   EQU    2           SELECT UNIT
 C.SELC   EQU    3           SELECT CONTROLLER
 C.IDLE   EQU    4           IDLE
 C.RESUME EQU    5           RESUME
 C.OLAY   EQU    6           EXECUTE OVERLAY
 C.READY  EQU    7           START READY SCAN
 C.SREADY EQU    10B         STOP READY SCAN
 C.PPAD   EQU    11B         SELECT PP MEMORY ADDRESS
 C.PPMEM  EQU    12B         COPY PP MEMORY
 C.LDCON  EQU    14B         LOAD CONTROLWARE
 C.LDCM   EQU    15B         LOAD CONTROLLER (CONTROLWARE)
 C.ONUN   EQU    20B         ENABLE UNIT
 C.OFFUN  EQU    21B         DISABLE UNIT
 C.FUNC   EQU    40B         OUTPUT FUNCTION
 C.OUTP   EQU    41B         OUTPUT 8-BIT PARAMETERS
 C.OUTD   EQU    43B         OUTPUT 8-BIT DATA
 C.IND    EQU    45B         INPUT 8-BIT DATA/PARAMETERS
 C.READ   EQU    100B        READ BYTES
 C.WRITE  EQU    120B        WRITE BYTES
 C.STATUS EQU    140B        READ STATUS
 C.COUNT  EQU    141B        STORE TRANSFER COUNT
 C.SWAP   EQU    160B        COMPARE AND SWAP
 C.WRITEI EQU    162B        WRITE INITIALIZE
 C.RFLAW  EQU    163B        READ FLAW MAPS
 C.WRITEV EQU    200B        WRITE VERIFY
          SPACE  6
* PP RESPONSE.

 RS       RECORD PACKED

* WORD 1.
 FILL1    BOOLEAN
 SHORT    BOOLEAN            IF SET, IT IS A ONE-WORD NORMAL RESPONSE
          ALIGN  8,64
 LUN      SUBRANGE 0,377B    LOGICAL UNIT
 PVA      STRUCT 6           PVA OF REQUEST

* WORD 2.
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST  (NOT USED)

* WORD 3.
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST) (NOT USED)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)  (NOT USED)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS  (NOT USED)
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY  (NOT USED)
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

* WORD 4.
          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED  (NOT USED)
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE INTERFACE
                             ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
                             (NOT USED)
 CHERR    BOOLEAN            CHANNEL PARITY ERROR
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION
                             OCCURRED ON INPUT OR INADEQUATE DATA RATE ON OUTPUT
                             (NOT USED)
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT  (NOT USED)
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A
                             HARDWARE MALFUNCTION.  EX: UNIT NOT READY,
                             UNIT NOT CONNECTED.  (NOT USED)
 FTO      BOOLEAN            FUNCTION TIMEOUT
 CHERO    BOOLEAN            CHANNEL OUTPUT PARITY ERROR
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
                               1 - RECOVERED ERROR
                               2 - COMMAND HAD EXPLICIT RESPONSE FLAG SET
                               3 - BOTH CONDITIONS 1 AND 2
 K.REC    EQU    1           RECOVERED ERROR
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE  (NOT USED)
                               1 - UNIT CHANGED FROM READY TO NOT READY
                               2 - UNIT CHANGED FROM NOT READY TO READY
                               3 - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
                               4 - CONTROLLER RESERVED
                               5 - UNIT RESERVED TO ANOTHER ACCESS
                               6 - RECOVERED ABNORMAL CONDITION
          ALIGN  49,64       ALERT CONDITIONS
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

* WORD 5.
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)

* WORD 6.

 PORT     BOOLEAN            PORT B IF SET
 CHAN     SUBRANGE 0,77777B  CHANNEL NUMBER
 SCYL     PPWORD             STARTING CYLINDER
 STRK     PPWORD             STARTING TRACK
 SSEC     PPWORD             STARTING SECTOR

* WORD 7.

 UNIT     PPWORD             UNIT NUMBER
 RTRY     PPWORD             REQUEST RETRY COUNT
 FTRK     PPWORD             FAILING TRACK
 FSEC     PPWORD             FAILING SECTOR

* WORD 8.

 DET      PPWORD             =1, IF DETAILED STATUS PRESENT
 K.CSP    EQU    1           CONTROLLER STATUS PRESENT
 K.DSP    EQU    2           DEVICE STATUS PRESENT
 K.ERIP   EQU    4           ERROR REGISTER IMAGE PRESENT
 K.ELP    EQU    10B         ERROR LOG PRESENT
 K.ICS    EQU    20B         INCORRECT CONTROLLER WAS SELECTED
 K.CSC    EQU    40B         CANNOT SELECT THE CONTROLLER
                             SELECT ACTIVE NEVER GETS SET
 K.TIP    EQU    100B        TIMEOUT - TRANSFER IN PROGRESS
                             DIDN'T CLEAR
 K.TOP    EQU    200B        TIMEOUT - PAUSE DIDN'T CLEAR
 K.ICA    EQU    400B        ERROR IN INITIALIZING CHANNEL ADAPTER
 K.HIE    EQU    1000B       HOST I/F INTEGRITY ERROR
 K.DIE    EQU    2000B       DRIVE I/F INTEGRITY ERROR
 K.MC     EQU    4000B       MASTER CLEAR DID NOT WORK
 K.CT     EQU    10000B      RUNNING THE CONFIDENCE TEST
 K.HOST   EQU    40000B      NOT THE SAME HOST ID
 K.SEC    EQU    100000B     SECTOR SIZE NOT 4096


 ID       PPWORD             ERROR IDENTIFIER
 K.CMLD   EQU    1           RELOAD OF CONTROLLER WAS ATTEMPTED
 K.CMLDS  EQU    2           CONTROLLER RELOADED SUCCESSFULLY
 K.XD     EQU    4           EXECUTING LEVEL II DIAGNOSTICS
 K.XDP    EQU    10B         LEVEL II DIAGNOSTICS PASSED
 K.PU     EQU    20B         POWERING UP SPINDLE
 K.PUC    EQU    40B         SPINDLE POWERED UP
 K.PTO    EQU    100B        PP TIMED OUT A COMMAND
 K.SR     EQU    1000B       SELECTIVE RESET WAS ATTEMPTED
 K.SRS    EQU    2000B       SELECTIVE RESET WAS SUCCESSFUL
 K.XD1    EQU    4000B       EXECUTING LEVEL I DIAGNOSTICS
 K.XDP1   EQU    10000B      LEVEL I DIAGNOSTICS PASSED
 K.UDN    EQU    20000B      UNIT DOWN
 K.CMDN   EQU    40000B      CONTROLLER DOWN
 K.CHDN   EQU    100000B     CHANNEL DOWN

 ID2      PPWORD
 K.ICM    EQU    1           INCOMPLETE COMMAND BLOCK TRANSFER
 K.SADCM  EQU    2           SELECT ACTIVE DROPPED WHEN WRITING COMMAND BLOCK
 K.ISTT   EQU    4           INCOMPLETE STATUS TRANSFER
 K.SADST  EQU    10B         SELECT ACTIVE DROPPED WHEN READING HYDRA STATUS
 K.IDS    EQU    20B         INCOMPLETE DEVICE STATUS TRANSFER
 K.SADDS  EQU    40B         SELECT ACTIVE DROPPED WHEN READING DEVICE STATUS
 K.IER    EQU    100B        INCOMPLETE ERROR REGISTER IMAGE TRANSFER
 K.SADER  EQU    200B        SELECT ACTIVE DROPPED WHEN READING ERROR REGISTER
                             IMAGE
 K.IEL    EQU    400B        INCOMPLETE ERROR LOG TRANSFER
 K.SADEL  EQU    1000B       SELECT ACTIVE DROPPED WHEN READING ERROR LOG
 K.SADAT  EQU    2000B       SELECT ACTIVE DROPPED WHEN TRANSFERRING DATA
 K.IES    EQU    4000B       INVALID EXECUTION STATUS
 K.XFER   EQU    10000B      I4 DETECTED ERROR DURING DATA TRANSFER
 K.XFRTO  EQU    20000B      TIMEOUT ON T' NOT EMPTY OR TRANSFER IN PROGRESS
 K.TRTO   EQU    40000B      TIMEOUT ON T REGISTER BYTE COUNT NONZERO
 K.SAC    EQU    100000B     SELECT ACTIVE DID NOT CLEAR


 STRY     PPWORD             SECTOR RETRY COUNT

* WORD 9.

 ESREG    PPWORD             ERROR STATUS REGISTER
 EID      PPWORD             PP ERROR STATUS
 FUNTO    PPWORD             FUNCTION CODE IF FUNCTION TIMEOUT ERROR
 ERRID    PPWORD             ERROR IDENTIFIER
 K.IST    EQU    1           INCOMPLETE SECTOR TRANSFER
 K.CRES   EQU    2           CLEAR UNIT RESERVE ON OPPOSITE ACCESS
 K.RAM    EQU    4           RAM PARITY ERROR
 K.CLOAD  EQU    10B         CONTROLWARE LOAD WAS ATTEMPTED
 K.AFT    EQU    20B         AUTOLOAD FUNCTION TIMEOUT
 K.CEMPT  EQU    40B         CHANNEL DOESNT GO EMPTY AFTER SENDING
                             PARAMETERS / DATA
 K.CINAC  EQU    100B        CHANNEL NOT INACTIVE AFTER
                             RECEIVING PARAMETERS / DATA
 K.MEDIA  EQU    200B        MEDIA FAILURE, REREAD SECTOR
 K.UNMED  EQU    400B        UNRECOVERED MEDIA ERROR
 K.RERR   EQU    1000B       READ ERROR.  STATUS BEFORE SUSPEND/TERMINATE .NE.
                             4XXXB.
 K.CF     EQU    2000B       POLL STATUS NONZERO AFTER SENDING CONTROLWARE
 K.DE     EQU    4000B       POLL STATUS NONZERO AFTER LOADING ATTENTION DELAY
 K.NR     EQU    10000B      NOT READY
 K.URS    EQU    20000B      UNIT RESERVED
 K.CRS    EQU    40000B      CONTROLLER RESERVED
 K.ADPT   EQU    100000B     CONTROLLER INTERFACE ERROR

* WORD 10.

 OPSTAT   PPWORD             OPERATIONAL STATUS REGISTER
 TREG     STRUCT 6           T REGISTER

* WORD 11.

 CREG     PPWORD             CONTROL REGISTER
 FMREG    PPWORD             FLAG MASK REGISTER
 IDSTAT   PPWORD             IDLE STATUS
 BSR      PPWORD             BSR IF INVALID

* WORD 12.

          ALIGN  0,64
 CMST1    STRUCT 12          CONTROLLER STATUS, WORDS 80 - 85.
                             THE FIRST TIME ERROR WAS ENCOUNTERED.
 DST1     STRUCT 8           DEVICE STATUS, WORDS 90 - 93.
                             THE FIRST TIME ERROR WAS ENCOUNTERED.
 CMST2    STRUCT 12          CONTROLLER STATUS, WORDS 80 - 85.
                             THE LAST TIME ERROR WAS ENCOUNTERED.
 DST2     STRUCT 8           DEVICE STATUS, WORDS 90 - 93.
                             THE LAST TIME ERROR WAS ENCOUNTERED.

* WORDS 17 - 28.

          ALIGN  0,64
 ERI      STRUCT 96          ERROR REGISTER IMAGE

* WORDS 29 - 40.

 ELOG     STRUCT 96          ERROR LOG


          MASKP  SHORT
 K.SHORT  EQU    MSK
          MGEN   N.LUN
 M.LUN    EQU    MASK$
          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$
          MGEN   N.UNIT
 M.UNIT   EQU    MASK$
          MASKP  INTERR
 K.INTERR EQU    MSK
          MASKP  DATOV
 K.DATOV  EQU    MSK
          MASKP  DATERR
 K.DATERR EQU    MSK
          MASKP  HDWR
 K.HDWR   EQU    MSK
          MASKP  CHERR
 K.CHERR  EQU    MSK
          MASKP  CHERO
 K.CHERO  EQU    MSK
          MASKP  NRDY
 K.NRDY   EQU    MSK
          MASKP  FTO
 K.FTO    EQU    MSK

 RS       RECEND
          SPACE  6
* RESPONSE CODES.
 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    1           INTERMEDIATE RESPONSE
 R.NRM    EQU    2           NORMAL REQUEST TERMINATION
 R.ABN    EQU    3           ABNORMAL REQUEST TERMINATION
          SPACE  10
* PP COMMUNICATION BUFFER.

 CB       RECORD PACKED

          ALIGN  31,64
 SLAVE    BOOLEAN            NONZERO IF SLAVE PP
 PARTNR   RMA                PARTNERS COMMUNICATION BUFFER (RMA)

 CONTRL   STRUCT 8           LOAD CONTROLWARE COMMAND
 CMCTRL   STRUCT 8           LOAD CONTROLLER CONTROLWARE
          STRUCT 24
          STRUCT 24

          ALIGN  0,64
 ZERO     STRUCT 272         CONTAINS ALL ZEROES

          ALIGN  0,64
 WRDL     EQU    512+151     NUMBER OF CM WORDS FOR WRITE DATA
 WRDL1    EQU    WRDL*8      NUMBER OF BYTES FOR WRITE DATA
 RDDL     EQU    512         NUMBER OF CM WORDS FOR READ DATA
 RDDL1    EQU    RDDL*8      NUMBER OF BYTES FOR READ DATA
 WRD      STRUCT WRDL1       READ AND WRITE DATA FOR CONFIDENCE TEST

          ALIGN  0,64
 OVR      STRUCT 552         PP OVERLAY



          MASKP  SLAVE
K.SLAVE   EQU    MSK


 CB       RECEND
          SPACE  6
* COMMANDS BETWEEN PPS.

 C.GO     EQU    1           DONE WITH THE DISK FOR THIS SECTOR
 C.REQ    EQU    2           START A DISK REQUEST
 C.ABT    EQU    3           ABORT THE REQUEST
 C.SWIT   EQU    4           SWITCH TO THE NEXT REQUEST
 C.END    EQU    5           END OF THE DISK REQUEST
          EJECT
          CON    INIT-1


* DIRECT CELLS

          ORG    5

 T1       BSSZ   1
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1

 CM.PIT   BSSZ   3           CM ADDRESS OF PP INTERFACE TABLE (REFORMATED)

 CH       BSSZ   1           INDEX TO CHANNEL TABLE, CHANT
 CMNDS    BSSZ   1           NUMBER OF OUTSTANDING COMMANDS TO CONTROLLER
 SEKCNT   CON    0           SEEK COUNT. NUMBER OF UNITS TO WHICH A SEEK WAS
                             ISSUED
 CMOD     BSSZ   1           CONTROLLER NUMBER
 UX       BSSZ   1           INDEX TO UNITS TABLE
 FI       CON    0           INDEX TO FUNCTION HISTORY BUFFER
 SI       CON    0           INDEX TO CONTROLLER STATUS HISTORY BUFFER

 OPSTAT   BSSZ   1           OPERATIONAL STATUS
 CI       BSSZ   1           INDEX TO CMWORK TABLE
 CML      BSSZ   1           INDEX TO CMLIST
 NT       BSSZ   1           INDEX TO TREG
 TOTAL    BSSZ   1           TOTAL SECTORS TO TRANSFER
 TWDS     BSSZ   2           TOTAL NUMBER OF CM WORDS TO TRANSFER TO THE
                             CM ADDRESS.
 WDS      BSSZ   1           NUMBER OF CM WORDS TO TRANSFER FROM CURRENT SECTOR.
 WDS2     BSSZ   1           CM WORDS TO TRANSFER
 WDSS     BSSZ   1           USED TO UPDATE BYTES TRANSFERRED IN RESPONSE STATUS
 WDSS2    BSSZ   1           USED TO UPDATE BYTES TRANSFERRED IN RESPONSE STATUS
 SECPOS   BSSZ   1           SECTOR BUFFER TRANSFER POSITION (TO CM)
 FUNCD    BSSZ   1           FUNCTION CODE
 MOVFC    BSSZ   1           MOVE DATA FUNCTION CODE
 FNC      BSSZ   1           FUNCTION CODE (INTERNAL)
 CREG     CON    0           CONTROL REGISTER
 BSR      BSSZ   1           BIT SIGNIFICANT RESPONSE
 CMFUN    BSSZ   1           CONTROLLER FUNCTION
 CMADR    BSSZ   3           CM ADDRESS

 P1       BSSZ   1
 P2       BSSZ   1
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 P6       BSSZ   1
 WC       BSSZ   1           WORD COUNT TO READ/WRITE CM WORDS

 NOLOCK   EQU    75B         THIS VALUE IN LOCKS MEANS NO LOCK IS SET
 LOCKS    CON    NOLOCK      USED SO LOCK DOESN'T GET CLEARED UNTIL A
                             DIFFERENT LOCK IS SET. (UX INDEX)
 LUX      BSSZ   1           VALUE OF UNIT INDEX OF LAST UNIT SELECTED
 UNUML    BSSZ   1           LENGTH OF CONFIGURED UNIT ENTRIES
 CNUML    BSSZ   1           LENGTH OF CONFIGURED ENTRIES IN CHANT TABLE
 FRSTSC   BSSZ   1           FIRST SECTOR FLAG
 PIDLE    BSSZ   1           PRE-IDLE FLAG.  WHEN SET, DON'T ISSUE ANY
                             SEEKS.  BUT FINISH OUTSTANDING COMMANDS.
 IALF     BSSZ   1           BIT 0 = 1, IF ALL CHANNELS HAVE BEEN INITIALIZED
                             BIT 1 = 1, IF INITIAL RESET HAS BEEN ISSUED
                             ON ALL CONTROLLERS
                             BIT 2 = 1, IF CONFIDENCE TEST HAS BEEN STARTED
                             ON ALL CONTROLLERS
          SPACE  3
          ORG    72B

 DSRTP    CON    0           HCS REAL MEMORY WORD-ADDRESS
          CON    1
 SAVUX    EQU    DSRTP       USED TO SAVE UX INDEX
 INPNT    EQU    DSRTP+1     IN POINTER FOR RESPONSE BUFFER
 LIM      BSSZ   1           LIMIT OF RESPONSE BUFFER (IN 8-BIT BYTES)
 PPNO     CON    1           LOGICAL PP NUMBER
          ORG    76B
          CON    5           TEMPORARY, PP TYPE USED BY DEADSTART
 RESPC    EQU    76B         RESPONSE CODE
 LFF00    BSSZ   1
          EJECT
          ORG    100B
          LJM    INIT1
          CON    CONTYP      USED FOR DUMP IDENTIFICATION
          SPACE  6
 HALT     CON    0           HALT THE PP
          UJN    *
          SPACE  6
 PROC600  BSSZ   1           UNWANTED ATTENTIONS FOR READ DATA AVAILABLE
 PROC610  BSSZ   1           UNWANTED ATTENTIONS FOR BUFFER SPACE AVAILABLE
 PROC620  BSSZ   1           UNWANTED ATTENTIONS FOR COMMAND COMPLETE


 CURCH    CON    DC          CURRENT CHANNEL NUMBER

 FMREG    CON    377B        FLAG MASK REGISTER
          SPACE  6
* TRANSFER SIZE BEFORE SUSPENDING (64-BIT WORDS).

 XFERSZ   EQU    100000B     TRANSFER SIZE BEFORE SUSPENDING (64-BIT WORDS)
 XFERSZ2  EQU    8192        (16 SECTORS)

* NUMBER OF 16-BIT WORDS TO TRANSFER FOR EACH SECTOR.

 SECWDS   EQU    2048        SECTOR SIZE (IN 16-BIT BYTES)

* NUMBER BY WHICH THE SECTOR ADDRESS IS INCREMENTED
* FOR EACH SECTOR.

 SECSC    EQU    1

* NUMBER OF SECTORS PER TRACK FOR EACH DEVICE.

 DVSEC    EQU    38          HYDRA

* NUMBER OF TRACKS PER CYLINDER FOR EACH DEVICE.

 DVTRK    EQU    4           HYDRA

* NUMBER OF CM BYTES TO TRANSFER FOR EACH SECTOR.

 CMBTS    EQU    4096        SECTOR SIZE IN BYTES
          SPACE  4
 FW.CMND  CON    W.CMND      HYDRA FUNCTION TO WRITE COMMAND BLOCK
 FW.STAT  CON    W.STAT      HYDRA FUNCTION TO READ STATUS
 FW.HOST  CON    W.HOST      HYDRA FUNCTION TO READ HOST ID
 FW.SEC   CON    W.SEC       HYDRA FUNCTION TO READ SECTOR SIZE
 FW.CA    CON    W.CA        HYDRA FUNCTION TO CLEAR ATTENTION
          SPACE  6
 CM.CB    BSSZ   3           CM ADDRESS OF PP COMMUNICATION BUFFER (REFORMATTED)
 CM.CBU   BSSZ   2           CM ADDRESS OF PP COMMUNICATION BUFFER (UNFORMATTED)
 CM.RS    BSSZ   3           CM ADDRESS OF RESPONSE BUFFER (REFORMATTED)
 CM.INT   BSSZ   3           CM ADDRESS OF INTERRUPT WORD
 CM.CHAN  BSSZ   3           CM ADDRESS OF CHANNEL INTERLOCK TABLE


 TT11     IFEQ   TIMES,1
 TIMAD    CON    0           CM ADDRESS OF MICROSECOND CLOCK
          CON    4000B       100,000 (16)
          CON    0
 TT11     ENDIF

          SPACE  2
          EJECT
 DISK     BSS
          RJM    RDOVL
          RJM    ICOM        INITIALIZE UNIT TABLES

 MAIN10   BSS
 K1       IFEQ   PAT,1
          RJM    PATCH       PATCH THE PP
 K1       ENDIF
          RJM    PPREQ       CHECK FOR ANY PP REQUESTS

* PROCESS UNIT REQUESTS.

 MAIN15   BSS
          LDDL   UNUML
          ZJN    MAIN50      IF NO UNITS
          LDML   IDLE
          NJN    MAIN50      IF IDLE COMMAND, ONLY PROCESS PP REQUESTS
          LDDL   PIDLE
          NJN    MAIN40      IF PRE-IDLE, DON'T ISSUE NEW REQUESTS

          LDDL   IALF
          SBN    7
          ZJN    MAIN40      IF EVERYTHING INITIALIZED
          LDDL   IALF
          LPN    1
          NJN    MAIN20      IF ALL CHANNELS HAVE BEEN INITIALIZED
          RJM    IALCH       INITIALIZE CHANNEL ADAPTER ON ALL CHANNELS
          UJN    MAIN50      MAKE SURE ALL CHANNELS ARE INITIALIZED
                             BEFORE CONTINUING

 MAIN20   BSS
          LDDL   IALF
          LPN    2
          NJN    MAIN30      IF INITIAL RESET HAS BEEN ISSUED ON ALL CONTROLLERS
          RJM    RESALL      ISSUE SELECTIVE RESET TO ALL CONTROLLERS

 MAIN30   BSS
          LDDL   IALF
          LPN    4
          NJN    MAIN40      IF CONFIDENCE TEST HAS BEEN STARTED ON ALL CONTROLLERS
          RJM    CTEST       START CONFIDENCE TEST ON ALL CONTROLLERS

 MAIN40   BSS
          RJM    GETUD       SELECT UNIT REQUESTS, SEEK,
                             AND PROCESS ATTENTIONS
 MAIN50   BSS
          SOML   CHLCNT
          NJN    MAIN55      IF PP DOESN'T HAVE TO GIVE UP CHANNEL
          RJM    CKCHAN      CHECK IF CHANNEL MUST BE GIVEN UP
 MAIN55   BSS
          UJK    MAIN10
          EJECT

* UNIT COMMANDS

 UCMD     BSS
          CON    C.READ
          CON    C.WRITE

* PP COMMANDS.

 K2       IFEQ   T1,0
          CON    C.OFFUN
          CON    C.ONUN
 K2       ENDIF
 UCMDL    EQU    *-UCMD

* UNIT COMMAND PROCESSORS
 UCMDPR   BSS
          CON    WRITE       READ BYTES
          CON    WRITE       WRITE BYTES

* PP COMMAND PROCESSORS.

 K3       IFEQ   T1,0
          CON    STOP        SET UNIT DISABLE
          CON    ONUN        CLEAR UNIT DISABLE FLAG
 K3       ENDIF
          EJECT
** NAME-- GETUD
*
** PURPOSE-- GET A UNIT REQUEST FROM CENTRAL.
*            ISSUE ALL SEEKS.
*
** NOTE-- EXIT ONLY IF THERE WAS NO ACTIVITY ON ANY OF THE UNITS.
          SPACE  6
 GETUX    LJM    **
 GETUD    EQU    *-1
          LDDL   UNUML
          ZJK    GETUX       IF NO UNITS
          RJM    RDATTN      READ ATTENTION BITS
          RJM    RCLOCK      READ THE CLOCK
          LDDL   LUX         UNIT INDEX OF LAST REQUEST FOUND + 1
          STML   STUX
          UJN    GETU15

* GO TO NEXT UNIT ENTRY.

 GETU10   BSS
          LDDL   LUX         HAVE ALL ENTRIES BEEN CHECKED
          SBML   STUX
          ZJK    GETUX       IF NO MORE ENTRIES TO CHECK
 GETU15   BSS
          LDDL   LUX
          STDL   UX
          LDN    P.UN
          RADL   LUX         BUMP UNIT ENTRY
          SBDL   UNUML
          MJN    GETU20      IF NOT END OF TABLE
          STDL   LUX
 GETU20   BSS
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ERRNZ  /UIT/C.DSABLE
          CRDL   T1          READ UNIT DISABLED FLAG
          ADN    /UIT/C.NEXT
          CRDL   T5          READ RMA OF NEXT REQUEST FROM UNIT QUEUE
          SBN    /UIT/C.NEXT-/UIT/C.ULOCK
          CRDL   T3          READ UNIT LOCKWORD

* CHECK IF OTHER ACCESS HAS THE LOCK SET.

          LDDL   T3
          ZJN    GETU25      IF NO ACCESS HAS THE LOCK SET
          LDML   UNITS+/UN/P.LOCK,UX  IS UNIT LOCKED BY THIS PP
          ZJK    GETU10      IF UNIT IS NOT LOCKED BY THIS PP
                             THEN IT MUST BE LOCKED BY THE OTHER ACCESS

* GET SEEK ISSUED FLAG, COMMAND ID, AND TIMEOUT VALUE.

          LDDL   LOCKS       CHECK IF SS ENTRY IS STILL IN MEMORY
          SBDL   UX
          NJN    GETU25      IF SS ENTRY IS NOT IN MEMORY
          LDML   SS+/SS/P.SEEK  GET SEEK ISSUED FLAG
          STDL   P1
          LDML   SS+/SS/P.RCNT  GET COMMAND ID
          STDL   P2
          LDML   SS+/SS/P.TOVAL  GET TIMEOUT VALUE
          STDL   P3
          UJN    GETU30

 GETU25   BSS
          LOADR  UNITS+/UN/P.CB,UX  ADDRESS OF UNIT COMMUNICATION  BUFFER
          CRDL   P1          CHECK IF SEEK HAS BEEN ISSUED
 GETU30   BSS
          ERRNZ  /SS/P.SEEK
          LDDL   P1          CHECK IF SEEK HAS BEEN ISSUED
          SHN    /SS/L.SEEK+2
          PJK    GETU65      IF SEEK HAS NOT BEEN ISSUED
          LDDL   T1+/UIT/P.DSABLE  CHECK IF UNIT IS DISABLED
          SHN    /UIT/L.DSABLE+2
          MJK    GETU10      IF UNIT IS DISABLED

* CHECK IF ATTENTION SET FOR THIS UNIT.

          LDML   UNITS+/UN/P.CM,UX  GET CONTROLLER NUMBER
          SHN    -3
          LPN    /UN/M.CM
          STDL   CMOD        CONTROLLER NUMBER
          LDML   UNITS+/UN/P.CHIX,UX  GET CHANNEL INDEX
          SHN    /UN/L.CHIX+/UN/N.CHIX+2
          LPK    /UN/M.CHIX
          STDL   CH
          LDML   CHANT+/CH/P.ATTN,CH  GET BUSY / ATTENTION BITS
          LPML   ATTAB,CMOD  ATTENTION BIT FOR THE CONTROLLER
          NJN    GETU40      IF ATTENTION IS SET

* CHECK FOR ATTENTION TIMEOUT.

          LDML   UNITS+/UN/P.ELAPT,UX  ELAPSED TIME
          SBDL   P3          /SS/P.TOVAL
          MJN    GETU35      IF COMMAND HAS NOT BEEN TIMED OUT
          LDDL   P2          /SS/P.RCNT
          SBML   UNITS+/UN/P.RCNT,UX  CURRENT COMMAND ID
          ZJK    GETU95      IF COMMAND HAS BEEN TIMED OUT
          LDDL   P2          GET LATEST COMMAND ID
          STML   UNITS+/UN/P.RCNT,UX  UPDATE CURRENT COMMAND ID
          LDN    0
          STML   UNITS+/UN/P.ELAPT,UX  CLEAR ELAPSED TIME
 GETU35   UJK    GETU10

 GETU40   BSS
          TIMER  TM1
          LDML   UNITS+/UN/P.LOCK,UX  IS UNIT LOCKED BY THIS PP
          ZJN    GETU45      IF UNIT IS NOT LOCKED
          RJM    GETSS       GET SS ENTRY
          UJN    GETU50

 GETU45   BSS
          RJM    SETLOCK     SET UNIT LOCK
          NJN    GETU35      IF LOCK COULD NOT BE SET

* RE-READ ATTENTION BITS NOW THAT LOCK IS SET.

          RJM    CHGCH       CHANGE CHANNEL INSTRUCTIONS
          LDK    F.RIS       REQUEST IDLE STATUS
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    P6,DC       READ ATTENTION BITS
          DCN    DC+40B      DEACTIVATE CHANNEL
          CFM    GETU47,DC   CHECK AND CLEAR CHANNEL ERROR
          RJM    CHNERR      RECORD CHANNEL ERROR
*         (RETURNS IF ERRORS ARE TO BE IGNORED.)

 GETU47   BSS
          LDDL   P6
          STML   CHANT+/CH/P.ATTN,CH  ATTENTION BITS
          LPML   ATTAB,CMOD
          NJN    GETU50      IF ATTENTION IS SET
          LDDL   UX          CLEAR THIS LOCK ONLY IF A NEW ONE IS SET
          STDL   LOCKS
 GETU48   BSS
          UJK    GETU10      GO TO NEXT ENTRY

* PROCESS ATTENTION.

 GETU50   BSS
          RJM    PROC        PROCESS ATTENTION
          TIMER  TM2

* READ ATTENTION BITS ON THIS CHANNEL ONLY.

 GETU55   BSS
          LDK    F.RIS       REQUEST IDLE STATUS
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    P6,DC       READ ATTENTION BITS
          DCN    DC+40B      DEACTIVATE CHANNEL
          CFM    GETU60,DC   CHECK AND CLEAR CHANNEL ERROR
          RJM    CHNERR      RECORD CHANNEL ERROR
*         (RETURNS IF ERRORS ARE TO BE IGNORED.)

 GETU60   BSS
          LDDL   P6
          STML   CHANT+/CH/P.ATTN,CH  ATTENTION BITS

          UJK    GETU48

*
* CHECK FOR ANY REQUESTS ON THIS UNIT QUEUE.
*

 GETU65   BSS
          LDDL   T7
          ADDL   T8
          ZJN    GETU70      IF NO REQUESTS ON THIS QUEUE
          LDDL   T1+/UIT/P.DSABLE  CHECK IF UNIT IS DISABLED
          SHN    /UIT/L.DSABLE+2
          MJN    GETU70      IF UNIT IS DISABLED
          LDDL   PIDLE       CHECK PRE-IDLE FLAG
          NJN    GETU70      IF PRE-IDLE, DON'T ISSUE ANY SEEKS

          TIMER  TM3
          LDML   UNITS+/UN/P.CM,UX  GET CONTROLLER NUMBER
          SHN    -3
          LPN    /UN/M.CM
          STDL   CMOD        CONTROLLER NUMBER
          LDML   UNITS+/UN/P.CHIX,UX  GET CHANNEL INDEX
          SHN    /UN/L.CHIX+/UN/N.CHIX+2
          LPK    /UN/M.CHIX
          STDL   CH
          LDML   UNITS+/UN/P.LOCK,UX  CHECK IF THIS PP ALREADY HAS THE LOCK SET
          ZJN    GETU75      IF THIS PP DOES NOT HAVE THE LOCK SET
          RJM    GETSS       GET SS ENTRY
          UJN    GETU80

 GETU70   UJK    GETU10

 GETU75   BSS
          LDN    0
          STML   CHANT+/CH/P.DOWN,CH  CLEAR CHANNEL DOWN FLAG

* SET UNIT LOCK.

          RJM    SETLOCK     SET UNIT LOCKWORD
          NJN    GETU70      IF LOCK COULD NOT BE SET
 GETU80   BSS
 M3       IFNE   CMSE,1
          LDML   UNITS+/UN/P.CTST,UX
          SHN    /UN/L.CTST+2
          PJN    GETU85      IF THE CONFIDENCE TEST HAS NOT BEEN RUN
 M3       ENDIF
          LDML   SS+/SS/P.CUR
          SHN    /SS/L.CUR+2
          MJN    GETU90      IF CURRENT REQUEST HAS BEEN SELECTED

* SELECT CURRENT REQUEST.

          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    GETU85      IF LOCK COULD NOT BE SET
          RJM    SELRQ       SELECT CURRENT REQUEST
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          LDML   SS+/SS/P.CUR  CHECK IF A REQUEST WAS FOUND
          SHN    /SS/L.CUR+2
          MJN    GETU90      IF A REQUEST WAS FOUND
 GETU85   BSS
*TEMPORARY
          LDDL   LOCKS
          SBDL   UX
          ZJN    GETU87
          LDDL   LOCKS
          SBN    NOLOCK
          NJN    GETU88      TEMPORARY HALT
*TEMPORARY END
          LDDL   UX          CLEAR THE LOCK ONLY IF A NEW ONE IS SET
          STDL   LOCKS
 GETU87   BSS
          TIMER  TM4
          UJK    GETU55

 GETU88   BSS
          RJM    HALT        HALT THE PP
*         (NO RETURN FROM HALT.)

* ISSUE THE SEEK.

 GETU90   BSS
          LDML   SS+/SS/P.SEEK  MAKE THE CHECK AGAIN AFTER SETLOCK
          SHN    /SS/L.SEEK+2
          MJN    GETU85      IF SEEK HAS BEEN ISSUED
          RJM    SEEKI       ISSUE INITIAL SEEK
          UJK    GETU85

*
* LAST COMMAND TO HYDRA HAS BEEN TIMED OUT.
*

 GETU95   BSS
          LDML   UNITS+/UN/P.LOCK,UX  IS UNIT LOCKED BY THIS PP
          ZJN    GETU100     IF UNIT IS NOT LOCKED
          RJM    GETSS       GET SS ENTRY
          UJN    GETU110

 GETU100  BSS
          RJM    SETLOCK     SET UNIT LOCK
          NJK    GETU10      IF LOCK COULD NOT BE SET
 GETU110  BSS
          LDK    /RS/K.PTO   PUT COMMAND TIMEOUT FLAG IN RESPONSE
          RJM    SID         ERROR ID
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    CHGCH       CHANGE CHANNEL INSTRUCTIONS
          RJM    SELCM       SELECT THE CONTROLLER
          RJM    ADPTERR     TRY TO RECOVER
*         (NO RETURN FROM ADPTERR.)
          EJECT
** NAME-- SEEKI
*
** PURPOSE-- ISSUE INITIAL SEEK.
          SPACE  6
 SEKIX    LJM    **
 SEEKI    EQU    *-1
          LDML   UNITS+/UN/P.CM,UX  GET CONTROLLER NUMBER
          SHN    -3
          LPN    /UN/M.CM
          STDL   CMOD        CONTROLLER NUMBER
          LDML   UNITS+/UN/P.CHIX,UX  GET POINTER TO CHANT
          SHN    /UN/L.CHIX+/UN/N.CHIX+2
          LPK    /UN/M.CHIX
          STDL   CH
          RJM    GETRQ       GET REQUEST
          RJM    CHGCH       CHANGE CHANNEL INSTRUCTIONS
          RJM    SELCM       SELECT THE CONTROLLER
          RJM    SEEKCK      ISSUE INITIAL SEEK
          AODL   SEKCNT      INCREMENT 'SEEK ISSUED' COUNTER
          UJK    SEKIX
          EJECT
** NAME-- SEEKCK.
*
** PURPOSE-- ISSUE A SEEK AND RECOVER ANY SEEK ERRORS.
          SPACE  6
 SEEX     LJM    **
 SEEKCK   EQU    *-1

* SET COMMAND CODE FOR LOAD COMMAND BLOCK.

          LDML   SS+/SS/P.FNC  GET FUNCTION CODE
          SHN    /SS/L.FNC+2
          PJN    SEE10       IF READ
          LDK    R.WRITE     SEEK AND WRITE
          UJN    SEE15

 SEE10    BSS
          LDK    R.READ      SEEK AND READ
 SEE15    BSS
          STML   SS+/SS/P.FUNC  PARAMETER IN LOAD COMMAND BLOCK

* COMPUTE NUMBER OF SECTORS TO END OF CYLINDER.

          LDML   SS+/SS/P.TRACK
          STML   SS+/SS/P.PTRK  PUT TRACK AND SECTOR ADDRESS IN COMMAND BLOCK
          SHN    -16+/SS/N.TRACK+/SS/L.TRACK
          STDL   T1          TRACK ADDRESS
          LDML   SS+/SS/P.SECTOR
          LPK    /SS/M.SECTOR
          STDL   T2          SECTOR ADDRESS
          LDN    DVSEC       NUMBER OF SECTORS PER TRACK
          SBDL   T2
          STML   SS+/SS/P.NSEC
          LDML   SEE100,T1   NUMBER OF SECTORS ON FULL TRACKS
          RAML   SS+/SS/P.NSEC  NUMBER OF SECTORS TO END OF CYLINDER
          LDML   SS+/SS/P.CYL  PUT CYLINDER ADDRESS IN COMMAND BLOCK
          STML   SS+/SS/P.PCYL


* WRITE THE COMMAND BLOCK.

          RJM    CMND        WRITE THE COMMAND BLOCK
          LDML   SS+/SS/P.SEEK  SET SEEK ISSUED FLAG
          LPC    -/SS/K.SEEK
          ADK    /SS/K.SEEK
          STML   SS+/SS/P.SEEK
          LDN    1
          STML   SS+/SS/P.CMND  SET COMMAND PROCESSOR INDEX
          UJK    SEEX





 SEE100   BSS
          CON    38*3        TRACK 0
          CON    38*2        TRACK 1
          CON    38          TRACK 2
          CON    0           TRACK 3
          EJECT
** NAME-- CMND
*
** PURPOSE-- WRITE A COMMAND TO THE CONTROLLER.
          SPACE  6
 CMNDX    LJM    **
 CMND     EQU    *-1
          TIMER  TM5
          LDML   SS+/SS/P.CER  SET COMMAND EXECUTE REQUEST FLAG
          LPC    -/SS/K.CER
          ADK    /SS/K.CER
          STML   SS+/SS/P.CER
          LDC    F.SCS       SET SELECT HOLD AND COMMAND SEQUENCE
          RJM    FUNC
 K4       IFEQ   TRACE,1
          LDML   FW.CMND
          RJM    TBUF        PUT IN TRACE BUFFER
 K4       ENDIF
          ACN    DC
          LDN    1
          OAM    FW.CMND,DC  FUNCTION WORD TO WRITE COMMAND BLOCK
          NJK    CMND80      IF TRANSFER DID NOT COMPLETE
          LDN    4
          OAM    CB,DC       SEND THE COMMAND BLOCK
          NJK    CMND80      IF TRANSFER DID NOT COMPLETE
          LDN    4
          OAM    SS+/SS/P.NSEC,DC
          RJM    DCN         DISCONNECT CHANNEL
*         (NO RETURN IF ERROR).

          RJM    WAITTR      WAIT FOR TRANSFER IN PROGRESS TO CLEAR
          LDC    F.CCS       CLEAR COMMAND SEQUENCE
          RJM    FUNC

* SET A NEW COMMAND TIMEOUT VALUE IF THIS COMMAND HAS A
* LONGER TIMEOUT THAN THE REMAINING TIMEOUT VALUE.

 K5       IFEQ   TIMES,1
 CMND13   BSS
          RJM    RDATTN      READ ATTENTION BITS
          LDML   CHANT+/CH/P.ATTN,CH
          LPML   ATTAB,CMOD
          ZJK    CMND13
 K5       ENDIF
          TIMER  TM6
          LDML   SS+/SS/P.FUNC  LOAD COMMAND BLOCK FUNCTION
          LPC    177B
          SBN    R.PUP
          ZJN    CMND20      IF POWER UP SPINDLE
          ADC    -R.DIAG2+R.PUP
          ZJN    CMND30      IF LEVEL II DIAGNOSTICS
          SBN    R.DIAG-R.DIAG2
          NJN    CMND40      IF NOT LEVEL I DIAGNOSTICS

* LEVEL I DIAGNOSTICS, POWER UP SPINDLE

 CMND20   BSS
          LDC    210+1       SET TIMEOUT OF 210 SECONDS
          UJN    CMND50

* LEVEL II DIAGNOSTICS.

 CMND30   BSS
          LDC    600+1       SET TIMEOUT OF 10 MINUTES
          UJN    CMND50

* READ, WRITE.

 CMND40   BSS
          LDN    10+1         SET TIMEOUT OF 10 SECONDS
 CMND50   BSS
          STML   SS+/SS/P.TOVAL  TIMEOUT VALUE
          LDN    0
          STML   UNITS+/UN/P.ELAPT,UX  CLEAR ELAPSED TIME
          AOML   SS+/SS/P.RCNT  INCREMENT COMMAND ID
          STML   UNITS+/UN/P.RCNT,UX  KEEP COMMAND ID IN PP
          AODL   CMNDS       INCREMENT COUNT OF OUTSTANDING CONTROLLER COMMANDS
          UJK    CMNDX

 CMND80   BSS
          STML   RS+/RS/P.FUNTO  NUMBER OF CHANNEL WORDS NOT TRANSFERRED
          LDK    /RS/K.ICM   INCOMPLETE COMMAND BLOCK TRANSFER
          RJM    SID2        SAVE ERROR FLAG
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    ADPTERR     RECOVER ERROR
*         (NO RETURN FROM ADPTERR.)
          EJECT
** NAME-- RDATTN
*
** PURPOSE-- READ ATTENTION BITS ON ALL THE CHANNELS.
          SPACE  6
 RDATX    LJM    **
 RDATTN   EQU    *-1
          LDN    1
          STML   RDAT        SET READING ATTENTIONS FLAG
          LDN    0
          STDL   CH          CHANT TABLE INDEX

* DON'T READ ATTENTION IF CHANNEL IS DOWN.
* (WHEN CHANNEL IS DOWN, THE CHANNEL LOCK FLAG IS CLEARED.)

 RDAT10   BSS
          LDML   CHANT+/CH/P.LOCK,CH  CHANNEL LOCK FLAG
          STDL   T1
          LDIL   T1
          ZJN    RDAT20      IF CHANNEL LOCK IS NOT SET
          RJM    CHGCH       CHANGE CHANNEL INSTRUCTIONS
          LDK    F.RIS       REQUEST IDLE STATUS
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    P6,DC       READ ATTENTION BITS
          DCN    DC+40B      DEACTIVATE CHANNEL
          CFM    RDAT15,DC   CHECK AND CLEAR CHANNEL ERROR
          RJM    CHNERR      RECORD CHANNEL ERROR
*         (RETURNS IF ERRORS ARE TO BE IGNORED.)

 RDAT15   BSS
          LDDL   P6
          STML   CHANT+/CH/P.ATTN,CH  ATTENTION BITS
 RDAT20   BSS
          LDN    P.CH        BUMP CHANNEL ENTRY
          RADL   CH
          SBDL   CNUML
          MJK    RDAT10      IF MORE CHANNELS
          LDN    0
          STML   RDAT        CLEAR READING ATTENTIONS FLAG
          UJK    RDATX

          EJECT
** NAME-- PROC
*
** PURPOSE-- PROCESS ATTENTION.
          SPACE  6
 PROCX    LJM    **
 PROC     EQU    *-1
          RJM    CHGCH       CHANGE CHANNEL INSTRUCTIONS
          TIMER  TM7
          RJM    SELCM       SELECT THE CONTROLLER
          TIMER  TM8
          RJM    STATUS      READ HYDRA STATUS
          TIMER  TM9
          LDML   SS+/SS/P.CMND  GET COMMAND PROCESSOR INDEX
          STDL   P2
          LDML   CMSTAT      CONTROLLER STATUS
          SHN    -11
          LPN    7
          STDL   P1          EXECUTION STATUS
          SBN    7
          NJN    PROC50      IF NOT COMMAND COMPLETE
          SODL   CMNDS       DECREMENT COUNT OF OUTSTANDING COMMANDS
          LDN    0
          STML   SS+/SS/P.CMND  CLEAR OUTSTANDING COMMAND INDEX
          LDML   CMSTAT      CONTROLLER STATUS
          SHN    17-15
          PJN    PROC10      IF NOT NORMAL END
          LDN    8
          STDL   P1
          UJN    PROC50

 PROC10   BSS
          SHN    15-14
          PJN    PROC50      IF NOT CHECK END
          SHN    14-9
          PJN    PROC50      IF MI STATUS IS NOT VALID
          LDML   CMSTAT+2    MANUAL INTERVENTION STATUS
          LPC    377B
          ADC    -301B       C1(16), ILLEGAL SEQUENCE
          NJN    PROC50      IF MI IS NOT C1(16)
          LDN    9           POWER UP SPINDLE
          STDL   P1

 PROC50   BSS
          LDML   CMDPR,P1    GET COMMAND PROCESSOR
          STML   PROC60
          RJM    **          PROCESS COMMAND
 PROC60   EQU    *-1
 PROC70   BSS
* TEMPORARY UNTIL TEMPORARY END. USED ONLY FOR CHECKOUT.
          LDDL   LOCKS
          SBDL   UX
          ZJN    PROC80
          LDDL   LOCKS
          SBN    NOLOCK
          NJN    PROC90      TEMPORARY HALT
* TEMPORARY END.
          LDDL   UX          CLEAR THIS LOCK ONLY IF A NEW ONE IS SET
          STDL   LOCKS
 PROC80   BSS
          TIMER  TM10
          UJK    PROCX

 PROC90   BSS
          RJM    HALT        HALT THE PP
*         (NO RETURN FROM HALT.)

          SPACE  6
* READ DATA AVAILABLE.

 PROC100  CON    0
          LDML   CMDPR1,P2   GET COMMAND PROCESSOR
          STML   PROC110
          RJM    **          PROCESS COMMAND
 PROC110  EQU    *-1
          UJK    PROC70
          SPACE  6
* WRITE BUFFER SPACE AVAILABLE.

 PROC200  CON    0
          LDML   CMDPR2,P2   GET COMMAND PROCESSOR
          STML   PROC210
          RJM    **          PROCESS COMMAND
 PROC210  EQU    *-1
 PROC220  UJK    PROC70
          SPACE  6
* COMMAND COMPLETED WITHOUT ERROR.

 PROC300  CON    0
          LDML   CMDPR3,P2   GET COMMAND PROCESSOR
          STML   PROC310
          RJM    **          PROCESS COMMAND
 PROC310  EQU    *-1
          UJK    PROC220
          SPACE  6
* ATTENTION RECEIVED BUT NO OUTSTANDING COMMAND.

 PROC500  CON    0           READ DATA AVAILABLE, BUT NO COMMAND
          AOML   PROC600     COUNT IT
 PROC505  RJM    TERMA       ERROR
*         (NO RETURN FROM TERMA.)

 PROC510  CON    0           WRITE BUFFER SPACE AVAILABLE, BUT NO COMMAND
          AOML   PROC610     COUNT IT
          UJK    PROC505     ERROR

 PROC520  CON    0           COMMAND COMPLETED, BUT NO COMMAND
          AOML   PROC620     COUNT IT
          UJK    PROC505     ERROR
          SPACE  10
 PERROR   CON    0
          LDK    /RS/K.IES   INVALID EXECUTION STATUS
          RJM    SID2        PUT ERROR ID IN RESPONSE
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    STRS        PUT CONTROLLER STATUS IN RESPONSE
          RJM    ADPTERR     RECOVER
*         (NO RETURN FROM ADPTERR.)
          SPACE  10
 CMDPR    BSS
          CON    PERROR      ERROR
          CON    PROC100     READ DATA AVAILABLE
          CON    PROC200     WRITE BUFFER SPACE AVAILABLE
          CON    PERROR      ERROR
          CON    UNSOL       COMMAND BLOCK INDEPENDENT
          CON    PERROR      ERROR
          CON    UNSOL       UNSOLICITED ATTENTION
          CON    RECS        RECOVER ERROR
          CON    PROC300     COMMAND COMPLETED WITHOUT ERROR
          CON    NOTRDY      DRIVE NOT READY, POWER UP SPINDLE


* READ DATA AVAILABLE.

 CMDPR1   BSS
          CON    PROC500     NO OUTSTANDING COMMAND
          CON    WRITE       READ / WRITE SPECIFIED
          CON    PERROR      SALVAGE DATA
          CON    PERROR      POWER UP SPINDLE
          CON    ELOGA       READ ERROR LOG
          CON    RDERA       READ ERROR REGISTER IMAGE
          CON    PERROR      LEVEL I DIAGNOSTICS
          CON    PERROR      LEVEL II DIAGNOSTIC COMMAND 78
          CON    PERROR      READ BUFFER
          CON    PERROR      WRITE BUFFER
          CON    PERROR      LOAD OPERATING MODE
          CON    PERROR      LOAD ATTENTION DELAY PARAMETERS
          CON    TERMD       READ ERROR LOG IN NORMAL REQUEST TERMINATION
          CON    PERROR      LEVEL II DIAGNOSTIC COMMAND 79
          CON    PERROR      LEVEL II DIAGNOSTICS
          CON    PERROR      WRITE CONFIDENCE TEST
          CON    TDATA       READ CONFIDENCE TEST
          CON    PERROR      WRITE TO CONTROLLER BUFFER
          CON    TDATA       READ FROM CONTROLLER BUFFER

* BUFFER SPACE AVAILABLE.

 CMDPR2   BSS
          CON    PROC510     NO OUTSTANDING COMMAND
          CON    WRITE       READ / WRITE SPECIFIED
          CON    PERROR      SALVAGE DATA
          CON    PERROR      POWER UP SPINDLE
          CON    PERROR      READ ERROR LOG
          CON    PERROR      READ ERROR REGISTER IMAGE
          CON    PERROR      LEVEL I DIAGNOSTICS
          CON    PERROR      LEVEL II DIAGNOSTIC COMMAND 78
          CON    PERROR      READ BUFFER
          CON    PERROR      WRITE BUFFER
          CON    PERROR      LOAD OPERATING MODE
          CON    PERROR      LOAD ATTENTION DELAY PARAMETERS
          CON    PERROR      READ ERROR LOG IN NORMAL REQUEST TERMINATION
          CON    PERROR      LEVEL II DIAGNOSTIC COMMAND 79
          CON    PERROR      LEVEL II DIAGNOSTICS
          CON    TDATA       WRITE CONFIDENCE TEST
          CON    PERROR      READ CONFIDENCE TEST
          CON    TDATA       WRITE TO CONTROLLER BUFFER
          CON    PERROR      READ FROM CONTROLLER BUFFER

* COMMAND COMPLETED WITHOUT ERROR.

 CMDPR3   BSS
          CON    PROC520     NO OUTSTANDING COMMAND
          CON    TERMC       READ / WRITE SPECIFIED
          CON    PERROR      SALVAGE DATA
          CON    NOTRDC      POWER UP SPINDLE
          CON    ELOGC       READ ERROR LOG
          CON    RDERC       READ ERROR REGISTER IMAGE
          CON    DIAGC       LEVEL I DIAGNOSTICS
          CON    DIAGSC      LEVEL II DIAGNOSTIC COMMAND 78
          CON    PERROR      READ BUFFER
          CON    PERROR      WRITE BUFFER
          CON    LOM         LOAD OPERATING MODE
          CON    LAD         LOAD ATTENTION DELAY PARAMETERS
          CON    TERME       READ ERROR LOG IN NORMAL REQUEST TERMINATION
          CON    DIAGT       LEVEL II DIAGNOSTIC COMMAND 79
          CON    DIAGD       LEVEL II DIAGNOSTICS PASSED
          CON    CWRC        WRITE CONFIDENCE TEST
          CON    CRDC        READ CONFIDENCE TEST
          CON    CWBC        WRITE TO CONTROLLER BUFFER
          CON    CRBC        READ FROM CONTROLLER BUFFER
          SPACE  4
          EJECT
** NAME-- WRITE
*
** PURPOSE-- TRANSFER DATA TO / FROM THE CONTROLLER.
*
** INPUT-- LISTL = NUMBER OF ADDRESS-LENGTH-PAIR ENTRIES IN THE
*                    COMMAND WHICH ARE LEFT TO PROCESS.
*          CMLIST = LIST OF ADDRESS-LENGTH-PAIRS POINTING TO THE
*                   CM DATA AREA.
          SPACE  6
 WRIX     LJM    **
 WRITE    EQU    *-1
          LDML   SS+/SS/P.TOTAL  TOTAL CM WORDS LEFT TO TRANSFER
          ADML   SS+/SS/P.TOTAL+1
          NJN    WRI10       IF NO ERROR
          RJM    TERMA       CONTROLLER INTERFACE ERROR
*         (NO RETURN FROM TERMA.)

 WRI10    BSS
          RJM    RDWT        SET UP FOR WRITE

* THE CONTROLLER IS ALREADY SELECTED.
* AN ATTENTION HAS BEEN RECEIVED SAYING READ DATA AVAILABLE
* OR WRITE BUFFER SPACE AVAILABLE.
* SEND A FUNCTION WORD TRANSFER TO SET UP FOR A READ DATA
* OR WRITE DATA OPERATION.

          LDC    F.SCS       SET COMMAND SEQUENCE
          RJM    FUNC
          ACN    DC
          LDN    1
          OAM    MOVFC,DC    READ / WRITE DATA FUNCTION WORD
          RJM    DCN         DISCONNECT CHANNEL
 K6       IFEQ   TRACE,1
          LDDL   MOVFC
          RJM    TBUF        PUT IN TRACE BUFFER
 K6       ENDIF
          RJM    WAITTR      WAIT FOR TRANSFER IN PROGRESS TO CLEAR

* ENABLE DMA MODE.

          LDC    F.SDM       SET DMA MODE
          RJM    FUNC
          TIMER2 TM11

* PREPARE T REGISTER VALUES.

 WRI20    BSS
          TIMER  TM23
          LDML   CMLIST+/CM/P.RMA,CML  RMA TO LOAD INTO T REGISTER
          STML   TREG+/TR/P.RMA,NT
          LDML   CMLIST+/CM/P.RMA+1,CML
          STML   TREG+/TR/P.RMA+1,NT
          LDML   CMWORK,CI   NUMBER OF BYTES LEFT TO TRANSFER
          STDL   WDS
          SHN    -3
          STDL   WDS2        NUMBER OF CM WORDS LEFT TO TRANSFER
          ZJK    WRI68       IF 0 WORDS TO TRANSFER
          LDDL   WDS
          STML   TREG+/TR/P.LEN,NT  CM BYTES LEFT TO TRANSFER
          ADC    -CMBTS      CM BYTES PER SECTOR
          ADDL   SECPOS      BYTES PREVIOUSLY TRANSFERRED FROM THIS SECTOR
          MJN    WRI30       IF LESS THAN 1 SECTOR LEFT TO TRANSFER
          LDC    CMBTS       COMPUTE NUMBER OF CM BYTES TO TRANSFER THIS LOOP
          SBDL   SECPOS
          STML   TREG+/TR/P.LEN,NT  NUMBER OF CM BYTES TO TRANSFER
                             TO CURRENT SECTOR

* UPDATE SECTOR POSITION.

 WRI30    BSS
          LDML   TREG+/TR/P.LEN,NT
          STDL   WDS
          SHN    -3
          STDL   WDS2        CM WORDS TO TRANSFER
          LDDL   WDS
          RADL   SECPOS      UPDATE SECTOR POSITION
          ADC    -CMBTS      CHECK FOR END OF SECTOR
          NJN    WRI40       IF NOT END OF SECTOR
          STDL   SECPOS      RESET SECTOR POSITION = 0

* CHECK IF SELECT ACTIVE IS STILL SET AND T' REGISTER EMPTY.

 WRI40    BSS
          LDDL   FRSTSC
          ZJK    WRI50       IF FIRST SECTOR, T' IS EMPTY
          TIMER  TM24
          LDN    2
          STML   WRI201      SET TIMEOUT VALUE FOR 2 SECONDS
 WRI42    BSS
          LDK    177777B
          STML   WRI200      SET TIMEOUT VALUE WHEN CHECKING T' REGISTER EMPTY
 WRI44    BSS
          LDK    F.RDOS      READ OPERATIONAL STATUS
*                            DONT CALL ROPS, PROCESS CHANNEL ERRORS HERE
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    OPSTAT,DC
          DCN    DC+40B      DEACTIVATE CHANNEL
 K7       IFEQ   TRACE,1
          LDDL   OPSTAT
          RJM    TBUF        PUT IN TRACE BUFFER
 K7       ENDIF
          CFM    WRI46,DC    CHECK CHANNEL ERROR FLAG
          AOML   WRI300
          LDK    /RS/K.XFER  I4 DETECTED ERROR DURING DATA TRANSFER
 WRI45    LJM    WRI124

 WRI46    BSS
          LDDL   OPSTAT
          SHN    17-9        CHECK SELECT ACTIVE STILL SET
          PJK    WRI170      IF SELECT ACTIVE IS NOT SET
          SHN    9-1
          MJN    WRI50       IF T' REGISTER EMPTY
          SOML   WRI200
          NJN    WRI44       IF NOT TIMED OUT
          SOML   WRI201
          NJK    WRI42       IF NOT TIMED OUT
          AOML   WRI301
          LDK    /RS/K.XFRTO  TIMEOUT ON T' NOT EMPTY OR TRANSFER IN PROGRESS
          UJK    WRI45


* WRITE T' REGISTER.

 WRI50    BSS
          TIMER  TM25
          LDC    TREG
          ADDL   NT
          STML   WRI54
          LDC    F.WTT       WRITE T' REGISTER
          RJM    FUNC
          ACN    DC
          LDN    3
          OAM    **,DC
 WRI54    EQU    *-1
          RJM    DCN         DISCONNECT CHANNEL
          AODL   FRSTSC
          RJM    RCLOCK      READ THE CLOCK

* SECTOR N HAS BEEN PUT IN THE T' REGISTER.
* THEREFORE SECTOR (N-2) HAS BEEN TRANSFERRED WITHOUT ERROR.
* UPDATE COUNTERS AND POINTERS.

          RJM    RDWTOK      UPDATE COUNTERS FOR GOOD TRANSFER
          LDDL   WDS         CM BYTES TRANSFERRED
          RADL   WDSS        SAVE BYTES TRANSFERRED THIS SECTOR

* MAKE SURE A FULL SECTOR IS WRITTEN FOR EACH COMMAND.

          LDDL   SECPOS
          ZJK    WRI60       IF A FULL SECTOR WAS TRANSFERRED
          LDML   CMWORK,CI
          SBDL   WDS
          NJN    WRI60       IF MORE WORDS TO TRANSFER TO THIS CM ADDRESS
          LDML   SS+/SS/P.LISTL
          SBN    1
          NJN    WRI60       IF NOT THE LAST RMA ENTRY
          LDC    CMBTS       CM BYTES PER SECTOR
          SBDL   SECPOS      BYTES TRANSFERRED THIS SECTOR
          STDL   WDS
          STML   CMWORK,CI
          STML   TREG+/TR/P.LEN,NT  CM BYTES LEFT TO TRANSFER
          LDN    0
          STDL   SECPOS
          LDK    /CB/C.WRD   OFFSET FOR DATA IN COMMUNICATION BUFFER
          SHN    3           BYTE OFFSET
          ADML   CM.CBU+1    RMA OF COMMUNICATION BUFFER
          STML   TREG+/TR/P.RMA+1,NT
          SHN    -16
          ADML   CM.CBU
          STML   TREG+/TR/P.RMA,NT
          UJK    WRI40

* PREPARE FOR NEXT T REGISTER VALUES.

 WRI60    BSS
          LDN    3
          RADL   NT          BUMP TO NEXT T REGISTER ENTRY
          SBN    NTL
          NJN    WRI64       IF NOT WRAP AROUND
          STDL   NT
 WRI64    BSS
          LDDL   WDS         UPDATE RMA ADDRESS
          RAML   CMLIST+/CM/P.RMA+1,CML
          SHN    -16
          RAML   CMLIST+/CM/P.RMA,CML
          LDML   CMWORK,CI   DECREMENT BYTES LEFT TO TRANSFER
          SBDL   WDS
          STML   CMWORK,CI
          NJN    WRI69       IF MORE WORDS LEFT TO TRANSFER TO THIS
                             CM ADDRESS
          LDN    P.CM
          RADL   CML         BUMP INDEX TO NEXT CM ADDRESS
          STML   SS+/SS/P.CML
          AODL   CI          BUMP WORKING LENGTHS INDEX
          STML   SS+/SS/P.CI
          SBN    /SS/CIL
          NJN    WRI68       IF NOT END OF TABLE
          STDL   CML
          STML   SS+/SS/P.CML
          STDL   CI
          STML   SS+/SS/P.CI
 WRI68    BSS
          SOML   SS+/SS/P.LISTL  DECREMENT ADDRESS-LENGTH-PAIR COUNT
          ZJN    WRI70       IF END OF RMA LIST
          RJM    GLIST       READ NEXT SECTION OF THE LIST WHICH POINTS
                             TO THE CM DATA AREA
 WRI69    UJN    WRI80

* GET NEXT COMMAND.

 WRI70    BSS
          RJM    UNCMND      GET NEXT COMMAND
          NJN    WRI80       IF MORE COMMANDS
          LDML   CSTREAM
          NJK    WRI94       CHECK IF MORE REQUESTS TO STREAM

* CHECK IF SWITCH TO NEXT REQUEST.

          LDML   SS+/SS/P.TOTAL  TOTAL CM WORDS LEFT TO TRANSFER
          NJN    WRI74       IF NOT END OF TRANSFER
          LDML   SS+/SS/P.TOTAL+1
          SBDL   WDS2        NUMBER OF CM WORDS TRANSFERRED THIS LOOP
          ZJN    WRI80       IF END OF TRANSFER
          MJN    *           TEMPORARY HALT
 WRI74    BSS
          RJM    CSWIT       CHECK IF SWITCH TO NEXT REQUEST
          NJN    WRI80       IF SWITCH TO NEXT REQUEST
          LDN    0           PARTIAL SECTOR WAS TRANSFERRED AND
                             NO MORE DATA
          STML   SS+/SS/P.TOTAL
          STML   SS+/SS/P.TOTAL+1
          LJM    WRI90


* CHECK IF TIME TO SUSPEND OR TERMINATE.

 WRI80    BSS
          LDML   CSTREAM
          NJN    WRI84       IF MORE TO TRANSFER
          LDML   SS+/SS/P.TOTAL+1  DECREMENT CM WORDS LEFT TO TRANSFER
          SBDL   WDS2        NUMBER OF CM WORDS TRANSFERRED THIS LOOP
          STML   SS+/SS/P.TOTAL+1
          PJN    WRI82       IF NOT NECESSARY TO ADJUST SECOND WORD
          ADC    200000B     ADD CARRY BIT
          STML   SS+/SS/P.TOTAL+1
          SOML   SS+/SS/P.TOTAL  SUBTRACT CARRY BIT FROM FIRST WORD
          MJN    *           IF INVALID COUNT, TEMPORARY HALT
 WRI82    BSS
          LDDL   TWDS+1      CM WORDS LEFT TO TRANSFER BEFORE
                             SUSPENDING / TERMINATING
          SBDL   WDS2        NUMBER OF CM WORDS TRANSFERRED THIS LOOP
          STDL   TWDS+1
          ZJN    WRI86       CHECK 2ND WORD
          PJN    WRI84       IF MORE TO TRANSFER
          ADC    200000B     ADD CARRY BIT
          STDL   TWDS+1
          SODL   TWDS        SUBTRACT CARRY BIT FROM FIRST WORD
          MJN    *           IF INVALID COUNT, TEMPORARY HALT
 WRI84    BSS
          UJK    WRI20       IF MORE TO TRANSFER

 WRI86    BSS
          LDDL   TWDS
          NJK    WRI84       IF MORE TO TRANSFER

* IF NOT SUSPENDING THE TRANSFER, REREAD THE STREAM FLAG.

 WRI90    BSS
          LDDL   MOVFC       CHECK IF SUSPEND
          LPK    T.TER
          ZJN    WRI100      IF SUSPEND
          LDML   SS+/SS/P.RECOV  DON'T STREAM IF IN ERROR RECOVERY
          NJN    WRI100      IF IN ERROR RECOVERY
 WRI94    BSS
          LDN    2           RE-READ REQUEST
          STDL   WC
          LOADF  SS+/SS/P.REQ  ADDRESS OF REQUEST
          ADN    2
          CRML   RQ+2*4,WC
          SBN    4
          CRML   RQ,WC
          AOML   CSTREAM     SET CONTINUE STREAMING FLAG
          RJM    CSWIT       CHECK IF SWITCH TO NEXT REQUEST
          NJK    WRI84       IF MORE TO TRANSFER

* SUSPEND OR TERMINATE.
* WAIT FOR T AND T' REGISTERS TO BECOME EMPTY.
* THEN CLEAR COMMAND SEQUENCE AND CLEAR SELECT HOLD.

 WRI100   BSS
          TIMER  TM26
          LDN    2
          STML   WRI201      SET TIMEOUT VALUE FOR 2 SECONDS
 WRI102   BSS
          LDC    177777B     SET TIMEOUT VALUE WHEN CHECKING T REGISTER
                             COMPLETION
          STML   WRI200
 WRI106   BSS
          LDC    F.RDOS      READ OPERATIONAL STATUS
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    OPSTAT,DC   READ OPERATIONAL STATUS
          RJM    DCN         DISCONNECT CHANNEL
          CFM    WRI110,DC   CHECK CHANNEL ERROR FLAG
          AOML   WRI302
          LDK    /RS/K.XFER  I4 DETECTED ERROR DURING DATA TRANSFER
          UJN    WRI118

 WRI110   BSS
          LDDL   OPSTAT
          SHN    17-9        CHECK SELECT ACTIVE STILL SET
          PJK    WRI170      IF SELECT ACTIVE IS NOT SET
          LDDL   OPSTAT
          LPN    3           CHECK T' REGISTER, AND TRANSFER IN PROGRESS
          SBN    2
          ZJN    WRI120      IF T' REGISTER EMPTY, AND TRANSFER NOT IN PROGRESS
          SOML   WRI200      DECREMENT TIMEOUT COUNTER
 WRI112   NJK    WRI106      IF NOT TIMED OUT
          SOML   WRI201
 WRI114   NJK    WRI102      IF NOT TIMED OUT

          AOML   WRI303
          LDK    /RS/K.XFRTO  TIMEOUT ON T' NOT EMPTY OR TRANSFER IN PROGRESS
 WRI118   UJN    WRI124

* READ T REGISTER AND CHECK BYTE COUNT = 0.

 WRI120   BSS
          LDK    F.RDT       READ T REGISTER
          RJM    FUNC
          ACN    DC
          LDN    3
          IAM    RS+/RS/P.TREG,DC  T REGISTER
          DCN    40B+DC
          LDML   RS+/RS/P.TREG
          ZJK    WRI145      IF ALL WORDS HAVE BEEN TRANSFERRED
          SOML   WRI200      DECREMENT TIMEOUT COUNTER
          NJK    WRI112      IF NOT TIMED OUT
          SOML   WRI201
          NJK    WRI114      IF NOT TIMED OUT
          AOML   WRI304
          LDK    /RS/K.TRTO  TIMEOUT ON T REGISTER BYTE COUNT NONZERO
 WRI124   BSS
          RJM    SID2        PUT ERROR ID IN RESPONSE
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    CHREG       SAVE CHANNEL REGISTERS
          LDN    3
          STML   WRI306
 WRI130   BSS
          LDC    177777B
          STML   WRI305
          LDK    F.CSH       CLEAR SELECT HOLD
          RJM    FUNC
 WRI135   BSS
          RJM    ROPS        READ OPERATIONAL STATUS
          LDDL   OPSTAT
          LPC    1400B
          ZJN    WRI140      IF SELECT HOLD AND SELECT ACTIVE ARE CLEAR
          SOML   WRI305
          NJK    WRI135      IF NOT TIMED OUT
          SOML   WRI306      DECREMENT RETRY COUNTER
          NJK    WRI130      TRY CLEARING SELECT HOLD AGAIN
          LDK    /RS/K.SAC   SELECT ACTIVE DID NOT CLEAR
          RJM    SID2        PUT ERROR ID IN RESPONSE
 WRI140   BSS
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    ADPTERR     RECOVER
*         (NO RETURN FROM ADPTERR.)

 WRI145   BSS
          LDC    F.CCS       CLEAR COMMAND SEQUENCE
          RJM    FUNC
          TIMER2 TM12
 K8       IFEQ   TIMES,1
 WRI150   BSS
          RJM    RDATTN      READ ATTENTION BITS
          LDML   CHANT+/CH/P.ATTN,CH
          LPML   ATTAB,CMOD
          ZJK    WRI150
 K8       ENDIF
          TIMER  TM13
 K9       IFEQ   TIMES2,1
          LDML   TM12+3
          SBML   TM11+3
          STML   TM50
 WRI155   EQU    *-1
          LDML   TM13+3
          SBML   TM12+3
          STML   TM51
 WRI160   EQU    *-1
          AOML   WRI155
          AOML   WRI160
          ADC    -TM51-12
          NJN    WRI165
          LDC    TM50
          STML   WRI155
          LDC    TM51
          STML   WRI160
 WRI165   BSS
 K9       ENDIF

          RJM    RDWTOK      UPDATE COUNTERS FOR GOOD TRANSFER
          RJM    RDWTOK      UPDATE COUNTERS AGAIN FOR GOOD TRANSFER
 WRI168   BSS
          UJK    WRIX

* SELECT ACTIVE IS CLEAR.

 WRI170   BSS
          LDK    /RS/K.SADAT  SELECT ACTIVE DROPPED WHEN TRANSFERRING DATA
          RJM    SID2        PUT ERROR ID IN RESPONSE
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    CHREG       SAVE CHANNEL REGISTERS IN RESPONSE
          RJM    ICH         MASTER CLEAR THE I4 CHANNEL ADAPTER
          UJK    WRI168
          SPACE  6
 WRI200   BSSZ   1           TIMEOUT COUNTER
 WRI201   BSSZ   1           TIMEOUT COUNTER

 WRI300   BSSZ   1           ERROR COUNTER
 WRI301   BSSZ   1           ERROR COUNTER
 WRI302   BSSZ   1           ERROR COUNTER
 WRI303   BSSZ   1           ERROR COUNTER
 WRI304   BSSZ   1           ERROR COUNTER
 WRI305   BSSZ   1           ERROR COUNTER
 WRI306   BSSZ   1           ERROR COUNTER

          EJECT
** NAME-- RDWT
*
** PURPOSE-- SET UP FOR READ OR WRITE.
          SPACE  6
 RDWX     LJM    **
 RDWT     EQU    *-1
          LDN    0
          STDL   WDSS        BYTES TRANSFERRED IN SECTOR
          STDL   WDSS2
          STDL   FRSTSC      FIRST SECTOR FLAG
          STDL   SECPOS      SET SECTOR POSITION = 0
          STML   CSTREAM     CLEAR CONTINUE STREAMING FLAG
          LDML   SS+/SS/P.CML  INDEX TO CMLIST
          STDL   CML
          LDML   SS+/SS/P.CI  INDEX TO CMWORK
          STDL   CI
          LDC    XFERSZ2     CM WORD TRANSFER SIZE BEFORE SUSPENDING
          STDL   TWDS+1      CM WORDS TO TRANSFER IN READ SEQUENCE
          LDC    XFERSZ
          STDL   TWDS
          SBML   SS+/SS/P.TOTAL  TOTAL CM WORDS LEFT TO TRANSFER
          MJN    RDW10       IF SUSPEND
          NJN    RDW8        IF TERMINATE
          LDDL   TWDS+1
          SBML   SS+/SS/P.TOTAL+1
          MJN    RDW10       IF SUSPEND
 RDW8     BSS
          LDML   SS+/SS/P.TOTAL  TRANSFER REMAINING WORDS AND
                             TERMINATE TRANSFER
          STDL   TWDS
          LDML   SS+/SS/P.TOTAL+1
          STDL   TWDS+1
          LDK    W.READT     READ AND TERMINATE
          UJN    RDW20

 RDW10    BSS
          LDK    W.READ      READ (SUSPEND)
 RDW20    BSS
          STDL   MOVFC       FUNCTION CODE
          LDML   SS+/SS/P.FNC
          SHN    /SS/L.FNC+2
          PJN    RDW30       IF READ
          LDK    T.OUT       IF WRITE
          RADL   MOVFC
 RDW30    BSS
          UJK    RDWX
          EJECT
** NAME-- RDWTOK
*
** PURPOSE-- UPDATE READ AND WRITE COUNTERS.
          SPACE  6
 RDWTX    LJM    **
 RDWTOK   EQU    *-1
          LDDL   WDSS2
          ADC    -CMBTS      BYTES PER SECTOR
          PJN    RDWT5       IF A FULL SECTOR WAS TRANSFERRED

* PARTIAL SECTOR WAS TRANSFERRED.

          LDDL   WDSS        ACCUMULATE THE BYTE COUNT UNTIL A FULL SECTOR
                             IS TRANSFERRED
          RADL   WDSS2
          LDN    0
          STDL   WDSS
          UJN    RDWT15


* FULL SECTOR WAS TRANSFERRED.

 RDWT5    BSS
          AOML   SS+/SS/P.CURSEC  INCREMENT SECTOR ADDRESS
          SBN    DVSEC       COMPARE WITH NUMBER OF SECTORS PER TRACK
          MJN    RDWT10      IF NOT END OF TRACK
          STML   SS+/SS/P.CURSEC  CURRENT SECTOR
          AOML   SS+/SS/P.CURTRK  INCREMENT TRACK ADDRESS
 RDWT10   BSS
          LDDL   WDSS2
          RAML   RS+/RS/P.XFER+1  UPDATE BYTES TRANSFERRED IN RESPONSE STATUS
          SHN    -16
          RAML   RS+/RS/P.XFER
          LDDL   WDSS
          STDL   WDSS2
          LDN    0
          STDL   WDSS

* CHECK FOR STREAMING REQUEST.

 RDWT15   BSS
          LDML   SS+/SS/P.SWFLG  WAS THERE A REQUEST SWITCH
          ZJK    RDWTX       IF NOT A REQUEST SWITCH
          LPN    2           WAS THIS THE SECOND SECTOR AFTER A
                             REQUEST SWITCH
          ZJN    RDWT20      IF NOT THE SECOND SECTOR AFTER A REQUEST SWITCH
          LMML   SS+/SS/P.SWFLG
          STML   SS+/SS/P.SWFLG  CLEAR SWITCH FLAG
          RJM    SNDRSP      SEND RESPONSE TO CM

 RDWT20   BSS
          LDML   SS+/SS/P.SWFLG  WAS THIS THE FIRST SECTOR AFTER A
                             REQUEST SWITCH  (BIT 0 = 1)
          ZJN    RDWT30      IF NOT THE FIRST SECTOR AFTER A REQUEST SWITCH
          SHN    1
          STML   SS+/SS/P.SWFLG  SAVE SWITCH FLAG IN BIT 1
 RDWT30   BSS
          LDML   SS+/SS/P.CURRQ  SAVE RMA OF PREVIOUS REQUEST
          STML   SS+/SS/P.CURRQ2
          LDML   SS+/SS/P.CURRQ+1
          STML   SS+/SS/P.CURRQ2+1
          LDML   SS+/SS/P.REQ  SAVE RMA OF CURRENT REQUEST
          STML   SS+/SS/P.CURRQ
          LDML   SS+/SS/P.REQ+1
          STML   SS+/SS/P.CURRQ+1
          UJK    RDWTX
          EJECT
** NAME-- CSWIT
*
** PURPOSE-- CHECK IF A SWITCH SHOULD BE MADE TO THE NEXT
*            REQUEST DURING THE SECTOR GAP.
*            AND, IF SO, MAKE THE SWITCH TO THE NEXT REQUEST.
*
** EXIT-- A REGISTER = 0, IF NOT SWITCH.
*         A REGISTER NONZERO, IF SWITCH.
          SPACE  6
 CSWX     LJM    **
 CSWIT    EQU    *-1
          LDML   SS+/SS/P.NUMCM  CHECK IF MORE COMMANDS TO PROCESS
 S1       IFEQ   STREAM,1
          ZJN    CSW6        IF END OF COMMANDS
 S1       ENDIF
          LDN    0           EXIT A REGISTER = 0
          UJK    CSWX

 CSW6     BSS
          LDML   RQ+/RQ/P.SWIT  CHECK IF REQUEST SWITCH FLAG SET
          SHN    -16+/RQ/N.SWIT+/RQ/L.SWIT
          ERRNZ  -1+/RQ/N.SWIT+/RQ/L.SWIT
          ZJK    CSWX        IF SWITCH FLAG IS NOT SET

* GET NEXT REQUEST.
* PREPARE SS ENTRY.

          LDML   RQ+/RQ/P.NEXT  PUT RMA OF NEXT REQUEST IN SS TABLE
          STML   SS+/SS/P.REQ
          LDML   RQ+/RQ/P.NEXT+1
          STML   SS+/SS/P.REQ+1
          LDML   RQ+/RQ/P.NEXTPV  PUT PVA OF NEXT REQUEST IN SS TABLE
          STML   SS+/SS/P.PVA
          LDML   RQ+/RQ/P.NEXTPV+1
          STML   SS+/SS/P.PVA+1
          LDML   RQ+/RQ/P.NEXTPV+2
          STML   SS+/SS/P.PVA+2
          RJM    UREQ        READ NEXT REQUEST INTO RQ
          LDML   RQ+/RQ/P.CYL
          SBML   SS+/SS/P.CYL  CYLINDER ADDRESS
          NJN    CSW15       TEMPORARY HALT
          LDN    SECSC*2     ADD A 2 SECTOR INCREMENT
          STDL   T1
          LDDL   FRSTSC      NUMBER OF SECTORS TRANSFERRED
          SBN    1
          NJN    CSW10       IF MORE THAN 1 SECTOR WAS TRANSFERRED
          LDN    SECSC*1     ADD A 1 SECTOR INCREMENT
          STDL   T1
 CSW10    BSS
          LDML   SS+/SS/P.CURSEC  CURRENT SECTOR - 2 (OR 1)
          ADDL   T1          ADD A 1 OR 2 SECTOR INCREMENT
          SBML   RQ+/RQ/P.SECTOR  SECTOR OF NEXT REQUEST
          ZJN    CSW20       IF OK
          SBN    DVSEC       NUMBER OF SECTORS PER TRACK
          ZJN    CSW17       IF OK
 CSW15    BSS
          RJM    HALT        HALT THE PP
*         (NO RETURN FROM HALT.)

 CSW17    BSS
          LDN    1           ADD 1 TO TRACK ADDRESS
 CSW20    BSS
          ADML   SS+/SS/P.CURTRK  CURRENT TRACK
          SBML   RQ+/RQ/P.TRACK  TRACK ADDRESS OF NEXT REQUEST
          NJN    CSW15       TEMPORARY HALT
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
          LDML   SS+/SS/P.FNC
          SHN    /SS/L.FNC+2
          MJN    CSW30       IF WRITE

* IF READ, SET SWFLG TO SEND RESPONSE OF COMPLETED REQUEST.
* IF WRITE, DON'T SEND RESPONSES FOR COMPLETED REQUESTS.
* FOR WRITE ERROR RECOVERY, RESTART ALL REQUESTS.

          LDN    1
          RAML   SS+/SS/P.SWFLG  SET SWITCH FLAG
 CSW30    BSS
          AOML   SS+/SS/P.NCOMW  INCREMENT NUMBER OF COMPLETED REQUESTS WHICH
                                 HAVE NOT SENT RESPONSES
          LDN    1           EXIT A REGISTER NONZERO
          UJK    CSWX
          EJECT
** NAME-- UREQ
*
** PURPOSE-- READ A UNIT REQUEST FROM CM.
*
** OUTPUT-- RQ  CONTAINS CURRENT REQUEST.
*           FRST = 0
*           NUMCM = NUMBER OF COMMANDS.
*
          SPACE  6
 UREQX    LJM    **
 UREQ     EQU    *-1
          LDML   SS+/SS/P.FRST  SET FLAG WHEN REQUEST IS READ
          LPC    -/SS/K.FRST
          STML   SS+/SS/P.FRST
          LDN    0
          STDL   CML         INDEX TO CMLIST
          STDL   CI          INDEX TO CMWORK
          STML   SS+/SS/P.CML  INDEX TO CMLIST
          STML   SS+/SS/P.CI  INDEX TO CMWORK
          LDN    3           NUMBER OF WORDS TO READ
          STDL   WC
          LOADF  SS+/SS/P.REQ  LOAD CM ADDRESS AND REFORMAT
          ADN    2
          CRML   RQ+2*4,WC   READ CURRENT REQUEST
                             READ SWITCH FLAG BEFORE READING LINKAGE WORDS
          SBN    5
          CRML   RQ,WC
          LDML   RQ+/RQ/P.LEN  DETERMINE NUMBER OF COMMANDS
          SHN    -3
          SBN    /RQ/C.CMND
          STML   SS+/SS/P.NUMCM  NUMBER OF COMMANDS
          LDN    /RQ/C.CMND
          STML   SS+/SS/P.LASTC  OFFSET OF COMMAND
          UJK    UREQX
          EJECT
** NAME-- SRESP
*
** PURPOSE-- SET UP STATUS RESPONSE BUFFER.
          SPACE  6
 SREX     LJM    **
 SRESP    EQU    *-1
          LDML   SS+/SS/P.PVA  PUT PVA OF REQUEST IN RESPONSE BUFFER
          STML   RS+/RS/P.PVA
          LDML   SS+/SS/P.PVA+1
          STML   RS+/RS/P.PVA+1
          LDML   SS+/SS/P.PVA+2
          STML   RS+/RS/P.PVA+2
*
          LDN    0
          STML   RS+/RS/P.XFER  TRANSFER COUNT
          STML   RS+/RS/P.XFER+1
          UJK    SREX
          EJECT
** NAME-- FAILAD
*
** PURPOSE-- SET FAILING DISK ADDRESS IN RESPONSE.
          SPACE  6
 FAILX    LJM    **
 FAILAD   EQU    *-1
          LDML   SS+/SS/P.CURTRK  FAILING TRACK ADDRESS
          STML   RS+/RS/P.FTRK
          LDML   SS+/SS/P.CURSEC  FAILING SECTOR
          STML   RS+/RS/P.FSEC
          LDK    C.RS*8
          STML   RS+/RS/P.RESPL  RESPONSE LENGTH
          UJK    FAILX
          EJECT
** NAME-- UNCMND
*
** PURPOSE-- GET NEXT COMMAND.
*
** INPUT-- NUMCM, FRST, RS+/RS/P.LASTC
*
** OUTPUT-- CMLIST, FNC, RQ+/RQ/P.CMND
*           LISTL.
*
** EXIT-- A REGISTER = 0, IF NO MORE COMMANDS.
*         A REGISTER .NE. 0, IF NEXT COMMAND PRESENT.
          SPACE  6
 UNCX     LJM    **
 UNCMND   EQU    *-1
          LDML   SS+/SS/P.NUMCM
          ZJN    UNCX        IF NO MORE COMMANDS, EXIT, A REGISTER = 0
          SOML   SS+/SS/P.NUMCM  DECREMENT COMMAND COUNT
          LDML   SS+/SS/P.FRST  HAS FIRST COMMAND BEEN PROCESSED
          SHN    /SS/L.FRST+2
          PJN    UNC10       IF FIRST COMMAND HASN'T BEEN PROCESSED

*         READ NEXT COMMAND FROM CM.

          AOML   SS+/SS/P.LASTC  INCREMENT OFFSET OF LAST COMMAND
          LDN    C.CM
          STDL   WC
          LOADF  SS+/SS/P.REQ  LOAD CM ADDRESS AND REFORMAT
          ADML   SS+/SS/P.LASTC  ADD OFFSET OF COMMAND
          CRML   CM,WC       READ COMMAND FROM CM

*         IF INDIRECT ADDRESS, READ CM ADDRESS LIST.

 UNC10    BSS
          LDML   CM+/CM/P.LEN  MAKE SURE IT IS AN EVEN NUMBER OF CM WORDS
          ADN    7
          SCN    7
          STML   CM+/CM/P.LEN
          STML   CMLIST+/CM/P.LEN,CML
          STML   CMWORK,CI
          SHN    -3
          STML   SS+/SS/P.LISTL  LENGTH OF CM ADDRESS AREA  (CM WORDS)
          LDML   CM+/CM/P.INDIR
          SHN    /CM/L.INDIR+2
          MJN    UNC15       IF INDIRECT ADDRESS
          LDN    1
          STML   SS+/SS/P.LISTL  IF NOT INDIRECT, ONLY 1 COMMAND.
          LDML   CM+/CM/P.RMA
          STML   CMLIST+/CM/P.RMA,CML
          LDML   CM+/CM/P.RMA+1
          STML   CMLIST+/CM/P.RMA+1,CML
          UJN    UNC20

 UNC15    BSS
          RJM    GLIST       GET CM ADDRESS LIST OF DATA AREA

* IF SWITCH FLAG IS SET, EXIT.

 UNC20    BSS

*         SET UP INTERNAL FUNCTION CODE, FNC.

          LDN    0
          STDL   FNC         SET UP INTERNAL FUNCTION CODE
          LDML   SS+/SS/P.FNC
          LPC    -/SS/K.FNC
          STML   SS+/SS/P.FNC
          LDML   CM+/CM/P.CODE  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          ERRNZ  /CM/L.CODE
          ADC    -C.READ     COMPARE COMMAND CODE
          ZJN    UNC40       IF READ
          SBN    C.WRITE-C.READ
          NJN    UNC47       IF NOT WRITE
          AODL   FNC         SET FUNCTION CODE FOR WRITE
          LDK    /SS/K.FNC   SET FUNCTION CODE FOR WRITE
          RAML   SS+/SS/P.FNC
 UNC40    BSS
          LDML   SS+/SS/P.FRST  SET FIRST COMMAND FLAG NONZERO
          LPC    -/SS/K.FRST
          ADK    /SS/K.FRST
          STML   SS+/SS/P.FRST
          UJK    UNCX        EXIT A REGISTER NONZERO

 UNC45    BSS
          LDML   CM+/CM/P.CODE  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          ERRNZ  /CM/L.CODE
          SBML   UCMD,FNC    COMPARE COMMAND CODE
          ZJN    UNC40       IF COMMAND FOUND
 UNC47    AODL   FNC
          SBN    UCMDL
          MJN    UNC45       IF MORE COMMANDS TO CHECK
          LDC    E501        ERROR IN COMMAND CODE
          RJM    ATERM       ABNORMAL TERMINATION (NO RETURN)
*         (NO RETURN FROM ATERM)
          EJECT
** NAME-- GLIST
*
** PURPOSE-- READ THE CM ADDRESS LIST PORTION OF A COMMAND.
*
** INPUT-- LISTL
*
** OUTPUT-- CMLIST, CM+/CM/P.RMA
          SPACE  6
 GLIX     LJM    **
 GLIST    EQU    *-1
          LDML   SS+/SS/P.LISTL  NO OF CM WORDS IN ADDRESS-LENGTH-PAIR LIST
          ZJN    GLIX        IF NO WORDS TO READ
          LDN    1
          STDL   WC          NUMBER OF CM WORDS TO READ
          LDC    CMLIST
          ADDL   CML
          STML   GLI10
          LOADF  CM+/CM/P.RMA  LOAD CM ADDRESS AND REFORMAT
          CRML   CMLIST,WC
 GLI10    EQU    *-1
          LDN    8
          RAML   CM+/CM/P.RMA+1  UPDATE RMA ADDRESS FOR NEXT READ
          SHN    -16
          RAML   CM+/CM/P.RMA
          LDML   CMLIST+/CM/P.LEN,CML  MAKE SURE IT IS AN EVEN NUMBER OF
                             CM WORDS
          ADN    7
          SCN    7
          STML   CMLIST+/CM/P.LEN,CML
          STML   CMWORK,CI
          UJK    GLIX
          EJECT
** NAME-- SELCM
*
** PURPOSE-- SELECT A CONTROLLER.
*            CM = CONTROLLER NUMBER TO SELECT.
*            ASSUMES SELECT HOLD IS DEACTIVATED.
*
** NOTE--    IF SELECT ACTIVE DOESN'T SET IN 10 MICROSECONDS, IT WILL NEVER SET.
*            BUSY CAN BE SET AS A RESULT OF THE CONTROLLER BEING IN THE FUNCTION
*            BUFFER.  IN THIS CASE, BUSY WILL BE SET FOR LESS THAN 1 MILLISECOND.
*            SELECT HOLD MUST BE CLEARED IN ORDER TO GET CORRECT BUSY STATUS.
*            ALSO, IF ANY OTHER CONTROLLER IS SELECTED, BUSY STATUS IS INVALID.
          SPACE  6
 SELCX    LJM    **
 SELCM    EQU    *-1
          LDC    177777B
          STML   CSATRY      RETRY COUNTER FOR CLEARING SELECT ACTIVE

* CHECK IF DESIRED CONTROLLER IS STILL SELECTED.

 SELC1    BSS
          LDK    F.RDOS      READ OPERATIONAL STATUS
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    OPSTAT,DC
          DCN    DC+40B      DEACTIVATE CHANNEL
          CFM    SELC2,DC    CHECK AND CLEAR CHANNEL ERROR
          RJM    CHNERR      RECORD CHANNEL ERROR
*         (RETURNS IF ERRORS ARE TO BE IGNORED.)

 SELC2    BSS
 K10      IFEQ   TRACE,1
          LDDL   OPSTAT
          RJM    TBUF        PUT IN TRACE BUFFER
 K10      ENDIF

          LDDL   OPSTAT      OPERATIONAL STATUS
          LPC    1400B       CHECK IF SELECT HOLD AND SELECT ACTIVE ARE SET
          ZJN    SELC5       IF SELECT HOLD AND SELECT ACTIVE ARE NOT SET
          ADC    -1400B
          NJN    SELC3       IF SELECT HOLD AND SELECT ACTIVE ARE NOT SET
          LDDL   BSR         CHECK IF DESIRED CONTROLLER IS STILL SELECTED
          SBML   ATTAB,CMOD
          ZJK    SELCX       IF CORRECT CONTROLLER IS STILL SELECTED
 SELC3    BSS
          LDK    F.CSH       CLEAR SELECT HOLD
          RJM    FUNC
          SOML   CSATRY
          NJK    SELC1       RETRY TO CLEAR SELECT HOLD AND SELECT ACTIVE
          LDK    /RS/K.SAC   SELECT ACTIVE DID NOT CLEAR
          RJM    SID2        PUT ERROR ID IN RESPONSE
          UJK    SELC50      CANNOT SELECT THE CONTROLLER

* SET SELECT HOLD AND COMMAND SEQUENCE.  OUTPUT CONTROLLER SELECT WORD.

 SELC5    BSS
          LDN    3
          STML   PRITRY      PRIORITY OVERRIDE RETRY COUNTER
          LDC    T.SEL       SELECT A CONTROLLER
          ADDL   CMOD        CONTROLLER NUMBER
          STDL   CMFUN
 SELC8    BSS
          LDN    5
          STML   SELTRY      SELECT RETRY COUNTER

 SELC10   BSS
          LDC    F.SCS       SET SELECT HOLD AND COMMAND SEQUENCE
          RJM    FUNC
 K11      IFEQ   TRACE,1
          LDDL   CMFUN
          RJM    TBUF        PUT IN TRACE BUFFER
 K11      ENDIF
          ACN    DC
          LDN    1
          OAM    CMFUN,DC    OUTPUT SELECT WORD
          RJM    DCN         DISCONNECT CHANNEL

* CONTROLLER IS SELECTED IF SELECT ACTIVE ACTIVE AND PAUSE NOT ACTIVE.
* ALSO, WAIT FOR TRANSFER IN PROGRESS TO CLEAR.
* TIME OUT AFTER 12 MICROSECONDS ON THE FIRST 2 ATTEMPTS.
* THEN TIMEOUT 32 MILLISECONDS ON THE LAST 3 ATTEMPTS.

          LDML   SELTRY      CHECK IF FIRST OR SECOND TIMEOUT
          SBN    4
          MJN    SELC14      IF NOT THE FIRST OR SECOND TIMEOUT
          LDN    2           TIMEOUT 12 MICROSECONDS
          UJN    SELC16

 SELC14   BSS
          LDN    0           TIMEOUT 32 MILLISECONDS
 SELC16   BSS
          STML   SELTO       SET SELECT TIMEOUT VALUE
 SELC20   BSS
          LDK    F.RDOS      READ OPERATIONAL STATUS
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    OPSTAT,DC
          DCN    DC+40B      DEACTIVATE CHANNEL
          CFM    SELC25,DC   CHECK AND CLEAR CHANNEL ERROR
          RJM    CHNERR      RECORD CHANNEL ERROR
*         (RETURNS IF ERRORS ARE TO BE IGNORED.)

 SELC25   BSS
 K12      IFEQ   TRACE,1
          LDDL   OPSTAT
          RJM    TBUF        PUT IN TRACE BUFFER
 K12      ENDIF

          LDDL   OPSTAT
          LPC    21001B      CHECK PAUSE, SELECT ACTIVE,
                             AND TRANSFER IN PROGRESS
          ADC    -1000B      WAIT UNTIL PAUSE NOT ACTIVE, SELECT ACTIVE SET,
                             AND TRANSFER NOT IN PROGRESS
          ZJN    SELC30      IF CONTROLLER SELECTED
          SOML   SELTO       DECREMENT SELECT TIMEOUT COUNTER
          NJK    SELC20      IF NOT TIMED OUT
          AOML   SELC100+1   SELECT TIMED OUT
          SHN    -16
          RAML   SELC100
          LDDL   OPSTAT
          SHN    17-9
          PJK    SELC40      IF SELECT ACTIVE NOT SET
          SHN    9-0
          PJN    SELC27      IF TRANSFER IN PROGRESS IS NOT SET
          LDK    /RS/K.TIP   TIMEOUT - TRANSFER IN PROGRESS DIDN'T CLEAR
          UJN    SELC28

 SELC27   BSS
          LDK    /RS/K.TOP   TIMEOUT - PAUSE DIDN'T CLEAR
 SELC28   LJM    SELC52

* READ BIT SIGNIFICANT RESPONSE FROM CONTROLLER.

 SELC30   BSS
          LDC    F.FSO       FORCE SYNC OUT
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    BSR,DC      READ BIT SIGNIFICANT RESPONSE
          DCN    DC+40B      DEACTIVATE CHANNEL
          CFM    SELC35,DC   CHECK AND CLEAR CHANNEL ERROR
          RJM    CHNERR      RECORD CHANNEL ERROR
*         (RETURNS IF ERRORS ARE TO BE IGNORED.)

 SELC35   BSS
          LDC    F.CCS       CLEAR COMMAND SEQUENCE
          RJM    FUNC
          LDDL   BSR
          SBML   ATTAB,CMOD
          NJN    SELC38      IF CORRECT CONTROLLER IS NOT SELECTED

* CHECK IF PRIORITY OVERRIDE WAS ISSUED.

          LDDL   CMFUN
          LPC    T.PO
          ZJK    SELCX       IF PRIORITY OVERRIDE WAS NOT ISSUED

* PRIORITY OVERRIDE SEQUENCE --
* 1. SELECT WITH PRIORITY OVERRIDE.
* 2. ISSUE SELECTIVE RESET.
* 3. WAIT FOR RESET TO COMPLETE.
*    STATUS = PRIORITY OVERRIDE COMPLETE.
* 4. SELECT WITHOUT PRIORITY OVERRIDE.
*
* THE PP MUST RETAIN THE UNIT LOCK UNTIL THE SEQUENCE IS COMPLETE.

          RJM    RESET       ISSUE SELECTIVE RESET
          LDK    F.CSH       CLEAR SELECT HOLD
          RJM    FUNC
          LDN    NOLOCK      MAKE SURE LOCK ISN'T CLEARED
          STDL   LOCKS
          RJM    SAVSS       SAVE SS ENTRY
          LJM    MAIN10      WAIT FOR ATTENTION

* INCORRECT CONTROLLER WAS SELECTED.
* WOULD ALSO GET HERE IF SELECT HOLD AND SELECT ACTIVE WERE SET
* AT THE BEGINNING OF SELCM AND WERE NOT CLEARED AS IT NOW IS.
* THIS IS THE REASON FOR THE CHECK AND CLEAR SELECT HOLD AT THE
* BEGINNING OF THIS ROUTINE.

 SELC38   BSS
          LDDL   BSR
          STML   RS+/RS/P.BSR  PUT INVALID BSR IN RESPONSE
          LDK    /RS/K.ICS   INCORRECT CONTROLLER WAS SELECTED
          UJK    SELC52


* SELECT ACTIVE DIDN'T GET SET.
* CHECK IF CONTROLLER HAS BUSY BIT SET.

 SELC40   BSS
          LDC    F.CSH       CLEAR SELECT HOLD
          RJM    FUNC
          LDN    20          TIMEOUT 1 MILLISECOND
          STML   SELTO       SET BUSY TIMEOUT VALUE
 SELC42   BSS
          LDC    F.RIS       REQUEST IDLE STATUS
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    P6,DC       READ BUSY / ATTENTION BITS
          RJM    INC         DEACTIVATE CHANNEL
          LDDL   P6
          STML   CHANT+/CH/P.ATTN,CH  BUSY / ATTENTION BITS
          SHN    -8
          LPML   ATTAB,CMOD
          ZJN    SELC44      IF NOT BUSY
          LDML   SELTO
          SBN    20
          NJN    SELC43      IF NOT THE FIRST TIME THROUGH LOOP
          AOML   SELC300+1   IF BUSY ON FIRST READ OF IDLE STATUS
          SHN    -16
          RAML   SELC300
 SELC43   BSS
          SOML   SELTO       DECREMENT BUSY TIMEOUT COUNTER
          NJK    SELC42      IF NOT TIMED OUT
          AOML   SELC400+1   STILL BUSY AFTER BUSY TIMEOUT
          SHN    -16
          RAML   SELC400
 SELC44   BSS
          LDML   SELTO
          SBN    20
          NJN    SELC46      IF NOT THE FIRST TIME THROUGH LOOP
          AOML   SELC200+1   IF NOT BUSY ON FIRST READ OF IDLE STATUS
          SHN    -16
          RAML   SELC200
 SELC46   BSS
          SOML   SELTRY
          SBN    3
          PJN    SELC48      RETRY THE SELECTION SEQUENCE
                             WITHOUT LOGGING AN ERROR
          LDML   CHANT+/CH/P.ATTN,CH  BUSY / ATTENTION BITS
          SHN    -8
          LPML   ATTAB,CMOD
          NJN    SELC60      IF BUSY
          AOML   SELC500+1   CANNOT SELECT THE CONTROLLER, LOG ERROR
          SHN    -16
          RAML   SELC500
          LDML   SELTRY
          ZJN    SELC50      IF TIMED OUT
          LDK    /RS/K.CSC   CANNOT SELECT THE CONTROLLER
          RJM    SDET        PUT ERROR ID IN RESPONSE
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
 SELC48   UJK    SELC10      RETRY TO SELECT


* GETS HERE IF NON-EXISTANT CONTROLLER.

 SELC50   BSS
          LDK    /RS/K.CSC   CANNOT SELECT THE CONTROLLER
 SELC52   BSS
          RJM    SDET        PUT ERROR ID IN RESPONSE
 SELC55   BSS
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    ADPTERR     RECOVER ERROR
*         (NO RETURN FROM ADPTERR.)

* ISSUE PRIORITY OVERRIDE.

 SELC60   BSS
          AOML   SELC700+1   SELC700 - SELC600 = NO. OF UNRECOVERED
                             CONTROLLER RESERVED ERRORS
          SHN    -16
          AOML   SELC700
          LDK    /RS/K.CRS   CONTROLLER RESERVED
          RJM    SERRID      PUT ERROR ID IN RESPONSE
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          LDML   SELTRY
          NJK    SELC48      IF NOT TIMED OUT
          SOML   PRITRY      DECREMENT RETRY COUNTER
          ZJK    SELC55      IF UNRECOVERED ERROR
          AOML   SELC600+1   NUMBER OF ATTEMPTS TO ISSUE PRIORITY OVERRIDE
          SHN    -16
          RAML   SELC600
          LDC    T.SEL+T.PO  SELECT WITH PRIORITY OVERRIDE
          ADDL   CMOD        CONTROLLER NUMBER
          STDL   CMFUN
          LJM    SELC8

          SPACE  6
 SELTO    BSSZ   1           SELECT TIMEOUT VALUE
 SELTRY   BSSZ   1           SELECT RETRY COUNTER
 PRITRY   BSSZ   1           PRIORITY OVERRIDE RETRY COUNTER
 CSATRY   BSSZ   1           RETRY COUNTER TO CLEAR SELECT ACTIVE
 SELC100  BSSZ   2           SELECT TIMEOUT COUNTER
                             EACH TIME SELC100 IS INCREMENTED, THEN EITHER
                             SELC200 OR SELC300 IS INCREMENTED.
 SELC200  BSSZ   2           IF NOT BUSY ON FIRST READ OF IDLE STATUS
 SELC300  BSSZ   2           IF BUSY ON FIRST READ OF IDLE STATUS
 SELC400  BSSZ   2           STILL BUSY AFTER BUSY TIMEOUT
 SELC500  BSSZ   2           ALL SELECT RETRIES FAILED, LOG 'CANNOT SELECT'
 SELC600  BSSZ   2           NUMBER OF TIMES PRIORITY OVERRIDE WAS ISSUED
 SELC700  BSSZ   2           SELC700 - SELC600 IS THE NUMBER OF UNRECOVERED
                             'CONTROLLER RESERVED'
          EJECT
** NAME-- SELCK
*
** PURPOSE-- IF THE CONTROLLER IS NOT SELECTED, SELECT IT.
          SPACE  6
 SELCKX   LJM    **
 SELCK    EQU    *-1
          RJM    SELCM       SELECT THE CONTROLLER
          UJK    SELCKX
          EJECT
** NAME-- ROPS
*
** PURPOSE-- READ OPERATIONAL STATUS.
          SPACE  6
 ROPSX    LJM    **
 ROPS     EQU    *-1
          LDK    F.RDOS      READ OPERATIONAL STATUS
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    OPSTAT,DC
          DCN    DC+40B      DEACTIVATE CHANNEL
 K13      IFEQ   TRACE,1
          LDDL   OPSTAT
          RJM    TBUF        PUT IN TRACE BUFFER
 K13      ENDIF
          CFM    ROPSX,DC    CHECK AND CLEAR CHANNEL ERROR
          RJM    CHNERR      RECORD CHANNEL ERROR
*         (RETURNS IF ERRORS ARE TO BE IGNORED.)

          UJK    ROPSX
          EJECT
** NAME-- WAITTR
*
** PURPOSE-- WAIT FOR TRANSFER IN PROGRESS TO CLEAR.
          SPACE  6
 WAIX     LJM    **
 WAITTR   EQU    *-1
 WAI10    BSS
          LDK    F.RDOS      READ OPERATIONAL STATUS
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    OPSTAT,DC
          DCN    DC+40B      DEACTIVATE CHANNEL
          CFM    WAI20,DC    CHECK AND CLEAR CHANNEL ERROR
          RJM    CHNERR      RECORD CHANNEL ERROR
*         (RETURNS IF ERRORS ARE TO BE IGNORED.)

 WAI20    BSS
 K14      IFEQ   TRACE,1
          LDDL   OPSTAT
          RJM    TBUF        PUT IN TRACE BUFFER
 K14      ENDIF

          LDDL   OPSTAT
          SHN    17-0
          PJK    WAIX        IF TRANSFER NOT IN PROGRESS

* TEMPORARY, ADD A TIMEOUT.

          UJK    WAI10
          EJECT
** NAME-- FUNC
*
** PURPOSE-- ISSUE FUNCTION TO DISK CONTROLLER.
*
** INPUT-- A REGISTER = FUNCTION CODE.
*
** OUTPUT-- CHANNEL IS INACTIVE.
          SPACE  6
 FUNX     LJM    **
 FUNC     EQU    *-1
          STDL   FUNCD       SAVE FUNCTION CODE
 K15      IFEQ   TRACE,1
          STML   FBUF,FI     SAVE HISTORY OF FUNCTIONS ISSUED
 K15      ENDIF
          AJM    FUN30,DC    IF CHANNEL ACTIVE
          FAN    DC          ISSUE THE FUNCTION
 K16      IFEQ   TRACE,1
          AODL   FI          INCREMENT FUNCTION BUFFER INDEX
          ADC    -FBUFL
          NJN    FUN4        IF NOT END OF BUFFER
          STDL   FI          INITIALIZE INDEX
 FUN4     BSS
 K16      ENDIF
          IJM    FUNX,DC     EXIT IF CHANNEL INACTIVE

* TIMEOUT 500 MILLISECONDS ON ALL FUNCTIONS

          LDC    377777B
 FUN10    IJM    FUNX,DC     EXIT IF CHANNEL INACTIVE
          SBN    1
          NJN    FUN10

          LDC    377777B
 FUN20    IJM    FUNX,DC     EXIT IF CHANNEL INACTIVE
          SBN    1
          NJN    FUN20

*
* DISK CHANNEL ERROR.
*

 FUN30    BSS
          LDML   IGNORE
          NJK    FUNX        IGNORE ERRORS
          LDK    /RS/K.FTO   SET FUNCTION TIMEOUT FLAG IN RESPONSE
          RJM    SERR        ERROR ID
          LDML   RS+/RS/P.FUNTO
          NJN    FUN45       IF FUNCTION CODE ALREADY IN RESPONSE BUFFER
          LDDL   FUNCD       PUT FUNCTION CODE IN RESPONSE BUFFER
          STML   RS+/RS/P.FUNTO
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
 FUN45    BSS
          RJM    ADPTERR     PROCESS FUNCTION TIMEOUT ERROR
*         (NO RETURN FROM ADPTERR.)
          EJECT
** NAME-- FUNCB
*
** PURPOSE-- ISSUE FUNCTION TO DISK CONTROLLER.
*            DOES NOT CALL ADPTERR IF FUNCTION TIMEOUT.
*
** INPUT-- A REGISTER = FUNCTION CODE.
*
** OUTPUT-- CHANNEL IS INACTIVE.
          SPACE  6
 FUNBX    LJM    **
 FUNCB    EQU    *-1
          STDL   FUNCD       SAVE FUNCTION CODE
 K17      IFEQ   TRACE,1
          STML   FBUF,FI     SAVE HISTORY OF FUNCTIONS ISSUED
 K17      ENDIF
          DCN    40B+DC
          AJM    FUNB30,DC   IF CHANNEL ACTIVE
          FAN    DC          ISSUE THE FUNCTION
 K18      IFEQ   TRACE,1
          AODL   FI          INCREMENT FUNCTION BUFFER INDEX
          ADC    -FBUFL
          NJN    FUNB4       IF NOT END OF BUFFER
          STDL   FI          INITIALIZE INDEX
 FUNB4    BSS
 K18      ENDIF
          IJM    FUNBX,DC    EXIT IF CHANNEL INACTIVE

* TIMEOUT 500 MILLISECONDS ON ALL FUNCTIONS

          LDC    377777B
 FUNB10   IJM    FUNBX,DC    EXIT IF CHANNEL INACTIVE
          SBN    1
          NJN    FUNB10

          LDC    377777B
 FUNB20   IJM    FUNBX,DC    EXIT IF CHANNEL INACTIVE
          SBN    1
          NJN    FUNB20

*
* DISK CHANNEL ERROR.
*

 FUNB30   BSS
          LDK    /RS/K.FTO   SET FUNCTION TIMEOUT FLAG IN RESPONSE
          RJM    SERR        ERROR ID
          LDML   RS+/RS/P.FUNTO
          NJN    FUNB45      IF FUNCTION CODE ALREADY IN RESPONSE BUFFER
          LDDL   FUNCD       PUT FUNCTION CODE IN RESPONSE BUFFER
          STML   RS+/RS/P.FUNTO
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
 FUNB45   BSS
          UJK    FUNBX
          EJECT
** NAME-- STATUS
*
** PURPOSE-- READ HYDRA STATUS BLOCK FROM CONTROLLER.
          SPACE  6
 STATX    LJM    **
 STATUS   EQU    *-1
          LDN    3
          STML   STAT200     RETRY COUNTER

* READ HYDRA STATUS BLOCK.

 STAT2    BSS
          LDK    F.SCS       SET SELECT HOLD AND COMMAND SEQUENCE
          RJM    FUNC
 K19      IFEQ   TRACE,1
          LDML   FW.STAT
          RJM    TBUF        PUT IN TRACE BUFFER
 K19      ENDIF
          ACN    DC
          LDN    1
          OAM    FW.STAT,DC  SEND FUNCTION TO READ HYDRA STATUS
          RJM    DCN         DISCONNECT THE CHANNEL
          ACN    DC
          LDN    6
          IAM    CMSTAT,DC   READ HYDRA STATUS
          NJK    STAT90      IF INPUT DID NOT COMPLETE
          DCN    DC+40B      DEACTIVATE CHANNEL
          CFM    STAT3,DC    CHECK AND CLEAR CHANNEL ERROR
          RJM    CHNERR      RECORD CHANNEL ERROR
*         (RETURNS IF ERRORS ARE TO BE IGNORED.)

 STAT3    BSS
          LDK    F.CCS       CLEAR COMMAND SEQUENCE
          RJM    FUNC

* SAVE STATUS IN TRACE BUFFER

 K20      IFEQ   TRACE,1
          LDML   CMSTAT
          RJM    TBUF        PUT IN TRACE BUFFER
 K20      ENDIF
          LDML   CMSTAT
          LPC    177760B
          ADDL   UX
          STML   SBUF,SI     SAVE HISTORY OF STATUS
          AODL   SI          INCREMENT STATUS BUFFER INDEX
          SBN    SBUFL
          NJN    STAT4       IF NOT END OF BUFFER
          STDL   SI          INITIALIZE STATUS BUFFER INDEX

* CHECK IF SELECT ACTIVE DROPPED.

 STAT4    BSS
          LDK    F.RDOS      READ OPERATIONAL STATUS
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    OPSTAT,DC
          DCN    DC+40B      DEACTIVATE CHANNEL
          CFM    STAT6,DC    CHECK AND CLEAR CHANNEL ERROR
          RJM    CHNERR      RECORD CHANNEL ERROR
*         (RETURNS IF ERRORS ARE TO BE IGNORED.)

 STAT6    BSS
 K21      IFEQ   TRACE,1
          LDDL   OPSTAT
          RJM    TBUF        PUT IN TRACE BUFFER
 K21      ENDIF

          LDDL   OPSTAT
          SHN    17-9        CHECK IF SELECT ACTIVE IS STILL SET
          PJK    STAT93      IF SELECT ACTIVE DROPPED WHEN READING STATUS

* IF EXECUTION STATUS IS 0, 3, OR 5, REREAD THE STATUS.

          LDML   CMSTAT      GET EXECUTION STATUS
          SHN    -11
          LPN    7
          ZJN    STAT12      IF BAD EXECUTION STATUS
          SBN    3
          ZJN    STAT12      IF BAD EXECUTION STATUS
          SBN    5-3
          NJN    STAT18      IF VALID EXECUTION STATUS
 STAT12   BSS
          LDK    /RS/K.IES   INVALID EXECUTION STATUS
          LJM    STAT92

* DON'T LOG STATUS IF DELAY STATUS = 81(16) OR 83(16).

 STAT18   BSS
          LDML   CMSTAT
          LPC    43400B      CHECK END, SYSTEM INTERVENTION STATUS,
                             MANUAL INTERVENTION STATUS, DELAY STATUS
          ZJN    STAT50
          LPC    43000B
          NJN    STAT60
          LDML   CMSTAT+3
          LPC    377B
          ADC    -203B
          NJN    STAT60      IF DELAY STATUS IS NOT 83(16),
                             RESET COMPLETED

* CLEAR ATTENTION.

 STAT50   BSS
          TIMER  TM18
          LDK    F.SCS       SET SELECT HOLD AND COMMAND SEQUENCE
          RJM    FUNC
          ACN    DC
          LDN    1
          OAM    FW.CA,DC    SEND FUNCTION TO CLEAR ATTENTION
          RJM    DCN         DISCONNECT THE CHANNEL
          LDK    F.CCS       CLEAR COMMAND SEQUENCE
          RJM    FUNC
          TIMER  TM19
          UJK    STATX

* READ DEVICE STATUS BLOCK.

 STAT60   BSS
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE

* READ DEVICE STATUS BLOCK.

 STAT62   BSS
          LDK    F.SCS       SET SELECT HOLD AND COMMAND SEQUENCE
          RJM    FUNC
          LDK    W.DST       READ DEVICE STATUS BLOCK
          STDL   CMFUN
 K22      IFEQ   TRACE,1
          RJM    TBUF        PUT IN TRACE BUFFER
 K22      ENDIF
          ACN    DC
          LDN    1
          OAM    CMFUN,DC    SEND FUNCTION TO CONTROLLER
          RJM    DCN         DISCONNECT THE CHANNEL
          ACN    DC
          LDN    4
          IAM    RS+/RS/P.DST2,DC  READ DEVICE STATUS
          NJK    STAT110     IF INPUT DID NOT COMPLETE
          RJM    INC         CHECK IF CHANNEL IS INACTIVE
          LDK    /RS/K.DSP   SET FLAG FOR DEVICE STATUS PRESENT
          RJM    SDET        PUT IN RESPONSE
          LDK    F.CCS       CLEAR COMMAND SEQUENCE
          RJM    FUNC

* PUT CONTROLLER STATUS IN RESPONSE.

          RJM    STRS        PUT CONTROLLER STATUS IN RESPONSE
          UJK    STAT50

* CHANNEL DISCONNECTED WHEN READING CONTROLLER STATUS.

 STAT90   BSS
          STML   RS+/RS/P.FUNTO  NUMBER OF PP WORDS NOT RECEIVED
          LDK    /RS/K.ISTT  INCOMPLETE CONTROLLER STATUS TRANSFER
 STAT92   BSS
          RJM    SID2        PUT ERROR ID IN RESPONSE
 STAT93   BSS
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    STRS        PUT CONTROLLER STATUS IN RESPONSE
          RJM    ROPS        READ OPERATIONAL STATUS
          LDDL   OPSTAT      OPERATIONAL STATUS
          SHN    17-9        CHECK IF SELECT ACTIVE IS STILL SET
          MJN    STAT95      IF SELECT ACTIVE IS STILL SET
          LDK    /RS/K.SADST  SELECT ACTIVE DROPPED WHEN READING
                             CONTROLLER STATUS
          RJM    SID2        PUT ERROR ID IN RESPONSE
 STAT95   BSS
          LDK    F.CCS       CLEAR COMMAND SEQUENCE
          RJM    FUNC
          RJM    SELCM       SELECT THE CONTROLLER
          SOML   STAT200     DECREMENT RETRY COUNTER
          NJK    STAT2       IF RETRY IS NOT EXHAUSTED

* CLEAR ATTENTION.

 STAT100  BSS
          LDK    F.SCS       SET SELECT HOLD AND COMMAND SEQUENCE
          RJM    FUNC
          LDK    W.CA        CLEAR ATTENTION
          STDL   CMFUN
          ACN    DC
          LDN    1
          OAM    CMFUN,DC    SEND FUNCTION TO CONTROLLER
          RJM    DCN         DISCONNECT THE CHANNEL
          LDK    F.CCS       CLEAR COMMAND SEQUENCE
          RJM    FUNC

          RJM    ADPTERR     TRY TO RECOVER
*         (NO RETURN FROM ADPTERR)

* CHANNEL DISCONNECTED WHEN READING DEVICE STATUS.

 STAT110  BSS
          STML   RS+/RS/P.FUNTO  NUMBER OF PP WORDS NOT TRANSFERRED
          LDK    /RS/K.IDS   INCOMPLETE DEVICE STATUS TRANSFER
          RJM    SID2        PUT ERROR ID IN RESPONSE
          RJM    STRS        PUT CONTROLLER STATUS IN RESPONSE
          RJM    ROPS        READ OPERATIONAL STATUS
          LDDL   OPSTAT      OPERATIONAL STATUS
          SHN    17-9        CHECK IF SELECT ACTIVE IS STILL SET
          MJN    STAT120     IF SELECT ACTIVE IS STILL SET
          LDK    /RS/K.SADDS  SELECT ACTIVE DROPPED WHEN READING
                             DEVICE STATUS
          RJM    SID2        PUT ERROR ID IN RESPONSE
 STAT120  BSS
          LDK    F.CCS       CLEAR COMMAND SEQUENCE
          RJM    FUNC
          RJM    SELCM       SELECT THE CONTROLLER
          SOML   STAT200     DECREMENT RETRY COUNTER
          NJK    STAT62      IF RETRY IS NOT EXHAUSTED
          UJK    STAT100
          SPACE  6
 STAT200  BSSZ   1           RETRY COUNTER
          EJECT
** NAME-- STRS
*
** PURPOSE-- PUT CONTROLLER STATUS IN RESPONSE
          SPACE  6
 STRSX    LJM    **
 STRS     EQU    *-1

* PUT STATUS BLOCK IN RESPONSE.

          LDN    6
          STDL   T1
 STRS10   BSS
          LDML   CMSTAT-1,T1  PUT STATUS IN RESPONSE
          STML   RS+/RS/P.CMST2-1,T1
          SODL   T1
          NJN    STRS10

          LDML   RS+/RS/P.DET  CHECK IF FIRST TIME FOR CONTROLLER STATUS
          LPK    /RS/K.CSP
          NJK    STRSX       IF NOT THE FIRST TIME FOR THIS ERROR
          LDK    /RS/K.CSP   SET FLAG FOR CONTROLLER STATUS PRESENT
          RJM    SDET        PUT ID IN RESPONSE
          LDN    10
          STDL   T1
 STRS20   BSS
          LDML   RS+/RS/P.CMST2-1,T1  MOVE STATUS FOR RESPONSE
          STML   RS+/RS/P.CMST1-1,T1
          SODL   T1
          NJK    STRS20
          UJK    STRSX
          EJECT
** NAME-- DCN
*
** PURPOSE-- DISCONNECT CHANNEL AFTER SENDING DATA.
          SPACE  6
 DCNX     LJM    **
 DCN      EQU    *-1
          ZJN    DCN10       IF TRANSFER WAS COMPLETE
          STML   RS+/RS/P.FUNTO  NUMBER OF CHANNEL WORDS NOT TRANSFERRED
          LDK    /RS/K.IST   INCOMPLETE SECTOR TRANSFER
          UJN    DCN40

 DCN10    BSS
          CFM    DCN20,DC    CHECK AND CLEAR CHANNEL ERROR
          RJM    CHERO       RECORD CHANNEL ERROR
*         (NO RETURN FROM CHERO.)

 DCN20    BSS
          EJM    DCN50,DC    IF CHANNEL IS EMPTY
          LDK    31          SET TIMEOUT FOR 2 SECONDS
          STDL   T2
 DCN25    BSS
          LDC    100000B
          STDL   T1
 DCN30    BSS
          EJM    DCN50,DC    IF CHANNEL IS EMPTY
          SODL   T1
          NJN    DCN30
          SODL   T2
          NJK    DCN25
          AOML   DCNCNT
          LDK    /RS/K.CEMPT  CHANNEL DOESNT GO EMPTY
 DCN40    BSS
          RJM    SERRID      SAVE ERROR FLAG
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    ADPTERR     RECOVER ERROR
*         (NO RETURN FROM ADPTERR.)

 DCN50    BSS
          DCN    DC+40B
          UJK    DCNX

 DCNCNT   BSSZ   1
          EJECT
** NAME-- INC
*
** PURPOSE-- CHECK FOR CHANNEL ERRORS AFTER INPUTING DATA.
          SPACE  6
 INCX     LJM    **
 INC      EQU    *-1
          DCN    DC+40B      DEACTIVATE CHANNEL
          CFM    INCX,DC     CHECK AND CLEAR CHANNEL ERROR
          RJM    CHNERR      RECORD CHANNEL ERROR
*         (RETURNS IF ERRORS ARE TO BE IGNORED.)

          UJK    INCX
          EJECT
** NAME-- TERMP
*
** PURPOSE-- TERMINATE PP REQUEST.
*
** OUTPUT-- RS+/RS/P.RC = RESPONSE CODE
          SPACE  6
 TERX     LJM    **
 TERMP    EQU    *-1
          RJM    PUTRC       PUT RESPONSE CODES IN RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
          RJM    ZRESP       ZERO OUT RESPONSE BUFFER
          UJK    TERX
          EJECT
** NAME-- TERMC.
*
** PURPOSE-- TERMINATE UNIT REQUEST.
*
** OUTPUT-- RS+/RS/P.RC = RESPONSE CODE.
*           SEKCNT.
          SPACE  6
 TERMC    CON    0           NORMAL TERMINATION
          TIMER  TM14

* NORMAL READ / WRITE TERMINATION.
* IF DELAY STATUS, READ THE ERROR LOG.

 M4       IFNE   CMSE,1
          LDML   CMSTAT      CONTROLLER STATUS
          SHN    17-8
          PJN    TERM20      IF DELAY STATUS IS NOT VALID
          RJM    ELOG        READ ERROR LOG
          LDN    12
          STML   SS+/SS/P.CMND  SET COMMAND PROCESSOR INDEX
 TERM10   BSS
          RJM    SAVSS       SAVE SS ENTRY
          LJM    MAIN10      WAIT FOR ATTENTION AND DATA AVAILABLE
 M4       ENDIF

* ENTRY WHEN DATA AVAILABLE FOR ERROR LOG.

 TERMD    CON    0
 M5       IFNE   CMSE,1
          RJM    ELA         READ ERROR LOG
          UJK    TERM10
 M5       ENDIF

* ENTRY WHEN READ ERROR LOG COMMAND COMPLETE.

 TERME    CON    0
 TERM20   BSS
          LDML   SS+/SS/P.TOTAL  MAKE SURE ALL BYTES WERE TRANSFERRED
          ADML   SS+/SS/P.TOTAL+1
          ADML   SS+/SS/P.LISTL
          ADML   SS+/SS/P.NUMCM
          ZJN    TERM30      IF NO ERROR
          RJM    TERMA       CONTROLLER INTERFACE ERROR
*         (NO RETURN FROM TERMA.)

 TERM30   BSS
          LDML   RS+/RS/P.RESPL  CHECK IF THERE WAS A RECOVERED ERROR
          SBN    8
          ZJN    TERM        IF NO RECOVERED ERROR
          LDK    /RS/K.REC   SET RECOVERED ERROR
          STML   RCON        ADDITIONAL RESPONSE CONDITION
          UJN    TERM

 TERMA    CON    0
          LDK    /RS/K.ADPT  CONTROLLER INTERFACE ERROR
          RJM    SERRID      ERROR ID
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    ADPTERR     RECOVER ERROR
*         (NO RETURN FROM ADPTERR.)
          SPACE  6
 TERM     BSS
          RJM    PUTRC       PUT RESPONSE CODES IN RESPONSE
          RJM    SNDWRS      SEND WRITE RESPONSES
          RJM    RESP        SEND RESPONSE TO CPU
          LDML   NODEL
          NJN    TERM50      IF NO DELINK OF REQUEST
          TIMER  TM15
          RJM    DELRQ       DELETE COMPLETED REQUEST FROM QUEUE
                             AND SELECT NEW REQUEST.
          TIMER  TM16
 TERM50   BSS
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
          SODL   SEKCNT      DECREMENT OUTSTANDING SEEK COUNT
          PJN    TERM80      IF VALID SEKCNT

* NOTE, A REQUEST CAN TERMINATE ABNORMALLY BEFORE SEKCNT IS
* INCREMENTED. THEREFORE, MAKE SURE SEKCNT IS NOT NEGATIVE.

          LDN    0
          STDL   SEKCNT      REINITIALIZE
 TERM80   BSS
 TERM90   BSS
          RJM    CFLGS       CLEAR FLAGS
          LDML   SS+/SS/P.SEEK  CLEAR SEEK ISSUED FLAG
          LPC    -/SS/K.SEEK
          STML   SS+/SS/P.SEEK
          LDML   CLEARL      NONZERO IF LOCK SHOULD BE CLEARED NOW
                             (UNIT WAS DISABLED)
          ADDL   PIDLE       IF PRE-IDLE FLAG IS SET, DON'T ISSUE A SEEK
          NJN    TERM93      IF UNIT WAS DISABLED, DON'T ISSUE ANOTHER SEEK
          LDML   SS+/SS/P.CUR  CHECK IF NEXT REQUEST HAS BEEN SELECTED
          SHN    /SS/L.CUR+2
          PJN    TERM92      IF CURRENT REQUEST WAS NOT SELECTED
          RJM    SEEKI       ISSUE INITIAL SEEK
 TERM92   BSS
          LDDL   UX          CLEAR LOCK ONLY IF A DIFFERENT LOCK IS SET
          STDL   LOCKS
          UJN    TERM95

 TERM93   BSS
          LDML   CHANT+/CH/P.DOWN,CH
          NJN    TERM94      IF CHANNEL DOWN, DON'T EXECUTE ON CHANNEL
          RJM    CSHOLD      CLEAR SELECT HOLD IF IT IS SET
 TERM94   BSS
          RJM    CLRLOCK     CLEAR LOCK ON UNIT
          LDN    0
          STML   CLEARL      CLEAR LOCK FLAG

 TERM95   BSS
          TIMER  TM17
          UJK    MAIN50
          EJECT
** NAME-- CFLGS
*
** PURPOSE-- CLEAR FLAGS WHEN TERMINATING A REQUEST OR
*            PROCESSING AN IDLE COMMAND.
          SPACE  6
 CFLGX    LJM    **
 CFLGS    EQU    *-1
          LDN    0
          STML   SS+/SS/P.RECOV  ZERO OUT ERROR RECOVERY INDEX
          STML   SS+/SS/P.MCTRY  MASTER CLEAR RETRY COUNTER
          ERRNZ  /SS/P.MCTRY-/SS/P.WTA
          ERRNZ  /SS/P.MCTRY-/SS/P.SRTRY
          ERRNZ  /SS/P.MCTRY-/SS/P.ERI
          ERRNZ  /SS/P.MCTRY-/SS/P.ELOG
          ERRNZ  /SS/P.MCTRY-/SS/P.NR
          STML   SS+/SS/P.RESET  CLEAR FLAG FOR RESET ISSUED
          ERRNZ  /SS/P.RESET-/SS/P.CONF
          ERRNZ  /SS/P.RESET-/SS/P.RVCNT
          STML   SS+/SS/P.NCOMW  ZERO OUT NUMBER OF RESPONSES TO SEND
          STML   RS+/RS/P.RTRY  ZERO OUT REQUEST RETRY COUNTER
          RJM    ZRESP       ZERO OUT RESPONSE BUFFER
          UJK    CFLGX
          EJECT
** NAME-- PUTRC
*
** PURPOSE-- PUT RESPONSE CODES IN RESPONSE
          SPACE  6
 PUTRCX   LJM    **
 PUTRC    EQU    *-1
          LDDL   RESPC       RESPONSE CODE
          SHN    /RS/L.RCON-/RS/L.RC+/RS/N.RCON-/RS/N.RC
          ADML   RCON        RESPONSE CONDITION
          SHN    /RS/L.URC-/RS/L.RCON+/RS/N.URC-/RS/N.RCON
          ERRNZ  /RS/P.URC-/RS/P.RCON
          ERRNZ  /RS/P.RC-/RS/P.URC
          STML   RS+/RS/P.URC
          UJK    PUTRCX
          EJECT
** NAME-- RESP
*
** PURPOSE-- WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
*
** INPUT-- CM.PIT, CM.RS, LIM, /PIT/IN, /PIT/OUT, RS+/RS/P.RESPL
*
** OUTPUT-- /PIT/IN, RESPONSE BUFFER
          SPACE  6
 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  6
 RESPX    LJM    **
 RESP     EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDN    0
          STML   STORS       SET FLAG TO STORE RESPONSE
          LDML   CM+/CM/P.STOR  CHECK IF CALLER WANTS RESPONSE
          SHN    /CM/L.STOR+2
          MJN    RESP10      IF STORE RESPONSE FLAG IS SET
          LDDL   RESPC       CHECK FOR NORMAL RESPONSE
          SBN    R.NRM
          NJN    RESP10      IF NOT NORMAL RESPONSE, STORE RESPONSE
          AOML   STORS       NONZERO MEANS DO NOT STORE RESPONSE
 RESP5    UJK    RESPX

* READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RESP10   BSS
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF 'IN' POINTER
          CRDL   P1          READ 'IN' POINTER

* CHECK IF A SHORT RESPONSE SHOULD BE SENT.

          LDML   RS+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          ZJK    RESP5       IF RESPONSE LENGTH = 0
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          SBN    1
          ZJN    RESP15      IF A SHORT RESPONSE
          LDN    0           CLEAR FLAG IF NOT SHORT RESPONSE
          UJN    RESP17

 RESP15   BSS
          LDML   RS+/RS/P.LU
          LPK    /RS/M.LUN
          ERRNZ  16-/RS/L.LUN-/RS/N.LUN
          ADK    /RS/K.SHORT  SET FLAG FOR SHORT RESPONSE
 RESP17   BSS
          STML   RS+/RS/P.SHORT

* CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDDL   INP
          SBDL   OUTP
          MJN    RESP20      IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP
 RESP20   LDML   RS+/RS/P.RESPL  GET RESPONSE LENGTH
          ADDL   INP
          STDL   INPNT       IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          MJN    RESP30      IF ENOUGH ROOM IN BUFFER
          LDN    1
          STML   RSP         SET PROCESSING RESPONSE FLAG
          RJM    PPREQ       CHECK IDLE AND ACTIVE FLAGS
          LDN    0
          STML   RSP
          UJK    RESP10

 RESP30   BSS
          LDN    0
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE
          LDDL   INP
          SHN    -3
          STDL   T3          'IN' POINTER IN WORDS
          LDDL   INPNT
          SBDL   LIM
          MJN    RESP50      IF IN + RESPONSE LENGTH .LT. LIMIT
                             ONLY 1 BLOCK WRITE
          STDL   INPNT       IN + RESPONSE LENGTH - LIMIT = NEW 'IN' POINTER
          SHN    -3
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE

* WRITE RESPONSE TO CM.

          LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADC    RS
          STML   RESP60      RESPONSE ADDRESS FOR 2ND BLOCK WRITE
 RESP50   BSS
          LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD 'IN' OFFSET
          CWML   RS,T4       WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          ZJN    RESP70      IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          LMC    400000B
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
                             (BEGINNING OF RESPONSE BUFFER)
 RESP60   EQU    *-1

 RESP70   BSS
          LJM    RESPX
          EJECT
** NAME-- RESPIN
*
** PURPOSE-- UPDATE THE 'IN' POINTER IN THE CM RESPONSE BUFFER.
*
** INPUT-- INPNT = NEW 'IN' POINTER.
          SPACE  6
 RESNX    LJM    **
 RESPIN   EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDML   STORS       CHECK IF CALLER WANTS RESPONSE
          NJK    RESNX       IF NO RESPONSE WAS SENT

* UPDATE THE 'IN' POINTER.

          LDN    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDDL   INPNT       NEW 'IN' POINTER
          STDL   P4
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   P1          WRITE NEW 'IN' POINTER TO CM

* INTERRUPT PROCESSOR. RESP ROUTINE SETS UP THIS INSTRUCTION.

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   PPNO-3      SET LAST BYTE NONZERO
 INTPRC   INPN   1           INTERRUPT OR PSN
          UJK    RESNX
          EJECT
** NAME-- RECRS
*
** PURPOSE-- IF AN ERROR HAS BEEN RECOVERED, SEND AN INTERMEDIATE
*            RESPONSE TO CM.
          SPACE  6
 D10      IFEQ   T1,0
 RECRSX   LJM    **
 RECRS    EQU    *-1
          LDML   RS+/RS/P.RESPL  RESPONSE LENGTH
          ADC    -C.RS*8
          NJN    RECRSX      IF NO ERRORS
          LDN    1
          ERRNZ  16-/SS/N.RVCNT-/SS/L.RVCNT
          RAML   SS+/SS/P.RVCNT  COUNT OF RECOVERED ERRORS PER REQUEST
          LPK    /SS/M.RVCNT
          SBN    RVTRY       HAS LIMIT BEEN REACHED
          PJK    RECRSX      IF TOO MANY RECOVERED ERRORS ON THIS REQUEST
          LDK    /RS/K.REC   RECOVERED ERROR
          STML   RCON        ADDITIONAL RESPONSE CONDITION
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          UJK    RECRSX
 D10      ENDIF
          EJECT
** NAME-- INTRS
*
** PURPOSE-- SEND INTERMEDIATE RESPONSE.
          SPACE  6
 INTRSX   LJM    **
 INTRS    EQU    *-1
          LDML   RS+/RS/P.PVA  PVA OF REQUEST
          ADML   RS+/RS/P.PVA+1
          ADML   RS+/RS/P.PVA+2
          NJN    INTRS10     IF REQUEST EXISTS
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          UJK    INTRSX

 INTRS10  BSS
          LDK    C.RS*8      SET RESPONSE LENGTH FOR ERROR
          STML   RS+/RS/P.RESPL
          LDN    R.INT       INTERMEDIATE RESPONSE
          STDL   RESPC       RESPONSE CODE
          RJM    TERMP       SEND RESPONSE TO CM
          UJK    INTRSX
          EJECT
** NAME-- CHNERR
*
** PURPOSE-- RECORD INPUT CHANNEL ERROR.
          SPACE  6
 CHNX     LJM    **
 CHNERR   EQU    *-1
          LDML   IGNORE
          NJK    CHNX        IGNORE ERRORS
          LDK    /RS/K.CHERR  INPUT CHANNEL ERROR
          RJM    CHER        RECORD CHANNEL ERROR
*         (NO RETURN FROM CHER.)

          EJECT
** NAME-- CHERO
*
** PURPOSE-- RECORD OUTPUT CHANNEL ERROR.
          SPACE  6
 CHERO    CON    0
          LDK    /RS/K.CHERO  OUTPUT CHANNEL ERROR
          RJM    CHER        RECORD CHANNEL ERROR
*         (NO RETURN FROM CHER.)

          EJECT
** NAME-- CHER
          SPACE  6
 CHER     CON    0
          RJM    SERR        SAVE ERROR ID

* READ ERROR STATUS REGISTER.

          LDK    F.RDES      READ ERROR STATUS
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    RS+/RS/P.ESREG,DC  ERROR STATUS REGISTER
          DCN    40B+DC      DISCONNECT CHANNEL
 K23      IFEQ   TRACE,1
          LDML   RS+/RS/P.ESREG
          RJM    TBUF        PUT IN TRACE BUFFER
 K23      ENDIF
          CFM    CHER10,DC   CLEAR CHANNEL ERROR FLAG
 CHER10   BSS
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    ADPTERR     RECOVER THE ERROR
*         (NO RETURN FROM ADPTERR.)
          EJECT
** NAME-- UNSOL
*
** PURPOSE-- PROCESS UNSOLICITED ATTENTION.
          SPACE  6
 UNSOL    CON    0
          LDML   CMSTAT      CHECK IF DELAY STATUS IS VALID
          SHN    17-8
          PJN    UNSOL10     IF DELAY STATUS NOT VALID
          LDML   CMSTAT+3    GET DELAY STATUS
          LPC    377B
          ADC    -203B       CHECK IF DELAY STATUS = 83,
                             RESET COMPLETED
          ZJN    UNSOL20     IF RESET COMPLETED
          LJM    RECD        ISSUE SELECTIVE RESET

 UNSOL10  BSS
          RJM    RECS        RECOVER ERROR
*         (NO RETURN FROM RECS.)

 UNSOL20  BSS
          LDML   SS+/SS/P.RESET
          SHN    /SS/L.RESET+2
          PJK    UNSOL10     IF RESET WAS NOT ISSUED
          SODL   CMNDS       DECREMENT COUNT OF OUTSTANDING COMMANDS
          LDML   SS+/SS/P.RESET  CLEAR RESET IN PROGRESS FLAG
          LPC    -/SS/K.RESET
          STML   SS+/SS/P.RESET
          LDK    /RS/K.SRS   SELECTIVE RESET WAS SUCCESSFUL
          RJM    SID         ERROR ID

* VERIFY SECTOR SIZE.

          LDK    F.SCS       SET SELECT HOLD AND COMMAND SEQUENCE
          RJM    FUNC
 K24      IFEQ   TRACE,1
          LDML   FW.SEC
          RJM    TBUF        PUT IN TRACE BUFFER
 K24      ENDIF
          ACN    DC
          LDN    1
          OAM    FW.SEC,DC   SEND FUNCTION TO READ SECTOR SIZE
          RJM    DCN         DISCONNECT THE CHANNEL
          ACN    DC
          LDN    1
          IAM    P1,DC       READ HYDRA SECTOR SIZE
          NJN    UNSOL35     IF INPUT DID NOT COMPLETE, TEMPORARY HALT
          DCN    DC+40B      DEACTIVATE CHANNEL
          CFM    UNSOL30,DC  CHECK AND CLEAR CHANNEL ERROR
          RJM    CHNERR      RECORD CHANNEL ERROR
*         (RETURNS IF ERRORS ARE TO BE IGNORED.)

 UNSOL30  BSS
          LDK    F.CCS       CLEAR COMMAND SEQUENCE
          RJM    FUNC
          LDDL   P1
          ADC    -4096
          ZJN    UNSOL40     IF SECTOR SIZE IS 4096
          LDK    /RS/K.SEC   NOT 4K SECTOR
          RJM    SDET        ERROR ID IN RESPONSE
          RJM    FAILAD      PUT THE FAILING ADDRESS IN RESPONSE
          RJM    UTERM       DISABLE THE UNIT
*         (NO RETURN FROM UTERM.)

 UNSOL35  BSS
          RJM    HALT        HALT THE PP
*         (NO RETURN FROM HALT.)

* VERIFY THE HYDRA HOST ID.

 UNSOL40  BSS
          LDK    F.SCS       SET SELECT HOLD AND COMMAND SEQUENCE
          RJM    FUNC
 K25      IFEQ   TRACE,1
          LDML   FW.HOST
          RJM    TBUF        PUT IN TRACE BUFFER
 K25      ENDIF
          ACN    DC
          LDN    1
          OAM    FW.HOST,DC  SEND FUNCTION TO READ HOST ID
          RJM    DCN         DISCONNECT THE CHANNEL
          ACN    DC
          LDN    1
          IAM    P1,DC       READ HYDRA HOST ID
          NJK    UNSOL35     IF INPUT DID NOT COMPLETE, TEMPORARY HALT
          DCN    DC+40B      DEACTIVATE CHANNEL
          CFM    UNSOL50,DC  CHECK AND CLEAR CHANNEL ERROR
          RJM    CHNERR      RECORD CHANNEL ERROR
*         (RETURNS IF ERRORS ARE TO BE IGNORED.)

 UNSOL50  BSS
          LDK    F.CCS       CLEAR COMMAND SEQUENCE
          RJM    FUNC
          LDDL   P1
          LPC    210B        BITS 3 AND 7 MUST BE EQUAL
          ZJN    UNSOL60     IF SAME HOST ID
          ADC    -210B
          ZJN    UNSOL60     IF SAME HOST ID
          LDK    /RS/K.HOST  NOT THE SAVE HOST ID
          RJM    SDET        ERROR ID IN RESPONSE
          RJM    FAILAD      PUT THE FAILING ADDRESS IN RESPONSE
          RJM    INTRS       SEND INTERMEDIATE RESPONSE

*         NOTE, DUAL ACCESS CAN'T RUN UNLESS BOTH PORTS HAVE THE SAME HOST ID.
*         BUT SINGLE ACCESS COULD RUN WITH DIFFERENT HOST IDS AS LONG AS
*         1 PORT IS DISABLED.  THEREFORE, THE UNIT IS NOT DISABLED.
*         DUAL ACCESS SHOULD GET AN TIMEOUT WAITING FOR THE NEXT ATTENTION.

* LOAD OPERATING MODE PARAMETERS.

 UNSOL60  BSS
          TIMER  TM20
          LDK    R.LOM       LOAD OPERATING MODE
          STML   SS+/SS/P.FUNC  PARAMETER IN COMMAND BLOCK
          LDN    0
          STML   SS+/SS/P.PCYL  SET COMMAND BLOCK PARAMETER = 0
          STML   SS+/SS/P.PTRK  SET COMMAND BLOCK PARAMETER = 0
          LDC    34403B+2000B  SELECT RECOVERY, WRITE BACKING FACTOR = 3
                             INHIBIT PARTIAL SECTOR TRANSFER (BIT 10)
          STML   SS+/SS/P.NSEC  SET OPERATING MODE PARAMETERS
          RJM    CMND        WRITE COMMAND BLOCK
          LDN    10          SET COMMAND PROCESSOR INDEX
          UJN    LOM10       SAVE SS ENTRY, GO TO MAIN
          SPACE  6
* ENTRY WHEN LOAD OPERATING MODE COMMAND IS COMPLETE.

 LOM      CON    0
          TIMER  TM21

* LOAD ATTENTION DELAY PARAMETERS.

          LDK    R.LAD       LOAD ATTENTION DELAY PARAMETERS
          STML   SS+/SS/P.FUNC  PARAMETER IN COMMAND BLOCK
          LDN    0
          STML   SS+/SS/P.PCYL  SET COMMAND BLOCK PARAMETER = 0
          STML   SS+/SS/P.PTRK  SET COMMAND BLOCK PARAMETER = 0
          LDC    401B        1 SECTOR BEFORE ATTENTION
          STML   SS+/SS/P.NSEC  SET ATTENTION DELAY PARAMETERS
          RJM    CMND        WRITE COMMAND BLOCK
          LDN    11
 LOM10    BSS
          STML   SS+/SS/P.CMND  SET COMMAND PROCESSOR INDEX
          UJN    LAD20       SAVE SS ENTRY, GO TO MAIN
          SPACE  6
* ENTRY WHEN LOAD ATTENTION DELAY COMMAND IS COMPLETE.

 LAD      CON    0
          TIMER  TM22
          LDML   SS+/SS/P.SRTRY
          LPK    /SS/K.SRTRY
          ZJN    LAD10       IF RESET WAS NOT ISSUED IN RECOVERY
          RJM    RECE        CONTINUE IN ERROR RECOVERY
*         (NO RETURN FROM RECE.)

 LAD10    BSS
          LDK    F.CSH       CLEAR SELECT HOLD
          RJM    FUNC
          LDML   SS+/SS/P.SEEK  CLEAR OUTSTANDING COMMAND FLAG
          LPC    -/SS/K.SEEK
          STML   SS+/SS/P.SEEK
          LDDL   UX          CLEAR THIS LOCK ONLY IF A NEW ONE IS SET
          STDL   LOCKS
          LDML   SS+/SS/P.CONF  CHECK IF DOING INITIAL CONFIDENCE TEST
          SHN    /SS/L.CONF+2
          PJN    LAD20       IF NOT DOING INITIAL CONFIDENCE TEST
          RJM    RSTRQ       RESTART CONFIDENCE TEST
 LAD20    BSS
          RJM    SAVSS       SAVE SS ENTRY
          LJM    MAIN10      GO TO MAIN LOOP
                             THIS ALLOWS THE INITIAL CONFIDENCE TEST TO BE RUN NEXT
          EJECT
* SEND UNSOLICITED MESSAGE.
          SPACE  6
 SNMSGX   LJM    **
 SNMSG    EQU    *-1
          LDK    C.RS*8      SET RESPONSE LENGTH FOR ERROR
          STML   RS+/RS/P.RESPL
          LDN    0           UNSOLICITED MESSAGE
          STDL   RESPC       RESPONSE CODE
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          RJM    TERMP       SEND RESPONSE TO CM
          UJK    SNMSGX
          EJECT
** NAME-- ATERM
*
** PURPOSE-- ABNORMAL TERMINATION FOR INTERFACE ERRORS.
          SPACE  6
 ATERM    CON    0
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          RJM    RDOVL       READ OVERLAY
          LJM    ATERMA
          EJECT
 SERRX    LJM    **
 SERR     EQU    *-1         SAVE ERROR ID
          STDL   T1
          LMC    -0
          STDL   T2
          LDML   RS+/RS/P.CHERR  ERROR ID
          LPDL   T2
          ADDL   T1          ADD ERROR FLAG
          STML   RS+/RS/P.CHERR
          UJK    SERRX
          EJECT
 SERRIX   LJM    **
 SERRID   EQU    *-1         SAVE ERROR ID
          STDL   T1
          LMC    -0
          STDL   T2
          LDML   RS+/RS/P.ERRID  ERROR ID
          LPDL   T2
          ADDL   T1          ADD ERROR FLAG
          STML   RS+/RS/P.ERRID
          UJK    SERRIX
          EJECT
 SIDX     LJM    **
 SID      EQU    *-1         SAVE ERROR ID
          STDL   T1
          LMC    -0
          STDL   T2
          LDML   RS+/RS/P.ID  ERROR ID
          LPDL   T2
          ADDL   T1          ADD ERROR FLAG
          STML   RS+/RS/P.ID
          UJK    SIDX
          EJECT
 SID2X    LJM    **
 SID2     EQU    *-1         SAVE ERROR ID
          STDL   T1
          LMC    -0
          STDL   T2
          LDML   RS+/RS/P.ID2  ERROR ID
          LPDL   T2
          ADDL   T1          ADD ERROR FLAG
          STML   RS+/RS/P.ID2
          UJK    SID2X
          EJECT
 SDETX    LJM    **
 SDET     EQU    *-1         SAVE ID
          STDL   T1
          LMC    -0
          STDL   T2
          LDML   RS+/RS/P.DET  ERROR ID
          LPDL   T2
          ADDL   T1          ADD ERROR FLAG
          STML   RS+/RS/P.DET
          UJK    SDETX
          EJECT
** NAME-- GETSS
*
** PURPOSE-- READ SS ENTRY FROM UNIT COMMUNICATION BUFFER IN
*            CM UNIT INTERFACE TABLE.
*
          SPACE  6
 GETSSX   LJM    **
 GETSS    EQU    *-1

* IF LOCKS = UX, THEN THE LOCK IS STILL SET, AND THE SS ENTRY IS STILL IN MEMORY.
* IF LOCKS = UX, RETURN.
* IF LOCKS = A DIFFERENT UX, CALL CSLOCK TO CLEAR THE OTHER LOCK.

          LDDL   LOCKS       CHECK IF LOCK IS STILL SET AND SS IN MEMORY
          SBDL   UX
          NJN    GETSS5      IF SS ENTRY IS NOT IN MEMORY
          LDML   UNITS+/UN/P.LUN,UX  VALIDATE LOGICAL UNIT NUMBER
          SBML   RS+/RS/P.LU
          ZJK    GETSSX      IF SS ENTRY IS IN MEMORY
          RJM    HALT        IF NOT THE CORRECT UNIT, TEMPORARY HALT
*         (NO RETURN FROM HALT.)

 GETSS5   BSS
          LDDL   LOCKS       CHECK IF A DIFFERENT LOCK IS SET
          SBN    NOLOCK
          ZJN    GETSS20     IF NO LOCK TO CLEAR
          LDML   SS+/SS/P.CONF  CHECK IF RUNNING INITIAL CONFIDENCE TEST
          LPK    /SS/K.CONF
          ADML   SS+/SS/P.RECOV  CHECK IF IN ERROR RECOVERY
          ZJN    GETSS10     IF NOT IN ERROR RECOVERY OR RUNNING CONFIDENCE TEST
          LDDL   UX          SAVE UX
          STDL   SAVUX
          LDDL   LOCKS       UX INDEX OF LOCK TO CLEAR
          STDL   UX
          RJM    SAVSS       SAVE SS ENTRY
          LDN    NOLOCK
          STDL   LOCKS       CLEAR LOCK FLAG
          LDDL   SAVUX       RESTORE UX
          STDL   UX
          UJN    GETSS20

 GETSS10  BSS
          RJM    CSLOCK      CLEAR THE OTHER LOCK

* READ SS ENTRY FROM UNIT COMMUNICATION BUFFER.

 GETSS20  BSS
          LDK    C.SS        NUMBER OF WORDS TO READ
          STDL   WC
          LOADR  UNITS+/UN/P.CB,UX  ADDRESS OF COMMUNICATION BUFFER
          CRML   SS,WC       READ SS ENTRY
          LDML   UNITS+/UN/P.LUN,UX  VALIDATE LOGICAL UNIT NUMBER
          SBML   RS+/RS/P.LU
          ZJK    GETSSX      IF THE CORRECT UNIT
          RJM    HALT        IF NOT THE CORRECT UNIT, TEMPORARY HALT
*         (NO RETURN FROM HALT.)
          SPACE  6
          EJECT
** NAME-- SAVSS
*
** PURPOSE-- WRITE THE SS ENTRY TO THE COMMUNICATION BUFFER
*            IN THE UNIT INTERFACE TABLE.
*
          SPACE  6
 SAVX     LJM    **
 SAVSS    EQU    *-1
          LDDL   UNUML
          ZJK    SAVX        IF NO UNITS
          LDML   UNITS+/UN/P.LUN,UX  VALIDATE THE LOGICAL UNIT NUMBER
          SBML   RS+/RS/P.LU
          NJN    SAV10       IF NOT THE CORRECT UNIT, TEMPORARY HALT
          LDDL   UX
          SBDL   UNUML
          PJK    SAVX        IF INVALID SS TABLE

* WRITE SS ENTRY TO COMMUNICATION BUFFER IN UNIT INTERFACE TABLE.

          LDK    C.SS        NUMBER OF WORDS TO WRITE
          STDL   WC
          LOADR  UNITS+/UN/P.CB,UX  ADDRESS OF COMMUNICATION BUFFER
          CWML   SS,WC       WRITE SS ENTRY
          UJK    SAVX

 SAV10    BSS
          RJM    HALT        HALT THE PP
*         (NO RETURN FROM HALT.)
          EJECT
** NAME-- ZRESP
*
** PURPOSE-- ZERO OUT PART OF THE RESPONSE BUFFER.
*
** NOTE-- THIS ROUTINE IS ALSO CALLED FOR RECOVERED ERROR RESPONSES.
          SPACE  6
 ZREX     LJM    **
 ZRESP    EQU    *-1
          LDN    0
          STML   RCON        RESPONSE CONDITION
          STML   NODEL       DON'T DELINK REQUEST FLAG
          STML   RS+/RS/P.HDWR  ABNORMAL STATUS
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE

          LDK    C.RS-/RS/C.FTRK
          STDL   WC
          LOADC  CM.CB       ADDRESS OF COMMUNICATION BUFFER
          ADK    /CB/C.ZERO
          CRML   RS+/RS/P.FTRK,WC  ZERO OUT PART OF RESPONSE BUFFER

          LDN    8           SET RESPONSE LENGTH FOR NORMAL RESPONSE
          STML   RS+/RS/P.RESPL
          LDN    R.NRM       SET RESPONSE CODE = NORMAL
          STDL   RESPC
          SHN    16-/RS/N.RC-/RS/L.RC
          STML   RS+/RS/P.RC  PUT RESPONSE CODE IN RESPONSE
          UJK    ZREX
          EJECT
** NAME-- SELRQ.
*
** PURPOSE-- SELECTS THE FIRST REQUEST IN THE CHAIN FOR THE
*            CURRENT REQUEST.
*
** INPUTS-- UNITS+/UN/P.UIT,UX = POINTER TO UNIT QUEUE TABLE.
*
** OUTPUTS-- RQ = CURRENT REQUEST.
*            SS+/SS/P.REQ
*            SS+/SS/P.CYL
*            SS+/SS/P.TRACK
*            SS+/SS/P.SECTOR
*            SS+/SS/M.CUR
*
** NOTE-- ASSUMES UNIT QUEUE LOCK HAS BEEN SET.
          SPACE  6
 SELRQX   LJM    **
 SELRQ    EQU    *-1

* READ RMA OF NEXT REQUEST FROM UNIT QUEUE.
* SET CURRENT REQUEST = FIRST REQUEST IN QUEUE.

          LDML   UNITS+/UN/P.QSTRT,UX  SET CURRENT QUEUE POINTER TO START OF CHAIN
          STML   SS+/SS/P.QP
          LDML   UNITS+/UN/P.QSTRT+1,UX
          STML   SS+/SS/P.QP+1
          LOADF  SS+/SS/P.QP  LOAD CM ADDRESS OF UNIT QUEUE TABLE
          CRDL   T1          READ RMA OF FIRST REQUEST IN CHAIN
          ADN    1
          CRDL   T1+4
          LDML   SS+/SS/P.CUR  CLEAR 'CURRENT REQUEST' FLAG
          LPC    -/SS/K.CUR
          STML   SS+/SS/P.CUR
          LDDL   T7
          STML   SS+/SS/P.REQ  SET RMA OF CURRENT REQUEST
          LDDL   T8
          STML   SS+/SS/P.REQ+1
          ADDL   T7
          ZJK    SELRQX      IF QUEUE EMPTY
          LDDL   T2          SET PVA OF CURRENT REQUEST
          STML   SS+/SS/P.PVA
          LDDL   T3
          STML   SS+/SS/P.PVA+1
          LDDL   T4
          STML   SS+/SS/P.PVA+2
          RJM    UREQ        READ SELECTED REQUEST INTO RQ
          LDML   RQ+/RQ/P.CYL
          STML   SS+/SS/P.CYL  CYLINDER ADDRESS OF CURRENT REQUEST
          LDML   RQ+/RQ/P.TRACK
          SHN    /SS/N.SECTOR  TRACK ADDRESS OF CURRENT REQUEST
          ADML   RQ+/RQ/P.SECTOR
          STML   SS+/SS/P.SECTOR  SECTOR ADDRESS OF CURRENT REQUEST

* SET CURRENT REQUEST FLAG.

          LDK    /SS/K.CUR   SET CURRENT REQUEST FLAG
          RAML   SS+/SS/P.CUR
          UJK    SELRQX
          EJECT
** NAME-- GETRQ
*
** PURPOSE-- GET FIRST REQUEST AND FIRST COMMAND.
*            SET UP STATUS RESPONSE BUFFER.
*            COMPUTE TOTAL BYTES TO TRANSFER
          SPACE  6
 GETRX    LJM    **
 GETRQ    EQU    *-1
          RJM    UREQ        READ UNIT REQUEST FROM CM
          RJM    SRESP       SET UP STATUS RESPONSE BUFFER
          RJM    SETRQ       SET UP FOR FIRST REQUEST
          RJM    UNCMND      GET FIRST COMMAND
          LDN    0
          STML   SS+/SS/P.SWFLG  CLEAR SWITCH FLAG

* COMPUTE TOTAL SECTORS TO TRANSFER.

          LDML   RQ+/RQ/P.MAUS  NUMBER OF SECTORS IN REQUEST
          LPK    /RQ/M.MAUS
          STDL   TOTAL
          LDML   SS+/SS/P.RECOV
          NJN    GETR20      IF IN ERROR RECOVERY, DONT STREAM
          LDML   RQ+/RQ/P.SWIT  CHECK SWITCH FLAG
          SHN    /RQ/L.SWIT+2
          PJN    GETR20      IF NO SWITCH TO NEXT REQUEST
          LOADF  RQ+/RQ/P.NEXT  READ NEXT REQUEST
 GETR10   BSS
          ADN    /RQ/C.MAUS
          CRDL   P1          P1 = SWIT AND MAUS
          SBN    /RQ/C.MAUS-/RQ/C.NEXT
          CRDL   P2          P4, P5 = RMA OF NEXT REQUEST
          LDDL   P1          GET NUMBER OF SECTORS IN THIS REQUEST
          LPK    /RQ/M.MAUS
          RADL   TOTAL       TOTAL SECTORS TO TRANSFER
          LDDL   P1          CHECK SWITCH FLAG
          SHN    /RQ/L.SWIT+2
          PJN    GETR20      IF NO SWITCH TO NEXT REQUEST
          LOADF  P4          READ NEXT REQUEST
          UJK    GETR10

 GETR20   BSS
          LDDL   TOTAL
          SHN    9
          LPC    177000B
          STML   SS+/SS/P.TOTAL+1  TOTAL CM WORDS TO TRANSFER
          LDDL   TOTAL
          SHN    -7
          STML   SS+/SS/P.TOTAL
          UJK    GETRX
          EJECT
** NAME-- SETRQ
*
** PURPOSE-- SET UP FOR FIRST REQUEST.
          SPACE  6
 SETRQX   LJM    **
 SETRQ    EQU    *-1
          LDML   SS+/SS/P.REQ  SAVE RMA OF REQUEST
          STML   SS+/SS/P.FCOMRQ  FIRST COMPLETED REQUEST (RMA)
          STML   SS+/SS/P.CURRQ  CURRENT REQUEST (RMA)
          STML   SS+/SS/P.CURRQ2  REQUEST TO BE RESTARTED DURING
                             ERROR RECOVERY
          LDML   SS+/SS/P.REQ+1
          STML   SS+/SS/P.FCOMRQ+1
          STML   SS+/SS/P.CURRQ+1
          STML   SS+/SS/P.CURRQ2+1
          LDN    1
          STML   SS+/SS/P.NCOMRQ  NUMBER OF COMPLETED REQUESTS
          RJM    SETADD      PUT STARTING ADDRESS IN RESPONSE BUFFER

* SET UP INTERRUPT PROCESSOR INSTRUCTION IF INTERRUPT IS SELECTED.

          LDML   RQ+/RQ/P.INT  CHECK IF INTERRUPT WAS SELECTED
          SHN    /RQ/L.INT+2
          MJN    SETR10      IF INTERRUPT SELECTED
          LDC    2400B       PSN INSTRUCTION
          UJN    SETR20

 SETR10   BSS
          LDML   RQ+/RQ/P.PORT  GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RQ/L.PORT+/RQ/N.PORT
          LPN    /RQ/M.PORT
          ADC    102600B     INPN INSTRUCTION
 SETR20   BSS
          STML   INTPRC
          UJK    SETRQX
          EJECT
** NAME-- SETADD
*
** PURPOSE-- SET STARTING DISK ADDRESS IN RESPONSE BUFFER.
          SPACE  6
 SETADDX  LJM    **
 SETADD   EQU    *-1
          LDML   CHANT,CH    CHANNEL NUMBER
          STML   RS+/RS/P.CHAN
          LDML   CHANT+/CH/P.PORT,CH  PORT B IF SET
          SHN    /CH/L.PORT-/RS/L.PORT
          RAML   RS+/RS/P.PORT

* PUT STARTING ADDRESS IN RESPONSE BUFFER.

          LDML   SS+/SS/P.CYL  STARTING CYLINDER ADDRESS
          STML   RS+/RS/P.SCYL
          LDML   SS+/SS/P.TRACK  TRACK
          SHN    -16+/SS/L.TRACK+/SS/N.TRACK
          STML   SS+/SS/P.CURTRK
          STML   RS+/RS/P.STRK
          LDML   SS+/SS/P.SECTOR  SECTOR
          LPK    /SS/M.SECTOR
          STML   SS+/SS/P.CURSEC
          STML   RS+/RS/P.SSEC
          UJK    SETADDX
          EJECT
** NAME-- SNDRSP
*
** PURPOSE-- SEND THE RESPONSE TO CM.
*            USED WHEN SWITCHING TO THE NEXT REQUEST.
          SPACE  6
 SNDX     LJM    **
 SNDRSP   EQU    *-1
          RJM    RESP        SEND RESPONSE TO CM
          RJM    RESPIN      UPDATE -IN- POINTER IN RESPONSE BUFFER
          LDN    1
          STDL   WC
          LOADF  SS+/SS/P.CURRQ2  GET PVA FOR NEXT RESPONSE
          CRML   RS,WC
          LDN    0
          STML   RS+/RS/P.XFER  TRANSFER COUNT
          STML   RS+/RS/P.XFER+1

          AOML   SS+/SS/P.NCOMRQ  INCREMENT NUMBER OF COMPLETED REQUESTS IN
                             WHICH RESPONSES HAVE BEEN SENT
          SOML   SS+/SS/P.NCOMW  DECREMENT NUMBER OF COMPLETED REQUESTS FOR
                             WHICH RESPONSES HAVE NOT BEEN SENT
          LDML   SS+/SS/P.CURRQ2  SAVE RMA OF REQUEST IN WHICH THE LAST
                             RESPONSE IS SENT
          STML   SS+/SS/P.PRERQ
          LDML   SS+/SS/P.CURRQ2+1
          STML   SS+/SS/P.PRERQ+1
          UJK    SNDX
          EJECT
** NAME-- SNDWRS
*
** PURPOSE-- SEND RESPONSES FOR REQUESTS THAT HAVE
*            BEEN SUCCESSFULLY STREAMED.
          SPACE  6
 SNDWX    LJM    **
 SNDWRS   EQU    *-1
          LDML   SS+/SS/P.NCOMW  NUMBER OF COMPLETED REQUESTS MINUS 1, FOR
                             WHICH A RESPONSE HAS NOT BEEN SENT
          ZJN    SNDWX       IF NO COMPLETED REQUESTS
          UJN    SNDW20

 SNDW10   BSS
          LDN    1
          STDL   WC
          LOADF  SS+/SS/P.CURRQ2  CM ADDRESS OF NEXT REQUEST
          ADN    /RQ/C.NEXT
          CRML   NRQ,WC      READ RMA OF NEXT REQUEST
          LDML   NRQ+2
          STML   SS+/SS/P.CURRQ2
          LDML   NRQ+3
          STML   SS+/SS/P.CURRQ2+1
 SNDW20   BSS
          RJM    SNDRSP      SEND RESPONSE TO CM
          LDML   SS+/SS/P.NCOMW  NUMBER OF RESPONSE LEFT TO SEND
          NJK    SNDW10      IF MORE RESPONSES TO SEND
          LDML   SS+/SS/P.REQ  SET CURRQ TO END OF CHAIN SO DELRQ WILL
                             DELINK ALL REQUESTS
          STML   SS+/SS/P.CURRQ
          LDML   SS+/SS/P.REQ+1
          STML   SS+/SS/P.CURRQ+1
          UJK    SNDWX
          EJECT
** NAME-- DELRQ.
*
** PURPOSE-- DELETE COMPLETED REQUEST FROM THE UNIT QUEUE.
*            SELECT A NEW CURRENT REQUEST BASED UPON CYLINDER ADDRESS.
*
** INPUTS-- UNITS+/UN/P.UIT = POINTER TO UNIT QUEUE TABLE
*           SS+/SS/P.NCOMRQ.
*           SS+/SS/P.CURRQ.
*
** OUTPUTS-- RQ = SELECTED REQUEST
*            SS+/SS/P.REQ
*            SS+/SS/P.CYL
*            SS+/SS/P.TRACK
*            SS+/SS/P.SECTOR
*            SS+/SS/M.CUR
*            SS+/SS/M.WRITE
*            /UIT/NEXT
*            /UIT/NEXTPV
*            /RQ/NEXT
*            /RQ/NEXTPV
*
** NOTE-- ASSUMES UNIT QUEUE LOCK HAS BEEN SET.
          SPACE  6
 DELX     LJM    **
 DELRQ    EQU    *-1
 DEL10    BSS
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    DEL10       IF LOCK COULD NOT BE SET

* DECREMENT QUEUE COUNTER.

          LOADR  UNITS+/UN/P.UIT,UX  LOAD CM ADDRESS OF UNIT QUEUE TABLE
          STDL   T1
          CRDL   P1          READ QUEUE COUNT
          ERRNZ  /UIT/C.QCNT
          LDDL   P1+/UIT/P.QCNT  DECREMENT QUEUE COUNT
          SBML   SS+/SS/P.NCOMRQ  NUMBER OF COMPLETED REQUESTS
          STDL   P1+/UIT/P.QCNT
          MJN    DEL20       IF INVALID QUEUE COUNT
          LDDL   T1
          LMC    400000B
          CWDL   P1          WRITE QUEUE COUNT

* RE-READ RMA CHAIN POINTERS OF CURRENT REQUEST.

 DEL20    BSS
          LDN    2
          STDL   P3
          LOADF  SS+/SS/P.CURRQ  RMA OF CURRENT REQUEST
          CRML   RQ,P3       READ RMA CHAIN OF CURRENT REQUEST

* DELINK REQUEST.
* (P3 = 2.)

 DEL30    BSS
          LOADF  SS+/SS/P.QP  CM ADDRESS OF LAST LINK ON QUEUE
          STDL   P2          SAVE CM ADDRESS
          ADN    1
          CRDL   T1          READ NEXT REQUEST POINTER
          ERRNZ  /RQ/C.NEXTPV
          ERRNZ  /RQ/C.NEXT-1
          ERRNZ  /UIT/C.NEXT-/UIT/C.NEXTPV-1

* CHECK IF NEXT REQUEST IN CHAIN = COMPLETED REQUEST.

          LDDL   T4
          SBML   SS+/SS/P.FCOMRQ+1  IS NEXT REQUEST IN CHAIN = COMPLETED REQUEST
          NJN    DEL40       IF NEXT REQUEST IN CHAIN IS NOT COMPLETED REQUEST
          LDDL   T3
          SBML   SS+/SS/P.FCOMRQ
          ZJN    DEL50       IF LINK FOUND TO COMPLETED REQUEST
 DEL40    BSS
          LDDL   T3          UPDATE CURRENT QUEUE POINTER
          STML   SS+/SS/P.QP
          LDDL   T4
          STML   SS+/SS/P.QP+1
          UJK    DEL30

* DELINK COMPLETED REQUESTS.
* (P3 = 2.)

 DEL50    BSS
          LDDL   P2          CM ADDRESS OF REQUEST
          ERRNZ  /RQ/C.NEXTPV
          LMC    400000B
          CWML   RQ,P3       PVA AND RMA OF NEXT REQUEST IN CHAIN

* CLEAR FLAGS IN SS ENTRY.

          LDML   SS+/SS/P.SEEK  CLEAR 'SEEK ISSUED', 'CURRENT REQUEST'
          LPC    -/SS/K.SEEK-/SS/K.CUR
          STML   SS+/SS/P.SEEK
          LDN    0
          STML   SS+/SS/P.NCOMRQ  CLEAR COMPLETED REQUEST COUNT

* SELECT NEXT REQUEST ON QUEUE.

          LDML   RQ+/RQ/P.NEXT  CHECK IF END OF QUEUE
          ADML   RQ+/RQ/P.NEXT+1
          NJN    DEL60       IF NEXT REQUEST EXISTS
          LDDL   P4          QUEUE COUNT
          ZJN    DEL60       IF QUEUE EMPTY
          RJM    SELRQ       SELECT FIRST REQUEST IN QUEUE
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          UJK    DELX

 DEL60    BSS
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          LDML   RQ+/RQ/P.NEXTPV  SAVE PVA OF NEXT REQUEST
          STML   SS+/SS/P.PVA
          LDML   RQ+/RQ/P.NEXTPV+1
          STML   SS+/SS/P.PVA+1
          LDML   RQ+/RQ/P.NEXTPV+2
          STML   SS+/SS/P.PVA+2
          LDML   RQ+/RQ/P.NEXT
          STML   SS+/SS/P.REQ  SAVE RMA ADDRESS OF NEXT REQUEST
          LDML   RQ+/RQ/P.NEXT+1
          STML   SS+/SS/P.REQ+1
          ADML   SS+/SS/P.REQ
          ZJN    DEL70       IF QUEUE EMPTY

* SET CURRENT REQUEST IN SS TO SELECTED REQUEST.

          RJM    UREQ        READ SELECTED REQUEST INTO RQ
          LDML   RQ+/RQ/P.CYL
          STML   SS+/SS/P.CYL  CYLINDER ADDRESS OF CURRENT REQUEST
          LDML   RQ+/RQ/P.TRACK
          SHN    /SS/N.SECTOR  TRACK ADDRESS
          ADML   RQ+/RQ/P.SECTOR
          STML   SS+/SS/P.SECTOR  SECTOR ADDRESS

          LDK    /SS/K.CUR   SET 'CURRENT REQUEST' FLAG
          RAML   SS+/SS/P.CUR
 DEL70    BSS
          UJK    DELX
          EJECT
** NAME-- CSLOCK
*
** PURPOSE-- CLEAR THE LOCK OF THE UNIT WHOSE UX INDEX IS IN LOCKS.
          SPACE  6
 CSLX     LJM    **
 CSLOCK   EQU    *-1
          LDDL   LOCKS       CHECK IF THERE IS A LOCK TO CLEAR
          SBN    NOLOCK
          ZJK    CSLX        IF NO LOCK TO CLEAR
          LDDL   UX          SAVE UX
          STDL   SAVUX
          LDDL   LOCKS       UX INDEX OF LOCK TO CLEAR
          STDL   UX
          RJM    CSHOLD      CLEAR SELECT HOLD IF IT IS SET
          RJM    CLRLOCK     CLEAR UNIT LOCK
          LDDL   SAVUX       RESTORE UX
          STDL   UX
          UJK    CSLX
          EJECT
** NAME-- SETLOCK
*
** PURPOSE-- SETS THE UNIT LOCK IN THE UNIT INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SETLX    LJM    **
 SETLOCK  EQU    *-1
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJK    SETLX       IF LOCK COULD NOT BE SET
          LDN    1
          STML   UNITS+/UN/P.LOCK,UX  SET UNIT LOCK FLAG
          RJM    GETSS       READ SS ENTRY FROM UNIT COMMUNICATION BUFFER
          RJM    SCLOCK      SET CHANNEL LOCK
          ZJK    SETLX       IF CHANNEL LOCK WAS SET
          RJM    CLRLOCK     CLEAR UNIT LOCK
          LDN    1           LOCK COULD NOT BE SET
          UJK    SETLX
          EJECT
** NAME-- SQLOCK
*
** PURPOSE-- SETS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SQLX     LJM    **
 SQLOCK   EQU    *-1
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          UJK    SQLX
          EJECT
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                   .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SCLX     LJM    **
 SCLOCK   EQU    *-1
          LDDL   UNUML
          ZJK    SCLX        IF NO UNITS
          LDML   CHANT+/CH/P.LOCK,CH
          STDL   P3
          LDIL   P3
          ZJN    SCL20       IF CHANNEL LOCK IS NOT SET
 SCL10    BSS
          LDN    0           EXIT A REGISTER = 0
 SCL15    UJK    SCLX

 SCL20    BSS
          LDK    C.CHCNT
          STML   CHLCNT      NUMBER OF REQUESTS TO PROCESS BEFORE
                             GIVING UP CHANNEL
          LDN    6           SET TIMEOUT DELAY TO 5 SECONDS ON S1
          STDL   P1
          STDL   P2
 SCL30    BSS
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDML   CHANT,CH    CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    SCL40       IF LOCK WAS NOT SET

* SET CHANNEL LOCK FLAG ON BOTH PORTS.

          AOIL   P3          SET CHANNEL LOCK FLAG
          UJK    SCL10       EXIT, LOCK WAS SET

 SCL40    BSS
          SODL   P1
          NJK    SCL30
          SODL   P2
          NJK    SCL30
          LDN    1           TIMEOUT ON TRYING TO GET CHANNEL LOCK
          UJK    SCL15       EXIT A REGISTER NONZERO
          EJECT
** NAME-- SPLOCK
*
** PURPOSE-- SETS THE PP REQUEST QUEUE LOCK IN THE
*            PP INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SPLX     LJM    **
 SPLOCK   EQU    *-1
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET THE LOCKWORD
          UJK    SPLX
          EJECT
** NAME-- LOCK
*
** PURPOSE-- SET A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS SET.
*         A REGISTER .NE. O, IF THE LOCK COULD NOT BE SET.
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T1 = 0, WRITE THE PP LOCKWORD TO CENTRAL MEMORY,
*            AS DESCRIBED IN THIS STEP.  ELSE IF T1 .NE. 0, GO TO
*            STEP 4.
*            TO WRITE THE PP LOCKWORD ID:
*            SET T1 - T4 = 8000 0000 0000 PPNO, WHERE PPNO IS THE
*            LOGICAL PP NUMBER OF THIS PP.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
*
*         4. IF T1 = 8000 AND T4 = PPNO, THIS LOCKWORD WAS ALREADY
*            RESERVED TO THIS PP.
*            RESTORE THE CENTRAL MEMORY LOCATION  (CWDL   T1).
*            SET THE A REGISTER = 0, AND EXIT.
*
*         5. IF T4 .NE. PPNO, THEN THIS LOCKWORD IS RESERVED TO
*            A DIFFERENT PROCESSOR.
*            SET BIT 16 OF THE LOCKWORD THAT WAS READ WITH THE
*            RDSL INSTRUCTION, AND WRITE THE CONTENTS BACK TO
*            CENTRAL MEMORY.
*            THE PURPOSE OF SETTING BIT 16 IS TO REQUEST THE
*            OTHER PROCESSOR TO GIVE UP THE LOCKWORD.
*            LDDL   T2
*            LPC    77777B
*            ADC    100000B
*            STDL   T2
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
          SPACE  6
 LOCKX    LJM    **
 LOCK     EQU    *-1

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 LOCK10   BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.

          LDDL   T1
          ADDL   T4
          ZJN    LOCK40      IF LOCK CAN BE SET

* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          NJN    LOCK20      IF THIS PP WAS FIRST TO WRITE
                             THE INTERMEDIATE VALUE
          AODL   LFF00
          UJK    LOCK10      REPEAT THE RDSL INSTRUCTION

* SET BIT 16 IN THE ORIGINAL CONTENTS OF CENTRAL MEMORY AND
* WRITE IT BACK TO CENTRAL MEMORY.

 LOCK20   BSS
          LDDL   T2          SET THE 'REQUEST LOCKWORD' FLAG
          LPC    77777B
          ADC    100000B
          STDL   T2
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE LOCKWORD

          LDDL   T4
          SBDL   PPNO        CHECK IF LOCK ALREADY SET
          NJN    LOCK30      IF LOCK COULD NOT BE SET, EXIT A .NE. 0
          LDDL   T1
          ADC    -100000B
 LOCK30   UJK    LOCKX       IF LOCK WAS ALREADY SET, EXIT A = 0
                             IF LOCK COULD NOT BE SET, EXIT A .NE. 0

* SET THE LOCKWORD.

 LOCK40   BSS
          LDC    100000B
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          LDDL   PPNO
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          SET THE LOCKWORD
          LDN    0
          UJK    LOCK30      EXIT, A REGISTER = 0
          EJECT
** NAME-- CLRLOCK
*
** PURPOSE-- CLEARS UNIT LOCK IN UNIT INTERFACE TABLE.
*
          SPACE  6
 CLRLX    LJM    **
 CLRLOCK  EQU    *-1
          RJM    SAVSS       WRITE SS ENTRY TO COMMUNICATION BUFFER
                               IN UNIT INTERFACE TABLE
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR UNIT LOCKWORD
          LDN    0
          STML   UNITS+/UN/P.LOCK,UX  CLEAR UNIT LOCK FLAG
          LDN    NOLOCK
          STDL   LOCKS       CLEAR LOCK FLAG
          UJK    CLRLX
          EJECT
** NAME-- CQLOCK
*
** PURPOSE-- CLEARS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
*
          SPACE  6
 CQLX     LJM    **
 CQLOCK   EQU    *-1
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CQLX
          EJECT
** NAME-- CCLOCK
*
** PURPOSE-- CLEARS CHANNEL LOCK.
*
          SPACE  6
 CCLX     LJM    **
 CCLOCK   EQU    *-1
          LDML   CHANT+/CH/P.LOCK,CH
          STDL   P3
          LDIL   P3
          ZJK    CCLX        IF CHANNEL LOCK WAS NOT SET
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDML   CHANT,CH    CHANNEL NUMBER = OFFSET IN TABLE
          STDL   T5
          RJM    CLOCK       CLEAR CHANNEL LOCKWORD

* CLEAR CHANNEL LOCK FLAG IN BOTH PORTS.

          LDN    0
          STIL   P3          CLEAR CHANNEL LOCK FLAG
          UJK    CCLX
          EJECT
** NAME-- CPLOCK
*
** PURPOSE-- CLEARS THE PP QUEUE LOCK IN THE PP INTERFACE TABLE.
*
          SPACE  6
 CPLX     LJM    **
 CPLOCK   EQU    *-1
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWROD
          UJK    CPLX
          EJECT
** NAME-- CLOCK
*
** PURPOSE-- CLEAR A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS CLEARED.
*         A REGISTER .NE. O, IF THE LOCK WAS NOT CLEARED.
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T4 .NE. PPNO, THIS LOCKWORD IS RESERVED TO A
*            DIFFERENT PROCESSOR.
*            RESTORE THE CONTENTS OF THIS CENTRAL MEMORY LOCATION
*            AS IT EXISTED BEFORE THE VALUE FFFF FFFF XXXX XXXX
*            WAS WRITTEN.
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
*
*         4. IF T4 = PPNO, THEN CLEAR THE LOCKWORD IN CENTRAL MEMORY.
*            SET T1 - T4 = 0000 0000 0000 0000.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
          SPACE  6
 CLKX     LJM    **
 CLOCK    EQU    *-1

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 CLK10    BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.
* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          NJN    CLK20       IF THIS PP WAS FIRST TO WRITE
                             THE INTERMEDIATE VALUE
          AODL   LFF00
          UJK    CLK10       REPEAT THE RDSL INSTRUCTION

 CLK20    BSS
          LDDL   T4          CHECK PP NUMBER
          SBDL   PPNO
          ZJN    CLK30       IF THIS PP HAS THE LOCK SET

* RESTORE THE ORIGINAL CONTENTS.

          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE ORIGINAL CONTENTS
          LDN    1
 CLK25    UJK    CLKX        EXIT, A REGISTER NONZERO

* CLEAR THE LOCKWORD.

 CLK30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          CLEAR THE LOCKWORD
          LDN    0
          UJK    CLK25       EXIT, A REGISTER = 0
          EJECT
** NAME-- CKCHAN
*
** PURPOSE-- CHECK IF MAINTENANCE PP WANTS THE CHANNEL.
          SPACE  6
 CKCX     LJM    **
 CKCHAN   EQU    *-1
          LDK    C.CHCNT
          STML   CHLCNT      NUMBER OF REQUESTS TO PROCESS BEFORE
                             GIVING UP THE CHANNEL
          LDN    0
          STDL   CH
          LDDL   UNUML
          ZJK    CKCX        IF NO UNITS
 CKC10    BSS
          LDML   CHANT+/CH/P.LOCK,CH
          STDL   T2
          LDIL   T2
          ZJN    CKC20       IF CHANNEL LOCK IS NOT SET
          LOADC  CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          ADML   CHANT,CH    CHANNEL NUMBER IS OFFSET IN TABLE
          CRDL   T1          READ CHANNEL LOCKWORD
          LDDL   T2
          SHN    17-0
          MJN    CKC30       IF MAINTENANCE PP WANTS THE CHANNEL

 CKC20    BSS
          LDN    P.CH
          RADL   CH
          SBDL   CNUML
          PJN    CKC35       IF END OF TABLE
          UJK    CKC10

* GIVE UP THE CHANNEL.

 CKC30    BSS
          RJM    RDOVL       READ OVERLAY
          RJM    CHGCH       CHANGE CHANNEL INSTRUCTIONS
          RJM    CSLOCK      CLEAR THE LAST UNIT LOCK, IF ANY
          RJM    CKCMND      CHECK IF OUTSTANDING COMMANDS
          LDDL   CMNDS
          NJN    CKC40       IF OUTSTANDING COMMANDS
          RJM    CLRUL       CLEAR ALL UNIT LOCKS
          LDN    0
          STDL   PIDLE       CLEAR PRE-IDLE FLAG
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          PAUSE  130000      DELAY 130 MILLISECONDS TO ALLOW
                             MAINTENANCE PP TO GET THE CHANNEL
 CKC35    UJK    CKCX

* DON'T GIVE UP THE CHANNEL UNTIL ALL COMMANDS HAVE FINISHED.

 CKC40    BSS
          LDN    1
          STDL   PIDLE       SET PRE-IDLE FLAG SO NO SEEKS WILL BE ISSUED
          UJK    CKC35
          EJECT
** NAME-- PPREQ
*
** PURPOSE-- CHECK FOR ANY PP REQUESTS ON THE PP QUEUE.
*
** EXIT-- A REGISTER = 0, IF NO PP REQUESTS.
*                    .NE. 0, IF A PP REQUEST WAS FOUND
          SPACE  6
 PPRQX    LJM    **
 PPREQ    EQU    *-1
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          ERRNZ  /PIT/C.ACTIVE
          CRDL   T1          READ PP REQUEST FLAGS
 PPRQ5    BSS
          LDDL   T4
          LPK    /PIT/K.ACTION  PP REQUEST FLAGS
          ZJK    PPRQX       IF NO PP REQUESTS
          SHN    /PIT/L.ACTIVE+2
          PJN    PPRQ6       IF THE ACTIVE CHECK FLAG IS NOT SET

* THE ACTIVE CHECK FLAG IS SET.
* SET THE LOCK, AND CLEAR THE ACTIVE CHECK FLAG.

          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDK    /PIT/K.LOCKF
          STDL   T4
          LOADC  CM.PIT
          ERRNZ  /PIT/C.ACTIVE
          RDSL   T1          TRY TO SET THE LOCK
          LDDL   T4
          LPK    /PIT/K.LOCKF
          NJK    PPRQX       IF SOMEONE ELSE HAS THE LOCK
          LDDL   T4          CLEAR THE ACTIVE CHECK FLAG
          LPC    -/PIT/K.ACTIVE-/PIT/K.LOCKF
          STDL   T4
          LOADC  CM.PIT
          ERRNZ  /PIT/C.LOCKF
          CWDL   T1
          UJK    PPRQ5

 PPRQ6    BSS                PROCESS IDLE OR RESUME REQUEST
          RJM    RDOVL       READ OVERLAY
          LJM    PPR1

          EJECT
** NAME-- RCLOCK
*
** PURPOSE-- READ THE REAL TIME CLOCK.
          SPACE  6
 RCLX     LJM    **
 RCLOCK   EQU    *-1
          LDDL   UNUML
          ZJK    RCLX        IF NO UNITS
          LDML   LCLOCK      TIME WHEN CLOCK LAST READ
          STDL   T1
          IAN    14B         READ THE CLOCK
          STML   LCLOCK
          SBDL   T1          ELAPSED TIME
          PJN    RCL10       IF CLOCK HASN'T WRAPPED AROUND
          ADC    10000B      ADJUST FOR WRAPAROUND
 RCL10    BSS
          RAML   ELAPT+1     UPDATE ELAPSED TIME
          SHN    -16
 RCL20    BSS
          RAML   ELAPT
          SBN    17B
          MJK    RCLX        IF LESS THAN 1 SECOND HAS ELAPSED

* UPDATE ELAPSED TIME FOR EACH UNIT.

          LDN    0
          STDL   T1
 RCL30    BSS
          AOML   UNITS+/UN/P.ELAPT,T1  ADD 1 SECOND TO ELAPSED TIME
          LDN    P.UN        BUMP UNIT ENTRY
          RADL   T1
          SBDL   UNUML
          MJK    RCL30       IF MORE UNITS
          LDC    -41100B     SUBTRACT 1 SECOND FROM ELAPSED TIME
          RAML   ELAPT+1
          LDC    -17B
          UJK    RCL20
          EJECT
** NAME--CHGCH
*
** PURPOSE--REPLACE CHANNEL INSTRUCTIONS WITH A DIFFERENT CHANNEL NUMBER.
*
** INPUT--CHANT,CH = CHANNEL NUMBER
*
          SPACE  6
 CHGX     LJM    **
 CHGCH    EQU    *-1
          LDML   CHANT,CH    CHANNEL NUMBER
          SBML   CURCH       CURRENT CHANNEL NUMBER
          ZJN    CHG20       NO CHANGE NEEDED
          RAML   CURCH       SAVE NEW CHANNEL
          LDDL   BSR         CHECK IF A CONTROLLER IS SELECTED
          ZJN    CHG5        IF NO CONTROLLER IS SELECTED
          RJM    CSHOLD      CLEAR SELECT HOLD IF SET
 CHG5     BSS
          LDDL   CREG        SET CONTROL REGISTER WITH CORRECT PORT SETTING
          LPC    -40000B
          ADML   CHANT+/CH/P.PORT,CH
          STDL   CREG
          LDN    0
          STDL   BSR         CLEAR BSR FROM LAST SELECT
          STDL   T1          CHANGE DISK CHANNEL INSTRUCTIONS
 CHG10    LDML   CONCH,T1    ADDRESS OF CHANNEL INSTRUCTIONS
          ZJN    CHG40       END OF LIST
          STDL   T2
          LDIL   T2
          SCN    37B
          LMML   CURCH       CHANNEL NUMBER
          STIL   T2
          AODL   T1
          UJK    CHG10

* CHECK IF CORRECT PORT IS SET.

 CHG20    BSS
          LDDL   CREG        CONTROL REGISTER
          LPC    /CH/K.PORT  PORT B IF SET
          SBML   CHANT+/CH/P.PORT,CH
          ZJN    CHG50       IF CORRECT PORT IS SET
          LDDL   BSR         CHECK IF A CONTROLLER IS SELECTED
          ZJN    CHG30       IF NO CONTROLLER IS SELECTED
          RJM    CSHOLD      CLEAR SELECT HOLD IF SET
 CHG30    BSS
          LDN    0
          STDL   BSR         CLEAR BSR FROM LAST SELECT
          LDDL   CREG        CHANGE TO OTHER PORT IN CONTROL REGISTER
          LMC    /CH/K.PORT
          STDL   CREG
 CHG40    BSS
          LDK    F.WTCR      WRITE CONTROL REGISTER
          RJM    FUNC
          ACN    DC
          LDN    1
          OAM    CREG,DC
          RJM    DCN         DISCONNECT CHANNEL
 CHG50    UJK    CHGX
          EJECT
** NAME--CHGCH2
*
** PURPOSE--REPLACE CHANNEL INSTRUCTIONS WITH A DIFFERENT CHANNEL NUMBER.
*           SAME AS CHGCH, ONLY IT DOESN'T SEND ANY FUNCTIONS.
*
** INPUT--CHANT,CH = CHANNEL NUMBER.
*
          SPACE  6
 CHGCX    LJM    **
 CHGCH2   EQU    *-1
          LDN    0
          STDL   BSR         CLEAR BSR FROM LAST SELECT
          LDML   CHANT+/CH/P.PORT,CH  SET CONTROL REGISTER WITH CORRECT PORT SETTING
          LPC    40000B
          STDL   CREG
          LDML   CHANT,CH    CHANNEL NUMBER
          SBML   CURCH       CURRENT CHANNEL NUMBER
          ZJN    CHGCX       NO CHANGE NEEDED
          RAML   CURCH       SAVE NEW CHANNEL
          LDN    0
          STDL   T1          CHANGE DISK CHANNEL INSTRUCTIONS
 CHGC10   LDML   CONCH,T1    ADDRESS OF CHANNEL INSTRUCTIONS
          ZJN    CHGCX       END OF LIST
          STDL   T2
          LDIL   T2
          SCN    37B
          LMML   CURCH       CHANNEL NUMBER
          STIL   T2
          AODL   T1
          UJK    CHGC10
          EJECT
** NAME-- RDOVL
*
** PURPOSE-- READ AN OVERLAY.
          SPACE  6
 RDOX     LJM    **
 RDOVL    EQU    *-1
          LDN    OVRLNC      OVERLAY LENGTH
          ZJK    RDOX
          STDL   WC
          LOADC  CM.CB       CM ADDRESS OF COMMUNICATION BUFFER
          ADK    /CB/C.OVR   CM ADDRESS OF OVERLAY
          CRML   BUFF,WC     READ OVERLAY
          UJK    RDOX
          EJECT
** NAME-- FORMA
*
** PURPOSE-- FORMAT A CM REAL MEMORY ADDRESS.
*
** CALLING SEQUENCE-- LDC    ADDRESS
*                     RJM    FORMA
*
** INPUT-- - A REGISTER- IS THE ADDRESS OF A 2-WORD CM BYTE ADDRESS.
*
** OUTPUT-- -CMADR- IS THE ADDRESS OF THE RESULTING 3-WORD REFORMATED
*                CM ADDRESS.  THE FORMAT CAN BE USED BY THE LOADC MACRO.
*           -ADDRESS-, WORD 0, BITS 0-13 AND
*                      WORD 1, BITS 3-15, ARE REFORMATTED TO-
*           -CMADR-,   WORD 0, BITS 0-9,
*                      WORD 1, BITS 0-11,
*                      WORD 2, BITS 0-5.
*
          SPACE  6
 FORX     LJM    **
 FORMA    EQU    *-1
          STDL   T1

* REFORMAT CM ADDRESS.

          LDML   1,T1
          LPN    7
          NJN    FOR10       RMA ADDRESS ERROR, TEMPORARY HALT
          LDIL   T1
          LPN    37B
          SHN    16
          LMML   1,T1
          SHN    9
          STD    CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   T1
          SHN    -5
          STD    CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMC    400000B
          UJK    FORX

 FOR10    BSS
          RJM    HALT        HALT THE PP
*         (NO RETURN FROM HALT.)
          EJECT
** NAME-- PAUS
*
** PURPOSE-- DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*            MICROSECONDS.
*
** INPUT-- A REGISTER (BITS 00-06) SPECIFIES NUMBER OF MICROSECONDS
*          TO BE DELAYED.
*
** NOTE-- THIS IS SET UP FOR 2X PP TIMING ON AN S1.
          SPACE  6
 PAUSX    LJM    **
 PAUS     EQU    *-1
 K26      IFEQ   HARDW,1
 PAUS10   SBN    1           EACH ITERATION OF THIS SBN-NJN LOOP
          NJN    PAUS10      UTILIZES 1 MICROSECOND
 K26      ENDIF
          UJK    PAUSX
          EJECT
 K27      IFEQ   TRACE,1
 TBUFX    LJM    **
 TBUF     EQU    *-1
          STML   FBUF,FI     SAVE HISTORY OF FUNCTIONS ISSUED
          AODL   FI          INCREMENT FUNCTION BUFFER INDEX
          ADC    -FBUFL
          NJN    TBUF10      IF NOT END OF BUFFER
          STDL   FI          INITIALIZE INDEX
 TBUF10   BSS
          UJK    TBUFX
 K27      ENDIF
          EJECT
** NAME-- PATCH
*
** PURPOSE-- PATCH THE PP.
*
** NOTES--
*    RMA OF PATCH AREA IS IN THE FIRST 32 BITS OF THE WORD CONTAINING THE
*    RESPONSE BUFFER RMA.
*    SET THE UPPER BIT IN THE 32-BIT RMA AS THE LAST THING.
*    (IF RMA = FC9008, THEN FIRST SET THE 32 BITS = 00FC 9008,
*    AND THEN SET THE 32 BITS = 80FC 9008
*    THE PP WILL CLEAR THE RMA AFTER IT HAS STORED THE PATCHES.
*
*    FORMAT OF PATCH AREA (EVERY 16 BITS).
*      ADDR, CONTENTS, ..., CONTENTS
*      F000, ADDR, CONTENTS, ..., CONTENTS
*      FFFF = END OF CONTENTS
*
*      ANY NUMBR OF F000 MAY SEPARATE CONTENTS FROM THE NEXT ADDRESS.
*      ZERO OR MORE F000 MAY SEPARATE CONTENTS FROM FFFF.
 K28      IFEQ   PAT,1
 PATX     LJM    **
 PATCH    EQU    *-1
          LDN    1
          STDL   WC
          LOADC  CM.PIT
          ADN    /PIT/C.RSBUF
          CRML   PCM,WC
          LDML   PCM
          LPC    100000B
          ZJN    PATX        IF NO PATCHES
          LMML   PCM         CLEAR UPPER BIT
          STML   PCM
          LOADF  PCM         RMA OF PATCH AREA
          CRDL   P1
          LDN    0
          STDL   P5
          LJM    PAT29

 PAT20    LDML   P1,P5
          ADC    -177777B    END OF PATCHES
          NJN    PAT28
          LDN    0
          STML   PCM
          STML   PCM+1
          LOADC  CM.PIT
          ADN    /PIT/C.RSBUF
          CWML   PCM,WC
          UJK    PATX

 PAT28    BSS
          ADC    -170000B+177777B  END OF CONTENTS
          NJN    PAT30
 PAT27    BSS
          RJM    PBUMP
 PAT29    BSS
          LDML   P1,P5
          STDL   PAD
          ADC    -170000B
          ZJN    PAT27
          RJM    PBUMP
          UJN    PAT40

 PAT30    LDML   P1,P5
          STIL   PAD
          AODL   PAD
          RJM    PBUMP
 PAT40    UJK    PAT20

 PBUX     LJM    **
 PBUMP    EQU    *-1
          AODL   P5
          SBN    4
          MJN    PBUX
          LDN    8
          RAML   PCM+1
          SHN    -16
          RAML   PCM
          LOADF  PCM
          CRDL   P1
          LDN    0
          STDL   P5
          UJK    PBUX

 PCM      BSSZ   4
 PAD      EQU    P6          PP ADDRESS TO PATCH
 K28      ENDIF
          EJECT
* DEBUG TEST.
          SPACE  6
 Q11      IFEQ   ERRTST,1
 TESTX    LJM    **
 TEST     EQU    *-1
          LOADC  CM.PIT
          ADN    /PIT/C.CBUF  COMMUNICATION BUFFER
          STDL   P1
          CRDL   P2
          LDDL   P2
          ZJN    TESTX
          STML   TESTPAR     SAVE PARAMETER
          LDN    0
          STDL   P2
          LDDL   P1
          LMC    400000B
          CWDL   P2
          LDML   TESTPAR
          SBN    29
          MJN    TESTX
          SBN    34-29+1
          PJN    TESTX       IF NOT FORCE ERROR FUNCTION
          UJK    TESTX
          SPACE  6
 TESTPAR  BSSZ   1           TEST PARAMETER
 Q11      ENDIF
          EJECT
* TABLE FOR CONVERTING BUSY / ATTENTION BITS TO CONTROLLER NUMBERS.
          SPACE  6
 ATTAB    CON    200B        CONTROLLER 0
          CON    100B        CONTROLLER 1
          CON    40B         CONTROLLER 2
          CON    20B         CONTROLLER 3
          CON    10B         CONTROLLER 4
          CON    4           CONTROLLER 5
          CON    2           CONTROLLER 6
          CON    1           CONTROLLER 7
          EJECT
 ADPTERR  CON    0
          LDML   RDAT
          ZJN    ADPT3       IF NOT READING ATTENTIONS
          RJM    SETUX       SET A LOCK ON A UNIT WITH THIS CHANNEL NUMBER
          NJK    MAIN10      IF LOCK COULD NOT BE SET, IGNORE ERROR

* MASTER CLEAR THE CHANNEL.

 ADPT3    BSS
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          LDN    1
          SHN    16-/SS/N.MCTRY-/SS/L.MCTRY
          RAML   SS+/SS/P.MCTRY  INCREMENT CHANNEL MASTER CLEAR RETRY COUNTER
          SHN    /SS/L.MCTRY+/SS/N.MCTRY+2
          LPK    /SS/M.MCTRY
          SBN    CNTRY+1
          MJN    ADPT5       IF MASTER CLEAR RETRY NOT EXHAUSTED
          RJM    OTERM       TURN OFF ALL UNITS ON CHANNEL
*         (NO RETURN FROM OTERM.)

 ADPT5    BSS
          RJM    CHREG       READ CHANNEL REGISTERS

          RJM    ICH         MASTER CLEAR THE CHANNEL

          LDML   RDAT
          NJK    REC3        IF ERROR DURING READING ATTENTIONS

          LDML   SS+/SS/P.MCTRY  CLEAR MASTER CLEAR RETRY COUNTER
          LPC    -/SS/K.MCTRY
          STML   SS+/SS/P.MCTRY

* WAIT FOR AN ATTENTION.

          LDML   SS+/SS/P.WTA
          SHN    /SS/L.WTA+2
          MJN    ADPT10      IF PREVIOUS ERROR WAITING FOR AN ATTENTION
          LDK    /SS/K.WTA
          RAML   SS+/SS/P.WTA  SET FLAG WHEN WAITING FOR ATTENTION
          RJM    WTATTN      WAIT 2 SECONDS FOR AN ATTENTION
          LDML   SS+/SS/P.WTA  ZERO OUT WAITING FOR ATTENTION FLAG
          LPC    -/SS/K.WTA
          STML   SS+/SS/P.WTA

 ADPT10   BSS
          LDML   SS+/SS/P.RESET
          SHN    /SS/L.RESET+2
          MJK    RECD        IF ERROR ON SELECTIVE RESET

          LDML   SS+/SS/P.NR  CHECK IF ERROR ON POWER UP SPINDLE
          LPK    /SS/K.NR
          ZJN    ADPT20      IF NOT TRYING TO POWER UP SPINDLE
          RJM    NOTRDY      RETRY TO POWER UP SPINDLE
*         (NO RETURN FROM NOTRDY.)

 ADPT20   BSS
          LDML   SS+/SS/P.RECOV  INDEX TO ERROR RECOVERY PROCEDURE
          STDL   T1
          LDML   RPROC,T1    ERROR RECOVERY PROCEDURE
          STML   ADPT24
          LJM    **          EXECUTE NEXT STEP IN ERROR RECOVERY
 ADPT24   EQU    *-1
          SPACE  6
* RETRY THE REQUEST.

 ADPTA    BSS
          AOML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
 ADPT30   BSS
          LDML   RS+/RS/P.CMST2
          SHN    17-10
          PJN    ADPT40      IF SYSTEM INTERVENTION STATUS NOT VALID
          LDML   RS+/RS/P.CMST2+1
          LPC    377B        SYSTEM INTERVENTION STATUS
          ADC    -150B       SI-68
          ZJN    ADPT50      IF TRANSFER COUNT ERROR
 ADPT40   BSS
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          RJM    SAVSS       SAVE SS ENTRY
          RJM    RCMRQ       RESTART THE REQUESTS
          LJM    MAIN10


* TRANSFER COUNT ERROR MEANS THAT THE CONTROLLER DID NOT END ON A SECTOR
* BOUNDARY.  THEREFORE, ALL OF THE DATA COULD BE BAD.
* RECOVERY WILL BE ATTEMPTED UNLESS THE DRIVER WAS STREAMING READ REQUESTS.
* IN THE CASE OF STREAMING READ REQUESTS, SINCE THE BAD DATA COULD HAVE
* BEEN IN A REQUEST IN WHICH A NORMAL RESPONSE HAS ALREADY BEEN SENT, THE
* CURRENT REQUEST WILL BE RETURNED AS UNRECOVERED, AND ERROR RECOVERY WILL
* NOT BE ATTEMPTED.  THIS WILL CAUSE THE JOB TO GET ABORTED.  THE EXCEPTION
* IS IF THE REQUEST THAT GOT THE BAD DATA WAS FOR A DIFFERENT FILE THAN THE
* CURRENT REQUEST.
* AN ERROR LOG MESSAGE OF AN UNRECOVERED -TRANSFER COUNT ERROR- SHOWS THAT
* BAD (OR SHIFTED) DATA MAY HAVE BEEN TRANSFERRED ON 1 OR MORE PREVIOUS
* REQUESTS.

 ADPT50   BSS
          LDML   SS+/SS/P.NCOMRQ  NUMBER OF RESPONSES - 1, WHICH HAVE BEEN SENT
          SBN    1
          ZJK    ADPT40      IF NO RESPONSES HAVE BEEN SENT, TRY TO RECOVER

* TRY TO RECOVER IF I4 CHANNEL ADAPTER STOPPED THE TRANSFER.

          LDML   RS+/RS/P.DET
          LPK    /RS/K.TIP+/RS/K.TOP
          NJK    ADPT40      TRY TO RECOVER
          LDML   RS+/RS/P.ID2
          LPK    /RS/K.XFER+/RS/K.XFRTO+/RS/K.TRTO
          NJK    ADPT40      TRY TO RECOVER
          LDML   RS+/RS/P.ESREG
          NJK    ADPT40      TRY TO RECOVER
          LDML   RS+/RS/P.ERRID
          LPK    /RS/K.IST+/RS/K.CEMPT+/RS/K.CINAC+/RS/K.ADPT
 ADPT54   NJK    ADPT40      TRY TO RECOVER
          LDML   RS+/RS/P.CHERR
          LPK    /RS/K.FTO
          NJK    ADPT54      TRY TO RECOVER
          LJM    REC25       ABORT THE REQUEST
          EJECT
 RECS     CON    0

          RJM    CHREG       READ CHANNEL REGISTERS

* READ ERROR REGISTER IMAGE.

          LDN    1
          SHN    16-/SS/N.ERI-/SS/L.ERI
          RAML   SS+/SS/P.ERI  INCREMENT READ ERROR REGISTER IMAGE RETRY COUNTER
          SHN    /SS/L.ERI+/SS/N.ERI+2
          LPK    /SS/M.ERI
          SBN    CNTRY+1
          PJN    REC2        IF READ ERROR REGISTER IMAGE RETRY IS EXHAUSTED
          RJM    RDERI       READ ERROR REGISTER IMAGE
          UJN    REC3        WAIT FOR ATTENTION AND DATA AVAILABLE
          SPACE  6
* ENTRY WHEN DATA AVAILABLE FOR ERROR REGISTER IMAGE.

 RDERA    CON    0
          RJM    ERA         READ ERROR REGISTER IMAGE
          UJN    REC3        WAIT FOR ATTENTION AND COMMAND COMPLETE
          SPACE  6
* ENTRY WHEN READ ERROR REGISTER IMAGE COMMAND COMPLETE.

 RDERC    CON    0

          LDML   SS+/SS/P.ERI  ZERO OUT READ ERROR REGISTER IMAGE
                               RETRY COUNTER
          LPC    -/SS/K.ERI
          STML   SS+/SS/P.ERI

* READ ERROR LOG.

 REC2     BSS
 M6       IFNE   CMSE,1
          LDN    1
          SHN    16-/SS/N.ELOG-/SS/L.ELOG
          RAML   SS+/SS/P.ELOG  INCREMENT READ ERROR LOG RETRY COUNTER
          SHN    /SS/L.ELOG+/SS/N.ELOG+2
          LPK    /SS/M.ELOG
          SBN    CNTRY+1
          PJN    REC4        IF READ ERROR LOG RETRY IS EXHAUSTED
          RJM    ELOG        READ ERROR LOG
 M6       ENDIF
 REC3     BSS
          RJM    SAVSS       SAVE SS ENTRY
          LJM    MAIN10      WAIT FOR ATTENTION AND DATA AVAILABLE
          SPACE  6
* ENTRY WHEN DATA AVAILABLE FOR ERROR LOG.

 ELOGA    CON    0
 M7       IFNE   CMSE,1
          RJM    ELA         READ ERROR LOG
          UJK    REC3        WAIT FOR ATTENTION AND COMMAND COMPLETION
          SPACE  6
* ENTRY WHEN READ ERROR LOG COMMAND COMPLETE.

 M7       ENDIF
 ELOGC    CON    0
 M8       IFNE   CMSE,1

          LDML   SS+/SS/P.ELOG  ZERO OUT READ ERROR LOG RETRY COUNTER
          LPC    -/SS/K.ELOG
          STML   SS+/SS/P.ELOG
 M8       ENDIF

 REC4     BSS
          UJK    ADPT10      RETRY THE REQUEST
          SPACE  6
* IF SI41 OR 43,
* EXECUTE CONTROLLER LEVEL II DIAGNOSTIC COMMAND 78, SUBTEST 6.

 RECA     BSS
          LDML   RS+/RS/P.CMST2
          SHN    17-10
          PJN    REC15       IF SYSTEM INTERVENTION STATUS NOT VALID
          LDML   RS+/RS/P.CMST2+1
          LPC    377B        SYSTEM INTERVENTION STATUS
          ADC    -101B       SI-41
          ZJN    REC5        IF MEDIA ERROR IN HEADER (READ OR WRITE)
          SBN    103B-101B   SI-43
          NJN    REC15       IF NOT MEDIA ERROR ON DATA (READ)
 REC5     BSS
          LDN    R40
          STML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
          RJM    DIAGSUB     EXECUTE CONTROLLER DIAGNOSTIC COMMAND 78, SUBTEST 6
 REC10    BSS
          UJK    REC3        WAIT FOR ATTENTION AND COMMAND COMPLETE

 REC15    UJK    REC30
          SPACE  6
* CONTROLLER DIAGNOSTIC COMMAND 78, SUBTEST 6, WAS SUCCESSFUL.
* EXECUTE CONTROLLER LEVEL II DIAGNOSTIC COMMAND 79, SUBTEST 5.

 DIAGSC   CON    0
          RJM    DIAGW       EXECUTE CONTROLLER DIAGNOSTIC COMMAND 79, SUBTEST 5
          UJK    REC10       WAIT FOR ATTENTION AND COMMAND COMPLETE
          SPACE  6
* CONTROLLER DIAGNOSTIC COMMAND 79, SUBTEST 5, WAS SUCCESSFUL.

 DIAGT    CON    0
          LDN    R30
          STML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
          RJM    SAVSS       SAVE SS ENTRY
          UJK    ADPT30      RETRY THE REQUEST
          SPACE  6
* UNRECOVERED MEDIA ERROR.

 RECC     BSS
          LDML   RS+/RS/P.CMST2
          SHN    17-10
          PJN    REC22       IF SYSTEM INTERVENTION STATUS NOT VALID
          LDML   RS+/RS/P.CMST2+1
          LPC    377B        SYSTEM INTERVENTION STATUS
          ADC    -101B       SI-41
          ZJN    REC20       IF MEDIA ERROR IN HEADER (READ OR WRITE)
          SBN    103B-101B   SI-43
          NJN    REC30       IF NOT MEDIA ERROR ON DATA (READ)
 REC20    BSS
          LDML   SS+/SS/P.CONF  CHECK IF DOING INITIAL CONFIDENCE TEST
          SHN    /SS/L.CONF+2
          PJN    REC23       IF NOT DOING INITIAL CONFIDENCE TEST
          LDN    0
          STML   SS+/SS/P.RECOV  START RECOVERY AT BEGINNING
          RJM    CREC        HANDLE CONFIDENCE TEST ERRORS
*         (RETURNS ONLY IF TOO MANY MEDIA ERRORS.)

 REC22    UJN    REC30       IF LIMIT OF MEDIA ERRORS HAS BEEN REACHED


 REC23    BSS
          LDK    /RS/K.DATERR  SOFTWARE FLAW THE ALLOCATION UNIT
          RJM    SERR        ERROR ID
          LDK    /RS/K.UNMED  UNRECOVERED MEDIA ERROR
          RJM    SERRID      ERROR ID

 REC25    BSS
          LDK    F.CSH       CLEAR SELECT HOLD
          RJM    FUNCB
          RJM    HTERM       UNRECOVERED ERROR
*         (NO RETURN FROM HTERM.)
          SPACE  6
 RECI     BSS

* DETERMINE IF UNIT SHOULD BE DOWNED.

          LDML   RS+/RS/P.CMST2
          SHN    17-14
          MJK    REC25       IF HYDRA REPORTED THE ERROR ON THE FINAL RETRY
          LJM    RECH        DISABLE THE UNIT
          SPACE  6
 REC30    BSS
          LDN    R40
          STML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
          SPACE  6
* SELECTIVE RESET THE HYDRA.

 RECD     BSS
          LDN    1
          SHN    16-/SS/N.SRTRY-/SS/L.SRTRY
          RAML   SS+/SS/P.SRTRY  INCREMENT CHANNEL MASTER CLEAR RETRY COUNTER
          SHN    /SS/L.SRTRY+/SS/N.SRTRY+2
          LPK    /SS/M.SRTRY
          SBN    COSTRY+1
          MJN    REC40       IF SELECTIVE RESET RETRY NOT EXHAUSTED
          LDK    F.CSH       CLEAR SELECT HOLD
          RJM    FUNCB
          RJM    OCTERM      TURN OFF ALL UNITS ON THE CONTROLLER
*         (NO RETURN FROM OCTERM.)

 REC40    BSS
          RJM    RESET       ISSUE SELECTIVE RESET
          UJN    REC50       WAIT FOR THE RESET COMPLETION
          SPACE  6
* ENTRY WHEN SELECTIVE RESET SUCCESSFULLY COMPLETES.

 RECE     CON    0
          LDML   SS+/SS/P.SRTRY  ZERO OUT SELECTIVE RESET RETRY COUNTER
          LPC    -/SS/K.SRTRY
          STML   SS+/SS/P.SRTRY
          AOML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
          UJN    REC60       RETRY THE REQUEST
          SPACE  6
* EXECUTE CONTROLLER LEVEL I DIAGNOSTICS.

 RECF     BSS
          AOML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
          RJM    DIAG        EXECUTE CONTROLLER LEVEL I DIAGNOSTICS
 REC50    UJK    REC10
          SPACE  6
* CONTROLLER LEVEL I DIAGNOSTICS PASSED.

 DIAGC    CON    0
          AOML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
          LDK    /RS/K.XDP1  LEVEL I DIAGNOSTICS PASSED
          RJM    SID         ERROR ID
 REC60    UJK    ADPT30      RETRY THE REQUEST
          SPACE  6
* EXECUTE CONTROLLER LEVEL II DIAGNOSTICS.

 RECJ     BSS
          AOML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
          RJM    DIAGG       EXECUTE CONTROLLER LEVEL II DIAGNOSTICS
          UJK    REC50
          SPACE  6
* CONTROLLER LEVEL II DIAGNOSTICS PASSED.

 DIAGD    CON    0
          AOML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
          LDK    /RS/K.XDP   LEVEL II DIAGNOSTICS PASSED
          RJM    SID         ERROR ID
          UJK    REC60       RETRY THE REQUEST
          SPACE  6
* LEVEL I OR II DIAGNOSTICS FAILED.
* RETRY THE REQUEST.  IF IT IS STILL UNRECOVERED, DOWN THE UNIT.

 RECG     BSS
          LDN    R60
          STML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
          UJK    REC60       RETRY THE REQUEST
          SPACE  6
* UNRECOVERED ERROR.  DOWN THE UNIT.

 RECH     BSS
          LDK    F.CSH       CLEAR SELECT HOLD
          RJM    FUNCB
          RJM    UTERM       UNRECOVERED ERROR, TURN OFF UNIT
*         (NO RETURN FROM UTERM.)
          EJECT
* SEQUENCE TO ERROR RECOVERY PROCEDURES.
          SPACE  6
 RPROC    BSS
          CON    ADPTA       RETRY THE REQUEST
          CON    ADPTA       RETRY THE REQUEST
          CON    ADPTA       RETRY THE REQUEST
          CON    RECA        EXECUTE CONTROLLER LEVEL II DIAGNOSTIC COMMAND 78, SUBTEST 6
 RP30     CON    RECC        UNRECOVERED MEDIA ERROR
 RP40     CON    RECD        SELECTIVE RESET
          CON    ADPTA       RETRY THE REQUEST
          CON    RECF        EXECUTE LEVEL I DIAGNOSTICS
          CON    RECG        LEVEL I DIAGNOSTICS FAILED
          CON    RECJ        EXECUTE LEVEL II DIAGNOSTICS
          CON    RECG        LEVEL II DIAGNOSTICS FAILED
          CON    RECI        UNRECOVERED ERROR, LEVEL II DIAGNOSTICS PASSED

 RP60     CON    RECH        UNRECOVERED ERROR, DOWN THE UNIT

 R30      EQU    RP30-RPROC
 R40      EQU    RP40-RPROC
 R60      EQU    RP60-RPROC
          EJECT
** NAME-- SETUX
*
** PURPOSE-- SET THE UNIT LOCK ON ANY UNIT WITH THE SAME CHANNEL AS CH.
*
** EXIT-- A REGISTER = 0 IF A LOCK WAS SET.
*         A REGISTER NONZERO IF NO LOCK WAS SET.
          SPACE  6
 SETUXX   LJM    **
 SETUX    EQU    *-1
          LDDL   UNUML
          ZJK    SETUXX      IF NO UNITS
          LDDL   LOCKS
          STDL   UX
          SBN    NOLOCK
          NJN    SETU50      IF A LOCK IS SET
 SETU5    BSS
          LDN    0
          STDL   UX
 SETU10   BSS
          LDML   UNITS+/UN/P.CHIX,UX  GET POINTER TO CHANT
          SHN    /UN/L.CHIX+/UN/N.CHIX+2
          LPK    /UN/M.CHIX
          SBDL   CH          COMPARE CHANNEL NUMBER
          ZJN    SETU30      IF THE SAME CHANNEL
 SETU20   BSS
          LDN    P.UN
          RADL   UX          BUMP UNIT ENTRY
          SBDL   UNUML
          MJK    SETU10      IF NOT END OF TABLE
          LDN    1           COULD NOT SET A UNIT LOCK
 SETU25   UJK    SETUXX

 SETU30   BSS
          RJM    CDSABLE     CHECK IF UNIT IS DISABLED
          MJN    SETU20      IF UNIT IS DISABLED
          LDML   UNITS+/UN/P.CM,UX  GET CONTROLLER NUMBER
          SHN    -3
          LPN    /UN/M.CM
          STDL   CMOD        CONTROLLER NUMBER
          RJM    SETLOCK     SET UNIT LOCK
          NJN    SETU20      IF LOCK COULD NOT BE SET
 SETU40   BSS
          LDN    0
          UJK    SETU25

* A LOCK IS ALREADY SET.  IF IT IS THE DESIRED CHANNEL, THEN IT IS OK.
* IF IT IS A DIFFERENT CHANNEL, SAVE SS ENTRY BUT LEAVE THE LOCK SET.
* DON'T ALLOW ANY ACTIVITY ON THE CHANNEL, BECAUSE THIS IS CALLED FROM
* ADPTERR.

 SETU50   BSS
          LDML   UNITS+/UN/P.CHIX,UX  GET POINTER TO CHANT
          SHN    /UN/L.CHIX+/UN/N.CHIX+2
          LPK    /UN/M.CHIX
          SBDL   CH          COMPARE CHANNEL NUMBER
          NJN    SETU60      IF NOT THE SAME CHANNEL
          LDML   UNITS+/UN/P.CM,UX  GET CONTROLLER NUMBER
          SHN    -3
          LPN    /UN/M.CM
          STDL   CMOD        CONTROLLER NUMBER
          UJK    SETU40

 SETU60   BSS
          AOML   DEBUG1      SET FOR DEBUG PURPOSES ONLY
          LDN    NOLOCK
          STDL   LOCKS
          RJM    SAVSS       SAVE SS ENTRY
          UJK    SETU5       FIND A DIFFERENT UNIT ENTRY
          EJECT
** NAME-- CDSABLE
*
** PURPOSE-- CHECK THE UNIT DISABLE FLAG.
*
** EXIT-- A REGISTER IS NEGATIVE IF THE UNIT DISABLE FLAG IS SET
          SPACE  6
 CDSX     LJM    **
 CDSABLE  EQU    *-1
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ERRNZ  /UIT/C.DSABLE
          CRDL   T1          READ UNIT DISABLED FLAG
          LDDL   T1+/UIT/P.DSABLE  CHECK IF UNIT IS DISABLED
          SHN    /UIT/L.DSABLE+2
          UJK    CDSX
          EJECT
** NAME-- CHREG
*
** PURPOSE-- READ CHANNEL REGISTERS AND PUT IN RESPONSE.
          SPACE  6
 CHRX     LJM    **
 CHREG    EQU    *-1
          CFM    CHR10,DC    CHECK CHANNEL ERROR

* READ ERROR STATUS REGISTER.

          LDK    F.RDES      READ ERROR STATUS
          RJM    FUNCB
          ACN    40B+DC
          LDN    1
          IAM    P1,DC       ERROR STATUS REGISTER
          DCN    40B+DC      DISCONNECT CHANNEL
          LDML   RS+/RS/P.ESREG
          NJN    CHR5        IF ERROR STATUS REGISTER IS ALREADY IN RESPONSE
          LDDL   P1
          STML   RS+/RS/P.ESREG  PUT ERROR STATUS REGISTER IN RESPONSE
 CHR5     BSS
 K29      IFEQ   TRACE,1
          LDDL   P1
          RJM    TBUF        PUT IN TRACE BUFFER
 K29      ENDIF

* CLEAR CHANNEL ERROR FLAG.

          CFM    CHR10,DC    CLEAR CHANNEL ERROR FLAG

* READ OPERATIONAL STATUS.

 CHR10    BSS
          LDML   RS+/RS/P.OPSTAT
          NJN    CHR20       IF OPERATIONAL STATUS IS ALREADY IN RESPONSE
          LDK    F.RDOS      READ OPERATIONAL STATUS
          RJM    FUNCB
          ACN    40B+DC
          LDN    1
          IAM    OPSTAT,DC
          DCN    40B+DC      DISCONNECT CHANNEL
          LDDL   OPSTAT
          STML   RS+/RS/P.OPSTAT  OPERATIONAL STATUS
 K30      IFEQ   TRACE,1
          RJM    TBUF        PUT IN TRACE BUFFER
 K30      ENDIF

* READ T REGISTER.

 CHR20    BSS
          LDML   RS+/RS/P.TREG
          ADML   RS+/RS/P.TREG+1
          ADML   RS+/RS/P.TREG+2
          NJN    CHR30       IF T REGISTER IS ALREADY IN RESPONSE
          LDK    F.RDT       READ T REGISTER
          RJM    FUNCB
          ACN    40B+DC
          LDN    3
          IAM    RS+/RS/P.TREG,DC  T REGISTER
          DCN    40B+DC

* READ CONTROL REGISTER.

 CHR30    BSS
          LDML   RS+/RS/P.CREG
          ADML   RS+/RS/P.FMREG
          NJN    CHR40       IF CONTROL AND MASK REGISTERS ARE ALREADY
                             IN RESPONSE
          LDK    F.RDCR      READ CONTROL REGISTER
          RJM    FUNCB
          ACN    40B+DC
          LDN    1
          IAM    RS+/RS/P.CREG,DC  CONTROL REGISTER
          DCN    40B+DC

* READ FLAG MASK REGISTER.

          LDK    F.RDMR      READ FLAG MASK REGISTER
          RJM    FUNCB
          ACN    40B+DC
          LDN    1
          IAM    RS+/RS/P.FMREG,DC  FLAG MASK REGISTER
          DCN    40B+DC

* PUT IDLE STATUS IN RESPONSE.

 CHR40    BSS
          LDML   RS+/RS/P.IDSTAT
          NJN    CHR50       IF IDLE STATUS IS ALREADY IN RESPONSE
          LDML   CHANT+/CH/P.ATTN,CH  BUSY / ATTENTION BITS
          STML   RS+/RS/P.IDSTAT
 CHR50    BSS
          UJK    CHRX
          EJECT
** CSHOLD
*
** PURPOSE-- CLEAR SELECT HOLD, IF IT IS SET
          SPACE  6
 CSHX     LJM    **
 CSHOLD   EQU    *-1
          LDK    F.RDOS      READ OPERATIONAL STATUS
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    OPSTAT,DC
          DCN    DC+40B      DEACTIVATE CHANNEL
          CFM    CSH10,DC    CHECK AND CLEAR CHANNEL ERROR
          RJM    CHNERR      RECORD CHANNEL ERROR
*         (RETURNS IF ERRORS ARE TO BE IGNORED.)

 CSH10    BSS
 K31      IFEQ   TRACE,1
          LDDL   OPSTAT
          RJM    TBUF        PUT IN TRACE BUFFER
 K31      ENDIF

          LDDL   OPSTAT      OPERATIONAL STATUS
          LPC    1400B       CHECK SELECT HOLD AND SELECT ACTIVE
          ZJK    CSHX        IF SELECT HOLD IS NOT SET
          LDK    F.CSH       CLEAR SELECT HOLD
          RJM    FUNC
          UJK    CSHX
          EJECT
** WTATTN
*
** PURPOSE-- WAIT 2 SECONDS FOR AN ATTENTION.
          SPACE  6
 WTAX     LJM    **
 WTATTN   EQU    *-1
          LDN    3
          STML   WTA101      SET TIMEOUT FOR 2 SECONDS
          LDC    11788
          STML   WTA100
 WTA10    BSS
          LDK    F.RIS       REQUEST IDLE STATUS
          RJM    FUNCB
          ACN    40B+DC
          LDN    1
          IAM    P6,DC       READ ATTENTION BITS
          DCN    40B+DC
          LDDL   P6
          LPML   ATTAB,CMOD  ATTENTION BIT FOR THIS CONTROLLER
          ZJN    WTA20       IF NO ATTENTION
          RJM    SELCK       SELECT CONTROLLER IF IT IS NOT SELECTED
          RJM    STATUS      READ STATUS AND CLEAR ATTENTION
 WTA20    BSS
          SOML   WTA100
          NJK    WTA10       IF 2 SECONDS IS NOT UP
          SOML   WTA101
          NJN    WTA10
          UJK    WTAX
          SPACE  6
 WTA100   BSSZ   1           TIMEOUT COUNTER
 WTA101   BSSZ   1           TIMEOUT COUNTER
          EJECT
** NAME-- RDCMND
*
** PURPOSE-- READ WORD 7 OF COMMAND BLOCK 0 AND DETERMINE
*            IF THERE WILL BE AN ATTENTION.
*
** OUTPUT-- A REGISTER = 0 IF NO ATTENTION EXPECTED.
*           A REGISTER NONZERO IF ATTENTION IS EXPECTED.
          SPACE  6
 D9       IFEQ   T1,0
 RDCX     LJM    **
 RDCMND   EQU    *-1
          RJM    SELCK       SELECT THE CONTROLLER ONLY IF NOT SELECTED
          LDK    F.SCS       SET SELECT HOLD AND COMMAND SEQUENCE
          RJM    FUNC
          LDK    W.RCMND7    READ WORD 7 OF COMMAND BLOCK
          STDL   CMFUN
 D8       IFEQ   TRACE,1
          RJM    TBUF        PUT IN TRACE BUFFER
 D8       ENDIF
          ACN    DC
          LDN    1
          OAM    CMFUN,DC    SEND FUNCTION TO HYDRA
          RJM    DCN         DISCONNECT THE CHANNEL
          ACN    DC
          LDN    1
          IAM    RDC100,DC   READ WORD 7 OF COMMAND BLOCK
          NJN    RDC5        IF INPUT DID NOT COMPLETE, TEMPORARY HALT
          RJM    INC         CHECK IF CHANNEL IS INACTIVE
          LDK    F.CCS       CLEAR COMMAND SEQUENCE
          RJM    FUNC
          LDML   RDC100      WORD 7 OF COMMAND BLOCK
          SHN    17-15
          PJN    RDC10       IF -CMND EXEC REQ- IS NOT SET
          SHN    15-7        CHECK COMMAND COMPLETE FLAG
          PJN    RDC50       IF COMMAND EXISTS BUT HASN'T BEEN PROCESSED
 RDC5     BSS
          RJM    HALT        INVALID SETTING OF COMMAND BITS

 RDC10    BSS
          SHN    15-7        CHECK COMMAND COMPLETE FLAG
          PJN    RDC50       IF COMMAND IN PROGRESS

* COMMAND HAS COMPLETED.  IF ATTENTION ISN'T SET AT THIS TIME,
* IT WON'T GET SET.

          LDK    F.RIS       READ IDLE STATUS
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    P6,DC       READ ATTENTION BITS
          RJM    INC         CHECK IF CHANNEL IS INACTIVE
          LDDL   P6
          STML   CHANT+/CH/P.ATTN,CH  ATTENTION BITS
          LPML   ATTAB,CMOD  ATTENTION BITS FOR THIS CONTROLLER
 RDC40    UJK    RDCX        EXIT A REGISTER = 0 IF NO ATTENTION,
                             NONZERO IF ATTENTION IS SET.

 RDC50    BSS
          LDN    1           COMMAND IN PROGRESS
          UJK    RDC40
          SPACE  6
 RDC100   BSSZ   1           WORD 7 OF COMMAND BLOCK 0
 D9       ENDIF
          EJECT
** NAME-- RDERI
*
** PURPOSE-- READ THE ERROR REGISTER IMAGE.
          SPACE  6
 RDERX    LJM    **
 RDERI    EQU    *-1
          RJM    SELCK       SELECT THE CONTROLLER ONLY IF NOT SELECTED

* WRITE COMMAND BLOCK TO READ THE ERROR REGISTER IMAGE.

          LDK    R.RERI      READ ERROR REGISTER IMAGE
          STML   SS+/SS/P.FUNC  PARAMETER IN COMMAND BLOCK
          LDN    0
          STML   SS+/SS/P.NSEC  SET COMMAND BLOCK PARAMETER = 0
          STML   SS+/SS/P.PCYL  SET COMMAND BLOCK PARAMETER = 0
          STML   SS+/SS/P.PTRK  SET COMMAND BLOCK PARAMETER = 0
          RJM    CMND        WRITE COMMAND BLOCK
          LDN    5
          STML   SS+/SS/P.CMND  SET COMMAND PROCESSOR INDEX
          UJK    RDERX
          EJECT
** NAME-- ELOG
*
** PURPOSE-- READ THE ERROR LOG.
          SPACE  6
 M9       IFNE   CMSE,1
 ELOGX    LJM    **
 ELOG     EQU    *-1

* WRITE A COMMAND BLOCK TO READ THE ERROR LOG.

          LDN    0
          STML   SS+/SS/P.NSEC  SET COMMAND BLOCK PARAMETER = 0
          LDK    R.REL       READ ERROR LOG
          RJM    DIA         WRITE COMMAND BLOCK
          LDN    4
          STML   SS+/SS/P.CMND  SET COMMAND PROCESSOR INDEX
          UJK    ELOGX
          EJECT
** NAME-- ELA
*
** PURPOSE-- READ THE DATA BUFFER WHICH CONTAINS THE
*            ERROR LOG IMAGE.
          SPACE  6
 ELAX     LJM    **
 ELA      EQU    *-1
          LDC    F.SCS       SET COMMAND SEQUUENCE
          RJM    FUNC
          LDK    W.RDI       FUNCTION WORD TO READ DATA BUFFER
          STDL   CMFUN
 K32      IFEQ   TRACE,1
          RJM    TBUF        PUT IN TRACE BUFFER
 K32      ENDIF
          ACN    DC
          LDN    1
          OAM    CMFUN,DC    SEND FUNCTION TO CONTROLLER
          RJM    DCN         DISCONNECT CHANNEL
          ACN    DC
          LDN    48
          IAM    RS+/RS/P.ELOG,DC  READ ERROR LOG
          NJN    ELA10
          RJM    INC         CHECK IF CHANNEL IS INACTIVE
          LDK    F.CCS       CLEAR COMMAND SEQUENCE
          RJM    FUNC
          LDK    /RS/K.ELP   SET FLAG FOR ERROR LOG PRESENT
          RJM    SDET        PUT ID IN RESPONSE
          UJK    ELAX

 ELA10    BSS
          STML   RS+/RS/P.FUNTO  NUMBER OF PP WORDS NOT TRANSFERRED
          LDK    /RS/K.IEL   INCOMPLETE ERROR LOG
          RJM    SID2        ERROR ID
          RJM    ROPS        READ OPERATIONAL STATUS
          LDDL   OPSTAT      OPERATIONAL STATUS
          SHN    17-9        CHECK IF SELECT ACTIVE IS STILL SET
          MJN    ELA20       IF SELECT ACTIVE IS STILL SET
          LDK    /RS/K.SADEL  SELECT ACTIVE DROPPED WHEN READING ERROR LOG
          RJM    SID2        ERROR ID
 ELA20    BSS
          RJM    ADPTERR      ATTEMPT TO RECOVER
*         (NO RETURN FROM ADPTERR.)
 M9       ENDIF
          EJECT
** NAME-- ERA
*
** PURPOSE-- READ THE DATA BUFFER WHICH CONTAINS THE
*            REGISTER IMAGE.
          SPACE  6
 ERAX     LJM    **
 ERA      EQU    *-1
          LDC    F.SCS       SET COMMAND SEQUUENCE
          RJM    FUNC
          LDK    W.RDI       FUNCTION WORD TO READ DATA BUFFER
          STDL   CMFUN
 K33      IFEQ   TRACE,1
          RJM    TBUF        PUT IN TRACE BUFFER
 K33      ENDIF
          ACN    DC
          LDN    1
          OAM    CMFUN,DC    SEND FUNCTION TO CONTROLLER
          RJM    DCN         DISCONNECT CHANNEL
          ACN    DC
          LDN    48
          IAM    RS+/RS/P.ERI,DC  READ ERROR REGISTER IMAGE
          NJN    ERA10
          RJM    INC         CHECK IF CHANNEL IS INACTIVE
          LDK    F.CCS       CLEAR COMMAND SEQUENCE
          RJM    FUNC
          LDK    /RS/K.ERIP  SET FLAG FOR ERROR REGISTER IMAGE PRESENT
          RJM    SDET        PUT ID IN RESPONSE
          UJK    ERAX

 ERA10    BSS
          STML   RS+/RS/P.FUNTO  NUMBER OF PP WORDS NOT TRANSFERRED
          LDK    /RS/K.IER   INCOMPLETE ERROR REGISTER IMAGE
          RJM    SID2        ERROR ID
          RJM    ROPS        READ OPERATIONAL STATUS
          LDDL   OPSTAT      OPERATIONAL STATUS
          SHN    17-9        CHECK IF SELECT ACTIVE IS STILL SET
          MJN    ERA20       IF SELECT ACTIVE IS STILL SET
          LDK    /RS/K.SADER  SELECT ACTIVE DROPPED WHEN READING ERROR
                             REGISTER IMAGE
          RJM    SID2        ERROR ID
 ERA20    BSS
          RJM    ADPTERR      ATTEMPT TO RECOVER
*         (NO RETURN FROM ADPTERR.)
          EJECT
 NOTRDY   CON    0
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          LDN    1
          ERRNZ  16-/SS/N.NR-/SS/L.NR
          RAML   SS+/SS/P.NR  INCREMENT NOT READY FAILURE COUNTER
          LPK    /SS/M.NR
          SBN    NRTRY+1
          PJN    NOTR10      IF RETRY EXHAUSTED

* WRITE A COMMAND BLOCK TO POWER UP SPINDLE.

          LDK    R.PUP       POWER UP SPINDLE
          STML   SS+/SS/P.FUNC  PARAMETER IN LOAD COMMAND BLOCK
          LDN    0
          STML   SS+/SS/P.NSEC  SET COMMAND BLOCK PARAMETER = 0
          STML   SS+/SS/P.PCYL  SET COMMAND BLOCK PARAMETER = 0
          STML   SS+/SS/P.PTRK  SET COMMAND BLOCK PARAMETER = 0
          RJM    CMND        WRITE COMMAND BLOCK
          LDN    3
          STML   SS+/SS/P.CMND  SET COMMAND PROCESSOR INDEX
          LDK    /RS/K.PU    POWER UP SPINDLE
          RJM    SID         ERROR ID
          LDML   SS+/SS/P.NR
          SHN    /SS/L.NR+/SS/N.NR+2
          LPK    /SS/M.NR
          SBN    1
          NJN    NOTR5       IF NOT FIRST ATTEMPT

* SEND AN INTERMEDIATE RESPONSE SO THAT AN MDD MESSAGE IS DISPLAYED.

          RJM    INTRS       SEND INTERMEDIATE RESPONSE
 NOTR5    BSS
          RJM    SAVSS       SAVE SS ENTRY
          LJM    MAIN10

 NOTR10   BSS
          LDK    F.CSH       CLEAR SELECT HOLD
          RJM    FUNCB
          RJM    UTERM       UNRECOVERED ERROR, TURN OFF UNIT
*         NO RETURN FROM UTERM
          EJECT

* POWER UP SPINDLE COMPLETED NORMALLY.

 NOTRDC   CON    0
          LDML   SS+/SS/P.NR  CLEAR NOT READY RECOVERY FLAG
          LPC    -/SS/K.NR
          STML   SS+/SS/P.NR
          LDK    /RS/K.PUC   POWER UP SPINDLE COMPLETED
          RJM    SID         SAVE ERROR ID
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    INTRS       SEND AN INTERMEDIATE RESPONSE
          RJM    RSTRQ       RESTART REQUEST
          RJM    SAVSS       SAVE SS ENTRY
          UJK    MAIN10
          EJECT
** NAME-- IALCH
*
** PURPOSE-- INITIALIZE CHANNEL ADAPTER ON ALL CHANNELS.
          SPACE  6
 IALX     LJM    **
 IALCH    EQU    *-1
          LDDL   UNUML
          ZJK    IALX        IF NO UNITS
          LDN    0
          STDL   CH          CHANT TABLE INDEX
          STML   IAL100      RECALL FLAG
 IAL10    BSS
          LDML   CHANT+/CH/P.DOWN,CH  CHECK IF CHANNEL IS DOWN
          NJN    IAL25       IF CHANNEL IS DOWN
 IAL20    BSS
          RJM    SCLOCK      SET CHANNEL LOCK
          NJK    IAL20       IF CHANNEL LOCK COULD NOT BE SET

* SET THE UNIT LOCK ON ANY UNIT WITH THE SAME CHANNEL.
* THIS IS SO ERROR PROCESSING CAN ALWAYS ASSUME THAT A UNIT LOCK IS SET.

          LDN    0
          STDL   UX
 IAL22    BSS
          LDML   UNITS+/UN/P.CHIX,UX  GET POINTER TO CHANT
          SHN    /UN/L.CHIX+/UN/N.CHIX+2
          LPK    /UN/M.CHIX
          SBDL   CH          COMPARE CHANNEL NUMBER
          NJN    IAL23       IF NOT THE SAME CHANNEL
          RJM    CDSABLE     CHECK THE UNIT DISABLE FLAG
          MJN    IAL23       IF UNIT IS DISABLED
          LDML   UNITS+/UN/P.CM,UX  GET CONTROLLER NUMBER
          SHN    -3
          LPN    /UN/M.CM
          STDL   CMOD        CONTROLLER NUMBER
          RJM    SETLOCK     SET UNIT LOCK
          ZJN    IAL27       IF LOCK WAS SET
 IAL23    BSS
          LDN    P.UN
          RADL   UX          BUMP UNIT ENTRY
          SBDL   UNUML
          MJK    IAL22       IF NOT END OF TABLE
          AOML   IAL100      COULD NOT INITIALIZE THIS CHANNEL
 IAL25    UJN    IAL30

 IAL27    BSS
          RJM    CHGCH2      CHANGE CHANNEL INSTRUCTIONS
          LDML   CHANT,CH    CHANNEL NUMBER
          STML   RS+/RS/P.CHAN
          LDML   CHANT+/CH/P.PORT,CH  PORT B IF SET
          SHN    /CH/L.PORT-/RS/L.PORT
          RAML   RS+/RS/P.PORT

          RJM    ICH         INITIALIZE CHANNEL ADAPTER
          RJM    CLRLOCK     CLEAR UNIT LOCK
 IAL30    BSS
          LDN    P.CH        BUMP CHANNEL ENTRY
          RADL   CH
          SBDL   CNUML
          MJK    IAL10       IF MORE CHANNELS
          LDML   IAL100
          NJN    IAL40       IF NOT ALL CHANNEL WERE INITIALIZED, RECALL LATER
          LDDL   IALF        SET FLAG WHEN ALL CHANNELS HAVE BEEN INITIALIZED
          LPC    -1
          ADN    1
          STDL   IALF
 IAL40    BSS
          UJK    IALX
          SPACE  6
 IAL100   BSSZ   1           RECALL FLAG
          EJECT
** NAME-- ICH
*
** PURPOSE-- INITIALIZE CHANNEL ADAPTER.
*            WRITE CONTROL REGISTER.
*            SET FLAG MASK REGISTER.
          SPACE  6
 ICHX     LJM    **
 ICH      EQU    *-1

* MASTER CLEAR THE CHANNEL ADAPTER.

          DCN    40B+DC      DISCONNECT THE CHANNEL
          LDK    F.MC        MASTER CLEAR
          RJM    FUNC

* WRITE CONTROL REGISTER.

          LDK    F.WTCR      WRITE CONTROL REGISTER
          RJM    FUNC
          ACN    DC
          LDN    1
          OAM    CREG,DC
          RJM    DCN         DISCONNECT CHANNEL

* READ AND VERIFY CONTROL REGISTER.

          LDK    F.RDCR      READ CONTROL REGISTER
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    T1,DC
          RJM    INC         CHECK IF CHANNEL INACTIVE
          LDDL   T1
          SBDL   CREG
          NJN    ICH10       IF NOT CORRECT CONTROL REGISTER

* WRITE FLAG MASK REGISTER.

          LDK    F.WTMR      WRITE MASK REGISTER
          RJM    FUNC
          ACN    DC
          LDN    1
          OAM    FMREG,DC
          RJM    DCN         DISCONNECT CHANNEL

* READ AND VERIFY FLAG MASK REGISTER.

          LDK    F.RDMR      READ MASK REGISTER
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    T1,DC
          RJM    INC         CHECK IF CHANNEL INACTIVE
          LDDL   T1
          SBML   FMREG       FLAG MASK REGISTER
          ZJN    ICH20       IF FLAG MASK REGISTER OK
 ICH10    BSS
          LDK    /RS/K.ICA   ERROR IN INITIALIZE CHANNEL ADAPTER
          RJM    SDET        PUT ERROR ID IN RESPONSE
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    ADPTERR
*         (NO RETURN FROM ADPTERR.)

* READ OPERATIONAL STATUS.

 ICH20    BSS
          LDC    177777B
          STML   ICH200
 ICH22    BSS
          RJM    ROPS        READ OPERATIONAL STATUS
          LDDL   OPSTAT
          LPC    1403B
          SBN    2
          ZJN    ICH30       IF SELECT HOLD CLEAR, SELECT ACTIVE CLEAR,
                             T' REGISTER EMPTY, TRANSFER NOT IN PROGRESS
          SOML   ICH200      DECREMENT TIMEOUT COUNTER
          NJK    ICH22       IF NOT TIMED OUT
          LDK    /RS/K.MC    MASTER CLEAR DID NOT WORK
          RJM    SDET        PUT ERROR ID IN RESPONSE
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          LDDL   OPSTAT
          STML   RS+/RS/P.OPSTAT  PUT OPERATIONAL STATUS IN RESPONSE
 ICH30    BSS
          UJK    ICHX
          SPACE  6
 ICH200   BSSZ   1           TIMEOUT COUNTER FOR MASTER CLEAR
          EJECT
** NAME-- RESALL
*
** PURPOSE-- ISSUE SELECTIVE RESET TO ALL CONTROLLERS
*            WHEN THE PP IS FIRST LOADED.  FOR DUAL ACCESS,
*            JUST 1 PP DOES IT.
          SPACE  6
 RESALX   LJM    **
 RESALL   EQU    *-1
          LDDL   UNUML
          ZJK    RESALX      IF NO UNITS
          LDN    0
          STDL   UX
          STML   RESAL90     CLEAR FLAG FOR RESALL TO BE RECALLED LATER
 RESAL10  BSS
          LOADR  UNITS+/UN/P.CB,UX  ADDRESS OF COMMUNICATION BUFFER
          ADK    /SS/C.IRSET
          CRDL   T1
          LDDL   T1+/SS/P.IRSET-/SS/C.IRSET*4
          SHN    /SS/L.IRSET+2
          MJN    RESAL17     IF INITIAL SELECTIVE RESET HAS BEEN ISSUED

* DON'T ISSUE SELECTIVE RESET IF UNIT DISABLE FLAG IS SET.

          RJM    CDSABLE     CHECK THE UNIT DISABLE FLAG
          MJN    RESAL17     IF UNIT IS DISABLED

          LDML   UNITS+/UN/P.CM,UX  GET CONTROLLER NUMBER
          SHN    -3
          LPN    /UN/M.CM
          STDL   CMOD        CONTROLLER NUMBER
          LDML   UNITS+/UN/P.CHIX,UX  GET POINTER TO CHANT
          SHN    /UN/L.CHIX+/UN/N.CHIX+2
          LPK    /UN/M.CHIX
          STDL   CH
          RJM    SETLOCK     SET UNIT LOCK
          NJN    RESAL15     IF LOCK COULD NOT BE SET
          LDML   SS+/SS/P.IRSET  HAS INITIAL SELECTIVE RESET BEEN ISSUED
          SHN    /SS/L.IRSET+2
          MJN    RESAL30     IF INITIAL SELECTIVE RESET HAS BEEN ISSUED
          LDML   SS+/SS/P.SEEK  CHECK IF OUTSTANDING COMMAND
          SHN    /SS/L.SEEK+2
          PJN    RESAL20     IF NO OUTSTANDING COMMAND
          RJM    CLRLOCK     CLEAR UNIT LOCK
 RESAL15  BSS
          AOML   RESAL90     RECALL RESALL LATER
 RESAL17  UJN    RESAL40

 RESAL20  BSS
          LDML   SS+/SS/P.IRSET  SET FLAG FOR INITIAL SELECTIVE RESET ISSUED
          LPC    -/SS/K.IRSET
          ADK    /SS/K.IRSET
          STML   SS+/SS/P.IRSET
          LDML   SS+/SS/P.SRTRY  CLEAR FLAG FOR IF IN ERROR RECOVERY
          LPC    -/SS/K.SRTRY
          STML   SS+/SS/P.SRTRY
          RJM    CHGCH       CHANGE CHANNEL INSTRUCTIONS
          RJM    RESET       SEND SELECTIVE RESET
 RESAL30  BSS
          RJM    CSHOLD      CLEAR SELECT HOLD IF IT IS SET
          RJM    CLRLOCK     CLEAR UNIT LOCK
 RESAL40  BSS
          LDN    P.UN
          RADL   UX          BUMP UNIT ENTRY
          SBDL   UNUML
          MJK    RESAL10     IF NOT END OF TABLE
          LDML   RESAL90
          NJN    RESAL50     NOT ALL CONTROLLERS WERE RESET,
                             COME BACK LATER
          LDDL   IALF        SET FLAG FOR INITIAL RESET ISSUED ON
                             ALL CONTROLLERS
          LPC    -2
          ADN    2
          STDL   IALF
 RESAL50  BSS
          UJK    RESALX
          SPACE  6
 RESAL90  BSSZ   1           RECALL FLAG
          EJECT
** NAME-- RESET
*
** PURPOSE-- ISSUE SELECTIVE RESET TO A CONTROLLER.
          SPACE  6
 RESETX   LJM    **
 RESET    EQU    *-1
          LDML   SS+/SS/P.RESET  SET SELECTIVE RESET ATTEMPT
          LPC    -/SS/K.RESET
          ADK    /SS/K.RESET
          STML   SS+/SS/P.RESET
          LDK    /RS/K.SR    SET -ATTEMPTED SELECTIVE RESET- FLAG IN RESPONSE
          RJM    SID         ERROR ID
          RJM    SELCK       SELECT THE CONTROLLER ONLY IF NOT SELECTED
          LDK    F.SCS       SET SELECT HOLD AND COMMAND SEQUENCE
          RJM    FUNC
          LDK    W.RESET     ISSUE SELECTIVE RESET
          STDL   CMFUN
 K34      IFEQ   TRACE,1
          RJM    TBUF        PUT IN TRACE BUFFER
 K34      ENDIF
          ACN    DC
          LDN    1
          OAM    CMFUN,DC    SEND FUNCTION TO CONTROLLER
          RJM    DCN         DISCONNECT THE CHANNEL

* TEMPORARY, THROUGH TEMPORARY END.
* HYDRA PROBLEM. HYDRA DROPS SELECT ACTIVE WHICH LATER RESULTS IN ISI TIMEOUT.

          LDK    F.RDOS      READ OPERATIONAL STATUS
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    OPSTAT,DC
          DCN    40B+DC
 K35      IFEQ   TRACE,1
          LDDL   OPSTAT
          RJM    TBUF        PUT IN TRACE BUFFER
 K35      ENDIF
          CFM    RES20,DC
          AOML   RES100
          LDK    F.RDES      READ ERROR STATUS
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    RS+/RS/P.ESREG,DC  ERROR STATUS REGISTER
          DCN    40B+DC
          LDML   RS+/RS/P.ESREG
          STML   RES110
 K36      IFEQ   TRACE,1
          RJM    TBUF        PUT IN TRACE BUFFER
 K36      ENDIF
          CFM    RES20,DC    CLEAR CHANNEL ERROR FLAG
 RES20    BSS
          RJM    ICH         MASTER CLEAR I4 CHANNEL ADAPTER
          UJN    RES22

* TEMPORARY END.

          RJM    WAITTR      WAIT FOR TRANSFER IN PROGRESS TO CLEAR
 RES22    BSS
          AODL   CMNDS       INCREMENT COUNT OF OUTSTANDING CONTROLLER COMMANDS
          LDML   SS+/SS/P.SEEK  SET OUTSTANDING COMMAND FLAG
          LPC    -/SS/K.SEEK
          ADK    /SS/K.SEEK
          STML   SS+/SS/P.SEEK
          LDK    70+1        SET TIMEOUT VALUE TO 70 SECONDS
          STML   SS+/SS/P.TOVAL  TIMEOUT VALUE
          LDN    0
          STML   UNITS+/UN/P.ELAPT,UX  CLEAR ELAPSED TIME
          AOML   SS+/SS/P.RCNT  INCREMENT COMMAND ID
          STML   UNITS+/UN/P.RCNT,UX  KEEP COMMAND ID IN PP
          UJK    RESETX

 RES100   BSSZ   1
 RES110   BSSZ   1
          EJECT
** NAME-- CTEST
*
** PURPOSE-- RUN THE CONFIDENCE TEST ON ALL CONTROLLERS
*            WHEN THE PP IS FIRST LOADED.  FOR DUAL ACCESS,
*            JUST 1 PP DOES IT.
          SPACE  6
 CTESTX   LJM    **
 CTEST    EQU    *-1
 M11      IFNE   CMSE,1
          LDDL   UNUML
          ZJK    CTESTX      IF NO UNITS
          LDN    0
          STDL   UX
          STML   CTEST100    CLEAR FLAG FOR CONFIDENCE TEST TO BE RECALLED LATER
 CTEST10  BSS
          LDML   UNITS+/UN/P.CTST,UX  HAS THE CONFIDENCE TEST BEEN STARTED
          SHN    /UN/L.CTST+2
          MJK    CTEST40     IF THE CONFIDENCE TEST HAS BEEN STARTED
          LDDL   LOCKS       LAST UNIT LOCKED
          SBDL   UX
          NJN    CTEST11     IF THE UNIT IS NOT LOCKED AND THE SS TABLE
                             IN MEMORY
          LDML   SS+/SS/P.SEEK
          UJN    CTEST12

 CTEST11  BSS
          LOADR  UNITS+/UN/P.CB,UX  ADDRESS OF COMMUNICATION BUFFER
          ERRNZ  /SS/C.SEEK
          CRDL   T1
          LDDL   T1+/SS/P.SEEK-/SS/C.SEEK*4
 CTEST12  BSS
          SHN    /SS/L.SEEK+2
          MJN    CTEST15     IF THERE IS AN OUTSTANDING COMMAND

* DON'T RUN THE CONFIDENCE TEST IF THE UNIT DISABLE FLAG IS SET.

          RJM    CDSABLE     CHECK THE UNIT DISABLE FLAG
          MJN    CTEST17     IF UNIT IS DISABLED

          LDML   UNITS+/UN/P.CM,UX  GET CONTROLLER NUMBER
          SHN    -3
          LPN    /UN/M.CM
          STDL   CMOD        CONTROLLER NUMBER
          LDML   UNITS+/UN/P.CHIX,UX  GET POINTER TO CHANT
          SHN    /UN/L.CHIX+/UN/N.CHIX+2
          LPK    /UN/M.CHIX
          STDL   CH
          RJM    SETLOCK     SET UNIT LOCK
          NJN    CTEST15     IF LOCK COULD NOT BE SET
          LDML   SS+/SS/P.SEEK  CHECK IF OUTSTANDING COMMAND
          SHN    /SS/L.SEEK+2
          PJN    CTEST20     IF NO OUTSTANDING COMMANDS
          RJM    CLRLOCK     CLEAR UNIT LOCK
 CTEST15  BSS
          AOML   CTEST100    EXIT WITH IALF, BIT 2 = 0 TO BE RECALLED LATER
 CTEST17  UJK    CTEST40

 CTEST20  BSS
          LDML   UNITS+/UN/P.CTST,UX  SET FLAG FOR CONFIDENCE TEST STARTED
          LPC    -/UN/K.CTST
          ADK    /UN/K.CTST
          STML   UNITS+/UN/P.CTST,UX
          LDK    /RS/K.CT    SET FLAG FOR CONFIDENCE TEST STARTED
          RJM    SDET        PUT ID IN RESPONSE
          LDML   SS+/SS/P.CONF  SET CONFIDENCE TEST FLAG
          LPC    -/SS/K.CONF
          ADK    /SS/K.CONF
          STML   SS+/SS/P.CONF
          LDN    0
          STML   SS+/SS/P.CI  SECTORS TRANSFERRED
          STML   SS+/SS/P.NMED  NUMBER OF MEDIA ERRORS
          LDML   SS+/SS/P.STV  INDEX TO TABLE OF STARTING VALUES OF DATA
          LPC    -/SS/K.STV
          STML   SS+/SS/P.STV
          RJM    CHGCH       CHANGE CHANNEL INSTRUCTIONS
          RJM    WBUF        SEND A COMMAND BLOCK TO WRITE TO CONTROLLER BUFFER
          RJM    SAVSS       SAVE SS ENTRY
          LDN    NOLOCK      MAKE SURE LOCK ISN'T CLEARED
          STDL   LOCKS

* LEAVE THE UNIT LOCKED.

 CTEST40  BSS
          LDN    P.UN
          RADL   UX          BUMP UNIT ENTRY
          SBDL   UNUML
          MJK    CTEST10     IF NOT END OF TABLE
          LDML   CTEST100
          NJN    CTEST50     IF AT LEAST 1 UNIT IS LEFT
          LDDL   IALF        SET FLAG FOR CONFIDENCE TEST STARTED ON
                             ALL CONTROLLERS
          LPC    -4
          ADN    4
          STDL   IALF
 CTEST50  BSS
 M11      ENDIF
          UJK    CTESTX
 M12      IFNE   CMSE,1



 CTEST100 BSSZ   1           NONZERO IF CONFIDENCE TEST SHOULD BE ATTEMPTED LATER
          EJECT
** NAME-- WBUF
*
** PURPOSE-- SEND A COMMAND BLOCK TO WRITE TO THE CONTROLLER BUFFER.
          SPACE  6
 WBUFX    LJM    **
 WBUF     EQU    *-1
          LDML   SS+/SS/P.CWRITE  WRITE
          LPC    -/SS/K.CWRITE
          ADK    /SS/K.CWRITE
          STML   SS+/SS/P.CWRITE
* TEMPORARY, UNTIL ALL UNITS CAN READ/WRITE CONTROLLER BUFFER.
          RJM    CWR         SEND A COMMAND BLOCK TO WRITE TO DISK
*         RJM    CWRB        SEND A COMMAND BLOCK TO WRITE TO CONTROLLER BUFFER
          RJM    SETADD      SET STARTING DISK ADDRESS IN RESPONSE BUFFER
          UJK    WBUFX
          EJECT
* THE WRITE TO CONTROLLER BUFFER COMPLETED WITHOUT ERROR.

 CWBC     CON    0
          LDML   SS+/SS/P.CI  SECTORS TRANSFERRED
          ADC    -16
          ZJN    CWBC5       IF NO ERROR
          RJM    TERMA       CONTROLLER INTERFACE ERROR
*         (NO RETURN FROM TERMA.)

* SEND A COMMAND BLOCK TO READ.

 CWBC5    BSS
          LDML   SS+/SS/P.CWRITE  READ
          LPC    -/SS/K.CWRITE
          STML   SS+/SS/P.CWRITE
          LDN    0
          STML   SS+/SS/P.CI  SECTORS TRANSFERRED
          LDML   SS+/SS/P.CPERR  COMPARE ERROR FLAG
          LPC    -/SS/K.CPERR
          STML   SS+/SS/P.CPERR
          RJM    CWRB        SEND A COMMAND BLOCK TO READ FROM CONTROLLER BUFFER
 CWBC10   BSS
          RJM    SETADD      SET STARTING DISK ADDRESS IN RESPONSE BUFFER
 CWBC20   BSS
          RJM    SAVSS       SAVE SS ENTRY
          LDN    NOLOCK      MAKE SURE LOCK ISN'T CLEARED
          STDL   LOCKS
          LJM    MAIN10
          SPACE  6
* THE READ FROM CONTROLLER BUFFER COMPLETED WITHOUT ERROR.

 CRBC     CON    0
          LDML   SS+/SS/P.CI  SECTORS TRANSFERRED
          ADC    -16
          ZJN    CRBC10      IF NO ERROR
          RJM    TERMA       CONTROLLER INTERFACE ERROR
*         (NO RETURN FROM TERMA.)

 CRBC10   BSS
          LDML   SS+/SS/P.CPERR  CHECK IF THERE WAS A COMPARE ERROR
          SHN    /SS/L.CPERR+2
          MJN    CRBC40      IF COMPARE ERROR
          LDN    0
          STML   SS+/SS/P.CI  SECTORS TRANSFERRED
          LDML   SS+/SS/P.CWRITE  WRITE
          LPC    -/SS/K.CWRITE
          ADK    /SS/K.CWRITE
          STML   SS+/SS/P.CWRITE
          RJM    CWR         SEND A COMMAND BLOCK TO WRITE
          UJK    CWBC10
          SPACE  6

* DATA COMPARE ERROR.

CRBC40    BSS
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          LDK    /RS/K.HIE   HOST INTERFACE INTEGRITY ERROR
          RJM    SDET        PUT ERROR ID IN RESPONSE
          RJM    UTERM       UNRECOVERED ERROR, TURN OFF UNIT
*         (NO RETURN FROM UTERM.)
          SPACE  6
* THE WRITE TO DISK COMPLETED WITHOUT ERROR.

 CWRC     CON    0
          LDML   SS+/SS/P.CI  SECTORS TRANSFERRED
          ADC    -152
          ZJN    CWRC5       IF NO ERROR
          RJM    TERMA       CONTROLLER INTERFACE ERROR
*         (NO RETURN FROM TERMA.)

* SEND A COMMAND BLOCK TO READ FROM DISK.

 CWRC5    BSS
          LDML   SS+/SS/P.CWRITE  READ
          LPC    -/SS/K.CWRITE
          STML   SS+/SS/P.CWRITE
          LDN    0
          STML   SS+/SS/P.CI  SECTORS TRANSFERRED
          LDML   SS+/SS/P.CPERR  COMPARE ERROR FLAG
          LPC    -/SS/K.CPERR
          STML   SS+/SS/P.CPERR
          RJM    CWR         SEND A COMMAND BLOCK TO READ
          UJK    CWBC10
          SPACE  6
* THE READ FROM DISK COMPLETED WITHOUT ERROR.

 CRDC     CON    0
          LDML   SS+/SS/P.CI  SECTORS TRANSFERRED
          ADC    -152
          ZJN    CRDC10      IF NO ERROR
          RJM    TERMA       CONTROLLER INTERFACE ERROR
*         (NO RETURN FROM TERMA.)

 CRDC10   BSS
          LDML   SS+/SS/P.CPERR  CHECK IF THERE WAS A COMPARE ERROR
          SHN    /SS/L.CPERR+2
          MJK    CRDC40      IF COMPARE ERROR
          LDN    1
          ERRNZ  16-/SS/N.STV-/SS/L.STV
          RAML   SS+/SS/P.STV  INDEX TO TABLE OF STARTING VALUES OF DATA
          LPK    /SS/M.STV
          SBN    STVL
          ZJN    CRDC20      IF END OF STARTING VALUE TABLE
          LDN    0
          STML   SS+/SS/P.CI  SECTORS TRANSFERRED
          RJM    WBUF        SEND COMMAND BLOCK TO WRITE TO CONTROLLER BUFFER
 CRDC15   UJK    CWBC20

* END OF CONFIDENCE TEST.

 CRDC20   BSS
          LDML   SS+/SS/P.STV  ZERO OUT STARTING VALUES
          LPC    -/SS/K.STV
          STML   SS+/SS/P.STV
          LDML   SS+/SS/P.CONF  CLEAR CONFIDENCE TEST FLAG
          LPC    -/SS/K.CONF
          STML   SS+/SS/P.CONF
          LDML   SS+/SS/P.SEEK  CLEAR OUTSTANDING COMMAND FLAG
          LPC    -/SS/K.SEEK
          STML   SS+/SS/P.SEEK
          LDML   SS+/SS/P.RECOV
          NJK    CRDC15      IF IN ERROR RECOVERY
          RJM    CSHOLD      CLEAR SELECT HOLD IF IT IS SET
          RJM    CLRLOCK     CLEAR UNIT LOCK
          LJM    MAIN10

* DATA COMPARE ERROR.

CRDC40    BSS
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          LDK    /RS/K.DIE   DRIVE INTERFACE INTEGRITY ERROR
          RJM    SDET        PUT ERROR ID IN RESPONSE
          RJM    UTERM       UNRECOVERED ERROR, TURN OFF UNIT
*         (NO RETURN FROM UTERM.)
          SPACE  6
          EJECT
** NAME-- CWRB
*
** PURPOSE-- SEND A READ / WRITE COMMAND BLOCK TO TRANSFER TO THE CONTROLLER BUFFER.
          SPACE  6
 CWRBX    LJM    **
 CWRB     EQU    *-1
          RJM    SELCK       SELECT THE CONTROLLER ONLY IF NOT SELECTED
          LDML   SS+/SS/P.CWRITE
          SHN    /SS/L.CWRITE+2
          PJN    CWRB10      IF READ
          LDK    R.WB        WRITE TO CONTROLLER BUFFER
          STML   SS+/SS/P.FUNC  PARAMETER IN LOAD COMMAND BLOCK
          LDN    17
          UJN    CWRB20

 CWRB10   BSS
          LDK    R.RB        READ FROM CONTROLLER BUFFER
          STML   SS+/SS/P.FUNC  PARAMETER IN LOAD COMMAND BLOCK
          LDN    18
 CWRB20   BSS
          STML   SS+/SS/P.CMND  SET COMMAND PROCESSOR INDEX

          LDN    0
          STML   SS+/SS/P.PCYL  ZERO OUT PARAMETERS
          STML   SS+/SS/P.PTRK
          LDC    4096
          STML   SS+/SS/P.NSEC  STARTING WORD OFFSET IN CONTROLLER BUFFER
          RJM    CMND        WRITE THE COMMAND BLOCK
          LDML   SS+/SS/P.SEEK  SET SEEK ISSUED FLAG
          LPC    -/SS/K.SEEK
          ADK    /SS/K.SEEK
          STML   SS+/SS/P.SEEK

* SET UP THE RMA ADDRESS FOR THE WRITE.

          LDK    /CB/C.WRD   OFFSET FOR WRITE DATA
          ADML   SS+/SS/P.CI  ADVANCE 1 WORD FOR EACH SECTOR TRANSFERRED
          SHN    3           BYTE OFFSET
          ADML   CM.CBU+1    RMA OF COMMUNICATION BUFFER
          STML   SS+/SS/P.TOTAL+1
          SHN    -16
          ADML   CM.CBU
          STML   SS+/SS/P.TOTAL
          UJK    CWRBX
          EJECT
** NAME-- CWR
*
** PURPOSE-- SEND A READ / WRITE COMMAND BLOCK FOR THE CONFIDENCE TEST.
          SPACE  6
 CWRX     LJM    **
 CWR      EQU    *-1
          RJM    SELCK       SELECT THE CONTROLLER ONLY IF NOT SELECTED
          LDML   SS+/SS/P.CWRITE
          SHN    /SS/L.CWRITE+2
          PJN    CWR10       IF READ
          LDK    R.WRITE     SEEK AND WRITE
          STML   SS+/SS/P.FUNC  PARAMETER IN LOAD COMMAND BLOCK
          LDN    15
          UJN    CWR20

 CWR10    BSS
          LDK    R.READ      SEEK AND READ
          STML   SS+/SS/P.FUNC  PARAMETER IN LOAD COMMAND BLOCK
          LDN    16
 CWR20    BSS
          STML   SS+/SS/P.CMND  SET COMMAND PROCESSOR INDEX
          LDC    881         CYLINDER ADDRESS
          STML   SS+/SS/P.CYL
          STML   SS+/SS/P.PCYL
          LDN    0
          STDL   T1
          LDML   SS+/SS/P.CI  SECTOR OFFSET
          STML   SS+/SS/P.SECTOR  SECTOR ADDRESS
 CWR30    BSS
          LDML   SS+/SS/P.SECTOR  COMPUTE TRACK AND SECTOR ADDRESS
          ADC    -38
          MJN    CWR40       IF END OF COMPUTATION
          STML   SS+/SS/P.SECTOR
          AODL   T1          INCREMENT TRACK ADDRESS
          UJN    CWR30

 CWR40    BSS
          LDDL   T1          TRACK ADDRESS
          SHN    8
          RAML   SS+/SS/P.SECTOR  TRACK AND SECTOR ADDRESS
          STML   SS+/SS/P.PTRK  TRACK AND SECTOR ADDRESS

          LDC    152
          SBML   SS+/SS/P.CI  SECTOR OFFSET
          STML   SS+/SS/P.NSEC  NUMBER OF SECTORS TO END OF CYLINDER
          LDML   SS+/SS/P.CUR  CLEAR CURRENT REQUEST FLAG
          LPC    -/SS/K.CUR
          STML   SS+/SS/P.CUR
          RJM    CMND        WRITE THE COMMAND BLOCK
          LDML   SS+/SS/P.SEEK  SET SEEK ISSUED FLAG
          LPC    -/SS/K.SEEK
          ADK    /SS/K.SEEK
          STML   SS+/SS/P.SEEK

* SET UP THE RMA ADDRESS FOR THE WRITE.

          LDK    /CB/C.WRD   OFFSET FOR WRITE DATA
          ADML   SS+/SS/P.CI  ADVANCE 1 WORD FOR EACH SECTOR TRANSFERRED
          SHN    3           BYTE OFFSET
          ADML   CM.CBU+1    RMA OF COMMUNICATION BUFFER
          STML   SS+/SS/P.TOTAL+1
          SHN    -16
          ADML   CM.CBU
          STML   SS+/SS/P.TOTAL
          UJK    CWRX
          EJECT
** NAME-- CREC
*
** PURPOSE-- HANDLE UNRECOVERED MEDIA ERRORS WHILE RUNNING THE CONFIDENCE TEST.
*            ACCEPT 3 MEDIA FAILURES BEFORE THE CONFIDENCE TEST FAILS.
          SPACE  6
 CREX     LJM    **
 CREC     EQU    *-1
          LDN    0
          STDL   T2
          LDML   RS+/RS/P.DST2+2  FAILING TRACK AND SECTOR
          SHN    -8
          STDL   T1          TRACK
          ZJN    CRE20       IF TRACK = 0
 CRE10    BSS
          LDK    38
          RADL   T2
          SODL   T1
          NJK    CRE10
 CRE20    BSS
          LDDL   T2
          ADML   RS+/RS/P.DST2+2  ADD SECTOR
          LPC    377B
          STDL   T3          SECTOR OFFSET
          LDML   SS+/SS/P.NMED  NUMBER OF MEDIA ERRORS SO FAR
          STDL   T2
          STDL   T1
          ZJN    CRE40       IF NO MEDIA ERRORS SO FAR
 CRE30    BSS
          LDML   SS+/SS/P.MEDERR-1,T1  SECTOR OFFSET OF PREVIOUS MEDIA ERROR
          SBDL   T3          SECTOR OFFSET OF CURRENT ERROR
          ZJN    CRE50       IF THIS ADDRESS IS ALREADY IN THE LIST OF MEDIA ERRORS
          SODL   T1          NUMBER OF MEDIA ERRORS SO FAR
          NJK    CRE30       IF MORE TO CHECK
 CRE40    BSS
          LDDL   T3
          STML   SS+/SS/P.MEDERR,T2   SAVE ADDRESS OF THIS MEDIA ERROR
          AOML   SS+/SS/P.NMED  INCREMENT NUMBER OF MEDIA ERRORS
          SBN    /SS/NMEDL+1 NUMBER OF MEDIA ERRORS ALLOWED
          PJK    CREX        TOO MANY MEDIA ERRORS DURING THE CONFIDENCE TEST
 CRE50    BSS
          AODL   T3          SECTOR OFFSET
          STML   SS+/SS/P.CI  START UP TRANSFER AT THIS SECTOR OFFSET
          ADC    -152
          ZJN    CRE60       IF END OF CYLINDER
          RJM    CWR         SEND A COMMAND BLOCK
 CRE55    BSS
          LJM    CWBC20


* CALL THE COMMAND PROCESSOR FOR NORMAL TERMINATION.

 CRE60    BSS
          LDML   SS+/SS/P.CMND  COMMAND PROCESSOR INDEX
          STDL   T1
          LDML   CMDPR3,T1   COMMAND PROCESSOR FOR NORMAL TERMINATION
          STML   CRE70
          RJM    **
 CRE70    EQU    *-1
*         (NO RETURN FROM COMMAND PROCESSOR.)

          UJK    CRE55
          EJECT
** NAME-- TDATA
*
** PURPOSE-- TRANSFER DATA TO / FROM THE CONTROLLER
*            FOR THE READ - WRITE CONFIDENCE TEST.
          SPACE  6
 TDATA    CON    0
          LDC    152         NUMBER OF SECTORS FOR DISK TRANSFER
          STML   TDA500
          LDML   SS+/SS/P.FUNC  COMMAND CODE
          LPC    377B
          ADC    -R.WB       WRITE TO CONTROLLER BUFFER
          MJN    TDA10       IF READ/WRITE TO DISK
          LDN    16          NUMBER OF SECTORS FOR BUFFER TRANSFER
          STML   TDA500
 TDA10    BSS
          LDML   SS+/SS/P.CI  SECTORS TRANSFERRED
          SBML   TDA500
          MJN    TDA20       IF NO ERROR
          RJM    TERMA       CONTROLLER INTERFACE ERROR
*         (NO RETURN FROM TERMA.)

 TDA20    BSS
          LDN    0
          STDL   FRSTSC      FIRST SECTOR FLAG
          LDK    W.READT     READ AND TERMINATE
          STDL   MOVFC       FUNCTION CODE
          LDML   SS+/SS/P.CWRITE
          SHN    /SS/L.CWRITE+2
          PJN    TDA30       IF READ
          RJM    INID        INITIALIZE THE WRITE DATA BUFFER
          LDK    T.OUT       IF WRITE
          RADL   MOVFC

* THE CONTROLLER IS ALREADY SELECTED.
* AN ATTENTION HAS BEEN RECEIVED SAYING READ DATA AVAILABLE
* OR WRITE BUFFER SPACE AVAILABLE.
* SEND A FUNCTION WORD TRANSFER TO SET UP FOR A READ DATA
* OR WRITE DATA OPERATION.

 TDA30    BSS
          LDC    F.SCS       SET COMMAND SEQUENCE
          RJM    FUNC
          ACN    DC
          LDN    1
          OAM    MOVFC,DC    READ / WRITE DATA FUNCTION WORD
          RJM    DCN         DISCONNECT CHANNEL
 K37      IFEQ   TRACE,1
          LDDL   MOVFC
          RJM    TBUF        PUT IN TRACE BUFFER
 K37      ENDIF
          RJM    WAITTR      WAIT FOR TRANSFER IN PROGRESS TO CLEAR

* ENABLE DMA MODE.

          LDC    F.SDM       SET DMA MODE
          RJM    FUNC

* PREPARE T REGISTER VALUES.

 TDA40    BSS
          LDML   SS+/SS/P.TOTAL  RMA TO LOAD INTO T REGISTER
          STML   TREG+/TR/P.RMA
          LDML   SS+/SS/P.TOTAL+1
          STML   TREG+/TR/P.RMA+1
          LDC    CMBTS       NUMBER OF BYTES TO TRANSFER
          STDL   WDS
          STML   TREG+/TR/P.LEN  CM BYTES TO TRANSFER

* UPDATE SECTOR POSITION.


* CHECK IF SELECT ACTIVE IS STILL SET AND T' REGISTER EMPTY.

          LDN    2
          STML   WRI201      SET TIMEOUT VALUE FOR 2 SECONDS
 TDA50    BSS
          LDK    177777B
          STML   WRI200      SET TIMEOUT VALUE WHEN CHECKING T' REGISTER EMPTY
 TDA60    BSS
          RJM    ROPS        READ OPERATIONAL STATUS
          CFM    TDA70,DC    CHECK CHANNEL ERROR FLAG
          AOML   WRI300
          LDK    /RS/K.XFER  I4 DETECTED ERROR DURING DATA TRANSFER
 TDA65    LJM    TDA150

 TDA70    BSS
          LDDL   OPSTAT
          SHN    17-9        CHECK SELECT ACTIVE STILL SET
          PJK    TDA190      IF SELECT ACTIVE IS NOT SET
          SHN    9-1
          MJN    TDA80       IF T' REGISTER EMPTY
          SOML   WRI200
          NJN    TDA60       IF NOT TIMED OUT
          SOML   WRI201
          NJK    TDA50       IF NOT TIMED OUT
          AOML   WRI301
          LDK    /RS/K.XFRTO  TIMEOUT ON T' NOT EMPTY OR TRANSFER IN PROGRESS
          UJK    TDA65


* WRITE T' REGISTER.

 TDA80    BSS
          LDC    F.WTT       WRITE T' REGISTER
          RJM    FUNC
          ACN    DC
          LDN    3
          OAM    TREG,DC
          RJM    DCN         DISCONNECT CHANNEL
          LDML   SS+/SS/P.CWRITE
          SHN    /SS/L.CWRITE+2
          PJN    TDA100      IF READ
          AODL   FRSTSC
          SBN    1
          ZJN    TDA90       IF THE FIRST SECTOR TRANSFERRED FOR
                             THIS WRITE SEQUENCE
          SBN    2
          MJN    TDA90       IF THE SECOND SECTOR OF THIS TRANSFER

* PREVIOUS SECTOR HAS BEEN TRANSFERRED WITHOUT ERROR.
* UPDATE COUNTERS AND POINTERS.

          AOML   SS+/SS/P.CURSEC  INCREMENT SECTOR ADDRESS
          SBN    DVSEC       COMPARE WITH NUMBER OF SECTORS PER TRACK
          MJN    TDA90       IF NOT END OF TRACK
          STML   SS+/SS/P.CURSEC  CURRENT SECTOR
          AOML   SS+/SS/P.CURTRK  INCREMENT TRACK ADDRESS

* PREPARE FOR NEXT T REGISTER VALUES.

 TDA90    BSS
          LDN    8           UPDATE RMA ADDRESS
          RAML   SS+/SS/P.TOTAL+1
          SHN    -16
          RAML   SS+/SS/P.TOTAL
          AOML   SS+/SS/P.CI  INCREMENT SECTOR COUNT
          SBML   TDA500
          MJK    TDA40       IF MORE TO TRANSFER

* TERMINATE.
* WAIT FOR T AND T' REGISTERS TO BECOME EMPTY.
* THEN CLEAR COMMAND SEQUENCE AND CLEAR SELECT HOLD.

 TDA100   BSS
          LDN    2
          STML   WRI201      SET TIMEOUT VALUE FOR 2 SECONDS
 TDA110   BSS
          LDC    177777B     SET TIMEOUT VALUE WHEN CHECKING T REGISTER
                             COMPLETION
          STML   WRI200
 TDA120   BSS
          LDC    F.RDOS      READ OPERATIONAL STATUS
          RJM    FUNC
          ACN    DC
          LDN    1
          IAM    OPSTAT,DC   READ OPERATIONAL STATUS
          RJM    DCN         DISCONNECT CHANNEL
          CFM    TDA130,DC   CHECK CHANNEL ERROR FLAG
          AOML   WRI302
          LDK    /RS/K.XFER  I4 DETECTED ERROR DURING DATA TRANSFER
          UJN    TDA138

 TDA130   BSS
          LDDL   OPSTAT
          SHN    17-9        CHECK SELECT ACTIVE STILL SET
          PJK    TDA190      IF SELECT ACTIVE IS NOT SET
          LDDL   OPSTAT
          LPN    3           CHECK T' REGISTER, AND TRANSFER IN PROGRESS
          SBN    2
          ZJN    TDA140      IF T' REGISTER EMPTY, AND TRANSFER NOT IN PROGRESS
          SOML   WRI200      DECREMENT TIMEOUT COUNTER
 TDA135   NJK    TDA120      IF NOT TIMED OUT
          SOML   WRI201
 TDA137   NJK    TDA110      IF NOT TIMED OUT
          AOML   WRI303
          LDK    /RS/K.XFRTO  TIMEOUT ON T' NOT EMPTY OR TRANSFER IN PROGRESS
 TDA138   UJN    TDA150

* READ T REGISTER AND CHECK BYTE COUNT = 0.

 TDA140   BSS
          LDK    F.RDT       READ T REGISTER
          RJM    FUNC
          ACN    DC
          LDN    3
          IAM    RS+/RS/P.TREG,DC  T REGISTER
          DCN    40B+DC
          LDML   RS+/RS/P.TREG
          ZJN    TDA160      IF ALL WORDS HAVE BEEN TRANSFERRED
          SOML   WRI200      DECREMENT TIMEOUT COUNTER
          NJK    TDA135      IF NOT TIMED OUT
          SOML   WRI201
          NJK    TDA137      IF NOT TIMED OUT

* TRY TO RECOVER.

          AOML   WRI304
          LDK    /RS/K.TRTO  TIMEOUT ON T REGISTER BYTE COUNT NONZERO
 TDA150   BSS
          RJM    SID2        PUT ERROR ID IN RESPONSE
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    CHREG       SAVE CHANNEL REGISTERS
          LDK    F.CSH       CLEAR SELECT HOLD
          RJM    FUNC
          RJM    ADPTERR     RECOVER
*         (NO RETURN FROM ADPTERR.)

 TDA160   BSS
          LDML   SS+/SS/P.CWRITE
          SHN    /SS/L.CWRITE+2
          MJK    TDA180      IF WRITE
          LDML   SS+/SS/P.NMED  NUMBER OF MEDIA ERRORS SO FAR
          ZJN    TDA164      IF NO MEDIA ERRORS SO FAR
          STDL   T1
 TDA162   BSS
          LDML   SS+/SS/P.MEDERR-1,T1  SECTOR OFFSET OF PREVIOUS MEDIA ERROR
          SBML   SS+/SS/P.CI
          ZJN    TDA166      IF THIS ADDRESS COULD NOT BE WRITTEN
          SODL   T1
          NJK    TDA162      IF MORE TO CHECK
 TDA164   BSS
          RJM    CKD         CHECK THE DATA
          LDML   SS+/SS/P.CPERR  CHECK IF DATA MISCOMPARE
          SHN    /SS/L.CPERR+2
          MJN    TDA180      IF DATA MISCOMPARE
 TDA166   BSS
          AODL   FRSTSC

* PREVIOUS SECTOR HAS BEEN TRANSFERRED WITHOUT ERROR.
* UPDATE COUNTERS AND POINTERS.

          AOML   SS+/SS/P.CURSEC  INCREMENT SECTOR ADDRESS
          SBN    DVSEC       COMPARE WITH NUMBER OF SECTORS PER TRACK
          MJN    TDA170      IF NOT END OF TRACK
          STML   SS+/SS/P.CURSEC  CURRENT SECTOR
          AOML   SS+/SS/P.CURTRK  INCREMENT TRACK ADDRESS
 TDA170   BSS
          AOML   SS+/SS/P.CI  INCREMENT SECTOR COUNT
          SBML   TDA500
          MJK    TDA40       IF MORE TO TRANSFER


* CLEAR COMMAND SEQUENCE.

 TDA180   BSS
          LDC    F.CCS       CLEAR COMMAND SEQUENCE
          RJM    FUNC
          UJN    TDA200

* SELECT ACTIVE IS CLEAR.

 TDA190   BSS
          LDK    /RS/K.SADAT  SELECT ACTIVE DROPPED WHEN TRANSFERRING DATA
          RJM    SID2        PUT ERROR ID IN RESPONSE
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    CHREG       SAVE CHANNEL REGISTERS IN RESPONSE
          RJM    ICH         MASTER CLEAR THE I4 CHANNEL ADAPTER

 TDA200   BSS
          RJM    SAVSS       SAVE SS ENTRY
          LDN    NOLOCK      MAKE SURE LOCK ISN'T CLEARED
          STDL   LOCKS
          LJM    MAIN10
          SPACE  6
 TDA500   BSSZ   1           NUMBER OF SECTORS TO TRANSFER
          EJECT
** NAME-- INID
*
** PURPOSE-- INITIALIZE DATA FOR THE READ / WRITE CONFIDENCE TEST.
          SPACE  6
 INIX     LJM    **
 INID     EQU    *-1
          LDML   SS+/SS/P.STV  INDEX TO TABLE OF STARTING VALUES
          ERRNZ  16-/SS/L.STV-/SS/N.STV
          LPK    /SS/M.STV
          STDL   T1
          LDML   STVAL,T1    INITIALIZE STARTING VALUE
          STDL   P1
          ADN    1           EACH 16 BITS IS INCREMENTED BY 1
          STDL   P2
          ADN    1
          STDL   P3
          ADN    1
          STDL   P4
          LDC    /CB/WRDL    NUMBER OF CM WORDS TO INITIALIZE
          STDL   T1
          LOADC  CM.CB
          ADK    /CB/C.WRD   ADDRESS OF WRITE DATA
          STDL   T2
          UJN    INI30

 INI20    BSS
          AODL   T2          ADDRESS OF NEXT CM WORD
          LMC    400000B
 INI30    BSS
          CWDL   P1          WRITE THE NEXT CM WORD
          LDN    4
          STDL   T3
 INI40    BSS
          LDN    4
          RAML   P1-1,T3     CREATE NEXT CM WORD VALUE
          SODL   T3
          NJN    INI40       IF NOT END OF CM WORD
          SODL   T1          DECREMENT CM WORD COUNT
          NJK    INI20       IF NOT DONE INITIALIZING THE DATA
          UJK    INIX
          SPACE  6

* EACH ENTRY IN THE STVAL TABLE CONTAINS THE STARTING 16-BIT VALUE
* FOR INITIALIZING THE WRITE DATA BUFFER.  EACH 16 BIT-FIELD IN THE
* WRITE DATA BUFFER IS INCREMENTED BY 1.

 STVAL    CON    170000B     STARTING VALUES OF DATA
          CON    174000B
 STVL     EQU    2           NUMBER OF ENTRIES IN STVAL TABLE
          EJECT
** NAME-- CKD
*
** PURPOSE-- CHECK THE DATA WHEN DOING THE CONFIDENCE TEST.
          SPACE  6
 CKX      LJM    **
 CKD      EQU    *-1
          LDML   SS+/SS/P.STV  INDEX TO TABLE OF STARTING VALUES
          ERRNZ  16-/SS/L.STV-/SS/N.STV
          LPK    /SS/M.STV
          STDL   T1
          LDML   SS+/SS/P.CI  SECTOR OFFSET
          SHN    2           SECTOR OFFSET * 4
          ADML   STVAL,T1    STARTING VALUE OF SECTOR
          STDL   T5
          ADN    1
          STDL   T6
          ADN    1
          STDL   T7
          ADN    1
          STDL   T8
          LDC    /CB/RDDL    NUMBER OF WORDS TO COMPARE
          STDL   T1
          LOADC  CM.CB
          ADK    /CB/C.WRD   ADDRESS OF READ DATA
          STDL   T2
          UJN    CK20

 CK10     BSS
          AODL   T2          ADDRESS OF NEXT CM WORD
          LMC    400000B
 CK20     BSS
          CRDL   P1          DATA THAT WAS READ
          LDN    4
          STDL   T4
 CK30     BSS
          LDML   P1-1,T4     COMPARE THE DATA
          SBML   T5-1,T4
          NJN    CK40        IF COMPARE ERROR
          LDN    4
          RAML   T5-1,T4     CREATE NEXT CM WORD THAT WAS WRITTEN
          SODL   T4
          NJK    CK30        IF NOT END OF CM WORD
          SODL   T1
          NJK    CK10        IF NOT END OF SECTOR
 CK35     UJK    CKX

* DATA COMPARE ERROR.

 CK40     BSS
          LDML   SS+/SS/P.CPERR  SET COMPARE ERROR
          LPC    -/SS/K.CPERR
          ADK    /SS/K.CPERR
          STML   SS+/SS/P.CPERR
          UJK    CK35

 M12      ELSE
 CWBC     CON    0
 CRBC     EQU    CWBC
 CWRC     EQU    CWBC
 CRDC     EQU    CWBC
 TDATA    EQU    CWBC
          RJM    HALT
 M12      ENDIF
          EJECT

 M18      IFNE   CMSE,1
 BUFF     EQU    17470B
 M18      ELSE
 BUFF     EQU    17100B
 M18      ENDIF
          SPACE  6
 BUFFERS  BSS
          SPACE  4
 NODEL    BSSZ   1           DON'T DELINK REQUEST FLAG
 UDL      BSSZ   1           LENGTH OF UNIT DESCRIPTORS (CM WORDS)
 RALL     BSSZ   1           SET NONZERO TO RESTART ALL REQUESTS
 STUX     BSSZ   1           UNIT INDEX USED BY GETUD
 STORS    BSSZ   1           STORE RESPONSE FLAG (USED BY RESPIN)
                               = 0, IF A RESPONSE IS SENT TO CM
                               = NONZERO, IF NO RESPONSE WAS SENT TO CM
 RCON     BSSZ   1           ADDITIONAL RESPONSE CONDITION
 SAVE     BSSZ   1           USED TO SAVE UX VALUE
 SAVE2    BSSZ   1           USED TO SAVE CHANNEL INDEX
 CHLCNT   BSSZ   1           NUMBER OF REQUESTS TO PROCESS BEFORE
                             CLEARING CHANNEL LOCK
 LCLOCK   BSSZ   1           LAST CLOCK READ
 ELAPT    BSSZ   2           ELAPSED TIME IN MICROSECONDS
 IDLE     BSSZ   1           NONZERO IF IDLE COMMAND RECEIVED,
                               RESUME COMMAND RESETS IT TO 0
 RDAT     BSSZ   1           NONZERO IF READING ATTENTIONS
 CLEARL   BSSZ   1           NONZERO IF UNIT LOCK IS TO BE CLEARED IN TERM
 CSTREAM  BSSZ   1           CONTINUE STREAMING FLAG
 DEBUG1   BSSZ   1           USED FOR DEBUG PURPOSES
 DEBUG2   BSSZ   1           USED FOR DEBUG PURPOSES
 IGNORE   BSSZ   1           NONZERO, IF ERRORS ARE TO BE IGNORED
 RSP      BSSZ   1           IF SET, PROCESSING RESPONSE FLAG
          SPACE  6
 CHNUM    EQU    4           MAXIMUM NUMBER OF CHANNELS SUPPORTED
 CHANT    BSSZ   CHNUM*P.CH  CHANNEL TABLE
 CHFLG    BSSZ   CHNUM       CHANNEL LOCK FLAGS


 NTL      EQU    4*3         LENGTH OF TREG TABLE
 TREG     BSSZ   NTL         T REGISTER VALUES
          SPACE  6
 UNUM     EQU    32          SUPPORT 32 UNITS
 UNITS    BSSZ   UNUM*P.UN   RMA OF UNIT QUEUE TABLE
 SS       BSSZ   P.SS        INFORMATION SAVED IN UNIT COMMUNICATION BUFFER
 RQ       EQU    SS+/SS/P.RQ  REQUEST
 CM       EQU    RQ+/RQ/P.CMND  CURRENT COMMAND
 CMLIST   EQU    SS+/SS/P.CMLIST  INDIRECT RMA LIST
 CMWORK   EQU    SS+/SS/P.CMWORK  INDIRECT RMA WORKING LIST
 RS       EQU    SS+/SS/P.RS  RESPONSE BUFFER
          BSSZ   3           NEED AFTER RS BECAUSE OF HOW IT IS ZEROED OUT
          SPACE  6
 CMSTAT   BSSZ   6           HYDRA STATUS BLOCK
 CB       BSSZ   4           COMMAND BUFFER (UNUSED PORTION)
 FBUF     BSSZ   200B        FUNCTION HISTORY BUFFER
 FBUFL    EQU    *-FBUF      LENGTH OF FUNCTION BUFFER
 SBUF     BSSZ   16          STATUS HISTORY BUFFER
 SBUFL    EQU    *-SBUF      LENGTH OF STATUS BUFFER

 UBUF     BSSZ   C.UIT*4     UNIT INTERFACE TABLE BUFFER
 IBUF     BSSZ   C.UD*4      UNIT DESCRIPTOR BUFFER

 K38      IFEQ   TIMES,1
 TM1      BSSZ   4           ATTENTION RECEIVED IN GETUD
 TM2      BSSZ   4           ATTENTION HAS BEEN PROCESSED IN GETUD
 TM3      BSSZ   4           GETUD, BEFORE ISSUEING SEEK
 TM4      BSSZ   4           GETUD, AFTER SEEK WAS ISSUED
 TM5      BSSZ   4           CMND, BEFORE WRITING COMMAND BLOCK
 TM6      BSSZ   4           CMND, WHEN ATTENTION RECEIVED (INSERTED WAIT FOR ATTENTION)
 TM7      BSSZ   4           PROC, BEFORE SELECTING HYDRA
 TM8      BSSZ   4           PROC, AFTER SELECTING, BEFORE READING STATUS
 TM9      BSSZ   4           PROC, AFTER READING STATUS
 TM10     BSSZ   4           PROC, AFTER PROCESSING ATTENTION
 K38      ENDIF
 K39      IFEQ   TIMES2,1
 TM11     BSSZ   4           WRITE, AFTER SETTING DMA
 TM12     BSSZ   4           WRITE, AFTER T' EMPTY ON LAST TRANSFER
 TM13     BSSZ   4           WRITE, AFTER ATTENTION RECEIVED (INSERTED WAIT FOR ATTENTION)
 K39      ENDIF
 K40      IFEQ   TIMES,1
 TM14     BSSZ   4           TERM, BEGINNING
 TM15     BSSZ   4           TERM, AFTER SENDING RESPONSE, BEFORE DELRQ
 TM16     BSSZ   4           TERM, AFTER DELRQ
 TM17     BSSZ   4           TERM, BEFORE EXITING
 TM18     BSSZ   4           STATUS, BEFORE CLEAR ATTENTION
 TM19     BSSZ   4           STATUS, AFTER CLEAR ATTENTION
 TM20     BSSZ   4           UNSOL, BEFORE SETTING OPERATING MODE
 TM21     BSSZ   4           UNSOL, AFTER SETTING OPERATING MODE, BEFORE SETTING ATTENTION DELAY
 TM22     BSSZ   4           UNSOL, AFTER SETTING ATTENTION DELAY PARAMETERS
 TM23     BSSZ   4           WRITE, START OF LAST SECTOR LOOP
 TM24     BSSZ   4           WRITE, BEFORE CHECKING T' REGISTER EMPTY
 TM25     BSSZ   4           WRITE, WHEN T' REGISTER EMPTY
 TM26     BSSZ   4           WRITE, END OF LAST SECTOR LOOP
 K40      ENDIF
 K41      IFEQ   TIMES2,1
 TM50     BSSZ   12          LAST 12 TRANSFER TIMES
 TM51     BSSZ   12          LAST 12 ENDING ATTENTION TIMES
 K41      ENDIF
          SPACE  6
 R        ERRPL  *-BUFF      IF > 0, RESIDENT PORTION IS TOO LARGE
 BUFFERL  EQU    *-BUFFERS
          EJECT
 CODE     BSS
          ORG    BUFFERS
          LOC    CODE
          EJECT
** NAME-- OCTERM
*
** PURPOSE-- TURN OFF ALL UNITS ON A CONTROLLER.
          SPACE  6
 OCTERM   CON    0
          LDK    /RS/K.CMDN  CONTROLLER DOWN
          RJM    SID         ERROR ID
          RJM    OFFUN       SET UNIT DISABLE FLAG
          RJM    OFFCM       TURN OFF ALL UNITS ON A CONTROLLER
          LJM    LTERM       LEAVE THE REQUEST ON THE UNIT QUEUE
          EJECT
** NAME-- HTERM
*
** PURPOSE-- ABNORMAL TERMINATION FOR HARDWARE ERRORS.
          SPACE  6
 HTERM    CON    0
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE

          LDML   RS+/RS/P.PVA
          ADML   RS+/RS/P.PVA+1
          ADML   RS+/RS/P.PVA+2
          NJN    HTERM10     IF UNRECOVERED REQUEST
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          LJM    TERM90

 HTERM10  BSS
          LDN    R.ABN       ABNORMAL TERMINATION
          STDL   RESPC       RESPONSE CODE
          LJM    TERM        SEND TERMINATION RESPONSE
          EJECT
** NAME-- UTERM
*
** PURPOSE-- ABNORMAL TERMINATION FOR HARDWARE ERRORS.
*            TURN OFF THE UNIT.
          SPACE  6
 UTERM    CON    0

* SET UNIT DISABLE BIT.

          LDK    /RS/K.UDN   UNIT DOWN
          RJM    SID         ERROR ID
          RJM    OFFUN       SET UNIT DISABLE FLAG
          LJM    LTERM       LEAVE THE REQUEST ON THE UNIT Q
          EJECT
 ATERMA   BSS
          LDK    /RS/K.INTERR  INTERFACE ERROR
          RJM    SERR        SAVE ERROR ID
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    UTERM       DISABLE UNIT
*         (NO RETURN FROM UTERM.)
          EJECT
** NAME-- OTERM
*
** PURPOSE-- TURN OFF ALL UNITS ON THE CHANNEL.
*            DO NOT DELINK ANY REQUESTS.
          SPACE  6
 OTERM    CON    0
          LDK    /RS/K.CHDN  CHANNEL DOWN
          RJM    SID         ERROR ID
          RJM    OFFUN       SET UNIT DISABLE FLAG
          RJM    OFFCH       TURN OFF ALL UNITS ON CHANNEL
          SPACE  6
* LEAVE THE REQUEST ON THE UNIT Q.
* SEND AN UNSOLICITED MESSAGE.

 LTERM    BSS
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    DELCM       DELINK ANY COMPLETED REQUESTS
          LDN    0           UNSOLICITED MESSAGE
          STDL   RESPC       RESPONSE CODE
          AOML   NODEL       SET NO DELINK FLAG, SO REQUEST IS NOT DELINKED
          AOML   CLEARL      SET FLAG SO UNIT LOCK WILL BE CLEARED
          LDML   SS+/SS/P.SEEK  RESET FLAGS
          LPC    -/SS/K.CUR-/SS/K.SEEK
          STML   SS+/SS/P.SEEK
          LJM    TERM        TERMINATE REQUEST
          EJECT
** NAME-- DIAG
*
** PURPOSE-- EXECUTE CONTROLLER LEVEL I DIAGNOSTICS.
          SPACE  6
 DIAGX    LJM    **
 DIAG     EQU    *-1
          LDK    /RS/K.XD1   SET -EXECUTING DIAGNOSTICS- IN RESPONSE
          RJM    SID         ERROR ID

* WRITE COMMAND BLOCK TO RUN LEVEL I DIAGNOSTICS.

          LDN    0
          STML   SS+/SS/P.NSEC  SET COMMAND BLOCK PARAMETER = 0
          LDK    R.DIAG      RUN LEVEL I DIAGNOSTICS
          RJM    DIA         WRITE COMMAND BLOCK
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          LDN    6
          STML   SS+/SS/P.CMND  SET COMMAND PROCESSOR INDEX
          UJK    DIAGX
          EJECT
** NAME-- DIAGG
*
** PURPOSE-- EXECUTE CONTROLLER LEVEL II DIAGNOSTICS.
          SPACE  6
 DIAGGX   LJM    **
 DIAGG    EQU    *-1
          LDK    /RS/K.XD    SET -EXECUTING DIAGNOSTICS- IN RESPONSE
          RJM    SID         ERROR ID

* WRITE COMMAND BLOCK TO RUN LEVEL II DIAGNOSTICS.

          LDN    0
          STML   SS+/SS/P.NSEC  SET COMMAND BLOCK PARAMETER = 0
          LDK    R.DIAG2     RUN LEVEL II DIAGNOSTICS
          RJM    DIA         WRITE COMMAND BLOCK
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          LDN    14
          STML   SS+/SS/P.CMND  SET COMMAND PROCESSOR INDEX
          UJK    DIAGGX
          EJECT
** NAME-- DIAGSUB
*
** PURPOSE-- EXECUTE CONTROLLER LEVEL II DIAGNOSTIC COMMAND 78,
*            SUBTEST 6.
          SPACE  6
 DIAGSX   LJM    **
 DIAGSUB  EQU    *-1
          LDN    6
          STML   SS+/SS/P.NSEC  SET COMMAND BLOCK PARAMETER = 6
          LDK    R.DIAGS     RUN DIAGNOSTIC COMMAND 78
          RJM    DIA         WRITE COMMAND BLOCK
          LDN    7
          STML   SS+/SS/P.CMND  SET COMMAND PROCESSOR INDEX
          UJK    DIAGSX
          EJECT
** NAME-- DIAGW
*
** PURPOSE-- EXECUTE CONTROLLER LEVEL II DIAGNOSTIC COMMAND 79,
*            SUBTEST 5.
          SPACE  6
 DIAGWX   LJM    **
 DIAGW    EQU    *-1
          LDN    5
          STML   SS+/SS/P.NSEC  SET COMMAND BLOCK PARAMETER = 5
          LDK    R.DIAGW     RUN DIAGNOSTIC COMMAND 79
          RJM    DIA         WRITE COMMAND BLOCK
          LDN    13
          STML   SS+/SS/P.CMND  SET COMMAND PROCESSOR INDEX
          UJK    DIAGWX
          EJECT
** NAME-- DIA
*
** PURPOSE-- USED BY DIAG AND DIAGSUB.
          SPACE  6
 DIAX     LJM    **
 DIA      EQU    *-1
          STML   SS+/SS/P.FUNC  PARAMETER IN LOAD COMMAND BLOCK
          LDN    0
          STML   SS+/SS/P.PCYL  SET COMMAND BLOCK PARAMETER = 0
          STML   SS+/SS/P.PTRK  SET COMMAND BLOCK PARAMETER = 0
          RJM    SELCK       SELECT THE CONTROLLER ONLY IF NOT SELECTED
          RJM    CMND        WRITE COMMAND BLOCK
          UJK    DIAX
          EJECT
** NAME-- RCMRQ
*
** PURPOSE-- RESTART ALL THE REQUESTS ON A CONTROLLER.
          SPACE  6
 RCMX     LJM    **
 RCMRQ    EQU    *-1
          LDDL   UNUML
          ZJK    RCMX        IF NO UNITS
          LDML   UNITS+/UN/P.CM,UX  GET CONTROLLER NUMBER
          SHN    -3
          LPN    /UN/M.CM
          STDL   CMOD        CONTROLLER NUMBER
          LDDL   UX          SAVE UX
          STML   SAVE
          LDDL   CH          SAVE CHANNEL INDEX
          STML   SAVE2
          LDML   UNITS+/UN/P.CHIX,UX  GET CHANNEL INDEX
          SHN    /UN/L.CHIX+/UN/N.CHIX+2
          LPK    /UN/M.CHIX
          STDL   CH
          LDN    0
          STDL   UX
          STDL   CMNDS       RECOMPUTE NUMBER OF OUTSTANDING COMMANDS
 RCM10    BSS
          RJM    GETSS       GET SS ENTRY
          LDML   SS+/SS/P.SEEK  CHECK IF SEEK WAS ISSUED
          SHN    /SS/L.SEEK+2
          PJN    RCM16       IF SEEK WAS NOT ISSUED
          AODL   CMNDS       NUMBER OF OUTSTANDING CONTROLLER COMMANDS
          LDML   RALL
          NJN    RCM15       IF ALL REQUESTS ARE TO BE RESTARTED
          LDML   UNITS+/UN/P.CM,UX  GET CONTROLLER NUMBER
          SHN    -3
          LPN    /UN/M.CM
          SBDL   CMOD
          NJN    RCM20       IF NOT THE SAME CONTROLLER
          LDML   UNITS+/UN/P.CHIX,UX  GET CHANNEL INDEX
          SHN    /UN/L.CHIX+/UN/N.CHIX+2
          LPK    /UN/M.CHIX
          SBDL   CH
          NJN    RCM20       IF NOT THE SAME CHANNEL
 RCM15    BSS
          SODL   CMNDS       NO OUTSTANDING COMMAND ON THIS UNIT
          LDML   UNITS+/UN/P.LOCK,UX  GET LOCK FLAG
          ZJN    RCM19       IF THIS PP DOES NOT HAVE THE LOCK SET
          RJM    RSTRQ       RESTART REQUEST
          RJM    SAVSS       SAVE SS ENTRY
 RCM16    UJN    RCM20       LEAVE THE UNIT LOCK SET

 RCM18    BSS
          RJM    HALT        HALT THE PP
*         (NO RETURN FROM HALT.)

 RCM19    BSS
          RJM    SETLOCK     GET SS ENTRY AND SET UNIT LOCK
* TEMPORARY
          NJN    RCM18       IF LOCK COULD NOT BE SET, TEMPORARY HALT
          RJM    RSTRQ       RESTART REQUEST
 RCM20    BSS
          LDN    P.UN
          RADL   UX          BUMP UNIT ENTRY
          SBDL   UNUML
          MJK    RCM10       IF NOT END OF TABLE
          LDML   RALL
          ZJN    RCM40       IF REQUESTS ON ONLY 1 CONTROLLER
          LDN    0
          STML   RALL        ZERO OUT -RESTART ALL REQUESTS- FLAG
 RCM40    BSS
          LDML   SAVE        RESTORE UX
          STDL   UX
          LDML   SAVE2       RESTORE CHANNEL INDEX
          STDL   CH
          UJK    RCMX
          EJECT
** NAME-- TERAC
*
** PURPOSE-- TERMINATE ACTIVE COMMANDS.
          SPACE  6
 K42      IFEQ   T1,0
 TERACX   LJM    **
 TERAC    EQU    *-1
          UJK    TERACX
 K42      ENDIF
          EJECT
** NAME-- RSTRQ
*
** PURPOSE-- INCREMENT REQUEST RETRY COUNTER.  IF RETRIES HAVE
*            NOT BEEN EXHAUSTED, RESTART THE REQUEST.
          SPACE  6
 RSTX     LJM    **
 RSTRQ    EQU    *-1
          AOML   RS+/RS/P.RTRY  INCREMENT REQUEST RETRY COUNTER
          LDML   SS+/SS/P.CONF  CHECK IF DOING INITIAL CONFIDENCE TEST
          SHN    /SS/L.CONF+2
          MJK    RST40       IF DOING INITIAL CONFIDENCE TEST

* RESTART REQUEST FROM BEGINNING.

          LDML   SS+/SS/P.CURRQ2  RESTORE RMA OF CURRENT REQUEST
          STML   SS+/SS/P.REQ
          LDML   SS+/SS/P.CURRQ2+1
          STML   SS+/SS/P.REQ+1
          LDML   RS+/RS/P.PVA  RESTORE PVA OF CURRENT REQUEST
          STML   SS+/SS/P.PVA
          LDML   RS+/RS/P.PVA+1
          STML   SS+/SS/P.PVA+1
          LDML   RS+/RS/P.PVA+2
          STML   SS+/SS/P.PVA+2
          RJM    UREQ        READ UNIT REQUEST
          LDML   RQ+/RQ/P.CYL  RESTORE CYLINDER ADDRESS
          STML   SS+/SS/P.CYL
          LDML   RQ+/RQ/P.TRACK  RESTORE TRACK ADDRESS
          SHN    /SS/N.SECTOR
          ADML   RQ+/RQ/P.SECTOR  RESTORE SECTOR ADDRESS
          STML   SS+/SS/P.SECTOR
 RST20    BSS
          LDML   SS+/SS/P.SEEK  CLEAR SEEK ISSUED FLAG
          LPC    -/SS/K.SEEK
          STML   SS+/SS/P.SEEK
          SODL   SEKCNT      DECREMENT SEEK COUNT
          PJN    RST30
          LDN    0
          STDL   SEKCNT
 RST30    BSS
          RJM    DELCM       DELINK ANY COMPLETED REQUESTS
          RJM    SAVSS       SAVE SS ENTRY
          UJK    RSTX        RETURN A REGISTER = 0 TO RESTART REQUEST

* RESTART CONFIDENCE TEST.

 RST40    BSS
          LDDL   IALF        CLEAR FLAG FOR CONFIDENCE TEST STARTED
                             ON ALL CONTROLLERS
          LPC    -4
          STDL   IALF
          LDML   UNITS+/UN/P.CTST,UX  CLEAR FLAG FOR CONFIDENCE TEST STARTED
          LPC    -/UN/K.CTST
          STML   UNITS+/UN/P.CTST,UX
          UJK    RST20
          EJECT
** NAME-- DELCM.
*
** PURPOSE-- DELINK COMPLETED REQUESTS.
*            THIS IS CALLED ONLY ON ERRORS IN ORDER TO DELINK REQUESTS
*            WHICH HAVE STREAMED SUCCESSFULLY.
          SPACE  6
 DELCX    LJM    **
 DELCM    EQU    *-1
          LDN    0
          STML   SS+/SS/P.NCOMW  ZERO OUT NUMBER OF COMPLETED REQUESTS FOR WHICH
                             A RESPONSE WAS NOT SENT
          LDML   SS+/SS/P.NCOMRQ  NUMBER OF COMPLETED REQUESTS WHICH HAVE
                             SENT RESPONSES
          ZJN    DELCX       IF NO REQUESTS HAVE BEEN COMPLETED
          SOML   SS+/SS/P.NCOMRQ  DECREMENT COMPLETED REQUEST COUNT
          ZJN    DELCX      IF NOT STREAMING OF REQUESTS
          LDML   SS+/SS/P.PRERQ  SET UP RMA OF LAST GOOD COMPLETED REQUEST
          STML   SS+/SS/P.CURRQ
          LDML   SS+/SS/P.PRERQ+1
          STML   SS+/SS/P.CURRQ+1
          RJM    DELRQ       DELINK COMPLETED REQUESTS FROM QUEUE
                             AND SELECT NEW REQUEST
          UJK    DELCX
          EJECT
** NAME-- CKCMND
*
** PURPOSE-- COUNT THE NUMBER OF OUTSTANDING COMMANDS.
*
** NOTES-- IF THE OTHER ACCESS HAS THE UNIT LOCK SET,
*          DON'T LOOK AT THAT UNIT BECAUSE THE SEEK FLAG
*          IS INVALID.
          SPACE  6
 CKCMX    LJM    **
 CKCMND   EQU    *-1

* FIND ALL UNITS IN WHICH A COMMAND WAS IN PROGRESS.

          LDN    0
          STDL   CMNDS       RESET OUTSTANDING ADAPTER COMMANDS
          STDL   T1
          LDDL   UNUML
          ZJK    CKCMX       IF NO UNITS
 CKCM10   BSS
          LDML   UNITS+/UN/P.LOCK,T1
          NJN    CKCM15      IF THIS PP HAS THE LOCK SET
          LOADR  UNITS+/UN/P.UIT,T1
          ADN    /UIT/C.ULOCK
          CRDL   T2          READ UNIT LOCKWORD
          LDDL   T2
          NJN    CKCM20      IF OTHER ACCESS HAS THE LOCK SET
 CKCM15   BSS
          LOADR  UNITS+/UN/P.CB,T1  ADDRESS OF UNIT COMMUNICATION BUFFER
          CRDL   P1          CHECK IF SEEK WAS ISSUED
          ERRNZ  /SS/P.SEEK
          LDDL   LOCKS       UNIT INDEX FOR SS TABLE
          SBDL   T1
          NJN    CKCM17      IF SS TABLE NOT IN MEMORY
          LDML   SS+/SS/P.SEEK  GET SEEK FLAG FROM SS TABLE
          STDL   P1
 CKCM17   LDDL   P1
          SHN    /SS/L.SEEK+2
          PJN    CKCM20      IF SEEK WAS NOT ISSUED
          AODL   CMNDS       NUMBER OF OUTSTANDING COMMANDS
 CKCM20   BSS
          LDN    P.UN
          RADL   T1          INCREMENT UNIT INDEX
          SBDL   UNUML       CHECK FOR END OF TABLE
          MJK    CKCM10      IF NOT END OF TABLE
          UJK    CKCMX
          EJECT
** NAME-- CLRUL
*
** PURPOSE-- CLEAR ALL THE UNIT LOCKS.
          SPACE  6
 CLRX     LJM    **
 CLRUL    EQU    *-1
          LDDL   UNUML
          ZJK    CLRX        IF NO UNITS
          LDDL   UX          SAVE UX
          STDL   SAVUX
          LDN    0
          STDL   UX
 CLR10    BSS
          LDML   UNITS+/UN/P.LOCK,UX
          ZJN    CLR20       IF THIS PP DOES NOT HAVE THE LOCK SET
          RJM    SETLOCK     GET SS ENTRY
          NJN    CLR20       IF LOCK REALLY WASN'T SET, SHOULD NEVER HAPPEN
          RJM    CSHOLD      CLEAR SELECT HOLD IF IT IS SET
          RJM    CLRLOCK     CLEAR THE UNIT LOCK
 CLR20    BSS
          LDN    P.UN
          RADL   UX          BUMP UNIT ENTRY
          SBDL   UNUML
          MJK    CLR10       IF NOT END OF TABLE
          LDDL   SAVUX       RESTORE UX
          STDL   UX
          UJK    CLRX
          EJECT
** NAME-- PPR
*
** PURPOSE-- CHECK FOR IDLE OR RESUME REQUESTS.
          SPACE  6
 PPR1     BSS
 M30      IFNE   CMSE,1
          AOML   IGNORE      IGNORE ERRORS DURING IDLE PROCESSING
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          ERRNZ  /PIT/C.IDLE
          CRDL   T1          READ PP REQUEST FLAGS
          LDDL   T4
          SHN    /PIT/L.IDLE+2
          MJN    PPR20       IF IDLE REQUEST FLAG IS SET
          SHN    /PIT/L.RESUME-/PIT/L.IDLE
          PJK    PPR40       IF RESUME REQUEST FLAG IS NOT SET

* PROCESS RESUME REQUEST.

          LDML   IDLE        IDLE FLAG
          ZJN    PPR10       IF ALREADY RESUMED
          RJM    ICOM        INITIALIZE UNIT TABLES
 PPR10    BSS
          RJM    RESUME      RESUME THE DRIVER
          LDK    -/PIT/K.RESUME-/PIT/K.IDSTAT-/PIT/K.LOCKF  FLAGS TO CLEAR
          STDL   T5
          LDN    0
          STDL   T6          FLAGS TO SET
          LJM    PPR30

* PROCESS IDLE REQUEST.

 PPR20    BSS
          LDML   RSP         PROCESSING RESPONSE FLAG
          ZJN    PPR22       IF NOT PROCESSING A RESPONSE
          AOML   DEBUG2      SET FOR DEBUG PURPOSES ONLY
          RJM    SAVSS       SAVE SS ENTRY
          RJM    RCMRQ       RESTART THE REQUESTS
          LDN    0
          STML   RSP         CLEAR PROCESSING RESPONSE FLAG

 PPR22    BSS
          RJM    CKCMND      CHECK IF ANY OUTSTANDING COMMANDS
          LDDL   CMNDS
          ZJN    PPR25       IF NO OUTSTANDING COMMANDS
          LDN    1
          STDL   PIDLE       SET PRE-IDLE FLAG
          UJK    PPR40

 PPR25    BSS
          RJM    CSLOCK      CLEAR THE LAST UNIT LOCK, IF ANY
          RJM    CLRUT       CLEAR UNIT TABLES
          RJM    IDLEP       SOFTWARE IDLE THE DRIVER
          LDK    -/PIT/K.IDLE-/PIT/K.IDSTAT-/PIT/K.LOCKF  FLAGS TO CLEAR
          STDL   T5
          LDK    /PIT/K.IDSTAT  FLAGS TO SET
          STDL   T6
 PPR30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDK    /PIT/K.LOCKF
          STDL   T4
          LOADC  CM.PIT
          ERRNZ  /PIT/C.LOCKF
          RDSL   T1          TRY TO SET THE LOCK
          LDDL   T4
          LPK    /PIT/K.LOCKF
          NJK    PPR30       IF SOMEONE ELSE HAS THE LOCK
          LDDL   T4
          LPDL   T5          CLEAR FLAGS
          LMDL   T6          SET FLAGS
          STDL   T4
          LOADC  CM.PIT
          ERRNZ  /PIT/C.LOCKF
          CWDL   T1          WRITE THE NEW FLAGS
 PPR40    BSS
          LDN    0
          STML   IGNORE      ALLOW ERRORS TO BE PROCESSED
          UJK    MAIN15
 M30      ENDIF
          EJECT
 MM1      IFEQ   T1,0
 PPRQ10   BSS
 M19      IFNE   CMSE,1
          RJM    CSLOCK      CLEAR THE LAST UNIT LOCK, IF ANY
          RJM    CLRUL       CLEAR ALL UNIT LOCKS

* SET PP QUEUE LOCKWORD.

          RJM    SPLOCK      SET PP QUEUE LOCKWORD
          ZJN    PPRQ20      IF LOCK WAS SET

 PPRQ15   BSS
          LDN    0
          UJK    PPRQX       EXIT, A REGISTER = 0

* GET THE RMA OF THE FIRST PP REQUEST IN THE CHAIN.

 PPRQ20   BSS
          LOADC  CM.PIT
          ADN    /PIT/C.PPQ
          CRDL   T5          READ RMA OF FIRST REQUEST IN CHAIN

* READ THE PP REQUEST.

          LOADF  T7          CM ADDRESS OF FIRST PP REQUEST
          ADN    /RQ/C.CMND
          CRDL   T1          READ COMMAND

* IF AN IDLE REQUEST, DON'T PROCESS IT UNTIL ALL OUTSTANDING CHANNEL
* COMMANDS HAVE BEEN PROCESSED.

          LDML   T1+/CM/P.CODE  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          SBN    C.IDLE
          NJN    PPRQ30      IF NOT AN IDLE REQUEST
          RJM    CKCMND      CHECK IF ANY OUTSTANDING COMMANDS
          LDDL   CMNDS
          ZJN    PPRQ25      IF NO OUTSTANDING COMMANDS
          LDN    1
          STDL   PIDLE       SET PRE-IDLE FLAG
          RJM    CPLOCK      CLEAR PP QUEUE LOCKWORD
          UJK    PPRQ15

 PPRQ25   BSS
          RJM    CLRUT       CLEAR UNIT FLAGS
          UJN    PPRQ40


* IF AN RESUME REQUEST, INITIALIZE THE UNIT TABLES.

 PPRQ30   BSS
          SBN    C.RESUME-C.IDLE
          NJN    PPRQ40      IF NOT A RESUME REQUEST
          RJM    ICOM        INITIALIZE UNIT TABLES

* GET THE RMA OF THE FIRST PP REQUEST IN THE CHAIN.

 PPRQ40   BSS
          LDN    2
          STDL   WC
          LOADC  CM.PIT
          ADN    /PIT/C.PPQPVA
          CRML   T1,WC       READ PVA AND RMA OF FIRST REQUEST IN CHAIN

* PUT PVA AND RMA OF REQUEST IN SS TABLE.

          LDDL   T2          PUT PVA OF REQUEST IN SS TABLE
          STML   SS+/SS/P.PVA
          LDDL   T3
          STML   SS+/SS/P.PVA+1
          LDDL   T4
          STML   SS+/SS/P.PVA+2
          LDDL   T7          PUT RMA OF REQUEST IN SS TABLE
          STML   SS+/SS/P.REQ
          LDDL   T8
          STML   SS+/SS/P.REQ+1
          LDML   SS+/SS/P.FRST  SET FLAG WHEN REQUEST IS READ
          LPC    -/SS/K.FRST
          STML   SS+/SS/P.FRST

* READ THE PP REQUEST.

          LDN    C.RQ
          STDL   P1
          LOADF  T7          CM ADDRESS OF FIRST PP REQUEST
          CRML   RQ,P1       READ PP REQUEST

* DELINK THE FIRST PP REQUEST FROM THE CHAIN.

          LOADC  CM.PIT
          ADN    /PIT/C.PPQPVA  CM ADDRESS OF PP QUEUE POINTER
          CWML   RQ,WC       WRITE PVA AND RMA POINTERS OF NEXT REQUEST

* CLEAR PP QUEUE LOCKWORD.

          RJM    CPLOCK      CLEAR PP QUEUE LOCKWORD

* DETERMINE NUMBER OF COMMANDS.

          LDML   RQ+/RQ/P.LEN  DETERMINE NUMBER OF COMMANDS
          SHN    -3
          SBN    /RQ/C.CMND
          STML   SS+/SS/P.NUMCM  NUMBER OF COMMANDS

          AOML   PPRQ        SET PP REQUEST FLAG
          UJK    PPRQX       EXIT, A REGISTER NONZERO
 M19      ENDIF
 MM1      ENDIF
          EJECT
** NAME-- IDLEP
*
** PURPOSE-- PROCESS IDLE COMMAND.
          SPACE  6
 IDLX     LJM    **
 IDLEP    EQU    *-1
 M20      IFNE   CMSE,1
          AOML   IDLE        SET IDLE FLAG
          LDN    0
          STDL   CH
 IDL10    BSS
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          LDN    P.CH
          RADL   CH
          SBDL   CNUML
          MJK    IDL10       IF NOT END OF TABLE
 M20      ENDIF
          UJK    IDLX
          EJECT
** NAME-- RESUME
*
** PURPOSE-- PROCESS RESUME COMMAND.
          SPACE  6
 RESUX    LJM    **
 RESUME   EQU    *-1
 M21      IFNE   CMSE,1
          LDN    0
          STML   IDLE        CLEAR IDLE FLAG
          STDL   PIDLE       CLEAR PRE-IDLE FLAG
 M21      ENDIF
          UJK    RESUX
          EJECT
** NAME-- STOP
*
** PURPOSE-- SET THE UNIT DISABLE FLAG IN THE UNIT INTERFACE TABLE.
          SPACE  6
 K43      IFEQ   T1,0
 STOPX    LJM    **
 STOP     EQU    *-1
          LOADF  CM+/CM/P.RMA  LOAD ADDRESS OF UNIT INTERFACE TABLE
          RJM    OFFUN       SET UNIT DISABLE
          UJK    STOPX
 K43      ENDIF
          EJECT
** NAME-- CLRUT
*
** PURPOSE-- CLEAR UNIT TABLES.
*
** NOTE-- IF THE UNIT LOCK CAN NOT BE SET, IT SKIPS THAT UNIT.
*         THIS ROUTINE SHOULD BE CALLED ONLY WHEN PROCESSING AN IDLE REQUEST,
*         AND AFTER ALL OUTSTANDING I/O IS COMPLETE AND ALL OF ITS OWN UNIT
*         LOCKS ARE CLEAR.
*         IF A UNIT IS BEING DISABLED AND THE REQUESTS DELINKED, THE OTHER
*         ACCESS WILL ALSO GET AN IDLE REQUEST AND WILL BE ABLE TO CLEAR
*         THAT UNIT.
*         IF A CHANNEL IS MANUALLY DOWNED, ONLY 1 PP WILL GET AN IDLE REQUEST.
          SPACE  6
 CLRUX    LJM    **
 CLRUT    EQU    *-1
          LDN    0
          STDL   UX          UNITS TABLE INDEX
          STDL   IALF        CLEAR INITIALIZE FLAG SO EVERYTHING
                             WILL GET INITIALIZED
          LDDL   UNUML
          ZJK    CLRUX       IF NO UNITS
 CLRU10   BSS
          LDML   UNITS+/UN/P.CTST,UX  CLEAR FLAG THAT CONFIDENCE TEST WAS RUN
          LPC    -/UN/K.CTST
          STML   UNITS+/UN/P.CTST,UX
          LDML   UNITS+/UN/P.CM,UX  GET CONTROLLER NUMBER
          SHN    -3
          LPN    /UN/M.CM
          STDL   CMOD        CONTROLLER NUMBER
          LDML   UNITS+/UN/P.CHIX,UX  GET CHANNEL INDEX
          SHN    /UN/L.CHIX+/UN/N.CHIX+2
          LPK    /UN/M.CHIX
          STDL   CH
          RJM    SETLOCK     SET THE UNIT LOCK
          NJN    CLRU20      IF THE LOCK COULD NOT BE SET
          LDML   SS+/SS/P.SEEK
          SHN    /SS/L.SEEK+2
          MJN    CLRU18      IF OUTSTANDING COMMAND, LET OTHER ACCESS
                             PROCESS IT AND CLEAR THIS UNIT.
                             (OTHER ACCESS MUST HAVE SET THIS FLAG OR
                             CLEARED ITS LOCK AFTER CKCMND WAS EXECUTED.)
          LDML   SS+/SS/P.SEEK  RESET FLAGS
          LPC    -/SS/K.CUR-/SS/K.SEEK-/SS/K.INIT
          STML   SS+/SS/P.SEEK
          ERRNZ  /SS/P.CUR-/SS/P.SEEK
          ERRNZ  /SS/P.SEEK-/SS/P.INIT
          LDML   SS+/SS/P.IRSET  CLEAR FLAG THAT INITIAL SELECTIVE
                             RESET WAS DONE
          LPC    -/SS/K.IRSET
          STML   SS+/SS/P.IRSET
          RJM    CFLGS       CLEAR FLAGS
 CLRU18   BSS
          RJM    CSHOLD      CLEAR SELECT HOLD IF IT IS SET
          RJM    CLRLOCK     CLEAR THE UNIT LOCK
 CLRU20   BSS
          LDN    P.UN
          RADL   UX          BUMP UNITS TABLE INDEX
          SBDL   UNUML
          NJK    CLRU10      IF NOT END OF TABLE
          UJK    CLRUX
          EJECT
** NAME-- OFFCH
*
** PURPOSE-- TURN OFF ALL UNITS ON A CHANNEL.
          SPACE  6
 OFCX     LJM    **
 OFFCH    EQU    *-1
          LDDL   UNUML
          ZJK    OFCX        IF NO UNITS
          RJM    SAVSS       SAVE SS ENTRY
          LDDL   UX          SAVE UX
          STDL   P6
          LDN    0
          STDL   UX          UNITS TABLE INDEX
 OFC10    BSS
          RJM    OFF         SET UNIT DISABLE FLAG
          LDN    P.UN
          RADL   UX          BUMP UNITS TABLE INDEX
          SBDL   UNUML
          NJK    OFC10       IF NOT END OF TABLE
          LDDL   P6
          STDL   UX          RESTORE UX
          RJM    GETSS       RESTORE SS ENTRY
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          AOML   CHANT+/CH/P.DOWN,CH  SET CHANNEL DOWN FLAG
          UJK    OFCX
          EJECT
** NAME-- OFFCM
*
** PURPOSE-- TURN OFF ALL UNITS ON A CONTROLLER.
          SPACE  6
 OFFCMX   LJM    **
 OFFCM    EQU    *-1
          LDDL   UNUML
          ZJK    OFFCMX      IF NO UNITS
          RJM    SAVSS       SAVE SS ENTRY
          LDDL   UX          SAVE UX
          STDL   P6
          LDN    0
          STDL   UX          UNITS TABLE INDEX
 OFFCM10  BSS
          LDML   UNITS+/UN/P.UNIT,P6  COMPARE IF SAME CONTROL MODULE
          LMML   UNITS+/UN/P.UNIT,UX
          LPN    70B
          NJN    OFFCM20     IF NOT THE SAME CONTROL MODULE
          RJM    OFF         SET UNIT DISABLE FLAG
 OFFCM20  BSS
          LDN    P.UN
          RADL   UX          BUMP UNITS TABLE INDEX
          SBDL   UNUML
          NJK    OFFCM10     IF NOT END OF TABLE
          LDDL   P6
          STDL   UX          RESTORE UX
          RJM    GETSS       RESTORE SS ENTRY
          UJK    OFFCMX
          EJECT
** NAME-- OFF
*
** PURPOSE-- SET THE UNIT LOCK, SET THE UNIT DISABLE FLAG,
*            AND CLEAR IMPORTANT FLAGS.
*
** NOTE-- IF THE LOCK CAN NOT BE SET, JUST SET THE UNIT DISABLE
*         FLAG.  AN IDLE REQUEST WHICH GOES TO ALL PPS WHENEVER
*         A UNIT IS DISABLED WILL CLEAR THE OTHER FLAGS.
          SPACE  6
 OFFX     LJM    **
 OFF      EQU    *-1
          LDML   UNITS+/UN/P.CHIX,UX  GET CHANNEL INDEX
          SHN    /UN/L.CHIX+/UN/N.CHIX+2
          LPK    /UN/M.CHIX
          SBDL   CH
          NJK    OFFX        IF NOT THE SAME CHANNEL

* IF UNIT IS DISABLED, DO NOT SETLOCK.
* THIS INSURES THE FAILING UNIT'S RESPONSE IS NOT CLEARED AT
* THIS TIME.

          RJM    CDSABLE     CHECK THE UNIT DISABLE FLAG
          MJN    OFFX        IF UNIT IS ALREADY DISABLED

          RJM    OFFUN       SET UNIT DISABLE FLAG
          RJM    SETLOCK     SET THE UNIT LOCK
          NJK    OFFX        IF LOCK WAS NOT SET

          LDML   SS+/SS/P.SEEK  RESET FLAGS
          LPC    -/SS/K.CUR-/SS/K.SEEK
          STML   SS+/SS/P.SEEK
          RJM    ZRESP       ZERO OUT RESPONSE BUFFER
          RJM    CLRLOCK     CLEAR UNIT LOCK
          UJK    OFFX
          EJECT
** NAME-- OFFUN
*
** PURPOSE-- SET THE DISABLE FLAG ON THE UNIT INTERFACE TABLE.
*
** INPUT-- A & R REGISTERS = CM ADDRESS OF UNIT INTERFACE TABLE.
          SPACE  6
 OFUX     LJM    **
 OFFUN    EQU    *-1
          LOADR  UNITS+/UN/P.UIT,UX  LOAD ADDRESS OF UNIT INTERFACE TABLE
          ERRNZ  /UIT/C.DSABLE
          STDL   T1
          LDK    /UIT/K.DSABLE  SET UNIT DISABLE FLAG
          STDL   T3
          LDN    0
          STDL   T2
          STDL   T4
          STDL   T5
          LDDL   T1
          LMC    400000B
          RDSL   T2          -LOGICAL OR- THE UNIT DISABLE FLAG
          UJK    OFUX
          EJECT
** NAME-- ONUN
*
** PURPOSE-- CLEAR THE DISABLE FLAG IN THE UNIT INTERFACE TABLE.
          SPACE  6
 K44      IFEQ   T1,0
 ONUNX    LJM    **
 ONUN     EQU    *-1
          LDK    -/UIT/K.DSABLE  CLEAR UNIT DISABLE FLAG
          STDL   T3
          LDC    177777B
          STDL   T2
          STDL   T4
          STDL   T5
          LOADF  CM+/CM/P.RMA  LOAD ADDRESS OF UNIT INTERFACE TABLE
          ERRNZ  /UIT/C.DSABLE
          RDCL   T2          -LOGICAL AND- TO CLEAR THE UNIT DISABLE FLAG
          UJK    ONUNX
 K44      ENDIF
          EJECT
 CONCH    BSS                DISK CHANNEL REFERENCES
 TDC+40B  HERE
 T40B+DC  HERE
 TDC      HERE
          CON    0           END OF TABLE
          EJECT
** NAME-- ICOM
*
** PURPOSE-- INITIALIZE THE UNIT COMMUNICATION BUFFER IN ALL THE UNIT
*            INTERFACE TABLES.
*            INITIALIZE ALL STATIC VARIABLES IN THE COMMUNICATION
*            BUFFER:  CHANNEL NUMBER, SEEK FUNCTION,
*            UNIT NUMBER, COMMUNICATION BUFFER (RMA), UNIT INTERFACE
*            TABLE (RMA).
          SPACE  6
 ICOMX    LJM    **
 ICOM     EQU    *-1

* INITILIZE VARIABLES.

          LDN    0
          STDL   LUX         LAST UNIT SELECTED
          STDL   CNUML       END OF CHANNEL TABLE
          STDL   UNUML       END OF ACTIVE UNIT TABLE

          LDML   UDL         LENGTH OF UNIT DESCRIPTORS (CM WORDS)
          ZJN    ICOMX       IF NO UNIT DESCRIPTORS

* ZERO OUT UNITS TABLE.

          LDK    UNUM*P.UN
          STDL   T1
 ICOM5    BSS
          LDN    0
          STML   UNITS-1,T1  ZERO OUT UNITS TABLE
          SODL   T1
          NJN    ICOM5

          LDN    0
          STDL   P5          NUMBER OF CONFIGURED UNITS
          STDL   P6          INDEX TO UNIT DESCRIPTORS
          STDL   UX          CONFIGURED UNIT TABLE INDEX
          LDC    CHFLG
          STDL   P4          ADDRESS OF CHANNEL LOCK FLAG
 ICOM10   BSS
          LDDL   CM.PIT+2    CM ADDRESS OFFSET OF UNIT DESCRIPTORS
          ADN    C.PIT
          ADDL   P6
          STDL   CMADR+2
          LDN    C.UD        READ 2 CM WORDS
          STDL   WC
          LOADC  CM.PIT,CMADR+2
          CRML   IBUF,WC     READ UNIT DESCRIPTOR
 K45      IFEQ   VALID,1
          RJM    CHKUD       CHECK FOR VALID UNIT DESCRIPTOR
 K45      ENDIF

* CHECK FOR NULL ENTRY.

          LDML   IBUF+/UD/P.UQT  RMA = 0 IF NULL ENTRY
          ADML   IBUF+/UD/P.UQT+1
          ZJK    ICOM85      IF NULL ENTRY

* ZERO OUT SS ENTRY.
* DONT ZERO OUT REQUEST OR RESPONSE BUFFER.

          LDK    UNUM*P.UN   TEMPORARY SETTING
          STDL   UNUML       END OF ACTIVE UNIT TABLE (TEMPORARY SETTING FOR NOW)
          LDK    /SS/P.RQ
          STDL   T1
 ICOM20   BSS
          LDN    0
          STML   SS-1,T1     ZERO OUT SS ENTRY
          SODL   T1
          NJN    ICOM20
          LDML   IBUF+/UD/P.UQT+1  INITIALIZE START OF QUEUE CHAIN
          ADN    4*8
          STML   UNITS+/UN/P.QSTRT+1,UX
          SHN    -16
          ADML   IBUF+/UD/P.UQT
          STML   UNITS+/UN/P.QSTRT,UX
          LOADF  IBUF+/UD/P.UQT  REFORMAT RMA ADDRESS OF UNIT QUEUE TABLE
          STML   UNITS+/UN/P.UIT+2,UX
          LDDL   CMADR
          STML   UNITS+/UN/P.UIT,UX
          LDDL   CMADR+1
          STML   UNITS+/UN/P.UIT+1,UX

* READ UNIT INTERFACE TABLE.

          LDN    C.UIT
          STDL   WC
          LDDL   CMADR+2     LOAD ADDRESS OF UNIT INTERFACE TABLE
          LMC    400000B
          CRML   UBUF,WC     READ UNIT INTERFACE TABLE
          LDML   UBUF+/UIT/P.DSABLE  CHECK IF UNIT IS DISABLED
          SHN    2+/UIT/L.DSABLE
          MJK    ICOM85      IF UNIT IS DISABLED

 K46      IFEQ   VALID,1
          RJM    CHKUIT      CHECK FOR VALID UNIT INTERFACE TABLE
 K46      ENDIF

* GET DEVICE TYPE AND TRANSLATE TO INTERNAL DEVICE TYPE.

          LDML   UBUF+/UIT/P.UTYPE  CHECK DEVICE TYPE
          ADC    -406B       CHECK FOR HYDRA
          ZJN    ICOM50      IF  HYDRA
          RJM    HALT        INVALID DEVICE TYPE

 ICOM50   BSS
          LDN    DHYDRA
          ERRNZ  16-/SS/L.DV-/SS/N.DV
          RAML   SS+/SS/P.DV

* GET CHANNEL NUMBER AND MOVE TO SS ENTRY.

          LDML   IBUF+/UD/P.CHAN
          SHN    /UD/L.CHAN+/UD/N.CHAN+2
          LPK    /UD/M.CHAN
          STDL   T1          CHANNEL NUMBER
          LDDL   P4          ADDRESS OF CHANNEL LOCK FLAG
          STDL   T3
          LDDL   CNUML
          ZJN    ICOM66      IF NO ENTRIES IN CHANNEL TABLE
          LDN    0
          STDL   CH
 ICOM62   BSS
          LDML   CHANT,CH    CHECK IF SAME CHANNEL NUMBER
          SBDL   T1
          NJN    ICOM64      IF NOT THE SAME CHANNEL NUMBER
          LDML   CHANT+/CH/P.LOCK,CH  ADDRESS OF CHANNEL LOCK FLAG
          STDL   T3
          LDML   IBUF+/UD/P.PORT  GET PORT NUMBER
          SHN    8
          LPK    /CH/K.PORT
          SBML   CHANT+/CH/P.PORT,CH
          ZJN    ICOM68      IF ALREADY AN ENTRY FOR THE CHANNEL
 ICOM64   BSS
          LDN    P.CH
          RADL   CH
          SBDL   CNUML
          MJK    ICOM62      IF NOT END OF TABLE
 ICOM66   BSS
          LDDL   CNUML
          STDL   CH
          LDDL   T1          CHANNEL NUMBER
          STML   CHANT+/CH/P.CHAN,CH
          LDML   IBUF+/UD/P.PORT
          SHN    8
          LPK    /CH/K.PORT  PORT
          STML   CHANT+/CH/P.PORT,CH
          LDDL   T3          ADDRESS OF CHANNEL LOCK FLAG
          STML   CHANT+/CH/P.LOCK,CH
          LDN    0
          STML   CHANT+/CH/P.ATTN,CH  ATTENTION BITS
          LDN    1
          STML   CHANT+/CH/P.DOWN,CH  CHANNEL DOWN FLAG WILL BE SET IF ALL UNITS
                             ON A CHANNEL ARE DISABLED
          LDN    P.CH
          RADL   CNUML       END OF CHANNEL TABLE
          AODL   P4          BUMP TO NEXT CHANNEL LOCK FLAG
 ICOM68   BSS
          LDDL   CH          PUT OFFSET OF CHANNEL TABLE IN UNITS TABLE
          SHN    15-/UN/L.CHIX-/UN/N.CHIX+1
          RAML   UNITS+/UN/P.CHIX,UX

* IF UNIT IS NOT DISABLED, CLEAR CHANNEL DOWN FLAG.

          LDML   UBUF+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2  CHECK UNIT DISABLE FLAG                                                                          C
          MJN    ICOM69      IF UNIT IS DISABLED
          LDN    0
          STML   CHANT+/CH/P.DOWN,CH  CLEAR CHANNEL DOWN FLAG

* PUT PHYSICAL UNIT NUMBER IN SEEK FUNCTION.

 ICOM69   BSS
          LDML   IBUF+/UD/P.UNIT
          ERRNZ  /UD/L.UNIT
          ERRNZ  /UD/N.UNIT-16
          LPN    7
          STML   RS+/RS/P.UNIT
          LPK    /UN/K.UNIT
          RAML   UNITS+/UN/P.UNIT,UX
          LDML   IBUF+/UD/P.CNTRLR
          LPN    77B
          SHN    3
          RAML   RS+/RS/P.UNIT
          LPK    /UN/K.CM
          RAML   UNITS+/UN/P.CM,UX
          LDML   IBUF+/UD/P.LU  PUT LOGICAL UNIT IN RESPONSE BUFFER
          STML   RS+/RS/P.LU
          STML   UNITS+/UN/P.LUN,UX
          LDML   CHANT,CH    CHANNEL NUMBER
          STML   RS+/RS/P.CHAN
          LDML   CHANT+/CH/P.PORT,CH  PORT B IF SET
          SHN    /CH/L.PORT-/RS/L.PORT
          RAML   RS+/RS/P.PORT

* REFORMAT COMMUNICATION BUFFER RMA.

          LOADF  UBUF+/UIT/P.UBUF  COMMUNICATION BUFFER RMA
          STML   UNITS+/UN/P.CB+2,UX
          LDDL   CMADR
          STML   UNITS+/UN/P.CB,UX
          LDDL   CMADR+1
          STML   UNITS+/UN/P.CB+1,UX

* CHECK THAT COMMUNICATION BUFFER IS LONG ENOUGH.

          LDML   UBUF+/UIT/P.UBUFL  NUMBER OF 8-BIT BYTES IN COMMUNICATION BUFFER
          SHN    -3          NUMBER OF CM WORDS
          ADC    -C.SS       MUST BE LARGER THAN SS ENTRY
          PJN    ICOM70      IF COMMUNICATION BUFFER IS LARGE ENOUGH
                             ERROR - COMMUNICATION BUFFER TOO SMALL
          LDC    E308
          RJM    INTERR      SEND ERROR TO CM
*         (NO RETURN FROM INTERR)


* SAVE SS ENTRY IN COMMUNICATION BUFFER.

 ICOM70   BSS
          LDK    /SS/K.INIT  SET SS ENTRY INITIALIZED FLAG
          RAML   SS+/SS/P.INIT

          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    ICOM80      IF LOCK COULD NOT BE SET
          LDN    1
          STML   UNITS+/UN/P.LOCK,UX  SET UNIT LOCK FLAG

          LOADR  UNITS+/UN/P.CB,UX  LOAD ADDRESS OF COMMUNICATION BUFFER
          CRDL   T2          READ SS ENTRY
          LDDL   T2
          SHN    /SS/L.INIT+2
          PJN    ICOM75      IF SS ENTRY HAS NOT BEEN INITIALIZED
          RJM    GETSS       GET SS ENTRY

 ICOM75   BSS
          RJM    CLRLOCK     CLEAR UNIT LOCK

* BUMP TO NEXT ENTRY.

 ICOM80   BSS
          AODL   P5          NUMBER OF CONFIGURED UNITS
          LDN    P.UN
          RADL   UX          BUMP CONFIGURED UNIT ENTRY
 ICOM85   BSS
          LDN    C.UD
          RADL   P6          BUMP TO NEXT UNIT DESCRIPTOR ENTRY
          SBML   UDL         CHECK FOR END OF UNIT DESCRIPTORS
          NJK    ICOM10      IF MORE UNIT DESCRIPTORS
          LDDL   UX
          STDL   UNUML       END OF ACTIVE UNIT TABLE
          LDN    0
          STDL   UX          INITIALIZE INDEX
          UJK    ICOMX       EXIT
          EJECT
* CHECK FOR VALID UNIT DESCRIPTOR.
          SPACE  6
 D5       IFEQ   VALID,1
 CHKUX    LJM    **
 CHKUD    EQU    *-1
          LDML   IBUF+/UD/P.CHAN  CHANNEL NUMBER
          SHN    /UD/L.CHAN+/UD/N.CHAN+2
          LPN    /SS/M.CHAN
          SBN    14B         VALID CHANNELS ARE 0 - 13B AND 20B - 33B
          MJN    CHKU30      CHANNEL OK
          SBN    20B-14B
          PJN    CHKU25
 CHKU20   BSS
          LDC    E20A        INVALID CHANNEL NUMBER
          UJN    CHKU100

 CHKU25   BSS
          SBN    34B-20B
          PJN    CHKU20

 CHKU30   BSS
          LDML   IBUF+/UD/P.UQT+1  UNIT INTERFACE TABLE ADDRESS
          LPN    7
          ZJK    CHKUX
          LDC    E209        UNIT INTERFACE TABLE NOT A WORD BOUNDARY

 CHKU100  BSS
          RJM    INTERR      SEND ERROR TO CM
*         (NO RETURN FROM INTERR)

 D5       ENDIF
          EJECT
* CHECK FOR VALID UNIT INTERFACE TABLE.
          SPACE  6
 W11      IFEQ   VALID,1
 CUTX     LJM    **
 CHKUIT   EQU    *-1
          LDN    0
          STDL   T1
          LDML   UBUF+/UIT/P.LU  LOGICAL UNIT NUMBER
          SBML   IBUF+/UD/P.LU
          NJN    CUT25       LOGICAL UNIT NUMBER MISMATCH

          AODL   T1
          LDML   UBUF+/UIT/P.UTYPE  UNIT TYPE
          ADC    -403B       VALID UNIT TYPE = 403B - 404B
          MJN    CUT100      INVALID UNIT TYPE

          SBN    404B-403B+1
          PJN    CUT100
*
          AODL   T1
          LDML   UBUF+/UIT/P.UBUFL  UNIT COMMUNICATION BUFFER LENGTH
          LPN    7
          ZJN    CUT30
 CUT25    UJN    CUT100

 CUT30    BSS
          AODL   T1
          LDML   UBUF+/UIT/P.UBUF+1  UNIT COMMUNICATION BUFFER
          LPN    7
          NJN    CUT100      NOT A WORD BOUNDARY

          AODL   T1
          LDML   UBUF+/UIT/P.NEXTPV-1  RESERVED FIELD OF UNIT
                             REQUEST QUEUE DESCRIPTOR
          ADML   UBUF+/UIT/P.NEXT-2
          ADML   UBUF+/UIT/P.NEXT-1
          ZJK    CUTX

 CUT100   BSS
          LDML   CUT110,T1   INTERFACE ERROR CODE
          RJM    INTERR      SEND ERROR TO CM
*         (NO RETURN FROM INTERR)

 CUT110   BSS
          CON    E301        LOGICAL UNIT NUMBER MISMATCH
          CON    E306        INVALID UNIT TYPE
          CON    E307        UNIT COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS
          CON    E302        UNIT COMMUNICATION BUFFER NOT A WORD BOUNDARY
          CON    E305        RESERVED FIELD OF UNIT REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 W11      ENDIF
          EJECT
* INTERFACE ERROR.
          SPACE  6
 INTERR   CON    0
 M22      IFNE   CMSE,1
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LDN    0           UNSOLICITED MESSAGE
          STDL   RESPC       RESPONSE CODE
          LDK    /RS/K.INTERR  INTERFACE ERROR
          STML   RS+/RS/P.INTERR  ABNORMAL STATUS CODE
          RJM    TERMP       SEND RESPONSE TO CM
 M22      ENDIF
          RJM    HALT
          EJECT
 T11      IFNE   HARDW,1
 CHG2X    LJM    **
 CHGCH2   EQU    *-1
          RJM    CHGCH
          LDN    0
          STDL   T1
 CHG210   LDML   CONCH2,T1
          ZJN    CHG2X
          STDL   T2
          LDIL   T2
          SCN    37B
          LMDL   CHAN
          STIL   T2
          AODL   T1
          UJK    CHG210
          EJECT
 CONCH2   BSS
 TDC+40B  HERE
 T40B+DC  HERE
 TDC      HERE
          CON    0
 T11      ENDIF
          EJECT
 M23      IFNE   CMSE,1
 ENDMEM   EQU    17775B      END OF MEMORY
 M23      ELSE
 ENDMEM   EQU    17374B      END OF MEMORY FOR CMSE
 M23      ENDIF

 NRQ      BSS                NEXT REQUEST ON QUEUE
 NRQL     EQU    4
 R3       ERRPL  *+NRQL-ENDMEM    IF .GT. 0, OVERLAY IS TOO LONG
          EJECT
 CODELN   EQU    BUFF-CODE   LENGTH OF PERMANENT CODE TO BE MOVED
 OVRORG   EQU    BUFFERS+CODELN  ORG FOR OVERLAY (AFTER ASSEMBLY)
 K47      IFLE   BUFF,*
 OVRLN    EQU    *-BUFF      OVERLAY LENGTH
          ELSE
 OVRLN    EQU    0
 K47      ENDIF
 OVRNDO   EQU    *O          ORG END OF OVERLAY
 OVREND   BSS                LOC END OF OVERLAY (EXECUTION END)
                             BUFF = BEGINNING EXECUTION LOCATION OF OVERLAY
 OVRLN1   EQU    OVRLN+3
 OVRLNC   EQU    OVRLN1/4    OVERLAY LENGTH IN CM WORDS
          ERRPL  OVRLNC-C.CB+/CB/C.OVR  CHECK IF ENOUGH ROOM IN COMMUNICATION
                             BUFFER FOR OVERLAY
          EJECT
 INI      EQU    BUFF

 IPIT     EQU    INI         PP INTERFACE TABLE
 IPITN    EQU    IPIT+P.PIT

          ERRPL  OVRNDO-IPITN  IF > 0, INCREASE INI LOCATION
                             NUMBER OF LOCATIONS LEFT IN RESIDENT + OVERLAY

          ORG    IPITN
          EJECT
** NAME-- INIT
*
** PURPOSE-- INITIALIZE THE DRIVER AFTER DEADSTART.
*
** INPUT-- DSRTP = CM BYTE-ADDRESS OF THE PP INTERFACE TABLE.
          SPACE  6
 INIT1    BSS


 INIT     BSS

          REFAD  DSRTP,CM.PIT   REFORMAT ADDRESS OF PP INTERFACE TABLE
                               AND SAVE.


* REFORMAT ADDRESS OF COMMUNICATION BUFFER.
* INITIALIZE CM.CB.

          LOADC  CM.PIT      ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.CBUF  OFFSET OF PP COMMUNICATION BUFFER ADDRESS
          CRDL   P1          READ ADDRESS OF PP COMMUNICATION BUFFER
          LDDL   P3          SAVE 2-WORD ADDRESS OF COMMUNICATION BUFFER
          STML   CM.CBU
          LDDL   P4
          STML   CM.CBU+1
          REFAD  P3,CM.CB    REFORMAT CM ADDRESS OF PP COMMUNICATION BUFFER
          LDDL   P2          GET LENGTH OF PP COMMUNICATION BUFFER
          SHN    -3
          ADC    -C.CB
          MJN    *           IF NOT ENOUGH ROOM IN COMMUNICATION BUFFER, TEMPORARY HALT

* WRITE OVERLAY TO PP COMMUNICATION BUFFER.

          LDN    OVRLNC     LENGTH OF OVERLAY
          ZJN    INIT60
          STDL   WC
          LDDL   CMADR+2     CM ADDRESS OF COMMUNICATION BUFFER
          LMC    400000B
          ADK    /CB/C.OVR   OFFSET OF OVERLAY
          CWML   OVRORG,WC   WRITE OVERLAY TO COMMUNICATION BUFFER

* MOVE 'CODELN' WORDS FROM BUFFERS TO CODE.

 INIT60   BSS
          ERRPL  CODE+CODELN-*

          LDK    CODELN      LENGTH OF CODE TO BE MOVED
          ZJN    INIT97
          STDL   T1
 INIT94   BSS
          LDML   BUFFERS-1,T1  MOVE CODE TO PROPER EXECUTION PLACE
          STML   CODE-1,T1
          SODL   T1
          NJN    INIT94      IF MORE CODE TO MOVE

* ZERO OUT BUFFERS.

          LDK    BUFFERL     LENGTH OF BUFFERS
          STDL   T1
 INIT96   BSS
          LDN    0
          STML   BUFFERS-1,T1  ZERO OUT BUFFERS
          SODL   T1
          NJN    INIT96

* NOTE, DO NOT USE BUFFERS BEFORE THIS POINT, UNLESS THE PP IS
* HALTED AFTERWARD.

 INIT97   BSS
          LDK    P.RS        ZERO OUT FULL RESPONSE BUFFER
          STDL   T1
 INIT98   BSS
          LDN    0
          STML   RS-1,T1     ZERO OUT RESPONSE BUFFER
          SODL   T1
          NJN    INIT98

* PUT ZEROES IN THE ZERO BUFFER.

          LDK    C.RS-/RS/C.FTRK
          STDL   WC
          LDDL   CMADR+2     CM ADDRESS OF COMMUNICATION BUFFER
          LMC    400000B
          ADK    /CB/C.ZERO
          CWML   RS+/RS/P.FTRK,WC  STORE ZEROES

          RJM    ZRESP       ZERO OUT RESPONSE BUFFER

* READ PP_INTERFACE_TABLE.

          LDN    C.PIT
          STDL   WC
          LOADC  CM.PIT      LOAD CM ADDRESS OF PP INTERFACE TABLE
          CRML   IPIT,WC     READ PP INTERFACE TABLE
 K48      IFEQ   VALID,1
          RJM    CHKRS       CHECK FOR VALIDITY OF PP RESPONSE BUFFER
 K48      ENDIF
          LDML   IPIT+/PIT/P.PPNO  GET PP NUMBER
          STDL   PPNO

* INITIALIZE UDL, LUDL.

          LDML   IPIT+/PIT/P.UNITC  NUMBER OF UNIT DESCRIPTORS
          SHN    1
          STML   UDL         LENGTH OF UNIT DESCRIPTORS (CM WORDS)

* REFORMAT ADDRESS OF RESPONSE BUFFER.
* INITIALIZE CM.RS, LIM.

          REFAD  IPIT+/PIT/P.RSBUF,CM.RS  REFORMAT CM ADDRESS OF RESPONSE
                             BUFFER
          LDML   IPIT+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STDL   LIM
 K49      IFEQ   VALID,1
          RJM    CHKPIT      CHECK FOR VALIDITY OF PP INTERFACE TABLE
 K49      ENDIF

* REFORMAT ADDRESS OF INTERRUPT WORD.

          REFAD  IPIT+/PIT/P.INT,CM.INT  REFORMAT CM ADDRESS OF
                             INTERRUPT WORD

* REFORMAT ADDRESS OF CHANNEL TABLE.

          REFAD  IPIT+/PIT/P.CHAN,CM.CHAN  REFORMAT CM ADDRESS OF
                             CHANNEL TABLE

          LJM    DISK
          EJECT
 SAVAX    LJM    **
 SAVAD    EQU    *-1
          STML   2,T2
          LDDL   CMADR
          STI    T2
          LDDL   CMADR+1
          STML   1,T2
          UJK    SAVAX
          EJECT
* CHECK FOR VALID PP RESPONSE BUFFER.
          SPACE  6
 D1       IFEQ   VALID,1
 CHKRX    LJM    **
 CHKRS    EQU    *-1
          LDML   IPIT+/PIT/P.RSBUF-2  RESERVED WORD OF RESPONSE
                             BUFFER DESCRIPTOR
          ADML   IPIT+/PIT/P.RSBUF-1
          ADML   IPIT+/PIT/P.RSPVA-1
          NJN    CHKR100     IF RESERVED FIELD NOT XERO

          LDML   IPIT+/PIT/P.IN-3  RESERVED FIELD OF IN POINTER
          ADML   IPIT+/PIT/P.IN-2
          ADML   IPIT+/PIT/P.IN-1
          NJN    CHKR100     IF RESERVED FIELD NOT ZERO

          LDML   IPIT+/PIT/P.OUT-3  RESERVED FIELD OF OUT POINTER
          ADML   IPIT+/PIT/P.OUT-2
          ADML   IPIT+/PIT/P.OUT-1
          NJN    CHKR100     IF RESERVED FIELD NOT ZERO

          LDML   IPIT+/PIT/P.LIMIT-2
          ADML   IPIT+/PIT/P.LIMIT-1
          ZJK    CHKRX

 CHKR100  BSS
          RJM    HALT        INVALID RESPONSE BUFFER
 D1       ENDIF
          EJECT
* CHECK FOR VALID PP-INTERFACE-TABLE.
          SPACE  6
 D2       IFEQ   VALID,1
 CHKPX    LJM    **
 CHKPIT   EQU    *-1
          LDN    0
          STDL   T1
          LDML   IPIT+/PIT/P.CBUFL  COMMUNICATION BUFFER LENGTH
          LPN    7
          NJN    CHKP100     IF LENGTH NOT A MULTIPLE OF WORDS

          AODL   T1
          LDML   IPIT+/PIT/P.CBUFL-1  RESERVED WORD OF PP COMMUNICATION
                             BUFFER DESCRIPTOR
          NJN    CHKP100     IF RESERVED WORD NOT ZERO

          AODL   T1
          LDML   IPIT+/PIT/P.CBUF+1  COMMUNICATION BUFFER (RMA)
          LPN    7
          NJN    CHKP100     IF PP COMMUNICATION BUFFER NOT A WORD BOUNDARY

          AODL   T1
          LDML   IPIT+/PIT/P.PPQPVA-1  RESERVED FIELD OF PP REQUEST
                             QUEUE DESCRIPTOR
          ADML   IPIT+/PIT/P.PPQ-1
          NJN    CHKP100     IF RESERVED FIELD NOT ZERO

          AODL   T1
          LDML   IPIT+/PIT/P.INT+1  INTERRUPT WORD (RMA)
          LPN    7
          NJN    CHKP100     IF INTERRUPT WORD NOT A WORD BOUNDARY
          AODL   T1
          LDML   IPIT+/PIT/P.CHAN+1  CHANNEL TABLE (RMA)
          LPN    7
          ZJK    CHKPX

 CHKP100  BSS
          LDML   CHKP110,T1  INTERFACE ERROR CODE
          RJM    INTERR2     SEND ERROR TO CM
*         (NO RETURN FROM INTERR)

 CHKP110  BSS
          CON    E20B        COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS
          CON    E204        RESERVED WORD OF PP COMMUNICATION
                             BUFFER DESCRIPTOR NOT ZERO
          CON    E203        PP COMMUNICATION BUFFER NOT A WORD BOUNDARY
          CON    E205        RESERVED FIELD OF PP REQUEST QUEUE
                             DESCRIPTOR NOT ZERO
          CON    E211        RMA OF INTERRUPT WORD NOT A WORD BOUNDARY
          CON    E212        RMA OF CHANNEL TABLE NOT A WORD BOUNDARY
          EJECT
* INTERFACE ERROR.
          SPACE  6
 INTERR2  CON    0
 M24      IFNE   CMSE,1
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LDN    0           UNSOLICITED MESSAGE
          STDL   RESPC       RESPONSE CODE
          LDK    /RS/K.INTERR  INTERFACE ERROR
          STML   RS+/RS/P.INTERR  ABNORMAL STATUS CODE
          RJM    TERMP       SEND RESPONSE TO CM
 M24      ENDIF
          RJM    HALT
 D2       ENDIF
          EJECT
 R2       ERRPL  *-ENDMEM-1  IF > 0, DECREASE INI.  OR ELSE INIT
                             IS TOO LONG
                             NUMBER OF LOCATIONS LEFT IN INIT.
          EJECT
          END    HYD
/EOR
*DECK DECK=I#BUILD_ADAPTABLE_ARRAY_PTR EXPAND=FALSE

  PROCEDURE [XREF] i#build_adaptable_array_ptr (ring: 0 .. 15;
        segment: 0 .. 4095;
        offset: -80000000(16) .. 7fffffff(16);
        array_size: 1 .. 80000000(16);
        lower_bound: -80000000(16) .. 7fffffff(16);
        element_size: 1 .. 80000000(16);
        array_p: ^^cell);
*DECK DECK=I#BUILD_ADAPTABLE_HEAP_POINTER EXPAND=FALSE
  PROCEDURE [XREF] i#build_adaptable_heap_pointer (ring: 0 .. 15;
        segment: 0 .. 4095;
        offset: -80000000(16) .. 7fffffff(16);
        heap_length: 0 .. 7fffffff(16);
    VAR heap_p: ^HEAP ( * ));

*DECK DECK=I#BUILD_ADAPTABLE_SEQ_POINTER EXPAND=FALSE
  PROCEDURE [XREF] i#build_adaptable_seq_pointer (ring: 0 .. 15;
        segment: 0 .. 4095;
        offset: -80000000(16) .. 7fffffff(16);
        sequence_length: 0 .. 80000000(16);
          next_entry: 0 .. 7fffffff(16);
    VAR seq_p: ^SEQ ( * ));

*DECK DECK=I#CALL_MONITOR EXPAND=FALSE

  PROCEDURE [XREF] i#call_monitor (reqblk_p: ^cell;
        reqblk_length: 8 .. 120);
*DECK DECK=I#COMPARE EXPAND=FALSE

  FUNCTION [XREF] i#compare (p1: string ( * );
        p2: string ( * )): - 1 .. 1;
*DECK DECK=I#COMPARE_COLLATED EXPAND=FALSE

  FUNCTION [XREF] i#compare_collated (p1: string (* <= 256);
        p2: string (* <= 256);
        table: string (256)): - 1 .. 1;
*DECK DECK=I#CURRENT_SEQUENCE_POSITION EXPAND=FALSE

  FUNCTION [INLINE] i#current_sequence_position
    (    sequence_pointer: ^SEQ ( * )): integer;

?? PUSH (LISTEXT := ON) ??

    VAR
      converter: record
        case 1 .. 2 of
        = 1 =
          pointer: ^SEQ ( * ),
        = 2 =
          breakdown: cyt$sequence_pointer,
        casend,
      recend;


    converter.pointer := sequence_pointer;
    i#current_sequence_position := converter.breakdown.nextt;

  FUNCEND i#current_sequence_position;

*copyc cyd$cybil_structure_definitions
?? POP ??
*DECK DECK=I#DISABLE_TRAPS EXPAND=FALSE

  PROCEDURE [INLINE] i#disable_traps (VAR old_te: 0 .. 3);
?? PUSH (LISTEXT := ON) ??

{  The purpose of this procedure is determine the current value
{  of the traps enabled flag, disable traps and return the previous
{  value of the flag.
{
{    I#DISABLE_TRAPS (OLD_TE);
{
{  OLD_TE: (output) Value of the traps enabled flag at the time this
{                   procedure was invoked.
{
{  NOTE - This procedure assumes the caller has 'local privilege'.
{

    old_te := #read_register (0c0(16));
    #write_register (0c0(16), 0c0(16));
  PROCEND i#disable_traps;
?? POP ??
*DECK DECK=I#ENABLE_TRAPS EXPAND=FALSE

  PROCEDURE [INLINE] i#enable_traps (VAR old_te: 0 .. 3);
?? PUSH (LISTEXT := ON) ??

{  This procedure reads the current value of the traps enabled
{  register, enables traps and returns the previous value of the
{  traps enabled register.
{
{    I#ENABLE_TRAPS (OLD_TE);
{
{  OLD_TE: (output) Value of the traps enabled flag at the time the
{                   procedure was invoked.
{
{  NOTE - This procedure assumes that the caller has 'local provilege' mode.
{

    old_te := #read_register (0c0(16));
    #write_register (0c2(16), 0c2(16));
  PROCEND i#enable_traps;
?? POP ??
*DECK DECK=I#MOVE EXPAND=FALSE

  PROCEDURE [INLINE] i#move (source: ^cell;
        dest: ^cell;
        length: 0 .. 7fffffff(16));

    VAR
      str1: ^string (65535),
      str2: ^string (65535);

?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??
    IF length <> 0 THEN
      str1 := source;
      str2 := dest;
      str2^ (1, length) := str1^ (1, length);
      #SPOIL (str2^);
    IFEND;
?? POP ??
  PROCEND i#move;
*DECK DECK=I#MTR_DISABLE_TRAPS EXPAND=FALSE

  PROCEDURE [INLINE] i#mtr_disable_traps (VAR old_te: 0 .. 3);
?? PUSH (LISTEXT := ON) ??

{  The purpose of this procedure is determine the current value
{  of the traps enabled flag, disable traps and return the previous
{  value of the flag.
{
{    I#MTR_DISABLE_TRAPS (OLD_TE);
{
{  OLD_TE: (output) Value of the traps enabled flag at the time this
{                   procedure was invoked.
{
{  NOTE - This procedure assumes the caller has 'monitor privilege';
{  this inline can only be used successfully in MONITOR mode.
{

    TYPE
      monitor_mask = RECORD
        CASE boolean OF
        = FALSE =
          mask: mtt$monitor_conditions,
        = TRUE =
          int: 0 .. 0ffff(16),
        CASEND,
      RECEND;

    VAR
      local_monitor_mask: monitor_mask;

    old_te := #read_register (0c0(16));
    local_monitor_mask.int := #read_register (osc$pr_monitor_mask_reg);
    local_monitor_mask.mask := local_monitor_mask.mask - $mtt$monitor_conditions [mtc$mcr_trap_enable_flag];
    #write_register (0c0(16), 0c0(16));
    #write_register (osc$pr_monitor_mask_reg, local_monitor_mask.int);

  PROCEND i#mtr_disable_traps;
*copyc osc$processor_defined_registers
*copyc mtt$monitor_conditions
?? POP ??
*DECK DECK=I#MTR_ENABLE_TRAPS EXPAND=FALSE

  PROCEDURE [INLINE] i#mtr_enable_traps (VAR old_te: 0 .. 3);
?? PUSH (LISTEXT := ON) ??

{  This procedure reads the current value of the traps enabled
{  register, enables traps and returns the previous value of the
{  traps enabled register.
{
{    I#MTR_ENABLE_TRAPS (OLD_TE);
{
{  OLD_TE: (output) Value of the traps enabled flag at the time the
{                   procedure was invoked.
{
{  NOTE - This procedure assumes the caller has 'monitor privilege';
{  this inline can only be used successfully in MONITOR mode.
{

    TYPE
      monitor_mask = RECORD
        CASE boolean OF
        = FALSE =
          mask: mtt$monitor_conditions,
        = TRUE =
          int: 0 .. 0ffff(16),
        CASEND,
      RECEND;

    VAR
      local_monitor_mask: monitor_mask;

    old_te := #read_register (0c0(16));
    local_monitor_mask.int := #read_register (osc$pr_monitor_mask_reg);
    local_monitor_mask.mask := local_monitor_mask.mask + $mtt$monitor_conditions [mtc$mcr_trap_enable_flag];
    #write_register (osc$pr_monitor_mask_reg, local_monitor_mask.int);
    #write_register (0c2(16), 0c2(16));

  PROCEND i#mtr_enable_traps;
*copyc mtt$monitor_conditions
*copyc osc$processor_defined_registers
?? POP ??
*DECK DECK=I#MTR_RESTORE_TRAPS EXPAND=FALSE

  PROCEDURE [INLINE] i#mtr_restore_traps (old_te: 0 .. 3);
?? PUSH (LISTEXT := ON) ??

{  The purpose of this procedure is to restore the trap enable flag
{  to the value specified by 'old_te'.
{
{    I#MTR_RESTORE_TRAPS (OLD_TE)
{
{  OLD_TE: (input) Value of trap enabled flag to be restored.
{
{  NOTE - This procedure assumes the caller has 'monitor privilege';
{  this inline can only be used successfully in MONITOR mode.
{

    TYPE
      monitor_mask = RECORD
        CASE boolean OF
        = FALSE =
          mask: mtt$monitor_conditions,
        = TRUE =
          int: 0 .. 0ffff(16),
        CASEND,
      RECEND;

    VAR
      local_monitor_mask: monitor_mask;

    local_monitor_mask.int := #read_register (osc$pr_monitor_mask_reg);
    IF old_te = 0 THEN
      local_monitor_mask.mask := local_monitor_mask.mask - $mtt$monitor_conditions [mtc$mcr_trap_enable_flag];
    ELSE
      local_monitor_mask.mask := local_monitor_mask.mask + $mtt$monitor_conditions [mtc$mcr_trap_enable_flag];
    IFEND;
    #write_register (osc$pr_monitor_mask_reg, local_monitor_mask.int);
    #write_register (0c0(16), old_te);

  PROCEND i#mtr_restore_traps;
*copyc mtt$monitor_conditions
*copyc osc$processor_defined_registers
?? POP ??
*DECK DECK=I#PROGRAM_ERROR EXPAND=FALSE

  PROCEDURE [XREF] i#program_error;
*DECK DECK=I#PTR EXPAND=FALSE

  FUNCTION [XREF] i#ptr (disp: integer;
        base_ptr: ^cell): ^cell;
*DECK DECK=I#REAL_MEMORY_ADDRESS EXPAND=FALSE

  PROCEDURE [XREF] i#real_memory_address (p: ^cell;
    VAR rma: integer);
*DECK DECK=I#REL EXPAND=FALSE

  FUNCTION [XREF] i#rel (ptr: ^cell;
        base_ptr: ^cell): integer;
*DECK DECK=I#RESTORE_TRAPS EXPAND=FALSE

  PROCEDURE [INLINE] i#restore_traps (old_te: 0 .. 3);
?? PUSH (LISTEXT := ON) ??

{  The purpose of this procedure is to restore the trap enable flag
{  to the value specified by 'old_te'.
{
{    I#RESTORE_TRAPS (OLD_TE)
{
{  OLD_TE: (input) Value of trap enabled flag to be restored.
{
{  NOTE - This procedure assumes the caller has 'local privilege' mode.
{

  #write_register (0c0(16), old_te);
  PROCEND i#restore_traps;
?? POP ??
*DECK DECK=I#SYNC EXPAND=FALSE

  PROCEDURE [XREF] i#sync;

*DECK DECK=I#TEST_ALTER_CONDITION_REG EXPAND=FALSE

  PROCEDURE [XREF] i#test_alter_condition_reg (selopt: 0 .. 15;
        bitnum: 0 .. 15;
    VAR branch_exit: boolean);
*DECK DECK=I#TEST_SET_BIT EXPAND=FALSE

  PROCEDURE [XREF] i#test_set_bit (p: ^cell;
        disp: integer;
    VAR previous_value: boolean);
*DECK DECK=I$REAL_MEMORY_ADDRESS EXPAND=FALSE

  PROCEDURE [XREF] i#real_memory_address (p: ^cell;
    VAR rma: integer);
*DECK DECK=ICA$ICAMMLI EXPAND=TRUE
          IDENT  ICAMMLI
          TITLE  ICA$ICAMMLI - SYMPL INTERFACE TO MEMORY LINK
          ENTRY  MLIPAR
          ENTRY  MLIQ
          ENTRY  PAUSE

          LIST   F
          SYSCOM B1
          IF     -DEF,RA.ORG,1
OPL XTEXT COMCMAC
          LIST   X
*copy COMSMLI
*copy COMSCVS
*copy COMMCVS
*copy MLA$C170_MEMORY_LINK_INTERFACE

MLIQ      BSS    1
          SB1    1
          RJ     MLI=
          EQ     MLIQ

PAUSE     BSS    1
          SA1    X1
          SX0    X1
          EQ     PAUSE2
PAUSE1    BSS    0
          RECALL
PAUSE2    SX0    X0-1
          PL     X0,PAUSE1
          EQ     PAUSE

          END
*DECK DECK=ICD$FILE_ROUTE_DECLARATIONS EXPAND=FALSE

?? PUSH (LISTEXT := ON) ??
?? POP ??

  CONST
*IF ($string($name(wev$target_operating_system))='NOS')
    in_disposition_code = 001110001111(2),
    local_batch_origin_type = 1,
    null_equipment_code_77 = 63,
    input_flags = 512;
*ELSE
    in_disposition_code = 001001001110(2),
    nosbe_priority = 111111111111(2),
    input_flags = 1100000000(2); {dont catalog input and 7_char job name spec.
*IFEND

  TYPE
    ict$route_parameter_block = packed record
      lfn: ict$nos_file_name,
      ec: 0 .. 3f(16),
      f: boolean,
      filler1: 0 .. 0f(16),
      ot: 0 .. 3f(16),
      c: boolean,
      zero: 0 .. 0fff(16),
      forms: 0 .. 0fff(16),
      disp: 0 .. 0fff(16),
      ex: 0 .. 7,
      s: boolean,
      ic: 0 .. 3,
      flags: ict$route_flags,
      reserved1: 0 .. 0fffffffff(16),
      tid: - 7fffff(16) .. 7fffff(16),
      reserved2: 0 .. 7fffffffffff(16),
      b: boolean,
      priority: 0 .. 0fff(16),
      spacing: 0 .. 0fff(16),
      svc: 0 .. 3fffffff(16),
      filler3: 0 .. 1,
      rc: 0 .. 1f(16),
      reserved4: 0 .. 0fff(16),
      reserved5: integer,
      reserved6: integer,
      reserved7:integer,
    recend,

    ict$route_flags = packed record
      return_system_file_name: boolean,
      reserved1: 0 .. 1,
      pfc_580_spacing_code: boolean,
      repeat_count: boolean,
      reserved2: 0 .. 1,
      return_error_code: boolean,
      reserved3: 0 .. 1,
      forms_code: boolean,
      priority: boolean,
      internal_characteristics: boolean,
      external_characteristics: boolean,
      reserved4: 0 .. 1,
      file_ident_specified: boolean,
      disposition_code: boolean,
      reserved5: boolean,
      tid: boolean,
      route_to_central_site: boolean,
      end_of_job: boolean,
    recend,

    ict$nos_file_name = 0 .. 3ffffffffff(16),

    ict$nos_fet_lfn_word = packed record
      lfn: ict$nos_file_name,
      code_and_status: 0 .. 3ffff(16),
    recend;
*DECK DECK=ICD$QUEUE_ACCESS_DECLARATIONS EXPAND=FALSE

?? PUSH (LISTEXT := ON) ??
?? POP ??

*IF ($string($name(wev$target_operating_system))='NOS')
  CONST
    peek_request_length = 11,
    qac_peek_function_code = 3;

  TYPE
    ict$qac_parameter_block = packed record
      fill0a: 0..3ffffffffff(16),
      err: 0..0ff(16),
      fcn: 0..1ff(16),
      complete_bit: boolean,
      fill1a: 0 .. 3ffffffff(16),
      request_block_length: 0 .. 0ff(16),
      first: ^cell,
      fill2a: 0 .. 3ffffffffff(16),
      inn: ^cell,
      fill3a: 0 .. 3ffffffffff(16),
      out: ^cell,
      fill4a: 0..0fff(16),
      ordinal: 0..0fff(16),
      queue: 0..0fff(16),
      fill4b: 0..3f(16),
      limit: ^cell,
      fill5: string(5),
      fill6: string(5),
      jsn: 0..0ffffff(16),
      fill7a: 0..1fffffff(16),
      jsn_option: boolean,
      fill7b: 0 .. 3f(16),
      fill8a: 0..3ff(16),
      execution_queue_flag: boolean,
      input_queue_flag: boolean,
      forms: 0 .. 0fff(16),
      disp: 0 .. 0fff(16),
      ec: 0 .. 7,
      ic: 0 .. 7,
      link_addr: 0 .. 3ffff(16),
      fill9: string(5),
      fill10: string(5),
      fill11: string(5),
      incnt: 0..0fff(16),
      excnt: 0..0fff(16),
      fill12a: string(3),
      fill13: ALIGNED string(5),
      fill14: ALIGNED string(5),
      fill15: string(5),
    recend,

    zero_lene_lenb = packed record
      zero: 0 .. 0ffffff(16),
      lene: 0 .. 3ffff(16),
      lenb: 0 .. 3ffff(16),
    recend,

    information_bits = integer,
    peek_reply_entry = array [1 .. 3] of cell;
*ELSE
  CONST
    qaf_job_name_zero_fill = 11011011011011011(2),
    qaf_count_function_code = 3;

  TYPE
    ict$qaf_parameter_block = packed record
      partner_job_name: 0..03ffffffffff(16),
      err: 0..3f(16),
      queue_type: packed record
        reserved0a: 0 .. 7(16),
        execution: boolean,
        special_output: boolean,
        punch: boolean,
        output: boolean,
        input: boolean,
      recend,
      fcn: 0..7(16),
      complete_bit: boolean,
      fill1a0: 0 .. 0fff(16),
      fill1a: 0 .. 0ffffffffffff(16),
      fill2a0: 0 .. 0fff(16),
      fill2a: 0 .. 0ffffffffffff(16),
      fill3a0: 0 .. 0fff(16),
      fill3a: 0 .. 0ffffffffffff(16),
      fill4a: 0 .. 0ffffffffffff(16),
      excnt: 0..0fff(16),
      fill5a: 0 .. 0fff(16),
      incnt: 0..0fff(16),
      fill6a: 0 .. 0fffffffff(16),
    recend;
*IFEND
*DECK DECK=ICE$ERROR_CODES EXPAND=FALSE

?? NEWTITLE := 'ICDECC  : Interstate Communication' ??

  CONST
    icc$min_ecc = (($INTEGER ('I') * 100(16)) + $INTEGER ('C')) * 1000000(16),
    icc$interstate_communication_id = 'IC';

  CONST

    ice$link_is_already_open = icc$min_ecc,
    {E File +F1 : The link to NOS/170 is already open.

    ice$no_job_spec_variable = icc$min_ecc + 5,
    {E File +F1 : User_Info is empty or does not name a defined SCL string
    {variable.

    ice$empty_job_spec_variable = icc$min_ecc + 10,
    {E File +F1 : The SCL string variable +P8 must contain a NOS/170 job deck, but
    {is empty.

    ice$partner_job_too_long = icc$min_ecc + 15,
    {E File +F1 : The control statements for the partner NOS/170 job exceed the
    {allowed length, beginning with statement number +P8.

    ice$partner_cannot_be_started = icc$min_ecc + 20,
    {E File +F1 : The partner NOS/170 job cannot be started by NOS/170.

    ice$access_level_not_record = icc$min_ecc + 25,
    {E File +F1 : The link file must have access_level of RECORD, but it specifies
    {+P3.

    ice$write_deadlock = icc$min_ecc + 30,
    {E File +F1 : This task and its partner NOS/170 job are both attempting PUTs.
    {(+P2 request.)

    ice$partner_ended = icc$min_ecc + 35,
    {E File +F1 : This task's partner NOS/170 job has ended or called CLOSLNK.
    {(+P2 request.)

    ice$read_deadlock = icc$min_ecc + 40,
    {E File +F1 : This task and its partner NOS/170 job are both attempting GETs.
    {(+P2 request.)

    ice$unexpected_ml_error = icc$min_ecc + 45,
    {E The partner NOS/170 job cannot be run due to an unexpected internal
    { system status +P.

    ice$mismatching_code = icc$min_ecc + 50,
    {E The dual state code for the NOS/VE and +P sides do not match.  Contact
    { your site analyst.

    ice$receiver_already_signed_on = icc$min_ecc + 55,
    {E The +P partner job is already signed on to the memory link but by a
    { different application name.  Retry the command or contact your site analyst.

    ice$receiver_not_signed_on = icc$min_ecc + 60,
    {E A problem occurred on the +P side - check your +P validations or
    { your +P file being busy.

    ice$no_partner_exists = icc$min_ecc + 65,
    {E This system is not running NOS or NOS/BE dual state, so the interstate
    {facility is not available.

    icc$first_unused_ecc = icc$min_ecc + 65;

?? OLDTITLE ??
*DECK DECK=ICF$OPEN_FILE_DESCRIPTOR EXPAND=FALSE

  TYPE
    icf_open_file_descriptor = record
      file_id: amt$file_identifier,
      application_name: mlt$application_name,
      partner_id: ict$partner_identification,
      position: amt$file_position,
      last_length: amt$max_record_length,
      record_length: amt$max_record_length,
      last_fap_op: amt$last_access_operation,
      last_status: ost$status_condition,
      opened_for_get: boolean,
      opened_for_put: boolean,
      buff: ^array [mlt$message_length] of 0 .. 0ff(16),
    recend;

  CONST
    icf_short_interval = 1000,
    icf_interval = 10000;

*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FILE_POSITION
*copyc AMD$OPERATION_DECLARATIONS
*copyc AMT$MAX_RECORD_LENGTH
*copyc ICT$PARTNER_MESSAGES
*copyc MLD$MEMORY_LINK_DECLARATIONS
*DECK DECK=ICH$SET_STATUS_ABNORMAL EXPAND=FALSE
{
{    The purpose of this request is to set the error status for certain
{  errors encountered by interstate communications processors.
{
{       ICP$SET_STATUS_ABNORMAL (STATUS)
{
{ STATUS: (input/output) This parameter specifies the error status to be
{       processed.  The status from this procedure replaces this input status.
{
*DECK DECK=ICM$CLOSE EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE icm$close;
?? TITLE := 'MODULE icm$close' ??

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_POSITION
*copyc AMD$OPERATION_DECLARATIONS
*copyc AMT$MAX_BLOCK_LENGTH
*copyc AMT$TERM_OPTION
*copyc AMT$TRANSFER_COUNT
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc ICE$ERROR_CODES
*copyc ICF$OPEN_FILE_DESCRIPTOR
*copyc ICP$DELETE_PARTNER_JOB
*copyc ICP$PUT
*copyc ICP$SET_STATUS_ABNORMAL
*copyc ICP$STATUS_PARTNER_JOB
*copyc IFE$ERROR_CODES
*copyc MLP$CONFIRM_SEND
*copyc MLP$FETCH_LINK_PARTNER_INFO
*copyc MLP$SEND_MESSAGE
*copyc MLP$SIGN_OFF
*copyc OST$STATUS
*copyc OSP$DISESTABLISH_COND_HANDLER
*copyc OSP$ESTABLISH_CONDITION_HANDLER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$CONTINUE_TO_CAUSE
*copyc PMP$EXIT
*copyc PMP$LONG_TERM_WAIT
*copyc PMP$TASK_STATE
*copyc PMP$WAIT
?? POP ??

?? NEWTITLE := 'PROCEDURE icp$close' ??

{  ICP$CLOSE
{
{     The purpose of this procedure is to close the link file. That
{  is, to (1) terminate any partial records that may have been sent,
{  (2) send an eoi if the file has been open for sending, (3) wait
{  for the partner job to receive the eoi, (4) sign off from the
{  memory link, and (5) force the partner's sign off.

  PROCEDURE [XDCL] icp$close
    (    icf_file: ^icf_open_file_descriptor;
         operation: amt$fap_operation;
     VAR status: ost$status);

    VAR
      ptr: ^cell,
      eoi: boolean,
      eop: boolean,
      first_message: boolean,
      last_message: boolean,
      last_op: mlt$operation,
      arbitrary_info: mlt$arbitrary_info,
      signal_record: mlt$signal_record,
      signal: mlt$signal,
      partner_stat: ict$status_partner_status,
      stat: ost$status;


    PROCEDURE handle_break
      (    cond: pmt$condition;
           condition_info: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR break_status: ost$status);

      VAR
        local_status: ost$status;

      IF (cond.selector = ifc$interactive_condition) THEN
        IF cond.interactive_condition = ifc$pause_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$pause_break_received, '', status);
        ELSEIF cond.interactive_condition = ifc$terminate_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$terminate_break_received, '', status);
        IFEND;
        pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
        EXIT icp$close;
      IFEND;
      break_status.normal := TRUE;
      RETURN;
    PROCEND handle_break;

{ Begin procedure ICP$CLOSE

    status.normal := TRUE;
    osp$establish_condition_handler (^handle_break, FALSE);
    ptr := icf_file;
    IF pmp$task_state () = pmc$task_active THEN
      IF icf_file^.opened_for_put THEN
        IF (icf_file^.last_fap_op = amc$put_partial_req) AND
              (icf_file^.position = amc$mid_record) THEN

{  Terminate prior partial records.

          icp$put (icf_file, amc$put_next_req, ptr, 0, amc$terminate, stat);
          IF NOT stat.normal THEN
            status := stat;
          IFEND;
        IFEND;

{  Send an eoi indication.

        signal := ^signal_record;
        eoi := TRUE;
        eop := FALSE;
        first_message := TRUE;
        last_message := TRUE;
        arbitrary_info := $INTEGER (eoi) * 8 + $INTEGER (eop) *
              4 + $INTEGER (first_message) * 2 + $INTEGER (last_message);

      /loop_1/
        WHILE TRUE DO
          mlp$send_message (icf_file^.application_name, arbitrary_info, signal,
                ptr, 0, icf_file^.partner_id.application_name, stat);
          IF (stat.normal) OR (stat.condition = mlc$ok) OR
                (stat.condition = mlc$signal_failed_ignored) OR
                (stat.condition = mlc$signal_to_c170_ignored) THEN
            EXIT /loop_1/;
          ELSE
            CASE stat.condition OF
            = mlc$busy_interlock, mlc$pool_buffer_not_avail =
              pmp$wait (icf_short_interval, icf_short_interval);
              CYCLE /loop_1/;
            = mlc$receiver_not_signed_on =
              icp$status_partner_job (icf_file^.partner_id, partner_stat,
                    stat);
              IF stat.normal THEN
                IF partner_stat = icc$partner_not_found THEN
                  amp$set_file_instance_abnormal
                        (icf_file^.file_id, ice$partner_ended, operation, '',
                        status);
                  EXIT /loop_1/;
                ELSE
                  pmp$long_term_wait (icf_interval, icf_interval);
                  CYCLE /loop_1/;
                IFEND;
              ELSE
                osp$disestablish_cond_handler;
                pmp$exit (stat);
              IFEND;
            = mlc$prior_msg_not_received, mlc$receive_list_full =

            /flpi_loop_1/
              WHILE TRUE DO
                mlp$fetch_link_partner_info (icf_file^.application_name,
                      icf_file^.partner_id.application_name, last_op, stat);
                IF (stat.normal) OR (stat.condition = mlc$ok) THEN
                  EXIT /flpi_loop_1/;
                ELSE
                  CASE stat.condition OF
                  = mlc$busy_interlock =
                    pmp$wait (icf_short_interval, icf_short_interval);
                    CYCLE /flpi_loop_1/;
                  = mlc$receiver_not_signed_on =
                    icp$status_partner_job (icf_file^.partner_id, partner_stat,
                          stat);
                    IF stat.normal THEN
                      IF partner_stat = icc$partner_not_found THEN
                        amp$set_file_instance_abnormal
                              (icf_file^.file_id, ice$partner_ended, operation,
                              '', status);
                        EXIT /loop_1/;
                      ELSE
                        pmp$long_term_wait (icf_interval, icf_interval);
                        CYCLE /loop_1/;
                      IFEND;
                    ELSE
                      icp$set_status_abnormal (stat);
                      osp$disestablish_cond_handler;
                      pmp$exit (stat);
                    IFEND;
                  ELSE
                    icp$set_status_abnormal (stat);
                    osp$disestablish_cond_handler;
                    pmp$exit (stat);
                  CASEND;
                IFEND;
              WHILEND /flpi_loop_1/;

              IF ((last_op.req = mlc$send_message_req) OR
                    (last_op.req = mlc$confirm_send_req)) AND
                    ((last_op.stat_condition = mlc$prior_msg_not_received) OR
                    (last_op.stat_condition = mlc$receive_list_full)) THEN
                amp$set_file_instance_abnormal (icf_file^.file_id,
                      ice$write_deadlock, operation, '', status);
                EXIT /loop_1/;
              ELSE
                pmp$long_term_wait (icf_interval, icf_interval);
                CYCLE /loop_1/;
              IFEND;
            ELSE
              icp$set_status_abnormal (stat);
              osp$disestablish_cond_handler;
              pmp$exit (stat);
            CASEND;
          IFEND;
        WHILEND /loop_1/;
        icf_file^.position := amc$eoi;

{  Wait for partner to receive last message.

      /loop_2/
        WHILE TRUE DO
          mlp$confirm_send (icf_file^.application_name,
                icf_file^.partner_id.application_name, stat);
          IF (stat.normal) OR (stat.condition = mlc$ok) THEN
            EXIT /loop_2/;
          ELSE
            CASE stat.condition OF
            = mlc$busy_interlock =
              pmp$wait (icf_short_interval, icf_short_interval);
              CYCLE /loop_2/;
            = mlc$receiver_not_signed_on =
              icp$status_partner_job (icf_file^.partner_id, partner_stat,
                    stat);
              IF stat.normal THEN
                IF partner_stat = icc$partner_not_found THEN
                  amp$set_file_instance_abnormal
                        (icf_file^.file_id, ice$partner_ended, operation, '',
                        status);
                  EXIT /loop_2/;
                ELSE
                  pmp$long_term_wait (icf_interval, icf_interval);
                  CYCLE /loop_2/;
                IFEND;
              ELSE
                osp$disestablish_cond_handler;
                pmp$exit (stat);
              IFEND;
            = mlc$prior_msg_not_received, mlc$receive_list_full =

            /flpi_loop_2/
              WHILE TRUE DO
                mlp$fetch_link_partner_info (icf_file^.application_name,
                      icf_file^.partner_id.application_name, last_op, stat);
                IF (stat.normal) OR (stat.condition = mlc$ok) THEN
                  EXIT /flpi_loop_2/;
                ELSE
                  CASE stat.condition OF
                  = mlc$busy_interlock =
                    pmp$wait (icf_short_interval, icf_short_interval);
                    CYCLE /flpi_loop_2/;
                  = mlc$receiver_not_signed_on =
                    icp$status_partner_job (icf_file^.partner_id, partner_stat,
                          stat);
                    IF stat.normal THEN
                      IF partner_stat = icc$partner_not_found THEN
                        amp$set_file_instance_abnormal
                              (icf_file^.file_id, ice$partner_ended, operation,
                              '', status);
                        EXIT /loop_2/;
                      ELSE
                        pmp$long_term_wait (icf_interval, icf_interval);
                        CYCLE /loop_2/;
                      IFEND;
                    ELSE
                      osp$disestablish_cond_handler;
                      pmp$exit (stat);
                    IFEND;
                  ELSE
                    icp$set_status_abnormal (stat);
                    osp$disestablish_cond_handler;
                    pmp$exit (stat);
                  CASEND;
                IFEND;
              WHILEND /flpi_loop_2/;

              IF ((last_op.req = mlc$send_message_req) OR
                    (last_op.req = mlc$confirm_send_req)) AND
                    ((last_op.stat_condition = mlc$prior_msg_not_received) OR
                    (last_op.stat_condition = mlc$receive_list_full)) THEN
                amp$set_file_instance_abnormal (icf_file^.file_id,
                      ice$write_deadlock, operation, '', status);
                EXIT /loop_2/;
              ELSE
                pmp$long_term_wait (icf_interval, icf_interval);
                CYCLE /loop_2/;
              IFEND;
            ELSE
              icp$set_status_abnormal (stat);
              osp$disestablish_cond_handler;
              pmp$exit (stat);
            CASEND;
          IFEND;
        WHILEND /loop_2/;
      IFEND;
    IFEND;

{  Sign off from the memory link.

    mlp$sign_off (icf_file^.application_name, stat);
    IF NOT stat.normal THEN
      CASE stat.condition OF
      = mlc$receiver_not_signed_on, mlc$queued_msgs_lost =
      ELSE
        icp$set_status_abnormal (stat);
        osp$disestablish_cond_handler;
        pmp$exit (stat);
      CASEND;
    IFEND;

{  Force the partner's sign off.

    icp$delete_partner_job (icf_file^.partner_id, stat);

  PROCEND icp$close;
MODEND icm$close;
*DECK DECK=ICM$FAP_CONTROL EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE icm$fap_control;
?? TITLE := ' MODULE icm$fap_control' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMP$ACCESS_METHOD
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc AMT$FAP_POINTER
*copyc AMP$FETCH_FAP_POINTER
*copyc AMP$STORE_FAP_POINTER
*copyc AME$FAP_VALIDATION_ERRORS
*copyc ICE$ERROR_CODES
*copyc ICF$OPEN_FILE_DESCRIPTOR
*copyc ICT$PARTNER_MESSAGES
*copyc ICP$CLOSE
*copyc ICP$FETCH_ACCESS_INFO
*copyc ICP$FLUSH
*copyc ICP$GET
*copyc ICP$OPEN
*copyc ICP$PUT
*copyc ICV$OPEN_FILE_COUNT_LOCK
*copyc ICP$WRITE_END_PARTITION
*copyc OST$STATUS
*copyc OSP$CLEAR_JOB_SIGNATURE_LOCK
*copyc OSP$SET_JOB_SIGNATURE_LOCK
*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSV$TASK_PRIVATE_HEAP
*copyc PMP$GET_170_OS_TYPE
*copyc PMP$EXIT
?? POP ??
?? NEWTITLE := 'PROCEDURE [XDCL, #GATE] icp$fap_control' ??

{  ICP$FAP_CONTROL
{
{     The purpose of this procedure is to do the initial FAP
{  processing of amp$ requests on a link file.  Additional routines
{  are called as necessary to complete the processing.

  PROCEDURE [XDCL, #GATE] icp$fap_control
    (    file_id: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      icf_file: ^icf_open_file_descriptor,
      os_type: ost$170_os_type,
      stat: ost$status;

    stat.normal := TRUE;
    pmp$get_170_os_type (os_type, status);
    IF status.normal THEN
      IF os_type = osc$ot7_none THEN
        osp$set_status_abnormal (icc$interstate_communication_id,
              ice$no_partner_exists, '', status);
        RETURN;
      IFEND;
    IFEND;
    IF call_block.operation = amc$open_req THEN
      ALLOCATE icf_file IN osv$task_private_heap^;
      amp$store_fap_pointer (file_id, layer_number, icf_file, stat);
      IF NOT stat.normal THEN
        pmp$exit (stat);
      IFEND;
      icf_file^.file_id := file_id;
      icp$open (icf_file, call_block.operation, call_block.open.access_level,
            stat);
      IF stat.normal THEN
        amp$access_method (file_id, call_block, layer_number, stat);
      IFEND;
    ELSE
      amp$fetch_fap_pointer (file_id, layer_number, icf_file, stat);
      IF NOT stat.normal THEN
        pmp$exit (stat);
      IFEND;
      CASE call_block.operation OF

      = amc$fetch_req =
        amp$access_method (file_id, call_block, layer_number, stat);

      = amc$fetch_access_information_rq =
        icp$fetch_access_info (icf_file, call_block.operation,
              call_block.fai.access_information, stat);

      = amc$rewind_req =
        icf_file^.position := amc$boi;

      = amc$seek_direct_req, amc$skip_req =

      = amc$write_tape_mark_req, amc$get_segment_pointer_req,
            amc$set_segment_eoi_req, amc$set_segment_position_req,
            amc$replace_req =
        amp$set_file_instance_abnormal (file_id, ame$improper_fap_operation,
              call_block.operation, '', stat);

      = amc$close_req =
        osp$set_job_signature_lock (icv$open_file_count_lock);
        IF icv$open_file_count > 0 THEN
          icv$open_file_count := icv$open_file_count - 1;
        IFEND;
        osp$clear_job_signature_lock (icv$open_file_count_lock);
        IF ((icf_file^.last_fap_op <> amc$open_req) OR
              ((icf_file^.last_fap_op = amc$open_req) AND
              (icf_file^.last_status = 0))) THEN
          icp$close (icf_file, call_block.operation, stat);
        IFEND;
        IF icf_file^.buff <> NIL THEN
          FREE icf_file^.buff IN osv$task_private_heap^;
        IFEND;
        FREE icf_file IN osv$task_private_heap^;
        amp$access_method (file_id, call_block, layer_number, stat);

      = amc$flush_req =
        icp$flush (icf_file, call_block.operation, stat);

      = amc$get_direct_req =
        icp$get (icf_file, call_block.operation,
              call_block.getd.working_storage_area,
              call_block.getd.working_storage_length,
              call_block.getd.transfer_count, amc$skip_to_eor, stat);
        call_block.getd.file_position^ := icf_file^.position;

      = amc$get_next_req =
        icp$get (icf_file, call_block.operation,
              call_block.getn.working_storage_area,
              call_block.getn.working_storage_length,
              call_block.getn.transfer_count, amc$skip_to_eor, stat);
        call_block.getn.file_position^ := icf_file^.position;

      = amc$get_partial_req =
        icp$get (icf_file, call_block.operation,
              call_block.getp.working_storage_area,
              call_block.getp.working_storage_length,
              call_block.getp.transfer_count, call_block.getp.skip_option,
              stat);
        call_block.getp.file_position^ := icf_file^.position;
        call_block.getp.record_length^ := icf_file^.record_length;

      = amc$put_direct_req =
        icp$put (icf_file, call_block.operation,
              call_block.putd.working_storage_area,
              call_block.putd.working_storage_length, amc$start, stat);

      = amc$put_next_req =
        icp$put (icf_file, call_block.operation,
              call_block.putn.working_storage_area,
              call_block.putn.working_storage_length, amc$start, stat);

      = amc$put_partial_req =
        icp$put (icf_file, call_block.operation,
              call_block.putp.working_storage_area,
              call_block.putp.working_storage_length,
              call_block.putp.term_option, stat);

      = amc$write_end_partition_req =
        icp$write_end_partition (icf_file, call_block.operation, stat);

      ELSE
        amp$access_method (file_id, call_block, layer_number, stat);
      CASEND;
    IFEND;
    IF (call_block.operation <> amc$close_req) AND
          (call_block.operation <> amc$fetch_access_information_rq) THEN
      icf_file^.last_fap_op := call_block.operation;
      IF stat.normal THEN
        icf_file^.last_status := 0;
      ELSE
        icf_file^.last_status := stat.condition;
      IFEND;
    IFEND;
    status := stat;
  PROCEND icp$fap_control;
MODEND icm$fap_control;
*DECK DECK=ICM$FETCH_ACCESS_INFO EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE icm$fetch_access_info;
?? TITLE := 'MODULE icm$fetch_access_info' ??

?? PUSH (LISTEXT := ON) ??
*copyc AMT$ACCESS_INFORMATION
*copyc AMD$OPERATION_DECLARATIONS
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc ICE$ERROR_CODES
*copyc ICF$OPEN_FILE_DESCRIPTOR
*copyc ICP$STATUS_PARTNER_JOB
*copyc OST$STATUS
?? POP ??

?? NEWTITLE := 'PROCEDURE icp$fetch_access_info' ??
{  ICP$FETCH_ACCESS_INFO
{
{     The purpose of this procedure is to return the access_info
{  that is available for a link file.

  PROCEDURE [XDCL] icp$fetch_access_info
    (    icf_file: ^icf_open_file_descriptor;
         operation: amt$fap_operation;
         access_info: ^amt$access_information;
     VAR status: ost$status);

    VAR
      partner_stat: ict$status_partner_status,
      stat: ost$status,
      i: integer;


    status.normal := TRUE;
    FOR i := LOWERBOUND (access_info^) TO UPPERBOUND (access_info^) DO
      access_info^ [i].item_returned := TRUE;
      CASE access_info^ [i].key OF

      = amc$error_status =
        access_info^ [i].error_status := icf_file^.last_status;

      = amc$file_position =
        access_info^ [i].file_position := icf_file^.position;

      = amc$last_access_operation =
        access_info^ [i].last_access_operation := icf_file^.last_fap_op;

      = amc$last_op_status =
        icp$status_partner_job (icf_file^.partner_id, partner_stat, stat);
        IF stat.normal THEN
          IF (partner_stat = icc$partner_signed_on) OR
                (partner_stat = icc$partner_not_found) THEN
            access_info^ [i].last_op_status := amc$complete;
          ELSE
            access_info^ [i].last_op_status := amc$active;
          IFEND;
          IF partner_stat = icc$partner_not_found THEN
            amp$set_file_instance_abnormal (icf_file^.file_id,
                  ice$partner_ended, operation, '', status);
          IFEND;
        ELSE
          status := stat;
        IFEND;

      = amc$previous_record_length =
        access_info^ [i].previous_record_length := icf_file^.last_length;

{  Thats all the info thats defined for a link file.

      ELSE
        access_info^ [i].item_returned := FALSE;

      CASEND;

    FOREND;

  PROCEND icp$fetch_access_info;
MODEND icm$fetch_access_info;
*DECK DECK=ICM$FLUSH EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE icm$flush;
?? TITLE := 'MODULE icm$flush' ??

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_POSITION
*copyc AMD$OPERATION_DECLARATIONS
*copyc AMT$TERM_OPTION
*copyc AMT$TRANSFER_COUNT
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc ICE$ERROR_CODES
*copyc ICF$OPEN_FILE_DESCRIPTOR
*copyc ICP$PUT
*copyc ICP$SET_STATUS_ABNORMAL
*copyc ICP$STATUS_PARTNER_JOB
*copyc IFE$ERROR_CODES
*copyc MLP$FETCH_LINK_PARTNER_INFO
*copyc MLP$CONFIRM_SEND
*copyc OSP$DISESTABLISH_COND_HANDLER
*copyc OSP$ESTABLISH_CONDITION_HANDLER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$CONTINUE_TO_CAUSE
*copyc PMP$EXIT
*copyc PMP$LONG_TERM_WAIT
*copyc PMP$WAIT
?? POP ??

?? NEWTITLE := 'PROCEDURE icp$flush' ??
{  ICP$FLUSH
{
{     The purpose of this procedure is to ensure that any prior
{  partial messages are terminated, and that the partner job has
{  received all outstanding  prior messages.

  PROCEDURE [XDCL] icp$flush
    (    icf_file: ^icf_open_file_descriptor;
         operation: amt$fap_operation;
     VAR status: ost$status);

    VAR
      ptr: ^cell,
      last_op: mlt$operation,
      partner_stat: ict$status_partner_status,
      stat: ost$status;

    PROCEDURE handle_break
      (    cond: pmt$condition;
           condition_info: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR break_status: ost$status);

      VAR
        local_status: ost$status;

      IF (cond.selector = ifc$interactive_condition) THEN
        IF cond.interactive_condition = ifc$pause_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$pause_break_received, '', status);
        ELSEIF cond.interactive_condition = ifc$terminate_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$terminate_break_received, '', status);
        IFEND;
        pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
        EXIT icp$flush;
      IFEND;
      break_status.normal := TRUE;
      RETURN;
    PROCEND handle_break;

{ Begin procedure ICP$FLUSH.

    status.normal := TRUE;
    osp$establish_condition_handler (^handle_break, FALSE);
    IF NOT icf_file^.opened_for_put THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ame$improper_output_attempt, operation, '', status);
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    ptr := icf_file;
    IF icf_file^.position = amc$mid_record THEN

{  Terminate prior partial record.

      icp$put (icf_file, amc$put_next_req, ptr, 0, amc$terminate, stat);
      IF NOT stat.normal THEN
        osp$disestablish_cond_handler;
        pmp$exit (stat);
      IFEND;
    IFEND;

{  Wait for partner job to receive any outstanding prior record.

  /loop/
    WHILE TRUE DO

      mlp$confirm_send (icf_file^.application_name,
            icf_file^.partner_id.application_name, stat);

      IF (stat.normal) OR (stat.condition = mlc$ok) THEN
        EXIT /loop/;
      ELSE
        CASE stat.condition OF
        = mlc$busy_interlock =
          pmp$wait (icf_short_interval, icf_short_interval);
          CYCLE /loop/;
        = mlc$receiver_not_signed_on =
          icp$status_partner_job (icf_file^.partner_id, partner_stat, stat);
          IF stat.normal THEN
            IF partner_stat = icc$partner_not_found THEN
              amp$set_file_instance_abnormal (icf_file^.file_id,
                    ice$partner_ended, operation, '', status);
              EXIT /loop/;
            ELSE
              pmp$long_term_wait (icf_interval, icf_interval);
              CYCLE /loop/;
            IFEND;
          ELSE
            osp$disestablish_cond_handler;
            pmp$exit (stat);
          IFEND;

        = mlc$prior_msg_not_received, mlc$receive_list_full =

        /flpi_loop/
          WHILE TRUE DO
            mlp$fetch_link_partner_info (icf_file^.application_name, icf_file^.
                partner_id.application_name, last_op, stat);
            IF (stat.normal) OR (stat.condition = mlc$ok) THEN
              EXIT /flpi_loop/;
            ELSE
              CASE stat.condition OF
              = mlc$busy_interlock =
                pmp$wait (icf_short_interval, icf_short_interval);
                CYCLE /flpi_loop/;
              = mlc$receiver_not_signed_on =
                icp$status_partner_job (icf_file^.partner_id, partner_stat,
                      stat);
                IF stat.normal THEN
                  IF partner_stat = icc$partner_not_found THEN
                    amp$set_file_instance_abnormal
                          (icf_file^.file_id, ice$partner_ended, operation, '',
                          status);
                    osp$disestablish_cond_handler;
                    RETURN;
                  ELSE
                    pmp$long_term_wait (icf_interval, icf_interval);
                    CYCLE /flpi_loop/;
                  IFEND;
                ELSE
                  osp$disestablish_cond_handler;
                  pmp$exit (stat);
                IFEND;
              ELSE
                icp$set_status_abnormal (stat);
                osp$disestablish_cond_handler;
                pmp$exit (stat);
              CASEND;
            IFEND;
          WHILEND /flpi_loop/;

          IF ((last_op.req = mlc$send_message_req) OR
                (last_op.req = mlc$confirm_send_req)) AND
                ((last_op.stat_condition = mlc$prior_msg_not_received) OR
                (last_op.stat_condition = mlc$receive_list_full)) THEN
            amp$set_file_instance_abnormal (icf_file^.file_id,
                  ice$write_deadlock, operation, '', status);
            RETURN;
          ELSE
            pmp$long_term_wait (icf_interval, icf_interval);
            CYCLE /loop/;
          IFEND;
        ELSE
          icp$set_status_abnormal (stat);
          osp$disestablish_cond_handler;
          pmp$exit (stat);
        CASEND;
      IFEND;
    WHILEND /loop/;

  PROCEND icp$flush;

MODEND icm$flush;
*DECK DECK=ICM$GET EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE icm$get;
?? TITLE := 'MODULE icm$get' ??

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_POSITION
*copyc AMT$SKIP_OPTION
*copyc AMD$OPERATION_DECLARATIONS
*copyc AMT$MAX_RECORD_LENGTH
*copyc AMT$TRANSFER_COUNT
*copyc AME$GET_VALIDATION_ERRORS
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc AME$GET_PROGRAM_ACTIONS
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc ICE$ERROR_CODES
*copyc ICF$OPEN_FILE_DESCRIPTOR
*copyc IFE$ERROR_CODES
*copyc ICP$SET_STATUS_ABNORMAL
*copyc ICP$STATUS_PARTNER_JOB
*copyc I#PTR
*copyc I#MOVE
*copyc MLP$CONFIRM_SEND
*copyc MLP$FETCH_RECEIVE_LIST
*copyc MLP$FETCH_LINK_PARTNER_INFO
*copyc MLP$RECEIVE_MESSAGE
*copyc OST$STATUS
*copyc OSV$TASK_PRIVATE_HEAP
*copyc OSP$DISESTABLISH_COND_HANDLER
*copyc OSP$ESTABLISH_CONDITION_HANDLER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$CONTINUE_TO_CAUSE
*copyc PMP$EXIT
*copyc PMP$WAIT
*copyc PMP$LONG_TERM_WAIT
?? POP ??

?? NEWTITLE := 'PROCEDURE icp$get' ??
{  ICP$GET
{
{     The purpose of this procedure is to get a record or partial
{  record from the 170 partner job.

  PROCEDURE [XDCL] icp$get
    (    icf_file: ^icf_open_file_descriptor;
         operation: amt$fap_operation;
         working_storage_area: ^cell;
         wsa_length: amt$working_storage_length;
         transfer_count: ^amt$transfer_count;
         skip_option: amt$skip_option;
     VAR status: ost$status);

    VAR
      buff_in: [STATIC] integer := 0,
      buff_out: [STATIC] integer := 0,
      p1: ^cell,
      p2: ^cell,
      p3: integer,
      fatal: boolean,
      zero_length_record: boolean,
      offset: amt$working_storage_length,
      message_length: mlt$message_length,
      unused_bits: integer,
      eoi: [STATIC] boolean := FALSE,
      eop: [STATIC] boolean := FALSE,
      first_message: [STATIC] boolean := FALSE,
      last_message: [STATIC] boolean := FALSE,
      last_op: mlt$operation,
      arbitrary_info: mlt$arbitrary_info,
      signal_record: mlt$signal_record,
      signal: mlt$signal;

{  RECEIVER
{
{     The purpose of this procedure is to read the next message into
{  the buffer.

    PROCEDURE receiver;

      VAR
        frl_list: mlt$receive_list,
        frl_count: mlt$receive_count,
        partner_stat: ict$status_partner_status,
        stat: ost$status;

      PROCEDURE handle_break
        (    cond: pmt$condition;
             condition_info: ^pmt$condition_information;
             stack_frame_save_area: ^ost$stack_frame_save_area;
         VAR break_status: ost$status);

        VAR
          busy_count: 0 .. 100,
          local_status: ost$status;

{  Receive any pending message before processing the break.

        busy_count := 0;

      /receive_message_loop/
        WHILE TRUE DO
          mlp$receive_message (icf_file^.application_name, arbitrary_info,
                signal, icf_file^.buff, message_length, mlc$max_message_length,
                0, icf_file^.partner_id.application_name, status);
          IF status.normal THEN
            EXIT /receive_message_loop/;
          ELSE
            CASE status.condition  OF
            = mlc$busy_interlock =
              pmp$wait (icf_short_interval, icf_short_interval);
            = mlc$receive_list_index_invalid =
              IF busy_count < 100 THEN
                busy_count := busy_count + 1;
                pmp$long_term_wait (icf_interval, icf_interval);
              ELSE

              /confirm_send/
                WHILE TRUE DO
                  mlp$confirm_send (icf_file^.application_name,
                        icf_file^.partner_id.application_name, status);
                  IF (status.normal) OR (status.condition = mlc$ok) OR
                        (status.condition = mlc$prior_msg_not_received) THEN
                    busy_count := 0;
                    pmp$long_term_wait (icf_interval, icf_interval);
                    CYCLE /receive_message_loop/;
                  ELSEIF (status.condition = mlc$busy_interlock) THEN
                    pmp$wait (icf_short_interval, icf_short_interval);
                    CYCLE /confirm_send/;
                  ELSEIF (status.condition = mlc$sender_not_permitted) THEN
                    pmp$long_term_wait (icf_interval, icf_interval);
                    CYCLE /confirm_send/;
                  ELSEIF status.condition = mlc$receiver_not_signed_on THEN
                    icp$status_partner_job (icf_file^.partner_id, partner_stat,
                          status);
                    IF status.normal THEN
                      IF partner_stat = icc$partner_not_found THEN
                        EXIT /receive_message_loop/;
                      ELSE
                        busy_count := 0;
                        pmp$long_term_wait (icf_interval, icf_interval);
                        CYCLE /receive_message_loop/;
                      IFEND;
                    ELSE
                      EXIT /receive_message_loop/;
                    IFEND;
                  IFEND;
                WHILEND /confirm_send/;
              IFEND;
            ELSE
              EXIT /receive_message_loop/;
            CASEND;
          IFEND;
        WHILEND /receive_message_loop/;
        IF (cond.selector = ifc$interactive_condition) THEN
          IF cond.interactive_condition = ifc$pause_break THEN
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$pause_break_received, '', status);
          ELSEIF cond.interactive_condition = ifc$terminate_break THEN
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$terminate_break_received, '', status);
          IFEND;
          pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
          fatal := TRUE;
          EXIT receiver;
        IFEND;
        break_status.normal := TRUE;
        RETURN;
      PROCEND handle_break;

{ Begin procedure RECEIVER.

      osp$establish_condition_handler (^handle_break, FALSE);
      stat.normal := TRUE;
      fatal := FALSE;

    /receive_loop/
      WHILE TRUE DO
        mlp$receive_message (icf_file^.application_name, arbitrary_info,
              signal, icf_file^.buff, message_length, mlc$max_message_length,
              0, icf_file^.partner_id.application_name, stat);

        IF stat.normal THEN
          EXIT /receive_loop/;
        ELSE
          CASE stat.condition OF
          = mlc$ok, mlc$signal_failed_ignored, mlc$signal_to_c170_ignored =
            EXIT /receive_loop/;
          = mlc$busy_interlock =
            pmp$wait (icf_short_interval, icf_short_interval);
            CYCLE /receive_loop/;
          = mlc$receive_list_index_invalid =

{  Check for read deadlock and partner ended.

          /confirm_loop/
            WHILE TRUE DO
              mlp$confirm_send (icf_file^.application_name,
                    icf_file^.partner_id.application_name, stat);
              IF (stat.normal) OR (stat.condition = mlc$ok) THEN
                EXIT /confirm_loop/;
              ELSE
                CASE stat.condition OF
                = mlc$prior_msg_not_received =
                  pmp$long_term_wait (icf_interval, icf_interval);
                  CYCLE /receive_loop/;
                = mlc$busy_interlock =
                  pmp$wait (icf_short_interval, icf_short_interval);
                  CYCLE /confirm_loop/;
                = mlc$sender_not_permitted =
                  pmp$long_term_wait (icf_interval, icf_interval);
                  CYCLE /confirm_loop/;
                = mlc$receiver_not_signed_on =
                  icp$status_partner_job (icf_file^.partner_id, partner_stat,
                        stat);
                  IF stat.normal THEN
                    IF partner_stat = icc$partner_not_found THEN
                      amp$set_file_instance_abnormal
                            (icf_file^.file_id, ice$partner_ended, operation,
                            '', status);
                      fatal := TRUE;
                      osp$disestablish_cond_handler;
                      RETURN;
                    ELSE
                      pmp$long_term_wait (icf_interval, icf_interval);
                      CYCLE /receive_loop/;
                    IFEND;
                  ELSE
                    fatal := TRUE;
                    osp$disestablish_cond_handler;
                    pmp$exit (stat);
                  IFEND;
                ELSE
                  icp$set_status_abnormal (stat);
                  fatal := TRUE;
                  osp$disestablish_cond_handler;
                  pmp$exit (stat);
                CASEND;
              IFEND;
            WHILEND /confirm_loop/;

          /flpi_loop_1/
            WHILE TRUE DO
              mlp$fetch_link_partner_info (icf_file^.application_name,
                    icf_file^.partner_id.application_name, last_op, stat);
              IF (stat.normal) OR (stat.condition = mlc$ok) THEN
                EXIT /flpi_loop_1/;
              ELSE
                CASE stat.condition OF
                = mlc$busy_interlock =
                  pmp$wait (icf_short_interval, icf_short_interval);
                  CYCLE /flpi_loop_1/;
                = mlc$receiver_not_signed_on =
                  icp$status_partner_job (icf_file^.partner_id, partner_stat,
                        stat);
                  IF stat.normal THEN
                    IF partner_stat = icc$partner_not_found THEN
                      amp$set_file_instance_abnormal
                            (icf_file^.file_id, ice$partner_ended, operation,
                            '', status);
                      fatal := TRUE;
                      osp$disestablish_cond_handler;
                      pmp$exit (stat);
                    ELSE
                      pmp$long_term_wait (icf_interval, icf_interval);
                      CYCLE /receive_loop/;
                    IFEND;
                  ELSE
                    fatal := TRUE;
                    osp$disestablish_cond_handler;
                    pmp$exit (stat);
                  IFEND;
                ELSE
                  icp$set_status_abnormal (stat);
                  fatal := TRUE;
                  osp$disestablish_cond_handler;
                  pmp$exit (stat);
                CASEND;
              IFEND;
            WHILEND /flpi_loop_1/;

            IF (last_op.req = mlc$receive_message_req) AND
                  (last_op.stat_condition = mlc$receive_list_index_invalid)
                  THEN

            /fetchrl_loop/
              WHILE TRUE DO
                mlp$fetch_receive_list (icf_file^.application_name,
                      icf_file^.partner_id.application_name, frl_list,
                      frl_count, stat);
                IF (stat.normal) OR (stat.condition = mlc$ok) THEN
                  IF frl_count <> 0 THEN
                    CYCLE /receive_loop/;
                  ELSE
                    amp$set_file_instance_abnormal
                          (icf_file^.file_id, ice$read_deadlock, operation, '',
                          status);
                    fatal := TRUE;
                    RETURN;
                  IFEND;
                ELSE
                  CASE stat.condition OF
                  = mlc$busy_interlock =
                    pmp$wait (icf_short_interval, icf_short_interval);
                    CYCLE /fetchrl_loop/;
                  ELSE
                    icp$set_status_abnormal (stat);
                    fatal := TRUE;
                    osp$disestablish_cond_handler;
                    pmp$exit (stat);
                  CASEND;
                IFEND;
              WHILEND /fetchrl_loop/;
            ELSE
              pmp$long_term_wait (icf_interval, icf_interval);
              CYCLE /receive_loop/;
            IFEND;
          ELSE
            fatal := TRUE;
            osp$disestablish_cond_handler;
            pmp$exit (stat);
          CASEND;
        IFEND;
      WHILEND /receive_loop/;
      zero_length_record := (message_length = 0);
      buff_in := message_length;
      buff_out := 0;
      unused_bits := arbitrary_info DIV 16;
      eoi := arbitrary_info MOD 16 >= 8;
      eop := arbitrary_info MOD 8 >= 4;
      first_message := arbitrary_info MOD 4 >= 2;
      last_message := arbitrary_info MOD 2 >= 1;
      osp$disestablish_cond_handler;

    PROCEND receiver;

{  Body of icp$get.

    status.normal := TRUE;
    IF icf_file^.position = amc$eoi THEN
      amp$set_file_instance_abnormal (icf_file^.file_id, ame$input_after_eoi,
            operation, '', status);
      RETURN;
    IFEND;
    IF NOT icf_file^.opened_for_get THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ame$improper_input_attempt, operation, '', status);
      RETURN;
    IFEND;
    signal := ^signal_record;
    offset := 0;
    zero_length_record := FALSE;
    IF icf_file^.buff = NIL THEN
      ALLOCATE icf_file^.buff IN osv$task_private_heap^;
    IFEND;
    IF (operation = amc$get_next_req) OR (operation = amc$get_direct_req) OR
          ((operation = amc$get_partial_req) AND
          (skip_option = amc$skip_to_eor)) THEN

      icf_file^.record_length := 0;
      first_message := FALSE;

{  Skip past any partial records until the beginning of a record
{  is found.

    /repeat_loop_1/
      REPEAT
        receiver;
        IF fatal THEN
          RETURN;
        IFEND;
      UNTIL first_message; {/REPEAT_LOOP_1/}
    IFEND;

{  Transfer data from the buffer until the end of a record is reached
{  or the user's record area is filled.  Call procedure 'receiver' to
{  fill or replenish the buffer as needed.

  /repeat_loop_2/
    WHILE TRUE DO
      IF (buff_out >= buff_in) AND (offset < wsa_length) AND
            (NOT zero_length_record) THEN
        receiver;
        IF fatal THEN
          RETURN;
        IFEND;
      IFEND;
      IF (offset <= wsa_length) AND (buff_out < buff_in) THEN
        IF (wsa_length - offset) < (buff_in - buff_out) THEN
          p3 := (wsa_length - offset);
        ELSE
          p3 := (buff_in - buff_out);
        IFEND;
        p1 := i#ptr (buff_out, icf_file^.buff); {source}
        p2 := i#ptr (offset, working_storage_area); {destination}
        i#move (p1, p2, p3);
        offset := offset + p3;
        buff_out := buff_out + p3;
      IFEND;
      IF (offset >= wsa_length) OR ((buff_out >= buff_in) AND (last_message))
            THEN
        EXIT /repeat_loop_2/;
      IFEND;
    WHILEND /repeat_loop_2/;
    transfer_count^ := offset;
    icf_file^.record_length := icf_file^.record_length + offset;

{  Store file position information.

    IF last_message THEN
      IF eoi THEN
        icf_file^.position := amc$eoi;
      ELSEIF eop THEN
        icf_file^.position := amc$eop;
      ELSEIF buff_out < buff_in THEN
        icf_file^.position := amc$mid_record;
      ELSE
        icf_file^.position := amc$eor;
        icf_file^.last_length := icf_file^.record_length;
      IFEND;
    ELSE
      icf_file^.position := amc$mid_record;
    IFEND;
  PROCEND icp$get;

MODEND icm$get;
*DECK DECK=ICM$JOB_INITIALIAZE EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE icm$job_initialiaze;
?? TITLE := 'MODULE icm$job_initialiaze' ??

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc ICV$OPEN_FILE_COUNT_LOCK
*copyc OSP$INITIALIZE_SIG_LOCK
?? POP ??

?? TITLE := 'PROCEDURE icp$job_initialize', EJECT ??

  PROCEDURE [XDCL] icp$job_initialize (VAR status: ost$status);

{ Initialize the open file count lock.
    status.normal := TRUE;

    osp$initialize_sig_lock (icv$open_file_count_lock);

  PROCEND icp$job_initialize;

MODEND icm$job_initialiaze;
*DECK DECK=ICM$OPEN EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE icm$open;

?? PUSH (LISTEXT := ON) ??
?? POP ??
*copyc AMT$FILE_POSITION
*copyc AMD$INFORMATION
*copyc AMD$OPERATION_DECLARATIONS
*copyc AMD$OPEN_DECLARATIONS
*copyc AMP$FETCH
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc CLP$READ_VARIABLE
*copyc I#PTR
*copyc I#REL
*copyc ICE$ERROR_CODES
*copyc MLP$ADD_SENDER
*copyc MLP$CONFIRM_SEND
*copyc MLP$SIGN_ON
*copyc ICF$OPEN_FILE_DESCRIPTOR
*copyc ICT$PARTNER_MESSAGES
*copyc ICP$INITIATE_PARTNER_JOB
*copyc ICP$SET_STATUS_ABNORMAL
*copyc ICV$OPEN_FILE_COUNT_LOCK
*copyc JMP$GET_JOB_ATTRIBUTES
*copyc OST$STATUS
*copyc OSS$JOB_PAGED_LITERAL
*copyc OSP$APPEND_STATUS_INTEGER
*copyc OSP$CLEAR_SIGNATURE_LOCK
*copyc OSP$SET_SIGNATURE_LOCK
*copyc PMP$EXIT
*copyc PMP$GET_USER_IDENTIFICATION
*copyc PMP$WAIT
*copyc RHP$GET_LINK_USER_DESCRIPTOR
?? POP ??

  TYPE
    ict$validation_information = packed record
      job: array [1 .. 10] of icf$170_record,
      user_name: array [1 .. 2] of icf$170_record,
      family_name: array [1 .. 2] of icf$170_record,
      password: array [1 .. 4] of icf$170_record,
      charge_number: array [1 .. 4] of icf$170_record,
      project_number: array [1 .. 4] of icf$170_record,
      original_user_name: array [1 .. 2] of icf$170_record,
      original_family_name: array [1 .. 2] of icf$170_record,
      original_charge_number: array [1 .. 4] of icf$170_record,
      original_project_number: array [1 .. 4] of icf$170_record,
    recend;

  VAR
    clv_gets: integer,
    single_string: boolean,
    previous_length: integer,
    clv_length: integer,
    clv_end: boolean,
    curr_ptr: ^cell,
    clvptr: ^cell;

?? EJECT ??
{  ICP$READ_CV
{
{     The purpose of this procedure is to read the command language
{  variable named in User_Info in the link file to get certain
{  attributes of the command language variable, i.e., a pointer to
{  the value string, the length of the string, and the dimensions
{  of the variable.
{
{     ICP$READ_CV (CVNAME, STAT);
{
{  CVNAME: (input) This parameter specifies the name of the command
{     language variable to be read.
{
{  STAT: (output) This parameter indicates whether or not the attempt
{     to read the command language variable was successful.

  PROCEDURE icp$read_cv
    (    cvname: string ( * );
     VAR clvar: clt$variable_reference;
     VAR stat: ost$status);

    VAR
      len_ptr: ^ost$string_size;

    clp$read_variable (cvname, clvar, stat);
    IF NOT stat.normal THEN
      RETURN;
    IFEND;
    IF clvar.value.kind <> clc$string_value THEN
      stat.normal := FALSE;
      RETURN;
    IFEND;
    single_string := clvar.lower_bound = clvar.upper_bound;
    IF single_string THEN
      previous_length := 1;
    ELSE
      previous_length := 0;
    IFEND;
    clv_length := clvar.value.max_string_size;
    clvptr := clvar.value.string_value;
    curr_ptr := clvptr;
    len_ptr := curr_ptr;
    clv_end := (clv_length = 0) OR (len_ptr^ = 0);
    clv_gets := 0;

  PROCEND icp$read_cv;
?? EJECT ??
{  ICP$GET_NEXT_CV
{
{     The purpose of this procedure is to locate the next NOS command
{  within the string of the command language variable named in User_
{  Info of the link file.  A pointer to the beginning of the next NOS
{  command, and the length of the NOS command are returned.
{
{     ICP$GET_NEXT_CV (PTR,LEN);
{
{  PTR: (output) This parameter points to the beginning of the next
{     NOS command.
{
{  LEN: (output) This parameter indicates the length of the next NOS
{     command.

  PROCEDURE icp$get_next_cv
    (VAR ptr: ^cell;
     VAR clvar: clt$variable_reference;
     VAR len: integer);

    VAR
      remains: integer,
      str_ptr: ^string (osc$max_string_size),
      len_ptr: ^ost$string_size;

    IF clv_end THEN
      len := 0;
      ptr := NIL;
      RETURN;
    IFEND;
    IF single_string THEN
      curr_ptr := i#ptr ((previous_length + 1), curr_ptr);
    ELSE
      len_ptr := i#ptr (previous_length, curr_ptr);
      curr_ptr := i#ptr (2, len_ptr);
    IFEND;

    IF single_string THEN
      remains := clv_length - i#rel (clvptr, curr_ptr);
      str_ptr := curr_ptr;

    /loop/
      FOR len := 1 TO remains DO
        IF str_ptr^ (len) = ';' THEN
          EXIT /loop/;
        IFEND;
      FOREND /loop/;
      clv_end := len >= remains;
      len := len - 1;
      previous_length := len;
    ELSE
      len := len_ptr^;
      clv_gets := clv_gets + 1;
      clv_end := clv_gets > (clvar.upper_bound - clvar.lower_bound);
      previous_length := clv_length;
    IFEND;
    ptr := curr_ptr;

  PROCEND icp$get_next_cv;
?? EJECT ??
{  ICP$CONVERT
{
{     The purpose of this routine is to convert a 180 ASCII string to
{  a 170 Z-type display code record.  The length of the 170 record is
{  'measured' in terms of words.  Conversion stops when the 170 record
{  area is filled (an error), or the 180 string is exhausted.  A Z-
{  type record is terminated by a right justified field of 12 to 60
{  bits of zeros.
{
{     ICP$CONVERT (SOURCE_STRING,SOURCE_LENGTH,ZREC,ZINDEX,ZLEN,STAT);
{
{  SOURCE_STRING (input) This parameter is a pointer to the ASCII
{     string that is to be converted.
{
{  SOURCE_LENGTH (input) This parameter indicates the length of
{     the ASCII string.
{
{  ZREC (input) This parameter is a pointer to where the converted
{     string is to be placed.
{
{  ZINDEX (output) This parameter indicates the number of 170
{     words needed to hold the converted string.
{
{  ZLEN (input) This parameter indicates the size (in words) of the
{     area where the converted string is to be placed.
{
{  STAT (output) This parameter indicates whether or not the converted
{     string would fit into ZREC.

  TYPE

    icf$170_record = packed record
      f1: 0 .. 0f(16),
      chr0: 0 .. 3f(16),
      chr1: 0 .. 3f(16),
      f_word: packed array [2 .. 9] of 0 .. 3f(16),
    recend,
    icf$180_record = 0 .. 0ff(16);


  PROCEDURE icp$convert
    (    source_string: ^array [1 .. 256] of icf$180_record;
         source_length: integer;
         z_rec: ^array [1 .. * ] of icf$170_record;
     VAR z_rec_index: integer;
         z_rec_length: integer;
     VAR status: ost$status);


?? FMT (FORMAT := ON) ??

    VAR
      cnv_tab: [STATIC, READ, oss$job_paged_literal] array [0 .. 255] of
            0 .. 3f(16) :=
{  } [REP 32 of 39,
{  } 45, 54, 52, 48, 43, 51, 55, 56, 41, 42, 39, 37, 46, 38, 47, 40,
{  } 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 00, 63, 58, 44, 59, 57,
{  } 60, 01, 02, 03, 04, 05, 06, 07, 08, 09, 10, 11, 12, 13, 14, 15,
{  } 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 49, 61, 50, 62, 53,
{  } 61, 01, 02, 03, 04, 05, 06, 07, 08, 09, 10, 11, 12, 13, 14, 15,
{  } 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 39, 39, 39, 39, 39,
{  } REP 128 of 39];


    VAR
      i: integer,
      source_offset: integer,
      working_length: integer,
      zeros_needed: 0 .. 11;

    source_offset := 1;
    z_rec_index := 0;
    working_length := source_length;

  /trailing_blanks/
    FOR i := working_length DOWNTO 1 DO
      IF source_string^ [i] = 32 THEN
        working_length := working_length - 1;
      ELSE
        EXIT /trailing_blanks/;
      IFEND;
    FOREND /trailing_blanks/;
    WHILE (z_rec_index <= z_rec_length) AND
          (source_offset <= working_length) DO
      icp$insert_next_170_char (z_rec, z_rec_index,
            cnv_tab [source_string^ [source_offset]]);
      source_offset := source_offset + 1;
    WHILEND;
    zeros_needed := (11 - source_offset MOD 10);
    IF zeros_needed < 2 THEN
      zeros_needed := zeros_needed + 10;
    IFEND;
    IF ((zeros_needed DIV 10) + z_rec_index) > z_rec_length THEN
      status.normal := FALSE;
      RETURN;
    IFEND;
    FOR i := 1 TO zeros_needed DO
      icp$insert_next_170_char (z_rec, z_rec_index, 0);
    FOREND;

  PROCEND icp$convert;

?? EJECT ??
{  ICP$INSERT_NEXT_170_CHAR
{
{     The purpose of this procedure is to insert  a display code
{  character into the next six bit character position in the lower
{  sixty bits of a word.
{
{     ICP$INSERT_NEXT_170_CHAR (ZREC, ZINDEX, ZCHAR);
{
{  ZREC (input) This parameter is a pointer to a 170 record area.
{
{  ZINDEX (input,output) This parameter indicates which word within
{     the 170 record area is to hold the next display code character.
{
{  ZCHAR (input) This parameter is the six bit display code character
{     to be inserted.

  PROCEDURE icp$insert_next_170_char
    (    z_rec: ^array [1 .. * ] of icf$170_record;
     VAR z_rec_index: integer;
         z_char: 0 .. 3f(16));

    VAR
      c: [STATIC] 0 .. 10;

    IF z_rec_index = 0 THEN
      z_rec_index := 1;
      c := 0;
    IFEND;
    IF c = 10 THEN
      z_rec_index := z_rec_index + 1;
      c := 0;
    IFEND;
    IF c < 2 THEN
      IF c = 0 THEN
        z_rec^ [z_rec_index].f1 := 0;
        z_rec^ [z_rec_index].chr0 := z_char;
      ELSE
        z_rec^ [z_rec_index].chr1 := z_char;
      IFEND;
    ELSE
      z_rec^ [z_rec_index].f_word [c] := z_char;
    IFEND;
    c := c + 1;

  PROCEND icp$insert_next_170_char;
?? EJECT ??
{  ICP$OPEN
{
{     The purpose of this procedure is to 'open' the link file, i.e.,
{  to signon to the memory link, to start the 170 partner job, and
{  to permit the 170 partner job to send to this 180 job.

  PROCEDURE [XDCL] icp$open
    (    icf_file: ^icf_open_file_descriptor;
         operation: amt$fap_operation;
         access_level: amt$access_level;
     VAR status: ost$status);

    VAR
      nos_card_counter: integer,
      liu_stuff: rht$link_user_descriptor,
      clvar: clt$variable_reference,
      get_attribute_p: ^jmt$job_attribute_results,
      validation_information: ict$validation_information,
      fetch_access: array [1 .. 2] of amt$fetch_item,
      stat: ost$status,
      rec: array [1 .. icc$max_partner_image_length] of icf$170_record,
      z_rec: ^array [1 .. icc$max_partner_image_length] of icf$170_record,
      z_rec_index: integer,
      z_rec_length: integer,
      ptr: ^cell,
      len: integer;

{  Initialize.

    status.normal := TRUE;
    icf_file^.position := amc$boi;
    icf_file^.record_length := 0;
    icf_file^.last_fap_op := amc$close_req;
    icf_file^.last_status := 0;
    icf_file^.buff := NIL;
    osp$set_signature_lock (icv$open_file_count_lock, osc$wait, stat);
    IF NOT stat.normal THEN
      pmp$exit (stat);
    IFEND;
    icv$open_file_count := icv$open_file_count + 1;
    osp$clear_signature_lock (icv$open_file_count_lock, stat);
    IF icv$open_file_count > icc$max_open_files_per_job THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ice$link_is_already_open, operation, '', status);
      RETURN;
    IFEND;
    IF access_level <> amc$record THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ice$access_level_not_record, operation, '', status);
      RETURN;
    IFEND;
    fetch_access [1].key := amc$user_info;
    fetch_access [2].key := amc$access_mode;
    amp$fetch (icf_file^.file_id, fetch_access, stat);
    IF fetch_access [1].source = amc$access_method_default THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ice$no_job_spec_variable, operation, '', status);
      RETURN;
    IFEND;

    icf_file^.opened_for_get := pfc$read IN fetch_access [2].access_mode;
    icf_file^.opened_for_put := (pfc$shorten IN fetch_access [2].
          access_mode) OR (pfc$append IN fetch_access [2].access_mode) OR
          (pfc$modify IN fetch_access [2].access_mode);

{  Sign on to the memory link.

  /loop_1/
    WHILE TRUE DO
      mlp$sign_on (mlc$null_name, 1, icf_file^.application_name, stat);

      IF (stat.normal) OR (stat.condition = mlc$ok) THEN
        EXIT /loop_1/;
      ELSE
        CASE stat.condition OF
        = mlc$busy_interlock, mlc$pool_buffer_not_avail =
          pmp$wait (icf_short_interval, icf_short_interval);
          CYCLE /loop_1/;
        ELSE
          icp$set_status_abnormal (stat);
          pmp$exit (stat);
        CASEND;
      IFEND;
    WHILEND /loop_1/;

{  Start the 170 partner job.

    icp$read_cv (fetch_access [1].user_info, clvar, stat);
    IF NOT stat.normal THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ice$no_job_spec_variable, operation, fetch_access [1].user_info,
            status);
      RETURN;
    IFEND;
    icp$get_next_cv (ptr, clvar, len);
    IF (ptr = NIL) OR (len = 0) THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ice$empty_job_spec_variable, operation, '', status);
      RETURN;
    IFEND;
    z_rec_length := icc$max_partner_image_length - icc$validation_image_length;

{ Convert all validation info to a 170 display code string
    icp$convert (ptr, len, ^validation_information.job, z_rec_index, 10, stat);
    rhp$get_link_user_descriptor (liu_stuff, stat);
    ptr := ^liu_stuff.user;
    icp$convert (ptr, 9, ^validation_information.user_name, z_rec_index, 2,
          stat);
    ptr := ^liu_stuff.password;
    icp$convert (ptr, 31, ^validation_information.password, z_rec_index, 4,
          stat);
    ptr := ^liu_stuff.family;
    icp$convert (ptr, 9, ^validation_information.family_name, z_rec_index, 2,
          stat);
    ptr := ^liu_stuff.charge;
    icp$convert (ptr, 31, ^validation_information.charge_number, z_rec_index,
          4, stat);
    ptr := ^liu_stuff.project;
    icp$convert (ptr, 31, ^validation_information.project_number, z_rec_index,
          4, stat);
    PUSH get_attribute_p: [1 .. 4];
    get_attribute_p^ [1].key := jmc$login_family;
    get_attribute_p^ [2].key := jmc$login_user;
    get_attribute_p^ [3].key := jmc$login_account;
    get_attribute_p^ [4].key := jmc$login_project;
    jmp$get_job_attributes (get_attribute_p, stat);

    IF NOT stat.normal THEN
      pmp$exit (stat);
    IFEND;

{ We also need to convert the original login USER, FAMILY, ACCOUNT, and
{ PROJECT.
    ptr := ^get_attribute_p^ [2].login_user;
    icp$convert (ptr, 9, ^validation_information.original_user_name,
          z_rec_index, 2, stat);
    ptr := ^get_attribute_p^ [1].login_family;
    icp$convert (ptr, 9, ^validation_information.original_family_name,
          z_rec_index, 2, stat);
    ptr := ^get_attribute_p^ [3].login_account;
    icp$convert (ptr, 31, ^validation_information.original_charge_number,
          z_rec_index, 4, stat);
    ptr := ^get_attribute_p^ [4].login_project;
    icp$convert (ptr, 31, ^validation_information.original_project_number,
          z_rec_index, 4, stat);
    z_rec := ^rec;
    stat.normal := TRUE;
    icp$get_next_cv (ptr, clvar, len);
    nos_card_counter := 1;
    WHILE (ptr <> NIL) AND (stat.normal) DO
      icp$convert (ptr, len, z_rec, z_rec_index, z_rec_length, stat);
      z_rec := i#ptr (z_rec_index * 8, z_rec);
      z_rec_length := z_rec_length - z_rec_index;
      icp$get_next_cv (ptr, clvar, len);
      nos_card_counter := nos_card_counter + 1;
    WHILEND;
    IF NOT stat.normal THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ice$partner_job_too_long, operation, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            nos_card_counter, 10, FALSE, status);
      RETURN;
    IFEND;
    z_rec_length := z_rec_length + icc$validation_image_length;
    icp$initiate_partner_job ((icc$max_partner_image_length - z_rec_length),
          ^rec, 1, ^icf_file^.application_name, icc$validation_image_length,
          ^validation_information, icf_file^.partner_id, stat);
    IF NOT stat.normal THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ice$partner_cannot_be_started, operation, '', status);
      RETURN;
    IFEND;

{  Permit the 170 partner job to send to us.

  /loop_2/
    WHILE TRUE DO
      mlp$add_sender (icf_file^.application_name,
            icf_file^.partner_id.application_name, stat);

      IF (stat.normal) OR (stat.condition = mlc$ok) OR
            (stat.condition = mlc$receiver_not_signed_on) THEN
        EXIT /loop_2/;
      ELSE
        CASE stat.condition OF
        = mlc$busy_interlock =
          pmp$wait (icf_short_interval, icf_short_interval);
          CYCLE /loop_2/;
        ELSE
          icp$set_status_abnormal (stat);
          pmp$exit (stat);
        CASEND;
      IFEND;
    WHILEND /loop_2/;

  PROCEND icp$open;
MODEND icm$open;
*DECK DECK=ICM$PARTNER_JOB_EXEC_REAL EXPAND=TRUE

  ?VAR
    icv$fake_out_madify: boolean := FALSE?;

*copyc OSD$DEFAULT_PRAGMATS
  MODULE icm$partner_job_exec_real;

{ Select target 170 operating system.
*IF ($string($name(wev$target_operating_system))='NOS')

  ?VAR icv$nos_be: boolean := FALSE ?;
*ELSE

  ?VAR icv$nos_be: boolean := TRUE ?;
*IFEND

?? PUSH (LISTEXT := ON) ??
    ?IF icv$fake_out_madify = TRUE THEN
*copy OST$STATUS
*copyc OSV$TASK_PRIVATE_HEAP
    ?IFEND

*copy OST$STRING

    TYPE
      ost$status = record
        condition: mlt$status,
      recend;

    TYPE
      ost$status_condition = 0 .. 999999;

*copyc BIZCLOS
*copyc BIZOPEN
*copyc BIZPUT
*copyc BIZWEOR
*copyc LGZOPEN
*copyc LGZCLOS
*copyc LGZGET
*copyc LGZPUT
*copyc LGZCODE
*copyc FZMARK
*copyc ICT$PARTNER_MESSAGES
*copyc ICP$ACQUIRE_FROM_NOS_QUEUE
*copyc ICP$ROUTE_TO_NOS_INPUT_QUEUE
*copyc MLP$ADD_SENDER
*copyc MLP$CREATE_JOB_ENTRY
*copyc MLP$DELETE_JOB_ENTRY
*copyc MLP$FORCE_JOB_SIGN_OFF
*copyc MLP$FIND_SIGNED_ON_JOB
*copyc mld$jsn
*copyc MLP$LOCATE_FREE_JOB_ENTRY
*copyc MLP$RECEIVE_MESSAGE
*copyc MLP$SEND_MESSAGE
*copyc MLP$SIGN_OFF
*copyc MLP$SIGN_ON
*copyc MLP$TERMINATE_SIGNED_ON_JOB
*copyc ZN7PMSG
*copyc ZUTPS2D
*copyc ZOSTSTR
*copyc ZUTPD2S
*copyc ZUTPDNS
*copyc ZUTPSDN
?? POP ??

?? OLDTITLE, NEWTITLE := 'TYPE DECLARATIONS', EJECT ??

    TYPE

      ict$mli_status = set of mlt$status,

      ict$operating_states = (initialize_flags, signon, addspl,
        wait_for_request, send_response),

      ict$ra_word_0 = packed record
        fill1: 0 .. 0ffffffffff(16),
        fill2: 0 .. 01f(16),
        cfo,
        idledown,
        pause,
        sw6,
        sw5,
        sw4,
        sw3,
        sw2,
        sw1: boolean,
        fill3: 0 .. 03f(16),
      recend,

      ict$job_name_to_jsn = packed record
        pad1: 0 .. 3ffff(16),
        first_four_char: 0 .. 0ffffff(16),
        last_three_char: 0 .. 3ffff(16),
      recend,

      ict$be_job_name_to_jsn = packed record
        pad1: 0 .. 3ffff(16),
        last_seven_chars: 0 .. 3ffffffffff(16),
      recend,

      ict$pj_exec_failure = (signon_failed, addspl_failed, receive_failed,
        arbinfo_failure, send_failed, okee_dokee),

      dc_validation_information_type = record
        job_info: array[1..10] of packed array[0..9] of 0..3f(16),
        user_name: array[1..2] of packed array[0..9] of 0..3f(16),
        family_name: array [1..2] of packed array[0..9] of 0..3f(16),
        password: array[1..4] of packed array[0..9] of 0..3f(16),
        charge_number: array[1..4] of packed array[0..9] of 0..3f(16),
        project_number: array[1..4] of packed array[0..9] of 0..3f(16),

{ The following are the NOS/VE login attributes of the user who is trying
{ to use the command.  These attributes are put in so a site can validate
{ a user to use Interstate Communications.
        original_user_name: array[1..2] of packed array[0..9] of 0..3f(16),
        original_family_name: array [1..2] of packed array[0..9] of 0..3f(16),
        original_charge_number: array[1..4] of packed array[0..9] of 0..3f(16),
        original_project_number: array[1..4] of packed array[0..9] of 0..3f(16),
      recend,
      job_validation_info_type = record
        job_info: string(78),
        user_name: string(9),
        password: string(31),
        family_name: string (9),
        charge_number: string(31),
        project_number: string(31),
        original_user_name: string(9),
        original_family_name: string (9),
        original_charge_number: string(31),
        original_project_number: string(31),
      recend;
?? OLDTITLE, NEWTITLE := 'STATIC VARIABLES', EJECT ??

    VAR
      current_state: ict$operating_states := initialize_flags,
      status: ost$status, { special definition for A170 modules }
      mli_retry_status: ict$mli_status := $ict$mli_status [mlc$busy_interlock,
        mlc$pool_buffer_not_avail, mlc$prior_msg_not_received,
        mlc$receive_list_full, mlc$receive_list_index_invalid],
      mli_ignore_status: ict$mli_status := $ict$mli_status
        [mlc$dup_permits_ignored, mlc$msgs_from_sender_queued, mlc$ok,
        mlc$queued_msgs_lost, mlc$signal_failed_ignored,
        mlc$signal_to_c170_ignored],
      mli_fatal_status: ict$mli_status := $ict$mli_status [mlc$ant_full,
        mlc$bad_c170_parameter, mlc$c170_c170_illegal, mlc$illegal_function,
        mlc$max_msgs_too_large, mlc$max_signons_this_appl,
        mlc$max_signons_this_task, mlc$message_too_long,
        mlc$mli_internal_error, mlc$nosve_not_up, mlc$permit_list_full,
        mlc$receiver_name_syntax_error, mlc$sender_name_syntax_error,
        mlc$system_name_no_match, mlc$message_truncated,
        mlc$receiver_not_signed_on, mlc$sender_not_permitted,
        mlc$sender_not_signed_on],
      abort: ict$pj_exec_failure := okee_dokee,
      length_returned: mlt$message_length,
      nosve_application: mlt$application_name,
      msg: ict$general_message,
      pj_exec_debug: BOOLEAN,
      ra_word_0: ict$ra_word_0,
      substitute_card_size: integer,
      signal_record: mlt$signal_record := [0, * , * ],
      signal: mlt$signal := ^signal_record,
      unique: mlt$application_name,
      arbinfo: mlt$arbitrary_info,
      mli_terminate_status: mlt$terminate_status,
      entry_located: boolean,
      job_unique_id: mlt$partner_job_unique_id,
      create_status: mlt$create_status,
      find_status: mlt$find_status,
      delete_status: mlt$delete_status,
      forced_sign_off_status: mlt$forced_sign_off_status,
      initiate_request_ptr: ^ict$initiate_partner_request,
      status_request_ptr: ^ict$status_partner_request,
      terminate_request_ptr: ^ict$terminate_partner_request,
      delete_request_ptr: ^ict$delete_partner_request,
      initiate_response: ict$initiate_partner_response,
      status_response: ict$status_partner_response,
      terminate_response: ict$terminate_partner_response,
      delete_response: ict$delete_partner_response,
      partner_job_file: file,
      skeleton_file: file,
      partner_job_name: ict$partner_job_name,
      job_name_to_jsn_ptr: ^ict$job_name_to_jsn,
      be_job_name: mlt$partner_job_unique_id,
      be_job_name_to_jsn_ptr: ^ict$be_job_name_to_jsn,
      route_status: ict$route_partner_status,
      queue_status: ict$partner_queue_status;

?? OLDTITLE, NEWTITLE := 'CONSTANT DECLARATIONS', EJECT ??

    CONST
      partner_job_file_name = 'icpjfil',
      partner_job_dc_file_name = 11032012061114(8),    { ICPJFIL }
      acct_skeleton_file_name = 'icaccnt',
      job_dayfile = 3;

?? OLDTITLE, NEWTITLE := 'EXTERNAL REFERENCES', EJECT ??

    PROCEDURE [XREF] getword (address: integer;
          word: ^cell);

    PROCEDURE [XREF] pause (time: integer);

    VAR
      mlv$terminate: [XREF] boolean,
      mlv$fatal_error: [XREF] boolean;

?? OLDTITLE, NEWTITLE := 'PROCEDURE log', EJECT ??

{ The purpose of this routine is to issue a dayfile message.

    PROCEDURE log (message: string ( * );
          dayfile: 0 .. 7;
          force: boolean);

      VAR
        display_code_string: array [1 .. 8] of packed array [0 .. 9] of 0 .. 3f(16),
        display_code_in_words: integer,
        display_code_in_characters: 0 .. 9,
        result_length: ost$string_index,
        end_of_line: boolean;

      IF (NOT pj_exec_debug) AND (dayfile = job_dayfile) AND (NOT force) THEN
        RETURN;
      IFEND;
      result_length := 1;
      display_code_in_words := 1;
      display_code_in_characters := 0;
      end_of_line := TRUE;
      utp$convert_string_to_dc_string (utc$ascii64, display_code_string, display_code_in_words,
            display_code_in_characters, message, result_length, end_of_line);
      n7p$issue_dayfile_message (#LOC (display_code_string), dayfile);

    PROCEND log;
?? OLDTITLE, NEWTITLE := 'PROCEDURE log_vrbl', EJECT ??

{ The purpose of this routine is to issue a dayfile message with a
{ variable value appended to it.

    PROCEDURE log_vrbl (message: string ( * );
          value: integer;
          dayfile: 0 .. 7;
          force: boolean);

      VAR
        new_string: ^string ( * ),
        new_string_length,
        string_length: integer;

      string_length := STRLENGTH (message);
      PUSH new_string: [string_length + 10];
      new_string^ (1, string_length) := message (1, string_length);
      new_string^ (string_length + 1, 10) := '          ';
      STRINGREP (new_string^ (string_length + 1, 10), new_string_length, value);
      log (new_string^, dayfile, force);

    PROCEND log_vrbl;

?? OLDTITLE, NEWTITLE := 'PROCEDURE dump', EJECT ??
    PROCEDURE dump (abort: ict$pj_exec_failure;
          error_status: ^cell;
          error_length: integer);

      CONST
        ordinal_size_of_word = 15;

      VAR
        new_error_status: ^packed array [1 .. 100] of packed array [1 .. ordinal_size_of_word] of 0 .. 15,
        size_limit,
        ordinal_char,
        number_of_ordinal_words,
        number_of_ordinal_chars: integer,
        message: string (17);

      log_vrbl (' hex data for pj_exec condition =', ORD (abort), job_dayfile,
            TRUE);
      message := ' ';
      new_error_status := error_status;
      size_limit := error_length;
      IF size_limit > 100 THEN
        size_limit := 100;
      IFEND;
      FOR number_of_ordinal_words := 1 TO size_limit DO
        FOR number_of_ordinal_chars := 1 TO ordinal_size_of_word DO
          ordinal_char := new_error_status^ [number_of_ordinal_words] [number_of_ordinal_chars];
          IF ordinal_char > 9 THEN
            ordinal_char := ordinal_char + 37(16);
          ELSE
            ordinal_char := ordinal_char + 30(16);
          IFEND;
          message (number_of_ordinal_chars + 1) := CHR (ordinal_char);
        FOREND;
        log (message, job_dayfile, TRUE);
      FOREND;

    PROCEND dump;
?? OLDTITLE, NEWTITLE := 'PROCEDURE route_partner_job', EJECT ??
    PROCEDURE route_partner_job (file_name: ict$nos_file_name;
      VAR partner_job_name: ict$partner_job_name;
      VAR route_status: ict$route_partner_status);

      VAR
        routepb: ict$route_parameter_block,
        routepb_init: [STATIC] ict$route_parameter_block := [0, 0, FALSE,
          0, 0, FALSE, 0, input_flags, in_disposition_code, 0, FALSE, 0, [TRUE, 0, FALSE,
          FALSE, 0, TRUE, 0, TRUE, FALSE, FALSE, FALSE, 0, FALSE, TRUE, FALSE, FALSE, TRUE,
          FALSE], 0, 0, 0, FALSE, 0, 0, 0, 0, 0, 0, 0, 0, 0],
        error_code_length: 1 .. 2;

      routepb := routepb_init;
      routepb.lfn := file_name;
      ? IF icv$nos_be = FALSE THEN
        routepb.f := TRUE;
        routepb.ot := local_batch_origin_type;
      ? ELSE
        routepb.flags.file_ident_specified := TRUE;
        routepb.flags.priority := TRUE;
        routepb.b := TRUE;
        routepb.priority := nosbe_priority;
      ? IFEND
      icp$route_to_nos_input_queue (routepb);
      log_vrbl (' route status ', routepb.ec, job_dayfile, FALSE);
      IF routepb.ec = 0 THEN
        partner_job_name := routepb.lfn;
        route_status := icc$partner_route_ok;
      ELSE
        route_status := icc$partner_route_failed;
      IFEND;

    PROCEND route_partner_job;
?? OLDTITLE, NEWTITLE := 'PROCEDURE find_partner_queue', EJECT ??
    PROCEDURE find_partner_queue (partner_job_name: ict$partner_job_name;
      VAR queue_status: ict$partner_queue_status);

    ? IF icv$nos_be = FALSE THEN
      VAR
        qacpb: [STATIC] ict$qac_parameter_block := [0, 0, 0, FALSE, 0, 0, NIL,
          0, NIL, 0, NIL, 0, 0, 0, 0, NIL, * , * , 0, 0, FALSE, 0, 0, FALSE,
          FALSE, 0, 0, 0, 0, 0, * , * , * , 0, 0, * , * , * , * ];

      qacpb.fcn := qac_peek_function_code;
      qacpb.complete_bit := FALSE;
      qacpb.request_block_length := peek_request_length;
      qacpb.ordinal := 0;
      qacpb.queue := 0;
      qacpb.jsn := partner_job_name;
      qacpb.jsn_option := TRUE;
      qacpb.input_queue_flag := TRUE;
      qacpb.execution_queue_flag := TRUE;
      qacpb.link_addr := 0;
      qacpb.first := #LOC (qacpb.fill13);
      qacpb.inn := qacpb.first;
      qacpb.out := qacpb.first;
      qacpb.limit := #LOC (qacpb.fill14);
{ First, in, out, and limit must be legitimate even tho unused by QAC

      icp$acquire_from_nos_queue (qacpb);
      log_vrbl (' acquire input status ', qacpb.err, job_dayfile, FALSE);
      log_vrbl (' incnt ', qacpb.incnt, job_dayfile, FALSE);
      log_vrbl (' excnt ', qacpb.excnt, job_dayfile, FALSE);

      IF qacpb.incnt <> 0 THEN
        queue_status := icc$partner_queue_input;
      ELSEIF qacpb.excnt <> 0 THEN
          queue_status := icc$partner_queue_executing;
      ELSE
        queue_status := icc$partner_not_in_queues;
      IFEND;
    ? ELSE
      VAR
        qafpbi: [STATIC] ict$qaf_parameter_block := [0, 0, [0, TRUE, FALSE,
          FALSE, FALSE, TRUE], qaf_count_function_code, FALSE, 0, 0, 0, 0, 0,
          0, 0, 0, 0, 0, 0],
        qafpb: ict$qaf_parameter_block;

      qafpb := qafpbi;
      qafpb.partner_job_name := partner_job_name;
      icp$acquire_from_nos_queue (qafpb);
      log_vrbl (' acquire input status ', qafpb.err, job_dayfile, FALSE);
      log_vrbl (' incnt ', qafpb.incnt, job_dayfile, FALSE);
      log_vrbl (' excnt ', qafpb.excnt, job_dayfile, FALSE);

      IF qafpb.incnt <> 0 THEN
        queue_status := icc$partner_queue_input;
      ELSEIF qafpb.excnt <> 0 THEN
        queue_status := icc$partner_queue_executing;
      ELSE
        queue_status := icc$partner_not_in_queues;
      IFEND;
    ? IFEND

    PROCEND find_partner_queue;
{ ICP$SUB_SKEL_PARMS
{
{        The purpose of this procedure is to substitute keywords with their
{  actual value and return a new card with the substituted values.
{
{       ICP$SUB_SKEL_PARMS (JOB_VALIDATION_INFO, SKELETON_CARD, SUBSTITUTE_CARD);
{
{ JOB_VALIDATION_INFO: (Input) This parameter contains all accounting
{       information needed for substitution on the skeleton card.
{
{ SKELETON_CARD: (Input) This parameter contains one skeleton record from
{       the skeleton file (Created at deadstart time with the name ICACCNT).
{
{ SUBSTITUTE_CARD: (Output) This parameter returns a copy of the skeleton
{       record with values substituted for the keywords.

    PROCEDURE icp$sub_skel_parms (
       job_validation_info: job_validation_info_type;
       skeleton_card: string (140);
       VAR substitute_card: string (140));

? IF icv$nos_be = FALSE THEN
    TYPE

      valid_family_info_rec = packed record
        family_name: 0 .. 3ffffffffff(16),
        filler1: 0 .. 3f(16),
        reply_code: 0 .. 0fff(16),
      recend,

      perm_file_info_rec = packed record
        family_name: 0 .. 3ffffffffff(16),
        zero: 0 .. 3ffff(16),
        filler1: integer,
        user_name: 0 .. 3ffffffffff(16),
        filler2: 0 .. 3ffff(16),
      recend;


  PROCEDURE [XREF] rhpgpfp (VAR perm_file_info: perm_file_info_rec);

  PROCEDURE [XREF] rhpvfam (VAR valid_family_info: valid_family_info_rec);
?IFEND

    CONST
      max_string_length = 140,
      invalid_family = 7777(8),
      skel_job = 'JOB',
      skel_user = 'USER',
      skel_password = 'PASSWORD',
      skel_family = 'FAMILY',
      skel_charge = 'CHARGE',
      skel_project = 'PROJECT',
      skel_orig_user = 'ORGUSER',
      skel_orig_family = 'ORGFAMILY',
      skel_orig_charge = 'ORGCHARGE',
      skel_orig_project = 'ORGPROJECT';

    VAR
      keyword_length: 0 .. 10,
      max_replacement_length: 1 .. 78,
      keyword_sub: string (78),
      name_string: string (31),
      in_buff_lngth: integer,
      out_buff_lngth: integer,
? IF icv$nos_be = FALSE THEN
      perm_file_info: perm_file_info_rec,
      valid_family_info: valid_family_info_rec,
      dc_family_name: utt$dc_name,
      result_length: 0 .. 7,
? IFEND
      replacement_length: 1 .. 78;
?? OLDTITLE, NEWTITLE := 'PROCEDURE icp$sub_skel_parms', EJECT ??

{ Replace keyword and copy to output buffer.  The SKELETON_CARD
{ parameter is the input buffer and the SUBSTITUTE_CARD parameter
{ is the output buffer.

    keyword_sub := ' ';
    in_buff_lngth := 1;
    out_buff_lngth :=1;
    substitute_card := ' ';
    REPEAT
      IF (skeleton_card (in_buff_lngth, 1) = '&') THEN

{  If input buffer has an '&', then replace the value of the
{  attribute specified into the job template.
        IF (skeleton_card (in_buff_lngth+1, 3) = skel_job) THEN
          keyword_sub := job_validation_info.job_info;
          max_replacement_length := 78;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 3;
        ELSEIF (skeleton_card (in_buff_lngth+1, 4) = skel_user) THEN

          keyword_sub := job_validation_info.user_name;
          max_replacement_length := 9;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 4;
        ELSEIF (skeleton_card (in_buff_lngth+1, 8) = skel_password) THEN

          keyword_sub := job_validation_info.password;
          max_replacement_length := 31;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 8;
        ELSEIF (skeleton_card (in_buff_lngth+1, 6) = skel_family) THEN

? IF icv$nos_be = FALSE THEN
          utp$convert_string_to_dc_name(job_validation_info.family_name (1,7),
              dc_family_name);

{ Validate that the family exists on NOS.  If it does not then use
{ the default NOS family that the IRHF170 job runs under.

          valid_family_info.family_name := dc_family_name;
          valid_family_info.filler1 := 0;
          valid_family_info.reply_code := 0;
          rhpvfam (valid_family_info);
          IF valid_family_info.reply_code = invalid_family THEN

{ The family does not exist on NOS, get the default NOS family.

            rhpgpfp (perm_file_info); { get default family and user }
            utp$convert_dc_name_to_string (perm_file_info.family_name,
                keyword_sub (1,7), result_length);
          ELSE  { family was valid on NOS. }
            utp$convert_dc_name_to_string (dc_family_name,
                keyword_sub (1,7), result_length);
          IFEND;
          max_replacement_length := 7;
? ELSE
          keyword_sub := job_validation_info.family_name;
          max_replacement_length := 9;
? IFEND
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 6;
        ELSEIF (skeleton_card (in_buff_lngth+1,6) = skel_charge) THEN

{ Use only login charge numbers that are alpha-numberic.
          create_valid_170_string (job_validation_info.charge_number,
              keyword_sub);
? IF icv$nos_be = FALSE THEN
          IF job_validation_info.charge_number = ' ' THEN
            keyword_sub := '*.';
          IFEND;
? IFEND
          max_replacement_length := 31;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 6;
        ELSEIF (skeleton_card (in_buff_lngth+1,7) = skel_project) THEN

{ Use only login project numbers that are alpha-numberic.
          create_valid_170_string (job_validation_info.project_number,
              keyword_sub);
          max_replacement_length := 31;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 7;
        ELSEIF (skeleton_card (in_buff_lngth+1,7) = skel_orig_user) THEN

{ Use only login user names that are alpha-numberic.  This is used for the
{ $SYSTEM user (entering a dual state command from the NOS/VE console.
          name_string (1,9) := job_validation_info.original_user_name;
          create_valid_170_string (name_string, keyword_sub);
          max_replacement_length := 9;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 7;
        ELSEIF (skeleton_card (in_buff_lngth+1,9) = skel_orig_family) THEN

{ Use only login family names that are alpha-numberic.  This is used for the
{ $SYSTEM family (entering a dual state command from the NOS/VE console.
          name_string (1,9) := job_validation_info.original_family_name;
          create_valid_170_string (name_string, keyword_sub);
          max_replacement_length := 9;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 9;
        ELSEIF (skeleton_card (in_buff_lngth+1,9) = skel_orig_charge) THEN

{ Use only login charge numbers that are alpha-numberic.
          create_valid_170_string (job_validation_info.original_charge_number,
              keyword_sub);
? IF icv$nos_be = FALSE THEN
          IF job_validation_info.original_charge_number = ' ' THEN
            keyword_sub := '*.';
          IFEND;
? IFEND
          max_replacement_length := 31;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 9;
        ELSEIF (skeleton_card (in_buff_lngth+1,10) = skel_orig_project) THEN

{ Use only login project numbers that are alpha-numberic.
          create_valid_170_string (job_validation_info.original_project_number,
              keyword_sub);
          max_replacement_length := 31;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 10;
        ELSE  { the '&' is not followed by a defined keyword, leave it on the command line.
          substitute_card (out_buff_lngth, 1) := skeleton_card (in_buff_lngth, 1);
          replacement_length := 1;
          keyword_length := 0;

        IFEND;
        out_buff_lngth := out_buff_lngth + replacement_length;
        in_buff_lngth := in_buff_lngth + keyword_length + 1;
        keyword_sub := ' ';
      ELSE
        substitute_card (out_buff_lngth, 1) := skeleton_card (in_buff_lngth, 1);
        in_buff_lngth := in_buff_lngth + 1;
        out_buff_lngth := out_buff_lngth + 1;
      IFEND;

    UNTIL (out_buff_lngth > max_string_length) OR (in_buff_lngth > max_string_length); {sub_keyword}

    IF NOT (out_buff_lngth > max_string_length) THEN

{ Set the remaining parts of the command card to blank.
      substitute_card (out_buff_lngth, max_string_length - out_buff_lngth + 1)  := ' ';
    IFEND;

  PROCEND icp$sub_skel_parms;
?? OLDTITLE, NEWTITLE := 'PROCEDURE substitute_keyword', EJECT ??

{ SUBSTITUTE_KEYWORD
{
{        This procedure will substitute a given value for the keyword
{ in an output buffer.
{
{        SUBSTITUTE_KEYWORD (SUBSTITUTE_CARD, REPLACEMENT_LENGTH
{             OUT_BUFF_LNGTH, MAX_REPLACEMENT_LENGTH, KEYWORD_SUB)
{
{ SUBSTITUTE_CARD: (Output) This parameter returns a copy of the input buffer
{
{ REPLACEMENT_LENGTH: (Output) This parameter returns the length of the replacement string.
{
{ OUT_BUFF_LNGTH: (Input) This parameter is the current size of the output buffer.
{
{ MAX_REPLACEMENT_LENGTH: (Input) This parameter is the size of the field to be replaced.
{
{ KEYWORD_SUB: (Input) This parameter is what is replaced into the output
{       buffer.
{
  PROCEDURE substitute_keyword
       (VAR substitute_card: string (140);
       VAR replacement_length: 1 .. 78;
       out_buff_lngth: integer;
       max_replacement_length: 1 .. 78;
       keyword_sub: string(78));

    VAR index: 1 .. 78;

{ Calculate length of the replacement string.

      replacement_length := 1;
    /cal_replacement_lngth/
      FOR index := 1 to 78 DO
        IF keyword_sub (index, 1) <> ' ' THEN
          replacement_length := index;
        IFEND;
      FOREND /cal_replacement_lngth/;

{ Replace keyword and copy to output buffer.}

      substitute_card (out_buff_lngth, replacement_length) :=
          keyword_sub (1, replacement_length);

  PROCEND substitute_keyword;

?? OLDTITLE, NEWTITLE := 'PROCEDURE create_valid_170_string', EJECT ??

{ CREATE_VALID_170_STRING
{
{        This procedure will create a valid 170 string (delete all $ from
{ the passed parameter and put into the new string.  The only values that
{ will be changed are the charge number, project number, orignal user name,
{ original family name, original charge number, and original project number.
{
{        CREATE_VALID_170_STRING (KEYWORD_STRING, KEYWORD_SUB)
{
{ KEYWORD_STRING: (Input) This parameter is the value of the old string to be changed.
{
{ KEYWORD_SUB: (Output) This parameter is the value of the new string created.
{
  PROCEDURE create_valid_170_string (keyword_string: string (31);
      VAR keyword_sub: string (78));

    CONST max_keyword_string_size = 31;

    VAR keyword_sub_size,
        keyword_string_size: 1 .. max_keyword_string_size;

{ Use only strings that are alpha-numberic.
    keyword_sub := ' ';
    keyword_sub_size := 1;
    FOR keyword_string_size := 1 TO max_keyword_string_size DO
      IF ((keyword_string (keyword_string_size) >= 'A') AND
        (keyword_string (keyword_string_size) <= 'Z')) OR
        ((keyword_string (keyword_string_size) >= 'a') AND
        (keyword_string (keyword_string_size) <= 'z')) OR
        ((keyword_string (keyword_string_size) >= '0') AND
        (keyword_string (keyword_string_size) <= '9')) OR
? IF icv$nos_be THEN
        (keyword_string (keyword_string_size) = '=') OR
        (keyword_string (keyword_string_size) = ',') OR
        (keyword_string (keyword_string_size) = '.') OR
? IFEND
        (keyword_string (keyword_string_size) = '*') THEN
        keyword_sub (keyword_sub_size) := keyword_string (keyword_string_size);
        keyword_sub_size := keyword_sub_size + 1;
      IFEND;
    FOREND;

  PROCEND create_valid_170_string;
?? OLDTITLE, NEWTITLE := 'PROCEDURE create_job_validation_record', EJECT ??

{ CREATE_JOB_VALIDATION_RECORD
{
{        This procedure will create the job validation record used for
{ substitution into the Interstate Communications template file (ICACCNT).
{
{        CREATE_JOB_VALIDATION_RECORD (DC_VALIDATION_RECORD, JOB_VALIDATION_RECORD)
{
{ DC_VALIDATION_RECORD: (Input) This parameter has the values of the various
{       attributes that are replaced onto the partner job template file.
{
{ JOB_VALIDATION_RECORD: (Output) This parameter will contain the values of the various
{       attributes that are replaced onto the partner job template file.
{
  PROCEDURE create_job_validation_record (dc_validation_record: ^dc_validation_information_type;
       VAR job_validation_record: job_validation_info_type);

    VAR display_code_in_words: integer,
        display_code_in_chars: 0..9,
        result_length: ost$string_length,
        end_of_line: boolean;

    job_validation_record.job_info := ' ';
    job_validation_record.user_name := ' ';
    job_validation_record.password := ' ';
    job_validation_record.family_name := ' ';
    job_validation_record.charge_number := ' ';
    job_validation_record.project_number := ' ';
    job_validation_record.original_user_name := ' ';
    job_validation_record.original_family_name := ' ';
    job_validation_record.original_charge_number := ' ';
    job_validation_record.original_project_number := ' ';
    display_code_in_words := 1;
    display_code_in_chars := 0;
    utp$convert_dc_string_to_string(utc$ascii64, dc_validation_record^.job_info,
      display_code_in_words, display_code_in_chars, job_validation_record.job_info,
      result_length, end_of_line);
    display_code_in_words := 1;
    display_code_in_chars := 0;
    utp$convert_dc_string_to_string(utc$ascii64, dc_validation_record^.user_name,
      display_code_in_words, display_code_in_chars, job_validation_record.user_name,
      result_length, end_of_line);
    display_code_in_words := 1;
    display_code_in_chars := 0;
    utp$convert_dc_string_to_string(utc$ascii64, dc_validation_record^.password,
      display_code_in_words, display_code_in_chars, job_validation_record.password,
      result_length, end_of_line);
    display_code_in_words := 1;
    display_code_in_chars := 0;
    utp$convert_dc_string_to_string (utc$ascii64, dc_validation_record^.family_name,
      display_code_in_words, display_code_in_chars, job_validation_record.family_name,
      result_length, end_of_line);
    display_code_in_words := 1;
    display_code_in_chars := 0;
    utp$convert_dc_string_to_string(utc$ascii64, dc_validation_record^.charge_number,
      display_code_in_words, display_code_in_chars, job_validation_record.charge_number,
      result_length, end_of_line);
    display_code_in_words := 1;
    display_code_in_chars := 0;
    utp$convert_dc_string_to_string(utc$ascii64, dc_validation_record^.project_number,
      display_code_in_words, display_code_in_chars, job_validation_record.project_number,
      result_length, end_of_line);
    display_code_in_words := 1;
    display_code_in_chars := 0;
    utp$convert_dc_string_to_string(utc$ascii64, dc_validation_record^.original_user_name,
      display_code_in_words, display_code_in_chars, job_validation_record.original_user_name,
      result_length, end_of_line);
    display_code_in_words := 1;
    display_code_in_chars := 0;
    utp$convert_dc_string_to_string(utc$ascii64, dc_validation_record^.original_family_name,
      display_code_in_words, display_code_in_chars, job_validation_record.original_family_name,
      result_length, end_of_line);
    display_code_in_words := 1;
    display_code_in_chars := 0;
    utp$convert_dc_string_to_string(utc$ascii64, dc_validation_record^.original_charge_number,
      display_code_in_words, display_code_in_chars, job_validation_record.original_charge_number,
      result_length, end_of_line);
    display_code_in_words := 1;
    display_code_in_chars := 0;
    utp$convert_dc_string_to_string(utc$ascii64, dc_validation_record^.original_project_number,
      display_code_in_words, display_code_in_chars, job_validation_record.original_project_number,
      result_length, end_of_line);

  PROCEND create_job_validation_record;
?? OLDTITLE, NEWTITLE := 'PROCEDURE icp$partner_job_exec_real', EJECT ??

    PROCEDURE [XDCL] icp$partner_job_exec_real ALIAS 'icppjer';
      VAR
        dc_validation_information: ^dc_validation_information_type,
        job_validation_record: job_validation_info_type,
        skeleton_card: string(140),
        substitute_card: string(140),
        card_length: integer,
        file_mark_returned: file_mark;

      CASE current_state OF

{ Initialize debug flags.
      = initialize_flags =
        getword (0, #LOC (ra_word_0));
        pj_exec_debug := ra_word_0.sw2;

{ Sign on to the Memory Link.

      = signon =
        mlp$sign_on (icc$pj_exec_application_name, 1, unique, status);
        IF status.condition = mlc$nosve_not_up THEN
          mlv$terminate := TRUE;
          RETURN;
        IFEND;
        IF status.condition IN mli_retry_status THEN
          RETURN;
        IFEND;
        IF status.condition = mlc$nosve_not_up THEN
          mlv$terminate := TRUE;
          RETURN;
        IFEND;
        IF status.condition IN mli_fatal_status THEN
          abort := signon_failed;
          dump (abort, #LOC (status), #SIZE (status));
          RETURN;
        IFEND;

{ Permit any application to send to us.

      = addspl =
        mlp$add_sender (icc$pj_exec_application_name, mlc$null_name, status);
        IF status.condition IN mli_retry_status THEN
          RETURN;
        IFEND;
        IF status.condition = mlc$nosve_not_up THEN
          mlv$terminate := TRUE;
          RETURN;
        IFEND;
        IF status.condition IN mli_fatal_status THEN
          abort := addspl_failed;
          dump (abort, #LOC (status), #SIZE (status));
          RETURN;
        IFEND;

{ Process partner job requests from NOS/VE.

      = wait_for_request =

        mlp$receive_message (icc$pj_exec_application_name, arbinfo, signal,
              #LOC (msg), length_returned, #SIZE (msg), 0, nosve_application,
              status);
        IF status.condition IN mli_retry_status THEN
          RETURN;
        IFEND;
        IF status.condition = mlc$nosve_not_up THEN
          mlv$terminate := TRUE;
          RETURN;
        IFEND;
        IF status.condition IN mli_fatal_status THEN
          abort := receive_failed;
          dump (abort, #LOC (status), #SIZE (status));
          RETURN;
        IFEND;

        CASE arbinfo OF

{ Initiate partner job request.

        = ORD (icc$initiate_partner_request) =

          mlp$locate_free_job_entry (entry_located);

          IF entry_located THEN

            initiate_request_ptr := #LOC (msg);
            dc_validation_information := #loc(initiate_request_ptr^.
              validation_image);
            create_job_validation_record (dc_validation_information,
                job_validation_record);

{ Open and read ICACCNT template file and put the information in the
{ partner job to be submitted.
            lg#open(skeleton_file,acct_skeleton_file_name,old#,input#,first#);
            request_queue_device (partner_job_dc_file_name);
            bi#open(partner_job_file,partner_job_file_name,new#,output#,first#);
            /job_card_loop/
            REPEAT
              skeleton_card := ' ';
              lg#get(skeleton_file,card_length,skeleton_card);
              f#mark(skeleton_file,file_mark_returned);
              IF file_mark_returned = data# THEN
                icp$sub_skel_parms(job_validation_record,skeleton_card,substitute_card);
                /find_string_size/
                FOR substitute_card_size := 140 DOWNTO 1 DO
                  IF substitute_card (substitute_card_size, 1) <> ' ' THEN
                    EXIT /find_string_size/;
                  IFEND;
                FOREND /find_string_size/;
                lg#put (partner_job_file, substitute_card(1,substitute_card_size));
              IFEND;
            UNTIL (file_mark_returned <> data#);

            bi#put (partner_job_file, #LOC (initiate_request_ptr^.partner_image [1]),
                  initiate_request_ptr^.commands_length);
            bi#weor (partner_job_file);
            bi#put (partner_job_file, #LOC (initiate_request_ptr^.partner_image
                  [initiate_request_ptr^.commands_length + 1]),
                  initiate_request_ptr^.data_length);
            bi#close (partner_job_file, first#);
            lg#close(skeleton_file,first#);

            route_partner_job (partner_job_dc_file_name, partner_job_name,
                  route_status);
            CASE route_status OF

            = icc$partner_route_ok =

              job_name_to_jsn_ptr := #LOC (partner_job_name);
              job_unique_id := job_name_to_jsn_ptr^.first_four_char;

? IF icv$nos_be = TRUE THEN
{ NOS/BE has seven character jsn's
              be_job_name_to_jsn_ptr := #LOC (partner_job_name);
              be_job_name := be_job_name_to_jsn_ptr^.last_seven_chars;
? IFEND;
{ The following shift ensures that a C170 application name is always different
{ from any C180 application name.

              initiate_response.partner_identification.application_name :=
                    job_unique_id *  4000(16);
? IF icv$nos_be = FALSE THEN
              initiate_response.partner_identification.job_name :=
                    job_unique_id;
? ELSE
              initiate_response.partner_identification.job_name :=
                    be_job_name;
? IFEND
              initiate_response.partner_identification.job_unique_id :=
                    job_unique_id;

              mlp$create_job_entry (job_unique_id, create_status, FALSE);
              IF create_status = mlc$job_entry_created_ok THEN
                initiate_response.initiate_status := ORD
                      (icc$partner_started_ok);
              ELSE
                initiate_response.initiate_status := ORD
                      (icc$partner_job_limit_exceeded);
              IFEND;

            = icc$partner_route_failed =

              initiate_response.initiate_status := ORD
                    (icc$partner_start_failed);

            ELSE

            CASEND;

          ELSE

            initiate_response.initiate_status := ORD
                  (icc$partner_job_limit_exceeded);

          IFEND;


{ Status partner job request.

        = ORD (icc$status_partner_request) =

          status_request_ptr := #LOC (msg);

          mlp$find_signed_on_job (status_request_ptr^.partner_identification.
                job_unique_id, find_status);

          IF find_status = mlc$job_signed_on THEN

            status_response.partner_status := ORD (icc$partner_signed_on);

          ELSE

            find_partner_queue (status_request_ptr^.partner_identification.
                  job_name, queue_status);

            CASE queue_status OF

            = icc$partner_queue_input =
              status_response.partner_status := ORD
                    (icc$partner_in_input_queue);

            = icc$partner_queue_executing =
              status_response.partner_status := ORD
                    (icc$partner_not_signed_on);

            = icc$partner_not_in_queues =
              status_response.partner_status := ORD (icc$partner_not_found);

            ELSE

            CASEND;

          IFEND;


{ Terminate partner job request.

        = ORD (icc$terminate_partner_request) =

          terminate_request_ptr := #LOC (msg);

          mlp$find_signed_on_job (terminate_request_ptr^.
                partner_identification.job_unique_id, find_status);

          IF find_status = mlc$job_signed_on THEN

            mlp$terminate_signed_on_job (terminate_request_ptr^.
                  partner_identification.job_unique_id, mli_terminate_status);
            IF mli_terminate_status = mlc$job_terminated THEN
              terminate_response.terminate_status := ORD
                    (icc$partner_terminated_ok);
            ELSE
              terminate_response.terminate_status := ORD
                    (icc$no_term_not_found);
            IFEND;

          ELSE

            find_partner_queue (terminate_request_ptr^.partner_identification.
                  job_name, queue_status);

            CASE queue_status OF

            = icc$partner_queue_input =
              terminate_response.terminate_status := ORD
                    (icc$no_term_in_input_queue);

            = icc$partner_queue_executing =
              terminate_response.terminate_status := ORD
                    (icc$no_term_not_signed_on);

            = icc$partner_not_in_queues =
              terminate_response.terminate_status := ORD
                    (icc$no_term_not_found);

            ELSE

            CASEND;

          IFEND;


{ Delete partner job request.

        = ORD (icc$delete_partner_request) =

          delete_request_ptr := #LOC (msg);

          mlp$delete_job_entry (delete_request_ptr^.partner_identification.
                job_unique_id, delete_status);

          IF delete_status = mlc$job_entry_deleted_ok THEN
            delete_response.delete_status := ORD (icc$partner_deleted_ok);
          ELSE
            delete_response.delete_status := ORD (icc$no_delete_not_found);
          IFEND;


        ELSE

        CASEND;

      = send_response =
        CASE arbinfo OF
        = ORD (icc$initiate_partner_request) =
          mlp$send_message (icc$pj_exec_application_name, ORD
                (icc$initiate_partner_response), signal, #LOC
                (initiate_response), #SIZE (initiate_response),
                nosve_application, status);

        = ORD (icc$status_partner_request) =

          mlp$send_message (icc$pj_exec_application_name, ORD
                (icc$status_partner_response), signal, #LOC (status_response),
                #SIZE (status_response), nosve_application, status);

        = ORD (icc$terminate_partner_request) =

          mlp$send_message (icc$pj_exec_application_name, ORD
                (icc$terminate_partner_response), signal, #LOC
                (terminate_response), #SIZE (terminate_response),
                nosve_application, status);

        = ORD (icc$delete_partner_request) =

          mlp$send_message (icc$pj_exec_application_name, ORD
                (icc$delete_partner_response), signal, #LOC (delete_response),
                #SIZE (delete_response), nosve_application, status);
        CASEND;
        IF status.condition IN mli_retry_status THEN
          RETURN;
        IFEND;
        IF status.condition = mlc$nosve_not_up THEN
          mlv$terminate := TRUE;
          RETURN;
        IFEND;
        IF status.condition IN mli_fatal_status THEN
          abort := send_failed;
          dump (abort, #LOC (status), #SIZE (status));
        IFEND;

        current_state := wait_for_request;
        RETURN;
      CASEND;

      current_state := SUCC (current_state);

    PROCEND icp$partner_job_exec_real;

  MODEND icm$partner_job_exec_real;
*DECK DECK=ICM$PARTNER_JOB_EXEC_VIRTUAL EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE icm$partner_job_exec_virtual;
?? TITLE := 'MODULE icm$partner_job_exec_virtual' ??

?? PUSH (LISTEXT := ON) ??
*copyc ICE$ERROR_CODES
*copyc ICF$OPEN_FILE_DESCRIPTOR
*copyc ICT$PARTNER_MESSAGES
*copyc ICP$PJ_ADD_SENDER
*copyc ICP$PJ_SIGN_OFF
*copyc ICP$PJ_SIGN_ON
*copyc ICP$RECEIVE_FROM_PJ_EXEC
*copyc ICP$REPORT_STATUS_ERROR
*copyc ICP$SEND_TO_PJ_EXEC
*copyc ICV$PJ_SIGNED_ON
*copyc IFE$ERROR_CODES
*copyc I#MOVE
*copyc OST$STATUS
*copyc OSP$APPEND_STATUS_INTEGER
*copyc OSP$DISESTABLISH_COND_HANDLER
*copyc OSP$ESTABLISH_CONDITION_HANDLER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$CONTINUE_TO_CAUSE
*copyc PMP$LONG_TERM_WAIT
?? POP ??
?? TITLE := 'PROCEDURE icp$initiate_partner_job', EJECT ??

  PROCEDURE [XDCL] icp$initiate_partner_job
    (    commands_length: ict$partner_commands_length;
         commands_pointer: ^cell;
         data_length: ict$partner_data_length;
         data_pointer: ^cell;
         validation_length: integer;
         validation_pointer: ^cell;
     VAR partner_identification: ict$partner_identification;
     VAR status: ost$status);

    VAR
      initiate_partner_request: ict$initiate_partner_request,
      initiate_partner_response: ict$initiate_partner_response,
      message_length: mlt$message_length,
      arbitrary_info: mlt$arbitrary_info,
      partner_status_returned: boolean;

    PROCEDURE pj_break_handler
      (    cond: pmt$condition;
           condition_info: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR break_status: ost$status);

      VAR
        local_status: ost$status;

      IF (cond.selector = ifc$interactive_condition) THEN
        IF partner_status_returned = TRUE THEN
          icp$receive_from_pj_exec (icv$pj_application_name,
                #LOC (initiate_partner_response),
                #SIZE (initiate_partner_response), message_length,
                arbitrary_info, status);
        IFEND;
        IF cond.interactive_condition = ifc$pause_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$pause_break_received, '', status);
        ELSEIF cond.interactive_condition = ifc$terminate_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$terminate_break_received, '', status);
        IFEND;
        pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
        EXIT icp$initiate_partner_job;
      IFEND;
      break_status.normal := TRUE;
      RETURN;
    PROCEND pj_break_handler;

{ Begin procedure ICP$INITIATE_PARTNER_JOB.

    status.normal := TRUE;
    osp$establish_condition_handler (^pj_break_handler, FALSE);
    IF NOT icv$pj_signed_on THEN
      icp$pj_sign_on (icv$pj_application_name, status);
      IF NOT status.normal THEN
        osp$disestablish_cond_handler;
        RETURN;
      IFEND;

{ Allow the partner-job-exec to send messages to us.

      icp$pj_add_sender (icv$pj_application_name, status);
      IF NOT status.normal THEN
        osp$disestablish_cond_handler;
        RETURN;
      IFEND;
    IFEND;

    icv$pj_signed_on := TRUE;

{ Build an initiate partner request message.

    initiate_partner_request.commands_length := commands_length;
    initiate_partner_request.data_length := data_length;
    i#move (commands_pointer, #LOC (initiate_partner_request.
          partner_image [1]), commands_length * 8);
    i#move (data_pointer, #LOC (initiate_partner_request.
          partner_image [commands_length + 1]), data_length * 8);
    i#move (validation_pointer, #LOC (initiate_partner_request.
          validation_image [1]), validation_length * 8);
    partner_status_returned := FALSE;

  /initiate_partner_job/
    WHILE TRUE DO

{ Send the initiate partner job request message to the partner-job-exec.

      icp$send_to_pj_exec (icv$pj_application_name,
            #LOC (initiate_partner_request), #SIZE (initiate_partner_request),
            $INTEGER (icc$initiate_partner_request), status);
      IF NOT status.normal THEN
        EXIT /initiate_partner_job/;
      IFEND;
      partner_status_returned := TRUE;

{ Get the initiate partner response from the partner-job-exec.

      icp$receive_from_pj_exec (icv$pj_application_name,
            #LOC (initiate_partner_response),
            #SIZE (initiate_partner_response), message_length, arbitrary_info,
            status);
      IF NOT status.normal THEN
        EXIT /initiate_partner_job/;
      IFEND;
      partner_status_returned := FALSE;

      IF arbitrary_info <> $INTEGER (icc$initiate_partner_response) THEN
        osp$set_status_abnormal (icc$interstate_communication_id,
              ice$partner_cannot_be_started, '', status);
        icp$report_status_error (status, ' garbage initiate response');
        EXIT /initiate_partner_job/;
      IFEND;

      CASE initiate_partner_response.initiate_status OF

      = $INTEGER (icc$partner_started_ok) =
        partner_identification := initiate_partner_response.
              partner_identification;
        EXIT /initiate_partner_job/;

      = $INTEGER (icc$partner_job_limit_exceeded) =
        pmp$long_term_wait (icf_interval, icf_interval);
        CYCLE /initiate_partner_job/;

      = $INTEGER (icc$partner_start_failed) =
        osp$set_status_abnormal (icc$interstate_communication_id,
              ice$partner_cannot_be_started, '', status);
        icp$report_status_error (status, ' initiate partner failed');
        EXIT /initiate_partner_job/;

      ELSE
        osp$set_status_abnormal (icc$interstate_communication_id,
              ice$partner_cannot_be_started, '', status);
        icp$report_status_error (status, ' initiate partner failed');
        EXIT /initiate_partner_job/;

      CASEND;
    WHILEND /initiate_partner_job/;
    osp$disestablish_cond_handler;

  PROCEND icp$initiate_partner_job;

?? TITLE := 'PROCEDURE icp$status_partner_job', EJECT ??

  PROCEDURE [XDCL] icp$status_partner_job
    (    partner_identification: ict$partner_identification;
     VAR status_partner_status: ict$status_partner_status;
     VAR status: ost$status);

    VAR
      status_partner_request: ict$status_partner_request,
      status_partner_response: ict$status_partner_response,
      partner_status_returned: boolean,
      message_length: mlt$message_length,
      arbitrary_info: mlt$arbitrary_info;

    PROCEDURE pj_break_handler
      (    cond: pmt$condition;
           condition_info: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR break_status: ost$status);

      VAR
        local_status: ost$status;

      IF (cond.selector = ifc$interactive_condition) THEN
        IF partner_status_returned = TRUE THEN
          icp$receive_from_pj_exec (icv$pj_application_name,
                #LOC (status_partner_response),
                #SIZE (status_partner_response), message_length,
                arbitrary_info, status);
        IFEND;
        IF cond.interactive_condition = ifc$pause_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$pause_break_received, '', status);
        ELSEIF cond.interactive_condition = ifc$terminate_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$terminate_break_received, '', status);
        IFEND;
        pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
        EXIT icp$status_partner_job;
      IFEND;
      break_status.normal := TRUE;
      RETURN;
    PROCEND pj_break_handler;

{ Begin procedure ICP$STATUS_PARTNER_JOB.

    status.normal := TRUE;
    osp$establish_condition_handler (^pj_break_handler, FALSE);
    partner_status_returned := FALSE;
    status_partner_request.partner_identification := partner_identification;
    icp$send_to_pj_exec (icv$pj_application_name,
          #LOC (status_partner_request), #SIZE (status_partner_request),
          $INTEGER (icc$status_partner_request), status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    partner_status_returned := TRUE;

{ Get the status partner response from the partner-job-exec.

    icp$receive_from_pj_exec (icv$pj_application_name,
          #LOC (status_partner_response), #SIZE (status_partner_response),
          message_length, arbitrary_info, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    partner_status_returned := FALSE;

    IF arbitrary_info <> $INTEGER (icc$status_partner_response) THEN
      osp$set_status_abnormal (icc$interstate_communication_id,
            ice$partner_ended, '', status);
      icp$report_status_error (status, ' garbage status response');
      osp$disestablish_cond_handler;
      RETURN;
    ELSE
      CASE status_partner_response.partner_status OF

      = $INTEGER (icc$partner_not_found) =
        status_partner_status := icc$partner_not_found;

      = $INTEGER (icc$partner_in_input_queue) =
        status_partner_status := icc$partner_in_input_queue;

      = $INTEGER (icc$partner_not_signed_on) =
        status_partner_status := icc$partner_not_signed_on;

      = $INTEGER (icc$partner_signed_on) =
        status_partner_status := icc$partner_signed_on;

      ELSE
        status_partner_status := icc$partner_not_found;

      CASEND;
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND icp$status_partner_job;
?? TITLE := 'PROCEDURE icp$delete_partner_job', EJECT ??

  PROCEDURE [XDCL] icp$delete_partner_job
    (    partner_identification: ict$partner_identification;
     VAR status: ost$status);

    VAR
      delete_partner_request: ict$delete_partner_request,
      delete_partner_response: ict$delete_partner_response,
      partner_status_returned: boolean,
      message_length: mlt$message_length,
      arbitrary_info: mlt$arbitrary_info,
      local_status: ost$status;

    PROCEDURE pj_break_handler
      (    cond: pmt$condition;
           condition_info: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR break_status: ost$status);

      VAR
        local_status: ost$status;

      IF (cond.selector = ifc$interactive_condition) THEN
        IF partner_status_returned = TRUE THEN
          icp$receive_from_pj_exec (icv$pj_application_name,
                #LOC (delete_partner_response),
                #SIZE (delete_partner_response), message_length,
                arbitrary_info, status);
        IFEND;
        IF cond.interactive_condition = ifc$pause_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$pause_break_received, '', status);
        ELSEIF cond.interactive_condition = ifc$terminate_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$terminate_break_received, '', status);
        IFEND;
        pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
        EXIT icp$delete_partner_job;
      IFEND;
      break_status.normal := TRUE;
      RETURN;
    PROCEND pj_break_handler;

  /delete_partner/
    BEGIN
      status.normal := TRUE;
      osp$establish_condition_handler (^pj_break_handler, FALSE);

{ Send a delete partner job request message to the partner-job-exec.

      delete_partner_request.partner_identification := partner_identification;
      partner_status_returned := FALSE;
      icp$send_to_pj_exec (icv$pj_application_name,
            #LOC (delete_partner_request), #SIZE (delete_partner_request),
            $INTEGER (icc$delete_partner_request), status);
      IF NOT status.normal THEN
        EXIT /delete_partner/;
      IFEND;
      partner_status_returned := TRUE;

{ Get the delete partner response from the partner-job-exec.

      icp$receive_from_pj_exec (icv$pj_application_name,
            #LOC (delete_partner_response), #SIZE (delete_partner_response),
            message_length, arbitrary_info, status);
      IF NOT status.normal THEN
        EXIT /delete_partner/;
      IFEND;
      partner_status_returned := FALSE;

      IF arbitrary_info <> $INTEGER (icc$delete_partner_response) THEN
        osp$set_status_abnormal (icc$interstate_communication_id,
              ice$partner_ended, '', status);
        icp$report_status_error (status, ' garbage delete response');
        EXIT /delete_partner/;
      IFEND;

    END /delete_partner/;

{ Sign off of the Memory Link.

    icp$pj_sign_off (icv$pj_application_name, local_status);
    icv$pj_signed_on := FALSE;
    osp$disestablish_cond_handler;

  PROCEND icp$delete_partner_job;

MODEND icm$partner_job_exec_virtual;
*DECK DECK=ICM$PARTNER_JOB_MLI_ACCESS EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE icm$partner_job_mli_access;
?? TITLE := 'MODULE icm$partner_job_mli_access' ??

?? PUSH (LIST := ON) ??
*copyc ICE$ERROR_CODES
*copyc ICT$PARTNER_MESSAGES
*copyc ICF$OPEN_FILE_DESCRIPTOR
*copyc ICP$REPORT_STATUS_ERROR
*copyc ICP$SET_STATUS_ABNORMAL
*copyc IFE$ERROR_CODES
*copyc OSP$DISESTABLISH_COND_HANDLER
*copyc OSP$ESTABLISH_CONDITION_HANDLER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$CONTINUE_TO_CAUSE
*copyc PMP$LONG_TERM_WAIT
*copyc PMP$WAIT
*copyc MLP$ADD_SENDER
*copyc MLP$CONFIRM_SEND
*copyc MLP$RECEIVE_MESSAGE
*copyc MLP$SEND_MESSAGE
*copyc MLP$SIGN_OFF
*copyc MLP$SIGN_ON
?? POP ??

?? TITLE := 'PROCEDURE icp$pj_sign_on', EJECT ??

  PROCEDURE [XDCL] icp$pj_sign_on
    (VAR application_name: mlt$application_name;
     VAR status: ost$status);

{  PURPOSE:
{    The purpose of this procedure is to Sign On to the Memory Link.
{  DESIGN:
{    A MLP$SIGN_ON request specifying that a unique application name should be
{    created is issued to the Memory Link.
{

    PROCEDURE handle_break
      (    cond: pmt$condition;
           condition_info: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR break_status: ost$status);

      VAR
        local_status: ost$status;

      IF (cond.selector = ifc$interactive_condition) THEN
        IF cond.interactive_condition = ifc$pause_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$pause_break_received, '', status);
        ELSEIF cond.interactive_condition = ifc$terminate_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$terminate_break_received, '', status);
        IFEND;
        pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
        EXIT icp$pj_sign_on;
      IFEND;
      break_status.normal := TRUE;
      RETURN;
    PROCEND handle_break;

{ Begin procedure ICP$PJ_SIGN_ON.

    status.normal := TRUE;
    osp$establish_condition_handler (^handle_break, FALSE);

{ Sign On to the Memory Link.

  /sign_on_to_mli/
    WHILE TRUE DO
      mlp$sign_on (mlc$unique_name, 1, application_name, status);
      IF status.normal THEN
        EXIT /sign_on_to_mli/;
      ELSE
        CASE status.condition OF
        = mlc$busy_interlock, mlc$pool_buffer_not_avail =
          pmp$wait (icf_short_interval, icf_short_interval);
        = mlc$ant_full =
          pmp$long_term_wait (icf_interval, icf_interval);
        ELSE
          icp$set_status_abnormal (status);
          EXIT /sign_on_to_mli/;
        CASEND;
      IFEND;
    WHILEND /sign_on_to_mli/;
    osp$disestablish_cond_handler;

  PROCEND icp$pj_sign_on;

?? TITLE := 'PROCEDURE icp$pj_add_sender', EJECT ??

  PROCEDURE [XDCL] icp$pj_add_sender
    (    application_name: mlt$application_name;
     VAR status: ost$status);

{  PURPOSE:
{    The purpose of this procedure is to permit the Partner-Job-Exec
{    application to send messages to the interstate communication task.
{  DESIGN:
{    A MLP$ADD_SENDER request for the Partner-Job-Exec is issued to the Memory
{    Link.
{

{ Permit Partner-Job-Exec to send messages to us.

    status.normal := TRUE;

  /permit_pj_exec_to_send/
    WHILE TRUE DO
      mlp$add_sender (application_name, icc$pj_exec_application_name, status);
      IF status.normal THEN
        EXIT /permit_pj_exec_to_send/;
      ELSE
        CASE status.condition OF
        = mlc$busy_interlock =
          pmp$wait (icf_short_interval, icf_short_interval);
        ELSE
          icp$set_status_abnormal (status);
          EXIT /permit_pj_exec_to_send/;
        CASEND;
      IFEND;
    WHILEND /permit_pj_exec_to_send/;

  PROCEND icp$pj_add_sender;

?? TITLE := 'PROCEDURE icp$send_to_pj_exec', EJECT ??

  PROCEDURE [XDCL] icp$send_to_pj_exec
    (    application_name: mlt$application_name;
         message_pointer: ^cell;
         message_length: mlt$message_length;
         message_type: mlt$arbitrary_info;
     VAR status: ost$status);

{  PURPOSE:
{    The purpose of this procedure is to send a message to the
{    Partner-Job-Exec.
{  DESIGN:
{    A MLP$SEND_MESSAGE to Partner-Job-Exec request is issued to the Memory
{    Link.
{

    PROCEDURE handle_break
      (    cond: pmt$condition;
           condition_info: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR break_status: ost$status);

      VAR
        local_status: ost$status;

      IF (cond.selector = ifc$interactive_condition) THEN
        IF cond.interactive_condition = ifc$pause_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$pause_break_received, '', status);
        ELSEIF cond.interactive_condition = ifc$terminate_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$terminate_break_received, '', status);
        IFEND;
        pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
        EXIT icp$send_to_pj_exec;
      IFEND;
      break_status.normal := TRUE;
      RETURN;
    PROCEND handle_break;

{ Begin procedure ICP$SEND_TO_PJ_EXEC.

    status.normal := TRUE;
    osp$establish_condition_handler (^handle_break, FALSE);

  /send_message_to_pj_exec/
    WHILE TRUE DO
      mlp$send_message (application_name, message_type, NIL, message_pointer,
            message_length, icc$pj_exec_application_name, status);
      IF status.normal THEN
        EXIT /send_message_to_pj_exec/;
      ELSE
        CASE status.condition OF
        = mlc$busy_interlock, mlc$pool_buffer_not_avail =
          pmp$wait (icf_short_interval, icf_short_interval);
        = mlc$receive_list_full, mlc$prior_msg_not_received =
          pmp$long_term_wait (icf_interval, icf_interval);
        ELSE
          icp$set_status_abnormal (status);
          EXIT /send_message_to_pj_exec/;
        CASEND;
      IFEND;
    WHILEND /send_message_to_pj_exec/;
    osp$disestablish_cond_handler;

  PROCEND icp$send_to_pj_exec;

?? TITLE := 'PROCEDURE icp$receive_from_pj_exec', EJECT ??

  PROCEDURE [XDCL] icp$receive_from_pj_exec
    (    application_name: mlt$application_name;
         buffer_pointer: ^cell;
         buffer_length: mlt$message_length;
     VAR message_length: mlt$message_length;
     VAR arbitrary_info: mlt$arbitrary_info;
     VAR status: ost$status);

{  PURPOSE:
{    The purpose of this procedure is to receive a message from the
{    Partner-Job-Exec.
{  DESIGN:
{    MLP$RECEIVE_MESSAGE requests are issued to the Memory Link until a message
{    is received.
{

    VAR
      busy_count: 0 .. 100,
      sender_application_name: mlt$application_name;


    PROCEDURE handle_break
      (    cond: pmt$condition;
           condition_info: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR break_status: ost$status);

      VAR
        local_status: ost$status;

      IF (cond.selector = ifc$interactive_condition) THEN
        IF cond.interactive_condition = ifc$pause_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$pause_break_received, '', status);
        ELSEIF cond.interactive_condition = ifc$terminate_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$terminate_break_received, '', status);
        IFEND;
        pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
        EXIT icp$receive_from_pj_exec;
      IFEND;
      break_status.normal := TRUE;
      RETURN;
    PROCEND handle_break;

{ Begin procedure ICP$RECEIVE_FROM_PJ_EXEC.

    status.normal := TRUE;
    busy_count := 0;
    osp$establish_condition_handler (^handle_break, FALSE);

  /receive_message_from_pj_exec/
    WHILE TRUE DO
      mlp$receive_message (application_name, arbitrary_info, NIL,
            buffer_pointer, message_length, buffer_length, 0,
            sender_application_name, status);
      IF status.normal THEN
        EXIT /receive_message_from_pj_exec/;
      ELSE
        CASE status.condition OF
        = mlc$busy_interlock =
          pmp$wait (icf_short_interval, icf_short_interval);
        = mlc$receive_list_index_invalid =
          IF busy_count < 100 THEN
            busy_count := busy_count + 1;
            pmp$long_term_wait (icf_interval, icf_interval);
          ELSE

          /confirm_loop/
            WHILE TRUE DO
              mlp$confirm_send (application_name, sender_application_name,
                    status);
              IF (status.normal) OR (status.condition =
                    mlc$prior_msg_not_received) THEN
                busy_count := 0;
                pmp$long_term_wait (icf_interval, icf_interval);
                CYCLE /receive_message_from_pj_exec/;
              ELSEIF (status.condition = mlc$busy_interlock) THEN
                pmp$wait (icf_short_interval, icf_short_interval);
                CYCLE /confirm_loop/;
              ELSEIF status.condition = mlc$sender_not_permitted THEN
                pmp$long_term_wait (icf_interval, icf_interval);
                CYCLE /confirm_loop/;
              ELSEIF status.condition = mlc$receiver_not_signed_on THEN
                osp$set_status_abnormal (icc$interstate_communication_id,
                      ice$partner_ended, '', status);
                EXIT /receive_message_from_pj_exec/;
              ELSE
                icp$set_status_abnormal (status);
                EXIT /receive_message_from_pj_exec/;
              IFEND;
            WHILEND /confirm_loop/;
          IFEND;
        ELSE
          icp$set_status_abnormal (status);
          EXIT /receive_message_from_pj_exec/;
        CASEND;
      IFEND;
    WHILEND /receive_message_from_pj_exec/;
    osp$disestablish_cond_handler;

  PROCEND icp$receive_from_pj_exec;


?? TITLE := 'PROCEDURE icp$pj_sign_off', EJECT ??

  PROCEDURE [XDCL] icp$pj_sign_off
    (    application_name: mlt$application_name;
     VAR status: ost$status);

{  PURPOSE:
{    The purpose of this procedure is to sign off from the Memory Link.
{  DESIGN:
{    A MLP$SIGN_OFF request is issued to the Memory Link.
{

    status.normal := TRUE;

  /sign_off_from_mli/
    WHILE TRUE DO
      mlp$sign_off (application_name, status);
      IF status.normal THEN
        EXIT /sign_off_from_mli/;
      ELSE
        CASE status.condition OF
        = mlc$busy_interlock =
          pmp$wait (icf_short_interval, icf_short_interval);
        ELSE
          icp$set_status_abnormal (status);
          EXIT /sign_off_from_mli/;
        CASEND;
      IFEND;
    WHILEND /sign_off_from_mli/;

  PROCEND icp$pj_sign_off;

MODEND icm$partner_job_mli_access;
*DECK DECK=ICM$PUT EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE icm$put;
?? TITLE := 'MODULE icm$put' ??

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_POSITION
*copyc AMD$OPERATION_DECLARATIONS
*copyc AMT$MAX_BLOCK_LENGTH
*copyc AMT$TERM_OPTION
*copyc AMT$TRANSFER_COUNT
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc ICE$ERROR_CODES
*copyc ICF$OPEN_FILE_DESCRIPTOR
*copyc ICP$SET_STATUS_ABNORMAL
*copyc ICP$STATUS_PARTNER_JOB
*copyc IFE$ERROR_CODES
*copyc I#PTR
*copyc MLP$FETCH_LINK_PARTNER_INFO
*copyc MLP$SEND_MESSAGE
*copyc OSP$DISESTABLISH_COND_HANDLER
*copyc OSP$ESTABLISH_CONDITION_HANDLER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSV$170_OS_TYPE
*copyc PMP$CONTINUE_TO_CAUSE
*copyc PMP$EXIT
*copyc PMP$LONG_TERM_WAIT
*copyc PMP$WAIT
?? POP ??

?? NEWTITLE := 'PROCEDURE icp$put' ??
{  ICP$PUT
{
{     The purpose of this procedure is to send a record or a
{  partial record to the 170 partner job.

  PROCEDURE [XDCL] icp$put
    (    icf_file: ^icf_open_file_descriptor;
         operation: amt$fap_operation;
         working_storage_area: ^cell;
         working_storage_length: amt$working_storage_length;
         term_option: amt$term_option;
     VAR status: ost$status);

    CONST max_nosbe_retries = 10;

    VAR
      offset: amt$working_storage_length,
      message_length: mlt$message_length,
      unused_bits: integer,
      partial: boolean,
      first_message: boolean,
      last_message: boolean,
      retry_count: 0 .. max_nosbe_retries,
      last_op: mlt$operation,
      arbitrary_info: mlt$arbitrary_info,
      signal_record: mlt$signal_record,
      signal: mlt$signal,
      partner_stat: ict$status_partner_status,
      stat: ost$status;


    PROCEDURE handle_break
      (    cond: pmt$condition;
           condition_info: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR break_status: ost$status);

      VAR
        local_status: ost$status;

      IF (cond.selector = ifc$interactive_condition) THEN
        IF cond.interactive_condition = ifc$pause_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$pause_break_received, '', status);
        ELSEIF cond.interactive_condition = ifc$terminate_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$terminate_break_received, '', status);
        IFEND;
        pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
        EXIT icp$put;
      IFEND;
      break_status.normal := TRUE;
      RETURN;
    PROCEND handle_break;

{ Begin procedure ICP$PUT.

    status.normal := TRUE;
    osp$establish_condition_handler (^handle_break, FALSE);
    IF working_storage_length > amc$maximum_block THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ame$record_exceeds_mbl, operation, '', status);
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    IF NOT icf_file^.opened_for_put THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ame$improper_output_attempt, operation, '', status);
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    IF (term_option = amc$continue) AND (icf_file^.position <> amc$mid_record)
          THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ame$improper_term_option, operation, '', status);
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

{  Terminate any prior partial record.

    IF (term_option = amc$start) AND (icf_file^.position = amc$mid_record) THEN
      icp$put (icf_file, amc$put_next_req, working_storage_area, 0,
            amc$terminate, stat);
      IF NOT stat.normal THEN
        status := stat;
        osp$disestablish_cond_handler;
        RETURN;
      IFEND;
    IFEND;
    partial := (operation = amc$put_partial_req);
    offset := 0;
    signal := ^signal_record;

{  Send data until the user's record area is empty.

  /outer_loop/
    REPEAT
      IF (working_storage_length - offset) <
            ((mlc$max_message_length DIV 8) * 8) THEN
        message_length := (working_storage_length - offset);
      ELSE
        message_length := ((mlc$max_message_length DIV 8) * 8);
      IFEND;
      first_message := (offset = 0) AND ((NOT partial) OR
            (partial AND (term_option = amc$start)) OR
            (partial AND (icf_file^.position <> amc$mid_record)));
      last_message := ((offset + message_length) >= working_storage_length) AND
            (NOT partial OR (partial AND (term_option = amc$terminate)));
      arbitrary_info := ($INTEGER (first_message) * 2) +
            $INTEGER (last_message);
      IF last_message AND ((working_storage_length MOD 8) <> 0) THEN
        unused_bits := 8 * (8 - (working_storage_length MOD 8));
        arbitrary_info := arbitrary_info + (unused_bits * 16);
      IFEND;
      IF first_message THEN
        icf_file^.record_length := 0;
      IFEND;

      retry_count := 0;
    /inner_loop/
      WHILE TRUE DO

        mlp$send_message (icf_file^.application_name, arbitrary_info, signal,
              i#ptr (offset, working_storage_area), message_length,
              icf_file^.partner_id.application_name, stat);
        IF (stat.normal) OR (stat.condition = mlc$ok) OR (stat.condition =
              mlc$signal_failed_ignored) OR (stat.condition =
              mlc$signal_to_c170_ignored) THEN
          EXIT /inner_loop/;
        ELSE
          CASE stat.condition OF
          = mlc$busy_interlock, mlc$pool_buffer_not_avail =
            pmp$wait (icf_short_interval, icf_short_interval);
            CYCLE /inner_loop/;
          = mlc$sender_not_permitted =
            pmp$long_term_wait (icf_interval, icf_interval);
            CYCLE /inner_loop/;
          = mlc$receiver_not_signed_on =
            icp$status_partner_job (icf_file^.partner_id, partner_stat, stat);
            IF stat.normal THEN
              IF partner_stat = icc$partner_not_found THEN
                IF osv$170_os_type = osc$ot7_dual_state_nos_be THEN
                  IF retry_count = max_nosbe_retries THEN
                    amp$set_file_instance_abnormal (icf_file^.file_id,
                        ice$partner_ended, operation, '', status);
                    EXIT /outer_loop/;
                  ELSE
                    retry_count := retry_count + 1;
                    pmp$long_term_wait (icf_short_interval, icf_short_interval);
                    CYCLE /inner_loop/;
                  IFEND;
                ELSE
                  amp$set_file_instance_abnormal (icf_file^.file_id,
                      ice$partner_ended, operation, '', status);
                  EXIT /outer_loop/;
                IFEND;
              ELSE
                pmp$long_term_wait (icf_interval, icf_interval);
                CYCLE /inner_loop/;
              IFEND;
            ELSE
              osp$disestablish_cond_handler;
              pmp$exit (stat);
            IFEND;
          = mlc$prior_msg_not_received, mlc$receive_list_full =

          /flpi_loop/
            WHILE TRUE DO
              mlp$fetch_link_partner_info (icf_file^.application_name,
                  icf_file^.partner_id.application_name, last_op, stat);
              IF (stat.normal) OR (stat.condition = mlc$ok) THEN
                EXIT /flpi_loop/;
              ELSE
                CASE stat.condition OF
                = mlc$busy_interlock =
                  pmp$wait (icf_short_interval, icf_short_interval);
                  CYCLE /flpi_loop/;
                = mlc$receiver_not_signed_on =
                  icp$status_partner_job (icf_file^.partner_id, partner_stat,
                      stat);
                  IF stat.normal THEN
                    IF partner_stat = icc$partner_not_found THEN
                      amp$set_file_instance_abnormal
                            (icf_file^.file_id, ice$partner_ended, operation,
                            '', status);
                      RETURN;
                    ELSE
                      pmp$long_term_wait (icf_interval, icf_interval);
                      CYCLE /inner_loop/;
                    IFEND;
                  ELSE
                    osp$disestablish_cond_handler;
                    pmp$exit (stat);
                  IFEND;
                ELSE
                  icp$set_status_abnormal (stat);
                  osp$disestablish_cond_handler;
                  pmp$exit (stat);
                CASEND;
              IFEND;
            WHILEND /flpi_loop/;

            IF ((last_op.req = mlc$send_message_req) OR
                  (last_op.req = mlc$confirm_send_req)) AND
                  ((last_op.stat_condition = mlc$prior_msg_not_received) OR
                  (last_op.stat_condition = mlc$receive_list_full)) THEN
              amp$set_file_instance_abnormal (icf_file^.file_id,
                  ice$write_deadlock, operation, '', status);
              osp$disestablish_cond_handler;
              RETURN;
            ELSE
              pmp$long_term_wait (icf_interval, icf_interval);
              CYCLE /inner_loop/;
            IFEND;
          ELSE
            icp$set_status_abnormal (stat);
            osp$disestablish_cond_handler;
            pmp$exit (stat);
          CASEND;
        IFEND;
      WHILEND /inner_loop/;

      offset := offset + message_length;
      icf_file^.record_length := icf_file^.record_length + message_length;
    UNTIL offset >= working_storage_length {/outer_loop/} ;

{  Store the file position information.

    IF last_message THEN
      icf_file^.position := amc$eor;
      icf_file^.last_length := icf_file^.record_length;
    ELSE
      icf_file^.position := amc$mid_record;
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND icp$put;

MODEND icm$put;
*DECK DECK=ICM$REPORT_STATUS_ERROR EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE icm$report_status_error;

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PMP$LOG
*copyc osp$unpack_status_condition
?? POP ??

?? TITLE := 'PROCEDURE [XDCL ] icp$report_status_error', EJECT ??

  PROCEDURE [XDCL] icp$report_status_error (VAR error_status: ost$status;
        message: string ( * ));

    CONST
      legend_1 = 'Status error on ',
      legend_2 = 'Id:   ; Cond:         ',
      legend_3 = 'Text:                                ';

    VAR
      identifier: ost$status_identifier,
      number: ost$status_condition_number,
      line: string (255),
      status: ost$status,
      i: integer;

{ Log the kind of error report that is to follow

    line (1, 16) := legend_1;
    line (17, STRLENGTH (message)) := message;
    pmp$log (line (1, 16 + STRLENGTH (message)), status);

{ Log the status id and condition code

    line (1, 22) := legend_2;
    osp$unpack_status_condition (error_status.condition, identifier, number);
    line (5, 2) := identifier;
    STRINGREP (line (14, 8), i, number);
    pmp$log (line (1, 21), status);

{ Log the status text

{    line (1, 37) := legend_3;
{    line (7, error_status.text.size) := error_status.text.value (1,
{          error_status.text.size);
{    pmp$log (line (1, 6 + error_status.text.size), status);

  PROCEND icp$report_status_error;

MODEND icm$report_status_error;
*DECK DECK=ICM$SET_STATUS_ABNORMAL EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Interstate Communication : Set Abnormal Condition' ??
MODULE icm$set_status_abnormal;

{ PURPOSE:
{   This module contains the procedure to set the error status for certain
{   Interstate Communication errors.
{
{ DESIGN:
{   Move the code from other Interstate Communication modules.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ice$error_codes
*copyc mld$memory_link_declarations
*copyc ost$status
?? POP ??
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osv$170_os_type

?? TITLE := '[XDCL] icp$set_status_abnormal', EJECT ??
*copy ich$set_status_abnormal

  PROCEDURE [XDCL] icp$set_status_abnormal
    (VAR status: ost$status);

    VAR
      length: integer,
      message: string (3),
      partner_state: string (6),
      partner_state_length: integer;

{ Set up dual state system indicator.

    IF osv$170_os_type = osc$ot7_dual_state_nos THEN
      partner_state := 'NOS';
      partner_state_length := 3;
    ELSE
      partner_state := 'NOS/BE';
      partner_state_length := 6;
    IFEND;

    CASE status.condition OF
    = mlc$message_truncated =
      osp$set_status_abnormal (icc$interstate_communication_id, ice$mismatching_code,
            partner_state (1, partner_state_length), status);
    = mlc$system_name_no_match =
      osp$set_status_abnormal (icc$interstate_communication_id, ice$receiver_already_signed_on,
            partner_state (1, partner_state_length), status);
    = mlc$receiver_not_signed_on =
      osp$set_status_abnormal (icc$interstate_communication_id, ice$receiver_not_signed_on,
            partner_state (1, partner_state_length), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, partner_state (1, partner_state_length),
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, partner_state (1, partner_state_length),
            status);
    ELSE
      STRINGREP (message, length, status.condition);
      osp$set_status_abnormal (icc$interstate_communication_id, ice$unexpected_ml_error, message (1, length),
            status);
    CASEND;

  PROCEND icp$set_status_abnormal;

MODEND icm$set_status_abnormal;
*DECK DECK=ICM$TASK_PRIVATE_VARIABLES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE icm$task_private_variables;
?? TITLE := 'MODULE icm$task_private_variables' ??

?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??

  VAR

    icv$pj_signed_on: [XDCL] boolean := FALSE,
    icv$pj_application_name: [XDCL] mlt$application_name;

MODEND icm$task_private_variables;
*DECK DECK=ICM$TASK_SHARED_VARIABLES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE icm$task_shared_variables;
?? TITLE := 'MODULE icm$task_shared_variables' ??

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??

  VAR

    icv$open_file_count_lock: [XDCL] ost$signature_lock := [0],
    icv$open_file_count: [XDCL] integer := 0;

MODEND icm$task_shared_variables;
*DECK DECK=ICM$WRITE_END_PARTITION EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE icm$write_end_partition;
?? TITLE := 'MODULE icm$write_end_partition' ??

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_POSITION
*copyc AMD$OPERATION_DECLARATIONS
*copyc AMT$MAX_BLOCK_LENGTH
*copyc AMT$TERM_OPTION
*copyc AMT$TRANSFER_COUNT
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc ICE$ERROR_CODES
*copyc ICF$OPEN_FILE_DESCRIPTOR
*copyc ICP$PUT
*copyc ICP$SET_STATUS_ABNORMAL
*copyc ICP$STATUS_PARTNER_JOB
*copyc IFE$ERROR_CODES
*copyc MLP$FETCH_LINK_PARTNER_INFO
*copyc MLP$SEND_MESSAGE
*copyc OSP$DISESTABLISH_COND_HANDLER
*copyc OSP$ESTABLISH_CONDITION_HANDLER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$CONTINUE_TO_CAUSE
*copyc PMP$EXIT
*copyc PMP$LONG_TERM_WAIT
*copyc PMP$WAIT
?? POP ??

?? NEWTITLE := 'PROCEDURE icp$write_end_partition' ??
{  ICP$WRITE_END_PARTITION
{
{     The purpose of this procedure is to send an EOP indication
{ to the 170 partner job.

  PROCEDURE [XDCL] icp$write_end_partition
    (    icf_file: ^icf_open_file_descriptor;
         operation: amt$fap_operation;
     VAR status: ost$status);

    VAR
      ptr: ^cell,
      eop: boolean,
      first_message: boolean,
      last_message: boolean,
      last_op: mlt$operation,
      arbitrary_info: mlt$arbitrary_info,
      signal_record: mlt$signal_record,
      signal: mlt$signal,
      partner_stat: ict$status_partner_status,
      stat: ost$status;


    PROCEDURE handle_break
      (    cond: pmt$condition;
           condition_info: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR break_status: ost$status);

      VAR
        local_status: ost$status;

      IF (cond.selector = ifc$interactive_condition) THEN
        IF cond.interactive_condition = ifc$pause_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$pause_break_received, '', status);
        ELSEIF cond.interactive_condition = ifc$terminate_break THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$terminate_break_received, '', status);
        IFEND;
        pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
        EXIT icp$write_end_partition;
      IFEND;
      break_status.normal := TRUE;
      RETURN;
    PROCEND handle_break;

{ Begin procedure ICM$WRITE_END_PARTITION.

    status.normal := TRUE;
    osp$establish_condition_handler (^handle_break, FALSE);
    IF NOT icf_file^.opened_for_put THEN
      amp$set_file_instance_abnormal (icf_file^.file_id,
            ame$improper_output_attempt, operation, '', status);
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

{  Terminate any prior partial record.

    ptr := icf_file;
    IF icf_file^.position = amc$mid_record THEN
      icp$put (icf_file, amc$put_next_req, ptr, 0, amc$terminate, stat);
      IF NOT stat.normal THEN
        osp$disestablish_cond_handler;
        pmp$exit (stat);
      IFEND;
    IFEND;
    signal := ^signal_record;
    eop := TRUE;
    first_message := TRUE;
    last_message := TRUE;
    arbitrary_info := $INTEGER (eop) * 4 + $INTEGER (first_message) *
          2 + $INTEGER (last_message);

{  Send the EOP indication.

  /loop/
    WHILE TRUE DO

      mlp$send_message (icf_file^.application_name, arbitrary_info, signal,
            ptr, 0, icf_file^.partner_id.application_name, stat);

      IF (stat.normal) OR (stat.condition = mlc$ok) OR (stat.condition =
            mlc$signal_failed_ignored) OR (stat.condition =
            mlc$signal_to_c170_ignored) THEN
        EXIT /loop/;
      ELSE
        CASE stat.condition OF
        = mlc$busy_interlock, mlc$pool_buffer_not_avail =
          pmp$wait (icf_short_interval, icf_short_interval);
          CYCLE /loop/;
        = mlc$receiver_not_signed_on =
          icp$status_partner_job (icf_file^.partner_id, partner_stat, stat);
          IF stat.normal THEN
            IF partner_stat = icc$partner_not_found THEN
              amp$set_file_instance_abnormal (icf_file^.file_id,
                    ice$partner_ended, operation, '', status);
              RETURN;
            ELSE
              pmp$long_term_wait (icf_interval, icf_interval);
              CYCLE /loop/;
            IFEND;
          ELSE
            osp$disestablish_cond_handler;
            pmp$exit (stat);
          IFEND;
        = mlc$prior_msg_not_received, mlc$receive_list_full =

        /flpi_loop/
          WHILE TRUE DO
            mlp$fetch_link_partner_info (icf_file^.application_name,
                  icf_file^.partner_id.application_name, last_op, stat);
            IF (stat.normal) OR (stat.condition = mlc$ok) THEN
              EXIT /flpi_loop/;
            ELSE
              CASE stat.condition OF
              = mlc$busy_interlock =
                pmp$wait (icf_short_interval, icf_short_interval);
                CYCLE /flpi_loop/;
              = mlc$receiver_not_signed_on =
                icp$status_partner_job (icf_file^.partner_id, partner_stat,
                    stat);
                IF stat.normal THEN
                  IF partner_stat = icc$partner_not_found THEN
                    amp$set_file_instance_abnormal
                          (icf_file^.file_id, ice$partner_ended, operation, '',
                          status);
                    RETURN;
                  ELSE
                    pmp$long_term_wait (icf_interval, icf_interval);
                    CYCLE /loop/;
                  IFEND;
                ELSE
                  osp$disestablish_cond_handler;
                  pmp$exit (stat);
                IFEND;
              ELSE
                icp$set_status_abnormal (stat);
                osp$disestablish_cond_handler;
                pmp$exit (stat);
              CASEND;
            IFEND;
          WHILEND /flpi_loop/;

          IF ((last_op.req = mlc$send_message_req) OR
                (last_op.req = mlc$confirm_send_req)) AND
                ((last_op.stat_condition = mlc$prior_msg_not_received) OR
                (last_op.stat_condition = mlc$receive_list_full)) THEN
            amp$set_file_instance_abnormal (icf_file^.file_id,
                  ice$write_deadlock, operation, '', status);
            osp$disestablish_cond_handler;
            RETURN;
          ELSE
            pmp$long_term_wait (icf_interval, icf_interval);
            CYCLE /loop/;
          IFEND;
        ELSE
          icp$set_status_abnormal (stat);
          osp$disestablish_cond_handler;
          pmp$exit (stat);
        CASEND;
      IFEND;
    WHILEND /loop/;

{  Store the file position information.

    icf_file^.position := amc$eop;
    osp$disestablish_cond_handler;

  PROCEND icp$write_end_partition;

MODEND icm$write_end_partition;
*DECK DECK=ICP$ACQUIRE_FROM_NOS_QUEUE EXPAND=FALSE

*IF ($string($name(wev$target_operating_system))='NOS')
  PROCEDURE [XREF] icp$acquire_from_nos_queue ALIAS 'icpqac' (VAR
    acquire_parameter_block: ict$qac_parameter_block);
*ELSE
  PROCEDURE [XREF] icp$acquire_from_nos_queue ALIAS 'icpqac' (VAR
    acquire_parameter_block: ict$qaf_parameter_block);
*IFEND

?? PUSH (LISTEXT := ON) ??
*copyc ICD$QUEUE_ACCESS_DECLARATIONS
?? POP ??
*DECK DECK=ICP$CLOSE EXPAND=FALSE

  PROCEDURE [XREF] icp$close (icf_file: ^icf_open_file_descriptor;
    operation: amt$fap_operation;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMD$OPERATION_DECLARATIONS
*copyc ICF$OPEN_FILE_DESCRIPTOR
*copyc OST$STATUS
?? POP ??

*DECK DECK=ICP$DELETE_PARTNER_JOB EXPAND=FALSE

  PROCEDURE [XREF] icp$delete_partner_job (partner_identification:
    ict$partner_identification;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ICT$PARTNER_MESSAGES
*copyc OST$STATUS
?? POP ??
*DECK DECK=ICP$FETCH_ACCESS_INFO EXPAND=FALSE

  PROCEDURE [XREF] icp$fetch_access_info (icf_file: ^icf_open_file_descriptor;
        operation: amt$fap_operation;
        access_info: ^amt$access_information;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMD$OPERATION_DECLARATIONS
*copyc ICF$OPEN_FILE_DESCRIPTOR
*copyc OST$STATUS
?? POP ??
*DECK DECK=ICP$FLUSH EXPAND=FALSE

  PROCEDURE [XREF] icp$flush (icf_file: ^icf_open_file_descriptor;
    operation: amt$fap_operation;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMD$OPERATION_DECLARATIONS
*copyc ICF$OPEN_FILE_DESCRIPTOR
*copyc OST$STATUS
?? POP ??
*DECK DECK=ICP$GET EXPAND=FALSE

  PROCEDURE [XREF] icp$get (icf_file: ^icf_open_file_descriptor;
    operation: amt$fap_operation;
    working_storage_area: ^cell;
    working_storage_length: amt$working_storage_length;
    transfer_count: ^amt$transfer_count;
    skip_option: amt$skip_option;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_POSITION
*copyc AMT$SKIP_OPTION
*copyc AMD$OPERATION_DECLARATIONS
*copyc AMT$MAX_RECORD_LENGTH
*copyc AMT$TRANSFER_COUNT
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc OST$STATUS
?? POP ??
*DECK DECK=ICP$INITIATE_PARTNER_JOB EXPAND=FALSE

  PROCEDURE [XREF] icp$initiate_partner_job (commands_length:
    ict$partner_commands_length;
        commands_pointer: ^cell;
        data_length: ict$partner_data_length;
        data_pointer: ^cell;
        validation_length: integer;
        validation_pointer: ^cell;
    VAR partner_identification: ict$partner_identification;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ICT$PARTNER_MESSAGES
*copyc OST$STATUS
?? POP ??
*DECK DECK=ICP$JOB_INITIALIZE EXPAND=FALSE

  PROCEDURE [XREF] icp$job_initialize (
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=ICP$OPEN EXPAND=FALSE

  PROCEDURE [XREF] icp$open (icf_file: ^icf_open_file_descriptor;
        operation: amt$fap_operation;
        access_level: amt$access_level;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMD$OPERATION_DECLARATIONS
*copyc AMD$OPEN_DECLARATIONS
*copyc ICF$OPEN_FILE_DESCRIPTOR
*copyc OST$STATUS
?? POP ??
*DECK DECK=ICP$PARTNER_JOB_EXEC_REAL EXPAND=FALSE

  PROCEDURE [XREF] icp$partner_job_exec_real ALIAS 'icppjer';

?? PUSH (LISTEXT := ON) ??
?? POP ??
*DECK DECK=ICP$PJ_ADD_SENDER EXPAND=FALSE

  PROCEDURE [XREF] icp$pj_add_sender (application_name: mlt$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=ICP$PJ_SIGN_OFF EXPAND=FALSE

  PROCEDURE [XREF] icp$pj_sign_off (application_name: mlt$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=ICP$PJ_SIGN_ON EXPAND=FALSE

  PROCEDURE [XREF] icp$pj_sign_on (VAR application_name: mlt$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=ICP$PUT EXPAND=FALSE

  PROCEDURE [XREF] icp$put (icf_file: ^icf_open_file_descriptor;
    operation: amt$fap_operation;
    working_storage_area: ^cell;
    working_storage_length: amt$working_storage_length;
    term_option: amt$term_option;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_POSITION
*copyc AMD$OPERATION_DECLARATIONS
*copyc AMT$TERM_OPTION
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc OST$STATUS
?? POP ??
*DECK DECK=ICP$RECEIVE_FROM_PJ_EXEC EXPAND=FALSE

  PROCEDURE [XREF] icp$receive_from_pj_exec (application_name:
    mlt$application_name;
        buffer_pointer: ^cell;
        buffer_length: mlt$message_length;
    VAR message_length: mlt$message_length;
    VAR arbitrary_info: mlt$arbitrary_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=ICP$REPORT_STATUS_ERROR EXPAND=FALSE

  PROCEDURE [XREF] icp$report_status_error (VAR error_status: ost$status;
        message: string ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=ICP$ROUTE_TO_NOS_INPUT_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] icp$route_to_nos_input_queue ALIAS 'icprout' (VAR
    route_parameter_block: ict$route_parameter_block);

 PROCEDURE [XREF] request_queue_device ALIAS 'rhprqd' ( lfn: integer);

?? PUSH (LISTEXT := ON) ??
*copyc ICD$FILE_ROUTE_DECLARATIONS
?? POP ??
*DECK DECK=ICP$SEND_TO_PJ_EXEC EXPAND=FALSE

  PROCEDURE [XREF] icp$send_to_pj_exec (application_name: mlt$application_name;
        message_pointer: ^cell;
        message_length: mlt$message_length;
        message_type: mlt$arbitrary_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=ICP$SET_STATUS_ABNORMAL EXPAND=FALSE

*copyc ich$set_status_abnormal

  PROCEDURE [XREF] icp$set_status_abnormal
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=ICP$STATUS_PARTNER_JOB EXPAND=FALSE

  PROCEDURE [XREF] icp$status_partner_job (partner_identification:
    ict$partner_identification;
    VAR partner_status: ict$status_partner_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ICT$PARTNER_MESSAGES
*copyc OST$STATUS
?? POP ??
*DECK DECK=ICP$TERMINATE_PARTNER_JOB EXPAND=FALSE

  PROCEDURE [XREF] icp$terminate_partner_job (partner_identification:
    ict$partner_identification;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ICT$PARTNER_MESSAGES
*copyc OST$STATUS
?? POP ??
*DECK DECK=ICP$WRITE_END_PARTITION EXPAND=FALSE

  PROCEDURE [XREF] icp$write_end_partition (icf_file: ^icf_open_file_descriptor;
    operation: amt$fap_operation;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMD$OPERATION_DECLARATIONS
*copyc ICF$OPEN_FILE_DESCRIPTOR
*copyc OST$STATUS
?? POP ??
*DECK DECK=ICS$ICSCLOS EXPAND=TRUE
PROC CLOSLNK (RSTATUS);
      BEGIN  # CLOSLNK #
*copyc ICS$ICSZCOM

      ITEM RSTATUS    U;

      ITEM LOOP$1     U;
      ITEM LOOP$2     U;
      ITEM FWA        U;
      ITEM SIGNAL     B;
      ITEM STAT       U;

      XREF
        BEGIN
        PROC ABORT;
        PROC PAUSE;
        PROC PUTLNK;
        PROC SEND;
        PROC CONFIRM;
        PROC SIGNOFF;
        END

#  INITIALIZE                                                         #

      RSTATUS = MLSOK;
      IF NOT OPENED
      THEN
        BEGIN
        RSTATUS = NOT$OPENED;
        RETURN;
        END

      IF ANY$PUTS
      THEN
        BEGIN
        IF POSITION EQ MID$RECORD
        THEN
          BEGIN  # TERMINATE ANY PRIOR PARTIAL RECORD #
          PUTLNK(FWA,0,TERMINATE,TRUE,STAT);
          IF STAT NQ 0
          THEN
            BEGIN
            RSTATUS  = STAT;
            RETURN;
            END

          END

#  SEND AN EOI INDICATION TO THE 180 PARTNER                          #

        AI$EOI = TRUE;
        AI$EOP = FALSE;
        FIRST$MSG = TRUE;
        LAST$MSG = TRUE;
        FOR LOOP$1 = 0
        DO
          BEGIN  # LOOP 1 #
          SEND (APPL$NAME, ARB$INFO, (SIGNAL), FWA, (0), PARTNER$NAME,
            STAT);

          IF  (STAT EQ MLSOK) OR (STAT EQ MLSSF)
          THEN
            BEGIN
            GOTO LOOP1END;
            END

          IF (STAT EQ MLSBI) OR (STAT EQ MLSBA) OR (STAT EQ MLSPN) OR
            ( STAT EQ MLSRF)
          THEN
            BEGIN
            PAUSE(PAUS$CNT);
            TEST LOOP$1;
            END

          IF (STAT EQ MLSRN)
          THEN
            BEGIN
            RSTATUS = PARTNER$QUIT;
            RETURN;
            END

          ELSE
            BEGIN
            ABORT;
            END

          END  # LOOP 1 #

LOOP1END%
        POSITION = EOI;

#  WAIT FOR THE 180 PARTNER TO RECEIVE THE EOI                        #

        FOR LOOP$2 = 0
        DO
          BEGIN  # LOOP 2 #
          CONFIRM (APPL$NAME, PARTNER$NAME, STAT);

          IF  (STAT EQ MLSOK)
          THEN
            BEGIN
            GOTO LOOP2END;
            END

          IF (STAT EQ MLSBI) OR (STAT EQ MLSPN) OR (STAT EQ MLSRF)
            THEN
            BEGIN
            PAUSE(PAUS$CNT);
            TEST LOOP$2;
            END

          IF (STAT EQ MLSRN)
          THEN
            BEGIN
            RSTATUS = PARTNER$QUIT;
            RETURN;
            END

          ELSE
            BEGIN
            ABORT;
            END

          END  # LOOP 2 #

LOOP2END%

        END

#  SIGN OFF FROM THE MEMORY LINK                                      #

      OPENED = FALSE;
      SIGNOFF (APPL$NAME, STAT);
      IF (STAT NQ MLSOK) AND (STAT NQ MLSRN) AND (STAT NQ MLSQL)
      THEN
        BEGIN
        ABORT;
        END


      END  # CLOSLNK #

    TERM
*DECK DECK=ICS$ICSGET EXPAND=TRUE
PROC  GETLNK ( WS$AREA, (WS$LENGTH), TRANSFER$CNT, ( SKIP$OPTION),
      (   PARTIAL), BITS, RSTATUS);
      BEGIN  # GETLNK #
*copyc ICS$ICSZCOM
      ARRAY WS$AREA [1%1] S(1);
        BEGIN
        ITEM FWA        U;
        END

      ITEM WS$LENGTH  U;
      ITEM TRANSFER$CNT U;
      ITEM SKIP$OPTION U;
      ITEM PARTIAL    B;
      ITEM BITS       U;
      ITEM RSTATUS    U;
      ITEM BUSY$COUNT U;

      ARRAY BUFFER [1%MAX$MSG$LEN] S(1);
        BEGIN
        ITEM BUFF       U;
        END

      ITEM LOOP$1     U;
      ITEM LOOP$2     U;
      ITEM RECEIVE$LOOP U;
      ITEM OFFSET     U;
      ITEM LIMIT      U;
      ITEM I          U;
      ITEM MSG$LEN    U;
      ITEM FETCH$CNT  U;
      ITEM ZLR        B;
      ITEM BUFF$IN    U;
      ITEM BUFF$OUT   U;
      ITEM SIGNAL     B = TRUE;
      ITEM STAT       U;
      ITEM PARTNER$SAVE U;
      XREF
        BEGIN
        PROC ABORT;
        PROC CONFIRM;
        PROC PAUSE;
        PROC RECEIVE;
        END

                                               CONTROL EJECT;
#  RECEIVE THE NEXT MESSAGE INTO THE MESSAGE BUFFER                   #

PROC RECEIVER;
        BEGIN  # RECEIVER #
        BUSY$COUNT = BUSY$CNT;
        FOR RECEIVE$LOOP = 0
        DO
          BEGIN  # RECEIVE LOOP #
          RECEIVE (APPL$NAME, ARB$INFO, (SIGNAL), BUFFER[1], MSG$LEN,
            MAX$MSG$LEN, 0, PARTNER$SAVE, STAT);
          IF  (STAT EQ MLSOK) OR (STAT EQ MLSSF)
            THEN
            BEGIN
            GOTO LOOPEND;
            END

          ELSE
            BEGIN
            IF (STAT EQ MLSBI) OR (STAT EQ MLSII)
            THEN
              BEGIN
              PAUSE(PAUS$CNT);
              IF (BUSY$COUNT EQ 0)
              THEN
                BEGIN
                CONFIRM (APPL$NAME, PARTNER$NAME, STAT);
                IF (STAT EQ MLSRN)
                THEN
                  BEGIN
                  STAT = PARTNER$QUIT;
                  RETURN;
                  END

                ELSE
                  BEGIN
                  BUSY$COUNT = BUSY$CNT;
                  END


                END

              BUSY$COUNT = BUSY$COUNT - 1;
              TEST RECEIVE$LOOP;
              END

            ELSE
              BEGIN
              ABORT;
              END


            END

          END  # RECEIVE LOOP #

LOOPEND%
        ZLR = (MSG$LEN EQ 0);
        BUFF$IN = MSG$LEN;
        BUFF$OUT = 0;

        END  # RECEIVER #

                                               CONTROL EJECT;
#  BODY OF GETLNK                                                     #

#  INITIALIZE                                                         #


      RSTATUS = MLSOK;
      BITS = 0;
      ZLR = FALSE;
      OFFSET = 0;
      IF NOT OPENED
      THEN
        BEGIN
        RSTATUS = NOT$OPENED;
        RETURN;
        END

#  SKIP PAST ANY PARTIAL RECORDS UNTIL THE BEGINNING OF A             #
#  RECORD IS FOUND                                                    #

      IF (NOT PARTIAL) OR (SKIP$OPTION EQ SKIP$TO$EOR)
      THEN
        BEGIN
        RECORD$LEN = 0;
        FIRST$MSG = FALSE;
        FOR LOOP$1 = 0 WHILE NOT FIRST$MSG
        DO
          BEGIN
          RECEIVER;
          IF (STAT EQ PARTNER$QUIT)
          THEN
            BEGIN
            RSTATUS = STAT;
            RETURN;
            END

          END

        END

#  TRANSFER DATA FROM THE BUFFER UNTIL THE END OF A RECORD            #
#  IS REACHED OR THE USERS RECORD AREA IS FILLED.  CALL               #
#  PROCEDURE RECEIVER TO FILL OR REPLENISH THE BUFFER AS              #
#  NEEDED                                                             #

      FOR LOOP$2 = 0
      DO
        BEGIN  # LOOP 2 #
        IF (BUFF$OUT GQ BUFF$IN) AND (OFFSET LS WS$LENGTH) AND (NOT
          ZLR)
          THEN
          BEGIN
          RECEIVER;
          IF (STAT EQ PARTNER$QUIT)
          THEN
            BEGIN
            RSTATUS = STAT;
            RETURN;
            END

          END

        IF (OFFSET LQ WS$LENGTH) AND (BUFF$OUT LS BUFF$IN)
        THEN
          BEGIN
          IF (WS$LENGTH - OFFSET) LS (BUFF$IN - BUFF$OUT)
          THEN
            BEGIN
            LIMIT = WS$LENGTH - OFFSET;
            END

          ELSE
            BEGIN
            LIMIT = BUFF$IN - BUFF$OUT;
            END

          FOR I=1 STEP 1 UNTIL LIMIT
          DO
            BEGIN
            FWA[OFFSET + I] = BUFF[BUFF$OUT + I];
            END

          OFFSET = OFFSET + LIMIT;
          BUFF$OUT= BUFF$OUT + LIMIT;
          END

        IF (OFFSET GQ WS$LENGTH) OR ((BUFF$OUT GQ BUFF$IN) AND
          LAST$MSG)
          THEN
          BEGIN
          GOTO LOOP2END;
          END

        END  # LOOP 2 #

LOOP2END%
      TRANSFER$CNT = OFFSET;

#  STORE THE FILE POSITION INFORMATION                                #

      IF LAST$MSG
      THEN
        BEGIN
        IF AI$EOI
        THEN
          BEGIN
          POSITION = EOI;
          END

        ELSE
          BEGIN
          IF AI$EOP
          THEN
            BEGIN
            POSITION = EOP;
            END

          ELSE
            BEGIN
            IF BUFF$OUT LS BUFF$IN
            THEN
              BEGIN
              POSITION = MID$RECORD;
              END

            ELSE
              BEGIN
              BITS = UNUSED$BITS;
              POSITION = EOR;
              END

            END

          END

        END

      ELSE
        BEGIN
        POSITION = MID$RECORD;
        END


      END  # GETLNK #

    TERM
*DECK DECK=ICS$ICSGETN EXPAND=TRUE
PROC  GETNLNK ( WS$AREA, WS$LENGTH, TRANSFER$CNT, BITS , FPOSITION
      , RSTATUS);
      BEGIN  # GETNLNK #
*copyc ICS$ICSZCOM
      ITEM WS$AREA    U;
      ITEM WS$LENGTH  U;
      ITEM TRANSFER$CNT U;
      ITEM BITS       U;
      ITEM FPOSITION  U;
      ITEM RSTATUS    U;

      ITEM STAT       U;

      XREF
        BEGIN
        PROC GETLNK;
        END

      IF POSITION EQ EOI
      THEN
        BEGIN
        FPOSITION = EOI;
        TRANSFER$CNT = 0;
        BITS = 0;
        RSTATUS = GETAFTEREOI;
        RETURN;
        END

      GETLNK (WS$AREA,WS$LENGTH,TRANSFER$CNT,(SKIP$TO$EOR), (FALSE ) ,
        BITS, STAT);
      FPOSITION = POSITION;
      RSTATUS = STAT;

      END  # GETNLNK #

    TERM
*DECK DECK=ICS$ICSGETP EXPAND=TRUE
PROC  GETPLNK ( WS$AREA, WS$LENGTH, TRANSFER$CNT, BITS , FPOSITION
      , RSTATUS);
      BEGIN  # GETPLNK #
*copyc ICS$ICSZCOM
      ITEM WS$AREA    U;
      ITEM WS$LENGTH  U;
      ITEM TRANSFER$CNT U;
      ITEM BITS       U;
      ITEM FPOSITION  U;
      ITEM RSTATUS    U;

      ITEM STAT       U;

      XREF
        BEGIN
        PROC GETLNK;
        END

      IF POSITION EQ EOI
      THEN
        BEGIN
        FPOSITION = EOI;
        TRANSFER$CNT = 0;
        BITS = 0;
        RSTATUS = GETAFTEREOI;
        RETURN;
        END

      GETLNK (WS$AREA,WS$LENGTH,TRANSFER$CNT,(NO$SKIP), (TRUE) , BITS,
        STAT);
      FPOSITION = POSITION;
      RSTATUS = STAT;

      END  # GETPLNK #

    TERM
*DECK DECK=ICS$ICSMLIF EXPAND=TRUE
PROC MLIF(APPL$NAME,MAX$MSGS,UNIQ$NAME, PARTNER$NAME,ARB$INFO,
      SIGNAL   , WSA,MSG$LEN,WSA$LEN, RCV$INDEX,FETCH$CNT,FRL$LIST,
      RSTATUS);
      BEGIN  # MLIF #

#  THE FOLLOWING SYMPL DEFINITION OF ARRAY MLIPAR MIRRORS THE         #
#  THE COMPASS DEFINITION THAT IS FOUND IN COMMON DECK COMSMLI        #

      XREF
        ARRAY MLIPAR [0,0] S(14);    # MLI REQUEST BLOCK #
        BEGIN
        ITEM MLPAN      U(0,0,60);   # APPLICATION NAME #
        ITEM MLPSN      U(1,0,60);   # SENDER APPLICATION NAME #
        ITEM MLPST      U(2,0,60);   # STATUS RETURN ADDRESS #
        ITEM MLPFN      U(3,0,60);   # MLI FUNCTION NUMBER #
        ITEM MLPCN      U(4,0,60);   # COUNT OF MESSAGES FOR FETCHRL #
        ITEM MLPMM      U(4,0,60);   # MAX MESSAGES #
        ITEM MLPRI      U(4,0,60);   # RECEIVE INDEX #
        ITEM MLPFA      U(5,0,60);   # FIRST WORD ADDRESS OF BUFFER #
        ITEM MLPJS      U(5,0,60);   # JSN FOR SIGNON/SIGNOFF #
        ITEM MLPBL      U(6,0,60);   # MESSAGE BUFFER LENGTH #
        ITEM MLPSG      U(7,0,60);   # VALUE OF SIGNAL FLAG #
        ITEM MLPAR      U(8,0,60);   # ARBITRARY INFORMATION #
        ITEM MLPLN      U(9,0,60);   # MESSAGE LENGTH RETURNED #
          ITEM MLPSV      U(10,0,60);  # RETURNED STATUS VALUE #
          ITEM MLPV1      U(11,0,60);  # RETURNED VALUE 1 #
          ITEM MLPV2      U(12,0,60);  # RETURNED VALUE 2 #
          ITEM MLPV3      U(13,0,60);  # RETURNED VALUE 3 #
          END


      XREF
        BEGIN
        PROC MLIQ;                   # MLI= #
        END


#  THE FOLLOWING SYMPL DEFINITION OF ML FUNCTION CODES MIRRORS        #
#  THE COMPASS DEFINITION THAT IS FOUND IN COMMON DECK COMSMLI        #

      DEF MLFON   #0#;               # SIGNON #
      DEF MLFOF      #1#;            # SIGNOFF #
      DEF MLFAD      #2#;            # ADDSPL #
      DEF MLFDE      #3#;            # DELSPL #
      DEF MLFSE      #4#;            # SEND #
      DEF MLFRE      #5#;            # RECEIVE #
      DEF MLFFE      #6#;            # FETCHRL #
      DEF MLFCO      #7#;            # CONFIRM #
      DEF MLFKI      #8#;            # KILL 170 JOB #
      DEF MLFKA      #9#;            # KILL ALL 170 JOBS #

      ITEM APPL$NAME  U;
      ITEM MAX$MSGS   U;
      ITEM UNIQ$NAME  U;
      ITEM RSTATUS    U;
      ITEM PARTNER$NAME U;
      ITEM ARB$INFO   U;
      ITEM SIGNAL     U;
      ITEM WSA        U;
      ITEM MSG$LEN    U;
      ITEM WSA$LEN    U;
      ITEM RCV$INDEX  U;
      ITEM FETCH$CNT  U;
      ITEM FRL$LIST   U;

PROC MLI$IF;
        BEGIN  # MLI$IF #
        MLPAN = APPL$NAME;
        MLPST = LOC(RSTATUS);
        MLIQ;
        RSTATUS = MLPSV;
        END  # MLI$IF #


#  THE FOLLOWING ALTERNATE ENTRY POINTS CONSTITUE THE                 #
#  SYMPL-CALLABLE INTERFACE TO THE MEMORY LINK. THE                   #
#  PRINCIPAL ENTRY POINT ITSELF (PROC MLIF) IS A DUMMY                #
#  THAT IS NOT INTENDED TO BE CALLED.                                 #

      ENTRY
PROC ADDSPL (APPL$NAME,PARTNER$NAME,RSTATUS);
      MLPSN = PARTNER$NAME;
      MLPFN = MLFAD;
      MLI$IF;
      RETURN;

      ENTRY
PROC CONFIRM (APPL$NAME,PARTNER$NAME,RSTATUS);
      MLPSN = PARTNER$NAME;
      MLPFN = MLFCO;
      MLI$IF;
      RETURN;

      ENTRY
PROC DELSPL (APPL$NAME,PARTNER$NAME,RSTATUS);
      MLPSN = PARTNER$NAME;
      MLPFN = MLFDE;
      MLI$IF;
      RETURN;

      ENTRY
PROC FETCHRL (APPL$NAME,PARTNER$NAME,FRL$LIST, FETCH$CNT,RSTATUS
        );
      MLPSN = PARTNER$NAME;
      MLPCN = LOC(FETCH$CNT);
      MLPFA=LOC(FRL$LIST);
      MLPFN = MLFFE;
      MLI$IF;
      FETCH$CNT = MLPV1;
      RETURN;

      ENTRY
PROC SIGNOFF (APPL$NAME,RSTATUS);
      MLPFN = MLFOF;
      MLI$IF;
      RETURN;

      ENTRY
PROC SIGNON (APPL$NAME,MAX$MSGS,UNIQ$NAME, RSTATUS);
      MLPMM=MAX$MSGS;
      MLPSN = LOC(UNIQ$NAME);
      MLPFN = MLFON;
      MLI$IF;
      UNIQ$NAME = MLPV1;
      RETURN;

      ENTRY
PROC RECEIVE (APPL$NAME,ARB$INFO,SIGNAL, WSA,MSG$LEN,WSA$LEN,
        RCV$INDEX,PARTNER$NAME,RSTATUS);
      MLPRI = RCV$INDEX;
      MLPFA = LOC(WSA);
      MLPBL = WSA$LEN;
      IF SIGNAL EQ 0
      THEN
        BEGIN
        MLPSG = O"377777";
        END

      ELSE
        BEGIN
        MLPSG = LOC(SIGNAL);
        MLPSV = SIGNAL;
        END

      MLPLN = LOC(MSG$LEN);
      MLPAR = LOC(ARB$INFO);
      MLPSN = LOC(PARTNER$NAME);
      MLPFN = MLFRE;
      MLI$IF;
      MSG$LEN = MLPV1;
      ARB$INFO = MLPV2;
      PARTNER$NAME = MLPV3;
      RETURN;

      ENTRY
PROC SEND (APPL$NAME,ARB$INFO,SIGNAL, WSA,MSG$LEN,PARTNER$NAME,
        RSTATUS);
      MLPSN = PARTNER$NAME;
      MLPAR = ARB$INFO;
      MLPFA = LOC(WSA);
      MLPBL = MSG$LEN;
      IF SIGNAL EQ 0
      THEN
        BEGIN
        MLPSG = O"377777";
        END

      ELSE
        BEGIN
        MLPSG = LOC(SIGNAL);
        MLPSV = SIGNAL;
        END

      MLPFN = MLFSE;
      MLI$IF;
      RETURN;

      END  # MLIF #

    TERM
*DECK DECK=ICS$ICSOPEN EXPAND=TRUE
PROC OPENLNK (RSTATUS);
CONTROL PRESET;
      BEGIN  # OPENLNK #
*copyc ICS$ICSZCOM
      ITEM RSTATUS    U;

      ITEM LOOP$1     U;
      ITEM LOOP$2     U;
      ITEM LOOP$3     U;
      ITEM STAT       U;
      ARRAY FET S(6);
        BEGIN
        ITEM FET$LFN    U(00,00,42);
        ITEM FET$LOCK   B(00,59,01);
        ITEM FET$FRST   U(01,42,18);
        ITEM FET$IN     U(02,42,18);
        ITEM FET$OUT    U(03,42,18);
        ITEM FET$LIM    U(04,42,18);
        END

      ARRAY BUF [64] S(1);
        BEGIN
        ITEM FW         U(00,00,60);
        END

      XREF
        BEGIN
        PROC ABORT;
        PROC ADDSPL;
        PROC CONFIRM;
        PROC PAUSE;
        PROC READSKP;
        PROC REWIND;
        PROC SIGNON;
        END

      DEF RCL #1#;

#  INITIALIZE                                                         #

      RSTATUS = MLSOK;
      IF OPENED
      THEN
        BEGIN
        RSTATUS = SECOND$OPEN;
        RETURN;
        END

#  READ NAME OF 180 PARTNER FROM SECOND RECORD OF INPUT FILE.         #

      FET$LFN[0] = O"11162025240000";  # INPUT #
      FET$LOCK[0] = TRUE;
      FET$FRST[0] = LOC(FW[0]);
      FET$IN[0] = FET$FRST[0];
      FET$OUT[0] = FET$FRST[0];
      FET$LIM[0] = FET$FRST[0] + 65;
      REWIND(FET[0],RCL);
      READSKP(FET[0],(0),RCL);
      FET$IN[0] = FET$FRST[0];
      READSKP(FET[0],(0), RCL);
      PARTNER$NAME = FW[0];

#  SIGN ON TO THE MEMORY LINK                                         #

      FOR LOOP$1 = 0
      DO
        BEGIN  # LOOP 1 #
        SIGNON ((0), (1), APPL$NAME, STAT);
        IF (STAT EQ MLSOK)
        THEN
          BEGIN
          GOTO LOOP1END;
          END

        IF (STAT EQ MLSBI) OR (STAT EQ MLSBA)
        THEN
          BEGIN
          PAUSE(PAUS$CNT);
          TEST LOOP$1;
          END

        IF (STAT EQ MLSND) OR (STAT EQ MLSIF)
        THEN
          BEGIN
          RSTATUS = BAD$OPEN;
          RETURN;
          END

        ABORT;
        END  # LOOP 1 #

LOOP1END%

#  PERMIT THE 180 PARTNER TO SEND TO US                               #

      FOR LOOP$2 = 0
      DO
        BEGIN  # LOOP 2 #
        ADDSPL (APPL$NAME, PARTNER$NAME, STAT);
        IF (STAT EQ MLSOK) OR (STAT EQ MLSRN)
        THEN
          BEGIN
          GOTO LOOP2END;
          END

        IF (STAT EQ MLSBI)
        THEN
          BEGIN
          PAUSE(PAUS$CNT);
          TEST LOOP$2;
          END

        ABORT;
        END  # LOOP 2 #

LOOP2END%

#  WAIT FOR 180 PARTNER TO COMPLETE ITS OPEN SEQUENCE                 #

      FOR LOOP$3 = 0
      DO
        BEGIN  # LOOP 3 #
        CONFIRM (APPL$NAME, PARTNER$NAME, STAT);
        IF (STAT EQ MLSOK)
        THEN
          BEGIN
          GOTO LOOP3END;
          END

        IF (STAT EQ MLSBI) OR (STAT EQ MLSSP)
        THEN
          BEGIN
          PAUSE(PAUS$CNT);
          TEST LOOP$3;
          END

        IF (STAT EQ MLSRN)
        THEN
          BEGIN
          RSTATUS = PARTNER$QUIT;
          RETURN;
          END

        ABORT;
        END  # LOOP 3 #

LOOP3END%

      OPENED = TRUE;
      POSITION = EOR;
      ANY$PUTS = FALSE;
      END  # OPENLNK #

    TERM
*DECK DECK=ICS$ICSPUT EXPAND=TRUE
PROC PUTLNK (WS$AREA, WS$LENGTH, (TERM$OPTION), ( PARTIAL   ),
      RSTATUS   ) ;
      BEGIN  # PUTLNK #
*copyc ICS$ICSZCOM

ARRAY WS$AREA [0] S(1);;
      ITEM WS$LENGTH  U;
      ITEM TERM$OPTION U;
      ITEM PARTIAL    B;
      ITEM RSTATUS    U;

      ITEM OUTER$LOOP U;
      ITEM INNER$LOOP U;
      ITEM OFFSET     U;
      ITEM MSG$LEN    U;
      ITEM STAT       U;
      ITEM SIGNAL     B = TRUE;

      XREF
        BEGIN
        PROC ABORT;
        PROC PAUSE;
        PROC SEND;
        END

#  INITIALIZE                                                         #

      RSTATUS = 0;
      IF NOT OPENED
      THEN
        BEGIN
        RSTATUS = NOT$OPENED;
        RETURN;
        END

      OFFSET = 0;
      ANY$PUTS = TRUE;

#  SEND DATA UNTIL THE USERS RECORD AREA IS EMPTY                     #

CONTROL FASTLOOP;
      FOR OUTER$LOOP = 0 WHILE OFFSET LS WS$LENGTH
      DO
        BEGIN  # OUTER LOOP #
        IF (WS$LENGTH - OFFSET) LS MAX$MSG$LEN
        THEN
          BEGIN
          MSG$LEN = (WS$LENGTH - OFFSET);
          END

        ELSE
          BEGIN
          MSG$LEN = MAX$MSG$LEN;
          END

        FIRST$MSG = (OFFSET EQ 0) AND ((NOT PARTIAL) OR (PARTIAL AND (
          TERM$OPTION EQ START)) OR (PARTIAL AND (
          POSITION NQ MID$RECORD)));
        LAST$MSG = ((OFFSET + MSG$LEN) GQ WS$LENGTH) AND (NOT PARTIAL
          OR (PARTIAL AND ( TERM$OPTION EQ TERMINATE)));
        AI$EOI = FALSE;
        AI$EOP = FALSE;
        UNUSED$BITS = 0;
        IF FIRST$MSG
        THEN
          BEGIN
          RECORD$LEN = 0;
          END

        FOR INNER$LOOP = 0
        DO
          BEGIN  # INNER LOOP #
          SEND (APPL$NAME, ARB$INFO, (SIGNAL), WS$AREA[OFFSET],
            MSG$LEN, PARTNER$NAME, STAT);

          IF (STAT EQ MLSOK) OR (STAT EQ MLSSF)
          THEN
            BEGIN
            GOTO INNEREND;
            END

          ELSE
            BEGIN
            IF (STAT EQ MLSBI) OR (STAT EQ MLSBA) OR (STAT EQ MLSPN)
              OR (STAT EQ MLSRF)
            THEN
              BEGIN
              PAUSE(PAUS$CNT);
              TEST INNER$LOOP;
              END

            ELSE
              BEGIN
              IF (STAT EQ MLSRN)
              THEN
                BEGIN
                RSTATUS = PARTNER$QUIT;
                RETURN;
                END

              ELSE
                BEGIN
                ABORT;
                END

              END

            END

          END  # INNER LOOP #

 INNEREND%
        OFFSET = OFFSET + MSG$LEN;
        RECORD$LEN = RECORD$LEN + MSG$LEN;
        END  # OUTER LOOP #

#  STORE THE FILE POSITION INFORMATION                                #


      IF LAST$MSG
      THEN
        BEGIN
        POSITION = EOR;
        END

      ELSE
        BEGIN
        POSITION = MID$RECORD;
        END

      END  # PUTLNK #

    TERM
*DECK DECK=ICS$ICSPUTN EXPAND=TRUE
PROC  PUTNLNK ( WS$AREA, WS$LENGTH, RSTATUS);
      BEGIN  # PUTNLNK #
*copyc ICS$ICSZCOM
      ITEM WS$AREA    U;
      ITEM WS$LENGTH  U;
      ITEM RSTATUS    U;

      ITEM STAT       U;

      XREF
        BEGIN
        PROC PUTLNK;
        END

      IF POSITION EQ MID$RECORD
      THEN
        BEGIN  # TERMINATE ANY PRIOR PARTIAL RECORD #
        PUTLNK(WS$AREA,0,TERMINATE,TRUE,STAT);
        IF STAT NQ 0
        THEN
          BEGIN
          RSTATUS  = STAT;
          RETURN;
          END

        END

      PUTLNK (WS$AREA,WS$LENGTH,(START),(FALSE),STAT);
      RSTATUS = STAT;

      END  # PUTNLNK #

    TERM
*DECK DECK=ICS$ICSPUTP EXPAND=TRUE
PROC  PUTPLNK ( WS$AREA, WS$LENGTH, (TERM$OPTION), RSTATUS);
      BEGIN  # PUTPLNK #
*copyc ICS$ICSZCOM
      ITEM WS$AREA    U;
      ITEM WS$LENGTH  U;
      ITEM TERM$OPTION U;
      ITEM RSTATUS    U;

      ITEM STAT       U;

      XREF
        BEGIN
        PROC PUTLNK;
        END

      IF (TERM$OPTION EQ CONTINUE) AND (POSITION NQ MID$RECORD)
      THEN
        BEGIN
        RSTATUS = CONTNOTMID;
        RETURN;
        END

      IF (TERM$OPTION EQ START) AND (POSITION EQ MID$RECORD)
      THEN
        BEGIN  # TERMINATE ANY PRIOR PARTIAL RECORD #
        PUTLNK(WS$AREA,0,TERMINATE,TRUE,STAT);
        IF STAT NQ 0
        THEN
          BEGIN
          RSTATUS  = STAT;
          RETURN;
          END

        END

      PUTLNK (WS$AREA,WS$LENGTH,(TERM$OPTION),(TRUE),STAT);
      RSTATUS = STAT;

      END  # PUTPLNK #

    TERM
*DECK DECK=ICS$ICSWEOP EXPAND=TRUE
PROC WREPLNK (RSTATUS);
      BEGIN  # WREPLNK #
*copyc ICS$ICSZCOM
      ITEM RSTATUS    U;

      ITEM OUTER$LOOP U;
      ITEM FWA        U;
      ITEM SIGNAL     B;
      ITEM STAT       U;

      XREF
        BEGIN
        PROC ABORT;
        PROC PAUSE;
        PROC PUTLNK;
        PROC SEND;
        END

#  INITIALIZE                                                         #

      RSTATUS = MLSOK;
      IF NOT OPENED
      THEN
        BEGIN
        RSTATUS = NOT$OPENED;
        RETURN;
        END

#  TERMINATE ANY PRIOR PARTIAL RECORD                                 #

      IF POSITION EQ MID$RECORD
      THEN
        BEGIN
        PUTLNK (FWA, (0), (TERMINATE),(FALSE), STAT);
        IF RSTATUS NQ MLSOK
        THEN
          BEGIN
          RSTATUS = STAT;
          RETURN;
          END

        END

      AI$EOP = TRUE;
      FIRST$MSG = TRUE;
      LAST$MSG = TRUE;

#  SEND THE EOP INDICATION                                            #

      FOR OUTER$LOOP = 0
      DO
        BEGIN  # OUTER$LOOP #
        SEND (APPL$NAME, ARB$INFO, (SIGNAL), FWA, (0), PARTNER$NAME,
          STAT);
        IF  (RSTATUS EQ MLSOK) OR (RSTATUS EQ MLSSF)
        THEN
          BEGIN
          GOTO OUTEREND;
          END

        IF (RSTATUS EQ MLSBI) OR (RSTATUS EQ MLSPN) OR (RSTATUS EQ
          MLSRF) OR (RSTATUS EQ MLSBA)
        THEN
          BEGIN
          PAUSE(PAUS$CNT);
          TEST OUTER$LOOP;
          END

        IF (RSTATUS EQ MLSRN)
        THEN
          BEGIN
          RSTATUS = PARTNER$QUIT;
          RETURN;
          END

        ELSE
          BEGIN
          ABORT;
          END

        END  # OUTER$LOOP #

OUTEREND%

#  STORE THE FILE POSITION INFORMATION                                #

      POSITION = EOP;
      ANY$PUTS = TRUE;
      END  # WREPLNK #

    TERM
*DECK DECK=ICS$ICSZCOM EXPAND=FALSE
      BEGIN  # ICSZCOM #
                                               CONTROL FTNCALL;
      DEF MAX$MSG$LEN #3074#;
      DEF PAUS$CNT   #5#;
      DEF BUSY$CNT   #100#;
      DEF START      #1#;
      DEF CONTINUE   #2#;
      DEF TERMINATE  #3#;
      DEF MID$RECORD #1#;
      DEF SKIP$TO$EOR #1#;
      DEF NO$SKIP    #2#;
      DEF EOR        #2#;
      DEF EOP        #3#;
      DEF EOI        #4#;
      DEF NOT$OPENED #1#;
      DEF PARTNER$QUIT #2#;
      DEF SECOND$OPEN #1#;
      DEF BAD$OPEN   #1#;
      DEF CONTNOTMID #3#;
      DEF GETAFTEREOI #3#;

#  THE FOLLOWING SYMPL DEFINITION OF THE MEMORY LINK STATUS           #
#  RESPONSES MIRRORS THE COMPASS DEFINITION THAT IS FOUND             #
#  IN COMMON DECK COMSMLI                                             #

      DEF MLSOK      #0#;            # MLC$OK #
      DEF MLSRS      #1#;            # MLC$RECEIVER$NAME$SYNTAX$ERROR #
      DEF MLSSS      #2#;            # MLC$SENDER$NAME$SYNTAX$ERROR #
      DEF MLSRN      #3#;            # MLC$RECEIVER$NOT$SIGNED$ON #
      DEF MLSSM      #4#;            # MLC$SYSTEM$NAME$NO$MATCH #
      DEF MLSBI      #5#;            # MLC$BUSSY$INTERLOCK #
      DEF MLSDI      #6#;            # MLC$DUP$PERMIT$IGNORED #
      DEF MLSPF      #7#;            # MLC$PERMIT$LIST$FULL #
      DEF MLSSN      #8#;            # MLC$SENDER$NOT$SIGNED$ON #
      DEF MLSCI      #9#;            # MLC$C170$C170$ILLEGAL #
      DEF MLSSP      #10#;           # MLC$SENDER$NOT$PERMITTED #
      DEF MLSPN      #11#;           # MLC$PRIOR$MSG$NOT$RECEIVED #
      DEF MLSRF      #12#;           # MLC$RECEIVE$LIST$FULL #
      DEF MLSMQ      #13#;           # MLC$MSGS$FROM$SENDER$QUEUED #
      DEF MLSII      #14#;           # MLC$RECEIVE$LIST$INDEX$INVALID #
      DEF MLSMT      #15#;           # MLC$MESSAGE$TRUNCATED #
      DEF MLSSC      #16#;           # MLC$SIGNAL$TO$C170$IGNORED #
      DEF MLSTL      #17#;           # MLC$MESSAGE$TOO$LONG #
      DEF MLSBA      #18#;           # MLC$POOL$BUFFER$NOT$AVAIL #
      DEF MLSSF      #19#;           # MLC$SIGNAL$FAILED$IGNORED #
      DEF MLSQL      #20#;           # MLC$QUEUED$MSGS$LOST #
      DEF MLSSA      #21#;           # MLC$MAX$SIGNONS$THIS$APPL #
      DEF MLSML      #22#;           # MLC$MAX$MSGS$TOO$LARGE$ #
      DEF MLSAF      #23#;           # MLC$ANT$FULL #
      DEF MLSST      #24#;           # MLC$MAX$SIGNONS$THIS$TASK #
      DEF MLSIE      #25#;           # MLC$MLI$INTERNAL$ERROR #
      DEF MLSIF      #26#;           # MLC$ILLEGAL$FUNCTION #
      DEF MLSAE      #27#;           # MLC$BAD$C170$PARAMETER #
      DEF MLSND      #28#;           # MLC$NOSVE$NOT$UP #

      ARRAY ARB$INFO [0] S(1);
        BEGIN
        ITEM UNUSED$BITS U(0,50,6);
        ITEM AI$EOI     B(0,56,1);
        ITEM AI$EOP     B(0,57,1);
        ITEM FIRST$MSG  B(0,58,1);
        ITEM LAST$MSG   B(0,59,1);
        END

      COMMON ICF$FILE;
        BEGIN
        ITEM APPL$NAME  U = 0;
        ITEM PARTNER$NAME U = 0;
        ITEM POSITION   U = EOR;
        ITEM RECORD$LEN U = 0;
        ITEM OPENED     B = FALSE;
        ITEM ANY$PUTS   B = FALSE;

        END

      END  # ICSZCOM #

*DECK DECK=ICT$PARTNER_MESSAGES EXPAND=FALSE

?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc MLT$PARTNER_JOB_UNIQUE_ID
?? POP ??

  CONST
    icc$pj_exec_application_name = 9d0285(16), { 'ICPJE'/10289797(10) }
    icc$pj_exec_time_delay = 100,
    icc$pj_exec_job_limit_delay = 2000,
    icc$max_message_length = mlc$max_message_length DIV 8,
    icc$max_partner_image_length = icc$max_message_length - 2,
    icc$max_open_files_per_job = 1,
    icc$validation_image_length = 38;

  TYPE

    ict$partner_messages = (icc$initiate_partner_request,
      icc$initiate_partner_response, icc$status_partner_request,
      icc$status_partner_response, icc$terminate_partner_request,
      icc$terminate_partner_response, icc$delete_partner_request,
      icc$delete_partner_response),

    ict$general_message = array [1 .. icc$max_message_length] of integer,

{ Initiate partner job request message.

    ict$initiate_partner_request = packed record
      commands_length: integer,
      data_length: integer,
      partner_image: array [1 .. icc$max_partner_image_length-
        icc$validation_image_length] of ict$partner_image_word,
      validation_image: array[1..icc$validation_image_length] of
        ict$partner_image_word,
    recend,

{ Initiate partner job response message.

    ict$initiate_partner_response = packed record
      initiate_status: integer,
      partner_identification: ict$partner_identification,
    recend,

{ Status partner job request message.

    ict$status_partner_request = packed record
      partner_identification: ict$partner_identification,
    recend,

{ Status partner job response message.

    ict$status_partner_response = packed record
      partner_status: integer,
    recend,

{ Terminate partner job request message.

    ict$terminate_partner_request = packed record
      partner_identification: ict$partner_identification,
    recend,

{ Delete partner job response message.

    ict$terminate_partner_response = packed record
      terminate_status: integer,
    recend,

{ Delete partner job request message.

    ict$delete_partner_request = packed record
      partner_identification: ict$partner_identification,
    recend,

{ Delete partner job response message.

    ict$delete_partner_response = packed record
      delete_status: integer,
    recend,

    ict$partner_commands_length = 0 .. icc$max_partner_image_length,

    ict$partner_data_length = 0 .. icc$max_partner_image_length,

    ict$partner_image_word = integer,

    ict$initiate_partner_status = (icc$partner_started_ok,
      icc$partner_job_limit_exceeded, icc$partner_start_failed),

    ict$partner_identification = record
      application_name: mlt$application_name,
      job_name: ict$partner_job_name,
      job_unique_id: mlt$partner_job_unique_id,
    recend,

    ict$partner_job_name = integer,

    ict$route_partner_status = (icc$partner_route_ok,
      icc$partner_route_failed),

    ict$status_partner_status = (icc$partner_not_found,
      icc$partner_in_input_queue, icc$partner_not_signed_on,
      icc$partner_signed_on),

    ict$terminate_partner_status = (icc$partner_terminated_ok,
      icc$no_term_in_input_queue, icc$no_term_not_signed_on,
      icc$no_term_not_found),

    ict$partner_queue_status = (icc$partner_queue_input,
      icc$partner_queue_executing, icc$partner_not_in_queues),

    ict$delete_partner_status = (icc$partner_deleted_ok,
      icc$no_delete_not_found,icc$delete_ok_sign_off_failed);
*DECK DECK=ICV$OPEN_FILE_COUNT_LOCK EXPAND=FALSE

  VAR

    icv$open_file_count_lock: [XREF] ost$signature_lock,
    icv$open_file_count: [XREF] integer;

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??
*DECK DECK=ICV$PJ_SIGNED_ON EXPAND=FALSE

  VAR

    icv$pj_signed_on: [XREF] boolean,
    icv$pj_application_name: [XREF] mlt$application_name;

?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=IFC$INTERRUPT EXPAND=FALSE
{
{ IFC$INTERRUPT:
{
{   This deck defines the interactive interrupt condition code
{ (ifc$interrupt).  The interrupt condition is sent to a task using the
{ ifp$send_interrupt_condition request.  The ifc$interrupt condition code
{ can be used with the pmp$establish_condition_handler to select the
{ interactive interrupt condition or within the condition handler to
{ determine that the interrupt condition has occurred.
{


 CONST
    ifc$interrupt = 5;
*DECK DECK=IFC$INTERRUPT_TIMESHARING_IO EXPAND=FALSE

  CONST
    ifc$interrupt_timesharing_io = 'IFC$INTERRUPT_TIMESHARING_IO   ';
*DECK DECK=IFC$TERMINAL_CONSTANTS EXPAND=FALSE

  CONST
    ifc$max_code_set_name_size = 31,
    ifc$max_cr_seq_size = 2,
    ifc$max_end_of_information_size = 31,
    ifc$max_end_out_seq_size = 4,
    ifc$max_form_feed_seq_size = 7,
    ifc$max_function_key_class_size = 31,
    ifc$max_line_feed_seq_size = 2,
    ifc$max_prompt_string_size = 31,
    ifc$max_terminal_model_size = 25,
    ifc$max_trans_fwd_char_size = 4,
    ifc$max_trans_term_char_size = 4,
    ifc$total_substitution_count = 64;

*DECK DECK=IFD$MACHINE_DEFINITION EXPAND=FALSE

{ Define cybil compile time variable to control differences in
{   c170/c180 source.

{ Define this module for c170 interactive use.

  ? VAR ifv$module_for_c180: boolean := FALSE ?;

*DECK DECK=IFE$ERROR_CODES EXPAND=FALSE

  CONST

*IF $true(osv$unix)
    ifc$min_ecc = (($INTEGER ('I') * 100(16)) + $INTEGER ('F')) * 10000(16),
*ELSE
    ifc$min_ecc = (($INTEGER ('I') * 100(16)) + $INTEGER ('F')) * 1000000(16),
*IFEND

    ifc$interactive_facility_id = 'IF',

    ife$file_name_not_terminal = ifc$min_ecc + 5,
    {E File +F must be assigned to a terminal device.

    ife$file_name_not_found = ifc$min_ecc + 10,
    {E File +P cannot be found.

    ife$file_name_ill_formed = ifc$min_ecc + 15,
    {E File name +P is ill-formed.

    ife$current_job_not_interactive = ifc$min_ecc + 20,
    {I The current job must be of interactive mode.

    ife$current_job_disconnected = ifc$min_ecc + 25,
    {E The current job must not be disconnected.

    ife$job_name_ill_formed = ifc$min_ecc + 30,
    {E Job name +P is ill-formed.

    ife$job_not_found = ifc$min_ecc + 35,
    {E Job +P cannot be found.

    ife$other_job_not_disconnected = ifc$min_ecc + 40,
    {E Job +P must be a disconnected interactive job.

    ife$no_suspended_activity = ifc$min_ecc + 60,
    {I There is no suspended activity to repeat from.

    ife$unknown_advance_unit = ifc$min_ecc + 70,
    {E Advance unit +P is unknown.

    ife$unknown_attribute_key = ifc$min_ecc + 75,
    {E Terminal attribute key +P is unknown.

    ife$invalid_key_for_request = ifc$min_ecc + 80,
    {E Terminal attribute key +P is invalid for this request.

    ife$control_char_conflict = ifc$min_ecc + 85,
    {E Terminal attribute +P of value '+P' must not be the same as attribute..
    { +P.

    ife$attr_val_disallowed_by_nam = ifc$min_ecc + 90,
    {E For +P, +P is outside the range of legal values.

    ife$illegal_nam_ve_change = ifc$min_ecc + 91,
    {I PBC, TC and TBC are read-only or non-applicable on a NAM/VE network.

    ife$illegal_nam_cdcnet_change = ifc$min_ecc + 92,
    {I PBC and TBC are read-only attributes on a NAM/CDCNET network.

    ife$illegal_nam_ccp_change = ifc$min_ecc + 93,
    {I AC, BLC, CRS, CS, EPA, FFD, FFS, FKC, HPO, LFS, and EOS are read-only ..
    {or non-applicable on a NAM/CCP network.

    ife$illegal_nam_ccp_conn_change = ifc$min_ecc + 94,
    {I TPM is non-applicable on a NAM/CCP network.

    ife$cr_delay = ifc$min_ecc + 95,
    {E Carriage return delay value +P must be from +P to +P.

    ife$end_of_information_size = ifc$min_ecc + 110,
    {E End Of Information string '+P' size must be from +P to +P characters.

    ife$unknown_input_output_mode = ifc$min_ecc + 125,
    {E Input Output Mode +P must be either: solicited, unsolicited, or full_duplex.

    ife$unknown_status_action = ifc$min_ecc + 126,
    {E Status Action +P must be either: send, hold or discard.

    ife$unknown_end_part_position = ifc$min_ecc + 127,
    {E End Partial Positioning +P must be either: none, crs, lfs, or crslfs.

    ife$lf_delay = ifc$min_ecc + 130,
    {E Line feed delay value +P must be from +P to +P.

    ife$unknown_output_device = ifc$min_ecc + 135,
    {E Output device +P must be either display or printer.

    ife$page_length = ifc$min_ecc + 140,
    {E Page length +P must be from +P to +P and not 1 on NAM/CDCNET.

    ife$page_width = ifc$min_ecc + 145,
    {E Page width +P must be from +P to +P and not 1 to 9 on NAM/CDCNET.

    ife$unknown_parity_mode = ifc$min_ecc + 150,
    {E Parity mode +P must be either: zero, mark, even, odd or none.

    ife$prompt_file_name_ill_formed = ifc$min_ecc + 155,
    {E Prompt file name +P is ill-formed.

    ife$prompt_file_name_not_found = ifc$min_ecc + 160,
    {E Prompt file +P cannot be found.

    ife$prompt_file_name_not_term = ifc$min_ecc + 165,
    {E Prompt file +P must be assigned to a terminal device.

    ife$prompt_file_id_not_found = ifc$min_ecc + 170,
    {E Prompt file +P for prompt file ID cannot be found.

    ife$prompt_file_id_not_term = ifc$min_ecc + 175,
    {E Prompt file +P for prompt file ID must be assigned to a terminal device.

    ife$prompt_string_size = ifc$min_ecc + 180,
    {E Prompt string '+P' size must be from +P to +P characters.

    ife$unknown_terminal_class = ifc$min_ecc + 185,
    {E Terminal class +P is unknown.

    ife$trans_message_length = ifc$min_ecc + 190,
    {E Trans Message Length +P must be from +P to +P.

    ife$trans_terminate_character = ifc$min_ecc + 195,
    {E Trans Terminate Character must select either count, character,..
    { or timeout.

    ife$echoplex = ifc$min_ecc + 225,
    {E Echoplex must be TRUE or FALSE.

    ife$fold_line = ifc$min_ecc + 226,
    {E Fold Line must be TRUE or FALSE.

    ife$partial_char_forwarding = ifc$min_ecc + 230,
    {E Partial Char Forwarding must be TRUE or FALSE.

    ife$store_backspace_character = ifc$min_ecc + 231,
    {E Store Backspace Character must be TRUE or FALSE.

    ife$store_nuls_dels = ifc$min_ecc + 232,
    {E Store Nuls Dels must be TRUE or FALSE.

    ife$hold_page = ifc$min_ecc + 235,
    {E Hold page must be TRUE or FALSE.

    ife$special_editing_range = ifc$min_ecc + 240,
    {E Special editing must be TRUE or FALSE.

    ife$transp_count_select_range = ifc$min_ecc + 245,
    {E Transparent delimiter count selection must be TRUE or FALSE.

    ife$transp_char_select_range = ifc$min_ecc + 250,
    {E Transparent delimiter character selection must be TRUE or FALSE.

    ife$transp_timeout_select_range = ifc$min_ecc + 255,
    {E Transparent delimiter timeout selection must be TRUE or FALSE.

    ife$transparent_mode_range = ifc$min_ecc + 260,
    {E Transparent mode must be TRUE or FALSE.

    ife$type_ahead_range = ifc$min_ecc + 265,
    {E Type ahead must be TRUE or FALSE.

    ife$pause_break_received = ifc$min_ecc + 270,
    {E Pause break received from terminal.

    ife$terminate_break_received = ifc$min_ecc + 275,
    {E Terminate break received from terminal.

    ife$connection_break_disconnect = ifc$min_ecc + 280,
    {I Terminal disconnected from job due to broken terminal connection.

    ife$job_disconnect_interactive = ifc$min_ecc + 285,
    {I Terminal disconnected from job due to program request -..
    {job continues in interactive mode.

    ife$job_disconnect_batch = ifc$min_ecc + 290,
    {I Terminal disconnected from job due to program request -..
    {job continues in batch mode.

    ife$terminal_reconnected_to_job = ifc$min_ecc + 295,
    {I Terminal has been reconnected to this disconnected job.

    ife$terminal_reconnected_other = ifc$min_ecc + 300,
    {I Terminal has been reconnected to a disconnected job -..
    {this job is being terminated.

    ife$disconnected_job_timeout = ifc$min_ecc + 305,
    {E This job is terminating because it remained disconnected longer ..
    {than the system allows.

    ife$cant_find_disconnected_job = ifc$min_ecc + 310,
    {E The specified disconnected job could not be found.

    ife$vt_create_paired_conn_rejct = ifc$min_ecc + 312,
    {E The paired connection request was rejected by the network.

    ife$character_flow_control = ifc$min_ecc + 315,
    {E Character flow control must be TRUE or FALSE.

    ife$invalid_host_parameter_size = ifc$min_ecc + 316,
    {E HOST parameter is invalid, size must be from 1 to 63 characters.

    ife$must_be_timesharing = ifc$min_ecc + 317,
    {E Request may only be performed from a TIMESHARING job.

    ife$cannot_locate_service = ifc$min_ecc + 318,
    {E Cannot locate service +P.

    ife$connection_already_switched = ifc$min_ecc + 319,
    {E A secondary connection is already established for this connection.

    ife$term_model_name_ill_formed = ifc$min_ecc + 320,
    {E Terminal Model name +P is ill_formed.

    ife$cannot_create_connection = ifc$min_ecc + 321,
    {E Cannot create connection.

    ife$service_is_busy = ifc$min_ecc + 322,
    {E Requested service is BUSY.

    ife$connection_data_dependent = ifc$min_ecc + 323,
    {E In order to specify parameter +P, +P must also be specified.

    ife$invalid_service_data = ifc$min_ecc + 324,
    {E Invalid Service Data.

    ife$abort_get = ifc$min_ecc + 325,
    {E Get operation aborted because interactive condition received.

    ife$invalid_connection_data = ifc$min_ecc + 326,
    {E Invalid Connection Data.

    ife$trans_timeout_lock_range = ifc$min_ecc + 330,
    {E Transparent timeout lock be TRUE or FALSE.

    ife$full_ascii_range = ifc$min_ecc + 335,
    {E Full ascii must be TRUE or FALSE.

    ife$unknown_end_block_position = ifc$min_ecc + 340,
    {E End block positioning +P must be either: no_input_positioning, ..
    { carriage_return,line_feed, or cr_lf.

    ife$unknown_input_editing_mode = ifc$min_ecc + 341,
    {E Input Editing Mode +P must be either: normal_edit or trans_edit

    ife$unknown_end_line_position = ifc$min_ecc + 345,
    {E End line positioning +P must be either: none, crs, lfs, or crslfs.

    ife$trans_fwd_character_size = ifc$min_ecc + 347,
    {E Trans Forward Character string '+P' size must be from +P to +P characters.

    ife$unknown_trans_char_mode = ifc$min_ecc + 349,
    {E Trans Character Mode +P must be either: none, terminate, forward, ..
    { or forward_terminate.

    ife$unknown_trans_length_mode = ifc$min_ecc + 351,
    {E Trans Length Mode +P must be either: none, terminate, forward, ..
    { or forward_exact.

    ife$unknown_trans_timeout_mode = ifc$min_ecc + 352,
    {E Trans Timeout Mode +P must be either: none, terminate, or forward.
    { or forward_terminate.

    ife$unknown_trans_protocol_mode = ifc$min_ecc + 353,
    {E Trans Protocol Mode +P must be either: none, terminate, or forward.

    ife$trans_fwd_char_size = ifc$min_ecc + 354,
    {E Trans Forward Character string '+P' size must be from +P to +P characters.

    ife$trans_term_character_size = ifc$min_ecc + 356,
    {E Trans Terminate Character string '+P' size must be from +P to +P characters.

    ife$input_flow_control_range = ifc$min_ecc + 358,
    {E Input flow control must be TRUE or FALSE.

    ife$input_timeout = ifc$min_ecc + 360,
    {E Input Timeout must be TRUE or FALSE.

    ife$input_timeout_purge = ifc$min_ecc + 365,
    {E Input Timeout Purge must be TRUE or FALSE.

    ife$input_timeout_length = ifc$min_ecc + 370,
    {E Input Timeout Length value +P must be from +P to +P.

    ife$attention_character_action = ifc$min_ecc + 371,
    {E Attention Character Action value +P must be from +P to +P.

    ife$break_key_action = ifc$min_ecc + 372,
    {E Break Key Action value +P must be from +P to +P.

    ife$input_block_size = ifc$min_ecc + 373,
    {E Input Block Size value +P must be from +P to +P.

    ife$full_duplex_range = ifc$min_ecc + 380,
    {E Full Duplex must be TRUE or FALSE.

    ife$cursor_positioning_range = ifc$min_ecc + 385,
    {E Cursor positioning must be TRUE or FALSE.

    ife$input_timeout_exceeded = ifc$min_ecc + 390,
    {E Wait for input from terminal exceeded Input Timeout Length.

    ife$no_data_available = ifc$min_ecc + 395,
    {E Input Timeout Length is zero and there is no input available ..
    {from the terminal.

    ife$xpt_mode_drop_unexpected = ifc$min_ecc + 400,
    {E Input is currently expected to be in transparent mode but ..
    {non-transparent input has been received.

    ife$file_is_not_network_file = ifc$min_ecc + 405,
    {E The terminal_file_name specified is not assigned to a network device.

    ife$terminal_file_name_required = ifc$min_ecc + 410,
    {E The terminal_file_name must be specified for this interface.

    ife$no_space_allocated = ifc$min_ecc + 415,
    {E An ALLOCATE in the osv$task_shared_heap returned a NIL pointer.

    ife$vt_file_not_open = ifc$min_ecc + 420,
    {E File +F not open.

    ife$vt_incorrect_buffer_size = ifc$min_ecc + 425,
    {E Incorrect buffer size used.

    ife$vt_incorrect_entry_on_queue = ifc$min_ecc + 430,
    {E Incorrect entry found on queue.

    ife$vt_no_eom_found = ifc$min_ecc + 435,
    {E No end of message_found.

    ife$vt_input_buffer_not_found = ifc$min_ecc + 440,
    {E Input buffer not found.

    ife$vt_output_buffer_not_found = ifc$min_ecc + 445,
    {E Output buffer not found.

    ife$vt_data_not_found = ifc$min_ecc + 450,
    {E Data not found.

    ife$vt_file_already_open = ifc$min_ecc + 455,
    {E File +F already open.

    ife$vt_file_already_closed = ifc$min_ecc + 460,
    {E File +F already closed.

    ife$vt_file_id_not_valid = ifc$min_ecc + 465,
    {E File id +P not valid.

    ife$vt_unexpected_message = ifc$min_ecc + 470,
    {E Unexpected message_received.

    ife$vt_unsupported_event = ifc$min_ecc + 475,
    {E Unsupported terminal event.

    ife$vt_change_attributes_error = ifc$min_ecc + 480,
    {E Change attributes error.

    ife$vt_sequence_number_mismatch = ifc$min_ecc + 485,
    {E File +F identifier sequence number mismatch.

    ife$wsl_out_of_range = ifc$min_ecc + 490,
    {E The Working_Storage_Length parameter is outside the ..
    {range defined by AMT$WORKING_STORAGE_LENGTH.

    ife$request_term_char_fail = ifc$min_ecc + 500,
    {E Request for terminal characteristics failed.

    ife$wsa_is_nil = ifc$min_ecc + 505,
    {E The Working_Storage_Area pointer is NIL.

    ife$abort_job_initialization = ifc$min_ecc + 506,
    {E The Connection was broken before the job monitor task started.

    ifc$max_ecc = ifc$min_ecc + 510;

*DECK DECK=IFE$INTERACTIVE_EXCEPTION_CODES EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc IFE$ERROR_CODES
?? POP ??

  CONST
    ifc$pc_base_exception = ifc$max_ecc + 1;

?? NEWTITLE := 'Interactive Exceptions : ''IF'' + 501 - ''IF'' + 504', EJECT ??

  CONST
    ife$pause_break = ifc$pc_base_exception + 0,
    {I A pause break condition has occurred.}

    ife$terminate_break = ifc$pc_base_exception + 1,
    {I A terminate break condition has occurred.}

    ife$terminal_connection_broken = ifc$pc_base_exception + 2,
    {I A terminal connection broken condition has occurred.}

    ife$job_reconnect = ifc$pc_base_exception + 3;
    {I A job reconnect to terminal condition has occurred.}

?? OLDTITLE ??
*DECK DECK=IFH$ADVANCE EXPAND=FALSE
{}
{   The purpose of this request is to advance or skip some output
{ from any job activity suspended because of a pause_break.
{}
{       IFP$ADVANCE (COUNT, UNIT, STATUS)
{}
{ COUNT: (input) This parameter specifies the number of UNITs to
{       skip.
{}
{ UNIT: (input) This parameter specifies the unit of advancement.
{}
{ STATUS: (output) This parameter specifies the request status.
{      CONDITION: ife$advance_count_range
{                 ife$current_job_not_interactive
{                 ife$unknown_advance_unit
{      IDENTIFIER: ifc$interactive_facility_id
{}
*DECK DECK=IFH$CHANGE_TERMINAL_ATTRIBUTES EXPAND=FALSE
{}
{   The purpose of this interface is to change the terminal attributes
{   for a terminal.  Connection attributes cannot be changed by this
{   interface.
{}
{       IFP$CHANGE_TERMINAL_ATTRIBUTES (TERMINAL_FILE_NAME,
{         TERMINAL_ATTRIBUTES, STATUS)
{}
{ TERMINAL_FILE_NAME: (input) This parameter specifies the name of the
{       terminal file for which terminal attributes are to be changed.
{}
{ TERMINAL_ATTRIBUTES: (input) This parameter specifies the terminal
{       attributes to be changed and their associated new values.
{}
{ STATUS: (output) This parameter specifies the request status.
{      CONDITION: ife$current_job_not_interactive
{                 ife$file_name_ill_formed
{                 ife$file_name_not_found
{                 ife$file_name_not_terminal
{                 ife$unknown_attribute_key
{                 ife$attr_val_disallowed_by_nam
{                 ife$page_length
{                 ife$page_width
{                 ife$control_char_conflict
{                 ife$cr_delay
{                 ife$echoplex
{                 ife$unknown_status_action
{                 ife$fold_line
{                 ife$unknown_end_part_position
{                 ife$unknown_end_line_position
{                 ife$character_flow_control
{                 ife$lf_delay
{                 ife$page_length
{                 ife$hold_page
{                 ife$page_width
{                 ife$unknown_parity_mode
{                 ife$unknown_terminal_class
{                 ife$invalid_key_for_request
{                 ife$vt_change_attributes_error
{      IDENTIFIER: ifc$interactive_facility_id
{}
*DECK DECK=IFH$CHANGE_TERM_CONN_ATTRIBUTES EXPAND=FALSE
{}
{   The purpose of this interface is to change the connection attributes
{   for a file.  Subsequent instances-of-open of the file will use the
{   new connection attribute values.  Instances-of-open of the file
{   created before the interface was executed will not be affected, but
{   will use the attribute values which were in effect for the file at
{   the creation of each instance.
{}
{       IFP$CHANGE_TERM_CONN_ATTRIBUTES (TERMINAL_FILE_NAME,
{         TERM_CONN_ATTRIBUTES, STATUS)
{}
{ TERMINAL_FILE_NAME: (input) This parameter specifies the name of the
{       terminal file for which connection attributes are to be changed.
{}
{ TERM_CONN_ATTRIBUTES: (input) This parameter specifies the connection
{       attributes to be changed and their associated new values.
{}
{ STATUS: (output) This parameter specifies the request status.
{      CONDITION: ife$current_job_not_interactive
{                 ife$file_name_ill_formed
{                 ife$illegal_nam_ccp_conn_change
{                 ife$current_job_not_interactive
{                 ife$file_name_not_terminal
{                 ife$unknown_attribute_key
{                 ife$attention_character_action
{                 ife$break_key_action
{                 ife$end_of_information_size
{                 ife$input_block_size
{                 ife$unknown_input_editing_mode
{                 ife$unknown_input_output_mode
{                 ife$input_timeout
{                 ife$input_timeout_length
{                 ife$input_timeout_purge
{                 ife$partial_char_forwarding
{                 ife$prompt_file_name_ill_formed
{                 ife$prompt_file_name_not_found
{                 ife$prompt_file_name_not_term
{                 ife$prompt_string_size
{                 ife$store_backspace_character
{                 ife$store_nuls_dels
{                 ife$unknown_trans_char_mode
{                 ife$unknown_trans_length_mode
{                 ife$unknown_trans_timeout_mode
{                 ife$trans_fwd_character_size
{                 ife$trans_message_length
{                 ife$trans_term_character_size
{                 ife$unknown_trans_protocol_mode
{                 ose$job_pageable_full
{      IDENTIFIER: ifc$interactive_facility_id
{}
*DECK DECK=IFH$CHANGE_TERM_CONN_DEFAULTS EXPAND=FALSE
{}
{   The purpose of this interface is to change the default connection
{   attribute values which are assigned to a file at its creation.
{   Subsequent file creations will use the new default connection
{   attribute values.  Files created before the interface was executed
{   will not be affected, but will use the default attribute values
{   which were in effect at each file's creation.
{}
{       IFP$CHANGE_TERM_CONN_DEFAULTS (TERMINAL_FILE_NAME,
{         TERM_CONN_ATTRIBUTES, STATUS)
{}
{ TERMINAL_FILE_NAME: (input) This parameter specifies the name of the
{       terminal file associated with the connection for which
{       connection attributes are to be changed.
{}
{ TERM_CONN_ATTRIBUTES: (input) This parameter specifies the connection
{       attributes to be changed and their associated new values.
{}
{ STATUS: (output) This parameter specifies the request status.
{      CONDITION: ife$current_job_not_interactive
{                 ife$$file_name_ill_formed
{                 ife$$file_is_not_network_file
{                 ife$$illegal_nam_ccp_conn_change
{                 ife$$unknown_attribute_key
{                 ife$$attention_character_action
{                 ife$$break_key_action
{                 ife$$end_of_information_size
{                 ife$$input_block_size
{                 ife$$unknown_input_editing_mode
{                 ife$$unknown_input_output_mode
{                 ife$$input_timeout
{                 ife$$input_timeout_length
{                 ife$$input_timeout_purge
{                 ife$$partial_char_forwarding
{                 ife$$prompt_file_name_ill_formed
{                 ife$$prompt_file_name_not_found
{                 ife$$prompt_file_name_not_term
{                 ife$$prompt_file_id_not_found
{                 ife$$prompt_file_id_not_term
{                 ife$$prompt_string_size
{                 ife$$store_backspace_character
{                 ife$$store_nuls_dels
{                 ife$$unknown_trans_char_mode
{                 ife$$unknown_trans_length_mode
{                 ife$$unknown_trans_timeout_mode
{                 ife$$trans_fwd_character_size
{                 ife$$trans_message_length
{                 ife$$trans_term_character_size
{                 ife$$unknown_trans_protocol_mode
{      IDENTIFIER: ifc$interactive_facility_id
{}


*DECK DECK=IFH$DISCONNECT EXPAND=FALSE
{}
{   The purpose of this request is to disconnect the current job
{ from terminal control and allow it to continue running.  This
{ disconnected job may execute until it needs to do input or output
{ to the terminal at which time it is suspended and awaits reconnection
{ to the user's terminal.
{}
{       IFP$DISCONNECT (STATUS)
{}
{ STATUS: (output) This parameter specifies the request status.
{}
*DECK DECK=IFH$FAP_CONTROL EXPAND=FALSE
{   The purpose of this request is to perform a BAM operation on a
{  file that is assigned to a terminal device.  The interface used is the
{  standard BAM file access procedure interface.  Consult BAM
{  documentation for parameter descriptions.  This interface is
{  intended only for use by BAM.
*DECK DECK=IFH$FETCH_TERMINAL EXPAND=FALSE
{}
{   The purpose of this request is to retrieve the value of one
{ or more connection attributes for a terminal-connected file
{ subsequent to the file being opened.  This request is similar
{ to IFP$GET_TERM_CONN_ATTRIBUTES except that the file_identifier
{ is used to distinguish from among what may be several instances
{ of open of the same file.
{}
{       IFP$FETCH_TERM_CONN_ATTRIBUTES (FILE_IDENTIFIER,
{         CONNECTION_ATTRIBUTES, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{}
{ CONNECTION_ATTRIBUTES: (input-output) This parameter specifies
{       one or more attributes whose value is sought.
{}
{ STATUS: (output) This parameter specifies the request status.
{      CONDITION: ame$improper_file_id
{                 ife$current_job_not_interactive
{                 ife$unknown_attribute_key
{      IDENTIFIER: ifc$interactive_facility_id
{}
*DECK DECK=IFH$GET_NETWORK_IDENTIFIER EXPAND=FALSE
{
{   This request can be used to determine via which network a job is connected
{ to an interactive terminal.
{
{       IFP$GET_NETWORK_IDENTIFIER (NETWORK_IDENTIFIER, STATUS)
{
{ NETWORK_IDENTIFIER: (output)  The identifier of the network is returned via
{       this parameter.  Possible values are:
{
{       IFC$NI_NONE:  The job's mode is batch or "disconnected".
{
{       IFC$NI_NAM_VE_CDCNET:  The interactive job is connected "directly" to
{             CDCNET.
{
{       IFC$NI_NAM_CDCNET:  The interactive job is connected "indirectly" to
{             CDCNET via NOS's NAM.
{
{       IFC$NI_NAM_CCP:  The interactive job is connected "indirectly" to CCP
{             via NOS's NAM.
{
{       IFC$NI_NTERCOM:  The interactive job is connected "indirectly" to
{             INTERCOM via NOS/BE.
{
{ STATUS: This parameter specifies the request's completion status.
{
*DECK DECK=IFH$GET_TERMINAL_ATTRIBUTES EXPAND=FALSE
{}
{   The purpose of this request is to allow a user to interrogate the
{   terminal attributes maintained by the system for his/her terminal.
{   Terminal attribute values may be defined in the following ways:
{      . default LOGIN values from the network
{      . IFP$CHANGE_TERMINAL_ATTRIBUTES request
{      . SET_TERMINAL_ATTRIBUTES or CHANGE_TERMINAL_ATTRIBUTES command
{   Terminal attribute values may also be defined via network commands
{   but this is discouraged on NAM/CCP and NAM/CDCNET connections
{   because this request would be unaware of such changes.
{}
{       IFP$GET_TERMINAL_ATTRIBUTES (TERMINAL_FILE_NAME,
{         TERMINAL_ATTRIBUTES, STATUS)
{}
{ TERMINAL_FILE_NAME: (input) This parameter specifies the name of the
{       terminal file for which terminal attributes are to be returned.
{}
{ TERMINAL_ATTRIBUTES: (input-output) This parameter specifies one or more
{       terminal attributes for which a value is to be returned.
{}
{ STATUS: (output) This parameter specifies the request status.
{      CONDITION: ife$current_job_not_interactive
{                 ife$file_name_ill_formed
{                 ife$file_name_not_found
{                 ife$file_name_not_terminal
{                 ife$unknown_attribute_key
{      IDENTIFIER: ifc$interactive_facility_id
{}
*DECK DECK=IFH$GET_TERM_CONN_ATTRIBUTES EXPAND=FALSE
{}
{   The purpose of this request is to allow a user to interrogate the
{   connection attributes associated with a particular terminal file.
{   Connection attribute values for a file are the result of either
{   of the following:
{      . default values assigned at LOGIN
{      . IFP$CHANGE_TERM_CONN_DEFAULTS request
{      . IFP$CHANGE_TERM_CONN_ATTRIBUTES request
{      . CHANGE_TERM_CONN_ATTRIBUTES or CHANGE_TERM_CONN_DEFAULTS command
{}
{       IFP$GET_TERM_CONN_ATTRIBUTES (TERMINAL_FILE_NAME,
{         TERM_CONN_ATTRIBUTES, STATUS)
{}
{ TERMINAL_FILE_NAME: (input) This parameter specifies the name of the
{       terminal file for which connection attributes are to be returned.
{}
{ TERM_CONN_ATTRIBUTES: (input-output) This parameter specifies one or more
{       connection attributes for which a value is to be returned.
{}
{ STATUS: (output) This parameter specifies the request status.
{      CONDITION: ife$current_job_not_interactive
{                 ife$file_name_ill_formed
{                 ife$file_name_not_terminal
{                 ife$unknown_attribute_key
{      IDENTIFIER: ifc$interactive_facility_id
{}




*DECK DECK=IFH$GET_TERM_CONN_DEFAULTS EXPAND=FALSE
{}
{   The purpose of this request is to allow a user to interrogate the
{   default connection attributes which will be associated with a file
{   at its creation.  These values are established as a result of
{   either of the following:
{      . default values assigned at LOGIN
{      . IFP$CHANGE_TERM_CONN_DEFAULTS request
{      . CHANGE_TERM_CONN_DEFAULTS command
{}
{       IFP$GET_TERM_CONN_DEFAULTS (TERMINAL_FILE_NAME,
{         TERM_CONN_ATTRIBUTES, STATUS)
{}
{ TERMINAL_FILE_NAME: (input) This parameter specifies the name of the
{       terminal file associated with the connection for which
{       connection attributes are to be returned.
{}
{ TERM_CONN_ATTRIBUTES: (input-output) This parameter specifies one or
{       more connection attributes for which a value is to be returned.
{}
{ STATUS: (output) This parameter specifies the request status.
{      CONDITION: ife$current_job_not_interactive
{                 ife$file_name_ill_formed
{                 ife$file_name_not_terminal
{                 ife$unknown_attribute_key
{      IDENTIFIER: ifc$interactive_facility_id
{}




*DECK DECK=IFH$HANDLE_SIGNAL EXPAND=FALSE
{   The purpose of this request is to process signals sent from one task
{ to another by the nos/ve interactive facility routines.  The tasks involved
{ are:
{     - interactive executive (one per system)
{     - job monitor (one per job)
{     - user tasks (n per job)
{
{        IFP$HANDLE_SIGNAL (ORIGINATOR, SIGNAL)
{
{ ORIGINATOR: (input) This parameter specifies the sender of the signal.
{
{ SIGNAL: (input) This parameter specifies the received signal.
{
*DECK DECK=IFH$IMMEDIATE_ATTRIBUTE_FLUSH EXPAND=FALSE
{
{   This request causes the connection attributes associated with an
{ instance-of-open to be effected immediately.
{
{   This request provides a means to prevent the latent effecting of connection
{ attributes, specifically, the transparent_mode related attributes:
{
{                  input_editing_mode
{                  transparent_character_mode
{                  transparent_length_mode
{                  transparent_timeout_mode
{                  transparent_message_length
{                  transparent_forward_character
{                  transparent_terminate_character
{
{   As an example, if a program leaves the terminal in transparent mode after
{ receiving input in transparent mode and desires immediately to continue
{ execution in non-transparent mode, it can do so by calling this request and
{ passing it the file_identifier of an instance-of-open whose
{ input_editing_mode is ifc$normal_edit.  Otherwise the terminal remains in
{ transparent mode until an input request is executed for a file_identifier
{ whose input_editing_mode is ifc$normal_edit.  This immediate effecting of
{ non-transparent mode may be desired to allow user interrupts.
{
{   As an example, if a program desires the terminal to be in transparent mode
{ immediately before continuing execution, it can do so by calling this request
{ and passing it the file_identifier of an instance-of-open whose
{ input_editing_mode is ifc$trans_edit.  Otherwise the terminal remains in
{ non-transparent mode until an input request is executed for a file_identifier
{ whose input_editing_mode is ifc$trans_edit.  This immediate effecting of
{ transparent mode may be desired for a program which expects typed-ahead input
{ and wants the input to be delivered in transparent mode.
{
{   This request achieves the same results as AMP$FLUSH for a terminal file
{ except that AMP$FLUSH will not immediately effect the transparent_mode
{ related attributes.
{
{       IFP$IMMEDIATE_ATTRIBUTE_FLUSH (FILE_IDENTIFIER, STATUS)
{
{ FILE_IDENTIFIER: (input) File identifier established for this
{       instance-of-open for which connection attributes are to be effected.
{
{ STATUS: (output) This parameter is used to return the request status.
{       CONDITIONS:
{             ife$file_name_not_terminal
{
*DECK DECK=IFH$JOB_INITIALIZE EXPAND=FALSE
{   The purpose of this procedure is to initialize interactive facility
{  structures and complete the network login sequence at job begin time.
{  This request is intended to be used only by JM.

{   IFP$JOB_INITIALIZE (STATUS)

{  status: (output) The status of the IF initialization.  If not normal
{          then the job should be terminated.
*DECK DECK=IFH$PURGE_CONNECTION_IO EXPAND=FALSE
{
{     This procedure builds the supervisory message FC/BRK/R and sends it
{   to PASSON for delivery to NAM.  NAM interprets this message as a direct
{   to throw away any input or output queued anywhere between PASSON and
{   the terminal for this job.
{
{       IFP$PURGE_CONNECTION_IO (STATUS)
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             ife$connection_break_disconnect
{             mlc$c170_c170_illegal
{             mlc$message_too_long
{             mlc$mli_internal_error
{             mlc$receiver_name_syntax_error
{             mlc$sender_name_syntax_error
{             mlc$sender_not_permitted
{             mlc$sender_not_signed_on
{             mlc$signal_failed_ignored
{             mlc$signal_to_c170_ignored
{             mlc$system_name_no_match
{
*DECK DECK=IFH$RECONNECT EXPAND=FALSE
{}
{   The purpose of this request is to reconnect the current job's
{ terminal to a disconnected interactive job.  The current job is
{ terminated.
{}
{       IFP$RECONNECT (GLOBAL_TASK_ID, STATUS)
{}
{ GLOBAL_TASK_ID: (input) This parameter specifies the task id of the
{       job to be reconnected.
{}
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=IFH$SEND_INTERRUPT_CONDITION EXPAND=FALSE
{
{ IFP$SEND_INTERRUPT_CONDITION:
{
{   The purpose of this request is to send the interactive interrupt
{ condition to a task.  If the specified task is not present, an error
{ will be returned.  The interrupt condition has no effect on the
{ processing of interactive input and output that occurs with other
{ interactive conditions.  The interrupt condition may be sent in a
{ non-interactive job.  The "ifc$interrupt" condition code is defined
{ in a deck with the same name.
{
{       IFP$SEND_INTERRUPT_CONDITION (TASK_ID, STATUS)
{
{ TASK_ID: (Input) This parameter specifies the task_id of the task that
{       is to receive the interrupt condition.  The task_id is provided by
{       the pmp$execute request at the time a task is started.  If no task
{       with the specified task_id is presend, an error will be returned.
{
{ STATUS: (Output) This parameter returns the request status.
{
{        CONDITIONS: pme$invalid_task_id
{                    pme$unknown_task_id
{
{        IDENTIFIER: pmc$program_management_id
{
*DECK DECK=IFH$START_PAUSE_UTILITY EXPAND=FALSE
{   The purpose of this request is to invoke the interactive pause
{  utility as a synchronous task from within a different task.  A
{  special version of pmp$execute (pmp$execute_with_less_priviledge)
{  is used to force the pause utility task to load and execute in the
{  nominal ring for the current user, which allows this request to be
{  issued from any task service ring.

{   IFP$START_PAUSE_UTILITY (STATUS)

{  status: (output) This parameter will contain the termination status
{          of the pause utility task.
*DECK DECK=IFH$STORE_TERMINAL EXPAND=FALSE
{}
{   The purpose of this request is to change the value of one or
{ more connection attributes for a terminal-connected file.  This
{ request may only be issued after the file has been opened.
{   The supplied attributes will be used to describe this task's
{ access to the terminal file but will be discarded when
{ this instance of open of this file is closed either explicitly
{ or automatically when the task terminates.
{}
{       IFP$STORE_TERM_CONN_ATTRIBUTES (FILE_IDENTIFIER,
{             CONNECTION_ATTRIBUTES, STATUS)
{}
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{}
{ CONNECTION_ATTRIBUTES: (input-output) This parameter specifies one
{       or more attributes which are to be associated with the
{       file's instance-of-open.
{}
{ STATUS: (output) This parameter specifies the request status.
{      CONDITION: ife$current_job_not_interactive
{                 ife$unknown_attribute_key
{                 ife$prompt_file_name_ill_formed
{                 ife$prompt_file_name_not_found
{                 ife$prompt_file_name_not_term
{                 ife$prompt_string_size
{                 ife$end_of_information_size
{                 ife$input_timeout
{                 ife$input_timeout_length
{                 ife$input_timeout_purge
{                 ife$file_is_not_network_file
{                 ife$vt_change_attributes_error
{                 ame$improper_file_id
{      IDENTIFIER: ifc$interactive_facility_id
{}
*DECK DECK=IFH$SUPPRESS_CURSOR_POS_ECHOPLX EXPAND=FALSE
{
{   This request toggles the cursor positioning and/or echoplexing feature for
{ only the next input from the terminal.
{
{       IFP$SUPPRESS_CURSOR_POS_ECHOPLX (SUPPRESS_CURSOR_POSITIONING,
{             SUPPRESS_ECHOPLEXING)
{
{ SUPPRESS_CURSOR_POSITIONING: (input) This parameter specifies whether or not
{       the Cursor_Positioning terminal attribute will be ignored for the next
{       input only.  Ignoring the attribute has the same effect as if the
{       attribute were set to NONE.
{
{ SUPPRESS_ECHOPLEXING: (input) This parameter specifies whether or not the
{       Echoplex terminal attribute will be ignored for the next input only.
{       Ignoring the attribute has the same effect as if the attribute were
{       set to OFF.
{
*DECK DECK=IFH$VTP_CREATE_CDCNET_CONNECT EXPAND=FALSE
{    This routine will send a create_cdcnet_connection VTP message to the
{ network and then wait for a response.  If the response is a
{ create_cdcnet_connection_confirm the routine will return normal status.  If
{ the response is a create_cdcnet_connection_reject the appropriate abnormal
{ status will be returned.  If a response is not received from the network
{ before the specified timeout interval expires abnormal status will be
{ returned.
{
{       IFP$VTP_CREATE_CDCNET_CONNECT (SERVICE_NAME, SERVICE_DATA,
{             CONNECTION_DATA_1, CONNECTION_DATA_2, CONNECTION_DATA_3,
{             END_DISCARD_PROMPT, TIMEOUT_INTERVAL_IN_MS, STATUS)
{
{ SERVICE_NAME: (input)  This parameter specifies the name of the service to
{       which a CDCNET connection is to be made.
{
{ SERVICE_DATA: (input)  This parameter specifies the data to be passed to
{       the connected service at connection establishment time.  For example,
{       for connections to a Telnet service, this would be the Telnet host name
{       or IP address.
{
{ CONNECTION_DATA_1: (input)  This parameter specifies the data to be sent as
{       the first VTP Normal Input message on the CDCNET connection.
{
{ CONNECTION_DATA_2: (input)  This parameter specifies the data to be sent as
{       the second VTP Normal Input message on the CDCNET connection.
{
{ CONNECTION_DATA_3: (input)  This parameter specifies the data to be sent as
{       the third VTP Normal Input message on the CDCNET connection.
{
{ END_DISCARD_PROMPT: (input)  This parameter specifies that all output from
{       the secondary connection be discarded, instead of sent to the user's
{       terminal, until a sequence of characters at the beginning of a new
{       line are found that match those specified on this parameter.
{
{ TIMEOUT_INTERVAL_IN_MS: (input)  This parameter specifies the time that this
{       procedure should wait for a response from the network before declaring
{       a timeout.
{
{ STATUS: (output) This parameter specifies the request status.
{   CONDITIONS:
{      ife$cannot_create_connection
{      ife$cannot_locate_service
{      ife$connection_already_switched
{      ife$connection_data_dependent
{      ife$invalid_connection_data
{      ife$invalid_host_parameter_size
{      ife$invalid_service_data
{      ife$must_be_timesharing
{      ife$service_is_busy
*DECK DECK=IFK$KEYPOINTS EXPAND=FALSE

  CONST
    ifk$change_terminal_attributes = ifk$base + 0,
    {E 'ifp$change_terminal_attributes' }
    {X 'ifp$change_terminal_attributes' }

    ifk$connection_broken = ifk$base + 1,
    {D 'if connection broken' }

    ifk$network_shutdown = ifk$base + 2,
    {D 'if network shutdown' }

    ifk$terminal_break = ifk$base + 3,
    {D 'if terminal break' }

    ifk$start_output = ifk$base + 4,
    {D 'if start output' }

    ifk$connection_ended = ifk$base + 5,
    {D 'if connection ended' }

    ifk$initialized_connection = ifk$base + 6,
    {D 'if initialized connection' }

    ifk$change_term_conn_attributes = ifk$base + 7,
    {E 'ifp$change_term_conn_attributes' }
    {X 'ifp$change_term_conn_attributes' }

    ifk$change_term_conn_defaults = ifk$base + 8,
    {E 'ifp$change_term_conn_defaults' }
    {X 'ifp$change_term_conn_defaults' }

    ifk$get_term_conn_attributes = ifk$base + 9,
    {E 'ifp$get_term_conn_attributes' }
    {X 'ifp$get_term_conn_attributes' }

    ifk$fetch_term_conn_attributes = ifk$base + 10,
    {E 'ifp$fetch_term_conn_attributes' }
    {X 'ifp$fetch_term_conn_attributes' 'status  ' I20}

    ifk$get_terminal_attributes = ifk$base + 11,
    {E 'ifp$get_terminal_attributes' }
    {X 'ifp$get_terminal_attributes' 'status  ' I20}

    ifk$store_term_conn_attributes = ifk$base + 12,
    {E 'ifp$store_term_conn_attributes' }
    {X 'ifp$store_term_conn_attributes' 'status  ' I20}

    ifk$advance = ifk$base + 13,
    {E 'ifp$advance' }
    {X 'ifp$advance' 'status  ' I20}

    ifk$get_term_conn_defaults = ifk$base + 14,
    {E 'ifp$get_term_conn_defaults' }
    {X 'ifp$get_term_conn_defaults' }

    ifk$repeat = ifk$base + 15,
    {E 'ifp$repeat' }
    {X 'ifp$repeat' }

    ifk$st_fap_control = ifk$base + 16,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'IF_terminal_file_access_control' }
    {X 'IF_terminal_file_access_control' }
*ELSE
    {E 'ifp$st_fap_control' }
    {X 'ifp$st_fap_control' }
*IFEND

    ifk$fap_control = ifk$base + 17,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'IF_ds_terminal_file_access_control' }
    {X 'IF_ds_terminal_file_access_control' }
*ELSE
    {E 'ifp$fap_control' }
    {X 'ifp$fap_control' }
*IFEND

    ifk$disconnect = ifk$base + 18,
    {E 'ifp$disconnect' }
    {X 'ifp$disconnect' }

    ifk$fetch_context = ifk$base + 19,
    {E 'ifp$fetch_context' }
    {X 'ifp$fetch_conext'  }

    ifk$suppress_cursor_pos_echoplx = ifk$base + 20;
    {E 'ifp$suppress_cursor_pos_echoplx' }
    {X 'ifp$suppress_cursor_pos_echoplx' }

?? PUSH (LISTEXT := ON) ??
*copyc AMK$BASE_KEYPOINT_VALUES
?? POP ??
*DECK DECK=IFM$BEGIN_END_HANDLER EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
MODULE ifm$begin_end_handler;
*copyc jmp$restore_dispatching_control
*copyc jmv$jcb
*copyc jmv$system_job_ssn
?? PUSH (LISTEXT := ON) ??
*copyc ift$condition_codes
*copyc IFK$KEYPOINTS
*copyc PMP$GET_EXECUTING_TASK_GTID
*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSP$APPEND_STATUS_INTEGER
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc oss$task_shared
*copyc ift$$advance_repeat_types
*copyc ift$title_for_error_codes
*copyc ift$pause_util_dispatching_info
*copyc ift$pause_utility_count


  PROCEDURE [XREF] iip$discard_suspended_output;
?? POP ??

  VAR
    ifv$pause_util_dispatching_info: [oss$task_shared] ift$pause_util_dispatching_info,

    ifv$pause_utility_count: [XDCL, #GATE, oss$task_shared] ift$pause_utility_count := 0;

  PROCEDURE [XDCL, #GATE] ifp$discard_suspended_output;

    iip$discard_suspended_output;

  PROCEND ifp$discard_suspended_output;


  PROCEDURE [XDCL, #GATE] ifp$advance (count: ift$advance_count_range;
        unit: ift$advance_unit;
    VAR status: ost$status);

    #KEYPOINT (osk$entry, 0, ifk$advance);
    status.normal := TRUE;
    CASE unit OF
    = ifc$advance_all_queued_output =
      iip$discard_suspended_output;
    ELSE
      osp$set_status_abnormal (ifc$interactive_facility_id,
            ife$unknown_advance_unit, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, ORD (unit),
            10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
        'IFP$ADVANCE', status);
    CASEND;
    #KEYPOINT (osk$exit, 0, ifk$advance);

  PROCEND ifp$advance;

  PROCEDURE [XDCL, #GATE] ifp$begin_pause_utility (VAR status: ost$status);

{  PURPOSE:
{    This procedure saves the job's current dispatching control information, updates the pause utility
{    count, and resets the job's dispatching control information as is done for interactive input.
{    Do NOT save and restore dispatching control information for the system job (the system job
{    dispatching priority should never be changed.

    status.normal := TRUE;

    IF jmv$jcb.system_name <> jmv$system_job_ssn THEN
      ifv$pause_util_dispatching_info [ifv$pause_utility_count].dispatching_control_index := jmv$jcb.ijle_p^.
            dispatching_control.dispatching_control_index;
      ifv$pause_util_dispatching_info [ifv$pause_utility_count].dispatching_priority := jmv$jcb.ijle_p^.
            scheduling_dispatching_priority;
      ifv$pause_util_dispatching_info [ifv$pause_utility_count].service_remaining := jmv$jcb.ijle_p^.
            dispatching_control.service_remaining;
    IFEND;

    ifv$pause_utility_count := ifv$pause_utility_count + 1;

  PROCEND ifp$begin_pause_utility;

  PROCEDURE [XDCL, #GATE] ifp$end_pause_utility (VAR status: ost$status);

{  PURPOSE:
{    This procedure decrements the pause utility count and issues a call to restore the job's
{    dispatching control iformation to what it was before the user entered the pause utility.
{    Do NOT save and restore dispatching control information for the system job (the system job
{    dispatching priority should never be changed.

    status.normal := TRUE;

    ifv$pause_utility_count := ifv$pause_utility_count - 1;

    IF jmv$jcb.system_name <> jmv$system_job_ssn THEN
      jmp$restore_dispatching_control (ifv$pause_util_dispatching_info [ifv$pause_utility_count]);
    IFEND;

  PROCEND ifp$end_pause_utility;

MODEND ifm$begin_end_handler
*DECK DECK=IFM$CHANGE_TERMINAL_ATTRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE ifm$change_terminal_attributes;

{ PURPOSE:  This Ring 3 module calls a Ring 2 interface to change
{           the terminal attributes for a connection.
{
{  DESIGN:  For dual state connections IIM$CHANGE_TERMINAL_ATTRIBUTES
{           is called to change the connection's attributes;  for
{           standalone connections, IIM$ST_CHNG_TERMINAL_ATTRIBUTES.
{
?? TITLE := 'MODULE ifm$change_terminal_attributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ife$error_codes
*copyc ifk$keypoints
*copyc ift$terminal_attributes
*copyc iip$st_chng_terminal_attributes
*copyc iip$change_terminal_attributes
*copyc iiv$connection_desc_ptr
*copyc iiv$interactive_terminated
*copyc oss$job_paged_literal
?? POP ??

*copyc clp$get_ultimate_connection
*copyc clp$validate_name
*copyc clv$standard_files
*copyc iip$xlate_local_file_to_session
*copyc osp$append_status_parameter
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pmp$get_job_mode
*copyc rmp$get_device_class

?? NEWTITLE := 'PROCEDURE ifp$change_terminal_attributes', EJECT ??
*copyc ifh$change_terminal_attributes

  PROCEDURE [XDCL, #GATE {TS_gate} ] ifp$change_terminal_attributes (terminal_file_name:
    fst$file_reference;
    terminal_attributes: ift$terminal_attributes;
    VAR status: ost$status);

    VAR
      converted_name: ost$name,
      device_assigned: boolean,
      device_class: rmt$device_class,
      i: integer,
      job_mode: jmt$job_mode,
      local_status: ost$status,
      log: [STATIC, READ, oss$job_paged_literal] pmt$ascii_logset := [pmc$job_log],
      message_status: ost$status,
      ultimate_name: amt$local_file_name,
      valid_name: boolean;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, ifk$change_terminal_attributes);

  /change_terminal_attributes/
    BEGIN
      IF STRLENGTH (terminal_file_name) > osc$max_name_size THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$file_name_ill_formed, terminal_file_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
        EXIT /change_terminal_attributes/;
      IFEND;

      clp$validate_name (terminal_file_name, converted_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$file_name_ill_formed, terminal_file_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
        EXIT /change_terminal_attributes/;
      IFEND;

    { Get the name of the file which the terminal file is connected to.

      clp$get_ultimate_connection (converted_name, ultimate_name, status);
      IF NOT status.normal THEN
        EXIT /change_terminal_attributes/;
      IFEND;

    { Verify that the file is assigned to a terminal device.

      rmp$get_device_class (ultimate_name, device_assigned, device_class,
            status);
      IF NOT status.normal THEN
        EXIT /change_terminal_attributes/;
      ELSE
        IF (device_class <> rmc$terminal_device) AND (device_class <> rmc$network_device) THEN
          pmp$get_job_mode (job_mode, local_status);
          IF NOT local_status.normal THEN
            status := local_status;
            EXIT /change_terminal_attributes/;
          ELSEIF (NOT (job_mode IN $iit$job_modes [jmc$interactive_connected,
                 jmc$interactive_cmnd_disconnect, jmc$interactive_line_disconnect,
                 jmc$interactive_sys_disconnect]) AND
                 (((ultimate_name = clv$standard_files [clc$sf_job_input_file].path_handle_name) OR
                 (ultimate_name = clv$standard_files [clc$sf_job_output_file].path_handle_name)) OR
                 (ultimate_name = clv$standard_files [clc$sf_command_file].path_handle_name))) THEN
            osp$set_status_abnormal (ifc$interactive_facility_id,
                 ife$current_job_not_interactive, 'IFP$CHANGE_TERMINAL_ATTRIBUTES',
                 status);
            EXIT /change_terminal_attributes/;
          ELSE
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$file_name_not_terminal, ultimate_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
            EXIT /change_terminal_attributes/;
          IFEND;
        IFEND;
      IFEND;

      CASE iiv$network_identifier OF
      = iic$cdcnet_network =
      { STANDALONE }

{ Check for attributes which have no meaning on this type of terminal connection.

        FOR i := 1 TO UPPERBOUND (terminal_attributes) DO
          CASE terminal_attributes [i].key OF
          = ifc$pause_break_character, ifc$terminate_break_character, ifc$terminal_class =
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$illegal_nam_ve_change, 'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
            message_status := status;
            osp$generate_log_message (log, message_status, status);
          ELSE
          CASEND;
        FOREND;

        iip$st_chng_terminal_attributes (ultimate_name, terminal_attributes,
               status);

      = iic$dsiaf_network =
      { DUAL STATE }

{ Check for attributes which have no meaning on this type of terminal connection.

        IF NOT iiv$cdcnet_connection THEN
          FOR i := 1 TO UPPERBOUND (terminal_attributes) DO
            CASE terminal_attributes [i].key OF
            = ifc$begin_line_character, ifc$carriage_return_sequence,
              ifc$code_set, ifc$end_page_action, ifc$form_feed_delay, ifc$form_feed_sequence,
              ifc$hold_page_over, ifc$line_feed_sequence, ifc$end_output_sequence,
              ifc$control_code_replacement , ifc$function_key_class =
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$illegal_nam_ccp_change, 'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              message_status := status;
              osp$generate_log_message (log, message_status, status);
            ELSE
            CASEND;
          FOREND;
        ELSE
          FOR i := 1 TO UPPERBOUND (terminal_attributes) DO
            CASE terminal_attributes [i].key OF
            = ifc$pause_break_character, ifc$terminate_break_character,
              ifc$control_code_replacement =
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$illegal_nam_cdcnet_change, 'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              message_status := status;
              osp$generate_log_message (log, message_status, status);
            ELSE
            CASEND;
          FOREND;
        IFEND;

        iip$change_terminal_attributes (terminal_attributes, status);

      ELSE
      CASEND;

    END /change_terminal_attributes/;
    #KEYPOINT (osk$exit, 0, ifk$change_terminal_attributes);

  PROCEND ifp$change_terminal_attributes;
MODEND ifm$change_terminal_attributes;
*DECK DECK=IFM$CHANGE_TERM_CONN_ATTRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE ifm$change_term_conn_attributes;

{ PURPOSE:  This ring 3 module calls IIP$CHANGE_TERM_CONN_ATTRIBUTES
{           to change the default connection attributes for the named
{           file.  It does so only if the file was created by
{           RMP$REQUEST_TERMINAL.
{
{           Note that the attributes defined for previous opens of the
{           file will not be affected by the new attributes.
{
{  DESIGN:  The parameters on this call are used to call
{           IIP$CHANGE_TERM_CONN_ATTRIBUTES which works the same for
{           both dual state and standalone connections.
{
?? TITLE := 'MODULE ifm$change_term_conn_attributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc FST$FILE_REFERENCE
*copyc ife$error_codes
*copyc IFK$KEYPOINTS
*copyc IFT$CONNECTION_ATTRIBUTES
*copyc IIP$CHANGE_TERM_CONN_ATTRIBUTES
*copyc iiv$interactive_terminated
*copyc OST$STATUS
?? POP ??

*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal

?? NEWTITLE := 'PROCEDURE ifp$change_term_conn_attributes', EJECT ??
*copyc ifh$change_term_conn_attributes

  PROCEDURE [XDCL, #GATE {TS_gate} ] ifp$change_term_conn_attributes
    (terminal_file_name: fst$file_reference;
        term_conn_attributes: ift$connection_attributes;
    VAR status: ost$status);

    VAR
      i:integer,
      internal_file_name: amt$local_file_name;

    /change_term_conn_attributes/
    BEGIN
    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, ifk$change_term_conn_attributes);

    IF STRLENGTH (terminal_file_name) <= osc$max_name_size THEN
      internal_file_name := terminal_file_name;
    ELSE
      osp$set_status_abnormal (ifc$interactive_facility_id,
            ife$file_name_ill_formed, terminal_file_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
        'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
      RETURN;
    IFEND;

{ Check for attributes which have no meaning on this type of terminal connection.

    IF iiv$network_identifier = iic$dsiaf_network THEN
      IF NOT iiv$cdcnet_connection THEN
        FOR i := 1 TO UPPERBOUND (term_conn_attributes) DO
          CASE term_conn_attributes [i].key OF
          = ifc$trans_protocol_mode =
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$illegal_nam_ccp_conn_change,
                  'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);

            EXIT /change_term_conn_attributes/;
          ELSE
          CASEND;
        FOREND;
      IFEND;
    IFEND;

    iip$change_term_conn_attributes (internal_file_name, term_conn_attributes, status);
    END /change_term_conn_attributes/;
    #KEYPOINT (osk$exit, 0, ifk$change_term_conn_attributes);

  PROCEND ifp$change_term_conn_attributes;
MODEND ifm$change_term_conn_attributes;
*DECK DECK=IFM$CHANGE_TERM_CONN_DEFAULTS EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE ifm$change_term_conn_defaults;

{ PURPOSE:  This ring 3 module calls a ring 2 counterpart to change
{           the default connection attributes for the task.  The
{           effects of this change are not retroactive, i.e., the
{           attributes of files created before the change are not
{           affected, but subsequent file creations are.
{
{  DESIGN:  Either IIM$CHANGE_TERM_CONN_DEFAULTS is called for dual
{           state connections or IIM$ST_CHANGE_TERM_CONN_DEFAULTS for
{           standalone connections.  These routines directly change
{           the attributes in the task's task-shared attribute table
{           managed by IF to the corresponding input attribute values.
{
?? TITLE := 'MODULE ifm$change_term_conn_defaults' ??

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ife$error_codes
*copyc ifk$keypoints
*copyc iip$change_term_conn_defaults
*copyc iip$st_chnge_term_conn_defaults
*copyc iit$connection_description
*copyc iiv$interactive_terminated
?? POP ??

*copyc clp$validate_name
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc rmp$get_device_class

?? NEWTITLE := 'PROCEDURE ifp$change_term_conn_defaults', EJECT ??
*copyc ifh$change_term_conn_defaults

  PROCEDURE [XDCL, #GATE {TS_gate} ] ifp$change_term_conn_defaults
    (terminal_file_name: fst$file_reference;
        term_conn_attributes: ift$connection_attributes;
    VAR status: ost$status);

    VAR
      i:integer,
      converted_name: ost$name,
      device_assigned: boolean,
      device_class: rmt$device_class,
      device_is_network: boolean,
      valid_name: boolean;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, ifk$change_term_conn_defaults);

  /change_term_conn_defaults/
    BEGIN
      IF STRLENGTH (terminal_file_name) > osc$max_name_size THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$file_name_ill_formed, terminal_file_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
        EXIT /change_term_conn_defaults/;
      IFEND;

    { Convert and validate the file name.

      clp$validate_name (terminal_file_name, converted_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$file_name_ill_formed, terminal_file_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
        EXIT /change_term_conn_defaults/;
      IFEND;

    { Verify that the terminal file exists and that it is a network file.

      rmp$get_device_class (converted_name, device_assigned, device_class,
            status);
      IF NOT status.normal THEN
        EXIT /change_term_conn_defaults/;
      IFEND;
      device_is_network := (device_class = rmc$network_device) OR (device_class = rmc$terminal_device);

      IF NOT device_is_network THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$file_is_not_network_file, converted_name, status);
        EXIT /change_term_conn_defaults/;
      IFEND;

      CASE iiv$network_identifier OF
      = iic$cdcnet_network =

      { STANDALONE }
        iip$st_chnge_term_conn_defaults (converted_name, term_conn_attributes,
               status);

      = iic$dsiaf_network =

      { DUAL STATE }

{ Check for attributes which have no meaning on this type of terminal connection.

        IF NOT iiv$cdcnet_connection THEN
          FOR i := 1 TO UPPERBOUND (term_conn_attributes) DO
            CASE term_conn_attributes [i].key OF
            = ifc$trans_protocol_mode =
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$illegal_nam_ccp_conn_change,
                    'IFP$CHANGE_TERM_CONN_DEFAULTS', status);

              EXIT /change_term_conn_defaults/;
            ELSE
            CASEND;
          FOREND;
        IFEND;

        iip$change_term_conn_defaults (term_conn_attributes, status);

      CASEND;

    END /change_term_conn_defaults/;
    #KEYPOINT (osk$exit, 0, ifk$change_term_conn_defaults);

  PROCEND ifp$change_term_conn_defaults;
MODEND ifm$change_term_conn_defaults;
*DECK DECK=IFM$DEFAULT_CONDITION_HANDLER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Interactive Facility: Default Condition Handler' ??
MODULE ifm$default_condition_handler;

{
{ PURPOSE:
{   This module contains the default handler for interactive conditions.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := OFF) ??
*copyc ifc$interrupt
*copyc ife$error_codes
*copyc ift$condition_codes
*copyc ost$status
*copyc pmt$condition
?? POP ??
*copyc avp$ring_nominal
*copyc clp$get_processing_phase
*copyc clp$put_job_output
*copyc ifp$advance
*copyc ifp$begin_pause_utility
*copyc ifp$end_pause_utility
*copyc ifv$pause_utility_count
*copyc iip$report_status_error
*copyc jmp$system_job
*copyc osp$executing_in_job_monitor
*copyc osp$set_status_condition
*copyc pmp$dispose_interactive_cond
*copyc pmp$execute_with_less_privilege
*copyc pmp$log
*copyc jmp$system_job
?? TITLE := 'ifp$default_interactive_handler', EJECT ??

  PROCEDURE [XDCL] ifp$default_interactive_handler
    (    condition: pmt$condition;
     VAR status: ost$status);

    VAR
      local_status: ost$status;


    status.normal := TRUE;

    IF condition.interactive_condition = ifc$terminate_break THEN
      pmp$log (' processing terminate break condition', local_status);
      IF osp$executing_in_job_monitor () THEN
        IF NOT jmp$system_job () THEN
          ifp$advance (1, ifc$advance_all_queued_output, local_status);
        IFEND;
        pmp$log (' terminate break in $JOBMNTR ignored', local_status);
      ELSE
        osp$set_status_condition (ife$terminate_break_received, status);
      IFEND;
      RETURN;
    IFEND;

    IF condition.interactive_condition = ifc$terminal_connection_broken THEN

{ ignore this in default handler - tasks will hang on terminal io

      pmp$log (' disconnect ignored by default handler', local_status);
      RETURN;
    IFEND;

    IF condition.interactive_condition = ifc$interrupt THEN
      pmp$log (' Ifc$interrupt condition ignored by default handler', local_status);
      RETURN;
    IFEND;

    IF condition.interactive_condition = ifc$job_reconnect THEN
      clp$put_job_output (' Job has been reconnected to this terminal', local_status);
    IFEND;

{ treat pause break and terminal reconnect the same

{ ignore pause breaks if max are currently pending
{ (treat as though the pause break was handled)

    IF NOT jmp$system_job () THEN
      IF ifv$pause_utility_count = ifc$pause_utility_count_maximum THEN
        clp$put_job_output (' Pause break ignored - the nested pause break limit has been exceeded',
              local_status);
        RETURN;
      IFEND;
    IFEND;

{ start pause utility - pause break

    ifp$start_pause_utility (status);

    IF status.normal THEN
      pmp$log ('resume after break', local_status);
      RETURN;
    IFEND;

{ raise terminate condition within the task

    pmp$log (' terminate_command causing terminate condition', local_status);
    pmp$dispose_interactive_cond (ifc$terminate_break);
    status.normal := TRUE;

  PROCEND ifp$default_interactive_handler;
?? TITLE := 'ifp$start_pause_utility', EJECT ??

  PROCEDURE [XDCL, #GATE] ifp$start_pause_utility
    (VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      pd: ^SEQ (REP 1 of pmt$program_attributes),
      ppa: ^pmt$program_attributes,
      params: SEQ (REP 1 of char),
      processing_phase: clt$processing_phase,
      tid: pmt$task_id,
      tsts: pmt$task_status;


    status.normal := TRUE;

    clp$get_processing_phase (processing_phase, ignore_status);

    IF (NOT jmp$system_job ()) AND ((processing_phase < clc$user_prolog_phase) OR
          (processing_phase > clc$user_epilog_phase)) THEN
      RETURN;
    IFEND;

    ifp$begin_pause_utility (ignore_status);

    PUSH pd;
    RESET pd;
    NEXT ppa IN pd;
    ppa^.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$load_map_options_specified,
          pmc$term_error_level_specified, pmc$debug_mode_specified];
    ppa^.starting_procedure := 'IIP$PAUSE_UTILITY';
    ppa^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    ppa^.termination_error_level := pmc$warning_load_errors;
    ppa^.debug_mode := pmc$debug_mode_off;
    RESET pd;
    pmp$execute_with_less_privilege (avp$ring_nominal (), pd^, params,
          osc$wait, FALSE, tid, tsts, status);
    IF NOT status.normal THEN
      ifp$end_pause_utility (ignore_status);
      iip$report_status_error (status, 'execute pause util');
      RETURN;
    IFEND;
    status := tsts.status;

    ifp$end_pause_utility (ignore_status);

  PROCEND ifp$start_pause_utility;

MODEND ifm$default_condition_handler;
*DECK DECK=IFM$DISCONNECT_RECONNECT EXPAND=TRUE
MODULE ifm$disconnect_reconnect;
*copyc OSD$DEFAULT_PRAGMATS

?? PUSH (LISTEXT := ON) ??
*copyc IIT$INTERACTIVE_SIGNAL_TYPE
*copyc ift$title_for_error_codes
*copyc IIV$CONNECTION_DESC_PTR
*copyc IIV$INTERACTIVE_TERMINATED
*copyc ost$global_task_id
*copyc OST$STATUS
*copyc tmc$signal_identifiers
*copyc ifk$keypoints
?? POP ??

*copyc PMP$SEND_SIGNAL

?? TITLE := 'PROCEDURE ifp$disconnect', EJECT ??

  PROCEDURE [XDCL] ifp$disconnect (VAR status: ost$status);

    VAR
      signal: pmt$signal,
      isig: ^iit$interactive_signal;

    #KEYPOINT (osk$entry, 0, ifk$disconnect);

    signal.identifier := ifc$signal_id;
    isig := #LOC (signal.contents);
    isig^ := iic$disconnect_request;
    pmp$send_signal (iiv$job_monitor_task_id, signal, status);

    #KEYPOINT (osk$exit, 0, ifk$disconnect);

  PROCEND ifp$disconnect;
?? TITLE := 'PROCEDURE ifp$reconnect', EJECT ??

  PROCEDURE [XDCL] ifp$reconnect (global_task_id: ost$global_task_id;
    VAR status: ost$status);

    VAR
      signal: pmt$signal,
      isig: ^iit$reconnect_request;

    signal.identifier := ifc$signal_id;
    isig := #LOC (signal.contents);
    isig^.sig := iic$reconnect_request;
    isig^.gtid := global_task_id;
    pmp$send_signal (iiv$job_monitor_task_id, signal, status);

  PROCEND ifp$reconnect;
MODEND ifm$disconnect_reconnect
*DECK DECK=IFM$FAP_CONTROL EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ifm$fap_control;
?? TITLE := 'MODULE ifm$fap_control' ??
*copyc AME$DEVICE_CLASS_VALIDATION
*copyc AME$OPEN_VALIDATION_ERRORS
*copyc AMP$ACCESS_METHOD
*copyc AMP$FETCH_FAP_POINTER
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc AMP$STORE_FAP_POINTER
*copyc AMT$FAP_POINTER
*copyc AMT$SKIP_OPTION
*copyc AMT$TERM_OPTION
*copyc bat$task_file_table
*copyc bav$last_tft_entry
*copyc bav$task_file_table
*copyc IFP$MARK_ATTRIBUTES_CHANGE
*copyc ife$error_codes
*copyc IIP$ALLOCATE_QUEUE_ENTRY
*copyc IIP$CHECK_FOR_CONDITION
*copyc IIP$CHECK_IF_STATUS
*copyc IIP$CLOSE
*copyc IIP$FETCH_ACCESS_INFORMATION
*copyc IIP$FETCH_TERM_CONN_ATTRIBUTES
*copyc IIP$FETCH_TERMINAL
*copyc IIP$FLUSH
*copyc IIP$FREE_QUEUE_ENTRY
*copyc IIP$GET
*copyc IIP$OPEN
*copyc IIP$PUT
*copyc IIP$REPORT_STATUS_ERROR
*copyc iip$search_connection_desc
*copyc IIP$STORE_TERMINAL
*copyc IIP$STORE_TERM_CONN_ATTRIBUTES
*copyc IIP$ST_ALLOCATE_QUEUE_ENTRY
*copyc IIP$ST_CLOSE
*copyc IIP$ST_FETCH_ACCESS_INFORMATION
*copyc IIP$ST_FLUSH
*copyc IIP$ST_GET
*copyc IIP$ST_OPEN
*copyc IIP$ST_PUT
*copyc IIP$UPDATE_OPEN_DESC_ATTRIBUTES
*copyc jmp$handle_ts_io_req_failure
*copyc jmp$ts_io_request_valid
*copyc IIV$CONNECTION_DESC_PTR
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIV$INT_TASK_OPEN_FILE_COUNT
*copyc iiv$interactive_terminated
*copyc jmv$terminal_io_disabled
*copyc osp$set_status_abnormal
*copyc OSS$TASK_PRIVATE
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc OST$STATUS
*copyc OSV$TASK_PRIVATE_HEAP
*copyc PMT$CONDITION_INFORMATION

?? NEWTITLE := 'PROCEDURE ifp$fap_control_ring_3', EJECT ??

  PROCEDURE [XDCL, #GATE] ifp$fap_control_ring_3 (file_id: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR callers_status: ost$status);

    VAR
      connection_desc_ptr: ^iit$connection_description,
      file_identifier: amt$file_identifier,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      open_file_entry_descriptor: iit$queue_entry_descriptor,
      st_open_file_entry_descriptor: iit$st_queue_entry_descriptor,
      open_file_dsc_pointer: ^iit$open_file_description,
      st_open_file_dsc_pointer: ^iit$st_open_file_description,
      fetch_attributes_pointer: ^amt$fetch_attributes,
      i: integer,
      pc: ^cell,
      sell: cell,
      status: ost$status,
      local_status: ost$status;

    status.normal := TRUE;
    open_file_dsc_pointer := NIL;

    /status_change_block/
    BEGIN
    IF call_block.operation = amc$open_req THEN

{ Detect improper access level ( physical access or segment access ).

      IF call_block.open.access_level = amc$physical THEN
        amp$set_file_instance_abnormal (file_id,
              ame$not_physical_access_device, call_block.operation, 'TERMINAL',
              callers_status);
        RETURN;
      IFEND;

      IF call_block.open.access_level = amc$segment THEN
        amp$set_file_instance_abnormal (file_id, ame$not_virtual_memory_device,
              call_block.operation, 'TERMINAL', callers_status);
        RETURN;
      IFEND;
        { check for disconnect condition on open to save environment
        iip$check_if_status(status);
        IF NOT status.normal THEN
        iip$check_for_condition (status);
        IF NOT status.normal THEN
          callers_status := status;
          RETURN;
        IFEND;
        IFEND;

{ Build open file description entry and store the pointer.

        iip$allocate_queue_entry (iic$open_file_description,
              open_file_entry_descriptor, status);
        IF NOT status.normal THEN
          EXIT /status_change_block/;
        IFEND;
        open_file_dsc_pointer := open_file_entry_descriptor.
              open_file_description_ptr;

        file_identifier := file_id;
*copy bai$validate_file_identifier
        IF file_id_is_valid AND
          (file_instance <> NIL) THEN
          IF file_instance^.device_class =
            rmc$terminal_device THEN
            file_instance^.open_file_dsc_pointer :=
            open_file_dsc_pointer;
          ELSE
            osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$file_name_not_terminal,
              file_instance^.local_file_name,status);
          IFEND;
        ELSE
          osp$set_status_abnormal (ifc$interactive_facility_id,
            ife$file_name_not_terminal,
            file_instance^.local_file_name,status);
        IFEND;
        IF NOT status.normal THEN
          EXIT /status_change_block/;
        IFEND;

        iip$open (file_id, open_file_dsc_pointer, call_block.open.
              local_file_name, layer_number, status);

      IF NOT status.normal THEN
        EXIT /status_change_block/;
      IFEND;

      amp$access_method (file_id, call_block, layer_number, status);

    ELSEIF call_block.operation = amc$close_req THEN

        file_identifier := file_id;
*copy bai$validate_file_identifier
*copy iii$fetch_open_file_desc_ptr
        IF NOT status.normal THEN
          EXIT /status_change_block/;
        IFEND;

        iip$close (file_id, open_file_dsc_pointer, status);

      amp$access_method (file_id, call_block, layer_number, status);
    ELSE

{ all reqs other than open/close respect if condition state

        iip$check_if_status(status);
        IF NOT status.normal THEN
          iip$check_for_condition (status);
          IF NOT status.normal THEN
            EXIT /status_change_block/;
          IFEND;
        IFEND;

{ Get pointer to open file description which was stored on the open.

        file_identifier := file_id;
*copy bai$validate_file_identifier
*copy iii$fetch_open_file_desc_ptr
        IF NOT status.normal THEN
          EXIT /status_change_block/;
        IFEND;


      CASE call_block.operation OF

      = amc$get_next_req =

        pc := call_block.getn.working_storage_area;
        sell := pc^;
        pc^ := sell;
        pc := call_block.getn.transfer_count;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;
        pc := call_block.getn.byte_address;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;
        pc := call_block.getn.file_position;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;

          iip$get (file_id, open_file_dsc_pointer, call_block.operation,
                call_block.getn.working_storage_area, call_block.getn.
                working_storage_length, NIL, call_block.getn.transfer_count,
                call_block.getn.byte_address, call_block.getn.file_position,
                amc$skip_to_eor, status);

      = amc$get_partial_req =

        pc := call_block.getp.working_storage_area;
        sell := pc^;
        pc^ := sell;
        pc := call_block.getp.record_length;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;
        pc := call_block.getp.transfer_count;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;
        pc := call_block.getp.byte_address;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;
        pc := call_block.getp.file_position;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;

          iip$get (file_id, open_file_dsc_pointer, call_block.operation,
                call_block.getp.working_storage_area, call_block.getp.
                working_storage_length, call_block.getp.record_length,
                call_block.getp.transfer_count, call_block.getp.byte_address,
                call_block.getp.file_position, call_block.getp.skip_option,
                status);

      = amc$get_direct_req =

        pc := call_block.getd.working_storage_area;
        sell := pc^;
        pc^ := sell;
        pc := call_block.getd.transfer_count;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;
        pc := call_block.getd.file_position;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;

          iip$get (file_id, open_file_dsc_pointer, call_block.operation,
                call_block.getd.working_storage_area, call_block.getd.
                working_storage_length, NIL, call_block.getd.transfer_count, NIL,
                call_block.getd.file_position, amc$skip_to_eor, status);

      = amc$put_next_req =

        IF (call_block.putn.working_storage_length >= 0) AND (call_block.putn.working_storage_length <=
               UPPERVALUE (amt$working_storage_length)) AND
               ((call_block.putn.working_storage_area <> NIL) OR
                 ((call_block.putn.working_storage_area = NIL) AND
                 (call_block.putn.working_storage_length = 0))) THEN
            iip$put (file_id, open_file_dsc_pointer, call_block.operation,
                  call_block.putn.working_storage_area, call_block.putn.
                  working_storage_length, call_block.putn.byte_address,
                  amc$terminate, status);

        ELSE
          IF call_block.putn.working_storage_area = NIL THEN
            osp$set_status_abnormal (ifc$interactive_facility_id, ife$wsa_is_nil, '', status);
          ELSE
            osp$set_status_abnormal (ifc$interactive_facility_id, ife$wsl_out_of_range, '', status);
          IFEND;
        IFEND;

      = amc$put_partial_req =

          iip$put (file_id, open_file_dsc_pointer, call_block.operation,
                call_block.putp.working_storage_area, call_block.putp.
                working_storage_length, call_block.putp.byte_address, call_block.
                putp.term_option, status);

      = amc$put_direct_req =

          iip$put (file_id, open_file_dsc_pointer, call_block.operation,
                call_block.putd.working_storage_area, call_block.putd.
                working_storage_length, NIL, amc$terminate, status);

      = amc$flush_req =

          iip$flush (file_id, open_file_dsc_pointer, status);

      = amc$fetch_access_information_rq =

        pc := call_block.fai.access_information;
        sell := pc^;
        pc^ := sell;

          iip$fetch_access_information (file_id, open_file_dsc_pointer,
                call_block.fai.access_information, status);

      = ifc$fetch_terminal_req =

        pc := call_block.fetch_terminal.terminal_attributes;
        sell := pc^;
        pc^ := sell;

          iip$fetch_terminal (file_id, open_file_dsc_pointer, call_block.fetch_terminal.
                terminal_attributes, status);

      = ifc$store_terminal_req =

        pc := call_block.store_terminal.terminal_attributes;
        sell := pc^;

          iip$store_terminal (file_id, open_file_dsc_pointer, call_block.store_terminal.
                terminal_attributes, status);

      = amc$seek_direct_req, amc$skip_req, amc$rewind_req, amc$replace_req,
            amc$write_end_partition_req =

        status.normal := TRUE;

      = amc$fetch_req =

{ Update the open file description attributes if they might have been changed.

          IF open_file_dsc_pointer^.connection_desc_pointer <> NIL THEN
            IF open_file_dsc_pointer^.attributes_cycle <> open_file_dsc_pointer^.
                  connection_desc_pointer^.attributes_cycle THEN
              iip$update_open_desc_attributes (file_id, open_file_dsc_pointer,
                    amc$fetch_req, local_status);
            IFEND;
          IFEND;

        amp$access_method (file_id, call_block, layer_number, status);

{ Return the interactive values for page_length and page_width if they have
{ not been specified by BAM requests.

        IF status.normal THEN

          fetch_attributes_pointer := call_block.fetch.file_attributes;

        /fix_page_length_and_page_width/
          FOR i := LOWERBOUND (fetch_attributes_pointer^) TO UPPERBOUND
                (fetch_attributes_pointer^) DO
            IF ((fetch_attributes_pointer^ [i].key = amc$page_length) AND
                  ((fetch_attributes_pointer^ [i].source =
                  amc$undefined_attribute) OR (fetch_attributes_pointer^ [i].
                  source = amc$access_method_default))) THEN

                IF open_file_dsc_pointer^.connection_desc_pointer^.terminal_attributes.page_length = 0 THEN
                  fetch_attributes_pointer^ [i].page_length := UPPERVALUE (amt$page_length);
                ELSE
                  fetch_attributes_pointer^ [i].page_length := open_file_dsc_pointer^.
                        connection_desc_pointer^.terminal_attributes.page_length;
                IFEND;

              CYCLE /fix_page_length_and_page_width/;

            IFEND;
            IF ((fetch_attributes_pointer^ [i].key = amc$page_width) AND
                  ((fetch_attributes_pointer^ [i].source =
                  amc$undefined_attribute) OR (fetch_attributes_pointer^ [i].
                  source = amc$access_method_default))) THEN

                IF open_file_dsc_pointer^.connection_desc_pointer^.terminal_attributes.page_width = 0 THEN
                  fetch_attributes_pointer^ [i].page_width := amc$max_page_width;
                ELSE
                  fetch_attributes_pointer^ [i].page_width := open_file_dsc_pointer^.
                        connection_desc_pointer^.terminal_attributes.page_width;
                IFEND;

              CYCLE /fix_page_length_and_page_width/;

            IFEND;
          FOREND /fix_page_length_and_page_width/;

        IFEND;

      = amc$store_req =

        pc := call_block.store.file_attributes;
        sell := pc^;

        amp$access_method (file_id, call_block, layer_number, status);

      ELSE

{ The operation is improper for a terminal device.

        amp$set_file_instance_abnormal (file_id, ame$improper_device_class,
              call_block.operation, 'terminal', status);
      CASEND;

    IFEND;

    END /status_change_block/;

    IF status.normal THEN
      callers_status.normal := TRUE;
      callers_status.condition := 0;
    ELSE
      CASE call_block.operation OF
      = amc$put_next_req, amc$put_partial_req, amc$put_direct_req, amc$flush_req =
        IF (status.condition = jme$job_is_in_termination) OR (status.condition = jme$task_is_in_termination)
           OR jmv$terminal_io_disabled THEN
          status.normal := TRUE;
          status.condition := 0;
        IFEND;
      ELSE
      CASEND;

      callers_status := status;
    IFEND;

{ Save access information for this request.

    IF open_file_dsc_pointer <> NIL THEN

      IF callers_status.normal THEN
        open_file_dsc_pointer^.error_status := 0;
      ELSE
        open_file_dsc_pointer^.error_status := callers_status.condition;
      IFEND;

      IF (call_block.operation <> amc$fetch_access_information_rq) AND
        (call_block.operation <> amc$fetch_req) THEN
        open_file_dsc_pointer^.last_access_operation := call_block.operation;
      IFEND;

    IFEND;

  PROCEND ifp$fap_control_ring_3;

MODEND ifm$fap_control;
*DECK DECK=IFM$FETCH_CONTEXT EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE ifm$fetch_context;
?? TITLE := 'MODULE ifm$fetch_context' ??

?? PUSH (LISTEXT := ON) ??
*copyc iip$fetch_context
*copyc ift$fetch_context_attributes
*copyc nat$data_fragments
*copyc OST$STATUS
*copyc ifk$keypoints
?? POP ??

?? NEWTITLE := 'PROCEDURE ifp$fetch_context', EJECT ??

  PROCEDURE [XDCL, #GATE] ifp$fetch_context (VAR {i/o} context_attributes:
    ift$fetch_context_attributes;
    VAR status: ost$status);

    #KEYPOINT (osk$entry, 0, ifk$fetch_context);

    status.normal := TRUE;

    iip$fetch_context (context_attributes, status);

    #KEYPOINT (osk$exit, 0, ifk$fetch_context);

  PROCEND ifp$fetch_context;

MODEND ifm$fetch_context;
*DECK DECK=IFM$FETCH_TERM_CONN_ATTRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE ifm$fetch_term_conn_attributes;

{ MODULE DECK IFMFT }

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] IFP$FETCH_TERM_CONN_ATTRIBUTES' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc IFK$KEYPOINTS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
*copyc IFH$FETCH_TERMINAL
?? EJECT ??

  PROCEDURE [XDCL, #GATE] ifp$fetch_term_conn_attributes (file_identifier:
    amt$file_identifier;
    VAR terminal_attributes: ift$get_connection_attributes;
    VAR status: ost$status);


    CONST
      interface_name = 'IFP$FETCH_TERM_CONN_ATTRIBUTES',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #KEYPOINT (osk$entry, file_identifier.ordinal * osk$m, ifk$fetch_term_conn_attributes);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #KEYPOINT (osk$exit, 0, ifk$fetch_term_conn_attributes);
      RETURN;
    IFEND;

    call_block.operation := ifc$fetch_terminal_req;

    call_block.fetch_terminal.terminal_attributes := ^terminal_attributes;

*copy bai$call_fap_control

    IF bam_status.normal THEN
      #KEYPOINT (osk$exit, 0, ifk$fetch_term_conn_attributes);
    ELSE
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF bam_status.normal THEN
        #KEYPOINT (osk$exit, 0, ifk$fetch_term_conn_attributes);
      ELSE
        status := bam_status;
        #KEYPOINT (osk$exit, 0, ifk$fetch_term_conn_attributes);
      IFEND;
    IFEND;
  PROCEND ifp$fetch_term_conn_attributes;
MODEND ifm$fetch_term_conn_attributes;
*DECK DECK=IFM$GET_NETWORK_IDENTIFIER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Interactive Facility : Get String Identifying Network' ??
MODULE ifm$get_network_identifier;

{
{ PURPOSE:
{   This module contains an interface that returns an identifier for the
{   interactive network to which the requesting job is connected.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ift$network_identifier
*copyc ost$status
?? POP ??
*copyc iiv$interactive_terminated
*copyc jmp$get_job_attributes
?? TITLE := 'ifp$get_network_identifier', EJECT ??
*copyc ifh$get_network_identifier

  PROCEDURE [XDCL, #GATE] ifp$get_network_identifier
    (VAR network_identifier: ift$network_identifier;
     VAR status: ost$status);

    VAR
      job_attributes: array [1 .. 2] of jmt$job_attribute_result;


    status.normal := TRUE;

    job_attributes [1].key := jmc$job_mode;
    job_attributes [2].key := jmc$c170_os_type;

    jmp$get_job_attributes (^job_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF job_attributes [1].job_mode <> jmc$interactive_connected THEN
      network_identifier := ifc$ni_none;
    ELSEIF iiv$network_identifier = iic$cdcnet_network THEN
      network_identifier := ifc$ni_nam_ve_cdcnet;
    ELSEIF job_attributes [2].c170_os_type = osc$ot7_dual_state_nos_be THEN
      network_identifier := ifc$ni_intercom;
    ELSEIF iiv$cdcnet_connection THEN
      network_identifier := ifc$ni_nam_cdcnet;
    ELSE
      network_identifier := ifc$ni_nam_ccp;
    IFEND;

  PROCEND ifp$get_network_identifier;

MODEND ifm$get_network_identifier;
*DECK DECK=IFM$GET_PAGE_LENGTH_WIDTH EXPAND=TRUE
*copyc osd$default_pragmats
MODULE ifm$get_page_length_width;

{ PURPOSE:  Ring 3 interface which calls a ring 2 procedure to retrieve
{           the page length and width attribute values for a connection.
{
{  DESIGN:  IIP$GET_PAGE_LENGTH_WIDTH is called to interlock the table of
{           terminal attributes for the connection and to return the PW
{           and PL attribute values.
{
?? TITLE := 'MODULE ifm$get_page_length_width' ??
?? PUSH (LISTEXT := ON) ??
*copyc iip$get_page_length_width
?? POP ??
?? NEWTITLE := 'PROCEDURE ifp$get_page_length_width' ??

  PROCEDURE [XDCL, #GATE] ifp$get_page_length_width (terminal_path_handle: fmt$path_handle;
    VAR page_length_width: array [1 .. 2] of ift$terminal_attribute;
    VAR status: ost$status);

    iip$get_page_length_width (terminal_path_handle, page_length_width, status);

  PROCEND ifp$get_page_length_width;
MODEND ifm$get_page_length_width;
*DECK DECK=IFM$GET_TELNET_CONNECTION_LIMIT EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'Telnet Connection Time Limit' ??
MODULE ifm$get_telnet_connection_limit;

*copyc ifv$telnet_connection_limit

  PROCEDURE [XDCL, #GATE] ifp$get_telnet_connection_limit
    (VAR telnet_connection_limit: integer);

    telnet_connection_limit := ifv$telnet_connection_limit;

  PROCEND ifp$get_telnet_connection_limit;

MODEND ifm$get_telnet_connection_limit;
*DECK DECK=IFM$GET_TERMINAL_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ifm$get_terminal_attributes;
?? TITLE := 'MODULE ifm$get_terminal_attributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc fst$file_reference
*copyc ife$error_codes
*copyc IFK$KEYPOINTS
*copyc ift$terminal_attributes
*copyc OST$STATUS
?? POP ??

*copyc clp$validate_name
*copyc clp$get_ultimate_connection
*copyc clv$standard_files
*copyc IIP$GET_TERMINAL_ATTRIBUTES
*copyc iip$st_get_terminal_attributes
*copyc iiv$connection_desc_ptr
*copyc iiv$interactive_terminated
*copyc iip$xlate_local_file_to_session
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc pmp$get_job_mode
*copyc rmp$get_device_class

?? NEWTITLE := 'PROCEDURE ifp$get_terminal_attributes', EJECT ??
*copyc ifh$get_terminal_attributes
  PROCEDURE [XDCL, #GATE {TS_gate} ] ifp$get_terminal_attributes
    (terminal_file_name: fst$file_reference;
    VAR terminal_attributes: ift$terminal_attributes;
    VAR status: ost$status);

   VAR
      attributes_mapped: integer,
      converted_name: ost$name,
      device_assigned: boolean,
      device_class: rmt$device_class,
      device_is_network: boolean,
      i: integer,
      internal_file_name: amt$local_file_name,
      j: integer,
      job_mode: jmt$job_mode,
      local_status: ost$status,
      map: ^array [1 .. * {ifc$max_terminal_attribute_key}] OF integer,
      mapped_attributes: ^ift$terminal_attributes,
      temp_file_name: ost$name,
      ultimate_name: amt$local_file_name,
      valid_name: boolean,
      validated_terminal_file_name: ost$name;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, ifk$get_terminal_attributes);

  /get_terminal_attributes/
    BEGIN
      IF STRLENGTH (terminal_file_name) <= osc$max_name_size THEN
        internal_file_name := terminal_file_name;
      ELSE
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$file_name_ill_formed, terminal_file_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$GET_TERMINAL_ATTRIBUTES', status);
        EXIT /get_terminal_attributes/;
      IFEND;

    { Convert and validate the file name.

      clp$get_ultimate_connection (internal_file_name, ultimate_name, status);
      IF NOT status.normal THEN
        EXIT /get_terminal_attributes/;
      IFEND;
      clp$validate_name (ultimate_name, converted_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$file_name_ill_formed, internal_file_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$GET_TERMINAL_ATTRIBUTES', status);
        EXIT /get_terminal_attributes/;
      IFEND;

      CASE iiv$network_identifier OF
      = iic$cdcnet_network =

      { STANDALONE }
      { Verify that the terminal file exists and that it is a network file.

        validated_terminal_file_name := converted_name;
        rmp$get_device_class (validated_terminal_file_name, device_assigned, device_class,
              status);
        IF NOT status.normal THEN
          EXIT /get_terminal_attributes/;
        IFEND;
        device_is_network := (device_class = rmc$network_device) OR (device_class = rmc$terminal_device);

        IF NOT device_is_network THEN
          pmp$get_job_mode (job_mode, local_status);
          IF NOT local_status.normal THEN
            status := local_status;
            EXIT /get_terminal_attributes/;
          ELSEIF (NOT (job_mode IN $iit$job_modes [jmc$interactive_connected,
                 jmc$interactive_cmnd_disconnect, jmc$interactive_line_disconnect,
                 jmc$interactive_sys_disconnect]) AND
                 (((ultimate_name = clv$standard_files [clc$sf_job_input_file].path_handle_name) OR
                 (ultimate_name = clv$standard_files [clc$sf_job_output_file].path_handle_name)) OR
                 (ultimate_name = clv$standard_files [clc$sf_command_file].path_handle_name))) THEN
            osp$set_status_abnormal (ifc$interactive_facility_id,
                 ife$current_job_not_interactive, 'IFP$GET_TERMINAL_ATTRIBUTES',
                 status);
            EXIT /get_terminal_attributes/;
          ELSE
            osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$file_name_not_terminal, converted_name, status);
            EXIT /get_terminal_attributes/;
          IFEND;
        IFEND;

        attributes_mapped := 0;
        FOR i:=1 to UPPERBOUND(terminal_attributes) DO
          CASE terminal_attributes [i].key OF
          = ifc$pause_break_character, ifc$terminal_class, ifc$terminate_break_character =

          ELSE
            attributes_mapped := attributes_mapped + 1;
          CASEND;
        FOREND;

        IF attributes_mapped <> 0 THEN
          PUSH map :[1 .. attributes_mapped];
          PUSH mapped_attributes :[1 .. attributes_mapped];
        IFEND;

        j := 0;
        FOR i:=1 to UPPERBOUND (terminal_attributes) DO
          CASE terminal_attributes [i].key OF
          = ifc$pause_break_character, ifc$terminal_class,
            ifc$terminate_break_character =
            terminal_attributes [i].key := ifc$null_terminal_attribute;

          ELSE
          j := j + 1;
          map^ [j] := i;
          mapped_attributes^ [j] := terminal_attributes [i];
          CASEND;
        FOREND;

        IF attributes_mapped > 0 THEN

          iip$st_get_terminal_attributes (ultimate_name, mapped_attributes^, status);

          FOR j:=1 to attributes_mapped DO
            terminal_attributes [map^ [j]] := mapped_attributes^ [j];
          FOREND;

        IFEND;

      = iic$dsiaf_network =

      { DUAL STATE }

      { Verify that the file is assigned to a terminal device.

        rmp$get_device_class (converted_name, device_assigned, device_class,
              local_status);
        IF NOT local_status.normal THEN
          status := local_status;
          EXIT /get_terminal_attributes/;
        ELSE
          IF device_class <> rmc$terminal_device THEN
            pmp$get_job_mode (job_mode, local_status);
            IF NOT local_status.normal THEN
              status := local_status;
              EXIT /get_terminal_attributes/;
            ELSEIF (NOT (job_mode IN $iit$job_modes [jmc$interactive_connected,
                   jmc$interactive_cmnd_disconnect, jmc$interactive_line_disconnect,
                   jmc$interactive_sys_disconnect]) AND
                   (((ultimate_name = clv$standard_files [clc$sf_job_input_file].path_handle_name) OR
                   (ultimate_name = clv$standard_files [clc$sf_job_output_file].path_handle_name)) OR
                   (ultimate_name = clv$standard_files [clc$sf_command_file].path_handle_name))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                   ife$current_job_not_interactive, 'IFP$GET_TERMINAL_ATTRIBUTES',
                   status);
              EXIT /get_terminal_attributes/;
            ELSE
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$file_name_not_terminal, converted_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$GET_TERMINAL_ATTRIBUTES', status);
              EXIT /get_terminal_attributes/;
            IFEND;
          IFEND;
        IFEND;

        IF NOT iiv$cdcnet_connection THEN

        { For those attributes which are ignored in dual state 255x connections,
        { replace their keys in terminal_attributes with ifc$null_terminal_attribute.

          FOR i := 1 TO UPPERBOUND (terminal_attributes) DO
            CASE terminal_attributes [i].key OF
            = ifc$attention_character, ifc$begin_line_character, ifc$carriage_return_sequence,
              ifc$code_set, ifc$end_page_action, ifc$form_feed_delay, ifc$form_feed_sequence,
              ifc$hold_page_over, ifc$line_feed_sequence,
              ifc$control_code_replacement, ifc$function_key_class =

              terminal_attributes [i].key := ifc$null_terminal_attribute;
            ELSE
            { All other attributes will have their values returned.
            CASEND;

          FOREND;

        ELSE

          FOR i := 1 TO UPPERBOUND (terminal_attributes) DO
            CASE terminal_attributes [i].key OF
            = ifc$control_code_replacement, ifc$line_feed_sequence =

              terminal_attributes [i].key := ifc$null_terminal_attribute;
            ELSE
            { All other attributes will have their values returned.
            CASEND;
          FOREND;
        IFEND;

        iip$get_terminal_attributes (terminal_attributes, status);

      ELSE

      CASEND;

    END /get_terminal_attributes/;

    #KEYPOINT (osk$exit, 0, ifk$get_terminal_attributes);

  PROCEND ifp$get_terminal_attributes;

MODEND ifm$get_terminal_attributes;
*DECK DECK=IFM$GET_TERM_CONN_ATTRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE IFM$GET_TERM_CONN_ATTRIBUTES;

{ PURPOSE:  For the named file, return the requested attribute values.
{
{  DESIGN:  This ring 3 module simply calls its ring 2 counterpart,
{           iim$get_term_conn_attributes, to get the attribute values
{           from the Local Name Table (LNT) entry for the named file.

?? TITLE := 'MODULE ifm$get_term_conn_attributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc FST$FILE_REFERENCE
*copyc ife$error_codes
*copyc IFK$KEYPOINTS
*copyc IFT$GET_CONNECTION_ATTRIBUTES
*copyc clp$get_ultimate_connection
*copyc IIP$GET_TERM_CONN_ATTRIBUTES
*copyc iiv$interactive_terminated
*copyc OST$STATUS
?? POP ??

*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal

?? NEWTITLE := 'PROCEDURE ifp$get_term_conn_attributes', EJECT ??
*copyc ifh$get_term_conn_attributes

  PROCEDURE [XDCL, #GATE {TS_gate} ] ifp$get_term_conn_attributes
    (terminal_file_name: fst$file_reference;
    VAR term_conn_attributes: ift$get_connection_attributes;
    VAR status: ost$status);

    VAR
      i: integer,
      internal_file_name: amt$local_file_name,
      ultimate_name: amt$local_file_name;

    status.normal := TRUE;

    #KEYPOINT (osk$entry, 0, ifk$get_term_conn_attributes);

    IF STRLENGTH (terminal_file_name) <= osc$max_name_size THEN
      internal_file_name := terminal_file_name;
    ELSE
      osp$set_status_abnormal (ifc$interactive_facility_id,
            ife$file_name_ill_formed, terminal_file_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
        'IFP$GET_TERM_CONN_ATTRIBUTES', status);
      RETURN;
    IFEND;

    clp$get_ultimate_connection (internal_file_name, ultimate_name, status);
    IF NOT status.normal THEN
      return;
    IFEND;

    IF iiv$network_identifier = iic$dsiaf_network THEN
      IF NOT iiv$cdcnet_connection THEN

      { For those attributes which are ignored in dual state 255x connections,
      { replace their keys in term_conn_attributes with ifc$null_connection_attribute.

        FOR i := 1 TO UPPERBOUND (term_conn_attributes) DO
          CASE term_conn_attributes [i].key OF
          = ifc$trans_protocol_mode =
            term_conn_attributes [i].key := ifc$null_connection_attribute;

          ELSE
          { All other attributes will have their values returned.
          CASEND;

        FOREND;
      IFEND;
    IFEND;
    iip$get_term_conn_attributes (ultimate_name, term_conn_attributes, status);

    #KEYPOINT (osk$exit, 0, ifk$get_term_conn_attributes);

  PROCEND ifp$get_term_conn_attributes;

MODEND ifm$get_term_conn_attributes;
*DECK DECK=IFM$GET_TERM_CONN_DEFAULTS EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE ifm$get_term_conn_defaults;

{ PURPOSE:  Return the task-level defaults for the requested attributes.
{
{  DESIGN:  This ring 3 module simply calls its ring 2 counterpart,
{           iim$get_term_conn_defaults, to retrieve the values from
{           the default attributes in the connection table (standalone)
{           or the attributes table pointed at by iiv$terminal_request_ptr
{           (dual state).
{
?? TITLE := 'MODULE ifm$get_term_conn_defaults' ??

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ife$error_codes
*copyc ifk$keypoints
*copyc ift$get_connection_attributes
*copyc iip$get_term_conn_defaults
*copyc iit$connection_description
*copyc iiv$interactive_terminated
*copyc OST$STATUS
?? POP ??

*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal

?? NEWTITLE := 'PROCEDURE ifp$get_term_conn_defaults', EJECT ??
*copyc ifh$get_term_conn_defaults

  PROCEDURE [XDCL, #GATE {TS_gate} ] ifp$get_term_conn_defaults
    (terminal_file_name: fst$file_reference;
    VAR term_conn_attributes: ift$get_connection_attributes;
    VAR status: ost$status);

    VAR
      i:integer,
      internal_file_name: amt$local_file_name;

    status.normal := TRUE;

    #KEYPOINT (osk$entry, 0, ifk$get_term_conn_defaults);

    IF STRLENGTH (terminal_file_name) <= osc$max_name_size THEN
      internal_file_name := terminal_file_name;
    ELSE
      osp$set_status_abnormal (ifc$interactive_facility_id,
            ife$file_name_ill_formed, terminal_file_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
        'IFP$GET_TERM_CONN_DEFAULTS', status);
      RETURN;
    IFEND;

    IF iiv$network_identifier = iic$dsiaf_network THEN
      IF NOT iiv$cdcnet_connection THEN

      { For those attributes which are ignored in dual state 255x connections,
      { replace their keys in term_conn_attributes with ifc$null_connection_attribute.

        FOR i := 1 TO UPPERBOUND (term_conn_attributes) DO
          CASE term_conn_attributes [i].key OF
          = ifc$trans_protocol_mode =
            term_conn_attributes [i].key := ifc$null_connection_attribute;


          ELSE
          { All other attributes will have their values returned.
          CASEND;

        FOREND;
      IFEND;
    IFEND;
    iip$get_term_conn_defaults (internal_file_name, term_conn_attributes, status);

    #KEYPOINT (osk$exit, 0, ifk$get_term_conn_defaults);

  PROCEND ifp$get_term_conn_defaults;

MODEND ifm$get_term_conn_defaults;
*DECK DECK=IFM$HANDLE_SIGNAL EXPAND=TRUE
*copyc osd$default_pragmats
MODULE ifm$handle_signal;

?? PUSH (LISTEXT := OFF) ??
*copyc ife$error_codes
*copyc ifk$keypoints
*copyc iit$interactive_signal_type
*copyc tmc$signal_identifiers
*copyc iit$connection_description

  PROCEDURE [XREF] iip$process_reconnect_request (gtid: ost$global_task_id);
*copyc iiv$interactive_terminated
*copyc ifc$interrupt
*copyc iip$begin_condition
*copyc iip$report_status_error
*copyc iip$send_output_message
*copyc iiv$int_task_open_file_count
*copyc iiv$connection_desc_ptr
*copyc jmv$terminal_io_disabled
*copyc jmv$user_breaks_enabled
*copyc ost$global_task_id
*copyc osp$set_status_abnormal
*copyc pmt$signal
*copyc pmp$dispose_interactive_cond
*copyc pmp$log
*copyc iip$disconnect_reconnect
*copyc pmp$exit
*copyc pmp$signal_all_child_tasks
?? POP ??

{
{   The purpose of this module is to define the signal handler for all
{ interactive signals.
{

  PROCEDURE [XDCL, #GATE] ifp$handle_signal (originator: ost$global_task_id;
        signal: pmt$signal);

    VAR
      lsig: pmt$signal,
      long_wait: boolean,
      psig: ^iit$interactive_signal,
      prs: ^iit$reconnect_job,
      prreq: ^iit$reconnect_request,
      i: integer,
      status: ost$status;


    psig := #LOC (signal.contents);
    CASE psig^ OF
    = iic$jm_send_data =
      iip$send_output_message (FALSE, status);
    = iic$pause_break =
      iip$begin_condition (ifc$pause_break, status);
      IF (NOT jmv$terminal_io_disabled) AND jmv$user_breaks_enabled THEN
        pmp$dispose_interactive_cond (ifc$pause_break);
      IFEND;
    = iic$terminate_break =
      iip$begin_condition (ifc$terminate_break, status);
      IF (NOT jmv$terminal_io_disabled) AND jmv$user_breaks_enabled THEN
        pmp$dispose_interactive_cond (ifc$terminate_break);
      IFEND;
    = iic$resume_task =
      lsig.identifier := ifc$signal_id;
      psig := #LOC (lsig.contents);
      psig^ := iic$resume_task;
      pmp$signal_all_child_tasks (signal, status);
    = iic$terminal_disconnect =
      iip$begin_condition (ifc$terminal_connection_broken, status);
      pmp$dispose_interactive_cond (ifc$terminal_connection_broken);
    = iic$terminal_reconnect =
      iip$begin_condition (ifc$job_reconnect, status);
      pmp$dispose_interactive_cond (ifc$job_reconnect);
    = iic$disconnect_request =
      iip$disconnect_job (iic$dont_end_connection, iic$start_new_job, status);
    = iic$reconnect_job =
      prs := #LOC (signal.contents);
      iip$reconnect_job (prs^.acn, prs^.reject_caused_reconnect);
    = iic$exec_says_disconnect =
      pmp$log ('IF: EXEC DISCONNECT', status);
      iip$disconnect_job (iic$dont_end_connection, iic$dont_start_new_job,
            status);
    = iic$jmtr_start_timeout =
      iip$timeout_suspended_job;
    = iic$reconnect_request =
      prreq := #LOC (signal.contents);
      iip$process_reconnect_request (prreq^.gtid);
    = iic$interrupt =
      pmp$dispose_interactive_cond (ifc$interrupt);
    ELSE
      status.condition := ORD (psig^);
      iip$report_status_error (status, 'invoke if signal handler');
    CASEND;

  PROCEND ifp$handle_signal;

MODEND ifm$handle_signal
*DECK DECK=IFM$IMMEDIATE_ATTRIBUTE_FLUSH EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Terminal Mgr. - Immediate Attribute Flush [2,3,D]' ??
MODULE ifm$immediate_attribute_flush;

{ PURPOSE:
{   This module contains the interface which causes immediate downloading
{   of queued attribute changes to the network.
{
{ DESIGN:
{   Doing an output with Term_Char_Null and Build_Msg_Block set to TRUE
{   puts a network block in the output queue which causes all attribute
{   changes (and the associated output data) queued by Terminal Manager
{   to be sent to the network (CDCNET or CCP).  The output buffer is then
{   flushed to immediately invoke the effects of the attribute values,
{   particularly the Input_Editing_Mode attribute and the transparent
{   mode attributes.
{
{   AMP$FLUSH for a terminal file causes the same results, except that
{   Term_Char_Null is not set to TRUE, causing the Input_Editing_Mode to
{   not be effected immediately.  AMP$GET_NEXT/PARTIAL will also accomplish
{   the same effect as this  interface with the added (and, maybe,
{   unwanted) effect of requesting input.
{
?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc bat$task_file_table
*copyc bav$last_tft_entry
*copyc bav$task_file_table
*copyc ife$error_codes
*copyc ifk$keypoints
*copyc iip$flush
*copyc iip$put
*copyc iip$st_flush
*copyc iip$st_put
*copyc iiv$interactive_terminated
*copyc iiv$int_task_open_file_count
*copyc osp$set_status_abnormal
?? POP ??

?? TITLE := '[XDCL, #GATE] ifp$immediate_attribute_flush' ??

*copyc ifh$immediate_attribute_flush

  PROCEDURE [XDCL, #GATE] ifp$immediate_attribute_flush
    (file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      file_identifier: amt$file_identifier,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      open_file_dsc_pointer: ^iit$open_file_description,
      st_open_file_dsc_pointer: ^iit$st_open_file_description,
      put_byte_address: amt$file_byte_address;


  /immediate_attribute_flush/
    BEGIN

{ Get the pointer to the open file description which was stored on the open.

      file_identifier := file_id;
*copy bai$validate_file_identifier
      IF iiv$network_identifier = iic$cdcnet_network THEN
*copy iii$fetch_st_open_file_desc_ptr
      ELSE
*copy iii$fetch_open_file_desc_ptr
      IFEND;
      IF NOT status.normal THEN
        EXIT /immediate_attribute_flush/;
      IFEND;

{ Perform an output with Term_Char_Null and Build_Msg_Block TRUE.

      iiv$put_info.build_msg_block := TRUE;
      iiv$put_info.term_char_null := TRUE;

      IF iiv$network_identifier = iic$cdcnet_network THEN
        iip$st_put (file_id, st_open_file_dsc_pointer, amc$put_partial_req,
              ^st_open_file_dsc_pointer^.attributes.prompt_string.value.value
              (1, 1), 0, ^put_byte_address, amc$terminate, status);
      ELSE
        iip$put (file_id, open_file_dsc_pointer, amc$put_partial_req,
              ^open_file_dsc_pointer^.attributes.prompt_string.value.value
              (1, 1), 0, ^put_byte_address, amc$terminate, status);
      IFEND;
      IF NOT status.normal THEN
        EXIT /immediate_attribute_flush/;
      IFEND;

{ Reset the Term_Char_Null and Build_Msg_Block flags.

      iiv$put_info.term_char_null := FALSE;
      iiv$put_info.build_msg_block := FALSE;

{ Flush the queued output data and its associated queued attribute changes.

      IF iiv$network_identifier = iic$cdcnet_network THEN
        iip$st_flush (file_id, st_open_file_dsc_pointer, status);
      ELSE
        iip$flush (file_id, open_file_dsc_pointer, status);
      IFEND;

    END /immediate_attribute_flush/;

  PROCEND ifp$immediate_attribute_flush;
MODEND ifm$immediate_attribute_flush;
*DECK DECK=IFM$INTERACTIVE_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Interactive Facility : Commands and Functions' ??
MODULE ifm$interactive_commands;

{
{ PURPOSE:
{   This module contains the processors of interactive facility commands and
{   functions.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc clt$data_value
*copyc clt$parameter_list
*copyc clt$work_area
*copyc fsc$local
*copyc fst$temporary_file_path
*copyc ife$error_codes
*copyc jmt$user_supplied_name
*copyc osc$timesharing
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc amp$flush
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_data_to_string
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_file
*copyc clp$evaluate_parameters
*copyc clp$get_fs_path_elements
*copyc clp$get_path_name
*copyc clp$get_system_file_id
*copyc clp$get_work_area
*copyc clp$horizontal_tab_display
*copyc clp$make_application_value
*copyc clp$make_boolean_value
*copyc clp$make_char_value
*copyc clp$make_file_value
*copyc clp$make_integer_value
*copyc clp$make_keyword_value
*copyc clp$make_list_value
*copyc clp$make_name_value
*copyc clp$make_range_value
*copyc clp$make_record_value
*copyc clp$make_sized_string_value
*copyc clp$make_string_value
*copyc clp$make_trimmed_string_value
*copyc clp$make_unspecified_value
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_data_representation
*copyc clp$put_display
*copyc clp$put_job_command_response
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$sort_record_fields
*copyc clp$trimmed_string_size
*copyc clv$nil_display_control
*copyc clv$standard_files
*copyc fsp$path_element
*copyc ifp$change_term_conn_attributes
*copyc ifp$change_term_conn_defaults
*copyc ifp$change_terminal_attributes
*copyc ifp$get_network_identifier
*copyc ifp$get_telnet_connection_limit
*copyc ifp$get_term_conn_attributes
*copyc ifp$get_term_conn_defaults
*copyc ifp$get_terminal_attributes
*copyc iip$vtp_create_cdcnet_connect
*copyc jmp$attach_timesharing_job
*copyc jmp$detach_timesharing_job
*copyc jmp$get_job_attributes
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc rmp$request_terminal
?? OLDTITLE, EJECT ??
  CONST
    max_host_parameter_length = 63;

  TYPE
    t$term_conn_type = (c$term_conn_attributes, c$term_conn_defaults);

  VAR
    attribute_undefined_message: [STATIC, READ, oss$job_paged_literal] string (28) :=
          'Undefined on current network';

?? TITLE := 'terminal_attribute_table', EJECT ??

{ This table is used to determine a terminal attribute's ordinal given its
{ keyword.  The entries in this table must be in alphabetical order by keyword.

  CONST
    max_terminal_attributes = 34;

  VAR
    terminal_attribute_table: [STATIC, READ, oss$job_paged_literal] array [1 .. max_terminal_attributes] of
          record
      name: clt$keyword,
      key: ift$terminal_attribute_keys,
    recend := [
          {} ['ATTENTION_CHARACTER            ', ifc$attention_character],
          {} ['BACKSPACE_CHARACTER            ', ifc$backspace_character],
          {} ['BEGIN_LINE_CHARACTER           ', ifc$begin_line_character],
          {} ['CANCEL_LINE_CHARACTER          ', ifc$cancel_line_character],
          {} ['CARRIAGE_RETURN_DELAY          ', ifc$carriage_return_delay],
          {} ['CARRIAGE_RETURN_SEQUENCE       ', ifc$carriage_return_sequence],
          {} ['CHARACTER_FLOW_CONTROL         ', ifc$character_flow_control],
          {} ['CODE_SET                       ', ifc$code_set],
          {} ['CONTROL_CODE_REPLACEMENT       ', ifc$control_code_replacement],
          {} ['ECHOPLEX                       ', ifc$echoplex],
          {} ['END_LINE_CHARACTER             ', ifc$end_line_character],
          {} ['END_LINE_POSITIONING           ', ifc$end_line_positioning],
          {} ['END_OUTPUT_SEQUENCE            ', ifc$end_output_sequence],
          {} ['END_PAGE_ACTION                ', ifc$end_page_action],
          {} ['END_PARTIAL_CHARACTER          ', ifc$end_partial_character],
          {} ['END_PARTIAL_POSITIONING        ', ifc$end_partial_positioning],
          {} ['FOLD_LINE                      ', ifc$fold_line],
          {} ['FORM_FEED_DELAY                ', ifc$form_feed_delay],
          {} ['FORM_FEED_SEQUENCE             ', ifc$form_feed_sequence],
          {} ['FUNCTION_KEY_CLASS             ', ifc$function_key_class],
          {} ['HOLD_PAGE                      ', ifc$hold_page],
          {} ['HOLD_PAGE_OVER                 ', ifc$hold_page_over],
          {} ['LINE_FEED_DELAY                ', ifc$line_feed_delay],
          {} ['LINE_FEED_SEQUENCE             ', ifc$line_feed_sequence],
          {} ['NETWORK_COMMAND_CHARACTER      ', ifc$network_command_character],
          {} ['PAGE_LENGTH                    ', ifc$page_length],
          {} ['PAGE_WIDTH                     ', ifc$page_width],
          {} ['PARITY                         ', ifc$parity],
          {} ['PAUSE_BREAK_CHARACTER          ', ifc$pause_break_character],
          {} ['STATUS_ACTION                  ', ifc$status_action],
          {} ['TERMINAL_CLASS                 ', ifc$terminal_class],
          {} ['TERMINAL_MODEL                 ', ifc$terminal_model],
          {} ['TERMINAL_NAME                  ', ifc$terminal_name],
          {} ['TERMINATE_BREAK_CHARACTER      ', ifc$terminate_break_character]];

?? TITLE := 'connection_attribute_table', EJECT ??

{ This table is used to determine a terminal connection attribute's ordinal
{ given its keyword.  The entries in this table must be in alphabetical order
{ by keyword.

  CONST
    max_connection_attributes = 21;

  VAR
    connection_attribute_table: [STATIC, READ, oss$job_paged_literal] array
          [1 .. max_connection_attributes] of record
      name: clt$keyword,
      key: ift$connection_attribute_keys,
    recend := [
          {} ['ATTENTION_CHARACTER_ACTION     ', ifc$attention_character_action],
          {} ['BREAK_KEY_ACTION               ', ifc$break_key_action],
          {} ['END_OF_INFORMATION             ', ifc$end_of_information],
          {} ['INPUT_BLOCK_SIZE               ', ifc$input_block_size],
          {} ['INPUT_EDITING_MODE             ', ifc$input_editing_mode],
          {} ['INPUT_OUTPUT_MODE              ', ifc$input_output_mode],
          {} ['INPUT_TIMEOUT                  ', ifc$input_timeout],
          {} ['INPUT_TIMEOUT_LENGTH           ', ifc$input_timeout_length],
          {} ['INPUT_TIMEOUT_PURGE            ', ifc$input_timeout_purge],
          {} ['PARTIAL_CHARACTER_FORWARDING   ', ifc$partial_char_forwarding],
          {} ['PROMPT_FILE                    ', ifc$prompt_file],
          {} ['PROMPT_STRING                  ', ifc$prompt_string],
          {} ['STORE_BACKSPACE_CHARACTER      ', ifc$store_backspace_character],
          {} ['STORE_NULS_DELS                ', ifc$store_nuls_dels],
          {} ['TRANSPARENT_CHARACTER_MODE     ', ifc$trans_character_mode],
          {} ['TRANSPARENT_FORWARD_CHARACTER  ', ifc$trans_forward_character],
          {} ['TRANSPARENT_LENGTH_MODE        ', ifc$trans_length_mode],
          {} ['TRANSPARENT_MESSAGE_LENGTH     ', ifc$trans_message_length],
          {} ['TRANSPARENT_PROTOCOL_MODE      ', ifc$trans_protocol_mode],
          {} ['TRANSPARENT_TERMINATE_CHARACTER', ifc$trans_terminate_character],
          {} ['TRANSPARENT_TIMEOUT_MODE       ', ifc$trans_timeout_mode]];

?? TITLE := 'change_term_conn', EJECT ??

  PROCEDURE change_term_conn
    (    pvt: ^array [1 .. * ] of clt$parameter_value;
         term_conn_type: t$term_conn_type;
     VAR status: ost$status);

    VAR
      attributes: ^ift$connection_attributes,
      attributes_area: ^SEQ ( * ),
      attribute_count: integer,
      attribute_limit: integer,
      count: clt$list_size,
      file: clt$file,
      i: integer,
      lfn: amt$local_file_name,
      node: ^clt$data_value;

    VAR
      p$terminal_file_name,
      p$attention_character_action,
      p$break_key_action,
      p$end_of_information,
      p$input_block_size,
      p$input_editing_mode,
      p$input_output_mode,
      p$input_timeout,
      p$input_timeout_length,
      p$input_timeout_purge,
      p$partial_character_forwarding,
      p$prompt_file,
      p$prompt_string,
      p$store_backspace_character,
      p$store_nuls_dels,
      p$transparent_character_mode,
      p$transparent_forward_character,
      p$transparent_length_mode,
      p$transparent_message_length,
      p$transparent_protocol_mode,
      p$transparent_terminate_charact {TRANSPARENT_TERMINATE_CHARACTER} ,
      p$transparent_timeout_mode,
      p$status: 1 .. 23;


    status.normal := TRUE;

    attribute_limit := $INTEGER (ifc$max_connection_key);
    PUSH attributes_area: [[REP attribute_limit OF ift$connection_attribute]];
    RESET attributes_area;
    NEXT attributes: [1 .. attribute_limit] IN attributes_area;
    attribute_count := 0;

    lfn := clv$standard_files [clc$sf_job_output_file].path_handle_name;
    IF term_conn_type = c$term_conn_defaults THEN
      p$attention_character_action := 1;
      p$break_key_action := 2;
      p$end_of_information := 3;
      p$input_block_size := 4;
      p$input_editing_mode := 5;
      p$input_output_mode := 6;
      p$input_timeout := 7;
      p$input_timeout_length := 8;
      p$input_timeout_purge := 9;
      p$partial_character_forwarding := 10;
      p$prompt_file := 11;
      p$prompt_string := 12;
      p$store_backspace_character := 13;
      p$store_nuls_dels := 14;
      p$transparent_character_mode := 15;
      p$transparent_forward_character := 16;
      p$transparent_length_mode := 17;
      p$transparent_message_length := 18;
      p$transparent_protocol_mode := 19;
      p$transparent_terminate_charact := 20 {TRANSPARENT_TERMINATE_CHARACTER} ;
      p$transparent_timeout_mode := 21;
      p$status := 22;
    ELSE {c$term_conn_attributes}
      p$terminal_file_name := 1;
      p$attention_character_action := 2;
      p$break_key_action := 3;
      p$end_of_information := 4;
      p$input_block_size := 5;
      p$input_editing_mode := 6;
      p$input_output_mode := 7;
      p$input_timeout := 8;
      p$input_timeout_length := 9;
      p$input_timeout_purge := 10;
      p$partial_character_forwarding := 11;
      p$prompt_file := 12;
      p$prompt_string := 13;
      p$store_backspace_character := 14;
      p$store_nuls_dels := 15;
      p$transparent_character_mode := 16;
      p$transparent_forward_character := 17;
      p$transparent_length_mode := 18;
      p$transparent_message_length := 19;
      p$transparent_protocol_mode := 20;
      p$transparent_terminate_charact := 21 {TRANSPARENT_TERMINATE_CHARACTER} ;
      p$transparent_timeout_mode := 22;
      p$status := 23;
      IF pvt^ [p$terminal_file_name].specified THEN
        clp$convert_string_to_file (pvt^ [p$terminal_file_name].value^.file_value^, file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        lfn := file.local_file_name;
      IFEND;
    IFEND;

    IF pvt^ [p$attention_character_action].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$attention_character_action;
      attributes^ [attribute_count].attention_character_action :=
            pvt^ [p$attention_character_action].value^.integer_value.value;
    IFEND;

    IF pvt^ [p$break_key_action].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$break_key_action;
      attributes^ [attribute_count].break_key_action := pvt^ [p$break_key_action].value^.integer_value.value;
    IFEND;

    IF pvt^ [p$end_of_information].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$end_of_information;
      attributes^ [attribute_count].end_of_information.size :=
            clp$trimmed_string_size (pvt^ [p$end_of_information].value^.string_value^);
      attributes^ [attribute_count].end_of_information.value :=
            pvt^ [p$end_of_information].value^.string_value^;
    IFEND;

    IF pvt^ [p$input_block_size].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$input_block_size;
      attributes^ [attribute_count].input_block_size := pvt^ [p$input_block_size].value^.integer_value.value;
    IFEND;

    IF pvt^ [p$input_editing_mode].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$input_editing_mode;
      IF pvt^ [p$input_editing_mode].value^.keyword_value = 'NORMAL' THEN
        attributes^ [attribute_count].input_editing_mode := ifc$normal_edit;
      ELSEIF pvt^ [p$input_editing_mode].value^.keyword_value = 'TRANSPARENT' THEN
        attributes^ [attribute_count].input_editing_mode := ifc$trans_edit;
      IFEND;
    IFEND;

    IF pvt^ [p$input_output_mode].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$input_output_mode;
      IF pvt^ [p$input_output_mode].value^.keyword_value = 'UNSOLICITED' THEN
        attributes^ [attribute_count].input_output_mode := ifc$unsolicited_output;
      ELSEIF pvt^ [p$input_output_mode].value^.keyword_value = 'SOLICITED' THEN
        attributes^ [attribute_count].input_output_mode := ifc$solicited;
      ELSEIF pvt^ [p$input_output_mode].value^.keyword_value = 'FULL_DUPLEX' THEN
        attributes^ [attribute_count].input_output_mode := ifc$full_duplex;
      IFEND;
    IFEND;

    IF pvt^ [p$input_timeout].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$input_timeout;
      attributes^ [attribute_count].input_timeout := pvt^ [p$input_timeout].value^.boolean_value.value;
    IFEND;

    IF pvt^ [p$input_timeout_length].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$input_timeout_length;
      attributes^ [attribute_count].input_timeout_length := pvt^ [p$input_timeout_length].value^.
            integer_value.value;
    IFEND;

    IF pvt^ [p$input_timeout_purge].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$input_timeout_purge;
      attributes^ [attribute_count].input_timeout_purge :=
            pvt^ [p$input_timeout_purge].value^.boolean_value.value;
    IFEND;

    IF pvt^ [p$partial_character_forwarding].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$partial_char_forwarding;
      attributes^ [attribute_count].partial_character_forwarding :=
            pvt^ [p$partial_character_forwarding].value^.boolean_value.value;
    IFEND;

    IF pvt^ [p$prompt_file].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$prompt_file;
      clp$convert_string_to_file (pvt^ [p$prompt_file].value^.file_value^, file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      attributes^ [attribute_count].prompt_file := file.local_file_name;
    IFEND;

    IF pvt^ [p$prompt_string].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$prompt_string;
      attributes^ [attribute_count].prompt_string.size := STRLENGTH (pvt^ [p$prompt_string].value^.
            string_value^);
      attributes^ [attribute_count].prompt_string.value := pvt^ [p$prompt_string].value^.string_value^;
    IFEND;

    IF pvt^ [p$store_backspace_character].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$store_backspace_character;
      attributes^ [attribute_count].store_backspace_character :=
            pvt^ [p$store_backspace_character].value^.boolean_value.value;
    IFEND;

    IF pvt^ [p$store_nuls_dels].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$store_nuls_dels;
      attributes^ [attribute_count].store_nuls_dels := pvt^ [p$store_nuls_dels].value^.boolean_value.value;
    IFEND;

    IF pvt^ [p$transparent_character_mode].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$trans_character_mode;
      IF pvt^ [p$transparent_character_mode].value^.keyword_value = 'NONE' THEN
        attributes^ [attribute_count].trans_character_mode := ifc$no_trans_char;
      ELSEIF pvt^ [p$transparent_character_mode].value^.keyword_value = 'TERMINATE' THEN
        attributes^ [attribute_count].trans_character_mode := ifc$trans_char_terminate;
      ELSEIF pvt^ [p$transparent_character_mode].value^.keyword_value = 'FORWARD' THEN
        attributes^ [attribute_count].trans_character_mode := ifc$trans_char_forward;
      ELSEIF pvt^ [p$transparent_character_mode].value^.keyword_value = 'FORWARD_TERMINATE' THEN
        attributes^ [attribute_count].trans_character_mode := ifc$trans_char_fwd_terminate;
      IFEND;
    IFEND;

    IF pvt^ [p$transparent_forward_character].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$trans_forward_character;
      node := pvt^ [p$transparent_forward_character].value;
      i := 0;
      WHILE node <> NIL DO
        i := i + 1;
        attributes^ [attribute_count].trans_forward_character.value (i, 1) :=
              node^.element_value^.string_value^ (1, 1);
        node := node^.link;
      WHILEND;
      attributes^ [attribute_count].trans_forward_character.size := i;
    IFEND;

    IF pvt^ [p$transparent_length_mode].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$trans_length_mode;
      IF pvt^ [p$transparent_length_mode].value^.keyword_value = 'NONE' THEN
        attributes^ [attribute_count].trans_length_mode := ifc$no_trans_len;
      ELSEIF pvt^ [p$transparent_length_mode].value^.keyword_value = 'TERMINATE' THEN
        attributes^ [attribute_count].trans_length_mode := ifc$trans_len_terminate;
      ELSEIF pvt^ [p$transparent_length_mode].value^.keyword_value = 'FORWARD' THEN
        attributes^ [attribute_count].trans_length_mode := ifc$trans_len_forward;
      ELSEIF pvt^ [p$transparent_length_mode].value^.keyword_value = 'FORWARD_EXACT' THEN
        attributes^ [attribute_count].trans_length_mode := ifc$trans_len_forward_exact;
      IFEND;
    IFEND;

    IF pvt^ [p$transparent_message_length].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$trans_message_length;
      attributes^ [attribute_count].trans_message_length :=
            pvt^ [p$transparent_message_length].value^.integer_value.value;
    IFEND;

    IF pvt^ [p$transparent_terminate_charact].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$trans_terminate_character;
      node := pvt^ [p$transparent_terminate_charact].value;
      i := 0;
      WHILE node <> NIL DO
        i := i + 1;
        attributes^ [attribute_count].trans_terminate_character.value (i, 1) :=
              node^.element_value^.string_value^ (1, 1);
        node := node^.link;
      WHILEND;
      attributes^ [attribute_count].trans_terminate_character.size := i;
    IFEND;

    IF pvt^ [p$transparent_timeout_mode].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$trans_timeout_mode;
      IF pvt^ [p$transparent_timeout_mode].value^.keyword_value = 'NONE' THEN
        attributes^ [attribute_count].trans_timeout_mode := ifc$no_trans_timeout;
      ELSEIF pvt^ [p$transparent_timeout_mode].value^.keyword_value = 'TERMINATE' THEN
        attributes^ [attribute_count].trans_timeout_mode := ifc$trans_timeout_terminate;
      ELSEIF pvt^ [p$transparent_timeout_mode].value^.keyword_value = 'FORWARD' THEN
        attributes^ [attribute_count].trans_timeout_mode := ifc$trans_timeout_forward;
      IFEND;
    IFEND;

    IF pvt^ [p$transparent_protocol_mode].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$trans_protocol_mode;
      IF pvt^ [p$transparent_protocol_mode].value^.keyword_value = 'NONE' THEN
        attributes^ [attribute_count].trans_protocol_mode := ifc$no_trans_protocol;
      ELSEIF pvt^ [p$transparent_protocol_mode].value^.keyword_value = 'TERMINATE' THEN
        attributes^ [attribute_count].trans_protocol_mode := ifc$trans_protocol_terminate;
      ELSEIF pvt^ [p$transparent_protocol_mode].value^.keyword_value = 'FORWARD' THEN
        attributes^ [attribute_count].trans_protocol_mode := ifc$trans_protocol_forward;
      IFEND;
    IFEND;

    IF attribute_count = 0 THEN
      RETURN;
    IFEND;

    RESET attributes_area;
    NEXT attributes: [1 .. attribute_count] IN attributes_area;
    IF term_conn_type = c$term_conn_attributes THEN
      ifp$change_term_conn_attributes (lfn, attributes^, status);
    ELSE {change_default}
      ifp$change_term_conn_defaults (lfn, attributes^, status);
    IFEND;

  PROCEND change_term_conn;
?? TITLE := 'display_attributes', EJECT ??

  PROCEDURE display_attributes
    (    display_name: ost$name_reference;
         subtitle_file: ^fst$file_reference;
         attributes_value: ^clt$data_value;
         output_file: fst$file_reference;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

*copy clv$display_variables

    VAR
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      ignore_status: ^ost$status,
      representation: ^clt$data_representation;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;


      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;
*copy clp$new_page_procedure
*copy clp$put_path_reference_subtitle
?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);


      IF subtitle_file = NIL THEN
        clp$put_display (display_control, 'TERMINAL', clc$trim, status);
      ELSE
        clp$put_path_reference_subtitle (subtitle_file^, 'FILE ', status);
      IFEND;

    PROCEND put_subtitle;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    osp$establish_block_exit_hndlr (^abort_handler);

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
    clp$open_display_reference (output_file, ^clp$new_page_procedure, fsc$list, default_ring_attributes,
          display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN
    IFEND;
    clv$titles_built := FALSE;
    clv$subtitles_built := FALSE;
    clv$command_name := display_name;

    IF display_control.page_width < clc$narrow_page_width THEN
      clv$page_width := clc$narrow_page_width;
    ELSEIF display_control.page_width > clc$wide_page_width THEN
      clv$page_width := clc$wide_page_width;
    ELSE
      clv$page_width := display_control.page_width;
    IFEND;

    clp$convert_data_to_string (attributes_value, clc$labeled_elem_representation, display_control.page_width,
          work_area, representation, status);
    IF status.normal THEN
      clp$put_data_representation (display_control, representation, status);
    IFEND;

    IF status.normal THEN
      clp$close_display (display_control, status);
    ELSE
      PUSH ignore_status;
      clp$close_display (display_control, ignore_status^);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND display_attributes;
?? TITLE := 'get_connection_attribute_key', EJECT ??

  PROCEDURE get_connection_attribute_key
    (    name: clt$keyword;
     VAR key: ift$connection_attribute_keys);

    VAR
      temp: integer,
      low_index: 1 .. max_connection_attributes + 1,
      high_index: 0 .. max_connection_attributes,
      current_index: 1 .. max_connection_attributes;


    low_index := 1;
    high_index := max_connection_attributes;

    REPEAT
      temp := low_index + high_index;
      current_index := temp DIV 2;
      IF name = connection_attribute_table [current_index].name THEN

        key := connection_attribute_table [current_index].key;
        RETURN;

      ELSEIF name > connection_attribute_table [current_index].name THEN
        low_index := current_index + 1;
      ELSE
        high_index := current_index - 1;
      IFEND;
    UNTIL low_index > high_index;

    key := UPPERVALUE (key);

  PROCEND get_connection_attribute_key;
?? TITLE := 'get_terminal_attribute_key', EJECT ??

  PROCEDURE get_terminal_attribute_key
    (    name: clt$keyword;
     VAR key: ift$terminal_attribute_keys);

    VAR
      temp: integer,
      low_index: 1 .. max_terminal_attributes + 1,
      high_index: 0 .. max_terminal_attributes,
      current_index: 1 .. max_terminal_attributes;


    low_index := 1;
    high_index := max_terminal_attributes;

    REPEAT
      temp := low_index + high_index;
      current_index := temp DIV 2;
      IF name = terminal_attribute_table [current_index].name THEN

        key := terminal_attribute_table [current_index].key;
        RETURN;

      ELSEIF name > terminal_attribute_table [current_index].name THEN
        low_index := current_index + 1;
      ELSE
        high_index := current_index - 1;
      IFEND;
    UNTIL low_index > high_index;

    key := UPPERVALUE (key);

  PROCEND get_terminal_attribute_key;
?? TITLE := 'ifp$$connection_attributes', EJECT ??

  PROCEDURE [XDCL] ifp$$connection_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$$cona) $connection_attributes (
{   terminal_file_name: file = $required
{   attributes: any of
{       key
{         all
{       keyend
{       list of key
{         (attention_character_action, aca)
{         (break_key_action, bka)
{         (end_of_information, eoi)
{         (input_block_size, ibs)
{         (input_editing_mode, iem)
{         (input_output_mode, iom)
{         (input_timeout, it)
{         (input_timeout_length, itl)
{         (input_timeout_purge, itp)
{         (partial_character_forwarding, pcf)
{         (prompt_file, pf)
{         (prompt_string, ps)
{         (store_backspace_character, sbc)
{         (store_nuls_dels, snd)
{         (transparent_character_mode, tcm)
{         (transparent_forward_character, tfc)
{         (transparent_length_mode, tlm)
{         (transparent_message_length, tml)
{         (transparent_protocol_mode, tpm)
{         (transparent_terminate_character, ttc)
{         (transparent_timeout_mode, ttm)
{       keyend
{     anyend = all
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: 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 .. 42] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
    recend := [
    [1,
    [90, 3, 2, 11, 59, 35, 422],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$TERCA'], [
    ['ATTRIBUTES                     ',clc$nominal_entry, 2],
    ['TERMINAL_FILE_NAME             ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [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, 1641,
  clc$optional_default_parameter, 0, 3]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[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]]
      ],
    1577, [[1, 0, clc$list_type], [1561, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [42], [
        ['ACA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['ATTENTION_CHARACTER_ACTION     ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['BKA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['BREAK_KEY_ACTION               ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['END_OF_INFORMATION             ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['EOI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['IBS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['IEM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['INPUT_BLOCK_SIZE               ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['INPUT_EDITING_MODE             ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['INPUT_OUTPUT_MODE              ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['INPUT_TIMEOUT                  ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['INPUT_TIMEOUT_LENGTH           ', clc$nominal_entry, clc$normal_usage_entry, 8],
        ['INPUT_TIMEOUT_PURGE            ', clc$nominal_entry, clc$normal_usage_entry, 9],
        ['IOM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['IT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
        ['ITL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
        ['ITP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
        ['PARTIAL_CHARACTER_FORWARDING   ', clc$nominal_entry, clc$normal_usage_entry, 10],
        ['PCF                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
        ['PF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
        ['PROMPT_FILE                    ', clc$nominal_entry, clc$normal_usage_entry, 11],
        ['PROMPT_STRING                  ', clc$nominal_entry, clc$normal_usage_entry, 12],
        ['PS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
        ['SBC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
        ['SND                            ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
        ['STORE_BACKSPACE_CHARACTER      ', clc$nominal_entry, clc$normal_usage_entry, 13],
        ['STORE_NULS_DELS                ', clc$nominal_entry, clc$normal_usage_entry, 14],
        ['TCM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
        ['TFC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
        ['TLM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
        ['TML                            ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
        ['TPM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
        ['TRANSPARENT_CHARACTER_MODE     ', clc$nominal_entry, clc$normal_usage_entry, 15],
        ['TRANSPARENT_FORWARD_CHARACTER  ', clc$nominal_entry, clc$normal_usage_entry, 16],
        ['TRANSPARENT_LENGTH_MODE        ', clc$nominal_entry, clc$normal_usage_entry, 17],
        ['TRANSPARENT_MESSAGE_LENGTH     ', clc$nominal_entry, clc$normal_usage_entry, 18],
        ['TRANSPARENT_PROTOCOL_MODE      ', clc$nominal_entry, clc$normal_usage_entry, 19],
        ['TRANSPARENT_TERMINATE_CHARACTER', clc$nominal_entry, clc$normal_usage_entry, 20],
        ['TRANSPARENT_TIMEOUT_MODE       ', clc$nominal_entry, clc$normal_usage_entry, 21],
        ['TTC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 20],
        ['TTM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 21]]
        ]
      ]
    ,
    'all']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$terminal_file_name = 1,
      p$attributes = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    make_term_conn_attr_record (FALSE, pvt [p$terminal_file_name].value^.file_value, pvt [p$attributes],
          work_area, result, status);

  PROCEND ifp$$connection_attributes;
?? TITLE := 'ifp$$term_conn_defaults', EJECT ??

  PROCEDURE [XDCL] ifp$$term_conn_defaults
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$tercd) $term_conn_defaults (
{   attributes: any of
{       key
{         all
{       keyend
{       list of key
{         (attention_character_action, aca)
{         (break_key_action, bka)
{         (end_of_information, eoi)
{         (input_block_size, ibs)
{         (input_editing_mode, iem)
{         (input_output_mode, iom)
{         (input_timeout, it)
{         (input_timeout_length, itl)
{         (input_timeout_purge, itp)
{         (partial_character_forwarding, pcf)
{         (prompt_file, pf)
{         (prompt_string, ps)
{         (store_backspace_character, sbc)
{         (store_nuls_dels, snd)
{         (transparent_character_mode, tcm)
{         (transparent_forward_character, tfc)
{         (transparent_length_mode, tlm)
{         (transparent_message_length, tml)
{         (transparent_protocol_mode, tpm)
{         (transparent_terminate_character, ttc)
{         (transparent_timeout_mode, ttm)
{       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 .. 42] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
    recend := [
    [1,
    [90, 3, 2, 12, 2, 40, 387],
    clc$function, 1, 1, 0, 0, 0, 0, 0, 'OSM$$TERCD'], [
    ['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, 1641,
  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]]
      ],
    1577, [[1, 0, clc$list_type], [1561, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [42], [
        ['ACA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['ATTENTION_CHARACTER_ACTION     ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['BKA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['BREAK_KEY_ACTION               ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['END_OF_INFORMATION             ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['EOI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['IBS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['IEM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['INPUT_BLOCK_SIZE               ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['INPUT_EDITING_MODE             ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['INPUT_OUTPUT_MODE              ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['INPUT_TIMEOUT                  ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['INPUT_TIMEOUT_LENGTH           ', clc$nominal_entry, clc$normal_usage_entry, 8],
        ['INPUT_TIMEOUT_PURGE            ', clc$nominal_entry, clc$normal_usage_entry, 9],
        ['IOM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['IT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
        ['ITL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
        ['ITP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
        ['PARTIAL_CHARACTER_FORWARDING   ', clc$nominal_entry, clc$normal_usage_entry, 10],
        ['PCF                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
        ['PF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
        ['PROMPT_FILE                    ', clc$nominal_entry, clc$normal_usage_entry, 11],
        ['PROMPT_STRING                  ', clc$nominal_entry, clc$normal_usage_entry, 12],
        ['PS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
        ['SBC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
        ['SND                            ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
        ['STORE_BACKSPACE_CHARACTER      ', clc$nominal_entry, clc$normal_usage_entry, 13],
        ['STORE_NULS_DELS                ', clc$nominal_entry, clc$normal_usage_entry, 14],
        ['TCM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
        ['TFC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
        ['TLM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
        ['TML                            ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
        ['TPM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
        ['TRANSPARENT_CHARACTER_MODE     ', clc$nominal_entry, clc$normal_usage_entry, 15],
        ['TRANSPARENT_FORWARD_CHARACTER  ', clc$nominal_entry, clc$normal_usage_entry, 16],
        ['TRANSPARENT_LENGTH_MODE        ', clc$nominal_entry, clc$normal_usage_entry, 17],
        ['TRANSPARENT_MESSAGE_LENGTH     ', clc$nominal_entry, clc$normal_usage_entry, 18],
        ['TRANSPARENT_PROTOCOL_MODE      ', clc$nominal_entry, clc$normal_usage_entry, 19],
        ['TRANSPARENT_TERMINATE_CHARACTER', clc$nominal_entry, clc$normal_usage_entry, 20],
        ['TRANSPARENT_TIMEOUT_MODE       ', clc$nominal_entry, clc$normal_usage_entry, 21],
        ['TTC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 20],
        ['TTM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 21]]
        ]
      ]
    ,
    'all']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$attributes = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    make_term_conn_attr_record (FALSE, NIL, pvt [p$attributes], work_area, result, status);

  PROCEND ifp$$term_conn_defaults;
?? TITLE := 'ifp$$terminal_attributes', EJECT ??

  PROCEDURE [XDCL] ifp$$terminal_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$$tera) $terminal_attributes (
{   attributes: any of
{       key
{         all
{       keyend
{       list of key
{         (attention_character, ac)
{         (backspace_character, bc)
{         (begin_line_character, blc)
{         (cancel_line_character, clc)
{         (carriage_return_delay, crd)
{         (carriage_return_sequence, crs)
{         (character_flow_control, cfc)
{         (code_set, cs)
{         (connect_view, cv)
{         (control_code_replacement, ccr)
{         (echoplex, e)
{         (end_line_character, elc)
{         (end_line_positioning, elp)
{         (end_output_sequence, eos)
{         (end_page_action, epa)
{         (end_partial_character, epc)
{         (end_partial_positioning, epp)
{         (fold_line, fl)
{         (form_feed_delay, ffd)
{         (form_feed_sequence, ffs)
{         (function_key_class, fkc)
{         (hold_page, hp)
{         (hold_page_over, hpo)
{         (line_feed_delay, lfd)
{         (line_feed_sequence, lfs)
{         (network, n)
{         (network_command_character, ncc)
{         (page_length, pl)
{         (page_width, pw)
{         (parity, p)
{         (pause_break_character, pbc)
{         (status_action, sa)
{         (terminal_class, tc)
{         (terminal_model, trm, tm)
{         (terminal_name, tn)
{         (terminate_break_character, tbc)
{       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 .. 73] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
    recend := [
    [1,
    [90, 10, 26, 14, 21, 16, 459],
    clc$function, 1, 1, 0, 0, 0, 0, 0, 'OSM$$TERA'], [
    ['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, 2788,
  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]]
      ],
    2724, [[1, 0, clc$list_type], [2708, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [73], [
        ['AC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['ATTENTION_CHARACTER            ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['BACKSPACE_CHARACTER            ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['BC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['BEGIN_LINE_CHARACTER           ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['BLC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['CANCEL_LINE_CHARACTER          ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['CARRIAGE_RETURN_DELAY          ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['CARRIAGE_RETURN_SEQUENCE       ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['CCR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
        ['CFC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
        ['CHARACTER_FLOW_CONTROL         ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['CLC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['CODE_SET                       ', clc$nominal_entry, clc$normal_usage_entry, 8],
        ['CONNECT_VIEW                   ', clc$nominal_entry, clc$normal_usage_entry, 9],
        ['CONTROL_CODE_REPLACEMENT       ', clc$nominal_entry, clc$normal_usage_entry, 10],
        ['CRD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['CRS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['CS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
        ['CV                             ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
        ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
        ['ECHOPLEX                       ', clc$nominal_entry, clc$normal_usage_entry, 11],
        ['ELC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
        ['ELP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
        ['END_LINE_CHARACTER             ', clc$nominal_entry, clc$normal_usage_entry, 12],
        ['END_LINE_POSITIONING           ', clc$nominal_entry, clc$normal_usage_entry, 13],
        ['END_OUTPUT_SEQUENCE            ', clc$nominal_entry, clc$normal_usage_entry, 14],
        ['END_PAGE_ACTION                ', clc$nominal_entry, clc$normal_usage_entry, 15],
        ['END_PARTIAL_CHARACTER          ', clc$nominal_entry, clc$normal_usage_entry, 16],
        ['END_PARTIAL_POSITIONING        ', clc$nominal_entry, clc$normal_usage_entry, 17],
        ['EOS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
        ['EPA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
        ['EPC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
        ['EPP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
        ['FFD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
        ['FFS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 20],
        ['FKC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 21],
        ['FL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
        ['FOLD_LINE                      ', clc$nominal_entry, clc$normal_usage_entry, 18],
        ['FORM_FEED_DELAY                ', clc$nominal_entry, clc$normal_usage_entry, 19],
        ['FORM_FEED_SEQUENCE             ', clc$nominal_entry, clc$normal_usage_entry, 20],
        ['FUNCTION_KEY_CLASS             ', clc$nominal_entry, clc$normal_usage_entry, 21],
        ['HOLD_PAGE                      ', clc$nominal_entry, clc$normal_usage_entry, 22],
        ['HOLD_PAGE_OVER                 ', clc$nominal_entry, clc$normal_usage_entry, 23],
        ['HP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 22],
        ['HPO                            ', clc$abbreviation_entry, clc$normal_usage_entry, 23],
        ['LFD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 24],
        ['LFS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 25],
        ['LINE_FEED_DELAY                ', clc$nominal_entry, clc$normal_usage_entry, 24],
        ['LINE_FEED_SEQUENCE             ', clc$nominal_entry, clc$normal_usage_entry, 25],
        ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 26],
        ['NCC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 27],
        ['NETWORK                        ', clc$nominal_entry, clc$normal_usage_entry, 26],
        ['NETWORK_COMMAND_CHARACTER      ', clc$nominal_entry, clc$normal_usage_entry, 27],
        ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 30],
        ['PAGE_LENGTH                    ', clc$nominal_entry, clc$normal_usage_entry, 28],
        ['PAGE_WIDTH                     ', clc$nominal_entry, clc$normal_usage_entry, 29],
        ['PARITY                         ', clc$nominal_entry, clc$normal_usage_entry, 30],
        ['PAUSE_BREAK_CHARACTER          ', clc$nominal_entry, clc$normal_usage_entry, 31],
        ['PBC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 31],
        ['PL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 28],
        ['PW                             ', clc$abbreviation_entry, clc$normal_usage_entry, 29],
        ['SA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 32],
        ['STATUS_ACTION                  ', clc$nominal_entry, clc$normal_usage_entry, 32],
        ['TBC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 36],
        ['TC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 33],
        ['TERMINAL_CLASS                 ', clc$nominal_entry, clc$normal_usage_entry, 33],
        ['TERMINAL_MODEL                 ', clc$nominal_entry, clc$normal_usage_entry, 34],
        ['TERMINAL_NAME                  ', clc$nominal_entry, clc$normal_usage_entry, 35],
        ['TERMINATE_BREAK_CHARACTER      ', clc$nominal_entry, clc$normal_usage_entry, 36],
        ['TM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 34],
        ['TN                             ', clc$abbreviation_entry, clc$normal_usage_entry, 35],
        ['TRM                            ', clc$alias_entry, clc$normal_usage_entry, 34]]
        ]
      ]
    ,
    'all']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$attributes = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    make_term_attr_record (FALSE, pvt [p$attributes], work_area, result, status);

  PROCEND ifp$$terminal_attributes;
?? TITLE := 'ifp$$terminal_model', EJECT ??

  PROCEDURE [XDCL] ifp$$terminal_model
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$terminal_model) $terminal_model (
{   terminal_file_name: file = $local.command
{   )

?? 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,
        default_value: string (14),
      recend,
    recend := [
    [1,
    [90, 3, 1, 17, 33, 35, 6],
    clc$function, 1, 1, 0, 0, 0, 0, 0, 'OSM$$TERMINAL_MODEL'], [
    ['TERMINAL_FILE_NAME             ',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, 3,
  clc$optional_default_parameter, 0, 14]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$local.command']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$terminal_file_name = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      attribute: array [1 .. 1] of ift$terminal_attribute;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    attribute [1].key := ifc$terminal_model;
    ifp$get_terminal_attributes (pvt [p$terminal_file_name].value^.file_value^, attribute, status);
    IF status.normal THEN
      clp$make_string_value (attribute [1].terminal_model.value (1, attribute [1].terminal_model.size),
            work_area, result);
    ELSE
      status.normal := TRUE;
      clp$make_sized_string_value (0, work_area, result);
    IFEND;

  PROCEND ifp$$terminal_model;
?? TITLE := 'ifp$_attach_job', EJECT ??

  PROCEDURE [XDCL] ifp$_attach_job
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$attj) attach_job, attj (
{   job_name, jn: name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 3, 1, 17, 47, 5, 817],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ATTJ'], [
    ['JN                             ',clc$abbreviation_entry, 1],
    ['JOB_NAME                       ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$job_name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      job_name: jmt$user_supplied_name;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$job_name].specified THEN
      job_name := pvt [p$job_name].value^.name_value;
    ELSE
      job_name := osc$null_name;
    IFEND;

    jmp$attach_timesharing_job (job_name, status);

  PROCEND ifp$_attach_job;
?? TITLE := 'ifp$_change_connection_attribut', EJECT ??

  PROCEDURE [XDCL] ifp$_change_connection_attribut
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$chatca) change_connection_attributes, change_connection_attribute, ..
{ change_term_conn_attributes, change_term_conn_attribute, chatca, chaca (
{   terminal_file_name, tfn: file = $required
{   attention_character_action, aca: (BY_NAME) integer 0..9 = $optional
{   break_key_action, bka: (BY_NAME) integer 0..9 = $optional
{   end_of_information, eoi: (BY_NAME) string 0..31 = $optional
{   input_block_size, ibs: (BY_NAME) integer 80..2000 = $optional
{   input_editing_mode, iem: (BY_NAME) key
{       (normal, n)
{       (transparent, t)
{     keyend = $optional
{   input_output_mode, iom: (BY_NAME) key
{       (unsolicited, u)
{       (solicited, s)
{       (full_duplex, fullduplex, f)
{     keyend = $optional
{   input_timeout, it: (BY_NAME) boolean = $optional
{   input_timeout_length, itl: (BY_NAME) integer 0..1048575 = $optional
{   input_timeout_purge, itp: (BY_NAME) boolean = $optional
{   partial_character_forwarding, pcf: (BY_NAME) boolean = $optional
{   prompt_file, pf: (BY_NAME) file = $optional
{   prompt_string, ps: (BY_NAME) string 0..31 = $optional
{   store_backspace_character, sbc: (BY_NAME) boolean = $optional
{   store_nuls_dels, snd: (BY_NAME) boolean = $optional
{   transparent_character_mode, tcm: (BY_NAME) key
{       (none, n)
{       (terminate, t)
{       (forward, f)
{       (forward_terminate, ft)
{     keyend = $optional
{   transparent_forward_character, tfc: (BY_NAME) list 1..4 of string 1 = $optional
{   transparent_length_mode, tlm: (BY_NAME) key
{       (none, n)
{       (terminate, t)
{       (forward, f)
{       (forward_exact, fe)
{     keyend = $optional
{   transparent_message_length, tml: (BY_NAME) integer 1..32767 = $optional
{   transparent_protocol_mode, tpm: (BY_NAME) key
{       (none, n)
{       (terminate, t)
{       (forward, f)
{     keyend = $optional
{   transparent_terminate_character, ttc: (BY_NAME) list 1..4 of string 1 = $optional
{   transparent_timeout_mode, ttm: (BY_NAME) key
{       (none, n)
{       (terminate, t)
{       (forward, f)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 45] of clt$pdt_parameter_name,
      parameters: array [1 .. 23] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 7] of clt$keyword_specification,
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
      type11: record
        header: clt$type_specification_header,
      recend,
      type12: record
        header: clt$type_specification_header,
      recend,
      type13: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type14: record
        header: clt$type_specification_header,
      recend,
      type15: record
        header: clt$type_specification_header,
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
      recend,
      type17: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type18: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
      recend,
      type19: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type20: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type21: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type22: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type23: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 3, 2, 17, 40, 49, 122],
    clc$command, 45, 23, 1, 0, 0, 0, 23, 'OSM$CHATCA'], [
    ['ACA                            ',clc$abbreviation_entry, 2],
    ['ATTENTION_CHARACTER_ACTION     ',clc$nominal_entry, 2],
    ['BKA                            ',clc$abbreviation_entry, 3],
    ['BREAK_KEY_ACTION               ',clc$nominal_entry, 3],
    ['END_OF_INFORMATION             ',clc$nominal_entry, 4],
    ['EOI                            ',clc$abbreviation_entry, 4],
    ['IBS                            ',clc$abbreviation_entry, 5],
    ['IEM                            ',clc$abbreviation_entry, 6],
    ['INPUT_BLOCK_SIZE               ',clc$nominal_entry, 5],
    ['INPUT_EDITING_MODE             ',clc$nominal_entry, 6],
    ['INPUT_OUTPUT_MODE              ',clc$nominal_entry, 7],
    ['INPUT_TIMEOUT                  ',clc$nominal_entry, 8],
    ['INPUT_TIMEOUT_LENGTH           ',clc$nominal_entry, 9],
    ['INPUT_TIMEOUT_PURGE            ',clc$nominal_entry, 10],
    ['IOM                            ',clc$abbreviation_entry, 7],
    ['IT                             ',clc$abbreviation_entry, 8],
    ['ITL                            ',clc$abbreviation_entry, 9],
    ['ITP                            ',clc$abbreviation_entry, 10],
    ['PARTIAL_CHARACTER_FORWARDING   ',clc$nominal_entry, 11],
    ['PCF                            ',clc$abbreviation_entry, 11],
    ['PF                             ',clc$abbreviation_entry, 12],
    ['PROMPT_FILE                    ',clc$nominal_entry, 12],
    ['PROMPT_STRING                  ',clc$nominal_entry, 13],
    ['PS                             ',clc$abbreviation_entry, 13],
    ['SBC                            ',clc$abbreviation_entry, 14],
    ['SND                            ',clc$abbreviation_entry, 15],
    ['STATUS                         ',clc$nominal_entry, 23],
    ['STORE_BACKSPACE_CHARACTER      ',clc$nominal_entry, 14],
    ['STORE_NULS_DELS                ',clc$nominal_entry, 15],
    ['TCM                            ',clc$abbreviation_entry, 16],
    ['TERMINAL_FILE_NAME             ',clc$nominal_entry, 1],
    ['TFC                            ',clc$abbreviation_entry, 17],
    ['TFN                            ',clc$abbreviation_entry, 1],
    ['TLM                            ',clc$abbreviation_entry, 18],
    ['TML                            ',clc$abbreviation_entry, 19],
    ['TPM                            ',clc$abbreviation_entry, 20],
    ['TRANSPARENT_CHARACTER_MODE     ',clc$nominal_entry, 16],
    ['TRANSPARENT_FORWARD_CHARACTER  ',clc$nominal_entry, 17],
    ['TRANSPARENT_LENGTH_MODE        ',clc$nominal_entry, 18],
    ['TRANSPARENT_MESSAGE_LENGTH     ',clc$nominal_entry, 19],
    ['TRANSPARENT_PROTOCOL_MODE      ',clc$nominal_entry, 20],
    ['TRANSPARENT_TERMINATE_CHARACTER',clc$nominal_entry, 21],
    ['TRANSPARENT_TIMEOUT_MODE       ',clc$nominal_entry, 22],
    ['TTC                            ',clc$abbreviation_entry, 21],
    ['TTM                            ',clc$abbreviation_entry, 22]],
    [
{ PARAMETER 1
    [31, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 266,
  clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 9
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 10
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 11
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 12
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 13
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 14
    [28, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 15
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 16
    [37, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [38, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 24, clc$optional_parameter,
  0, 0],
{ PARAMETER 18
    [39, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_parameter, 0, 0],
{ PARAMETER 19
    [40, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 20
    [41, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 21
    [42, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 24, clc$optional_parameter,
  0, 0],
{ PARAMETER 22
    [43, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 23
    [27, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, 9, 10]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, 9, 10]],
{ PARAMETER 4
    [[1, 0, clc$string_type], [0, 31, FALSE]],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [80, 2000, 10]],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [4], [
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NORMAL                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TRANSPARENT                    ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 7
    [[1, 0, clc$keyword_type], [7], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FULLDUPLEX                     ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['FULL_DUPLEX                    ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SOLICITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['UNSOLICITED                    ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 8
    [[1, 0, clc$boolean_type]],
{ PARAMETER 9
    [[1, 0, clc$integer_type], [0, 1048575, 10]],
{ PARAMETER 10
    [[1, 0, clc$boolean_type]],
{ PARAMETER 11
    [[1, 0, clc$boolean_type]],
{ PARAMETER 12
    [[1, 0, clc$file_type]],
{ PARAMETER 13
    [[1, 0, clc$string_type], [0, 31, FALSE]],
{ PARAMETER 14
    [[1, 0, clc$boolean_type]],
{ PARAMETER 15
    [[1, 0, clc$boolean_type]],
{ PARAMETER 16
    [[1, 0, clc$keyword_type], [8], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FORWARD                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['FORWARD_TERMINATE              ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['FT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 17
    [[1, 0, clc$list_type], [8, 1, 4, 0, FALSE, FALSE],
      [[1, 0, clc$string_type], [1, 1, FALSE]]
    ],
{ PARAMETER 18
    [[1, 0, clc$keyword_type], [8], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FE                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['FORWARD                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['FORWARD_EXACT                  ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 19
    [[1, 0, clc$integer_type], [1, 32767, 10]],
{ PARAMETER 20
    [[1, 0, clc$keyword_type], [6], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FORWARD                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 21
    [[1, 0, clc$list_type], [8, 1, 4, 0, FALSE, FALSE],
      [[1, 0, clc$string_type], [1, 1, FALSE]]
    ],
{ PARAMETER 22
    [[1, 0, clc$keyword_type], [6], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FORWARD                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 23
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$terminal_file_name = 1,
      p$attention_character_action = 2,
      p$break_key_action = 3,
      p$end_of_information = 4,
      p$input_block_size = 5,
      p$input_editing_mode = 6,
      p$input_output_mode = 7,
      p$input_timeout = 8,
      p$input_timeout_length = 9,
      p$input_timeout_purge = 10,
      p$partial_character_forwarding = 11,
      p$prompt_file = 12,
      p$prompt_string = 13,
      p$store_backspace_character = 14,
      p$store_nuls_dels = 15,
      p$transparent_character_mode = 16,
      p$transparent_forward_character = 17,
      p$transparent_length_mode = 18,
      p$transparent_message_length = 19,
      p$transparent_protocol_mode = 20,
      p$transparent_terminate_charact = 21 {TRANSPARENT_TERMINATE_CHARACTER} ,
      p$transparent_timeout_mode = 22,
      p$status = 23;

    VAR
      pvt: array [1 .. 23] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    change_term_conn (^pvt, c$term_conn_attributes, status);

  PROCEND ifp$_change_connection_attribut;
?? TITLE := 'ifp$_change_term_conn_defaults', EJECT ??

  PROCEDURE [XDCL] ifp$_change_term_conn_defaults
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$chatcd) change_term_conn_defaults, change_term_conn_default, chatcd (
{   attention_character_action, aca: integer 0..9 = $optional
{   break_key_action, bka: integer 0..9 = $optional
{   end_of_information, eoi: string 0..31 = $optional
{   input_block_size, ibs: integer 80..2000 = $optional
{   input_editing_mode, iem: key
{       (normal, n)
{       (transparent, t)
{     keyend = $optional
{   input_output_mode, iom: key
{       (unsolicited, u)
{       (solicited, s)
{       (full_duplex, fullduplex, f)
{     keyend = $optional
{   input_timeout, it: boolean = $optional
{   input_timeout_length, itl: integer 0..1048575 = $optional
{   input_timeout_purge, itp: boolean = $optional
{   partial_character_forwarding, pcf: boolean = $optional
{   prompt_file, pf: file = $optional
{   prompt_string, ps: string 0..31 = $optional
{   store_backspace_character, sbc: boolean = $optional
{   store_nuls_dels, snd: boolean = $optional
{   transparent_character_mode, tcm: key
{       (none, n)
{       (terminate, t)
{       (forward, f)
{       (forward_terminate, ft)
{     keyend = $optional
{   transparent_forward_character, tfc: list 1..4 of string 1 = $optional
{   transparent_length_mode, tlm: key
{       (none, n)
{       (terminate, t)
{       (forward, f)
{       (forward_exact, fe)
{     keyend = $optional
{   transparent_message_length, tml: integer 1..32767 = $optional
{   transparent_protocol_mode, tpm: key
{       (none, n)
{       (terminate, t)
{       (forward, f)
{     keyend = $optional
{   transparent_terminate_character, ttc: list 1..4 of string 1 = $optional
{   transparent_timeout_mode, ttm: key
{       (none, n)
{       (terminate, t)
{       (forward, f)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 43] of clt$pdt_parameter_name,
      parameters: array [1 .. 22] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 7] of clt$keyword_specification,
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type9: record
        header: clt$type_specification_header,
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
      type11: record
        header: clt$type_specification_header,
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type13: record
        header: clt$type_specification_header,
      recend,
      type14: record
        header: clt$type_specification_header,
      recend,
      type15: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type17: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
      recend,
      type18: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type19: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type20: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type21: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type22: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 3, 2, 12, 43, 47, 931],
    clc$command, 43, 22, 0, 0, 0, 0, 22, 'OSM$CHATCD'], [
    ['ACA                            ',clc$abbreviation_entry, 1],
    ['ATTENTION_CHARACTER_ACTION     ',clc$nominal_entry, 1],
    ['BKA                            ',clc$abbreviation_entry, 2],
    ['BREAK_KEY_ACTION               ',clc$nominal_entry, 2],
    ['END_OF_INFORMATION             ',clc$nominal_entry, 3],
    ['EOI                            ',clc$abbreviation_entry, 3],
    ['IBS                            ',clc$abbreviation_entry, 4],
    ['IEM                            ',clc$abbreviation_entry, 5],
    ['INPUT_BLOCK_SIZE               ',clc$nominal_entry, 4],
    ['INPUT_EDITING_MODE             ',clc$nominal_entry, 5],
    ['INPUT_OUTPUT_MODE              ',clc$nominal_entry, 6],
    ['INPUT_TIMEOUT                  ',clc$nominal_entry, 7],
    ['INPUT_TIMEOUT_LENGTH           ',clc$nominal_entry, 8],
    ['INPUT_TIMEOUT_PURGE            ',clc$nominal_entry, 9],
    ['IOM                            ',clc$abbreviation_entry, 6],
    ['IT                             ',clc$abbreviation_entry, 7],
    ['ITL                            ',clc$abbreviation_entry, 8],
    ['ITP                            ',clc$abbreviation_entry, 9],
    ['PARTIAL_CHARACTER_FORWARDING   ',clc$nominal_entry, 10],
    ['PCF                            ',clc$abbreviation_entry, 10],
    ['PF                             ',clc$abbreviation_entry, 11],
    ['PROMPT_FILE                    ',clc$nominal_entry, 11],
    ['PROMPT_STRING                  ',clc$nominal_entry, 12],
    ['PS                             ',clc$abbreviation_entry, 12],
    ['SBC                            ',clc$abbreviation_entry, 13],
    ['SND                            ',clc$abbreviation_entry, 14],
    ['STATUS                         ',clc$nominal_entry, 22],
    ['STORE_BACKSPACE_CHARACTER      ',clc$nominal_entry, 13],
    ['STORE_NULS_DELS                ',clc$nominal_entry, 14],
    ['TCM                            ',clc$abbreviation_entry, 15],
    ['TFC                            ',clc$abbreviation_entry, 16],
    ['TLM                            ',clc$abbreviation_entry, 17],
    ['TML                            ',clc$abbreviation_entry, 18],
    ['TPM                            ',clc$abbreviation_entry, 19],
    ['TRANSPARENT_CHARACTER_MODE     ',clc$nominal_entry, 15],
    ['TRANSPARENT_FORWARD_CHARACTER  ',clc$nominal_entry, 16],
    ['TRANSPARENT_LENGTH_MODE        ',clc$nominal_entry, 17],
    ['TRANSPARENT_MESSAGE_LENGTH     ',clc$nominal_entry, 18],
    ['TRANSPARENT_PROTOCOL_MODE      ',clc$nominal_entry, 19],
    ['TRANSPARENT_TERMINATE_CHARACTER',clc$nominal_entry, 20],
    ['TRANSPARENT_TIMEOUT_MODE       ',clc$nominal_entry, 21],
    ['TTC                            ',clc$abbreviation_entry, 20],
    ['TTM                            ',clc$abbreviation_entry, 21]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 266,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 8
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 9
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 10
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 11
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 12
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 13
    [28, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 14
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 15
    [35, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_parameter, 0, 0],
{ PARAMETER 16
    [36, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 24, clc$optional_parameter,
  0, 0],
{ PARAMETER 17
    [37, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_parameter, 0, 0],
{ PARAMETER 18
    [38, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 19
    [39, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 20
    [40, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 24, clc$optional_parameter,
  0, 0],
{ PARAMETER 21
    [41, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 22
    [27, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 9, 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, 9, 10]],
{ PARAMETER 3
    [[1, 0, clc$string_type], [0, 31, FALSE]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [80, 2000, 10]],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [4], [
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NORMAL                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TRANSPARENT                    ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [7], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FULLDUPLEX                     ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['FULL_DUPLEX                    ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SOLICITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['UNSOLICITED                    ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 7
    [[1, 0, clc$boolean_type]],
{ PARAMETER 8
    [[1, 0, clc$integer_type], [0, 1048575, 10]],
{ PARAMETER 9
    [[1, 0, clc$boolean_type]],
{ PARAMETER 10
    [[1, 0, clc$boolean_type]],
{ PARAMETER 11
    [[1, 0, clc$file_type]],
{ PARAMETER 12
    [[1, 0, clc$string_type], [0, 31, FALSE]],
{ PARAMETER 13
    [[1, 0, clc$boolean_type]],
{ PARAMETER 14
    [[1, 0, clc$boolean_type]],
{ PARAMETER 15
    [[1, 0, clc$keyword_type], [8], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FORWARD                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['FORWARD_TERMINATE              ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['FT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 16
    [[1, 0, clc$list_type], [8, 1, 4, 0, FALSE, FALSE],
      [[1, 0, clc$string_type], [1, 1, FALSE]]
    ],
{ PARAMETER 17
    [[1, 0, clc$keyword_type], [8], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FE                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['FORWARD                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['FORWARD_EXACT                  ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 18
    [[1, 0, clc$integer_type], [1, 32767, 10]],
{ PARAMETER 19
    [[1, 0, clc$keyword_type], [6], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FORWARD                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 20
    [[1, 0, clc$list_type], [8, 1, 4, 0, FALSE, FALSE],
      [[1, 0, clc$string_type], [1, 1, FALSE]]
    ],
{ PARAMETER 21
    [[1, 0, clc$keyword_type], [6], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FORWARD                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 22
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$attention_character_action = 1,
      p$break_key_action = 2,
      p$end_of_information = 3,
      p$input_block_size = 4,
      p$input_editing_mode = 5,
      p$input_output_mode = 6,
      p$input_timeout = 7,
      p$input_timeout_length = 8,
      p$input_timeout_purge = 9,
      p$partial_character_forwarding = 10,
      p$prompt_file = 11,
      p$prompt_string = 12,
      p$store_backspace_character = 13,
      p$store_nuls_dels = 14,
      p$transparent_character_mode = 15,
      p$transparent_forward_character = 16,
      p$transparent_length_mode = 17,
      p$transparent_message_length = 18,
      p$transparent_protocol_mode = 19,
      p$transparent_terminate_charact = 20 {TRANSPARENT_TERMINATE_CHARACTER} ,
      p$transparent_timeout_mode = 21,
      p$status = 22;

    VAR
      pvt: array [1 .. 22] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    change_term_conn (^pvt, c$term_conn_defaults, status);

  PROCEND ifp$_change_term_conn_defaults;
?? TITLE := 'ifp$_change_terminal_attributes', EJECT ??

  PROCEDURE [XDCL] ifp$_change_terminal_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$setta) change_terminal_attributes, change_terminal_attribute, set_terminal_attributes, ..
{ set_terminal_attribute, setta, chata (
{   attention_character, ac: (BY_NAME) string 1 = $optional
{   backspace_character, bc: (BY_NAME) string 1 = $optional
{   begin_line_character, blc: (BY_NAME) string 1 = $optional
{   cancel_line_character, clc: (BY_NAME) string 1 = $optional
{   carriage_return_delay, crd: (BY_NAME) integer 0..1000 = $optional
{   carriage_return_sequence, crs: (BY_NAME) string 0..2 = $optional
{   character_flow_control, cfc: (BY_NAME) boolean = $optional
{   code_set, cs: (BY_NAME) any of
{       key
{         ascii, bpapl, tpapl, ascii48, ascii64, ascii95, ascii128, ascii256, ebcdic
{       keyend
{       name
{     anyend = $optional
{   control_code_replacement, ccr: (BY_NAME) any of
{       key
{         none
{       keyend
{       list 1..64 of record
{         original: range of string 1
{         substitute: string 1 = $optional
{       recend
{     anyend = $optional
{   echoplex, e: (BY_NAME) boolean = $optional
{   end_line_character, elc: (BY_NAME) string 1 = $optional
{   end_line_positioning, elp: (BY_NAME) key
{       none, crs, lfs, crslfs
{     keyend = $optional
{   end_output_sequence, eos: (BY_NAME) string 0..4 = $optional
{   end_page_action, epa: (BY_NAME) key
{       none, ffs
{     keyend = $optional
{   end_partial_character, epc: (BY_NAME) string 1 = $optional
{   end_partial_positioning, epp: (BY_NAME) key
{       none, crs, lfs, crslfs
{     keyend = $optional
{   fold_line, fl: (BY_NAME) boolean = $optional
{   form_feed_delay, ffd: (BY_NAME) integer 0..3000 = $optional
{   form_feed_sequence, ffs: (BY_NAME) string 0..7 = $optional
{   function_key_class, fkc: (BY_NAME) any of
{       key
{         none
{       keyend
{       name
{     anyend = $optional
{   hold_page, hp: (BY_NAME) boolean = $optional
{   hold_page_over, hpo: (BY_NAME) boolean = $optional
{   line_feed_delay, lfd: (BY_NAME) integer 0..1000 = $optional
{   line_feed_sequence, lfs: (BY_NAME) string 0..2 = $optional
{   network_command_character, ncc: (BY_NAME) string 1 = $optional
{   page_length, pl: (BY_NAME) integer 0..255 = $optional
{   page_width, pw: (BY_NAME) integer 0..255 = $optional
{   parity, p: (BY_NAME) key
{       even, none, odd, zero, mark
{     keyend = $optional
{   pause_break_character, pbc: (BY_NAME) string 1 = $optional
{   status_action, sa: (BY_NAME) key
{       (send, s)
{       (hold, h)
{       (discard, d)
{     keyend = $optional
{   terminal_class, tc: (BY_NAME) key
{       (cdc200ut, c200ut)
{       (cdc711, c711)
{       (cdc714_10, c714_20, cdc714_20, c714_10)
{       (cdc714_30, c714_40, cdc714_40, c714_30)
{       (cdc721, c721)
{       (cdc73x, c73x)
{       (cdc75x, cdc713, c713, c75x)
{       hasp_post, hasp_pre
{       (hp2000, h2000)
{       (ibm2740, i2740)
{       (ibm2741, i2741)
{       (ibm3270, i3270)
{       (ibm3780, i3780)
{       t4010, tty, tty40
{       (x364, vt100)
{     keyend = $optional
{   terminal_model, trm, tm: (BY_NAME) any of
{       key
{         none
{       keyend
{       name 1..25
{     anyend = $optional
{   terminate_break_character, tbc: (BY_NAME) string 1 = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 68] of clt$pdt_parameter_name,
      parameters: array [1 .. 34] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
      type8: 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 .. 9] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type9: 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$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: record
              header: clt$type_specification_header,
              qualifier: clt$range_type_qualifier,
              element_type_spec: record
                header: clt$type_specification_header,
                qualifier: clt$string_type_qualifier,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$string_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type13: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type14: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
      recend,
      type15: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type17: record
        header: clt$type_specification_header,
      recend,
      type18: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type19: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type20: 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$name_type_qualifier,
        recend,
      recend,
      type21: record
        header: clt$type_specification_header,
      recend,
      type22: record
        header: clt$type_specification_header,
      recend,
      type23: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type24: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type25: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type26: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type27: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type28: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
      recend,
      type29: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type30: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type31: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 37] of clt$keyword_specification,
      recend,
      type32: 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$name_type_qualifier,
        recend,
      recend,
      type33: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type34: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 3, 2, 17, 44, 24, 866],
    clc$command, 68, 34, 0, 0, 0, 0, 34, 'OSM$SETTA'], [
    ['AC                             ',clc$abbreviation_entry, 1],
    ['ATTENTION_CHARACTER            ',clc$nominal_entry, 1],
    ['BACKSPACE_CHARACTER            ',clc$nominal_entry, 2],
    ['BC                             ',clc$abbreviation_entry, 2],
    ['BEGIN_LINE_CHARACTER           ',clc$nominal_entry, 3],
    ['BLC                            ',clc$abbreviation_entry, 3],
    ['CANCEL_LINE_CHARACTER          ',clc$nominal_entry, 4],
    ['CARRIAGE_RETURN_DELAY          ',clc$nominal_entry, 5],
    ['CARRIAGE_RETURN_SEQUENCE       ',clc$nominal_entry, 6],
    ['CCR                            ',clc$abbreviation_entry, 9],
    ['CFC                            ',clc$abbreviation_entry, 7],
    ['CHARACTER_FLOW_CONTROL         ',clc$nominal_entry, 7],
    ['CLC                            ',clc$abbreviation_entry, 4],
    ['CODE_SET                       ',clc$nominal_entry, 8],
    ['CONTROL_CODE_REPLACEMENT       ',clc$nominal_entry, 9],
    ['CRD                            ',clc$abbreviation_entry, 5],
    ['CRS                            ',clc$abbreviation_entry, 6],
    ['CS                             ',clc$abbreviation_entry, 8],
    ['E                              ',clc$abbreviation_entry, 10],
    ['ECHOPLEX                       ',clc$nominal_entry, 10],
    ['ELC                            ',clc$abbreviation_entry, 11],
    ['ELP                            ',clc$abbreviation_entry, 12],
    ['END_LINE_CHARACTER             ',clc$nominal_entry, 11],
    ['END_LINE_POSITIONING           ',clc$nominal_entry, 12],
    ['END_OUTPUT_SEQUENCE            ',clc$nominal_entry, 13],
    ['END_PAGE_ACTION                ',clc$nominal_entry, 14],
    ['END_PARTIAL_CHARACTER          ',clc$nominal_entry, 15],
    ['END_PARTIAL_POSITIONING        ',clc$nominal_entry, 16],
    ['EOS                            ',clc$abbreviation_entry, 13],
    ['EPA                            ',clc$abbreviation_entry, 14],
    ['EPC                            ',clc$abbreviation_entry, 15],
    ['EPP                            ',clc$abbreviation_entry, 16],
    ['FFD                            ',clc$abbreviation_entry, 18],
    ['FFS                            ',clc$abbreviation_entry, 19],
    ['FKC                            ',clc$abbreviation_entry, 20],
    ['FL                             ',clc$abbreviation_entry, 17],
    ['FOLD_LINE                      ',clc$nominal_entry, 17],
    ['FORM_FEED_DELAY                ',clc$nominal_entry, 18],
    ['FORM_FEED_SEQUENCE             ',clc$nominal_entry, 19],
    ['FUNCTION_KEY_CLASS             ',clc$nominal_entry, 20],
    ['HOLD_PAGE                      ',clc$nominal_entry, 21],
    ['HOLD_PAGE_OVER                 ',clc$nominal_entry, 22],
    ['HP                             ',clc$abbreviation_entry, 21],
    ['HPO                            ',clc$abbreviation_entry, 22],
    ['LFD                            ',clc$abbreviation_entry, 23],
    ['LFS                            ',clc$abbreviation_entry, 24],
    ['LINE_FEED_DELAY                ',clc$nominal_entry, 23],
    ['LINE_FEED_SEQUENCE             ',clc$nominal_entry, 24],
    ['NCC                            ',clc$abbreviation_entry, 25],
    ['NETWORK_COMMAND_CHARACTER      ',clc$nominal_entry, 25],
    ['P                              ',clc$abbreviation_entry, 28],
    ['PAGE_LENGTH                    ',clc$nominal_entry, 26],
    ['PAGE_WIDTH                     ',clc$nominal_entry, 27],
    ['PARITY                         ',clc$nominal_entry, 28],
    ['PAUSE_BREAK_CHARACTER          ',clc$nominal_entry, 29],
    ['PBC                            ',clc$abbreviation_entry, 29],
    ['PL                             ',clc$abbreviation_entry, 26],
    ['PW                             ',clc$abbreviation_entry, 27],
    ['SA                             ',clc$abbreviation_entry, 30],
    ['STATUS                         ',clc$nominal_entry, 34],
    ['STATUS_ACTION                  ',clc$nominal_entry, 30],
    ['TBC                            ',clc$abbreviation_entry, 33],
    ['TC                             ',clc$abbreviation_entry, 31],
    ['TERMINAL_CLASS                 ',clc$nominal_entry, 31],
    ['TERMINAL_MODEL                 ',clc$nominal_entry, 32],
    ['TERMINATE_BREAK_CHARACTER      ',clc$nominal_entry, 33],
    ['TM                             ',clc$abbreviation_entry, 32],
    ['TRM                            ',clc$alias_entry, 32]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 7
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 8
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 365,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 182,
  clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 11
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 12
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 13
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 14
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81, clc$optional_parameter,
  0, 0],
{ PARAMETER 15
    [27, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 16
    [28, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [37, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 18
    [38, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 19
    [39, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 20
    [40, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 21
    [41, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 22
    [42, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 23
    [47, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 24
    [48, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 25
    [50, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 26
    [52, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 27
    [53, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 28
    [54, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,
  clc$optional_parameter, 0, 0],
{ PARAMETER 29
    [55, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 30
    [61, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 31
    [64, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1376,
  clc$optional_parameter, 0, 0],
{ PARAMETER 32
    [65, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 33
    [66, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 34
    [60, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [1, 1, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 1, FALSE]],
{ PARAMETER 3
    [[1, 0, clc$string_type], [1, 1, FALSE]],
{ PARAMETER 4
    [[1, 0, clc$string_type], [1, 1, FALSE]],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [0, 1000, 10]],
{ PARAMETER 6
    [[1, 0, clc$string_type], [0, 2, FALSE]],
{ PARAMETER 7
    [[1, 0, clc$boolean_type]],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    340, [[1, 0, clc$keyword_type], [9], [
      ['ASCII                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['ASCII128                       ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['ASCII256                       ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['ASCII48                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['ASCII64                        ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['ASCII95                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['BPAPL                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['EBCDIC                         ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['TPAPL                          ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    118, [[1, 0, clc$list_type], [102, 1, 64, 0, FALSE, FALSE],
        [[1, 0, clc$record_type], [2],
        ['ORIGINAL                       ', clc$required_field, 15], [[1, 0, clc$range_type], [8],
            [[1, 0, clc$string_type], [1, 1, FALSE]]
          ],
        ['SUBSTITUTE                     ', clc$optional_field, 8], [[1, 0, clc$string_type], [1, 1, FALSE]]
        ]
      ]
    ],
{ PARAMETER 10
    [[1, 0, clc$boolean_type]],
{ PARAMETER 11
    [[1, 0, clc$string_type], [1, 1, FALSE]],
{ PARAMETER 12
    [[1, 0, clc$keyword_type], [4], [
    ['CRS                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['CRSLFS                         ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['LFS                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 13
    [[1, 0, clc$string_type], [0, 4, FALSE]],
{ PARAMETER 14
    [[1, 0, clc$keyword_type], [2], [
    ['FFS                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 15
    [[1, 0, clc$string_type], [1, 1, FALSE]],
{ PARAMETER 16
    [[1, 0, clc$keyword_type], [4], [
    ['CRS                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['CRSLFS                         ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['LFS                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 17
    [[1, 0, clc$boolean_type]],
{ PARAMETER 18
    [[1, 0, clc$integer_type], [0, 3000, 10]],
{ PARAMETER 19
    [[1, 0, clc$string_type], [0, 7, FALSE]],
{ PARAMETER 20
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 21
    [[1, 0, clc$boolean_type]],
{ PARAMETER 22
    [[1, 0, clc$boolean_type]],
{ PARAMETER 23
    [[1, 0, clc$integer_type], [0, 1000, 10]],
{ PARAMETER 24
    [[1, 0, clc$string_type], [0, 2, FALSE]],
{ PARAMETER 25
    [[1, 0, clc$string_type], [1, 1, FALSE]],
{ PARAMETER 26
    [[1, 0, clc$integer_type], [0, 255, 10]],
{ PARAMETER 27
    [[1, 0, clc$integer_type], [0, 255, 10]],
{ PARAMETER 28
    [[1, 0, clc$keyword_type], [5], [
    ['EVEN                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['MARK                           ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['ODD                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['ZERO                           ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ],
{ PARAMETER 29
    [[1, 0, clc$string_type], [1, 1, FALSE]],
{ PARAMETER 30
    [[1, 0, clc$keyword_type], [6], [
    ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['DISCARD                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['H                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['HOLD                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SEND                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 31
    [[1, 0, clc$keyword_type], [37], [
    ['C200UT                         ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['C711                           ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['C713                           ', clc$alias_entry, clc$normal_usage_entry, 7],
    ['C714_10                        ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['C714_20                        ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['C714_30                        ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['C714_40                        ', clc$alias_entry, clc$normal_usage_entry, 4],
    ['C721                           ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['C73X                           ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['C75X                           ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
    ['CDC200UT                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['CDC711                         ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['CDC713                         ', clc$alias_entry, clc$normal_usage_entry, 7],
    ['CDC714_10                      ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['CDC714_20                      ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['CDC714_30                      ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['CDC714_40                      ', clc$alias_entry, clc$normal_usage_entry, 4],
    ['CDC721                         ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['CDC73X                         ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['CDC75X                         ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['H2000                          ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
    ['HASP_POST                      ', clc$nominal_entry, clc$normal_usage_entry, 8],
    ['HASP_PRE                       ', clc$nominal_entry, clc$normal_usage_entry, 9],
    ['HP2000                         ', clc$nominal_entry, clc$normal_usage_entry, 10],
    ['I2740                          ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
    ['I2741                          ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
    ['I3270                          ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
    ['I3780                          ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
    ['IBM2740                        ', clc$nominal_entry, clc$normal_usage_entry, 11],
    ['IBM2741                        ', clc$nominal_entry, clc$normal_usage_entry, 12],
    ['IBM3270                        ', clc$nominal_entry, clc$normal_usage_entry, 13],
    ['IBM3780                        ', clc$nominal_entry, clc$normal_usage_entry, 14],
    ['T4010                          ', clc$nominal_entry, clc$normal_usage_entry, 15],
    ['TTY                            ', clc$nominal_entry, clc$normal_usage_entry, 16],
    ['TTY40                          ', clc$nominal_entry, clc$normal_usage_entry, 17],
    ['VT100                          ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
    ['X364                           ', clc$nominal_entry, clc$normal_usage_entry, 18]]
    ],
{ PARAMETER 32
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, 25]]
    ],
{ PARAMETER 33
    [[1, 0, clc$string_type], [1, 1, FALSE]],
{ PARAMETER 34
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$attention_character = 1,
      p$backspace_character = 2,
      p$begin_line_character = 3,
      p$cancel_line_character = 4,
      p$carriage_return_delay = 5,
      p$carriage_return_sequence = 6,
      p$character_flow_control = 7,
      p$code_set = 8,
      p$control_code_replacement = 9,
      p$echoplex = 10,
      p$end_line_character = 11,
      p$end_line_positioning = 12,
      p$end_output_sequence = 13,
      p$end_page_action = 14,
      p$end_partial_character = 15,
      p$end_partial_positioning = 16,
      p$fold_line = 17,
      p$form_feed_delay = 18,
      p$form_feed_sequence = 19,
      p$function_key_class = 20,
      p$hold_page = 21,
      p$hold_page_over = 22,
      p$line_feed_delay = 23,
      p$line_feed_sequence = 24,
      p$network_command_character = 25,
      p$page_length = 26,
      p$page_width = 27,
      p$parity = 28,
      p$pause_break_character = 29,
      p$status_action = 30,
      p$terminal_class = 31,
      p$terminal_model = 32,
      p$terminate_break_character = 33,
      p$status = 34;

    VAR
      pvt: array [1 .. 34] of clt$parameter_value;

    VAR
      attributes: ^ift$terminal_attributes,
      attributes_area: ^SEQ ( * ),
      attribute_count: integer,
      attribute_limit: integer,
      j: integer,
      node: ^clt$data_value,
      original_char: char;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    attribute_limit := $INTEGER (ifc$max_terminal_attribute_key);
    PUSH attributes_area: [[REP attribute_limit OF ift$terminal_attribute]];
    RESET attributes_area;
    NEXT attributes: [1 .. attribute_limit] IN attributes_area;
    attribute_count := 0;

    IF pvt [p$attention_character].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$attention_character;
      attributes^ [attribute_count].attention_character := pvt [p$attention_character].
            value^.string_value^ (1);
    IFEND;

    IF pvt [p$backspace_character].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$backspace_character;
      attributes^ [attribute_count].backspace_character := pvt [p$backspace_character].
            value^.string_value^ (1);
    IFEND;

    IF pvt [p$begin_line_character].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$begin_line_character;
      attributes^ [attribute_count].begin_line_character := pvt [p$begin_line_character].value^.
            string_value^ (1);
    IFEND;

    IF pvt [p$cancel_line_character].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$cancel_line_character;
      attributes^ [attribute_count].cancel_line_character := pvt [p$cancel_line_character].value^.
            string_value^ (1);
    IFEND;

    IF pvt [p$carriage_return_delay].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$carriage_return_delay;
      attributes^ [attribute_count].carriage_return_delay :=
            pvt [p$carriage_return_delay].value^.integer_value.value;
    IFEND;

    IF pvt [p$carriage_return_sequence].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$carriage_return_sequence;
      attributes^ [attribute_count].carriage_return_sequence.size :=
            clp$trimmed_string_size (pvt [p$carriage_return_sequence].value^.string_value^);
      attributes^ [attribute_count].carriage_return_sequence.value :=
            pvt [p$carriage_return_sequence].value^.string_value^;
    IFEND;

    IF pvt [p$character_flow_control].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$character_flow_control;
      attributes^ [attribute_count].character_flow_control :=
            pvt [p$character_flow_control].value^.boolean_value.value;
    IFEND;

    IF pvt [p$code_set].specified THEN
      attribute_count := attribute_count + 1;
      IF pvt [p$code_set].value^.kind = clc$keyword THEN
        IF pvt [p$code_set].value^.keyword_value = 'ASCII' THEN
          attributes^ [attribute_count].key := ifc$code_set;
          attributes^ [attribute_count].code_set := ifc$ascii_code_set;
        ELSEIF pvt [p$code_set].value^.keyword_value = 'BPAPL' THEN
          attributes^ [attribute_count].key := ifc$code_set;
          attributes^ [attribute_count].code_set := ifc$bpapl_code_set;
        ELSEIF pvt [p$code_set].value^.keyword_value = 'TPAPL' THEN
          attributes^ [attribute_count].key := ifc$code_set;
          attributes^ [attribute_count].code_set := ifc$tpapl_code_set;
        ELSE
          attributes^ [attribute_count].key := ifc$code_set_name;
          PUSH attributes^ [attribute_count].code_set_name;
          attributes^ [attribute_count].code_set_name^.size :=
                clp$trimmed_string_size (pvt [p$code_set].value^.keyword_value);
          attributes^ [attribute_count].code_set_name^.value := pvt [p$code_set].value^.keyword_value;
        IFEND;
      ELSE
        attributes^ [attribute_count].key := ifc$code_set_name;
        PUSH attributes^ [attribute_count].code_set_name;
        attributes^ [attribute_count].code_set_name^.size :=
              clp$trimmed_string_size (pvt [p$code_set].value^.name_value);
        attributes^ [attribute_count].code_set_name^.value := pvt [p$code_set].value^.name_value;
      IFEND;
    IFEND;

    IF pvt [p$control_code_replacement].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$control_code_replacement;
      PUSH attributes^ [attribute_count].control_code_replacement;
      attributes^ [attribute_count].control_code_replacement^.total_substitution_count := 0;
      IF pvt [p$control_code_replacement].value^.kind <> clc$keyword THEN

{ The Control_Code_Replacement attribute is not 'NONE'.

        j := 0;
        node := pvt [p$control_code_replacement].value;
        WHILE node <> NIL DO

{ Create each Control_Code_Replacement record by grouping each value in the range of
{ original control codes with its substitute control code.

          FOR original_char := node^.element_value^.field_values^ [1].value^.low_value^.string_value^ (1)
                TO node^.element_value^.field_values^ [1].value^.high_value^.string_value^ (1) DO
            j := j + 1;
            attributes^ [attribute_count].control_code_replacement^.value [j].original_control_code :=
                  original_char;
            IF (node^.element_value^.field_values^ [2].value = NIL) THEN
              attributes^ [attribute_count].control_code_replacement^.value [j].substitute_control_code :=
                    original_char;
            ELSE
              attributes^ [attribute_count].control_code_replacement^.value [j].substitute_control_code :=
                    node^.element_value^.field_values^ [2].value^.string_value^ (1);
            IFEND;
          FOREND;

{ Increment the total number of Control_Code_Replacement records.

          attributes^ [attribute_count].control_code_replacement^.total_substitution_count :=
                attributes^ [attribute_count].control_code_replacement^.total_substitution_count +
                ($INTEGER (node^.element_value^.field_values^ [1].value^.high_value^.string_value^ (1)) -
                $INTEGER (node^.element_value^.field_values^ [1].value^.low_value^.string_value^ (1)) + 1);

          node := node^.link;
        WHILEND;
      IFEND;
    IFEND;

    IF pvt [p$echoplex].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$echoplex;
      attributes^ [attribute_count].echoplex := pvt [p$echoplex].value^.boolean_value.value;
    IFEND;

    IF pvt [p$end_line_character].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$end_line_character;
      attributes^ [attribute_count].end_line_character := pvt [p$end_line_character].value^.string_value^ (1);
    IFEND;

    IF pvt [p$end_line_positioning].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$end_line_positioning;
      IF pvt [p$end_line_positioning].value^.keyword_value = 'NONE' THEN
        attributes^ [attribute_count].end_line_positioning := ifc$elp_none;
      ELSEIF pvt [p$end_line_positioning].value^.keyword_value = 'CRS' THEN
        attributes^ [attribute_count].end_line_positioning := ifc$elp_crs;
      ELSEIF pvt [p$end_line_positioning].value^.keyword_value = 'LFS' THEN
        attributes^ [attribute_count].end_line_positioning := ifc$elp_lfs;
      ELSEIF pvt [p$end_line_positioning].value^.keyword_value = 'CRSLFS' THEN
        attributes^ [attribute_count].end_line_positioning := ifc$elp_crslfs;
      IFEND;
    IFEND;

    IF pvt [p$end_output_sequence].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$end_output_sequence;
      attributes^ [attribute_count].end_output_sequence.size :=
            clp$trimmed_string_size (pvt [p$end_output_sequence].value^.string_value^);
      attributes^ [attribute_count].end_output_sequence.value :=
            pvt [p$end_output_sequence].value^.string_value^;
    IFEND;

    IF pvt [p$end_page_action].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$end_page_action;
      IF pvt [p$end_page_action].value^.keyword_value = 'NONE' THEN
        attributes^ [attribute_count].end_page_action := ifc$no_epa;
      ELSEIF pvt [p$end_page_action].value^.keyword_value = 'FFS' THEN
        attributes^ [attribute_count].end_page_action := ifc$epa_ffs;
      IFEND;
    IFEND;

    IF pvt [p$end_partial_character].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$end_partial_character;
      attributes^ [attribute_count].end_partial_character := pvt [p$end_partial_character].value^.
            string_value^ (1);
    IFEND;

    IF pvt [p$end_partial_positioning].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$end_partial_positioning;
      IF pvt [p$end_partial_positioning].value^.keyword_value = 'NONE' THEN
        attributes^ [attribute_count].end_partial_positioning := ifc$no_epp;
      ELSEIF pvt [p$end_partial_positioning].value^.keyword_value = 'CRS' THEN
        attributes^ [attribute_count].end_partial_positioning := ifc$epp_crs;
      ELSEIF pvt [p$end_partial_positioning].value^.keyword_value = 'LFS' THEN
        attributes^ [attribute_count].end_partial_positioning := ifc$epp_lfs;
      ELSEIF pvt [p$end_partial_positioning].value^.keyword_value = 'CRSLFS' THEN
        attributes^ [attribute_count].end_partial_positioning := ifc$epp_crslfs;
      IFEND;
    IFEND;

    IF pvt [p$fold_line].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$fold_line;
      attributes^ [attribute_count].fold_line := pvt [p$fold_line].value^.boolean_value.value;
    IFEND;

    IF pvt [p$form_feed_delay].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$form_feed_delay;
      attributes^ [attribute_count].form_feed_delay := pvt [p$form_feed_delay].value^.integer_value.value;
    IFEND;

    IF pvt [p$form_feed_sequence].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$form_feed_sequence;
      attributes^ [attribute_count].form_feed_sequence.size :=
            clp$trimmed_string_size (pvt [p$form_feed_sequence].value^.string_value^);
      attributes^ [attribute_count].form_feed_sequence.value := pvt [p$form_feed_sequence].value^.
            string_value^;
    IFEND;

    IF pvt [p$function_key_class].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$function_key_class;
      PUSH attributes^ [attribute_count].function_key_class;
      IF pvt [p$function_key_class].value^.kind = clc$keyword THEN
        attributes^ [attribute_count].function_key_class^.size := 1;
        attributes^ [attribute_count].function_key_class^.value := '';
      ELSE
        attributes^ [attribute_count].function_key_class^.size :=
              clp$trimmed_string_size (pvt [p$function_key_class].value^.name_value);
        attributes^ [attribute_count].function_key_class^.value :=
              pvt [p$function_key_class].value^.name_value;
      IFEND;
    IFEND;

    IF pvt [p$hold_page].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$hold_page;
      attributes^ [attribute_count].hold_page := pvt [p$hold_page].value^.boolean_value.value;
    IFEND;

    IF pvt [p$hold_page_over].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$hold_page_over;
      attributes^ [attribute_count].hold_page_over := pvt [p$hold_page_over].value^.boolean_value.value;
    IFEND;

    IF pvt [p$line_feed_delay].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$line_feed_delay;
      attributes^ [attribute_count].line_feed_delay := pvt [p$line_feed_delay].value^.integer_value.value;
    IFEND;

    IF pvt [p$line_feed_sequence].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$line_feed_sequence;
      attributes^ [attribute_count].line_feed_sequence.size :=
            STRLENGTH (pvt [p$line_feed_sequence].value^.string_value^);
      attributes^ [attribute_count].line_feed_sequence.value := pvt [p$line_feed_sequence].value^.
            string_value^;
    IFEND;

    IF pvt [p$network_command_character].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$network_command_character;
      attributes^ [attribute_count].network_command_character :=
            pvt [p$network_command_character].value^.string_value^ (1);
    IFEND;

    IF pvt [p$page_length].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$page_length;
      attributes^ [attribute_count].page_length := pvt [p$page_length].value^.integer_value.value;
    IFEND;

    IF pvt [p$page_width].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$page_width;
      attributes^ [attribute_count].page_width := pvt [p$page_width].value^.integer_value.value;
    IFEND;

    IF pvt [p$parity].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$parity;
      IF pvt [p$parity].value^.keyword_value = 'EVEN' THEN
        attributes^ [attribute_count].parity := ifc$even_parity;
      ELSEIF pvt [p$parity].value^.keyword_value = 'ODD' THEN
        attributes^ [attribute_count].parity := ifc$odd_parity;
      ELSEIF pvt [p$parity].value^.keyword_value = 'ZERO' THEN
        attributes^ [attribute_count].parity := ifc$zero_parity;
      ELSEIF pvt [p$parity].value^.keyword_value = 'NONE' THEN
        attributes^ [attribute_count].parity := ifc$no_parity;
      ELSEIF pvt [p$parity].value^.keyword_value = 'MARK' THEN
        attributes^ [attribute_count].parity := ifc$mark_parity;
      IFEND;
    IFEND;

    IF pvt [p$pause_break_character].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$pause_break_character;
      attributes^ [attribute_count].pause_break_character := pvt [p$pause_break_character].value^.
            string_value^ (1);
    IFEND;

    IF pvt [p$status_action].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$status_action;
      IF (pvt [p$status_action].value^.keyword_value = 'SEND') OR
            (pvt [p$status_action].value^.keyword_value = 'S') THEN
        attributes^ [attribute_count].status_action := ifc$send_status;
      ELSEIF (pvt [p$status_action].value^.keyword_value = 'HOLD') OR
            (pvt [p$status_action].value^.keyword_value = 'H') THEN
        attributes^ [attribute_count].status_action := ifc$hold_status;
      ELSEIF (pvt [p$status_action].value^.keyword_value = 'DISCARD') OR
            (pvt [p$status_action].value^.keyword_value = 'D') THEN
        attributes^ [attribute_count].status_action := ifc$discard_status;
      IFEND;
    IFEND;

    IF pvt [p$terminal_class].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$terminal_class;

      IF pvt [p$terminal_class].value^.keyword_value = 'CDC200UT' {C200UT} THEN
        attributes^ [attribute_count].terminal_class := ifc$c200ut_class;
      ELSEIF pvt [p$terminal_class].value^.keyword_value = 'CDC711' {C711} THEN
        attributes^ [attribute_count].terminal_class := ifc$c711_class;
      ELSEIF pvt [p$terminal_class].value^.keyword_value = 'CDC714_10' {CDC714_20 C714_20 C714_10} THEN
        attributes^ [attribute_count].terminal_class := ifc$c714_10_20_class;
      ELSEIF pvt [p$terminal_class].value^.keyword_value = 'CDC714_30' {CDC714_40 C714_40 C714_30} THEN
        attributes^ [attribute_count].terminal_class := ifc$c714_30_40;
      ELSEIF pvt [p$terminal_class].value^.keyword_value = 'CDC721' {C721} THEN
        attributes^ [attribute_count].terminal_class := ifc$c721_class;
      ELSEIF pvt [p$terminal_class].value^.keyword_value = 'CDC73X' {C73X} THEN
        attributes^ [attribute_count].terminal_class := ifc$c73x_class;
      ELSEIF pvt [p$terminal_class].value^.keyword_value = 'CDC75X' {CDC713 C713 C75X} THEN
        attributes^ [attribute_count].terminal_class := ifc$c75x_class;
      ELSEIF pvt [p$terminal_class].value^.keyword_value = 'HASP_POST' THEN
        attributes^ [attribute_count].terminal_class := ifc$hasp_post_class;
      ELSEIF pvt [p$terminal_class].value^.keyword_value = 'HASP_PRE' THEN
        attributes^ [attribute_count].terminal_class := ifc$hasp_pre_class;
      ELSEIF pvt [p$terminal_class].value^.keyword_value = 'HP2000' {H2000} THEN
        attributes^ [attribute_count].terminal_class := ifc$h2000_class;
      ELSEIF pvt [p$terminal_class].value^.keyword_value = 'IBM2740' {I2740} THEN
        attributes^ [attribute_count].terminal_class := ifc$i2740_class;
      ELSEIF pvt [p$terminal_class].value^.keyword_value = 'IBM2741' {I2741} THEN
        attributes^ [attribute_count].terminal_class := ifc$i2741_class;
      ELSEIF pvt [p$terminal_class].value^.keyword_value = 'IBM3270' {I3270} THEN
        attributes^ [attribute_count].terminal_class := ifc$i3270_class;
      ELSEIF pvt [p$terminal_class].value^.keyword_value = 'IBM3780' {I3780} THEN
        attributes^ [attribute_count].terminal_class := ifc$i3780_class;
      ELSEIF pvt [p$terminal_class].value^.keyword_value = 'T4010' THEN
        attributes^ [attribute_count].terminal_class := ifc$t4010_class;
      ELSEIF pvt [p$terminal_class].value^.keyword_value = 'TTY' THEN
        attributes^ [attribute_count].terminal_class := ifc$tty_class;
      ELSEIF pvt [p$terminal_class].value^.keyword_value = 'TTY40' THEN
        attributes^ [attribute_count].terminal_class := ifc$tty40_class;
      ELSEIF pvt [p$terminal_class].value^.keyword_value = 'X364' {VT100} THEN
        attributes^ [attribute_count].terminal_class := ifc$x364_class;
      IFEND;
    IFEND;

    IF pvt [p$terminal_model].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$terminal_model;
      IF pvt [p$terminal_model].value^.kind = clc$keyword THEN
        attributes^ [attribute_count].terminal_model.size := 1;
        attributes^ [attribute_count].terminal_model.value := '';
      ELSE
        attributes^ [attribute_count].terminal_model.size :=
              clp$trimmed_string_size (pvt [p$terminal_model].value^.name_value);
        attributes^ [attribute_count].terminal_model.value := pvt [p$terminal_model].value^.name_value;
      IFEND;
    IFEND;

    IF pvt [p$terminate_break_character].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$terminate_break_character;
      attributes^ [attribute_count].terminate_break_character :=
            pvt [p$terminate_break_character].value^.string_value^ (1);
    IFEND;

    IF attribute_count = 0 THEN
      RETURN;
    IFEND;

    RESET attributes_area;
    NEXT attributes: [1 .. attribute_count] IN attributes_area;
    ifp$change_terminal_attributes (clv$standard_files [clc$sf_command_file].path_handle_name, attributes^,
          status);

  PROCEND ifp$_change_terminal_attributes;

?? TITLE := '[XDCL] ifp$_create_telnet_connection', EJECT ??

{ PURPOSE:
{   This is the Command Processor for the CREATE_TELNET_CONNECTION command.
{
{   Once this command is executed, the user's current host connection is
{   suspended by CDCNET and all subsequent user input is sent (by CDCNET)
{   on the Telnet connection.  When the user clears his Telnet connection,
{   CDCNET puts the user back into the original host connection.
{
{   The Telnet connection is actually a CDCNET connection to a User Telnet
{   Gateway.  The name of the gateway to use is configured in each CDCNET
{   DI via the DEFINE_TELNET_SERVICE_NAME command.

  PROCEDURE [XDCL] ifp$_create_telnet_connection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (osm$cretc) create_telnet_connection, telnet, cretc (
{   host, h: any of
{       string 1..63
{       application
{     anyend = $required
{   connection_data_1, cd1: (CHECK, SECURE) string 1..127 = $optional
{   connection_data_2, cd2: (CHECK, SECURE) string 1..127 = $optional
{   connection_data_3, cd3: (CHECK, SECURE) string 1..127 = $optional
{   end_discard_prompt, edp: string 1..16 = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$application_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 2, 11, 13, 30, 41, 877],
    clc$command, 11, 6, 1, 0, 0, 0, 6, 'OSM$CRETC'], [
    ['CD1                            ',clc$abbreviation_entry, 2],
    ['CD2                            ',clc$abbreviation_entry, 3],
    ['CD3                            ',clc$abbreviation_entry, 4],
    ['CONNECTION_DATA_1              ',clc$nominal_entry, 2],
    ['CONNECTION_DATA_2              ',clc$nominal_entry, 3],
    ['CONNECTION_DATA_3              ',clc$nominal_entry, 4],
    ['EDP                            ',clc$abbreviation_entry, 5],
    ['END_DISCARD_PROMPT             ',clc$nominal_entry, 5],
    ['H                              ',clc$abbreviation_entry, 1],
    ['HOST                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 32, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 6
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$application_type, clc$string_type],
    FALSE, 2],
    8, [[1, 0, clc$string_type], [1, 63, FALSE]],
    4, [[1, 0, clc$application_type], [FALSE]]
    ],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 127, FALSE]],
{ PARAMETER 3
    [[1, 0, clc$string_type], [1, 127, FALSE]],
{ PARAMETER 4
    [[1, 0, clc$string_type], [1, 127, FALSE]],
{ PARAMETER 5
    [[1, 0, clc$string_type], [1, 16, FALSE]],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$host = 1,
      p$connection_data_1 = 2,
      p$connection_data_2 = 3,
      p$connection_data_3 = 4,
      p$end_discard_prompt = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

?? NEWTITLE := 'check_procedure', EJECT ??

    PROCEDURE check_procedure
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
        first: boolean,
        parameter_length: 0 .. clc$max_string_size,
        second: boolean,
        third: boolean;

      status.normal := TRUE;

      IF NOT which_parameter.specific THEN
        IF (parameter_value_table^ [p$host].value^.kind = clc$application) THEN
          parameter_length := STRLENGTH (parameter_value_table^ [p$host].value^.application_value^);
          IF (parameter_length > max_host_parameter_length) OR (parameter_length < 1) THEN
            osp$set_status_condition (ife$invalid_host_parameter_size, status);
            RETURN;
          IFEND;
        IFEND;

        first := parameter_value_table^ [p$connection_data_1].specified;
        second := parameter_value_table^ [p$connection_data_2].specified;
        third := parameter_value_table^ [p$connection_data_3].specified;

        IF second AND (NOT first) THEN
          osp$set_status_abnormal ('IF', ife$connection_data_dependent, 'CONNECTION_DATA_2', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'CONNECTION_DATA_1', status);
          RETURN;
        IFEND;

        IF third AND ((NOT second) OR (NOT first)) THEN
          osp$set_status_abnormal ('IF', ife$connection_data_dependent, 'CONNECTION_DATA_3', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'CONNECTION_DATA_1 and CONNECTION_DATA_2', status);
          RETURN;
        IFEND;
      IFEND;

    PROCEND check_procedure;
?? OLDTITLE, EJECT ??

    VAR
      connection_data_1: ^SEQ ( * ),
      connection_data_2: ^SEQ ( * ),
      connection_data_3: ^SEQ ( * ),
      end_discard_prompt: ^SEQ ( * ),
      host_name: ^string ( * ),
      telnet_connection_limit: integer,
      telnet_service_name: [STATIC] ost$name := 'TELNET';

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_procedure, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$host].value^.kind = clc$string THEN
      host_name := pvt [p$host].value^.string_value;
    ELSEIF pvt [p$host].value^.kind = clc$application THEN
      host_name := pvt [p$host].value^.application_value;
    IFEND;

    IF pvt [p$connection_data_1].specified THEN
      connection_data_1 := #SEQ (pvt [p$connection_data_1].value^.string_value^);
    ELSE
      connection_data_1 := NIL;
    IFEND;

    IF pvt [p$connection_data_2].specified THEN
      connection_data_2 := #SEQ (pvt [p$connection_data_2].value^.string_value^);
    ELSE
      connection_data_2 := NIL;
    IFEND;

    IF pvt [p$connection_data_3].specified THEN
      connection_data_3 := #SEQ (pvt [p$connection_data_3].value^.string_value^);
    ELSE
      connection_data_3 := NIL;
    IFEND;

    IF pvt [p$end_discard_prompt].specified THEN
      end_discard_prompt := #SEQ (pvt [p$end_discard_prompt].value^.string_value^);
    ELSE
      end_discard_prompt := NIL;
    IFEND;

    ifp$get_telnet_connection_limit (telnet_connection_limit);

    ifp$vtp_create_cdcnet_connect (telnet_service_name, #SEQ (host_name^), connection_data_1,
          connection_data_2, connection_data_3, end_discard_prompt, telnet_connection_limit, status);

  PROCEND ifp$_create_telnet_connection;
?? TITLE := '[XDCL, #GATE] ifp$vtp_create_cdcnet_connect', EJECT ??
*copy ifh$vtp_create_cdcnet_connect

  PROCEDURE [XDCL, #GATE] ifp$vtp_create_cdcnet_connect
    (    service_name: ost$name;
         service_data: ^SEQ ( * );
         connection_data_1: ^SEQ ( * );
         connection_data_2: ^SEQ ( * );
         connection_data_3: ^SEQ ( * );
         end_discard_prompt: ^SEQ ( * );
         timeout_interval_in_ms: 0 .. 0ffffffff(16);
     VAR status: ost$status);

    VAR
      file_id: amt$file_identifier,
      job_attribute_p: ^jmt$job_attribute_results,
      parameter_length: 0 .. clc$max_string_size;


    status.normal := TRUE;

    clp$put_job_command_response (' ', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_system_file_id (clc$job_command_response, file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$flush (file_id, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH job_attribute_p: [1 .. 1];
    job_attribute_p^ [1].key := jmc$origin_application_name;
    jmp$get_job_attributes (job_attribute_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF job_attribute_p^ [1].origin_application_name <> osc$timesharing THEN
      osp$set_status_condition (ife$must_be_timesharing, status);
      RETURN;
    IFEND;

    IF service_data <> NIL THEN
      parameter_length := #SIZE (service_data^);
      IF (parameter_length > max_host_parameter_length) OR (parameter_length < 1) THEN
        osp$set_status_condition (ife$invalid_host_parameter_size, status);
        RETURN;
      IFEND;
    IFEND;

    IF (connection_data_2 <> NIL) AND (connection_data_1 = NIL) THEN
      osp$set_status_abnormal ('IF', ife$connection_data_dependent, 'CONNECTION_DATA_2', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'CONNECTION_DATA_1', status);
      RETURN;
    IFEND;

    IF (connection_data_3 <> NIL) AND ((connection_data_1 = NIL) OR (connection_data_2 = NIL)) THEN
      osp$set_status_abnormal ('IF', ife$connection_data_dependent, 'CONNECTION_DATA_3', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            'CONNECTION_DATA_1 and CONNECTION_DATA_2', status);
      RETURN;
    IFEND;

    iip$vtp_create_cdcnet_connect (service_name, service_data, connection_data_1, connection_data_2,
          connection_data_3, end_discard_prompt, timeout_interval_in_ms, status);

  PROCEND ifp$vtp_create_cdcnet_connect;

?? TITLE := 'ifp$_detach_job', EJECT ??

  PROCEDURE [XDCL] ifp$_detach_job
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$detj) detach_job, detj (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [90, 3, 1, 17, 46, 11, 704],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'OSM$DETJ'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$detach_timesharing_job (status);

  PROCEND ifp$_detach_job;
?? TITLE := 'ifp$_display_connection_attribue', EJECT ??

  PROCEDURE [XDCL] ifp$_display_connection_attribu
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$distca) display_connection_attributes, display_connection_attribute, ..
{ display_term_conn_attributes, display_term_conn_attribute, distca, disca (
{   terminal_file_name, tfn: file = $required
{   display_options, display_option, do: any of
{       key
{         all
{       keyend
{       list of key
{         (attention_character_action, aca)
{         (break_key_action, bka)
{         (end_of_information, eoi)
{         (input_block_size, ibs)
{         (input_editing_mode, iem)
{         (input_output_mode, iom)
{         (input_timeout, it)
{         (input_timeout_length, itl)
{         (input_timeout_purge, itp)
{         (partial_character_forwarding, pcf)
{         (prompt_file, pf)
{         (prompt_string, ps)
{         (store_backspace_character, sbc)
{         (store_nuls_dels, snd)
{         (transparent_character_mode, tcm)
{         (transparent_forward_character, tfc)
{         (transparent_length_mode, tlm)
{         (transparent_message_length, tml)
{         (transparent_protocol_mode, tpm)
{         (transparent_terminate_character, ttc)
{         (transparent_timeout_mode, ttm)
{       keyend
{     anyend = all
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: 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 .. 42] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 3, 2, 17, 38, 2, 272],
    clc$command, 8, 4, 1, 0, 0, 0, 4, 'OSM$DISTCA'], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['TERMINAL_FILE_NAME             ',clc$nominal_entry, 1],
    ['TFN                            ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1641,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[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]]
      ],
    1577, [[1, 0, clc$list_type], [1561, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [42], [
        ['ACA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['ATTENTION_CHARACTER_ACTION     ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['BKA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['BREAK_KEY_ACTION               ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['END_OF_INFORMATION             ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['EOI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['IBS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['IEM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['INPUT_BLOCK_SIZE               ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['INPUT_EDITING_MODE             ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['INPUT_OUTPUT_MODE              ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['INPUT_TIMEOUT                  ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['INPUT_TIMEOUT_LENGTH           ', clc$nominal_entry, clc$normal_usage_entry, 8],
        ['INPUT_TIMEOUT_PURGE            ', clc$nominal_entry, clc$normal_usage_entry, 9],
        ['IOM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['IT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
        ['ITL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
        ['ITP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
        ['PARTIAL_CHARACTER_FORWARDING   ', clc$nominal_entry, clc$normal_usage_entry, 10],
        ['PCF                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
        ['PF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
        ['PROMPT_FILE                    ', clc$nominal_entry, clc$normal_usage_entry, 11],
        ['PROMPT_STRING                  ', clc$nominal_entry, clc$normal_usage_entry, 12],
        ['PS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
        ['SBC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
        ['SND                            ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
        ['STORE_BACKSPACE_CHARACTER      ', clc$nominal_entry, clc$normal_usage_entry, 13],
        ['STORE_NULS_DELS                ', clc$nominal_entry, clc$normal_usage_entry, 14],
        ['TCM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
        ['TFC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
        ['TLM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
        ['TML                            ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
        ['TPM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
        ['TRANSPARENT_CHARACTER_MODE     ', clc$nominal_entry, clc$normal_usage_entry, 15],
        ['TRANSPARENT_FORWARD_CHARACTER  ', clc$nominal_entry, clc$normal_usage_entry, 16],
        ['TRANSPARENT_LENGTH_MODE        ', clc$nominal_entry, clc$normal_usage_entry, 17],
        ['TRANSPARENT_MESSAGE_LENGTH     ', clc$nominal_entry, clc$normal_usage_entry, 18],
        ['TRANSPARENT_PROTOCOL_MODE      ', clc$nominal_entry, clc$normal_usage_entry, 19],
        ['TRANSPARENT_TERMINATE_CHARACTER', clc$nominal_entry, clc$normal_usage_entry, 20],
        ['TRANSPARENT_TIMEOUT_MODE       ', clc$nominal_entry, clc$normal_usage_entry, 21],
        ['TTC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 20],
        ['TTM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 21]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$terminal_file_name = 1,
      p$display_options = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      attributes_value: ^clt$data_value,
      work_area: ^^clt$work_area;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$get_work_area (#RING (^work_area), work_area, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    make_term_conn_attr_record (TRUE, pvt [p$terminal_file_name].value^.file_value, pvt [p$display_options],
          work_area^, attributes_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_attributes ('display_connection_attributes', pvt [p$terminal_file_name].value^.file_value,
          attributes_value, pvt [p$output].value^.file_value^, work_area^, status);

  PROCEND ifp$_display_connection_attribu;
?? TITLE := 'ifp$_display_term_conn_defaults', EJECT ??

  PROCEDURE [XDCL] ifp$_display_term_conn_defaults
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$distcd) display_term_conn_defaults, display_term_conn_attributes, distcd (
{   display_options, display_option, do: any of
{       key
{         all
{       keyend
{       list of key
{         (attention_character_action, aca)
{         (break_key_action, bka)
{         (end_of_information, eoi)
{         (input_block_size, ibs)
{         (input_editing_mode, iem)
{         (input_output_mode, iom)
{         (input_timeout, it)
{         (input_timeout_length, itl)
{         (input_timeout_purge, itp)
{         (partial_character_forwarding, pcf)
{         (prompt_file, pf)
{         (prompt_string, ps)
{         (store_backspace_character, sbc)
{         (store_nuls_dels, snd)
{         (transparent_character_mode, tcm)
{         (transparent_forward_character, tfc)
{         (transparent_length_mode, tlm)
{         (transparent_message_length, tml)
{         (transparent_protocol_mode, tpm)
{         (transparent_terminate_character, ttc)
{         (transparent_timeout_mode, ttm)
{       keyend
{     anyend = all
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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 .. 42] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 3, 1, 18, 16, 9, 0],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'OSM$DISTCD'], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 1],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 1],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1641,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    1577, [[1, 0, clc$list_type], [1561, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [42], [
        ['ACA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['ATTENTION_CHARACTER_ACTION     ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['BKA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['BREAK_KEY_ACTION               ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['END_OF_INFORMATION             ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['EOI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['IBS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['IEM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['INPUT_BLOCK_SIZE               ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['INPUT_EDITING_MODE             ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['INPUT_OUTPUT_MODE              ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['INPUT_TIMEOUT                  ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['INPUT_TIMEOUT_LENGTH           ', clc$nominal_entry, clc$normal_usage_entry, 8],
        ['INPUT_TIMEOUT_PURGE            ', clc$nominal_entry, clc$normal_usage_entry, 9],
        ['IOM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['IT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
        ['ITL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
        ['ITP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
        ['PARTIAL_CHARACTER_FORWARDING   ', clc$nominal_entry, clc$normal_usage_entry, 10],
        ['PCF                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
        ['PF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
        ['PROMPT_FILE                    ', clc$nominal_entry, clc$normal_usage_entry, 11],
        ['PROMPT_STRING                  ', clc$nominal_entry, clc$normal_usage_entry, 12],
        ['PS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
        ['SBC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
        ['SND                            ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
        ['STORE_BACKSPACE_CHARACTER      ', clc$nominal_entry, clc$normal_usage_entry, 13],
        ['STORE_NULS_DELS                ', clc$nominal_entry, clc$normal_usage_entry, 14],
        ['TCM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
        ['TFC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
        ['TLM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
        ['TML                            ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
        ['TPM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
        ['TRANSPARENT_CHARACTER_MODE     ', clc$nominal_entry, clc$normal_usage_entry, 15],
        ['TRANSPARENT_FORWARD_CHARACTER  ', clc$nominal_entry, clc$normal_usage_entry, 16],
        ['TRANSPARENT_LENGTH_MODE        ', clc$nominal_entry, clc$normal_usage_entry, 17],
        ['TRANSPARENT_MESSAGE_LENGTH     ', clc$nominal_entry, clc$normal_usage_entry, 18],
        ['TRANSPARENT_PROTOCOL_MODE      ', clc$nominal_entry, clc$normal_usage_entry, 19],
        ['TRANSPARENT_TERMINATE_CHARACTER', clc$nominal_entry, clc$normal_usage_entry, 20],
        ['TRANSPARENT_TIMEOUT_MODE       ', clc$nominal_entry, clc$normal_usage_entry, 21],
        ['TTC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 20],
        ['TTM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 21]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$display_options = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      attributes_value: ^clt$data_value,
      work_area: ^^clt$work_area;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$get_work_area (#RING (^work_area), work_area, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    make_term_conn_attr_record (TRUE, NIL, pvt [p$display_options], work_area^, attributes_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_attributes ('display_term_conn_attributes', NIL, attributes_value,
          pvt [p$output].value^.file_value^, work_area^, status);

  PROCEND ifp$_display_term_conn_defaults;
?? TITLE := 'ifp$_display_terminal_attribute', EJECT ??

  PROCEDURE [XDCL] ifp$_display_terminal_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (osm$dista) display_terminal_attributes, display_terminal_attri..
{ bute, dista (
{     display_options, display_option, do: any of
{         key
{           all
{         keyend
{         list of key
{           (attention_character, ac)
{           (backspace_character, bc)
{           (begin_line_character, blc)
{           (cancel_line_character, clc)
{           (carriage_return_delay, crd)
{           (carriage_return_sequence, crs)
{           (character_flow_control, cfc)
{           (code_set, cs)
{           (connect_view, cv)
{           (control_code_replacement, ccr)
{           (echoplex, e)
{           (end_line_character, elc)
{           (end_line_positioning, elp)
{           (end_output_sequence, eos)
{           (end_page_action, epa)
{           (end_partial_character, epc)
{           (end_partial_positioning, epp)
{           (fold_line, fl)
{           (form_feed_delay, ffd)
{           (form_feed_sequence, ffs)
{           (function_key_class, fkc)
{           (hold_page, hp)
{           (hold_page_over, hpo)
{           (line_feed_delay, lfd)
{           (line_feed_sequence, lfs)
{           (network, n)
{           (network_command_character, ncc)
{           (page_length, pl)
{           (page_width, pw)
{           (parity, p)
{           (pause_break_character, pbc)
{           (status_action, sa)
{           (terminal_class, tc)
{           (terminal_model, trm, tm)
{           (terminal_name, tn)
{           (terminate_break_character, tbc)
{         keyend
{       anyend = all
{     output, o: file = $output
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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 .. 73] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 10, 12, 9, 4, 35, 474],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'OSM$DISTA'], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 1],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 1],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 2788, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    2724, [[1, 0, clc$list_type], [2708, 1, clc$max_list_size, 0, FALSE, FALSE]
  ,
        [[1, 0, clc$keyword_type], [73], [
        ['AC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['ATTENTION_CHARACTER            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['BACKSPACE_CHARACTER            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['BC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['BEGIN_LINE_CHARACTER           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['BLC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['CANCEL_LINE_CHARACTER          ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['CARRIAGE_RETURN_DELAY          ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['CARRIAGE_RETURN_SEQUENCE       ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
        ['CCR                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
        ['CFC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
        ['CHARACTER_FLOW_CONTROL         ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
        ['CLC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['CODE_SET                       ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
        ['CONNECT_VIEW                   ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
        ['CONTROL_CODE_REPLACEMENT       ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
        ['CRD                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['CRS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['CS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
        ['CV                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
        ['E                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 11],
        ['ECHOPLEX                       ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
        ['ELC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 12],
        ['ELP                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 13],
        ['END_LINE_CHARACTER             ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
        ['END_LINE_POSITIONING           ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
        ['END_OUTPUT_SEQUENCE            ', clc$nominal_entry,
  clc$normal_usage_entry, 14],
        ['END_PAGE_ACTION                ', clc$nominal_entry,
  clc$normal_usage_entry, 15],
        ['END_PARTIAL_CHARACTER          ', clc$nominal_entry,
  clc$normal_usage_entry, 16],
        ['END_PARTIAL_POSITIONING        ', clc$nominal_entry,
  clc$normal_usage_entry, 17],
        ['EOS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 14],
        ['EPA                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 15],
        ['EPC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 16],
        ['EPP                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 17],
        ['FFD                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 19],
        ['FFS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 20],
        ['FKC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 21],
        ['FL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 18],
        ['FOLD_LINE                      ', clc$nominal_entry,
  clc$normal_usage_entry, 18],
        ['FORM_FEED_DELAY                ', clc$nominal_entry,
  clc$normal_usage_entry, 19],
        ['FORM_FEED_SEQUENCE             ', clc$nominal_entry,
  clc$normal_usage_entry, 20],
        ['FUNCTION_KEY_CLASS             ', clc$nominal_entry,
  clc$normal_usage_entry, 21],
        ['HOLD_PAGE                      ', clc$nominal_entry,
  clc$normal_usage_entry, 22],
        ['HOLD_PAGE_OVER                 ', clc$nominal_entry,
  clc$normal_usage_entry, 23],
        ['HP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 22],
        ['HPO                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 23],
        ['LFD                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 24],
        ['LFS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 25],
        ['LINE_FEED_DELAY                ', clc$nominal_entry,
  clc$normal_usage_entry, 24],
        ['LINE_FEED_SEQUENCE             ', clc$nominal_entry,
  clc$normal_usage_entry, 25],
        ['N                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 26],
        ['NCC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 27],
        ['NETWORK                        ', clc$nominal_entry,
  clc$normal_usage_entry, 26],
        ['NETWORK_COMMAND_CHARACTER      ', clc$nominal_entry,
  clc$normal_usage_entry, 27],
        ['P                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 30],
        ['PAGE_LENGTH                    ', clc$nominal_entry,
  clc$normal_usage_entry, 28],
        ['PAGE_WIDTH                     ', clc$nominal_entry,
  clc$normal_usage_entry, 29],
        ['PARITY                         ', clc$nominal_entry,
  clc$normal_usage_entry, 30],
        ['PAUSE_BREAK_CHARACTER          ', clc$nominal_entry,
  clc$normal_usage_entry, 31],
        ['PBC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 31],
        ['PL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 28],
        ['PW                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 29],
        ['SA                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 32],
        ['STATUS_ACTION                  ', clc$nominal_entry,
  clc$normal_usage_entry, 32],
        ['TBC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 36],
        ['TC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 33],
        ['TERMINAL_CLASS                 ', clc$nominal_entry,
  clc$normal_usage_entry, 33],
        ['TERMINAL_MODEL                 ', clc$nominal_entry,
  clc$normal_usage_entry, 34],
        ['TERMINAL_NAME                  ', clc$nominal_entry,
  clc$normal_usage_entry, 35],
        ['TERMINATE_BREAK_CHARACTER      ', clc$nominal_entry,
  clc$normal_usage_entry, 36],
        ['TM                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 34],
        ['TN                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 35],
        ['TRM                            ', clc$alias_entry,
  clc$normal_usage_entry, 34]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$display_options = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      attributes_value: ^clt$data_value,
      work_area: ^^clt$work_area;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$get_work_area (#RING (^work_area), work_area, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    make_term_attr_record (TRUE, pvt [p$display_options], work_area^, attributes_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_attributes ('display_terminal_attributes', NIL, attributes_value, pvt [p$output].value^.
          file_value^, work_area^, status);

  PROCEND ifp$_display_terminal_attribute;
?? TITLE := 'ifp$_request_terminal', EJECT ??

  PROCEDURE [XDCL] ifp$_request_terminal
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$reqt) request_terminal, reqt (
{   file, f: file = $required
{   attention_character_action, aca: (BY_NAME) integer 0..9 = $optional
{   break_key_action, bka: (BY_NAME) integer 0..9 = $optional
{   end_of_information, eoi: (BY_NAME) string 0..31 = $optional
{   input_block_size, ibs: (BY_NAME) integer 80..2000 = $optional
{   input_editing_mode, iem: (BY_NAME) key
{       (normal, n)
{       (transparent, t)
{     keyend = $optional
{   input_output_mode, iom: (BY_NAME) key
{       (unsolicited, u)
{       (solicited, s)
{       (full_duplex, fullduplex, f)
{     keyend = $optional
{   input_timeout, it: (BY_NAME) boolean = $optional
{   input_timeout_length, itl: (BY_NAME) integer 0..1048575 = $optional
{   input_timeout_purge, itp: (BY_NAME) boolean = $optional
{   partial_character_forwarding, pcf: (BY_NAME) boolean = $optional
{   prompt_file, pf: (BY_NAME) file = $optional
{   prompt_string, ps: (BY_NAME) string 0..31 = $optional
{   store_backspace_character, sbc: (BY_NAME) boolean = $optional
{   store_nuls_dels, snd: (BY_NAME) boolean = $optional
{   transparent_character_mode, tcm: (BY_NAME) key
{       (none, n)
{       (terminate, t)
{       (forward, f)
{       (forward_terminate, ft)
{     keyend = $optional
{   transparent_forward_character, tfc: (BY_NAME) list 1..4 of string 1 = $optional
{   transparent_length_mode, tlm: (BY_NAME) key
{       (none, n)
{       (terminate, t)
{       (forward, f)
{       (forward_exact, fe)
{     keyend = $optional
{   transparent_message_length, tml: (BY_NAME) integer 1..32767 = $optional
{   transparent_protocol_mode, tpm: (BY_NAME) key
{       (none, n)
{       (terminate, t)
{       (forward, f)
{     keyend = $optional
{   transparent_terminate_character, ttc: (BY_NAME) list 1..4 of string 1 = $optional
{   transparent_timeout_mode, ttm: (BY_NAME) key
{       (none, n)
{       (terminate, t)
{       (forward, f)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 45] of clt$pdt_parameter_name,
      parameters: array [1 .. 23] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 7] of clt$keyword_specification,
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
      type11: record
        header: clt$type_specification_header,
      recend,
      type12: record
        header: clt$type_specification_header,
      recend,
      type13: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type14: record
        header: clt$type_specification_header,
      recend,
      type15: record
        header: clt$type_specification_header,
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
      recend,
      type17: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type18: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
      recend,
      type19: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type20: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type21: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type22: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type23: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 3, 2, 12, 44, 28, 755],
    clc$command, 45, 23, 1, 0, 0, 0, 23, 'OSM$REQT'], [
    ['ACA                            ',clc$abbreviation_entry, 2],
    ['ATTENTION_CHARACTER_ACTION     ',clc$nominal_entry, 2],
    ['BKA                            ',clc$abbreviation_entry, 3],
    ['BREAK_KEY_ACTION               ',clc$nominal_entry, 3],
    ['END_OF_INFORMATION             ',clc$nominal_entry, 4],
    ['EOI                            ',clc$abbreviation_entry, 4],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['IBS                            ',clc$abbreviation_entry, 5],
    ['IEM                            ',clc$abbreviation_entry, 6],
    ['INPUT_BLOCK_SIZE               ',clc$nominal_entry, 5],
    ['INPUT_EDITING_MODE             ',clc$nominal_entry, 6],
    ['INPUT_OUTPUT_MODE              ',clc$nominal_entry, 7],
    ['INPUT_TIMEOUT                  ',clc$nominal_entry, 8],
    ['INPUT_TIMEOUT_LENGTH           ',clc$nominal_entry, 9],
    ['INPUT_TIMEOUT_PURGE            ',clc$nominal_entry, 10],
    ['IOM                            ',clc$abbreviation_entry, 7],
    ['IT                             ',clc$abbreviation_entry, 8],
    ['ITL                            ',clc$abbreviation_entry, 9],
    ['ITP                            ',clc$abbreviation_entry, 10],
    ['PARTIAL_CHARACTER_FORWARDING   ',clc$nominal_entry, 11],
    ['PCF                            ',clc$abbreviation_entry, 11],
    ['PF                             ',clc$abbreviation_entry, 12],
    ['PROMPT_FILE                    ',clc$nominal_entry, 12],
    ['PROMPT_STRING                  ',clc$nominal_entry, 13],
    ['PS                             ',clc$abbreviation_entry, 13],
    ['SBC                            ',clc$abbreviation_entry, 14],
    ['SND                            ',clc$abbreviation_entry, 15],
    ['STATUS                         ',clc$nominal_entry, 23],
    ['STORE_BACKSPACE_CHARACTER      ',clc$nominal_entry, 14],
    ['STORE_NULS_DELS                ',clc$nominal_entry, 15],
    ['TCM                            ',clc$abbreviation_entry, 16],
    ['TFC                            ',clc$abbreviation_entry, 17],
    ['TLM                            ',clc$abbreviation_entry, 18],
    ['TML                            ',clc$abbreviation_entry, 19],
    ['TPM                            ',clc$abbreviation_entry, 20],
    ['TRANSPARENT_CHARACTER_MODE     ',clc$nominal_entry, 16],
    ['TRANSPARENT_FORWARD_CHARACTER  ',clc$nominal_entry, 17],
    ['TRANSPARENT_LENGTH_MODE        ',clc$nominal_entry, 18],
    ['TRANSPARENT_MESSAGE_LENGTH     ',clc$nominal_entry, 19],
    ['TRANSPARENT_PROTOCOL_MODE      ',clc$nominal_entry, 20],
    ['TRANSPARENT_TERMINATE_CHARACTER',clc$nominal_entry, 21],
    ['TRANSPARENT_TIMEOUT_MODE       ',clc$nominal_entry, 22],
    ['TTC                            ',clc$abbreviation_entry, 21],
    ['TTM                            ',clc$abbreviation_entry, 22]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 266,
  clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 9
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 10
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 11
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 12
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 13
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 14
    [30, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 15
    [31, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 16
    [37, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [38, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 24, clc$optional_parameter,
  0, 0],
{ PARAMETER 18
    [39, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_parameter, 0, 0],
{ PARAMETER 19
    [40, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 20
    [41, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 21
    [42, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 24, clc$optional_parameter,
  0, 0],
{ PARAMETER 22
    [43, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 23
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, 9, 10]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, 9, 10]],
{ PARAMETER 4
    [[1, 0, clc$string_type], [0, 31, FALSE]],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [80, 2000, 10]],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [4], [
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NORMAL                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TRANSPARENT                    ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 7
    [[1, 0, clc$keyword_type], [7], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FULLDUPLEX                     ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['FULL_DUPLEX                    ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SOLICITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['UNSOLICITED                    ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 8
    [[1, 0, clc$boolean_type]],
{ PARAMETER 9
    [[1, 0, clc$integer_type], [0, 1048575, 10]],
{ PARAMETER 10
    [[1, 0, clc$boolean_type]],
{ PARAMETER 11
    [[1, 0, clc$boolean_type]],
{ PARAMETER 12
    [[1, 0, clc$file_type]],
{ PARAMETER 13
    [[1, 0, clc$string_type], [0, 31, FALSE]],
{ PARAMETER 14
    [[1, 0, clc$boolean_type]],
{ PARAMETER 15
    [[1, 0, clc$boolean_type]],
{ PARAMETER 16
    [[1, 0, clc$keyword_type], [8], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FORWARD                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['FORWARD_TERMINATE              ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['FT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 17
    [[1, 0, clc$list_type], [8, 1, 4, 0, FALSE, FALSE],
      [[1, 0, clc$string_type], [1, 1, FALSE]]
    ],
{ PARAMETER 18
    [[1, 0, clc$keyword_type], [8], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FE                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['FORWARD                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['FORWARD_EXACT                  ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 19
    [[1, 0, clc$integer_type], [1, 32767, 10]],
{ PARAMETER 20
    [[1, 0, clc$keyword_type], [6], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FORWARD                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 21
    [[1, 0, clc$list_type], [8, 1, 4, 0, FALSE, FALSE],
      [[1, 0, clc$string_type], [1, 1, FALSE]]
    ],
{ PARAMETER 22
    [[1, 0, clc$keyword_type], [6], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['FORWARD                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 23
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$attention_character_action = 2,
      p$break_key_action = 3,
      p$end_of_information = 4,
      p$input_block_size = 5,
      p$input_editing_mode = 6,
      p$input_output_mode = 7,
      p$input_timeout = 8,
      p$input_timeout_length = 9,
      p$input_timeout_purge = 10,
      p$partial_character_forwarding = 11,
      p$prompt_file = 12,
      p$prompt_string = 13,
      p$store_backspace_character = 14,
      p$store_nuls_dels = 15,
      p$transparent_character_mode = 16,
      p$transparent_forward_character = 17,
      p$transparent_length_mode = 18,
      p$transparent_message_length = 19,
      p$transparent_protocol_mode = 20,
      p$transparent_terminate_charact = 21 {TRANSPARENT_TERMINATE_CHARACTER} ,
      p$transparent_timeout_mode = 22,
      p$status = 23;

    VAR
      pvt: array [1 .. 23] of clt$parameter_value;

    VAR
      attributes: ^ift$connection_attributes,
      attributes_area: ^SEQ ( * ),
      attribute_count: integer,
      attribute_limit: integer,
      file: clt$file,
      i: integer,
      local_file_name: amt$local_file_name,
      evaluated_file_reference: fst$evaluated_file_reference,
      null_attribute: [STATIC, READ, oss$job_paged_literal] array
            [1 .. 1] of ift$connection_attribute := [[ifc$null_connection_attribute]],
      node: ^clt$data_value,
      terminal_lfn_loc: ^amt$local_file_name;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$convert_string_to_file (pvt [p$file].value^.file_value^, file, status);
    local_file_name := file.local_file_name;

    clp$get_fs_path_elements (local_file_name, evaluated_file_reference, status);

    IF (fsp$path_element (^evaluated_file_reference, 1) ^ <> fsc$local) OR
          (evaluated_file_reference.number_of_path_elements = 1) THEN
      osp$set_status_abnormal ('CL', cle$only_permitted_on_loc_file, '', status);
      RETURN;
    IFEND;

    attribute_limit := $INTEGER (ifc$max_connection_key);
    PUSH attributes_area: [[REP attribute_limit OF ift$connection_attribute]];
    RESET attributes_area;
    NEXT attributes: [1 .. attribute_limit] IN attributes_area;
    attribute_count := 0;

    IF pvt [p$attention_character_action].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$attention_character_action;
      attributes^ [attribute_count].attention_character_action :=
            pvt [p$attention_character_action].value^.integer_value.value;
    IFEND;

    IF pvt [p$break_key_action].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$break_key_action;
      attributes^ [attribute_count].break_key_action := pvt [p$break_key_action].value^.integer_value.value;
    IFEND;

    IF pvt [p$end_of_information].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$end_of_information;
      attributes^ [attribute_count].end_of_information.size :=
            clp$trimmed_string_size (pvt [p$end_of_information].value^.string_value^);
      attributes^ [attribute_count].end_of_information.value := pvt [p$end_of_information].value^.
            string_value^;
    IFEND;

    IF pvt [p$input_block_size].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$input_block_size;
      attributes^ [attribute_count].input_block_size := pvt [p$input_block_size].value^.integer_value.value;
    IFEND;

    IF pvt [p$input_editing_mode].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$input_editing_mode;
      IF pvt [p$input_editing_mode].value^.keyword_value = 'NORMAL' THEN
        attributes^ [attribute_count].input_editing_mode := ifc$normal_edit;
      ELSEIF pvt [p$input_editing_mode].value^.keyword_value = 'TRANSPARENT' THEN
        attributes^ [attribute_count].input_editing_mode := ifc$trans_edit;
      IFEND;
    IFEND;

    IF pvt [p$input_output_mode].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$input_output_mode;
      IF pvt [p$input_output_mode].value^.keyword_value = 'UNSOLICITED' THEN
        attributes^ [attribute_count].input_output_mode := ifc$unsolicited_output;
      ELSEIF pvt [p$input_output_mode].value^.keyword_value = 'SOLICITED' THEN
        attributes^ [attribute_count].input_output_mode := ifc$solicited;
      ELSEIF pvt [p$input_output_mode].value^.keyword_value = 'FULL_DUPLEX' THEN
        attributes^ [attribute_count].input_output_mode := ifc$full_duplex;
      IFEND;
    IFEND;

    IF pvt [p$input_timeout].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$input_timeout;
      attributes^ [attribute_count].input_timeout := pvt [p$input_timeout].value^.boolean_value.value;
    IFEND;

    IF pvt [p$input_timeout_length].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$input_timeout_length;
      attributes^ [attribute_count].input_timeout_length :=
            pvt [p$input_timeout_length].value^.integer_value.value;
    IFEND;

    IF pvt [p$input_timeout_purge].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$input_timeout_purge;
      attributes^ [attribute_count].input_timeout_purge :=
            pvt [p$input_timeout_purge].value^.boolean_value.value;
    IFEND;

    IF pvt [p$partial_character_forwarding].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$partial_char_forwarding;
      attributes^ [attribute_count].partial_character_forwarding := pvt [p$partial_character_forwarding].
            value^.boolean_value.value;
    IFEND;

    IF pvt [p$prompt_file].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$prompt_file;
      clp$convert_string_to_file (pvt [p$prompt_file].value^.file_value^, file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      attributes^ [attribute_count].prompt_file := file.local_file_name;
    IFEND;

    IF pvt [p$prompt_string].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$prompt_string;
      attributes^ [attribute_count].prompt_string.size := STRLENGTH (pvt [p$prompt_string].value^.
            string_value^);
      attributes^ [attribute_count].prompt_string.value := pvt [p$prompt_string].value^.string_value^;
    IFEND;

    IF pvt [p$store_backspace_character].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$store_backspace_character;
      attributes^ [attribute_count].store_backspace_character :=
            pvt [p$store_backspace_character].value^.boolean_value.value;
    IFEND;

    IF pvt [p$store_nuls_dels].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$store_nuls_dels;
      attributes^ [attribute_count].store_nuls_dels := pvt [p$store_nuls_dels].value^.boolean_value.value;
    IFEND;

    IF pvt [p$transparent_character_mode].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$trans_character_mode;
      IF pvt [p$transparent_character_mode].value^.keyword_value = 'NONE' THEN
        attributes^ [attribute_count].trans_character_mode := ifc$no_trans_char;
      ELSEIF pvt [p$transparent_character_mode].value^.keyword_value = 'TERMINATE' THEN
        attributes^ [attribute_count].trans_character_mode := ifc$trans_char_terminate;
      ELSEIF pvt [p$transparent_character_mode].value^.keyword_value = 'FORWARD' THEN
        attributes^ [attribute_count].trans_character_mode := ifc$trans_char_forward;
      ELSEIF pvt [p$transparent_character_mode].value^.keyword_value = 'FORWARD_TERMINATE' THEN
        attributes^ [attribute_count].trans_character_mode := ifc$trans_char_fwd_terminate;
      IFEND;
    IFEND;

    IF pvt [p$transparent_forward_character].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$trans_forward_character;
      node := pvt [p$transparent_forward_character].value;
      i := 0;
      WHILE node <> NIL DO
        i := i + 1;
        attributes^ [attribute_count].trans_forward_character.value (i) :=
              node^.element_value^.string_value^ (1);
        node := node^.link;
      WHILEND;
      attributes^ [attribute_count].trans_forward_character.size := i;
    IFEND;

    IF pvt [p$transparent_length_mode].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$trans_length_mode;
      IF pvt [p$transparent_length_mode].value^.keyword_value = 'NONE' THEN
        attributes^ [attribute_count].trans_length_mode := ifc$no_trans_len;
      ELSEIF pvt [p$transparent_length_mode].value^.keyword_value = 'TERMINATE' THEN
        attributes^ [attribute_count].trans_length_mode := ifc$trans_len_terminate;
      ELSEIF pvt [p$transparent_length_mode].value^.keyword_value = 'FORWARD' THEN
        attributes^ [attribute_count].trans_length_mode := ifc$trans_len_forward;
      ELSEIF pvt [p$transparent_length_mode].value^.keyword_value = 'FORWARD_EXACT' THEN
        attributes^ [attribute_count].trans_length_mode := ifc$trans_len_forward_exact;
      IFEND;
    IFEND;

    IF pvt [p$transparent_message_length].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$trans_message_length;
      attributes^ [attribute_count].trans_message_length :=
            pvt [p$transparent_message_length].value^.integer_value.value;
    IFEND;

    IF pvt [p$transparent_terminate_charact].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$trans_terminate_character;
      node := pvt [p$transparent_terminate_charact].value;
      i := 0;
      WHILE node <> NIL DO
        i := i + 1;
        attributes^ [attribute_count].trans_terminate_character.value (i, 1) :=
              node^.element_value^.string_value^ (1, 1);
        node := node^.link;
      WHILEND;
      attributes^ [attribute_count].trans_terminate_character.size := i;
    IFEND;

    IF pvt [p$transparent_timeout_mode].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$trans_timeout_mode;
      IF pvt [p$transparent_timeout_mode].value^.keyword_value = 'NONE' THEN
        attributes^ [attribute_count].trans_timeout_mode := ifc$no_trans_timeout;
      ELSEIF pvt [p$transparent_timeout_mode].value^.keyword_value = 'TERMINATE' THEN
        attributes^ [attribute_count].trans_timeout_mode := ifc$trans_timeout_terminate;
      ELSEIF pvt [p$transparent_timeout_mode].value^.keyword_value = 'FORWARD' THEN
        attributes^ [attribute_count].trans_timeout_mode := ifc$trans_timeout_forward;
      IFEND;
    IFEND;

    IF pvt [p$transparent_protocol_mode].specified THEN
      attribute_count := attribute_count + 1;
      attributes^ [attribute_count].key := ifc$trans_protocol_mode;
      IF pvt [p$transparent_protocol_mode].value^.keyword_value = 'NONE' THEN
        attributes^ [attribute_count].trans_protocol_mode := ifc$no_trans_protocol;
      ELSEIF pvt [p$transparent_protocol_mode].value^.keyword_value = 'TERMINATE' THEN
        attributes^ [attribute_count].trans_protocol_mode := ifc$trans_protocol_terminate;
      ELSEIF pvt [p$transparent_protocol_mode].value^.keyword_value = 'FORWARD' THEN
        attributes^ [attribute_count].trans_protocol_mode := ifc$trans_protocol_forward;
      IFEND;
    IFEND;

    IF attribute_count = 0 THEN
      attributes := ^null_attribute;
    ELSE
      RESET attributes_area;
      NEXT attributes: [1 .. attribute_count] IN attributes_area;
    IFEND;

    terminal_lfn_loc := NIL;
    rmp$request_terminal (local_file_name, terminal_lfn_loc, attributes^, status);

  PROCEND ifp$_request_terminal;
?? TITLE := 'make_term_attr_record', EJECT ??

  PROCEDURE make_term_attr_record
    (    make_for_display: boolean;
         options: clt$parameter_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    CONST
      pc_connect_ = 'PC_CONNECT_';

    TYPE
      terminal_attributes = set of ift$terminal_attribute_keys;

    VAR
      code_sets: [STATIC, READ, oss$job_paged_literal] array [ift$code_set] of string (17) := ['ASCII',
            'BPAPL', 'TPAPL', 'Use Code_Set_Name'],
      end_line_positions: [STATIC, READ, oss$job_paged_literal] array [ift$end_line_positioning] of
            string (6) := ['NONE', 'CRS', 'LFS', 'CRSLFS'],
      end_page_actions: [STATIC, READ, oss$job_paged_literal] array [ift$end_page_action] of string (4) :=
            ['NONE', 'FFS'],
      end_partial_positions: [STATIC, READ, oss$job_paged_literal] array [ift$end_partial_positioning] of
            string (6) := ['NONE', 'CRS', 'LFS', 'CRSLFS'],
      network_identifiers: [STATIC, READ, oss$job_paged_literal] array [0 .. ifc$max_network_identifier] of
            string (13) := ['NONE', 'NAM/VE CDCNET', 'NAM CDCNET', 'NAM CCP', 'INTERCOM'],
      parity_modes: [STATIC, READ, oss$job_paged_literal] array [ift$parity] of string (4) := ['ZERO', 'MARK',
            'EVEN', 'ODD', 'NONE'],
      status_actions: [STATIC, READ, oss$job_paged_literal] array [ift$status_action] of string (7) :=
            ['SEND', 'HOLD', 'DISCARD'],
      terminal_classes: [STATIC, READ, oss$job_paged_literal] array [ift$terminal_class] of string (9) :=
            ['TTY', 'CDC75X', 'CDC721', 'IBM2741', 'TTY40', 'HP2000', 'X364', 'T4010', 'HASP_POST',
            'CDC200UT', 'CDC714_30', 'CDC711', 'CDC714_10', 'HASP_PRE', 'CDC73X', 'IBM2740', 'IBM3780',
            'IBM3270'];

    VAR
      attribute_count: clt$list_size,
      attribute_key: ift$terminal_attribute_keys,
      attribute_set: terminal_attributes,
      attributes: ^ift$terminal_attributes,
      code_set_name: ost$name,
      connect_view: boolean,
      connect_view_requested: boolean,
      current_node: ^^clt$data_value,
      i: clt$list_size,
      j: integer,
      network_identifier: ift$network_identifier,
      network_requested: boolean,
      option: ^clt$data_value,
      original_code_high: char,
      original_code_low: char,
      requested_attributes: ^ift$terminal_attributes,
      substitute_code: char,
      terminal_model_requested: boolean;


    status.normal := TRUE;
    result := NIL;

    IF options.value^.kind = clc$keyword {ALL} THEN
      attribute_set := -$terminal_attributes [] - $terminal_attributes
            [ifc$null_terminal_attribute, ifc$code_set_name];
      connect_view_requested := TRUE;
      network_requested := TRUE;
      terminal_model_requested := TRUE;
    ELSE {clc$list}
      attribute_set := $terminal_attributes [];
      connect_view_requested := FALSE;
      network_requested := FALSE;
      terminal_model_requested := FALSE;
      option := options.value;
      WHILE option <> NIL DO
        IF option^.element_value^.keyword_value = 'CONNECT_VIEW' THEN
          connect_view_requested := TRUE;
          attribute_set := attribute_set + $terminal_attributes [ifc$terminal_model];
        ELSEIF option^.element_value^.keyword_value = 'NETWORK' THEN
          network_requested := TRUE;
        ELSEIF option^.element_value^.keyword_value = 'TERMINAL_MODEL' THEN
          terminal_model_requested := TRUE;
          attribute_set := attribute_set + $terminal_attributes [ifc$terminal_model];
        ELSE
          get_terminal_attribute_key (option^.element_value^.keyword_value, attribute_key);
          attribute_set := attribute_set + $terminal_attributes [attribute_key];
        IFEND;
        option := option^.link;
      WHILEND;
    IFEND;

    i := 0;
    FOR attribute_key := ifc$attention_character TO ifc$max_terminal_attribute_key DO
      i := i + $INTEGER (attribute_key IN attribute_set);
    FOREND;

    IF i = 0 THEN {only NETWORK requested}
      clp$make_record_value (1, work_area, result);

    ELSE
      PUSH attributes: [1 .. i];
      PUSH requested_attributes: [1 .. i];
      i := 0;

      FOR attribute_key := ifc$attention_character TO ifc$max_terminal_attribute_key DO
        IF attribute_key IN attribute_set THEN
          i := i + 1;
          attributes^ [i].key := attribute_key;
          IF attribute_key = ifc$terminal_name THEN
            PUSH attributes^ [i].terminal_name;
          IFEND;
          IF attribute_key = ifc$control_code_replacement THEN
            PUSH attributes^ [i].control_code_replacement;
          IFEND;
          IF attribute_key = ifc$code_set THEN
            PUSH attributes^ [i].code_set_name;
          IFEND;
          IF attribute_key = ifc$function_key_class THEN
            PUSH attributes^ [i].function_key_class;
          IFEND;
        IFEND;
      FOREND;

      requested_attributes^ := attributes^;
      ifp$get_terminal_attributes (clv$standard_files [clc$sf_command_file].path_handle_name, attributes^,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$make_record_value (UPPERBOUND (attributes^) + $INTEGER (connect_view_requested AND
            terminal_model_requested) + $INTEGER (network_requested), work_area, result);

      FOR i := 1 TO UPPERBOUND (attributes^) DO
        CASE requested_attributes^ [i].key OF

        = ifc$attention_character =
          result^.field_values^ [i].name := 'ATTENTION_CHARACTER';
          IF attributes^ [i].key <> ifc$null_terminal_attribute THEN
            clp$make_char_value (attributes^ [i].attention_character, work_area,
                  result^.field_values^ [i].value);
          ELSEIF make_for_display THEN
            clp$make_application_value (attribute_undefined_message, work_area,
                  result^.field_values^ [i].value);
          ELSE
            clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
          IFEND;

        = ifc$backspace_character =
          result^.field_values^ [i].name := 'BACKSPACE_CHARACTER';
          clp$make_char_value (attributes^ [i].backspace_character, work_area, result^.field_values^ [i].
                value);

        = ifc$begin_line_character =
          result^.field_values^ [i].name := 'BEGIN_LINE_CHARACTER';
          IF attributes^ [i].key <> ifc$null_terminal_attribute THEN
            clp$make_char_value (attributes^ [i].begin_line_character, work_area,
                  result^.field_values^ [i].value);
          ELSEIF make_for_display THEN
            clp$make_application_value (attribute_undefined_message, work_area,
                  result^.field_values^ [i].value);
          ELSE
            clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
          IFEND;

        = ifc$cancel_line_character =
          result^.field_values^ [i].name := 'CANCEL_LINE_CHARACTER';
          clp$make_char_value (attributes^ [i].cancel_line_character, work_area,
                result^.field_values^ [i].value);

        = ifc$carriage_return_delay =
          result^.field_values^ [i].name := 'CARRIAGE_RETURN_DELAY';
          clp$make_integer_value (attributes^ [i].carriage_return_delay, 10, FALSE, work_area,
                result^.field_values^ [i].value);

        = ifc$carriage_return_sequence =
          result^.field_values^ [i].name := 'CARRIAGE_RETURN_SEQUENCE';
          IF attributes^ [i].key <> ifc$null_terminal_attribute THEN
            clp$make_string_value (attributes^ [i].carriage_return_sequence.
                  value (1, attributes^ [i].carriage_return_sequence.size),
                  work_area, result^.field_values^ [i].value);
          ELSEIF make_for_display THEN
            clp$make_application_value (attribute_undefined_message, work_area,
                  result^.field_values^ [i].value);
          ELSE
            clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
          IFEND;

        = ifc$character_flow_control =
          result^.field_values^ [i].name := 'CHARACTER_FLOW_CONTROL';
          clp$make_boolean_value (attributes^ [i].character_flow_control, clc$yes_no_boolean, work_area,
                result^.field_values^ [i].value);

        = ifc$code_set =
          result^.field_values^ [i].name := 'CODE_SET';
          IF attributes^ [i].key <> ifc$null_terminal_attribute THEN
            IF attributes^ [i].key = ifc$code_set_name THEN
              code_set_name := attributes^ [i].code_set_name^.value (1, attributes^ [i].code_set_name^.size);
              IF code_set_name = '' THEN
                clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
              ELSEIF (code_set_name = 'ASCII48') OR (code_set_name = 'ASCII64') OR
                    (code_set_name = 'ASCII95') OR (code_set_name = 'ASCII128') OR
                    (code_set_name = 'ASCII256') OR (code_set_name = 'EBCDIC') THEN
                clp$make_keyword_value (code_set_name, work_area, result^.field_values^ [i].value);
              ELSE
                clp$make_name_value (code_set_name, work_area, result^.field_values^ [i].value);
              IFEND;
            ELSE
              clp$make_keyword_value (code_sets [attributes^ [i].code_set],
                    work_area, result^.field_values^ [i].value);
            IFEND;
          ELSEIF make_for_display THEN
            clp$make_application_value (attribute_undefined_message, work_area,
                  result^.field_values^ [i].value);
          ELSE
            clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
          IFEND;

        = ifc$control_code_replacement =
          result^.field_values^ [i].name := 'CONTROL_CODE_REPLACEMENT';
          IF attributes^ [i].key <> ifc$null_terminal_attribute THEN
            IF attributes^ [i].control_code_replacement^.total_substitution_count = 0 THEN
              clp$make_keyword_value ('NONE', work_area, result^.field_values^ [i].value);
            ELSE
              current_node := ^result^.field_values^ [i].value;
              j := 1;
              WHILE j <= attributes^ [i].control_code_replacement^.total_substitution_count DO
                original_code_low := attributes^ [i].control_code_replacement^.value [j].
                      original_control_code;
                substitute_code := attributes^ [i].control_code_replacement^.value [j].
                      substitute_control_code;
                WHILE (j < attributes^ [i].control_code_replacement^.total_substitution_count) AND
                      (attributes^ [i].control_code_replacement^.value [j + 1].substitute_control_code =
                      substitute_code) AND (attributes^ [i].control_code_replacement^.value [j +
                      1].original_control_code = SUCC (attributes^ [i].control_code_replacement^.value [j].
                      original_control_code)) DO
                  j := j + 1;
                WHILEND;
                original_code_high := attributes^ [i].control_code_replacement^.value [j].
                      original_control_code;
                clp$make_list_value (work_area, current_node^);
                clp$make_record_value (2, work_area, current_node^^.element_value);
                current_node^^.element_value^.field_values^ [1].name := 'ORIGINAL';
                current_node^^.element_value^.field_values^ [2].name := 'SUBSTITUTE';
                clp$make_range_value (work_area, current_node^^.element_value^.field_values^ [1].value);
                clp$make_char_value (original_code_low, work_area,
                      current_node^^.element_value^.field_values^ [1].value^.low_value);
                IF original_code_high = original_code_low THEN
                  current_node^^.element_value^.field_values^ [1].value^.high_value :=
                        current_node^^.element_value^.field_values^ [1].value^.low_value;
                ELSE
                  clp$make_char_value (original_code_high, work_area,
                        current_node^^.element_value^.field_values^ [1].value^.high_value);
                IFEND;
                clp$make_char_value (substitute_code, work_area, current_node^^.element_value^.
                      field_values^ [2].value);
                current_node := ^current_node^^.link;
                j := j + 1;
              WHILEND;
            IFEND;
          ELSEIF make_for_display THEN
            clp$make_application_value (attribute_undefined_message, work_area,
                  result^.field_values^ [i].value);
          ELSE
            clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
          IFEND;

        = ifc$echoplex =
          result^.field_values^ [i].name := 'ECHOPLEX';
          clp$make_boolean_value (attributes^ [i].echoplex, clc$yes_no_boolean, work_area,
                result^.field_values^ [i].value);

        = ifc$end_line_character =
          result^.field_values^ [i].name := 'END_LINE_CHARACTER';
          clp$make_char_value (attributes^ [i].end_line_character, work_area, result^.field_values^ [i].
                value);

        = ifc$end_line_positioning =
          result^.field_values^ [i].name := 'END_LINE_POSITIONING';
          clp$make_keyword_value (end_line_positions [attributes^ [i].end_line_positioning],
                work_area, result^.field_values^ [i].value);

        = ifc$end_output_sequence =
          result^.field_values^ [i].name := 'END_OUTPUT_SEQUENCE';
          IF attributes^ [i].key <> ifc$null_terminal_attribute THEN
            clp$make_string_value (attributes^ [i].end_output_sequence.
                  value (1, attributes^ [i].end_output_sequence.size), work_area,
                  result^.field_values^ [i].value);
          ELSEIF make_for_display THEN
            clp$make_application_value (attribute_undefined_message, work_area,
                  result^.field_values^ [i].value);
          ELSE
            clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
          IFEND;

        = ifc$end_page_action =
          result^.field_values^ [i].name := 'END_PAGE_ACTION';
          IF attributes^ [i].key <> ifc$null_terminal_attribute THEN
            clp$make_keyword_value (end_page_actions [attributes^ [i].end_page_action],
                  work_area, result^.field_values^ [i].value);
          ELSEIF make_for_display THEN
            clp$make_application_value (attribute_undefined_message, work_area,
                  result^.field_values^ [i].value);
          ELSE
            clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
          IFEND;

        = ifc$end_partial_character =
          result^.field_values^ [i].name := 'END_PARTIAL_CHARACTER';
          clp$make_char_value (attributes^ [i].end_partial_character, work_area,
                result^.field_values^ [i].value);

        = ifc$end_partial_positioning =
          result^.field_values^ [i].name := 'END_PARTIAL_POSITIONING';
          clp$make_keyword_value (end_partial_positions [attributes^ [i].end_partial_positioning],
                work_area, result^.field_values^ [i].value);

        = ifc$fold_line =
          result^.field_values^ [i].name := 'FOLD_LINE';
          clp$make_boolean_value (attributes^ [i].fold_line, clc$yes_no_boolean, work_area,
                result^.field_values^ [i].value);

        = ifc$form_feed_delay =
          result^.field_values^ [i].name := 'FORM_FEED_DELAY';
          IF attributes^ [i].key <> ifc$null_terminal_attribute THEN
            clp$make_integer_value (attributes^ [i].form_feed_delay, 10, FALSE, work_area,
                  result^.field_values^ [i].value);
          ELSEIF make_for_display THEN
            clp$make_application_value (attribute_undefined_message, work_area,
                  result^.field_values^ [i].value);
          ELSE
            clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
          IFEND;

        = ifc$form_feed_sequence =
          result^.field_values^ [i].name := 'FORM_FEED_SEQUENCE';
          IF attributes^ [i].key <> ifc$null_terminal_attribute THEN
            clp$make_string_value (attributes^ [i].form_feed_sequence.
                  value (1, attributes^ [i].form_feed_sequence.size), work_area,
                  result^.field_values^ [i].value);
          ELSEIF make_for_display THEN
            clp$make_application_value (attribute_undefined_message, work_area,
                  result^.field_values^ [i].value);
          ELSE
            clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
          IFEND;

        = ifc$function_key_class =
          result^.field_values^ [i].name := 'FUNCTION_KEY_CLASS';
          IF attributes^ [i].key <> ifc$null_terminal_attribute THEN
            IF attributes^ [i].function_key_class^.value (1, attributes^ [i].function_key_class^.size) =
                  '' THEN
              clp$make_keyword_value ('NONE', work_area, result^.field_values^ [i].value);
            ELSE
              clp$make_string_value (attributes^ [i].function_key_class^.
                    value (1, attributes^ [i].function_key_class^.size), work_area,
                    result^.field_values^ [i].value);
            IFEND;
          ELSEIF make_for_display THEN
            clp$make_application_value (attribute_undefined_message, work_area,
                  result^.field_values^ [i].value);
          ELSE
            clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
          IFEND;

        = ifc$hold_page =
          result^.field_values^ [i].name := 'HOLD_PAGE';
          clp$make_boolean_value (attributes^ [i].hold_page, clc$yes_no_boolean, work_area,
                result^.field_values^ [i].value);

        = ifc$hold_page_over =
          result^.field_values^ [i].name := 'HOLD_PAGE_OVER';
          IF attributes^ [i].key <> ifc$null_terminal_attribute THEN
            clp$make_boolean_value (attributes^ [i].hold_page_over, clc$yes_no_boolean, work_area,
                  result^.field_values^ [i].value);
          ELSEIF make_for_display THEN
            clp$make_application_value (attribute_undefined_message, work_area,
                  result^.field_values^ [i].value);
          ELSE
            clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
          IFEND;

        = ifc$line_feed_delay =
          result^.field_values^ [i].name := 'LINE_FEED_DELAY';
          clp$make_integer_value (attributes^ [i].line_feed_delay, 10, FALSE, work_area,
                result^.field_values^ [i].value);

        = ifc$line_feed_sequence =
          result^.field_values^ [i].name := 'LINE_FEED_SEQUENCE';
          IF attributes^ [i].key <> ifc$null_terminal_attribute THEN
            clp$make_string_value (attributes^ [i].line_feed_sequence.
                  value (1, attributes^ [i].line_feed_sequence.size), work_area,
                  result^.field_values^ [i].value);
          ELSEIF make_for_display THEN
            clp$make_application_value (attribute_undefined_message, work_area,
                  result^.field_values^ [i].value);
          ELSE
            clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
          IFEND;

        = ifc$network_command_character =
          result^.field_values^ [i].name := 'NETWORK_COMMAND_CHARACTER';
          clp$make_char_value (attributes^ [i].network_command_character, work_area, result^.
                field_values^ [i].value);

        = ifc$page_length =
          result^.field_values^ [i].name := 'PAGE_LENGTH';
          clp$make_integer_value (attributes^ [i].page_length, 10, FALSE, work_area, result^.
                field_values^ [i].value);

        = ifc$page_width =
          result^.field_values^ [i].name := 'PAGE_WIDTH';
          clp$make_integer_value (attributes^ [i].page_width, 10, FALSE, work_area,
                result^.field_values^ [i].value);

        = ifc$parity =
          result^.field_values^ [i].name := 'PARITY';
          clp$make_keyword_value (parity_modes [attributes^ [i].parity], work_area,
                result^.field_values^ [i].value);

        = ifc$pause_break_character =
          result^.field_values^ [i].name := 'PAUSE_BREAK_CHARACTER';
          IF attributes^ [i].key <> ifc$null_terminal_attribute THEN
            clp$make_char_value (attributes^ [i].pause_break_character, work_area,
                  result^.field_values^ [i].value);
          ELSEIF make_for_display THEN
            clp$make_application_value (attribute_undefined_message, work_area,
                  result^.field_values^ [i].value);
          ELSE
            clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
          IFEND;

        = ifc$status_action =
          result^.field_values^ [i].name := 'STATUS_ACTION';
          clp$make_keyword_value (status_actions [attributes^ [i].status_action],
                work_area, result^.field_values^ [i].value);

        = ifc$terminal_class =
          result^.field_values^ [i].name := 'TERMINAL_CLASS';
          IF attributes^ [i].key <> ifc$null_terminal_attribute THEN
            clp$make_keyword_value (terminal_classes [attributes^ [i].terminal_class],
                  work_area, result^.field_values^ [i].value);
          ELSEIF make_for_display THEN
            clp$make_application_value (attribute_undefined_message, work_area,
                  result^.field_values^ [i].value);
          ELSE
            clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
          IFEND;

        = ifc$terminal_model =
          IF connect_view_requested THEN
            connect_view := (attributes^ [i].terminal_model.size > STRLENGTH (pc_connect_)) AND
                  (attributes^ [i].terminal_model.value (1, STRLENGTH (pc_connect_)) = pc_connect_) AND
                  (attributes^ [i].terminal_model.value (STRLENGTH (pc_connect_) + 1) >= '2');
            IF NOT terminal_model_requested THEN
              result^.field_values^ [i].name := 'CONNECT_VIEW';
              clp$make_boolean_value (connect_view, clc$yes_no_boolean, work_area,
                    result^.field_values^ [i].value);
            IFEND;
          IFEND;

          IF terminal_model_requested THEN
            result^.field_values^ [i].name := 'TERMINAL_MODEL';
            IF attributes^ [i].terminal_model.value (1, attributes^ [i].terminal_model.size) = '' THEN
              clp$make_keyword_value ('NONE', work_area, result^.field_values^ [i].value);
            ELSE
              clp$make_name_value (attributes^ [i].terminal_model.
                    value (1, attributes^ [i].terminal_model.size), work_area, result^.field_values^ [i].
                    value);
            IFEND;
          IFEND;

        = ifc$terminal_name =
          result^.field_values^ [i].name := 'TERMINAL_NAME';
          IF attributes^ [i].key <> ifc$null_terminal_attribute THEN
            clp$make_trimmed_string_value (attributes^ [i].terminal_name^, work_area, result^.
                  field_values^ [i].value);
          ELSEIF make_for_display THEN
            clp$make_application_value (attribute_undefined_message, work_area,
                  result^.field_values^ [i].value);
          ELSE
            clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
          IFEND;

        = ifc$terminate_break_character =
          result^.field_values^ [i].name := 'TERMINATE_BREAK';
          IF attributes^ [i].key <> ifc$null_terminal_attribute THEN
            clp$make_char_value (attributes^ [i].terminate_break_character, work_area, result^.
                  field_values^ [i].value);
          ELSEIF make_for_display THEN
            clp$make_application_value (attribute_undefined_message, work_area,
                  result^.field_values^ [i].value);
          ELSE
            clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
          IFEND;

        ELSE
          result^.field_values^ [i].name := 'Unknown Attribute #';
          clp$make_integer_value ($INTEGER (requested_attributes^ [i].key),
                10, FALSE, work_area, result^.field_values^ [i].value);
        CASEND;
      FOREND;
    IFEND;

    IF terminal_model_requested AND connect_view_requested THEN
      result^.field_values^ [UPPERBOUND (result^.field_values^) - $INTEGER (network_requested)].name :=
            'CONNECT_VIEW';
      clp$make_boolean_value (connect_view, clc$yes_no_boolean, work_area, result^.
            field_values^ [UPPERBOUND (result^.field_values^) - $INTEGER (network_requested)].value);
    IFEND;

    IF network_requested THEN
      ifp$get_network_identifier (network_identifier, status);
      IF (NOT status.normal) OR (network_identifier > ifc$max_network_identifier) THEN
        status.normal := TRUE;
        network_identifier := SUCC (ifc$max_network_identifier);
      IFEND;
      result^.field_values^ [UPPERBOUND (result^.field_values^)].name := 'NETWORK';
      clp$make_trimmed_string_value (network_identifiers [network_identifier], work_area,
            result^.field_values^ [UPPERBOUND (result^.field_values^)].value);
    IFEND;

    clp$sort_record_fields (result^.field_values^);

  PROCEND make_term_attr_record;
?? TITLE := 'make_term_conn_attr_record', EJECT ??

  PROCEDURE make_term_conn_attr_record
    (    make_for_display: boolean;
         terminal_file: ^fst$file_reference;
         options: clt$parameter_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    TYPE
      connection_attributes = set of ift$connection_attribute_keys;

    VAR
      input_editing_modes: [STATIC, READ, oss$job_paged_literal] array [ift$input_editing_mode] of
            string (11) := ['NORMAL', 'TRANSPARENT'],
      input_output_modes: [STATIC, READ, oss$job_paged_literal] array [ift$input_output_mode] of
            string (11) := ['UNSOLICITED', 'SOLICITED', 'FULL_DUPLEX'],
      transparent_character_modes: [STATIC, READ, oss$job_paged_literal] array [ift$trans_character_mode] of
            string (17) := ['NONE', 'TERMINATE', 'FORWARD', 'FORWARD_TERMINATE'],
      transparent_length_modes: [STATIC, READ, oss$job_paged_literal] array [ift$trans_length_mode] of
            string (13) := ['NONE', 'TERMINATE', 'FORWARD', 'FORWARD_EXACT'],
      transparent_protocol_modes: [STATIC, READ, oss$job_paged_literal] array [ift$trans_protocol_mode] of
            string (9) := ['NONE', 'TERMINATE', 'FORWARD'],
      transparent_timeout_modes: [STATIC, READ, oss$job_paged_literal] array [ift$trans_timeout_mode] of
            string (9) := ['NONE', 'TERMINATE', 'FORWARD'];

    VAR
      attribute_count: clt$list_size,
      attributes_for_file: boolean,
      attribute_key: ift$connection_attribute_keys,
      attribute_set: connection_attributes,
      attributes: ^ift$get_connection_attributes,
      current_node: ^^clt$data_value,
      file: clt$file,
      file_reference: ^fst$path,
      i: clt$list_size,
      j: integer,
      option: ^clt$data_value,
      requested_attributes: ^ift$get_connection_attributes;


    IF options.value^.kind = clc$keyword {ALL} THEN
      attribute_set := -$connection_attributes [] - $connection_attributes
            [ifc$null_connection_attribute, ifc$prompt_file_identifier];
    ELSE {clc$list}
      attribute_set := $connection_attributes [];
      option := options.value;
      WHILE option <> NIL DO
        get_connection_attribute_key (option^.element_value^.name_value, attribute_key);
        attribute_set := attribute_set + $connection_attributes [attribute_key];
        option := option^.link;
      WHILEND;
    IFEND;

    i := 0;
    FOR attribute_key := ifc$attention_character_action TO ifc$max_connection_key DO
      i := i + $INTEGER (attribute_key IN attribute_set);
    FOREND;

    PUSH attributes: [1 .. i];
    PUSH requested_attributes: [1 .. i];
    i := 0;

    FOR attribute_key := ifc$attention_character_action TO ifc$max_connection_key DO
      IF attribute_key IN attribute_set THEN
        i := i + 1;
        attributes^ [i].key := attribute_key;
      IFEND;
    FOREND;

    requested_attributes^ := attributes^;
    IF terminal_file = NIL THEN
      ifp$get_term_conn_defaults (clv$standard_files [clc$sf_command_file].path_handle_name, attributes^,
            status);
    ELSE
      clp$convert_string_to_file (terminal_file^, file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      ifp$get_term_conn_attributes (file.local_file_name, attributes^, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_record_value (UPPERBOUND (attributes^), work_area, result);
    FOR i := 1 TO UPPERBOUND (attributes^) DO
      CASE requested_attributes^ [i].key OF

      = ifc$attention_character_action =
        result^.field_values^ [i].name := 'ATTENTION_CHARACTER_ACTION';
        clp$make_integer_value (attributes^ [i].attention_character_action, 10, FALSE, work_area,
              result^.field_values^ [i].value);

      = ifc$break_key_action =
        result^.field_values^ [i].name := 'BREAK_KEY_ACTION';
        clp$make_integer_value (attributes^ [i].break_key_action, 10, FALSE, work_area,
              result^.field_values^ [i].value);

      = ifc$end_of_information =
        result^.field_values^ [i].name := 'END_OF_INFORMATION';
        clp$make_string_value (attributes^ [i].end_of_information.
              value (1, attributes^ [i].end_of_information.size), work_area, result^.field_values^ [i].value);

      = ifc$input_block_size =
        result^.field_values^ [i].name := 'INPUT_BLOCK_SIZE';
        clp$make_integer_value (attributes^ [i].input_block_size, 10, FALSE, work_area,
              result^.field_values^ [i].value);

      = ifc$input_editing_mode =
        result^.field_values^ [i].name := 'INPUT_EDITING_MODE';
        clp$make_keyword_value (input_editing_modes [attributes^ [i].input_editing_mode],
              work_area, result^.field_values^ [i].value);

      = ifc$input_output_mode =
        result^.field_values^ [i].name := 'INPUT_OUTPUT_MODE';
        clp$make_keyword_value (input_output_modes [attributes^ [i].input_output_mode],
              work_area, result^.field_values^ [i].value);

      = ifc$input_timeout =
        result^.field_values^ [i].name := 'INPUT_TIMEOUT';
        clp$make_boolean_value (attributes^ [i].input_timeout, clc$yes_no_boolean, work_area,
              result^.field_values^ [i].value);

      = ifc$input_timeout_length =
        result^.field_values^ [i].name := 'INPUT_TIMEOUT_LENGTH';
        clp$make_integer_value (attributes^ [i].input_timeout_length, 10, FALSE, work_area,
              result^.field_values^ [i].value);

      = ifc$input_timeout_purge =
        result^.field_values^ [i].name := 'INPUT_TIMEOUT_PURGE';
        clp$make_boolean_value (attributes^ [i].input_timeout_purge, clc$yes_no_boolean, work_area,
              result^.field_values^ [i].value);

      = ifc$partial_char_forwarding =
        result^.field_values^ [i].name := 'PARTIAL_CHARACTER_FORWARDING';
        clp$make_boolean_value (attributes^ [i].partial_character_forwarding, clc$yes_no_boolean, work_area,
              result^.field_values^ [i].value);

      = ifc$prompt_file =
        result^.field_values^ [i].name := 'PROMPT_FILE';
        PUSH file_reference;
        clp$get_path_name (attributes^ [i].prompt_file, osc$full_message_level, file_reference^);
        clp$make_file_value (file_reference^, work_area, result^.field_values^ [i].value);

      = ifc$prompt_string =
        result^.field_values^ [i].name := 'PROMPT_STRING';
        clp$make_string_value (attributes^ [i].prompt_string.value (1, attributes^ [i].prompt_string.size),
              work_area, result^.field_values^ [i].value);

      = ifc$store_backspace_character =
        result^.field_values^ [i].name := 'STORE_BACKSPACE_CHARACTER';
        clp$make_boolean_value (attributes^ [i].store_backspace_character, clc$yes_no_boolean, work_area,
              result^.field_values^ [i].value);

      = ifc$store_nuls_dels =
        result^.field_values^ [i].name := 'STORE_NULS_DELS';
        clp$make_boolean_value (attributes^ [i].store_nuls_dels, clc$yes_no_boolean, work_area,
              result^.field_values^ [i].value);

      = ifc$trans_character_mode =
        result^.field_values^ [i].name := 'TRANSPARENT_CHARACTER_MODE';
        clp$make_keyword_value (transparent_character_modes [attributes^ [i].trans_character_mode], work_area,
              result^.field_values^ [i].value);

      = ifc$trans_length_mode =
        result^.field_values^ [i].name := 'TRANSPARENT_LENGTH_MODE';
        clp$make_keyword_value (transparent_length_modes [attributes^ [i].trans_length_mode],
              work_area, result^.field_values^ [i].value);

      = ifc$trans_message_length =
        result^.field_values^ [i].name := 'TRANSPARENT_MESSAGE_LENGTH';
        clp$make_integer_value (attributes^ [i].trans_message_length, 10, FALSE, work_area,
              result^.field_values^ [i].value);

      = ifc$trans_timeout_mode =
        result^.field_values^ [i].name := 'TRANSPARENT_TIMEOUT_MODE';
        clp$make_keyword_value (transparent_timeout_modes [attributes^ [i].trans_timeout_mode],
              work_area, result^.field_values^ [i].value);

      = ifc$trans_forward_character =
        result^.field_values^ [i].name := 'TRANSPARENT_FORWARD_CHARACTER';
        current_node := ^result^.field_values^ [i].value;
        FOR j := 1 TO attributes^ [i].trans_forward_character.size DO
          clp$make_list_value (work_area, current_node^);
          clp$make_char_value (attributes^ [i].trans_forward_character.value (j), work_area,
                current_node^^.element_value);
          current_node := ^current_node^^.link;
        FOREND;

      = ifc$trans_terminate_character =
        result^.field_values^ [i].name := 'TRANSPARENT_TERMINATE_CHARACTER';
        clp$make_string_value (attributes^ [i].trans_terminate_character.value (1), work_area,
              result^.field_values^ [i].value);
        current_node := ^result^.field_values^ [i].value;
        FOR j := 1 TO attributes^ [i].trans_terminate_character.size DO
          clp$make_list_value (work_area, current_node^);
          clp$make_char_value (attributes^ [i].trans_terminate_character.value (j), work_area,
                current_node^^.element_value);
          current_node := ^current_node^^.link;
        FOREND;

      = ifc$trans_protocol_mode =
        result^.field_values^ [i].name := 'TRANSPARENT_PROTOCOL_MODE';
        IF attributes^ [i].key <> ifc$null_connection_attribute THEN
          clp$make_keyword_value (transparent_protocol_modes [attributes^ [i].trans_protocol_mode], work_area,
                result^.field_values^ [i].value);
        ELSEIF make_for_display THEN
          clp$make_application_value (attribute_undefined_message, work_area, result^.field_values^ [i].
                value);
        ELSE
          clp$make_unspecified_value (work_area, result^.field_values^ [i].value);
        IFEND;

      ELSE
        result^.field_values^ [i].name := 'Unknown Attribute #';
        clp$make_integer_value ($INTEGER (requested_attributes^ [i].key),
              10, FALSE, work_area, result^.field_values^ [i].value);
      CASEND;
    FOREND;

    clp$sort_record_fields (result^.field_values^);

  PROCEND make_term_conn_attr_record;

MODEND ifm$interactive_commands;
*DECK DECK=IFM$INTERACTIVE_EXECUTIVE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Interactive Facility: Executive' ??
?? NEWTITLE := 'Purpose and Design', EJECT ??
MODULE ifm$interactive_executive;

{  PURPOSE:
{    The purpose of the interactive executive is fourfold:
{      1.  To receive requests for new terminal connections to NOS/VE
{          interactive jobs.  When a new connection request is
{          received, the connecting user is briefly re-validated in
{          the NOS/VE system and a new interactive job is started if
{          the validation succeeds.  If the validation does not
{          succeed, the connection request is rejected.  If, for some
{          reason, a new job cannot be started, the connection request
{          is also rejected.
{      2.  To receive notifications of logical errors committed by
{          NOS/VE software - where the specific connection number
{          is not known.  These error notifications are recorded in
{          a NOS/VE log and are counted.  When the count of these
{          errors becomes too large, the NOS/VE interactive system
{          is stopped.
{      3.  To process commands from the NOS/VE operator facility that
{          affect the operation of the interactive system.  For
{          example, start-up the interactive system, stop the
{          interactive system, establish the "banner" message to be
{          displayed to terminals as they login, or send a broadcast
{          message to all terminals.
{      4.  To process "collector mode" input operations for
{          interactive jobs.
{
{  DESIGN:
{

?? TITLE := 'Global External Procedure Declarations', EJECT ??
*copyc IFV$MODULE_FOR_C180
*copyc TMC$WAIT_TIMES
*copyc MLP$SIGN_ON
*copyc PMT$PROGRAM_PARAMETERS
*copyc MLP$SIGN_OFF
*copyc MLP$RECEIVE_MESSAGE
*copyc MLP$SEND_MESSAGE
*copyc MLP$ADD_SENDER
*copyc PMP$WAIT
*copyc PMP$ESTABLISH_CONDITION_HANDLER
*copyc PMP$CONTINUE_TO_CAUSE
*copyc PMP$LOG
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIP$REPORT_LOGICAL_ERROR
*copyc OSP$UNPACK_STATUS_IDENTIFIER
*copyc i#move
  PROCEDURE [XREF] iip$interactive_shutdown (VAR status: ost$status);
*copyc JMT$JOB_MODE
*copyc jmp$get_attribute_defaults
*copyc OST$STATUS
*copyc IIP$ROUTE
*copyc IIP$REPORT_STATUS_ERROR
*copyc IIP$REPORT_UNHANDLED_MESSAGE
*copyc IIP$REPORT_UNHANDLED_SUPER_MSG
*copyc IIP$DPC64_TO_STRING
?? TITLE := 'Common Global Constants and Types', EJECT ??
*copyc iit$application_names_messages
?? TITLE := 'Module-Local Global Constants and Types', EJECT ??

  TYPE
    mli_condition = set of mlt$status;

?? TITLE := 'Global Variables', EJECT ??

  VAR
    mli_retry_condition: mli_condition := $mli_condition [mlc$busy_interlock,
      mlc$pool_buffer_not_avail, mlc$prior_msg_not_received,
      mlc$receive_list_full, mlc$receive_list_index_invalid],
    mli_ignore_condition: mli_condition := $mli_condition
      [mlc$dup_permits_ignored, mlc$msgs_from_sender_queued, mlc$ok,
      mlc$queued_msgs_lost, mlc$signal_failed_ignored,
      mlc$signal_to_c170_ignored],
    mli_fatal_condition: mli_condition := $mli_condition [mlc$ant_full,
      mlc$bad_c170_parameter, mlc$c170_c170_illegal, mlc$illegal_function,
      mlc$max_msgs_too_large, mlc$max_signons_this_appl,
      mlc$max_signons_this_task, mlc$message_too_long, mlc$message_truncated,
      mlc$mli_internal_error, mlc$nosve_not_up, mlc$permit_list_full,
      mlc$receiver_name_syntax_error, mlc$receiver_not_signed_on,
      mlc$sender_name_syntax_error, mlc$sender_not_permitted,
      mlc$sender_not_signed_on, mlc$system_name_no_match];

?? TITLE := 'PROCEDURE validate_login', EJECT ??

  PROCEDURE validate_login (VAR con_req: iit$input_supervisory_message;
    VAR rstatus: ost$status);

    rstatus.normal := TRUE;

  PROCEND validate_login;
?? TITLE := 'PROCEDURE reject_connection', EJECT ??

  PROCEDURE reject_connection (VAR problem_status: ost$status;
    VAR con_req: iit$input_supervisory_message);

    VAR
      con_rej: [STATIC] iit$output_supervisory_message := [[ * ,
        iic$supervisory_block, 0, iic$min_block_number, iic$60_bit_characters,
        * , 1], * , iic$sm_connection_rejected, [ * , * , * ]],
      problem_status_identifier: ost$status_identifier,
      status: ost$status,
      status_1: ost$status;

{ Set the reason for the connection reject

    osp$unpack_status_identifier (problem_status.condition, problem_status_identifier);
    IF problem_status_identifier = 'AV' THEN
      con_rej.connection_rejected.reason := iic$unspecified_reject;
    ELSEIF problem_status_identifier = 'JM' THEN
      con_rej.connection_rejected.reason := iic$unspecified_reject;
    ELSE
      con_rej.connection_rejected.reason := iic$unspecified_reject;
    IFEND;

{ Set the connection number of the connection being rejected

    con_rej.connection_rejected.connection_number := con_req.
          conreq_connection_number;

{ Send the connection reject

  /send_reject/
    REPEAT
      mlp$send_message (iic$exec_application_name,
            iic$output_supervisory_message, NIL, #LOC (con_rej), #SIZE
            (con_rej), iic$passon_application_name, status);
      IF (NOT status.normal) AND (status.condition IN mli_retry_condition) THEN
        pmp$wait (1000, 1000);
      IFEND;
    UNTIL status.normal OR NOT (status.condition IN mli_retry_condition);
    IF (NOT status.normal) AND (status.condition IN mli_fatal_condition) THEN
      iip$report_status_error (status, 'con_rej');
    IFEND;

{ Log the connection reject

{*fill in later*}

  PROCEND reject_connection;
?? TITLE := 'PROCEDURE record_login', EJECT ??

  PROCEDURE record_login (VAR con_req: iit$input_supervisory_message);

{*fill in later*}

  PROCEND record_login;
?? TITLE := 'PROCEDURE string_to_dpc64', EJECT ??

  PROCEDURE string_to_dpc64 (str: string ( * );
    VAR dpc: packed array [0 .. * ] OF iit$170_display_word;
    VAR number_of_dpc_words: integer);

    VAR
      display_code: [STATIC] array [0 .. 127] of 0 .. 3f(16) := [39, 39, 39,
        39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
        39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 45, 54, 52, 48, 43, 51, 55,
        56, 41, 42, 39, 37, 46, 38, 47, 40, 27, 28, 29, 30, 31, 32, 33, 34, 35,
        36, 0, 63, 58, 44, 59, 57, 60, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12,
        13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 49, 61, 50, 62,
        53, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
        39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39],
      eol_fill: integer,
      needed: integer,
      available: integer,
      leng: integer,
      dch: 0 .. 3f(16),
      i: integer,
      word: integer,
      character: integer;

{ Determine number of 6-bit end-of-line "00" characters and number of
{   characters to convert

    eol_fill := 10 - (STRLENGTH (str) MOD 10);
    IF eol_fill = 1 THEN
      eol_fill := 11;
    IFEND;
    needed := STRLENGTH (str) + eol_fill;
    available := (UPPERBOUND (dpc) + 1) * 10;
    IF available >= needed THEN
      leng := STRLENGTH (str);
    ELSE
      leng := available - eol_fill;
    IFEND;

{ Convert the string to display code

    FOR i := 1 TO leng DO
      word := (i - 1) DIV 10;
      character := (i - 1) MOD 10;
      dch := display_code [ORD (str (i))];
      IF character < 5 THEN
        dpc [word].left_character [character] := dch;
      ELSE
        dpc [word].right_character [character - 5] := dch;
      IFEND;
    FOREND;

{ Append the Z-type end-of-line

    FOR i := leng + 1 TO leng + eol_fill DO
      word := (i - 1) DIV 10;
      character := (i - 1) MOD 10;
      IF character < 5 THEN
        dpc [word].left_character [character] := 0;
      ELSE
        dpc [word].right_character [character - 5] := 0;
      IFEND;
    FOREND;

{ Return the number of display code words constructed

    number_of_dpc_words := word + 1;

  PROCEND string_to_dpc64;
?? TITLE := 'PROCEDURE start_job', EJECT ??

  PROCEDURE start_job (VAR con_req: iit$input_supervisory_message;
    VAR rstatus: ost$status);

    VAR
      status: ost$status,
      i: integer,
      job_parameters: jmt$system_job_parameters,
      user_id: ost$user_identification,
      temp_dc_array: packed array [1 .. 7] of iit$display_code,
      default_attribute_results: ^jmt$default_attribute_results,
      job_name: jmt$user_supplied_name,
      job_name_length: integer,
      user_name: ost$name,
      family_name: ost$name,
      user_name_length: integer,
      family_name_length: integer;

{ Assume abnormal status

    rstatus.normal := FALSE;

{ ROUTE the job file to the input queue

    temp_dc_array := con_req.conreq_user_name;
    iip$dpc64_to_string (temp_dc_array, 7, ' ', user_name, user_name_length);

{ If the user exists on NOS and is validated to use VEIAF
{ and the user exists on VE within a family we will accept
{ the job a "valid".  The NOS/VE default login family
{ is used only if a NULL family is returned
{ from NOS (the first character of the family is NULL), otherwise
{ the family that is passed from NOS is used.

    PUSH default_attribute_results: [1 .. 1 ];
    default_attribute_results^ [1].key := jmc$login_family;

    jmp$get_attribute_defaults (jmc$interactive_connected, default_attribute_results, status);
    IF NOT status.normal THEN
      iip$report_status_error (status, 'get_attribute_defaults');
      RETURN;
    IFEND;

    IF con_req.conreq_family_name[1] = 00(16) THEN
      user_id.family := default_attribute_results^ [1].login_family;
    ELSE
      temp_dc_array := con_req.conreq_family_name;
      iip$dpc64_to_string (temp_dc_array, 7, ' ', family_name,
        family_name_length);
      user_id.family := family_name(1,family_name_length);
    IFEND;

    user_id.user := user_name(1,user_name_length);

    job_name := user_name (1, user_name_length);

    con_req.conreq_fill6 := iic$initial_job_start;

    job_parameters.system_job_parameter_count := 20 * 8;
    i#move(^con_req, ^job_parameters.system_job_parameter, job_parameters.system_job_parameter_count);

    iip$route (user_id, job_name, job_parameters, status);
    IF NOT status.normal THEN
      iip$report_status_error (status, 'route');
      RETURN;
    IFEND;
    rstatus.normal := TRUE;

  PROCEND start_job;
?? TITLE := 'PROCEDURE initialize', EJECT ??

  PROCEDURE initialize (VAR rstatus: ost$status);

    VAR
      unique: mlt$application_name,
      status: ost$status,
      status_1: ost$status;

    rstatus.normal := TRUE;

{ Sign-on to the memory link

  /sign_on/
    REPEAT
      mlp$sign_on (iic$exec_application_name, mlc$max_queued_messages, unique,
            status);
      IF (NOT status.normal) AND (status.condition IN mli_retry_condition) THEN
        pmp$wait (1000, 1000);
      IFEND;
    UNTIL status.normal OR NOT (status.condition IN mli_retry_condition);
    IF (NOT status.normal) AND (status.condition IN mli_fatal_condition) THEN
      iip$report_status_error (status, 'signon');
      rstatus := status;
      RETURN;
    IFEND;

{ Permit any job / task to send

  /permit_all/
    REPEAT
      mlp$add_sender (iic$exec_application_name, mlc$null_name, status);
      IF (NOT status.normal) AND (status.condition IN mli_retry_condition) THEN
        pmp$wait (1000, 1000);
      IFEND;
    UNTIL status.normal OR NOT (status.condition IN mli_retry_condition);
    IF (NOT status.normal) AND (status.condition IN mli_fatal_condition) THEN
      iip$report_status_error (status, 'add_sender');
      rstatus := status;
      RETURN;
    IFEND;

{ Tell PASSON to start interactive processing

    start_passon (rstatus);

  PROCEND initialize;
?? TITLE := 'PROCEDURE start_passon', EJECT ??

  PROCEDURE start_passon (VAR status: ost$status);

    VAR
      start_interactive_msg: iit$output_supervisory_message;

    start_interactive_msg.header.pad1 := 0;
    start_interactive_msg.header.block_type := iic$supervisory_block;
    start_interactive_msg.header.address := 0;
    start_interactive_msg.header.block_number := iic$min_block_number;
    start_interactive_msg.header.character_type := iic$60_bit_characters;
    start_interactive_msg.header.fill1 := 0;
    start_interactive_msg.header.text_length := 0;
    start_interactive_msg.message_type := iic$sm_start_interactive;
    start_interactive_msg.start_interactive := 0;

    REPEAT
      pmp$wait (1000, 1000);
      mlp$send_message (iic$exec_application_name,
            iic$output_supervisory_message, NIL, #LOC (start_interactive_msg),
            #SIZE (start_interactive_msg), iic$passon_application_name,
            status);
    UNTIL status.normal OR (status.condition IN mli_ignore_condition) OR ((NOT
          (status.condition IN mli_retry_condition)) AND (status.condition <>
          mlc$receiver_not_signed_on) AND (status.condition <>
          mlc$sender_not_permitted));
    IF (NOT status.normal) AND (status.condition IN mli_fatal_condition) THEN
      iip$report_status_error (status, 'send_start_int');
      RETURN;
    IFEND;

  PROCEND start_passon;
?? TITLE := 'PROCEDURE quit', EJECT ??

  PROCEDURE quit;

    VAR
      stop_interactive_msg: [STATIC] iit$output_supervisory_message,
      status: ost$status,
      status_1: ost$status;

{ Initialize the "stop" message (until CYBIL bug fixed)

    stop_interactive_msg.header.pad1 := 0;
    stop_interactive_msg.header.block_type := iic$supervisory_block;
    stop_interactive_msg.header.address := 0;
    stop_interactive_msg.header.block_number := 0;
    stop_interactive_msg.header.character_type := iic$60_bit_characters;
    stop_interactive_msg.header.fill1 := 0;
    stop_interactive_msg.header.text_length := 0;
    stop_interactive_msg.message_type := iic$sm_stop_interactive;
    stop_interactive_msg.stop_interactive := 0;

{ Tell PASSON to stop interactive processing

  /stop_interactive/
    REPEAT
      mlp$send_message (iic$exec_application_name,
            iic$output_supervisory_message, NIL, #LOC (stop_interactive_msg),
            #SIZE (stop_interactive_msg), iic$passon_application_name, status);
      IF (NOT status.normal) AND (status.condition IN mli_retry_condition) THEN
        pmp$wait (1000, 1000);
      IFEND;
    UNTIL status.normal OR NOT (status.condition IN mli_retry_condition);
    IF (NOT status.normal) AND (status.condition IN mli_fatal_condition) THEN
      iip$report_status_error (status, 'stop_interactive');
    IFEND;

{ Sign off from the memory link

  /sign_off/
    REPEAT
      mlp$sign_off (iic$exec_application_name, status);
      IF (NOT status.normal) AND (status.condition IN mli_retry_condition) THEN
        pmp$wait (1000, 1000);
      IFEND;
    UNTIL status.normal OR NOT (status.condition IN mli_retry_condition);
    IF (NOT status.normal) AND (status.condition IN mli_fatal_condition) THEN
      iip$report_status_error (status, 'sign_off');
    IFEND;

  PROCEND quit;
?? TITLE := 'PROCEDURE handle_break', EJECT ??

  PROCEDURE handle_break (cond: pmt$condition;
        cd: ^pmt$condition_information;
        sa: ^ost$stack_frame_save_area;
    VAR ch_status: ost$status);

    VAR
      local_status: ost$status;

    iip$interactive_shutdown (local_status);
    pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
    ch_status.normal := TRUE;
  PROCEND handle_break;
?? TITLE := 'PROCEDURE ifexec', EJECT ??

  PROCEDURE [XDCL, #GATE] ifexec (params: pmt$program_parameters;
    VAR rstatus: ost$status);

    VAR
      status: ost$status,
      bxeh: pmt$established_handler,
      block_exit_cond: pmt$condition,
      state: [STATIC] (waiting_for_started, running) := waiting_for_started,
      shutdown_received: [STATIC] boolean := FALSE,
      fatal_error: [STATIC] boolean := FALSE,
      sender_application: mlt$application_name,
      input_message: iit$general_message,
      upline_super_msg: ^iit$input_supervisory_message,
      message_length: mlt$message_length,
      message_class: mlt$arbitrary_info;

{ suspend any jobs currently running

    iip$interactive_shutdown (status);


{ Establish the typed pointer to the input message area

    upline_super_msg := #LOC (input_message);

{ Initialize the interactive executive

    initialize (status);
    IF NOT status.normal THEN
      quit;
      rstatus := status;
      RETURN;
    IFEND;

    block_exit_cond.selector := pmc$condition_combination;
    block_exit_cond.combination := $pmt$condition_combination
          [pmc$block_exit_processing];
    pmp$establish_condition_handler (block_exit_cond, ^handle_break, ^bxeh,
          status);

{ Main loop: delay, check for incoming messages, process incoming
{  messages

  /main_loop/
    REPEAT

{ Delay

{ Try to receive a message

      mlp$receive_message (iic$exec_application_name, message_class, NIL, #LOC
            (input_message), message_length, #SIZE (input_message), 0,
            sender_application, status);
      IF NOT status.normal THEN
        IF status.condition IN mli_fatal_condition THEN
          iip$report_status_error (status, 'receive');
          fatal_error := TRUE;
        IFEND;
        pmp$wait (tmc$infinite_wait, tmc$infinite_wait);
        CYCLE /main_loop/;
      IFEND;

{ A message was received - process it

      IF sender_application = iic$passon_application_name THEN
        CASE state OF
        = waiting_for_started =
          IF message_class = iic$input_supervisory_message THEN
            IF upline_super_msg^.message_type = iic$sm_interactive_started THEN
              state := running;
              pmp$log ('IF: PASSON STARTED', status);
            ELSEIF upline_super_msg^.message_type = iic$sm_start_interactive
                  THEN
{ ignore it
            ELSE
              iip$report_unhandled_super_msg (upline_super_msg^);
            IFEND;
          ELSE
            iip$report_unhandled_message (#LOC (input_message), message_class,
                  sender_application, message_length);
          IFEND;
        = running =
          CASE message_class OF
          = iic$input_supervisory_message =
            IF upline_super_msg^.message_type = iic$sm_connection_request THEN
              validate_login (upline_super_msg^, status);
              IF NOT status.normal THEN
                reject_connection (status, upline_super_msg^);
              ELSE
                start_job (upline_super_msg^, status);
                IF NOT status.normal THEN
                  reject_connection (status, upline_super_msg^);
                ELSE
                  record_login (upline_super_msg^);
                IFEND;
              IFEND;
            ELSEIF upline_super_msg^.message_type = iic$sm_logical_error THEN
              iip$report_logical_error (upline_super_msg^);
            ELSEIF upline_super_msg^.message_type = iic$sm_shutdown THEN
              IF upline_super_msg^.shutdown.immediate THEN
                shutdown_received := TRUE;
              IFEND;
            ELSEIF upline_super_msg^.message_type = iic$sm_start_interactive
                  THEN

{ react to passon restart

              pmp$log ('IF: PASSON RESTART', status);
              iip$interactive_shutdown (status);
              start_passon (status);
              IF NOT status.normal THEN
                fatal_error := TRUE;
              IFEND;
            ELSEIF upline_super_msg^.message_type = iic$sm_interactive_started
                  THEN
{ ignore it
              pmp$log ('IF: PASSON RESTART COMPLETE', status);
            ELSE
              iip$report_unhandled_super_msg (upline_super_msg^);
            IFEND;
          ELSE
            iip$report_unhandled_message (#LOC (input_message), message_class,
                  sender_application, message_length);
          CASEND;
        ELSE
        CASEND;
      ELSE
        iip$report_unhandled_message (#LOC (input_message), message_class,
              sender_application, message_length);
      IFEND;
    UNTIL shutdown_received OR fatal_error;

{ End the interactive executive

    IF fatal_error THEN
      rstatus := status;
    ELSE
      rstatus.normal := TRUE;
    IFEND;
    quit;

  PROCEND ifexec;
MODEND
*DECK DECK=IFM$INTERACTIVE_USER_FAP_SCREEN EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Interactive Facility (Dual State): FAP Screen' ??
MODULE ifm$interactive_user_fap_screen;

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$unseen_mail_condition
*copyc ife$interactive_exception_codes
*copyc ifk$keypoints
*copyc nae$internal_interactive_appl
*copyc ost$status
?? POP ??
*copyc ifp$fap_control_ring_3
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$long_term_wait

?? OLDTITLE ??
?? NEWTITLE := 'ifp$fap_control', EJECT ??

  PROCEDURE [XDCL] ifp$fap_control
    (    file_id: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      CASE condition.selector OF

      = ifc$interactive_condition =
        CASE condition.interactive_condition OF
        = ifc$pause_break =
          osp$set_status_condition (ife$pause_break_received, status);
        = ifc$terminate_break =
          osp$set_status_condition (ife$terminate_break_received, status);
        = ifc$terminal_connection_broken =
          osp$set_status_condition (ife$connection_break_disconnect, status);
        = ifc$job_reconnect =
          osp$set_status_condition (ife$terminal_reconnected_to_job, status);
        ELSE
          osp$set_status_abnormal (ifc$interactive_facility_id, 0,
                'unknown interactive condition encountered', status);
        CASEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND condition_handler;
?? OLDTITLE ??

    #KEYPOINT (osk$entry, 0, ifk$fap_control);

    osp$establish_condition_handler (^condition_handler, FALSE);

  /perform_operation/
    WHILE TRUE DO
      ifp$fap_control_ring_3 (file_id, call_block, layer_number, status);

      IF status.normal THEN
        EXIT /perform_operation/;
      ELSE
        CASE status.condition OF
        = cle$unseen_mail_condition, ife$abort_get, ife$connection_break_disconnect, ife$pause_break_received,
              ife$terminal_reconnected_to_job, ife$terminate_break_received, nae$interactive_cond_interrupt =
          pmp$long_term_wait (100,100);
          CYCLE /perform_operation/;
        ELSE
          EXIT /perform_operation/;
        CASEND;
      IFEND;
    WHILEND /perform_operation/;

    osp$disestablish_cond_handler;

    #KEYPOINT (osk$exit, 0, ifk$fap_control);

  PROCEND ifp$fap_control;

MODEND ifm$interactive_user_fap_screen
*DECK DECK=IFM$JOB_CONTROL EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ifm$job_control;
?? NEWTITLE := 'NOS/VE Interactive Facility User Job Terminal Access' ??
?? TITLE := 'Purpose and Design', EJECT ??

{  PURPOSE:
{    The purpose of this module is to provide various basic interactive
{    functions such as:
{    - initialize an interactive job
{    - terminate an interactive job
{    - process most synchronous supervisory network messages.
{    - manage disconnect and reconnect
{

?? PUSH (LISTEXT := ON) ??
*copyc amp$get_next
*copyc amp$return
*copyc amp$open
*copyc amp$close
*copyc amp$put_next
*copyc clc$standard_file_names
*copyc clp$find_current_job_synch_task
*copyc clp$get_system_file_id
*copyc clp$include_command
*copyc clp$put_job_output
*copyc oss$job_paged_literal
*copyc osv$job_pageable_heap
*copyc tmc$signal_identifiers
*copyc ift$title_for_error_codes
*copyc ifp$immediate_attribute_flush
*copyc ifk$keypoints
*copyc iit$interactive_signal_type
*copyc iit$connection_description
*copyc iip$add_sender
*copyc iip$set_lock
*copyc iip$clear_lock
*copyc iip$request_default_attributes
*copyc iip$route
*copyc i#move

  PROCEDURE [XREF] iip$discard_typed_ahead_input
    (    save: boolean);

*copyc iip$allocate_queue_entry
*copyc iip$build_data_msg_skeleton
*copyc iip$build_super_msg_skeleton
*copyc iip$convert_downline_block
*copyc iip$initialize_connection
*copyc iiv$interactive_terminated
*copyc iip$register_handler
*copyc clp$put_job_output

{*copyc jmp$get_job_internal_info

*copyc iip$receive_from_pass_on
*copyc iip$report_logical_error
*copyc iip$report_status_error
*copyc iip$report_unhandled_data_msg
*copyc iip$report_unhandled_super_msg
*copyc iip$sign_off
*copyc iip$sign_on
*copyc iip$send_output_message
*copyc iip$send_to_pass_on
*copyc iiv$int_task_open_file_count
*copyc iiv$connection_desc_ptr
*copyc iiv$output
*copyc jmv$terminal_io_disabled
*copyc jme$queued_file_conditions
*copyc pmp$long_term_wait
*copyc lgp$display_log
*copyc jmp$set_job_mode
*copyc jmp$get_job_attributes
*copyc jmp$display_job_status
*copyc pmp$continue_to_cause
*copyc pmp$disable_ts_io_in_tasks
*copyc pmp$display_active_tasks
*copyc pmp$enable_ts_io_in_tasks
*copyc pmp$get_user_identification
*copyc pmp$task_state
*copyc pmp$get_job_names
*copyc pmp$signal_all_child_tasks
*copyc osp$system_error
*copyc osp$set_status_abnormal
*copyc jmp$get_job_parameters
*copyc osp$system_error
*copyc pmp$exit
*copyc pmp$get_global_task_id
*copyc pmp$log
*copyc pmp$send_signal
*copyc pmp$establish_condition_handler
*copyc osv$job_pageable_heap
*copyc osv$170_os_type
*copyc osp$set_job_signature_lock
*copyc osp$clear_job_signature_lock
*copyc pmp$wait
*copyc mlp$force_send_message
*copyc mlp$send_message
?? POP ??

?? TITLE := 'Global Internal Type, Constant and Variable Declarations', EJECT
        ??

  TYPE
    iit$mli_status = set of mlt$status;

  VAR

{ Job Global Read/Write variables.

    iiv$reject_caused_reconnect: boolean := FALSE,
    iiv$end_job_connection,
    iiv$start_new_job,
    connection_ended: boolean := FALSE,
    connection_started: boolean := FALSE,
    connection_rejected: boolean := FALSE,
    wait_change_jm: boolean := FALSE,
    wait_hold_ack: boolean := FALSE,

{ Miscellaneous Read Only variables.

    shutdown_exit_msg: [READ, oss$job_paged_literal] string (57) :=
          'Network Shutdown - Please Do LOGOUT As Soon As Possible.',
    conend_zero2_value: [READ, oss$job_paged_literal] iit$170_display_word :=
          [0, [REP 5 of 0], [REP 5 of 0]],

{ Diagnostic Message Read Only variables.

    connection_broken_msg: [READ, oss$job_paged_literal] string (27) :=
          'Connection Broken Received.',
    immediate_shutdown_msg: [READ, oss$job_paged_literal] string (28) :=
          'Immediate Shutdown Received.',
    shutdown_warning_msg: [READ, oss$job_paged_literal] string (26) :=
          'Shutdown Warning Received.';

?? TITLE := 'PROCEDURE ifp$stop_interactive', EJECT ??

  PROCEDURE [XDCL, #GATE] ifp$stop_interactive;

{  PURPOSE:
{    The purpose of this procedure is to terminate the interactive
{    environment for the task.
{  DESIGN:
{    The connection to the terminal is ended and then a Sign Off is
{    issued to the Memory Link.
{

    VAR
      status: ost$status;

    IF connection_rejected THEN
      RETURN;
    IFEND;

{ Open up the connection to IO at job end.

    pmp$enable_ts_io_in_tasks;

    end_connection (status);

    iiv$interactive_terminated := TRUE;
    iip$sign_off (iiv$jm_application_name, status);

  PROCEND ifp$stop_interactive;

?? TITLE := 'PROCEDURE ifp$job_initialize', EJECT ??

  PROCEDURE [XDCL, #GATE] ifp$job_initialize
    (VAR status: ost$status);

{  PURPOSE:
{    The purpose of this procedure is to complete the connection to the
{    NAM so the task can access the terminal, and to sign on and register
{    the job monitor as a separate mli application.
{  DESIGN:
{    The following is done to complete the connection:
{      - Signon and register a signal handler with the mli.
{      - Send a Connection Accepted (con_req_n) message to the NAM.
{      - Receive an Initialized Connection (fc_init_r) message from the NAM.
{      - Send a Connection Initialized (fc_init_n) message to the NAM.
{

    PROCEDURE handle_condition
      (    cond: pmt$condition;
           cd: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR ch_status: ost$status);

      ch_status.normal := TRUE;

      osp$set_status_abnormal ('IF', 0, 'condition during initialization',
            status);

      EXIT ifp$job_initialize;
    PROCEND handle_condition;

    TYPE
      align_buffer = record { This is to prevent the buffer from being
            {allocated within 200 bytes of
        buffer: ALIGNED [0 MOD 200] iit$input_data_message,
              { the end of a page.
      recend;

    VAR
      iiv$job_output: [XREF] ^SEQ ( * ),
      iiv$output: [XDCL] ^SEQ ( * ) := NIL,
      job_params: jmt$system_job_parameters,
      eh: pmt$established_handler,
      pism: ^iit$input_supervisory_message,
      upline_data_buffer_p: ^align_buffer,
      queue_entry_descriptor: iit$queue_entry_descriptor,
      posm: ^iit$output_supervisory_message;


    status.normal := TRUE;

{ set up environment from connection request

    jmp$get_job_parameters (job_params, status);
    pism := #LOC (job_params.system_job_parameter);
    IF pism^.message_type <> iic$sm_connection_request THEN
      osp$system_error ('IF - bad connection req', NIL);
    IFEND;

    ALLOCATE iiv$output: [[REP 20000 OF cell]] IN osv$job_pageable_heap^;
    RESET iiv$output;
    iiv$job_output := iiv$output;
    iiv$job_connection := pism^.conreq_connection_number;
    iiv$cdcnet_connection := pism^.conreq_cdcnet_connection;
    iiv$cdcnet_connection := pism^.conreq_cdcnet_connection;

    pmp$establish_condition_handler (iiv$condition_descriptor,
          ^handle_condition, ^eh, status);
    pmp$establish_condition_handler (iiv$condition_descriptor,
          ^handle_condition, ^eh, status);

{ signon and register a handler for the job monitor task (this task).

    init_mli_environ (status);

{ skip connection stuff if this is a suspended job being reconnected.

    IF pism^.conreq_fill6 = iic$initial_job_start THEN

{ Send Connection Accepted (con_req_n) to Pass-On.

      PUSH posm;
      iip$build_super_msg_skeleton (posm, iic$sm_connection_accepted,
            iic$l_connection_accepted);

      posm^.connection_accepted.connection_number := iiv$job_connection;
      IF osv$170_os_type = osc$ot7_dual_state_nos_be THEN
        posm^.connection_accepted.character_type := iic$8_of_12_bit_characters;
      ELSE
        posm^.connection_accepted.character_type := iic$8_bit_characters;
      IFEND;
      posm^.connection_accepted.list_number := iic$min_list_number;

      iip$send_to_pass_on (iiv$jm_application_name, posm,
            (iic$l_connection_accepted + 1) * 8,
            iic$output_supervisory_message + iic$dont_signal, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Receive Initialized Connection (fc_init_r) from Pass-On.
{
{     WHILE NOT connection_started DO
{       pmp$long_term_wait (iic$user_time_delay, iic$user_time_delay);
{     WHILEND;
{
{ Send Connection Initialized (fc_init_n) to Pass-On.
{
{     iip$build_super_msg_skeleton (posm, iic$sm_connection_initialized,
{           iic$l_connection_initialized);
{
{     posm^.connection_initialized.connection_number := iiv$job_connection;
{
{     iip$send_to_pass_on (iiv$jm_application_name, posm,
{           (iic$l_connection_initialized + 1) * 8,
{           iic$output_supervisory_message, status);
{
{ connection is automatically put on a list - take it off until input
{
{     iip$build_super_msg_skeleton (posm, iic$sm_list_off, iic$l_list_off);
{
{     posm^.list_off.connection_number := iiv$job_connection;
{
{     iip$send_to_pass_on (iiv$jm_application_name, posm, (iic$l_list_off + 1)
{           * 8, iic$output_supervisory_message, status);
{
{     iip$build_super_msg_skeleton (posm, iic$sm_list_switch,
{           iic$l_list_switch);
{
{     posm^.list_switch.connection_number := iiv$job_connection;
{     posm^.list_switch.new_list_number := iic$normal_input_list_number;
{
{     iip$send_to_pass_on (iiv$jm_application_name, posm, (iic$l_list_switch +
{           1) * 8, iic$output_supervisory_message, status);
{
{     iip$build_super_msg_skeleton (posm, iic$sm_list_off, iic$l_list_off);
{
{     posm^.list_off.connection_number := iiv$job_connection;
{
{     iip$send_to_pass_on (iiv$jm_application_name, posm, (iic$l_list_off + 1)
{           * 8, iic$output_supervisory_message, status);

    ELSE
      pmp$log (' disconnect- new job begun', status);

{ switch jmtr at passon

      PUSH posm;
      iip$build_super_msg_skeleton (posm, iic$sm_change_job_monitor,
            iic$l_change_job_monitor);
      posm^.changejm_connection_number := iiv$job_connection;
      posm^.changejm_new_jm := iiv$jm_application_name;
      wait_change_jm := TRUE;
      iip$send_to_pass_on (iiv$jm_application_name, posm,
            (iic$l_change_job_monitor + 1) * 8, iic$output_supervisory_message,
            status);
      IF NOT status.normal THEN
        pmp$log (' cannot change jm - reconnect', status);
        RETURN;
      IFEND;

{ wait for change to complete

      WHILE wait_change_jm DO
        pmp$long_term_wait (iic$user_time_delay, iic$user_time_delay);
      WHILEND;
    IFEND;

{ initialize the connection

    iip$initialize_connection (pism);

{ the following call causes a read request to be issued and causes a call
{ to iip$set_default_attributes

    iip$request_default_attributes (iiv$connection_desc_ptr, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Allocate input buffer space for the job's interactive gets.

    ALLOCATE upline_data_buffer_p IN osv$job_pageable_heap^;
    iiv$upline_data_buffer_ptr := ^upline_data_buffer_p^.buffer;


  PROCEND ifp$job_initialize;
?? TITLE := 'PROCEDURE init_mli_environ', EJECT ??

  PROCEDURE init_mli_environ
    (VAR status: ost$status);

{ PURPOSE:
{   This procedure initializes the mli environment for the interactive
{   job's job monitor.


    iip$sign_on (iiv$jm_application_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    iip$register_handler (iiv$jm_application_name,
          ^iip$jm_passon_signal_handler, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    iip$add_sender (iiv$jm_application_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND init_mli_environ;

?? TITLE := 'PROCEDURE ifp$reject_connection', EJECT ??

{ PROCEDURE [XDCL, #GATE] ifp$reject_connection;

{    The purpose of this procedure is to issue a con_req_a instead
{  of a con_req_n at job begin.  This routine is called instead of
{  ifp$job_initialize, but note that ifp$stop_interactive will be
{  called eventually.

{   VAR
{     user_supplied_name: jmt$user_supplied_name,
{     system_supplied_name: jmt$system_supplied_name,
{     status_count: jmt$job_status_count,
{     status_options_p: ^jmt$job_status_options,
{     status_results_p: ^jmt$job_status_results,
{     internal_info: jmt$job_internal_information,
{     signal: pmt$signal,
{     isig: ^iit$reconnect_job,
{     job_params: jmt$system_job_parameters,
{     pism: ^iit$input_supervisory_message,
{     appl: mlt$application_name,
{     status: ost$status,
{     posm: ^iit$output_supervisory_message;

{   connection_rejected := TRUE;
{   pmp$log ('IF - connection being rejected', status);
{   jmp$get_job_parameters (job_params, status);
{   pism := #LOC (job_params.system_job_parameter);
{   IF pism^.message_type <> iic$sm_connection_request THEN
{     osp$system_error ('IF - bad connection req', NIL);
{   IFEND;

{   IF pism^.conreq_fill6 = iic$suspended_job_start THEN

{Reconnect the suspended job that created this job by ascertaining
{  the creator job's jsn, and, subsequently, his gtid.....

{     pmp$get_job_names (user_supplied_name, system_supplied_name, status);
{     IF NOT status.normal THEN
{       iip$report_status_error (status, ' get_job_names ');
{       RETURN;
{     IFEND;

{     PUSH status_options_p: [1 .. 2];
{     status_options_p^[1].key := jmc$job_name_list;
{     PUSH status_options_p^[1].job_name_list: [1 .. 1];
{     status_options_p^[1].job_name_list^[1].kind := jmc$system_supplied_name;
{     status_options_p^[1].job_name_list^[1].system_supplied_name :=
{     system_supplied_name;
{     status_options_p^[2].key := jmc$job_state_set;
{     status_options_p^[2].job_state_set := $jmt$job_state_set
{     [jmc$initiated_job];

{     PUSH status_results_p: [1 .. 1];
{     PUSH status_results_p^[1]: [1 .. 1];
{     status_results_p^[1]^[1].key := jmc$job_originator_ssn;

{     jmp$get_job_status (status_options_p, status_results_p, status_count,
{     status);
{     IF NOT status.normal THEN
{       iip$report_status_error (status, ' get_job_status');
{       RETURN;
{     IFEND;

{     jmp$get_job_internal_info (status_results_p^[1]^[1].job_originator_ssn,
{           internal_info, status);
{     IF NOT status.normal THEN
{       iip$report_status_error (status, ' get_job_internal_info');
{       RETURN;
{     IFEND;

{.....so that a signal can be built and sent to reconnect the creator job.

{     signal.identifier := ifc$signal_id;
{     isig := #LOC (signal.contents);
{     isig^.sig := iic$reconnect_job;
{     isig^.acn := pism^.conreq_connection_number;
{     isig^.reject_caused_reconnect := TRUE;
{     pmp$send_signal (internal_info.jmtr_global_taskid, signal, status);
{     IF NOT status.normal THEN
{       iip$report_status_error (status, ' send_signal');
{       RETURN;
{     IFEND;

{   ELSE
{     iip$sign_on (appl, status);
{     IF NOT status.normal THEN
{       osp$system_error ('IF - reject signon', ^status);
{     IFEND;

{     PUSH posm;
{     iip$build_super_msg_skeleton (posm, iic$sm_connection_rejected,
{           iic$l_connection_rejected);
{     posm^.connection_rejected.connection_number := pism^.
{           conreq_connection_number;
{     posm^.connection_rejected.reason := iic$unspecified_reject;
{     iip$send_to_pass_on (appl, posm, (iic$l_connection_rejected + 1) * 8,
{           iic$output_supervisory_message, status);
{     IF NOT status.normal THEN
{       osp$system_error ('IF - send reject', ^status);
{     IFEND;

{     iip$sign_off (appl, status);
{   IFEND;

{ PROCEND ifp$reject_connection;

?? TITLE := 'PROCEDURE handle_upline_supervisory', EJECT ??

  PROCEDURE handle_upline_supervisory
    (    pism: ^iit$input_supervisory_message;
     VAR status: ost$status);

{  PURPOSE:
{    The purpose of this procedure is to handle an upline supervisory
{    message that has been received by the "user" task from the NAM.
{  DESIGN:
{    Upline Supervisory messages are handled as follows:
{    Read rejected
{      pause and continue
{
{    All Others
{      Report on the unexpected message.
{      Return an abnormal status in order to cause the task to terminate.
{


{ Pause and retry if read request was rejected by passon.

    IF pism^.message_type = iic$sm_read_rejected THEN
      pmp$long_term_wait (iic$user_time_delay, iic$user_time_delay);
    ELSE
      report_unexpected_message (pism);
      status.normal := FALSE;
    IFEND;

  PROCEND handle_upline_supervisory;

?? TITLE := 'PROCEDURE end_connection', EJECT ??

  PROCEDURE end_connection
    (VAR status: ost$status);

{  PURPOSE:
{    The purpose of this procedure is to terminate the interactive
{    job's connection to the terminal.
{  DESIGN:
{    The following is done to terminate the connection to the terminal:
{      - Send an End Connection (con_end_r) to the NAM.
{      - Receive a Connection Ended (con_end_n) from the NAM.
{

    VAR
      appl: mlt$application_name,
      i: integer,
      posm: ^iit$output_supervisory_message;


{ Send End Connection (con_end_r) to Pass-On.

    IF connection_ended THEN
      status.normal := TRUE;
      RETURN;
    IFEND;

    iip$sign_on (appl, status);
    IF NOT status.normal THEN
      log_message ('IF - CON/END/R application failed to signon');
      RETURN;
    IFEND;
    iip$add_sender (appl, status);
    IF NOT status.normal THEN
      log_message ('IF - CON/END/R application failed to add_sender');
      RETURN;
    IFEND;

    PUSH posm;
    iip$build_super_msg_skeleton (posm, iic$sm_end_connection,
          iic$l_end_connection);
    posm^.conend_zero1 := 0;
    posm^.conend_connection_number := iiv$job_connection;
    posm^.conend_zero2 := conend_zero2_value;
    posm^.conend_fill1 := 0;
    connection_ended := FALSE;
    iip$send_to_pass_on (appl, posm, (iic$l_end_connection + 1) * 8,
          iic$output_supervisory_message, status);
    IF NOT status.normal THEN
      log_message ('IF - CON/END/R failed to be sent to PASSON');
      RETURN;
    IFEND;
    iip$sign_off (appl, status);
    IF NOT status.normal THEN
      log_message ('IF - CON/END/R application failed to signoff');
      RETURN;
    IFEND;

{ Wait for a Connection Ended (con_end_n) from Pass-On.

{Due to an absurd number of problems with this code, only wait (about) 10
{seconds
{for the connection to end - then continue as if it had

    FOR i := 1 TO 10 DO
      IF NOT connection_ended THEN
        pmp$long_term_wait (iic$user_time_delay, iic$user_time_delay);
      IFEND;
    FOREND;
    IF NOT connection_ended THEN
      connection_ended := TRUE;
      log_message ('End connection response never received');
    IFEND;

  PROCEND end_connection;


?? TITLE := 'PROCEDURE report_unexpected_message', EJECT ??

  PROCEDURE report_unexpected_message
    (    p: ^cell);

{  PURPOSE:
{    The purpose of this procedure is to report unexpected upline
{    supervisory and upline data messages that are received from the
{    Pass-On.
{

    VAR
      pism: ^iit$input_supervisory_message,
      pidm: ^iit$input_data_message;

    pism := p;
    pidm := p;

    IF pism^.header.block_type = iic$supervisory_block THEN
      iip$report_unhandled_super_msg (pism^);
      IF pism^.message_type = iic$sm_logical_error THEN
        iip$report_logical_error (pism^);
      IFEND;
    ELSE
      iip$report_unhandled_data_msg (pidm^);
    IFEND;

  PROCEND report_unexpected_message;

?? TITLE := 'PROCEDURE log_message', EJECT ??

  PROCEDURE log_message
    (    message: string ( * ));

{  PURPOSE:
{    The purpose of this procedure is to put a message into the job's
{    log so that it will be printed when the interactive job terminates.
{

    VAR
      status: ost$status;

    pmp$log (message, status);

  PROCEND log_message;

?? TITLE := 'PROCEDURE iip$jm_passon_signal_handler', EJECT ??

  PROCEDURE iip$jm_passon_signal_handler
    (    signalee: mlt$application_name;
         signaler: mlt$signaler_application_info;
         signal: mlt$signal;
     VAR status: ost$status);

    PROCEDURE respond_to_user_interrupt;

{ Build and send a INTR/RSP/R to PASSON.  This signals to the network that the
{ current interrupt has been acknowledged and another interrupt can be
{ received.

      iip$build_super_msg_skeleton (#LOC (osm), iic$sm_interrupt_response,
            iic$l_interrupt_response);
      osm.interrupt_response.alpha := $CHAR (0);
      osm.interrupt_response.connection_number := iiv$job_connection;
      osm.interrupt_response.fill1 := 0;
      iip$send_to_pass_on (iiv$jm_application_name, #LOC (osm),
            (iic$l_interrupt_response + 1) * 8, iic$output_supervisory_message,
            status);
      IF NOT status.normal THEN
        iip$report_status_error (status, 'send to passon');
      IFEND;
    PROCEND respond_to_user_interrupt;

    VAR
      display_option_selection: lgt$display_option_selection,
      flush_fid: amt$file_identifier,
      job_name: clt$data_value,
      job_name_p: ^jmt$job_attribute_results,
      ml: mlt$message_length,
      long_wait: boolean,
      old_task_break_level: integer,
      osm: iit$output_supervisory_message,
      message: string (2),
      ism: iit$input_supervisory_message;

    CASE signal^.direction OF
    = mlc$receive =
    = mlc$send =

{ Get message from passon.

      iip$receive_from_pass_on (iiv$jm_application_name, #LOC (ism),
            #SIZE (ism), ml, status);
      IF NOT status.normal THEN
        iip$report_status_error (status, 'jm sh mli');
        RETURN;
      IFEND;
      IF ism.header.block_type <> iic$supervisory_block THEN
        report_unexpected_message (^ism);
        RETURN;
      IFEND;
      status.normal := TRUE;

{ If the task is terminating only process a con_end_n message.

      IF pmp$task_state () > pmc$task_active THEN
        IF ism.message_type <> iic$sm_connection_ended THEN
          IF ism.message_type = iic$sm_interrupt_user THEN

{ Send a user-interrupt response to the network but do not
{ process the interrupt.

            log_message ('User interrupt ignored');
            respond_to_user_interrupt;
          IFEND;
          EXIT iip$jm_passon_signal_handler;
        IFEND;
      IFEND;

{ Handle Connection Broken (con_cb_r).

      IF ism.message_type = iic$sm_connection_broken THEN
        IF connection_started THEN
          log_message (connection_broken_msg);
          iip$disconnect_job (iic$end_connection, iic$dont_start_new_job,
                status);
        ELSE
          pmp$log (' Connection-Broken received before job initialized',
                status);
          iiv$abort_job_initialization := TRUE;
        IFEND;

{ Handle Shutdown (shut_insd_r).

      ELSEIF ism.message_type = iic$sm_shutdown THEN
        IF ism.shutdown.immediate THEN
          log_message (immediate_shutdown_msg);
        ELSE
          log_message (shutdown_warning_msg);
        IFEND;

{ Handle Terminal Break (fc_brk_r) .

      ELSEIF ism.message_type = iic$sm_break THEN

{ unsupported break - log and continue

        report_unexpected_message (^ism);

{ Send Reset Connection (fc_rst_r) to Pass-On.

        iip$build_super_msg_skeleton (#LOC (osm), iic$sm_reset_connection,
              iic$l_reset_connection);
        osm.reset_connection.connection_number := iiv$job_connection;

        iip$send_to_pass_on (iiv$jm_application_name, #LOC (osm),
              (iic$l_reset_connection + 1) * 8, iic$output_supervisory_message,
              status);
        RETURN;

{ Handle start output (fc_strt_r)

      ELSEIF ism.message_type = iic$sm_start_output THEN

{ Send Reset Connection (fc_rst_r) to Pass-On.

        iip$build_super_msg_skeleton (#LOC (osm), iic$sm_reset_connection,
              iic$l_reset_connection);
        osm.reset_connection.connection_number := iiv$job_connection;

        iip$send_to_pass_on (iiv$jm_application_name, #LOC (osm),
              (iic$l_reset_connection + 1) * 8, iic$output_supervisory_message,
              status);

{ Handle Connection Ended (con_end_n).

      ELSEIF ism.message_type = iic$sm_connection_ended THEN
        connection_ended := TRUE;

{ Handle initialize connection (fc_init_r).

      ELSEIF ism.message_type = iic$sm_initialized_connection THEN
        connection_started := TRUE;

{ Handle inactive connection.

      ELSEIF (ism.message_type = iic$sm_inactive_connection) OR
            (ism.message_type = iic$sm_term_char_changed) THEN

      ELSEIF ism.message_type = iic$sm_interrupt_user THEN

        CASE ism.interrupt_user.alpha OF
        = $CHAR (3) =
          log_message ('Pause break received');
          iiv$break_abn := 0;
          iiv$break_reason := iic$user_break_1;
          raise_condition (iic$pause_break);
        = $CHAR (4) =
          log_message ('Terminate break received');
          iiv$break_abn := 0;
          iiv$break_reason := iic$user_break_2;
          raise_condition (iic$terminate_break);
        ELSE
          IF NOT iiv$job_suspended THEN

            message (1) := $CHAR (10);
            message (2) := $CHAR (13);
            IF NOT jmv$terminal_io_disabled THEN
              CASE ism.interrupt_user.alpha OF
              = 'L', 'l' =
                display_option_selection.display_options := lgc$count;
                display_option_selection.count := 10;
                lgp$display_log (clc$display_job_log, display_option_selection,
                      ':$LOCAL.OUTPUT.1', status);
                clp$put_job_output (message, status);
              = 'A', 'a' =
                pmp$display_active_tasks (':$LOCAL.OUTPUT.1', status);
                clp$put_job_output (message, status);
              = 'J', 'j' =
                job_name.kind := clc$keyword;
                job_name.keyword_value := 'ALL';
                jmp$display_job_status (':$LOCAL.OUTPUT.1',
                      $jmt$attribute_keys_set [jmc$cpu_time_used,
                      jmc$display_message, jmc$job_state, jmc$page_faults,
                      jmc$system_job_name], job_name, status);
                clp$put_job_output (message, status);
              = 'T', 't' =
                iip$discard_typed_ahead_input (FALSE);
              = 'D', 'd' =
                iip$disconnect_job (iic$dont_end_connection, iic$start_new_job,
                      status);
              = 'X', 'x' =
                ;
              ELSE
                job_name.kind := clc$name;
                PUSH job_name_p: [1 .. 1];
                job_name_p^ [1].key := jmc$system_job_name;
                jmp$get_job_attributes (job_name_p, status);
                job_name.name_value := job_name_p^ [1].system_job_name;
                jmp$display_job_status (':$LOCAL.OUTPUT.1',
                      $jmt$attribute_keys_set [jmc$cpu_time_used,
                      jmc$display_message, jmc$page_faults], job_name, status);
                clp$put_job_output (message, status);
              CASEND;
            IFEND;

            CASE ism.interrupt_user.alpha OF
            = 'X', 'x' =
              osp$set_status_abnormal ('JM', jme$user_requested_exit, '',
                    status);
              pmp$exit (status);
            ELSE
            CASEND;

{ send intr/resp here for all other user-interrupts

            respond_to_user_interrupt;

{ Flush output with wait

            clp$get_system_file_id (clc$job_output, flush_fid, status);
            IF NOT status.normal THEN
            RETURN;
            IFEND;
            ifp$immediate_attribute_flush (flush_fid,status);
            IF NOT status.normal THEN
            RETURN;
            IFEND;

{ restore task break level

          ELSE {job_suspended}
            respond_to_user_interrupt;
          IFEND; {job_suspended}
        CASEND;

      ELSEIF ism.message_type = iic$sm_absentee_begun THEN
      ELSEIF ism.message_type = iic$sm_job_monitor_changed THEN
        wait_change_jm := FALSE;
      ELSEIF ism.message_type = iic$sm_hold_acknowlege THEN
        wait_hold_ack := FALSE;
      ELSE

        report_unexpected_message (^ism);
        status.normal := FALSE;
      IFEND;
    ELSE
    CASEND;

  PROCEND iip$jm_passon_signal_handler;
?? TITLE := 'PROCEDURE raise_condition', EJECT ??

  PROCEDURE raise_condition
    (    condition: iit$interactive_signal);

    VAR
      psig: ^iit$interactive_signal,
      tid: pmt$task_id,
      local_signal: pmt$signal,
      status: ost$status;


{ signal task that will handle break

{ disable IO in the job.

    pmp$disable_ts_io_in_tasks;

    psig := #LOC (local_signal.contents);
    local_signal.identifier := ifc$signal_id;
    psig^ := condition;
    clp$find_current_job_synch_task (tid, status);
    IF NOT status.normal THEN
      iip$report_status_error (status, ' find current synch task');
    IFEND;
    pmp$get_global_task_id (tid, iiv$task_handling_break, status);
    IF NOT status.normal THEN
      iip$report_status_error (status, ' get global tid');
    IFEND;
    pmp$send_signal (iiv$task_handling_break, local_signal, status);
    IF NOT status.normal THEN
      iip$report_status_error (status, ' send break signal');

{ try a second time before giving up

      clp$find_current_job_synch_task (tid, status);
      IF NOT status.normal THEN
        iip$report_status_error (status, ' find current synch task');
      IFEND;
      pmp$get_global_task_id (tid, iiv$task_handling_break, status);
      IF NOT status.normal THEN
        iip$report_status_error (status, ' get global tid');
      IFEND;
      pmp$send_signal (iiv$task_handling_break, local_signal, status);
    IFEND;
    IF NOT status.normal THEN
      iip$report_status_error (status, 'send break signal');
      iiv$task_handling_break := iiv$job_monitor_task_id;
      pmp$log ('IF couldnt find break task', status);
      pmp$send_signal (iiv$task_handling_break, local_signal, status);
    IFEND;
  PROCEND raise_condition;
?? TITLE := 'PROCEDURE iip$disconnect_job', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$disconnect_job
    (    end_job_connection: boolean;
         start_new_job: boolean;
     VAR status: ost$status);

    log_message ('Job being disconnected');
    iiv$end_job_connection := end_job_connection;
    iiv$start_new_job := start_new_job;
    raise_condition (iic$terminal_disconnect);
    status.normal := TRUE;

  PROCEND iip$disconnect_job;

?? TITLE := 'PROCEDURE iip$complete_disconnect', EJECT ??

  PROCEDURE [XDCL] iip$complete_disconnect;

    VAR
      job_parameters: jmt$system_job_parameters,
      pism: ^iit$input_supervisory_message,
      posm: ^iit$output_supervisory_message,
      user_id: ost$user_identification,
      user_supplied_job_name: jmt$user_supplied_name,
      system_supplied_job_name: jmt$system_supplied_name,
      i: integer,
      appl: mlt$application_name,
      status,
      lst: ost$status;

    status.normal := TRUE;
    IF iiv$job_suspended THEN
      pmp$log (' disconnect in suspended job', status);
      RETURN;
    IFEND;

    iiv$job_suspended := TRUE;

    IF (NOT iiv$end_job_connection) AND (NOT iiv$start_new_job) THEN
      jmp$set_job_mode (jmc$interactive_sys_disconnect, status);
    IFEND;

    IF iiv$end_job_connection THEN
      pmp$log (' job suspended due to terminal disconnect', status);
      end_connection (status);
      jmp$set_job_mode (jmc$interactive_line_disconnect, status);
    IFEND;

    IF iiv$start_new_job THEN
      jmp$set_job_mode (jmc$interactive_cmnd_disconnect, status);

      iip$sign_on (appl, status);
      IF NOT status.normal THEN
      IFEND;
      iip$add_sender (appl, status);
      IF NOT status.normal THEN
        iip$sign_off (appl, status);
      IFEND;

{ idle the connection at passon, then start new job (which will skip the
{ connection sequence).

      PUSH pism;
      PUSH posm;
      iip$build_super_msg_skeleton (#LOC (posm^), iic$sm_hold, iic$l_hold);
      posm^.hold.connection_number := iiv$job_connection;
      wait_hold_ack := TRUE;
      iip$send_to_pass_on (appl, posm, (iic$l_hold + 1) * 8,
            iic$output_supervisory_message, status);
      iip$sign_off (appl, status);
      WHILE wait_hold_ack DO
        pmp$long_term_wait (iic$user_time_delay, iic$user_time_delay);
      WHILEND;

      jmp$get_job_parameters (job_parameters, status);
      pism := #LOC (job_parameters.system_job_parameter);
      IF pism^.message_type <> iic$sm_connection_request THEN
        osp$system_error ('IF - bad connection req', NIL);
      IFEND;


      pism^.conreq_fill6 := iic$suspended_job_start;
      pism^.conreq_connection_number := iiv$job_connection;

      pmp$get_user_identification (user_id, status);
      pmp$get_job_names (user_supplied_job_name, system_supplied_job_name,
            status);

      iip$route (user_id, user_supplied_job_name, job_parameters, status);
      IF NOT status.normal THEN
        iip$report_status_error (status, 'route suspended');
        iip$reconnect_job (iiv$job_connection, TRUE);
        RETURN;
      IFEND;
      pmp$log (' new (suspended) job routed', status);
    IFEND;
    connection_ended := TRUE;

  PROCEND iip$complete_disconnect;
?? TITLE := 'PROCEDURE iip$end_dr_job', EJECT ??

  PROCEDURE [XDCL] iip$end_dr_job
    (    status: ost$status);

{  PURPOSE:
{    To end an interactive job without ending the connection or generating
{    any more output.


{ cause all output/input generated from now on to be thrown away

    iiv$interactive_terminated := TRUE;
    iiv$job_suspended := FALSE;
    connection_ended := TRUE;

    pmp$exit (status);

  PROCEND iip$end_dr_job;
?? TITLE := 'PROCEDURE iip$terminate_disconnected_job', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$terminate_disconnected_job;

{  PURPOSE:
{    To terminate an interactive job that has been suspended.  Consequently,
{    any output to the disconnected job will be discarded.

    VAR
      status: ost$status,
      posm: ^iit$output_supervisory_message;

    iiv$interactive_terminated := TRUE;

  /loop/
    BEGIN
      IF iiv$job_suspended THEN
        iiv$job_suspended := FALSE;
      ELSEIF iiv$end_job_connection THEN
        PUSH posm;
        iip$build_super_msg_skeleton (#LOC (posm^), iic$sm_terminate,
              iic$l_terminate);
        posm^.terminate.connection_number := iiv$job_connection;
        REPEAT
          mlp$send_message (iiv$jm_application_name,
                iic$output_supervisory_message, NIL, posm,
                (iic$l_terminate + 1) * 8, iic$passon_application_name,
                status);
          IF NOT status.normal THEN
            IF (status.condition = mlc$receiver_not_signed_on) OR
                  (status.condition = mlc$sender_not_signed_on) THEN
              EXIT /loop/;
            ELSEIF status.condition = mlc$prior_msg_not_received THEN
              pmp$wait (1000, 1000);
              mlp$force_send_message (iiv$jm_application_name,
                    iic$output_supervisory_message, NIL, posm,
                    (iic$l_terminate + 1) * 8, iic$passon_application_name,
                    status);
              IF NOT status.normal THEN
                IF (status.condition = mlc$receiver_not_signed_on) OR
                      (status.condition = mlc$sender_not_signed_on) THEN
                  EXIT /loop/;
                ELSE
                  pmp$wait (1000, 1000);
                IFEND;
              IFEND;
            ELSE
              pmp$wait (1000, 1000);
            IFEND;
          IFEND;
        UNTIL status.normal;
      IFEND;
    END /loop/;

{ Open up the connection to allow all tasks to do IO.

    pmp$enable_ts_io_in_tasks;

  PROCEND iip$terminate_disconnected_job;
?? TITLE := 'PROCEDURE iip$reconnect_job', EJECT ??

  PROCEDURE [XDCL] iip$reconnect_job
    (    acn: iit$application_connection_num;
         reject_caused_reconnect: boolean);

    log_message ('Job being reconnected');
    iiv$job_connection := acn;
    connection_ended := FALSE;
    iiv$connection_desc_ptr^.connection_number := acn;
    iiv$reject_caused_reconnect := reject_caused_reconnect;
    raise_condition (iic$terminal_reconnect);

  PROCEND iip$reconnect_job;
?? TITLE := 'PROCEDURE iip$complete_reconnect', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$complete_reconnect;

    VAR
      ost,
      status: ost$status,
      posm: ^iit$output_supervisory_message,
      signal: pmt$signal,
      i: integer,
      appl: mlt$application_name,
      isig: ^iit$interactive_signal;

{ switch jmtr at passon

    iip$sign_on (appl, status);
    IF NOT status.normal THEN
    IFEND;
    iip$add_sender (appl, status);
    IF NOT status.normal THEN
      iip$sign_off (appl, status);
    IFEND;
    PUSH posm;
    iip$build_super_msg_skeleton (posm, iic$sm_change_job_monitor,
          iic$l_change_job_monitor);
    posm^.changejm_connection_number := iiv$job_connection;
    posm^.changejm_new_jm := iiv$jm_application_name;
    wait_change_jm := TRUE;
    iip$send_to_pass_on (appl, posm, (iic$l_change_job_monitor + 1) * 8,
          iic$output_supervisory_message, status);
    iip$sign_off (appl, ost);
    IF NOT status.normal THEN
      pmp$log (' cannot change jm - reconnect', status);
      RETURN;
    IFEND;

{ wait for change to complete

    WHILE wait_change_jm DO
      pmp$long_term_wait (iic$user_time_delay, iic$user_time_delay);
    WHILEND;

{ this job now owns the terminal

    jmp$set_job_mode (jmc$interactive_connected, status);

    IF NOT iiv$reject_caused_reconnect THEN

{ force current terminal attributes to be reset (except for terminal class

      iip$set_lock (iiv$connection_desc_ptr^.lock, osc$wait, status);
      FOR i := iic$key_user_break_1 TO iic$key_trans_mode_delim_char DO
        IF iiv$connection_desc_ptr^.term_char_values [i] < 0ff(16) THEN
          iiv$connection_desc_ptr^.term_char_values [i] :=
                iiv$connection_desc_ptr^.term_char_values [i] + 1;
        ELSE
          iiv$connection_desc_ptr^.term_char_values [i] := 1;
        IFEND;
        IF iiv$connection_desc_ptr^.active_term_char_values [i] < 0ff(16) THEN
          iiv$connection_desc_ptr^.active_term_char_values [i] :=
                iiv$connection_desc_ptr^.active_term_char_values [i] + 1;
        ELSE
          iiv$connection_desc_ptr^.active_term_char_values [i] := 1;
        IFEND;
      FOREND;
      iip$clear_lock (iiv$connection_desc_ptr^.lock, status);
    IFEND;

    iiv$job_suspended := FALSE;
    IF iiv$reject_caused_reconnect THEN
      iiv$reject_caused_reconnect := FALSE;
      clp$put_job_output (
            ' New job connection aborted--original job reconnecting', status);
    IFEND;


  PROCEND iip$complete_reconnect;
?? TITLE := 'PROCEDURE iip$timeout_suspended_job', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$timeout_suspended_job;

    VAR
      status: ost$status;

    pmp$log ('IF: disconnected job timeout and exit', status);
    osp$set_status_abnormal (ifc$interactive_facility_id,
          ife$disconnected_job_timeout, '', status);
    iip$end_dr_job (status);
  PROCEND iip$timeout_suspended_job;
?? TITLE := 'PROCEDURE iip$process_reconnect_request', EJECT ??

  PROCEDURE [XDCL] iip$process_reconnect_request
    (    gtid: ost$global_task_id);

    VAR
      prs: ^iit$reconnect_job,
      signal: pmt$signal,
      posm: ^iit$output_supervisory_message,
      status: ost$status;

    PUSH posm;
    iip$build_super_msg_skeleton (#LOC (posm^), iic$sm_hold, iic$l_hold);
    posm^.hold.connection_number := iiv$job_connection;
    wait_hold_ack := TRUE;
    iip$send_to_pass_on (iiv$jm_application_name, posm, (iic$l_hold + 1) * 8,
          iic$output_supervisory_message, status);
    WHILE wait_hold_ack DO
      pmp$long_term_wait (iic$user_time_delay, iic$user_time_delay);
    WHILEND;
    signal.identifier := ifc$signal_id;
    prs := #LOC (signal.contents);
    prs^.acn := iiv$job_connection;
    prs^.sig := iic$reconnect_job;
    prs^.reject_caused_reconnect := FALSE;
    pmp$send_signal (gtid, signal, status);
    IF NOT status.normal THEN
      iip$report_status_error (status, 'send reconnect signal');
    ELSE
      osp$set_status_abnormal (ifc$interactive_facility_id,
            ife$terminal_reconnected_other, '', status);
      iip$end_dr_job (status);
    IFEND;
  PROCEND iip$process_reconnect_request;

MODEND ifm$job_control;
*DECK DECK=IFM$PURGE_CONNECTION_IO EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Interactive Facility: Purge outstanding interactive i/o', EJECT ??
MODULE ifm$purge_connection_io;

{ PURPOSE:
{   This module contains the procedure which causes the purging of all
{   i/o outstanding on the network for a dual state interactive job.
{
{ DESIGN:
{   The single procedure in this module interfaces with NAM via PASSON
{   and directs NAM to 'throw away' any input/output queued between the
{   terminal and PASSON.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ifk$keypoints
*copyc iiv$interactive_terminated
*copyc iiv$int_task_open_file_count
?? POP ??
*copyc iip$build_super_msg_skeleton
*copyc iip$report_status_error
*copyc iip$send_to_pass_on

?? TITLE := 'ifp$purge_connection_io', EJECT ??
*copy ifh$purge_connection_io

  PROCEDURE [XDCL] ifp$purge_connection_io (VAR status: ost$status);

    VAR
      output_supervisory_message: iit$output_supervisory_message,
      local_status: ost$status;


{ Build and send a FC/BRK/R supervisory message to NAM via PASSON.

    iip$build_super_msg_skeleton (^output_supervisory_message,
          iic$sm_break, iic$l_break);

    output_supervisory_message.break.connection_number := iiv$job_connection;

    iip$send_to_pass_on (iiv$int_application_name,
          #LOC (output_supervisory_message), (iic$l_break + 1) * 8,
          iic$output_supervisory_message, status);
    IF NOT status.normal THEN
      iip$report_status_error (status, ' IFP$PURGE_CONNECTION');
    IFEND;
  PROCEND ifp$purge_connection_io;
MODEND ifm$purge_connection_io;
*DECK DECK=IFM$SEND_ATTRIBUTE_KLUDGE EXPAND=TRUE
MODULE ifm$send_attribute_kludge;
?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc iit$connection_description
*copyc iiv$int_task_open_file_count
*copyc iip$build_super_msg_skeleton
*copyc iip$convert_downline_term_char
*copyc iiv$interactive_terminated
*copyc iip$send_to_pass_on
*copyc iip$sign_on
*copyc iip$sign_off
?? POP ??

  PROCEDURE [XDCL, #GATE] ifp$send_attribute_kludge (attrs: ^array [ * ] OF
    record
          fn,
          fv: 0 .. 0ff(16),
    recend;
    VAR status: ost$status);

    VAR
      ost: ost$status,
      term_char_message_length: mlt$message_length,
      appln: mlt$application_name,
      define_term_char_message: iit$output_data_message,
      osm: iit$output_supervisory_message,
      i,
      j: integer;

    status.normal := TRUE;
    iip$build_super_msg_skeleton (^osm, iic$sm_define_term_char, 0);
    osm.header.address := iiv$job_connection;
    osm.header.character_type := iic$8_bit_characters;
    osm.header.block_number := 1;

    j := 1;
    FOR i := LOWERBOUND (attrs^) TO UPPERBOUND (attrs^) DO
      osm.define_term_char.term_char_string [j].field_number := attrs^ [i].fn;
      osm.define_term_char.term_char_string [j].field_value := attrs^ [i].fv;
      j := j + 1;
    FOREND;
    IF j > 1 THEN
      osm.header.text_length := (j - 1) * 2 + 2;

{ Convert the define terminal characteristics message to C170 NAM format.

      iip$convert_downline_term_char (#LOC (osm), #LOC
            (define_term_char_message), iic$l_define_term_char * 8,
            term_char_message_length);

{ Send the define terminal characteristics message to Pass-On.

      iip$sign_on (appln, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      iip$send_to_pass_on (appln, #LOC (define_term_char_message),
            term_char_message_length, iic$output_data_message +
            iiv$job_connection, status);
      iip$sign_off (appln, ost);
    IFEND;
  PROCEND ifp$send_attribute_kludge;
MODEND
*DECK DECK=IFM$SEND_INTERRUPT_CONDITION EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
??
FMT (FORMAT := ON, keyw := upper, ident := lower) ??
?? SET (LISTCTS := OFF) ??
MODULE ifm$send_interrupt_condition;

{
{   The purpose of this module is to process the request to send an interactive
{ interrupt condition to a task.
{

?? PUSH (LISTEXT := ON) ??
*copyc tmc$signal_identifiers
*copyc iit$interactive_signal_type
*copyc osp$set_status_abnormal
*copyc pmc$program_management_id
*copyc pme$execution_exceptions
*copyc pme$unknown_recipient_task
*copyc pmp$get_global_task_id
*copyc pmp$send_signal
?? POP ??
?? TITLE := 'IFP$SEND_INTERRUPT_CONDITION', EJECT ??
*copyc ifh$send_interrupt_condition

  PROCEDURE [XDCL, #GATE] ifp$send_interrupt_condition (task_id: pmt$task_id;
    VAR status: ost$status);

    VAR
      signal: pmt$signal,
      global_task_id: ost$global_task_id,
      local_status: ost$status;

    IF (task_id < LOWERVALUE (task_id)) OR (task_id > UPPERVALUE (task_id)) THEN
      osp$set_status_abnormal (pmc$program_management_id, pme$invalid_task_id, '', local_status)
    ELSE
      pmp$get_global_task_id (task_id, global_task_id, local_status);
    IFEND;

    IF local_status.normal THEN
      signal.identifier := ifc$signal_id;
      signal.contents [1] := $INTEGER (iic$interrupt);
      pmp$send_signal (global_task_id, signal, local_status);
      IF NOT local_status.normal AND (local_status.condition = pme$unknown_recipient_task) THEN
        osp$set_status_abnormal (pmc$program_management_id, pme$unknown_task_id, '', local_status);
      IFEND;
    IFEND;

    status := local_status;
  PROCEND ifp$send_interrupt_condition;
MODEND ifm$send_interrupt_condition;
*DECK DECK=IFM$STORE_CONTEXT EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE ifm$store_context;
?? TITLE := 'MODULE ifm$store_context' ??

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc iip$store_context
*copyc ift$store_context_attributes
*copyc nat$data_fragments
*copyc OST$STATUS
?? POP ??

?? NEWTITLE := 'PROCEDURE ifp$store_context', EJECT ??

  PROCEDURE [XDCL, #GATE] ifp$store_context (file_id: amt$file_identifier;
        context_attributes: ift$store_context_attributes;
    VAR status: ost$status);

    status.normal := TRUE;

    iip$store_context (file_id, context_attributes, status);

  PROCEND ifp$store_context;

MODEND ifm$store_context;
*DECK DECK=IFM$STORE_TERM_CONN_ATTRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE ifm$store_term_conn_attributes;

{ MODULE DECK IFMST }
*copyc AMH$ALSO

?? TITLE := 'NOS/VE :  BASIC ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] IFP$STORE_TERM_CONN_ATTRIBUTES' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc IFK$KEYPOINTS
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc OST$CALLER_IDENTIFIER
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? POP ??
?? EJECT ??
*copyc IFH$STORE_TERMINAL

  PROCEDURE [XDCL, #GATE] ifp$store_term_conn_attributes (file_identifier:
    amt$file_identifier;
        terminal_attributes: ift$connection_attributes;
    VAR status: ost$status);


    CONST
      interface_name = 'IFP$STORE_TERM_CONN_ATTRIBUTES',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry,
      store_attributes: ^ift$connection_attributes;


    #KEYPOINT (osk$entry, file_identifier.ordinal * osk$m, ifk$store_term_conn_attributes);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      RETURN;
    IFEND;

    call_block.operation := ifc$store_terminal_req;

    PUSH store_attributes: [LOWERBOUND (terminal_attributes) .. UPPERBOUND
          (terminal_attributes)];
    store_attributes^ := terminal_attributes;
    call_block.store_terminal.terminal_attributes := store_attributes;

*copy bai$call_fap_control

    IF bam_status.normal THEN
      #KEYPOINT (osk$exit, 0, ifk$store_term_conn_attributes);
    ELSE
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF bam_status.normal THEN
        #KEYPOINT (osk$exit, 0, ifk$store_term_conn_attributes);
      ELSE
        status := bam_status;
        #KEYPOINT (osk$exit, 0, ifk$store_term_conn_attributes);
      IFEND;
    IFEND;
  PROCEND ifp$store_term_conn_attributes;
MODEND ifm$store_term_conn_attributes;
*DECK DECK=IFM$ST_FAP_CONTROL EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ifm$st_fap_control;
?? TITLE := 'MODULE ifm$st_fap_control' ??
*copyc AME$DEVICE_CLASS_VALIDATION
*copyc AME$OPEN_VALIDATION_ERRORS
*copyc AMP$ACCESS_METHOD
*copyc AMP$FETCH_FAP_POINTER
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc AMP$STORE_FAP_POINTER
*copyc AMT$FAP_POINTER
*copyc AMT$SKIP_OPTION
*copyc AMT$TERM_OPTION
*copyc bat$task_file_table
*copyc bav$last_tft_entry
*copyc bav$task_file_table
*copyc IFP$MARK_ATTRIBUTES_CHANGE
*copyc ife$error_codes
*copyc IIP$ALLOCATE_QUEUE_ENTRY
*copyc IIP$CHECK_FOR_CONDITION
*copyc IIP$CHECK_IF_STATUS
*copyc IIP$FETCH_ACCESS_INFORMATION
*copyc IIP$FETCH_TERM_CONN_ATTRIBUTES
*copyc IIP$FREE_QUEUE_ENTRY
*copyc IIP$REPORT_STATUS_ERROR
*copyc iip$search_connection_desc
*copyc IIP$STORE_TERM_CONN_ATTRIBUTES
*copyc IIP$ST_ALLOCATE_QUEUE_ENTRY
*copyc IIP$ST_CLOSE
*copyc IIP$ST_FETCH_ACCESS_INFORMATION
*copyc IIP$ST_FLUSH
*copyc IIP$ST_GET
*copyc IIP$ST_OPEN
*copyc IIP$ST_PUT
*copyc IIP$UPDATE_OPEN_DESC_ATTRIBUTES
*copyc jmp$handle_ts_io_req_failure
*copyc jmp$ts_io_request_valid
*copyc jmv$connection_acquired
*copyc IIV$CONNECTION_DESC_PTR
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIV$INT_TASK_OPEN_FILE_COUNT
*copyc iiv$interactive_terminated
*copyc jmv$terminal_io_disabled
*copyc osp$set_status_abnormal
*copyc OSS$TASK_PRIVATE
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc OST$STATUS
*copyc OSV$TASK_PRIVATE_HEAP
*copyc PMT$CONDITION_INFORMATION

?? NEWTITLE := 'PROCEDURE ifp$st_fap_control_ring_3', EJECT ??

  PROCEDURE [XDCL, #GATE] ifp$st_fap_control_ring_3 (file_id: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR callers_status: ost$status);

    VAR
      connection_desc_ptr: ^iit$connection_description,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      open_file_entry_descriptor: iit$queue_entry_descriptor,
      st_open_file_entry_descriptor: iit$st_queue_entry_descriptor,
      open_file_dsc_pointer: ^iit$open_file_description,
      st_open_file_dsc_pointer: ^iit$st_open_file_description,
      fetch_attributes_pointer: ^amt$fetch_attributes,
      file_identifier: amt$file_identifier,
      i: integer,
      pc: ^cell,
      sell: cell,
      status: ost$status,
      local_status: ost$status;

    status.normal := TRUE;
    open_file_dsc_pointer := NIL;

    /status_change_block/
    BEGIN
    IF call_block.operation = amc$open_req THEN

{ Detect improper access level ( physical access or segment access ).

      IF call_block.open.access_level = amc$physical THEN
        amp$set_file_instance_abnormal (file_id,
              ame$not_physical_access_device, call_block.operation, 'TERMINAL',
              callers_status);
        RETURN;
      IFEND;

      IF call_block.open.access_level = amc$segment THEN
        amp$set_file_instance_abnormal (file_id, ame$not_virtual_memory_device,
              call_block.operation, 'TERMINAL', callers_status);
        RETURN;
      IFEND;
        IF NOT jmp$ts_io_request_valid () THEN
          IF jmv$connection_acquired THEN
            jmp$handle_ts_io_req_failure (status);
            IF NOT status.normal THEN
              callers_status := status;
              RETURN;
            IFEND;
          IFEND;
        IFEND;

{ Build open file description entry and store the pointer.

        iip$st_allocate_queue_entry (iic$open_file_description,
              st_open_file_entry_descriptor, status);
        IF NOT status.normal THEN
          EXIT /status_change_block/;
        IFEND;

        st_open_file_dsc_pointer := st_open_file_entry_descriptor.
              open_file_description_ptr;

        file_identifier := file_id;
*copy bai$validate_file_identifier
        IF file_id_is_valid AND
          (file_instance <> NIL) THEN
          IF file_instance^.device_class =
            rmc$terminal_device THEN
            file_instance^.st_open_file_dsc_pointer :=
            st_open_file_dsc_pointer;
          ELSE
            osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$file_name_not_terminal,
              file_instance^.local_file_name,status);
          IFEND;
        ELSE
          osp$set_status_abnormal (ifc$interactive_facility_id,
            ife$file_name_not_terminal,
            'NON_TERMINAL_FILE',status);
        IFEND;
        IF NOT status.normal THEN
          EXIT /status_change_block/;
        IFEND;

        iip$st_open (file_id, st_open_file_dsc_pointer, call_block.open.
              local_file_name, layer_number, status);

      IF NOT status.normal THEN
        EXIT /status_change_block/;
      IFEND;

      amp$access_method (file_id, call_block, layer_number, status);

    ELSEIF call_block.operation = amc$close_req THEN
        file_identifier := file_id;
*copy bai$validate_file_identifier
*copy iii$fetch_st_open_file_desc_ptr
        IF NOT status.normal THEN
          EXIT /status_change_block/;
        IFEND;

        iip$st_close (file_id, st_open_file_dsc_pointer, status);

      amp$access_method (file_id, call_block, layer_number, status);
    ELSE

{ all reqs other than open/close respect if condition state

        IF NOT jmp$ts_io_request_valid () THEN
          IF (NOT jmv$connection_acquired) AND (
             (call_block.operation = amc$put_next_req) OR
             (call_block.operation = amc$put_partial_req) OR
             (call_block.operation = amc$fetch_req) OR
             (call_block.operation = amc$put_direct_req) OR
             (call_block.operation = amc$flush_req)) THEN
            {Ignore request
            status.normal := TRUE;
            EXIT /status_change_block/;
          ELSE
            jmp$handle_ts_io_req_failure (status);
            IF NOT status.normal THEN
              EXIT /status_change_block/;
            IFEND;
          IFEND;
        IFEND;

{ Get pointer to open file description which was stored on the open.

        file_identifier := file_id;
*copy bai$validate_file_identifier
*copy iii$fetch_st_open_file_desc_ptr
        IF NOT status.normal THEN
          EXIT /status_change_block/;
        IFEND;
        iip$search_connection_desc (st_open_file_dsc_pointer^.session_layer_file_name,
              connection_desc_ptr);
        IF connection_desc_ptr = NIL THEN
          osp$set_status_abnormal (ifc$interactive_facility_id, ife$file_is_not_network_file, '', status);
          EXIT /status_change_block/;
        IFEND;

      CASE call_block.operation OF

      = amc$get_next_req =

        pc := call_block.getn.working_storage_area;
        sell := pc^;
        pc^ := sell;
        pc := call_block.getn.transfer_count;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;
        pc := call_block.getn.byte_address;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;
        pc := call_block.getn.file_position;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;

          iip$st_get (file_id, st_open_file_dsc_pointer, call_block.operation,
                call_block.getn.working_storage_area, call_block.getn.
                working_storage_length, NIL, call_block.getn.transfer_count,
                call_block.getn.byte_address, call_block.getn.file_position,
                amc$skip_to_eor, status);

      = amc$get_partial_req =

        pc := call_block.getp.working_storage_area;
        sell := pc^;
        pc^ := sell;
        pc := call_block.getp.record_length;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;
        pc := call_block.getp.transfer_count;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;
        pc := call_block.getp.byte_address;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;
        pc := call_block.getp.file_position;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;

          iip$st_get (file_id, st_open_file_dsc_pointer, call_block.operation,
                call_block.getp.working_storage_area, call_block.getp.
                working_storage_length, call_block.getp.record_length,
                call_block.getp.transfer_count, call_block.getp.byte_address,
                call_block.getp.file_position, call_block.getp.skip_option,
                status);

      = amc$get_direct_req =

        pc := call_block.getd.working_storage_area;
        sell := pc^;
        pc^ := sell;
        pc := call_block.getd.transfer_count;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;
        pc := call_block.getd.file_position;
        IF pc <> NIL THEN
          sell := pc^;
          pc^ := sell;
        IFEND;

          iip$st_get (file_id, st_open_file_dsc_pointer, call_block.operation,
                call_block.getd.working_storage_area, call_block.getd.
                working_storage_length, NIL, call_block.getd.transfer_count, NIL,
                call_block.getd.file_position, amc$skip_to_eor, status);

      = amc$put_next_req =

        IF (call_block.putn.working_storage_length >= 0) AND (call_block.putn.working_storage_length <=
               UPPERVALUE (amt$working_storage_length)) AND
               ((call_block.putn.working_storage_area <> NIL) OR
                 ((call_block.putn.working_storage_area = NIL) AND
                 (call_block.putn.working_storage_length = 0))) THEN
            iip$st_put (file_id, st_open_file_dsc_pointer, call_block.operation,
                  call_block.putn.working_storage_area, call_block.putn.
                  working_storage_length, call_block.putn.byte_address,
                  amc$terminate, status);

        ELSE
          IF call_block.putn.working_storage_area = NIL THEN
            osp$set_status_abnormal (ifc$interactive_facility_id, ife$wsa_is_nil, '', status);
          ELSE
            osp$set_status_abnormal (ifc$interactive_facility_id, ife$wsl_out_of_range, '', status);
          IFEND;
        IFEND;

      = amc$put_partial_req =

          iip$st_put (file_id, st_open_file_dsc_pointer, call_block.operation,
                call_block.putp.working_storage_area, call_block.putp.
                working_storage_length, call_block.putp.byte_address, call_block.
                putp.term_option, status);

      = amc$put_direct_req =

          iip$st_put (file_id, st_open_file_dsc_pointer, call_block.operation,
                call_block.putd.working_storage_area, call_block.putd.
                working_storage_length, NIL, amc$terminate, status);

      = amc$flush_req =

          iip$st_flush (file_id, st_open_file_dsc_pointer, status);

      = amc$fetch_access_information_rq =

        pc := call_block.fai.access_information;
        sell := pc^;
        pc^ := sell;

          iip$st_fetch_access_information (file_id, st_open_file_dsc_pointer,
                call_block.fai.access_information, status);

      = ifc$fetch_terminal_req =

        pc := call_block.fetch_terminal.terminal_attributes;
        sell := pc^;
        pc^ := sell;

          iip$fetch_term_conn_attributes (file_id, st_open_file_dsc_pointer, call_block.
                fetch_terminal.terminal_attributes^, status);

      = ifc$store_terminal_req =

        pc := call_block.store_terminal.terminal_attributes;
        sell := pc^;

          iip$store_term_conn_attributes (file_id, st_open_file_dsc_pointer, call_block.
                store_terminal.terminal_attributes, status);

      = amc$seek_direct_req, amc$skip_req, amc$rewind_req, amc$replace_req,
            amc$write_end_partition_req =

        status.normal := TRUE;

      = amc$fetch_req =

{ Update the open file description attributes if they might have been changed.


        amp$access_method (file_id, call_block, layer_number, status);

{ Return the interactive values for page_length and page_width if they have
{ not been specified by BAM requests.

        IF status.normal THEN

          fetch_attributes_pointer := call_block.fetch.file_attributes;

        /fix_page_length_and_page_width/
          FOR i := LOWERBOUND (fetch_attributes_pointer^) TO UPPERBOUND
                (fetch_attributes_pointer^) DO
            IF ((fetch_attributes_pointer^ [i].key = amc$page_length) AND
                  ((fetch_attributes_pointer^ [i].source =
                  amc$undefined_attribute) OR (fetch_attributes_pointer^ [i].
                  source = amc$access_method_default))) THEN

                IF connection_desc_ptr <> NIL THEN
                  IF connection_desc_ptr^.page_length = 0 THEN
                    fetch_attributes_pointer^ [i].page_length := UPPERVALUE (amt$page_length);
                  ELSE
                    fetch_attributes_pointer^ [i].page_length := connection_desc_ptr^.page_length;
                  IFEND;
                IFEND;

              CYCLE /fix_page_length_and_page_width/;

            IFEND;
            IF ((fetch_attributes_pointer^ [i].key = amc$page_width) AND
                  ((fetch_attributes_pointer^ [i].source =
                  amc$undefined_attribute) OR (fetch_attributes_pointer^ [i].
                  source = amc$access_method_default))) THEN

                IF connection_desc_ptr <> NIL THEN
                  IF connection_desc_ptr^.page_width = 0 THEN
                    fetch_attributes_pointer^ [i].page_width := amc$max_page_width;
                  ELSE
                    fetch_attributes_pointer^ [i].page_width := connection_desc_ptr^.page_width;
                  IFEND;
                IFEND;

              CYCLE /fix_page_length_and_page_width/;

            IFEND;
          FOREND /fix_page_length_and_page_width/;

        IFEND;

      = amc$store_req =

        pc := call_block.store.file_attributes;
        sell := pc^;

        amp$access_method (file_id, call_block, layer_number, status);

      ELSE

{ The operation is improper for a terminal device.

        amp$set_file_instance_abnormal (file_id, ame$improper_device_class,
              call_block.operation, 'terminal', status);
      CASEND;

    IFEND;

    END /status_change_block/;

    IF status.normal THEN
      callers_status.normal := TRUE;
      callers_status.condition := 0;
    ELSE
      CASE call_block.operation OF
      = amc$put_next_req, amc$put_partial_req, amc$put_direct_req, amc$flush_req =
        IF (status.condition = jme$job_is_in_termination) OR (status.condition = jme$task_is_in_termination)
             OR jmv$terminal_io_disabled THEN
          status.normal := TRUE;
          status.condition := 0;
        IFEND;
      ELSE
      CASEND;

      callers_status := status;
    IFEND;

{ Save access information for this request.

    IF open_file_dsc_pointer <> NIL THEN

      IF callers_status.normal THEN
        open_file_dsc_pointer^.error_status := 0;
      ELSE
        open_file_dsc_pointer^.error_status := callers_status.condition;
      IFEND;

      IF (call_block.operation <> amc$fetch_access_information_rq) AND
        (call_block.operation <> amc$fetch_req) THEN
        open_file_dsc_pointer^.last_access_operation := call_block.operation;
      IFEND;

    IFEND;

  PROCEND ifp$st_fap_control_ring_3;

MODEND ifm$st_fap_control;
*DECK DECK=IFM$ST_INTERACTIVE_USR_FAP_SCRN EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Interactive Facility (Stand Alone): FAP Screen' ??
MODULE ifm$st_interactive_usr_fap_scrn;

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$unseen_mail_condition
*copyc ife$interactive_exception_codes
*copyc ifk$keypoints
*copyc nae$condition_codes
*copyc ost$status
?? POP ??
*copyc ifp$st_fap_control_ring_3
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$long_term_wait
?? OLDTITLE ??
?? NEWTITLE := 'ifp$st_fap_control', EJECT ??

  PROCEDURE [XDCL] ifp$st_fap_control
    (    file_id: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      CASE condition.selector OF

      = ifc$interactive_condition =
        CASE condition.interactive_condition OF
        = ifc$pause_break =
          osp$set_status_condition (ife$pause_break_received, status);
        = ifc$terminate_break =
          osp$set_status_condition (ife$terminate_break_received, status);
        = ifc$terminal_connection_broken =
          osp$set_status_condition (ife$connection_break_disconnect, status);
        = ifc$job_reconnect =
          osp$set_status_condition (ife$terminal_reconnected_to_job, status);
        ELSE
          osp$set_status_abnormal (ifc$interactive_facility_id, 0,
                'unknown interactive condition encountered', status);
        CASEND;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND condition_handler;
?? OLDTITLE ??

    #KEYPOINT (osk$entry, 0, ifk$st_fap_control);

    osp$establish_condition_handler (^condition_handler, FALSE);

  /perform_operation/
    WHILE TRUE DO
      ifp$st_fap_control_ring_3 (file_id, call_block, layer_number, status);

      IF status.normal THEN
        EXIT /perform_operation/;
      ELSE
        CASE status.condition OF
        = cle$unseen_mail_condition, ife$abort_get, ife$connection_break_disconnect, ife$pause_break_received,
              ife$terminal_reconnected_to_job, ife$terminate_break_received, nae$interactive_cond_interrupt =
          pmp$long_term_wait (100, 100);
          CYCLE /perform_operation/;
        ELSE
          EXIT /perform_operation/;
        CASEND;
      IFEND;
    WHILEND /perform_operation/;

    osp$disestablish_cond_handler;

    #KEYPOINT (osk$exit, 0, ifk$st_fap_control);

  PROCEND ifp$st_fap_control;

MODEND ifm$st_interactive_usr_fap_scrn
*DECK DECK=IFM$SUPPRESS_CURSOR_POS_ECHOPLX EXPAND=TRUE
*copyc osd$default_pragmats
?? TITLE := 'IFM$SUPPRESS_CURSOR_POS_ECHOPLX--toggle cursor positioning and/or echoplexing for next input' ??
MODULE ifm$suppress_cursor_pos_echoplx;

{  PURPOSE:
{    To provide a 23d interface which allows the caller to turn off cursor
{    positioning and/or echoplexing for only the next input from the terminal.
{
{  DESIGN:
{    Call iip$suppress_cursor_pos_echoplx to set IIV$SUPPRESS_CURSOR_POSITIONING
{    and/or IIV$SUPPRESS_ECHOPLEXING to TRUE.  This will cause single-input
{    suppression of cursor positioning and/or echoplexing.
{
?? PUSH (LISTEXT := ON) ??
*copyc iip$suppress_cursor_pos_echoplx
*copyc ifk$keypoints
?? POP ??

*copyc ifh$suppress_cursor_pos_echoplx
  PROCEDURE [XDCL,#GATE] ifp$suppress_cursor_pos_echoplx (
    suppress_cursor_positioning: boolean;
    suppress_echoplexing: boolean);

    #KEYPOINT (osk$entry, 0, ifk$suppress_cursor_pos_echoplx);

    iip$suppress_cursor_pos_echoplx (suppress_cursor_positioning,
          suppress_echoplexing);

    #KEYPOINT (osk$exit, 0, ifk$suppress_cursor_pos_echoplx);

  PROCEND ifp$suppress_cursor_pos_echoplx;
MODEND ifm$suppress_cursor_pos_echoplx;
*DECK DECK=IFP$ADVANCE EXPAND=FALSE

  PROCEDURE [XREF] ifp$advance (count: ift$advance_count_range;
    unit: ift$advance_unit;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ift$$advance_repeat_types
*copyc ift$title_for_error_codes
*copyc OST$STATUS
?? POP ??
*DECK DECK=IFP$BEGIN_PAUSE_UTILITY EXPAND=FALSE
  PROCEDURE [XREF] ifp$begin_pause_utility (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ife$error_codes
*copyc ost$status
?? POP ??
*DECK DECK=IFP$CHANGE_TERMINAL_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] ifp$change_terminal_attributes
    (terminal_file_name: fst$file_reference;
        terminal_attributes: ift$terminal_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ife$error_codes
*copyc ift$terminal_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IFP$CHANGE_TERM_CONN_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] ifp$change_term_conn_attributes
    (terminal_file_name: fst$file_reference;
        term_conn_attributes: ift$connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ife$error_codes
*copyc ift$connection_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IFP$CHANGE_TERM_CONN_DEFAULTS EXPAND=FALSE

  PROCEDURE [XREF] ifp$change_term_conn_defaults
    (terminal_file_name: fst$file_reference;
        term_conn_attributes: ift$connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ife$error_codes
*copyc ift$connection_attributes
*copyc ost$status
?? POP ??

*DECK DECK=IFP$DEFAULT_INTERACTIVE_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] ifp$default_interactive_handler
    (    condition: pmt$condition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ife$error_codes
*copyc ost$status
*copyc pmt$condition
?? POP ??
*DECK DECK=IFP$DISCARD_SUSPENDED_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] ifp$discard_suspended_output;
*DECK DECK=IFP$DISCONNECT EXPAND=FALSE

  PROCEDURE [XREF] ifp$disconnect (
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ife$error_codes
*copyc ost$status
?? POP ??
*DECK DECK=IFP$END_PAUSE_UTILITY EXPAND=FALSE
  PROCEDURE [XREF] ifp$end_pause_utility (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ife$error_codes
*copyc ost$status
?? POP ??
*DECK DECK=IFP$FAP_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] ifp$fap_control (file_id: amt$file_identifier;
    call_block: amt$call_block;
    layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_POINTER
*copyc ife$error_codes
*copyc OST$STATUS
?? POP ??
*DECK DECK=IFP$FAP_CONTROL_RING_3 EXPAND=FALSE

  PROCEDURE [XREF] ifp$fap_control_ring_3 (file_id: amt$file_identifier;
    call_block: amt$call_block;
    layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_POINTER
*copyc ife$error_codes
*copyc OST$STATUS
?? POP ??
*DECK DECK=IFP$FETCH_CONTEXT EXPAND=FALSE

  PROCEDURE [XREF] ifp$fetch_context (VAR {i/o}
    context_attributes: ift$fetch_context_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ife$error_codes
*copyc ift$fetch_context_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IFP$FETCH_TERM_CONN_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] ifp$fetch_term_conn_attributes
    (file_identifier: amt$file_identifier;
    VAR term_conn_attributes: ift$get_connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ife$error_codes
*copyc ift$get_connection_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IFP$GET_NETWORK_IDENTIFIER EXPAND=FALSE

  PROCEDURE [XREF] ifp$get_network_identifier
    (VAR network_identifier: ift$network_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ift$network_identifier
*copyc ost$status
?? POP ??
*DECK DECK=IFP$GET_PAGE_LENGTH_WIDTH EXPAND=FALSE

  PROCEDURE [XREF] ifp$get_page_length_width (terminal_path_handle: fmt$path_handle;
    VAR page_length_width: array [1 .. 2] of ift$terminal_attribute;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_handle
*copyc ife$error_codes
*copyc ift$terminal_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IFP$GET_TELNET_CONNECTION_LIMIT EXPAND=FALSE

  PROCEDURE [XREF] ifp$get_telnet_connection_limit
    (VAR telnet_connection_limit: integer);
*DECK DECK=IFP$GET_TERMINAL_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] ifp$get_terminal_attributes (terminal_file_name:
    fst$file_reference;
    VAR terminal_attributes: ift$terminal_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ife$error_codes
*copyc ift$terminal_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IFP$GET_TERM_CONN_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] ifp$get_term_conn_attributes
    (terminal_file_name: fst$file_reference;
    VAR term_conn_attributes: ift$get_connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ife$error_codes
*copyc ift$get_connection_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IFP$GET_TERM_CONN_DEFAULTS EXPAND=FALSE

  PROCEDURE [XREF] ifp$get_term_conn_defaults
    (terminal_file_name: fst$file_reference;
    VAR term_conn_attributes: ift$get_connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ife$error_codes
*copyc ift$get_connection_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IFP$HANDLE_SIGNAL EXPAND=FALSE


  PROCEDURE [XREF] ifp$handle_signal (originator: ost$global_task_id;
    signal: pmt$signal);
?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc PMT$SIGNAL
?? POP ??
*DECK DECK=IFP$IMMEDIATE_ATTRIBUTE_FLUSH EXPAND=FALSE

   PROCEDURE [XREF] ifp$immediate_attribute_flush
     (    file_id: amt$file_identifier;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=IFP$INVOKE_PAUSE_UTILITY EXPAND=FALSE
  PROCEDURE [INLINE] ifp$invoke_pause_utility (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_status: ost$status;

     status.normal := TRUE;

{ ignore pause breaks if the maximum number of pause utility invokations is
{ currently pending - simply pretend as though a RESC was done.

    IF NOT jmp$system_job () THEN
      IF ifv$pause_utility_count = ifc$pause_utility_count_maximum THEN
        clp$put_job_output (' Pause break ignored - the nested pause break lim'
          CAT 'it has been exceeded', ignore_status);
        status.normal := TRUE;
        RETURN;
      IFEND;
    IFEND;

    ifp$start_pause_utility (status);

    IF NOT status.normal THEN

{ raise terminate condition within the task

      pmp$log ('terminate command causing terminate condition', ignore_status);
      pmp$dispose_interactive_cond (ifc$terminate_break);
      status.normal := TRUE;
    ELSE

      pmp$log ('resume after break', ignore_status);
    IFEND;
  PROCEND ifp$invoke_pause_utility;

*copyc clp$put_job_output
*copyc ife$error_codes
*copyc ifp$start_pause_utility
*copyc ifv$pause_utility_count
*copyc jmp$system_job
*copyc ost$status
*copyc pmp$dispose_interactive_cond
*copyc pmp$log


?? POP ??
*DECK DECK=IFP$JOB_INITIALIZE EXPAND=FALSE

  PROCEDURE [XREF] ifp$job_initialize (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ife$error_codes
*copyc OST$STATUS
?? POP ??

*DECK DECK=IFP$MARK_ATTRIBUTES_CHANGE EXPAND=FALSE

  PROCEDURE [XREF] ifp$mark_attributes_change (change_source:
    ift$connection_attribute_source;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ife$error_codes
*copyc ift$connection_attribute_source
*copyc OST$STATUS
?? POP ??
*DECK DECK=IFP$PURGE_CONNECTION_IO EXPAND=FALSE

   PROCEDURE [XREF] ifp$purge_connection_io  (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iik$keypoints
*copyc iip$build_super_msg_skeleton
*copyc iip$report_status_error
*copyc iip$send_to_pass_on
*copyc iiv$interactive_terminated
*copyc iiv$int_task_open_file_count
?? POP ??
*DECK DECK=IFP$PUT_STND_OUT EXPAND=FALSE

  PROCEDURE [XREF] ifp$put_stnd_out (s: string ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ife$error_codes
*copyc OST$STATUS
?? POP ??
*DECK DECK=IFP$RECONNECT EXPAND=FALSE

  PROCEDURE [XREF] ifp$reconnect (
        global_task_id: ost$global_task_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ife$error_codes
*copyc ost$global_task_id
*copyc ost$status
?? POP ??
*DECK DECK=IFP$SEND_ATTRIBUTE_KLUDGE EXPAND=FALSE

  PROCEDURE [XREF] ifp$send_attribute_kludge (attributes: ^array [ * ] of
        record
            fn,
            fv: 0 .. 0ff(16),
        recend;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ife$error_codes
*copyc ost$status
?? POP ??

*DECK DECK=IFP$SEND_INTERRUPT_CONDITION EXPAND=FALSE
 PROCEDURE [XREF] ifp$send_interrupt_condition (task_id: pmt$task_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ife$error_codes
*copyc ost$status
*copyc pmc$program_management_id
*copyc pme$execution_exceptions
*copyc pmt$task_id
?? POP ??
*DECK DECK=IFP$START_PAUSE_UTILITY EXPAND=FALSE

  PROCEDURE [XREF] ifp$start_pause_utility(VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ife$error_codes
*copyc OST$STATUS
?? POP ??
*DECK DECK=IFP$STOP_INTERACTIVE EXPAND=FALSE

  PROCEDURE [XREF {TS_gate} ] ifp$stop_interactive;
*DECK DECK=IFP$STORE_CONTEXT EXPAND=FALSE

  PROCEDURE [XREF] ifp$store_context (file_id:
    amt$file_identifier;
        context_attributes: ift$store_context_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ife$error_codes
*copyc ift$store_context_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IFP$STORE_TERM_CONN_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] ifp$store_term_conn_attributes
    (file_identifier: amt$file_identifier;
        terminal_attributes: ift$connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ife$error_codes
*copyc ift$connection_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IFP$ST_FAP_CONTROL EXPAND=FALSE


  PROCEDURE [XREF] ifp$st_fap_control (file_id: amt$file_identifier;
    call_block: amt$call_block;
    layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_POINTER
*copyc ife$interactive_exception_codes
*copyc nae$condition_codes
*copyc OST$STATUS
?? POP ??
*DECK DECK=IFP$ST_FAP_CONTROL_RING_3 EXPAND=FALSE


  PROCEDURE [XREF] ifp$st_fap_control_ring_3 (file_id: amt$file_identifier;
    call_block: amt$call_block;
    layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_POINTER
*copyc ife$error_codes
*copyc OST$STATUS
?? POP ??
*DECK DECK=IFP$SUPPRESS_CURSOR_POS_ECHOPLX EXPAND=FALSE

  PROCEDURE [XREF] ifp$suppress_cursor_pos_echoplx (
    suppress_cursor_positioning: boolean;
    suppress_echoplexing: boolean);

*copyc ifh$suppress_cursor_pos_echoplx
*DECK DECK=IFP$VTP_CREATE_CDCNET_CONNECT EXPAND=FALSE

  PROCEDURE [XREF] ifp$vtp_create_cdcnet_connect
    (    service_name: ost$name;
         service_data: ^SEQ ( * );
         connection_data_1: ^SEQ ( * );
         connection_data_2: ^SEQ ( * );
         connection_data_3: ^SEQ ( * );
         end_discard_prompt: ^SEQ ( * );
         timeout_interval_in_ms: 0 .. 0ffffffff(16);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ife$error_codes
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=IFT$$ADVANCE_REPEAT_TYPES EXPAND=FALSE

  TYPE
    ift$advance_count_range = 1 .. 256,
    ift$advance_unit = (ifc$advance_logical_line, ifc$advance_logical_page,
      ifc$advance_to_input, ifc$advance_all_queued_output),
    ift$repeat_count_range = 1 .. 256,
    ift$repeat_unit = (ifc$repeat_logical_line, ifc$repeat_logical_page,
      ifc$repeat_from_input),
    ift$repeat_level = (ifc$repeat_current, ifc$repeat_suspended_1);
*DECK DECK=IFT$CODE_SET_NAME EXPAND=FALSE


  TYPE
    ift$code_set_name_size = 1 .. ifc$max_code_set_name_size;

  TYPE
    ift$code_set_name = record
      size: ift$code_set_name_size,
      value: string (ifc$max_code_set_name_size),
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ifc$terminal_constants
?? POP ??
*DECK DECK=IFT$CONDITION_CODES EXPAND=FALSE

  CONST
    ifc$pause_break = 1,
    ifc$terminate_break = 2,
    ifc$terminal_connection_broken = 3,
    ifc$job_reconnect = 4;

  TYPE
    ift$interactive_condition = pmt$condition_identifier;

?? PUSH (LISTEXT := ON) ??
*copyc PMT$CONDITION_IDENTIFIER
?? POP ??
*DECK DECK=IFT$CONNECTION_ATTRIBUTES EXPAND=FALSE

  TYPE
    ift$connection_attributes = array [1 .. * ] of
      ift$connection_attribute;

  TYPE
    ift$connection_attribute = record
      case key {input} : ift$connection_attribute_keys of
      = ifc$attention_character_action =
        attention_character_action:
          ift$attention_character_action,
      = ifc$break_key_action =
        break_key_action: ift$break_key_action,
      = ifc$end_of_information =
        end_of_information: ift$end_of_information,
      = ifc$input_block_size =
        input_block_size: ift$input_block_size,
      = ifc$input_editing_mode =
        input_editing_mode: ift$input_editing_mode,
      = ifc$input_output_mode =
        input_output_mode: ift$input_output_mode,
      = ifc$input_timeout =
        input_timeout: boolean,
      = ifc$input_timeout_length =
        input_timeout_length: ift$input_timeout_length,
      = ifc$input_timeout_purge =
        input_timeout_purge: boolean,
      = ifc$null_connection_attribute =
        ,
      = ifc$partial_char_forwarding =
        partial_character_forwarding: boolean,
      = ifc$prompt_file =
        prompt_file: amt$local_file_name,
      = ifc$prompt_file_identifier =
        prompt_file_identifier: amt$file_identifier,
      = ifc$prompt_string =
        prompt_string: ift$prompt_string,
      = ifc$store_backspace_character =
        store_backspace_character: boolean,
      = ifc$store_nuls_dels =
        store_nuls_dels: boolean,
      = ifc$trans_character_mode =
        trans_character_mode: ift$trans_character_mode,
      = ifc$trans_forward_character =
        trans_forward_character: ift$trans_forward_character,
      = ifc$trans_length_mode =
        trans_length_mode: ift$trans_length_mode,
      = ifc$trans_message_length =
        trans_message_length: ift$trans_message_length,
      = ifc$trans_terminate_character =
        trans_terminate_character: ift$trans_terminate_character,
      = ifc$trans_timeout_mode =
        trans_timeout_mode: ift$trans_timeout_mode,
      = ifc$trans_protocol_mode =
        trans_protocol_mode: ift$trans_protocol_mode,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc ift$connection_attribute_keys
*copyc ift$terminal_connection_types
?? POP ??

*DECK DECK=IFT$CONNECTION_ATTRIBUTE_KEYS EXPAND=FALSE

  TYPE
    ift$connection_attribute_keys =
      (ifc$attention_character_action, ifc$break_key_action,
      ifc$end_of_information, ifc$input_block_size,
      ifc$input_editing_mode, ifc$input_output_mode,
      ifc$input_timeout, ifc$input_timeout_length,
      ifc$input_timeout_purge, ifc$null_connection_attribute,
      ifc$partial_char_forwarding, ifc$prompt_file,
      ifc$prompt_file_identifier, ifc$prompt_string,
      ifc$store_backspace_character, ifc$store_nuls_dels,
      ifc$trans_character_mode, ifc$trans_forward_character,
      ifc$trans_length_mode, ifc$trans_message_length,
      ifc$trans_terminate_character, ifc$trans_timeout_mode,
      ifc$trans_protocol_mode);

  CONST
    ifc$min_connection_key = ifc$attention_character_action,
    ifc$max_connection_key = ifc$trans_protocol_mode;

*DECK DECK=IFT$CONNECTION_ATTRIBUTE_SOURCE EXPAND=FALSE

  TYPE

{ For each attribute, the origin of the current value is one of:

    ift$connection_attribute_source = (ifc$undefined_attribute,
      ifc$nam_default, ifc$os_default,
      ifc$change_term_conn_dflt_cmd,
      ifc$change_term_conn_dflt_req,
      ifc$change_term_conn_command, ifc$change_term_conn_request,
      ifc$request_terminal_command, ifc$request_terminal_request,
      ifc$store_term_conn_request);

*DECK DECK=IFT$CONTROL_CODE_REPLACEMENT EXPAND=FALSE


  TYPE
    ift$total_substitution_count = 0 .. ifc$total_substitution_count;

  TYPE
    ift$control_code_replacement = record
      total_substitution_count : ift$total_substitution_count,
      value: array [1 .. ifc$total_substitution_count] OF
        ift$control_code_rep_char,
    recend;

  TYPE
    ift$control_code_rep_char = record
      original_control_code: char,
      substitute_control_code: char,
    recend;








?? PUSH (LISTEXT := ON) ??
*copyc ifc$terminal_constants
?? POP ??
*DECK DECK=IFT$DEFAULT_TERMINAL_ATTRIBUTES EXPAND=FALSE

{ NOS/VE default terminal attribute values.  Attributes not listed
{   here have the initial defaults supplied by NAM.

  CONST

{eoi_string.size}
    ifc$def_eoi_string_size = 4,
{eoi_string.value}
    ifc$def_eoi_string_value = '*EOI            ',
{input_timeout}
    ifc$def_input_timeout = FALSE,
{input_timeout_length}
    ifc$def_input_timeout_length = 86401,
{input_timeout_purge}
    ifc$def_input_timeout_purge = TRUE,
{prompt_file}
    ifc$def_prompt_file = ':$LOCAL.OUTPUT.1               ',
{prompt_string.size}
    ifc$def_prompt_string_size = 3,
{prompt_string.value}
    ifc$def_prompt_string_value = ' ? ',
{terminal_model}
    ifc$def_terminal_model = '';
*DECK DECK=IFT$FETCH_CONTEXT_ATTRIBUTE EXPAND=FALSE

  TYPE
    ift$fetch_context_attribute = record
      case key: ift$fetch_context_keys of
      = ifc$previous_mode =
        previous_mode: ift$terminal_mode,
      = ifc$previous_file_id =
        previous_file_id: amt$file_identifier,
      = ifc$previous_operation =
        previous_operation: amt$fap_operation,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ift$fetch_context_keys
*copyc ift$terminal_mode
*copyc amt$file_identifier
*copyc amt$fap_operation
?? POP ??
*DECK DECK=IFT$FETCH_CONTEXT_ATTRIBUTES EXPAND=FALSE

  TYPE
    ift$fetch_context_attributes = array [ * ] of
      ift$fetch_context_attribute;

?? PUSH (LISTEXT := ON) ??
*copyc ift$fetch_context_attribute
?? POP ??
*DECK DECK=IFT$FETCH_CONTEXT_KEYS EXPAND=FALSE

  TYPE
    ift$fetch_context_keys = (ifc$previous_mode,
      ifc$previous_file_id, ifc$previous_operation);

*DECK DECK=IFT$FORMAT_EFFECTORS EXPAND=FALSE

{ Definition of NAM format effectors.

  CONST
    ifc$pre_print_space_1 = ' ',
    ifc$pre_print_space_2 = '0',
    ifc$pre_print_space_3 = '-',
    ifc$pre_print_start_of_line = '+',
    ifc$pre_print_home_cursor = '*',
    ifc$pre_print_home_clear_screen = '1',
    ifc$pre_print_no_positioning = ',',
    ifc$post_print_space_1 = '.',
    ifc$post_print_start_of_line = '/';
*DECK DECK=IFT$FUNCTION_KEY_CLASS EXPAND=FALSE


  TYPE
    ift$function_key_class_size = 1 .. ifc$max_function_key_class_size;

  TYPE
    ift$function_key_class = record
      size: ift$function_key_class_size,
      value: string (ifc$max_function_key_class_size),
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ifc$terminal_constants
?? POP ??
*DECK DECK=IFT$GET_CONNECTION_ATTRIBUTES EXPAND=FALSE

  TYPE
    ift$get_connection_attributes = array [1 .. * ] of
      ift$get_connection_attribute;

  TYPE
    ift$get_connection_attribute = record
      source {output} : ift$connection_attribute_source,
      case key {input} : ift$connection_attribute_keys of
      = ifc$attention_character_action =
        attention_character_action:
          ift$attention_character_action,
      = ifc$break_key_action =
        break_key_action: ift$break_key_action,
      = ifc$end_of_information =
        end_of_information: ift$end_of_information,
      = ifc$input_block_size =
        input_block_size: ift$input_block_size,
      = ifc$input_editing_mode =
        input_editing_mode: ift$input_editing_mode,
      = ifc$input_output_mode =
        input_output_mode: ift$input_output_mode,
      = ifc$input_timeout =
        input_timeout: boolean,
      = ifc$input_timeout_length =
        input_timeout_length: ift$input_timeout_length,
      = ifc$input_timeout_purge =
        input_timeout_purge: boolean,
      = ifc$null_connection_attribute =
        ,
      = ifc$partial_char_forwarding =
        partial_character_forwarding: boolean,
      = ifc$prompt_file =
        prompt_file: amt$local_file_name,
      = ifc$prompt_file_identifier =
        prompt_file_identifier: amt$file_identifier,
      = ifc$prompt_string =
        prompt_string: ift$prompt_string,
      = ifc$store_backspace_character =
        store_backspace_character: boolean,
      = ifc$store_nuls_dels =
        store_nuls_dels: boolean,
      = ifc$trans_character_mode =
        trans_character_mode: ift$trans_character_mode,
      = ifc$trans_forward_character =
        trans_forward_character: ift$trans_forward_character,
      = ifc$trans_length_mode =
        trans_length_mode: ift$trans_length_mode,
      = ifc$trans_message_length =
        trans_message_length: ift$trans_message_length,
      = ifc$trans_terminate_character =
        trans_terminate_character: ift$trans_terminate_character,
      = ifc$trans_timeout_mode =
        trans_timeout_mode: ift$trans_timeout_mode,
      = ifc$trans_protocol_mode =
        trans_protocol_mode: ift$trans_protocol_mode,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc ift$connection_attribute_source
*copyc ift$connection_attribute_keys
*copyc ift$terminal_connection_types
?? POP ??
*DECK DECK=IFT$GET_CONNECTION_ATTR_ERROR EXPAND=FALSE

  TYPE
    ift$get_connection_attr_error =
      ift$connection_attribute_keys;

?? PUSH (LISTEXT := ON) ??
*copyc ift$connection_attribute_keys
?? POP ??
*DECK DECK=IFT$NETWORK_IDENTIFIER EXPAND=FALSE

  TYPE
    ift$network_identifier = 0 .. 255;

  CONST
    ifc$ni_none = 0,
    ifc$ni_nam_ve_cdcnet = 1,
    ifc$ni_nam_cdcnet = 2,
    ifc$ni_nam_ccp = 3,
    ifc$ni_intercom = 4,

    ifc$max_network_identifier = 4;

*DECK DECK=IFT$PAUSE_UTILITY_COUNT EXPAND=FALSE
  TYPE
    ift$pause_utility_count = 0 .. ifc$pause_utility_count_maximum;

  CONST
    ifc$pause_utility_count_maximum = 5;
*DECK DECK=IFT$PAUSE_UTIL_DISPATCHING_INFO EXPAND=FALSE

  TYPE
    ift$pause_util_dispatching_info = ARRAY [0..ifc$pause_utility_count_maximum] OF
          jmt$dispatching_control_info;

*copyc ift$pause_utility_count
*copyc jmt$dispatching_control_info

*DECK DECK=IFT$STORE_CONTEXT_ATTRIBUTE EXPAND=FALSE

  TYPE
    ift$store_context_attribute = record
      case key: ift$store_context_keys of
      = ifc$instance_mode =
        instance_mode: ift$terminal_mode,
      = ifc$blank_flag =
        blank_flag: boolean,
      = ifc$screen_clear_string =
        screen_clear_string: ost$string,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ift$store_context_keys
*copyc ift$terminal_mode
*copyc ost$string
?? POP ??
*DECK DECK=IFT$STORE_CONTEXT_ATTRIBUTES EXPAND=FALSE

  TYPE
    ift$store_context_attributes = array [ * ] of
      ift$store_context_attribute;

?? PUSH (LISTEXT := ON) ??
*copyc ift$store_context_attribute
?? POP ??
*DECK DECK=IFT$STORE_CONTEXT_KEYS EXPAND=FALSE

  TYPE
    ift$store_context_keys = (ifc$instance_mode, ifc$blank_flag,
      ifc$screen_clear_string);

*DECK DECK=IFT$TERMINAL_ATTRIBUTES EXPAND=FALSE

  TYPE
    ift$terminal_attributes = array [1 .. * ] of
      ift$terminal_attribute;

  TYPE
    ift$terminal_attribute = record
      case key {input} : ift$terminal_attribute_keys of
      = ifc$attention_character =
        attention_character: char,
      = ifc$backspace_character =
        backspace_character: char,
      = ifc$begin_line_character =
        begin_line_character: char,
      = ifc$cancel_line_character =
        cancel_line_character: char,
      = ifc$carriage_return_delay =
        carriage_return_delay: ift$carriage_return_delay,
      = ifc$carriage_return_sequence =
        carriage_return_sequence: ift$carriage_return_sequence,
      = ifc$character_flow_control =
        character_flow_control: boolean,
      = ifc$code_set =
        code_set: ift$code_set,
      = ifc$echoplex =
        echoplex: boolean,
      = ifc$end_line_character =
        end_line_character: char,
      = ifc$end_line_positioning =
        end_line_positioning: ift$end_line_positioning,
      = ifc$end_output_sequence =
        end_output_sequence: ift$end_output_sequence,
      = ifc$end_page_action =
        end_page_action: ift$end_page_action,
      = ifc$end_partial_character =
        end_partial_character: char,
      = ifc$end_partial_positioning =
        end_partial_positioning: ift$end_partial_positioning,
      = ifc$fold_line =
        fold_line: boolean,
      = ifc$form_feed_delay =
        form_feed_delay: ift$form_feed_delay,
      = ifc$form_feed_sequence =
        form_feed_sequence: ift$form_feed_sequence,
      = ifc$hold_page =
        hold_page: boolean,
      = ifc$hold_page_over =
        hold_page_over: boolean,
      = ifc$line_feed_delay =
        line_feed_delay: ift$line_feed_delay,
      = ifc$line_feed_sequence =
        line_feed_sequence: ift$line_feed_sequence,
      = ifc$network_command_character =
        network_command_character: char,
      = ifc$null_terminal_attribute =
        ,
      = ifc$page_length =
        page_length: ift$page_length,
      = ifc$page_width =
        page_width: ift$page_width,
      = ifc$parity =
        parity: ift$parity,
      = ifc$pause_break_character =
        pause_break_character: char,
      = ifc$status_action =
        status_action: ift$status_action,
      = ifc$terminal_class =
        terminal_class: ift$terminal_class,
      = ifc$terminal_model =
        terminal_model: ift$terminal_model,
      = ifc$terminate_break_character =
        terminate_break_character: char,
      = ifc$terminal_name =
        terminal_name: ^ift$terminal_name,
      = ifc$control_code_replacement =
        control_code_replacement: ^ift$control_code_replacement,
      = ifc$code_set_name =
        code_set_name: ^ift$code_set_name,
      = ifc$function_key_class =
        function_key_class: ^ift$function_key_class,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ifc$terminal_constants
*copyc ift$terminal_attribute_keys
*copyc ift$terminal_attribute_types
*copyc ift$terminal_class
*copyc ift$terminal_model
*copyc ift$function_key_class
*copyc ift$code_set_name
?? POP ??
*DECK DECK=IFT$TERMINAL_ATTRIBUTE_KEYS EXPAND=FALSE

  TYPE
    ift$terminal_attribute_keys = (ifc$attention_character,
      ifc$backspace_character, ifc$begin_line_character,
      ifc$cancel_line_character, ifc$carriage_return_delay,
      ifc$carriage_return_sequence, ifc$character_flow_control,
      ifc$code_set, ifc$echoplex, ifc$end_line_character,
      ifc$end_line_positioning, ifc$end_output_sequence,
      ifc$end_page_action, ifc$end_partial_character,
      ifc$end_partial_positioning, ifc$fold_line,
      ifc$form_feed_delay, ifc$form_feed_sequence, ifc$hold_page,
      ifc$hold_page_over, ifc$line_feed_delay,
      ifc$line_feed_sequence, ifc$network_command_character,
      ifc$null_terminal_attribute, ifc$page_length,
      ifc$page_width, ifc$parity, ifc$pause_break_character,
      ifc$status_action, ifc$terminal_class, ifc$terminal_model,
      ifc$terminate_break_character, ifc$terminal_name,
      ifc$control_code_replacement,ifc$code_set_name,
      ifc$function_key_class);

  CONST
    ifc$min_terminal_attribute_key = ifc$attention_character,
    ifc$max_terminal_attribute_key = ifc$function_key_class;


*DECK DECK=IFT$TERMINAL_ATTRIBUTE_TYPES EXPAND=FALSE

  TYPE
    ift$carriage_return_delay = 0 .. 1000,
    ift$cr_seq_size = 0 .. ifc$max_cr_seq_size,
    ift$carriage_return_sequence = record
      size: ift$cr_seq_size,
      value: string (ifc$max_cr_seq_size),
    recend,
    ift$code_set = (ifc$ascii_code_set, ifc$bpapl_code_set,
      ifc$tpapl_code_set,ifc$name_code_set),
    ift$end_line_positioning = (ifc$elp_none, ifc$elp_crs,
      ifc$elp_lfs, ifc$elp_crslfs),
    ift$end_out_seq_size = 0 .. ifc$max_end_out_seq_size,
    ift$end_output_sequence = record
      size: ift$end_out_seq_size,
      value: string (ifc$max_end_out_seq_size),
    recend,
    ift$end_page_action = (ifc$no_epa, ifc$epa_ffs),
    ift$end_partial_positioning = (ifc$no_epp, ifc$epp_crs,
      ifc$epp_lfs, ifc$epp_crslfs),
    ift$form_feed_delay = 0 .. 3000,
    ift$form_feed_seq_size = 0 .. ifc$max_form_feed_seq_size,
    ift$form_feed_sequence = record
      size: ift$form_feed_seq_size,
      value: string (ifc$max_form_feed_seq_size),
    recend,
    ift$line_feed_delay = 0 .. 1000,
    ift$line_feed_seq_size = 0 .. ifc$max_line_feed_seq_size,
    ift$line_feed_sequence = record
      size: ift$line_feed_seq_size,
      value: string (ifc$max_line_feed_seq_size),
    recend,
    ift$page_length = 0 .. 255,
    ift$page_width = 0 .. 255,
    ift$parity = (ifc$zero_parity, ifc$mark_parity,
      ifc$even_parity, ifc$odd_parity, ifc$no_parity),
    ift$status_action = (ifc$send_status, ifc$hold_status,
      ifc$discard_status);

?? PUSH (LISTEXT := ON) ??
*copyc ifc$terminal_constants
*copyc ift$terminal_class
*copyc ift$terminal_model
*copyc ift$terminal_name
*copyc ift$control_code_replacement
?? POP ??
*DECK DECK=IFT$TERMINAL_CLASS EXPAND=FALSE

  TYPE
    ift$terminal_class = (ifc$tty_class, ifc$c75x_class,
      ifc$c721_class, ifc$i2741_class, ifc$tty40_class,
      ifc$h2000_class, ifc$x364_class, ifc$t4010_class,
      ifc$hasp_post_class, ifc$c200ut_class, ifc$c714_30_40,
      ifc$c711_class, ifc$c714_10_20_class, ifc$hasp_pre_class,
      ifc$c73x_class, ifc$i2740_class, ifc$i3780_class,
      ifc$i3270_class);

*DECK DECK=IFT$TERMINAL_CONNECTION_TYPES EXPAND=FALSE


  TYPE
    ift$attention_character_action = 0 .. 9,
    ift$break_key_action = 0 .. 9,
    ift$end_of_information_size = 0 ..
      ifc$max_end_of_information_size,
    ift$end_of_information = record
      size: ift$end_of_information_size,
      value: string (ifc$max_end_of_information_size),
    recend,
    ift$input_block_size = 80 .. 2000,
    ift$input_editing_mode = (ifc$normal_edit, ifc$trans_edit),
    ift$input_output_mode = (ifc$unsolicited_output,
      ifc$solicited, ifc$full_duplex),
    ift$input_timeout_length = 0 .. 0fffff(16),
    ift$prompt_string_size = 0 .. ifc$max_prompt_string_size,
    ift$prompt_string = record
      size: ift$prompt_string_size,
      value: string (ifc$max_prompt_string_size),
    recend,
    ift$trans_character_mode = (ifc$no_trans_char,
      ifc$trans_char_terminate, ifc$trans_char_forward,
      ifc$trans_char_fwd_terminate),
    ift$trans_fwd_char_size = 0 .. ifc$max_trans_fwd_char_size,
    ift$trans_forward_character = record
      size: ift$trans_fwd_char_size,
      value: string (ifc$max_trans_fwd_char_size),
    recend,
    ift$trans_length_mode = (ifc$no_trans_len,
      ifc$trans_len_terminate, ifc$trans_len_forward,
      ifc$trans_len_forward_exact),
    ift$trans_message_length = 1 .. 32767,
    ift$trans_protocol_mode = (ifc$no_trans_protocol,
      ifc$trans_protocol_terminate, ifc$trans_protocol_forward),
    ift$trans_term_char_size = 0 .. ifc$max_trans_term_char_size,
    ift$trans_terminate_character = record
      size: ift$trans_term_char_size,
      value: string (ifc$max_trans_term_char_size),
    recend,
    ift$trans_timeout_mode = (ifc$no_trans_timeout,
      ifc$trans_timeout_terminate, ifc$trans_timeout_forward);

?? PUSH (LISTEXT := ON) ??
*copyc ifc$terminal_constants
?? POP ??
*DECK DECK=IFT$TERMINAL_DEFINITIONS EXPAND=FALSE

  TYPE
    ift$terminal_definitions = array [1 .. * ] of
      ift$terminal_model;

?? PUSH (LISTEXT := ON) ??
*copyc ift$terminal_model
?? POP ??
*DECK DECK=IFT$TERMINAL_MODE EXPAND=FALSE

  TYPE
    ift$terminal_mode = (ifc$line, ifc$screen);

*DECK DECK=IFT$TERMINAL_MODEL EXPAND=FALSE

  TYPE
    ift$terminal_model_size = 1 .. ifc$max_terminal_model_size;

  TYPE
    ift$terminal_model = record
      size: ift$terminal_model_size,
      value: string (ifc$max_terminal_model_size),
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ifc$terminal_constants
?? POP ??
*DECK DECK=IFT$TERMINAL_NAME EXPAND=FALSE
  TYPE
    ift$terminal_name = ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=IFT$TITLE_FOR_ERROR_CODES EXPAND=FALSE

?? NEWTITLE := 'IFDECC  : Interactive Facility    : ''IF'' 0 .. 9999' ??
*copyc IFE$ERROR_CODES
{allc ifdcerr

?? OLDTITLE ??
*DECK DECK=IFV$MODULE_FOR_C180 EXPAND=FALSE

{ Define cybil compile time variable to control differences in
{   c170/c180 source.

{ Define this module for c180 interactive use.

  ? VAR ifv$module_for_c180: boolean := TRUE ?;

*DECK DECK=IFV$PAUSE_UTILITY_COUNT EXPAND=FALSE
  VAR
    ifv$pause_utility_count: [XREF] ift$pause_utility_count;

?? PUSH (LISTEXT := ON) ??
*copyc ift$pause_utility_count
?? POP ??
*DECK DECK=IFV$TELNET_CONNECTION_LIMIT EXPAND=FALSE

  VAR
    ifv$telnet_connection_limit: [XREF] integer;
*DECK DECK=IIA$IIAPAS EXPAND=TRUE
          IDENT  IIAPAS
          TITLE  IIA$IIAPAS
          ENTRY  VEIAF
VEIAF     BSS    0
          JP     =XSW=MAIN
          END
*DECK DECK=IIA$MUJHELP EXPAND=TRUE
          IDENT  MUJHELP
          TITLE  IIA$MUJHELP
          ENTRY  CIORD,CIOWR
          ENTRY  CONNCT,DISCON
          ENTRY  CALLMUJ,GETVEID
          ENTRY  PUT1QP,SAVEMSG
          ENTRY  SETUP,REQUEST
          ENTRY  SAVEMEM,DUMPEN
          ENTRY  CLFIELD
          EXT    ZSMRENT,ZSMRRET
*COPYC    DSA$CYBIL_IF_MACROS
          SPACE  3
*         THE COMPASS CODE CONTAINS CYBIL-CALLABLE PROCEDURES TO SUP=
*         PORT NOS/BE-PASSON. AS REQUIRED BY CYBIL THE PARAMETERS OR
*         POINTERS TO THEM ARE IN X-REGISTERS. NO PROGRAM HAS MORE THAN
*         FOUR PARAMETERS, SO REGISTERS X5 AND B5 ARE FREE FOR USE BY
*         THE PROCEDURES. ALL PROCEDURES HAVE TO CALL THE PROLOG BEFORE
*         THEY START THEIR PROCESSING,THE RETURN ADDRESS IS SAVED IN RE=
*         REGISTER B5. EXIT IS ALWAYS MADE THROUGH EPILOG. THE REGISTER
*         B1 IS SET TO 1 BY CYBIL.
          SPACE  3
***       CLEAR A FIELD
*
*--       A FIELD OF GIVEN LENGTH IS CLEAREWD TO ZERO, FWA AND
*         LENGTH ARE PARAMETERS SUPPLIED BY THE CALLER. IF THE
*         LENGTH IS ZERO OR NEGATIVE NOTHING IS DONE.
*
*--       PARAMETERS:
*
*         1. FWA OF THE FIELD
*         2. LENGTH OF THE FIELD
*
 CLFIELD  RJ     ZSMRENT     CALL PROLOG
          NG     X2,ZSMRRET  EXIT IF LENGTH .LT. 0
          ZR     X2,ZSMRRET  EXIT IF LENGTH .EQ. 0
          MX7    0
          SA7    X1          CLEAR THE FIRST WORD OF THE FIELD
          SB5    X2
          SB5    B5-B1       CHECK ONE WORD, EXIT IF SO
          ZR     B5,ZSMRRET
 +        SA7    A7+B1       CLEAR NEXT WORD
          SB5    B5-B1       STEP COUNTER
          NZ     B5,*        LOOP
          EQ     ZSMRRET
          SPACE  3
***       STOP THE PROGRAM
*
*--       THIS PROGRAM ABORTS PASSON BY CREATING A MODE 0 ERROR
*         THE SYSTEM CAN THEN DUMP THE FIELDLENGTH. TWO NUMBERS
*         MAY BE SUPPLIED BY THE CALLER TO IDENTIFY THE DUMP, THEY
*         ARE SAVED IN LOCATION 20B AND 21B.
*
*--       PARAMETERS:
*
*         1. FIRST IDENTIFIER
*         2. SECOND IDENTIFIER
*
 DUMPEN   RJ     ZSMRENT     CALL PROLOG
 DUMP1    BX6    X1
          BX7    X2
          SA6    20B         SAVE CHARACTERISTICS
          SA7    21B
          EQ     *+400000B
          SPACE  3
***       GET NOS/VE USER-ID
*
*--       THE PASSWORD FILE IS ATTACHED USING PP-PROGRAMS IPP, FSN AND
*         PFA; IF THE PASSWORD FILE IS BUSY HOWEVER, WE SET THE ERROR-
*         FLAG TO -1 AND EXIT.
*         IF NOT BUSY THE FIRST TWO RECORDS ARE SKIPPED. THE THIRD RE=
*         CORD CONTAINS THE RESTRICTED PASSWORD FILE ENTRIES, EACH ENTRY
*         CONSISTS OF FIVE CM-WORDS. THE THIRD BYTE OF THE THIRD WORD
*         CONTAINS THE USER-ID, WHICH IS ALSO GIVEN AS SECOND PARAMETER
*         TO THIS PROCEDURE. THE RECORD IS SEARCHED FOR THE USER-ID, IF
*         FOUND THE NOS/VE USERNAME IS EXTRACTED FROM THE FOURTH WORD OF
*         THE ENTRY AND PUT INTO THE LOCATION, TO WHICH THE FIRST PARA=
*         METER POINTS; THE ERRORFLAG IS SET TO ZERO.
*         IF THE USER-ID IS NOT FOUND IN THE THIRD RECORD THEN THE 4TH
*         ONE IS SERACHED. IT CONTAINS THE UNRESTRICTED PASSWORDS AND
*         THE ENTRIES CONSIST OF FOUR CM-WORDS. AGAIN THE THIRD BYTE OF
*         THE THIRD WORD CONTAINS THE USER-ID FOR WHICH THE RECORD IS
*         SEARCHED. THE FOURTH WORD CONTAINS THE NOS/VE USERNAME. IF THE
*         ID IS FOUND, THE NOS/VE-ID IS EXTRACTED AND SAVED; THE ERROR
*         FLAG IS CLEARED.
*         IF THE USER-ID IS NOT FOUND OR THE NOS/VE USER-NAME IS ZERO,
*         THEN THE ERROR FLAG IS SET TO 1.
*         THIS ROUTINE ALSO GIVES INSTALLATIONS A HOOK TO CHANGE THE
*         FAMILY NAME THE THE USER LOGS IN TO ON NOS/VE.  TO LOGIN TO
*         A FAMILY OTHER THAN THE DEFAULT FAMILY, THE VALUE IN THE CELL
*         *FAMILY* (DEFINED AT THE END OF THIS DECK) MAY BE CHANGED TO
*         ANY VALUE (7 CHARACTER, BLANK FILLED) THE SITE MAY WANT.  THIS
*         FAMILY WILL APPLY TO ALL USERS.  IF A SITE WANTS TO HAVE A
*         FLEXIBLE FAMILY NAME, THEN THAT FAMILY MUST BE CALULATED AND
*         EITHER RETURNED IN X2 OR STORED IN THE CELL *FAMILY* AND
*         GETVEID WILL RETURN IT IN X2.
*
*--       PARAMETERS:
*
*         1. POINTER TO LOCATION FOR NOS/VE USER-NAME
*         2. POINTER TO LOCATION FOR NOS/VE FAMILY
*         3. THE INTERCOM USER-ID, RIGHT JUSTIFIED AND ZERO FILLED
*         4. POINTER TO THE ERROR-FLAG
*
 GETVEID  RJ     ZSMRENT     CALL PROLOG
          BX6    X4          COPY TO ERROR FLAG
          SA6    ERRADDR     SAVE ERROR FLAG ADDRESS
 GETVE1   SX6    3RIPP       FORM IPP CALL WORD
          SX5    B1
          SX4    FDB         FWA OF FDB
          LX6    2
          BX6    X5+X6
          LX6    40
          BX6    X6+X4
          MX7    0           CLEAR READY BIT OF FDB
          SA7    X4
          RJ     RAP         CALL IPP
          SA4    FSN         LOAD FSN CALL WORD
          MX0    48
          SA5    FDB         LOAD POINTER WORD
          AX5    12          EXTRACT POINTER
          BX7    -X0*X5
          SX0    X7+FDB+4    FORM ADDRESS OF OUR FDB
          BX6    X4+X0
          SA4    X0
          MX7    -1
          BX7    X7*X4       CLEAR READY BIT IN FDB
          SA7    X0
          RJ     RAP         CALL FSN
          SA5    PFA
          BX6    X5+X0       FORM PFA CALL WORD
          SA4    X0
          BX7    X7*X4       CLEAR READY BIT IN FDB
          SA7    X0
          RJ     RAP         CALL PFA TO ATTACH PASSWORD-FILE
          SA5    X0
          MX7    -9          EXTRACT RETURN CODE
          LX5    8-17
          BX7    -X7*X5      CHECK FOR FILE BUSY
          SX7    X7-37B
          NZ     X7,GETVE2   JUMP IF FILE NOT BUSY
          MX7    -1
          EQ     GETVE15     GO INDICATE FILE BUSY
*
 GETVE2   SA5    X0          GET NAME OF LOCAL FILE
          MX0    42
          BX6    X0*X5       PUT NAME INTO FET FOR PASSWORDFILE
          SA6    PET
          SX6    12B         SKIP FIRST RECORD
          RJ     GETCIO
          SX6    12B         SKIP SECOND RECORD
          RJ     GETCIO
          SB7    FDB         POINTER TO FIRST PACKAGE
*
 GETVE3   SX6    12B         GET NEXT DATA OF 3RD RECORD
          RJ     GETCIO
          SA4    PETI        GET POINTER IN
          SX7    X4-FDB
          ZR     X7,GETVE8   JUMP IF EOR, USER NOT IN 3RD RECORD
          SB5    X4
          MX7    48
 GETVE4   SA5    B7+2
          SB7    B7+5
          GT     B7,B5,GETVE41 IF END OF BUFFER
          AX5    24          EXTRACT USER ID
          BX5    -X7*X5
          BX4    X5-X3
          ZR     X4,GETVE7   JUMP IF USER FOUND
          EQ     GETVE4      TRY AGAIN

 GETVE41  SX4    B5-FDBE+1
          PL     X4,GETVE45  IF NOT EOR
          AX5    24          EXTRACT LAST USER ID IN 3RD RECORD
          BX5    -X7*X5
          BX4    X5-X3
          ZR     X4,GETVE7   JUMP IF USER FOUND
          EQ     GETVE8      TO PROCESS 4TH RECORD
 GETVE45  SA6    FDB
          SB7    B7-5
          EQ     B5,B7,GETVE6   JUMP IF NO REST
 GETVE5   SA5    B5-B1
          BX6    X5          MOVE REST TO TOP OF BUFFER
          SA6    A6-B1
          SB5    A5
          NE  B5,B7,GETVE5   LOOP FOR NEXT WORD OF REST
 GETVE6   SB7    A6
          EQ     GETVE3      GO READ NEXT DATA
*
 GETVE7   SA5    B7-2        GET WORD WITH VE-ID
          LX5    3
          BX6    X0*X5       EXTRACT VE-ID
          SA6    X1
          ZR     X6,GETVE10  JUMP IF VE-ID ZERO
          MX7    0
          EQ     GETVE12     GO CLEAR ERROR FLAG
*
 GETVE8   SX6    12B         GET NEXT DATA OF 4TH RECORD
          RJ     GETCIO
          SA4    PETI        GET POINTER IN
          SX7    X4-FDB
          ZR     X7,GETVE10  JUMP ON EOR, USER-ID NOT FOUND
          SB5    X4
          SB7    FDB         SET POINTERS
          MX4    48
*
 GETVE9   SA5    B7+2        GET WORD WITH USER-ID
          LX5    -24
          BX7    -X4*X5      EXTRACT USER-ID
          BX7    X7-X3
          ZR     X7,GETVE11  JUMP IF USER FOUND
          SB7    B7+4
          LT  B7,B5,GETVE9   LOOP FOR NEXT PACKAGE
          SX7    B5-FDBE+1
          ZR     X7,GETVE8   GO READ NEXT DATA BLOCK
 GETVE10  SX7    B1
          EQ     GETVE14     GO INDICATE ERROR
*
 GETVE11  MX0    18          EXTRACT LOWER 3 CHARACTERS
          BX7    X0*X5
          LX7    -24
          LX5    24          REPOSITION VE-ID
          MX4    24
          BX6    X4*X5       UPPER MOST 4 CHARACTERS
          BX6    X7+X6
          SA6    X1          SAVE VE-ID
          SX7    B1
          ZR     X6,GETVE14  JUMP IF VE-ID ZERO
 GETVE12  SA5    SPACS
          MX0    42          LOAD MASKS AND SPACES
          MX7    54
          BX6    X0*X6       CLEAR TRAILING CHARACTERS
          LX7    -6
 GETVE13  BX4    X7*X6       CHECK END OF STRING
          AX7    6
          NZ     X4,GETVE13  LOOP
          LX7    6
          BX5    X7*X5       EXTRACT AND INSERT SPACES
          BX6    X6+X5
          BX6    X0*X6       CLEAR LAST 18 BIT
          MX7    0
          SA6    X1          SAVE NAME IN MEMORY
          SA5    FAMILY      GET DEFAULT FAMILY NAME
          BX6    X5
          SA6    X2          RETURN FAMILY NAME
*
 GETVE14  SX6    174B        RETURN PASSWORD FILE
          RJ     GETCIO
 GETVE15  SA4    ERRADDR     GET ERROR ADDRESS
          SA7    X4          SET ERROR FLAG
          SX6    3RIPP
          LX6    42
          RJ     RAP         CALL IPP TO CLEAR NO SWAP CONDITIONS
*
*         ERASE AND MARK PASSWORD BUFFER PLUS EXTENSION
*
          MX6    30          MARK TO EASE DUMP ANALYSIS
          SB7    FDBL+4      NUMBER OF WORDS TO MARK
          LX6    15          15/77777B,30/0,15/77777B
 GETVE16  SA6    FDB-4+B7    MARK THE BUFFER
          SB7    B7-B1       DECREMENT THE INDEX
          GE     B7,B0,GETVE16  LOOP UNTIL ALL WORDS HAVE BEEN MARKED
          EQ     ZSMRRET     RETURN TO CALLER
*
 GETCIO   DATA   0
          SA5    PET         GET FIRST WORD OF PET
          BX5    X0*X5
          BX6    X6+X5       INSERT CODE
          SA6    A5
          SX6    FDB         SET POINTERS IN AND OUT
          SA6    PETI
          SA6    A6+B1
          SA5    CIOCLL      GET CIO CALL WORD
          BX6    X5
          RJ     RAP         CALL CIO
          SA5    PET         LOAD CODE AND STATUS
          BX5    -X0*X5
          EQ     GETCIO      EXIT
          SPACE  3
***       CALL PP-PROGRAM MUJ
*
*--       PP-PROGRAM "MUJ" IS CALLED TO CONNECT OR DISCONNECT THE PP-
*         PROGRAM "1QP" TO VEIAF. IF THE PARAMETER IS POSITIVE, THEN
*         A CONNECT IS REQUESTED, OTHERWISE, A DISCONNECT IS WANTED.
*         IN THE LATTER CASE "MUJ" IS CALLED WITH A ZERO PARAMETER.
*
*--       PARAMETERS:
*         1. FWA OF TERMIN/TERMOUT AREA
*
 CALLMUJ  RJ     ZSMRENT     CALL PROLOG
 CALL1    SA2    X1          CHECK ZERO-PARM, JUMP IF NOT
          PL     X2,CALL2
          MX1    0           CLEAR PARAMETER ADDRESS
 CALL2    SX6    3RMUJ
          LX6    42          FORM MUJ CALL WORD
          BX6    X6+X1
          RJ     RAP         CALL MUJ
          EQ     ZSMRRET
          SPACE  3
***       READ WITH CIO
*
*--       CIO IS CALLED TO READ ONE LINE FROM THE TYERMINAL; A 6-WORD
*         FET MUST BE USED. THE SIXTH WORD IS SET UP BY THE CALLING
*         PROGRAM, THE SECOND PARAMETER IS A POINTER TO THAT WORD. THE
*         FIRST PARAMETER POINTS TO THE HEADERWORD OF THE INPUT BLOCK,
*         DATA STARTS AT THE FOLLOWING WORD. A FET IS SET UP WITH CODE
*         12B AND IN=OUT=HDR+1; THEN CIO IS CALLED WITH AUTORECALL. THE
*         NUMBER OF CM-WORDS READ IS CALCULATED AND SENT TO THE CALLER;
*         THE ERROR CODE IS EXTRACTED AND ALSO SENT.
*
*--       PARAMETERS:
*         1. POINTER TO HEADER WORD
*         2. POINTER TO 6TH WORD OF FET
*         3. POINTER TO LOCATION FOR LENGTH
*         4. POINTER TO LOCATION FOR ERROR CODE
*
 CIORD    RJ     ZSMRENT     CALL PROLOG
 CRD1     SA5    HDR         GET FILENAME AND READ-CODE
          SA2    X2          GET INTERCOM WORD
          SX1    X1+B1       GET FWA OF DATA BLOCK
          BX6    X5
          BX7    X2
          SA6    FET         SET FILENAME AND CODE OF FET
          SA7    FET+5       SET INTERCOM WORD
          SX0    A6
          SA5    A6-B1       GET WORD FIRST
          SX7    X1+408
          BX6    X5+X1
          SA7    A7-B1       SET LIMIT
          SA6    A6+B1       SET FIRST
          SX6    X1
          SA6    A6+B1       SET IN
          SA6    A6+B1       SET OUT
          SX7    4*3RCIO+1
          LX7    40          FORM CIO COMMAND
          BX6    X7+X0
          RJ     RAP         CALL CIO
          SA2    FET+2
          SA5    A2+B1       LOAD POINTERS IN AND OUT
          IX6    X2-X5
          SA6    X3          SAVE NUMBER OF WORDS READ
          EQ     CWR2
          SPACE  3
***       WRITE WITH CIO
*
*--       CIO IS CALLED TO SEND THE CONTENTS OF THE MESSAGE BUFFER TO THE
*         TERMINAL; A SIX WORD FET MUST BE USED. THE SIXTH WORD IS SET UP
*         THE CALLER, THE 2ND PARAMETER IS A POINTER TO THAT WORD. THE
*         FIRST PARAMETER IS THE FWA OF THE INPUT BUFFER, THE FIRST WORD
*         OF WHICH CONTAINS THE MESSAGE HEADER; DATA STARTS WITH THE FOL=
*         LOWING WORD. A FET IS SET UP WITH CODE 26B, POINTERS FIRST AND
*         OUT ARE THE ADDRESS OF THE HEADER, THE VALUE OF POINTER IN IS
*         CALCULATED FROM FIRST AND LENGTH, WHICH IS THE THIRD PARAMETER.
*         CIO IS CALLED WITH AUTO RECALL; AN EVENTUAL ERROR CODE IS SENT
*         TO A WORD TO WHICH THE FOURTH PARAMETER POINTS. IF NO ERROR,
*         THIS LOCATION IS CLEARED.
*
*--       PARAMETERS:
*         1. POINTER TO HEADER WORD
*         2. POINTER TO 6TH WORD OF FET
*         3. LENGTH OF DATA IN CM-WORDS
*         4. POINTER TO LOCATION FOR ERROR CODE
*
 CIOWR    RJ     ZSMRENT     CALL PROLOG
 CWR1     SA5    HDR+1       GET FILENAME AND WRITE-CODE
          SA2    X2          GET INTERCOM WORD
          SX1    X1+B1       GET FWA OF DATA BLOCK
          BX6    X5
          BX7    X2
          SA6    FET         SET FILENAME AND CODE OF FET
          SA7    FET+5       SET INTERCOM WORD
          SX0    A6
          SA5    A6-B1       GET WORD FIRST
          SX7    X1+412
          BX6    X5+X1
          SA7    A7-B1       SET LIMIT
          SA6    A6+B1       SET FIRST
          SX6    X1
          IX7    X1+X3
          SA7    A6+B1       SET IN
          SA6    A7+B1       SET OUT
          SX7    4*3RCIO+1
          LX7    40          FORM CIO COMMAND
          BX6    X7+X0
          RJ     RAP         CALL CIO
 CWR2     SA1    FET         LOAD HEADER
          MX0    -5
          SX5    X1
          AX1    9           EXTRACT ERROR CODE
          BX7    -X0*X1
          SA7    X4          SAVE ERROR CODE
          EQ     ZSMRRET     RETURN
          SPACE  3
***       CONNECT FILE ZZZZZSG
*
*--       THE FILE ZZZZZSG IS CONNECTED TO THE TERMINAL BY CALLING THE
*         PP-PROGRAM "CON". IF ANY ERROR IS REPORTED THE PROGRAM IS
*         ABORTED.
*
*--       PARAMETERS: NO PARAMETERS
*
 CONNCT   RJ     ZSMRENT     CALL PROLOGS
 CON1     SA5    CON         LOAD FILE NAME
          MX7    0
 CON2     SX6    4*3RCON+1   CON COMMAND WITH AUTO-RECALL
          LX6    22
          BX6    X7+X6       INSERT CONNECT/DISCONNECT BIT
          LX6    18
          BX7    X5
          SA7    A5+B1       SET FILE NAME FOR CONNECT
          SX5    A7
          BX6    X6+X5
          RJ     RAP         CALL CON
          SA5    A7
          SX0    B1          CHECK FOR ERRORS
          LX0    1
          BX5    X0*X5
          BX7    -X7*X7
          ZR     X5,CON3     JUMP IF NO ERROR
          SX6    3RABT
          LX6    42          FORM ABT COMMAND
          RJ     RAP         CALL ABT
          EQ     *+400000B

 CON3     SA7    X1          INDICATE ERROR STATE
          EQ     ZSMRRET
          SPACE  3
***       DISCONNECT FILE ZZZZZSG
*
*--       THE FILE ZZZZZSG IS DISCONNECTED FROM THE TERMINAL BY CALLING
*         THE PP-PROGRAM "CON". IF ANY ERROR IS REPORTED THE PROGRAM IS
*         ABORTED.
*
*--       PARAMETERS: NO PARAMETERS
*
 DISCON   RJ     ZSMRENT     CALL PROLOG
 DIS1     SA5    CON         LOAD FILE NAME
          SX7    B1
          LX7    8           POSITION DISCONNECT BIT
          EQ     CON2        GO DISCONNECT
          SPACE  3
***       SEND 1QP-REQUEST TO TERMOUT
*
*--       A TERMOUT REQUEST IS FORMED FROM THE PARAMETERS 2 TO 4
*         THIS REQUEST IS PUT INTO TABLE TERMOUT, PARAMETER 1 IS
*         A POINTER TO THE RELATED LOCATION
*
*--       PARAMETERS:
*
*         1. POINTER TO TERMOUT-ENTRY
*         2. POINTER TO CONNECTION-CURRENCY
*         3. USER-ID
*         4. REQUEST
*
 PUT1QP   RJ     ZSMRENT     CALL PROLOG
 PUT1     SX6    X4-10       CHECK TERM-CHAR, JUMP IF SO
          PL     X6,PUT2
          MX2    0           CLEAR ADDRESS
 PUT2     LX2    12
          LX3    -12         POSITION USER-ID
          BX6    X2+X4
          BX6    X6+X3       FORM 1QP-REQUEST
          SA6    X1
          EQ     ZSMRRET     PLACE REQUEST AND EXIT
          SPACE  3
***       SAVE THE MESSAGES
*
*--       THE ROUTINE DUMPS DATA AND SUPERVISORY MESSAGES OF PASSON TO A
*         FILE ZZZDMP0. EACH MESSAGE IS PRECEDED BY A HEADER CONTAINING
*         LENGTH AND TYPE OF THE MESSAGE, LENGTH AND TYPE ARE PARAMETERS
*         OF THE PROCEDURE. IF THE LENGTH IS NEGATIVE THE DUMPFILE IS
*         CLOSED BY DUMPING THE BUFFER WITH EOR AND THEN IT IS MADE PER=
*         MANENT.
*
*--       PARAMETERS:
*
*         1. POINTER TO FWA OF MESSAGE
*         2. LENGTH OF MESSAGE IN CM-WORDS
*         3. TYPE OF MESSAGE
*
 SAVEMSG  RJ     ZSMRENT     CALL PROLOG
 SAVE1    PL     X2,SAVE2    JUMP IF NOT CLOSE
          SA3    SFET
          SX6    26B
          RJ     MSDMP       DUMP ALL CONTENTS OF BUFFER
          SA3    SFET
          SX1    1R0
          RJ     PERM        MAKE FILE PERMANENT AND EXIT
          EQ     ZSMRRET
*
 SAVE2    SA4    SIN         LOAD POINTERS IN AND OUT
          SA5    A4+2
          LX3    18          COMBINE TYPE AND LENGTH
          BX7    X3+X2
          SA7    X4          SAVE TYPE AND LENGTH
          SX5    X5-1
          SX4    X4+B1
          IX6    X5-X4       ADVANCE POINTER IN AND CHECK
          NZ     X6,SAVE3
          BX7    X4
          SA7    SIN         PUT POINTER IN INTO FET
          SA3    SFET
          SX6    16B
          RJ     MSDMP       DUMP FULL BUFFER
          SX2    X2
          ZR     X2,ZSMRRET  EXIT IF NO DATA
 SAVE3    SA1    X1-1
          SX2    X2          INITIALIZE LOOP
          ZR     X2,SAVE6    JUMP IF NO DATA
*
 SAVE4    SA1    A1+B1       MOVE NEXT WORD OF DATA
          BX7    X1
          SA7    X4
          SX4    X4+B1       ADVANCE IN AND CHECK
          IX6    X5-X4
          NZ     X6,SAVE5    JUMP IF IN .NE. LIMIT
          BX7    X4
          SA7    SIN         PUT POINTER IN INTO FET
          SA3    SFET
          SX6    16B
          RJ     MSDMP       DUMP FULL BUFFER
 SAVE5    SX2    X2-1
          NZ     X2,SAVE4    LOOP IF NOT ALL MOVED
 SAVE6    BX7    X4
          SA7    SIN         PUT POINTER IN INTO FET
          EQ     ZSMRRET
          SPACE  3
***       ISSUE A CIO-REQUEST FOR OUTPUT
*
*--       A CIO-REQUEST IS FORMATTED AND PUT INTO RA+1, THE RELATED
*         FET MUST BE SETUP BY THE CALLER. AFTER RETURN THE POINTERS
*         OF THE FET ARE RESET.
*
*--       ENTRY CONDITION, REGISTER CONTENTS
*
*         REGISTER X3: NAME OF FILE, RIGHTJUSTIFIED
*         REGISTER X6: CODE FOR CIO, LEFTJUSTIFIED AND ZERO FILLED
*         REGISTER A3: ADDRESS OF FET HEADER
*         REGISTER B1: CONSTAT 1
*
 MSDMP    DATA   0
          MX7    42          PUT NEW CODE INTO HEADERWORD
          BX7    X7*X3
          BX7    X7+X6
          SX6    4*3RCIO+1   FORM CIO COMMAND
          SX3    A3
          LX6    40
          SA7    A3          RESET HEADERWORD
          BX6    X3+X6
          RJ     RAP         CALL CIO
          SA4    A3+1
          SX4    X4          LOAD POINTERS FIRST AND LIMIT
          SA5    A4+3
          SX5    X5-1
          BX7    X4          RESET POINTERS IN AND OUT IN FET
          SA7    A4+B1
          SA7    A7+B1
          EQ     MSDMP       EXIT
          SPACE  3
***       GET ANALYST AND PERM-FILE ID
*
*--       THE PROCEDURE FETCHES THE USER-ID OF THE ANALYST FROM LOCATION
*         RA+2 IF PASSON WAS CALLED BY A PROCEDURE; THE LOWER 18 BIT OF
*         WORD 64B CONTAIN THE NUMBER OF PARAMETERS. IF MORE THAN ONE PA=
*         RAMETER IS SUPPLYED, THEN THE PERMFILE-ID IS ALSO FETCHED FROM
*         WORD RA+3 OR FROM WORDS RA+3 AND RA+4. AS HELP FOR DEBUGGING THE
*         FWA'S OF SOME TABLES ARE SAVED IN LOW CORE.
*
*--       PARAMETERS:
*
*         1. POINTER TO USER-ID OF ANALYST
*         2. INDICATOR FOR RESULT
*         3. POINTER TO MESSAGE BUFFER "MSG"
*         4. POINTER TO TABLE "CONNECTION_CURRENCY"
*         5. POINTER TO 1QP-TABLES TERMIN/TERMOUT
*
 SETUP    RJ     ZSMRENT     CALL PROLOG
          BX7    X3
          BX6    X4          SAVE THE ADDRESSES
          SA7    30B
          SA6    A7+B1
          BX7    X5
          SA7    A6+B1
          SA5    64B
          SB5    X5          GET NUMBER OF PARAMETERS
          NZ     B5,SETUP1   JUMP IF NOT ZERO
          MX7    0
          SA7    X2          SIGNAL NO DUMP AND EXIT
          EQ     ZSMRRET
*
 SETUP1   SA3    B1+B1       GET ANALYST ID AND SPACES
          SA5    SPACS
          MX0    42          CLEAR DELIMITER OF PARAMETER
          BX3    X0*X3
          LX0    -6
*
 SETUP2   BX6    X0*X3       CHECK TRAILING CHARACTERS FOR ZERO
          AX0    6
          NZ     X6,SETUP2   LOOP IF NOT
          LX0    6
          BX5    X0*X5       EXTRACT SPACES
          BX6    X5+X3
          SA6    X1          SAVE NAME WITH TRAILING BLANKS
          SB5    B5-B1
          ZR     B5,SETUP5   JUMP IF NO PERM-FILE ID
          SA3    A3+B1
          MX6    42          EXTRACT UPPER 7 CHARACTERS
          BX6    X6*X3
          SB5    B5-B1
          ZR     B5,SETUP3   JUMP IF NOT MORE CHARACTERS
          SA3    A3+B1
          MX0    12          GET NEXT CHARACTERS
          BX3    X0*X3
          LX3    -18
 SETUP3   BX6    X6+X3       COMBINE CHARACTERSTRINGS
          ZR     X6,SETUP5
          MX3    6
          LX3    -12
 SETUP4   BX7    X3*X6       REMOVE TRAILING ZEROES
          LX6    -6
          ZR     X7,SETUP4
          LX6    6           REPOSITION
          SX7    14B
          BX6    X6+X7       INSERT KEY FOR USER ID AND SAVE
          SA6    FDBD+1
 SETUP5   SX7    B1          INDICATE NAMES PRESENT
          SA7    X2
          EQ     ZSMRRET     EXIT
          SPACE  3
***       REQUEST PERMANENT FILE
*
*--       FOR THE FILE WITH NAME ZZZDMPN A PERMFILE DEVICE IS REQUESTED
*         USING PP-PROGRAM "REQ". THE LAST CHARACTER OF THE FILE NAME IS
*         ONE OF THE DIGITS 0 TO 9.
*
*--       PARAMETERS: ONLY ONE, THE DIGIT N
*
 REQUEST  RJ     ZSMRENT     CALL PROLOG
          SA5    REQPRM      GET NAME OF FILE
          MX6    36
          BX6    X6*X5       CLEAR STATUS
          LX1    18
          BX6    X6+X1       INSERT LOWER CHARACTER
          SA6    A5
          SX7    B1          SET UP 2ND WORD
          LX7    31
          SA7    A5+B1
          SX6    3RREQ       FORM REQ-CALL
          SX7    B1
          LX6    2           INSERT RECALL BIT
          BX6    X7+X6
          SX5    A5
          LX6    40          INSERT PARAMETER ADDRESS
          BX6    X6+X5
          RJ     RAP         CALL REQ
          EQ     ZSMRRET     EXIT
          SPACE  3
***       DUMP VARIABLES FOR DEBUGGING
*
*--       THE PROCEDURE IS CALLED BY THE SYSTEM ANALYST TO DUMP THE ME=
*         MORY OF PASSON TO A FILE "ZZZDMPN", WHERE N IS A DIGIT 1 TO 9.
*         THIS FILE IS THEN MADE PERMANENT.
*
*--       PARAMETERS:
*
*         1. FILE NUMBER N = 1,2 ... 9
*         2. POINTER TO MESSAGE BUFFER "MSG"
*         3. POINTER TO TABLE "CONNECTION_CURRENCY"
*         4. POINTER TO 1QP-TABLES TERMIN/TERMOUT
*
 SAVEMEM  RJ     ZSMRENT     CALL PROLOG
          BX7    X2
          BX6    X3          SAVE THE ADDRESSES
          SA7    30B
          SA6    A7+B1
          BX7    X4
          SA7    A6+B1
          MX7    0
          SA7    MEMREQ      CLEAR REQUESTWORD FOR MEM
          SX7    3RMEM
          LX7    2           FORM MEM COMMAND
          SX6    B1
          BX7    X7+X6       INSERT RECALL FLAG
          LX7    40
          SX6    A7          INSERT ADDRESS
          BX6    X7+X6
          RJ     RAP         CALL MEM
          SA3    MEMREQ
          LX3    30          GET FIELDLENGTH
          SX7    X3
          SA7    SDLIM       SET POINTER LIM OF FET
          MX6    0
          SX7    1000B
          SA6    A7-B1       SET POINTER OUT
          SA7    A6-B1       SET POINTER IN
          SA6    A7-B1       SET POINTER FIRST
          SA3    SDFET       GET HEADER OF FET
          MX6    36
          BX3    X6*X3       CLEAR LOWER 24 BIT
          LX1    18
          BX3    X3+X1       INSERT COUNTER
          SX6    16B
          RJ     MSDMP       DUMP LOWER MEMORY
          MX6    0
          SX7    1000B
          SA6    SDIN        SET POINTER IN
          SA7    A6+B1       SET POINTER OUT
          SA3    SDFET       GET HEADER OF FET
          SX6    26B
          RJ     MSDMP       DUMP REST OF MEMORY
          LX1    -18
          SA3    SDFET
          RJ     PERM        CATALOG FILE
          EQ     ZSMRRET     EXIT
          SPACE  3
***       MAKE A FILE PERMANENT
*
*--       A FILE WITH NAME ZZZDMPN, WHERE N IS A DIGIT 0 TO 9, IS MADE
*         PERMANENT BY USE OF PP-PROGRAM "PFC". AFTER THAT THE FILE IS
*         RETURNED. THE FILE MUST RESIDE ON A PERMFILE DEVICE, PROCEDURE
*         "PERM" MUST HAVE BEEN CALLED FOR THIS FILE. ANY REPORTED ER=
*         RORS ARE IGNORED.
*
*--       ENTRY CONDITIONS, REGISTER CONTENTS
*
*         REGISTER X1: NUMBER N AS DISPLAY CHARACTER, RIGHTJUSTIFIED
*                      AND ZERO FILLED
*         REGISTER X3: FILE NAME, LEFTJUSTIFIED
*         REGISTER A3: ADDRESS OF FET HEADER
*         REGISTER B1: CONSTANT 1
*
 PERM     DATA   0
          SA5    FDBD        GET NAME OF LOGICAL FILE
          MX6    36
          LX1    18
          BX6    X6*X5       CLEAR LAST CHARACTER AND STATUS
          BX6    X6+X1
          SA6    A5-4        INSERT NAME INTO FDB
          SA6    A5
          SX7    3RPFC       FORM PFC CALL
          SX6    B1
          LX7    2           INSERT RECALL BIT
          BX7    X7+X6
          LX7    40
          SX6    A5          INSERT FDB-ADDRESS
          BX6    X7+X6
          RJ     RAP         CALL PFC
          SX6    170B
          RJ     MSDMP       RETURN FILE
          EQ     PERM
          SPACE  3
***       PROCESS AN RA + 1 REQUEST
*
*--       PLACE A REQUEST IN RA+1 AND EXCHANGE TO CENTRAL MONITOR.
*
*--       PARAMETERS
*
*         X6 CONTAINS THE RA + 1 REQUEST WITH THE AUTORECALL BIT SET.
*
 RAP      DATA   0           ENTRY
 RAP1     SA5    B1          WAIT RA+1 CLEAR
          NZ     X5,RAP1
          SA6    B1
          XJ                 EXCHANGE TO CP MTR
          EQ     RAP
          SPACE  3
***       CONSTANTS AND WS
*
 MEMREQ   VFD    60/0
          VFD    42/7LZZZDMP0,18/0
          VFD    60/0,60/0,60/0
 FDBD     VFD    42/7HZZZDMP0,18/0
          VFD    54/9HPASSONDMP,6/14B
          VFD    60/0
 REQPRM   VFD    42/7HZZZDMP0,18/0
          VFD    30/2,30/0
 SPACS    VFD    42/7H       ,18/0
 CIOCLL   VFD    18/3RCIO,2/1,22/0,18/PET
 FSN      VFD    18/3RFSN,2/1,16/1,6/0,18/0
 PFA      VFD    18/3RPFA,2/1,22/0,18/0
 CON      VFD    42/7HZZZZZSG,18/0,60/0
 HDR      VFD    42/7HZZZZZSG,18/12B
          VFD    42/7HZZZZZSG,18/26B
          VFD    18/1,24/1,18/0
 FET      VFD    60/0,60/0,60/0,60/0,60/0,60/0
 PET      VFD    42/7HZZZZZII,18/0
          VFD    42/0,18/FDB
 PETI     VFD    42/0,18/FDB
 PETO     VFD    42/0,18/FDB
          VFD    42/0,18/FDBE
 SFET     VFD    42/7HZZZDMP0,18/1
          VFD    42/0,18/SBUF
 SIN      VFD    42/0,18/SBUF
          VFD    42/0,18/SBUF
          VFD    42/0,18/SBUFE
 SDFET    VFD    42/7HZZZDMP0,18/1
          VFD    42/0,18/0
 SDIN     VFD    42/0,18/0
          VFD    42/0,18/0
 SDLIM    VFD    42/0,18/0
*
 FDBL     EQU    129         LENGTH OF THE FDB BUFFER
          BSSZ   4
 FDB      BSSZ   FDBL        BUFFER FOR CIO AND PFA
 FDBE     EQU    *
 BUFLNG   EQU    8*64+1      LENGTH OF BUFFER FOR DUMP
          BSSZ   1
 SBUF     BSSZ   BUFLNG      BUFFER TO DUMP DEBUG DATA
 SBUFE    BSSZ   1

 ERRADDR  BSSZ   1           SAVE AREA FOR RETURN ADDRESS FOR GETVEID
 FAMILY   VFD    42/0,18/0   DEFAULT FAMILY TO BE USED BY GETVEID
*                            TO CHANGE THE DEFAULT FAMILY, CHANGE THE
*                            FAMILY VARIABLE SUCH THAT THE NEW FAMILY
*                            IS A LEFT JUSTIFIED BLANK FILLED 7 CHAR
*                            FIELD E.G. FAMILY   VFD  42/7LXXX    ,18/0
*
          END
*DECK DECK=IIC$VT_MAX_OUTPUT_MESS_LENGTH EXPAND=FALSE

CONST
  iic$vt_max_output_mess_length = 143;
*DECK DECK=IIC$XT_COMPILING_FOR_TRACE EXPAND=FALSE

?VAR
  iic$xt_compiling_for_trace: boolean := TRUE ?;

*DECK DECK=IIC$XT_JOB_CATALOG_NAME EXPAND=FALSE

  CONST
    iic$xt_job_catalog_name = '$JOBS';

*DECK DECK=IIC$XT_MAX_MESSAGE_LENGTH EXPAND=FALSE

  CONST
    iic$xt_max_message_length = 256;

*DECK DECK=IIC$XT_MESSAGE_OFFSET EXPAND=FALSE

  CONST
    iic$xt_message_offset = 21;

*DECK DECK=IIC$XT_STATUS_CATALOG_NAME EXPAND=FALSE

  CONST
    iic$xt_status_catalog_name = '$STATUS';

*DECK DECK=IIC$XT_XTERM_CATALOG_NAME EXPAND=FALSE

  CONST
    iic$xt_xterm_catalog_name = '$XTERM';

*DECK DECK=IIH$SUPPRESS_CURSOR_POS_ECHOPLX EXPAND=FALSE

{       This is the 223 agent used by IFP$SUPPRESS_CURSOR_POS_ECHOPLX
{   to write the job pageable variables
{   IIV$SUPPRESS_CURSOR_POSITIONING and IIV$SUPPRESS_ECHOPLEXING,
{   since it cannot write them directly.  IIM$ST_PUT reacts to the
{   setting of these variables by setting the
{   suppress_end_line_positioning and/or the suppress_echoplexing bit
{   in the header of the next non-partial output data message.
*DECK DECK=IIH$VTP_CREATE_CDCNET_CONNECT EXPAND=FALSE
{    This routine will send a create_cdcnet_connection VTP message to the
{ network and then wait for a response.  If the response is a
{ create_cdcnet_connection_confirm the routine will return normal status.  If
{ the response is a create_cdcnet_connection_reject the appropriate abnormal
{ status will be returned.  If a response is not received from the network
{ before the specified timeout interval expires abnormal status will be
{ returned.
{
{       IIP$VTP_CREATE_CDCNET_CONNECT (SERVICE_NAME, SERVICE_DATA,
{             CONNECTION_DATA_1, CONNECTION_DATA_2, CONNECTION_DATA_3,
{             END_DISCARD_PROMPT, TIMEOUT_INTERVAL_IN_MS, STATUS)
{
{ SERVICE_NAME: (input)  This parameter specifies the name of the service to
{       which a CDCNET connection is to be made.
{
{ SERVICE_DATA: (input)  This parameter specifies the data to be passed to
{       the connected service at connection establishment time.  For example,
{       for connections to a Telnet service, this would be the Telnet host name
{       or IP address.
{
{ CONNECTION_DATA_1: (input)  This parameter specifies the data to be sent as
{       the first VTP Normal Input message on the CDCNET connection.
{
{ CONNECTION_DATA_2: (input)  This parameter specifies the data to be sent as
{       the second VTP Normal Input message on the CDCNET connection.
{
{ CONNECTION_DATA_3: (input)  This parameter specifies the data to be sent as
{       the third VTP Normal Input message on the CDCNET connection.
{
{ END_DISCARD_PROMPT: (input)  This parameter specifies that all output from
{       the secondary connection be discarded, instead of sent to the user's
{       terminal, until a sequence of characters at the beginning of a new
{       line are found that match those specified on this parameter.
{
{ TIMEOUT_INTERVAL_IN_MS: (input)  This parameter specifies the time that this
{       procedure should wait for a response from the network before declaring
{       a timeout.
{
{ STATUS: (output) This parameter specifies the request status.
{   CONDITIONS:
{      ife$connection_already_switched
{      ife$cannot_create_connection
{      ife$cannot_locate_service
{      ife$invalid_connection_data
{      ife$invalid_service_data
{      ife$service_is_busy
*DECK DECK=IIH$VTP_CREATE_PAIRED_CONNECT EXPAND=FALSE
{
{    This routine will send a create_paired_connection VTP message to the
{ network and then wait for a response.  If the response is a
{ create_paired_connection_ confirm the routine will return normal status.  If
{ the response is a create_ paired_connection_reject the appropriate abnormal
{ status will be returned.  If a response is not received from the network
{ before the specified timeout interval expires abnormal status will be
{ returned.
{
{       IIP$VTP_CREATE_PAIRED_CONNECT (FILE_IDENTIFIER, DESTINATION_TITLE,
{             PAIRED_CONNECTION_DATA, TIMEOUT_INTERVAL_IN_MS, STATUS)
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the file identifer of the
{       connection's terminal file.
{
{ DESTINATION_TITLE: (input)  This parameter specifies the system id portion of
{       the destination's network address.
{
{ PAIRED_CONNECTION_DATA: (input)  This parameter specifies the data to be sent
{       to the caller's peer.
{
{ TIMEOUT_INTERVAL_IN_MS: (input)  This parameter specifies the time that this
{       procedure should wait for a response from the network to the paired
{       connect message before declaring a timeout.
{
{ STATUS: (output) This parameter specifies the request status.
{   CONDITIONS:
{      ife$vtp_create_paired_conn_rejct
*DECK DECK=IIH$VTP_DELETE_PAIRED_CONNECT EXPAND=FALSE

{PURPOSE:
{
{ This routine will send a delete_paired_connection VTP message to the network.
{
{ NOTE -
{    A request to delete a paired connection will be honored whether or not
{    the request is received from the user's current connection.
{
{       IIP$VTP_DELETE_PAIRED_CONNECT (PAIRED_CONNECTION_DATA, STATUS)
{
{ PAIRED_CONNECTION_DATA: (input) This parameter specifies the data to be
{       sent to the caller's peer.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=IIH$VTP_GET_NEXT EXPAND=FALSE

{PURPOSE:
{
{ IIP$VTP_GET_NEXT conceptually replaces AMP$GET_NEXT and AMP$GET_PARTIAL.  It
{ skips the Interactive FAP associated with the AMP$ interfaces, and directly
{ calls NAM/VE.  Thus device dependency is the responsibility of the application.
{
{ IIP$VTP_GET_NEXT has parameters similar to AMP$GET_NEXT, but has some
{ essential behavioral differences:
{
{   AMP$GET_NEXT always discards the VTP header.  IIP$VTP_GET_NEXT always
{   returns the VTP header thru an additional parameter. The header is
{   described by type IIT$VT_INPUT_INFORMATION.
{
{   AMP$GET_NEXT is normally used in conjunction with AMP$PUT_NEXT to
{   provide a variety of services.  IIP$VTP_GET_NEXT is intended to be used in
{   conjunction with IIP$VTP_PUT_NEXT, and they do not provide most of the
{   special services.  This is discussed in greater detail in the documentation
{   of IIP$VTP_PUT_NEXT.
{
{   With the AMP$ routines, the file identifier must be for a terminal file.
{   With the these routines, it must be that of a network file.
{   For the ordinary one-job/one-terminal architecture, filename $LOCAL.$TERMINAL
{   will suffice. IIP$VTP_OPEN_NETWORK will take care of this for you.
{
{ Compared to AMP$GET_NEXT, IIP$VTP_GET_NEXT adds some parameters.  One is used
{ to return the VTP header, as discussed above.  The other
{ new parameter is used by the application to specify input timeout.  This is
{ done because AMP$GET_NEXT normally uses the "input timeout" connection
{ attributes stored with the instance of open to know what to do.  Since
{ IIP$VTP_GET_NEXT has no capability to know which attributes belong with each
{ instance of open, it must have this information thru an extra parameter.
{ Remember that "input timeout" is not the same as transparent inter-character
{ timeout.
{
{ When an input timeout actually occurs, this is reflected by any of the error
{ codes nae$no_data_available, nae$no_event, or nae$data_transfer_timeout.
{ Note that these error codes are different from the ones returned by
{ AMP$GET_NEXT for input timeout.
{
{       IIP$VTP_GET_NEXT (FILE_IDENTIFIER, WORKING_STORAGE_AREA,
{         WORKING_STORAGE_LENGTH, TRANSFER_COUNT,
{         FILE_POSITION, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ WORKING_STORAGE_AREA: (input) This parameter specifies the address of the
{       first byte of a contiguous area bounded by the working_storage_length
{       into which all or part of a record from the file will be moved.
{       If the length of the record is less than the working storage length
{       the access method does NOT guarantee that the area between the
{       transfer count and the end of the working storage area will be left
{       unmodified.
{
{ WORKING_STORAGE_LENGTH: (input) This parameter specifies the size of the
{       working storage area. The size of the working storage area should
{       equal or exceed the length of the longest record to be input.
{       If a record exceeds the working storage length, subsequent
{       amp$get_partial requests may be issued to obtain the remainder.
{       A zero or negative value for working_storage_length is improper.
{
{ TIMEOUT: (input) This parameter specifies input timeout.
{
{ INPUT_INFORMATION: (output) This parameter specifies the Virtual Terminal
{       Protocol header associated with the input.
{
{ TRANSFER_COUNT: (output) This parameter specifies the number of bytes
{       of data moved to the working_storage_area by this request.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=IIH$VTP_OPEN_NETWORK EXPAND=FALSE

{ PURPOSE:
{
{ IIP$VTP_OPEN_NETWORK opens a network file and returns the file identifier.
{ It is built for simple one-job/one-terminal applications, so it just uses
{ $LOCAL.$TERMINAL as the filename.
{
{ An application can safely perform startup and shutdown I/O thru the normal
{ AMP$GET_xxx and AMP$PUT_xxx interfaces, including related interfaces for
{ attribute management such as IFP$STORE_TERM_CONN_ATTRIBUTES and
{ IFP$CHANGE_TERMINAL_ATTRIBUTES.  However, to achieve correct and efficient
{ results an application should use the I/O procedures IIP$VTP_GET_NEXT
{ and IIP$VTP_PUT_NEXT in combination for all I/O during the application's main
{ loop.  Any attributes that must be changed during main-loop processing can
{ be done thru IIP$VTP_PUT_NEXT.
{
{       IIP$VTP_OPEN_NETWORK (FILE_IDENTIFIER, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=IIH$VTP_PUT_NEXT EXPAND=FALSE

{PURPOSE:
{
{ IIP$VTP_PUT_NEXT conceptually replaces AMP$PUT_NEXT and AMP$PUT_PARTIAL.  It
{ bypasses the Interactive FAP associated with the AMP$ interfaces and calls
{ NAM/VE directly.  The application is responsible for device dependencies.
{
{ IIP$VTP_PUT_NEXT sends a message to the network.  The parameters
{ resemble AMP$PUT_NEXT, but there are essential behavioral differences:
{
{ 1. AMP$PUT_NEXT sends text, while IIP$VTP_PUT_NEXT sends a VTP message.
{ Note that text messages can be folded into the VTP protocol with the
{ appropriate header, IIT$VT_OUTPUT_INFORMATION.
{
{ 2. AMP$PUT_NEXT works with AMP$GET_NEXT to keep track of connection
{ attributes for various instances of open, and to download any changes
{ as needed.  IIP$VTP_PUT_NEXT is intended to be used with IIP$VTP_GET_NEXT,
{ and there is no concept of even saving connection attributes per instance
{ of open.  The application is responsible to know when connection attributes
{ should be downloaded, and can do so only thru IIP$VTP_PUT_NEXT with the right
{ VTP message; ie, you cannot use IFP$STORE_TERM_CONN_ATTRIBUTES.
{
{ 3. AMP$PUT_NEXT attempts to compact text messages into a large buffer,
{ to reduce the number of actual VTP messages to the network.  IIP$VTP_PUT_NEXT
{ always calls the network, thus it is up to the application to perform
{ any buffering for best performance.   THIS IS VERY IMPORTANT!
{
{ 4. AMP$PUT_NEXT and AMP$GET_NEXT work together to manage the "partial"
{ bit to help the network know when to perform delayed echoing if the
{ "solicited" input/output mode is in effect.  IIP$VTP_GET_NEXT always sends
{ a fake output message to suppress the "partial" bit;  however, IIP$VTP_PUT_NEXT
{ assumes that the application will correctly set the "partial" bit for any
{ textual messages.
{
{ 5. With the AMP$ routines, the file identifier must be for a terminal file.
{ With the these routines, it must be that of a network file.  For the ordinary
{ one-job/one-terminal architecture, filename $LOCAL.$TERMINAL will suffice.
{ IIP$VTP_OPEN_NETWORK will take care of this for you.
{
{ To output text, generate a working_storage_area and working_storage_length
{ which starts with the IIT$VT_OUTPUT_INFORMATION record and is followed by
{ the actual text, with the length being equal to the size of the output
{ information record plus the actual number of bytes of text.  Set the output
{ information record as follows:
{
{   output_information.message_type := iic$vt_output_data_message;
{   output_information.fill_0 := 0;
{   output_information.reserved_1 := 0;
{   output_information.reserved_2 := 0;
{   output_information.formatting_mode := 0;  { this is transparent output
{   output_information.secured.suppress_end_line_positioning := FALSE;
{   output_information.secured.suppress_echoplexing := FALSE;
{   output_information.partial := TRUE;
{
{ Note that the formatting_mode of zero provides transparent output, for which
{ the network adds no carriage return or line feed; only those bytes generated
{ into the application's buffer will be sent.  A formatting mode of one will
{ generate normal output, for which CR/LF are generated wherever the output
{ buffer contains an Ascii unit separator code (hex 1F).
{
{ To output any application-to-TIP messages read the VTP ERS document to
{ determine the desired message formats.
{
{       IIP$VTP_PUT_NEXT (FILE_IDENTIFIER,
{         WORKING_STORAGE_AREA, WORKING_STORAGE_LENGTH, STATUS)
{
{ FILE_IDENTIFIER: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ WORKING_STORAGE_AREA: (input) This parameter specifies the address of the
{       record to be output.
{
{ WORKING_STORAGE_LENGTH: (input) This parameter specifies the length of the}
{       record to be output.}
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=IIHSTOP EXPAND=FALSE
{   The purpose of this request is to end a job's connection with the
{  170 network.  Any output issued to a terminal device after this
{  point will be discarded.  Intended for use only by PM.

{   IFP$STOP_INTERACTIVE
*DECK DECK=III$FETCH_OPEN_FILE_DESC_PTR EXPAND=FALSE
        IF file_id_is_valid AND
          (file_instance <> NIL) THEN
          IF file_instance^.device_class =
            rmc$terminal_device THEN
            open_file_dsc_pointer :=
            file_instance^.open_file_dsc_pointer;
          ELSE
            osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$file_name_not_terminal,
              file_instance^.local_file_name,status);
          IFEND;
        ELSE
          osp$set_status_abnormal (ifc$interactive_facility_id,
            ife$file_name_not_terminal,
            'NON_TERMINAL_FILE',status);
        IFEND;
*DECK DECK=III$FETCH_ST_OPEN_FILE_DESC_PTR EXPAND=FALSE
        IF file_id_is_valid AND
          (file_instance <> NIL) THEN
          IF file_instance^.device_class =
            rmc$terminal_device THEN
            st_open_file_dsc_pointer :=
            file_instance^.st_open_file_dsc_pointer;
          ELSE
            osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$file_name_not_terminal,
              file_instance^.local_file_name,status);
          IFEND;
        ELSE
          osp$set_status_abnormal (ifc$interactive_facility_id,
            ife$file_name_not_terminal,
            'NON_TERMINAL_FILE',status);
        IFEND;
*DECK DECK=IIK$KEYPOINTS EXPAND=FALSE

  CONST
    iik$change_terminal_attributes = iik$base + 0,
    {E 'iip$change_terminal_attributes' }
    {X 'iip$change_terminal_attributes' }

    iik$change_term_conn_attributes = iik$base + 1,
    {E 'iip$change_term_conn_attributes' }
    {X 'iip$change_term_conn_attributes' }

    iik$change_term_conn_defaults = iik$base + 2,
    {E 'iip$change_term_conn_defaults' }
    {X 'iip$change_term_conn_defaults' }

    iik$fetch_term_conn_attributes = iik$base + 3,
    {E 'iip$fetch_term_conn_attributes' }
    {X 'iip$fetch_term_conn_attributes' }

    iik$wait_for_passon = iik$base + 4,
    {D 'ii wait for passon' }

    iik$get_terminal_attributes = iik$base + 5,
    {E 'iip$get_terminal_attributes' }
    {X 'iip$get_terminal_attributes' }

    iik$get = iik$base + 6,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'II_get_next_ds_terminal_input' }
    {X 'II_get_next_ds_terminal_input' }
*ELSE
    {E 'iip$get' }
    {X 'iip$get' 'status  ' I20 }
*IFEND

    iik$send_output_message = iik$base + 7,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'II_send_output_to_ds_network' }
    {X 'II_send_output_to_ds_network' }
*ELSE
    {E 'iip$send_output_message' }
    {X 'iip$send_output_message' }
*IFEND

    iik$st_get = iik$base + 8,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'II_get_next_terminal_input' }
    {X 'II_get_next_terminal_input' }
*ELSE
    {E 'iip$st_get' }
    {X 'iip$st_get' }
*IFEND

    iik$send_prompt = iik$base + 9,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'II_send_prompt_to_terminal' }
    {X 'II_send_prompt_to_terminal' }
*ELSE
    {E 'send_prompt' }
    {X 'send_prompt' }
*IFEND

    iik$st_send_output_message = iik$base + 10;
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'II_send_output_to_network' }
    {X 'II_send_output_to_network' }
*ELSE
    {E 'iip$st_send_output_message' }
    {X 'iip$st_send_output_message' }
*IFEND

?? PUSH (LISTEXT := ON) ??
*copyc AMK$BASE_KEYPOINT_VALUES
?? POP ??
*DECK DECK=IIK$VT_KEYPOINTS EXPAND=FALSE

  CONST
    iik$vt_input = iik$vt_base + 0,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'II_get_input_from_terminal'}
    {X 'II_get_input_from_terminal'}
*ELSE
    {E 'iip$vt_input'}
    {X 'iip$vt_input'}
*IFEND

    iik$vt_get_next_special_block = iik$vt_base + 1;
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'II_get_response_from_network'}
    {X 'II_get_response_from_network'}
*ELSE
    {E 'iip$vt_get_next_special_block'}
    {X 'iip$vt_get_next_special_block'}
*IFEND

?? PUSH (LISTEXT := ON) ??
*copyc AMK$BASE_KEYPOINT_VALUES
?? POP ??
*DECK DECK=IIM$ALLOCATE_OR_FREE_SPACE EXPAND=TRUE
MODULE iim$allocate_or_free_space;
*copyc OSD$DEFAULT_PRAGMATS
?? TITLE := 'MODULE iim$allocate_or_free_space' ??

{ WARNING:
{    THESE ROUTINES ASSUME THAT ALL REQUIRED LOCKS HAVE BEEN SET PRIOR
{    TO THEIR INVOCATION.

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIK$KEYPOINTS
*copyc OST$STATUS
*copyc osp$system_error
*copyc iiv$interactive_terminated
*copyc OSV$JOB_PAGEABLE_HEAP
*copyc OSV$TASK_PRIVATE_HEAP
*copyc OSV$TASK_SHARED_HEAP
?? POP ??

?? NEWTITLE := 'PROCEDURE [XDCL, #GATE] iip$allocate_queue_entry' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iip$allocate_queue_entry (queue_key: iit$queue_key;
    VAR queue_entry_descriptor: iit$queue_entry_descriptor;
    VAR status: ost$status);


    status.normal := TRUE;
    queue_entry_descriptor.queue_key := queue_key;

    CASE queue_key OF

    = iic$connection_description =

      ALLOCATE queue_entry_descriptor.connection_description_ptr:
        [iiv$network_identifier] IN osv$task_shared_heap^;
      IF queue_entry_descriptor.connection_description_ptr = NIL THEN
      osp$system_error('Interactive failure', NIL);
      IFEND;

    = iic$terminal_request =
      ALLOCATE queue_entry_descriptor.terminal_request_ptr IN
        osv$task_shared_heap^;

    = iic$open_file_description =
      ALLOCATE queue_entry_descriptor.open_file_description_ptr IN
        osv$task_private_heap^;

    = iic$downline_queue =
      osp$system_error('Interactive failure', NIL);

    = iic$repeat_queue =
      osp$system_error('Interactive failure', NIL);

    ELSE
      status.normal := FALSE;

    CASEND;

  PROCEND iip$allocate_queue_entry;

?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE [XDCL, #GATE] iip$st_allocate_queue_entry' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iip$st_allocate_queue_entry (queue_key: iit$queue_key;
    VAR queue_entry_descriptor: iit$st_queue_entry_descriptor;
    VAR status: ost$status);


    status.normal := TRUE;
    queue_entry_descriptor.queue_key := queue_key;

    CASE queue_key OF

    = iic$connection_description =


      ALLOCATE queue_entry_descriptor.connection_description_ptr:
        [iiv$network_identifier] IN osv$job_pageable_heap^;
      IF queue_entry_descriptor.connection_description_ptr = NIL THEN
      osp$system_error('Interactive failure', NIL);
      IFEND;

    = iic$open_file_description =
      ALLOCATE queue_entry_descriptor.open_file_description_ptr IN
        osv$task_private_heap^;

    = iic$downline_queue =
      osp$system_error('Interactive failure', NIL);

    ELSE
      status.normal := FALSE;

    CASEND;

  PROCEND iip$st_allocate_queue_entry;

?? OLDTITLE ??
?? NEWTITLE := ' PROCEDURE [XDCL, #GATE] iip$free_queue_entry' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iip$free_queue_entry (queue_key: iit$queue_key;
    VAR queue_entry_descriptor: iit$queue_entry_descriptor;
    VAR status: ost$status);

    status.normal := TRUE;

    CASE queue_key OF

    = iic$connection_description =
      IF queue_entry_descriptor.connection_description_ptr <> NIL THEN
        FREE queue_entry_descriptor.connection_description_ptr IN
          osv$job_pageable_heap^;
      IFEND;

    = iic$terminal_request =
      IF queue_entry_descriptor.terminal_request_ptr <> NIL THEN
        FREE queue_entry_descriptor.terminal_request_ptr IN
          osv$task_shared_heap^;
      IFEND;

    = iic$open_file_description =
      IF queue_entry_descriptor.open_file_description_ptr <> NIL THEN
        FREE queue_entry_descriptor.open_file_description_ptr IN
          osv$task_private_heap^;
      IFEND;

    = iic$downline_queue =
      osp$system_error('Interactive failure', NIL);

    = iic$repeat_queue =
      osp$system_error('Interactive failure', NIL);

    ELSE
      status.normal := FALSE;

    CASEND;

  PROCEND iip$free_queue_entry;
?? OLDTITLE ??
?? NEWTITLE := ' PROCEDURE [XDCL, #GATE] iip$st_free_queue_entry' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iip$st_free_queue_entry (queue_key: iit$queue_key;
    VAR queue_entry_descriptor: iit$st_queue_entry_descriptor;
    VAR status: ost$status);

    status.normal := TRUE;

    CASE queue_key OF

    = iic$connection_description =
      IF queue_entry_descriptor.connection_description_ptr <> NIL THEN
        FREE queue_entry_descriptor.connection_description_ptr IN
          osv$job_pageable_heap^;
      IFEND;

    = iic$open_file_description =
      IF queue_entry_descriptor.open_file_description_ptr <> NIL THEN
        FREE queue_entry_descriptor.open_file_description_ptr IN
          osv$task_private_heap^;
      IFEND;

    = iic$downline_queue =
      osp$system_error('Interactive failure', NIL);

    ELSE
      status.normal := FALSE;

    CASEND;

  PROCEND iip$st_free_queue_entry;
MODEND iim$allocate_or_free_space;
*DECK DECK=IIM$ASCII_170_TO_HEX EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Interactive Facility' ??
?? NEWTITLE := '  [XDCL] iip$ascii_170_to_hex' ??
MODULE iim$ascii_170_to_hex;


{ Global Constants and Types
*copyc IFV$MODULE_FOR_C180
*copyc oss$job_paged_literal
?? SET (LIST := OFF) ??
*copyc iit$application_names_messages
?? SET (LIST := ON) ??

?? TITLE := 'PROCEDURE [XDCL] iip$ascii_170_to_hex', EJECT ??

  PROCEDURE [XDCL] iip$ascii_170_to_hex (ascii: iit$170_ascii_word;
    VAR hex: string ( * ));

    VAR
      length: integer,
      i: integer,
      hex_digits: [STATIC, READ, oss$job_paged_literal] array [0 .. 0f(16)] of char := ['0', '1', '2', '3',
        '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'];

{ Determine the number of hex digits to convert

    IF STRLENGTH (hex) < 15 THEN
      length := STRLENGTH (hex) - 1;
    ELSE
      length := 14;
    IFEND;

{ Convert half-bytes (nibbles) to hexadecimal digits

    FOR i := 0 TO length DO
      IF i < 8 THEN
        hex (i + 1) := hex_digits [ascii.left_nibble [i]];
      ELSE
        hex (i + 1) := hex_digits [ascii.right_nibble [i - 8]];
      IFEND;
    FOREND;

{ Blank fill any remaining characters in the hex string

    FOR i := 16 TO STRLENGTH (hex) DO
      hex (i) := ' ';
    FOREND;
  PROCEND iip$ascii_170_to_hex;
MODEND
*DECK DECK=IIM$BLOCK_MANAGEMENT_UTILITIES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS

MODULE iim$block_management_utilities;

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc OSV$170_OS_TYPE
?? POP ??


?? TITLE := 'PROCEDURE iip$build_super_msg_skeleton', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$build_super_msg_skeleton (posm:
    ^iit$output_supervisory_message;
    osm_type: iit$supervisory_message_type;
    osm_length: iit$text_length);

{  PURPOSE:
{    The purpose of this procedure is to build a skeleton output supervisory
{    message containing the standard output supervisory message information.
{

    posm^.header.block_type := iic$supervisory_block;
    posm^.header.address := iic$supervisory_connection_num;
    posm^.header.character_type := iic$60_bit_characters;
    posm^.message_type := osm_type;
    posm^.header.text_length := osm_length;

  PROCEND iip$build_super_msg_skeleton;

?? TITLE := 'PROCEDURE iip$build_data_msg_skeleton', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$build_data_msg_skeleton (podm: ^iit$output_data_message;
    odm_length: iit$text_length);

{  PURPOSE:
{    The purpose of this procedure is to build a skeleton output data message
{    containing the stanard output data message information.
{
    VAR
      status: ost$status;

    podm^.header.block_type := iic$continued_block;

{  Application character type 2 will be used with NOS dual state systems.
{  Application character type 3 will be used with NOS/BE dual state systems.

    IF osv$170_os_type = osc$ot7_dual_state_nos_be THEN
      podm^.header.character_type := iic$8_of_12_bit_characters;
    ELSE
      podm^.header.character_type := iic$8_bit_characters;
    IFEND;

    podm^.header.suppress_echo := FALSE;
    podm^.header.auto_input := FALSE;
    podm^.header.text_length := odm_length;

  PROCEND iip$build_data_msg_skeleton;

?? TITLE := 'PROCEDURE iip$convert_downline_block', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$convert_downline_block (pib: ^cell;
    pob: ^cell;
    input_block_length: mlt$message_length;
    VAR output_block_length: mlt$message_length);

{  PURPOSE:
{    The purpose of this procedure is to convert a C180 Downline Block
{    to a C170 Downline Block which can be sent to the NAM.
{  DESIGN:
{    The conversion is accomplished by moving 4 bits at a time from the
{    C180 Downline Block to the C170 Downline Block while inserting the
{    upper 4 bits of each C170 word.
{

    VAR
      pins,
      pons: ^iit$nibble_string,
      i,
      j: integer;

    pins := pib;
    pons := pob;

    IF osv$170_os_type = osc$ot7_dual_state_nos_be THEN
{   Copy header word into the C170 downline block.}

      FOR i := 1 TO 15 DO
        pons^ [i] := pins^ [i];
      FOREND;

{   Move 4 bits at a time from C180 block to C170 block inserting 4 zero
{   bits at the front of each word and each 8-of-12 character.

      i := 16;
      j := 16;
      WHILE i <= 2 * input_block_length DO
        IF j MOD 16 = 0 THEN
          pons^ [j] := 0;
          j := j + 1;
        IFEND;
        pons^ [j] := 0;
        pons^ [j + 1] := pins^ [i];
        pons^ [j + 2] := pins^ [i + 1];
        j := j + 3;
        i := i + 2;
      WHILEND
    ELSE

      j := 1;

      FOR i := 1 TO 2 * input_block_length DO
        IF j MOD 16 = 0 THEN
          pons^ [j] := 0;
          j := j + 1;
        IFEND;
        pons^ [j] := pins^ [i];
        j := j + 1;
      FOREND;
    IFEND;

    output_block_length := (j + 1) DIV 2;

  PROCEND iip$convert_downline_block;

MODEND iim$block_management_utilities;
*DECK DECK=IIM$BREAK_HANDLER EXPAND=TRUE
?? RIGHT := 110 ??
MODULE iim$break_handler;
{
{  PURPOSE:
{        The purpose of this module is to handle interactive conditions.

  TYPE
    iit$task_queued_conditions = SET of ifc$pause_break .. ifc$job_reconnect;

  VAR
    iiv$task_queued_conditions: [XDCL, oss$task_private] iit$task_queued_conditions :=
      $iit$task_queued_conditions [],
    initial_put_info: [READ, oss$job_paged_literal] iit$task_put_info := [1, 0,
      amc$terminate, FALSE, FALSE, FALSE, 0];

?? PUSH (LISTEXT := ON) ??
*copyc ift$condition_codes
*copyc ifc$interrupt
*copyc iik$keypoints
*copyc ife$error_codes
*copyc tmc$signal_identifiers
*copyc iit$interactive_signal_type
*copyc iit$connection_description
*copyc iip$add_sender
*copyc iip$build_super_msg_skeleton
*copyc iip$clear_lock
*copyc iip$delete_queue_entry
*copyc iip$delete_queue_entry
*copyc iip$flush
*copyc iip$free_queue_entry
*copyc iiv$interactive_terminated
*copyc iiv$output
*copyc iip$sign_on
*copyc iip$sign_off
*copyc iip$set_lock
*copyc iip$send_to_pass_on
*copyc iip$receive_from_pass_on
*copyc iip$report_status_error
*copyc iiv$int_task_open_file_count
*copyc iiv$connection_desc_ptr
*copyc jme$queued_file_conditions
*copyc tmc$wait_times
*copyc pmp$long_term_wait
*copyc pmp$ready_task
*copyc pmp$send_signal
*copyc osv$job_pageable_heap
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osv$task_private_heap
*copyc osp$test_sig_lock
*copyc osp$test_set_job_sig_lock
*copyc osp$clear_job_signature_lock
*copyc pmp$log
*copyc osp$system_error
*copyc jmp$system_job
*copyc pmt$condition_information
*copyc pmt$condition
*copyc pmp$begin_timesharing_condition
*copyc pmp$begin_timesharing_handler
*copyc pmp$disestablish_cond_handler
*copyc pmp$enable_timesharing_io
*copyc pmp$enable_ts_io_in_tasks
*copyc pmp$end_timesharing_handler
*copyc pmp$establish_condition_handler
*copyc pmp$ts_task_io_enabled
*copyc pmp$zero_ts_conditions_in_task
*copyc pmp$continue_to_cause
*copyc jmv$jcb
*copyc jmv$terminal_io_disabled
*copyc pmv$task_execution_phase
PROCEDURE [XREF] iip$complete_reconnect;
PROCEDURE [XREF] iip$complete_disconnect;
?? POP ??

?? TITLE := ' PROCEDURE  iip$begin_condition ', EJECT ??

  PROCEDURE [XDCL] iip$begin_condition (condition: ift$interactive_condition;
    VAR status: ost$status);

    VAR
      isig: ^iit$interactive_signal,
      signal: pmt$signal,
      tqc: ift$interactive_condition,
      i,
      mult,
      igtid: integer,
      iiv$break_application_name: mlt$application_name,
      dqlock: boolean,
      ls: ost$signature_lock_status,
      gtid: ost$global_task_id,
      iiv$abort_get: [XREF] boolean,
      iiv$job_output: [XREF] ^seq(*),
      osm: iit$output_supervisory_message;

    IF iiv$task_condition_in_progress THEN
      pmp$log ('IF: condition queued within task already processing condition',
            status);
      iiv$task_queued_conditions := iiv$task_queued_conditions +
        $iit$task_queued_conditions [condition];
      RETURN;
    IFEND;

    status.normal := TRUE;
    iiv$task_condition_in_progress := TRUE;
    dqlock := TRUE;

{ Enable this task to do IO on the connection.

    pmp$enable_timesharing_io;
    pmp$begin_timesharing_condition;

    osp$test_sig_lock (iiv$get_lock, ls);
    IF ls = osc$sls_locked_by_current_task THEN
{ do nothing ... continue condition processing
    ELSE
      IF ls = osc$sls_locked_by_another_task THEN
        igtid := iiv$get_lock.lock_id;

      /assemble_gtid/
        BEGIN
          mult := 1;
          FOR i := 1 TO #SIZE (gtid.seqno) DO
            mult := mult * 256;
          FOREND;

          IF (igtid DIV mult) > UPPERVALUE (gtid.index) THEN
            EXIT /assemble_gtid/;
          IFEND;
          gtid.index := igtid DIV mult;
          IF (igtid MOD mult) > UPPERVALUE (gtid.seqno) THEN
            EXIT /assemble_gtid/;
          IFEND;
          gtid.seqno := igtid MOD mult;
          iiv$abort_get := TRUE;
          pmp$ready_task (gtid, status);
        END /assemble_gtid/;
      IFEND;

{ wait for any 'get' to clear

      iip$set_lock (iiv$get_lock, osc$wait, status);
      iiv$get_info.position_in_block := 1;
      iiv$get_info.file_position := amc$eor;
      iiv$get_info.cancel_input := FALSE;
      iip$clear_lock (iiv$get_lock, status);
    IFEND;

    osp$test_sig_lock (iiv$downline_queue_lock, ls);
    IF ls = osc$sls_locked_by_current_task THEN
      dqlock := FALSE;
{ do nothing ... continue condition processing
    ELSE
      IF ls = osc$sls_locked_by_another_task THEN
        igtid := iiv$downline_queue_lock.lock_id;

      /asm_gtid_dql/
        BEGIN
          mult := 1;
          FOR i := 1 TO #SIZE (gtid.seqno) DO
            mult := mult * 256;
          FOREND;

          IF (igtid DIV mult) > UPPERVALUE (gtid.index) THEN
            EXIT /asm_gtid_dql/;
          IFEND;
          gtid.index := igtid DIV mult;
          IF (igtid MOD mult) > UPPERVALUE (gtid.seqno) THEN
            EXIT /asm_gtid_dql/;
          IFEND;
          gtid.seqno := igtid MOD mult;
          pmp$ready_task (gtid, status);
        END /asm_gtid_dql/;
      IFEND;
    IFEND;

{ lock downline/repeat queues and adjust their contents based on the abn
{ found in the nam break sm.

    IF dqlock THEN
      iip$set_lock (iiv$downline_queue_lock, osc$wait, status);
    IFEND;
    reset iiv$output;
    reset iiv$job_output;
    iiv$downline_queue_count := 0;
    iiv$put_info := initial_put_info;
    IF dqlock THEN
      iip$clear_lock (iiv$downline_queue_lock, status);
    IFEND;


{ discard any typed ahead input - this must be done before the reset is sent

    IF (condition = ifc$pause_break) OR (condition = ifc$terminate_break) THEN
      iip$discard_typed_ahead_input (FALSE);
    IFEND;

{ enable terminal (for this task)


    IF (condition = ifc$pause_break) OR (condition = ifc$terminate_break) THEN

{ restart terminal

      iip$sign_on (iiv$break_application_name, status);
      IF NOT status.normal THEN
        osp$system_error ('IF - break cant signon', ^status);
      IFEND;
      iip$add_sender (iiv$break_application_name, status);


      iip$build_super_msg_skeleton (#LOC (osm), iic$sm_resume_output_mark,
            iic$l_resume_output_mark);
      osm.header.address := iiv$job_connection;
      osm.header.character_type := iic$8_bit_characters;
      osm.header.block_number := 0;
      iip$send_to_pass_on (iiv$break_application_name, #LOC (osm),
            (iic$l_resume_output_mark + 1) * 8, iic$output_data_message +
            iiv$job_connection, status);


{ send intr/resp here

      iip$build_super_msg_skeleton (#LOC (osm), iic$sm_interrupt_response,
            iic$l_interrupt_response);
      osm.interrupt_response.alpha := CHR (0);
      osm.interrupt_response.connection_number := iiv$job_connection;
      osm.interrupt_response.fill1 := 0;
      iip$send_to_pass_on (iiv$break_application_name, #LOC (osm),
            (iic$l_interrupt_response + 1) * 8, iic$output_supervisory_message,
            status);
      IF NOT status.normal THEN
        iip$report_status_error (status, 'send to passon');
      IFEND;
      iip$sign_off (iiv$break_application_name, status);
    ELSEIF condition = ifc$terminal_connection_broken THEN
      iip$complete_disconnect;
    ELSEIF condition = ifc$job_reconnect THEN
      iip$complete_reconnect;
    IFEND;

    iiv$task_condition_in_progress := FALSE;

    WHILE iiv$task_queued_conditions <> $iit$task_queued_conditions [] DO
      FOR tqc := ifc$pause_break TO ifc$job_reconnect DO
        IF tqc IN iiv$task_queued_conditions THEN
          iiv$task_queued_conditions := iiv$task_queued_conditions -
            $iit$task_queued_conditions [tqc];
          iip$begin_condition (tqc, status);
        IFEND;
      FOREND;
    WHILEND;

    signal.identifier := ifc$signal_id;
    isig := #LOC (signal.contents);
    isig^ := iic$resume_task;
    pmp$send_signal (iiv$job_monitor_task_id, signal, status);


  PROCEND iip$begin_condition;
?? TITLE := ' PROCEDURE [XDCL, #GATE] iip$discard_typed_ahead_input', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$discard_typed_ahead_input (save: boolean);

    VAR
      status: ost$status,
    locked: boolean,
      appl: mlt$application_name,
      ls: ost$signature_lock_status,
      osm: iit$output_supervisory_message,
      upline_data: iit$input_supervisory_message,
      upline_length: mlt$message_length;

    osp$test_sig_lock (iiv$get_lock, ls);
    IF ls <> osc$sls_locked_by_current_task THEN
      osp$test_set_job_sig_lock (iiv$get_lock, locked);
      IF NOT locked THEN
        { cannot get lock - skip it.
        RETURN;
      IFEND;
    IFEND;
    iip$sign_on (appl, status);
    IF NOT status.normal THEN
      IF ls <> osc$sls_locked_by_current_task THEN
        osp$clear_job_signature_lock (iiv$get_lock);
      IFEND;
      RETURN;
    IFEND;
    iip$add_sender (appl, status);
    IF NOT status.normal THEN
      IF ls <> osc$sls_locked_by_current_task THEN
        osp$clear_job_signature_lock (iiv$get_lock);
      IFEND;
      iip$sign_off (appl, status);
      RETURN;
    IFEND;


{ fetch and discard all typed ahead input
    iip$build_super_msg_skeleton (#LOC (osm), iic$sm_read_request,
          iic$l_read_request);
    osm.read_request.connection_number := iiv$job_connection;
    osm.read_request.begin_absentee := FALSE; {** note **}
    osm.read_request.notify_if_absentee_started := FALSE;

  /fetch_type_ahead/
    BEGIN
      REPEAT
        iip$send_to_pass_on (appl, #LOC (osm), (iic$l_read_request + 1) * 8,
              iic$output_supervisory_message, status);
        IF NOT status.normal THEN
          EXIT /fetch_type_ahead/;
        IFEND;
        iip$receive_from_pass_on (appl, #LOC (upline_data), #SIZE
              (upline_data), upline_length, status);
        IF NOT status.normal THEN
          EXIT /fetch_type_ahead/;
        IFEND;
      UNTIL ((upline_data.header.block_type = iic$supervisory_block) AND
            ((upline_data.message_type = iic$sm_break_indication_mark) OR
            (upline_data.message_type = iic$sm_read_rejected))) OR
            (upline_data.header.block_type = iic$null_block);
    END /fetch_type_ahead/;

    IF ls <> osc$sls_locked_by_current_task THEN
      osp$clear_job_signature_lock (iiv$get_lock);
    IFEND;
    iip$sign_off (appl, status);

  PROCEND iip$discard_typed_ahead_input;
?? TITLE := ' PROCEDURE [XDCL, #gate] iip$check_for_condition', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$check_for_condition (VAR status: ost$status);

    VAR
      signal: pmt$signal,
      isig: ^iit$interactive_signal,
      start: [STATIC] integer,
      time: [STATIC] integer := 0,
      eh: pmt$established_handler;

?? NEWTITLE := 'PROCEDURE handle_break', EJECT ??

    PROCEDURE handle_break (cond: pmt$condition;
          cd: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR ch_status: ost$status);

      VAR
        local_status: ost$status;

{ return to screen with abnormal status

      time := 0;
      pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);

      CASE cond.interactive_condition OF
      = ifc$pause_break =
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$pause_break_received, '', status);
      = ifc$terminate_break =
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$terminate_break_received, '', status);
      = ifc$terminal_connection_broken =
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$connection_break_disconnect, '', status);
      = ifc$job_reconnect =
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$terminal_reconnected_to_job, '', status);
      ELSE
        osp$set_status_abnormal (ifc$interactive_facility_id, 0,
          'unknown interactive condition encountered', status);
      CASEND;
      EXIT iip$check_for_condition;

    PROCEND handle_break;
?? OLDTITLE ??
?? EJECT ??

    IF jmv$terminal_io_disabled THEN
      osp$set_status_condition (jme$job_is_in_termination, status);
      RETURN;
    IFEND;

    IF (pmv$task_execution_phase > pmc$task_executing) THEN
      osp$set_status_condition (jme$task_is_in_termination, status);
      RETURN;
    IFEND;

    IF iiv$interactive_terminated THEN
      {Ignore all conditions if terminating.
      status.normal := TRUE;
      RETURN;
    IFEND;

    IF iiv$job_suspended THEN
      pmp$establish_condition_handler (iiv$condition_descriptor, ^handle_break,
            ^ eh, status);
      pmp$log (' interactive timeout begins', status);

{ note that time and start are job environment variables and will
{ be used by any task executing this code.

      IF time = 0 THEN
        start := #free_running_clock (0);
        time := jmv$jcb.detached_job_wait_time * 1000;
      IFEND;

    /check_timeout/
      BEGIN

      /timeout/
        WHILE time > 0 DO
          pmp$long_term_wait (time, time);
          IF NOT iiv$job_suspended THEN

{ reconnected ....

            time := 0;
            EXIT /check_timeout/;
          IFEND;
          IF jmv$jcb.detached_job_wait_time <> jmc$unlimited_det_job_wait_time THEN
            time := (jmv$jcb.detached_job_wait_time * 1000) - ((#free_running_clock (0) -
                  start) DIV 1000);
          IFEND;
        WHILEND /timeout/;

{ signal jmtr to exit

        signal.identifier := ifc$signal_id;
        isig := #LOC (signal.contents);
        isig^ := iic$jmtr_start_timeout;
        pmp$send_signal (iiv$job_monitor_task_id, signal, status);


{ Return with abnormal status to the user

        osp$set_status_abnormal ('JM', jme$job_is_in_termination, '', status);
        RETURN;
      END /check_timeout/;
    IFEND;

    IF NOT pmp$ts_task_io_enabled () THEN
      pmp$establish_condition_handler (iiv$condition_descriptor, ^handle_break,
            ^ eh, status);
      WHILE NOT pmp$ts_task_io_enabled () DO
        pmp$long_term_wait (tmc$infinite_wait, 100000000);
      WHILEND;
      {Force a return to the screen so this routine will be recalled
      {and all previous conditions will be checked again!!!! (like disconnect)
      osp$set_status_abnormal (ifc$interactive_facility_id,
            ife$pause_break_received, '', status);
      RETURN;
    IFEND;
    status.normal := TRUE;

  PROCEND iip$check_for_condition;
?? TITLE := ' PROCEDURE iip$discard_suspended_output', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$discard_suspended_output;
  PROCEND iip$discard_suspended_output;
MODEND iim$break_handler
*DECK DECK=IIM$BUILD_TERM_CHAR_VALUES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$build_term_char_values;
?? TITLE := 'MODULE iim$build_term_char_values' ??

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIV$INTERACTIVE_TERMINATED
*copyc OST$STATUS
*copyc PMP$LOG
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$build_term_char_values', EJECT ??

  PROCEDURE [XDCL] iip$build_term_char_values (open_file_desc_pointer:
    ^iit$open_file_description);

    VAR
      ofdp: ^iit$open_file_description,
      status: ost$status,
      field_value_pointer: ^iit$field_value;

    ofdp := open_file_desc_pointer;  { for coding convenience. }

  { Set break key action.

    IF ofdp^.attributes.break_key_action.value = 0 THEN
      ofdp^.term_char_values [iic$key_user_break_1] := 0;           {iic$key_user_break_1 maps to BR:  FN=33(16)}
    ELSE
      ofdp^.term_char_values [iic$key_user_break_1] := 1;
    IFEND;

  { Set input editing mode.

    IF ofdp^.attributes.input_editing_mode.value = ifc$normal_edit THEN
      ofdp^.term_char_values [iic$key_trans_input_mode] := 0;       {iic$key_trans_input_mode:  FN=34(16)}
    ELSEIF ofdp^.attributes.input_editing_mode.value = ifc$trans_edit THEN
      ofdp^.term_char_values [iic$key_trans_input_mode] := 1;
    ELSE
      pmp$log (' Attribute value is out of range in iim$build_tc_values', status);
    IFEND;

  { Set input output mode.

    IF (ofdp^.attributes.input_output_mode.value = ifc$unsolicited_output) THEN
      ofdp^.term_char_values [iic$key_full_duplex] := 0;            {iic$key_full_duplex:  FN=57(16)}
      ofdp^.term_char_values [iic$key_solicited_mode] := 0;
    ELSEIF (ofdp^.attributes.input_output_mode.value =
          ifc$solicited) THEN
      ofdp^.term_char_values [iic$key_full_duplex] := 0;
      ofdp^.term_char_values [iic$key_solicited_mode] := 1;
    ELSEIF (ofdp^.attributes.input_output_mode.value =
          ifc$full_duplex) THEN
      ofdp^.term_char_values [iic$key_full_duplex] := 1;
      ofdp^.term_char_values [iic$key_solicited_mode] := 0;
    ELSE
      pmp$log (' Attribute value is out of range in iim$build_tc_values', status);
    IFEND;

  { Set partial character forwarding.

    IF ofdp^.attributes.partial_char_forwarding.value THEN
    { block mode }
      ofdp^.term_char_values [iic$key_input_device] := iiv$downline_input_device_conv
            [ifc$block_mode_input];
    ELSE
    { keyboard input device }
      ofdp^.term_char_values [iic$key_input_device] := iiv$downline_input_device_conv
            [ifc$keyboard_input];
    IFEND;

  { Set store backspace character.

    IF ofdp^.attributes.store_backspace_character.value THEN
      IF NOT (ofdp^.attributes.store_nuls_dels.value) THEN
      { turn special editing on }
        ofdp^.term_char_values [iic$key_special_editing] := 1;
      IFEND;
    ELSE
      { turn special editing off }
        ofdp^.term_char_values [iic$key_special_editing] := 0;
    IFEND;

  { Set store nuls dels.

    IF ofdp^.attributes.store_nuls_dels.value THEN
      IF ofdp^.attributes.store_backspace_character.value THEN
      { turn full ascii on }
        ofdp^.term_char_values [iic$key_full_ascii] := 1;
      IFEND;
    ELSE
      { turn full ascii off }
        ofdp^.term_char_values [iic$key_full_ascii] := 0;
    IFEND;

  { Set transparent character mode.

    CASE ofdp^.attributes.trans_character_mode.value OF
    = ifc$no_trans_char =
      ofdp^.term_char_values [iic$key_trans_delim_char_select] := 0;  { FN=38(16) }
    = ifc$trans_char_terminate =
      ofdp^.term_char_values [iic$key_trans_delim_char_select] := 1;
    = ifc$trans_char_forward, ifc$trans_char_fwd_terminate =
      ofdp^.term_char_values [iic$key_trans_delim_char_select] := 1;
    ELSE
      pmp$log (' Attribute value is out of range in iim$build_tc_values', status);
    CASEND;

  { Set transparent length mode.

    CASE ofdp^.attributes.trans_length_mode.value OF
    = ifc$no_trans_len =
      ofdp^.term_char_values [iic$key_trans_delim_count_most] := 0;  { FN=39(16) }
      ofdp^.term_char_values [iic$key_trans_delim_count_least] := 0;  { FN=3A(16) }
    = ifc$trans_len_terminate =
    = ifc$trans_len_forward, ifc$trans_len_forward_exact =
    ELSE
      pmp$log (' Attribute value is out of range in iim$build_tc_values', status);
    CASEND;

  { Set transparent timeout mode.

    CASE ofdp^.attributes.trans_timeout_mode.value OF
    = ifc$no_trans_timeout =
      ofdp^.term_char_values [iic$key_trans_delim_timeout] := 0;  { FN=3C(16) }
    = ifc$trans_timeout_terminate =
      ofdp^.term_char_values [iic$key_trans_delim_timeout] := 1;
      ofdp^.term_char_values [iic$key_trans_mode_delim_lock] := 0; { FN=92(16) 'sticky' }
    = ifc$trans_timeout_forward =
      ofdp^.term_char_values [iic$key_trans_delim_timeout] := 1;
      ofdp^.term_char_values [iic$key_trans_mode_delim_lock] := 1;
    ELSE
      pmp$log (' Attribute value is out of range in iim$build_tc_values', status);
    CASEND;

  { Set transparent input type.

    IF (ofdp^.attributes.trans_character_mode.value = ifc$trans_char_forward) OR
          (ofdp^.attributes.trans_character_mode.value = ifc$trans_char_fwd_terminate) OR
          (ofdp^.attributes.trans_length_mode.value = ifc$trans_len_forward) OR
          (ofdp^.attributes.trans_length_mode.value = ifc$trans_len_forward_exact) OR
          (ofdp^.attributes.trans_timeout_mode.value = ifc$trans_timeout_forward) THEN
      ofdp^.term_char_values [iic$key_trans_input_type] := 1;       { FN=46(16) }
    ELSE
      ofdp^.term_char_values [iic$key_trans_input_type] := 0;
    IFEND;

  { Set transparent delimiter end count, i.e., transparent message length.

    IF ofdp^.attributes.trans_length_mode.value <>
          ifc$no_trans_len THEN
      ofdp^.term_char_values [iic$key_trans_delim_count_most]
            := ofdp^.attributes.trans_message_length.value
            DIV 100(16);
      ofdp^.term_char_values [iic$key_trans_delim_count_least]
            := ofdp^.attributes.trans_message_length.value
            MOD 100(16);
    ELSE
      ofdp^.term_char_values [iic$key_trans_delim_count_most] := 0;
      ofdp^.term_char_values [iic$key_trans_delim_count_least] := 0;
    IFEND;

  { Set transparent forwarding character.

    field_value_pointer := #LOC (ofdp^.attributes.trans_forward_character.value.value);
    ofdp^.term_char_values [iic$key_trans_delim_character] := field_value_pointer^;  { FN=3B(16) }

  { Set transparent terminate character.

    field_value_pointer := #LOC (ofdp^.attributes.trans_terminate_character.value.value);
    ofdp^.term_char_values [iic$key_trans_mode_delim_char] := field_value_pointer^;  { FN=45(16) }

  PROCEND iip$build_term_char_values;
MODEND iim$build_term_char_values;
*DECK DECK=IIM$CHANGE_TERMINAL_ATTRIBUTES EXPAND=TRUE
*copyc osd$default_pragmats
MODULE iim$change_terminal_attributes;

{ PURPOSE:  This ring 2 module changes the terminal attributes for a dual
{           state connection to the attribute values specified on a SETTA
{           or CHATA command.
{
{  DESIGN:  The input attribute keys and values are validated and then a
{           CNTL/CHAR/R message is built using the input attribute values.
{           This message is sent downline to PASSON to effect the terminal
{           characteristics change in the TIP.  The connection descriptor's
{           terminal attributes are finally updated with the new attribute
{           values.
{
{           Note that as of 3/6/86 this module does not wait for a normal
{           response (i.e., CNTL/CHAR/N) to ensure that the TIP was actually
{           changed.  Consequently, if an attribute change is rejected by
{           the network for some reason, this module would not detect it
{           and would unknowingly update the connection descriptor with the
{           wrong values.
{
?? TITLE := 'MODULE iim$change_terminal_attributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc CLP$VALIDATE_NAME
*copyc IFE$ERROR_CODES
*copyc IFT$TERMINAL_ATTRIBUTE_TYPES
*copyc IIK$KEYPOINTS
*copyc IIP$ADD_SENDER
*copyc IIP$BUILD_SUPER_MSG_SKELETON
*copyc IIP$CHANGE_TERMINAL_CLASS
*copyc IIP$CLEAR_LOCK
*copyc IIP$CONVERT_DOWNLINE_TERM_CHAR
*copyc IIP$FLUSH
*copyc IIP$REPORT_STATUS_ERROR
*copyc IIP$REQUEST_DEFAULT_ATTRIBUTES
*copyc IIP$SEND_TO_PASS_ON
*copyc IIP$SET_LOCK
*copyc IIP$SIGN_ON
*copyc IIP$SIGN_OFF
*copyc IIP$TERMINAL_TO_VT_ATTRIBUTES
*copyc IIT$VT_CONNECTIONS
*copyc IIP$VT_CREATE_ATTRIBUTE_OCTETS
*copyc IIV$CONNECTION_DESC_PTR
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIV$INT_TASK_OPEN_FILE_COUNT
*copyc JMP$SYSTEM_JOB
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc OST$STATUS
*copyc OSP$APPEND_STATUS_INTEGER
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSS$JOB_PAGED_LITERAL
?? POP ??

{ Static variables.

  VAR
    fake_file_id: [READ,OSS$JOB_PAGED_LITERAL] amt$file_identifier := [0, 1];

?? NEWTITLE := 'PROCEDURE iip$change_terminal_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$change_terminal_attributes (terminal_attributes:
    ift$terminal_attributes;
    VAR status: ost$status);

    VAR
      array_of_octets: ^array [1 .. *] of iit$term_char_pair,
      buffer: ^SEQ (*),
      cdp: ^iit$connection_description,
      char_value: char,
      conflicting_attribute: string (osc$max_name_size),
      current_control_char_values: array [1 .. iic$number_of_control_chars] of char,
      define_term_char_message: iit$output_data_message,
      delay: 0 .. 250,
      field_value_pointer: ^iit$field_value,
      i: integer,
      index: integer,
      iiv$chata_application_name: mlt$application_name,
      j: integer,
      k: integer,
      length_of_octets: nat$data_length,
      local_status: ost$status,
      new_control_char_values: array [1 .. iic$number_of_control_chars] of char,
      osm: iit$output_supervisory_message,
      page_length: integer,
      page_width: integer,
      set_of_end_line_positions: iit$set_of_end_line_positions,
      set_of_end_part_positions: iit$set_of_end_part_positions,
      set_of_parity_modes: iit$set_of_parity_modes,
      set_of_status_actions: iit$set_of_status_actions,
      set_of_terminal_attribute_keys: iit$terminal_attribute_keys_set,
      set_of_terminal_classes: iit$set_of_terminal_classes,
      terminal_class: boolean,
      term_class: iit$terminal_class,
      term_char_message_length: mlt$message_length,
      vt_attributes: ^iit$vt_attributes;

    status.normal := TRUE;

    #KEYPOINT (osk$entry, 0 , iik$change_terminal_attributes);

  { Get the pointer to the connection description.

    iip$set_lock (iiv$connection_desc_lock, osc$wait, local_status);
    cdp := iiv$connection_desc_ptr;
    iip$clear_lock (iiv$connection_desc_lock, local_status);

  { Build a define terminal characteristics message to change terminal
  { attributes.

    IF iiv$cdcnet_connection THEN
      iip$build_super_msg_skeleton (^osm, iic$sm_cdcnet_define_term_char, 0);
    ELSE
      iip$build_super_msg_skeleton (^osm, iic$sm_define_term_char, 0);
    IFEND;
    osm.header.address := cdp^.connection_number;
    osm.header.character_type := iic$8_bit_characters;
    index := 1;
    length_of_octets := 0;
    terminal_class := FALSE;

  { Validate the terminal attribute keys.

    set_of_terminal_attribute_keys := - $iit$terminal_attribute_keys_set [];
    FOR i := LOWERBOUND (terminal_attributes) TO UPPERBOUND
          (terminal_attributes) DO
      IF NOT (terminal_attributes [i].key IN set_of_terminal_attribute_keys)
            THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$unknown_attribute_key, '', status);
        k := ORD (terminal_attributes [i].key);
        osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
              FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
        RETURN;
      IFEND;
    FOREND;

    IF iiv$cdcnet_connection THEN

{ Validate character attribute values and page length and width.

      page_length := 0;           { Initialize these variables to legal values. }
      page_width := 0;

   /validate_character_attributes/
      FOR i := 1 TO UPPERBOUND (terminal_attributes) DO
        CASE terminal_attributes [i].key OF
        = ifc$attention_character =
          char_value := terminal_attributes [i].attention_character;
        = ifc$begin_line_character =
          char_value := terminal_attributes [i].begin_line_character;
        = ifc$backspace_character =
          char_value := terminal_attributes [i].backspace_character;
        = ifc$cancel_line_character =
          char_value := terminal_attributes [i].cancel_line_character;
        = ifc$network_command_character =
          char_value := terminal_attributes [i].network_command_character;
        = ifc$end_partial_character =
          char_value := terminal_attributes [i].end_partial_character;
        = ifc$terminal_class =
          terminal_class := TRUE;
          term_class := iiv$downline_term_class_conv [terminal_attributes [i] .terminal_class];
          CYCLE /validate_character_attributes/;
        = ifc$page_length =
          page_length := terminal_attributes [i].page_length;
          CYCLE /validate_character_attributes/;
        = ifc$page_width =
          page_width := terminal_attributes [i].page_width;
          CYCLE /validate_character_attributes/;
        ELSE
          CYCLE /validate_character_attributes/;
        CASEND;

        k := ORD (char_value);
        IF (k > 7f(16)) { the character is non-ascii } OR
           ((k >= 30(16)) AND (k <= 39(16))) { number } OR
           ((k >= 41(16)) AND (k <= 5a(16))) { uppercase letter } OR
           ((k >= 61(16)) AND (k <= 7a(16))) { lowercase letter } THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$attr_val_disallowed_by_nam, 'this Character attribute', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 16,
                TRUE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
          RETURN;
        IFEND;
      FOREND /validate_character_attributes/;

      IF (page_length < LOWERVALUE (ift$page_length)) OR
            (page_length > UPPERVALUE (ift$page_length)) OR (page_length = 1) THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$page_length, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, page_length, 10,
              FALSE, status);
        page_length := LOWERVALUE (ift$page_length);
        osp$append_status_integer (osc$status_parameter_delimiter, page_length, 10,
              FALSE, status);
        page_length := UPPERVALUE (ift$page_length);
        osp$append_status_integer (osc$status_parameter_delimiter, page_length, 10,
              FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
        RETURN;
      IFEND;

      IF (page_width < LOWERVALUE (ift$page_width)) OR
            (page_width > UPPERVALUE (ift$page_width)) OR
            ((page_width > 0) AND (page_width < 10)) THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$page_width, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, page_width, 10,
              FALSE, status);
        page_width := LOWERVALUE (ift$page_width);
        osp$append_status_integer (osc$status_parameter_delimiter, page_width, 10,
              FALSE, status);
        page_width := UPPERVALUE (ift$page_width);
        osp$append_status_integer (osc$status_parameter_delimiter, page_width, 10,
              FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
        RETURN;
      IFEND;

      PUSH vt_attributes: [1 .. UPPERBOUND (terminal_attributes)];
      iip$terminal_to_vt_attributes (terminal_attributes, vt_attributes^);
      PUSH buffer: [[REP iic$vt_max_output_mess_length OF cell]];
      iip$vt_create_attribute_octets (vt_attributes^, buffer, length_of_octets);
      RESET buffer;
      IF length_of_octets > 0 THEN
        NEXT array_of_octets: [1 .. (length_of_octets MOD 2) + (length_of_octets DIV 2) ] IN buffer;
        osm.cdcnet_define_term_char.array_of_octets := array_of_octets^;
      IFEND;
    ELSE
    { Get the current control character values.

      j := 1;
      current_control_char_values [j] := cdp^.terminal_attributes.backspace_character;
      j := j + 1;
      current_control_char_values [j] := cdp^.terminal_attributes.cancel_line_character;
      j := j + 1;
      current_control_char_values [j] := cdp^.terminal_attributes.end_line_character;
      j := j + 1;
      current_control_char_values [j] := cdp^.terminal_attributes.network_command_character;
      j := j + 1;
      current_control_char_values [j] := cdp^.terminal_attributes.pause_break_character;
      j := j + 1;
      current_control_char_values [j] := cdp^.terminal_attributes.terminate_break_character;

    { Initialize the new control character values.

      FOR j := 1 TO iic$number_of_control_chars DO
        new_control_char_values [j] := '=';
      FOREND;

    { Validate the attribute values.

      iip$set_lock (cdp^.lock, osc$wait, status);
      IF status.normal THEN

      /validate_attributes/
        FOR i := LOWERBOUND (terminal_attributes) TO UPPERBOUND
              (terminal_attributes) DO

          CASE terminal_attributes [i].key OF

          = ifc$backspace_character =

            k := ORD (terminal_attributes [i].backspace_character);
            IF ((terminal_attributes [i].backspace_character = '=') OR
                  (k > 7f(16)) { the character is non-ascii } OR
                  ((k >= 30(16)) AND (k <= 39(16))) { number } OR
                  ((k >= 41(16)) AND (k <= 5a(16))) { uppercase letter } OR
                  ((k >= 61(16)) AND (k <= 7a(16)))) { lowercase letter } THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$attr_val_disallowed_by_nam, 'BACKSPACE_CHARACTER', status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 16,
                    TRUE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

            conflicting_attribute := '  ';

          /check_backspace_conflict/
            FOR j := 1 TO iic$number_of_control_chars DO
              IF iiv$control_char_descriptions [j].key = ifc$backspace_character
                    THEN
                new_control_char_values [j] := terminal_attributes[i].backspace_character;
                CYCLE /check_backspace_conflict/;
              ELSEIF terminal_attributes [i].backspace_character =
                    current_control_char_values [j] THEN
                conflicting_attribute := iiv$control_char_descriptions [j].text;
              ELSEIF terminal_attributes [i].backspace_character =
                    new_control_char_values [j] THEN
                conflicting_attribute := iiv$control_char_descriptions [j].text;
              IFEND;

              IF conflicting_attribute <> '  ' THEN
                osp$set_status_abnormal (ifc$interactive_facility_id,
                      ife$control_char_conflict, 'BACKSPACE_CHARACTER', status);
                osp$append_status_integer (osc$status_parameter_delimiter, k, 16,
                      TRUE, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      conflicting_attribute, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                  'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
                EXIT /validate_attributes/;
              IFEND;

            FOREND /check_backspace_conflict/;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_backspace_character;
            field_value_pointer := #LOC (terminal_attributes [i].backspace_character);
            osm.define_term_char.term_char_string [index].field_value :=
                  field_value_pointer^;
            index := index + 1;

          = ifc$cancel_line_character =

            k := ORD (terminal_attributes [i].cancel_line_character);
            IF ((terminal_attributes [i].cancel_line_character = '=') OR
                  (k > 7f(16)) { the character is non-ascii } OR
                  ((k >= 30(16)) AND (k <= 39(16))) { number } OR
                  ((k >= 41(16)) AND (k <= 5a(16))) { uppercase letter } OR
                  ((k >= 61(16)) AND (k <= 7a(16)))) { lowercase letter } THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$attr_val_disallowed_by_nam, 'CANCEL_LINE_CHARACTER',
                    status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 16,
                    TRUE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

            conflicting_attribute := '  ';

          /check_cancel_line_conflict/
            FOR j := 1 TO iic$number_of_control_chars DO
              IF iiv$control_char_descriptions [j].key = ifc$cancel_line_character
                    THEN
                new_control_char_values [j] := terminal_attributes[i].cancel_line_character;
                CYCLE /check_cancel_line_conflict/;
              ELSEIF terminal_attributes [i].cancel_line_character =
                    current_control_char_values [j] THEN
                conflicting_attribute := iiv$control_char_descriptions [j].text;
              ELSEIF terminal_attributes [i].cancel_line_character =
                    new_control_char_values [j] THEN
                conflicting_attribute := iiv$control_char_descriptions [j].text;
              IFEND;

              IF conflicting_attribute <> '  ' THEN
                osp$set_status_abnormal (ifc$interactive_facility_id,
                      ife$control_char_conflict, 'CANCEL_LINE_CHARACTER', status);
                osp$append_status_integer (osc$status_parameter_delimiter, k, 16,
                      TRUE, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      conflicting_attribute, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                  'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
                EXIT /validate_attributes/;
              IFEND;
            FOREND /check_cancel_line_conflict/;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_cancel_line_character;
            field_value_pointer := #LOC (terminal_attributes [i].cancel_line_character);
            osm.define_term_char.term_char_string [index].field_value :=
                  field_value_pointer^;
            index := index + 1;

          = ifc$carriage_return_delay =

            k := terminal_attributes [i].carriage_return_delay;
            IF ((k < LOWERVALUE (ift$carriage_return_delay)) OR (k >
                  UPPERVALUE (ift$carriage_return_delay))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$cr_delay, '', status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := LOWERVALUE (ift$carriage_return_delay);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := UPPERVALUE (ift$carriage_return_delay);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_cr_delay_count;
            delay := terminal_attributes [i].carriage_return_delay DIV 4;
            field_value_pointer := #LOC (delay);
            osm.define_term_char.term_char_string [index].field_value :=
                  field_value_pointer^;
            index := index + 1;

          = ifc$echoplex =

            IF ((terminal_attributes [i].echoplex < LOWERVALUE (boolean)) OR
                  (terminal_attributes [i].echoplex > UPPERVALUE (boolean))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$echoplex, 'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_echoplex;
            IF terminal_attributes [i].echoplex THEN
              osm.define_term_char.term_char_string [index].field_value := 1;
            ELSE
              osm.define_term_char.term_char_string [index].field_value := 0;
            IFEND;
            index := index + 1;

          = ifc$status_action =

            set_of_status_actions := - $iit$set_of_status_actions [];
            IF NOT (terminal_attributes [i].status_action IN set_of_status_actions)
                  THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$unknown_status_action, '', status);
              k := ORD (terminal_attributes [i].status_action);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_lockout_unsolicited_msgs;  { LK = 32(10) }
            CASE terminal_attributes [i].status_action OF
            = ifc$send_status =
              osm.define_term_char.term_char_string [index].field_value := 0;
            = ifc$hold_status, ifc$discard_status =
              osm.define_term_char.term_char_string [index].field_value := 1;
            CASEND;

            index := index + 1;

          = ifc$fold_line =

            IF ((terminal_attributes [i].fold_line < LOWERVALUE (boolean)) OR
                  (terminal_attributes [i].fold_line > UPPERVALUE (boolean))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$fold_line, 'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_output_device;
            IF terminal_attributes [i].fold_line THEN
              osm.define_term_char.term_char_string [index].field_value := 0;
            ELSE
              osm.define_term_char.term_char_string [index].field_value := 1;
            IFEND;
            index := index + 1;

          = ifc$end_partial_character =

            k := ORD (terminal_attributes [i].end_partial_character);
            IF ((terminal_attributes [i].end_partial_character = '=') OR
                  (k > 7f(16)) { the character is non-ascii } OR
                  ((k >= 30(16)) AND (k <= 39(16))) { number } OR
                  ((k >= 41(16)) AND (k <= 5a(16))) { uppercase letter } OR
                  ((k >= 61(16)) AND (k <= 7a(16)))) { lowercase letter } THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$attr_val_disallowed_by_nam, 'END_PARTIAL_CHARACTER',
                    status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 16,
                    TRUE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

            conflicting_attribute := '  ';

          /check_end_part_conflict/
            FOR j := 1 TO iic$number_of_control_chars DO
              IF iiv$control_char_descriptions [j].key = ifc$end_partial_character
                    THEN
                new_control_char_values [j] := terminal_attributes[i].end_partial_character;
                CYCLE /check_end_part_conflict/;
              ELSEIF terminal_attributes [i].end_partial_character =
                    current_control_char_values [j] THEN
                conflicting_attribute := iiv$control_char_descriptions [j].text;
              ELSEIF terminal_attributes [i].end_partial_character =
                    new_control_char_values [j] THEN
                conflicting_attribute := iiv$control_char_descriptions [j].text;
              IFEND;

              IF conflicting_attribute <> '  ' THEN
                osp$set_status_abnormal (ifc$interactive_facility_id,
                      ife$control_char_conflict, 'END_PARTIAL_CHARACTER', status);
                osp$append_status_integer (osc$status_parameter_delimiter, k, 16,
                      TRUE, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      conflicting_attribute, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                  'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
                EXIT /validate_attributes/;
              IFEND;
            FOREND /check_end_part_conflict/;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_end_block_character;
            field_value_pointer := #LOC (terminal_attributes [i].end_partial_character);
            osm.define_term_char.term_char_string [index].field_value :=
                  field_value_pointer^;
            index := index + 1;

          = ifc$end_partial_positioning =

            set_of_end_part_positions := - $iit$set_of_end_part_positions [];
            IF NOT (terminal_attributes [i].end_partial_positioning IN set_of_end_part_positions)
                  THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$unknown_end_part_position, '', status);
              k := ORD (terminal_attributes [i].end_partial_positioning);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

          { Turn the cursor_positioning characteristic ON for all EPP settings

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_cursor_positioning;
            osm.define_term_char.term_char_string [index].field_value := 1;
            index := index + 1;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_eob_cursor_positioning;
            CASE terminal_attributes [i].end_partial_positioning OF
            = ifc$no_epp =
              osm.define_term_char.term_char_string [index].field_value := 0;
            = ifc$epp_crs =
              osm.define_term_char.term_char_string [index].field_value := 1;
            = ifc$epp_lfs =
              osm.define_term_char.term_char_string [index].field_value := 2;
            = ifc$epp_crslfs =
              osm.define_term_char.term_char_string [index].field_value := 3;
            ELSE
            CASEND;

            index := index + 1;

          = ifc$end_line_character =

            k := ORD (terminal_attributes [i].end_line_character);
            IF ((terminal_attributes [i].end_line_character = '=') OR
                  (k > 7f(16)) { the character is non-ascii } OR
                  ((k >= 30(16)) AND (k <= 39(16))) { number } OR
                  ((k >= 41(16)) AND (k <= 5a(16))) { uppercase letter } OR
                  ((k >= 61(16)) AND (k <= 7a(16)))) { lowercase letter } THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$attr_val_disallowed_by_nam, 'END_LINE_CHARACTER',
                    status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 16,
                    TRUE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

            conflicting_attribute := '  ';

          /check_end_line_conflict/
            FOR j := 1 TO iic$number_of_control_chars DO
              IF iiv$control_char_descriptions [j].key = ifc$end_line_character
                    THEN
                new_control_char_values [j] := terminal_attributes[i].end_line_character;
                CYCLE /check_end_line_conflict/;
              ELSEIF terminal_attributes [i].end_line_character =
                    current_control_char_values [j] THEN
                conflicting_attribute := iiv$control_char_descriptions [j].text;
              ELSEIF terminal_attributes [i].end_line_character =
                    new_control_char_values [j] THEN
                conflicting_attribute := iiv$control_char_descriptions [j].text;
              IFEND;

              IF conflicting_attribute <> '  ' THEN
                osp$set_status_abnormal (ifc$interactive_facility_id,
                      ife$control_char_conflict, 'END_LINE_CHARACTER', status);
                osp$append_status_integer (osc$status_parameter_delimiter, k, 16,
                      TRUE, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      conflicting_attribute, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                  'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
                EXIT /validate_attributes/;
              IFEND;
            FOREND /check_end_part_conflict/;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_end_line_character;
            field_value_pointer := #LOC (terminal_attributes [i].end_line_character);
            osm.define_term_char.term_char_string [index].field_value :=
                  field_value_pointer^;
            index := index + 1;

          = ifc$end_line_positioning =

            set_of_end_line_positions := - $iit$set_of_end_line_positions [];
            IF NOT (terminal_attributes [i].end_line_positioning IN set_of_end_line_positions)
                  THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$unknown_end_line_position, '', status);
              k := ORD (terminal_attributes [i].end_line_positioning);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

          { Turn the cursor_positioning characteristic ON for all ELP settings

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_cursor_positioning;
            osm.define_term_char.term_char_string [index].field_value := 1;
            index := index + 1;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_eol_cursor_positioning;
            CASE terminal_attributes [i].end_line_positioning OF
            = ifc$elp_none =
              osm.define_term_char.term_char_string [index].field_value := 0;
            = ifc$elp_crs =
              osm.define_term_char.term_char_string [index].field_value := 1;
            = ifc$elp_lfs =
              osm.define_term_char.term_char_string [index].field_value := 2;
            = ifc$elp_crslfs =
              osm.define_term_char.term_char_string [index].field_value := 3;
            ELSE
            CASEND;

            index := index + 1;

          = ifc$character_flow_control =

            IF ((terminal_attributes [i].character_flow_control < LOWERVALUE (boolean)) OR
                  (terminal_attributes [i].character_flow_control > UPPERVALUE (boolean))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$character_flow_control, 'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;
            IF terminal_attributes [i].character_flow_control THEN
              osm.define_term_char.term_char_string [index].field_number :=
                    iic$fn_output_flow_control;
              osm.define_term_char.term_char_string [index].field_value := 1;
              index := index + 1;
              osm.define_term_char.term_char_string [index].field_number :=
                    iic$fn_input_flow_control;
              osm.define_term_char.term_char_string [index].field_value := 1;
            ELSE
              osm.define_term_char.term_char_string [index].field_number :=
                    iic$fn_output_flow_control;
              osm.define_term_char.term_char_string [index].field_value := 0;
              index := index + 1;
              osm.define_term_char.term_char_string [index].field_number :=
                    iic$fn_input_flow_control;
              osm.define_term_char.term_char_string [index].field_value := 0;
            IFEND;

            index := index + 1;

          = ifc$line_feed_delay =

            k := terminal_attributes [i].line_feed_delay;
            IF ((k < LOWERVALUE (ift$line_feed_delay)) OR (k > UPPERVALUE
                  (ift$line_feed_delay))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$lf_delay, '', status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := LOWERVALUE (ift$line_feed_delay);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := UPPERVALUE (ift$line_feed_delay);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_lf_delay_count;
            delay := terminal_attributes [i].line_feed_delay DIV 4;
            field_value_pointer := #LOC (delay);
            osm.define_term_char.term_char_string [index].field_value :=
                  field_value_pointer^;
            index := index + 1;

          = ifc$network_command_character =

            k := ORD (terminal_attributes [i].network_command_character);
            IF ((terminal_attributes [i].network_command_character = '=') OR
                  (k > 7f(16)) { the character is non-ascii } OR
                  ((k >= 30(16)) AND (k <= 39(16))) { number } OR
                  ((k >= 41(16)) AND (k <= 5a(16))) { uppercase letter } OR
                  ((k >= 61(16)) AND (k <= 7a(16)))) { lowercase letter } THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$attr_val_disallowed_by_nam, 'NETWORK_CONTROL_CHARACTER', status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 16,
                    TRUE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

            conflicting_attribute := '  ';

          /check_network_command_conflict/
            FOR j := 1 TO iic$number_of_control_chars DO
              IF iiv$control_char_descriptions [j].key = ifc$network_command_character
                    THEN
                new_control_char_values [j] := terminal_attributes[i].network_command_character;
                CYCLE /check_network_command_conflict/;
              ELSEIF terminal_attributes [i].network_command_character =
                    current_control_char_values [j] THEN
                conflicting_attribute := iiv$control_char_descriptions [j].text;
              ELSEIF terminal_attributes [i].network_command_character =
                    new_control_char_values [j] THEN
                conflicting_attribute := iiv$control_char_descriptions [j].text;
              IFEND;

              IF conflicting_attribute <> '  ' THEN
                osp$set_status_abnormal (ifc$interactive_facility_id,
                      ife$control_char_conflict, 'NETWORK_COMMAND_CHARACTER', status);
                osp$append_status_integer (osc$status_parameter_delimiter, k, 16,
                      TRUE, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      conflicting_attribute, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                  'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
                EXIT /validate_attributes/;
              IFEND;

            FOREND /check_network_command_conflict/;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_network_cmd_character;
            field_value_pointer := #LOC (terminal_attributes [i].network_command_character);
            osm.define_term_char.term_char_string [index].field_value :=
                  field_value_pointer^;
            index := index + 1;

          = ifc$null_terminal_attribute =

          = ifc$page_length =

            k := terminal_attributes [i].page_length;
            IF ((k < LOWERVALUE (ift$page_length)) OR (k > UPPERVALUE
                  (ift$page_length))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$page_length, '', status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := LOWERVALUE (ift$page_length);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := UPPERVALUE (ift$page_length);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_page_length;
            field_value_pointer := #LOC (terminal_attributes [i].page_length);
            osm.define_term_char.term_char_string [index].field_value :=
                  field_value_pointer^;
            index := index + 1;

          = ifc$hold_page =

            IF ((terminal_attributes [i].hold_page < LOWERVALUE (boolean)) OR
                  (terminal_attributes [i].hold_page > UPPERVALUE (boolean))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$hold_page, 'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_hold_page;
            IF terminal_attributes [i].hold_page THEN
              osm.define_term_char.term_char_string [index].field_value := 1;
            ELSE
              osm.define_term_char.term_char_string [index].field_value := 0;
            IFEND;
            index := index + 1;

          = ifc$page_width =

            k := terminal_attributes [i].page_width;
            IF ((k < LOWERVALUE (ift$page_width)) OR (k > UPPERVALUE
                  (ift$page_width))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$page_width, '', status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := LOWERVALUE (ift$page_width);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := UPPERVALUE (ift$page_width);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_page_width;
            field_value_pointer := #LOC (terminal_attributes [i].page_width);
            osm.define_term_char.term_char_string [index].field_value :=
                  field_value_pointer^;
            index := index + 1;

          = ifc$parity =

            set_of_parity_modes := - $iit$set_of_parity_modes [];
            IF NOT (terminal_attributes [i].parity IN set_of_parity_modes) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$unknown_parity_mode, '', status);
              k := ORD (terminal_attributes [i].parity);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_parity;
            CASE terminal_attributes [i].parity OF
            = ifc$zero_parity, ifc$mark_parity =
              osm.define_term_char.term_char_string [index].field_value :=
                    iic$zero_parity;
            = ifc$even_parity =
              osm.define_term_char.term_char_string [index].field_value :=
                    iic$even_parity;
            = ifc$odd_parity =
              osm.define_term_char.term_char_string [index].field_value :=
                  iic$odd_parity;
            = ifc$no_parity =

              osm.define_term_char.term_char_string [index].field_value :=
                    iic$no_parity;

            { Turn on IGNORE PARITY if XPT mode is on and the 2**7 bit of either the TFC or TTC
            { is zero.  This tells the 2550 to ignore the parity bit when it is checking for the
            { TFC or TTC, which, in effect, allows, for example, a TFC of 0D(16) to successfully
            { compare with 8D(16).

              IF (cdp^.nam_os_default_attributes.input_editing_mode.value =
                    ifc$trans_edit) THEN
                IF (ORD (cdp^.nam_os_default_attributes.trans_forward_character.value.
                      value (1)) < 7F(16)) OR
                      (ORD (cdp^.nam_os_default_attributes.trans_terminate_character.value.
                      value (1)) < 7F(16)) THEN
                  osm.define_term_char.term_char_string [index].field_value :=
                        iic$ignore_parity;
                IFEND;
              IFEND;

            ELSE
            CASEND;

            index := index + 1;

          = ifc$pause_break_character =

            k := ORD (terminal_attributes [i].pause_break_character);
            IF ((terminal_attributes [i].pause_break_character = '=') OR
                 (k > 7f(16)) { the character is non-ascii } OR
                 ((k >= 30(16)) AND (k <= 39(16))) { number } OR
                 ((k >= 41(16)) AND (k <= 5a(16))) { uppercase letter } OR
                 ((k >= 61(16)) AND (k <= 7a(16)))) { lowercase letter } THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$attr_val_disallowed_by_nam, 'PAUSE_BREAK_CHARACTER',
                    status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 16,
                    TRUE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

            conflicting_attribute := '  ';

          /check_pause_break_conflict/
            FOR j := 1 TO iic$number_of_control_chars DO
              IF iiv$control_char_descriptions [j].key = ifc$pause_break_character
                    THEN
                new_control_char_values [j] := terminal_attributes[i].pause_break_character;
                CYCLE /check_pause_break_conflict/;
              ELSEIF terminal_attributes [i].pause_break_character =
                    current_control_char_values [j] THEN
                conflicting_attribute := iiv$control_char_descriptions [j].text;
              ELSEIF terminal_attributes [i].pause_break_character =
                    new_control_char_values [j] THEN
                conflicting_attribute := iiv$control_char_descriptions [j].text;
              IFEND;

              IF conflicting_attribute <> '  ' THEN
                osp$set_status_abnormal (ifc$interactive_facility_id,
                      ife$control_char_conflict, 'PAUSE_BREAK_CHARACTER', status);
                osp$append_status_integer (osc$status_parameter_delimiter, k, 16,
                      TRUE, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      conflicting_attribute, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                  'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
                EXIT /validate_attributes/;
              IFEND;

            FOREND /check_pause_break_conflict/;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_pause_break_character;
            field_value_pointer := #LOC (terminal_attributes [i].pause_break_character);
            osm.define_term_char.term_char_string [index].field_value :=
                  field_value_pointer^;
            index := index + 1;

          = ifc$terminal_class =

            set_of_terminal_classes := - $iit$set_of_terminal_classes [];
            IF NOT (terminal_attributes [i].terminal_class IN
                  set_of_terminal_classes) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$unknown_terminal_class, '', status);
              k := ORD (terminal_attributes [i].terminal_class);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            ELSE
              terminal_class := TRUE;
              term_class := iiv$downline_term_class_conv [terminal_attributes [i] .terminal_class];
            IFEND;

          = ifc$terminal_model =

            cdp^.terminal_attributes.terminal_model.size := terminal_attributes [i].
                  terminal_model.size;
            cdp^.terminal_attributes.terminal_model.value := terminal_attributes [i].
                  terminal_model.value;

          = ifc$terminate_break_character =

            k := ORD (terminal_attributes [i].terminate_break_character);
            IF ((terminal_attributes [i].terminate_break_character = '=') OR
                  (k > 7f(16)) { the character is non-ascii } OR
                  ((k >= 30(16)) AND (k <= 39(16))) { number } OR
                  ((k >= 41(16)) AND (k <= 5a(16))) { uppercase letter } OR
                  ((k >= 61(16)) AND (k <= 7a(16)))) { lowercase letter } THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$attr_val_disallowed_by_nam, 'TERMINATE_BREAK_CHARACTER',
                    status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 16,
                    TRUE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
              EXIT /validate_attributes/;
            IFEND;

            conflicting_attribute := '  ';

          /check_terminate_break_conflict/
            FOR j := 1 TO iic$number_of_control_chars DO
              IF iiv$control_char_descriptions [j].key =
                    ifc$terminate_break_character THEN
                new_control_char_values [j] := terminal_attributes[i].terminate_break_character;
                CYCLE /check_terminate_break_conflict/;
              ELSEIF terminal_attributes [i].terminate_break_character =
                    current_control_char_values [j] THEN
                conflicting_attribute := iiv$control_char_descriptions [j].text;
              ELSEIF terminal_attributes [i].terminate_break_character =
                    new_control_char_values [j] THEN
                conflicting_attribute := iiv$control_char_descriptions [j].text;
              IFEND;

              IF conflicting_attribute <> '  ' THEN
                osp$set_status_abnormal (ifc$interactive_facility_id,
                      ife$control_char_conflict, 'TERMINATE_BREAK_CHARACTER',
                      status);
                osp$append_status_integer (osc$status_parameter_delimiter, k, 16,
                      TRUE, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      conflicting_attribute, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                  'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
                EXIT /validate_attributes/;
              IFEND;

            FOREND /check_terminate_break_conflict/;

            osm.define_term_char.term_char_string [index].field_number :=
                  iic$fn_term_break_character;
            field_value_pointer := #LOC (terminal_attributes [i].terminate_break_character);
            osm.define_term_char.term_char_string [index].field_value :=
                  field_value_pointer^;
            index := index + 1;

          = ifc$attention_character =
            { note - this attribute is accepted only to the extent that storing a non-null }
            { character will indicate to iim$build_term_char_values that it should use }
            { transparency type 2 (interruptible) instead of the default type 1 (no interrupts). }

          = ifc$begin_line_character, ifc$carriage_return_sequence,
            ifc$control_code_replacement, ifc$code_set, ifc$code_set_name,
            ifc$end_page_action, ifc$form_feed_delay,ifc$form_feed_sequence,
            ifc$function_key_class, ifc$hold_page_over, ifc$line_feed_sequence =

          { *** THESE ATTRIBUTES ARE IGNORED FOR DUAL STATE CONNECTIONS *** }

          = ifc$end_output_sequence =

          { The NAM mapping for EOS is to PP (FN=66(16):  pacer prompting) which cannot be reset. }

          ELSE

        { The attribute key is not valid for this request.

            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$invalid_key_for_request, '', status);
            k := ORD (terminal_attributes [i].key);
            osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                  FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
              'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
            EXIT /validate_attributes/;

          CASEND;

        FOREND /validate_attributes/;
        iip$clear_lock (cdp^.lock, local_status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND; { status.normal from iip$set_lock }
    IFEND; { iiv$cdcnet_connection }

  { Change the terminal class if specified.

    IF terminal_class THEN
      iip$flush (fake_file_id, NIL, local_status);
      iip$change_terminal_class (cdp, term_class, local_status);
    IFEND;

    IF (length_of_octets > 0) OR (index > 1) THEN
      IF iiv$cdcnet_connection THEN
        osm.header.text_length := length_of_octets + 2;
      ELSE
        osm.header.text_length := (index - 1) * 2 + 2;
      IFEND;

    { Convert the define terminal characteristics message to C170 NAM format.

      iip$convert_downline_term_char (#LOC (osm), #LOC (define_term_char_message),
            iic$l_define_term_char * 8, term_char_message_length);

    { Send the define terminal characteristics message to Pass-On.

      IF iiv$int_task_open_file_count = 0 THEN

      { No files are open in this task, which infers that
      { this task is not signed on to the Memory Link and,
      { hence, cannot 'talk to' PASSON.  NV0I012 fix--5/8/86.

        iip$sign_on (iiv$chata_application_name, status);
        IF NOT status.normal THEN
          #KEYPOINT (osk$exit, 0 , iik$change_terminal_attributes);
          RETURN;
        IFEND;

        iip$add_sender (iiv$chata_application_name, status);
        IF NOT status.normal THEN
          iip$sign_off (iiv$chata_application_name, local_status);
          #KEYPOINT (osk$exit, 0 , iik$change_terminal_attributes);
          RETURN;
        IFEND;

        iip$send_to_pass_on (iiv$chata_application_name, #LOC
              (define_term_char_message), term_char_message_length,
              iic$output_data_message + iiv$job_connection, status);
        IF NOT status.normal THEN
          iip$report_status_error (status, 'send to passon');
        IFEND;

        iip$sign_off (iiv$chata_application_name, status);

      ELSE
        iip$send_to_pass_on (iiv$int_application_name, #LOC
              (define_term_char_message), term_char_message_length,
              iic$output_data_message + iiv$job_connection, status);
      IFEND;
    IFEND; { index > 1 }

    { Update the NAM default attributes if the terminal class was specified.

    IF terminal_class THEN
      iip$request_default_attributes (cdp, status);
    IFEND;

  { Update the terminal_attributes record in the connection description.

    FOR i := 1 TO UPPERBOUND (terminal_attributes) DO
      CASE terminal_attributes [i].key OF
      = ifc$backspace_character =
          cdp^.terminal_attributes.backspace_character :=
                terminal_attributes [i].backspace_character;
      = ifc$cancel_line_character =
        cdp^.terminal_attributes.cancel_line_character :=
              terminal_attributes [i].cancel_line_character;
      = ifc$carriage_return_delay =
        cdp^.terminal_attributes.carriage_return_delay :=
              terminal_attributes [i].carriage_return_delay;
      = ifc$echoplex =
        cdp^.terminal_attributes.echoplex :=
              terminal_attributes [i].echoplex;
      = ifc$status_action =
        cdp^.terminal_attributes.status_action := terminal_attributes [i].status_action;
      = ifc$fold_line =
        cdp^.terminal_attributes.fold_line := terminal_attributes [i].fold_line;
      = ifc$end_partial_character =
        cdp^.terminal_attributes.end_partial_character :=
              terminal_attributes [i].end_partial_character;
      = ifc$end_partial_positioning =
        cdp^.terminal_attributes.end_partial_positioning :=
              terminal_attributes [i].end_partial_positioning;
      = ifc$end_line_character =
        cdp^.terminal_attributes.end_line_character :=
              terminal_attributes [i].end_line_character;
      = ifc$end_line_positioning =
        cdp^.terminal_attributes.end_line_positioning :=
              terminal_attributes [i].end_line_positioning;
      = ifc$character_flow_control =
        cdp^.terminal_attributes.character_flow_control :=
              terminal_attributes [i].character_flow_control;
      = ifc$line_feed_delay =
        cdp^.terminal_attributes.line_feed_delay :=
              terminal_attributes [i].line_feed_delay;
      = ifc$network_command_character =
        cdp^.terminal_attributes.network_command_character :=
              terminal_attributes [i].network_command_character;
      = ifc$null_terminal_attribute =
      = ifc$page_length =
        cdp^.terminal_attributes.page_length :=
              terminal_attributes [i].page_length;
      = ifc$hold_page =
        cdp^.terminal_attributes.hold_page :=
              terminal_attributes [i].hold_page;
      = ifc$page_width =
        cdp^.terminal_attributes.page_width :=
              terminal_attributes [i].page_width;
      = ifc$parity =
        cdp^.terminal_attributes.parity := terminal_attributes [i].parity;
      = ifc$pause_break_character =
        IF NOT iiv$cdcnet_connection THEN
          cdp^.terminal_attributes.pause_break_character :=
                terminal_attributes [i].pause_break_character;
        IFEND;
      = ifc$terminal_class =
          cdp^.terminal_attributes.terminal_class :=
                terminal_attributes [i].terminal_class;
      = ifc$terminal_model =
          cdp^.terminal_attributes.terminal_model :=
                terminal_attributes [i].terminal_model;
      = ifc$terminate_break_character =
        IF NOT iiv$cdcnet_connection THEN
          cdp^.terminal_attributes.terminate_break_character :=
                terminal_attributes [i].terminate_break_character;
        IFEND;
      = ifc$attention_character =
        cdp^.terminal_attributes.attention_character :=
              terminal_attributes [i].attention_character;
      = ifc$hold_page_over =
        IF iiv$cdcnet_connection THEN
          cdp^.terminal_attributes.hold_page_over :=
                terminal_attributes [i].hold_page_over;
        IFEND;
      = ifc$begin_line_character =
        IF iiv$cdcnet_connection THEN
          cdp^.terminal_attributes.begin_line_character :=
                terminal_attributes [i].begin_line_character;
        IFEND;
      = ifc$carriage_return_sequence =
        IF iiv$cdcnet_connection THEN
          cdp^.terminal_attributes.carriage_return_sequence :=
                terminal_attributes [i].carriage_return_sequence;
        IFEND;
      = ifc$end_output_sequence =
        IF iiv$cdcnet_connection THEN
          cdp^.terminal_attributes.end_output_sequence :=
                terminal_attributes [i].end_output_sequence;
        IFEND;
      = ifc$line_feed_sequence =
        IF iiv$cdcnet_connection THEN
          cdp^.terminal_attributes.line_feed_sequence :=
                terminal_attributes [i].line_feed_sequence;
        IFEND;
      = ifc$code_set =
        IF iiv$cdcnet_connection THEN
          cdp^.terminal_attributes.code_set := terminal_attributes [i].code_set;
        IFEND;
      = ifc$end_page_action =
        IF iiv$cdcnet_connection THEN
          cdp^.terminal_attributes.end_page_action :=
                terminal_attributes [i].end_page_action;
        IFEND;
      = ifc$form_feed_delay =
        IF iiv$cdcnet_connection THEN
          cdp^.terminal_attributes.form_feed_delay :=
                terminal_attributes [i].form_feed_delay;
        IFEND;
      = ifc$form_feed_sequence =
        IF iiv$cdcnet_connection THEN
          cdp^.terminal_attributes.form_feed_sequence :=
                terminal_attributes [i].form_feed_sequence;
        IFEND;
      = ifc$function_key_class =
        IF iiv$cdcnet_connection THEN
          cdp^.terminal_attributes.function_key_class :=
                terminal_attributes [i].function_key_class^;
        IFEND;
      ELSE
      CASEND;
    FOREND;

    #KEYPOINT (osk$exit, 0 , iik$change_terminal_attributes);

  PROCEND iip$change_terminal_attributes;
MODEND iim$change_terminal_attributes;
*DECK DECK=IIM$CHANGE_TERMINAL_CLASS EXPAND=TRUE
*copyc osd$default_pragmats
MODULE iim$change_terminal_class;
?? TITLE := 'MODULE iim$change_terminal_class' ??

?? PUSH (LISTEXT := ON) ??
*copyc iit$connection_description
*copyc ost$status
?? POP ??
*copyc iip$build_super_msg_skeleton
*copyc iip$sign_on
*copyc iip$sign_off
*copyc iip$add_sender
*copyc iip$clear_lock
*copyc iip$convert_downline_term_char
*copyc iiv$interactive_terminated
*copyc iip$set_lock
*copyc iip$send_to_pass_on
*copyc mld$memory_link_declarations

?? NEWTITLE := 'PROCEDURE iip$change_terminal_class', EJECT ??

  PROCEDURE [XDCL] iip$change_terminal_class (connection_desc_pointer:
    ^iit$connection_description;
        new_terminal_class: iit$terminal_class;
    VAR status: ost$status);

    VAR
      output_supervisory_message: iit$output_supervisory_message,
      define_term_char_message: iit$output_data_message,
      term_char_message_length: mlt$message_length,
      appl: mlt$application_name,
      i: integer,
      local_status: ost$status;

  /send_define_term_char_message/
    BEGIN

{ Build a define terminal characteristics message to set the terminal class.

      iip$build_super_msg_skeleton (^output_supervisory_message,
            iic$sm_define_term_char, iic$l_define_term_char);
      output_supervisory_message.header.address := connection_desc_pointer^.
            connection_number;
      output_supervisory_message.header.character_type := iic$8_bit_characters;
      output_supervisory_message.header.block_number := 0;
      output_supervisory_message.define_term_char.term_char_string
            [1].field_number := iic$fn_terminal_class;
      output_supervisory_message.define_term_char.term_char_string
            [1].field_value := new_terminal_class;
      output_supervisory_message.header.text_length := 4;
      iip$convert_downline_term_char (#LOC (output_supervisory_message), #LOC
            (define_term_char_message), iic$l_define_term_char * 8,
            term_char_message_length);

{ Send the define terminal terminal characteristics message to Pass-On.

      iip$sign_on (appl, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      iip$add_sender (appl, status);
      IF NOT status.normal THEN
        iip$sign_off (appl, local_status);
        RETURN;
      IFEND;
      iip$send_to_pass_on (appl, #LOC (define_term_char_message),
            term_char_message_length, iic$output_data_message +
            iiv$job_connection, status);
      iip$sign_off (appl, local_status);
      IF NOT status.normal THEN
        EXIT /send_define_term_char_message/;
      IFEND;

    END /send_define_term_char_message/;

  PROCEND iip$change_terminal_class;

MODEND iim$change_terminal_class;
*DECK DECK=IIM$CHANGE_TERM_CONN_ATTRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$change_term_conn_attributes;

{ PURPOSE:  This ring 2 module provides the interface to change the
{           default connection attributes for a file created by
{           RMP$REQUEST_TERMINAL.  Subsequent opens of the file will
{           use the new attribute values, but previous opens of the
{           file will not be affected.
{
{  DESIGN:  After verifying the job mode and attribute keys,
{           FMP$GET_CYCLE_DESCRIPTION is called to validate the file name,
{           search for its entry in the path table, and interlock the cycle
{           description.  An abnormal status is returned if the path table entry
{           indicates that the file was not created by RMP$REQUEST_TERMINAL.
{
{           The new attribute values are validated and are then used
{           to update the cycle description for the file.  If file's cycle
{           description contains attributes then they are merged with the
{           attributes passed from IFP$CHANGE_TERM_CONN_ATTRIBUTES overriding in
{           case of conflicts.  If no cycle description attributes exist then
{           space is allocated and used to store the IFP$CHANGE_TERM_CONN_ATTRIBUTES
{           and a pointer to this space is stored in the cycle description.
{           Finally, the cycle description's interlock is cleared.
{
?? TITLE := 'MODULE iim$change_term_conn_attributes' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc CLP$GET_ULTIMATE_CONNECTION
*copyc CLP$VALIDATE_NAME
*copyc CLV$STANDARD_FILES
*copyc CLE$ECC_LEXICAL
*copyc FMP$GET_CYCLE_DESCRIPTION
*copyc FMP$UNLOCK_PATH_TABLE
*copyc IFE$ERROR_CODES
*copyc IIK$KEYPOINTS
*copyc IIP$SEARCH_CONNECTION_DESC
*copyc IIP$SET_BAM_ATTRIBUTES
*copyc IIP$XLATE_LOCAL_FILE_TO_SESSION
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIV$INTERACTIVE_TERMINATED
*copyc JMP$SYSTEM_JOB
*copyc OSD$OPERATING_SYSTEM_EXCEPTIONS
*copyc OSP$APPEND_STATUS_INTEGER
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSS$TASK_PRIVATE
*copyc OSV$JOB_PAGEABLE_HEAP
*copyc OSV$TASK_PRIVATE_HEAP
*copyc PMP$GET_JOB_MODE
*copyc RME$REQUEST_TERMINAL
*copyc RMP$GET_DEVICE_CLASS
?? POP ??
?? SET (LIST := ON) ??

?? NEWTITLE := 'PROCEDURE iip$change_term_conn_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$change_term_conn_attributes (local_file_name:
    amt$local_file_name;
        connection_attributes: ift$connection_attributes;
    VAR status: ost$status);

    VAR
      converted_name: ost$name,
      cycle_description: ^fmt$cycle_description,
      device_assigned: boolean,
      device_class: rmt$device_class,
      device_is_network: boolean,
      found: boolean,
      i: integer,
      job_mode: jmt$job_mode,
      k: integer,
      last_element: integer,
      cd_attributes_ptr: ^ift$connection_attributes,
      local_status: ost$status,
      new_lnt_attributes: array [0 .. ORD (ifc$max_connection_key)] of ift$connection_attribute,
      session_file: amt$local_file_name,
      set_of_trans_char_modes: iit$set_of_trans_char_modes,
      set_of_trans_length_modes: iit$set_of_trans_length_modes,
      set_of_trans_protocol_modes: iit$set_of_trans_protocol_modes,
      set_of_trans_timeout_modes: iit$set_of_trans_timeout_modes,
      set_of_input_editing_modes: iit$set_of_input_editing_modes,
      set_of_input_output_modes: iit$set_of_input_output_modes,
      set_of_terminal_attribute_keys: iit$set_of_term_conn_attr_keys,
      temp_file_name: ost$name,
      ultimate_name: amt$local_file_name,
      ultimate_prompt_file: amt$local_file_name,
      updated_attributes: ^ift$connection_attributes,
      valid_name: boolean;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, iik$change_term_conn_attributes);

  /change_term_conn_attributes/
    BEGIN

    { Convert and validate the file name.

      clp$validate_name (local_file_name, converted_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$file_name_ill_formed, local_file_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
        RETURN;
      IFEND;

    { Verify that the file is assigned to a terminal device.

      clp$get_ultimate_connection (local_file_name, ultimate_name, status);
      IF NOT status.normal THEN
        EXIT /change_term_conn_attributes/;
      IFEND;

      rmp$get_device_class (ultimate_name, device_assigned, device_class,
            local_status);
      IF NOT local_status.normal THEN
        status := local_status;
        RETURN;
      ELSE
        IF (device_class <> rmc$terminal_device) AND (device_class <> rmc$network_device) THEN
          pmp$get_job_mode (job_mode, local_status);
          IF NOT local_status.normal THEN
            status := local_status;
            RETURN;
          ELSEIF (NOT (job_mode IN $iit$job_modes [jmc$interactive_connected,
                 jmc$interactive_cmnd_disconnect, jmc$interactive_line_disconnect,
                 jmc$interactive_sys_disconnect]) AND
                 (((ultimate_name = clv$standard_files [clc$sf_job_input_file].path_handle_name) OR
                 (ultimate_name = clv$standard_files [clc$sf_job_output_file].path_handle_name)) OR
                 (ultimate_name = clv$standard_files [clc$sf_command_file].path_handle_name))) THEN
            osp$set_status_abnormal (ifc$interactive_facility_id,
                 ife$current_job_not_interactive, 'IFP$CHANGE_TERM_CONN_ATTRIBUTES',
                 status);
            RETURN;
          ELSE
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$file_name_not_terminal, converted_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
              'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
            RETURN;
          IFEND;
        IFEND;
      IFEND;

    { Validate the connection attribute keys.

      set_of_terminal_attribute_keys := - $iit$set_of_term_conn_attr_keys [];
      FOR i := LOWERBOUND (connection_attributes) TO UPPERBOUND (connection_attributes) DO
        IF NOT (connection_attributes [i].key IN set_of_terminal_attribute_keys) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_attribute_key, '', status);
          k := ORD (connection_attributes [i].key);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          EXIT /change_term_conn_attributes/;
        IFEND;
      FOREND;

      { Validate the attribute values.

        FOR i := LOWERBOUND (connection_attributes) TO UPPERBOUND
              (connection_attributes) DO

          CASE connection_attributes [i].key OF

          = ifc$attention_character_action =

            k := connection_attributes [i].attention_character_action;
            IF ((k < LOWERVALUE (ift$attention_character_action)) OR (k >
                  UPPERVALUE (ift$attention_character_action))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$attention_character_action, '', status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := LOWERVALUE (ift$attention_character_action);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := UPPERVALUE (ift$attention_character_action);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$break_key_action =

            k := connection_attributes [i].break_key_action;
            IF ((k < LOWERVALUE (ift$break_key_action)) OR (k >
                  UPPERVALUE (ift$break_key_action))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$break_key_action, '', status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := LOWERVALUE (ift$break_key_action);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := UPPERVALUE (ift$break_key_action);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$end_of_information =

            k := connection_attributes [i].end_of_information.size;
            IF ((k < LOWERVALUE (ift$end_of_information_size)) OR (k > UPPERVALUE
                  (ift$end_of_information_size))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$end_of_information_size, '', status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := LOWERVALUE (ift$end_of_information_size);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := UPPERVALUE (ift$end_of_information_size);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$input_block_size =

            k := connection_attributes [i].input_block_size;
            IF ((k < LOWERVALUE (ift$input_block_size)) OR (k > UPPERVALUE
                  (ift$input_block_size))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$input_block_size, '', status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := LOWERVALUE (ift$input_block_size);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := UPPERVALUE (ift$input_block_size);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$input_editing_mode =

            set_of_input_editing_modes := - $iit$set_of_input_editing_modes [];
            IF NOT (connection_attributes [i].input_editing_mode IN set_of_input_editing_modes)
                  THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$unknown_input_editing_mode, '', status);
              k := ORD (connection_attributes [i].input_editing_mode);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$input_output_mode =

            set_of_input_output_modes := - $iit$set_of_input_output_modes [];
            IF NOT (connection_attributes [i].input_output_mode IN set_of_input_output_modes)
                  THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$unknown_input_output_mode, '', status);
              k := ORD (connection_attributes [i].input_output_mode);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$input_timeout =

            IF ((connection_attributes [i].input_timeout < LOWERVALUE
                  (boolean)) OR (connection_attributes [i].input_timeout >
                  UPPERVALUE (boolean))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$input_timeout, 'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$input_timeout_length =

            k := connection_attributes [i].input_timeout_length;
            IF ((k < LOWERVALUE (ift$input_timeout_length)) OR (k > UPPERVALUE
                  (ift$input_timeout_length))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$input_timeout_length, '', status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := LOWERVALUE (ift$input_timeout_length);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := UPPERVALUE (ift$input_timeout_length);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$input_timeout_purge =

            IF ((connection_attributes [i].input_timeout_purge < LOWERVALUE
                  (boolean)) OR (connection_attributes [i].input_timeout_purge >
                  UPPERVALUE (boolean))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$input_timeout_purge, 'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$partial_char_forwarding =

            IF ((connection_attributes [i].partial_character_forwarding < LOWERVALUE
                  (boolean)) OR (connection_attributes [i].partial_character_forwarding >
                  UPPERVALUE (boolean))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$partial_char_forwarding, 'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$prompt_file =

            clp$get_ultimate_connection (connection_attributes [i].prompt_file, ultimate_prompt_file, status);
            IF NOT status.normal THEN
              EXIT /change_term_conn_attributes/;
            IFEND;
            IF ultimate_prompt_file <> ultimate_name THEN

      { Verify that the file is assigned to a terminal device.

              rmp$get_device_class (ultimate_prompt_file, device_assigned, device_class, local_status);
              IF NOT local_status.normal THEN
                status := local_status;
                EXIT /change_term_conn_attributes/;
              ELSE
                IF NOT device_assigned THEN
                  osp$set_status_abnormal (ifc$interactive_facility_id,
                        ife$prompt_file_name_not_found, ultimate_prompt_file, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                    'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
                  EXIT /change_term_conn_attributes/;
                ELSEIF device_class <> rmc$terminal_device THEN
                  osp$set_status_abnormal (ifc$interactive_facility_id,
                        ife$prompt_file_name_not_term, ultimate_prompt_file, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                    'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
                  EXIT /change_term_conn_attributes/;
                IFEND;
              IFEND;
            IFEND;

          = ifc$prompt_file_identifier =

    { Get the file_name for the file_id.

    { The following code is no-op'ed until BAM provides a way to obtain
    { the local_file_name given the file_id.

    {       fetch_attributes [1].key := amc$local_file_name;
    {       amp$fetch (connection_attributes [i].prompt_file_identifier, fetch_attributes,
    {             local_status);
    {       IF NOT local_status.normal THEN
    {         status := local_status;
    {         EXIT /change_term_conn_attributes/;
    {       IFEND;
    {
    {       clp$get_ultimate_connection (connection_attributes [i].prompt_file, ultimate_prompt_file, status);
    {       IF NOT status.normal THEN
    {         EXIT /change_term_conn_attributes/;
    {       IFEND;
    {       IF ultimate_prompt_file <> ultimate_name THEN
    {
    { Verify that the file is assigned to a terminal device.
    {
    {         rmp$get_device_class (fetch_attributes [1].file_name^.local_file_name,
    {               device_assigned, device_class, local_status);
    {         IF NOT local_status.normal THEN
    {           status := local_status;
    {           EXIT /change_term_conn_attributes/;
    {         ELSE
    {           IF NOT device_assigned THEN
    {             osp$set_status_abnormal (ifc$interactive_facility_id,
    {                   ife$prompt_file_id_not_found, fetch_attributes [1].
    {                   file_name^.local_file_name, status);
    {             osp$append_status_parameter (osc$status_parameter_delimiter,
    {               'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
    {             EXIT /change_term_conn_attributes/;
    {           ELSEIF device_class <> rmc$terminal_device THEN
    {             osp$set_status_abnormal (ifc$interactive_facility_id,
    {                   ife$prompt_file_id_not_term, fetch_attributes [1].file_name^.
    {                   local_file_name, status);
    {             osp$append_status_parameter (osc$status_parameter_delimiter,
    {               'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
    {             EXIT /change_term_conn_attributes/;
    {           IFEND;
    {         IFEND;
    {       IFEND;

          = ifc$prompt_string =

            k := connection_attributes [i].prompt_string.size;
            IF ((k < LOWERVALUE (ift$prompt_string_size)) OR (k > UPPERVALUE
                  (ift$prompt_string_size))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$prompt_string_size, '', status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := LOWERVALUE (ift$prompt_string_size);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := UPPERVALUE (ift$prompt_string_size);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$store_backspace_character =

            IF ((connection_attributes [i].store_backspace_character < LOWERVALUE
                  (boolean)) OR (connection_attributes [i].store_backspace_character >
                  UPPERVALUE (boolean))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$store_backspace_character, 'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$store_nuls_dels =

            IF ((connection_attributes [i].store_nuls_dels < LOWERVALUE
                  (boolean)) OR (connection_attributes [i].store_nuls_dels >
                  UPPERVALUE (boolean))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$store_nuls_dels, 'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$trans_character_mode =

            set_of_trans_char_modes := - $iit$set_of_trans_char_modes [];
            IF NOT (connection_attributes [i].trans_character_mode IN set_of_trans_char_modes)
                  THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$unknown_trans_char_mode, '', status);
              k := ORD (connection_attributes [i].trans_character_mode);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$trans_length_mode =

            set_of_trans_length_modes := - $iit$set_of_trans_length_modes [];
            IF NOT (connection_attributes [i].trans_length_mode IN set_of_trans_length_modes)
                  THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$unknown_trans_length_mode, '', status);
              k := ORD (connection_attributes [i].trans_length_mode);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$trans_timeout_mode =

            set_of_trans_timeout_modes := - $iit$set_of_trans_timeout_modes [];
            IF NOT (connection_attributes [i].trans_timeout_mode IN set_of_trans_timeout_modes)
                  THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$unknown_trans_timeout_mode, '', status);
              k := ORD (connection_attributes [i].trans_timeout_mode);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$trans_forward_character =

            k := connection_attributes [i].trans_forward_character.size;
            IF ((k < LOWERVALUE (ift$trans_fwd_char_size)) OR (k > UPPERVALUE
                  (ift$trans_fwd_char_size))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$trans_fwd_character_size, '', status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := LOWERVALUE (ift$trans_fwd_char_size);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := UPPERVALUE (ift$trans_fwd_char_size);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$trans_message_length =

            k := connection_attributes [i].trans_message_length;
            IF ((k < LOWERVALUE (ift$trans_message_length)) OR (k > UPPERVALUE
                  (ift$trans_message_length))) THEN
              IF (k <> 0) OR (iiv$network_identifier = iic$cdcnet_network) THEN
                osp$set_status_abnormal (ifc$interactive_facility_id,
                      ife$trans_message_length, '', status);
                osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                      FALSE, status);
                k := LOWERVALUE (ift$trans_message_length);
                osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                      FALSE, status);
                k := UPPERVALUE (ift$trans_message_length);
                osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                      FALSE, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                  'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
                EXIT /change_term_conn_attributes/;
              IFEND;
            IFEND;

          = ifc$trans_terminate_character =

            k := connection_attributes [i].trans_terminate_character.size;
            IF ((k < LOWERVALUE (ift$trans_term_char_size)) OR (k > UPPERVALUE
                  (ift$trans_term_char_size))) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$trans_term_character_size, '', status);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := LOWERVALUE (ift$trans_term_char_size);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              k := UPPERVALUE (ift$trans_term_char_size);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          = ifc$trans_protocol_mode =

            set_of_trans_protocol_modes := - $iit$set_of_trans_protocol_modes [];
            IF NOT (connection_attributes [i].trans_protocol_mode IN set_of_trans_protocol_modes)
                  THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                    ife$unknown_trans_protocol_mode, '', status);
              k := ORD (connection_attributes [i].trans_protocol_mode);
              osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                    FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /change_term_conn_attributes/;
            IFEND;

          ELSE
          CASEND;

        FOREND;

    { Get a pointer to the connection attributes in the file's Local Name Table entry.

      cd_attributes_ptr := NIL;
      fmp$get_cycle_description (ultimate_name, cycle_description, status);
      IF NOT status.normal THEN
        EXIT /change_term_conn_attributes/;
      IFEND;

    /path_table_locked/
      BEGIN

        IF cycle_description^.attached_file AND (cycle_description^.device_class = rmc$terminal_device) THEN
        { RMP$REQUEST_TERMINAL created the file.
          IF cycle_description^.terminal_request <> NIL THEN
          { Attributes were specified on the request terminal call.
            cd_attributes_ptr := cycle_description^.terminal_request;
          IFEND;
        ELSE
          osp$set_status_abnormal (ifc$interactive_facility_id, ife$file_name_not_terminal,
                '', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, local_file_name,
                status);
          EXIT /path_table_locked/;
        IFEND;

        IF cd_attributes_ptr = NIL THEN

          ALLOCATE updated_attributes: [1 .. UPPERBOUND (connection_attributes)]
                IN osv$job_pageable_heap^;
          IF updated_attributes = NIL THEN
            osp$set_status_abnormal (rmc$resource_management_id, ose$job_pageable_full,
                  'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
            EXIT /path_table_locked/;
          IFEND;
          updated_attributes^ := connection_attributes;
        ELSE

        { Update cycle description attributes with attributes specified on this request.

          last_element := 0;
          FOR i := 1 TO UPPERBOUND (connection_attributes) DO

            found := FALSE;
           /find_and_update_attribute/
            FOR k := 1 TO UPPERBOUND (cd_attributes_ptr^) DO
              IF cd_attributes_ptr^ [k].key = connection_attributes [i].key THEN
                cd_attributes_ptr^ [k] := connection_attributes [i];
                found := TRUE;
                EXIT /find_and_update_attribute/;
              IFEND;
            FOREND /find_and_update_attribute/;

            IF NOT found THEN
              last_element := last_element + 1;
              new_lnt_attributes [last_element] := connection_attributes [i];
            IFEND;
          FOREND;

          IF last_element = 0 THEN
            EXIT /path_table_locked/;
          ELSE
            ALLOCATE updated_attributes: [1 .. (last_element +
                  UPPERBOUND (cd_attributes_ptr^))] IN osv$job_pageable_heap^;
            IF updated_attributes = NIL THEN
              osp$set_status_abnormal (rmc$resource_management_id,
                    ose$job_pageable_full, 'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
              EXIT /path_table_locked/;
            IFEND;
            FOR i := 1 TO last_element DO
              updated_attributes^ [i] := new_lnt_attributes [i];
            FOREND;
            k := 1;
            FOR i := (last_element + 1) TO UPPERBOUND (updated_attributes^) DO
              updated_attributes^ [i] := cd_attributes_ptr^ [k];
              k := k + 1;
            FOREND;
            FREE cycle_description^.terminal_request IN osv$job_pageable_heap^;
          IFEND; { last_element = 0 }
        IFEND; { cd_attributes_ptr = NIL }

      { Point the cycle description to the updated set of attributes }
        cycle_description^.terminal_request := updated_attributes;

      END /path_table_locked/;

      fmp$unlock_path_table;

    END /change_term_conn_attributes/;
    #KEYPOINT (osk$entry, 0, iik$change_term_conn_attributes);

  PROCEND iip$change_term_conn_attributes;
MODEND iim$change_term_conn_attributes;
*DECK DECK=IIM$CHANGE_TERM_CONN_DEFAULTS EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$change_term_conn_defaults;

{ PURPOSE:  This module provides the ring 2 interface to change the
{           default connection attributes for a dual state task.
{           Consequently, subsequent file creations will employ the
{           new attribute values, but previously created files will
{           not be affected.
{
{  DESIGN:  The new attribute values are validated and are then used
{           to replace corresponding values in an IF attributes table
{           which resides in task shared memory.
{
{           For dual state connections, attribute validation consists
{           of verifying that the attribute key is known and that the
{           value is within the valid range for the attribute.  Once
{           this verification is completed for each input attribute
{           the new values replace their corresponding attributes in
{           a task-shared table of attributes pointed at by the
{           iiv$terminal_request_ptr.
{
?? TITLE := 'MODULE iim$change_term_conn_defaults' ??

?? PUSH (LISTEXT := ON) ??
*copyc AMP$FETCH
*copyc CLP$GET_ULTIMATE_CONNECTION
*copyc IFE$ERROR_CODES
*copyc iik$keypoints
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIP$ALLOCATE_QUEUE_ENTRY
*copyc IIP$BUILD_TERM_CONN_ATTR_ARRAY
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIV$INT_TASK_OPEN_FILE_COUNT
*copyc JMP$SYSTEM_JOB
*copyc OST$STATUS
*copyc OSP$APPEND_STATUS_INTEGER
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$GET_JOB_MODE
*copyc RMP$GET_DEVICE_CLASS
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$change_term_conn_defaults', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$change_term_conn_defaults (
        connection_attributes: ift$connection_attributes;
    VAR status: ost$status);

    VAR
      device_assigned: boolean,
      device_class: rmt$device_class,
      fetch_attributes: array [1 .. 1] of amt$fetch_item,
      i: integer,
      j: ift$connection_attribute_keys,
      job_mode: jmt$job_mode,
      k: integer,
      local_status: ost$status,
      replace_attributes: iit$connection_attributes,
      set_of_input_editing_modes: iit$set_of_input_editing_modes,
      set_of_input_output_modes: iit$set_of_input_output_modes,
      set_of_terminal_attribute_keys: iit$set_of_term_conn_attr_keys,
      set_of_trans_char_modes: iit$set_of_trans_char_modes,
      set_of_trans_length_modes: iit$set_of_trans_length_modes,
      set_of_trans_protocol_modes: iit$set_of_trans_protocol_modes,
      set_of_trans_timeout_modes: iit$set_of_trans_timeout_modes,
      terminal_request_attributes: iit$connection_attributes,
      terminal_request_descriptor: iit$queue_entry_descriptor,
      ultimate_prompt_file: amt$local_file_name;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, iik$change_term_conn_defaults);

  { Validate the connection attribute keys.

    set_of_terminal_attribute_keys := - $iit$set_of_term_conn_attr_keys [];
    FOR i := LOWERBOUND (connection_attributes) TO UPPERBOUND (connection_attributes) DO
      IF NOT (connection_attributes [i].key IN set_of_terminal_attribute_keys) THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$unknown_attribute_key, '', status);
        k := ORD (connection_attributes [i].key);
        osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
              FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
        RETURN;
      IFEND;
    FOREND;

  { Validate the attribute values.

    FOR i := LOWERBOUND (connection_attributes) TO UPPERBOUND
          (connection_attributes) DO

      CASE connection_attributes [i].key OF

      = ifc$attention_character_action =

        k := connection_attributes [i].attention_character_action;
        IF ((k < LOWERVALUE (ift$attention_character_action)) OR (k >
              UPPERVALUE (ift$attention_character_action))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$attention_character_action, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$attention_character_action);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$attention_character_action);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$break_key_action =

        k := connection_attributes [i].break_key_action;
        IF ((k < LOWERVALUE (ift$break_key_action)) OR (k >
              UPPERVALUE (ift$break_key_action))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$break_key_action, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$break_key_action);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$break_key_action);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$end_of_information =

        k := connection_attributes [i].end_of_information.size;
        IF ((k < LOWERVALUE (ift$end_of_information_size)) OR (k > UPPERVALUE
              (ift$end_of_information_size))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$end_of_information_size, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$end_of_information_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$end_of_information_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$input_block_size =

        k := connection_attributes [i].input_block_size;
        IF ((k < LOWERVALUE (ift$input_block_size)) OR (k > UPPERVALUE
              (ift$input_block_size))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$input_block_size, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$input_block_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$input_block_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$input_editing_mode =

        set_of_input_editing_modes := - $iit$set_of_input_editing_modes [];
        IF NOT (connection_attributes [i].input_editing_mode IN set_of_input_editing_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_input_editing_mode, '', status);
          k := ORD (connection_attributes [i].input_editing_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$input_output_mode =

        set_of_input_output_modes := - $iit$set_of_input_output_modes [];
        IF NOT (connection_attributes [i].input_output_mode IN set_of_input_output_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_input_output_mode, '', status);
          k := ORD (connection_attributes [i].input_output_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$input_timeout =

        IF ((connection_attributes [i].input_timeout < LOWERVALUE
              (boolean)) OR (connection_attributes [i].input_timeout >
              UPPERVALUE (boolean))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$input_timeout, 'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$input_timeout_length =

        k := connection_attributes [i].input_timeout_length;
        IF ((k < LOWERVALUE (ift$input_timeout_length)) OR (k > UPPERVALUE
              (ift$input_timeout_length))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$input_timeout_length, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$input_timeout_length);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$input_timeout_length);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$input_timeout_purge =

        IF ((connection_attributes [i].input_timeout_purge < LOWERVALUE
              (boolean)) OR (connection_attributes [i].input_timeout_purge >
              UPPERVALUE (boolean))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$input_timeout_purge, 'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$partial_char_forwarding =

        IF ((connection_attributes [i].partial_character_forwarding < LOWERVALUE
              (boolean)) OR (connection_attributes [i].partial_character_forwarding >
              UPPERVALUE (boolean))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$partial_char_forwarding, 'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$prompt_file =

        clp$get_ultimate_connection (connection_attributes [i].prompt_file, ultimate_prompt_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Verify that the file is assigned to a terminal device.

        rmp$get_device_class (ultimate_prompt_file, device_assigned, device_class, local_status);
        IF NOT local_status.normal THEN
          status := local_status;
          RETURN;
        ELSE
          IF NOT device_assigned THEN
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$prompt_file_name_not_found, ultimate_prompt_file, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
              'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
            RETURN;
          ELSEIF device_class <> rmc$terminal_device THEN
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$prompt_file_name_not_term, ultimate_prompt_file, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
              'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
            RETURN;
          IFEND;
        IFEND;

      = ifc$prompt_file_identifier =

{ Get the file_name for the file_id.

{ The following code is no-op'ed until BAM provides a way to obtain
{ the local_file_name given the file_id.

{       fetch_attributes [1].key := amc$local_file_name;
{       amp$fetch (connection_attributes [i].prompt_file_identifier, fetch_attributes,
{             local_status);
{       IF NOT local_status.normal THEN
{         status := local_status;
{         RETURN;
{       IFEND;
{
{ Verify that the file is assigned to a terminal device.
{
{       rmp$get_device_class (fetch_attributes [1].file_name^.local_file_name,
{             device_assigned, device_class, local_status);
{       IF NOT local_status.normal THEN
{         status := local_status;
{         RETURN;
{       ELSE
{         IF NOT device_assigned THEN
{           osp$set_status_abnormal (ifc$interactive_facility_id,
{                 ife$prompt_file_id_not_found, fetch_attributes [1].
{                 file_name^.local_file_name, status);
{           osp$append_status_parameter (osc$status_parameter_delimiter,
{             'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
{           RETURN;
{         ELSEIF device_class <> rmc$terminal_device THEN
{           osp$set_status_abnormal (ifc$interactive_facility_id,
{                 ife$prompt_file_id_not_term, fetch_attributes [1].file_name^.
{                 local_file_name, status);
{           osp$append_status_parameter (osc$status_parameter_delimiter,
{             'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
{           RETURN;
{         IFEND;
{       IFEND;

      = ifc$prompt_string =

        k := connection_attributes [i].prompt_string.size;
        IF ((k < LOWERVALUE (ift$prompt_string_size)) OR (k > UPPERVALUE
              (ift$prompt_string_size))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$prompt_string_size, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$prompt_string_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$prompt_string_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$store_backspace_character =

        IF ((connection_attributes [i].store_backspace_character < LOWERVALUE
              (boolean)) OR (connection_attributes [i].store_backspace_character >
              UPPERVALUE (boolean))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$store_backspace_character, 'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$store_nuls_dels =

        IF ((connection_attributes [i].store_nuls_dels < LOWERVALUE
              (boolean)) OR (connection_attributes [i].store_nuls_dels >
              UPPERVALUE (boolean))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$store_nuls_dels, 'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$trans_character_mode =

        set_of_trans_char_modes := - $iit$set_of_trans_char_modes [];
        IF NOT (connection_attributes [i].trans_character_mode IN set_of_trans_char_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_trans_char_mode, '', status);
          k := ORD (connection_attributes [i].trans_character_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$trans_length_mode =

        set_of_trans_length_modes := - $iit$set_of_trans_length_modes [];
        IF NOT (connection_attributes [i].trans_length_mode IN set_of_trans_length_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_trans_length_mode, '', status);
          k := ORD (connection_attributes [i].trans_length_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$trans_timeout_mode =

        set_of_trans_timeout_modes := - $iit$set_of_trans_timeout_modes [];
        IF NOT (connection_attributes [i].trans_timeout_mode IN set_of_trans_timeout_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_trans_timeout_mode, '', status);
          k := ORD (connection_attributes [i].trans_timeout_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$trans_forward_character =

        k := connection_attributes [i].trans_forward_character.size;
        IF ((k < LOWERVALUE (ift$trans_fwd_char_size)) OR (k > UPPERVALUE
              (ift$trans_fwd_char_size))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$trans_fwd_character_size, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$trans_fwd_char_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$trans_fwd_char_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$trans_message_length =

        k := connection_attributes [i].trans_message_length;
        IF ((k < LOWERVALUE (ift$trans_message_length)) OR (k > UPPERVALUE
              (ift$trans_message_length))) THEN
          IF k <> 0 THEN
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$trans_message_length, '', status);
            osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                  FALSE, status);
            k := LOWERVALUE (ift$trans_message_length);
            osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                  FALSE, status);
            k := UPPERVALUE (ift$trans_message_length);
            osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                  FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
              'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
            RETURN;
          IFEND;
        IFEND;

      = ifc$trans_terminate_character =

        k := connection_attributes [i].trans_terminate_character.size;
        IF ((k < LOWERVALUE (ift$trans_term_char_size)) OR (k > UPPERVALUE
              (ift$trans_term_char_size))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$trans_term_character_size, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$trans_term_char_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$trans_term_char_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$trans_protocol_mode =

        set_of_trans_protocol_modes := - $iit$set_of_trans_protocol_modes [];
        IF NOT (connection_attributes [i].trans_protocol_mode IN set_of_trans_protocol_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_trans_protocol_mode, '', status);
          k := ORD (connection_attributes [i].trans_protocol_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      ELSE
      CASEND;

    FOREND; { validate each input attribute value }

  { Initialize the terminal request attributes.

    IF iiv$terminal_request_ptr = NIL THEN
      terminal_request_attributes := iiv$init_undefined_attributes;
    ELSE
      terminal_request_attributes := iiv$terminal_request_ptr^;
    IFEND;

  { Replace the attributes specified on the IFP$CHANGE_TERM_CONN_DEFAULTS in the
  { terminal request table.

    FOR i := LOWERBOUND (connection_attributes) TO UPPERBOUND (connection_attributes) DO
      CASE connection_attributes [i].key OF

      = ifc$attention_character_action =
        terminal_request_attributes.attention_character_action.value := connection_attributes [i].
              attention_character_action;
        terminal_request_attributes.attention_character_action.source := ifc$change_term_conn_dflt_req;

      = ifc$break_key_action =
        terminal_request_attributes.break_key_action.value := connection_attributes [i].
              break_key_action;
        terminal_request_attributes.break_key_action.source := ifc$change_term_conn_dflt_req;

      = ifc$end_of_information =
        terminal_request_attributes.end_of_information.value := connection_attributes [i].
              end_of_information;
        terminal_request_attributes.end_of_information.source := ifc$change_term_conn_dflt_req;

      = ifc$input_block_size =
        terminal_request_attributes.input_block_size.value := connection_attributes [i].
              input_block_size;
        terminal_request_attributes.input_block_size.source := ifc$change_term_conn_dflt_req;

      = ifc$input_editing_mode =
        terminal_request_attributes.input_editing_mode.value := connection_attributes [i].
              input_editing_mode;
        terminal_request_attributes.input_editing_mode.source := ifc$change_term_conn_dflt_req;

      = ifc$input_output_mode =
        terminal_request_attributes.input_output_mode.value := connection_attributes [i].
              input_output_mode;
        terminal_request_attributes.input_output_mode.source := ifc$change_term_conn_dflt_req;

      = ifc$input_timeout =
        terminal_request_attributes.input_timeout.value := connection_attributes [i].
              input_timeout;
        terminal_request_attributes.input_timeout.source := ifc$change_term_conn_dflt_req;

      = ifc$input_timeout_length =
        terminal_request_attributes.input_timeout_length.value := connection_attributes [i].
              input_timeout_length;
        terminal_request_attributes.input_timeout_length.source := ifc$change_term_conn_dflt_req;

      = ifc$input_timeout_purge =
        terminal_request_attributes.input_timeout_purge.value := connection_attributes [i].
              input_timeout_purge;
        terminal_request_attributes.input_timeout_purge.source := ifc$change_term_conn_dflt_req;

      = ifc$partial_char_forwarding =
        terminal_request_attributes.partial_char_forwarding.value := connection_attributes [i].
              partial_character_forwarding;
        terminal_request_attributes.partial_char_forwarding.source := ifc$change_term_conn_dflt_req;

      = ifc$prompt_file =
        terminal_request_attributes.prompt_file.value := connection_attributes [i].
              prompt_file;
        terminal_request_attributes.prompt_file.source := ifc$change_term_conn_dflt_req;

      = ifc$prompt_file_identifier =
        terminal_request_attributes.prompt_file_identifier.value := connection_attributes [i].
              prompt_file_identifier;
        terminal_request_attributes.prompt_file_identifier.source := ifc$change_term_conn_dflt_req;

      = ifc$prompt_string =
        terminal_request_attributes.prompt_string.value := connection_attributes [i].
              prompt_string;
        terminal_request_attributes.prompt_string.source := ifc$change_term_conn_dflt_req;

      = ifc$store_backspace_character =
        terminal_request_attributes.store_backspace_character.value := connection_attributes [i].
              store_backspace_character;
        terminal_request_attributes.store_backspace_character.source := ifc$change_term_conn_dflt_req;

      = ifc$store_nuls_dels =
        terminal_request_attributes.store_nuls_dels.value := connection_attributes [i].
              store_nuls_dels;
        terminal_request_attributes.store_nuls_dels.source := ifc$change_term_conn_dflt_req;

      = ifc$trans_character_mode =
        terminal_request_attributes.trans_character_mode.value := connection_attributes [i].
              trans_character_mode;
        terminal_request_attributes.trans_character_mode.source := ifc$change_term_conn_dflt_req;

      = ifc$trans_forward_character =
        terminal_request_attributes.trans_forward_character.value := connection_attributes [i].
              trans_forward_character;
        terminal_request_attributes.trans_forward_character.source := ifc$change_term_conn_dflt_req;

      = ifc$trans_length_mode =
        terminal_request_attributes.trans_length_mode.value := connection_attributes [i].
              trans_length_mode;
        terminal_request_attributes.trans_length_mode.source := ifc$change_term_conn_dflt_req;

      = ifc$trans_timeout_mode =
        terminal_request_attributes.trans_timeout_mode.value := connection_attributes [i].
              trans_timeout_mode;
        terminal_request_attributes.trans_timeout_mode.source := ifc$change_term_conn_dflt_req;

      = ifc$trans_message_length =
        terminal_request_attributes.trans_message_length.value := connection_attributes [i].
              trans_message_length;
        terminal_request_attributes.trans_message_length.source := ifc$change_term_conn_dflt_req;

      = ifc$trans_terminate_character =
        terminal_request_attributes.trans_terminate_character.value := connection_attributes [i].
              trans_terminate_character;
        terminal_request_attributes.trans_terminate_character.source := ifc$change_term_conn_dflt_req;

      = ifc$trans_protocol_mode =
        terminal_request_attributes.trans_protocol_mode.value := connection_attributes [i].
              trans_protocol_mode;
        terminal_request_attributes.trans_protocol_mode.source := ifc$change_term_conn_dflt_req;

      ELSE
      CASEND;
    FOREND;

{ Allocate a terminal request table if the task doesn't have one.

    IF iiv$terminal_request_ptr = NIL THEN
      iip$allocate_queue_entry (iic$terminal_request,
            terminal_request_descriptor, local_status);
      iiv$terminal_request_ptr := terminal_request_descriptor.terminal_request_ptr;
    IFEND;

  { Replace the terminal request attributes in the terminal request table.

    iiv$terminal_request_ptr^ := terminal_request_attributes;

    #KEYPOINT (osk$exit, 0, iik$change_term_conn_defaults);

  PROCEND iip$change_term_conn_defaults;

MODEND iim$change_term_conn_defaults;
*DECK DECK=IIM$CLEAR_JOB_LOCKS EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$clear_job_locks;
?? TITLE := 'MODULE iim$clear_job_locks' ??

?? PUSH (LISTEXT := ON) ??
*copyc iiv$connection_desc_ptr
*copyc iiv$interactive_terminated
*copyc iiv$io_requests_in_job
*copyc iiv$io_requests_in_task
*copyc iiv$xt_xterm_control_block
*copyc jmv$timesharing_job
*copyc jmv$xterm_job
*copyc osp$clear_job_signature_lock
*copyc osp$decrement_locked_variable
*copyc osp$test_sig_lock
*copyc pmp$log
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$clear_job_locks' ??

  PROCEDURE [XDCL, #GATE] iip$clear_job_locks (VAR status: ost$status);

    VAR
      decrement_error: boolean,
      io_requests_in_job: integer,
      ls: ost$signature_lock_status,
      local_status: ost$status;

    status.normal := TRUE;

    IF jmv$timesharing_job or jmv$xterm_job THEN
      WHILE iiv$io_requests_in_task > 0 DO
        iiv$io_requests_in_task := iiv$io_requests_in_task - 1;
        osp$decrement_locked_variable (iiv$io_requests_in_job, iiv$io_requests_in_job,
              io_requests_in_job, decrement_error);
      WHILEND;
    IFEND;

    osp$test_sig_lock (iiv$get_lock, ls);
    IF ls = osc$sls_locked_by_current_task THEN
      iiv$get_info.position_in_block := 1;
      iiv$get_info.file_position := amc$eor;
      osp$clear_job_signature_lock (iiv$get_lock);
      pmp$log ('task exit - iiv$get_lock cleared', local_status);
    IFEND;

    osp$test_sig_lock (iiv$downline_queue_lock, ls);
    IF ls = osc$sls_locked_by_current_task THEN
      osp$clear_job_signature_lock (iiv$downline_queue_lock);
      pmp$log ('task exit - iiv$downline_queue_lock cleared', local_status);
    IFEND;

    osp$test_sig_lock (iiv$interactive_task_count_lock, ls);

    IF ls = osc$sls_locked_by_current_task THEN
      osp$clear_job_signature_lock (iiv$interactive_task_count_lock);
      pmp$log ('task exit - iiv$interactive_task_count_lock cleared',
        local_status);
    IFEND;

    osp$test_sig_lock (iiv$connection_desc_lock, ls);
    IF ls = osc$sls_locked_by_current_task THEN
      osp$clear_job_signature_lock (iiv$connection_desc_lock);
      pmp$log ('task exit - iiv$connection_desc_lock cleared', local_status);
    IFEND;

    osp$test_sig_lock (iiv$xt_xterm_control_block.upline_lock, ls);
    IF ls = osc$sls_locked_by_current_task THEN
      osp$clear_job_signature_lock (iiv$xt_xterm_control_block.upline_lock);
    IFEND;

    osp$test_sig_lock (iiv$xt_xterm_control_block.downline_lock, ls);
    IF ls = osc$sls_locked_by_current_task THEN
      osp$clear_job_signature_lock (iiv$xt_xterm_control_block.downline_lock);
    IFEND;
  PROCEND iip$clear_job_locks;

MODEND iim$clear_job_locks;
*DECK DECK=IIM$CLOSE EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$close;
?? TITLE := 'MODULE iim$close' ??

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMP$CLOSE
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIP$CLEAR_LOCK
*copyc IIP$FREE_QUEUE_ENTRY
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIP$PUT
*copyc IIP$REPORT_STATUS_ERROR
*copyc IIP$SIGN_OFF
*copyc IIP$SKIP_TO_EOR
*copyc iip$flush
*copyc IIP$SET_LOCK
*copyc IIV$INT_TASK_OPEN_FILE_COUNT
*copyc OST$STATUS
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$close', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$close (file_id: amt$file_identifier;
    VAR open_file_desc_pointer: ^iit$open_file_description;
    VAR status: ost$status);

    VAR
      open_file_entry_descriptor: iit$queue_entry_descriptor,
      local_status: ost$status;

{ Return with normal status if the file is not open because BAM must close file.

      status.normal := TRUE;

      IF open_file_desc_pointer = NIL THEN
        RETURN;
      IFEND;

{ Close the prompt file if the system has opened it.

    IF ((open_file_desc_pointer^.attributes.prompt_file_identifier.value.ordinal <> 0) AND
          (open_file_desc_pointer^.attributes.prompt_file_identifier.
          source = ifc$os_default)) THEN
      amp$close (open_file_desc_pointer^.attributes.prompt_file_identifier.value, local_status);
    IFEND;

{ Decrement task open file count.

    IF iiv$int_task_open_file_count > 0 THEN
    iiv$int_task_open_file_count := iiv$int_task_open_file_count - 1;
    IFEND;

{ Terminate the previous record if at mid_record.

    IF iiv$put_info.last_term_option <> amc$terminate THEN
      iip$put (file_id, open_file_desc_pointer, amc$put_partial_req, NIL, 0,
        NIL, amc$terminate, local_status);
    IFEND;
    iip$flush (file_id, open_file_desc_pointer, local_status);

    IF (iiv$int_task_open_file_count = 0) THEN

{ Decrement interactive task count.

      iip$set_lock (iiv$interactive_task_count_lock, osc$wait, local_status);
      iiv$interactive_task_count := iiv$interactive_task_count - 1;
      iip$clear_lock (iiv$interactive_task_count_lock, local_status);

      iip$sign_off (iiv$int_application_name, local_status);

    IFEND;

    open_file_entry_descriptor.open_file_description_ptr :=
      open_file_desc_pointer;
    iip$free_queue_entry (iic$open_file_description,
      open_file_entry_descriptor, local_status);

  PROCEND iip$close;

MODEND iim$close;
*DECK DECK=IIM$DIRECT_FETCH_TRM_CONN_ATTS EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$direct_fetch_trm_conn_atts;

?? TITLE := '  [XDCL] IIP$DIRECT_FETCH_TRM_CONN_ATTS' ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc bap$validate_file_identifier
*copyc ife$error_codes
*copyc iip$fetch_term_conn_attributes
*copyc iip$fetch_terminal
*copyc iiv$interactive_terminated
*copyc osp$set_status_abnormal
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iip$direct_fetch_trm_conn_atts (file_identifier:
    amt$file_identifier;
    VAR terminal_attributes: ift$get_connection_attributes;
    VAR status: ost$status);

    CONST
      interface_name = 'IIP$DIRECT_FETCH_TRM_CONN_ATTS';

    VAR
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      open_file_dsc_pointer: ^iit$open_file_description,
      store_attributes: ^ift$connection_attributes,
      st_open_file_dsc_pointer: ^iit$st_open_file_description;


    status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      RETURN;
    IFEND;

    IF (file_instance <> NIL) THEN
      IF file_instance^.device_class =
        rmc$terminal_device THEN
        CASE iiv$network_identifier OF
        = iic$cdcnet_network =
          st_open_file_dsc_pointer :=
          file_instance^.st_open_file_dsc_pointer;
          iip$fetch_term_conn_attributes (file_identifier,
            st_open_file_dsc_pointer, terminal_attributes, status);
        = iic$dsiaf_network =
          open_file_dsc_pointer :=
          file_instance^.open_file_dsc_pointer;
          iip$fetch_terminal (file_identifier, open_file_dsc_pointer,
            ^terminal_attributes, status);
        ELSE
        CASEND;

      ELSE
        osp$set_status_abnormal (ifc$interactive_facility_id,
          ife$file_name_not_terminal,
          file_instance^.local_file_name,status);
      IFEND;
    ELSE
      osp$set_status_abnormal (ifc$interactive_facility_id,
        ife$file_name_not_terminal,
        file_instance^.local_file_name,status);
    IFEND;
  PROCEND iip$direct_fetch_trm_conn_atts;
MODEND iim$direct_fetch_trm_conn_atts;
*DECK DECK=IIM$DIRECT_STORE_TRM_CONN_ATTS EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$direct_store_trm_conn_atts;

?? TITLE := '  [XDCL] IIP$DIRECT_STORE_TRM_CONN_ATTS' ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc bap$validate_file_identifier
*copyc ife$error_codes
*copyc iip$store_term_conn_attributes
*copyc iip$store_terminal
*copyc iiv$interactive_terminated
*copyc osp$set_status_abnormal
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iip$direct_store_trm_conn_atts (file_identifier:
    amt$file_identifier;
        terminal_attributes: ift$connection_attributes;
    VAR status: ost$status);

    CONST
      interface_name = 'IIP$DIRECT_STORE_TRM_CONN_ATTS';

    VAR
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      open_file_dsc_pointer: ^iit$open_file_description,
      store_attributes: ^ift$connection_attributes,
      st_open_file_dsc_pointer: ^iit$st_open_file_description;


    status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      RETURN;
    IFEND;

    IF (file_instance <> NIL) THEN
      IF file_instance^.device_class =
        rmc$terminal_device THEN
        CASE iiv$network_identifier OF
        = iic$cdcnet_network =
          st_open_file_dsc_pointer :=
          file_instance^.st_open_file_dsc_pointer;
          iip$store_term_conn_attributes (file_identifier,
            st_open_file_dsc_pointer, ^terminal_attributes, status);
        = iic$dsiaf_network =
          open_file_dsc_pointer :=
          file_instance^.open_file_dsc_pointer;
          iip$store_terminal (file_identifier, open_file_dsc_pointer,
            ^terminal_attributes, status);
        ELSE
        CASEND;

      ELSE
        osp$set_status_abnormal (ifc$interactive_facility_id,
          ife$file_name_not_terminal,
          file_instance^.local_file_name,status);
      IFEND;
    ELSE
      osp$set_status_abnormal (ifc$interactive_facility_id,
        ife$file_name_not_terminal,
        file_instance^.local_file_name,status);
    IFEND;
  PROCEND iip$direct_store_trm_conn_atts;
MODEND iim$direct_store_trm_conn_atts;
*DECK DECK=IIM$DPC64_TO_STRING EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Interactive Facility' ??
?? NEWTITLE := '  [XDCL] iip$dpc64_to_string' ??
MODULE iim$dpc64_to_string;


{ Global Constants and Types
*copyc oss$job_paged_literal
*copyc IFV$MODULE_FOR_C180
?? SET (LIST := OFF) ??
*copyc iit$application_names_messages
?? SET (LIST := ON) ??
?? TITLE := 'PROCEDURE [XDCL] iip$dpc64_to_string', EJECT ??

  PROCEDURE [XDCL] iip$dpc64_to_string (VAR dpc: packed array [ * ] OF
    iit$display_code;
    dpc_length: integer;
    trailing_char_to_suppress: char;
    VAR str: string ( * );
    VAR str_length: integer);

    VAR
      ascii: [STATIC, READ, oss$job_paged_literal] string (64) :=
        ':ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789+-*/()$= ,.#[]%"_!&''?<>@\^;',
      str_index: integer,
      dpc_index: integer,
      last_dpc: integer;

{ Determine the last display code character to convert

    IF dpc_length > ((UPPERBOUND (dpc) - LOWERBOUND (dpc)) + 1) THEN
      last_dpc := UPPERBOUND (dpc);
    ELSE
      last_dpc := LOWERBOUND (dpc) + dpc_length - 1;
    IFEND;

{ Convert DPC to ASCII

    str_index := 0;
    str_length := 0;
  /convert_to_string/
    FOR dpc_index := LOWERBOUND (dpc) TO last_dpc DO
      str_index := str_index + 1;
      IF str_index > STRLENGTH (str) THEN
        EXIT /convert_to_string/;
      IFEND;
      str (str_index) := ascii (dpc [dpc_index] + 1);
      IF str (str_index) <> trailing_char_to_suppress THEN
        str_length := str_index;
      IFEND;
    FOREND;

  PROCEND iip$dpc64_to_string;
MODEND
*DECK DECK=IIM$FETCH_ACCESS_INFORMATION EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$fetch_access_information;
?? TITLE := 'MODULE iim$fetch_access_information' ??

?? PUSH (LISTEXT := ON) ??
*copyc AME$IMPROPER_ACCESS_INFO_KEY
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc IIK$KEYPOINTS
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIV$INT_TASK_OPEN_FILE_COUNT
*copyc OST$STATUS
*copyc PMP$LOG
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$fetch_access_information', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$fetch_access_information (file_id:
    amt$file_identifier;
    open_file_desc_pointer: ^iit$open_file_description;
    access_information: ^amt$access_information;
    VAR status: ost$status);

    VAR
      set_of_access_info_keys: iit$set_of_access_info_keys,
      i: integer;

    status.normal := TRUE;

  /fetch_access_information/
    BEGIN

      set_of_access_info_keys := - $iit$set_of_access_info_keys [];
      FOR i := 1 TO UPPERBOUND (access_information^) DO
        IF NOT (access_information^ [i].key IN set_of_access_info_keys) THEN
          amp$set_file_instance_abnormal (file_id, ame$improper_access_info_key,
                amc$fetch_access_information_rq, '', status);
            EXIT /fetch_access_information/;
        IFEND;
      FOREND;

      FOR i := 1 TO UPPERBOUND (access_information^) DO

        access_information^ [i].item_returned := TRUE;

        CASE access_information^ [i].key OF

        = amc$block_number =
          access_information^ [i].block_number := 1;

        = amc$error_status =
          access_information^ [i].error_status := open_file_desc_pointer^.
                error_status;

        = amc$file_position =
          CASE open_file_desc_pointer^.last_get_put_operation OF
          = amc$get_next_req, amc$get_partial_req, amc$get_direct_req =
            access_information^ [i].file_position := iiv$get_info.file_position;
          = amc$put_next_req, amc$put_partial_req, amc$put_direct_req =
            IF iiv$put_info.last_term_option = amc$terminate THEN
              access_information^ [i].file_position := amc$eor;
            ELSE
              access_information^ [i].file_position := amc$mid_record;
            IFEND;
          ELSE
            pmp$log (' fetch_access_info: unknown last_get_put_operation', status);
          CASEND;

        = amc$last_access_operation =
          access_information^ [i].last_access_operation :=
                open_file_desc_pointer^.last_access_operation;

        = amc$last_op_status =
          access_information^ [i].last_op_status := amc$complete;

        = amc$previous_record_length =
          CASE open_file_desc_pointer^.last_get_put_operation OF
          = amc$get_next_req, amc$get_partial_req, amc$get_direct_req =
            IF iiv$get_info.file_position <> amc$mid_record THEN
              access_information^ [i].previous_record_length :=
                    open_file_desc_pointer^.previous_record_length;
            ELSE
              access_information^ [i].item_returned := FALSE;
            IFEND;
          = amc$put_next_req, amc$put_partial_req, amc$put_direct_req =
            IF iiv$put_info.last_term_option = amc$terminate THEN
              access_information^ [i].previous_record_length :=
                    open_file_desc_pointer^.previous_record_length;
            ELSE
              access_information^ [i].item_returned := FALSE;
            IFEND;
          ELSE
            pmp$log (' fetch_access_info: unknown previous_record_length', status);
          CASEND;

        ELSE
          access_information^ [i].item_returned := FALSE;
        CASEND;

      FOREND;

    END /fetch_access_information/;

  PROCEND iip$fetch_access_information;
MODEND iim$fetch_access_information;
*DECK DECK=IIM$FETCH_CONTEXT EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$fetch_context;
?? TITLE := 'MODULE iim$fetch_context' ??

?? PUSH (LISTEXT := ON) ??
*copyc ift$fetch_context_attributes
*copyc iiv$interactive_terminated
*copyc OST$STATUS
*copyc nat$data_fragments
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$fetch_context', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$fetch_context (VAR {i/o} context_attributes:
    ift$fetch_context_attributes;
    VAR status: ost$status);

    VAR
      i: integer;

    status.normal := TRUE;

    FOR i := LOWERBOUND (context_attributes) TO UPPERBOUND (context_attributes) DO
      CASE context_attributes [i].key OF
      = ifc$previous_mode =
        CASE iiv$previous_mode OF
        = iic$line =
          context_attributes [i].previous_mode := ifc$line;
        = iic$screen =
          context_attributes [i].previous_mode := ifc$screen;
        CASEND;
      = ifc$previous_file_id =
        context_attributes [i].previous_file_id := iiv$previous_file_id;
      = ifc$previous_operation =
        context_attributes [i].previous_operation := iiv$previous_operation;
        IF iiv$previous_blank_flag THEN
          context_attributes [i].previous_operation := amc$get_next_req;
        IFEND;
      ELSE
      CASEND;
    FOREND;

  PROCEND iip$fetch_context;

MODEND iim$fetch_context;
*DECK DECK=IIM$FETCH_TERMINAL EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$fetch_terminal;
?? TITLE := 'MODULE iim$fetch_terminal' ??

?? PUSH (LISTEXT := ON) ??
*copyc IFE$ERROR_CODES
*copyc ift$get_connection_attributes
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIP$UPDATE_OPEN_DESC_ATTRIBUTES
*copyc OST$STATUS
*copyc OSP$APPEND_STATUS_INTEGER
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$GET_JOB_MODE
*copyc jmp$system_job
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$fetch_terminal', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$fetch_terminal (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$open_file_description;
    terminal_attributes: ^ift$get_connection_attributes;
    VAR status: ost$status);

    VAR
      get_all_attributes: iit$connection_attributes,
      set_of_terminal_attribute_keys: iit$set_of_term_conn_attr_keys,
      i: integer,
      j: ift$connection_attribute_keys,
      k: integer,
      job_mode: jmt$job_mode,
      local_status: ost$status;

    status.normal := TRUE;

{ Verify that this is an interactive job.

    pmp$get_job_mode (job_mode, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    ELSEIF NOT jmp$system_job () THEN
      IF NOT (job_mode IN $iit$job_modes [jmc$interactive_connected,
            jmc$interactive_cmnd_disconnect, jmc$interactive_line_disconnect,
            jmc$interactive_sys_disconnect]) THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$current_job_not_interactive, 'IFP$FETCH_TERMINAL', status);
        RETURN;
      IFEND;
    IFEND;

{ Validate the terminal attribute keys.

    set_of_terminal_attribute_keys := - $iit$set_of_term_conn_attr_keys [];
    FOR i := LOWERBOUND (terminal_attributes^) TO UPPERBOUND
          (terminal_attributes^) DO
      IF NOT (terminal_attributes^ [i].key IN set_of_terminal_attribute_keys)
            THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$unknown_attribute_key, '', status);
        k := ORD (terminal_attributes^ [i].key);
        osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
              FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$FETCH_TERMINAL', status);
        RETURN;
      IFEND;
    FOREND;

{ Update the terminal attributes for the file id if they might have changed.

    IF open_file_desc_pointer^.attributes_cycle <> open_file_desc_pointer^.
      connection_desc_pointer^.attributes_cycle THEN
      iip$update_open_desc_attributes (file_id, open_file_desc_pointer,
            ifc$fetch_terminal_req, local_status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF NOT iiv$cdcnet_connection THEN
    { For those attributes which are ignored in dual state 255x connections,
    { replace their keys in terminal_attributes with ifc$null_connection_attribute.

      FOR i := 1 TO UPPERBOUND (terminal_attributes^) DO
        CASE terminal_attributes^ [i].key OF
        = ifc$trans_protocol_mode =
          terminal_attributes^ [i].key := ifc$null_connection_attribute;

        ELSE
        { All other attributes will have their values returned.
        CASEND;

      FOREND;
    IFEND;

{ Get the terminal attributes for the file id.

    FOR i := 1 TO UPPERBOUND (terminal_attributes^) DO
      CASE terminal_attributes^ [i].key OF
      = ifc$attention_character_action =
        terminal_attributes^ [i].attention_character_action := open_file_desc_pointer^.
              attributes.attention_character_action.value;
      = ifc$break_key_action =
        terminal_attributes^ [i].break_key_action := open_file_desc_pointer^.
              attributes.break_key_action.value;
      = ifc$end_of_information =
        terminal_attributes^ [i].end_of_information := open_file_desc_pointer^.
              attributes.end_of_information.value;
      = ifc$input_block_size =
        terminal_attributes^ [i].input_block_size := open_file_desc_pointer^.
              attributes.input_block_size.value;
      = ifc$input_editing_mode =
        terminal_attributes^ [i].input_editing_mode := open_file_desc_pointer^.
              attributes.input_editing_mode.value;
      = ifc$input_output_mode =
        terminal_attributes^ [i].input_output_mode := open_file_desc_pointer^.
              attributes.input_output_mode.value;
      = ifc$input_timeout =
        terminal_attributes^ [i].input_timeout := open_file_desc_pointer^.
              attributes.input_timeout.value;
      = ifc$input_timeout_length =
        terminal_attributes^ [i].input_timeout_length := open_file_desc_pointer^.
              attributes.input_timeout_length.value;
      = ifc$input_timeout_purge =
        terminal_attributes^ [i].input_timeout_purge := open_file_desc_pointer^.
              attributes.input_timeout_purge.value;
      = ifc$partial_char_forwarding =
        terminal_attributes^ [i].partial_character_forwarding := open_file_desc_pointer^.
              attributes.partial_char_forwarding.value;
      = ifc$prompt_file =
        terminal_attributes^ [i].prompt_file := open_file_desc_pointer^.
              attributes.prompt_file.value;
      = ifc$prompt_file_identifier =
        terminal_attributes^ [i].prompt_file_identifier := open_file_desc_pointer^.
              attributes.prompt_file_identifier.value;
      = ifc$prompt_string =
        terminal_attributes^ [i].prompt_string := open_file_desc_pointer^.
              attributes.prompt_string.value;
      = ifc$store_backspace_character =
        terminal_attributes^ [i].store_backspace_character := open_file_desc_pointer^.
              attributes.store_backspace_character.value;
      = ifc$store_nuls_dels =
        terminal_attributes^ [i].store_nuls_dels := open_file_desc_pointer^.
              attributes.store_nuls_dels.value;
      = ifc$trans_character_mode =
        terminal_attributes^ [i].trans_character_mode := open_file_desc_pointer^.
              attributes.trans_character_mode.value;
      = ifc$trans_forward_character =
        terminal_attributes^ [i].trans_forward_character := open_file_desc_pointer^.
              attributes.trans_forward_character.value;
      = ifc$trans_length_mode =
        terminal_attributes^ [i].trans_length_mode := open_file_desc_pointer^.
              attributes.trans_length_mode.value;
      = ifc$trans_timeout_mode =
        terminal_attributes^ [i].trans_timeout_mode := open_file_desc_pointer^.
              attributes.trans_timeout_mode.value;
      = ifc$trans_message_length =
        terminal_attributes^ [i].trans_message_length := open_file_desc_pointer^.
              attributes.trans_message_length.value;
      = ifc$trans_terminate_character =
        terminal_attributes^ [i].trans_terminate_character := open_file_desc_pointer^.
              attributes.trans_terminate_character.value;

      = ifc$trans_protocol_mode =
        terminal_attributes^ [i].trans_protocol_mode := open_file_desc_pointer^.
              attributes.trans_protocol_mode.value;
      ELSE
      CASEND;
    FOREND;

  PROCEND iip$fetch_terminal;

MODEND iim$fetch_terminal;
*DECK DECK=IIM$FETCH_TERM_CONN_ATTRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$fetch_term_conn_attributes;
?? TITLE := 'MODULE iim$fetch_term_conn_attributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc bap$validate_file_identifier
*copyc clp$get_ultimate_connection
*copyc clp$validate_name
*copyc clv$standard_files
*copyc ift$get_connection_attributes
*copyc IFE$ERROR_CODES
*copyc iik$keypoints
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIV$INTERACTIVE_TERMINATED
*copyc OST$STATUS
*copyc OSP$APPEND_STATUS_INTEGER
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$GET_JOB_MODE
*copyc rmp$get_device_class
*copyc jmp$system_job
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$fetch_term_conn_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$fetch_term_conn_attributes (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$st_open_file_description;
    VAR connection_attributes: ift$get_connection_attributes;
    VAR status: ost$status);

    VAR
      converted_name: amt$local_file_name,
      device_assigned: boolean,
      device_class: rmt$device_class,
      device_is_network: boolean,
      file_identifier: amt$file_identifier,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      i: integer,
      j: ift$terminal_attribute_keys,
      job_mode: jmt$job_mode,
      k: integer,
      local_status: ost$status,
      set_of_term_conn_attribute_keys: iit$set_of_term_conn_attr_keys,
      ultimate_name: amt$local_file_name,
      valid_name: boolean;

    status.normal := TRUE;
    file_identifier := file_id;

*copy bai$validate_file_identifier

{ Verify that the terminal file exists and that it is a network file.

    device_is_network := (file_instance^.device_class = rmc$network_device) OR
           (file_instance^.device_class = rmc$terminal_device);

    IF NOT device_is_network THEN
      clp$get_ultimate_connection (file_instance^.local_file_name, ultimate_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pmp$get_job_mode (job_mode, local_status);
      IF NOT local_status.normal THEN
        status := local_status;
        RETURN;
      ELSEIF (NOT (job_mode IN $iit$job_modes [jmc$interactive_connected,
             jmc$interactive_cmnd_disconnect, jmc$interactive_line_disconnect,
             jmc$interactive_sys_disconnect]) AND
             (((ultimate_name = clv$standard_files [clc$sf_job_input_file].path_handle_name) OR
             (ultimate_name = clv$standard_files [clc$sf_job_output_file].path_handle_name)) OR
             (ultimate_name = clv$standard_files [clc$sf_command_file].path_handle_name))) THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
             ife$current_job_not_interactive, 'IIP$FETCH_TERM_CONN_ATTRIBUTES',
             status);
        RETURN;
      ELSE
        osp$set_status_abnormal (ifc$interactive_facility_id,
             ife$file_name_not_terminal, converted_name, status);
        RETURN;
      IFEND;
    IFEND;

{ Validate the terminal attribute keys.

    set_of_term_conn_attribute_keys := - $iit$set_of_term_conn_attr_keys [];
    FOR i := LOWERBOUND (connection_attributes) TO UPPERBOUND
          (connection_attributes) DO
      IF NOT (connection_attributes [i].key IN set_of_term_conn_attribute_keys)
            THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$unknown_attribute_key, '', status);
        k := ORD (connection_attributes [i].key);
        osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
              FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$FETCH_TERMINAL', status);
        RETURN;
      IFEND;
    FOREND;


{ Get the connection attributes for the file id.

    FOR i := 1 TO UPPERBOUND (connection_attributes) DO
      CASE connection_attributes [i].key OF

      = ifc$attention_character_action =
        connection_attributes [i].attention_character_action := open_file_desc_pointer^.
              attributes.attention_character_action.value;

      = ifc$break_key_action =
        connection_attributes [i].break_key_action := open_file_desc_pointer^.attributes.
              break_key_action.value;

      = ifc$end_of_information =
        connection_attributes [i].end_of_information := open_file_desc_pointer^.attributes.
              end_of_information.value;

      = ifc$input_block_size =
        connection_attributes [i].input_block_size := open_file_desc_pointer^.attributes.
              input_block_size.value;

      = ifc$input_editing_mode =
        connection_attributes [i].input_editing_mode := open_file_desc_pointer^.attributes.
              input_editing_mode.value;

      = ifc$input_output_mode =
        connection_attributes [i].input_output_mode := open_file_desc_pointer^.attributes.
              input_output_mode.value;

      = ifc$input_timeout =
        connection_attributes [i].input_timeout := open_file_desc_pointer^.attributes.
              input_timeout.value;

      = ifc$input_timeout_length =
        connection_attributes [i].input_timeout_length := open_file_desc_pointer^.attributes.
              input_timeout_length.value;

      = ifc$input_timeout_purge =
        connection_attributes [i].input_timeout_purge := open_file_desc_pointer^.attributes.
              input_timeout_purge.value;

      = ifc$partial_char_forwarding =
        connection_attributes [i].partial_character_forwarding := open_file_desc_pointer^.attributes.
              partial_char_forwarding.value;

      = ifc$prompt_file =
        connection_attributes [i].prompt_file := open_file_desc_pointer^.attributes.
              prompt_file.value;

      = ifc$prompt_file_identifier =
        connection_attributes [i].prompt_file_identifier := open_file_desc_pointer^.attributes.
              prompt_file_identifier.value;

      = ifc$prompt_string =
        connection_attributes [i].prompt_string := open_file_desc_pointer^.attributes.
              prompt_string.value;

      = ifc$store_backspace_character =
        connection_attributes [i].store_backspace_character := open_file_desc_pointer^.attributes.
              store_backspace_character.value;

      = ifc$store_nuls_dels =
        connection_attributes [i].store_nuls_dels := open_file_desc_pointer^.attributes.
              store_nuls_dels.value;

      = ifc$trans_character_mode =
        connection_attributes [i].trans_character_mode := open_file_desc_pointer^.attributes.
              trans_character_mode.value;

      = ifc$trans_forward_character =
        connection_attributes [i].trans_forward_character := open_file_desc_pointer^.attributes.
              trans_forward_character.value;

      = ifc$trans_length_mode =
        connection_attributes [i].trans_length_mode := open_file_desc_pointer^.attributes.
              trans_length_mode.value;

      = ifc$trans_protocol_mode =

        connection_attributes [i].trans_protocol_mode := open_file_desc_pointer^.attributes.
              trans_protocol_mode.value;

      = ifc$trans_timeout_mode =
        connection_attributes [i].trans_timeout_mode := open_file_desc_pointer^.attributes.
              trans_timeout_mode.value;

      = ifc$trans_message_length =
        connection_attributes [i].trans_message_length := open_file_desc_pointer^.attributes.
              trans_message_length.value;

      = ifc$trans_terminate_character =
        connection_attributes [i].trans_terminate_character := open_file_desc_pointer^.attributes.
              trans_terminate_character.value;
      ELSE
      CASEND;
    FOREND;

  PROCEND iip$fetch_term_conn_attributes;

MODEND iim$fetch_term_conn_attributes;
*DECK DECK=IIM$FLUSH EXPAND=TRUE
*copyc osd$default_pragmats
MODULE iim$flush;
?? TITLE := 'MODULE iim$flush' ??

?? PUSH (LISTEXT := OFF) ??
*copyc ife$error_codes
*copyc iik$keypoints
*copyc iit$interactive_signal_type
*copyc iit$connection_description
*copyc iip$clear_lock
*copyc iiv$interactive_terminated
*copyc iip$put
*copyc iip$report_status_error
*copyc iip$set_lock
*copyc iip$send_output_message
*copyc iiv$int_task_open_file_count
*copyc iiv$connection_desc_ptr
*copyc ost$status
*copyc osp$set_status_abnormal
*copyc osp$test_sig_lock
*copyc osp$establish_condition_handler
*copyc osp$clear_job_signature_lock
*copyc pmp$continue_to_cause
*copyc pmp$log
*copyc iip$check_if_status
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$flush', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$flush (file_id: amt$file_identifier;
        open_file_desc_pointer: ^iit$open_file_description;
    VAR status: ost$status);

    VAR
      ls: ost$signature_lock_status,
      local_status: ost$status;

?? NEWTITLE := 'PROCEDURE handle_break', EJECT ??

    PROCEDURE handle_break (cond: pmt$condition;
          cd: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR ch_status: ost$status);

      VAR
        local_status: ost$status;

{ return to screen with abnormal status

      pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);

      IF cond.selector = ifc$interactive_condition THEN
        CASE cond.interactive_condition OF
        = ifc$pause_break =
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$pause_break_received, '', status);
        = ifc$terminate_break =
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$terminate_break_received, '', status);
        = ifc$terminal_connection_broken =
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$connection_break_disconnect, '', status);
        = ifc$job_reconnect =
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$terminal_reconnected_to_job, '', status);
        ELSE
          osp$set_status_abnormal (ifc$interactive_facility_id, 0,
            'unknown interactive condition encountered', status);
        CASEND;

        EXIT iip$flush;
      IFEND;

    PROCEND handle_break;
?? OLDTITLE ??
?? EJECT ??

    iip$check_if_status (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    osp$test_sig_lock (iiv$downline_queue_lock, ls);
    IF ls = osc$sls_locked_by_current_task THEN

{     some sort of unintended recursion has occured. ignore flush.

      status.normal := TRUE;
      RETURN;
    IFEND;

    osp$establish_condition_handler (^handle_break, FALSE);

    IF iiv$put_info.last_term_option <> amc$terminate THEN

    { Add the contents of the buffer used for put-partial data to the downline queue.

      iip$put (file_id, open_file_desc_pointer, amc$put_partial_req,
            NIL, 0, NIL, amc$terminate, status);
      IF NOT status.normal THEN
        pmp$log (' IIP$PUT returned bad status in IIP$FLUSH', status);
      IFEND;
    IFEND;

  /empty_the_downline_queue/
    WHILE TRUE DO
      iip$set_lock (iiv$downline_queue_lock, osc$wait, local_status);
      IF iiv$downline_queue_count = 0 THEN
        iip$clear_lock (iiv$downline_queue_lock, local_status);
        EXIT /empty_the_downline_queue/;
      ELSE
        iip$clear_lock (iiv$downline_queue_lock, status);
        iip$send_output_message (TRUE, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    WHILEND /empty_the_downline_queue/;

    status.normal := TRUE;

  PROCEND iip$flush;

MODEND iim$flush;
*DECK DECK=IIM$GET EXPAND=TRUE
?? RIGHT := 110 ??
MODULE iim$get;
?? TITLE := 'MODULE iim$get' ??

?? PUSH (LISTEXT := OFF) ??
*copyc amt$file_byte_address
*copyc bat$task_file_table
*copyc bav$last_tft_entry
*copyc bav$task_file_table
*copyc osv$170_os_type
*copyc iik$keypoints
*copyc amt$file_position
*copyc amt$skip_option
*copyc amd$operation_declarations
*copyc amt$max_record_length
*copyc amt$transfer_count
*copyc ame$terminal_validation_errors
*copyc amt$working_storage_length
*copyc amp$put_next
*copyc amp$set_file_instance_abnormal
*copyc clp$get_system_file_id
*copyc clc$standard_file_names
*copyc fsp$open_file
*copyc cle$unseen_mail_condition
*copyc osc$unseen_mail_condition
*copyc osc$job_recovery_condition_name
*copyc ife$error_codes
*copyc ifp$fap_control
*copyc ifp$immediate_attribute_flush
*copyc iit$connection_description
*copyc iip$build_term_char_values
*copyc iip$clear_lock
*copyc iip$flush
*copyc iiv$interactive_terminated
*copyc iip$put
*copyc iip$report_status_error
*copyc iip$set_lock
*copyc iiv$int_task_open_file_count
*copyc iiv$connection_desc_ptr
*copyc iip$update_open_desc_attributes
*copyc jmp$change_dispatching_prior_r1
*copyc jmp$select_reset_disp_pr_r2
*copyc jmt$dispatching_control_info
*copyc jmv$jcb
*copyc jmv$system_job_ssn
*copyc oss$job_paged_literal
*copyc ost$status
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$ready_task
*copyc pmp$log
*copyc osp$establish_condition_handler
*copyc osp$fetch_locked_variable
*copyc osp$initialize_signature_lock
*copyc osp$test_sig_lock
*copyc iip$build_super_msg_skeleton
*copyc mlp$receive_message
*copyc iip$report_unhandled_super_msg
*copyc iip$send_to_pass_on
*copyc pmp$long_term_wait
*copyc mld$memory_link_declarations
*copyc tmc$wait_times
*copyc pmp$exit
*copyc osp$disestablish_cond_handler
*copyc clp$get_time_string
*copyc pmp$get_job_names
*copyc tmv$null_global_task_id
?? POP ??

PROCEDURE [XREF] iip$disconnect_job (end_connection: boolean;
      start_new_job: boolean;
  VAR status: ost$status);

?? NEWTITLE := 'PROCEDURE iip$get', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$get (file_id: amt$file_identifier;
        open_file_desc_pointer: ^iit$open_file_description;
        operation: amt$fap_operation;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
        record_length: ^amt$max_record_length;
        transfer_count: ^amt$transfer_count;
        byte_address: ^amt$file_byte_address;
        file_position: ^amt$file_position;
        skip_option: amt$skip_option;
    VAR status: ost$status);

    PROCEDURE get;

    VAR
      file_identifier: amt$file_identifier,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      warning_message: [STATIC, READ, oss$job_paged_literal] string (35) :=
            ' TERMINAL TIMEOUT IN 30 SECONDS.' CAT $char(7) CAT $char(13) CAT $char(10),
      timeout_message: string (80),
      str: ost$string,
      user_supplied_name: jmt$user_supplied_name,
      system_supplied_name: jmt$system_supplied_name,
      saved_attributes: iit$connection_attributes,
      saved_build_msg: boolean,
      saved_effectors: boolean,
      current_transfer_count: amt$transfer_count,
      move_length: iit$block_size,
      reissue_read_after_skipping: boolean,
      null_dispatching_info: jmt$dispatching_control_info,
      first_time: boolean,
      working_storage_array_pointer: ^array [0 .. iic$max_record_length] of char,
      skip_upline_block,
      input_timeout_started, { indicates whether or not the input timeout countdown has begun }
      disconnect_timeout_started, { indicates whether or not the disconnect timeout countdown has begun }
      timeout_warning_posted,
      prompt_sent: boolean,
      put_byte_address: amt$file_byte_address,
      start, { the start time for timeout countdowns }
      short_wait_count: integer,
      prompt_block_number: integer,
      get_lock_set: boolean,
      mult,
      igtid,
      expected_wait,
      limit,
      j,
      i: integer,
      input_cell_ptr,
      output_cell_ptr: ^iit$nibble_string,
      output_supervisory_message: iit$output_supervisory_message,
      c170_upline_message_length: mlt$message_length,
      c170_upline_super_msg_pointer: ^iit$input_supervisory_message,
      arb: mlt$arbitrary_info,
      san: mlt$application_name,
      gtid: ost$global_task_id,
      xcb: ^ost$execution_control_block,
      lock_status: ost$signature_lock_status,
      open_file_dsc_pointer: ^iit$open_file_description,
      local_status: ost$status;

?? NEWTITLE := 'FUNCTION eoi', EJECT ??

      FUNCTION eoi: boolean;

        { If the data just received is equal to the end_of_information
        { attribute
        { for this file instance return with eoi set to TRUE; otherwise, FALSE.

        VAR
          local_stat: ost$status,
          end_of_info: boolean,
          wsa_pointer: ^string (ifc$max_end_of_information_size);

        IF open_file_desc_pointer^.attributes.end_of_information.
          value.value (1, open_file_desc_pointer^.attributes.
          end_of_information.value.size) = $char(13) THEN
          IF iiv$get_info.record_length = 0 THEN
            eoi := true;
          ELSE
            eoi := false;
          IFEND;
        ELSE
          end_of_info := (working_storage_area <> NIL) AND
            (open_file_desc_pointer^.attributes.end_of_information.value.
            size <> 0) AND (open_file_desc_pointer^.attributes.
            input_editing_mode.value = ifc$normal_edit) AND
            (iiv$get_info.record_length =
            open_file_desc_pointer^.attributes.end_of_information.value.
            size);

          IF end_of_info THEN
            wsa_pointer := working_storage_area;
            end_of_info := (wsa_pointer^ (1, iiv$get_info.
              record_length) = open_file_desc_pointer^.attributes.
              end_of_information.value.value (1, open_file_desc_pointer^.
              attributes.end_of_information.value.size));
          IFEND;
          eoi := end_of_info;
        IFEND;
      FUNCEND eoi;
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE send_prompt', EJECT ??

    PROCEDURE send_prompt (VAR status: ost$status);

      VAR
        file_identifier: amt$file_identifier,
        file_id_is_valid: boolean,
        file_instance: ^bat$task_file_entry,
        prompt_file_no_format_effectors: boolean,
        prompt_string_start_index: 1 .. ifc$max_prompt_string_size,
        iiv$begin_absentee : [xdcl] boolean,
        format_effector_null_prompt: char,
        put_length: amt$working_storage_length,
        open_file_dsc_pointer: ^iit$open_file_description,
        put_byte_address: amt$file_byte_address;

      status.normal := TRUE;

{ Ensure that the prompt file is open.

   IF open_file_desc_pointer^.attributes.prompt_file_identifier.value.ordinal = 0 THEN
     fsp$open_file (open_file_desc_pointer^.attributes.prompt_file.value, amc$record, NIL, NIL, NIL, NIL,
        NIL, open_file_desc_pointer^.attributes.prompt_file_identifier.value, status);
        open_file_desc_pointer^.attributes.prompt_file_identifier.source := ifc$os_default;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      put_length := 0;
      prompt_string_start_index := 1;
      iiv$put_info.build_msg_block := TRUE;

      iiv$begin_absentee := TRUE;
      IF open_file_desc_pointer^.attributes.input_timeout.value AND
        (open_file_desc_pointer^.attributes.input_timeout_length.value = 0) THEN
        iiv$begin_absentee := FALSE;
      IFEND;

      IF (open_file_desc_pointer^.attributes.input_editing_mode.value = ifc$normal_edit) AND
            (open_file_desc_pointer^.attributes.prompt_string.value.size <> 0) THEN

      { Determine whether or not the prompt file has format effectors.

        file_identifier := open_file_desc_pointer^.attributes.
          prompt_file_identifier.value;
*copy bai$validate_file_identifier
*copy iii$fetch_open_file_desc_ptr
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        prompt_file_no_format_effectors := NOT open_file_dsc_pointer^.
          format_effectors;

        put_length := open_file_desc_pointer^.attributes.prompt_string.value.size;

{ Discard the format effector of the prompt string if at mid record.

        IF (open_file_desc_pointer^.attributes.prompt_string.value.size <> 0) AND
              (NOT prompt_file_no_format_effectors) AND (iiv$put_info.
              last_term_option <> amc$terminate) THEN
          prompt_string_start_index := 2;
          put_length := open_file_desc_pointer^.attributes.prompt_string.value.size -
                1;
        IFEND;

{ Output the prompt string.

        open_file_dsc_pointer^.attributes.trans_character_mode.value :=
          ifc$no_trans_char;

        IF (put_length = 0) AND (NOT prompt_file_no_format_effectors) AND
              (iiv$put_info.last_term_option = amc$terminate) THEN
          format_effector_null_prompt := ifc$pre_print_no_positioning;
          put_length := 1;
          iip$put (open_file_desc_pointer^.attributes.prompt_file_identifier.value,
                open_file_dsc_pointer,
                amc$put_partial_req, ^format_effector_null_prompt, put_length,
                ^put_byte_address, amc$terminate, status);
        ELSE
          iip$put (open_file_desc_pointer^.attributes.prompt_file_identifier.value,
                open_file_dsc_pointer,
                amc$put_partial_req, ^open_file_desc_pointer^.attributes.prompt_string.value.
                value (prompt_string_start_index, 1), put_length,
                ^ put_byte_address, amc$terminate, status);
        IFEND;

        iiv$put_info.build_msg_block := FALSE;

        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

{ Output an iic$last_block for the get file id.
      iiv$put_info.term_char_null := TRUE;

      iip$put (file_id, open_file_desc_pointer, amc$put_partial_req,
            ^open_file_desc_pointer^.attributes.prompt_string.value.value
            (prompt_string_start_index, 1), 0, ^put_byte_address,
            amc$terminate, status);

      iiv$put_info.term_char_null := FALSE;
      iiv$put_info.build_msg_block := FALSE;

      IF NOT status.normal THEN
        RETURN;
      IFEND;

      iip$flush (file_id, open_file_desc_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND send_prompt;

?? TITLE := 'PROCEDURE handle_break', EJECT ??

    PROCEDURE handle_break (cond: pmt$condition;
          cd: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR ch_status: ost$status);

      VAR
        break_abn: integer,
        local_status: ost$status;

{ return to screen with abnormal status

      IF cond.selector = pmc$user_defined_condition THEN
        IF cond.user_condition_name = osc$job_recovery_condition_name THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
          RETURN;
        ELSEIF cond.user_condition_name = osc$unseen_mail_condition THEN
          osp$set_status_condition (cle$unseen_mail_condition, status);
          pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
          EXIT iip$get;
        IFEND;
      IFEND;

      IF (cond.selector = ifc$interactive_condition) OR
          (cond.selector = pmc$block_exit_processing) THEN
        break_abn := iiv$break_abn;
        IF get_lock_set THEN
          iiv$get_info.file_position := amc$eor;
          iip$clear_lock (iiv$get_lock, local_status);
          get_lock_set := FALSE;
        IFEND;

        IF (cond.selector = ifc$interactive_condition) THEN
          CASE cond.interactive_condition OF
          = ifc$pause_break =
            osp$set_status_condition (ife$pause_break_received, status);
          = ifc$terminate_break =
            osp$set_status_condition (ife$terminate_break_received, status);
          = ifc$terminal_connection_broken =
            osp$set_status_condition (ife$connection_break_disconnect, status);
          = ifc$job_reconnect =
            osp$set_status_condition (ife$terminal_reconnected_to_job, status);
          ELSE
            osp$set_status_abnormal (ifc$interactive_facility_id, 0,
              'unknown interactive condition encountered', status);
          CASEND;
          pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
          EXIT iip$get;
        ELSE
          {Do nothing for block exit
          RETURN;
        IFEND;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);

    PROCEND handle_break;
?? TITLE := 'PROCEDURE handle_exit', EJECT ??

{ This code has been disabled to prevent the overhead associated with
{ block exit handling.
{
{   PROCEDURE handle_exit (cond: pmt$condition;
{         cd: ^pmt$condition_information;
{         sa: ^ost$stack_frame_save_area;
{     VAR ch_status: ost$status);
{
{     VAR
{       local_status: ost$status;
{
{     IF get_lock_set THEN
{       iiv$get_info.file_position := amc$eor;
{       iip$clear_lock (iiv$get_lock, local_status);
{       get_lock_set := FALSE;
{     IFEND;
{     pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
{     ch_status.normal := TRUE;
{
{   PROCEND handle_exit;

?? OLDTITLE, EJECT ??

    #KEYPOINT (osk$entry, 0, iik$get);

{ any gets while iiv$interactive_terminated is true cause exit.
    IF iiv$interactive_terminated THEN
      osp$set_status_condition (ife$abort_get, status);
      #KEYPOINT (osk$exit, 0, iik$get);
      pmp$exit (status);
    IFEND;
    prompt_sent := FALSE;
    get_lock_set := FALSE;
    skip_upline_block := FALSE;
    reissue_read_after_skipping := FALSE;

{ The following procedure call causes the jobs priority to be reset. It is
{ support code for DYNAMIC DISPATCHING. This procedure calls a ring 1 procedure
{ which stores the global_taskid of this task (the interactive task) in the
{ IJL entry of the job. When the task is next readied, the priority of the job
{ will be reset, and the taskid in the IJL entry will be set to null. If
{ we exit this procedure with the taskid still in the IJL entry, the priority
{ of the job will be immediately reset. The situation will occur if the user
{ is typing ahead.

      jmp$select_reset_disp_pr_r2;

{   Protect the get lock with a handler for interactive conditions to
{   insure that they are recognized and the get lock gets cleared.

    osp$establish_condition_handler (^handle_break, TRUE);
    osp$test_sig_lock (iiv$get_lock, lock_status);

    IF lock_status = osc$sls_locked_by_another_task THEN

{     Determine the task which set the lock and clear its lock if the
{     the task has terminated.

      osp$fetch_locked_variable (iiv$get_lock.lock_id, igtid);

    /assemble_gtid/
      BEGIN
        mult := 1;
        FOR i := 1 TO #SIZE (gtid.seqno) DO
          mult := mult * 256;
        FOREND;

        IF (igtid DIV mult) > UPPERVALUE (gtid.index) THEN
          EXIT /assemble_gtid/;
        IFEND;
        gtid.index := igtid DIV mult;
        IF (igtid MOD mult) > UPPERVALUE (gtid.seqno) THEN
          EXIT /assemble_gtid/;
        IFEND;
        gtid.seqno := igtid MOD mult;
        pmp$ready_task (gtid, status);
        IF  NOT status.normal THEN
          osp$initialize_signature_lock (iiv$get_lock, status);
        IFEND;
      END /assemble_gtid/;

    ELSEIF lock_status = osc$sls_locked_by_current_task THEN

{     Some sort of unintended recursion has occured due to break, escape,
{     task/job termination, etc.  RETURN with normal status.

      status.normal := TRUE;
      #KEYPOINT (osk$exit, 0, iik$get);
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

    iip$set_lock (iiv$get_lock, osc$wait, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, iik$get);
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    get_lock_set := TRUE;
    working_storage_array_pointer := NIL;

  /do_it_all_again/
    WHILE TRUE DO

      status.normal := TRUE;

{     Set up for data transfer.

      IF skip_option = amc$skip_to_eor THEN
        IF iiv$get_info.file_position = amc$mid_record THEN
          iiv$get_info.position_in_block := 1;
          IF iiv$get_info.block_type = iic$last_block THEN
            skip_upline_block := FALSE;
            iiv$get_info.file_position := amc$eor;
            reissue_read_after_skipping := TRUE;
          ELSE
            skip_upline_block := TRUE;
          IFEND;
        IFEND;
      IFEND;

{     Update the terminal attributes of the open file description if they might
{     have changed.

      IF open_file_desc_pointer^.attributes_cycle <> open_file_desc_pointer^.
            connection_desc_pointer^.attributes_cycle THEN
        iip$update_open_desc_attributes (file_id, open_file_desc_pointer,
              operation, status);
        IF NOT status.normal THEN
          iip$clear_lock (iiv$get_lock, local_status);
          #KEYPOINT (osk$exit, 0, iik$get);
          osp$disestablish_cond_handler;
          RETURN;
        IFEND;
      IFEND;

      IF (skip_option = amc$skip_to_eor) OR (iiv$get_info.file_position <>
            amc$mid_record) THEN
        IF NOT prompt_sent THEN
          send_prompt (status);
          prompt_sent := TRUE;
          prompt_block_number := iiv$put_info.block_number;
          IF NOT status.normal THEN
            iip$clear_lock (iiv$get_lock, local_status);
            #KEYPOINT (osk$exit, 0, iik$get);
            osp$disestablish_cond_handler;
            RETURN;
          IFEND;
        IFEND;
      IFEND;

    { Detect context switching and, if needed, blank the screen.

      IF (iiv$previous_mode = iic$screen) AND
            ((open_file_desc_pointer^.terminal_mode = iic$line) OR (file_id.ordinal <>
            iiv$previous_file_id.ordinal)) THEN
        iiv$previous_mode := iic$line;
        IF NOT iiv$previous_blank_flag THEN
          iiv$previous_blank_flag := TRUE;
          saved_attributes := open_file_desc_pointer^.attributes;
          saved_build_msg := iiv$put_info.build_msg_block;
          saved_effectors := open_file_desc_pointer^.format_effectors;
          open_file_desc_pointer^.attributes := iiv$previous_connection_attr;
          open_file_desc_pointer^.format_effectors := FALSE;
          iiv$put_info.build_msg_block := FALSE;
          iip$build_term_char_values (open_file_desc_pointer);
          iip$put (file_id, open_file_desc_pointer, amc$put_next_req,
            #LOC (iiv$screen_clear_string.value), iiv$screen_clear_string.size,
            ^put_byte_address, amc$terminate, status);
          open_file_desc_pointer^.attributes := saved_attributes;
          open_file_desc_pointer^.format_effectors := saved_effectors;
          iiv$put_info.build_msg_block := saved_build_msg;
          iip$build_term_char_values (open_file_desc_pointer);
        IFEND;
      IFEND;

      iiv$previous_blank_flag := FALSE;
      IF open_file_desc_pointer^.terminal_mode = iic$line THEN
        iiv$previous_mode := iic$line;
      IFEND;
      iiv$previous_operation := operation;
      iiv$previous_file_id := file_id;

      IF iiv$get_info.file_position <> amc$mid_record THEN
        iiv$get_info.record_length := 0;
        iiv$get_info.transfer_count := 0;
        iiv$get_info.position_in_block := 1;
      IFEND;


      current_transfer_count := 0;
      first_time := true;
    /transfer_data_to_user/
      WHILE TRUE DO

      input_timeout_started := FALSE;
      disconnect_timeout_started := FALSE;
      timeout_warning_posted := FALSE;

      /read_upline_data/
        WHILE TRUE DO

          IF iiv$get_info.position_in_block = 1 THEN

            iiv$get_info.queued_data_length := 0;
            expected_wait := iic$user_time_delay;

{           Build read request.
            IF NOT first_time OR (iiv$get_info.block_type <> iic$last_block)
                  OR reissue_read_after_skipping THEN
              iip$build_super_msg_skeleton (^output_supervisory_message,
                    iic$sm_read_request, iic$l_read_request);
              output_supervisory_message.read_request.connection_number :=
                    iiv$job_connection;
              output_supervisory_message.read_request.begin_absentee := TRUE;
              output_supervisory_message.read_request.notify_if_absentee_started
                    := TRUE;

              IF open_file_desc_pointer^.attributes.input_timeout.value AND
                    (open_file_desc_pointer^.attributes.input_timeout_length.value = 0) THEN
                output_supervisory_message.read_request.begin_absentee := FALSE;
              IFEND;

  {           Send read request to Pass-On.

              iip$send_to_pass_on (iiv$int_application_name, #LOC
                    (output_supervisory_message), (iic$l_read_request + 1) * 8,
                    iic$output_supervisory_message, status);

              IF NOT status.normal THEN
                iip$clear_lock (iiv$get_lock, local_status);
                #KEYPOINT (osk$exit, 0, iik$get);
                osp$disestablish_cond_handler;
                RETURN;
              IFEND;
            IFEND;
            first_time := false;
            reissue_read_after_skipping := FALSE;
            short_wait_count := 0;

          /wait_receive/
            WHILE TRUE DO

{             Receive upline block from Pass-On.

              mlp$receive_message (iiv$int_application_name, arb, NIL, #LOC
                    (iiv$upline_data_buffer_ptr^), c170_upline_message_length,
                    #SIZE (iiv$upline_data_buffer_ptr^), 0, san, status);
              IF NOT status.normal THEN
                CASE status.condition OF
                = mlc$busy_interlock, mlc$receive_list_index_invalid =
                  pmp$long_term_wait (expected_wait, expected_wait);
                  IF iiv$abort_get THEN
                    iiv$abort_get := FALSE;
                    iip$clear_lock (iiv$get_lock, local_status);
                    #KEYPOINT (osk$exit, 0, iik$get);
                    osp$set_status_condition (ife$abort_get, status);
                    osp$disestablish_cond_handler;
                    RETURN;
                  IFEND;

                  IF input_timeout_started THEN
                    mlp$receive_message (iiv$int_application_name, arb, NIL, #LOC
                          (iiv$upline_data_buffer_ptr^), c170_upline_message_length,
                          #SIZE (iiv$upline_data_buffer_ptr^), 0, san, status);
                    IF NOT status.normal THEN

                      expected_wait := open_file_desc_pointer^.
                      attributes.input_timeout_length.value -
                            ((#free_running_clock (0) - start) DIV 1000);
                      IF expected_wait > 0 THEN
                        CYCLE /wait_receive/;
                      IFEND;

                      { Build and send a LST/OFF/R to PASSON.

                      iip$build_super_msg_skeleton (^output_supervisory_message,
                            iic$sm_list_off, iic$l_list_off);
                      output_supervisory_message.list_off.connection_number := iiv$job_connection;
                      iip$send_to_pass_on (iiv$int_application_name, #LOC (output_supervisory_message),
                            (iic$l_list_off + 1) * 8, iic$output_supervisory_message, status);
                      IF NOT status.normal THEN
                        iip$clear_lock (iiv$get_lock, local_status);
                        #KEYPOINT (osk$exit, 0, iik$get);
                        osp$disestablish_cond_handler;
                        RETURN;
                      IFEND;

                      { If input_timeout_length <> 0 and input_timeout_purge then build and
                      { send a FC/BRK/R to PASSON.

                      IF open_file_desc_pointer^.attributes.input_timeout_purge.value AND
                            (open_file_desc_pointer^.attributes.input_timeout_length.value <> 0) THEN
                        iip$build_super_msg_skeleton (^output_supervisory_message,
                              iic$sm_break, iic$l_break);
                        output_supervisory_message.break.connection_number := iiv$job_connection;
                        iip$send_to_pass_on (iiv$int_application_name,
                              #LOC (output_supervisory_message), (iic$l_break + 1) * 8,
                              iic$output_supervisory_message, status);
                        IF NOT status.normal THEN
                          iip$clear_lock (iiv$get_lock, local_status);
                          #KEYPOINT (osk$exit, 0, iik$get);
                          osp$disestablish_cond_handler;
                          RETURN;
                        IFEND;
                      IFEND;

{ Decrement the time left before the disconnect timeout limit expires by the Input_Timeout_Length.

                      iiv$terminal_timeout_limit_left := iiv$terminal_timeout_limit_left -
                            open_file_desc_pointer^.attributes.input_timeout_length.value;

                      osp$set_status_condition (ife$input_timeout_exceeded, status);
                      iip$clear_lock (iiv$get_lock, local_status);
                      #KEYPOINT (osk$exit, 0, iik$get);
                      osp$disestablish_cond_handler;
                      RETURN;

                    IFEND;
                  ELSEIF disconnect_timeout_started AND (iiv$terminal_timeout_limit <> tmc$infinite_wait) THEN
                    mlp$receive_message (iiv$int_application_name, arb, NIL, #LOC
                          (iiv$upline_data_buffer_ptr^), c170_upline_message_length,
                          #SIZE (iiv$upline_data_buffer_ptr^), 0, san, status);
                    IF NOT status.normal THEN

{ Recalculate the disconnect wait time.  Wait for input again if the disconnect wait time is not expired.

                      expected_wait := iiv$terminal_timeout_limit_left -
                            ((#free_running_clock (0) - start) DIV 1000);
                      IF expected_wait > 0 THEN
                        CYCLE /wait_receive/;
                      IFEND;

                      IF timeout_warning_posted THEN

{ Display time and job name in the message accompanying the job disconnection and the job log.

                        clp$get_time_string (str, status);
                        timeout_message (1, 1) := ' ';
                        timeout_message (2, str.size) := str.value (1, str.size);
                        timeout_message (str.size + 2, 24) := ' TERMINAL TIMEOUT.  JOB ';
                        pmp$get_job_names (user_supplied_name, system_supplied_name, status);
                        timeout_message (str.size + 26, 19) := system_supplied_name;
                        timeout_message (str.size + 46, 12) :=
                              ' DETACHED.' CAT $char(13) CAT $char (10);
                        pmp$log (timeout_message (str.size + 3, 54), status);
                        iip$put (file_identifier, open_file_dsc_pointer, amc$put_next_req,
                              #LOC (timeout_message), str.size + 57, byte_address, amc$terminate, status);
                        iip$flush (file_identifier, open_file_dsc_pointer, status);
                        iip$disconnect_job (iic$end_connection, iic$dont_start_new_job, status);
                        IF NOT status.normal THEN
                          #KEYPOINT (osk$exit, 0, iik$get);
                          RETURN;
                        IFEND;
                      ELSE { timeout_warning_posted }

  { Output the timeout warning message to the terminal and job log and wait 2 minutes more for input data.

                        clp$get_system_file_id (clc$job_output, file_identifier, status);
                        IF NOT status.normal THEN
                          #KEYPOINT (osk$exit, 0, iik$get);
                          RETURN;
                        IFEND;
*copy bai$validate_file_identifier
*copy iii$fetch_open_file_desc_ptr
                        IF NOT status.normal THEN
                          #KEYPOINT (osk$exit, 0, iik$get);
                          RETURN;
                        IFEND;
                        pmp$log (warning_message (1, 32), status);
                        iip$put (file_identifier, open_file_dsc_pointer, amc$put_next_req,
                              ^warning_message, 35, byte_address, amc$terminate, status);
                        IF NOT status.normal THEN
                          #KEYPOINT (osk$exit, 0, iik$get);
                          RETURN;
                        IFEND;
                        iip$flush (file_identifier, open_file_dsc_pointer, status);
                        IF NOT status.normal THEN
                          #KEYPOINT (osk$exit, 0, iik$get);
                          RETURN;
                        IFEND;
                        timeout_warning_posted := TRUE;
                        expected_wait := 30000;  { thirty seconds in terms of milliseconds }
                        iiv$terminal_timeout_limit_left := 30000;
                        start := #free_running_clock (0);
                        CYCLE /wait_receive/;
                      IFEND; { timeout_warning_posted }
                    ELSE { status.normal from mlp$receive_message after disconnect-timeout started.
                      IF iiv$upline_data_buffer_ptr^.header.block_type <> iic$supervisory_block THEN
                        iiv$terminal_timeout_limit_left := iiv$terminal_timeout_limit;
                      IFEND;
                    IFEND; { status.normal from mlp$receive_message after disconnect-timeout started.
                  ELSE { NOT input_timeout_started--NOT disconnect_timeout_started }
                    short_wait_count := short_wait_count + 1;
                    IF short_wait_count > 10 THEN
{ Force long waits for either the disconnect timeout limit or infinite.
                      IF iiv$terminal_timeout_limit <> tmc$infinite_wait THEN
                        expected_wait := iiv$terminal_timeout_limit_left - (10 * iic$user_time_delay);
                        IF expected_wait < 0 THEN
                          expected_wait := 0;
                        IFEND;
                        disconnect_timeout_started := TRUE;
                        start := #free_running_clock (0);
                      ELSE
                        expected_wait := tmc$infinite_wait;
                      IFEND;
                    IFEND; { short_wait_count > 10 }
                    CYCLE /wait_receive/;
                  IFEND; { NOT input_timeout_started--NOT disconnect_timeout_started }
                ELSE
                  iip$clear_lock (iiv$get_lock, local_status);
                  #KEYPOINT (osk$exit, 0, iik$get);
                  osp$disestablish_cond_handler;
                  RETURN;
                CASEND;
              ELSE { status.normal }
                IF iiv$upline_data_buffer_ptr^.header.block_type <> iic$supervisory_block THEN
                  iiv$terminal_timeout_limit_left := iiv$terminal_timeout_limit;
                IFEND;
              IFEND; { status.normal }

              IF iiv$upline_data_buffer_ptr^.header.block_type =
                    iic$supervisory_block THEN

                IF input_timeout_started THEN
                  expected_wait := open_file_desc_pointer^.attributes.input_timeout_length.value -
                        (#free_running_clock (0) - start);
                ELSEIF disconnect_timeout_started AND (iiv$terminal_timeout_limit <> tmc$infinite_wait) THEN
                  expected_wait := iiv$terminal_timeout_limit_left - ((#free_running_clock (0) - start)
                        DIV 1000);
                IFEND;
                IF expected_wait < 0 THEN
                  expected_wait := 0;
                IFEND;

                c170_upline_super_msg_pointer := #LOC (iiv$upline_data_buffer_ptr^);
                CASE c170_upline_super_msg_pointer^.message_type OF
                = iic$sm_read_rejected =
                  pmp$long_term_wait (iic$user_time_delay, iic$user_time_delay);
                  IF iiv$abort_get THEN
                    iiv$abort_get := FALSE;
                    iip$clear_lock (iiv$get_lock, local_status);
                    #KEYPOINT (osk$exit, 0, iik$get);
                    osp$set_status_condition (ife$abort_get, status);
                    osp$disestablish_cond_handler;
                    RETURN;
                  IFEND;
                  CYCLE /read_upline_data/;
                = iic$sm_define_term_char_n, iic$sm_cdcnet_define_term_chr_n,
                  iic$sm_cdcnet_unsolct_term_char =
{                 ignore these
                  CYCLE /read_upline_data/;
                = iic$sm_absentee_begun =

                  IF iiv$terminal_timeout_limit <> tmc$infinite_wait THEN
                    expected_wait := iiv$terminal_timeout_limit_left;
                    disconnect_timeout_started := TRUE;
                  ELSE
                    expected_wait := tmc$infinite_wait;
                  IFEND;

                  IF open_file_desc_pointer^.attributes.input_timeout.value THEN
                    IF expected_wait > open_file_desc_pointer^.attributes.input_timeout_length.value THEN
                      expected_wait := open_file_desc_pointer^.attributes.input_timeout_length.value;
                      input_timeout_started := TRUE;
                      disconnect_timeout_started := FALSE;
                    IFEND;
                  IFEND;
                  start := #free_running_clock (0);
                  CYCLE /wait_receive/;
                ELSE
                  iip$report_unhandled_super_msg (c170_upline_super_msg_pointer^);
                  CYCLE /read_upline_data/;
                CASEND;
              IFEND;

              EXIT /wait_receive/;
            WHILEND /wait_receive/;

            IF iiv$upline_data_buffer_ptr^.header.block_type = iic$null_block THEN
              IF open_file_desc_pointer^.attributes.input_timeout.value AND
                    (open_file_desc_pointer^.attributes.input_timeout_length.value = 0) THEN
                osp$set_status_condition (ife$no_data_available, status);
                iip$clear_lock (iiv$get_lock, local_status);
                #KEYPOINT (osk$exit, 0, iik$get);
                osp$disestablish_cond_handler;
                RETURN;
              IFEND;
              CYCLE /read_upline_data/;
            IFEND;

            iiv$get_info.block_type := iiv$upline_data_buffer_ptr^.header.
                  block_type;
            iiv$get_info.record_length := iiv$get_info.record_length +
                  iiv$upline_data_buffer_ptr^.header.text_length;
            iiv$get_info.queued_data_length := iiv$get_info.queued_data_length
                  + iiv$upline_data_buffer_ptr^.header.text_length;
            iiv$get_info.cancel_input := iiv$upline_data_buffer_ptr^.header.
                  cancel;
{           Check to see if transparent mode has been dropped with this input block.

            IF (open_file_desc_pointer^.connection_desc_pointer^.
                  active_term_char_values [iic$key_trans_input_mode] <> 0) AND
                  (NOT iiv$upline_data_buffer_ptr^.header.transparent) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id, ife$xpt_mode_drop_unexpected,
                    '', status);
              open_file_desc_pointer^.connection_desc_pointer^.
                    active_term_char_values [iic$key_trans_input_mode] := 0;
              open_file_desc_pointer^.connection_desc_pointer^.
                    active_term_char_values [iic$key_trans_input_type] := iic$single_message;
              open_file_desc_pointer^.connection_desc_pointer^.
                    term_char_values [iic$key_trans_input_mode] := 0;
              open_file_desc_pointer^.connection_desc_pointer^.
                    term_char_values [iic$key_trans_input_type] := iic$single_message;
            IFEND;

          IFEND; { iiv$get_info.position_in_block = 1 }

          IF (iiv$upline_data_buffer_ptr^.header.text_length <> 0) AND
                (working_storage_length <> 0) THEN
            move_length := (iiv$upline_data_buffer_ptr^.header.text_length + 1)
                  - iiv$get_info.position_in_block;
            IF move_length + current_transfer_count > working_storage_length
                  THEN
              move_length := working_storage_length - current_transfer_count;
            IFEND;

            { Copy upline data into the user's working storage area.

            input_cell_ptr := #LOC (iiv$upline_data_buffer_ptr^.data);
            output_cell_ptr := working_storage_area;

            j := current_transfer_count * 2;
            IF osv$170_os_type = osc$ot7_dual_state_nos_be THEN
              i := (16 * iiv$get_info.position_in_block - 11) DIV 5;
            ELSE
              i := (32 * iiv$get_info.position_in_block - 16) DIV 15;
            IFEND;
            limit := move_length * 2;

          /move_half_bytes/
            WHILE limit <> 0 DO
              IF i MOD 16 = 0 THEN
                i := i + 1;
              IFEND;
              IF osv$170_os_type = osc$ot7_dual_state_nos_be THEN
              output_cell_ptr^ [j] := input_cell_ptr^ [i + 1];
              output_cell_ptr^ [j + 1] := input_cell_ptr^ [i + 2];
              j := j + 2;
              i := i + 3;
              limit := limit - 2;
              ELSE
              output_cell_ptr^ [j] := input_cell_ptr^ [i];
              j := j + 1;
              i := i + 1;
              limit := limit - 1;
              IFEND;
            WHILEND /move_half_bytes/;

            iiv$get_info.position_in_block := iiv$get_info.position_in_block +
                  move_length;

            current_transfer_count := current_transfer_count + move_length;
            iiv$get_info.transfer_count := iiv$get_info.transfer_count +
                  move_length;
          IFEND; {(working_storage_length <> 0) AND (upline text length <> 0)

          IF (iiv$get_info.position_in_block > iiv$get_info.queued_data_length) THEN
            iiv$get_info.position_in_block := 1;
          IFEND;

          IF (iiv$upline_data_buffer_ptr^.header.block_type = iic$last_block)
                OR (iiv$upline_data_buffer_ptr^.header.cancel) OR
                (iiv$get_info.queued_data_length >= iic$max_cancellable_input)
                OR (current_transfer_count = working_storage_length)
                THEN
            EXIT /read_upline_data/;
          IFEND;

        WHILEND /read_upline_data/;

        IF skip_upline_block THEN
          CYCLE /do_it_all_again/;
        IFEND;

        IF (iiv$get_info.cancel_input) THEN
          iiv$get_info.file_position := amc$eor;
          iiv$get_info.position_in_block := 1;
          iiv$get_info.record_length := 0;
          iiv$get_info.transfer_count := 0;
          current_transfer_count := 0;
          CYCLE /transfer_data_to_user/;
        IFEND;

        working_storage_array_pointer := working_storage_area;

        IF current_transfer_count = working_storage_length THEN
          EXIT /transfer_data_to_user/;
        IFEND;

        iiv$get_info.position_in_block := 1;

        IF iiv$get_info.block_type = iic$last_block THEN
          EXIT /transfer_data_to_user/;
        IFEND;

      WHILEND /transfer_data_to_user/;

{     Set proper post operation file position.

      IF (((iiv$get_info.position_in_block = 1) AND (iiv$get_info.block_type =
            iic$last_block)) OR (iiv$get_info.position_in_block - 1 =
            iiv$get_info.record_length)) THEN
        iiv$get_info.file_position := amc$eor;
      ELSE
        iiv$get_info.file_position := amc$mid_record;
      IFEND;

{     Detect input cancellation.

      IF (iiv$get_info.file_position = amc$eor) AND (iiv$get_info.cancel_input)
            AND (iiv$get_info.record_length > iic$max_cancellable_input) THEN
        amp$set_file_instance_abnormal (file_id, ame$max_cancellable_input,
              operation, '', status);
      IFEND;

      EXIT /do_it_all_again/;

    WHILEND /do_it_all_again/;


{   Return parameters to the caller.

    IF record_length <> NIL THEN
      record_length^ := iiv$get_info.record_length;
    IFEND;

    IF transfer_count <> NIL THEN
      transfer_count^ := current_transfer_count;
    IFEND;

    IF file_position <> NIL THEN
      file_position^ := iiv$get_info.file_position;
    IFEND;

    IF byte_address <> NIL THEN
      byte_address^ := 0;
    IFEND;

{   Check for end-of-information.

    IF eoi() THEN
      IF record_length <> NIL THEN
        record_length^ := 0;
      IFEND;
      IF transfer_count <> NIL THEN
        transfer_count^ := 0;
      IFEND;
      IF file_position <> NIL THEN
        file_position^ := amc$eoi;
      IFEND;
      IF byte_address <> NIL THEN
        byte_address^ := 0;
      IFEND;

      iiv$get_info.file_position := amc$eoi;

    IFEND; { Check for end-of-information. }

{   Save access information.

    open_file_desc_pointer^.last_get_put_operation := operation;
    open_file_desc_pointer^.last_access_operation := operation;
    open_file_desc_pointer^.previous_record_length := iiv$get_info.
          record_length;

{ Raise priority if it has not already been done.

    IF jmv$jcb.ijle_p^.interactive_task_gtid <> tmv$null_global_task_id THEN
      jmp$change_dispatching_prior_r1 (tmc$cpo_interactive_command, jmv$jcb.ijl_ordinal, jmv$jcb.system_name,
         null_dispatching_info, local_status);
    IFEND;

    iip$clear_lock (iiv$get_lock, local_status);

    #KEYPOINT (osk$exit, 0, iik$get);

    osp$disestablish_cond_handler;
  PROCEND get;


  {Call the inner procedure

    get;

  PROCEND iip$get;

MODEND iim$get;
*DECK DECK=IIM$GET_PAGE_LENGTH_WIDTH EXPAND=TRUE
*copyc osd$default_pragmats
MODULE iim$get_page_length_width;

{ PURPOSE:  Retrieve the page length and width attribute values for a
{           connection.
{
{  DESIGN:  The retrieved PW and PL attribute values are returned in
{           a formal parameter.  These values are taken directly from
{           the attributes pointed at by IIV$CONNECTION_DESC_PTR.
{
{           If this interface is executed on a standalone connection,
{           i.e., iiv$network_identifier is iic$cdcnet_network, then
{           the appropriate connection table pointer is determined
{           from the terminal file name.
{
?? TITLE := 'MODULE iim$get_page_length_width' ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$construct_path_handle_name
*copyc iip$clear_lock
*copyc iip$search_connection_desc
*copyc iip$set_lock
*copyc iip$xlate_local_file_to_session
*copyc iiv$connection_desc_ptr
*copyc iiv$interactive_terminated
?? POP ??
?? NEWTITLE := 'PROCEDURE iip$get_page_length_width' ??

  PROCEDURE [XDCL, #GATE] iip$get_page_length_width (terminal_path_handle: fmt$path_handle;
    VAR page_length_width: array [1 .. 2] of ift$terminal_attribute;
    VAR status: ost$status);

    VAR
      connection_desc_ptr: ^iit$connection_description,
      terminal_file_name: amt$local_file_name,
      session_file: amt$local_file_name;

  /get_pl_pw/
    BEGIN

      page_length_width [1].key := ifc$page_length;
      page_length_width [2].key := ifc$page_width;

      CASE iiv$network_identifier OF
      = iic$cdcnet_network =

        clp$construct_path_handle_name (terminal_path_handle, terminal_file_name);
        iip$xlate_local_file_to_session (terminal_file_name, session_file, status);
        IF NOT status.normal THEN
          EXIT /get_pl_pw/;
        IFEND;
        iip$search_connection_desc (session_file, connection_desc_ptr);
        IF connection_desc_ptr = NIL THEN
          EXIT /get_pl_pw/;
        IFEND;

        iip$set_lock (connection_desc_ptr^.connection_attributes_lock, osc$wait, status);
        IF status.normal THEN
          page_length_width [1].page_length := connection_desc_ptr^.page_length;
          page_length_width [2].page_width := connection_desc_ptr^.page_width;
          iip$clear_lock (connection_desc_ptr^.connection_attributes_lock, status);
        IFEND;

      = iic$dsiaf_network =

        iip$set_lock (iiv$connection_desc_ptr^.lock, osc$wait, status);
        IF status.normal THEN
          page_length_width [1].page_length := iiv$connection_desc_ptr^.terminal_attributes.
                page_length;
          page_length_width [2].page_width := iiv$connection_desc_ptr^.terminal_attributes.
                page_width;
          iip$clear_lock (iiv$connection_desc_ptr^.lock, status);
        IFEND;

      CASEND;

    END /get_pl_pw/;

  PROCEND iip$get_page_length_width;
MODEND iim$get_page_length_width;
*DECK DECK=IIM$GET_TERMINAL_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??
MODULE iim$get_terminal_attributes;

{ PURPOSE: This module provides the ring 2 interface which gets
{          the terminal attributes for a dual state connection.
{
{  DESIGN: The input keys are validated and then the values for
{          the requested attributes are copied from the terminal
{          attributes field of the connection descriptor.
{
?? TITLE := 'MODULE iim$get_terminal_attributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc IFE$ERROR_CODES
*copyc IFT$TERMINAL_ATTRIBUTES
*copyc iik$keypoints
*copyc ost$status
*copyc pmt$condition_information
?? POP ??

*copyc JMP$SYSTEM_JOB
*copyc iiv$connection_desc_ptr
*copyc OSP$APPEND_STATUS_INTEGER
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc OSP$SET_STATUS_ABNORMAL
*copyc osp$set_status_from_condition
*copyc osv$170_os_type
*copyc pmp$continue_to_cause

?? NEWTITLE := 'PROCEDURE iip$get_terminal_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$get_terminal_attributes (VAR terminal_attributes:
        ift$terminal_attributes;
    VAR status: ost$status);

    VAR
      cdp: ^iit$terminal_attributes,
      i: integer,
      k: integer,
      set_of_terminal_attribute_keys: iit$terminal_attribute_keys_set;

?? OLDTITLE ??
?? NEWTITLE := 'handle_system_conditions', EJECT ??

{  PURPOSE:
{    This procedure handles system conditions.
{
{  DESIGN:
{    The procedure will set an abnormal status and exit the block.

   PROCEDURE handle_system_conditions
     (    condition:  pmt$condition;
          condition_descriptor: ^pmt$condition_information;
          stack_frame_save_area_p: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

     VAR
       ignore_status:  ost$status;

     IF condition.selector = pmc$system_conditions THEN
       IF status.normal THEN
         osp$set_status_from_condition ('II', condition,
               stack_frame_save_area_p, status, ignore_status);
       IFEND;
       EXIT  iip$get_terminal_attributes;
     ELSE
       pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
     IFEND;
   PROCEND handle_system_conditions;

    status.normal := TRUE;

  { Validate the terminal attribute keys.

    set_of_terminal_attribute_keys := - $iit$terminal_attribute_keys_set [];
    FOR i := LOWERBOUND (terminal_attributes) TO UPPERBOUND
          (terminal_attributes) DO
      IF NOT (terminal_attributes [i].key IN set_of_terminal_attribute_keys)
            THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$unknown_attribute_key, '', status);
        k := ORD (terminal_attributes [i].key);
        osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
              FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$GET_TERMINAL_ATTRIBUTES', status);
        RETURN;
      IFEND;
    FOREND;

  { Get the requested terminal attributes.

    cdp := ^iiv$connection_desc_ptr^.terminal_attributes; { convenience ploy }

    FOR i := 1 TO UPPERBOUND (terminal_attributes) DO
      CASE terminal_attributes [i].key OF

      = ifc$attention_character =
        terminal_attributes [i].attention_character := cdp^.attention_character;
      = ifc$backspace_character =
        terminal_attributes [i].backspace_character := cdp^.backspace_character;
      = ifc$begin_line_character =
        terminal_attributes [i].begin_line_character := cdp^.begin_line_character;
      = ifc$cancel_line_character =
        terminal_attributes [i].cancel_line_character := cdp^.cancel_line_character;
      = ifc$carriage_return_delay =
        terminal_attributes [i].carriage_return_delay := cdp^.carriage_return_delay;
      = ifc$carriage_return_sequence =
        terminal_attributes [i].carriage_return_sequence := cdp^.carriage_return_sequence;
      = ifc$character_flow_control =
        terminal_attributes [i].character_flow_control := cdp^.character_flow_control;
      = ifc$code_set =
        terminal_attributes [i].code_set := cdp^.code_set;
      = ifc$echoplex =
        terminal_attributes [i].echoplex := cdp^.echoplex;
      = ifc$end_line_character =
        terminal_attributes [i].end_line_character := cdp^.end_line_character;
      = ifc$end_line_positioning =
        terminal_attributes [i].end_line_positioning := cdp^.end_line_positioning;
      = ifc$end_output_sequence =
        terminal_attributes [i].end_output_sequence := cdp^.end_output_sequence;
      = ifc$end_page_action =
        terminal_attributes [i].end_page_action := cdp^.end_page_action;
      = ifc$end_partial_character =
        terminal_attributes [i].end_partial_character := cdp^.end_partial_character;
      = ifc$end_partial_positioning =
        terminal_attributes [i].end_partial_positioning := cdp^.end_partial_positioning;
      = ifc$fold_line =
        terminal_attributes [i].fold_line := cdp^.fold_line;
      = ifc$form_feed_delay =
        terminal_attributes [i].form_feed_delay := cdp^.form_feed_delay;
      = ifc$form_feed_sequence =
        terminal_attributes [i].form_feed_sequence := cdp^.form_feed_sequence;
      = ifc$function_key_class =

{  Condition handler deals with an invalid function_key_class pointer.

        osp$establish_condition_handler (^handle_system_conditions, FALSE);
        terminal_attributes [i].function_key_class^ := cdp^.function_key_class;
        osp$disestablish_cond_handler;
      = ifc$hold_page =
        terminal_attributes [i].hold_page := cdp^.hold_page;
      = ifc$hold_page_over =
        terminal_attributes [i].hold_page_over := cdp^.hold_page_over;
      = ifc$line_feed_delay =
        terminal_attributes [i].line_feed_delay := cdp^.line_feed_delay;
      = ifc$line_feed_sequence =
        terminal_attributes [i].line_feed_sequence := cdp^.line_feed_sequence;
      = ifc$network_command_character =
        terminal_attributes [i].network_command_character := cdp^.network_command_character;
      = ifc$null_terminal_attribute =

      { ignored attributes get "ignored" here }

      = ifc$page_length =
        terminal_attributes [i].page_length := cdp^.page_length;
      = ifc$page_width =
        terminal_attributes [i].page_width := cdp^.page_width;
      = ifc$parity =
        terminal_attributes [i].parity := cdp^.parity;
      = ifc$pause_break_character =
        terminal_attributes [i].pause_break_character := cdp^.pause_break_character;
      = ifc$status_action =
        terminal_attributes [i].status_action := cdp^.status_action;
      = ifc$terminal_class =
        terminal_attributes [i].terminal_class := cdp^.terminal_class;
      = ifc$terminal_model =
        terminal_attributes [i].terminal_model := cdp^.terminal_model;
      = ifc$terminal_name =
        IF osv$170_os_type <> osc$ot7_dual_state_nos_be THEN

{  Condition handler deals with an invalid terminal_name pointer.

          osp$establish_condition_handler (^handle_system_conditions, FALSE);
          terminal_attributes [i].terminal_name^ := iiv$connection_desc_ptr^.terminal_name;
          osp$disestablish_cond_handler;
        ELSE

{ The terminal_name attribute is undefined on NOS/BE.

          terminal_attributes [i].key := ifc$null_terminal_attribute;
        IFEND;
      = ifc$terminate_break_character =
        terminal_attributes [i].terminate_break_character := cdp^.terminate_break_character;
      ELSE
      CASEND;
    FOREND;


  PROCEND iip$get_terminal_attributes;

MODEND iim$get_terminal_attributes;
*DECK DECK=IIM$GET_TERM_CONN_ATTRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$get_term_conn_attributes;

{ PURPOSE: This module provides the ring 2 interface which gets
{          the default connection attributes for a particular file.
{          The returned values are the values which will be in
{          effect for subsequent instances-of-open of the file.

{  DESIGN: The values for the requested attributes are obtained from
{          the Local Name Table (LNT) entry for the named file.  The
{          attributes in this entry may have been set by the commands
{          REQT, CHATCA, or CHATCD or by their program interfaces
{          IFP$CHANGE_TERM_CONN_ATTRIBUTES, RMP$REQUEST_TERMINAL, or
{          IFP$CHANGE_TERM_CONN_DEFAULTS.  If a requested attribute
{          has not been set by either of these interfaces then the
{          value returned for it is the value it defaults to at login.
{
{          Authored by V.L. Richardson on 2/18/86.

?? TITLE := 'MODULE iim$get_term_conn_attributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc FMP$GET_TERMINAL_ATTRIBUTES
*copyc CLP$GET_ULTIMATE_CONNECTION
*copyc CLP$VALIDATE_NAME
*copyc CLV$STANDARD_FILES
*copyc IFE$ERROR_CODES
*copyc IIK$KEYPOINTS
*copyc IIV$CONNECTION_DESC_PTR
*copyc IIV$INTERACTIVE_TERMINATED
*copyc OSP$APPEND_STATUS_INTEGER
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$GET_JOB_MODE
*copyc RMP$GET_DEVICE_CLASS
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$get_term_conn_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$get_term_conn_attributes (local_file_name:
    amt$local_file_name;
    VAR connection_attributes: ift$get_connection_attributes;
    VAR status: ost$status);

    VAR
      converted_name: ost$name,
      default_term_attributes_ptr: ^ift$get_connection_attributes,
      device_assigned: boolean,
      device_class: rmt$device_class,
      i: integer,
      job_mode: jmt$job_mode,
      k: integer,
      local_status: ost$status,
      set_of_term_conn_attr_keys: iit$set_of_term_conn_attr_keys,
      ultimate_name: ost$name,
      valid_name: boolean;

    status.normal := TRUE;

  { Convert and validate the file name.

    clp$validate_name (local_file_name, converted_name, valid_name);
    IF NOT valid_name THEN
      osp$set_status_abnormal (ifc$interactive_facility_id,
            ife$file_name_ill_formed, local_file_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
        'IFP$GET_TERM_CONN_ATTRIBUTES', status);
      RETURN;
    IFEND;

  { Verify that the file is assigned to a terminal device.

    rmp$get_device_class (converted_name, device_assigned, device_class,
          local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    ELSE
      IF (device_class <> rmc$terminal_device) AND (device_class <> rmc$network_device) THEN
        clp$get_ultimate_connection (local_file_name, ultimate_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        pmp$get_job_mode (job_mode, local_status);
        IF NOT local_status.normal THEN
          status := local_status;
          RETURN;
        ELSEIF (NOT (job_mode IN $iit$job_modes [jmc$interactive_connected,
               jmc$interactive_cmnd_disconnect, jmc$interactive_line_disconnect,
               jmc$interactive_sys_disconnect]) AND
               (((ultimate_name = clv$standard_files [clc$sf_job_input_file].path_handle_name) OR
               (ultimate_name = clv$standard_files [clc$sf_job_output_file].path_handle_name)) OR
               (ultimate_name = clv$standard_files [clc$sf_command_file].path_handle_name))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
               ife$current_job_not_interactive, 'IFP$GET_TERM_CONN_ATTRIBUTES',
               status);
          RETURN;
        ELSE
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$file_name_not_terminal, converted_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$GET_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;
      IFEND;
    IFEND;

  { Validate the attribute keys.

    set_of_term_conn_attr_keys := - $iit$set_of_term_conn_attr_keys [];
    FOR i := LOWERBOUND (connection_attributes) TO UPPERBOUND
          (connection_attributes) DO
      IF NOT (connection_attributes [i].key IN set_of_term_conn_attr_keys)
            THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$unknown_attribute_key, '', status);
        k := ORD (connection_attributes [i].key);
        osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
              FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$GET_TERM_CONN_ATTRIBUTES', status);
        RETURN;
      IFEND;
    FOREND;

  { Get the requested attribute values from BAM's LNT.

    fmp$get_terminal_attributes (converted_name, connection_attributes, local_status);

  { Return the requested attribute values from the LNT if found there,
  { or from the set of login defaults, if not.

    FOR i := 1 TO UPPERBOUND (connection_attributes) DO
      IF connection_attributes [i].source = ifc$undefined_attribute THEN
        CASE iiv$network_identifier OF
        = iic$cdcnet_network =  { STANDALONE }
          CASE connection_attributes [i].key OF
          = ifc$attention_character_action =
            connection_attributes [i].attention_character_action :=
                  iiv$deflt_connection_attributes.attention_character_action.value;
          = ifc$break_key_action =
            connection_attributes [i].break_key_action :=
                  iiv$deflt_connection_attributes.break_key_action.value;
          = ifc$end_of_information =
            connection_attributes [i].end_of_information :=
                  iiv$deflt_connection_attributes.end_of_information.value;
          = ifc$input_block_size =
            connection_attributes [i].input_block_size :=
                  iiv$deflt_connection_attributes.input_block_size.value;
          = ifc$input_editing_mode =
            connection_attributes [i].input_editing_mode :=
                  iiv$deflt_connection_attributes.input_editing_mode.value;
          = ifc$input_output_mode =
            connection_attributes [i].input_output_mode :=
                  iiv$deflt_connection_attributes.input_output_mode.value;
          = ifc$input_timeout =
            connection_attributes [i].input_timeout :=
                  iiv$deflt_connection_attributes.input_timeout.value;
          = ifc$input_timeout_length =
            connection_attributes [i].input_timeout_length :=
                  iiv$deflt_connection_attributes.input_timeout_length.value;
          = ifc$input_timeout_purge =
            connection_attributes [i].input_timeout_purge :=
                  iiv$deflt_connection_attributes.input_timeout_purge.value;
          = ifc$partial_char_forwarding =
            connection_attributes [i].partial_character_forwarding :=
                  iiv$deflt_connection_attributes.partial_char_forwarding.value;
          = ifc$prompt_file =
            connection_attributes [i].prompt_file :=
                  iiv$deflt_connection_attributes.prompt_file.value;
          = ifc$prompt_file_identifier =
            connection_attributes [i].prompt_file_identifier :=
                  iiv$deflt_connection_attributes.prompt_file_identifier.value;
          = ifc$prompt_string =
            connection_attributes [i].prompt_string :=
                  iiv$deflt_connection_attributes.prompt_string.value;
          = ifc$store_backspace_character =
            connection_attributes [i].store_backspace_character :=
                  iiv$deflt_connection_attributes.store_backspace_character.value;
          = ifc$store_nuls_dels =
            connection_attributes [i].store_nuls_dels :=
                  iiv$deflt_connection_attributes.store_nuls_dels.value;
          = ifc$trans_character_mode =
            connection_attributes [i].trans_character_mode :=
                  iiv$deflt_connection_attributes.trans_character_mode.value;
          = ifc$trans_forward_character =
            connection_attributes [i].trans_forward_character :=
                  iiv$deflt_connection_attributes.trans_forward_character.value;
          = ifc$trans_length_mode =
            connection_attributes [i].trans_length_mode :=
                  iiv$deflt_connection_attributes.trans_length_mode.value;
          = ifc$trans_timeout_mode =
            connection_attributes [i].trans_timeout_mode :=
                  iiv$deflt_connection_attributes.trans_timeout_mode.value;
          = ifc$trans_message_length =
            connection_attributes [i].trans_message_length :=
                  iiv$deflt_connection_attributes.trans_message_length.value;
          = ifc$trans_terminate_character =
            connection_attributes [i].trans_terminate_character :=
                  iiv$deflt_connection_attributes.trans_terminate_character.value;
          = ifc$trans_protocol_mode =
            connection_attributes [i].trans_protocol_mode :=
                  iiv$deflt_connection_attributes.trans_protocol_mode.value;
          ELSE
          CASEND;

        = iic$dsiaf_network =  { DUAL STATE }

          CASE connection_attributes [i].key OF
          = ifc$attention_character_action =
            connection_attributes [i].attention_character_action := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.attention_character_action.value;
          = ifc$break_key_action =
            connection_attributes [i].break_key_action := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.break_key_action.value;
          = ifc$end_of_information =
            connection_attributes [i].end_of_information := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.end_of_information.value;
          = ifc$input_block_size =
            connection_attributes [i].input_block_size := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.input_block_size.value;
          = ifc$input_editing_mode =
            connection_attributes [i].input_editing_mode := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.input_editing_mode.value;
          = ifc$input_output_mode =
            connection_attributes [i].input_output_mode := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.input_output_mode.value;
          = ifc$input_timeout =
            connection_attributes [i].input_timeout := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.input_timeout.value;
          = ifc$input_timeout_length =
            connection_attributes [i].input_timeout_length := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.input_timeout_length.value;
          = ifc$input_timeout_purge =
            connection_attributes [i].input_timeout_purge := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.input_timeout_purge.value;
          = ifc$partial_char_forwarding =
            connection_attributes [i].partial_character_forwarding := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.partial_char_forwarding.value;
          = ifc$prompt_file =
            connection_attributes [i].prompt_file := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.prompt_file.value;
          = ifc$prompt_file_identifier =
            connection_attributes [i].prompt_file_identifier := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.prompt_file_identifier.value;
          = ifc$prompt_string =
            connection_attributes [i].prompt_string := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.prompt_string.value;
          = ifc$store_backspace_character =
            connection_attributes [i].store_backspace_character := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.store_backspace_character.value;
          = ifc$store_nuls_dels =
            connection_attributes [i].store_nuls_dels := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.store_nuls_dels.value;
          = ifc$trans_character_mode =
            connection_attributes [i].trans_character_mode := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.trans_character_mode.value;
          = ifc$trans_forward_character =
            connection_attributes [i].trans_forward_character := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.trans_forward_character.value;
          = ifc$trans_length_mode =
            connection_attributes [i].trans_length_mode := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.trans_length_mode.value;
          = ifc$trans_timeout_mode =
            connection_attributes [i].trans_timeout_mode := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.trans_timeout_mode.value;
          = ifc$trans_message_length =
            connection_attributes [i].trans_message_length := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.trans_message_length.value;
          = ifc$trans_terminate_character =
            connection_attributes [i].trans_terminate_character := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.trans_terminate_character.value;
          = ifc$trans_protocol_mode =
            connection_attributes [i].trans_protocol_mode := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.trans_protocol_mode.value;
          ELSE
          CASEND;

        CASEND;
      IFEND;
    FOREND;


  PROCEND iip$get_term_conn_attributes;
MODEND iim$get_term_conn_attributes;
*DECK DECK=IIM$GET_TERM_CONN_DEFAULTS EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$get_term_conn_defaults;

{ PURPOSE: This module provides the ring 2 interface which gets
{          the default connection attributes for the task.
{          The returned values are the values which will be the
{          defaults for subsequent files created within the task.

{  DESIGN: The values for the requested attributes are obtained from
{          the terminal connection table, in the case of standalone
{          connections, or from the attributes table pointed at by
{          iiv$terminal_request_ptr, for dual state.  These tables
{          are set/changed by CHATCD, IFP$CHANGE_TERM_CONN_DEFAULTS
{          or from the NAM/OS default attribute values at login.
{
{          Authored by V.L. Richardson on 3/01/86.

?? TITLE := 'MODULE iim$get_term_conn_defaults' ??

?? PUSH (LISTEXT := ON) ??
*copyc CLP$GET_ULTIMATE_CONNECTION
*copyc CLP$VALIDATE_NAME
*copyc CLV$STANDARD_FILES
*copyc IFE$ERROR_CODES
*copyc IIV$CONNECTION_DESC_PTR
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIV$INT_TASK_OPEN_FILE_COUNT
*copyc OSP$APPEND_STATUS_INTEGER
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$GET_JOB_MODE
*copyc RMP$GET_DEVICE_CLASS
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$get_term_conn_defaults', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$get_term_conn_defaults (local_file_name:
    amt$local_file_name;
    VAR connection_attributes: ift$get_connection_attributes;
    VAR status: ost$status);

    VAR
      converted_name: ost$name,
      device_assigned: boolean,
      device_class: rmt$device_class,
      i: integer,
      job_mode: jmt$job_mode,
      k: integer,
      local_status: ost$status,
      set_of_term_conn_attr_keys: iit$set_of_term_conn_attr_keys,
      ultimate_name: ost$name,
      valid_name: boolean;

    status.normal := TRUE;

  { Convert and validate the file name.

    clp$validate_name (local_file_name, converted_name, valid_name);
    IF NOT valid_name THEN
      osp$set_status_abnormal (ifc$interactive_facility_id,
            ife$file_name_ill_formed, local_file_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
        'IFP$GET_TERM_CONN_DEFAULTS', status);
      RETURN;
    IFEND;

    clp$get_ultimate_connection (local_file_name, ultimate_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  { Verify that the file is assigned to a terminal device.

    rmp$get_device_class (ultimate_name, device_assigned, device_class,
          local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    ELSE
      IF (device_class <> rmc$terminal_device) AND (device_class <> rmc$network_device) THEN
        pmp$get_job_mode (job_mode, local_status);
        IF NOT local_status.normal THEN
          status := local_status;
          RETURN;
        ELSEIF (NOT (job_mode IN $iit$job_modes [jmc$interactive_connected,
               jmc$interactive_cmnd_disconnect, jmc$interactive_line_disconnect,
               jmc$interactive_sys_disconnect]) AND
               (((ultimate_name = clv$standard_files [clc$sf_job_input_file].path_handle_name) OR
               (ultimate_name = clv$standard_files [clc$sf_job_output_file].path_handle_name)) OR
               (ultimate_name = clv$standard_files [clc$sf_command_file].path_handle_name))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
               ife$current_job_not_interactive, 'IFP$GET_TERM_CONN_DEFAULTS',
               status);
          RETURN;
        ELSE
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$file_name_not_terminal, converted_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
              'IFP$GET_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;
      IFEND;
    IFEND;

  { Validate the attribute keys.

    set_of_term_conn_attr_keys := - $iit$set_of_term_conn_attr_keys [];
    FOR i := LOWERBOUND (connection_attributes) TO UPPERBOUND
          (connection_attributes) DO
      IF NOT (connection_attributes [i].key IN set_of_term_conn_attr_keys)
            THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$unknown_attribute_key, '', status);
        k := ORD (connection_attributes [i].key);
        osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
              FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$GET_TERM_CONN_DEFAULTS', status);
        RETURN;
      IFEND;
    FOREND;

    IF iiv$network_identifier = iic$cdcnet_network THEN

    { Get the requested attribute values from the connection table.

      FOR i := 1 TO UPPERBOUND (connection_attributes) DO
        CASE connection_attributes [i].key OF
        = ifc$attention_character_action =
          connection_attributes [i].attention_character_action := iiv$connection_desc_ptr^.
                default_connection_attributes.attention_character_action.value;
        = ifc$break_key_action =
          connection_attributes [i].break_key_action := iiv$connection_desc_ptr^.
                default_connection_attributes.break_key_action.value;
        = ifc$end_of_information =
          connection_attributes [i].end_of_information := iiv$connection_desc_ptr^.
                default_connection_attributes.end_of_information.value;
        = ifc$input_block_size =
          connection_attributes [i].input_block_size := iiv$connection_desc_ptr^.
                default_connection_attributes.input_block_size.value;
        = ifc$input_editing_mode =
          connection_attributes [i].input_editing_mode := iiv$connection_desc_ptr^.
                default_connection_attributes.input_editing_mode.value;
        = ifc$input_output_mode =
          connection_attributes [i].input_output_mode := iiv$connection_desc_ptr^.
                default_connection_attributes.input_output_mode.value;
        = ifc$input_timeout =
          connection_attributes [i].input_timeout := iiv$connection_desc_ptr^.
                default_connection_attributes.input_timeout.value;
        = ifc$input_timeout_length =
          connection_attributes [i].input_timeout_length := iiv$connection_desc_ptr^.
                default_connection_attributes.input_timeout_length.value;
        = ifc$input_timeout_purge =
          connection_attributes [i].input_timeout_purge := iiv$connection_desc_ptr^.
                default_connection_attributes.input_timeout_purge.value;
        = ifc$partial_char_forwarding =
          connection_attributes [i].partial_character_forwarding := iiv$connection_desc_ptr^.
                default_connection_attributes.partial_char_forwarding.value;
        = ifc$prompt_file =
          connection_attributes [i].prompt_file := iiv$connection_desc_ptr^.
                default_connection_attributes.prompt_file.value;
        = ifc$prompt_file_identifier =
          connection_attributes [i].prompt_file_identifier := iiv$connection_desc_ptr^.
                default_connection_attributes.prompt_file_identifier.value;
        = ifc$prompt_string =
          connection_attributes [i].prompt_string := iiv$connection_desc_ptr^.
                default_connection_attributes.prompt_string.value;
        = ifc$store_backspace_character =
          connection_attributes [i].store_backspace_character := iiv$connection_desc_ptr^.
                default_connection_attributes.store_backspace_character.value;
        = ifc$store_nuls_dels =
          connection_attributes [i].store_nuls_dels := iiv$connection_desc_ptr^.
                default_connection_attributes.store_nuls_dels.value;
        = ifc$trans_character_mode =
          connection_attributes [i].trans_character_mode := iiv$connection_desc_ptr^.
                default_connection_attributes.trans_character_mode.value;
        = ifc$trans_forward_character =
          connection_attributes [i].trans_forward_character := iiv$connection_desc_ptr^.
                default_connection_attributes.trans_forward_character.value;
        = ifc$trans_length_mode =
          connection_attributes [i].trans_length_mode := iiv$connection_desc_ptr^.
                default_connection_attributes.trans_length_mode.value;
        = ifc$trans_timeout_mode =
          connection_attributes [i].trans_timeout_mode := iiv$connection_desc_ptr^.
                default_connection_attributes.trans_timeout_mode.value;
        = ifc$trans_message_length =
          connection_attributes [i].trans_message_length := iiv$connection_desc_ptr^.
                default_connection_attributes.trans_message_length.value;
        = ifc$trans_terminate_character =
          connection_attributes [i].trans_terminate_character := iiv$connection_desc_ptr^.
                default_connection_attributes.trans_terminate_character.value;
        = ifc$trans_protocol_mode =
          connection_attributes [i].trans_protocol_mode := iiv$connection_desc_ptr^.
                default_connection_attributes.trans_protocol_mode.value;
        ELSE
        CASEND;
      FOREND;

    ELSE

    { Put the default attributes into the caller's array.

    /return_attributes_to_caller/
      FOR i := 1 TO UPPERBOUND (connection_attributes) DO

        CASE connection_attributes [i].key OF

        = ifc$attention_character_action =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                attention_character_action.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].attention_character_action := iiv$terminal_request_ptr^.
                  attention_character_action.value;
          ELSE
            connection_attributes [i].attention_character_action := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.attention_character_action.value;
          IFEND;

        = ifc$break_key_action =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                break_key_action.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].break_key_action := iiv$terminal_request_ptr^.
                  break_key_action.value;
          ELSE
            connection_attributes [i].break_key_action := iiv$connection_desc_ptr^.
                nam_os_default_attributes.break_key_action.value;
          IFEND;

        = ifc$end_of_information =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                end_of_information.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].end_of_information := iiv$terminal_request_ptr^.
                  end_of_information.value;
          ELSE
            connection_attributes [i].end_of_information := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.end_of_information.value;
          IFEND;

        = ifc$input_block_size =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                input_block_size.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].input_block_size := iiv$terminal_request_ptr^.
                  input_block_size.value;
          ELSE
            connection_attributes [i].input_block_size := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.input_block_size.value;
          IFEND;

        = ifc$input_editing_mode =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                input_editing_mode.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].input_editing_mode := iiv$terminal_request_ptr^.
                  input_editing_mode.value;
          ELSE
            connection_attributes [i].input_editing_mode := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.input_editing_mode.value;
          IFEND;

        = ifc$input_output_mode =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                input_output_mode.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].input_output_mode := iiv$terminal_request_ptr^.
                  input_output_mode.value;
          ELSE
            connection_attributes [i].input_output_mode := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.input_output_mode.value;
          IFEND;

        = ifc$input_timeout =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                input_timeout.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].input_timeout := iiv$terminal_request_ptr^.
                  input_timeout.value;
          ELSE
            connection_attributes [i].input_timeout := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.input_timeout.value;
          IFEND;

        = ifc$input_timeout_length =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                input_timeout_length.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].input_timeout_length := iiv$terminal_request_ptr^.
                  input_timeout_length.value;
          ELSE
            connection_attributes [i].input_timeout_length := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.input_timeout_length.value;
          IFEND;

        = ifc$input_timeout_purge =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                input_timeout_purge.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].input_timeout_purge := iiv$terminal_request_ptr^.
                  input_timeout_purge.value;
          ELSE
            connection_attributes [i].input_timeout_purge := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.input_timeout_purge.value;
          IFEND;

        = ifc$partial_char_forwarding =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                partial_char_forwarding.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].partial_character_forwarding := iiv$terminal_request_ptr^.
                  partial_char_forwarding.value;
          ELSE
            connection_attributes [i].partial_character_forwarding := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.partial_char_forwarding.value;
          IFEND;

        = ifc$prompt_file =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                prompt_file.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].prompt_file := iiv$terminal_request_ptr^.
                  prompt_file.value;
          ELSE
            connection_attributes [i].prompt_file := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.prompt_file.value;
          IFEND;

        = ifc$prompt_file_identifier =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                prompt_file_identifier.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].prompt_file_identifier := iiv$terminal_request_ptr^.
                  prompt_file_identifier.value;
          ELSE
            connection_attributes [i].prompt_file_identifier := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.prompt_file_identifier.value;
          IFEND;

        = ifc$prompt_string =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                prompt_string.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].prompt_string := iiv$terminal_request_ptr^.
                  prompt_string.value;
          ELSE
            connection_attributes [i].prompt_string := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.prompt_string.value;
          IFEND;

        = ifc$store_backspace_character =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                store_backspace_character.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].store_backspace_character := iiv$terminal_request_ptr^.
                  store_backspace_character.value;
          ELSE
            connection_attributes [i].store_backspace_character := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.store_backspace_character.value;
          IFEND;

        = ifc$store_nuls_dels =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                store_nuls_dels.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].store_nuls_dels := iiv$terminal_request_ptr^.
                  store_nuls_dels.value;
          ELSE
            connection_attributes [i].store_nuls_dels := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.store_nuls_dels.value;
          IFEND;

        = ifc$trans_character_mode =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                trans_character_mode.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].trans_character_mode := iiv$terminal_request_ptr^.
                  trans_character_mode.value;
          ELSE
            connection_attributes [i].trans_character_mode := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.trans_character_mode.value;
          IFEND;

        = ifc$trans_forward_character =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                trans_forward_character.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].trans_forward_character := iiv$terminal_request_ptr^.
                  trans_forward_character.value;
          ELSE
            connection_attributes [i].trans_forward_character := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.trans_forward_character.value;
          IFEND;

        = ifc$trans_length_mode =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                trans_length_mode.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].trans_length_mode := iiv$terminal_request_ptr^.
                  trans_length_mode.value;
          ELSE
            connection_attributes [i].trans_length_mode := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.trans_length_mode.value;
          IFEND;

        = ifc$trans_timeout_mode =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                trans_timeout_mode.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].trans_timeout_mode := iiv$terminal_request_ptr^.
                  trans_timeout_mode.value;
          ELSE
            connection_attributes [i].trans_timeout_mode := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.trans_timeout_mode.value;
          IFEND;

        = ifc$trans_message_length =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                trans_message_length.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].trans_message_length := iiv$terminal_request_ptr^.
                  trans_message_length.value;
          ELSE
            connection_attributes [i].trans_message_length := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.trans_message_length.value;
          IFEND;

        = ifc$trans_terminate_character =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                trans_terminate_character.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].trans_terminate_character := iiv$terminal_request_ptr^.
                  trans_terminate_character.value;
          ELSE
            connection_attributes [i].trans_terminate_character := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.trans_terminate_character.value;
          IFEND;

        = ifc$trans_protocol_mode =
          IF (iiv$terminal_request_ptr <> NIL) AND (iiv$terminal_request_ptr^.
                trans_protocol_mode.source <> ifc$undefined_attribute) THEN
            connection_attributes [i].trans_protocol_mode := iiv$terminal_request_ptr^.
                  trans_protocol_mode.value;
          ELSE
            connection_attributes [i].trans_protocol_mode := iiv$connection_desc_ptr^.
                  nam_os_default_attributes.trans_protocol_mode.value;
          IFEND;

        ELSE
        CASEND;

      FOREND /return_attributes_to_caller/;
    IFEND; { iiv$network_identifier = iic$cdcnet_network }

  PROCEND iip$get_term_conn_defaults;
MODEND iim$get_term_conn_defaults;
*DECK DECK=IIM$IIMNAM EXPAND=TRUE
          IDENT  IIMNAM
          TITLE  IIM$IIMNAM - CYBIL INTERFACE TO THE NAM.
*copyc dsa$cybil_if_macros
          ENTRY  NET#ON
          ENTRY  NET#OFF
          ENTRY  NET#PUT
          ENTRY  NET#GET
          ENTRY  NET#STC
          ENTRY  NET#DBG
          ENTRY  NET#WAI
          ENTRY  NET#GTL
          ENTRY  ROJ
          EXT    PXSAVE
          LIST   F
          SYSCOM B1
          IF     -DEF,RA.ORG,1
OPL XTEXT COMCMAC
          EXT    PXREST
          SST
FORMFTN   MACRO  L
CNT       SET    0
          IRP    L
          SX6    L
          IFNE   CNT,0,2
          SA6    A6+B1
          SKIP   1
          SA6    PLIST+CNT
CNT       SET    CNT+1
          IRP
          MX6    0
          SA6    A6+B1
          ENDM
*
STP       MACRO  REG,LOC
          BX6    REG
          SA6    LOC
          ENDM
*
IND       MACRO  REG,LOC
          SA1    REG+NAMTAB
          BX6    X1
          SA6    LOC
          ENDM
*
NOS       IF     -DEF,RA.ORG
PLIST     BSS    10
TT1        BSS    1
TT2        BSS    1
TT3        BSS    1
TT4        BSS    1
TT5        BSS    1
CWP       BSS    1           POINTER TO COMM_WORD
*
          LIST   M
*
*      PROCEDURE [XREF] NET#ON (ANAME: INTEGER;
*        NSUP: ^CELL;
*        STATUS: ^CELL;
*        MINACN,
*        MAXACN: INTEGER);
*
NOS       ENDIF
NET#ON    BSS    0
NOS       IF     -DEF,RA.ORG
          RJ     PXSAVE
          BX6    X2
          SA6    CWP         SAVE POINTER TO COMM_WORD
          FORMFTN (TT1,X2,X3,TT4,TT5)
          SA1    X1
          STP    X1,TT1
          STP    X4,TT4
          STP    X5,TT5
          SA1    PLIST
          RJ     =XNETON
          EQ     LEAVE
*
*      PROCEDURE [XREF] NET#OFF;
*
NOS       ENDIF
NET#OFF   BSS    0
NOS       IF     -DEF,RA.ORG
          RJ     PXSAVE
          RJ     =XNETOFF
          EQ     LEAVE
*
*      PROCEDURE [XREF] NET#GET (ACN: INTEGER;
*        MSG: ^CELL;
*        TLMAX: INTEGER);
*
NOS       ENDIF
NET#GET   BSS    0
NOS       IF     -DEF,RA.ORG
          RJ     PXSAVE
          FORMFTN (TT1,X2,X2+1,TT4)
          STP    X1,TT1
          STP    X3,TT4
          SA1    PLIST
          RJ     =XNETGET
          EQ     LEAVE
*
*      PROCEDURE [XREF] NET#GTL (ALN: INTEGER;
*        MSG: ^CELL;
*        TLMAX: INTEGER);
*
NOS       ENDIF
NET#GTL   BSS    0
NOS       IF     -DEF,RA.ORG
          RJ     PXSAVE
          FORMFTN (TT1,X2,X2+1,TT4)
          STP    X1,TT1
          STP    X3,TT4
          SA1    PLIST
          RJ     =XNETGETL
          EQ     LEAVE
*
*      PROCEDURE [XREF] NET#PUT (MSG: ^CELL);
*
NOS       ENDIF
NET#PUT   BSS    0
NOS       IF     -DEF,RA.ORG
          RJ     PXSAVE
          FORMFTN (X1,X1+1)
          SA1    PLIST
          RJ     =XNETPUT
          EQ     LEAVE
*
*      PROCEDURE [XREF] NET#STC (ONOFF: INTEGER;
*        AVAIL: ^CELL);
*
NOS       ENDIF
NET#STC   BSS    0
NOS       IF     -DEF,RA.ORG
          RJ     PXSAVE
          FORMFTN (TT1,X2)
          STP    X1,TT1
          SA1    PLIST
          RJ     =XNETSTC
          EQ     LEAVE
*
*      PROCEDURE [XREF] NET#DBG (DBUGSUP: INTEGER;
*        DBUGDAT: INTEGER;
*        AVAIL: ^CELL);
*
NOS       ENDIF
NET#DBG   BSS    0
NOS       IF     -DEF,RA.ORG
          RJ     PXSAVE
          FORMFTN (TT1,TT2,X3)
          STP    X1,TT1
          STP    X2,TT2
          SA1    PLIST
          RJ     =XNETDBG
*
* SET FLUSH BIT
*
          SX6    1
          MX7    0
          SA6    TT1
          SA7    TT2
          FORMFTN (TT1,TT2)
          SA1    PLIST
          RJ     =XNETSETF
          EQ     LEAVE
*
*      PROCEDURE [XREF] NET#WAIT (TIME,
*        KIND: INTEGER);
*
NOS       ENDIF
NET#WAI   BSS    0
NOS       IF     -DEF,RA.ORG
          RJ     PXSAVE
          FORMFTN (TT1,TT2)
          STP    X1,TT1
          STP    X2,TT2
* *
* * CHECK IF TO TERMINATE
* *
*           SX6    ERAD
*           SA6    KILLJOB+10
*           GET    KILLJOB
*           SA1    KILLJOB
*           AX1    10
*           MX0    52
*           BX1    -X0*X1
*           SX0    2
*           IX0    X0-X1
*           NZ     X0,ENDR
          SA1    PLIST
          RJ     =XNETWAIT
          EQ     LEAVE
* KILLJOB   FILEB  0,0,(EPR),(FET=16)
* ERAD      BSS    10
*
* PROCEDURE [XREF] ROJ (TIME: INTEGER);
* ROJ - ROLLOUT JOB FOR A SPECIFIED NUMBER OF SECONDS
*
NOS       ENDIF
ROJ       BSS    0
NOS       IF     -DEF,RA.ORG
          RJ     PXSAVE
          SA2    ROW
          MX3    48
          BX4    X3*X2
          BX6    X4+X1
          SA6    A2
          ROLLOUT ROW
          EQ     LEAVE
ROW       VFD    30/0,18/770000B,12/0
NOS       ELSE
          SHORTEX
NOS       ENDIF
*
*****
*
          IF     -DEF,RA.ORG,2
LEAVE     BSS    0
          RJ     PXREST
*
*****
*
* ENDR      BSS    0
*           MESSAGE (=C$ ENDED BY *PF=KILLJOB*. $),3,R
*           RJ     =XNETOFF
*           ENDRUN
          END
*DECK DECK=IIM$INITIALIZE_CONNECTION EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$initialize_connection;
?? TITLE := 'MODULE iim$initialize_connection' ??

?? PUSH (LISTEXT := ON) ??
*copyc OSS$JOB_PAGED_LITERAL
*copyc IIP$ALLOCATE_QUEUE_ENTRY
*copyc IIP$DPC64_TO_STRING
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIV$CONNECTION_DESC_PTR
*copyc ost$name
*copyc OST$STATUS
*copyc osv$170_os_type
*copyc OSS$TASK_SHARED
*copyc OSP$INITIALIZE_SIG_LOCK
*copyc OSV$TASK_SHARED_HEAP
*copyc PMP$GET_EXECUTING_TASK_GTID
*copyc PMP$LOG
*copyc tmc$wait_times
?? POP ??
*copyc qfp$set_terminal_name

  VAR
    connection_attributes: [READ,OSS$JOB_PAGED_LITERAL] iit$connection_attributes := [
      [0, ifc$nam_default],                                      {attention_character_action}
      [0, ifc$nam_default],                                      {break_key_action}
      [[4, '*EOI'], ifc$os_default],                             {end_of_information}
      [2000, ifc$nam_default],                                   {input_block_size}
      [ifc$normal_edit, ifc$nam_default],                        {input_editing_mode}
      [ifc$unsolicited_output, ifc$nam_default],                 {input_output_mode}
      [FALSE, ifc$os_default],                                   {input_timeout}
      [1048575, ifc$os_default],                                 {input_timeout_length}
      [TRUE, ifc$os_default],                                    {input_timeout_purge}
      [FALSE, ifc$nam_default],                                  {partial_char_forwarding}
      [':$LOCAL.OUTPUT.1               ', ifc$os_default],       {prompt_file}
      [[0, 1], ifc$os_default],                                  {prompt_file_identifier}
      [[3, ' ? '], ifc$os_default],                              {prompt_string}
      [FALSE, ifc$nam_default],                                  {store_backspace_character}
      [FALSE, ifc$nam_default],                                  {store_nuls_dels}
      [ifc$no_trans_char, ifc$nam_default],                      {trans_character_mode}
      [[1, $char(0d(16))], ifc$nam_default],                     {trans_forward_character}
      [ifc$no_trans_len, ifc$nam_default],                       {trans_length_mode}
      [2000, ifc$nam_default],                                   {trans_message_length}
      [[1, $char(0d(16))], ifc$nam_default],                     {trans_terminate_character}
      [ifc$no_trans_timeout, ifc$nam_default],                  {trans_timeout_mode}
      [ifc$no_trans_protocol, ifc$nam_default]];                  {trans_protocol_mode}

?? NEWTITLE := 'PROCEDURE iip$initialize_connection', EJECT ??

  PROCEDURE [XDCL] iip$initialize_connection (pism: ^iit$input_supervisory_message);

    VAR
      conn_desc_entry_descriptor: iit$queue_entry_descriptor,
      display_code_characters: iit$terminal_name,
      i: 1 .. 15,
      status: ost$status,
      terminal_name: ift$terminal_name,
      terminal_name_length: integer;

    osp$initialize_sig_lock (iiv$interactive_task_count_lock);

    osp$initialize_sig_lock (iiv$downline_queue_lock);
    osp$initialize_sig_lock (iiv$get_lock);

    osp$initialize_sig_lock (iiv$connection_desc_lock);

    iip$allocate_queue_entry (iic$connection_description,
      conn_desc_entry_descriptor, status);
    iiv$connection_desc_ptr := conn_desc_entry_descriptor.
      connection_description_ptr;
    iiv$connection_desc_ptr^.attributes_cycle := 0;
    iiv$connection_desc_ptr^.next_entry := NIL;
    iiv$connection_desc_ptr^.previous_entry := NIL;
    iiv$connection_desc_ptr^.connection_number := 0;
    iiv$connection_desc_ptr^.next_block_number := 0;
    iiv$connection_desc_ptr^.block_size := 120;
    iiv$connection_desc_ptr^.nam_os_default_attributes := connection_attributes;

{ Set terminal_model attribute to null string.

    iiv$connection_desc_ptr^.terminal_attributes.terminal_model.value := ' ';
    iiv$connection_desc_ptr^.terminal_attributes.terminal_model.size := 1;

{ Set terminal_class.

    iiv$connection_desc_ptr^.terminal_attributes.terminal_class :=
          iiv$upline_term_class_conv [pism^.conreq_terminal_class];

{ On NOS dual state, set terminal_name attribute to name passed from CON/REQ/R
{ message which is in display code and must be converted to ASCII.  For NOS/BE,
{ the terminal name will always be OSC$NULL_NAME.

    IF osv$170_os_type <> osc$ot7_dual_state_nos_be THEN
      display_code_characters := pism^.conreq_terminal_name;
      iip$dpc64_to_string (display_code_characters, 7, ' ', terminal_name,
            terminal_name_length);
      iiv$connection_desc_ptr^.terminal_name := terminal_name (1, terminal_name_length);
      qfp$set_terminal_name (terminal_name);
    ELSE
      iiv$connection_desc_ptr^.terminal_name := osc$null_name;
      qfp$set_terminal_name (osc$null_name);
    IFEND;

{ Insure that invoking the Terminal Timeout Disconnect feature does not cause
{  PMP$LONG_TERM_WAIT to be called with out-of-range parameters in IIP$GET.

    IF iiv$terminal_timeout_limit > tmc$infinite_wait THEN
      iiv$terminal_timeout_limit := tmc$infinite_wait;
      iiv$terminal_timeout_limit_left := tmc$infinite_wait;
    IFEND;

    FOR i := 1 TO 15 DO
      iiv$connection_desc_ptr^.term_char_values [i] := 0ff(16);
      iiv$connection_desc_ptr^.active_term_char_values [i] := 0ff(16);
    FOREND;

    iiv$connection_desc_ptr^.connection_number := iiv$job_connection;
    osp$initialize_sig_lock (iiv$connection_desc_ptr^.lock);

    pmp$get_executing_task_gtid (iiv$job_monitor_task_id);
    iiv$task_handling_break := iiv$job_monitor_task_id;

  PROCEND iip$initialize_connection;

MODEND iim$initialize_connection
*DECK DECK=IIM$INIT_OPEN_DESC_ATTRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$init_open_desc_attributes;
?? TITLE := 'MODULE iim$init_open_desc_attributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc AMP$FETCH
*copyc FMP$GET_TERMINAL_ATTRIBUTES
*copyc IFE$ERROR_CODES
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIP$BUILD_TERM_CHAR_VALUES
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIV$INT_TASK_OPEN_FILE_COUNT
*copyc OST$STATUS
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc OSP$SET_STATUS_ABNORMAL
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$init_open_desc_attributes', EJECT ??

  PROCEDURE [XDCL] iip$init_open_desc_attributes (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$open_file_description;
    VAR status: ost$status);

    VAR
      get_all_attributes: array [1 .. (ORD (ifc$max_connection_key) + 1)] OF
            ift$get_connection_attribute,
      replace_all_attributes: iit$connection_attributes,
      open_file_terminal_attributes: iit$connection_attributes,
      get_bam_file_attributes: array [1 .. 2] of amt$fetch_item,
      i: ift$connection_attribute_keys,
      j: integer,
      local_status: ost$status;

    status.normal := TRUE;

    open_file_terminal_attributes := iiv$init_undefined_attributes;

    get_all_attributes := iiv$all_get_term_attributes;

  { Get the attributes stored in BAM's LNT entry for the named file.

    fmp$get_terminal_attributes (open_file_desc_pointer^.file_name,
      get_all_attributes, local_status);

  { Replace the attributes in the open_file_terminal_attributes array.

    FOR j := LOWERBOUND (get_all_attributes) TO UPPERBOUND (get_all_attributes) DO
      CASE get_all_attributes [j].key OF
      = ifc$attention_character_action =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.attention_character_action.value :=
                get_all_attributes [j].attention_character_action;
          open_file_terminal_attributes.attention_character_action.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.attention_character_action := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.attention_character_action;
        IFEND;

      = ifc$break_key_action =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.break_key_action.value :=
                get_all_attributes [j].break_key_action;
          open_file_terminal_attributes.break_key_action.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.break_key_action := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.break_key_action;
        IFEND;

      = ifc$end_of_information =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.end_of_information.value :=
                get_all_attributes [j].end_of_information;
          open_file_terminal_attributes.end_of_information.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.end_of_information := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.end_of_information;
        IFEND;

      = ifc$input_block_size =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.input_block_size.value :=
                get_all_attributes [j].input_block_size;
          open_file_terminal_attributes.input_block_size.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.input_block_size := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.input_block_size;
        IFEND;

      = ifc$input_editing_mode =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.input_editing_mode.value :=
                get_all_attributes [j].input_editing_mode;
          open_file_terminal_attributes.input_editing_mode.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.input_editing_mode := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.input_editing_mode;
        IFEND;

      = ifc$input_output_mode =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.input_output_mode.value :=
                get_all_attributes [j].input_output_mode;
          open_file_terminal_attributes.input_output_mode.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.input_output_mode := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.input_output_mode;
        IFEND;

      = ifc$input_timeout =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.input_timeout.value :=
                get_all_attributes [j].input_timeout;
          open_file_terminal_attributes.input_timeout.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.input_timeout := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.input_timeout;
        IFEND;

      = ifc$input_timeout_length =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.input_timeout_length.value :=
                get_all_attributes [j].input_timeout_length;
          open_file_terminal_attributes.input_timeout_length.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.input_timeout_length := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.input_timeout_length;
        IFEND;

      = ifc$input_timeout_purge =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.input_timeout_purge.value :=
                get_all_attributes [j].input_timeout_purge;
          open_file_terminal_attributes.input_timeout_purge.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.input_timeout_purge := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.input_timeout_purge;
        IFEND;

      = ifc$partial_char_forwarding =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.partial_char_forwarding.value :=
                get_all_attributes [j].partial_character_forwarding;
          open_file_terminal_attributes.partial_char_forwarding.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.partial_char_forwarding := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.partial_char_forwarding;
        IFEND;

      = ifc$prompt_file =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.prompt_file.value :=
                get_all_attributes [j].prompt_file;
          open_file_terminal_attributes.prompt_file.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.prompt_file := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.prompt_file;
        IFEND;

      = ifc$prompt_file_identifier =
        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.prompt_file_identifier.value :=
                get_all_attributes [j].prompt_file_identifier;
          open_file_terminal_attributes.prompt_file_identifier.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.prompt_file_identifier := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.prompt_file_identifier;
        IFEND;

      = ifc$prompt_string =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.prompt_string.value :=
                get_all_attributes [j].prompt_string;
          open_file_terminal_attributes.prompt_string.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.prompt_string := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.prompt_string;
        IFEND;

      = ifc$store_backspace_character =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.store_backspace_character.value :=
                get_all_attributes [j].store_backspace_character;
          open_file_terminal_attributes.store_backspace_character.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.store_backspace_character := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.store_backspace_character;
        IFEND;

      = ifc$store_nuls_dels =
        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.store_nuls_dels.value :=
                get_all_attributes [j].store_nuls_dels;
          open_file_terminal_attributes.store_nuls_dels.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.store_nuls_dels := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.store_nuls_dels;
        IFEND;

      = ifc$trans_character_mode =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.trans_character_mode.value :=
                get_all_attributes [j].trans_character_mode;
          open_file_terminal_attributes.trans_character_mode.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.trans_character_mode := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.trans_character_mode;
        IFEND;

      = ifc$trans_forward_character =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.trans_forward_character.value :=
                get_all_attributes [j].trans_forward_character;
          open_file_terminal_attributes.trans_forward_character.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.trans_forward_character := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.trans_forward_character;
        IFEND;

      = ifc$trans_length_mode =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.trans_length_mode.value :=
                get_all_attributes [j].trans_length_mode;
          open_file_terminal_attributes.trans_length_mode.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.trans_length_mode := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.trans_length_mode;
        IFEND;

      = ifc$trans_timeout_mode =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.trans_timeout_mode.value :=
                get_all_attributes [j].trans_timeout_mode;
          open_file_terminal_attributes.trans_timeout_mode.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.trans_timeout_mode := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.trans_timeout_mode;
        IFEND;

      = ifc$trans_message_length =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.trans_message_length.value :=
                get_all_attributes [j].trans_message_length;
          open_file_terminal_attributes.trans_message_length.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.trans_message_length := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.trans_message_length;
        IFEND;

      = ifc$trans_terminate_character =

        IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
          open_file_terminal_attributes.trans_terminate_character.value :=
                get_all_attributes [j].trans_terminate_character;
          open_file_terminal_attributes.trans_terminate_character.source :=
                get_all_attributes [j].source;
        ELSE
          open_file_terminal_attributes.trans_terminate_character := open_file_desc_pointer^.
                connection_desc_pointer^.nam_os_default_attributes.trans_terminate_character;
        IFEND;

      ELSE
      CASEND;
    FOREND;

  { Set the terminal attributes in the open file descriptor.

    open_file_desc_pointer^.attributes := open_file_terminal_attributes;

  { Initialize the attributes cycle in the open file descriptor.

    open_file_desc_pointer^.attributes_cycle := open_file_desc_pointer^.
          connection_desc_pointer^.attributes_cycle;

  { Initialize the characteristics values in the open file descriptor.

    iip$build_term_char_values (open_file_desc_pointer);

  PROCEND iip$init_open_desc_attributes;
MODEND iim$init_open_desc_attributes;
*DECK DECK=IIM$INTERRUPT_TIMESHARING_IO EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'Module iim$interrupt_timesharing_io' ??
?? NEWTITLE := 'Global Declarations' ??
  MODULE iim$interrupt_timesharing_io;
?? PUSH (LISTEXT := ON) ??
*copyc ifc$interrupt_timesharing_io
*copyc ife$error_codes
?? POP ??
*copyc iip$vt_flush_input
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc oss$task_private
*copyc osp$decrement_locked_variable
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$cause_condition
*copyc pmp$wait

*copyc iiv$connection_desc_ptr
*copyc iiv$interactive_terminated

  VAR
    iiv$io_requests_in_job: [XDCL , oss$task_shared] integer {ALIGNED [0 MOD 8]} := 0,
    iiv$io_requests_in_task: [XDCL , oss$task_private] integer :=0;

?? TITLE := '[XDCL] iip$interrupt_timesharing_io', EJECT ??

    PROCEDURE [XDCL, #GATE] iip$interrupt_timesharing_io (VAR status: ost$status);

      VAR
        decrement_error: boolean,
        io_requests_in_job: integer,
        ignore_status: ost$status,
        initial_put_info: [READ, oss$job_paged_literal] iit$task_put_info := [1, 0,
          amc$terminate, FALSE, FALSE, FALSE, 0];

      status.normal := TRUE;
      ignore_status.normal := TRUE;

      WHILE iiv$io_requests_in_job > 0 DO
        IF iiv$io_requests_in_job = iiv$io_requests_in_task THEN
          pmp$cause_condition(ifc$interrupt_timesharing_io, NIL, ignore_status);
          IF iiv$io_requests_in_task > 0 THEN

{ This implies that the current task was pulled out of an io-attempt due to
{ termination - io_request_counts will be off - can locks be set?? - do we care??
{ We must re-adjust the counts by decrementing the job count by the task count.
{ The decrement of the job count must be locked - another task may try to start io.
{ This should yield us the exit condition for the while loop.

            WHILE iiv$io_requests_in_task > 0 DO
              iiv$io_requests_in_task := iiv$io_requests_in_task - 1;
              osp$decrement_locked_variable (iiv$io_requests_in_job, iiv$io_requests_in_job,
                    io_requests_in_job, decrement_error);
            WHILEND;

          IFEND;
        ELSE
          pmp$wait (100, 100);
        IFEND;
      WHILEND;
      { Empty upline and downline queues.}
      { Note - the following references to iiv$connection_desc_ptr assume that
      { any interrupt can be presumed to relate to the first (nominal)
      { connection.  In release 1.2.1, timesharing jobs can have only one
      { connection, and it is nominal, while the system job can have multiple
      { connections, of which none are nominal.

      { It is possible for timesharing interrupts to occur when the connection
      { description has not been defined.

      IF iiv$connection_desc_ptr <> NIL THEN
        RESET iiv$connection_desc_ptr^.output_buffer_entry_loc;
        RESET iiv$connection_desc_ptr^.output_buffer_exit_loc;
        iiv$connection_desc_ptr^.downline_queue_count := 0;
        iiv$connection_desc_ptr^.put_info := initial_put_info;
        iip$vt_flush_input (iiv$connection_desc_ptr^.vtp_connection_id, ignore_status);
      IFEND;

    PROCEND iip$interrupt_timesharing_io;

  MODEND iim$interrupt_timesharing_io;
*DECK DECK=IIM$JOB_PAGEABLE_VARIABLES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$job_pageable_variables;

{   WARNING:
{      The following order must be used when obtaining more than one
{      interactive lock in order to avoid deadlocks:
{       - iiv$downline_queue_lock
{       - iiv$repeat_queue_lock
{       - iiv$upline_queue_lock

?? TITLE := 'MODULE iim$job_pageable_variables' ??

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc osd$integer_limits
*copyc ost$signature_lock
*copyc OSS$JOB_PAGED_LITERAL
*copyc oss$task_shared
*copyc PMT$CONDITION
?? POP ??

  VAR
    iiv$connection_desc_ptr: [XDCL] ^iit$connection_description := NIL,
    iiv$connection_desc_lock: [XDCL] ost$signature_lock,
    iiv$connection_desc_count: [XDCL] integer := 0,

    iiv$suppress_cursor_positioning: [XDCL] boolean := FALSE,
    iiv$suppress_echoplexing: [XDCL] boolean := FALSE,
    iiv$interactive_terminated: [XDCL] boolean := FALSE,
    iiv$abort_get: [XDCL] boolean := FALSE,
    iiv$abort_job_initialization: [XDCL] boolean := FALSE,

    iiv$interactive_task_count: [XDCL] integer := 0,
    iiv$interactive_task_count_lock: [XDCL] ost$signature_lock,

    iiv$get_lock: [XDCL] ost$signature_lock,
    iiv$get_info: [XDCL] iit$task_get_info := [ * ,
      iic$last_block, * , FALSE , * , 1, * , amc$eor],

    iiv$downline_queue_lock: [XDCL] ost$signature_lock,
    iiv$downline_queue_count: [XDCL] integer := 0,

    iiv$last_formatting_mode: [XDCL, #GATE] 0 .. 0ff(16) := 0,

    iiv$upline_data_buffer_ptr: [XDCL] ^iit$input_data_message,

    iiv$job_connection: [XDCL, #GATE] iit$application_connection_num := 0,

    iiv$cdcnet_connection: [XDCL, #GATE] boolean,

    iiv$network_identifier: [XDCL, #GATE] iit$network_identifier := iic$dsiaf_network,

    iiv$screen_clear_string: [XDCL] ost$string := [0, ' '],

    iiv$terminal_timeout_limit: [XDCL, #GATE, oss$task_shared] integer :=
         osc$max_integer,

    iiv$terminal_timeout_limit_left: [XDCL, #GATE, oss$task_shared] integer :=
         osc$max_integer,

    iiv$previous_blank_flag: [XDCL] boolean := FALSE,

    iiv$previous_connection_attr: [XDCL] iit$connection_attributes,

    iiv$previous_mode: [XDCL] iit$terminal_mode := iic$line,

    iiv$previous_file_id: [XDCL] amt$file_identifier,

    iiv$previous_operation: [XDCL] amt$fap_operation := amc$put_next_req,

    iiv$jm_application_name: [XDCL] mlt$application_name := mlc$null_name,


    iiv$break_abn: [XDCL] integer := 0,
    iiv$task_handling_break: [XDCL] ost$global_task_id,

    iiv$condition_descriptor: [XDCL, READ, oss$job_paged_literal] pmt$condition :=
      [pmc$condition_combination, $pmt$condition_combination
      [ifc$interactive_condition]],

    iiv$downline_term_class_conv: [XDCL, READ, oss$job_paged_literal] array
      [ifc$tty_class .. ifc$i3270_class] of iit$field_value := [iic$tty_class,
      iic$c75x_class, iic$c721_class, iic$i2741_class,
      iic$tty40_class,iic$h2000_class,
      iic$x364_class, iic$t4010_class, iic$hasp_post_print_class,
      iic$c200ut_class, iic$c714_30_class,
      iic$c711_class, iic$c714_10_or_20_class, iic$hasp_pre_print_class,
      iic$c73x_class, iic$i2740_class, iic$i3780_class, iic$i3270_class],

    iiv$upline_term_class_conv: [XDCL, READ, oss$job_paged_literal] array
      [iic$tty_class .. iic$i3270_class] of ift$terminal_class := [
       { 1 = }   ifc$tty_class,
       { 2 = }   ifc$c75x_class,
       { 3 = }   ifc$c721_class,
       { 4 = }   ifc$i2741_class,
       { 5 = }   ifc$tty40_class,
       { 6 = }   ifc$h2000_class,
       { 7 = }   ifc$x364_class,
       { 8 = }   ifc$t4010_class,
       { 9 = }   ifc$hasp_post_class,
       { 10 = }  ifc$c200ut_class,
       { 11 = }  ifc$c714_30_40,
       { 12 = }  ifc$c711_class,
       { 13 = }  ifc$c714_10_20_class,
       { 14 = }  ifc$hasp_pre_class,
       { 15 = }  ifc$c73x_class,
       { 16 = }  ifc$i2740_class,
       { 17 = }  ifc$i3780_class,
       { 18 = }  ifc$i3270_class],

   iiv$downline_input_device_conv: [XDCL, READ, oss$job_paged_literal] array
     [ifc$keyboard_input .. ifc$block_mode_input] of iit$field_value :=
     [iic$keyboard_input, iic$block_mode_input],

{   iiv$upline_input_device_conv: [XDCL, READ, oss$job_paged_literal] array
{     [0 .. 1] of ift$input_devices := [ifc$keyboard_input, ifc$block_mode_input],

{   iiv$downline_output_device_conv: [XDCL, READ, oss$job_paged_literal] array
{     [ifc$display_output .. ifc$printer_output] of iit$field_value :=
{     [iic$display_output, iic$printer_output],

{   iiv$upline_output_device_conv: [XDCL, READ, oss$job_paged_literal] array
{     [iic$printer_output .. iic$display_output] of ift$output_devices :=
{     [ifc$printer_output, ifc$display_output],

   iiv$downline_parity_conv: [XDCL, READ, oss$job_paged_literal] array
     [ifc$zero_parity .. ifc$no_parity] of iit$field_value := [iic$zero_parity, iic$zero_parity,
     iic$even_parity, iic$no_parity, iic$ignore_parity],

    iiv$upline_parity_conv: [XDCL, READ, oss$job_paged_literal] array
      [iic$zero_parity .. iic$ignore_parity] of ift$parity :=
      [ifc$zero_parity, ifc$odd_parity, ifc$even_parity, ifc$no_parity, ifc$no_parity],

 {  iiv$downline_end_position_conv: [XDCL, READ, oss$job_paged_literal] array
{    [ifc$no_input_positioning .. ifc$cr_lf] of iit$field_value :=
{     [iic$no_input_positioning, iic$carriage_return, iic$line_feed, iic$cr_lf],

    iiv$upline_end_position_conv: [XDCL, READ, oss$job_paged_literal] array
     [iic$elp_none .. iic$elp_crslfs] of ift$end_line_positioning :=
      [ifc$elp_none, ifc$elp_crs, ifc$elp_lfs, ifc$elp_crslfs],

    iiv$upline_part_position_conv: [XDCL, READ, oss$job_paged_literal] array
     [iic$epp_none .. iic$epp_crslfs] of ift$end_partial_positioning :=
      [ifc$no_epp, ifc$epp_crs, ifc$epp_lfs, ifc$epp_crslfs],

    iiv$deflt_connection_attributes: [XDCL, READ, OSS$JOB_PAGED_LITERAL]
          iit$connection_attributes := [
      [2, ifc$nam_default], {attention_character_action}
      [0, ifc$nam_default], {break_key_action}
      [[4, '*EOI'], ifc$os_default], {end_of_information}
      [160, ifc$nam_default], {input_block_size}
      [ifc$normal_edit, ifc$nam_default], {input_editing_mode}
      [ifc$unsolicited_output, ifc$nam_default], {input_output_mode}
      [FALSE, ifc$os_default], {input_timeout}
      [1048575, ifc$os_default], {input_timeout_length}
      [TRUE, ifc$os_default], {input_timeout_purge}
      [FALSE, ifc$nam_default], {partial_char_forwarding}
      [':$LOCAL.OUTPUT.1               ', ifc$os_default], {prompt_file}
      [[0, 1], ifc$os_default], {prompt_file_identifier}
      [[3, ' ? '], ifc$os_default], {prompt_string}
      [FALSE, ifc$nam_default], {store_backspace_character}
      [FALSE, ifc$nam_default], {store_nuls_dels}
      [ifc$no_trans_char, ifc$nam_default], {trans_character_mode}
      [[2, $CHAR(0d(16)) CAT $CHAR(8D(16))], ifc$nam_default], {trans_forward_character}
      [ifc$no_trans_len, ifc$nam_default], {trans_length_mode}
      [2000, ifc$nam_default], {trans_message_length}
      [[2, $CHAR(0d(16)) CAT $CHAR(8D(16))], ifc$nam_default], {trans_terminate_character}
      [ifc$no_trans_timeout, ifc$nam_default], {trans_timeout_mode}
      [ifc$no_trans_protocol, ifc$nam_default]], {trans_protocol_mode}

    iiv$skeleton_term_char_string: [XDCL, READ, oss$job_paged_literal]
      iit$term_char_string := [[iic$fn_user_break_1, * ],
      [iic$fn_full_duplex, * ], [iic$fn_solicited_mode, * ], [iic$fn_input_device, * ],
      [iic$fn_special_editing, * ], [iic$fn_full_ascii, * ],
      [iic$fn_trans_input_mode, * ], [iic$fn_trans_delim_char_select, * ],
      [iic$fn_trans_input_type, * ], [iic$fn_trans_delim_count_most, * ],
      [iic$fn_trans_delim_count_least, * ], [iic$fn_trans_delim_timeout, * ],
      [iic$fn_trans_mode_delim_lock, * ], [iic$fn_trans_delim_character, * ],
      [iic$fn_trans_mode_delim_char, * ], [iic$fn_terminal_class, * ],
      [iic$fn_page_width, * ], [iic$fn_page_length, * ],
      [iic$fn_cancel_line_character, * ], [iic$fn_backspace_character, * ],
      [iic$fn_cr_delay_count, * ], [iic$fn_lf_delay_count, * ],
      [iic$fn_echoplex, * ], [iic$fn_hold_page, * ],
      [iic$fn_parity, * ], [iic$fn_network_cmd_character, * ],
      [iic$fn_end_block_character, * ], [iic$fn_eob_cursor_positioning, * ],
      [iic$fn_end_line_character, * ], [iic$fn_eol_cursor_positioning, * ],
      [iic$fn_input_flow_control, * ], [iic$fn_output_flow_control, * ],
      [iic$fn_lockout_unsolicited_msgs, * ], [iic$fn_pacer_prompting, * ],
      [iic$fn_output_device, * ], [iic$fn_pause_break_character, * ],
      [iic$fn_term_break_character, * ]],

   iiv$all_get_term_attributes: [XDCL, READ, oss$job_paged_literal]
     array [1 .. (ORD(ifc$max_connection_key) + 1)] of ift$get_connection_attribute := [
    [* , ifc$attention_character_action, *], [* , ifc$break_key_action, *],
    [* , ifc$end_of_information, *], [* , ifc$input_block_size, *],
    [* , ifc$input_editing_mode, *], [* , ifc$input_output_mode, *],
    [* , ifc$input_timeout, *], [* , ifc$input_timeout_length, *],
    [* , ifc$input_timeout_purge, *], [* , ifc$null_connection_attribute],
    [* , ifc$partial_char_forwarding, *], [* , ifc$prompt_file, *],
    [* , ifc$prompt_file_identifier, *], [* , ifc$prompt_string, *],
    [* , ifc$store_backspace_character, *], [* , ifc$store_nuls_dels, *],
    [* , ifc$trans_character_mode, *], [* , ifc$trans_forward_character, *],
    [* , ifc$trans_length_mode, *], [* , ifc$trans_message_length, *],
    [* , ifc$trans_terminate_character, *], [* , ifc$trans_timeout_mode, *],
    [* , ifc$trans_protocol_mode, *]],

   iiv$init_undefined_attributes: [XDCL, READ, oss$job_paged_literal]
     iit$connection_attributes :=
    [{ attention_character_action } [ * , ifc$undefined_attribute],
     { break_key_action           } [ * , ifc$undefined_attribute],
     { end_of_information         } [ * , ifc$undefined_attribute],
     { input_block_size           } [ * , ifc$undefined_attribute],
     { input_editing_mode         } [ * , ifc$undefined_attribute],
     { input_output_mode          } [ * , ifc$undefined_attribute],
     { input_timeout              } [ * , ifc$undefined_attribute],
     { input_timeout_length       } [ * , ifc$undefined_attribute],
     { input_timeout_purge        } [ * , ifc$undefined_attribute],
     { partial_char_forwarding    } [ * , ifc$undefined_attribute],
     { prompt_file                } [ * , ifc$undefined_attribute],
     { prompt_file_identifier     } [ * , ifc$undefined_attribute],
     { prompt_string              } [ * , ifc$undefined_attribute],
     { store_backspace_character  } [ * , ifc$undefined_attribute],
     { store_nuls_dels            } [ * , ifc$undefined_attribute],
     { trans_character_mode       } [ * , ifc$undefined_attribute],
     { trans_forward_character    } [ * , ifc$undefined_attribute],
     { trans_length_mode          } [ * , ifc$undefined_attribute],
     { trans_message_length       } [ * , ifc$undefined_attribute],
     { trans_terminate_character  } [ * , ifc$undefined_attribute],
     { trans_protocol_mode         } [ * , ifc$undefined_attribute],
     { trans_timeout_mode         } [ * , ifc$undefined_attribute]],

    iiv$control_char_descriptions: [XDCL, READ, oss$job_paged_literal]
      iit$control_char_descriptions := [
      [ifc$backspace_character, 'BACKSPACE_CHARACTER'],
      [ifc$cancel_line_character, 'CANCEL_LINE_CHARACTER'],
      [ifc$end_line_character, 'END_LINE_CHARACTER'],
      [ifc$network_command_character, 'NETWORK_COMMAND_CHARACTER'],
      [ifc$pause_break_character, 'PAUSE_BREAK_CHARACTER'],
      [ifc$terminate_break_character, 'TERMINATE_BREAK_CHARACTER']],

    iiv$term_char_change_count: [XDCL] integer := 0;

MODEND iim$job_pageable_variables;
*DECK DECK=IIM$MEMORY_LINK_ACCESS EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$memory_link_access;
?? TITLE := 'MODULE iim$memory_link_access' ??

?? PUSH (LISTEXT := OFF) ??
*copyc IFE$ERROR_CODES
*copyc IIK$KEYPOINTS
*copyc IIT$CONNECTION_DESCRIPTION
*copyc TMC$WAIT_TIMES
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIP$REPORT_STATUS_ERROR
*copyc IIV$INT_TASK_OPEN_FILE_COUNT
*copyc IIV$CONNECTION_DESC_PTR
*copyc PMP$LONG_TERM_WAIT
*copyc MLP$ADD_SENDER
*copyc MLP$CONFIRM_SEND
*copyc MLP$FORCE_SEND_MESSAGE
*copyc MLP$RECEIVE_MESSAGE
*copyc MLP$REGISTER_SIGNAL_HANDLER
*copyc MLP$SEND_MESSAGE
*copyc MLP$SIGN_OFF
*copyc MLP$SIGN_ON
*copyc OSP$SET_STATUS_ABNORMAL
?? POP ??

?? TITLE := 'Global Internal Type, Constant and Variable Declarations', EJECT
  ??

  TYPE
    iit$mli_status = set of mlt$status;


?? TITLE := 'PROCEDURE iip$sign_on', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$sign_on (VAR application_name:
    mlt$application_name;
    VAR status: ost$status);

{  PURPOSE:
{    The purpose of this procedure is to Sign On to the Memory Link.
{  DESIGN:
{    A MLP$SIGN_ON request specifying that a unique application name should be
{    created is issued to the Memory Link.
{


{ Sign On to the Memory Link.

  /sign_on_to_mli/
    WHILE TRUE DO
      {Note use of max_messages = 0, which allows mlc$max_in_transit messages to be in use
      mlp$sign_on (mlc$unique_name, 0, application_name, status);
      IF status.normal THEN
        EXIT /sign_on_to_mli/;
      ELSE
        IF status.condition IN $iit$mli_status [mlc$busy_interlock,
              mlc$ant_full, mlc$pool_buffer_not_avail] THEN
          pmp$long_term_wait (iic$user_time_delay, iic$user_time_delay);
        ELSE
          iip$report_status_error (status, 'sign_on');
          EXIT /sign_on_to_mli/;
        IFEND;
      IFEND;
    WHILEND /sign_on_to_mli/;

  PROCEND iip$sign_on;

?? TITLE := 'PROCEDURE iip$add_sender', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$add_sender (application_name:
    mlt$application_name;
    VAR status: ost$status);

{  PURPOSE:
{    The purpose of this procedure is to permit the Pass-On application to
{    send messages to the interactive task.
{  DESIGN:
{    A MLP$ADD_SENDER request for the Pass-On is issued to the Memory Link.
{

{ Permit Pass-On to send messages to us.

  /permit_pass_on_to_send/
    WHILE TRUE DO
      mlp$add_sender (application_name, iic$passon_application_name, status);
      IF status.normal THEN
        EXIT /permit_pass_on_to_send/;
      ELSE
        IF status.condition IN $iit$mli_status [mlc$busy_interlock] THEN
          pmp$long_term_wait (iic$user_time_delay, iic$user_time_delay);
        ELSE
          iip$report_status_error (status, 'add_sender');
          EXIT /permit_pass_on_to_send/;
        IFEND;
      IFEND;
    WHILEND /permit_pass_on_to_send/;

  PROCEND iip$add_sender;

?? TITLE := 'PROCEDURE iip$send_to_pass_on', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$send_to_pass_on (application_name:
    mlt$application_name;
        message_pointer: ^cell;
        message_length: mlt$message_length;
        message_type: mlt$arbitrary_info;
    VAR status: ost$status);

{  PURPOSE:
{    The purpose of this procedure is to send a message to the Pass-On.
{  DESIGN:
{    A MLP$SEND_MESSAGE to Pass-On request is issued to the Memory Link.
{    If the message is a CON/END/R a MLP$FORCE_SEND_MESSAGE is issued to
{    insure that the connection is ended (VLR--10/14/86--NV0J496).
{

    VAR
      lst: ost$status,
      msg: ^iit$output_supervisory_message;


    msg := message_pointer;
  /send_message_to_pass_on/
    WHILE TRUE DO

      IF msg^.message_type <> iic$sm_end_connection THEN
        mlp$send_message (application_name, message_type, NIL, message_pointer,
              message_length, iic$passon_application_name, status);
      ELSE
        mlp$force_send_message (application_name, message_type, NIL, message_pointer,
              message_length, iic$passon_application_name, status);
      IFEND;

      IF status.normal THEN
        EXIT /send_message_to_pass_on/;
      ELSE
        IF status.condition IN $iit$mli_status [mlc$busy_interlock,
              mlc$pool_buffer_not_avail, mlc$prior_msg_not_received,
              mlc$receive_list_full] THEN
            IF status.condition IN $iit$mli_status [mlc$busy_interlock,
                  mlc$pool_buffer_not_avail, mlc$receive_list_full] THEN
              pmp$long_term_wait (iic$user_time_delay, iic$user_time_delay);
            ELSE
              pmp$long_term_wait (tmc$infinite_wait, 4000);
            IFEND;
        ELSEIF status.condition IN $iit$mli_status [mlc$receiver_not_signed_on]
              THEN

{ assume disconnect

          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$connection_break_disconnect, '', status);
          EXIT /send_message_to_pass_on/;
        ELSE
          iip$report_status_error (status, 'send_message');
          EXIT /send_message_to_pass_on/;
        IFEND;
      IFEND;
    WHILEND /send_message_to_pass_on/;

  PROCEND iip$send_to_pass_on;

?? TITLE := 'PROCEDURE iip$receive_from_pass_on', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$receive_from_pass_on (application_name:
    mlt$application_name;
        buffer_pointer: ^cell;
        buffer_length: mlt$message_length;
    VAR message_length: mlt$message_length;
    VAR status: ost$status);

{  PURPOSE:
{    The purpose of this procedure is to receive a message from the Pass-On.
{  DESIGN:
{    - MLP$RECEIVE_MESSAGE from Pass-On requests are issued to the Memory Link
{      until a message is received.
{

    VAR
      lst: ost$status,
      sender_application_name: mlt$application_name,
      arbitrary_information: mlt$arbitrary_info;


  /receive_message_from_pass_on/
    WHILE TRUE DO
      mlp$receive_message (application_name, arbitrary_information, NIL,
            buffer_pointer, message_length, buffer_length, 0,
            sender_application_name, status);
      IF status.normal THEN
        EXIT /receive_message_from_pass_on/;
      ELSE
        IF status.condition IN $iit$mli_status [mlc$busy_interlock,
              mlc$receive_list_index_invalid] THEN
            IF status.condition IN $iit$mli_status [mlc$busy_interlock] THEN
              pmp$long_term_wait (iic$user_time_delay, iic$user_time_delay);
            ELSE
              pmp$long_term_wait (tmc$infinite_wait, 4000);
            IFEND;
        ELSE
          iip$report_status_error (status, 'receive_message');
          EXIT /receive_message_from_pass_on/;
        IFEND;
      IFEND;
    WHILEND /receive_message_from_pass_on/;

  PROCEND iip$receive_from_pass_on;

?? TITLE := 'PROCEDURE iip$confirm_send', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$confirm_send (application_name:
    mlt$application_name;
    VAR status: ost$status);

{  PURPOSE:
{    The purpose of this procedure is to determine whether or not a
{    a message can be sent to the Pass-On.
{  DESIGN:
{    A MLP$CONFIRM_SEND request for the Pass-On is issued to the Memory
{    Link.
{

  /confirm_send_to_pass_on/
    WHILE TRUE DO
      mlp$confirm_send (application_name, iic$passon_application_name, status);
      IF status.normal THEN
        EXIT /confirm_send_to_pass_on/;
      ELSE
        IF status.condition IN $iit$mli_status [mlc$busy_interlock,
              mlc$prior_msg_not_received, mlc$receive_list_full] THEN
          pmp$long_term_wait (iic$user_time_delay, iic$user_time_delay);
        ELSEIF status.condition IN $iit$mli_status [mlc$receiver_not_signed_on]
              THEN

{ assume disconnect

          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$connection_break_disconnect, '', status);
          EXIT /confirm_send_to_pass_on/;
        ELSE
          iip$report_status_error (status, 'confirm_send');
          EXIT /confirm_send_to_pass_on/;
        IFEND;
      IFEND;
    WHILEND /confirm_send_to_pass_on/;

  PROCEND iip$confirm_send;

?? TITLE := 'PROCEDURE iip$sign_off', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$sign_off (application_name: mlt$application_name;
    VAR status: ost$status);

{  PURPOSE:
{    The purpose of this procedure is to sign off from the Memory Link.
{  DESIGN:
{    A MLP$SIGN_OFF request is issued to the Memory Link.
{

  /sign_off_from_mli/
    WHILE TRUE DO
      mlp$sign_off (application_name, status);
      IF status.normal THEN
        EXIT /sign_off_from_mli/;
      ELSE
        IF status.condition IN $iit$mli_status [mlc$busy_interlock] THEN
          pmp$long_term_wait (iic$user_time_delay, iic$user_time_delay);
        ELSE
          iip$report_status_error (status, 'sign_off');
          EXIT /sign_off_from_mli/;
        IFEND;
      IFEND;
    WHILEND /sign_off_from_mli/;

  PROCEND iip$sign_off;

?? TITLE := 'PROCEDURE iip$register_handler', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$register_handler (application_name:
    mlt$application_name;
        handler: mlt$handler;
    VAR status: ost$status);

{  PURPOSE:
{    The purpose of this procedure is to register a signal handler for a
{    given application name.
{  DESIGN:
{    A MLP$REGISTER_SIGNAL_HANDLER request is issued to the memory link.
{

{ Permit Pass-On to send messages to us.

  /register_handler/
    WHILE TRUE DO
      mlp$register_signal_handler (application_name, handler, status);
      IF status.normal THEN
        EXIT /register_handler/;
      ELSE
        IF status.condition IN $iit$mli_status [mlc$busy_interlock] THEN
          pmp$long_term_wait (iic$user_time_delay, iic$user_time_delay);
        ELSE
          iip$report_status_error (status, 'register_handler');
          EXIT /register_handler/;
        IFEND;
      IFEND;
    WHILEND /register_handler/;

  PROCEND iip$register_handler;

MODEND iim$memory_link_access;
*DECK DECK=IIM$NAM_PASSOFF EXPAND=TRUE
MODULE iim$nam_passoff;
*copyc OSD$DEFAULT_PRAGMATS
?? TITLE := '  NOS/VE: IIM$NAM_PASSOFF ' ??
{
{  The purpose of this module is to sign_off the nam_passon from the
{    memory link.
{
?? PUSH (LISTEXT := ON) ??
*copyc ifd$machine_definition
*copyc iit$application_names_messages
*copyc MLP$SIGN_OFF

  PROCEDURE [XREF] initmli (i: integer);
?? POP ??

  VAR
    status: ost$status;

  PROGRAM nam_passoff;

    initmli (0);
    mlp$sign_off (iic$passon_application_name, status);
  PROCEND nam_passoff;
MODEND
*DECK DECK=IIM$NAM_PASSON EXPAND=TRUE
MODULE iim$nam_passon;
?? NEWTITLE := 'NOS/VE: IIM$NAM_PASSON ' ??
*copyc osd$default_pragmats

{ Select target operating system

*IF (wev$target_operating_system='NOS')
  ? VAR ifv$nos_be: boolean := false ?;
*ELSE
  ? VAR ifv$nos_be: boolean := true ?;
*IFEND

?? PUSH (LISTEXT := OFF) ??
*copyc ifd$machine_definition
  ?IF ifv$module_for_c180 = TRUE THEN
*copy ost$status
*copyc osv$task_private_heap
  ?ELSE
*copy ost$string

    TYPE
      ost$status_condition = 0 .. 999999;

    TYPE
      ost$status = record
        condition: mlt$status,
      recend;

  ?IFEND

  PROCEDURE [XREF {TS_gate} ] mlp$add_sender ALIAS 'mladds' (application_name:
    mlt$application_name;
    sender_name: mlt$application_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??

  PROCEDURE [XREF {TS_gate} ] mlp$confirm_send ALIAS 'mlconf'
    (application_name: mlt$application_name;
    destination_name: mlt$application_name;
    VAR status: ost$status);

  PROCEDURE [XREF {TS_gate} ] mlp$delete_sender ALIAS 'mldels'
    (application_name: mlt$application_name;
    sender_name: mlt$application_name;
    VAR status: ost$status);

  PROCEDURE [XREF {TS_gate} ] mlp$fetch_receive_list ALIAS 'mlferl'
    (application_name: mlt$application_name;
    sender_name: mlt$application_name;
    VAR receive_list: mlt$receive_list;
    VAR receive_count: mlt$receive_count;
    VAR status: ost$status);

  PROCEDURE [XREF {TS_gate} ] mlp$receive_message ALIAS 'mlrecm'
    (application_name: mlt$application_name;
    VAR arbitrary_info: mlt$arbitrary_info;
    signal: mlt$signal;
    message_area: mlt$message_ptr;
    VAR message_length: mlt$message_length;
    message_area_length: mlt$message_length;
    receive_index: mlt$receive_index;
    VAR sender_name: mlt$application_name;
    VAR status: ost$status);

  PROCEDURE [XREF {TS_gate} ] mlp$send_message ALIAS 'mlsendm'
    (application_name: mlt$application_name;
    arbitrary_info: mlt$arbitrary_info;
    signal: mlt$signal;
    message_area: mlt$message_ptr;
    message_length: mlt$message_length;
    destination_name: mlt$application_name;
    VAR status: ost$status);

  PROCEDURE [XREF {TS_gate} ] mlp$sign_off ALIAS 'mlsinof' (application_name:
    mlt$application_name;
    VAR status: ost$status);

  PROCEDURE [XREF {TS_gate} ] mlp$sign_on ALIAS 'mlsinon' (application_name:
    mlt$application_name;
    max_messages: mlt$max_messages;
    VAR unique_application_name: mlt$application_name;
    VAR status: ost$status);

  PROCEDURE [XREF] mmove (from,
        dest: ^cell;
        length: integer);

  PROCEDURE [XREF] getword (address: integer;
        word: ^cell);
?? POP ??
*copyc iit$application_names_messages
? IF ifv$nos_be = true THEN

  PROCEDURE [XREF] pause (time : integer);
?? SET(LIST:=OFF) ??
? ELSE
*copyc net#on
? IFEND
?? SET(LIST:=ON) ??

  TYPE
    iit$connection_states = (absentee_read, wait_connection, break_active,
      broken_connection, stopped, available_for_use, connection_ending,
      connection_hold, wait_init, shutdown_complete, terminate),
    iit$connection_state = set of iit$connection_states,
    iit$connection_currency = record
      connection_state: iit$connection_state,
      application_name_jm: mlt$application_name,
      front_queued_sm_ptr,
      back_queued_sm_ptr: ^iit$sm_queue,
      front_queued_data_ptr,
      back_queued_data_ptr: ^iit$data_queue,
    ? IF ifv$nos_be = false THEN
      unacknowledged_block_count: integer,
    ? IFEND
      block_number: iit$application_block_number,
    ? IF ifv$nos_be = false THEN
      application_block_limit: iit$application_block_limit,
    ? IFEND
      application_name_last_io: mlt$application_name,
      connection_end_pending: boolean,
    ? IF ifv$nos_be = true THEN
      ind_synch,
      ind_req_1qp : integer,
      connection_ext : tint$connection_ext,
      fet_6 : tint$fet_6,
      req_1qp : tint$req_1qp,
      synch_msg : tint$synch_msg,
      term_char : tint$term_char,
    ? IFEND
    recend,
    iit$sm_queue = record
      front,
      back: ^iit$sm_queue,
      application_name: mlt$application_name,
      msg: array [ * ] of iit$170_word,
    recend,
    iit$data_queue = record
      front,
      back: ^iit$data_queue,
      application_name: mlt$application_name,
      msg: array [ * ] of iit$170_word,
    recend,
    iit$mli_status = set of mlt$status,
    iit$ra_word_0 = packed record
      fill1: 0 .. 0ffffffffff(16),
      fill2: 0 .. 01f(16),
      cfo,
      idledown,
      pause,
      sw6,
      sw5,
      sw4,
      sw3,
      sw2,
      sw1: boolean,
      fill3: 0 .. 03f(16),
    recend,
    iit$passon_failure = (signon_failed, addspl_failed, waiting_exec,
      netdbg_failed, netstc_failed, downline_failure, arbinfo_failure,
      expected_sm, conend_failure, conreq1_failure, init_failure, shutdown,
      input_sm, okee_dokee, queued_sm_send, sm_send, no_space,
      queued_data_send, data_send, reject_failure, accept_failure,
      nosve_stop_interactive, bad_downline_sm, not_exec_neton, data_ibu,
    ? IF ifv$nos_be = true THEN
      char_type_failed, init_req_failed, break_req_failed,
      termin_failed, synch_sm_failed, term_class_failed,
    ? IFEND
      sm_ibu, exec_dead, error_logical);

  VAR
  ? IF ifv$nos_be = false THEN
    mlv$mli: [XREF] integer,
  ? IFEND
    abort_poll: boolean,
    receive_index: mlt$receive_index,
    receive_list: mlt$receive_list,
    receive_count: mlt$receive_count,
    all_shutdown: boolean,
    connection_number: iit$application_connection_num,
    cs: iit$connection_state,
    msg_displayed: boolean := FALSE,
    work_done: boolean,
    status: ost$status, {*** special defn of c170 code ***}
    mli_retry_status: iit$mli_status := $iit$mli_status [mlc$busy_interlock,
      mlc$pool_buffer_not_avail, mlc$prior_msg_not_received,
      mlc$receive_list_full, mlc$receive_list_index_invalid],
    mli_ignore_status: iit$mli_status := $iit$mli_status
      [mlc$dup_permits_ignored, mlc$msgs_from_sender_queued, mlc$ok,
      mlc$queued_msgs_lost, mlc$signal_failed_ignored,
      mlc$signal_to_c170_ignored],
    mli_fatal_status: iit$mli_status := $iit$mli_status [mlc$ant_full,
      mlc$bad_c170_parameter, mlc$c170_c170_illegal, mlc$illegal_function,
      mlc$max_msgs_too_large, mlc$max_signons_this_appl,
      mlc$max_signons_this_task, mlc$message_too_long, mlc$mli_internal_error,
      mlc$nosve_not_up, mlc$permit_list_full, mlc$receiver_name_syntax_error,
      mlc$sender_name_syntax_error, mlc$system_name_no_match,
      mlc$message_truncated, mlc$receiver_not_signed_on,
      mlc$sender_not_permitted, mlc$sender_not_signed_on],
    abort: iit$passon_failure := okee_dokee,
    length_returned: mlt$message_length,
    retry_count: INTEGER,
    nosve_application: mlt$application_name,
    msg: iit$general_message,
    nam_debug,
    passon_debug,
    mli_debug: boolean,
    check_operator: integer := 0,
    ra_word_0: iit$ra_word_0,
    comm_word: packed array [1 .. 60] of boolean,
    i,
    j: integer,
    signal_record: mlt$signal_record := [0, * , * ],
    signal: mlt$signal := ^signal_record,
    signal_180: mlt$signal,
    unique: mlt$application_name,
    arbinfo: mlt$arbitrary_info,
    posm: ^iit$output_supervisory_message,
    nam_application_name: iit$nam_application_name := [22, 5, 9, 1, 6, REP 5 of
      45],
    nam_status: integer,
    next_queued_sm_acn,
    next_queued_data_acn: integer := 0,
    queued_data_count,
    queued_sm_count: integer := 0,
    connection_currency: array [0 .. iic$passon_max_cn] of
      iit$connection_currency := [REP iic$passon_max_cn + 1 of
      [$iit$connection_state [available_for_use], mlc$null_name, NIL, NIL, NIL,
    ? IF ifv$nos_be = false THEN
      NIL, 0, 0, 0, mlc$null_name, FALSE]],
    ? ELSE
      NIL, 0, mlc$null_name, FALSE,
      0, 0, $tint$connection_ext[], [0,0,0,0,0,FALSE,FALSE,FALSE,FALSE,0],
      [REP 15 OF 0], [REP 10 OF 0], [0,0,0,0,0] ]],
    ? IFEND
    pacer_kludge_enabled: [XDCL] boolean := FALSE,
    hex_digits: string (16) := '0123456789ABCDEF';

  CONST
    iic$retry_count = 3,
    retry_limit = 60,
    ?IF ifv$module_for_c180 = TRUE THEN
      iic$mli_multiplier = 8,
    ?ELSE
      iic$mli_multiplier = 1,
    ?IFEND
    sm_available = 5,
    b_display = 2,
    terminate_if_abnormal = FALSE,
    job_dayfile = 3,
    iic$exec_acn = 0,
    long_pause = 42,
    short_pause = 5,
    iic$passon_max_cn = 400,
    data_available = 4;

  PROCEDURE [XREF] initmli (i: integer);
? IF ifv$nos_be = false THEN
?? SET(LIST:=OFF) ??
?  ELSE
?? NEWTITLE := '    Definitions for NOS/BE PASSON' ??
?? EJECT ??
CONST

{ status codes reported from 1QP }

  cint$termin_zro = 0,   { empty line
  cint$termin_loc = 1,   { autologout
  cint$termin_brk = 2,   { user break
  cint$termin_nuc = 3,   { new user
  cint$termin_ico = 5,   { input available
  cint$termin_oco = 6,   { output complete
  cint$termin_dis = 7,   { user back from disconnect

{ request codes for 1QP }

  cint$termout_brk = 2,  { confirm break
  cint$termout_nuc = 3,  { detach from muj
  cint$termout_ico = 5,  { request input
  cint$termout_oco = 6,  { wait output complete
  cint$termout_trm = 10, { request terminal characteristics

{ length of 1QP communication tables

  cint$out_length = iic$passon_max_cn,
  cint$in_length = cint$out_length+15,

{ message types for simulated synchronous upline sm's }

  cint$ssm_bi_mark_r = 1,
  cint$ssm_ctrl_char_n = 2,
  cint$ssm_ctrl_tcd_r = 3,

{ fraktions of sm_term_char_definitions }

  cint$frk1 = (iic$sm_term_char_definitions DIV 4096),
  cint$frk2 = ((iic$sm_term_char_definitions-4096*cint$frk1) DIV 256),
  cint$frk3 = ((iic$sm_term_char_definitions-4096*cint$frk1
              -256*cint$frk2) DIV 16),
  cint$frk4 = iic$sm_term_char_definitions-4096*cint$frk1
              -256*cint$frk2-16*cint$frk3;

TYPE

{ type of table elements }

  tint$user_id = 0 .. 0fff(16),
  tint$user_table_address = 0 .. 3ffff(16),
  tint$input_status = 0 .. 0fff(16),
  tint$output_request = 0 .. 0f(16),

{ 1QP communication tables TERMIN and TERMOUT }

  tint$com_tables = PACKED RECORD
    fill : 0 .. 0fffffffff(16),
    out_length : 0 .. 0fff(16),
    in_length : 0 .. 0fff(16),
    in_table : ARRAY[1..cint$in_length] OF tint$in_table,
    out_table : ARRAY[1..cint$out_length] OF tint$out_table,
  RECEND,

  tint$in_table = PACKED RECORD
    user_id : tint$user_id,
    fill : 0 .. 3ffff(16),
    user_table_address : tint$user_table_address,
    status : tint$input_status,
  RECEND,

  tint$out_table = PACKED RECORD
    user_id : tint$user_id,
    fill1 : 0 .. 3ffff(16),
    add : 0 .. 3ffff(16),
    fill2 : 0 .. 0ff(16),
    request : tint$output_request,
  RECEND,

{ extensions to table connection currency }

  tint$connection_exts = (autologout,connection_rejected,detached,detach_pend,
    force_parity,init_accept,init_req,input_available,input_req,input_suppress,
    input_trans,new_user,output_suppress,output_wait,term_char_req,user_break,
    user_break_akn,user_break_out,user_break_as,user_break_rel,user_break_sy,
    wait_int,idle_ind,shut_ind,trans_break),
  tint$connection_ext = SET OF tint$connection_exts,

  tint$fet_6 = PACKED RECORD
    user_id : tint$user_id,
    in_byte : 0 .. 3f(16),
    out_byte : 0 .. 3f(16),
    fill2 : 0 .. 0fff(16),
    char_code : 0 .. 3(16),
    unit_sep,
    format_effector,
    one_line,
    par_force : BOOLEAN,
    user_table_address : tint$user_table_address,
  RECEND,

  tint$req_1qp = PACKED ARRAY[1..15] OF 0 .. 0f(16),
  tint$synch_msg = PACKED ARRAY[1..10] OF 0 .. 3f(16),

  tint$term_char = PACKED RECORD
    page_length,
    page_width,
    page_wait,
    paper_mode,
    term_class : 0 .. 0fff(16),
  RECEND,

{ predefined upline supervisory messages }

  tint$con_req_r = RECORD                  { CON/REQ/R }
    header : iit$input_supervisory_header,
    data : tint$text_con_req_r,
    logname : tint$nve_user,
    b1,b2,b3,b4 : integer,
  RECEND,

  { tint$logfam is defined as 10 6 bit elements, only the left most 7  }
  { elements are used for the family name.  10 elements are defined to }
  { insure proper word alignment when this definition is aligned.      }
  tint$logfam = PACKED ARRAY[1..10] OF 0 .. 3f(16),

  tint$text_con_req_r = PACKED RECORD
    sm_typ : iit$supervisory_message_type,
    fill1 : 0 .. 0ff(16),
    acn : iit$application_connection_num,
    abl : 0 .. 7(16),
    fill2 : 0 .. 1fffff(16),
    tname : tint$logfam,
    a1,a2 : integer,
    logfam : aligned tint$logfam,
  RECEND,

  tint$predef_sm = PACKED RECORD
    header : iit$input_supervisory_header,
    data : tint$predef_sm_text,
  RECEND,

  tint$predef_sm_text = PACKED RECORD
    sm_typ : iit$supervisory_message_type,
    rc : 0 .. 0ff(16),
    acn : iit$application_connection_num,
    fill : 0 .. 0ffffff(16),
  RECEND,

{ predefined messages }

  tint$predef_msg = PACKED RECORD        { message to user }
    header : iit$output_data_block_header,
    data : tint$meldung,
  RECEND,

  tint$debug_request = PACKED RECORD
    header : iit$output_data_block_header,
    data : tint$debug,
  RECEND,

  tint$record_request = PACKED RECORD
    header : iit$output_data_block_header,
    data : tint$record,
  RECEND,

  tint$accept_msg = PACKED RECORD
    header : iit$output_data_block_header,
    data : tint$accept,
  RECEND,

  tint$nosve_msg = PACKED RECORD
    header : iit$output_data_block_header,
    data : tint$nosve,
  RECEND,

  tint$word_8_of_12 = PACKED RECORD
    obn : 0 .. 0fffffffff(16),
    unt : 0 .. 0ffffff(16),
  RECEND,

  tint$trans_break = PACKED RECORD
    header : iit$input_data_block_header,
    data : tint$word_8_of_12,
  RECEND,

  tint$meldung = ARRAY[1..6] OF tint$word_8_of_12,
  tint$debug = ARRAY[1..27] OF tint$word_8_of_12,
  tint$record = ARRAY[1..8] OF tint$word_8_of_12,
  tint$accept = ARRAY[1..3] OF tint$word_8_of_12,
  tint$nosve = ARRAY[1..4] OF tint$word_8_of_12,

  tint$nve_user = PACKED RECORD
    id : 0..3ffffffffff(16),
    nr_prm : 0..3ffff(16),
  RECEND,

{ synchronous downline sm of type 2

  tint$synch_out_sm = PACKED RECORD
    header : iit$output_data_block_header,
    data : PACKED ARRAY[1..240] OF 0 .. 0f(16),
  RECEND,

{ synchronous upline sm of type 2

  tint$synch_in_sm = PACKED RECORD
    header : iit$input_supervisory_header,
    data : PACKED ARRAY[1..152] OF 0 .. 0f(16),
  RECEND,

{ input/output data block for intercom

  tint$data_block = ARRAY[1..iic$max_block_length_in_words]
                    OF tint$170_ascii_word,

  tint$170_ascii_word = PACKED RECORD
    byte : PACKED ARRAY[0..4] OF 0 .. 0fff(16),
  RECEND,

  tint$input_data_message = RECORD
    header : iit$input_data_block_header,
    data : tint$data_block,
  RECEND,

  tint$output_data_message = RECORD
    header : iit$output_data_block_header,
    data : tint$data_block,
  RECEND;

  VAR

    nr_msg : integer := -1,
    analyst_user_id : tint$user_id,
    analyst_acn : iit$application_connection_num := 0,
    analyst_ig,
    analyst_id : tint$nve_user,
    end_counter : integer := 50,
    nr_of_users : integer := 0,
    dump_indicator, trace_mli,
    shut_last, shut_down,
    idle_last, idle_down : boolean,
    predef_asm : ARRAY[1..5] OF tint$predef_sm :=
      [[[3,0,0,1,FALSE,0,1],[iic$sm_connection_broken,1,0,0]]      {CON/CB/R   }
      ,[[3,0,0,1,FALSE,0,1],[iic$sm_connection_ended,0,0,0]]       {CON/END/N  }
      ,[[3,0,0,1,FALSE,0,1],[iic$sm_initialized_connection,0,0,0]] {FC/INIT/R  }
      ,[[3,0,0,1,FALSE,0,1],[iic$sm_interrupt_user,3,0,0]]         {INTR/USR/R }
      ,[[3,0,0,1,FALSE,0,1],[iic$sm_shutdown,0,0,1]]               {SHUT/INSD/R}
      ],
    con_req_r : tint$con_req_r :=                                  {CON/REQ/R  }
      [[3,0,0,1,FALSE,0,10],[iic$sm_connection_request,0,0,1,0,
        [45,45,45,45,45,45,45,00,00,00],0,0,
        [45,45,45,45,45,45,45,00,00,00]],[0,0],0,0,0,0],
    predef_ssm : ARRAY[1..2] OF tint$predef_sm :=
      [[[3,0,0,2,FALSE,0,2],[iic$sm_break_indication_mark,0,0,0]]  {BI/MARK/R  }
      ,[[3,0,0,2,FALSE,0,2],[iic$sm_define_term_char_n,0,0,0]]     {CTRL/CHAR/N}
      ],
    ctrl_tcd_r : tint$synch_in_sm := [[3,0,0,2,FALSE,0,76],        {CTRL/TCD/R }
      [cint$frk1,cint$frk2,cint$frk3,cint$frk4,
       3,3,0,0,5,7,0,0,7,0,0,0,3,5,0,0,3,0,0,0,3,7,0,0,3,4,0,0,3,8,0,1,
       4,6,0,0,3,9,0,1,3,10,0,1,3,12,0,0,9,2,0,0,3,11,0,13,4,5,0,13,
       2,2,0,0,2,3,0,0,2,4,0,0,2,6,1,8,2,7,0,8,2,12,0,0,2,13,0,0,
       3,1,0,0,2,5,0,0,3,2,0,2,2,8,1,11,4,0,0,4,4,2,0,3,3,13,0,13,
       3,15,0,2,4,3,0,0,4,4,0,0,2,0,0,0,6,6,0,0,3,6,0,0,2,10,0,0,2,11,0,0]],
    predef_msg : ARRAY[1..6] OF tint$predef_msg :=
      [[[2,0,1,3,0,FALSE,FALSE,FALSE,FALSE,30],        {TOO MANY USERS...}
       [[006001240117(8),01170040(8)],[011501010116(8),01310040(8)],
        [012501230105(8),01220123(8)],[005400400124(8),01220131(8)],
        [004001140101(8),01240105(8)],[012200400040(8),00400037(8)]]]
      ,[[2,0,1,3,0,FALSE,FALSE,FALSE,FALSE,30],        {CONNECTION TO VEIAF...}
       [[006001030117(8),01160116(8)],[010501030124(8),01110117(8)],
        [011600400124(8),01170040(8)],[012601050111(8),01010106(8)],
        [004001220105(8),01120105(8)],[010301240105(8),01040037(8)]]]
      ,[[2,0,1,3,0,FALSE,FALSE,FALSE,FALSE,30],        {YOU ARE NOT VALID...}
       [[006001310117(8),01250040(8)],[010101220105(8),00400116(8)],
        [011701240040(8),01260101(8)],[011401110104(8),01010124(8)],
        [010501040040(8),01170116(8)],[004001260105(8),00400037(8)]]]
      ,[[2,0,1,3,0,FALSE,FALSE,FALSE,FALSE,30],        {NVE IDLES DOWN...}
       [[006001160126(8),01050040(8)],[011101040114(8),01050123(8)],
        [004001040117(8),01270116(8)],[005400400120(8),01140123(8)],
        [004001140117(8),01070117(8)],[012501240037(8),00400057(8)]]]
      ,[[2,0,1,3,0,FALSE,FALSE,FALSE,FALSE,30],        {NO ACCESS PERM...}
       [[006001160117(8),00400101(8)],[010301030105(8),01230123(8)],
        [004001200105(8),01220115(8)],[011101240124(8),01050104(8)],
        [004001010124(8),00400124(8)],[011101150105(8),00400037(8)]]]
      ,[[2,0,1,3,0,FALSE,FALSE,FALSE,FALSE,30],        {NVE SHUT DOWN ...}
       [[006001160126(8),01050040(8)],[012301100125(8),01240104(8)],
        [011701270116(8),00400116(8)],[011701270040(8),00410041(8)],
        [004100400040(8),00370040(8)],[003700400040(8),00400037(8)]]]
      ],
    debug_request : tint$debug_request :=
      [[2,0,1,3,0,FALSE,FALSE,FALSE,FALSE,133],        {DEBUG HELP WANTED ...}
      [[006001040105(8),01020125(8)],[010701100105(8),01140120(8)],
       [004001270101(8),01160124(8)],[010501040077(8),00370040(8)],
       [010501160124(8),01050122(8)],[004001230124(8),01220111(8)],
       [011601070040(8),01170106(8)],[004001040111(8),01070124(8)],
       [012300400061(8),00400124(8)],[011700400064(8),00400037(8)],
       [004000610040(8),01230101(8)],[012601050040(8),01150105(8)],
       [012301230101(8),01070105(8)],[012300370040(8),00620040(8)],
       [010401110123(8),01200114(8)],[010101310040(8),01150105(8)],
       [012301230101(8),01070105(8)],[004001240131(8),01200105(8)],
       [003700400063(8),00400104(8)],[011101230120(8),01140101(8)],
       [013100400115(8),01050115(8)],[011701220131(8),01140111(8)],
       [011601130037(8),00400064(8)],[004001040125(8),01150120(8)],
       [004001010124(8),00400105(8)],[012201220117(8),01220037(8)],
       [004000570037(8),00000000(8)]]],
    record_request : tint$record_request :=
      [[2,0,1,3,0,FALSE,FALSE,FALSE,FALSE,36],         {HOW MANY MESSAGES ...}
      [[006001100117(8),01270040(8)],[011501010116(8),01310040(8)],
       [011501050123(8),01230101(8)],[010701050123(8),00400104(8)],
       [011700400131(8),01170125(8)],[004001270101(8),01160124(8)],
       [004000770037(8),00400057(8)],[003700000000(8),00000000(8)]]],
    accept_msg : tint$accept_msg :=
      [[2,0,1,3,0,FALSE,FALSE,FALSE,FALSE,13],         {ACCEPTED             }
      [[004001010103(8),01030105(8)],[012001240105(8),01040037(8)],
       [004000570037(8),00000000(8)]]],
    nosve_msg : tint$nosve_msg :=
      [[2,0,1,3,0,FALSE,FALSE,FALSE,FALSE,17],         {NOSVE IS NOT UP      }
      [[004001160117(8),01230126(8)],[010500400111(8),01230040(8)],
       [011601170124(8),00400125(8)],[012000370000(8),00000000(8)]]],
    trans_break_msg : tint$trans_break :=
      [[2,0,1,3,FALSE,0,TRUE,FALSE,FALSE,5],           {user break           }
       [002000150000(8),00000000(8)]],
    class_table : ARRAY[0..31] OF integer :=
      [2,2,2,2,2,2,2,2,10,11,2,2,2,2,2,2,16,17,9,2,2,2,2,17,2,2,2,2,2,2,2,2],
    com : tint$com_tables := [0, cint$out_length, cint$in_length,
      [REP cint$in_length OF [0,0,0,0]], [REP cint$out_length OF [0,0,0,0,0]]];
?? OLDTITLE ??
?? NEWTITLE := '   COMPASS procedures for NOS/BE PASSON' ??
?? EJECT ??
PROCEDURE [XREF] ciord (fwa,ptr : ^CELL;    { call CIO to read from terminal }
                        VAR length : iit$text_length;
                        VAR error  : integer);

PROCEDURE [XREF] ciowr (fwa,ptr : ^CELL;    { call CIO to write to terminal }
                        length : integer;
                        VAR  error  : integer);

PROCEDURE [XREF] clfield (ptr : ^CELL;      { clear a field }
                          length : integer);

PROCEDURE [XREF] callmuj (ptr : ^CELL);     { call PP-program MUJ }

PROCEDURE [XREF] connct;                    { connect file ZZZZZSG to INTERCOM }

PROCEDURE [XREF] discon;                    { disconnect file ZZZZZSG from INTERCOM }

PROCEDURE [XREF] dumpen (i : integer;       { abort the program }
                         k : iit$passon_failure);

PROCEDURE [XREF] getveid (ptr : ^CELL;      { get NOSVE validation }
                          ptr : ^CELL;
                          us : tint$user_id;
                          VAR error : integer);

PROCEDURE [XREF] put1qp (                   { place 1qp-request into TERMOUT }
                         table,address : ^CELL;
                         cus : tint$user_id;
                         req : tint$output_request);

PROCEDURE [XREF] request (ordinal:integer); { request permanent file disk }

PROCEDURE [XREF] savemem (ordinal:integer;  { save variable-field for debugging
                          pt1,pt2,pt3 : ^CELL);

PROCEDURE [XREF] savemsg (ptr : ^CELL;      { save messages for debugging }
                          lng,dir : integer);

PROCEDURE [XREF] setup (ptr : ^CELL;        { get user-id of analyst }
                        VAR indicator : integer;
                        pt1,pt2,pt3 : ^CELL);
?? OLDTITLE ??
?? NEWTITLE := '    procedure analyst_action' ??
?? EJECT ??
PROCEDURE analyst_action (fwa : ^tint$input_data_message;
                          VAR ind : integer);
  VAR
    file_nr,
    lng,
    byte,
    n1,n2,n3,
    i,k : integer;

  ind := 0;
  lng := fwa^.header.text_length;
  IF lng < 9 THEN
     RETURN;
  IFEND;
  FOR i := 0 TO 4 DO
    IF fwa^.data[1].byte[i] <> 44(8) THEN
       RETURN;
    IFEND;
  FOREND;
  IF fwa^.data[2].byte[0] <> 054(8) THEN
     RETURN;
  IFEND;
  n1 := fwa^.data[2].byte[1] MOD 200(8);
  IF n1 > 140(8) THEN
     n1 := n1 - 40(8);
  IFEND;
  n2 := fwa^.data[2].byte[2] MOD 200(8);
  IF n2 > 140(8) THEN
     n2 := n2 - 40(8);
  IFEND;
  n3 := fwa^.data[2].byte[3] MOD 200(8);
  IF n3 > 140(8) THEN
     n3 := n3 - 40(8);
  IFEND;
  IF n1 = 104(8) THEN
     IF n2 = 115(8) THEN
        IF n3 = 120(8) THEN
           IF lng < 11 THEN
              RETURN;
           IFEND;
           IF fwa^.data[2].byte[4] = 054(8) THEN
              byte := fwa^.data[3].byte[0] - 60(8);
              IF (byte < 0) OR (byte > 9) THEN
                 RETURN;
              ELSE
                 ind := 1;
                 IF byte = 0 THEN
                    IF nam_debug AND (nr_msg >= 0) THEN
                       savemsg (#LOC(msg),-1,0);
                       nr_msg := -1;
                       nam_debug := false;
                    ELSE
                       RETURN;
                    IFEND;
                 ELSE
                    file_nr := byte + 33(8);
                    request (file_nr);
                    savemem (file_nr,#LOC(msg),
                             #LOC(connection_currency[0]),#LOC(com));
                 IFEND;
              IFEND;
           IFEND;
        IFEND;
     IFEND;
  IFEND;
  IF n1 = 115(8) THEN
     IF n2 = 123(8) THEN
        IF n3 = 107(8) THEN
           ind := 1;
           IF (NOT nam_debug) AND (nr_msg < 0) THEN
              nam_debug := true;
              nr_msg := 2000;
           IFEND;
        IFEND;
     IFEND;
  IFEND;
  IF ind = 1 THEN
     send_data (analyst_acn,#LOC(accept_msg));
     downline_sm (analyst_acn,cint$termout_ico);
  IFEND;
PROCEND analyst_action;
?? OLDTITLE ??
?? NEWTITLE := '    procedure connection_tour' ??
?? EJECT ??
{  The purpose of this procedure is to check and update the states of the
{    connections as described by the sets connection_state and connection_
{    _ext of table connection_currency. If required the procedure forms
{    and sends upline supervisory messages to IF. Downline supervisory mes=
{    sages are replaced by 1QP-requests, which are put into the 1QP-queue,
{    which is also updated by connection_tour.
{
PROCEDURE connection_tour;

  VAR

    connection_ext : tint$connection_ext,
    itr : ^integer,
    ptr : ^tint$term_char,
    qtr : ^tint$out_table,
    acn : iit$application_connection_num,
    request : tint$output_request,
    output_user_id,
    connect_user_id : tint$user_id,
    connect_user_table : tint$user_table_address,
    ind,
    error,
    lng,
    ind_synch,
    req_1qp,
    i,k : integer;

  acn := 0;
  /check_connection_currency/
  FOR i := 1 TO iic$passon_max_cn DO
    acn := acn + 1;
    connect_user_id := connection_currency[i].fet_6.user_id;
    /check_user_id_zero/
    BEGIN
    IF connect_user_id <> 0 THEN
       connect_user_table := connection_currency[i].fet_6.user_table_address;
{
{      check for queued 1QP-requests
{
       req_1qp := connection_currency[i].ind_req_1qp;
       output_user_id := com.out_table[i].user_id;
       IF (output_user_id = 0) AND (req_1qp <> 0) THEN
          request := connection_currency[i].req_1qp[1];
          ptr := ^connection_currency[i].term_char;
          qtr := ^com.out_table[i];
          put1qp (qtr,ptr,connect_user_id,request);
          IF request = cint$termout_nuc THEN
             connection_currency[i].connection_ext :=
                        connection_currency[i].connection_ext
                      + $tint$connection_ext[detached];
          ELSEIF request = cint$termout_brk THEN
             connection_currency[i].connection_ext :=
                        connection_currency[i].connection_ext
                      + $tint$connection_ext[user_break_rel];
          IFEND;
          /pop_up_req_1qp/
          FOR k := 1 TO req_1qp-1 DO
            connection_currency[i].req_1qp[k] :=
                       connection_currency[i].req_1qp[k+1];
          FOREND /pop_up_req_1qp/;
          connection_currency[i].req_1qp[req_1qp] := 0;
          connection_currency[i].ind_req_1qp := req_1qp - 1;
       IFEND;
       connection_ext := connection_currency[i].connection_ext;
?? NEWTITLE := '    process user break' ??
?? EJECT ??
{
{  check break aknowledge accepted by intercom
{
IF ((user_break_rel IN connection_ext)
   AND NOT (trans_break IN connection_ext)) THEN
   output_user_id := com.out_table[i].user_id;
   IF output_user_id = 0 THEN
      connection_currency[i].connection_ext :=
                 connection_currency[i].connection_ext
               - $tint$connection_ext[user_break_rel,input_available,
                 user_break_out,input_req,input_suppress,output_suppress];
      connection_ext := connection_currency[i].connection_ext;
   ELSE
      CYCLE /check_connection_currency/;
   IFEND;
IFEND;
{
{  check for user break
{
IF user_break IN connection_ext THEN
   predef_asm[4].data.acn := acn;
   modify_upline_connection_status (#LOC(predef_asm[4]),abort); {INTR/USR/R}
   IF abort <> okee_dokee THEN
      set_passon_abnormal (abort);
      IF abort <> okee_dokee THEN
         RETURN;
      IFEND;
   IFEND;
   connection_currency[i].connection_ext := connection_ext
            - $tint$connection_ext[user_break]
            + $tint$connection_ext[user_break_as,user_break_sy];
   ind_synch := connection_currency[i].ind_synch + 1;
   connection_currency[i].synch_msg[ind_synch] := cint$ssm_bi_mark_r;
   connection_currency[acn].ind_synch := ind_synch;
   CYCLE /check_connection_currency/;
IFEND;
{
{  check break aknowledge accepted by NOSVE
{
IF (user_break_akn IN connection_ext) AND
   (user_break_out IN connection_ext) THEN
   connection_currency[i].connection_ext := connection_ext
            - $tint$connection_ext[user_break_akn];
   downline_sm (acn,cint$termout_brk);
   CYCLE /check_connection_currency/;
IFEND;
?? OLDTITLE ??
?? NEWTITLE := '    process request for new user and term characteristics' ??
?? EJECT ??
{
{  check for new user
{
IF new_user IN connection_ext THEN
   nr_of_users := nr_of_users + 1;
   IF (i = iic$passon_max_cn) OR idle_down THEN
      k := 1;
      IF idle_down THEN k := 5; IFEND;
      predef_msg[k].header.connection_number := acn;
      send_data (acn,#LOC(predef_msg[k]));
      connection_currency[i].connection_ext :=
                 $tint$connection_ext[detach_pend];
   ELSE
      connection_currency[i].connection_ext := connection_ext
               - $tint$connection_ext[new_user]
               + $tint$connection_ext[term_char_req];
      connection_currency[i].term_char.term_class := 0;
      downline_sm (acn,cint$termout_trm);
      end_counter := 50;
      CYCLE /check_connection_currency/;
   IFEND;
IFEND;
{
{  request connection
{
IF term_char_req IN connection_ext THEN
   IF connection_currency[i].term_char.term_class <> 0 THEN
      getveid (#LOC(con_req_r.logname),#LOC(con_req_r.data.logfam),
               connect_user_id,error);
      IF error <> 0 THEN
         IF error = 1 THEN
            predef_msg[3].header.connection_number := acn;
            send_data (acn,#LOC(predef_msg[3]));
            connection_currency[i].connection_ext := connection_ext
                     - $tint$connection_ext[term_char_req]
                     + $tint$connection_ext[detach_pend];
         IFEND;
         CYCLE /check_connection_currency/;
      IFEND;
      connection_currency[i].connection_ext := connection_ext
               - $tint$connection_ext[term_char_req];
      con_req_r.data.acn := acn;
      modify_upline_connection_status (#LOC(con_req_r),abort);   { CON/REQ/R }
      IF abort <> okee_dokee THEN
         set_passon_abnormal (abort);
         IF abort <> okee_dokee THEN
            RETURN;
         IFEND;
      IFEND;
      IF (con_req_r.logname.id=analyst_id.id) AND (analyst_acn=0) THEN
         analyst_acn := i;
         analyst_user_id := connection_currency[i].fet_6.user_id;
         accept_msg.header.connection_number := acn;
      IFEND;
   IFEND;
   CYCLE /check_connection_currency/;
IFEND;
?? OLDTITLE ??
?? NEWTITLE := '    process connection accepted and initialized' ??
?? EJECT ??
{
{  check connection accepted
{
IF wait_int IN connection_ext THEN
   predef_asm[3].data.acn := acn;      { FC/INIT/R }
   modify_upline_connection_status (#LOC(predef_asm[3]),abort);
   IF abort <> okee_dokee THEN
      set_passon_abnormal (abort);
      IF abort <> okee_dokee THEN
         RETURN;
      IFEND;
   IFEND;
   connection_currency[i].connection_ext := connection_ext
            - $tint$connection_ext[wait_int]
            + $tint$connection_ext[init_req];
   CYCLE /check_connection_currency/;
IFEND;
{
{  check connection initialized
{
IF init_accept IN connection_ext THEN
   connection_currency[i].connection_ext := $tint$connection_ext[];
   downline_sm (acn,cint$termout_ico);
   CYCLE /check_connection_currency/;
IFEND;
?? OLDTITLE ??
?? NEWTITLE := '    process idle down and shut down' ??
?? EJECT ??
{
{  check for idle down
{
IF idle_last AND (idle_ind IN connection_ext) THEN
   IF connection_ext*$tint$connection_ext[new_user,output_suppress,
      detached,detach_pend,connection_rejected] = $tint$connection_ext[] THEN
      predef_msg[4].header.connection_number := acn;
      send_data (acn,#LOC(predef_msg[4]));
      connection_currency[i].connection_ext := connection_ext
               - $tint$connection_ext[idle_ind];
      CYCLE /check_connection_currency/;
   IFEND;
IFEND;
{
{  check for shut down
{
IF shut_last AND (shut_ind IN connection_ext) THEN
   req_1qp := connection_currency[i].ind_req_1qp;
   IF (connection_ext*$tint$connection_ext[new_user,output_suppress,idle_ind,
      detached,detach_pend,connection_rejected] = $tint$connection_ext[])
                                                        AND (req_1qp = 0) THEN
      predef_msg[4].header.connection_number := acn;
      send_data (acn,#LOC(predef_msg[6]));
      connection_currency[i].connection_ext := $tint$connection_ext[];
      predef_asm[1].data.acn := acn;
      modify_upline_connection_status (#LOC(predef_asm[1]),abort);  {CON/CB/R}
      CYCLE /check_connection_currency/;
   IFEND;
IFEND;
?? OLDTITLE ??
?? NEWTITLE := '    process detach, detach pending and autologout' ??
?? EJECT ??
{
{  check detach pending
{
IF detach_pend IN connection_ext THEN
   connection_currency[i].connection_ext := connection_ext
            - $tint$connection_ext[detach_pend];
   downline_sm (acn,cint$termout_nuc);
   connection_ext := connection_currency[acn].connection_ext;
IFEND;
{
{  check user detached
{
output_user_id := com.out_table[i].user_id;
IF (detached IN connection_ext) AND (output_user_id = 0) THEN
   IF connection_currency[i].ind_req_1qp = 0 THEN
      nr_of_users := nr_of_users - 1;
      clfield (#LOC(connection_currency[i].block_number),10);
      connection_currency[i].connection_state :=
                 $iit$connection_state[available_for_use];
   IFEND;
   CYCLE /check_connection_currency/;
IFEND;
{
{  check autologout
{
IF autologout IN connection_ext THEN
   req_1qp := connection_currency[i].ind_req_1qp;
   IF req_1qp <> 0 THEN
      FOR k := 1 TO req_1qp DO
         connection_currency[i].req_1qp[k] := 0;
      FOREND;
      connection_currency[i].ind_req_1qp := 0;
   IFEND;
   connection_currency[i].connection_ext := $tint$connection_ext[];
   predef_asm[1].data.acn := acn;
   modify_upline_connection_status (#LOC(predef_asm[1]),abort);     {CON/CB/R}
   IF abort <> okee_dokee THEN
      set_passon_abnormal (abort);
      IF abort <> okee_dokee THEN
         RETURN;
      IFEND;
   IFEND;
   CYCLE /check_connection_currency/;
IFEND;
?? OLDTITLE ??
?? NEWTITLE := '    process connection end and reject' ??
?? EJECT ??
{
{  check connection end
{
IF connection_ending IN connection_currency[i].connection_state THEN
   IF connection_currency[i].ind_req_1qp = 0 THEN
      nr_of_users := nr_of_users - 1;
      downline_sm (acn,cint$termout_nuc);
      clfield (#LOC(connection_currency[i].block_number),10);
   ELSE
      connection_currency[i].connection_ext := connection_ext
               + $tint$connection_ext[detach_pend];
   IFEND;
   predef_asm[2].data.acn := acn;
   modify_upline_connection_status (#LOC(predef_asm[2]),abort);  { CON/END/N }
   IF abort <> okee_dokee THEN
      set_passon_abnormal (abort);
      IF abort <> okee_dokee THEN
         RETURN;
      IFEND;
   IFEND;
   CYCLE /check_connection_currency/;
IFEND;
{
{  check connection rejected
{
IF connection_rejected IN connection_ext THEN
   predef_msg[2].header.connection_number := acn;
   send_data (acn,#LOC(predef_msg[2]));
   connection_currency[i].connection_ext := connection_ext
            - $tint$connection_ext[connection_rejected]
            + $tint$connection_ext[detach_pend];
   CYCLE /check_connection_currency/;
IFEND;
?? OLDTITLE ??
?? NEWTITLE := '    process absentee reads' ??
?? EJECT ??
       IF (absentee_read IN connection_currency[i].connection_state) AND
          NOT (input_suppress IN connection_ext) THEN
          ind_synch := connection_currency[acn].ind_synch;
          IF ind_synch <> 0 THEN
             synch_upline_sm (#LOC(msg),acn,lng);
             send_upline_data (#LOC(msg),lng,acn,nosve_application,abort);
          ELSE
             IF trans_break IN connection_ext THEN
                output_user_id := com.out_table[i].user_id;
                IF (output_user_id = 0) AND
                   (user_break_rel IN connection_ext) THEN
                   trans_break_msg.header.connection_number := acn;
                   mmove (#LOC(trans_break_msg),#LOC(msg),2);
                   poll_for_absentee_reads (#LOC(msg),abort);
                   connection_currency[i].connection_ext := connection_ext
                             -$tint$connection_ext[user_break_rel,trans_break,
                                                   input_available,input_req];
                ELSE
                   CYCLE /check_connection_currency/;
                IFEND;
             ELSEIF input_available IN connection_ext THEN
                read_data (acn,#LOC(msg));
                connection_currency[i].connection_ext := connection_ext
                         - $tint$connection_ext[input_available];
                IF acn = analyst_acn THEN
                   analyst_action (#LOC(msg),ind);
                   IF ind = 1 THEN
                      CYCLE /check_connection_currency/;
                   IFEND;
                IFEND;
                poll_for_absentee_reads (#LOC(msg),abort);
             ELSE
                CYCLE /check_connection_currency/;
             IFEND;
          IFEND;
          IF abort <> okee_dokee THEN
             set_passon_abnormal (abort);
             IF abort <> okee_dokee THEN
                RETURN;
             IFEND;
          IFEND;
       IFEND;
    IFEND;
    END /check_user_id_zero/;
  FOREND /check_connection_currency/;
PROCEND connection_tour;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := '    procedure downline_sm' ??
?? EJECT ??
{  The purpose of this procedure is to set up and put a 1QP-request into table
{    TERMOUT or to queue the request in array req_1qp of connection_currency
{    if the related slot in TERMOUT is not zero. Related pointers are updated.
{
PROCEDURE downline_sm (acn : iit$application_connection_num;
                       output_request : tint$output_request);
  VAR
    request : tint$output_request,
    con_user_id,
    tab_user_id : tint$user_id,
    ptr : ^tint$term_char,
    qtr : ^tint$out_table,
    parm_put : boolean,
    i,req : integer;

  IF output_request = cint$termout_ico THEN
     IF input_req IN connection_currency[acn].connection_ext THEN
        RETURN;
     ELSE
        connection_currency[acn].connection_ext :=
                   connection_currency[acn].connection_ext
                 + $tint$connection_ext[input_req];
     IFEND;
  IFEND;
  tab_user_id := com.out_table[acn].user_id;
  parm_put := false;
  IF tab_user_id = 0 THEN
     req := connection_currency[acn].ind_req_1qp;
     con_user_id := connection_currency[acn].fet_6.user_id;
     qtr := ^com.out_table[acn];
     ptr := ^connection_currency[acn].term_char;
     IF req <> 0 THEN
        request := connection_currency[acn].req_1qp[1];
        /pop_1qp_requests/
        FOR i := 1 TO req-1 DO
            connection_currency[acn].req_1qp[i] :=
                       connection_currency[acn].req_1qp[i+1];
        FOREND /pop_1qp_requests/;
        connection_currency[acn].req_1qp[req] := 0;
        connection_currency[acn].ind_req_1qp := req - 1;
     ELSE
        parm_put := true;
        request := output_request;
     IFEND;
     put1qp (qtr,ptr,con_user_id,request);
     IF request = cint$termout_brk THEN
        connection_currency[acn].connection_ext :=
                   connection_currency[acn].connection_ext
                 + $tint$connection_ext[user_break_rel];
     ELSEIF request = cint$termout_nuc THEN
        connection_currency[acn].connection_ext :=
                   connection_currency[acn].connection_ext
                 + $tint$connection_ext[detached];
     IFEND;
  IFEND;
  IF NOT parm_put THEN
     req := connection_currency[acn].ind_req_1qp + 1;
     IF req = 16 THEN
        RETURN;
     ELSE
        connection_currency[acn].req_1qp[req] := output_request;
     IFEND;
     connection_currency[acn].ind_req_1qp := req;
  IFEND;
  RETURN;
PROCEND downline_sm;
?? OLDTITLE ??
?? NEWTITLE := '    procedure dump_mem' ??
?? EJECT ??
{  The purpose of this procedure is to close a existing trace file and
{    to generate a mode 0 error, which abort PASSON and causes the system
{    to produce a dump of the memory.
{
PROCEDURE dump_mem (nn : integer; ab : iit$passon_failure);

  IF nam_debug AND (nr_msg>0) THEN
     savemsg (#LOC(msg),-1,0);
     nr_msg := -100;
  IFEND;
  dumpen (nn,ab);
PROCEND dump_mem;
?? OLDTITLE ??
?? NEWTITLE := '    procedure get_debug_directives' ??
?? EJECT ??
{  The purpose of this procedure is to receive debug directives from the
{    systems analyst via terminal type-ins
{
PROCEDURE get_debug_directives (fwa : ^tint$input_data_message);

  VAR
    byte,
    i,k,lng : integer,
    error : integer,
    acn : iit$application_connection_num,
    get_user_id : tint$user_id,
    user_table : tint$user_table_address;

  acn := 1;
  nr_msg := -2;
  ra_word_0.sw1 := false;
  ra_word_0.sw2 := false;
  ra_word_0.sw3 := false;
  ra_word_0.sw4 := false;
  ra_word_0.sw5 := false;
  ra_word_0.sw6 := false;

  /search_site_analyst/
  BEGIN
  FOR k := 1 TO 20 DO
    FOR i := 1 TO cint$in_length DO
      get_user_id := com.in_table[i].user_id;
      IF get_user_id <> 0 THEN
         user_table := com.in_table[i].user_table_address;
         EXIT /search_site_analyst/;
      IFEND;
    FOREND;
    pause (long_pause);
  FOREND;
  RETURN;
  END /search_site_analyst/;

  error := -1;
  WHILE error < 0 DO
    getveid (#LOC(analyst_ig),#LOC(con_req_r.data.logfam),get_user_id,error);
    pause (short_pause);
  WHILEND;
  IF (error=0) AND (analyst_ig.id=analyst_id.id) THEN
     connection_currency[acn].fet_6.user_id := get_user_id;
     connection_currency[acn].fet_6.user_table_address := user_table;
     get_debug_data (acn,#LOC(debug_request),fwa,lng);
     IF lng = 0 THEN
        RETURN;
     ELSE
        lng := lng - 1;
        IF lng > 3 THEN
           lng := 3;
        IFEND;
        FOR i := 0 TO lng DO
          byte := fwa^.data[1].byte[i];
          IF byte = 61(8) THEN
             ra_word_0.sw1 := true;
          ELSEIF byte = 62(8) THEN
             ra_word_0.sw2 := true;
          ELSEIF byte = 63(8) THEN
             ra_word_0.sw3 := true;
          ELSEIF byte = 64(8) THEN
             ra_word_0.sw4 := true;
          IFEND;
        FOREND;
     IFEND;
  ELSE
     RETURN;
  IFEND;
  IF ra_word_0.sw1 THEN
     get_debug_data (acn,#LOC(record_request),fwa,lng);
     /get_nr_msg/
     BEGIN
       IF lng = 0 THEN
          nr_msg := 1000;
          EXIT /get_nr_msg/;
       ELSE
          nr_msg := 0;
          lng := lng - 1;
          IF lng > 4 THEN
             lng := 4;
          IFEND;
       IFEND;
       FOR i := 0 TO lng DO
         byte := fwa^.data[1].byte[i] - 60(8);
         IF (byte>=0) AND (byte<10) THEN
            nr_msg := 10*nr_msg + byte;
         IFEND;
       FOREND;
       IF nr_msg = 0 THEN
          nr_msg := 1000;
       IFEND;
     END /get_nr_msg/;
     request (33(8));
  IFEND;
  connection_currency[acn].fet_6.user_id := 0;
  connection_currency[acn].fet_6.user_table_address := 0;
PROCEND get_debug_directives;
?? OLDTITLE ??
?? NEWTITLE := '    procedure get_debug_data' ??
?? EJECT ??
PROCEDURE get_debug_data (acn :  iit$application_connection_num;
                          msg : ^tint$output_data_message;
                          fwa : ^tint$input_data_message; VAR lng : integer);
  VAR
    i : integer,
    user_it,
    user_id : tint$user_id,
    status : tint$input_status;

  user_id := connection_currency[acn].fet_6.user_id;
  msg^.header.connection_number := acn;
  send_data (acn,msg);
  downline_sm (acn,cint$termout_ico);
  /wait_request_accepted/
  WHILE true DO
    user_it := com.out_table[acn].user_id;
    IF user_it = 0 THEN
       EXIT /wait_request_accepted/;
    IFEND;
    pause (short_pause);
  WHILEND /wait_request_accepted/;
  connection_currency[acn].connection_ext := $tint$connection_ext[];
  /wait_debug_directive/
  WHILE true DO
    FOR i := 1 TO cint$in_length DO
      user_it := com.in_table[i].user_id;
      IF user_it = user_id THEN
         status := com.in_table[i].status;
         IF status = cint$termin_ico THEN
            com.in_table[i].user_table_address := 0;
            com.in_table[i].status := 0;
            com.in_table[i].user_id := 0;
            EXIT /wait_debug_directive/;
         IFEND;
      IFEND;
    FOREND;
    pause (short_pause);
  WHILEND /wait_debug_directive/;
  read_data (acn,fwa);
  lng := fwa^.header.text_length;
  IF lng = 0 THEN
     connection_currency[acn].fet_6.user_id := 0;
     connection_currency[acn].fet_6.user_table_address := 0;
  IFEND;
PROCEND get_debug_data;
?? OLDTITLE ??
?? NEWTITLE := '    procedure no_nosve' ??
?? EJECT ??
PROCEDURE no_nosve;

  VAR
    nr_of_users,
    i, k : integer,
    user_id, user_it, user_ig : tint$user_id,
    user_table : tint$user_table_address,
    status : tint$input_status;

  nr_of_users := -1;
  WHILE nr_of_users <>0 DO
    nr_of_users := 0;
    /search_through_termin/
    FOR i := 1 TO cint$in_length DO
      user_id := com.in_table[i].user_id;
      IF user_id <> 0 THEN
         status := com.in_table[i].status;
         IF status <> cint$termin_nuc THEN
            com.in_table[i].user_table_address := 0;
            com.in_table[i].status := 0;
            com.in_table[i].user_id := 0;
            CYCLE /search_through_termin/;
         IFEND;
         nr_of_users := nr_of_users + 1;
         /search_user_in_con_currency/
         FOR k := 1 TO iic$passon_max_cn DO
             user_it := connection_currency[k].fet_6.user_id;
             IF user_it = user_id THEN
                user_ig := com.out_table[k].user_id;
                IF user_ig = 0 THEN
                   connection_currency[k].fet_6.user_id := 0;
                   connection_currency[k].fet_6.user_table_address := 0;
                   com.in_table[i].user_table_address := 0;
                   com.in_table[i].status := 0;
                   com.in_table[i].user_id := 0;
                   nr_of_users := nr_of_users - 1;
                IFEND;
                CYCLE /search_through_termin/;
             IFEND;
         FOREND /search_user_in_con_currency/;
         /search_empty_entry_in_currency/
         FOR k := 1 to iic$passon_max_cn DO
             user_it := connection_currency[k].fet_6.user_id;
             IF user_it = 0 THEN
                user_table := com.in_table[i].user_table_address;
                connection_currency[k].fet_6.user_id := user_id;
                connection_currency[k].fet_6.user_table_address := user_table;
                nosve_msg.header.connection_number := k;
                send_data (k,#LOC(nosve_msg));
                downline_sm (k,cint$termout_nuc);
                CYCLE /search_through_termin/;
             IFEND;
         FOREND /search_empty_entry_in_currency/;
      IFEND;
    FOREND /search_through_termin/;
    pause (short_pause);
  WHILEND;
PROCEND no_nosve;
?? OLDTITLE ??
?? NEWTITLE := '    procedure read_data' ??
?? EJECT ??
{  The purpose of this procedure is to read a single line of data from the
{    terminal and to supply a headerword, that makes the data look like a
{    NAM-datablock.
{
PROCEDURE read_data (acn :  iit$application_connection_num;
                     fwa : ^tint$input_data_message);

  VAR
    block_number : iit$application_block_number,
    ftr : ^tint$fet_6,
    lng,
    length : iit$text_length,
    i,k,
    error : integer;

  IF input_trans IN connection_currency[acn].connection_ext THEN
     connection_currency[acn].fet_6.char_code := 2;
     fwa^.header.transparent := true;
     IF force_parity IN connection_currency[acn].connection_ext THEN
        connection_currency[acn].fet_6.par_force := false;
     ELSE
        connection_currency[acn].fet_6.par_force := true;
     IFEND;
  ELSE
     connection_currency[acn].fet_6.char_code := 1;
     fwa^.header.transparent := false;
  IFEND;
  connection_currency[acn].fet_6.in_byte := 0;
  connection_currency[acn].fet_6.out_byte := 0;
  connection_currency[acn].fet_6.unit_sep := false;
  connection_currency[acn].fet_6.format_effector := false;
  ftr := ^connection_currency[acn].fet_6;
  ciord (fwa,ftr,length,error);
  IF error = 10(8) THEN
     fwa^.header.undeliverable := true;
  ELSE
     fwa^.header.undeliverable := false;
  IFEND;
  lng := 5*length;
  IF lng<>0 THEN
     /search_zero_byte/
     FOR i := 0 TO 4 DO
         k := 4 - i;
         IF fwa^.data[length].byte[k] = 0 THEN
            lng := lng - 1;
         ELSE;
            EXIT /search_zero_byte/;
         IFEND;
     FOREND /search_zero_byte/;
     IF fwa^.header.transparent THEN
       If lng > 0 THEN
         lng := lng - 1;
       IFEND;
     IFEND;
  IFEND;
  block_number := connection_currency[acn].block_number + 1;
  IF block_number > iic$max_block_number THEN
     block_number := 1;
  IFEND;
  connection_currency[acn].block_number := block_number;
  fwa^.header.block_type := iic$last_block;
  fwa^.header.connection_number := acn;
  fwa^.header.block_number := block_number;
  fwa^.header.character_type := iic$8_of_12_bit_characters;
  fwa^.header.zero1 := 0;
  fwa^.header.cancel := false;
  fwa^.header.parity_error := false;
  fwa^.header.text_length := lng;
  RETURN;
PROCEND read_data;
?? OLDTITLE ??
?? NEWTITLE := '    procedure send_data' ??
?? EJECT ??
{  The purpose of this procedure is to send data received from IF to the ter=
{    minal. The header is stripped off, its content is used to set up the FET.
{
PROCEDURE send_data (acn : iit$application_connection_num;
                     fwa : ^tint$output_data_message);

  VAR
    ftr : ^tint$fet_6,
    i,k,
    nr_char,nr_byte,
    error,
    length : integer;

  IF fwa^.header.character_type <> iic$8_of_12_bit_characters THEN
     abort := char_type_failed;
     set_passon_abnormal (abort);
     IF abort <> okee_dokee THEN
        RETURN;
     IFEND;
  IFEND;
  IF output_suppress IN connection_currency[acn].connection_ext THEN
     RETURN;
  IFEND;
  nr_char := fwa^.header.text_length;
  length := (nr_char+4) DIV 5;
  IF fwa^.header.transparent THEN
     nr_char := nr_char + 5 - 5*length;
     IF nr_char = 5 THEN
        nr_char := 0;
        length := length + 1;
        fwa^.data[length].byte[0] := 0;
     IFEND;
     fwa^.data[length].byte[4] := 0;
     IF nr_char < 4 THEN
        fwa^.data[length].byte[3] := 0;
        IF nr_char < 3 THEN
           fwa^.data[length].byte[2] := 0;
           IF nr_char < 2 THEN
              fwa^.data[length].byte[1] := 0;
           IFEND;
        IFEND;
     IFEND;
     connection_currency[acn].fet_6.char_code := 2;
     connection_currency[acn].fet_6.unit_sep := false;
     connection_currency[acn].fet_6.out_byte := 0;
     connection_currency[acn].fet_6.in_byte := 0;
     IF force_parity IN connection_currency[acn].connection_ext THEN
        connection_currency[acn].fet_6.par_force := false;
     ELSE
        connection_currency[acn].fet_6.par_force := true;
     IFEND;
  ELSE
     connection_currency[acn].fet_6.char_code := 1;
     connection_currency[acn].fet_6.par_force := false;
     connection_currency[acn].fet_6.in_byte := nr_char MOD 5;
     connection_currency[acn].fet_6.out_byte := 0;
     connection_currency[acn].fet_6.unit_sep := true;
  IFEND;
  connection_currency[acn].fet_6.format_effector :=
             fwa^.header.no_format_effectors;
  ftr := ^connection_currency[acn].fet_6;
  ciowr (fwa,ftr,length,error);
  IF error = 10(8) THEN
     downline_sm (acn,cint$termout_oco);
     connection_currency[acn].connection_ext :=
                connection_currency[acn].connection_ext
              + $tint$connection_ext[output_wait];
  IFEND;
  IF nam_debug AND (nr_msg>0) THEN
     savemsg (ftr,1,8);
     nr_msg := nr_msg - 1;
     savemsg (fwa,length+1,6);
  IFEND;
  RETURN;
PROCEND send_data;
?? OLDTITLE ??
?? NEWTITLE := '    procedure synch_downline_sm' ??
?? EJECT ??
{  The purpose of this procedure is to process one of three possible synchronous
{    downline supervisory messages.
{
PROCEDURE synch_downline_sm (acn : iit$application_connection_num;
                             msg : ^tint$synch_out_sm);

  VAR
    case_value : 0 .. 0ffff(16),
    lim,
    ind_synch,
    field_number,
    field_value,
    i : integer;

  ind_synch := connection_currency[acn].ind_synch + 1;
  case_value := ((16*msg^.data[1]+msg^.data[2])*16+msg^.data[3])*16
                + msg^.data[4];
  CASE case_value OF

  = iic$sm_resume_output_mark =    { RO/MARK/R = CB00(16) = 626000(8) }

    IF NOT (user_break_sy IN connection_currency[acn].connection_ext) THEN
       abort := break_req_failed;
       IF dump_indicator THEN
          dump_mem (1,abort);
       IFEND;
       RETURN;
    IFEND;
    connection_currency[acn].connection_ext :=
               connection_currency[acn].connection_ext
             + $tint$connection_ext[user_break_out]
             - $tint$connection_ext[user_break_sy];

  = iic$sm_define_term_char =      { CTRL/CHAR/R = C108(16) = 602040(8) }

    lim := (2*msg^.header.text_length-4) DIV 4;
    FOR i := 1 TO lim DO
      field_number := 16*msg^.data[4*i+1] + msg^.data[4*i+2];
      field_value  := 16*msg^.data[4*i+3] + msg^.data[4*i+4];
      IF field_number = iic$fn_trans_input_mode THEN
         IF field_value = 1 THEN
            connection_currency[acn].connection_ext :=
                       connection_currency[acn].connection_ext
                     + $tint$connection_ext[input_trans];
         ELSE
            connection_currency[acn].connection_ext :=
                       connection_currency[acn].connection_ext
                     - $tint$connection_ext[input_trans];
         IFEND;
      ELSEIF field_number = iic$fn_parity THEN
         IF field_value = 3 THEN
            connection_currency[acn].connection_ext :=
                       connection_currency[acn].connection_ext
                     + $tint$connection_ext[force_parity];
         ELSE
            connection_currency[acn].connection_ext :=
                       connection_currency[acn].connection_ext
                     - $tint$connection_ext[force_parity];
         IFEND;
      IFEND;
    FOREND;
    connection_currency[acn].synch_msg[ind_synch] := cint$ssm_ctrl_char_n;
    connection_currency[acn].ind_synch := ind_synch;

  = iic$sm_request_term_char =        { CTRL/RTC/R = C109(16) = 602044(8) }

    connection_currency[acn].synch_msg[ind_synch] := cint$ssm_ctrl_tcd_r;
    connection_currency[acn].ind_synch := ind_synch;

  ELSE;
  abort := synch_sm_failed;
  IF dump_indicator THEN
     dump_mem (2,abort);
  IFEND;
  CASEND;
  RETURN;
PROCEND synch_downline_sm;
?? OLDTITLE ??
?? NEWTITLE := '    procedure synch_upline_sm' ??
?? EJECT ??
{  The purpose of this procedure is to form a synchronous upline supervisory
{    message out of data stored in connection_currency. The type of the next
{    message is contained in the first place of array synch_msg.
{
PROCEDURE synch_upline_sm (msg : ^tint$predef_sm;
                           acn : iit$application_connection_num;
                       VAR lng : integer);

  VAR
    ind_synch,
    synch_type,
    a,b,
    i : integer,
    connection_ext : tint$connection_ext;

  synch_type := connection_currency[acn].synch_msg[1];

  CASE synch_type OF

  = cint$ssm_bi_mark_r =

    connection_ext := connection_currency[acn].connection_ext;
    IF connection_ext*$tint$connection_ext[user_break_as,
                      user_break_sy] <> $tint$connection_ext[] THEN
       connection_currency[acn].connection_ext := connection_ext
                 + $tint$connection_ext[input_suppress];
    IFEND;
    predef_ssm[1].header.address := acn;
    mmove (#LOC(predef_ssm[1]),msg,2);
    lng := 1;

  = cint$ssm_ctrl_char_n =

    predef_ssm[2].header.address := acn;
    mmove (#LOC(predef_ssm[2]),msg,2);
    lng := 1;

  = cint$ssm_ctrl_tcd_r =

    ctrl_tcd_r.header.address := acn;
    a := connection_currency[acn].term_char.term_class;
    b := class_table[a];
    a := b DIV 16;
    ctrl_tcd_r.data[7]  := a;
    ctrl_tcd_r.data[8]  := b - 16*a;
    a := connection_currency[acn].term_char.page_width DIV 16;
    b := connection_currency[acn].term_char.page_width - 16*a;
    ctrl_tcd_r.data[11] := a;
    ctrl_tcd_r.data[12] := b;
    a := connection_currency[acn].term_char.page_length DIV 16;
    b := connection_currency[acn].term_char.page_length - 16*a;
    ctrl_tcd_r.data[15] := a;
    ctrl_tcd_r.data[16] := b;
    a := connection_currency[acn].term_char.page_wait DIV 16;
    b := connection_currency[acn].term_char.page_wait - 16*a;
    ctrl_tcd_r.data[71] := a;
    ctrl_tcd_r.data[72] := b;
    mmove (#LOC(ctrl_tcd_r),msg,11);
    lng := 10;

  ELSE
    abort := synch_sm_failed;
    IF dump_indicator THEN
       dump_mem (3,abort);
    IFEND;
    RETURN;
  CASEND;
  ind_synch := connection_currency[acn].ind_synch;
  FOR i := 1 TO ind_synch-1 DO
    connection_currency[acn].synch_msg[i] :=
               connection_currency[acn].synch_msg[i+1];
  FOREND;
  connection_currency[acn].synch_msg[ind_synch] := 0;
  connection_currency[acn].ind_synch := ind_synch - 1;
  RETURN;
PROCEND synch_upline_sm;
?? OLDTITLE ??
?? NEWTITLE := '    procedure termin_search' ??
?? EJECT ??
{  The purpose of this pocedure is to check the 1QP-communication table
{    TERMIN for messages from 1QP and to convert them to flags of set
{    connection_ext. For new users an empty slot is searched in connection
{    _currency.
{
PROCEDURE termin_search;

  VAR

    connection_ext : tint$connection_ext,
    input_status : tint$input_status,
    input_user_id,
    connect_user_id : tint$user_id,
    input_user_table,
    connect_user_table : tint$user_table_address,
    i,
    k : integer;

  /search_table_termin/
  FOR i := 1 TO cint$in_length DO
    input_user_id := com.in_table[i].user_id;
    /check_termin_entry_zero/
    BEGIN
    IF input_user_id <> 0 THEN
       input_user_table := com.in_table[i].user_table_address;
       input_status := com.in_table[i].status;
       /check_for_new_user/
       BEGIN
       IF input_status = cint$termin_nuc THEN
          /search_empty_slot_in_currency/
          FOR k := 1 TO iic$passon_max_cn DO
            connect_user_id := connection_currency[k].fet_6.user_id;
            IF connect_user_id = 0 THEN
               connection_currency[k].fet_6.user_id := input_user_id;
               connection_currency[k].fet_6.user_table_address :=
                                      input_user_table;
               connection_currency[k].connection_ext :=
                          $tint$connection_ext[new_user];
               com.in_table[i].user_table_address := 0;
               com.in_table[i].status := 0;
               com.in_table[i].user_id := 0;
               EXIT /search_empty_slot_in_currency/;
            IFEND;
          FOREND /search_empty_slot_in_currency/;
       ELSE
?? NEWTITLE := '    check the status bits' ??
?? EJECT ??
/search_user_in_currency/
FOR k := 1 TO iic$passon_max_cn DO
  connect_user_id := connection_currency[k].fet_6.user_id;
  IF connect_user_id = input_user_id THEN
     connection_ext := connection_currency[k].connection_ext;
     CASE input_status OF

   = cint$termin_loc =      { autologout }
     connection_currency[k].connection_ext := connection_ext
              + $tint$connection_ext[autologout];

   = cint$termin_brk =      { user break }
     IF (connection_ext*$tint$connection_ext[user_break_as,
        user_break_akn] <> $tint$connection_ext[]) THEN
        abort := termin_failed;
        IF dump_indicator THEN
           dump_mem (4,abort);
        IFEND;
     ELSEIF (connection_ext*$tint$connection_ext[new_user,
             detach_pend,autologout,connection_rejected,trans_break,
             term_char_req,detached]) <> $tint$connection_ext[] THEN
        downline_sm (k,cint$termout_brk);
     ELSEIF input_trans IN connection_ext THEN
        connection_currency[k].connection_ext := connection_ext
                 - $tint$connection_ext[output_wait]
                 + $tint$connection_ext[trans_break];
        downline_sm (k,cint$termout_brk);
     ELSE
        connection_currency[k].connection_ext := connection_ext
                 - $tint$connection_ext[output_wait]
                 + $tint$connection_ext[user_break,output_suppress];
     IFEND;

   = cint$termin_ico =      { input available }
     connection_currency[k].connection_ext := connection_ext
              - $tint$connection_ext[input_req]
              + $tint$connection_ext[input_available];

   = cint$termin_oco =      { output complete }
     connection_currency[k].connection_ext := connection_ext
              - $tint$connection_ext[output_wait];

   = cint$termin_dis =      { user back from disconnect }
     downline_sm (k,cint$termout_ico);

     ELSE
       abort := termin_failed;
       IF dump_indicator THEN
          dump_mem (5,abort);
       IFEND;
       RETURN;
     CASEND;
     com.in_table[i].user_table_address := 0;
     com.in_table[i].status := 0;
     com.in_table[i].user_id := 0;
     EXIT /search_user_in_currency/;
  IFEND;
FOREND /search_user_in_currency/;
?? OLDTITLE ??
?? EJECT ??
       IFEND;
       END /check_for_new_user/;
    IFEND;
    END /check_termin_entry_zero/;
  FOREND /search_table_termin/;
?? OLDTITLE ??
PROCEND termin_search;
?? OLDTITLE ??
?  IFEND
?? SET(LIST:=ON) ??
?? NEWTITLE := '    procedure compute_block_length' ??
?? EJECT ??
{  The purpose of this routine is to compute the number of CM words required
{    to contain a given number of characters of a variable size.

  PROCEDURE compute_block_length (char_type: iit$application_character_type;
        text_length: iit$text_length;
    VAR length: iit$text_length);
    CASE char_type OF
    = iic$60_bit_characters =
      length := text_length;
    = iic$8_bit_characters =
      length := ((text_length + 7) * 2) DIV 15;
    = iic$8_of_12_bit_characters =
      length := (text_length + 4) DIV 5;
    = iic$display_code_characters =
      length := (text_length + 9) DIV 10;
    CASEND;
  PROCEND compute_block_length;
?? OLDTITLE ??
?? NEWTITLE := '    procedure log ' ??
?? EJECT ??
{  The purpose of this routine is to issue a dayfile message to the
{    NOS/A170 dayfile(s).

  PROCEDURE log (s: string ( * );
        dayfile: 0 .. 7;
        force: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc zutps2d
*copyc zn7pmsg
?? POP ??

    VAR
      dcm: array [1 .. 8] of packed array [0 .. 9] of 0 .. 3f(16),
      dcwi: integer,
      dcci: 0 .. 9,
      si: ost$string_index,
      eol: boolean;

    IF (NOT passon_debug) AND (dayfile = job_dayfile) AND (NOT force) THEN
      RETURN;
    IFEND;
    si := 1;
    dcwi := 1;
    dcci := 0;
    eol := TRUE;
    utp$convert_string_to_dc_string (utc$ascii64, dcm, dcwi, dcci, s, si, eol);
    n7p$issue_dayfile_message (#LOC (dcm), dayfile);
  PROCEND log;
?? OLDTITLE ??
?? NEWTITLE := '    procedure set_passon_abnormal' ??
?? EJECT ??
{  The purpose of this routine is to issue the passon abnormal
{    log message and possibly cause passon to terminate execution.

  PROCEDURE set_passon_abnormal (VAR abort: iit$passon_failure);
    log_vrbl (' passon abnormal ', ORD (abort), job_dayfile, FALSE);
    IF status.condition = mlc$nosve_not_up THEN
      log ('$nosve down', b_display, FALSE);
      RETURN;
    IFEND;
    IF NOT terminate_if_abnormal THEN
      abort := okee_dokee;
    IFEND;
  PROCEND set_passon_abnormal;
?? OLDTITLE ??
?? NEWTITLE := '    procedure log_vrbl' ??
?? EJECT ??
{  The purpose of this routine is to issue a dayfile message to the
{    NOS/A170 dayfile(s) with a varibale value appended to it.

  PROCEDURE log_vrbl (s: string ( * );
        value: integer;
        dayfile: 0 .. 7;
        force: boolean);

    VAR
      new_s: ^string ( * ),
      n,
      l: integer;

    IF (NOT passon_debug) AND (dayfile = job_dayfile) AND (NOT force) THEN
      RETURN;
    IFEND;
    l := STRLENGTH (s);
    PUSH new_s: [l + 10];
    new_s^ (1, l) := s (1, l);
    new_s^ (l + 1, 10) := '          ';
    STRINGREP (new_s^ (l + 1, 10), n, value);
    log (new_s^, dayfile, force);
  PROCEND log_vrbl;
?? OLDTITLE ??
?? NEWTITLE := '    procedure form_sm ' ??
?? EJECT ??
{  The purpose of this procedure is to initialize the common parts of a
{    supervisory message.

  PROCEDURE form_sm (msg: ^iit$output_supervisory_message;
        pfcsfc: iit$supervisory_message_type;
        length: integer);

    VAR
      standard_header: [STATIC] iit$output_supervisory_header := [
      ?IF ifv$module_for_c180 = TRUE THEN
        0,
      ?IFEND
        {} iic$supervisory_block, 0, 0, iic$60_bit_characters, 0, 0];

    msg^.header := standard_header;
    msg^.header.text_length := length;
    msg^.message_type := pfcsfc;
  PROCEND form_sm;
?? OLDTITLE ??
?? NEWTITLE := '    procedure dump', EJECT ??

  PROCEDURE dump (abort: iit$passon_failure;
        p: ^cell;
        len: integer);

    CONST
      ?IF ifv$module_for_c180 = TRUE THEN
        nod = 16;

      ?ELSE
        nod = 15;
    ?IFEND

    VAR
      pa: ^packed array [1 .. 100] of packed array [1 .. nod] of 0 .. 15,
      lim,
      ich,
      i,
      j: integer,
      s: string (17);

    log_vrbl (' hex data for passon condition =', ORD (abort), job_dayfile,
          TRUE);
    s := '  ';
    pa := p;
    lim := len;
    IF lim > 100 THEN
      lim := 100;
    IFEND;
    FOR i := 1 TO lim DO
      FOR j := 1 TO nod DO
        ich := pa^ [i] [j];
        IF ich > 9 THEN
          ich := ich + 37(16);
        ELSE
          ich := ich + 30(16);
        IFEND;
        s (j + 1) := CHR (ich);
      FOREND;
      log (s, job_dayfile, TRUE);
    FOREND;
  PROCEND dump;
?? OLDTITLE ??
?? NEWTITLE := '    procedure begin_data_read' ??
?? EJECT ??
{  The purpose of this request is to start a read operation on a given
{    connection.

  PROCEDURE begin_data_read (acn: iit$application_connection_num;
        begin_absentee: boolean;
        notify: boolean;
        application: mlt$application_name;
    VAR abort: iit$passon_failure);

    VAR
    ? IF ifv$nos_be = true THEN
      block_number : iit$application_block_number,
      lng, ind,
      ind_synch : integer,
      connection_ext : tint$connection_ext,
      output_user_id : tint$user_id,
    ? IFEND
      cs: iit$connection_state,
      dmsg: iit$input_data_message,
      length: iit$text_length,
      smsg: iit$output_supervisory_message;

  {!log_vrbl (' begin read on acn ', acn, job_dayfile, FALSE);
    cs := connection_currency [acn].connection_state;

{ Allow reads if a break is active and read is without wait

    IF (cs * $iit$connection_state [wait_connection, break_active,
          broken_connection, stopped, connection_ending, connection_hold,
          wait_init, available_for_use, terminate]) <> $iit$connection_state [] THEN
      IF NOT ((break_active IN cs) AND (NOT begin_absentee)) THEN
        log_vrbl (' read ignored ', acn, job_dayfile, FALSE);
{
{  Notify the nos/ve task doing the read that the read was not accepted.
{
        form_sm (#LOC (smsg), iic$sm_read_rejected, iic$l_read_rejected);
        send_upline_sm (#LOC (smsg), iic$l_read_rejected, acn, application,
              abort);
        RETURN;
      IFEND;
    IFEND;
    connection_currency [acn].application_name_last_io := application;
  ? IF ifv$nos_be = false THEN
    net#get (acn, #LOC (dmsg), iic$max_block_length_in_words);
  ? ELSE
    IF input_suppress IN connection_currency[acn].connection_ext THEN
       form_sm (#LOC (smsg), iic$sm_read_rejected, iic$l_read_rejected);
       send_upline_sm (#LOC (smsg), iic$l_read_rejected, acn, application,
           abort);
       RETURN;
    IFEND;
    ind_synch := connection_currency[acn].ind_synch;
    IF ind_synch <> 0 THEN
       synch_upline_sm  (#LOC(dmsg),acn,lng);
       IF abort = okee_dokee THEN
          send_upline_data (#LOC(dmsg),lng,acn,application,abort);
       ELSE
          IF dump_indicator THEN
             dump_mem (6,abort);
          IFEND;
       IFEND;
       RETURN;
    ELSE
       /input_available_check/
       BEGIN
       /check_analyst_action/
       BEGIN
       connection_ext := connection_currency[acn].connection_ext;
       IF trans_break IN connection_ext THEN
          output_user_id := com.out_table[acn].user_id;
          IF (output_user_id = 0) AND
             (user_break_rel IN connection_ext) THEN
             trans_break_msg.header.connection_number := acn;
             mmove (#LOC(trans_break_msg),#LOC(dmsg),2);
             connection_currency[i].connection_ext := connection_ext
                       -$tint$connection_ext[user_break_rel,trans_break,
                                             input_available,input_req];
             downline_sm (acn,cint$termout_ico);
             EXIT /input_available_check/;
          IFEND;
          EXIT /check_analyst_action/;
       IFEND;
       IF input_available IN connection_ext THEN
          read_data (acn,#LOC(dmsg));
          connection_currency[acn].connection_ext := connection_ext
                   - $tint$connection_ext[input_available];
          IF acn = analyst_acn THEN
             analyst_action (#LOC(dmsg),ind);
             IF ind = 1 THEN
                EXIT /check_analyst_action/;
             IFEND;
          IFEND;
          EXIT /input_available_check/;
       IFEND;
       END /check_analyst_action/;
       block_number := connection_currency[acn].block_number + 1;
       IF block_number > iic$max_block_number THEN
          block_number := 1;
       IFEND;
       connection_currency[acn].block_number := block_number;
       dmsg.header.block_type := iic$null_block;
       dmsg.header.connection_number := acn;
       dmsg.header.block_number := block_number;
       dmsg.header.undeliverable := false;
       dmsg.header.character_type := iic$8_of_12_bit_characters;
       downline_sm (acn,cint$termout_ico);
       END /input_available_check/;
    IFEND;
  ? IFEND
    IF dmsg.header.undeliverable THEN
      abort := data_ibu;
      dump (abort, #LOC (dmsg), 5);
      RETURN;
    IFEND;
    IF (dmsg.header.block_type <> iic$null_block) OR (NOT begin_absentee) THEN
      IF dmsg.header.block_type = iic$null_block THEN
        length := 0;
      ELSE
        compute_block_length (dmsg.header.character_type, dmsg.header.
              text_length, length);
      IFEND;
      send_upline_data (#LOC (dmsg), length, acn, application, abort);
      IF abort <> okee_dokee THEN
      ? IF ifv$nos_be = true THEN
        IF dump_indicator THEN
           dump_mem (7,abort);
        IFEND;
      ? IFEND
        RETURN;
      IFEND;
    ELSE
      IF begin_absentee THEN
        connection_currency [acn].connection_state := connection_currency
              [acn].connection_state + $iit$connection_state [absentee_read];
      ? IF ifv$nos_be = false THEN
        form_sm (#LOC (smsg), iic$sm_list_on, iic$l_list_on);
        smsg.list_on.connection_number := acn;
        net#put (#LOC (smsg));
      ? IFEND
      {!log_vrbl (' begin absentee on acn ', acn, job_dayfile, FALSE);
        IF notify THEN
          form_sm (#LOC (smsg), iic$sm_absentee_begun, iic$l_absentee_begun);
          send_upline_sm (#LOC (smsg), iic$l_absentee_begun, acn,
                connection_currency [acn].application_name_last_io, abort);
        IFEND;
      IFEND;
    IFEND;
  PROCEND begin_data_read;
?? OLDTITLE ??
?? NEWTITLE := '    Map NOS family to NOSVE          ' ??
?? EJECT ??

{  The purpose of this routine is to map a NOS family to a NOS/VE
{  family.  The default NOS/VE family will be used if the first
{  character of the returned family is NULL.
{
{  Note  that the format for the family name and user name is one to
{  seven 6-bit display code letters and digits, left-justified with
{  blank fill.
{
{  For example, the following statements would specify a NOS/VE family
{  name of NOSVE and a NOS/VE user name of SON:
{
{  family [1] := 14; { 'N' in display code
{  family [2] := 15; { 'O' in display code
{  family [3] := 19; { 'S' in display code
{  family [4] := 22; { 'V' in display code
{  family [5] := 05; { 'E' in display code
{  family [6] := 45; { ' ' in display code
{  family [7] := 45; { ' ' in display code
{
{  user_name [1] := 19; { 'S' in display code
{  user_name [2] := 15; { 'O' in display code
{  user_name [3] := 14; { 'N' in display code
{  user_name [4] := 45; { ' ' in display code
{  user_name [5] := 45; { ' ' in display code
{  user_name [6] := 45; { ' ' in display code
{  user_name [7] := 45; { ' ' in display code

  PROCEDURE map_nos_family_to_nosve (VAR family: iit$login_family_name;
    VAR user_name: iit$login_user_name);

    family[1] :=  00(16);

  PROCEND map_nos_family_to_nosve;
?? OLDTITLE ??
?? NEWTITLE := '    procedure poll_for_absentee_reads' ??
?? EJECT ??
{  The purpose of this routine is to perform a nam net get list request
{    on the absentee list and send any data to the correct nos/ve task.

  PROCEDURE poll_for_absentee_reads (msg: ^iit$input_data_message;
    VAR abort: iit$passon_failure);

    VAR
      acn: iit$application_connection_num,
      application: mlt$application_name,
      length: iit$text_length,
      posm: ^iit$output_supervisory_message;

  ? IF ifv$nos_be = false THEN
    net#gtl (iic$normal_input_list_number, msg, iic$max_block_length_in_words);
  ? IFEND
    IF msg^.header.undeliverable THEN
      abort := data_ibu;
      dump (abort, #LOC (msg^), 5);
    ? IF ifv$nos_be = true THEN
      IF dump_indicator THEN
         dump_mem (8,abort);
      IFEND;
    ? IFEND
      RETURN;
    IFEND;
    IF msg^.header.block_type = iic$null_block THEN
      abort_poll := TRUE;
      RETURN;
    IFEND;
    acn := msg^.header.connection_number;
  {!log_vrbl (' absentee input from acn ', acn, job_dayfile, FALSE);
    application := connection_currency [acn].application_name_last_io;
    compute_block_length (msg^.header.character_type, msg^.header.text_length,
          length);
    abort := okee_dokee;
    send_upline_data (msg, length, acn, application, abort);
{
{ disable absentee read for this acn
{
    IF abort = okee_dokee THEN
    ? IF ifv$nos_be = false THEN
      posm := #LOC (msg^);
      form_sm (posm, iic$sm_list_off, iic$l_list_off);
      posm^.list_off.connection_number := acn;
      net#put (posm);
    ? IFEND
      connection_currency [acn].connection_state := connection_currency [acn].
            connection_state - $iit$connection_state [absentee_read];
    IFEND;
  PROCEND poll_for_absentee_reads;
?? OLDTITLE ??
?? NEWTITLE := '    procedure send_queued_upline_sm' ??
?? EJECT ??
{  The purpose of this procedure is to send queued upline supervisory messages
{    to nos/ve.

  PROCEDURE send_queued_upline_sm (acn: iit$application_connection_num;
    VAR abort: iit$passon_failure);

    VAR
      nextqp,
      qp: ^iit$sm_queue,
      sp: ^iit$input_supervisory_message,
      length: mlt$message_length;

    IF NOT (connection_hold IN connection_currency [acn].connection_state) THEN
      qp := connection_currency [acn].front_queued_sm_ptr;
      IF qp <> NIL THEN
        length := UPPERBOUND (qp^.msg);
        mlp$send_message (iic$passon_application_name,
              iic$input_supervisory_message, signal, #LOC (qp^.msg), length *
              iic$mli_multiplier, qp^.application_name, status);
        IF status.condition IN mli_retry_status THEN
          RETURN;
        IFEND;
        IF status.condition IN mli_fatal_status THEN
          IF status.condition <> mlc$receiver_not_signed_on THEN
            abort := queued_sm_send;
            dump (abort, #LOC (status), #SIZE (status));
          ? IF ifv$nos_be = true THEN
            IF dump_indicator THEN
               dump_mem (9,abort);
            IFEND;
          ? IFEND
            RETURN;
          ELSE
            log_vrbl (' upline failure to acn ', acn, job_dayfile, FALSE);
            IF acn = iic$exec_acn THEN
              abort := exec_dead;
              dump (abort, #LOC (status), #SIZE (status));
            ? IF ifv$nos_be = true THEN
              IF dump_indicator THEN
                 dump_mem (10,abort);
              IFEND;
            ? IFEND
              set_passon_abnormal (abort);
            IFEND;
          IFEND;
        IFEND;
{
{ message was sent - release space
{
        sp := #LOC (qp^.msg);
        IF sp^.message_type = iic$sm_hold_acknowlege THEN
          connection_currency [acn].connection_state := connection_currency
                [acn].connection_state + $iit$connection_state
                [connection_hold];
        IFEND;
        connection_currency [acn].front_queued_sm_ptr := qp^.front;
        IF qp^.front <> NIL THEN
          qp^.front^.back := NIL;
        ELSE
          connection_currency [acn].back_queued_sm_ptr := NIL;
        IFEND;
      {!log_vrbl (' queued sm sent from acn ', acn, job_dayfile, FALSE);
      {!log_vrbl (' sent to appl ', qp^.application_name, job_dayfile, FALSE);
        ?IF ifv$module_for_c180 = TRUE THEN
          FREE qp IN osv$task_private_heap^;
        ?ELSE
          FREE qp;
        ?IFEND
        queued_sm_count := queued_sm_count - 1;
      IFEND;
    IFEND;
  PROCEND send_queued_upline_sm;
?? OLDTITLE ??
?? NEWTITLE := '    procedure send_upline_sm' ??
?? EJECT ??
{  The purpose of this procedure is to (attempt to) send a supervisory message
{    (upline) to nos/ve.  If the message cannot be sent, it will be added to
{    a queue for later transmission.  The actual length transferred is length +
{1 to
{    account for the header word.

  PROCEDURE send_upline_sm (msg: ^iit$input_supervisory_message;
        length: integer;
        acn: iit$application_connection_num;
        application: mlt$application_name;
    VAR abort: iit$passon_failure);

    VAR
      qp: ^iit$sm_queue,
      queued_sm: ^iit$sm_queue;

  {!log_vrbl (' send sm acn', acn, job_dayfile, FALSE);
  {!log_vrbl (' send sm type ', msg^.message_type, job_dayfile, FALSE);
  {!log_vrbl (' send to appl ', application, job_dayfile, FALSE);
    qp := connection_currency [acn].back_queued_sm_ptr;
    IF NOT (connection_hold IN connection_currency [acn].connection_state) THEN
      IF qp = NIL THEN
{
{ attempt mli send
{
        mlp$send_message (iic$passon_application_name,
              iic$input_supervisory_message, signal, msg, (length + 1) *
              iic$mli_multiplier, application, status);
      ? IF ifv$nos_be = true THEN
        IF nam_debug AND (nr_msg>0) THEN
           savemsg (msg,length+1,1);
           nr_msg := nr_msg - 1;
        IFEND;
      ? IFEND
        IF status.condition IN mli_ignore_status THEN
{
{ handle connection hold
{
          IF msg^.message_type = iic$sm_hold_acknowlege THEN
            connection_currency [acn].connection_state := connection_currency
                  [acn].connection_state + $iit$connection_state
                  [connection_hold];
          IFEND;
          RETURN;
        IFEND;
        IF status.condition IN mli_fatal_status THEN
          IF status.condition <> mlc$receiver_not_signed_on THEN
            abort := sm_send;
            dump (abort, #LOC (status), #SIZE (status));
          ? IF ifv$nos_be = true THEN
            IF dump_indicator THEN
               dump_mem (11,abort);
            IFEND;
          ? IFEND
            RETURN;
          ELSE
            log_vrbl (' upline failure to acn ', acn, job_dayfile, FALSE);
            IF acn = iic$exec_acn THEN
              abort := exec_dead;
              dump (abort, #LOC (status), #SIZE (status));
            ? IF ifv$nos_be = true THEN
              IF dump_indicator THEN
                 dump_mem (12,abort);
              IFEND;
            ? IFEND
              set_passon_abnormal (abort);
            IFEND;
            RETURN;
          IFEND;
        IFEND;
      IFEND;
      IFEND; {connection_hold}
{
{ message could not be sent to nos/ve.
{ queue for later transmission.
{
      ?IF ifv$module_for_c180 = TRUE THEN
        ALLOCATE queued_sm: [1 .. length + 1] IN osv$task_private_heap^;
      ?ELSE
        ALLOCATE queued_sm: [1 .. length + 1];
      ?IFEND
      IF queued_sm = NIL THEN
        abort := no_space;
      ? IF ifv$nos_be = true THEN
        IF dump_indicator THEN
           dump_mem (13,abort);
        IFEND;
      ? IFEND
        RETURN;
      IFEND;
      mmove (#LOC (msg^), #LOC (queued_sm^.msg), length + 1);
      queued_sm^.front := NIL;
      queued_sm^.back := qp;
      IF qp <> NIL THEN
        qp^.front := queued_sm;
      ELSE
        connection_currency [acn].front_queued_sm_ptr := queued_sm;
      IFEND;
      connection_currency [acn].back_queued_sm_ptr := queued_sm;
      queued_sm^.application_name := application;
      queued_sm_count := queued_sm_count + 1;
    {!log (' sm queued ', job_dayfile, FALSE);
  PROCEND send_upline_sm;
?? OLDTITLE ??
?? NEWTITLE := '    procedure send_queued_upline_data' ??
?? EJECT ??
{  The purpose of this procedure is to send queued upline data messages
{    to nos/ve.

  PROCEDURE send_queued_upline_data (acn: iit$application_connection_num;
    VAR abort: iit$passon_failure);

    VAR
      nextqp,
      qp: ^iit$data_queue,
      length: mlt$message_length;

    IF NOT (connection_hold IN connection_currency [acn].connection_state) THEN
      qp := connection_currency [acn].front_queued_data_ptr;
      IF qp <> NIL THEN
        length := UPPERBOUND (qp^.msg);
        mlp$send_message (iic$passon_application_name, iic$input_data_message,
              signal, #LOC (qp^.msg), length * iic$mli_multiplier, qp^.
              application_name, status);
        IF status.condition IN mli_retry_status THEN
          RETURN;
        IFEND;
        IF status.condition IN mli_fatal_status THEN
          IF status.condition <> mlc$receiver_not_signed_on THEN
            abort := queued_data_send;
            dump (abort, #LOC (status), #SIZE (status));
          ? IF ifv$nos_be = true THEN
            IF dump_indicator THEN
               dump_mem (14,abort);
            IFEND;
          ? IFEND
            RETURN;
          ELSE
            log_vrbl (' upline failure to acn ', acn, job_dayfile, FALSE);
            IF acn = iic$exec_acn THEN
              abort := exec_dead;
              dump (abort, #LOC (status), #SIZE (status));
            ? IF ifv$nos_be = true THEN
              IF dump_indicator THEN
                 dump_mem (15,abort);
             IFEND;
           ? IFEND
              set_passon_abnormal (abort);
            IFEND;
          IFEND;
        IFEND;
{
{ message was sent - release space
{
        connection_currency [acn].front_queued_data_ptr := qp^.front;
        IF qp^.front <> NIL THEN
          qp^.front^.back := NIL;
        ELSE
          connection_currency [acn].back_queued_data_ptr := NIL;
        IFEND;
      {!log_vrbl (' queued data sent from acn ', acn, job_dayfile, FALSE);
      {!log_vrbl (' sent to appl ', qp^.application_name, job_dayfile, FALSE);
        ?IF ifv$module_for_c180 = TRUE THEN
          FREE qp IN osv$task_private_heap^;
        ?ELSE
          FREE qp;
        ?IFEND
        queued_data_count := queued_data_count - 1;
      IFEND;
    IFEND;
  PROCEND send_queued_upline_data;
?? OLDTITLE ??
?? NEWTITLE := '    procedure send_upline_data' ??
?? EJECT ??
{  The purpose of this procedure is to (attempt to) send a data message
{    (upline) to nos/ve.  If the message cannot be sent, it will be added to
{    a queue for later transmission.  The actual length transferred is length +
{1
{    to account for the header word.

  PROCEDURE send_upline_data (msg: ^iit$input_data_message;
        length: integer;
        acn: iit$application_connection_num;
        application: mlt$application_name;
    VAR abort: iit$passon_failure);

    VAR
    ? IF ifv$nos_be = true THEN
      k : integer,
    ? IFEND
      qp: ^iit$data_queue,
      queued_data: ^iit$data_queue;

  {!log_vrbl (' send data from acn ', acn, job_dayfile, FALSE);
  {!log_vrbl (' send to appl ', application, job_dayfile, FALSE);
    qp := connection_currency [acn].back_queued_data_ptr;
    IF NOT (connection_hold IN connection_currency [acn].connection_state) THEN
    ? IF ifv$nos_be = true THEN
      IF nam_debug AND (nr_msg>0) THEN
         IF msg^.header.block_type  = iic$supervisory_block THEN
            k := 3;
         ELSE
            k := 5;
            savemsg (#LOC(connection_currency[acn].fet_6),1,7);
         IFEND;
         savemsg (msg,length+1,k);
         nr_msg := nr_msg - 1;
      IFEND;
    ? IFEND
      IF qp = NIL THEN
{
{ attempt mli send
{
        mlp$send_message (iic$passon_application_name, iic$input_data_message,
              signal, msg, (length + 1) * iic$mli_multiplier, application,
              status);
        IF status.condition IN mli_ignore_status THEN
          RETURN;
        IFEND;
        IF status.condition IN mli_fatal_status THEN
          IF status.condition <> mlc$receiver_not_signed_on THEN
            abort := data_send;
            dump (abort, #LOC (status), #SIZE (status));
            dump (abort, msg, 10);
            dump (abort, #LOC (acn), 1);
          ? IF ifv$nos_be = true THEN
            IF dump_indicator THEN
               dump_mem (16,abort);
            IFEND;
          ? IFEND
            RETURN;
          ELSE
            log_vrbl (' upline failure to acn ', acn, job_dayfile, FALSE);
            IF acn = iic$exec_acn THEN
              abort := exec_dead;
              dump (abort, #LOC (status), #SIZE (status));
            ? IF ifv$nos_be = true THEN
              IF dump_indicator THEN
                 dump_mem (17,abort);
              IFEND;
            ? IFEND
              set_passon_abnormal (abort);
            IFEND;
            RETURN;
          IFEND;
        IFEND;
      IFEND;
{
{ message could not be sent to nos/ve.
{ queue for later transmission.
{
      ?IF ifv$module_for_c180 = TRUE THEN
        ALLOCATE queued_data: [1 .. length + 1] IN osv$task_private_heap^;
      ?ELSE
        ALLOCATE queued_data: [1 .. length + 1];
      ?IFEND
      IF queued_data = NIL THEN
        abort := no_space;
      ? IF ifv$nos_be = true THEN
        IF dump_indicator THEN
           dump_mem (18,abort);
        IFEND;
      ? IFEND
        RETURN;
      IFEND;
      mmove (#LOC (msg^), #LOC (queued_data^.msg), length + 1);
      queued_data^.front := NIL;
      queued_data^.back := qp;
      IF qp <> NIL THEN
        qp^.front := queued_data;
      ELSE
        connection_currency [acn].front_queued_data_ptr := queued_data;
      IFEND;
      connection_currency [acn].back_queued_data_ptr := queued_data;
      queued_data^.application_name := application;
      queued_data_count := queued_data_count + 1;
    {!log (' data queued ', job_dayfile, FALSE);
    IFEND;
  PROCEND send_upline_data;
?? OLDTITLE ??
?? NEWTITLE := '    procedure send_downline_data' ??
?? EJECT ??
{  The purpose of this procedure is to transmit the specified data message
{    to nam.

? IF ifv$nos_be = true THEN
  PROCEDURE send_downline_data (msg : ^tint$output_data_message;
                                fwa : ^tint$synch_out_sm);

    VAR
      lng: integer,
      cs: iit$connection_state,
      acn: iit$application_connection_num;
? ELSE
  PROCEDURE send_downline_data (msg: ^iit$output_data_message);

    VAR
      cs: iit$connection_state,
      acn: iit$application_connection_num;
? IFEND
    VAR
      begin_absentee: boolean,
      smsg: iit$output_supervisory_message;

    begin_absentee := false;
    IF msg^.header.block_type = iic$begin_absentee THEN
       msg^.header.block_type := iic$last_block;
       begin_absentee := true;
    IFEND;
    acn := msg^.header.connection_number;
    cs := connection_currency [acn].connection_state;
    IF (cs * $iit$connection_state [wait_connection, break_active,
          broken_connection, stopped, connection_ending, connection_hold,
          wait_init, available_for_use, terminate]) <> $iit$connection_state [] THEN
      RETURN;
    IFEND;
  ? IF ifv$nos_be = false THEN
    connection_currency [acn].unacknowledged_block_count := connection_currency
          [acn].unacknowledged_block_count + 1;
    net#put (msg);
  ? ELSE
    IF msg^.header.block_type <> iic$supervisory_block THEN
      send_data (acn,msg);
    ELSE
      IF nam_debug AND (nr_msg>0) THEN
         lng := (2*fwa^.header.text_length+14) DIV 15 + 1;
         nr_msg := nr_msg - 1;
         savemsg (fwa,lng,4);
      IFEND;
      synch_downline_sm (acn,fwa);
    IFEND;
  ? IFEND
    IF msg^.header.block_type = iic$last_block THEN
      form_sm(#loc(smsg), iic$sm_read_request, iic$l_read_request);
      smsg.read_request.connection_number := acn;
      smsg.read_request.begin_absentee := begin_absentee;
      smsg.read_request.notify_if_absentee_started := true;
      modify_downline_connection (#loc(smsg), nosve_application,abort);
    IFEND;
  PROCEND send_downline_data;
? IF ifv$nos_be = true THEN
?? SET(LIST:=OFF) ??
?  ELSE
?? OLDTITLE ??
?? NEWTITLE := 'fetch_upline_sm' ??
?? EJECT ??
{  The purpose of this procedure is to get an upline supervisory message
{    from nam and send it to the appropriate nos/ve task.

  PROCEDURE fetch_upline_sm (msg: ^iit$input_supervisory_message;

    VAR abort: iit$passon_failure);
    net#get (iic$supervisory_connection_num, msg,
          iic$max_block_length_in_words);
    IF msg^.header.undeliverable THEN
      abort := sm_ibu;
      dump (abort, #LOC (msg^), 5);
      RETURN;
    IFEND;
{
{ check if no sm available
{
    IF msg^.header.block_type = iic$null_block THEN
      RETURN;
    IFEND;
    IF msg^.header.block_type <> iic$supervisory_block THEN
      abort := expected_sm;
      dump (abort, #LOC (msg^), 5);
      RETURN;
    IFEND;
    modify_upline_connection_status (msg, abort);
  PROCEND fetch_upline_sm;
?  IFEND
?? SET(LIST:=ON) ??
?? OLDTITLE ??
?? NEWTITLE := '    procedure modify_upline_connection_status' ??
?? EJECT ??
{  The purpose of this procedure is to modify the passon environment,
{    as needed, from the upline supervisory message.  The message is then sent
{    (upline) to nos/ve;

  PROCEDURE modify_upline_connection_status (msg:
    ^iit$input_supervisory_message;
    VAR abort: iit$passon_failure);

    TYPE
      kludge = record
        w1: integer,
        w2: integer,
        w3: iit$output_data_block_header,
      recend;

    VAR
    ? IF ifv$nos_be = true THEN
      lng : integer,
    ? IFEND
      family: iit$login_family_name,
      user_name: iit$login_user_name,
      xsmp,
      smp: ^iit$sm_queue,
      xdmp,
      dmp: ^iit$data_queue,
      ptr: ^kludge,
      ismsg: ^iit$input_supervisory_message,
      osmsg: ^iit$output_supervisory_message,
      conend_zero2: [STATIC] iit$170_display_word := [[REP 5 of 0], [REP 5 of
        0]],
      acn: iit$application_connection_num;

  {!log_vrbl (' upline sm ', msg^.message_type, job_dayfile, FALSE);
    CASE msg^.message_type OF
    = iic$sm_connection_broken =
      acn := msg^.connection_broken.connection_number;
      connection_currency [acn].connection_state := connection_currency [acn].
            connection_state + $iit$connection_state [broken_connection];
    ? IF ifv$nos_be = false THEN
      connection_currency [acn].unacknowledged_block_count := 0;
    ? IFEND
      send_upline_sm (msg, iic$l_connection_broken, acn, connection_currency
            [acn].application_name_jm, abort);
    = iic$sm_connection_ended =
      acn := msg^.connection_ended.connection_number;
      send_upline_sm (msg, iic$l_connection_ended, acn, connection_currency
            [acn].application_name_jm, abort);
      dmp := connection_currency [acn].front_queued_data_ptr;
      WHILE dmp <> NIL DO
        xdmp := dmp;
        dmp := xdmp^.front;
        ?IF ifv$module_for_c180 = TRUE THEN
          FREE xdmp IN osv$task_private_heap^;
        ?ELSE
          FREE xdmp;
        ?IFEND
        queued_data_count := queued_data_count - 1;
      WHILEND;
      connection_currency [acn].connection_state := $iit$connection_state
            [available_for_use];
{
{ add the supervisory messages for this connection to the exec's sm queue.
{ this will enable passon to free the acn before the 180 tasks have
{ completed interactive termination.
{
      smp := connection_currency [acn].front_queued_sm_ptr;
      IF smp <> NIL THEN
        xsmp := connection_currency [iic$exec_acn].back_queued_sm_ptr;
        IF xsmp <> NIL THEN
          xsmp^.front := smp;
          smp^.back := xsmp;
        ELSE
          connection_currency [iic$exec_acn].front_queued_sm_ptr := smp;
        IFEND;
        connection_currency [iic$exec_acn].back_queued_sm_ptr :=
              connection_currency [acn].back_queued_sm_ptr;
      IFEND;
      connection_currency [acn].front_queued_sm_ptr := NIL;
      connection_currency [acn].back_queued_sm_ptr := NIL;
      connection_currency [acn].connection_end_pending := FALSE;
    = iic$sm_connection_request =
      acn := msg^.conreq_connection_number;
      IF connection_currency [acn].connection_state <> $iit$connection_state
            [available_for_use] THEN
        abort := conreq1_failure;
        dump (abort, #LOC (connection_currency [acn]), #SIZE
              (connection_currency [acn]));
      ? IF ifv$nos_be = true THEN
        IF dump_indicator THEN
           dump_mem (19,abort);
        IFEND;
      ? IFEND
        RETURN;
      IFEND;
      connection_currency [acn].connection_state := connection_currency [acn].
            connection_state - $iit$connection_state [available_for_use] +
            $iit$connection_state [wait_connection];
    ? IF ifv$nos_be = false THEN
      connection_currency [acn].application_block_limit := msg^.
            conreq_block_limit;
      connection_currency [acn].unacknowledged_block_count := 0;
      family := msg^.conreq_family_name;
      user_name := msg^.conreq_user_name;
      map_nos_family_to_nosve(family,user_name);
      msg^.conreq_family_name := family;
      msg^.conreq_user_name := user_name;

    ? IFEND
      send_upline_sm (msg, iic$l_connection_request, iic$exec_acn,
            iic$exec_application_name, abort);
      IF abort = exec_dead THEN
      ? IF ifv$nos_be = false THEN
        PUSH osmsg;
        form_sm (osmsg, iic$sm_connection_rejected, iic$l_connection_rejected);
        osmsg^.connection_rejected.connection_number := acn;
        osmsg^.connection_rejected.reason := iic$unspecified_reject;
        net#put (osmsg);
      ? IFEND
      {!log_vrbl (' exec dead conreq reject', acn, job_dayfile, FALSE);
        connection_currency [acn].connection_state := $iit$connection_state
              [available_for_use];
      ? IF ifv$nos_be = true THEN
        connection_currency [acn].connection_ext :=
                                  $tint$connection_ext[detach_pend];
      ? IFEND
      IFEND;
    ? IF ifv$nos_be = true THEN
    ?? SET(LIST:=OFF) ??
    ? ELSE
    = iic$sm_output_stopped =
      acn := msg^.output_stopped.connection_number;
      connection_currency [acn].connection_state := connection_currency [acn].
            connection_state + $iit$connection_state [stopped];
      connection_currency [acn].unacknowledged_block_count := 0;
      send_upline_sm (msg, iic$l_output_stopped, acn, connection_currency
            [acn].application_name_jm, abort);
    = iic$sm_logical_error =
      log (' an errlgl follows ', job_dayfile, FALSE);
      dump (okee_dokee, #LOC (msg^), 10);
      IF msg^.errlgl_reason = iic$block_limit_exceeded THEN
{
{  send to job monitor
{
        ptr := #LOC (msg^);
        acn := ptr^.w3.connection_number;
        send_upline_sm (msg, iic$l_logical_error, acn, connection_currency
              [acn].application_name_jm, abort);
      ELSE
{
{ send to exec
{
        send_upline_sm (msg, iic$l_logical_error, iic$exec_acn,
              iic$exec_application_name, abort);
      IFEND;
      abort := error_logical;
    = iic$sm_break =
      acn := msg^.break.connection_number;
      connection_currency [acn].connection_state := connection_currency [acn].
            connection_state + $iit$connection_state [break_active];
      connection_currency [acn].unacknowledged_block_count := 0;
      send_upline_sm (msg, iic$l_break, acn, connection_currency [acn].
            application_name_jm, abort);
      IF absentee_read IN connection_currency [acn].connection_state THEN
{
{ remove absentee read from passon environment
{
        connection_currency [acn].connection_state := connection_currency
              [acn].connection_state - $iit$connection_state [absentee_read];
        PUSH osmsg;
        form_sm (osmsg, iic$sm_list_off, iic$l_list_off);
        osmsg^.list_off.connection_number := acn;
        net#put (osmsg);
      IFEND;
    ? IFEND
    ?? SET(LIST:=ON) ??
    = iic$sm_initialized_connection =
      acn := msg^.initialized_connection.connection_number;
      IF connection_currency [acn].connection_state <> $iit$connection_state
            [wait_init] THEN
        IF connection_currency [acn].connection_state <> $iit$connection_state
              [wait_init, broken_connection] THEN
          abort := init_failure;
          dump (abort, #LOC (connection_currency [acn]), #SIZE
                (connection_currency [acn]));
        ? IF ifv$nos_be = true THEN
          IF dump_indicator THEN
             dump_mem (20,abort);
          IFEND;
        ? IFEND
          RETURN;
        IFEND;
      IFEND;
      PUSH osmsg;
{ issue network connection initialized for NOS/VE
      form_sm(osmsg,iic$sm_connection_initialized,iic$l_connection_initialized);
      osmsg^.connection_initialized.connection_number:=acn;
      modify_downline_connection (osmsg, 0, abort);
{ issue network list off for the connection
      form_sm(osmsg,iic$sm_list_off,iic$l_list_off);
      osmsg^.list_off.connection_number := acn;
      modify_downline_connection (osmsg, 0, abort);
{ issue network list switch for this connection
      form_sm (osmsg, iic$sm_list_switch, iic$l_list_switch);
      osmsg^.list_switch.connection_number := acn;
      osmsg^.list_switch.new_list_number := iic$normal_input_list_number;
      modify_downline_connection (osmsg, 0, abort);
{ issue another list off request for this connection
      form_sm(osmsg, iic$sm_list_off, iic$l_list_off);
      osmsg^.list_off.connection_number := acn;
      modify_downline_connection (osmsg, 0, abort);
{ let nos/ve know that the connection is initialized
      send_upline_sm (msg, iic$l_initialized_connection, acn,
            connection_currency [acn].application_name_jm, abort);
      connection_currency [acn].connection_state := connection_currency [acn].
            connection_state - $iit$connection_state [wait_init];
    ? IF ifv$nos_be = true THEN
    ?? SET(LIST:=OFF) ??
    ? ELSE
    = iic$sm_start_output =
      acn := msg^.start_output.connection_number;
{
{ dont clear stopped state until nos/ve sends reset connection
{
      send_upline_sm (msg, iic$l_start_output, acn, connection_currency [acn].
            application_name_jm, abort);
    = iic$sm_shutdown =
      IF msg^.shutdown.immediate THEN
        abort := shutdown;
        RETURN;
      ELSE
        send_upline_sm (msg, iic$l_shutdown, iic$exec_acn,
              iic$exec_application_name, abort);
      IFEND;
    = iic$sm_block_delivered =
      acn := msg^.block_delivered.connection_number;
      IF connection_currency [acn].unacknowledged_block_count > 0 THEN
      connection_currency [acn].unacknowledged_block_count :=
            connection_currency [acn].unacknowledged_block_count - 1;
      IFEND;

{ If ubc is zero and this connection is to be ended - do it.

      IF (connection_currency [acn].unacknowledged_block_count = 0) AND
            (connection_currency [acn].connection_end_pending) THEN
        PUSH osmsg;
        form_sm (osmsg, iic$sm_end_connection, iic$l_end_connection);
        osmsg^.conend_connection_number := acn;
        osmsg^.conend_fill1 := 0;
        osmsg^.conend_zero2 := conend_zero2;
        net#put (osmsg);
      {!log_vrbl ('delayed end connection', acn, job_dayfile, FALSE);
      IFEND;
    = iic$sm_inactive_connection =
      acn := msg^.inactive_connection.connection_number;
      send_upline_sm (msg, iic$l_inactive_connection, acn, connection_currency
            [acn].application_name_jm, abort);
    = iic$sm_block_not_delivered =
      acn := msg^.block_not_delivered.connection_number;
      IF connection_currency [acn].unacknowledged_block_count > 0 THEN
      connection_currency [acn].unacknowledged_block_count :=
            connection_currency [acn].unacknowledged_block_count - 1;
      IFEND;

{ If ubc is zero and this connection is to be ended - do it.

      IF (connection_currency [acn].unacknowledged_block_count = 0) AND
            (connection_currency [acn].connection_end_pending) THEN
        PUSH osmsg;
        form_sm (osmsg, iic$sm_end_connection, iic$l_end_connection);
        osmsg^.conend_connection_number := acn;
        osmsg^.conend_fill1 := 0;
        osmsg^.conend_zero2 := conend_zero2;
        net#put (osmsg);
      {!log_vrbl ('delayed end connection', acn, job_dayfile, FALSE);
      IFEND;
    = iic$sm_term_char_changed =
      acn := msg^.term_char_redefined.connection_number;
      send_upline_sm (msg, iic$l_term_char_redefined, acn, connection_currency
            [acn].application_name_jm, abort);
    ? IFEND
    ?? SET(LIST:=ON) ??
    = iic$sm_interrupt_user =
      acn := msg^.interrupt_user.connection_number;
      send_upline_sm (msg, iic$l_interrupt_user, acn, connection_currency
            [acn].application_name_jm, abort);
      IF (absentee_read IN connection_currency [acn].connection_state) AND
            (msg^.interrupt_user.alpha < CHR (5)) THEN
{
{ remove absentee read from passon environment - but do not send read reject
{
        connection_currency [acn].connection_state := connection_currency
              [acn].connection_state - $iit$connection_state [absentee_read];
      ? IF ifv$nos_be = false THEN
        PUSH osmsg;
        form_sm (osmsg, iic$sm_list_off, iic$l_list_off);
        osmsg^.list_off.connection_number := acn;
        net#put (osmsg);
      ? IFEND
      IFEND;
    = iic$sm_reset_connection =

{ Enable outputting (disabled by an FC/BRK/R).

      acn := msg^.reset_connection.connection_number;
      connection_currency [acn].connection_state := connection_currency [acn].
            connection_state - $iit$connection_state [break_active];
    ELSE
      abort := input_sm;
      dump (abort, #LOC (msg^), 20);
    ? IF ifv$nos_be = true THEN
      IF dump_indicator THEN
         dump_mem (21,abort);
      IFEND;
    ? IFEND
      RETURN;
    CASEND;
  PROCEND modify_upline_connection_status;
?? OLDTITLE ??
?? NEWTITLE := '    procedure modify_downline_connection' ??
?? EJECT ??
{  The purpose of this procedure is to process downline supervisory messages
{    sent from nos/ve to nam.  Certain modifications are made to the
{    passon environment before the message is sent to nam.  Some messages
{    are never sent to nam, as they are meant only for use by passon.

  PROCEDURE modify_downline_connection (msg: ^iit$output_supervisory_message;
        from_application: mlt$application_name;
    VAR abort: iit$passon_failure);

    VAR
    ? IF ifv$nos_be = true THEN
      lng : integer,
      ex : tint$connection_ext,
      user_id : tint$user_id,
      qtr : ^tint$out_table,
    ? IFEND
      osm: iit$output_supervisory_message,
      acn: iit$application_connection_num,
      rle: mlt$receive_index,
      notify,
      begin_absentee: boolean,
      newjm,
      oldjm: mlt$application_name,
      qp: ^iit$sm_queue;

  ? IF ifv$nos_be = true THEN
    IF nam_debug AND (nr_msg>0) THEN
       lng := msg^.header.text_length + 1;
       nr_msg := nr_msg - 1;
       savemsg (msg,lng,2);
    IFEND;
  ? IFEND
  {!log_vrbl (' downline sm ', msg^.message_type, job_dayfile, FALSE);
  {!log_vrbl (' from appl ', from_application, job_dayfile, FALSE);
  {!log_vrbl (' acn ', msg^.connection_accepted.connection_number, job_dayfile,
  {!      FALSE);
    CASE msg^.message_type OF
    = iic$sm_end_connection =
      acn := msg^.conend_connection_number;
    ? IF ifv$nos_be = false THEN
      IF absentee_read IN connection_currency [acn].connection_state THEN
        form_sm (#LOC (osm), iic$sm_list_off, iic$l_list_off);
        osm.list_off.connection_number := acn;
        net#put (#LOC (osm));
      IFEND;
    ? IFEND
      connection_currency [acn].connection_state := connection_currency [acn].
            connection_state + $iit$connection_state [connection_ending] -
            $iit$connection_state [absentee_read];
    ? IF ifv$nos_be = false THEN
      IF connection_currency [acn].unacknowledged_block_count = 0 THEN
        net#put (msg);
      ELSE
    ? IFEND

{ Delay the end connection until all blocks have been ack'd.

        connection_currency [acn].connection_end_pending := TRUE;
    ? IF ifv$nos_be = false THEN
     {! log_vrbl ('end connection delayed', acn, job_dayfile, FALSE);
      IFEND;
    ? IFEND

{ Formerly, there was a receive message here to discard any output
{ destined to this acn.  This did not work.  Now we rely
{ on a connection_state of connection_ending to throw data away in
{ procedure send_downline_data. DAH.

    = iic$sm_connection_rejected =
      acn := msg^.connection_rejected.connection_number;
      IF connection_currency [acn].connection_state <> $iit$connection_state
            [wait_connection] THEN
        IF connection_currency [acn].connection_state <> $iit$connection_state
              [wait_connection, broken_connection] THEN
          abort := reject_failure;
          dump (abort, #LOC (connection_currency [acn]), #SIZE
                (connection_currency [acn]));
          RETURN;
        IFEND;
      IFEND;
    ? IF ifv$nos_be = false THEN
      net#put (msg);
    ? ELSE
      connection_currency[acn].connection_ext :=
                 connection_currency[acn].connection_ext
               + $tint$connection_ext[connection_rejected];
    ? IFEND;
      connection_currency [acn].connection_state := $iit$connection_state
            [available_for_use];
    = iic$sm_connection_accepted =
      acn := msg^.connection_accepted.connection_number;
      IF connection_currency [acn].connection_state <> $iit$connection_state
            [wait_connection] THEN
        IF connection_currency [acn].connection_state <> $iit$connection_state
              [wait_connection, broken_connection] THEN
          abort := accept_failure;
          dump (abort, #LOC (connection_currency [acn]), #SIZE
                (connection_currency [acn]));
          RETURN;
        IFEND;
      IFEND;
      connection_currency [acn].application_name_jm := from_application;
    ? IF ifv$nos_be = false THEN
      connection_currency [acn].unacknowledged_block_count := 0;
    ? IFEND
      connection_currency [acn].connection_state := connection_currency [acn].
            connection_state - $iit$connection_state [wait_connection] +
            $iit$connection_state [wait_init];
    ? IF ifv$nos_be = false THEN
      net#put (msg);
    ? ELSE
      IF msg^.connection_accepted.character_type <>
                                   iic$8_of_12_bit_characters THEN
         abort := char_type_failed;
         IF dump_indicator THEN
            dump_mem (22,abort);
         IFEND;
         RETURN;
      IFEND;
      connection_currency[acn].connection_ext :=
                 connection_currency[acn].connection_ext
               + $tint$connection_ext[wait_int];
    ? IFEND
    = iic$sm_connection_initialized =
      acn := msg^.connection_initialized.connection_number;
      IF connection_currency [acn].connection_state <> $iit$connection_state
            [wait_init] THEN
        IF connection_currency [acn].connection_state <> $iit$connection_state
              [wait_connection, broken_connection] THEN
          abort := init_failure;
          dump (abort, #LOC (connection_currency [acn]), #SIZE
                (connection_currency [acn]));
          RETURN;
        IFEND;
      IFEND;
      connection_currency [acn].connection_state := connection_currency [acn].
            connection_state - $iit$connection_state [wait_init];
    ? IF ifv$nos_be = false THEN
      net#put (msg);
    ? ELSE
      IF init_req IN connection_currency[acn].connection_ext THEN
         connection_currency[acn].connection_ext :=
                    connection_currency[acn].connection_ext
                  - $tint$connection_ext[init_req]
                  + $tint$connection_ext[init_accept];
      ELSE
         abort := init_req_failed;
         IF dump_indicator THEN
            dump_mem (23,abort);
         IFEND;
      IFEND;
    ? IFEND
    ? IF ifv$nos_be = false THEN
    = iic$sm_reset_connection =
      acn := msg^.reset_connection.connection_number;
      connection_currency [acn].connection_state := connection_currency [acn].
            connection_state - $iit$connection_state [break_active, stopped];
      net#put (msg);
    ? IFEND
    = iic$sm_hold =
      acn := msg^.hold.connection_number;
{
{ send hold acknowledge - hold takes affect when acknowledge is sent to
{   the nos/ve task.
{
      form_sm (msg, iic$sm_hold_acknowlege, iic$l_hold_acknowlege);
      send_upline_sm (#LOC (msg^), iic$l_hold_acknowlege, acn,
            connection_currency [acn].application_name_jm, abort);
    = iic$sm_terminate =
      {Job is terminating - ignore all io traffic
      acn := msg^.terminate.connection_number;
      log_vrbl ('Job termination requested', acn, job_dayfile, FALSE);
      connection_currency [acn].connection_state := connection_currency [acn].
            connection_state + $iit$connection_state [terminate];
    ? IF ifv$nos_be = false THEN
      IF absentee_read IN connection_currency [acn].connection_state THEN
        connection_currency [acn].connection_state := connection_currency
              [acn].connection_state - $iit$connection_state [absentee_read];
        form_sm (msg, iic$sm_list_off, iic$l_list_off);
        msg^.list_off.connection_number := acn;
        net#put (msg);
      IFEND;
      connection_currency [acn].unacknowledged_block_count := 0;
    ? IFEND
    = iic$sm_unhold =
      acn := msg^.unhold.connection_number;
      connection_currency [acn].connection_state := connection_currency [acn].
            connection_state - $iit$connection_state [connection_hold];
    = iic$sm_read_request =
      acn := msg^.read_request.connection_number;
      begin_absentee := msg^.read_request.begin_absentee;
      notify := msg^.read_request.notify_if_absentee_started;
    ? IF ifv$nos_be = true THEN
      ex := connection_currency[acn].connection_ext;
      IF ex*$tint$connection_ext[input_available,input_suppress,input_req]
         = $tint$connection_ext[] THEN
         downline_sm (acn,cint$termout_ico);
      IFEND;
    ? IFEND
      begin_data_read (acn, begin_absentee, notify, from_application, abort);
    = iic$sm_change_job_monitor =
      acn := msg^.changejm_connection_number;
      newjm := msg^.changejm_new_jm;
      oldjm := connection_currency [acn].application_name_jm;
      connection_currency [acn].application_name_jm := newjm;
      qp := connection_currency [acn].front_queued_sm_ptr;
      WHILE qp <> NIL DO
        IF qp^.application_name = oldjm THEN
          qp^.application_name := newjm;
        IFEND;
        qp := qp^.front;
      WHILEND;
{
{ force unhold here
{
      connection_currency [acn].connection_state := connection_currency [acn].
            connection_state - $iit$connection_state [connection_hold];
      form_sm (msg, iic$sm_job_monitor_changed, iic$l_job_monitor_changed);
      send_upline_sm (#LOC (msg^), iic$l_job_monitor_changed, acn, newjm,
            abort);
    = iic$sm_stop_interactive =
      abort := nosve_stop_interactive;
      RETURN;
    ? IF ifv$nos_be = false THEN
    = iic$sm_redefine_term_char, iic$sm_start_input, iic$sm_stop_input,
          iic$sm_change_character_type, iic$sm_list_on,
            iic$sm_list_switch, iic$sm_message_to_operator,
            iic$sm_interrupt_response =
      net#put (msg);
    = iic$sm_break =

{ Inhibit outputting until an FC/RST/R is received. }

      acn := msg^.break.connection_number;
      connection_currency [acn].connection_state := connection_currency [acn].
            connection_state + $iit$connection_state [break_active];
      connection_currency [acn].unacknowledged_block_count := 0;
      net#put (msg);
    = iic$sm_list_off =
      acn := msg^.list_off.connection_number;
      connection_currency[acn].connection_state :=
                 connection_currency[acn].connection_state
               - $iit$connection_state[absentee_read];
      net#put (msg);
    ? ELSE
    = iic$sm_list_off =
      acn := msg^.list_off.connection_number;
      connection_currency[acn].connection_state :=
                 connection_currency[acn].connection_state
               - $iit$connection_state[absentee_read];
    = iic$sm_list_on,iic$sm_list_switch =
    = iic$sm_interrupt_response =
      acn := msg^.interrupt_response.connection_number;
      IF user_break_as IN connection_currency[acn].connection_ext THEN
         connection_currency[acn].connection_ext :=
                    connection_currency[acn].connection_ext
                  + $tint$connection_ext[user_break_akn]
                  - $tint$connection_ext[user_break_as];
      ELSE
         abort := break_req_failed;
         IF dump_indicator THEN
            dump_mem (24,abort);
         IFEND;
      IFEND;
    = iic$sm_break =
{     iic$sm_break is treated as a NO-OP in nosbe.
    ? IFEND
    = iic$sm_start_interactive =
      log (' start interactive on the fly ', job_dayfile, FALSE);
      form_sm (msg, iic$sm_interactive_started, iic$l_interactive_started);
      send_upline_sm (#LOC (msg^), iic$l_interactive_started, iic$exec_acn,
            iic$exec_application_name, abort);
    ELSE
      abort := bad_downline_sm;
      dump (abort, #LOC (msg^), 20);
    ? IF ifv$nos_be = true THEN
      IF dump_indicator THEN
         dump_mem (25,abort);
      IFEND;
    ? IFEND
      RETURN;
    CASEND;
  PROCEND modify_downline_connection;
?? OLDTITLE ??
?? NEWTITLE := ' nam passon main program' ??
?? EJECT ??
{
{  PASSON MAIN PROGRAM
  ?IF ifv$module_for_c180 = FALSE THEN

    PROGRAM nam_passon;
  ?ELSE

    PROCEDURE [XDCL, #GATE] nam_passon;
    ?IFEND
  ? IF ifv$nos_be = false THEN
    getword (0, #LOC (ra_word_0));
  ? ELSE
    idle_last := false;
    idle_down := false;
    shut_last := false;
    shut_down := false;
    connct;
    callmuj (#LOC(com));
    setup (#LOC(analyst_id),nr_msg,#LOC(msg),
           #LOC(connection_currency[0]),#LOC(com));
    IF nr_msg <> 0 THEN
       get_debug_directives (#LOC(msg));
       dump_indicator := ra_word_0.sw4;
    IFEND;
    i := 0;
  ? IFEND
    mli_debug := ra_word_0.sw3;
    nam_debug := ra_word_0.sw1;
    passon_debug := ra_word_0.sw2;
    pacer_kludge_enabled := ra_word_0.sw4;
  ? IF ifv$nos_be THEN
    trace_mli := mli_debug AND nam_debug;
  ? IFEND
    IF mli_debug THEN
      initmli (1);
    ELSE
      initmli (0);
    IFEND;

  /continue_passon_after_shutdown/
    WHILE TRUE DO
    /passon/
      BEGIN
        msg_displayed := FALSE;

      /signon/
        WHILE TRUE DO
          mlp$sign_on (iic$passon_application_name, mlc$max_queued_messages,
                unique, status);
          IF (status.condition IN mli_retry_status) OR (status.condition =
                mlc$nosve_not_up) THEN
            IF NOT msg_displayed THEN
              log (' waiting for nos/ve    ', b_display, FALSE);
              msg_displayed := TRUE;
            IFEND;
          ? IF ifv$nos_be = true THEN
            IF status.condition = mlc$nosve_not_up THEN
               i := i + 1;
               IF i = 20 THEN
                  no_nosve;
                  EXIT /passon/;
               IFEND;
            IFEND;
          ? IFEND
            pause (long_pause);
            CYCLE /signon/;
          IFEND;
          IF status.condition IN mli_fatal_status THEN
            abort := signon_failed;
            dump (abort, #LOC (status), #SIZE (status));
          ? IF ifv$nos_be = true THEN
            no_nosve;
          ? IFENd
            EXIT /passon/;
          IFEND;
          EXIT /signon/;
        WHILEND /signon/;

      /addspl/
        WHILE TRUE DO
          mlp$add_sender (iic$passon_application_name, mlc$null_name, status);
          IF status.condition IN mli_retry_status THEN
            pause (short_pause);
            CYCLE /addspl/;
          IFEND;
          IF status.condition IN mli_fatal_status THEN
            abort := addspl_failed;
            dump (abort, #LOC (status), #SIZE (status));
          ? IF ifv$nos_be = true THEN
            no_nosve;
          ? IFEND
            EXIT /passon/;
          IFEND;
          EXIT /addspl/;
        WHILEND /addspl/;
        log (' c180/mli connected', job_dayfile, FALSE);

  { send start interactive to exec (in case this is a passon restart)

        REPEAT
          abort := okee_dokee;
          form_sm (#LOC (msg), iic$sm_start_interactive,
                iic$l_start_interactive);
          mlp$send_message (iic$passon_application_name,
                iic$input_supervisory_message, signal, #LOC (msg),
                (iic$l_start_interactive + 1) * iic$mli_multiplier,
                iic$exec_application_name, status);
          IF status.condition <> mlc$ok THEN
            log (' waiting for exec', b_display, FALSE);
            pause (long_pause);
          IFEND;
        UNTIL status.condition = mlc$ok;
        msg_displayed := FALSE;

      /wait_exec/
        WHILE TRUE DO
          mlp$receive_message (iic$passon_application_name, arbinfo, signal, #LOC
                (msg), length_returned, #SIZE (msg), 0, nosve_application,
                status);
          IF status.condition IN mli_retry_status THEN
            IF NOT msg_displayed THEN
              log (' waiting for exec', b_display, FALSE);
              msg_displayed := TRUE;
            IFEND;
            pause (long_pause);
            CYCLE /wait_exec/;
          IFEND;
          IF status.condition IN mli_fatal_status THEN
            abort := waiting_exec;
            dump (abort, #LOC (status), #SIZE (status));
          ? IF ifv$nos_be = true THEN
            no_nosve;
          ? IFEND
            EXIT /passon/;
          IFEND;
          IF (arbinfo <> iic$output_supervisory_message) OR (nosve_application <>
                iic$exec_application_name) THEN
            log (' wait exec - garbage ignored ', job_dayfile, FALSE);
            CYCLE /wait_exec/;
          IFEND;
          posm := #LOC (msg);
          IF posm^.message_type <> iic$sm_start_interactive THEN
            log (' wait exec - garbage ignored ', job_dayfile, FALSE);
            CYCLE /wait_exec/;
          IFEND;
          EXIT /wait_exec/;
        WHILEND /wait_exec/;
        log (' exec connected ', job_dayfile, FALSE);
        msg_displayed := FALSE;

    ?  IF ifv$nos_be = true THEN
    ?? SET(LIST:=OFF) ??
    ?  ELSE
      /wait_neton/
        WHILE TRUE DO
          net#on (nam_application_name, #LOC (comm_word), #LOC (nam_status),
                iic$min_connection_number, iic$passon_max_cn);
          IF nam_status <> 0 THEN
            log_vrbl (' nam status ', nam_status, job_dayfile, FALSE);
            IF NOT msg_displayed THEN
              log (' waiting for network', b_display, FALSE);
              msg_displayed := TRUE;
            IFEND;
            pause (long_pause);
            CYCLE /wait_neton/;
          ELSE
            EXIT /wait_neton/;
          IFEND;
        WHILEND /wait_neton/;
        IF nam_debug THEN
          net#dbg (0, 0, #LOC (i));
          IF i <> 0 THEN
            abort := netdbg_failed;
            EXIT /passon/;
          IFEND;
          net#stc (0, #LOC (i));
          IF i <> 0 THEN
            abort := netstc_failed;
            EXIT /passon/;
          IFEND;
        IFEND;
      ? IFEND
      ?? SET(LIST:=ON) ??
        form_sm (#LOC (msg), iic$sm_interactive_started,
              iic$l_interactive_started);
        send_upline_sm (#LOC (msg), iic$l_interactive_started, iic$exec_acn,
              iic$exec_application_name, abort);
        IF abort <> okee_dokee THEN
        ? IF ifv$nos_be = true THEN
          no_nosve;
        ? IFEND
          EXIT /passon/;
        IFEND;
  {
  { Begin PASSON processing
  {
        log (' passon passing ', b_display, FALSE);

      /main_loop/
        WHILE TRUE DO
          work_done := FALSE;
        ? IF ifv$nos_be = true THEN
          termin_search;
          IF abort <> okee_dokee THEN
             set_passon_abnormal (abort);
             IF abort <> okee_dokee THEN
                EXIT /passon/;
             IFEND;
          IFEND;
          connection_tour;
          IF abort <> okee_dokee THEN
             set_passon_abnormal (abort);
             IF abort <> okee_dokee THEN
                EXIT /passon/;
             IFEND;
          IFEND;
        ?? SET(LIST:=OFF) ??
        ? ELSE
          ?IF ifv$module_for_c180 = TRUE THEN
            IF comm_word [sm_available] THEN
          ?ELSE
            REPEAT
            ?IFEND
            { must ALWAYS make this call - to update
            { comm_word [input_avail] - used below.
            fetch_upline_sm (#LOC (msg), abort);
            IF abort <> okee_dokee THEN
              IF abort = shutdown THEN
                EXIT /passon/;
              IFEND;
              set_passon_abnormal (abort);
              IF abort <> okee_dokee THEN
                EXIT /passon/;
              IFEND;
            IFEND;
            ?IF ifv$module_for_c180 = TRUE THEN
            IFEND;
            ?ELSE
            UNTIL NOT comm_word [sm_available];
          ?IFEND
            { The following test assumes that the fetch_upline_sm call above
            { has updated comm_word.
            IF comm_word [data_available] THEN
              abort_poll := FALSE;
              REPEAT
                poll_for_absentee_reads (#LOC (msg), abort);
                IF abort <> okee_dokee THEN
                  set_passon_abnormal (abort);
                  IF abort <> okee_dokee THEN
                    EXIT /passon/;
                  IFEND;
                IFEND;
              UNTIL (NOT comm_word [data_available]) OR abort_poll;
            IFEND;
          ?  IFEND
          ?? SET(LIST:=ON) ??
          IF queued_sm_count > 0 THEN
  {
  { find next queued sm
  {

          /search_sm/
            FOR i := 0 TO iic$passon_max_cn DO
              IF connection_currency [next_queued_sm_acn].front_queued_sm_ptr <>
                    NIL THEN
                send_queued_upline_sm (next_queued_sm_acn, abort);
                work_done := TRUE;
                IF abort <> okee_dokee THEN
                  set_passon_abnormal (abort);
                  IF abort <> okee_dokee THEN
                    EXIT /passon/;
                  IFEND;
                IFEND;
                next_queued_sm_acn := (next_queued_sm_acn + 1) MOD
                      (iic$passon_max_cn + 1);
                EXIT /search_sm/;
              ELSE
                next_queued_sm_acn := (next_queued_sm_acn + 1) MOD
                      (iic$passon_max_cn + 1);
              IFEND;
            FOREND /search_sm/;
          IFEND;
          IF queued_data_count > 0 THEN
  {
  { find next queued data message
  {

          /search_data/
            FOR i := 0 TO iic$passon_max_cn DO
              IF connection_currency [next_queued_data_acn].front_queued_data_ptr
                    <> NIL THEN
                send_queued_upline_data (next_queued_data_acn, abort);
                work_done := TRUE;
                IF abort <> okee_dokee THEN
                  set_passon_abnormal (abort);
                  IF abort <> okee_dokee THEN
                    EXIT /passon/;
                  IFEND;
                IFEND;
                next_queued_data_acn := (next_queued_data_acn + 1) MOD
                      (iic$passon_max_cn + 1);
                EXIT /search_data/;
              ELSE
                next_queued_data_acn := (next_queued_data_acn + 1) MOD
                      (iic$passon_max_cn + 1);
              IFEND;
            FOREND /search_data/;
          IFEND;
          retry_count := 0;

        /downline/
          BEGIN

          /wait_fetch/
            WHILE TRUE DO
              mlp$fetch_receive_list (iic$passon_application_name, mlc$null_name,
                    receive_list, receive_count, status);
            ? IF ifv$nos_be = true THEN
              IF trace_mli AND (nr_msg>0) THEN
                 i := 4*receive_count;
                 savemsg (#LOC(receive_list),i,9);
                 nr_msg := nr_msg - 1;
              IFEND;
            ? IFEND
              IF status.condition IN mli_retry_status THEN
                retry_count := retry_count + 1;
                IF retry_count > iic$retry_count THEN
                  EXIT /downline/;
                IFEND;
                pause (short_pause);
                CYCLE /wait_fetch/;
              IFEND;
              IF status.condition IN mli_fatal_status THEN
                abort := downline_failure;
                dump (abort, #LOC (status), #SIZE (status));
                set_passon_abnormal (abort);
                IF abort <> okee_dokee THEN
                  EXIT /passon/;
                IFEND;
              IFEND;
              EXIT /wait_fetch/;
            WHILEND /wait_fetch/;
          ? IF ifv$nos_be = false THEN
            IF receive_count < 4 THEN
               MLV$MLI := 24;
            ELSEIF receive_count < 8 THEN
               MLV$MLI := 12;
            ELSE
               MLV$MLI := 8;
            IFEND;
          ? IFEND

          /process_downline/
            FOR i := 1 TO receive_count DO
  {
  { allow downline data only if abl is not exceeded
  {
              signal_180 := signal;
              IF receive_list [i].arbitrary_info >= iic$dont_signal THEN
                 receive_list [i].arbitrary_info := receive_list [i].arbitrary_info -
                    iic$dont_signal;
                 signal_180 := NIL;
              IFEND;
              IF receive_list [i].arbitrary_info >= iic$output_data_message THEN
                j := receive_list [i].arbitrary_info - iic$output_data_message;
              ? IF ifv$nos_be = false THEN
                IF (connection_currency [j].unacknowledged_block_count >=
                      connection_currency [j].application_block_limit) THEN
              ? ELSE
                IF (user_break_out IN connection_currency[j].connection_ext) OR
                   (output_wait IN connection_currency[j].connection_ext) THEN
                   IF trace_mli AND (nr_msg>0) THEN
                      savemsg(#LOC(connection_currency[j].connection_ext),1,11);
                      nr_msg := nr_msg - 1;
                   IFEND;
              ? IFEND
                  CYCLE /process_downline/;
                IFEND;

                IF connection_currency [j].connection_state>= $iit$connection_state [wait_init] THEN
                  CYCLE /process_downline/;
                IFEND;

                IF (connection_currency [j].connection_state * $iit$connection_state [break_active]) <>
                      $iit$connection_state [] THEN
                    CYCLE /process_downline/;
                IFEND;

              IFEND;
              receive_index := receive_list [i].receive_index;
              retry_count := 0;

            /wait_downline/
              WHILE TRUE DO
                mlp$receive_message (iic$passon_application_name, arbinfo,
                      signal_180, #LOC (msg), length_returned, #SIZE (msg),
                      receive_index, nosve_application, status);
              ? IF ifv$nos_be = true THEN
                IF trace_mli AND (nr_msg>0) THEN
                   savemsg (#LOC(msg),1,10);
                   nr_msg := nr_msg - 1;
                IFEND;
              ? IFEND
                IF status.condition IN mli_retry_status THEN
                  IF status.condition = mlc$receive_list_index_invalid THEN
                    EXIT /process_downline/;
                  IFEND;
                  retry_count := retry_count + 1;
                  IF retry_count > iic$retry_count THEN
                    EXIT /process_downline/;
                  IFEND;
                  pause (short_pause);
                  CYCLE /wait_downline/;
                IFEND;
                IF status.condition IN mli_fatal_status THEN
                  abort := downline_failure;
                  dump (abort, #LOC (status), #SIZE (status));
                  set_passon_abnormal (abort);
                  IF abort <> okee_dokee THEN
                    EXIT /passon/;
                  IFEND;
                IFEND;
                EXIT /wait_downline/;
              WHILEND /wait_downline/;
              work_done := TRUE;
              IF arbinfo >= iic$dont_signal THEN
                 arbinfo := arbinfo - iic$dont_signal;
              IFEND;
              IF arbinfo >= iic$output_data_message THEN
                arbinfo := iic$output_data_message;
              IFEND;
              CASE arbinfo OF
              = iic$output_data_message =
              ? IF ifv$nos_be = true THEN
                send_downline_data (#LOC(msg),#LOC(msg));
              ? ELSE
                send_downline_data (#LOC (msg));
              ? IFEND
                IF abort <> okee_dokee THEN
                  set_passon_abnormal (abort);
                  IF abort <> okee_dokee THEN
                    EXIT /passon/;
                  IFEND;
                IFEND;
              = iic$output_supervisory_message =
                modify_downline_connection (#LOC (msg), nosve_application,
                      abort);
                IF abort <> okee_dokee THEN
                  IF abort = nosve_stop_interactive THEN
                    EXIT /passon/;
                  IFEND;
                  set_passon_abnormal (abort);
                  IF abort <> okee_dokee THEN
                    EXIT /passon/;
                  IFEND;
                IFEND;
              ELSE
                abort := arbinfo_failure;
                dump (abort, #LOC (arbinfo), #SIZE (arbinfo));
                set_passon_abnormal (abort);
                IF abort <> okee_dokee THEN
                  EXIT /passon/;
                IFEND;
              CASEND;
            FOREND /process_downline/;
          END /downline/;
          IF NOT work_done THEN
            pause (short_pause);
          IFEND;
          work_done := FALSE;
          check_operator := check_operator + 1;
          IF check_operator = 50 THEN
            check_operator := 0;
            getword (0, #LOC (ra_word_0));
          ? IF ifv$nos_be = true THEN
            idle_down := ra_word_0.sw5;
            shut_down := ra_word_0.sw6;
            IF shut_down AND NOT shut_last THEN
               shut_last := true;
               FOR j := 1 TO iic$passon_max_cn DO
                 IF connection_currency[j].fet_6.user_id <> 0 THEN
                    connection_currency[j].connection_ext :=
                               connection_currency[j].connection_ext
                             + $tint$connection_ext[shut_ind];
                 IFEND;
               FOREND;
               IF NOT idle_last THEN
                  idle_down := true;
               IFEND;
            IFEND;
            IF idle_down AND NOT idle_last THEN
               idle_last := true;
               FOR j := 1 TO iic$passon_max_cn DO
                 IF connection_currency[j].fet_6.user_id <> 0 THEN
                    connection_currency[j].connection_ext :=
                               connection_currency[j].connection_ext
                             + $tint$connection_ext[idle_ind];
                 IFEND;
               FOREND;
            IFEND;
          ?? SET(LIST:=OFF) ??
          ? ELSE
            IF ra_word_0.sw1 THEN
              IF NOT nam_debug THEN
  { turn on
                nam_debug := TRUE;
                net#dbg (0, 0, #LOC (i));
                net#stc (0, #LOC (i));
              IFEND;
            ELSE
              IF nam_debug THEN
  { turn off
                nam_debug := FALSE;
                net#dbg (1, 1, #LOC (i));
                net#stc (1, #LOC (i));
              IFEND;
            IFEND;
          ? IFEND
          ?? SET(LIST:=ON) ??
            passon_debug := ra_word_0.sw2;
            IF ra_word_0.sw3 THEN
              IF NOT mli_debug THEN
  { turn on
                mli_debug := TRUE;
                initmli (1);
              IFEND;
            ELSE
              IF mli_debug THEN
  { turn off
                mli_debug := FALSE;
                initmli (0);
              IFEND;
            IFEND;
            pacer_kludge_enabled := ra_word_0.sw4;
          IFEND;
        ? IF ifv$nos_be = true THEN
          IF nam_debug AND (nr_msg=0) THEN
             savemsg (#LOC(MSG),-1,0);
             nr_msg := -1;
          IFEND;
          IF nr_of_users = 0 THEN
             end_counter := end_counter - 1;
             IF end_counter = 0 THEN
                EXIT /passon/;
             IFEND;
             pause (short_pause);
          IFEND;
        ? IFEND
        WHILEND /main_loop/;
      END /passon/;
      passon_debug := TRUE;
      IF abort <> okee_dokee THEN
        log_vrbl (' passon status', ORD (abort), job_dayfile, FALSE);
        log_vrbl (' last mli status ', status.condition, job_dayfile, FALSE);
      IFEND;
  {
  { bring PASSON down
  {
    ? IF ifv$nos_be = false THEN
      net#off;
    ? ELSE
      discon;
      mmove (#LOC(predef_asm[5]),#LOC(msg),2);
      IF nam_debug AND (nr_msg>=0) THEN
         savemsg (#LOC(MSG),-1,0);
      IFEND;
    ? IFEND
      mlp$sign_off (iic$passon_application_name, status);
      IF abort = shutdown THEN
        abort := okee_dokee;
        FOR connection_number := 1 TO iic$passon_max_cn DO

{ Make all PASSON connections available for use.

          connection_currency [connection_number].connection_state :=
                $iit$connection_state [available_for_use];
        FOREND;
      ELSE
        EXIT /continue_passon_after_shutdown/;
      IFEND;
    WHILEND /continue_passon_after_shutdown/;
    IF (abort <> okee_dokee) AND (abort <> nosve_stop_interactive) THEN
      log ('$passon failure', b_display, FALSE);
      ?IF ifv$module_for_c180 = FALSE THEN
        WHILE TRUE DO
          pause (short_pause);
        WHILEND;
      ?IFEND
    IFEND;
  PROCEND nam_passon;
MODEND iim$nam_passon
*DECK DECK=IIM$OPEN EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$open;
?? TITLE := 'MODULE iim$open' ??

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc IIK$KEYPOINTS
*copyc AMT$FILE_IDENTIFIER
*copyc AMD$OPERATION_DECLARATIONS
*copyc AME$OPEN_VALIDATION_ERRORS
*copyc amp$access_method
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc cle$ecc_lexical
*copyc CLP$CONVERT_INTEGER_TO_STRING
*copyc clp$validate_name
*copyc IIT$CONNECTION_DESCRIPTION
*copyc osp$set_status_abnormal
*copyc OSV$TASK_PRIVATE_HEAP
*copyc OSS$TASK_PRIVATE
*copyc IIP$ADD_SENDER
*copyc IIP$CLEAR_LOCK
*copyc IIP$INIT_OPEN_DESC_ATTRIBUTES
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIP$SIGN_ON
*copyc IIP$SET_LOCK
*copyc IIV$INT_TASK_OPEN_FILE_COUNT
*copyc IIV$CONNECTION_DESC_PTR
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$open', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$open (file_id: amt$file_identifier;
        open_file_desc_pointer: ^iit$open_file_description;
        file_name: amt$local_file_name;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    VAR
      call_block: amt$call_block,
      lfn: ost$name,
      clt_name: ost$name,
      fetch_file_contents_array: array [1 .. 1] of amt$fetch_item,
      max_task_count_string: ost$string,
      connection_desc_pointer: ^iit$connection_description,
      local_status: ost$status,
      valid_name: boolean;


{ Put the file name into the open file description.

    clp$validate_name (file_name, clt_name, valid_name);
    IF NOT valid_name THEN
      osp$set_status_abnormal ('CL', cle$improper_name, file_name, status);
      RETURN;
    IFEND;
    lfn := clt_name;
    open_file_desc_pointer^.file_name := lfn;

{ Initialize file access information.

    open_file_desc_pointer^.block_number := 1;
    open_file_desc_pointer^.last_get_put_operation := amc$put_next_req;
    open_file_desc_pointer^.last_access_operation := amc$open_req;
    open_file_desc_pointer^.previous_record_length := 0;

{ Put the pointer to the connection description into the open file description.

    iip$set_lock (iiv$connection_desc_lock, osc$wait, local_status);
    connection_desc_pointer := iiv$connection_desc_ptr;
    iip$clear_lock (iiv$connection_desc_lock, local_status);

    open_file_desc_pointer^.connection_desc_pointer := connection_desc_pointer;

    IF iiv$int_task_open_file_count = 0 THEN

{ Increment interactive task count.

      iip$set_lock (iiv$interactive_task_count_lock, osc$wait, local_status);
      IF iiv$interactive_task_count >= 100000 THEN
        iip$clear_lock (iiv$interactive_task_count_lock, local_status);
        clp$convert_integer_to_string (100000, 10, FALSE,
              max_task_count_string, local_status);
        amp$set_file_instance_abnormal (file_id, ame$terminal_task_limit,
              amc$open_req, max_task_count_string.value, status);
        RETURN;
      IFEND;
      iiv$interactive_task_count := iiv$interactive_task_count + 1;
      iip$clear_lock (iiv$interactive_task_count_lock, local_status);

{ Initialize access to the Memory Link.

      iip$sign_on (iiv$int_application_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      iip$add_sender (iiv$int_application_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    IFEND;

{ Initialize terminal attributes in the open file description.

    iip$init_open_desc_attributes (file_id, open_file_desc_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    open_file_desc_pointer^.terminal_mode := iic$line;
    fetch_file_contents_array [1].key := amc$file_contents;
    call_block.operation :=  amc$fetch_req;
    call_block.fetch.file_attributes := ^fetch_file_contents_array;
    amp$access_method (file_id,call_block,layer_number,status);
    open_file_desc_pointer^.format_effectors := (fetch_file_contents_array [1].file_contents = amc$list);

{ Increment task open interactive file count.

    iiv$int_task_open_file_count := iiv$int_task_open_file_count + 1;

    IF iiv$downline_data_block_ptr = NIL THEN
      ALLOCATE iiv$downline_data_block_ptr IN osv$task_private_heap^;
    IFEND;


  PROCEND iip$open;

MODEND iim$open;
*DECK DECK=IIM$PAUSE_UTILITY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Interactive Facility: Pause Utility' ??
MODULE iim$pause_utility;

{
{ PURPOSE:
{   This module contains the "pause utility" which is invoked as part
{   of the default processing for "pause break" and "terminal reconnect"
{   conditions.
{   It provides commands for resuming or terminating the current activity,
{   as well as allowing access to other SCL commands.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc ife$error_codes
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc clp$begin_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc clp$put_job_output
*copyc ifv$pause_utility_count
*copyc iip$report_status_error
*copyc osp$establish_condition_handler
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$exit
?? EJECT ??

  CONST
    pause_name = 'Pause_Utility                  ';

{ table iiv$pause_commands t=command s=local sn=oss$job_paged_literal
{ command (resume_command                 ,resc) ifp$_resume_command
{ command (terminate_command              ,terc) ifp$_terminate_command
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    iiv$pause_commands: [STATIC, READ, oss$job_paged_literal] ^clt$command_table :=
          ^iiv$pause_commands_entries,

    iiv$pause_commands_entries: [STATIC, READ, oss$job_paged_literal] array [1 .. 4] of
          clt$command_table_entry := [
          {} ['RESC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^ifp$_resume_command],
          {} ['RESUME_COMMAND                 ', clc$nominal_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^ifp$_resume_command],
          {} ['TERC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^ifp$_terminate_command],
          {} ['TERMINATE_COMMAND              ', clc$nominal_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^ifp$_terminate_command]];

?? POP ??

?? TITLE := 'iip$pause_utility', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$pause_utility
    (    ignore_program_parameters: pmt$program_parameters;
     VAR status: ost$status);

    VAR
      suspended_message: string (17),
      suspended_message_size: integer,
      utility_attributes: array [1 .. 4] of clt$utility_attribute;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_info: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      CASE condition.selector OF

      = ifc$interactive_condition =
        IF condition.interactive_condition = ifc$pause_break THEN
          RETURN {ignore pause breaks while in the "pause utility"} ;
        IFEND;

      = pmc$block_exit_processing =
        RETURN;

      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND condition_handler;
?? TITLE := 'error', EJECT ??

    PROCEDURE [INLINE] error;


      iip$report_status_error (status, 'error in pause utility');
      pmp$exit (status);

    PROCEND error;
?? TITLE := 'interactive_include_processor', EJECT ??

    PROCEDURE interactive_include_processor
      (    interaction_style: ost$interaction_style;
       VAR status: ost$status);


{ Do nothing so the utility always runs in line mode.

      status.normal := TRUE;

    PROCEND interactive_include_processor;
?? OLDTITLE, EJECT ??

    STRINGREP (suspended_message, suspended_message_size, ' *Suspended - ', ifv$pause_utility_count, '*');
    clp$put_job_output (suspended_message (1, suspended_message_size), status);
    IF NOT status.normal THEN
      error;
    IFEND;

    utility_attributes [1].key := clc$utility_command_table;
    utility_attributes [1].command_table := iiv$pause_commands;
    utility_attributes [2].key := clc$utility_termination_command;
    utility_attributes [2].termination_command := 'RESUME_COMMAND';
    utility_attributes [3].key := clc$utility_interactive_include;
    utility_attributes [3].interactive_include_processor.call_method := clc$linked_call;
    utility_attributes [3].interactive_include_processor.proc := ^interactive_include_processor;
    utility_attributes [4].key := clc$utility_prompt;
    utility_attributes [4].prompt.size := 1;
    utility_attributes [4].prompt.value := 'p';
    clp$begin_utility (pause_name, utility_attributes, status);
    IF NOT status.normal THEN
      error;
    IFEND;

    osp$establish_condition_handler (^condition_handler, FALSE);

    clp$include_file (':$LOCAL.COMMAND.1', 'p', pause_name, status);

    pmp$exit (status);

  PROCEND iip$pause_utility;
?? TITLE := 'ifp$_resume_command', EJECT ??

  PROCEDURE ifp$_resume_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$p_resc) resume_command, resc (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [90, 3, 1, 17, 45, 17, 769],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'OSM$P_RESC'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    pmp$exit (status);

  PROCEND ifp$_resume_command;
?? TITLE := 'ifp$_terminate_command', EJECT ??

  PROCEDURE ifp$_terminate_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$p_terc) terminate_command, terc (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [90, 3, 1, 17, 44, 11, 274],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'OSM$P_TERC'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    osp$set_status_condition (ife$terminate_break_received, status);
    pmp$exit (status);

  PROCEND ifp$_terminate_command;

MODEND iim$pause_utility;
*DECK DECK=IIM$PUT EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$put;
?? TITLE := 'MODULE iim$put' ??

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMD$OPERATION_DECLARATIONS
*copyc AMT$TERM_OPTION
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc amp$put_next
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc IIK$KEYPOINTS
*copyc IIT$INTERACTIVE_SIGNAL_TYPE
*copyc IIP$BUILD_DATA_MSG_SKELETON
*copyc iip$build_term_char_values
*copyc IIP$CLEAR_LOCK
*copyc IIP$FLUSH
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIP$REPORT_STATUS_ERROR
*copyc IIP$SET_LOCK
*copyc IIV$INT_TASK_OPEN_FILE_COUNT
*copyc IIV$CONNECTION_DESC_PTR
*copyc IIP$UPDATE_OPEN_DESC_ATTRIBUTES
*copyc I#MOVE
*copyc I#COMPARE
*copyc OST$STATUS
*copyc OSP$TEST_SIG_LOCK
*copyc IIP$SEND_OUTPUT_MESSAGE
*copyc pmp$task_debug_mode_on
*copyc iiv$output
*copyc osp$establish_condition_handler
*copyc osp$set_status_from_condition
*copyc pmp$continue_to_cause
*copyc pmp$log
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$put', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$put (file_id: amt$file_identifier;
        open_file_desc_pointer: ^iit$open_file_description;
        operation: amt$fap_operation;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
        byte_address: ^amt$file_byte_address;
        term_option: amt$term_option;
    VAR status: ost$status);

    VAR
      saved_attributes: iit$connection_attributes,
      saved_build_msg: boolean,
      saved_effectors: boolean,
      save_last_term_option: amt$term_option,
      direct_move,
      wait,
      flush_output: boolean,
      iiv$last_output_time,
      iiv$output_option: [XREF] integer,
      po: ^iit$output,
      put_byte_address: amt$file_byte_address,
      current_transfer_count: amt$transfer_count,
      ol,
      move_length: 0..0ffffffffffff(16),
      ps1,
      ps2: ^string (15),
      working_storage_array_pointer: ^array [0 .. iic$max_record_length] of
        char,
      downline_queue_entry_descriptor: iit$queue_entry_descriptor,
      c180_downline_queue_entry_ptr: ^iit$downline_queue_entry,
      c180_downline_text_length: iit$text_length,
      ls: ost$signature_lock_status,
      temp: iit$field_value,
      local_status: ost$status;

    PROCEDURE handle_condition (cond: pmt$condition;
          cd: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR ch_status: ost$status);

      ch_status.normal := TRUE;

      IF (cond.selector = pmc$user_defined_condition) AND
            (cond.user_condition_name = 'OSC$JOB_RECOVERY') THEN
        pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
        RETURN;
      IFEND;

      IF cond.selector <> ifc$interactive_condition THEN
        osp$set_status_from_condition ('IF', cond, sa, status, local_status);
        IF NOT local_status.normal THEN
          status := local_status;
        IFEND;
        pmp$log ('Possible invalid user parameter detected by interactive', local_status);
        osp$test_sig_lock (iiv$downline_queue_lock, ls);
        IF ls = osc$sls_locked_by_current_task THEN
          IF po <> NIL THEN
            RESET iiv$output TO po;
          IFEND;
          iip$clear_lock (iiv$downline_queue_lock, local_status);
        IFEND;
        EXIT iip$put;
      ELSE

{ Clear the lock for interactive conditions

        osp$test_sig_lock (iiv$downline_queue_lock, ls);
        IF ls = osc$sls_locked_by_current_task THEN
          IF po <> NIL THEN
            RESET iiv$output TO po;
          IFEND;
          iip$clear_lock (iiv$downline_queue_lock, local_status);
        IFEND;
        pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);

{ If we get control back, pretend the put request was completed okay and exit.

        status.normal := TRUE;
        EXIT iip$put;
      IFEND;
    PROCEND handle_condition;

?? EJECT ??



    osp$test_sig_lock (iiv$downline_queue_lock, ls);
    IF (ls = osc$sls_locked_by_current_task) OR iiv$interactive_terminated THEN

{ some sort of unintended recursion has occured (due to break, escape,
{ task/job termination, etc.  return with normal status.

      status.normal := TRUE;
      RETURN;
    IFEND;
    status.normal := TRUE;

{ Return an error if at end of record and the operation is a
{ put partial continue.

    IF (iiv$put_info.last_term_option = amc$terminate) AND (term_option =
          amc$continue) THEN
      amp$set_file_instance_abnormal (file_id, ame$improper_continue,
            operation, '', status);
      RETURN;
    IFEND;

{ Terminate the previous record if at mid-record and the operation
{ is a full put or a put partial start.

    IF (iiv$put_info.last_term_option <> amc$terminate) AND ((operation =
          amc$put_next_req) OR (operation = amc$put_direct_req) OR (term_option
          = amc$start)) THEN
      iip$put (file_id, open_file_desc_pointer, amc$put_partial_req, NIL, 0,
            byte_address, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  { Detect context switching and, if needed, blank the screen.

    IF (iiv$previous_mode = iic$screen) AND
          ((open_file_desc_pointer^.terminal_mode = iic$line) OR (file_id.ordinal <>
          iiv$previous_file_id.ordinal)) THEN
      iiv$previous_mode := iic$line;
      IF NOT iiv$previous_blank_flag THEN
        iiv$previous_blank_flag := TRUE;
        saved_attributes := open_file_desc_pointer^.attributes;
        saved_build_msg := iiv$put_info.build_msg_block;
        saved_effectors := open_file_desc_pointer^.format_effectors;
        open_file_desc_pointer^.attributes := iiv$previous_connection_attr;
        open_file_desc_pointer^.format_effectors := FALSE;
        iiv$put_info.build_msg_block := FALSE;
        iip$build_term_char_values (open_file_desc_pointer);
        iip$put (file_id, open_file_desc_pointer, amc$put_next_req,
          #LOC (iiv$screen_clear_string.value), iiv$screen_clear_string.size,
          ^put_byte_address, amc$terminate, status);
        open_file_desc_pointer^.attributes := saved_attributes;
        open_file_desc_pointer^.format_effectors := saved_effectors;
        iiv$put_info.build_msg_block := saved_build_msg;
        iip$build_term_char_values (open_file_desc_pointer);
      IFEND;
    IFEND;

    iiv$previous_blank_flag := FALSE;
    IF open_file_desc_pointer^.terminal_mode = iic$line THEN
      iiv$previous_mode := iic$line;
    IFEND;
    iiv$previous_operation := operation;
    iiv$previous_file_id := file_id;

    po := NIL;
    direct_move := FALSE;
    flush_output := FALSE;
    current_transfer_count := 0;
    iiv$put_info.transfer_count := working_storage_length;
    osp$establish_condition_handler (^handle_condition, FALSE);

{ Transfer data from the user's working storage area to the downline queue.

  /transfer_data_to_downline_queue/
    WHILE TRUE DO

{ Determine the amount of data to move.

      IF working_storage_length > 0 THEN
        move_length := working_storage_length - current_transfer_count;
        IF (move_length + (iiv$put_info.position_in_block - 1)) >
              iic$max_block_size - 9 THEN
          move_length := (iic$max_block_size - 9) - (iiv$put_info.
                position_in_block - 1);
        IFEND;

{ Move the data from the working storage area to a task local downline block.

        working_storage_array_pointer := working_storage_area;
        IF (iiv$put_info.position_in_block <> 1) OR (term_option <>
          amc$terminate) THEN
          i#move (#LOC (working_storage_array_pointer^ [current_transfer_count]),
                #LOC (iiv$downline_data_block_ptr^.data [iiv$put_info.
                position_in_block]), move_length);
        ELSE
          direct_move := TRUE;
        IFEND;

{ Update transfer counts.

        current_transfer_count := current_transfer_count + move_length;
        iiv$put_info.position_in_block := iiv$put_info.position_in_block +
              move_length;
        iiv$put_info.transfer_count := iiv$put_info.transfer_count +
              move_length;

      IFEND;

{ Create a new downline queue entry.

      IF ((current_transfer_count = working_storage_length) AND (term_option =
            amc$terminate)) OR (iiv$put_info.position_in_block >
            iic$max_block_size - 9) OR direct_move THEN

      /queue_downline_block/
        WHILE TRUE DO

          iip$set_lock (iiv$downline_queue_lock, osc$nowait, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        c180_downline_text_length := iiv$put_info.position_in_block - 1;
        IF c180_downline_text_length <> 0 THEN
          ol := c180_downline_text_length;
        ELSE
          ol := 1;
        IFEND;

        NEXT po: [1 .. ol] in iiv$output;
        IF po = NIL then
            iip$clear_lock (iiv$downline_queue_lock, local_status);

            save_last_term_option := iiv$put_info.last_term_option;
            iiv$put_info.last_term_option := amc$terminate;
            iip$flush (file_id, open_file_desc_pointer, status);
            iiv$put_info.last_term_option := save_last_term_option;
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            CYCLE /queue_downline_block/;
        IFEND;

        c180_downline_queue_entry_ptr := ^po^.block;
        po^.length := ol;

        iip$build_data_msg_skeleton (^c180_downline_queue_entry_ptr^.message,
              c180_downline_text_length);

        IF open_file_desc_pointer^.format_effectors THEN
          c180_downline_queue_entry_ptr^.message.header.no_format_effectors := false;
        ELSE
          c180_downline_queue_entry_ptr^.message.header.no_format_effectors := true;
        IFEND;

        c180_downline_queue_entry_ptr^.message.header.transparent := (open_file_desc_pointer^.
              attributes.input_editing_mode.value = ifc$trans_edit);

        c180_downline_queue_entry_ptr^.term_char_null := iiv$put_info.
              term_char_null;
        c180_downline_queue_entry_ptr^.connection_ptr :=
              open_file_desc_pointer^.connection_desc_pointer;
        c180_downline_queue_entry_ptr^.repeated_output := FALSE;

        IF iiv$put_info.build_msg_block THEN
          c180_downline_queue_entry_ptr^.message.header.block_type :=
                iic$last_block;
          c180_downline_queue_entry_ptr^.message.header.transparent := FALSE;
        IFEND;

{ Update the terminal attributes of the open file description if they might
{ have changed.

        IF open_file_desc_pointer^.attributes_cycle <> open_file_desc_pointer^.
              connection_desc_pointer^.attributes_cycle THEN
          iip$update_open_desc_attributes (file_id, open_file_desc_pointer,
                operation, status);
          IF NOT status.normal THEN
            iip$clear_lock (iiv$downline_queue_lock, local_status);
            RETURN;
          IFEND;
        IFEND;
        c180_downline_queue_entry_ptr^.term_char_changed := FALSE;
        c180_downline_queue_entry_ptr^.term_char_sent := FALSE;

{ Update the connection description terminal characteristics values if
{ they have changed.

        iip$set_lock (open_file_desc_pointer^.connection_desc_pointer^.lock,
              osc$wait, local_status);

{ Save the transparency indicator for this instance-of-open.  It may be overwritten
{ in the upcoming ploy to avoid sending transparent attribute changes.

        temp := open_file_desc_pointer^.term_char_values [ iic$key_trans_input_mode ];

{ This IF statement was added to fix PSR NV02502.

        IF (NOT iiv$put_info.term_char_null) THEN
          open_file_desc_pointer^.term_char_values [ iic$key_trans_input_mode ] :=
            open_file_desc_pointer^.connection_desc_pointer^.
              term_char_values [ iic$key_trans_input_mode ];
        ELSEIF (open_file_desc_pointer^.attributes.input_editing_mode.value =
             ifc$trans_edit) THEN
          open_file_desc_pointer^.term_char_values [ iic$key_trans_input_mode ] := 1;
        IFEND;

        ps1 := #LOC (open_file_desc_pointer^.term_char_values);
        ps2 := #LOC (open_file_desc_pointer^.connection_desc_pointer^.
              term_char_values);
        IF (i#compare (ps1^, ps2^) <> 0) OR
              ((open_file_desc_pointer^.attributes.trans_character_mode.value =
               ifc$trans_char_terminate) AND (iiv$put_info.term_char_null)) THEN
          c180_downline_queue_entry_ptr^.term_char_changed := TRUE;
          c180_downline_queue_entry_ptr^.term_char_values :=
                open_file_desc_pointer^.term_char_values;
          c180_downline_queue_entry_ptr^.transparent_character_selected :=
                (open_file_desc_pointer^.attributes.
                trans_character_mode.value <> ifc$no_trans_char);
          c180_downline_queue_entry_ptr^.transparent_count_selected :=
                (open_file_desc_pointer^.attributes.
                trans_length_mode.value <> ifc$no_trans_len);
          c180_downline_queue_entry_ptr^.transparent_time_out_selected :=
                (open_file_desc_pointer^.attributes.
                trans_timeout_mode.value <> ifc$no_trans_timeout);
          open_file_desc_pointer^.connection_desc_pointer^.term_char_values :=
                open_file_desc_pointer^.term_char_values;
        IFEND;

{ Restore the transparency indicator.

        open_file_desc_pointer^.term_char_values [ iic$key_trans_input_mode ] := temp;

        iip$clear_lock (open_file_desc_pointer^.connection_desc_pointer^.lock,
              local_status);

{ Move the data from the task downline block to the downline queue entry.

        IF c180_downline_text_length > 0 THEN
          IF NOT direct_move THEN
            i#move (#LOC (iiv$downline_data_block_ptr^.data [1]), #LOC
                  (c180_downline_queue_entry_ptr^.message.data [1]),
                  c180_downline_text_length);
          ELSE
            i#move (#LOC (working_storage_array_pointer^ [current_transfer_count-move_length]),
                  #LOC (c180_downline_queue_entry_ptr^.message.data [1]),
                  c180_downline_text_length);
          IFEND;
        IFEND;

{ Add the downline queue entry to the downline queue.

          IF ((iiv$output_option <> 0) AND (iiv$output_option <
              (#free_running_clock (0) - iiv$last_output_time))) THEN
            flush_output := TRUE;
          IFEND;
          iiv$downline_queue_count := iiv$downline_queue_count + ol;
          po := NIL;
          iip$clear_lock (iiv$downline_queue_lock, local_status);
          EXIT /queue_downline_block/;

        WHILEND /queue_downline_block/;

        iiv$put_info.position_in_block := 1;

      IFEND;

      IF current_transfer_count = working_storage_length THEN
        EXIT /transfer_data_to_downline_queue/;
      IFEND;

    WHILEND /transfer_data_to_downline_queue/;

{ Save access information.

    IF flush_output THEN
      iip$send_output_message (FALSE, local_status);
    IFEND;
    open_file_desc_pointer^.last_get_put_operation := operation;
    open_file_desc_pointer^.last_access_operation := operation;
    open_file_desc_pointer^.previous_record_length := iiv$put_info.
          transfer_count;

    iiv$put_info.last_term_option := term_option;

    IF term_option = amc$terminate THEN
      iiv$put_info.transfer_count := 0;
    IFEND;


  PROCEND iip$put;

MODEND iim$put;
*DECK DECK=IIM$QUEUE_MANAGEMENT_UTILITIES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$queue_management_utilities;
?? TITLE := 'MODULE iim$queue_management_utilities' ??

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIK$KEYPOINTS
*copyc OST$STATUS
*copyc osp$system_error
?? POP ??
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIV$CONNECTION_DESC_PTR

{ WARNING:
{    THESE ROUTINES ASSUME THAT ALL REQUIRED LOCKS HAVE BEEN SET PRIOR
{    TO THEIR INVOCATION.

?? NEWTITLE := 'PROCEDURE [XDCL] iip$add_queue_entry', EJECT ??

  PROCEDURE [XDCL] iip$add_queue_entry (queue_key: iit$queue_key;
    queue_entry_descriptor: iit$queue_entry_descriptor;
    VAR status: ost$status);

    status.normal := TRUE;

    CASE queue_key OF

    = iic$connection_description =

      IF iiv$connection_desc_ptr = NIL THEN
        queue_entry_descriptor.connection_description_ptr^.next_entry := NIL;
        queue_entry_descriptor.connection_description_ptr^.previous_entry :=
          NIL;
        iiv$connection_desc_ptr := queue_entry_descriptor.
          connection_description_ptr;
      ELSE
        queue_entry_descriptor.connection_description_ptr^.next_entry :=
          iiv$connection_desc_ptr;
        iiv$connection_desc_ptr^.previous_entry := queue_entry_descriptor.
          connection_description_ptr;
        queue_entry_descriptor.connection_description_ptr^.previous_entry :=
          NIL;
        iiv$connection_desc_ptr := queue_entry_descriptor.
          connection_description_ptr;
      IFEND;

      iiv$connection_desc_count := iiv$connection_desc_count + 1;

    = iic$open_file_description, iic$terminal_request =

      status.normal := FALSE;

    = iic$downline_queue =
      osp$system_error('Interactive failure', NIL);
    = iic$repeat_queue =
      osp$system_error('Interactive failure', NIL);
    CASEND;

  PROCEND iip$add_queue_entry;

?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE [XDCL] iip$delete_queue_entry', EJECT ??

  PROCEDURE [XDCL] iip$delete_queue_entry (queue_key: iit$queue_key;
    queue_entry_descriptor: iit$queue_entry_descriptor;
    VAR status: ost$status);

    status.normal := TRUE;

    CASE queue_key OF

    = iic$connection_description =

      IF queue_entry_descriptor.connection_description_ptr^.next_entry <> NIL
        THEN
        queue_entry_descriptor.connection_description_ptr^.next_entry^.
              previous_entry := queue_entry_descriptor.
              connection_description_ptr^.previous_entry;
      IFEND;

      IF queue_entry_descriptor.connection_description_ptr^.previous_entry <>
        NIL THEN
        queue_entry_descriptor.connection_description_ptr^.previous_entry^.
          next_entry := queue_entry_descriptor.connection_description_ptr^.
          next_entry;
      IFEND;

      IF queue_entry_descriptor.connection_description_ptr^.previous_entry =
        NIL THEN
        iiv$connection_desc_ptr := queue_entry_descriptor.
          connection_description_ptr^.next_entry;
      IFEND;


      queue_entry_descriptor.connection_description_ptr^.next_entry := NIL;
      queue_entry_descriptor.connection_description_ptr^.previous_entry := NIL;

      iiv$connection_desc_count := iiv$connection_desc_count - 1;

    = iic$open_file_description, iic$terminal_request =

      status.normal := FALSE;

    = iic$downline_queue =
      osp$system_error('Interactive failure', NIL);
    = iic$repeat_queue =
      osp$system_error('Interactive failure', NIL);
    CASEND;
  PROCEND iip$delete_queue_entry;

MODEND iim$queue_management_utilities
*DECK DECK=IIM$REPORT_LOGICAL_ERROR EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE : Interactive Facility' ??
?? NEWTITLE := '  [XDCL] iip$report_logical_error' ??
MODULE iim$report_logical_error;

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIP$ASCII_170_TO_HEX
*copyc OST$STATUS
*copyc PMP$LOG
?? POP ??

?? TITLE := 'PROCEDURE [XDCL] iip$report_logical_error', EJECT ??

  PROCEDURE [XDCL] iip$report_logical_error (VAR msg:
    iit$input_supervisory_message);

    CONST
      legend_1 = 'Logical error:',
      legend_2 = 'Reason:    ',
      legend_3 = 'ABH:                ',
      legend_4 = 'WORD:                ';

    VAR
      line: string (60),
      i: integer,
      status: ost$status;

{ Log the kind of error report that is to follow

    line (1, 14) := legend_1;
    pmp$log (line (1, 14), status);

{ Log the logical error reason code

    line (1, 11) := legend_2;
    STRINGREP (line (8, 4), i, msg.errlgl_reason);
    pmp$log (line (1, 11), status);

{ Log the hex representation of the bad block header

    line (1, 20) := legend_3;
    iip$ascii_170_to_hex (msg.errlgl_bad_header, line (6, 15));
    pmp$log (line (1, 20), status);

{ Log the hex representation of the first word of the bad block

    line (1, 21) := legend_4;
    iip$ascii_170_to_hex (msg.errlgl_first_word_of_block, line (7, 15));
    pmp$log (line (1, 21), status);

  PROCEND iip$report_logical_error;
MODEND
*DECK DECK=IIM$REPORT_STATUS_ERROR EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE : Interactive Facility' ??
?? NEWTITLE := '  [XDCL, #GATE] iip$report_status_error' ??
MODULE iim$report_status_error;


{ Global External Procedure Declarations
*copyc IFV$MODULE_FOR_C180
?? SET (LIST := OFF) ??
*copyc PMP$LOG
*copyc OSP$UNPACK_STATUS_CONDITION
?? SET (LIST := ON) ??


{ Global Constants and Types
?? SET (LIST := OFF) ??
*copyc OST$STATUS
?? SET (LIST := ON) ??

?? TITLE := 'PROCEDURE [XDCL, #GATE] iip$report_status_error', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$report_status_error (VAR error_status: ost$status;
    message: string ( * ));

    CONST
      legend_1 = 'Status error on ',
      legend_2 = 'Id:   ; Cond:         ',
      legend_3 = 'Text:                                ';

    VAR
      identifier: ost$status_identifier,
      number: ost$status_condition_number,
      line: string (255),
      status: ost$status,
      i: integer;

{ Log the kind of error report that is to follow

    line (1, 16) := legend_1;
    line (17, STRLENGTH (message)) := message;
    pmp$log (line (1, 16 + STRLENGTH (message)), status);

{ Log the status id and condition code

    line (1, 22) := legend_2;
    osp$unpack_status_condition (error_status.condition, identifier, number);
    line (5, 2) := identifier;
    STRINGREP (line (14, 8), i, number);
    pmp$log (line (1, 22), status);

{ Log the status text

{   line (1, 37) := legend_3;
{   line (7, error_status.text.size) := error_status.text.value (1,
{     error_status.text.size);
{   pmp$log (line (1, 6 + error_status.text.size), status);

  PROCEND iip$report_status_error;
MODEND
*DECK DECK=IIM$REPORT_UNHANDLED_DATA_MSG EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE : Interactive Facility' ??
?? NEWTITLE := '  [XDCL] iip$report_unhandled_data_msg' ??
MODULE iim$report_unhandled_data_msg;

{ Global External System Procedures Declarations

{ Turn off the listing of pmxlogj and osdstat.

?? PUSH (LISTEXT := ON) ??
*copyc PMP$LOG
*copyc OST$STATUS
?? POP ??


{ Global Interactive Type Declarations

{ Turn off the listing of ifd180 and ifdnam.

?? PUSH (LISTEXT := ON) ??
*copyc IFV$MODULE_FOR_C180
*copyc iit$application_names_messages
?? POP ??

?? TITLE := 'PROCEDURE [XDCL] iip$report_unhandled_data_msg', EJECT ??

{  PURPOSE:
{    The purpose of this procedure is to report on an upline data message
{    which has not been handled for some reason or other.
{

  PROCEDURE [XDCL] iip$report_unhandled_data_msg (VAR msg:
    iit$input_data_message);

    CONST
      legend_1 = 'Unhandled input data message:',
      legend_2 = 'ABT:  ; ADR:     ; ABN:      ;ACT:   IBU:      ;',
      legend_3 = 'XPT:      ;CAN:      ;PEF:      ;TLC:     ;';

    VAR
      line: string (60),
      status: ost$status,
      i: integer;

{ Log the kind of error report that is to follow.

    pmp$log (legend_1, status);

    line (1, 49) := legend_2;
    STRINGREP (line (6, 1), i, msg.header.block_type);
    STRINGREP (line (14, 4), i, msg.header.connection_number);
    STRINGREP (line (24, 5), i, msg.header.block_number);
    STRINGREP (line (36, 2), i, msg.header.character_type);
    STRINGREP (line (44, 5), i, msg.header.undeliverable);

    pmp$log (line (1, 49), status);

{ Log the transparent mode, cancel input, parity error and text length.
    line (1, 43) := legend_3;
    STRINGREP (line (6, 5), i, msg.header.transparent);
    STRINGREP (line (17, 5), i, msg.header.cancel);
    STRINGREP (line (28, 5), i, msg.header.parity_error);
    STRINGREP (line (39, 4), i, msg.header.text_length);

    pmp$log (line (1, 43), status);

  PROCEND iip$report_unhandled_data_msg;

MODEND iim$report_unhandled_data_msg;
*DECK DECK=IIM$REPORT_UNHANDLED_MESSAGE EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE : Interactive Facility' ??
?? NEWTITLE := '  [XDCL] iip$report_unhandled_message' ??
MODULE iim$report_unhandled_message;


{ Global External Procedure Declarations
*copyc IFV$MODULE_FOR_C180
?? SET (LIST := OFF) ??
*copyc PMP$LOG
?? SET (LIST := ON) ??


{ Global Constants and Types
?? SET (LIST := OFF) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? SET (LIST := ON) ??

?? TITLE := 'PROCEDURE [XDCL] iip$report_unhandled_message', EJECT ??

  PROCEDURE [XDCL] iip$report_unhandled_message (msg: ^cell;
    arbinfo: mlt$arbitrary_info;
    sender_name: mlt$application_name;
    msg_length: mlt$message_length);

    CONST
      legend_1 = 'Unhandled message:',
      legend_2 = 'From:                     ',
      legend_3 = 'Arb:      ; Len:     ';

    VAR
      line: string (60),
      i: integer,
      status: ost$status;

{ Log the kind of error report to follow

    pmp$log (legend_1, status);

{ Log who sent the message

    line (1, 26) := legend_2;
    STRINGREP (line (6, 21), i, sender_name);
    pmp$log (line (1, 26), status);

{ Log: arbitrary info, message length

    line (1, 21) := legend_3;
    STRINGREP (line (5, 6), i, arbinfo);
    STRINGREP (line (17, 5), i, msg_length);
    pmp$log (line (1, 21), status);

  PROCEND iip$report_unhandled_message;
MODEND
*DECK DECK=IIM$REPORT_UNHANDLED_SUPER_MSG EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE : Interactive Facility' ??
?? NEWTITLE := '  [XDCL] iip$report_unhandled_super_msg' ??
MODULE iim$report_unhandled_super_msg;


{ Global External Procedure Declarations
*copyc IFV$MODULE_FOR_C180
?? SET (LIST := OFF) ??
*copyc PMP$LOG
?? SET (LIST := ON) ??


{ Global Constants and Types
?? SET (LIST := OFF) ??
*copyc OST$STATUS
*copyc iit$application_names_messages
?? SET (LIST := ON) ??

?? TITLE := 'PROCEDURE [XDCL] iip$report_unhandled_super_msg', EJECT ??

  PROCEDURE [XDCL] iip$report_unhandled_super_msg (VAR msg:
    iit$input_supervisory_message);

    CONST
      legend_1 = 'Unhandled input supervisory message:',
      legend_2 = 'ABT:  ; ADR:     ; ACT:   ; IBU:      ; TLC:     ',
      legend_3 = 'TYPE:      ';

    VAR
      line: string (60),
      status: ost$status,
      i: integer;

{ Log the kind of error report that is to follow

    pmp$log (legend_1, status);

{ Log the block type, address, character type, block undeliverable,
{   and text length

    line (1, 49) := legend_2;
    STRINGREP (line (5, 2), i, msg.header.block_type);
    STRINGREP (line (13, 5), i, msg.header.address);
    STRINGREP (line (24, 3), i, msg.header.character_type);
    STRINGREP (line (33, 6), i, msg.header.undeliverable);
    STRINGREP (line (45, 5), i, msg.header.text_length);
    pmp$log (line (1, 49), status);

{ Log the message block type

    line (1, 11) := legend_3;
    STRINGREP (line (6, 6), i, msg.message_type);
    pmp$log (line (1, 11), status);

  PROCEND iip$report_unhandled_super_msg;
MODEND
*DECK DECK=IIM$REQUEST_DEFAULT_ATTRIBUTES EXPAND=TRUE
*copyc osd$default_pragmats
MODULE iim$request_default_attributes;
?? TITLE := 'MODULE iim$request_default_attributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc ife$error_codes
*copyc iit$connection_description
*copyc ost$status
*copyc iip$build_super_msg_skeleton
*copyc iip$sign_on
*copyc iip$sign_off
*copyc iip$add_sender
*copyc iip$set_default_attributes
*copyc iip$clear_lock
*copyc iip$convert_upline_term_char
*copyc iip$convert_downline_term_char
*copyc iiv$interactive_terminated
*copyc iip$set_lock
*copyc iip$send_to_pass_on
*copyc iip$receive_from_pass_on
*copyc iit$vt_attribute_kinds
*copyc mld$memory_link_declarations
*copyc osp$set_status_abnormal
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$request_default_attributes', EJECT ??

  PROCEDURE [XDCL] iip$request_default_attributes (connection_desc_pointer:
    ^iit$connection_description;
    VAR status: ost$status);

    VAR
      output_supervisory_message: iit$output_supervisory_message,
      request_term_char_message: iit$output_data_message,
      upline_msg: iit$input_supervisory_message,
      appl: mlt$application_name,
      ost: ost$status,
      c170_upline_message_length,
      term_char_message_length: mlt$message_length;

    iip$sign_on (appl, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    iip$add_sender (appl, status);
    IF NOT status.normal THEN
      iip$sign_off (appl, ost);
      RETURN;
    IFEND;
    iip$set_lock (iiv$get_lock, osc$wait, status);
    IF NOT status.normal THEN
      iip$sign_off (appl, ost);
      RETURN;
    IFEND;

  /locked/
    BEGIN

{ Build a request terminal characteristics message.
{ Note: the request and response are *synchronous* messages

      IF iiv$cdcnet_connection THEN
        iip$build_super_msg_skeleton (^output_supervisory_message,
              iic$sm_cdcnet_request_term_char, iic$l_cdcnet_request_term_char + 1);
      ELSE
        iip$build_super_msg_skeleton (^output_supervisory_message,
              iic$sm_request_term_char, (iic$max_term_char_pairs * 2) + 2);
        output_supervisory_message.request_term_char.term_char_string :=
              iiv$skeleton_term_char_string;
      IFEND;
      output_supervisory_message.header.address := connection_desc_pointer^.
            connection_number;
      output_supervisory_message.header.character_type := iic$8_bit_characters;

{ Send the request terminal characteristics message to Pass-On.

      IF iiv$cdcnet_connection THEN
        iip$send_to_pass_on (appl, #LOC (output_supervisory_message),
              (iic$l_cdcnet_request_term_char + 1) * 8, iic$output_data_message +
              iiv$job_connection + iic$dont_signal, status);
      ELSE
        iip$convert_downline_term_char (#LOC (output_supervisory_message), #LOC
              (request_term_char_message), iic$l_request_term_char * 8,
              term_char_message_length);
        iip$send_to_pass_on (appl, #LOC (request_term_char_message),
              term_char_message_length, iic$output_data_message +
              iiv$job_connection + iic$dont_signal, status);
      IFEND;

      IF NOT status.normal THEN
        EXIT /locked/;
      IFEND;

{ Build read request.

      iip$build_super_msg_skeleton (^output_supervisory_message,
            iic$sm_read_request, iic$l_read_request);
      output_supervisory_message.read_request.connection_number :=
            iiv$job_connection;
      output_supervisory_message.read_request.begin_absentee := TRUE;
      output_supervisory_message.read_request.notify_if_absentee_started :=
            FALSE;

    /wait_tcd_ccd/
      WHILE TRUE DO

{ Send read request to Pass-On.

        iip$send_to_pass_on (appl, #LOC (output_supervisory_message),
              (iic$l_read_request + 1) * 8, iic$output_supervisory_message
              + iic$dont_signal, status);
        IF NOT status.normal THEN
          EXIT /locked/;
        IFEND;


{ Receive upline block from Pass-On.

        iip$receive_from_pass_on (appl, #LOC (upline_msg), #SIZE (upline_msg),
              c170_upline_message_length, status);
        IF NOT status.normal THEN
          EXIT /locked/;
        IFEND;

        IF iiv$abort_job_initialization THEN

{ The connection was broken before the job monitor task sent the CON/REQ/N.
{ Cause IFP$JOB_INITIALIZE to return an abnormal status so that the job aborts.

          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$abort_job_initialization, '', status);
          EXIT /wait_tcd_ccd/;
        IFEND;

        IF upline_msg.header.block_type = iic$supervisory_block THEN
          IF (upline_msg.message_type = iic$sm_cdcnet_term_char_defines) OR
                (upline_msg.message_type = iic$sm_term_char_definitions) THEN

{ Initialize the interactive attributes for the job.

            iip$set_default_attributes (^upline_msg, connection_desc_pointer,
                  status);
            EXIT /wait_tcd_ccd/;
          ELSE
            IF (upline_msg.message_type = iic$sm_cdcnet_request_trm_chr_a) OR
                  (upline_msg.message_type = iic$sm_request_term_char_a) THEN
              osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$request_term_char_fail, '', status);

              EXIT /wait_tcd_ccd/;
            IFEND;
          IFEND;
        IFEND;
      WHILEND /wait_tcd_ccd/;
    END /locked/;
    iip$sign_off (appl, ost);
    iip$clear_lock (iiv$get_lock, ost);
  PROCEND iip$request_default_attributes;

MODEND iim$request_default_attributes;
*DECK DECK=IIM$RESTORE_TERM_CONN_ATRIBUTES EXPAND=TRUE
?? TITLE := 'MODULE iim$restore_term_conn_atributes [2,2,3]' ??
*copyc osd$default_pragmats
MODULE iim$restore_term_conn_atributes;

?? PUSH (LISTEXT := ON) ??
*copyc iip$connection_to_vt_attributes
*copyc iiv$connection_desc_ptr
?? POP ??

{ Purpose:  This interface is only called during the processing of ATTACH_JOB
{           on standalone CDCNET connections to restore the reconnected job's
{           actual_connection_attributes which were active when the job was
{           disconnected.
{
{ Design:   All the values in the actual_connection_attributes field of the
{           connection's CONNECTION_DESCRIPTION are reactivated at the terminal
{           by passing these values in a call to the interface
{           IIP$CONNECTION_TO_VT_ATTRIBUTES.
{
{           This code resides in ring 2 so that it can access the pointer to
{           the CONNECTION_DESCRIPTION.  It is GATED because its sole caller
{           is privileged to run in a higher ring, ring 3.


  PROCEDURE [XDCL, #GATE] iip$restore_term_conn_atributes
    (VAR status: ost$status);

    VAR
      i: ifc$min_connection_key .. ifc$max_connection_key,
      actual_attributes: ^ift$connection_attributes;

    PUSH actual_attributes: [$INTEGER (ifc$min_connection_key) +
          1 .. $INTEGER (ifc$max_connection_key) + 1];
    FOR i := ifc$min_connection_key TO ifc$max_connection_key DO
      CASE i OF
      = ifc$attention_character_action =
        actual_attributes^ [$INTEGER (i) + 1].key := ifc$attention_character_action;
        actual_attributes^ [$INTEGER (i) + 1].attention_character_action :=
              iiv$connection_desc_ptr^.actual_connection_attributes.attention_character_action.value;
      = ifc$break_key_action =
        actual_attributes^ [$INTEGER (i) + 1].key := ifc$break_key_action;
        actual_attributes^ [$INTEGER (i) + 1].break_key_action :=
              iiv$connection_desc_ptr^.actual_connection_attributes.break_key_action.value;
      = ifc$input_block_size =
        actual_attributes^ [$INTEGER (i) + 1].key := ifc$input_block_size;
        actual_attributes^ [$INTEGER (i) + 1].input_block_size :=
              iiv$connection_desc_ptr^.actual_connection_attributes.input_block_size.value;
      = ifc$input_editing_mode =
        actual_attributes^ [$INTEGER (i) + 1].key := ifc$input_editing_mode;
        actual_attributes^ [$INTEGER (i) + 1].input_editing_mode :=
              iiv$connection_desc_ptr^.actual_connection_attributes.input_editing_mode.value;
      = ifc$input_output_mode =
        actual_attributes^ [$INTEGER (i) + 1].key := ifc$input_output_mode;
        actual_attributes^ [$INTEGER (i) + 1].input_output_mode :=
              iiv$connection_desc_ptr^.actual_connection_attributes.input_output_mode.value;
      = ifc$partial_char_forwarding =
        actual_attributes^ [$INTEGER (i) + 1].key := ifc$partial_char_forwarding;
        actual_attributes^ [$INTEGER (i) + 1].partial_character_forwarding :=
              iiv$connection_desc_ptr^.actual_connection_attributes.partial_char_forwarding.value;
      = ifc$store_backspace_character =
        actual_attributes^ [$INTEGER (i) + 1].key := ifc$store_backspace_character;
        actual_attributes^ [$INTEGER (i) + 1].store_backspace_character :=
              iiv$connection_desc_ptr^.actual_connection_attributes.store_backspace_character.value;
      = ifc$store_nuls_dels =
        actual_attributes^ [$INTEGER (i) + 1].key := ifc$store_nuls_dels;
        actual_attributes^ [$INTEGER (i) + 1].store_nuls_dels :=
              iiv$connection_desc_ptr^.actual_connection_attributes.store_nuls_dels.value;
      = ifc$trans_character_mode =
        actual_attributes^ [$INTEGER (i) + 1].key := ifc$trans_character_mode;
        actual_attributes^ [$INTEGER (i) + 1].trans_character_mode :=
              iiv$connection_desc_ptr^.actual_connection_attributes.trans_character_mode.value;
      = ifc$trans_forward_character =
        actual_attributes^ [$INTEGER (i) + 1].key := ifc$trans_forward_character;
        actual_attributes^ [$INTEGER (i) + 1].trans_forward_character :=
              iiv$connection_desc_ptr^.actual_connection_attributes.trans_forward_character.value;
      = ifc$trans_length_mode =
        actual_attributes^ [$INTEGER (i) + 1].key := ifc$trans_length_mode;
        actual_attributes^ [$INTEGER (i) + 1].trans_length_mode :=
              iiv$connection_desc_ptr^.actual_connection_attributes.trans_length_mode.value;
      = ifc$trans_timeout_mode =
        actual_attributes^ [$INTEGER (i) + 1].key := ifc$trans_timeout_mode;
        actual_attributes^ [$INTEGER (i) + 1].trans_timeout_mode :=
              iiv$connection_desc_ptr^.actual_connection_attributes.trans_timeout_mode.value;
      = ifc$trans_message_length =
        actual_attributes^ [$INTEGER (i) + 1].key := ifc$trans_message_length;
        actual_attributes^ [$INTEGER (i) + 1].trans_message_length :=
              iiv$connection_desc_ptr^.actual_connection_attributes.trans_message_length.value;
      ELSE
{     = ifc$trans_terminate_character =
        actual_attributes^ [$INTEGER (i) + 1].key := ifc$trans_terminate_character;
        actual_attributes^ [$INTEGER (i) + 1].trans_terminate_character :=
              iiv$connection_desc_ptr^.actual_connection_attributes.trans_terminate_character.value;
      CASEND;
    FOREND;

    iip$connection_to_vt_attributes (iiv$connection_desc_ptr, actual_attributes^, status);

  PROCEND iip$restore_term_conn_atributes;
MODEND iim$restore_term_conn_atributes;
*DECK DECK=IIM$ROUTE EXPAND=TRUE
MODULE iim$route;
*copyc osd$default_pragmats
{ PURPOSE:
{   The purpose of this module is to provide a ring 3 interface for
{   the interactive executive task.  All procs must validate that they
{   are being called from the system job. The functions supplied are:
{       iip$route - route a new interactive job.
{       iip$interactive_shutdown - signal all interactive jobs to suspend.
?? PUSH (LISTEXT := OFF) ??
*copyc ost$user_identification
*copyc clc$standard_file_names
*copyc osc$dual_state_interactive
*copyc jmt$system_supplied_name
*copyc jmp$list_jobs_via_mode
*copyc pmp$log
*copyc jmp$get_job_internal_info
*copyc iit$interactive_signal_type
*copyc tmc$signal_identifiers
*copyc iip$report_status_error
*copyc pmp$send_signal
*copyc jmp$system_job
*copyc jmp$submit_job
*copyc amp$open
*copyc amp$put_next
*copyc amp$close
*copyc amp$return
*copyc clp$trimmed_string_size
?? POP ??

  PROCEDURE [XDCL, #GATE] iip$route (user_id: ost$user_identification;
        user_supplied_job_name: jmt$user_supplied_name;
        system_job_parameters: jmt$system_job_parameters;
    VAR status: ost$status);

    VAR
      job_submission_options_p: ^jmt$job_submission_options,
      system_supplied_job_name: jmt$system_supplied_name;

    status.normal := TRUE;

{ submit the job

    PUSH job_submission_options_p: [1 .. 7];
    job_submission_options_p^ [1].key := jmc$user_job_name;
    job_submission_options_p^ [1].user_job_name := user_supplied_job_name;
    job_submission_options_p^ [2].key := jmc$system_job_parameters;
    PUSH job_submission_options_p^ [2].system_job_parameters;
    job_submission_options_p^ [2].system_job_parameters^ :=
          system_job_parameters;
    job_submission_options_p^ [3].key := jmc$origin_application_name;
    job_submission_options_p^ [3].origin_application_name := osc$dual_state_interactive;
    job_submission_options_p^ [4].key := jmc$login_command_supplied;
    job_submission_options_p^ [4].login_command_supplied := FALSE;
    job_submission_options_p^ [5].key := jmc$immediate_init_candidate;
    job_submission_options_p^ [5].immediate_init_candidate := TRUE;
    job_submission_options_p^ [6].key := jmc$login_family;
    job_submission_options_p^ [6].login_family := user_id.family;
    job_submission_options_p^ [7].key := jmc$login_user;
    job_submission_options_p^ [7].login_user := user_id.user;

    jmp$submit_job (clc$null_file, job_submission_options_p,
          system_supplied_job_name, status);
  PROCEND iip$route;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iip$interactive_shutdown (VAR status: ost$status);

    VAR
      jsns: array [1 .. 1024] of jmt$system_supplied_name,
      i,
      count: integer,
      job_info: jmt$job_internal_information,
      jmsg: string (30),
      signal: pmt$signal,
      isig: ^iit$interactive_signal;

    IF NOT jmp$system_job () THEN
      RETURN;
    IFEND;

    jmp$list_jobs_via_mode (jmc$interactive_connected, jsns, count, status);
    IF NOT status.normal THEN
      iip$report_status_error (status, 'interactive shutdown');
      RETURN;
    IFEND;

    signal.identifier := ifc$signal_id;
    isig := #LOC (signal.contents);
    isig^ := iic$exec_says_disconnect;
    jmsg := ' IF SHUTDOWN:';

  /send_to_jobs/
    FOR i := 1 TO count DO
      jmsg (15, 5) := jsns [i];
      pmp$log (jmsg, status);
      jmp$get_job_internal_info (jsns [i], job_info, status);
      IF NOT status.normal THEN
        iip$report_status_error (status, 'IF get internal info');
        CYCLE /send_to_jobs/;
      IFEND;
      IF NOT job_info.timesharing_job THEN
        pmp$send_signal (job_info.jmtr_global_taskid, signal, status);
        IF NOT status.normal THEN
          iip$report_status_error (status, 'IF send signal');
          CYCLE /send_to_jobs/;
        IFEND;
      IFEND;
    FOREND /send_to_jobs/;
  PROCEND iip$interactive_shutdown;
MODEND iim$route
*DECK DECK=IIM$SEARCH_CONNECTION_DESC EXPAND=TRUE
*copyc osd$default_pragmats
MODULE iim$search_connection_desc;

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc iit$connection_description
*copyc iiv$connection_desc_ptr
*copyc iiv$interactive_terminated
?? POP ??

  PROCEDURE [XDCL, #GATE] iip$search_connection_desc (session_file: amt$local_file_name;
    VAR connection_desc_ptr: ^iit$connection_description);

    connection_desc_ptr := iiv$connection_desc_ptr;
    IF iiv$network_identifier = iic$cdcnet_network THEN
    /look_for_connection/
      WHILE connection_desc_ptr <> NIL DO
        IF connection_desc_ptr^.session_layer_file_name = session_file THEN
          EXIT /look_for_connection/;
        IFEND;
        connection_desc_ptr := connection_desc_ptr^.next_connection_desc_ptr;
      WHILEND /look_for_connection/;
    IFEND;

  PROCEND iip$search_connection_desc;

MODEND iim$search_connection_desc;
*DECK DECK=IIM$SEND_ATTRIBUTES_CHANGE EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$send_attributes_change;
?? TITLE := 'MODULE iim$send_attributes_change' ??

?? PUSH (LISTEXT := ON) ??
*copyc iik$keypoints
*copyc IIT$CONNECTION_DESCRIPTION
*copyc iiv$int_task_open_file_count
*copyc IIP$BUILD_SUPER_MSG_SKELETON
*copyc IIP$CONVERT_DOWNLINE_TERM_CHAR
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIP$SEND_TO_PASS_ON
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc pmp$task_debug_mode_on
*copyc OST$STATUS
?? POP ??


?? NEWTITLE := 'PROCEDURE iip$send_attributes_change', EJECT ??

  PROCEDURE [XDCL] iip$send_attributes_change (downline_queue_entry_pointer:
    ^iit$downline_queue_entry;
        connection_desc_pointer: ^iit$connection_description;
    VAR status: ost$status);


    PROCEDURE build_fn_fv_pair (fn: 0..0ff(16),
          key: iic$key_user_break_1..iic$key_trans_mode_delim_char);

  {  Purpose: Add an FN/FV pair to the CTRL/CHAR/R supervisory message being built.

      output_supervisory_message.define_term_char.term_char_string [j].field_number := fn;
      output_supervisory_message.define_term_char.term_char_string [j].field_value := dqe^ [key];
      j := j + 1;

  {  Update the connection description's active_term_char_values array.
      cdp^ [key] := dqe^ [key];

    PROCEND build_fn_fv_pair;


    PROCEDURE build_fn_constant_pair (fn: 0..0ff(16),
          constant: 0..0ff(16));

  {  Purpose: Add an FN/FV pair to the CTRL/CHAR/R supervisory message being built.

      output_supervisory_message.define_term_char.term_char_string [j].field_number := fn;
      output_supervisory_message.define_term_char.term_char_string [j].field_value := constant;
      j := j + 1;

    PROCEND build_fn_constant_pair;


    VAR
      downloading: boolean,
      output_supervisory_message: iit$output_supervisory_message,
      define_term_char_message: iit$output_data_message,
      term_char_message_length: mlt$message_length,
      i: iic$key_user_break_1 .. iic$key_trans_mode_delim_char,
      j: 1 .. 15,
      dqe,
      cdp: ^array [1..15] of iit$field_value,
      send_term_char_pair,
      transparent_mode: boolean;


{ Build a define terminal characteristics message to change terminal
{ attributes.

    iip$build_super_msg_skeleton (^output_supervisory_message,
          iic$sm_define_term_char, 0);
    output_supervisory_message.header.address := connection_desc_pointer^.
          connection_number;
    output_supervisory_message.header.character_type := iic$8_bit_characters;
    output_supervisory_message.header.block_number :=
          downline_queue_entry_pointer^.message.header.block_number;

    downloading := false;
    j := 1;

    dqe := ^downline_queue_entry_pointer^.term_char_values;
    cdp := ^connection_desc_pointer^.active_term_char_values;

    IF dqe^ [iic$key_trans_input_mode] = 0 THEN
      IF cdp^ [iic$key_trans_input_mode] <> 0 THEN
        IF cdp^ [iic$key_trans_input_type] = iic$multi_message THEN
        { Turn transparent mode off. }
          build_fn_fv_pair (iic$fn_trans_input_mode, iic$key_trans_input_mode);
        ELSE
        { Update the connection description to reflect the drop of xparency inherent with single-message mode.
          cdp^ [iic$key_trans_input_mode] := 0;
        IFEND;
      IFEND;
    ELSE
      IF downline_queue_entry_pointer^.term_char_null THEN

      { Send transparency attribute changes only for output flushed because of a request for input.

        IF (dqe^ [iic$key_trans_input_type] = iic$single_message) OR
              (cdp^ [iic$key_trans_input_type] <> iic$multi_message) OR
              (cdp^ [iic$key_trans_input_mode] = 0) THEN
          downloading := TRUE;
        IFEND;
        IF dqe^ [iic$key_trans_input_type] <> cdp^ [iic$key_trans_input_type] THEN
          downloading := TRUE;
        IFEND;
        IF dqe^ [iic$key_trans_delim_char_select] <> cdp^ [iic$key_trans_delim_char_select] THEN
          downloading := TRUE;
        IFEND;
        IF dqe^ [iic$key_trans_delim_char_select] = 1 THEN
          CASE dqe^ [iic$key_trans_input_type] OF
          = iic$single_message =
            IF dqe^ [iic$key_trans_mode_delim_char] <> cdp^ [iic$key_trans_mode_delim_char] THEN
              downloading := TRUE;
            IFEND;
          = iic$multi_message =
            IF dqe^ [iic$key_trans_mode_delim_char] <> cdp^ [iic$key_trans_mode_delim_char] THEN
              downloading := TRUE;
            IFEND;
            IF dqe^ [iic$key_trans_delim_character] <> cdp^ [iic$key_trans_delim_character] THEN
              downloading := TRUE;
            IFEND;
          ELSE
          CASEND;
        IFEND;
        IF NOT downline_queue_entry_pointer^.transparent_count_selected THEN
          IF (cdp^ [iic$key_trans_delim_count_most] <> 0)
                OR (cdp^ [iic$key_trans_delim_count_least] <> 0) THEN
            downloading := TRUE;
          IFEND;
        ELSE
          IF (dqe^ [iic$key_trans_delim_count_least] <> cdp^ [iic$key_trans_delim_count_least])
                OR (dqe^ [iic$key_trans_delim_count_most] <> cdp^ [iic$key_trans_delim_count_most]) THEN
            downloading := TRUE;
          IFEND;
        IFEND;
        IF dqe^ [iic$key_trans_delim_timeout] <> cdp^ [iic$key_trans_delim_timeout] THEN
          downloading := TRUE;
        IFEND;
        IF (dqe^ [iic$key_trans_input_type] = iic$multi_message)
              AND (dqe^ [iic$key_trans_delim_timeout] <> 0)
              AND (dqe^ [iic$key_trans_mode_delim_lock] <> cdp^ [iic$key_trans_mode_delim_lock]) THEN
          downloading := TRUE;
        IFEND;

  {  Always turn transparent mode on unless multi_message is already in effect.

        IF downloading THEN

          { Turn transparent mode on. }
          build_fn_fv_pair (iic$fn_trans_input_mode, iic$key_trans_input_mode);
          IF NOT iiv$cdcnet_connection THEN
            IF connection_desc_pointer^.terminal_attributes.attention_character = CHR (0(16)) THEN
              build_fn_constant_pair (iic$fn_trans_interruptable, 0);
            ELSE
              build_fn_constant_pair (iic$fn_trans_interruptable, 1);
            IFEND;
          IFEND;

      {  Select transparent type.

          build_fn_fv_pair (iic$fn_trans_input_type, iic$key_trans_input_type);

      {  Select end character message and mode delimiter.

          build_fn_fv_pair (iic$fn_trans_delim_char_select, iic$key_trans_delim_char_select);   { 38(16):TDS }

          IF dqe^ [iic$key_trans_delim_char_select] = 1 THEN

          { Send a msg. and/or mode character delimiter only if they changed.

            CASE dqe^ [iic$key_trans_input_type] OF

            = iic$single_message =
              build_fn_fv_pair (iic$fn_trans_delim_character, iic$key_trans_mode_delim_char);   { 3b(16):TTC }

            = iic$multi_message =
              build_fn_fv_pair (iic$fn_trans_mode_delim_char, iic$key_trans_mode_delim_char);   { 45(16):TTC }
              build_fn_fv_pair (iic$fn_trans_delim_character, iic$key_trans_delim_character);   { 3b(16):TFC }

            ELSE
            CASEND;
          IFEND;

      {  Select transparent end count message delimiter.

          IF NOT downline_queue_entry_pointer^.transparent_count_selected THEN
            dqe^ [iic$key_trans_delim_count_least] := 0;
            dqe^ [iic$key_trans_delim_count_most] := 0;
            IF NOT iiv$cdcnet_connection THEN
              build_fn_fv_pair (iic$fn_trans_delim_count_most, iic$key_trans_delim_count_most);
              build_fn_fv_pair (iic$fn_trans_delim_count_least, iic$key_trans_delim_count_least);
            IFEND;
          ELSE
            build_fn_fv_pair (iic$fn_trans_delim_count_most, iic$key_trans_delim_count_most);
            build_fn_fv_pair (iic$fn_trans_delim_count_least, iic$key_trans_delim_count_least);
          IFEND;

      {  Select timeout message and mode delimiter.

          build_fn_fv_pair (iic$fn_trans_delim_timeout, iic$key_trans_delim_timeout);

          IF (dqe^ [iic$key_trans_input_type] = iic$multi_message)
                AND (dqe^ [iic$key_trans_delim_timeout] <> 0)
                AND (dqe^ [iic$key_trans_mode_delim_lock] <> cdp^ [iic$key_trans_mode_delim_lock])
                THEN
            build_fn_fv_pair (iic$fn_trans_mode_delim_lock, iic$key_trans_mode_delim_lock);
          IFEND;

        IFEND; {downloading}

      IFEND; { term_char_null}
    IFEND;
    FOR i := iic$key_user_break_1 TO iic$key_full_ascii DO

      IF dqe^ [i] <> cdp^ [i] THEN

      { Add the pair to the define terminal characteristics message

        output_supervisory_message.define_term_char.term_char_string [j].
              field_number := iiv$skeleton_term_char_string [i].field_number;
        output_supervisory_message.define_term_char.term_char_string [j].
              field_value := dqe^ [i];
        j := j + 1;

      { Update the active terminal characteristic value.

        cdp^ [i] := dqe^ [i];
      IFEND;

    FOREND;

    status.normal := TRUE;
    IF j > 1 THEN
      output_supervisory_message.header.text_length := (j - 1) * 2 + 2;

      iiv$term_char_change_count := iiv$term_char_change_count + 1;

{ Convert the define terminal characteristics message to C170 NAM format.

      iip$convert_downline_term_char (#LOC (output_supervisory_message), #LOC
            (define_term_char_message), iic$l_define_term_char * 8,
            term_char_message_length);

{ Send the define terminal characteristics message to Pass-On.

      iip$send_to_pass_on (iiv$int_application_name, #LOC
            (define_term_char_message), term_char_message_length,
            iic$output_data_message + iiv$job_connection, status);
    IFEND;


  PROCEND iip$send_attributes_change;

MODEND iim$send_attributes_change;
*DECK DECK=IIM$SEND_OUTPUT_MESSAGE EXPAND=TRUE
MODULE iim$send_output_message;
*copyc osd$default_pragmats

  TYPE
    iit$mli_status = set of mlt$status;

?? PUSH (LISTEXT := ON) ??
*copyc ifv$module_for_c180
*copyc iik$keypoints
*copyc iit$application_names_messages
*copyc iit$connection_description
*copyc iiv$interactive_terminated
*copyc iiv$int_task_open_file_count
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$test_sig_lock
*copyc osp$clear_job_signature_lock
*copyc osp$establish_condition_handler
*copyc osp$disestablish_cond_handler
*copyc pmp$continue_to_cause
*copyc ife$error_codes
*copyc i#move
*copyc iip$delete_queue_entry
*copyc iip$add_queue_entry
*copyc iip$report_status_error
*copyc iip$free_queue_entry
*copyc iip$build_data_msg_skeleton
*copyc iip$convert_downline_block
*copyc iip$send_attributes_change
*copyc mld$memory_link_declarations
*copyc mlp$send_message
*copyc pmp$long_term_wait
*copyc tmc$wait_times
*copyc pmp$task_state
*copyc osp$system_error
*copyc iiv$output
*copyc i#current_sequence_position
*copyc iip$check_if_status
?? POP ??

  PROCEDURE [XDCL] iip$send_output_message (wait: boolean;
    VAR status: ost$status);

    VAR
      dqe: ^iit$downline_queue_entry,
      nfe: iit$no_format_effectors,
      xpt: iit$transparent_mode,
      tcc: boolean,
      tcs: boolean,
      tcn: boolean,
      cdp: ^iit$connection_description,
      block_type: iit$application_block_type,
      cml: 0..0ffffffffffff(16),
      lib: integer,
      len: 0..0ffffffffffff(16),
      xpt_length: 0 .. 1,
      output_data: iit$output_data_message,
      c170_message_length: mlt$message_length,
      rqed,
      qed: iit$queue_entry_descriptor,
      tlength,
      i: integer,
      ls: ost$signature_lock_status,
      signal_response: integer,
      iiv$begin_absentee: [XREF] boolean,
      first_wait: boolean,
      first_po,
      po: ^iit$output,
      p_length: ^integer,
      iiv$job_output: [XDCL] ^SEQ ( * ) := NIL,
      iiv$last_output_time: [XDCL] integer := 0,
      ost: ost$status,
      output_data_message: iit$output_data_message;

?? NEWTITLE := 'PROCEDURE handle_break', EJECT ??

    PROCEDURE handle_break (cond: pmt$condition;
          cd: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR ch_status: ost$status);

      VAR
        local_status: ost$status;

      osp$test_sig_lock (iiv$downline_queue_lock, ls);
      IF ls = osc$sls_locked_by_current_task THEN
        osp$clear_job_signature_lock (iiv$downline_queue_lock);
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);

      IF cond.selector = ifc$interactive_condition THEN
        CASE cond.interactive_condition OF
        = ifc$pause_break =
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$pause_break_received, '', status);
        = ifc$terminate_break =
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$terminate_break_received, '', status);
        = ifc$terminal_connection_broken =
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$connection_break_disconnect, '', status);
        = ifc$job_reconnect =
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$terminal_reconnected_to_job, '', status);
        ELSE
          osp$set_status_abnormal (ifc$interactive_facility_id, 0,
            'unknown interactive condition encountered', status);
        CASEND;

        osp$test_sig_lock (iiv$downline_queue_lock, ls);
        IF ls = osc$sls_locked_by_current_task THEN
          osp$clear_job_signature_lock (iiv$downline_queue_lock);
        IFEND;
        EXIT iip$send_output_message;

      IFEND;

      ch_status.normal := TRUE;

    PROCEND handle_break;
?? OLDTITLE ??
?? EJECT ??
    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, iik$send_output_message);

{   interlock the send output message operation (1 per job)

    osp$test_sig_lock (iiv$downline_queue_lock, ls);
    IF ls = osc$sls_locked_by_current_task THEN
      RETURN;
    IFEND;
    osp$establish_condition_handler (^handle_break, TRUE);
    osp$set_job_signature_lock (iiv$downline_queue_lock);

  /send_output_message/
    WHILE TRUE DO

{     discard downline stuff ...

      IF iiv$interactive_terminated OR iiv$job_suspended THEN
        RESET iiv$output;
        RESET iiv$job_output;
        iiv$downline_queue_count := 0;
        EXIT /send_output_message/;
      IFEND;


{     if queue is empty then exit

      IF iiv$downline_queue_count = 0 THEN
        EXIT /send_output_message/;
      IFEND;

{     data is present - try to pack as many downline queue entries into
{     one output message as possible.  the following conditions terminate
{     the building of a message:
{     - downline queue empty
{     - output message full
{  - change in block modes (transparent, format effectors)
{     - terminal attributes change

      cml := 0;
      tlength := 0;
      NEXT p_length IN iiv$job_output;
      RESET iiv$job_output TO p_length;
      NEXT po: [1 .. p_length^] IN iiv$job_output;
      first_po := po;
      dqe := ^po^.block;
      nfe := dqe^.message.header.no_format_effectors;
      xpt := dqe^.message.header.transparent;
      tcc := dqe^.term_char_changed;
      tcs := dqe^.term_char_sent;
      tcn := dqe^.term_char_null;
      cdp := dqe^.connection_ptr;

{     Send terminal characteristics pairs if NAM terminal attributes
{     have been changed and they have not been sent yet.

      IF tcc AND NOT tcs THEN
        iip$send_attributes_change (dqe, cdp, status);
        IF status.normal THEN
          dqe^.term_char_sent := TRUE;
        IFEND;
        RESET iiv$job_output TO po;
        CYCLE /send_output_message/;
      IFEND;

      IF xpt THEN
        xpt_length := 0;
      ELSE
        xpt_length := 1;
      IFEND;

    /build_output_message/
      WHILE TRUE DO
        len := dqe^.message.header.text_length;
        tcn := dqe^.term_char_null;

{       check if to terminate building the current message

        IF (nfe <> dqe^.message.header.no_format_effectors) OR (xpt <> dqe^.
              message.header.transparent)
              OR (cml + len + xpt_length > (iic$max_block_size -
              8)) OR ((cml > 0) AND dqe^.term_char_changed) THEN
          RESET iiv$job_output TO po;
          EXIT /build_output_message/;
        IFEND;
        block_type := dqe^.message.header.block_type;

{       add this queue entry to the message being built

        IF (NOT tcn) OR (len > 0) THEN
          i#move (#LOC (dqe^.message.data [1]), #LOC (output_data.data [cml +
                1]), len);
          cml := cml + len;

{         add unit separator if not transparent

          IF NOT xpt THEN
            IF len = 0 THEN
              output_data.data [cml + 1] := ' ';
              cml := cml + 1;
            IFEND;
            output_data.data [cml + 1] := iic$ascii_us;
            cml := cml + 1;
          IFEND;
        IFEND;
        tlength := tlength + p_length^;


{       terminate building block if the last message added was a msg block

        IF block_type = iic$last_block THEN
          EXIT /build_output_message/;
        IFEND;

{       attempt to continue if there are any more queue entries left
{       set dqe to point to the next entry to add to the message

        IF tlength < iiv$downline_queue_count THEN
          NEXT p_length IN iiv$job_output;
          RESET iiv$job_output TO p_length;
          NEXT po: [1 .. p_length^] IN iiv$job_output;
          dqe := ^po^.block;
        ELSE
          EXIT /build_output_message/;
        IFEND;
      WHILEND /build_output_message/;

{     Send a downline block if this is not a terminal characteristics
{     null block.

      iiv$downline_queue_count := iiv$downline_queue_count - tlength;
      IF (cml > 0) OR (block_type = iic$last_block) THEN

{       Build nam output_data_message and send it to passon.

        iip$build_data_msg_skeleton (^output_data, cml);
        output_data.header.no_format_effectors := nfe;
        output_data.header.transparent := xpt;

{       set acn here from job acn to insure it is correct for reconnected job.

        output_data.header.connection_number := iiv$job_connection;
        signal_response := 0;
        output_data.header.block_type := block_type;
        IF (block_type = iic$last_block) THEN
           signal_response := iic$dont_signal;
           IF (iiv$begin_absentee) THEN
           output_data.header.block_type := iic$begin_absentee;
           IFEND;
        IFEND;
        output_data.header.zero1 := 0;

        iip$convert_downline_block (#LOC (output_data), #LOC
              (output_data_message), cml + #SIZE (output_data_message.header),
              c170_message_length);

        first_wait := TRUE;
        REPEAT

          mlp$send_message (iiv$int_application_name, iic$output_data_message +
                signal_response + iiv$job_connection, NIL, #LOC (output_data_message),
                c170_message_length, iic$passon_application_name, status);

          IF NOT status.normal THEN
            IF NOT wait THEN
              {Re-queue output
              RESET iiv$job_output TO first_po;
              iiv$downline_queue_count := iiv$downline_queue_count + tlength;
              status.normal := TRUE;
              EXIT /send_output_message/;
            IFEND;
            {Note: wait is done with lock set - depends on iip$check_if_status below.
            IF status.condition = mlc$prior_msg_not_received THEN
              IF first_wait THEN { inhibit swap out of this job }
                pmp$long_term_wait (250, 250);
                first_wait := FALSE;
              ELSE
                {allow swap out of this job }
                pmp$long_term_wait (tmc$infinite_wait, tmc$infinite_wait);
              IFEND;
            ELSE
              pmp$long_term_wait (250, 250);
            IFEND;
            {Detect asynchronous interrupts
            iip$check_if_status (ost);
            IF NOT ost.normal THEN
              status := ost;
              EXIT /send_output_message/;
            IFEND;

            IF pmp$task_state () = pmc$task_terminating THEN
              EXIT /send_output_message/;
            IFEND;
          IFEND;

        UNTIL status.normal;

      ELSE

        status.normal := TRUE;

      IFEND;

      iiv$last_output_time := #free_running_clock (0);
      IF iiv$downline_queue_count <= 0 THEN
        IF (iiv$downline_queue_count < 0) THEN
          osp$system_error ('SOM CONFUSED', NIL);
        IFEND;
        RESET iiv$output;
        RESET iiv$job_output;
      IFEND;

      {If send output successful - exit now.
      EXIT /send_output_message/;

    WHILEND /send_output_message/;

    osp$clear_job_signature_lock (iiv$downline_queue_lock);
    osp$disestablish_cond_handler;

    #KEYPOINT (osk$exit, 0, iik$send_output_message);

  PROCEND iip$send_output_message;
MODEND iim$send_output_message
*DECK DECK=IIM$SET_DEFAULT_ATTRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$set_default_attributes;

{ PURPOSE:  The procedure in this module is designed to extract and use the
{           attribute values from a CTRL/TCD/R message, or CTRL/CCD/N in
{           the case of NAM/CDCNET, to initialize the
{           nam_os_default_attributes, terminal_attributes,
{           active_term_char_values, and term_char_values fields of an
{           IIT$CONNECTION_DESCRIPTION record passed as a formal input
{           parameter.  Its only caller, IIM$REQUEST_DEFAULT_ATTRIBUTES, is
{           only called for dual state connections and only during LOGIN
{           and when a SETTA changes the terminal class.
{
{  DESIGN:  The CTRL/TCD/R, or CTRL/CCD/N, is an upline supervisory message
{           sent from NAM in response to the request for the terminal
{           characteristics, CTRL/RTC/R or CTRL/RCC/R, made by
{           IIM$REQUEST_DEFAULT_ATTRIBUTES.  It consists of a message
{           header followed by either an array of FN/FV pairs from CCP or
{           an array of AN/AV's from CDCNET.  Each field number and field
{           value (FN/FV) pair corresponds to a unique terminal
{           characteristic and its value.  An AN/AV consists of an octet,
{           which is an 8-bit value, to indicate the attribute number and
{           at least one octet for the value of the attribute; in the case
{           where the attribute value spans more than one octet, the first
{           bit of the attribute number octet is set, otherwise it is 0.
{
{           Extraneous zeroes added to the CTRL/TCD/R or CTRL/CCD/N message
{           by MLI are stripped off by calling IIP$CONVERT_UPLINE_TERM_CHAR
{           and attribute numbers in the resultant message are used for the
{           initialization.
{
{           Note that NAM/CDCNET does not return the pause break character,
{           terminate break character, or terminal class attribute values
{           so these attributes are initialized with constant values:
{                 PBC = '%',          TBC = '%',          TC = 3.
{
{           Note that there is a one-to-one correspondence between many of
{           the field_numbers and terminal/connection-attributes, for
{           example, 28(16) = Network_Control_Character and 31(16) =
{           Echoplex.  But other terminal/connection-attributes are defined
{           by multiple terminal characteristics.  For example,
{           Character_Flow_Control is set according to the values for
{           attribute numbers 43(16) and 44(16).
{
?? TITLE := 'MODULE iim$set_default_attributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc IIP$CLEAR_LOCK
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIP$CONVERT_UPLINE_TERM_CHAR
*copyc IIP$SET_LOCK
*copyc iit$vt_attributes
*copyc iit$vt_attribute_descriptions
*copyc iit$vt_attribute_kinds
*copyc IIV$INTERACTIVE_TERMINATED
*copyc OST$STATUS
*copyc PMP$LOG
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$set_default_attributes', EJECT ??

  PROCEDURE [XDCL] iip$set_default_attributes (input_super_message_pointer:
        ^iit$input_supervisory_message;
        cdp: ^iit$connection_description;
    VAR status: ost$status);

    VAR
      delay: 0 .. 999,
      field_value: iit$field_value,
      field_values: iit$term_char_string,
      field_value2: iit$field_value,
      i: integer,
      index: integer,
      limit: integer,
      local_status: ost$status,
      nam_os_defaults: ^iit$connection_attributes,
      number: 0 .. 255,
      octets: array [1 .. iic$vt_max_output_mess_length] of iit$field_value,
      terminal_attributes: ^iit$terminal_attributes,
      term_char_definitions_message: iit$input_supervisory_message,
      vt_attribute: iit$field_number,
      xpt_count_value: 0 .. 32767;

      iip$set_lock (cdp^.lock, osc$wait, local_status);
      nam_os_defaults := ^cdp^.nam_os_default_attributes;
      terminal_attributes := ^cdp^.terminal_attributes;

  { Convert the terminal characteristics definitions message from C170 format
  { to C180 format.

    iip$convert_upline_term_char (#LOC (input_super_message_pointer^), #LOC
          (term_char_definitions_message), (input_super_message_pointer^.
          header.text_length - 2) * 2);

    IF iiv$cdcnet_connection THEN
      field_values := iiv$skeleton_term_char_string;
      octets := term_char_definitions_message.cdcnet_term_char_defines.array_of_octets;
      limit := term_char_definitions_message.header.text_length - 2;
      index := 1;

      REPEAT

{ Extract the attribute-number octet.  Determine the number
{ of octets which comprise the attribute-value and the array
{ index of the first octet of the attribute-value.

        vt_attribute := octets [index];
        IF octets [index] >= 80(16) THEN
      { This is a multiple octet. }
          vt_attribute := octets [index] - 80(16);
          number := octets [index + 1];
          index := index + 2;
        ELSE
          number := 1;
          index := index + 1;
        IFEND;

{ Initialize the field values of an IIV$SKELETON_TERM_CHAR_STRING array,
{ and the terminal and connection attributes not in such an array.

        CASE vt_attribute OF

        = ORD (iic$vt_break_key_action) =
          nam_os_defaults^.break_key_action.value := octets [index];
          field_values [iic$key_user_break_1].field_value := octets [index];

        = ORD (iic$vt_input_editing_mode) =
          field_values [iic$key_trans_input_mode].field_value := octets [index];

        = ORD (iic$vt_input_output_mode) =
          CASE octets [index] OF
          = ORD (ifc$unsolicited_output) =
            field_values [iic$key_full_duplex].field_value := 0;
            field_values [iic$key_solicited_mode].field_value := 0;
          = ORD (ifc$solicited) =
            field_values [iic$key_full_duplex].field_value := 0;
            field_values [iic$key_solicited_mode].field_value := 1;
          = ORD (ifc$full_duplex) =
            field_values [iic$key_full_duplex].field_value := 1;
            field_values [iic$key_solicited_mode].field_value := 0;
          ELSE
          CASEND;

        = ORD (iic$vt_partial_char_forwarding) =
          IF octets [index] = 0 THEN
            field_values [iic$key_input_device].field_value := 0;
          ELSEIF octets [index] = 1 THEN
            field_values [iic$key_input_device].field_value := 2;
          IFEND;

        = ORD (iic$vt_store_backspace_char) =
          field_values [iic$key_special_editing].field_value := octets [index];

        = ORD (iic$vt_store_nuls_dels) =
          field_values [iic$key_full_ascii].field_value := octets [index];

        = ORD (iic$vt_trans_character_mode) =
          CASE octets [index] OF
          = ORD (ifc$no_trans_char) =
            field_values [iic$key_trans_delim_char_select].field_value := 0;
          = ORD (ifc$trans_char_terminate) =
            field_values [iic$key_trans_delim_char_select].field_value := 1;
            field_values [iic$key_trans_input_type].field_value := 0;
          = ORD (ifc$trans_char_forward), ORD (ifc$trans_char_fwd_terminate) =
            field_values [iic$key_trans_delim_char_select].field_value := 1;
            field_values [iic$key_trans_input_type].field_value := 1;
          ELSE
          CASEND;

        = ORD (iic$vt_trans_forward_character) =
          field_values [iic$key_trans_delim_character].field_value := octets [index];

        = ORD (iic$vt_trans_term_character) =
          field_values [iic$key_trans_mode_delim_char].field_value := octets [index];

        = ORD (iic$vt_trans_timeout_mode) =
          CASE octets [index] OF
          = ORD (ifc$no_trans_timeout) =
            field_values [iic$key_trans_delim_timeout].field_value := 0;
          = ORD (ifc$trans_timeout_terminate) =
            field_values [iic$key_trans_delim_timeout].field_value := 1;
            field_values [iic$key_trans_mode_delim_lock].field_value := 0;
          = ORD (ifc$trans_timeout_forward) =
            field_values [iic$key_trans_input_type].field_value := 1;
            field_values [iic$key_trans_delim_timeout].field_value := 1;
            field_values [iic$key_trans_mode_delim_lock].field_value := 1;
          ELSE
          CASEND;

        = ORD (iic$vt_trans_length_mode) =
          CASE octets [index] OF
          = ORD (ifc$no_trans_len) =
            field_values [iic$key_trans_delim_count_most].field_value := 0;
            field_values [iic$key_trans_delim_count_least].field_value := 0;
          = ORD (ifc$trans_len_terminate) =
            field_values [iic$key_trans_input_type].field_value := 0;
          = ORD (ifc$trans_len_forward), ORD (ifc$trans_len_forward_exact) =
            field_values [iic$key_trans_input_type].field_value := 1;
          ELSE
          CASEND;

        = ORD (iic$vt_trans_message_length) =
          IF number = 2 THEN
            field_values [iic$key_trans_delim_count_most].field_value := octets [index];
            field_values [iic$key_trans_delim_count_least].field_value := octets [index + 1];
          ELSEIF number = 1 THEN
            field_values [iic$key_trans_delim_count_most].field_value := 0;
            field_values [iic$key_trans_delim_count_least].field_value := octets [index];
          IFEND;

        = ORD (iic$vt_trans_protocol_mode) =
          CASE octets [index] OF
          = ORD (ifc$no_trans_protocol) =
            nam_os_defaults^.trans_timeout_mode.value := ifc$no_trans_timeout;
          = ORD (ifc$trans_protocol_terminate) =
            nam_os_defaults^.trans_timeout_mode.value :=
              ifc$trans_timeout_terminate;
          = ORD (ifc$trans_protocol_forward) =
            nam_os_defaults^.trans_timeout_mode.value :=
              ifc$trans_timeout_forward;
          ELSE
          CASEND;

        = ORD (iic$vt_page_width) =
          field_values [iic$key_page_width].field_value := octets [index];

        = ORD (iic$vt_page_length) =
          field_values [iic$key_page_length].field_value := octets [index];

        = ORD (iic$vt_cancel_line_character) =
          field_values [iic$key_cancel_line_character].field_value := octets [index];

        = ORD (iic$vt_backspace_character) =
          field_values [iic$key_backspace_character].field_value := octets [index];

        = ORD (iic$vt_carriage_return_delay) =
          IF number > 1 THEN
            delay := octets [index] * 100;
            delay := (delay + octets [index + 1]) DIV 4;
            field_values [iic$key_cr_delay_count].field_value := delay;
          ELSE
            field_values [iic$key_cr_delay_count].field_value := octets [index] DIV 4;
          IFEND;

        = ORD (iic$vt_line_feed_delay) =
          IF number > 1 THEN
            delay := octets [index] * 100;
            delay := (delay + octets [index + 1]) DIV 4;
            field_values [iic$key_lf_delay_count].field_value := delay;
          ELSE
            field_values [iic$key_lf_delay_count].field_value := octets [index] DIV 4;
          IFEND;

        = ORD (iic$vt_echoplex) =
          field_values [iic$key_echoplex].field_value := octets [index];

        = ORD (iic$vt_hold_page) =
          field_values [iic$key_hold_page].field_value := octets [index];

        = ORD (iic$vt_parity) =
          CASE octets [index] OF
          = 0, 1 =
            field_values [iic$key_parity].field_value := 0;
          = 2 =
            field_values [iic$key_parity].field_value := 2;
          = 3 =
            field_values [iic$key_parity].field_value := 1;
          = 4 =
            field_values [iic$key_parity].field_value := 3;
          ELSE
          CASEND;

        = ORD (iic$vt_network_command_char) =
          field_values [iic$key_network_cmd_character].field_value := octets [index];

        = ORD (iic$vt_end_partial_character) =
          field_values [iic$key_end_partial_character].field_value := octets [index];

        = ORD (iic$vt_end_partial_positioning) =
          field_values [iic$key_end_partial_positioning].field_value := octets [index];

        = ORD (iic$vt_end_line_character) =
          field_values [iic$key_end_line_character].field_value := octets [index];

        = ORD (iic$vt_end_line_positioning) =
          field_values [iic$key_end_line_positioning].field_value := octets [index];

        = ORD (iic$vt_character_flow_control) =
          field_values [iic$key_input_flow_control].field_value := octets [index];
          field_values [iic$key_output_flow_control].field_value := octets [index];

        = ORD (iic$vt_status_action) =
          IF octets [index] = 2 THEN
            field_values [iic$key_lockout_unsolicited_msg].field_value := 1;
          ELSE
            field_values [iic$key_lockout_unsolicited_msg].field_value := octets [index];
          IFEND;

        = ORD (iic$vt_end_output_sequence) =
          IF number <> 0 THEN
            field_values [iic$key_pacer_prompting].field_value := octets [index];
            FOR i := 0 TO (number - 1) DO
              terminal_attributes^.end_output_sequence.value (i + 1, 1) := CHR (octets [index + i]);
            FOREND;
          ELSE
            field_values [iic$key_pacer_prompting].field_value := 0;
            terminal_attributes^.end_output_sequence.value := '';
          IFEND;
          terminal_attributes^.end_output_sequence.size := number;

        = ORD (iic$vt_fold_line) =
          field_values [iic$key_output_device].field_value := octets [index];

        = ORD (iic$vt_attention_char_action) =
          nam_os_defaults^.attention_character_action.value := octets [index];

        = ORD (iic$vt_input_block_size) =
          IF number > 1 THEN
            i := octets [index] * 100(16);
            nam_os_defaults^.input_block_size.value := octets [index + 1] + i;
          ELSE
            nam_os_defaults^.input_block_size.value := octets [index];
          IFEND;

        = ORD (iic$vt_begin_line_character) =
          terminal_attributes^.begin_line_character :=CHR (octets [index]);

        = ORD (iic$vt_attention_character) =
          terminal_attributes^.attention_character := CHR (octets [index]);

        = ORD (iic$vt_hold_page_over) =
          terminal_attributes^.hold_page_over := (octets [index] <> 0);

        = ORD (iic$vt_carriage_return_sequence) =
          IF number <> 0 THEN
            FOR i := 0 TO (number - 1) DO
              terminal_attributes^.carriage_return_sequence.value (i + 1, 1) := CHR (octets [index + i]);
            FOREND;
          ELSE
            terminal_attributes^.carriage_return_sequence.value := '';
          IFEND;
          terminal_attributes^.carriage_return_sequence.size := number;

        = ORD (iic$vt_line_feed_sequence) =
          IF number <> 0 THEN
            FOR i := 0 TO (number - 1) DO
              terminal_attributes^.line_feed_sequence.value (i + 1, 1) := CHR (octets [index + i]);
            FOREND;
          ELSE
            terminal_attributes^.line_feed_sequence.value := '';
          IFEND;
          terminal_attributes^.line_feed_sequence.size := number;

        = ORD (iic$vt_form_feed_sequence) =
          IF number <> 0 THEN
            FOR i := 0 TO (number - 1) DO
              terminal_attributes^.form_feed_sequence.value (i + 1, 1) := CHR (octets [index + i]);
            FOREND;
          ELSE
            terminal_attributes^.form_feed_sequence.value := '';
          IFEND;
          terminal_attributes^.form_feed_sequence.size := number;

        = ORD (iic$vt_end_page_action) =
          IF octets [index] = 0 THEN
            terminal_attributes^.end_page_action := ifc$no_epa;
          ELSE
            terminal_attributes^.end_page_action := ifc$epa_ffs;
          IFEND;

        = ORD (iic$vt_form_feed_delay) =
          IF number > 1 THEN
            delay := octets [index] * 100(16);
            delay := delay + octets [index + 1];
            terminal_attributes^.form_feed_delay := delay;
          ELSE
            terminal_attributes^.form_feed_delay := octets [index];
          IFEND;

        = ORD (iic$vt_function_key_class) =
          IF number <> 0 THEN
            FOR i := 0 TO (number - 1) DO
              terminal_attributes^.function_key_class.value (i + 1, 1) := CHR (octets [index + i]);
            FOREND;
            terminal_attributes^.function_key_class.size := number;
          ELSE
            terminal_attributes^.function_key_class.value := '';
            terminal_attributes^.function_key_class.size := 1;
          IFEND;

        = ORD (iic$vt_terminal_model) =
          IF number <> 0 THEN
            FOR i := 0 TO (number - 1) DO
              terminal_attributes^.terminal_model.value (i + 1, 1) := CHR (octets [index + i]);
            FOREND;
            terminal_attributes^.terminal_model.size := number;
          ELSE
            terminal_attributes^.terminal_model.value := '';
            terminal_attributes^.terminal_model.size := 1;
          IFEND;

        = ORD (iic$vt_code_set) =
          CASE octets [index] OF
          = 0 =
            terminal_attributes^.code_set := ifc$ascii_code_set;
          = 1 =
            terminal_attributes^.code_set := ifc$bpapl_code_set;
          = 2 =
            terminal_attributes^.code_set := ifc$tpapl_code_set;
          ELSE
          CASEND;

        ELSE
        CASEND;
        index := index + number;

      UNTIL index > limit;

    { CDCNET does not return values for the following attributes: }

      field_values [iic$key_pause_break_character].field_value := 31(16);
      field_values [iic$key_term_break_character].field_value := 32(16);


    ELSE  { use the FN/FV pairs in the order that they were returned }

      field_values := term_char_definitions_message.term_char_definitions.
            term_char_string;

    IFEND;  { iiv$cdcnet_connection }


  /initialize_nam_os_defaults/
    BEGIN

    { Set input editing mode.

      field_value := field_values [iic$key_trans_input_mode].field_value;
      IF field_value = 0 THEN
        nam_os_defaults^.input_editing_mode.value := ifc$normal_edit;
      ELSE
        nam_os_defaults^.input_editing_mode.value := ifc$trans_edit;
      IFEND;

    { Set input output mode.

      field_value := field_values [iic$key_full_duplex].field_value;
      field_value2 := field_values [iic$key_solicited_mode].field_value;

      IF (field_value = 0) AND (field_value2 = 0) THEN
        nam_os_defaults^.input_output_mode.value := ifc$unsolicited_output;
      ELSEIF (field_value = 0) AND (field_value2 = 1) THEN
        nam_os_defaults^.input_output_mode.value := ifc$solicited;
      ELSEIF (field_value = 1) AND (field_value2 = 0) THEN
        nam_os_defaults^.input_output_mode.value := ifc$full_duplex;
      IFEND;

    { Set partial character forwarding.

      IF iiv$cdcnet_connection THEN
          nam_os_defaults^.partial_char_forwarding.value := FALSE;
      ELSE
        IF field_values [iic$key_input_device].field_value = 0 THEN
          nam_os_defaults^.partial_char_forwarding.value := FALSE;
        ELSEIF field_values [iic$key_input_device].field_value = 2 THEN
          nam_os_defaults^.partial_char_forwarding.value := TRUE;
        IFEND;
      IFEND;

    { Set store backspace character and store nuls dels.

      field_value := field_values [iic$key_full_ascii].field_value;
      field_value2 := field_values [iic$key_special_editing].field_value;
      nam_os_defaults^.store_backspace_character.value :=
            ((field_value = 0) AND (field_value2 = 1));
      nam_os_defaults^.store_nuls_dels.value :=
            (nam_os_defaults^.store_backspace_character.value AND (field_value = 1));

    { Set transparent character mode.

      field_value := field_values [iic$key_trans_delim_char_select].field_value;

      IF field_value = 0 THEN
        nam_os_defaults^.trans_character_mode.value := ifc$no_trans_char;
      ELSE
        field_value := field_values [iic$key_trans_input_type].field_value;
        IF field_value = 0 THEN
          nam_os_defaults^.trans_character_mode.value := ifc$trans_char_terminate;
        ELSEIF field_value = 1 THEN
          nam_os_defaults^.trans_character_mode.value := ifc$trans_char_fwd_terminate;
        IFEND;
      IFEND;

    { Set transparent length mode.

      xpt_count_value := field_values [iic$key_trans_delim_count_least].field_value;
      xpt_count_value := xpt_count_value + field_values [iic$key_trans_delim_count_most].
            field_value * 100(16);
      nam_os_defaults^.trans_message_length.value := xpt_count_value;
      IF xpt_count_value = 0 THEN
        nam_os_defaults^.trans_length_mode.value := ifc$no_trans_len;
      ELSE
        field_value := field_values [iic$key_trans_input_type].field_value;
        IF field_value = 0 THEN
          nam_os_defaults^.trans_length_mode.value := ifc$trans_len_terminate;
        ELSEIF field_value = 1 THEN
          nam_os_defaults^.trans_length_mode.value := ifc$trans_len_forward_exact;
        IFEND;
      IFEND;

    { Set transparent timeout mode.

      IF field_values [iic$key_trans_delim_timeout].field_value = 0 THEN
        nam_os_defaults^.trans_timeout_mode.value := ifc$no_trans_timeout;
      ELSEIF (field_values [iic$key_trans_mode_delim_lock].field_value = 0) OR
            iiv$cdcnet_connection THEN
        nam_os_defaults^.trans_timeout_mode.value := ifc$trans_timeout_terminate;
      ELSEIF field_values [iic$key_trans_input_type].field_value = 1 THEN
        nam_os_defaults^.trans_timeout_mode.value := ifc$trans_timeout_forward;
      IFEND;

    { Set transparent terminate character and forwarding character.

      field_value := field_values [iic$key_trans_delim_character].field_value;
      nam_os_defaults^.trans_forward_character.value.value (1) := CHR (field_value);
      IF nam_os_defaults^.trans_character_mode.value = ifc$trans_char_terminate THEN
        nam_os_defaults^.trans_terminate_character.value.value (1) := CHR (field_value);
      ELSE
        field_value := field_values [iic$key_trans_mode_delim_char].field_value;
        nam_os_defaults^.trans_terminate_character.value.value (1) := CHR (field_value);
      IFEND;
      nam_os_defaults^.trans_terminate_character.value.size := 1;
      nam_os_defaults^.trans_forward_character.value.size := 1;

     { Set attention character action and break key action.

      IF NOT iiv$cdcnet_connection THEN
        nam_os_defaults^.attention_character_action.value := 0;
        nam_os_defaults^.break_key_action.value := 0;
      IFEND;

    END /initialize_nam_os_defaults/;

  { Initialize term_char_values and active_term_char_values in connection descriptor. }

  /initialize_term_char_values/
    FOR i:=iic$key_user_break_1 to iic$key_trans_mode_delim_char DO
      cdp^.term_char_values [i]:= field_values [i].field_value;
      cdp^.active_term_char_values [i]:= field_values [i].field_value;
    FOREND /initialize_term_char_values/;

  /initialize_terminal_attributes/
    BEGIN

    { Set attention character.

      IF NOT iiv$cdcnet_connection THEN
        terminal_attributes^.attention_character := CHR (0(16));
      IFEND;

      IF (field_values [iic$key_trans_input_mode].field_value = 1) AND
            (terminal_attributes^.attention_character <> chr(00)) THEN

    { The following assignment can now be made since the attention character is determined.

        field_values [iic$key_trans_input_mode].field_value := 2; { xpt input mode w/user breaks enabled }
      IFEND;

    { Set backspace character.

      field_value := field_values [iic$key_backspace_character].field_value;
      terminal_attributes^.backspace_character := CHR (field_value);

    { Set begin line character.

      IF NOT iiv$cdcnet_connection THEN
        terminal_attributes^.begin_line_character := CHR (0(16));
      IFEND;

    { Set cancel line character.

      field_value := field_values [iic$key_cancel_line_character].field_value;
      terminal_attributes^.cancel_line_character := CHR (field_value);

    { Set carriage return delay.

      field_value := field_values [iic$key_cr_delay_count].field_value;
      terminal_attributes^.carriage_return_delay := field_value * 4;

    { Set character flow control.

      field_value := field_values [iic$key_output_flow_control].field_value;
      field_value2 := field_values [iic$key_input_flow_control].field_value;

      IF (field_value = 0) AND (field_value2 = 0) THEN
        terminal_attributes^.character_flow_control := FALSE;
      ELSE
        terminal_attributes^.character_flow_control := TRUE;
      IFEND;

    { Set echoplex.

      IF field_values [iic$key_echoplex].field_value = 0 THEN
        terminal_attributes^.echoplex := FALSE;
      ELSE
        terminal_attributes^.echoplex := TRUE;
      IFEND;

    { Set end line character.

      field_value := field_values [iic$key_end_line_character].field_value;
      terminal_attributes^.end_line_character := CHR (field_value);

    { Set end line positioning.

      field_value := field_values [iic$key_end_line_positioning].field_value;
      terminal_attributes^.end_line_positioning := iiv$upline_end_position_conv [field_value];

    { Set end output sequence.

      IF NOT iiv$cdcnet_connection THEN
        field_value := field_values [iic$key_pacer_prompting].field_value;
        terminal_attributes^.end_output_sequence.value (1)  := CHR (field_value);
        terminal_attributes^.end_output_sequence.size := 1;
      IFEND;

    { Set end partial character.

      field_value := field_values [iic$key_end_partial_character].field_value;
      terminal_attributes^.end_partial_character := CHR (field_value);

    { Set end partial positioning.

      field_value := field_values [iic$key_end_partial_positioning].field_value;
      terminal_attributes^.end_partial_positioning := iiv$upline_part_position_conv [field_value];

    { Set fold line.

      IF field_values [iic$key_output_device].field_value = 1 THEN
        terminal_attributes^.fold_line := FALSE;
      ELSEIF field_values [iic$key_output_device].field_value = 0 THEN
        terminal_attributes^.fold_line := TRUE;
      IFEND;

    { Set hold page.

      IF field_values [iic$key_hold_page].field_value = 0 THEN
        terminal_attributes^.hold_page := FALSE;
      ELSE
        terminal_attributes^.hold_page := TRUE;
      IFEND;

    { Set line feed delay.

      field_value := field_values [iic$key_lf_delay_count].field_value;
      terminal_attributes^.line_feed_delay := field_value * 4;

    { Set network command character.

      field_value := field_values [iic$key_network_cmd_character].field_value;
      terminal_attributes^.network_command_character := CHR (field_value);

    { Set page width.

      field_value := field_values [iic$key_page_width].field_value;
      IF field_value = 0 THEN
        terminal_attributes^.page_width := UPPERVALUE (ift$page_width);
      ELSE
        terminal_attributes^.page_width := field_value;
      IFEND;

    { Set page length.

      field_value := field_values [iic$key_page_length].field_value;
      IF field_value = 0 THEN
        terminal_attributes^.page_length := UPPERVALUE (ift$page_length);
      ELSE
        terminal_attributes^.page_length := field_value;
      IFEND;

    { Set parity.

      field_value := field_values [iic$key_parity].field_value;
      terminal_attributes^.parity := iiv$upline_parity_conv [field_value];
      IF (nam_os_defaults^.input_editing_mode.value =
            ifc$trans_edit) THEN

      { Select IGNORE PARITY if XPT mode is on and the 2**7 bit of either the TFC or TTC
      { is zero.  This tells the 2550 to ignore the parity bit when it is checking for the
      { TFC or TTC, which, in effect, allows, for example, a TFC of 0D(16) to successfully
      { compare with 8D(16).

        IF (ORD (nam_os_defaults^.trans_forward_character.value.
              value (1)) < 7F(16)) OR
              (ORD (nam_os_defaults^.trans_terminate_character.value.
              value (1)) < 7F(16)) THEN
          field_values [iic$key_parity].field_value := 4;
        IFEND;
      IFEND;

    { Set status action.

      IF field_values [iic$key_lockout_unsolicited_msg].field_value = 0 THEN
        terminal_attributes^.status_action := ifc$send_status;
      ELSE
        terminal_attributes^.status_action := ifc$hold_status;
      IFEND;

    { Set pause break character.

      field_value := field_values [iic$key_pause_break_character].field_value;
      terminal_attributes^.pause_break_character := CHR (field_value);

    { Set terminate break character.

      field_value := field_values [iic$key_term_break_character].field_value;
      terminal_attributes^.terminate_break_character := CHR (field_value);

    { Set terminal class.

      IF NOT iiv$cdcnet_connection THEN
        field_value := field_values [iic$key_terminal_class].field_value;
        terminal_attributes^.terminal_class := iiv$upline_term_class_conv [field_value];
      IFEND;

    END /initialize_terminal_attributes/;

    iip$clear_lock (cdp^.lock, local_status);

  PROCEND iip$set_default_attributes;

MODEND iim$set_default_attributes;
*DECK DECK=IIM$SET_TERMINAL_NAME EXPAND=TRUE
?? TITLE := 'MODULE iim$set_terminal_name [2,2,3]', EJECT ??
*copyc osd$default_pragmats
MODULE iim$set_terminal_name;

?? PUSH (LISTEXT := ON) ??
*copyc ift$terminal_attributes
*copyc iiv$connection_desc_ptr
*copyc nap$get_attributes
*copyc osc$timesharing_terminal_file
*copyc pmp$log
*copyc qfp$set_terminal_name
?? POP ??

{ Purpose: Initialize the Terminal_Name terminal attribute.
{
{ Design : Set the Terminal_Name terminal attribute to the string
{          passed as an input parameter.

  PROCEDURE [XDCL, #GATE] iip$set_terminal_name (terminal_name: ift$terminal_name);

{ Set the Terminal_Name terminal attribute in the connection description.

    iiv$connection_desc_ptr^.terminal_name (1, 31) := terminal_name;
    qfp$set_terminal_name (terminal_name);

  PROCEND iip$set_terminal_name;
MODEND iim$set_terminal_name;
*DECK DECK=IIM$STORE_CONTEXT EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$store_context;
?? TITLE := 'MODULE iim$store_context' ??

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc bat$task_file_table
*copyc bav$last_tft_entry
*copyc bav$task_file_table
*copyc ift$store_context_attributes
*copyc iiv$interactive_terminated
*copyc nat$data_fragments
*copyc osp$set_status_abnormal
*copyc OST$STATUS
*copyc ifp$fap_control
*copyc ifp$st_fap_control
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$store_context', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$store_context (file_id: amt$file_identifier;
        context_attributes: ift$store_context_attributes;
    VAR status: ost$status);

    VAR
      file_identifier: amt$file_identifier,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      i: integer,
      open_file_dsc_pointer: ^iit$open_file_description,
      st_open_file_dsc_pointer: ^iit$st_open_file_description;

    status.normal := TRUE;

    FOR i := LOWERBOUND (context_attributes) TO UPPERBOUND (context_attributes) DO
      CASE context_attributes [i].key OF
      = ifc$instance_mode =
        CASE iiv$network_identifier OF
        = iic$cdcnet_network =
        file_identifier := file_id;
*copy bai$validate_file_identifier
*copy iii$fetch_st_open_file_desc_ptr
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        = iic$dsiaf_network =
        file_identifier := file_id;
*copy bai$validate_file_identifier
*copy iii$fetch_open_file_desc_ptr
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        CASEND;
        iiv$previous_file_id := file_id;
        CASE  context_attributes [i].instance_mode OF
        = ifc$line =
          iiv$previous_mode := iic$line;
          CASE iiv$network_identifier OF
          = iic$cdcnet_network =
            st_open_file_dsc_pointer^.terminal_mode := iic$line;
          = iic$dsiaf_network =
            open_file_dsc_pointer^.terminal_mode := iic$line;
          CASEND;
        = ifc$screen =
          iiv$previous_mode := iic$screen;
          CASE iiv$network_identifier OF
          = iic$cdcnet_network =
            st_open_file_dsc_pointer^.terminal_mode := iic$screen;
            iiv$previous_connection_attr := st_open_file_dsc_pointer^.attributes;
          = iic$dsiaf_network =
            open_file_dsc_pointer^.terminal_mode := iic$screen;
            iiv$previous_connection_attr := open_file_dsc_pointer^.attributes;
          CASEND;
        CASEND;
      = ifc$blank_flag =
        iiv$previous_blank_flag := context_attributes [i].blank_flag;
      = ifc$screen_clear_string =
        iiv$screen_clear_string := context_attributes [i].screen_clear_string;
      ELSE
      CASEND;
    FOREND;

  PROCEND iip$store_context;

MODEND iim$store_context;
*DECK DECK=IIM$STORE_TERMINAL EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$store_terminal;
?? TITLE := 'MODULE iim$store_terminal' ??

?? PUSH (LISTEXT := ON) ??
*copyc AMP$CLOSE
*copyc AMP$FETCH
*copyc clp$get_ultimate_connection
*copyc IFE$ERROR_CODES
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIP$BUILD_TERM_CONN_ATTR_ARRAY
*copyc IIP$BUILD_TERM_CHAR_VALUES
*copyc IIV$INTERACTIVE_TERMINATED
*copyc jmp$system_job
*copyc OST$STATUS
*copyc OSP$APPEND_STATUS_INTEGER
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$GET_JOB_MODE
*copyc PMP$LOG
*copyc RMP$GET_DEVICE_CLASS
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$store_terminal', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$store_terminal (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$open_file_description;
    terminal_attributes: ^ift$connection_attributes;
    VAR status: ost$status);

    VAR
      replace_attributes: iit$connection_attributes,
      open_file_terminal_attributes: iit$connection_attributes,
      set_of_terminal_attribute_keys: iit$set_of_term_conn_attr_keys,
      set_of_trans_char_modes: iit$set_of_trans_char_modes,
      set_of_trans_length_modes: iit$set_of_trans_length_modes,
      set_of_trans_protocol_modes: iit$set_of_trans_protocol_modes,
      set_of_trans_timeout_modes: iit$set_of_trans_timeout_modes,
      set_of_input_editing_modes: iit$set_of_input_editing_modes,
      set_of_input_output_modes: iit$set_of_input_output_modes,
      device_assigned: boolean,
      device_class: rmt$device_class,
      i: integer,
      j: ift$connection_attribute_keys,
      k: integer,
      job_mode: jmt$job_mode,
      fetch_attributes: array [1 .. 1] of amt$fetch_item,
      local_status: ost$status,
      ultimate_prompt_file: amt$local_file_name;

    /store_terminal/
    BEGIN
    status.normal := TRUE;

    open_file_terminal_attributes := open_file_desc_pointer^.attributes;

{ Verify that this is an interactive job.

    pmp$get_job_mode (job_mode, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    ELSEIF NOT jmp$system_job () THEN
      IF NOT (job_mode IN $iit$job_modes [jmc$interactive_connected,
            jmc$interactive_cmnd_disconnect, jmc$interactive_line_disconnect,
            jmc$interactive_sys_disconnect]) THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$current_job_not_interactive, 'IFP$STORE_TERMINAL', status);
        RETURN;
      IFEND;
    IFEND;

{ Validate the terminal attribute keys.

    set_of_terminal_attribute_keys := - $iit$set_of_term_conn_attr_keys [];
    FOR i := LOWERBOUND (terminal_attributes^) TO UPPERBOUND
          (terminal_attributes^) DO
      IF NOT (terminal_attributes^ [i].key IN set_of_terminal_attribute_keys)
            THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$unknown_attribute_key, '', status);
        k := ORD (terminal_attributes^ [i].key);
        osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
              FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$STORE_TERMINAL', status);
        RETURN;
      IFEND;
    FOREND;

{ Check for attributes which have no meaning on this type of terminal connection.

    IF NOT iiv$cdcnet_connection THEN
      FOR i := 1 TO UPPERBOUND (terminal_attributes^) DO
        CASE terminal_attributes^ [i].key OF
        = ifc$trans_protocol_mode =
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$illegal_nam_ccp_change,
                'IFP$STORE_TERMINAL', status);

          EXIT /store_terminal/;
        ELSE
        CASEND;
      FOREND;
    IFEND;

{ Validate the attribute values.

    FOR i := LOWERBOUND (terminal_attributes^) TO UPPERBOUND
          (terminal_attributes^) DO

      CASE terminal_attributes^ [i].key OF

      = ifc$attention_character_action =

        k := terminal_attributes^ [i].attention_character_action;
        IF ((k < LOWERVALUE (ift$attention_character_action)) OR (k >
              UPPERVALUE (ift$attention_character_action))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$attention_character_action, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$attention_character_action);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$attention_character_action);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$TERMINAL', status);
          RETURN;
        IFEND;

      = ifc$break_key_action =

        k := terminal_attributes^ [i].break_key_action;
        IF ((k < LOWERVALUE (ift$break_key_action)) OR (k >
              UPPERVALUE (ift$break_key_action))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$break_key_action, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$break_key_action);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$break_key_action);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$end_of_information =

        k := terminal_attributes^ [i].end_of_information.size;
        IF ((k < LOWERVALUE (ift$end_of_information_size)) OR (k > UPPERVALUE
              (ift$end_of_information_size))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$end_of_information_size, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$end_of_information_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$end_of_information_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$input_block_size =

        k := terminal_attributes^ [i].input_block_size;
        IF ((k < LOWERVALUE (ift$input_block_size)) OR (k > UPPERVALUE
              (ift$input_block_size))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$input_block_size, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$input_block_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$input_block_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$input_editing_mode =

        set_of_input_editing_modes := - $iit$set_of_input_editing_modes [];
        IF NOT (terminal_attributes^ [i].input_editing_mode IN set_of_input_editing_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_input_editing_mode, '', status);
          k := ORD (terminal_attributes^ [i].input_editing_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$input_output_mode =

        set_of_input_output_modes := - $iit$set_of_input_output_modes [];
        IF NOT (terminal_attributes^ [i].input_output_mode IN set_of_input_output_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_input_output_mode, '', status);
          k := ORD (terminal_attributes^ [i].input_output_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$input_timeout =

        IF ((terminal_attributes^ [i].input_timeout < LOWERVALUE
              (boolean)) OR (terminal_attributes^ [i].input_timeout >
              UPPERVALUE (boolean))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$input_timeout, 'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$input_timeout_length =

        k := terminal_attributes^ [i].input_timeout_length;
        IF ((k < LOWERVALUE (ift$input_timeout_length)) OR (k > UPPERVALUE
              (ift$input_timeout_length))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$input_timeout_length, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$input_timeout_length);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$input_timeout_length);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$input_timeout_purge =

        IF ((terminal_attributes^ [i].input_timeout_purge < LOWERVALUE
              (boolean)) OR (terminal_attributes^ [i].input_timeout_purge >
              UPPERVALUE (boolean))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$input_timeout_purge, 'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$partial_char_forwarding =

        IF ((terminal_attributes^ [i].partial_character_forwarding < LOWERVALUE
              (boolean)) OR (terminal_attributes^ [i].partial_character_forwarding >
              UPPERVALUE (boolean))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$partial_char_forwarding, 'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$prompt_file =

        clp$get_ultimate_connection (terminal_attributes^ [i].prompt_file, ultimate_prompt_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Verify that the file is assigned to a terminal device.

        rmp$get_device_class (ultimate_prompt_file, device_assigned, device_class, local_status);
        IF NOT local_status.normal THEN
          status := local_status;
          RETURN;
        ELSE
          IF NOT device_assigned THEN
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$prompt_file_name_not_found, ultimate_prompt_file, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
              'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
            RETURN;
          ELSEIF device_class <> rmc$terminal_device THEN
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$prompt_file_name_not_term, ultimate_prompt_file, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
              'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
            RETURN;
          IFEND;
        IFEND;

      = ifc$prompt_file_identifier =

{ Get the file_name for the file_id.

{ The following code is no-op'ed until BAM provides a way to obtain
{ the local_file_name given the file_id.

{       fetch_attributes [1].key := amc$local_file_name;
{       amp$fetch (terminal_attributes^ [i].prompt_file_identifier, fetch_attributes,
{             local_status);
{       IF NOT local_status.normal THEN
{         status := local_status;
{         RETURN;
{       IFEND;
{
{ Verify that the file is assigned to a terminal device.
{
{       rmp$get_device_class (fetch_attributes [1].file_name^.local_file_name,
{             device_assigned, device_class, local_status);
{       IF NOT local_status.normal THEN
{         status := local_status;
{         RETURN;
{       ELSE
{         IF NOT device_assigned THEN
{           osp$set_status_abnormal (ifc$interactive_facility_id,
{                 ife$prompt_file_id_not_found, fetch_attributes [1].
{                 file_name^.local_file_name, status);
{           osp$append_status_parameter (osc$status_parameter_delimiter,
{             'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
{           RETURN;
{         ELSEIF device_class <> rmc$terminal_device THEN
{           osp$set_status_abnormal (ifc$interactive_facility_id,
{                 ife$prompt_file_id_not_term, fetch_attributes [1].file_name^.
{                 local_file_name, status);
{           osp$append_status_parameter (osc$status_parameter_delimiter,
{             'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
{           RETURN;
{         IFEND;
{       IFEND;

      = ifc$prompt_string =

        k := terminal_attributes^ [i].prompt_string.size;
        IF ((k < LOWERVALUE (ift$prompt_string_size)) OR (k > UPPERVALUE
              (ift$prompt_string_size))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$prompt_string_size, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$prompt_string_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$prompt_string_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$store_backspace_character =

        IF ((terminal_attributes^ [i].store_backspace_character < LOWERVALUE
              (boolean)) OR (terminal_attributes^ [i].store_backspace_character >
              UPPERVALUE (boolean))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$store_backspace_character, 'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$store_nuls_dels =

        IF ((terminal_attributes^ [i].store_nuls_dels < LOWERVALUE
              (boolean)) OR (terminal_attributes^ [i].store_nuls_dels >
              UPPERVALUE (boolean))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$store_nuls_dels, 'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$trans_character_mode =

        set_of_trans_char_modes := - $iit$set_of_trans_char_modes [];
        IF NOT (terminal_attributes^ [i].trans_character_mode IN set_of_trans_char_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_trans_char_mode, '', status);
          k := ORD (terminal_attributes^ [i].trans_character_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$trans_length_mode =

        set_of_trans_length_modes := - $iit$set_of_trans_length_modes [];
        IF NOT (terminal_attributes^ [i].trans_length_mode IN set_of_trans_length_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_trans_length_mode, '', status);
          k := ORD (terminal_attributes^ [i].trans_length_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$trans_timeout_mode =

        set_of_trans_timeout_modes := - $iit$set_of_trans_timeout_modes [];
        IF NOT (terminal_attributes^ [i].trans_timeout_mode IN set_of_trans_timeout_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_trans_timeout_mode, '', status);
          k := ORD (terminal_attributes^ [i].trans_timeout_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$trans_forward_character =

        k := terminal_attributes^ [i].trans_forward_character.size;
        IF ((k < LOWERVALUE (ift$trans_fwd_char_size)) OR (k > UPPERVALUE
              (ift$trans_fwd_char_size))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$trans_fwd_character_size, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$trans_fwd_char_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$trans_fwd_char_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$trans_message_length =

        k := terminal_attributes^ [i].trans_message_length;
        IF ((k < LOWERVALUE (ift$trans_message_length)) OR (k > UPPERVALUE
              (ift$trans_message_length))) THEN
          IF k <> 0 THEN
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$trans_message_length, '', status);
            osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                  FALSE, status);
            k := LOWERVALUE (ift$trans_message_length);
            osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                  FALSE, status);
            k := UPPERVALUE (ift$trans_message_length);
            osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                  FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
              'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
            RETURN;
          IFEND;
        IFEND;

      = ifc$trans_terminate_character =

        k := terminal_attributes^ [i].trans_terminate_character.size;
        IF ((k < LOWERVALUE (ift$trans_term_char_size)) OR (k > UPPERVALUE
              (ift$trans_term_char_size))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$trans_term_character_size, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$trans_term_char_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$trans_term_char_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$trans_protocol_mode =

        set_of_trans_protocol_modes := - $iit$set_of_trans_protocol_modes [];
        IF NOT (terminal_attributes^ [i].trans_protocol_mode IN set_of_trans_protocol_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_trans_protocol_mode, '', status);
          k := ORD (terminal_attributes^ [i].trans_protocol_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;


      ELSE
      CASEND;

    FOREND;

{ Replace the attributes in the open file description.

    FOR i := LOWERBOUND (terminal_attributes^) TO UPPERBOUND (terminal_attributes^) DO
      CASE terminal_attributes^ [i].key OF

      = ifc$attention_character_action =
        open_file_terminal_attributes.attention_character_action.value := terminal_attributes^ [i].
              attention_character_action;
        open_file_terminal_attributes.attention_character_action.source := ifc$store_term_conn_request;

      = ifc$break_key_action =
        open_file_terminal_attributes.break_key_action.value := terminal_attributes^ [i].
              break_key_action;
        open_file_terminal_attributes.break_key_action.source := ifc$store_term_conn_request;

      = ifc$end_of_information =
        open_file_terminal_attributes.end_of_information.value := terminal_attributes^ [i].
              end_of_information;
        open_file_terminal_attributes.end_of_information.source := ifc$store_term_conn_request;

      = ifc$input_block_size =
        open_file_terminal_attributes.input_block_size.value := terminal_attributes^ [i].
              input_block_size;
        open_file_terminal_attributes.input_block_size.source := ifc$store_term_conn_request;

      = ifc$input_editing_mode =
        open_file_terminal_attributes.input_editing_mode.value := terminal_attributes^ [i].
              input_editing_mode;
        open_file_terminal_attributes.input_editing_mode.source := ifc$store_term_conn_request;

      = ifc$input_output_mode =
        open_file_terminal_attributes.input_output_mode.value := terminal_attributes^ [i].
              input_output_mode;
        open_file_terminal_attributes.input_output_mode.source := ifc$store_term_conn_request;

      = ifc$input_timeout =
        open_file_terminal_attributes.input_timeout.value := terminal_attributes^ [i].
              input_timeout;
        open_file_terminal_attributes.input_timeout.source := ifc$store_term_conn_request;

      = ifc$input_timeout_length =
        open_file_terminal_attributes.input_timeout_length.value := terminal_attributes^ [i].
              input_timeout_length;
        open_file_terminal_attributes.input_timeout_length.source := ifc$store_term_conn_request;

      = ifc$input_timeout_purge =
        open_file_terminal_attributes.input_timeout_purge.value := terminal_attributes^ [i].
              input_timeout_purge;
        open_file_terminal_attributes.input_timeout_purge.source := ifc$store_term_conn_request;

      = ifc$partial_char_forwarding =
        open_file_terminal_attributes.partial_char_forwarding.value := terminal_attributes^ [i].
              partial_character_forwarding;
        open_file_terminal_attributes.partial_char_forwarding.source := ifc$store_term_conn_request;

      = ifc$prompt_file =
        open_file_terminal_attributes.prompt_file.value := terminal_attributes^ [i].
              prompt_file;
        open_file_terminal_attributes.prompt_file.source := ifc$store_term_conn_request;

      = ifc$prompt_file_identifier =
        open_file_terminal_attributes.prompt_file_identifier.value := terminal_attributes^ [i].
              prompt_file_identifier;
        open_file_terminal_attributes.prompt_file_identifier.source := ifc$store_term_conn_request;

      = ifc$prompt_string =
        open_file_terminal_attributes.prompt_string.value := terminal_attributes^ [i].
              prompt_string;
        open_file_terminal_attributes.prompt_string.source := ifc$store_term_conn_request;

      = ifc$store_backspace_character =
        open_file_terminal_attributes.store_backspace_character.value := terminal_attributes^ [i].
              store_backspace_character;
        open_file_terminal_attributes.store_backspace_character.source := ifc$store_term_conn_request;

      = ifc$store_nuls_dels =
        open_file_terminal_attributes.store_nuls_dels.value := terminal_attributes^ [i].
              store_nuls_dels;
        open_file_terminal_attributes.store_nuls_dels.source := ifc$store_term_conn_request;

      = ifc$trans_character_mode =
        open_file_terminal_attributes.trans_character_mode.value := terminal_attributes^ [i].
              trans_character_mode;
        open_file_terminal_attributes.trans_character_mode.source := ifc$store_term_conn_request;

      = ifc$trans_forward_character =
        open_file_terminal_attributes.trans_forward_character.value := terminal_attributes^ [i].
              trans_forward_character;
        open_file_terminal_attributes.trans_forward_character.source := ifc$store_term_conn_request;

      = ifc$trans_length_mode =
        open_file_terminal_attributes.trans_length_mode.value := terminal_attributes^ [i].
              trans_length_mode;
        open_file_terminal_attributes.trans_length_mode.source := ifc$store_term_conn_request;

      = ifc$trans_timeout_mode =
        open_file_terminal_attributes.trans_timeout_mode.value := terminal_attributes^ [i].
              trans_timeout_mode;
        open_file_terminal_attributes.trans_timeout_mode.source := ifc$store_term_conn_request;

      = ifc$trans_message_length =
        open_file_terminal_attributes.trans_message_length.value := terminal_attributes^ [i].
              trans_message_length;
        open_file_terminal_attributes.trans_message_length.source := ifc$store_term_conn_request;

      = ifc$trans_terminate_character =
        open_file_terminal_attributes.trans_terminate_character.value := terminal_attributes^ [i].
              trans_terminate_character;
        open_file_terminal_attributes.trans_terminate_character.source := ifc$store_term_conn_request;

      = ifc$trans_protocol_mode =
        open_file_terminal_attributes.trans_protocol_mode.value := terminal_attributes^ [i].
              trans_protocol_mode;
        open_file_terminal_attributes.trans_protocol_mode.source := ifc$store_term_conn_request;

      ELSE
      CASEND;
    FOREND;

{ Close the prompt file if the system has opened it and the prompt_file_id is
{ being replaced.

    IF ((open_file_desc_pointer^.attributes.prompt_file_identifier.value.ordinal <> 0) AND
          (open_file_desc_pointer^.attributes.prompt_file_identifier.
          source = ifc$os_default)) AND
          (open_file_terminal_attributes.prompt_file_identifier.source <>
          ifc$os_default) THEN
      amp$close (open_file_desc_pointer^.attributes.prompt_file_identifier.value,
            local_status);
    IFEND;

{ Set the terminal attributes in the open file descriptor.

    open_file_desc_pointer^.attributes := open_file_terminal_attributes;

{ Update the characteristics values in the open file description
{ and the access information.

    iip$build_term_char_values (open_file_desc_pointer);
    open_file_desc_pointer^.last_access_operation := ifc$store_terminal_req;

  END /store_terminal/;
  PROCEND iip$store_terminal;

MODEND iim$store_terminal;
*DECK DECK=IIM$STORE_TERM_CONN_ATTRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$store_term_conn_attributes;
?? TITLE := 'MODULE iim$store_term_conn_attributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc AMP$CLOSE
*copyc AMP$FETCH
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc CLP$GET_ULTIMATE_CONNECTION
*copyc CLP$VALIDATE_NAME
*copyc CLV$STANDARD_FILES
*copyc IFE$ERROR_CODES
*copyc IFT$CONNECTION_ATTRIBUTES
*copyc IIP$CONNECTION_TO_VT_ATTRIBUTES
*copyc iik$keypoints
*copyc iip$search_connection_desc
*copyc iip$st_update_actual_attributes
*copyc iip$st_flush
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIV$INTERACTIVE_TERMINATED
*copyc jmp$system_job
*copyc OST$STATUS
*copyc OSP$APPEND_STATUS_INTEGER
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$GET_JOB_MODE
*copyc RMP$GET_DEVICE_CLASS
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$store_term_conn_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$store_term_conn_attributes (file_id: amt$file_identifier;
        open_file_desc_pointer: ^iit$st_open_file_description;
        connection_attributes: ^ift$connection_attributes;
    VAR status: ost$status);

    VAR
      connection_desc_ptr: ^iit$connection_description,
      converted_name: amt$local_file_name,
      device_assigned: boolean,
      device_class: rmt$device_class,
      device_is_network: boolean,
      fetch_attributes: array [1 .. 1] of amt$fetch_item,
      file_identifier: amt$file_identifier,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      i: integer,
      j: integer,
      job_mode: jmt$job_mode,
      k: integer,
      local_status: ost$status,
      ofdp: ^iit$st_open_file_description,
      replacing_prompt_file_id: boolean,
      response_received: boolean,
      set_of_input_editing_modes: iit$set_of_input_editing_modes,
      set_of_input_output_modes: iit$set_of_input_output_modes,
      set_of_term_conn_attribute_keys: iit$set_of_term_conn_attr_keys,
      set_of_trans_char_modes: iit$set_of_trans_char_modes,
      set_of_trans_length_modes: iit$set_of_trans_length_modes,
      set_of_trans_protocol_modes: iit$set_of_trans_protocol_modes,
      set_of_trans_timeout_modes: iit$set_of_trans_timeout_modes,
      ultimate_name: amt$local_file_name,
      ultimate_prompt_file: amt$local_file_name,
      valid_name: boolean;

    status.normal := TRUE;
    replacing_prompt_file_id := FALSE;
    file_identifier := file_id;

*copy bai$validate_file_identifier

{ Verify that the terminal file exists and that it is a network file.

    device_is_network := (file_instance^.device_class = rmc$network_device) OR
            (file_instance^.device_class = rmc$terminal_device);

    IF NOT device_is_network THEN
      clp$get_ultimate_connection (file_instance^.local_file_name, ultimate_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pmp$get_job_mode (job_mode, local_status);
      IF NOT local_status.normal THEN
        status := local_status;
        RETURN;
      ELSEIF (NOT (job_mode IN $iit$job_modes [jmc$interactive_connected,
             jmc$interactive_cmnd_disconnect, jmc$interactive_line_disconnect,
             jmc$interactive_sys_disconnect]) AND
             (((ultimate_name = clv$standard_files [clc$sf_job_input_file].path_handle_name) OR
             (ultimate_name = clv$standard_files [clc$sf_job_output_file].path_handle_name)) OR
             (ultimate_name = clv$standard_files [clc$sf_command_file].path_handle_name))) THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
             ife$current_job_not_interactive, 'IIP$STORE_TERM_CONN_ATTRIBUTES',
             status);
        RETURN;
      ELSE
        osp$set_status_abnormal (ifc$interactive_facility_id,
            ife$file_name_not_terminal, converted_name, status);
        RETURN;
      IFEND;
    IFEND;

{ Validate the connection attribute keys and the OS-defined attribute values
{ for prompt_file, prompt_file_id, prompt_string, input_timeout, input_timeout_purge,
{ input_timeout_length, and end_of_information.

    set_of_term_conn_attribute_keys := - $iit$set_of_term_conn_attr_keys [];
    FOR i := LOWERBOUND (connection_attributes^) TO UPPERBOUND
          (connection_attributes^) DO
      IF NOT (connection_attributes^ [i].key IN set_of_term_conn_attribute_keys)
            THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$unknown_attribute_key, '', status);
        k := ORD (connection_attributes^ [i].key);
        osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
              FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
        RETURN;
      IFEND;
      CASE connection_attributes^ [i].key OF

      = ifc$attention_character_action =

        k := connection_attributes^ [i].attention_character_action;
        IF ((k < LOWERVALUE (ift$attention_character_action)) OR (k >
              UPPERVALUE (ift$attention_character_action))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$attention_character_action, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$attention_character_action);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$attention_character_action);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$break_key_action =

        k := connection_attributes^ [i].break_key_action;
        IF ((k < LOWERVALUE (ift$break_key_action)) OR (k >
              UPPERVALUE (ift$break_key_action))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$break_key_action, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$break_key_action);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$break_key_action);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$end_of_information =

        k := connection_attributes^ [i].end_of_information.size;
        IF ((k < LOWERVALUE (ift$end_of_information_size)) OR (k > UPPERVALUE
              (ift$end_of_information_size))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$end_of_information_size, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$end_of_information_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$end_of_information_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$input_block_size =

        k := connection_attributes^ [i].input_block_size;
        IF ((k < LOWERVALUE (ift$input_block_size)) OR (k > UPPERVALUE
              (ift$input_block_size))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$input_block_size, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$input_block_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$input_block_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$input_editing_mode =

        set_of_input_editing_modes := - $iit$set_of_input_editing_modes [];
        IF NOT (connection_attributes^ [i].input_editing_mode IN set_of_input_editing_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_input_editing_mode, '', status);
          k := ORD (connection_attributes^ [i].input_editing_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$input_output_mode =

        set_of_input_output_modes := - $iit$set_of_input_output_modes [];
        IF NOT (connection_attributes^ [i].input_output_mode IN set_of_input_output_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_input_output_mode, '', status);
          k := ORD (connection_attributes^ [i].input_output_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$input_timeout =

        IF ((connection_attributes^ [i].input_timeout < LOWERVALUE
              (boolean)) OR (connection_attributes^ [i].input_timeout >
              UPPERVALUE (boolean))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$input_timeout, 'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$input_timeout_length =

        k := connection_attributes^ [i].input_timeout_length;
        IF ((k < LOWERVALUE (ift$input_timeout_length)) OR (k > UPPERVALUE
              (ift$input_timeout_length))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$input_timeout_length, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$input_timeout_length);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$input_timeout_length);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$input_timeout_purge =

        IF ((connection_attributes^ [i].input_timeout_purge < LOWERVALUE
              (boolean)) OR (connection_attributes^ [i].input_timeout_purge >
              UPPERVALUE (boolean))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$input_timeout_purge, 'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$partial_char_forwarding =

        IF ((connection_attributes^ [i].partial_character_forwarding < LOWERVALUE
              (boolean)) OR (connection_attributes^ [i].partial_character_forwarding >
              UPPERVALUE (boolean))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$partial_char_forwarding, 'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$prompt_file =

        clp$get_ultimate_connection (connection_attributes^ [i].prompt_file, ultimate_prompt_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Verify that the file is assigned to a terminal device.

        rmp$get_device_class (ultimate_prompt_file, device_assigned, device_class, local_status);
        IF NOT local_status.normal THEN
          status := local_status;
          RETURN;
        ELSE
          IF NOT device_assigned THEN
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$prompt_file_name_not_found, ultimate_prompt_file, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
              'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
            RETURN;
          ELSEIF device_class <> rmc$terminal_device THEN
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$prompt_file_name_not_term, ultimate_prompt_file, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
              'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
            RETURN;
          IFEND;
        IFEND;

      = ifc$prompt_file_identifier =

{ Get the file_name for the file_id.

{ The following code is no-op'ed until BAM provides a way to obtain
{ the local_file_name given the file_id.

{       fetch_attributes [1].key := amc$local_file_name;
{       amp$fetch (connection_attributes^ [i].prompt_file_identifier, fetch_attributes,
{             local_status);
{       IF NOT local_status.normal THEN
{         status := local_status;
{         RETURN;
{       IFEND;
{
{ Verify that the file is assigned to a terminal device.
{
{       rmp$get_device_class (fetch_attributes [1].file_name^.local_file_name,
{             device_assigned, device_class, local_status);
{       IF NOT local_status.normal THEN
{         status := local_status;
{         RETURN;
{       ELSE
{         IF NOT device_assigned THEN
{           osp$set_status_abnormal (ifc$interactive_facility_id,
{                 ife$prompt_file_id_not_found, fetch_attributes [1].
{                 file_name^.local_file_name, status);
{           osp$append_status_parameter (osc$status_parameter_delimiter,
{             'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
{           RETURN;
{         ELSEIF device_class <> rmc$terminal_device THEN
{           osp$set_status_abnormal (ifc$interactive_facility_id,
{                 ife$prompt_file_id_not_term, fetch_attributes [1].file_name^.
{                 local_file_name, status);
{           osp$append_status_parameter (osc$status_parameter_delimiter,
{             'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
{           RETURN;
{         IFEND;
{       IFEND;

      = ifc$prompt_string =

        k := connection_attributes^ [i].prompt_string.size;
        IF ((k < LOWERVALUE (ift$prompt_string_size)) OR (k > UPPERVALUE
              (ift$prompt_string_size))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$prompt_string_size, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$prompt_string_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$prompt_string_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$store_backspace_character =

        IF ((connection_attributes^ [i].store_backspace_character < LOWERVALUE
              (boolean)) OR (connection_attributes^ [i].store_backspace_character >
              UPPERVALUE (boolean))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$store_backspace_character, 'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$store_nuls_dels =

        IF ((connection_attributes^ [i].store_nuls_dels < LOWERVALUE
              (boolean)) OR (connection_attributes^ [i].store_nuls_dels >
              UPPERVALUE (boolean))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$store_nuls_dels, 'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$trans_character_mode =

        set_of_trans_char_modes := - $iit$set_of_trans_char_modes [];
        IF NOT (connection_attributes^ [i].trans_character_mode IN set_of_trans_char_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_trans_char_mode, '', status);
          k := ORD (connection_attributes^ [i].trans_character_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$trans_length_mode =

        set_of_trans_length_modes := - $iit$set_of_trans_length_modes [];
        IF NOT (connection_attributes^ [i].trans_length_mode IN set_of_trans_length_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_trans_length_mode, '', status);
          k := ORD (connection_attributes^ [i].trans_length_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$trans_timeout_mode =

        set_of_trans_timeout_modes := - $iit$set_of_trans_timeout_modes [];
        IF NOT (connection_attributes^ [i].trans_timeout_mode IN set_of_trans_timeout_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_trans_timeout_mode, '', status);
          k := ORD (connection_attributes^ [i].trans_timeout_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$trans_forward_character =

        k := connection_attributes^ [i].trans_forward_character.size;
        IF ((k < LOWERVALUE (ift$trans_fwd_char_size)) OR (k > UPPERVALUE
              (ift$trans_fwd_char_size))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$trans_fwd_character_size, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$trans_fwd_char_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$trans_fwd_char_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$trans_message_length =

        k := connection_attributes^ [i].trans_message_length;
        IF ((k < LOWERVALUE (ift$trans_message_length)) OR (k > UPPERVALUE
              (ift$trans_message_length))) THEN
          IF k <> 0 THEN
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$trans_message_length, '', status);
            osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                  FALSE, status);
            k := LOWERVALUE (ift$trans_message_length);
            osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                  FALSE, status);
            k := UPPERVALUE (ift$trans_message_length);
            osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                  FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
              'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
            RETURN;
          IFEND;
        IFEND;

      = ifc$trans_terminate_character =

        k := connection_attributes^ [i].trans_terminate_character.size;
        IF ((k < LOWERVALUE (ift$trans_term_char_size)) OR (k > UPPERVALUE
              (ift$trans_term_char_size))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$trans_term_character_size, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$trans_term_char_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$trans_term_char_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      = ifc$trans_protocol_mode =

        set_of_trans_protocol_modes := - $iit$set_of_trans_protocol_modes [];
        IF NOT (connection_attributes^ [i].trans_protocol_mode IN set_of_trans_protocol_modes)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_trans_protocol_mode, '', status);
          k := ORD (connection_attributes^ [i].trans_protocol_mode);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$STORE_TERM_CONN_ATTRIBUTES', status);
          RETURN;
        IFEND;

      ELSE
      CASEND;
    FOREND;

    IF replacing_prompt_file_id AND ((open_file_desc_pointer^.attributes.
          prompt_file_identifier.value.ordinal <> 0) AND
         (open_file_desc_pointer^.attributes.prompt_file_identifier.source =
         ifc$os_default)) THEN
      amp$close (open_file_desc_pointer^.attributes.prompt_file_identifier.value, local_status);
    IFEND;

{ Update the attributes in the open file descriptor.

    ofdp := open_file_desc_pointer;
    FOR j := 1 TO UPPERBOUND (connection_attributes^) DO
      CASE connection_attributes^ [j].key OF
      = ifc$attention_character_action =
        ofdp^.attributes.attention_character_action.value :=
              connection_attributes^ [j].attention_character_action;
        ofdp^.attributes.attention_character_action.source := ifc$store_term_conn_request;
      = ifc$break_key_action =
        ofdp^.attributes.break_key_action.value :=
              connection_attributes^ [j].break_key_action;
        ofdp^.attributes.break_key_action.source := ifc$store_term_conn_request;
      = ifc$end_of_information =
        ofdp^.attributes.end_of_information.value :=
              connection_attributes^ [j].end_of_information;
        ofdp^.attributes.end_of_information.source := ifc$store_term_conn_request;
      = ifc$input_block_size =
        ofdp^.attributes.input_block_size.value :=
              connection_attributes^ [j].input_block_size;
        ofdp^.attributes.input_block_size.source := ifc$store_term_conn_request;
      = ifc$input_editing_mode =
        ofdp^.attributes.input_editing_mode.value :=
              connection_attributes^ [j].input_editing_mode;
        ofdp^.attributes.input_editing_mode.source := ifc$store_term_conn_request;
      = ifc$input_output_mode =
        ofdp^.attributes.input_output_mode.value :=
              connection_attributes^ [j].input_output_mode;
        ofdp^.attributes.input_output_mode.source := ifc$store_term_conn_request;
      = ifc$input_timeout =
        ofdp^.attributes.input_timeout.value :=
              connection_attributes^ [j].input_timeout;
        ofdp^.attributes.input_timeout.source := ifc$store_term_conn_request;
      = ifc$input_timeout_length =
        ofdp^.attributes.input_timeout_length.value :=
              connection_attributes^ [j].input_timeout_length;
        ofdp^.attributes.input_timeout_length.source := ifc$store_term_conn_request;
      = ifc$input_timeout_purge =
        ofdp^.attributes.input_timeout_purge.value :=
              connection_attributes^ [j].input_timeout_purge;
        ofdp^.attributes.input_timeout_purge.source := ifc$store_term_conn_request;
      = ifc$partial_char_forwarding =
        ofdp^.attributes.partial_char_forwarding.value :=
              connection_attributes^ [j].partial_character_forwarding;
        ofdp^.attributes.partial_char_forwarding.source := ifc$store_term_conn_request;
      = ifc$prompt_file =
        ofdp^.attributes.prompt_file.value :=
              connection_attributes^ [j].prompt_file;
        ofdp^.attributes.prompt_file.source := ifc$store_term_conn_request;
      = ifc$prompt_file_identifier =
        ofdp^.attributes.prompt_file_identifier.value :=
              connection_attributes^ [j].prompt_file_identifier;
        ofdp^.attributes.prompt_file_identifier.source := ifc$store_term_conn_request;
      = ifc$prompt_string =
        ofdp^.attributes.prompt_string.value :=
              connection_attributes^ [j].prompt_string;
        ofdp^.attributes.prompt_string.source := ifc$store_term_conn_request;
      = ifc$store_backspace_character =
        ofdp^.attributes.store_backspace_character.value :=
              connection_attributes^ [j].store_backspace_character;
        ofdp^.attributes.store_backspace_character.source := ifc$store_term_conn_request;
      = ifc$store_nuls_dels =
        ofdp^.attributes.store_nuls_dels.value :=
              connection_attributes^ [j].store_nuls_dels;
        ofdp^.attributes.store_nuls_dels.source := ifc$store_term_conn_request;
      = ifc$trans_character_mode =
        ofdp^.attributes.trans_character_mode.value :=
              connection_attributes^ [j].trans_character_mode;
        ofdp^.attributes.trans_character_mode.source := ifc$store_term_conn_request;
      = ifc$trans_forward_character =
        ofdp^.attributes.trans_forward_character.value :=
              connection_attributes^ [j].trans_forward_character;
        ofdp^.attributes.trans_forward_character.source := ifc$store_term_conn_request;
      = ifc$trans_length_mode =
        ofdp^.attributes.trans_length_mode.value :=
              connection_attributes^ [j].trans_length_mode;
        ofdp^.attributes.trans_length_mode.source := ifc$store_term_conn_request;
      = ifc$trans_timeout_mode =
        ofdp^.attributes.trans_timeout_mode.value :=
              connection_attributes^ [j].trans_timeout_mode;
        ofdp^.attributes.trans_timeout_mode.source := ifc$store_term_conn_request;
      = ifc$trans_message_length =
        ofdp^.attributes.trans_message_length.value :=
              connection_attributes^ [j].trans_message_length;
        ofdp^.attributes.trans_message_length.source := ifc$store_term_conn_request;
      = ifc$trans_terminate_character =
        ofdp^.attributes.trans_terminate_character.value :=
              connection_attributes^ [j].trans_terminate_character;
        ofdp^.attributes.trans_terminate_character.source := ifc$store_term_conn_request;
      = ifc$trans_protocol_mode =
        ofdp^.attributes.trans_protocol_mode.value :=
              connection_attributes^ [j].trans_protocol_mode;
        ofdp^.attributes.trans_protocol_mode.source := ifc$store_term_conn_request;
      ELSE
        {}
      CASEND;
    FOREND;
{ Update access information.

      ofdp^.last_access_operation := ifc$store_terminal_req;



  PROCEND iip$store_term_conn_attributes;

MODEND iim$store_term_conn_attributes;
*DECK DECK=IIM$ST_CHNGE_TERM_CONN_DEFAULTS EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$st_chnge_term_conn_defaults;

{ PURPOSE:  This module provides the ring 2 interface to change the
{           default connection attributes for a standalone task.
{           Consequently, subsequent file creations will employ the
{           new attribute values, but previously created files will
{           not be affected.
{
{  DESIGN:  The new attribute values are validated and are then used
{           to replace corresponding values in an IF attributes table
{           which resides in task shared memory.
{
{           For standalone connections, attribute validation consists
{           of verifying that the attribute key is known and that a
{           normal response is received after an attributes change
{           message is sent to the network for the input attribute
{           values.  After validation the new attribute values replace
{           their corresponding attributes in the connection table.
{
?? TITLE := 'MODULE iim$st_chnge_term_conn_defaults' ??

?? PUSH (LISTEXT := ON) ??
*copyc clp$get_ultimate_connection
*copyc ife$error_codes
*copyc iip$clear_lock
*copyc iip$connection_to_vt_attributes
*copyc iip$search_connection_desc
*copyc iip$set_lock
*copyc iip$st_update_actual_attributes
*copyc iip$st_update_default_atributes
*copyc iiv$connection_desc_ptr
*copyc jmp$system_job
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osv$job_pageable_heap
*copyc rmp$get_device_class
?? POP ??

*copyc iip$xlate_local_file_to_session
*copyc pmp$get_job_mode

?? NEWTITLE := 'PROCEDURE iip$st_chnge_term_conn_defaults', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$st_chnge_term_conn_defaults (terminal_file_name: amt$local_file_name;
    connection_attributes: ift$connection_attributes;
    VAR status: ost$status);

    VAR
      connection_desc_ptr: ^iit$connection_description,
      device_assigned: boolean,
      device_class: rmt$device_class,
      file_id: amt$file_identifier,
      i: integer,
      index: integer,
      j: integer,
      job_mode: jmt$job_mode,
      k: integer,
      local_status: ost$status,
      new_connection_attributes: ^ift$connection_attributes,
      response_received: boolean,
      session_file: amt$local_file_name,
      set_of_term_conn_attribute_keys: iit$set_of_term_conn_attr_keys,
      ultimate_prompt_file: amt$local_file_name;

    status.normal := TRUE;

  { Validate the connection attribute keys and, if specified, the values for
  { the OS defined attributes--prompt_file, prompt_file_id, prompt_string,
  { input_timeout, input_timeout_length, input_timeout_purge, and end_of_information.

    set_of_term_conn_attribute_keys := - $iit$set_of_term_conn_attr_keys [];
    FOR i := LOWERBOUND (connection_attributes) TO UPPERBOUND
          (connection_attributes) DO
      IF NOT (connection_attributes [i].key IN set_of_term_conn_attribute_keys)
            THEN
        osp$set_status_abnormal (ifc$interactive_facility_id,
              ife$unknown_attribute_key, '', status);
        k := ORD (connection_attributes [i].key);
        osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
              FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
          'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
        RETURN;
      IFEND;

      CASE connection_attributes [i].key OF
      = ifc$prompt_file =

        clp$get_ultimate_connection (connection_attributes [i].prompt_file, ultimate_prompt_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Verify that the file is assigned to a terminal device.

        rmp$get_device_class (ultimate_prompt_file, device_assigned, device_class, local_status);
        IF NOT local_status.normal THEN
          status := local_status;
          RETURN;
        ELSE
          IF NOT device_assigned THEN
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$prompt_file_name_not_found, ultimate_prompt_file, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
              'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
            RETURN;
          ELSEIF device_class <> rmc$terminal_device THEN
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$prompt_file_name_not_term, ultimate_prompt_file, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
              'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
            RETURN;
          IFEND;
        IFEND;

      = ifc$prompt_file_identifier =

{ Get the file_name for the file_id.

{ The following code is no-op'ed until BAM provides a way to obtain
{ the local_file_name given the file_id.

{       fetch_attributes [1].key := amc$local_file_name;
{       amp$fetch (connection_attributes [i].prompt_file_identifier, fetch_attributes,
{             local_status);
{       IF NOT local_status.normal THEN
{         status := local_status;
{         RETURN;
{       IFEND;
{
{       clp$get_ultimate_connection (connection_attributes [i].prompt_file, ultimate_prompt_file, status);
{       IF NOT status.normal THEN
{         RETURN;
{       IFEND;
{       IF ultimate_prompt_file <> ultimate_name THEN
{
{ Verify that the file is assigned to a terminal device.
{
{         rmp$get_device_class (fetch_attributes [1].file_name^.local_file_name,
{               device_assigned, device_class, local_status);
{         IF NOT local_status.normal THEN
{           status := local_status;
{           RETURN;
{         ELSE
{           IF NOT device_assigned THEN
{             osp$set_status_abnormal (ifc$interactive_facility_id,
{                   ife$prompt_file_id_not_found, fetch_attributes [1].
{                   file_name^.local_file_name, status);
{             osp$append_status_parameter (osc$status_parameter_delimiter,
{               'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
{             RETURN;
{           ELSEIF device_class <> rmc$terminal_device THEN
{             osp$set_status_abnormal (ifc$interactive_facility_id,
{                   ife$prompt_file_id_not_term, fetch_attributes [1].file_name^.
{                   local_file_name, status);
{             osp$append_status_parameter (osc$status_parameter_delimiter,
{               'IFP$CHANGE_TERM_CONN_ATTRIBUTES', status);
{             RETURN;
{           IFEND;
{         IFEND;
{       IFEND;

      = ifc$prompt_string =

        k := connection_attributes [i].prompt_string.size;
        IF ((k < LOWERVALUE (ift$prompt_string_size)) OR (k > UPPERVALUE
              (ift$prompt_string_size))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$prompt_string_size, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$prompt_string_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$prompt_string_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$end_of_information =

        k := connection_attributes [i].end_of_information.size;
        IF ((k < LOWERVALUE (ift$end_of_information_size)) OR (k > UPPERVALUE
              (ift$end_of_information_size))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$end_of_information_size, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$end_of_information_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$end_of_information_size);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$input_timeout =

        IF ((connection_attributes [i].input_timeout < LOWERVALUE
              (boolean)) OR (connection_attributes [i].input_timeout >
              UPPERVALUE (boolean))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$input_timeout, 'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$input_timeout_length =

        k := connection_attributes [i].input_timeout_length;
        IF ((k < LOWERVALUE (ift$input_timeout_length)) OR (k > UPPERVALUE
              (ift$input_timeout_length))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$input_timeout_length, '', status);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := LOWERVALUE (ift$input_timeout_length);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          k := UPPERVALUE (ift$input_timeout_length);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      = ifc$input_timeout_purge =

        IF ((connection_attributes [i].input_timeout_purge < LOWERVALUE
              (boolean)) OR (connection_attributes [i].input_timeout_purge >
              UPPERVALUE (boolean))) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$input_timeout_purge, 'IFP$CHANGE_TERM_CONN_DEFAULTS', status);
          RETURN;
        IFEND;

      ELSE
      CASEND;
    FOREND;

    iip$xlate_local_file_to_session (terminal_file_name, session_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    iip$search_connection_desc (session_file, connection_desc_ptr);
    IF connection_desc_ptr = NIL THEN
      RETURN;
    IFEND;

    iip$set_lock (connection_desc_ptr^.connection_attributes_lock, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  { Validate the attribute values by changing them in the network and receiving a
  { normal status from the change.

    iip$connection_to_vt_attributes (connection_desc_ptr, connection_attributes,
           status);
    IF status.normal THEN

    { Update the default attributes in the connection table.

      iip$st_update_default_atributes (connection_desc_ptr, connection_attributes,
            ifc$change_term_conn_dflt_req);
      iip$st_update_actual_attributes (connection_desc_ptr, connection_attributes,
            ifc$change_term_conn_dflt_req);
    IFEND;
    iip$clear_lock (connection_desc_ptr^.connection_attributes_lock, local_status);

  PROCEND iip$st_chnge_term_conn_defaults;
MODEND iim$st_chnge_term_conn_defaults;
*DECK DECK=IIM$ST_CHNG_TERMINAL_ATTRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$st_chng_terminal_attributes;
?? TITLE := 'MODULE iim$st_chng_terminal_attributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc ifc$interrupt_timesharing_io
*copyc iik$keypoints
*copyc iip$vt_open
*copyc iip$vt_close
*copyc iip$vt_get_change_response
*copyc iip$vt_to_terminal_attributes
*copyc iip$terminal_to_vt_attributes
*copyc IFE$ERROR_CODES
*copyc iip$vt_change_attributes
*copyc iit$vt_change_error_codes
*copyc iiv$connection_desc_ptr
*copyc iip$clear_lock
*copyc iip$set_lock
*copyc iip$search_connection_desc
*copyc iip$xlate_local_file_to_session
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIV$INTERACTIVE_TERMINATED
*copyc iiv$int_task_open_file_count
*copyc jmp$is_xterm_task
*copyc jmp$system_job
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc OST$STATUS
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc OSP$APPEND_STATUS_INTEGER
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc osp$system_error
*copyc osp$test_sig_lock
*copyc oss$task_shared
*copyc pmp$continue_to_cause
*copyc pmp$find_executing_task_tcb
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$st_chng_terminal_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$st_chng_terminal_attributes (terminal_file_name: amt$local_file_name;
    terminal_attributes: ift$terminal_attributes;
    VAR status: ost$status);

    VAR
      activity_status: [STATIC, oss$task_shared {namve workaround }] ost$activity_status,
      attempt_count: integer,
      attribute_error_pairs: array [1 .. 2] of iit$vt_attribute,
      confirmed: boolean,
      connection_desc_ptr: ^iit$connection_description,
      connection_desc_ptr_set: boolean,
      downline_lock_set: boolean,
      error_code: iit$vt_change_error_codes,
      exit_in_progress: boolean,
      get_lock_already_set: boolean,
      i: integer,
      index: integer,
      j: integer,
      k: integer,
      local_status: ost$status,
      ls: ost$signature_lock_status,
      response_received: boolean,
      session_file: amt$local_file_name,
      set_of_terminal_attribute_keys: iit$terminal_attribute_keys_set,
      tcb_p: ^pmt$task_control_block,
      vtp_attributes: ^iit$vt_attributes,
      vtp_file_id: amt$file_identifier;

?? NEWTITLE := 'PROCEDURE handle_condition', EJECT ??

    PROCEDURE handle_condition (cond: pmt$condition;
          cd: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR ch_status: ost$status);

      ch_status.normal := TRUE;

      IF cond.selector = pmc$block_exit_processing THEN
        IF downline_lock_set THEN
        osp$test_sig_lock (iiv$downline_queue_lock, ls);
          IF ls = osc$sls_locked_by_current_task THEN
            RESET connection_desc_ptr^.output_buffer_entry_loc;
            RESET connection_desc_ptr^.output_buffer_exit_loc;
            connection_desc_ptr^.downline_queue_count := 0;
            iip$clear_lock (iiv$downline_queue_lock, local_status);
          IFEND;
        IFEND;
        IF NOT get_lock_already_set THEN
        IF connection_desc_ptr_set THEN
          osp$test_sig_lock (connection_desc_ptr^.st_get_lock, ls);
          IF ls = osc$sls_locked_by_current_task THEN
            iip$clear_lock (connection_desc_ptr^.st_get_lock, local_status);
          IFEND;
        IFEND;
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
        IF exit_in_progress THEN
          EXIT iip$st_chng_terminal_attributes;
        IFEND;
      IFEND;
    PROCEND handle_condition;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

  /st_change_terminal_attributes/
    BEGIN
      connection_desc_ptr_set := false;
      #spoil(connection_desc_ptr_set);
      exit_in_progress := FALSE;
      downline_lock_set := FALSE;
      osp$establish_condition_handler (^handle_condition, TRUE);

    { Validate the terminal attribute keys.

      set_of_terminal_attribute_keys := - $iit$terminal_attribute_keys_set [];
      FOR i := LOWERBOUND (terminal_attributes) TO UPPERBOUND
            (terminal_attributes) DO
        IF NOT (terminal_attributes [i].key IN set_of_terminal_attribute_keys)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_attribute_key, '', status);
          k := ORD (terminal_attributes [i].key);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$CHANGE_TERMINAL_ATTRIBUTES', status);
          EXIT /st_change_terminal_attributes/;
        IFEND;
      FOREND;

      IF NOT status.normal THEN
        EXIT /st_change_terminal_attributes/;
      IFEND;

      pmp$find_executing_task_tcb (tcb_p);
      IF jmp$is_xterm_task (tcb_p^.task_id) THEN

{ Do not allow xterm task to change terminal attributes.

        RETURN;
      IFEND;

  {   Build a iit$vt_attributes record for input to the iip$vt_change_attributes call.

      PUSH vtp_attributes: [1 .. UPPERBOUND (terminal_attributes)];

      iip$terminal_to_vt_attributes (terminal_attributes, vtp_attributes^);

      iip$xlate_local_file_to_session (terminal_file_name, session_file, status);
      IF NOT status.normal THEN
        EXIT /st_change_terminal_attributes/;
      IFEND;
      iip$search_connection_desc (session_file, connection_desc_ptr);
      IF connection_desc_ptr = NIL THEN
        EXIT /st_change_terminal_attributes/;
      ELSE
        connection_desc_ptr_set := true;
        #spoil(connection_desc_ptr_set);
      IFEND;

      iip$vt_open (connection_desc_ptr^.session_layer_file_name, vtp_file_id, status);
      IF NOT status.normal THEN
        EXIT /st_change_terminal_attributes/;
      IFEND;

      attempt_count := 0;
      REPEAT
        attempt_count := attempt_count + 1;
        iip$set_lock (iiv$downline_queue_lock, osc$wait, status);
        IF NOT status.normal THEN
          EXIT /st_change_terminal_attributes/;
        IFEND;
        downline_lock_set := true;
        #spoil(downline_lock_set);
        iip$vt_change_attributes (connection_desc_ptr^.vtp_connection_id, vtp_file_id, vtp_attributes^,
              osc$wait, activity_status, status);
        IF NOT status.normal THEN
          iip$clear_lock (iiv$downline_queue_lock, local_status);
          downline_lock_set := false;
          #spoil(downline_lock_set);
          EXIT /st_change_terminal_attributes/;
        IFEND;
        iip$clear_lock (iiv$downline_queue_lock, status);
        IF NOT status.normal THEN
          EXIT /st_change_terminal_attributes/;
        IFEND;
        downline_lock_set := false;
        #spoil(downline_lock_set);

        osp$test_sig_lock (connection_desc_ptr^.st_get_lock, ls);
        IF ls <> osc$sls_not_locked THEN
          get_lock_already_set := TRUE;
          #spoil(get_lock_already_set);
        ELSE
          get_lock_already_set := FALSE;
          #spoil(get_lock_already_set);
          iip$set_lock (connection_desc_ptr^.st_get_lock, osc$wait, status);
          IF NOT status.normal THEN
            EXIT /st_change_terminal_attributes/;
          IFEND;
        IFEND;
        IF (ls = osc$sls_locked_by_current_task) OR (NOT get_lock_already_set) THEN
          iip$vt_get_change_response (connection_desc_ptr^.vtp_connection_id, vtp_file_id, osc$wait,
               {confirmed} error_code, attribute_error_pairs, response_received, status);
          { status check will not happen till outside of loop }
        IFEND;
        IF NOT get_lock_already_set THEN
          iip$clear_lock (connection_desc_ptr^.st_get_lock, local_status);
        IFEND;
      UNTIL (attempt_count > 9) OR (status.normal) OR
            ((NOT status.normal) AND (status.condition <> nae$no_event)
            AND (status.condition <> nae$no_data_available)
            AND (status.condition <> nae$data_transfer_timeout));
      IF NOT status.normal THEN
        EXIT /st_change_terminal_attributes/;
      IFEND;

      iip$vt_close (vtp_file_id, status);
      IF NOT status.normal THEN
        EXIT /st_change_terminal_attributes/;
      IFEND;

      confirmed := TRUE;

      IF confirmed THEN

  {     Update the PW, PL and/or TM  attributes in the connection table if they changed.

        iip$set_lock (connection_desc_ptr^.terminal_attributes_lock, osc$wait, status);
        FOR i := 1 TO UPPERBOUND (terminal_attributes) DO
          CASE terminal_attributes [i].key OF
          = ifc$page_length =
            connection_desc_ptr^.page_length := terminal_attributes [i].page_length;
          = ifc$page_width =
            connection_desc_ptr^.page_width := terminal_attributes [i].page_width;
          = ifc$terminal_model =
            connection_desc_ptr^.terminal_model := terminal_attributes [i].terminal_model;
          ELSE
          CASEND;
        FOREND;
      IFEND;
      iip$clear_lock (connection_desc_ptr^.terminal_attributes_lock, status);

    END /st_change_terminal_attributes/;

    osp$disestablish_cond_handler;

  PROCEND iip$st_chng_terminal_attributes;
MODEND iim$st_chng_terminal_attributes;
*DECK DECK=IIM$ST_CLOSE EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$st_close;
?? TITLE := 'MODULE iim$st_close' ??

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc AMP$CLOSE
*copyc ife$error_codes
*copyc IIV$CONNECTION_DESC_PTR
*copyc IIP$CLEAR_LOCK
*copyc IIP$ST_FREE_QUEUE_ENTRY
*copyc IIV$INTERACTIVE_TERMINATED
*copyc iip$search_connection_desc
*copyc IIP$ST_PUT
*copyc iip$st_flush
*copyc IIP$SET_LOCK
*copyc iip$vt_terminate_connection
*copyc IIV$INT_TASK_OPEN_FILE_COUNT
*copyc osp$set_status_abnormal
*copyc OST$STATUS
*copyc iip$vt_close
*copyc osv$job_pageable_heap
*copyc jmv$connection_acquired
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$st_close', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$st_close (file_id: amt$file_identifier;
    VAR open_file_desc_pointer: ^iit$st_open_file_description;
    VAR status: ost$status);

    VAR
      connection_desc_ptr: ^iit$connection_description,
      conn_desc_entry_descriptor: iit$st_queue_entry_descriptor,
      local_status: ost$status,
      open_file_entry_descriptor: iit$st_queue_entry_descriptor,
      temp_connection_desc_ptr: ^iit$connection_description;

      status.normal := TRUE;

{ Return with normal status if the file is not open because BAM must close file.

      IF open_file_desc_pointer = NIL THEN
        RETURN;
      IFEND;

{ Close the prompt file if the system has opened it.

    IF (open_file_desc_pointer^.attributes.prompt_file_identifier.value.ordinal
          <> 0) AND (open_file_desc_pointer^.attributes.prompt_file_identifier.
          source = ifc$os_default) THEN
      amp$close (open_file_desc_pointer^.attributes.prompt_file_identifier.value, status);
      IF status.normal = FALSE THEN
      return;
      IFEND;

    IFEND;

{ Decrement task open file count.

    IF iiv$int_task_open_file_count > 0 THEN
    iiv$int_task_open_file_count := iiv$int_task_open_file_count - 1;
    IFEND;

    iip$search_connection_desc (open_file_desc_pointer^.session_layer_file_name, connection_desc_ptr);
    IF connection_desc_ptr = NIL THEN
      osp$set_status_abnormal (ifc$interactive_facility_id, ife$file_is_not_network_file, '', status);
      RETURN;
    IFEND;

{ Terminate the previous record if at mid_record.

    IF iiv$put_info.last_term_option <> amc$terminate THEN
      iip$st_put (file_id, open_file_desc_pointer, amc$put_partial_req, NIL, 0,
        NIL, amc$terminate, status);
      IF status.normal = FALSE THEN
      return;
      IFEND;

    IFEND;

    IF jmv$connection_acquired THEN
    iip$st_flush (file_id, open_file_desc_pointer, status);
    IF status.normal = FALSE THEN
    return;
    IFEND;
    IFEND;


  { Call iip$vt_close to close the session-layer file's instance-of-open.

    iip$vt_close (open_file_desc_pointer^.vtp_file_id, status);
    IF status.normal = FALSE THEN
    return;
    IFEND;


  { Determine if the connection description is now orphaned and should be freed.

    iip$set_lock (iiv$connection_desc_lock, osc$wait, status);

    IF status.normal = FALSE THEN
    return;
    IFEND;

    connection_desc_ptr^.open_local_file_count := connection_desc_ptr^.open_local_file_count - 1;
    IF connection_desc_ptr^.open_local_file_count <= 0 THEN
      { decrement count of connection descriptors, and unlink it }
      iiv$connection_desc_count := PRED (iiv$connection_desc_count);
      IF connection_desc_ptr = iiv$connection_desc_ptr THEN
        iiv$connection_desc_ptr := iiv$connection_desc_ptr^.next_connection_desc_ptr;
      ELSE
        temp_connection_desc_ptr := iiv$connection_desc_ptr;
      /search_and_unlink/
        WHILE temp_connection_desc_ptr <> NIL DO
          IF temp_connection_desc_ptr^.next_connection_desc_ptr = connection_desc_ptr THEN
            temp_connection_desc_ptr^.next_connection_desc_ptr :=
                  connection_desc_ptr^.next_connection_desc_ptr;
            EXIT /search_and_unlink/;
          ELSE
            temp_connection_desc_ptr := temp_connection_desc_ptr^.next_connection_desc_ptr;
          IFEND;
        WHILEND /search_and_unlink/;
      IFEND;
      { de-allocate the connection description }
      iip$vt_terminate_connection (connection_desc_ptr^.vtp_connection_id, status);

      IF status.normal = FALSE THEN
      return;
      IFEND;

      IF connection_desc_ptr^.output_buffer_entry_loc <> NIL THEN
        FREE connection_desc_ptr^.output_buffer_entry_loc IN osv$job_pageable_heap^;
      IFEND;
      connection_desc_ptr^.output_buffer_exit_loc := NIL;
      conn_desc_entry_descriptor.connection_description_ptr := connection_desc_ptr;
      iip$st_free_queue_entry (iic$connection_description, conn_desc_entry_descriptor, status);
      IF status.normal = FALSE THEN
      return;
      IFEND;

    IFEND;
    iip$clear_lock (iiv$connection_desc_lock, status);
    IF status.normal = FALSE THEN
    return;
    IFEND;


    IF (iiv$int_task_open_file_count = 0) THEN

  { Decrement interactive task count.

      iip$set_lock (iiv$interactive_task_count_lock, osc$wait, status);
      IF status.normal = FALSE THEN
      return;
      IFEND;

      iiv$interactive_task_count := iiv$interactive_task_count - 1;
      iip$clear_lock (iiv$interactive_task_count_lock, status);
      IF status.normal = FALSE THEN
      return;
      IFEND;

    IFEND;
    open_file_entry_descriptor.open_file_description_ptr :=
      open_file_desc_pointer;
    iip$st_free_queue_entry (iic$open_file_description,
      open_file_entry_descriptor, status);
      IF status.normal = FALSE THEN
      return;
      IFEND;


  PROCEND iip$st_close;

MODEND iim$st_close;
*DECK DECK=IIM$ST_CLR_INPUT_OUTPUT_COUNTS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'Module iim$st_clr_input_output_counts' ??
?? NEWTITLE := 'Global Declarations' ??
MODULE iim$st_clr_input_output_counts;
?? PUSH (LISTEXT := ON) ??
*copyc iit$connection_description
*copyc iiv$connection_desc_ptr
*copyc osc$timesharing_terminal_file
*copyc ost$status
?? POP ??

?? TITLE := '[XDCL] iip$st_clr_input_output_counts', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$st_clr_input_output_counts
     (VAR status: ost$status);

    VAR
      connection_desc_ptr: ^iit$connection_description;

    status.normal := true;
    IF iiv$connection_desc_ptr = NIL THEN
      RETURN;
    ELSE
      connection_desc_ptr := iiv$connection_desc_ptr;
      WHILE connection_desc_ptr <> NIL DO
        IF connection_desc_ptr^.session_layer_file_name =
          osc$timesharing_terminal_file THEN
          connection_desc_ptr^.job_input_count := 0;
          connection_desc_ptr^.job_output_count := 0;
        IFEND;
        connection_desc_ptr := connection_desc_ptr^.next_connection_desc_ptr;
      WHILEND;
    IFEND;
  PROCEND iip$st_clr_input_output_counts;

MODEND iim$st_clr_input_output_counts;
*DECK DECK=IIM$ST_FETCH_ACCESS_INFORMATION EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$st_fetch_access_information;
?? TITLE := 'MODULE iim$st_fetch_access_information' ??

?? PUSH (LISTEXT := ON) ??
*copyc AME$IMPROPER_ACCESS_INFO_KEY
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc IIK$KEYPOINTS
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIV$INT_TASK_OPEN_FILE_COUNT
*copyc OST$STATUS
*copyc PMP$LOG
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$st_fetch_access_information', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$st_fetch_access_information (file_id:
    amt$file_identifier;
    st_open_file_desc_pointer: ^iit$st_open_file_description;
    access_information: ^amt$access_information;
    VAR status: ost$status);

    VAR
      set_of_access_info_keys: iit$set_of_access_info_keys,
      i: integer;

    status.normal := TRUE;

  /fetch_access_information/
    BEGIN

      set_of_access_info_keys := - $iit$set_of_access_info_keys [];
      FOR i := 1 TO UPPERBOUND (access_information^) DO
        IF NOT (access_information^ [i].key IN set_of_access_info_keys) THEN
          amp$set_file_instance_abnormal (file_id, ame$improper_access_info_key,
                amc$fetch_access_information_rq, '', status);
          EXIT /fetch_access_information/;
        IFEND;
      FOREND;

      FOR i := 1 TO UPPERBOUND (access_information^) DO

        access_information^ [i].item_returned := TRUE;

        CASE access_information^ [i].key OF

        = amc$block_number =
        { This is a NO-OP on NAM/VE since block numbers are not a part of the
        { protocol as with NAM.

        = amc$error_status =
          access_information^ [i].error_status := st_open_file_desc_pointer^.
                error_status;

        = amc$file_position =
          CASE st_open_file_desc_pointer^.last_get_put_operation OF
          = amc$get_next_req, amc$get_partial_req, amc$get_direct_req =
            access_information^ [i].file_position := iiv$get_info.file_position;
          = amc$put_next_req, amc$put_partial_req, amc$put_direct_req =
            IF iiv$put_info.last_term_option = amc$terminate THEN
              access_information^ [i].file_position := amc$eor;
            ELSE
              access_information^ [i].file_position := amc$mid_record;
            IFEND;
          ELSE
            pmp$log (' st_fetch_access_info: unknown last_get_put_operation', status);
          CASEND;

        = amc$last_access_operation =
          access_information^ [i].last_access_operation :=
                st_open_file_desc_pointer^.last_access_operation;

        = amc$last_op_status =
          access_information^ [i].last_op_status := amc$complete;

        = amc$previous_record_length =
          CASE st_open_file_desc_pointer^.last_get_put_operation OF
          = amc$get_next_req, amc$get_partial_req, amc$get_direct_req =
            IF iiv$get_info.file_position <> amc$mid_record THEN
              access_information^ [i].previous_record_length :=
                    st_open_file_desc_pointer^.previous_record_length;
            ELSE
              access_information^ [i].item_returned := FALSE;
            IFEND;
          = amc$put_next_req, amc$put_partial_req, amc$put_direct_req =
            IF iiv$put_info.last_term_option = amc$terminate THEN
              access_information^ [i].previous_record_length :=
                    st_open_file_desc_pointer^.previous_record_length;
            ELSE
              access_information^ [i].item_returned := FALSE;
            IFEND;
          ELSE
            pmp$log (' st_fetch_access_info: unknown previous_record_length', status);
          CASEND;

        ELSE
          access_information^ [i].item_returned := FALSE;
        CASEND;

      FOREND;

    END /fetch_access_information/;

  PROCEND iip$st_fetch_access_information;
MODEND iim$st_fetch_access_information;
*DECK DECK=IIM$ST_FLUSH EXPAND=TRUE
*copyc osd$default_pragmats
MODULE iim$st_flush;
?? NEWTITLE := 'MODULE iim$st_flush' ??

?? PUSH (LISTEXT := ON) ??
*copyc ifc$interrupt_timesharing_io
*copyc ife$error_codes
*copyc iik$keypoints
*copyc iit$connection_description
*copyc iit$interactive_signal_type
*copyc iiv$connection_desc_ptr
*copyc iiv$interactive_terminated
*copyc iiv$int_task_open_file_count
*copyc nat$data_fragments
*copyc ost$status
*copyc pmp$log
?? POP ??

*copyc iip$clear_lock
*copyc iip$report_status_error
*copyc iip$search_connection_desc
*copyc iip$set_lock
*copyc iip$st_put
*copyc iip$st_send_output_message
*copyc jmp$handle_ts_io_req_failure
*copyc jmp$ts_io_request_valid
*copyc osp$clear_job_signature_lock
*copyc osp$establish_condition_handler
*copyc osp$decrement_locked_variable
*copyc osp$disestablish_cond_handler
*copyc osp$increment_locked_variable
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osp$test_sig_lock
*copyc pmp$continue_to_cause
*copyc pmp$log

*copyc iiv$io_requests_in_job
*copyc iiv$io_requests_in_task

?? NEWTITLE := 'PROCEDURE iip$st_flush', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$st_flush (file_id: amt$file_identifier;
        open_file_desc_pointer: ^iit$st_open_file_description;
    VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      connection_desc_ptr: ^iit$connection_description,
      decrement_error: boolean,
      exit_in_progress: boolean,
      io_requests_in_job: integer,
      local_status: ost$status,
      ls: ost$signature_lock_status;

?? NEWTITLE := 'PROCEDURE handle_break', EJECT ??

    PROCEDURE handle_break (cond: pmt$condition;
          cd: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR ch_status: ost$status);

      VAR
      iiv$condition_handler_trace: [XREF]  boolean,
      local_status: ost$status;


      IF cond.selector = pmc$block_exit_processing THEN
        IF iiv$condition_handler_trace THEN
          pmp$log ('ST_FLUSH block exit condition',local_status);
        IFEND;
        iiv$io_requests_in_task:= iiv$io_requests_in_task - 1;
        osp$decrement_locked_variable (iiv$io_requests_in_job, iiv$io_requests_in_job, io_requests_in_job,
              decrement_error);

      ELSEIF (cond.selector = pmc$user_defined_condition) AND
          (cond.user_condition_name = ifc$interrupt_timesharing_io) THEN

        IF iiv$condition_handler_trace THEN
          pmp$log ('ST_FLUSH interrupt condition',local_status);
        IFEND;
        IF exit_in_progress THEN
          pmp$log ('Multiple ifc$interrupt_timesharing_io conditions received.', local_status);
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
        exit_in_progress := TRUE;
        EXIT iip$st_flush;
      ELSE
        IF iiv$condition_handler_trace THEN
          pmp$log ('ST_FLUSH neither block exit nor interrupt',local_status);
        IFEND;
        pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
        IF exit_in_progress THEN
          EXIT iip$st_flush;
        IFEND;
      IFEND;

    PROCEND handle_break;
?? OLDTITLE ??
?? EJECT ??

    osp$test_sig_lock (iiv$downline_queue_lock, ls);
    IF ls = osc$sls_locked_by_current_task THEN

{     some sort of unintended recursion has occured. ignore flush.

      status.normal := TRUE;
      RETURN;
    IFEND;

    exit_in_progress := FALSE;
    #spoil (exit_in_progress);
    osp$establish_condition_handler (^handle_break, TRUE);

    IF iiv$put_info.last_term_option <> amc$terminate THEN

    { Add the contents of the buffer used for put-partial data to the downline queue.

      iip$st_put (file_id, open_file_desc_pointer, amc$put_partial_req,
            NIL, 0, NIL, amc$terminate, status);
      IF NOT status.normal THEN
        pmp$log (' IIP$ST_PUT returned bad status in IIP$ST_FLUSH', status);
      IFEND;
    IFEND;

  /st_flush/
    BEGIN
      osp$increment_locked_variable (iiv$io_requests_in_job, iiv$io_requests_in_job, io_requests_in_job);
      iiv$io_requests_in_task := iiv$io_requests_in_task + 1;
      WHILE NOT jmp$ts_io_request_valid () DO
        iiv$io_requests_in_task := iiv$io_requests_in_task - 1;
        osp$decrement_locked_variable (iiv$io_requests_in_job, iiv$io_requests_in_job, io_requests_in_job,
              decrement_error);
        osp$disestablish_cond_handler;

        jmp$handle_ts_io_req_failure (status);
        IF status.normal THEN
          osp$establish_condition_handler (^handle_break, TRUE);
          osp$increment_locked_variable (iiv$io_requests_in_job, iiv$io_requests_in_job, io_requests_in_job);
          iiv$io_requests_in_task := iiv$io_requests_in_task + 1;
        ELSE
          RETURN;
        IFEND;
      WHILEND;

      iip$search_connection_desc (open_file_desc_pointer^.session_layer_file_name, connection_desc_ptr);
      IF connection_desc_ptr = NIL THEN
        IF exit_in_progress THEN
          osp$system_error ('FLUSH non-local exit did not complete.', NIL);
        IFEND;

        iiv$io_requests_in_task := iiv$io_requests_in_task - 1;
        osp$decrement_locked_variable (iiv$io_requests_in_job, iiv$io_requests_in_job,
              io_requests_in_job, decrement_error);
        osp$disestablish_cond_handler;
        RETURN;
      IFEND;

    /empty_the_downline_queue/
      WHILE TRUE DO
        iip$set_lock (iiv$downline_queue_lock, osc$wait, local_status);
        IF connection_desc_ptr^.downline_queue_count = 0 THEN
          iip$clear_lock (iiv$downline_queue_lock, local_status);
          EXIT /empty_the_downline_queue/;
        ELSE
          iip$clear_lock (iiv$downline_queue_lock, status);
          iip$st_send_output_message (connection_desc_ptr, open_file_desc_pointer^.vtp_file_id, status);
          IF NOT status.normal THEN
            IF exit_in_progress THEN
              osp$system_error ('FLUSH non-local exit did not complete.', NIL);
            IFEND;

            iiv$io_requests_in_task := iiv$io_requests_in_task - 1;
            osp$decrement_locked_variable (iiv$io_requests_in_job, iiv$io_requests_in_job,
                  io_requests_in_job, decrement_error);
            osp$disestablish_cond_handler;
            RETURN;
          IFEND;
        IFEND;
      WHILEND /empty_the_downline_queue/;

    END /st_flush/;

    #spoil (exit_in_progress);
    IF exit_in_progress THEN
      osp$system_error ('FLUSH non-local exit did not complete.', NIL);
    IFEND;

    iiv$io_requests_in_task := iiv$io_requests_in_task - 1;
    osp$decrement_locked_variable (iiv$io_requests_in_job, iiv$io_requests_in_job, io_requests_in_job,
          decrement_error);
    osp$disestablish_cond_handler;

    status.normal := TRUE;

  PROCEND iip$st_flush;

MODEND iim$st_flush;
*DECK DECK=IIM$ST_GET EXPAND=TRUE
*copyc osd$default_pragmats
MODULE iim$st_get;
?? NEWTITLE := 'MODULE iim$st_get' ??

?? PUSH (LISTEXT := ON) ??
*copyc amd$operation_declarations
*copyc ame$terminal_validation_errors
*copyc amp$put_next
*copyc amt$file_byte_address
*copyc amt$file_position
*copyc amt$max_record_length
*copyc amt$skip_option
*copyc amt$transfer_count
*copyc amt$working_storage_length
*copyc cle$unseen_mail_condition
*copyc ifc$interrupt_timesharing_io
*copyc ife$error_codes
*copyc ife$interactive_exception_codes
*copyc iik$keypoints
*copyc iit$connection_description
*copyc i#ptr
*copyc jmt$dispatching_control_info
*copyc jmv$jcb
*copyc jmv$system_job_ssn
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc osc$unseen_mail_condition
*copyc oss$task_shared
*copyc ost$status
*copyc ost$wait
*copyc tmc$wait_times
*copyc tmv$null_global_task_id
*copyc pmp$log
*copyc iip$vt_input
?? POP ??

*copyc amp$set_file_instance_abnormal
*copyc bat$task_file_table
*copyc bav$last_tft_entry
*copyc bav$task_file_table
*copyc fsp$open_file
*copyc ifp$fap_control
*copyc ifp$st_fap_control
*copyc iip$clear_lock
*copyc iip$search_connection_desc
*copyc iip$set_lock
*copyc iip$st_flush
*copyc iip$st_put
*copyc jmp$handle_ts_io_req_failure
*copyc jmp$select_reset_disp_pr_r2
*copyc jmp$ts_io_request_valid
*copyc jmp$system_job
*copyc jmp$change_dispatching_prior_r1
*copyc jmp$select_reset_disp_pr_r2
*copyc osp$decrement_locked_variable
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$increment_locked_variable
*copyc osp$set_status_condition
*copyc osp$system_error
*copyc osp$test_sig_lock
*copyc pmp$continue_to_cause
*copyc pmp$exit

*copyc iiv$interactive_terminated
*copyc iiv$int_task_open_file_count
*copyc iiv$io_requests_in_job
*copyc iiv$io_requests_in_task

?? NEWTITLE := 'PROCEDURE iip$st_get', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$st_get (file_id: amt$file_identifier;
        open_file_desc_pointer: ^iit$st_open_file_description;
        operation: amt$fap_operation;
        working_storage_area: ^cell;
        working_storage_length: nat$data_length;
        record_length: ^amt$max_record_length;
        transfer_count: ^amt$transfer_count;
        byte_address: ^amt$file_byte_address;
        file_position: ^amt$file_position;
        skip_option: amt$skip_option;
    VAR status: ost$status);

      VAR
        exit_in_progress: boolean,
        connection_desc_ptr: ^iit$connection_description,
        current_transfer_count: amt$transfer_count,
        decrement_error: boolean,
        get_lock_set: boolean,
        input_information: [STATIC, oss$task_shared {NAMVE workaround}] iit$vt_input_information,
        io_requests_in_job: integer,
        local_status: ost$status,
        message_received,
        prompt_sent: boolean,
        null_dispatching_info: jmt$dispatching_control_info,
        put_byte_address: amt$file_byte_address,
        saved_attributes: iit$connection_attributes,
        skip_upline_block: boolean,
        temp_working_storage_area: ^cell,
        temp_working_storage_length: nat$data_length,
        timeout: iit$vt_timeout,
        vtp_transfer_count: nat$data_length;

?? NEWTITLE := 'FUNCTION eoi', EJECT ??

      FUNCTION eoi: boolean;

        { If the data just received is equal to the end_of_information
        { attribute
        { for this file instance return with eoi set to TRUE; otherwise, FALSE.

        VAR
          local_stat: ost$status,
          end_of_info: boolean,
          wsa_pointer: ^string (ifc$max_end_of_information_size);

        IF open_file_desc_pointer^.attributes.end_of_information.
          value.value (1, open_file_desc_pointer^.attributes.
          end_of_information.value.size) = $char(13) THEN
          IF connection_desc_ptr^.get_info.record_length = 0 THEN
            eoi := true;
          ELSE
            eoi := false;
          IFEND;
        ELSE
          end_of_info := (working_storage_area <> NIL) AND
            (open_file_desc_pointer^.attributes.end_of_information.value.
            size <> 0) AND (open_file_desc_pointer^.attributes.
            input_editing_mode.value = ifc$normal_edit) AND
            (connection_desc_ptr^.get_info.record_length =
            open_file_desc_pointer^.attributes.end_of_information.value.
            size);

          IF end_of_info THEN
            wsa_pointer := working_storage_area;
            end_of_info := (wsa_pointer^ (1, connection_desc_ptr^.get_info.
            record_length) = open_file_desc_pointer^.attributes.
            end_of_information.value.value (1, open_file_desc_pointer^.
            attributes.end_of_information.value.size));
          IFEND;
          eoi := end_of_info;
        IFEND;
      FUNCEND eoi;
?? OLDTITLE ??
  ?? NEWTITLE := 'PROCEDURE send_prompt', EJECT ??

      PROCEDURE send_prompt (prompt_allowed: boolean;
        VAR status: ost$status);

        VAR
          file_identifier: amt$file_identifier,
          file_id_is_valid: boolean,
          file_instance: ^bat$task_file_entry,
          prompt_file_has_format_effector: boolean,
          prompt_string_start_index: 1 .. ifc$max_prompt_string_size,
          format_effector_null_prompt: char,
          put_length: amt$working_storage_length,
          st_open_file_dsc_pointer: ^iit$st_open_file_description,
          put_byte_address: amt$file_byte_address;

        #KEYPOINT (osk$entry, 0, iik$send_prompt);
        status.normal := TRUE;

      { Ensure that the prompt file is open.

        IF open_file_desc_pointer^.attributes.prompt_file_identifier.value.ordinal = 0 THEN
          fsp$open_file (open_file_desc_pointer^.attributes.prompt_file.value,
                amc$record, NIL, NIL, NIL, NIL, NIL, open_file_desc_pointer^.attributes.
                prompt_file_identifier.value, status);
          IF NOT status.normal THEN
            #KEYPOINT (osk$exit, 0, iik$send_prompt);
            RETURN;
          IFEND;
        IFEND;

        put_length := 0;
        prompt_string_start_index := 1;
        iiv$put_info.build_msg_block := TRUE;

        IF (open_file_desc_pointer^.attributes.input_editing_mode.value = ifc$normal_edit)
              AND (prompt_allowed) AND
              (open_file_desc_pointer^.attributes.prompt_string.value.size <> 0) THEN

        { Determine whether or not the prompt file has format effectors.

          file_identifier := open_file_desc_pointer^.attributes.
            prompt_file_identifier.value;
*copy bai$validate_file_identifier
*copy iii$fetch_st_open_file_desc_ptr
          IF NOT status.normal THEN
            #KEYPOINT (osk$exit, 0, iik$send_prompt);
            RETURN;
          IFEND;
          prompt_file_has_format_effector := st_open_file_dsc_pointer^.
            format_effectors;

          put_length := open_file_desc_pointer^.attributes.prompt_string.value.size;

        { Discard the format effector of the prompt string if at mid record.

          IF (open_file_desc_pointer^.attributes.prompt_string.value.size <> 0) AND
                prompt_file_has_format_effector AND (iiv$put_info.last_term_option
                <> amc$terminate) THEN
            prompt_string_start_index := 2;
            put_length := open_file_desc_pointer^.attributes.prompt_string.value.size - 1;
          IFEND;

        { Output the prompt string.

          st_open_file_dsc_pointer^.attributes.input_editing_mode.value :=
            ifc$normal_edit;

          IF (put_length = 0) AND prompt_file_has_format_effector AND
                (iiv$put_info.last_term_option = amc$terminate) THEN
            format_effector_null_prompt := ifc$pre_print_no_positioning;
            put_length := 1;
            iip$st_put (open_file_desc_pointer^.attributes.prompt_file_identifier.value,
                  st_open_file_dsc_pointer, amc$put_partial_req,
                  ^format_effector_null_prompt,
                  put_length, ^put_byte_address, amc$terminate, status);
          ELSE
            iip$st_put (open_file_desc_pointer^.attributes.prompt_file_identifier.value,
                  st_open_file_dsc_pointer, amc$put_partial_req,
                    ^open_file_desc_pointer^.attributes.prompt_string.
                  value.value (prompt_string_start_index, 1), put_length, ^ put_byte_address,
                  amc$terminate, status);
          IFEND;

          iiv$put_info.build_msg_block := FALSE;

          IF NOT status.normal THEN
            #KEYPOINT (osk$exit, 0, iik$send_prompt);
            RETURN;
          IFEND;
        IFEND;

      { Output an iic$last_block for the get file id.
        iiv$put_info.term_char_null := TRUE;

        iip$st_put (file_id, open_file_desc_pointer, amc$put_partial_req,
              ^open_file_desc_pointer^.attributes.prompt_string.value.value
              (prompt_string_start_index, 1), 0, ^put_byte_address,
              amc$terminate, status);

        iiv$put_info.term_char_null := FALSE;
        iiv$put_info.build_msg_block := FALSE;

        IF NOT status.normal THEN
          #KEYPOINT (osk$exit, 0, iik$send_prompt);
          RETURN;
        IFEND;

        iip$st_flush (file_id, open_file_desc_pointer, status);
        IF NOT status.normal THEN
          #KEYPOINT (osk$exit, 0, iik$send_prompt);
          RETURN;
        IFEND;

        #KEYPOINT (osk$exit, 0, iik$send_prompt);

      PROCEND send_prompt;
  ?? OLDTITLE ??
  ?? NEWTITLE := 'PROCEDURE handle_break', EJECT ??

      PROCEDURE handle_break (cond: pmt$condition;
            cd: ^pmt$condition_information;
            sa: ^ost$stack_frame_save_area;
        VAR ch_status: ost$status);

        VAR
          iiv$condition_handler_trace: [XREF]  boolean,
          ls: ost$signature_lock_status,
          local_status: ost$status;


        CASE cond.selector OF
        = pmc$block_exit_processing =
          IF iiv$condition_handler_trace THEN
            pmp$log ('ST_GET block exit condition',local_status);
          IFEND;
          iiv$io_requests_in_task:= iiv$io_requests_in_task - 1;
          osp$decrement_locked_variable (iiv$io_requests_in_job, iiv$io_requests_in_job, io_requests_in_job,
                decrement_error);

          IF get_lock_set THEN
            IF iiv$condition_handler_trace THEN
              pmp$log ('ST_GET - get_lock_set entered',local_status);
            IFEND;
            osp$test_sig_lock (connection_desc_ptr^.st_get_lock, ls);
            IF ls = osc$sls_locked_by_current_task THEN
              iip$clear_lock (connection_desc_ptr^.st_get_lock, local_status);
            IFEND;
            get_lock_set := FALSE;
            #spoil (get_lock_set);
            connection_desc_ptr^.get_info.file_position := amc$eor;
          IFEND;

          osp$set_status_condition (ife$abort_get, status);

        = pmc$user_defined_condition =
          IF cond.user_condition_name = ifc$interrupt_timesharing_io THEN
            IF iiv$condition_handler_trace THEN
              pmp$log ('ST_GET interrupt_timesharing_io',local_status);
            IFEND;
            IF exit_in_progress THEN
              pmp$log ('Multiple ifc$interrupt_timesharing_io conditions received.', local_status);
            IFEND;
            pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
            #KEYPOINT (osk$exit, 0, iik$st_get);
            exit_in_progress := TRUE;
            EXIT iip$st_get;

          ELSEIF cond.user_condition_name = osc$unseen_mail_condition THEN
            IF iiv$condition_handler_trace THEN
              pmp$log ('ST_GET unseen_mail_condition',local_status);
            IFEND;
            pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
            osp$set_status_condition (cle$unseen_mail_condition, status);
            #KEYPOINT (osk$exit, 0, iik$st_get);
            EXIT iip$st_get;
          IFEND;

        ELSE
          ;
        CASEND;

        IF iiv$condition_handler_trace THEN
          pmp$log ('ST_GET continue_to_cause',local_status);
        IFEND;
        pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
        IF exit_in_progress THEN
          #KEYPOINT (osk$exit, 0, iik$st_get);
          EXIT iip$st_get;
        IFEND;

      PROCEND handle_break;
  ?? OLDTITLE ??
  ?? EJECT ??

      #KEYPOINT (osk$entry, 0, iik$st_get);
    /st_get/
      BEGIN
        exit_in_progress := FALSE;

        prompt_sent := FALSE;
        get_lock_set := FALSE;
        #spoil(get_lock_set);
        #spoil (get_lock_set);
        skip_upline_block := FALSE;

{ The following procedure call causes the jobs priority to be reset. It is
{ support code for DYNAMIC DISPATCHING. This procedure calls a ring 1 procedure
{ which stores the global_taskid of this task (the interactive task) in the
{ IJL entry of the job. When the task is next readied, the priority of the job
{ will be reset, and the taskid in the IJL entry will be set to null. If
{ we exit this procedure with the taskid still in the IJL entry, the priority
{ of the job will be immediately reset. The situation will occur if the user
{ is typing ahead.

      jmp$select_reset_disp_pr_r2;

      { Protect the get lock with a handler for interactive conditions to
      { insure that they are recognized and the get lock gets cleared.

        osp$establish_condition_handler (^handle_break, TRUE);

        osp$increment_locked_variable (iiv$io_requests_in_job, iiv$io_requests_in_job, io_requests_in_job);
        iiv$io_requests_in_task := iiv$io_requests_in_task + 1;
        iip$search_connection_desc (open_file_desc_pointer^.session_layer_file_name, connection_desc_ptr);
        IF connection_desc_ptr = NIL THEN
          osp$set_status_condition (ife$file_is_not_network_file, status);
          EXIT /st_get/;
        IFEND;

        iip$set_lock (connection_desc_ptr^.st_get_lock, osc$wait, status);
        IF NOT status.normal THEN
          EXIT /st_get/;
        IFEND;
        get_lock_set := TRUE;
        #spoil (get_lock_set);

        WHILE NOT jmp$ts_io_request_valid () DO

          IF exit_in_progress THEN
            osp$system_error ('GET non-local exit did not complete.', NIL);
          IFEND;

          iiv$io_requests_in_task := iiv$io_requests_in_task - 1;
          osp$decrement_locked_variable (iiv$io_requests_in_job, iiv$io_requests_in_job, io_requests_in_job,
                decrement_error);
          IF get_lock_set THEN
            iip$clear_lock (connection_desc_ptr^.st_get_lock, local_status);
            get_lock_set := FALSE;
            #spoil (get_lock_set);
          IFEND;
          osp$disestablish_cond_handler;
          jmp$handle_ts_io_req_failure (status);
          IF status.normal THEN
            osp$establish_condition_handler (^handle_break, TRUE);
            osp$increment_locked_variable (iiv$io_requests_in_job, iiv$io_requests_in_job,
                  io_requests_in_job);
            iiv$io_requests_in_task := iiv$io_requests_in_task + 1;
            iip$set_lock (connection_desc_ptr^.st_get_lock, osc$wait, status);
            IF NOT status.normal THEN
              EXIT /st_get/;
            IFEND;
            get_lock_set := TRUE;
            #spoil (get_lock_set);
          ELSE
            RETURN;
          IFEND;
        WHILEND;

        IF NOT jmp$system_job() THEN
          connection_desc_ptr^.solicitation_pending := FALSE;
        IFEND;

      /loop_here_if_skip_upline_block/
        WHILE TRUE DO
          status.normal := TRUE;

        { Set up for data transfer.

          IF skip_option = amc$skip_to_eor THEN
            IF connection_desc_ptr^.get_info.file_position = amc$mid_record THEN

            { Position to EOR before receiving input by discarding buffered input data until
            { a logical end_of_message.

              connection_desc_ptr^.get_info.end_of_message := TRUE;
              IF connection_desc_ptr^.get_info.block_type = iic$last_block THEN
                skip_upline_block := FALSE;
                connection_desc_ptr^.get_info.file_position := amc$eor;
              ELSE
                skip_upline_block := TRUE;
              IFEND;
            IFEND;
          IFEND;

          IF (skip_option = amc$skip_to_eor) OR (connection_desc_ptr^.get_info.file_position <>
                amc$mid_record) THEN
            IF NOT prompt_sent THEN
              send_prompt ((NOT connection_desc_ptr^.solicitation_pending), status);
              prompt_sent := TRUE;
              IF NOT status.normal THEN
                EXIT /st_get/;
              IFEND;
            IFEND;
          IFEND;

        { Detect context switching and, if needed, blank the screen.

          IF (iiv$previous_mode = iic$screen) AND
                ((open_file_desc_pointer^.terminal_mode = iic$line) OR (file_id.ordinal <>
                iiv$previous_file_id.ordinal)) THEN
            iiv$previous_mode := iic$line;
            IF NOT iiv$previous_blank_flag THEN
              iiv$previous_blank_flag := TRUE;
              saved_attributes := open_file_desc_pointer^.attributes;
              open_file_desc_pointer^.attributes := iiv$previous_connection_attr;
            iip$st_put (file_id, open_file_desc_pointer, amc$put_next_req,
              #LOC (iiv$screen_clear_string.value), iiv$screen_clear_string.size,
              ^put_byte_address, amc$terminate, status);
              open_file_desc_pointer^.attributes := saved_attributes;
            IFEND;
          IFEND;

          iiv$previous_blank_flag := FALSE;
          IF open_file_desc_pointer^.terminal_mode = iic$line THEN
            iiv$previous_mode := iic$line;
          IFEND;
          iiv$previous_operation := operation;
          iiv$previous_file_id := file_id;

        { Initialize data transfer variables.

          IF connection_desc_ptr^.get_info.file_position <> amc$mid_record THEN
            connection_desc_ptr^.get_info.record_length := 0;
            connection_desc_ptr^.get_info.transfer_count := 0;
            connection_desc_ptr^.get_info.end_of_message := TRUE;
          IFEND;
          current_transfer_count := 0;
          temp_working_storage_area := working_storage_area;
          temp_working_storage_length := working_storage_length;

        /transfer_data_to_user/
          WHILE TRUE DO

          /get_data_from_network/
            REPEAT

              IF connection_desc_ptr^.get_info.end_of_message THEN
                connection_desc_ptr^.get_info.queued_data_length := 0;
              IFEND; { connection_desc_ptr^.get_info.end_of_message }

              timeout.on := open_file_desc_pointer^.attributes.input_timeout.value;
              IF timeout.on THEN
                timeout.length := open_file_desc_pointer^.attributes.input_timeout_length.value;
                timeout.purge := open_file_desc_pointer^.attributes.input_timeout_purge.value;
              IFEND;

{ The following procedure call causes the jobs priority to be reset. It is
{ support code for DYNAMIC DISPATCHING.

              jmp$select_reset_disp_pr_r2;

              iip$vt_input (open_file_desc_pointer^.vtp_connection_id, open_file_desc_pointer^.vtp_file_id,
                    temp_working_storage_area, temp_working_storage_length, timeout,
                    message_received, connection_desc_ptr^.get_info.end_of_message, vtp_transfer_count,
                    input_information, status);

              IF NOT status.normal THEN
                IF (status.condition = nae$no_data_available) OR (status.condition = nae$no_event)
                      OR (status.condition = nae$data_transfer_timeout) THEN
                  IF timeout.on THEN
                    IF timeout.length = 0 THEN
                      osp$set_status_condition (ife$no_data_available, status);
                    ELSE
                      osp$set_status_condition (ife$input_timeout_exceeded, status);
                    IFEND;
                    EXIT /st_get/;
                  ELSE
{!!                 Unexpected timeout code.  For R121 convert to cancel.  Someday do better.
{!!!}               input_information.cancel := TRUE;
                  IFEND;
                ELSE
                  connection_desc_ptr^.solicitation_pending := FALSE;
                  EXIT /st_get/;
                IFEND;
              ELSE
                connection_desc_ptr^.job_input_count :=
                  connection_desc_ptr^.job_input_count + vtp_transfer_count;
              IFEND;

              connection_desc_ptr^.solicitation_pending := FALSE;

              IF input_information.partial OR NOT
                    connection_desc_ptr^.get_info.end_of_message THEN
                connection_desc_ptr^.get_info.block_type := iic$continued_block;
                temp_working_storage_area := i#ptr (vtp_transfer_count,
                  temp_working_storage_area);
                temp_working_storage_length := temp_working_storage_length -
                  vtp_transfer_count;

              ELSE
                connection_desc_ptr^.get_info.block_type := iic$last_block;
              IFEND;
              connection_desc_ptr^.get_info.record_length := connection_desc_ptr^.get_info.record_length
                    + vtp_transfer_count;
              connection_desc_ptr^.get_info.queued_data_length := connection_desc_ptr^.get_info.
                    queued_data_length + vtp_transfer_count;
              connection_desc_ptr^.get_info.cancel_input := input_information.cancel;

              IF (working_storage_length <> 0) AND (vtp_transfer_count <> 0) THEN

              { Data has been moved to the user's working_storage_area and the
              { following variables are updated to account for this.

                current_transfer_count := current_transfer_count + vtp_transfer_count;
                connection_desc_ptr^.get_info.transfer_count := connection_desc_ptr^.get_info.transfer_count
                      + vtp_transfer_count;
              IFEND;

              IF (open_file_desc_pointer^.attributes.input_editing_mode.value = ifc$trans_edit) THEN
                IF input_information.editing_mode = 0 THEN
                  osp$set_status_condition (ife$xpt_mode_drop_unexpected, status);
                  { Note - do NOT return after setting this abnormal status }
                IFEND;
              IFEND;

            UNTIL (NOT input_information.partial) OR (input_information.cancel) OR
                  (connection_desc_ptr^.get_info.queued_data_length >= iic$max_cancellable_input) OR
                  (current_transfer_count = working_storage_length);
        { /get_data_from_network/ end }

            IF skip_upline_block THEN
              CYCLE /loop_here_if_skip_upline_block/;
            IFEND;

            IF (connection_desc_ptr^.get_info.cancel_input) THEN
              connection_desc_ptr^.get_info.file_position := amc$eor;
              connection_desc_ptr^.get_info.end_of_message := TRUE;
              connection_desc_ptr^.get_info.record_length := 0;
              connection_desc_ptr^.get_info.transfer_count := 0;
              current_transfer_count := 0;
              temp_working_storage_area := working_storage_area;
              temp_working_storage_length := working_storage_length;
              IF connection_desc_ptr^.get_info.queued_data_length < iic$max_cancellable_input THEN
                CYCLE /transfer_data_to_user/;
              IFEND;
            IFEND;

            IF (current_transfer_count = working_storage_length) OR (temp_working_storage_length <= 0) THEN
              EXIT /transfer_data_to_user/;
            IFEND;

            connection_desc_ptr^.get_info.end_of_message := TRUE;

            IF connection_desc_ptr^.get_info.block_type = iic$last_block THEN
              EXIT /transfer_data_to_user/;
            IFEND;

          WHILEND /transfer_data_to_user/;

        { Set proper post operation file position.

          IF connection_desc_ptr^.get_info.end_of_message AND (connection_desc_ptr^.get_info.block_type =
                iic$last_block) THEN
            connection_desc_ptr^.get_info.file_position := amc$eor;
          ELSE
            connection_desc_ptr^.get_info.file_position := amc$mid_record;
          IFEND;

        { Detect input cancellation.

          IF (connection_desc_ptr^.get_info.file_position = amc$eor) AND (connection_desc_ptr^.get_info.
                cancel_input) AND (connection_desc_ptr^.get_info.record_length > iic$max_cancellable_input)
                THEN
            amp$set_file_instance_abnormal(file_id, ame$max_cancellable_input,
                  operation, '', status);
          IFEND;

          EXIT /loop_here_if_skip_upline_block/;

        WHILEND /loop_here_if_skip_upline_block/;


      { Return parameters to the caller.

        IF record_length <> NIL THEN
          record_length^ := connection_desc_ptr^.get_info.record_length;
        IFEND;

        IF transfer_count <> NIL THEN
          transfer_count^ := current_transfer_count;
        IFEND;

        IF file_position <> NIL THEN
          file_position^ := connection_desc_ptr^.get_info.file_position;
        IFEND;

        IF byte_address <> NIL THEN
          byte_address^ := 0;
        IFEND;

      { Check for end-of-information.

        IF eoi() THEN
          IF record_length <> NIL THEN
            record_length^ := 0;
          IFEND;
          IF transfer_count <> NIL THEN
            transfer_count^ := 0;
          IFEND;
          IF file_position <> NIL THEN
            file_position^ := amc$eoi;
          IFEND;
          IF byte_address <> NIL THEN
            byte_address^ := 0;
          IFEND;

          connection_desc_ptr^.get_info.file_position := amc$eoi;

        IFEND; { IF eoi THEN }

      { Save access information.

        open_file_desc_pointer^.last_get_put_operation := operation;
        open_file_desc_pointer^.last_access_operation := operation;
        open_file_desc_pointer^.previous_record_length := connection_desc_ptr^.get_info.record_length;

      END /st_get/;
      #KEYPOINT (osk$exit, 0, iik$st_get);

      IF exit_in_progress THEN
        osp$system_error ('GET non-local exit did not complete.', NIL);
      IFEND;

{ Raise priority if it has not already been done.

      IF jmv$jcb.ijle_p^.interactive_task_gtid <> tmv$null_global_task_id THEN
        jmp$change_dispatching_prior_r1 (tmc$cpo_interactive_command, jmv$jcb.ijl_ordinal,
           jmv$jcb.system_name, null_dispatching_info, local_status);
      IFEND;

      iiv$io_requests_in_task := iiv$io_requests_in_task - 1;
      osp$decrement_locked_variable (iiv$io_requests_in_job, iiv$io_requests_in_job, io_requests_in_job,
            decrement_error);
      IF get_lock_set THEN
        iip$clear_lock (connection_desc_ptr^.st_get_lock, local_status);
        get_lock_set := FALSE;
        #spoil (get_lock_set);
      IFEND;
      osp$disestablish_cond_handler;

  PROCEND iip$st_get;

MODEND iim$st_get;
*DECK DECK=IIM$ST_GET_INPUT_OUTPUT_COUNTS EXPAND=TRUE
*copyc osd$default_pragmats
MODULE iim$st_get_input_output_counts;
?? NEWTITLE := 'Module iim$st_get_input_output_counts' ??
?? NEWTITLE := 'Global Declarations' ??
?? PUSH (LISTEXT := ON) ??
*copyc iit$connection_description
*copyc iip$st_clr_input_output_counts
*copyc iiv$connection_desc_ptr
*copyc osc$timesharing_terminal_file
*copyc osd$integer_limits
*copyc ost$status
?? POP ??

?? TITLE := '[XDCL] iip$st_get_input_output_counts', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$st_get_input_output_counts
    (VAR input_count: ost$non_negative_integers;
     VAR output_count: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      connection_desc_ptr: ^iit$connection_description;

    status.normal := true;
    input_count := 0;
    output_count := 0;

    IF iiv$connection_desc_ptr = NIL THEN
      RETURN;
    ELSE
      connection_desc_ptr := iiv$connection_desc_ptr;
      WHILE connection_desc_ptr <> NIL DO
        IF connection_desc_ptr^.session_layer_file_name =
          osc$timesharing_terminal_file THEN
          input_count := input_count + connection_desc_ptr^.job_input_count;
          output_count := output_count + connection_desc_ptr^.job_output_count;
        IFEND;
        connection_desc_ptr := connection_desc_ptr^.next_connection_desc_ptr;
      WHILEND;

      iip$st_clr_input_output_counts (status);
    IFEND;

  PROCEND iip$st_get_input_output_counts;

MODEND iim$st_get_input_output_counts;








*DECK DECK=IIM$ST_GET_TERMINAL_ATTRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$st_get_terminal_attributes;
?? TITLE := 'MODULE iim$st_get_terminal_attributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc ifc$interrupt_timesharing_io
*copyc iik$keypoints
*copyc iip$vt_kind_to_if_key
*copyc iip$terminal_keys_to_vt_kinds
*copyc iip$vt_to_terminal_attributes
*copyc IFE$ERROR_CODES
*copyc ift$terminal_attributes
*copyc IIV$CONNECTION_DESC_PTR
*copyc iiv$interactive_terminated
*copyc IIP$CLEAR_LOCK
*copyc IIP$SET_LOCK
*copyc iip$xlate_local_file_to_session
*copyc iip$search_connection_desc
*copyc iip$xt_get_terminal_attributes
*copyc jmp$get_job_attributes
*copyc jmp$is_xterm_task
*copyc jmp$system_job
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nat$data_fragments
*copyc oss$task_shared
*copyc OST$STATUS
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc OSP$APPEND_STATUS_INTEGER
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc osp$set_status_from_condition
*copyc osp$system_error
*copyc osp$test_sig_lock
*copyc pmp$continue_to_cause
*copyc pmp$find_executing_task_tcb
*copyc iip$vt_open
*copyc iip$vt_close
*copyc iip$vt_query_attributes
*copyc iip$vt_get_query_response
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$st_get_terminal_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$st_get_terminal_attributes (file_name: amt$local_file_name;
    VAR terminal_attributes: ift$terminal_attributes;
    VAR status: ost$status);

    VAR
      activity_status: [STATIC, oss$task_shared {namve workaround} ] ost$activity_status,
      attempt_count: integer,
      confirmed: boolean,
      connection_desc_ptr: ^iit$connection_description,
      connection_desc_ptr_set: boolean,
      downline_lock_set: boolean,
      exit_in_progress: boolean,
      get_lock_set: boolean,
      i: integer,
      job_attribute_results: ^jmt$job_attribute_results,
      k: integer,
      local_status: ost$status,
      ls: ost$signature_lock_status,
      response_received: boolean,
      session_file: amt$local_file_name,
      set_of_terminal_attribute_keys: iit$terminal_attribute_keys_set,
      tcb_p: ^pmt$task_control_block,
      terminal_name_ptr: ^ift$terminal_name,
      terminal_name_requested: boolean,
      terminal_name_index: integer,
      unknown_attribute_number: iit$vt_attribute_kind,
      vtp_attributes: ^iit$vt_attributes,
      vtp_attribute_kinds: ^iit$vt_attribute_kinds,
      vtp_file_id: amt$file_identifier;

?? NEWTITLE := 'PROCEDURE handle_condition', EJECT ??

    PROCEDURE handle_condition (cond: pmt$condition;
          cd: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR ch_status: ost$status);

      VAR
        ignore_status: ost$status;

      ch_status.normal := TRUE;

      IF cond.selector = pmc$block_exit_processing THEN
        IF downline_lock_set THEN
        osp$test_sig_lock (iiv$downline_queue_lock, ls);
          IF ls = osc$sls_locked_by_current_task THEN
            RESET connection_desc_ptr^.output_buffer_entry_loc;
            RESET connection_desc_ptr^.output_buffer_exit_loc;
            connection_desc_ptr^.downline_queue_count := 0;
            iip$clear_lock (iiv$downline_queue_lock, local_status);
          IFEND;
        IFEND;
        IF get_lock_set THEN
        osp$test_sig_lock (connection_desc_ptr^.st_get_lock, ls);
          IF ls = osc$sls_locked_by_current_task THEN
          iip$clear_lock (connection_desc_ptr^.st_get_lock, local_status);
          IFEND;
        IFEND;
      ELSEIF cond.selector = pmc$system_conditions THEN
        IF status.normal THEN
          osp$set_status_from_condition ('II', cond, sa,
                status, ignore_status);
        IFEND;
        EXIT  iip$st_get_terminal_attributes;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
        IF exit_in_progress THEN
          EXIT iip$st_get_terminal_attributes;
        IFEND;
      IFEND;
    PROCEND handle_condition;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

  /st_get_terminal_attributes/
    BEGIN

      connection_desc_ptr_set := false;
      #spoil(connection_desc_ptr_set);
      exit_in_progress := FALSE;
      downline_lock_set := FALSE;
      get_lock_set := FALSE;
      osp$establish_condition_handler (^handle_condition, TRUE);

{ Validate the terminal attribute keys.

      terminal_name_index := 0;
      set_of_terminal_attribute_keys := - $iit$terminal_attribute_keys_set [];
      FOR i := LOWERBOUND (terminal_attributes) TO UPPERBOUND
            (terminal_attributes) DO
        IF NOT (terminal_attributes [i].key IN set_of_terminal_attribute_keys)
              THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$unknown_attribute_key, '', status);
          k := ORD (terminal_attributes [i].key);
          osp$append_status_integer (osc$status_parameter_delimiter, k, 10,
                FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'IFP$GET_TERMINAL_ATTRIBUTES', status);
          EXIT /st_get_terminal_attributes/;
        IFEND;
        IF terminal_attributes [i].key = ifc$terminal_name THEN
          terminal_name_ptr := terminal_attributes [i].terminal_name;
          terminal_attributes [i].key := ifc$attention_character;
          terminal_name_index := i;
        IFEND;
      FOREND;

      pmp$find_executing_task_tcb (tcb_p);
      IF jmp$is_xterm_task (tcb_p^.task_id) THEN

{ Get default terminal attributes needed by C to start xterm program.

        iip$xt_get_terminal_attributes (file_name, terminal_attributes, status);
        RETURN;
      IFEND;

{ Build a iit$vt_attribute_kinds array for input to a iip$vt_query_attributes call.

      PUSH vtp_attribute_kinds: [1 .. UPPERBOUND (terminal_attributes)];
      PUSH vtp_attributes: [1 .. UPPERBOUND (terminal_attributes)];

      iip$terminal_keys_to_vt_kinds (terminal_attributes, vtp_attribute_kinds^);

      iip$xlate_local_file_to_session (file_name, session_file, status);
      IF NOT status.normal THEN
        EXIT /st_get_terminal_attributes/;
      IFEND;

      iip$search_connection_desc (session_file, connection_desc_ptr);
      IF connection_desc_ptr = NIL THEN
        EXIT /st_get_terminal_attributes/;
      ELSE
        connection_desc_ptr_set := true;
        #spoil(connection_desc_ptr_set);
      IFEND;

      iip$vt_open (connection_desc_ptr^.session_layer_file_name, vtp_file_id, status);
      IF NOT status.normal THEN
        EXIT /st_get_terminal_attributes/;
      IFEND;

      attempt_count := 0;
      REPEAT
        attempt_count := attempt_count + 1;
        iip$set_lock (iiv$downline_queue_lock, osc$wait, status);
        IF NOT status.normal THEN
          EXIT /st_get_terminal_attributes/;
        IFEND;
        downline_lock_set := true;
        #spoil(downline_lock_set);

        iip$vt_query_attributes (connection_desc_ptr^.vtp_connection_id, vtp_file_id, vtp_attribute_kinds^,
              osc$wait, activity_status, status);
        IF NOT status.normal THEN
          iip$clear_lock (iiv$downline_queue_lock, local_status);
          downline_lock_set := false;
          #spoil(downline_lock_set);
          EXIT /st_get_terminal_attributes/;
        IFEND;
        iip$clear_lock (iiv$downline_queue_lock, status);
        IF NOT status.normal THEN
          EXIT /st_get_terminal_attributes/;
        IFEND;
        downline_lock_set := false;
        #spoil(downline_lock_set);

  { Get the query response and return either the queried attribute values or, if the query
  { caused an error, the attribute key causing the error.

        iip$set_lock (connection_desc_ptr^.st_get_lock, osc$wait, status);
        IF NOT status.normal THEN
          EXIT /st_get_terminal_attributes/;
        IFEND;
        get_lock_set := true;
        #spoil(get_lock_set);

        iip$vt_get_query_response (connection_desc_ptr^.vtp_connection_id, vtp_file_id, osc$wait, confirmed,
              vtp_attributes^, unknown_attribute_number, response_received, status);
        { status check will not happen till outside of loop }
        iip$clear_lock (connection_desc_ptr^.st_get_lock, local_status);
        get_lock_set := false;
        #spoil(get_lock_set);
      UNTIL (attempt_count > 9) OR (status.normal) OR
            ((NOT status.normal) AND (status.condition <> nae$no_event)
            AND (status.condition <> nae$no_data_available)
            AND (status.condition <> nae$data_transfer_timeout));
      IF NOT status.normal THEN
        EXIT /st_get_terminal_attributes/;
      IFEND;

      iip$vt_close (vtp_file_id, local_status);
      IF NOT local_status.normal THEN
        IF status.normal THEN
          status := local_status;
        IFEND;
        EXIT /st_get_terminal_attributes/;
      IFEND;

      IF confirmed THEN
        iip$vt_to_terminal_attributes (vtp_attributes^, terminal_attributes);
      IFEND;

      IF terminal_name_index <> 0 THEN
        terminal_attributes [terminal_name_index].key := ifc$terminal_name;
        terminal_attributes [terminal_name_index].terminal_name := terminal_name_ptr;
        terminal_attributes [terminal_name_index].terminal_name^ :=
              connection_desc_ptr^.terminal_name;
      IFEND;

    END /st_get_terminal_attributes/;

    osp$disestablish_cond_handler;

  PROCEND iip$st_get_terminal_attributes;

MODEND iim$st_get_terminal_attributes;
*DECK DECK=IIM$ST_INITIALIZE_CONNECTION EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$st_initialize_connection;
?? TITLE := 'MODULE iim$st_initialize_connection' ??

?? PUSH (LISTEXT := ON) ??
*copyc OSS$JOB_PAGED_LITERAL
*copyc IIT$CONNECTION_DESCRIPTION
*copyc iip$clear_lock
*copyc iip$connection_to_vt_attributes
*copyc iip$set_lock
*copyc IIP$ST_ALLOCATE_QUEUE_ENTRY
*copyc iip$vt_initialize_connection
*copyc IIV$CONNECTION_DESC_PTR
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIV$INT_TASK_OPEN_FILE_COUNT
*copyc jmv$connection_acquired
*copyc nap$get_attributes
*copyc jmp$is_xterm_job
*copyc jmp$system_job
*copyc nat$data_fragments
*copyc OSS$TASK_SHARED
*copyc OSP$INITIALIZE_SIG_LOCK
*copyc OSV$TASK_SHARED_HEAP
*copyc PMP$GET_EXECUTING_TASK_GTID
?? POP ??

?? NEWTITLE := '  convert_and_download', EJECT ??

    PROCEDURE convert_and_download (attributes: iit$connection_attributes;
          connection_desc_ptr: ^iit$connection_description;
      VAR status: ost$status);

      VAR
        converted_loc: ^ift$connection_attributes,
        i: ift$connection_attribute_keys,
        j: integer,
        scratch_seq: ^SEQ ( * );

      PUSH scratch_seq: [[REP (ORD (ifc$max_connection_key) - ORD (ifc$min_connection_key) + 1)
            * #SIZE (ift$connection_attribute) OF CELL]];
      RESET scratch_seq;
      NEXT converted_loc: [1 .. (ORD (ifc$max_connection_key) - ORD (ifc$min_connection_key) + 1)]
            IN scratch_seq;
      j := 0;
      FOR i := ifc$min_connection_key TO ifc$max_connection_key DO
        j := j + 1;
        converted_loc^ [j].key := i;
        CASE i OF
        = ifc$attention_character_action =
          converted_loc^ [j].attention_character_action := attributes.attention_character_action.value;

        = ifc$break_key_action =
          converted_loc^ [j].break_key_action := attributes.break_key_action.value;

        = ifc$end_of_information =
          converted_loc^ [j].end_of_information := attributes.end_of_information.value;

        = ifc$input_block_size =
          converted_loc^ [j].input_block_size := attributes.input_block_size.value;

        = ifc$input_editing_mode =
          converted_loc^ [j].input_editing_mode := attributes.input_editing_mode.value;

        = ifc$input_output_mode =
          converted_loc^ [j].input_output_mode := attributes.input_output_mode.value;

        = ifc$input_timeout =
          converted_loc^ [j].input_timeout := attributes.input_timeout.value;

        = ifc$input_timeout_length =
          converted_loc^ [j].input_timeout_length := attributes.input_timeout_length.value;

        = ifc$input_timeout_purge =
          converted_loc^ [j].input_timeout_purge := attributes.input_timeout_purge.value;

        = ifc$null_connection_attribute =
          j := j - 1;

        = ifc$partial_char_forwarding =
          converted_loc^ [j].partial_character_forwarding := attributes.partial_char_forwarding.value;

        = ifc$prompt_file =
          converted_loc^ [j].prompt_file := attributes.prompt_file.value;

        = ifc$prompt_file_identifier =
          converted_loc^ [j].prompt_file_identifier := attributes.prompt_file_identifier.value;

        = ifc$prompt_string =
          converted_loc^ [j].prompt_string := attributes.prompt_string.value;

        = ifc$store_backspace_character =
          converted_loc^ [j].store_backspace_character := attributes.store_backspace_character.value;

        = ifc$store_nuls_dels =
          converted_loc^ [j].store_nuls_dels := attributes.store_nuls_dels.value;

        = ifc$trans_character_mode =
          converted_loc^ [j].trans_character_mode := attributes.trans_character_mode.value;

        = ifc$trans_forward_character =
          converted_loc^ [j].trans_forward_character := attributes.trans_forward_character.value;

        = ifc$trans_length_mode =
          converted_loc^ [j].trans_length_mode := attributes.trans_length_mode.value;

        = ifc$trans_message_length =
          converted_loc^ [j].trans_message_length := attributes.trans_message_length.value;

        = ifc$trans_terminate_character =
          converted_loc^ [j].trans_terminate_character := attributes.trans_terminate_character.value;

        = ifc$trans_timeout_mode =
          converted_loc^ [j].trans_timeout_mode := attributes.trans_timeout_mode.value;

        ELSE
          j := j - 1;
        CASEND;
      FOREND;

      IF j > 0 THEN
        RESET scratch_seq;
        NEXT converted_loc: [1 .. j] IN scratch_seq;
        iip$connection_to_vt_attributes (connection_desc_ptr, converted_loc^,
              status);
      IFEND;

    PROCEND convert_and_download;
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE iip$st_initialize_connection', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$st_initialize_connection (terminal_file_name: amt$local_file_name;
    VAR status: ost$status);

    VAR
      connection_desc_ptr: ^iit$connection_description,
      conn_desc_entry_descriptor: iit$st_queue_entry_descriptor,
      temp_string: ^string (*),
      get_attributes: array [1 ..1] of nat$get_attribute,
      local_status: ost$status,
      vtp_connection_id: iit$vtp_connection_id;

    iiv$network_identifier := iic$cdcnet_network;

    iip$set_lock (iiv$connection_desc_lock, osc$wait, status);

    iip$st_allocate_queue_entry (iic$connection_description, conn_desc_entry_descriptor, status);

    IF iiv$connection_desc_ptr = NIL THEN
      iiv$connection_desc_ptr := conn_desc_entry_descriptor.connection_description_ptr;
      connection_desc_ptr := iiv$connection_desc_ptr;
      osp$initialize_sig_lock (iiv$interactive_task_count_lock);
      osp$initialize_sig_lock (iiv$downline_queue_lock);
      osp$initialize_sig_lock (connection_desc_ptr^.st_get_lock);
    ELSE
      connection_desc_ptr := iiv$connection_desc_ptr;
      WHILE connection_desc_ptr^.next_connection_desc_ptr <> NIL DO
        connection_desc_ptr := connection_desc_ptr^.next_connection_desc_ptr;
      WHILEND;
      connection_desc_ptr^.next_connection_desc_ptr := conn_desc_entry_descriptor.connection_description_ptr;
      connection_desc_ptr := connection_desc_ptr^.next_connection_desc_ptr;
      osp$initialize_sig_lock (connection_desc_ptr^.st_get_lock);
    IFEND;

    connection_desc_ptr^.actual_connection_attributes := iiv$deflt_connection_attributes;
    connection_desc_ptr^.default_connection_attributes := iiv$deflt_connection_attributes;
    connection_desc_ptr^.downline_queue_count := 0;
    connection_desc_ptr^.get_info := iiv$get_info;
    connection_desc_ptr^.job_input_count := 0;
    connection_desc_ptr^.job_output_count := 0;
    connection_desc_ptr^.next_connection_desc_ptr := NIL;
    connection_desc_ptr^.open_local_file_count := 0;
    connection_desc_ptr^.output_buffer_entry_loc := NIL;
    connection_desc_ptr^.output_buffer_exit_loc := NIL;
    connection_desc_ptr^.page_length := 30;
    connection_desc_ptr^.page_width := 80;
    connection_desc_ptr^.session_layer_file_name := terminal_file_name;
    connection_desc_ptr^.solicitation_pending := FALSE;
    connection_desc_ptr^.terminal_model.size := 6;
    connection_desc_ptr^.terminal_model.value := 'CDC721';

{ Set the Terminal_Name terminal attribute in the connection description.

    IF jmp$is_xterm_job () THEN

{ An xterm job cannot get accounting information
{ through network access accounting information from peer.

      iiv$connection_desc_ptr^.terminal_name := osc$null_name;
    ELSE
      get_attributes [1].kind := nac$peer_accounting_information;
      PUSH get_attributes [1].peer_accounting_information: [[REP 256 OF char]];
      nap$get_attributes (terminal_file_name, get_attributes, status);
      IF NOT status.normal THEN
        get_attributes [1].peer_accounting_info_length := 0;
        status.normal := TRUE;
      IFEND;

      RESET get_attributes [1].peer_accounting_information;
      IF get_attributes [1].peer_accounting_info_length <> 0 THEN
        NEXT temp_string: [get_attributes [1].peer_accounting_info_length]
              IN get_attributes [1].peer_accounting_information;
        iiv$connection_desc_ptr^.terminal_name := temp_string^ (79, 31);
      ELSE
        iiv$connection_desc_ptr^.terminal_name := osc$null_name;
      IFEND;
    IFEND;

    iip$vt_initialize_connection (connection_desc_ptr^.vtp_connection_id, status);

    osp$initialize_sig_lock (connection_desc_ptr^.connection_attributes_lock);
    osp$initialize_sig_lock (connection_desc_ptr^.terminal_attributes_lock);

    pmp$get_executing_task_gtid (iiv$job_monitor_task_id);
    iiv$task_handling_break := iiv$job_monitor_task_id;

    iiv$connection_desc_count := SUCC (iiv$connection_desc_count);

    iip$clear_lock (iiv$connection_desc_lock, status);

    IF (NOT jmp$system_job ()) AND (jmv$connection_acquired) THEN
      IF NOT jmp$is_xterm_job () THEN

{ Connection attributes are already initialized for an xterm job.

        convert_and_download (connection_desc_ptr^.actual_connection_attributes,
              connection_desc_ptr, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

  PROCEND iip$st_initialize_connection;

?? NEWTITLE := 'PROCEDURE iip$st_clone_connection', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$st_clone_connection
    (VAR status: ost$status);

    pmp$get_executing_task_gtid (iiv$job_monitor_task_id);
    iiv$task_handling_break := iiv$job_monitor_task_id;
    status.normal := TRUE;
    convert_and_download (iiv$deflt_connection_attributes,
        iiv$connection_desc_ptr, status);

  PROCEND iip$st_clone_connection;
MODEND
*DECK DECK=IIM$ST_INIT_OPEN_DESC_ATRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$st_init_open_desc_atributes;

{ PURPOSE:  This module initializes the attributes field of an open
{           file descriptor.  Its procedure is called only by
{           IIP$ST_OPEN.
{
{  DESIGN:  The connection attribute values used to initialize the
{           open file descriptor are obtained from REQUEST_TERMINAL,
{           CHANGE_TERM_CONN_ATTRIBUTES, CHANGE_TERM_CONN_DEFAULT
{           command interface requests, and RMP$REQUEST_TERMINAL,
{           IFP$CHANGE_TERM_CONN_ATTRIBUTES, IFP$CHANGE_TERM_CONN_
{           DEFAULTS program interface requests, upline attribute
{           changes (i.e., attributes changed by TIP commands), and
{           the default connection attributes established at LOGIN.
{           An attribute hierarchy is established here:  LOGIN values,
{           CHATCD/IFP$CHATCD, REQT/RMP$REQT/CHATCA/IFP$CHATCA, and,
{           finally, upline attribute changes, in order of increasing
{           priority.
{
?? TITLE := 'MODULE iim$st_init_open_desc_atributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc fmp$get_terminal_attributes
*copyc clp$get_ultimate_connection
*copyc iip$clear_lock
*copyc iip$search_connection_desc
*copyc iip$set_lock
*copyc iip$vt_get_attr_ch_indications
*copyc iip$vt_to_terminal_attributes
*copyc iip$xlate_local_file_to_session
*copyc iiv$connection_desc_ptr
*copyc iiv$interactive_terminated
*copyc oss$task_private
*copyc ost$status
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$st_init_open_desc_atributes', EJECT ??

  PROCEDURE [XDCL] iip$st_init_open_desc_atributes (file_name: ost$name;
        open_file_desc_pointer: ^iit$st_open_file_description;
    VAR status: ost$status);

    VAR
      connection_desc_ptr: ^iit$connection_description,
      dummy: iit$vt_attribute_kind,
      i: integer,
      if_attributes: ^ift$terminal_attributes,
      j: ift$connection_attribute_keys,
      lnt_attributes: array [1 .. (ORD (ifc$max_connection_key) + 1)] OF
        ift$get_connection_attribute,
      number_of_attributes: 0 .. iic$vt_max_number_of_attributes,
      session_file: amt$local_file_name,
      ultimate_name: amt$local_file_name,
      valid_name: boolean,
      vt_attributes: ^iit$vt_attributes,
      vt_indications: ^iit$vt_attributes,
      validated_name: ost$name;

    status.normal := TRUE;
    lnt_attributes := iiv$all_get_term_attributes;

    clp$get_ultimate_connection (file_name, ultimate_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    iip$xlate_local_file_to_session (ultimate_name, session_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    iip$search_connection_desc (session_file, connection_desc_ptr);
    IF connection_desc_ptr = NIL THEN
      RETURN;
    IFEND;

  { Initialize the open file descriptor's attributes to the connection's defaults.

    open_file_desc_pointer^.attributes := iiv$deflt_connection_attributes;

  { Get the connection attributes from the Local Name Table entry for the file
  { and use them to update the open file descriptor attributes.

    fmp$get_terminal_attributes (ultimate_name, lnt_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    FOR i := 1 TO (ORD (ifc$max_connection_key) + 1) DO
      CASE lnt_attributes [i].key OF
      = ifc$attention_character_action =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.attention_character_action.value :=
                lnt_attributes [i].attention_character_action;
          open_file_desc_pointer^.attributes.attention_character_action.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$break_key_action =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.break_key_action.value :=
                lnt_attributes [i].break_key_action;
          open_file_desc_pointer^.attributes.break_key_action.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$end_of_information =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.end_of_information.value :=
                lnt_attributes [i].end_of_information;
          open_file_desc_pointer^.attributes.end_of_information.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$input_block_size =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.input_block_size.value :=
                lnt_attributes [i].input_block_size;
          open_file_desc_pointer^.attributes.input_block_size.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$input_editing_mode =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.input_editing_mode.value :=
                lnt_attributes [i].input_editing_mode;
          open_file_desc_pointer^.attributes.input_editing_mode.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$input_output_mode =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.input_output_mode.value :=
                lnt_attributes [i].input_output_mode;
          open_file_desc_pointer^.attributes.input_output_mode.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$input_timeout =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.input_timeout.value :=
                lnt_attributes [i].input_timeout;
          open_file_desc_pointer^.attributes.input_timeout.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$input_timeout_length =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.input_timeout_length.value :=
                lnt_attributes [i].input_timeout_length;
          open_file_desc_pointer^.attributes.input_timeout_length.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$input_timeout_purge =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.input_timeout_purge.value :=
                lnt_attributes [i].input_timeout_purge;
          open_file_desc_pointer^.attributes.input_timeout_purge.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$partial_char_forwarding =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.partial_char_forwarding.value :=
                lnt_attributes [i].partial_character_forwarding;
          open_file_desc_pointer^.attributes.partial_char_forwarding.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$prompt_file =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.prompt_file.value :=
                lnt_attributes [i].prompt_file;
          open_file_desc_pointer^.attributes.prompt_file.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$prompt_file_identifier =
        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.prompt_file_identifier.value :=
                lnt_attributes [i].prompt_file_identifier;
          open_file_desc_pointer^.attributes.prompt_file_identifier.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$prompt_string =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.prompt_string.value :=
                lnt_attributes [i].prompt_string;
          open_file_desc_pointer^.attributes.prompt_string.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$store_backspace_character =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.store_backspace_character.value :=
                lnt_attributes [i].store_backspace_character;
          open_file_desc_pointer^.attributes.store_backspace_character.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$store_nuls_dels =
        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.store_nuls_dels.value :=
                lnt_attributes [i].store_nuls_dels;
          open_file_desc_pointer^.attributes.store_nuls_dels.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$trans_character_mode =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.trans_character_mode.value :=
                lnt_attributes [i].trans_character_mode;
          open_file_desc_pointer^.attributes.trans_character_mode.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$trans_forward_character =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.trans_forward_character.value :=
                lnt_attributes [i].trans_forward_character;
          open_file_desc_pointer^.attributes.trans_forward_character.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$trans_length_mode =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.trans_length_mode.value :=
                lnt_attributes [i].trans_length_mode;
          open_file_desc_pointer^.attributes.trans_length_mode.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$trans_timeout_mode =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.trans_timeout_mode.value :=
                lnt_attributes [i].trans_timeout_mode;
          open_file_desc_pointer^.attributes.trans_timeout_mode.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$trans_message_length =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.trans_message_length.value :=
                lnt_attributes [i].trans_message_length;
          open_file_desc_pointer^.attributes.trans_message_length.source :=
                lnt_attributes [i].source;
        IFEND;

      = ifc$trans_terminate_character =

        IF lnt_attributes [i].source <> ifc$undefined_attribute THEN
          open_file_desc_pointer^.attributes.trans_terminate_character.value :=
                lnt_attributes [i].trans_terminate_character;
          open_file_desc_pointer^.attributes.trans_terminate_character.source :=
                lnt_attributes [i].source;
        IFEND;

      ELSE
      CASEND;
    FOREND;

  { Update BAM's page width and page length attributes for the file if they have been
  { changed from the terminal end with a TIP command.

    PUSH vt_attributes: [1 .. (ORD (UPPERVALUE (dummy))-
          ORD (LOWERVALUE (dummy))+ 1)];
    iip$vt_get_attr_ch_indications (connection_desc_ptr^.vtp_connection_id,
          vt_attributes^, number_of_attributes, status);
    IF status.normal AND (number_of_attributes <> 0) THEN
      PUSH vt_indications: [1 .. number_of_attributes];
      PUSH if_attributes: [1 .. number_of_attributes];
      FOR i := 1 TO number_of_attributes DO
        vt_indications^ [i] := vt_attributes^ [i];
      FOREND;
      iip$vt_to_terminal_attributes (vt_indications^, if_attributes^);
      iip$set_lock (connection_desc_ptr^.terminal_attributes_lock, osc$wait, status);
      IF status.normal THEN
        FOR i := 1 TO number_of_attributes DO
          CASE if_attributes^ [i].key OF
          = ifc$page_length =
            connection_desc_ptr^.page_length := if_attributes^ [i].page_length;
          = ifc$page_width =
            connection_desc_ptr^.page_width := if_attributes^ [i].page_width;
          = ifc$terminal_model =
            connection_desc_ptr^.terminal_model := if_attributes^ [i].terminal_model;
          ELSE
          CASEND;
        FOREND;
        iip$clear_lock (connection_desc_ptr^.terminal_attributes_lock, status);

      IFEND; { status.normal from iip$set_lock }
    IFEND; { status.normal from iip$vt_get_attr_ch_indications AND (number_of_attributes <> 0) }

  PROCEND iip$st_init_open_desc_atributes;
MODEND iim$st_init_open_desc_atributes;
*DECK DECK=IIM$ST_OPEN EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$st_open;
?? TITLE := 'MODULE iim$st_open' ??

?? PUSH (LISTEXT := ON) ??
*copyc ame$open_validation_errors
*copyc amd$operation_declarations
*copyc amp$access_method
*copyc amp$get_file_attributes
*copyc amp$set_file_instance_abnormal
*copyc amt$fap_declarations
*copyc amt$file_identifier
*copyc cle$ecc_lexical
*copyc clp$convert_integer_to_string
*copyc clp$validate_name
*copyc ife$error_codes
*copyc iip$search_connection_desc
*copyc iip$xlate_local_file_to_session
*copyc iik$keypoints
*copyc iip$clear_lock
*copyc iip$set_lock
*copyc iip$st_initialize_connection
*copyc iip$st_init_open_desc_atributes
*copyc iit$connection_description
*copyc iiv$connection_desc_ptr
*copyc iiv$interactive_terminated
*copyc iiv$int_task_open_file_count
*copyc nat$data_fragments
*copyc osc$timesharing_terminal_file
*copyc osp$set_status_abnormal
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc osv$job_pageable_heap
*copyc osv$task_private_heap
*copyc osv$task_shared_heap
*copyc rmp$get_device_class
*copyc iip$vt_open
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$st_open', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$st_open (file_id: amt$file_identifier;
        open_file_desc_pointer: ^iit$st_open_file_description;
        file_name: amt$local_file_name;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    VAR
      call_block: amt$call_block,
      connection_desc_ptr: ^iit$connection_description,
      contains_data: boolean,
      device_assigned: boolean,
      device_class: rmt$device_class,
      fetch_file_contents_array: array [1 .. 1] of amt$fetch_item,
      file_attributes: [STATIC, READ, oss$job_paged_literal] array [1 .. 1] of amt$get_item :=
        [[amc$undefined_attribute, amc$null_attribute]],
      iiv$tbl_initialized: [STATIC, oss$task_private] boolean := FALSE,
      lfn: ost$name,
      local_file: boolean,
      local_status: ost$status,
      max_task_count_string: ost$string,
      old_file: boolean,
      terminal_file_name: amt$local_file_name,
      validated_name: ost$name,
      valid_name: boolean;

  /open_file/
    BEGIN


    { Put the file name into the open file description.

      clp$validate_name (file_name, validated_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal ('CL', cle$improper_name, file_name, status);
        EXIT /open_file/;
      IFEND;
      open_file_desc_pointer^.file_name := validated_name;

    { Initialize file access information.

      open_file_desc_pointer^.last_get_put_operation := amc$put_next_req;
      open_file_desc_pointer^.last_access_operation := amc$open_req;
      open_file_desc_pointer^.previous_record_length := 0;

    { Get the terminal file name associated with the file being opened.

      iip$xlate_local_file_to_session (file_name, terminal_file_name, status);
      IF NOT status.normal THEN
        EXIT /open_file/;
      IFEND;

    { Make sure the terminal file is actually assigned to a network device.

      rmp$get_device_class (terminal_file_name, device_assigned, device_class, status);
      IF NOT status.normal THEN
        EXIT /open_file/;
      IFEND;
      IF (device_class <> rmc$network_device) OR (NOT device_assigned) THEN
        osp$set_status_abnormal (ifc$interactive_facility_id, ife$file_is_not_network_file,
              '', status);
        EXIT /open_file/;
      IFEND;

      { The connection description was allocated at request_terminal time.  However, check
      { for its possible non-existence, as it could have been subsequently freed by closing
      { of all local files before opening of this one.

      iip$search_connection_desc (terminal_file_name, connection_desc_ptr);
      IF connection_desc_ptr = NIL THEN
        iip$st_initialize_connection (terminal_file_name, status);
        IF NOT status.normal THEN
          EXIT /open_file/;
        IFEND;
        iip$search_connection_desc (terminal_file_name, connection_desc_ptr);
      IFEND;
      connection_desc_ptr^.open_local_file_count := connection_desc_ptr^.open_local_file_count + 1;

      IF connection_desc_ptr^.output_buffer_entry_loc = NIL THEN
        ALLOCATE connection_desc_ptr^.output_buffer_entry_loc: [[REP 10000 OF cell]]
              in osv$job_pageable_heap^;
        RESET connection_desc_ptr^.output_buffer_entry_loc;
        connection_desc_ptr^.output_buffer_exit_loc := connection_desc_ptr^.output_buffer_entry_loc;
      IFEND;

    { Use session file name to point to the terminal connection table in the open file descriptor.

      open_file_desc_pointer^.session_layer_file_name := terminal_file_name;
      open_file_desc_pointer^.vtp_connection_id := connection_desc_ptr^.vtp_connection_id;
      iip$vt_open (terminal_file_name, open_file_desc_pointer^.vtp_file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF iiv$int_task_open_file_count = 0 THEN

      { Increment interactive task count.

        iip$set_lock (iiv$interactive_task_count_lock, osc$wait, local_status);
        IF iiv$interactive_task_count >= 100000 THEN
          iip$clear_lock (iiv$interactive_task_count_lock, local_status);
          clp$convert_integer_to_string (100000, 10, FALSE,
                max_task_count_string, local_status);
          amp$set_file_instance_abnormal (file_id, ame$terminal_task_limit,
                amc$open_req, max_task_count_string.value, status);
          EXIT /open_file/;
        IFEND;
        iiv$interactive_task_count := iiv$interactive_task_count + 1;
        iip$clear_lock (iiv$interactive_task_count_lock, local_status);

      { Initialize the task break level to equal the current job break level.
      { This is a kludge which should be replaced by using task inherited
      { (from the parent) data if/when it is implemented.

        IF NOT iiv$tbl_initialized THEN
          {iiv$task_break_level := iiv$job_break_level;
          iiv$tbl_initialized := TRUE;
        IFEND;
      IFEND;  { IF iiv$int_task_open_file_count = 0 }

    { Initialize connection attributes in the open file descriptor.

      iip$st_init_open_desc_atributes (validated_name, open_file_desc_pointer, status);
      IF NOT status.normal THEN
        EXIT /open_file/;
      IFEND;
      open_file_desc_pointer^.terminal_mode := iic$line;
      fetch_file_contents_array [1].key := amc$file_contents;
      call_block.operation :=  amc$fetch_req;
      call_block.fetch.file_attributes := ^fetch_file_contents_array;
      amp$access_method (file_id,call_block,layer_number,status);
      open_file_desc_pointer^.format_effectors := (fetch_file_contents_array [1].file_contents = amc$list);

    { Increment task open interactive file count.

      iiv$int_task_open_file_count := iiv$int_task_open_file_count + 1;

      IF iiv$downline_data_block_ptr = NIL THEN

      { Allocate space to buffer task output from put partials.

        ALLOCATE iiv$downline_data_block_ptr IN osv$task_private_heap^;
      IFEND;

    END /open_file/;

  PROCEND iip$st_open;

MODEND iim$st_open;
*DECK DECK=IIM$ST_PUT EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$st_put;
?? NEWTITLE := 'MODULE iim$st_put' ??

?? PUSH (LISTEXT := ON) ??
*copyc AMD$OPERATION_DECLARATIONS
*copyc AME$PUT_VALIDATION_ERRORS
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$TERM_OPTION
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc ifc$interrupt_timesharing_io
*copyc ife$error_codes
*copyc IIK$KEYPOINTS
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIT$INTERACTIVE_SIGNAL_TYPE
*copyc IIV$CONNECTION_DESC_PTR
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIV$INT_TASK_OPEN_FILE_COUNT
*copyc IIV$OUTPUT
*copyc NAT$DATA_FRAGMENTS
*copyc OST$ACTIVITY_STATUS
*copyc OST$STATUS
*copyc pmp$log
?? POP ??

*copyc amp$put_next
*copyc AMP$SET_FILE_INSTANCE_ABNORMAL
*copyc IIP$CLEAR_LOCK
*copyc IIP$REPORT_STATUS_ERROR
*copyc iip$search_connection_desc
*copyc IIP$SET_LOCK
*copyc IIP$ST_FLUSH
*copyc iip$xt_redirect_xterm_output
*copyc I#COMPARE
*copyc I#MOVE
*copyc iiv$io_requests_in_job
*copyc iiv$io_requests_in_task
*copyc iiv$xt_xterm_control_block
*copyc osp$decrement_locked_variable
*copyc OSP$ESTABLISH_CONDITION_HANDLER
*copyc osp$set_status_abnormal
*copyc OSP$SET_STATUS_FROM_CONDITION
*copyc osp$system_error
*copyc OSP$TEST_SIG_LOCK
*copyc osv$task_private_heap
*copyc PMP$CONTINUE_TO_CAUSE
*copyc pmp$get_executing_task_gtid
*copyc PMP$LOG
*copyc PMP$TASK_DEBUG_MODE_ON

?? NEWTITLE := 'PROCEDURE iip$st_put', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$st_put (file_id: amt$file_identifier;
        open_file_desc_pointer: ^iit$st_open_file_description;
        operation: amt$fap_operation;
        working_storage_area: ^cell;
        working_storage_length: amt$working_storage_length;
        byte_address: ^amt$file_byte_address;
        term_option: amt$term_option;
    VAR status: ost$status);

    VAR
      decrement_error: boolean,
      exit_in_progress: boolean,
      add_space: boolean,
      allocate_length: integer,
      connection_desc_ptr: ^iit$connection_description,
      current_transfer_count: amt$transfer_count,
      data_length: 0 .. osc$max_segment_length,
      direct_move: boolean,
      downline_queue_entry_ptr: ^iit$st_downline_queue_entry,
      global_task_id: ost$global_task_id,
      io_requests_in_job: integer,
      local_status: ost$status,
      ls: ost$signature_lock_status,
      move_length: integer,
      output_sequence_pointer: ^iit$st_output,
      put_byte_address: amt$file_byte_address,
      saved_attributes: iit$connection_attributes,
      save_last_term_option: amt$term_option,
      working_storage_array_pointer: ^array [0 .. iic$max_record_length] of char;

     ?? OLDTITLE ??
     ?? EJECT ??
{  If a call is made to a procedure that will go into wait with the lock
{  set then the lock must be protected with a block exit handler.


  /put_data/
    BEGIN
      exit_in_progress := FALSE;
      #spoil (exit_in_progress);

{ The xterm task cannot do output to the terminal.  The xterm task output
{ is redirected to a mass storage file.  In most cases the xterm task attempts
{ to do output when the communications software cannot accept output.
{ The terminal user may examine the mass storage file to see the xterm output.
{ Usually the xterm task only does output when a failure occurs.

      pmp$get_executing_task_gtid (global_task_id);
      IF (iiv$xt_xterm_control_block.task.exists AND (global_task_id =
            iiv$xt_xterm_control_block.xterm_global_task_id)) THEN
        iip$xt_redirect_xterm_output (working_storage_area, working_storage_length,status);
        RETURN;
      IFEND;

      iip$search_connection_desc (open_file_desc_pointer^.session_layer_file_name, connection_desc_ptr);
        IF connection_desc_ptr = NIL THEN
          osp$set_status_abnormal (ifc$interactive_facility_id, ife$file_is_not_network_file, '', status);
          EXIT /put_data/;
        IFEND;

      osp$test_sig_lock (iiv$downline_queue_lock, ls);
      IF (ls = osc$sls_locked_by_current_task) THEN

      { Some sort of unintended recursion has occured (due to break, escape,
      { task/job termination, etc.  Return with normal status.

        status.normal := TRUE;
        EXIT /put_data/;
      IFEND;
      status.normal := TRUE;

    { Return an error if at EOR and the operation is a put partial continue.

      IF (iiv$put_info.last_term_option = amc$terminate) AND (term_option =
            amc$continue) THEN
        amp$set_file_instance_abnormal (file_id, ame$improper_continue,
              operation, '', status);
        EXIT /put_data/;
      IFEND;

    { Terminate the previous record if at mid-record and the operation
    { is a full put or a put partial start.
    { The reader should be aware that a recursive call to iip$st_put is made here.

      IF (iiv$put_info.last_term_option <> amc$terminate) AND ((operation =
            amc$put_next_req) OR (operation = amc$put_direct_req) OR (term_option
            = amc$start)) THEN
        iip$st_put (file_id, open_file_desc_pointer, amc$put_partial_req, NIL, 0,
              byte_address, amc$terminate, status);
        IF NOT status.normal THEN
          EXIT /put_data/;
        IFEND;
      IFEND;

    { Detect context switching and, if needed, blank the screen.
    { The reader should be aware that a recursive call to iip$st_put is made here.

      IF (iiv$previous_mode = iic$screen) AND
            ((open_file_desc_pointer^.terminal_mode = iic$line) OR (file_id.ordinal <>
            iiv$previous_file_id.ordinal)) THEN
        iiv$previous_mode := iic$line;
        IF NOT iiv$previous_blank_flag THEN
          iiv$previous_blank_flag := TRUE;
          saved_attributes := open_file_desc_pointer^.attributes;
          open_file_desc_pointer^.attributes := iiv$previous_connection_attr;
          iip$st_put (file_id, open_file_desc_pointer, amc$put_next_req,
            #LOC (iiv$screen_clear_string.value), iiv$screen_clear_string.size,
            ^put_byte_address, amc$terminate, status);
          open_file_desc_pointer^.attributes := saved_attributes;
        IFEND;
      IFEND;

      iiv$previous_blank_flag := FALSE;
      IF open_file_desc_pointer^.terminal_mode = iic$line THEN
        iiv$previous_mode := iic$line;
      IFEND;
      iiv$previous_operation := operation;
      iiv$previous_file_id := file_id;

      output_sequence_pointer := NIL;
      direct_move := FALSE;
      current_transfer_count := 0;
      iiv$put_info.transfer_count := working_storage_length;
      add_space := FALSE;

    { Transfer data from the user's working storage area to the iiv$output sequence.

      REPEAT

      { Determine the amount of data to move.

        IF working_storage_length > 0 THEN
          move_length := working_storage_length - current_transfer_count;
          IF (move_length + (iiv$put_info.position_in_block - 1)) >
                iic$max_block_size THEN
            move_length := iic$max_block_size - (iiv$put_info.position_in_block
                  - 1);
          IFEND;

          working_storage_array_pointer := working_storage_area; {handle output data as character array. }
          IF (iiv$put_info.position_in_block <> 1) OR (term_option <>
            amc$terminate) THEN

          { Accumulate put partial data in a task local buffer.

            i#move (#LOC (working_storage_array_pointer^ [current_transfer_count]),
                  #LOC (iiv$downline_data_block_ptr^.data [iiv$put_info.position_in_block]),
                  move_length);
          ELSE
            direct_move := TRUE;  { directly move data from wsa to output sequence.}
          IFEND;

        { Update transfer counts.

          current_transfer_count := current_transfer_count + move_length;
          iiv$put_info.position_in_block := iiv$put_info.position_in_block +
                move_length;
          iiv$put_info.transfer_count := iiv$put_info.transfer_count +
                move_length;

        IFEND;  { working_storage_length > 0 }

      { IF the working_storage_length amount of data is buffered AND this is a termination put,
      {    or the put partial buffer is full,
      {    or the output data is to be moved directly from the wsa to the output sequence,
      { THEN move the data to the output sequence.

        IF ((current_transfer_count = working_storage_length) AND (term_option =
              amc$terminate)) OR (iiv$put_info.position_in_block >
              iic$max_block_size) OR direct_move THEN

        /move_data_to_output_sequence/
          WHILE TRUE DO

            iip$set_lock (iiv$downline_queue_lock, osc$nowait, status);
            IF NOT status.normal THEN
              EXIT /put_data/;
            IFEND;
            data_length := iiv$put_info.position_in_block - 1;
            IF data_length <> 0 THEN
              allocate_length := data_length;
            ELSE
              allocate_length := 1;
            IFEND;
            IF open_file_desc_pointer^.attributes.input_editing_mode.value =
                  ifc$normal_edit THEN

        {  Allow for the ascii unit separator (and a blank if the data is zero-length). }

              IF (data_length > 0) THEN
                allocate_length := allocate_length + 1;  { to account for ascii US added later }
                data_length := data_length + 1;
              ELSEIF (data_length = 0) AND (NOT iiv$put_info.term_char_null) THEN
                allocate_length := allocate_length + 1;  { to account for a space added later }
                data_length := data_length + 2;
                add_space := TRUE;
              IFEND;
            IFEND;

            NEXT output_sequence_pointer: [1 .. allocate_length]
                  IN connection_desc_ptr^.output_buffer_entry_loc;

            IF output_sequence_pointer = NIL then
              iip$clear_lock (iiv$downline_queue_lock, status);
              IF NOT status.normal THEN
                EXIT /put_data/;
              IFEND;

              save_last_term_option := iiv$put_info.last_term_option;
              iiv$put_info.last_term_option := amc$terminate;
              iip$st_flush (file_id, open_file_desc_pointer, status);
              iiv$put_info.last_term_option := save_last_term_option;
              IF NOT status.normal THEN
                EXIT /put_data/;
              IFEND;
              CYCLE /move_data_to_output_sequence/;
            IFEND;
            downline_queue_entry_ptr := ^output_sequence_pointer^.block;
            output_sequence_pointer^.length := allocate_length;

          { Form an iit$downline_queue_entry for the output data.

            downline_queue_entry_ptr^.output_info.fill_0 := 0;
            downline_queue_entry_ptr^.output_info.reserved_1 := 0;
            downline_queue_entry_ptr^.output_info.reserved_2 := 0;

            IF (open_file_desc_pointer^.attributes.input_editing_mode.value =
                  ifc$trans_edit) THEN
              downline_queue_entry_ptr^.output_info.formatting_mode := 0;

            { Determine transparency type:  single or multi-message.

              IF (open_file_desc_pointer^.attributes.trans_character_mode.value =
                    ifc$trans_char_terminate) OR
                   (open_file_desc_pointer^.attributes.trans_length_mode.value =
                   ifc$trans_len_terminate) OR
                   (open_file_desc_pointer^.attributes.trans_timeout_mode.value =
                   ifc$trans_timeout_terminate) THEN
                downline_queue_entry_ptr^.transparent_type := ifc$single_message;
              ELSE
                downline_queue_entry_ptr^.transparent_type := ifc$multi_message;
              IFEND;
            ELSE
              IF open_file_desc_pointer^.format_effectors THEN
                downline_queue_entry_ptr^.output_info.formatting_mode := 1;
              ELSE
                downline_queue_entry_ptr^.output_info.formatting_mode := 2;
              IFEND;
            IFEND;  { Determine formatting mode. }

            IF iiv$put_info.term_char_null AND (data_length > 0) THEN
            { A queue entry w/tcn=true should have zero length, else send_output_message will
            { not send it downline--NV0J139, NV0G816.
              downline_queue_entry_ptr^.term_char_null := FALSE;
            ELSE
              downline_queue_entry_ptr^.term_char_null := iiv$put_info.term_char_null;
            IFEND;

            downline_queue_entry_ptr^.term_char_sent := FALSE;
            downline_queue_entry_ptr^.connection_ptr := connection_desc_ptr;
            downline_queue_entry_ptr^.vtp_connection_id := open_file_desc_pointer^.vtp_connection_id;
            downline_queue_entry_ptr^.attributes := open_file_desc_pointer^.attributes;
            downline_queue_entry_ptr^.output_info.secured.suppress_end_line_positioning := FALSE;
            downline_queue_entry_ptr^.output_info.secured.suppress_echoplexing := FALSE;

            IF (iiv$put_info.build_msg_block)
                  AND (NOT connection_desc_ptr^.solicitation_pending) THEN
              downline_queue_entry_ptr^.output_info.partial := FALSE;
              connection_desc_ptr^.solicitation_pending := TRUE;

            { Cause echoplexing and/or cursor positioning to be suppressed with this output.

              IF iiv$suppress_echoplexing THEN
                downline_queue_entry_ptr^.output_info.secured.suppress_echoplexing := TRUE;
                iiv$suppress_echoplexing := FALSE;
              IFEND;
              IF iiv$suppress_cursor_positioning THEN
                downline_queue_entry_ptr^.output_info.secured.suppress_end_line_positioning := TRUE;
                iiv$suppress_cursor_positioning := FALSE;
              IFEND;
            ELSE
              downline_queue_entry_ptr^.output_info.partial := TRUE;
              IF NOT downline_queue_entry_ptr^.term_char_null THEN
                connection_desc_ptr^.solicitation_pending := FALSE;
              IFEND;
            IFEND;

          { Move the data from either the task downline block or the user's working
          { storage area to the downline_queue_entry.

            IF data_length > 0 THEN
              IF NOT direct_move THEN
                i#move (#LOC (iiv$downline_data_block_ptr^.data [1]), #LOC
                      (downline_queue_entry_ptr^.data [1]), data_length);
              ELSE
                i#move (#LOC (working_storage_array_pointer^ [current_transfer_count-move_length]),
                      #LOC (downline_queue_entry_ptr^.data [1]), data_length);
              IFEND;
            IFEND;

            IF open_file_desc_pointer^.attributes.input_editing_mode.value = ifc$normal_edit THEN

            { Add an ascii unit separator to non-transparent output lines.

              IF data_length > 0 THEN
                downline_queue_entry_ptr^.data [data_length] := iic$ascii_us;
                IF add_space THEN

                { Add a SPACE to avoid problem of double ascii-US characters (NV0G353).

                  downline_queue_entry_ptr^.data [data_length - 1] := ' ';
                  add_space := FALSE;
                IFEND;
              IFEND;
            ELSE { then it must be transparent }
              IF data_length = 0 THEN
                { turn on term_char_null so no output will be sent to network.
                downline_queue_entry_ptr^.term_char_null := TRUE;
              IFEND;
            IFEND;

            connection_desc_ptr^.downline_queue_count := connection_desc_ptr^.downline_queue_count +
                  allocate_length;
            output_sequence_pointer := NIL;
            iip$clear_lock (iiv$downline_queue_lock, local_status);
            EXIT /move_data_to_output_sequence/;

          WHILEND /move_data_to_output_sequence/;

          iiv$put_info.position_in_block := 1;

        IFEND;  { Check to see if there is data to be moved to output sequence. }

      UNTIL current_transfer_count = working_storage_length;

    { Save access information.

      open_file_desc_pointer^.last_get_put_operation := operation;
      open_file_desc_pointer^.last_access_operation := operation;
      open_file_desc_pointer^.previous_record_length := iiv$put_info.transfer_count;

      iiv$put_info.last_term_option := term_option;

      IF term_option = amc$terminate THEN
        iiv$put_info.transfer_count := 0;
      IFEND;

    END /put_data/;

  PROCEND iip$st_put;

MODEND iim$st_put;
*DECK DECK=IIM$ST_SEND_ATTRIBUTES_CHANGE EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$st_send_attributes_change;
?? TITLE := 'MODULE iim$st_send_attributes_change' ??

?? PUSH (LISTEXT := ON) ??
*copyc iik$keypoints
*copyc iip$clear_lock
*copyc iip$set_lock
*copyc iip$connection_to_vt_attributes
*copyc iip$st_update_actual_attributes
*copyc iiv$connection_desc_ptr
*copyc iiv$interactive_terminated
*copyc ost$status
*copyc osv$job_pageable_heap
*copyc pmp$log
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$st_send_attributes_change', EJECT ??

  PROCEDURE [XDCL] iip$st_send_attributes_change (downline_queue_entry: ^iit$st_downline_queue_entry;
        count: integer;
    VAR status: ost$status);

  { Construct a iit$vt_attributes from the different connection attributes in the downline queue
  { and the connection table.  Use this array to call iip$vt_change_attributes.

    VAR
      cdp,
      dqe: ^iit$connection_attributes,
      if_attributes: ^ift$connection_attributes,
      if_attributes_final: ^ift$connection_attributes,
      j: integer,
      k: integer;


  { Build an ift$connection_attributes array from those attribute records in the downline
  { queue entry which are different from those in the connection table.

    cdp := ^downline_queue_entry^.connection_ptr^.actual_connection_attributes;
    dqe := ^downline_queue_entry^.attributes;
    PUSH if_attributes:  [1 .. count];

  { Note - the following comparisons must exactly mimic those in iim$st_send_output_message,
  { otherwise we could have a problem with the array allocated at wrong dimension.

    j := 1;

    IF downline_queue_entry^.term_char_null THEN

      IF dqe^ .input_editing_mode.value <> cdp^ .input_editing_mode.value THEN
        if_attributes^ [j].key := ifc$input_editing_mode;
        if_attributes^ [j].input_editing_mode := dqe^ .input_editing_mode.value;
        j := j + 1;
      IFEND;

      IF dqe^ .trans_character_mode.value <> cdp^ .trans_character_mode.value THEN
        if_attributes^ [j].key := ifc$trans_character_mode;
        if_attributes^ [j].trans_character_mode := dqe^ .trans_character_mode.value;
        j := j + 1;
      IFEND;

      IF (dqe^ .trans_forward_character.value.size <> cdp^ .trans_forward_character.value.size) OR
            (dqe^ .trans_forward_character.value.value (1, dqe^ .trans_forward_character.value.size)
            <> cdp^ .trans_forward_character.value.value (1, cdp^ .trans_forward_character.value.size))
      THEN
        if_attributes^ [j].key := ifc$trans_forward_character;
        if_attributes^ [j].trans_forward_character := dqe^ .trans_forward_character.value;
        j := j + 1;
      IFEND;

      IF dqe^ .trans_length_mode.value <> cdp^ .trans_length_mode.value THEN
        if_attributes^ [j].key := ifc$trans_length_mode;
        if_attributes^ [j].trans_length_mode := dqe^ .trans_length_mode.value;
        j := j + 1;
      IFEND;

      IF dqe^ .trans_timeout_mode.value <> cdp^ .trans_timeout_mode.value THEN
        if_attributes^ [j].key := ifc$trans_timeout_mode;
        if_attributes^ [j].trans_timeout_mode := dqe^ .trans_timeout_mode.value;
        j := j + 1;
      IFEND;

      IF dqe^ .trans_message_length.value <> cdp^ .trans_message_length.value THEN
        if_attributes^ [j].key := ifc$trans_message_length;
        if_attributes^ [j].trans_message_length := dqe^ .trans_message_length.value;
        j := j + 1;
      IFEND;

      IF (dqe^ .trans_terminate_character.value.size <> cdp^ .trans_terminate_character.value.size) OR
            (dqe^ .trans_terminate_character.value.value (1, dqe^ .trans_terminate_character.value.size)
            <> cdp^ .trans_terminate_character.value.value (1, cdp^ .trans_terminate_character.
            value.size)) THEN
        if_attributes^ [j].key := ifc$trans_terminate_character;
        if_attributes^ [j].trans_terminate_character := dqe^ .trans_terminate_character.value;
        j := j + 1;
      IFEND;
    IFEND;  { term_char_null }


    IF dqe^ .attention_character_action.value <> cdp^ .attention_character_action.value THEN
      if_attributes^ [j].key := ifc$attention_character_action;
      if_attributes^ [j].attention_character_action := dqe^ .attention_character_action.value;
      j := j + 1;
    IFEND;

    IF dqe^ .break_key_action.value <> cdp^ .break_key_action.value THEN
      if_attributes^ [j].key := ifc$break_key_action;
      if_attributes^ [j].break_key_action := dqe^ .break_key_action.value;
      j := j + 1;
    IFEND;

    IF dqe^ .input_block_size.value <> cdp^ .input_block_size.value THEN
      if_attributes^ [j].key := ifc$input_block_size;
      if_attributes^ [j].input_block_size := dqe^ .input_block_size.value;
      j := j + 1;
    IFEND;

    IF dqe^ .input_output_mode.value <> cdp^ .input_output_mode.value THEN
      if_attributes^ [j].key := ifc$input_output_mode;
      if_attributes^ [j].input_output_mode := dqe^ .input_output_mode.value;
      j := j + 1;
    IFEND;

    IF dqe^ .partial_char_forwarding.value <> cdp^ .partial_char_forwarding.value THEN
      if_attributes^ [j].key := ifc$partial_char_forwarding;
      if_attributes^ [j].partial_character_forwarding := dqe^ .partial_char_forwarding.value;
      j := j + 1;
    IFEND;

    IF dqe^ .store_backspace_character.value <> cdp^ .store_backspace_character.value THEN
      if_attributes^ [j].key := ifc$store_backspace_character;
      if_attributes^ [j].store_backspace_character := dqe^ .store_backspace_character.value;
      j := j + 1;
    IFEND;

    IF dqe^ .store_nuls_dels.value <> cdp^ .store_nuls_dels.value THEN
      if_attributes^ [j].key := ifc$store_nuls_dels;
      if_attributes^ [j].store_nuls_dels := dqe^ .store_nuls_dels.value;
      j := j + 1;
    IFEND;

  { Convert the ift$connection_attributes array to a iit$vt_attributes array and use it
  { as input on a iip$vt_change_attributes call.
    IF j-1 > 0 THEN
      PUSH if_attributes_final: [1.. j-1];
      FOR k := 1 to  j-1 DO
        if_attributes_final^[k] := if_attributes^[k];
      FOREND;

      iip$connection_to_vt_attributes (downline_queue_entry^.connection_ptr, if_attributes_final^,
             status);
      IF NOT status.normal THEN
{!!   we are required to continue despite error }
        status.normal := TRUE;
      IFEND;

      { Update the actual_attributes in the terminal connection table.
      iip$st_update_actual_attributes (downline_queue_entry^.connection_ptr, if_attributes_final^,
          ifc$undefined_attribute);
    IFEND;

  PROCEND iip$st_send_attributes_change;

MODEND iim$st_send_attributes_change;
*DECK DECK=IIM$ST_SEND_OUTPUT_MESSAGE EXPAND=TRUE
*copyc osd$default_pragmats
MODULE iim$st_send_output_message;

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc bat$task_file_table
*copyc clc$standard_file_names
*copyc ifc$interrupt_timesharing_io
*copyc ife$error_codes
*copyc iik$keypoints
*copyc iit$connection_description
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc tmc$wait_times
?? POP ??
*copyc amp$flush
*copyc clp$get_system_file_id
*copyc clp$get_time_string
*copyc iip$st_put
*copyc iip$clear_job_locks
*copyc iip$st_send_attributes_change
*copyc iip$vt_output
*copyc nap$await_data_available
*copyc nap$se_clear_request
*copyc nap$se_receive_data
*copyc nap$se_synchronize
*copyc osp$clear_job_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osp$set_status_from_condition
*copyc osp$test_sig_lock
*copyc pmp$continue_to_cause
*copyc pmp$get_job_names
*copyc pmp$log
*copyc bav$last_tft_entry
*copyc bav$task_file_table
*copyc iiv$interactive_terminated
*copyc iiv$output
*copyc jmv$terminal_io_disabled

  PROCEDURE [XDCL] iip$st_send_output_message (connection_desc_ptr:
        ^iit$connection_description;
        vtp_file_id: amt$file_identifier;
    VAR status: ost$status);

    VAR
      activity_status: [STATIC, oss$task_shared {namve workaround }] ost$activity_status,
      data: [STATIC] array [1 .. 1] of nat$data_fragment,
      data1: SEQ (REP iic$vt_header_length_input of cell),
      difference_count: integer,
      dqe: ^iit$st_downline_queue_entry,
      file_identifier: amt$file_identifier,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      fm: 0 .. 0ff(16),
      i: integer,
      ignore_status: ost$status,
      index: integer,
      job_is_disconnected: boolean,
      len: integer,
      local_status: ost$status,
      ls: ost$signature_lock_status,
      output_array: ^nat$data_fragments,
      output_info: iit$vt_output_information,
      p_length: ^integer,
      peer_operation: [STATIC, oss$task_shared {NAMVE workaround} ] nat$se_peer_operation,
      po: ^iit$st_output,
      put_byte_address: amt$file_byte_address,
      st_open_file_dsc_pointer: ^iit$st_open_file_description,
      str: ost$string,
      system_supplied_name: jmt$system_supplied_name,
      tcn: boolean,
      tcs: boolean,
      temp_output_array: array [1 .. nac$max_data_fragment_count] OF nat$data_fragment,
      text: [STATIC, READ, oss$job_paged_literal] string(35) :=
            ' TERMINAL TIMEOUT IN 30 SECONDS.' CAT $CHAR(7) CAT
            $CHAR(13) CAT $CHAR(10),
      timeout_data: SEQ (REP 1 of cell),
      timeout_message: string (80),
      tlength: integer,
      user_supplied_name: jmt$user_supplied_name,
      warning_displayed: boolean,
      xpt_type: ift$transparent_types;

?? NEWTITLE := 'PROCEDURE handle_break', EJECT ??

    PROCEDURE handle_break (cond: pmt$condition;
          cd: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR ch_status: ost$status);

      VAR
        iiv$condition_handler_trace: [XREF]  boolean,
        ignore_status: ost$status;

      IF (cond.selector = ifc$interactive_condition) OR (cond.selector = pmc$block_exit_processing) THEN
        osp$test_sig_lock (iiv$downline_queue_lock, ls);
        IF ls = osc$sls_locked_by_current_task THEN

          IF iiv$condition_handler_trace THEN
            pmp$log ('ST_SOM locked by current task',local_status);
          IFEND;
          IF cond.selector = ifc$interactive_condition THEN
            pmp$log ('ST - SOM - Had to clear the lock for interactive condition.', ignore_status);
          ELSE
            pmp$log ('ST - SOM - Had to clear the lock for block exit condition.', ignore_status);
          IFEND;

          RESET connection_desc_ptr^.output_buffer_entry_loc;
          RESET connection_desc_ptr^.output_buffer_exit_loc;
          connection_desc_ptr^.downline_queue_count := 0;
          osp$clear_job_signature_lock (iiv$downline_queue_lock);
        IFEND;

        IF cond.selector = ifc$interactive_condition THEN
          IF iiv$condition_handler_trace THEN
            pmp$log ('ST_SOM interactive condition',local_status);
          IFEND;
          pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
          osp$set_status_from_condition (ifc$interactive_facility_id, cond, sa, status, ignore_status);
          EXIT iip$st_send_output_message;

        ELSE { cond.selector = pmc$block_exit_processing }

          IF (pmc$program_termination IN cond.reason) OR (pmc$program_abort IN cond.reason) THEN
            iip$clear_job_locks (ignore_status)
          IFEND;
          RETURN;
          IF iiv$condition_handler_trace THEN
            pmp$log ('ST_SOM block exit condition',local_status);
          IFEND;
        IFEND;

      ELSE
          IF iiv$condition_handler_trace THEN
            pmp$log ('ST_SOM neither interactive nor block exit',local_status);
          IFEND;
        pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
      IFEND;
    PROCEND handle_break;
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE compare_attributes', EJECT ??

    PROCEDURE compare_attributes (array1: ^iit$connection_attributes;
          array2: ^iit$connection_attributes;
      VAR difference_count: integer);

    { Compare the values of the connection attributes of array1 with those of
    { array2.  Return the number of discrepancies.

      difference_count := 0;
      IF dqe^.term_char_null THEN
        IF array1^.input_editing_mode.value <> array2^.input_editing_mode.value THEN
          difference_count := difference_count + 1;
        IFEND;

        IF array1^.trans_character_mode.value <> array2^.trans_character_mode.value THEN
          difference_count := difference_count + 1;
        IFEND;

        IF (array1^.trans_forward_character.value.size <> array2^.trans_forward_character.value.size) OR
              (array1^.trans_forward_character.value.value (1, array1^.trans_forward_character.value.size)
              <> array2^.trans_forward_character.value.value (1, array2^.trans_forward_character.value.
              size)) THEN
          difference_count := difference_count + 1;
        IFEND;

        IF array1^.trans_length_mode.value <> array2^.trans_length_mode.value THEN
          difference_count := difference_count + 1;
        IFEND;

        IF array1^.trans_message_length.value <> array2^.trans_message_length.value THEN
          difference_count := difference_count + 1;
        IFEND;

        IF (array1^.trans_terminate_character.value.size <> array2^.trans_terminate_character.value.size) OR
              (array1^.trans_terminate_character.value.value (1, array1^.trans_terminate_character.value.
              size) <> array2^.trans_terminate_character.value.value (1, array2^.trans_terminate_character.
              value.size)) THEN
          difference_count := difference_count + 1;
        IFEND;

        IF array1^.trans_timeout_mode.value <> array2^.trans_timeout_mode.value THEN
          difference_count := difference_count + 1;
        IFEND;
      IFEND;

      IF array1^.attention_character_action.value <> array2^.attention_character_action.value THEN
        difference_count := difference_count + 1;
      IFEND;

      IF array1^.break_key_action.value <> array2^.break_key_action.value THEN
        difference_count := difference_count + 1;
      IFEND;

      IF array1^.input_block_size.value <> array2^.input_block_size.value THEN
        difference_count := difference_count + 1;
      IFEND;

      IF array1^.input_output_mode.value <> array2^.input_output_mode.value THEN
        difference_count := difference_count + 1;
      IFEND;

      IF array1^.partial_char_forwarding.value <> array2^.partial_char_forwarding.value THEN
        difference_count := difference_count + 1;
      IFEND;

      IF array1^.store_backspace_character.value <> array2^.store_backspace_character.value THEN
        difference_count := difference_count + 1;
      IFEND;

      IF array1^.store_nuls_dels.value <> array2^.store_nuls_dels.value THEN
        difference_count := difference_count + 1;
      IFEND;


    PROCEND compare_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE timeout_job', EJECT ??

    PROCEDURE timeout_job;

{ Synchronize the connection in both directions. Then input on the connection to
{ clear the synchronize_confirm response.
{
      job_is_disconnected := FALSE;
      nap$se_synchronize (vtp_file_id, nac$se_synchronize_all_data, timeout_data,
              ignore_status);
      data [1].address := ^data1;
      data [1].length := iic$vt_header_length_input;
      nap$se_receive_data (vtp_file_id,
              data, osc$wait, peer_operation, activity_status,
              ignore_status);
{
{ Discard all data in the output buffer and clear the downline queue count.
{ We clear the downline queue lock so that we can call iip$st_put to output
{ the timeout messages.
{
      RESET connection_desc_ptr^.output_buffer_entry_loc;
      RESET connection_desc_ptr^.output_buffer_exit_loc;
      connection_desc_ptr^.downline_queue_count := 0;
      osp$clear_job_signature_lock (iiv$downline_queue_lock);
      IF NOT warning_displayed THEN
        clp$get_system_file_id (clc$job_output, file_identifier, ignore_status);
*copy bai$validate_file_identifier
*copy iii$fetch_st_open_file_desc_ptr
{
{ Output a character to reset the output side of the network.
{
        iip$st_put (file_identifier, st_open_file_dsc_pointer,
                amc$put_next_req, ^text, 1, ^put_byte_address,
                amc$terminate, ignore_status);
{
{ Output the timeout warning message.
{
        iip$st_put (file_identifier, st_open_file_dsc_pointer,
                amc$put_next_req, ^text, STRLENGTH (text), ^put_byte_address,
              amc$terminate, ignore_status);
        warning_displayed := TRUE;
        amp$flush (file_identifier, osc$wait, ignore_status);
{
{ Wait 30 seconds for a response to the warning message.
{
        nap$await_data_available (vtp_file_id, 30000, 30000, status);
        IF status.normal THEN
          osp$set_job_signature_lock (iiv$downline_queue_lock);
          RETURN;
        IFEND;
      IFEND;

{ Display the time and job name in the terminal timeout message.

      clp$get_time_string (str, ignore_status);
      timeout_message (1, 1) := ' ';
      timeout_message (2, str.size) := str.value (1, str.size);
      timeout_message (str.size + 2, 24) := ' TERMINAL TIMEOUT.  JOB ';
      pmp$get_job_names (user_supplied_name, system_supplied_name, ignore_status);
      timeout_message (str.size + 26, 19) := system_supplied_name;
      timeout_message (str.size + 45, 13) := ' DETACHED.' CAT $CHAR (7) CAT
            $CHAR (13) CAT $CHAR (10);
      clp$get_system_file_id (clc$job_output, file_identifier, ignore_status);
*copy bai$validate_file_identifier
*copy iii$fetch_st_open_file_desc_ptr
{
{ Output the terminal timeout message to the terminal.
{
      iip$st_put (file_identifier, st_open_file_dsc_pointer, amc$put_next_req,
             #LOC (timeout_message), str.size + 57, ^put_byte_address,
             amc$terminate, ignore_status);
      amp$flush (file_identifier, osc$wait, ignore_status);
      file_identifier := vtp_file_id;
*copy bai$validate_file_identifier
      nap$se_clear_request(file_instance^.local_file_name, status);
      IF NOT status.normal THEN
        osp$set_job_signature_lock (iiv$downline_queue_lock);
        RETURN;
      IFEND;

      job_is_disconnected := TRUE;
      RETURN;

    PROCEND timeout_job;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, iik$st_send_output_message);

{   interlock the send output message operation (1 per job)

    osp$test_sig_lock (iiv$downline_queue_lock, ls);
    IF ls = osc$sls_locked_by_current_task THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^handle_break, TRUE);
    osp$set_job_signature_lock (iiv$downline_queue_lock);
  /begin_end/
    BEGIN
      IF connection_desc_ptr^.downline_queue_count <> 0 THEN

      /send_output_message/
        REPEAT
          index := 0;

        { repeatedly send downline queue entries, via iip$vt_output, to the network
        { until the downline queue count is 0.

    {     Build address-length pairs for as many like queue
    {     entries as possible.  The following conditions terminate the building of pairs:
    {     - downline queue empty
    {     - temp_output_array contains nac$max_data_fragments_count entries
    {     - change in block modes (transparent, format effectors)
    {     - terminal attributes change

          tlength := 0;
          NEXT p_length IN connection_desc_ptr^.output_buffer_exit_loc;
          IF p_length = NIL THEN
            osp$system_error ('ST_SOM CONFUSION #1 ', NIL);
          IFEND;
          RESET connection_desc_ptr^.output_buffer_exit_loc TO p_length;
          NEXT po: [1 .. p_length^] IN connection_desc_ptr^.output_buffer_exit_loc;
          IF po = NIL THEN
            osp$system_error ('ST_SOM CONFUSION #2 ', NIL);
          IFEND;
          dqe := ^po^.block;
          fm := dqe^.output_info.formatting_mode;
          output_info := dqe^.output_info;
          tcs := dqe^.term_char_sent;
          tcn := dqe^.term_char_null;
          xpt_type := dqe^.transparent_type;

          IF (output_info.secured.suppress_echoplexing) OR
                (output_info.secured.suppress_end_line_positioning) THEN

          { When echoplexing and/or cursor_positioning are to be suppressed for the first queue
          { entry in the output buffer, flush the queue entry alone and cycle /send_output_message/.

            temp_output_array [1].address := #LOC (dqe^.data [1]);
            temp_output_array [1].length := p_length^;

            PUSH output_array: [1 .. 1];
            output_array^ [1] := temp_output_array [1];

          { Update the downline_queue_count, but check for zero since condition handler may have zeroed.

            IF connection_desc_ptr^.downline_queue_count <> 0 THEN
              connection_desc_ptr^.downline_queue_count := connection_desc_ptr^.
                    downline_queue_count - p_length^;
            IFEND;

            IF iiv$terminal_timeout_limit <> tmc$infinite_wait THEN
              iip$vt_output (dqe^.vtp_connection_id, vtp_file_id, output_array^,
                    output_info, osc$nowait, activity_status, status);
              warning_displayed := FALSE;
              IF jmv$terminal_io_disabled THEN
                RESET connection_desc_ptr^.output_buffer_entry_loc;
                RESET connection_desc_ptr^.output_buffer_exit_loc;
                connection_desc_ptr^.downline_queue_count := 0;
                EXIT /begin_end/;
              IFEND;

              IF NOT activity_status.complete THEN { it's time to disconnect.
                activity_status.complete := TRUE;
                timeout_job;
                IF job_is_disconnected THEN
                  osp$disestablish_cond_handler;
                  RETURN;
                IFEND;
              IFEND;

            ELSE
              iip$vt_output (dqe^.vtp_connection_id, vtp_file_id, output_array^,
                    output_info, osc$wait, activity_status, status);
              IF jmv$terminal_io_disabled THEN
                RESET connection_desc_ptr^.output_buffer_entry_loc;
                RESET connection_desc_ptr^.output_buffer_exit_loc;
                connection_desc_ptr^.downline_queue_count := 0;
                EXIT /begin_end/;
              IFEND;
            IFEND;

            IF NOT status.normal THEN
              status.normal := TRUE;
              EXIT /begin_end/;  { do not enable until debugging is done }
            IFEND;

            connection_desc_ptr^.job_output_count :=
              connection_desc_ptr^.job_output_count + p_length^;
            CYCLE /send_output_message/;
          IFEND;

        { Compare the downline queue entry's attributes with those in the
        { terminal connection table.  If different then send an attributes
        { change message to the network.

          IF NOT tcs THEN
            IF dqe^.output_info.formatting_mode = 0 THEN
              IF dqe^.transparent_type =ifc$single_message THEN
                dqe^.connection_ptr^.actual_connection_attributes.input_editing_mode.value := ifc$normal_edit;
              IFEND;
            IFEND;
            compare_attributes (^dqe^.attributes, ^dqe^.connection_ptr^.actual_connection_attributes,
                  difference_count);
            IF difference_count <> 0 THEN
              { send attribute downline, immediately update data structure before considering status }
              iip$st_send_attributes_change (dqe, difference_count, status);
              dqe^.term_char_sent := TRUE;
              IF jmv$terminal_io_disabled THEN
                RESET connection_desc_ptr^.output_buffer_entry_loc;
                RESET connection_desc_ptr^.output_buffer_exit_loc;
                connection_desc_ptr^.downline_queue_count := 0;
                EXIT /begin_end/;
              ELSE
                RESET connection_desc_ptr^.output_buffer_exit_loc TO po;
              IFEND;
              IF NOT status.normal THEN
    {!!!}       EXIT /begin_end/;    { do not enable this until debugging done }
              IFEND;
              CYCLE /send_output_message/;
            IFEND;
          IFEND;

        /build_output_message/
          WHILE TRUE DO
            len := p_length^;
            tcn := dqe^.term_char_null;
            tcs := dqe^.term_char_sent;

          { check if to terminate building the current message

            IF NOT tcs THEN
              compare_attributes (^dqe^.attributes, ^dqe^.connection_ptr^.actual_connection_attributes,
                    difference_count);
            IFEND;
            IF (fm <> dqe^.output_info.formatting_mode)
                  OR (index >= nac$max_data_fragment_count)
                  OR (output_info.partial <> dqe^.output_info.partial)
                  OR (dqe^.output_info.secured.suppress_end_line_positioning)
                  OR (dqe^.output_info.secured.suppress_echoplexing)
                  OR (tlength > iic$max_block_size)
                  OR ((NOT tcs) AND (difference_count <> 0)) THEN
              RESET connection_desc_ptr^.output_buffer_exit_loc TO po;
              EXIT /build_output_message/;
            IFEND;

    {       add an address-length pair to the temp_output_array for this queue entry

            IF (NOT tcn) { OR (len > 0) } THEN      { OR section removed by gkc }
              index := index + 1;
              temp_output_array [index].address := #LOC (dqe^.data [1]);
              temp_output_array [index].length := len;
            IFEND;
            tlength := tlength + p_length^;

    {       attempt to continue if there are any more queue entries left
    {       set dqe to point to the next entry to add to the message

            IF tlength < connection_desc_ptr^.downline_queue_count THEN
              NEXT p_length IN connection_desc_ptr^.output_buffer_exit_loc;
              IF p_length = NIL THEN
                osp$system_error ('ST_SOM CONFUSION #3 ', NIL);
              IFEND;
              RESET connection_desc_ptr^.output_buffer_exit_loc TO p_length;
              NEXT po: [1 .. p_length^] IN connection_desc_ptr^.output_buffer_exit_loc;
              IF po = NIL THEN
                osp$system_error ('ST_SOM CONFUSION #4 ', NIL);
              IFEND;
              dqe := ^po^.block;
            ELSE
              EXIT /build_output_message/;
            IFEND;
          WHILEND /build_output_message/;
        { Re-evaluate downline_queue_count since cond handler may have zeroed.
          IF connection_desc_ptr^.downline_queue_count <> 0 THEN
            connection_desc_ptr^.downline_queue_count := connection_desc_ptr^.downline_queue_count - tlength;
          IFEND;

        { Send a downline block if there are any data fragments in the output array }

          IF (index > 0) THEN
            PUSH output_array: [1 .. index];
            FOR i := 1 TO index DO
              output_array^ [i] := temp_output_array [i];
            FOREND;
          ELSE
            PUSH output_array: [1 .. 1];
            output_array^ [1].address := NIL;
            output_array^ [1].length := 0;
            output_info.formatting_mode := iiv$last_formatting_mode;
          IFEND;

          { Call vtp to output the contents of output_buffer.

          IF (index > 0) OR (NOT output_info.partial) THEN
            iiv$last_formatting_mode := output_info.formatting_mode;
            IF iiv$terminal_timeout_limit <> tmc$infinite_wait THEN
              iip$vt_output (dqe^.vtp_connection_id, vtp_file_id, output_array^,
                    output_info, osc$nowait, activity_status, status);
              warning_displayed := FALSE;
              IF jmv$terminal_io_disabled THEN
                RESET connection_desc_ptr^.output_buffer_entry_loc;
                RESET connection_desc_ptr^.output_buffer_exit_loc;
                connection_desc_ptr^.downline_queue_count := 0;
                EXIT /begin_end/;
              IFEND;

              IF NOT activity_status.complete THEN { it's time to disconnect.
                activity_status.complete := TRUE;
                timeout_job;
                IF job_is_disconnected THEN
                  osp$disestablish_cond_handler;
                  RETURN;
                IFEND;
              IFEND;

            ELSE
              iip$vt_output (dqe^.vtp_connection_id, vtp_file_id, output_array^,
                    output_info, osc$wait, activity_status, status);
              IF jmv$terminal_io_disabled THEN
                RESET connection_desc_ptr^.output_buffer_entry_loc;
                RESET connection_desc_ptr^.output_buffer_exit_loc;
                connection_desc_ptr^.downline_queue_count := 0;
                EXIT /begin_end/;
              IFEND;
            IFEND;

            IF NOT status.normal THEN
{!!!}         status.normal := TRUE;
{!!!          EXIT /begin_end/;  { do not enable until debugging is done }
            IFEND;

            connection_desc_ptr^.job_output_count :=
              connection_desc_ptr^.job_output_count + tlength;
          IFEND;

          index := 0;
          IF connection_desc_ptr^.downline_queue_count <= 0 THEN
            IF (connection_desc_ptr^.downline_queue_count < 0) THEN
              osp$system_error ('ST_SOM CONFUSED #5 ', NIL);
            IFEND;
            RESET connection_desc_ptr^.output_buffer_entry_loc;
            RESET connection_desc_ptr^.output_buffer_exit_loc;
          IFEND;

        UNTIL connection_desc_ptr^.downline_queue_count <= 0;
      IFEND;

    END /begin_end/;
    osp$clear_job_signature_lock (iiv$downline_queue_lock);
    osp$disestablish_cond_handler;

    #KEYPOINT (osk$exit, 0, iik$st_send_output_message);

  PROCEND iip$st_send_output_message;
MODEND iim$st_send_output_message

*DECK DECK=IIM$ST_UPDATE_ACTUAL_ATTRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$st_update_actual_attributes;
?? TITLE := 'MODULE iim$st_update_actual_attributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc iiv$connection_desc_ptr
*copyc pmp$log
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$st_update_actual_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$st_update_actual_attributes (connection_desc_ptr: ^iit$connection_description;
        new_attributes: ift$connection_attributes;
        source: ift$connection_attribute_source);

{  Update the actual_connection_attributes field of the terminal connection table with
{  the new_attributes array.

    VAR
      status: ost$status,
      cdp: ^iit$connection_attributes,
      i: integer;

      cdp := ^connection_desc_ptr^.actual_connection_attributes;
      FOR i := LOWERBOUND (new_attributes) TO UPPERBOUND (new_attributes) DO
        IF ($INTEGER(new_attributes [i].key) >=
          $INTEGER(ifc$attention_character_action))
          AND ($INTEGER(new_attributes [i].key) <=
            $INTEGER(ifc$trans_timeout_mode)) THEN
        CASE new_attributes [i].key OF

        = ifc$attention_character_action =
          cdp^.attention_character_action.value := new_attributes [i].attention_character_action;
          IF source <> ifc$undefined_attribute THEN
            cdp^.attention_character_action.source := source;
          IFEND;

        = ifc$break_key_action =
          cdp^.break_key_action.value := new_attributes [i].break_key_action;
          IF source <> ifc$undefined_attribute THEN
            cdp^.break_key_action.source := source;
          IFEND;

        = ifc$end_of_information =
          cdp^.end_of_information.value := new_attributes [i].end_of_information;
          IF source <> ifc$undefined_attribute THEN
            cdp^.end_of_information.source := source;
          IFEND;

        = ifc$input_block_size =
          cdp^.input_block_size.value := new_attributes [i].input_block_size;
          IF source <> ifc$undefined_attribute THEN
            cdp^.input_block_size.source := source;
          IFEND;

        = ifc$input_editing_mode =
          cdp^.input_editing_mode.value := new_attributes [i].input_editing_mode;
          IF source <> ifc$undefined_attribute THEN
            cdp^.input_editing_mode.source := source;
          IFEND;

        = ifc$input_output_mode =
          cdp^.input_output_mode.value := new_attributes [i].input_output_mode;
          IF source <> ifc$undefined_attribute THEN
            cdp^.input_output_mode.source := source;
          IFEND;

        = ifc$input_timeout =
          cdp^.input_timeout.value := new_attributes [i].input_timeout;
          IF source <> ifc$undefined_attribute THEN
            cdp^.input_timeout.source := source;
          IFEND;

        = ifc$input_timeout_length =
          cdp^.input_timeout_length.value := new_attributes [i].input_timeout_length;
          IF source <> ifc$undefined_attribute THEN
            cdp^.input_timeout_length.source := source;
          IFEND;

        = ifc$input_timeout_purge =
          cdp^.input_timeout_purge.value := new_attributes [i].input_timeout_purge;
          IF source <> ifc$undefined_attribute THEN
            cdp^.input_timeout_purge.source := source;
          IFEND;

        = ifc$partial_char_forwarding =
          cdp^.partial_char_forwarding.value := new_attributes [i].partial_character_forwarding;
          IF source <> ifc$undefined_attribute THEN
            cdp^.partial_char_forwarding.source := source;
          IFEND;

        = ifc$prompt_file =
          cdp^.prompt_file.value := new_attributes [i].prompt_file;
          IF source <> ifc$undefined_attribute THEN
            cdp^.prompt_file.source := source;
          IFEND;

        = ifc$prompt_file_identifier =
          cdp^.prompt_file_identifier.value := new_attributes [i].prompt_file_identifier;
          IF source <> ifc$undefined_attribute THEN
            cdp^.prompt_file_identifier.source := source;
          IFEND;

        = ifc$prompt_string =
          cdp^.prompt_string.value := new_attributes [i].prompt_string;
          IF source <> ifc$undefined_attribute THEN
            cdp^.prompt_string.source := source;
          IFEND;

        = ifc$store_backspace_character =
          cdp^.store_backspace_character.value := new_attributes [i].store_backspace_character;
          IF source <> ifc$undefined_attribute THEN
            cdp^.store_backspace_character.source := source;
          IFEND;

        = ifc$store_nuls_dels =
          cdp^.store_nuls_dels.value := new_attributes [i].store_nuls_dels;
          IF source <> ifc$undefined_attribute THEN
            cdp^.store_nuls_dels.source := source;
          IFEND;

        = ifc$trans_character_mode =
          cdp^.trans_character_mode.value := new_attributes [i].trans_character_mode;
          IF source <> ifc$undefined_attribute THEN
            cdp^.trans_character_mode.source := source;
          IFEND;

        = ifc$trans_forward_character =
          cdp^.trans_forward_character.value := new_attributes [i].trans_forward_character;
          IF source <> ifc$undefined_attribute THEN
            cdp^.trans_forward_character.source := source;
          IFEND;

        = ifc$trans_length_mode =
          cdp^.trans_length_mode.value := new_attributes [i].trans_length_mode;
          IF source <> ifc$undefined_attribute THEN
            cdp^.trans_length_mode.source := source;
          IFEND;

        = ifc$trans_timeout_mode =
          cdp^.trans_timeout_mode.value := new_attributes [i].trans_timeout_mode;
          IF source <> ifc$undefined_attribute THEN
            cdp^.trans_timeout_mode.source := source;
          IFEND;

        = ifc$trans_message_length =
          cdp^.trans_message_length.value := new_attributes [i].trans_message_length;
          IF source <> ifc$undefined_attribute THEN
            cdp^.trans_message_length.source := source;
          IFEND;

        = ifc$trans_terminate_character =
          cdp^.trans_terminate_character.value := new_attributes [i].trans_terminate_character;
          IF source <> ifc$undefined_attribute THEN
            cdp^.trans_terminate_character.source := source;
          IFEND;

        = ifc$trans_protocol_mode =
          cdp^.trans_protocol_mode.value := new_attributes [i].trans_protocol_mode;
          IF source <> ifc$undefined_attribute THEN
            cdp^.trans_protocol_mode.source := source;
          IFEND;

        ELSE
          {}
        CASEND;
        ELSE
          {}
        IFEND;
      FOREND;

  PROCEND iip$st_update_actual_attributes;

MODEND iim$st_update_actual_attributes;
*DECK DECK=IIM$ST_UPDATE_DEFAULT_ATRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$st_update_default_atributes;
?? TITLE := 'MODULE iim$st_update_default_atributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc iiv$connection_desc_ptr
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$st_update_default_atributes', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$st_update_default_atributes (connection_desc_ptr: ^iit$connection_description;
        new_attributes: ift$connection_attributes;
        source: ift$connection_attribute_source);

    VAR
      cdp: ^iit$connection_attributes,
      i: integer;

      cdp := ^connection_desc_ptr^.default_connection_attributes;
      FOR i := LOWERBOUND (new_attributes) TO UPPERBOUND (new_attributes) DO
        CASE new_attributes [i].key OF

        = ifc$attention_character_action =
          cdp^.attention_character_action.value := new_attributes [i].attention_character_action;
          cdp^.attention_character_action.source := source;

        = ifc$break_key_action =
          cdp^.break_key_action.value := new_attributes [i].break_key_action;
          cdp^.break_key_action.source := source;

        = ifc$end_of_information =
          cdp^.end_of_information.value := new_attributes [i].end_of_information;
          cdp^.end_of_information.source := source;

        = ifc$input_block_size =
          cdp^.input_block_size.value := new_attributes [i].input_block_size;
          cdp^.input_block_size.source := source;

        = ifc$input_editing_mode =
          cdp^.input_editing_mode.value := new_attributes [i].input_editing_mode;
          cdp^.input_editing_mode.source := source;

        = ifc$input_output_mode =
          cdp^.input_output_mode.value := new_attributes [i].input_output_mode;
          cdp^.input_output_mode.source := source;

        = ifc$input_timeout =
          cdp^.input_timeout.value := new_attributes [i].input_timeout;
          cdp^.input_timeout.source := source;

        = ifc$input_timeout_length =
          cdp^.input_timeout_length.value := new_attributes [i].input_timeout_length;
          cdp^.input_timeout_length.source := source;

        = ifc$input_timeout_purge =
          cdp^.input_timeout_purge.value := new_attributes [i].input_timeout_purge;
          cdp^.input_timeout_purge.source := source;

        = ifc$partial_char_forwarding =
          cdp^.partial_char_forwarding.value := new_attributes [i].partial_character_forwarding;
          cdp^.partial_char_forwarding.source := source;

        = ifc$prompt_file =
          cdp^.prompt_file.value := new_attributes [i].prompt_file;
          cdp^.prompt_file.source := source;

        = ifc$prompt_file_identifier =
          cdp^.prompt_file_identifier.value := new_attributes [i].prompt_file_identifier;
          cdp^.prompt_file_identifier.source := source;

        = ifc$prompt_string =
          cdp^.prompt_string.value := new_attributes [i].prompt_string;
          cdp^.prompt_string.source := source;

        = ifc$store_backspace_character =
          cdp^.store_backspace_character.value := new_attributes [i].store_backspace_character;
          cdp^.store_backspace_character.source := source;

        = ifc$store_nuls_dels =
          cdp^.store_nuls_dels.value := new_attributes [i].store_nuls_dels;
          cdp^.store_nuls_dels.source := source;

        = ifc$trans_character_mode =
          cdp^.trans_character_mode.value := new_attributes [i].trans_character_mode;
          cdp^.trans_character_mode.source := source;

        = ifc$trans_forward_character =
          cdp^.trans_forward_character.value := new_attributes [i].trans_forward_character;
          cdp^.trans_forward_character.source := source;

        = ifc$trans_length_mode =
          cdp^.trans_length_mode.value := new_attributes [i].trans_length_mode;
          cdp^.trans_length_mode.source := source;

        = ifc$trans_timeout_mode =
          cdp^.trans_timeout_mode.value := new_attributes [i].trans_timeout_mode;
          cdp^.trans_timeout_mode.source := source;

        = ifc$trans_message_length =
          cdp^.trans_message_length.value := new_attributes [i].trans_message_length;
          cdp^.trans_message_length.source := source;

        = ifc$trans_terminate_character =
          cdp^.trans_terminate_character.value := new_attributes [i].trans_terminate_character;
          cdp^.trans_terminate_character.source := source;

        = ifc$trans_protocol_mode =
          cdp^.trans_protocol_mode.value := new_attributes [i].trans_protocol_mode;
          cdp^.trans_protocol_mode.source := source;

        ELSE
          {}
        CASEND;
      FOREND;

  PROCEND iip$st_update_default_atributes;
MODEND iim$st_update_default_atributes;
*DECK DECK=IIM$SUPPRESS_CURSOR_POS_ECHOPLX EXPAND=TRUE
*copyc osd$default_pragmats
?? TITLE := 'IIM$SUPPRESS_CURSOR_POS_ECHOPLX:  toggle cursor positioning and/or echoplexing for next input' ??
MODULE iim$suppress_cursor_pos_echoplx;

{  PURPOSE:
{    This is the 223 agent used by IFP$SUPPRESS_CURSOR_POS_ECHOPLX
{    to write the job-pageable variables
{    IIV$SUPPRESS_CURSOR_POSITIONING and IIV$SUPPRESS_ECHOPLEXING,
{    since it cannot write it directly.

{  DESIGN:
{    Set the 233 (job pageable) variables
{    IIV$SUPPRESS_CURSOR_POSITIONING and IIV$SUPPRESS_ECHOPLEXING
{    according to the values of the passed parameters.  IIM$ST_PUT
{    reacts to the setting of these variables by setting the
{    suppress_end_line_positioning and suppress_echoplexing bits
{    in the header of the next non-partial output data message.

?? PUSH (LISTEXT := ON) ??
*copyc iiv$interactive_terminated
?? POP ??

  PROCEDURE [XDCL,#GATE] iip$suppress_cursor_pos_echoplx (
    suppress_cursor_positioning: boolean;
    suppress_echoplexing: boolean);

    iiv$suppress_cursor_positioning := suppress_cursor_positioning;
    iiv$suppress_echoplexing := suppress_echoplexing;

  PROCEND iip$suppress_cursor_pos_echoplx;
MODEND iim$suppress_cursor_pos_echoplx;
*DECK DECK=IIM$TASK_PRIVATE_DATA EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$task_private_data;
?? NEWTITLE := 'NOS/VE Interactive Facility Task Private Data' ??

{  PURPOSE:
{    The purpose of this module is to define (XDCL) the task private data that
{    is used by the interactive user tasks.
{

?? TITLE := 'Global External Type Declarations', EJECT ??

{ Turn off the listing of ifdmach, ifdnam and mldextt.

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
?? POP ??

  VAR

    iiv$put_in_progress: [XDCL] boolean := FALSE,
    iiv$fid: [XDCL] amt$file_identifier,
    iiv$clp_pso_open: [XDCL] boolean := FALSE;

MODEND iim$task_private_data;
*DECK DECK=IIM$TASK_PRIVATE_VARIABLES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$task_private_variables;
?? TITLE := 'MODULE iim$task_private_variables' ??

?? PUSH (LISTEXT := OFF) ??
*copyc nat$data_fragments
*copyc IIT$CONNECTION_DESCRIPTION
*copyc iit$xt_xterm_message_control
*copyc iit$xt_xterm_task_output
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??

  VAR
    iiv$int_task_open_file_count: [XDCL] integer := 0,
    iiv$task_condition_in_progress: [XDCL] boolean := FALSE,
    iiv$task_ignore_condition: [XDCL] boolean := FALSE,
    iiv$int_application_name: [XDCL] mlt$application_name := mlc$unique_name,
    iiv$put_info: [XDCL] iit$task_put_info := [1, 0, amc$terminate, FALSE,
      FALSE, FALSE, 0],
    iiv$downline_data_block_ptr: [XDCL] ^iit$output_data_message := NIL,
    iiv$xt_xterm_downline: [XDCL, #GATE] iit$xt_xterm_message_control :=
    [*,FALSE,*],
    iiv$xt_xterm_task_output: [XDCL, #GATE] iit$xt_xterm_task_output := [{text_p} NIL,{position} 0],
    iiv$xt_xterm_upline: [XDCL, #GATE] iit$xt_xterm_message_control :=
          [{file_identifier} *, {opened} FALSE,{segment_pointer} *];

MODEND iim$task_private_variables;
*DECK DECK=IIM$TASK_SHARED_VARIABLES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$task_shared_variables;
?? TITLE := 'MODULE iim$task_shared_variables' ??

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc iit$xt_xterm_control_block
*copyc iit$xt_xterm_message_control
*copyc nat$data_fragments
*copyc OST$GLOBAL_TASK_ID
*copyc ost$signature_lock
?? POP ??

  VAR
    iiv$job_monitor_task_id: [XDCL, #GATE] ost$global_task_id,
    iiv$job_suspended: [XDCL] boolean := FALSE,
    iiv$break_reason: [XDCL, #GATE] iit$break_reason := 0,
    iiv$terminal_request_ptr: [XDCL] ^iit$connection_attributes := NIL,
    iiv$xt_xterm_control_block: [XDCL, #GATE] iit$xt_xterm_control_block :=
          ['' {downline_file_reference},
           * {downline_lock},
           iic$xt_inactive {downline_state},
           FALSE {network_file_opened},
           * {network_file_identifier},
           [FALSE, *] {status},
           [FALSE {task.defined},* {task_id}],
           $iit$xt_trace_set [] {trace_set},
           '' {upline_file_reference},
           * {upline_global_task_id},
           * {upline_lock},
           iic$xt_inactive {upline_state},
           * {xterm_global_task_id},
           iic$xterm_uninitialized {xterm_state}];

MODEND iim$task_shared_variables;
*DECK DECK=IIM$TERM_CHAR_UTILITIES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS

MODULE iim$term_char_utilities;

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??

?? TITLE := 'PROCEDURE iip$convert_upline_term_char', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$convert_upline_term_char (pib: ^cell;
    pob: ^cell;
    input_block_length: mlt$message_length);

{  PURPOSE:
{    The purpose of this procedure is to convert a C170 Upline Terminal
{    Charactistics Message  received from the NAM to a C180 Upline Terminal
{    Characteristics Message which can be delivered to the caller.
{  DESIGN:
{    The conversion is accomplished by moving 4 bits at a time from the
{    C170 Upline Terminal Characteristics Message to the C180 Upline Terminal
{    Characteristics Message while skipping the upper 4 bits of each word of
{    the C170 Upline Terminal Characteristics Message.
{

    VAR
      limit: integer,
      pins,
      pons: ^iit$nibble_string,
      i,
      j: integer;

    pins := pib;
    pons := pob;

{ Copy the first 22 half bytes asis.  This is header information.

    FOR i := 0 TO 21 DO
      pons^ [i] := pins^ [i];
    FOREND;

{ Convert the rest of the message starting at the 22nd half byte, the first
{ FN/FV pair.

    j := 22;
    i := 21;
    limit := input_block_length;

  /move_half_bytes/
    WHILE limit <> 0 DO
      IF i MOD 16 = 0 THEN
        i := i + 1;
        CYCLE /move_half_bytes/;
      IFEND;
      pons^ [j] := pins^ [i];
      j := j + 1;
      i := i + 1;
      limit := limit - 1;
    WHILEND /move_half_bytes/;

  PROCEND iip$convert_upline_term_char;

?? TITLE := 'PROCEDURE iip$convert_downline_term_char', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$convert_downline_term_char (pib: ^cell;
    pob: ^cell;
    input_block_length: mlt$message_length;
    VAR output_block_length: mlt$message_length);

{  PURPOSE:
{    The purpose of this procedure is to convert a C180 Downline Terminal
{    Characteristics Message to a C170 Downline Characteristics Message which
{    can be sent to the NAM.
{  DESIGN:
{    The conversion is accomplished by moving 4 bits at a time from the
{    C180 Downline Terminal Characteristics Message to the C170 Downline
{Terminal
{    Characteristics Message while inserting the upper 4 bits of each C170
{    word.
{

    VAR
      pins,
      pons: ^iit$nibble_string,
      i,
      j: integer;

    pins := pib;
    pons := pob;

{ Copy the first two words without conversion.

    FOR i := 0 TO 31 DO
      pons^ [i] := pins^ [i];
    FOREND;

{ Convert the rest of the message starting at the first terminal
{ characteristics pair which starts at the 4th byte of the second
{ word.

    j := 21;

    FOR i := 22 TO 2 * input_block_length DO
      IF j MOD 16 = 0 THEN
        pons^ [j] := 0;
        j := j + 1;
      IFEND;
      pons^ [j] := pins^ [i];
      j := j + 1;
    FOREND;

    output_block_length := (j + 1) DIV 2;

  PROCEND iip$convert_downline_term_char;

MODEND iim$term_char_utilities;
*DECK DECK=IIM$UPDATE_OPEN_DESC_ATTRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE iim$update_open_desc_attributes;
?? TITLE := 'MODULE iim$update_open_desc_attributes' ??

?? PUSH (LISTEXT := ON) ??
*copyc FMP$GET_TERMINAL_ATTRIBUTES
*copyc IFE$ERROR_CODES
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIP$BUILD_TERM_CHAR_VALUES
*copyc IIV$INTERACTIVE_TERMINATED
*copyc OST$STATUS
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc OSP$SET_STATUS_ABNORMAL
?? POP ??

?? NEWTITLE := 'PROCEDURE iip$update_open_desc_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$update_open_desc_attributes (file_id:
    amt$file_identifier;
        open_file_desc_pointer: ^iit$open_file_description;
        operation: amt$fap_operation;
    VAR status: ost$status);


    VAR
      get_all_attributes: array [1 .. (ORD (ifc$max_connection_key) + 1)] OF
            ift$get_connection_attribute,
      replace_all_attributes: iit$connection_attributes,
      open_file_terminal_attributes: iit$connection_attributes,
      operation_text: string (osc$max_name_size),
      i: ift$connection_attribute_keys,
      j: integer,
      local_status: ost$status;

    status.normal := TRUE;

    open_file_terminal_attributes := open_file_desc_pointer^.attributes;

    get_all_attributes := iiv$all_get_term_attributes;

  { Get the attributes set by REQT, CHATCA, CHATCD, their corresponding program
  { interfaces, or IFP$STORE_TERM_CONN_ATTRIBUTES.  These attributes are obtained
  { from BAM's LNT entry for the file.

    fmp$get_terminal_attributes (open_file_desc_pointer^.file_name,
      get_all_attributes, local_status);

  { Replace the attributes in the open_file_terminal_attributes array.

    FOR j := LOWERBOUND (get_all_attributes) TO UPPERBOUND (get_all_attributes) DO
      IF get_all_attributes [j].source <> ifc$undefined_attribute THEN
        CASE get_all_attributes [j].key OF
        = ifc$attention_character_action =
          open_file_terminal_attributes.attention_character_action.value :=
                get_all_attributes [j].attention_character_action;
        = ifc$break_key_action =
          open_file_terminal_attributes.break_key_action.value :=
                get_all_attributes [j].break_key_action;
        = ifc$end_of_information =
          open_file_terminal_attributes.end_of_information.value :=
                get_all_attributes [j].end_of_information;
        = ifc$input_block_size =
          open_file_terminal_attributes.input_block_size.value :=
                get_all_attributes [j].input_block_size;
        = ifc$input_editing_mode =
          open_file_terminal_attributes.input_editing_mode.value :=
                get_all_attributes [j].input_editing_mode;
        = ifc$input_output_mode =
          open_file_terminal_attributes.input_output_mode.value :=
                get_all_attributes [j].input_output_mode;
        = ifc$input_timeout =
          open_file_terminal_attributes.input_timeout.value :=
                get_all_attributes [j].input_timeout;
        = ifc$input_timeout_length =
          open_file_terminal_attributes.input_timeout_length.value :=
                get_all_attributes [j].input_timeout_length;
        = ifc$input_timeout_purge =
          open_file_terminal_attributes.input_timeout_purge.value :=
                get_all_attributes [j].input_timeout_purge;
        = ifc$partial_char_forwarding =
          open_file_terminal_attributes.partial_char_forwarding.value :=
                get_all_attributes [j].partial_character_forwarding;
        = ifc$prompt_file =
          open_file_terminal_attributes.prompt_file.value :=
                get_all_attributes [j].prompt_file;
        = ifc$prompt_file_identifier =
          open_file_terminal_attributes.prompt_file_identifier.value :=
                get_all_attributes [j].prompt_file_identifier;
        = ifc$prompt_string =
          open_file_terminal_attributes.prompt_string.value :=
                get_all_attributes [j].prompt_string;
        = ifc$store_backspace_character =
          open_file_terminal_attributes.store_backspace_character.value :=
                get_all_attributes [j].store_backspace_character;
        = ifc$store_nuls_dels =
          open_file_terminal_attributes.store_nuls_dels.value :=
                get_all_attributes [j].store_nuls_dels;
        = ifc$trans_character_mode =
          open_file_terminal_attributes.trans_character_mode.value :=
                get_all_attributes [j].trans_character_mode;
        = ifc$trans_forward_character =
          open_file_terminal_attributes.trans_forward_character.value :=
                get_all_attributes [j].trans_forward_character;
        = ifc$trans_length_mode =
          open_file_terminal_attributes.trans_length_mode.value :=
                get_all_attributes [j].trans_length_mode;
        = ifc$trans_timeout_mode =
          open_file_terminal_attributes.trans_timeout_mode.value :=
                get_all_attributes [j].trans_timeout_mode;
        = ifc$trans_message_length =
          open_file_terminal_attributes.trans_message_length.value :=
                get_all_attributes [j].trans_message_length;
        = ifc$trans_terminate_character =
          open_file_terminal_attributes.trans_terminate_character.value :=
                get_all_attributes [j].trans_terminate_character;
        ELSE
        CASEND;
      IFEND;
    FOREND;

{ Set the terminal attributes in the open file descriptor.

    open_file_desc_pointer^.attributes := open_file_terminal_attributes;

{ Update the characteristics values and attributes cycle in the open file
{ descriptor.

    iip$build_term_char_values (open_file_desc_pointer);

    open_file_desc_pointer^.attributes_cycle := open_file_desc_pointer^.
      connection_desc_pointer^.attributes_cycle;

  PROCEND iip$update_open_desc_attributes;
MODEND iim$update_open_desc_attributes;
*DECK DECK=IIM$VTP_INTERFACE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE VIRTUAL TERMINAL PROTOCOL INTERFACE' ??

MODULE iim$vtp_interface;
{ PURPOSE: }
{   This VIRTUAL TERMINAL PROTOCOL (VTP) interface provides externally declared procedures }
{   which are used to access CDCNET. }
{ DESIGN:  }
{   The VTP interface procedures make calls to NAMVE to send and receive on CDCNET. }
{   Input received from NAMVE/CDCNET is queued until specifically requested by the procedure }
{   which is using the VTP interface. }

?? PUSH (LISTEXT := ON) ??
*copyc i#move
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc clp$get_time_string
*copyc pmp$get_job_names
*copyc bat$task_file_table
*copyc bav$last_tft_entry
*copyc bav$task_file_table
*copyc clp$get_system_file_id
*copyc clc$standard_file_names
*copyc ife$error_codes
*copyc jmt$timesharing_signal
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nat$data_fragments
*copyc oss$task_shared
*copyc osp$i_await_activity
*copyc ost$activity_status
*copyc ost$status
*copyc ost$wait
*copyc pmp$wait
*copyc amp$flush
*copyc iik$vt_keypoints
*copyc iip$st_put
*copyc iit$vt_attributes
*copyc iit$vt_attribute_descriptions
*copyc iit$vt_attribute_kinds
*copyc iit$vt_change_error_codes
*copyc iit$vt_connections
*copyc iit$vt_input_information
*copyc iit$vt_message_types
*copyc iit$vt_octet_header
*copyc iit$vt_output_information
*copyc iit$vt_timeout
*copyc iiv$interactive_terminated
*copyc iiv$xt_xterm_downline
*copyc iiv$xt_xterm_upline
*copyc oss$job_pageable
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc syv$job_initialization_complete
?? POP ??

*copyc amp$open
*copyc amp$close
*copyc ifp$st_fap_control
*copyc iip$vt_validate_file_identifier
*copyc iip$xt_check_upline
*copyc iip$xt_open_downline_messages
*copyc iip$xt_open_upline_messages
*copyc iiv$interactive_terminated
*copyc i#move
*copyc i#ptr
*copyc jmp$detach_timesharing_job
*copyc jmp$is_xterm_job
*copyc nap$check_data_available
*copyc nap$await_data_available
*copyc nap$se_clear_request
*copyc nap$se_receive_data
*copyc nap$se_send_data
*copyc nap$se_synchronize
*copyc nap$se_synchronize_confirm
*copyc osp$append_status_integer
*copyc osp$set_status_abnormal
*copyc osp$format_message
*copyc osv$job_pageable_heap
*copyc osv$task_shared_heap
*copyc pmp$log_ascii
*copyc pmp$log


?? NEWTITLE := 'STATIC VARIABLES', EJECT ??

  VAR
    char_length: [STATIC, oss$job_pageable] integer,
    connections_head: [STATIC, oss$job_pageable] ^iit$vt_connection := NIL,
    connections_tail: [STATIC, oss$job_pageable] ^iit$vt_connection := NIL,
    file_id_is_valid: [STATIC, oss$job_pageable] boolean,
    ordinal_char: [STATIC, oss$job_pageable] string (10),
    queue_type_from_message: [STATIC, READ, oss$job_paged_literal] iit$vt_queue_type_from_message :=
        [iic$vt_output, iic$vt_input, iic$vt_change, iic$vt_change, iic$vt_change, iic$vt_indications,
        iic$vt_status, iic$vt_status, iic$vt_status, iic$vt_start_stop_comm, iic$vt_start_stop_comm_resp,
        iic$vt_start_stop_comm, iic$vt_start_stop_comm_resp, iic$vt_change, iic$vt_version, iic$vt_create,
        iic$vt_create_status, iic$vt_create_status, iic$vt_delete, iic$vt_status, iic$vt_status,
        iic$vt_status, iic$vt_create, iic$vt_create_status, iic$vt_create_status];

?? TITLE := '[XDCL] iip$vt_create_attribute_octets', EJECT ??

  PROCEDURE [XDCL] iip$vt_create_attribute_octets
    (    attributes: iit$vt_attributes;
     VAR buffer: ^SEQ ( * );
     VAR data_length: nat$data_length);

{ Purpose:  Create octets from an iit$vt_attributes array.

{ Design:   Each element in the iit$vt_attributes array is an AN/AV
{           (attribute-number/attribute-value) group.  This procedure
{           creates one or more 8-bit bytes (called octets) from each
{           AN/AV group, stores these octets in an adaptable sequence
{           and returns a pointer to this sequence as well as the
{           total byte size of all the octets it created.

    CONST
      vtc_multiple_octet_number = 128,
      vtc_multiple_octet_number_dflt = 2,
      vtc_single_octet = FALSE,
      vtc_multiple_octet = TRUE,
      vtc_octet_header_fill = 0,
      vtc_site_defined_code_set_dflt = 3;

    CONST
      iic$vt_max_octet_size = 143;

    TYPE
      vtt_input_output_mode_oct = record
        header: iit$vt_octet_header,
        attribute: ift$input_output_mode,
      recend,
      vtt_input_editing_mode_oct = record
        header: iit$vt_octet_header,
        attribute: ift$input_editing_mode,
      recend,
      vtt_transp_char_mode_oct = record
        header: iit$vt_octet_header,
        attribute: ift$trans_character_mode,
      recend,
      vtt_transp_for_char_single_oct = record
        header: iit$vt_octet_header,
        attribute: string (1),
      recend,
      vtt_transp_for_char_mult_oct = record
        header: iit$vt_octet_header,
        octet_number: 1 .. 4,
      recend,
      vtt_transp_term_char_sing_oct = record
        header: iit$vt_octet_header,
        attribute: string (1),
      recend,
      vtt_transp_term_char_mult_oct = record
        header: iit$vt_octet_header,
        octet_number: 1 .. 4,
      recend,
      vtt_transp_timeout_mode_oct = record
        header: iit$vt_octet_header,
        attribute: ift$trans_timeout_mode,
      recend,
      vtt_transp_len_mode_oct = record
        header: iit$vt_octet_header,
        attribute: ift$trans_length_mode,
      recend,
      vtt_transp_mess_len_sing_oct = record
        header: iit$vt_octet_header,
        attribute: 0 .. 255,
      recend,
      vtt_transp_mess_len_mult_oct = record
        header: iit$vt_octet_header,
        octet_number: 2 .. 2,
        attribute: 0 .. 32767,
      recend,
      vtt_partial_char_forward_oct = record
        header: iit$vt_octet_header,
        attribute: boolean,
      recend,
      vtt_atten_char_act_oct = record
        header: iit$vt_octet_header,
        attribute: ift$attention_character_action,
      recend,
      vtt_break_key_action_oct = record
        header: iit$vt_octet_header,
        attribute: ift$break_key_action,
      recend,
      vtt_input_block_size_sing_oct = record
        header: iit$vt_octet_header,
        attribute: 20 .. 255,
      recend,
      vtt_input_block_size_mult_oct = record
        header: iit$vt_octet_header,
        octet_number: 2 .. 2,
        attribute: ift$input_block_size,
      recend,
      vtt_store_nul_del_oct = record
        header: iit$vt_octet_header,
        attribute: boolean,
      recend,
      vtt_store_back_char_oct = record
        header: iit$vt_octet_header,
        attribute: boolean,
      recend,
      vtt_network_ctl_char_oct = record
        header: iit$vt_octet_header,
        attribute: char,
      recend,
      vtt_cancel_line_char_oct = record
        header: iit$vt_octet_header,
        attribute: char,
      recend,
      vtt_end_line_char_oct = record
        header: iit$vt_octet_header,
        attribute: char,
      recend,
      vtt_begin_line_char_oct = record
        header: iit$vt_octet_header,
        attribute: char,
      recend,
      vtt_backspace_char_oct = record
        header: iit$vt_octet_header,
        attribute: char,
      recend,
      vtt_end_partial_char_oct = record
        header: iit$vt_octet_header,
        attribute: char,
      recend,
      vtt_attention_char_oct = record
        header: iit$vt_octet_header,
        attribute: char,
      recend,
      vtt_page_length_oct = record
        header: iit$vt_octet_header,
        attribute: ift$page_length,
      recend,
      vtt_page_width_oct = record
        header: iit$vt_octet_header,
        attribute: ift$page_width,
      recend,
      vtt_hold_page_oct = record
        header: iit$vt_octet_header,
        attribute: boolean,
      recend,
      vtt_hold_page_over_oct = record
        header: iit$vt_octet_header,
        attribute: boolean,
      recend,
      vtt_fold_line_oct = record
        header: iit$vt_octet_header,
        attribute: boolean,
      recend,
      vtt_end_out_seq_sing_oct = record
        header: iit$vt_octet_header,
        attribute: string (1),
      recend,
      vtt_end_out_seq_mult_oct = record
        header: iit$vt_octet_header,
        octet_number: 0 .. 4,
      recend,
      vtt_carr_ret_seq_sing_oct = record
        header: iit$vt_octet_header,
        attribute: string (1),
      recend,
      vtt_carr_ret_seq_mult_oct = record
        header: iit$vt_octet_header,
        octet_number: 0 .. 2,
      recend,
      vtt_line_feed_seq_sing_oct = record
        header: iit$vt_octet_header,
        attribute: string (1),
      recend,
      vtt_line_feed_seq_mult_oct = record
        header: iit$vt_octet_header,
        octet_number: 0 .. 2,
      recend,
      vtt_form_feed_seq_sing_oct = record
        header: iit$vt_octet_header,
        attribute: string (1),
      recend,
      vtt_form_feed_seq_mult_oct = record
        header: iit$vt_octet_header,
        octet_number: 0 .. 7,
      recend,
      vtt_end_page_action_oct = record
        header: iit$vt_octet_header,
        attribute: ift$end_page_action,
      recend,
      vtt_carr_ret_delay_sing_oct = record
        header: iit$vt_octet_header,
        attribute: 0 .. 255,
      recend,
      vtt_carr_ret_delay_mult_oct = record
        header: iit$vt_octet_header,
        octet_number: 2 .. 2,
        attribute: 0 .. 999,
      recend,
      vtt_line_feed_delay_sing_oct = record
        header: iit$vt_octet_header,
        attribute: 0 .. 255,
      recend,
      vtt_line_feed_delay_mult_oct = record
        header: iit$vt_octet_header,
        octet_number: 2 .. 2,
        attribute: 0 .. 999,
      recend,
      vtt_form_feed_delay_sing_oct = record
        header: iit$vt_octet_header,
        attribute: 0 .. 255,
      recend,
      vtt_form_feed_delay_mult_oct = record
        header: iit$vt_octet_header,
        octet_number: 2 .. 2,
        attribute: 0 .. 3000,
      recend,
      vtt_end_line_position_oct = record
        header: iit$vt_octet_header,
        attribute: ift$end_line_positioning,
      recend,
      vtt_end_partial_position_oct = record
        header: iit$vt_octet_header,
        attribute: ift$end_partial_positioning,
      recend,
      vtt_char_flow_control_oct = record
        header: iit$vt_octet_header,
        attribute: boolean,
      recend,
      vtt_function_key_class_sing_oct = record
        header: iit$vt_octet_header,
        attribute: string (1),
      recend,
      vtt_function_key_class_mult_oct = record
        header: iit$vt_octet_header,
        octet_number: 0 .. ifc$max_function_key_class_size,
      recend,
      vtt_terminal_model_sing_oct = record
        header: iit$vt_octet_header,
        attribute: string (1),
      recend,
      vtt_terminal_model_mult_oct = record
        header: iit$vt_octet_header,
        octet_number: 0 .. ifc$max_terminal_model_size,
      recend,
      vtt_code_set_oct = record
        header: iit$vt_octet_header,
        attribute: ift$code_set,
      recend,
      vtt_code_set_name_oct = record
        header: iit$vt_octet_header,
        octet_number: 0 .. ifc$max_code_set_name_size,
        site_defined_code_set : 3 .. 3,
      recend,
      vtt_parity_type_oct = record
        header: iit$vt_octet_header,
        attribute: ift$parity,
      recend,
      vtt_echoplex_oct = record
        header: iit$vt_octet_header,
        attribute: boolean,
      recend,
      vtt_status_action_oct = record
        header: iit$vt_octet_header,
        attribute: ift$status_action,
      recend,
      vtt_transp_protocol_mode_oct = record
        header: iit$vt_octet_header,
        attribute: ift$trans_protocol_mode,
      recend,
      vtt_control_code_rep_none_oct = record
        header: iit$vt_octet_header,
        octet_number: 0 .. 0,
      recend,
      vtt_control_code_rep_mult_oct = record
        header: iit$vt_octet_header,
        octet_number: 0 .. ifc$total_substitution_count * 2 - 2,
      recend,
      vtt_control_code_rep_ext_oct = record
        header: iit$vt_octet_header,
        octet_length: packed record
          multiple_attribute_length_octet: boolean,
          fill_0: 0..1F(16),
          attribute_length_octet_number: 1 .. 2,
        recend,
        octet_number: 0 .. 0FFFF(16),
      recend;


    VAR
      input_output_mode_oct: [STATIC, READ, oss$job_paged_literal] vtt_input_output_mode_oct :=
            [[vtc_single_octet, iic$vt_input_output_mode], *],
      input_editing_mode_oct: [STATIC, READ, oss$job_paged_literal] vtt_input_editing_mode_oct :=
            [[vtc_single_octet, iic$vt_input_editing_mode], *],
      transp_char_mode_oct: [STATIC, READ, oss$job_paged_literal] vtt_transp_char_mode_oct :=
            [[vtc_single_octet, iic$vt_trans_character_mode], *],
      transp_for_char_single_oct: [STATIC, READ, oss$job_paged_literal] vtt_transp_for_char_single_oct :=
            [[vtc_single_octet, iic$vt_trans_forward_character], *],
      transp_for_char_mult_oct: [STATIC, READ, oss$job_paged_literal] vtt_transp_for_char_mult_oct :=
            [[vtc_multiple_octet, iic$vt_trans_forward_character], vtc_multiple_octet_number_dflt],
      transp_term_char_sing_oct: [STATIC, READ, oss$job_paged_literal] vtt_transp_term_char_sing_oct :=
            [[vtc_single_octet, iic$vt_trans_term_character], *],
      transp_term_char_mult_oct: [STATIC, READ, oss$job_paged_literal] vtt_transp_term_char_mult_oct :=
            [[vtc_multiple_octet, iic$vt_trans_term_character], vtc_multiple_octet_number_dflt],
      transp_protocol_mode_oct: [STATIC, READ, oss$job_paged_literal] vtt_transp_protocol_mode_oct :=
            [[vtc_single_octet, iic$vt_trans_protocol_mode], *],
      transp_timeout_mode_oct: [STATIC, READ, oss$job_paged_literal] vtt_transp_timeout_mode_oct :=
            [[vtc_single_octet, iic$vt_trans_timeout_mode], *],
      transp_len_mode_oct: [STATIC, READ, oss$job_paged_literal] vtt_transp_len_mode_oct :=
            [[vtc_single_octet, iic$vt_trans_length_mode], *],
      transp_mess_len_sing_oct: [STATIC, READ, oss$job_paged_literal] vtt_transp_mess_len_sing_oct :=
            [[vtc_single_octet, iic$vt_trans_message_length], *],
      transp_mess_len_mult_oct: [STATIC, READ, oss$job_paged_literal] vtt_transp_mess_len_mult_oct :=
            [[vtc_multiple_octet, iic$vt_trans_message_length], vtc_multiple_octet_number_dflt, *],
      control_code_rep_none_oct: [STATIC, READ, oss$job_paged_literal] vtt_control_code_rep_none_oct :=
            [[vtc_multiple_octet, iic$vt_control_code_replacement], *],
      control_code_rep_mult_oct: [STATIC, READ, oss$job_paged_literal] vtt_control_code_rep_mult_oct :=
            [[vtc_multiple_octet, iic$vt_control_code_replacement],
              vtc_multiple_octet_number_dflt],
      control_code_rep_ext_oct: [STATIC, READ, oss$job_paged_literal] vtt_control_code_rep_ext_oct :=
            [[vtc_multiple_octet, iic$vt_control_code_replacement],
              [vtc_multiple_octet, 0, vtc_multiple_octet_number_dflt],
              vtc_multiple_octet_number],
      partial_char_forward_oct: [STATIC, READ, oss$job_paged_literal] vtt_partial_char_forward_oct :=
            [[vtc_single_octet, iic$vt_partial_char_forwarding], *],
      atten_char_act_oct: [STATIC, READ, oss$job_paged_literal] vtt_atten_char_act_oct :=
            [[vtc_single_octet, iic$vt_attention_char_action], *],
      break_key_action_oct: [STATIC, READ, oss$job_paged_literal] vtt_break_key_action_oct :=
            [[vtc_single_octet, iic$vt_break_key_action], *],
      input_block_size_sing_oct: [STATIC, READ, oss$job_paged_literal] vtt_input_block_size_sing_oct :=
            [[vtc_single_octet, iic$vt_input_block_size], *],
      input_block_size_mult_oct: [STATIC, READ, oss$job_paged_literal] vtt_input_block_size_mult_oct :=
            [[vtc_multiple_octet, iic$vt_input_block_size], vtc_multiple_octet_number_dflt, *],
      store_nul_del_oct: [STATIC, READ, oss$job_paged_literal] vtt_store_nul_del_oct :=
            [[vtc_single_octet, iic$vt_store_nuls_dels], *],
      store_back_char_oct: [STATIC, READ, oss$job_paged_literal] vtt_store_back_char_oct :=
            [[vtc_single_octet, iic$vt_store_backspace_char], *],
      network_ctl_char_oct: [STATIC, READ, oss$job_paged_literal] vtt_network_ctl_char_oct :=
            [[vtc_single_octet, iic$vt_network_command_char], *],
      cancel_line_char_oct: [STATIC, READ, oss$job_paged_literal] vtt_cancel_line_char_oct :=
            [[vtc_single_octet, iic$vt_cancel_line_character], *],
      end_line_char_oct: [STATIC, READ, oss$job_paged_literal] vtt_end_line_char_oct :=
            [[vtc_single_octet, iic$vt_end_line_character], *],
      begin_line_char_oct: [STATIC, READ, oss$job_paged_literal] vtt_begin_line_char_oct :=
            [[vtc_single_octet, iic$vt_begin_line_character], *],
      backspace_char_oct: [STATIC, READ, oss$job_paged_literal] vtt_backspace_char_oct :=
            [[vtc_single_octet, iic$vt_backspace_character], *],
      end_partial_char_oct: [STATIC, READ, oss$job_paged_literal] vtt_end_partial_char_oct :=
            [[vtc_single_octet, iic$vt_end_partial_character], *],
      attention_char_oct: [STATIC, READ, oss$job_paged_literal] vtt_attention_char_oct :=
            [[vtc_single_octet, iic$vt_attention_character], *],
      page_length_oct: [STATIC, READ, oss$job_paged_literal] vtt_page_length_oct :=
            [[vtc_single_octet, iic$vt_page_length], *],
      page_width_oct: [STATIC, READ, oss$job_paged_literal] vtt_page_width_oct :=
            [[vtc_single_octet, iic$vt_page_width], *],
      hold_page_oct: [STATIC, READ, oss$job_paged_literal] vtt_hold_page_oct :=
            [[vtc_single_octet, iic$vt_hold_page], *],
      hold_page_over_oct: [STATIC, READ, oss$job_paged_literal] vtt_hold_page_over_oct :=
            [[vtc_single_octet, iic$vt_hold_page_over], *],
      fold_line_oct: [STATIC, READ, oss$job_paged_literal] vtt_fold_line_oct :=
            [[vtc_single_octet, iic$vt_fold_line], *],
      end_out_seq_sing_oct: [STATIC, READ, oss$job_paged_literal] vtt_end_out_seq_sing_oct :=
            [[vtc_single_octet, iic$vt_end_output_sequence], *],
      end_out_seq_mult_oct: [STATIC, READ, oss$job_paged_literal] vtt_end_out_seq_mult_oct :=
            [[vtc_multiple_octet, iic$vt_end_output_sequence], vtc_multiple_octet_number_dflt],
      carr_ret_seq_sing_oct: [STATIC, READ, oss$job_paged_literal] vtt_carr_ret_seq_sing_oct :=
            [[vtc_single_octet, iic$vt_carriage_return_sequence], *],
      carr_ret_seq_mult_oct: [STATIC, READ, oss$job_paged_literal] vtt_carr_ret_seq_mult_oct :=
            [[vtc_multiple_octet, iic$vt_carriage_return_sequence], vtc_multiple_octet_number_dflt],
      line_feed_seq_sing_oct: [STATIC, READ, oss$job_paged_literal] vtt_line_feed_seq_sing_oct :=
            [[vtc_single_octet, iic$vt_line_feed_sequence], *],
      line_feed_seq_mult_oct: [STATIC, READ, oss$job_paged_literal] vtt_line_feed_seq_mult_oct :=
            [[vtc_multiple_octet, iic$vt_line_feed_sequence], vtc_multiple_octet_number_dflt],
      form_feed_seq_sing_oct: [STATIC, READ, oss$job_paged_literal] vtt_form_feed_seq_sing_oct :=
            [[vtc_single_octet, iic$vt_form_feed_sequence], *],
      form_feed_seq_mult_oct: [STATIC, READ, oss$job_paged_literal] vtt_form_feed_seq_mult_oct :=
            [[vtc_multiple_octet, iic$vt_form_feed_sequence], vtc_multiple_octet_number_dflt],
      end_page_action_oct: [STATIC, READ, oss$job_paged_literal] vtt_end_page_action_oct :=
            [[vtc_single_octet, iic$vt_end_page_action], *],
      carr_ret_delay_sing_oct: [STATIC, READ, oss$job_paged_literal] vtt_carr_ret_delay_sing_oct :=
            [[vtc_single_octet, iic$vt_carriage_return_delay], *],
      carr_ret_delay_mult_oct: [STATIC, READ, oss$job_paged_literal] vtt_carr_ret_delay_mult_oct :=
            [[vtc_multiple_octet, iic$vt_carriage_return_delay], vtc_multiple_octet_number_dflt, *],
      line_feed_delay_sing_oct: [STATIC, READ, oss$job_paged_literal] vtt_line_feed_delay_sing_oct :=
            [[vtc_single_octet, iic$vt_line_feed_delay], *],
      line_feed_delay_mult_oct: [STATIC, READ, oss$job_paged_literal] vtt_line_feed_delay_mult_oct :=
            [[vtc_multiple_octet, iic$vt_line_feed_delay], vtc_multiple_octet_number_dflt, *],
      form_feed_delay_sing_oct: [STATIC, READ, oss$job_paged_literal] vtt_form_feed_delay_sing_oct :=
            [[vtc_single_octet, iic$vt_form_feed_delay], *],
      form_feed_delay_mult_oct: [STATIC, READ, oss$job_paged_literal] vtt_form_feed_delay_mult_oct :=
            [[vtc_multiple_octet, iic$vt_form_feed_delay], vtc_multiple_octet_number_dflt, *],
      end_line_position_oct: [STATIC, READ, oss$job_paged_literal] vtt_end_line_position_oct :=
            [[vtc_single_octet, iic$vt_end_line_positioning], *],
      end_partial_position_oct: [STATIC, READ, oss$job_paged_literal] vtt_end_partial_position_oct :=
            [[vtc_single_octet, iic$vt_end_partial_positioning], *],
      char_flow_control_oct: [STATIC, READ, oss$job_paged_literal] vtt_char_flow_control_oct :=
            [[vtc_single_octet, iic$vt_character_flow_control], *],
      function_key_class_sing_oct: [STATIC, READ, oss$job_paged_literal] vtt_function_key_class_sing_oct :=
            [[vtc_single_octet, iic$vt_function_key_class], *],
      function_key_class_mult_oct: [STATIC, READ, oss$job_paged_literal] vtt_function_key_class_mult_oct :=
            [[vtc_multiple_octet, iic$vt_function_key_class], vtc_multiple_octet_number_dflt],
      terminal_model_sing_oct: [STATIC, READ, oss$job_paged_literal] vtt_terminal_model_sing_oct :=
            [[vtc_single_octet, iic$vt_terminal_model], *],
      terminal_model_mult_oct: [STATIC, READ, oss$job_paged_literal] vtt_terminal_model_mult_oct :=
            [[vtc_multiple_octet, iic$vt_terminal_model], vtc_multiple_octet_number_dflt],
      code_set_oct: [STATIC, READ, oss$job_paged_literal] vtt_code_set_oct :=
            [[vtc_single_octet, iic$vt_code_set], *],
      code_set_name_oct: [STATIC, READ, oss$job_paged_literal] vtt_code_set_name_oct :=
            [[vtc_multiple_octet, iic$vt_code_set], vtc_multiple_octet_number_dflt,
            vtc_site_defined_code_set_dflt],
      parity_type_oct: [STATIC, READ, oss$job_paged_literal] vtt_parity_type_oct :=
            [[vtc_single_octet, iic$vt_parity], *],
      echoplex_oct: [STATIC, READ, oss$job_paged_literal] vtt_echoplex_oct :=
            [[vtc_single_octet, iic$vt_echoplex], *],
      status_action_oct: [STATIC, READ, oss$job_paged_literal] vtt_status_action_oct :=
            [[vtc_single_octet, iic$vt_status_action], *];

    VAR
      input_output_mode_oct_ptr: ^vtt_input_output_mode_oct,
      input_editing_mode_oct_ptr: ^vtt_input_editing_mode_oct,
      transp_char_mode_oct_ptr: ^vtt_transp_char_mode_oct,
      transp_for_char_single_oct_ptr: ^vtt_transp_for_char_single_oct,
      transp_for_char_mult_oct_ptr: ^vtt_transp_for_char_mult_oct,
      transp_term_char_sing_oct_ptr: ^vtt_transp_term_char_sing_oct,
      transp_term_char_mult_oct_ptr: ^vtt_transp_term_char_mult_oct,
      transp_protocol_mode_oct_ptr: ^vtt_transp_protocol_mode_oct,
      transp_timeout_mode_oct_ptr: ^vtt_transp_timeout_mode_oct,
      transp_len_mode_oct_ptr: ^vtt_transp_len_mode_oct,
      transp_mess_len_sing_oct_ptr: ^vtt_transp_mess_len_sing_oct,
      transp_mess_len_mult_oct_ptr: ^vtt_transp_mess_len_mult_oct,
      control_code_rep_none_oct_ptr: ^vtt_control_code_rep_none_oct,
      control_code_rep_mult_oct_ptr: ^vtt_control_code_rep_mult_oct,
      control_code_rep_ext_oct_ptr: ^vtt_control_code_rep_ext_oct,
      partial_char_forward_oct_ptr: ^vtt_partial_char_forward_oct,
      atten_char_act_oct_ptr: ^vtt_atten_char_act_oct,
      break_key_action_oct_ptr: ^vtt_break_key_action_oct,
      input_block_size_sing_oct_ptr: ^vtt_input_block_size_sing_oct,
      input_block_size_mult_oct_ptr: ^vtt_input_block_size_mult_oct,
      store_nul_del_oct_ptr: ^vtt_store_nul_del_oct,
      store_back_char_oct_ptr: ^vtt_store_back_char_oct,
      network_ctl_char_oct_ptr: ^vtt_network_ctl_char_oct,
      cancel_line_char_oct_ptr: ^vtt_cancel_line_char_oct,
      end_line_char_oct_ptr: ^vtt_end_line_char_oct,
      begin_line_char_oct_ptr: ^vtt_begin_line_char_oct,
      backspace_char_oct_ptr: ^vtt_backspace_char_oct,
      end_partial_char_oct_ptr: ^vtt_end_partial_char_oct,
      attention_char_oct_ptr: ^vtt_attention_char_oct,
      page_length_oct_ptr: ^vtt_page_length_oct,
      page_width_oct_ptr: ^vtt_page_width_oct,
      hold_page_oct_ptr: ^vtt_hold_page_oct,
      hold_page_over_oct_ptr: ^vtt_hold_page_over_oct,
      fold_line_oct_ptr: ^vtt_fold_line_oct,
      end_out_seq_sing_oct_ptr: ^vtt_end_out_seq_sing_oct,
      end_out_seq_mult_oct_ptr: ^vtt_end_out_seq_mult_oct,
      carr_ret_seq_sing_oct_ptr: ^vtt_carr_ret_seq_sing_oct,
      carr_ret_seq_mult_oct_ptr: ^vtt_carr_ret_seq_mult_oct,
      line_feed_seq_sing_oct_ptr: ^vtt_line_feed_seq_sing_oct,
      line_feed_seq_mult_oct_ptr: ^vtt_line_feed_seq_mult_oct,
      form_feed_seq_sing_oct_ptr: ^vtt_form_feed_seq_sing_oct,
      form_feed_seq_mult_oct_ptr: ^vtt_form_feed_seq_mult_oct,
      end_page_action_oct_ptr: ^vtt_end_page_action_oct,
      carr_ret_delay_sing_oct_ptr: ^vtt_carr_ret_delay_sing_oct,
      carr_ret_delay_mult_oct_ptr: ^vtt_carr_ret_delay_mult_oct,
      line_feed_delay_sing_oct_ptr: ^vtt_line_feed_delay_sing_oct,
      line_feed_delay_mult_oct_ptr: ^vtt_line_feed_delay_mult_oct,
      form_feed_delay_sing_oct_ptr: ^vtt_form_feed_delay_sing_oct,
      form_feed_delay_mult_oct_ptr: ^vtt_form_feed_delay_mult_oct,
      end_line_position_oct_ptr: ^vtt_end_line_position_oct,
      end_partial_position_oct_ptr: ^vtt_end_partial_position_oct,
      char_flow_control_oct_ptr: ^vtt_char_flow_control_oct,
      terminal_model_sing_oct_ptr: ^vtt_terminal_model_sing_oct,
      terminal_model_mult_oct_ptr: ^vtt_terminal_model_mult_oct,
      function_key_class_sing_oct_ptr: ^vtt_function_key_class_sing_oct,
      function_key_class_mult_oct_ptr: ^vtt_function_key_class_mult_oct,
      code_set_oct_ptr: ^vtt_code_set_oct,
      code_set_name_oct_ptr: ^vtt_code_set_name_oct,
      parity_type_oct_ptr: ^vtt_parity_type_oct,
      echoplex_oct_ptr: ^vtt_echoplex_oct,
      status_action_oct_ptr: ^vtt_status_action_oct;

    VAR
      i: integer,
      j: integer,
      k: integer,
      control_code_replacement_value: ^array [1 .. *]
        OF ift$control_code_rep_char,
      original_control_code_set: ^array[1 .. *] OF char,
      original_control_code_set_size: 1 .. 2 * ifc$total_substitution_count,
      string_attribute: ^string ( * );

*copyc ift$terminal_connection_types
*copyc ift$terminal_attribute_types
*copyc iit$vt_attribute_descriptions
*copyc iit$vt_attribute_kinds

?? EJECT ??


    FOR i := 1 TO UPPERBOUND (attributes) DO
      CASE attributes [i].kind OF

      = iic$vt_input_output_mode =
        data_length := data_length + #SIZE (input_output_mode_oct);
        NEXT input_output_mode_oct_ptr IN buffer;
        input_output_mode_oct_ptr^ := input_output_mode_oct;
        input_output_mode_oct_ptr^.attribute := attributes [i].input_output_mode;

      = iic$vt_input_editing_mode =
        data_length := data_length + #SIZE (input_editing_mode_oct);
        NEXT input_editing_mode_oct_ptr IN buffer;
        input_editing_mode_oct_ptr^ := input_editing_mode_oct;
        input_editing_mode_oct_ptr^.attribute := attributes [i].input_editing_mode;

      = iic$vt_trans_character_mode =
        data_length := data_length + #SIZE (transp_char_mode_oct);
        NEXT transp_char_mode_oct_ptr IN buffer;
        transp_char_mode_oct_ptr^ := transp_char_mode_oct;
        transp_char_mode_oct_ptr^.attribute := attributes [i].trans_character_mode;

      = iic$vt_trans_forward_character =
        IF attributes [i].trans_forward_character.size = 1 THEN
          data_length := data_length + #SIZE (transp_for_char_single_oct);
          NEXT transp_for_char_single_oct_ptr IN buffer;
          transp_for_char_single_oct_ptr^ := transp_for_char_single_oct;
          transp_for_char_single_oct_ptr^.attribute := attributes [i].trans_forward_character.value;
        ELSE
          data_length := data_length + #SIZE (transp_for_char_mult_oct) +
                attributes [i].trans_forward_character.size;
          NEXT transp_for_char_mult_oct_ptr IN buffer;
          transp_for_char_mult_oct_ptr^ := transp_for_char_mult_oct;
          NEXT string_attribute: [attributes [i].trans_forward_character.size] IN buffer;
          string_attribute^ := attributes [i].trans_forward_character.value;
          transp_for_char_mult_oct_ptr^.octet_number := attributes [i].trans_forward_character.size;
        IFEND;

      = iic$vt_trans_term_character =
        IF attributes [i].trans_terminate_character.size = 1 THEN
          data_length := data_length + #SIZE (transp_term_char_sing_oct);
          NEXT transp_term_char_sing_oct_ptr IN buffer;
          transp_term_char_sing_oct_ptr^ := transp_term_char_sing_oct;
          transp_term_char_sing_oct_ptr^.attribute := attributes [i].trans_terminate_character.value;
        ELSE
          data_length := data_length + #SIZE (transp_term_char_mult_oct) +
                attributes [i].trans_terminate_character.size;
          NEXT transp_term_char_mult_oct_ptr IN buffer;
          transp_term_char_mult_oct_ptr^ := transp_term_char_mult_oct;
          NEXT string_attribute: [attributes [i].trans_terminate_character.size] IN buffer;
          string_attribute^ := attributes [i].trans_terminate_character.value;
          transp_term_char_mult_oct_ptr^.octet_number := attributes [i].trans_terminate_character.size;
        IFEND;

      = iic$vt_trans_timeout_mode =
        data_length := data_length + #SIZE (transp_timeout_mode_oct);
        NEXT transp_timeout_mode_oct_ptr IN buffer;
        transp_timeout_mode_oct_ptr^ := transp_timeout_mode_oct;
        transp_timeout_mode_oct_ptr^.attribute := attributes [i].trans_timeout_mode;

      = iic$vt_trans_length_mode =
        data_length := data_length + #SIZE (transp_len_mode_oct);
        NEXT transp_len_mode_oct_ptr IN buffer;
        transp_len_mode_oct_ptr^ := transp_len_mode_oct;
        transp_len_mode_oct_ptr^.attribute := attributes [i].trans_length_mode;

      = iic$vt_trans_message_length =
        IF attributes [i].trans_message_length <= 255 THEN
          data_length := data_length + #SIZE (transp_mess_len_sing_oct);
          NEXT transp_mess_len_sing_oct_ptr IN buffer;
          transp_mess_len_sing_oct_ptr^ := transp_mess_len_sing_oct;
          transp_mess_len_sing_oct_ptr^.attribute := attributes [i].trans_message_length;
        ELSE
          data_length := data_length + #SIZE (transp_mess_len_mult_oct);
          NEXT transp_mess_len_mult_oct_ptr IN buffer;
          transp_mess_len_mult_oct_ptr^ := transp_mess_len_mult_oct;
          transp_mess_len_mult_oct_ptr^.attribute := attributes [i].trans_message_length;
        IFEND;

      = iic$vt_partial_char_forwarding =
        data_length := data_length + #SIZE (partial_char_forward_oct);
        NEXT partial_char_forward_oct_ptr IN buffer;
        partial_char_forward_oct_ptr^ := partial_char_forward_oct;
        partial_char_forward_oct_ptr^.attribute := attributes [i].partial_char_forwarding;

      = iic$vt_attention_char_action =
        data_length := data_length + #SIZE (atten_char_act_oct);
        NEXT atten_char_act_oct_ptr IN buffer;
        atten_char_act_oct_ptr^ := atten_char_act_oct;
        atten_char_act_oct_ptr^.attribute := attributes [i].attention_character_action;

      = iic$vt_break_key_action =
        data_length := data_length + #SIZE (break_key_action_oct);
        NEXT break_key_action_oct_ptr IN buffer;
        break_key_action_oct_ptr^ := break_key_action_oct;
        break_key_action_oct_ptr^.attribute := attributes [i].break_key_action;

      = iic$vt_input_block_size =
        IF attributes [i].input_block_size <= 255 THEN
          data_length := data_length + #SIZE (input_block_size_sing_oct);
          NEXT input_block_size_sing_oct_ptr IN buffer;
          input_block_size_sing_oct_ptr^ := input_block_size_sing_oct;
          input_block_size_sing_oct_ptr^.attribute := attributes [i].input_block_size;
        ELSE
          data_length := data_length + #SIZE (input_block_size_mult_oct);
          NEXT input_block_size_mult_oct_ptr IN buffer;
          input_block_size_mult_oct_ptr^ := input_block_size_mult_oct;
          input_block_size_mult_oct_ptr^.attribute := attributes [i].input_block_size;
        IFEND;

      = iic$vt_store_nuls_dels =
        data_length := data_length + #SIZE (store_nul_del_oct);
        NEXT store_nul_del_oct_ptr IN buffer;
        store_nul_del_oct_ptr^ := store_nul_del_oct;
        store_nul_del_oct_ptr^.attribute := attributes [i].store_nuls_dels;

      = iic$vt_store_backspace_char =
        data_length := data_length + #SIZE (store_back_char_oct);
        NEXT store_back_char_oct_ptr IN buffer;
        store_back_char_oct_ptr^ := store_back_char_oct;
        store_back_char_oct_ptr^.attribute := attributes [i].store_backspace_character;

      = iic$vt_network_command_char =
        data_length := data_length + #SIZE (network_ctl_char_oct);
        NEXT network_ctl_char_oct_ptr IN buffer;
        network_ctl_char_oct_ptr^ := network_ctl_char_oct;
        network_ctl_char_oct_ptr^.attribute := attributes [i].network_command_character;

      = iic$vt_cancel_line_character =
        data_length := data_length + #SIZE (cancel_line_char_oct);
        NEXT cancel_line_char_oct_ptr IN buffer;
        cancel_line_char_oct_ptr^ := cancel_line_char_oct;
        cancel_line_char_oct_ptr^.attribute := attributes [i].cancel_line_character;

      = iic$vt_end_line_character =
        data_length := data_length + #SIZE (end_line_char_oct);
        NEXT end_line_char_oct_ptr IN buffer;
        end_line_char_oct_ptr^ := end_line_char_oct;
        end_line_char_oct_ptr^.attribute := attributes [i].end_line_character;

      = iic$vt_begin_line_character =
        data_length := data_length + #SIZE (begin_line_char_oct);
        NEXT begin_line_char_oct_ptr IN buffer;
        begin_line_char_oct_ptr^ := begin_line_char_oct;
        begin_line_char_oct_ptr^.attribute := attributes [i].begin_line_character;

      = iic$vt_backspace_character =
        data_length := data_length + #SIZE (backspace_char_oct);
        NEXT backspace_char_oct_ptr IN buffer;
        backspace_char_oct_ptr^ := backspace_char_oct;
        backspace_char_oct_ptr^.attribute := attributes [i].backspace_character;

      = iic$vt_end_partial_character =
        data_length := data_length + #SIZE (end_partial_char_oct);
        NEXT end_partial_char_oct_ptr IN buffer;
        end_partial_char_oct_ptr^ := end_partial_char_oct;
        end_partial_char_oct_ptr^.attribute := attributes [i].end_partial_character;

      = iic$vt_attention_character =
        data_length := data_length + #SIZE (attention_char_oct);
        NEXT attention_char_oct_ptr IN buffer;
        attention_char_oct_ptr^ := attention_char_oct;
        attention_char_oct_ptr^.attribute := attributes [i].attention_character;

      = iic$vt_page_length =
        data_length := data_length + #SIZE (page_length_oct);
        NEXT page_length_oct_ptr IN buffer;
        page_length_oct_ptr^ := page_length_oct;
        page_length_oct_ptr^.attribute := attributes [i].page_length;

      = iic$vt_page_width =
        data_length := data_length + #SIZE (page_width_oct);
        NEXT page_width_oct_ptr IN buffer;
        page_width_oct_ptr^ := page_width_oct;
        page_width_oct_ptr^.attribute := attributes [i].page_width;

      = iic$vt_hold_page =
        data_length := data_length + #SIZE (hold_page_oct);
        NEXT hold_page_oct_ptr IN buffer;
        hold_page_oct_ptr^ := hold_page_oct;
        hold_page_oct_ptr^.attribute := attributes [i].hold_page;

      = iic$vt_hold_page_over =
        data_length := data_length + #SIZE (hold_page_over_oct);
        NEXT hold_page_over_oct_ptr IN buffer;
        hold_page_over_oct_ptr^ := hold_page_over_oct;
        hold_page_over_oct_ptr^.attribute := attributes [i].hold_page_over;

      = iic$vt_fold_line =
        data_length := data_length + #SIZE (fold_line_oct);
        NEXT fold_line_oct_ptr IN buffer;
        fold_line_oct_ptr^ := fold_line_oct;
        fold_line_oct_ptr^.attribute := attributes [i].fold_line;

      = iic$vt_end_output_sequence =
        IF attributes [i].end_output_sequence.size = 1 THEN
          data_length := data_length + #SIZE (end_out_seq_sing_oct);
          NEXT end_out_seq_sing_oct_ptr IN buffer;
          end_out_seq_sing_oct_ptr^ := end_out_seq_sing_oct;
          end_out_seq_sing_oct_ptr^.attribute := attributes [i].end_output_sequence.value;
        ELSE
          data_length := data_length + #SIZE (end_out_seq_mult_oct) + attributes [i].end_output_sequence.size;
          NEXT end_out_seq_mult_oct_ptr IN buffer;
          end_out_seq_mult_oct_ptr^ := end_out_seq_mult_oct;
          NEXT string_attribute: [attributes [i].end_output_sequence.size] IN buffer;
          string_attribute^ := attributes [i].end_output_sequence.value;
          end_out_seq_mult_oct_ptr^.octet_number := attributes [i].end_output_sequence.size;
        IFEND;

      = iic$vt_carriage_return_sequence =
        IF attributes [i].carriage_return_sequence.size = 1 THEN
          data_length := data_length + #SIZE (carr_ret_seq_sing_oct);
          NEXT carr_ret_seq_sing_oct_ptr IN buffer;
          carr_ret_seq_sing_oct_ptr^ := carr_ret_seq_sing_oct;
          carr_ret_seq_sing_oct_ptr^.attribute := attributes [i].carriage_return_sequence.value;
        ELSE
          data_length := data_length + #SIZE (carr_ret_seq_mult_oct) +
                attributes [i].carriage_return_sequence.size;
          NEXT carr_ret_seq_mult_oct_ptr IN buffer;
          carr_ret_seq_mult_oct_ptr^ := carr_ret_seq_mult_oct;
          NEXT string_attribute: [attributes [i].carriage_return_sequence.size] IN buffer;
          string_attribute^ := attributes [i].carriage_return_sequence.value;
          carr_ret_seq_mult_oct_ptr^.octet_number := attributes [i].carriage_return_sequence.size;
        IFEND;

      = iic$vt_line_feed_sequence =
        IF attributes [i].line_feed_sequence.size = 1 THEN
          data_length := data_length + #SIZE (line_feed_seq_sing_oct);
          NEXT line_feed_seq_sing_oct_ptr IN buffer;
          line_feed_seq_sing_oct_ptr^ := line_feed_seq_sing_oct;
          line_feed_seq_sing_oct_ptr^.attribute := attributes [i].line_feed_sequence.value;
        ELSE
          data_length := data_length + #SIZE (line_feed_seq_mult_oct) +
                attributes [i].line_feed_sequence.size;
          NEXT line_feed_seq_mult_oct_ptr IN buffer;
          line_feed_seq_mult_oct_ptr^ := line_feed_seq_mult_oct;
          NEXT string_attribute: [attributes [i].line_feed_sequence.size] IN buffer;
          string_attribute^ := attributes [i].line_feed_sequence.value;
          line_feed_seq_mult_oct_ptr^.octet_number := attributes [i].line_feed_sequence.size;
        IFEND;

      = iic$vt_form_feed_sequence =
        IF attributes [i].form_feed_sequence.size = 1 THEN
          data_length := data_length + #SIZE (form_feed_seq_sing_oct);
          NEXT form_feed_seq_sing_oct_ptr IN buffer;
          form_feed_seq_sing_oct_ptr^ := form_feed_seq_sing_oct;
          form_feed_seq_sing_oct_ptr^.attribute := attributes [i].form_feed_sequence.value;
        ELSE
          data_length := data_length + #SIZE (form_feed_seq_mult_oct) +
                attributes [i].form_feed_sequence.size;
          NEXT form_feed_seq_mult_oct_ptr IN buffer;
          form_feed_seq_mult_oct_ptr^ := form_feed_seq_mult_oct;
          NEXT string_attribute: [attributes [i].form_feed_sequence.size] IN buffer;
          string_attribute^ := attributes [i].form_feed_sequence.value;
          form_feed_seq_mult_oct_ptr^.octet_number := attributes [i].form_feed_sequence.size;
        IFEND;

      = iic$vt_end_page_action =
        data_length := data_length + #SIZE (end_page_action_oct);
        NEXT end_page_action_oct_ptr IN buffer;
        end_page_action_oct_ptr^ := end_page_action_oct;
        end_page_action_oct_ptr^.attribute := attributes [i].end_page_action;

      = iic$vt_carriage_return_delay =
        IF attributes [i].carriage_return_delay <= 255 THEN
          data_length := data_length + #SIZE (carr_ret_delay_sing_oct);
          NEXT carr_ret_delay_sing_oct_ptr IN buffer;
          carr_ret_delay_sing_oct_ptr^ := carr_ret_delay_sing_oct;
          carr_ret_delay_sing_oct_ptr^.attribute := attributes [i].carriage_return_delay;
        ELSE
          data_length := data_length + #SIZE (carr_ret_delay_mult_oct);
          NEXT carr_ret_delay_mult_oct_ptr IN buffer;
          carr_ret_delay_mult_oct_ptr^ := carr_ret_delay_mult_oct;
          carr_ret_delay_mult_oct_ptr^.attribute := attributes [i].carriage_return_delay;
        IFEND;

      = iic$vt_line_feed_delay =
        IF attributes [i].line_feed_delay <= 255 THEN
          data_length := data_length + #SIZE (line_feed_delay_sing_oct);
          NEXT line_feed_delay_sing_oct_ptr IN buffer;
          line_feed_delay_sing_oct_ptr^ := line_feed_delay_sing_oct;
          line_feed_delay_sing_oct_ptr^.attribute := attributes [i].line_feed_delay;
        ELSE
          data_length := data_length + #SIZE (line_feed_delay_mult_oct);
          NEXT line_feed_delay_mult_oct_ptr IN buffer;
          line_feed_delay_mult_oct_ptr^ := line_feed_delay_mult_oct;
          line_feed_delay_mult_oct_ptr^.attribute := attributes [i].line_feed_delay;
        IFEND;

      = iic$vt_form_feed_delay =
        IF attributes [i].form_feed_delay <= 255 THEN
          data_length := data_length + #SIZE (form_feed_delay_sing_oct);
          NEXT form_feed_delay_sing_oct_ptr IN buffer;
          form_feed_delay_sing_oct_ptr^ := form_feed_delay_sing_oct;
          form_feed_delay_sing_oct_ptr^.attribute := attributes [i].form_feed_delay;
        ELSE
          data_length := data_length + #SIZE (form_feed_delay_mult_oct);
          NEXT form_feed_delay_mult_oct_ptr IN buffer;
          form_feed_delay_mult_oct_ptr^ := form_feed_delay_mult_oct;
          form_feed_delay_mult_oct_ptr^.attribute := attributes [i].form_feed_delay;
        IFEND;

      = iic$vt_end_line_positioning =
        data_length := data_length + #SIZE (end_line_position_oct);
        NEXT end_line_position_oct_ptr IN buffer;
        end_line_position_oct_ptr^ := end_line_position_oct;
        end_line_position_oct_ptr^.attribute := attributes [i].end_line_positioning;

      = iic$vt_end_partial_positioning =
        data_length := data_length + #SIZE (end_partial_position_oct);
        NEXT end_partial_position_oct_ptr IN buffer;
        end_partial_position_oct_ptr^ := end_partial_position_oct;
        end_partial_position_oct_ptr^.attribute := attributes [i].end_partial_positioning;

      = iic$vt_character_flow_control =
        data_length := data_length + #SIZE (char_flow_control_oct);
        NEXT char_flow_control_oct_ptr IN buffer;
        char_flow_control_oct_ptr^ := char_flow_control_oct;
        char_flow_control_oct_ptr^.attribute := attributes [i].character_flow_control;

      = iic$vt_function_key_class =
        IF attributes [i].function_key_class.size = 1 THEN
          data_length := data_length + #SIZE (function_key_class_sing_oct);
          NEXT function_key_class_sing_oct_ptr IN buffer;
          function_key_class_sing_oct_ptr^ := function_key_class_sing_oct;
          function_key_class_sing_oct_ptr^.attribute := attributes [i].function_key_class.value;
        ELSE
          data_length := data_length + #SIZE (function_key_class_mult_oct) +
                attributes [i].function_key_class.size;
          NEXT function_key_class_mult_oct_ptr IN buffer;
          function_key_class_mult_oct_ptr^ := function_key_class_mult_oct;
          NEXT string_attribute: [attributes [i].function_key_class.size] IN buffer;
          string_attribute^ := attributes [i].function_key_class.value;
          function_key_class_mult_oct_ptr^.octet_number := attributes [i].function_key_class.size;
        IFEND;

      = iic$vt_terminal_model =
        IF attributes [i].terminal_model.size = 1 THEN
          data_length := data_length + #SIZE (terminal_model_sing_oct);
          NEXT terminal_model_sing_oct_ptr IN buffer;
          terminal_model_sing_oct_ptr^ := terminal_model_sing_oct;
          terminal_model_sing_oct_ptr^.attribute := attributes [i].terminal_model.value;
        ELSE
          data_length := data_length + #SIZE (terminal_model_mult_oct) + attributes [i].terminal_model.size;
          NEXT terminal_model_mult_oct_ptr IN buffer;
          terminal_model_mult_oct_ptr^ := terminal_model_mult_oct;
          NEXT string_attribute: [attributes [i].terminal_model.size] IN buffer;
          string_attribute^ := attributes [i].terminal_model.value;
          terminal_model_mult_oct_ptr^.octet_number := attributes [i].terminal_model.size;
        IFEND;

      = iic$vt_code_set =
        data_length := data_length + #SIZE (code_set_oct);
        NEXT code_set_oct_ptr IN buffer;
        code_set_oct_ptr^ := code_set_oct;
        code_set_oct_ptr^.attribute := attributes [i].code_set;

      = iic$vt_parity =
        data_length := data_length + #SIZE (parity_type_oct);
        NEXT parity_type_oct_ptr IN buffer;
        parity_type_oct_ptr^ := parity_type_oct;
        parity_type_oct_ptr^.attribute := attributes [i].parity;

      = iic$vt_echoplex =
        data_length := data_length + #SIZE (echoplex_oct);
        NEXT echoplex_oct_ptr IN buffer;
        echoplex_oct_ptr^ := echoplex_oct;
        echoplex_oct_ptr^.attribute := attributes [i].echoplex;

      = iic$vt_status_action =
        data_length := data_length + #SIZE (status_action_oct);
        NEXT status_action_oct_ptr IN buffer;
        status_action_oct_ptr^ := status_action_oct;
        status_action_oct_ptr^.attribute := attributes [i].status_action;

      = iic$vt_trans_protocol_mode =
        data_length := data_length + #SIZE (transp_protocol_mode_oct);
        NEXT transp_protocol_mode_oct_ptr IN buffer;
        transp_protocol_mode_oct_ptr^ := transp_protocol_mode_oct;
        transp_protocol_mode_oct_ptr^.attribute := attributes [i].trans_protocol_mode;

      = iic$vt_code_set_name =

          data_length := data_length + #SIZE (code_set_name_oct) + attributes [i].code_set_name.size;
          NEXT code_set_name_oct_ptr IN buffer;
          code_set_name_oct_ptr^ := code_set_name_oct;
          NEXT string_attribute: [attributes [i].code_set_name.size] IN buffer;
          string_attribute^ := attributes [i].code_set_name.value;
          code_set_name_oct_ptr^.octet_number := attributes [i].code_set_name.size + 1;


      = iic$vt_control_code_replacement =
        IF attributes [i].control_code_replacement.
          total_substitution_count <= 63 THEN
          IF attributes [i].control_code_replacement.
            total_substitution_count <> 0 THEN
            data_length := data_length + #SIZE (control_code_rep_mult_oct) +
              2 * attributes [i].control_code_replacement.
              total_substitution_count;
            NEXT control_code_rep_mult_oct_ptr IN buffer;
            control_code_rep_mult_oct_ptr^ := control_code_rep_mult_oct;
            control_code_rep_mult_oct_ptr^.octet_number := 2 *
              attributes [i].control_code_replacement.total_substitution_count;
            NEXT control_code_replacement_value:
              [1..attributes [i].control_code_replacement.
              total_substitution_count] IN buffer;
            FOR j := 1 TO attributes [i].control_code_replacement.
              total_substitution_count DO
                control_code_replacement_value^[j].original_control_code :=
                  attributes[i].control_code_replacement.value[j].
                  original_control_code;
                control_code_replacement_value^[j].substitute_control_code :=
                  attributes[i].control_code_replacement.value[j].
                  substitute_control_code;
            FOREND;
          ELSE
            data_length := data_length + #SIZE (control_code_rep_none_oct);
            NEXT control_code_rep_none_oct_ptr IN buffer;
            control_code_rep_none_oct_ptr^ := control_code_rep_none_oct;
          IFEND;
        ELSE
          data_length := data_length + #SIZE (control_code_rep_ext_oct) +
            2 * attributes [i].control_code_replacement.
            total_substitution_count;
          NEXT control_code_rep_ext_oct_ptr IN buffer;
          control_code_rep_ext_oct_ptr^ := control_code_rep_ext_oct;
            control_code_rep_ext_oct_ptr^.octet_number := 2 * attributes[i].
              control_code_replacement.total_substitution_count;
          NEXT control_code_replacement_value:
            [1..attributes [i].control_code_replacement.
            total_substitution_count] IN buffer;
          FOR j := 1 TO attributes [i].control_code_replacement.
            total_substitution_count DO
              control_code_replacement_value^[j].original_control_code :=
                attributes[i].control_code_replacement.value[j].
                original_control_code;
              control_code_replacement_value^[j].substitute_control_code :=
                attributes[i].control_code_replacement.value[j].
                substitute_control_code;
          FOREND;
        IFEND;

      ELSE
        {}
      CASEND;
    FOREND;


  PROCEND iip$vt_create_attribute_octets;

?? TITLE := '[XDCL] iip$vt_change_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$vt_change_attributes
    (    vtp_connection_id: iit$vtp_connection_id;
         file_identifier: amt$file_identifier;
         attributes: iit$vt_attributes;
         wait: ost$wait;
     VAR activity_status: ost$activity_status;
     VAR status: ost$status);

    VAR
      data: array [1 .. 1] of nat$data_fragment,
      local_file_name: amt$local_file_name;

    VAR
      buffer: ^SEQ ( * ),
      connection: [STATIC, oss$task_shared {namve workaround} ] ^iit$vt_connection,
      data_length: nat$data_length,
      data_ptr: ^cell,
      send_change_header: [STATIC, READ, oss$job_paged_literal] iit$vt_message_types :=
        iic$vt_change_attributes,
      send_change_header_ptr: ^iit$vt_message_types;


    status.normal := TRUE;
    connection := vtp_connection_id.connection;
    IF connection = NIL THEN
      iip$vt_validate_file_identifier (file_identifier, local_file_name, file_id_is_valid);
      IF NOT file_id_is_valid THEN
        STRINGREP (ordinal_char, char_length, file_identifier.ordinal);
        osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_id_not_valid, ordinal_char, status);
        RETURN;
      IFEND;
      osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_not_open, local_file_name, status);
    ELSE
      buffer := connection^.output_buffer;
      data [1].address := buffer;
      data [1].length := #SIZE (send_change_header);
      RESET buffer;
      NEXT send_change_header_ptr IN buffer;
      send_change_header_ptr^ := send_change_header;
      iip$vt_create_attribute_octets (attributes, buffer, data [1].length);
      WHILE connection^.change.head <> NIL DO
        remove_queue_entry (iic$vt_change, vtp_connection_id, status);
      WHILEND;
      nap$se_send_data (file_identifier, data, TRUE {EOM} , FALSE {not qualified data} , wait,
            activity_status, status);
    IFEND;

  PROCEND iip$vt_change_attributes;

?? TITLE := '[XDCL] iip$vt_check_data_available', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$vt_check_data_available
    (    file_identifier: amt$file_identifier;
     VAR activity_complete: boolean;
     VAR status: ost$status);

    VAR
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      st_open_file_dsc_pointer: ^iit$st_open_file_description;

    activity_complete := false;
*copy bai$validate_file_identifier
*copy iii$fetch_st_open_file_desc_ptr
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF st_open_file_dsc_pointer^.vtp_connection_id.connection^.input.head
         <> NIL THEN
      activity_complete := true;
      RETURN;
    ELSEIF jmp$is_xterm_job () THEN

{ Check for message from the xterm task that communicates with the X terminal.

      iip$xt_check_upline (st_open_file_dsc_pointer^.vtp_file_id,
           activity_complete, status);

    ELSE { This is a timesharing job.
      nap$check_data_available (st_open_file_dsc_pointer^.vtp_file_id,
        activity_complete,status);
    IFEND;

  PROCEND iip$vt_check_data_available;
?? TITLE := '[XDCL] iip$vt_close', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$vt_close
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);


    amp$close (file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


  PROCEND iip$vt_close;
?? TITLE := '[XDCL] iip$vt_flush_input', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$vt_flush_input
    (    vtp_connection_id: iit$vtp_connection_id;
     VAR status: ost$status);

    VAR
      connection: [STATIC, oss$task_shared {namve workaround} ] ^iit$vt_connection;

    status.normal := TRUE;
    connection := vtp_connection_id.connection;
    IF connection = NIL THEN
      osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_already_closed, '', status);
      RETURN;
    ELSE

      WHILE connection^.input.head <> NIL DO
        remove_queue_entry (iic$vt_input, vtp_connection_id, status);
      WHILEND;

      WHILE connection^.output.head <> NIL DO
        remove_queue_entry (iic$vt_output, vtp_connection_id, status);
      WHILEND;

    IFEND;

  PROCEND iip$vt_flush_input;

?? TITLE := '[XDCL] iip$vt_get_attr_ch_indications', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$vt_get_attr_ch_indications
    (    vtp_connection_id: iit$vtp_connection_id;
     VAR attributes: iit$vt_attributes;
     VAR number_of_attributes: 0 .. iic$vt_max_number_of_attributes;
     VAR status: ost$status);

    VAR
      connection: [STATIC, oss$task_shared {namve workaround} ] ^iit$vt_connection,
      local_file_name: amt$local_file_name,
      message_type: ^iit$vt_message_types,
      query_response: ^SEQ ( * ),
      start_of_octets: ^SEQ ( * ),
      transfer_count: nat$data_length,
      vtp_buffer: ^SEQ ( * );

    status.normal := TRUE;
    connection := vtp_connection_id.connection;

    IF connection = NIL THEN
      osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_not_open, local_file_name, status);
    ELSE
      number_of_attributes := 0;
      IF connection^.indications.head <> NIL THEN
        vtp_buffer := connection^.indications.head^.vtp_buffer;
        RESET vtp_buffer;
        transfer_count := connection^.indications.head^.q_header.transfer_length;
        NEXT query_response: [[REP transfer_count OF cell]] IN vtp_buffer;
        RESET query_response;
        NEXT message_type IN query_response;
        IF queue_type_from_message [message_type^] = iic$vt_indications THEN
          iip$vt_externalize_octets (query_response, attributes, number_of_attributes);
        IFEND;
        remove_queue_entry (iic$vt_indications, vtp_connection_id, status);
      IFEND;
    IFEND;

  PROCEND iip$vt_get_attr_ch_indications;
?? TITLE := '[XDCL] iip$vt_get_change_response', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$vt_get_change_response
    (    vtp_connection_id: iit$vtp_connection_id;
         file_identifier: amt$file_identifier;
         wait: ost$wait;
     VAR error_code: iit$vt_change_error_codes;
     VAR attribute_error_pairs: array [1 .. 2] of iit$vt_attribute;
     VAR response_received: boolean;
     VAR status: ost$status);


    VAR
      connection: [STATIC, oss$task_shared {namve workaround} ] ^iit$vt_connection,
      end_of_message: boolean,
      extra_status: ost$status,
      input: iit$vt_input_information,
      local_file_name: amt$local_file_name,
      queue_entry: ^iit$vt_queue_entry,
      transfer_count: nat$data_length,
      timeout: iit$vt_timeout,
      vtp_buffer: ^SEQ ( * );

?? NEWTITLE := '  EXTERNALIZE_CHANGE', EJECT ??

    PROCEDURE externalize_change
      (VAR vtp_buffer: ^SEQ ( * );
       VAR error_code: iit$vt_change_error_codes;
       VAR attribute_error_pairs: iit$vt_attributes;
       VAR status: ost$status);

      VAR
        error: ^iit$vt_change_error_codes,
        message_type: ^iit$vt_message_types,
        number_of_octets: 0 .. iic$vt_max_number_of_attributes;


      NEXT message_type IN vtp_buffer;
      IF message_type = NIL THEN
        RETURN;
      IFEND;
      IF message_type^ = iic$vt_change_attribute_confirm THEN
        status.normal := TRUE;
      ELSE
        IF message_type^ = iic$vt_change_attributes_reject THEN
          osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_change_attributes_error, '', status);
          NEXT error IN vtp_buffer;
          IF error = NIL THEN
            RETURN;
          IFEND;
          error_code := error^;
          iip$vt_externalize_octets (vtp_buffer, attribute_error_pairs, number_of_octets);
        ELSE
          osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_incorrect_entry_on_queue, '', status);
          RETURN;
        IFEND;
      IFEND;


    PROCEND externalize_change;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    connection := vtp_connection_id.connection;
    IF connection = NIL THEN
      iip$vt_validate_file_identifier (file_identifier, local_file_name, file_id_is_valid);
      IF NOT file_id_is_valid THEN
        STRINGREP (ordinal_char, char_length, file_identifier.ordinal);
        osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_id_not_valid, ordinal_char, status);
        RETURN;
      IFEND;
      osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_not_open, local_file_name, status);
    ELSE
      queue_entry := connection^.change.head;
      response_received := FALSE;
      IF queue_entry <> NIL THEN
        vtp_buffer := queue_entry^.vtp_buffer;
        RESET vtp_buffer;
        externalize_change (vtp_buffer, error_code, attribute_error_pairs, status);
        extra_status.normal := TRUE;
        remove_queue_entry (iic$vt_change, vtp_connection_id, extra_status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF NOT extra_status.normal THEN
          status := extra_status;
          RETURN;
        IFEND;
        response_received := TRUE;
      ELSE
        vtp_buffer := connection^.input_buffer;
        RESET vtp_buffer; {gkc}
        timeout. ON := TRUE;
        timeout.length := 12000;
        timeout.purge := FALSE;
        get_next_special_block (vtp_connection_id, file_identifier, iic$vt_change, vtp_buffer,
              iic$vt_max_transfer_length, wait, timeout, response_received, end_of_message, transfer_count,
              input, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF response_received THEN
          externalize_change (vtp_buffer, error_code, attribute_error_pairs, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND iip$vt_get_change_response;
?? TITLE := '[XDCL] iip$vt_get_query_response', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$vt_get_query_response
    (    vtp_connection_id: iit$vtp_connection_id;
         file_identifier: amt$file_identifier;
         wait: ost$wait;
     VAR confirmed: boolean;
     VAR attributes: iit$vt_attributes;
     VAR unknown_attribute_number: iit$vt_attribute_kind;
     VAR response_received: boolean;
     VAR status: ost$status);

    VAR
      end_of_message: boolean,
      extra_status: ost$status,
      timeout: iit$vt_timeout,
      queue_entry: ^iit$vt_queue_entry,
      query_response: ^SEQ ( * ),
      connection: [STATIC, oss$task_shared {namve workaround} ] ^iit$vt_connection,
      local_file_name: amt$local_file_name,
      transfer_count: nat$data_length,
      vtp_buffer: ^SEQ ( * ),
      input: iit$vt_input_information;

?? NEWTITLE := '  EXTERNALIZE_QUERY', EJECT ??

    PROCEDURE externalize_query
      (VAR query_response: ^SEQ ( * );
       VAR confirmed: boolean;
       VAR attributes: iit$vt_attributes;
       VAR unknown_attribute_number: iit$vt_attribute_kind;
       VAR status: ost$status);

      VAR
        message_type: ^iit$vt_message_types,
        attribute_number: ^iit$vt_attribute_kind,
        number_of_octets: 0 .. iic$vt_max_number_of_attributes;


      NEXT message_type IN query_response;
      IF message_type = NIL THEN
        RETURN;
      IFEND;
      confirmed := message_type^ = iic$vt_query_attributes_confirm;
      IF confirmed THEN
        iip$vt_externalize_octets (query_response, attributes, number_of_octets);
      ELSE
        IF message_type^ = iic$vt_query_attributes_reject THEN
          osp$set_status_abnormal (ifc$interactive_facility_id, ife$unknown_attribute_key, '', status);
          NEXT attribute_number IN query_response;
          IF attribute_number = NIL THEN
            RETURN;
          IFEND;
          unknown_attribute_number := attribute_number^;
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (unknown_attribute_number), 10,
                FALSE, status)
        ELSE
          osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_incorrect_entry_on_queue, '', status);
        IFEND;
      IFEND;


    PROCEND externalize_query;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    connection := vtp_connection_id.connection;

    IF connection = NIL THEN
      iip$vt_validate_file_identifier (file_identifier, local_file_name, file_id_is_valid);
      IF NOT file_id_is_valid THEN
        STRINGREP (ordinal_char, char_length, file_identifier.ordinal);
        osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_id_not_valid, ordinal_char, status);
        RETURN;
      IFEND;
      osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_not_open, local_file_name, status);
    ELSE
      queue_entry := connection^.status.head;
      confirmed := FALSE;
      response_received := FALSE;
      IF queue_entry <> NIL THEN
        vtp_buffer := queue_entry^.vtp_buffer;
        RESET vtp_buffer;
        transfer_count := queue_entry^.q_header.transfer_length;
        NEXT query_response: [[REP transfer_count OF cell]] IN vtp_buffer;
        IF query_response = NIL THEN
          RETURN;
        IFEND;
        RESET query_response;
        externalize_query (query_response, confirmed, attributes, unknown_attribute_number, status);
        extra_status.normal := TRUE;
        remove_queue_entry (iic$vt_status, vtp_connection_id, extra_status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF NOT extra_status.normal THEN
          status := extra_status;
          RETURN;
        IFEND;
        response_received := TRUE;
      ELSE
        vtp_buffer := connection^.input_buffer;
        RESET vtp_buffer; {gkc}
        timeout. ON := TRUE;
        timeout.length := 12000;
        timeout.purge := FALSE;
        get_next_special_block (vtp_connection_id, file_identifier, iic$vt_status, vtp_buffer,
              iic$vt_max_transfer_length, wait, timeout, response_received, end_of_message, transfer_count,
              input, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF response_received THEN
          NEXT query_response: [[REP transfer_count OF cell]] IN vtp_buffer;
          IF query_response = NIL THEN
            RETURN;
          IFEND;
          RESET query_response;
          externalize_query (query_response, confirmed, attributes, unknown_attribute_number, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND iip$vt_get_query_response;
?? TITLE := '[XDCL] iip$vt_initialize_connection', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$vt_initialize_connection
    (VAR vtp_connection_id: iit$vtp_connection_id;
     VAR status: ost$status);

    VAR
      new_connection: [STATIC, oss$task_shared {namve workaround} ] ^iit$vt_connection;

    ALLOCATE new_connection IN osv$task_shared_heap^; { job_pageable }
    new_connection^.input.head := NIL;
    new_connection^.input.offset := 0;
    new_connection^.output.head := NIL;
    new_connection^.change.head := NIL;
    new_connection^.status.head := NIL;
    new_connection^.indications.head := NIL;

    ALLOCATE new_connection^.input_buffer: [[REP iic$vt_max_transfer_length OF cell]] IN
          osv$task_shared_heap^; { job_pageable }
    ALLOCATE new_connection^.output_buffer: [[REP iic$vt_max_output_mess_length OF cell]] IN
          osv$task_shared_heap^; { job_pageable }
          vtp_connection_id.connection := new_connection;

  PROCEND iip$vt_initialize_connection;
?? TITLE := '[XDCL] iip$vt_input', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$vt_input
    (    vtp_connection_id: iit$vtp_connection_id;
         file_identifier: amt$file_identifier;
         buffer_ptr: ^cell;
         buffer_length: nat$data_length;
         timeout: iit$vt_timeout;
     VAR message_received: boolean;
     VAR end_of_message: boolean;
     VAR transfer_count: nat$data_length;
     VAR input_information: iit$vt_input_information;
     VAR status: ost$status);

    VAR
      wait: ost$wait,
      offset: 0 .. iic$vt_max_transfer_length - 1,
      file_id_is_valid: boolean,
      vtp_buffer: ^iit$vt_ibs_buffer_hold,
      local_file_name: amt$local_file_name,
      message_type: ^iit$vt_message_types,
      input: ^iit$vt_input_information,
      connection: [STATIC, oss$task_shared {namve workaround} ] ^iit$vt_connection,
      vtp_buffer_data: ^cell,
      queue_entry: ^iit$vt_queue_entry;

    #KEYPOINT (osk$entry, 0, iik$vt_input);

    end_of_message := TRUE;
    connection := vtp_connection_id.connection;
    IF connection = NIL THEN
      iip$vt_validate_file_identifier (file_identifier, local_file_name, file_id_is_valid);
      IF NOT file_id_is_valid THEN
        STRINGREP (ordinal_char, char_length, file_identifier.ordinal);
        osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_id_not_valid,
              ordinal_char (1, char_length), status);
        #KEYPOINT (osk$exit, 0, iik$vt_input);
        RETURN;
      IFEND;
      osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_not_open, local_file_name, status);
    ELSE
      queue_entry := connection^.input.head;
      offset := connection^.input.offset;
      IF queue_entry <> NIL THEN
        message_received := TRUE;
        vtp_buffer := queue_entry^.vtp_buffer;
        RESET vtp_buffer;
        NEXT input IN vtp_buffer;
        input_information := input^;
        IF (queue_entry^.q_header.transfer_length - (iic$vt_header_length_input + offset)) >= 0 THEN
          transfer_count := queue_entry^.q_header.transfer_length - (iic$vt_header_length_input + offset);
        ELSE
          transfer_count := 0;
        IFEND;
        vtp_buffer_data := i#ptr (iic$vt_header_length_input + offset, ^vtp_buffer^);
        IF (buffer_length <= 0) OR (buffer_length >= transfer_count) OR (input_information.cancel) THEN
          IF transfer_count > 0 THEN
            IF transfer_count > buffer_length THEN
              transfer_count := buffer_length;
            IFEND;
            IF transfer_count > 0 THEN
              i#move (vtp_buffer_data, buffer_ptr, transfer_count);
            IFEND;
          IFEND;
          remove_queue_entry (iic$vt_input, vtp_connection_id, status);
        ELSE
          transfer_count := buffer_length;
          i#move (vtp_buffer_data, buffer_ptr, transfer_count);
          connection^.input.offset := offset + buffer_length;
          end_of_message := FALSE;
        IFEND;

      ELSE
        wait := osc$wait;
        get_next_special_block (vtp_connection_id, file_identifier, iic$vt_input, buffer_ptr, buffer_length,
              wait, timeout, message_received, end_of_message, transfer_count, input_information, status);
      IFEND;
    IFEND;

    #KEYPOINT (osk$exit, 0, iik$vt_input);

  PROCEND iip$vt_input;
?? TITLE := '[XDCL] iip$vt_open', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$vt_open
    (    lfn: amt$local_file_name;
     VAR file_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      access_selections: [STATIC, READ, oss$job_paged_literal] array [1 .. 1] of amt$access_selection :=
            [[amc$ring_attributes, [3, 3, 3]]];

{ Every task running in an xterm job needs to open a downline and
{ an upline message file.  The task sends output on the downline message file
{ to the xterm task.  The task receives input from the xterm task on
{ the upline message file.

    IF jmp$is_xterm_job () THEN
      IF NOT iiv$xt_xterm_downline.opened THEN
        iip$xt_open_downline_messages (iiv$xt_xterm_downline.file_identifier,
         iiv$xt_xterm_downline.segment_pointer, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        iiv$xt_xterm_downline.opened := TRUE;
      IFEND;

      IF NOT iiv$xt_xterm_upline.opened THEN
        iip$xt_open_upline_messages (iiv$xt_xterm_upline.file_identifier,
         iiv$xt_xterm_upline.segment_pointer, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        iiv$xt_xterm_upline.opened := TRUE;
      IFEND;
    IFEND;

    amp$open (lfn, amc$record, ^access_selections, file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND iip$vt_open;

?? TITLE := '[XDCL] iip$vt_output', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$vt_output
    (    vtp_connection_id: iit$vtp_connection_id;
         file_identifier: amt$file_identifier;
         data: nat$data_fragments;
         output_information: iit$vt_output_information;
         wait: ost$wait;
     VAR activity_status: ost$activity_status;
     VAR status: ost$status);

    VAR

      connection: [STATIC, oss$task_shared {namve workaround} ] ^iit$vt_connection,
      data_hold: ^array [1 .. * ] of nat$data_fragment,
      file_id_is_valid: boolean,
      i: 1 .. nac$max_data_fragment_count,
      local_file_name: amt$local_file_name,
      local_status: ost$status,
      output_information_hold: iit$vt_output_information,
      ready_index: integer,
      wait_complete: boolean,
      wait_list: array [1 .. 2] of ost$i_activity;

    connection := vtp_connection_id.connection;
    IF connection = NIL THEN
      iip$vt_validate_file_identifier (file_identifier, local_file_name, file_id_is_valid);
      IF NOT file_id_is_valid THEN
        STRINGREP (ordinal_char, char_length, file_identifier.ordinal);
        osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_id_not_valid,
              ordinal_char (1, char_length), status);
        RETURN;
      IFEND;
      osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_not_open, local_file_name, status);
    ELSE

      PUSH data_hold: [1 .. UPPERBOUND (data) + 1];
      output_information_hold := output_information;
      output_information_hold.message_type := iic$vt_output_data_message;
      data_hold^ [1].address := ^output_information_hold;
      data_hold^ [1].length := #SIZE (output_information_hold);
      FOR i := 1 TO UPPERBOUND (data) DO
        data_hold^ [i + 1] := data [i];
      FOREND;
      nap$se_send_data (file_identifier, data_hold^, TRUE {eom} , FALSE {not qualified} , wait,
            activity_status, status);
      IF (wait = osc$nowait) AND NOT activity_status.complete THEN
        wait_list [1].activity := osc$i_await_time;
        wait_list [1].milliseconds := iiv$terminal_timeout_limit;
        wait_list [2].activity := nac$i_await_activity_status;
        wait_list [2].activity_status := ^activity_status;
        osp$i_await_activity (wait_list, ready_index, wait_complete, local_status)
      IFEND;
    IFEND;


  PROCEND iip$vt_output;
?? TITLE := '[XDCL] iip$vt_query_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$vt_query_attributes
    (    vtp_connection_id: iit$vtp_connection_id;
         file_identifier: amt$file_identifier;
         attribute_kinds: iit$vt_attribute_kinds;
         wait: ost$wait;
     VAR activity_status: ost$activity_status;
     VAR status: ost$status);

    VAR
      buffer: ^SEQ ( * ),
      connection: [STATIC, oss$task_shared {namve workaround} ] ^iit$vt_connection,
      kinds_ptr: ^iit$vt_attribute_kinds,
      local_file_name: amt$local_file_name,
      query_attributes_header: [STATIC, READ, oss$job_paged_literal] iit$vt_message_types :=
        iic$vt_query_attributes,
      query_attributes_header_ptr: ^iit$vt_message_types,
      data: array [1 .. 1] of nat$data_fragment,
      i: integer,
      attribute_kind_ptr: ^iit$vt_attribute_kind;

    status.normal := TRUE;
    connection := vtp_connection_id.connection;
    IF connection = NIL THEN
      iip$vt_validate_file_identifier (file_identifier, local_file_name, file_id_is_valid);
      IF NOT file_id_is_valid THEN
        STRINGREP (ordinal_char, char_length, file_identifier.ordinal);
        osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_id_not_valid, ordinal_char, status);
        RETURN;
      IFEND;
      osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_not_open, local_file_name, status);
    ELSE
      data [1].length := #SIZE (query_attributes_header) + #SIZE (attribute_kinds);
      PUSH buffer: [[REP data [1].length OF cell]];
      data [1].address := buffer;
      RESET buffer;
      NEXT query_attributes_header_ptr IN buffer;
      query_attributes_header_ptr^ := query_attributes_header;
      NEXT kinds_ptr: [1 .. UPPERBOUND (attribute_kinds)] IN buffer;
      kinds_ptr^ := attribute_kinds;
      WHILE connection^.status.head <> NIL DO
        remove_queue_entry (iic$vt_status, vtp_connection_id, status);
      WHILEND;
      nap$se_send_data (file_identifier, data, TRUE {EOM} , FALSE {not qualified data} , wait,
            activity_status, status);
    IFEND;

  PROCEND iip$vt_query_attributes;
?? TITLE := '[XDCL] iip$vt_terminate_connection', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$vt_terminate_connection
    (VAR vtp_connection_id: iit$vtp_connection_id;
     VAR status: ost$status);


    IF vtp_connection_id.connection = NIL THEN
      osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_already_closed, '', status);
      RETURN;
    ELSE

      WHILE vtp_connection_id.connection^.input.head <> NIL DO
        remove_queue_entry (iic$vt_input, vtp_connection_id, status);
      WHILEND;

      WHILE vtp_connection_id.connection^.output.head <> NIL DO
        remove_queue_entry (iic$vt_output, vtp_connection_id, status);
      WHILEND;

      WHILE vtp_connection_id.connection^.change.head <> NIL DO
        remove_queue_entry (iic$vt_change, vtp_connection_id, status);
      WHILEND;

      WHILE vtp_connection_id.connection^.status.head <> NIL DO
        remove_queue_entry (iic$vt_status, vtp_connection_id, status);
      WHILEND;

      WHILE vtp_connection_id.connection^.indications.head <> NIL DO
        remove_queue_entry (iic$vt_indications, vtp_connection_id, status);
      WHILEND;

      IF vtp_connection_id.connection^.input_buffer = NIL THEN
        osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_input_buffer_not_found, '', status);
        return;
      ELSE
        FREE vtp_connection_id.connection^.input_buffer IN osv$task_shared_heap^; { job_pageable }
      IFEND;


      IF vtp_connection_id.connection^.output_buffer = NIL THEN
        osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_output_buffer_not_found, '', status);
        return;
      ELSE
        FREE vtp_connection_id.connection^.output_buffer IN osv$task_shared_heap^; { job_pageable }
      IFEND;
      FREE vtp_connection_id.connection IN osv$task_shared_heap^; { job_pageable }

    IFEND;


  PROCEND iip$vt_terminate_connection;
?? TITLE := ' debug_log', EJECT ??

  PROCEDURE debug_log
    (    str: string ( * ));

    VAR
      ignore_status: ost$status;

    ignore_status.normal := TRUE;
    pmp$log_ascii (str, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_program,
          ignore_status);

  PROCEND debug_log;
?? TITLE := ' debug_log', EJECT ??

  PROCEDURE debug_status
    (    status: ost$status);

    VAR
      ignore_status: ost$status,
      length_pointer: ^ost$status_message_line_size,
      line_count_pointer: ^ost$status_message_line_count,
      line_index: ost$status_message_line_count,
      message: ost$status_message,
      message_sequence: ^SEQ ( * ),
      text_pointer: ^string ( * );

    osp$format_message (status, osc$full_message_level, osc$max_status_message_line, message, ignore_status);
    message_sequence := ^message;
    RESET message_sequence;
    NEXT line_count_pointer IN message_sequence;
    FOR line_index := 1 TO line_count_pointer^ DO
      NEXT length_pointer IN message_sequence;
      NEXT text_pointer: [length_pointer^] IN message_sequence;
      debug_log (text_pointer^);
    FOREND;

  PROCEND debug_status;
?? TITLE := '  IIP$VT_EXTERNALIZE_OCTETS', EJECT ??

  PROCEDURE [XDCL] iip$vt_externalize_octets
    (    octets: ^SEQ ( * );
     VAR attributes: iit$vt_attributes;
     VAR number_of_attributes: 0 .. iic$vt_max_number_of_attributes);

  { Purpose: Initialize an iit$vt_attributes array from a sequence of octets.
  {
  { Design:   All octets pertaining to a particular attribute are used
  {           to construct an element in the iit$vt_attributes array.
  {           This array is returned to the caller as well as the number
  {           of elements in the array.  The procedure returns when it
  {           has seen the last octet and created an attribute for it.

    VAR
      octets_hold: ^SEQ ( * ),
      ptr: ^SEQ ( * ),
      j: 0 .. iic$vt_max_number_of_attributes,
      octet_found: boolean,
      attribute: iit$vt_attribute;

      {The following subranges of integer must exactly fill one byte.}

    VAR
      octet_length:  ^packed record
        multiple_attribute_length_octet: boolean,
        fill_0: 0..0EE(16),
        attribute_length_octet_number: 1 .. 2,
      recend,
      octet_number_mult: ^0 .. ifc$total_substitution_count * 2,
      number_of_octets: ^packed record
        multiple_octet: boolean,
        number: 0..127,
      recend,
      number: 0 .. 127;

    VAR
      octet_header: ^iit$vt_octet_header,
      attribute_kind: iit$vt_attribute_kind,
      char_string: ^string ( * ),
      int: ^0 .. 0ffff(16),
      bool: ^boolean;

    VAR
      input_output_mode: ^ift$input_output_mode,
      input_editing_mode: ^ift$input_editing_mode,
      transp_char_mode: ^ift$trans_character_mode,
      transp_protocol_mode: ^ift$trans_protocol_mode,
      transp_timeout_mode: ^ift$trans_timeout_mode,
      transp_len_mode: ^ift$trans_length_mode,
      atten_char_act: ^ift$attention_character_action,
      break_key_action: ^ift$break_key_action,
      input_block_size: ^ift$input_block_size,
      page_length: ^ift$page_length,
      page_width: ^ift$page_width,
      end_page_action: ^ift$end_page_action,
      carr_ret_delay: ^ift$carriage_return_delay,
      line_feed_delay: ^ift$line_feed_delay,
      form_feed_delay: ^ift$form_feed_delay,
      end_line_position: ^ift$end_line_positioning,
      end_partial_position: ^ift$end_partial_positioning,
      code_set: ^ift$code_set,
      code_set_name: ^ift$code_set_name,
      control_code_replacement: ^ift$control_code_replacement,
      control_code_replacement_value: ^array [1 .. *]
        OF ift$control_code_rep_char,
      parity_type: ^ift$parity,
      single_octet_ptr: ^0 .. 0ff(16),  { For NEXTs of multiple-byte types but single-byte values. }
      status_action: ^ift$status_action;


    number_of_attributes := 0;
    octets_hold := octets;

  /parse_responses/
    FOR j := 1 TO UPPERBOUND (attributes) DO
      NEXT octet_header IN octets_hold;
      IF octet_header = NIL THEN
        octet_found := FALSE;
        EXIT /parse_responses/;
      ELSE
        octet_found := TRUE;
      IFEND;
      IF octet_header^.multiple_octet THEN
        NEXT number_of_octets IN octets_hold;
        IF number_of_octets = NIL THEN
          octet_found := FALSE;
          EXIT /parse_responses/;
        IFEND;
        IF number_of_octets^.multiple_octet = FALSE THEN
          number := number_of_octets^.number;
        ELSE
          RESET octets_hold TO number_of_octets;
          NEXT octet_length IN octets_hold;
          NEXT octet_number_mult IN octets_hold;
          number := octet_number_mult^;
        IFEND;
      ELSE
        number := 1;
      IFEND;
      attribute.kind := octet_header^.kind;
      CASE octet_header^.kind OF

      = iic$vt_input_output_mode =
        NEXT input_output_mode IN octets_hold;
        IF input_output_mode = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.input_output_mode := input_output_mode^;

      = iic$vt_input_editing_mode =
        NEXT input_editing_mode IN octets_hold;
        IF input_editing_mode = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.input_editing_mode := input_editing_mode^;

      = iic$vt_trans_character_mode =
        NEXT transp_char_mode IN octets_hold;
        IF transp_char_mode = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.trans_character_mode := transp_char_mode^;

      = iic$vt_trans_forward_character =
        IF number > 0 THEN
          NEXT char_string: [number] IN octets_hold;
          IF char_string = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.trans_forward_character.value := char_string^;
        IFEND;
        attribute.trans_forward_character.size := number;

      = iic$vt_trans_term_character =
        IF number > 0 THEN
          NEXT char_string: [number] IN octets_hold;
          IF char_string = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.trans_terminate_character.value := char_string^;
        IFEND;
        attribute.trans_terminate_character.size := number;

      = iic$vt_trans_timeout_mode =
        NEXT transp_timeout_mode IN octets_hold;
        IF transp_timeout_mode = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.trans_timeout_mode := transp_timeout_mode^;

      = iic$vt_trans_length_mode =
        NEXT transp_len_mode IN octets_hold;
        IF transp_len_mode = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.trans_length_mode := transp_len_mode^;

      = iic$vt_trans_message_length =
        IF number > 1 THEN
          NEXT int IN octets_hold;
          IF int = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.trans_message_length := int^;
        ELSEIF number = 1 THEN
          NEXT single_octet_ptr IN octets_hold;
          IF single_octet_ptr = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.trans_message_length := single_octet_ptr^;
        IFEND;

      = iic$vt_partial_char_forwarding =
        NEXT bool IN octets_hold;
        IF bool = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.partial_char_forwarding := bool^;

      = iic$vt_attention_char_action =
        NEXT atten_char_act IN octets_hold;
        IF atten_char_act = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.attention_character_action := atten_char_act^;

      = iic$vt_break_key_action =
        NEXT break_key_action IN octets_hold;
        IF break_key_action = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.break_key_action := break_key_action^;

      = iic$vt_input_block_size =
        IF number > 1 THEN
          NEXT input_block_size IN octets_hold;
          IF input_block_size = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.input_block_size := input_block_size^;
        ELSEIF number = 1 THEN
          NEXT single_octet_ptr IN octets_hold;
          IF single_octet_ptr = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.input_block_size := single_octet_ptr^;
        IFEND;

      = iic$vt_store_nuls_dels =
        NEXT bool IN octets_hold;
        IF bool = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.store_nuls_dels := bool^;

      = iic$vt_store_backspace_char =
        NEXT bool IN octets_hold;
        IF bool = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.store_backspace_character := bool^;

      = iic$vt_network_command_char =
        IF number = 0 THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        NEXT char_string: [number] IN octets_hold;
        IF char_string = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.network_command_character := char_string^ (1);

      = iic$vt_cancel_line_character =
        IF number = 0 THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        NEXT char_string: [number] IN octets_hold;
        IF char_string = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.cancel_line_character := char_string^ (1);

      = iic$vt_end_line_character =
        IF number = 0 THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        NEXT char_string: [number] IN octets_hold;
        IF char_string = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.end_line_character := char_string^ (1);

      = iic$vt_begin_line_character =
        IF number = 0 THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        NEXT char_string: [number] IN octets_hold;
        IF char_string = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.begin_line_character := char_string^ (1);

      = iic$vt_backspace_character =
        IF number = 0 THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        NEXT char_string: [number] IN octets_hold;
        IF char_string = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.backspace_character := char_string^ (1);

      = iic$vt_end_partial_character =
        IF number = 0 THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        NEXT char_string: [number] IN octets_hold;
        IF char_string = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.end_partial_character := char_string^ (1);

      = iic$vt_attention_character =
        IF number = 0 THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        NEXT char_string: [number] IN octets_hold;
        IF char_string = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.attention_character := char_string^ (1);

      = iic$vt_page_length =
        NEXT page_length IN octets_hold;
        IF page_length = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.page_length := page_length^;

      = iic$vt_page_width =
        NEXT page_width IN octets_hold;
        IF page_width = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.page_width := page_width^;

      = iic$vt_hold_page =
        NEXT bool IN octets_hold;
        IF bool = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.hold_page := bool^;

      = iic$vt_hold_page_over =
        NEXT bool IN octets_hold;
        IF bool = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.hold_page_over := bool^;

      = iic$vt_fold_line =
        NEXT bool IN octets_hold;
        IF bool = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.fold_line := bool^;

      = iic$vt_end_output_sequence =
        IF number > 0 THEN
          NEXT char_string: [number] IN octets_hold;
          IF char_string = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.end_output_sequence.value := char_string^;
        IFEND;
        attribute.end_output_sequence.size := number;

      = iic$vt_carriage_return_sequence =
        IF number > 0 THEN
          NEXT char_string: [number] IN octets_hold;
          IF char_string = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.carriage_return_sequence.value := char_string^;
        IFEND;
        attribute.carriage_return_sequence.size := number;

      = iic$vt_line_feed_sequence =
        IF number > 0 THEN
          NEXT char_string: [number] IN octets_hold;
          IF char_string = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.line_feed_sequence.value := char_string^;
        IFEND;
        attribute.line_feed_sequence.size := number;

      = iic$vt_form_feed_sequence =
        IF number > 0 THEN
          NEXT char_string: [number] IN octets_hold;
          IF char_string = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.form_feed_sequence.value := char_string^;
        IFEND;
        attribute.form_feed_sequence.size := number;

      = iic$vt_end_page_action =
        NEXT end_page_action IN octets_hold;
        IF end_page_action = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.end_page_action := end_page_action^;

      = iic$vt_carriage_return_delay =
        IF number > 1 THEN
          NEXT carr_ret_delay IN octets_hold;
          IF carr_ret_delay = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.carriage_return_delay := carr_ret_delay^;
        ELSEIF number = 1 THEN
          NEXT single_octet_ptr IN octets_hold;
          IF single_octet_ptr = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.carriage_return_delay := single_octet_ptr^;
        IFEND;

      = iic$vt_line_feed_delay =
        IF number > 1 THEN
          NEXT line_feed_delay IN octets_hold;
          IF line_feed_delay = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.line_feed_delay := line_feed_delay^;
        ELSEIF number = 1 THEN
          NEXT single_octet_ptr IN octets_hold;
          IF single_octet_ptr = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.line_feed_delay := single_octet_ptr^;
        IFEND;

      = iic$vt_form_feed_delay =
        IF number > 1 THEN
          NEXT form_feed_delay IN octets_hold;
          IF form_feed_delay = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.form_feed_delay := form_feed_delay^;
        ELSEIF number = 1 THEN
          NEXT single_octet_ptr IN octets_hold;
          IF single_octet_ptr = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.form_feed_delay := single_octet_ptr^;
        IFEND;

      = iic$vt_end_line_positioning =
        NEXT end_line_position IN octets_hold;
        IF end_line_position = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.end_line_positioning := end_line_position^;

      = iic$vt_end_partial_positioning =
        NEXT end_partial_position IN octets_hold;
        IF end_partial_position = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.end_partial_positioning := end_partial_position^;

      = iic$vt_character_flow_control =
        NEXT bool IN octets_hold;
        IF bool = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.character_flow_control := bool^;

      = iic$vt_function_key_class =
        IF number > 0 THEN
          NEXT char_string: [number] IN octets_hold;
          IF char_string = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.function_key_class.value := char_string^;
        IFEND;
        IF number > 0 THEN
          attribute.function_key_class.size := number;
        ELSE
          attribute.function_key_class.size := 1;
          attribute.function_key_class.value := ' ';
        IFEND;

      = iic$vt_terminal_model =
        IF number > 0 THEN
          NEXT char_string: [number] IN octets_hold;
          IF char_string = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.terminal_model.value := char_string^;
        IFEND;
        IF number > 0 THEN
          attribute.terminal_model.size := number;
        ELSE
          attribute.terminal_model.size := 1;
          attribute.terminal_model.value := ' ';
        IFEND;

      = iic$vt_code_set =
        IF number = 1 THEN
          NEXT code_set IN octets_hold;
          IF code_set = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.code_set := code_set^;
        ELSE

          NEXT code_set IN octets_hold;
          NEXT char_string: [number-1] IN octets_hold;
          IF char_string = NIL THEN
            octet_found := FALSE;
            RETURN;
          IFEND;
          attribute.code_set_name.size := number;
          attribute.code_set_name.value := char_string^;
          attribute.kind := iic$vt_code_set_name;
        IFEND;

      = iic$vt_parity =
        NEXT parity_type IN octets_hold;
        IF parity_type = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.parity := parity_type^;

      = iic$vt_echoplex =
        NEXT bool IN octets_hold;
        IF bool = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.echoplex := bool^;

      = iic$vt_status_action =
        NEXT status_action IN octets_hold;
        IF status_action = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.status_action := status_action^;

      = iic$vt_trans_protocol_mode =
        NEXT transp_protocol_mode IN octets_hold;
        IF transp_protocol_mode = NIL THEN
          octet_found := FALSE;
          RETURN;
        IFEND;
        attribute.trans_protocol_mode := transp_protocol_mode^;

      = iic$vt_control_code_replacement =
        attribute.control_code_replacement.total_substitution_count :=
          number DIV 2;
        IF number DIV 2 <> 0 THEN
          NEXT control_code_replacement_value:
            [1..attribute.control_code_replacement.total_substitution_count] IN
              octets_hold;
          attribute.control_code_replacement.value :=
            control_code_replacement_value^;
        IFEND;
      ELSE
        octet_found := FALSE;
      CASEND;

      IF octet_found THEN
        number_of_attributes := number_of_attributes + 1;
        attributes [j] := attribute;
      ELSE
        EXIT /parse_responses/;
      IFEND;
    FOREND /parse_responses/;


  PROCEND iip$vt_externalize_octets;
?? TITLE := 'GET_NEXT_SPECIAL_BLOCK', EJECT ??

  PROCEDURE get_next_special_block
    (    vtp_connection_id: iit$vtp_connection_id;
         input_file_identifier: amt$file_identifier;
         special_block: iit$vt_queue_types;
         buffer_ptr: ^cell;
         buffer_length: nat$data_length;
         wait: ost$wait;
         timeout: iit$vt_timeout;
     VAR message_received: boolean;
     VAR end_of_message: boolean;
     VAR transfer_count: nat$data_length;
     VAR input: iit$vt_input_information;
     VAR status: ost$status);

    VAR

      empty_header: [STATIC, READ, oss$job_paged_literal] iit$vt_input_information :=
        [0, iic$vt_input_data_message, 0, 0, iic$vt_character, FALSE, FALSE, TRUE, FALSE, 'a'],
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      length_to_queue: nat$data_length,
      local_file_name: amt$local_file_name,
      activity_status: [STATIC, oss$task_shared {NAMVE workaround} ] ost$activity_status,
      peer_operation: [STATIC, oss$task_shared {NAMVE workaround} ] nat$se_peer_operation,
      st_open_file_dsc_pointer: ^iit$st_open_file_description,
      message_type: iit$vt_message_types,
      message_type_ptr: ^iit$vt_message_types,
      vtp_buffer: ^SEQ ( * ),
      connection: [STATIC, oss$task_shared {namve workaround} ] ^iit$vt_connection,
      timeout_data: SEQ (REP 1 of cell),
      data: [STATIC, oss$task_shared {NAMVE workaround} ] array [1 .. 2] of nat$data_fragment,
      data1: [STATIC, oss$task_shared {NAMVE workaround} ] array [1 .. 1] of nat$data_fragment,
      file_identifier: amt$file_identifier,
      input_header_data: iit$vt_input_information,
      input_header: ^iit$vt_input_information,
      wait_time: integer,
      ibs_buffer: [STATIC, oss$task_shared] iit$vt_ibs_buffer,
      status_save: ost$status,
      text: [STATIC, READ, oss$job_paged_literal] string(35) :=
         ' TERMINAL TIMEOUT IN 30 SECONDS.' CAT $CHAR(7) CAT
         $CHAR(13) CAT $CHAR(10),
      move_ptr: ^cell,
      move_length: 0 .. iic$vt_max_transfer_length,
      timeout_message: string (80),
      str: ost$string,
      user_supplied_name: jmt$user_supplied_name,
      system_supplied_name: jmt$system_supplied_name,
      put_byte_address: ^amt$file_byte_address,
      warning_displayed: boolean;

?? OLDTITLE, EJECT ??

    #KEYPOINT (osk$entry, 0, iik$vt_get_next_special_block);

    status.normal := TRUE;
    message_received := FALSE;
    transfer_count := 0;
    warning_displayed := FALSE;

    REPEAT
      IF timeout. ON THEN
        wait_time := iiv$terminal_timeout_limit_left;
        IF timeout.length <= wait_time THEN
          wait_time := timeout.length;
        IFEND;

        nap$await_data_available (input_file_identifier, wait_time,
          wait_time, status);
        IF timeout.length <= iiv$terminal_timeout_limit_left THEN
          IF NOT status.normal THEN
            IF (status.condition = nae$no_event) OR (status.condition = nae$no_data_available) OR
                  (status.condition = nae$data_transfer_timeout) THEN
              iiv$terminal_timeout_limit_left := iiv$terminal_timeout_limit_left -
                timeout.length;
              status_save := status;
              IF timeout.length <> 0 THEN
                IF timeout.purge THEN
                  nap$se_synchronize (input_file_identifier,
                    nac$se_synchronize_all_data, timeout_data, status);
                  IF NOT status.normal THEN
                    IF status.condition = nae$se_synch_confirm_pending THEN
                      status.normal := TRUE;
                    IFEND;
                    #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
                    RETURN;
                  ELSE
                    status := status_save;
                  IFEND;
                IFEND; { of timeout.purge }
              IFEND; { of timeout.length nonzero }
            IFEND; { of timeout-related status }
            #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
            RETURN; { for any abnormal status }
          IFEND; { of abnormal status }

        ELSE { timeout.length > iiv$terminal_timeout_limit left }
          IF NOT status.normal THEN
            IF (status.condition = nae$no_event) OR (status.condition = nae$no_data_available) OR
                  (status.condition = nae$data_transfer_timeout) THEN
              IF NOT warning_displayed THEN
              clp$get_system_file_id (clc$job_output, file_identifier, status);
              IF NOT status.normal THEN
                #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
                RETURN;
              IFEND;
*copy bai$validate_file_identifier
*copy iii$fetch_st_open_file_desc_ptr
              IF NOT status.normal THEN
                #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
                RETURN;
              IFEND;

              warning_displayed := TRUE;
              iip$st_put (file_identifier, st_open_file_dsc_pointer,
              amc$put_next_req, ^text, STRLENGTH (text), put_byte_address,
                amc$terminate, status);
              IF NOT status.normal THEN
                #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
                RETURN;
              IFEND;
              amp$flush (file_identifier, osc$wait, status);
              IF NOT status.normal THEN
                #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
                RETURN;
              IFEND;
              IFEND; {of NOT warning displayed}
              nap$await_data_available (input_file_identifier, 30000,
                30000, status);

              IF NOT status.normal THEN
                IF (status.condition = nae$no_event) OR (status.condition = nae$no_data_available) OR
                  (status.condition = nae$data_transfer_timeout) THEN
                  status_save := status;

{ Display the time and job name in the terminal timeout message.

                  clp$get_time_string (str, status);
                  timeout_message (1, 1) := ' ';
                  timeout_message (2, str.size) := str.value (1, str.size);
                  timeout_message (str.size + 2, 24) := ' TERMINAL TIMEOUT.  JOB ';
                  pmp$get_job_names (user_supplied_name, system_supplied_name, status);
                  timeout_message (str.size + 26, 19) := system_supplied_name;
                  timeout_message (str.size + 46, 12) :=
                    ' DETACHED.' CAT $char(13) CAT $char (10);
                  iip$st_put (file_identifier, st_open_file_dsc_pointer,
                    amc$put_next_req, #LOC (timeout_message), str.size + 57,
                   put_byte_address, amc$terminate, status);
                  amp$flush (file_identifier, osc$wait, status);
                  file_identifier := input_file_identifier;
*copy bai$validate_file_identifier
                  nap$se_clear_request(file_instance^.local_file_name,status);
                IFEND; { of timeout-related status }
                #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
                RETURN;
              IFEND;
            IFEND;  { of check for timeout status }
          IFEND;  { of NOT status.normal }
        IFEND; { of timeout.length vs iiv$terminal_timeout_limit_left }
      ELSE { NOT timeout.on }

        wait_time := iiv$terminal_timeout_limit;
        nap$await_data_available (input_file_identifier,
          wait_time, wait_time, status);
        IF NOT status.normal THEN
          IF (status.condition = nae$no_event) OR (status.condition = nae$no_data_available) OR
            (status.condition = nae$data_transfer_timeout) THEN
            IF NOT warning_displayed THEN
            clp$get_system_file_id (clc$job_output, file_identifier, status);
            IF NOT status.normal THEN
              #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
              RETURN;
            IFEND;
*copy bai$validate_file_identifier
*copy iii$fetch_st_open_file_desc_ptr
            IF NOT status.normal THEN
              #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
              RETURN;
            IFEND;

            warning_displayed := TRUE;
            iip$st_put (file_identifier, st_open_file_dsc_pointer,
              amc$put_next_req, ^text, STRLENGTH (text), put_byte_address,
              amc$terminate, status);
            IF NOT status.normal THEN
              #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
              RETURN;
            IFEND;
            amp$flush (file_identifier, osc$wait, status);
            IF NOT status.normal THEN
              #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
              RETURN;
            IFEND;
            IFEND; {warning displayed}
            nap$await_data_available (input_file_identifier, 30000,
              30000, status);
            IF NOT status.normal THEN
              IF (status.condition = nae$no_event) OR (status.condition = nae$no_data_available) OR
                (status.condition = nae$data_transfer_timeout) THEN
                status_save := status;

{ Display the time and job name in the terminal timeout message.

                clp$get_time_string (str, status);
                timeout_message (1, 1) := ' ';
                timeout_message (2, str.size) := str.value (1, str.size);
                timeout_message (str.size + 2, 24) := ' TERMINAL TIMEOUT.  JOB ';
                pmp$get_job_names (user_supplied_name, system_supplied_name, status);
                timeout_message (str.size + 26, 19) := system_supplied_name;
                timeout_message (str.size + 46, 12) :=
                  ' DETACHED.' CAT $char(13) CAT $char (10);
                iip$st_put (file_identifier, st_open_file_dsc_pointer,
                  amc$put_next_req, #LOC (timeout_message), str.size + 57,
                  put_byte_address, amc$terminate, status);
                amp$flush (file_identifier, osc$wait, status);
                file_identifier := input_file_identifier;
*copy bai$validate_file_identifier
                nap$se_clear_request(file_instance^.local_file_name,status);
              IFEND; { of timeout-related status }
              #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
              RETURN;
            IFEND; { of abnormal status }
          IFEND; { of timeout-related status }
          #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
          RETURN; { for any abnormal status }
        IFEND; { of abnormal status}
      IFEND; { of timeout.on }

{ Receive block and return it or queue it.}
      connection := vtp_connection_id.connection;
      IF connection = NIL THEN
        iip$vt_validate_file_identifier (input_file_identifier,
          local_file_name, file_id_is_valid);
        IF NOT file_id_is_valid THEN
          STRINGREP (ordinal_char, char_length, input_file_identifier.ordinal);
          osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_id_not_valid, ordinal_char,
                status);
          #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
          RETURN;
        IFEND;
        osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_not_open, local_file_name, status);
        #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
        RETURN;
      IFEND;
      IF special_block = iic$vt_input THEN
        connection^.data := ^data;
        connection^.data^ [1].address := ^input;
        connection^.data^ [1].length := iic$vt_header_length_input;
        connection^.data^ [2].address := buffer_ptr;
        connection^.data^ [2].length := buffer_length;
        nap$se_receive_data (input_file_identifier,
          connection^.data^, wait, peer_operation, activity_status,
              status);
        IF (status.normal) AND (activity_status.complete) AND (NOT activity_status.status.normal) THEN
          status := activity_status.status;
        IFEND;
        IF NOT status.normal THEN
          #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
          RETURN;
        IFEND;
        CASE peer_operation.kind OF

        = nac$se_interrupt =
          osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_unsupported_event, '', status);
          #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
          RETURN;

        = nac$se_synchronize =
          IF peer_operation.direction = nac$se_synchronize_receive_data THEN
            transfer_count := 0;
            input := empty_header;
            message_received := TRUE;
          ELSE
            nap$se_synchronize_confirm (input_file_identifier, status);
            IF NOT status.normal THEN
              #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
              RETURN;
            IFEND;
          IFEND;

        = nac$se_synchronize_confirm =
          ; { add code someday if there is  anything to do }

        = nac$se_send_data =
          iiv$terminal_timeout_limit_left := iiv$terminal_timeout_limit;
          IF NOT peer_operation.end_of_message THEN
            IF queue_type_from_message [input.message_type] = iic$vt_input THEN
              message_received := TRUE;
              transfer_count := peer_operation.data_length - iic$vt_header_length_input;
              end_of_message := false;
              ibs_buffer := connection^.input_buffer;
              reset ibs_buffer;
              move_ptr := ibs_buffer;
              i#move (^input, move_ptr, iic$vt_header_length_input);
              length_to_queue := iic$vt_header_length_input;

              connection^.data := ^data1;
              connection^.data^ [1].address := i#ptr (iic$vt_header_length_input, move_ptr);
              connection^.data^ [1].length := iic$vt_max_transfer_length - iic$vt_header_length_input;
              nap$se_receive_data (input_file_identifier,
               connection^.data^, wait, peer_operation, activity_status,
                    status);
              IF (status.normal) AND (activity_status.complete) AND (NOT activity_status.status.normal) THEN
                status := activity_status.status;
              IFEND;
              IF NOT status.normal THEN
                #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
                RETURN;
              IFEND;

              IF NOT peer_operation.end_of_message THEN
                osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_no_eom_found, ' ', status);
                #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
                RETURN;
              IFEND;

              CASE peer_operation.kind OF

              = nac$se_interrupt =
                osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_unsupported_event, '', status);
                #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
                RETURN;

              = nac$se_synchronize =
                IF peer_operation.direction = nac$se_synchronize_receive_data THEN
                  transfer_count := 0;
                  input := empty_header;
                  message_received := TRUE;
                ELSE
                  nap$se_synchronize_confirm (input_file_identifier, status);
                  IF NOT status.normal THEN
                    #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
                    RETURN;
                  IFEND;
                IFEND;

              = nac$se_synchronize_confirm =
                ; { add code someday if there is  anything to do }

              = nac$se_send_data =
                length_to_queue := length_to_queue + peer_operation.data_length;
                queue_message (ibs_buffer, vtp_connection_id, input.message_type, length_to_queue, status);
                #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
                RETURN;

              CASEND; { of peer_operation.kind, outer layer }

            ELSE { not input data }

              ibs_buffer := connection^.input_buffer;
              reset ibs_buffer;
              move_ptr := ibs_buffer;
              i#move (^input, move_ptr, iic$vt_header_length_input);
              move_ptr := i#ptr (iic$vt_header_length_input, move_ptr);
              length_to_queue := iic$vt_header_length_input;
              IF peer_operation.data_length > iic$vt_header_length_input THEN
                move_length := peer_operation.data_length - iic$vt_header_length_input;
                i#move (buffer_ptr, move_ptr, move_length);
                move_ptr := i#ptr (move_length, move_ptr);
                length_to_queue := length_to_queue + move_length;
              IFEND;

              connection^.data := ^data1;
              connection^.data^ [1].address := move_ptr;
              connection^.data^ [1].length := iic$vt_max_transfer_length - length_to_queue;

              nap$se_receive_data (input_file_identifier,
                connection^.data^, wait, peer_operation, activity_status,
                    status);
              IF (status.normal) AND (activity_status.complete) AND (NOT activity_status.status.normal) THEN
                status := activity_status.status;
              IFEND;
              IF NOT status.normal THEN
                #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
                RETURN;
              IFEND;

              IF NOT peer_operation.end_of_message THEN
                osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_no_eom_found, ' ', status);
                #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
                RETURN;
              IFEND;


              CASE peer_operation.kind OF

              = nac$se_interrupt =
                osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_unsupported_event, '', status);
                #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
                RETURN;

              = nac$se_synchronize =
                IF peer_operation.direction = nac$se_synchronize_receive_data THEN
                  transfer_count := 0;
                  input := empty_header;
                  message_received := TRUE;
                ELSE
                  nap$se_synchronize_confirm (input_file_identifier, status);
                  IF NOT status.normal THEN
                  #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
                    RETURN;
                  IFEND;
                IFEND;

              = nac$se_synchronize_confirm =
                ; { add code someday if there is  anything to do }

              = nac$se_send_data =

                length_to_queue := length_to_queue + peer_operation.data_length;
                queue_message (ibs_buffer, vtp_connection_id, input.message_type, length_to_queue, status);


              CASEND; { of peer_operation.kind, outer layer }

            IFEND; { not input data}


          ELSE {eom encountered}
            end_of_message := peer_operation.end_of_message;
            IF queue_type_from_message [input.message_type] = iic$vt_input THEN
              message_received := TRUE;
              transfer_count := peer_operation.data_length - iic$vt_header_length_input;
              #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
              RETURN;
            ELSE
              ibs_buffer := connection^.input_buffer;
              reset ibs_buffer;
              move_ptr := ibs_buffer;
              i#move (^input, move_ptr, iic$vt_header_length_input);
              IF peer_operation.data_length > iic$vt_header_length_input THEN
                move_length := peer_operation.data_length - iic$vt_header_length_input;
                move_ptr := i#ptr (iic$vt_header_length_input, move_ptr);
                i#move (buffer_ptr, move_ptr, move_length);
              IFEND;
              queue_message (ibs_buffer, vtp_connection_id, input.message_type, peer_operation.data_length,
                    status);
            IFEND;
          IFEND; {eom encountered }
        ELSE
        CASEND; { of peer_operation.kind, outer layer }

      ELSE {The special block is not of type INPUT.}
        IF buffer_length <> iic$vt_max_transfer_length THEN
          osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_incorrect_buffer_size, '', status);
          #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
          RETURN;
        IFEND;
        connection^.data := ^data1;
        connection^.data^ [1].address := buffer_ptr;
        connection^.data^ [1].length := buffer_length;
        nap$se_receive_data (input_file_identifier,
          connection^.data^, wait, peer_operation, activity_status,
              status);
        IF (status.normal) AND (activity_status.complete) AND (NOT activity_status.status.normal) THEN
          status := activity_status.status;
        IFEND;
        IF NOT status.normal THEN
          #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
          RETURN;
        IFEND;
        CASE peer_operation.kind OF

        = nac$se_interrupt =
          osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_unsupported_event, '', status);
          #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
          RETURN;

        = nac$se_synchronize =
          IF peer_operation.direction = nac$se_synchronize_receive_data THEN
            transfer_count := 0;
            input := empty_header;
            message_received := TRUE;
          ELSE
            nap$se_synchronize_confirm (input_file_identifier, status);
            IF NOT status.normal THEN
              #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
              RETURN;
            IFEND;
          IFEND;

        = nac$se_synchronize_confirm =
          { add code if there is anything to be done here }

        = nac$se_send_data =
          IF NOT peer_operation.end_of_message THEN
            osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_no_eom_found, ' ', status);
            #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
            RETURN;
          IFEND;
          message_type_ptr := ^message_type;
          i#move (buffer_ptr, message_type_ptr, 1);
          IF queue_type_from_message [message_type_ptr^] = special_block THEN
            message_received := TRUE;
            transfer_count := peer_operation.data_length;
            #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
            RETURN;
          ELSEIF queue_type_from_message [message_type_ptr^] = iic$vt_input THEN
            queue_message (buffer_ptr, vtp_connection_id, message_type_ptr^, peer_operation.data_length,
                  status);
            IF NOT status.normal THEN
              #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
              RETURN;
            IFEND;
          ELSE
            queue_message (buffer_ptr, vtp_connection_id, message_type_ptr^, peer_operation.data_length,
                  status);
            IF NOT status.normal THEN
              #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);
              RETURN;
            IFEND;
          IFEND;
        ELSE
        CASEND; { of peer_operation.kind }
      IFEND; { of IF/ELSE for special_block  = iic$vt_input }

    UNTIL message_received;

    #KEYPOINT (osk$exit, 0, iik$vt_get_next_special_block);

  PROCEND get_next_special_block;
?? TITLE := 'QUEUE_MESSAGE', EJECT ??

  PROCEDURE queue_message
    (    entry_ptr: ^cell;
         vtp_connection_id: iit$vtp_connection_id;
         message_type: iit$vt_message_types;
     VAR transfer_count: nat$data_length;
     VAR status: ost$status);

    VAR

      queue_type: iit$vt_queue_types,
      connection: [STATIC, oss$task_shared {namve workaround} ] ^iit$vt_connection,
      queue_entry: ^iit$vt_queue_entry,
      ptr: ^iit$vt_queue_entry;

?? NEWTITLE := '  FIND_TAIL', EJECT ??

    PROCEDURE [INLINE] find_tail
      (VAR queue_entry_ptr {input/output} : ^iit$vt_queue_entry);

      WHILE queue_entry_ptr^.q_header.next_entry <> NIL DO
        queue_entry_ptr := queue_entry_ptr^.q_header.next_entry;
      WHILEND;
    PROCEND find_tail;
?? OLDTITLE, EJECT ??

    IF NOT syv$job_initialization_complete THEN
      {Must not queue data if job not yet cloned
      status.normal := TRUE;
      RETURN;
    IFEND;

    IF $INTEGER (message_type) >= iic$vt_message_type_max THEN
      osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_unexpected_message, '', status);
      RETURN;
    IFEND;

    ptr := NIL;
    connection := vtp_connection_id.connection;
    IF connection = NIL THEN
      osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_not_open, '', status);
    ELSE
      queue_type := queue_type_from_message [message_type];
      ALLOCATE queue_entry IN osv$task_shared_heap^; { job_pageable }
      ALLOCATE queue_entry^.vtp_buffer IN osv$task_shared_heap^; { job_pageable }
      queue_entry^.q_header.transfer_length := transfer_count;
      queue_entry^.q_header.next_entry := NIL;

      i#move (entry_ptr, queue_entry^.vtp_buffer, transfer_count);
      CASE queue_type OF

      = iic$vt_input =
        ptr := connection^.input.head;

      = iic$vt_output =
        ptr := connection^.output.head;

      = iic$vt_change =
        ptr := connection^.change.head;

      = iic$vt_status =
        ptr := connection^.status.head;

      = iic$vt_indications =
        ptr := connection^.indications.head;

      ELSE
      CASEND;
      IF ptr = NIL THEN
        CASE queue_type OF

        = iic$vt_input =
          connection^.input.head := queue_entry;

        = iic$vt_output =
          connection^.output.head := queue_entry;

        = iic$vt_change =
          connection^.change.head := queue_entry;

        = iic$vt_status =
          connection^.status.head := queue_entry;

        = iic$vt_indications =
          connection^.indications.head := queue_entry;
        ELSE
        CASEND;
      ELSE
        find_tail (ptr);
        ptr^.q_header.next_entry := queue_entry;
      IFEND;
    IFEND;

  PROCEND queue_message;

?? TITLE := 'REMOVE_QUEUE_ENTRY', EJECT ??

  PROCEDURE remove_queue_entry
    (    queue_type: iit$vt_queue_types;
         vtp_connection_id: iit$vtp_connection_id;
     VAR status: ost$status);

    VAR
      connection: [STATIC, oss$task_shared {namve workaround} ] ^iit$vt_connection,
      queue_entry: ^iit$vt_queue_entry;

    connection := vtp_connection_id.connection;
    IF connection = NIL THEN
      osp$set_status_abnormal (ifc$interactive_facility_id, ife$vt_file_not_open, '', status);
      RETURN;
    ELSE

      CASE queue_type OF

      = iic$vt_input =
        queue_entry := connection^.input.head;
        connection^.input.head := queue_entry^.q_header.next_entry;

      = iic$vt_output =
        queue_entry := connection^.output.head;
        connection^.output.head := queue_entry^.q_header.next_entry;

      = iic$vt_change =
        queue_entry := connection^.change.head;
        connection^.change.head := queue_entry^.q_header.next_entry;

      = iic$vt_status =
        queue_entry := connection^.status.head;
        connection^.status.head := queue_entry^.q_header.next_entry;

      = iic$vt_indications =
        queue_entry := connection^.indications.head;
        connection^.indications.head := queue_entry^.q_header.next_entry;

      ELSE
      CASEND;
      FREE queue_entry^.vtp_buffer IN osv$task_shared_heap^; { job_pageable }
      FREE queue_entry IN osv$task_shared_heap^; { job_pageable }
    IFEND;
    connection^.input.offset := 0;


  PROCEND remove_queue_entry;

MODEND iim$vtp_interface;
*DECK DECK=IIM$VTP_TERMINAL_INTERFACE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'VTP Terminal Interface' ??
MODULE iim$vtp_terminal_interface;

{ PURPOSE:
{
{ This module provides procedures IIP$VTP_OPEN_NETWORK, IIP$VTP_GET_NEXT, and
{ IIP$VTP_PUT_NEXT.  These are alternatives to FSP$OPEN_FILE, AMP$GET_xxx, and
{ AMP$PUT_xxx.  There are two primary effects of using this interface:
{ some overhead is avoided by going as directly as possible to NAM/VE without
{ using the Interactive FAP, and the application gets visibility to the
{ VTP (virtual terminal protocol) headers in CDCNET.  The VTP header is
{ useful for applications that need to determine which of several possible
{ transparent input forwarding conditions have occurred.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc ife$error_codes
*copyc ife$interactive_exception_codes
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nat$data_fragments
*copyc iit$cdcnet_conn_reject_reasons
*copyc iit$vt_attributes
*copyc iit$vt_attribute_descriptions
*copyc iit$vt_attribute_kinds
*copyc iit$vt_change_error_codes
*copyc iit$vt_connections
*copyc iit$vt_input_information
*copyc iit$vt_message_types
*copyc iit$vt_octet_header
*copyc iit$vt_output_information
*copyc iit$vt_timeout
?? POP ??
*copyc bav$last_tft_entry
*copyc bav$task_file_table
*copyc clp$get_system_file_id
*copyc fsp$close_file
*copyc fsp$open_file
*copyc i#move
*copyc i#ptr
*copyc nap$await_data_available
*copyc nap$se_receive_data
*copyc nap$se_send_data
*copyc nap$se_synchronize
*copyc nap$se_synchronize_confirm
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc oss$job_paged_literal
*copyc pmp$log

?? OLDTITLE ??
?? TITLE := ' iip$vtp_open_network ', EJECT ??

*copyc iih$vtp_open_network

  PROCEDURE [XDCL, #GATE] iip$vtp_open_network
    (VAR file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      i: integer,
      network_lfn: ost$name;

    status.normal := TRUE;
    network_lfn := ':$LOCAL.$TERMINAL';
    fsp$open_file (network_lfn, amc$record, NIL, NIL, NIL, NIL, NIL, file_id, status);

  PROCEND iip$vtp_open_network;
?? TITLE := ' iip$vtp_put_next ', EJECT ??

*copyc iih$vtp_put_next

  PROCEDURE [XDCL, #GATE] iip$vtp_put_next
    (    file_identifier: amt$file_identifier;
         working_storage_area: ^cell;
         working_storage_length: amt$working_storage_length;
     VAR status: ost$status);

    VAR
      activity_status: ost$activity_status,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      local_status: ost$status;

    data_fragment [1].address := working_storage_area;
    data_fragment [1].length := working_storage_length;
    nap$se_send_data (file_identifier, data_fragment, TRUE, FALSE, osc$wait, activity_status, status);
    IF NOT status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, local_status);
      pmp$log ('VTP-PUT 01', local_status);
      RETURN;
    IFEND;

  PROCEND iip$vtp_put_next;
?? TITLE := ' iip$vtp_get_next ', EJECT ??

*copyc iih$vtp_get_next

  PROCEDURE [XDCL, #GATE] iip$vtp_get_next
    (    file_identifier: amt$file_identifier;
         working_storage_area: ^cell;
         working_storage_length: amt$working_storage_length;
         timeout: iit$vt_timeout;
     VAR input_information: iit$vt_input_information;
     VAR transfer_count: amt$transfer_count;
     VAR status: ost$status);

    VAR
      activity_status: ost$activity_status,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      end_of_message: boolean,
      local_status: ost$status,
      message_received: boolean,
      output_information: iit$vt_output_information;

    output_information.message_type := iic$vt_output_data_message;
    output_information.fill_0 := 0;
    output_information.reserved_1 := 0;
    output_information.reserved_2 := 0;
    output_information.formatting_mode := 0;
    output_information.secured.suppress_end_line_positioning := FALSE;
    output_information.secured.suppress_echoplexing := FALSE;
    output_information.partial := FALSE;
    data_fragment [1].address := ^output_information;
    data_fragment [1].length := #SIZE (output_information);
    nap$se_send_data (file_identifier, data_fragment, TRUE, FALSE, osc$wait, activity_status, status);
    IF NOT status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, local_status);
      pmp$log ('VTP-GET 01', local_status);
      RETURN;
    IFEND;

    get_next_special_block (file_identifier, working_storage_area, working_storage_length, osc$wait, timeout,
          message_received, end_of_message, transfer_count, input_information, status);

  PROCEND iip$vtp_get_next;
?? TITLE := ' iip$vtp_del_paired_con_first ', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$vtp_del_paired_con_first
    (    paired_connection_data: ^SEQ ( * );
     VAR status: ost$status);

    TYPE
      delete_connection_type = record
        message_type: iit$vt_message_types,
        paired_connection_data: SEQ ( * ),
      recend;

    VAR
      delete_connection: ^delete_connection_type,
      delete_connection_message: ^cell,
      delete_conn_msg_length: amt$working_storage_length,
      ignore_status: ost$status,
      local_status: ost$status,
      network_fid: amt$file_identifier;

    status.normal := TRUE;

    iip$vtp_open_network (network_fid, status);
    IF NOT status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$system_log, pmc$job_log], status, local_status);
      pmp$log ('VTP-DC 01', local_status);
      RETURN;
    IFEND;

    PUSH delete_connection: [[REP #SIZE (paired_connection_data^) OF cell]];
    delete_connection^.message_type := iic$vt_delete_paired_connection;
    delete_connection^.paired_connection_data := paired_connection_data^;
    delete_connection_message := delete_connection;
    delete_conn_msg_length := #SIZE (delete_connection^);
    iip$vtp_put_next (network_fid, delete_connection_message, delete_conn_msg_length, status);

    fsp$close_file (network_fid, ignore_status);
  PROCEND iip$vtp_del_paired_con_first;

?? TITLE := ' iip$vtp_delete_paired_connect ', EJECT ??

*copyc iih$vtp_delete_paired_connect

  PROCEDURE [XDCL, #GATE] iip$vtp_delete_paired_connect
    (    file_identifier: amt$file_identifier;
         paired_connection_data: ^SEQ ( * );
     VAR status: ost$status);

    TYPE
      delete_connection_type = record
        message_type: iit$vt_message_types,
        paired_connection_data: SEQ ( * ),
      recend;

    VAR
      delete_connection: ^delete_connection_type,
      delete_connection_message: ^cell,
      delete_conn_msg_length: amt$working_storage_length,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      local_status: ost$status,
      network_fid: amt$file_identifier,
      st_open_file_dsc_pointer: ^iit$st_open_file_description;

    status.normal := TRUE;

*copy bai$validate_file_identifier
*copy iii$fetch_st_open_file_desc_ptr
    IF NOT status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, local_status);
      pmp$log ('VTP-DC 02', local_status);
      RETURN;
    IFEND;
    network_fid := st_open_file_dsc_pointer^.vtp_file_id;
    PUSH delete_connection: [[REP #SIZE (paired_connection_data^) OF cell]];
    delete_connection^.message_type := iic$vt_delete_paired_connection;
    delete_connection^.paired_connection_data := paired_connection_data^;
    delete_connection_message := delete_connection;
    delete_conn_msg_length := #SIZE (delete_connection^);
    iip$vtp_put_next (network_fid, delete_connection_message, delete_conn_msg_length, status);

  PROCEND iip$vtp_delete_paired_connect;
?? TITLE := '[XDCL, #GATE] iip$vtp_create_paired_connect ', EJECT ??

*copyc iih$vtp_create_paired_connect

  PROCEDURE [XDCL, #GATE] iip$vtp_create_paired_connect
    (    file_identifier: amt$file_identifier;
         destination_title: ost$name;
         paired_connection_data: ^SEQ ( * );
         timeout_interval_in_ms: 0 .. 0ffffffff(16);
     VAR status: ost$status);

    TYPE
      create_connection_type = record
        message_type: iit$vt_message_types,
        destination_id_type: 0 .. 0ff(16),
        destination_title: ost$name,
        paired_connection_data: SEQ ( * ),
      recend;

    VAR

      buffer: SEQ (REP 1 of cell),
      create_connection: ^create_connection_type,
      create_connection_message: ^cell,
      create_conn_msg_length: amt$working_storage_length,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      input_information: iit$vt_input_information,
      local_status: ost$status,
      network_fid: amt$file_identifier,
      st_open_file_dsc_pointer: ^iit$st_open_file_description,
      timeout: iit$vt_timeout,
      transfer_count: amt$transfer_count,
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length;

    status.normal := TRUE;

*copy bai$validate_file_identifier
*copy iii$fetch_st_open_file_desc_ptr
    IF NOT status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, local_status);
      pmp$log ('VTP-CPC 02', local_status);
      RETURN;
    IFEND;
    network_fid := st_open_file_dsc_pointer^.vtp_file_id;
    PUSH create_connection: [[REP #SIZE (paired_connection_data^) OF cell]];
    create_connection^.message_type := iic$vt_create_paired_connection;
    create_connection^.destination_id_type := 1;
    create_connection^.destination_title := destination_title;
    create_connection^.paired_connection_data := paired_connection_data^;
    create_connection_message := create_connection;
    create_conn_msg_length := #SIZE (create_connection^);
    iip$vtp_put_next (network_fid, create_connection_message, create_conn_msg_length, status);
    IF NOT status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, local_status);
      pmp$log ('VTP-CPC 03', local_status);
      RETURN;
    IFEND;

    IF timeout_interval_in_ms <> 0 THEN
      timeout. ON := TRUE;
      timeout.length := timeout_interval_in_ms;
      timeout.purge := FALSE;
    ELSE
      timeout. ON := FALSE;
    IFEND;

    working_storage_area := ^buffer;
    working_storage_length := 1;
    iip$vtp_get_next (network_fid, working_storage_area, working_storage_length, timeout, input_information,
          transfer_count, status);
    IF NOT status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, local_status);
      pmp$log ('VTP-CPC 04', local_status);
      RETURN;
    IFEND;

    IF input_information.message_type = iic$vt_create_paired_conn_cnfrm THEN
      RETURN;
    ELSE { input_information.message_type = iic$vt_create_paired_conn_rejct.
      osp$set_status_condition (ife$vt_create_paired_conn_rejct, status);
    IFEND;

  PROCEND iip$vtp_create_paired_connect;
?? TITLE := '[XDCL, #GATE] iip$vtp_create_cdcnet_connect ', EJECT ??

*copyc iih$vtp_create_cdcnet_connect

  PROCEDURE [XDCL, #GATE] iip$vtp_create_cdcnet_connect
    (    service_name: ost$name;
         service_data: ^SEQ ( * );
         connection_data_1: ^SEQ ( * );
         connection_data_2: ^SEQ ( * );
         connection_data_3: ^SEQ ( * );
         end_discard_prompt: ^SEQ ( * );
         timeout_interval_in_ms: 0 .. 0ffffffff(16);
     VAR status: ost$status);

    TYPE
      create_connection_type = record
        message_type: iit$vt_message_types,
        service_name: ost$name,
        length: 0 .. 0ff(16),
        service_data: SEQ ( * ),
      recend;

    TYPE
      create_connection_type2 = record
        message_type: iit$vt_message_types,
        service_name: ost$name,
        length: 0 .. 0ff(16),
      recend;

    TYPE
      connection_data_type = record
        length: 0 .. 0ff(16),
        connection_data: SEQ ( * ),
      recend;

    TYPE
      receive_data = record
        case boolean of
        = true =
          input_info: iit$vt_input_information,
        = false =
          data: packed record
            fill1: 0 .. 1fff(16),
            reason: iit$cdcnet_conn_reject_reasons,
            fill2: 0 .. 0ffff(16),
          recend,
        casend,
      recend;


    VAR
      activity_status: ost$activity_status,
      buffer: SEQ (REP 1 of cell),
      create_connection: ^create_connection_type,
      create_connection_no_serv_data: ^create_connection_type2,
      cdata1: ^connection_data_type,
      cdata2: ^connection_data_type,
      cdata3: ^connection_data_type,
      data_fragment: array [1 .. 5] of nat$data_fragment,
      edp_data: ^connection_data_type,
      end_discard_prompt_length: 0 .. 16,
      file_identifier: amt$file_identifier,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      i: 1 .. 5,
      input_information: iit$vt_input_information,
      local_status: ost$status,
      network_fid: amt$file_identifier,
      received: receive_data,
      st_open_file_dsc_pointer: ^iit$st_open_file_description,
      timeout: iit$vt_timeout,
      transfer_count: amt$transfer_count,
      working_storage_area: ^cell,
      working_storage_length: amt$working_storage_length;


    status.normal := TRUE;

    clp$get_system_file_id (clc$job_output, file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

*copy bai$validate_file_identifier
*copy iii$fetch_st_open_file_desc_ptr
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    network_fid := st_open_file_dsc_pointer^.vtp_file_id;
    IF service_data <> NIL THEN
      PUSH create_connection: [[REP #SIZE (service_data^) OF cell]];
      create_connection^.message_type := iic$vt_create_cdcnet_connection;
      create_connection^.service_name := service_name;
      create_connection^.length := #SIZE (service_data^);
      create_connection^.service_data := service_data^;
      data_fragment [1].address := create_connection;
      data_fragment [1].length := #SIZE (create_connection^);
    ELSE
      PUSH create_connection_no_serv_data;
      create_connection_no_serv_data^.message_type := iic$vt_create_cdcnet_connection;
      create_connection_no_serv_data^.service_name := service_name;
      create_connection_no_serv_data^.length := 0;
      data_fragment [1].address := create_connection_no_serv_data;
      data_fragment [1].length := #SIZE (create_connection_no_serv_data^);
    IFEND;

    IF end_discard_prompt = NIL THEN
      end_discard_prompt_length := 0;
      data_fragment [2].address := ^end_discard_prompt_length;
      data_fragment [2].length := #SIZE (end_discard_prompt_length);
    ELSE
      PUSH edp_data: [[REP #SIZE (end_discard_prompt^) OF cell]];
      edp_data^.length := #SIZE (end_discard_prompt^);
      edp_data^.connection_data := end_discard_prompt^;
      data_fragment [2].address := edp_data;
      data_fragment [2].length := #SIZE (edp_data^);
    IFEND;

    FOR i := 3 TO 5 DO
      data_fragment [i].address := NIL;
      data_fragment [i].length := 0;
    FOREND;

    IF connection_data_1 <> NIL THEN
      PUSH cdata1: [[REP #SIZE (connection_data_1^) OF cell]];
      cdata1^.length := #SIZE (connection_data_1^);
      cdata1^.connection_data := connection_data_1^;
      data_fragment [3].address := cdata1;
      data_fragment [3].length := #SIZE (cdata1^);
      IF connection_data_2 <> NIL THEN
        PUSH cdata2: [[REP #SIZE (connection_data_2^) OF cell]];
        cdata2^.length := #SIZE (connection_data_2^);
        cdata2^.connection_data := connection_data_2^;
        data_fragment [4].address := cdata2;
        data_fragment [4].length := #SIZE (cdata2^);
        IF connection_data_3 <> NIL THEN
          PUSH cdata3: [[REP #SIZE (connection_data_3^) OF cell]];
          cdata3^.length := #SIZE (connection_data_3^);
          cdata3^.connection_data := connection_data_3^;
          data_fragment [5].address := cdata3;
          data_fragment [5].length := #SIZE (cdata3^);
        IFEND;
      IFEND;
    IFEND;

    nap$se_send_data (network_fid, data_fragment, TRUE, FALSE, osc$wait, activity_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF timeout_interval_in_ms <> 0 THEN
      timeout. ON := TRUE;
      timeout.length := timeout_interval_in_ms;
      timeout.purge := FALSE;
    ELSE
      timeout. ON := FALSE;
    IFEND;

    working_storage_area := ^buffer;
    working_storage_length := 1;
    iip$vtp_get_next (network_fid, working_storage_area, working_storage_length, timeout, input_information,
          transfer_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF input_information.message_type <> iic$vt_create_cdcnet_conn_cnfrm THEN
      received.input_info := input_information;
      IF received.data.reason = iic$cannot_locate_service THEN
        osp$set_status_abnormal ('IF', ife$cannot_locate_service, service_name, status);
      ELSEIF received.data.reason = iic$connection_already_switched THEN
        osp$set_status_condition (ife$connection_already_switched, status);
      ELSEIF received.data.reason = iic$cannot_create_connection THEN
        osp$set_status_condition (ife$cannot_create_connection, status);
      ELSEIF received.data.reason = iic$service_is_busy THEN
        osp$set_status_condition (ife$service_is_busy, status);
      ELSEIF received.data.reason = iic$invalid_service_data THEN
        osp$set_status_condition (ife$invalid_service_data, status);
      ELSEIF received.data.reason = iic$invalid_connection_data THEN
        osp$set_status_condition (ife$invalid_connection_data, status);
      ELSE
        pmp$log ('VTP - CCC - UNKNOWN REJECT REASON', local_status);
        osp$set_status_condition (ife$cannot_create_connection, status);
      IFEND;
    IFEND;

  PROCEND iip$vtp_create_cdcnet_connect;
?? TITLE := 'GET_NEXT_SPECIAL_BLOCK', EJECT ??

  PROCEDURE get_next_special_block
    (    input_file_identifier: amt$file_identifier;
         buffer_ptr: ^cell;
         buffer_length: nat$data_length;
         wait: ost$wait;
         timeout: iit$vt_timeout;
     VAR message_received: boolean;
     VAR end_of_message: boolean;
     VAR transfer_count: nat$data_length;
     VAR input: iit$vt_input_information;
     VAR status: ost$status);


    VAR
      activity_status: ost$activity_status,
      data: array [1 .. 2] of nat$data_fragment,
      data1: array [1 .. 1] of nat$data_fragment,
      empty_header: [STATIC, READ, oss$job_paged_literal] iit$vt_input_information :=
            [0, iic$vt_input_data_message, 0, 0, iic$vt_character, FALSE, FALSE, TRUE, FALSE, 'a'],
      file_identifier: amt$file_identifier,
      ibs_buffer: ^SEQ (REP 2048 of cell),
      move_ptr: ^cell,
      non_eom_buffer: SEQ (REP 2048 of cell),
      peer_operation: nat$se_peer_operation,
      queue_type_from_message: [STATIC, READ, oss$job_paged_literal] iit$vt_queue_type_from_message :=
            [iic$vt_output, iic$vt_input, iic$vt_change, iic$vt_change, iic$vt_change, iic$vt_indications,
            iic$vt_status, iic$vt_status, iic$vt_status, iic$vt_start_stop_comm, iic$vt_start_stop_comm_resp,
            iic$vt_start_stop_comm, iic$vt_start_stop_comm_resp, iic$vt_change, iic$vt_version, iic$vt_create,
            iic$vt_create_status, iic$vt_create_status, iic$vt_delete, iic$vt_status, iic$vt_status,
            iic$vt_status, iic$vt_create, iic$vt_create_status, iic$vt_create_status],
      status_save: ost$status,
      timeout_data: SEQ (REP 1 of cell),
      wait_time: integer;


    status.normal := TRUE;
    message_received := FALSE;
    transfer_count := 0;

    REPEAT
      IF timeout. ON THEN
        wait_time := timeout.length;
        nap$await_data_available (input_file_identifier, wait_time, wait_time, status);
        IF NOT status.normal THEN
          IF (status.condition = nae$no_event) OR (status.condition = nae$no_data_available) OR
                (status.condition = nae$data_transfer_timeout) THEN
            status_save := status;
            IF timeout.length <> 0 THEN
              IF timeout.purge THEN
                nap$se_synchronize (input_file_identifier, nac$se_synchronize_all_data, timeout_data, status);
                IF NOT status.normal THEN
                  IF status.condition = nae$se_synch_confirm_pending THEN
                    status.normal := TRUE;
                  IFEND;
                  RETURN;
                ELSE
                  status := status_save;
                IFEND;
              IFEND; { of timeout.purge }
            IFEND; { of timeout.length nonzero }
          IFEND; { of timeout-related status }
          RETURN; { for any abnormal status }
        IFEND; { of abnormal status }
      IFEND; { of timeout.on }

{ Receive block and return it or queue it.

      data [1].address := ^input;
      data [1].length := iic$vt_header_length_input;
      data [2].address := buffer_ptr;
      data [2].length := buffer_length;
      nap$se_receive_data (input_file_identifier, data, wait, peer_operation, activity_status, status);
      IF (status.normal) AND (activity_status.complete) AND (NOT activity_status.status.normal) THEN
        status := activity_status.status;
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE peer_operation.kind OF
      = nac$se_interrupt =
        osp$set_status_condition (ife$vt_unsupported_event, status);
        RETURN;

      = nac$se_synchronize =
        IF peer_operation.direction = nac$se_synchronize_receive_data THEN
          transfer_count := 0;
          input := empty_header;
          message_received := TRUE;
        ELSE
          nap$se_synchronize_confirm (input_file_identifier, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      = nac$se_synchronize_confirm =
        ; { add code someday if there is  anything to do }

      = nac$se_send_data =
        IF queue_type_from_message [input.message_type] = iic$vt_input THEN
          IF NOT peer_operation.end_of_message THEN
            message_received := TRUE;
            transfer_count := peer_operation.data_length - iic$vt_header_length_input;
            end_of_message := FALSE;
            ibs_buffer := ^non_eom_buffer;
            RESET ibs_buffer;
            move_ptr := ibs_buffer;
            i#move (^input, move_ptr, iic$vt_header_length_input);
            data1 [1].address := i#ptr (iic$vt_header_length_input, move_ptr);
            data1 [1].length := iic$vt_max_transfer_length - iic$vt_header_length_input;
            nap$se_receive_data (input_file_identifier, data1, wait, peer_operation, activity_status, status);
            IF (status.normal) AND (activity_status.complete) AND (NOT activity_status.status.normal) THEN
              status := activity_status.status;
            IFEND;
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF NOT peer_operation.end_of_message THEN
              osp$set_status_condition (ife$vt_no_eom_found, status);
              RETURN;
            IFEND;

            CASE peer_operation.kind OF

            = nac$se_interrupt =
              osp$set_status_condition (ife$vt_unsupported_event, status);
              RETURN;

            = nac$se_synchronize =
              IF peer_operation.direction = nac$se_synchronize_receive_data THEN
                transfer_count := 0;
                input := empty_header;
                message_received := TRUE;
              ELSE
                nap$se_synchronize_confirm (input_file_identifier, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              IFEND;

            = nac$se_synchronize_confirm =
              ; { add code someday if there is  anything to do }

            = nac$se_send_data =

{ Discarding data after non-EOM

              RETURN;

            CASEND; { of peer_operation.kind, inner layer }

          ELSE {eom encountered}
            end_of_message := peer_operation.end_of_message;
            IF queue_type_from_message [input.message_type] = iic$vt_input THEN
              message_received := TRUE;
              transfer_count := peer_operation.data_length - iic$vt_header_length_input;
              RETURN;
            IFEND;
          IFEND; { eom encountered }

        ELSE { not input data}

          CASE peer_operation.kind OF
          = nac$se_interrupt =
            osp$set_status_condition (ife$vt_unsupported_event, status);
            RETURN;

          = nac$se_synchronize =
            IF peer_operation.direction = nac$se_synchronize_receive_data THEN
              transfer_count := 0;
              input := empty_header;
              message_received := TRUE;
            ELSE
              nap$se_synchronize_confirm (input_file_identifier, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;

          = nac$se_synchronize_confirm =

{ add code if there is anything to be done here

          = nac$se_send_data =
            IF NOT peer_operation.end_of_message THEN
              osp$set_status_condition (ife$vt_no_eom_found, status);
              RETURN;
            IFEND;
            message_received := TRUE;
            transfer_count := peer_operation.data_length;
            RETURN;
          ELSE
          CASEND; { of peer_operation.kind, not input data}
        IFEND; { not input data}
      ELSE
      CASEND; { of peer_operation.kind, outer layer }

    UNTIL message_received;

  PROCEND get_next_special_block;

?? OLDTITLE ??
?? OLDTITLE ??
MODEND iim$vtp_terminal_interface;
*DECK DECK=IIM$VTT_IFT_CONVERSION_ROUTINES EXPAND=TRUE
?? RIGHT := 110 ??
MODULE iim$vtt_ift_conversion_routines;
?? TITLE := 'MODULE iim$vtt_ift_conversion_routines' ??
?? PUSH (LISTEXT := ON) ??
*copyc ifc$interrupt_timesharing_io
*copyc ife$error_codes
*copyc iit$vt_attributes
*copyc ift$connection_attributes
*copyc ift$terminal_attributes
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nat$data_fragments
*copyc iiv$connection_desc_ptr
*copyc iiv$interactive_terminated
*copyc iiv$int_task_open_file_count
*copyc iip$set_lock
*copyc iip$clear_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$system_error
*copyc osp$test_sig_lock
*copyc osv$job_pageable_heap
*copyc osv$lower_to_upper
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc osv$task_shared_heap
*copyc pmp$continue_to_cause
*copyc pmp$log
*copyc iip$vt_open
*copyc iip$vt_close
*copyc iip$vt_change_attributes
*copyc iip$vt_get_change_response
*copyc iit$vt_change_error_codes
?? POP ??

 VAR
   translate_vt_kinds_to_if_keys: [STATIC , READ, oss$job_paged_literal] array [iit$vt_attribute_kind] OF
         ift$terminal_attribute_keys :=  [

{iic$vt_fill0} ifc$null_terminal_attribute,
{iic$vt_input_output_mode} ifc$null_terminal_attribute,
{iic$vt_input_editing_mode} ifc$null_terminal_attribute,
{iic$vt_trans_character_mode} ifc$null_terminal_attribute,
{iic$vt_trans_forward_character} ifc$null_terminal_attribute,
{iic$vt_trans_term_character} ifc$null_terminal_attribute,
{iic$vt_trans_timeout_mode} ifc$null_terminal_attribute,
{iic$vt_trans_length_mode} ifc$null_terminal_attribute,
{iic$vt_trans_message_length} ifc$null_terminal_attribute,
{iic$vt_partial_char_forwarding} ifc$null_terminal_attribute,
{iic$vt_attention_char_action} ifc$null_terminal_attribute,
{iic$vt_break_key_action} ifc$null_terminal_attribute,
{iic$vt_input_block_size} ifc$null_terminal_attribute,
{iic$vt_store_nuls_dels} ifc$null_terminal_attribute,
{iic$vt_store_backspace_char} ifc$null_terminal_attribute,
{iic$vt_fill15} ifc$null_terminal_attribute,
{iic$vt_fill16} ifc$null_terminal_attribute,
{iic$vt_fill17} ifc$null_terminal_attribute,
{iic$vt_fill18} ifc$null_terminal_attribute,
{iic$vt_fill19} ifc$null_terminal_attribute,
{iic$vt_fill20} ifc$null_terminal_attribute,
{iic$vt_fill21} ifc$null_terminal_attribute,
{iic$vt_fill22} ifc$null_terminal_attribute,
{iic$vt_fill23} ifc$null_terminal_attribute,
{iic$vt_fill24} ifc$null_terminal_attribute,
{iic$vt_fill25} ifc$null_terminal_attribute,
{iic$vt_fill26} ifc$null_terminal_attribute,
{iic$vt_fill27} ifc$null_terminal_attribute,
{iic$vt_fill28} ifc$null_terminal_attribute,
{iic$vt_fill29} ifc$null_terminal_attribute,
{iic$vt_fill30} ifc$null_terminal_attribute,
{iic$vt_fill31} ifc$null_terminal_attribute,
{iic$vt_fill32} ifc$null_terminal_attribute,
{iic$vt_fill33} ifc$null_terminal_attribute,
{iic$vt_fill34} ifc$null_terminal_attribute,
{iic$vt_fill35} ifc$null_terminal_attribute,
{iic$vt_fill36} ifc$null_terminal_attribute,
{iic$vt_fill37} ifc$null_terminal_attribute,
{iic$vt_fill38} ifc$null_terminal_attribute,
{iic$vt_fill39} ifc$null_terminal_attribute,
{iic$vt_fill40} ifc$null_terminal_attribute,
{iic$vt_fill41} ifc$null_terminal_attribute,
{iic$vt_fill42} ifc$null_terminal_attribute,
{iic$vt_fill43} ifc$null_terminal_attribute,
{iic$vt_fill44} ifc$null_terminal_attribute,
{iic$vt_fill45} ifc$null_terminal_attribute,
{iic$vt_fill46} ifc$null_terminal_attribute,
{iic$vt_fill47} ifc$null_terminal_attribute,
{iic$vt_fill48} ifc$null_terminal_attribute,
{iic$vt_fill49} ifc$null_terminal_attribute,
{iic$vt_fill50} ifc$null_terminal_attribute,
{iic$vt_fill51} ifc$null_terminal_attribute,
{iic$vt_fill52} ifc$null_terminal_attribute,
{iic$vt_fill53} ifc$null_terminal_attribute,
{iic$vt_fill54} ifc$null_terminal_attribute,
{iic$vt_fill55} ifc$null_terminal_attribute,
{iic$vt_fill56} ifc$null_terminal_attribute,
{iic$vt_fill57} ifc$null_terminal_attribute,
{iic$vt_fill58} ifc$null_terminal_attribute,
{iic$vt_fill59} ifc$null_terminal_attribute,
{iic$vt_fill60} ifc$null_terminal_attribute,
{iic$vt_fill61} ifc$null_terminal_attribute,
{iic$vt_fill62} ifc$null_terminal_attribute,
{iic$vt_fill63} ifc$null_terminal_attribute,
{iic$vt_network_command_char} ifc$network_command_character,
{iic$vt_cancel_line_character} ifc$cancel_line_character,
{iic$vt_end_line_character} ifc$end_line_character,
{iic$vt_begin_line_character} ifc$begin_line_character,
{iic$vt_backspace_character} ifc$backspace_character,
{iic$vt_end_partial_character} ifc$end_partial_character,
{iic$vt_attention_character} ifc$attention_character,
{iic$vt_page_length} ifc$page_length,
{iic$vt_page_width} ifc$page_width,
{iic$vt_hold_page} ifc$hold_page,
{iic$vt_hold_page_over} ifc$hold_page_over,
{iic$vt_fold_line} ifc$fold_line,
{iic$vt_end_output_sequence} ifc$end_output_sequence,
{iic$vt_carriage_return_sequence} ifc$carriage_return_sequence,
{iic$vt_line_feed_sequence} ifc$line_feed_sequence,
{iic$vt_form_feed_sequence} ifc$form_feed_sequence,
{iic$vt_end_page_action} ifc$end_page_action,
{iic$vt_carriage_return_delay} ifc$carriage_return_delay,
{iic$vt_line_feed_delay} ifc$line_feed_delay,
{iic$vt_form_feed_delay} ifc$form_feed_delay,
{iic$vt_end_line_positioning} ifc$end_line_positioning,
{iic$vt_end_partial_positioning} ifc$end_partial_positioning,
{iic$vt_character_flow_control} ifc$character_flow_control,
{iic$vt_terminal_model} ifc$terminal_model,
{iic$vt_code_set} ifc$code_set,
{iic$vt_parity} ifc$parity,
{iic$vt_echoplex} ifc$echoplex,
{iic$vt_status_action} ifc$status_action,
{iic$vt_fill92} ifc$null_terminal_attribute,
{iic$vt_fill93} ifc$null_terminal_attribute,
{iic$vt_control_code_replacement} ifc$control_code_replacement,
{iic$vt_function_key_class} ifc$function_key_class,
{iic$vt_terminal_name} ifc$terminal_name,
{iic$vt_code_set_name} ifc$code_set_name];

  VAR
    translate_if_keys_to_vt_kinds: [STATIC, READ, oss$job_paged_literal] array [ift$terminal_attribute_keys]
          of iit$vt_attribute_kind := [
          {ifc$attention_character} iic$vt_attention_character,
          {ifc$backspace_character} iic$vt_backspace_character,
          {ifc$begin_line_character} iic$vt_begin_line_character,
          {ifc$cancel_line_character} iic$vt_cancel_line_character,
          {ifc$carriage_return_delay} iic$vt_carriage_return_delay,
          {ifc$carriage_return_sequence} iic$vt_carriage_return_sequence,
          {ifc$character_flow_control} iic$vt_character_flow_control,
          {ifc$code_set} iic$vt_code_set,
          {ifc$echoplex} iic$vt_echoplex,
          {ifc$end_line_character} iic$vt_end_line_character,
          {ifc$end_line_positioning} iic$vt_end_line_positioning,
          {ifc$end_output_sequence} iic$vt_end_output_sequence,
          {ifc$end_page_action} iic$vt_end_page_action,
          {ifc$end_partial_character} iic$vt_end_partial_character,
          {ifc$end_partial_positioning} iic$vt_end_partial_positioning,
          {ifc$fold_line} iic$vt_fold_line,
          {ifc$form_feed_delay} iic$vt_form_feed_delay,
          {ifc$form_feed_sequence} iic$vt_form_feed_sequence,
          {ifc$hold_page} iic$vt_hold_page,
          {ifc$hold_page_over} iic$vt_hold_page_over,
          {ifc$line_feed_delay} iic$vt_line_feed_delay,
          {ifc$line_feed_sequence} iic$vt_line_feed_sequence,
          {ifc$network_command_character} iic$vt_network_command_char,
          {ifc$null_terminal_attribute} iic$vt_fill0,
          {ifc$page_length} iic$vt_page_length,
          {ifc$page_width} iic$vt_page_width,
          {ifc$parity} iic$vt_parity,
          {ifc$pause_break_character} iic$vt_fill0,
          {ifc$status_action} iic$vt_status_action,
          {ifc$terminal_class} iic$vt_fill0,
          {ifc$terminal_model} iic$vt_terminal_model,
          {ifc$terminate_break_character} iic$vt_fill0,
          {ifc$terminal_name} iic$vt_terminal_name,
          {ifc$control_code_replacement} iic$vt_control_code_replacement,
          {ifc$code_set_name} iic$vt_code_set_name,
          {ifc$function_key_class} iic$vt_function_key_class];


?? NEWTITLE := 'PROCEDURE iip$vt_to_terminal_attributes', EJECT ??

  PROCEDURE [XDCL] iip$vt_to_terminal_attributes (vt_attributes: iit$vt_attributes;
    VAR terminal_attributes: ift$terminal_attributes);

{   Convert an array of iit$vt_attribute records into an array of ift$terminal_attribute
{   records.

    VAR
      i: integer,
      j: integer,
      k: integer;

      j := 0;
      FOR i := LOWERBOUND (vt_attributes) TO UPPERBOUND (vt_attributes) DO
        j := j + 1;
        CASE vt_attributes [i].kind OF
        = iic$vt_attention_character =
          terminal_attributes [j].key := ifc$attention_character;
          terminal_attributes [j].attention_character := vt_attributes [i].attention_character;
        = iic$vt_backspace_character =
          terminal_attributes [j].key := ifc$backspace_character;
          terminal_attributes [j].backspace_character := vt_attributes [i].backspace_character;
        = iic$vt_begin_line_character =
          terminal_attributes [j].key := ifc$begin_line_character;
          terminal_attributes [j].begin_line_character := vt_attributes [i].begin_line_character;
        = iic$vt_cancel_line_character =
          terminal_attributes [j].key := ifc$cancel_line_character;
          terminal_attributes [j].cancel_line_character := vt_attributes [i].cancel_line_character;
        = iic$vt_carriage_return_delay =
          terminal_attributes [j].key := ifc$carriage_return_delay;
          terminal_attributes [j].carriage_return_delay := vt_attributes [i].carriage_return_delay;
        = iic$vt_carriage_return_sequence =
          terminal_attributes [j].key := ifc$carriage_return_sequence;
          terminal_attributes [j].carriage_return_sequence := vt_attributes [i].carriage_return_sequence;
        = iic$vt_character_flow_control =
          terminal_attributes [j].key := ifc$character_flow_control;
          terminal_attributes [j].character_flow_control := vt_attributes [i].character_flow_control;
        = iic$vt_code_set =
          terminal_attributes [j].key := ifc$code_set;
          terminal_attributes [j].code_set := vt_attributes [i].code_set;
        = iic$vt_echoplex =
          terminal_attributes [j].key := ifc$echoplex;
          terminal_attributes [j].echoplex := vt_attributes [i].echoplex;
        = iic$vt_end_line_character =
          terminal_attributes [j].key := ifc$end_line_character;
          terminal_attributes [j].end_line_character := vt_attributes [i].end_line_character;
        = iic$vt_end_line_positioning =
          terminal_attributes [j].key := ifc$end_line_positioning;
          terminal_attributes [j].end_line_positioning := vt_attributes [i].end_line_positioning;
        = iic$vt_end_output_sequence =
          terminal_attributes [j].key := ifc$end_output_sequence;
          terminal_attributes [j].end_output_sequence := vt_attributes [i].end_output_sequence;
        = iic$vt_end_page_action =
          terminal_attributes [j].key := ifc$end_page_action;
          terminal_attributes [j].end_page_action := vt_attributes [i].end_page_action;
        = iic$vt_end_partial_character =
          terminal_attributes [j].key := ifc$end_partial_character;
          terminal_attributes [j].end_partial_character := vt_attributes [i].end_partial_character;
        = iic$vt_end_partial_positioning =
          terminal_attributes [j].key := ifc$end_partial_positioning;
          terminal_attributes [j].end_partial_positioning := vt_attributes [i].end_partial_positioning;
        = iic$vt_fold_line =
          terminal_attributes [j].key := ifc$fold_line;
          terminal_attributes [j].fold_line := vt_attributes [i].fold_line;
        = iic$vt_form_feed_delay =
          terminal_attributes [j].key := ifc$form_feed_delay;
          terminal_attributes [j].form_feed_delay := vt_attributes [i].form_feed_delay;
        = iic$vt_form_feed_sequence =
          terminal_attributes [j].key := ifc$form_feed_sequence;
          terminal_attributes [j].form_feed_sequence := vt_attributes [i].form_feed_sequence;
        = iic$vt_function_key_class =
          terminal_attributes [j].key := ifc$function_key_class;
          terminal_attributes [j].function_key_class^ := vt_attributes [i].function_key_class;
        = iic$vt_hold_page =
          terminal_attributes [j].key := ifc$hold_page;
          terminal_attributes [j].hold_page := vt_attributes [i].hold_page;
        = iic$vt_hold_page_over =
          terminal_attributes [j].key := ifc$hold_page_over;
          terminal_attributes [j].hold_page_over := vt_attributes [i].hold_page_over;
        = iic$vt_line_feed_delay =
          terminal_attributes [j].key := ifc$line_feed_delay;
          terminal_attributes [j].line_feed_delay := vt_attributes [i].line_feed_delay;
        = iic$vt_line_feed_sequence =
          terminal_attributes [j].key := ifc$line_feed_sequence;
          terminal_attributes [j].line_feed_sequence := vt_attributes [i].line_feed_sequence;
        = iic$vt_network_command_char =
          terminal_attributes [j].key := ifc$network_command_character;
          terminal_attributes [j].network_command_character := vt_attributes [i].network_command_character;
        = iic$vt_page_length =
          terminal_attributes [j].key := ifc$page_length;
          terminal_attributes [j].page_length := vt_attributes [i].page_length;
        = iic$vt_page_width =
          terminal_attributes [j].key := ifc$page_width;
          terminal_attributes [j].page_width := vt_attributes [i].page_width;
        = iic$vt_parity =
          terminal_attributes [j].key := ifc$parity;
          terminal_attributes [j].parity := vt_attributes [i].parity;
        = iic$vt_status_action =
          terminal_attributes [j].key := ifc$status_action;
          terminal_attributes [j].status_action := vt_attributes [i].status_action;
        = iic$vt_terminal_model =
          terminal_attributes [j].key := ifc$terminal_model;
          terminal_attributes [j].terminal_model := vt_attributes [i].terminal_model;
        = iic$vt_code_set_name =
          terminal_attributes [j].key := ifc$code_set_name;
          terminal_attributes [j].code_set_name^ := vt_attributes [i].code_set_name;
        = iic$vt_control_code_replacement =
          terminal_attributes [j].key := ifc$control_code_replacement;
          terminal_attributes [j].control_code_replacement^.
            total_substitution_count := vt_attributes [i].
              control_code_replacement.total_substitution_count;
          FOR k := 1 TO vt_attributes [i].control_code_replacement.
            total_substitution_count  DO
            terminal_attributes [j].control_code_replacement^.
              value[k].original_control_code := vt_attributes [i].
                control_code_replacement.value[k].original_control_code;
{           terminal_attributes [j].control_code_replacement^.
{             value[k].substitute_control_code_entered := vt_attributes [i].
{               control_code_replacement.value[k].
{               substitute_control_code_entered;
            terminal_attributes [j].control_code_replacement^.
              value[k].substitute_control_code := vt_attributes [i].
                control_code_replacement.value[k].substitute_control_code;
          FOREND;

        ELSE
          terminal_attributes [j].key := ifc$null_terminal_attribute;
        CASEND;
      FOREND;

  PROCEND iip$vt_to_terminal_attributes;

?? TITLE := 'PROCEDURE iip$vt_kind_to_if_key', EJECT ??

  PROCEDURE [XDCL] iip$vt_kind_to_if_key (vt_kind: iit$vt_attribute_kind;
    VAR if_key: ift$terminal_attribute_keys);

{   This routine was inspired by the need in IFP$GET_TERMINAL_ATTRIBUTES to convert any
{   possible error, a iit$vt_attribute_kind, to its equivalent in ift$terminal_attribute_keys.

    VAR
      i: integer;

    if_key := translate_vt_kinds_to_if_keys [vt_kind];

  PROCEND iip$vt_kind_to_if_key;
?? TITLE := 'PROCEDURE iip$terminal_to_vt_attributes', EJECT ??

  PROCEDURE [XDCL] iip$terminal_to_vt_attributes (terminal_attributes: ift$terminal_attributes;
    VAR vt_attributes: iit$vt_attributes);

{   Convert an array of ift$terminal_attribute records to an equivalent array of
{   iit$vt_attribute records.

    VAR
      destination_source: string (31),
      i: integer,
      j: integer,
      k: integer;

      j := 0;
      FOR i := LOWERBOUND (vt_attributes) TO UPPERBOUND (vt_attributes) DO
        j := j + 1;
        CASE terminal_attributes [i].key OF
        = ifc$attention_character =
          vt_attributes [j].kind := iic$vt_attention_character;
          vt_attributes [j].attention_character := terminal_attributes [i].attention_character;
        = ifc$backspace_character =
          vt_attributes [j].kind := iic$vt_backspace_character;
          vt_attributes [j].backspace_character := terminal_attributes [i].backspace_character;
        = ifc$begin_line_character =
          vt_attributes [j].kind := iic$vt_begin_line_character;
          vt_attributes [j].begin_line_character := terminal_attributes [i].begin_line_character;
        = ifc$cancel_line_character =
          vt_attributes [j].kind := iic$vt_cancel_line_character;
          vt_attributes [j].cancel_line_character := terminal_attributes [i].cancel_line_character;
        = ifc$carriage_return_delay =
          vt_attributes [j].kind := iic$vt_carriage_return_delay;
          vt_attributes [j].carriage_return_delay := terminal_attributes [i].carriage_return_delay;
        = ifc$carriage_return_sequence =
          vt_attributes [j].kind := iic$vt_carriage_return_sequence;
          vt_attributes [j].carriage_return_sequence := terminal_attributes [i].carriage_return_sequence;
        = ifc$character_flow_control =
          vt_attributes [j].kind := iic$vt_character_flow_control;
          vt_attributes [j].character_flow_control := terminal_attributes [i].character_flow_control;
        = ifc$code_set =
          vt_attributes [j].kind := iic$vt_code_set;
          vt_attributes [j].code_set := terminal_attributes [i].code_set;
        = ifc$echoplex =
          vt_attributes [j].kind := iic$vt_echoplex;
          vt_attributes [j].echoplex := terminal_attributes [i].echoplex;
        = ifc$end_line_character =
          vt_attributes [j].kind := iic$vt_end_line_character;
          vt_attributes [j].end_line_character := terminal_attributes [i].end_line_character;
        = ifc$end_line_positioning =
          vt_attributes [j].kind := iic$vt_end_line_positioning;
          vt_attributes [j].end_line_positioning := terminal_attributes [i].end_line_positioning;
        = ifc$end_output_sequence =
          vt_attributes [j].kind := iic$vt_end_output_sequence;
          vt_attributes [j].end_output_sequence := terminal_attributes [i].end_output_sequence;
        = ifc$end_page_action =
          vt_attributes [j].kind := iic$vt_end_page_action;
          vt_attributes [j].end_page_action := terminal_attributes [i].end_page_action;
        = ifc$end_partial_character =
          vt_attributes [j].kind := iic$vt_end_partial_character;
          vt_attributes [j].end_partial_character := terminal_attributes [i].end_partial_character;
        = ifc$end_partial_positioning =
          vt_attributes [j].kind := iic$vt_end_partial_positioning;
          vt_attributes [j].end_partial_positioning := terminal_attributes [i].end_partial_positioning;
        = ifc$fold_line =
          vt_attributes [j].kind := iic$vt_fold_line;
          vt_attributes [j].fold_line := terminal_attributes [i].fold_line;
        = ifc$form_feed_delay =
          vt_attributes [j].kind := iic$vt_form_feed_delay;
          vt_attributes [j].form_feed_delay := terminal_attributes [i].form_feed_delay;
        = ifc$form_feed_sequence =
          vt_attributes [j].kind := iic$vt_form_feed_sequence;
          vt_attributes [j].form_feed_sequence := terminal_attributes [i].form_feed_sequence;
        = ifc$function_key_class =
          vt_attributes [j].kind := iic$vt_function_key_class;
          vt_attributes [j].function_key_class := terminal_attributes [i].function_key_class^;
        = ifc$hold_page =
          vt_attributes [j].kind := iic$vt_hold_page;
          vt_attributes [j].hold_page := terminal_attributes [i].hold_page;
        = ifc$hold_page_over =
          vt_attributes [j].kind := iic$vt_hold_page_over;
          vt_attributes [j].hold_page_over := terminal_attributes [i].hold_page_over;
        = ifc$line_feed_delay =
          vt_attributes [j].kind := iic$vt_line_feed_delay;
          vt_attributes [j].line_feed_delay := terminal_attributes [i].line_feed_delay;
        = ifc$line_feed_sequence =
          vt_attributes [j].kind := iic$vt_line_feed_sequence;
          vt_attributes [j].line_feed_sequence := terminal_attributes [i].line_feed_sequence;
        = ifc$network_command_character =
          vt_attributes [j].kind := iic$vt_network_command_char;
          vt_attributes [j].network_command_character := terminal_attributes [i].network_command_character;
        = ifc$page_length =
          vt_attributes [j].kind := iic$vt_page_length;
          vt_attributes [j].page_length := terminal_attributes [i].page_length;
        = ifc$page_width =
          vt_attributes [j].kind := iic$vt_page_width;
          vt_attributes [j].page_width := terminal_attributes [i].page_width;
        = ifc$parity =
          vt_attributes [j].kind := iic$vt_parity;
          vt_attributes [j].parity := terminal_attributes [i].parity;
        = ifc$status_action =
          vt_attributes [j].kind := iic$vt_status_action;
          vt_attributes [j].status_action := terminal_attributes [i].status_action;
        = ifc$terminal_model =
          vt_attributes [j].kind := iic$vt_terminal_model;
          vt_attributes [j].terminal_model := terminal_attributes [i].terminal_model;
        = ifc$code_set_name =
          vt_attributes [j].kind := iic$vt_code_set_name;
          #TRANSLATE (osv$lower_to_upper, terminal_attributes [i].
            code_set_name^.value, destination_source);
          vt_attributes [j].code_set_name :=
            terminal_attributes [i].code_set_name^;
          vt_attributes [j].code_set_name.value := destination_source;
        = ifc$control_code_replacement =
          vt_attributes [j].kind := iic$vt_control_code_replacement;
          vt_attributes [j].control_code_replacement.
            total_substitution_count := terminal_attributes [i].
              control_code_replacement^.total_substitution_count;
          IF terminal_attributes [i].control_code_replacement^.
            total_substitution_count <> 0 THEN
            FOR k := 1 TO terminal_attributes [i].control_code_replacement^.
              total_substitution_count  DO
              vt_attributes [j].control_code_replacement.
                value[k].original_control_code := terminal_attributes [i].
                  control_code_replacement^.value[k].original_control_code;
              vt_attributes [j].control_code_replacement.
                value[k].substitute_control_code := terminal_attributes [i].
                  control_code_replacement^.value[k].substitute_control_code;
            FOREND;
          IFEND;
        ELSE
          vt_attributes [j].kind := iic$vt_fill0;
        CASEND;
      FOREND;

  PROCEND iip$terminal_to_vt_attributes;
?? TITLE := 'PROCEDURE iip$terminal_keys_to_vt_kinds', EJECT ??

  PROCEDURE [XDCL] iip$terminal_keys_to_vt_kinds (terminal_attributes: ift$terminal_attributes;
    VAR vt_kinds: iit$vt_attribute_kinds);

{   This routine is needed by IFP$GET_TERMINAL_ATTRIBUTES to build a iit$vt_attribute_kinds array
{   which will subsequently be used as input on a iip$vt_query_attributes call.

    VAR
      i: integer;

    FOR i := LOWERBOUND (terminal_attributes) TO UPPERBOUND (terminal_attributes) DO
      vt_kinds [i] := translate_if_keys_to_vt_kinds [terminal_attributes [i].key];
    FOREND;

  PROCEND iip$terminal_keys_to_vt_kinds;

?? TITLE := 'PROCEDURE iip$vt_to_connection_attributes', EJECT ??

  PROCEDURE [XDCL] iip$vt_to_connection_attributes (vt_attributes: iit$vt_attributes;
    VAR if_attributes: ift$connection_attributes);

{   Convert an array of iit$vt_attribute records to an equivalent array of
{   ift$connection_attribute records.

    VAR
      i: integer,
      j: integer;

      j := 0;
      FOR i := LOWERBOUND (vt_attributes) TO UPPERBOUND (vt_attributes) DO
        j := j + 1;
        CASE vt_attributes [i].kind OF
        = iic$vt_attention_char_action =
          if_attributes [j].key := ifc$attention_character_action;
          if_attributes [j].attention_character_action := vt_attributes [i].attention_character_action;
        = iic$vt_break_key_action =
          if_attributes [j].key := ifc$break_key_action;
          if_attributes [j].break_key_action := vt_attributes [i].break_key_action;
        = iic$vt_input_block_size =
          if_attributes [j].key := ifc$input_block_size;
          if_attributes [j].input_block_size := vt_attributes [i].input_block_size;
        = iic$vt_input_editing_mode =
          if_attributes [j].key := ifc$input_editing_mode;
          if_attributes [j].input_editing_mode := vt_attributes [i].input_editing_mode;
        = iic$vt_input_output_mode =
          if_attributes [j].key := ifc$input_output_mode;
          if_attributes [j].input_output_mode := vt_attributes [i].input_output_mode;
        = iic$vt_partial_char_forwarding =
          if_attributes [j].key := ifc$partial_char_forwarding;
          if_attributes [j].partial_character_forwarding := vt_attributes [i].partial_char_forwarding;
        = iic$vt_store_backspace_char =
          if_attributes [j].key := ifc$store_backspace_character;
          if_attributes [j].store_backspace_character := vt_attributes [i].store_backspace_character;
        = iic$vt_store_nuls_dels =
          if_attributes [j].key := ifc$store_nuls_dels;
          if_attributes [j].store_nuls_dels := vt_attributes [i].store_nuls_dels;
        = iic$vt_trans_character_mode =
          if_attributes [j].key := ifc$trans_character_mode;
          if_attributes [j].trans_character_mode := vt_attributes [i].trans_character_mode;
        = iic$vt_trans_forward_character =
          if_attributes [j].key := ifc$trans_forward_character;
          if_attributes [j].trans_forward_character := vt_attributes [i].trans_forward_character;
        = iic$vt_trans_length_mode =
          if_attributes [j].key := ifc$trans_length_mode;
          if_attributes [j].trans_length_mode := vt_attributes [i].trans_length_mode;
        = iic$vt_trans_timeout_mode =
          if_attributes [j].key := ifc$trans_timeout_mode;
          if_attributes [j].trans_timeout_mode := vt_attributes [i].trans_timeout_mode;
        = iic$vt_trans_message_length =
          if_attributes [j].key := ifc$trans_message_length;
          if_attributes [j].trans_message_length := vt_attributes [i].trans_message_length;
        = iic$vt_trans_protocol_mode =
          if_attributes [j].key := ifc$trans_protocol_mode;
          if_attributes [j].trans_protocol_mode := vt_attributes [i].trans_protocol_mode;
        = iic$vt_trans_term_character =
          if_attributes [j].key := ifc$trans_terminate_character;
          if_attributes [j].trans_terminate_character := vt_attributes [i].trans_terminate_character;
        ELSE
          {}
        CASEND;
      FOREND;

  PROCEND iip$vt_to_connection_attributes;

?? TITLE := 'PROCEDURE iip$connection_to_vt_attributes', EJECT ??

  PROCEDURE [XDCL] iip$connection_to_vt_attributes (connection_desc_ptr: ^iit$connection_description;
        if_attributes: ift$connection_attributes;
    VAR status: ost$status);

{   Convert an array of ift$connection_attribute records into an equivalent array
{   of iit$vt_attribute records.

    VAR
      activity_status: [STATIC, oss$task_shared {namve workaround}] ost$activity_status,
      attempt_count: integer,
      attribute_error_pairs: [STATIC, oss$task_shared {namve workaround}] array [1 .. 2] of iit$vt_attribute,
      attribute_sequence: ^SEQ ( * ),
      attribute_sequence_size : integer,
      downline_lock_already_set: boolean,
      error_code: iit$vt_change_error_codes,
      exit_in_progress: boolean,
      get_lock_already_set: boolean,
      i: integer,
      j: integer,
      local_status: ost$status,
      ls: ost$signature_lock_status,
      response_received: boolean,
      vt_attribute: iit$vt_attribute,
      vt_attributes: ^iit$vt_attributes,
      vtp_file_id: amt$file_identifier;
?? NEWTITLE := 'PROCEDURE handle_condition', EJECT ??

    PROCEDURE handle_condition (cond: pmt$condition;
          cd: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR ch_status: ost$status);

      ch_status.normal := TRUE;

      IF cond.selector = pmc$block_exit_processing THEN
        IF NOT downline_lock_already_set THEN
          osp$test_sig_lock (iiv$downline_queue_lock, ls);
          IF ls = osc$sls_locked_by_current_task THEN
            RESET connection_desc_ptr^.output_buffer_entry_loc;
            RESET connection_desc_ptr^.output_buffer_exit_loc;
            connection_desc_ptr^.downline_queue_count := 0;
            iip$clear_lock (iiv$downline_queue_lock, local_status);
          IFEND;
        IFEND;
        IF NOT get_lock_already_set THEN
          osp$test_sig_lock (connection_desc_ptr^.st_get_lock, ls);
          IF ls = osc$sls_locked_by_current_task THEN
            iip$clear_lock (connection_desc_ptr^.st_get_lock, local_status);
          IFEND;
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
        IF exit_in_progress THEN
          EXIT iip$connection_to_vt_attributes;
        IFEND;
      IFEND;
    PROCEND handle_condition;

?? OLDTITLE, EJECT ??

  /connection_to_vt_attributes/
    BEGIN

      exit_in_progress := FALSE;
      osp$establish_condition_handler (^handle_condition, TRUE);

      { note - usage of task shared heap rather than PUSH is namve workaround for ring voting }
      attribute_sequence_size := UPPERBOUND (if_attributes) *
        #size(vt_attribute);
      ALLOCATE attribute_sequence: [[REP attribute_sequence_size OF CELL]] IN osv$task_shared_heap^;
      RESET attribute_sequence;
      NEXT vt_attributes: [1 .. UPPERBOUND (if_attributes)] IN attribute_sequence;
      j := 0;
      FOR i := LOWERBOUND (if_attributes) TO UPPERBOUND (if_attributes) DO
        j := j + 1;
        IF ($INTEGER(if_attributes[i].key) >=
          $integer(ifc$attention_character_action)) AND
          ($INTEGER(if_attributes[i].key) <=
          $INTEGER(ifc$trans_protocol_mode)) THEN
        CASE if_attributes [i].key OF
        = ifc$attention_character_action =
          vt_attributes^ [j].kind := iic$vt_attention_char_action;
          vt_attributes^ [j].attention_character_action := if_attributes [i].attention_character_action;
        = ifc$break_key_action =
          vt_attributes^ [j].kind := iic$vt_break_key_action;
          vt_attributes^ [j].break_key_action := if_attributes [i].break_key_action;
        = ifc$input_block_size =
          vt_attributes^ [j].kind := iic$vt_input_block_size;
          vt_attributes^ [j].input_block_size := if_attributes [i].input_block_size;
        = ifc$input_editing_mode =
          vt_attributes^ [j].kind := iic$vt_input_editing_mode;
          vt_attributes^ [j].input_editing_mode := if_attributes [i].input_editing_mode;
        = ifc$input_output_mode =
          vt_attributes^ [j].kind := iic$vt_input_output_mode;
          vt_attributes^ [j].input_output_mode := if_attributes [i].input_output_mode;
        = ifc$partial_char_forwarding =
          vt_attributes^ [j].kind := iic$vt_partial_char_forwarding;
          vt_attributes^ [j].partial_char_forwarding := if_attributes [i].partial_character_forwarding;
        = ifc$store_backspace_character =
          vt_attributes^ [j].kind := iic$vt_store_backspace_char;
          vt_attributes^ [j].store_backspace_character := if_attributes [i].store_backspace_character;
        = ifc$store_nuls_dels =
          vt_attributes^ [j].kind := iic$vt_store_nuls_dels;
          vt_attributes^ [j].store_nuls_dels := if_attributes [i].store_nuls_dels;
        = ifc$trans_character_mode =
          vt_attributes^ [j].kind := iic$vt_trans_character_mode;
          vt_attributes^ [j].trans_character_mode := if_attributes [i].trans_character_mode;
        = ifc$trans_forward_character =
          vt_attributes^ [j].kind := iic$vt_trans_forward_character;
          vt_attributes^ [j].trans_forward_character := if_attributes [i].trans_forward_character;
        = ifc$trans_length_mode =
          vt_attributes^ [j].kind := iic$vt_trans_length_mode;
          vt_attributes^ [j].trans_length_mode := if_attributes [i].trans_length_mode;
        = ifc$trans_timeout_mode =
          vt_attributes^ [j].kind := iic$vt_trans_timeout_mode;
          vt_attributes^ [j].trans_timeout_mode := if_attributes [i].trans_timeout_mode;
        = ifc$trans_message_length =
          vt_attributes^ [j].kind := iic$vt_trans_message_length;
          vt_attributes^ [j].trans_message_length := if_attributes [i].trans_message_length;
        = ifc$trans_protocol_mode =
          vt_attributes^ [j].kind := iic$vt_trans_protocol_mode;
          vt_attributes^ [j].trans_protocol_mode := if_attributes [i].trans_protocol_mode;
        = ifc$trans_terminate_character =
          vt_attributes^ [j].kind := iic$vt_trans_term_character;
          vt_attributes^ [j].trans_terminate_character := if_attributes [i].trans_terminate_character;
        ELSE
          j := j - 1;
        CASEND;
        ELSE
          j := j - 1;
        IFEND;
      FOREND;

      IF j <> 0 THEN

        RESET attribute_sequence;
        NEXT vt_attributes: [1 .. j] IN attribute_sequence;

        iip$vt_open (connection_desc_ptr^.session_layer_file_name, vtp_file_id, status);
        IF NOT status.normal THEN
          EXIT /connection_to_vt_attributes/;
        IFEND;

        attempt_count := 0;
        REPEAT
          attempt_count := attempt_count + 1;
          osp$test_sig_lock (iiv$downline_queue_lock, ls);
          IF ls = osc$sls_locked_by_current_task THEN
            downline_lock_already_set := TRUE;
            #spoil(downline_lock_already_set);
          ELSE
            downline_lock_already_set := FALSE;
            #spoil(downline_lock_already_set);
            iip$set_lock (iiv$downline_queue_lock, osc$wait, status);
            IF NOT status.normal THEN
              EXIT /connection_to_vt_attributes/;
            IFEND;
          IFEND;
          iip$vt_change_attributes (connection_desc_ptr^.vtp_connection_id, vtp_file_id, vt_attributes^,
                osc$wait, activity_status, status);
          IF NOT status.normal THEN
            IF NOT downline_lock_already_set THEN
              iip$clear_lock (iiv$downline_queue_lock, local_status);
            IFEND;
            EXIT /connection_to_vt_attributes/;
          IFEND;
          IF NOT downline_lock_already_set THEN
            iip$clear_lock (iiv$downline_queue_lock, status);
            IF NOT status.normal THEN
              EXIT /connection_to_vt_attributes/;
            IFEND;
          IFEND;

          osp$test_sig_lock (connection_desc_ptr^.st_get_lock, ls);
          IF ls <> osc$sls_not_locked THEN
            get_lock_already_set := TRUE;
          ELSE
            get_lock_already_set := FALSE;
            iip$set_lock (connection_desc_ptr^.st_get_lock, osc$wait, status);
            IF NOT status.normal THEN
              EXIT /connection_to_vt_attributes/;
            IFEND;
          IFEND;
          IF (ls = osc$sls_locked_by_current_task) OR (NOT get_lock_already_set) THEN
            iip$vt_get_change_response (connection_desc_ptr^.vtp_connection_id, vtp_file_id, osc$wait,
                  error_code, attribute_error_pairs, response_received, status);
            { status check will not happen till outside of loop }
          IFEND;
          IF NOT get_lock_already_set THEN
            iip$clear_lock (connection_desc_ptr^.st_get_lock, local_status);
          IFEND;
        UNTIL (attempt_count > 9) OR (status.normal) OR
              ((NOT status.normal) AND (status.condition <> nae$no_event)
              AND (status.condition <> nae$no_data_available)
              AND (status.condition <> nae$data_transfer_timeout));
        IF NOT status.normal THEN
          EXIT /connection_to_vt_attributes/;
        IFEND;

        iip$vt_close (vtp_file_id, status);
        IF NOT status.normal THEN
          EXIT /connection_to_vt_attributes/;
        IFEND;

      IFEND;  { j <> 0 }
      FREE attribute_sequence IN osv$task_shared_heap^;

    END /connection_to_vt_attributes/;

    osp$disestablish_cond_handler;

  PROCEND iip$connection_to_vt_attributes;

MODEND iim$vtt_ift_conversion_routines;
*DECK DECK=IIM$VT_VALIDATE_FILE_IDENTIFIER EXPAND=TRUE
?? RIGHT := 110 ??
MODULE iim$vt_validate_file_identifier;
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc bat$task_file_table
?? POP ??

*copyc bap$validate_file_identifier

?? TITLE := '[XDCL] iip$vt_validate_file_identifier', EJECT ??

  PROCEDURE [XDCL] iip$vt_validate_file_identifier (file_identifier: amt$file_identifier;
    VAR file_name: amt$local_file_name;
    VAR file_id_is_valid: boolean);

    VAR
      file_instance: ^bat$task_file_entry;

    file_instance := NIL;
    bap$validate_file_identifier (file_identifier, file_instance, file_id_is_valid);
    IF file_instance <> NIL THEN
      file_name := file_instance^.local_file_name;
    ELSE
      file_name := '';
    IFEND;

  PROCEND iip$vt_validate_file_identifier;
MODEND iim$vt_validate_file_identifier;
*DECK DECK=IIM$XLATE_LOCAL_FILE_TO_SESSION EXPAND=TRUE
*copyc osd$default_pragmats
MODULE iim$xlate_local_file_to_session;

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc fmp$get_cycle_description
*copyc fmp$unlock_path_table
*copyc cle$ecc_lexical
*copyc clp$get_ultimate_connection
*copyc clp$validate_name
*copyc oss$task_private
*copyc osp$set_status_abnormal
*copyc osc$timesharing_terminal_file
?? POP ??


  PROCEDURE [XDCL, #GATE] iip$xlate_local_file_to_session (file_name: amt$local_file_name;
    VAR terminal_file_name: amt$local_file_name;
    VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      ultimate_name: amt$local_file_name,
      valid_name: boolean,
      validated_name: ost$name;


    terminal_file_name := osc$null_name;

    clp$validate_name (file_name, validated_name, valid_name);
    IF NOT valid_name THEN
      osp$set_status_abnormal ('CL', cle$improper_name, file_name, status);
      RETURN;
    IFEND;

    clp$get_ultimate_connection (validated_name, ultimate_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fmp$get_cycle_description (ultimate_name, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF cycle_description^.attached_file AND (cycle_description^.device_class = rmc$terminal_device) THEN
      terminal_file_name := cycle_description^.terminal_file_name;
    IFEND;
    fmp$unlock_path_table;

    IF terminal_file_name = osc$null_name THEN
      terminal_file_name := osc$timesharing_terminal_file;
    IFEND;

  PROCEND iip$xlate_local_file_to_session;

MODEND iim$xlate_local_file_to_session;
*DECK DECK=IIM$XT_CREATE_NETWORK_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Interactive Facility: Interfaces to emulate session' ??
MODULE iim$xt_create_network_file;

{ PURPOSE:
{   This module creates the network file to support xterm.
{
{ DESIGN:
{   The procedure iip$xt_create_network_file resembles the procedure
{   fmp$create_network_file. The cycle description.system file label.
{   descriptive_label.application_info_source uses amc$local_file_information
{   with the value set to osc$timesharing_terminal_file to indicate this
{   network file applies to xterm rather than other network interfaces.
{   The function iip$xt_is_xterm_file uses the above information.
{   The network_global_file_information.file_state is set to nac$connection_terminated
{   and the cycle_description^.global_file_information^.device_dependent_info.
{   network_connection_id is set to nac$null_connection_id so that NAM procedures
{   will ignore the the xterm network file.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc ame$lfn_program_actions
*copyc fmt$system_file_label
*copyc fst$evaluated_file_reference
*copyc fst$file_reference
*copyc nat$global_file_information
*copyc nac$null_connection_id
*copyc nat$connection_state
*copyc osc$timesharing_terminal_file
*copyc ost$status
?? POP ??

*copyc amp$get_next
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc amp$set_file_instance_abnormal
*copyc bap$set_evaluated_file_abnormal
*copyc fmp$evaluate_path
*copyc fmp$unlock_path_table
*copyc jmp$is_xterm_job
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osv$task_shared_heap

?? TITLE := 'PROCEDURE [XDCL, #GATE] iip$xt_create_network_file', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_create_network_file
    (VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      evaluated_file_reference: fst$evaluated_file_reference,
      network_global_file_information: ^nat$global_file_information;

    cycle_description := NIL;
    status.normal := TRUE;

    fmp$evaluate_path (osc$timesharing_terminal_file, $bat$process_pt_work_list
          [bac$resolve_path, bac$resolve_to_catalog, bac$return_cycle_description, bac$record_path,
          bac$create_cycle_description], evaluated_file_reference, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /path_table_locked/
    BEGIN
      IF ((cycle_description^.static_setfa_entries <> NIL) OR
            (cycle_description^.dynamic_setfa_entries <> NIL)) THEN
        bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_known, 'FMP$CREATE_NETWORK_FILE',
              '', status);
        EXIT /path_table_locked/;
      IFEND;

      IF NOT cycle_description^.attached_file THEN
        cycle_description^.attached_file := TRUE;
        cycle_description^.system_file_label.file_previously_opened := FALSE;
        cycle_description^.system_file_label.static_label := NIL;

{ The application_info_source and application_info values allow the system
{ to determine a normal network file from an xterm network file.

        cycle_description^.system_file_label.descriptive_label.application_info_source :=
              amc$local_file_information;
        cycle_description^.system_file_label.descriptive_label.application_info :=
              osc$timesharing_terminal_file;
        cycle_description^.system_file_label.descriptive_label.global_access_mode :=
              $pft$usage_selections [pfc$read, pfc$shorten, pfc$append, pfc$modify];
        cycle_description^.system_file_label.descriptive_label.global_access_mode_source :=
              amc$access_method_default;
        cycle_description^.system_file_label.descriptive_label.global_file_name_source :=
              amc$undefined_attribute;
        cycle_description^.system_file_label.descriptive_label.internal_cycle_name_source :=
              amc$undefined_attribute;
        cycle_description^.system_file_label.descriptive_label.global_share_mode := $pft$share_selections [];
        cycle_description^.system_file_label.descriptive_label.global_share_mode_source :=
              amc$access_method_default;
        cycle_description^.system_file_label.descriptive_label.permanent_file := FALSE;
        cycle_description^.device_class := rmc$network_device;
        cycle_description^.global_file_information^.device_dependent_info.device_class := rmc$network_device;
        ALLOCATE network_global_file_information IN osv$task_shared_heap^;

{ The connection terminated file status  prevents NAM from processing this connection.
{ The information only applies to xterm.

        network_global_file_information^.file_state := nac$connection_terminated;
        network_global_file_information^.connect.start_time := #FREE_RUNNING_CLOCK (0);
        network_global_file_information^.connect.down_time := 0;
        network_global_file_information^.connect.start_down_time :=
              network_global_file_information^.connect.start_time;
        network_global_file_information^.connect.valid_start_down_time := TRUE;
        network_global_file_information^.disconnect_indication := TRUE;
        cycle_description^.global_file_information^.device_dependent_info.network_global_file_information :=
              network_global_file_information;

{ The null connection id prevents NAM from processing this connection.  The information
{ only applies to xterm.

        cycle_description^.global_file_information^.device_dependent_info.network_connection_id :=
              nac$null_connection_id;
      ELSE
        osp$set_status_condition (ame$file_known, status);
      IFEND;

    END /path_table_locked/;

    fmp$unlock_path_table;

  PROCEND iip$xt_create_network_file;
MODEND iim$xt_create_network_file;
*DECK DECK=IIM$XT_XTERM_FAP EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE: IIM$XT_XTERM_FAP' ??
?? NEWTITLE := 'XREF TYPES' ??
MODULE iim$xt_xterm_fap;
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amt$call_block
*copyc ifc$interrupt
*copyc iic$xt_compiling_for_trace
*copyc ost$caller_identifier
*copyc ost$i_wait
*copyc ost$status
?? TITLE := 'CONDITION_CODES', EJECT ??
*copyc ame$device_class_validation
*copyc nae$application_interfaces
*copyc nae$namve_conditions
?? POP ??
?? TITLE := 'XREF PROCEDURES', EJECT ??
*copyc amp$set_file_instance_abnormal
*copyc bap$close
*copyc bap$fetch
*copyc bap$fetch_access_information
*copyc bap$store
*copyc iip$xt_open_file
*copyc iip$xt_close_file
*copyc iip$xt_fetch_attributes
*copyc iip$xt_receive_data
*copyc iip$xt_send_data
*copyc iip$xt_send_interrupt
*copyc iip$xt_synchronize
*copyc iip$xt_synchronize_confirm
*copyc iip$xt_store_attributes
*copyc iip$xt_write_trace
*copyc iip$xt_write_trace_status
*copyc iiv$xt_xterm_control_block
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$i_await_activity_completion
*copyc osp$set_status_abnormal
*copyc pmp$continue_to_cause
*copyc pmp$get_executing_task_gtid
*copyc pmp$long_term_wait
?? TITLE := 'iip$xt_xterm_fap', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_xterm_fap
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer: amt$fap_layer_number;
     VAR status: ost$status);

    PROCEDURE terminate_network_fap
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);


      PROCEDURE process_block_exit
        (    condition: pmt$condition;
             ignore_condition_descriptor: ^pmt$condition_information;
             sa: ^ost$stack_frame_save_area;
         VAR condition_status: ost$status);

        CASE call_block.operation OF
        = amc$get_next_req, amc$get_partial_req, nac$se_receive_data_req =

          IF (status.normal) AND ((call_block.operation <> nac$se_receive_data_req) OR
                ((call_block.operation = nac$se_receive_data_req) AND
                (call_block.se_receive_data_req.wait = osc$wait))) THEN
            WHILE NOT activity_status^.complete DO
              pmp$long_term_wait (wait_time, 0);
            WHILEND;
          IFEND;
        = amc$put_next_req, amc$put_partial_req, nac$se_send_data_req =

          IF (status.normal) AND ((call_block.operation <> nac$se_send_data_req) OR
                ((call_block.operation = nac$se_send_data_req) AND
                (call_block.se_send_data_req.wait = osc$wait))) THEN
            WHILE NOT activity_status^.complete DO
              pmp$long_term_wait (wait_time, 0);
            WHILEND;
          IFEND;
        ELSE
        CASEND;

      PROCEND process_block_exit;

      CASE condition.selector OF
      = ifc$interactive_condition =
        IF request_started THEN
          osp$establish_block_exit_hndlr (^process_block_exit);
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IF request_started THEN
          osp$disestablish_cond_handler;
        IFEND;
        condition_status.normal := TRUE;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          CASE call_block.operation OF
          = amc$get_next_req, amc$get_partial_req, nac$se_receive_data_req =
            osp$set_status_abnormal (nac$status_id, nae$job_recovery, '', status);
            pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
            EXIT iip$xt_xterm_fap;
          = amc$put_next_req, amc$put_partial_req, nac$se_send_data_req =
            osp$set_status_abnormal (nac$status_id, nae$job_recovery, '', status);
            pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
            EXIT iip$xt_xterm_fap;
          ELSE
            ;
          CASEND;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;
    PROCEND terminate_network_fap;

    PROCEDURE terminate_await_data_available
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$interrupt) THEN
        osp$set_status_abnormal (nac$status_id, nae$interactive_cond_interrupt, '', status);
        EXIT iip$xt_xterm_fap;
      IFEND;
    PROCEND terminate_await_data_available;
?? EJECT ??

    CONST
      nac$wait_to_receive_increment = 2000,
      nac$wait_to_send_increment = 2000;

    VAR
      activity_status: ^ost$activity_status,
      caller_id: ost$caller_identifier,
      end_time: integer,
      global_task_id: ost$global_task_id,
      ignore_structure_pointer: ^cell,
      ready_index: integer,
      request_started: boolean,
      start_time: integer,
      validation_ok: boolean,
      wait_list: array [1 .. 2] of ost$i_activity,
      wait_time: nat$wait_time;

    status.normal := TRUE;
    #CALLER_ID (caller_id);

    CASE call_block.operation OF

    = amc$open_req =
      iip$xt_open_file (file_identifier, layer, call_block, status);

    = amc$close_req =
      iip$xt_close_file (file_identifier, layer, call_block, status);
      bap$close (file_identifier, status);

    = amc$fetch_access_information_rq =
      bap$fetch_access_information (file_identifier, call_block, layer, status);

    = amc$fetch_req =
      bap$fetch (file_identifier, call_block, layer, status);

    = amc$store_req =
      bap$store (file_identifier, call_block, layer, status);

    = amc$get_next_req, amc$get_partial_req, nac$se_receive_data_req =
      IF call_block.operation = nac$se_receive_data_req THEN
        activity_status := call_block.se_receive_data_req.activity_status;
      ELSE
        PUSH activity_status;
        IF call_block.operation = amc$get_next_req THEN
          call_block.getn.byte_address^ := 0;
        ELSE
          call_block.getp.byte_address^ := 0;
        IFEND;
      IFEND;
      activity_status^.complete := TRUE;
      activity_status^.status.normal := TRUE;

      request_started := FALSE;
      start_time := #FREE_RUNNING_CLOCK (0);
      osp$establish_condition_handler (^terminate_network_fap, FALSE);
      iip$xt_receive_data (file_identifier, layer, call_block, start_time, request_started, wait_time,
            activity_status, status);
      WHILE (status.normal AND NOT request_started AND NOT activity_status^.complete) DO
        end_time := #FREE_RUNNING_CLOCK (0);
        IF wait_time > ((end_time - start_time) DIV 1000) THEN
          wait_time := wait_time - ((end_time - start_time) DIV 1000);
          IF wait_time > nac$wait_to_receive_increment THEN
            pmp$long_term_wait (nac$wait_to_receive_increment, 0);
          ELSE
            pmp$long_term_wait (wait_time, 0);
          IFEND;
          iip$xt_receive_data (file_identifier, layer, call_block, start_time, request_started, wait_time,
                activity_status, status);
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$data_transfer_timeout, '', status);
        IFEND;
      WHILEND;

    = amc$put_next_req, amc$put_partial_req, nac$se_send_data_req =
      IF call_block.operation = nac$se_send_data_req THEN
        activity_status := call_block.se_send_data_req.activity_status;
      ELSE
        PUSH activity_status;
        IF call_block.operation = amc$put_next_req THEN
          call_block.putn.byte_address^ := 0;
        ELSE
          call_block.putp.byte_address^ := 0;
        IFEND;
      IFEND;
      activity_status^.complete := TRUE;
      activity_status^.status.normal := TRUE;

      request_started := FALSE;
      start_time := #FREE_RUNNING_CLOCK (0);
      osp$establish_condition_handler (^terminate_network_fap, FALSE);
      iip$xt_send_data (file_identifier, layer, call_block, start_time, request_started, wait_time,
            activity_status, status);

    = nac$se_synchronize_req =
      iip$xt_synchronize (file_identifier, layer, call_block, status);

    = nac$se_synchronize_confirm_req =
      iip$xt_synchronize_confirm (file_identifier, layer, call_block, status);

    = nac$await_data_available =
      iip$xt_write_trace (' Begin await_data_available');
      IF iiv$xt_xterm_control_block.xterm_state >= iic$execute_xterm_task THEN
        pmp$get_executing_task_gtid (global_task_id);
        IF global_task_id = iiv$xt_xterm_control_block.xterm_global_task_id THEN
          osp$set_status_abnormal (nac$status_id, nae$no_data_available, '', status);
        ELSE
          wait_list [1].activity := nac$i_await_data_available;
          wait_list [1].file_identifier := file_identifier;
          wait_list [2].activity := osc$i_await_time;
          wait_list [2].milliseconds := call_block.await_data_available.wait_time;
          osp$establish_condition_handler (^terminate_await_data_available, FALSE);
          osp$i_await_activity_completion (wait_list, ready_index, status);
          IF (status.normal) AND (ready_index = 2) THEN
            osp$set_status_abnormal (nac$status_id, nae$no_data_available, '', status);
          IFEND;
        IFEND;
      IFEND;

      IF status.normal THEN
        iip$xt_write_trace (' Exit await_data_available');
      ELSE
        iip$xt_write_trace_status (' await_data_available failed', status);
      IFEND;

    = nac$fetch_attributes =
      iip$xt_fetch_attributes (file_identifier, layer, call_block, status);

    = nac$store_attributes =
      iip$xt_store_attributes (file_identifier, layer, call_block, status);

    = amc$flush_req, amc$rewind_req, amc$skip_req, amc$write_end_partition_req =
      ; {ignore request (return normal status)
    ELSE
      amp$set_file_instance_abnormal (file_identifier, ame$improper_device_class, call_block.operation,
            'CALL_BLOCK ERROR - iip$xt_xterm_fap', status);
    CASEND;

  PROCEND iip$xt_xterm_fap;

MODEND iim$xt_xterm_fap;

*DECK DECK=IIM$XT_XTERM_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Interactive Facility: Interfaces to emulate session' ??
MODULE iim$xt_xterm_interfaces;

{ PURPOSE:
{   This module provides interfaces to support X terminals.
{
{ DESIGN:
{   The Network Access Methods session layer is replaced by routines
{   in this module.  This module emulates the session layer for
{   communication with X terminals.
{   See Internal Design Specification DCS A9218.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc amt$working_storage_length
*copyc bat$task_file_table
*copyc clc$standard_file_names
*copyc clt$parameter_list
*copyc clt$parameter_list_text
*copyc clt$parameter_list_text_size
*copyc fmt$system_file_label
*copyc fst$file_reference
*copyc ift$terminal_attributes
*copyc iit$vt_input_header
*copyc iit$vt_input_information
*copyc iic$xt_compiling_for_trace
*copyc iic$xt_job_catalog_name
*copyc iic$xt_max_message_length
*copyc iic$xt_status_catalog_name
*copyc iic$xt_xterm_catalog_name
*copyc iit$xt_message_control_block
*copyc iit$xt_message_header
*copyc iit$xt_message_file_reference
*copyc iit$xt_trace_options
*copyc iit$xt_xterm_status
*copyc jmt$timesharing_signal
*copyc jmt$system_job_parameters
*copyc nae$application_interfaces
*copyc nae$internal_interactive_appl
*copyc nat$await_data_available
*copyc nat$change_attributes
*copyc nat$data_length
*copyc nat$get_attributes
*copyc nat$connection_state
*copyc nat$se_receive_data_req
*copyc nat$se_send_data_req
*copyc nat$se_synchronize_req
*copyc nat$data_fragments
*copyc nat$wait_time
*copyc osc$timesharing_terminal_file
*copyc ost$activity_status
*copyc ost$caller_identifier
*copyc ost$status
*copyc ost$string
*copyc ost$user_identification
*copyc oss$job_paged_literal
*copyc osc$xterm_application_name
?? POP ??

*copyc amp$get_next
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc amp$set_file_instance_abnormal
*copyc bap$validate_file_identifier
*copyc clp$convert_string_to_file
*copyc clp$convert_str_to_path_handle
*copyc clp$count_list_elements
*copyc clp$evaluate_sub_parameters
*copyc clp$define_initial_application
*copyc clp$get_date_string
*copyc clp$get_system_file_id
*copyc clp$get_time_string
*copyc clp$get_variable
*copyc clp$get_variable_value
*copyc clp$get_work_area
*copyc clp$include_file
*copyc clp$set_working_catalog
*copyc clp$trimmed_string_size
*copyc clp$update_connected_files
*copyc pfp$purge
*copyc pmp$get_account_project
*copyc fsp$close_file
*copyc fsp$open_file
*copyc i#current_sequence_position
*copyc i#move
*copyc iip$xt_create_network_file
*copyc jmp$is_xterm_job
*copyc jmp$logout
*copyc jmp$set_job_termination_status
*copyc jmp$submit_job
*copyc pfp$convert_fs_path_to_pf_path
*copyc pfp$convert_string_to_fs_path
*copyc pfp$purge
*copyc pmp$execute
*copyc pmp$get_global_task_id
*copyc pmp$get_job_monitor_gtid
*copyc pmp$get_job_names
*copyc pmp$get_unique_name
*copyc pmp$wait
*copyc qfp$set_interactive_jrd_jad
*copyc qfp$set_terminal_name
*copyc rmp$request_terminal
*copyc osp$clear_job_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$get_status_condition_string
*copyc osp$i_await_activity_completion
*copyc osp$initialize_sig_lock
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$test_sig_lock
*copyc pfp$define_catalog
*copyc pmp$continue_to_cause
*copyc pmp$get_executing_task_gtid
*copyc pmp$log
*copyc pmp$ready_task
*copyc pmp$send_signal
*copyc pmp$terminate

*copyc iiv$connection_desc_ptr
*copyc iiv$interactive_terminated
*copyc iiv$xt_xterm_control_block
*copyc iiv$xt_xterm_downline
*copyc iiv$xt_xterm_task_output
*copyc iiv$xt_xterm_upline
*copyc jmv$connection_acquired
*copyc jmv$executing_within_system_job
*copyc jmv$job_attributes
*copyc osv$task_private_heap
*copyc osv$task_shared_heap


?? TITLE := 'define_xterm_catalog', EJECT ??

  PROCEDURE define_xterm_catalog
    (VAR status: ost$status);

    VAR
      path: array [1 .. 3] of pft$name;

    path [pfc$family_name_index] := osc$null_name;
    path [pfc$master_catalog_name_index] := osc$null_name;
    path [pfc$subcatalog_name_index] := iic$xt_xterm_catalog_name;
    pfp$define_catalog (path, status);
    IF NOT status.normal AND (status.condition = pfe$name_already_subcatalog) THEN
      status.normal := TRUE;
    IFEND;

  PROCEND define_xterm_catalog;

?? TITLE := '[XDCL, #GATE] iip$xt_check_upline', EJECT ??

?? OLDTITLE, EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_check_upline
    (    file_identifier: amt$file_identifier;
     VAR activity_complete: boolean;
     VAR status: ost$status);

    VAR
      get_p: ^SEQ ( * ),
      global_task_id: ost$global_task_id,
      put_p: ^SEQ ( * ),
      sequence_p: ^SEQ ( * ),
      xt_message_control_block_p: ^iit$xt_message_control_block;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF condition.selector = pmc$block_exit_processing THEN
        iip$xt_unlock_upline_messages (ignore_status);
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      IFEND;
    PROCEND condition_handler;

    status.normal := TRUE;
    activity_complete := FALSE;
    sequence_p := iiv$xt_xterm_upline.segment_pointer.sequence_pointer;
    RESET sequence_p;
    NEXT xt_message_control_block_p IN sequence_p;
    get_p := #PTR (xt_message_control_block_p^.get_p, sequence_p^);
    put_p := #PTR (xt_message_control_block_p^.put_p, sequence_p^);

    IF ((i#current_sequence_position (put_p) > i#current_sequence_position (get_p)) AND
          (xt_message_control_block_p^.terminate_option = iic$xt_terminate_record)) THEN
      activity_complete := TRUE;
      ?IF iic$xt_compiling_for_trace THEN
        iip$xt_write_trace (' Exit iip$xt_check_upline - activity complete upline');
      ?IFEND;
    ELSE { Activity is not complete.
      IF iiv$xt_xterm_control_block.status.complete THEN

{ Xterm task has completed.  Terminate job.

        pmp$get_executing_task_gtid (global_task_id);
        send_disconnect_signal (global_task_id);
      IFEND;

      osp$establish_condition_handler (^condition_handler, TRUE);

{ Xterm task and user task may modify upline messages.

      iip$xt_lock_upline_messages ({ignore status} status);
      IF iiv$xt_xterm_control_block.upline_state = iic$xt_inactive THEN

{ When xterm task sends some data on upline, ready this task.

        pmp$get_executing_task_gtid (global_task_id);
        iiv$xt_xterm_control_block.upline_global_task_id := global_task_id;
        iiv$xt_xterm_control_block.upline_state := iic$xt_wait_for_data;
      IFEND;
      iip$xt_unlock_upline_messages ({ignore status} status);
      osp$disestablish_cond_handler;

{ User or job monitor task is waiting for xterm task to complete some work so
{ ready xterm task.

      IF iiv$xt_xterm_control_block.xterm_state >= iic$execute_xterm_task THEN
        pmp$ready_task (iiv$xt_xterm_control_block.xterm_global_task_id, status);
        IF NOT status.normal THEN
          pmp$get_executing_task_gtid (global_task_id);
          send_disconnect_signal (global_task_id);
        IFEND;
      IFEND;
    IFEND;

  PROCEND iip$xt_check_upline;

?? TITLE := '[XDCL, #GATE] iip$xt_close_file', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_close_file
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

    VAR
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean;

    status.normal := TRUE;
    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_condition (ame$improper_file_id, status);
      RETURN;
    IFEND;

    IF file_instance^.eoi_message <> NIL THEN
      FREE file_instance^.eoi_message IN osv$task_private_heap^;
    IFEND;

  PROCEND iip$xt_close_file;

?? TITLE := '[XDCL, #GATE] iip$xt_create_message_file', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_create_message_file
    (    file_reference: fst$file_reference;
     VAR file_identifier: amt$file_identifier;
     VAR segment_pointer: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      attachment_option: array [1 .. 2] of fst$attachment_option,
      file_cycle_attribute: array [1 .. 1] of fst$file_cycle_attribute,
      get_p: ^SEQ ( * ),
      length: integer,
      message_control_block_p: ^iit$xt_message_control_block,
      remaining_sequence_length: integer,
      sequence_p: ^SEQ ( * );

    status.normal := TRUE;

{ Create segment used to pass information to xterm task.

    attachment_option [1].selector := fsc$access_and_share_modes;
    attachment_option [1].access_modes.selector := fsc$specific_access_modes;
    attachment_option [1].access_modes.value := $fst$file_access_options
          [fsc$read, fsc$append, fsc$shorten, fsc$modify];
    attachment_option [1].share_modes.selector := fsc$specific_share_modes;
    attachment_option [1].share_modes.value := $fst$file_access_options
          [fsc$read, fsc$append, fsc$shorten, fsc$modify];
    attachment_option [2].selector := fsc$open_share_modes;
    attachment_option [2].open_share_modes := $fst$file_access_options
          [fsc$read, fsc$append, fsc$shorten, fsc$modify];
    file_cycle_attribute [1].selector := fsc$ring_attributes;
    file_cycle_attribute [1].ring_attributes.r1 := 4;
    file_cycle_attribute [1].ring_attributes.r2 := 4;
    file_cycle_attribute [1].ring_attributes.r3 := 13;
    fsp$open_file (file_reference, amc$segment, {attachment options=} ^attachment_option,
          {default creation attributes=} ^file_cycle_attribute, {mandated creation attributes=} NIL,
          {attribute validation=} NIL, {attribute override=} NIL, file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_identifier, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sequence_p := segment_pointer.sequence_pointer;
    RESET sequence_p;
    NEXT message_control_block_p IN sequence_p;
    message_control_block_p^.count := 0;
    message_control_block_p^.global_task_id_defined := FALSE;
    message_control_block_p^.record_position := iic$xt_end_of_record;
    message_control_block_p^.status := iic$xt_file_created;
    message_control_block_p^.terminate_option := iic$xt_terminate_record;
    remaining_sequence_length := #SIZE (sequence_p^) - i#current_sequence_position (sequence_p);
    NEXT get_p: [[REP remaining_sequence_length OF cell]] IN sequence_p;
    RESET get_p;
    message_control_block_p^.get_p := #REL (get_p, sequence_p^);
    message_control_block_p^.put_p := message_control_block_p^.get_p;

  PROCEND iip$xt_create_message_file;

?? TITLE := '[XDCL, #GATE] iip$xt_create_xterm_files', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_create_xterm_files
    (VAR status: ost$status);

    VAR
      length: integer,
      message_file_name: iit$xt_message_file_reference,
      null_attribute: [STATIC, READ, oss$job_paged_literal] array
            [1 .. 1] of ift$connection_attribute := [[ifc$null_connection_attribute]],
      unique_name: ost$name;

    iip$xt_create_network_file (status);
    IF NOT status.normal THEN
      ?IF iic$xt_compiling_for_trace THEN
        iip$xt_write_trace_status (' fmp$create_network_file failed', status);
      ?IFEND;
      RETURN;
    IFEND;

{ Create downline file for sending messages to xterm task.

    iiv$xt_xterm_control_block.downline_file_reference := '$local.';
    pmp$get_unique_name (unique_name, {ignore} status);
    iiv$xt_xterm_control_block.downline_file_reference (8, * ) := unique_name;
    iip$xt_create_message_file (iiv$xt_xterm_control_block.downline_file_reference,
          iiv$xt_xterm_downline.file_identifier, iiv$xt_xterm_downline.segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    iiv$xt_xterm_downline.opened := TRUE;
    osp$initialize_sig_lock (iiv$xt_xterm_control_block.downline_lock);

{ Create upline file for xterm task to send to operating system.

    iiv$xt_xterm_control_block.upline_file_reference := '$local.';
    pmp$get_unique_name (unique_name, {ignore} status);
    iiv$xt_xterm_control_block.upline_file_reference (8, * ) := unique_name;
    iip$xt_create_message_file (iiv$xt_xterm_control_block.upline_file_reference,
          iiv$xt_xterm_upline.file_identifier, iiv$xt_xterm_upline.segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    iiv$xt_xterm_upline.opened := TRUE;
    osp$initialize_sig_lock (iiv$xt_xterm_control_block.upline_lock);

    qfp$set_terminal_name (osc$null_name);

{ Request terminal for standard job files.

    rmp$request_terminal (clc$job_command_input, NIL, null_attribute, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rmp$request_terminal (clc$job_input, NIL, null_attribute, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rmp$request_terminal (clc$job_output, NIL, null_attribute, status);

  PROCEND iip$xt_create_xterm_files;

?? TITLE := '[XDCL, #GATE] iip$xt_execute_xterm_command', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_execute_xterm_command
    (VAR status: ost$status);

    CONST
      xterm_status_wait_time = 2*1000, {2 seconds.
      xterm_wait_time = 1000;

    VAR
      activity_status_p: ^ost$activity_status,
      attachment_option: array [1 .. 3] of fst$attachment_option,
      file_identifier: amt$file_identifier,
      file_reference: string ({$user.} 6 + {xterm catalog name} 31 + {.} 1 +
            {status catalog name} 31 + {.} 1 + {system_supplied_name} 31),
      file_reference_length: integer,
      file_status: ost$status,
      i_activity: array [1 .. 2] of ost$i_activity,
      ready_index: integer,
      segment_pointer: amt$segment_pointer,
      sequence_p: ^SEQ ( * ),
      system_supplied_name: jmt$system_supplied_name,
      times: 1 .. 5,
      user_supplied_name: jmt$user_supplied_name,
      xterm_status_p: ^iit$xt_xterm_status;

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF condition.selector = pmc$block_exit_processing THEN
        iip$xt_unlock_upline_messages (ignore_status);
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      IFEND;
    PROCEND condition_handler;

    status.normal := TRUE;
    i_activity [1].activity := osc$i_await_time;
    i_activity [1].milliseconds := xterm_wait_time;
    i_activity [2].activity := osc$i_await_unspecified_event;
    osp$establish_condition_handler (^condition_handler, TRUE);

{ Wait for xterm task to send an upline message indicating that xterm is
{ ready to start executing commands. The terminal user may specify the
{ initial command through the xterm -e option.

    WHILE ((iiv$xt_xterm_control_block.xterm_state < iic$execute_initial_command) AND status.normal) DO
      pmp$ready_task (iiv$xt_xterm_control_block.xterm_global_task_id, status);
      IF status.normal THEN
        osp$i_await_activity_completion (i_activity, ready_index, status);
      IFEND;
      IF status.normal THEN
        iip$xt_lock_upline_messages ({ignore} status);
        process_upline_command;
        iip$xt_unlock_upline_messages ({ignore} status);
        status.normal := TRUE;
      IFEND;
    WHILEND;

    osp$disestablish_cond_handler;

{ Tell xterm origin job xterm has finished startup.  The xterm job communicates with
{ the origin job via a segment access file.

    attachment_option [1].selector := fsc$access_and_share_modes;
    attachment_option [1].access_modes.selector := fsc$specific_access_modes;
    attachment_option [1].access_modes.value := $fst$file_access_options
          [fsc$read, fsc$append, fsc$shorten, fsc$modify];
    attachment_option [1].share_modes.selector := fsc$specific_share_modes;
    attachment_option [1].share_modes.value := $fst$file_access_options
          [fsc$read, fsc$append, fsc$shorten, fsc$modify];
    attachment_option [2].selector := fsc$open_share_modes;
    attachment_option [2].open_share_modes := $fst$file_access_options
          [fsc$read, fsc$append, fsc$shorten, fsc$modify];
    attachment_option [3].selector := fsc$create_file;
    attachment_option [3].create_file := FALSE;
    pmp$get_job_names (user_supplied_name, system_supplied_name, file_status);
    IF NOT file_status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (file_reference, file_reference_length, '$USER.',iic$xt_xterm_catalog_name,
          '.', iic$xt_status_catalog_name, '.', system_supplied_name);

{ Job starting xterm creates a $USER.$XTERM.$STATUS.system_supplied_name file.
{ Wait some time for this file to appear.  A number of factors may prevent the
{ creation of the file.  Continue if the file does not exist after a
{ period of time.

   /wait_for_status_file/
    FOR times := LOWERVALUE (times) TO UPPERVALUE (times) DO
      fsp$open_file (file_reference (1, file_reference_length), amc$segment,
            {attachment options=} ^attachment_option,
            {default creation attributes=} NIL, {mandated creation attributes=} NIL,
            {attribute validation=} NIL, {attribute override=} NIL, file_identifier, file_status);
      IF file_status.normal THEN
        EXIT /wait_for_status_file/;
      IFEND;
      IF ((file_status.condition = pfe$unknown_nth_subcatalog) OR
            (file_status.condition = pfe$unknown_permanent_file)) THEN
        pmp$wait (xterm_status_wait_time, xterm_status_wait_time);
      ELSE
        EXIT /wait_for_status_file/;
      IFEND;
    FOREND /wait_for_status_file/;

    IF NOT file_status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_identifier, amc$sequence_pointer, segment_pointer, file_status);
    IF NOT file_status.normal THEN
      fsp$close_file (file_identifier, {ignore} file_status);
      RETURN;
    IFEND;

{ Set activity status complete and ready task of the job submitting xterm.
{ This causes the job submitting xterm to come out of wait and process
{ any errors recorded in the $XTERM.$JOBS.SYSTEM_SUPPLIED_NAME file.

    sequence_p := segment_pointer.sequence_pointer;
    RESET sequence_p;
    NEXT xterm_status_p IN sequence_p;
    xterm_status_p^.activity_status.complete := TRUE;
    xterm_status_p^.activity_status.status := status;
    pmp$ready_task (xterm_status_p^.global_task_id, {ignore} file_status);
    fsp$close_file (file_identifier, {ignore} file_status);

  PROCEND iip$xt_execute_xterm_command;

?? TITLE := '[XDCL, #GATE] iip$xt_get_terminal_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_get_terminal_attributes
    (    file_name: amt$local_file_name;
     VAR terminal_attributes: ift$terminal_attributes;
     VAR status: ost$status);

    VAR
      attribute_index: integer;

    status.normal := TRUE;

{ Provide default attributes for C to start up a program.

    FOR attribute_index := LOWERBOUND (terminal_attributes) TO UPPERBOUND (terminal_attributes) DO
      CASE terminal_attributes [attribute_index].key OF

      = ifc$backspace_character =
        terminal_attributes [attribute_index].backspace_character := $CHAR (8);

{Backspace

      = ifc$cancel_line_character =
        terminal_attributes [attribute_index].cancel_line_character := $CHAR (24); {Cancel}

      = ifc$character_flow_control =
        terminal_attributes [attribute_index].character_flow_control := TRUE;

      = ifc$echoplex =
        terminal_attributes [attribute_index].echoplex := FALSE;

      = ifc$hold_page =
        terminal_attributes [attribute_index].hold_page := TRUE;

      = ifc$parity =
        terminal_attributes [attribute_index].parity := ifc$no_parity;

      ELSE
      CASEND;

    FOREND;

  PROCEND iip$xt_get_terminal_attributes;


?? TITLE := 'iip$xt_fetch_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_fetch_attributes
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

    VAR
      attribute_index: integer,
      file_is_valid: boolean,
      file_instance: ^bat$task_file_entry;

    status.normal := TRUE;
    ?IF iic$xt_compiling_for_trace THEN
      iip$xt_write_trace (' Begin iip$xt_fetch_attributes');
    ?IFEND;

    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_condition (ame$improper_file_id, status);
      RETURN;
    IFEND;

    IF call_block.fetch_attributes <> NIL THEN

    /attribute_loop/
      FOR attribute_index := LOWERBOUND (call_block.fetch_attributes^)
            TO UPPERBOUND (call_block.fetch_attributes^) DO
        CASE call_block.fetch_attributes^ [attribute_index].kind OF
        = nac$client_identity =

        = nac$connect_data =
          call_block.fetch_attributes^ [attribute_index].connect_data_length := 0;

        = nac$connection_state =

        = nac$data_transfer_timeout =
          call_block.fetch_attributes^ [attribute_index].data_transfer_timeout :=
                file_instance^.data_transfer_timeout;
        = nac$eoi_message =
          IF file_instance^.eoi_message <> NIL THEN
            call_block.fetch_attributes^ [attribute_index].eoi_message := file_instance^.eoi_message^;
          ELSE

{call_block.fetch_attributes^ [attribute_index].eoi_message := nav$eoi_message;

          IFEND;
        = nac$eoi_message_enabled =
          call_block.fetch_attributes^ [attribute_index].eoi_message_enabled :=
                file_instance^.eoi_message_enabled;
        = nac$eoi_peer_termination =
          call_block.fetch_attributes^ [attribute_index].eoi_peer_termination :=
                file_instance^.eoi_peer_termination;
        = nac$local_address =
        = nac$null_attribute =
        = nac$optimum_transfer_unit_incr =
        = nac$optimum_transfer_unit_size =
        = nac$peer_accounting_information =
          call_block.fetch_attributes^ [attribute_index].peer_accounting_info_length := 0;
        = nac$peer_address =
        = nac$peer_connect_data =
          call_block.fetch_attributes^ [attribute_index].peer_connect_data_length := 0;
        = nac$peer_termination_data =
          call_block.fetch_attributes^ [attribute_index].peer_termination_data_length := 0;
        = nac$protocol =
        = nac$receive_wait_swapout =
        = nac$termination_data =
          call_block.fetch_attributes^ [attribute_index].termination_data_length := 0;
        = nac$termination_reason =
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$unknown_attribute, ' on FETCH_ATTRIBUTES ', status);
        CASEND;
        IF NOT status.normal THEN
          EXIT /attribute_loop/;
        IFEND;
      FOREND /attribute_loop/;
    IFEND;

    ?IF iic$xt_compiling_for_trace THEN
      iip$xt_write_trace (' Exit iip$xt_fetch_attributes');
    ?IFEND;

  PROCEND iip$xt_fetch_attributes;

?? TITLE := '[XDCL, #GATE] iip$xt_initialize_xterm', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_initialize_xterm
    (VAR status: ost$status);

{ PROCEDURE initialize_xterm (
{   options, o: string 0..256 = $optional
{   trace: (BY_NAME) list of key
{       pc, dm, um
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: 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 .. 3] of clt$keyword_specification,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 3, 19, 14, 57, 59, 302],
    clc$command, 4, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OPTIONS                        ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['TRACE                          ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 134,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, 256, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [118, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [3], [
      ['DM                             ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['PC                             ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UM                             ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$options = 1,
      p$trace = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    CONST
      user_xterm_prolog = '$USER.$XTERM.PROLOG';

    VAR
      access_creation_selections: [STATIC, READ, oss$job_paged_literal] array [1 .. 1] of
            fst$file_cycle_attribute := [[fsc$file_contents_and_processor, amc$list, osc$null_name]],
      access_selections: [STATIC, READ, oss$job_paged_literal] array
            [1 .. 1] of fst$attachment_option := [[fsc$access_and_share_modes,
            [fsc$specific_access_modes, [fsc$read, fsc$append, fsc$modify]], [fsc$required_share_modes]]],
      caller_identifier: ost$caller_identifier,
      connection_id: nat$connection_id,
      data_value_p: ^clt$data_value,
      evaluated_file_reference: fst$evaluated_file_reference,
      file: clt$file,
      ignore_status: ost$status,
      list: clt$list_size,
      list_size: clt$list_size,
      network_file_name: ost$name,
      next_data_value_p: ^clt$data_value,
      null_parameters: string (40),
      object_files_p: ^pmt$object_file_list,
      parameters: string (31),
      parameters_p: ^record
        size: clt$parameter_list_text_size,
        value: clt$parameter_list_text,
      recend,
      program_parameters_p: ^pmt$program_parameters,
      program_attributes_p: ^pmt$program_attributes,
      program_descriptor_p: ^SEQ ( * ),
      task_id: pmt$task_id,
      task_status: pmt$task_status,
      term_conn_attributes: array [1 .. 7] of ift$connection_attribute,
      terminal_attributes: [STATIC, READ, oss$job_paged_literal] array [1 .. 7] of
            ift$connection_attribute := [[ifc$input_editing_mode, ifc$normal_edit], [ifc$input_timeout, TRUE],
            [ifc$input_timeout_length, 0], [ifc$input_timeout_purge, TRUE],
            [ifc$partial_char_forwarding, FALSE], [ifc$prompt_string, [1, ',']], * ],
      terminal_file_name: ost$name,
      work_area_p_p: ^^clt$work_area;

{ Process xterm parameters.

    clp$get_work_area (#RING (^work_area_p_p), work_area_p_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_sub_parameters (jmv$job_attributes.system_job_parameters.system_job_parameter, #SEQ (pdt),
          work_area_p_p^, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    iiv$xt_xterm_control_block.trace_set := $iit$xt_trace_set [];
    IF pvt [p$trace].specified THEN
      list_size := clp$count_list_elements (pvt [p$trace].value);
      next_data_value_p := pvt [p$trace].value;

    /get_next_key/
      FOR list := 1 TO list_size DO
        IF next_data_value_p^.element_value^.keyword_value = 'PC' THEN
          iiv$xt_xterm_control_block.trace_set := iiv$xt_xterm_control_block.trace_set +
                $iit$xt_trace_set [iic$xt_trace_procedures];
        ELSEIF next_data_value_p^.element_value^.keyword_value = 'UPLINE_MESSAGES' THEN
          iiv$xt_xterm_control_block.trace_set := iiv$xt_xterm_control_block.trace_set +
                $iit$xt_trace_set [iic$xt_trace_upline_messages];
        ELSEIF next_data_value_p^.element_value^.keyword_value = 'UM' THEN
          iiv$xt_xterm_control_block.trace_set := iiv$xt_xterm_control_block.trace_set +
                $iit$xt_trace_set [iic$xt_trace_upline_messages];
        ELSEIF next_data_value_p^.element_value^.keyword_value = 'DOWNLINE_MESSAGES' THEN
          iiv$xt_xterm_control_block.trace_set := iiv$xt_xterm_control_block.trace_set +
                $iit$xt_trace_set [iic$xt_trace_downline_messages];
        ELSEIF next_data_value_p^.element_value^.keyword_value = 'DM' THEN
          iiv$xt_xterm_control_block.trace_set := iiv$xt_xterm_control_block.trace_set +
                $iit$xt_trace_set [iic$xt_trace_downline_messages];
        IFEND;
        next_data_value_p := next_data_value_p^.link;
      FOREND /get_next_key/;
    IFEND;

{ Process commands that must execute before starting xterm task.

    clp$include_file (user_xterm_prolog, '', osc$null_name, status);
    IF NOT status.normal THEN
      status.normal := TRUE;
    IFEND;
    iiv$xt_xterm_control_block.xterm_state := iic$ran_prolog;

    ?IF iic$xt_compiling_for_trace THEN
      iip$xt_write_trace (jmv$job_attributes.system_job_parameters.system_job_parameter);
    ?IFEND;

{ Start xterm task.

    PUSH program_descriptor_p: [[REP (#SIZE (pmt$program_attributes) + #SIZE (amt$local_file_name)) OF cell]];
    RESET program_descriptor_p;
    NEXT program_attributes_p IN program_descriptor_p;
    program_attributes_p^.contents := $pmt$prog_description_contents
          [pmc$object_file_list_specified, pmc$preset_specified];
    program_attributes_p^.number_of_modules := 0;
    program_attributes_p^.number_of_libraries := 0;
    program_attributes_p^.number_of_object_files := 1;
    program_attributes_p^.preset := pmc$initialize_to_zero;
    NEXT object_files_p: [1 .. 1] IN program_descriptor_p;

    clp$get_variable_value ('XWF$XTERM_LIBRARY', data_value_p, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

    clp$convert_string_to_file (data_value_p^.file_value^, file, ignore_status);
    object_files_p^ [1] := file.local_file_name;
    IF pvt [p$options].specified THEN
      PUSH parameters_p: [STRLENGTH (pvt [p$options].value^.string_value^)];
      parameters_p^.size := STRLENGTH (pvt [p$options].value^.string_value^);
      parameters_p^.value := pvt [p$options].value^.string_value^;
    ELSE
      PUSH parameters_p: [0];
      parameters_p^.size := 0;
      parameters_p^.value := '';
    IFEND;

{ The xterm task expects to run with in $USER catalog.

    clp$set_working_catalog ('$USER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ?IF iic$xt_compiling_for_trace THEN
      iip$xt_write_trace (' Call execute xterm');
    ?IFEND;

    pmp$execute (program_descriptor_p^, #SEQ (parameters_p^) ^, osc$nowait,
          iiv$xt_xterm_control_block.task.id, iiv$xt_xterm_control_block.status, status);
    clp$set_working_catalog ('$LOCAL', ignore_status);
    IF NOT status.normal THEN
      ?IF iic$xt_compiling_for_trace THEN
        iip$xt_write_trace_status (' Xterm execute failed', status);
      ?IFEND;
      RETURN;
    IFEND;

    iiv$xt_xterm_control_block.xterm_state := iic$execute_xterm_task;
    iiv$xt_xterm_control_block.task.exists := TRUE;
    pmp$get_global_task_id (iiv$xt_xterm_control_block.task.id,
          iiv$xt_xterm_control_block.xterm_global_task_id, {ignore} status);

    ?IF iic$xt_compiling_for_trace THEN
      iip$xt_write_trace (' Exit iip$xt_initialize_xterm');
    ?IFEND;

  PROCEND iip$xt_initialize_xterm;

?? TITLE := '[XDCL, #GATE] iip$xt_is_xterm_file', EJECT ??

  FUNCTION [XDCL, #GATE] iip$xt_is_xterm_file
    (    system_file_label_p: ^fmt$system_file_label): boolean;

    iip$xt_is_xterm_file := jmp$is_xterm_job () AND
         (system_file_label_p^.descriptive_label.application_info_source = amc$local_file_information) AND
         (system_file_label_p^.descriptive_label.application_info = osc$timesharing_terminal_file);

  FUNCEND iip$xt_is_xterm_file;

?? TITLE := '[XDCL, #GATE] iip$xt_lock_downline_messages', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_lock_downline_messages
    (VAR status: ost$status);

    status.normal := TRUE;
    osp$set_job_signature_lock (iiv$xt_xterm_control_block.downline_lock);

  PROCEND iip$xt_lock_downline_messages;

?? TITLE := '[XDCL, #GATE] iip$xt_lock_upline_messages', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_lock_upline_messages
    (VAR status: ost$status);

    status.normal := TRUE;
    osp$set_job_signature_lock (iiv$xt_xterm_control_block.upline_lock);

  PROCEND iip$xt_lock_upline_messages;

?? TITLE := '[XDCL, #GATE] iip$xt_open_file', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_open_file
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean;

    status.normal := TRUE;

    ?IF iic$xt_compiling_for_trace THEN
      iip$xt_write_trace (' Begin iip$xt_open_file');
    ?IFEND;

    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_condition (ame$improper_file_id, status);
      RETURN;
    IFEND;

    file_instance^.sender_active := FALSE;
    file_instance^.receiver_active := FALSE;
    file_instance^.eoi_message := NIL;
    file_instance^.eoi_message_enabled := FALSE;
    file_instance^.data_transfer_timeout := 60000;
    file_instance^.eoi_peer_termination := FALSE;

    ?IF iic$xt_compiling_for_trace THEN
      iip$xt_write_trace (' Exit iip$xt_open_file');
    ?IFEND;

  PROCEND iip$xt_open_file;

?? TITLE := '[XDCL, #GATE] iip$xt_open_downline_messages', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_open_downline_messages
    (VAR file_identifier: amt$file_identifier;
     VAR segment_pointer: amt$segment_pointer;
     VAR status: ost$status);

    iip$xt_open_message_file (iiv$xt_xterm_control_block.downline_file_reference, file_identifier,
          segment_pointer, status);

  PROCEND iip$xt_open_downline_messages;

?? TITLE := 'iip$xt_open_message_file', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_open_message_file
    (    file_reference: fst$file_reference;
     VAR file_identifier: amt$file_identifier;
     VAR segment_pointer: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      attachment_option: array [1 .. 2] of fst$attachment_option,
      file_cycle_attribute: array [1 .. 1] of fst$file_cycle_attribute;

    status.normal := TRUE;

    ?IF iic$xt_compiling_for_trace THEN
      iip$xt_write_trace (' Begin iip$xt_open_message_file');
    ?IFEND;

    attachment_option [1].selector := fsc$access_and_share_modes;
    attachment_option [1].access_modes.selector := fsc$specific_access_modes;
    attachment_option [1].access_modes.value := $fst$file_access_options
          [fsc$read, fsc$append, fsc$shorten, fsc$modify];
    attachment_option [1].share_modes.selector := fsc$specific_share_modes;
    attachment_option [1].share_modes.value := $fst$file_access_options
          [fsc$read, fsc$append, fsc$shorten, fsc$modify];
    attachment_option [2].selector := fsc$open_share_modes;
    attachment_option [2].open_share_modes := $fst$file_access_options
          [fsc$read, fsc$append, fsc$shorten, fsc$modify];

    file_cycle_attribute [1].selector := fsc$ring_attributes;
    file_cycle_attribute [1].ring_attributes.r1 := 4;
    file_cycle_attribute [1].ring_attributes.r2 := 4;
    file_cycle_attribute [1].ring_attributes.r3 := 13;

    fsp$open_file (file_reference, amc$segment, {attachment options=} ^attachment_option,
          {default creation attributes=} ^file_cycle_attribute, {mandated creation attributes=} NIL,
          {attribute validation=} NIL, {attribute override=} NIL, file_identifier, status);
    IF NOT status.normal THEN
      ?IF iic$xt_compiling_for_trace THEN
        iip$xt_write_trace_status (' iip$xt_open_message_file', status);
      ?IFEND;
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_identifier, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ?IF iic$xt_compiling_for_trace THEN
      iip$xt_write_trace (' Exit iip$xt_open_message_file');
    ?IFEND;

  PROCEND iip$xt_open_message_file;

?? TITLE := '[XDCL, #GATE] iip$xt_open_upline_messages', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_open_upline_messages
    (VAR file_identifier: amt$file_identifier;
     VAR segment_pointer: amt$segment_pointer;
     VAR status: ost$status);

    iip$xt_open_message_file (iiv$xt_xterm_control_block.upline_file_reference, file_identifier,
          segment_pointer, status);

  PROCEND iip$xt_open_upline_messages;


?? TITLE := '[XDCL, #GATE] iip$xt_ready_task', EJECT ??



  PROCEDURE [XDCL, #GATE] iip$xt_ready_task
    (VAR status: ost$status);

    VAR
      global_task_id: ost$global_task_id;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF condition.selector = pmc$block_exit_processing THEN
        iip$xt_unlock_upline_messages (ignore_status);
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      IFEND;
    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    osp$establish_condition_handler (^condition_handler, TRUE);

{ Xterm task and user task may modify upline messages.

    iip$xt_lock_upline_messages ({ignore status} status);
    IF iiv$xt_xterm_control_block.upline_state = iic$xt_wait_for_data THEN
      pmp$ready_task (iiv$xt_xterm_control_block.upline_global_task_id, status);
      iiv$xt_xterm_control_block.upline_state := iic$xt_inactive;
    IFEND;
    iip$xt_unlock_upline_messages ({ignore status} status);
    status.normal := TRUE;
    osp$disestablish_cond_handler;

  PROCEND iip$xt_ready_task;

?? TITLE := '[XDCL, #GATE] iip$xt_receive_data', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_receive_data
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
         start_time: integer;
     VAR request_started: boolean;
     VAR wait_time: nat$wait_time;
     VAR activity_status: ^ost$activity_status;
     VAR status: ost$status);

    VAR
      command_line_p: ^clt$command_line,
      data_fragments_p: ^nat$data_fragments,
      data_length: integer,
      data_p: ^SEQ ( * ),
      get_p: ^SEQ ( * ),
      put_p: ^SEQ ( * ),
      message_length: integer,
      sequence_p: ^SEQ ( * ),
      vt_input_header_p: ^iit$vt_input_header,
      xt_message_header_p: ^iit$xt_message_header,
      xt_message_control_block_p: ^iit$xt_message_control_block;

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF condition.selector = pmc$block_exit_processing THEN
        iip$xt_unlock_downline_messages (ignore_status);
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      IFEND;
    PROCEND condition_handler;

    PROCEDURE move_data_fragments;

      VAR
        current_data_offset: integer,
        current_fragment_capacity: nat$data_length,
        data_cell_p: ^cell,
        data_offset: integer,
        data_ring: integer,
        data_segment: integer,
        data_start: integer,

{ This declaration exists solely to develop the address for the i#move which
{ moves data from
{ the container to the user's address space.

        fragment_array_p: ^array [1 .. 0ffffff(16)] of cell,
        fragment: nat$data_length,
        fragment_data_start: integer,
        fragment_index: integer,
        fragment_length: integer,
        remaining_data: integer;

      status.normal := TRUE;
      fragment_length := 0;
      data_length := 0;
      data_ring := #RING (data_p);
      data_segment := #SEGMENT (data_p);
      data_offset := #OFFSET (data_p);
      data_cell_p := #ADDRESS (data_ring, data_segment, data_offset);

    /get_total_data_area_length/
      FOR fragment_index := 1 TO UPPERBOUND (data_fragments_p^) DO
        IF (data_fragments_p^ [fragment_index].length > 0) AND
              (data_fragments_p^ [fragment_index].address <> NIL) THEN
          IF fragment_length = 0 THEN
            fragment := fragment_index; { First non empty fragment.
            current_fragment_capacity := data_fragments_p^ [fragment_index].length;
          IFEND;
          fragment_length := fragment_length + data_fragments_p^ [fragment_index].length;
        IFEND;
      FOREND /get_total_data_area_length/;

      IF message_length <= fragment_length THEN
        IF message_length > 0 THEN

{ The whole message is contained in one buffer.  It fits into the first
{ fragment.

          IF current_fragment_capacity >= message_length THEN
            data_length := message_length;
            fragment_array_p := data_fragments_p^ [fragment].address;
            i#move (data_cell_p, ^fragment_array_p^ [1], message_length);
          ELSE
            data_start := 0;
            fragment_data_start := 0;
            remaining_data := message_length;

          /flush_message/
            WHILE data_length < message_length DO

{ Find next non empty fragment if current is empty.

              WHILE current_fragment_capacity = 0 DO
                fragment := fragment + 1;
                IF (data_fragments_p^ [fragment].length > 0) AND (data_fragments_p^ [fragment].address <>
                      NIL) THEN
                  current_fragment_capacity := data_fragments_p^ [fragment].length;
                  fragment_data_start := 0;
                IFEND;
              WHILEND;

              fragment_array_p := data_fragments_p^ [fragment].address;

{ Fill the current fragment.

              IF remaining_data >= current_fragment_capacity THEN
                current_data_offset := data_offset + data_start;
                data_cell_p := #ADDRESS (data_ring, data_segment, current_data_offset);
                i#move (data_cell_p, ^fragment_array_p^ [1 + fragment_data_start], current_fragment_capacity);
                data_length := data_length + current_fragment_capacity;
                remaining_data := remaining_data - current_fragment_capacity;
                data_start := data_start + current_fragment_capacity;
                current_fragment_capacity := 0;

              ELSE { Partially fill current fragment with remainder of current

{ container.

                current_data_offset := data_offset + data_start;
                fragment_array_p := data_fragments_p^ [fragment].address;
                data_cell_p := #ADDRESS (data_ring, data_segment, current_data_offset);
                i#move (data_cell_p, ^fragment_array_p^ [1 + fragment_data_start], remaining_data);
                data_length := data_length + remaining_data;
                current_fragment_capacity := current_fragment_capacity - remaining_data;
                fragment_data_start := fragment_data_start + remaining_data;
                remaining_data := 0;
              IFEND;
            WHILEND /flush_message/;
          IFEND;
        IFEND;
      ELSE { Data area too small.

{ osp$set_status_condition (nae$data_area_too_small, status);

      IFEND;
    PROCEND move_data_fragments;

    status.normal := TRUE;

    ?IF iic$xt_compiling_for_trace THEN
      iip$xt_write_trace (' Begin iip$xt_receive_data');
    ?IFEND;

    activity_status^.status.normal := TRUE;
    activity_status^.complete := FALSE;
    request_started := FALSE;
    osp$establish_condition_handler (^condition_handler, TRUE);

{ Xterm task and user task may modify upline messages.

    iip$xt_lock_upline_messages ({ignore} status);
    status.normal := TRUE;
    IF iiv$xt_xterm_control_block.xterm_state < iic$execute_initial_command THEN
      process_upline_command;
    IFEND;
    sequence_p := iiv$xt_xterm_upline.segment_pointer.sequence_pointer;
    RESET sequence_p;
    NEXT xt_message_control_block_p IN sequence_p;
    get_p := #PTR (xt_message_control_block_p^.get_p, sequence_p^);
    put_p := #PTR (xt_message_control_block_p^.put_p, sequence_p^);
    IF ((i#current_sequence_position (put_p) > i#current_sequence_position (get_p)) AND
          (xt_message_control_block_p^.terminate_option = iic$xt_terminate_record)) THEN
      NEXT xt_message_header_p IN get_p;
      message_length := xt_message_header_p^.xt_message_size;
      NEXT data_p: [[REP message_length OF cell]] IN get_p;
      xt_message_control_block_p^.get_p := #REL (get_p, sequence_p^);

      IF call_block.operation = nac$se_receive_data_req THEN
        data_fragments_p := call_block.se_receive_data_req.buffer;
        move_data_fragments;
        call_block.se_receive_data_req.peer_operation^.kind := nac$se_send_data;
        call_block.se_receive_data_req.peer_operation^.end_of_message := TRUE;
        call_block.se_receive_data_req.peer_operation^.qualified_data := FALSE;
        call_block.se_receive_data_req.peer_operation^.data_length := data_length;
        request_started := TRUE;
        activity_status^.complete := TRUE;
      ELSE
        ?IF iic$xt_compiling_for_trace THEN
          iip$xt_write_trace (' Unexpected iip$xt_receive_data call block operation');
        ?IFEND;
      IFEND;
    IFEND;

    iip$xt_unlock_upline_messages ({ignore} status);
    status.normal := TRUE;
    osp$disestablish_cond_handler;

  PROCEND iip$xt_receive_data;

?? TITLE := '[XDCL, #GATE] iip$xt_redirect_xterm_output', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_redirect_xterm_output
    (    working_storage_area: ^cell;
         working_storage_length: amt$working_storage_length;
     VAR status: ost$status);

    VAR
      format_effector: char,
      working_storage_array_pointer: ^array [0 .. iic$max_record_length] of char;

?? NEWTITLE := 'write_xterm_output', EJECT ??

    PROCEDURE write_xterm_output;

      CONST
        close_message = ':  fatal IO error 104';

      VAR
        character_index: 0 .. iic$xt_max_message_length,
        date_string: ost$string,
        edited_string: string (iic$xt_max_message_length),
        edited_length: 0 .. iic$xt_max_message_length,
        fba: amt$file_byte_address,
        file_identifier: amt$file_identifier,
        time_string: ost$string,
        working_length: integer,
        working_storage_p: ^string ( * ),
        working_string: string (iic$xt_max_message_length);

      working_storage_p := ^iiv$xt_xterm_task_output.text_p^ (1, iiv$xt_xterm_task_output.position);
      edited_length := 1;
      edited_string (1) := ' ';

{ If the terminal user uses the close menu, xterm drops with a fatal IO error 104.
{ This error means xterm attempted output on a socket that is no longer open.
{ If this error occurs, shutdown should be considered normal.
{ Do not write anything to the trace file.

      FOR character_index := 1 TO STRLENGTH (working_storage_p^) DO
        edited_length := edited_length + 1;
        edited_string (edited_length, 1) := working_storage_p^ (character_index, 1);
        IF working_storage_p^ (character_index, 1) = ':' THEN
          IF STRLENGTH (working_storage_p^ (character_index, * )) >= STRLENGTH (close_message) THEN
            IF working_storage_p^ (character_index, STRLENGTH (close_message)) = close_message THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      FOREND;

      open_trace_file (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$get_date_string (date_string, {ignore} status);
      clp$get_time_string (time_string, {ignore} status);

{ If you can the format of this output, you must also change iic$xt_message_offset.

      STRINGREP (working_string, working_length, ' ', date_string.value (1, date_string.size), ' ',
            time_string.value (1, time_string.size), ' ', edited_string (1, edited_length));
      amp$put_next (file_identifier, ^working_string, working_length, fba, {ignore} status);
      fsp$close_file (file_identifier, {ignore} status);
      status.normal := TRUE;
    PROCEND write_xterm_output;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

{ Check format effectors to determine when to write data to output.

    working_storage_array_pointer := working_storage_area;

{handle output data as character array.

    i#move (working_storage_area, ^format_effector, 1);

    CASE format_effector OF

{ This format effector continues a record.

    = ',' =

      IF iiv$xt_xterm_task_output.text_p = NIL THEN
        ALLOCATE iiv$xt_xterm_task_output.text_p IN osv$task_private_heap^;
        iiv$xt_xterm_task_output.position := 0;
      IFEND;

      IF working_storage_length > 1 THEN
        i#move (#LOC (working_storage_array_pointer^ [1]), ^iiv$xt_xterm_task_output.
              text_p^ (iiv$xt_xterm_task_output.position + 1), working_storage_length - 1);
        iiv$xt_xterm_task_output.position := iiv$xt_xterm_task_output.position + working_storage_length - 1;
      IFEND;

{ The format effector ends the record.

    = '.', '/' =
      IF iiv$xt_xterm_task_output.text_p = NIL THEN
        ALLOCATE iiv$xt_xterm_task_output.text_p IN osv$task_private_heap^;
        iiv$xt_xterm_task_output.position := 0;
      IFEND;

      IF working_storage_length > 1 THEN
        i#move (#LOC (working_storage_array_pointer^ [1]), ^iiv$xt_xterm_task_output.
              text_p^ (iiv$xt_xterm_task_output.position + 1), working_storage_length - 1);
        iiv$xt_xterm_task_output.position := iiv$xt_xterm_task_output.position + working_storage_length - 1;
      IFEND;

      IF iiv$xt_xterm_task_output.position > 0 THEN
        write_xterm_output;
      IFEND;

      FREE iiv$xt_xterm_task_output.text_p IN osv$task_private_heap^;
      iiv$xt_xterm_task_output.position := 0;

{ These format effectors start a record.

    ELSE
      IF iiv$xt_xterm_task_output.text_p <> NIL THEN
        write_xterm_output;
      ELSE
        ALLOCATE iiv$xt_xterm_task_output.text_p IN osv$task_private_heap^;
        iiv$xt_xterm_task_output.position := 0;
      IFEND;
      IF working_storage_length > 1 THEN
        i#move (#LOC (working_storage_array_pointer^ [1]), iiv$xt_xterm_task_output.text_p,
              working_storage_length - 1);
        iiv$xt_xterm_task_output.position := working_storage_length - 1;
      IFEND;
    CASEND;

  PROCEND iip$xt_redirect_xterm_output;

?? TITLE := '[XDCL, #GATE] iip$xt_route', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_route
    (    user_id: ost$user_identification;
         user_supplied_name: jmt$user_supplied_name;
         system_job_parameters: jmt$system_job_parameters;
     VAR system_supplied_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      account_name: avt$account_name,
      job_submission_options_p: ^jmt$job_submission_options,
      project_name: avt$project_name;

    VAR
      data_value_p: ^clt$data_value;

    status.normal := TRUE;
    pmp$get_account_project (account_name, project_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH job_submission_options_p: [1 .. 10];
    IF user_supplied_name <> osc$null_name THEN
      job_submission_options_p^ [1].key := jmc$user_job_name;
      job_submission_options_p^ [1].user_job_name := user_supplied_name;
    ELSE
      job_submission_options_p^ [1].key := jmc$null_attribute;
    IFEND;
    job_submission_options_p^ [2].key := jmc$system_job_parameters;
    PUSH job_submission_options_p^ [2].system_job_parameters;
    job_submission_options_p^ [2].system_job_parameters^ := system_job_parameters;
    job_submission_options_p^ [3].key := jmc$origin_application_name;
    job_submission_options_p^ [3].origin_application_name := osc$xterm_application_name;
    job_submission_options_p^ [4].key := jmc$login_command_supplied;
    job_submission_options_p^ [4].login_command_supplied := FALSE;
    job_submission_options_p^ [5].key := jmc$immediate_init_candidate;
    job_submission_options_p^ [5].immediate_init_candidate := TRUE;
    job_submission_options_p^ [6].key := jmc$login_family;
    job_submission_options_p^ [6].login_family := user_id.family;
    job_submission_options_p^ [7].key := jmc$login_user;
    job_submission_options_p^ [7].login_user := user_id.user;

    clp$get_variable_value ('XWV$XTERM_JOB_CLASS', data_value_p, status);
    IF NOT status.normal THEN
      job_submission_options_p^ [8].key := jmc$null_attribute;
    ELSE
      job_submission_options_p^ [8].key := jmc$job_class;
      job_submission_options_p^ [8].job_class := data_value_p^.name_value;
    IFEND;
    job_submission_options_p^ [9].key := jmc$login_account;
    job_submission_options_p^ [9].login_account := account_name;
    job_submission_options_p^ [10].key := jmc$login_project;
    job_submission_options_p^ [10].login_project := project_name;
    jmp$submit_job (clc$null_file, job_submission_options_p, system_supplied_name, status);

  PROCEND iip$xt_route;

?? TITLE := '[XDCL, #GATE] iip$xt_send_data', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_send_data
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
         start_time: integer;
     VAR request_started: boolean;
     VAR wait_time: nat$wait_time;
     VAR activity_status: ^ost$activity_status;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      current_time: integer,
      data: array [1 .. 1] of nat$data_fragment,
      data_area: ^nat$data_fragments,
      description_upperbound: integer,
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      global_task_id: ost$global_task_id,
      ignore_status: ost$status;

    PROCEDURE move_data_fragments
      (    term_option: amt$term_option;
           data_fragments: nat$data_fragments;
       VAR status: ost$status);

      VAR
        data_p: ^SEQ ( * ),
        data_fragment_count: nat$data_fragment_count,
        get_p: ^SEQ ( * ),
        ignore_status: ost$status,
        message_size: integer,
        put_p: ^SEQ ( * ),
        sequence_p: ^SEQ ( * ),
        xt_message_control_block_p: ^iit$xt_message_control_block,
        xt_message_header_p: ^iit$xt_message_header;

      VAR
        trace_length: integer,
        trace_string: string (80);

      PROCEDURE condition_handler
        (    condition: pmt$condition;
             condition_information: ^pmt$condition_information;
             stack_frame_save_area: ^ost$stack_frame_save_area;
         VAR condition_status: ost$status);

        VAR
          ignore_status: ost$status;

        IF condition.selector = pmc$block_exit_processing THEN
          iip$xt_unlock_downline_messages (ignore_status);
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
      PROCEND condition_handler;

      PROCEDURE copy_fragments;

        FOR data_fragment_count := 1 TO UPPERBOUND (data_fragments) DO
          message_size := message_size + data_fragments [data_fragment_count].length;
          NEXT data_p: [[REP data_fragments [data_fragment_count].length OF cell]] IN put_p;
          i#move (data_fragments [data_fragment_count].address, data_p,
                data_fragments [data_fragment_count].length);
        FOREND;
      PROCEND copy_fragments;

      status.normal := TRUE;
      ?IF iic$xt_compiling_for_trace THEN
        iip$xt_write_trace (' Begin iip$xt_send_data');
      ?IFEND;

      osp$establish_condition_handler (^condition_handler, TRUE);
      iip$xt_lock_downline_messages ({ignore} status);
      status.normal := TRUE;
      sequence_p := iiv$xt_xterm_downline.segment_pointer.sequence_pointer;
      RESET sequence_p;
      NEXT xt_message_control_block_p IN sequence_p;
      put_p := #PTR (xt_message_control_block_p^.put_p, sequence_p^);

      CASE term_option OF

      = amc$start =
        NEXT xt_message_header_p IN put_p;
        xt_message_control_block_p^.put_message_header_p := #REL (xt_message_header_p, sequence_p^);
        message_size := 0;
        copy_fragments;
        xt_message_header_p^.xt_message_type := iic$xt_vtp_message_type;
        xt_message_header_p^.xt_message_size := message_size;
        xt_message_control_block_p^.terminate_option := iic$xt_start_record;

      = amc$continue =
        xt_message_header_p := #PTR (xt_message_control_block_p^.put_message_header_p, sequence_p^);
        message_size := xt_message_header_p^.xt_message_size;
        copy_fragments;
        xt_message_header_p^.xt_message_type := iic$xt_vtp_message_type;
        xt_message_header_p^.xt_message_size := message_size;
        xt_message_control_block_p^.terminate_option := iic$xt_continue_record;

      ELSE { amc$terminate
        IF (xt_message_control_block_p^.terminate_option = iic$xt_terminate_record) THEN
          NEXT xt_message_header_p IN put_p;
          xt_message_control_block_p^.put_p := #REL (put_p, sequence_p^);
          xt_message_control_block_p^.put_message_header_p := #REL (xt_message_header_p, sequence_p^);
          message_size := 0;
          copy_fragments;
          xt_message_header_p^.xt_message_type := iic$xt_vtp_message_type;
          xt_message_header_p^.xt_message_size := message_size;
          xt_message_control_block_p^.terminate_option := iic$xt_terminate_record;
        ELSE
          xt_message_header_p := #PTR (xt_message_control_block_p^.put_message_header_p, sequence_p^);
          message_size := xt_message_header_p^.xt_message_size;
          copy_fragments;
          xt_message_header_p^.xt_message_size := message_size;
          xt_message_control_block_p^.terminate_option := iic$xt_terminate_record;
        IFEND;

        xt_message_control_block_p^.put_p := #REL (put_p, sequence_p^);
        iiv$xt_xterm_control_block.downline_state := iic$xt_wait_for_data;
        iip$xt_unlock_downline_messages ({ignore} status);
        status.normal := TRUE;
        osp$disestablish_cond_handler;
        IF iiv$xt_xterm_control_block.xterm_state >= iic$execute_xterm_task THEN
          pmp$ready_task (iiv$xt_xterm_control_block.xterm_global_task_id, status);
          IF NOT status.normal THEN
            send_disconnect_signal (global_task_id);
          IFEND;
        IFEND;
      CASEND;

    PROCEND move_data_fragments;

    PROCEDURE send_xterm_output
      (    data_fragments: nat$data_fragments;
       VAR status: ost$status);

      VAR
        data_fragment_count: nat$data_fragment_count,
        output_position: integer,
        vt_output_information: iit$vt_output_information,
        position: integer,
        xterm_string: string (1000);

      status.normal := TRUE;
      i#move (data_fragments [1].address, ^vt_output_information, #SIZE (vt_output_information));
      IF vt_output_information.message_type <> iic$vt_output_data_message THEN
        RETURN;
      IFEND;

    /move_data/
      FOR data_fragment_count := 2 TO UPPERBOUND (data_fragments) DO
        i#move (data_fragments [data_fragment_count].address, ^xterm_string,
              data_fragments [data_fragment_count].length);
        iip$xt_write_trace (xterm_string (1, data_fragments [data_fragment_count].length));
      FOREND /move_data/;

    PROCEND send_xterm_output;

    status.normal := TRUE;

    ?IF iic$xt_compiling_for_trace THEN
      iip$xt_write_trace (' Begin iip$xt_send_data');
    ?IFEND;

    activity_status^.status.normal := TRUE;
    activity_status^.complete := TRUE;
    request_started := TRUE;
    IF call_block.operation = nac$se_send_data_req THEN
      data_area := call_block.se_send_data_req.data;
    ELSE
      IF call_block.operation = amc$put_next_req THEN
        data [1].length := call_block.putn.working_storage_length;
        data [1].address := call_block.putn.working_storage_area;
        call_block.putn.byte_address^ := 0;
      ELSE
        data [1].length := call_block.putp.working_storage_length;
        data [1].address := call_block.putp.working_storage_area;
        call_block.putp.byte_address^ := 0;
      IFEND;
      data_area := ^data;
    IFEND;

    pmp$get_executing_task_gtid (global_task_id);
    IF (iiv$xt_xterm_control_block.task.exists AND (global_task_id =
          iiv$xt_xterm_control_block.xterm_global_task_id)) THEN
      send_xterm_output (data_area^, status);
      RETURN;
    IFEND;

    IF iiv$xt_xterm_control_block.status.complete THEN

{ Xterm task has completed.  Do not send anything to xterm task.

        send_disconnect_signal (global_task_id);
      RETURN;
    IFEND;

    IF call_block.operation = nac$se_send_data_req THEN
      IF call_block.se_send_data_req.end_of_message THEN
        move_data_fragments (amc$terminate, data_area^, status);
      ELSE
        move_data_fragments (amc$continue, data_area^, status);
      IFEND;

    ELSEIF (call_block.operation = amc$put_partial_req) THEN
      move_data_fragments (call_block.putp.term_option, data_area^, status);
    ELSE
      move_data_fragments (amc$terminate, data_area^, status);
    IFEND;

  PROCEND iip$xt_send_data;

?? TITLE := '[XDCL, #GATE] iip$xt_send_signal', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_send_signal
    (    interrupt_character: char;
     VAR status: ost$status);

    CONST
      pause_break_character = '1',
      terminate_break_character = '2';

    VAR
      timesharing_signal: jmt$timesharing_signal;

    status.normal := TRUE;
    timesharing_signal.signal_id := jmc$timesharing_signal_id;
    CASE interrupt_character OF

    = pause_break_character, terminate_break_character =
      timesharing_signal.signal_contents.signal_kind := jmc$timesharing_synchronize;
      timesharing_signal.signal_contents.synchronize (1) := interrupt_character;

    ELSE
      timesharing_signal.signal_contents.signal_kind := jmc$timesharing_interrupt;
      timesharing_signal.signal_contents.interrupt (1) := interrupt_character;
    CASEND;
    pmp$send_signal (iiv$job_monitor_task_id, timesharing_signal.signal, status);

  PROCEND iip$xt_send_signal;


?? TITLE := '[XDCL, #GATE] iip$xt_stop_xterm', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_stop_xterm
    (VAR status: ost$status);

    VAR
      condition_string: ost$string;

    status.normal := TRUE;
    IF iiv$xt_xterm_control_block.task.exists THEN
      IF iiv$xt_xterm_control_block.status.complete THEN
        iiv$xt_xterm_control_block.xterm_state := iic$terminate_xterm_task;
      IFEND;
      iiv$xt_xterm_control_block.task.exists := FALSE;
    IFEND;

  PROCEND iip$xt_stop_xterm;

?? TITLE := '[XDCL, #GATE] iip$xt_store_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_store_attributes
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

    VAR
      attribute_index: integer,
      error_string: string (iic$xt_max_message_length),
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      length: integer;

    status.normal := TRUE;
    ?IF iic$xt_compiling_for_trace THEN
      iip$xt_write_trace (' Begin iip$xt_store_attributes');
    ?IFEND;

    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_condition (ame$improper_file_id, status);
      RETURN;
    IFEND;

    IF call_block.store_attributes <> NIL THEN
      FOR attribute_index := LOWERBOUND (call_block.store_attributes^)
            TO UPPERBOUND (call_block.store_attributes^) DO
        CASE call_block.store_attributes^ [attribute_index].kind OF
        = nac$connect_data =
        = nac$data_transfer_timeout =
          file_instance^.data_transfer_timeout := call_block.store_attributes^ [attribute_index].
                data_transfer_timeout;
        = nac$eoi_message =
          IF call_block.store_attributes^ [attribute_index].eoi_message.size <= 31 {nac$maximum_eoi_size} THEN
            IF file_instance^.eoi_message = NIL THEN
              ALLOCATE file_instance^.eoi_message IN osv$task_private_heap^;
            IFEND;
            file_instance^.eoi_message^ := call_block.store_attributes^ [attribute_index].eoi_message;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$invalid_eoi_message_size,
                  '31' {nac$maximum_eoi_size} , status);
          IFEND;
        = nac$eoi_message_enabled =
          file_instance^.eoi_message_enabled := call_block.store_attributes^ [attribute_index].
                eoi_message_enabled;
        = nac$eoi_peer_termination =
          file_instance^.eoi_peer_termination := call_block.store_attributes^ [attribute_index].
                eoi_peer_termination;
        = nac$null_attribute =
        = nac$receive_wait_swapout =
        = nac$termination_data =
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$unknown_attribute, ' on STORE ATTRIBUTES ', status);
        CASEND;
      FOREND;
    IFEND;

    ?IF iic$xt_compiling_for_trace THEN
      iip$xt_write_trace (' Exit iip$xt_store_attributes');
    ?IFEND;

  PROCEND iip$xt_store_attributes;

?? TITLE := 'iip$xt_synchronize', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_synchronize
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

    VAR
      downline_locked: boolean,
      get_p: ^SEQ ( * ),
      message_control_block_p: ^iit$xt_message_control_block,
      remaining_sequence_length: integer,
      sequence_p: ^SEQ ( * ),
      upline_locked: boolean;

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF condition.selector = pmc$block_exit_processing THEN
        IF downline_locked THEN
          iip$xt_unlock_downline_messages (ignore_status);
        IFEND;
        IF upline_locked THEN
          iip$xt_unlock_upline_messages (ignore_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      IFEND;
    PROCEND condition_handler;

    status.normal := TRUE;

    ?IF iic$xt_compiling_for_trace THEN
      iip$xt_write_trace (' Begin iip$xt_synchronize');
    ?IFEND;

    downline_locked := FALSE;
    #SPOIL (downline_locked);
    upline_locked := FALSE;
    #SPOIL (upline_locked);
    osp$establish_condition_handler (^condition_handler, TRUE);
    IF NOT iiv$xt_xterm_control_block.status.complete THEN
      iip$xt_lock_downline_messages ({ignore} status);
      status.normal := TRUE;
      downline_locked := TRUE;
      #SPOIL (downline_locked);
      sequence_p := iiv$xt_xterm_downline.segment_pointer.sequence_pointer;
      RESET sequence_p;
      NEXT message_control_block_p IN sequence_p;
      message_control_block_p^.record_position := iic$xt_end_of_record;
      message_control_block_p^.terminate_option := iic$xt_terminate_record;
      remaining_sequence_length := #SIZE (sequence_p^) - i#current_sequence_position (sequence_p);
      NEXT get_p: [[REP remaining_sequence_length OF cell]] IN sequence_p;
      RESET get_p;
      message_control_block_p^.get_p := #REL (get_p, sequence_p^);
      message_control_block_p^.put_p := message_control_block_p^.get_p;
      iip$xt_unlock_downline_messages ({ignore} status);
      status.normal := TRUE;
      downline_locked := FALSE;
      #SPOIL (downline_locked);
    IFEND;

{ Xterm and user task my modify upline messages.

    iip$xt_lock_upline_messages ({ignore} status);
    status.normal := TRUE;
    upline_locked := TRUE;
    #SPOIL (upline_locked);
    sequence_p := iiv$xt_xterm_upline.segment_pointer.sequence_pointer;
    RESET sequence_p;
    NEXT message_control_block_p IN sequence_p;
    message_control_block_p^.record_position := iic$xt_end_of_record;
    message_control_block_p^.terminate_option := iic$xt_terminate_record;
    remaining_sequence_length := #SIZE (sequence_p^) - i#current_sequence_position (sequence_p);
    NEXT get_p: [[REP remaining_sequence_length OF cell]] IN sequence_p;
    RESET get_p;
    message_control_block_p^.get_p := #REL (get_p, sequence_p^);
    message_control_block_p^.put_p := message_control_block_p^.get_p;
    iip$xt_unlock_upline_messages ({ignore} status);
    status.normal := TRUE;
    upline_locked := FALSE;
    #SPOIL (upline_locked);
    osp$disestablish_cond_handler;

    ?IF iic$xt_compiling_for_trace THEN
      iip$xt_write_trace (' Exit iip$xt_synchronize');
    ?IFEND;

  PROCEND iip$xt_synchronize;

?? TITLE := '[XDCL, #GATE] iip$xt_synchronize_confirm', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_synchronize_confirm
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

    status.normal := TRUE;

{ For xterm there is nothing to do.

  PROCEND iip$xt_synchronize_confirm;

?? TITLE := '[XDCL, #GATE] iip$xt_unlock_downline_messages', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_unlock_downline_messages
    (VAR status: ost$status);

    VAR
      signature_lock_status: ost$signature_lock_status;

    status.normal := TRUE;
    osp$test_sig_lock (iiv$xt_xterm_control_block.downline_lock, signature_lock_status);
    IF signature_lock_status = osc$sls_locked_by_current_task THEN
      osp$clear_job_signature_lock (iiv$xt_xterm_control_block.downline_lock);
    IFEND;

  PROCEND iip$xt_unlock_downline_messages;

?? TITLE := '[XDCL, #GATE] iip$xt_unlock_upline_messages', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_unlock_upline_messages
    (VAR status: ost$status);

    VAR
      signature_lock_status: ost$signature_lock_status;

    status.normal := TRUE;
    osp$test_sig_lock (iiv$xt_xterm_control_block.upline_lock, signature_lock_status);
    IF signature_lock_status = osc$sls_locked_by_current_task THEN
      osp$clear_job_signature_lock (iiv$xt_xterm_control_block.upline_lock);
    IFEND;

  PROCEND iip$xt_unlock_upline_messages;

?? TITLE := '[XDCL, #GATE] iip$xt_wait_for_xterm', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_wait_for_xterm
    (    system_supplied_name: jmt$system_supplied_name;
     VAR examine_job_file: boolean;
     VAR status: ost$status);

  CONST
    xterm_wait_time = 30*1000; {30 seconds.

  VAR
    attachment_option: array [1 .. 2] of fst$attachment_option,
    file_identifier: amt$file_identifier,
    file_reference: string ({$user.} 6 + {xterm catalog} 31 + {.} 1 +
            {status catalog} 31 + {.} 1 + {system_supplied_name} 31),
    file_reference_length: integer,
    global_task_id: ost$global_task_id,
    i_activity: array [1 .. 2] of ost$i_activity,
    ignore_status: ost$status,
    ready_index: integer,
    segment_pointer: amt$segment_pointer,
    sequence_p: ^SEQ (*),
    xterm_status_p: ^iit$xt_xterm_status;

?? OLDTITLE ??
?? NEWTITLE := 'clean_up', EJECT ??
   PROCEDURE clean_up;

     VAR
       cycle_selector: pft$cycle_selector,
       file_path: array [1 .. 5] of pft$name;

     fsp$close_file (file_identifier, ignore_status);
     file_path [pfc$family_name_index] := osc$null_name;
     file_path [pfc$master_catalog_name_index] := osc$null_name;
     file_path [pfc$subcatalog_name_index] := iic$xt_xterm_catalog_name;
     file_path [4] := iic$xt_status_catalog_name;
     file_path [5] := system_supplied_name;
     cycle_selector.cycle_option :=  pfc$highest_cycle;
     pfp$purge (file_path, cycle_selector, osc$null_name, ignore_status);
   PROCEND clean_up;

?? OLDTITLE, EJECT ??

{ Create segment access file for communicating with the xterm job.
{ The job submitting xterm executes this code.   The xterm job will wait
{ a certain period of time for this file to be created.

    attachment_option [1].selector := fsc$access_and_share_modes;
    attachment_option [1].access_modes.selector := fsc$specific_access_modes;
    attachment_option [1].access_modes.value := $fst$file_access_options
          [fsc$read, fsc$append, fsc$shorten, fsc$modify];
    attachment_option [1].share_modes.selector := fsc$specific_share_modes;
    attachment_option [1].share_modes.value := $fst$file_access_options
          [fsc$read, fsc$append, fsc$shorten, fsc$modify];
    attachment_option [2].selector := fsc$open_share_modes;
    attachment_option [2].open_share_modes := $fst$file_access_options
          [fsc$read, fsc$append, fsc$shorten, fsc$modify];
    STRINGREP (file_reference, file_reference_length, '$USER.',iic$xt_xterm_catalog_name,
          '.', iic$xt_status_catalog_name, '.', system_supplied_name);
    fsp$open_file (file_reference (1, file_reference_length), amc$segment,
          {attachment options=} ^attachment_option,
          {default creation attributes=} NIL, {mandated creation attributes=} NIL,
          {attribute validation=} NIL, {attribute override=} NIL, file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_identifier, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      clean_up;
      RETURN;
    IFEND;

{ Pass the global task id to the xterm job.  When the xterm job has completed initialization
{ it readies the task of the job submitting xterm.  The job submitting xterm then examines
{ the $USER.$JOBS.SYSTEM_SUPPLIED_NAME file for errors.

    pmp$get_executing_task_gtid (global_task_id);
    sequence_p := segment_pointer.sequence_pointer;
    RESET sequence_p;
    NEXT xterm_status_p IN sequence_p;
    xterm_status_p^.activity_status.complete := FALSE;
    xterm_status_p^.activity_status.status.normal := FALSE;
    xterm_status_p^.global_task_id := global_task_id;

{ Wait for xterm job to write a status.

    i_activity [1].activity := osc$i_await_time;
    i_activity [1].milliseconds := xterm_wait_time;
    i_activity [2].activity := nac$i_await_activity_status;
    i_activity [2].activity_status := ^xterm_status_p^.activity_status;
    osp$i_await_activity_completion (i_activity, ready_index, status);
    examine_job_file :=  ((ready_index = 1) OR
          (NOT xterm_status_p^.activity_status.status.normal));
    clean_up;

  PROCEND iip$xt_wait_for_xterm;

?? TITLE := '[XDCL, #GATE] iip$xt_write_trace', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_write_trace
    (    working_storage_area: string ( * ));

    VAR
      date_string: ost$string,
      fba: amt$file_byte_address,
      file_identifier: amt$file_identifier,
      global_task_id: ost$global_task_id,
      status: ost$status,
      time_string: ost$string,
      working_length: integer,
      working_string: string (iic$xt_max_message_length);

    IF NOT selected_trace_option (iic$xt_trace_procedures) THEN
      RETURN;
    IFEND;

    open_trace_file (file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_date_string (date_string, {ignore} status);
    clp$get_time_string (time_string, {ignore} status);
    pmp$get_executing_task_gtid (global_task_id);
    STRINGREP (working_string, working_length, ' ', date_string.value (1, date_string.size), ' ',
          time_string.value (1, time_string.size), ' task = ', global_task_id.index, global_task_id.seqno,
          ' ', working_storage_area);
    amp$put_next (file_identifier, ^working_string, working_length, fba, {ignore} status);
    fsp$close_file (file_identifier, {ignore} status);
    status.normal := TRUE;

  PROCEND iip$xt_write_trace;

?? TITLE := '[XDCL, #GATE] iip$xt_write_trace_status', EJECT ??

  PROCEDURE [XDCL, #GATE] iip$xt_write_trace_status
    (    working_storage_area: string ( * );
         trace_status: ost$status);

    VAR
      condition_string: ost$string,
      fba: amt$file_byte_address,
      file_identifier: amt$file_identifier,
      global_task_id: ost$global_task_id,
      status: ost$status,
      time_string: ost$string,
      working_length: integer,
      working_string: string (iic$xt_max_message_length);

    IF NOT selected_trace_option (iic$xt_trace_procedures) THEN
      RETURN;
    IFEND;

    open_trace_file (file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_time_string (time_string, {ignore} status);
    pmp$get_executing_task_gtid (global_task_id);
    osp$get_status_condition_string (trace_status.condition, condition_string, {ignore} status);

    STRINGREP (working_string, working_length, ' ', time_string.value (1, time_string.size), ' task = ',
          global_task_id.index, global_task_id.seqno, ' ', working_storage_area
          (1, STRLENGTH (working_storage_area)), ' ', condition_string.value (1, condition_string.size));
    amp$put_next (file_identifier, ^working_string, working_length, fba, {ignore} status);
    fsp$close_file (file_identifier, {ignore} status);

  PROCEND iip$xt_write_trace_status;

?? TITLE := 'open_trace_file', EJECT ??

  PROCEDURE open_trace_file
    (VAR file_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      attachment_option: array [1 .. 2] of fst$attachment_option,
      file_cycle_attribute: array [1 .. 2] of fst$file_cycle_attribute,
      file_reference: string ({$user.} 6 + {xterm catalog} 31 + {.} 1 +
           {job catalog} 31 + {.} 1 + {system_supplied_name} 31),
      file_reference_length: integer,
      path: array [1 .. 4] of pft$name,
      system_supplied_name: jmt$system_supplied_name,
      user_supplied_name: jmt$user_supplied_name;

    define_xterm_catalog (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    path [pfc$family_name_index] := osc$null_name;
    path [pfc$master_catalog_name_index] := osc$null_name;
    path [pfc$subcatalog_name_index] := iic$xt_xterm_catalog_name;
    path [4] := iic$xt_job_catalog_name;
    pfp$define_catalog (path, status);
    IF NOT status.normal AND (status.condition = pfe$name_already_subcatalog) THEN
      status.normal := TRUE;
    ELSE
      RETURN;
    IFEND;

    attachment_option [1].selector := fsc$open_position;
    attachment_option [1].open_position := amc$open_at_eoi;
    attachment_option [2].selector := fsc$access_and_share_modes;
    attachment_option [2].access_modes.selector := fsc$specific_access_modes;
    attachment_option [2].access_modes.value := $fst$file_access_options [fsc$append];
    attachment_option [2].share_modes.selector := fsc$specific_share_modes;
    attachment_option [2].share_modes.value := $fst$file_access_options [fsc$read];
    file_cycle_attribute [1].selector := fsc$ring_attributes;
    file_cycle_attribute [1].ring_attributes.r1 := 11;
    file_cycle_attribute [1].ring_attributes.r2 := 11;
    file_cycle_attribute [1].ring_attributes.r3 := 11;
    file_cycle_attribute [2].selector := fsc$file_contents_and_processor;
    file_cycle_attribute [2].file_contents := amc$legible;
    file_cycle_attribute [2].file_processor := osc$null_name;
    pmp$get_job_names (user_supplied_name, system_supplied_name, {ignore} status);
    STRINGREP (file_reference, file_reference_length, '$USER.',iic$xt_xterm_catalog_name,
          '.', iic$xt_job_catalog_name,'.', system_supplied_name);
    fsp$open_file (file_reference (1, file_reference_length), amc$record, ^attachment_option,
          ^file_cycle_attribute, NIL, NIL, NIL, file_identifier, status);
  PROCEND open_trace_file;

?? TITLE := 'process_upline_command', EJECT ??
  PROCEDURE process_upline_command;

    VAR
      command_line_p: ^clt$command_line,
      data_p: ^SEQ ( * ),
      get_p: ^SEQ ( * ),
      ignore_status: ost$status,
      put_p: ^SEQ ( * ),
      message_length: integer,
      sequence_p: ^SEQ ( * ),
      vt_input_header_p: ^iit$vt_input_header,
      xt_message_header_p: ^iit$xt_message_header,
      xt_message_control_block_p: ^iit$xt_message_control_block;

    sequence_p := iiv$xt_xterm_upline.segment_pointer.sequence_pointer;
    RESET sequence_p;
    NEXT xt_message_control_block_p IN sequence_p;
    get_p := #PTR (xt_message_control_block_p^.get_p, sequence_p^);
    put_p := #PTR (xt_message_control_block_p^.put_p, sequence_p^);
    IF ((i#current_sequence_position (put_p) > i#current_sequence_position (get_p)) AND
          (xt_message_control_block_p^.terminate_option = iic$xt_terminate_record)) THEN
      NEXT xt_message_header_p IN get_p;
      message_length := xt_message_header_p^.xt_message_size;
      NEXT data_p: [[REP message_length OF cell]] IN get_p;
      RESET data_p;
      NEXT vt_input_header_p IN data_p;
      IF vt_input_header_p^.message_type = iic$vt_execute_xterm_command THEN
        xt_message_control_block_p^.get_p := #REL (get_p, sequence_p^);
        iiv$xt_xterm_control_block.xterm_state := iic$execute_initial_command;
        IF message_length > #SIZE (iit$vt_input_header) THEN
          NEXT command_line_p: [message_length - #SIZE (iit$vt_input_header)] IN data_p;
          clp$define_initial_application (command_line_p, FALSE {logout_upon_termination},ignore_status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND process_upline_command;


?? TITLE := 'selected_trace_option', EJECT ??
  FUNCTION [INLINE] selected_trace_option
    (    trace_option: iit$xt_trace_options): boolean;

    selected_trace_option := FALSE;

    IF NOT jmp$is_xterm_job () THEN
      RETURN;
    IFEND;

    selected_trace_option := (trace_option IN iiv$xt_xterm_control_block.trace_set);

  FUNCEND selected_trace_option;

?? TITLE := '  SEND_DISCONNECT_SIGNAL', EJECT ??

  PROCEDURE send_disconnect_signal
    (    task_id: ost$global_task_id);

    VAR
      local_status: ost$status,
      timesharing_signal: jmt$timesharing_signal;

    timesharing_signal.signal_id := jmc$timesharing_signal_id;
    timesharing_signal.signal_contents.signal_kind := jmc$timesharing_disconnect;
    timesharing_signal.signal_contents.disconnect.disconnect_reason := jmc$ts_line_disconnect;
    pmp$send_signal (task_id, timesharing_signal.signal, local_status);

  PROCEND send_disconnect_signal;

MODEND iim$xt_xterm_interfaces;
*DECK DECK=IIP$ADD_QUEUE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] iip$add_queue_entry (queue_key: iit$queue_key;
    queue_entry_descriptor: iit$queue_entry_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$ADD_SENDER EXPAND=FALSE
  PROCEDURE [XREF] iip$add_sender (application_name: mlt$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=IIP$ALLOCATE_QUEUE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] iip$allocate_queue_entry (queue_key: iit$queue_key;
    VAR queue_entry_descriptor: iit$queue_entry_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$ASCII_170_TO_HEX EXPAND=FALSE

  PROCEDURE [XREF] iip$ascii_170_to_hex (ascii: iit$170_ascii_word;
    VAR hex: string ( * ));
?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
?? POP ??
*DECK DECK=IIP$BEGIN_CONDITION EXPAND=FALSE


  PROCEDURE [XREF] iip$begin_condition (condition: ift$interactive_condition;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ift$condition_codes
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$BUILD_DATA_MSG_SKELETON EXPAND=FALSE

  PROCEDURE [XREF] iip$build_data_msg_skeleton (podm: ^iit$output_data_message;
    odm_length: iit$text_length);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
?? POP ??
*DECK DECK=IIP$BUILD_SUPER_MSG_SKELETON EXPAND=FALSE

  PROCEDURE [XREF] iip$build_super_msg_skeleton (posm:
    ^iit$output_supervisory_message;
    osm_type: iit$supervisory_message_type;
    osm_length: iit$text_length);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
?? POP ??
*DECK DECK=IIP$BUILD_TERM_CHAR_VALUES EXPAND=FALSE

  PROCEDURE [XREF] iip$build_term_char_values (open_file_desc_pointer:
    ^iit$open_file_description);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
?? POP ??
*DECK DECK=IIP$BUILD_TERM_CONN_ATTR_ARRAY EXPAND=FALSE

  PROCEDURE [XREF] iip$build_term_conn_attr_array (source_pointer:
    ^ift$connection_attributes;
    attribute_source: ift$connection_attribute_source;
    destination_pointer: ^iit$connection_attributes);
?? PUSH (LISTEXT := ON) ??
*copyc ift$connection_attributes
*copyc IIT$CONNECTION_DESCRIPTION
?? POP ??
*DECK DECK=IIP$BUILD_TERM_REQ_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$build_term_conn_attr_array (source_pointer:
    ^ift$connection_attributes;
    attribute_source: ift$connection_attribute_source;
    destination_pointer: ^iit$connection_attributes);
?? PUSH (LISTEXT := ON) ??
*copyc ift$connection_attributes
*copyc IIT$CONNECTION_DESCRIPTION
?? POP ??
*DECK DECK=IIP$CHANGE_TERMINAL_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$change_terminal_attributes (terminal_attributes:
        ift$terminal_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ift$terminal_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IIP$CHANGE_TERMINAL_CLASS EXPAND=FALSE

  PROCEDURE [XREF] iip$change_terminal_class
    (connection_description_pointer: ^iit$connection_description;
    new_terminal_class: iit$terminal_class;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$CHANGE_TERM_CONN_ATTRIBUTES EXPAND=FALSE
  PROCEDURE [XREF] iip$change_term_conn_attributes (terminal_file_name: amt$local_file_name;
    connection_attributes: ift$connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc iit$connection_description
*copyc ost$status
?? POP ??
*DECK DECK=IIP$CHANGE_TERM_CONN_DEFAULTS EXPAND=FALSE

  PROCEDURE [XREF] iip$change_term_conn_defaults (
        connection_attributes: ift$connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IFT$CONNECTION_ATTRIBUTES
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$CHECK_FOR_CONDITION EXPAND=FALSE


  PROCEDURE [XREF] iip$check_for_condition (VAR status: ost$status);
*DECK DECK=IIP$CHECK_IF_STATUS EXPAND=FALSE

  PROCEDURE [INLINE] iip$check_if_status (VAR status: ost$status);

    status.normal := TRUE;

    IF jmv$terminal_io_disabled THEN
      osp$set_status_abnormal ('JM', jme$job_is_in_termination, '',status);
      RETURN;
    IFEND;

    IF NOT pmp$ts_task_io_enabled () THEN
      osp$set_status_abnormal (ifc$interactive_facility_id,
            ife$pause_break_received, '', status);
    IFEND;

    IF iiv$job_suspended THEN
      osp$set_status_abnormal (ifc$interactive_facility_id,
            ife$connection_break_disconnect, '', status);
      RETURN;
    IFEND;

  PROCEND iip$check_if_status;
?? PUSH (LISTEXT := OFF) ??
*copyc OST$STATUS
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIV$INT_TASK_OPEN_FILE_COUNT
*copyc jmv$terminal_io_disabled
*copyc ift$title_for_error_codes
*copyc jme$queued_file_conditions
*copyc ife$error_codes
*copyc OSP$SET_STATUS_ABNORMAL
*copyc pmp$ts_task_io_enabled
?? POP ??
*DECK DECK=IIP$CLEAR_JOB_LOCKS EXPAND=FALSE

  PROCEDURE [XREF] iip$clear_job_locks (
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$CLEAR_LOCK EXPAND=FALSE

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
*copyc OST$STATUS
*copyc OSP$CLEAR_JOB_SIGNATURE_LOCK
?? POP ??

  PROCEDURE [INLINE] iip$clear_lock (VAR lock: ost$signature_lock;
    VAR status: ost$status);

    osp$clear_job_signature_lock (lock);

  PROCEND iip$clear_lock;
*DECK DECK=IIP$CLOSE EXPAND=FALSE

  PROCEDURE [XREF] iip$close (file_id: amt$file_identifier;
    VAR open_file_desc_pointer: ^iit$open_file_description;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc AMT$FILE_IDENTIFIER
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$CONFIRM_SEND EXPAND=FALSE
  PROCEDURE [XREF] iip$confirm_send (application_name: mlt$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=IIP$CONNECTION_TO_VT_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$connection_to_vt_attributes (connection_desc_ptr: ^iit$connection_description;
        if_attributes: ift$connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ift$connection_attributes
*copyc iit$connection_description
*copyc ost$status
?? POP ??
*DECK DECK=IIP$CONVERT_DOWNLINE_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] iip$convert_downline_block (pib: ^cell;
    pob: ^cell;
    input_block_length: mlt$message_length;
    VAR output_block_length: mlt$message_length);

?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=IIP$CONVERT_DOWNLINE_TERM_CHAR EXPAND=FALSE

  PROCEDURE [XREF] iip$convert_downline_term_char (pib: ^cell;
    pob: ^cell;
    input_block_length: mlt$message_length;
    VAR output_block_length: mlt$message_length);

?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=IIP$CONVERT_UPLINE_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] iip$convert_upline_block (pib: ^cell;
    pob: ^cell;
    input_block_length: mlt$message_length);

?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=IIP$CONVERT_UPLINE_TERM_CHAR EXPAND=FALSE

  PROCEDURE [XREF] iip$convert_upline_term_char (pib: ^cell;
    pob: ^cell;
    input_block_length: mlt$message_length);

?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=IIP$DELETE_QUEUE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] iip$delete_queue_entry (queue_key: iit$queue_key;
    queue_entry_descriptor: iit$queue_entry_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$DIRECT_FETCH_TRM_CONN_ATTS EXPAND=FALSE
  PROCEDURE [XREF] iip$direct_fetch_trm_conn_atts
    (file_identifier: amt$file_identifier;
    VAR terminal_attributes: ift$get_connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ife$error_codes
*copyc ift$connection_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IIP$DIRECT_STORE_TRM_CONN_ATTS EXPAND=FALSE
  PROCEDURE [XREF] iip$direct_store_trm_conn_atts
    (file_identifier: amt$file_identifier;
        terminal_attributes: ift$connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ife$error_codes
*copyc ift$connection_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IIP$DISCONNECT_RECONNECT EXPAND=FALSE
 PROCEDURE [XREF] iip$disconnect_job (end_connection: boolean;
        start_new_job: boolean;
    VAR status: ost$status);

  PROCEDURE [XREF] iip$reconnect_job (acn: iit$application_connection_num;
        reject_caused_reconnect: boolean);

  PROCEDURE [XREF] iip$timeout_suspended_job;
?? PUSH (LISTEXT := OFF) ??
*copyc ost$status
*copyc iit$application_names_messages
?? POP ??
*DECK DECK=IIP$DPC64_TO_STRING EXPAND=FALSE

  PROCEDURE [XREF] iip$dpc64_to_string (VAR display_code: packed array [ * ] OF
    iit$display_code;
    number_of_dpc_chars_to_convert: integer;
    trailing_char_to_suppress: char;
    VAR destination_string: string ( * );
    VAR number_of_characters_converted: integer);
?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
?? POP ??
*DECK DECK=IIP$FETCH_ACCESS_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] iip$fetch_access_information (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$open_file_description;
    access_information: ^amt$access_information;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$access_information
*copyc AMT$FILE_IDENTIFIER
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$FETCH_CONTEXT EXPAND=FALSE

  PROCEDURE [XREF] iip$fetch_context (VAR {i/o} context_attributes:
    ift$fetch_context_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ift$fetch_context_attributes
?? POP ??
*DECK DECK=IIP$FETCH_TERMINAL EXPAND=FALSE

  PROCEDURE [XREF] iip$fetch_terminal (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$open_file_description;
    terminal_attributes: ^ift$get_connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc ift$get_connection_attributes
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$FETCH_TERM_CONN_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$fetch_term_conn_attributes (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$st_open_file_description;
    VAR connection_attributes: ift$get_connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc IFT$GET_CONNECTION_ATTRIBUTES
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$FLUSH EXPAND=FALSE

  PROCEDURE [XREF] iip$flush (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$open_file_description;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$FREE_QUEUE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] iip$free_queue_entry (queue_key: iit$queue_key;
    VAR queue_entry_descriptor: iit$queue_entry_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$GET EXPAND=FALSE

  PROCEDURE [XREF] iip$get (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$open_file_description;
    operation: amt$fap_operation;
    working_storage_area: ^cell;
    working_storage_length: amt$working_storage_length;
    record_length: ^amt$max_record_length;
    transfer_count: ^amt$transfer_count;
    byte_address: ^amt$file_byte_address;
    file_position: ^amt$file_position;
    skip_option: amt$skip_option;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$FILE_POSITION
*copyc AMT$SKIP_OPTION
*copyc AMD$OPERATION_DECLARATIONS
*copyc AMT$MAX_RECORD_LENGTH
*copyc AMT$TRANSFER_COUNT
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$GET_DEFLT_TERM_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$get_deflt_term_attributes (VAR terminal_attributes:
    ift$get_connection_attributes;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ift$get_connection_attributes
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$GET_PAGE_LENGTH_WIDTH EXPAND=FALSE

  PROCEDURE [XREF] iip$get_page_length_width (terminal_path_handle: fmt$path_handle;
    VAR page_length_width: array [1 .. 2] of ift$terminal_attribute;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_handle
*copyc ift$terminal_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IIP$GET_TERMINAL_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$get_terminal_attributes (VAR terminal_attributes:
        ift$terminal_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ift$terminal_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IIP$GET_TERM_CONN_ATTRIBUTES EXPAND=FALSE


  PROCEDURE [XREF] iip$get_term_conn_attributes (file_name: amt$local_file_name;
    VAR connection_attributes: ift$get_connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ift$get_connection_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IIP$GET_TERM_CONN_DEFAULTS EXPAND=FALSE

  PROCEDURE [XREF] iip$get_term_conn_defaults (local_file_name:
    amt$local_file_name;
    VAR connection_attributes: ift$get_connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ift$get_connection_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IIP$INITIALIZE_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] iip$initialize_connection (pism:
    ^iit$input_supervisory_message);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
?? POP ??
*DECK DECK=IIP$INIT_OPEN_DESC_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$init_open_desc_attributes (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$open_file_description;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$INTERRUPT_TIMESHARING_IO EXPAND=FALSE
{ This procedure resides in deck iim$interrupt_timesharing_io.}

    PROCEDURE [XREF] iip$interrupt_timesharing_io (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IIP$OPEN EXPAND=FALSE

  PROCEDURE [XREF] iip$open (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$open_file_description;
    file_name: amt$local_file_name;
    layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_layer_number
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$PUT EXPAND=FALSE

  PROCEDURE [XREF] iip$put (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$open_file_description;
    operation: amt$fap_operation;
    working_storage_area: ^cell;
    working_storage_length: amt$working_storage_length;
    byte_address: ^amt$file_byte_address;
    term_option: amt$term_option;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMD$OPERATION_DECLARATIONS
*copyc AMT$TERM_OPTION
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$READ_UPLINE_DATA EXPAND=FALSE

  PROCEDURE [XREF] iip$read_upline_data (connection_description_pointer:
    ^iit$connection_description;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$RECEIVE_FROM_PASS_ON EXPAND=FALSE

  PROCEDURE [XREF] iip$receive_from_pass_on (application_name:
    mlt$application_name;
    buffer_pointer: ^cell;
    buffer_length: mlt$message_length;
    VAR message_length: mlt$message_length;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$REGISTER_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] iip$register_handler (application_name:
    mlt$application_name;
    handler: mlt$handler;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$REPORT_LOGICAL_ERROR EXPAND=FALSE

  PROCEDURE [XREF] iip$report_logical_error (VAR msg:
    iit$input_supervisory_message);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
?? POP ??
*DECK DECK=IIP$REPORT_STATUS_ERROR EXPAND=FALSE

  PROCEDURE [XREF] iip$report_status_error (VAR error_status:
    ost$status;
    message: string ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$REPORT_UNHANDLED_DATA_MSG EXPAND=FALSE

  PROCEDURE [XREF] iip$report_unhandled_data_msg (VAR msg:
    iit$input_data_message);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
?? POP ??
*DECK DECK=IIP$REPORT_UNHANDLED_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] iip$report_unhandled_message (msg: ^cell;
    arbinfo: mlt$arbitrary_info;
    sender_name: mlt$application_name;
    msg_length: mlt$message_length);

?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=IIP$REPORT_UNHANDLED_SUPER_MSG EXPAND=FALSE

  PROCEDURE [XREF] iip$report_unhandled_super_msg (VAR msg:
    iit$input_supervisory_message);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
?? POP ??
*DECK DECK=IIP$REQUEST_DEFAULT_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$request_default_attributes
    (connection_description_pointer: ^iit$connection_description;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$RESTORE_TERM_CONN_ATRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$restore_term_conn_atributes (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IIP$ROUTE EXPAND=FALSE

  PROCEDURE [XREF] iip$route (user_identification: ost$user_identification;
        user_supplied_job_name: jmt$user_supplied_name;
        system_job_parameters: jmt$system_job_parameters;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$user_identification
*copyc jmt$user_supplied_name
*copyc jmt$system_job_parameters
*copyc ost$status
?? POP ??
*DECK DECK=IIP$SEARCH_CONNECTION_DESC EXPAND=FALSE

  PROCEDURE [XREF] iip$search_connection_desc (session_file: amt$local_file_name;
    VAR connection_desc_ptr: ^iit$connection_description);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc iit$connection_description
?? POP ??
*DECK DECK=IIP$SEND_ATTRIBUTES_CHANGE EXPAND=FALSE

  PROCEDURE [XREF] iip$send_attributes_change (downline_queue_entry_pointer:
    ^iit$downline_queue_entry;
    connection_desc_pointer: ^iit$connection_description;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$SEND_OUTPUT_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] iip$send_output_message (wait: boolean;
      VAR status: ost$status);
*DECK DECK=IIP$SEND_TO_PASS_ON EXPAND=FALSE

  PROCEDURE [XREF] iip$send_to_pass_on (application_name: mlt$application_name;
    message_pointer: ^cell;
    message_length: mlt$message_length;
    message_type: mlt$arbitrary_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$SET_BAM_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$set_bam_attributes (local_file_name:
    amt$local_file_name;
        connection_attributes: ift$connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ift$connection_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IIP$SET_DEFAULT_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$set_default_attributes (input_super_message_pointer:
    ^ iit$input_supervisory_message;
    connection_description_pointer: ^iit$connection_description;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$SET_LOCK EXPAND=FALSE

  PROCEDURE [INLINE] iip$set_lock (VAR lock: ost$signature_lock;
    wait: ost$wait;
    VAR status: ost$status);

?? EJECT ??

VAR
   locked: boolean;

    status.normal := TRUE;

  /lock_loop/
    WHILE TRUE DO
      osp$test_set_job_sig_lock (lock, locked);
      IF locked THEN
        RETURN;
      ELSE

{ osc$wait - wait for lock until available

        IF wait = osc$wait THEN
          pmp$long_term_wait (750, 750);
          CYCLE /lock_loop/;
        IFEND;

{ osc$nowait - return if break in progress, else wait

        IF NOT pmp$ts_task_io_enabled () THEN
          CASE iiv$break_reason OF
          = iic$user_break_1 =
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$pause_break_received, '', status);
          = iic$user_break_2 =
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$terminate_break_received, '', status);
          ELSE
            osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$connection_break_disconnect, '', status);
          CASEND;
          RETURN;
        ELSE
          pmp$long_term_wait (750, 750);
          CYCLE /lock_loop/;
        IFEND;
      IFEND;
    WHILEND /lock_loop/;
  PROCEND iip$set_lock;

?? PUSH (LISTEXT := ON) ??
*copyc OST$WAIT
*copyc OST$SIGNATURE_LOCK
*copyc OSP$SET_JOB_SIGNATURE_LOCK
*copyc pmp$ts_task_io_enabled
*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSP$TEST_SET_JOB_SIG_LOCK
*copyc PMP$LONG_TERM_WAIT
*copyc IFE$ERROR_CODES
*copyc IIT$CONNECTION_DESCRIPTION
*copyc IIV$INTERACTIVE_TERMINATED
*copyc IIV$INT_TASK_OPEN_FILE_COUNT
*copyc IIV$CONNECTION_DESC_PTR
?? POP ??
*DECK DECK=IIP$SET_TERMINAL_NAME EXPAND=FALSE

  PROCEDURE [XREF] iip$set_terminal_name (terminal_name: ift$terminal_name);

?? PUSH (LISTEXT := ON) ??
*copyc ift$terminal_name
?? POP ??
*DECK DECK=IIP$SIGN_OFF EXPAND=FALSE
  PROCEDURE [XREF] iip$sign_off (application_name: mlt$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=IIP$SIGN_ON EXPAND=FALSE
  PROCEDURE [XREF] iip$sign_on (VAR application_name: mlt$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=IIP$SKIP_TO_EOR EXPAND=FALSE

  PROCEDURE [XREF] iip$skip_to_eor (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$open_file_description;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$STORE_CONTEXT EXPAND=FALSE

  PROCEDURE [XREF] iip$store_context (file_id: amt$file_identifier;
        context_attributes: ift$store_context_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ift$store_context_attributes
?? POP ??
*DECK DECK=IIP$STORE_TERMINAL EXPAND=FALSE

  PROCEDURE [XREF] iip$store_terminal (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$open_file_description;
    terminal_attributes: ^ift$connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc ift$connection_attributes
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$STORE_TERM_CONN_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$store_term_conn_attributes (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$st_open_file_description;
    terminal_attributes: ^ift$connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc IFT$CONNECTION_ATTRIBUTES
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$ST_ALLOCATE_QUEUE_ENTRY EXPAND=TRUE


  PROCEDURE [XREF] iip$st_allocate_queue_entry (queue_key: iit$queue_key;
    VAR queue_entry_descriptor: iit$st_queue_entry_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$ST_CHNGE_TERM_CONN_DEFAULTS EXPAND=FALSE

  PROCEDURE [XREF] iip$st_chnge_term_conn_defaults (terminal_file_name: amt$local_file_name;
    connection_attributes: ift$connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ift$connection_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IIP$ST_CHNG_TERMINAL_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$st_chng_terminal_attributes (terminal_file_name: amt$local_file_name;
    terminal_attributes: ift$terminal_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ift$terminal_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IIP$ST_CHNG_TERM_CONN_ATRIBUTES EXPAND=FALSE
  PROCEDURE [XREF] iip$st_chng_term_conn_atributes (terminal_file_name: amt$local_file_name;
    connection_attributes: ift$connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc iit$connection_description
*copyc ost$status
?? POP ??
*DECK DECK=IIP$ST_CLONE_CONNECTION EXPAND=FALSE
PROCEDURE [XREF] iip$st_clone_connection (
      VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IIP$ST_CLOSE EXPAND=FALSE

  PROCEDURE [XREF] iip$st_close (file_id: amt$file_identifier;
    VAR open_file_desc_pointer: ^iit$st_open_file_description;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc AMT$FILE_IDENTIFIER
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$ST_CLR_INPUT_OUTPUT_COUNTS EXPAND=FALSE

    PROCEDURE [XREF] iip$st_clr_input_output_counts (VAR status:ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IIP$ST_FETCH_ACCESS_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] iip$st_fetch_access_information (file_id: amt$file_identifier;
    st_open_file_desc_pointer: ^iit$st_open_file_description;
    access_information: ^amt$access_information;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$ACCESS_INFORMATION
*copyc AMT$FILE_IDENTIFIER
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$ST_FLUSH EXPAND=FALSE

  PROCEDURE [XREF] iip$st_flush (file_id: amt$file_identifier;
        open_file_desc_pointer: ^iit$st_open_file_description;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IIP$ST_FREE_QUEUE_ENTRY EXPAND=TRUE


  PROCEDURE [XREF] iip$st_free_queue_entry (queue_key: iit$queue_key;
    VAR queue_entry_descriptor: iit$st_queue_entry_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$ST_GET EXPAND=FALSE

  PROCEDURE [XREF] iip$st_get (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$st_open_file_description;
    operation: amt$fap_operation;
    working_storage_area: ^cell;
    working_storage_length: nat$data_length;
    record_length: ^amt$max_record_length;
    transfer_count: ^amt$transfer_count;
    byte_address: ^amt$file_byte_address;
    file_position: ^amt$file_position;
    skip_option: amt$skip_option;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amd$operation_declarations
*copyc ame$terminal_validation_errors
*copyc amt$file_byte_address
*copyc amt$file_identifier
*copyc amt$file_position
*copyc amt$max_record_length
*copyc amt$skip_option
*copyc amt$transfer_count
*copyc nat$data_length
*copyc ife$interactive_exception_codes
*copyc iit$connection_description
*copyc ost$status
?? POP ??
*DECK DECK=IIP$ST_GET_INPUT_OUTPUT_COUNTS EXPAND=FALSE

  PROCEDURE [XREF] iip$st_get_input_output_counts
    (VAR input_count: ost$non_negative_integers;
     VAR output_count: ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc osd$integer_limits
?? POP ??
*DECK DECK=IIP$ST_GET_TERMINAL_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$st_get_terminal_attributes (file_name: amt$local_file_name;
    VAR terminal_attributes: ift$terminal_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ift$terminal_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IIP$ST_INITIALIZE_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] iip$st_initialize_connection (terminal_file_name:
    amt$local_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
?? POP ??
*DECK DECK=IIP$ST_INIT_OPEN_DESC_ATRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$st_init_open_desc_atributes (file_id: ost$name;
    open_file_desc_pointer: ^iit$st_open_file_description;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$ST_OPEN EXPAND=FALSE

  PROCEDURE [XREF] iip$st_open (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$st_open_file_description;
    file_name: amt$local_file_name;
    layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_layer_number
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$LOCAL_FILE_NAME
*copyc iit$connection_description
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$ST_PUT EXPAND=FALSE

  PROCEDURE [XREF] iip$st_put (file_id: amt$file_identifier;
    open_file_desc_pointer: ^iit$st_open_file_description;
    operation: amt$fap_operation;
    working_storage_area: ^cell;
    working_storage_length: amt$working_storage_length;
    byte_address: ^amt$file_byte_address;
    term_option: amt$term_option;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_BYTE_ADDRESS
*copyc AMT$FILE_IDENTIFIER
*copyc AMD$OPERATION_DECLARATIONS
*copyc AMT$TERM_OPTION
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$ST_REPLACE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$st_replace_attributes (connection_attributes: iit$connection_attributes;
    attribute_source_selections: iit$attribute_source_selections;
    destination: ^iit$connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc ost$status
?? POP ??
*DECK DECK=IIP$ST_SEND_ATTRIBUTES_CHANGE EXPAND=FALSE

  PROCEDURE [XREF] iip$st_send_attributes_change (downline_queue_entry_pointer:
    ^iit$st_downline_queue_entry;
        count: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iit$connection_description
*copyc ost$status
?? POP ??
*DECK DECK=IIP$ST_SEND_OUTPUT_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] iip$st_send_output_message (connection_desc_ptr:
        ^iit$connection_description;
        vtp_file_id: amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IIP$ST_UPDATE_ACTUAL_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$st_update_actual_attributes (connection_desc_ptr: ^iit$connection_description;
        new_attributes: ift$connection_attributes;
        source: ift$connection_attribute_source);

?? PUSH (LISTEXT := ON) ??
*copyc ift$connection_attributes
*copyc ift$connection_attribute_source
*copyc iit$connection_description
?? POP ??
*DECK DECK=IIP$ST_UPDATE_DEFAULT_ATRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$st_update_default_atributes (connection_desc_ptr: ^iit$connection_description;
        new_attributes: ift$connection_attributes;
        source: ift$connection_attribute_source);

?? PUSH (LISTEXT := ON) ??
*copyc ift$connection_attributes
*copyc ift$connection_attribute_source
*copyc iit$connection_description
?? POP ??
*DECK DECK=IIP$SUPPRESS_CURSOR_POS_ECHOPLX EXPAND=FALSE

PROCEDURE [XREF] iip$suppress_cursor_pos_echoplx (
    suppress_cursor_positioning: boolean;
    suppress_echoplexing: boolean);

*copyc iih$suppress_cursor_pos_echoplx
?? PUSH (LISTEXT := ON) ??
*copyc iiv$interactive_terminated
?? POP ??
*DECK DECK=IIP$TERMINAL EXPAND=FALSE

  PROCEDURE [XREF] iip$terminal (terminal_attributes:
    ift$connection_attributes;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ift$connection_attributes
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$TERMINAL_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] iip$terminal_command (terminal_attributes:
    ift$terminal_attributes;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ift$terminal_attributes
*copyc IFE$ERROR_CODES
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$TERMINAL_KEYS_TO_VT_KINDS EXPAND=FALSE

  PROCEDURE [XREF] iip$terminal_keys_to_vt_kinds (terminal_attributes: ift$terminal_attributes;
    VAR vt_kinds: iit$vt_attribute_kinds);

{   This routine is needed by IFP$GET_TERMINAL_ATTRIBUTES to build a iit$vt_attribute_kinds array
{   which will subsequently be used as input on a iip$vt_query_attributes call.

?? PUSH (LISTEXT := ON) ??
*copyc iit$vt_attributes
*copyc ift$terminal_attributes
?? POP ??
*DECK DECK=IIP$TERMINAL_TO_VT_ATTRIBUTES EXPAND=FALSE


  PROCEDURE [XREF] iip$terminal_to_vt_attributes (terminal_attributes: ift$terminal_attributes;
    VAR vt_attributes: iit$vt_attributes);

?? PUSH (LISTEXT := ON) ??
*copyc iit$vt_attributes
*copyc ift$terminal_attributes
?? POP ??
*DECK DECK=IIP$TERMINATE_DISCONNECTED_JOB EXPAND=FALSE
procedure [xref] iip$terminate_disconnected_job;
*DECK DECK=IIP$TIME_DELAY EXPAND=FALSE

  PROCEDURE [XREF] iip$time_delay (millisecond_delay: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$UPDATE_OPEN_DESC_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$update_open_desc_attributes (file_id:
    amt$file_identifier;
        open_file_desc_pointer: ^iit$open_file_description;
        operation: amt$fap_operation;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=IIP$VTP_CREATE_CDCNET_CONNECT EXPAND=FALSE

  PROCEDURE [XREF] iip$vtp_create_cdcnet_connect
    (    service_name: ost$name;
         service_data: ^SEQ ( * );
         connection_data_1: ^SEQ ( * );
         connection_data_2: ^SEQ ( * );
         connection_data_3: ^SEQ ( * );
         end_discard_prompt: ^SEQ ( * );
         timeout_interval_in_ms: 0 .. 0ffffffff(16);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ife$error_codes
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=IIP$VTP_CREATE_PAIRED_CONNECT EXPAND=FALSE

  PROCEDURE [XREF] iip$vtp_create_paired_connect
    (    file_identifier: amt$file_identifier;
         destination_title: ost$name;
         paired_connection_data: ^SEQ ( * );
         timeout_interval_in_ms: 0 .. 0ffffffff(16);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ife$error_codes
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=IIP$VTP_DELETE_PAIRED_CONNECT EXPAND=FALSE

  PROCEDURE [XREF] iip$vtp_delete_paired_connect
    (    file_identifier: amt$file_identifier;
         paired_connection_data: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=IIP$VTP_DEL_PAIRED_CON_FIRST EXPAND=FALSE

  PROCEDURE [XREF] iip$vtp_del_paired_con_first
    (    paired_connection_data: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IIP$VTP_GET_NEXT EXPAND=FALSE
  PROCEDURE [XREF] iip$vtp_get_next (file_identifier:
    amt$file_identifier;
    working_storage_area: ^cell;
    working_storage_length: amt$working_storage_length;
    timeout: iit$vt_timeout;
    VAR input_information: iit$vt_input_information;
    VAR transfer_count: amt$transfer_count;
    VAR status: ost$status);
*copyc amt$file_identifier
*copyc amt$working_storage_length
*copyc amt$transfer_count
*copyc iit$vt_input_information
*copyc iit$vt_timeout
*copyc ost$status
*DECK DECK=IIP$VTP_OPEN_NETWORK EXPAND=FALSE
  PROCEDURE [XREF] iip$vtp_open_network (VAR file_id: amt$file_identifier;
    VAR status: ost$status);
*copyc amt$file_identifier
*copyc ost$status
*DECK DECK=IIP$VTP_PUT_NEXT EXPAND=FALSE
  PROCEDURE [XREF] iip$vtp_put_next (file_identifier:
    amt$file_identifier;
    working_storage_area: ^cell;
    working_storage_length: amt$working_storage_length;
    VAR status: ost$status);
*copyc amt$file_identifier
*copyc amt$working_storage_length
*copyc ost$status
*DECK DECK=IIP$VT_CHANGE_ATTRIBUTES EXPAND=FALSE
{IIP$VT_CHANGE_ATTRIBUTES is in module IIM$VTP_INTERFACE.}

PROCEDURE [XREF] iip$vt_change_attributes (connection: iit$vtp_connection_id;
      file_identifier: amt$file_identifier;
      attributes: iit$vt_attributes;
      wait: ost$wait;
  VAR activity_status: ost$activity_status;
  VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc nat$data_fragments
*copyc ost$activity_status
*copyc iit$vt_attributes
*copyc ost$wait
*copyc ost$status
?? POP ??
*DECK DECK=IIP$VT_CHECK_DATA_AVAILABLE EXPAND=TRUE


 PROCEDURE [XREF] iip$vt_check_data_available (
        file_identifier: amt$file_identifier;
    VAR activity_complete: boolean;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??

*DECK DECK=IIP$VT_CLOSE EXPAND=FALSE

PROCEDURE [XREF] iip$vt_close (file_identifier: amt$file_identifier;
  VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=IIP$VT_CREATE_ATTRIBUTE_OCTETS EXPAND=FALSE

    PROCEDURE [XREF] iip$vt_create_attribute_octets (attributes: iit$vt_attributes;
      VAR buffer: ^SEQ ( * );
      VAR data_length: nat$data_length);

*copyc iit$vt_attributes
*copyc nat$data_fragments
*DECK DECK=IIP$VT_FLUSH_INPUT EXPAND=FALSE
{iip$vt_flush_input is in module IIM$VTP_INTERFACE.}

PROCEDURE [XREF] iip$vt_flush_input (connection: iit$vtp_connection_id;
  VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc iit$vt_connections
*copyc iit$vt_input_information
*copyc ost$status
?? POP ??

*DECK DECK=IIP$VT_GET_ATTR_CH_INDICATIONS EXPAND=FALSE
{iip$vt_get_attr_ch_INDICATIONS is in module IIM$VTP_INTERFACE.}

PROCEDURE [XREF] iip$vt_get_attr_ch_indications (vtp_connection_id: iit$vtp_connection_id;
  VAR attributes: iit$vt_attributes;
  VAR number_of_attributes: 0 .. iic$vt_max_number_of_attributes;
  VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iit$vt_attributes
*copyc iit$vt_connections
*copyc ost$status
?? POP ??
*DECK DECK=IIP$VT_GET_CHANGE_RESPONSE EXPAND=FALSE
{iip$vt_get_change_response is in module IIM$VTP_INTERFACE.}

PROCEDURE [XREF] iip$vt_get_change_response (vtp_connection_id: iit$vtp_connection_id;
      file_identifier: amt$file_identifier;
      wait: ost$wait;
  VAR error_code: iit$vt_change_error_codes;
  VAR attribute_error_pairs: array [1 .. 2] OF iit$vt_attribute;
  VAR response_received: boolean;
  VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
*copyc ost$wait
*copyc iit$vt_attributes
*copyc iit$vt_connections
?? POP ??
*DECK DECK=IIP$VT_GET_QUERY_RESPONSE EXPAND=FALSE
{iip$vt_get_query_response is in module IIM$VTP_INTERFACE.}

PROCEDURE [XREF] iip$vt_get_query_response (connection: iit$vtp_connection_id;
      file_identifier: amt$file_identifier;
      wait: ost$wait;
  VAR confirmed: boolean;
  VAR attributes: iit$vt_attributes;
  VAR unknown_an: iit$vt_attribute_kind;
  VAR response_received: boolean;
  VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc iit$vt_connections
*copyc iit$vt_attributes
*copyc iit$vt_attribute_kinds
*copyc ost$status
?? POP ??
*DECK DECK=IIP$VT_INITIALIZE_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] iip$vt_initialize_connection (VAR vtp_connection_id: iit$vtp_connection_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iit$vt_connections
*copyc ost$status
?? POP ??

*DECK DECK=IIP$VT_INPUT EXPAND=FALSE
{iip$vt_input is in module IIM$VTP_INTERFACE.}

PROCEDURE [XREF] iip$vt_input (connection: iit$vtp_connection_id;
      file_identifier: amt$file_identifier;
      buffer_ptr: ^cell;
      buffer_length: nat$data_length;
      timeout: iit$vt_timeout;
  VAR message_received: boolean;
  VAR end_of_message: boolean;
  VAR transfer_count: nat$data_length;
  VAR input_information: iit$vt_input_information;
  VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc iit$vt_connections
*copyc iit$vt_timeout
*copyc nat$wait_time
*copyc nat$data_fragments
*copyc iit$vt_input_information
*copyc ost$status
?? POP ??
*DECK DECK=IIP$VT_KIND_TO_IF_KEY EXPAND=FALSE

  PROCEDURE [XREF] iip$vt_kind_to_if_key (vt_kind: iit$vt_attribute_kind;
    VAR if_key: ift$terminal_attribute_keys);

{   This routine was inspired by the need in IFP$GET_TERMINAL_ATTRIBUTES to convert any
{   possible error, a iit$vt_attribute_kind, to its equivalent in ift$terminal_attribute_keys.

?? PUSH (LISTEXT := ON) ??
*copyc iit$vt_attribute_kinds
*copyc ift$terminal_attribute_keys
?? POP ??
*DECK DECK=IIP$VT_OPEN EXPAND=FALSE

PROCEDURE [XREF] iip$vt_open (lfn: amt$local_file_name;
  VAR file_identifier: amt$file_identifier;
  VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=IIP$VT_OUTPUT EXPAND=FALSE

PROCEDURE [XREF] iip$vt_output (connection: iit$vtp_connection_id;
      file_identifier: amt$file_identifier;
      data: nat$data_fragments;
      output_information: iit$vt_output_information;
      wait: ost$wait;
  VAR activity_status: ost$activity_status;
  VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc nat$data_fragments
*copyc iit$vt_output_information
*copyc iit$vt_connections
*copyc ost$activity_status
*copyc ost$status
?? POP ??
*DECK DECK=IIP$VT_QUERY_ATTRIBUTES EXPAND=FALSE
{IIP$VT_QUERY_ATTRIBUTES is in module IIM$VTP_INTERFACE.}

PROCEDURE [XREF] iip$vt_query_attributes (vtp_connection_id: iit$vtp_connection_id;
      file_identifier: amt$file_identifier;
      attribute_kinds: iit$vt_attribute_kinds;
      wait: ost$wait;
  VAR activity_status: ost$activity_status;
  VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$activity_status
*copyc ost$status
*copyc ost$wait
*copyc iit$vt_attribute_kinds
?? POP ??
*DECK DECK=IIP$VT_TERMINATE_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] iip$vt_terminate_connection (VAR vtp_connection_id: iit$vtp_connection_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iit$vt_connections
*copyc ost$status
?? POP ??
*DECK DECK=IIP$VT_TO_CONNECTION_ATTRIBUTES EXPAND=FALSE
  PROCEDURE [XREF] iip$vt_to_connection_attributes (vt_attributes: iit$vt_attributes;
    VAR if_attributes: ift$connection_attributes);

?? PUSH (LISTEXT := ON) ??
*copyc iit$vt_attributes
*copyc ift$connection_attributes
?? POP ??



*DECK DECK=IIP$VT_TO_TERMINAL_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$vt_to_terminal_attributes (vt_attributes: iit$vt_attributes;
    VAR terminal_attributes: ift$terminal_attributes);

?? PUSH (LISTEXT := ON) ??
*copyc iit$vt_attributes
*copyc ift$terminal_attributes
?? POP ??
*DECK DECK=IIP$VT_VALIDATE_FILE_IDENTIFIER EXPAND=FALSE

PROCEDURE [XREF] iip$vt_validate_file_identifier (file_identifier: amt$file_identifier;
  VAR file_name: amt$local_file_name;
  VAR file_id_is_valid: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
?? POP ??
*DECK DECK=IIP$XLATE_LOCAL_FILE_TO_SESSION EXPAND=FALSE

  PROCEDURE [XREF] iip$xlate_local_file_to_session (file_name: amt$local_file_name;
    VAR terminal_file_name: amt$local_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ost$status
?? POP ??
*DECK DECK=IIP$XT_CHECK_DOWNLINE EXPAND=FALSE

  PROCEDURE [XREF] iip$xt_check_downline
    (    file_identifier: amt$file_identifier;
     VAR activity_complete: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=IIP$XT_CHECK_UPLINE EXPAND=FALSE

  PROCEDURE [XREF] iip$xt_check_upline
    (    file_identifier: amt$file_identifier;
     VAR activity_complete: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??

*DECK DECK=IIP$XT_CLOSE_FILE EXPAND=FALSE

  PROCEDURE [XREF] iip$xt_close_file
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=IIP$XT_CREATE_MESSAGE_FILE EXPAND=FALSE

  PROCEDURE [XREF] iip$xt_create_message_file
    (    file_reference: fst$file_reference;
     VAR file_identifier: amt$file_identifier;
     VAR segment_pointer: amt$segment_pointer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$segment_pointer
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=IIP$XT_CREATE_NETWORK_FILE EXPAND=FALSE
  PROCEDURE [XREF] iip$xt_create_network_file
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=IIP$XT_CREATE_XTERM_FILES EXPAND=FALSE

  PROCEDURE [XREF] iip$xt_create_xterm_files
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=IIP$XT_EXECUTE_XTERM_COMMAND EXPAND=FALSE
  PROCEDURE [XREF] iip$xt_execute_xterm_command
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=IIP$XT_FETCH_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$xt_fetch_attributes
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
*copyc nae$namve_conditions
?? POP ??
*DECK DECK=IIP$XT_GET_TERMINAL_ATTRIBUTES EXPAND=TRUE
  PROCEDURE [XREF] iip$xt_get_terminal_attributes
    (    file_name: amt$local_file_name;
     VAR terminal_attributes: ift$terminal_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ift$terminal_attributes
*copyc ost$status
?? POP ??
*DECK DECK=IIP$XT_INITIALIZE_XTERM EXPAND=FALSE
  PROCEDURE [XREF] iip$xt_initialize_xterm
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IIP$XT_IS_XTERM_FILE EXPAND=FALSE
  FUNCTION [XREF] iip$xt_is_xterm_file
    (    system_file_label_p: ^fmt$system_file_label): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc fmt$system_file_label
?? POP ??
*DECK DECK=IIP$XT_LOCK_DOWNLINE_MESSAGES EXPAND=TRUE
  PROCEDURE [XREF] iip$xt_lock_downline_messages
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IIP$XT_LOCK_UPLINE_MESSAGES EXPAND=TRUE
  PROCEDURE [XREF] iip$xt_lock_upline_messages
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IIP$XT_OPEN_DOWNLINE_MESSAGES EXPAND=FALSE
  PROCEDURE [XREF] iip$xt_open_downline_messages
    (VAR file_identifier: amt$file_identifier;
     VAR segment_pointer: amt$segment_pointer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$segment_pointer
*copyc ost$status
?? POP ??
*DECK DECK=IIP$XT_OPEN_FILE EXPAND=FALSE
  PROCEDURE [XREF] iip$xt_open_file
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
?? POP ??

*DECK DECK=IIP$XT_OPEN_MESSAGE_FILE EXPAND=FALSE

  PROCEDURE [XREF] iip$xt_open_message_file
    (    file_reference: fst$file_reference;
     VAR file_identifier: amt$file_identifier;
     VAR segment_pointer: amt$segment_pointer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$segment_pointer
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=IIP$XT_OPEN_UPLINE_MESSAGES EXPAND=FALSE
  PROCEDURE [XREF] iip$xt_open_upline_messages
    (VAR file_identifier: amt$file_identifier;
     VAR segment_pointer: amt$segment_pointer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$segment_pointer
*copyc ost$status
?? POP ??
*DECK DECK=IIP$XT_READY_TASK EXPAND=FALSE
  PROCEDURE [XREF] iip$xt_ready_task
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=IIP$XT_RECEIVE_DATA EXPAND=FALSE
  PROCEDURE [XREF] iip$xt_receive_data
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
         start_time: integer;
     VAR request_started: boolean;
     VAR wait_time: nat$wait_time;
     VAR activity_status: ^ost$activity_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc nat$wait_time
*copyc ost$activity_status
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
*copyc nae$internal_interactive_appl
?? POP ??
*DECK DECK=IIP$XT_REDIRECT_XTERM_OUTPUT EXPAND=FALSE
  PROCEDURE [XREF] iip$xt_redirect_xterm_output
    (    working_storage_area: ^cell;
         working_storage_length: amt$working_storage_length;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$working_storage_length
*copyc ost$status
?? POP ??

*DECK DECK=IIP$XT_ROUTE EXPAND=FALSE
  PROCEDURE [XREF] iip$xt_route
    (    user_id: ost$user_identification;
         user_supplied_job_name: jmt$user_supplied_name;
         system_job_parameters: jmt$system_job_parameters;
     VAR system_supplied_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$user_supplied_name
*copyc jmt$system_job_parameters
*copyc jmt$system_supplied_name
*copyc ost$status
*copyc ost$user_identification
?? POP ??

*DECK DECK=IIP$XT_SEND_DATA EXPAND=FALSE

  PROCEDURE [XREF] iip$xt_send_data
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
         start_time: integer;
     VAR request_started: boolean;
     VAR wait_time: nat$wait_time;
     VAR activity_status: ^ost$activity_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc nat$wait_time
*copyc ost$activity_status
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
*copyc nae$internal_interactive_appl
?? POP ??
*DECK DECK=IIP$XT_SEND_INTERRUPT EXPAND=FALSE

  PROCEDURE [XREF] iip$xt_send_interrupt
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=IIP$XT_SEND_SIGNAL EXPAND=FALSE

  PROCEDURE [XREF] iip$xt_send_signal
    (    interrupt_character: char;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IIP$XT_STOP_XTERM EXPAND=FALSE
  PROCEDURE [XREF] iip$xt_stop_xterm
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=IIP$XT_STORE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] iip$xt_store_attributes
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
?? POP ??

*DECK DECK=IIP$XT_SYNCHRONIZE EXPAND=FALSE

  PROCEDURE [XREF] iip$xt_synchronize
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=IIP$XT_SYNCHRONIZE_CONFIRM EXPAND=FALSE

  PROCEDURE [XREF] iip$xt_synchronize_confirm
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=IIP$XT_UNLOCK_DOWNLINE_MESSAGES EXPAND=FALSE
  PROCEDURE [XREF] iip$xt_unlock_downline_messages
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IIP$XT_UNLOCK_UPLINE_MESSAGES EXPAND=FALSE
  PROCEDURE [XREF] iip$xt_unlock_upline_messages
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IIP$XT_WAIT_FOR_XTERM EXPAND=FALSE
  PROCEDURE [XREF] iip$xt_wait_for_xterm
    (    system_supplied_name: jmt$system_supplied_name;
     VAR examine_job_file: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??

*DECK DECK=IIP$XT_WRITE_TRACE EXPAND=FALSE

  PROCEDURE [XREF] iip$xt_write_trace
    (    working_storage_area: string ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=IIP$XT_WRITE_TRACE_STATUS EXPAND=FALSE

  PROCEDURE [XREF] iip$xt_write_trace_status
    (    working_storage_area: string ( * );
         trace_status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=IIP$XT_XTERM_FAP EXPAND=FALSE
  PROCEDURE [XREF] iip$xt_xterm_fap
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc ost$status
?? POP ??

*DECK DECK=IIT$APPLICATION_NAMES_MESSAGES EXPAND=FALSE
{ DAH controls modifications to this deck

  CONST

{ Memory link pre-defined application names

    iic$passon_application_name = 9190053(16), { 'IFPAS'/152633427(10) }
    iic$exec_application_name = 9185605(16), { 'IFEXE'/152589829(10) }
    iic$user_application_prefix = 1, { Prefix for User Tasks }

{ Memory link arbitrary information (passon to 180 applications)
{ Note:
{  For output data messages, the value of the arbitrary info parameter
{  should be iic$output_data_message + connection_number

    iic$input_supervisory_message = 1,
    iic$input_data_message = 2,
    iic$output_supervisory_message = 3,
    iic$output_data_message = 10,

{ Application block type

    iic$null_block = 0,
    iic$continued_block = 1,
    iic$last_block = 2,
    iic$supervisory_block = 3,
    iic$begin_absentee = 10,
    iic$dont_signal = 1024,
{ Application connection number

    iic$min_connection_number = 1,
    iic$max_connection_number = 0fff(16),
    iic$supervisory_connection_num = 0,

{ Application block number

    iic$min_block_number = 1,
    iic$max_block_number = 3ffff(16),

{ Application character type

    iic$60_bit_characters = 1,
    iic$8_bit_characters = 2,
    iic$8_of_12_bit_characters = 3,
    iic$display_code_characters = 4,

{ Text length in a block

    iic$min_text_length = 0,
    iic$max_text_length = 0fff(16),

{ Supervisory message primary function codes

    iic$pfc_connect = 63(16),
    iic$pfc_control = 0c1(16),
    iic$pfc_data_control = 0c2(16),
    iic$pfc_error = 84(16),
    iic$pfc_flow_control = 83(16),
    iic$pfc_interrupt = 80(16),
    iic$pfc_list = 0c0(16),
    iic$pfc_message = 0e0(16),
    iic$pfc_shutdown = 42(16),
    iic$pfc_term_char = 64(16),
    iic$pfc_break_indication = 0ca(16),
    iic$pfc_resume_output = 0cb(16),
    iic$pfc_180_interactive = 0f0(16),

{ Supervisory message secondary function codes

    iic$sfc_break = 0,
    iic$sfc_reset_connection = 1,
    iic$sfc_acknowlege = 2,
    iic$sfc_negative_acknowlege = 3,
    iic$sfc_inactive = 4,
    iic$sfc_output_stopped = 5,
    iic$sfc_start_output = 6,
    iic$sfc_initialized = 7,
    iic$sfc_off = 0,
    iic$sfc_on = 1,
    iic$sfc_switch_lists = 2,
    iic$sfc_half_duplex = 4,
    iic$sfc_change_character_type = 0,
    iic$sfc_term_char_changed = 0,
    iic$sfc_logical = 1,
    iic$sfc_shutdown = 6,
    iic$sfc_request = 0,
    iic$sfc_appl_connection_request = 2,
    iic$sfc_connection_broken = 5,
    iic$sfc_end = 6,
    iic$sfc_redefine = 4,
    iic$sfc_start_input = 5,
    iic$sfc_stop_input = 6,
    iic$sfc_input_stopped = 7,
    iic$sfc_cdcnet_define_term_char = 2,
    iic$sfc_define_term_char = 8,
    iic$sfc_cdcnet_request_term_chr = 0b(16),
    iic$sfc_request_term_char = 9,
    iic$sfc_term_char_definitions = 10,
    iic$sfc_cdcnet_term_char_define = 0c(16),
    iic$sfc_cdcnet_unsolct_term_chr = 0d(16),
    iic$sfc_local_operator = 7,
    iic$sfc_hold = 0,
    iic$sfc_hold_acknowlege = 1,
    iic$sfc_unhold = 2,
    iic$sfc_change_job_monitor = 3,
    iic$sfc_job_monitor_changed = 4,
    iic$sfc_read_request = 5,
    iic$sfc_start_interactive = 6,
    iic$sfc_stop_interactive = 7,
    iic$sfc_read_rejected = 8,
    iic$sfc_absentee_begun = 9,
    iic$sfc_terminate = 10,
    iic$sfc_response = 1,
    iic$sfc_user = 0,
    iic$sfc_mark = 0,

{ Error and response codes in supervisory messages

    iic$request = 00(2),
    iic$normal = 01(2),
    iic$abnormal = 10(2),

{ Supervisory message types: primary function, error/response, secondary

{ CON / CB / R }
    iic$sm_connection_broken = iic$pfc_connect * 100(16) + iic$request * 40(16)
      + iic$sfc_connection_broken,
{ CON / END / N }
    iic$sm_connection_ended = iic$pfc_connect * 100(16) + iic$normal * 40(16) +
      iic$sfc_end,
{ CON / END / R }
    iic$sm_end_connection = iic$pfc_connect * 100(16) + iic$request * 40(16) +
      iic$sfc_end,
{ CON / REQ / A }
    iic$sm_connection_rejected = iic$pfc_connect * 100(16) + iic$abnormal *
      40(16) + iic$sfc_request,
{ CON / REQ / N }
    iic$sm_connection_accepted = iic$pfc_connect * 100(16) + iic$normal *
      40(16) + iic$sfc_request,
{ CON / REQ / R }
    iic$sm_connection_request = iic$pfc_connect * 100(16) + iic$request *
      40(16) + iic$sfc_request,
{ CTRL / DEF / R }
    iic$sm_redefine_term_char = iic$pfc_control * 100(16) + iic$request *
      40(16) + iic$sfc_redefine,
{ CTRL / START / R }
    iic$sm_start_input = iic$pfc_control * 100(16) + iic$request * 40(16) +
      iic$sfc_start_input,
{ CTRL / STOP / R }
    iic$sm_stop_input = iic$pfc_control * 100(16) + iic$request * 40(16) +
      iic$sfc_stop_input,
{ CTRL / STPD / R }
    iic$sm_input_stopped = iic$pfc_control * 100(16) + iic$request * 40(16) +
      iic$sfc_input_stopped,
{ CTRL / CTD / R }
    iic$sm_cdcnet_define_term_char = iic$pfc_control * 100(16) + iic$request * 40(16)
      + iic$sfc_cdcnet_define_term_char,
{ CTRL / CTD / A }
    iic$sm_cdcnet_define_term_chr_a = iic$pfc_control * 100(16) + iic$abnormal * 40(16)
      + iic$sfc_cdcnet_define_term_char,
{ CTRL / CTD / N }
    iic$sm_cdcnet_define_term_chr_n = iic$pfc_control * 100(16) + iic$normal * 40(16)
      + iic$sfc_cdcnet_define_term_char,
{ CTRL / CHAR / R }
    iic$sm_define_term_char = iic$pfc_control * 100(16) + iic$request * 40(16)
      + iic$sfc_define_term_char,
{ CTRL / CHAR / A }
    iic$sm_define_term_char_a = iic$pfc_control * 100(16) + iic$abnormal *
      40(16) + iic$sfc_define_term_char,
{ CTRL / CHAR / N }
    iic$sm_define_term_char_n = iic$pfc_control * 100(16) + iic$normal * 40(16)
      + iic$sfc_define_term_char,
{ CTRL / RTC / R }
    iic$sm_request_term_char = iic$pfc_control * 100(16) + iic$request * 40(16)
      + iic$sfc_request_term_char,
{ CTRL / RCC / R }
    iic$sm_cdcnet_request_term_char = iic$pfc_control * 100(16) + iic$request * 40(16)
      + iic$sfc_cdcnet_request_term_chr,
{ CTRL / RTC / A }
    iic$sm_request_term_char_a = iic$pfc_control * 100(16) + iic$abnormal *
      40(16) + iic$sfc_request_term_char,
{ CTRL / RCC / A }
    iic$sm_cdcnet_request_trm_chr_a = iic$pfc_control * 100(16) + iic$abnormal *
      40(16) + iic$sfc_cdcnet_request_term_chr,
{ CTRL / TCD / N }
    iic$sm_term_char_definitions = iic$pfc_control * 100(16) + iic$request *
      40(16) + iic$sfc_term_char_definitions,
{ CTRL / CCD / N }
    iic$sm_cdcnet_term_char_defines = iic$pfc_control * 100(16) + iic$request *
      40(16) + iic$sfc_cdcnet_term_char_define,
{ CTRL / UCD / N }
    iic$sm_cdcnet_unsolct_term_char = iic$pfc_control * 100(16) + iic$request *
      40(16) + iic$sfc_cdcnet_unsolct_term_chr,
{ DC / CICT / R }
    iic$sm_change_character_type = iic$pfc_data_control * 100(16) + iic$request
      * 40(16) + iic$sfc_change_character_type,
{ ERR / LGL / R }
    iic$sm_logical_error = iic$pfc_error * 100(16) + iic$request * 40(16) +
      iic$sfc_logical,
{ FC / ACK / R }
    iic$sm_block_delivered = iic$pfc_flow_control * 100(16) + iic$request *
      40(16) + iic$sfc_acknowlege,
{ FC / BRK / R }
    iic$sm_break = iic$pfc_flow_control * 100(16) + iic$request * 40(16) +
      iic$sfc_break,
{ FC / INACT / R }
    iic$sm_inactive_connection = iic$pfc_flow_control * 100(16) + iic$request *
      40(16) + iic$sfc_inactive,
{ FC / INIT / N }
    iic$sm_connection_initialized = iic$pfc_flow_control * 100(16) + iic$normal
      * 40(16) + iic$sfc_initialized,
{ FC / INIT / R }
    iic$sm_initialized_connection = iic$pfc_flow_control * 100(16) +
      iic$request * 40(16) + iic$sfc_initialized,
{ FC / NAK / R }
    iic$sm_block_not_delivered = iic$pfc_flow_control * 100(16) + iic$request *
      40(16) + iic$sfc_negative_acknowlege,
{ FC / RST / R }
    iic$sm_reset_connection = iic$pfc_flow_control * 100(16) + iic$request *
      40(16) + iic$sfc_reset_connection,
{ FC / STP / R }
    iic$sm_output_stopped = iic$pfc_flow_control * 100(16) + iic$request *
      40(16) + iic$sfc_output_stopped,
{ FC / STRT / R }
    iic$sm_start_output = iic$pfc_flow_control * 100(16) + iic$request * 40(16)
      + iic$sfc_start_output,
{ INTR / RSP / N }
    iic$sm_interrupt_response = iic$pfc_interrupt * 100(16) + iic$request *
      40(16) + iic$sfc_response,
{ INTR / USR / R }
    iic$sm_interrupt_user = iic$pfc_interrupt * 100(16) + iic$request * 40(16)
      + iic$sfc_user,
{ LST / OFF / R }
    iic$sm_list_off = iic$pfc_list * 100(16) + iic$request * 40(16) +
      iic$sfc_off,
{ LST / ON / R }
    iic$sm_list_on = iic$pfc_list * 100(16) + iic$request * 40(16) +
      iic$sfc_on,
{ LST / SWH / R }
    iic$sm_list_switch = iic$pfc_list * 100(16) + iic$request * 40(16) +
      iic$sfc_switch_lists,
{ LST / HDX / R }
    iic$sm_list_half_duplex = iic$pfc_list * 100(16) + iic$request * 40(16) +
      iic$sfc_half_duplex,
{ MSG / LOP / R }
    iic$sm_message_to_operator = iic$pfc_message * 100(16) + iic$request *
      40(16) + iic$sfc_local_operator,
{ SHUT / INSD / R }
    iic$sm_shutdown = iic$pfc_shutdown * 100(16) + iic$request * 40(16) +
      iic$sfc_shutdown,
{ TCH / TCHAR / R }
    iic$sm_term_char_changed = iic$pfc_term_char * 100(16) + iic$request *
      40(16) + iic$sfc_term_char_changed,
{ IFP / HOLD / R }
    iic$sm_hold = iic$pfc_180_interactive * 100(16) + iic$request * 40(16) +
      iic$sfc_hold,
{ IFP / HOLD_ACK / R }
    iic$sm_hold_acknowlege = iic$pfc_180_interactive * 100(16) + iic$request *
      40(16) + iic$sfc_hold_acknowlege,
{ IFP / UNHOLD / R }
    iic$sm_unhold = iic$pfc_180_interactive * 100(16) + iic$request * 40(16) +
      iic$sfc_unhold,
{ IFP / CHANGE_JM / R }
    iic$sm_change_job_monitor = iic$pfc_180_interactive * 100(16) + iic$request
      * 40(16) + iic$sfc_change_job_monitor,
{ IFP / JM_CHANGED / R }
    iic$sm_job_monitor_changed = iic$pfc_180_interactive * 100(16) +
      iic$request * 40(16) + iic$sfc_job_monitor_changed,
{ IFP / READ_REQ / R }
    iic$sm_read_request = iic$pfc_180_interactive * 100(16) + iic$request *
      40(16) + iic$sfc_read_request,
{ IFP / TERMINATE / R }
    iic$sm_terminate = iic$pfc_180_interactive * 100(16) + iic$request * 40(16) +
      iic$sfc_terminate,
{ IFP / START_INTERACTIVE / R }
    iic$sm_start_interactive = iic$pfc_180_interactive * 100(16) + iic$request
      * 40(16) + iic$sfc_start_interactive,
{ IFP / INTERACTIVE_STARTED / N }
    iic$sm_interactive_started = iic$pfc_180_interactive * 100(16) + iic$normal
      * 40(16) + iic$sfc_start_interactive,
{ IFP / STOP_INTERACTIVE / R }
    iic$sm_stop_interactive = iic$pfc_180_interactive * 100(16) + iic$request *
      40(16) + iic$sfc_stop_interactive,
{ IFP / READ_REJECTED / A }
    iic$sm_read_rejected = iic$pfc_180_interactive * 100(16) + iic$abnormal *
      40(16) + iic$sfc_read_rejected,
{ IFP / ABSENTEE_BEGUN / N }
    iic$sm_absentee_begun = iic$pfc_180_interactive * 100(16) + iic$normal *
      40(16) + iic$sfc_absentee_begun,
{ BI  / MARK / R }
    iic$sm_break_indication_mark = iic$pfc_break_indication * 100(16) +
      iic$request * 40(16) + iic$sfc_mark,
{ RO  / MARK / R }
    iic$sm_resume_output_mark = iic$pfc_resume_output * 100(16) + iic$request *
      40(16) + iic$sfc_mark,

{ Supervisory message lengths - in words
{ Note that the length does not include the message header word

    iic$l_connection_broken = 1,
    iic$l_connection_ended = 1,
    iic$l_end_connection = 2,
    iic$l_connection_rejected = 1,
    iic$l_connection_accepted = 1,
    iic$l_connection_request = 63,
    iic$l_redefine_term_char = 3,
    iic$l_start_input = 1,
    iic$l_stop_input = 1,
    iic$l_input_stopped = 1,
    iic$l_change_character_type = 1,
    iic$l_logical_error = 3,
    iic$l_block_delivered = 1,
    iic$l_break = 1,
    iic$l_inactive_connection = 1,
    iic$l_interrupt_response = 1,
    iic$l_interrupt_user = 1,
    iic$l_connection_initialized = 1,
    iic$l_initialized_connection = 1,
    iic$l_block_not_delivered = 1,
    iic$l_reset_connection = 1,
    iic$l_output_stopped = 1,
    iic$l_start_output = 1,
    iic$l_list_off = 1,
    iic$l_list_on = 1,
    iic$l_list_switch = 1,
    iic$l_half_duplex = 1,
    iic$l_message_to_operator = 9,
    iic$l_shutdown = 1,
    iic$l_term_char_redefined = 1,
    iic$l_define_term_char = (((2 * iic$max_term_char_pairs) * 2) DIV 15)
      + 2,
    iic$l_request_term_char = (((2 * iic$max_term_char_pairs) * 2) DIV
      15) + 2,
    iic$l_cdcnet_request_term_char = 1,
    iic$l_term_char_definitions = (((2 * iic$max_term_char_pairs) * 2)
      DIV 15) + 2,
    iic$l_define_term_char_a = 1,
    iic$l_define_term_char_n = 1,
    iic$l_request_term_char_a = 1,
    iic$l_hold = 1,
    iic$l_terminate = 1,
    iic$l_hold_acknowlege = 1,
    iic$l_unhold = 1,
    iic$l_change_job_monitor = 2,
    iic$l_job_monitor_changed = 1,
    iic$l_read_request = 1,
    iic$l_start_interactive = 1,
    iic$l_interactive_started = 1,
    iic$l_stop_interactive = 1,
    iic$l_read_rejected = 1,
    iic$l_absentee_begun = 1,
    iic$l_break_indication_mark = 1,
    iic$l_resume_output_mark = 2,

{ Application block limit

    iic$min_block_limit = 1,
    iic$max_block_limit = 7,

{ Terminal device type

    iic$console = 0,
    iic$card_reader = 1,
    iic$line_printer = 2,
    iic$card_punch = 3,
    iic$plotter = 4,

{ Terminal class values

    iic$tty_class = 1,
    iic$c75x_class = 2,
    iic$c721_class = 3,
    iic$i2741_class = 4,
    iic$tty40_class = 5,
    iic$h2000_class = 6,
    iic$x364_class = 7,
    iic$t4010_class = 8,
    iic$hasp_post_print_class = 9,
    iic$c200ut_class = 10,
    iic$c714_30_class = 11,
    iic$c711_class = 12,
    iic$c714_10_or_20_class = 13,
    iic$hasp_pre_print_class = 14,
    iic$c73x_class = 15,
    iic$i2740_class = 16,
    iic$i3780_class = 17,
    iic$i3270_class = 18,

{ Input device values

    iic$keyboard_input = 0,
    iic$block_mode_input = 2,

{ Output device values

    iic$printer_output = 0,
    iic$display_output = 1,

{ Transparent types

    iic$single_message = 0,
    iic$multi_message = 1,

{ End line cursor position values

    iic$elp_none = 0,
    iic$elp_crs = 1,
    iic$elp_lfs = 2,
    iic$elp_crslfs = 3,

{ End partial cursor position values

    iic$epp_none = 0,
    iic$epp_crs = 1,
    iic$epp_lfs = 2,
    iic$epp_crslfs = 3,

{ Parity values

    iic$zero_parity = 0,
    iic$odd_parity = 1,
    iic$even_parity = 2,
    iic$no_parity = 3,
    iic$ignore_parity = 4,

{ Terminal device ordinal

    iic$min_device_ordinal = 0,
    iic$max_device_ordinal = 7,

{ Terminal page dimensions

    iic$min_page_width = 0,
    iic$max_page_width = 255,
    iic$min_page_length = 0,
    iic$max_page_length = 255,

{ Application block size

    iic$min_block_size = 1,
    iic$max_block_size = 2043,
    iic$max_input_block_size = 3275,
    iic$max_block_length_in_words = 410,

{ Application list number

    iic$min_list_number = 0,
    iic$max_list_number = 63,
    iic$normal_input_list_number = 1,
    iic$collector_input_list_number = 2,

{ Special ascii control characters

    iic$ascii_us = CHR (1f(16)),

{ Connection reject reasons

    iic$bad_connection_number = 1,
    iic$unspecified_reject = 2,
    iic$application_is_full = 3,
    iic$invalid_for_application = 4,

{ Application connection reject reasons

    iic$application_not_running_etc = 1,
    iic$shutdown_in_progress = 2,
    iic$too_many_appl_connections = 3,

{ Connection broken reasons

    iic$communications_lost = 1,
    iic$nam_broke_connection = 2,

{ Block-not-delivered reasons

    iic$nam_lost_the_block = 1,

{ Break reasons

    iic$user_break_1 = 1,
    iic$user_break_2 = 2,
    iic$output_device_not_ready = 3,
    iic$bad_data = 4,

{ Stop-output reasons

    iic$terminal_busy = 1,
    iic$terminal_failure = 2,
    iic$console_interrupted_batch = 3,

{ Input-stopped reasons

    iic$stopped_by_application = 0,
    iic$card_reader_not_ready = 1,
    iic$card_slippage = 2,
    iic$end_of_information = 3,
    iic$console_interrupted_reader = 4,

{ Message to local operator

    iic$max_operator_message_chars = 80,
    iic$max_operator_message_words = 8,

{ Logical error reasons

    iic$invalid_character_type = 1,
    iic$invalid_text_length = 2,
    iic$invalid_block_type = 3,
    iic$invalid_connection_number = 4,
    iic$block_limit_exceeded = 5,
    iic$too_many_errors = 6,
    iic$invalid_supervisory = 7,
    iic$fragmented_io_error = 8,

{ Terminal characteristics pairs

    iic$max_term_char_pairs = 37,

{ Terminal characteristics pairs field numbers

    iic$fn_lockout_unsolicited_msgs = 32,
    iic$fn_terminal_class = 34,
    iic$fn_page_width = 35,
    iic$fn_page_length = 36,
    iic$fn_hold_page = 37,
    iic$fn_cancel_line_character = 38,
    iic$fn_backspace_character = 39,
    iic$fn_network_cmd_character = 40,
    iic$fn_pause_break_character = 42,
    iic$fn_term_break_character = 43,
    iic$fn_cr_delay_default = 46,
    iic$fn_lf_delay_default = 47,
    iic$fn_special_editing = 48,
    iic$fn_echoplex = 49,
    iic$fn_parity = 50,
    iic$fn_user_break_1 = 51,
    iic$fn_trans_input_mode = 52,
    iic$fn_input_device = 53,
    iic$fn_output_device = 54,
    iic$fn_full_ascii = 55,
    iic$fn_trans_delim_char_select = 56,
    iic$fn_trans_delim_count_most = 57,
    iic$fn_trans_delim_count_least = 58,
    iic$fn_trans_delim_character = 59,
    iic$fn_trans_delim_timeout = 60,
    iic$fn_end_line_character = 61,
    iic$fn_eol_cursor_positioning = 63,
    iic$fn_end_block_character = 64,
    iic$fn_eob_cursor_positioning = 66,
    iic$fn_input_flow_control = 67,
    iic$fn_output_flow_control = 68,
    iic$fn_trans_mode_delim_char = 69,
    iic$fn_trans_input_type = 70,
    iic$fn_cursor_positioning = 71,
    iic$fn_full_duplex = 87,
    iic$fn_pacer_prompting = 102,
    iic$fn_solicited_mode = 112,
    iic$fn_trans_mode_delim_lock = 146,
    iic$fn_cr_delay_count = 147,
    iic$fn_lf_delay_count = 148,
    iic$fn_trans_interruptable = 149,


{ Terminal characteristic pairs array index keys for connection attributes

    iic$key_user_break_1 = 1,               { attention character action }
    iic$key_full_duplex = 2,                { input output mode--full duplex }
    iic$key_solicited_mode = 3,             { input output mode--solicited/unsolicited }
    iic$key_input_device = 4,               { partial character forwarding }
    iic$key_special_editing = 5,            { store backspace character }
    iic$key_full_ascii = 6,                 { store nuls dels }
    iic$key_trans_input_mode = 7,           { input editing mode }
    iic$key_trans_delim_char_select = 8,    { transparent character mode--on/off }
    iic$key_trans_input_type = 9,           { transparent type--single/multi }
    iic$key_trans_delim_count_most = 10,    { upper byte of transparent count }
    iic$key_trans_delim_count_least = 11,   { lower byte of transparent count }
    iic$key_trans_delim_timeout = 12,       { transparent timeout mode--on/off }
    iic$key_trans_mode_delim_lock = 13,     { transparent timeout mode--"sticky" }
    iic$key_trans_delim_character = 14,     { transparent forwarding character }
    iic$key_trans_mode_delim_char = 15,     { transparent character mode delimiter }

{ Terminal characteristics

    iic$key_terminal_class = 16,
    iic$key_page_width = 17,
    iic$key_page_length = 18,
    iic$key_cancel_line_character = 19,
    iic$key_backspace_character = 20,
    iic$key_cr_delay_count = 21,
    iic$key_lf_delay_count = 22,
    iic$key_echoplex = 23,
    iic$key_hold_page = 24,
    iic$key_parity = 25,
    iic$key_network_cmd_character = 26,
    iic$key_end_partial_character = 27,
    iic$key_end_partial_positioning = 28,
    iic$key_end_line_character = 29,
    iic$key_end_line_positioning = 30,
    iic$key_input_flow_control = 31,
    iic$key_output_flow_control = 32,
    iic$key_lockout_unsolicited_msg = 33,
    iic$key_pacer_prompting = 34,
    iic$key_output_device = 35,
    iic$key_pause_break_character = 36,
    iic$key_term_break_character = 37,

{ Terminal characteristics error reason codes

    iic$term_char_no_error = 0,
    iic$term_char_illegal_value = 1,
    iic$term_char_duplicate_char = 2,
    iic$term_char_invalid_for_tc = 3,
    iic$term_char_illegal_tc_change = 4,
    iic$term_char_illegal_param = 5;

*copyc iic$vt_max_output_mess_length

  TYPE

{ Types used in message block definitions

    iit$170_word = packed record
      ?IF ifv$module_for_c180 = TRUE THEN
        pad1: iit$word_fill,
      ?IFEND
      left_half: 0 .. 3fffffff(16),
      right_half: 0 .. 3fffffff(16),
    recend,
    iit$address = 0 .. 0fff(16),
    iit$application_block_limit = 0 .. 7,
    iit$application_block_number = 0 .. 3ffff(16),
    iit$application_block_type = 0 .. 3f(16),
    iit$application_character_type = 0 .. 0f(16),
    iit$application_connection_num = 0 .. 0fff(16),
    iit$application_list_number = 0 .. 3f(16),
    iit$appl_connection_rej_reason = 0 .. 0ff(16),
    iit$block_not_delivered_reason = 0 .. 0ff(16),
    iit$block_size = 1 .. 7ff(16),
    iit$break_reason = 0 .. 0ff(16),
    iit$cancel_input = boolean,
    iit$connection_broken_reason = 0 .. 0ff(16),
    iit$connection_reject_reason = 0 .. 0ff(16),
    iit$device_ordinal = 0 .. 0ff(16),
    iit$device_type = 0 .. 7,
    iit$display_code = 0 .. 3f(16),
    iit$downline_data_block =
    ?IF ifv$module_for_c180 = TRUE THEN
      array [1 .. * ] of char,
    ?ELSE
      array [1 .. * ] of iit$170_ascii_word,
    ?IFEND
    iit$error = boolean,
    iit$family_ordinal = 0 .. 3ffff(16),
    iit$field_number = 0 .. 0ff(16),
    iit$field_value = 0 .. 0ff(16),
    iit$half_byte = 0 .. 0f(16),
    iit$hardwired_line = boolean,
    iit$immediate_shutdown = boolean,
    iit$input_block_undeliverable = boolean,
    iit$input_data_block =
    ?IF ifv$module_for_c180 = TRUE THEN
      array [1 .. iic$max_input_block_size] of char,
    ?ELSE
      array [1 .. iic$max_block_length_in_words] of iit$170_ascii_word,
    ?IFEND
    iit$input_stopped_reason = 0 .. 0ff(16),
    iit$logical_error_abh = iit$170_ascii_word,
    iit$logical_error_reason = 0 .. 0ff(16),
    iit$logical_error_word_1 = iit$170_ascii_word,
    iit$login_family_name = packed array [1 .. 7] of iit$display_code,
    iit$login_user_name = packed array [1 .. 7] of iit$display_code,
    iit$nam_application_name = packed array [1 .. 10] of iit$display_code,
    iit$nibble_string = packed array [0 .. 3 * iic$max_block_size + 1000] of
      iit$half_byte,
    iit$cdcnet = boolean,
    iit$new_application_list_number = 0 .. 3f(16),
    iit$no_format_effectors = boolean,
    iit$operator_message_length = 0 .. 0fff(16),
    iit$output_data_block =
    ?IF ifv$module_for_c180 = TRUE THEN
      array [1 .. ((iic$max_block_size * 16 + 20) DIV 10)] of char,
        { 2043 + ((2043 DIV 5) DIV 2) + (2043 DIV 2) + 2   affords enough space for
        { each character, each word's 4-bit memory link zero, and the 4-bit zero of
        { each 8-of-12 character.
    ?ELSE
      array [1 .. iic$max_block_length_in_words] of iit$170_ascii_word,
    ?IFEND
    iit$owning_console_name = packed array [1 .. 7] of iit$display_code,
    iit$page_length = 0 .. 0ff(16),
    iit$page_width = 0 .. 0ff(16),
    iit$parity_error = boolean,
    iit$primary_function_code = 0 .. 3f(16),
    iit$punch_banner_card = boolean,
    iit$redefined_terminal_class = 0 .. 0ff(16),
    iit$response = boolean,
    iit$secondary_function_code = 0 .. 3f(16),
    iit$stop_output_reason = 0 .. 0ff(16),
    iit$supervisory_message_type = 0 .. 0ffff(16),
    iit$term_char_pair = record
      field_number: iit$field_number,
      field_value: iit$field_value,
    recend,
    iit$cdcnet_term_char_pair = record
      application_number: iit$field_number,
      application_value: iit$field_value,
    recend,
    iit$term_char_string = array [1 .. iic$max_term_char_pairs] of
      iit$term_char_pair,
    iit$cdcnet_term_char_string =
      array [1 .. iic$vt_max_output_mess_length] of iit$field_value,
    iit$term_char_values = array [1 .. iic$max_term_char_pairs] of
      iit$field_value,
    iit$terminal_class = 0 .. 1f(16),
    iit$terminal_definition = packed array [1 .. 17] of iit$half_byte,
    iit$terminal_name = packed array [1 .. 7] of iit$display_code,
    iit$text_length = 0 .. 0fff(16),
    iit$transparent_mode = boolean,
    iit$upline_data_block =
    ?IF ifv$module_for_c180 = TRUE THEN
      array [1 .. * ] of char,
    ?ELSE
      array [1 .. * ] of iit$170_ascii_word,
    ?IFEND
    iit$user_index = 0 .. 3ffff(16),
    iit$word_fill = 0 .. 0f(16),
    iit$170_ascii_word = packed record
      ?IF ifv$module_for_c180 = TRUE THEN
        pad1: iit$word_fill,
      ?IFEND
      left_nibble: packed array [0 .. 7] of iit$half_byte,
      right_nibble: packed array [0 .. 6] of iit$half_byte,
    recend,
    iit$170_display_word = packed record
      ?IF ifv$module_for_c180 = TRUE THEN
        pad1: iit$word_fill,
      ?IFEND
      left_character: packed array [0 .. 4] of iit$display_code,
      right_character: packed array [0 .. 4] of iit$display_code,
    recend,

{ Application block headers

    iit$input_data_block_header = packed record
      ?IF ifv$module_for_c180 = TRUE THEN
        pad1: iit$word_fill,
      ?IFEND
      block_type: iit$application_block_type,
      connection_number: iit$application_connection_num,
      block_number: iit$application_block_number,
      character_type: iit$application_character_type,
      undeliverable: iit$input_block_undeliverable,
      zero1: 0 .. 0f(16),
      transparent: iit$transparent_mode,
      cancel: iit$cancel_input,
      parity_error: iit$parity_error,
      text_length: iit$text_length,
    recend,

    iit$output_data_block_header = packed record
      ?IF ifv$module_for_c180 = TRUE THEN
        pad1: iit$word_fill,
      ?IFEND
      block_type: iit$application_block_type,
      connection_number: iit$application_connection_num,
      block_number: iit$application_block_number,
      character_type: iit$application_character_type,
      zero1: 0 .. 0f(16),
      no_format_effectors: iit$no_format_effectors,
      transparent: iit$transparent_mode,
      suppress_echo: boolean,
      auto_input: boolean,
      text_length: iit$text_length,
    recend,

    iit$input_supervisory_header = packed record
      ?IF ifv$module_for_c180 = TRUE THEN
        pad1: iit$word_fill,
      ?IFEND
      block_type: iit$application_block_type,
      address: iit$address,
      fill1: 0 .. 3ffff(16),
      character_type: iit$application_character_type,
      undeliverable: iit$input_block_undeliverable,
      fill2: 0 .. 7f(16),
      text_length: iit$text_length,
    recend,

    iit$output_supervisory_header = packed record
      ?IF ifv$module_for_c180 = TRUE THEN
        pad1: iit$word_fill,
      ?IFEND
      block_type: iit$application_block_type,
      address: iit$address,
      block_number: iit$application_block_number,
      character_type: iit$application_character_type,
      fill1: 0 .. 0ff(16),
      text_length: iit$text_length,
    recend,

{ Supervisory messages

    iit$connection_request = packed record { CON / REQ / R }
      fill1: 0 .. 0ff(16),
      connection_number: iit$application_connection_num,
      block_limit: iit$application_block_limit,
      fill2: 0 .. 0f(16),
      hardwired: iit$hardwired_line,
      device_type: iit$device_type,
      terminal_class: iit$terminal_class,
      device_ordinal: iit$device_ordinal,
      ?IF ifv$module_for_c180 = TRUE THEN
        pad2: iit$word_fill,
      ?IFEND
      terminal_name: iit$terminal_name,
      fill3: 0 .. 3(16),
      page_width: iit$page_width,
      page_length: iit$page_length,
      ?IF ifv$module_for_c180 = TRUE THEN
        pad3: iit$word_fill,
      ?IFEND
      owning_console_name: iit$owning_console_name,
      fill4: 0 .. 3f(16),
      block_size: iit$block_size,
      fill5: 0 .. 1,
      ?IF ifv$module_for_c180 = TRUE THEN
        pad4: iit$word_fill,
      ?IFEND
      fill6: 0 .. 0fff(16),
      fill7: 0 .. 0ffffffffffff(16),
      ?IF ifv$module_for_c180 = TRUE THEN
        pad5: iit$word_fill,
      ?IFEND
      family_name: iit$login_family_name,
      family_ordinal: iit$family_ordinal,
      ?IF ifv$module_for_c180 = TRUE THEN
        pad6: iit$word_fill,
      ?IFEND
      user_name: iit$login_user_name,
      user_index: iit$user_index,
      other_stuff: array [1 .. 57] of iit$170_display_word,
    recend,

    iit$connection_accepted = packed record { CON / REQ / N }
      fill1: 0 .. 0ff(16),
      connection_number: iit$application_connection_num,
      fill2: 0 .. 3fff(16),
      character_type: iit$application_character_type,
      list_number: iit$application_list_number,
    recend,

    iit$connection_rejected = packed record { CON / REQ / A }
      reason: iit$connection_reject_reason,
      connection_number: iit$application_connection_num,
      fill1: 0 .. 0ffffff(16),
    recend,

    iit$initialized_connection = packed record { FC / INIT / R }
      fill1: 0 .. 0ff(16),
      connection_number: iit$application_connection_num,
      fill2: 0 .. 0ffffff(16),
    recend,

    iit$connection_initialized = packed record { FC / INIT / N }
      fill1: 0 .. 0ff(16),
      connection_number: iit$application_connection_num,
      fill2: 0 .. 0ffffff(16),
    recend,

    iit$connection_broken = packed record { CON / CB / R }
      reason: iit$connection_broken_reason,
      connection_number: iit$application_connection_num,
      fill1: 0 .. 0ffffff(16),
    recend,

    iit$end_connection = packed record { CON / END / R }
      zero1: 0 .. 0ff(16),
      connection_number: iit$application_connection_num,
      fill1: 0 .. 0ffffff(16),
      zero2: iit$170_display_word,
    recend,

    iit$connection_ended = packed record { CON / END / N }
      fill1: 0 .. 0ff(16),
      connection_number: iit$application_connection_num,
      fill2: 0 .. 0ffffff(16),
    recend,

    iit$appl_connection_request_rej = packed record { CON / ACRQ / A }
      reason: iit$appl_connection_rej_reason,
      fill1: 0 .. 0fffffffff(16),
      ?IF ifv$module_for_c180 = TRUE THEN
        pad2: iit$word_fill,
      ?IFEND
      application_name: iit$nam_application_name,
      fill2: 0 .. 3ffff(16),
    recend,

    iit$inactive_connection = packed record { FC / INACT / R }
      fill1: 0 .. 0ff(16),
      connection_number: iit$application_connection_num,
      fill2: 0 .. 0ffffff(16),
    recend,

    iit$interrupt_user = packed record { INTR / USR / R }
      alpha: char,
      connection_number: iit$application_connection_num,
      fill1: 0 .. 0ffffff(16),
    recend,

    iit$list_off = packed record { LST / OFF / R }
      fill1: 0 .. 0ff(16),
      connection_number: iit$application_connection_num,
      fill2: 0 .. 0ffffff(16),
    recend,

    iit$list_on = packed record { LST / ON / R }
      fill1: 0 .. 0ff(16),
      connection_number: iit$application_connection_num,
      fill2: 0 .. 0ffffff(16),
    recend,

    iit$list_switch = packed record { LST / SWH / R }
      fill1: 0 .. 0ff(16),
      connection_number: iit$application_connection_num,
      fill2: 0 .. 3ffff(16),
      new_list_number: iit$new_application_list_number,
    recend,

     iit$list_half_duplex = packed record { LST / HDX / R }
      fill1: 0 .. 0ff(16),
      connection_number: iit$application_connection_num,
      disable: 0 .. 0ffffff(16),
    recend,

    iit$block_delivered = packed record { FC / ACK / R }
      fill1: 0 .. 0ff(16),
      connection_number: iit$application_connection_num,
      block_number: iit$application_block_number,
      fill2: 0 .. 3f(16),
    recend,

    iit$block_not_delivered = packed record { FC / NAK / R }
      reason: iit$block_not_delivered_reason,
      connection_number: iit$application_connection_num,
      block_number: iit$application_block_number,
      fill1: 0 .. 3f(16),
    recend,

    iit$break = packed record { FC / BRK / R }
      reason: iit$break_reason,
      connection_number: iit$application_connection_num,
      block_number: iit$application_block_number,
      fill1: 0 .. 3f(16),
    recend,

    iit$reset_connection = packed record { FC / RST / R }
      fill1: 0 .. 0ff(16),
      connection_number: iit$application_connection_num,
      fill2: 0 .. 0ffffff(16),
    recend,

    iit$output_stopped = packed record { FC / STP / R }
      reason: iit$stop_output_reason,
      connection_number: iit$application_connection_num,
      last_good_block: iit$application_block_number,
      fill1: 0 .. 3f(16),
    recend,

    iit$start_output = packed record { FC / STRT / R }
      fill1: 0 .. 0ff(16),
      connection_number: iit$application_connection_num,
      fill2: 0 .. 0ffffff(16),
    recend,

    iit$start_input = packed record { CTRL / STRT / R }
      fill1: 0 .. 0fffffffffff(16),
    recend,

    iit$stop_input = packed record { CTRL / STOP / R }
      fill1: 0 .. 0fffffffffff(16),
    recend,

    iit$input_stopped = packed record { CTRL / STPD / R }
      reason: iit$input_stopped_reason,
      fill1: 0 .. 0fffffffff(16),
    recend,

    iit$cdcnet_define_term_char = packed record { CTRL / CTD / R }
      array_of_octets: array [1 .. iic$vt_max_output_mess_length] of iit$term_char_pair,
    recend,

    iit$define_term_char = packed record { CTRL / CHAR / R }
      term_char_string: iit$term_char_string,
    recend,

    iit$define_term_char_n = packed record { CTRL / CHAR / N }
      fill1: 0 .. 0fffffffffff(16)
    recend,

    iit$define_term_char_a = packed record { CTRL / CHAR / A }
      field_number: iit$field_number,
      reason_code: 0 .. 0ff(16),
    recend,

    iit$request_term_char = packed record { CTRL / RTC / R }
      term_char_string: iit$term_char_string,
    recend,

    iit$request_term_char_a = packed record { CTRL / RTC / A }
      field_number: iit$field_number,
      reason_code: 0 .. 0ff(16),
    recend,

    iit$cdcnet_request_term_char_a = packed record { CTRL / RCC / A }
      attribute_number: iit$field_number,
    recend,

    iit$term_char_definitions = packed record { CTRL / TCD / N }
      term_char_string: iit$term_char_string,
    recend,

    iit$cdcnet_term_char_defines = packed record { CTRL / CCD / N }
      array_of_octets: iit$cdcnet_term_char_string,
    recend,

    iit$change_character_type = packed record { DC / CICT / R }
      fill1: 0 .. 0ff(16),
      connection_number: iit$application_connection_num,
      fill2: 0 .. 0fff(16),
      character_type: iit$application_character_type,
    recend,

    iit$term_char_redefined = packed record { TCH / TCHAR / R }
      fill1: 0 .. 0ff(16),
      connection_number: iit$application_connection_num,
      terminal_class: iit$terminal_class,
      page_width: iit$page_width,
      page_length: iit$page_length,
    recend,

    iit$redefine_term_char = packed record { CTRL / DEF / R }
      terminal_definition: iit$terminal_definition,
    recend,

    iit$message_to_operator = packed record { MSG / LOP / R }
      fill1: 0 .. 0ff(16),
      number_of_characters: 0 .. 0fff(16),
      fill2: 0 .. 0ffffff(16),
      message: packed array [1 .. iic$max_operator_message_words] of
        iit$170_display_word,
    recend,

    iit$shutdown = packed record { SHUT / INSD / R }
      fill1: 0 .. 7ffffffffff(16),
      immediate: iit$immediate_shutdown,
    recend,

    iit$logical_error = packed record { ERR / LGL / R }
      reason: iit$logical_error_reason,
      fill1: 0 .. 0fffffffff(16),
      bad_header: iit$logical_error_abh,
      first_word_of_block: iit$logical_error_word_1,
    recend,

    iit$hold = packed record { IFP / HOLD / R }
      connection_number: iit$application_connection_num,
      fill1: 0 .. 0ffffffff(16),
    recend,

    iit$hold_acknowlege = packed record { IFP / HOLD_ACK / R }
      fill1: 0 .. 0fffffffffff(16),
    recend,

    iit$unhold = packed record { IFP / UNHOLD / R }
      connection_number: iit$application_connection_num,
      fill1: 0 .. 0ffffffff(16),
    recend,

    iit$change_job_monitor = packed record { IFP / CHANGE_JM / R }
      fill1: 0 .. 0fffffffffff(16),
      new_jm: integer,
    recend,

    iit$job_monitor_changed = packed record { IFP / JM_CHANGED / R }
      fill1: 0 .. 0fffffffffff(16),
    recend,

    iit$read_rejected = packed record { IFP / READ_REJECTED / A }
      fill1: 0 .. 0fffffffffff(16),
    recend,

    iit$absentee_begun = packed record { IFP / ABSENTEE_BEGUN / N }
      fill1: 0 .. 0fffffffffff(16),
    recend,

    iit$read_request = packed record { IFP / READ_REQ / R }
      connection_number: iit$application_connection_num,
      begin_absentee: boolean,
      notify_if_absentee_started: boolean,
      fill1: 0 .. 3fffffff(16),
    recend,

    iit$input_data_message = record
      header: iit$input_data_block_header,
      data: iit$input_data_block,
    recend,

    iit$upline_data_message = record
      header: iit$input_data_block_header,
      data: iit$upline_data_block,
    recend,

    iit$output_data_message = record
      header: iit$output_data_block_header,
      data: iit$output_data_block,
    recend,

    iit$downline_data_message = record
      header: iit$output_data_block_header,
      data: iit$downline_data_block,
    recend,

    iit$general_message = packed array [1 .. iic$max_block_length_in_words + 1]
      of iit$170_word,

    iit$input_supervisory_message = packed record
      header: iit$input_supervisory_header,
      ?IF ifv$module_for_c180 = TRUE THEN
        pad1: iit$word_fill,
      ?IFEND
      case message_type: iit$supervisory_message_type of
      = iic$sm_connection_broken = { CON / CB / R }
        connection_broken: iit$connection_broken,
      = iic$sm_connection_ended = { CON / END / N }
        connection_ended: iit$connection_ended,
      = iic$sm_connection_request = { CON / REQ / R }
        conreq_fill1: 0 .. 0ff(16),
        conreq_connection_number: iit$application_connection_num,
        conreq_block_limit: iit$application_block_limit,
        conreq_fill2: 0 .. 0f(16),
        conreq_hardwired: iit$hardwired_line,
        conreq_device_type: iit$device_type,
        conreq_terminal_class: iit$terminal_class,
        conreq_device_ordinal: iit$device_ordinal,
        ?IF ifv$module_for_c180 = TRUE THEN
          conreq_pad2: iit$word_fill,
        ?IFEND
        conreq_terminal_name: iit$terminal_name,
        conreq_fill3: 0 .. 3(16),
        conreq_page_width: iit$page_width,
        conreq_page_length: iit$page_length,
        ?IF ifv$module_for_c180 = TRUE THEN
          conreq_pad3: iit$word_fill,
        ?IFEND
        conreq_owning_console_name: iit$owning_console_name,
        conreq_fill4a: 0 .. 1,
        conreq_cdcnet_connection: iit$cdcnet,
        conreq_fill4b: 0 .. 0f(16),
        conreq_block_size: iit$block_size,
        conreq_fill5: 0 .. 1,
        ?IF ifv$module_for_c180 = TRUE THEN
          conreq_pad4: iit$word_fill,
        ?IFEND
        conreq_fill6: 0 .. 0fff(16),
        conreq_fill7: 0 .. 0ffffffffffff(16),
        ?IF ifv$module_for_c180 = TRUE THEN
          conreq_pad5: iit$word_fill,
        ?IFEND
        conreq_family_name: iit$login_family_name,
        conreq_family_ordinal: iit$family_ordinal,
        ?IF ifv$module_for_c180 = TRUE THEN
          conreq_pad6: iit$word_fill,
        ?IFEND
        conreq_user_name: iit$login_user_name,
        conreq_user_index: iit$user_index,
        conreq_other_stuff: array [1 .. 57] of iit$170_display_word,
      = iic$sm_input_stopped = { CTRL / STPD / R }
        input_stopped: iit$input_stopped,
      = iic$sm_term_char_definitions = { CTRL / TCD / N }
        ctrltcd_pad1: 0 .. 0f(16),
        term_char_definitions: iit$term_char_definitions,
      = iic$sm_cdcnet_term_char_defines = { CTRL / CCD / N }
        cdcnet_term_char_defines: iit$cdcnet_term_char_defines,
      = iic$sm_logical_error = { ERR / LGL / R }
        errlgl_reason: iit$logical_error_reason,
        errlgl_fill1: 0 .. 0fffffffff(16),
        errlgl_bad_header: iit$170_ascii_word,
        errlgl_first_word_of_block: iit$logical_error_word_1,
      = iic$sm_block_delivered = { FC / ACK / R }
        block_delivered: iit$block_delivered,
      = iic$sm_break = { FC / BRK / R }
        break: iit$break,
      = iic$sm_reset_connection = { FC / RST / R }
        reset_connection: iit$reset_connection,
      = iic$sm_inactive_connection = { FC / INACT / R }
        inactive_connection: iit$inactive_connection,
      = iic$sm_initialized_connection = { FC / INIT / R }
        initialized_connection: iit$initialized_connection,
      = iic$sm_block_not_delivered = { FC / NAK / R }
        block_not_delivered: iit$block_not_delivered,
      = iic$sm_output_stopped = { FC / STP / R }
        output_stopped: iit$output_stopped,
      = iic$sm_start_output = { FC / STRT / R }
        start_output: iit$start_output,
      = iic$sm_shutdown = { SHUT / INSD / R }
        shutdown: iit$shutdown,
      = iic$sm_term_char_changed = { TCH / TCHAR / R }
        term_char_redefined: iit$term_char_redefined,
      = iic$sm_hold_acknowlege = { IFP / HOLD_ACK / R }
        hold_acknowlege: iit$hold_acknowlege,
      = iic$sm_job_monitor_changed = { IFP / JM_CHANGED / R }
        job_monitor_changed: iit$job_monitor_changed,
      = iic$sm_interactive_started = { IFP / INTERACTIVE_STARTED / N }
        interactive_started: 0 .. 0fffffffffff(16),
      = iic$sm_read_rejected = { IFP / READ_REJECTED / A }
        read_rejected: iit$read_rejected,
      = iic$sm_interrupt_user = { INTR / USR / R }
        interrupt_user: iit$interrupt_user,
      = iic$sm_absentee_begun = { IFP / ABSENTEE_BEGUN / N }
        absentee_begun: iit$absentee_begun,
      = iic$sm_break_indication_mark = { BI / MARK / R }
        bi_mark: 0 .. 0fffffffffff(16),
      = iic$sm_define_term_char_n = { CTRL / CHAR / N }
        dtc_normal: iit$define_term_char_n,
      = iic$sm_define_term_char_a = { CTRL / CHAR / A }
        dtc_abnormal: iit$define_term_char_a,
      = iic$sm_request_term_char_a = { CTRL / RTC / A }
        rtc_abnormal: iit$request_term_char_a,
      = iic$sm_cdcnet_request_trm_chr_a = { CTRL / RCC / A }
        rcc_abnormal: iit$cdcnet_request_term_char_a,
      casend,
    recend,

    iit$output_supervisory_message = packed record
      header: iit$output_supervisory_header,
      ?IF ifv$module_for_c180 = TRUE THEN
        pad1: iit$word_fill,
      ?IFEND
      case message_type: iit$supervisory_message_type of
      = iic$sm_end_connection = { CON / END / R }
        conend_zero1: 0 .. 0ff(16),
        conend_connection_number: iit$application_connection_num,
        conend_fill1: 0 .. 0ffffff(16),
        conend_zero2: iit$170_display_word,
      = iic$sm_connection_rejected = { CON / REQ / A }
        connection_rejected: iit$connection_rejected,
      = iic$sm_connection_accepted = { CON / REQ / N }
        connection_accepted: iit$connection_accepted,
      = iic$sm_redefine_term_char = { CTRL / DEF / R }
        ctrldef_part1: packed array [0 .. 10] of iit$half_byte,
        ctrldef_part2: iit$170_ascii_word,
        ?IF ifv$module_for_c180 = TRUE THEN
          ctrldef_pad1: iit$word_fill,
        ?IFEND
        ctrldef_part3: packed array [0 .. 3] of iit$half_byte,
        ctrldef_pad2: 0 .. 0fffffffffff(16),
      = iic$sm_start_input = { CTRL / START / R }
        start_input: iit$start_input,
      = iic$sm_stop_input = { CTRL / STOP / R }
        stop_input: iit$stop_input,
      = iic$sm_define_term_char = { CTRL / CHAR / R }
        ctrlchar_pad1: 0 .. 0f(16),
        define_term_char: iit$define_term_char,
      = iic$sm_cdcnet_define_term_char = { CTRL / CTD / R }
        cdcnet_define_term_char: iit$cdcnet_define_term_char,
      = iic$sm_request_term_char = { CTRL / RTC / R }
        ctrlrtc_pad1: 0 .. 0f(16),
        request_term_char: iit$request_term_char,
      = iic$sm_cdcnet_request_term_char = { CTRL / RCC / R }
        { No AN's indicates a request for all AV's. },
      = iic$sm_change_character_type = { DC / CICT / R }
        change_character_type: iit$change_character_type,
      = iic$sm_break = { FC / BRK / R }
        break: iit$break,
      = iic$sm_connection_initialized = { FC / INIT / N }
        connection_initialized: iit$connection_initialized,
      = iic$sm_reset_connection = { FC / RST / R }
        reset_connection: iit$reset_connection,
      = iic$sm_list_off = { LST / OFF / R }
        list_off: iit$list_off,
      = iic$sm_list_on = { LST / ON / R }
        list_on: iit$list_on,
      = iic$sm_list_switch = { LST / SWH / R }
        list_switch: iit$list_switch,
      = iic$sm_list_half_duplex = { LST / HDX / R }
        half_duplex: iit$list_half_duplex,
      = iic$sm_message_to_operator = { MSG / LOP / R }
        msglop_fill1: 0 .. 0ff(16),
        msglop_number_of_characters: 0 .. 0fff(16),
        msglop_fill2: 0 .. 0ffffff(16),
        msglop_message: packed array [1 .. iic$max_operator_message_words] of
          iit$170_display_word,
      = iic$sm_hold = { IFP / HOLD / R }
        hold: iit$hold,
      = iic$sm_unhold = { IFP / UNHOLD / R }
        unhold: iit$unhold,
      = iic$sm_read_request = { IFP / READ_REQ / R }
        read_request: iit$read_request,
      = iic$sm_change_job_monitor = { IFP / CHANGE_JM / R }
        changejm_connection_number: iit$application_connection_num,
        changejm_fill1: 0 .. 0ffffffff(16),
        changejm_new_jm: integer,
      = iic$sm_start_interactive = { IFP / START_INTERACTIVE / R }
        start_interactive: 0 .. 0fffffffffff(16),
      = iic$sm_stop_interactive = { IFP / STOP_INTERACTIVE / R }
        stop_interactive: 0 .. 0fffffffffff(16),
      = iic$sm_interrupt_response = { INTR / RSP / N }
        interrupt_response: iit$interrupt_user,
      = iic$sm_resume_output_mark = { RO / MARK / R }
        ro_mark: 0 .. 0ffffffffffff(16),
      = iic$sm_terminate = { IFP / TERMINATE / R }
        terminate: iit$hold,
      casend,
    recend;

*DECK DECK=IIT$CDCNET_CONN_REJECT_REASONS EXPAND=FALSE

  TYPE
    iit$cdcnet_conn_reject_reasons = (iic$reject_reason_unused,
          iic$cannot_locate_service, iic$connection_already_switched,
          iic$cannot_create_connection, iic$service_is_busy,
          iic$invalid_service_data, iic$invalid_connection_data);

*DECK DECK=IIT$CONNECTION_ATTRIBUTES EXPAND=FALSE
  TYPE

    attention_character_action = record
      value: ift$attention_character_action,
      source: ift$connection_attribute_source,
    recend,

    break_key_action = record
      value: ift$break_key_action,
      source: ift$connection_attribute_source,
    recend,

    end_of_information = record
      value: ift$end_of_information,
      source: ift$connection_attribute_source,
    recend,

    input_block_size = record
      value: ift$input_block_size,
      source: ift$connection_attribute_source,
    recend,

    input_editing_mode = record
      value: ift$input_editing_mode,
      source: ift$connection_attribute_source,
    recend,

    input_output_mode = record
      value: ift$input_output_mode,
      source: ift$connection_attribute_source,
    recend,

    input_timeout = record
      value: boolean,
      source: ift$connection_attribute_source,
    recend,

    input_timeout_length = record
      value: ift$input_timeout_length,
      source: ift$connection_attribute_source,
    recend,

    input_timeout_purge = record
      value: boolean,
      source: ift$connection_attribute_source,
    recend,

    partial_char_forwarding = record
      value: boolean,
      source: ift$connection_attribute_source,
    recend,

    prompt_file = record
      value: amt$local_file_name,
      source: ift$connection_attribute_source,
    recend,

    prompt_file_identifier = record
      value: amt$file_identifier,
      source: ift$connection_attribute_source,
    recend,

    prompt_string = record
      value: ift$prompt_string,
      source: ift$connection_attribute_source,
    recend,

    store_backspace_character = record
      value: boolean,
      source: ift$connection_attribute_source,
    recend,

    store_nuls_dels = record
      value: boolean,
      source: ift$connection_attribute_source,
    recend,

    trans_character_mode = record
      value: ift$trans_character_mode,
      source: ift$connection_attribute_source,
    recend,

    trans_forward_character = record
      value: ift$trans_forward_character,
      source: ift$connection_attribute_source,
    recend,

    trans_length_mode = record
      value: ift$trans_length_mode,
      source: ift$connection_attribute_source,
    recend,

    trans_message_length = record
      value: ift$trans_message_length,
      source: ift$connection_attribute_source,
    recend,

    trans_protocol_mode = record
      value: ift$trans_protocol_mode,
      source: ift$connection_attribute_source,
    recend,

    trans_terminate_character = record
      value: ift$trans_terminate_character,
      source: ift$connection_attribute_source,
    recend,

    trans_timeout_mode = record
      value: ift$trans_timeout_mode,
      source: ift$connection_attribute_source,
    recend,

    iit$connection_attributes = record
      attention_character_action: attention_character_action,
      break_key_action: break_key_action,
      end_of_information: end_of_information,
      input_block_size: input_block_size,
      input_editing_mode: input_editing_mode,
      input_output_mode: input_output_mode,
      input_timeout: input_timeout,
      input_timeout_length: input_timeout_length,
      input_timeout_purge: input_timeout_purge,
      partial_char_forwarding: partial_char_forwarding,
      prompt_file: prompt_file,
      prompt_file_identifier: prompt_file_identifier,
      prompt_string: prompt_string,
      store_backspace_character: store_backspace_character,
      store_nuls_dels: store_nuls_dels,
      trans_character_mode: trans_character_mode,
      trans_forward_character: trans_forward_character,
      trans_length_mode: trans_length_mode,
      trans_message_length: trans_message_length,
      trans_terminate_character: trans_terminate_character,
      trans_timeout_mode: trans_timeout_mode,
      trans_protocol_mode: trans_protocol_mode,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc ift$connection_attribute_source
*copyc ift$terminal_connection_types
?? POP ??
*DECK DECK=IIT$CONNECTION_DESCRIPTION EXPAND=FALSE
  CONST
    iic$max_logical_err_no_acn_cnt = 0ffff(16),
    iic$max_logical_err_acn_cnt = 0ffff(16),
    iic$number_of_control_chars = 6,
    iic$max_attributes_cycle = 0ffff(16),
    iic$max_record_length = 0ffff(16),
    iic$max_cancellable_input = 80,
    iic$max_lines_per_block = 20,
    iic$max_interactive_task_count = 10,
    iic$max_break_level = 5,
    iic$initial_job_start = 6,
    iic$suspended_job_start = 13,
    iic$end_connection = TRUE,
    iic$max_output_sequence_size = 20000,
    iic$dont_end_connection = FALSE,
    iic$start_new_job = TRUE,
    iic$dont_start_new_job = FALSE,
    iic$user_time_delay = 1000;

  TYPE
    iit$connection_description = BOUND RECORD
      attributes_cycle: 0 .. iic$max_attributes_cycle,
      terminal_name: ift$terminal_name,
      CASE network_identifier: iit$network_identifier OF
      = iic$cdcnet_network =

        actual_connection_attributes: iit$connection_attributes,
        connection_attributes_lock: ost$signature_lock,
        default_connection_attributes: iit$connection_attributes,
        downline_queue_count: integer,
        get_info: iit$task_get_info,
        job_input_count: integer,
        job_output_count: integer,
        next_connection_desc_ptr: ^iit$connection_description,
        open_local_file_count: integer,
        output_buffer_entry_loc: ^SEQ ( * ),
        output_buffer_exit_loc: ^SEQ ( * ),
        page_length: ift$page_length,
        page_width: ift$page_width,
        put_info: iit$task_put_info,
        session_layer_file_name: amt$local_file_name,
        solicitation_pending: boolean,
        st_get_lock: ost$signature_lock,
        terminal_attributes_lock: ost$signature_lock,
        terminal_model: ift$terminal_model,
        vtp_connection_id: iit$vtp_connection_id,

      = iic$dsiaf_network =

        next_entry,
        previous_entry: ^iit$connection_description,
        lock: ost$signature_lock,
        connection_number: iit$application_connection_num,
        next_block_number: iit$application_block_number,
        nam_os_default_attributes: iit$connection_attributes,
        terminal_attributes: iit$terminal_attributes,
        term_char_values: array [1..15] of iit$field_value,
        active_term_char_values: array [1..15] of iit$field_value,
        block_size: iit$block_size,

      casend,
    recend,

    iit$st_open_file_description = RECORD
      attributes: iit$connection_attributes,
      attributes_cycle: 0 .. iic$max_attributes_cycle,
      error_status: ost$status_condition,
      file_name: amt$local_file_name,
      format_effectors: boolean,
      last_access_operation: amt$last_access_operation,
      last_get_put_operation: amt$last_access_operation,
      last_op_status: amt$last_op_status,
      previous_record_length: amt$max_record_length,
      session_layer_file_name: amt$local_file_name,
      vtp_connection_id: iit$vtp_connection_id,
      vtp_file_id: amt$file_identifier,
      terminal_mode: iit$terminal_mode,
    recend,

    iit$open_file_description = record
      file_name: amt$local_file_name,
      connection_desc_pointer: ^iit$connection_description,
      attributes_cycle: 0 .. iic$max_attributes_cycle,
      attributes: iit$connection_attributes,
      term_char_values: array [1 .. 15] of iit$field_value,
      block_number: amt$block_number,
      error_status: ost$status_condition,
      format_effectors: boolean,
      last_get_put_operation: amt$last_access_operation,
      last_access_operation: amt$last_access_operation,
      last_op_status: amt$last_op_status,
      previous_record_length: amt$max_record_length,
      terminal_mode: iit$terminal_mode,
    recend,

    iit$terminal_attributes = record
      attention_character: char,
      backspace_character: char,
      begin_line_character: char,
      cancel_line_character: char,
      carriage_return_delay: ift$carriage_return_delay,
      carriage_return_sequence: ift$carriage_return_sequence,
      character_flow_control: boolean,
      code_set: ift$code_set,
      echoplex: boolean,
      end_line_character: char,
      end_line_positioning: ift$end_line_positioning,
      end_output_sequence: ift$end_output_sequence,
      end_page_action: ift$end_page_action,
      end_partial_character: char,
      end_partial_positioning: ift$end_partial_positioning,
      fold_line: boolean,
      form_feed_delay: ift$form_feed_delay,
      form_feed_sequence: ift$form_feed_sequence,
      function_key_class: ift$function_key_class,
      hold_page: boolean,
      hold_page_over: boolean,
      line_feed_delay: ift$line_feed_delay,
      line_feed_sequence: ift$line_feed_sequence,
      network_command_character: char,
      page_length: ift$page_length,
      page_width: ift$page_width,
      parity: ift$parity,
      pause_break_character: char,
      status_action: ift$status_action,
      terminal_class: ift$terminal_class,
      terminal_model: ift$terminal_model,
      terminate_break_character: char,
    recend,

    iit$control_char_descriptor = record
      key: ift$terminal_attribute_keys,
      text: string (osc$max_name_size),
    recend,

    iit$control_char_descriptions = array [1 .. iic$number_of_control_chars] of
      iit$control_char_descriptor,

    iit$attribute_source_selections = set of ift$connection_attribute_source,

    iit$bam_source_selections = set of amt$attribute_source,

    iit$set_of_term_conn_attr_keys = set of ift$connection_attribute_keys,

    iit$terminal_attribute_keys_set = set of ift$terminal_attribute_keys,

    iit$set_of_trans_char_modes = set of ift$trans_character_mode,

    iit$set_of_trans_timeout_modes = set of ift$trans_timeout_mode,

    iit$set_of_trans_length_modes = set of ift$trans_length_mode,

    iit$set_of_trans_protocol_modes = set of ift$trans_protocol_mode,

    iit$set_of_input_editing_modes = set of ift$input_editing_mode,

    iit$set_of_input_output_modes = set of ift$input_output_mode,

    iit$set_of_parity_modes = set of ift$parity,

    iit$set_of_end_part_positions = set of ift$end_partial_positioning,

    iit$set_of_end_line_positions = set of ift$end_line_positioning,

    iit$set_of_status_actions = set of ift$status_action,

    iit$set_of_terminal_classes = set of ift$terminal_class,

    iit$set_of_access_info_keys = set of amt$access_info_keys,

    iit$job_modes = set of jmt$job_mode,

    iit$task_get_info = record
      queued_data_length: amt$max_record_length,
      block_type: iit$application_block_type,
      cancel_input: iit$cancel_input,
      end_of_message: boolean,
      transfer_count: amt$transfer_count,
      position_in_block: iit$block_size,
      record_length: amt$max_record_length,
      file_position: amt$file_position,
    recend,

    iit$task_put_info = record
      position_in_block: iit$block_size,
      transfer_count: amt$transfer_count,
      last_term_option: amt$term_option,
      build_msg_block: boolean,
      term_char_null: boolean,
      term_char_sent: boolean,
      block_number: integer,
    recend,

    iit$network_identifier = (iic$cdcnet_network, iic$dsiaf_network),

    iit$terminal_mode = (iic$line, iic$screen),

    ift$attribute_types = (ifc$actual, ifc$default),

    ift$transparent_types = (ifc$single_message, ifc$multi_message),

    ift$input_devices = (ifc$keyboard_input, ifc$block_mode_input),

    iit$st_downline_queue_entry = record
      next_entry,
      previous_entry: ^iit$downline_queue_entry,
      connection_ptr: ^iit$connection_description,
      output_info: iit$vt_output_information,
      term_char_null: boolean,
      term_char_sent: boolean,
      attributes: iit$connection_attributes,
      transparent_type: ift$transparent_types,
      vtp_connection_id: iit$vtp_connection_id,
      vtp_file_id: amt$file_identifier,
      data: array [1 .. *] of char,
    recend,
    iit$downline_queue_entry = record
      next_entry,
      previous_entry: ^iit$downline_queue_entry,
      connection_ptr: ^iit$connection_description,
      term_char_changed: boolean,
      term_char_sent: boolean,
      term_char_null: boolean,
      term_char_values: array [1..15] of iit$field_value,
      transparent_character_selected: boolean,
      transparent_count_selected: boolean,
      transparent_time_out_selected: boolean,
      repeated_output: boolean,
      message: iit$downline_data_message,
    recend,

    iit$queue_key = (iic$connection_description, iic$terminal_request,
      iic$open_file_description, iic$downline_queue, iic$repeat_queue),

    iit$queue_entry_descriptor = record

      case queue_key: iit$queue_key of

      = iic$connection_description =
        connection_description_ptr: ^iit$connection_description,

      = iic$terminal_request =
        terminal_request_ptr: ^iit$connection_attributes,

      = iic$open_file_description =
        open_file_description_ptr: ^iit$open_file_description,

      = iic$downline_queue =
        downline_queue_entry_ptr: ^iit$downline_queue_entry,
        downline_queue_entry_size: iit$text_length,

      = iic$repeat_queue =
        repeat_queue_entry_ptr: ^iit$downline_queue_entry,
        repeat_queue_entry_size: iit$text_length,

      casend,
    recend,

    iit$st_queue_entry_descriptor = record
      case queue_key: iit$queue_key of

      = iic$connection_description =
        connection_description_ptr: ^iit$connection_description,

      = iic$terminal_request =
        terminal_request_ptr: ^iit$terminal_attributes,

      = iic$open_file_description =
        open_file_description_ptr: ^iit$st_open_file_description,

      = iic$downline_queue =
        downline_queue_entry_ptr: ^iit$st_downline_queue_entry,
        downline_queue_entry_size: iit$text_length,

      = iic$repeat_queue =
        repeat_queue_entry_ptr: ^iit$st_downline_queue_entry,
        repeat_queue_entry_size: iit$text_length,

    casend,
    recend,


    iit$break_stack_entry = record
      downline_queue_head: ^iit$downline_queue_entry,
      downline_queue_tail: ^iit$downline_queue_entry,
      downline_queue_count: integer,
      repeat_queue_head: ^iit$downline_queue_entry,
      repeat_queue_tail: ^iit$downline_queue_entry,
      repeat_queue_count: integer,
      get_info: iit$task_get_info,
      put_info: iit$task_put_info,
      ddbp: ^iit$output_data_message,
      ready: boolean,
    recend,
    iit$reconnect_job = record
      sig: iit$interactive_signal,
      acn: iit$application_connection_num,
      reject_caused_reconnect: boolean,
    recend,
    iit$reconnect_request = record
      sig: iit$interactive_signal,
      gtid: ost$global_task_id,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$file_attributes
*copyc amt$access_information
*copyc amt$file_position
*copyc amd$operation_declarations
*copyc amt$max_record_length
*copyc amt$local_file_name
*copyc amt$term_option
*copyc amt$transfer_count
*copyc ifv$module_for_c180
*copyc ift$get_connection_attributes
*copyc ift$format_effectors
*copyc ift$terminal_attributes
*copyc ift$terminal_name
*copyc ift$connection_attributes
*copyc iit$connection_attributes
*copyc iit$interactive_signal_type
*copyc iit$application_names_messages
*copyc jmt$job_mode
*copyc ost$signature_lock
*copyc ost$global_task_id
*copyc ost$string
*copyc iit$vt_output_information
*copyc iit$vt_connections
?? POP ??
*DECK DECK=IIT$INTERACTIVE_SIGNAL_TYPE EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
?? POP ??

  TYPE
    iit$interactive_signal_type = (iic$jm_send_data, iic$resume_task,
      iic$jmtr_start_timeout, iic$reconnect_job, iic$operator_message,
      iic$pause_break, iic$terminate_break, iic$immediate_shutdown,
      iic$warning_shutdown, iic$exec_says_disconnect, iic$user_break,
      iic$disconnect_request, iic$reconnect_request, iic$terminal_disconnect,
      iic$terminal_reconnect, iic$interrupt),
    iit$interactive_signal = iit$interactive_signal_type;
*DECK DECK=IIT$VT_ATTRIBUTES EXPAND=FALSE

TYPE
  iit$vt_attributes = array [1 .. * ] of iit$vt_attribute,
  iit$vt_attribute = record
    case kind: iit$vt_attribute_kind of
    = iic$vt_input_output_mode =
      input_output_mode: ift$input_output_mode,
    = iic$vt_input_editing_mode =
      input_editing_mode: ift$input_editing_mode,
    = iic$vt_trans_character_mode =
      trans_character_mode: ift$trans_character_mode,
    = iic$vt_trans_forward_character =
      trans_forward_character: ift$trans_forward_character,
    = iic$vt_trans_term_character =
      trans_terminate_character: ift$trans_terminate_character,
    = iic$vt_trans_timeout_mode =
      trans_timeout_mode: ift$trans_timeout_mode,
    = iic$vt_trans_length_mode =
      trans_length_mode: ift$trans_length_mode,
    = iic$vt_trans_message_length =
      trans_message_length: ift$trans_message_length,
    = iic$vt_partial_char_forwarding =
      partial_char_forwarding: boolean,
    = iic$vt_attention_char_action =
      attention_character_action: ift$attention_character_action,
    = iic$vt_break_key_action =
      break_key_action: ift$break_key_action,
    = iic$vt_input_block_size =
      input_block_size: ift$input_block_size,
    = iic$vt_store_nuls_dels =
      store_nuls_dels: boolean,
    = iic$vt_store_backspace_char =
      store_backspace_character: boolean,
    = iic$vt_network_command_char =
      network_command_character: char,
    = iic$vt_cancel_line_character =
      cancel_line_character: char,
    = iic$vt_end_line_character =
      end_line_character: char,
    = iic$vt_begin_line_character =
      begin_line_character: char,
    = iic$vt_backspace_character =
      backspace_character: char,
    = iic$vt_end_partial_character =
      end_partial_character: char,
    = iic$vt_attention_character =
      attention_character: char,
    = iic$vt_page_length =
      page_length: ift$page_length,
    = iic$vt_page_width =
      page_width: ift$page_width,
    = iic$vt_hold_page =
      hold_page: boolean,
    = iic$vt_hold_page_over =
      hold_page_over: boolean,
    = iic$vt_fold_line =
      fold_line: boolean,
    = iic$vt_end_output_sequence =
      end_output_sequence: ift$end_output_sequence,
    = iic$vt_carriage_return_sequence =
      carriage_return_sequence: ift$carriage_return_sequence,
    = iic$vt_line_feed_sequence =
      line_feed_sequence: ift$line_feed_sequence,
    = iic$vt_form_feed_sequence =
      form_feed_sequence: ift$form_feed_sequence,
    = iic$vt_end_page_action =
      end_page_action: ift$end_page_action,
    = iic$vt_carriage_return_delay =
      carriage_return_delay: ift$carriage_return_delay,
    = iic$vt_line_feed_delay =
      line_feed_delay: ift$line_feed_delay,
    = iic$vt_form_feed_delay =
      form_feed_delay: ift$form_feed_delay,
    = iic$vt_end_line_positioning =
      end_line_positioning: ift$end_line_positioning,
    = iic$vt_end_partial_positioning =
      end_partial_positioning: ift$end_partial_positioning,
    = iic$vt_character_flow_control =
      character_flow_control: boolean,
    = iic$vt_terminal_model =
      terminal_model: ift$terminal_model,
    = iic$vt_function_key_class =
      function_key_class: ift$function_key_class,
    = iic$vt_code_set =
      code_set: ift$code_set,
    = iic$vt_parity =
      parity: ift$parity,
    = iic$vt_echoplex =
      echoplex: boolean,
    = iic$vt_status_action =
      status_action: ift$status_action,
    = iic$vt_terminal_name =
      terminal_name: ^ift$terminal_name,
    = iic$vt_code_set_name =
      code_set_name: ift$code_set_name,
    = iic$vt_control_code_replacement =
      control_code_replacement: ift$control_code_replacement,
    = iic$vt_trans_protocol_mode =
      trans_protocol_mode: ift$trans_protocol_mode,
    casend,
  recend;

*copyc ift$code_set_name
*copyc ift$connection_attributes
*copyc ift$terminal_attributes
*copyc ift$terminal_model
*copyc iit$vt_attribute_kinds
*copyc iit$vt_attribute_descriptions
*DECK DECK=IIT$VT_ATTRIBUTE_DESCRIPTIONS EXPAND=FALSE

CONST
  iic$vt_max_number_of_attributes = 44;

*DECK DECK=IIT$VT_ATTRIBUTE_KINDS EXPAND=FALSE

TYPE
  iit$vt_attribute_kind = (iic$vt_fill0, iic$vt_input_output_mode, iic$vt_input_editing_mode,
    iic$vt_trans_character_mode, iic$vt_trans_forward_character, iic$vt_trans_term_character,
    iic$vt_trans_timeout_mode, iic$vt_trans_length_mode, iic$vt_trans_message_length,
    iic$vt_partial_char_forwarding, iic$vt_attention_char_action, iic$vt_break_key_action,
    iic$vt_input_block_size, iic$vt_store_nuls_dels, iic$vt_store_backspace_char, iic$vt_trans_protocol_mode,
    iic$vt_fill16, iic$vt_fill17, iic$vt_fill18, iic$vt_fill19, iic$vt_fill20, iic$vt_fill21, iic$vt_fill22,
    iic$vt_fill23, iic$vt_fill24, iic$vt_fill25, iic$vt_fill26, iic$vt_fill27, iic$vt_fill28, iic$vt_fill29,
    iic$vt_fill30, iic$vt_fill31, iic$vt_fill32, iic$vt_fill33, iic$vt_fill34, iic$vt_fill35, iic$vt_fill36,
    iic$vt_fill37, iic$vt_fill38, iic$vt_fill39, iic$vt_fill40, iic$vt_fill41, iic$vt_fill42, iic$vt_fill43,
    iic$vt_fill44, iic$vt_fill45, iic$vt_fill46, iic$vt_fill47, iic$vt_fill48, iic$vt_fill49, iic$vt_fill50,
    iic$vt_fill51, iic$vt_fill52, iic$vt_fill53, iic$vt_fill54, iic$vt_fill55, iic$vt_fill56, iic$vt_fill57,
    iic$vt_fill58, iic$vt_fill59, iic$vt_fill60, iic$vt_fill61, iic$vt_fill62, iic$vt_fill63,
    iic$vt_network_command_char, iic$vt_cancel_line_character, iic$vt_end_line_character,
    iic$vt_begin_line_character, iic$vt_backspace_character, iic$vt_end_partial_character,
    iic$vt_attention_character, iic$vt_page_length, iic$vt_page_width, iic$vt_hold_page,
    iic$vt_hold_page_over, iic$vt_fold_line, iic$vt_end_output_sequence, iic$vt_carriage_return_sequence,
    iic$vt_line_feed_sequence, iic$vt_form_feed_sequence, iic$vt_end_page_action,
    iic$vt_carriage_return_delay, iic$vt_line_feed_delay, iic$vt_form_feed_delay, iic$vt_end_line_positioning,
    iic$vt_end_partial_positioning, iic$vt_character_flow_control, iic$vt_terminal_model,
    iic$vt_code_set, iic$vt_parity, iic$vt_echoplex, iic$vt_status_action,
    iic$vt_fill92, iic$vt_fill93,iic$vt_control_code_replacement, iic$vt_function_key_class,
    iic$vt_terminal_name,iic$vt_code_set_name);

TYPE
  iit$vt_attribute_kinds = array [1 .. * ] of iit$vt_attribute_kind;

*DECK DECK=IIT$VT_CHANGE_ERROR_CODES EXPAND=FALSE

TYPE
  iit$vt_change_error_codes = (iic$vt_change_unknown_attribute, iic$vt_change_known_attribute,
    iic$vt_length_out_of_range, iic$vt_conflict_in_values);

*DECK DECK=IIT$VT_CONNECTIONS EXPAND=FALSE

CONST
  iic$vt_max_header_length = 4,
  iic$vt_max_ibs_size = 2000,
  iic$vt_max_transfer_length = iic$vt_max_ibs_size,
  iic$vt_header_length_input = 4,
  iic$vt_header_length_output = 4,
  iic$vt_header_length_change = 1,
  iic$vt_header_length_status = 1,
  iic$vt_header_length_indication = 1;

TYPE
  iit$vt_ibs_buffer = ^iit$vt_ibs_buffer_hold,
  iit$vt_ibs_buffer_hold = SEQ (REP iic$vt_max_ibs_size of cell);


TYPE
  iit$vt_queue_types = (iic$vt_input, iic$vt_output, iic$vt_change, iic$vt_status, iic$vt_indications,
    iic$vt_start_stop_comm, iic$vt_start_stop_comm_resp, iic$vt_version, iic$vt_create, iic$vt_delete,
    iic$vt_create_status),

  iit$vt_queue_type_from_message = array [iit$vt_message_types] of iit$vt_queue_types,
  iit$vt_header_length = array [iit$vt_message_types] of 0 .. iic$vt_max_header_length,

  iit$vt_queue_entry = record
    q_header: record
      next_entry: ^iit$vt_queue_entry,
      transfer_length: 0 .. iic$vt_max_transfer_length,
    recend,
    vtp_buffer: ^iit$vt_ibs_buffer_hold,
  recend,
  iit$vt_connection = record
    input_buffer: ^SEQ ( * ),
    output_buffer: ^SEQ ( * ),
    data: ^nat$data_fragments,
    input: record
      head: ^iit$vt_queue_entry,
      offset: 0 .. iic$vt_max_transfer_length - 1,
    recend,
    output: record
      head: ^iit$vt_queue_entry,
    recend,
    change: record
      head: ^iit$vt_queue_entry,
    recend,
    status: record
      head: ^iit$vt_queue_entry,
    recend,
    indications: record
      head: ^iit$vt_queue_entry,
    recend,
    queue_entry: iit$vt_queue_entry,
  recend,
  iit$vtp_connection_id = record
    connection: ^iit$vt_connection,
  recend;

*copyc nat$data_fragments
*copyc iit$vt_message_types
*copyc amt$file_identifier
*copyc iit$connection_description
*copyc iic$vt_max_output_mess_length
*DECK DECK=IIT$VT_INPUT_HEADER EXPAND=FALSE
TYPE
  iit$vt_input_header = packed record
    fill_0: 0 .. 07(16),
    message_type: iit$vt_message_types,
  recend;

*copyc iit$vt_message_types
*DECK DECK=IIT$VT_INPUT_INFORMATION EXPAND=FALSE

TYPE
  iit$vt_input_information = packed record
    fill_0: 0 .. 07(16),
    message_type: iit$vt_message_types,
    editing_mode: 0 .. 0ff(16),
    fill_1: 0 .. 3(16),
    forwarding_condition: (iic$vt_character, iic$vt_inter_character_timeout, iic$vt_character_count,
      iic$vt_tip_protocol),
    solicited_data: boolean,
    error: boolean,
    cancel: boolean,
    partial: boolean,
    forwarding_character: char,
  recend;

*copyc iit$vt_message_types
*DECK DECK=IIT$VT_MESSAGE_TYPES EXPAND=FALSE

CONST
  iic$vt_message_type_max = 25;


TYPE
  iit$vt_message_types = (iic$vt_output_data_message, iic$vt_input_data_message, iic$vt_change_attributes,
    iic$vt_change_attribute_confirm, iic$vt_change_attributes_reject, iic$vt_change_attr_indication,
    iic$vt_query_attributes, iic$vt_query_attributes_confirm, iic$vt_query_attributes_reject,
    iic$vt_stop_communications, iic$vt_stop_communications_resp, iic$vt_start_communications,
    iic$vt_start_communications_rsp, iic$vt_chng_attribute_uncnfrmed,iic$vt_appl_vtp_version,
    iic$vt_create_paired_connection, iic$vt_create_paired_conn_cnfrm, iic$vt_create_paired_conn_rejct,
    iic$vt_delete_paired_connection, iic$vt_interrupt_message, iic$vt_execute_xterm_command,
    iic$vt_resize_xterm, iic$vt_create_cdcnet_connection, iic$vt_create_cdcnet_conn_cnfrm,
    iic$vt_create_cdcnet_conn_rejct);
*DECK DECK=IIT$VT_OCTET_HEADER EXPAND=TRUE

      TYPE
        iit$vt_octet_header = packed record
          multiple_octet: boolean,
          kind: iit$vt_attribute_kind,
        recend;

?? PUSH (LISTEXT := ON) ??
*copyc iit$vt_attribute_kinds
?? POP ??
*DECK DECK=IIT$VT_OUTPUT_INFORMATION EXPAND=FALSE

TYPE
  iit$vt_output_information = packed record
    fill_0: 0 .. 07(16),
    message_type: iit$vt_message_types,
    formatting_mode: 0 .. 0ff(16),
    reserved_1: 0 .. 1f(16),
    secured: iit$vt_secured,
    partial: boolean,
    reserved_2: 0 .. 0ff(16),
  recend;

*copyc iit$vt_secured
*DECK DECK=IIT$VT_SECURED EXPAND=FALSE

TYPE
  iit$vt_secured = packed record
    suppress_echoplexing: boolean,
    suppress_end_line_positioning: boolean,
  recend;


*DECK DECK=IIT$VT_TIMEOUT EXPAND=FALSE

TYPE
  iit$vt_timeout = record
    case on: boolean of
    = TRUE =
      length: nat$wait_time,
      purge: boolean,
    = FALSE =
    casend,
  recend;

*copyc nat$wait_time
*DECK DECK=IIT$XT_MESSAGE_CONTROL_BLOCK EXPAND=FALSE
  TYPE
    iit$xt_message_control_block = record

{ Count of messages put into file.

      count: iit$xt_message_count,

{ Message header for get on file.

      get_message_header: iit$xt_message_header,

{ Relative address of next get on file.

      get_p: REL (SEQ ( * )) ^SEQ ( * ),

{ Task to ready when message arrives.

      global_task_id: ost$global_task_id,
      global_task_id_defined: boolean,

{ Relative address of message header for put on file.

      put_message_header_p: REL (SEQ ( * )) ^iit$xt_message_header,

{ Relative address for next put on file.

      put_p: REL (SEQ ( * )) ^SEQ ( * ),
      record_position: iit$xt_record_position,
      status: iit$xt_message_control_status,
      terminate_option: iit$xt_terminate_option,
    recend;

*copyc amt$segment_pointer
*copyc iit$xt_message_control_status
*copyc iit$xt_message_count
*copyc iit$xt_message_header
*copyc iit$xt_record_position
*copyc iit$xt_terminate_option
*copyc ost$global_task_id
*copyc ost$signature_lock
*DECK DECK=IIT$XT_MESSAGE_CONTROL_STATUS EXPAND=FALSE

  TYPE
    iit$xt_message_control_status = (iic$xt_file_created, iic$xt_file_open,
          iic$xt_file_closed, iic$xt_file_deleted);

*DECK DECK=IIT$XT_MESSAGE_COUNT EXPAND=FALSE

  TYPE
    iit$xt_message_count = 0 .. 8192;

*DECK DECK=IIT$XT_MESSAGE_FILE_REFERENCE EXPAND=FALSE

  TYPE
    iit$xt_message_file_reference = string (7 {$user. or $local.} + 7
          {$xterm. or null} + 32 {unique name} );

*DECK DECK=IIT$XT_MESSAGE_HEADER EXPAND=FALSE

  TYPE
    iit$xt_message_header = record
      xt_message_type: iit$xt_message_type,
      xt_message_size: iit$xt_message_size,
    recend;

*copyc iit$xt_message_type
*copyc iit$xt_message_size

*DECK DECK=IIT$XT_MESSAGE_SIZE EXPAND=FALSE

  TYPE
    iit$xt_message_size = 0 .. 8192;

*DECK DECK=IIT$XT_MESSAGE_STATE EXPAND=FALSE

  TYPE
    iit$xt_message_state = (iic$xt_inactive, iic$xt_synchronize, iic$xt_reset,
          iic$xt_wait_for_data);

*DECK DECK=IIT$XT_MESSAGE_TYPE EXPAND=FALSE

  TYPE
    iit$xt_message_type = (iic$xt_vtp_message_type,
          iic$xt_unused1_message_type, iic$xt_unused2_message_type,
          iic$xt_unused3_message_type, iic$xt_unused4_message_type,
          iic$xt_unused5_message_type, iic$xt_unused6_message_type,
          iic$xt_unused7_message_type);

*DECK DECK=IIT$XT_RECORD_POSITION EXPAND=FALSE
  TYPE
    iit$xt_record_position = integer;

  CONST
    iic$xt_end_of_record = 0,
    iic$xt_mid_record = 1;
*DECK DECK=IIT$XT_TERMINATE_OPTION EXPAND=FALSE
  TYPE
    iit$xt_terminate_option = integer;

  CONST
    iic$xt_start_record = 1,
    iic$xt_continue_record = 2,
    iic$xt_terminate_record = 3;
*DECK DECK=IIT$XT_TRACE_OPTIONS EXPAND=FALSE

  TYPE
    iit$xt_trace_options = (iic$xt_trace_procedures,
          iic$xt_trace_downline_messages, iic$xt_trace_upline_messages,
          iic$xt_trace_reserved_1, iic$xt_trace_reserved_2,
          iic$xt_trace_reserved_3, ic$xt_trace_reserved_4,
          iic$xt_trace_reserved_5, iic$xt_trace_reserved_6);

*DECK DECK=IIT$XT_TRACE_SET EXPAND=FALSE

  TYPE
    iit$xt_trace_set = set of iit$xt_trace_options;

*copyc iit$xt_trace_options
*DECK DECK=IIT$XT_XTERM_CONTROL_BLOCK EXPAND=FALSE

  TYPE

    iit$xt_xterm_control_block = record
      downline_file_reference: iit$xt_message_file_reference,
      downline_lock: ost$signature_lock,
      downline_state: iit$xt_message_state,
      network_file_opened: boolean,
      network_file_identifier: amt$file_identifier,
      status: pmt$task_status,
      task: iit$xt_xterm_task,
      trace_set: iit$xt_trace_set,
      upline_file_reference: iit$xt_message_file_reference,
      upline_global_task_id: ost$global_task_id,
      upline_lock: ost$signature_lock,
      upline_state: iit$xt_message_state,
      xterm_global_task_id: ost$global_task_id,
      xterm_state: iit$xt_xterm_state,
    recend;

*copyc amt$file_identifier
*copyc iit$xt_message_file_reference
*copyc iit$xt_message_state
*copyc iit$xt_trace_set
*copyc iit$xt_xterm_state
*copyc iit$xt_xterm_task
*copyc ost$global_task_id
*copyc ost$signature_lock
*copyc pmt$task_status
*DECK DECK=IIT$XT_XTERM_MESSAGE_CONTROL EXPAND=FALSE
 TYPE
    iit$xt_xterm_message_control = record
      file_identifier: amt$file_identifier,
      opened: boolean,
      segment_pointer: amt$segment_pointer,
    recend;

*copyc amt$file_identifier
*copyc amt$segment_pointer
*DECK DECK=IIT$XT_XTERM_STATE EXPAND=FALSE

  TYPE
    iit$xt_xterm_state = (iic$xterm_uninitialized, iic$created_catalog,
          iic$ran_prolog, iic$create_upline_file, iic$create_downline_file,
          iic$execute_xterm_task, iic$execute_initial_command,
          iic$terminate_xterm_task);

*DECK DECK=IIT$XT_XTERM_STATUS EXPAND=FALSE
  TYPE
    iit$xt_xterm_status = record
      activity_status: ost$activity_status,
      global_task_id: ost$global_task_id,
    recend;

*copyc ost$activity_status
*copyc ost$global_task_id
*DECK DECK=IIT$XT_XTERM_TASK EXPAND=FALSE

  TYPE
    iit$xt_xterm_task = record
      exists: boolean,
      id: pmt$task_id,
    recend;

*copyc pmt$task_id
*DECK DECK=IIT$XT_XTERM_TASK_OUTPUT EXPAND=FALSE

  TYPE
    iit$xt_xterm_task_output = record
      text_p: ^string (132),
      position: 0 .. 132,
    recend;

*DECK DECK=IIV$CONNECTION_DESC_PTR EXPAND=FALSE

  VAR
    iiv$connection_desc_ptr: [XREF] ^iit$connection_description,
    iiv$connection_desc_lock: [XREF] ost$signature_lock,
    iiv$connection_desc_count: [XREF] integer,

    iiv$job_monitor_task_id: [XREF] ost$global_task_id,

    iiv$break_reason: [XREF] iit$break_reason;

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
?? POP ??
*DECK DECK=IIV$INTERACTIVE_TERMINATED EXPAND=FALSE


{   WARNING:
{      The following order must be used when obtaining more than one
{      interactive lock in order to avoid deadlocks:
{       - iiv$downline_queue_lock
{       - iiv$repeat_queue_lock
{       - iiv$upline_queue_lock

  VAR
    iiv$suppress_cursor_positioning: [XREF] boolean,
    iiv$suppress_echoplexing: [XREF] boolean,
    iiv$interactive_terminated: [XREF] boolean,
    iiv$job_suspended: [XREF] boolean,
    iiv$abort_get: [XREF] boolean,
    iiv$abort_job_initialization: [XREF] boolean,

    iiv$interactive_task_count: [XREF] integer,
    iiv$interactive_task_count_lock: [XREF] ost$signature_lock,

    iiv$get_lock: [XREF] ost$signature_lock,
    iiv$get_info: [XREF] iit$task_get_info,

    iiv$downline_queue_lock: [XREF] ost$signature_lock,
    iiv$downline_queue_count: [XREF] integer,
    iiv$downline_queue_size: [XREF] integer,
    iiv$downline_block_number: [XREF] integer,

    iiv$last_formatting_mode: [XREF] 0 .. 0ff(16),

    iiv$upline_data_buffer_ptr: [XREF] ^iit$input_data_message,

    iiv$job_connection: [XREF] iit$application_connection_num,

    iiv$cdcnet_connection: [XREF] boolean,

    iiv$network_identifier: [XREF] iit$network_identifier,

    iiv$screen_clear_string: [XREF] ost$string,

    iiv$send_timeout_warning: [XREF] boolean,

    iiv$terminal_timeout_limit: [XREF] integer,

    iiv$terminal_timeout_limit_left: [XREF] integer,

    iiv$previous_blank_flag: [XREF] boolean,

    iiv$previous_connection_attr: [XREF] iit$connection_attributes,

    iiv$previous_mode: [XREF] iit$terminal_mode,

    iiv$previous_file_id: [XREF] amt$file_identifier,

    iiv$previous_operation: [XREF] amt$fap_operation,

    iiv$jm_application_name: [XREF] mlt$application_name,


    iiv$break_abn: [XREF] integer,
    iiv$task_handling_break: [XREF] ost$global_task_id,

    iiv$condition_descriptor: [XREF] pmt$condition,

    iiv$downline_term_class_conv: [XREF] array [ifc$tty_class ..
      ifc$i3270_class] of iit$field_value,
    iiv$upline_term_class_conv: [XREF] array [iic$tty_class .. iic$i3270_class]
      of ift$terminal_class,
   iiv$downline_input_device_conv: [XREF] array [ifc$keyboard_input ..
     ifc$block_mode_input] of iit$field_value,
{   iiv$upline_input_device_conv: [XREF] array [0 .. 1] of ift$input_devices,
{   iiv$downline_output_device_conv: [XREF] array [ifc$display_output ..
{     ifc$printer_output] of iit$field_value,
{   iiv$upline_output_device_conv: [XREF] array [iic$printer_output ..
{     iic$display_output] of ift$output_devices,
    iiv$downline_parity_conv: [XREF] array [ifc$zero_parity .. ifc$no_parity]
      of iit$field_value,
    iiv$upline_parity_conv: [XREF] array [iic$zero_parity .. iic$ignore_parity] of
      ift$parity,
{   iiv$downline_end_position_conv: [XREF] array [ifc$no_input_positioning ..
{     ifc$cr_lf] of iit$field_value,
    iiv$upline_end_position_conv: [XREF] array [iic$elp_none ..
      iic$elp_crslfs] of ift$end_line_positioning,
    iiv$upline_part_position_conv: [XREF] array [iic$epp_none ..
      iic$epp_crslfs] of ift$end_partial_positioning,
    iiv$deflt_connection_attributes: [XREF] iit$connection_attributes,
{   iiv$downline_xparent_type_conv: [XREF] array [ifc$single_message ..
{     ifc$multi_message] of iit$field_value,
    iiv$skeleton_term_char_string: [XREF] iit$term_char_string,

    iiv$all_get_term_attributes: [XREF] array [1 .. (ORD (ifc$max_connection_key) + 1)] OF
      ift$get_connection_attribute,
    iiv$init_undefined_attributes: [XREF] iit$connection_attributes,
    iiv$control_char_descriptions: [XREF] iit$control_char_descriptions,
    iiv$interactive_wait_time: [XREF] integer,
    iiv$term_char_change_count: [XREF] integer;

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc OST$GLOBAL_TASK_ID
*copyc ost$signature_lock
*copyc PMT$CONDITION
?? POP ??
*DECK DECK=IIV$INT_TASK_OPEN_FILE_COUNT EXPAND=FALSE

  VAR
    iiv$int_task_open_file_count: [XREF] integer,
    iiv$task_condition_in_progress: [XREF] boolean,
    iiv$task_ignore_condition: [XREF] boolean,
    iiv$int_application_name: [XREF] mlt$application_name,
    iiv$put_info: [XREF] iit$task_put_info,
    iiv$downline_data_block_ptr: [XREF] ^iit$output_data_message,


    iiv$terminal_request_ptr: [XREF] ^iit$connection_attributes;

?? PUSH (LISTEXT := OFF) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc IIT$CONNECTION_DESCRIPTION
?? POP ??
*DECK DECK=IIV$IO_REQUESTS_IN_JOB EXPAND=FALSE
{ iiv$io_requests_in_job resides in module iim$interrupt_timesharing_io.}

  VAR
    iiv$io_requests_in_job: [XREF , oss$task_shared] integer {ALIGNED [0 MOD 8]};

?? PUSH (LISTEXT := ON) ??
*copyc oss$task_shared
?? POP ??
*DECK DECK=IIV$IO_REQUESTS_IN_TASK EXPAND=FALSE
{ iiv$io_requests_in_task resides in module iim$interrupt_timesharing_io.}

  VAR
    iiv$io_requests_in_task: [XREF , oss$task_private] integer;

?? PUSH (LISTEXT := ON) ??
*copyc oss$task_private
?? POP ??
*DECK DECK=IIV$JOB_OUTPUT EXPAND=FALSE

  VAR
    iiv$job_output: [XREF] ^ SEQ ( * );
*DECK DECK=IIV$OUTPUT EXPAND=FALSE
type
  iit$output = record
    length: integer,
    block: iit$downline_queue_entry,
  recend,

  iit$st_output = record
    length: integer,
    block: iit$st_downline_queue_entry,
  recend;
var
  iiv$output: [xref] ^seq(*);
*DECK DECK=IIV$PUT_IN_PROGRESS EXPAND=FALSE

  VAR

    iiv$put_in_progress: [XREF] boolean,
    iiv$fid: [XREF] amt$file_identifier,
    iiv$clp_pso_open: [XREF] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
?? POP ??
*DECK DECK=IIV$ST_CONNECTION_DESC_PTR EXPAND=TRUE


  VAR
    iiv$connection_desc_ptr: [XREF] ^iit$st_connection_description,
    iiv$connection_desc_lock: [XREF] ost$signature_lock,
    iiv$connection_desc_count: [XREF] integer,

    iiv$job_monitor_task_id: [XREF] ost$global_task_id,

    iiv$break_reason: [XREF] iit$break_reason;

?? PUSH (LISTEXT := ON) ??
*copyc IIT$CONNECTION_DESCRIPTION
?? POP ??
*DECK DECK=IIV$XT_MESSAGE_CONTROL EXPAND=FALSE

  VAR
    iiv$xt_message_control: [XREF] array [1 .. 2] of
          iit$xt_message_control_block;

*copyc iit$xt_message_control_block
*DECK DECK=IIV$XT_XTERM_CONTROL_BLOCK EXPAND=FALSE

  VAR
    iiv$xt_xterm_control_block: [XREF] iit$xt_xterm_control_block;

*copyc iit$xt_xterm_control_block

*DECK DECK=IIV$XT_XTERM_DOWNLINE EXPAND=FALSE

  VAR
    iiv$xt_xterm_downline: [XREF] iit$xt_xterm_message_control;

*copyc iit$xt_xterm_message_control

*DECK DECK=IIV$XT_XTERM_TASK_OUTPUT EXPAND=FALSE

  VAR
    iiv$xt_xterm_task_output: [XREF] iit$xt_xterm_task_output;

*copyc iit$xt_xterm_task_output
*DECK DECK=IIV$XT_XTERM_UPLINE EXPAND=FALSE

  VAR
    iiv$xt_xterm_upline: [XREF] iit$xt_xterm_message_control;

*copyc iit$xt_xterm_message_control
*DECK DECK=IOC$CONDITION_LIMITS EXPAND=FALSE
*copyc osc$base_exception

  CONST
    ioc$disk_min_ecc = osc$base_exception + 2000,
    ioc$disk_max_ecc = ioc$disk_min_ecc + 999,
    ioc$tape_min_ecc = osc$base_exception + 3000,
    ioc$tape_max_ecc = ioc$tape_min_ecc + 999;

  CONST
    ioc$io_id = 'IO';
*DECK DECK=IOC$MAX_NUM_TAPE_UNITS EXPAND=FALSE

  CONST
     ioc$max_number_tape_units = 0ff(16),   { maximum of 255 tape units
     ioc$max_tape_blocks_to_process = 30,
     ioc$max_tape_block_length = amc$maximum_block,
     ioc$max_tape_not_long_blk_lgth = 4128,
     ioc$cart_tape_default_maxbl = 32640,
*IF $true(osv$unix)
     ioc$tape_max_data_transfer = 7fffffff(16),
*ELSE
     ioc$tape_max_data_transfer = ioc$max_tape_blocks_to_process * ioc$max_tape_block_length,
*IFEND
     ioc$min_tape_block_length = 1;

*copyc amc$maximum_block
*DECK DECK=IOC$MAX_SERVER_INDEX EXPAND=FALSE
  CONST
    ioc$max_server_index = 0ffff(16);

*DECK DECK=IOC$MAX_TASKS_PER_SERVER EXPAND=FALSE
  CONST
    ioc$max_tasks_per_server = 4;

*DECK DECK=IOC$SUBSYSTEM_IO_COMPLETED_ID EXPAND=FALSE
*DECK DECK=IOC$TAPE_RETRY_LIMITS EXPAND=FALSE
{ DECK: IOC$TAPE_RETRY_LIMITS

  CONST
    ioc$tape_long_wait = 5000,
    ioc$tape_status_wait = 100,
    ioc$max_ipi_retry = 6,
    ioc$tape_max_pp_q_retry = 5,
    ioc$tape_max_tcu_parity_retry = 3,
    ioc$tape_max_lost_data_retry = 6,
    ioc$tape_max_busy_retry = 36,
    ioc$tape_max_lateack_retry = 6,
    ioc$tape_max_misc_retry = 3,
    ioc$tape_max_chan_parity_retry = 6,
    ioc$tape_max_tape_parity_retry = 16,
    ioc$tape_max_parity_retry = ioc$tape_max_chan_parity_retry +
        ioc$tape_max_tape_parity_retry;

  TYPE
    iot$max_retry_count = 0 .. 0ff(16);
*DECK DECK=IOC$UNSOLICITED_RESPONSE_CODES EXPAND=FALSE
  CONST
    ioc$unit_ready_to_not_ready = 1,
    ioc$unit_not_ready_to_ready = 2,
    ioc$internal_error = 3,
    ioc$controller_reserved = 4,
    ioc$unit_reserved = 5,
    ioc$recovered_abnormal_error = 6,
    ioc$channelnet_input = 7,
    ioc$device_error = 8,
    ioc$log_pp_message = 9,
    ioc$channel_connection_input = 13,
    ioc$device_operational = 14,
    ioc$flow_control_status_change = 15;
*DECK DECK=IOD$DEBUG_OPTIONS EXPAND=FALSE
*DECK DECK=IODDSKP EXPAND=FALSE
*copyc IODMAC1 "{RECORD DEFINITION MACROS}
*copyc IODMAC2 "{LOAD/STORE MACROS}
*copyc IODMAC3 "{GENERAL MACROS}
*copyc IODMAC4 "{GENERAL MACROS}
*copyc IODMAC5 "{OVERLAY MACROS}
          EJECT
* DEFINE HARDW EQU 1, TO RUN ON THE HARDWARE.  .NE. 1, FOR SIMULATOR.

 HARDW    EQU    1           TO RUN ON THE HARDWARE
 SHARED   EQU    1           = 1, TO SHARE THE CONTROLLER
 MULT     EQU    0           = 1, IF MULTIPLE CONTROLLERS ON 1 PP
 ICHK     EQU    0           =1, TO CHECK HARDWARE DURING INITIALIZATION
 OFFU     EQU    0           =1, TO SUPPORT OFF UNIT, ON UNIT, COMMANDS
 RAM      EQU    0           =1, TO DETERMINE IF RAM PARITY ERROR
 LARGE    EQU    0           =1, TO INITIALIZE A UNIT WITH LARGE SECTORS
 SMALL    EQU    0           =1, TO INITIALIZE AN 844 WITH SMALL SECTORS
 IN844    EQU    0           =1, TO INITIALIZE AN 844 UNIT
                             .NE. 1, TO INITIALIZE AN 885 UNIT
 DUMP     EQU    0           =1, TO DUMP CONTROLWARE ON FUNCTION TIMEOUT
 PAT      EQU    0           =1, TO PATCH THE PP
 VER      EQU    2           READ FLAW SIMULATOR VERSION
 ERRTST   EQU    0           = 1, TO TEST ERROR HANDLING CODE
 ATST     EQU    0           = 1, TO TEST AUTOMATIC ERROR HANDLING CODE
 ETST     EQU    0           TEMPORARY


* EQUATES

 DC       EQU    22B         DISK CHANNEL
 SBYTE7   EQU    1376        NUMBER OF 12-BIT BYTES PER SECTOR
 SBYTE8   EQU    1032        NUMBER OF 16-BIT BYTES PER SECTOR
 CTLN     EQU    1           NUMBER OF CONTROLWARE WORDS TO READ INTO BUFFER
 STRY     EQU    40          NUMBER OF ATTEMPTS TO RECOVER A SEEK ERROR
 CNTRY    EQU    3           NUMBER OF ATTEMPTS TO LOAD CONTROLWARE
 CTRY     EQU    3           NUMBER OF ATTEMPTS TO RECOVER A CHANNEL ERROR
 RVTRY    EQU    10          LIMIT OF RECOVERED ERRORS PER REQUEST
 SCTRY    EQU    3           NUMBER OF ATTEMPTS TO RETRY A SECTOR
 UTRY     EQU    3           NUMBER OF ATTEMPTS TO CLEAR UNIT RESERVE
                               ON OPPOSITE ACCESS

* DISK FUNCTIONS

 F.MC     EQU    100000B     MASTER CLEAR THE 170 CIO CHANNEL ADAPTOR
 F.CONECT EQU    0           CONNECT
 F.SEEK   EQU    1           SEEK
 K.CPRES  EQU    4000B       CLEAR PHYSICAL RESERVE ON UNIT
 K.CLRES  EQU    400B        CLEAR LOGICAL RESERVE ON UNIT
 F.READ   EQU    4           READ
 F.WRITE  EQU    5           WRITE
 F.WRITEV EQU    6           WRITE VERIFY
 F.OPCMP  EQU    10B         OPERATION COMPLETE
 F.GS     EQU    12B         GENERAL STATUS
 F.DS     EQU    13B         7ETAILED STATUS
 F.CONT   EQU    14B         CONTINUE
 F.DRPSK  EQU    15B         DROP SEEKS
 F.RSEC   EQU    17B         RETURN SECTOR ADDRESS
 F.RCYL   EQU    21B         RETURN CYLINDER ADDRESS
 F.EDS    EQU    23B         EXTENDED DETAILED STATUS
 F.READFD EQU    30B         READ FACTORY DATA
 F.READUM EQU    31B         READ UTILITY MAP
 F.READPS EQU    34B         READ PROTECTED SECTOR
 F.WRITEL EQU    35B         WRITE LAST SECTOR
 F.WRITVL EQU    36B         WRITE VERITY LAST SECTOR
 F.CLEAR  EQU    42B         CLEAR CONNECTED ACCESS
 F.WRBUF  EQU    46B         WRITE BUFFER TO DISK
 F.CHST   EQU    52B         INPUT PROCESSOR CHANNEL STATUS
 F.AUTDP  EQU    61B         AUTODUMP
 F.ERROR  EQU    66B         FORCE ERROR
 F.AUTOD  EQU    100B        AUTOLOAD FROM DISK
 F.AUTOP  EQU    414B        AUTOLOAD FROM PP

* DETAILED STATUS FROM DISK.

 P.WRDAD  EQU    13          PP WORD ADDRESS OF CORRECTABLE READ ERROR
 P.VECT1  EQU    14          FIRST WORD OF 2-WORD CORRECTION VECTOR
 P.VECT2  EQU    15          2ND WORD OF 2-WORD CORRECTION VECTOR
          SPACE  6
* INTERNAL DEVICE CODES
 DT844    EQU    0           844-4X DEVICE TYPE
 DT885.1  EQU    1           885-1X DEVICE TYPE
          EJECT
* INTERFACE ERROR CODES.
          SPACE  6
 E101     EQU    401B        PP REQUEST QUEUE LOCKWORD TIMEOUT
 E102     EQU    402B        UNIT REQUEST QUEUE LOCKWORD TIMEOUT
 E103     EQU    403B        UNIT LOCKWORD TIMEOUT
 E104     EQU    404B        CHANNEL LOCKWORD TIMEOUT
 E105     EQU    405B        BUFFER POOL LOCKWORD TIMEOUT
 E106     EQU    406B        UNIT HARDWARE RESERVE TIMEOUT
 E107     EQU    407B        CONTROLLER HARDWARE RESERVE TIMEOUT
 E201     EQU    1001B       RMA OF CHANNEL RESERVATION TABLE NOT
                             A WORD BOUNDARY
 E202     EQU    1002B       RMA OF UNIT ACTIVITY MASK NOT A
                             WORD BOUNDARY
 E203     EQU    1003B       RMA OF PP COMMUNICATION BUFFER NOT A
                             WORD BOUNDARY
 E204     EQU    1004B       RESERVED FIELD OF THE PP COMMUNICATION
                             BUFFER DESCRIPTOR IS NOT ZERO
 E205     EQU    1005B       RESERVED FIELD OF THE PP REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 E206     EQU    1006B       RMA OF NEXT PP NOT A WORD BOUNDARY
 E207     EQU    1007B       RESERVED FIELD OF THE PP RESPONSE
                             BUFFER DESCRIPTOR IS NOT ZERO
 E208     EQU    1010B       LOGICAL UNIT OF UNIT DESCRIPTOR NOT
                             IN SEQUENCE OR NOT IN RANGE
 E209     EQU    1011B       RMA OF UNIT INTERFACE TABLE NOT A
                             WORD BOUNDARY
 E20A     EQU    1012B       INVALID CHANNEL NUMBER SPECIFIED
                             IN UNIT DESCRIPTOR
 E20B     EQU    1013B       COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS OR NOT LONG ENOUGH
 E20C     EQU    1014B       RESERVED FIELD AFTER NUMBER OF
                             UNITS IS NOT ZERO
 E20D     EQU    1015B       RESERVED FIELD OF IN POINTER
                             IS NOT ZERO
 E20E     EQU    1016B       RESERVED FIELD OF OUT POINTER
                             IS NOT ZERO
 E20F     EQU    1017B       RESERVED FIELD OF LIMIT POINTER
                             IS NOT ZERO
 E210     EQU    1020B       INVALID PHYSICAL UNIT NUMBER
 E211     EQU    1021B       RMA OF INTERRUPT WORD NOT A WORD
                             BOUNDARY
 E212     EQU    1022B       RMA OF CHANNEL TABLE NOT A WORD
                             BOUNDARY
 E213     EQU    1023B       CONTROLWARE IS NOT PRESENT IN THE
                             PP COMMUNICATION BUFFER
 E301     EQU    1401B       LOGICAL UNIT NUMBER NOT EQUAL TO LOGICAL
                             UNIT OF UNIT DESCRIPTOR
 E302     EQU    1402B       RMA OF UNIT COMMUNICATION BUFFER
                             NOT A WORD BOUNDARY
 E303     EQU    1403B       A RESERVED FIELD OF THE UNIT COMMUNICATION BUFFER
                             DESCRIPTOR IS NOT ZERO
 E304     EQU    1404B       RMA OF NEXT UNIT REQUEST
                             NOT A WORD BOUNDARY
 E305     EQU    1405B       RESERVED FIELD OF UNIT REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 E306     EQU    1406B       INVALID UNIT TYPE
 E307     EQU    1407B       UNIT COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF CM WORDS
 E308     EQU    1410B       UNIT COMMUNICATION BUFFER IS TOO SMALL
 E401     EQU    2001B       RMA OF NEXT REQUEST NOT A WORD BOUNDARY
 E402     EQU    2002B       REQUEST LENGTH NOT A MULTIPLE
                             OF EIGHT BYTES
 E403     EQU    2003B       REQUEST LENGTH IS LESS THAN FORTY BYTES
 E404     EQU    2004B       LOGICAL UNIT NUMBER NOT EQUAL TO LOGICAL
                             UNIT IN UNIT INTERFACE TABLE
 E405     EQU    2005B       RESERVED LINKAGE FIELD IS NOT ZERO
 E406     EQU    2006B       INVALID RECOVERY/INTERRUPT SELECTIONS
 E407     EQU    2007B       INVALID PRIORITY SELECTION
 E408     EQU    2010B       INVALID SECONDARY ADDRESS
 E501     EQU    2401B       INVALID COMMAND CODE
 E502     EQU    2402B       INVALID FLAG SELECTION
 E503     EQU    2403B       INVALID FUNCTION
 E504     EQU    2404B       FUNCTION NOT SUPPORTED BY HARDWARE
 E505     EQU    2405B       INVALID LENGTH SPECIFICATION
                             IN COMMAND
 E506     EQU    2406B       INVALID ADDRESS SPECIFICATION
                             IN COMMAND
 E507     EQU    2407B       INVALID LENGTH SPECIFICATION IN
                             INDIRECT LIST
 E508     EQU    2410B       INVALID ADDRESS SPECIFICATION
                             IN INDIRECT LIST
 E509     EQU    2411B       PP COMMAND NOT ALLOWED IN REQUEST
                             TO A UNIT
 E50A     EQU    2412B       INVALID SEQUENCE OF COMMANDS
 E50B     EQU    2413B       INVALID PARAMETER SPECIFICATION
                             (POOL READ OR COMPARE SWAP COMMANDS)
          EJECT
* CONFIGURED UNITS.

 UN       RECORD PACKED

* WORD 1.

 UIT      STRUCT 6           RMA OF UNIT INTERFACE TABLE (REFORMATTED)

* WORD 4.

 FILL1    SUBRANGE 0,77777B
 CTST     BOOLEAN            NONZERO IF THE CONFIDENCE TEST WAS RUN


          MASKP  CTST
 K.CTST   EQU    MSK

 UN       RECEND
          EJECT
* SELECTION SET (SS)

 SS       RECORD PACKED

* WORD 1.

 CHAN     SUBRANGE 0,77B     CHANNEL NUMBER
 FILL     SUBRANGE 0,7B
 INIT     BOOLEAN            NONZERO IF SS ENTRY HAS BEEN INITIALIZED
 ENTRY    BOOLEAN            ENTRY PRESENT
 SEEK     BOOLEAN            SEEK ISSUED
 WRITE    BOOLEAN            WRITE REQUEST
 CUR      BOOLEAN            CURRENT REQUEST HAS BEEN SELECTED (IF SET)
 DV       SUBRANGE 0,3       DEVICE TYPE

 FILL1    SUBRANGE 0,77B
 LS       BOOLEAN            LARGE SECTOR FLAG IN SEEK COMMAND
 FILL2    SUBRANGE 0,7
 UNIT     SUBRANGE 0,77B     UNIT NUMBER

 CYL      PPWORD             CYLINDER ADDRESS
 TRACK    PPWORD             TRACK ADDRESS

* WORD 2.

 SECTOR   PPWORD             SECTOR ADDRESS
 LU       PPWORD             LOGICAL UNIT
 FILL3    SUBRANGE 0,77777B
 CONF     BOOLEAN            NONZERO IF RUNNING THE CONFIDENCE TEST
 REQ      STRUCT 4           CURRENT REQUEST (UNFORMATTED RMA)
 PVA      STRUCT 6           PVA OF CURRENT REQUEST
 QSTRT    STRUCT 4           START OF QUEUE ( UIT + 4)
 QP       STRUCT 4           CURRENT QUEUE POINTER
 COM      STRUCT 6           COMMUNICATION BUFFER (RMA, REFORMATTED)
 UQT      STRUCT 6           UNIT Q TABLE (RMA, REFORMATTED)
          MGEN   N.ENTRY
 M.ENTRY  EQU    MASK$
          MGEN   N.WRITE
 M.WRITE  EQU    MASK$
          MGEN   N.CUR
 M.CUR    EQU    MASK$
          MASKP  INIT
 K.INIT   EQU    MSK
          MASKP  ENTRY
 K.ENTRY  EQU    MSK
          MASKP  WRITE
 K.WRITE  EQU    MSK
          MASKP  SEEK
 K.SEEK   EQU    MSK
          MASKP  CUR
 K.CUR    EQU    MSK
          MGEN   N.CHAN
 M.CHAN   EQU    MASK$
          MGEN   N.DV
 M.DV     EQU    MASK$
          MGEN   N.LS
 M.LS     EQU    MASK$
          MGEN   N.UNIT
 M.UNIT   EQU    MASK$
          MASKP  CONF
 K.CONF   EQU    MSK

 SS       RECEND
          SPACE  6
* PP TABLE.

 PT       RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 PART     PPWORD             PARTNER PP NUMBER
 PIT      RMA                PP INTERFACE TABLE ADDRESS (RMA)
 PITPVA   STRUCT 24          PP INTERFACE TABLE ADDRESS (PVA)

 PT       RECEND
          SPACE  6
* PP INTERFACE TABLE
 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
 ACTIVE   BOOLEAN            ACTIVE_CHECK FLAG.  WHEN SET, THE PP
                             MUST CLEAR IT.
 IDLE     BOOLEAN            IDLE REQUEST
 RESUME   BOOLEAN            RESUME REQUEST
 IDSTAT   BOOLEAN            IDLE_STATUS. IF SET, THE PP IS SOFTWARE IDLED.
 FILL1    SUBRANGE 0,3777B
 LOCKF    BOOLEAN            THIS LOCK FLAG MUST BE SET BEFORE CHANGING ANYTHING
                             IN THIS CM WORD.
          ALIGN  0,64
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER
          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)
          ALIGN  32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER




          MASKP  ACTIVE
 K.ACTIVE EQU    MSK
          MASKP  IDLE
 K.IDLE   EQU    MSK
          MASKP  RESUME
 K.RESUME EQU    MSK
          MASKP  IDSTAT
 K.IDSTAT EQU    MSK
          MASKP  LOCKF
 K.LOCKF  EQU    MSK
 K.ACTION EQU    K.ACTIVE+K.IDLE+K.RESUME

 PIT      RECEND
          SPACE  6
* UNIT DESCRIPTORS.

 UD       RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 UD       RECEND
          SPACE  6
* UNIT INTERFACE TABLE

 UIT      RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
                               = 400B, 844-4X
                               = 401B, 885-1X
 QCNT     PPWORD             QUEUE COUNT
*
 SHARE    BOOLEAN            NONZERO IF THIS UNIT IS BEING SHARED WITH MALET OR DFT
          ALIGN  16,64
 UBUFL    PPWORD             UNIT COMMUNICATION BUFFER LENGTH
 UBUF     RMA                UNIT COMMUNICATION BUFFER (RMA)
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

          MASKP  DSABLE
 K.DSABLE EQU    MSK

 UIT      RECEND
          SPACE  6
* PP REQUESTS.

 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS
                               0 - ATTEMPT RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
          ALIGN  0,64
 SWIT     BOOLEAN            SWITCH TO NEXT REQUEST
          ALIGN  16,64
 CYL      PPWORD             CYLINDER ADDRESS
 TRACK    PPWORD             TRACK ADDRESS
 SECTOR   PPWORD             SECTOR ADDRESS
 CMND     INTEGER            COMMAND SEQUENCE


          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$

 RQ       RECEND
          SPACE  6
* PP COMMAND.

 CM       RECORD PACKED

 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$

 CM       RECEND
          SPACE  6
* COMMAND CODES.

 C.ACK    EQU    0           ACKNOWLEDGE
 C.STOP   EQU    1           STOP UNIT
 C.SELU   EQU    2           SELECT UNIT
 C.SELC   EQU    3           SELECT CONTROLLER
 C.IDLE   EQU    4           IDLE
 C.RESUME EQU    5           RESUME
 C.OLAY   EQU    6           EXECUTE OVERLAY
 C.READY  EQU    7           START READY SCAN
 C.SREADY EQU    10B         STOP READY SCAN
 C.PPAD   EQU    11B         SELECT PP MEMORY ADDRESS
 C.PPMEM  EQU    12B         COPY PP MEMORY
 C.LDCON  EQU    14B         LOAD CONTROLWARE
 C.ONUN   EQU    20B         ENABLE UNIT
 C.OFFUN  EQU    21B         DISABLE UNIT
 C.FUNC   EQU    40B         OUTPUT FUNCTION
 C.OUTP   EQU    41B         OUTPUT 8-BIT PARAMETERS
 C.OUTD   EQU    43B         OUTPUT 8-BIT DATA
 C.IND    EQU    45B         INPUT 8-BIT DATA/PARAMETERS
 C.READ   EQU    100B        READ BYTES
 C.WRITE  EQU    120B        WRITE BYTES
 C.STATUS EQU    140B        READ STATUS
 C.COUNT  EQU    141B        STORE TRANSFER COUNT
 C.SWAP   EQU    160B        COMPARE AND SWAP
 C.WRITEI EQU    162B        WRITE INITIALIZE
 C.RFLAW  EQU    163B        READ FLAW MAPS
 C.WRITEV EQU    200B        WRITE VERIFY
          SPACE  6
* PP RESPONSE.

 RS       RECORD PACKED

* WORD 1.
 FILL1    BOOLEAN
 SHORT    BOOLEAN            IF SET, IT IS A ONE-WORD NORMAL RESPONSE
          ALIGN  8,64
 LUN      SUBRANGE 0,377B    LOGICAL UNIT
 PVA      STRUCT 6           PVA OF REQUEST

* WORD 2.
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST  (NOT USED)

* WORD 3.
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST) (NOT USED)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)  (NOT USED)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS  (NOT USED)
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY  (NOT USED)
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

* WORD 4.
          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED  (NOT USED)
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE INTERFACE
                             ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
                             (NOT USED)
 CHERR    BOOLEAN            CHANNEL PARITY ERROR
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION
                             OCCURRED ON INPUT OR INADEQUATE DATA RATE ON OUTPUT
                             (NOT USED)
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT  (NOT USED)
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A
                             HARDWARE MALFUNCTION.  EX: UNIT NOT READY,
                             UNIT NOT CONNECTED.  (NOT USED)
 FTO      BOOLEAN            FUNCTION TIMEOUT
 CHERO    BOOLEAN            CHANNEL OUTPUT PARITY ERROR
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
                               1 - RECOVERED ERROR
                               2 - COMMAND HAD EXPLICIT RESPONSE FLAG SET
                               3 - BOTH CONDITIONS 1 AND 2
 K.REC    EQU    1           RECOVERED ERROR
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE  (NOT USED)
                               1 - UNIT CHANGED FROM READY TO NOT READY
                               2 - UNIT CHANGED FROM NOT READY TO READY
                               3 - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
                               4 - CONTROLLER RESERVED
                               5 - UNIT RESERVED TO ANOTHER ACCESS
                               6 - RECOVERED ABNORMAL CONDITION
          ALIGN  49,64       ALERT CONDITIONS
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

* WORD 5.
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)

* WORD 6.

 CHAN     PPWORD             CHANNEL NUMBER
 SCYL     PPWORD             STARTING CYLINDER
 STRK     PPWORD             STARTING TRACK
 SSEC     PPWORD             STARTING SECTOR

* WORD 7.

 UNIT     PPWORD             UNIT NUMBER
 RTRY     PPWORD             REQUEST RETRY COUNT
 FTRK     PPWORD             FAILING TRACK
 FSEC     PPWORD             FAILING SECTOR

* WORD 8.

 DET      PPWORD             =1, IF DETAILED STATUS PRESENT
 K.CSP    EQU    1           CONTROLLER STATUS PRESENT
 K.DSP    EQU    2           DEVICE STATUS PRESENT
 K.ERIP   EQU    4           ERROR REGISTER IMAGE PRESENT
 K.ELP    EQU    10B         ERROR LOG PRESENT
 K.ICS    EQU    20B         INCORRECT CONTROLLER WAS SELECTED
 K.CSC    EQU    40B         CANNOT SELECT THE CONTROLLER
                             SELECT ACTIVE NEVER GETS SET
 K.TIP    EQU    100B        TIMEOUT - TRANSFER IN PROGRESS
                             DIDN'T CLEAR
 K.TOP    EQU    200B        TIMEOUT - PAUSE DIDN'T CLEAR
 K.ICA    EQU    400B        ERROR IN INITIALIZING CHANNEL ADAPTER
 K.HIE    EQU    1000B       HOST I/F INTEGRITY ERROR
 K.DIE    EQU    2000B       DRIVE I/F INTEGRITY ERROR
 K.MC     EQU    4000B       MASTER CLEAR DID NOT WORK
 K.CT     EQU    10000B      RUNNING THE CONFIDENCE TEST
 K.CFLAW  EQU    20000B      ALL SECTORS / TRACKS ARE FLAWED ON THE CONFIDENCE
                             CYLINDER
 K.HOST   EQU    40000B      NOT THE SAME HOST ID
 K.SEC    EQU    100000B     SECTOR SIZE NOT 4096


 ID       PPWORD             ERROR IDENTIFIER
 K.CMLD   EQU    1           RELOAD OF CONTROL MODULE WAS ATTEMPTED
 K.CMLDS  EQU    2           CONTROL MODULE RELOADED SUCCESSFULLY
 K.XD     EQU    4           EXECUTING LEVEL II DIAGNOSTICS
 K.XDP    EQU    10B         LEVEL II DIAGNOSTICS PASSED
 K.PU     EQU    20B         POWERING UP SPINDLE
 K.PUC    EQU    40B         SPINDLE POWERED UP
 K.PTO    EQU    100B        PP TIMED OUT A COMMAND
 K.UDN    EQU    20000B      UNIT DOWN
 K.CMDN   EQU    40000B      CONTROL MODULE DOWN
 K.CHDN   EQU    100000B     CHANNEL DOWN
 FILL2    PPWORD
 STRY     PPWORD             SECTOR RETRY COUNT

* WORD 9.

 GENST1   PPWORD             GENERAL STATUS OF THE FIRST TIME ERROR
                               WAS ENCOUNTERED
 GENST2   PPWORD             GENERAL STATUS OF THE LAST TIME ERROR
 FUNTO    PPWORD             FUNCTION CODE IF FUNCTION TIMEOUT ERROR
 ERRID    PPWORD             ERROR IDENTIFIER
 K.IST    EQU    1           INCOMPLETE SECTOR TRANSFER
 K.CRES   EQU    2           CLEAR UNIT RESERVE ON OPPOSITE ACCESS
 K.RAM    EQU    4           RAM PARITY ERROR
 K.CLOAD  EQU    10B         CONTROLWARE LOAD WAS ATTEMPTED
 K.AFT    EQU    20B         AUTOLOAD FUNCTION TIMEOUT
 K.CEMPT  EQU    40B         CHANNEL DOESNT GO EMPTY AFTER SENDING
                             PARAMETERS / DATA
 K.CINAC  EQU    100B        CHANNEL NOT INACTIVE AFTER
                             RECEIVING PARAMETERS / DATA
 K.MEDIA  EQU    200B        MEDIA FAILURE, REREAD SECTOR
 K.UNMED  EQU    400B        UNRECOVERED MEDIA ERROR
 K.RERR   EQU    1000B       READ ERROR.  STATUS BEFORE SUSPEND/TERMINATE .NE.
                             4XXXB.
 K.CF     EQU    2000B       POLL STATUS NONZERO AFTER SENDING CONTROLWARE
 K.DE     EQU    4000B       POLL STATUS NONZERO AFTER LOADING ATTENTION DELAY
 K.NR     EQU    10000B      NOT READY
 K.URS    EQU    20000B      UNIT RESERVED
 K.CRS    EQU    40000B      CONTROLLER RESERVED
 K.ADPT   EQU    100000B     ADAPTER CONTROLWARE ERROR

* WORD 10.

          ALIGN  0,64
 DETAIL   STRUCT 40          DETAILED STATUS OF THE FIRST TIME ERROR
                             WAS ENCOUNTERED
 DET2     STRUCT 40          DETAILED STATUS OF THE LAST TIME ERROR
                             WAS ENCOUNTERED.


          MASKP  SHORT
 K.SHORT  EQU    MSK
          MGEN   N.LUN
 M.LUN    EQU    MASK$
          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$
          MASKP  INTERR
 K.INTERR EQU    MSK
          MASKP  DATOV
 K.DATOV  EQU    MSK
          MASKP  DATERR
 K.DATERR EQU    MSK
          MASKP  HDWR
 K.HDWR   EQU    MSK
          MASKP  CHERR
 K.CHERR  EQU    MSK
          MASKP  CHERO
 K.CHERO  EQU    MSK
          MASKP  NRDY
 K.NRDY   EQU    MSK
          MASKP  FTO
 K.FTO    EQU    MSK

 RS       RECEND
          SPACE  6
* RESPONSE CODES.
 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    1           INTERMEDIATE RESPONSE
 R.NRM    EQU    2           NORMAL REQUEST TERMINATION
 R.ABN    EQU    3           ABNORMAL REQUEST TERMINATION
          SPACE  10
* PP COMMUNICATION BUFFER.

 CB       RECORD PACKED

          ALIGN  31,64
 SLAVE    BOOLEAN            NONZERO IF SLAVE PP
 PARTNR   RMA                PARTNERS COMMUNICATION BUFFER (RMA)

 CONTRL   STRUCT 8           LOAD CONTROLWARE COMMAND
 CMCTRL   STRUCT 8           LOAD CONTROL MODULE CONTROLWARE
          STRUCT 24
          STRUCT 24

 MSGIN    PPWORD             MESSAGE TO MASTER FROM SLAVE

          ALIGN  0,64
 MSGOUT   PPWORD             MESSAGE TO SLAVE FROM MASTER

          ALIGN  0,64
 ZERO     STRUCT 272         CONTAINS ALL ZEROES

          ALIGN  0,64
 SS       STRUCT 40          SS ENTRY

 REQ      STRUCT 40          REQUEST

          ALIGN  0,64
 UNITS    STRUCT 320         UNIT INTERFACE TABLE POINTERS FOR 40 UNITS

          ALIGN  0,64
 OVR      STRUCT 1944        PP OVERLAY



          MASKP  SLAVE
K.SLAVE   EQU    MSK


 CB       RECEND
          SPACE  6
* COMMANDS BETWEEN PPS.

 C.GO     EQU    1           DONE WITH THE DISK FOR THIS SECTOR
 C.REQ    EQU    2           START A DISK REQUEST
 C.ABT    EQU    3           ABORT THE REQUEST
 C.SWIT   EQU    4           SWITCH TO THE NEXT REQUEST
 C.END    EQU    5           END OF THE DISK REQUEST
          EJECT
          CON    INIT-1


* DIRECT CELLS

 T1       BSSZ   1
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1

 TRKEND   BSSZ   1           END OF TRACK FLAG
 SEKI     BSSZ   1           INDEX TO SEKS TABLE
 CM.PIT   BSSZ   3           CM ADDRESS OF PP INTERFACE TABLE (REFORMATED)
 MAPC     BSSZ   1           INDEX TO VARIOUS READ FUNCTIONS TO
                               READ THE FLAW MAPS

* KEEP GNSTAT AND P1 ADJACENT.
 GNSTAT   BSSZ   1           GENERAL STATUS
 P1       BSSZ   1
 P2       BSSZ   1
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 P6       BSSZ   1
 WC       BSSZ   1           WORD COUNT TO READ/WRITE CM WORDS

 FNC      BSSZ   1           FUNCTION CODE (INTERNAL)
 DEVICE   BSSZ   1           DEVICE TYPE
 DEV      BSSZ   1           USED FOR SMALL OR LARGE SECTOR DISTINCTION
 ERRCNT   BSSZ   1           ERROR COUNTER
 CHAN     BSSZ   1           CHANNEL NUMBER
 NUMCM    BSSZ   1           NUMBER OF COMMANDS LEFT TO PROCESS IN THIS REQUEST
 SELECT   BSSZ   1           SS INDEX TO SELECTED REQUEST
 SELIN    BSSZ   1           SELECTION SET INDEX USED DURING THE SELECTION
                             PROCESS
 SEKCNT   CON    0           SEEK COUNT. NUMBER OF UNITS TO WHICH A SEEK WAS
                             ISSUED
 DATADD   BSSZ   3           CM ADDRESS OF DATA AREA
 CMADR    BSSZ   3           CM ADDRESS
 CMLISTL  BSSZ   1           NUMBER OF CM WORDS IN ADDRESS-LENGTH PAIR LIST.
                             (INCLUDES THE NUMBER OF WORDS WHICH HAVENT
                             BEEN READ FROM CM.)
 CML      BSSZ   1           INDEX TO CMLIST
 WDS      BSSZ   1           NUMBER OF CM WORDS TO TRANSFER FROM CURRENT SECTOR.
 WDSS     BSSZ   1           USED TO UPDATE BYTES TRANSFERRED IN RESPONSE STATUS
 TWDS     BSSZ   1           TOTAL NUMBER OF CM WORDS TO TRANSFER TO THE
                             CM ADDRESS.
 SECWDS   BSSZ   1           NUMBER OF DATA WORDS IN SECTOR
 SECPOS   BSSZ   1           SECTOR BUFFER TRANSFER POSITION (TO CM)
 RESPC    BSSZ   1           RESPONSE CODE
 SMSEC    BSSZ   1           SMALL SECTOR COUNTER
 SIO      BSSZ   1           NONZERO IF I/0 HAS BEEN STARTED ON A REQUEST
 PPNO     CON    1           LOGICAL PP NUMBER
 SWFLG    BSSZ   1           NONZERO IF A STREAMING REQUEST SWITCH WAS MADE
 NCOMRQ   BSSZ   1           NUMBER OF COMPLETED REQUESTS
                             MUST BE INITIALLY = 0
 CUNITS   BSSZ   1           NUMBER OF CONFIGURED UNITS
 LDC      BSSZ   1           RETRY COUNTER FOR LOADING CONTROLWARE
 NORQ     BSSZ   1           NONZERO IF NO REQUEST IS BEING PROCESSED,
                             (FOR ERROR RECOVERY)
          SPACE  3
          ORG    72B

 DSRTP    CON    0           HCS REAL MEMORY WORD-ADDRESS
          CON    1
 FUNCD    EQU    DSRTP       FUNCTION CODE
 INPNT    EQU    DSRTP+1     IN POINTER FOR RESPONSE BUFFER
 FRST     BSSZ   1           = 0, IF FIRST TIME THROUGH UNCMND
 LIM      BSSZ   1           LIMIT OF RESPONSE BUFFER (IN 8-BIT BYTES)
          ORG    76B
          CON    5           TEMPORARY, PP TYPE USED BY DEADSTART
 FNERR    EQU    76B         FUNCTION TIMEOUT IF NONZERO
 RLAST    BSSZ   1           USED TO DETERMINE IF AN ERROR OCCURED ON
                             WRITE LAST SECTOR
          EJECT
          ORG    100B
          LJM    INIT
          CON    CONTYP      USED FOR DUMP IDENTIFICATION
          SPACE  6
 HALT     CON    0           HALT THE PP
          UJN    *
          SPACE  6

* NUMBER BY WHICH THE SECTOR ADDRESS IS INCREMENTED
* FOR EACH SECTOR.

 SECSC    CON    1           844
          CON    4           885-1

* NUMBER OF SECTORS PER TRACK FOR EACH DEVICE.

 DVSEC    CON    24          844
          CON    32          885-1

* NUMBER OF TRACKS PER CYLINDER FOR EACH DEVICE.

 DVTRK    CON    19          844
          CON    40          885-1

* NUMBER OF CM WORDS TO TRANSFER FOR EACH SECTOR.
* (EXCEPT EVERY 5TH SECTOR.)

 CMWDS    CON    60          844
          CON    256         885-1

* NUMBER OF CM WORDS TO TRANSFER FOR EACH 5TH SECTOR.

 CMWDS5   CON    16          844
          CON    256         885-1

* NUMBER OF CHANNEL WORDS PER SECTOR.

 CHWDS    CON    322         844
          CON    SBYTE7      885-1


 LUD      BSSZ   1           INDEX OF LAST UNIT DESCRIPTOR REQUEST FOUND

 CM.RS    BSSZ   3           CM ADDRESS OF RESPONSE BUFFER (REFORMATTED)

 CM.CB    BSSZ   3           CM ADDRESS OF PP COMMUNICATION BUFFER (REFORMATTED)
 CM.INT   BSSZ   3           CM ADDRESS OF INTERRUPT WORD
 CM.CHAN  BSSZ   3           CM ADDRESS OF CHANNEL INTERLOCK TABLE
 DH       BSSZ   3           CM ADDRESS OF OVERLAY DIRECTORY
          SPACE  6


* WHEN PROCESSING THE FUNCTION C.FLAW, READ FLAW MAPS, UP TO FOUR
* DIFFERENT READ-TYPE FUNCTIONS ARE TRIED.

 MAPFN    BSS
          CON    F.READPS    READ PROTECTED SECTOR
          CON    F.READ      READ
          CON    F.READFD    READ FACTORY DATA
          CON    F.READUM    READ UTILITY MAP
 MAPLN    EQU    *-MAPFN
          SPACE 2
 CURCH    CON    DC          CURRENT CHANNEL NUMBER
          SPACE  2
          EJECT
          QUAL   RES
*COPYC IODMAC6
          EJECT
 SCLX     LJM    **
 SCLOCK   EQU    *-1
          LDML   CHLOCK
          ZJN    SCL1        IF CHANNEL LOCK IS NOT SET
          LDN    0           EXIT A REGISTER = 0
          UJK    SCLX

 SCL1     BSS
          LOADOVL RECSO
          LJM    SCL10

 SELRQX   LJM    **
 SELRQ    EQU    *-1
          LDML   OVAD1
          SBN    SELRQOO
          ZJN    SELRQ2      IF OVERLAY IS ALREADY LOADED
          LOADOVL SELRQO
 SELRQ2   BSS
          LJM    SELRQ1

 RDEX     LJM    **
 RDERR    EQU    *-1
          LDML   OVAD1
          SBN    RDERROO
          ZJN    RDERR2      IF OVERLAY IS ALREADY LOADED
          LOADOVL RDERRO
 RDERR2   BSS
          LJM    RDERR1

 RECS     CON    0
          LOADOVL RECSO
          LJM    RECS1

 ATERM    CON    0
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LOADOVL RECSO
          LJM    ATERM1

 HTERM    CON    0
          LOADOVL RECSO
          LJM    HTERM1

 UTERM    CON    0
          LOADOVL DOWNO
          LJM    UTERM1

 OTERM    CON    0
          LOADOVL DOWNO
          LJM    OTERM1

 LTERM    CON    0
          LOADOVL DOWNO
          LJM    LTERM1

 TSKX     LJM    **
 TERMSK   EQU    *-1
          LOADOVL RECSO
          LJM    TERMSK1

 PPRQX    LJM    **
 PPREQ    EQU    *-1
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          ERRNZ  /PIT/C.ACTIVE
          CRDL   T1          READ PP REQUEST FLAGS
 PPRQ5    BSS
          LDDL   T4
          LPK    /PIT/K.ACTION  PP REQUEST FLAGS
          ZJK    PPRQX       IF NO PP REQUESTS
          SHN    /PIT/L.ACTIVE+2
          PJN    PPRQ6       IF THE ACTIVE CHECK FLAG IS NOT SET

* THE ACTIVE CHECK FLAG IS SET.
* SET THE LOCK, AND CLEAR THE ACTIVE CHECK FLAG.

          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDK    /PIT/K.LOCKF
          STDL   T4
          LOADC  CM.PIT
          ERRNZ  /PIT/C.ACTIVE
          RDSL   T1          TRY TO SET THE LOCK
          LDDL   T4
          LPK    /PIT/K.LOCKF
          NJK    PPRQX       IF SOMEONE ELSE HAS THE LOCK
          LDDL   T4          CLEAR THE ACTIVE CHECK FLAG
          LPC    -/PIT/K.ACTIVE-/PIT/K.LOCKF
          STDL   T4
          LOADC  CM.PIT
          ERRNZ  /PIT/C.LOCKF
          CWDL   T1
          UJK    PPRQ5

 PPRQ6    BSS                PROCESS IDLE OR RESUME REQUEST
          LOADOVL PPREQO
          LJM    PPR1


 LDCNX    LJM    **
 LDCN     EQU    *-1
          LOADOVL RECSO
          LJM    LDCN1

 ACNX     LJM    **
 ACN      EQU    *-1
          ACN    DC          ACTIVATE THE CHANNEL
          UJK    ACNX

 IAX      LJM    **
 IAPMBF   EQU    *-1
          IAPM   BUFF,DC     READ A SECTOR OF DATA FROM DISK
          UJK    IAX

 OAX      LJM    **
 OAPMBF   EQU    *-1
          OAPM   BUFF,DC     WRITE A SECTOR OF DATA TO DISK
          UJK    OAX

 CFMX     LJM    **
 CFM      EQU    *-1
          CFM    CFMX,DC     CHECK AND CLEAR CHANNEL ERROR
          AOML   CFM         CHANNEL ERROR, EXIT * + 1
          UJK    CFMX

 OAMCTX   LJM    **
 OAMCT    EQU    *-1
          OAM    CTBUF,DC    SEND DATA TO CONTROLLER
          UJK    OAMCTX

 DCNX     LJM    **
 DCN      EQU    *-1
          FJM    *,DC        WAIT FOR CHANNEL TO BECOME EMPTY
          PSN
          PSN
          DCN    40B+DC
          UJK    DCNX



 RSAX     LJM    **
 RSA      EQU    *-1
 RSA10    BSS
          LDN    F.RSEC      ISSUE RETURN SECTOR ADDRESS FUNCTION
          RJM    FUNC
          ACN    DC
          LDN    3
          IAM    GNSTAT,DC   INPUT STATUSES
          CFM    RSA20,DC    CHECK AND CLEAR CHANNEL ERROR
          RJM    CHNERR      RECORD CHANNEL ERROR
          UJK    RSA10       RETRY

 RSA20    BSS
          UJK    RSAX

 RSTX     LJM    **
          EJECT
 DISK     BSS
          LOADOVL PPREQO
          RJM    ICOM        INITIALIZE UNIT TABLES
          LOADOVL SELRQO     INITIALIZE THIS OVERLAY AREA

 MAINA    BSS
          IFEQ   PAT,1
          RJM    PATCH       PATCH THE PP
          ENDIF
 Q13      IFEQ   ERRTST,1
          LOADOVL TESTO
          RJM    TEST        CHECK FOR FUNCTION TIMEOUT TEST
 Q13      ENDIF

          RJM    PPREQ       CHECK FOR ANY PP REQUESTS

          LDDL   CUNITS
          ZJN    MAINB       IF NO UNITS
          LDML   IDLE
          ZJN    MAIN10      IF NOT SOFTWARE IDLED
 MAINB    BSS
          SOML   CHLCNT
          NJK    MAINA       IF PP DOESN'T HAVE TO GIVE UP CHANNEL
          RJM    CKCHAN      CHECK IF CHANNEL MUST BE GIVEN UP
          UJK    MAINA

 MAIN10   BSS
          LDML   IALF
          NJN    MAIN50      IF CONFIDENCE TEST HAS BEEN RUN ON ALL UNITS
          LDML   OVAD2
          SBN    CONFOO
          ZJN    MAIN2       IF OVERLAY IS ALREADY LOADED
          LOADOVL CONFO
 MAIN2    BSS
          RJM    CTEST       RUN CONFIDENCE TEST ON ALL UNITS

 MAIN50   BSS
          LDML   OVAD2
          SBN    READOO
          ZJN    MAIN55      IF OVERLAY IS ALREADY LOADED
          LOADOVL READO
 MAIN55   BSS
          RJM    SELSEK      SELECT UNIT REQUESTS AND SEEK
          RJM    RECRS       CHECK FOR RECOVERED ERRORS
          LDDL   SEKCNT
          ZJK    MAINB       IF NO SEEKS WERE ISSUED
          RJM    UREQ        READ UNIT REQUEST FROM CM

          RJM    SETRQ       SET UP FOR FIRST REQUEST
          RJM    SRESP       SET UP RESPONSE BUFFER
          AODL   SIO         SET -START I/O- FLAG
 MAIN60   RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
          ZJN    MAIN70      IF NO MORE COMMANDS
 MAINC    BSS
          LDML   OVAD2
          SBN    READOO
          ZJN    MAIN63      IF OVERLAY IS ALREADY LOADED
          LOADOVL READO
 MAIN63   BSS
          LDML   UCMDPR,FNC  GET COMMAND PROCESSOR
          STML   MAIN65
          RJM    **          PROCESS COMMAND
 MAIN65   EQU    *-1
          LDDL   RESPC       CHECK FOR ABNORMAL RESPONSE CODE
          SBN    R.ABN
          NJK    MAIN60      IF NO ERROR, LOOK FOR ANOTHER COMMAND

* TERMINATE REQUEST.

 MAIN70   BSS
          LJM    TERM        SEND TERMINATION RESPONSE

          SPACE  6
* UNIT COMMANDS
 UCMD     BSS
          CON    C.READ
          CON    C.WRITE
          CON    C.RFLAW

* PP COMMANDS.

 F31      IFEQ   OFFU,1
          CON    C.OFFUN
          CON    C.ONUN
 F31      ENDIF
 UCMDL    EQU    *-UCMD

* UNIT COMMAND PROCESSORS
 UCMDPR   BSS
          CON    READ        READ BYTES
          CON    WRITE       WRITE BYTES
          IFEQ   HARDW,1
          CON    READ        READ FLAW MAP
          ELSE
          CON    RFLAW
          ENDIF

* PP COMMAND PROCESSORS.

 F32      IFEQ   OFFU,1
          CON    STOP        SET UNIT DISABLE
          CON    ONUN        CLEAR UNIT DISABLE FLAG
 F32      ENDIF
          EJECT
** NAME-- SEEKI.
*
** PURPOSE-- DETERMINE IF A SEEK SHOULD BE ISSUED, AND, IF SO,
*            ISSUE THE SEEK.
*
** INPUT-- SELIN, SEKCNT.
*
** OUTPUT-- SEKS,SEKCNT
*           SEKCNT
*           /SS/P.SEEK
          SPACE  6
 SEKIX    LJM    **
 SEEKI    EQU    *-1

* CHECK FOR VALID SECTOR ADDRESS.

          LDML   SS+/SS/P.DV,SELIN  GET DEVICE TYPE
          ERRNZ  -16+/SS/L.DV+/SS/N.DV
          LPK    /SS/M.DV
          STDL   T1          DEVICE TYPE
          LDML   SS+/SS/P.SECTOR,SELIN  SECTOR ADDRESS
          LPN    3
          ZJN    SEKI6       IF EVENLY DIVISIBLE BY 4
          LDML   SECSC,T1    SECTOR ADDRESS MUST BE INCREMENTED BY 1
          SBN    1
          PJN    SEKI6       IF NO ERROR IN SEEK ADDRESS

* ERROR IN  SEEK ADDRESS.

          LDC    E408
          RJM    ATERM       ABNORMAL TERMINATION (NO RETURN)
*         (NO RETURN FROM ATERM)

* CHANGE CHANNEL NUMBERS IN I/O INSTRUCTIONS, IF NECESSARY.

 SEKI6    BSS
 X2       IFEQ   MULT,1
          LDML   SS+/SS/P.CHAN,SELIN  GET CHANNEL NUMBER
          SHN    -16+/SS/L.CHAN+/SS/N.CHAN
          LPK    /SS/M.CHAN
          STDL   CHAN        CHANNEL NUMBER
          RJM    CHGCH       CHANGE CHANNEL NUMBERS IF NECESSARY
 X2       ENDIF

* ISSUE SEEK.

          LDML   SS+/SS/P.SEEK,SELIN  CLEAR 'SEEK ISSUED' FLAG
          LPC    -/SS/K.SEEK
          STML   SS+/SS/P.SEEK,SELIN
          RJM    SEEKCK      ISSUE INITIAL SEEK AND RECOVER ERRORS

* SEEK WAS SUCCESSFUL.

          LDK    /SS/K.SEEK  SET 'SEEK ISSUED' FLAG
          RAML   SS+/SS/P.SEEK,SELIN
          LDDL   SELIN       SAVE INDEX OF SEEK ISSUED
          STML   SEKS,SEKCNT
          AODL   SEKCNT      INCREMENT 'SEEK ISSUED' COUNTER

 E101     IFEQ   ATST,1
          AOML   AUTOT       NUMBER OF SEEKS ISSUED
 E101     ENDIF
          UJK    SEKIX
          EJECT
** NAME-- SEEKCK.
*
** PURPOSE-- ISSUE A SEEK AND RECOVER ANY SEEK ERRORS.
          SPACE  6
 SEEX     LJM    **
 SEEKCK   EQU    *-1
          RJM    GENSTAT     RESERVE THE CONTROLLER
          SHN    17-10
          MJN    SCK30       IF MULTI-ACCESS COUPLER NOT CONNECTED

* LOAD CONTROLWARE BEFORE THE FIRST REQUEST WHEN THE DRIVER IS LOADED.

          LDML   ILOAD
          ADML   RECOV       DONT LOAD CONTROLWARE IF IN RECOVERY
          NJN    SCK10       IF CONTROLWARE HAS BEEN LOADED
          RJM    LDCN        LOAD CONTROLWARE
          AOML   ILOAD       SET FLAG FOR INITIAL CONTROLWARE LOAD

* GET UNIT RESERVE.

 SCK10    BSS
          LDN    5           SET TIMEOUT FOR UNIT RESERVE
          STML   CRSV2
 SCK20    BSS
          SOML   CRSV2       DECREMENT UNIT RESERVE TIMEOUT COUNTERS
          ZJN    SCK30       IF TIMED OUT
          RJM    SEEK        ISSUE SEEK
          RJM    GENSTAT     READ GENERAL STATUS
          SHN    17-3
          MJN    SCK20       IF UNIT RESERVED
          RJM    CKSTAT      PROCESS GENERAL STATUS ERRORS
          MJK    SCK20       IF ERROR, RETRY THE SEEK
          RJM    RECRS       SEND ANY RECOVERED ERROR RESPONSES
          UJK    SEEX        IF NO ERROR


* CALL SEEKERR TO RECOVER SEEK ERRORS.

 SCK30    BSS
          LOADOVL RECSO
          LJM    SEEKERR1
          EJECT
** NAME-- SEEKON
*
** PURPOSE-- ISSUE SEEK, CHECK FOR ERRORS, WAIT FOR ON-CYLINDER.
          SPACE  6
 SEKOX    LJM    **
 SEEKON   EQU    *-1
 SEKO10   BSS
          RJM    SEEKCK      ISSUE SEEK AND RECOVER SEEK ERRORS
          LDDL   GNSTAT      GENERAL STATUS
          NJN    SEKO10      IF NOT ON CYLINDER
          UJN    SEKOX
          EJECT
** NAME-- SEEK
*
** PURPOSE-- ISSUES  SEEKS TO DISK UNITS ACCORDING TO UNIT NUMBER,
*            AND DISK ADDRESS CONTAINED IN THE CURRENT SS ENTRY.
*
** INPUT-- SELIN = CURRENT SS ENTRY OFFSET.
*
** OUTPUT-- DISK CHANNEL IS INACTIVE.
*           GENERAL STATUS IS IN GNSTAT.
*
          SPACE  6
 SEEKX    LJM    **
 SEEK     EQU    *-1
 Z1       IFNE   CONTYP,2

* USE SMALL SECTOR SEEK FOR READ FLAW MAPS.

          LDC    7777B
          STML   SEEK14
          LDDL   FNC         GET FUNCTION CODE
          SBN    2
          NJN    SEEK10      IF NOT READ FLAW MAPS
 Z2       IFEQ   HARDW,1
          LDC    6777B
 Z2       ELSE
          LDC    7777B
 Z2       ENDIF
          STML   SEEK14
 SEEK10   BSS

* ASSURE THAT THE SUBSYSTEM COUPLER IS DEDICATED TO THIS PPU.

          LDC    SS+/SS/P.UNIT+1  BASE ADDRESS OF SS + SEEK COMMAND
          ADDL   SELIN       ADD ENTRY OFFSET
          STML   SEEK20      STORE DATA ADDRESS INTO OAM INSTRUCTION
 SEEK12   BSS
          LDN    F.SEEK
          RJM    FUNC        ISSUE THE SEEK
          ACN    DC
          LDML   SS+/SS/P.UNIT,SELIN  ADJUST FIRST PARAMETER OF SEEK COMMAND
          LPC    **
 SEEK14   EQU    *-1
          OAN    DC          SEND LARGE/SMALL SECTOR SEEK PARAMETER
          LDN    3
          ELSE
          LDC    SS+/SS/P.UNIT  BASE ADDRESS OF SS + SEEK COMMAND
          ADDL   SELIN       ADD ENTRY OFFSET
          STML   SEEK20      STORE DATA ADDRESS INTO OAM INSTRUCTION
 SEEK12   BSS
          LDN    F.SEEK
          RJM    FUNC        ISSUE THE SEEK
          ACN    DC
          LDN    4
 Z1       ENDIF
          OAM    **,DC       SEND SEEK FUNCTION PARAMETERS
 SEEK20   EQU    *-1
          FJM    *,DC        WAIT FOR CHANNEL TO BECOME EMPTY
          PSN
          PSN
          DCN    40B+DC      DISCONNECT THE CHANNEL
          CFM    SEEKX,DC    CHECK AND CLEAR CHANNEL ERROR
          RJM    CHERO       RECORD CHANNEL ERROR ON OUTPUT
          UJK    SEEK12      RETRY
          EJECT
** NAME-- UREQ
*
** PURPOSE-- READ A UNIT REQUEST FROM CM.
*
** INPUT-- SELIN = INDEX TO SS TABLE WHICH IDENTIFIES THE UNIT QUEUE.
*
** OUTPUT-- RQ  CONTAINS CURRENT REQUEST.
*           FRST = 0
*           NUMCM = NUMBER OF COMMANDS.
*           DEVICE = DEVICE TYPE.
*
          SPACE  6
 UREQX    LJM    **
 UREQ     EQU    *-1
          LDN    0
          STDL   FRST        SET FLAG WHEN REQUEST IS READ
          LDN    3           NUMBER OF WORDS TO READ
          STDL   WC
          LOADF  SS+/SS/P.REQ,SELIN  LOAD CM ADDRESS AND REFORMAT
          ADN    2
          CRML   RQ+2*4,WC   READ CURRENT REQUEST
                             READ SWITCH FLAG BEFORE READING LINKAGE POINTERS
          SBN    5
          CRML   RQ,WC
          LDML   RQ+/RQ/P.LEN  DETERMINE NUMBER OF COMMANDS
          SHN    -3
          SBN    /RQ/C.CMND
          STDL   NUMCM       NUMBER OF COMMANDS

* GET DEVICE TYPE.

          LDML   SS+/SS/P.DV,SELIN  GET DEVICE TYPE
          ERRNZ  -16+/SS/L.DV+/SS/N.DV
          LPN    /SS/M.DV
          STDL   DEVICE

* PUT REQUEST IN PP COMMUNICATION BUFFER.

          UJK    UREQX
          EJECT
** NAME-- SRESP
*
** PURPOSE-- SET UP STATUS RESPONSE BUFFER.
*
** INPUT-- SELIN = INDEX TO SS TABLE WHICH IDENTIFIES THE REQUEST.
*          RQ HAS THE CURRENT REQUEST.
          SPACE  6
 SREX     LJM    **
 SRESP    EQU    *-1
          LDML   SS+/SS/P.PVA,SELIN  PUT PVA OF REQUEST IN RESPONSE BUFFER
          STML   RS+/RS/P.PVA
          LDML   SS+/SS/P.PVA+1,SELIN
          STML   RS+/RS/P.PVA+1
          LDML   SS+/SS/P.PVA+2,SELIN
          STML   RS+/RS/P.PVA+2
*
          LDML   SS+/SS/P.REQ+1,SELIN
          ADN    /RQ/C.CMND*8  DETERMINE RMA OF COMMAND
          STML   RS+/RS/P.LASTC+1  PUT RMA OF COMMAND IN RESPONSE BUFFER
          SHN    -16
          ADML   SS+/SS/P.REQ,SELIN
          STML   RS+/RS/P.LASTC
          LDN    0
          STML   RS+/RS/P.XFER  TRANSFER COUNT
          STML   RS+/RS/P.XFER+1
          UJK    SREX
          EJECT
** NAME-- FAILAD
*
** PURPOSE-- SET FAILING DISK ADDRESS IN RESPONSE.
          SPACE  6
 FAILX    LJM    **
 FAILAD   EQU    *-1
          LDML   SS+/SS/P.TRACK,SELIN  FAILING TRACK ADDRESS
          STML   RS+/RS/P.FTRK
          LDML   SS+/SS/P.SECTOR,SELIN  FAILING SECTOR
          STML   RS+/RS/P.FSEC
          LDK    C.RS*8
          STML   RS+/RS/P.RESPL  RESPONSE LENGTH
          UJK    FAILX
          EJECT
** NAME-- UNCMND
*
** PURPOSE-- GET NEXT COMMAND.
*
** INPUT-- NUMCM, FRST, RS+/RS/P.LASTC
*
** OUTPUT-- CMLIST, FNC, RQ+/RQ/P.CMND
*           CMLISTL.
*
** EXIT-- A REGISTER = 0, IF NO MORE COMMANDS.
*         A REGISTER .NE. 0, IF NEXT COMMAND PRESENT.
          SPACE  6
 UNCX     LJM    **
 UNCMND   EQU    *-1
          LDDL   NUMCM
          ZJN    UNCX        IF NO MORE COMMANDS, EXIT, A REGISTER = 0
          SODL   NUMCM       DECREMENT COMMAND COUNT
          LDDL   FRST        HAS FIRST COMMAND BEEN PROCESSED
          ZJN    UNC10       IF FIRST COMMAND HASN'T BEEN PROCESSED

*         READ NEXT COMMAND FROM CM.

          LDN    8
          RAML   RS+/RS/P.LASTC+1  INCREMENT RMA ADDRESS OF LAST COMMAND
          SHN    -16
          RAML   RS+/RS/P.LASTC
          LDN    C.CM
          STDL   WC
          LOADF  RS+/RS/P.LASTC  LOAD CM ADDRESS AND REFORMAT
          CRML   CM,WC       READ COMMAND FROM CM
 UNC10    AODL   FRST        SET NONZERO

*         IF INDIRECT ADDRESS, READ CM ADDRESS LIST.

          LDN    0
          STDL   CML         CLEAR INDEX TO CMLIST
          LDN    1
          STDL   CMLISTL     IF NOT INDIRECT, ONLY 1 COMMAND.
          LDML   CM+/CM/P.INDIR
          SHN    /CM/L.INDIR+2
          PJN    UNC20       IF NOT INDIRECT ADDRESS

          LDML   CM+/CM/P.LEN
          SHN    -3
          STDL   CMLISTL     LENGTH OF CM ADDRESS AREA  (CM WORDS)
          RJM    GLIST       GET CM ADDRESS LIST OF DATA AREA

* IF SWITCH FLAG IS SET, EXIT.

 UNC20    BSS

*         SET UP INTERNAL FUNCTION CODE, FNC.

          LDN    0
          STDL   FNC         SET UP INTERNAL FUNCTION CODE
 UNC30    LDML   CM+/CM/P.CODE  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          ERRNZ  /CM/L.CODE
          SBML   UCMD,FNC    COMPARE COMMAND CODE
          ZJN    UNC40       IF COMMAND FOUND
          AODL   FNC
          SBN    UCMDL
          MJN    UNC30       IF MORE COMMANDS TO CHECK
          LDC    E501        ERROR IN COMMAND CODE
          RJM    ATERM       ABNORMAL TERMINATION (NO RETURN)
*         (NO RETURN FROM ATERM)

 UNC40    LDN    1           SET A REGISTER NONZERO FOR EXIT
          UJK    UNCX
          EJECT
** NAME-- GLIST
*
** PURPOSE-- READ THE CM ADDRESS LIST PORTION OF A COMMAND.
*
** INPUT-- CMLISTL
*
** OUTPUT-- CMLIST, CM+/CM/P.RMA
          SPACE  6
 GLIX     LJM    **
 GLIST    EQU    *-1
          LDDL   CMLISTL     NO OF CM WORDS IN ADDRESS-LENGTH-PAIR LIST
          ZJN    GLIX        IF NO WORDS TO READ
          STDL   WC
          LDN    CMLN-4      CHECK IF WORDS LEFT TO READ IS LARGER THAN BUFFER
          SHN    -2          (CM WORDS)
          SBDL   WC
          PJN    GLI10       IF BUFFER CAN CONTAIN ALL THE WORDS
          RADL   WC          READ PARTIAL ADDRESS AREA TO FILL CMLIST BUFFER
 GLI10    LOADF  CM+/CM/P.RMA  LOAD CM ADDRESS AND REFORMAT
          CRML   CMLIST+P.CM,WC
          LDN    P.CM
          STDL   CML         SET INDEX TO CMLIST
          LDDL   WC
          SHN    3           BYTE COUNT
          RAML   CM+/CM/P.RMA+1  UPDATE RMA ADDRESS FOR NEXT READ
          SHN    -16
          RAML   CM+/CM/P.RMA
          UJK    GLIX
          EJECT
** NAME-- FUNC
*
** PURPOSE-- ISSUE FUNCTION TO DISK CONTROLLER.
*
** INPUT-- A REGISTER = FUNCTION CODE.
*
** OUTPUT-- CHANNEL IS INACTIVE.
          SPACE  6
 FUNX     LJM    **
 FUNC     EQU    *-1
 FUN2     BSS
          STDL   FUNCD       SAVE FUNCTION CODE
          AJM    FUN30,DC    IF CHANNEL ACTIVE
          FAN    DC          ISSUE THE FUNCTION
          IFEQ   HARDW,1
          LDK    8           TIMEOUT 1 SECOND ON ALL FUNCTIONS
          STDL   T1
          ELSE
          LDN    1
          STDL   T1
          ENDIF
 FUN8     BSS
          LDC    377777B
 FUN10    IJM    FUNX,DC     EXIT IF CHANNEL INACTIVE

          SBN    1
          NJN    FUN10
          IJM    FUNX,DC     EXIT IF CHANNEL INACTIVE
          SODL   T1          DECREMENT TIMEOUT COUNTER
          NJN    FUN8

*
* DISK CHANNEL ERROR.
*

 FUN30    BSS
 FDCN     DCN    40B+DC      FORCE THE DISCONNECT
          LDML   IGNORE
          NJK    FUNX        IGNORE ERRORS
          RJM    PPREQ       CHECK FOR PP REQUESTS
          LOADOVL RECSO
          LJM    FUNERR      PROCESS FUNCTION TIMEOUT ERROR
          EJECT
** NAME-- GENSTAT
*
** PURPOSE-- READ GENERAL STATUS FROM CONTROLLER.
*
** OUTPUT-- A REGISTER = GENERAL STATUS.
*           GNSTAT = GENERAL STATUS.
*
          SPACE  6
 GENSX    LJM    **
 GENSTAT  EQU    *-1
 E7       IFEQ   ERRTST,1
          LDML   GSTEST
          ZJN    GENS2       IF NOT A DEBUG TEST
          RJM    TESTREC     TEST FOR A RECOVERED DEBUG TEST
          UJN    GENS8
 E7       ENDIF
 GENS2    BSS
          LDN    F.GS        GENERAL STATUS FUNCTION CODE
          RJM    FUNC        ISSUE FUNCTION CODE
          ACN    DC
          LDN    1
          IAM    GNSTAT,DC   INPUT GENERAL STATUS
          NJK    GENS40      IF INPUT DID NOT COMPLETE
          CFM    GENS8,DC    CHECK AND CLEAR CHANNEL ERROR
 GENS5    BSS
          RJM    CHNERR      RECORD CHANNEL ERROR
          UJK    GENS2       RETRY

 GENS8    BSS
          LDDL   GNSTAT      SAVE GENERAL STATUS
          ZJN    GENS10      IF NO ERRORS
          SBN    2           CHECK 'NOT ON CYLINDER'
          NJN    GENS20      IF ERRORS
 GENS10   BSS
          LDML   FUNTO       CHECK IF CALLED FROM FUNC
          NJN    GENS20      IF FUNCTION TIMEOUT, READ DETAILED STATUS
 GENS15   BSS
          LDDL   GNSTAT      A REGISTER = GENERAL STATUS
          UJK    GENSX

 GENS18   BSS
          LDDL   T1
          STML   RS+/RS/P.RESPL  SET TO PREVIOUS RESPONSE LENGTH
          UJK    GENS15

* CHECK STATUS.

 GENS20   BSS
          LDML   RS+/RS/P.RESPL  RESPONSE LENGTH
          STDL   T1
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE

* READ EXTENDED DETAILED STATUS.

          LDML   RS+/RS/P.DET  CHECK IF FIRST TIME FOR DETAILED STATUS
          LPK    /RS/K.CSP
          NJN    GENS30      IF NOT THE FIRST TIME FOR THIS ERROR
          LDK    /RS/K.CSP
          RAML   RS+/RS/P.DET  SET FLAG FOR DETAILED STATUS PRESENT
          LDDL   GNSTAT      PUT GENERAL STATUS IN RESPONSE BUFFER
          STML   RS+/RS/P.GENST1
          LPC    2010B       IF MULTI-ACCESS COUPLER CONNECTED
                             OR IF DSU RESERVED
 GENS25   NJK    GENS18      IF MULTI-ACCESS COUPLER CONNECTED
          LDN    F.EDS       READ EXTENDED DETAILED STATUS
          RJM    FUNC
          LDN    20
          ACN    DC
          IAM    RS+/RS/P.DETAIL,DC  READ EXTENDED DETAILED STATUS
          NJN    GENS40      INPUT DID NOT COMPLETE
          SFM    GENS5,DC     CHECK AND CLEAR CHANNEL ERROR

* IN CASE THIS IS THE LAST TIME THE ERROR IS ENCOUNTERED BEFORE
* IT IS RECOVERED, READ DETAILED STATUS.

 GENS30   BSS
          LDDL   GNSTAT      PUT LAST GENERAL STATUS IN RESPONSE BUFFER
          STML   RS+/RS/P.GENST2
          LPC    2010B       IF MULTI-ACCESS COUPLER CONNECTED
                             OR IF DSU RESERVED
          NJK    GENS25      IF MULTI-ACCESS COUPLER CONNECTED
          LDN    F.EDS       READ EXTENDED DETAILED STATUS
          RJM    FUNC
          LDN    20
          ACN    DC
          IAM    RS+/RS/P.DET2,DC  READ LAST EXTENDED DETAILED STATUS
          NJN    GENS40      IF INPUT DID NOT COMPLETE
          SFM    GENS5,DC    CHECK AND CLEAR CHANNEL ERROR
          UJK    GENS15      IF NOT CHANNEL ERROR

 GENS40   BSS
          STML   RS+/RS/P.FUNTO  NUMBER OF PP WORDS NOT RECEIVED
          LDK    /RS/K.IST   INCOMPLETE SECTOR TRANSFER
          RJM    SERRID      ERROR ID
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    RECS        ABNORMAL TERMINATION
*         (NO RETURN FROM RECS.)
          EJECT
** NAME-- CKSTAT
*
** PURPOSE-- CHECK FOR GENERAL STATUS ERRORS.
*
** INPUT-- GNSTAT.
*        SELIN = INDEX TO SS TABLE.
*
** EXIT-- GNSTAT MUST = 0 OR 2 FOR NO ERROR.
*         A REGISTER = 0, IF NO ERROR, OR NOT ON CYLINDER
*         A REGISTER .LT. 0, IF ERROR RECOVERY SHOULD BE ATTEMPTED.
          SPACE  6
 CKSX     LJM    **
 CKSTAT   EQU    *-1
          LDDL   GNSTAT      GENERAL STATUS
          ZJK    CKSX        IF NO ERRORS, EXIT A REGISTER = 0
          SBN    2
          ZJK    CKSX        IF NOT ON CYLINDER, EXIT A REGISTER = 0

          AODL   ERRCNT      INCREMENT ERROR COUNTER
          SBN    STRY        CHECK IF MAXIMUM TRIES TO RECOVER ERROR
          PJN    CKS30       IF UNRECOVERED ERROR
          AOML   RS+/RS/P.STRY  INCREMENT SECTOR RETRY COUNT
          LCN    1           EXIT, A REGISTER .LT. 0, IF ERROR RECOVERY
                             SHOULD BE ATTEMPTED
          UJK    CKSX

* ERROR.

 CKS30    BSS
          RJM    RECS        ATTEMPT TO RECOVER
*         (NO RETURN FROM RECS.)
          EJECT
** NAME-- TERM.
*
** PURPOSE-- TERMINATE UNIT REQUEST.
*
** OUTPUT-- RS+/RS/P.RC = RESPONSE CODE.
          SPACE  6
 TERM     BSS
          LDDL   SIO         CHECK IF DATA TRANSFER HAS BEEN STARTED
          NJN    TERM8       IF I/O HAS BEEN STARTED ON THIS REQUEST

* UNRECOVERED ERROR DURING SEEK PROCESS.

          RJM    TERMSK      SET UP FOR TERMINATION

* DATA TRANSFER WAS STARTED ON THIS REQUEST.

 TERM8    BSS
          LDDL   FNERR       CHECK FOR FUNCTION TIMEOUT
          NJN    TERM40      IF FUNCTION TIMEOUT ERROR, DO NOT ISSUE
                               ANOTHER FUNCTION
          LDML   CHLOCK
          ZJN    TERM40      IF CHANNEL LOCK IS NOT SET
          LDN    F.OPCMP     ISSUE OPERATION COMPLETE
          RJM    FUNC

 TERM40   BSS
          RJM    PUTRC       PUT RESPONSE CODES IN RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          LDML   NODEL
          NJN    TERM50      IF NO DELINK OF REQUEST
          RJM    DELRQ       DELETE COMPLETED REQUEST FROM QUEUE
                             AND SELECT NEW REQUEST.
 TERM50   BSS
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
          RJM    CFLGS       CLEAR FLAGS
          LDN    0
          STDL   SEKCNT      CLEAR OUTSTANDING SEEK COUNT

* ISSUE NEXT SEEK ON THIS UNIT.

          LDML   SS+/SS/P.CUR,SELIN
          SHN    /SS/L.CUR+2
          PJN    TERM60      IF CURRENT REQUEST HAS NOT BEEN SELECTED
          RJM    ZRESP       ZERO OUT RESPONSE BUFFER
          RJM    SEEKI       ISSUE INITIAL SEEK
          UJK    MAINB       IF SEEK WAS ISSUED

 TERM60   BSS
          LDML   SS+/SS/P.SEEK,SELIN  CLEAR FLAGS
          LPC    -/SS/K.SEEK-/SS/K.CUR
          STML   SS+/SS/P.SEEK,SELIN

          RJM    CLRLOCK     CLEAR LOCK ON UNIT

 TERMB    BSS
          RJM    ZRESP       ZERO OUT RESPONSE BUFFER
          UJK    MAINB
          EJECT
** NAME--  CFLGS
*
** PURPOSE-- CLEAR FLAGS WHEN TERMINATING A REQUEST OR
*            PROCESSING AN IDLE COMMAND.
          SPACE  6
 CFLGX    LJM    **
 CFLGS    EQU    *-1

 E12      IFEQ   ERRTST,1
          LDML   RECOV
          ZJN    CFL10       IF NO RECOVERY WAS DONE
          RJM    TESTEND     TERMINATE THE TEST
 CFL10    BSS
 E12      ENDIF

          LDN    0
          STML   RVCNT       ZERO OUT RECOVERED ERRORS COUNTER
          STML   RQTRY       ZERO OUT REQUEST RETRY COUNTER
          STDL   SIO         START I/O FLAG
          STDL   LDC         LOAD CONTROLWARE COUNTER
          STML   RECOV       INDEX TO RECOVERY PROCEDURE
          STDL   NORQ        NO REQUEST FLAG
          STML   SS+/SS/P.CONF,SELIN  CLEAR FLAG FOR CONFIDENCE TEST
          UJK    CFLGX
          EJECT
** NAME-- PUTRC
*
** PURPOSE-- PUT RESPONSE CODES IN RESPONSE
          SPACE  6
 PUTRCX   LJM    **
 PUTRC    EQU    *-1
          LDDL   RESPC       RESPONSE CODE
          SHN    /RS/L.RCON-/RS/L.RC+/RS/N.RCON-/RS/N.RC
          ADML   RCON        RESPONSE CONDITION
          SHN    /RS/L.URC-/RS/L.RCON+/RS/N.URC-/RS/N.RCON
          ERRNZ  /RS/P.URC-/RS/P.RCON
          ERRNZ  /RS/P.RC-/RS/P.URC
          STML   RS+/RS/P.URC
          UJK    PUTRCX
          EJECT
** NAME-- RESP
*
** PURPOSE-- WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
*
** INPUT-- CM.PIT, CM.RS, LIM, /PIT/IN, /PIT/OUT, RS+/RS/P.RESPL
*
** OUTPUT-- /PIT/IN, RESPONSE BUFFER
          SPACE  6
 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  6
 RESPX    LJM    **
 RESP     EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDN    0
          STML   STORS       SET FLAG TO STORE RESPONSE
          LDML   CM+/CM/P.STOR  CHECK IF CALLER WANTS RESPONSE
          SHN    /CM/L.STOR+2
          MJN    RESP10      IF STORE RESPONSE FLAG IS SET
          LDDL   RESPC       CHECK FOR NORMAL RESPONSE
          SBN    R.NRM
          NJN    RESP10      IF NOT NORMAL RESPONSE, STORE RESPONSE
          AOML   STORS       NONZERO MEANS DO NOT STORE RESPONSE
 RESP5    UJK    RESPX

* READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RESP10   BSS
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF 'IN' POINTER
          CRDL   P1          READ 'IN' POINTER

* CHECK IF A SHORT RESPONSE SHOULD BE SENT.

          LDML   RS+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          ZJK    RESP5       IF RESPONSE LENGTH = 0
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          SBN    1
          ZJN    RESP15      IF A SHORT RESPONSE
          LDN    0           CLEAR FLAG IF NOT SHORT RESPONSE
          UJN    RESP17

 RESP15   BSS
          LDML   RS+/RS/P.LU  PUT LOGICAL UNIT IN SHORT RESPONSE
          LPK    /RS/M.LUN
          ERRNZ  16-/RS/L.LUN-/RS/N.LUN
          ADK    /RS/K.SHORT  SET FLAG FOR SHORT RESPONSE
 RESP17   BSS
          STML   RS+/RS/P.SHORT

* CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDDL   INP
          SBDL   OUTP
          MJN    RESP20      IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP
 RESP20   LDML   RS+/RS/P.RESPL  GET RESPONSE LENGTH
          ADDL   INP
          STDL   INPNT       IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          MJN    RESP30      IF ENOUGH ROOM IN BUFFER
          RJM    PPREQ       CHECK IDLE AND ACTIVE FLAGS
          UJK    RESP10

 RESP30   BSS
          LDN    0
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE
          LDDL   INP
          SHN    -3
          STDL   T3          'IN' POINTER IN WORDS
          LDDL   INPNT
          SBDL   LIM
          MJN    RESP50      IF IN + RESPONSE LENGTH .LT. LIMIT
                             ONLY 1 BLOCK WRITE
          STDL   INPNT       IN + RESPONSE LENGTH - LIMIT = NEW 'IN' POINTER
          SHN    -3
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE

* WRITE RESPONSE TO CM.

          LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADC    RS
          STML   RESP60      RESPONSE ADDRESS FOR 2ND BLOCK WRITE
 RESP50   BSS
          LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD 'IN' OFFSET
          CWML   RS,T4       WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          ZJN    RESP70      IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          LMC    400000B
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
                             (BEGINNING OF RESPONSE BUFFER)
 RESP60   EQU    *-1

 RESP70   BSS
          LJM    RESPX
          EJECT
** NAME-- RESPIN
*
** PURPOSE-- UPDATE THE 'IN' POINTER IN THE CM RESPONSE BUFFER.
*
** INPUT-- INPNT = NEW 'IN' POINTER.
          SPACE  6
 RESNX    LJM    **
 RESPIN   EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDML   STORS       CHECK IF CALLER WANTS RESPONSE
          NJK    RESNX       IF NO RESPONSE WAS SENT

* UPDATE THE 'IN' POINTER.

          LDN    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDDL   INPNT       NEW 'IN' POINTER
          STDL   P4
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   P1          WRITE NEW 'IN' POINTER TO CM

* INTERRUPT PROCESSOR. RESP ROUTINE SETS UP THIS INSTRUCTION.

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   PPNO-3      SET LAST BYTE NONZERO
 INTPRC   INPN   1           INTERRUPT OR PSN
          CRDL   T1          THIS INSTRUCTION IS BECAUSE OF AN 810/830 PROBLEM
          UJK    RESNX
          EJECT
** NAME-- RECRS
*
** PURPOSE-- IF AN ERROR HAS BEEN RECOVERED, SEND AN INTERMEDIATE
*            RESPONSE TO CM.
*
** EXIT-- A REGISTER = 0,    IF RECOVERED ERROR LIMIT HAS NOT BEEN REACHED.
*         A REGISTER .GT. 0, IF RECOVERED ERROR LIMIT HAS BEEN REACHED.
          SPACE  6
 RECRSX   LJM    **
 RECRS    EQU    *-1
          LDDL   ERRCNT      ERROR COUNTER
          ADDL   FNERR       FUNCTION TIMEOUT COUNTER
          ADML   CHERR       CHANNEL ERROR COUNTER
          ZJN    RECRSX      IF NO ERRORS

          LOADOVL RECSO
          LJM    RECRS1
          EJECT
** NAME-- CHNERR
*
** PURPOSE-- RECORD CHANNEL ERROR. ABORT REQUEST IF MAXIMUM RETRIES
**           HAVE BEEN MADE.
          SPACE  6
 CHNRX    LJM    **
 CHNERR   EQU    *-1
          LDK    /RS/K.CHERR  CHANNEL ERROR
          RJM    CHER        RECORD CHANNEL ERROR
          UJK    CHNRX
          EJECT
** NAME-- CHERO
*
** PURPOSE-- RECORD OUTPUT CHANNEL ERROR.
*            ABORT REQUEST IF MAXIMUM RETRIES HAVE BEEN MADE.
          SPACE  6
 CHEROX   LJM    **
 CHERO    EQU    *-1
          LDK    /RS/K.CHERO  OUTPUT CHANNEL ERROR
          RJM    CHER        RECORD CHANNEL ERROR
          UJK    CHEROX
          EJECT
** NAME-- CHER
          SPACE  6
 CHERX    LJM    **
 CHER     EQU    *-1
          RJM    SERR        ERROR ID
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
 E3       IFEQ   ERRTST,1
          RJM    TESTREC     TERMINATE RECOVERED ERROR TEST
 E3       ENDIF
          AOML   CHERR       INCREMENT CHANNEL ERROR RETRY COUNTER
          SBN    CTRY        HAVE MAXIMUM TRIES BEEN ATTEMPTED
          PJN    CHER10      IF MAXIMUM TRIES HAVE BEEN ATTEMPTED
          AOML   RS+/RS/P.STRY  INCREMENT RETRY COUNT
          UJK    CHERX

 CHER10   BSS
          RJM    RECS        ATTEMPT TO RECOVER
*         (NO RETURN FROM RECS.)
          EJECT
 SERRX    LJM    **
 SERR     EQU    *-1         SAVE ERROR ID
          STDL   T1
          LMC    -0
          STDL   T2
          LDML   RS+/RS/P.CHERR  ERROR ID
          LPDL   T2
          ADDL   T1          ADD ERROR FLAG
          STML   RS+/RS/P.CHERR
          UJK    SERRX
          EJECT
 SERRIX   LJM    **
 SERRID   EQU    *-1         SAVE ERROR ID
          STDL   T1
          LMC    -0
          STDL   T2
          LDML   RS+/RS/P.ERRID  ERROR ID
          LPDL   T2
          ADDL   T1          ADD ERROR FLAG
          STML   RS+/RS/P.ERRID
          UJK    SERRIX
          EJECT
 SIDX     LJM    **
 SID      EQU    *-1         SAVE ERROR ID
          STDL   T1
          LMC    -0
          STDL   T2
          LDML   RS+/RS/P.ID  ERROR ID
          LPDL   T2
          ADDL   T1          ADD ERROR FLAG
          STML   RS+/RS/P.ID
          UJK    SIDX
          EJECT
** NAME-- ZRESP
*
** PURPOSE-- ZERO OUT PART OF THE RESPONSE BUFFER.
*
** NOTE-- THIS ROUTINE IS ALSO CALLED FOR RECOVERED ERROR RESPONSES.
          SPACE  6
 ZREX     LJM    **
 ZRESP    EQU    *-1
          LDN    0
          STDL   ERRCNT      ZERO OUT ERROR COUNTER
          STDL   FNERR       ZERO OUT FUNCTION TIMEOUT COUNTER
          STML   RCON        RESPONSE CONDITION
          STML   CHERR       CHANNEL ERROR COUNTER
          STML   SECTRY      SECTOR RETRY COUNTER
          STML   NODEL       DON'T DELINK REQUEST FLAG
          STML   RS+/RS/P.HDWR  ABNORMAL STATUS
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE

          LDK    C.RS-/RS/C.FTRK
          STDL   WC
          LOADC  CM.CB       ADDRESS OF COMMUNICATION BUFFER
          ADK    /CB/C.ZERO
          CRML   RS+/RS/P.FTRK,WC  ZERO OUT PART OF RESPONSE BUFFER

          LDN    8           SET RESPONSE LENGTH FOR NORMAL RESPONSE
          STML   RS+/RS/P.RESPL
          LDN    R.NRM       SET RESPONSE CODE = NORMAL
          STDL   RESPC
          SHN    16-/RS/N.RC-/RS/L.RC
          STML   RS+/RS/P.RC  PUT REPONSE CODE IN RESPONSE
          UJK    ZREX
          EJECT
** NAME-- SETRQ
*
** PURPOSE-- SET UP FOR FIRST REQUEST.
          SPACE  6
 SETRQX   LJM    **
 SETRQ    EQU    *-1
          LDML   SS+/SS/P.REQ,SELIN  SAVE RMA OF REQUEST
          STML   FCOMRQ      FIRST COMPLETED REQUEST (RMA)
          STML   CURRQ       CURRENT REQUEST (RMA)
          LDML   SS+/SS/P.REQ+1,SELIN
          STML   FCOMRQ+1
          STML   CURRQ+1
          LDN    1
          STDL   NCOMRQ      NUMBER OF COMPLETED REQUESTS
          RJM    SETADD      PUT STARTING ADDRESS IN RESPONSE BUFFER

* SET UP INTERRUPT PROCESSOR INSTRUCTION IF INTERRUPT IS SELECTED.

          LDML   RQ+/RQ/P.INT  CHECK IF INTERRUPT WAS SELECTED
          SHN    /RQ/L.INT+2
          MJN    SETR10      IF INTERRUPT SELECTED
          LDC    2400B       PSN INSTRUCTION
          UJN    SETR20

 SETR10   BSS
          LDML   RQ+/RQ/P.PORT  GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RQ/L.PORT+/RQ/N.PORT
          LPN    /RQ/M.PORT
          ADC    102600B     INPN INSTRUCTION
 SETR20   BSS
          STML   INTPRC
          UJK    SETRQX
          EJECT
** NAME-- SETADD
*
** PURPOSE-- SET STARTING DISK ADDRESS IN RESPONSE BUFFER.
          SPACE  6
 SETADDX  LJM    **
 SETADD   EQU    *-1
          LDML   SS+/SS/P.LU,SELIN  PUT LOGICAL UNIT IN RESPONSE
          STML   RS+/RS/P.LU
*
          LDDL   CHAN        CHANNEL NUMBER
          STML   RS+/RS/P.CHAN
          LDML   SS+/SS/P.UNIT,SELIN  UNIT NUMBER
          LPN    /SS/M.UNIT
          STML   RS+/RS/P.UNIT

* PUT STARTING ADDRESS IN RESPONSE BUFFER.

          LDML   SS+/SS/P.CYL,SELIN  STARTING CYLINDER ADDRESS
          STML   RS+/RS/P.SCYL
          LDML   SS+/SS/P.TRACK,SELIN  TRACK
          STML   RS+/RS/P.STRK
          LDML   SS+/SS/P.SECTOR,SELIN  SECTOR
          STML   RS+/RS/P.SSEC

* PUT REQUEST RETRY COUNT IN RESPONSE BUFFER.

          LDML   RQTRY       REQUEST RETRY COUNT
          STML   RS+/RS/P.RTRY
          UJK    SETADDX
          EJECT
** NAME-- DELRQ.
*
** PURPOSE-- DELETE COMPLETED REQUEST FROM THE UNIT QUEUE.
*            SELECT A NEW CURRENT REQUEST BASED UPON CYLINDER ADDRESS.
*
** INPUTS-- SS+P.UQT,SELIN = POINTER TO UNIT QUEUE TABLE
*           RQ = COMPLETED REQUEST.
*
** OUTPUTS-- RQ = SELECTED REQUEST
*            SS+/SS/P.REQ
*            SS+/SS/P.CYL
*            SS+/SS/P.TRACK
*            SS+/SS/P.SECTOR
*            SS+/SS/M.CUR
*            SS+/SS/M.WRITE
*            /UIT/NEXT
*            /UIT/NEXTPV
*            /RQ/NEXT
*            /RQ/NEXTPV
*
** NOTE-- ASSUMES UNIT QUEUE LOCK HAS BEEN SET.
          SPACE  6
 DELX     LJM    **
 DELRQ    EQU    *-1

 DEL10    BSS
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    DEL10       IF LOCK COULD NOT BE SET

* DECREMENT QUEUE COUNTER.

          LOADR  SS+/SS/P.UQT,SELIN  LOAD CM ADDRESS OF UNIT QUEUE TABLE
          STDL   T1
          CRDL   P1          READ QUEUE COUNT
          ERRNZ  /UIT/C.QCNT
          LDDL   P1+/UIT/P.QCNT  DECREMENT QUEUE COUNT
          SBDL   NCOMRQ      NUMBER OF COMPLETED REQUESTS
          STDL   P1+/UIT/P.QCNT
          MJN    DEL20       IF INVALID QUEUE COUNT
          LDDL   T1
          LMC    400000B
          CWDL   P1          WRITE QUEUE COUNT

* RE-READ RMA CHAIN POINTERS OF CURRENT REQUEST.

 DEL20    BSS
          LDN    2
          STDL   P3
          LOADF  CURRQ       RMA OF CURRENT REQUEST
          CRML   RQ,P3       READ RMA CHAIN OF CURRENT REQUEST

* DELINK REQUEST.
* (P3 = 2.)

 DEL30    BSS
          LOADF  SS+/SS/P.QP,SELIN  CM ADDRESS OF LAST LINK ON QUEUE
          STDL   P2          SAVE CM ADDRESS
          ADN    1
          CRDL   T1          READ NEXT REQUEST POINTER
          ERRNZ  /RQ/C.NEXTPV
          ERRNZ  /RQ/C.NEXT-1
          ERRNZ  /UIT/C.NEXT-/UIT/C.NEXTPV-1

* CHECK IF NEXT REQUEST IN CHAIN = COMPLETED REQUEST.

          LDDL   T4
          SBML   FCOMRQ+1    IS NEXT REQUEST IN CHAIN = COMPLETED REQUEST
          NJN    DEL40       IF NEXT REQUEST IN CHAIN IS NOT COMPLETED REQUEST
          LDDL   T3
          SBML   FCOMRQ
          ZJN    DEL50       IF LINK FOUND TO COMPLETED REQUEST
 DEL40    BSS
          LDDL   T3          UPDATE CURRENT QUEUE POINTER
          STML   SS+/SS/P.QP,SELIN
          LDDL   T4
          STML   SS+/SS/P.QP+1,SELIN
          UJK    DEL30

* DELINK COMPLETED REQUESTS.
* (P3 = 2.)

 DEL50    BSS
          LDDL   P2          CM ADDRESS OF REQUEST
          ERRNZ  /RQ/C.NEXTPV
          LMC    400000B
          CWML   RQ,P3       PVA AND RMA OF NEXT REQUEST IN CHAIN

* CLEAR FLAGS IN SS ENTRY.

          LDML   SS+/SS/P.SEEK,SELIN  CLEAR 'SEEK ISSUED',
                             'WRITE REQUEST', 'CURRENT REQUEST'
          LPC    -/SS/K.SEEK-/SS/K.WRITE-/SS/K.CUR
          STML   SS+/SS/P.SEEK,SELIN
          ERRNZ  /SS/L.SEEK-11
          ERRNZ  /SS/L.WRITE-12
          ERRNZ  /SS/L.CUR-13
          LDN    0
          STDL   NCOMRQ      CLEAR COMPLETED REQUEST COUNT

* SELECT NEXT REQUEST ON QUEUE.

          LDML   RQ+/RQ/P.NEXT  CHECK IF END OF QUEUE
          ADML   RQ+/RQ/P.NEXT+1
          NJN    DEL60       IF NEXT REQUEST EXISTS
          LDDL   P4          QUEUE COUNT
          ZJN    DEL60       IF QUEUE EMPTY
          RJM    SELRQ       SELECT FIRST REQUEST IN QUEUE
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          UJK    DELX

 DEL60    BSS
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          LDML   RQ+/RQ/P.NEXTPV  SAVE PVA OF NEXT REQUEST
          STML   SS+/SS/P.PVA,SELIN
          LDML   RQ+/RQ/P.NEXTPV+1
          STML   SS+/SS/P.PVA+1,SELIN
          LDML   RQ+/RQ/P.NEXTPV+2
          STML   SS+/SS/P.PVA+2,SELIN
          LDML   RQ+/RQ/P.NEXT
          STML   SS+/SS/P.REQ,SELIN  SAVE RMA ADDRESS OF NEXT REQUEST
          LDML   RQ+/RQ/P.NEXT+1
          STML   SS+/SS/P.REQ+1,SELIN
          ADML   SS+/SS/P.REQ,SELIN
          ZJN    DEL70       IF QUEUE EMPTY

* SET CURRENT REQUEST IN SS TO SELECTED REQUEST.

          RJM    UREQ        READ SELECTED REQUEST INTO RQ
          LDML   RQ+/RQ/P.CYL
          STML   SS+/SS/P.CYL,SELIN CYLINDER ADDRESS OF CURRENT REQUEST
          LDML   RQ+/RQ/P.TRACK
          STML   SS+/SS/P.TRACK,SELIN  TRACK ADDRESS
          LDML   RQ+/RQ/P.SECTOR
          STML   SS+/SS/P.SECTOR,SELIN  SECTOR ADDRESS

* SET /SS/M.WRITE FOR ALL WRITE OPERATIONS.

          LDML   CM+/CM/P.CODE  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          ERRNZ  /CM/L.CODE
          ADC    -C.WRITE
          NJN    DEL65       IF COMMAND CODE .NE. WRITE
          LDK    /SS/K.WRITE+/SS/K.CUR  SET 'WRITE' FLAG
                             AND 'CURRENT REQUEST' FLAG
          UJN    DEL67

 DEL65    BSS
          LDK    /SS/K.CUR   SET 'CURRENT REQUEST' FLAG
 DEL67    RAML   SS+/SS/P.CUR,SELIN
 DEL70    BSS
          UJK    DELX
          EJECT
** NAME-- GETSS
*
** PURPOSE-- READ SS ENTRY FROM UNIT COMMUNICATION BUFFER IN
*            CM UNIT INTERFACE TABLE.
*
** INPUT-- SELIN, /SS/P.COM.
*
          SPACE  6
 GETSSX   LJM    **
 GETSS    EQU    *-1
          LDC    SS+/SS/P.ENTRY  ADDRESS OF SS ENTRY
          ADDL   SELIN
          STML   GETSS10
          LDN    C.SS        NUMBER OF WORDS TO READ
          STDL   WC
          LOADR  SS+/SS/P.COM,SELIN  ADDRESS OF COMMUNICATION BUFFER
          CRML   **,WC       READ SS ENTRY
 GETSS10  EQU    *-1
          UJK    GETSSX
          EJECT
** NAME-- SETLOCK
*
** PURPOSE-- SETS THE UNIT LOCK IN THE UNIT INTERFACE TABLE.
*
** INPUT-- SELIN = INDEX TO SS TABLE WHICH IDENTIFIES THE UNIT TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SETLX    LJM    **
 SETLOCK  EQU    *-1
          LDC    SS+/SS/P.UQT  UNIT INTERFACE TABLE ADDRESS
          ADDL   SELIN
          STDL   T7
          LDN    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJK    SETLX       IF LOCK COULD NOT BE SET
          RJM    GETSS       READ SS ENTRY FROM UNIT COMMUNICATION BUFFER
          LDML   SS+/SS/P.ENTRY,SELIN  CLEAR 'ENTRY PRESENT' FLAG
          LPC    -/SS/K.ENTRY
          ADK    /SS/K.ENTRY
          STML   SS+/SS/P.ENTRY,SELIN
          RJM    SCLOCK      SET CHANNEL LOCK
          ZJK    SETLX       IF CHANNEL LOCK WAS SET
          RJM    CLRLOCK     CLEAR UNIT LOCK
          LDN    1           LOCK COULD NOT BE SET
          UJK    SETLX
          EJECT
** NAME-- SQLOCK
*
** PURPOSE-- SETS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
*
** INPUT-- SELIN = INDEX TO SS TABLE WHICH IDENTIFIES THE UNIT TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SQLX     LJM    **
 SQLOCK   EQU    *-1
          LDC    SS+/SS/P.UQT  UNIT INTERFACE TABLE ADDRESS
          ADDL   SELIN
          STDL   T7
          LDN    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          UJK    SQLX
          EJECT
** NAME-- LOCK
*
** PURPOSE-- SET A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS SET.
*         A REGISTER .NE. O, IF THE LOCK COULD NOT BE SET.
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T1 = 0, WRITE THE PP LOCKWORD TO CENTRAL MEMORY,
*            AS DESCRIBED IN THIS STEP.  ELSE IF T1 .NE. 0, GO TO
*            STEP 4.
*            TO WRITE THE PP LOCKWORD ID:
*            SET T1 - T4 = 8000 0000 0000 PPNO, WHERE PPNO IS THE
*            LOGICAL PP NUMBER OF THIS PP.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
*
*         4. IF T1 = 8000 AND T4 = PPNO, THIS LOCKWORD WAS ALREADY
*            RESERVED TO THIS PP.
*            RESTORE THE CENTRAL MEMORY LOCATION  (CWDL   T1).
*            SET THE A REGISTER = 0, AND EXIT.
*
*         5. IF T4 .NE. PPNO, THEN THIS LOCKWORD IS RESERVED TO
*            A DIFFERENT PROCESSOR.
*            SET BIT 16 OF THE LOCKWORD THAT WAS READ WITH THE
*            RDSL INSTRUCTION, AND WRITE THE CONTENTS BACK TO
*            CENTRAL MEMORY.
*            THE PURPOSE OF SETTING BIT 16 IS TO REQUEST THE
*            OTHER PROCESSOR TO GIVE UP THE LOCKWORD.
*            LDDL   T2
*            LPC    77777B
*            ADC    100000B
*            STDL   T2
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
          SPACE  6
 LOCKX    LJM    **
 LOCK     EQU    *-1

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 LOCK10   BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.

          LDDL   T1
          ADDL   T4
          ZJN    LOCK40      IF LOCK CAN BE SET

* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJK    LOCK10      IF SOMEONE ELSE WAS FIRST TO WRITE
                             THE INTERMEDIATE VALUE

* SET BIT 16 IN THE ORIGINAL CONTENTS OF CENTRAL MEMORY AND
* WRITE IT BACK TO CENTRAL MEMORY.

          LDDL   T2          SET THE 'REQUEST LOCKWORD' FLAG
          LPC    77777B
          ADC    100000B
          STDL   T2

 LOCK20   BSS
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE LOCKWORD

          LDDL   T4
          SBDL   PPNO        CHECK IF LOCK ALREADY SET
          NJN    LOCK30      IF LOCK COULD NOT BE SET, EXIT A .NE. 0
          LDDL   T1
          ADC    -100000B
 LOCK30   UJK    LOCKX       IF LOCK WAS ALREADY SET, EXIT A = 0
                             IF LOCK COULD NOT BE SET, EXIT A .NE. 0

* SET THE LOCKWORD.

 LOCK40   BSS
          LDC    100000B
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          LDDL   PPNO
          STDL   T4
          UJK    LOCK20



          EJECT
** NAME-- CLRLOCK
*
** PURPOSE-- CLEARS UNIT LOCK IN UNIT INTERFACE TABLE.
*
** INPUT-- SELIN = INDEX TO SS TABLE WHICH IDENTIFIES THE UNIT TABLE.
*          /SS/P.COM, /SS/P.UQT.
          SPACE  6
 CLRLX    LJM    **
 CLRLOCK  EQU    *-1
          LDML   SS+/SS/P.ENTRY,SELIN  CLEAR 'ENTRY PRESENT' FLAG
          LPC    -/SS/K.ENTRY
          STML   SS+/SS/P.ENTRY,SELIN
          RJM    SAVSS       WRITE SS ENTRY TO COMMUNICATION BUFFER
                               IN UNIT INTERFACE TABLE
          LDC    SS+/SS/P.UQT  UNIT INTERFACE TABLE ADDRESS
          ADDL   SELIN
          STDL   T7
          LDN    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR UNIT LOCKWORD
          UJK    CLRLX
          EJECT
** NAME-- SAVSS
*
** PURPOSE-- WRITE THE SS ENTRY TO THE COMMUNICATION BUFFER
*            IN THE UNIT INTERFACE TABLE.
*
** INPUT-- SELIN = INDEX TO SS TABLE WHICH IDENTIFIES THE UNIT TABLE.
          SPACE  6
 SAVX     LJM    **
 SAVSS    EQU    *-1

* WRITE SS ENTRY TO COMMUNICATION BUFFER IN UNIT INTERFACE TABLE.

          LDC    SS+/SS/P.ENTRY  ADDRESS OF SS ENTRY
          ADDL   SELIN
          STML   SAV10
          LDN    C.SS        NUMBER OF WORDS TO WRITE
          STDL   WC
          LOADR  SS+/SS/P.COM,SELIN  ADDRESS OF COMMUNICATION BUFFER
          CWML   **,WC       WRITE SS ENTRY
 SAV10    EQU    *-1
          UJK    SAVX
          EJECT
** NAME-- CQLOCK
*
** PURPOSE-- CLEARS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
*
** INPUT-- SELIN = INDEX TO SS TABLE WHICH IDENTIFIES THE UNIT TABLE.
*          /SS/P.COM, /SS/P.UQT.
          SPACE  6
 CQLX     LJM    **
 CQLOCK   EQU    *-1
          LDC    SS+/SS/P.UQT  UNIT INTERFACE TABLE ADDRESS
          ADDL   SELIN
          STDL   T7
          LDN    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CQLX
          EJECT
** NAME-- CLOCK
*
** PURPOSE-- CLEAR A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS CLEARED.
*         A REGISTER .NE. O, IF THE LOCK WAS NOT CLEARED.
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T4 .NE. PPNO, THIS LOCKWORD IS RESERVED TO A
*            DIFFERENT PROCESSOR.
*            RESTORE THE CONTENTS OF THIS CENTRAL MEMORY LOCATION
*            AS IT EXISTED BEFORE THE VALUE FFFF FFFF XXXX XXXX
*            WAS WRITTEN.
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
*
*         4. IF T4 = PPNO, THEN CLEAR THE LOCKWORD IN CENTRAL MEMORY.
*            SET T1 - T4 = 0000 0000 0000 0000.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
          SPACE  6
 CLKX     LJM    **
 CLOCK    EQU    *-1

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 CLK10    BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.
* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJK    CLK10       IF SOMEONE ELSE WAS FIRST TO WRITE
                             THE INTERMEDIATE VALUE

          LDDL   T4          CHECK PP NUMBER
          SBDL   PPNO
          NJN    CLK20       IF THIS PP DOES NOT HAVE THE LOCK SET,
                             RESTORE THE ORIGINAL CONTENTS.

* CLEAR THE LOCKWORD.

          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4

* WRITE THE LOCKWORD.

 CLK20    BSS
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE ORIGINAL CONTENTS
          LDDL   T1
          UJK    CLKX        EXIT, A REGISTER NONZERO IF THE LOCK IS NOT CLEAR.
                             A REGISTER = 0 IF THE LOCK WAS CLEARED OR WAS
                             ALREADY CLEAR WHEN THIS ROUTINE WAS ENTERED.
          EJECT
** NAME-- CKCHAN
*
** PURPOSE-- CHECK IF MAINTENANCE PP WANTS THE CHANNEL.
          SPACE  6
 CKCX     LJM    **
 CKCHAN   EQU    *-1
          LDN    C.CHCNT     NUMBER OF REQUESTS TO PROCESS BEFORE
                             GIVING UP THE CHANNEL
          STML   CHLCNT
          LDML   CHLOCK
          ZJK    CKCX        IF CHANNEL LOCK IS NOT SET
          LOADC  CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          ADDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          CRDL   T1          READ CHANNEL LOCKWORD
          LDDL   T2
          SHN    17-0
          PJK    CKCX        IF MAINTENANCE PP DOES NOT WANT THE CHANNEL
          LOADOVL PPREQO
          LJM    CKC10
          EJECT
** NAME-- DROPS
*
** PURPOSE-- ISSUE DROP SEEKS COMMAND.
*
** INPUT-- SELECT = INDEX TO SELECTED SS ENTRY.
          SPACE  6
 DROX     LJM    **
 DROPS    EQU    *-1

* ISSUE DROP SEEKS COMMAND TO THE CONTROLLER.

          LDML   CHLOCK
          ZJN    DROX        IF CHANNEL LOCK IS NOT SET,
                             THEN THERE CANNOT BE ANY UNITS LOCKED
          LDDL   SEKCNT
          STDL   P6
          ZJN    DROX        IF NO OUTSTANDING SEEKS
          LDN    F.DRPSK     ISSUE DROP SEEKS FUNCTION
          RJM    FUNC

* FIND ALL UNITS IN WHICH A SEEK WAS ISSUED.
* SAVE SS ENTRY AND CLEAR LOCK.

 DRO10    BSS
          LDML   SEKS-1,P6   INDEX OF SEEKS ISSUED
          STDL   SELIN
          SBDL   SELECT
          ZJN    DRO20       IF SELECTED UNIT
          LDML   SS+/SS/P.ENTRY,SELIN
          SHN    /SS/L.ENTRY+2
          PJN    DRO20       IF ENTRY IS NOT PRESENT
          RJM    CLRLOCK     CLEAR UNIT LOCK
          SODL   SEKCNT
 DRO20    BSS
          SODL   P6          DECREMENT INDEX
          NJK    DRO10       IF NOT END OF TABLE
          LDDL   SELECT      PUT SELECTED UNIT AS FIRST ENTRY IN SEKS
          STML   SEKS
          UJK    DROX
          EJECT
** NAME-- FORMA
*
** PURPOSE-- FORMAT A CM REAL MEMORY ADDRESS.
*
** CALLING SEQUENCE-- LDC    ADDRESS
*                     RJM    FORMA
*
** INPUT-- - A REGISTER- IS THE ADDRESS OF A 2-WORD CM BYTE ADDRESS.
*
** OUTPUT-- -CMADR- IS THE ADDRESS OF THE RESULTING 3-WORD REFORMATED
*                CM ADDRESS.  THE FORMAT CAN BE USED BY THE LOADC MACRO.
*           -ADDRESS-, WORD 0, BITS 0-13 AND
*                      WORD 1, BITS 3-15, ARE REFORMATTED TO-
*           -CMADR-,   WORD 0, BITS 0-9,
*                      WORD 1, BITS 0-11,
*                      WORD 2, BITS 0-5.
*
          SPACE  6
 FORX     LJM    **
 FORMA    EQU    *-1
          STDL   T1

* REFORMAT CM ADDRESS.

          LDML   1,T1
          LPN    7
          ZJN    FOR10       IF VALID RMA ADDRESS
          RJM    HALT        INVALID RMA ADDRESS
*         (NO RETURN FROM HALT.)

 FOR10    BSS
          LDIL   T1
          LPN    37B
          SHN    16
          LMML   1,T1
          SHN    9
          STD    CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   T1
          SHN    -5
          STD    CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMC    400000B
          UJK    FORX
          EJECT
** NAME-- PAUS
*
** PURPOSE-- DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*            MICROSECONDS.
*
** INPUT-- A REGISTER (BITS 00-06) SPECIFIES NUMBER OF MICROSECONDS
*          TO BE DELAYED.
*
** NOTE-- THIS IS SET UP FOR 2X PP TIMING ON AN S1.
          SPACE  6
 PAUSX    LJM    **
 PAUS     EQU    *-1
          IFEQ   HARDW,1
 PAUS10   SBN    1           EACH ITERATION OF THIS SBN-NJN LOOP
          NJN    PAUS10      UTILIZES 1 MICROSECOND
          ENDIF
          UJK    PAUSX
          EJECT
          IFEQ   DUMP,1
 DUMPC    BSS
 DMP10    BSS
          LDN    61B         AUTODUMP FUNCTION
          IJM    DMP20,DC
 DMP15    DCN    40B+DC
          PSN
          UJK    DMP10

 DMP20    BSS
          FAN    DC
          LDC    177777B
 DMP30    IJM    DMP40,DC
          SBN    1
          NJN    DMP30
          UJK    DMP15

DMP40     BSS
          ACN    DC
          LDC    7765B
          LJM    RCDUMP
          ENDIF
          EJECT
          IFEQ   PAT,1
 PATX     LJM    **
 PATCH    EQU    *-1
          LDN    1
          STDL   WC
          LOADC  CM.PIT
          ADN    /PIT/C.UAM
          CRML   PCM,WC
          LDML   PCM+2
          ADML   PCM+3
          ZJN    PATX
          LOADF  PCM+2
          CRDL   P1
          LDN    0
          STDL   P5
          LJM    PAT29

 PAT20    LDML   P1,P5
          ADC    -177777B    END OF PATCHES
          NJN    PAT28
          LDN    0
          STML   PCM+2
          STML   PCM+3
          LDN    1
          STDL   WC
          LOADC  CM.PIT
          ADN    /PIT/C.UAM
          CWML   PCM,WC
          UJK    PATX

 PAT28    BSS
          ADC    -170000B+177777B  END OF CONTENTS
          NJN    PAT30
 PAT27    BSS
          RJM    PBUMP
 PAT29    BSS
          LDML   P1,P5
          STDL   PAD
          ADC    -170000B
          ZJN    PAT27
          RJM    PBUMP
          UJK    PAT20

 PAT30    LDML   P1,P5
          STIL   PAD
          AODL   PAD
          RJM    PBUMP
          UJK    PAT20

 PBUX     LJM    **
 PBUMP    EQU    *-1
          AODL   P5
          SBN    4
          MJN    PBUX
          LDN    8
          RAML   PCM+3
          SHN    -16
          RAML   PCM+2
          LOADF  PCM+2
          CRDL   P1
          LDN    0
          STDL   P5
          UJK    PBUX

 PCM      BSSZ   4
 PAD      EQU    P6          PP ADDRESS TO PATCH
          ENDIF
          EJECT
          QUAL   *
 Q113     IFEQ   ATST,1
 AUTOT    BSSZ   1           INCREMENTED FOR EACH SEEK ISSUED
 Q113     ENDIF
 GSTEST   BSSZ   1           GENERAL STATUS TEST
 ICSTEST  BSSZ   1           INCOMPLETE SECTOR TEST
 TESTPAR  BSSZ   1           TEST PARAMETER
 CHTEST   BSSZ   1           CHANNEL PARITY TEST
 CTPAR    BSSZ   1           CONFIDENCE TEST CODES
 CITEST   BSSZ   1           CONFIDENCE TEST INCOMPLETE SECTOR
          QUAL   RES
          SPACE  10
 FORCX    LJM    **
 FORC     EQU    *-1
          LDN    F.ERROR     FORCE ERROR FUNCTION
          RJM    FUNC
          ACN    DC
          LDDL   P1          PARAMETER
          OAN    DC
          FJM    *,DC
          LDI    P5          TIME DELAY
          DCN    40B+DC
          RJM    GENSTAT
          UJK    FORCX
          SPACE  10
 TESTEX   LJM    **          TERMINATE THE TEST
 TESTEND  EQU    *-1
          LDN    0
          STML   GSTEST
          STML   ICSTEST
          STML   CHTEST
          STML   CTPAR
          UJK    TESTEX
          SPACE  10
 TESTRX   LJM    **          END THE RECOVERED ERROR TESTS
 TESTREC  EQU    *-1
          LDML   TESTPAR
          SBN    5
          ZJN    TESTR10     IF RECOVERED CONTROLLER RESERVED TEST
          SBN    7-5
          ZJN    TESTR10     IF RECOVERED UNIT RESERVED TEST
          SBN    9-7
          ZJN    TESTR10     IF RECOVERED INCOMPLETE SECTOR TRANSFER
          SBN    12-9
          NJK    TESTRX
 TESTR10  BSS
          RJM    TESTEND     TERMINATE THE TEST
          UJK    TESTRX
 Q11      ENDIF
          EJECT

 CONCH    BSS                DISK CHANNEL REFERENCES
 TDC+40B  HERE
 T40B+DC  HERE
 TDC      HERE
          CON    0           END OF TABLE
          QUAL   *
          EJECT
          IFNE   CHANTYP,1
 BUFF     EQU    7777B-SBYTE8  SECTOR DATA BUFFER
          ELSE
 BUFF     EQU    17777B-SBYTE8  SECTOR DATA BUFFER
          ENDIF
 CBUF     EQU    BUFF        START OF CM DATA IN SECTOR BUFFER
          SPACE  6
 IDLE     BSSZ   1           NONZERO IF IDLE COMMAND RECEIVED,
                               RESUME COMMAND RESETS IT TO 0
 IALF     BSSZ   1           BIT 0 = 1, IF THE CONFIDENCE TEST HAS BEEN STARTED
                             ON ALL UNITS
 CTESTU   BSSZ   1           UNIT INDEX FOR THE CONFIDENCE TEST
 CKDATA   BSSZ   1           CONFIDENCE TEST COMPARE DATA FLAG
 SAVE     BSSZ   1           SAVE THE SELIN VALUE
 DEBUG1   BSSZ   1           DEBUG PURPOSES ONLY
 NSEC     BSSZ   1           NUMBER OF SECTORS TO TRANSFER
 NTRANS   BSSZ   1           NUMBER OF SECTORS TRANSFERRED
 SNTRANS  BSSZ   1           STARTING VALUE OF NTRANS
 STV      BSSZ   1           INDEX TO TABLE OF DATA PATTERNS FOR THE
                             CONFIDENCE TEST
 NMED     BSSZ   1           NUMBER OF MEDIA ERRORS IN CONFIDENCE TEST
 NMEDL    EQU    3           NUMBER OF ACCEPTED MEDIA ERRORS IN CONFIDENCE CYLINDER
 MEDERR   BSSZ   NMEDL+1     NTRANS VALUES OF MEDIA ERRORS
 CPERR    BSSZ   1           NONZERO IF THERE WAS A COMPARE ERROR IN
                             THE CONFIDENCE TEST
 NCPERR   BSSZ   1           NUMBER OF SECTORS SUCCESSFULLY COMPARED
 STORS    BSSZ   1           STORE RESPONSE FLAG (USED BY RESPIN)
                               = 0, IF A RESPONSE IS SENT TO CM
                               = NONZERO, IF NO RESPONSE WAS SENT TO CM
 RVCNT    BSSZ   1           COUNT OF RECOVERED ERRORS PER REQUEST
 RQTRY    BSSZ   1           COUNT OF RETRIES OF REQUEST
 FCOMRQ   BSSZ   2           FIRST COMPLETED REQUEST (RMA)
 CURRQ    BSSZ   2           RMA OF CURRENT REQUEST
 PRERQ    BSSZ   2           RMA OF PREVIOUS REQUEST
 RCON     BSSZ   1           ADDITIONAL RESPONSE CONDITION
 CHERR    BSSZ   1           CHANNEL ERROR COUNTER
          IFEQ   ICHK,1
 INITL    BSSZ   1           SET NONZERO DURING INITIALIZATION
          ENDIF
 SECTRY   BSSZ   1           SECTOR RETRY COUNTER
 NODEL    BSSZ   1           DON'T DELINK REQUEST FLAG
 CHLOCK   BSSZ   1           SET NONZERO IF CHANNEL LOCK IS SET
 CHLCNT   BSSZ   1           NUMBER OF REQUESTS TO PROCESS BEFORE
                             CLEARING CHANNEL LOCK
 C.CHCNT  EQU    37          NUMBER OF REQUESTS TO PROCESS BEFORE
                             CLEARING CHANNEL LOCK
 SHARECH  BSSZ   1           NONZERO IF THE CHANNEL WAS GIVEN UP TO MALET OR DFT
 ILOAD    BSSZ   1           NONZERO AFTER INITIAL CONTROLWARE LOAD
 RECOV    BSSZ   1           INDEX TO NEXT RECOVERY PROCEDURE
 CRSV1    BSSZ   1           TIMEOUT COUNTER FOR CONTROLLER RESERVE
 CRSV2    BSSZ   1           TIMEOUT COUNTER FOR CONTROLLER RESERVE
 AREG     BSSZ   1
 FUNTO    BSSZ   1           SET WHILE FUNC IS READING DETAILED STATUS
 IGNORE   BSSZ   1           NONZERO, IF ERRORS ARE TO BE IGNORED
          SPACE  6

 D19      IFEQ   CONTYP,2
 SELIL    EQU    6           NUMBER OF ENTRIES IN SELECTION SET
 D19      ELSE
 SELIL    EQU    8           NUMBER OF ENTRIES IN SELECTION SET
 D19      ENDIF

 SEKS     BSSZ   SELIL       UNITS TO WHICH SEEKS HAVE BEEN ISSUED
 SS       BSSZ   SELIL*C.SS*4  SELECTION SET
 SSL      EQU    *-SS        LENGTH OF SELECTION SET TABLE
          SPACE  6
 RQ       BSSZ   C.RQ*4      REQUEST BEING PROCESSED
 CM       EQU    RQ+/RQ/P.CMND  COMMAND PORTION OF REQUEST
 CMLIST   EQU    CM
          BSSZ   P.CM*2+4    LIST OF CM ADDRESS AND LENGTH PAIRS POINTING TO
                              CM DATA.
 CMLN     EQU    *-CMLIST    LENGTH OF CMLIST BUFFER
          SPACE  6
 RS       BSSZ   C.RS*4      RESPONSE BUFFER
          BSSZ   3           MUST FOLLOW RS, FOR ZEROING OUT RS

 CTBUF    BSSZ   8           BUFFER FOR LOADING CONTROLWARE
          SPACE  6
 UDL      BSSZ   1           LENGTH OF UNIT DESCRIPTORS (CM WORDS)
          SPACE  6
 R        ERRPL  *-OVAD2     IF > 0, RESIDENT PORTION IS TOO LARGE
          EJECT
          QUAL   RES
 RUD      EQU    BUFF        NONZERO IF UNIT POINTERS HAVE BEEN READ
 UDBUF    EQU    BUFF+1      ACTIVE UNITS BUFFER
 UDBUFL   EQU    40*4        LENGTH OF ACTIVE UNITS BUFFER

          IFNE   CHANTYP,1
 END      EQU    7761B       END OF MEMORY
          ELSE
 END      EQU    17761B      END OF MEMORY
          ENDIF

 R3       ERRPL  UDBUF+UDBUFL-END
          EJECT
          QUAL   *

 END      EQU    /RES/END
 LNO      EQU    /RES/LNO
 RECS     EQU    /RES/RECS
 ATERM    EQU    /RES/ATERM
 HTERM    EQU    /RES/HTERM
 OTERM    EQU    /RES/OTERM
 LTERM    EQU    /RES/LTERM
 UTERM    EQU    /RES/UTERM
 ACN      EQU    /RES/ACN
 IAPMBF   EQU    /RES/IAPMBF
 OAPMBF   EQU    /RES/OAPMBF
 CFM      EQU    /RES/CFM
 OAMCT    EQU    /RES/OAMCT
 DCN      EQU    /RES/DCN
 RSA      EQU    /RES/RSA
 DISK     EQU    /RES/DISK
 MAINA    EQU    /RES/MAINA
 MAINB    EQU    /RES/MAINB
 MAINC    EQU    /RES/MAINC
 SEEK     EQU    /RES/SEEK
 SQLOCK   EQU    /RES/SQLOCK
 LOCK     EQU    /RES/LOCK
 CLRLOCK  EQU    /RES/CLRLOCK
 CQLOCK   EQU    /RES/CQLOCK
 SAVSS    EQU    /RES/SAVSS
 CLOCK    EQU    /RES/CLOCK
 GETSS    EQU    /RES/GETSS
 UREQ     EQU    /RES/UREQ
 ZRESP    EQU    /RES/ZRESP
 SETRQ    EQU    /RES/SETRQ
 SETADD   EQU    /RES/SETADD
 FAILAD   EQU    /RES/FAILAD
 SRESP    EQU    /RES/SRESP
 UNCMND   EQU    /RES/UNCMND
 GLIST    EQU    /RES/GLIST
 CFLGS    EQU    /RES/CFLGS
 PUTRC    EQU    /RES/PUTRC
 CHNERR   EQU    /RES/CHNERR
 CHERO    EQU    /RES/CHERO
 CHER     EQU    /RES/CHER
 SERR     EQU    /RES/SERR
 SERRID   EQU    /RES/SERRID
 SID      EQU    /RES/SID
 RESP     EQU    /RES/RESP
 RESPIN   EQU    /RES/RESPIN
 FUNC     EQU    /RES/FUNC
 GENSTAT  EQU    /RES/GENSTAT
 CKSTAT   EQU    /RES/CKSTAT
 FORMA    EQU    /RES/FORMA
 PAUS     EQU    /RES/PAUS
 DELRQ    EQU    /RES/DELRQ
 SELRQ    EQU    /RES/SELRQ
 UDBUFL   EQU    /RES/UDBUFL
 UCMDPR   EQU    /RES/UCMDPR
 FDCN     EQU    /RES/FDCN
 CONCH    EQU    /RES/CONCH
 TERMB    EQU    /RES/TERMB
 DROPS    EQU    /RES/DROPS
 E100     IFEQ   ERRTST,1
 TESTREC  EQU    /RES/TESTREC
 TESTEND  EQU    /RES/TESTEND
 E100     ENDIF
          EJECT
          QUAL   IN
 IPIT     BSSZ   C.PIT*4     PP INTERFACE TABLE
          EJECT
** NAME-- INIT
*
** PURPOSE-- INITIALIZE THE DRIVER AFTER DEADSTART.
*
** INPUT-- DSRTP = CM BYTE-ADDRESS OF THE PP INTERFACE TABLE.
          SPACE  6
          QUAL   *
 INIT     BSS
          QUAL   IN
          IFEQ   ICHK,1
          AOML   INITL       SET INITIALIZATION FLAG
          ENDIF

* GET POINTER TO SP-ADDRS-ARRAY.

          REFAD  DSRTP,CM.PIT   REFORMAT ADDRESS OF PP INTERFACE TABLE
                               AND SAVE.


* REFORMAT ADDRESS OF COMMUNICATION BUFFER.
* INITIALIZE CM.CB, COML.

          LOADC  CM.PIT      ADDRESS OF PP INTERFACE TABLE
          RJM    SETCB       SAVE ADDRESS OF COMMUNICATION BUFFER

* PUT ZEROES IN THE ZERO BUFFER.

          LDK    C.RS-/RS/C.FTRK
          STDL   WC
          LDDL   CMADR+2     CM ADDRESS OF COMMUNICATION BUFFER
          LMC    400000B
          ADK    /CB/C.ZERO
          CWML   RS+/RS/P.FTRK,WC  STORE ZEROES

* REFORMAT ADDRESS OF OVERLAY DIRECTORY.

          LOADC  CM.CB       POINTER TO PP COMMUNICATION BUFFER
          ADN    3
          CRDL   T1          READ WORD CONTAINING RMA OF DIRECTORY
          REFAD  T3,DH       REFORMAT DIRECTORY RMA


          RJM    ZRESP       ZERO OUT RESPONSE BUFFER

* READ PP_INTERFACE_TABLE.

          LDN    C.PIT
          STDL   WC
          LOADC  CM.PIT      LOAD CM ADDRESS OF PP INTERFACE TABLE
          CRML   IPIT,WC     READ PP INTERFACE TABLE
          IFEQ   LARGE,SMALL
          RJM    CHKRS       CHECK FOR VALIDITY OF PP RESPONSE BUFFER
          ENDIF
          LDML   IPIT+/PIT/P.PPNO  GET PP NUMBER
          STDL   PPNO

* INITIALIZE UDL, LUDL.

          LDML   IPIT+/PIT/P.UNITC  NUMBER OF UNIT DESCRIPTORS
          SHN    1
          STML   UDL         LENGTH OF UNIT DESCRIPTORS (CM WORDS)

* REFORMAT ADDRESS OF RESPONSE BUFFER.
* INITIALIZE CM.RS, LIM.

          REFAD  IPIT+/PIT/P.RSBUF,CM.RS  REFORMAT CM ADDRESS OF RESPONSE
                             BUFFER
          LDML   IPIT+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STDL   LIM
          IFEQ   LARGE,SMALL
          RJM    CHKPIT      CHECK FOR VALIDITY OF PP INTERFACE TABLE
          ENDIF

* REFORMAT ADDRESS OF INTERRUPT WORD.

          REFAD  IPIT+/PIT/P.INT,CM.INT  REFORMAT CM ADDRESS OF
                             INTERRUPT WORD

* REFORMAT ADDRESS OF CHANNEL TABLE.

          REFAD  IPIT+/PIT/P.CHAN,CM.CHAN  REFORMAT CM ADDRESS OF
                             CHANNEL TABLE

*
          IFEQ   LARGE,1
          RJM    WTDSK       INITIALIZE UNIT WITH LARGE SECTORS
          ELSE
 S1       IFEQ   SMALL,1
          RJM    WTDSK
S1        ENDIF
          ENDIF
*

 INIT110  BSS
          IFEQ   ICHK,1
          LDN    0
          STML   INITL       CLEAR INITIALIZATION FLAG
          ENDIF
          LJM    DISK
          EJECT
 SETCBX   LJM    **
 SETCB    EQU    *-1
          ADN    /PIT/C.CBUF  OFFSET OF PP COMMUNICATION BUFFER ADDRESS
          CRDL   P1          READ ADDRESS OF PP COMMUNICATION BUFFER
          LOADF  P3          REFORMAT CM ADDRESS OF PP COMMUNICATION BUFFER
          STML   CM.CB+2
          LDDL   CMADR
          STML   CM.CB
          LDDL   CMADR+1
          STML   CM.CB+1
          LDDL   P2          GET LENGTH OF PP COMMUNICATION BUFFER
          SHN    -3
          ADC    -C.CB
          MJN    *           IF NOT ENOUGH ROOM IN COMMUNICATION BUFFER
          UJK    SETCBX
          EJECT
 SAVAX    LJM    **
 SAVAD    EQU    *-1
          STML   2,T2
          LDDL   CMADR
          STI    T2
          LDDL   CMADR+1
          STML   1,T2
          UJK    SAVAX
          EJECT
* CHECK IF CONTROLLER IS RESERVED TO ANOTHER ACCESS.
          SPACE  6
          IFEQ   ICHK,1
 CONRX    LJM    *-1
 CONRSV   EQU    *-1
          RJM    CHGCH2      CHANGE CHANNEL NUMBERS IN I/O INSTRUCTIONS
          RJM    CFM         CLEAR CHANNEL FLAG AND IGNORE IF SET
          UJN    CONR5       IF NO CHANNEL ERROR

 CONR5    BSS
          LDC    187         WAIT 10 SECONDS
          STML   CONR110
 CONR10   BSS
          RJM    GENSTAT      GET GENERAL STATUS
          LDDL   GNSTAT      GENERAL STATUS
          SHN    17-10
          PJN    CONRX       IF MULTI-ACCESS COUPLER NOT CONNECTED
          SOML   CONR100
          NJN    CONR10
          SOML   CONR110
          NJN    CONR10      IF NOT 10 SECONDS
          LDK    /RS/K.CRS   CONTROLLER RESERVED
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          UJK    CONR5
          SPACE  6
 CONR100  BSSZ   1           TIMEOUT COUNTER
 CONR110  BSSZ   1           TIMEOUT COUNTER
          ENDIF
          EJECT
 RFUNTO   BSS                RECOVERED FUNCTION TIMEOUT
          IFEQ   ICHK,1
          LDN    0           UNSOLICITED MESSAGE
          STDL   RESPC       RESPONSE CODE
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LDK    /RS/K.HDWR  HARDWARE ERROR
          STML   RS+/RS/P.HDWR  ABNORMAL STATUS
          RJM    TERMP       SEND UNSOLICITED MESSAGE TO CM
          LDDL   FUNCD       FUNCTION CODE
          LJM    FUN2        RETRY FUNCTION
          ENDIF
          EJECT
 UNREC    BSS                UNRECOVERED ERROR DURING INITIALIZATION
          IFEQ   ICHK,1
          LDN    0           UNSOLICITED MESSAGE
          STDL   RESPC       RESPONSE CODE
          RJM    TERMP       SEND UNSOLICITED MESSAGE TO CM
          RJM    HALT        ERROR
*         (NO RETURN FROM HALT.)

          ENDIF
          EJECT
* CHECK FOR VALID PP RESPONSE BUFFER.
          SPACE  6
 D2       IFEQ   LARGE,SMALL
 CHKRX    LJM    **
 CHKRS    EQU    *-1
 F2       IFEQ   ERRTST,0
 D1       IFEQ   HARDW,1
          LDML   IPIT+/PIT/P.RSBUF-2  RESERVED WORD OF RESPONSE
                             BUFFER DESCRIPTOR
          ADML   IPIT+/PIT/P.RSBUF-1
          ADML   IPIT+/PIT/P.RSPVA-1
          NJN    CHKR100     IF RESERVED FIELD NOT XERO

          LDML   IPIT+/PIT/P.IN-3  RESERVED FIELD OF IN POINTER
          ADML   IPIT+/PIT/P.IN-2
          ADML   IPIT+/PIT/P.IN-1
          NJN    CHKR100     IF RESERVED FIELD NOT ZERO

          LDML   IPIT+/PIT/P.OUT-3  RESERVED FIELD OF OUT POINTER
          ADML   IPIT+/PIT/P.OUT-2
          ADML   IPIT+/PIT/P.OUT-1
          NJN    CHKR100     IF RESERVED FIELD NOT ZERO

          LDML   IPIT+/PIT/P.LIMIT-2
          ADML   IPIT+/PIT/P.LIMIT-1
          ZJK    CHKRX

 CHKR100  BSS
          RJM    HALT        INVALID RESPONSE BUFFER
*         (NO RETURN FROM HALT.)

 D1       ELSE
          UJK    CHKRX
 D1       ENDIF
 F2       ELSE
          UJN    CHKRX
 F2       ENDIF
 D2       ENDIF
          EJECT
* CHECK FOR VALID PP-INTERFACE-TABLE.
          SPACE  6
          IFEQ   LARGE,SMALL
 CHKPX    LJM    **
 CHKPIT   EQU    *-1
 F3       IFEQ   ERRTST,0
 D8       IFNE   CONTYP,2
          LDN    0
          STDL   T1
          LDML   IPIT+/PIT/P.CBUFL  COMMUNICATION BUFFER LENGTH
          LPN    7
          NJN    CHKP100     IF LENGTH NOT A MULTIPLE OF WORDS

          AODL   T1
          LDML   IPIT+/PIT/P.CBUFL-1  RESERVED WORD OF PP COMMUNICATION
                             BUFFER DESCRIPTOR
          NJN    CHKP100     IF RESERVED WORD NOT ZERO

          AODL   T1
          LDML   IPIT+/PIT/P.CBUF+1  COMMUNICATION BUFFER (RMA)
          LPN    7
          NJN    CHKP100     IF PP COMMUNICATION BUFFER NOT A WORD BOUNDARY

          AODL   T1
          LDML   IPIT+/PIT/P.PPQPVA-1  RESERVED FIELD OF PP REQUEST
                             QUEUE DESCRIPTOR
          ADML   IPIT+/PIT/P.PPQ-1
          NJN    CHKP100     IF RESERVED FIELD NOT ZERO

          AODL   T1
          LDML   IPIT+/PIT/P.INT+1  INTERRUPT WORD (RMA)
          LPN    7
          NJN    CHKP100     IF INTERRUPT WORD NOT A WORD BOUNDARY
          AODL   T1
          LDML   IPIT+/PIT/P.CHAN+1  CHANNEL TABLE (RMA)
          LPN    7
          ZJK    CHKPX

 CHKP100  BSS
          LDML   CHKP110,T1  INTERFACE ERROR CODE
          RJM    INTERR      SEND ERROR TO CM
*         (NO RETURN FROM INTERR)

 CHKP110  BSS
          CON    E20B        COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS
          CON    E204        RESERVED WORD OF PP COMMUNICATION
                             BUFFER DESCRIPTOR NOT ZERO
          CON    E203        PP COMMUNICATION BUFFER NOT A WORD BOUNDARY
          CON    E205        RESERVED FIELD OF PP REQUEST QUEUE
                             DESCRIPTOR NOT ZERO
          CON    E211        RMA OF INTERRUPT WORD NOT A WORD BOUNDARY
          CON    E212        RMA OF CHANNEL TABLE NOT A WORD BOUNDARY
 D8       ELSE
          UJN    CHKPX
 D8       ENDIF
 F3       ELSE
          UJN    CHKPX
 F3       ENDIF
          ENDIF
          EJECT
* INTERFACE ERROR.
          SPACE  6
 INTERR   CON    0
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LDN    0           UNSOLICITED MESSAGE
          STDL   RESPC       RESPONSE CODE
          LDK    /RS/K.INTERR  INTERFACE ERROR
          STML   RS+/RS/P.INTERR  ABNORMAL STATUS CODE
          RJM    TERMP       SEND RESPONSE TO CM
          RJM    HALT        ERROR
*         (NO RETURN FROM HALT.)

          EJECT
** NAME-- TERMP
*
** PURPOSE-- TERMINATE PP REQUEST.
*
** OUTPUT-- RS+/RS/P.RC = RESPONSE CODE
          SPACE  6
 TERX     LJM    **
 TERMP    EQU    *-1
          RJM    PUTRC       PUT RESPONSE CODES IN RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
          RJM    ZRESP       ZERO OUT RESPONSE BUFFER
          UJK    TERX
          EJECT
 R5       ERRPL  *-END       INITIALIZE CODE
          QUAL   *


 PRGNAM   MICRO  1,4,*DISK*

*         OVERLAY STRUCTURE -
*
*         START              RESIDENT
*         OVAD2              SELSEK, READ, WRITE          CONFIDENCE TEST
*         OVAD3                (SELSEK EXTENDS)           CRC, CREAD, CWRITE
*         OVAD1              SELRQ,       RDERR
*         BUFF               DATA,   RECS,   DOWN UNIT,   PPREQ


          IFEQ   CONTYP,2
 OVAD1    EQU    BUFF-51B*4
 OVAD2    EQU    OVAD1-311B*4
          ELSE
 OVAD1    EQU    BUFF-22B*4
 OVAD2    EQU    OVAD1-325B*4
          ENDIF
 OVAD3    EQU    OVAD1-56B*4
          EJECT

          OVERLAY (READ WRITE),OVAD2
          ROUTINE READO
          CON    READOO

          QUAL   RD
          EJECT
** NAME--SELSEK
*
** PURPOSE--THIS ROUTINE SELECTS UNITS FOR THE SELECTION SET AND
*           ISSUES THE INITIAL SEEK.
*
          SPACE  6
 SELSX    LJM    **
          QUAL   *
 SELSEK   EQU    *-1
          QUAL   RD
          LDDL   CUNITS
          ZJK    SELSX       IF NO UNITS
          LDN    0
          STDL   FNC         ZERO OUT FUNCTION CODE

* SEARCH FOR NEW UNIT REQUESTS.

 SELS10   BSS
          RJM    GETUD       GET NEW UNIT REQUESTS
          LDDL   SEKCNT
          ZJK    SELSX       IF NO SEEKS WERE ISSUED

* POLL UNITS FOR ON SECTOR.

          RJM    POLLON      POLL FOR ON-SECTOR
          PJN    SELS50      IF UNIT ON-SECTOR OR ON-CYLINDER, SELECT IT

* DROP CONTROLLER RESERVE.
* REPOLL UNITS.

 P3       IFEQ   SHARED,1
 P4       IFEQ   HARDW,1
          AODL   NORQ        SET NO REQUEST FLAG IS CASE OF ERROR
          LDN    F.CLEAR     CLEAR CONTROLLER ACCESS
          RJM    FUNC        CLEAR THE COUPLER ACCESS
          LDN    0
          STDL   NORQ        CLEAR NO REQUEST FLAG

* DELAY 50 MICROSECONDS.

          PAUSE  50          DELAY 50 MICROSECONDS
 P4       ENDIF
 P3       ENDIF
          UJK    SELS10      REPOLL UNITS

* SELECT UNIT FROM LAST POLL.
* DROP SEEKS ON OTHER UNITS.

 SELS50   BSS
          RJM    DROPS       DROP SEEKS ON OTHER UNITS
          LDDL   SELECT      INDEX TO SELECTED UNIT
          STDL   SELIN
          UJK    SELSX
          EJECT
** NAME-- GETUD
*
** PURPOSE-- GET A UNIT REQUEST FROM CM.
*
** INPUT-- SELIN = INDEX TO SS TABLE.
*
** OUTPUT-- AN ENTRY IN THE SS TABLE IS FILLED WITH THE NEW UNIT REQUEST.
*
          SPACE  6
 GETUX    LJM    **
 GETUD    EQU    *-1
          LDML   LUD         INDEX OF LAST UNIT DESCRIPTOR REQUEST FOUND + 1
          STDL   P6
          LDN    0
          STDL   SELIN
          STML   /RES/RUD    READ UNIT POINTERS
 GETU5    BSS
          LDML   SS+/SS/P.ENTRY,SELIN
          SHN    /SS/L.ENTRY+2
          PJN    GETU10      IF ENTRY NOT PRESENT
          LDN    C.SS*4
          RADL   SELIN       INCREMENT SELECTION SET INDEX
          ADK    -SSL        CHECK FOR END OF TABLE
          PJK    GETUX       IF END OF TABLE
          UJK    GETU5


* FIND THE NEXT VACANT SS ENTRY.

 GETU7    BSS
          LDN    C.SS*4
          RADL   SELIN       INCREMENT SELECTION SET INDEX
          ADK    -SSL        CHECK FOR END OF TABLE
          PJK    GETUX       IF END OF TABLE
          LDML   SS+/SS/P.ENTRY,SELIN
          SHN    /SS/L.ENTRY+2
          MJN    GETU7       IF ENTRY IS TAKEN

* CHECK IF ALL UNITS HAVE BEEN SEARCHED.

 GETU8    BSS
          LDML   LUD         HAVE ALL ENTRIES BEEN CHECKED
          SBDL   P6
          ZJK    GETUX       IF NO MORE ENTRIES TO CHECK

 GETU10   BSS
          LDML   LUD
          STDL   P2
          LDN    4
          RAML   LUD         BUMP UNIT POINTER INDEX
          SHN    -2
          SBDL   CUNITS
          NJN    GETU16      IF NOT END OF TABLE
          STML   LUD


* CHECK FOR ANY REQUESTS ON THIS UNIT QUEUE.

 GETU16   BSS
          LDML   SS+/SS/P.SEEK,SELIN  CLEAR SEEK FLAG IN SS
          LPC    -/SS/K.SEEK-/SS/K.CUR
          STML   SS+/SS/P.SEEK,SELIN
          LDML   /RES/RUD    CHECK IF UNIT POINTERS HAVE BEEN
          SBN    77B         CLOBBERED BY AN OVERLAY
          ZJN    GETU15      IF UNIT POINTERS HAVE BEEN READ INTO PP BUFFER
          RJM    READUD      READ POINTERS TO UNIT INTERFACE TABLES
 GETU15   BSS
          LOADR  /RES/UDBUF+/UN/P.UIT,P2  LOAD ADDRESS OF UNIT INTERFACE TABLE
          ERRNZ  /UIT/C.DSABLE
          CRDL   T1          READ UNIT DISABLED FLAG
          ADN    /UIT/C.NEXT
          CRDL   T5          READ RMA OF NEXT REQUEST FROM UNIT QUEUE
          SBN    /UIT/C.NEXT-/UIT/C.UBUF  ADDRESS OF UNIT COMMUNICATION BUFFER
          CRDL   P2          READ ADDRESS OF UNIT COMMUNICATION BUFFER
          ADN    /UIT/C.ULOCK-/UIT/C.UBUF
          CRDL   T3          READ UNIT LOCKWORD
          LDDL   T3
          NJN    GETU18      IF LOCK IS SET
          LDDL   T7
          ADDL   T8
          ZJN    GETU18      IF NO REQUESTS ON THIS QUEUE
          LDDL   T1+/UIT/P.DSABLE  CHECK IF UNIT IS DISABLED
          SHN    2+/UIT/L.DSABLE
          PJN    GETU19      IF UNIT IS NOT DISABLED
 GETU18   BSS
          UJK    GETU8

* READ SS ENTRY FROM UNIT COMMUNICATION BUFFER.

 GETU19   BSS
          LDC    SS+/SS/P.ENTRY  ADDRESS OF SS ENTRY
          ADDL   SELIN
          STML   GETU20
          LDN    C.SS        NUMBER OF WORDS TO READ
          STDL   WC
          LOADF  P4          LOAD ADDRESS OF UNIT COMMUNICATION BUFFER
          CRML   **,WC       READ SS ENTRY
 GETU20   EQU    *-1

* SET UNIT LOCK.

          RJM    /RES/SETLOCK  SET UNIT LOCKWORD
          NJN    GETU57      IF LOCK COULD NOT BE SET
          LDML   SS+/SS/P.CUR,SELIN
          SHN    /SS/L.CUR+2
          MJN    GETU50      IF CURRENT REQUEST HAS BEEN SELECTED

* SELECT CURRENT REQUEST.

          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    GETU55      IF LOCK COULD NOT BE SET
          RJM    SELRQ       SELECT CURRENT REQUEST
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          LDML   SS+/SS/P.CUR,SELIN  CHECK IF REQUEST WAS FOUND
          SHN    /SS/L.CUR+2
          MJN    GETU50      IF A REQUEST WAS FOUND
 GETU55   BSS
          LDML   SS+/SS/P.SEEK,SELIN  CLEAR SEEK FLAG IN SS
          LPC    -/SS/K.SEEK-/SS/K.CUR
          STML   SS+/SS/P.SEEK,SELIN
          RJM    CLRLOCK     CLEAR UNIT LOCKWORD
 GETU57   UJK    GETU8


* ISSUE THE SEEK.

 GETU50   BSS
          RJM    /RES/SEEKI  ISSUE INITIAL SEEK
          UJK    GETU7
          EJECT
** NAME-- READUD
*
** PURPOSE-- READ POINTERS TO UNIT INTERFACE TABLES FROM THE PP COMMUNICATION BUFFER.
*
          SPACE  6
 REAX     LJM    **
 READUD   EQU    *-1

* READ POINTERS TO UNIT INTERFACE TABLES FROM THE PP COMMUNICATION BUFFER.

          LDDL   CUNITS      NUMBER OF CONFIGURED UNITS
          ZJK    REAX        IF NO UNITS
          STDL   WC
          LOADC  CM.CB
          ADK    /CB/C.UNITS  UNIT INTERFACE TABLE POINTERS
          CRML   /RES/UDBUF,WC  READ UNIT INTERFACE TABLE POINTERS
          LDN    77B         SET FLAG FOR UNIT POINTERS IN MEMORY
          STML   /RES/RUD
          UJK    REAX
          EJECT
** NAME--POLLON
*
** PURPOSE-- THIS ROUTINE POLLS UNITS FOR ON-CYLINDER AND ON-SECTOR
*            AND CHOOSES THE CLOSEST UNIT FOR I/O TRANSFER.
*
** CALLING SEQUENCE--RJM POLLON
*
** INPUT-- SEKCNT, CHAN.
*
** OUTPUT-- A REGISTER = 0, IF THE UNIT IS ON-SECTOR.
*                      GT 0, IF THE UNIT IS CLOSEST TO ON-SECTOR.
*                            AND A REGISTER = NUMBER OF SECTORS TO THE
*                            START OF TRANSFER FOR THAT CLOSEST UNIT.
*                      LT 0, IF NO UNITS ARE ON-CYLINDER.
*           SELECT = SELECTED UNIT ENTRY (SS INDEX).
*           SELECTED UNIT IS CONNECTED.
*
          SPACE  6
 POLLX    LJM    **
 POLLON   EQU    *-1
          LDN    0           INITIALIZE SEKS TABLE INDEX
          STDL   P6
 Y2       IFNE   CONTYP,2
          LDN    77B
          STDL   P4          INITIALIZE CLOSEST UNIT'S SS INDEX
          STDL   P5          SECTOR DISTANCE OF CLOSEST UNIT
 Y2       ENDIF

* CHECK IF UNIT IS ON CYLINDER.

 POLL4    LDML   SEKS,P6     SET SELECTION SET INDEX
          STDL   SELECT
          STDL   SELIN
          LDML   SS+/SS/P.ENTRY,SELECT  CHECK IF LOCK IS SET AND SEEK ISSUED
          LPK    /SS/K.ENTRY+/SS/K.SEEK
          SBN    /SS/K.ENTRY+/SS/K.SEEK
          NJN    POLL20      IF SEEK WAS NOT ISSUED
 X1       IFEQ   MULT,1
          LDML   SS+/SS/P.CHAN,SELECT  GET CHANNEL NUMBER
          SHN    -16+/SS/L.CHAN+/SS/N.CHAN
          LPN    /SS/M.CHAN
          SBDL   CHAN
          NJN    POLL20      IF NOT SAME CHANNEL
 X1       ENDIF
 POLL14   BSS
          RJM    SEEK        ISSUE SEEK FUNCTION
 Y3       IFNE   CONTYP,2
          RJM    RSA         ISSUE RETURN SECTOR ADDRESS FUNCTION
 Y3       ELSE
          RJM    GENSTAT     GET GENERAL STATUS
 Y3       ENDIF
          LDDL   GNSTAT      CHECK GENERAL STATUS
          ZJN    POLL30      IF NO ERRORS
          SBN    2
          ZJN    POLL20      IF NO ERRORS
          RJM    GENSTAT     READ DETAILED STATUS
          RJM    CKSTAT      CHECK FOR GENERAL STATUS ERRORS
          MJK    POLL14      ATTEMPT RECOVERY OF ERROR
          RJM    /RES/RECRS  SEND ANY RECOVERED ERROR RESPONSES
 Y4       IFNE   CONTYP,2
 POLL20   UJN    POLL80

* COMPARE SECTOR ADDRESS OF REQUEST WITH CURRENT DISK SECTOR
* ADDRESS.
* COMPUTE SECTOR DISTANCE TO THE START OF THE REQUEST.

 POLL30   BSS
          LDML   SS+/SS/P.DV,SELECT  GET DEVICE TYPE
          ERRNZ  -16+/SS/L.DV+/SS/N.DV
          LPN    /SS/M.DV
          STDL   T3
          LDML   SS+/SS/P.WRITE,SELECT  CHECK IF READ OR WRITE
          SHN    /SS/L.WRITE+2
          PJN    POLL40      IF READ FUNCTION
          LDML   SECSC,T3    IF WRITE FUNCTION
          RADL   P2
 POLL40   LDML   SS+/SS/P.SECTOR,SELECT  STARTING SECTOR ADDRESS
          SBDL   P2          CURRENT DISK SECTOR ADDRESS
          ZJN    POLL48      IF CURRENT SECTOR = STARTING SECTOR
          PJN    POLL50      IF NOT END OF TRACK WRAP AROUND
 POLL48   ADML   DVSEC,T3    ADD NUMBER OF SECTORS/TRACK
 POLL50   STDL   T2
          ZJN    POLL60      IF NOT 1 OR 2 SECTORS AWAY
          SBN    3
          PJN    POLL60      IF NOT 1 OR 2 SECTORS AWAY
          LDN    0
          UJN    POLL85      EXIT, A REGISTER = 0, IF UNIT ON-SECTOR


* SELECT THE CLOSEST UNIT.

 POLL60   BSS
          LDDL   T2
          SBDL   P5
          PJN    POLL80      IF THIS UNIT IS NOT THE CLOSEST
          RADL   P5          SAVE THIS UNITS SECTOR DISTANCE
          LDDL   SELECT
          STDL   P4          SAVE THIS UNITS INDEX
 POLL80   AODL   P6          HAVE ALL UNITS BEEN CHECKED
          SBDL   SEKCNT
          MJK    POLL4       NO
          LDDL   P4          WERE ANY UNITS ON CYLINDER
          SBN    77B
          NJN    POLL90      IF AT LEAST 1 UNIT ON-CYLINDER
          LCN    1           A REGISTER .LT. 0, WHEN NO UNITS ON-CYLINDER
 POLL85   UJK    POLLX


* LEAVE CLOSEST UNIT SELECTED.

 POLL90   BSS
          LDDL   SELECT      CHECK IF UNIT IS ALREADY CONNECTED
          SBDL   P4
          ZJN    POLL98      IF UNIT IS ALREADY CONNECTED
          LDDL   P4
          STDL   SELECT      SET TO SELECTED UNIT ENTRY
          STDL   SELIN
          RJM    /RES/SEEKON  ISSUE SEEK FUNCTION AND RECOVER SEEK ERRORS
 POLL98   BSS
          LDDL   P5          A REGISTER .GT. 0, FOR CLOSEST UNIT
          UJK    POLL85      A REGISTER = SECTOR DISTANCE


 Y4       ELSE
 POLL20   UJN    POLL80
 POLL30   BSS
          LDN    1           A REGISTER .GT. 0, FOR SELECTED UNIT
          UJK    POLL85

 POLL80   BSS
          AODL   P6          HAVE ALL UNITS BEEN CHECKED
          SBDL   SEKCNT
          MJK    POLL4       NO
          LCN    1           A REGISTER .LT. 0, WHEN NO UNITS ON-CYLINDER
 POLL85   UJK    POLLX
 Y4       ENDIF
          EJECT
** NAME-- READ.
*
** PURPOSE-- PROCESS READ DATA COMMAND.
*
** INPUT-- CMLISTL = NUMBER OF ADDRESS-LENGTH-PAIR ENTRIES IN THE
*                    COMMAND WHICH ARE LEFT TO PROCESS.
*          CMLIST  = LIST OF ADDRESS-LENGTH-PAIRS POINTING TO THE
*                    CM DATA AREA.
*          CML     = 0 IF NOT INDIRECT ADDRESS (COMMAND IS AT CMLIST)
*                  = 4 IF INDIRECT ADDRESS (COMMAND IS AT CMLIST + CML).
          SPACE  6
 READX    LJM    **
          QUAL   *
 READ     EQU    *-1
          QUAL   RD
 READ3    BSS
          LDDL   DEVICE      DEVICE TYPE
          STDL   DEV
          LDDL   FNC         FUNCTION CODE
          ZJN    READ1       IF READ
          LDN    0           FOR READ=FLAWS, TREAT AS SMALL
          STDL   DEV         SECTOR DEVICE
          RJM    SEEK        ISSUE SMALL SECTOR SEEK
 READ1    BSS
          LDN    5
          STDL   SMSEC       SET SMALL SECTOR COUNTER
          LDN    0
          STDL   TRKEND      SET TRACK END FLAG = 0
          STDL   SECPOS      SET SECTOR POSITION = 0
          STDL   SWFLG       CLEAR SWITCH FLAG

* SET UP NUMBER OF WORDS TO TRANSFER TO THIS CM ADDRESS.

 READ10   BSS
          LOADF  CMLIST+/CM/P.RMA,CML  SET UP CM ADDRESS OF DATA AREA
          STDL   DATADD+2
          SRD    DATADD      SAVE R REGISTER
          LDML   CMLIST+/CM/P.LEN,CML  NUMBER OF BYTES TO TRANSFER
          ADN    7           ROUND UP
          SHN    -3          NUMBER OF CM WORDS TO TRANSFER
          STDL   TWDS        TOTAL NUMBER OF CM WORDS TO TRANSFER TO THIS
                             ADDRESS
          ZJK    READ60      IF NO WORDS TO TRANSFER TO THIS ADDRESS
 READ20   STDL   WDS         COMPUTE NUMBER OF WORDS FROM CURRENT SECTOR
          SODL   SMSEC       DECREMENT SMALL SECTOR COUNTER
          NJN    READ22      IF NOT THE 5TH SECTOR
          LDN    5
          STDL   SMSEC       SET SMALL SECTOR COUNTER
          LDML   CMWDS5,DEV  COMPUTE NUMBER OF WORDS FROM CURRENT SECTOR
          UJN    READ23

 READ22   BSS
          LDML   CMWDS,DEV   COMPUTE NUMBER OF WORDS FROM CURRENT SECTOR
 READ23   BSS
          STDL   SECWDS      NUMBER OF DATA WORDS IN SECTOR
          SBDL   WDS
          SBDL   SECPOS      WORDS PREVIOUSLY TRANSFERRED FROM THIS SECTOR
          PJN    READ25      IF LESS THAN 1 SECTOR
          LDDL   SECWDS
          SBDL   SECPOS
          PJN    READ24      IF VALID SECTOR POSITION
          LDDL   WDS         IF WDS = 0, POSITIONING TO NEXT MAU
          ZJN    READ24      IF VALID SECTOR POSITION
          RJM    HALT        INVALID SECTOR POSITION
*         (NO RETURN FROM HALT.)

 READ24   BSS
          STDL   WDS         NUMBER OF CM WORDS TO TRANSFER FROM CURRENT SECTOR

* CHECK IF END OF TRACK ON LAST READ.

 READ25   BSS
          LDDL   SECPOS
          NJK    READ51      IF MORE WORDS TO TRANSFER FROM LAST SECTOR
          LDDL   TRKEND
          ZJN    READ30      IF NOT END OF TRACK
          LDN    0
          STDL   TRKEND      RESET END OF TRACK FLAG
          LDML   SS+/SS/P.TRACK,SELIN  CHECK FOR INVALID TRACK ADDRESS
          SBML   DVTRK,DEVICE  COMPARE WITH NUMBER OF TRACKS / CYLINDER
          MJN    READ30      IF NOT END OF CYLINDER
          LDC    E507        ERROR IN REQUEST
          RJM    ATERM       ABNORMAL TERMINATION  (NO RETURN)
*         (NO RETURN FROM ATERM)


* TRANSFER DATA FROM DISK.

 READ30   BSS
          LDDL   FNC
          ZJN    READ32      IF READ FUNCTION
          RJM    /RES/SEEKON  ISSUE SEEK AND RECOVER SEEK ERRORS
          LDN    0
          STDL   MAPC        INITIALIZE READ-TYPE FUNCTION INDEX
          LDML   MAPFN,MAPC  ISSUE READ PROTECTED SECTOR
          UJN    READ34

 READ32   BSS
          LDN    F.READ      ISSUE READ FUNCTION TO DISK CONTROLLER
 READ34   BSS
          RJM    FUNC
 READ40   RJM    ACN         ACN   DC
          LDDL   FNC
          NJN    READ42      IF READ FLAW MAP
          LDDL   DEV
          NJN    READ44      IF NOT 844
 READ42   BSS
          LDC    322
          RJM    IAPMBF      IAPM   BUFF,DC
          UJN    READ46

 READ44   BSS
          LDC    SBYTE7
          RJM    IAPMBF      IAPM   BUFF,DC
 READ46   BSS
 E4       IFEQ   ERRTST,1
          ADML   ICSTEST     INCOMPLETE SECTOR TEST
 E4       ENDIF
          STML   AREG        SAVE A REGISTER IN CASE OF PREMATURE TERMINATION
 E5       IFEQ   ERRTST,1
          LDML   CHTEST      CHANNEL PARITY ERROR TEST
          NJN    *+4
 E5       ENDIF
          RJM    CFM         CFM    READ47,DC
          UJN    READ47      IF NO CHANNEL ERROR

          RJM    CHNERR      RECORD CHANNEL ERROR
 READ45   BSS
          RJM    /RES/SEEKON  REISSUE SEEK
          UJK    READ30      RE-READ SECTOR

 READ47   BSS
          RJM    GENSTAT     GET GENERAL STATUS
          ZJN    READ48      IF NO ERRORS
          RJM    /RES/RDERR  CHECK READ ERRORS
          ZJN    READ48      IF ERROR WAS CORRECTED
          PJK    READ40      IF RETRY OF READ
 READ54   BSS
          AOML   SECTRY      INCREMENT SECTOR RETRY COUNT
          SBN    SCTRY
          PJN    READ57      IF MAXIMUM TRIES HAVE BEEN ATTEMPTED
          AOML   RS+/RS/P.STRY  INCREMENT SECTOR RETRY COUNT
          UJK    READ45      RESEEK AND READ SECTOR

* UNRECOVERED ERROR.

 READ57   BSS
          RJM    RECS        ATTEMPT TO RECOVER
*         (NO RETURN FROM RECS.)


* CHECK IF A FULL SECTOR WAS READ.

 READ48   BSS
 E6       IFEQ   ERRTST,1
          RJM    TESTREC     RECOVERED ERROR TEST
 E6       ENDIF
          LDML   AREG        WAS ENTIRE SECTOR READ
          ZJN    READ50      IF ENTIRE SECTOR WAS READ
          STML   RS+/RS/P.FUNTO  NUMBER OF CHANNEL WORDS NOT RECEIVED
          LDK    /RS/K.IST   INCOMPLETE SECTOR TRANSFER
          RJM    SERRID      ERROR ID
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          UJK    READ54      RETRY SECTOR AND REQUEST


* UPDATE SECTOR ADDRESS AND CHECK FOR END OF TRACK.

 READ50   BSS
          LDML   SECSC,DEV   SECTOR INCREMENT
          RAML   SS+/SS/P.SECTOR,SELIN  INCREMENT SECTOR ADDRESS
          SBML   DVSEC,DEVICE  COMPARE WITH NUMBER OF SECTORS / TRACK
          MJN    READ51      IF NOT END OF TRACK
          STML   SS+/SS/P.SECTOR,SELIN  SET SECTOR
          AODL   TRKEND      SET FLAG FOR END OF TRACK
          AOML   SS+/SS/P.TRACK,SELIN  INCREMENT HEAD ADDRESS

* TRANSFER DATA TO CM.

 READ51   BSS
          LDDL   SECPOS      CALCULATE SECTOR BUFFER TRANSFER ADDRESS
          SHN    2
          ADC    CBUF
          STML   READ53
          LDDL   WDS
          ZJN    READ55      IF 0 WORDS TO TRANSFER
          LOADC  DATADD      CM ADDRESS OF DATA AREA
          CWML   CBUF,WDS    SEND SECTOR TO CM
 READ53   EQU    *-1
          LDDL   SECPOS
          NJN    READ55      IF SOME DATA IS LEFT IN THE BUFFER,
                             DONT LET AN OVERLAY BE READ
          RJM    /RES/RECRS  CHECK IF A PREVIOUS ERROR WAS RECOVERED

* UPDATE BYTES TRANSFERRED.

 READ55   BSS
          LDDL   WDS
          RADL   SECPOS      UPDATE SECTOR POSITION
          SBDL   SECWDS      CHECK FOR END OF SECTOR
          NJN    READ58      IF NOT END OF SECTOR
          STDL   SECPOS      RESET SECTOR POSITION = 0
 READ58   BSS
          LDDL   SECPOS
          NJN    READ59      IF SOME DATA IS LEFT IN THE BUFFER,
                             DONT LET AN OVERLAY BE READ
          RJM    /RES/RECRS  CHECK IF A PREVIOUS ERROR WAS RECOVERED
 READ59   BSS
          LDDL   WDS
          SHN    3
          RAML   RS+/RS/P.XFER+1  UPDATE BYTES TRANSFERRED IN RESPONSE STATUS
          SHN    -16
          RAML   RS+/RS/P.XFER
          LDDL   WDS
          RADL   DATADD+2    UPDATE CM ADDRESS
          LDDL   TWDS        UPDATE TOTAL WORDS LEFT TO TRANSFER TO THIS
                             CM ADDRESS
          SBDL   WDS
          STDL   TWDS
          NJN    READ61      IF MORE WORDS TO TRANSFER TO THIS CM ADDRESS

* FOR 844, MAKE SURE A MULTIPLE OF 5 SECTORS IS TRANSFERRED IN
* ORDER TO INSURE THE CORRECT SECTOR ADDRESS FOR THE NEXT TRANSFER.

          LDDL   CMLISTL
          SBN    1
          NJN    READ60      IF NOT END OF ADDRESS-LENGTH-PAIRS IN COMMAND
          LDDL   DEV
          NJN    READ60      IF NOT 844
          LDDL   SMSEC
          SBN    5
          ZJN    READ60      IF A MULTIPLE OF 5 SECTORS HAS BEEN TRANSFERRED
          LDN    0           READ 0 WORDS FROM NEXT SECTOR
 READ61   LJM    READ20

* GET NEXT CM ADDRESS OF DATA AREA.

 READ60   SODL   CMLISTL     DECREMENT ADDRESS-LENGTH-PAIR COUNT
          ZJN    READ80      IF END OF ADDRESS-LENGTH-PAIRS IN COMMAND
          LDDL   SECPOS      CHECK IF A PARTIAL SECTOR WAS TRANSFERRED TO CM
          ZJN    READ70      IF FULL SECTOR WAS TRANSFERRED
          LDDL   SMSEC
          SBN    5
          NJN    READ65
          STDL   SMSEC
 READ65   BSS
          AODL   SMSEC       READJUST SMALL SECTOR COUNTER
 READ70   BSS
          LDN    P.CM        BUMP INDEX TO NEXT CM ADDRESS
          RADL   CML
          ADC    -CMLN
          NJN    READ75      IF MORE DATA TO TRANSFER
          RJM    GLIST       READ NEXT SECTION OF THE LIST WHICH POINTS
                             TO THE CM DATA AREA
 READ75   UJK    READ10

 READ80   BSS
          RJM    CSWIT       CHECK IF SWITCH TO NEXT REQUEST
          NJK    READ1       IF SWITCH TO NEXT REQUEST
          UJK    READX       IF END OF STREAMING REQUESTS

          EJECT
** NAME-- WRITE
*
** PURPOSE-- PROCESS THE WRITE DATA COMMAND.
*
** INPUT-- CMLISTL = NUMBER OF ADDRESS-LENGTH-PAIR ENTRIES IN THE
*                    COMMAND WHICH ARE LEFT TO PROCESS.
*          CMLIST = LIST OF ADDRESS-LENGTH-PAIRS POINTING TO THE
*                   CM DATA AREA.
          SPACE  6
 WRIX     LJM    **
          QUAL   *
 WRITE    EQU    *-1
          QUAL   RD
 WRI3     BSS
          LDN    0
          STDL   WDSS        USED TO UPDATE BYTES TRANSFERRED IN
                             RESPONSE TABLE
          STDL   SWFLG       CLEAR SWITCH FLAG
 WRI5     BSS
          LDN    5
          STDL   SMSEC       SET SMALL SECTOR COUNTER
          LDN    0
          STDL   TRKEND      SET TRACK END FLAG = 0
          STDL   SECPOS      SET SECTOR POSITION = 0
          STDL   RLAST       NONZERO, IF RECOVERING AN ERROR ON LAST SECTOR

* SETUP NUMBER OF WORDS TO TRANSFER FROM THIS CM ADDRESS.

 WRI20    BSS
          LOADF  CMLIST+/CM/P.RMA,CML  SET UP CM ADDRESS OF DATA AREA
          STDL   DATADD+2
          SRD    DATADD      SAVE R REGISTER
          LDML   CMLIST+/CM/P.LEN,CML  NUMBER OF 8-BIT BYTES TO TRANSFER
          ADN    7           ROUND UP
          SHN    -3          NUMBER OF CM WORDS TO TRANSFER
          STDL   TWDS        TOTAL NUMBER OF CM WORDS TO TRANSFER
                             FROM THIS ADDRESS
          ZJK    WRI70       IF NO WORDS TO TRANSFER FROM THIS ADDRESS
 WRI30    BSS
          STDL   WDS         COMPUTE NUMBER OF WORDS TO TRANSFER TO
                             CURRENT SECTOR
          SODL   SMSEC       DECREMENT SMALL SECTOR COUNTER
          NJN    WRI32       IF NOT THE 5TH SECTOR
          LDN    5
          STDL   SMSEC       SET SMALL SECTOR COUNTER
          LDML   CMWDS5,DEVICE  COMPUTE NUMBER OF WORDS FROM CURRENT SECTOR
          UJN    WRI33

 WRI32    BSS
          LDML   CMWDS,DEVICE  COMPUTE NUMBER OF WORDS FROM CURRENT SECTOR
 WRI33    BSS
          STDL   SECWDS      NUMBER OF DATA WORDS IN SECTOR
          SBDL   WDS
          SBDL   SECPOS      WORDS PREVIOUSLY TRANSFERRED FROM THIS SECTOR
          PJN    WRI35       IF LESS THAN 1 SECTOR
          LDDL   SECWDS
          SBDL   SECPOS
          PJN    WRI34       IF VALID SECTOR POSITION
          LDDL   WDS         IF WDS = 0, POSITIONING TO NEXT MAU
          ZJN    WRI34       IF VALID SECTOR POSITION
          RJM    HALT        INVALID SECTOR POSITION
*         (NO RETURN FROM HALT.)

 WRI34    BSS
          STDL   WDS         NUMBER OF CM WORDS TO TRANSFER TO
                             CURRENT SECTOR

* TRANSFER DATA FROM CM.

 WRI35    BSS
          LDDL   SECPOS      CALCULATE SECTOR BUFFER TRANSFER ADDRESS
          SHN    2
          ADC    CBUF
          STML   WRI37
          LDDL   WDS
          ZJN    WRI38       IF 0 WORDS TO TRANSFER
          LOADC  DATADD      CM ADDRESS OF DATA AREA
          CRML   CBUF,WDS    READ SECTOR FROM CM
 WRI37    EQU    *-1

* UPDATE SECTOR POSITION.

 WRI38    BSS
          LDDL   WDS
          RADL   SECPOS      UPDATE SECTOR POSITION
          SBDL   SECWDS      CHECK FOR END OF SECTOR
          NJN    WRI39       IF NOT END OF SECTOR
          STDL   SECPOS      RESET SECTOR POSITION = 0
 WRI39    BSS

* CHECK IF END OF TRACK ON LAST WRITE.

          LDDL   SECPOS
          ZJN    WRI46       IF FULL SECTOR HAS BEEN TRANSFERRED FROM CM
          LDDL   CMLISTL     CHECK IF MORE CM ADDRESS-LENGTH-PAIRS
          SBN    1
          NJK    WRI68       IF MORE CM DATA TO TRANSFER
          LDN    0
          STDL   SECPOS      RESET SECTOR POSITION = 0
 WRI46    BSS
          LDDL   TRKEND
          ZJN    WRI50       IF NOT END OF TRACK
          LDN    0
          STDL   TRKEND      RESET TRACK END FLAG
          LDML   SS+/SS/P.TRACK,SELIN  CHECK FOR INVALID TRACK ADDRESS
          SBML   DVTRK,DEVICE  COMPARE WITH NUMBER OF TRACKS / CYLINDER
          MJN    WRI50       IF NOT END OF CYLINDER
          LDC    E507        ERROR IN REQUEST
          RJM    ATERM       ABNORMAL TERMINATION (NO RETURN)
*         (NO RETURN FROM ATERM)


* TRANSFER DATA TO DISK.

 WRI50    BSS
          LDN    F.WRITE     ISSUE WRITE FUNCTION TO DISK CONTROLLER
          RJM    FUNC        ISSUE THE FUNCTION
 WRI56    BSS
          RJM    ACN         ACN    DC
          LDML   CHWDS,DEVICE  NUMBER OF CHANNEL WORDS
          RJM    OAPMBF      OAPM   BUFF,DC
          RJM    DCN         FJM    *,DC      DCN    40B+DC
          RJM    GENSTAT     GET GENERAL STATUS
          RJM    CFM         CFM    WRI57,DC
          UJN    WRI57       IF NO CHANNEL ERROR

          RJM    CHERO       RECORD CHANNEL ERROR
          UJN    WRI58       CHANNEL OUTPUT PARITY ERROR, UNRECOVERED

 WRI57    BSS
          LDDL   GNSTAT      GENERAL STATUS
          ZJN    WRI60       IF NO ERRORS
          RJM    /RES/RDERR  CHECK WRITE ERRORS
          ZJN    WRI60       IF ERROR WAS CORRECTED
          PJN    WRI56       IF RETRY OF WRITE.
                             'CONTINUE' FUNCTION HAS BEEN ISSUED
 WRI58    UJK    WRI100      UNRECOVERED ERROR

* UPDATE BYTES TRANSFERRED FROM PREVIOUS SECTOR WRITTEN.

 WRI60    BSS
          LDDL   RLAST
          NJK    WRI85       IF RECOVERY OF ERROR FROM LAST SECTOR

          LDDL   SECPOS
          NJN    WRI64       IF SOME DATA IS LEFT IN THE BUFFER,
                             DONT LET AN OVERLAY BE READ
          RJM    /RES/RECRS  CHECK IF AN ERROR WAS RECOVERED

* UPDATE SECTOR ADDRESS AND CHECK FOR END OF TRACK.

 WRI64    BSS
          LDML   SECSC,DEVICE  SECTOR INCREMENT
          RAML   SS+/SS/P.SECTOR,SELIN  INCREMENT SECTOR ADDRESS
          SBML   DVSEC,DEVICE  COMPARE WITH NUMBER OF SECTORS / TRACK
          MJN    WRI66       IF NOT END OF TRACK
          STML   SS+/SS/P.SECTOR,SELIN  SET SECTOR
          AODL   TRKEND      SET FLAG FOR END OF TRACK
          AOML   SS+/SS/P.TRACK,SELIN  INCREMENT HEAD ADDRESS

* UPDATE BYTES TRANSFERRED.

 WRI66    BSS
          LDDL   WDSS
          SHN    3
          RAML   RS+/RS/P.XFER+1  UPDATE BYTES TRANSFERRED IN RESPONSE STATUS
          SHN    -16
          RAML   RS+/RS/P.XFER
          LDN    0
          STDL   WDSS
          LDDL   SWFLG       WAS THIS THE FIRST WRITE AFTER A REQUEST SWITCH
          ZJN    WRI69       IF NOT THE FIRST WRITE AFTER A REQUEST SWITCH
          LDN    0
          STDL   SWFLG       CLEAR SWITCH FLAG
          RJM    SNDRSP      SEND RESPONSE TO CM
 WRI67    BSS
          AODL   NCOMRQ      INCREMENT NUMBER OF COMPLETED REQUESTS
          LDML   CURRQ       SAVE RMA OF PREVIOUS REQUEST
          STML   PRERQ
          LDML   CURRQ+1
          STML   PRERQ+1
          LDML   SS+/SS/P.REQ,SELIN  SAVE RMA OF CURRENT REQUEST
          STML   CURRQ
          LDML   SS+/SS/P.REQ+1,SELIN
          STML   CURRQ+1
 WRI69    BSS
 WRI68    BSS
          LDDL   WDS
          RADL   WDSS        SAVE WORDS TRANSFERRED THIS SECTOR
          LDDL   WDS
          RADL   DATADD+2    UPDATE CM ADDRESS
          LDDL   TWDS        UPDATE TOTAL WORDS LEFT TO TRANSFER
                               TO THIS CM ADDRESS.
          SBDL   WDS
          STDL   TWDS
          NJN    WRI75       IF MORE WORDS TO TRANSFER FROM THIS CM ADDRESS

* FOR 844, MAKE SURE A MULTIPLE OF 5 SECTORS IS TRANSFERRED IN
* ORDER TO INSURE THE CORRECT SECTOR ADDRESS FOR THE NEXT TRANSFER.

          LDDL   CMLISTL
          SBN    1
          NJN    WRI70       IF NOT END OF ADDRESS-LENGTH-PAIRS IN COMMAND
          LDDL   SECPOS      CHECK IF A PARTIAL SECTOR WAS TRANSFERRED TO CM
          ZJN    WRI63       IF FULL SECTOR WAS TRANSFERRED
 WRI63    BSS
          LDDL   DEVICE
          NJN    WRI70       IF NOT 844
          LDDL   SMSEC
          SBN    5
          ZJN    WRI70       IF A MULTIPLE OF 5 SECTORS HAS BEEN TRANSFERRED
          LDN    0           WRITE 0 WORDS FROM NEXT SECTOR
 WRI75    LJM    WRI30

* GET NEXT CM ADDRESS OF DATA AREA.

 WRI70    BSS
          SODL   CMLISTL     DECREMENT ADDRESS-LENGTH-PAIR COUNT
          ZJN    WRI74       IF END OF ADDRESS-LENGTH-PAIRS IN COMMAND
          LDDL   SECPOS      CHECK IF A PARTIAL SECTOR WAS TRANSFERRED
          ZJN    WRI72       IF FULL SECTOR WAS TRANSFERRED
          LDDL   SMSEC
          SBN    5
          NJN    WRI71
          STDL   SMSEC
 WRI71    BSS
          AODL   SMSEC       ADJUST SMALL SECTOR POSITION
 WRI72    BSS
          LDN    P.CM        BUMP INDEX TO NEXT CM ADDRESS
          RADL   CML
          ADC    -CMLN
          NJN    WRI73       IF MORE DATA TO TRANSFER
          RJM    GLIST       READ NEXT SECTION OF THE LIST WHICH
                             POINTS TO THE CM DATA AREA
 WRI73    UJK    WRI20

* GET NEXT COMMAND.

WRI74     BSS
          RJM    UNCMND      GET NEXT COMMAND
          ZJN    WRI80       IF NO MORE COMMANDS
          LDDL   FNC         GET COMMAND CODE
          SBN    1
          ZJK    WRI20       IF WRITE COMMAND
          LDC    E50A
          RJM    ATERM       ABNORMAL TERMINATION (NO RETURN)
*         (NO RETURN FROM ATERM)

* END OF DATA.  GET GENERAL STATUS FOR LAST SECTOR

 WRI80    BSS
          RJM    CSWIT       CHECK IF SWITCH TO NEXT REQUEST
          NJK    WRI5        IF SWITCH TO NEXT REQUEST
 WRI85    BSS
          RJM    GENSTAT     GET GENERAL STATUS
          ZJN    WRI90       IF NO ERRORS
          AODL   RLAST       SET NONZERO FOR ERROR ON LAST SECTOR
          RJM    /RES/RDERR  CHECK WRITE ERRORS
          ZJN    WRI90       IF ERROR WAS RECOVERED
          MJN    WRI100      IF UNRECOVERED ERROR
          UJK    WRI50       IF RETRY OF WRITE

* UPDATE BYTES TRANSFERRED FROM LAST SECTOR.

 WRI90    BSS
          RJM    /RES/RECRS  CHECK IF ERROR WAS RECOVERED


 WRI95    BSS
          LDDL   WDSS
          SHN    3
          RAML   RS+/RS/P.XFER+1  UPDATE BYTES TRANSFERRED IN RESPONSE STATUS
          SHN    -16
          RAML   RS+/RS/P.XFER
          UJK    WRIX

* UNRECOVERED WRITE ERROR.

 WRI100   BSS
          RJM    RECS        ATTEMPT TO RECOVER
*         (NO RETURN FROM RECS.)
          EJECT
** NAME-- CSWIT
*
** PURPOSE-- CHECK IF A SWITCH SHOULD BE MADE TO THE NEXT
*            REQUEST DURING THE SECTOR GAP.
*            AND, IF SO, MAKE THE SWITCH TO THE NEXT REQUEST.
*
** EXIT-- A REGISTER = 0, IF NOT SWITCH.
*         A REGISTER NONZERO, IF SWITCH.
          SPACE  6
 CSWX     LJM    **
 CSWIT    EQU    *-1
          LDDL   NUMCM       CHECK IF MORE COMMANDS TO PROCESS
          ZJN    CSW6        IF END OF COMMANDS
 CSW5     BSS
          LDN    0           EXIT A REGISTER = 0
          UJK    CSWX


* RE-READ THE SWITCH FLAG AND LINKAGE WORDS.

 CSW6     BSS
          LDML   RECOV
          NJK    CSW5        IF IN ERROR RECOVERY, DON'T STREAM
          LDN    2
          STDL   WC
          LOADF  SS+/SS/P.REQ,SELIN  REREAD SWITCH FLAG IN REQUEST
          ADN    2
          CRML   RQ+2*4,WC
          SBN    4
          CRML   RQ,WC
          LDML   RQ+/RQ/P.SWIT  CHECK IF REQUEST SWITCH FLAG SET
          SHN    -16+/RQ/N.SWIT+/RQ/L.SWIT
          ERRNZ  -1+/RQ/N.SWIT+/RQ/L.SWIT
          STDL   SWFLG       SAVE SWITCH FLAG
          ZJK    CSWX        IF SWITCH FLAG IS NOT SET
          LDDL   FNC         FUNCTION CODE
          NJN    CSW10       IF NOT READ
          AODL   NCOMRQ      INCREMENT NUMBER OF COMPLETED REQUESTS
          LDML   CURRQ       SAVE RMA OF PREVIOUS REQUEST
          STML   PRERQ
          LDML   CURRQ+1
          STML   PRERQ+1
          LDML   RQ+/RQ/P.NEXT  SAVE RMA OF NEXT REQUEST
          STML   CURRQ
          LDML   RQ+/RQ/P.NEXT+1
          STML   CURRQ+1
 CSW10    BSS

* THIS PP TRANSFERRED NEXT TO THE LAST SECTOR.
* GET NEXT REQUEST.
* PREPARE SS ENTRY.

          LDML   RQ+/RQ/P.NEXT  PUT RMA OF NEXT REQUEST IN SS TABLE
          STML   SS+/SS/P.REQ,SELIN
          LDML   RQ+/RQ/P.NEXT+1
          STML   SS+/SS/P.REQ+1,SELIN
          LDML   RQ+/RQ/P.NEXTPV  PUT PVA OF NEXT REQUEST IN SS TABLE
          STML   SS+/SS/P.PVA,SELIN
          LDML   RQ+/RQ/P.NEXTPV+1
          STML   SS+/SS/P.PVA+1,SELIN
          LDML   RQ+/RQ/P.NEXTPV+2
          STML   SS+/SS/P.PVA+2,SELIN
          RJM    UREQ        READ NEXT REQUEST INTO RQ
          LDML   RQ+/RQ/P.CYL
          SBML   SS+/SS/P.CYL,SELIN  CYLINDER ADDRESS
          ZJN    CSW11       IF VALID CYLINDER ADDRESS
          RJM    HALT        INVALID CYLINDER ADDRESS
*         (NO RETURN FROM HALT.)

 CSW11    BSS
          LDML   RQ+/RQ/P.TRACK
          SBML   SS+/SS/P.TRACK,SELIN  TRACK ADDRESS
          ZJN    CSW12       IF VALID TRACK ADDRESS
          RJM    HALT        INVALID TRACK ADDRESS
*         (NO RETURN FROM HALT.)

 CSW12    BSS
          LDML   RQ+/RQ/P.SECTOR
          SBML   SS+/SS/P.SECTOR,SELIN  SECTOR ADDRESS
          ZJN    CSW13       IF VALID SECTOR ADDRESS
          RJM    HALT        INVALID SECTOR ADDRESS
*         (NO RETURN FROM HALT.)

 CSW13    BSS
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
          LDDL   FNC         FUNCTION CODE
          NJN    CSW30       IF NOT READ
          RJM    SNDRSP      SEND RESPONSE TO CM
 CSW30    BSS
          LDN    1           EXIT A REGISTER NONZERO
          UJK    CSWX
          EJECT
** NAME-- SNDRSP
*
** PURPOSE-- SEND THE RESPONSE TO CM.
*            USED WHEN SWITCHING TO THE NEXT REQUEST.
          SPACE  6
 SNDX     LJM    **
 SNDRSP   EQU    *-1
          RJM    RESP        SEND RESPONSE TO CM
          RJM    RESPIN      UPDATE -IN- POINTER IN RESPONSE BUFFER
          RJM    SRESP       SET UP RESPONSE BUFFER
          UJK    SNDX
          EJECT
          ERRPL  *-OVAD1     READ - WRITE
          QUAL   *

          OVERLAY (SELECT REQUEST),OVAD1
          ROUTINE SELRQO
          CON    SELRQOO

** NAME-- SELRQ.
*
** PURPOSE-- SELECTS THE FIRST REQUEST IN THE CHAIN FOR THE
*            CURRENT REQUEST.
*
** INPUTS-- SS+P.UQT,SELIN = POINTER TO UNIT QUEUE TABLE.
*
** OUTPUTS-- RQ = CURRENT REQUEST.
*            SS+/SS/P.REQ
*            SS+/SS/P.CYL
*            SS+/SS/P.TRACK
*            SS+/SS/P.SECTOR
*            SS+/SS/M.CUR
*            SS+/SS/M.WRITE
*
** NOTE-- ASSUMES UNIT QUEUE LOCK HAS BEEN SET.
          SPACE  6
          QUAL   SL
          QUAL   *
 SELRQ1   BSS
          QUAL   SL

* READ RMA OF NEXT REQUEST FROM UNIT QUEUE.
* SET CURRENT REQUEST = FIRST REQUEST IN QUEUE.

          LDML   SS+/SS/P.QSTRT,SELIN  SET CURRENT QUEUE POINTER TO START OF CHAIN
          STML   SS+/SS/P.QP,SELIN
          LDML   SS+/SS/P.QSTRT+1,SELIN
          STML   SS+/SS/P.QP+1,SELIN
          LOADF  SS+/SS/P.QP,SELIN   LOAD CM ADDRESS OF UNIT QUEUE TABLE
          CRDL   T1          READ RMA OF FIRST REQUEST IN CHAIN
          ADN    1
          CRDL   T1+4
          LDML   SS+/SS/P.CUR,SELIN  CLEAR 'CURRENT REQUEST' AND -WRITE- FLAG
          LPC    -/SS/K.CUR-/SS/K.WRITE
          STML   SS+/SS/P.CUR,SELIN
          LDDL   T7
          STML   SS+/SS/P.REQ,SELIN  SET RMA OF CURRENT REQUEST
          LDDL   T8
          STML   SS+/SS/P.REQ+1,SELIN
          ADDL   T7
          ZJK    /RES/SELRQX  IF QUEUE EMPTY
          LDDL   T2          SET PVA OF CURRENT REQUEST
          STML   SS+/SS/P.PVA,SELIN
          LDDL   T3
          STML   SS+/SS/P.PVA+1,SELIN
          LDDL   T4
          STML   SS+/SS/P.PVA+2,SELIN
          RJM    UREQ        READ SELECTED REQUEST INTO RQ
          LDML   RQ+/RQ/P.CYL
          STML   SS+/SS/P.CYL,SELIN  CYLINDER ADDRESS OF CURRENT REQUEST
          LDML   RQ+/RQ/P.TRACK
          STML   SS+/SS/P.TRACK,SELIN  TRACK ADDRESS OF CURRENT REQUEST
          LDML   RQ+/RQ/P.SECTOR
          STML   SS+/SS/P.SECTOR,SELIN  SECTOR ADDRESS OF CURRENT REQUEST

* SET /SS/M.WRITE FOR ALL WRITE OPERATIONS.

          LDML   CM+/CM/P.CODE  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          ERRNZ  /CM/L.CODE
          ADC    -C.WRITE
          NJN    SELRQ20     IF COMMAND CODE .NE. WRITE
          LDK    /SS/K.WRITE+/SS/K.CUR  SET WRITE FLAG AND
                                        CURRENT REQUEST FLAG
          ERRNZ  /SS/P.WRITE-/SS/P.CUR
          UJN    SELRQ30

* SET CURRENT REQUEST FLAG.

 SELRQ20  BSS
          LDK    /SS/K.CUR   SET CURRENT REQUEST FLAG
 SELRQ30  RAML   SS+/SS/P.CUR,SELIN
          UJK    /RES/SELRQX



          EJECT
          QUAL   *
          ERRPL  *-BUFF      IF > 0, SELRQ IS TOO LONG

          OVERLAY (RECOVER READ/WRITE ERRORS),OVAD1
          ROUTINE RDERRO
          CON    RDERROO

** NAME-- RDERR
*
** PURPOSE-- CHECK GENERAL STATUS ERRORS AFTER A READ OR WRITE FUNCTION.
*            READ EXTENDED DETAILED STATUS.
*
** INPUT-- GNSTAT = GENERAL STATUS
*
** EXIT-- A REGISTER = 0, IF ERROR WAS CORRECTED
*         A REGISTER .GT. 0, IF 'CONTINUE' FUNCTION WAS ISSUED TO
*                RETRY THE DATA TRANSFER.
*         A REGISTER .LT. 0, IF UNRECOVERED ERROR.
          SPACE  6
 RDERR1   BSS
          QUAL   RD


          AODL   ERRCNT      INCREMENT ERROR COUNTER
          LDDL   GNSTAT      GET GENERAL STATUS
          ZJK    /RES/RDEX   IF NO ERROR, A REGISTER = 0
          SHN    17-11
          MJN    RDE20       IF ABNORMAL TERMINATION
 RDE10    BSS
          LDC    -1          INVALID STATUS
 RDE15    UJK    /RES/RDEX   EXIT, A REGISTER .LT. 0

* CHECK IF RECOVERY IS IN PROGRESS.

 RDE20    BSS
          SHN    11-9        CHECK FOR NON-RECOVERABLE ERROR
          PJK    RDE26       IF NOT NON-RECOVERABLE ERROR

* THIS IS A NON-RECOVERABLE ERROR.
* IF THE FUNCTION = READ FLAW MAP, TRY VARIOUS READ-TYPE FUNCTIONS.

          LDDL   FNC         CHECK IF READ FLAW MAP
          SBN    2
          NJK    RDE10       IF NOT READ FLAW MAP
          LDML   RS+/RS/P.DET2  CHECK FOR ADDRESS ERROR
          LPN    10B
          ZJK    RDE10       IF NOT ADDRESS ERROR
          AODL   MAPC        INCREMENT READ-TYPE FUNCTION INDEX
          SBN    MAPLN       CHECK IF ALL FUNCTIONS HAVE BEEN TRIED
          PJK    RDE10       IF ALL READ-TYPE FUNCTIONS HAVE BEEN TRIED
          SODL   ERRCNT      DO NOT REPORT THIS ERROR
          LDN    8
          STML   RS+/RS/P.RESPL  SET RESPONSE LENGTH FOR NORMAL RESPONSE
          RJM    /RES/SEEKON ISSUE SEEK AND RECOVER SEEK ERRORS
          LDML   MAPFN,MAPC  ISSUE NEXT READ TYPE FUNCTION
 RDE25    BSS
          RJM    FUNC
          AOML   RS+/RS/P.STRY  INCREMENT SECTOR RETRY COUNT
          LDN    1           EXIT WITH A REGISTER .GT. 0
          UJK    RDE15

* CHECK IF RECOVERY IS IN PROGRESS.  IF SO, ISSUE THE 'CONTINUE'
* FUNCTION.

 RDE26    BSS
          SHN    9-8
          PJN    RDE30       IF NOT 'RECOVERY IN PROGRESS'
          LDN    F.CONT      ISSUE CONTINUE FUNCTION
          UJK    RDE25

 RDE30    BSS
 Z4       IFNE   CONTYP,2
          UJK    RDE10       IF INVALID STATUS
 Z4       ELSE
 Z5       IFEQ   HARDW,1
          SHN    8-5         CHECK FOR CORRECTABLE CHECKWORD ERROR
          PJK    RDE10       IF INVALID STATUS

* THE CORRECTION VECTORS AND BUFFER ADDRESS WHICH APPEAR IN THE
* DETAILED STATUS ARE SET UP FOR 12-BIT DATA BYTES.  SINCE THE
* DATA WAS READ PACKED INTO 16-BIT BYTES, A NEW BUFFER ADDRESS AND
* NEW CORRECTION VECTORS MUST BE COMPUTED.
*
* COMPUTE BUFFER ADDRESS AND PUT IN T4.
* BUFFER ADDRESS = BUFF + P.WRDAD - (P.WRDAD + 3)/4.

          LDML   RS+/RS/P.DET2+P.WRDAD  PP WORD ADDRESS
                               OF CORRECTABLE READ ERROR
          ADN    3
          SHN    -2
          STDL   T4
          LDC    BUFF
          ADML   RS+/RS/P.DET2+P.WRDAD
          SBDL   T4
          STDL   T4
          LDML   RS+/RS/P.DET2+P.WRDAD  IF LAST BYTE, ADD 1 TO
                               COMPUTED ADDRESS
          ADC    -321
          NJN    RDE34       IF NOT THE LAST BYTE
          AODL   T4

* SET UP SHIFTED VECTORS AND PUT IN T1, T2, T3.

 RDE34    BSS
          LDN    0
          STDL   T3
          LDML   RS+/RS/P.DET2+P.WRDAD  WORD ADDRESS OF ERROR
          ADC    -319        SPECIAL CASE THE LAST 3 BYTES
          MJN    RDE50       IF NOT THE LAST 3 BYTES
          SBN    4
          MJN    RDE38       IF THE LAST 3 BYTES
*                            ERROR, WORD ADDRESS OUT OF RANGE
          RJM    RECS        ABNORMAL TERMINATION  (NO RETURN)
*         (NO RETURN FROM RECS.)

* THE LAST 3 WORDS MUST BE SPECIAL CASED, BECAUSE THE LAST 2 12-BIT
* BYTES WERE READ SEPARATELY.

 RDE38    BSS
          LDML   RS+/RS/P.DET2+P.VECT1  FIRST WORD OF CORRECTION VECTOR
          STDL   T1
          LDML   RS+/RS/P.DET2+P.VECT2  2ND WORD OF CORRECTION VECTOR
          STDL   T2

* CORRECT THE DATA.

 RDE40    BSS
          LDIL   T4          FIRST BUFFER WORD TO CORRECT
          LMDL   T1          CORRECT WITH 1ST VECTOR WORD
          STIL   T4
          AODL   T4
          LDIL   T4          2ND BUFFER WORD TO CORRECT
          LMDL   T2          2ND PART OF CORRECTION VECTOR
          STIL   T4
          AODL   T4
          LDIL   T4          3RD BUFFER WORD TO CORRECT
          LMDL   T3          3RD PART OF CORRECTION VECTOR
          STIL   T4
 Z5       ENDIF
          LDN    0           EXIT WITH A REGISTER = 0
          UJK    /RES/RDEX

* THE PATTERN REPEATS EVERY 4 12-BIT BYTES.
* SHIFT THE CORRECTION VECTORS FOR EACH OF THE 4 PATTERNS.

 Z6       IFEQ   HARDW,1
 RDE50    BSS
          LDML   RS+/RS/P.DET2+P.WRDAD  WORD ADDRESS OF ERROR
          LPN    3
          NJN    RDE60       IF NOT THE 1ST PATTERN
          LDML   RS+/RS/P.DET2+P.VECT1
          SHN    4
          STDL   T1
          LDML   RS+/RS/P.DET2+P.VECT2
          SHN    -8
          RADL   T1
          LDML   RS+/RS/P.DET2+P.VECT2
          LPC    377B
          SHN    8
          STDL   T2
          UJK    RDE40

 RDE60    BSS
          SBN    1
          NJN    RDE70       IF NOT THE 2ND PATTERN
          LDML   RS+/RS/P.DET2+P.VECT1
          SHN    -8
          STDL   T1
          LDML   RS+/RS/P.DET2+P.VECT1
          LPC    377B
          SHN    8
          STDL   T2
          LDML   RS+/RS/P.DET2+P.VECT2
          SHN    -4
          RADL   T2
          LDML   RS+/RS/P.DET2+P.VECT2
          LPN    17B
          SHN    12
          STDL   T3
          UJK    RDE40

 RDE70    BSS
          SBN    1
          NJN    RDE80       IF NOT THE 3RD PATTERN
          LDML   RS+/RS/P.DET2+P.VECT1
          SHN    -4
          STDL   T1
          LDML   RS+/RS/P.DET2+P.VECT1
          LPK    17B
          SHN    12
          ADML   RS+/RS/P.DET2+P.VECT2
          STDL   T2
          UJK    RDE40

 RDE80    BSS
          LDML   RS+/RS/P.DET2+P.VECT1  1ST WORD OF CORRECTION VECTOR
          STDL   T1
          LDML   RS+/RS/P.DET2+P.VECT2  2ND WORD OF CORRECTION VECTOR
          SHN    4
          STDL   T2
          UJK    RDE40
 Z6       ENDIF
 Z4       ENDIF


          EJECT
          QUAL   *
          ERRPL  *-BUFF      IF > 0, RDERR IS TOO LONG

          OVERLAY (RECOVER ERRORS),BUFF
          ROUTINE RECSO
          QUAL   RC
          QUAL   *
          EJECT
 FUNERR   BSS
          QUAL   RC
          LDML   FUNTO
          NJN    FUN60       IF NOT FIRST FUNCTION TIMEOUT
          LDK    /RS/K.FTO   SET FUNCTION TIMEOUT FLAG IN RESPONSE
          RJM    SERR        PUT ERROR ID IN RESPONSE
          LDML   RS+/RS/P.FUNTO
          NJN    FUN45       IF FUNCTION CODE ALREADY IN RESPONSE BUFFER
          LDDL   FUNCD       PUT FUNCTION CODE IN RESPONSE BUFFER
          STML   RS+/RS/P.FUNTO
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
 FUN45    BSS
          AOML   FUNTO       SET FUNC PROCESSING FLAG
          AODL   FNERR       SET FUNCTION TIMEOUT FLAG
          RJM    GENSTAT     READ GENERAL AND DETAILED STATUSES
          LDML   RS+/RS/P.DET2+13-1
          SHN    17-11
          PJN    FUN60       IF DATA IS NOT IN CONTROLLER BUFFER
          LDML   RS+/RS/P.FUNTO
          SBN    F.WRITE
          NJN    FUN60       IF NOT FORCED TIMEOUT ON WRITE FUNCTION
          STDL   FNERR       CLEAR FUNCTION TIMEOUT FLAG
          UJN    FUN70

 FUN60    BSS
          AOML   RS+/RS/P.STRY  INCREMENT RETRY COUNT
 H1       IFNE   CONTYP,2
 H9       IFEQ   RAM,1
 H2       IFEQ   HARDW,1
          LDK    F.AUTOP     SEND AUTOLOAD FUNCTION
          RJM    FUNC
          ACN    DC
          PAUSE  5           DELAY 5 MICROSECONDS
          DCN    40B+DC

          LDN    F.AUTDP     SEND AUTODUMP FUNCTION
          RJM    FUNC
          LDC    12288       NUMBER OF CHANNEL WORDS TO INPUT
          STDL   T1
          ACN    DC
 FUN65    BSS
          IAN    DC          READ CONTROLLER MEMORY
          SODL   T1
          NJN    FUN65       IF NOT ALL WORDS READ
          DCN    40B+DC
          LDK    F.CHST      INPUT PROCESSOR CHANNEL STATUS
          RJM    FUNC
          ACN    DC
          IAN    DC
          DCN    40B+DC
 H2       ELSE
          LDN    20B
 H2       ENDIF
          SHN    17-4        CHECK BIT 4
          PJN    FUN70       IF NOT RAM PARITY ERROR
          LDK    /RS/K.RAM   PUT RAM PARITY FLAG IN RESPONSE
          RJM    SERRID      ERROR ID
 H9       ENDIF
 H1       ENDIF
 FUN70    BSS
          LDN    0
          STML   FUNTO
          RJM    RECS        ATTEMPT TO RECOVER
*         (NO RETURN FROM RECS.)

          SPACE  4
          EJECT
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                   .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
          QUAL   *
 SCL10    BSS
          QUAL   RC
          LDDL   CUNITS
          ZJN    SCL35       IF NO UNITS
          LDN    C.CHCNT
          STML   CHLCNT      NUMBER OF REQUESTS TO PROCESS BEFORE
                             GIVING UP CHANNEL
          LDDL   CUNITS
          ZJN    SCL35       IF NO UNITS
          LDN    6           SET TIMEOUT DELAY TO 5 SECONDS ON S1
          STDL   P1
          STDL   P2
 SCL30    BSS
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    SCL40       IF LOCK WAS NOT SET
          AOML   CHLOCK      SET FLAG IF LOCK WAS SET
          LDN    0
          STML   SHARECH     CLEAR SHARE CHANNEL FLAG
 SCL35    BSS
          LDN    0
          UJK    /RES/SCLX   EXIT, A REGISTER = 0, LOCK WAS SET

 SCL40    BSS
          SODL   P1
          NJK    SCL30
          SODL   P2
          NJK    SCL30
          LDN    1           TIMEOUT ON TRYING TO GET CHANNEL LOCK
          UJK    /RES/SCLX   EXIT A REGISTER NONZERO
          EJECT
** NAME-- SEEKON
*
** PURPOSE-- ISSUE SEEK, CHECK FOR ERRORS, WAIT FOR ON-CYLINDER.
          SPACE  6
 SEEKON   CON    0
 SEKO10   BSS
          LDML   SEEKON
          STML   /RES/SEEKON
          RJM    SEEKCK      ISSUE SEEK AND RECOVER SEEK ERRORS
          LDDL   GNSTAT      GENERAL STATUS
          NJN    SEKO10      IF NOT ON CYLINDER
          UJK    /RES/SEKOX
          EJECT
** NAME-- SEEKERR.
*
** PURPOSE-- ISSUE A SEEK AND RECOVER ANY SEEK ERRORS.
          SPACE  6
 SEEKCK   CON    0
          LDML   SEEKCK
          STML   /RES/SEEX+1
          QUAL   *
 SEEKERR1 BSS
          QUAL   RC
          LDN    6           SET TIMEOUT FOR CONTROLLER RESERVE
          STML   CRSV1       = 10 SECONDS ON S1
          STML   CRSV2
 SEE10    BSS
          RJM    GENSTAT     RESERVE THE CONTROLLER
          SHN    17-10
          PJN    SEE16       IF MULTI-ACCESS COUPLER CONNECTED
          RJM    /RES/PPREQ  CHECK FOR PP REQUESTS
          SOML   CRSV2       DECREMENT CONTROLLER RESERVE TIMEOUT COUNTERS
          NJN    SEE10       IF NOT TIMED OUT
          SOML   CRSV1
          NJN    SEE10       IF NOT TIMED OUT
          LJM    SEE30       IF TIMEOUT OF CONTROLLER RESERVE

 SEE14    BSS
          RJM    RECRS       SEND ANY RECOVERED ERROR RESPONSES
          UJK    /RES/SEEX

* LOAD CONTROLWARE BEFORE THE FIRST REQUEST WHEN THE DRIVER IS LOADED.

 SEE16    BSS
          LDML   ILOAD
          ADML   RECOV       DONT LOAD CONTROLWARE IF IN RECOVERY
          NJN    SEE17       IF CONTROLWARE HAS BEEN LOADED
          RJM    LDCN        LOAD CONTROLWARE
          AOML   ILOAD       SET FLAG FOR INITIAL CONTROLWARE LOAD

* GET UNIT RESERVE.

 SEE17    BSS
          LDC    37500       SET TIMEOUT FOR UNIT RESERVE
          STML   CRSV2       = 10 SECONDS ON S1
 SEE20    BSS
          RJM    /RES/PPREQ  CHECK FOR PP REQUESTS
          SOML   CRSV2       DECREMENT UNIT RESERVE TIMEOUT COUNTERS
          ZJN    SEE40       IF TIMED OUT
          RJM    SEEK        ISSUE SEEK
          RJM    GENSTAT     READ GENERAL STATUS
          SHN    17-3
          MJN    SEE20       IF UNIT RESERVED
          RJM    CKSTAT      PROCESS GENERAL STATUS ERRORS
          PJK    SEE14       IF NO ERROR
          UJK    SEE20       RETRY THE SEEK


* CONTROLLER RESERVED FOR MORE THAN 10 SECONDS.

 SEE30    BSS
          LDK    /RS/K.CRS   SET CONTROLLER RESERVED FLAG IN RESPONSE
          RJM    SERRID      ERROR ID
          UJK    SEE50

* UNIT RESERVED FOR MORE THAN 10 SECONDS.

 SEE40    BSS
          LDK    /RS/K.URS   SET UNIT RESERVED FLAG IN RESPONSE
          RJM    SERRID      ERROR ID
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          AODL   ERRCNT      INCREMENT RETRY COUNT
          SBN    UTRY
          PJK    SEE50       IF UNRECOVERED REQUEST
          AOML   RS+/RS/P.STRY  INCREMENT RETRY COUNT
          LOADR  SS+/SS/P.UQT,SELIN  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.SHARE  READ SHARE UNIT FLAG
          CRDL   T1
          LDDL   T1
          SHN    17-15
          MJN    SEE60       IF SHARING UNIT, DO NOT CLEAR OPPOSITE RESERVE

* CLEAR UNIT RESERVE ON OPPOSITE ACCESS.

          LDK    /RS/K.CRES  SET -CLEAR OPPOSITE UNIT RESERVE ATTEMPT-
                             IN DETAILED STATUS
          RJM    SERRID      ERROR ID
          LDK    K.CPRES     CLEAR UNIT RESERVE ON OPPOSITE ACCESS
          RAML   SS+/SS/P.UNIT,SELIN
          RJM    SEEK        CLEAR UNIT RESERVE ON OPPOSITE ACCESS
          LDML   SS+/SS/P.UNIT,SELIN
          LPC    -K.CPRES
          STML   SS+/SS/P.UNIT,SELIN
          UJK    SEE17       RETRY

* UNRECOVERED UNIT RESERVE.

 SEE50    BSS
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    RECS        ABNORMAL TERMINATION
*         (NO RETURN FROM RECS.)

* SHARING UNIT WITH MALET OR DFT.  DO NOT CLEAR RESERVE.
* SEND AN INTERMEDIATE RESPONSE.
* LEAVE THE REQUEST ON THE QUEUE, AND TRY AGAIN LATER.

 SEE60    BSS
          RJM    LTERM       LEAVE REQUEST ON THE UNIT QUEUE




          EJECT
** NAME-- RECS
*
** PURPOSE-- GENERAL ERROR RECOVERY
          SPACE  6
          QUAL   *
 RECS1    BSS                CONTINUATION OF RECS ROUTINE
          QUAL   RC
          LDDL   NORQ
          NJK    RECE        IF NO REQUEST WAS BEING PROCESSED
                             RELOAD CONTROLWARE
          LDML   RECOV       INDEX TO ERROR RECOVERY PROCEDURE
          STDL   T1
          LDML   RPROC,T1    ERROR RECOVERY PROCEDURE
          STML   REC10
          LJM    **          EXECUTE NEXT STEP IN ERROR RECOVERY
 REC10    EQU    *-1
          SPACE  6

* RETRY THE REQUEST.

 RECA     BSS
          LDML   SS+/SS/P.CONF,SELIN  CHECK IF DOING INITIAL CONFIDENCE TEST
          SHN    /SS/L.CONF+2
          PJN    REC14       IF NOT DOING INITIAL CONFIDENCE TEST

          LDML   NMED        NUMBER OF MEDIA ERRORS
          SBN    NMEDL+1     NUMBER OF MEDIA ERRORS ALLOWED
          PJN    REC14       IF LIMIT OF MEDIA ERRORS HAS BEEN REACHED
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          LOADOVL CONFO      LOAD CONFIDENCE TEST OVERLAY
          RJM    /CF/CREC    HANDLE CONFIDENCE TEST ERRORS
          UJN    REC25       CONFIDENCE TEST WAS SUCCESSFUL


 REC14    BSS
          AOML   RECOV       INDEX TO NEXT RECOVERY PROCEDURE

 REC15    BSS
          LDDL   SIO
          NJN    REC20       IF REQUEST HAS BEEN SET UP
          RJM    SFRESP      SET UP THE STATUS RESPONSE BUFFER
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
          LDDL   SELIN
          STDL   SELECT      SET SS INDEX TO SELECTED REQUEST
          AODL   SIO         SET -START I/O- FLAG
 REC20    BSS
          LDML   SS+/SS/P.CONF,SELIN  CHECK IF DOING INITIAL CONFIDENCE TEST
          SHN    /SS/L.CONF+2
          MJN    REC25       IF DOING INITIAL CONFIDENCE TEST
          RJM    RSTRQ       RESTART THE REQUEST
          LJM    MAINC       RETRY THE REQUEST

* RESTART CONFIDENCE TEST.

 REC25    BSS
          LJM    MAINA
          SPACE  6
* RUN THE CONFIDENCE TEST.

 RECB     BSS
          LDML   SS+/SS/P.CONF,SELIN  CHECK IF DOING INITIAL CONFIDENCE TEST
          SHN    /SS/L.CONF+2
          MJK    RECE        IF DOING INITIAL CONFIDENCE TEST
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          LDN    R20
          STML   RECOV       INDEX TO NEXT RECOVERY PROCEDURE
          LOADOVL CONFO      LOAD CONFIDENCE TEST OVERLAY
          RJM    /CF/CONFR   RUN THE CONFIDENCE TEST

* CONFIDENCE TEST WAS SUCCESSFUL.

 RECB10   BSS
          LDN    R10
          STML   RECOV       INDEX TO NEXT RECOVERY PROCEDURE
          UJK    REC15       RETRY THE REQUEST

          SPACE  6
* UNRECOVERED MEDIA ERROR.

 RECC     BSS
          LDK    /RS/K.DATERR  SOFTWARE FLAW THE ALLOCATION UNIT
          RJM    SERR        ERROR ID
          LDK    /RS/K.UNMED  UNRECOVERED MEDIA ERROR
          RJM    SERRID      ERROR ID
          RJM    HTERM       UNRECOVERED ERROR
*         (NO RETURN FROM HTERM.)
          SPACE  6
* CONFIDENCE TEST FAILED.
* RELOAD THE CONTROLLER.

 RECD     BSS
          LDML   NMED        NUMBER OF MEDIA ERRORS
          SBN    NMEDL+1     NUMBER OF MEDIA ERRORS ALLOWED
          PJN    RECD10      IF LIMIT OF MEDIA ERRORS HAS BEEN REACHED
          RJM    INTRS       SEND RESPONSE FOR CONFIDENCE TEST FAILURE
          LOADOVL CONFO      LOAD CONFIDENCE TEST OVERLAY
          RJM    /CF/CREC    HANDLE CONFIDENCE TEST ERRORS
          LDML   NCPERR      NUMBER OF SECTORS SUCCESSFULLY COMPARED
          NJK    RECB10      IF CONFIDENCE TEST WAS SUCCESSFUL



 RECD10   BSS
          LDML   SS+/SS/P.CONF,SELIN  CLEAR CONFIDENCE TEST FLAG
          LPC    -/SS/K.CONF
          STML   SS+/SS/P.CONF,SELIN

* LOAD CONTROLWARE.

 RECE     BSS
          RJM    FAILAD      MAKE SURE RESPONSE IS SENT AFTER
                             CONTROLWARE IS LOADED
          LDN    R30
          STML   RECOV
          AODL   LDC         INCREMENT LOAD CONTROLLER RETRY COUNTER
          SBN    CNTRY+1
          MJN    REC30       IF LOAD CONTROLLER RETRY NOT EXHAUSTED
          RJM    OTERM       TURN OFF ALL UNITS ON THE CONTROLLER
*         (NO RETURN FROM OTERM.)

 REC30    BSS
          RJM    LDCN        LOAD THE CONTROLLER

* THE CONTROLLER HAS BEEN SUCCESSFULLY LOADED.

          LDML   SS+/SS/P.CONF,SELIN  CHECK IF DOING INITIAL CONFIDENCE TEST
          SHN    /SS/L.CONF+2
          PJN    REC40       IF NOT DOING INITIAL CONFIDENCE TEST
          RJM    INTRS       LOG CONTROLLER LOADED MESSAGE

 REC40    BSS
          LDN    0
          STDL   LDC         ZERO OUT LOAD CONTROLLER RETRY COUNTER
          LDDL   NORQ
          ZJK    RECA        IF A REQUEST WAS BEING PROCESSED
          LDN    0           IF NO REQUEST WAS BEING PROCESSED
          STDL   NORQ        CLEAR NO REQUEST FLAG
          LJM    MAINA       GO TO MAIN LOOP


* UNRECOVERED ERROR.

 RECH     BSS
          RJM    UTERM       UNRECOVERED ERROR, TURN OFF UNIT
*         (NO RETURN FROM UTERM.)
          EJECT
* SEQUENCE TO ERROR RECOVERY PROCEDURES.
          SPACE  6
 RPROC    BSS
          CON    RECA        RETRY THE REQUEST
          CON    RECA        RETRY THE REQUEST
          CON    RECA        RETRY THE REQUEST
          CON    RECB        RUN THE CONFIDENCE TEST
 RP10     CON    RECC        UNRECOVERED MEDIA ERROR
 RP20     CON    RECD        CONFIDENCE TEST FAILED
 RP30     CON    RECE        RELOAD THE CONTROLLER
          CON    RECA        RETRY THE REQUEST
          CON    RECH        UNRECOVERED ERROR, DOWN THE UNIT


 R10      EQU    RP10-RPROC
 R20      EQU    RP20-RPROC
 R30      EQU    RP30-RPROC
          EJECT
** NAME-- RSTRQ
*
** PURPOSE-- INCREMENT REQUEST RETRY COUNTER.  IF RETRIES HAVE
*            NOT BEEN EXHAUSTED, RESTART THE REQUEST.
          SPACE  6
 RSTRQ    CON    0
          LDML   RSTRQ
          STML   /RES/RSTX+1
          AOML   RQTRY       INCREMENT REQUEST RETRY COUNTER

* RESTART REQUEST FROM BEGINNING.

          LDML   CURRQ       RESTORE RMA OF CURRENT REQUEST
          STML   SS+/SS/P.REQ,SELIN
          LDML   CURRQ+1
          STML   SS+/SS/P.REQ+1,SELIN
          LDML   RS+/RS/P.PVA  RESTORE PVA OF CURRENT REQUEST
          STML   SS+/SS/P.PVA,SELIN
          LDML   RS+/RS/P.PVA+1
          STML   SS+/SS/P.PVA+1,SELIN
          LDML   RS+/RS/P.PVA+2
          STML   SS+/SS/P.PVA+2,SELIN
          RJM    UREQ        READ UNIT REQUEST
          LDML   RQ+/RQ/P.CYL  RESTORE CYLINDER ADDRESS
          STML   SS+/SS/P.CYL,SELIN
          LDML   RQ+/RQ/P.TRACK  RESTORE TRACK ADDRESS
          STML   SS+/SS/P.TRACK,SELIN
          LDML   RQ+/RQ/P.SECTOR  RESTORE SECTOR ADDRESS
          STML   SS+/SS/P.SECTOR,SELIN

          LDML   RECOV
          SBN    R10
          ZJN    RST20       IF CONFIDENCE TEST WAS JUST RUN AND WAS
                             SUCCESSFUL
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
 RST20    BSS
          RJM    SRESP       SET UP RESPONSE BUFFER
          RJM    SETADD      PUT STARTING ADDRESS IN RESPONSE BUFFER
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
          RJM    SEEKON      ISSUE SEEK AND RECOVER SEEK ERRORS
          UJK    /RES/RSTX   RETURN A REGISTER = 0 TO RESTART REQUEST
          EJECT
** NAME-- ATERM
*
** PURPOSE-- ABNORMAL TERMINATION FOR INTERFACE ERRORS.
          SPACE  6
          QUAL   *
 ATERM1   BSS
          QUAL   RC
          LDK    /RS/K.INTERR  INTERFACE ERROR
          RJM    SERR        ERROR ID
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    UTERM       DISABLE UNIT
*         (NO RETURN FROM UTERM.)
          EJECT
** NAME-- HTERM
*
** PURPOSE-- ABNORMAL TERMINATION FOR HARDWARE ERRORS.
          SPACE  6
          QUAL   *
 HTERM1   BSS
          QUAL   RC


* SET ABNORMAL RESPONSE LENGTH.

          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          LDML   RS+/RS/P.PVA  PVA OF REQUEST
          ADML   RS+/RS/P.PVA+1
          ADML   RS+/RS/P.PVA+2
          NJN    HTERM90     IF UNRECOVERED REQUEST
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          LJM    TERMB

 HTERM90  BSS
 G3       IFEQ   ICHK,1
          LDML   INITL
          NJK    UNREC       IF ERROR DURING INITIALIZATION
 G3       ENDIF
          LDN    R.ABN       ABNORMAL TERMINATION
          STDL   RESPC       RESPONSE CODE

* TERMINATE REQUEST.

          LJM    /RES/TERM   SEND TERMINATION RESPONSE
          EJECT
** NAME-- RECRS
*
** PURPOSE-- IF AN ERROR HAS BEEN RECOVERED, SEND AN INTERMEDIATE
*            RESPONSE TO CM.
*
** EXIT-- A REGISTER = 0,    IF RECOVERED ERROR LIMIT HAS NOT BEEN REACHED.
*         A REGISTER .GT. 0, IF RECOVERED ERROR LIMIT HAS BEEN REACHED.
          SPACE  6
 RECRS    CON    0
          LDML   RECRS
          STML   /RES/RECRS
          LDDL   ERRCNT      ERROR COUNTER
          ADDL   FNERR       FUNCTION TIMEOUT COUNTER
          ADML   CHERR       CHANNEL ERROR COUNTER
          ZJK    /RES/RECRSX  IF NO ERRORS

          QUAL   *
 RECRS1   BSS
          QUAL   RC
          AOML   RVCNT       COUNT OF RECOVERED ERRORS PER REQUEST
          SBN    RVTRY       HAS LIMIT BEEN REACHED
          PJK    /RES/RECRSX  IF TOO MANY RECOVERED ERRORS ON THIS REQUEST
          RJM    SFRESP      SET UP THE STATUS RESPONSE BUFFER
          LDK    /RS/K.REC   RECOVERED ERROR
          STML   RCON        ADDITIONAL RESPONSE CONDITION
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          LDN    0
          UJK    /RES/RECRSX
          EJECT
** NAME-- TERMP
*
** PURPOSE-- TERMINATE PP REQUEST.
*
** OUTPUT-- RS+/RS/P.RC = RESPONSE CODE
          SPACE  6
 TERX     LJM    **
 TERMP    EQU    *-1
          RJM    PUTRC       PUT RESPONSE CODES IN RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
          RJM    ZRESP       ZERO OUT RESPONSE BUFFER
          UJK    TERX
          EJECT
** NAME-- INTRS
*
** PURPOSE-- SEND INTERMEDIATE RESPONSE.
          SPACE  6
 INTRSX   LJM    **
 INTRS    EQU    *-1
          LDML   RS+/RS/P.PVA  PVA OF REQUEST
          ADML   RS+/RS/P.PVA+1
          ADML   RS+/RS/P.PVA+2
          NJN    INTRS10     IF REQUEST EXISTS
          RJM    SNMSG       SEND UNSOLICITED RESPONSE
          UJK    INTRSX

 INTRS10  BSS
          LDK    C.RS*8      SET RESPONSE LENGTH FOR ERROR
          STML   RS+/RS/P.RESPL
          LDN    R.INT       INTERMEDIATE RESPONSE
          STDL   RESPC       RESPONSE CODE
          RJM    TERMP       SEND RESPONSE TO CM
          UJK    INTRSX
          EJECT
* SEND UNSOLICITED MESSAGE.
          SPACE  6
 SNMSGX   LJM    **
 SNMSG    EQU    *-1
          RJM    SFRESP      SET UP THE STATUS RESPONSE BUFFER
          LDK    C.RS*8      SET RESPONSE LENGTH FOR ERROR
          STML   RS+/RS/P.RESPL
          LDN    0           UNSOLICITED MESSAGE
          STDL   RESPC       RESPONSE CODE
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          RJM    TERMP       SEND RESPONSE TO CM
          UJK    SNMSGX
          EJECT
** NAME-- SFRESP
*
** PURPOSE-- SET UP FIRST RESPONSE.
          SPACE  6
 SFRESX   LJM    **
 SFRESP   EQU    *-1
          LDDL   SIO         CHECK IF RESPONSE HAS BEEN SET UP
          NJN    SFRES10     IF I/O HAS BEEN STARTED
          RJM    UREQ        READ THE REQUEST FROM CM
          RJM    SETRQ       SET UP FOR FIRST REQUEST
          RJM    SRESP       SET UP RESPONSE
 SFRES10  BSS
          UJK    SFRESX
          EJECT
** NAME-- TERMSK
*
** PURPOSE-- SET UP TERMINATION FOR SEEK ERRORS.
          SPACE  6
          QUAL   *
 TERMSK1  BSS
          QUAL   RC

* UNRECOVERED ERROR DURING SEEK PROCESS.

          RJM    SFRESP      SET UP STATUS RESPONSE BUFFER
          LDDL   SELIN
          STDL   SELECT
          LDDL   FNERR       CHECK FOR FUNCTION TIMEOUT ERROR
          NJN    TERM14      IF FUNCTION TIMEOUT ERROR
          RJM    DROPS       DROP SEEKS ON OTHER UNITS
 TERM14   BSS
          LDDL   SELECT
          STDL   SELIN
          UJK    /RES/TSKX
          EJECT
 F34      IFEQ   OFFU,1
** NAME-- ONUN
*
** PURPOSE-- CLEAR THE DISABLE FLAG IN THE UNIT INTERFACE TABLE.
          SPACE  6
 F1       IFEQ   ERRTST,0
 ONUNX    LJM    **
 ONUN     EQU    *-1
          LDK    -/UIT/K.DSABLE  CLEAR UNIT DISABLE FLAG
          STDL   T3
          LDC    177777B
          STDL   T2
          STDL   T4
          STDL   T5
          LOADF  CM+/CM/P.RMA  LOAD ADDRESS OF UNIT INTERFACE TABLE
          ERRNZ  /UIT/C.DSABLE
          RDCL   T2          -LOGICAL AND- TO CLEAR THE UNIT DISABLE FLAG
          UJK    ONUNX
 F1       ENDIF
 F34      ENDIF
          EJECT
*         THIS IS TEMPORARY UNTIL THE SIMULATOR SUPPORTS READ FLAW MAPS.
          SPACE  6
 B2       IFNE   HARDW,1
 RFLX     LJM    **
 RFLAW    EQU    *-1
B1        IFEQ   VER,1
          LDC    256*4
          STDL   T1
 RFL10    BSS
          LDN    0           ZERO OUT BUFFER
          STML   CBUF-1,T1
          SODL   T1
          NJN    RFL10

          LDML   CMLIST+/CM/P.LEN,CML  NUMBER OF BYTES TO TRANSFER
          SHN    -3
          STDL   TWDS
 RFL40    BSS
          STDL   WDS
          ADC    -256
          MJN    RFL50
          LDC    256
          STDL   WDS
 RFL50    BSS
          LOADF  CMLIST+/CM/P.RMA,CML  LOAD CM ADDRESS AND REFORMAT
          CWML   CBUF,WDS    SEND TO CM
          LDDL   WDS
          SHN    3
          RAML   RS+/RS/P.XFER+1  UPDATE BYTES TRANSFERRED IN RESPONSE STATUS
          LDDL   WDS
          SHN    3
          RAML   CMLIST+/CM/P.RMA+1,CML  UPDATE CM ADDRESS
          SHN    -16
          RAML   CMLIST+/CM/P.RMA,CML
          LDDL   TWDS
          SBDL   WDS
          STDL   TWDS
          NJK    RFL40
 B1       ELSE
          LDN    0
          STDL   P1
          STDL   P2
          STDL   P3
          STDL   P4
          LOADF  CMLIST+/CM/P.RMA,CML  LOAD CM ADDRESS AND REFORMAT
          CWDL   P1          ZERO OUT 1 WORD
 B1       ENDIF
          UJK    RFLX
 B2       ENDIF
          EJECT
** NAME-- LDCN
*
** PURPOSE-- LOAD CONTROLWARE.
          SPACE  6
 LDCN     CON    0
          LDML   LDCN
          STML   /RES/LDCNX+1
          QUAL   *
 LDCN1    BSS
          QUAL   RC
 E11      IFEQ   ETST,0
 Z1       IFEQ   CHANTYP,1

* MASTER CLEAR THE CHANNEL IF RUNNING IN A CIO PP.

          LDK    F.MC        MASTER CLEAR THE CHANNEL
          RJM    FUNC
 Z1       ENDIF

          LDN    1
          STDL   WC
 LDCN10   BSS
          LOADC  CM.CB       CM ADDRESS OF COMMUNICATION BUFFER
          ADN    /CB/C.CONTRL  CM ADDRESS OF CONTROLWARE COMMAND
          CRML   CM,WC       READ COMMAND
          LDML   CM+/CM/P.CODE  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          ERRNZ  /CM/L.CODE
          SBN    C.LDCON
          NJK    LDCN10      IF LOAD CONTROLWARE COMMAND IS NOT PRESENT
          LDK    /RS/K.CLOAD  SET -ATTEMPTED CONTROLWARE LOAD- FLAG
          RJM    SERRID      ERROR ID
          LDML   CM+/CM/P.LEN
          SHN    -3
          STDL   CMLISTL     LENGTH OF CM ADDRESS AREA (CM WORDS)
          RJM    GLIST       GET CM ADDRESS LIST OF DATA AREA
          RJM    LOADCON     LOAD CONTROLWARE
*         RETURN ONLY IF CONTROLWARE LOAD WAS SUCCESSFUL

          UJK    /RES/LDCNX

 E11      ELSE
 LOADCON  EQU    LDCN
          UJK    /RES/LDCNX
 E11      ENDIF
          EJECT
** NAME-- LOADCON
*
** PURPOSE-- LOAD CONTROLWARE.
*
** INPUT-- CMLISTL = NUMBER OF ADDRESS-LENGTH-PAIR ENTRIES IN THE
*                    COMMAND WHICH ARE LEFT TO PROCESS.
*          CMLIST =  LIST OF ADDRESS-LENGTH-PAIRS POINTING TO THE
*                    CM DATA AREA.
*          CML    =  INDEX TO CM LIST.
          SPACE  6
 E10      IFEQ   ETST,0
 LOAX     LJM    **
 LOADCON  EQU    *-1
          LDML   CMLIST+/CM/P.LEN,CML  CHECK FOR 0 WORDS OF CONTROLWARE
          NJN    LOA10       IF LENGTH .GT. 0
          LDC    E213        CONTROLWARE IS NOT PRESENT
          RJM    ATERM
*         (NO RETURN FROM ATERM.)

 LOA10    BSS
          LDK    F.AUTOP     ISSUE LOAD CONTROLWARE FUNCTION
          RJM    FUNC        ISSUE THE FUNCTION
          RJM    ACN         ACN   DC

* SETUP NUMBER OF WORDS TO TRANSFER FROM THIS CM ADDRESS.

 LOA20    BSS
          LOADF  CMLIST+/CM/P.RMA,CML  SET UP CM ADDRESS OF DATA AREA
          LDML   CMLIST+/CM/P.LEN,CML  NUMBER OF 8-BIT BYTES TO TRANSFER
          ADN    7           ROUND UP
          SHN    -3          NUMBER OF CM WORDS TO TRANSFER
          STDL   TWDS        TOTAL NUMBER OF CM WORDS TO TRANSFER
                             FROM THIS ADDRESS
          ZJK    LOA70       IF NO WORDS TO TRANSFER FROM THIS ADDRESS
 LOA30    BSS
          STDL   WDS         COMPUTE NUMBER OF CM WORDS TO TRANSFER TO BUFFER
          ADC    -CTLN       MAXIMUM SIZE OF BUFFER IN PP
          MJN    LOA40       IF LESS THAN PP BUFFER
          LDK    CTLN
          STDL   WDS         NUMBER OF CM WORDS TO TRANSFER TO BUFFER

* TRANSFER DATA FROM CM.

 LOA40    BSS
          LDDL   CMADR+2     CM ADDRESS OF DATA AREA
          LMC    400000B
          CRML   CTBUF,WDS   READ CONTROLWARE BINARY FROM CM
          STDL   CMADR+2     UPDATE CM ADDRESS

* CONVERT DATA TO ONE 8-BIT BYTE PER PP WORD.

          LDDL   WDS         NUMBER OF CM WORDS
          SHN    3
          STDL   T2          NUMBER OF 8-BIT BYTES
          STDL   T3
          SHN    -1          NUMBER OF 16-BIT PP WORDS
          ADC    CTBUF-1
          STDL   T1
 LOA50    BSS
          LDIL   T1          CONVERT DATA
          LPC    377B
          STML   CTBUF-1,T2
          LDIL   T1
          SHN    -8
          STML   CTBUF-2,T2
          SODL   T1
          SODL   T2
          SODL   T2
          NJK    LOA50       IF MORE DATA

* SEND DATA TO CONTROLLER.

          LDDL   T3
          RJM    OAMCT       OAM    CTBUF,DC
          NJN    LOA90       IF THE TRANSFER DID NOT COMPLETE
          LDDL   TWDS        UPDATE TOTAL WORDS LEFT TO TRANSFER
                               TO THIS CM ADDRESS.
          SBDL   WDS
          STDL   TWDS
          NJK    LOA30       IF MORE WORDS TO TRANSFER FROM THIS CM ADDRESS

* GET NEXT CM ADDRESS OF DATA AREA.

 LOA70    BSS
          SODL   CMLISTL     DECREMENT ADDRESS-LENGTH-PAIR COUNT
          ZJN    LOA80       IF END OF ADDRESS-LENGTH-PAIRS IN COMMAND
          LDN    P.CM        BUMP INDEX TO NEXT CM ADDRESS
          RADL   CML
          ADC    -CMLN
          NJN    LOA75       IF MORE DATA TO TRANSFER
          RJM    GLIST       READ NEXT SECTION OF THE LIST WHICH POINTS
                             TO THE CM DATA AREA
 LOA75    BSS
          UJK    LOA20

* END OF DATA.  GET GENERAL STATUS.

 LOA80    BSS
 H11      IFNE   HARDW,1
          LDN    4
          RJM    OAMCT       OAM    CTBUFF,DC
 H11      ENDIF
          RJM    DCN         FJM    *,DC          DCN    40B+DC
          RJM    GENSTAT     GET GENERAL STATUS
          ZJK    LOAX        IF NOT UNRECOVERED ERROR

* UNRECOVERED ERROR.

 LOA85    BSS
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    RECS        ABNORMAL TERMINATION
*         (NO RETURN FROM RECS.)

 LOA90    BSS
          STML   RS+/RS/P.FUNTO  NUMBER OF CHANNEL WORDS NOT TRANSFERRED
          LDK    /RS/K.IST   INCOMPLETE TRANSFER
          RJM    SERRID      SAVE ERROR ID
          UJN    LOA85
 E10      ENDIF
          EJECT
 R4       ERRPL  *-END       IF > 0, RECSO IS TOO LONG
          QUAL   *

          OVERLAY (DOWN UNIT),BUFF
          ROUTINE DOWNO

** NAME-- UTERM
*
** PURPOSE-- TURN OFF A UNIT.
*            DO NOT DELINK ANY REQUESTS.
          SPACE  6
 UTERM1   BSS
          QUAL   DN
          LDK    /RS/K.UDN   UNIT DOWN
          RJM    SID         ERROR ID
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    OFFUN       SET UNIT DISABLE FLAG
          RJM    LTERM       LEAVE THE REQUEST ON THE UNIT Q
*         (NO RETURN FROM LTERM.)
          EJECT
** NAME-- OTERM
*
** PURPOSE-- TURN OFF ALL UNITS ON THE CONTROLLER.
*            DO NOT DELINK ANY REQUESTS.
          SPACE  6
          QUAL   *
 OTERM1   BSS
          QUAL   DN
          LDK    /RS/K.CHDN  CHANNEL DOWN
          RJM    SID         ERROR ID
          RJM    OFFUN       SET UNIT DISABLE FLAG
          RJM    OFFCH       TURN OFF ALL UNITS ON CONTROLLER
          SPACE  6
* LEAVE THE REQUEST ON THE UNIT Q.
* SEND AN UNSOLICITED MESSAGE.

          QUAL   *
 LTERM1   BSS
          QUAL   DN
          LDDL   SIO
          ZJN    OTERM30     IF I/O HAS NOT BEEN STARTED
          RJM    DELCM       DELINK ANY COMPLETED REQUESTS
 OTERM30  BSS
          LDN    0           UNSOLICITED MESSAGE
          STDL   RESPC       RESPONSE CODE
          AOML   NODEL       SET NO DELINK FLAG, SO REQUEST IS NOT DELINKED
          LDML   SS+/SS/P.SEEK,SELIN  RESET FLAGS
          LPC    -/SS/K.CUR-/SS/K.SEEK
          STML   SS+/SS/P.SEEK,SELIN
          LJM    /RES/TERM   TERMINATE REQUEST
          EJECT
** NAME-- DELCM.
*
** PURPOSE-- DELINK COMPLETED REQUESTS.
*            THIS IS CALLED ONLY ON ERRORS IN ORDER TO DELINK REQUESTS
*            WHICH HAVE STREAMED SUCCESSFULLY.
          SPACE  6
 DELCX    LJM    **
 DELCM    EQU    *-1
          LDDL   NCOMRQ      NUMBER OF COMPLETED REQUESTS
          ZJN    DELC10      IF NO REQUESTS HAVE BEEN COMPLETED
          SODL   NCOMRQ      DECREMENT COMPLETED REQUEST COUNT
          ZJN    DELC10      IF NOT STREAMING OF REQUESTS
          LDML   PRERQ       SET UP RMA OF LAST GOOD COMPLETED REQUEST
          STML   CURRQ
          LDML   PRERQ+1
          STML   CURRQ+1
          RJM    DELRQ       DELINK COMPLETED REQUESTS FROM QUEUE
                             AND SELECT NEW REQUEST
 DELC10   BSS
          LDML   SS+/SS/P.SEEK,SELIN  CLEAR 'SEEK ISSUED',
                             'WRITE REQUEST', 'CURRENT REQUEST'
          LPC    -/SS/K.SEEK-/SS/K.WRITE-/SS/K.CUR
          STML   SS+/SS/P.SEEK,SELIN
          ERRNZ  /SS/L.SEEK-11
          ERRNZ  /SS/L.WRITE-12
          ERRNZ  /SS/L.CUR-13
          UJK    DELCX
          EJECT
** NAME-- OFFCH
*
** PURPOSE-- TURN OFF ALL UNITS ON A CONTROLLER.
          SPACE  6
 OFCX     LJM    **
 OFFCH    EQU    *-1
          RJM    CLRUT       CLEAR UNIT TABLES AND SET
                             UNIT DISABLE FLAG
          UJK    OFCX
          EJECT
** NAME-- CLRUT
*
** PURPOSE-- CLEAR UNIT TABLES,
*            AND, IF NOT PROCESSING AN IDLE COMMAND,
*            THEN SET THE UNIT DISABLE FLAG.
*
** NOTE --   IF THE LOCK CAN NOT BE SET, JUST SET THE UNIT DISABLE
*            FLAG.  AN IDLE REQUEST WHICH GOES TO ALL PPS WHENEVER
*            A UNIT IS DISABLED WILL CLEAR THE OTHER FLAGS.
          SPACE  6
 CLRUX    LJM    **
 CLRUT    EQU    *-1
          LDN    0
          STML   IALF        CLEAR FLAG SO CONFIDENCE TEST WILL
                             BE RERUN
          STDL   P5          UNIT POINTER INDEX
          LDDL   CUNITS
          ZJK    CLRUX       IF NO UNITS
          RJM    RDUD        READ UNIT INTERFACE TABLE POINTERS
          LDDL   SELIN       SAVE SELIN
          STDL   P6
          ADN    C.SS*4      FIND A DIFFERENT SS ENTRY
          STDL   SELIN
          ADK    -SSL        CHECK FOR END OF TABLE
          MJK    CLRU10      IF NOT END OF TABLE
          LDN    0
          STDL   SELIN

* READ SS ENTRY FROM UNIT COMMUNICATION BUFFER.

 CLRU10   BSS
          LDC    SS+/SS/P.ENTRY  ADDRESS OF SS ENTRY
          ADDL   SELIN
          STML   CLRU15
          LDN    C.SS        NUMBER OF WORDS TO TRANSFER
          STDL   WC
          LOADR  UDBF+/UN/P.UIT,P5  LOAD ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T5          READ UNIT DISABLED BIT
          ADN    /UIT/C.UBUF
          CRDL   T1
          LDDL   T5+/UIT/P.DSABLE  CHECK IF UNIT IS DISABLED
          SHN    /UIT/L.DSABLE+2
          MJK    CLRU50      IF UNIT IS DISABLED
          LOADF  T3          LOAD ADDRESS OF UNIT COMMUNICATION BUFFER
          CRML   **,WC       READ SS ENTRY
 CLRU15   EQU    *-1
          RJM    STLOCK      SET THE UNIT LOCK
          ZJN    CLRU30      IF LOCK WAS SET
          LDML   IDLE
          NJN    CLRU50      IF PROCESSING AN IDLE COMMAND
          RJM    OFFUN       SET UNIT DISABLE FLAG
          UJN    CLRU50

 CLRU30   BSS
          LDML   IDLE
          NJN    CLRU40      IF PROCESSING AN IDLE COMMAND
          RJM    OFFUN       SET UNIT DISABLE FLAG
 CLRU40   BSS
          LDML   SS+/SS/P.SEEK,SELIN  RESET FLAGS
          LPC    -/SS/K.CUR-/SS/K.SEEK-/SS/K.INIT
          STML   SS+/SS/P.SEEK,SELIN
          ERRNZ  /SS/P.CUR-/SS/P.SEEK
          ERRNZ  /SS/P.SEEK-/SS/P.INIT
          RJM    CLRLOCK     CLEAR THE UNIT LOCK
 CLRU50   BSS
          LDN    4
          RADL   P5          BUMP UNIT POINTER INDEX
          SHN    -2
          SBDL   CUNITS
          NJK    CLRU10      IF NOT END OF TABLE
          LDDL   P6          RESTORE SELIN
          STDL   SELIN

* CLEAR INTERNAL TABLES.

          LDN    0
          STDL   T1
 CLRU60   BSS
          LDN    0
          STML   SS+/SS/P.ENTRY,T1  CLEAR ENTRY ASSIGNED
          LDN    C.SS*4      BUMP TO NEXT ENTRY
          RADL   T1
          ADK    -SSL        CHECK FOR END OF TABLE
          MJK    CLRU60      IF NOT END OF TABLE
          UJK    CLRUX
          EJECT
** NAME-- STLOCK
*
** PURPOSE-- SETS THE UNIT LOCK IN THE UNIT INTERFACE TABLE.
*            THIS ROUTINE IS THE SAME AS SETLOCK, ONLY IT DOESN'T
*            SET THE CHANNEL LOCK.  THIS IS TO PREVENT THIS OVERLAY
*            FROM BEING READ AGAIN, CAUSING THE RJM-S TO BE DESTROYED.
*
** INPUT-- SELIN = INDEX TO SS TABLE WHICH IDENTIFIES THE UNIT TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SETLX    LJM    **
 STLOCK   EQU    *-1
          LDC    SS+/SS/P.UQT  UNIT INTERFACE TABLE ADDRESS
          ADDL   SELIN
          STDL   T7
          LDN    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJK    SETLX       IF LOCK COULD NOT BE SET
          RJM    GETSS       READ SS ENTRY FROM UNIT COMMUNICATION BUFFER
          RJM    SCLOCK      SET CHANNEL LOCK
          ZJK    SETLX       IF CHANNEL LOCK WAS SET
          RJM    CLRLOCK     CLEAR UNIT LOCK
          LDN    1           LOCK COULD NOT BE SET
          UJK    SETLX
          EJECT
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                   .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SCLX     LJM    **
 SCLOCK   EQU    *-1
          LDML   CHLOCK
          ZJN    SCL10       IF CHANNEL LOCK IS NOT SET
          LDN    0           EXIT A REGISTER = 0
          UJK    SCLX

 SCL10    BSS
          LDN    C.CHCNT
          STML   CHLCNT      NUMBER OF REQUESTS TO PROCESS BEFORE
                             GIVING UP CHANNEL
          LDDL   CUNITS
          ZJN    SCL35       IF NO UNITS
          LDN    6           SET TIMEOUT DELAY TO 5 SECONDS ON S1
          STDL   P1
          STDL   P2
 SCL30    BSS
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    SCL40       IF LOCK WAS NOT SET
          AOML   CHLOCK      SET FLAG IF LOCK WAS SET
          LDN    0
          STML   SHARECH     CLEAR SHARE CHANNEL FLAG
 SCL35    BSS
          LDN    0
          UJK    SCLX        EXIT, A REGISTER = 0, LOCK WAS SET

 SCL40    BSS
          SODL   P1
          NJK    SCL30
          SODL   P2
          NJK    SCL30
          LDN    1           TIMEOUT ON TRYING TO GET CHANNEL LOCK
          UJK    SCLX        EXIT A REGISTER NONZERO
          EJECT
** NAME-- RDUD
*
** PURPOSE-- READ POINTERS TO UNIT INTERFACE TABLES FROM THE PP COMMUNICATION BUFFER.
*
          SPACE  6
 RDUX     LJM    **
 RDUD     EQU    *-1

* READ POINTERS TO UNIT INTERFACE TABLES FROM THE PP COMMUNICATION BUFFER.

          LDDL   CUNITS      NUMBER OF CONFIGURED UNITS
          ZJK    RDUX        IF NO UNITS
          STDL   WC
          LOADC  CM.CB
          ADK    /CB/C.UNITS  UNIT INTERFACE TABLE POINTERS
          CRML   UDBF,WC     READ UNIT INTERFACE TABLE POINTERS
          UJK    RDUX
          SPACE  6
 UDBF     BSSZ   UDBUFL      UNIT INTERFACE TABLE POINTERS
          EJECT
** NAME-- OFFUN
*
** PURPOSE-- SET THE DISABLE FLAG ON THE UNIT INTERFACE TABLE.
*
** INPUT-- A & R REGISTERS = CM ADDRESS OF UNIT INTERFACE TABLE.
          SPACE  6
 OFUX     LJM    **
 OFFUN    EQU    *-1
          LDDL   SELIN
          ADC    -SSL
          ZJK    OFUX        IF INVALID UIT
          LOADR  SS+/SS/P.UQT,SELIN  LOAD ADDRESS OF UNIT INTERFACE TABLE
          ERRNZ  /UIT/C.DSABLE
          STDL   T1
          LDK    /UIT/K.DSABLE  SET UNIT DISABLE FLAG
          STDL   T3
          LDN    0
          STDL   T2
          STDL   T4
          STDL   T5
          LDDL   T1
          LMC    400000B
          RDSL   T2          -LOGICAL OR- THE UNIT DISABLE FLAG
          UJK    OFUX
          EJECT
 R4       ERRPL  *-END       IF > 0, DOWN UNIT IS TOO LONG
          QUAL   *

          OVERLAY (PP REQUESTS),BUFF
          ROUTINE PPREQO


          QUAL   PR
          EJECT
          QUAL   *
 CKC10    BSS
          QUAL   PR
          AOML   SHARECH     SET FLAG THAT CHANNEL HAD TO BE GIVEN UP
          LDDL   SEKCNT
          ZJN    CKC20       IF NO OUTSTANDING SEEKS

          AODL   NORQ        SET NO REQUEST FLAG IN CASE OF ERROR
          LDN    F.OPCMP     ISSUE OPERATION COMPLETE
          RJM    FUNC
          LCN    0           SET 'SELECT' INVALID SO DROPS CLEARS ALL
                             LOCKS
          STDL   SELECT
          RJM    DROPS       TERMINATE ACTIVE REQUESTS
          LDN    0
          STDL   NORQ        CLEAR NO REQUEST FLAG

 CKC20    BSS
          RJM    CCLOCK      CLEAR CHANNEL LOCK

          PAUSE  130000      DELAY 130 MILLISECONDS TO ALLOW
                             MAINTENANCE PP TO GET THE CHANNEL
          UJK    /RES/CKCX
          EJECT
** NAME-- PPR
*
** PURPOSE-- CHECK FOR IDLE OR RESUME REQUESTS.
          SPACE  6
          QUAL   *
 PPR1     BSS
          QUAL   PR
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          ERRNZ  /PIT/C.IDLE
          CRDL   T1          READ PP REQUEST FLAGS
          LDDL   T4
          SHN    /PIT/L.IDLE+2
          MJN    PPR20       IF IDLE REQUEST FLAG IS SET
          SHN    /PIT/L.RESUME-/PIT/L.IDLE
          PJK    PPR40       IF RESUME REQUEST FLAG IS NOT SET

* PROCESS RESUME REQUEST.

          LDML   IDLE
          ZJN    PPR10       IF ALREADY RESUMED
          RJM    RESUME      RESUME THE DRIVER

 PPR10    BSS
          LDK    -/PIT/K.RESUME-/PIT/K.IDSTAT-/PIT/K.LOCKF  FLAGS TO CLEAR
          STDL   T5
          LDN    0
          STDL   T6          FLAGS TO SET
          UJN    PPR30


* PROCESS IDLE REQUEST.

 PPR20    BSS
          LDDL   SIO
          ZJN    PPR22       IF I/O HAS NOT BEEN STARTED
          AOML   DEBUG1      SET FOR DEBUG PURPOSES ONLY
          RJM    DELCM       DELINK COMPLETED REQUESTS
 PPR22    BSS
          RJM    IDLEP       SOFTWARE IDLE THE DRIVER
          LDK    -/PIT/K.IDLE-/PIT/K.IDSTAT-/PIT/K.LOCKF  FLAGS TO CLEAR
          STDL   T5
          LDK    /PIT/K.IDSTAT  FLAGS TO SET
          STDL   T6
 PPR30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDK    /PIT/K.LOCKF
          STDL   T4
          LOADC  CM.PIT
          ERRNZ  /PIT/C.LOCKF
          RDSL   T1          TRY TO SET THE LOCK
          LDDL   T4
          LPK    /PIT/K.LOCKF
          NJK    PPR30       IF SOMEONE ELSE HAS THE LOCK
          LDDL   T4
          LPDL   T5          CLEAR FLAGS
          LMDL   T6          SET FLAGS
          STDL   T4
          LOADC  CM.PIT
          ERRNZ  /PIT/C.LOCKF
          CWDL   T1          WRITE THE NEW FLAGS
 PPR40    BSS
          UJK    /RES/MAINA
          EJECT
** NAME-- PPREQ
*
** PURPOSE-- CHECK FOR ANY PP REQUESTS ON THE PP QUEUE.
*
** EXIT-- A REGISTER = 0, IF NO PP REQUESTS.
*                    .NE. 0, IF A PP REQUEST WAS FOUND
          SPACE  6
          QUAL   *
 PPREQ1   BSS
          QUAL   PR


          LDN    0
          STDL   FRST        SET FLAG WHEN REQUEST IS READ

* SET PP QUEUE LOCKWORD.

          RJM    SPLOCK      SET PP QUEUE LOCKWORD
          ZJN    PPRQ20      IF LOCK WAS SET

          LDN    0
          UJK    /RES/PPRQX  EXIT, A REGISTER = 0

* GET THE RMA OF THE FIRST PP REQUEST IN THE CHAIN.

 PPRQ20   BSS
          LDN    2
          STDL   WC
          LOADC  CM.PIT
          ADN    /PIT/C.PPQPVA
          CRML   T1,WC       READ PVA AND RMA OF FIRST REQUEST IN CHAIN

* PUT PVA AND RMA OF REQUEST IN SS TABLE.

          LDK    SSL
          STDL   SELIN
          LDDL   T2          PUT PVA OF REQUEST IN SS TABLE
          STML   SS+/SS/P.PVA,SELIN
          LDDL   T3
          STML   SS+/SS/P.PVA+1,SELIN
          LDDL   T4
          STML   SS+/SS/P.PVA+2,SELIN
          LDDL   T7          PUT RMA OF REQUEST IN SS TABLE
          STML   SS+/SS/P.REQ,SELIN
          LDDL   T8
          STML   SS+/SS/P.REQ+1,SELIN

* READ THE PP REQUEST.

          LDN    C.RQ
          STDL   P1
          LOADF  T7          CM ADDRESS OF FIRST PP REQUEST
          CRML   RQ,P1       READ PP REQUEST

* CLEAR PP QUEUE LOCKWORD.

          RJM    CPLOCK      CLEAR PP QUEUE LOCKWORD

* DETERMINE NUMBER OF COMMANDS.

          LDML   RQ+/RQ/P.LEN  DETERMINE NUMBER OF COMMANDS
          SHN    -3
          SBN    /RQ/C.CMND
          STDL   NUMCM       NUMBER OF COMMANDS

* PROCESS PP REQUEST.

          RJM    SRESP       SET UP RESPONSE BUFFER
 PPRQ30   RJM    UNCMND      GET PP COMMAND AND SET UP TO PROCESS
          ZJN    PPRQ50      IF NO MORE COMMANDS
          LDML   UCMDPR,FNC  GET COMMAND PROCESSOR
          STML   PPRQ40
          RJM    **          PROCESS COMMAND
 PPRQ40   EQU    *-1
          LDDL   RESPC       CHECK FOR ABNORMAL RESPONSE CODE
          SBN    R.ABN
          NJK    PPRQ30      IF NO ERROR, LOOK FOR ANOTHER COMMAND


* SET PP QUEUE LOCKWORD.

 PPRQ50   BSS
          RJM    SPLOCK      SET PP QUEUE LOCKWORD
          NJN    PPRQ50      IF LOCK WAS NOT SET
          LDN    2
          STDL   WC
          LOADC  CM.PIT
          ADN    /PIT/C.PPQPVA
          CRML   T1,WC       READ PVA AND RMA OF FIRST REQUEST IN CHAIN
          LOADF  T7          CM ADDRESS OF FIRST PP REQUEST
          CRML   RQ,WC       READ THE LINK PORTION TO THE NEXT REQUEST

* DELINK THE FIRST PP REQUEST FROM THE CHAIN.

          LOADC  CM.PIT
          ADN    /PIT/C.PPQPVA  CM ADDRESS OF PP QUEUE POINTER
          CWML   RQ,WC       WRITE PVA AND RMA POINTERS OF NEXT REQUEST

* CLEAR PP QUEUE LOCKWORD.

          RJM    CPLOCK      CLEAR PP QUEUE LOCKWORD

          RJM    TERMP       SEND TERMINATION RESPONSE
          UJK    /RES/PPRQX


* UNRECOVERED ERROR.

          QUAL   *
 PPRQC1   BSS
          QUAL   PR
          LDN    R.ABN       UNRECOVERED ERROR
          STDL   RESPC
          UJK    PPRQ50
          EJECT
** NAME-- STLOCK
*
** PURPOSE-- SETS THE UNIT LOCK IN THE UNIT INTERFACE TABLE.
*            THIS ROUTINE IS THE SAME AS SETLOCK, ONLY IT DOESN'T
*            SET THE CHANNEL LOCK.  THIS IS TO PREVENT THIS OVERLAY
*            FROM BEING READ AGAIN, CAUSING THE RJM-S TO BE DESTROYED.
*
** INPUT-- SELIN = INDEX TO SS TABLE WHICH IDENTIFIES THE UNIT TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SETLX    LJM    **
 STLOCK   EQU    *-1
          LDC    SS+/SS/P.UQT  UNIT INTERFACE TABLE ADDRESS
          ADDL   SELIN
          STDL   T7
          LDN    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJK    SETLX       IF LOCK COULD NOT BE SET
          RJM    GETSS       READ SS ENTRY FROM UNIT COMMUNICATION BUFFER
          RJM    SCLOCK      SET CHANNEL LOCK
          ZJK    SETLX       IF CHANNEL LOCK WAS SET
          RJM    CLRLOCK     CLEAR UNIT LOCK
          LDN    1           LOCK COULD NOT BE SET
          UJK    SETLX
          EJECT
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                   .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SCLX     LJM    **
 SCLOCK   EQU    *-1
          LDML   CHLOCK
          ZJN    SCL10       IF CHANNEL LOCK IS NOT SET
          LDN    0           EXIT A REGISTER = 0
          UJK    SCLX

 SCL10    BSS
          LDN    C.CHCNT
          STML   CHLCNT      NUMBER OF REQUESTS TO PROCESS BEFORE
                             GIVING UP CHANNEL
          LDDL   CUNITS
          ZJN    SCL35       IF NO UNITS
          LDN    6           SET TIMEOUT DELAY TO 5 SECONDS ON S1
          STDL   P1
          STDL   P2
 SCL30    BSS
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    SCL40       IF LOCK WAS NOT SET
          AOML   CHLOCK      SET FLAG IF LOCK WAS SET
          LDN    0
          STML   SHARECH     CLEAR SHARE CHANNEL FLAG
 SCL35    BSS
          LDN    0
          UJK    SCLX        EXIT, A REGISTER = 0, LOCK WAS SET

 SCL40    BSS
          SODL   P1
          NJK    SCL30
          SODL   P2
          NJK    SCL30
          LDN    1           TIMEOUT ON TRYING TO GET CHANNEL LOCK
          UJK    SCLX        EXIT A REGISTER NONZERO
          EJECT
** NAME-- SPLOCK
*
** PURPOSE-- SETS THE PP REQUEST QUEUE LOCK IN THE
*            PP INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SPLX     LJM    **
 SPLOCK   EQU    *-1
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET THE LOCKWORD
          NJK    SPLX        IF LOCK COULD NOT BE SET
          UJK    SPLX
          EJECT
** NAME-- CPLOCK
*
** PURPOSE-- CLEARS THE PP QUEUE LOCK IN THE PP INTERFACE TABLE.
*
          SPACE  6
 CPLX     LJM    **
 CPLOCK   EQU    *-1
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWROD
          UJK    CPLX
          EJECT
** NAME-- CCLOCK
*
** PURPOSE-- CLEARS CHANNEL LOCK.
*
          SPACE  6
 CCLX     LJM    **
 CCLOCK   EQU    *-1
          LDML   CHLOCK
          ZJK    CCLX        IF CHANNEL LOCK WAS NOT SET
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CHAN        CHANNEL NUMBER = OFFSET IN TABLE
          STDL   T5
          RJM    CLOCK       CLEAR CHANNEL LOCKWORD
          LDN    0
          STML   CHLOCK      CLEAR CHANNEL LOCK FLAG
          STML   ILOAD       LOAD CONTROLWARE AND MASTER CLEAR A CIO
                             CHANNEL BEFORE DOING THE NEXT DISK REQUEST
          UJK    CCLX
          EJECT
** NAME-- TERMP
*
** PURPOSE-- TERMINATE PP REQUEST.
*
** OUTPUT-- RS+/RS/P.RC = RESPONSE CODE
          SPACE  6
 TERX     LJM    **
 TERMP    EQU    *-1
          RJM    PUTRC       PUT RESPONSE CODES IN RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
          RJM    ZRESP       ZERO OUT RESPONSE BUFFER
          UJK    TERX
          EJECT
** NAME-- IDLEP
*
** PURPOSE-- PROCESS IDLE COMMAND.
          SPACE  6
 IDLX     LJM    **
          QUAL   *
 IDLEP    EQU    *-1
          QUAL   PR
          AOML   IDLE        SET IDLE FLAG
          AOML   IGNORE      IGNORE ERRORS DURING IDLE PROCESSING
          LDK    SSL
          STDL   SELECT      SET -SELECT- SO -DROPS- WILL NOT FIND A MATCH
          RJM    DROPS       ISSUE DROP SEEKS COMMAND
          LDML   CHLOCK
          ZJN    IDL10       IF CHANNEL LOCK IS NOT SET
          LDN    F.OPCMP     ISSUE OPERATION COMPLETE
          RJM    FUNC
 IDL10    BSS
          RJM    CLRUT       CLEAR UNIT TABLES
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          RJM    CFLGS       CLEAR FLAGS
          LDN    0
          STML   IGNORE      ALLOW ERRORS TO BE PROCESSED
          UJK    IDLX
          EJECT
** NAME-- CLRUT
*
** PURPOSE-- CLEAR UNIT TABLES,
*            AND, IF NOT PROCESSING AN IDLE COMMAND,
*            THEN SET THE UNIT DISABLE FLAG.
*
** NOTE --   IF THE LOCK CAN NOT BE SET, JUST SET THE UNIT DISABLE
*            FLAG.  AN IDLE REQUEST WHICH GOES TO ALL PPS WHENEVER
*            A UNIT IS DISABLED WILL CLEAR THE OTHER FLAGS.
          SPACE  6
 CLRUX    LJM    **
 CLRUT    EQU    *-1
          LDN    0
          STML   IALF        CLEAR FLAG SO CONFIDENCE TEST WILL
                             BE RERUN
          STDL   P5          UNIT POINTER INDEX
          LDDL   CUNITS
          ZJK    CLRUX       IF NO UNITS
          RJM    RDUD        READ UNIT INTERFACE TABLE POINTERS
          LDDL   SELIN       SAVE SELIN
          STDL   P6
          ADN    C.SS*4      FIND A DIFFERENT SS ENTRY
          STDL   SELIN
          ADK    -SSL        CHECK FOR END OF TABLE
          MJK    CLRU10      IF NOT END OF TABLE
          STDL   SELIN

* READ SS ENTRY FROM UNIT COMMUNICATION BUFFER.

 CLRU10   BSS
          LDC    SS+/SS/P.ENTRY  ADDRESS OF SS ENTRY
          ADDL   SELIN
          STML   CLRU15
          LDN    C.SS        NUMBER OF WORDS TO TRANSFER
          STDL   WC
          LOADR  UDBF+/UN/P.UIT,P5  LOAD ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T5          READ UNIT DISABLED BIT
          ADN    /UIT/C.UBUF
          CRDL   T1
          LDDL   T5+/UIT/P.DSABLE  CHECK IF UNIT IS DISABLED
          SHN    /UIT/L.DSABLE+2
          MJK    CLRU50      IF UNIT IS DISABLED
          LOADF  T3          LOAD ADDRESS OF UNIT COMMUNICATION BUFFER
          CRML   **,WC       READ SS ENTRY
 CLRU15   EQU    *-1
          RJM    STLOCK      SET THE UNIT LOCK
          ZJN    CLRU30      IF LOCK WAS SET

* FOR IDLE REQUESTS, LET THE SHARING PP CLEAR THIS UNIT'S TABLE.
* IF A CHANNEL IS MANUALLY DOWNED, ONLY 1 PP WILL GET AN IDLE REQUEST.
* IN THAT CASE, THE TABLE DOESN'T NEED TO BE CLEARED.

          LDML   IDLE
          NJN    CLRU50      IF PROCESSING AN IDLE COMMAND
          RJM    OFFUN       SET UNIT DISABLE FLAG
          UJN    CLRU50

 CLRU30   BSS
          LDML   IDLE
          NJN    CLRU40      IF PROCESSING AN IDLE COMMAND
          RJM    OFFUN       SET UNIT DISABLE FLAG
 CLRU40   BSS
          LDML   SS+/SS/P.SEEK,SELIN  RESET FLAGS
          LPC    -/SS/K.CUR-/SS/K.SEEK-/SS/K.INIT
          STML   SS+/SS/P.SEEK,SELIN
          ERRNZ  /SS/P.CUR-/SS/P.SEEK
          ERRNZ  /SS/P.SEEK-/SS/P.INIT
          RJM    CLRLOCK     CLEAR THE UNIT LOCK
 CLRU50   BSS
          LDN    4
          RADL   P5          BUMP UNIT POINTER INDEX
          SHN    -2
          SBDL   CUNITS
          NJK    CLRU10      IF NOT END OF TABLE
          LDDL   P6          RESTORE SELIN
          STDL   SELIN

* CLEAR INTERNAL TABLES.

          LDN    0
          STDL   T1
 CLRU60   BSS
          LDN    0
          STML   SS+/SS/P.ENTRY,T1  CLEAR ENTRY ASSIGNED
          LDN    C.SS*4      BUMP TO NEXT ENTRY
          RADL   T1
          ADK    -SSL        CHECK FOR END OF TABLE
          MJK    CLRU60      IF NOT END OF TABLE
          UJK    CLRUX
          EJECT
** NAME-- RDUD
*
** PURPOSE-- READ POINTERS TO UNIT INTERFACE TABLES FROM THE PP COMMUNICATION BUFFER.
*
          SPACE  6
 RDUX     LJM    **
 RDUD     EQU    *-1

* READ POINTERS TO UNIT INTERFACE TABLES FROM THE PP COMMUNICATION BUFFER.

          LDDL   CUNITS      NUMBER OF CONFIGURED UNITS
          ZJK    RDUX        IF NO UNITS
          STDL   WC
          LOADC  CM.CB
          ADK    /CB/C.UNITS  UNIT INTERFACE TABLE POINTERS
          CRML   UDBF,WC     READ UNIT INTERFACE TABLE POINTERS
          UJK    RDUX
          SPACE  6
 UDBF     BSSZ   UDBUFL      UNIT INTERFACE TABLE POINTERS
          EJECT
** NAME-- OFFUN
*
** PURPOSE-- SET THE DISABLE FLAG ON THE UNIT INTERFACE TABLE.
*
** INPUT-- A & R REGISTERS = CM ADDRESS OF UNIT INTERFACE TABLE.
          SPACE  6
 OFUX     LJM    **
 OFFUN    EQU    *-1
          LOADR  SS+/SS/P.UQT,SELIN  LOAD ADDRESS OF UNIT INTERFACE TABLE
          ERRNZ  /UIT/C.DSABLE
          STDL   T1
          LDK    /UIT/K.DSABLE  SET UNIT DISABLE FLAG
          STDL   T3
          LDN    0
          STDL   T2
          STDL   T4
          STDL   T5
          LDDL   T1
          LMC    400000B
          RDSL   T2          -LOGICAL OR- THE UNIT DISABLE FLAG
          UJK    OFUX
          EJECT
** NAME-- RESUME
*
** PURPOSE-- PROCESS RESUME COMMAND.
          SPACE  6
 RESX     LJM    **
          QUAL   *
 RESUME   EQU    *-1
          QUAL   PR
          LDN    0
          STML   IDLE        CLEAR IDLE FLAG
          RJM    ICOM        INITIALIZE UNIT TABLES
          UJK    RESX
          EJECT
 F33      IFEQ   OFFU,1
** NAME-- STOP
*
** PURPOSE-- SET THE UNIT DISABLE FLAG IN THE UNIT INTERFACE TABLE.
          SPACE  6
 STOPX    LJM    **
 STOP     EQU    *-1
          LOADF  CM+/CM/P.RMA  LOAD ADDRESS OF UNIT INTERFACE TABLE
          RJM    OFFUN       SET UNIT DISABLE
          UJK    STOPX
 F33      ENDIF
          EJECT
** NAME-- DELCM.
*
** PURPOSE-- DELINK COMPLETED REQUESTS.
*            THIS IS CALLED ONLY ON ERRORS IN ORDER TO DELINK REQUESTS
*            WHICH HAVE STREAMED SUCCESSFULLY.
          SPACE  6
 DELCX    LJM    **
 DELCM    EQU    *-1
          LDDL   NCOMRQ      NUMBER OF COMPLETED REQUESTS
          ZJN    DELC10      IF NO REQUESTS HAVE BEEN COMPLETED
          SODL   NCOMRQ      DECREMENT COMPLETED REQUEST COUNT
          ZJN    DELC10      IF NOT STREAMING OF REQUESTS
          LDML   PRERQ       SET UP RMA OF LAST GOOD COMPLETED REQUEST
          STML   CURRQ
          LDML   PRERQ+1
          STML   CURRQ+1
          RJM    DELRQ       DELINK COMPLETED REQUESTS FROM QUEUE
                             AND SELECT NEW REQUEST
 DELC10   BSS
          LDML   SS+/SS/P.SEEK,SELIN  CLEAR 'SEEK ISSUED',
                             'WRITE REQUEST', 'CURRENT REQUEST'
          LPC    -/SS/K.SEEK-/SS/K.WRITE-/SS/K.CUR
          STML   SS+/SS/P.SEEK,SELIN
          ERRNZ  /SS/L.SEEK-11
          ERRNZ  /SS/L.WRITE-12
          ERRNZ  /SS/L.CUR-13
          UJK    DELCX
          EJECT
 UBUF     BSSZ   C.UIT*4     UNIT INTERFACE TABLE BUFFER

 IBUF     BSSZ   C.UD*4      UNIT DESCRIPTOR BUFFER
          EJECT
** NAME-- ICOM
*
** PURPOSE-- INITIALIZE THE UNIT COMMUNICATION BUFFER IN ALL THE UNIT
*            INTERFACE TABLES.
*            INITIALIZE ALL STATIC VARIABLES IN THE COMMUNICATION
*            BUFFER:  DEVICE TYPE, CHANNEL NUMBER, SEEK FUNCTION,
*            UNIT NUMBER, COMMUNICATION BUFFER (RMA), UNIT INTERFACE
*            TABLE (RMA).
          SPACE  6
 ICOMX    LJM    **
          QUAL   *
 ICOM     EQU    *-1
          QUAL   PR

* INITIALIZE VARIABLES.

          LDN    0
          STML   LUD         LAST UNIT SELECTED

          LDML   UDL         LENGTH OF UNIT DESCRIPTORS (CM WORDS)
          ZJN    ICOMX       IF NO UNIT DESCRIPTORS
          LDN    0
          STDL   P6          INDEX TO UNIT DESCRIPTORS
          STDL   CUNITS      NUMBER OF CONFIGURED UNITS
 ICOM10   BSS
          LDDL   CM.PIT+2    CM ADDRESS OFFSET OF UNIT DESCRIPTORS
          ADN    C.PIT
          ADDL   P6
          STDL   CMADR+2
          LDN    C.UD        READ 2 CM WORDS
          STDL   WC
          LOADC  CM.PIT,CMADR+2
          CRML   IBUF,WC     READ UNIT DESCRIPTOR
          IFEQ   LARGE,SMALL
          RJM    CHKUD       CHECK FOR VALID UNIT DESCRIPTOR
          ENDIF

* CHECK FOR NULL ENTRY.

          LDML   IBUF+/UD/P.UQT  RMA = 0 IF NULL ENTRY
          ADML   IBUF+/UD/P.UQT+1
          ZJK    ICOM80      IF NULL ENTRY

* ZERO OUT SS ENTRY.

          LDN    C.SS*4
          STDL   T1
 ICOM20   BSS
          LDN    0
          STML   SS-1,T1     ZERO OUT SS ENTRY
          SODL   T1
          NJN    ICOM20
          LDML   IBUF+/UD/P.UQT+1  INITIALIZE START OF QUEUE CHAIN
          ADN    4*8
          STML   SS+/SS/P.QSTRT+1
          SHN    -16
          ADML   IBUF+/UD/P.UQT
          STML   SS+/SS/P.QSTRT
          LOADF  IBUF+/UD/P.UQT  REFORMAT RMA ADDRESS OF UNIT QUEUE TABLE
          STML   SS+/SS/P.UQT+2
          LDDL   CMADR
          STML   SS+/SS/P.UQT
          LDDL   CMADR+1
          STML   SS+/SS/P.UQT+1

* PUT ADDRESS OF UNIT INTERFACE TABLE IN PP COMMUNICATION BUFFER.

          LDN    0
          STML   SS+/SS/P.UQT+3  SET FLAGS = 0 FOR UNIT TABLE
          LDN    1
          STDL   WC
          LOADC  CM.CB
          ADK    /CB/C.UNITS
          ADDL   CUNITS      NUMBER OF CONFIGURED UNITS
          CWML   SS+/SS/P.UQT,WC  SAVE REFORMATTED UNIT INTERFACE TABLE ADDRESS

* READ UNIT INTERFACE TABLE.

          LDN    C.UIT
          STDL   WC
          LOADR  SS+/SS/P.UQT  LOAD ADDRESS OF UNIT INTERFACE TABLE
          CRML   UBUF,WC     READ UNIT INTERFACE TABLE
          LDML   UBUF+/UIT/P.DSABLE  CHECK IF UNIT IS DISABLED
          SHN    2+/UIT/L.DSABLE
          MJK    ICOM80      IF UNIT IS DISABLED

          AODL   CUNITS      NUMBER OF CONFIGURED UNITS
          SBN    41
          NJN    ICOM25      IF 40 OR LESS UNITS
          RJM    HALT        IF MORE THAN 40 UNITS
*         (NO RETURN FROM HALT.)

 ICOM25   BSS
          IFEQ   LARGE,SMALL
          RJM    CHKUIT      CHECK FOR VALID UNIT INTERFACE TABLE
          ENDIF

* GET DEVICE TYPE AND TRANSLATE TO INTERNAL DEVICE TYPE.

          LDML   UBUF+/UIT/P.UTYPE  CHECK DEVICE TYPE
          ADC    -400B       CHECK FOR 844
          NJN    ICOM30      IF NOT 844
          LDN    DT844
          UJN    ICOM60

 ICOM30   BSS
          SBN    401B-400B   CHECK FOR 885-1X
          ZJN    ICOM50      IF 885-1X
          RJM    HALT        INVALID DEVICE TYPE
*         (NO RETURN FROM HALT.)

 ICOM50   BSS
          LDN    DT885.1
 ICOM60   BSS
          STDL   T1
          ERRNZ  16-/SS/L.DV-/SS/N.DV
          RAML   SS+/SS/P.DV

* GET CHANNEL NUMBER AND MOVE TO SS ENTRY.

          IFEQ   HARDW,1
          LDML   IBUF+/UD/P.CHAN
          SHN    /UD/L.CHAN+/UD/N.CHAN+2
          LPN    /SS/M.CHAN
          ENDIF
 W1       IFNE   HARDW,1
 W2       IFEQ   CONTYP,2
          LDN    2
 W2       ELSE
          LDN    4
 W2       ENDIF
 W1       ENDIF
          STDL   CHAN        CHANNEL NUMBER
          SHN    16-/SS/L.CHAN-/SS/N.CHAN
          RAML   SS+/SS/P.CHAN

* SET LARGE SECTOR BIT IN SEEK FUNCTION.

          LDDL   T1
          SBN    DT844
          ZJN    ICOM65      IF 844, USE SMALL SECTOR SEEK FUNCTION
          LDN    /SS/M.LS
          SHN    16-/SS/L.LS-/SS/N.LS
          RAML   SS+/SS/P.LS

* CHANGE DISK CHANNEL INSTRUCTIONS.

 ICOM65   BSS
          RJM    CHGCH       CHANGE DISK CHANNEL INSTRUCTIONS

          LDML   FDCN        DISCONNECT THE CHANNEL
          STML   ICOM67
 ICOM67   DCN    40B         DISCONNECT THE CHANNEL

* PUT PHYSICAL UNIT NUMBER IN SEEK FUNCTION.

          LDML   IBUF+/UD/P.UNIT
          ERRNZ  /UD/L.UNIT
          ERRNZ  /UD/N.UNIT-16
          LPN    /SS/M.UNIT
          ERRNZ  16-/SS/L.UNIT-/SS/N.UNIT
          RAML   SS+/SS/P.UNIT  PUT PHYSICAL UNIT NUMBER IN SEEK FUNCTION
          LDML   IBUF+/UD/P.LU  PUT LOGICAL UNIT IN SS TABLE
          STML   SS+/SS/P.LU

* REFORMAT COMMUNICATION BUFFER RMA.

          LOADF  UBUF+/UIT/P.UBUF  REFORMAT RMA ADDRESS OF UNIT QUEUE TABLE
          STML   SS+/SS/P.COM+2
          LDDL   CMADR
          STML   SS+/SS/P.COM
          LDDL   CMADR+1
          STML   SS+/SS/P.COM+1

* CHECK THAT COMMUNICATION BUFFER IS LONG ENOUGH.

          LDML   UBUF+/UIT/P.UBUFL  NUMBER OF 8-BIT BYTES IN COMMUNICATION BUFFER
          SHN    -3          NUMBER OF CM WORDS
          SBN    C.SS        MUST BE LARGER THAN SS ENTRY
          PJN    ICOM70      IF COMMUNICATION BUFFER IS LARGE ENOUGH
                             ERROR - COMMUNICATION BUFFER TOO SMALL
          LDC    E308
          RJM    INTERR      SEND ERROR TO CM
*         (NO RETURN FROM INTERR)


* SAVE SS ENTRY IN COMMUNICATION BUFFER.

 ICOM70   BSS
          LDN    C.SS
          STDL   WC
          LDK    /SS/K.INIT  SET SS ENTRY INITIALIZED FLAG
          RAML   SS+/SS/P.INIT

          LOADR  SS+/SS/P.UQT  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          CRDL   T2          READ UNIT LOCKWORD
          LDDL   T2
          NJN    ICOM73      IF UNIT IS LOCKED

          LOADR  SS+/SS/P.COM  LOAD ADDRESS OF COMMUNICATION BUFFER
          STDL   T1
          CRDL   T2          READ SS ENTRY
          LDDL   T2
          SHN    /SS/L.INIT+2
          MJN    ICOM73      IF SS ENTRY ALREADY INITIALIZED
          LDDL   T1
          LMC    400000B
          CWML   SS,WC       WRITE SS ENTRY TO COMMUNICATION BUFFER

 ICOM73   BSS

* CHECK IF CONTROLLER IS RESERVED TO ANOTHER ACCESS.

 W3       IFNE   HARDW,1
          RJM    CHGCH2      CHANGE DISK CHANNEL INSTRUCTIONS
          LDC    F.AUTOP     SIMULATOR ONLY
          RJM    FUNC        SIMULATOR ONLY
          ACN    DC
          LDC    100
          OAM    BUFF,DC
          FJM    *,DC
          DCN    40B+DC
 W3       ENDIF

 W4       IFEQ   ICHK,1
          RJM    CONRSV      CHECK IF CONTROLLER IS RESERVED


* CHECK IF UNIT IS RESERVED TO ANOTHER ACCESS.

          LDML   IBUF+/UD/P.LU  PUT LOGICAL UNIT IN RESPONSE BUFFER
          STML   RS+/RS/P.LU
 ICOM72   BSS
          RJM    SEEKCK      ISSUE SEEK AND CHECK FOR ERRORS
          LDDL   GNSTAT      GENERAL STATUS
          SHN    17-3
          PJN    ICOM75      IF DSU NOT RESERVED
          LDK    /RS/K.URS   UNIT RESERVED
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          UJK    ICOM72      KEEP CHECKING RESERVE FLAG

 ICOM75   BSS
          LDN    F.OPCMP     ISSUE OPERATION COMPLETE
          RJM    FUNC
 W4       ENDIF

* BUMP TO NEXT ENTRY.

 ICOM80   BSS
          LDN    C.UD
          RADL   P6          BUMP TO NEXT UNIT DESCRIPTOR ENTRY
          SBML   UDL         CHECK FOR END OF UNIT DESCRIPTORS
          NJK    ICOM10      IF MORE UNIT DESCRIPTORS
          UJK    ICOMX       EXIT
** NAME--CHGCH
*
** PURPOSE--REPLACE CHANNEL INSTRUCTIONS WITH A DIFFERENT CHANNEL NUMBER.
*
** INPUT--CHAN = CHANNEL NUMBER
*
          SPACE  6
 CHGX     LJM    **
 CHGCH    EQU    *-1
          LDDL   CHAN        CHANNEL NUMBER
          SBML   CURCH       CURRENT CHANNEL NUMBER
          ZJN    CHGX        NO CHANGE NEEDED
          RAML   CURCH       SAVE NEW CHANNEL
          LDN    0
          STDL   T1          CHANGE DISK CHANNEL INSTRUCTIONS
 CHG10    LDML   CONCH,T1    ADDRESS OF CHANNEL INSTRUCTIONS
          ZJN    CHGX        END OF LIST
          STDL   T2
          LDIL   T2
          SCN    37B
          LMDL   CHAN        CHANNEL NUMBER
          STIL   T2
          AODL   T1
          UJK    CHG10
          EJECT
* CHECK FOR VALID UNIT DESCRIPTOR.
          SPACE  6
          IFEQ   LARGE,SMALL
 CHKUX    LJM    **
 CHKUD    EQU    *-1
 F4       IFEQ   ERRTST,0
          LDML   IBUF+/UD/P.CHAN  CHANNEL NUMBER
          SHN    /UD/L.CHAN+/UD/N.CHAN+2
          LPN    /SS/M.CHAN
          SBN    14B         VALID CHANNELS ARE 0 - 13B AND 20B - 33B
          MJN    CHKU30      CHANNEL OK
          SBN    20B-14B
          PJN    CHKU25
 CHKU20   BSS
          LDC    E20A        INVALID CHANNEL NUMBER
          UJN    CHKU42

 CHKU25   BSS
          SBN    34B-20B
          PJN    CHKU20

 CHKU30   BSS
          LDML   IBUF+/UD/P.UNIT  PHYSICAL UNIT NUMBER
          SBN    10B         VALID UNIT NUMBERS ARE 0 - 7, 40B - 57B
          MJN    CHKU50      UNIT OK
          SBN    40B-10B
          PJN    CHKU45
 CHKU40   BSS
          LDC    E210        INVALID PHYSICAL UNIT NUMBER
 CHKU42   UJN    CHKU100

 CHKU45   BSS
          SBN    60B-40B
          PJN    CHKU40

 CHKU50   BSS
          LDML   IBUF+/UD/P.UQT+1  UNIT INTERFACE TABLE ADDRESS
          LPN    7
          ZJK    CHKUX
          LDC    E209        UNIT INTERFACE TABLE NOT A WORD BOUNDARY

 CHKU100  BSS
          RJM    INTERR      SEND ERROR TO CM
*         (NO RETURN FROM INTERR)
 F4       ELSE
          UJN    CHKUX
 F4       ENDIF
          ENDIF
          EJECT
* CHECK FOR VALID UNIT INTERFACE TABLE.
          SPACE  6
 W10      IFEQ   LARGE,SMALL
 CUTX     LJM    **
 CHKUIT   EQU    *-1
 W9       IFEQ   HARDW,1
 W11      IFEQ   CONTYP,0
          LDN    0
          STDL   T1
          LDML   UBUF+/UIT/P.LU  LOGICAL UNIT NUMBER
          SBML   IBUF+/UD/P.LU
          NJN    CUT25       LOGICAL UNIT NUMBER MISMATCH

          AODL   T1
          LDML   UBUF+/UIT/P.UTYPE  UNIT TYPE
          ADC    -400B       VALID UNIT TYPE = 400B - 402B
          MJN    CUT100      INVALID UNIT TYPE

          SBN    403B-400B
          PJN    CUT100
*
          AODL   T1
          LDML   UBUF+/UIT/P.UBUFL  UNIT COMMUNICATION BUFFER LENGTH
          LPN    7
          ZJN    CUT30
 CUT25    UJN    CUT100

 CUT30    BSS
          AODL   T1
          LDML   UBUF+/UIT/P.UBUF+1  UNIT COMMUNICATION BUFFER
          LPN    7
          NJN    CUT100      NOT A WORD BOUNDARY

          AODL   T1
          LDML   UBUF+/UIT/P.NEXTPV-1  RESERVED FIELD OF UNIT
                             REQUEST QUEUE DESCRIPTOR
          ADML   UBUF+/UIT/P.NEXT-2
          ADML   UBUF+/UIT/P.NEXT-1
          ZJK    CUTX

 CUT100   BSS
          LDML   CUT110,T1   INTERFACE ERROR CODE
          RJM    INTERR      SEND ERROR TO CM
*         (NO RETURN FROM INTERR)

 CUT110   BSS
          CON    E301        LOGICAL UNIT NUMBER MISMATCH
          CON    E306        INVALID UNIT TYPE
          CON    E307        UNIT COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS
          CON    E302        UNIT COMMUNICATION BUFFER NOT A WORD BOUNDARY
          CON    E305        RESERVED FIELD OF UNIT REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 W11      ELSE
          UJK    CUTX
 W11      ENDIF
 W9       ELSE
          UJK    CUTX
 W9       ENDIF
 W10      ENDIF
          EJECT
* INTERFACE ERROR.
          SPACE  6
 INTERR   CON    0
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LDN    0           UNSOLICITED MESSAGE
          STDL   RESPC       RESPONSE CODE
          LDK    /RS/K.INTERR  INTERFACE ERROR
          STML   RS+/RS/P.INTERR  ABNORMAL STATUS CODE
          RJM    TERMP       SEND RESPONSE TO CM
          RJM    HALT        ERROR
*         (NO RETURN FROM HALT.)

          EJECT
 T11      IFNE   HARDW,1
 CHG2X    LJM    **
 CHGCH2   EQU    *-1
          RJM    CHGCH
          LDN    0
          STDL   T1
 CHG210   LDML   CONCH2,T1
          ZJN    CHG2X
          STDL   T2
          LDIL   T2
          SCN    37B
          LMDL   CHAN
          STIL   T2
          AODL   T1
          UJK    CHG210
 T11      ENDIF
          EJECT
 SL2      IFNE   LARGE,SMALL
 WTDX     LJM    **
 WTDSK    EQU    *-1
 WTD1     BSS
          LDN    3
          STDL   CHAN
          RJM    CHGCH2
          LDN    0
          STML   RESTRT
          LDN    0
          STDL   SELIN

* SET FOR 844.

          LDC    820
          STML   NMCYL
          LDN    19
          STML   TK.CY
 S2       IFEQ   SMALL,1
          LDN    6*4
 S2       ELSE
          LDN    6
 S2       ENDIF
          STML   SC.TK
 S3       IFEQ   IN844,1
          LDC    0           UNIT 00B
 S3       ELSE
          LDC    43B
 S3       ENDIF
          STML   SS+/SS/P.UNIT
          LPN    40B
          ZJN    WTD5        IF 844
          LDC    842
          STML   NMCYL
          LDN    40
          STML   TK.CY
 SL4      IFEQ   SMALL,1
          LDN    8*4
 SL4      ELSE
          LDN    8
 SL4      ENDIF
          STML   SC.TK
 WTD5     BSS
 S4       IFNE   SMALL,1
          LDML   SS+/SS/P.UNIT  SET LARGE SECTOR BIT
          LPC    -1000B
          LMC    1000B
          STML   SS+/SS/P.UNIT
 S4       ENDIF
          LDC    0
          STML   SS+/SS/P.CYL
          LDC    0
          STML   SS+/SS/P.TRACK
          LDC    0
          STML   SS+/SS/P.SECTOR
 WTD10    BSS
          LDN    0
          STML   ERROR
 WTD15    BSS
 S5       IFEQ   PAT,1
          RJM    PATCH
 S5       ENDIF
          LDML   RESTRT
          NJK    WTD1
          RJM    SEEK
          RJM    GENSTAT
          NJN    WTD15
 WTD20    BSS
          LDN    F.WRITE
          IJM    WTD52,DC
          RJM    FUNC
          UJN    *

 WTD52    BSS
          FAN    DC
          LDC    100000
 WTD54    IJM    WTD56,DC
          SBN    1
          NJN    WTD54
          UJN    *

 WTD56    BSS
          ACN    DC
 S6       IFEQ   SMALL,1
          LDN    2
          OAM    BUFF,DC
          LDC    322
 S6       ELSE
          LDC    SBYTE7
 S6       ENDIF
          OAPM   BUFF,DC
          FJM    *,DC
          PSN
          PSN
          DCN    40B+DC
          RJM    GENSTAT
          ZJK    WTD60
          AOML   ERROR
          LDML   ERR1
          STDL   T1
          ZJN    WTD58       IF THIS IS THE FIRST ERROR
          LDML   SS+/SS/P.CYL
          SBML   ERRORS-3,T1
          NJN    WTD58       IF NOT THE SAME TRACK
          LDML   SS+/SS/P.TRACK
          SBML   ERRORS-2,T1
          ZJN    WTD60       IF ERROR ON THE SAME TRACK, DO NOT RECORD
 WTD58    BSS
          LDML   SS+/SS/P.CYL
          STML   ERRORS,T1
          LDML   SS+/SS/P.TRACK
          STML   ERRORS+1,T1
          LDML   SS+/SS/P.SECTOR
          STML   ERRORS+2,T1
          LDN    3
          RAML   ERR1
          ADC    -ERRLN
          MJN    WTD60
          UJN    *

 WTD60    BSS
 S7       IFEQ   PAT,1
          RJM    PATCH
 S7       ENDIF
          LDML   RESTRT
          NJK    WTD1
          AOML   SS+/SS/P.SECTOR
          SBML   SC.TK
          NJK    WTD70
          STML   SS+/SS/P.SECTOR
          AOML   SS+/SS/P.TRACK
          SBML   TK.CY
          NJK    WTD70
          STML   SS+/SS/P.TRACK
          AOML   SS+/SS/P.CYL
          SBML   NMCYL
          NJK    WTD10
          UJK    WTDX

 WTD70    BSS
          LDML   ERROR
          NJK    WTD10
          UJK    WTD20

 NSEC     BSSZ   1
 NMCYL    BSSZ   1
 RESTRT   BSSZ   1
 TK.CY    BSSZ   1
 SC.TK    BSSZ   1
 ERROR    BSSZ   1
 ERR1     BSSZ   1
 ERRORS   BSSZ   3*33
 ERRLN    EQU    *-ERRORS
 SL2      ENDIF
          EJECT
          IFEQ   DUMP,1
 BF1      EQU    7770B
 BF       EQU    5
 BP       EQU    1


          ORG    7700B
 RCDUMP   BSS
          LDN    1
          STDL   CHAN
          RJM    CHGCH2
          LDN    0
          STDL   BP
 RCD10    IAN    DC
          SHN    8
          STML   BF1,BP
          IAN    DC
          RAML   BF1,BP
          AODL   BP
          SBN    5
          NJN    RCD10

          LDN    0
          STDL   BP
 RCD20    IAN    DC
          SHN    8
          STML   BF,BP
          IAN    DC
          RAML   BF,BP
          AODL   BP
          ADC    -7700B
          NJN    RCD20
          UJN    *
          ENDIF
          EJECT
 CONCH2   BSS
 TDC+40B  HERE
 T40B+DC  HERE
 TDC      HERE
          CON    0
          EJECT
          QUAL   *
 R6       ERRPL  *-END       IF > 0, PPREQ IS TOO LONG

          OVERLAY (CONFIDENCE TEST),OVAD2
          ROUTINE CONFO
          CON    CONFOO

          QUAL   CF
          EJECT
** NAME-- CTEST
*
** PURPOSE-- RUN THE CONFIDENCE TEST ON ALL UNITS
*            WHEN THE PP IS FIRST LOADED.
          SPACE  6
 CTESTX   LJM    **
          QUAL   *
 CTEST    EQU    *-1
          QUAL   CF
          LDDL   CUNITS
          ZJK    CTEST60     IF NO UNITS
          LDDL   SELIN       SAVE SELIN
          STML   SAVE
          ADN    C.SS*4      FIND A DIFFERENT SS ENTRY
          STDL   SELIN
          ADK    -SSL        CHECK FOR END OF TABLE
          MJK    CTEST5      IF NOT END OF TABLE
          STDL   SELIN
 CTEST5   BSS
          LDN    0
          STML   CTESTU      UNIT POINTER INDEX

* READ POINTERS TO UNIT INTERFACE TABLES FROM THE PP COMMUNICATION BUFFER.

 CTEST10  BSS
          LOADC  CM.CB
          ADK    /CB/C.UNITS  UNIT INTERFACE TABLE POINTERS
          ADML   CTESTU      UNIT INDEX
          CRDL   T1

          LDDL   T1+/UN/P.CTST  HAS THE CONFIDENCE TEST BEEN RUN
          SHN    /UN/L.CTST+2
          MJK    CTEST50     IF THE CONFIDENCE TEST HAS BEEN RUN

* READ SS ENTRY FROM UNIT COMMUNICATION BUFFER.

          LDC    SS+/SS/P.ENTRY  ADDRESS OF SS ENTRY
          ADDL   SELIN
          STML   CTEST15
          LDN    C.SS        NUMBER OF WORDS TO TRANSFER
          STDL   WC
          LOADR  T1          LOAD ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T5          READ UNIT DISABLED BIT
          ADN    /UIT/C.UBUF
          CRDL   T1

* DON'T RUN THE CONFIDENCE TEST IF THE UNIT DISABLE FLAG IS SET.

          LDDL   T5+/UIT/P.DSABLE  CHECK IF UNIT IS DISABLED
          SHN    /UIT/L.DSABLE+2
          MJK    CTEST50     IF UNIT IS DISABLED
          LOADF  T3          LOAD ADDRESS OF UNIT COMMUNICATION BUFFER
          CRML   **,WC       READ SS ENTRY
 CTEST15  EQU    *-1

 CTEST20  BSS
          RJM    /RES/PPREQ  CHECK IDLE AND ACTIVE FLAGS
          RJM    /RES/SETLOCK  SET THE UNIT LOCK

* TEMPORARY, PUT IN A TIMEOUT OF 30 SECONDS.

          NJK    CTEST20     IF LOCK WAS NOT SET
          STML   RS+/RS/P.PVA    CLEAR OUT ANY LEFT OVER PVA
          STML   RS+/RS/P.PVA+1  FROM RESPONSE BUFFER.
          STML   RS+/RS/P.PVA+2
          LDML   SS+/SS/P.SEEK,SELIN  CLEAR  'SEEK ISSUED',
          LPC    -/SS/K.SEEK-/SS/K.WRITE-/SS/K.CUR
                             'WRITE REQUEST', 'CURRENT REQUEST'
                             IN CASE OPPOSITE ACCESS LEFT THESE SET
          STML   SS+/SS/P.SEEK,SELIN
          ERRNZ  /SS/L.SEEK-11
          ERRNZ  /SS/L.WRITE-12
          ERRNZ  /SS/L.CUR-13
          RJM    CONF        EXECUTE THE CONFIDENCE TEST

* SET FLAG THAT THE CONFIDENCE TEST WAS RUN.

 CTEST30  BSS
          LOADC  CM.CB
          ADK    /CB/C.UNITS  UNIT INTERFACE TABLE POINTERS
          ADML   CTESTU      UNIT INDEX
          STDL   T5          SAVE CM ADDRESS
          CRDL   T1
          LDDL   T1+/UN/P.CTST  SET FLAG THAT CONFIDENCE TEST WAS RUN
          LPC    -/UN/K.CTST
          ADK    /UN/K.CTST
          STDL   T1+/UN/P.CTST
          LDDL   T5
          LMC    400000B
          CWDL   T1          WRITE FLAG IN PP COMMUNICATION BUFFER


* CLEAR FLAGS IN SS ENTRY.

          LDML   SS+/SS/P.SEEK,SELIN  CLEAR 'SEEK ISSUED',
                             'WRITE REQUEST', 'CURRENT REQUEST'
          LPC    -/SS/K.SEEK-/SS/K.WRITE-/SS/K.CUR
          STML   SS+/SS/P.SEEK,SELIN
          ERRNZ  /SS/L.SEEK-11
          ERRNZ  /SS/L.WRITE-12
          ERRNZ  /SS/L.CUR-13

          RJM    CLRLOCK     CLEAR THE UNIT LOCK
          RJM    ZRESP       ZERO OUT RESPONSE BUFFER

 CTEST50  BSS
          AOML   CTESTU      BUMP UNIT POINTER INDEX
          SBDL   CUNITS
          NJK    CTEST10     IF NOT END OF TABLE
          LDML   SAVE        RESTORE SELIN
          STDL   SELIN
 CTEST60  BSS
          AOML   IALF        SET FLAG FOR CONFIDENCE TEST STARTED ON
                             ALL UNITS
          UJK    CTESTX
          EJECT
** NAME-- CONFR
*
** PURPOSE-- EXECUTE THE CONFIDENCE TEST.
*            THIS IS THE ENTRY DURING RECOVERY OF AN ERROR.
*            RELOAD THE RECOVERY OVERLAY WHEN THE CONFIDENCE TEST IS
*            FINISHED.
          SPACE  6
 CONFRX   LJM    **
 CONFR    EQU    *-1
          RJM    CONF        EXECUTE THE CONFIDENCE TEST.

 E9       IFEQ   ERRTST,1
          RJM    TESTR2      TEST REQUEST RETRY RECOVERED ERRORS
 E9       ENDIF

          LOADOVL RECSO
          UJK    CONFRX
          EJECT
** NAME-- CONF
*
** PURPOSE-- EXECUTE THE CONFIDENCE TEST.
          SPACE  6
 CONFX    LJM    **
 CONF     EQU    *-1
 Q15      IFEQ   ERRTST,1
          LDML   CTPAR
          ZJN    CONF2       IF NO ERROR TO FORCE
          STDL   P1          PARAMETER FOR /RES/FORC
          SBN    5
          PJN    CONF2       IF NOT FORCE ERROR FUNCTION
          RJM    /RES/FORC   ISSUE FORCE ERROR FUNCTION
          LDN    0
          STML   CTPAR       END OF TEST
 CONF2    BSS
 Q15      ENDIF

          LDML   SS+/SS/P.CONF,SELIN  SET CONFIDENCE TEST FLAG
          LPC    -/SS/K.CONF
          ADK    /SS/K.CONF
          STML   SS+/SS/P.CONF,SELIN
          LDK    /RS/K.CT    SET FLAG FOR CONFIDENCE TEST STARTED
          RJM    SDET        PUT ID IN RESPONSE

* GET DEVICE TYPE.

          LDML   SS+/SS/P.DV,SELIN  GET DEVICE TYPE
          ERRNZ  -16+/SS/L.DV+/SS/N.DV
          LPN    /SS/M.DV
          STDL   DEVICE
          LDN    0           INDEX TO TABLE OF STARTING VALUES OF DATA
          STML   STV
          STML   NMED        NUMBER OF MEDIA ERRORS

 CONF10   BSS
          LDN    0
          STML   NTRANS      SECTORS TRANSFERRED
          STML   SNTRANS     STARTING NTRANS VALUE
          LDN    1
          STDL   FNC         SET FUNCTION CODE = WRITE
          AODL   SIO         SET START I/O FLAG
          AODL   SEKCNT      INCREMENT SEEK ISSUED FLAG

 CONFA    BSS
          RJM    CSETUP      SET UP THE DISK ADDRESS
          RJM    SETADD      SET STARTING DISK ADDRESS IN RESPONSE BUFFER
          RJM    /RES/SEEKON  SEEK AND WAIT FOR ON-CYLINDER
          LDML   SS+/SS/P.SEEK,SELIN  CLEAR 'SEEK ISSUED' FLAG
          LPC    -/SS/K.SEEK
          STML   SS+/SS/P.SEEK,SELIN
          RJM    CWRITE      WRITE THE CYLINDER
          SODL   SEKCNT      DECREMENT SEEK ISSUED FLAG
          LDN    F.OPCMP     ISSUE OPERATION COMPLETE
          RJM    FUNC

          LDN    0
          STML   NTRANS      SET SECTORS TRANSFERRED = 0
          STML   SNTRANS     STARTING NTRANS VALUE
          STML   CPERR       COMPARE ERROR FLAG
          STDL   FNC         SET FUNCTION CODE = READ

 CONFB    BSS
          RJM    CSETUP      SET UP THE DISK ADDRESS
          RJM    SETADD      SET STARTING DISK ADDRESS IN RESPONSE BUFFER
          RJM    /RES/SEEKON  SEEK AND WAIT FOR ON-CYLINDER
          LDML   SS+/SS/P.SEEK,SELIN  CLEAR 'SEEK ISSUED' FLAG
          LPC    -/SS/K.SEEK
          STML   SS+/SS/P.SEEK,SELIN
          RJM    CREAD       READ AND COMPARE THE DATA
          LDN    F.OPCMP     ISSUE OPERATION COMPLETE
          RJM    FUNC
          LDML   CPERR       CHECK IF THERE WAS A COMPARE ERROR
          NJN    CONF20      IF COMPARE ERROR

          AOML   STV         INDEX TO TABLE OF STARTING VALUES OF DATA
          SBN    STVL
          NJK    CONF10      IF NOT END OF STARTING VALUE TABLE

* END OF CONFIDENCE TEST.

          LDML   SS+/SS/P.CONF,SELIN  CLEAR CONFIDENCE TEST FLAG
          LPC    -/SS/K.CONF
          STML   SS+/SS/P.CONF,SELIN
          UJK    CONFX

* DATA COMPARE ERROR.

 CONF20   BSS
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          LDK    /RS/K.DIE   DRIVE INTERFACE INTEGRITY ERROR
          RJM    SDET        PUT ERROR ID IN RESPONSE
          RJM    UTERM       UNRECOVERED ERROR, TURN OFF UNIT
*         (NO RETURN FROM UTERM.)
          SPACE  6
          EJECT
** NAME-- CSETUP
*
** PURPOSE-- SET UP PARAMETERS FOR THE CONFIDENCE TEST.
          SPACE  6
 CSEX     LJM    **
 CSETUP   EQU    *-1
          LDML   /CF/CFCYL,DEVICE
          STML   SS+/SS/P.CYL,SELIN  CYLINDER ADDRESS OF CURRENT REQUEST
          LDN    0
          STDL   T1
          LDML   NTRANS      SECTORS TRANSFERRED
          STML   SS+/SS/P.SECTOR,SELIN  SECTOR ADDRESS
 CSE10    BSS
          LDML   SS+/SS/P.SECTOR,SELIN  COMPUTE TRACK AND SECTOR ADDRESS
          SBML   DVSEC,DEVICE  NUMBER OF SECTORS PER TRACK
          MJN    CSE20       IF END OF COMPUTATION
          STML   SS+/SS/P.SECTOR,SELIN
          AODL   T1          INCREMENT TRACK ADDRESS
          UJN    CSE10

 CSE20    BSS
          LDDL   T1          TRACK ADDRESS
          STML   SS+/SS/P.TRACK,SELIN  TRACK ADDRESS OF CURRENT REQUEST

          LDML   /CF/SECCYL,DEVICE  NUMBER OF SECTORS TO TRANSFER PER CYLINDER
          SBML   NTRANS      SECTORS TRANSFERRED
          STML   NSEC        NUMBER OF SECTORS TO END OF CYLINDER
          UJK    /CF/CSEX
          EJECT
** NAME-- CREAD.
*
** PURPOSE-- READ THE CONFIDENCE TEST CYLINDER.
          SPACE  6
 CREADX   LJM    **
 CREAD    EQU    *-1
          LOADOVL CRDO
          LJM    /CR/CREAD10
          EJECT
** NAME-- CWRITE
*
** PURPOSE-- WRITE THE CONFIDENCE TEST CYLINDER.
          SPACE  6
 CWRIX    LJM    **
 CWRITE   EQU    *-1
          LOADOVL CWRO
          LJM    /CW/CWRI10
          EJECT
** NAME-- CREC
*
** PURPOSE-- HANDLE ERRORS IN THE CONFIDENCE TEST.
          SPACE  6
 CRECX    LJM    **
 CREC     EQU    *-1
          LDC    CREC80      SET RETURN ADDRESS IF CONFIDENCE TEST RUNS OK
          STML   CONF

          LDK    /RS/K.CT    SET FLAG FOR CONFIDENCE TEST STARTED
          RJM    SDET        PUT ID IN RESPONSE
          LDDL   FNC
          ZJN    CREC10      IF READ
          LDML   NTRANS      WAS THE ERROR POSITIVELY ON THE FIRST
                             SECTOR AFTER THE SEEK
          SBML   SNTRANS
          NJN    CREC60      IF DON'T KNOW THE FAILING ADDRESS

* ASSUME EVERY ERROR IS A MEDIA ERROR, UNLESS THE SECTOR OR TRACK
* IS FLAWED.
* ACCEPT 3 MEDIA ERRORS IN THE CONFIDENCE TEST.

* CHECK IF SECTOR OR TRACK IS FLAWED.

 CREC10   BSS
          LOADOVL CRCO
          RJM    /CC/CRC     RECORD MEDIA ERROR

 CREC50   BSS
          LDDL   FNC
          NJK    CONFA       IF WRITE
          UJK    CONFB       IF READ

* FOR WRITES, DECREMENT STARTING ADDRESS AND WRITE 1 SECTOR.

 CREC60   BSS
          LDML   NTRANS      DECREMENT NUMBER OF SECTORS TRANSFERRED
          SBML   SECSC,DEVICE  SECTOR INCREMENT
          STML   NTRANS
          STML   SNTRANS     SAVE STARTING ADDRESS
          LDML   SS+/SS/P.SECTOR,SELIN  DECREMENT SECTOR ADDRESS
          SBML   SECSC,DEVICE
          STML   SS+/SS/P.SECTOR,SELIN
          PJN    CREC70      IF NO NEED TO ADJUST TRACK ADDRESS
          ADML   DVSEC,DEVICE  NUMBER OF SECTORS PER TRACK
          STML   SS+/SS/P.SECTOR,SELIN
          SOML   SS+/SS/P.TRACK,SELIN  DECREMENT TRACK ADDRESS
 CREC70   BSS
          LDML   SECSC,DEVICE  SET TO TRANSFER 1 SECTOR
          STML   NSEC        NUMBER OF SECTORS LEFT TO TRANSFER

          RJM    /RES/SEEKON  SEEK AND WAIT FOR ON-CYLINDER
          LDML   SS+/SS/P.SEEK,SELIN  CLEAR 'SEEK ISSUED' FLAG
          LPC    -/SS/K.SEEK
          STML   SS+/SS/P.SEEK,SELIN
          RJM    CWRITE      WRITE THE CYLINDER
          LDN    F.OPCMP     ISSUE OPERATION COMPLETE
          RJM    FUNC
          LDML   NTRANS      SAVE STARTING ADDRESS
          STML   SNTRANS
          UJK    CREC50      CONTINUE IN CONFIDENCE TEST

* CONFIDENCE TEST WAS SUCCESSFUL.

 CREC80   BSS
          LDML   NCPERR      NUMBER OF SECTORS SUCCESSFULLY COMPARED
          NJK    CREC90      IF CONFIDENCE TEST WAS SUCCESSFUL
          LDK    /RS/K.CFLAW  ALL THE SECTORS / TRACKS ARE FLAWED
          RJM    SDET        PUT ID IN RESPONSE
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          LOADOVL RECSO      LOAD OVERLAY
          RJM    /RC/INTRS   SEND INTERMEDIATE RESPONSE
 CREC90   BSS
          LDML   RECOV
          SBN    /RC/R20
          ZJN    CREC95      IF THE CONFIDENCE TEST WAS RUN AS
                             PART OF ERROR RECOVERY

* THE INITIAL CONFIDENCE TEST WAS BEING RUN.

          LDC    MAINA       SET UP RETURN ADDRESS
          STML   CTEST
          LJM    CTEST30     CONTINUE INITIAL CONFIDENCE TEST

* GO BACK TO ERROR RECOVERY.

 CREC95   BSS
          LOADOVL RECSO
          UJK    CRECX
          EJECT
 SDETX    LJM    **
 SDET     EQU    *-1         SAVE ERROR ID
          STDL   T1
          LMC    -0
          STDL   T2
          LDML   RS+/RS/P.DET  ERROR ID
          LPDL   T2
          ADDL   T1          ADD ERROR FLAG
          STML   RS+/RS/P.DET
          UJK    SDETX
          EJECT
 CFCYL    CON    821         844 CONFIDENCE TEST CYLINDER
          CON    842         885 CONFIDENCE TEST CYLINDER
 SECCYL   CON    450         844 - NUMBER OF SECTORS PER CYLINDER
          CON    1280        885 - NUMBER OF SECTORS PER CYLINDER
 SWORDS   CON    240         844 - NUMBER OF WORDS PER SECTOR
          CON    1024        885 - NUMBER OF WORDS PER SECTOR
          SPACE  6

* EACH ENTRY IN THE STVAL TABLE CONTAINS THE STARTING 16-BIT VALUE
* FOR INITIALIZING THE WRITE DATA BUFFER.  EACH 16 BIT-FIELD IN THE
* WRITE DATA BUFFER IS INCREMENTED BY 1.

 STVAL    CON    170000B     STARTING VALUES OF DATA
          CON    174000B
 STVL     EQU    2           NUMBER OF ENTRIES IN STVAL TABLE
          EJECT
 Q11      IFEQ   ERRTST,1
 TESTR2X  LJM    **          TERMINATE THE TEST AFTER RUNNING THE CONFIDENCE TEST
 TESTR2   EQU    *-1
          LDML   TESTPAR
          SBN    11
          NJK    TESTR2X
          RJM    TESTEND     TERMINATE THE TEST
          UJK    TESTR2X

 Q11      ENDIF
          EJECT


          QUAL   *
E10       ERRPL  *-OVAD3     CONFO






          OVERLAY (CONFIDENCE TEST, CRC),OVAD3
          ROUTINE CRCO

          QUAL   CC
          EJECT
* ASSUME EVERY ERROR IS A MEDIA ERROR, UNLESS THE SECTOR OR TRACK
* IS FLAWED.
* ACCEPT 3 MEDIA ERRORS IN THE CONFIDENCE TEST.

* CHECK IF SECTOR OR TRACK IS FLAWED.

 CRCX     LJM    **
 CRC      EQU    *-1
          LDDL   DEVICE
          NJN    CRC14       IF 885
          LDML   RS+/RS/P.DET2+5
          LPN    30B
          NJN    CRC40       IF TRACK OR SECTOR IS FLAWED
          UJN    CRC16

 CRC14    BSS
          LDML   RS+/RS/P.DET2+4
          SHN    17-11
          MJN    CRC40       IF TRACK IS FLAWED

 CRC16    BSS
          LDML   NMED        NUMBER OF MEDIA ERRORS SO FAR
          STDL   T1
          STDL   T2
          ZJN    CRC30       IF NO MEDIA ERRORS SO FAR
 CRC20    BSS
          LDML   MEDERR-1,T1  RECORDED ADDRESS OF PREVIOUS MEDIA ERRORS
          SBML   NTRANS
          ZJN    CRC40       IF THIS ADDRESS IS ALREADY IN THE LIST
                             OF MEDIA ERRORS
          SODL   T1
          NJK    CRC20       IF MORE TO CHECK

 CRC30    BSS
          LDML   NTRANS
          STML   MEDERR,T2   SAVE ADDRESS OF THIS MEDIA ERROR
          AOML   NMED        INCREMENT NUMBER OF MEDIA ERRORS
          SBN    NMEDL+1     NUMBER OF MEDIA ERRORS ALLOWED
          MJN    CRC40       IF ACCEPTABLE COUNT OF MEDIA ERRORS

* CONFIDENCE TEST FAILED.
* TOO MANY ERRORS DURING THE CONFIDENCE TEST.

          RJM    RECS        RECOVER
*         (NO RETURN FROM RECS.)


* INCREMENT TO NEXT SECTOR.

 CRC40    BSS
          LDML   SECSC,DEVICE  SECTOR INCREMENT
          RAML   NTRANS      INCREMENT NUMBER OF SECTORS TRANSFERRED
          STML   SNTRANS     SAVE STARTING OFFSET
          UJK    CRCX
          EJECT


          QUAL   *
E10       ERRPL  *-OVAD1     CRC



          OVERLAY (CONFIDENCE TEST, CREAD),OVAD3
          ROUTINE CRDO

          QUAL   CR
          EJECT
** NAME-- CREAD.
*
** PURPOSE-- READ THE CONFIDENCE TEST CYLINDER.
          SPACE  6
 CREAD10  BSS
          LDML   SS+/SS/P.DV,SELIN  GET DEVICE TYPE
          ERRNZ  -16+/SS/L.DV+/SS/N.DV
          LPN    /SS/M.DV
          STDL   DEVICE
          LDN    0
          STML   CKDATA      COMPARE DATA ON ONE SECTOR FOR EACH TRACK

* TRANSFER DATA FROM DISK.

 CREAD30  BSS
 Q20      IFEQ   ERRTST,1
          LDN    0
          STML   CITEST      CLEAR INCOMPLETE SECTOR ERROR
          LDML   CTPAR
          SBN    41B
          NJN    CREAD35
          LDML   SS+/SS/P.TRACK,SELIN
          NJN    CREAD32     IF NOT TIME TO FORCE AN ERROR
          LDML   SS+/SS/P.SECTOR,SELIN
          SBML   SAD1,DEVICE
          ZJN    CREAD36     ISSUE FORCE ERROR
          UJN    CREAD37

 CREAD32  BSS
          SBN    3
          NJN    CREAD37     IF NOT TIME TO FORCE AN ERROR
          LDML   SS+/SS/P.SECTOR,SELIN
          NJN    CREAD37     IF NOT TIME TO FORCE AN ERROR
          LDN    0           END OF TEST
          STML   CTPAR
          UJN    CREAD36

 CREAD35  BSS
          SBN    1
          NJN    CREAD37     IF NO ERROR TO FORCE
          LDN    0
          STML   ICSTEST     MAKE NEXT REQUEST RETRY SUCCEED
 CREAD36  BSS
          LDN    17B
          STML   CITEST      FORCE INCOMPLETE SECTOR
 CREAD37  BSS
 Q20      ENDIF

          LDN    F.READ      ISSUE READ FUNCTION TO DISK CONTROLLER
          RJM    FUNC
 CREAD40  RJM    ACN         ACN    DC
          LDML   CHWDS,DEVICE  NUMBER OF CHANNEL WORDS
          RJM    IAPMBF      IAPM   BUFF,DC
 E24      IFEQ   ERRTST,1
          ADML   CITEST      INCOMPLETE SECTOR
 E24      ENDIF
          STML   AREG        SAVE A REGISTER IN CASE OF PREMATURE TERMINATION
          RJM    CFM         CFM    CREAD47,DC
          UJN    CREAD47     IF NO CHANNEL ERROR

          RJM    CHNERR      RECORD CHANNEL ERROR
 CREAD45  BSS
          RJM    /RES/SEEKON  REISSUE SEEK
          UJK    CREAD30     RE-READ SECTOR

 CREAD47  BSS
          RJM    GENSTAT     GET GENERAL STATUS
          ZJN    CREAD48     IF NO ERRORS
          RJM    /RES/RDERR  CHECK READ ERRORS
          ZJN    CREAD48     IF ERROR WAS CORRECTED
          PJK    CREAD40     IF RETRY OF READ
 CREAD54  BSS
          AOML   SECTRY      INCREMENT SECTOR RETRY COUNT
          SBN    SCTRY
          PJN    CREAD57     IF MAXIMUM TRIES HAVE BEEN ATTEMPTED
          AOML   RS+/RS/P.STRY  INCREMENT SECTOR RETRY COUNT
          UJK    CREAD45     RESEEK AND READ SECTOR

* UNRECOVERED ERROR.

 CREAD57  BSS
          RJM    RECS        ATTEMPT TO RECOVER
*         (NO RETURN FROM RECS.)


* CHECK IF A FULL SECTOR WAS READ.

 CREAD48  BSS
          LDML   AREG        WAS ENTIRE SECTOR READ
          ZJN    CREAD50     IF ENTIRE SECTOR WAS READ
          STML   RS+/RS/P.FUNTO  NUMBER OF CHANNEL WORDS NOT RECEIVED
          LDK    /RS/K.IST   INCOMPLETE SECTOR TRANSFER
          RJM    SERRID      ERROR ID
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          UJK    CREAD54     RETRY SECTOR AND REQUEST


* UPDATE SECTOR ADDRESS AND CHECK FOR END OF TRACK.

 CREAD50  BSS
          LDML   CKDATA
          NJN    CREAD60     IF A SECTOR HAS BEEN COMPARED FOR THIS TRACK

          LDML   NMED        NUMBER OF MEDIA ERRORS SO FAR
          ZJN    CREAD53     IF NO MEDIA ERRORS SO FAR
          STDL   T1
 CREAD51  BSS
          LDML   MEDERR-1,T1   RECORDED ADDRESS OF PREVIOUS MEDIA ERRORS
          SBML   NTRANS
          ZJN    CREAD60     IF THIS ADDRESS COULD NOT BE WRITTEN
          SODL   T1
          NJK    CREAD51     IF MORE TO CHECK

 CREAD53  BSS
          RJM    CKD         CHECK THE DATA
          AOML   CKDATA      SET FLAG THAT DATA HAS BEEN CHECKED

 CREAD60  BSS
          RJM    /RES/RECRS  CHECK IF A PREVIOUS ERROR WAS RECOVERED
          LDML   SECSC,DEVICE  SECTOR INCREMENT
          RAML   SS+/SS/P.SECTOR,SELIN  INCREMENT SECTOR ADDRESS
          SBML   DVSEC,DEVICE  COMPARE WITH NUMBER OF SECTORS / TRACK
          MJN    CREAD70     IF NOT END OF TRACK
          STML   SS+/SS/P.SECTOR,SELIN  SET SECTOR
          AOML   SS+/SS/P.TRACK,SELIN  INCREMENT HEAD ADDRESS
          LDN    0
          STML   CKDATA      COMPARE DATA ON A SECTOR FOR EACH TRACK

* UPDATE BYTES TRANSFERRED.

 CREAD70  BSS
          LDML   SECSC,DEVICE  SECTOR INCREMENT
          RAML   NTRANS      INCREMENT NUMBER OF SECTORS TRANSFERRED
          LDML   NSEC        DECREMENT NUMBER OF SECTORS LEFT TO TRANSFER
          SBML   SECSC,DEVICE
          STML   NSEC
          NJK    CREAD30     IF MORE WORDS TO TRANSFER
          UJK    /CF/CREADX  IF END OF DATA

          EJECT
** NAME-- CKD
*
** PURPOSE-- CHECK THE DATA WHEN DOING THE CONFIDENCE TEST.
          SPACE  6
 CKX      LJM    **
 CKD      EQU    *-1
          LDML   STV         INDEX TO TABLE OF STARTING VALUES
          STDL   T1
          LDML   /CF/STVAL,T1  STARTING VALUE OF SECTOR
          ADN    1
          STDL   P1

          LDN    1
          STDL   T1

 CK20     BSS
          LDDL   P1
          SBML   BUFF,T1     COMPARE THE DATA
          NJN    CK40        IF COMPARE ERROR
          AODL   P1
          AODL   T1          INCREMENT PP WORD COUNT
          SBML   /CF/SWORDS,DEVICE  NUMBER OF WORDS PER SECTOR
          MJK    CK20        IF NOT END OF SECTOR
          LDML   SS+/SS/P.TRACK,SELIN  CHECK IF FIRST WORD OF SECTOR IS
                             THE TRACK AND SECTOR ADDRESS
          SHN    8
          ADML   SS+/SS/P.SECTOR,SELIN
          SBML   BUFF
          NJN    CK40        IF COMPARE ERROR
          AOML   NCPERR      COUNT NUMBER OF SECTORS SUCCESSFULLY COMPARED
          UJK    CKX

* DATA COMPARE ERROR.

 CK40     BSS
          AOML   CPERR       SET COMPARE ERROR
          UJK    CKX
          EJECT
 Q22      IFEQ   ERRTST,1
 SAD1     CON    20          SECTOR - 844
          CON    28          SECTOR - 885
 Q22      ENDIF
          EJECT


          QUAL   *
E10       ERRPL  *-OVAD1     CREAD



          OVERLAY (CONFIDENCE TEST, CWRITE),OVAD3
          ROUTINE CWRO

          QUAL   CW
          EJECT
** NAME-- CWRITE
*
** PURPOSE-- WRITE THE CONFIDENCE TEST CYLINDER.
          SPACE  6
 CWRI10   BSS
          LDML   SS+/SS/P.DV,SELIN  GET DEVICE TYPE
          ERRNZ  -16+/SS/L.DV+/SS/N.DV
          LPN    /SS/M.DV
          STDL   DEVICE
          RJM    INID        INITIALIZE THE WRITE DATA BUFFER

* CHECK IF THE DATA IS STILL IN THE BUFFER.
* AN ERROR RECOVERY OVERLAY COULD WIPE IT OUT.  (RECRS MAY CALL AN OVRLAY.)

 CWRI50   BSS
 Q21      IFEQ   ERRTST,1
          LDN    0
          STML   CITEST      CLEAR INCOMPLETE SECTOR ERROR
          LDML   CTPAR
          SBN    41B
          NJN    CWRI35      IF NOT ERROR CODE 41B
          LDML   SS+/SS/P.TRACK,SELIN
          NJN    CWRI32      IF NOT TIME TO FORCE AN ERROR
          LDML   SS+/SS/P.SECTOR,SELIN
          SBML   SAD1,DEVICE
          ZJN    CWRI36      ISSUE FORCE ERROR
          UJN    CWRI37

 CWRI32   BSS
          SBN    2
          NJN    CWRI37      IF NOT TIME TO FORCE AN ERROR
          LDML   SS+/SS/P.SECTOR,SELIN
          NJN    CWRI37      IF NOT TIME TO FORCE AN ERROR
          UJN    CWRI36

 CWRI35   BSS
          SBN    1
          NJN    CWRI37      IF NO ERROR TO FORCE
          LDN    0
          STML   ICSTEST     MAKE NEXT REQUEST RETRY SUCCEED
 CWRI36   BSS
          LDN    37B
          STML   CITEST      FORCE INCOMPLETE SECTOR
 CWRI37   BSS
 Q21      ENDIF

 CWRI40   BSS
          LDML   STV         INDEX TO TABLE OF STARTING VALUES
          STDL   T1
          LDML   /CF/STVAL,T1
          ADN    1           CHECK THE SECOND WORD
          SBML   BUFF+1
          ZJN    CWRI54      IF DATA IS STILL IN BUFFER
          RJM    INID        INITIALIZE THE DATA

* TRANSFER DATA TO DISK.

 CWRI54   BSS
          LDML   SS+/SS/P.TRACK,SELIN  PUT TRACK AND SECTOR ADDRESS IN
                             FIRST WORD OF SECTOR
          SHN    8
          ADML   SS+/SS/P.SECTOR,SELIN
          STML   BUFF
          LDN    F.WRITE     ISSUE WRITE FUNCTION TO DISK CONTROLLER
          RJM    FUNC        ISSUE THE FUNCTION
 CWRI56   BSS
          RJM    ACN         ACN    DC
          LDML   CHWDS,DEVICE  NUMBER OF CHANNEL WORDS PER DEVICE
 E25      IFEQ   ERRTST,1
          SBML   CITEST      INCOMPLETE SECTOR
 E25      ENDIF
          RJM    OAPMBF      OAPM   BUFF,DC
          RJM    DCN         FJM    *,DC      DCN    40B+DC
          RJM    GENSTAT     GET GENERAL STATUS
          RJM    CFM         CFM    CWRI57,DC
          UJN    CWRI57      IF NO CHANNEL ERROR

          RJM    CHERO       RECORD CHANNEL ERROR
          UJN    CWRI58      CHANNEL OUTPUT PARITY ERROR, UNRECOVERED

 CWRI57   BSS
          LDDL   GNSTAT      GENERAL STATUS
          ZJN    CWRI60      IF NO ERRORS
          RJM    /RES/RDERR  CHECK WRITE ERRORS
          ZJN    CWRI60      IF ERROR WAS CORRECTED
          PJN    CWRI56      IF RETRY OF WRITE.
                             'CONTINUE' FUNCTION HAS BEEN ISSUED
 CWRI58   UJK    CWRI95      UNRECOVERED ERROR

* UPDATE BYTES TRANSFERRED FROM PREVIOUS SECTOR WRITTEN.

 CWRI60   BSS
          LDML   NSEC        CHECK IF LAST SECTOR WAS TRANSFERRED
          SBML   SECSC,DEVICE
          NJN    CWRI64      IF NOT THE LAST SECTOR
          RJM    GENSTAT     GET GENERAL STATUS
          ZJN    CWRI64      IF NO ERRORS
          RJM    /RES/RDERR  CHECK WRITE ERRORS
          ZJN    CWRI64      IF ERROR WAS RECOVERED
          MJN    CWRI95      IF UNRECOVERED ERROR
          UJK    CWRI40      IF RETRY OF WRITE

 CWRI64   BSS
          RJM    /RES/RECRS  CHECK IF AN ERROR WAS RECOVERED

* UPDATE SECTOR ADDRESS AND CHECK FOR END OF TRACK.

          LDML   SECSC,DEVICE  SECTOR INCREMENT
          RAML   SS+/SS/P.SECTOR,SELIN  INCREMENT SECTOR ADDRESS
          SBML   DVSEC,DEVICE  COMPARE WITH NUMBER OF SECTORS / TRACK
          MJN    CWRI66      IF NOT END OF TRACK
          STML   SS+/SS/P.SECTOR,SELIN  SET SECTOR
          AOML   SS+/SS/P.TRACK,SELIN  INCREMENT HEAD ADDRESS

* UPDATE BYTES TRANSFERRED.

 CWRI66   BSS
          LDML   SECSC,DEVICE  SECTOR INCREMENT
          RAML   NTRANS      INCREMENT NUMBER OF SECTORS TRANSFERRED
          LDML   NSEC        DECREMENT NUMBER OF SECTORS LEFT TO TRANSFER
          SBML   SECSC,DEVICE
          STML   NSEC
          NJK    CWRI50      IF MORE TO TRANSFER
          UJK    /CF/CWRIX

* UNRECOVERED WRITE ERROR.

 CWRI95   BSS
          RJM    RECS        ATTEMPT TO RECOVER
*         (NO RETURN FROM RECS.)
          EJECT
** NAME-- INID
*
** PURPOSE-- INITIALIZE DATA FOR THE READ / WRITE CONFIDENCE TEST.
          SPACE  6
 INIX     LJM    **
 INID     EQU    *-1
          LDML   STV         INDEX TO TABLE OF STARTING VALUES
          STDL   T1
          LDML   /CF/STVAL,T1  INITIALIZE STARTING VALUE
          STDL   P1

          LDN    0
          STDL   T1

 INI20    BSS
          LDDL   P1
          STML   BUFF,T1     PUT DATA IN BUFFER
          AODL   P1
          AODL   T1          INCREMENT PP WORD COUNT
          SBML   /CF/SWORDS+1  NUMBER OF WORDS PER SECTOR (885)
          MJK    INI20       IF NOT DONE INITIALIZING THE DATA
          UJK    INIX
          EJECT
 Q22      IFEQ   ERRTST,1
 SAD1     CON    20          SECTOR - 844
          CON    28          SECTOR - 885
 Q22      ENDIF
          EJECT

          QUAL   *
E10       ERRPL  *-OVAD1     CWRITE

          OVERLAY (DEBUG TEST),BUFF
          ROUTINE TESTO
          QUAL   TE
          EJECT
* DEBUG TEST.
*
* PARAMETERS -
*    1 = WRITE FUNCTION ACCEPTED.
*        TIMEOUT ON GENERAL STATUS
*        TIMEOUT ON ALL FUNCTIONS EXCEPT AUTOLOAD
*        RAM PARITY ERROR.
*        (CONFIDENCE TEST FAILS, BUT REQUEST RETRY AFTER AUTOLOAD,
*        SUCCEEDS.)
*
*    2 = WRITE BUFFER TO DISK, RAM PARITY ERROR
*        TIMEOUT TO 2ND WRITE FUNCTION
*        TIMEOUT TO ALL FUNCTIONS EXCEPT AUTOLOAD
*        (CONFIDENCE TEST FAILS, BUT REQUEST RETRY AFTER AUTOLOAD,
*        SUCCEEDS.)
*
*    3 = INCOMPLETE DATA TRANSFER AFTER READ FUNCTION.
*        RAM PARITY ERROR.
*
*    4 = WRITE BUFFER TO DISK ERROR.  NOT RAM PARITY ERROR.
*        TIMEOUT TO 2ND WRITE FUNCTION.
*
*    5 = CONTROLLER RESERVED, RECOVERED.
*    6 = CONTROLLER RESERVED, UNRECOVERED.
*        (ALSO APPLIES TO CONFIDENCE TEST.)
*    7 = UNIT RESERVED, RECOVERED.
*  10B = UNIT RESERVED, UNRECOVERED.
*        (ALSO APPLIES TO CONFIDENCE TEST.)
*  11B = INCOMPLETE SECTOR TRANSFER, RECOVERED.
*  12B = INCOMPLETE SECTOR TRANSFER, UNRECOVERED.
*        CONFIDENCE TEST PASSES SO THE RESULT IS
*        UNRECOVERED MEDIA FAILURE.
*  13B = INCOMPLETE SECTOR TRANSFER, RECOVERED AFTER THE CONFIDENCE TEST IS RUN.
*  14B = CHANNEL PARITY ERROR, RECOVERED.
*  15B = CHANNEL PARITY ERROR, UNRECOVERED.
*        (ALSO APPLIES TO CONFIDENCE TEST.)
*
*
*  WHEN BITS 6 - 11 ARE SET WITH ONE OF THE ABOVE, IT APPLIES
*  TO THE CONFIDENCE TEST.
*
*  OTHER CONFIDENCE TEST CODES -
*
*  41B = THE CONFIDENCE TEST WILL RECORD THE FIRST 3 ERRORS AS
*        MEDIA ERRORS AND THEN SUCCEED.
*        WHEN WRITING, IT WILL ISSUE FORCE ERROR CODE 4 ON THE LAST SECTOR,
*        FIRST TRACK, AND ALSO, ON THE FIRST SECTOR, 3RD TRACK.
*        WHEN READING, IT WILL ISSUE FORCE ERROR CODE 3 ON THE LAST SECTOR,
*        FIRST TRACK, AND ALSO, ON THE FIRST SECTOR, 4TH TRACK.
*
*  4212B = CONFIDENCE TEST WILL FAIL BUT REQUEST RETRY WILL SUCCEED.
*          ISSUE FORCE ERROR CODE 3 OR 4 ON EVERY SECTOR ON THE CONFIDENCE
*          TEST.
          SPACE  6
 Q11      IFEQ   ERRTST,1
 TESTX    LJM    **
          QUAL   *
 TEST     EQU    *-1
          QUAL   TE
 Q111     IFEQ   ATST,1
          LDN    TESTN
          STDL   T1
 TEST2    BSS
          LDML   AUTOT
          SBML   TESTA-1,T1
          MJN    TEST3       IF NOT TIME TO SIMULATE AN ERROR
          SBN    10
          MJN    TEST4       IF TIME TO SIMULATE AN ERROR
 TEST3    BSS
          SODL   T1
          NJK    TEST2
          UJK    TESTX

 TEST4    BSS
          LDN    10
          RAML   AUTOT       TO PREVENT THE SAME FORCE ERROR CODE FROM BEING
                             ISSUED ON THE NEXT CALL
          RJM    TESTREC     MAKE SURE PREVIOUS ERROR IS ENDED
          LDML   TESTP-1,T1
          STML   TESTPAR

 Q111     ELSE
          LOADC  CM.PIT
          ADN    /PIT/C.CBUF  COMMUNICATION BUFFER
          STDL   P1
          CRDL   P2
          LDDL   P2
          ZJN    TESTX
          STML   TESTPAR     SAVE PARAMETER
          LDN    0
          STDL   P2
          LDDL   P1
          LMC    400000B
          CWDL   P2
 Q111     ENDIF

          LDML   TESTPAR
          SHN    -6
          STML   CTPAR       CONFIDENCE TEST CODES
          LDML   TESTPAR
          LPN    77B
          STDL   P1
          ZJN    TESTXX      IF NOT ERROR TO SIMULATE
          SBN    5
          PJN    TEST10      IF NOT FORCE ERROR FUNCTION
          RJM    /RES/FORC   FORCE ERROR FUNCTION (CODE = P1)
          UJN    TESTXX

 TEST10   BSS
          SBN    2
          PJN    TEST15

* PARAMETER = 5, 6.  CONTROLLER RESERVED TEST.

          LDC    2000B       CONTROLLER RESERVED STATUS
 TEST12   STDL   GNSTAT      GENERAL STATUS
          STML   GSTEST
 TESTXX   UJK    TESTX

 TEST15   BSS
          SBN    2
          PJN    TEST20

* PARAMETER = 7, 10B.  UNIT RESERVED TEST.

          LDN    10B         UNIT RESERVED STATUS
          UJK    TEST12

 TEST20   BSS
          SBN    3
          PJN    TEST30

* PARAMETER = 11B, 12B, 13B.  INCOMPLETE SECTOR TRANSFER TEST.

          LDC    123B        NUMBER OF WORDS NOT TRANSFERRED
          STML   ICSTEST
          UJK    TESTXX

 TEST30   BSS
          SBN    2
          PJK    TESTX

* PARAMETER = 14B, 15B.  CHANNEL PARITY TEST.

          AOML   CHTEST
          UJK    TESTXX
          SPACE  10
 Q112     IFEQ   ATST,1
 TESTA    BSS
*         CON    0           INITIAL CONFIDENCE TEST
          CON    11000
          CON    11200
          CON    11400
          CON    11600
          CON    11800
          CON    12000
          CON    12200
          CON    12400
          CON    12600
          CON    12800
          CON    13000
          CON    13100

 TESTP    BSS
***       CON    4100B
****      CON    4112B
*****     CON    4212B
******    CON    4200B       UNRECOVERED, USE FOR INITIAL CONFIDENCE TEST

**        CON    13B
**        CON    1
**        CON    5
**        CON    3
**        CON    7
**        CON    11B
**        CON    2
**        CON    14B
**        CON    4

***       CON    12B

          CON    15B         UNRECOVERED, DOWN UNIT

 TESTN    EQU    *-TESTP
 Q112     ENDIF
          EJECT

          QUAL   *
          ERRPL  *-END       IF > 0, TEST IS TOO LONG

*DECK DECK=IODECC EXPAND=FALSE

?? NEWTITLE := 'IODECC  : IO interpreter        : ''OS'' 2000 .. 3999' ??
?? OLDTITLE ??
*DECK DECK=IODISD EXPAND=FALSE
*copyc IODMAC1 "{RECORD DEFINITION MACROS}
*copyc IODMAC2 "{LOAD/STORE MACROS}
*copyc IODMAC3 "{GENERAL MACROS}
*copyc IODMAC4 "{GENERAL MACROS}
*copyc IODMAC5 "{OVERLAY MACROS}
** NAME--LOADS.
*
** PURPOSE-- LOAD A CM ADDRESS INTO THE R AND A REGISTERS.
*            AN INDEXED MEMORY LOCATION SPECIFIES THE ADDRESS.
*
** CALLING SEQUENCE-- LOADS   CMR,INDEX
*     THE 3-WORD CM ADDRESS IS CONTAINED IN THE LOCATIONS STARTING AT
*         CMR INDEXED BY INDEX.

 LOADS    MACRO  CMR,INDEX
 M        IFC    NE,$INDEX$$
          LDML   CMR,INDEX
          STD    CMADR
          LDML   CMR+1,INDEX
          STD    CMADR+1
          LRD    CMADR
          LDML   CMR+2,INDEX
          LMC    400000B
 M        ELSE
          LDML   CMR
          STD    CMADR
          LDML   CMR+1
          STD    CMADR+1
          LRD    CMADR
          LDML   CMR+2
          LMC    400000B
 M        ENDIF
          ENDM
          SPACE  6
          EJECT
 HARDW    EQU    1           = 1, TO RUN ON THE HARDWARE,
                             .NE. 1 TO RUN ON THE SIMULATOR
 SLOCK    EQU    1           = 0, TO ACTUALLY SET THE UNIT LOCK
 MULT     EQU    0           = 1, IF MULTIPLE CONTROLLERS ON 1 PP
 PAT      EQU    0           = 1, TO PATCH THE PP
 ERRTST   EQU    1           = 1, TO TEST ERROR HANDLING CODE
 ATST     EQU    0           = 1, TO TEST AUTOMATIC ERROR HANDLING CODE
 STREAM   EQU    1           = 1, TO STREAM REQUESTS
 VALID    EQU    0           = 1, TO VALIDATE CP TABLES
 SMALL    EQU    0           = 1, TO SUPPORT SMALL AND LARGE SECTORS


* EQUATES

 DC       EQU    22B         DISK CHANNEL
 SBYTE8   EQU    1024        NUMBER OF 16-BIT BYTES PER SECTOR
 CTLN     EQU    1           NUMBER OF CONTROLWARE WORDS TO READ INTO BUFFER
 CNTRY    EQU    3           NUMBER OF ATTEMPTS TO LOAD THE ADAPTER
 COSTRY   EQU    3           NUMBER OF ATTEMPTS TO LOAD COS
 RVTRY    EQU    10          LIMIT OF RECOVERED ERRORS PER REQUEST
 NRTRY    EQU    3           NUMBER OF ATTEMPTS TO RECOVER NOT READY
 C.CHCNT  EQU    37          NUMBER OF REQUESTS TO PROCESS BEFORE
                             CLEARING CHANNEL LOCK

* DISK FUNCTIONS

 F.CONECT EQU    0           CONNECT
 F.SEEK   EQU    1           SEEK
 K.CPRES  EQU    4000B       CLEAR PHYSICAL RESERVE ON UNIT
 K.CLRES  EQU    400B        CLEAR LOGICAL RESERVE ON UNIT
 F.LOADCB EQU    3           LOAD COMMAND BLOCK
 R.CON    EQU    0           CONNECT CM
 R.SEEK   EQU    21B         SEEK
 R.READ   EQU    60B         SEEK AND READ
 R.WRITE  EQU    40B         SEEK AND WRITE
 R.PUP    EQU    23B         POWER UP SPINDLE
 R.PDOWN  EQU    22B         POWER DOWN SPINDLE
 R.LDCM   EQU    116B        AUTOLOAD CONTROL MODULE
 R.DIAG   EQU    160B        70(16). RUN LEVEL II DIAGNOSTICS
 R.DIAGS  EQU    162B        RUN DIAGNOSTIC COMMAND 72

 F.READ   EQU    4           READ
 F.WRITE  EQU    5           WRITE
 F.LDCM   EQU    6           AUTOLOAD CONTROL MODULE
 F.WRITEV EQU    6           WRITE VERIFY
 F.OPCMP  EQU    10B         OPERATION COMPLETE
 F.GS     EQU    12B         GENERAL STATUS
 F.POLL   EQU    12B         POLL STATUS
 F.DS     EQU    13B         DETAILED STATUS
 F.CONT   EQU    14B         CONTINUE
 F.RCYL   EQU    21B         RETURN CYLINDER ADDRESS
 F.EDS    EQU    23B         EXTENDED DETAILED STATUS
 F.MOVD   EQU    24B         MOVE DATA
 F.MOVDT  EQU    25B         MOVE DATA AND TERMINATE
 F.TERT   EQU    26B         TERMINATE TRANSFER
 F.TERM   EQU    27B         TERMINATE ALL ACTIVE COMMANDS
 F.WRITEL EQU    35B         WRITE LAST SECTOR
 F.WRITVL EQU    36B         WRITE VERITY LAST SECTOR
 F.CLEAR  EQU    42B         CLEAR CONNECTED ACCESS
 F.WRBUF  EQU    46B         WRITE BUFFER TO DISK
 F.CHST   EQU    52B         INPUT PROCESSOR CHANNEL STATUS
 F.POWER  EQU    55B         POWER UP SPINDLE
 F.PDOWN  EQU    56B         POWER DOWN SPINDLE
 F.AUTDP  EQU    61B         AUTODUMP
 F.ADPT   EQU    64B         EXECUTE ADAPTER DIAGNOSTICS
 F.DIAG   EQU    65B         EXECUTE CM DIAGNOSTICS
 F.ERROR  EQU    66B         FORCE ERROR
 F.DELAY  EQU    73B         LOAD ATTENTION DELAY
 F.AUTOD  EQU    100B        AUTOLOAD FROM DISK
 F.AUTOP  EQU    414B        AUTOLOAD FROM PP
          SPACE  6
* INTERNAL DEVICE CODES

 DTISD1   EQU    0           ISD-1 DEVICE TYPE
 DTISD2   EQU    1           ISD-2 DEVICE TYPE
          EJECT
* INTERFACE ERROR CODES.
          SPACE  6
 E101     EQU    401B        PP REQUEST QUEUE LOCKWORD TIMEOUT
 E102     EQU    402B        UNIT REQUEST QUEUE LOCKWORD TIMEOUT
 E103     EQU    403B        UNIT LOCKWORD TIMEOUT
 E104     EQU    404B        CHANNEL LOCKWORD TIMEOUT
 E105     EQU    405B        BUFFER POOL LOCKWORD TIMEOUT
 E106     EQU    406B        UNIT HARDWARE RESERVE TIMEOUT
 E107     EQU    407B        CONTROLLER HARDWARE RESERVE TIMEOUT
 E201     EQU    1001B       RMA OF CHANNEL RESERVATION TABLE NOT
                             A WORD BOUNDARY
 E202     EQU    1002B       RMA OF UNIT ACTIVITY MASK NOT A
                             WORD BOUNDARY
 E203     EQU    1003B       RMA OF PP COMMUNICATION BUFFER NOT A
                             WORD BOUNDARY
 E204     EQU    1004B       RESERVED FIELD OF THE PP COMMUNICATION
                             BUFFER DESCRIPTOR IS NOT ZERO
 E205     EQU    1005B       RESERVED FIELD OF THE PP REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 E206     EQU    1006B       RMA OF NEXT PP NOT A WORD BOUNDARY
 E207     EQU    1007B       RESERVED FIELD OF THE PP RESPONSE
                             BUFFER DESCRIPTOR IS NOT ZERO
 E208     EQU    1010B       LOGICAL UNIT OF UNIT DESCRIPTOR NOT
                             IN SEQUENCE OR NOT IN RANGE
 E209     EQU    1011B       RMA OF UNIT INTERFACE TABLE NOT A
                             WORD BOUNDARY
 E20A     EQU    1012B       INVALID CHANNEL NUMBER SPECIFIED
                             IN UNIT DESCRIPTOR
 E20B     EQU    1013B       COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS OR NOT LONG ENOUGH
 E20C     EQU    1014B       RESERVED FIELD AFTER NUMBER OF
                             UNITS IS NOT ZERO
 E20D     EQU    1015B       RESERVED FIELD OF IN POINTER
                             IS NOT ZERO
 E20E     EQU    1016B       RESERVED FIELD OF OUT POINTER
                             IS NOT ZERO
 E20F     EQU    1017B       RESERVED FIELD OF LIMIT POINTER
                             IS NOT ZERO
 E210     EQU    1020B       INVALID PHYSICAL UNIT NUMBER
 E211     EQU    1021B       RMA OF INTERRUPT WORD NOT A WORD
                             BOUNDARY
 E212     EQU    1022B       RMA OF CHANNEL TABLE NOT A WORD
                             BOUNDARY
 E213     EQU    1023B       CONTROLWARE IS NOT PRESENT IN THE
                             PP COMMUNICATION BUFFER
 E301     EQU    1401B       LOGICAL UNIT NUMBER NOT EQUAL TO LOGICAL
                             UNIT OF UNIT DESCRIPTOR
 E302     EQU    1402B       RMA OF UNIT COMMUNICATION BUFFER
                             NOT A WORD BOUNDARY
 E303     EQU    1403B       A RESERVED FIELD OF THE UNIT COMMUNICATION BUFFER
                             DESCRIPTOR IS NOT ZERO
 E304     EQU    1404B       RMA OF NEXT UNIT REQUEST
                             NOT A WORD BOUNDARY
 E305     EQU    1405B       RESERVED FIELD OF UNIT REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 E306     EQU    1406B       INVALID UNIT TYPE
 E307     EQU    1407B       UNIT COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF CM WORDS
 E308     EQU    1410B       UNIT COMMUNICATION BUFFER IS TOO SMALL
 E401     EQU    2001B       RMA OF NEXT REQUEST NOT A WORD BOUNDARY
 E402     EQU    2002B       REQUEST LENGTH NOT A MULTIPLE
                             OF EIGHT BYTES
 E403     EQU    2003B       REQUEST LENGTH IS LESS THAN FORTY BYTES
 E404     EQU    2004B       LOGICAL UNIT NUMBER NOT EQUAL TO LOGICAL
                             UNIT IN UNIT INTERFACE TABLE
 E405     EQU    2005B       RESERVED LINKAGE FIELD IS NOT ZERO
 E406     EQU    2006B       INVALID RECOVERY/INTERRUPT SELECTIONS
 E407     EQU    2007B       INVALID PRIORITY SELECTION
 E408     EQU    2010B       INVALID SECONDARY ADDRESS
 E501     EQU    2401B       INVALID COMMAND CODE
 E502     EQU    2402B       INVALID FLAG SELECTION
 E503     EQU    2403B       INVALID FUNCTION
 E504     EQU    2404B       FUNCTION NOT SUPPORTED BY HARDWARE
 E505     EQU    2405B       INVALID LENGTH SPECIFICATION
                             IN COMMAND
 E506     EQU    2406B       INVALID ADDRESS SPECIFICATION
                             IN COMMAND
 E507     EQU    2407B       INVALID LENGTH SPECIFICATION IN
                             INDIRECT LIST
 E508     EQU    2410B       INVALID ADDRESS SPECIFICATION
                             IN INDIRECT LIST
 E509     EQU    2411B       PP COMMAND NOT ALLOWED IN REQUEST
                             TO A UNIT
 E50A     EQU    2412B       INVALID SEQUENCE OF COMMANDS
 E50B     EQU    2413B       INVALID PARAMETER SPECIFICATION
                             (POOL READ OR COMPARE SWAP COMMANDS)
          EJECT
* CONFIGURED UNITS.

 UN       RECORD PACKED

* WORD 1

 UNUSED   SUBRANGE 0,37777B
 CTST     BOOLEAN            NONZERO IF THE CONFIDENCE TEST WAS STARTED
 BUSY     BOOLEAN            COMMAND IN PROGRESS.  WAITING FOR ACTION
                             FROM ADAPTER

* WORD 2

 CM       SUBRANGE 0,17777B  CONTROL MODULE NUMBER AS SENT TO ADAPTER
 UNIT     SUBRANGE 0,7       UNIT NUMBER AS SENT TO ADAPTER

* WORD 3

 LUN      PPWORD             LOGICAL UNIT NUMBER

* WORD 4

 TMOT1    PPWORD             TIMEOUT FOR OUTSTANDING COMMANDS

* WORD 5

 TMOT2    PPWORD             TIMEOUT FOR OUTSTANDING COMMANDS

* WORD 6 - 8

 UIT      STRUCT 6           RMA OF UNIT INTERFACE TABLE (REFORMATTED)

* WORD 9 - 11

 CB       STRUCT 6           RMA OF UNIT COMMUNICATION BUFFER (REFORMATTED)



          MASKP  BUSY
 K.BUSY   EQU    MSK
          MASKP  CTST
 K.CTST   EQU    MSK

 UN       RECEND
          SPACE  10
* SS TABLE DEFINITIONS. INFORMATION SAVED FOR EACH UNIT.

 SS       RECORD PACKED

* WORD 1

 CHAN     SUBRANGE 0,77B     CHANNEL NUMBER
 FILL1    SUBRANGE 0,37B
 INIT     BOOLEAN            NONZERO IF SS ENTRY HAS BEEN INITIALIZED
 SEEK     BOOLEAN            SEEK ISSUED
 CUR      BOOLEAN            CURRENT REQUEST HAS BEEN SELECTED (IF SET)
 DV       SUBRANGE 0,3       DEVICE TYPE

* WORDS 2 - 6 = PARAMETERS FOR LOAD COMMAND BLOCK FUNCTION.

 FILL2    SUBRANGE 0,7
 SMALL    BOOLEAN            512 BYTE SECTOR, IF SET
 PRIOV    BOOLEAN            PRIORITY OVERRIDE IF SET
 FILL3    SUBRANGE 0,37B
 CMOD     SUBRANGE 0,7       CONTROL MODULE NUMBER
 UNIT     SUBRANGE 0,7       UNIT NUMBER
*
 FUNC     PPWORD             FUNCTION CODE
*
 CYL      PPWORD             CYLINDER ADDRESS
*
 TRACK    SUBRANGE 0,377B    TRACK ADDRESS
 SECTOR   SUBRANGE 0,377B    SECTOR ADDRESS
*
 TLFLG    BOOLEAN            NONZERO MEANS USE TRANSFER LENGTH
 LENGTH   SUBRANGE 0,77777B  TRANSFER LENGTH

* WORD 7 - END = SAVED INFORMATION PER UNIT.

 FNC      PPWORD             FUNCTION CODE  READ = 0
                                            WRITE = 1
                                            WRITE INITIALIZE = 2
 REQ      STRUCT 4           CURRENT REQUEST (UNFORMATTED RMA)
 PVA      STRUCT 6           PVA OF CURRENT REQUEST
 REQ2     STRUCT 6           CURRENT REQUEST (REFORMATTED RMA)

 QP       STRUCT 4           CURRENT QUEUE POINTER
 LASTC    PPWORD             OFFSET OF COMMAND IN REQUEST
 FRST     PPWORD             = 0, IF FIRST TIME THROUGH UNCMND
 NUMCM    PPWORD             NUMBER OF COMMANDS LEFT TO PROCESS IN
                             THIS REQUEST
 LISTL    PPWORD             NUMBER OF CM WORDS IN ADDRESS-LENGTH PAIR LIST.
                             (INCLUDES THE NUMBER OF WORDS WHICH HAVENT
                             BEEN READ FROM CM.)
 MAUS     PPWORD             NUMBER OF SECTORS TO TRANSFER ON CURRENT REQUEST
 TOTAL    STRUCT 2           TOTAL CM WORDS LEFT TO TRANSFER BEFORE TERMINATING
 FCOMRQ   STRUCT 4           FIRST COMPLETED REQUEST (RMA)
 CURRQ    STRUCT 4           CURRENT REQUEST (RMA)
 PRERQ    STRUCT 4           PREVIOUS REQUEST (RMA)
 NCOMRQ   PPWORD             NUMBER OF COMPLETED REQUESTS
 NCOMW    PPWORD             NUMBER OF COMPLETED WRITE REQUESTS
 CURTRK   PPWORD             CURRENT TRACK
 CURSEC   PPWORD             CURRENT SECTOR
 SWFLG    PPWORD             NONZERO IF A STREAMING REQUEST SWITCH WAS MADE
 RVCNT    PPWORD             COUNT OF RECOVERED ERRORS PER REQUEST
 RQTRY    PPWORD             REQUEST RETRY COUNT
 ADERR    PPWORD             ADAPTER ERROR
 NR       PPWORD             NOT READY RETRY COUNT
 LAD      PPWORD             LOAD ADAPTER RETRY COUNTER
 CMLD     PPWORD             CM LOAD RETRY COUNTER
 PRELD    PPWORD             PRELOAD OF CONTROL MODULE IF NONZERO
 DIAG     PPWORD             NONZERO IF RUNNING LEVEL II DIAGNOSTICS
 DIAGS    PPWORD             NONZERO IF RUNNING DIAGNOSTICS COMMAND 72
 RECOV    PPWORD             NONZERO IF IN RECOVERY

 FILL3    SUBRANGE 0,3777B
 CONF     BOOLEAN            NONZERO IF RUNNING THE CONFIDENCE TEST
 CPERR    BOOLEAN            NONZERO IF THERE WAS A COMPARE ERROR IN
                             THE CONFIDENCE TEST
 STV      SUBRANGE 0,7       INDEX TO TABLE OF DATA PATTERNS FOR THE
                             CONFIDENCE TEST


* CURRENT REQUEST.  MUST BE ALIGNED ON A WORD BOUNDARY.

          ALIGN  0,64
 RQ       STRUCT 40          REQUEST

 CMLIST   STRUCT 8           CURRENT DATA ADDRESS OR CURRENT COMMAND

* RESPONSE.

 RS       STRUCT 152         RESPONSE
          MGEN   N.CUR
 M.CUR    EQU    MASK$
          MGEN   N.SEEK
 M.SEEK   EQU    MASK$
          MASKP  SEEK
 K.SEEK   EQU    MSK
          MASKP  CUR
 K.CUR    EQU    MSK
          MASKP  INIT
 K.INIT   EQU    MSK
          MGEN   N.CHAN
 M.CHAN   EQU    MASK$
          MGEN   N.DV
 M.DV     EQU    MASK$
          MASKP  SMALL
 K.SMALL  EQU    MSK
          MGEN   N.SMALL
 M.SMALL  EQU    MASK$
          MASKP  PRIOV
 K.PRIOV  EQU    MSK
          MGEN   N.UNIT
 M.UNIT   EQU    MASK$
          MASKP  UNIT
 K.UNIT   EQU    MSK
          MASKP  CMOD
 K.CMOD   EQU    MSK
          MGEN   N.CMOD
 M.CMOD   EQU    MASK$
          MGEN   N.TRACK
 M.TRACK  EQU    MASK$
          MGEN   N.SECTOR
 M.SECTOR EQU    MASK$
          MASKP  CONF
 K.CONF   EQU    MSK
          MASKP  CPERR
 K.CPERR  EQU    MSK
          MASKP  STV
 K.STV    EQU    MSK
          MGEN   N.STV
 M.STV    EQU    MASK$

 SS       RECEND
          SPACE  6
* PP TABLE.

 PT       RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 PART     PPWORD             PARTNER PP NUMBER
 PIT      RMA                PP INTERFACE TABLE ADDRESS (RMA)
 PITPVA   STRUCT 24          PP INTERFACE TABLE ADDRESS (PVA)

 PT       RECEND
          SPACE  6
* PP INTERFACE TABLE
 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
 ACTIVE   BOOLEAN            ACTIVE_CHECK FLAG.  WHEN SET, THE PP
                             MUST CLEAR IT.
 IDLE     BOOLEAN            IDLE REQUEST
 RESUME   BOOLEAN            RESUME REQUEST
 IDSTAT   BOOLEAN            IDLE_STATUS. IF SET, THE PP IS SOFTWARE IDLED.
 FILL1    SUBRANGE 0,3777B
 LOCKF    BOOLEAN            THIS LOCK FLAG MUST BE SET BEFORE CHANGING ANYTHING
                             IN THIS CM WORD.
          ALIGN  0,64
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER
          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)
          ALIGN  32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER




          MASKP  ACTIVE
 K.ACTIVE EQU    MSK
          MASKP  IDLE
 K.IDLE   EQU    MSK
          MASKP  RESUME
 K.RESUME EQU    MSK
          MASKP  IDSTAT
 K.IDSTAT EQU    MSK
          MASKP  LOCKF
 K.LOCKF  EQU    MSK
 K.ACTION EQU    K.ACTIVE+K.IDLE+K.RESUME

 PIT      RECEND
          SPACE  6
* UNIT DESCRIPTORS.

 UD       RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 UD       RECEND
          SPACE  6
* UNIT INTERFACE TABLE

 UIT      RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
                               = 400B, 844-4X
                               = 401B, 885-1X
                               = 402B, 885-42
 QCNT     PPWORD             QUEUE COUNT
*
          ALIGN  16,64
 UBUFL    PPWORD             UNIT COMMUNICATION BUFFER LENGTH
 UBUF     RMA                UNIT COMMUNICATION BUFFER (RMA)
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

          MASKP  DSABLE
 K.DSABLE EQU    MSK

 UIT      RECEND
          SPACE  6
* PP REQUESTS.

 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS
                               0 - ATTEMPT RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
          ALIGN  0,64
 SWIT     BOOLEAN            SWITCH TO NEXT REQUEST
 FILL     SUBRANGE 0,37B
 MAUS     SUBRANGE 0,1777B   NUMBER OF SECTORS IN THIS REQUEST
          ALIGN  16,64
 CYL      PPWORD             CYLINDER ADDRESS
 TRACK    PPWORD             TRACK ADDRESS
 SECTOR   PPWORD             SECTOR ADDRESS
 CMND     INTEGER            COMMAND SEQUENCE


          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$
          MGEN   N.MAUS
 M.MAUS   EQU    MASK$

 RQ       RECEND
          SPACE  6
* PP COMMAND.

 CM       RECORD PACKED

 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$

 CM       RECEND
          SPACE  6
* COMMAND CODES.

 C.ACK    EQU    0           ACKNOWLEDGE
 C.STOP   EQU    1           STOP UNIT
 C.SELU   EQU    2           SELECT UNIT
 C.SELC   EQU    3           SELECT CONTROLLER
 C.IDLE   EQU    4           IDLE
 C.RESUME EQU    5           RESUME
 C.OLAY   EQU    6           EXECUTE OVERLAY
 C.READY  EQU    7           START READY SCAN
 C.SREADY EQU    10B         STOP READY SCAN
 C.PPAD   EQU    11B         SELECT PP MEMORY ADDRESS
 C.PPMEM  EQU    12B         COPY PP MEMORY
 C.LDCON  EQU    14B         LOAD CONTROLWARE
 C.LDCM   EQU    15B         LOAD CONTROL MODULE (CONTROLWARE)
 C.ONUN   EQU    20B         ENABLE UNIT
 C.OFFUN  EQU    21B         DISABLE UNIT
 C.FUNC   EQU    40B         OUTPUT FUNCTION
 C.OUTP   EQU    41B         OUTPUT 8-BIT PARAMETERS
 C.OUTD   EQU    43B         OUTPUT 8-BIT DATA
 C.IND    EQU    45B         INPUT 8-BIT DATA/PARAMETERS
 C.READ   EQU    100B        READ BYTES
 C.WRITE  EQU    120B        WRITE BYTES
 C.STATUS EQU    140B        READ STATUS
 C.COUNT  EQU    141B        STORE TRANSFER COUNT
 C.SWAP   EQU    160B        COMPARE AND SWAP
 C.WRITEI EQU    162B        WRITE INITIALIZE
 C.RFLAW  EQU    163B        READ FLAW MAPS
 C.WRITEV EQU    200B        WRITE VERIFY
          SPACE  6
* PP RESPONSE.

 RS       RECORD PACKED

* WORD 1.
 FILL1    BOOLEAN
 SHORT    BOOLEAN            IF SET, IT IS A ONE-WORD NORMAL RESPONSE
          ALIGN  8,64
 LUN      SUBRANGE 0,377B    LOGICAL UNIT
 PVA      STRUCT 6           PVA OF REQUEST

* WORD 2.
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST  (NOT USED)

* WORD 3.
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST) (NOT USED)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)  (NOT USED)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS  (NOT USED)
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY  (NOT USED)
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

* WORD 4.
          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED  (NOT USED)
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE INTERFACE
                             ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
                             (NOT USED)
 CHERR    BOOLEAN            CHANNEL PARITY ERROR
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION
                             OCCURRED ON INPUT OR INADEQUATE DATA RATE ON OUTPUT
                             (NOT USED)
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT  (NOT USED)
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A
                             HARDWARE MALFUNCTION.  EX: UNIT NOT READY,
                             UNIT NOT CONNECTED.  (NOT USED)
 FTO      BOOLEAN            FUNCTION TIMEOUT
 CHERO    BOOLEAN            CHANNEL OUTPUT PARITY ERROR
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
                               1 - RECOVERED ERROR
                               2 - COMMAND HAD EXPLICIT RESPONSE FLAG SET
                               3 - BOTH CONDITIONS 1 AND 2
 K.REC    EQU    1           RECOVERED ERROR
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE  (NOT USED)
                               1 - UNIT CHANGED FROM READY TO NOT READY
                               2 - UNIT CHANGED FROM NOT READY TO READY
                               3 - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
                               4 - CONTROLLER RESERVED
                               5 - UNIT RESERVED TO ANOTHER ACCESS
                               6 - RECOVERED ABNORMAL CONDITION
          ALIGN  49,64       ALERT CONDITIONS
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

* WORD 5.
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)

* WORD 6.

 CHAN     PPWORD             CHANNEL NUMBER
 SCYL     PPWORD             STARTING CYLINDER
 STRK     PPWORD             STARTING TRACK
 SSEC     PPWORD             STARTING SECTOR

* WORD 7.

 UNIT     PPWORD             UNIT NUMBER
 RTRY     PPWORD             REQUEST RETRY COUNT
 FTRK     PPWORD             FAILING TRACK
 FSEC     PPWORD             FAILING SECTOR

* WORD 8.

 DET      PPWORD             =1, IF DETAILED STATUS PRESENT
 K.CSP    EQU    1           CONTROLLER STATUS PRESENT
 K.DSP    EQU    2           DEVICE STATUS PRESENT
 K.ERIP   EQU    4           ERROR REGISTER IMAGE PRESENT
 K.ELP    EQU    10B         ERROR LOG PRESENT
 K.ICS    EQU    20B         INCORRECT CONTROLLER WAS SELECTED
 K.CSC    EQU    40B         CANNOT SELECT THE CONTROLLER
                             SELECT ACTIVE NEVER GETS SET
 K.TIP    EQU    100B        TIMEOUT - TRANSFER IN PROGRESS
                             DIDN'T CLEAR
 K.TOP    EQU    200B        TIMEOUT - PAUSE DIDN'T CLEAR
 K.ICA    EQU    400B        ERROR IN INITIALIZING CHANNEL ADAPTER
 K.HIE    EQU    1000B       HOST I/F INTEGRITY ERROR
 K.DIE    EQU    2000B       DRIVE I/F INTEGRITY ERROR
 K.MC     EQU    4000B       MASTER CLEAR DID NOT WORK
 K.CT     EQU    10000B      RUNNING THE CONFIDENCE TEST
 K.HOST   EQU    40000B      NOT THE SAME HOST ID
 K.SEC    EQU    100000B     SECTOR SIZE NOT 4096

 ID       PPWORD             ERROR IDENTIFIER
 K.CMLD   EQU    1           RELOAD OF CONTROL MODULE WAS ATTEMPTED
 K.CMLDS  EQU    2           CONTROL MODULE RELOADED SUCCESSFULLY
 K.XD     EQU    4           EXECUTING LEVEL II DIAGNOSTICS
 K.XDP    EQU    10B         LEVEL II DIAGNOSTICS PASSED
 K.PU     EQU    20B         POWERING UP SPINDLE
 K.PUC    EQU    40B         SPINDLE POWERED UP
 K.PTO    EQU    100B        PP TIMED OUT A COMMAND
 K.UDN    EQU    20000B      UNIT DOWN
 K.CMDN   EQU    40000B      CONTROL MODULE DOWN
 K.CHDN   EQU    100000B     CHANNEL DOWN
 FILL2    PPWORD
 STRY     PPWORD             SECTOR RETRY COUNT

* WORD 9.

 GENST1   PPWORD             GENERAL STATUS OF THE FIRST TIME ERROR
                               WAS ENCOUNTERED
 GENST2   PPWORD             GENERAL STATUS OF THE LAST TIME ERROR
                               WAS ENCOUNTERED
 FUNTO    PPWORD             FUNCTION CODE IF FUNCTION TIMEOUT ERROR
 ERRID    PPWORD             ERROR IDENTIFIER
 K.IST    EQU    1           INCOMPLETE SECTOR TRANSFER
 K.CRES   EQU    2           CLEAR UNIT RESERVE ON OPPOSITE ACCESS
 K.RAM    EQU    4           RAM PARITY ERROR
 K.CLOAD  EQU    10B         CONTROLWARE LOAD WAS ATTEMPTED
 K.AFT    EQU    20B         AUTOLOAD FUNCTION TIMEOUT
 K.CEMPT  EQU    40B         CHANNEL DOESNT GO EMPTY AFTER SENDING
                             PARAMETERS / DATA
 K.CINAC  EQU    100B        CHANNEL NOT INACTIVE AFTER
                             RECEIVING PARAMETERS / DATA
 K.MEDIA  EQU    200B        MEDIA FAILURE, REREAD SECTOR
 K.UNMED  EQU    400B        UNRECOVERED MEDIA ERROR
 K.RERR   EQU    1000B       READ ERROR.  STATUS BEFORE SUSPEND/TERMINATE .NE.
                             4XXXB.
 K.CF     EQU    2000B       POLL STATUS NONZERO AFTER SENDING CONTROLWARE
 K.DE     EQU    4000B       POLL STATUS NONZERO AFTER LOADING ATTENTION DELAY
 K.NR     EQU    10000B      NOT READY
 K.URS    EQU    20000B      UNIT RESERVED
 K.CRS    EQU    40000B      CONTROLLER RESERVED
 K.ADPT   EQU    100000B     ADAPTER CONTROLWARE ERROR

* WORD 10.

          ALIGN  0,64
 DETAIL   STRUCT 40          DETAILED STATUS OF THE FIRST TIME ERROR
                             WAS ENCOUNTERED
 DET2     STRUCT 40          DETAILED STATUS OF THE LAST TIME ERROR
                             WAS ENCOUNTERED.


          MASKP  SHORT
 K.SHORT  EQU    MSK
          MGEN   N.LUN
 M.LUN    EQU    MASK$
          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$
          MASKP  INTERR
 K.INTERR EQU    MSK
          MASKP  DATOV
 K.DATOV  EQU    MSK
          MASKP  DATERR
 K.DATERR EQU    MSK
          MASKP  HDWR
 K.HDWR   EQU    MSK
          MASKP  CHERR
 K.CHERR  EQU    MSK
          MASKP  CHERO
 K.CHERO  EQU    MSK
          MASKP  NRDY
 K.NRDY   EQU    MSK
          MASKP  FTO
 K.FTO    EQU    MSK

 RS       RECEND
          SPACE  6
* RESPONSE CODES.
 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    1           INTERMEDIATE RESPONSE
 R.NRM    EQU    2           NORMAL REQUEST TERMINATION
 R.ABN    EQU    3           ABNORMAL REQUEST TERMINATION
          SPACE  10
* PP COMMUNICATION BUFFER.

 CB       RECORD PACKED

          ALIGN  31,64
 SLAVE    BOOLEAN            NONZERO IF SLAVE PP
 PARTNR   RMA                PARTNERS COMMUNICATION BUFFER (RMA)

 CONTRL   STRUCT 8           LOAD CONTROLWARE COMMAND
 CMCTRL   STRUCT 8           LOAD CONTROL MODULE CONTROLWARE
          STRUCT 24
          STRUCT 24

 MSGIN    PPWORD             MESSAGE TO MASTER FROM SLAVE

          ALIGN  0,64
 MSGOUT   PPWORD             MESSAGE TO SLAVE FROM MASTER

          ALIGN  0,64
 ZERO     STRUCT 272         CONTAINS ALL ZEROES

          ALIGN  0,64
 SS       STRUCT 40          SS ENTRY

 REQ      STRUCT 40          REQUEST

          ALIGN  0,64
 OVR      STRUCT 2000        PP OVERLAY



          MASKP  SLAVE
K.SLAVE   EQU    MSK


 CB       RECEND
          SPACE  6
* COMMANDS BETWEEN PPS.

 C.GO     EQU    1           DONE WITH THE DISK FOR THIS SECTOR
 C.REQ    EQU    2           START A DISK REQUEST
 C.ABT    EQU    3           ABORT THE REQUEST
 C.SWIT   EQU    4           SWITCH TO THE NEXT REQUEST
 C.END    EQU    5           END OF THE DISK REQUEST
          EJECT
          CON    INIT-1


* DIRECT CELLS

 CM.PIT   BSSZ   3           CM ADDRESS OF PP INTERFACE TABLE (REFORMATED)

 T1       BSSZ   1
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1

 CMADR    BSSZ   3           CM ADDRESS
 MOVFC    BSSZ   1           MOVE DATA FUNCTION CODE
 CHAN     BSSZ   1           CHANNEL NUMBER
 PLSTAT   BSSZ   1           POLL STATUS
 CMNDS    BSSZ   1           NUMBER OF OUTSTANDING COMMANDS TO ADAPTER
 CMOD     BSSZ   1           CONTROL MODULE NUMBER
 UX       BSSZ   1           INDEX TO UNITS TABLE
 FI       CON    0           INDEX TO FUNCTION HISTORY BUFFER
 SI       CON    0           INDEX TO POLL STATUS HISTORY BUFFER
 P1       BSSZ   1
 P2       BSSZ   1
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 P6       BSSZ   1
 WC       BSSZ   1           WORD COUNT TO READ/WRITE CM WORDS

 FNC      BSSZ   1           FUNCTION CODE (INTERNAL)
 DEVICE   BSSZ   1           DEVICE TYPE
 WDS      BSSZ   1           NUMBER OF CM WORDS TO TRANSFER FROM CURRENT SECTOR.
 WDSS     BSSZ   1           USED TO UPDATE BYTES TRANSFERRED IN RESPONSE STATUS
 TWDS     BSSZ   1           TOTAL NUMBER OF SECTORS TO TRANSFER TO THE
                             CM ADDRESS.
 SECPOS   BSSZ   1           SECTOR BUFFER TRANSFER POSITION (TO CM)
 RESPC    BSSZ   1           RESPONSE CODE
 UDL      BSSZ   1           LENGTH OF UNIT DESCRIPTORS (CM WORDS)
 LUX      BSSZ   1           VALUE OF UNIT INDEX OF LAST UNIT SELECTED
          IFEQ   SMALL,1
 SZ       BSSZ   1           SECTOR SIZE.  =0 IF SMALL SECTOR,
                             =1 IF LARGE SECTOR
          ENDIF
 AREG     BSSZ   1           A REGISTER AFTER TRANSFER
 SSUN     CON    7777B       UX VALUE OF CURRENT SS TABLE
 CHLOCK   BSSZ   1           SET NONZERO IF CHANNEL LOCK IS SET
 UNUML    BSSZ   1           LENGTH OF CONFIGURED UNIT ENTRIES
 QEND     BSSZ   1           SET NONZERO IF THE LAST REQUEST IN
                               THE QUEUE WAS PROCESSED
 IDLE     BSSZ   1           NONZERO IF IDLE COMMAND RECEIVED,
                               RESUME COMMAND RESETS IT TO 0
 STRRQ    BSSZ   1           SET NONZERO IF STREAMING REQUESTS
 CHGUN    BSSZ   1           FLAG USED BY POLSTAT TO CONTROL CHANGING
                             THE SS ENTRY
 DTSTAT   BSSZ   1           GET DETAILED STATUS DURING ERROR RECOVERY
 CSTREAM  BSSZ   1           CONTINUE STREAMING FLAG
 UNUSED1  BSSZ   1
 UNUSED2  BSSZ   1
 CURCH    CON    DC          CURRENT CHANNEL NUMBER
 FUNCD    BSSZ   1           FUNCTION CODE
 FRSTSC   BSSZ   1           FIRST SECTOR FLAG
 STORS    BSSZ   1           STORE RESPONSE FLAG (USED BY RESPIN)
                               = 0, IF A RESPONSE IS SENT TO CM
                               = NONZERO, IF NO RESPONSE WAS SENT TO CM
 CHLCNT   BSSZ   1           NUMBER OF REQUESTS TO PROCESS BEFORE
                             CLEARING CHANNEL LOCK
 IALF     BSSZ   1           BIT 1 = 1, IF CONTROLWARE HAS BEEN LOADED
                             ON ALL CONTROLLERS
                             BIT 2 = 1, IF CONFIDENCE TEST HAS BEEN STARTED
                             ON ALL CONTROLLERS
 RCON     BSSZ   1           ADDITIONAL RESPONSE CONDITION
          SPACE  3
          ORG    72B

 DSRTP    CON    0           HCS REAL MEMORY WORD-ADDRESS
          CON    1
 NODEL    EQU    DSRTP       DON'T DELINK REQUEST FLAG
 INPNT    EQU    DSRTP+1     IN POINTER FOR RESPONSE BUFFER
 LIM      BSSZ   1           LIMIT OF RESPONSE BUFFER (IN 8-BIT BYTES)
 PPNO     CON    1           LOGICAL PP NUMBER
          ORG    76B
          CON    5           TEMPORARY, PP TYPE USED BY DEADSTART
 LDCMF    EQU    76B         LOAD CONTROL MODULE, IF NONZERO
 LFF00    BSSZ   1
          EJECT
          ORG    100B
          LJM    INIT
          CON    CONTYP      ID FOR ISD
          SPACE  6
 HALT     CON    0
          UJN    *           HALT THE PP
          SPACE  6
* TRANSFER SIZE BEFORE SUSPENDING (64-BIT WORDS).

 XFERSZ   CON    4           TRANSFER SIZE BEFORE SUSPENDING (2048 BYTE SECTORS)
                             ISD-1
          CON    4           ISD-2

* NUMBER OF 16-BIT WORDS TO TRANSFER FOR EACH SECTOR.

          IFNE   SMALL,1
 SECWDS   EQU    1024        LARGE SECTOR
          ELSE
 SECWDS   CON    256         SMALL SECTOR
          CON    1024        LARGE SECTOR
          ENDIF

* NUMBER BY WHICH THE SECTOR ADDRESS IS INCREMENTED
* FOR EACH SECTOR.

          IFNE   SMALL,1
 SECSC    EQU    4           LARGE SECTOR
          ELSE
 SECSC    CON    1           SMALL SECTOR
          CON    4           LARGE SECTOR
          ENDIF

* NUMBER OF SECTORS PER TRACK FOR EACH DEVICE.

 DVSEC    CON    32          ISD-1
          CON    47          ISD-2

* NUMBER OF TRACKS PER CYLINDER FOR EACH DEVICE.

          IFEQ   T1,0
 DVTRK    CON    10          ISD-1
          CON    24          ISD-2
          ENDIF

* NUMBER OF CM WORDS TO TRANSFER FOR EACH SECTOR.

          IFNE   SMALL,1
 CMWDS    EQU    256         LARGE SECTOR
          ELSE
 CMWDS    CON    64          SMALL SECTOR
          CON    256         LARGE SECTOR
          ENDIF

* DELAY VALUES FOR EACH DEVICE.

 DELV     CON    4010B       ISD-1, 1 LARGE SECTOR OR 8 TINY SECTORS
          CON    2004B       ISD-2, 1 LARGE SECTOR OR 4 TINY SECTORS



          SPACE  6
 CM.CB    BSSZ   3           CM ADDRESS OF PP COMMUNICATION BUFFER (REFORMATTED)
 CM.RS    BSSZ   3           CM ADDRESS OF RESPONSE BUFFER (REFORMATTED)
 CM.INT   BSSZ   3           CM ADDRESS OF INTERRUPT WORD
 CM.CHAN  BSSZ   3           CM ADDRESS OF CHANNEL INTERLOCK TABLE
 DH       BSSZ   3           CM ADDRESS OF OVERLAY DIRECTORY

          SPACE  2
          EJECT
          QUAL   RES
*COPYC IODMAC6
          EJECT
 SCLX     LJM    **
 SCLOCK   EQU    *-1
          LDDL   CHLOCK
          ZJN    SCL1        IF CHANNEL LOCK IS NOT SET
          LDN    0           EXIT A REGISTER = 0
          UJK    SCLX

 SCL1     BSS
          LOADOVL RECSO
          LJM    SCL10

 ADPTERR  CON    0
          LOADOVL RECSO
          LJM    ADPTR

 RECS     CON    0
          LOADOVL RECSO
          LJM    RECSA

 NOTRX    LJM    **
 NOTRDY   EQU    *-1
          LOADOVL RECSO
          LJM    NOTR

 ATERM    CON    0
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LOADOVL RECSO
          LJM    ATERMA

 HTERM    CON    0
          LOADOVL RECSO
          LJM    HTERM1

 UTERM    CON    0
          LOADOVL DOWNO
          LJM    UTERM1

 OTERM    CON    0
          LOADOVL DOWNO
          LJM    OTERM1

 OCTERM   CON    0
          LOADOVL DOWNO
          LJM    OCTERM1

 LTERM    CON    0
          LOADOVL DOWNO
          LJM    LTERM1

 PPRQX    LJM    **
 PPREQ    EQU    *-1
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          ERRNZ  /PIT/C.ACTIVE
          CRDL   T1          READ PP REQUEST FLAGS
 PPRQ5    BSS
          LDDL   T4
          LPK    /PIT/K.ACTION  PP REQUEST FLAGS
          ZJK    PPRQX       IF NO PP REQUESTS
          SHN    /PIT/L.ACTIVE+2
          PJN    PPRQ6       IF THE ACTIVE CHECK FLAG IS NOT SET

* THE ACTIVE CHECK FLAG IS SET.
* SET THE LOCK, AND CLEAR THE ACTIVE CHECK FLAG.

          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDK    /PIT/K.LOCKF
          STDL   T4
          LOADC  CM.PIT
          ERRNZ  /PIT/C.ACTIVE
          RDSL   T1          TRY TO SET THE LOCK
          LDDL   T4
          LPK    /PIT/K.LOCKF
          NJK    PPRQX       IF SOMEONE ELSE HAS THE LOCK
          LDDL   T4          CLEAR THE ACTIVE CHECK FLAG
          LPC    -/PIT/K.ACTIVE-/PIT/K.LOCKF
          STDL   T4
          LOADC  CM.PIT
          ERRNZ  /PIT/C.LOCKF
          CWDL   T1
          UJK    PPRQ5

 PPRQ6    BSS                PROCESS IDLE OR RESUME REQUEST
          LOADOVL PPREQO
          LJM    PPR1

 LDCMBX   LJM    **
 LDCMB    EQU    *-1
          LOADOVL RECSO
          LJM    LDCMB1

 ACNX     LJM    **
 ACN      EQU    *-1
          ACN    DC          ACTIVATE THE CHANNEL
          UJK    ACNX

 DCN2X    LJM    **
 DCN2     EQU    *-1
          DCN    40B+DC      DISCONNECT THE CHANNEL
          UJK    DCN2X

 IAX      LJM    **
 IAMBF    EQU    *-1
          ACN    DC
          IFNE   SMALL,1
          LDC    SECWDS      NUMBER OF WORDS IN SECTOR
          ELSE
          LDML   SECWDS,SZ   NUMBER OF WORDS IN SECTOR
          ENDIF
          IAM    BUFF,DC     READ A SECTOR OF DATA FROM DISK
          UJK    IAX

 OAX      LJM    **
 OAMBF    EQU    *-1
          OAM    BUFF,DC     WRITE A SECTOR OF DATA TO DISK
          UJK    OAX

 CFMX     LJM    **
 CFM      EQU    *-1
          CFM    CFMX,DC     CHECK AND CLEAR CHANNEL ERROR
          AOML   CFM         CHANNEL ERROR, EXIT * + 1
          UJK    CFMX

 OAMCTX   LJM    **
 OAMCT    EQU    *-1
          OAM    CTBUF,DC    SEND DATA TO CONTROLLER
          UJK    OAMCTX

 OAMP1X   LJM    **
 OAMP1    EQU    *-1
          OAM    P1,DC       SEND DELAY PARAMETER
          UJK    OAMP1X

 EJMX     LJM    **
 EJM      EQU    *-1
          EJM    EJMX,DC     IF CHANNEL IS EMPTY
          AOML   EJM
          UJK    EJMX


          EJECT
 MAINA    BSS
          LOADOVL PPREQO
          RJM    ICOM        INITIALIZE UNIT TABLES

 MAINB    BSS
          SODL   CHLCNT
          NJN    MAINC       IF PP DOESN'T HAVE TO GIVE UP CHANNEL
          RJM    CKCHAN      CHECK IF CHANNEL MUST BE GIVEN UP

 MAINC    BSS
          IFEQ   PAT,1
          RJM    PATCH       PATCH THE PP
          ENDIF
 Q13      IFEQ   ERRTST,1
          RJM    TEST        CHECK FOR FUNCTION TIMEOUT TEST
 Q13      ENDIF
          RJM    PPREQ       CHECK FOR ANY PP REQUESTS


 MAIND    BSS
          LDDL   UNUML
          ZJK    MAINB       IF NO UNITS
          LDDL   IDLE
          NJK    MAINB       IF SOFTWARE IDLED

          LDDL   IALF
          SBN    6
          ZJN    MAIN12      IF EVERYTHING INITIALIZED

          LDDL   IALF
          LPN    2
          NJN    MAIN5       IF INITIAL RESET HAS BEEN ISSUED ON ALL CONTROLLERS
          LOADOVL RECSO
          RJM    LOAD        LOAD ADAPTER AND ALL CONTROL MODULES

 MAIN5    BSS
          LDDL   IALF
          LPN    4
          NJN    MAIN12      IF CONFIDENCE TEST HAS BEEN RUN ON ALL UNITS
          LDML   OVAD1
          SBN    CONFOO
          ZJN    MAIN11      IF OVERLAY IS ALREADY LOADED
          LOADOVL CONFO
 MAIN11   BSS
          RJM    CTEST       RUN CONFIDENCE TEST ON ALL UNITS

 MAIN12   BSS
          RJM    SELSEK      SELECT UNIT REQUESTS, SEEK,
                             AND PROCESS ADAPTER COMMANDS
          UJK    MAINB
          EJECT

* UNIT COMMANDS

 UCMD     BSS
          CON    C.READ
          CON    C.WRITE

* PP COMMANDS.

          IFEQ   T1,0
          CON    C.OFFUN
          CON    C.ONUN
          ENDIF
 UCMDL    EQU    *-UCMD

* UNIT COMMAND PROCESSORS
 UCMDPR   BSS
          CON    READ        READ BYTES
          CON    WRITE       WRITE BYTES

* PP COMMAND PROCESSORS.

          IFEQ   T1,0
          CON    STOP        SET UNIT DISABLE
          CON    ONUN        CLEAR UNIT DISABLE FLAG
          ENDIF
          EJECT
** NAME-- SELSEK
*
** PURPOSE-- LOOK FOR NEW UNIT REQUESTS AND ISSUE SEEKS.
*            PROCESS COMMANDS OR ERRORS FROM POLL STATUS.
          SPACE  6
 SELSX    LJM    **
 SELSEK   EQU    *-1
          LDDL   UNUML
          ZJK    SELSX       IF NO UNITS
 SELS5    BSS
          RJM    GETUD       LOOK FOR NEW REQUESTS AND ISSUE SEEKS
          LDDL   CMNDS       NUMBER OF OUTSTANDING COMMANDS
          ZJK    SELSX       IF NO OUTSTANDING COMMANDS
 SELS10   BSS
          RJM    POLS        GET POLL STATUS
          LDDL   PLSTAT
          SHN    17-11
          MJN    SELS11      IF STATUS
          LDDL   PLSTAT
          SBN    10B         CHECK IF CONTROL MODULE RESERVED
          NJK    SELSX       IF NO STATUS

* PROCESS COMMAND.

 SELS11   BSS
          RJM    PROC        PROCESS COMMAND OR ERROR
          UJK    SELS5

          EJECT
** NAME-- CMND
*
** PURPOSE-- SEND THE LOAD COMMAND BLOCK FUNCTION TO THE ADAPTER.
          SPACE  6
 CMNDX    LJM    **
 CMND     EQU    *-1
          LDN    2           CONTROL MODULE RESERVE RETRY COUNTER
          STML   CRSV2
 CMND10   BSS
          LDN    F.LOADCB
          RJM    FUNC        ISSUE LOAD COMMAND BLOCK
          ACN    DC
          LDN    5
          OAM    SS+/SS/P.UNIT,DC  SEND LOAD COMMAND BLOCK
          RJM    DCN         DISCONNECT CHANNEL
*         (NO RETURN IF ERROR).

          LDML   SS+/SS/P.PRIOV  CLEAR PRIORITY OVERRIDE BIT
          LPC    -/SS/K.PRIOV
          STML   SS+/SS/P.PRIOV
          RJM    POLSTAT     GET POLL STATUS
          LDDL   PLSTAT      POLL STATUS
          NJK    CMND70      IF ERROR
          LDML   SS+/SS/P.FUNC  LOAD COMMAND BLOCK FUNCTION
          SBN    R.PUP
          ZJN    CMND20      IF POWER UP SPINDLE
          SBN    R.LDCM-R.PUP
          ZJN    CMND30      IF LOAD CONTROL MODULE
          SBN    R.DIAGS-R.LDCM
          ZJN    CMND30      IF DIAGNOSTIC SUBTEST 5
          ADN    R.DIAGS-R.DIAG
          NJN    CMND40      IF NOT LEVEL II DIAGNOSTICS

* LEVEL II DIAGNOSTICS, POWER UP SPINDLE

 CMND20   BSS
          LDML   SC185       SET TIMEOUT OF 185 SECONDS
          STML   LDTIM,CMOD
          LDN    0
          STML   LDTIM+1,CMOD
          UJN    CMND60

* LOAD CONTROL MODULE, DIAGNOSTIC SUBTEST 5.
* (DIAGNOSTIC SUBTEST 5 SHOULD TAKE LESS THAN 4 SECONDS.
* A 60 SECOND TIMEOUT IS IMPLEMENTED DUE TO LACK OF SPACE IN THE PP.)

 CMND30   BSS
          LDML   SC60        SET TIMEOUT OF 60 SECONDS
          STML   UNITS+/UN/P.TMOT1,UX
          LDN    0
          STML   UNITS+/UN/P.TMOT2,UX
          UJN    CMND60

* READ, WRITE.

 CMND40   BSS
          LDN    1           SET TIMEOUT OF 2 SECONDS
          STML   UNITS+/UN/P.TMOT1,UX
          LDML   SC2
          STML   UNITS+/UN/P.TMOT2,UX
 CMND60   BSS
          AODL   CMNDS       INCREMENT COUNT OF OUTSTANDING ADAPTER COMMANDS
          UJK    CMNDX

* POLL STATUS IS NONZERO.
* EITHER CONTROL MODULE IS RESERVED OR ERROR.

 CMND70   BSS
          SBN    10B
          NJN    CMND80      IF ERROR


* CONTROL MODULE IS RESERVED.
* SET PRIORITY OVERRIDE TO CLEAR RESERVE ON OTHER CM ACCESS.

          SOML   CRSV2       DECREMENT CONTROL MODULE RESERVE RETRY COUNTER
          ZJN    CMND90      IF UNRECOVERED CONTROL MODULE RESERVE
          LDK    /RS/K.CRS   SET CONTROLLER RESERVED FLAG IN RESPONSE
          RJM    SERRID      ERROR ID
          LDML   SS+/SS/P.PRIOV  SET PRIORITY OVERRIDE TO CLEAR RESERVE
                             ON OTHER CM ACCESS
          LPC    -/SS/K.PRIOV
          ADC    /SS/K.PRIOV
          STML   SS+/SS/P.PRIOV
          UJK    CMND10

 CMND80   BSS
          RJM    ADPTERR     RECOVER ERROR
*         (NO RETURN FROM ADPTERR)

 CMND90   BSS
          RJM    RECS        RECOVER ERROR
*         (NO RETURN FROM RECS)

 CRSV2    BSSZ   1           TIMEOUT COUNTER FOR CONTROLLER RESERVE
          EJECT
** NAME-- PROC
*
** PURPOSE-- PROCESS A COMMAND OR AN ERROR FROM POLL STATUS.
          SPACE  6
 PROCX    LJM    **
 PROC     EQU    *-1
          LDDL   PLSTAT
          SHN    17-11
          PJN    PROC15      IF ERROR
          SHN    11-9
          PJN    PROC20

* ADAPTER ERROR.

 PROC15   BSS
          RJM    ADPTERR     TRY TO RECOVER
*         (NO RETURN FROM ADPTERR)

 PROC20   BSS
          RJM    GETUX       CHANGE UX INDEX TO MATCH UNIT IN PLSTAT,
                             GET SS ENTRY
          LDDL   PLSTAT      GET STATUS CODE
          SHN    -12
          STDL   P1
          SBN    7
          MJN    PROC50
          LDN    7           SUBSYSTEM ERROR
          STDL   P1
 PROC50   BSS
          LDML   SS+/SS/P.CONF
          SHN    /SS/L.CONF+2
          MJN    PROC70      IF RUNNING THE CONFIDENCE TEST
          LDML   OVAD1
          SBN    READOO
          ZJN    PROC55      IF OVERLAY IS ALREADY LOADED
          LOADOVL READO

 PROC55   BSS
          LDML   CMDPR,P1    GET COMMAND PROCESSOR
          STML   PROC60
          RJM    **          PROCESS COMMAND
 PROC60   EQU    *-1
 PROC65   BSS
          UJK    PROCX


 PROC70   BSS
          LOADOVL CONFO
          LDML   CTPR,P1     GET COMMAND PROCESSOR
          STML   PROC80
          RJM    **          PROCESS COMMAND
 PROC80   EQU    *-1
          UJK    PROC65
          SPACE  10
 CMDPR    BSS
          CON    TERMC       COMMAND COMPLETED WITHOUT ERROR
          CON    READ        READ DATA AVAILABLE
          CON    WRITE       WRITE BUFFER SPACE AVAILABLE
          CON    LDCMB       FIRST PART OF LOAD CONTROL MODULE COMPLETED
          CON    NOTRDY      DRIVE NOT READY
          CON    ADPTERR     ADAPTER ERROR
          CON    READ        MEDIA ERROR
          CON    RECS        RECOVER ERROR

 CTPR     BSS
          CON    CTERM       COMMAND COMPLETED WITHOUT ERROR
          CON    CREAD       READ DATA AVAILABLE
          CON    CWRITE      WRITE BUFFER SPACE AVAILABLE
          CON    LDCMB       FIRST PART OF LOAD CONTROL MODULE COMPLETED
          CON    NOTRDY      DRIVE NOT READY
          CON    ADPTERR     ADAPTER ERROR
          CON    CREAD       MEDIA ERROR
          CON    RECS        RECOVER ERROR
          EJECT
** NAME-- DCN
*
** PURPOSE-- DISCONNECT CHANNEL AFTER SENDING DATA.
          SPACE  6
 DCNX     LJM    **
 DCN      EQU    *-1
          ZJN    DCN10       IF TRANSFER WAS COMPLETE
          STML   RS+/RS/P.FUNTO  NUMBER OF CHANNEL WORDS NOT TRANSFERRED
          LDK    /RS/K.IST   INCOMPLETE SECTOR TRANSFER
          UJN    DCN40

 DCN10    BSS
          CFM    DCN20,DC    CHECK AND CLEAR CHANNEL ERROR
          RJM    CHERO       RECORD CHANNEL ERROR
*         (NO RETURN FROM CHERO.)

 DCN20    BSS
          LDC    250         SET TIMEOUT FOR 1 MILLISECOND ON S1
          STDL   T1
 DCN30    BSS
          EJM    DCN50,DC    IF CHANNEL IS EMPTY
          SODL   T1
          NJN    DCN30
          LDK    /RS/K.CEMPT  CHANNEL DOESNT GO EMPTY
 DCN40    BSS
          RJM    SERRID      SAVE ERROR FLAG
          RJM    ADPTERR     RECOVER ERROR
*         (NO RETURN FROM ADPTERR.)

 DCN50    BSS
          DCN    40B+DC
          UJK    DCNX
          EJECT
** NAME-- UREQ
*
** PURPOSE-- READ A UNIT REQUEST FROM CM.
*
** OUTPUT-- RQ  CONTAINS CURRENT REQUEST.
*           FRST = 0
*           NUMCM = NUMBER OF COMMANDS.
*           DEVICE = DEVICE TYPE.
*
          SPACE  6
 UREQX    LJM    **
 UREQ     EQU    *-1
          LDN    0
          STML   SS+/SS/P.FRST  SET FLAG WHEN REQUEST IS READ
          LDN    3           NUMBER OF WORDS TO READ
          STDL   WC
          LDC    SS+/SS/P.REQ2  REFORMAT RMA ADDRESS
          STDL   T2
          LOADF  SS+/SS/P.REQ  LOAD CM ADDRESS AND REFORMAT
          STML   2,T2
          ADN    2
          CRML   RQ+2*4,WC   READ CURRENT REQUEST
                             READ SWITCH FLAG BEFORE READING LINKAGE FLAGS
          SBN    5
          CRML   RQ,WC
          LDDL   CMADR       SAVE REFORMATED RMA ADDRESS
          STIL   T2
          LDDL   CMADR+1
          STML   1,T2

          LDML   RQ+/RQ/P.LEN  DETERMINE NUMBER OF COMMANDS
          SHN    -3
          SBN    /RQ/C.CMND
          STML   SS+/SS/P.NUMCM  NUMBER OF COMMANDS
          LDN    /RQ/C.CMND
          STML   SS+/SS/P.LASTC  OFFSET OF COMMAND
          LDML   RQ+/RQ/P.MAUS  GET SECTOR COUNT
          LPK    /RQ/M.MAUS
          STML   SS+/SS/P.MAUS
          UJK    UREQX
          EJECT
** NAME-- SRESP
*
** PURPOSE-- SET UP STATUS RESPONSE BUFFER.
          SPACE  6
 SREX     LJM    **
 SRESP    EQU    *-1
          LDML   SS+/SS/P.PVA  PUT PVA OF REQUEST IN RESPONSE BUFFER
          STML   RS+/RS/P.PVA
          LDML   SS+/SS/P.PVA+1
          STML   RS+/RS/P.PVA+1
          LDML   SS+/SS/P.PVA+2
          STML   RS+/RS/P.PVA+2
*
          LDN    0
          STML   RS+/RS/P.XFER  TRANSFER COUNT
          STML   RS+/RS/P.XFER+1
          UJK    SREX
          EJECT
** NAME-- FAILAD
*
** PURPOSE-- SET FAILING DISK ADDRESS IN RESPONSE.
          SPACE  6
 FAILX    LJM    **
 FAILAD   EQU    *-1
          LDML   SS+/SS/P.CURTRK  FAILING TRACK ADDRESS
          STML   RS+/RS/P.FTRK
          LDML   SS+/SS/P.CURSEC  FAILING SECTOR
          STML   RS+/RS/P.FSEC
          LDK    C.RS*8
          STML   RS+/RS/P.RESPL  RESPONSE LENGTH
          UJK    FAILX
          EJECT
** NAME-- UNCMND
*
** PURPOSE-- GET NEXT COMMAND.
*
** INPUT-- NUMCM, FRST, RS+/RS/P.LASTC
*
** OUTPUT-- CMLIST, FNC, RQ+/RQ/P.CMND
*           LISTL.
*
** EXIT-- A REGISTER = 0, IF NO MORE COMMANDS.
*         A REGISTER .NE. 0, IF NEXT COMMAND PRESENT.
          SPACE  6
 UNCX     LJM    **
 UNCMND   EQU    *-1
          LDML   SS+/SS/P.NUMCM
          ZJN    UNCX        IF NO MORE COMMANDS, EXIT, A REGISTER = 0
          SOML   SS+/SS/P.NUMCM  DECREMENT COMMAND COUNT
          LDML   SS+/SS/P.FRST  HAS FIRST COMMAND BEEN PROCESSED
          ZJN    UNC10       IF FIRST COMMAND HASN'T BEEN PROCESSED

*         READ NEXT COMMAND FROM CM.

          AOML   SS+/SS/P.LASTC  INCREMENT OFFSET OF LAST COMMAND
          LDN    C.CM
          STDL   WC
          LOADS  SS+/SS/P.REQ2  LOAD CM ADDRESS
          ADML   SS+/SS/P.LASTC  ADD OFFSET OF COMMAND
          CRML   CM,WC       READ COMMAND FROM CM

*         IF INDIRECT ADDRESS, READ CM ADDRESS LIST.

 UNC10    BSS
          LDML   CM+/CM/P.LEN  MAKE SURE IT IS AN EVEN NUMBER OF CM WORDS
          ADN    7
          SCN    7
          STML   CM+/CM/P.LEN
          STML   CMLIST+/CM/P.LEN
          SHN    -3
          STML   SS+/SS/P.LISTL  LENGTH OF CM ADDRESS AREA  (CM WORDS)
          LDML   CM+/CM/P.INDIR
          SHN    /CM/L.INDIR+2
          MJN    UNC15       IF INDIRECT ADDRESS
          LDN    1
          STML   SS+/SS/P.LISTL  IF NOT INDIRECT, ONLY 1 COMMAND.
          LDML   CM+/CM/P.RMA
          STML   CMLIST+/CM/P.RMA
          LDML   CM+/CM/P.RMA+1
          STML   CMLIST+/CM/P.RMA+1
          UJN    UNC20

 UNC15    BSS
          RJM    GLIST       GET CM ADDRESS LIST OF DATA AREA

* IF SWITCH FLAG IS SET, EXIT.

 UNC20    BSS

*         SET UP INTERNAL FUNCTION CODE, FNC.

          LDN    0
          STDL   FNC         SET UP INTERNAL FUNCTION CODE
 UNC30    LDML   CM+/CM/P.CODE  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          ERRNZ  /CM/L.CODE
          SBML   UCMD,FNC    COMPARE COMMAND CODE
          ZJN    UNC40       IF COMMAND FOUND
          AODL   FNC
          SBN    UCMDL
          MJN    UNC30       IF MORE COMMANDS TO CHECK
 UNC35    BSS
          LDC    E501        ERROR IN COMMAND CODE
          RJM    ATERM       ABNORMAL TERMINATION (NO RETURN)
*         (NO RETURN FROM ATERM)

 UNC40    BSS
          LDML   SS+/SS/P.FRST
          ZJN    UNC60       IF FRST COMMAND
          LDDL   FNC
          SBML   SS+/SS/P.FNC  FUNCTION CODE
          ZJN    UNC70       IF SAME AS LAST COMMAND
          UJK    UNC35       IF NOT SAME AS LAST COMMAND, ERROR

 UNC60    BSS
          LDDL   FNC
          STML   SS+/SS/P.FNC  SAVE COMMAND CODE
 UNC70    BSS
          AOML   SS+/SS/P.FRST  SET FIRST COMMAND FLAG NONZERO
          UJK    UNCX        EXIT A REGISTER NONZERO
          EJECT
** NAME-- GLIST
*
** PURPOSE-- READ THE CM ADDRESS LIST PORTION OF A COMMAND.
*
** INPUT-- LISTL
*
** OUTPUT-- CMLIST, CM+/CM/P.RMA
          SPACE  6
 GLIX     LJM    **
 GLIST    EQU    *-1
          LDML   SS+/SS/P.LISTL  NO OF CM WORDS IN ADDRESS-LENGTH-PAIR LIST
          ZJN    GLIX        IF NO WORDS TO READ
          LDN    1
          STDL   WC          NUMBER OF CM WORDS TO READ
          LOADF  CM+/CM/P.RMA  LOAD CM ADDRESS AND REFORMAT
          CRML   CMLIST,WC
          LDN    8
          RAML   CM+/CM/P.RMA+1  UPDATE RMA ADDRESS FOR NEXT READ
          SHN    -16
          RAML   CM+/CM/P.RMA
          LDML   CMLIST+/CM/P.LEN  MAKE SURE IT IS AN EVEN NUMBER OF CM WORDS
          ADN    7
          SCN    7
          STML   CMLIST+/CM/P.LEN
          UJK    GLIX
          EJECT
** NAME-- FUNC
*
** PURPOSE-- ISSUE FUNCTION TO DISK CONTROLLER.
*
** INPUT-- A REGISTER = FUNCTION CODE.
*
** OUTPUT-- CHANNEL IS INACTIVE.
          SPACE  6
 FUNX     LJM    **
 FUNC     EQU    *-1
          STDL   FUNCD       SAVE FUNCTION CODE
          STML   FBUF,FI     SAVE HISTORY OF FUNCTIONS ISSUED
          AJM    FUN30,DC    IF CHANNEL ACTIVE
          FAN    DC          ISSUE THE FUNCTION
          AODL   FI          INCREMENT FUNCTION BUFFER INDEX
          ADC    -FBUFL
          NJN    FUN4        IF NOT END OF BUFFER
          STDL   FI          INITIALIZE INDEX
 FUN4     BSS
          IJM    FUNX,DC     EXIT IF CHANNEL INACTIVE
          LDK    2           TIMEOUT 500 MILLISECONDS ON ALL FUNCTIONS
          STDL   T1
 FUN8     BSS
          LDC    377777B
 FUN10    IJM    FUNX,DC     EXIT IF CHANNEL INACTIVE

          SBN    1
          NJN    FUN10
          IJM    FUNX,DC     EXIT IF CHANNEL INACTIVE
          SODL   T1          DECREMENT TIMEOUT COUNTER
          NJN    FUN8

*
* DISK CHANNEL ERROR.
*

 FUN30    BSS
          LDML   IGNORE
          NJK    FUNX        IGNORE ERRORS
          LDK    /RS/K.FTO   SET FUNCTION TIMEOUT FLAG IN RESPONSE
          RJM    SERR        ERROR ID
          LDML   RS+/RS/P.FUNTO
          NJN    FUN45       IF FUNCTION CODE ALREADY IN RESPONSE BUFFER
          LDDL   FUNCD       PUT FUNCTION CODE IN RESPONSE BUFFER
          STML   RS+/RS/P.FUNTO
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
 FUN45    BSS
          RJM    ADPTERR     PROCESS FUNCTION TIMEOUT ERROR
*         (NO RETURN FROM ADPTERR.)
          EJECT
** NAME-- POLSTAT
*
** PURPOSE-- READ POLL STATUS FROM CONTROLLER.
*
** OUTPUT-- PLSTAT = POLL STATUS.
*
          SPACE  6
 POLSX    LJM    **
 POLSTAT  EQU    *-1
          LDN    F.POLL      POLL STATUS FUNCTION CODE
          RJM    FUNC        ISSUE FUNCTION CODE
          ACN    DC
          LDN    1
          IAM    PLSTAT,DC   INPUT POLL STATUS
          NJK    POLS90      IF INPUT DID NOT COMPLETE
          LDDL   PLSTAT
          STML   SBUF,SI     SAVE HISTORY OF STATUS
          AODL   SI          INCREMENT STATUS BUFFER INDEX
          ADC    -SBUFL
          NJN    POLS4       IF NOT END OF BUFFER
          STDL   SI          INITIALIZE STATUS BUFFER INDEX
 POLS4    BSS
          RJM    INC         CHECK IF CHANNEL IS INACTIVE
*         (NO RETURN IF ERROR).

          LDDL   PLSTAT      SAVE POLL STATUS
          ZJN    POLS40      IF NO ERRORS
          SHN    17-11
          PJN    POLS52      CHECK FOR CONTROL MODULE RESERVED
          SHN    11-9
          MJN    POLS60      IF REPORTED ERROR
          LDDL   PLSTAT
          SHN    -12
          SBN    4
          PJN    POLS55      IF REPORTED ERROR

 POLS40   BSS

**
*   THE FOLLOWING CODE WAS DISABLED TO PREVENT SENDING
*   SOMETIMES AMBIGUOUS GENERAL STATUS TO THE RESPONSE
*   BUFFER. THIS OCCURRED WHEN ATTEMPTING TO CAPTURE
*   INITIAL AND FINAL STATUS.

*         LDDL   DTSTAT      CHECK IF CALLED FROM ADPTERR
*         NJN    POLS60      IF IN ERROR RECOVERY, READ DETAILED STATUS

 POLS50   BSS
          UJK    POLSX

 POLS52   BSS
          LDDL   PLSTAT
          SBN    10B
          ZJK    POLS40      IF CONTROL MODULE RESERVED
          UJK    POLS50      NO STATUS AVAILABLE

* CHECK IF A DIFFERENT SS ENTRY SHOULD BE READ.

 POLS55   BSS
          LDDL   CHGUN
          ZJN    POLS60      IF SS ENTRY SHOULD NOT BE CHANGED
          RJM    GETUX       CHANGE UX TO MATCH UNIT IN POLL STATUS,
                             GET SS ENTRY

* CHECK STATUS.

 POLS60   BSS
          LDN    0
          STDL   DTSTAT      ZERO OUT GET STATUS FLAG
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE

* READ EXTENDED DETAILED STATUS.

          LDML   RS+/RS/P.DET  CHECK IF FIRST TIME FOR DETAILED STATUS
          LPK    /RS/K.CSP
          NJN    POLS80      IF NOT THE FIRST TIME FOR THIS ERROR
          LDK    /RS/K.CSP
          RAML   RS+/RS/P.DET  SET FLAG FOR DETAILED STATUS PRESENT
          LDDL   PLSTAT      PUT POLL STATUS IN RESPONSE BUFFER
          STML   RS+/RS/P.GENST1
          LDN    F.EDS       READ EXTENDED DETAILED STATUS
          RJM    FUNC
          LDN    20
          ACN    DC
          IAM    RS+/RS/P.DETAIL,DC  READ EXTENDED DETAILED STATUS
          NJN    POLS90      INPUT DID NOT COMPLETE
          RJM    INC         CHECK IF CHANNEL IS INACTIVE
*         (NO RETURN IF ERROR).


* IN CASE THIS IS THE LAST TIME THE ERROR IS ENCOUNTERED BEFORE
* IT IS RECOVERED, READ DETAILED STATUS.

 POLS80   BSS
          LDDL   PLSTAT      PUT LAST POLL STATUS IN RESPONSE BUFFER
          STML   RS+/RS/P.GENST2
          LDN    F.EDS       READ EXTENDED DETAILED STATUS
          RJM    FUNC
          LDN    20
          ACN    DC
          IAM    RS+/RS/P.DET2,DC  READ LAST EXTENDED DETAILED STATUS
          NJN    POLS90      IF INPUT DID NOT COMPLETE
          RJM    INC         CHECK IF CHANNEL IS INACTIVE
*         (NO RETURN IF ERROR).

          UJK    POLS50

 POLS90   BSS
          STML   RS+/RS/P.FUNTO  NUMBER OF PP WORDS NOT RECEIVED
          LDK    /RS/K.IST   INCOMPLETE SECTOR TRANSFER
 POLS95   BSS
          RJM    SERRID      SAVE ERROR ID
          RJM    ADPTERR     ABNORMAL TERMINATION, RECOVERED SUBSYSTEM
*         (NO RETURN FROM ADPTERR)
          EJECT
** NAME-- INC
*
** PURPOSE-- CHECK FOR CHANNEL ERRORS AFTER INPUTING DATA.
          SPACE  6
 INCX     LJM    **
 INC      EQU    *-1
          LDC    250         SET TIMEOUT FOR 1 MILLISECOND ON S1
          STDL   T3
 INC10    BSS
          IJM    INC20,DC    IF CHANNEL INACTIVE
          SODL   T3
          NJN    INC10
          LDK    /RS/K.CINAC  CHANNEL NOT INACTIVE
          UJK    POLS95      SAVE ERROR ID
*                            RECOVER ERROR.  CHANNEL ACTIVE TIMEOUT
*         (NO RETURN FROM ADPTERR)

 INC20    BSS
          CFM    INCX,DC     CHECK AND CLEAR CHANNEL ERROR
          RJM    CHNERR      RECORD CHANNEL ERROR
*         (NO RETURN FROM CHNERR)
          EJECT
** NAME-- POLS
*
** PURPOSE-- READ POLL STATUS AND CHANGE SS ENTRY IF THERE
*            IS AN ERROR.
          SPACE  6
 POLX     LJM    **
 POLS     EQU    *-1
          AODL   CHGUN       SET FLAG SO SS ENTRY WILL BE CHANGED
          RJM    POLSTAT     GET POLL STATUS
          LDN    0
          STDL   CHGUN
          UJK    POLX
          EJECT
** NAME-- TERMC.
*
** PURPOSE-- TERMINATE UNIT REQUEST.
*
** OUTPUT-- RS+/RS/P.RC = RESPONSE CODE.
          SPACE  6
 TERMC    CON    0           NORMAL TERMINATION
          SODL   CMNDS       DECREMENT COUNT OF OUTSTANDING ADAPTER COMMANDS

          LDML   CMLOAD,CMOD  CONTROL MODULE LOADING TABLE
          ADML   SS+/SS/P.NR  CHECK IF NOT READY ERROR PROCESSING
          ADML   SS+/SS/P.DIAG  CHECK IF RUNNING DIAGNOSTICS
          ADML   SS+/SS/P.DIAGS  CHECK IF RUNNING DIAGNOSTICS
          NJN    TERM40      CALL OVERLAY TO PROCESS

* NORMAL WRITE TERMINATION.

          LDML   SS+/SS/P.TOTAL  MAKE SURE ALL SECTORS WERE TRANSFERRED
          ADML   SS+/SS/P.LISTL
          ADML   SS+/SS/P.NUMCM
          ZJN    TERM        IF TERMINATION IS OK
          RJM    TERMA       PROBABLY ADAPTER ERROR
*         (NO RETURN FROM TERMA.)






* LOAD OVERLAY FOR SPECIAL PROCESSING

 TERM40   BSS
          LOADOVL RECSO
          LJM    TERMER1



 TERM     BSS
          RJM    PUTRC       PUT RESPONSE CODES IN RESPONSE
          RJM    SNDWRS      SEND WRITE RESPONSES
          RJM    RESP        SEND RESPONSE TO CPU
          LDDL   NODEL
          NJN    TERM50      IF NO DELINK OF REQUEST
          RJM    DELRQ       DELETE COMPLETED REQUEST FROM QUEUE
                             AND SELECT NEW REQUEST.
 TERM50   BSS
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
          RJM    CFLGS       CLEAR FLAGS
          RJM    CLRLOCK     CLEAR LOCK ON UNIT
          UJK    MAINB
          EJECT

* ADAPTER INTERFACE ERROR.

 TERMA    CON    0
          LDK    /RS/K.ADPT  ADAPTER CONTROLWARE ERROR
          RJM    SERRID      ERROR ID
          RJM    ADPTERR     RECOVER ERROR
*         (NO RETURN FROM ADPTERR.)
          EJECT
** NAME-- CFLGS
*
** PURPOSE-- CLEAR FLAGS WHEN TERMINATING A REQUEST OR
*            PROCESSING AN IDLE COMMAND.
          SPACE  6
 CFLGX    LJM    **
 CFLGS    EQU    *-1
          LDML   UNITS+/UN/P.CM,UX
          SHN    -3
          STDL   CMOD        CONTROL MODULE NUMBER
          LDN    0
          STDL   DTSTAT      CLEAR STATUS READING FLAG
          STML   CMLOAD,CMOD  CLEAR CONTROL MODULE LOADING ENTRY
          STML   SS+/SS/P.RECOV  ZERO OUT ERROR RECOVERY INDEX
          STML   SS+/SS/P.PRELD  PRELOAD OF CONTROL MODULE
          STML   SS+/SS/P.ADERR  CLEAR ADAPTER ERROR FLAG
          STML   SS+/SS/P.CMLD  CONTROL MODULE LOAD RETRY COUNTER
          STML   SS+/SS/P.LAD  ADAPTER LOAD RETRY COUNTER
          STML   SS+/SS/P.DIAG  LEVEL II DIAGNOSTIC FLAG
          STML   SS+/SS/P.DIAGS  DIAGNOSTIC SUBTEST FLAG
          STML   SS+/SS/P.NR  NOT READY RETRY COUNTER
          STML   SS+/SS/P.NCOMW  ZERO OUT NUMBER OF COMPLETED WRITE REQUESTS
          STML   SS+/SS/P.RVCNT  ZERO OUT RECOVERED ERRORS COUNTER
          STML   SS+/SS/P.RQTRY  ZERO OUT REQUEST RETRY COUNTER
          LDML   SS+/SS/P.CONF  CLEAR CONFIDENCE TEST FLAG
          LPC    -/SS/K.CONF
          STML   SS+/SS/P.CONF
          LDML   UNITS+/UN/P.BUSY,UX  CLEAR BUSY FLAG
          LPC    -/UN/K.BUSY
          STML   UNITS+/UN/P.BUSY,UX
          RJM    ZRESP       ZERO OUT RESPONSE BUFFER
          UJK    CFLGX
          EJECT
** NAME-- TERMP
*
** PURPOSE-- TERMINATE PP REQUEST.
*
** OUTPUT-- RS+/RS/P.RC = RESPONSE CODE
          SPACE  6
 TERX     LJM    **
 TERMP    EQU    *-1
          RJM    PUTRC       PUT RESPONSE CODES IN RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
*         LDN    0
*         STML   PPRQ        ZERO OUT PP REQUEST FLAG
          RJM    ZRESP       ZERO OUT RESPONSE BUFFER
          UJK    TERX
          EJECT
** NAME-- PUTRC
*
** PURPOSE-- PUT RESPONSE CODES IN RESPONSE
          SPACE  6
 PUTRCX   LJM    **
 PUTRC    EQU    *-1
          LDDL   RESPC       RESPONSE CODE
          SHN    /RS/L.RCON-/RS/L.RC+/RS/N.RCON-/RS/N.RC
          ADDL   RCON        RESPONSE CONDITION
          SHN    /RS/L.URC-/RS/L.RCON+/RS/N.URC-/RS/N.RCON
          ERRNZ  /RS/P.URC-/RS/P.RCON
          ERRNZ  /RS/P.RC-/RS/P.URC
          STML   RS+/RS/P.URC
          UJK    PUTRCX
          EJECT
** NAME-- RESP
*
** PURPOSE-- WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
*
** INPUT-- CM.PIT, CM.RS, LIM, /PIT/IN, /PIT/OUT, RS+/RS/P.RESPL
*
** OUTPUT-- /PIT/IN, RESPONSE BUFFER
          SPACE  6
 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  6
 RESPX    LJM    **
 RESP     EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDN    0
          STDL   STORS       SET FLAG TO STORE RESPONSE
          LDML   CM+/CM/P.STOR  CHECK IF CALLER WANTS RESPONSE
          SHN    /CM/L.STOR+2
          MJN    RESP10      IF STORE RESPONSE FLAG IS SET
          LDDL   RESPC       CHECK FOR NORMAL RESPONSE
          SBN    R.NRM
          NJN    RESP10      IF NOT NORMAL RESPONSE, STORE RESPONSE
          AODL   STORS       NONZERO MEANS DO NOT STORE RESPONSE
 RESP5    UJK    RESPX

* READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RESP10   BSS
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF 'IN' POINTER
          CRDL   P1          READ 'IN' POINTER

* CHECK IF A SHORT RESPONSE SHOULD BE SENT.

          LDML   RS+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          ZJK    RESP5       IF RESPONSE LENGTH = 0
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          SBN    1
          ZJN    RESP15      IF A SHORT RESPONSE
          LDN    0           CLEAR FLAG IF NOT SHORT RESPONSE
          UJN    RESP17

 RESP15   BSS
          LDML   RS+/RS/P.LU
          LPK    /RS/M.LUN
          ERRNZ  16-/RS/L.LUN-/RS/N.LUN
          ADK    /RS/K.SHORT  SET FLAG FOR SHORT RESPONSE
 RESP17   BSS
          STML   RS+/RS/P.SHORT

* CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDDL   INP
          SBDL   OUTP
          MJN    RESP20      IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP
 RESP20   LDML   RS+/RS/P.RESPL  GET RESPONSE LENGTH
          ADDL   INP
          STDL   INPNT       IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          MJN    RESP30      IF ENOUGH ROOM IN BUFFER
          LDN    1
          STML   RSP         SET PROCESSING RESPONSE FLAG
          RJM    PPREQ       CHECK IDLE AND ACTIVE FLAGS
          LDN    0
          STML   RSP
          UJK    RESP10

 RESP30   BSS
          LDN    0
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE
          LDDL   INP
          SHN    -3
          STDL   T3          'IN' POINTER IN WORDS
          LDDL   INPNT
          SBDL   LIM
          MJN    RESP50      IF IN + RESPONSE LENGTH .LT. LIMIT
                             ONLY 1 BLOCK WRITE
          STDL   INPNT       IN + RESPONSE LENGTH - LIMIT = NEW 'IN' POINTER
          SHN    -3
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE

* WRITE RESPONSE TO CM.

          LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADC    RS
          STML   RESP60      RESPONSE ADDRESS FOR 2ND BLOCK WRITE
 RESP50   BSS
          LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD 'IN' OFFSET
          CWML   RS,T4       WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          ZJN    RESP70      IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          LMC    400000B
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
                             (BEGINNING OF RESPONSE BUFFER)
 RESP60   EQU    *-1

 RESP70   BSS
          LJM    RESPX
          EJECT
** NAME-- RESPIN
*
** PURPOSE-- UPDATE THE 'IN' POINTER IN THE CM RESPONSE BUFFER.
*
** INPUT-- INPNT = NEW 'IN' POINTER.
          SPACE  6
 RESNX    LJM    **
 RESPIN   EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDDL   STORS       CHECK IF CALLER WANTS RESPONSE
          NJK    RESNX       IF NO RESPONSE WAS SENT

* UPDATE THE 'IN' POINTER.

          LDN    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDDL   INPNT       NEW 'IN' POINTER
          STDL   P4
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   P1          WRITE NEW 'IN' POINTER TO CM

* INTERRUPT PROCESSOR. RESP ROUTINE SETS UP THIS INSTRUCTION.

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   PPNO-3      SET LAST BYTE NONZERO
 INTPRC   INPN   1           INTERRUPT OR PSN
          CRDL   T1          THIS INSTRUCTION IS BECAUSE OF AN 810/830 PROBLEM
          UJK    RESNX
          EJECT
** NAME-- SNDRSP
*
** PURPOSE-- SEND THE RESPONSE TO CM.
*            USED WHEN SWITCHING TO THE NEXT REQUEST.
          SPACE  6
 SNDX     LJM    **
 SNDRSP   EQU    *-1
          RJM    RESP        SEND RESPONSE TO CM
          RJM    RESPIN      UPDATE -IN- POINTER IN RESPONSE BUFFER
          RJM    SRESP       SET UP RESPONSE BUFFER
          AOML   SS+/SS/P.NCOMRQ  INCREMENT NUMBER OF COMPLETED REQUESTS
                             (FOR DELRQ)
          UJK    SNDX
          EJECT
** NAME-- RECRS
*
** PURPOSE-- IF AN ERROR HAS BEEN RECOVERED, SEND AN INTERMEDIATE
*            RESPONSE TO CM.
          SPACE  6
 RECRSX   LJM    **
 RECRS    EQU    *-1
          LDML   RS+/RS/P.RESPL  RESPONSE LENGTH
          ADC    -C.RS*8
          NJN    RECRSX      IF NO ERRORS

          LOADOVL RECSO
          LJM    RECRS1
          EJECT
** NAME-- CHNERR
*
** PURPOSE-- RECORD INPUT CHANNEL ERROR.
          SPACE  6
 CHNERR   CON    0
          LDK    /RS/K.CHERR  INPUT CHANNEL ERROR
          RJM    CHER        RECORD CHANNEL ERROR
*         (NO RETURN FROM CHER.)
          EJECT
** NAME-- CHERO
*
** PURPOSE-- RECORD OUTPUT CHANNEL ERROR.
          SPACE  6
 CHERO    CON    0
          LDK    /RS/K.CHERO  OUTPUT CHANNEL ERROR
          RJM    CHER        RECORD CHANNEL ERROR
*         (NO RETURN FROM CHER.)
          EJECT
** NAME-- CHER
          SPACE  6
 CHER     CON    0
          RJM    SERR        SAVE ERROR ID
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    ADPTERR     RECOVER THE ERROR
*         (NO RETURN FROM ADPTERR.)
          EJECT
 SERRX    LJM    **
 SERR     EQU    *-1         SAVE ERROR ID
          STDL   T1
          LMC    -0
          STDL   T2
          LDML   RS+/RS/P.CHERR  ERROR ID
          LPDL   T2
          ADDL   T1          ADD ERROR FLAG
          STML   RS+/RS/P.CHERR
          UJK    SERRX
          EJECT
 SERRIX   LJM    **
 SERRID   EQU    *-1         SAVE ERROR ID
          STDL   T1
          LMC    -0
          STDL   T2
          LDML   RS+/RS/P.ERRID  ERROR ID
          LPDL   T2
          ADDL   T1          ADD ERROR FLAG
          STML   RS+/RS/P.ERRID
          UJK    SERRIX
          EJECT
 SIDX     LJM    **
 SID      EQU    *-1         SAVE ERROR ID
          STDL   T1
          LMC    -0
          STDL   T2
          LDML   RS+/RS/P.ID  ERROR ID
          LPDL   T2
          ADDL   T1          ADD ERROR FLAG
          STML   RS+/RS/P.ID
          UJK    SIDX
          EJECT
** NAME-- GETUX
*
** PURPOSE-- CHANGE UX INDEX TO MATCH UNIT IN PLSTAT.
*             READ SS ENTRY.
          SPACE  6
 GETUXX   LJM    **
 GETUX    EQU    *-1
          LDDL   UNUML
          ZJK    GETUXX      IF NO UNITS
          LDDL   PLSTAT
          LPN    77B
          SHN    -3
          STDL   CMOD        CONTROL MODULE NUMBER
          LDML   CMLOAD,CMOD
          ZJN    GETUX30     IF THIS CONTROL MODULE IS NOT BEING LOADED
          LPN    77B
          STDL   UX          UNITS TABLE INDEX
 GETUX20  BSS
          RJM    GETSS       GET SS ENTRY
          UJK    GETUXX

 GETUX30  BSS
          LDN    0
          STDL   UX
 GETUX40  BSS
          LDDL   PLSTAT
          LPN    77B         UNIT NUMBER IN POLL STATUS
          SBML   UNITS+/UN/P.UNIT,UX  COMPARE WITH UNIT NUMBER IN TABLE
          ZJN    GETUX20     IF THE UNIT ENTRY IS FOUND
          LDN    P.UN
          RADL   UX          BUMP TO NEXT ENTRY
          SBDL   UNUML
          MJN    GETUX40     IF NOT END OF TABLE
          RJM    TERMA       INVALID POLL STATUS
*         (NO RETURN FROM TERMA.)
          EJECT
** NAME-- GETSS
*
** PURPOSE-- READ SS ENTRY FROM UNIT COMMUNICATION BUFFER IN
*            CM UNIT INTERFACE TABLE.
*
          SPACE  6
 GETSSX   LJM    **
 GETSS    EQU    *-1

* CHECK IF SS TABLES NEEDS TO BE SAVED.

          LDDL   UX
          STML   SAVUX       SAVE UX
          SBDL   SSUN        UX OF CURRENT SS TABLE
          ZJN    GETSSX      IF SS TABLE ALREADY IN MEMORY
          LDDL   SSUN
          STDL   UX
          RJM    SAVSS       SAVE SS TABLE BEFORE READING ANOTHER SS TABLE
          LDML   SAVUX       RESTORE UX
          STDL   UX
          STDL   SSUN        SAVE UX OF NEW SS TABLE

* READ NEW SS TABLE.

          LDN    C.SS        NUMBER OF WORDS TO READ
          STDL   WC
          LOADR  UNITS+/UN/P.CB,UX  ADDRESS OF COMMUNICATION BUFFER
          CRML   SS,WC       READ SS ENTRY
          UJK    GETSSX
          EJECT
** NAME-- SAVSS
*
** PURPOSE-- WRITE THE SS ENTRY TO THE COMMUNICATION BUFFER
*            IN THE UNIT INTERFACE TABLE.
*
          SPACE  6
 SAVX     LJM    **
 SAVSS    EQU    *-1
          LDDL   UX
          SBDL   UNUML
          PJK    SAVX        IF INVALID SS TABLE

* WRITE SS ENTRY TO COMMUNICATION BUFFER IN UNIT INTERFACE TABLE.

          LDN    C.SS        NUMBER OF WORDS TO WRITE
          STDL   WC
          LOADR  UNITS+/UN/P.CB,UX  ADDRESS OF COMMUNICATION BUFFER
          CWML   SS,WC       WRITE SS ENTRY
          UJK    SAVX
          EJECT
** NAME-- ZRESP
*
** PURPOSE-- ZERO OUT PART OF THE RESPONSE BUFFER.
*
** NOTE-- THIS ROUTINE IS ALSO CALLED FOR RECOVERED ERROR RESPONSES.
          SPACE  6
 ZREX     LJM    **
 ZRESP    EQU    *-1
          LDN    0
          STDL   RCON        RESPONSE CONDITION
          STDL   NODEL       DON'T DELINK REQUEST FLAG
          STML   RS+/RS/P.HDWR  ABNORMAL STATUS
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE

          LDK    C.RS-/RS/C.FTRK
          STDL   WC
          LOADC  CM.CB       ADDRESS OF COMMUNICATION BUFFER
          ADK    /CB/C.ZERO
          CRML   RS+/RS/P.FTRK,WC  ZERO OUT PART OF RESPONSE BUFFER

          LDN    8           SET RESPONSE LENGTH FOR NORMAL RESPONSE
          STML   RS+/RS/P.RESPL
          LDN    R.NRM       SET RESPONSE CODE = NORMAL
          STDL   RESPC
          SHN    16-/RS/N.RC-/RS/L.RC
          STML   RS+/RS/P.RC  PUT REPONSE CODE IN RESPONSE
          UJK    ZREX
          EJECT
** NAME-- GETUD
*
** PURPOSE-- GET A UNIT REQUEST FROM CENTRAL.
*            ISSUE ALL SEEKS.
          SPACE  6
 GETUDX   LJM    **
 GETUD    EQU    *-1
          LDDL   UNUML
          ZJK    GETUDX      IF NO UNITS
          LDDL   LUX         UNIT INDEX OF LAST REQUEST FOUND + 1
          STDL   P6
 GETU10   BSS
          LDDL   LUX
          STDL   UX
          LDN    P.UN
          RADL   LUX         BUMP UNIT ENTRY
          SBDL   UNUML
          MJN    GETU20      IF NOT END OF TABLE
          STDL   LUX
 GETU20   BSS
          LDML   UNITS+/UN/P.CM,UX  GET CONTROL MODULE NUMBER
          SHN    -3
          STDL   CMOD        CONTROL MODULE NUMBER
          LDML   CMLOAD,CMOD  CHECK IF CONTROL MODULE IS BEING LOADED
          ZJN    GETU22      IF CONTROL MODULE IS NOT BEING LOADED

* UPDATE/CHECK COMMAND TIMEOUT VALUE FOR CM LOAD
          SOML   LDTIM+1,CMOD  DECREMENT LOAD TIMEOUT VALUE
                               LOWER BITS
          NJK    GETU30      IF LSB'S NOT TIMED OUT
          SOML   LDTIM,CMOD    DECREMENT LOAD TIMEOUT VALUE
                               UPPER BITS
          ZJK    GETU75      IF COMMAND TIMED OUT
          UJN    GETU30      GET NEXT ENTRY

 GETU22   LDML   UNITS+/UN/P.BUSY,UX  CHECK IF OUTSTANDING COMMAND
          SHN    /UN/L.BUSY+2
          PJN    GETU40      IF NO COMMAND IN PROGRESS

* UPDATE/CHECK COMMAND TIMEOUT VALUE

 GETU24   BSS
          SOML   UNITS+/UN/P.TMOT2,UX  DECREMENT TIMEOUT VALUE
                                       LOWER BITS
          NJK    GETU30      IF NOT TIMED OUT
          SOML   UNITS+/UN/P.TMOT1,UX  DECREMENT TIMEOUT VALUE
                                       UPPER BITS
          ZJK    GETU75      IF COMMAND TIMED OUT

* GO TO NEXT UNIT ENTRY.

 GETU30   BSS
          LDDL   LUX         HAVE ALL ENTRIES BEEN CHECKED
          SBDL   P6
          ZJK    GETUDX      IF NO MORE ENTRIES TO CHECK
          UJK    GETU10

* CHECK FOR ANY REQUESTS ON THIS UNIT QUEUE.

 GETU40   BSS
          LDML   PIDLE       CHECK PRE-IDLE FLAG
          NJN    GETU30      IF PRE-IDLE, DON'T ISSUE ANY NEW SEEKS
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ERRNZ  /UIT/C.DSABLE
          CRDL   T5          READ UNIT DISABLED FLAG
          ADN    /UIT/C.NEXT
          CRDL   T1          READ RMA OF NEXT REQUEST FROM UNIT QUEUE
          LDDL   T3
          ADDL   T4
          ZJK    GETU30      IF NO REQUESTS ON THIS QUEUE
          LDDL   T5+/UIT/P.DSABLE  CHECK IF UNIT IS DISABLED
          SHN    /UIT/L.DSABLE+2
          MJK    GETU30      IF UNIT IS DISABLED

* SET UNIT LOCK.

          RJM    SETLOCK     SET UNIT LOCKWORD
          NJK    GETU30      IF LOCK COULD NOT BE SET
          LDML   SS+/SS/P.CUR
          SHN    /SS/L.CUR+2
          MJN    GETU60      IF CURRENT REQUEST HAS BEEN SELECTED

* SELECT CURRENT REQUEST.

          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    GETU50      IF LOCK COULD NOT BE SET
          RJM    SELRQ       SELECT CURRENT REQUEST
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          LDML   SS+/SS/P.CUR  CHECK IF A REQUEST WAS FOUND
          SHN    /SS/L.CUR+2
          MJN    GETU60      IF A REQUEST WAS FOUND
 GETU50   BSS
          RJM    CLRLOCK     CLEAR UNIT LOCKWORD
 GETU55   UJK    GETU30

* ISSUE THE SEEK.

 GETU60   BSS
          RJM    SEEKI       ISSUE INITIAL SEEK
          LDML   UNITS+/UN/P.BUSY,UX  CHECK IF OUTSTANDING COMMAND
          SHN    /UN/L.BUSY+2
          PJN    GETU50      IF SEEK COMMAND FAILED
          UJK    GETU55
 GETU75   BSS
          RJM    GETSS       GET SS ENTRY
          LDK    /RS/K.PTO   PP TIMED OUT A COMMAND
          RJM    SID         ERROR ID
          RJM    ADPTERR     ADAPTER / CONTROL MODULE ERROR
                             RESTART ALL REQUESTS
*         (NO RETURN FROM ADPTERR.)

          EJECT
** NAME-- SEEKI
*
** PURPOSE-- ISSUE INITIAL SEEK.
          SPACE  6
 SEKIX    LJM    **
 SEEKI    EQU    *-1
          LDML   UNITS+/UN/P.BUSY,UX  CLEAR BUSY FLAG
          LPC    -/UN/K.BUSY
          STML   UNITS+/UN/P.BUSY,UX
          RJM    GETRQ       GET REQUEST
          RJM    SEEKCK      ISSUE INITIAL SEEK
          LDDL   PLSTAT
          NJK    SEKIX       IF COMMAND BLOCK ISSUE WAS UNSUCCESSFUL
          LDML   UNITS+/UN/P.BUSY,UX  SET 'UNIT BUSY' FLAG
          LPC    -/UN/K.BUSY
          ADK    /UN/K.BUSY
          STML   UNITS+/UN/P.BUSY,UX
 E110     IFEQ   ATST,1
          AOML   AUTOT       NUMBER OF SEEKS ISSUED
 E110     ENDIF
          UJK    SEKIX
          EJECT
** NAME-- SEEKCK.
*
** PURPOSE-- ISSUE A SEEK AND RECOVER ANY SEEK ERRORS.
          SPACE  6
 SEEX     LJM    **
 SEEKCK   EQU    *-1

* SET FUNCTION CODE FOR LOAD COMMAND BLOCK.

          LDML   SS+/SS/P.FNC  GET FUNCTION CODE
          ZJN    SEE10       IF READ
          LDK    R.WRITE     SEEK AND WRITE
          UJN    SEE15

 SEE10    BSS
          LDK    R.READ      SEEK AND READ
 SEE15    BSS
          STML   SS+/SS/P.FUNC  PARAMETER IN LOAD COMMAND BLOCK

* ISSUE LOAD COMMAND BLOCK.

          LDML   UNITS+/UN/P.UNIT,UX  UNIT NUMBER FOR LOAD COMMAND BLOCK
          STML   SS+/SS/P.UNIT
          LDN    0
          STML   SS+/SS/P.LENGTH  PARAMETER IN LOAD COMMAND BLOCK
          RJM    CMND        ISSUE LOAD COMMAND BLOCK
          UJK    SEEX
          EJECT
** NAME-- GETRQ
*
** PURPOSE-- GET FIRST REQUEST AND FIRST COMMAND.
*            SET UP STATUS RESPONSE BUFFER.
*            COMPUTE TOTAL BYTES TO TRANSFER
          SPACE  6
 GETRX    LJM    **
 GETRQ    EQU    *-1
          RJM    UREQ        READ UNIT REQUEST FROM CM
          RJM    SRESP       SET UP STATUS RESPONSE BUFFER
          RJM    SETRQ       SET UP FOR FIRST REQUEST
          RJM    UNCMND      GET FIRST COMMAND
          LDN    0
          STML   SS+/SS/P.SWFLG  CLEAR SWITCH FLAG

* COMPUTE TOTAL SECTORS TO TRANSFER.

          LDML   RQ+/RQ/P.MAUS  NUMBER OF SECTORS IN REQUEST
          LPK    /RQ/M.MAUS
          STML   SS+/SS/P.TOTAL  TOTAL SECTORS TO TRANSFER
          LDML   SS+/SS/P.RECOV
          NJN    GETR20      IF IN ERROR RECOVERY, DONT STREAM
          LDML   RQ+/RQ/P.SWIT  CHECK SWITCH FLAG
          SHN    /RQ/L.SWIT+2
 S2       IFNE   STREAM,1
          UJN    GETR20      TEMPORARY
 S2       ENDIF
          PJN    GETR20      IF NO SWITCH TO NEXT REQUEST
          LOADF  RQ+/RQ/P.NEXT  READ NEXT REQUEST
 GETR10   BSS
          ADN    /RQ/C.MAUS
          CRDL   P1          P1 = SWIT AND MAUS
          SBN    /RQ/C.MAUS-/RQ/C.NEXT
          CRDL   P2          P4, P5 = RMA OF NEXT REQUEST
          LDDL   P1          GET NUMBER OF SECTORS IN THIS REQUEST
          LPK    /RQ/M.MAUS
          RAML   SS+/SS/P.TOTAL  TOTAL SECTORS TO TRANSFER
          LDDL   P1          CHECK SWITCH FLAG
          SHN    /RQ/L.SWIT+2
          PJN    GETR20      IF NO SWITCH TO NEXT REQUEST
          LOADF  P4          READ NEXT REQUEST
          UJK    GETR10

 GETR20   BSS
          IFEQ   SMALL,1
          LDML   SS+/SS/P.SMALL  SET/CLEAR SMALL SECTOR FLAG
          LPC    -/SS/K.SMALL
          STML   SS+/SS/P.SMALL
          LDML   SMALL       NONZERO IF SMALL SECTORS
          ZJN    GETR40      IF LARGE SECTORS
          LDK    /SS/K.SMALL  SET SMALL SECTOR FLAG
          RAML   SS+/SS/P.SMALL
 GETR40   BSS
          ENDIF
          UJK    GETRX
          EJECT
** NAME-- SETRQ
*
** PURPOSE-- SET UP FOR FIRST REQUEST.
          SPACE  6
 SETRQX   LJM    **
 SETRQ    EQU    *-1
          LDML   SS+/SS/P.REQ  SAVE RMA OF REQUEST
          STML   SS+/SS/P.FCOMRQ  FIRST COMPLETED REQUEST (RMA)
          STML   SS+/SS/P.CURRQ  CURRENT REQUEST (RMA)
          LDML   SS+/SS/P.REQ+1
          STML   SS+/SS/P.FCOMRQ+1
          STML   SS+/SS/P.CURRQ+1
          LDN    1
          STML   SS+/SS/P.NCOMRQ  NUMBER OF COMPLETED REQUESTS
          RJM    SETADD      PUT STARTING ADDRESS IN RESPONSE BUFFER

* SET UP INTERRUPT PROCESSOR INSTRUCTION IF INTERRUPT IS SELECTED.

          LDML   RQ+/RQ/P.INT  CHECK IF INTERRUPT WAS SELECTED
          SHN    /RQ/L.INT+2
          MJN    SETR10      IF INTERRUPT SELECTED
          LDC    2400B       PSN INSTRUCTION
          UJN    SETR20

 SETR10   BSS
          LDML   RQ+/RQ/P.PORT  GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RQ/L.PORT+/RQ/N.PORT
          LPN    /RQ/M.PORT
          ADC    102600B     INPN INSTRUCTION
 SETR20   BSS
          STML   INTPRC
          UJK    SETRQX
          EJECT
** NAME-- SETADD
*
** PURPOSE-- SET STARTING DISK ADDRESS IN RESPONSE BUFFER.
          SPACE  6
 SETADDX  LJM    **
 SETADD   EQU    *-1

* PUT STARTING ADDRESS IN RESPONSE BUFFER.

          LDML   SS+/SS/P.CYL  STARTING CYLINDER ADDRESS
          STML   RS+/RS/P.SCYL
          LDML   SS+/SS/P.TRACK  TRACK
          SHN    /SS/L.TRACK+/SS/N.TRACK+2
          LPK    /SS/M.TRACK
          STML   SS+/SS/P.CURTRK
          STML   RS+/RS/P.STRK
          LDML   SS+/SS/P.SECTOR  SECTOR
          LPK    /SS/M.SECTOR
          STML   SS+/SS/P.CURSEC
          STML   RS+/RS/P.SSEC

* PUT REQUEST RETRY COUNT IN RESPONSE BUFFER.

          LDML   SS+/SS/P.RQTRY  REQUEST RETRY COUNT
          STML   RS+/RS/P.RTRY
          UJK    SETADDX
          EJECT
** NAME-- SNDWRS
*
** PURPOSE-- SEND WRITE RESPONSES FOR WRITE REQUESTS THAT HAVE
*            BEEN SUCCESSFULLY STREAMED.
          SPACE  6
 SNDWX    LJM    **
 SNDWRS   EQU    *-1
          LDML   SS+/SS/P.NCOMW  NUMBER OF COMPLETED WRITE REQUESTS MINUS 1
          ZJN    SNDWX       IF NO COMPLETED WRITE REQUESTS
          LDN    2
          STDL   WC
          LOADF  SS+/SS/P.CURRQ
          CRML   NRQ,WC      READ FIRST REQUEST TO GET START OF CHAIN
          LDML   SS+/SS/P.REQ  SET CURRQ TO END OF CHAIN SO DELRQ WILL
                             DELINK ALL REQUESTS
          STML   SS+/SS/P.CURRQ
          LDML   SS+/SS/P.REQ+1
          STML   SS+/SS/P.CURRQ+1
 SNDW10   BSS
          RJM    SNDRSP      SEND RESPONSE TO CM
          LDML   NRQ+/RQ/P.NEXT  PUT RMA IN PRERQ IN CASE THERE IS NO ROOM IN
                             RESPONSE BUFFER
          STML   SS+/SS/P.PRERQ
          LDML   NRQ+/RQ/P.NEXT+1
          STML   SS+/SS/P.PRERQ+1
          LDML   NRQ+/RQ/P.NEXTPV  PUT PVA OF NEXT RESPONSE IN RESPONSE BUFFER
          STML   RS+/RS/P.PVA
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   RS+/RS/P.PVA+1
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   RS+/RS/P.PVA+2
          LDN    2
          STDL   WC
          LOADF  NRQ+/RQ/P.NEXT  CM ADDRESS OF NEXT REQUEST
          CRML   NRQ,WC      READ NEXT REQUEST CHAIN POINTERS
          SOML   SS+/SS/P.NCOMW  DECREMENT COUNT OF RESPONSES LEFT TO SEND
          NJK    SNDW10      IF MORE RESPONSES
          UJK    SNDWX
          EJECT
** NAME-- SELRQ.
*
** PURPOSE-- SELECTS THE FIRST REQUEST IN THE CHAIN FOR THE
*            CURRENT REQUEST.
*
** INPUTS-- UNITS+/UN/P.UIT,UX = POINTER TO UNIT QUEUE TABLE.
*
** OUTPUTS-- RQ = CURRENT REQUEST.
*            SS+/SS/P.REQ
*            SS+/SS/P.CYL
*            SS+/SS/P.TRACK
*            SS+/SS/P.SECTOR
*            SS+/SS/M.CUR
*
** NOTE-- ASSUMES UNIT QUEUE LOCK HAS BEEN SET.
          SPACE  6
 SELRQX   LJM    **
 SELRQ    EQU    *-1

* READ RMA OF NEXT REQUEST FROM UNIT QUEUE.
* SET CURRENT REQUEST = FIRST REQUEST IN QUEUE.

          LOADR  UNITS+/UN/P.UIT,UX  LOAD CM ADDRESS OF UNIT QUEUE TABLE
          ADN    /UIT/C.NEXTPV
          CRDL   T1          READ RMA OF FIRST REQUEST IN CHAIN
          ADN    1
          CRDL   T1+4
          LDML   SS+/SS/P.CUR  CLEAR 'CURRENT REQUEST' FLAG
          LPC    -/SS/K.CUR
          STML   SS+/SS/P.CUR
          LDDL   T7
          STML   SS+/SS/P.REQ  SET RMA OF CURRENT REQUEST
          LDDL   T8
          STML   SS+/SS/P.REQ+1
          ADDL   T7
          ZJK    SELRQX      IF QUEUE EMPTY
          LDDL   T2          SET PVA OF CURRENT REQUEST
          STML   SS+/SS/P.PVA
          LDDL   T3
          STML   SS+/SS/P.PVA+1
          LDDL   T4
          STML   SS+/SS/P.PVA+2
          RJM    UREQ        READ SELECTED REQUEST INTO RQ
          LDML   RQ+/RQ/P.CYL
          STML   SS+/SS/P.CYL  CYLINDER ADDRESS OF CURRENT REQUEST
          LDML   RQ+/RQ/P.TRACK
          SHN    /SS/N.SECTOR  TRACK ADDRESS OF CURRENT REQUEST
          ADML   RQ+/RQ/P.SECTOR
          STML   SS+/SS/P.SECTOR  SECTOR ADDRESS OF CURRENT REQUEST

* SET CURRENT REQUEST FLAG.

          LDK    /SS/K.CUR   SET CURRENT REQUEST FLAG
          RAML   SS+/SS/P.CUR
          UJK    SELRQX
          EJECT
** NAME-- DELRQ.
*
** PURPOSE-- DELETE COMPLETED REQUEST FROM THE UNIT QUEUE.
*            SELECT A NEW CURRENT REQUEST BASED UPON CYLINDER ADDRESS.
*
** INPUTS-- UNITS+/UN/P.UIT = POINTER TO UNIT QUEUE TABLE
*           SS+/SS/P.NCOMRQ.
*           SS+/SS/P.CURRQ.
*
** OUTPUTS-- RQ = SELECTED REQUEST
*            SS+/SS/P.REQ
*            SS+/SS/P.CYL
*            SS+/SS/P.TRACK
*            SS+/SS/P.SECTOR
*            SS+/SS/M.CUR
*            SS+/SS/M.WRITE
*            /UIT/NEXT
*            /UIT/NEXTPV
*            /RQ/NEXT
*            /RQ/NEXTPV
*
** NOTE-- ASSUMES UNIT QUEUE LOCK HAS BEEN SET.
          SPACE  6
 DELX     LJM    **
 DELRQ    EQU    *-1
          LDN    0
          STDL   QEND        SET QUEUE-END FLAG = 0
          STDL   STRRQ       STREAMING REQUEST FLAG

 DEL2     BSS
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    DEL2        IF LOCK COULD NOT BE SET

* DECREMENT QUEUE COUNTER.

          LOADR  UNITS+/UN/P.UIT,UX  LOAD CM ADDRESS OF UNIT QUEUE TABLE
          STDL   T1
          CRDL   P1          READ QUEUE COUNT
          ERRNZ  /UIT/C.QCNT
          LDDL   P1+/UIT/P.QCNT  DECREMENT QUEUE COUNT
          SBML   SS+/SS/P.NCOMRQ  NUMBER OF COMPLETED REQUESTS
          STDL   P1+/UIT/P.QCNT
          MJN    DEL3        IF INVALID QUEUE COUNT
          LDDL   T1
          LMC    400000B
          CWDL   P1          WRITE QUEUE COUNT

* RE-READ RMA CHAIN POINTERS OF CURRENT REQUEST.

 DEL3     BSS
          LDN    2
          STDL   P3
          LOADF  SS+/SS/P.CURRQ  RMA OF CURRENT REQUEST
          CRML   RQ,P3       READ RMA CHAIN OF CURRENT REQUEST

* CLEAR FLAGS IN SS ENTRY.

          LDN    C.RQ
          STDL   WC
          LDML   SS+/SS/P.CUR  CLEAR 'CURRENT REQUEST'
          LPC    -/SS/K.CUR
          STML   SS+/SS/P.CUR

* READ NEXT REQUEST ON QUEUE.

          LDC    RQ
          STDL   P6
 DEL4     BSS
          LDML   /RQ/P.NEXT,P6
          STML   SS+/SS/P.REQ  SAVE RMA ADDRESS OF NEXT REQUEST
          LDML   /RQ/P.NEXT+1,P6
          STML   SS+/SS/P.REQ+1
          ADML   SS+/SS/P.REQ
          NJN    DEL5        IF NEXT REQUEST EXISTS
          AODL   QEND        SET QUEUE-END FLAG
          LJM    DEL10

 DEL5     BSS
          LDML   /RQ/P.NEXTPV,P6  SAVE PVA OF NEXT REQUEST
          STML   SS+/SS/P.PVA
          LDML   /RQ/P.NEXTPV+1,P6
          STML   SS+/SS/P.PVA+1
          LDML   /RQ/P.NEXTPV+2,P6
          STML   SS+/SS/P.PVA+2
          LOADF  /RQ/P.NEXT,P6  LOAD AND FORMAT CM ADDRESS OF NEXT REQUEST
          CRML   NRQ,WC      READ NEXT REQUEST

* SELECT HIGHEST PRIORITY REQUESTS.

          LDC    NRQ
          STDL   P6
          LDML   NRQ+/RQ/P.CMND+/CM/P.CODE  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          ADC    -C.READ
          NJN    DEL9        IF NOT A READ, GET NEXT REQUEST
          LDDL   STRRQ
          NJN    DEL6        IF PREVIOUS REQUEST IS A STREAMING REQUEST
          LDML   NRQ+/RQ/P.CMND+/CM/P.LEN  GET LENGTH OF CM ADDRESS AREA
          SBN    21B
          MJN    DEL10       IF READ OF 1 OR 2 PAGES
 DEL6     BSS
          LDML   NRQ+/RQ/P.SWIT  GET REQUEST SWITCH FLAG
          SHN    -16+/RQ/N.SWIT+/RQ/L.SWIT
          ERRNZ  -1+/RQ/N.SWIT+/RQ/L.SWIT
          STDL   STRRQ       NONZERO IF STREAMING REQUEST
 DEL9     UJK    DEL4

* GET RMA OF FIRST REQUEST IN CHAIN.
* START AT BEGINNING OF CHAIN IN ORDER TO DELINK THE REQUEST.
* ALSO, THE FIRST REQUEST IN THE CHAIN IS SELECTED IF THE END
* OF THE QUEUE WAS REACHED.

 DEL10    BSS
          LOADR  UNITS+/UN/P.UIT,UX  LOAD CM ADDRESS OF UNIT QUEUE TABLE
          ADN    /UIT/C.NEXTPV
          UJN    DEL35       READ RMA OF FIRST REQUEST IN CHAIN

* THE FIRST REQUEST IN THE CHAIN IS SELECTED IF THE END OF THE
* QUEUE WAS REACHED.

 DEL20    BSS
          LDDL   QEND        CHECK IF THE END OF Q WAS REACHED
          ZJN    DEL30       IF NOT THE END OF THE Q. GET NEXT REQUEST.
          LDN    0           TAKE THE FIRST REQUEST IN THE QUEUE
          STDL   QEND        RESET QUEUE-END FLAG
          LDML   NRQ+/RQ/P.NEXT  SAVE RMA OF THIS REQUEST
          STML   SS+/SS/P.REQ
          LDML   NRQ+/RQ/P.NEXT+1
          STML   SS+/SS/P.REQ+1
          LDML   NRQ+/RQ/P.NEXTPV  SAVE PVA OF THIS REQUEST
          STML   SS+/SS/P.PVA
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   SS+/SS/P.PVA+1
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   SS+/SS/P.PVA+2

* GET RMA AND PVA OF NEXT REQUEST IN CHAIN.
* (P3 = 2.)

 DEL30    BSS
          LOADF  NRQ+/RQ/P.NEXT  LOAD CM ADDRESS OF NEXT REQUEST
 DEL35    BSS
          STDL   P2          SAVE CM ADDRESS
          CRML   NRQ,P3      READ REQUEST FROM CHAIN
          ERRNZ  /RQ/C.NEXTPV
          ERRNZ  /RQ/C.NEXT-1
          ERRNZ  /UIT/C.NEXT-/UIT/C.NEXTPV-1

* CHECK IF NEXT REQUEST IN CHAIN = COMPLETED REQUEST.

          LDML   NRQ+/RQ/P.NEXT
          SBML   SS+/SS/P.FCOMRQ  IS NEXT REQUEST IN CHAIN = COMPLETED REQUEST
          NJN    DEL42       IF NEXT REQUEST IN CHAIN IS NOT COMPLETED REQUEST
          LDML   NRQ+/RQ/P.NEXT+1
          SBML   SS+/SS/P.FCOMRQ+1
 DEL42    NJK    DEL20       IF NEXT REQUEST IN CHAIN IS NOT COMPLETED REQUEST

* DELINK COMPLETED REQUESTS.
* (P3 = 2.)

          LDDL   P2          CM ADDRESS OF REQUEST
          ERRNZ  /RQ/C.NEXTPV
          LMC    400000B
          CWML   RQ,P3       PVA AND RMA OF NEXT REQUEST IN CHAIN
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD

* SET CURRENT REQUEST IN SS TO SELECTED REQUEST.

          LDML   SS+/SS/P.REQ  RMA OF SELECTED REQUEST
          ADML   SS+/SS/P.REQ+1
          ZJN    DEL70       IF QUEUE EMPTY
          RJM    UREQ        READ SELECTED REQUEST INTO RQ
          LDML   RQ+/RQ/P.CYL
          STML   SS+/SS/P.CYL  CYLINDER ADDRESS OF CURRENT REQUEST
          LDML   RQ+/RQ/P.TRACK
          SHN    /SS/N.SECTOR  TRACK ADDRESS
          ADML   RQ+/RQ/P.SECTOR
          STML   SS+/SS/P.SECTOR  SECTOR ADDRESS

          LDK    /SS/K.CUR   SET 'CURRENT REQUEST' FLAG
          RAML   SS+/SS/P.CUR
 DEL70    BSS
          LDN    0
          STML   SS+/SS/P.NCOMRQ  CLEAR COMPLETED REQUEST COUNT
          UJK    DELX
          EJECT
** NAME-- SETLOCK
*
** PURPOSE-- SETS THE UNIT LOCK IN THE UNIT INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SETLX    LJM    **
 SETLOCK  EQU    *-1
 F1       IFEQ   SLOCK,0
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJK    SETLX       IF LOCK COULD NOT BE SET
 F1       ENDIF
          RJM    GETSS       READ SS ENTRY FROM UNIT COMMUNICATION BUFFER
          RJM    SCLOCK      SET CHANNEL LOCK
          UJK    SETLX
          EJECT
** NAME-- SQLOCK
*
** PURPOSE-- SETS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SQLX     LJM    **
 SQLOCK   EQU    *-1
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          UJK    SQLX
          EJECT
** NAME-- LOCK
*
** PURPOSE-- SET A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS SET.
*         A REGISTER .NE. O, IF THE LOCK COULD NOT BE SET.
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T1 = 0, WRITE THE PP LOCKWORD TO CENTRAL MEMORY,
*            AS DESCRIBED IN THIS STEP.  ELSE IF T1 .NE. 0, GO TO
*            STEP 4.
*            TO WRITE THE PP LOCKWORD ID:
*            SET T1 - T4 = 8000 0000 0000 PPNO, WHERE PPNO IS THE
*            LOGICAL PP NUMBER OF THIS PP.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
*
*         4. IF T1 = 8000 AND T4 = PPNO, THIS LOCKWORD WAS ALREADY
*            RESERVED TO THIS PP.
*            RESTORE THE CENTRAL MEMORY LOCATION  (CWDL   T1).
*            SET THE A REGISTER = 0, AND EXIT.
*
*         5. IF T4 .NE. PPNO, THEN THIS LOCKWORD IS RESERVED TO
*            A DIFFERENT PROCESSOR.
*            SET BIT 16 OF THE LOCKWORD THAT WAS READ WITH THE
*            RDSL INSTRUCTION, AND WRITE THE CONTENTS BACK TO
*            CENTRAL MEMORY.
*            THE PURPOSE OF SETTING BIT 16 IS TO REQUEST THE
*            OTHER PROCESSOR TO GIVE UP THE LOCKWORD.
*            LDDL   T2
*            LPC    77777B
*            ADC    100000B
*            STDL   T2
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
          SPACE  6
 LOCKX    LJM    **
 LOCK     EQU    *-1

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 LOCK10   BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.

          LDDL   T1
          ADDL   T4
          ZJN    LOCK40      IF LOCK CAN BE SET

* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          NJN    LOCK20      IF THIS PP WAS FIRST TO WRITE
                             THE INTERMEDIATE VALUE
          AODL   LFF00
          UJK    LOCK10      REPEAT THE RDSL INSTRUCTION

* SET BIT 16 IN THE ORIGINAL CONTENTS OF CENTRAL MEMORY AND
* WRITE IT BACK TO CENTRAL MEMORY.

 LOCK20   BSS
          LDDL   T2          SET THE 'REQUEST LOCKWORD' FLAG
          LPC    77777B
          ADC    100000B
          STDL   T2
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE LOCKWORD

          LDDL   T4
          SBDL   PPNO        CHECK IF LOCK ALREADY SET
          NJN    LOCK30      IF LOCK COULD NOT BE SET, EXIT A .NE. 0
          LDDL   T1
          ADC    -100000B
 LOCK30   UJK    LOCKX       IF LOCK WAS ALREADY SET, EXIT A = 0
                             IF LOCK COULD NOT BE SET, EXIT A .NE. 0

* SET THE LOCKWORD.

 LOCK40   BSS
          LDC    100000B
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          LDDL   PPNO
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          SET THE LOCKWORD
          LDN    0
          UJK    LOCKX       EXIT, A REGISTER = 0
          EJECT
** NAME-- CLRLOCK
*
** PURPOSE-- CLEARS UNIT LOCK IN UNIT INTERFACE TABLE.
*
          SPACE  6
 CLRLX    LJM    **
 CLRLOCK  EQU    *-1
          LDDL   SSUN        UX FOR THIS SS IMAGE
          SBDL   UX          UNIT INDEX
          NJK    CLRLX       IF NOT THIS UNITS SS TABLE
          RJM    SAVSS       WRITE SS ENTRY TO COMMUNICATION BUFFER
                               IN UNIT INTERFACE TABLE
 F2       IFEQ   CLRLOCK,0
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR UNIT LOCKWORD
 F2       ENDIF
          UJK    CLRLX
          EJECT
** NAME-- CQLOCK
*
** PURPOSE-- CLEARS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
*
          SPACE  6
 CQLX     LJM    **
 CQLOCK   EQU    *-1
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CQLX
          EJECT
** NAME-- CLOCK
*
** PURPOSE-- CLEAR A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS CLEARED.
*         A REGISTER .NE. O, IF THE LOCK WAS NOT CLEARED.
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T4 .NE. PPNO, THIS LOCKWORD IS RESERVED TO A
*            DIFFERENT PROCESSOR.
*            RESTORE THE CONTENTS OF THIS CENTRAL MEMORY LOCATION
*            AS IT EXISTED BEFORE THE VALUE FFFF FFFF XXXX XXXX
*            WAS WRITTEN.
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
*
*         4. IF T4 = PPNO, THEN CLEAR THE LOCKWORD IN CENTRAL MEMORY.
*            SET T1 - T4 = 0000 0000 0000 0000.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
          SPACE  6
 CLKX     LJM    **
 CLOCK    EQU    *-1

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 CLK10    BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.
* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          NJN    CLK20       IF THIS PP WAS FIRST TO WRITE
                             THE INTERMEDIATE VALUE
          AODL   LFF00
          UJK    CLK10       REPEAT THE RDSL INSTRUCTION

 CLK20    BSS
          LDDL   T4          CHECK PP NUMBER
          SBDL   PPNO
          ZJN    CLK30       IF THIS PP HAS THE LOCK SET

* RESTORE THE ORIGINAL CONTENTS.

          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE ORIGINAL CONTENTS
          LDN    1
          UJK    CLKX        EXIT, A REGISTER NONZERO

* CLEAR THE LOCKWORD.

 CLK30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          CLEAR THE LOCKWORD
          LDN    0
          UJK    CLKX        EXIT, A REGISTER = 0
          EJECT
** NAME-- CKCHAN
*
** PURPOSE-- CHECK IF MAINTENANCE PP WANTS THE CHANNEL.
          SPACE  6
 CKCX     LJM    **
 CKCHAN   EQU    *-1
          LDK    C.CHCNT     NUMBER OF REQUESTS TO PROCESS BEFORE
                             GIVING UP THE CHANNEL
          STDL   CHLCNT
          LDDL   CHLOCK
          ZJK    CKCX        IF CHANNEL LOCK IS NOT SET
          LOADC  CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          ADDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          CRDL   T1          READ CHANNEL LOCKWORD
          LDDL   T2
          SHN    17-0
          PJK    CKCX        IF MAINTENANCE PP DOES NOT WANT THE CHANNEL
          LOADOVL PPREQO
          LJM    CKC1
          EJECT
** NAME-- FORMA
*
** PURPOSE-- FORMAT A CM REAL MEMORY ADDRESS.
*
** CALLING SEQUENCE-- LDC    ADDRESS
*                     RJM    FORMA
*
** INPUT-- - A REGISTER- IS THE ADDRESS OF A 2-WORD CM BYTE ADDRESS.
*
** OUTPUT-- -CMADR- IS THE ADDRESS OF THE RESULTING 3-WORD REFORMATED
*                CM ADDRESS.  THE FORMAT CAN BE USED BY THE LOADC MACRO.
*           -ADDRESS-, WORD 0, BITS 0-13 AND
*                      WORD 1, BITS 3-15, ARE REFORMATTED TO-
*           -CMADR-,   WORD 0, BITS 0-9,
*                      WORD 1, BITS 0-11,
*                      WORD 2, BITS 0-5.
*
          SPACE  6
 FORX     LJM    **
 FORMA    EQU    *-1
          STDL   T1

* REFORMAT CM ADDRESS.

          LDML   1,T1
          LPN    7
          ZJN    FOR10       IF VALID RMA ADDRESS
          RJM    HALT        RMA ADDRESS ERROR
*         (NO RETURN FROM HALT.)

 FOR10    BSS
          LDIL   T1
          LPN    37B
          SHN    16
          LMML   1,T1
          SHN    9
          STD    CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   T1
          SHN    -5
          STD    CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMC    400000B
          UJK    FORX
          EJECT
** NAME-- PAUS
*
** PURPOSE-- DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*            MICROSECONDS.
*
** INPUT-- A REGISTER (BITS 00-06) SPECIFIES NUMBER OF MICROSECONDS
*          TO BE DELAYED.
*
** NOTE-- THIS IS SET UP FOR 2X PP TIMING ON AN S1.
          SPACE  6
 PAUSX    LJM    **
 PAUS     EQU    *-1
          IFEQ   HARDW,1
 PAUS10   SBN    1           EACH ITERATION OF THIS SBN-NJN LOOP
          NJN    PAUS10      UTILIZES 1 MICROSECOND
          ENDIF
          UJK    PAUSX
          EJECT
          IFEQ   PAT,1
 PATX     LJM    **
 PATCH    EQU    *-1
          LDN    1
          STDL   WC
          LOADC  CM.PIT
          ADN    /PIT/C.RSBUF
          CRML   PCM,WC
          LDML   PCM
          ADML   PCM+1
          ZJN    PATX
          LOADF  PCM
          CRDL   P1
          LDN    0
          STDL   P5
          LJM    PAT29

 PAT20    LDML   P1,P5
          ADC    -177777B    END OF PATCHES
          NJN    PAT28
          LDN    0
          STML   PCM
          STML   PCM+1
          LDN    1
          STDL   WC
          LOADC  CM.PIT
          ADN    /PIT/C.RSBUF
          CWML   PCM,WC
          UJK    PATX

 PAT28    BSS
          ADC    -170000B+177777B  END OF CONTENTS
          NJN    PAT30
 PAT27    BSS
          RJM    PBUMP
 PAT29    BSS
          LDML   P1,P5
          STDL   PAD
          ADC    -170000B
          ZJN    PAT27
          RJM    PBUMP
          UJK    PAT20

 PAT30    LDML   P1,P5
          STIL   PAD
          AODL   PAD
          RJM    PBUMP
          UJK    PAT20

 PBUX     LJM    **
 PBUMP    EQU    *-1
          AODL   P5
          SBN    4
          MJN    PBUX
          LDN    8
          RAML   PCM+1
          SHN    -16
          RAML   PCM
          LOADF  PCM
          CRDL   P1
          LDN    0
          STDL   P5
          UJK    PBUX

 PCM      BSSZ   4
 PAD      EQU    P6          PP ADDRESS TO PATCH
          ENDIF
          EJECT
* DEBUG TEST.
          SPACE  6
 Q11      IFEQ   ERRTST,1
 TESTX    LJM    **
 TEST     EQU    *-1
 Q111     IFEQ   ATST,1
          LDN    6
          STDL   T1
 TEST3    BSS
          LDML   AUTOT
          SBML   TESTA-1,T1
          ZJN    TEST5
          SODL   T1
          NJK    TEST3
          UJK    TESTX

 TEST5    BSS
          AOML   AUTOT       TO PREVENT THE SAME FORCE ERROR CODE TO BE
                             ISSUED ON THE NEXT CALL
          LDML   TESTP-1,T1
          STML   TESTPAR

 Q111     ELSE
          LOADC  CM.PIT
          ADN    /PIT/C.CBUF  COMMUNICATION BUFFER
          STDL   P1
          CRDL   P2
          LDDL   P2
          ZJK    TESTX
          STML   TESTPAR     SAVE PARAMETER
          LDN    0
          STDL   P2
          LDDL   P1
          LMC    400000B
          CWDL   P2
 Q111     ENDIF

          LDML   TESTPAR
          SBN    29
          MJK    TESTX
          SBN    34-29+1
          PJK    TESTX       IF NOT FORCE ERROR FUNCTION
          LDN    F.ADPT     FORCE ERROR
          RJM    FUNC
          ACN    DC
          LDML   TESTPAR     PARAMETER
          OAN    DC
          FJM    *,DC
          LDI    P5          TIME DELAY
          DCN    40B+DC
          UJK    TESTX
          SPACE  6
 TESTPAR  BSSZ   1           TEST PARAMETER

 Q112     IFEQ   ATST,1
 TESTA    CON    11000
          CON    11200
          CON    11400
          CON    11600
          CON    11800
          CON    12000
 TESTP    CON    31
          CON    32
          CON    33
          CON    34
          CON    29
          CON    30
          QUAL   *
 AUTOT    BSSZ   1           NUMBER OF SEEKS ISSUED
          QUAL   RES
 Q112     ENDIF

 Q11      ENDIF
          EJECT
 CONCH    BSS                DISK CHANNEL REFERENCES
 TDC+40B  HERE
 T40B+DC  HERE
 TDC      HERE
          CON    0           END OF TABLE
          EJECT
          QUAL   *

 BUFF     EQU    7777B-SBYTE8  SECTOR DATA BUFFER
 CBUF     EQU    BUFF        START OF CM DATA IN SECTOR BUFFER
          SPACE  6
          SPACE  4
* PPRQ    BSSZ   1           PP REQUEST FLAG
          IFEQ   SMALL,1
 SMALL    BSSZ   1           NONZERO IF SMALL SECTOR TRANSFER
          ENDIF
 SAVE     BSSZ   1           USED TO SAVE UX VALUE
 SC2      BSSZ   1           TIMEOUT OF 2 SECONDS
 SC60     BSSZ   1           TIMEOUT OF 60 SECONDS
 SC185    BSSZ   1           TIMEOUT OF 185 SECONDS
 PIDLE    BSSZ   1           PRE-IDLE FLAG.  WHEN SET, DON'T ISSUE ANY
                             SEEKS.  BUT FINISH OUTSTANDING COMMANDS.
 SAVUX    BSSZ   1
 IADL     BSSZ   1           NONZERO IF LOADING THE ADAPTER DURING INITIALIZATION
 CKDATA   BSSZ   1           CONFIDENCE TEST COMPARE DATA FLAG
 IGNORE   BSSZ   1           NONZERO, IF ERRORS ARE TO BE IGNORED
 DEBUG2   BSSZ   1           USED FOR DEBUG PURPOSES
 RSP      BSSZ   1           IF SET, PROCESSING RESPONSE FLAG
          SPACE  6
 CMNUM    EQU    8           MAXIMUM NUMBER OF CONTROL MODULES
 LDTIM    BSSZ   CMNUM*2     CONTROL MODULE TIMEOUT TABLE
*                            (TWO CELLS/CONTROL MODULE)
 CMLOAD   BSSZ   CMNUM       CONTROL MODULE LOAD TABLE
                             CONTROL MODULE NUMBER INDEXES INTO THIS TABLE.
                             BIT 11 = 1 IF LOADING THIS CONTROL MODULE.
                             BITS 5 - 0 = INDEX TO UNITS TABLE.
 UNUM     EQU    8           SUPPORT 8 UNITS
 UNITS    BSSZ   UNUM*P.UN   RMA OF UNIT QUEUE TABLE
 SS       BSSZ   P.SS        INFORMATION SAVED IN UNIT COMMUNICATION BUFFER
 RQ       EQU    SS+/SS/P.RQ  REQUEST
 CM       EQU    RQ+/RQ/P.CMND  CURRENT COMMAND
 CMLIST   EQU    SS+/SS/P.CMLIST  INDIRECT RMA LIST
 RS       EQU    SS+/SS/P.RS  RESPONSE BUFFER
          BSSZ   3           MUST FOLLOW RS, FOR ZEROING OUT RS
          SPACE  6
 FBUF     BSSZ   16          FUNCTION HISTORY BUFFER
 FBUFL    EQU    *-FBUF      LENGTH OF FUNCTION BUFFER
 SBUF     BSSZ   16          STATUS HISTORY BUFFER
 SBUFL    EQU    *-SBUF      LENGTH OF STATUS BUFFER

 CTBUF    BSSZ   8           BUFFER FOR LOADING CONTROLWARE
 NRQ      BSSZ   C.RQ*4      NEXT REQUEST ON QUEUE
          SPACE  6
 R        ERRPL  *-OVAD1     IF > 0, RESIDENT PORTION IS TOO LARGE
          EJECT
 ADPTERR  EQU    /RES/ADPTERR
 RECS     EQU    /RES/RECS
 ATERM    EQU    /RES/ATERM
 HTERM    EQU    /RES/HTERM
 UTERM    EQU    /RES/UTERM
 OTERM    EQU    /RES/OTERM
 OCTERM   EQU    /RES/OCTERM
 LTERM    EQU    /RES/LTERM
 ACN      EQU    /RES/ACN
 INC      EQU    /RES/INC
 IAMBF    EQU    /RES/IAMBF
 OAMBF    EQU    /RES/OAMBF
 OAMP1    EQU    /RES/OAMP1
 CFM      EQU    /RES/CFM
 EJM      EQU    /RES/EJM
 OAMCT    EQU    /RES/OAMCT
 DCN      EQU    /RES/DCN
 DCN2     EQU    /RES/DCN2
 MAINA    EQU    /RES/MAINA
 MAINC    EQU    /RES/MAINC
 MAINB    EQU    /RES/MAINB
 MAIND    EQU    /RES/MAIND
 SQLOCK   EQU    /RES/SQLOCK
 LOCK     EQU    /RES/LOCK
 CLRLOCK  EQU    /RES/CLRLOCK
 CQLOCK   EQU    /RES/CQLOCK
 SAVSS    EQU    /RES/SAVSS
 CLOCK    EQU    /RES/CLOCK
 GETSS    EQU    /RES/GETSS
 UREQ     EQU    /RES/UREQ
 ZRESP    EQU    /RES/ZRESP
 SETRQ    EQU    /RES/SETRQ
 SETADD   EQU    /RES/SETADD
 FAILAD   EQU    /RES/FAILAD
 SRESP    EQU    /RES/SRESP
 UNCMND   EQU    /RES/UNCMND
 GLIST    EQU    /RES/GLIST
 CFLGS    EQU    /RES/CFLGS
 PUTRC    EQU    /RES/PUTRC
 CHNERR   EQU    /RES/CHNERR
 CHERO    EQU    /RES/CHERO
 CHER     EQU    /RES/CHER
 SERR     EQU    /RES/SERR
 SERRID   EQU    /RES/SERRID
 SID      EQU    /RES/SID
 RESP     EQU    /RES/RESP
 RESPIN   EQU    /RES/RESPIN
 SNDRSP   EQU    /RES/SNDRSP
 FUNC     EQU    /RES/FUNC
 CMND     EQU    /RES/CMND
 POLSTAT  EQU    /RES/POLSTAT
 FORMA    EQU    /RES/FORMA
 PAUS     EQU    /RES/PAUS
 DELRQ    EQU    /RES/DELRQ
 SELRQ    EQU    /RES/SELRQ
 UCMDPR   EQU    /RES/UCMDPR
 CONCH    EQU    /RES/CONCH
 TERM     EQU    /RES/TERM
 TERMA    EQU    /RES/TERMA
 TERMC    EQU    /RES/TERMC
          EJECT
          QUAL   IN
 IPIT     BSSZ   C.PIT*4     PP INTERFACE TABLE
          EJECT
** NAME-- INIT
*
** PURPOSE-- INITIALIZE THE DRIVER AFTER DEADSTART.
*
** INPUT-- DSRTP = CM BYTE-ADDRESS OF THE PP INTERFACE TABLE.
          SPACE  6
          QUAL   *
 INIT     BSS
          QUAL   IN

          REFAD  DSRTP,CM.PIT   REFORMAT ADDRESS OF PP INTERFACE TABLE
                               AND SAVE.


* REFORMAT ADDRESS OF COMMUNICATION BUFFER.
* INITIALIZE CM.CB.

          LOADC  CM.PIT      ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.CBUF  OFFSET OF PP COMMUNICATION BUFFER ADDRESS
          CRDL   P1          READ ADDRESS OF PP COMMUNICATION BUFFER
          REFAD  P3,CM.CB    REFORMAT CM ADDRESS OF PP COMMUNICATION BUFFER

* PUT ZEROES IN THE ZERO BUFFER.

          LDK    C.RS-/RS/C.FTRK
          STDL   WC
          LDDL   CMADR+2     CM ADDRESS OF COMMUNICATION BUFFER
          LMC    400000B
          ADK    /CB/C.ZERO
          CWML   RS+/RS/P.FTRK,WC  STORE ZEROES


* REFORMAT ADDRESS OF OVERLAY DIRECTORY.

          LOADC  CM.CB       POINTER TO PP COMMUNICATION BUFFER
          ADN    3
          CRDL   T1          READ WORD CONTAINING RMA OF DIRECTORY
          REFAD  T3,DH       REFORMAT DIRECTORY RMA


          RJM    ZRESP       ZERO OUT RESPONSE BUFFER

* READ PP_INTERFACE_TABLE.

          LDN    C.PIT
          STDL   WC
          LOADC  CM.PIT      LOAD CM ADDRESS OF PP INTERFACE TABLE
          CRML   IPIT,WC     READ PP INTERFACE TABLE
          IFEQ   VALID,1
          RJM    CHKRS       CHECK FOR VALIDITY OF PP RESPONSE BUFFER
          ENDIF
          LDML   IPIT+/PIT/P.PPNO  GET PP NUMBER
          STDL   PPNO

* INITIALIZE UDL, LUDL.

          LDML   IPIT+/PIT/P.UNITC  NUMBER OF UNIT DESCRIPTORS
          SHN    1
          STDL   UDL         LENGTH OF UNIT DESCRIPTORS (CM WORDS)

* REFORMAT ADDRESS OF RESPONSE BUFFER.
* INITIALIZE CM.RS, LIM.

          REFAD  IPIT+/PIT/P.RSBUF,CM.RS  REFORMAT CM ADDRESS OF RESPONSE
                             BUFFER
          LDML   IPIT+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STDL   LIM
          IFEQ   VALID,1
          RJM    CHKPIT      CHECK FOR VALIDITY OF PP INTERFACE TABLE
          ENDIF

* REFORMAT ADDRESS OF INTERRUPT WORD.

          REFAD  IPIT+/PIT/P.INT,CM.INT  REFORMAT CM ADDRESS OF
                             INTERRUPT WORD

* REFORMAT ADDRESS OF CHANNEL TABLE.

          REFAD  IPIT+/PIT/P.CHAN,CM.CHAN  REFORMAT CM ADDRESS OF
                             CHANNEL TABLE

* GO TO MAIN LOOP.

          LJM    MAINA
          EJECT
 SAVAX    LJM    **
 SAVAD    EQU    *-1
          STML   2,T2
          LDDL   CMADR
          STI    T2
          LDDL   CMADR+1
          STML   1,T2
          UJK    SAVAX
          EJECT
* CHECK FOR VALID PP RESPONSE BUFFER.
          SPACE  6
 D1       IFEQ   VALID,1
 CHKRX    LJM    **
 CHKRS    EQU    *-1
          LDML   IPIT+/PIT/P.RSBUF-2  RESERVED WORD OF RESPONSE
                             BUFFER DESCRIPTOR
          ADML   IPIT+/PIT/P.RSBUF-1
          ADML   IPIT+/PIT/P.RSPVA-1
          NJN    CHKR100     IF RESERVED FIELD NOT XERO

          LDML   IPIT+/PIT/P.IN-3  RESERVED FIELD OF IN POINTER
          ADML   IPIT+/PIT/P.IN-2
          ADML   IPIT+/PIT/P.IN-1
          NJN    CHKR100     IF RESERVED FIELD NOT ZERO

          LDML   IPIT+/PIT/P.OUT-3  RESERVED FIELD OF OUT POINTER
          ADML   IPIT+/PIT/P.OUT-2
          ADML   IPIT+/PIT/P.OUT-1
          NJN    CHKR100     IF RESERVED FIELD NOT ZERO

          LDML   IPIT+/PIT/P.LIMIT-2
          ADML   IPIT+/PIT/P.LIMIT-1
          ZJK    CHKRX

 CHKR100  BSS
          RJM    HALT        INVALID RESPONSE BUFFER
*         (NO RETURN FROM HALT.)

 D1       ENDIF
          EJECT
* CHECK FOR VALID PP-INTERFACE-TABLE.
          SPACE  6
 D2       IFEQ   VALID,1
 CHKPX    LJM    **
 CHKPIT   EQU    *-1
          LDN    0
          STDL   T1
          LDML   IPIT+/PIT/P.CBUFL  COMMUNICATION BUFFER LENGTH
          LPN    7
          NJN    CHKP100     IF LENGTH NOT A MULTIPLE OF WORDS

          AODL   T1
          LDML   IPIT+/PIT/P.CBUFL-1  RESERVED WORD OF PP COMMUNICATION
                             BUFFER DESCRIPTOR
          NJN    CHKP100     IF RESERVED WORD NOT ZERO

          AODL   T1
          LDML   IPIT+/PIT/P.CBUF+1  COMMUNICATION BUFFER (RMA)
          LPN    7
          NJN    CHKP100     IF PP COMMUNICATION BUFFER NOT A WORD BOUNDARY

          AODL   T1
          LDML   IPIT+/PIT/P.PPQPVA-1  RESERVED FIELD OF PP REQUEST
                             QUEUE DESCRIPTOR
          ADML   IPIT+/PIT/P.PPQ-1
          NJN    CHKP100     IF RESERVED FIELD NOT ZERO

          AODL   T1
          LDML   IPIT+/PIT/P.INT+1  INTERRUPT WORD (RMA)
          LPN    7
          NJN    CHKP100     IF INTERRUPT WORD NOT A WORD BOUNDARY
          AODL   T1
          LDML   IPIT+/PIT/P.CHAN+1  CHANNEL TABLE (RMA)
          LPN    7
          ZJK    CHKPX

 CHKP100  BSS
          LDML   CHKP110,T1  INTERFACE ERROR CODE
          RJM    INTERR2     SEND ERROR TO CM
*         (NO RETURN FROM INTERR)

 CHKP110  BSS
          CON    E20B        COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS
          CON    E204        RESERVED WORD OF PP COMMUNICATION
                             BUFFER DESCRIPTOR NOT ZERO
          CON    E203        PP COMMUNICATION BUFFER NOT A WORD BOUNDARY
          CON    E205        RESERVED FIELD OF PP REQUEST QUEUE
                             DESCRIPTOR NOT ZERO
          CON    E211        RMA OF INTERRUPT WORD NOT A WORD BOUNDARY
          CON    E212        RMA OF CHANNEL TABLE NOT A WORD BOUNDARY
 D2       ENDIF
          EJECT
* INTERFACE ERROR.
          SPACE  6
 INTERR2  CON    0
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LDN    0           UNSOLICITED MESSAGE
          STDL   RESPC       RESPONSE CODE
          LDK    /RS/K.INTERR  INTERFACE ERROR
          STML   RS+/RS/P.INTERR  ABNORMAL STATUS CODE
          RJM    TERMP       SEND RESPONSE TO CM
          RJM    HALT        HALT THE PP
*         (NO RETURN FROM HALT.)

          EJECT
** NAME-- TERMP
*
** PURPOSE-- TERMINATE PP REQUEST.
*
** OUTPUT-- RS+/RS/P.RC = RESPONSE CODE
          SPACE  6
 TERX     LJM    **
 TERMP    EQU    *-1
          RJM    PUTRC       PUT RESPONSE CODES IN RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
*         LDN    0
*         STML   PPRQ        ZERO OUT PP REQUEST FLAG
          RJM    ZRESP       ZERO OUT RESPONSE BUFFER
          UJK    TERX
          EJECT
 R2       ERRPL  *-7761B
          EJECT
          QUAL   *


 PRGNAM   MICRO  1,4,*ISDD*

 OVAD1    EQU    BUFF-206B*4
          EJECT
          OVERLAY (READ WRITE),OVAD1
          ROUTINE READO
          CON    READOO

          QUAL   RD
          EJECT
** NAME-- READ.
*
** PURPOSE-- PROCESS READ DATA COMMAND.
*
** INPUT-- LISTL = NUMBER OF ADDRESS-LENGTH-PAIR ENTRIES IN THE
*                    COMMAND WHICH ARE LEFT TO PROCESS.
*          CMLIST  = LIST OF ADDRESS-LENGTH-PAIRS POINTING TO THE
*                    CM DATA AREA.
          SPACE  6
 READX    LJM    **
          QUAL   *
 READ     EQU    *-1
          QUAL   RD
          LDML   SS+/SS/P.TOTAL  TOTAL SECTORS LEFT TO TRANSFER
          NJN    READ10      IF MORE DATA TO TRANSFER
          RJM    TERMA       PROBABLY ADAPTER ERROR
*         (NO RETURN FROM TERMA.)

 READ10   BSS
          RJM    RDWT        SET UP FOR READ / WRITE
 READ20   BSS
          LDML   CMLIST+/CM/P.LEN  NUMBER OF BYTES LEFT TO TRANSFER
          SHN    -3
          STDL   WDS         CM WORDS LEFT TO TRANSFER
          ZJK    READ125     IF NO WORDS TO TRANSFER TO THIS ADDRESS
          IFNE   SMALL,1
          ADC    -CMWDS      CM WORDS PER SECTOR
          ELSE
          SBML   CMWDS,SZ    CM WORDS PER SECTOR
          ENDIF
          ADDL   SECPOS      WORDS PREVIOUSLY TRANSFERRED FROM THIS SECTOR
          MJN    READ30      IF LESS THAN 1 SECTOR LEFT TO TRANSFER
          IFNE   SMALL,1
          LDC    CMWDS       COMPUTE NUMBER OF CM WORDS TO TRANSFER THIS LOOP
          ELSE
          LDML   CMWDS,SZ    COMPUTE NUMBER OF CM WORDS TO TRANSFER THIS LOOP
          ENDIF
          SBDL   SECPOS
          PJN    READ24
          LDDL   WDS
          ZJN    READ24      IF VALID SECTOR POSITION
          RJM    HALT        INVALID SECTOR POSITION
*         (NO RETURN FROM HALT.)

 READ24   BSS
          STDL   WDS         NUMBER OF CM WORDS TO TRANSFER FROM
                             CURRENT SECTOR
 READ30   BSS
          LDDL   SECPOS
          NJK    READ90      IF MORE WORDS TO TRANSFER FROM LAST SECTOR

* DETERMINE IF THE ENDING STATUS SHOULD BE TAKEN.
* IN OTHER WORDS, DETERMINE IF THIS IS THE LAST SECTOR BEFORE
* SUSPENDING OR TERMINATING.

          LDN    0
          STDL   P1          P1 = 0 IF NOT LAST SECTOR
          SOML   SS+/SS/P.MAUS  DECREMENT MAU COUNT FOR THIS REQUEST
          LDDL   MOVFC       CHECK IF SUSPEND
          SBN    F.MOVD
          NJN    READ35      IF NOT SUSPEND
          LDN    1
          STDL   T1
          LDDL   FRSTSC
          ZJN    READ32      IF FIRST SECTOR
          AODL   T1
 READ32   BSS
          LDDL   TWDS        SECTORS LEFT TO TRANSFER
          SBDL   T1
          NJN    READ40      IF NOT SUSPEND OR TERMINATE
          UJN    READ37      LAST SECTOR

 READ35   BSS
          LDML   SS+/SS/P.MAUS  MAU COUNT
          NJN    READ40      IF MORE DATA
          LDN    1           RE-READ REQUEST
          RJM    CKSTR       CHECK STREAM FLAG
          NJN    READ40      IF NOT END OF DATA
 READ37   BSS
          AODL   P1          LAST SECTOR

* READ FROM DISK.

 READ40   BSS
          LDDL   MOVFC       SEND MOVE DATA FUNCTION
          RJM    FUNC
          RJM    IAMBF       ACN    DC
                             LDC    SECWDS      NUMBER OF CHANNEL WORDS
                             IAM   BUFF,DC
          ZJN    READ50      IF TRANSFER WAS COMPLETE
          STDL   AREG        SAVE A REGISTER IN CASE OF PREMATURE TERMINATION
          RJM    POLSTAT     GET POLL STATUS
          LDDL   PLSTAT      IF POLL STATUS = 640XX B, THEN
                             IT WAS A MEDIA ERROR, REPEAT MOVE DATA
          ADC    -64000B
          SBML   UNITS+/UN/P.UNIT,UX
          NJN    READ45      IF NOT MEDIA ERROR
          LDK    /RS/K.MEDIA  MEDIA ERROR
          RJM    SERRID      SAVE ERROR ID
          UJK    READ40      REPEAT MOVE DATA

 READ45   BSS
          LDDL   AREG
          STML   RS+/RS/P.FUNTO  NUMBER OF CHANNEL WORDS NOT RECEIVED
          LDK    /RS/K.IST   INCOMPLETE SECTOR TRANSFER
          UJN    READ75

 READ50   BSS
          RJM    INC         CHECK IF CHANNEL IS INACTIVE
*         (NO RETURN IF ERROR).

          LDDL   P1
          ZJN    READ85      IF NOT SUSPEND OR TERMINATE

* SUSPEND OR TERMINATE.
* THIS STATUS MUST BE ISSUED IMMEDIATELY, (WITHIN 50 MICROSECONDS),
* AFTER THE READ FUNCTION.
* THE TIMING PERIOD STARTS AFTER THE  IAM  FROM INPUTING THE DATA AND
* ENDS AFTER THE  FAN  OF SENDING THE POLL STATUS FUNCTION.

          RJM    POLSTAT     GET POLL STATUS
          LDDL   PLSTAT
          ADC    -4000B
          SBML   UNITS+/UN/P.UNIT,UX
          ZJN    READ85      IF NO ERROR ON LAST SECTOR
          LDK    /RS/K.RERR  STATUS BEFORE SUSPEND / TERMINATE READ .NE.
                             4XXXB.
 READ75   BSS
          RJM    SERRID      SAVE ERROR FLAG
          RJM    ADPTERR     RECOVER ERROR
*         (NO RETURN FROM ADPTERR.)

 READ85   BSS
          AODL   FRSTSC
          SBN    1
          ZJN    READ90      IF FIRST SECTOR TRANSFERRED FOR THIS
                             READ SEQUENCE

* PREVIOUS SECTOR HAS BEEN TRANSFERRED WITHOUT ERROR.
* UPDATE COUNTERS AND POINTERS.

          RJM    RDWTOK      UPDATE COUNTERS FOR GOOD READ TRANSFER

* TRANSFER DATA TO CM.

 READ90   BSS
          LDDL   SECPOS      CALCULATE SECTOR BUFFER TRANSFER ADDRESS
          SHN    2
          ADC    CBUF
          STML   READ100
          LDDL   WDS
          ZJN    READ110     IF 0 WORDS TO TRANSFER
          LOADF  CMLIST+/CM/P.RMA  CM ADDRESS OF DATA AREA
          CWML   CBUF,WDS    SEND DATA TO CM
 READ100  EQU    *-1
          LDDL   SECPOS
          NJN    READ110     IF SOME DATA IS LEFT IN THE BUFFER,
                             DONT LET AN OVERLAY BE READ
          RJM    /RES/RECRS  CHECK IF A PREVIOUS ERROR WAS RECOVERED

* UPDATE BYTES TRANSFERRED.

 READ110  BSS
          LDDL   WDS
          RADL   SECPOS      UPDATE SECTOR POSITION
          IFNE   SMALL,1
          ADC    -CMWDS      CHECK FOR END OF SECTOR
          ELSE
          SBML   CMWDS,SZ    CHECK FOR END OF SECTOR
          ENDIF
          NJN    READ120
          STDL   SECPOS      RESET SECTOR POSITION = 0
 READ120  BSS
          LDDL   SECPOS
          NJN    READ122     IF SOME DATA IS LEFT IN THE BUFFER,
                             DONT LET AN OVERLAY BE READ
          RJM    /RES/RECRS  CHECK IF A PREVIOUS ERROR WAS RECOVERED
 READ122  BSS
          LDDL   WDS         CM WORDS TRANSFERRED
          SHN    3
          STDL   T1          BYTES TRANSFERRED
          RADL   WDSS        SAVE BYTES TRANSFERRED THIS SECTOR
          LDDL   T1
          RAML   CMLIST+/CM/P.RMA+1  UPDATE CM ADDRESS
          SHN    -16
          RAML   CMLIST+/CM/P.RMA
          LDML   CMLIST+/CM/P.LEN  UPDATE BYTES LEFT TO TRANSFER
          SBDL   T1
          STML   CMLIST+/CM/P.LEN
          NJN    READ150     IF MORE WORDS TO TRANSFER TO THIS CM ADDRESS
 READ125  BSS
          SOML   SS+/SS/P.LISTL  DECREMENT ADDRESS-LENGTH-PAIR COUNT
          ZJN    READ130     IF END OF RMA LIST
          RJM    GLIST       READ NEXT SECTION OF THE LIST WHICH POINTS
                             TO THE CM DATA AREA
          UJN    READ150

* GET NEXT COMMAND.

 READ130  BSS
          LDN    0
          STDL   SECPOS      THROW AWAY ANY PARTIAL SECTOR
          RJM    UNCMND      GET NEXT COMMAND
          NJN    READ150     IF MORE COMMANDS
          LDDL   CSTREAM
          NJN    READ160     CHECK IF MORE REQUESTS TO STREAM

* CHECK IF SWITCH TO NEXT REQUEST.

          LDML   SS+/SS/P.TOTAL  TOTAL SECTORS LEFT TO TRANSFER
          SBN    1
          ZJN    READ150     IF END OF TRANSFER
          RJM    CSWIT       CHECK IF SWITCH TO NEXT REQUEST
          NJN    READ150     IF SWITCH TO NEXT REQUEST
          LDN    0           PARTIAL SECTOR WAS TRANSFERRED
                             AND NO MORE DATA
          STML   SS+/SS/P.TOTAL
          UJN    READ160

* CHECK IF TIME TO SUSPEND OR TERMINATE.

 READ150  BSS
          LDDL   CSTREAM
          NJN    READ156     IF MORE TO TRANSFER
          LDDL   TWDS
          SBN    1
          ADDL   SECPOS      MAKE SURE FULL SECTOR IS TRANSFERRED
 READ156  BSS
          NJK    READ20      IF MORE TO TRANSFER

* IF NOT SUSPENDING THE TRANSFER, REREAD THE STREAM FLAG.

 READ160  BSS
          LDN    2           DON'T RE-READ REQUEST
          RJM    CKSTR       CHECK STREAM FLAG
          NJK    READ156     IF MORE TO TRANSFER

* SUSPEND OR TERMINATE.

          RJM    RDWTOK      UPDATE COUNTERS FOR GOOD READ TRANSFER

* CHECK IF END OF REQUEST.

          LDML   SS+/SS/P.TOTAL
          NJN    READ170     IF MORE WORDS TO TRANSFER
          RJM    TERMC       TERMINATE REQUEST
*         (NO RETURN FROM TERMC.)

 READ170  BSS
          LDDL   SECPOS
          ZJK    READX
          RJM    HALT        SHOULD NEVER HAPPEN
*         (NO RETURN FROM HALT.)
          EJECT
** NAME-- WRITE
*
** PURPOSE-- PROCESS THE WRITE DATA COMMAND.
*
** INPUT-- LISTL = NUMBER OF ADDRESS-LENGTH-PAIR ENTRIES IN THE
*                    COMMAND WHICH ARE LEFT TO PROCESS.
*          CMLIST = LIST OF ADDRESS-LENGTH-PAIRS POINTING TO THE
*                   CM DATA AREA.
          SPACE  6
 WRIX     LJM    **
          QUAL   *
 WRITE    EQU    *-1
          QUAL   RD
          LDML   SS+/SS/P.TOTAL  TOTAL SECTORS LEFT TO TRANSFER
          NJN    WRI10       IF MORE DATA TO TRANSFER
          RJM    TERMA       PROBABLY ADAPTER ERROR
*         (NO RETURN FROM TERMA.)

 WRI10    BSS
          RJM    RDWT        SET UP FOR WRITE
 WRI20    BSS
          LDML   CMLIST+/CM/P.LEN  NUMBER OF BYTES LEFT TO TRANSFER
          SHN    -3
          STDL   WDS         CM WORDS LEFT TO TRANSFER
          IFNE   SMALL,1
          ADC    -CMWDS      CM WORDS PER SECTOR
          ELSE
          SBML   CMWDS,SZ    CM WORDS PER SECTOR
          ENDIF
          ADDL   SECPOS      WORDS PREVIOUSLY TRANSFERRED FROM THIS SECTOR
          MJN    WRI30       IF LESS THAN 1 SECTOR LEFT TO TRANSFER
          IFNE   SMALL,1
          LDC    CMWDS       COMPUTE NUMBER OF CM WORDS TO TRANSFER THIS LOOP
          ELSE
          LDML   CMWDS,SZ    COMPUTE NUMBER OF CM WORDS TO TRANSFER THIS LOOP
          ENDIF
          SBDL   SECPOS
          PJN    WRI24
          LDDL   WDS
          ZJN    WRI24       IF VALID SECTOR POSITION
          RJM    HALT        INVALID SECTOR POSITION
*         (NO RETURN FROM HALT.)

 WRI24    BSS
          STDL   WDS         NUMBER OF CM WORDS TO TRANSFER TO CURRENT SECTOR

* TRANSFER DATA FROM CM.

 WRI30    BSS
          LDDL   SECPOS      CALCULATE SECTOR BUFFER TRANSFER ADDRESS
          SHN    2
          ADC    CBUF
          STML   WRI35
          LDDL   WDS
          ZJN    WRI40       IF 0 WORDS TO TRANSFER
          LOADF  CMLIST+/CM/P.RMA  CM ADDRESS OF DATA AREA
          CRML   CBUF,WDS    READ SECTOR FROM CM
 WRI35    EQU    *-1

* UPDATE SECTOR POSITION.

 WRI40    BSS
          LDDL   WDS
          RADL   SECPOS      UPDATE SECTOR POSITION
          IFNE   SMALL,1
          ADC    -CMWDS      CHECK FOR END OF SECTOR
          ELSE
          SBML   CMWDS,SZ    CHECK FOR END OF SECTOR
          ENDIF
          NJN    WRI50       IF NOT END OF SECTOR
          STDL   SECPOS      RESET SECTOR POSITION = 0
 WRI50    BSS
          LDDL   SECPOS
          ZJN    WRI60       IF FULL SECTOR HAS BEEN TRANSFERRED FROM CM
          LDML   SS+/SS/P.LISTL  CHECK IF MORE CM ADDRESS-LENGTH-PAIRS
          SBN    1
          NJN    WRI120      IF MORE CM DATA TO TRANSFER
          LDN    0
          STDL   SECPOS      RESET SECTOR POSITION = 0

* TRANSFER DATA TO DISK.

 WRI60    BSS
          LDDL   MOVFC       SEND MOVE DATA FUNCTION
          RJM    FUNC
          RJM    ACN         ACN    DC
          IFNE   SMALL,1
          LDC    SECWDS      NUMBER OF WORDS IN SECTOR
          ELSE
          LDML   SECWDS,SZ   NUMBER OF WORDS IN SECTOR
          ENDIF
          RJM    OAMBF       OAM    BUFF,DC
          RJM    DCN         DISCONNECT CHANNEL
*         (NO RETURN IF ERROR).

          AODL   FRSTSC
          SBN    1
          ZJN    WRI120      IF FIRST SECTOR TRANSFERRED FOR
                             THIS WRITE SEQUENCE

* PREVIOUS SECTOR HAS BEEN TRANSFERRED WITHOUT ERROR.
* UPDATE COUNTERS AND POINTERS.

          RJM    RDWTOK      UPDATE COUNTERS FOR GOOD TRANSFER
 WRI120   BSS
          LDDL   WDS         CM WORDS TRANSFERRED
          SHN    3
          STDL   T1          BYTES TRANSFERRED
          RADL   WDSS        SAVE BYTES TRANSFERRED THIS SECTOR
          LDDL   T1
          RAML   CMLIST+/CM/P.RMA+1  UPDATE CM ADDRESS
          SHN    -16
          RAML   CMLIST+/CM/P.RMA
          LDML   CMLIST+/CM/P.LEN  UPDATE BYTES LEFT TO TRANSFER
          SBDL   T1
          STML   CMLIST+/CM/P.LEN
          NJN    WRI125      IF MORE WORDS LEFT TO TRANSFER TO THIS
                             CM ADDRESS
          SOML   SS+/SS/P.LISTL  DECREMENT ADDRESS-LENGTH-PAIR COUNT
          ZJN    WRI130      IF END OF RMA LIST
          RJM    GLIST       READ NEXT SECTION OF THE LIST WHICH POINTS
                             TO THE CM DATA AREA
 WRI125   BSS
          LDDL   SECPOS      CHECK IF PARTIAL SECTOR OF DATA
          NJK    WRI20       IF PARTIAL SECTOR OF DATA
          UJN    WRI150

* GET NEXT COMMAND.

 WRI130   BSS
          RJM    UNCMND      GET NEXT COMMAND
          NJN    WRI150      IF MORE COMMANDS
          LDDL   CSTREAM
          NJN    WRI160      CHECK IF MORE REQUESTS TO STREAM

* CHECK IF SWITCH TO NEXT REQUEST.

          LDML   SS+/SS/P.TOTAL  TOTAL SECTORS LEFT TO TRANSFER
          SBN    1
          ZJN    WRI150      IF END OF TRANSFER
          MJN    *
          RJM    CSWIT       CHECK IF SWITCH TO NEXT SECTOR
          NJN    WRI150      IF SWITCH TO NEXT REQUEST
          LDN    0           PARTIAL SECTOR WAS TRANSFERRED
                             AND NO MORE DATA
          STML   SS+/SS/P.TOTAL
          UJN    WRI160

* CHECK IF TIME TO SUSPEND OR TERMINATE.

 WRI150   BSS
          LDDL   CSTREAM
          NJN    WRI156
          LDDL   TWDS
          SBN    1
 WRI156   BSS
          NJK    WRI20       IF MORE TO TRANSFER

* IF NOT SUSPENDING THE TRANSFER, REREAD THE STREAM FLAG.

 WRI160   BSS
          LDN    0
          RJM    CKSTR       CHECK STREAM FLAG
          NJK    WRI156      IF MORE TO TRANSFER

* SUSPEND OR TERMINATE.

          RJM    RDWTOK      UPDATE COUNTERS FOR GOOD TRANSFER
          LDDL   SECPOS
          ZJK    WRIX
          RJM    HALT        SHOULD NEVER HAPPEN
*         (NO RETURN FROM HALT.)
          EJECT
** NAME-- RDWT
*
** PURPOSE-- SET UP FOR READ OR WRITE.
          SPACE  6
 RDWX     LJM    **
 RDWT     EQU    *-1
          LDN    0
          STDL   WDSS        BYTES TRANSFERRED IN SECTOR
          STDL   FRSTSC      FIRST SECTOR FLAG
          STDL   SECPOS      SET SECTOR POSITION = 0
          STDL   CSTREAM     CLEAR CONTINUE STREAMING FLAG
          LDML   SS+/SS/P.DV  GET DEVICE TYPE
          ERRNZ  -16+/SS/L.DV+/SS/N.DV
          LPK    /SS/M.DV
          STDL   DEVICE      DEVICE TYPE
          IFEQ   SMALL,1
          LDML   SS+/SS/P.SMALL  GET SMALL / LARGE SECTOR FLAG
          SHN    /SS/L.SMALL+/SS/N.SMALL+2
          ADN    1
          LPN    1
          STDL   SZ          = 1 IF LARGE SECTOR (1024 16-BIT WORDS),
                             = 0 IF SMALL SECTOR TRANSFER (256 16-BIT WORDS)
          ENDIF

* DON'T SUSPEND IF IN ERROR RECOVERY.
* THE REASON IS BECAUSE THE ADAPTER DOES NOT RECOVER A READ CHECKWORD
* ERROR IF IT IS THE LAST SECTOR BEFORE SUSPENDING.  AFTER RE-READING THE
* SECTOR, THE ADAPTER RETURNS A 5000(8) POLL STATUS WITH DETAILED STATUS
* WORD 3, BIT 0 SET, MEANING THAT THE DRIVER TOOK MORE THAN 50
* MICROSECONDS TO ISSUE THE POLL STATUS.

          LDML   SS+/SS/P.RECOV  DON'T SUSPEND IF IN ERROR RECOVERY
          NJN    RDW5        IF IN ERROR RECOVERY

          LDML   XFERSZ,DEVICE  SECTORS TO TRANSFER BEFORE SUSPENDING
          STDL   TWDS
          SBML   SS+/SS/P.TOTAL  TOTAL SECTORS LEFT TO TRANSFER
          MJN    RDW10       IF SUSPEND
 RDW5     BSS
          LDML   SS+/SS/P.TOTAL  TRANSFER REMAINING SECTORS AND
                             TERMINATE TRANSFER
          STDL   TWDS
          LDN    F.MOVDT     MOVE DATA FUNCTION (TERMINATE)
          UJN    RDW20

 RDW10    BSS
          LDN    F.MOVD      MOVE DATA FUNCTION (SUSPEND)
 RDW20    BSS
          STDL   MOVFC       FUNCTION CODE
          UJK    RDWX
          EJECT
** NAME-- RDWTOK
*
** PURPOSE-- UPDATE READ AND WRITE COUNTERS.
          SPACE  6
 RDWTX    LJM    **
 RDWTOK   EQU    *-1
          LDML   SS+/SS/P.TOTAL
          ZJN    RDWT5       IF STREAMING REQUESTS
          SOML   SS+/SS/P.TOTAL  DECREMENT SECTORS LEFT TO TRANSFER
 RDWT5    BSS
          LDDL   TWDS
          ZJN    RDWT7       IF STREAMING REQUESTS
          SODL   TWDS        DECREMENT SECTORS LEFT BEFORE SUSPENDING
                             OR TERMINATING
 RDWT7    BSS
          IFNE   SMALL,1
          LDN    SECSC       SECTOR INCREMENT
          ELSE
          LDML   SECSC,SZ    SECTOR INCREMENT
          ENDIF
          RAML   SS+/SS/P.CURSEC  INCREMENT SECTOR ADDRESS
          SBML   DVSEC,DEVICE  COMPARE WITH NUMBER OF SECTORS PER TRACK
          MJN    RDWT10      IF NOT END OF TRACK
          STML   SS+/SS/P.CURSEC  CURRENT SECTOR
          AOML   SS+/SS/P.CURTRK  INCREMENT TRACK ADDRESS
 RDWT10   BSS
          LDDL   WDSS
          RAML   RS+/RS/P.XFER+1  UPDATE BYTES TRANSFERRED IN RESPONSE STATUS
          SHN    -16
          RAML   RS+/RS/P.XFER
          LDN    0
          STDL   WDSS

* CHECK FOR STREAMING REQUEST.

          LDML   SS+/SS/P.SWFLG  WAS THIS THE FIRST SECTOR AFTER A
                             REQUEST SWITCH
          ZJK    RDWTX       IF NOT THE FIRST SECTOR AFTER A REQUEST SWITCH
          LDN    0
          STML   SS+/SS/P.SWFLG  CLEAR SWITCH FLAG
          RJM    SNDRSP      SEND RESPONSE TO CM
          LDML   SS+/SS/P.CURRQ  SAVE RMA OF PREVIOUS REQUEST
          STML   SS+/SS/P.PRERQ
          LDML   SS+/SS/P.CURRQ+1
          STML   SS+/SS/P.PRERQ+1
          LDML   SS+/SS/P.REQ  SAVE RMA OF CURRENT REQUEST
          STML   SS+/SS/P.CURRQ
          LDML   SS+/SS/P.REQ+1
          STML   SS+/SS/P.CURRQ+1
          UJK    RDWTX
          EJECT
** NAME-- CKSTR
*
** PURPOSE-- RE-READ THE REQUEST AND CHECK THE STREAM FLAG.
*
** ENTRY--A REGISTER = 0, TO RE-READ THE REQUEST AND CALL CSWIT.
*                    = 1, TO RE-READ THE REQUEST AND CHECK THE
*                         SWITCH FLAG, BUT NOT CALL CSWIT.
*                    = 2, DO NOT RE-READ THE REQUEST, BUT CALL
*                         CSWIT.
*
** EXIT-- A REGISTER = 0, IF NO MORE DATA.
*         A REGISTER NONZERO, IF MORE DATA TO TRANSFER.
          SPACE  6
 CKSTRX   LJM    **
 CKSTR    EQU    *-1
          STDL   T1          SAVE PARAMETER
          LDDL   MOVFC       CHECK IF SUSPEND
          SBN    F.MOVD
          ZJN    CKSTRX      IF SUSPEND
          LDML   SS+/SS/P.RECOV  DON'T STREAM IF IN ERROR RECOVERY
          ZJN    CKSTR10     IF NOT IN ERROR RECOVERY
          LDN    0           EXIT A REGISTER = 0
          UJK    CKSTRX

 CKSTR10  BSS
          LDDL   T1          GET PARAMETER
          SBN    2
          ZJN    CKSTR20     IF NOT TO RE-READ REQUEST
          LDN    2           RE-READ REQUEST
          STDL   WC
          LOADS  SS+/SS/P.REQ2  ADDRESS OF REQUEST
          ADN    2
          CRML   RQ+2*4,WC
          SBN    4
          CRML   RQ,WC
          LDDL   T1          GET PARAMETER
          SBN    1
          NJN    CKSTR20     IF CSWIT IS TO BE CALLED
          LDML   RQ+/RQ/P.SWIT  CHECK IF REQUEST SWITCH FLAG SET
          SHN    -16+/RQ/N.SWIT+/RQ/L.SWIT
          ERRNZ  -1+/RQ/N.SWIT+/RQ/L.SWIT
          UJN    CKSTR30

 CKSTR20  BSS
          AODL   CSTREAM     SET CONTINUE STREAMING FLAG
          RJM    CSWIT       CHECK IF SWITCH TO NEXT REQUEST
 CKSTR30  UJK    CKSTRX      EXIT, A REGISTER NONZERO IF SWITCH
                             FLAG IS SET
          EJECT
** NAME-- CSWIT
*
** PURPOSE-- CHECK IF A SWITCH SHOULD BE MADE TO THE NEXT
*            REQUEST DURING THE SECTOR GAP.
*            AND, IF SO, MAKE THE SWITCH TO THE NEXT REQUEST.
*
** EXIT-- A REGISTER = 0, IF NOT SWITCH.
*         A REGISTER NONZERO, IF SWITCH.
          SPACE  6
 CSWX     LJM    **
 CSWIT    EQU    *-1
          LDML   SS+/SS/P.NUMCM  CHECK IF MORE COMMANDS TO PROCESS
 S1       IFEQ   STREAM,1
          ZJN    CSW6        IF END OF COMMANDS
 S1       ENDIF
          LDN    0           EXIT A REGISTER = 0
          UJK    CSWX

 CSW6     BSS
          LDML   RQ+/RQ/P.SWIT  CHECK IF REQUEST SWITCH FLAG SET
          SHN    -16+/RQ/N.SWIT+/RQ/L.SWIT
          ERRNZ  -1+/RQ/N.SWIT+/RQ/L.SWIT
          STML   SS+/SS/P.SWFLG  SAVE SWITCH FLAG
          ZJK    CSWX        IF SWITCH FLAG IS NOT SET

* GET NEXT REQUEST.
* PREPARE SS ENTRY.

          LDML   RQ+/RQ/P.NEXT  PUT RMA OF NEXT REQUEST IN SS TABLE
          STML   SS+/SS/P.REQ
          LDML   RQ+/RQ/P.NEXT+1
          STML   SS+/SS/P.REQ+1
          LDML   RQ+/RQ/P.NEXTPV  PUT PVA OF NEXT REQUEST IN SS TABLE
          STML   SS+/SS/P.PVA
          LDML   RQ+/RQ/P.NEXTPV+1
          STML   SS+/SS/P.PVA+1
          LDML   RQ+/RQ/P.NEXTPV+2
          STML   SS+/SS/P.PVA+2
          RJM    UREQ        READ NEXT REQUEST INTO RQ
          LDML   RQ+/RQ/P.CYL
          SBML   SS+/SS/P.CYL  CYLINDER ADDRESS
          ZJN    CSW10       IF VALID CYLINDER ADDRESS
          RJM    HALT        INVALID CYLINDER ADDRESS
*         (NO RETURN FROM HALT.)

 CSW10    BSS
          LDML   SS+/SS/P.CURSEC  CURRENT SECTOR - 1
          IFNE   SMALL,1
          ADN    SECSC       ADD SECTOR INCREMENT
          ELSE
          ADML   SECSC,SZ    ADD SECTOR INCREMENT
          ENDIF
          SBML   RQ+/RQ/P.SECTOR  SECTOR OF NEXT REQUEST
          ZJN    CSW20       IF OK
          SBML   DVSEC,DEVICE  NUMBER OF SECTORS PER TRACK
          ZJN    CSW15       IF VALID SECTOR ADDRESS
          RJM    HALT        INVALID SECTOR ADDRESS
*         (NO RETURN FROM HALT.)

 CSW15    BSS
          LDN    1           ADD 1 TO TRACK ADDRESS
 CSW20    BSS
          ADML   SS+/SS/P.CURTRK  CURRENT TRACK
          SBML   RQ+/RQ/P.TRACK  TRACK ADDRESS OF NEXT REQUEST
          ZJN    CSW25       IF VALID TRACK ADDRESS
          RJM    HALT        INVALID TRACK ADDRESS
*         (NO RETURN FROM HALT.)

 CSW25    BSS
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
          LDML   SS+/SS/P.FNC
          ZJN    CSW30       IF READ, SEND RESPONSE OF COMPLETED REQUEST

* IF WRITE, DON'T SEND RESPONSES FOR COMPLETED REQUESTS.
* FOR WRITE ERROR RECOVERY, RESTART ALL REQUESTS.

          LDN    0
          STML   SS+/SS/P.SWFLG  CLEAR SWITCH FLAG
          AOML   SS+/SS/P.NCOMW  INCREMENT NUMBER OF COMPLETED WRITE REQUESTS
 CSW30    BSS
          LDN    1           EXIT A REGISTER NONZERO
          UJK    CSWX
          EJECT
          ERRPL  *-BUFF
          QUAL   *

          OVERLAY (RECOVER ERRORS),BUFF
          ROUTINE RECSO
          QUAL   RC
          EJECT
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                   .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SCLOCK   CON    0
          LDML   SCLOCK
          STML   /RES/SCLX+1


          QUAL   *
 SCL10    BSS
          QUAL   RC
          LDDL   CHLOCK
          ZJN    SCL20       IF CHANNEL LOCK IS NOT SET
 SCL14    BSS
          LDN    0           EXIT A REGISTER = 0
          UJK    /RES/SCLX

 SCL20    BSS
          LDDL   UNUML
          ZJK    SCL14       IF NO UNITS
          LDK    C.CHCNT
          STDL   CHLCNT      NUMBER OF REQUESTS TO PROCESS BEFORE
                             GIVING UP CHANNEL
          LDN    6           SET TIMEOUT DELAY TO 5 SECONDS ON S1
          STDL   P1
          STDL   P2
 SCL30    BSS
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    SCL40       IF LOCK WAS NOT SET
          AODL   CHLOCK      SET FLAG IF LOCK WAS SET
          UJK    SCL14       EXIT, LOCK WAS SET

 SCL40    BSS
          SODL   P1
          NJK    SCL30
          SODL   P2
          NJK    SCL30
          LDN    1           TIMEOUT ON TRYING TO GET CHANNEL LOCK
          UJK    /RES/SCLX   EXIT A REGISTER NONZERO
          EJECT

          QUAL   *
 ADPTR    BSS                CONTINUATION OF ADPTERR ROUTINE
          QUAL   RC

          LDML   SS+/SS/P.ADERR
          ADML   SS+/SS/P.PRELD  PRELOAD OF CONTROL MODULE
          NJN    ADPT5       IF PREVIOUS ADAPTER ERROR,
                             OR PRELOAD OF CONTROL MODULE,
                             CONTINUE IN RECOVERY
          LDN    0
          STML   SS+/SS/P.RECOV  START RECOVERY SEQUENCE FROM THE BEGINNING
          AOML   SS+/SS/P.ADERR  SET ADAPTER ERROR FLAG
 ADPT5    BSS

 ADPT10   BSS
          AODL   DTSTAT      MAKE SURE DETAILED STATUS IS READ
          RJM    DCN2        DISCONNECT THE CHANNEL
          RJM    CFM         CFM    **,DC   CLEAR CHANNEL ERROR (IF ANY)
          PSN
          LDML   SS+/SS/P.RECOV  INDEX TO ERROR RECOVERY PROCEDURE
          STDL   T1
          LDML   RPROC,T1    ERROR RECOVERY PROCEDURE
          STML   ADPT24
          LJM    **          EXECUTE NEXT STEP IN ERROR RECOVERY
 ADPT24   EQU    *-1
          SPACE  6
* RETRY THE REQUEST.

 ADPTA    BSS
          AOML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
          RJM    POLSTAT     GET DETAILED STATUS
 ADPT30   BSS
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
 ADPT35   BSS
          RJM    RCMRQ       RESTART THE REQUESTS
          LJM    MAINC
          SPACE  6
* LOAD THE ADAPTER.

 ADPTB    BSS
          AOML   SS+/SS/P.LAD  INCREMENT LOAD ADAPTER RETRY COUNTER
          SBN    CNTRY+1
          MJN    ADPT40      IF LOAD ADAPTER RETRY NOT EXHAUSTED
          RJM    OTERM       TURN OFF ALL UNITS ON THE CONTROLLER
*         (NO RETURN FROM OTERM).

 ADPT40   BSS
          RJM    LDCON       LOAD THE ADAPTER

* ADAPTER HAS BEEN SUCCESSFULLY LOADED.

          LDN    0
          STML   SS+/SS/P.LAD  ZERO OUT LOAD ADAPTER RETRY COUNTER
          LDML   IADL        CHECK IF INITIAL ADAPTER LOAD
          NJK    MAINC       IF INITIAL ADAPTER LOAD
          LDN    R25
          STML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
          UJN    ADPT30      RETRY THE REQUEST
          EJECT
          QUAL   *
 RECSA    BSS                CONTINUATION OF RECS ROUTINE
          QUAL   RC
          LDML   SS+/SS/P.RECOV
          NJN    REC5        IF ALREADY IN ERROR RECOVERY
          LDN    R20         RETRY THE REQUEST
          STML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
 REC5     BSS
          UJK    ADPT10      RETRY THE REQUEST
          SPACE  6
* EXECUTE CONTROL MODULE LEVEL II DIAGNOSTIC COMMAND 72, SUBTEST 5.

 RECA     BSS
          LDN    R40
          STML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
          RJM    POLSTAT     GET DETAILED STATUS
          RJM    RCMRQ       TERMINATE ACTIVE COMMANDS
          RJM    DIAGSUB     EXECUTE CM DIAGNOSTIC COMMAND 72, SUBTEST 5
 REC10    BSS
          LJM    MAINC
          SPACE  6
* CM DIAGNOSTIC COMMAND 72, SUBTEST 5, WAS SUCCESSFUL.

 RECB     BSS
          LDN    R30
          STML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
          UJK    ADPT30      RETRY THE REQUEST
          SPACE  6
* UNRECOVERED MEDIA ERROR.

 RECC     BSS
          LDML   RS+/RS/P.DETAIL+8
          SHN    -4          SYSTEM INTERVENTION STATUS
          ADC    -101B
          ZJN    REC20       IF MEDIA ERROR IN HEADER (READ OR WRITE)
          SBN    103B-101B
          NJN    REC30       IF NOT MEDIA ERROR ON DATA (READ)
 REC20    BSS
          LDK    /RS/K.DATERR  SOFTWARE FLAW THE ALLOCATION UNIT
          RJM    SERR        ERROR ID
          LDK    /RS/K.UNMED  UNRECOVERED MEDIA ERROR
          RJM    SERRID      ERROR ID

 RECI     BSS
          RJM    HTERM       UNRECOVERED ERROR
*         (NO RETURN FROM HTERM.)
          SPACE  6
 REC30    BSS
          LDN    R40         RELOAD CONTROL MODULE
          STML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
          SPACE  6
* RELOAD THE CONTROL MODULE.

 RECD     BSS
          AOML   SS+/SS/P.CMLD  INCREMENT LOAD CONTROL MODULE RETRY COUNTER
          SBN    COSTRY+1
          MJN    REC40       IF LOAD CM RETRY NOT EXHAUSTED
          RJM    OCTERM      TURN OFF ALL UNITS ON THE CONTROL MODULE
*         (NO RETURN FROM OCTERM.

 REC40    BSS
          RJM    POLSTAT     GET DETAILED STATUS
          RJM    LDCM        LOAD THE CONTROL MODULE
          LDML   SS+/SS/P.CMLD  CM LOAD RETRY COUNTER
          SBN    1
          NJN    REC45       IF NOT THE FIRST ATTEMPT
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
 REC45    BSS
          UJK    REC10
          SPACE  6
* CONTROL MODULE SUCCESSFULLY LOADED.

 RECE     BSS
          AOML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
 REC50    BSS
          UJK    ADPT30      RETRY THE REQUEST
          SPACE  6
* EXECUTE CONTROL MODULE LEVEL II DIAGNOSTICS.

 RECF     BSS
          AOML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
          RJM    POLSTAT     GET DETAILED STATUS
          RJM    RCMRQ       TERMINATE ACTIVE COMMANDS
          RJM    DIAG        EXECUTE CM LEVEL II DIAGNOSTICS
          UJK    REC45
          SPACE  6
* CM LEVEL II DIAGNOSTICS PASSED.

 RECG     BSS
          AOML   SS+/SS/P.RECOV  INDEX TO NEXT RECOVERY PROCEDURE
          UJK    REC50       RETRY THE REQUEST
          SPACE  6
* UNRECOVERED ERROR.  LEVEL II DIAGNOSTICS FAILED.

 RECH     BSS
          RJM    UTERM       UNRECOVERED ERROR, TURN OFF UNIT
*         (NO RETURN FROM UTERM.)
          EJECT
* SEQUENCE TO ERROR RECOVERY PROCEDURES.
          SPACE  6
 RPROC    BSS
          CON    ADPTA       RETRY THE REQUEST
 RP10     CON    ADPTB       LOAD THE ADAPTER
 RP20     CON    ADPTA       RETRY THE REQUEST
          CON    ADPTA       RETRY THE REQUEST
 RP25     CON    RECA        EXECUTE CM LEVEL II DIAGNOSTICS
 RP30     CON    RECC        UNRECOVERED MEDIA ERROR
 RP40     CON    RECD        LOAD THE CONTROL MODULE
          CON    RECF        EXECUTE LEVEL II DIAGNOSTIC COMMAND 70
          CON    RECH        UNRECOVERED ERROR, LEVEL II DIAGNOSTICS FAILED
          CON    RECI        UNRECOVERED ERROR, LEVEL II DIAGNOSTICS PASSED


 R10      EQU    RP10-RPROC
 R20      EQU    RP20-RPROC
 R25      EQU    RP25-RPROC
 R30      EQU    RP30-RPROC
 R40      EQU    RP40-RPROC
          EJECT
          QUAL   *
 NOTR     BSS                CONTINUATION OF NOTRDY ROUTINE
          QUAL   RC
          SODL   CMNDS       DECREMENT COUNT OF OUTSTANDING COMMANDS
          AOML   SS+/SS/P.NR  INCREMENT NOT READY FAILURE COUNTER
          SBN    NRTRY
          PJK    NOTR10      IF RETRY EXHAUSTED
          LDML   UNITS+/UN/P.BUSY,UX  CLEAR BUSY FLAG
          LPC    -/UN/K.BUSY
          STML   UNITS+/UN/P.BUSY,UX
          LDK    R.PUP       POWER UP SPINDLE
          STML   SS+/SS/P.FUNC  PARAMETER IN LOAD COMMAND BLOCK
          LDML   UNITS+/UN/P.UNIT,UX  UNIT NUMBER FOR LOAD COMMAND BLOCK
          STML   SS+/SS/P.UNIT
          LDN    0
          STML   SS+/SS/P.LENGTH  PARAMETER IN LOAD COMMAND BLOCK
          RJM    CMND        ISSUE LOAD COMMAND BLOCK
          LDML   UNITS+/UN/P.BUSY,UX  SET 'UNIT BUSY' FLAG
          LPC    -/UN/K.BUSY
          ADK    /UN/K.BUSY
          STML   UNITS+/UN/P.BUSY,UX
          LDK    /RS/K.PU    POWER UP SPINDLE
          RJM    SID         ERROR ID
          LDML   SS+/SS/P.NR
          SBN    1
          NJN    NOTR5       IF NOT FIRST ATTEMPT

* SEND AN INTERMEDIATE RESPONSE SO THAT AN MDD MESSAGE IS DISPLAYED.

          RJM    INTRS       SEND INTERMEDIATE RESPONSE
 NOTR5    BSS
          UJK    /RES/NOTRX

 NOTR10   BSS
          RJM    UTERM       UNRECOVERED ERROR, TURN OFF UNIT
*         NO RETURN FROM UTERM
          EJECT
** NAME-- RCMRQ
*
** PURPOSE-- RESTART ALL THE REQUESTS ON A CONTROL MODULE.
          SPACE  6
 RCMX     LJM    **
 RCMRQ    EQU    *-1
          LDDL   UNUML
          ZJK    RCMX        IF NO UNITS
          LDN    F.TERM      TERMINATE ACTIVE COMMANDS
          RJM    FUNC
          RJM    SAVSS       SAVE SS TABLE
          LDML   UNITS+/UN/P.CM,UX  GET CONTROL MODULE NUMBER
          SHN    -3
          STDL   CMOD        CONTROL MODULE NUMBER
          LDDL   UX          SAVE UX
          STML   SAVE
          LDN    0
          STDL   UX
          STDL   CMNDS       RECOMPUTE NUMBER OF OUTSTANDING COMMANDS
 RCM10    BSS
          LDML   UNITS+/UN/P.BUSY,UX  CHECK IF OUTSTANDING COMMAND
          SHN    /UN/L.BUSY+2
          PJN    RCM20       IF NOT AN OUTSTANDING COMMAND
          RJM    GETSS       GET SS ENTRY
          RJM    RSTRQ       RESTART REQUEST
 RCM20    BSS
          LDN    P.UN
          RADL   UX          BUMP UNIT ENTRY
          SBDL   UNUML
          MJN    RCM10       IF NOT END OF TABLE

* ZERO OUT CONTROL MODULE LOAD TABLE.

          LDN    CMNUM       NUMBER OF ENTRIES
          STDL   T1
 RCM30    BSS
          LDN    0
          STML   CMLOAD-1,T1  ZERO OUT CONTROL MODULE LOAD TABLE
          SODL   T1
          NJN    RCM30       IF NOT END OF TABLE
 RCM40    BSS
          LDML   SAVE        RESTORE UX
          STDL   UX
          RJM    GETSS       GET SS ENTRY
          UJK    RCMX
          EJECT
** NAME-- RSTRQ
*
** PURPOSE-- INCREMENT REQUEST RETRY COUNTER.  IF RETRIES HAVE
*            NOT BEEN EXHAUSTED, RESTART THE REQUEST.
          SPACE  6
 RSTX     LJM    **
 RSTRQ    EQU    *-1
          AOML   SS+/SS/P.RQTRY  INCREMENT REQUEST RETRY COUNTER
          LDML   SS+/SS/P.CONF  CHECK IF DOING INITIAL CONFIDENCE TEST
          SHN    /SS/L.CONF+2
          MJK    RST40       IF DOING INITIAL CONFIDENCE TEST

* RESTART REQUEST FROM BEGINNING.

          LDML   SS+/SS/P.CURRQ  RESTORE RMA OF CURRENT REQUEST
          STML   SS+/SS/P.REQ
          LDML   SS+/SS/P.CURRQ+1
          STML   SS+/SS/P.REQ+1
          LDML   RS+/RS/P.PVA  RESTORE PVA OF CURRENT REQUEST
          STML   SS+/SS/P.PVA
          LDML   RS+/RS/P.PVA+1
          STML   SS+/SS/P.PVA+1
          LDML   RS+/RS/P.PVA+2
          STML   SS+/SS/P.PVA+2
          RJM    UREQ        READ UNIT REQUEST
          LDML   RQ+/RQ/P.CYL  RESTORE CYLINDER ADDRESS
          STML   SS+/SS/P.CYL
          LDML   RQ+/RQ/P.TRACK  RESTORE TRACK ADDRESS
          SHN    /SS/N.SECTOR
          ADML   RQ+/RQ/P.SECTOR  RESTORE SECTOR ADDRESS
          STML   SS+/SS/P.SECTOR
 RST20    BSS
          LDML   UNITS+/UN/P.BUSY,UX  CLEAR BUSY FLAG
          LPC    -/UN/K.BUSY
          STML   UNITS+/UN/P.BUSY,UX
          RJM    DELCM       DELINK ANY COMPLETED REQUESTS
          RJM    CLRLOCK     CLEAR LOCK ON UNIT
          UJK    RSTX        RETURN A REGISTER = 0 TO RESTART REQUEST

* RESTART CONFIDENCE TEST.

 RST40    BSS
          LDDL   IALF        CLEAR FLAG FOR CONFIDENCE TEST STARTED
                             ON ALL CONTROLLERS
          LPC    -4
          STDL   IALF
          LDML   UNITS+/UN/P.CTST,UX  CLEAR FLAG FOR CONFIDENCE TEST STARTED
          LPC    -/UN/K.CTST
          STML   UNITS+/UN/P.CTST,UX
          UJK    RST20
          EJECT
** NAME-- DELCM.
*
** PURPOSE-- DELINK COMPLETED REQUESTS.
*            THIS IS CALLED ONLY ON ERRORS IN ORDER TO DELINK REQUESTS
*            WHICH HAVE STREAMED SUCCESSFULLY.
          SPACE  6
 DELCX    LJM    **
 DELCM    EQU    *-1
          LDN    0
          STML   SS+/SS/P.NCOMW  ZERO OUT NUMBER OF COMPLETED WRITE REQUESTS
          LDML   SS+/SS/P.NCOMRQ  NUMBER OF COMPLETED REQUESTS
          ZJN    DELCX       IF NO REQUESTS HAVE BEEN COMPLETED
          SOML   SS+/SS/P.NCOMRQ  DECREMENT COMPLETED REQUEST COUNT
          ZJN    DELCX      IF NOT STREAMING OF REQUESTS
          LDML   SS+/SS/P.PRERQ  SET UP RMA OF LAST GOOD COMPLETED REQUEST
          STML   SS+/SS/P.CURRQ
          LDML   SS+/SS/P.PRERQ+1
          STML   SS+/SS/P.CURRQ+1
          RJM    DELRQ       DELINK COMPLETED REQUESTS FROM QUEUE
                             AND SELECT NEW REQUEST
          UJK    DELCX
          EJECT
** NAME-- HTERM
*
** PURPOSE-- ABNORMAL TERMINATION FOR HARDWARE ERRORS.
          SPACE  6
          QUAL   *
 HTERM1   BSS
          QUAL   RC
          UJN    ATERM20
          EJECT
** NAME-- ATERM
*
** PURPOSE-- ABNORMAL TERMINATION FOR INTERFACE ERRORS.
          SPACE  6
          QUAL   *
 ATERMA   BSS
          QUAL   RC
          LDK    /RS/K.INTERR  INTERFACE ERROR
          RJM    SERR        SAVE ERROR ID

* CHECK FOR ERRORS WHICH RESULT IN SETTING THE UNIT DOWN,
* AND THEN, SET THE UNIT DISABLE FLAG.

 ATERM20  BSS
          LDML   SS+/SS/P.NR  NOT READY FAILURE COUNTER
          SBN    3
          PJN    ATERM50     IF UNRECOVERED -NOT READY-

* CHECK IF UNIT WRITE PROTECT SWITCH ON.

          LDML   RS+/RS/P.DETAIL+9
          LPC    377B
          ADC    -302B       WRITE PROTECTED
          NJN    ATERM80     IF NOT WRITE PROTECTED
          LDML   SS+/SS/P.FNC
          ZJN    ATERM80     IF NOT A WRITE FUNCTION

* SET UNIT DISABLE BIT.

 ATERM50  BSS
          RJM    UTERM       TURN OFF UNIT
*         (NO RETURN FROM UTERM).

 ATERM80  BSS
          LDK    C.RS*8
          STML   RS+/RS/P.RESPL  RESPONSE LENGTH
          LDML   RS+/RS/P.PVA
          ADML   RS+/RS/P.PVA+1
          ADML   RS+/RS/P.PVA+2
          NJN    ATERM90     IF UNRECOVERED REQUEST
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          LJM    TERM90

 ATERM90  BSS
          LDN    R.ABN       ABNORMAL TERMINATION
          STDL   RESPC       RESPONSE CODE

          LJM    /RES/TERM   SEND TERMINATION RESPONSE
          EJECT
          QUAL   *
 RECRS1   BSS
          QUAL   RC
          AOML   SS+/SS/P.RVCNT  COUNT OF RECOVERED ERRORS PER REQUEST
          SBN    RVTRY       HAS LIMIT BEEN REACHED
          PJK    /RES/RECRSX  IF TOO MANY RECOVERED ERRORS ON THIS REQUEST
          LDK    /RS/K.REC   RECOVERED ERROR
          STDL   RCON        ADDITIONAL RESPONSE CONDITION
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          UJK    /RES/RECRSX
          EJECT
** NAME-- INTRS
*
** PURPOSE-- SEND INTERMEDIATE RESPONSE.
          SPACE  6
 INTRSX   LJM    **
 INTRS    EQU    *-1
          LDML   RS+/RS/P.PVA  PVA OF REQUEST
          ADML   RS+/RS/P.PVA+1
          ADML   RS+/RS/P.PVA+2
          NJN    INTRS10     IF REQUEST EXISTS
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          UJK    INTRSX

 INTRS10  BSS
          LDK    C.RS*8      SET RESPONSE LENGTH FOR ERROR
          STML   RS+/RS/P.RESPL
          LDN    R.INT       INTERMEDIATE RESPONSE
          STDL   RESPC       RESPONSE CODE
          RJM    TERMP       SEND RESPONSE TO CM
          UJK    INTRSX
          EJECT
* SEND UNSOLICITED MESSAGE.
          SPACE  6
 SNMSGX   LJM    **
 SNMSG    EQU    *-1
          LDK    C.RS*8      SET RESPONSE LENGTH FOR ERROR
          STML   RS+/RS/P.RESPL
          LDN    0           UNSOLICITED MESSAGE
          STDL   RESPC       RESPONSE CODE
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          RJM    TERMP       SEND RESPONSE TO CM
          UJK    SNMSGX
          EJECT
          QUAL   *
 TERMER1  BSS
          QUAL   RC

* CHECK IF LOADING A CONTROL MODULE.

          LDML   CMLOAD,CMOD  CONTROL MODULE LOADING TABLE
          ZJN    TERM10      IF NOT LOADING THE CONTROL MODULE
          LDN    0
          STML   CMLOAD,CMOD  ZERO OUT CONTROL MODULE LOADING ENTRY
          STML   SS+/SS/P.CMLD  ZERO OUT CM LOAD RETRY COUNTER
          LDK    /RS/K.CMLDS  CONTROLWARE RELOAD SUCCESSFUL
          RJM    SID         ERROR ID
          LDML   SS+/SS/P.PRELD  CHECK IF PRELOAD OF CM
          ZJN    TERM5       IF IN ERROR RECOVERY
          LJM    TERM80

 TERM5    BSS
          LJM    RECE        CONTINUE IN ERROR RECOVERY

* CHECK IF POWER UP SPINDLE COMPLETED.

 TERM10   BSS
          LDML   SS+/SS/P.NR  CHECK IF NOT READY ERROR PROCESSING
          ZJN    TERM20      IF NOT -NOT READY-

* POWER UP SPINDLE COMPLETED NORMALLY.

          LDN    0
          STML   SS+/SS/P.NR  CLEAR NOT READY RECOVERY FLAG
          LDK    /RS/K.PUC   POWER UP SPINDLE COMPLETED
          RJM    SID         SAVE ERROR ID
          RJM    INTRS       SEND AN INTERMEDIATE RESPONSE
          RJM    RSTRQ       RESTART REQUEST
          UJK    MAINC

* CHECK IF CONTROL MODULE LEVEL II DIAGNOSTICS HAVE FINISHED.

 TERM20   BSS
          LDML   SS+/SS/P.DIAG
          ZJN    TERM30      IF NOT RUNNING LEVEL II DIAGNOSTICS
          LDN    0
          STML   SS+/SS/P.DIAG  CLEAR DIAGNOSTIC FLAG
          LDK    /RS/K.XDP   LEVEL II DIAGNOSTICS PASSED
          RJM    SID         ERROR ID
          RJM    INTRS       SEND AN INTERMEDIATE MESSAGE
          LJM    RECG        CONTINUE IN ERROR RECOVERY

* CHECK IF DIAGNOSTIC COMMAND 72, SUBTEST 5, FINISHED

 TERM30   BSS
          LDML   SS+/SS/P.DIAGS
          ZJN    TERM95      IF NOT RUNNING DIAGNOSTIC 72, SUBTEST 5
          LDN    0
          STML   SS+/SS/P.DIAGS  CLEAR DIAGNOSTIC FLAG
          LJM    RECB        CONTINUE IN ERROR RECOVERY

 TERM80   BSS
 TERM90   BSS
          RJM    CFLGS       CLEAR FLAGS
          RJM    CLRLOCK     CLEAR LOCK ON UNIT
 TERM95   BSS
          UJK    MAINB
          EJECT
** NAME-- LOAD
*
** PURPOSE-- LOAD CONTROLWARE INTO THE ADAPTER AND ALL THE CONTROL
*            MODULES.
          SPACE  6
 LOADX    LJM    **
          QUAL   *
 LOAD     EQU    *-1
          QUAL   RC
          LDDL   UNUML
          ZJK    LOADX       IF NO UNITS

* LOAD THE ADPTER.
* LOAD THE CONTROL MODULES.

          AOML   IADL        INITIAL LOAD ADAPTER FLAG
          LDN    0
          STDL   UX          UNIT INDEX
 LOAD10   BSS
          LDML   UNITS+/UN/P.CM,UX  GET CONTROL MODULE NUMBER
          SHN    -3
          STDL   CMOD        CONTROL MODULE NUMBER

* CHECK IF UNIT IS DISABLED.

          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ERRNZ  /UIT/C.DSABLE
          CRDL   T1          READ UNIT DISABLED FLAG
          LDDL   T1+/UIT/P.DSABLE  CHECK IF UNIT IS DISABLED
          SHN    /UIT/L.DSABLE+2
          MJK    LOAD40      IF UNIT IS DISABLED
          LDML   IADL        HAS ADAPTER CONTROLWARE BEEN LOADED
          ZJN    LOAD30      IF ADAPTER HAS BEEN LOADED

* LOAD THE ADAPTER ONLY IF THERE IS AN ENABLED UNIT.

 LOAD20   BSS
          RJM    STLOCK      SET UNIT LOCK
          NJN    LOAD20      IF LOCK COULD NOT BE SET
          LDN    R10
          STML   SS+/SS/P.RECOV  INDEX TO RECOVERY PROCEDURE
          RJM    LDCON       LOAD ADAPTER
          LDN    0
          STML   IADL        CLEAR INITIAL LOAD ADAPTER FLAG
          RJM    CLRLOCK     CLEAR UNIT LOCK

* LOAD THE CONTROL MODULE.

 LOAD30   BSS
          LDML   CMLOAD,CMOD
          NJN    LOAD40      IF THIS CM HAS BEEN LOADED
          RJM    STLOCK      SET UNIT LOCK
          NJN    LOAD40      IF LOCK COULD NOT BE SET
          LDN    R40         RELOAD CONTROL MODULE
          STML   SS+/SS/P.RECOV  INDEX TO RECOVERY PROCEDURE
          AOML   SS+/SS/P.PRELD  PRELOAD OF CONTROL MODULE FLAG
          AOML   SS+/SS/P.CMLD  CM LOAD RETRY COUNTER
          RJM    LDCM        LOAD CONTROL MODULE
 LOAD40   BSS
          LDN    P.UN
          RADL   UX          BUMP UNIT ENTRY
          SBDL   UNUML
          MJK    LOAD10      IF NOT END OF TABLE
          LDDL   IALF        SET FLAG FOR LOADING CONTROLWARE DONE ON
                             ALL CONTROLLERS
          LPC    -2
          ADN    2
          STDL   IALF
          LDN    0
          STML   IADL        CLEAR IN CASE ALL UNITS ARE DISABLED AND
                             ADAPTER LOAD WAS NOT DONE
          UJK    LOADX
          EJECT
** NAME-- LDCON
*
** PURPOSE-- LOAD CONTROLWARE IN ADAPTER IF COMMAND IS PRESENT.
          SPACE  6
 LDCX     LJM    **
 LDCON    EQU    *-1
          LDN    0
          STDL   LDCMF       LOAD ADAPTER
          LDN    1
          STDL   WC
 LDC20    BSS
          LOADC  CM.CB       CM ADDRESS OF COMMUNICATION BUFFER
          ADN    /CB/C.CONTRL  CM ADDRESS OF CONTROLWARE COMMAND
          CRML   CM,WC       READ COMMAND
          LDML   CM+/CM/P.CODE  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          ERRNZ  /CM/L.CODE
          SBN    C.LDCON
          NJN    LDC20       IF CONTROLWARE LOAD COMMAND NOT PRESENT YET
          LDK    /RS/K.CLOAD  SET -ATTEMPTED CONTROLWARE LOAD- FLAG
          RJM    SERRID      SAVE ERROR ID
          LDML   CM+/CM/P.LEN
          SHN    -3
          STML   SS+/SS/P.LISTL  LENGTH OF CM ADDRESS AREA (CM WORDS)
          RJM    GLIST       GET CM ADDRESS LIST OF DATA AREA
          RJM    LOADCON     LOAD CONTROLWARE
*         RETURN ONLY IF CONTROLWARE LOAD WAS SUCCESSFUL

          RJM    POLSTAT     GET POLL STATUS
          LDDL   PLSTAT      POLL STATUS
          ZJN    LDC30       IF NOT UNRECOVERED ERROR
          LDK    /RS/K.CF    POLL STATUS NONZERO AFTER SENDING CONTROLWARE
          RJM    SERRID      SAVE ERROR ID
          RJM    ADPTERR     RECOVER ERROR
*         (NO RETURN FROM ADPTERR.)

 LDC30    BSS
          RJM    SDELAY      SET ATTENTION DELAY
          UJK    LDCX
          SPACE  6
          EJECT
** NAME-- LDCM
*
** PURPOSE-- AUTOLOAD CONTROL MODULE.
          SPACE  6
 LDCMX    LJM    **
 LDCM     EQU    *-1
          LDDL   UX
          LMC    4000B
          STML   CMLOAD,CMOD  SET CONTROL MODULE LOADING ENTRY
          LDN    1
          STDL   WC
 LDCM10   BSS
          LOADC  CM.CB       CM ADDRESS OF COMMUNICATION BUFFER
          ADN    /CB/C.CMCTRL  CM ADDRESS OF CONTROL MODULE
                             AUTOLOAD COMMAND
          CRML   CM,WC       READ COMMAND
          LDML   CM+/CM/P.CODE  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          ERRNZ  /CM/L.CODE
          SBN    C.LDCM
          NJN    LDCM10      IF CONTROL MODULE AUTOLOAD COMMAND NOT PRESENT YET
          LDK    /RS/K.CMLD  SET -ATTEMPTED CONTROL MODULE LOAD- FLAG
                             IN RESPONSE
          RJM    SID         SAVE ERROR ID

* SEND LOAD COMMAND BLOCK TO AUTOLOAD THE CONTROL MODULE.

          LDK    R.LDCM      AUTOLOAD CONTROL MODULE
          STML   SS+/SS/P.FUNC  PARAMETER IN LOAD COMMAND BLOCK
          LDN    1
          STML   SS+/SS/P.LENGTH  SELECT LOADING THE CM FROM HOST
          LDML   SS+/SS/P.CMOD
          LPK    /SS/K.CMOD
          STML   SS+/SS/P.CMOD  SET UNIT NUMBER = 0
          RJM    CMND        LOAD COMMAND BLOCK
          UJK    LDCMX
          EJECT
* ENTRY WHEN FIRST PART OF LOAD CONTROL MODULE COMPLETES

          QUAL   *
 LDCMB1   BSS
          QUAL   RC

          AODL   LDCMF       SET LOAD CONTROL MODULE FLAG
          LDML   CM+/CM/P.LEN
          SHN    -3
          STML   SS+/SS/P.LISTL  LENGTH OF CM ADDRESS AREA (CM WORDS)
          RJM    GLIST       GET CM ADDRESS LIST OF DATA AREA
          RJM    LOADCON     LOAD CONTROLWARE

* RETURN ONLY IF CONTROLWARE LOAD WAS SUCCESSFUL.

          UJK    /RES/LDCMBX
          EJECT
** NAME-- LOADCON
*
** PURPOSE-- LOAD CONTROLWARE.
*
** INPUT-- LISTL = NUMBER OF ADDRESS-LENGTH-PAIR ENTRIES IN THE
*                    COMMAND WHICH ARE LEFT TO PROCESS.
*          CMLIST =  LIST OF ADDRESS-LENGTH-PAIRS POINTING TO THE
*                    CM DATA AREA.
          SPACE  6
 LOAX     LJM    **
 LOADCON  EQU    *-1
          LDML   CMLIST+/CM/P.LEN  CHECK FOR 0 WORDS OF CONTROLWARE
          NJN    LOA5        IF LENGTH .GT. 0
          LDC    E213        CONTROLWARE IS NOT PRESENT
          RJM    ATERM
*         (NO RETURN FROM ATERM.)

 LOA5     BSS
          LDDL   LDCMF       LOAD CONTROL MODULE FLAG
          ZJN    LOA10       IF NOT LOAD CONTROL MODULE
          LDK    F.LDCM      ISSUE LOAD CONTROL MODULE FUNCTION
          UJN    LOA12

 LOA10    BSS
          LDK    F.AUTOP     ISSUE LOAD CONTROLWARE FUNCTION
 LOA12    BSS
          RJM    FUNC        ISSUE THE FUNCTION
          RJM    ACN         ACN    DC

* SETUP NUMBER OF WORDS TO TRANSFER FROM THIS CM ADDRESS.

 LOA20    BSS
          LOADF  CMLIST+/CM/P.RMA  SET UP CM ADDRESS OF DATA AREA
          LDML   CMLIST+/CM/P.LEN  NUMBER OF 8-BIT BYTES TO TRANSFER
          ADN    7           ROUND UP
          SHN    -3          NUMBER OF CM WORDS TO TRANSFER
          STDL   TWDS        TOTAL NUMBER OF CM WORDS TO TRANSFER
                             FROM THIS ADDRESS
          ZJK    LOA70       IF NO WORDS TO TRANSFER FROM THIS ADDRESS
 LOA30    BSS
          STDL   WDS         COMPUTE NUMBER OF CM WORDS TO TRANSFER TO BUFFER
          ADC    -CTLN       MAXIMUM SIZE OF BUFFER IN PP
          MJN    LOA40       IF LESS THAN PP BUFFER
          LDK    CTLN
          STDL   WDS         NUMBER OF CM WORDS TO TRANSFER TO BUFFER

* TRANSFER DATA FROM CM.

 LOA40    BSS
          LDDL   CMADR+2     CM ADDRESS OF DATA AREA
          LMC    400000B
          CRML   CTBUF,WDS   READ CONTROLWARE BINARY FROM CM
          STDL   CMADR+2     UPDATE CM ADDRESS
          LDDL   WDS         NUMBER OF CM WORDS
          SHN    2
          STDL   T3          NUMBER OF 16-BIT PP WORDS
          LDDL   LDCMF       LOAD CONTROL MODULE FLAG
          NJN    LOA60       IF LOADING CONTROL MODULE

* CONVERT DATA TO ONE 8-BIT BYTE PER PP WORD.

          LDDL   WDS         NUMBER OF CM WORDS
          SHN    3
          STDL   T2          NUMBER OF 8-BIT BYTES
          STDL   T3
          SHN    -1          NUMBER OF 16-BIT PP WORDS
          ADC    CTBUF-1
          STDL   T1
 LOA50    BSS
          LDIL   T1          CONVERT DATA
          LPC    377B
          STML   CTBUF-1,T2
          LDIL   T1
          SHN    -8
          STML   CTBUF-2,T2
          SODL   T1
          SODL   T2
          SODL   T2
          NJK    LOA50       IF MORE DATA

* SEND DATA TO CONTROLLER.

 LOA60    BSS
          LDDL   T3
          RJM    OAMCT       OAM    CTBUF,DC    SEND DATA TO CONTROLLER
          NJN    LOA90       IF THE TRANSFER DID NOT COMPLETE
          LDDL   TWDS        UPDATE TOTAL WORDS LEFT TO TRANSFER
                               TO THIS CM ADDRESS.
          SBDL   WDS
          STDL   TWDS
          NJK    LOA30       IF MORE WORDS TO TRANSFER FROM THIS CM ADDRESS

* GET NEXT CM ADDRESS OF DATA AREA.

 LOA70    BSS
          SOML   SS+/SS/P.LISTL  DECREMENT ADDRESS-LENGTH-PAIR COUNT
          ZJN    LOA80       IF END OF ADDRESS-LENGTH-PAIRS IN COMMAND
          RJM    GLIST       READ NEXT SECTION OF THE LIST WHICH POINTS
                             TO THE CM DATA AREA
          UJK    LOA20

 LOA80    BSS
          LDC    250         SET TIMEOUT FOR 1 MILLISECOND ON S1
          STDL   T5
 LOA85    BSS
          RJM    EJM         EJM    LOA88,DC    IF CHANNEL IS EMPTY
          UJN    LOA88       IF CHANNEL IS EMPTY

          SODL   T5
          NJN    LOA85
          LDK    /RS/K.CEMPT  CHANNEL DOESNT GO EMPTY
          UJN    LOA95       TIMEOUT ON CHANNEL EMPTY

 LOA88    BSS
          RJM    DCN2        DISCONNECT THE CHANNEL
          UJK    LOAX

 LOA90    BSS
          STML   RS+/RS/P.FUNTO  NUMBER OF CHANNEL WORDS NOT TRANSFERRED
          LDK    /RS/K.IST   INCOMPLETE SECTOR TRANSFER
 LOA95    BSS
          RJM    SERRID      SAVE ERROR ID

* UNRECOVERED ERROR.

          RJM    ADPTERR      ABNORMAL TERMINATION
*         (NO RETURN FROM ADPTERR)

          EJECT
** NAME-- DIAG
*
** PURPOSE-- EXECUTE CONTROL MODULE LEVEL II DIAGNOSTICS.
          SPACE  6
 DIAGX    LJM    **
 DIAG     EQU    *-1
          AOML   SS+/SS/P.DIAG  SET FLAG WHEN RUNNING LEVEL II DIAGNOSTICS
          LDK    /RS/K.XD    SET -EXECUTING DIAGNOSTICS- IN RESPONSE
          RJM    SID         ERROR ID

* SEND LOAD COMMAND BLOCK TO RUN LEVEL II DIAGNOSTICS.

          LDN    0
          STML   SS+/SS/P.LENGTH  RUN ALL DIAGNOSTICS
          LDK    R.DIAG      RUN LEVEL II DIAGNOSTICS
          RJM    DIA         SEND LOAD COMMAND BLOCK
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          UJK    DIAGX
          EJECT
** NAME-- DIAGSUB
*
** PURPOSE-- EXECUTE CONTROL MODULE LEVEL II DIAGNOSTIC COMMAND 72,
*            SUBTEST 5.
          SPACE  6
 DIAGSX   LJM    **
 DIAGSUB  EQU    *-1
          AOML   SS+/SS/P.DIAGS  SET FLAG WHEN RUNNING DIAGNOSTIC 72, SUBTEST 5
          LDN    5           SUBTEST 5
          STML   SS+/SS/P.LENGTH  PARAMETER IN LOAD COMMAND BLOCK
          LDK    R.DIAGS     RUN DIAGNOSTIC COMMAND 72
          RJM    DIA         SEND LOAD COMMAND BLOCK
          UJK    DIAGSX
          EJECT
** NAME-- DIA
*
** PURPOSE-- USED BY DIAG AND DIAGSUB.
          SPACE  6
 DIAX     LJM    **
 DIA      EQU    *-1
          STML   SS+/SS/P.FUNC  PARAMETER IN LOAD COMMAND BLOCK
          LDML   UNITS+/UN/P.UNIT,UX  UNIT NUMBER FOR LOAD COMMAND BLOCK
          STML   SS+/SS/P.UNIT
          LDML   UNITS+/UN/P.BUSY,UX  CLEAR BUSY FLAG
          LPC    -/UN/K.BUSY
          STML   UNITS+/UN/P.BUSY,UX
          RJM    CMND        LOAD COMMAND BLOCK
          LDML   UNITS+/UN/P.BUSY,UX  SET 'UNIT BUSY' FLAG
          LPC    -/UN/K.BUSY
          ADK    /UN/K.BUSY
          STML   UNITS+/UN/P.BUSY,UX
          UJK    DIAX
          EJECT
** NAME-- SDELAY
*
** PURPOSE-- LOAD ATTENTION DELAY.
          SPACE  6
 SDEX     LJM    **
 SDELAY   EQU    *-1
          LDML   SS+/SS/P.DV  GET DEVICE TYPE
          ERRNZ  -16+/SS/L.DV+/SS/N.DV
          LPN    /SS/M.DV
          STDL   DEVICE
          LDML   DELV,DEVICE  DELAY VALUE
          STDL   P1
          LDN    F.DELAY     LOAD ATTENTION DELAY
          RJM    FUNC
          RJM    ACN         ACN    DC
          LDN    1
          RJM    OAMP1       OAM    P1,DC       SEND DELAY PARAMETER
          RJM    DCN         DISCONNECT CHANNEL
*         (NO RETURN IF ERROR).

          RJM    POLSTAT     GET POLL STATUS
          LDDL   PLSTAT
          ZJK    SDEX        IF NO ERROR
          LDK    /RS/K.DE    POLL STATUS NONZERO AFTER LOADING ATTENTION DELAY
          RJM    SERRID      SAVE ERROR ID
          RJM    ADPTERR     RECOVER ERROR
*         (NO RETURN FROM ADPTERR.)
          EJECT
** NAME-- STLOCK
*
** PURPOSE-- SETS THE UNIT LOCK IN THE UNIT INTERFACE TABLE.
*            SAME AS SETLOCK ROUTINE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SETLX    LJM    **
 STLOCK   EQU    *-1
 F1       IFEQ   SLOCK,0
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJK    SETLX       IF LOCK COULD NOT BE SET
 F1       ENDIF
          RJM    GETSS       READ SS ENTRY FROM UNIT COMMUNICATION BUFFER
          RJM    SCLOCK      SET CHANNEL LOCK
          UJK    SETLX
          EJECT
** NAME-- TERMP
*
** PURPOSE-- TERMINATE PP REQUEST.
*
** OUTPUT-- RS+/RS/P.RC = RESPONSE CODE
          SPACE  6
 TERX     LJM    **
 TERMP    EQU    *-1
          RJM    PUTRC       PUT RESPONSE CODES IN RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
*         LDN    0
*         STML   PPRQ        ZERO OUT PP REQUEST FLAG
          RJM    ZRESP       ZERO OUT RESPONSE BUFFER
          UJK    TERX
          EJECT
 R4       ERRPL  *-7761B     IF > 0, OVERLAY IS TOO LONG
          QUAL   *

          OVERLAY (DOWN UNIT),BUFF
          ROUTINE DOWNO




** NAME-- OCTERM
*
** PURPOSE-- TURN OFF ALL UNITS ON A CONTROL MODULE.
          SPACE  6
 OCTERM1  BSS
          QUAL   DN
          LDK    /RS/K.CMDN  CONTROL MODULE DOWN
          RJM    SID         ERROR ID
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    OFFUN       SET UNIT DISABLE FLAG
          RJM    OFFCM       TURN OFF ALL UNITS ON A CONTROL MODULE
          LJM    LTERM       LEAVE THE REQUEST ON THE UNIT QUEUE
          EJECT
** NAME-- OTERM
*
** PURPOSE-- TURN OFF ALL UNITS ON THE CONTROLLER.
*            DO NOT DELINK ANY REQUESTS.
          SPACE  6
          QUAL   *
 OTERM1   BSS
          QUAL   DN
          LDK    /RS/K.CHDN  CHANNEL DOWN
          RJM    SID         ERROR ID
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    OFFUN       SET UNIT DISABLE FLAG
          RJM    OFFCH       TURN OFF ALL UNITS ON CONTROLLER
          SPACE  6
* LEAVE THE REQUEST ON THE UNIT Q.
* SEND AN UNSOLICITED MESSAGE.

          QUAL   *
 LTERM1   BSS
          QUAL   DN
          RJM    DELCM       DELINK ANY COMPLETED REQUESTS
          LDN    0           UNSOLICITED MESSAGE
          STDL   RESPC       RESPONSE CODE
          AODL   NODEL       SET NO DELINK FLAG, SO REQUEST IS NOT DELINKED
          LDML   SS+/SS/P.CUR  CLEAR 'CURRENT REQUEST'
          LPC    -/SS/K.CUR
          STML   SS+/SS/P.CUR
          LJM    TERM        TERMINATE REQUEST
          EJECT
** NAME-- UTERM
*
** PURPOSE-- ABNORMAL TERMINATION FOR HARDWARE ERRORS.
*            TURN OFF THE UNIT.
          SPACE  6
          QUAL   *
 UTERM1   BSS
          QUAL   DN
          LDK    /RS/K.UDN   UNIT DOWN
          RJM    SID         ERROR ID
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    OFFUN       SET UNIT DISABLE FLAG
          UJK    LTERM       LEAVE THE REQUEST ON THE UNIT Q
          EJECT
** NAME-- DELCM.
*
** PURPOSE-- DELINK COMPLETED REQUESTS.
*            THIS IS CALLED ONLY ON ERRORS IN ORDER TO DELINK REQUESTS
*            WHICH HAVE STREAMED SUCCESSFULLY.
          SPACE  6
 DELCX    LJM    **
 DELCM    EQU    *-1
          LDN    0
          STML   SS+/SS/P.NCOMW  ZERO OUT NUMBER OF COMPLETED WRITE REQUESTS
          LDML   SS+/SS/P.NCOMRQ  NUMBER OF COMPLETED REQUESTS
          ZJN    DELCX       IF NO REQUESTS HAVE BEEN COMPLETED
          SOML   SS+/SS/P.NCOMRQ  DECREMENT COMPLETED REQUEST COUNT
          ZJN    DELCX      IF NOT STREAMING OF REQUESTS
          LDML   SS+/SS/P.PRERQ  SET UP RMA OF LAST GOOD COMPLETED REQUEST
          STML   SS+/SS/P.CURRQ
          LDML   SS+/SS/P.PRERQ+1
          STML   SS+/SS/P.CURRQ+1
          RJM    DELRQ       DELINK COMPLETED REQUESTS FROM QUEUE
                             AND SELECT NEW REQUEST
          UJK    DELCX
          EJECT
** NAME-- OFFCH
*
** PURPOSE-- TURN OFF ALL UNITS ON A CONTROLLER.
          SPACE  6
 OFCX     LJM    **
 OFFCH    EQU    *-1
          LDDL   UNUML
          ZJK    OFCX        IF NO UNITS
          RJM    SAVSS       SAVE SS ENTRY
          LDDL   UX          SAVE UX
          STDL   P6
          LDN    0
          STDL   CMNDS       SET OUTSTANDING ADAPTER COMMANDS = 0, SO
                             CHANNEL WILL NOT BE USED
          STDL   UX          UNITS TABLE INDEX
 OFC10    BSS
          RJM    OFF         SET UNIT DISABLE FLAG
          LDN    P.UN
          RADL   UX          BUMP UNITS TABLE INDEX
          SBDL   UNUML
          NJK    OFC10       IF NOT END OF TABLE
          LDDL   P6
          STDL   UX          RESTORE UX
          RJM    GETSS       RESTORE SS ENTRY
          UJK    OFCX
          EJECT
** NAME-- OFFCM
*
** PURPOSE-- TURN OFF ALL UNITS ON A CONTROL MODULE.
          SPACE  6
 OFFCMX   LJM    **
 OFFCM    EQU    *-1
          LDDL   UNUML
          ZJK    OFFCMX      IF NO UNITS
          RJM    SAVSS       SAVE SS ENTRY
          LDDL   UX          SAVE UX
          STDL   P6
          LDN    0
          STDL   UX          UNITS TABLE INDEX
 OFFCM10  BSS
          LDML   UNITS+/UN/P.UNIT,P6  COMPARE IF SAME CONTROL MODULE
          LMML   UNITS+/UN/P.UNIT,UX
          LPN    70B
          NJN    OFFCM20     IF NOT THE SAME CONTROL MODULE
          RJM    OFF         SET UNIT DISABLE FLAG
 OFFCM20  BSS
          LDN    P.UN
          RADL   UX          BUMP UNITS TABLE INDEX
          SBDL   UNUML
          NJK    OFFCM10     IF NOT END OF TABLE
          LDDL   P6
          STDL   UX          RESTORE UX
          RJM    GETSS       RESTORE SS ENTRY
          UJK    OFFCMX
          EJECT
** NAME-- OFF
*
** PURPOSE-- SET THE UNIT LOCK, SET THE UNIT DISABLE FLAG,
*            AND CLEAR IMPORTANT FLAGS.
          SPACE  6
 OFFX     LJM    **
 OFF      EQU    *-1
 OFF10    BSS
          LOADR  UNITS+/UN/P.UIT,UX  READ UNIT DISABLE FLAG
          CRDL   T1
          LDDL   T1+/UIT/P.DSABLE  CHECK IF UNIT IS DISABLED
          SHN    /UIT/L.DSABLE+2
          MJN    OFF40       IF UNIT IS ALREADY DISABLED
          RJM    STLOCK      SET THE UNIT LOCK
          NJN    OFF10       IF LOCK WAS NOT SET

 OFF20    BSS
          RJM    OFFUN       SET UNIT DISABLE FLAG
          LDML   SS+/SS/P.CUR  CLEAR 'CURRENT REQUEST'
          LPC    -/SS/K.CUR
          STML   SS+/SS/P.CUR
          RJM    ZRESP       ZERO OUT RESPONSE BUFFER
          RJM    CLRLOCK     CLEAR UNIT LOCK
 OFF40    BSS
          UJK    OFFX
          EJECT
** NAME-- OFFUN
*
** PURPOSE-- SET THE DISABLE FLAG ON THE UNIT INTERFACE TABLE.
*
** INPUT-- A & R REGISTERS = CM ADDRESS OF UNIT INTERFACE TABLE.
          SPACE  6
 OFUX     LJM    **
 OFFUN    EQU    *-1
          LOADR  UNITS+/UN/P.UIT,UX  LOAD ADDRESS OF UNIT INTERFACE TABLE
          ERRNZ  /UIT/C.DSABLE
          STDL   T1
          LDK    /UIT/K.DSABLE  SET UNIT DISABLE FLAG
          STDL   T3
          LDN    0
          STDL   T2
          STDL   T4
          STDL   T5
          LDDL   T1
          LMC    400000B
          RDSL   T2          -LOGICAL OR- THE UNIT DISABLE FLAG
          UJK    OFUX
          EJECT
** NAME-- ONUN
*
** PURPOSE-- CLEAR THE DISABLE FLAG IN THE UNIT INTERFACE TABLE.
          SPACE  6
          IFEQ   T1,0
 ONUNX    LJM    **
 ONUN     EQU    *-1
          LDK    -/UIT/K.DSABLE  CLEAR UNIT DISABLE FLAG
          STDL   T3
          LDC    177777B
          STDL   T2
          STDL   T4
          STDL   T5
          LOADF  CM+/CM/P.RMA  LOAD ADDRESS OF UNIT INTERFACE TABLE
          ERRNZ  /UIT/C.DSABLE
          RDCL   T2          -LOGICAL AND- TO CLEAR THE UNIT DISABLE FLAG
          UJK    ONUNX
          ENDIF
          EJECT
** NAME-- STLOCK
*
** PURPOSE-- SETS THE UNIT LOCK IN THE UNIT INTERFACE TABLE.
*            SAME AS SETLOCK ROUTINE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SETLX    LJM    **
 STLOCK   EQU    *-1
 F1       IFEQ   SLOCK,0
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJK    SETLX       IF LOCK COULD NOT BE SET
 F1       ENDIF
          RJM    GETSS       READ SS ENTRY FROM UNIT COMMUNICATION BUFFER
          RJM    SCLOCK      SET CHANNEL LOCK
          UJK    SETLX
          EJECT
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                   .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SCLX     LJM    **
 SCLOCK   EQU    *-1
          LDDL   CHLOCK
          ZJN    SCL20       IF CHANNEL LOCK IS NOT SET
 SCL14    BSS
          LDN    0           EXIT A REGISTER = 0
          UJK    SCLX

 SCL20    BSS
          LDDL   UNUML
          ZJK    SCL14       IF NO UNITS
          LDK    C.CHCNT
          STDL   CHLCNT      NUMBER OF REQUESTS TO PROCESS BEFORE
                             GIVING UP CHANNEL
          LDN    6           SET TIMEOUT DELAY TO 5 SECONDS ON S1
          STDL   P1
          STDL   P2
 SCL30    BSS
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    SCL40       IF LOCK WAS NOT SET
          AODL   CHLOCK      SET FLAG IF LOCK WAS SET
          UJK    SCL14       EXIT, LOCK WAS SET

 SCL40    BSS
          SODL   P1
          NJK    SCL30
          SODL   P2
          NJK    SCL30
          LDN    1           TIMEOUT ON TRYING TO GET CHANNEL LOCK
          UJK    SCLX        EXIT A REGISTER NONZERO
          EJECT
 R4       ERRPL  *-7761B     IF > 0, OVERLAY IS TOO LONG
          QUAL   *

          OVERLAY (PP REQUESTS),BUFF
          ROUTINE PPREQO


          QUAL   PR
          EJECT
          QUAL   *
 CKC1     BSS
          QUAL   PR
          RJM    CKCMND      CHECK IF OUTSTANDING COMMANDS
          LDDL   CMNDS
          NJN    CKC10       IF OUTSTANDING COMMANDS
          LDN    0
          STML   PIDLE       CLEAR PRE-IDLE FLAG
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          PAUSE  130000      DELAY 130 MILLISECONDS TO ALLOW
                             MAINTENANCE PP TO GET THE CHANNEL
          UJK    /RES/CKCX

* DON'T GIVE UP THE CHANNEL UNTIL ALL COMMANDS HAVE FINISHED.

 CKC10    BSS
          LDN    1
          STML   PIDLE       SET PRE-IDLE FLAG SO NO SEEKS WILL BE ISSUED
          UJK    /RES/CKCX
          EJECT
** NAME-- CKCMND
*
** PURPOSE-- COUNT THE NUMBER OF OUTSTANDING COMMANDS.
*
          SPACE  6
 CKCMX    LJM    **
 CKCMND   EQU    *-1

* FIND ALL UNITS IN WHICH A COMMAND WAS IN PROGRESS.

          LDN    0
          STDL   CMNDS       RESET OUTSTANDING ADAPTER COMMANDS
          STDL   T1
          LDDL   UNUML
          ZJK    CKCMX       IF NO UNITS
 CKCM10   BSS
          LDML   UNITS+/UN/P.BUSY,T1  CHECK IF OUTSTANDING COMMAND
          SHN    /UN/L.BUSY+2
          PJN    CKCM20      IF NO COMMAND IN PROGRESS
          AODL   CMNDS       NUMBER OF OUTSTANDING COMMANDS
 CKCM20   BSS
          LDN    P.UN
          RADL   T1          INCREMENT UNIT INDEX
          SBDL   UNUML       CHECK FOR END OF TABLE
          MJK    CKCM10      IF NOT END OF TABLE

* CHECK CONTROL MODULE LOAD TABLE.

          LDN    CMNUM       NUMBER OF ENTRIES
          STDL   T1
 CKCM30   BSS
          LDML   CMLOAD-1,T1  CHECK CONTROL MODULE LOAD TABLE
          ZJN    CKCM40      IF NOT LOADING CONTROL MODULE
          AODL   CMNDS       NUMBER OF OUTSTANDING COMMANDS
 CKCM40   BSS
          SODL   T1
          NJK    CKCM30      IF NOT END OF TABLE
          UJK    CKCMX
          EJECT
** NAME-- PPR
*
** PURPOSE-- CHECK FOR IDLE OR RESUME REQUESTS.
          SPACE  6
          QUAL   *
 PPR1     BSS
          QUAL   PR
          LDN    1
          STML   IGNORE      IGNORE ERRORS DURING IDLE PROCESSING
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          ERRNZ  /PIT/C.IDLE
          CRDL   T1          READ PP REQUEST FLAGS
          LDDL   T4
          SHN    /PIT/L.IDLE+2
          MJN    PPR20       IF IDLE REQUEST FLAG IS SET
          SHN    /PIT/L.RESUME-/PIT/L.IDLE
          PJK    PPR40       IF RESUME REQUEST FLAG IS NOT SET

* PROCESS RESUME REQUEST.

          LDDL   IDLE        IDLE FLAG
          ZJN    PPR10       IF ALREADY RESUMED
          RJM    ICOM        INITIALIZE UNIT TABLES
 PPR10    BSS
          RJM    RESUME      RESUME THE DRIVER
          LDK    -/PIT/K.RESUME-/PIT/K.IDSTAT-/PIT/K.LOCKF  FLAGS TO CLEAR
          STDL   T5
          LDN    0
          STDL   T6          FLAGS TO SET
          UJN    PPR30

* PROCESS IDLE REQUEST.

 PPR20    BSS
          LDML   RSP         PROCESSING RESPONSE FLAG
          ZJN    PPR22       IF NOT PROCESSING A RESPONSE
          AOML   DEBUG2      SET FOR DEBUG PURPOSES ONLY
          RJM    RCMRQ       RESTART THE REQUESTS
          LDN    0
          STML   RSP         CLEAR PROCESSING RESPONSE FLAG

 PPR22    BSS
          RJM    CKCMND      CHECK IF ANY OUTSTANDING COMMANDS
          LDDL   CMNDS
          ZJN    PPR25       IF NO OUTSTANDING COMMANDS
          LDN    1
          STML   PIDLE       SET PRE-IDLE FLAG
          UJK    PPR40

 PPR25    BSS
          RJM    CLRUT       CLEAR UNIT TABLES
          RJM    IDLEP       SOFTWARE IDLE THE DRIVER
          LDK    -/PIT/K.IDLE-/PIT/K.IDSTAT-/PIT/K.LOCKF  FLAGS TO CLEAR
          STDL   T5
          LDK    /PIT/K.IDSTAT  FLAGS TO SET
          STDL   T6
 PPR30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDK    /PIT/K.LOCKF
          STDL   T4
          LOADC  CM.PIT
          ERRNZ  /PIT/C.LOCKF
          RDSL   T1          TRY TO SET THE LOCK
          LDDL   T4
          LPK    /PIT/K.LOCKF
          NJK    PPR30       IF SOMEONE ELSE HAS THE LOCK
          LDDL   T4
          LPDL   T5          CLEAR FLAGS
          LMDL   T6          SET FLAGS
          STDL   T4
          LOADC  CM.PIT
          ERRNZ  /PIT/C.LOCKF
          CWDL   T1          WRITE THE NEW FLAGS
 PPR40    BSS
          LDN    0
          STML   IGNORE      ALLOW ERRORS TO BE PROCESSED
          UJK    MAIND
          EJECT
** NAME-- PPREQ
*
** PURPOSE-- CHECK FOR ANY PP REQUESTS ON THE PP QUEUE.
*
** EXIT-- A REGISTER = 0, IF NO PP REQUESTS.
*                    .NE. 0, IF A PP REQUEST WAS FOUND
          SPACE  6
 MM1      IFEQ   T1,0
          QUAL   *
 PPREQ1   BSS
          QUAL   PR

* SET PP QUEUE LOCKWORD.

          RJM    SPLOCK      SET PP QUEUE LOCKWORD
          ZJN    PPRQ20      IF LOCK WAS SET

 PPRQ15   BSS
          LDN    0
          UJK    /RES/PPRQX  EXIT, A REGISTER = 0

* GET THE RMA OF THE FIRST PP REQUEST IN THE CHAIN.

 PPRQ20   BSS
          LOADC  CM.PIT
          ADN    /PIT/C.PPQ
          CRDL   T5          READ RMA OF FIRST REQUEST IN CHAIN

* READ THE PP REQUEST.

          LOADF  T7          CM ADDRESS OF FIRST PP REQUEST
          ADN    /RQ/C.CMND
          CRDL   T1          READ COMMAND

* IF AN IDLE REQUEST, DON'T PROCESS IT UNTIL ALL OUTSTANDING CHANNEL
* COMMANDS HAVE BEEN PROCESSED.

          LDDL   T1+/CM/P.CODE  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          SBN    C.IDLE
          NJN    PPRQ30      IF NOT AN IDLE REQUEST
          RJM    CKCMND      CHECK IF ANY OUTSTANDING COMMANDS
          LDDL   CMNDS
          ZJN    PPRQ25      IF NO OUTSTANDING COMMANDS
          LDN    1
          STML   PIDLE       SET PRE-IDLE FLAG
          RJM    CPLOCK      CLEAR PP QUEUE LOCKWORD
          UJK    PPRQ15

 PPRQ25   BSS
          RJM    CLRUT       CLEAR UNIT TABLES
          UJN    PPRQ33


* IF AN RESUME REQUEST, INITIALIZE THE UNIT TABLES.

 PPRQ30   BSS
          SBN    C.RESUME-C.IDLE
          NJN    PPRQ33      IF NOT A RESUME REQUEST
          RJM    ICOM        INITIALIZE UNIT TABLES

* GET THE RMA OF THE FIRST PP REQUEST IN THE CHAIN.

 PPRQ33   BSS
          LDN    2
          STDL   WC
          LOADC  CM.PIT
          ADN    /PIT/C.PPQPVA
          CRML   T1,WC       READ PVA AND RMA OF FIRST REQUEST IN CHAIN

* PUT PVA AND RMA OF REQUEST IN SS TABLE.

          LDDL   T2          PUT PVA OF REQUEST IN SS TABLE
          STML   SS+/SS/P.PVA
          LDDL   T3
          STML   SS+/SS/P.PVA+1
          LDDL   T4
          STML   SS+/SS/P.PVA+2
          LDDL   T7          PUT RMA OF REQUEST IN SS TABLE
          STML   SS+/SS/P.REQ
          LDDL   T8
          STML   SS+/SS/P.REQ+1
          LDN    0
          STML   SS+/SS/P.FRST  SET FLAG WHEN REQUEST IS READ

* READ THE PP REQUEST.

          LDN    C.RQ
          STDL   P1
          LOADF  T7          CM ADDRESS OF FIRST PP REQUEST
          CRML   RQ,P1       READ PP REQUEST

* DELINK THE FIRST PP REQUEST FROM THE CHAIN.

          LOADC  CM.PIT
          ADN    /PIT/C.PPQPVA  CM ADDRESS OF PP QUEUE POINTER
          CWML   RQ,WC       WRITE PVA AND RMA POINTERS OF NEXT REQUEST

* CLEAR PP QUEUE LOCKWORD.

          RJM    CPLOCK      CLEAR PP QUEUE LOCKWORD

* DETERMINE NUMBER OF COMMANDS.

          LDML   RQ+/RQ/P.LEN  DETERMINE NUMBER OF COMMANDS
          SHN    -3
          SBN    /RQ/C.CMND
          STML   SS+/SS/P.NUMCM  NUMBER OF COMMANDS

          AODL   PPRQ        SET PP REQUEST FLAG


* PROCESS PP REQUEST.

          RJM    ZRESP       ZERO OUT RESPONSE BUFFER
          RJM    SRESP       SET UP RESPONSE BUFFER
 PPRQ35   RJM    UNCMND      GET PP COMMAND AND SET UP TO PROCESS
          ZJN    PPRQ50      IF NO MORE COMMANDS
          QUAL   *
 PPRQB1   BSS
          QUAL   PR
          LDML   UCMDPR,FNC  GET COMMAND PROCESSOR
          STML   PPRQ40
          RJM    **          PROCESS COMMAND
 PPRQ40   EQU    *-1
          LDDL   RESPC       CHECK FOR ABNORMAL RESPONSE CODE
          SBN    R.ABN
          NJK    PPRQ35      IF NO ERROR, LOOK FOR ANOTHER COMMAND

 PPRQ50   RJM    TERMP       SEND TERMINATION RESPONSE
          UJK    /RES/PPRQX  EXIT, A REGISTER NONZERO
 MM1      ENDIF
          EJECT
** NAME-- SPLOCK
*
** PURPOSE-- SETS THE PP REQUEST QUEUE LOCK IN THE
*            PP INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SPLX     LJM    **
 SPLOCK   EQU    *-1
          LDDL   UX          SAVE UX
          STML   SAVUX
          LDDL   SSUN        UX OF CURRENT SS TABLE
          STDL   UX
          RJM    SAVSS       SAVE SS TABLE
          LDML   SAVUX       RESTORE UX
          STDL   UX
          LDC    7777B
          STDL   SSUN        INVALIDATE SS TABLE
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET THE LOCKWORD
          NJK    SPLX        IF LOCK COULD NOT BE SET
          RJM    SCLOCK      SET CHANNEL LOCK
          UJK    SPLX
          EJECT
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                   .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SCLX     LJM    **
 SCLOCK   EQU    *-1
          LDDL   CHLOCK
          ZJN    SCL20       IF CHANNEL LOCK IS NOT SET
 SCL14    BSS
          LDN    0           EXIT A REGISTER = 0
          UJK    SCLX

 SCL20    BSS
          LDDL   UNUML
          ZJK    SCL14       IF NO UNITS
          LDK    C.CHCNT
          STDL   CHLCNT      NUMBER OF REQUESTS TO PROCESS BEFORE
                             GIVING UP CHANNEL
          LDN    6           SET TIMEOUT DELAY TO 5 SECONDS ON S1
          STDL   P1
          STDL   P2
 SCL30    BSS
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    SCL40       IF LOCK WAS NOT SET
          AODL   CHLOCK      SET FLAG IF LOCK WAS SET
          UJK    SCL14       EXIT, LOCK WAS SET

 SCL40    BSS
          SODL   P1
          NJK    SCL30
          SODL   P2
          NJK    SCL30
          LDN    1           TIMEOUT ON TRYING TO GET CHANNEL LOCK
          UJK    SCLX        EXIT A REGISTER NONZERO
          EJECT
** NAME-- CPLOCK
*
** PURPOSE-- CLEARS THE PP QUEUE LOCK IN THE PP INTERFACE TABLE.
*
          SPACE  6
 CPLX     LJM    **
 CPLOCK   EQU    *-1
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWROD
          UJK    CPLX
          EJECT
** NAME-- CCLOCK
*
** PURPOSE-- CLEARS CHANNEL LOCK.
*
          SPACE  6
 CCLX     LJM    **
 CCLOCK   EQU    *-1
          LDDL   CHLOCK
          ZJK    CCLX        IF CHANNEL LOCK WAS NOT SET
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CHAN        CHANNEL NUMBER = OFFSET IN TABLE
          STDL   T5
          RJM    CLOCK       CLEAR CHANNEL LOCKWORD
          LDN    0
          STDL   CHLOCK      CLEAR CHANNEL LOCK FLAG
          UJK    CCLX
          EJECT
** NAME-- IDLEP
*
** PURPOSE-- PROCESS IDLE COMMAND.
          SPACE  6
 IDLX     LJM    **
          QUAL   *
 IDLEP    EQU    *-1
          QUAL   PR
          AODL   IDLE        SET IDLE FLAG
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          UJK    IDLX
          EJECT
** NAME-- RESUME
*
** PURPOSE-- PROCESS RESUME COMMAND.
          SPACE  6
 RESX     LJM    **
          QUAL   *
 RESUME   EQU    *-1
          QUAL   PR
          LDN    0
          STDL   IDLE        CLEAR IDLE FLAG
          STML   PIDLE       CLEAR PRE-IDLE FLAG
          UJK    RESX
          EJECT
** NAME-- STOP
*
** PURPOSE-- SET THE UNIT DISABLE FLAG IN THE UNIT INTERFACE TABLE.
          SPACE  6
          IFEQ   T1,0
 STOPX    LJM    **
 STOP     EQU    *-1
          LOADF  CM+/CM/P.RMA  LOAD ADDRESS OF UNIT INTERFACE TABLE
          RJM    OFFUN       SET UNIT DISABLE
          UJK    STOPX
          ENDIF
          EJECT
** NAME-- CLRUT
*
** PURPOSE-- CLEAR UNIT TABLES.
          SPACE  6
 CLRUX    LJM    **
 CLRUT    EQU    *-1
          LDN    0
          STDL   CMNDS       SET OUTSTANDING ADAPTER COMMANDS = 0, SO
                             CHANNEL WILL NOT BE USED
          STDL   IALF        CLEAR INITIALIZE FLAG SO EVERYTHING
                             WILL GET INITIALIZED
          STDL   UX          UNITS TABLE INDEX
          LDDL   UNUML
          ZJK    CLRUX       IF NO UNITS
 CLRU10   BSS
          LDML   UNITS+/UN/P.CTST,UX  CLEAR FLAG THAT CONFIDENCE TEST WAS RUN
          LPC    -/UN/K.CTST
          STML   UNITS+/UN/P.CTST,UX
          RJM    STLOCK      SET THE UNIT LOCK
          NJN    CLRU20      IF THE LOCK COULD NOT BE SET
          LDML   SS+/SS/P.CUR  CLEAR 'CURRENT REQUEST'
          LPC    -/SS/K.CUR-/SS/K.INIT
          STML   SS+/SS/P.CUR
          ERRNZ  /SS/P.CUR-/SS/P.INIT
          RJM    CFLGS       CLEAR FLAGS
          RJM    CLRLOCK     CLEAR THE UNIT LOCK
 CLRU20   BSS
          LDN    P.UN
          RADL   UX          BUMP UNITS TABLE INDEX
          SBDL   UNUML
          NJK    CLRU10      IF NOT END OF TABLE
          UJK    CLRUX
          EJECT
** NAME-- RCMRQ
*
** PURPOSE-- RESTART ALL THE REQUESTS ON A CONTROL MODULE.
          SPACE  6
 RCMX     LJM    **
 RCMRQ    EQU    *-1
          LDDL   UNUML
          ZJK    RCMX        IF NO UNITS
          LDN    F.TERM      TERMINATE ACTIVE COMMANDS
          RJM    FUNC
          RJM    SAVSS       SAVE SS TABLE
          LDML   UNITS+/UN/P.CM,UX  GET CONTROL MODULE NUMBER
          SHN    -3
          STDL   CMOD        CONTROL MODULE NUMBER
          LDDL   UX          SAVE UX
          STML   SAVE
          LDN    0
          STDL   UX
          STDL   CMNDS       RECOMPUTE NUMBER OF OUTSTANDING COMMANDS
 RCM10    BSS
          LDML   UNITS+/UN/P.BUSY,UX  CHECK IF OUTSTANDING COMMAND
          SHN    /UN/L.BUSY+2
          PJN    RCM20       IF NOT AN OUTSTANDING COMMAND
          RJM    GETSS       GET SS ENTRY
          RJM    RSTRQ       RESTART REQUEST
 RCM20    BSS
          LDN    P.UN
          RADL   UX          BUMP UNIT ENTRY
          SBDL   UNUML
          MJN    RCM10       IF NOT END OF TABLE

* ZERO OUT CONTROL MODULE LOAD TABLE.

          LDN    CMNUM       NUMBER OF ENTRIES
          STDL   T1
 RCM30    BSS
          LDN    0
          STML   CMLOAD-1,T1  ZERO OUT CONTROL MODULE LOAD TABLE
          SODL   T1
          NJN    RCM30       IF NOT END OF TABLE
 RCM40    BSS
          LDML   SAVE        RESTORE UX
          STDL   UX
          RJM    GETSS       GET SS ENTRY
          UJK    RCMX
          EJECT
** NAME-- RSTRQ
*
** PURPOSE-- INCREMENT REQUEST RETRY COUNTER.  IF RETRIES HAVE
*            NOT BEEN EXHAUSTED, RESTART THE REQUEST.
          SPACE  6
 RSTX     LJM    **
 RSTRQ    EQU    *-1
          AOML   SS+/SS/P.RQTRY  INCREMENT REQUEST RETRY COUNTER
          LDML   SS+/SS/P.CONF  CHECK IF DOING INITIAL CONFIDENCE TEST
          SHN    /SS/L.CONF+2
          MJK    RST40       IF DOING INITIAL CONFIDENCE TEST

* RESTART REQUEST FROM BEGINNING.

          LDML   SS+/SS/P.CURRQ  RESTORE RMA OF CURRENT REQUEST
          STML   SS+/SS/P.REQ
          LDML   SS+/SS/P.CURRQ+1
          STML   SS+/SS/P.REQ+1
          LDML   RS+/RS/P.PVA  RESTORE PVA OF CURRENT REQUEST
          STML   SS+/SS/P.PVA
          LDML   RS+/RS/P.PVA+1
          STML   SS+/SS/P.PVA+1
          LDML   RS+/RS/P.PVA+2
          STML   SS+/SS/P.PVA+2
          RJM    UREQ        READ UNIT REQUEST
          LDML   RQ+/RQ/P.CYL  RESTORE CYLINDER ADDRESS
          STML   SS+/SS/P.CYL
          LDML   RQ+/RQ/P.TRACK  RESTORE TRACK ADDRESS
          SHN    /SS/N.SECTOR
          ADML   RQ+/RQ/P.SECTOR  RESTORE SECTOR ADDRESS
          STML   SS+/SS/P.SECTOR
 RST20    BSS
          LDML   UNITS+/UN/P.BUSY,UX  CLEAR BUSY FLAG
          LPC    -/UN/K.BUSY
          STML   UNITS+/UN/P.BUSY,UX
          RJM    DELCM       DELINK ANY COMPLETED REQUESTS
          RJM    CLRLOCK     CLEAR LOCK ON UNIT
          UJK    RSTX        RETURN A REGISTER = 0 TO RESTART REQUEST

* RESTART CONFIDENCE TEST.

 RST40    BSS
          LDDL   IALF        CLEAR FLAG FOR CONFIDENCE TEST STARTED
                             ON ALL CONTROLLERS
          LPC    -4
          STDL   IALF
          LDML   UNITS+/UN/P.CTST,UX  CLEAR FLAG FOR CONFIDENCE TEST STARTED
          LPC    -/UN/K.CTST
          STML   UNITS+/UN/P.CTST,UX
          UJK    RST20
          EJECT
** NAME-- DELCM.
*
** PURPOSE-- DELINK COMPLETED REQUESTS.
*            THIS IS CALLED ONLY ON ERRORS IN ORDER TO DELINK REQUESTS
*            WHICH HAVE STREAMED SUCCESSFULLY.
          SPACE  6
 DELCX    LJM    **
 DELCM    EQU    *-1
          LDN    0
          STML   SS+/SS/P.NCOMW  ZERO OUT NUMBER OF COMPLETED WRITE REQUESTS
          LDML   SS+/SS/P.NCOMRQ  NUMBER OF COMPLETED REQUESTS
          ZJN    DELCX       IF NO REQUESTS HAVE BEEN COMPLETED
          SOML   SS+/SS/P.NCOMRQ  DECREMENT COMPLETED REQUEST COUNT
          ZJN    DELCX      IF NOT STREAMING OF REQUESTS
          LDML   SS+/SS/P.PRERQ  SET UP RMA OF LAST GOOD COMPLETED REQUEST
          STML   SS+/SS/P.CURRQ
          LDML   SS+/SS/P.PRERQ+1
          STML   SS+/SS/P.CURRQ+1
          RJM    DELRQ       DELINK COMPLETED REQUESTS FROM QUEUE
                             AND SELECT NEW REQUEST
          UJK    DELCX
          EJECT
 UBUF     BSSZ   C.UIT*4     UNIT INTERFACE TABLE BUFFER

 IBUF     BSSZ   C.UD*4      UNIT DESCRIPTOR BUFFER

          EJECT
** NAME-- ICOM
*
** PURPOSE-- INITIALIZE THE UNIT COMMUNICATION BUFFER IN ALL THE UNIT
*            INTERFACE TABLES.
*            INITIALIZE ALL STATIC VARIABLES IN THE COMMUNICATION
*            BUFFER:  DEVICE TYPE, CHANNEL NUMBER, SEEK FUNCTION,
*            UNIT NUMBER, COMMUNICATION BUFFER (RMA), UNIT INTERFACE
*            TABLE (RMA).
          SPACE  6
 ICOMX    LJM    **
          QUAL   *
 ICOM     EQU    *-1
          QUAL   PR

* INITILIZE VARIABLES.

          LDN    0
          STDL   LUX         LAST UNIT SELECTED
          LDC    7777B
          STDL   SSUN        INVALIDATE SS TABLE

          LDDL   UDL         LENGTH OF UNIT DESCRIPTORS (CM WORDS)
          ZJN    ICOMX       IF NO UNIT DESCRIPTORS

* ZERO OUT UNITS TABLE.

          LDK    UNUM*P.UN
          STDL   T1
 ICOM5    BSS
          LDN    0
          STML   UNITS-1,T1  ZERO OUT UNITS TABLE
          SODL   T1
          NJN    ICOM5

* ZERO OUT CONTROL MODULE LOAD TABLE.

          LDN    CMNUM       NUMBER OF ENTRIES
          STDL   T1
 ICOM8    BSS
          LDN    0
          STML   CMLOAD-1,T1  ZERO OUT CONTROL MODULE LOAD TABLE
          SODL   T1
          NJN    ICOM8       IF NOT END OF TABLE

          LDN    0
          STDL   P5          NUMBER OF CONFIGURED UNITS
          STDL   P6          INDEX TO UNIT DESCRIPTORS
          STDL   UX          CONFIGURED UNIT TABLE INDEX
 ICOM10   BSS
          LDDL   CM.PIT+2    CM ADDRESS OFFSET OF UNIT DESCRIPTORS
          ADN    C.PIT
          ADDL   P6
          STDL   CMADR+2
          LDN    C.UD        READ 2 CM WORDS
          STDL   WC
          LOADC  CM.PIT,CMADR+2
          CRML   IBUF,WC     READ UNIT DESCRIPTOR
          IFEQ   VALID,1
          RJM    CHKUD       CHECK FOR VALID UNIT DESCRIPTOR
          ENDIF

* CHECK FOR NULL ENTRY.

          LDML   IBUF+/UD/P.UQT  RMA = 0 IF NULL ENTRY
          ADML   IBUF+/UD/P.UQT+1
          ZJK    ICOM85      IF NULL ENTRY

* ZERO OUT SS ENTRY.
* DONT ZERO OUT REQUEST OR RESPONSE BUFFER.

          LDK    /SS/P.RQ
          STDL   T1
 ICOM20   BSS
          LDN    0
          STML   SS-1,T1     ZERO OUT SS ENTRY
          SODL   T1
          NJN    ICOM20
          LOADF  IBUF+/UD/P.UQT  REFORMAT RMA ADDRESS OF UNIT QUEUE TABLE
          STML   UNITS+/UN/P.UIT+2,UX
          LDDL   CMADR
          STML   UNITS+/UN/P.UIT,UX
          LDDL   CMADR+1
          STML   UNITS+/UN/P.UIT+1,UX

* READ UNIT INTERFACE TABLE.

          LDN    C.UIT
          STDL   WC
          LDDL   CMADR+2     LOAD ADDRESS OF UNIT INTERFACE TABLE
          LMC    400000B
          CRML   UBUF,WC     READ UNIT INTERFACE TABLE
          LDML   UBUF+/UIT/P.DSABLE  CHECK IF UNIT IS DISABLED
          SHN    2+/UIT/L.DSABLE
          MJK    ICOM85      IF UNIT IS DISABLED
          IFEQ   VALID,1
          RJM    CHKUIT      CHECK FOR VALID UNIT INTERFACE TABLE
          ENDIF

* GET DEVICE TYPE AND TRANSLATE TO INTERNAL DEVICE TYPE.

          LDML   UBUF+/UIT/P.UTYPE  CHECK DEVICE TYPE
          ADC    -403B       CHECK FOR ISD-1
          NJN    ICOM30      IF NOT ISD-1
          LDN    DTISD1
          UJN    ICOM60

 ICOM30   BSS
          SBN    404B-403B   CHECK FOR ISD-2
          ZJN    ICOM50      IF  ISD-2
          RJM    HALT        INVALID DEVICE TYPE
*         (NO RETURN FROM HALT.)

 ICOM50   BSS
          LDN    DTISD2
 ICOM60   BSS
          ERRNZ  16-/SS/L.DV-/SS/N.DV
          RAML   SS+/SS/P.DV

* GET CHANNEL NUMBER AND MOVE TO SS ENTRY.

          LDML   IBUF+/UD/P.CHAN
          SHN    /UD/L.CHAN+/UD/N.CHAN+2
          LPN    /SS/M.CHAN
          STDL   CHAN        CHANNEL NUMBER
          STML   RS+/RS/P.CHAN
          SHN    16-/SS/L.CHAN-/SS/N.CHAN
          RAML   SS+/SS/P.CHAN

* PUT PHYSICAL UNIT NUMBER IN SEEK FUNCTION.

          LDML   IBUF+/UD/P.UNIT
          ERRNZ  /UD/L.UNIT
          ERRNZ  /UD/N.UNIT-16
          LPN    /SS/M.UNIT
          ERRNZ  16-/SS/L.UNIT-/SS/N.UNIT
          RAML   SS+/SS/P.UNIT  UNIT AND CONTROL MODULE
          LDML   IBUF+/UD/P.CNTRLR
          LPN    77B
          SHN    3
          RAML   SS+/SS/P.UNIT
          STML   UNITS+/UN/P.UNIT,UX
          STML   RS+/RS/P.UNIT
          LDML   IBUF+/UD/P.LU  PUT LOGICAL UNIT IN RESPONSE BUFFER
          STML   RS+/RS/P.LU

* REFORMAT COMMUNICATION BUFFER RMA.

          LOADF  UBUF+/UIT/P.UBUF  COMMUNICATION BUFFER RMA
          STML   UNITS+/UN/P.CB+2,UX
          LDDL   CMADR
          STML   UNITS+/UN/P.CB,UX
          LDDL   CMADR+1
          STML   UNITS+/UN/P.CB+1,UX

* CHECK THAT COMMUNICATION BUFFER IS LONG ENOUGH.

          LDML   UBUF+/UIT/P.UBUFL  NUMBER OF 8-BIT BYTES IN COMMUNICATION BUFFER
          SHN    -3          NUMBER OF CM WORDS
          SBN    C.SS        MUST BE LARGER THAN SS ENTRY
          PJN    ICOM70      IF COMMUNICATION BUFFER IS LARGE ENOUGH
                             ERROR - COMMUNICATION BUFFER TOO SMALL
          LDC    E308
          RJM    INTERR      SEND ERROR TO CM
*         (NO RETURN FROM INTERR)


* SAVE SS ENTRY IN COMMUNICATION BUFFER.

 ICOM70   BSS
          LDN    C.SS
          STDL   WC
          LOADR  UNITS+/UN/P.CB,UX  LOAD ADDRESS OF COMMUNICATION BUFFER
          STDL   T1
          CRDL   T2          READ SS ENTRY
          LDDL   T2
          SHN    /SS/L.INIT+2
          MJN    ICOM80      IF SS ENTRY ALREADY INITIALIZED
          LDK    /SS/K.INIT
          RAML   SS+/SS/P.INIT  SET SS ENTRY INITIALIZED FLAG
          LDDL   T1
          LMC    400000B
          CWML   SS,WC       WRITE SS ENTRY TO COMMUNICATION BUFFER

* BUMP TO NEXT ENTRY.

 ICOM80   BSS
          AODL   P5          NUMBER OF CONFIGURED UNITS
          LDN    P.UN
          RADL   UX          BUMP CONFIGURED UNIT ENTRY
 ICOM85   BSS
          LDN    C.UD
          RADL   P6          BUMP TO NEXT UNIT DESCRIPTOR ENTRY
          SBDL   UDL         CHECK FOR END OF UNIT DESCRIPTORS
          NJK    ICOM10      IF MORE UNIT DESCRIPTORS
          LDDL   UX
          STDL   UNUML       END OF ACTIVE UNIT TABLE
          LDN    0
          STDL   UX          INITIALIZE INDEX

* SET COMMAND TIMEOUT VALUES BASED UPON THE NUMBER OF
* CONFIGURED UNITS.

          LDML   S2-1,P5     SET TIMEOUT FOR 2 SECONDS
          STML   SC2
          LDML   S60-1,P5    SET TIMEOUT FOR 60 SECONDS
          STML   SC60
          LDML   S185-1,P5   SET TIMEOUT FOR 185 SECONDS
          STML   SC185
          RJM    CHGCH       CHANGE CHANNEL REFERENCES
          UJK    ICOMX       EXIT
          EJECT
 S2       BSS                TABLE FOR 2 SECOND TIMEOUT VALUES
          CON    19231       1 UNIT
          CON    13514       2 UNITS
          CON    10417       3 UNITS
          CON    8475        4 UNITS
          CON    7143        5 UNITS
          CON    6173        6 UNITS
          CON    5435        7 UNITS
          CON    4855        8 UNITS

 S60      BSS                TABLE FOR 60 SECOND TIMEOUT VALUES
          CON    9           1 UNIT
          CON    7           2 UNITS
          CON    5           3 UNITS
          CON    4           4 UNITS
          CON    4           5 UNITS
          CON    3           6 UNITS
          CON    3           7 UNITS
          CON    3           8 UNITS

 S185     BSS                TABLE FOR 185 SECOND TIMEOUT VALUES
          CON    28          1 UNIT
          CON    20          2 UNITS
          CON    15          3 UNITS
          CON    12          4 UNITS
          CON    11          5 UNITS
          CON    9           6 UNITS
          CON    8           7 UNITS
          CON    7           8 UNITS
          EJECT
** NAME--CHGCH
*
** PURPOSE--REPLACE CHANNEL INSTRUCTIONS WITH A DIFFERENT CHANNEL NUMBER.
*
** INPUT--CHAN = CHANNEL NUMBER
*
          SPACE  6
 CHGX     LJM    **
 CHGCH    EQU    *-1
          LDDL   CHAN        CHANNEL NUMBER
          SBDL   CURCH       CURRENT CHANNEL NUMBER
          ZJN    CHGX        NO CHANGE NEEDED
          RADL   CURCH       SAVE NEW CHANNEL
          LDN    0
          STDL   T1          CHANGE DISK CHANNEL INSTRUCTIONS
 CHG10    LDML   CONCH,T1    ADDRESS OF CHANNEL INSTRUCTIONS
          ZJN    CHGX        END OF LIST
          STDL   T2
          LDIL   T2
          SCN    37B
          LMDL   CHAN        CHANNEL NUMBER
          STIL   T2
          AODL   T1
          UJK    CHG10
          EJECT
* CHECK FOR VALID UNIT DESCRIPTOR.
          SPACE  6
 D5       IFEQ   VALID,1
 CHKUX    LJM    **
 CHKUD    EQU    *-1
          LDML   IBUF+/UD/P.CHAN  CHANNEL NUMBER
          SHN    /UD/L.CHAN+/UD/N.CHAN+2
          LPN    /SS/M.CHAN
          SBN    14B         VALID CHANNELS ARE 0 - 13B AND 20B - 33B
          MJN    CHKU30      CHANNEL OK
          SBN    20B-14B
          PJN    CHKU25
 CHKU20   BSS
          LDC    E20A        INVALID CHANNEL NUMBER
          UJN    CHKU100

 CHKU25   BSS
          SBN    34B-20B
          PJN    CHKU20

 CHKU30   BSS
          LDML   IBUF+/UD/P.UQT+1  UNIT INTERFACE TABLE ADDRESS
          LPN    7
          ZJK    CHKUX
          LDC    E209        UNIT INTERFACE TABLE NOT A WORD BOUNDARY

 CHKU100  BSS
          RJM    INTERR      SEND ERROR TO CM
*         (NO RETURN FROM INTERR)

 D5       ENDIF
          EJECT
* CHECK FOR VALID UNIT INTERFACE TABLE.
          SPACE  6
 W11      IFEQ   VALID,1
 CUTX     LJM    **
 CHKUIT   EQU    *-1
          LDN    0
          STDL   T1
          LDML   UBUF+/UIT/P.LU  LOGICAL UNIT NUMBER
          SBML   IBUF+/UD/P.LU
          NJN    CUT25       LOGICAL UNIT NUMBER MISMATCH

          AODL   T1
          LDML   UBUF+/UIT/P.UTYPE  UNIT TYPE
          ADC    -403B       VALID UNIT TYPE = 403B - 404B
          MJN    CUT100      INVALID UNIT TYPE

          SBN    404B-403B+1
          PJN    CUT100
*
          AODL   T1
          LDML   UBUF+/UIT/P.UBUFL  UNIT COMMUNICATION BUFFER LENGTH
          LPN    7
          ZJN    CUT30
 CUT25    UJN    CUT100

 CUT30    BSS
          AODL   T1
          LDML   UBUF+/UIT/P.UBUF+1  UNIT COMMUNICATION BUFFER
          LPN    7
          NJN    CUT100      NOT A WORD BOUNDARY

          AODL   T1
          LDML   UBUF+/UIT/P.NEXTPV-1  RESERVED FIELD OF UNIT
                             REQUEST QUEUE DESCRIPTOR
          ADML   UBUF+/UIT/P.NEXT-2
          ADML   UBUF+/UIT/P.NEXT-1
          ZJK    CUTX

 CUT100   BSS
          LDML   CUT110,T1   INTERFACE ERROR CODE
          RJM    INTERR      SEND ERROR TO CM
*         (NO RETURN FROM INTERR)

 CUT110   BSS
          CON    E301        LOGICAL UNIT NUMBER MISMATCH
          CON    E306        INVALID UNIT TYPE
          CON    E307        UNIT COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS
          CON    E302        UNIT COMMUNICATION BUFFER NOT A WORD BOUNDARY
          CON    E305        RESERVED FIELD OF UNIT REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 W11      ENDIF
          EJECT
* INTERFACE ERROR.
          SPACE  6
 INTERR   CON    0
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LDN    0           UNSOLICITED MESSAGE
          STDL   RESPC       RESPONSE CODE
          LDK    /RS/K.INTERR  INTERFACE ERROR
          STML   RS+/RS/P.INTERR  ABNORMAL STATUS CODE
          RJM    TERMP       SEND RESPONSE TO CM
          RJM    HALT        HALT THE PP
*         (NO RETURN FROM HALT.)

          EJECT
** NAME-- STLOCK
*
** PURPOSE-- SETS THE UNIT LOCK IN THE UNIT INTERFACE TABLE.
*            SAME AS SETLOCK ROUTINE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SETLX    LJM    **
 STLOCK   EQU    *-1
 F1       IFEQ   SLOCK,0
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJK    SETLX       IF LOCK COULD NOT BE SET
 F1       ENDIF
          RJM    GETSS       READ SS ENTRY FROM UNIT COMMUNICATION BUFFER
          RJM    SCLOCK      SET CHANNEL LOCK
          UJK    SETLX
          EJECT
** NAME-- TERMP
*
** PURPOSE-- TERMINATE PP REQUEST.
*
** OUTPUT-- RS+/RS/P.RC = RESPONSE CODE
          SPACE  6
 TERX     LJM    **
 TERMP    EQU    *-1
          RJM    PUTRC       PUT RESPONSE CODES IN RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
*         LDN    0
*         STML   PPRQ        ZERO OUT PP REQUEST FLAG
          RJM    ZRESP       ZERO OUT RESPONSE BUFFER
          UJK    TERX
          EJECT
          QUAL   *
 R3       ERRPL  *-7761B     IF .GT. 0, OVERLAY IS TOO LONG
          EJECT

          OVERLAY (CONFIDENCE TEST),OVAD1
          ROUTINE CONFO
          CON    CONFOO

          QUAL   CF
          EJECT
** NAME-- CTEST
*
** PURPOSE-- RUN THE CONFIDENCE TEST ON ALL UNITS
*            WHEN THE PP IS FIRST LOADED.
          SPACE  6
 CTESTX   LJM    **
          QUAL   *
 CTEST    EQU    *-1
          QUAL   CF

          LDN    0
          STML   UX          UNIT INDEX
          STML   CTEST100    CLEAR FLAG FOR CONFIDENCE TEST TO BE RECALLED LATER
          LDDL   UNUML
          ZJK    CTEST60     IF NO UNITS
 CTEST10  BSS
          LDML   UNITS+/UN/P.CTST,UX  HAS THE CONFIDENCE TEST BEEN STARTED
          SHN    /UN/L.CTST+2
          MJK    CTEST50     IF THE CONFIDENCE TEST HAS BEEN STARTED
          LDML   UNITS+/UN/P.CM,UX  GET CONTROL MODULE NUMBER
          SHN    -3
          STDL   CMOD        CONTROL MODULE NUMBER
          LDML   CMLOAD,CMOD  CHECK IF CONTROL MODULE IS BEING LOADED
          NJK    CTEST80     IF CONTROL MODULE IS BEING LOADED
          LDML   UNITS+/UN/P.BUSY,UX  CHECK IF OUTSTANDING COMMAND
          SHN    /UN/L.BUSY+2
          MJK    CTEST80     IF A COMMAND IS IN PROGRESS
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ERRNZ  /UIT/C.DSABLE
          CRDL   T5          READ UNIT DISABLED FLAG
          LDDL   T5+/UIT/P.DSABLE  CHECK IF UNIT IS DISABLED
          SHN    /UIT/L.DSABLE+2
          MJK    CTEST50     IF UNIT IS DISABLED
 CTEST20  BSS
          RJM    /RES/PPREQ  CHECK IDLE AND ACTIVE FLAGS
          RJM    /RES/SETLOCK  SET THE UNIT LOCK
          NJK    CTEST20     IF LOCK WAS NOT SET
          STML   RS+/RS/P.PVA    CLEAR OUT ANY LEFT OVER PVA
          STML   RS+/RS/P.PVA+1  FROM RESPONSE BUFFER
          STML   RS+/RS/P.PVA+2
          LDML   UNITS+/UN/P.CTST,UX  SET FLAG THAT CONFIDENCE TEST WAS STARTED
          LPC    -/UN/K.CTST
          ADK    /UN/K.CTST
          STML   UNITS+/UN/P.CTST,UX

* GET DEVICE TYPE.

          LDML   SS+/SS/P.DV  GET DEVICE TYPE
          ERRNZ  -16+/SS/L.DV+/SS/N.DV
          LPN    /SS/M.DV
          STDL   DEVICE
          LDML   SS+/SS/P.STV  INDEX TO TABLE OF STARTING VALUES OF DATA
          LPC    -/SS/K.STV
          STML   SS+/SS/P.STV

          RJM    CONF        EXECUTE THE CONFIDENCE TEST

* SET FLAG THAT THE CONFIDENCE TEST WAS RUN.

          LDML   SS+/SS/P.CONF  SET CONFIDENCE TEST FLAG
          LPC    -/SS/K.CONF
          ADK    /SS/K.CONF
          STML   SS+/SS/P.CONF

          RJM    CLRLOCK     SAVE SS ENTRY

* LEAVE THE UNIT LOCKED.

 CTEST50  BSS
          LDN    P.UN
          RADL   UX          BUMP UNIT ENTRY
          SBDL   UNUML
          MJK    CTEST10     IF NOT END OF TABLE
 CTEST60  BSS
          LDML   CTEST100
          NJN    CTEST70     IF AT LEAST 1 UNIT IS LEFT
          LDDL   IALF        SET FLAG FOR CONFIDENCE TEST STARTED ON
                             ALL CONTROLLERS
          LPC    -4
          ADN    4
          STDL   IALF
 CTEST70  BSS
          UJK    CTESTX

 CTEST80  BSS
          AOML   CTEST100    EXIT WITH IALF, BIT 2 = 0 TO BE RECALLED LATER
          UJK    CTEST50


 CTEST100 BSSZ   1           NONZERO IF CONFIDENCE TEST SHOULD BE ATTEMPTED LATER
          EJECT
** NAME-- CONF
*
** PURPOSE-- EXECUTE THE CONFIDENCE TEST.
          SPACE  6
 CONFX    LJM    **
 CONF     EQU    *-1
          LDK    /RS/K.CT    SET FLAG FOR CONFIDENCE TEST STARTED
          RJM    SDET        PUT ID IN RESPONSE

          LDN    0
          STML   SS+/SS/P.TOTAL  SECTORS TRANSFERRED
          LDN    1
          STDL   FNC         SET FUNCTION CODE = WRITE
          STML   SS+/SS/P.FNC  SET FUNCTION CODE = WRITE
          RJM    CSETUP      SET UP THE DISK ADDRESS
          RJM    SETADD      SET STARTING DISK ADDRESS IN RESPONSE BUFFER
          LDML   UNITS+/UN/P.BUSY,UX  CLEAR BUSY FLAG
          LPC    -/UN/K.BUSY
          STML   UNITS+/UN/P.BUSY,UX
          RJM    /RES/SEEKCK  ISSUE SEEK
          LDDL   PLSTAT
          NJK    CTERM60     IF COMMAND BLOCK ISSUE WAS UNSUCCESSFUL
          LDML   UNITS+/UN/P.BUSY,UX  SET 'UNIT BUSY' FLAG
          LPC    -/UN/K.BUSY
          ADK    /UN/K.BUSY
          STML   UNITS+/UN/P.BUSY,UX
          UJK    CONFX
          EJECT
* THE COMMAND COMPLETED WITHOUT ERROR.
          SPACE  6
          QUAL   *
 CTERM    CON    0
          QUAL   CF

          SODL   CMNDS       DECREMENT COUNT OF OUTSTANDING COMMANDS
          LDML   CMLOAD,CMOD  CONTROL MODULE LOADING TABLE
          ADML   SS+/SS/P.NR  CHECK IF NOT READY ERROR PROCESSING
          ADML   SS+/SS/P.DIAG  CHECK IF RUNNING DIAGNOSTICS
          ADML   SS+/SS/P.DIAGS  CHECK IF RUNNING DIAGNOSTICS
          NJK    /RES/TERM40  CALL OVERLAY TO PROCESS

          LDML   UNITS+/UN/P.BUSY,UX  CLEAR BUSY FLAG
          LPC    -/UN/K.BUSY
          STML   UNITS+/UN/P.BUSY,UX
          LDML   SS+/SS/P.FNC
          ZJK    CTERM20     IF READ
          LDN    0
          STML   SS+/SS/P.TOTAL  SET SECTORS TRANSFERRED = 0
          STDL   FNC         SET FUNCTION CODE = READ
          STML   SS+/SS/P.FNC  SET FUNCTION CODE = READ
          LDML   SS+/SS/P.CPERR  COMPARE ERROR FLAG
          LPC    -/SS/K.CPERR
          STML   SS+/SS/P.CPERR
          RJM    CSETUP      SET UP THE DISK ADDRESS
          RJM    SETADD      SET STARTING DISK ADDRESS IN RESPONSE BUFFER
          RJM    /RES/SEEKCK  ISSUE SEEK
          LDDL   PLSTAT
          NJK    CTERM60     IF COMMAND BLOCK ISSUE WAS UNSUCCESSFUL
          LDML   UNITS+/UN/P.BUSY,UX  SET 'UNIT BUSY' FLAG
          LPC    -/UN/K.BUSY
          ADK    /UN/K.BUSY
          STML   UNITS+/UN/P.BUSY,UX
          UJN    CTERM40

 CTERM20  BSS
          LDML   SS+/SS/P.CPERR  CHECK IF THERE WAS A COMPARE ERROR
          SHN    /SS/L.CPERR+2
          MJN    CTERM50     IF COMPARE ERROR

          LDN    1
          ERRNZ  16-/SS/N.STV-/SS/L.STV
          RAML   SS+/SS/P.STV  INDEX TO TABLE OF STARTING VALUES OF DATA
          LPK    /SS/M.STV
          SBN    STVL
          ZJN    CTERM30     IF END OF STARTING VALUE TABLE

* ISSUE THE SEEK TO WRITE DATA.

          RJM    CONF        ISSUE THE SEEK FOR WRITE
          UJN    CTERM40

* END OF CONFIDENCE TEST.

 CTERM30  BSS
          LDML   SS+/SS/P.CONF  CLEAR CONFIDENCE TEST FLAG
          LPC    -/SS/K.CONF
          STML   SS+/SS/P.CONF
 CTERM40  BSS
          RJM    CLRLOCK     SAVE SS ENTRY
          UJK    MAINC

* DATA COMPARE ERROR.

 CTERM50  BSS
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          LDK    /RS/K.DIE   DRIVE INTERFACE INTEGRITY ERROR
          RJM    SDET        PUT ERROR ID IN RESPONSE
          RJM    UTERM       UNRECOVERED ERROR, TURN OFF UNIT
*         (NO RETURN FROM UTERM.)

 CTERM60  BSS
          RJM    FAILAD      PUT FAILING ADDRESS IN RESPONSE
          RJM    RECS        UNRECOVERED ERROR
*         (NO RETURN FROM RECS.)
          SPACE  6
          EJECT
** NAME-- CSETUP
*
** PURPOSE-- SET UP PARAMETERS FOR THE CONFIDENCE TEST.
          SPACE  6
 CSEX     LJM    **
 CSETUP   EQU    *-1
          LDML   CFCYL,DEVICE
          STML   SS+/SS/P.CYL  CYLINDER ADDRESS OF CURRENT REQUEST
          LDN    0
          STDL   T1
          LDML   SS+/SS/P.TOTAL  SECTORS TRANSFERRED
          STML   SS+/SS/P.SECTOR  SECTOR ADDRESS
 CSE10    BSS
          LDML   SS+/SS/P.SECTOR  COMPUTE TRACK AND SECTOR ADDRESS
          SBML   DVSEC,DEVICE  NUMBER OF SECTORS PER TRACK
          MJN    CSE20       IF END OF COMPUTATION
          STML   SS+/SS/P.SECTOR
          AODL   T1          INCREMENT TRACK ADDRESS
          UJN    CSE10

 CSE20    BSS
          LDDL   T1          TRACK ADDRESS
          STML   SS+/SS/P.TRACK  TRACK ADDRESS OF CURRENT REQUEST

          LDML   SECCYL,DEVICE  NUMBER OF SECTORS TO TRANSFER PER CYLINDER
          SBML   SS+/SS/P.TOTAL  SECTORS TRANSFERRED
          STML   SS+/SS/P.MAUS  NUMBER OF SECTORS TO END OF CYLINDER
          UJK    CSEX
          EJECT
** NAME-- CREAD.
*
** PURPOSE-- READ THE CONFIDENCE TEST CYLINDER.
          SPACE  6
          QUAL   *
 CREAD    CON    0
          QUAL   CF
          LDML   SS+/SS/P.MAUS  TOTAL SECTORS LEFT TO TRANSFER
          NJN    CREAD10     IF MORE DATA TO TRANSFER
          RJM    TERMA       PROBABLY ADAPTER ERROR
*         (NO RETURN FROM TERMA.)

 CREAD10  BSS
          LDN    0
          STDL   FRSTSC      FIRST SECTOR FLAG
          STML   CKDATA      COMPARE DATA ON ONE SECTOR FOR EACH TRACK
          LDML   SS+/SS/P.DV  GET DEVICE TYPE
          ERRNZ  -16+/SS/L.DV+/SS/N.DV
          LPN    /SS/M.DV
          STDL   DEVICE

* TRANSFER DATA FROM DISK.

 CREAD20  BSS
          LDN    F.MOVDT     MOVE DATA FUNCTION (TERMINATE)
          RJM    FUNC
          RJM    IAMBF       ACN    DC
                             LDC    SECWDS      NUMBER OF CHANNEL WORDS
                             IAM   BUFF,DC
          STDL   AREG        SAVE A REGISTER IN CASE OF PREMATURE TERMINATION
          ZJN    CREAD40     IF TRANSFER WAS COMPLETE

          RJM    POLSTAT     GET POLL STATUS
          LDDL   PLSTAT      IF POLL STATUS = 640XX B, THEN
                             IT WAS A MEDIA ERROR, REPEAT MOVE DATA
          ADC    -64000B
          SBML   UNITS+/UN/P.UNIT,UX
          NJN    CREAD30     IF NOT MEDIA ERROR
          LDK    /RS/K.MEDIA  MEDIA ERROR
          RJM    SERRID      SAVE ERROR ID
          UJK    CREAD20     REPEAT MOVE DATA

 CREAD30  BSS
          LDDL   AREG
          STML   RS+/RS/P.FUNTO  NUMBER OF CHANNEL WORDS NOT RECEIVED
          LDK    /RS/K.IST   INCOMPLETE SECTOR TRANSFER
          UJN    CREAD50

 CREAD40  BSS
          RJM    INC         CHECK IF CHANNEL IS INACTIVE
*         (NO RETURN IF ERROR).

          LDML   SS+/SS/P.MAUS  NUMBER OF SECTORS LEFT TO TRANSFER
          SBN    SECSC       SECTOR INCREMENT
          NJN    CREAD60     IF NOT TERMINATE

* TERMINATE.
* THIS STATUS MUST BE ISSUED IMMEDIATELY, (WITHIN 50 MICROSECONDS),
* AFTER THE READ FUNCTION.

          RJM    POLSTAT     GET POLL STATUS
          LDDL   PLSTAT
          ADC    -4000B
          SBML   UNITS+/UN/P.UNIT,UX
          ZJN    CREAD60     IF NO ERROR ON LAST SECTOR
          LDK    /RS/K.RERR  STATUS BEFORE SUSPEND / TERMINATE READ .NE.
                             4XXXB.
 CREAD50  BSS
          RJM    SERRID      SAVE ERROR FLAG
          RJM    ADPTERR     RECOVER ERROR
*         (NO RETURN FROM ADPTERR.)



* UPDATE SECTOR ADDRESS AND CHECK FOR END OF TRACK.

 CREAD60  BSS
          LDML   CKDATA
          NJN    CREAD62     IF A SECTOR HAS BEEN COMPARED FOR THIS TRACK
          RJM    CKD         CHECK THE DATA
          AOML   CKDATA      SET FLAG THAT DATA HAS BEEN CHECKED

 CREAD62  BSS
          RJM    /RES/RECRS  CHECK IF A PREVIOUS ERROR WAS RECOVERED
          AODL   FRSTSC
          SBN    1
          ZJN    CREAD70     IF FIRST SECTOR TRANSFERRED FOR THIS
                             READ SEQUENCE
          LDN    SECSC       SECTOR INCREMENT
          RAML   SS+/SS/P.CURSEC  INCREMENT SECTOR ADDRESS
          SBML   DVSEC,DEVICE  COMPARE WITH NUMBER OF SECTORS / TRACK
          MJN    CREAD70     IF NOT END OF TRACK
          STML   SS+/SS/P.CURSEC  SET SECTOR
          AOML   SS+/SS/P.CURTRK  INCREMENT HEAD ADDRESS
          LDN    0
          STML   CKDATA      COMPARE DATA ON A SECTOR FOR EACH TRACK

* UPDATE BYTES TRANSFERRED.

 CREAD70  BSS
          LDN    SECSC       SECTOR INCREMENT
          RAML   SS+/SS/P.TOTAL  INCREMENT NUMBER OF SECTORS TRANSFERRED
          LDML   SS+/SS/P.MAUS  DECREMENT NUMBER OF SECTORS LEFT TO TRANSFER
          SBN    SECSC
          STML   SS+/SS/P.MAUS
          NJK    CREAD20     IF MORE WORDS TO TRANSFER
          RJM    CTERM       TERMINATE THE READ
*         (NO RETURN FROM CTERM.)
          EJECT
** NAME-- CWRITE
*
** PURPOSE-- WRITE THE CONFIDENCE TEST CYLINDER.
          SPACE  6
 CWRIX    LJM    **
          QUAL   *
 CWRITE   EQU    *-1
          QUAL   CF
          LDML   SS+/SS/P.MAUS  TOTAL SECTORS LEFT TO TRANSFER
          NJN    CWRI10      IF MORE DATA TO TRANSFER
          RJM    TERMA       PROBABLY ADAPTER ERROR
*         (NO RETURN FROM TERMA.)

 CWRI10   BSS
          LDN    0
          STDL   FRSTSC      FIRST SECTOR FLAG
          LDML   SS+/SS/P.DV  GET DEVICE TYPE
          ERRNZ  -16+/SS/L.DV+/SS/N.DV
          LPN    /SS/M.DV
          STDL   DEVICE
          RJM    INID        INITIALIZE THE WRITE DATA BUFFER

* CHECK IF THE DATA IS STILL IN THE BUFFER.
* AN ERROR RECOVERY OVERLAY COULD WIPE IT OUT.  (RECRS MAY CALL AN OVRLAY.)

 CWRI20   BSS
          ERRNZ  16-/SS/N.STV-/SS/L.STV
          LDML   SS+/SS/P.STV  INDEX TO TABLE OF STARTING VALUES OF DATA
          LPK    /SS/M.STV
          STDL   T1
          LDML   STVAL,T1
          ADN    1           CHECK THE SECOND WORD
          SBML   BUFF+1
          ZJN    CWRI30      IF DATA IS STILL IN BUFFER
          RJM    INID        INITIALIZE THE DATA

* TRANSFER DATA TO DISK.

 CWRI30   BSS
          LDML   SS+/SS/P.CURTRK  PUT TRACK AND SECTOR ADDRESS IN
                             FIRST WORD OF SECTOR
          SHN    8
          ADML   SS+/SS/P.CURSEC
          STML   BUFF
          LDN    F.MOVDT     ISSUE MOVE DATA AND TERMINATE
          RJM    FUNC        ISSUE THE FUNCTION
          RJM    ACN         ACN    DC
          LDC    SECWDS      NUMBER OF WORDS IN SECTOR
          RJM    OAMBF       OAM   BUFF,DC
          RJM    DCN         DCN    40B+DC
*         (NO RETURN IF ERROR).

          AODL   FRSTSC
          SBN    1
          ZJN    CWRI40      IF FIRST SECTOR TRANSFERRED FOR THIS
                             READ SEQUENCE
          LDN    SECSC       SECTOR INCREMENT
          RAML   SS+/SS/P.CURSEC  INCREMENT SECTOR ADDRESS
          SBML   DVSEC,DEVICE  COMPARE WITH NUMBER OF SECTORS / TRACK
          MJN    CWRI40      IF NOT END OF TRACK
          STML   SS+/SS/P.CURSEC  SET SECTOR
          AOML   SS+/SS/P.CURTRK  INCREMENT HEAD ADDRESS

* UPDATE BYTES TRANSFERRED.

 CWRI40   BSS
          LDN    SECSC       SECTOR INCREMENT
          RAML   SS+/SS/P.TOTAL  INCREMENT NUMBER OF SECTORS TRANSFERRED
          LDML   SS+/SS/P.MAUS  DECREMENT NUMBER OF SECTORS LEFT TO TRANSFER
          SBN    SECSC
          STML   SS+/SS/P.MAUS
          NJK    CWRI20      IF MORE WORDS TO TRANSFER
          UJK    CWRIX       IF END OF DATA
          EJECT
** NAME-- INID
*
** PURPOSE-- INITIALIZE DATA FOR THE READ / WRITE CONFIDENCE TEST.
          SPACE  6
 INIX     LJM    **
 INID     EQU    *-1
          ERRNZ  16-/SS/N.STV-/SS/L.STV
          LDML   SS+/SS/P.STV  INDEX TO TABLE OF STARTING VALUES OF DATA
          LPK    /SS/M.STV
          STDL   T1
          LDML   STVAL,T1    INITIALIZE STARTING VALUE
          STDL   P1

          LDN    0
          STDL   T1

 INI20    BSS
          LDDL   P1
          STML   BUFF,T1     PUT DATA IN BUFFER
          AODL   P1
          AODL   T1          INCREMENT PP WORD COUNT
          ADC    -SECWDS     NUMBER OF WORDS PER SECTOR
          MJK    INI20       IF NOT DONE INITIALIZING THE DATA
          UJK    INIX
          SPACE  6

* EACH ENTRY IN THE STVAL TABLE CONTAINS THE STARTING 16-BIT VALUE
* FOR INITIALIZING THE WRITE DATA BUFFER.  EACH 16 BIT-FIELD IN THE
* WRITE DATA BUFFER IS INCREMENTED BY 1.

 STVAL    CON    170000B     STARTING VALUES OF DATA
          CON    174000B
 STVL     EQU    2           NUMBER OF ENTRIES IN STVAL TABLE
          EJECT
** NAME-- CKD
*
** PURPOSE-- CHECK THE DATA WHEN DOING THE CONFIDENCE TEST.
          SPACE  6
 CKX      LJM    **
 CKD      EQU    *-1
          ERRNZ  16-/SS/N.STV-/SS/L.STV
          LDML   SS+/SS/P.STV  INDEX TO TABLE OF STARTING VALUES OF DATA
          LPK    /SS/M.STV
          STDL   T1
          LDML   STVAL,T1    STARTING VALUE OF SECTOR
          ADN    1
          STDL   P1

          LDN    1
          STDL   T1

 CK20     BSS
          LDDL   P1
          SBML   BUFF,T1     COMPARE THE DATA
          NJN    CK40        IF COMPARE ERROR
          AODL   P1
          AODL   T1          INCREMENT PP WORD COUNT
          ADC    -SECWDS     NUMBER OF WORDS PER SECTOR
          MJK    CK20        IF NOT END OF SECTOR
          LDML   SS+/SS/P.CURTRK  CHECK IF FIRST WORD OF SECTOR IS
                             THE TRACK AND SECTOR ADDRESS
          SHN    8
          ADML   SS+/SS/P.CURSEC
          SBML   BUFF
          NJN    CK40        IF COMPARE ERROR
          UJK    CKX

* DATA COMPARE ERROR.

 CK40     BSS
          LDML   SS+/SS/P.CPERR  SET COMPARE ERROR FLAG
          LPC    -/SS/K.CPERR
          ADK    /SS/K.CPERR
          STML   SS+/SS/P.CPERR
          UJK    CKX
          EJECT
 SDETX    LJM    **
 SDET     EQU    *-1         SAVE ERROR ID
          STDL   T1
          LMC    -0
          STDL   T2
          LDML   RS+/RS/P.DET  ERROR ID
          LPDL   T2
          ADDL   T1          ADD ERROR FLAG
          STML   RS+/RS/P.DET
          UJK    SDETX
          EJECT
 CFCYL    CON    815         ISD-1   CONFIDENCE TEST CYLINDER
          CON    699         ISD-2   CONFIDENCE TEST CYLINDER
 SECCYL   CON    320         ISD-1 - NUMBER OF SECTORS PER CYLINDER
          CON    1128        ISD-2 - NUMBER OF SECTORS PER CYLINDER
          EJECT



          QUAL   *
          ERRPL  *-BUFF

*DECK DECK=IODMAC1 EXPAND=FALSE
* BEGIN IODMAC1
          SPACE  5
** THE FOLLOWING SET OF MACROS PROVIDE A MEANS OF AIDING THE PP COMPASS
** PROGRAMMER IN MAKING REFERENCES TO CYBIL STRUCTURES.  A PARALLEL DEF-
** INITION DECK IS CREATED TO MATCH THE CYBIL DECLARATIONS.  THIS DECK IS
** INPUT TO PP ASSEMBLIES WHICH REFERENCE THE STRUCTURES.
** REFERENCES TO FIELDS OF A RECORD ARE MADE ACCORDING TO THE FOLLOWING
**
**   1.ALL FIELD NAMES ARE QUALIFIED BY THE RECORD NAME.
**      B.RECORD=BYTE LENGTH OF RECORD
**      P.RECORD=LENGTH OF RECORD IN PP WORDS
**      C.RECORD=LENGTH OF RECORD IN CP WORDS
**
**   2.FIELD DEFINITIONS PRODUCE A SET OF SYMBOLS FOR CODE REFERENCE...
**      /RECORD/C.FIELD=CP WORD OFFSET OF FIELD WITHIN RECORD
**      /RECORD/P.FIELD=PP WORD OFFSET OF FIELD WITHIN RECORD
**      /RECORD/L.FIELD=LEFTMOST BIT OF FIELD IN FIRST PP WORD (0=2**15)
**                      IN UNPACKED RECORDS, FIELDS NOT DESCRIBED AS
**                      MULTIPLES OF BYTES ARE ASSUMED TO BE RIGHT ALIGNED
**                      WITHIN AN INTEGRAL NUMBER OF BYTES.  GARBAGE IS
**                      ASSUMED IN THE LEFT (UNUSED) BIT POSITIONS.
**      /RECORD/N.FIELD=NUMBER OF BITS IN THE FIELD (INCLUDING UNUSED BITS
**                      IN JUSTIFIED FIELDS).
**      /RECORD/B.FIELD=BYTE COUNT OF FIELD.
          SPACE  5
** RECORD DEFINITION MACRO
** NAME IS NAME WITH WHICH THE REFERENCES TO THE FIELDS OF THE RECORD
** MUST BE QUALIFIED.  PACKING IS *PACKED* OR OTHER TO INDICATE THE
** ATTRIBUTE OF THE CYBIL RECORD DEFINITION.
          SPACE  3
          MACRO  RECORD,NAME,PACKING
          QUAL   NAME
BITC      SET    0
PACKED    SET    0
          IFC    EQ,*PACKING*PACKED*,1
PACKED    SET    1
          ENDM
          SPACE  5
** RECEND MACRO
** DEFINE THE END OF A RECORD
          SPACE  3
          MACRO  RECEND,NAME
          QUAL
B.NAME    SET    /NAME/BITC+7
B.NAME    SET    B.NAME/8
P.NAME    SET    B.NAME+1
P.NAME    SET    P.NAME/2
C.NAME    SET    P.NAME+3
C.NAME    SET    C.NAME/4
          ENDM
          SPACE  5
** FIELD DEFINITION MACRO
** THIS MACRO DEFINES A FIELD WITHIN A RECORD IN TERMS OF ITS STARTING
** PP WORD NUMBER, LEFTMOST BIT WITHIN THE PP WORD, NUMBER OF BITS IN
** THE FIELD, AND NUMBER OF BYTES IN THE FIELD.
** NAME-NAME OF FIELD FOR QUALIFIED REFERENCES
** LENGTH-NUMBER OF BITS IN FIELD
          SPACE  3
          MACRO  FIELD,NAME,LENGTH
*PP WORD OFFSET
P.NAME    SET    BITC/16

* CP WORD OFFSET
C.NAME    SET    BITC/64

* LEFTMOST BIT IN WORD 0 (0 FROM LEFTMOST, 15=RIGHTMOST)
L.NAME    SET    BITC-P.NAME*16

* BIT LENGTH
N.NAME    SET    LENGTH

* BYTE COUNT
B.NAME    SET    LENGTH+7
B.NAME    SET    B.NAME/8

* INCREMENT BIT COUNTER
BITC      SET    BITC+N.NAME
          ENDM
          SPACE  5
** LOG2 MACRO
** THIS IS A SUPPORT MACRO TO ASSIST IN DETERMINING SUBRANGE STORAGE
** REQUIREMENTS.  THE PARAMETER IS THE VALUE WHICH MUST BE SIZED.
** THE BIT COUNT REQUIRED TO REPRESENT THE PARAMETER VALUE IS RETURNED
** IN ASSEMBLY VARIABLE LOG2$.
          SPACE  3
LOG2      MACRO  N
          LOCAL  J
LOG2$     SET    1
J         SET    N/2
          DUP    32
          IFGT   J,0,2
LOG2$     SET    LOG2$+1
J         SET    J/2
          ENDD
          ENDM
          SPACE  5
** MGEN MACRO
** THIS IS A SUPPORT MACRO FOR THE LOAD/STORE MACROS
** THE LENGTH PARAMETER IS THE LENGTH OF A FIELD OF RJ BITS IN A
** 16 BIT WORD.  THE VALUE OF MASK$ UPON EXIT FROM THE MACRO IS
** A 16 BIT MASK TO ZERO FILL THE RIGHT JUSTIFIED BIT PATTERN.
          SPACE  3
MGEN      MACRO  LENGTH
MASK$     SET    0
          DUP    LENGTH
MASK$     SET    MASK$+MASK$+1
          ENDD
          ENDM
          SPACE  5
** ALIGN MACRO
** MACRO TO ALIGN THE CURRENT BIT COUNTER TO BE *OFFSET* MOD *MODULUS*
** EXAMPLE ALIGN 0,8 FORCES BYTE BOUNDARY.
          SPACE  3
ALIGN     MACRO  OFFSET,MODULUS
          LOCAL M

* VERIFY PARAMETERS
          IFGE   OFFSET,MODULUS,1
M         ERR                      MODULUS MUST EXCEED OFFSET
          IFLE   MODULUS,0,1
M         ERR                      MODULUS MUST EXCEED 0

M         SET    BITC+MODULUS-OFFSET-1
M         SET    M/MODULUS*MODULUS
BITC      SET    M+OFFSET
          ENDM
          SPACE  5
** INTEGER MACRO
** THIS MACRO DEFINES THE NAMED FIELD AS A CYBIL INTEGER
          SPACE  3
          MACRO  INTEGER,NAME
          ALIGN  0,8
NAME      FIELD  64
          ENDM
          SPACE  5
** CHARACTER MACRO
** THIS MACRO DEFINES THE NAMED FIELD AS AN EIGHT BIT CHARACTER
          SPACE  3
          MACRO  CHARC,NAME
          IFEQ   PACKED,0,1
          ALIGN  0,8               BYTE ALIGNED IF UNPACKED
NAME      FIELD  8
          ENDM
          SPACE  5
** ORDINAL MACRO
** THIS MACRO DEFINES THE NAMED FIELD AS AN ORDINAL OF RANGE 0..N
          SPACE  3
          MACRO  ORDINAL,NAME,N
          LOCAL Q
Q         SET    N-1
NAME      SUBRANGE 0,Q
          ENDM
          SPACE  5
** BOOLEAN MACRO
** THIS MACRO DEFINES THE NAMED FIELD AS A BOOLEAN VALUE
          SPACE  3
          MACRO  BOOLEAN,NAME
PK        IFEQ   PACKED,1
* PACKED RECORD
NAME      FIELD  1
PK        ELSE
* NOT PACKED, FORCE BYTE BOUNDARY THEN RIGHT ALIGNMENT
          ALIGN  0,8
          ALIGN  7,8
NAME      FIELD  1
PK        ENDIF
          ENDM
          SPACE  5
** STRING MACRO
** THIS MACRO GENERATES A STRING OF SPECIFIED LENGTH
          SPACE  3
          MACRO  STRING,NAME,LENGTH
          ALIGN  0,8               STRINGS ARE ALWAYS BYTE ALIGNED
NAME      FIELD  LENGTH*8
          ENDM
          SPACE  5
** STRUCT MACRO
** THIS MACRO IS USED WHEN A STRUCTURE (BYTE ALIGNED) AND OF SPECIFIED
** BYTE LENGTH IS EMBEDDED IN A RECORD.
          SPACE  3
          MACRO  STRUCT,NAME,LENGTH
          ALIGN  0,8
NAME      FIELD  LENGTH*8
          ENDM
          SPACE  5
** SUBRANGE MACRO
** THIS MACRO DEFINES THE NAMED FIELD AS A SUBRANGE OF A..B
          SPACE  3
          MACRO  SUBRANGE,NAME,A,B
          LOCAL Q
PK        IFEQ   PACKED,1
* PACKED RECORD
ANEGP     IFLT   A,0
Q         SET    -A
          IFLE   Q,B,1
Q         SET    B+1
          LOG2   Q
Q         SET    LOG2$+1
ANEGP     ELSE
          LOG2   B
Q         SET    LOG2$
ANEGP     ENDIF

NAME      FIELD  Q
PK        ELSE

* UNPACKED RECORD
          ALIGN  0,8
ANEGU     IFLT   A,0
* NEGATIVE LOWER BOUNT REQUIRES 8 BYTES
NAME      FIELD  64
ANEGU     ELSE

* USE UPPER BOUND
          LOG2   B
Q         SET    LOG2$+7
Q         SET    Q/8*8
NAME      FIELD  Q
ANEGU     ENDIF

PK        ENDIF
          ENDM
          SPACE  5
** PPWORD MACRO
** THIS MACRO CAUSES THE NAMED FIELD TO BE DEFINED AS AN ALIGNED PP WORD
** IT IS USED AS A DOCUMENTATION AID TO REMIND THE PROGRAMMER THAT THE
** CYBIL STRUCTURE IS DESIGNED TO ACCOMODATE PP REFERENCE.
          SPACE  3
          MACRO  PPWORD,NAME
          ALIGN  0,16
NAME      FIELD  16
          ENDM
          SPACE  5
** RMA MACRO
** THIS IS A CONVENIENCE MACRO FOR RMA FIELD DEFINITION (BYTE ALIGNMENT
** IS ASSUMED).
          SPACE  3
          MACRO  RMA,NAME
          ALIGN  0,8
NAME      FIELD  32
          ENDM
          SPACE  5
** MLOAD MACRO
** MACRO TO PERFORM A 16 BIT LOAD FROM PP MEMORY USING THE LDDL OR LDML
** INSTRUCTION.  USED TO SUPPORT THE LOAD MACRO.
          SPACE  3
MLOAD     MACRO  W
M         IFLE   W,77B
          LDDL   W
M         ELSE
          LDML   W
M         ENDIF
          ENDM
          SPACE  5
** MSTORE MACRO
** MACRO TO PERFORM A 16 BIT STORE TO PP MEMORY USING THE STDL OR STML
** INSTRUCTION.  USED TO SUPPORT THE STORE MACRO.
          SPACE  3
MSTORE    MACRO  W
M         IFLE   W,77B
          STDL   W
M         ELSE
          STML   W
M         ENDIF
          ENDM
* END IODMAC1
*DECK DECK=IODMAC2 EXPAND=FALSE
* BEGIN IODMAC2
          SPACE  5
** THESE MACROS MAY USE T1-T8 WITH IN LINE CODE GENERATION OR INDIRECTLY
** THROUGH CALLS TO THE LOAD/STORE SUPPORT ROUTINES
          SPACE  5
** LOAD MACRO
** LOAD A FIELD INTO A AND RIGHT JUSTIFY, ZERO FILL THE REGISTER
** INPUT..RLOC=LOCATION OF BEGINNING OF RECORD
**        RNAME=RECORD NAME
**        FIELD=FIELD NAME (MUST BE LESS THAN 17 BITS LONG)
** OUTPUT..(A)=/RECORD/FIELD RJZF
** USES T1, T2 WHEN FIELDS CROSS PP WORD BOUNDARIES
          SPACE  3
LOAD      MACRO  RLOC,RNAME,FIELD
          LOCAL T
ERCHK     IFGT   /RNAME/N.FIELD,16
M         ERR    FIELD TOO LARGE
ERCHK     ELSE

* TEST WHETHER FIELD CROSSES PP WORD BOUNDARIES AND IF IT DOES NOT,
* GENERATE THE LOAD IN LINE.
L1        IFLE   /RNAME/N.FIELD+/RNAME/L.FIELD,16

* LOAD IT
          LDML   /RNAME/P.FIELD+RLOC

* SHIFT IT
T         SET    16-/RNAME/N.FIELD-/RNAME/L.FIELD
          IFNE   T,0,1
          SHN    -T

* MASK IT
M0        IFNE   /RNAME/L.FIELD,0
M1        IFNE   /RNAME/N.FIELD,16
          MGEN   /RNAME/N.FIELD
M2        IFGT   MASK$,77B
          LPC    MASK$
M2        ELSE
          LPN    MASK$
M2        ENDIF
M1        ENDIF
M0        ENDIF

L1        ELSE

* CROSSES WORD BOUNDARIES
          RJM    LOADF
          VFD    4/0,12/RLOC+/RNAME/P.FIELD
          VFD    4//RNAME/L.FIELD,12//RNAME/N.FIELD

L1        ENDIF

ERCHK     ENDIF

          ENDM
          SPACE  5
** STORE MACRO
** THIS MACRO STORES THE CONTENTS OF A INTO A FIELD IN PP MEMORY.
** THE FIELD MAY CROSS PP WORD BOUNDARIES BUT MUST NOT EXCEED 16
** BITS IN LENGTH.
** INPUT...RLOC=LOCATION OF BEGINNING OF RECORD
**         RNAME=RECORD NAME
**         FIELD=FIELD NAME (MUST BE A FIELD OF 16 OR LESS BITS IN LENGTH)
**         (A)=RJZF VALUE TO STORE.  (IT MUST NOT EXCEED FIELD WIDTH OR
**             UNPREDICTABLE RESULTS WILL OCCUR).
**
** OUTPUT..RECORD UPDATED IN PP MEMORY.
**
** USES T1, T2 PLUS REFERENCE STOREF
          SPACE  3
STORE     MACRO  RLOC,RNAME,FIELD
          LOCAL  X
ERCHK     IFGT   /RNAME/N.FIELD,16
M         ERR    FIELD TOO LARGE
ERCHK     ELSE

* TEST WHETHER FIELD CROSSES PP WORD BOUNDARIES AND IF IT DOES NOT,
* GENERATE IN LINE CODE.
L1        IFLE   /RNAME/N.FIELD+/RNAME/L.FIELD,16
L2        IFEQ   /RNAME/N.FIELD,16

* FULL PP WORD
          STML   /RNAME/P.FIELD+RLOC

L2        ELSE

* ALIGN SOURCE VALUE
X         SET    16-/RNAME/N.FIELD-/RNAME/L.FIELD
          IFNE   X,0,1
          SHN    X

* STORE ALIGNED VALUE
          STDL   T1

* LOAD DEST. FIELD
          LDML   /RNAME/P.FIELD+RLOC

* FORM SHIFTED MASK VALUE
          MGEN   /RNAME/N.FIELD

          DUP    X
MASK$     SET    MASK$+MASK$
          ENDD

* GENERATE MASK INSTRUCTION
          LPC    -MASK$

* INSERT DATA
          ADDL   T1

* REPLACE
          STML   /RNAME/P.FIELD+RLOC

L2        ENDIF

L1        ELSE

* FIELD CROSSES WORD BOUNDARIES
          RJM    STOREF
          VFD    4/0,12/RLOC+/RNAME/P.FIELD
          VFD    4//RNAME/L.FIELD,12//RNAME/N.FIELD

L1        ENDIF
ERCHK     ENDIF
          ENDM
* END IODMAC2
*DECK DECK=IODMAC3 EXPAND=FALSE
*BEGIN IODMAC3
          SPACE  5
** COMMON PP ROUTINE AID MACROS
          SPACE  2
** MACRO TO DEFINE A SUBROUTINE ENTRY POINT TO BE CALLED BY RJM NAME
          PURGMAC  SUBR
          MACRO  SUBR,NAME
QQQ$RET   SET    *
          LJM    *
          ORG    *-1
NAME      DATA   0
          ENDM
          SPACE  5
** MACRO TO EXECUTE A RETURN FROM A SUBROUTINE
** IT MUST FOLLOW A SUBR DECLARATION
          PURGMAC  RETURN
RETURN    MACRO
M         IFGT   *-QQQ$RET,37B
          LJM    QQQ$RET
M         ELSE
          UJN    QQQ$RET
M         ENDIF
          ENDM
          SPACE  5
** MACRO TO PROVIDE QUALIFIED SYMBOL DEFINITION (HEX)
**  NAME=NAME TO QUALIFY IN DEFINITION
**  QUAL=QUALIFIES NAME
**  VALUE=HEX DIGIT STRING (0-9,A-F)
          SPACE  3
          MACRO  SYMDEFH,NAME,QUALS,VALUE
          QUAL   QUALS
NAME      EQU    0#_VALUE
          QUAL   *
          ENDM
          SPACE  5
** MACRO TO PROVIDE QUALIFIED SYMBOL DEFINITION (DEFAULT BASE)
** NAME=NAME TO QUALIFY IN DEFINITION
** QUALS=QUALIFIES NAME
** VALUE=DIGIT STRING (OCTAL OR DECIMAL OR HEX)
          SPACE  3
          MACRO  SYMDEF,NAME,QUALS,VALUE
          QUAL   QUALS
NAME      EQU    VALUE
          QUAL   *
          ENDM


* END IODMAC3
*DECK DECK=IODMAC4 EXPAND=FALSE
*BEGIN IODMAC4
          SPACE  5
*
** NAME-- LMK,LPK,LDK,ADK,ZJK,NJK,PJK,MJK,UJK
*
** PURPOSE-- DETERMINE FOR THOSE INSTRUCTIONS HAVING A SHORT AND LONG
*            FORM WHICH INSTRUCTION FORM NEEDS TO BE GENERATED.
*
** CALLING SEQUENCE-- SAME AS THE REGULAR PP INSTRUCTION
*
** RESTRICTIONS-- SYMBOLS REFERENCED BY THESE MACROS SHOULD BE
*                 DEFINED PRIOR TO THE MACRO CALL.
*
* NO-ADDRESS AND CONSTANT INSTRUCTIONS
NEWOP     ECHO   ,I=(LM,LP,LD,AD)
*
I_K       MACRO  P1
L         IF     DEF,P1
L         IFLE   P1,77B
L         IFGE   P1,0
          I_N    P1
L         ELSE   1
          I_C    P1
          ENDM
NEWOP     ENDD
*
*
*
* JUMP INSTRUCTIONS
NEWOP     ECHO   ,I=(ZJ,NJ,PJ,MJ),J=(NJ,ZJ,MJ,PJ)
*
I_K       MACRO  P1
L         IF     DEF,P1
L         IFGE   *-P1,0
L         IFLT   *-P1,40B
          I_N    P1
L         ELSE   2
          J_N    *+3
          LJM    P1
          ENDM
NEWOP     ENDD
*
*
*
UJK       MACRO  P1
L         IF     DEF,P1
L         IFGE   *-P1,0
L         IFLT   *-P1,40B
          UJN    P1
L         ELSE   1
          LJM    P1
          ENDM
          SPACE  6
** NAME-- AJM,SCF,IJM,CCF,FJM,SFM,EJM,CFM,IAN,IAM,OAN,OAM,ACN,DCN
*         FAN,FNC,FSJM,FCJM,IAPM,OAPM,CMCH,CHCM,MCLR
*
** PURPOSE-- REDEFINE I/O INSTRUCTIONS SO THAT THE ADDRESS OF CHANNEL
*            INSTRUCTIONS CAN BE SAVED IN A TABLE.
NEWOP     ECHO   ,OP=(AJM,SCF,IJM,DCN,FJM,SFM,EJM,CFM,IAN,IAM,OAN,OAM,AC
,N,FAN,FNC,FSJM,FCJM,IAPM,OAPM,CCF,CMCH,CHCM,MCLR)
*
 OP_.     OPSYN  OP          E.G.  IAN. = IAN
*
          PURGMAC OP
OP        MACRO  P1,P2
          LOCAL  TAG
L         IFC    EQ,$P2$$
TAG       OP_.   P1
T_P1      RMT                IAN,OAN,ACN,DCN,FAN
          CON    TAG
          RMT
L         ELSE
TAG       OP_.   P1,P2
T_P2      RMT                AJM,IJM,FJM,EJM,IAM,OAM,FCN,IAPM,OAPM,
                             SCF,CCF,SFM,CFM,FSJM,FCJM,CMCH,CHCM,MCLR
          CON    TAG
          RMT
L         ENDIF
OP        ENDM
NEWOP     ENDD
          SPACE  6
** NAME-- LOADC
*
** PURPOSE-- LOAD A CM ADDRESS INTO THE R AND A REGISTERS.
*
** CALLING SEQUENCE-- LOADC   CMR,CMA
*     CMR = ADDRESS OF THE 2-WORD CONTENTS TO BE LOADED INTO THE R REGISTER.
*           (IF CMA IS ABSENT, THEN CMR = ADDRESS OF THE 3-WORD CONTENTS.)
*     CMA = ADDRESS OF THE CONTENTS TO BE LOADED INTO THE A REGISTER.
*     BIT 17 OF THE A REGISTER IS ALSO SET UPON EXIT.
*     CMA IS OPTIONAL.

 LOADC    MACRO  CMR,CMA
 L        IFLE   CMR,77B
 L        IFGE   CMR,0
          LRD    CMR
 L        ELSE   5
          LDML   CMR
          STD    CMADR
          LDML   CMR+1
          STD    CMADR+1
          LRD    CMADR
 L        ENDIF
*
 P        IFC    NE,$CMA$$
 M        IFLE   CMA,77B
 M        IFGE   CMA,0
          LDDL   CMA
 M        ELSE   1
          LDML   CMA
 M        ENDIF
 P        ELSE
 Q        IFLE   CMR+1,77B
 Q        IFGE   CMR,0
          LDDL   CMR+2
 Q        ELSE
          LDML   CMR+2
 Q        ENDIF
 P        ENDIF
          LMC    400000B
          ENDM
          SPACE  6
** NAME--LOADR.
*
** PURPOSE-- LOAD A CM ADDRESS INTO THE R AND A REGISTERS.
*            AN INDEXED MEMORY LOCATION SPECIFIES THE ADDRESS.
*
** CALLING SEQUENCE-- LOADR   CMR,INDEX
*     THE 3-WORD CM ADDRESS IS CONTAINED IN THE LOCATIONS STARTING AT
*         CMR INDEXED BY INDEX.

 LOADR    MACRO  CMR,INDEX
 M        IFC    NE,$INDEX$$
          LDML   CMR,INDEX
          STD    CMADR
          LDML   CMR+1,INDEX
          STD    CMADR+1
          LRD    CMADR
          LDML   CMR+2,INDEX
          LMC    400000B
 M        ELSE
 X        IFNE   CMR,CMADR
          LDML   CMR
          STD    CMADR
          LDML   CMR+1
          STD    CMADR+1
 X        ENDIF
          LRD    CMADR
          LDML   CMR+2
          LMC    400000B
 M        ENDIF
          ENDM
          SPACE  6
** NAME--LOADF.
*
** PURPOSE-- REFORMAT A CM ADDRESS AND THEN LOAD IT INTO THE R AND A REGISTERS.
*
** CALLING SEQUENCE-- LOADF   CMR,INDEX
*     THE 2-WORD, UNFORMATTED CM ADDRESS IS CONTAINED IN THE LOCATIONS
*          STARTING AT CMR INDEXED BY INDEX.
*     INDEX IS OPTIONAL.
*
** FORMA IS CALLED WHICH PUTS THE REFORMATTED CM ADDRESS IN CMADR.

 LOADF    MACRO  CMR,INDEX
          LDK    CMR
 M        IFC    NE,$INDEX$$
          ADDL   INDEX
 M        ENDIF
          RJM    FORMA
          ENDM
          SPACE  6
** NAME-- REFAD.
*
** PURPOSE-- REFORMAT AND SAVE A CM ADDRESS.
*
** CALLING SEQUENCE-- REFAD   CMR,SAV
*     THE 2-WORD,UNFORMATTED CM ADDRESS IS CONTAINED IN THE LOCATIONS
*          STARTING AT CMR.
*     THE 3-WORD, REFORMATTED CM ADDRESS IS STORED IN THE LOCATIONS
*          STARTING AT SAV.
*
** FORMA AND SAVAD ROUTINES ARE CALLED.


 REFAD    MACRO  CMR,SAV
 L        IFLE   SAV,77B
 L        IFGE   SAV,0
          LOADF  CMR
          STDL   SAV+2
          SRD    SAV
 L        ELSE
          LDK    SAV
          STDL   T2
          LOADF  CMR
          RJM    SAVAD       SAVE THE RMA ADDRESS
 L        ENDIF
          ENDM
          SPACE  6
 PAUSE    MACRO  X           DELAY X MICROSECONDS
 M        IFLE   X,77B
          LDN    X
 M        ELSE
          LDC    X
 M        ENDIF
          RJM    PAUS        PROCESS THE DELAY
          ENDM
          SPACE  6
 MASKP    MACRO  FIELD
          LOCAL  X
 X        SET    16-N.FIELD-L.FIELD
          MGEN   N.FIELD
 MSK      SET    MASK$
          DUP    X
 MSK      SET    MSK+MSK
          ENDD
          ENDM
          SPACE  6
* END IODMAC4
*DECK DECK=IODMAC5 EXPAND=TRUE
*BEGIN  IODMAC5
 OVERLAY  SPACE  4,10
**        OVERLAY - DEFINE OVERLAY TITLE AND LOAD ADDRESS
*
*         THIS MACRO MUST BE THE FIRST LINE OF THE OVERLAY.
*         IT GENEERATES THE IDENT, TITLE, AND ORG PSEUDO
*         INSTRUCTIONS.  TAG OVLA MUST BE EQUATED TO A DEFAULT
*         LOAD ADDRESS IF THE SECOND VARIABLE ON THE OVERLAY
*         MACRO IS LEFT BLANK.

          PURGMAC OVERLAY
 ALPHABET MICRO  1,25,*ABCDEFGHIJKLMNOP*
 OVERLAY  MACRO  DESC,LOADADD
          LOCAL  AD
          QUAL
          NOREF  OVLN
 OVLL     SET    OVLL+1
          IFEQ   OVLL,21,2
          SET    1
 OVLU     SET    OVLU+1
 OVLN     SET    OVLU*20+OVLL-21
 CHL      MICRO  OVLL,1,*"ALPHABET"*
 CHU      MICRO  OVLU,1,*"ALPHABET"*
 NU       OCTMIC OVLN,2
 AD       OCTMIC LOADADD OVLA
          TITLE  "PRGNAM""CHU""CHL" ("NU") - DESC
          BASE   O
          IDENT  "PRGNAM""CHU""CHL","AD" "NU" DESC
          ORG    "AD"
          BASE   *
          ENDM
 OVLL     SET    1           INITIALIZE OVERLAY NUMBER
 OVLU     SET    1
 ROUTINE  SPACE  4,10
**        ROUTINE - DEFINE AN OVERLAY NAME AND NUMBER
*
*         THIS MACRO MUST BE USED WITHIN AN OVERLAY TO DEFINE
*         ITS NAME AND OVERLAY NUMBER.  BOTH OF THESE SYMBOLS
*         ARE REQUIRED BY THE LOADOVL MACRO.

          PURGMAC ROUTINE
 ROUTINE  MACRO  NAME
 NAME     BSS    0
 NAME_O   EQU    OVLN
          ENDM
 LOADOVL  SPACE  4,10
**        LOADOVL - LOAD AN OVERLAY
*
*         THIS MACRO LOADS AN OVERLAY WHOSE NAME WAS DEFINED BY A
*         ROUTINE MACRO.  THIS MACRO REQUIRES 4 CONSECUTIVE DIRECT
*         CELLS.  THE FIRST ONE MUST HAVE A TAG NAME OF T1.  ALSO,
*         THREE CONSECUTIVE LOCATIONS BEGINNING WITH TAG DH MUST
*         CONTAIN THE REFORMATTED RMA OF THE OVERLAY DIRECTORY.
*           DH - BITS 21-31 OF THE DIRECTORY RMA RIGHT JUSTIFIED
*           DH+1 - BITS 9-20 OF THE DIRECTORY RMA RIGHT JUSTIFIED
*           DH+2 - BITS 3-8 OF THE DIRECTORY RMA RIGHT JUSTIFIED

          PURGMAC LOADOVL
 LOADOVL  MACRO  NAME
          LDN    NAME_O
          RJM    LNO         LOAD NEXT OVERLAY
          ENDM
*END IODMAC5
*DECK DECK=IODMAC6 EXPAND=TRUE
*BEGIN IODMAC6
          SPACE  4,10
**        LNO - LOAD NEXT OVERLAY
*
*         ENTRY (A) = OVERLAY NUMBER
*               (DH-DH+2) = RMA POINTER TO OVERLAY DIRECTORY

 LNOX     LJM    **
 LNO      EQU    *-1
          STML   LNO20       SAVE OVERLAY NUMBER
          LOADC  DH          LOAD REGISTERS WITH DIRECTORY RMA
          ADML   LNO20       OFFSET INTO DIRECTORY
          CRDL   T1          READ DIRECTORY WORD FOR THE OVERLAY
          LDDL   T3          OVERLAY NUMBER
          SBML   LNO20       COMPARE WITH EXPECTED NUMBER
          NJN    *           IF WRONG OVERLAY NUMBER
          LDDL   T1
          STML   LNO10       STARTING ADDRESS TO STORE OVERLAY
          LDDL   T4          OFFSET FROM DIRECTORY TO OVERLAY
          ADML   DH+2
          ADC    400001B     ALLOW FOR HEADER
          CRML   **,T2       INPUT OVERLAY FROM CENTRAL MEMORY
 LNO10    EQU    *-1
          UJK    LNOX
 LNO20    BSS    1
*END IODMAC6
*DECK DECK=IOE$ST_ERRORS EXPAND=FALSE
*copyc ioc$condition_limits

  CONST
    ioc$st_errors = ioc$disk_min_ecc,
    ioe$unrecovered_disk_error = ioc$st_errors + 1,
    ioc$unrecovered_disk_error = ioc$st_errors + 1,
    ioc$pp_not_configured = ioc$st_errors + 2,
    ioc$pp_interlock_set = ioc$st_errors + 3,
    ioc$no_space_to_allocate = ioc$st_errors + 4,
    ioc$invalid_image_request = ioc$st_errors + 5,
    ioc$invalid_disk_type = ioc$st_errors + 6,
    ioc$disk_media_error = ioc$st_errors + 7,
    ioe$requests_full = ioc$st_errors + 8,
    ioe$unable_to_build_io_request = ioc$st_errors + 9,
    ioe$free_failure = ioc$st_errors + 10,
    ioe$address_error = ioc$st_errors + 11,
    ioe$unable_to_unlock_rma_list = ioc$st_errors + 12,
    ioe$unable_to_set_system_flag = ioc$st_errors + 13,
    ioe$allocation_failure = ioc$st_errors + 14,
    ioe$unable_to_queue_io_request = ioc$st_errors + 15,
    ioe$unable_to_destroy_io_req = ioc$st_errors + 16,
    ioe$io_completion_table_error = ioc$st_errors + 17,
    ioe$unsupported_monitor_request = ioc$st_errors + 18,
    ioe$request_id_mismatch = ioc$st_errors + 19,
    ioe$io_request_error = ioc$st_errors + 20,
    ioe$ssiot_recovery_required = ioc$st_errors + 21,
    ioe$unit_disabled = ioc$st_errors + 22,
    ioc$critical_device_disabled = ioc$st_errors + 23,
    ioc$no_idle_response = ioc$st_errors + 24,
    ioe$task_missing = ioc$st_errors + 25,
    ioe$foreign_interface_down = ioc$st_errors + 26;
  CONST
    ioc$subsystem_io_manager = 'IO';
*DECK DECK=IOE$TAPE_IO_CONDITIONS EXPAND=FALSE
*copyc ioc$condition_limits

  CONST
    ioc$min_tape_io = ioc$tape_min_ecc;

  CONST
{ Tape I/O conditions. }
     ioc$block_size_too_large = ioc$min_tape_io + 28,
     ioc$block_size_too_small = ioc$min_tape_io + 29,
     ioc$improper_ad_mode = ioc$min_tape_io + 20,
     ioc$improper_byte_count = ioc$min_tape_io + 30,
     ioc$improper_data_address = ioc$min_tape_io + 31,
     ioc$improper_density = ioc$min_tape_io + 21,
     ioc$improper_disable_hard_cor = ioc$min_tape_io + 22,
     ioc$improper_system_file_id = ioc$min_tape_io + 40,
     ioc$improper_inhibit_err_recov = ioc$min_tape_io + 50,
     ioc$improper_io_id = ioc$min_tape_io + 60,
     ioc$improper_max_block_length = ioc$min_tape_io + 26,
     ioc$improper_min_block_length = ioc$min_tape_io + 23,
     ioc$improper_parity = ioc$min_tape_io + 24,
     ioc$improper_sequence = ioc$min_tape_io + 70,
     ioc$improper_block_count = ioc$min_tape_io + 80,
     ioc$improper_translator = ioc$min_tape_io + 25,
     ioc$os_failure = ioc$min_tape_io,
     ioc$outstanding_io = ioc$min_tape_io + 90,
     ioc$page_unavailable = ioc$min_tape_io + 100,
     ioc$request_not_found = ioc$min_tape_io + 110,
     ioc$unit_in_use = ioc$min_tape_io + 120,
     ioc$unrecognized_unit_id = ioc$min_tape_io + 130,
     ioc$reposition_failure = ioc$min_tape_io + 140,
     ioc$tape_position_loss = ioc$min_tape_io + 150,
     ioc$tape_io_incomplete = ioc$min_tape_io + 160,
     ioc$tape_pp_q_locked = ioc$min_tape_io + 2;

  CONST
{ Tape I/O conditions. }
     ioe$block_size_too_large = ioc$min_tape_io + 28,
     {E +I +C +T }
     ioe$block_size_too_small = ioc$min_tape_io + 29,
     {E +I +C +T }
     ioe$improper_ad_mode = ioc$min_tape_io + 20,
     {E +I +C +T }
     ioe$improper_byte_count = ioc$min_tape_io + 30,
     {E +I +C +T }
     ioe$improper_data_address = ioc$min_tape_io + 31,
     {E +I +C +T }
     ioe$improper_density = ioc$min_tape_io + 21,
     {E +I +C +T }
     ioe$improper_disable_hard_cor = ioc$min_tape_io + 22,
     {E +I +C +T }
     ioe$improper_system_file_id = ioc$min_tape_io + 40,
     {E +I +C +T }
     ioe$improper_inhibit_err_recov = ioc$min_tape_io + 50,
     {E +I +C +T }
     ioe$improper_io_id = ioc$min_tape_io + 60,
     {E +I +C +T }
     ioe$improper_max_block_length = ioc$min_tape_io + 26,
     {E +I +C +T }
     ioe$improper_min_block_length = ioc$min_tape_io + 23,
     {E +I +C +T }
     ioe$improper_parity = ioc$min_tape_io + 24,
     {E +I +C +T }
     ioe$improper_sequence = ioc$min_tape_io + 70,
     {E +I +C +T }
     ioe$improper_block_count = ioc$min_tape_io + 80,
     {E +I +C +T }
     ioe$improper_translator = ioc$min_tape_io + 25,
     {E +I +C +T }
     ioe$os_failure = ioc$min_tape_io + 00,
     {E +I +C +T }
     ioe$outstanding_io = ioc$min_tape_io + 90,
     {E +I +C +T }
     ioe$page_unavailable = ioc$min_tape_io + 100,
     {E +I +C +T }
     ioe$request_not_found = ioc$min_tape_io + 110,
     {E +I +C +T }
     ioe$unit_in_use = ioc$min_tape_io + 120,
     {E +I +C +T }
     ioe$unrecognized_unit_id = ioc$min_tape_io + 130,
     {E +I +C +T }
     ioe$reposition_failure = ioc$min_tape_io + 140,
     {E +I +C +T }
     ioe$tape_position_loss = ioc$min_tape_io + 150,
     {E +I +C +T }
     ioe$tape_io_incomplete = ioc$min_tape_io + 160,
     {E +I +C +T }
     ioe$tape_rma_list_overflow = ioc$min_tape_io + 170,
     {E +I +C +T }
     ioe$tape_unit_disabled = ioc$min_tape_io + 180,
     {E +I +C +T }

     ioe$tape_job_recovery = ioc$min_tape_io + 185,
     {E Job recovery occurred on tape file, repositioning required.}

     ioe$too_many_tapes_defined = ioc$min_tape_io + 190,
     {E More than 255 tape units are defined in the configuration.}

     ioe$task_terminated_during_rec = ioc$min_tape_io + 195,
     {E Task termination occurred during tape error recovery.}

     ioe$tape_pp_q_locked = ioc$min_tape_io + 02;
     {E +I +C +T }

*DECK DECK=IOH$BACKSPACE_TAPE EXPAND=FALSE
{}
{  The purpose of this request is to space backward a number of physical
{ blocks on magnetic tape.
{}
{       IOP$BACKSPACE_TAPE (SYSTEM_FILE_ID, BLOCK_COUNT, IO_ID, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This parameter specifies the system
{       file identifier of the file.
{}
{ BLOCK_COUNT: (input) This parameter specifies the number of blocks to
{       space over.
{}
{ IO_ID: (output) This parameter specifies the identifer of this I/O
{       request.
{}
{ STATUS: (output) This parameter specifies the request status.
{       Condition:
{               ioc$improper_block_count
{               ioc$improper_sequence
{               ioc$improper_system_file_id
{               ioc$os_failure
{       Identifier: ioc$physical_io
{}


*DECK DECK=IOH$BUILD_PP_QUEUE_REQ_R2 EXPAND=FALSE


*DECK DECK=IOH$BUILD_RMA_LIST EXPAND=FALSE
{
{    This request is used to translate a list of pvas and associated lengths
{  to their corresponding rmas and associated lengths.  The pages
{  associated with the pvas must be locked down prior to calling this
{  procedure.
{
{          CMP$BUILD_RMA_LIST (PVA_LIST_P, RMA_LIST_P, RMA_LIST_LENGTH)
{
{  PVA_LIST_P: (input)  This parameter is a pointer to a list of pvas and
{                       associated lengths to be translated to rmas and
{                       associated lengths.
{
{  RMA_LIST_P: (input/output)  This parameter is a pointer to the rma list to
{                              be returned.
{
{  RMA_LIST_LENGTH: (input)  This parameter specifies the number of entries in
{                            the rma list.
{
*DECK DECK=IOH$DESTROY_PP_QUEUE_REQ_R2 EXPAND=FALSE


*DECK DECK=IOH$ERASE_TAPE EXPAND=FALSE
{}
{  The purpose of this request is to erase the amount of tape specified
{       by the caller in number of bytes.  The minimum erased area is
{       approximately 3 inches.
{}
{       IOP$ERASE_TAPE (SYSTEM_FILE_ID, BLOCK_LENGTH, IO_STATUS, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This parameter specifies the system
{       file identification of the file.
{}
{ BLOCK_LENGTH: (input) This parameter specifies, in bytes, the amount
{       of tape to be erased.  Only used if number_of_erases = 0.
{}
{ NUMBER_OF_ERASES: (input) This parameter is used to erase a specific
{       amount of tape independent of density.  If this parameter is
{       non-zero, it will be used instead of block_length.
{}
{ IO_STATUS: (output) This parameter specifies the I/O status of the
{       request.  Callers of this deck should NOT request I/O status
{       by calling iop$tape_request_status since this VAR parameter
{       provides that status.
{}
{ STATUS: (output) This parameter specifies the request status.
{       Condition:
{               ioc$improper_sequence
{               ioc$improper_system_file_id
{               ioc$os_failure
{       Identifier: ioc$physical_io.
{}
*DECK DECK=IOH$FETCH_TAPE_CAPABILITIES EXPAND=FALSE
{}
{  The purpose of this request is to return information about the requested
{       tape unit to the caller.
{}
{       IOP$FETCH_TAPE_CAPABILITIES (SYSTEM_FILE_ID, MAXIMUM_BLOCK_LENGTH,
{             MAX_BLOCKS_PER_PHYSICAL_CALL, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This parameter specifies the system
{       file identification of the file.
{}
{ MAXIMUM_BLOCK_LENGTH: (output) This parameter specifies, in bytes, the maximum
{       block length supported on the requested tape unit.
{}
{ MAX_BLOCKS_PER_PHYSICAL_CALL: (output) This parameter specifies the maximum number
{       of blocks read or written per request to the PP.
{}
{ STATUS: (output) This parameter specifies the request status.
{       Condition:
{               ioc$improper_sequence
{               ioc$improper_system_file_id
{               ioc$os_failure
{       Identifier: ioc$physical_io.
{}
*DECK DECK=IOH$FORMAT_TAPE_UNIT EXPAND=FALSE
{}
{  The purpose of this request is to format the unit for subsequent I/O
{ operations to the unit.
{}
{       IOP$FORMAT_TAPE_UNIT (SYSTEM_FILE_ID, FORMAT, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This parameter specifies the system
{       file identification of the file.
{}
{ FORMAT: (input) This parameter specifies the new format information.
{}
{ STATUS: (output) This parameter specifies the request status.
{       Condition:
{               ioc$improper_density
{               ioc$improper_min_block_length
{               ioc$improper_system_file_id
{               ioc$improper_translator
{               ioc$os_failure
{               ioc$outstanding_io
{       Identifier: ioc$physical_io
{}


*DECK DECK=IOH$FORSPACE_TAPE EXPAND=FALSE
{}
{  The purpose of this request is to space forward a number of physical
{ blocks on magnetic tape.
{}
{       IOP$FORSPACE_TAPE (SYSTEM_FILE_ID, BLOCK_COUNT, IO_ID, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This parameter specifies the system
{       file identifier of the file.
{}
{ BLOCK_COUNT: (input) This parameter specifies the number of blocks to
{       space over.
{}
{ IO_ID: (output) This parameter specifies the identifer of this I/O
{       request.
{}
{ STATUS: (output) This parameter specifies the request status.
{       Condition:
{               ioc$improper_block_count
{               ioc$improper_sequence
{               ioc$improper_system_file_id
{               ioc$os_failure
{       Identifier: ioc$physical_io
{}


*DECK DECK=IOH$INITIALIZE_TAPE_UNIT EXPAND=FALSE
{}
{  The purpose of this request is to initialize a tape unit.  It must be
{ done after each assign and before any I/O operations are done to a unit.
{}
{       IOP$INITIALIZE_TAPE_UNIT (^TAPE_FILE_DESCRIPTOR, LOGICAL_UNIT_NUMBER,
{         STATUS)
{}
{ TAPE_FILE_DESCRIPTOR: (input) Pointer to the descriptor for the tape file.
{}
{ LOGICAL_UNIT_NUMBER: (input) This parameter specifies the unit to be
{       initialized.
{}
{ STATUS: (output) This parameter specifies the request status.
{       Condition:
{               ioc$unrecognized_unit_id
{               ioc$improper_sequence
{       Identifier: ioc$physical_io.
{}


*DECK DECK=IOH$MASS_STORAGE_IO EXPAND=FALSE
{}
{   This request is used by the Device Manager to perform disk I/O.
{}
{       IOP$MASS_STORAGE_IO (PVA, LENGTH, IO_FUNCTION, DEVICE_ADDRESS,
{         STATUS);
{}
{ PVA: (input) This parameter specifies the pva of the buffer which
{       contains the data to be transferred.
{}
{ LENGTH: (input) This parameter specifies the number of bytes to
{       transfer.
{}
{ IO_FUNCTION: (input) This parameter specifies the type of I/O
{       function to be performed.
{}
{ DEVICE_ADDRESS: (input) This parameter specifies the logical
{       address on the device in which to start data transfer.
{}
{ STATUS: (output) This parameter specifies the request status.
{}
*DECK DECK=IOH$MFH_SUBSYSTEM_IO_COMPLETION EXPAND=FALSE
{
{  The purpose of this procedure is to move the wired pp response to the
{  response area specified in the unit queue request entry.  After the wired
{  response area has been moved and an appropriate status set in the
{  io completion table, the wired part of the unit queue request entry will be
{  freed.
{
{          IOP$MFH_SUBSYSTEM_IO_COMPLETION (FLAG_ID)
{
{  FLAG_ID: (input)  This parameter specifies the flag identification the
{                    handler is to process.
{
*DECK DECK=IOH$MTR_SET_STATUS_ABNORMAL EXPAND=FALSE
{
{      The purpose of this request is to set an abnormal status condition
{ when running in monitor mode.
{
{      IOP$MTR_SET_STATUS_ABNORMAL (CONDITION, TEXT, STATUS)
{
{ CONDITION:(input)  this parameter specifies the abnormal condition
{      indication to be placed in the status record.
{
{  TEXT:(input)  This parameter specifies a message text.
{
{ STATUS:(output)  This parameter is the status record to be modified.
{
*DECK DECK=IOH$PAGER_IO EXPAND=FALSE
{}
{   This request is used by Memory Manager to perform an IO transfer.
{}
{       IOP$PAGER_IO (SYSTEM_FILE_ID, JOB_ID, CHAPTER, CHAPTER_OFFSET,
{         BUFFER_DESCRIPTOR, LENGTH, IO_FUNCTION, STATUS);
{}
{ SYSTEM_FILE_ID: (input) This parameter specifies the
{       identity of the file.
{}
{ JOB_ID: (input) This parameter specifies the
{       identity of the job.
{}
{ CHAPTER: (input) This parameter specifies the
{       chapter_number.
{}
{ CHAPTER_OFFSET: (input) This parameter specifies the beginning
{       byte address to/from which data will be transferred from/to the
{       device.  The page frames must already be assigned.
{       There is no requirement on the lock attribute of
{       a page.  This address must be on a mau boundary.
{}
{ BUFFER_DESCRIPTOR: (input) This parameter specifies the
{       buffer_descriptor used to lock pages.
{}
{ LENGTH: (input) This parameter specifies the number of
{       bytes to transfer.  If the request involves more than one
{       allocation unit, the request will be rejected.
{}
{ IO_FUNCTION: (input) This parameter specifies the type of IO
{       function to be performed.
{}
{ STATUS: (output) This parameter specifies the request status.
{}
*DECK DECK=IOH$PROCESS_ABNORMAL_RESPONSE EXPAND=FALSE
{
{  This request is used to process an abnormal pp response.
{
*DECK DECK=IOH$PROCESS_IO_COMPLETIONS EXPAND=FALSE
{}
{   This request is used by Monitor to process the completion
{       of pp requests.
{}
{       IOP$PROCESS_IO_COMPLETIONS (EIFLAG);
{}
{ EIFLAG: (output) If eiflag = false, Monitor will not call
{       iop$process_io_completions.
{}
*DECK DECK=IOH$QUEUE_PP_REQUEST_R1 EXPAND=FALSE
{
{    This request is used to link a pp request queue entry into a pp
{  queue.
{
{          IOP$QUEUE_PP_REQUEST_R1 (REQUEST_ID, QUEUE_CONTROL, RECOVERY_OPTIONS,
{                                   READY_TASK_UPON_IO_COMPLETION, STATUS)
{
{  REQUEST_ID: (input)  This parameter specifies the operating system identification
{                        that is associated with the pp queue request.
{
{  QUEUE_CONTROL: (input)  This parameter specifies the manner in which
{                          to link this request into the request queue.
{
{  RECOVERY_OPTIONS: (input)  This parameter specifies the type of recovery
{                             to associate with this request.
{
{  READY_TASK_UPON_IO_COMPLETION  :  (input)  This parameter specifies whether or not
{                                             to ready the task upon completion of the io
{                                             request.
{
{  STATUS: (output)  This parameter returns the request status.
{
*DECK DECK=IOH$READ_TAPE EXPAND=FALSE
{}
{  The purpose of this request is to read a number of physical blocks
{ from magnetic tape.
{}
{       IOP$READ_TAPE (SYSTEM_FILE_ID, INHIBIT_ERROR_RECOVERY,
{         MAX_BYTE_COUNT, BLOCK_DESCRIPTION, NO_OF_BLOCKS_TO_READ,
{         IO_ID, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This parameter specifies the system
{       file identification of the file.
{}
{ INHIBIT_ERROR_RECOVERY: (input) This parameter specifies whether
{       I/O recovery is to be attempted in the event of a parity error.
{}
{ MAX_BYTE_COUNT: (input) This parameter specifies the maximum number
{       of bytes to read from a given block.
{}
{ BLOCK_DESCRIPTION: (input)
{       This parameter specifies the address of the start of each buffer
{       area into which a block will be read and the address of where
{       the transfer_count will be stored for each block read.
{}
{ NO_OF_BLOCKS_TO_READ: (input)
{        This parameter specifies the number of blocks to read, that is
{        the number of address/length pairs in the block_description.
{}
{ IO_ID: (output) This parameter specifies the identifier of this I/O
{       request.  The identifier is needed to determine the status of
{       the I/O request.
{}
{ STATUS: (output) This parameter specifies the request status.
{       Condition:
{               ioc$improper_block_count
{               ioc$improper_byte_count
{               ioc$improper_data_address
{               ioc$improper_sequence
{               ioc$improper_system_file_id
{               ioc$os_failure
{               ioc$page_unavailable
{       Identifier: ioc$physical_io.
{}

*DECK DECK=IOH$RETURN_WIRED_REQUEST EXPAND=FALSE
{
{     This request is used to return a wired unit queue request.
{
{          IOP$RETURN_WIRED_REQUEST (JOB_IO_COMPLETION_QUEUE_INDEX,
{                                    STATUS)
{
{  JOB_IO_COMPLETION_QUEUE_INDEX: (input/output)  This parameter specifies the
{                                   job io completion queue index whose
{                                   associated wired unit queue request is to
{                                   be released.
{
{  STATUS: (output)  This parameter returns the request status.
{

*DECK DECK=IOH$REWIND_TAPE EXPAND=FALSE
{}
{  The purpose of this request is to rewind the tape to load point.
{}
{       IOP$REWIND_TAPE (SYSTEM_FILE_ID, IO_ID, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This parameter specifies the system
{       file identification of the file.
{}
{ IO_ID: (output) This parameter specifies the identifier of this I/O
{       request.  The identifier is needed to determine the status of
{       the I/O request.
{}
{ STATUS: (output) This parameter specifies the request status.
{       Condition:
{               ioc$improper_system_file_id
{               ioc$os_failure
{       Identifier: ioc$physical_io.
{}


*DECK DECK=IOH$SET_QUEUE_LOCKWORD EXPAND=FALSE
{
{    The purpose of this procedure is to set a defined compare_swap lock
{  when the user knows the initial contents fo the lock.
{
{          IOP$SET_QUEUE_LOCKWORD (QUEUE_LOCKWORD, INITIAL_VALUE, FINAL_VALUE,
{                          ACTUAL_VALUE, LCOK_SET)
{
{  LOCK_SET: (output)  This parameter specifies whether the queue lock was
{                      successfully set or not.
{
*DECK DECK=IOH$SET_STATUS_ABNORMAL EXPAND=FALSE
{
{      This request is used to set status for io modules in r1 - r3.
{
{          IOP$SET_STATUS_ABNORMAL (CONDITION, TEXT, STATUS)
{
{  CONDITION: (input)  This parameter specifies the condition code to
{                      set in the status record.
{
{  TEXT: (input)  This parameter specifies text to be set in the status
{                 record.
{
{  STATUS: (input/output)  This parameter specifies the status record in which
{                          in which the various fields will be set.
{


*DECK DECK=IOH$SET_SUBSYSTEM_IO_STATUS EXPAND=FALSE
{
{    This request is used to set a subsystem io response status in a subsystem
{  io response record.
{
{          CMP$SET_SUBSYSTEM_IO_STATUS (IO_STATUS_P, NEW_SUBSYSTEM_IO_STATUS,
{                               NEW_SUBSYSTEM_IO_STATUS_SET)
{
{  IO_STATUS_P: (input)  This parameter specifies the subsystem io response
{                        record in which the status will be set.
{
{  NEW_SUBSYSTEM_IO_STATUS: (input)  This parameter is the status to set in
{                                    the subsystem io response record.
{
{  NEW_SUBSYSTEM_IO_STATUS_SET: (output)  This parameter returns the result
{                                         of the request.
{
*DECK DECK=IOH$SKIP_TAPEMARK_BACKWARD EXPAND=FALSE
{}
{  The purpose of this request is to skip backward a number of physical
{ tape marks on magnetic tape.
{}
{       IOP$SKIP_TAPEMARK_BACKWARD (SYSTEM_FILE_ID, FILE_COUNT, IO_ID, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This parameter specifies the system
{       file identifier of the file.
{}
{ FILE_COUNT: (input) This parameter specifies the number of tape marks to
{       skip backward.
{}
{ IO_ID: (output) This parameter specifies the identifer of this I/O
{       request.
{}
{ STATUS: (output) This parameter specifies the request status.
{       Condition:
{               ioc$improper_block_count
{               ioc$improper_sequence
{               ioc$improper_system_file_id
{               ioc$os_failure
{       Identifier: ioc$physical_io
{}
*DECK DECK=IOH$SKIP_TAPEMARK_FORWARD EXPAND=FALSE
{}
{  The purpose of this request is to skip forward a number of physical
{ tape marks on magnetic tape.
{}
{       IOP$SKIP_TAPEMARK_FORWARD (SYSTEM_FILE_ID, FILE_COUNT, IO_ID, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This parameter specifies the system
{       file identifier of the file.
{}
{ FILE_COUNT: (input) This parameter specifies the number of tape marks to
{       skip forward.
{}
{ IO_ID: (output) This parameter specifies the identifer of this I/O
{       request.
{}
{ STATUS: (output) This parameter specifies the request status.
{       Condition:
{               ioc$improper_block_count
{               ioc$improper_sequence
{               ioc$improper_system_file_id
{               ioc$os_failure
{       Identifier: ioc$physical_io
{}


*DECK DECK=IOH$SUBSYSTEM_QUEUE_REQUEST EXPAND=FALSE
{
{     This request is used to queue a request to the associated unit
{  request queue.
{
{          IOP$SUBSYSTEM_QUEUE_REQUEST (REQUEST_BLOCK)
{
*DECK DECK=IOH$TAPE_PROCESS_RESPONSE EXPAND=FALSE
{}
{  The purpose of this request is to process the response of a previous
{ request.  This procedure is called to execute in monitor mode, completes
{ the entries in the response queue, places a waiting response in the
{ completion queue, and unlocks any pages involved in a data transfer
{ request.
{}
{       IOP$TAPE_PROCESS_PP_RESPONSE (PP_RESPONSE_HEADER_P,
{         DETAILED_STATUS_P, PP_NUMBER, MON_STATUS)
{}
{ PP_RESPONSE_P: (input) This parameter specifies an address of the
{       information contained in the peripheral response header.
{}
{ DETAILED_STATUS_P: (input) This parameter specifies an address of
{       the tape device detailed status information.
{}
{ PP_NUMBER: (input) This parameter specifies the periferal number
{       involved in this request/response.
{}
{ MON_STATUS: (output) this parameter specifies the request status.
{}
*DECK DECK=IOH$TAPE_QUEUE_REQUEST EXPAND=FALSE
{}
{  The purpose of this request is to lock those pages in memory that
{ were allocated for the buffers involved with any data transfers. The
{ necessary real memory addresses required by the PP are derived and
{ placed in the appropriate interface tables and parameter areas.
{ Finally, the unit request queue lockword is set, the request placed
{ on the unit queue, and the lockword is cleared.  This procedure
{ executes in monitor mode.
{}
{       IOP$TAPE_QUEUE_REQUEST (REQUEST_BLOCK)
{}
{ REQUEST_BLOCK: (input) This parameter provides the request block that
{       is placed in the unit request queue.  The request block also
{       provides the descriptors for any data transfers and any further
{       parameter areas.
{}
*DECK DECK=IOH$TAPE_QUEUE_REQUEST_SETUP EXPAND=FALSE
{}
{  The purpose of this request is to complete the initialization of
{ the request block information, allocate the necessary areas in wired
{ memory, and set up those areas with the tables required to interface
{ to the PP.  Those tables include the portion of the request block
{ presented to the PP, the response buffer, the various block
{ descriptors, etc.  This procedure makes the monitor call to
{ iop$tape_queue_request.
{}
{       IOP$TAPE_QUEUE_REQUEST_SETUP (TAPE_REQUEST_P, STATUS)
{}
{ TAPE_REQUEST_P: (input) This parameter specifies the address of the
{       request block that exists in mainframe_pageable_heap.
{}
{ STATUS: (output) This parameter specifies the request status.
{       condition:
{               ioc$outstanding_io
{               ioc$tape_pp_q_locked
{               ioc$os_failure
{       identifier: ioc$physical_io
{}
*DECK DECK=IOH$TAPE_REQUEST_STATUS EXPAND=FALSE
{}
{  The purpose of this request is to obtain the status of the designated
{ tape I/O operation.
{}
{       IOP$TAPE_REQUEST_STATUS (SYSTEM_FILE_ID, IO_ID, IO_STATUS, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This parameter specifies the system
{       file identification of the file.
{}
{ IO_ID: (input) This parameter identifies the I/O request
{       for which the present status is desired.
{}
{ IO_STATUS: (output) This parameter specifies the status of the identified
{       tape I/O request.
{}
{ STATUS: (output) This parameter specifies the request status.
{       Condition:
{               ioc$improper_io_id
{               ioc$improper_system_file_id
{               ioc$io_request_not_found
{               ioc$tape_io_incomplete
{               ioc$os_failure
{       Identifier: ioc$physical_io
{}
    { Is a wait for response option desired? }
    { If yes,  wait: ost$wait in deck OSDWNW can be used. }
*DECK DECK=IOH$TAPE_RETURN_WIRED_REQUEST EXPAND=FALSE
{}
{  The purpose of this request is to free the areas of memory that were
{ allocated in MAINFRAME WIRED HEAP for this request.
{}
{       IOP$TAPE_RETURN_WIRED_REQUEST (I, IO_ID, TAPE_REQUEST_P,
{         STATUS)
{}
{ I: (input) This parameter specifies the index into the completion
{       queue table that will eventually indicate that a response is
{       waiting from a completed request.
{}
{ IO_ID: (input) This parameter specifies  the identifier of this I/O
{       request.
{}
{ TAPE_REQUEST_P: (input, output) This parameter specifies the address
{       of the request block.
{}
{ STATUS: (output) This parameter specifies the request status.
{}
*DECK DECK=IOH$UNLOAD_TAPE EXPAND=FALSE
{}
{  The purpose of this request is to unload the tape.
{}
{       IOP$UNLOAD_TAPE (SYSTEM_FILE_ID, IO_ID, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This parameter specifies the system
{       file identification of the file.
{}
{ IO_ID: (output) This parameter specifies the identifier of this I/O
{       request.  The identifier is needed to determine the status of
{       the I/O request.
{}
{ STATUS: (output) This parameter specifies the request status.
{       Condition:
{               ioc$improper_system_file_id
{               ioc$os_failure
{       Identifier: ioc$physical_io.
{}


*DECK DECK=IOH$UNSOLICITED_SUBSYSTEM_RESP EXPAND=FALSE
{
{    This request is used to process unsolicited subsystem io responses.
{
{         IOP$UNSOLICITED_SUBSYSTEM_RESP (PP_RESPONSE_P, DETAILED_STATUS_P,
{                            PP_NUMBER, STATUS)
{
{  PP_RESPONSE_P: (input)  This parameter specifies the pp response.
{
{  DETAILED_STATUS_P: (input)  This parameter specifies the detailed status
{                              associated with the response.
{
{  PP_NUMBER: (input)  This parameter specifies the number of the pp associated
{                      with the response.
{
{  STATUS: (output)  This parameter returns the request status.
{

*DECK DECK=IOH$WRITE_TAPE EXPAND=FALSE
{}
{  The purpose of this request is to write a number of physical blocks
{ to magnetic tape.
{}
{       IOP$WRITE_TAPE (SYSTEM_FILE_ID, INHIBIT_ERROR_RECOVERY,
{         BLOCK_DESCRIPTION, NO_OF_BLOCKS_TO_READ, IO_ID, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This parameter specifies the system
{       file identification of the file.
{}
{ INHIBIT_ERROR_RECOVERY: (input) This parameter specifies whether
{       I/O recovery is to be attempted in the event of a parity error.
{}
{ BLOCK_DESCRIPTION: (input)
{       This parameter specifies the address of the start of each buffer
{       area from which a block will be written and the length of the
{       block to be written.
{}
{ NO_OF_BLOCKS_TO_WRITE (input)
{       This parameter specifies the number of blocks to write on tape,
{       that is the number of address/length pairs in the block_description.
{}
{ IO_ID: (output) This parameter specifies the identifier of this I/O
{       request.  The identifier is needed to determine the status of
{       the I/O request.
{}
{ STATUS: (output) This parameter specifies the request status.
{       Condition:
{               ioc$improper_block_count
{               ioc$improper_byte_count
{               ioc$improper_data_address
{               ioc$improper_sequence
{               ioc$improper_system_file_id
{               ioc$os_failure
{               ioc$page_unavailable
{       Identifier: ioc$physical_io.
{}


*DECK DECK=IOH$WRITE_TAPEMARK EXPAND=FALSE
{}
{  The purpose of this request is to write a tapemark on magnetic tape.
{}
{       IOP$WRITE_TAPEMARK (SYSTEM_FILE_ID, IO_ID, STATUS)
{}
{ SYSTEM_FILE_ID: (input) This parameter specifies the system
{       file identification of the file.
{}
{ IO_ID: (output) This parameter specifies the identifier of this I/O
{       request.  The identifier is needed to determine the status of
{        the I/O request.
{}
{ STATUS: (output) This parameter specifies the request status.
{       Condition:
{               ioc$improper_sequence
{               ioc$improper_system_file_id
{               ioc$os_failure
{       Identifier: ioc$physical_io.
{}


*DECK DECK=IOI$TAPE_QUEUE_MANAGER EXPAND=FALSE
*copyc osd$default_pragmats
{
{
{ DECK: IOI$TAPE_QUEUE_MANAGER
{
{
{ This deck contains all of the source code for the modules IOM$TAPE_QUEUE_MANAGER_RING2
{ and IOM$TAPE_BOOT_MANAGER.  The version which gets compiled depends on the compile
{ time variable system_version.  If system_version := TRUE, the IOM$TAPE_QUEUE_MANAGER_RING2
{ version of the code is compiled.  If system_version := FALSE, then the
{ IOM$TAPE_BOOT_MANAGER version of the code is compiled.  The boot version of the code
{ differs from the system version in the following respects:
{
{ 1.  All ALLOCATE's and FREE's must be done in mainframe_pageable instead of job_pageable.
{
{ 2.  The procedures iop$establish_tape_statistics, iop$tape_error_logging,
{     iop$tape_usage_logging, iop$write_tape and iop$write_tapemark will contain no
{     code.  The procedures are retained but do nothing if called.
{
{ 3.  The beginning of procedure iop$initialize_tape_ud differs from the system version.
{
{ NOTE - because of the above, tape error and usage logging is disabled during deadstart.
{
{ The compile time variable system_version is assumed to be defined by the calling module.

?? OLDTITLE ??
?? NEWTITLE := ' global definitions ' ??
?? EJECT ??

*copyc bav$max_bytes_per_tape_io
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc iov$establish_tape_statistics
*copyc iov$number_of_tape_units
*copyc iov$tape_completion_q_table
*copyc iov$tusl_p
*copyc oss$job_paged_literal
*copyc osv$job_pageable_heap
*copyc osv$mainframe_pageable_heap
*copyc osv$mainframe_wired_heap
*copyc osv$page_size
? IF NOT system_version THEN
*copyc osv$deadstart_device_lun
? IFEND
?? PUSH (LISTEXT := ON) ??

*copyc bat$process_pt_results
*copyc dme$tape_errors
*copyc dmt$system_file_id
*copyc dmt$tape_initialization_record
*copyc clt$path_handle
*copyc fmp$process_pt_request
*copyc fmt$cycle_description
*copyc fmt$detachment_options
*copyc fst$evaluated_file_reference
*copyc fst$path
*copyc fst$path_size
*copyc fsv$evaluated_file_reference
*copyc ioc$max_num_tape_units
*copyc ioe$tape_io_conditions
*copyc iot$io_id
*copyc iot$io_request
*copyc iot$logical_unit
*copyc iot$no_of_tape_units
*copyc iot$pp_interface_table
*copyc iot$pp_number
*copyc iot$pp_response
*copyc iot$read_tape_description
*copyc iot$tape_block_count
*copyc iot$tape_block_id_area
*copyc iot$tape_collected_pp_response
*copyc iot$tape_command_table_entry
*copyc iot$tape_completion_packet
*copyc iot$tape_device_status
*copyc iot$tape_failure_statistic_data
*copyc iot$tape_job_statistic_data
*copyc iot$tape_job_unit_descriptor
*copyc iot$tape_position
*copyc iot$tape_request_types
*copyc iot$tape_usage_statistic_data
*copyc iot$tape_user_mesg_index
*copyc iot$unit_type
*copyc osd$integer_limits
*copyc osk$keypoints
*copyc osk$tape_keypoints
*copyc oss$job_pageable
*copyc ost$page_size
*copyc ost$signature_lock
*copyc ost$status
*copyc ost$wait
?? POP ??

?? OLDTITLE ??
?? NEWTITLE := ' tape failure data format ' ??
?? EJECT ??
*copyc iot$tape_statistics

?? OLDTITLE ??
?? NEWTITLE := ' xref definitions ' ??
?? EJECT ??
*copyc cmp$get_element_name_via_lun
*copyc cmh$return_descriptor_data
*copyc cmp$return_descriptor_data
? IF system_version THEN
*copyc dmp$convert_sfid_to_lun
? IFEND
*copyc iop$allocate_wired_tape_tables
*copyc iop$access_tusl_entry
*copyc iop$free_wired_tape_tables
*copyc iop$tape_clear_activate_stats
*copyc iop$tape_enable_ready_task
*copyc iop$tape_enable_taskid_check
*copyc iop$tape_queue_request_setup
*copyc iop$tape_request_not_processed
*copyc iop$tape_return_wired_request
*copyc i#move
*copyc osp$append_status_integer
*copyc osp$clear_job_signature_lock
*copyc osp$establish_condition_handler
*copyc osp$disestablish_cond_handler
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$continue_to_cause
*copyc pmp$delay
*copyc pmp$wait
*copyc sfp$activate_system_statistic
*copyc sfp$emit_statistic

?? OLDTITLE ??
?? NEWTITLE := ' module level VARS ' ??
?? EJECT ??
{The following VARS are placed at the module level to place the structures in the appropriate STATIC area.}
{The structures are also referenced by IOM$TAPE_BOOT_MANAGER and will be in WIRED for that module.}

  CONST
    max_store_unit_ready_attempts = 10,
    one_second = 1000 {milliseconds};

? IF system_version THEN

       VAR
         iov$p_statistic_data_p_array: [XDCL, STATIC]
               ^iot$statistic_data_p_array := NIL;

       VAR
         statistic_data_lock: [XDCL, STATIC] ost$signature_lock := [0];

? ELSE { do not XDCL boot version

       VAR
         iov$p_statistic_data_p_array: [STATIC]
               ^iot$statistic_data_p_array := NIL;

       VAR
         statistic_data_lock: [STATIC] ost$signature_lock := [0];

? IFEND

       VAR
? IF system_version THEN
         iov$67x_command_table: [STATIC, READ, oss$job_paged_literal] array [1 .. ioc$no_of_67x_commands]
? ELSE
         iov$67x_command_table: [STATIC] array [1 .. ioc$no_of_67x_commands]
? IFEND
           of tape_command_table_entry :=
           [[ioc$67x_cmd_pos_clear, ioc$tape_pkt_lng_clear, ioc$67x_func_clear],
           [ioc$67x_cmd_pos_rewind, ioc$tape_pkt_lng_rewind, ioc$67x_func_rewind],
           [ioc$67x_cmd_pos_unload, ioc$tape_pkt_lng_unload, ioc$67x_func_unload],
           [ioc$67x_cmd_pos_forspace, ioc$tape_pkt_lng_forspace, ioc$67x_func_forspace],
           [ioc$67x_cmd_pos_backspace, ioc$tape_pkt_lng_backspace, ioc$67x_func_backspace],
           [ioc$67x_cmd_pos_cont_backspace, ioc$tape_pkt_lng_cont_backspace, ioc$67x_func_cont_backspace],
           [ioc$67x_cmd_pos_read, ioc$tape_pkt_lng_read, ioc$67x_func_read],
           [ioc$67x_cmd_pos_read_backwards, ioc$tape_pkt_lng_read_backwards, ioc$67x_func_read_backwards],
           [ioc$67x_cmd_pos_write, ioc$tape_pkt_lng_write, ioc$67x_func_write],
           [ioc$67x_cmd_pos_loop1, ioc$tape_pkt_lng_loop1, ioc$67x_cmd_pos_loop1],
           [ioc$67x_cmd_pos_loop2, ioc$tape_pkt_lng_loop2, ioc$67x_func_loop2],
           [ioc$67x_cmd_pos_loop3, ioc$tape_pkt_lng_loop3, ioc$67x_func_loop3],
           [ioc$67x_cmd_pos_write_tapemark, ioc$tape_pkt_lng_write_tapemark, ioc$67x_func_write_tapemark],
           [ioc$67x_cmd_pos_erase, ioc$tape_pkt_lng_erase, ioc$67x_func_erase],
           [ioc$67x_cmd_pos_security_erase, ioc$tape_pkt_lng_security_erase, ioc$67x_func_security_erase],
           [ioc$67x_cmd_pos_master_clear, ioc$tape_pkt_lng_master_clear, ioc$67x_func_master_clear],
           [ioc$67x_cmd_pos_get_status, ioc$tape_pkt_lng_get_status, ioc$67x_func_get_status],
           [ioc$67x_cmd_pos_skip_tm_f, ioc$tape_pkt_lng_skip_tm_f, ioc$67x_func_skip_tm_f],
           [ioc$67x_cmd_pos_skip_tm_b, ioc$tape_pkt_lng_skip_tm_b, ioc$67x_func_skip_tm_b]],

? IF system_version THEN
         zero_ccc_cart_bid: [STATIC, READ, oss$job_paged_literal] iot$cartridge_tape_bid := [0, 0];
? ELSE
         zero_ccc_cart_bid: [STATIC] iot$cartridge_tape_bid := [0, 0];
? IFEND

?? OLDTITLE ??
?? NEWTITLE := ' convert_sfid_to_lun ' ??
?? EJECT ??

  PROCEDURE [INLINE] convert_sfid_to_lun (
        system_file_id: dmt$system_file_id;
    VAR logical_unit_number: iot$logical_unit;
    VAR status: ost$status);

? IF system_version THEN
    dmp$convert_sfid_to_lun (system_file_id, logical_unit_number, status);
? ELSE
    logical_unit_number := osv$deadstart_device_lun;
? IFEND

  PROCEND convert_sfid_to_lun;

?? OLDTITLE ??
?? NEWTITLE := ' iop$set_current_heap ' ??
?? EJECT ??

  PROCEDURE [INLINE] iop$set_current_heap (VAR current_heap: ^ost$heap);

? IF system_version THEN
    current_heap := osv$job_pageable_heap;
? ELSE
    current_heap := osv$mainframe_pageable_heap;
? IFEND

  PROCEND iop$set_current_heap;

?? OLDTITLE ??
?? NEWTITLE := ' iop$67x_non_data_trans_setup ' ??
?? EJECT ??

  PROCEDURE iop$67x_non_data_trans_setup (tape_unit_number: iot$logical_unit;
        tape_request_type: iot$tape_request_types;
        repeat_count: iot$tape_block_count;
        pp_unit_disable: boolean;
        physical_unload: boolean;
    VAR io_id: iot$io_id;
    VAR status: ost$status);

    VAR
      i: 0 .. ioc$max_tape_blocks_to_process,
      j: iot$tape_command_index,
      current_heap: ^ost$heap,
      p_tape_request: ^iot$tape_request,
      pkt_length: iot$tape_request_length;

    BEGIN
      status.normal := TRUE;
      io_id := 1;
      iop$set_current_heap (current_heap);

      pkt_length := iov$67x_command_table [tape_request_type].length + (repeat_count - 1) * 8;
      iop$tape_build_pp_req_header (tape_unit_number, pkt_length, p_tape_request, status);
      IF status.normal THEN
        io_id := p_tape_request^.io_id;
        j := iov$67x_command_table [tape_request_type].index;
        FOR i := 0 TO repeat_count - 1 DO
          p_tape_request^.request.tape_command [j + i].command_code := ioc$cc_function;
          p_tape_request^.request.tape_command [j + i].flags.store_response := FALSE;
          p_tape_request^.request.tape_command [j + i].flags.indirect_address := FALSE;
          p_tape_request^.request.tape_command [j + i].flags.fill := 0;
          p_tape_request^.request.tape_command [j + i].length := ioc$tape_function_code_length;
          p_tape_request^.request.tape_command [j + i].address := iov$67x_command_table [tape_request_type].
                hardware_command;
        FOREND;
        p_tape_request^.request_type := tape_request_type;

        IF (tape_request_type = ioc$tape_unload) AND (NOT physical_unload) THEN
          p_tape_request^.request.tape_command [2].address := ioc$67x_func_rewind;
        IFEND;

        IF NOT (tape_request_type = ioc$tape_erase) THEN
          p_tape_request^.ud^.consecutive_erases := 0;
        ELSE
          p_tape_request^.ud^.consecutive_erases := p_tape_request^.ud^.consecutive_erases + repeat_count;
        IFEND;

        p_tape_request^.io_type := ioc$no_io;
        p_tape_request^.initial_block_count := repeat_count;
        p_tape_request^.no_of_non_data_commands := repeat_count;
        IF (tape_request_type = ioc$tape_forspace) OR (tape_request_type = ioc$tape_backspace) THEN
          p_tape_request^.request.alert_mask.logical_delimiter := TRUE;
        IFEND;
        p_tape_request^.request.alert_mask.disabled_unit := pp_unit_disable;
        iop$tape_queue_request_setup (p_tape_request, status);
      IFEND;
      IF (p_tape_request <> NIL) AND NOT status.normal THEN
        IF NOT p_tape_request^.must_free_pageable_request THEN
          p_tape_request^.ud^.pageable_tape_requests [p_tape_request^.pageable_tape_request_index].
                slot_in_use := FALSE;
        ELSE
          FREE p_tape_request^.pp_response_p IN current_heap^;
          FREE p_tape_request IN current_heap^;
        IFEND;
      IFEND;
    END
  PROCEND iop$67x_non_data_trans_setup;

?? OLDTITLE ??
?? NEWTITLE := ' iop$67x_read_setup ' ??
?? EJECT ??

  PROCEDURE iop$67x_read_setup (tape_unit_number: iot$logical_unit;
        tape_request_type: iot$tape_request_types;
        inhibit_error_recovery: boolean;
        max_byte_count: iot$tape_block_length;
        block_description: ^iot$read_tape_description;
        no_of_blocks_to_read: iot$tape_block_count;
    VAR io_id: iot$io_id;
    VAR status: ost$status);

    VAR
      address_pair_count: 0 .. mmc$max_rma_list_length,
      current_heap: ^ost$heap,
      i: 0 .. 2 * (ioc$max_tape_blocks_to_process + 1),
      j: iot$tape_command_index,
      l: iot$tape_block_count,
      length: iot$transfer_count,
      offset: ost$segment_offset,
      page_offset: 0 .. 65536,
      p_tape_request: ^iot$tape_request,
      p_ud: ^iot$tape_job_unit_descriptor,
      pkt_length: iot$tape_request_length;

    BEGIN
      status.normal := TRUE;
      io_id := 1;
      iop$set_current_heap (current_heap);

      #INLINE ('keypoint', osk$debug, osk$m * max_byte_count, ioc$tape_debug_ioptrsu);
      pkt_length := iov$67x_command_table [tape_request_type].length + (ioc$read_cmd_per_block * 8) *
            no_of_blocks_to_read;
      iop$tape_build_pp_req_header (tape_unit_number, pkt_length, p_tape_request, status);
    /build_request/
      BEGIN
        IF status.normal THEN
          io_id := p_tape_request^.io_id;
          p_ud := p_tape_request^.ud;
          IF max_byte_count > p_ud^.max_block_length THEN
             osp$set_status_abnormal ('IO', ioe$block_size_too_large, 'Block size is too large.', status);
             EXIT /build_request/
          IFEND;
          IF max_byte_count < p_ud^.min_block_length THEN
             osp$set_status_abnormal ('IO', ioe$block_size_too_small, 'Block size too small.', status);
             EXIT /build_request/
          IFEND;
          address_pair_count := 0;
          length := max_byte_count;
          j := iov$67x_command_table [tape_request_type].index;
          i := 0;
          FOR l := 1 to no_of_blocks_to_read DO
            offset := #OFFSET (block_description^[l].buffer_area);
            IF ((offset MOD 8) <> 0) THEN
              osp$set_status_abnormal ('IO', ioe$improper_data_address, 'Data buffer not word aligned.',
                   status);
              EXIT /build_request/
            IFEND;
            page_offset := offset MOD osv$page_size;
            address_pair_count := address_pair_count + (((page_offset + length - 1) DIV osv$page_size) + 1);
            p_tape_request^.request.tape_command [j + i].command_code := ioc$cc_read_record;
            p_tape_request^.request.tape_command [j + i].flags.store_response := FALSE;
            p_tape_request^.request.tape_command [j + i].flags.indirect_address := TRUE;
            p_tape_request^.request.tape_command [j + i].flags.fill := 0;
            p_tape_request^.request.tape_command [j + i + 1].command_code := ioc$cc_store_transfer_count;
            p_tape_request^.request.tape_command [j + i + 1].flags.store_response := FALSE;
            p_tape_request^.request.tape_command [j + i + 1].flags.indirect_address := FALSE;
            p_tape_request^.request.tape_command [j + i + 1].flags.fill := 0;
            p_tape_request^.request.tape_command [j + i + 1].length := 8;
            i := i + ioc$read_cmd_per_block;
          FOREND;
          IF address_pair_count > (osv$page_size DIV 8) THEN
            osp$set_status_abnormal ('IO', ioe$tape_rma_list_overflow,
                 'Page size will not accommodate RMA list', status);
            EXIT /build_request/
          IFEND;

{ If IPI, store max byte count for read into request.

          IF (p_ud^.controller_type = cmc$mt5698_xx) THEN
            p_tape_request^.request.mode.read_max_byte_count := max_byte_count;
          IFEND;

          p_ud^.consecutive_erases := 0;
          p_tape_request^.estimated_address_pair_count := address_pair_count + 1;
          p_tape_request^.read_block_description := block_description;
          p_tape_request^.no_of_data_commands := no_of_blocks_to_read;
          p_tape_request^.max_input_count := max_byte_count;
          p_tape_request^.first_data_command := j + 1;
          p_tape_request^.request_type := tape_request_type;
          p_tape_request^.io_type := ioc$explicit_read;
          p_tape_request^.request.alert_mask.logical_delimiter := TRUE;
          p_tape_request^.request.alert_mask.long_input_block := TRUE;
          p_tape_request^.inhibit_error_recovery := inhibit_error_recovery;
          IF inhibit_error_recovery THEN
            p_tape_request^.request.recovery := ioc$terminate_at_error;
          IFEND;
          p_tape_request^.initial_block_count := no_of_blocks_to_read;
          iop$tape_queue_request_setup (p_tape_request, status);
        IFEND;
      END /build_request/;
      IF (p_tape_request <> NIL) AND NOT status.normal THEN
        IF NOT p_tape_request^.must_free_pageable_request THEN
          p_tape_request^.ud^.pageable_tape_requests [p_tape_request^.pageable_tape_request_index].
                slot_in_use := FALSE;
        ELSE
          FREE p_tape_request^.pp_response_p IN current_heap^;
          FREE p_tape_request IN current_heap^;
        IFEND;
      IFEND;
    END
  PROCEND iop$67x_read_setup;

?? OLDTITLE ??
?? NEWTITLE := ' iop$backspace_tape ' ??
?? EJECT ??

  PROCEDURE [XDCL] iop$backspace_tape (
        system_file_id: dmt$system_file_id;
        block_count: iot$tape_block_count;
        use_locate_block: boolean;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

    CONST
      disable_unit = TRUE,
      physical_unload = FALSE;

    VAR
      block_id: iot$cartridge_tape_bid,
      found: boolean,
      i: iot$no_of_tape_units,
      io_id: iot$io_id,
      logical_unit_number: iot$logical_unit,
      p_ud: ^iot$tape_job_unit_descriptor;

    status.normal := TRUE;

    convert_sfid_to_lun (system_file_id, logical_unit_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (block_count > ioc$max_tape_blocks_to_process) OR (block_count <= 0) THEN
      osp$set_status_abnormal ('IO', ioe$improper_block_count,
            'Bad block count in iop$backspace_tape, block_count = ', status);
      osp$append_status_integer (' ', block_count, 10, FALSE, status);
      RETURN;
    IFEND;

{ Obtain pointer to tape job unit descriptor.

    i := 1;
    found := FALSE;
    WHILE (i <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
      IF logical_unit_number = iov$p_statistic_data_p_array^ [i]. logical_unit THEN
        found := TRUE;
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;

    IF NOT found THEN
      osp$set_status_abnormal ('io', ioc$os_failure,
            'unable to find unit in iop$backspace_tape', status);
      RETURN;
    IFEND;

    p_ud := iov$p_statistic_data_p_array^ [i].p_tape_job_unit_descriptor;

    IF (p_ud^.controller_type = cmc$mt5680_xx) AND use_locate_block THEN
      block_id := p_ud^.cartridge_tape_last_good_bid;
      block_id.logical_position := (block_id.logical_position - block_count -
            p_ud^.error_block_forespace_count);
      iop$locate_block (logical_unit_number, block_id, {bid_recovery} FALSE,
            0, ioc$lbg, io_status, status);
    ELSE
      iop$67x_non_data_trans_setup (logical_unit_number, ioc$tape_backspace, block_count,
            disable_unit, physical_unload, io_id, status);

      IF status.normal THEN
        iop$tape_internal_request_stat (logical_unit_number, io_id, {buf_release =} TRUE,
              {bid_recovery =} FALSE, {bid_update =} TRUE, osc$wait, io_status, status);
      IFEND;
    IFEND;

    IF NOT status.normal OR (NOT io_status.normal_completion) THEN
      io_status.position_uncertain := TRUE;
    IFEND;

  PROCEND iop$backspace_tape;

?? OLDTITLE ??
?? NEWTITLE := ' iop$backspace_tape_to_tapemark ' ??
?? EJECT ??
?  IF system_version THEN

  PROCEDURE [XDCL, #GATE] iop$backspace_tape_to_tapemark (system_file_id: dmt$system_file_id;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

    CONST
      disable_unit = true,
      physical_unload = FALSE;

    VAR
      found: boolean,
      i: iot$no_of_tape_units,
      io_id: iot$io_id,
      logical_unit_number: iot$logical_unit,
      ud_p: ^iot$tape_job_unit_descriptor;

      status.normal := TRUE;
      convert_sfid_to_lun (system_file_id, logical_unit_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Obtain pointer to tape job unit descriptor.

      i := 1;
      found := FALSE;
      WHILE (i <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
        IF logical_unit_number = iov$p_statistic_data_p_array^ [i]. logical_unit THEN
          found := TRUE;
        ELSE
          i := i + 1;
        IFEND;
      WHILEND;

      IF NOT found THEN
        osp$set_status_abnormal ('io', ioc$os_failure,
              'unable to find unit in iop$backspace_tape_to_tapemark', status);
        RETURN;
      IFEND;

      ud_p := iov$p_statistic_data_p_array^ [i].p_tape_job_unit_descriptor;

      IF ud_p^.controller_type = cmc$mt5680_xx THEN { use skip tapemark for cartridge
        iop$skip_tapemark_backward (system_file_id, io_status, status);
        RETURN;
      IFEND;

{ Set indicator in job unit descriptor that we are backspacing to a tapemark.

      ud_p^.positioning_to_tapemark := TRUE;

{ Backspace 30 decimal blocks with each request while looking for status of tapemark read.
{ Also discontinue the backspacing operation if abnormal io_status is received.

    /backspace_loop_to_tapemark/
      REPEAT
        iop$67x_non_data_trans_setup (logical_unit_number, ioc$tape_backspace,
                 ioc$max_tape_blocks_to_process, disable_unit, physical_unload, io_id, status);
        IF NOT status.normal THEN
          EXIT /backspace_loop_to_tapemark/
        IFEND;

{ Note that in the normal search for a tapemark, all parity errors are bypassed and the status
{ of tapemark read is the only block that will cause us to stop unless a fatal hardware error occurs.
{ In using a backspace to reach a tapemark, we are setting the passing boolean parameters of
{ bid_recovery and bid_update to TRUE and TRUE respectivly. These passing boolean parameters to
{ the procedure iop$tape_internal_request_stat are passed through to the status checking
{ procedure named iop$tape_status_check. The bid_recovery boolean set to TRUE will allow the
{ backspacing to continue while disregarding non-fatal errors and their entry into the engineering
{ log. The bid_update set to TRUE, will place a block identification of ioc$unavail_bid
{ in the block_id_window for that position, and continue to backspace down the tape looking for
{ a tapemark.

        iop$tape_internal_request_stat (logical_unit_number, io_id, {buf_release =} TRUE,
              {bid_recovery =} TRUE, {bid_update =} TRUE, osc$wait, io_status, status);
        IF NOT status.normal THEN
          EXIT /backspace_loop_to_tapemark/
        IFEND;

        IF (NOT io_status.normal_completion) AND (io_status.completion_code = ioc$tapemark_read) THEN
          io_status.normal_completion := TRUE;
          EXIT /backspace_loop_to_tapemark/
        IFEND;
      UNTIL NOT io_status.normal_completion; { /backspace_loop_to_tapemark/

      ud_p^.positioning_to_tapemark := FALSE;

  PROCEND iop$backspace_tape_to_tapemark;

?  IFEND

?? OLDTITLE ??
?? NEWTITLE := ' iop$erase_tape ' ??
?? EJECT ??

  PROCEDURE [XDCL] iop$erase_tape (system_file_id: dmt$system_file_id;
        block_length: amt$max_block_length;
        number_of_erases: integer;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

    CONST
      disable_unit = true,
      physical_unload = FALSE;

    VAR
      count: 0 .. 0ffff(16),
      found: boolean,
      i: iot$no_of_tape_units,
      io_id: iot$io_id,
      logical_unit_number: iot$logical_unit,
      loop: boolean,
      p_ud: ^iot$tape_job_unit_descriptor,
      repeat_count: iot$tape_block_count;

    BEGIN
      status.normal := TRUE;
      convert_sfid_to_lun (system_file_id, logical_unit_number, status);
      IF status.normal THEN
        i := 1;
        found := FALSE;
        WHILE (i <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
          IF logical_unit_number = iov$p_statistic_data_p_array^ [i].logical_unit THEN
            found := TRUE;
          ELSE
            i := i + 1;
          IFEND;
        WHILEND;
        IF NOT found THEN
          osp$set_status_abnormal ('io', ioc$os_failure,
                'unable to find unit in iop$erase_tape', status);
          RETURN;
        IFEND;
        p_ud := iov$p_statistic_data_p_array^ [i].p_tape_job_unit_descriptor;

        IF (number_of_erases <> 0) AND (p_ud^.controller_type = cmc$mt5680_xx) THEN

{ Do not erase at EOT for cartridge tape.

          io_status.normal_completion := TRUE;
          RETURN;
        IFEND;

        IF number_of_erases = 0 THEN {uses block_length to compute erase length}
          IF (p_ud^.tape_unit_density = 3) THEN
            count := (block_length DIV 6250) DIV 3 + 1;
          ELSEIF (p_ud^.tape_unit_density = 4) THEN
            count := block_length DIV 14700 + 1;
          ELSE
            count := (block_length DIV 1600) DIV 3 + 1;
          IFEND;
        ELSE {use number_of_erases}
          count := number_of_erases;
        IFEND;

        IF (p_ud^.controller_type = cmc$mt5680_xx) AND (count + p_ud^.consecutive_erases > 32) THEN
          io_status.normal_completion := FALSE;
          io_status.completion_code := ioc$erase_limit_exceeded;
          RETURN;
        IFEND;

        loop := TRUE;
        repeat_count := ioc$max_tape_blocks_to_process;
        WHILE loop DO
          IF (count > ioc$max_tape_blocks_to_process) THEN
            count := count - ioc$max_tape_blocks_to_process;
          ELSE
            repeat_count := count;
            loop := FALSE;
          IFEND;
          iop$67x_non_data_trans_setup (logical_unit_number, ioc$tape_erase, repeat_count,
                 disable_unit, physical_unload, io_id, status);
          IF NOT status.normal THEN
            RETURN;
          ELSE
            iop$tape_internal_request_stat (logical_unit_number, io_id, {buf_release =} TRUE,
                  {bid_recovery =} FALSE, {bid_update =} TRUE, osc$wait, io_status, status);
          IFEND;

          IF NOT io_status.normal_completion THEN
            io_status.position_uncertain := TRUE;
            RETURN;
          IFEND;
        WHILEND;
      IFEND;

      #INLINE ('keypoint', osk$exit, 0, ioc$tape_exit_iopte);
    END
  PROCEND iop$erase_tape;

?? OLDTITLE ??
?? NEWTITLE := ' iop$establish_tape_statistics ' ??
?? EJECT ??

  PROCEDURE iop$establish_tape_statistics (VAR status: ost$status);

? IF system_version THEN

    CONST
      number_of_statistics = 6;

    VAR

      i: integer,
      statistics: array [1 .. number_of_statistics] of sft$statistic_code;

    status.normal := TRUE;

    statistics [1] := cml$7021_3x_failure_data;
    statistics [2] := cml$7221_1_failure_data;
    statistics [3] := cml$698_1x_failure_data;
    statistics [4] := cml$5698_1x_failure_data;
    statistics [5] := cml$5680_11_failure_data;
    statistics [6] := cml$tape_subsystem_usage_data;

    FOR i := 1 TO number_of_statistics DO
      sfp$activate_system_statistic (statistics [i], $sft$binary_logset [pmc$engineering_log], status);
      IF status.normal = FALSE THEN
        RETURN;
      IFEND;
    FOREND;

{ Set flag to false that causes the activation of tape statistics for the first tape assignment.

    iop$tape_clear_activate_stats (status);
? ELSE
    status.normal := TRUE;
? IFEND

  PROCEND iop$establish_tape_statistics;

?? OLDTITLE ??
?? NEWTITLE := ' iop$fetch_tape_capabilities ' ??
?? EJECT ??

  PROCEDURE [XDCL] iop$fetch_tape_capabilities (system_file_id: dmt$system_file_id;
    VAR maximum_block_length: amt$max_block_length;
    VAR max_blocks_per_physical_call: iot$tape_block_count;
    VAR status: ost$status);

    VAR
      found: boolean,
      i: iot$no_of_tape_units,
      logical_unit_number: iot$logical_unit,
      p_ud: ^iot$tape_job_unit_descriptor;

    BEGIN
      status.normal := TRUE;
      convert_sfid_to_lun (system_file_id, logical_unit_number, status);
      IF status.normal THEN
        i := 1;
        found := FALSE;
        WHILE (i <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
          IF logical_unit_number = iov$p_statistic_data_p_array^ [i].logical_unit THEN
            found := TRUE;
          ELSE
            i := i + 1;
          IFEND;
        WHILEND;
        IF NOT found THEN
          osp$set_status_abnormal ('io', ioc$os_failure,
                'unable to find unit in iop$fetch_tape_capabilities', status);
          RETURN;
        IFEND;
        p_ud := iov$p_statistic_data_p_array^ [i].p_tape_job_unit_descriptor;

        maximum_block_length := p_ud^.max_block_length;
        max_blocks_per_physical_call := ioc$max_tape_blocks_to_process;
      IFEND;

    END
  PROCEND iop$fetch_tape_capabilities;

?? OLDTITLE ??
?? NEWTITLE := ' iop$forspace_tape ' ??
?? EJECT ??

  PROCEDURE [XDCL] iop$forspace_tape (system_file_id: dmt$system_file_id;
        block_count: iot$tape_block_count;
    VAR io_id: iot$io_id;
    VAR status: ost$status);

    CONST
      disable_unit = true,
      physical_unload = FALSE;

    VAR
      logical_unit_number: iot$logical_unit;

    BEGIN
      status.normal := TRUE;

      IF (block_count <= ioc$max_tape_blocks_to_process) AND (block_count > 0) THEN
        convert_sfid_to_lun (system_file_id, logical_unit_number, status);
        IF status.normal THEN
          iop$67x_non_data_trans_setup (logical_unit_number, ioc$tape_forspace, block_count,
                 disable_unit, physical_unload, io_id, status);
        IFEND;
      ELSE
        osp$set_status_abnormal ('IO', ioe$improper_block_count,
              'Bad block count in iop$forspace_tape, block_count = ', status);
        osp$append_status_integer (' ', block_count, 10, FALSE, status);
      IFEND;

      #INLINE ('keypoint', osk$exit, 0,
            ioc$tape_exit_ioptsf);
    END
  PROCEND iop$forspace_tape;

?? OLDTITLE ??
?? NEWTITLE := ' iop$forspace_tape_to_tapemark ' ??
?? EJECT ??
?  IF system_version THEN

  PROCEDURE [XDCL, #GATE] iop$forspace_tape_to_tapemark (system_file_id: dmt$system_file_id;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

? ELSE

  PROCEDURE [XDCL] iop$forspace_tape_to_tapemark (system_file_id: dmt$system_file_id;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

? IFEND

    CONST
      disable_unit = true,
      physical_unload = FALSE;

    VAR
      found: boolean,
      i: iot$no_of_tape_units,
      io_id: iot$io_id,
      logical_unit_number: iot$logical_unit,
      ud_p: ^iot$tape_job_unit_descriptor;

      status.normal := TRUE;
      convert_sfid_to_lun (system_file_id, logical_unit_number, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Obtain pointer to tape job unit descriptor.

      i := 1;
      found := FALSE;
      WHILE (i <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
        IF logical_unit_number = iov$p_statistic_data_p_array^ [i]. logical_unit THEN
          found := TRUE;
        ELSE
          i := i + 1;
        IFEND;
      WHILEND;

      IF NOT found THEN
        osp$set_status_abnormal ('io', ioc$os_failure,
              'unable to find unit in iop$forspace_tape_to_tapemark', status);
        RETURN;
      IFEND;

      ud_p := iov$p_statistic_data_p_array^ [i].p_tape_job_unit_descriptor;

      IF ud_p^.controller_type = cmc$mt5680_xx THEN { use skip tapemark for cartridge
        iop$skip_tapemark_forward (system_file_id, io_status, status);
        RETURN;
      IFEND;

{ Set indicator in job unit descriptor that we are forespacing to a tapemark.

      ud_p^.positioning_to_tapemark := TRUE;

{ Forspace 30 decimal blocks with each request while looking for status of tapemark read.
{ Also discontinue the forspacing operation if abnormal io_status is received.

    /forespace_loop_to_tapemark/
      REPEAT
        iop$67x_non_data_trans_setup (logical_unit_number, ioc$tape_forspace,
                 ioc$max_tape_blocks_to_process, disable_unit, physical_unload, io_id, status);
        IF NOT status.normal THEN
          EXIT /forespace_loop_to_tapemark/
        IFEND;

{ Note that in the normal search for a tapemark, all parity errors are bypassed and the status
{ of tapemark read is the only block that will cause us to stop unless a fatal hardware error occurs.
{ In using a forspace to reach a tapemark, we are setting the passing boolean parameters of
{ bid_recovery and bid_update to TRUE and FALSE respectivly. These boolean passing parameters to
{ to the procedure iop$tape_internal_request_stat are passed through to the status check procedure
{ iop$tape_status_check.  The bid_recovery set to TRUE will inhibit logging any parity errors along
{ the way to reaching a tapemark. The bid_update of FALSE will inhibit any recovery attempt in the
{ status checking routine (iop$tape_status_check) due to a parity error on the forspace,
{ place a block identification of ioc$error_block_bid in the block_id_window for that position,
{ and continue to forespace down the tape looking for a tapemark.

        iop$tape_internal_request_stat (logical_unit_number, io_id, {buf_release =} TRUE,
              {bid_recovery =} TRUE, {bid_update =} FALSE, osc$wait, io_status, status);
        IF NOT status.normal THEN
          EXIT /forespace_loop_to_tapemark/
        IFEND;

        IF (NOT io_status.normal_completion) AND (io_status.completion_code = ioc$tapemark_read) THEN
          io_status.normal_completion := TRUE;
          EXIT /forespace_loop_to_tapemark/
        IFEND;
      UNTIL NOT io_status.normal_completion; { /forespace_loop_to_tapemark/

      ud_p^.positioning_to_tapemark := FALSE;

  PROCEND iop$forspace_tape_to_tapemark;

?? OLDTITLE ??
?? NEWTITLE := ' iop$free_boot_tape_tables ' ??
?? EJECT ??
?  IF NOT system_version THEN

  PROCEDURE [XDCL] iop$free_boot_tape_tables;

    IF iov$p_statistic_data_p_array <> NIL THEN
      IF iov$p_statistic_data_p_array^ [1].p_tape_job_unit_descriptor <> NIL THEN
        iop$free_pageable_tape_requests (iov$p_statistic_data_p_array^ [1].
              p_tape_job_unit_descriptor);
        iop$free_wired_tape_tables (iov$p_statistic_data_p_array^ [1].p_tape_job_unit_descriptor^.
              completion_q_index);
        FREE iov$p_statistic_data_p_array^ [1].p_tape_job_unit_descriptor IN
              osv$mainframe_pageable_heap^;
      IFEND;
      FREE iov$p_statistic_data_p_array IN osv$mainframe_pageable_heap^;
    IFEND;

  PROCEND iop$free_boot_tape_tables;
? IFEND

?? OLDTITLE ??
?? NEWTITLE := ' iop$free_pageable_tape_reqeusts ' ??
?? EJECT ??

  PROCEDURE iop$free_pageable_tape_requests (
    p_ud: ^iot$tape_job_unit_descriptor);

    VAR
      current_heap: ^ost$heap,
      index: 1 .. ioc$max_multiple_tape_requests + 1;

    iop$set_current_heap (current_heap);

    FOR index := 1 TO (ioc$max_multiple_tape_requests + 1) DO
      IF p_ud^.pageable_tape_requests [index].tape_request_p <> NIL THEN
        FREE p_ud^.pageable_tape_requests [index].tape_request_p IN current_heap^;
        FREE p_ud^.pageable_tape_requests [index].pp_response_p IN current_heap^;
      IFEND;
    FOREND;

  PROCEND iop$free_pageable_tape_requests;

?? OLDTITLE ??
?? NEWTITLE := ' iop$get_position_of_tape_file ' ??
?? EJECT ??
? IF system_version THEN

?? TITLE := 'PROCEDURE iop$get_position_of_tape_file' ??

PROCEDURE [XDCL, #GATE] iop$get_position_of_tape_file (lun: iot$logical_unit;
           VAR position: iot$tape_position;
           VAR status: ost$status);

  VAR
    found: boolean,
    i: iot$no_of_tape_units,
    ud_p: ^iot$tape_job_unit_descriptor;

    status.normal := TRUE;

{ Obtain pointer to tape_job_unit_descriptor that contains current BID Window.

    i := 1;
    found := FALSE;
    WHILE (i <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
      IF lun = iov$p_statistic_data_p_array^ [i].logical_unit THEN
        found := TRUE;
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;
    IF NOT found THEN
      osp$set_status_abnormal ('io', ioc$os_failure,
            'unable to find unit in iop$get_position_of_tape_file', status);
      RETURN;
    IFEND;
    ud_p := iov$p_statistic_data_p_array^ [i].p_tape_job_unit_descriptor;

{ Investigate if tape position indicates tape located at Loadpoint.
{ Note that bid_index points to next entry to be updated in BID_WINDOW.

    IF ud_p^.controller_type <> cmc$mt5680_xx THEN
      position.unit_type := ioc$reel_to_reel;
      IF (ud_p^.historical_bid_index = LOWERVALUE(iot$bid_index) + 1) AND
            (ud_p^.historical_bid_window [LOWERBOUND(iot$bid_window)] = ioc$loadpoint_bid) THEN
        position.tape_position := ioc$tape_at_loadpoint_position;
      ELSE
        position.tape_position := ioc$tape_not_loadpoint_position;
      IFEND;
      position.historical_bid_index := ud_p^.historical_bid_index;
      position.historical_bid_window := ud_p^.historical_bid_window;
    ELSE {cartridge tape
      position.unit_type := ioc$cartridge;
      position.last_good_bid := ud_p^.cartridge_tape_last_good_bid;
      IF ud_p^.cartridge_tape_last_good_bid.logical_position = 0 THEN
        position.tape_position := ioc$tape_at_loadpoint_position;
      ELSE
        position.tape_position := ioc$tape_not_loadpoint_position;
      IFEND;
    IFEND;
    position.blocks_from_loadpoint := ud_p^.block_count;
    position.tapemarks_from_loadpoint := ud_p^.tapemark_count;

  PROCEND iop$get_position_of_tape_file;

? IFEND

?? OLDTITLE ??
?? NEWTITLE := ' iop$get_tape_usage_data ' ??
?? EJECT ??
? IF system_version THEN

?? TITLE := 'PROCEDURE iop$get_tape_usage_data' ??

  PROCEDURE [XDCL, #GATE] iop$get_tape_usage_data (
        system_file_id: dmt$system_file_id;
    VAR block_count: ost$non_negative_integers;
    VAR tapemark_count: ost$non_negative_integers;
    VAR status: ost$status);

  VAR
    found: boolean,
    i: iot$no_of_tape_units,
    lun: iot$logical_unit,
    p_ud: ^iot$tape_job_unit_descriptor;

    status.normal := TRUE;

    dmp$convert_sfid_to_lun (system_file_id, lun, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Obtain pointer to tape_job_unit_descriptor that contains current usage data.

    i := 1;
    found := FALSE;
    WHILE (i <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
      IF lun = iov$p_statistic_data_p_array^ [i].logical_unit THEN
        found := TRUE;
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;
    IF NOT found THEN
      osp$set_status_abnormal ('io', ioc$os_failure,
            'unable to find unit in iop$get_tape_usage_data', status);
      RETURN;
    IFEND;
    p_ud := iov$p_statistic_data_p_array^ [i].p_tape_job_unit_descriptor;

    block_count := p_ud^.block_count;
    tapemark_count := p_ud^.tapemark_count;

  PROCEND iop$get_tape_usage_data;

? IFEND

?? OLDTITLE ??
?? NEWTITLE := ' iop$initialize_tape_ud ' ??
?? EJECT ??

? IF system_version THEN
  PROCEDURE [XDCL, #GATE] iop$initialize_tape_ud (
      tape_initial: dmt$tape_initialization_record;
      multiple_requests_possible: boolean;
    VAR status: ost$status);
? ELSE
  PROCEDURE [XDCL] iop$initialize_tape_ud (
      tape_initial: dmt$tape_initialization_record;
      multiple_requests_possible: boolean;
    VAR status: ost$status);
? IFEND

    VAR
      controller_type : cmt$controller_type,
      current_heap : ^ost$heap,
      ad_mode : 1 .. 2,
      dummy_iou : cmt$element_name,
      element_name : cmt$element_name,
      found: boolean,
      i: 1 .. ioc$max_multiple_tape_requests,
      index: 1 .. ioc$max_multiple_tape_requests + 1,
      j: iot$bid_index,
      logical_pp_number: iot$pp_number,
      number_of_pageable_requests: 1 .. ioc$max_multiple_tape_requests + 1,
      offset: iot$no_of_tape_units,
      p_ud: ^iot$tape_job_unit_descriptor;

      status.normal := TRUE;
      iop$set_current_heap (current_heap);

{ The following code initializes IOV$P_STATISTIC_DATA_P_ARRAY to a NIL pointer only for
{ the module IOM$TAPE_BOOT_MANAGER.  The boot_manager module does not log any statistic data and
{ must have this pointer initialized to assure a unit connect is possible.
{ If the pointer is not NIL upon entry, the structures are FREE'ed so the boot size does not grow.

? IF NOT system_version THEN
      IF iov$p_statistic_data_p_array <> NIL THEN
        IF iov$p_statistic_data_p_array^ [1].p_tape_job_unit_descriptor <> NIL THEN
          iop$free_wired_tape_tables (iov$p_statistic_data_p_array^ [1].p_tape_job_unit_descriptor^.
                completion_q_index);
          iop$free_pageable_tape_requests (iov$p_statistic_data_p_array^ [1].p_tape_job_unit_descriptor);
          FREE iov$p_statistic_data_p_array^ [1].p_tape_job_unit_descriptor IN current_heap^;
        IFEND;
        FREE iov$p_statistic_data_p_array IN current_heap^;
      IFEND;
? IFEND

{     If establish_tape_statistics is TRUE a call has to be made to
{     iop$establish_tape_statistics in order to allow error logging.
{     Establish_tape_statistics is set to FALSE after activation of statistics.

? IF system_version THEN
      IF iov$establish_tape_statistics = TRUE THEN
        iop$establish_tape_statistics (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
? IFEND

{     Allocate space in the job_pageable_heap for the package that is going to contain the
{     tape_job_unit_descriptor and store the pointer in a slot in iov$p_statistic_data_p_array
{     based on the logical unit number of the involved tape unit.

      p_ud := NIL;

      ALLOCATE p_ud IN current_heap^;

      found := false;
      offset := 1;
      WHILE (offset <= iov$number_of_tape_units) AND (NOT found) DO
        IF (iov$tape_completion_q_table^ [offset].lun =
              tape_initial.logical_unit_number) THEN
          p_ud^.completion_q_index := offset;
          found := TRUE;
        ELSE
          offset := offset + 1;
        IFEND;
      WHILEND;

      IF NOT found THEN
        osp$set_status_abnormal ('io', ioc$unrecognized_unit_id,
              'unable to find unit in iop$tape_initialize_ud', status);
        RETURN;
      IFEND;

{ Allocate slots to hold pageable tape requests.  This memory is in job pageable and is released
{ when the job is completed with the tape.  The number of slots allocated is one greater than
{ ioc$max_multiple_tape_requests because we have to have a spare slot for error recovery requests.

      IF multiple_requests_possible THEN
        number_of_pageable_requests := ioc$max_multiple_tape_requests + 1;
      ELSE { do not need more that 2 slots
        number_of_pageable_requests := 2;
        FOR index := 3 TO ioc$max_multiple_tape_requests + 1 DO
          p_ud^.pageable_tape_requests [index].slot_in_use := TRUE;
          p_ud^.pageable_tape_requests [index].tape_request_p := NIL;
        FOREND;
      IFEND;

      FOR index := 1 TO number_of_pageable_requests DO
        p_ud^.pageable_tape_requests [index].slot_in_use := FALSE;
        ALLOCATE p_ud^.pageable_tape_requests [index].tape_request_p IN current_heap^;
        ALLOCATE p_ud^.pageable_tape_requests [index].pp_response_p IN current_heap^;
      FOREND;

{ Allocate mainframe wired slots for the wired tape requests.  This memory is released
{ when the job is completed with the tape.

      iop$allocate_wired_tape_tables (p_ud^.completion_q_index, multiple_requests_possible);

      cmp$get_element_name_via_lun (tape_initial.logical_unit_number , element_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      found := FALSE;

    /get_controller_type/
      FOR offset := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
        IF element_name = iov$tusl_p^ [offset].element_name THEN
          logical_pp_number := iov$tusl_p^ [offset].logical_pp [1];
          controller_type := cmv$logical_pp_table_p^ [logical_pp_number].controller_info.controller_type;
          found := TRUE;
          EXIT /get_controller_type/;
        IFEND;
      FOREND /get_controller_type/;

      IF NOT found THEN
        osp$set_status_abnormal ('io', ioc$unrecognized_unit_id,
              'unable to find controller_type in iop$tape_initialize_ud', status);
        RETURN;
      IFEND;

      p_ud^.controller_type := controller_type;

      IF controller_type =  cmc$mt7221_2_s0 THEN
        ad_mode := 2;
      ELSE
        ad_mode := 1;
      IFEND;

      osp$set_job_signature_lock (statistic_data_lock);

{     Check whether array statistic_package_p_array has been established; if not allocate space
{     in the job_pageable_heap, initialize each entry by setting bit 'slot_in_use' to FALSE and
{     save pointer iov$p_statistic_package_p_array in job pageable.

      IF iov$p_statistic_data_p_array = NIL THEN

        ALLOCATE iov$p_statistic_data_p_array: [1 .. iov$number_of_tape_units] IN
              current_heap^;

        FOR offset :=1 TO UPPERBOUND (iov$p_statistic_data_p_array^) DO
          iov$p_statistic_data_p_array^ [offset].slot_in_use := FALSE;
          iov$p_statistic_data_p_array^ [offset].logical_unit := 0;
          iov$p_statistic_data_p_array^ [offset].p_tape_job_unit_descriptor := NIL;
          iov$p_statistic_data_p_array^ [offset].unit_type := ioc$non_ipi_reel;
          iov$p_statistic_data_p_array^ [offset].p_failure_data := NIL;
        FOREND;
      IFEND;

      found := FALSE;
      offset := 1;

      WHILE (offset <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
        IF (iov$p_statistic_data_p_array^ [offset].slot_in_use = FALSE ) THEN
          iov$p_statistic_data_p_array^ [offset].logical_unit := tape_initial.logical_unit_number;
          iov$p_statistic_data_p_array^ [offset].p_tape_job_unit_descriptor := p_ud;
          IF controller_type = cmc$mt5698_xx THEN
            iov$p_statistic_data_p_array^ [offset].unit_type := ioc$ipi_reel;
            iov$p_statistic_data_p_array^ [offset].p_ipi_failure_data := NIL;
          ELSEIF controller_type = cmc$mt5680_xx THEN
            iov$p_statistic_data_p_array^ [offset].unit_type := ioc$ccc_cart;
            iov$p_statistic_data_p_array^ [offset].p_ccc_cart_failure_data := NIL;
          ELSE
            iov$p_statistic_data_p_array^ [offset].unit_type := ioc$non_ipi_reel;
            iov$p_statistic_data_p_array^ [offset].p_failure_data := NIL;
          IFEND;
          iov$p_statistic_data_p_array^ [offset].slot_in_use := TRUE;
          osp$clear_job_signature_lock (statistic_data_lock);
          found := TRUE;
        ELSE
          offset := offset + 1;
        IFEND;
      WHILEND;

      IF NOT found THEN
        osp$set_status_abnormal ('io', ioc$unrecognized_unit_id,
              'unable to find unit in iop$initialize_tape_ud', status);
        osp$clear_job_signature_lock (statistic_data_lock);
        RETURN;
      IFEND;

{     Initialize the tape_job_unit_descriptor for this tape unit

      p_ud^.io_id := 2;

      p_ud^.blocks_read := 0;
      p_ud^.blocks_read_for_accounting := 0;
      p_ud^.blocks_read_for_byte_count := 0;
      p_ud^.bytes_read := 0;
      p_ud^.blocks_written := 0;
      p_ud^.blocks_written_for_accounting := 0;
      p_ud^.blocks_written_for_byte_count := 0;
      p_ud^.bytes_written := 0;
      p_ud^.blocks_skipped := 0;
      p_ud^.block_count := 0;
      p_ud^.tapemark_count := 0;
      p_ud^.tape_unit_density := 0;
      p_ud^.io_requests_count := 0;
      p_ud^.tape_error_log_entry := FALSE;
      p_ud^.task_terminated_during_recovery := FALSE;
      p_ud^.block_in_error := -1;
      p_ud^.last_request := ioc$tape_unload;
      p_ud^.free_running_clock := #free_running_clock (0);
      p_ud^.positioning_to_tapemark := FALSE;
      p_ud^.min_block_length := ioc$min_tape_block_length;
      IF (p_ud^.controller_type = cmc$mt7221_2_s0) OR (p_ud^.controller_type = cmc$mt5698_xx) OR
            (p_ud^.controller_type = cmc$mt5680_xx) OR
            (cmv$logical_pp_table_p^ [logical_pp_number].pp_info.logical_partner_pp_index > 0) THEN
        p_ud^.max_block_length := amc$maximum_block;
      ELSE
        p_ud^.max_block_length := ioc$max_tape_not_long_blk_lgth;
      IFEND;
      p_ud^.position_uncertain := FALSE;

      FOR i := 1 TO ioc$max_multiple_tape_requests DO
         p_ud^.pending_pageable_requests [i] := NIL;
      FOREND;

{ Set the format parameters for this tape unit.  Do not initialize the
{ format parameters for cartridge tape, since the PP driver will not use them.

      IF controller_type <> cmc$mt5680_xx THEN
        p_ud^.format_parameters.define_code_translation := 1;
        p_ud^.format_parameters.code_translation := 0;

        p_ud^.format_parameters.define_ad := 1;
        p_ud^.format_parameters.ad_mode := ad_mode;

{ The unit number is set to zero here, but will be filled out by the PP to its proper value.

        p_ud^.format_parameters.define_unit_no := TRUE;
        p_ud^.format_parameters.hardware_unit_number := 0;

        p_ud^.format_parameters.define_vertical_parity := 1;
        p_ud^.format_parameters.vertical_parity := 0;

        p_ud^.format_parameters.define_density := 1;
        CASE tape_initial.density OF

        = rmc$200 =
          osp$set_status_abnormal ('IO', ioc$improper_density, '200 FPI density not valid for this unit.',
                status);

        = rmc$556 =
          osp$set_status_abnormal ('IO', ioc$improper_density, '556 FPI density not valid for this unit.',
                status);

        = rmc$800 =
          p_ud^.format_parameters.density := 1;

        = rmc$1600 =
          p_ud^.format_parameters.density := 0;

        = rmc$6250 =
          p_ud^.format_parameters.density := 1;

        ELSE
          osp$set_status_abnormal ('io', ioc$improper_density, 'density requested not recognized.', status);

        CASEND;

        p_ud^.format_parameters.define_min_block_length := 1;
        p_ud^.format_parameters.min_block_length := 1;

        p_ud^.format_parameters.define_disable_error_correction := 1;
        p_ud^.format_parameters.disable_hardware_correction := 0;

        p_ud^.format_parameters.fill := 0;
        p_ud^.format_parameters.fill1 := 0;
        p_ud^.format_parameters.read_max_byte_count := 0;
      IFEND;

{ Initialize the Single/Double Track Hardware Correction counter.

      p_ud^.single_double_track_corrections := 0;

{Initialize the Block_Id index and the Block_id Window at assign time.
{For future recovery across deadstarts, this initialization may require investigation.

      p_ud^.bid_index := LOWERVALUE(iot$bid_index);
      FOR j := LOWERBOUND(iot$bid_window) TO UPPERBOUND(iot$bid_window) DO
        p_ud^.bid_window [j] := ioc$empty_bid;
      FOREND;

      p_ud^.cartridge_tape_last_good_bid := zero_ccc_cart_bid;
      p_ud^.error_block_forespace_count := 0;
      p_ud^.ccc_cart_buffer_underruns := 0;

      #INLINE ('keypoint', osk$exit, 0,
            ioc$tape_exit_ioptin);

  PROCEND iop$initialize_tape_ud;

?? OLDTITLE ??
?? NEWTITLE := ' iop$locate_block ' ??
?? EJECT ??

? IF system_version THEN

  PROCEDURE [XDCL, #GATE] iop$locate_block (
        logical_unit: iot$logical_unit;
        block_id: iot$cartridge_tape_bid;
        bid_recovery: boolean;
        tape_mark_reset: integer;
        locate_block_option: iot$locate_block_option;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

? ELSE { do not xdcl in boot version

  PROCEDURE iop$locate_block (
        logical_unit: iot$logical_unit;
        block_id: iot$cartridge_tape_bid;
        bid_recovery: boolean;
        tape_mark_reset: integer;
        locate_block_option: iot$locate_block_option;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

? IFEND

    CONST
      disable_unit = FALSE,
      physical_unload = FALSE;

    VAR
      current_heap: ^ost$heap,
      forespace_count: 0 .. 0ffff(16),
      forespace_count_for_request: 0 .. 0ffff(16),
      io_id: iot$io_id,
      p_tape_request: ^iot$tape_request,
      p_ud: ^iot$tape_job_unit_descriptor;

    status.normal := TRUE;
    iop$tape_build_pp_req_header (logical_unit, {length} 48, p_tape_request, status);
    IF status.normal THEN
      io_id := p_tape_request^.io_id;
      p_ud := p_tape_request^.ud;
      p_ud^.cartridge_tape_last_good_bid := block_id;
      p_tape_request^.request.tape_command [2].command_code := ioc$cc_locate_block;
      p_tape_request^.request.tape_command [2].flags.store_response := FALSE;
      p_tape_request^.request.tape_command [2].flags.indirect_address := FALSE;
      p_tape_request^.request.tape_command [2].flags.fill := 0;
      p_tape_request^.request.tape_command [2].length := 0;
      p_tape_request^.request.tape_command [2].address := (block_id.physical_position * 1000000(16)) +
            block_id.logical_position;

      p_tape_request^.request_type := ioc$locate_block;
      p_tape_request^.io_type := ioc$no_io;
      p_tape_request^.initial_block_count := 1;
      p_tape_request^.no_of_non_data_commands := 1;
      p_tape_request^.request.alert_mask.disabled_unit := TRUE;
      iop$tape_queue_request_setup (p_tape_request, status);
    IFEND;

    IF NOT status.normal THEN
      IF p_tape_request <> NIL THEN
        IF NOT p_tape_request^.must_free_pageable_request THEN
          p_tape_request^.ud^.pageable_tape_requests [p_tape_request^.pageable_tape_request_index].
                slot_in_use := FALSE;
        ELSE
          iop$set_current_heap (current_heap);
          FREE p_tape_request^.pp_response_p IN current_heap^;
          FREE p_tape_request IN current_heap^;
        IFEND;
      IFEND;
      RETURN;
    IFEND;

    iop$tape_internal_request_stat (logical_unit, io_id, {buf_release} TRUE, bid_recovery,
          {bid_update} FALSE, osc$wait, io_status, status);

{ Reset the tapemark count in the unit descriptor if it is non-zero.  This is used for fatal
{ tape error recovery to maintain the correct count.

    IF status.normal AND io_status.normal_completion AND (tape_mark_reset <> 0) THEN
      p_ud^.tapemark_count := tape_mark_reset;
    IFEND;

{ If requested on the call, forespace the number of error blocks in the counter
{ p_ud^.error_block_forespace_count.  This is used since locate_block to a block with
{ an unrecovered parity error does not work.
{ Note - additional forespaces are not performed if the count is zero or if the
{ locate_block status or io_status are not normal.

    IF (p_ud^.error_block_forespace_count = 0) OR NOT status.normal OR
          NOT io_status.normal_completion THEN
      RETURN;
    IFEND;

    CASE locate_block_option OF

    = ioc$lbg =

      RETURN; { No additional positioning

    = ioc$lbg_plus_count =

      forespace_count := p_ud^.error_block_forespace_count;

    = ioc$lbg_plus_count_minus_1 =

      forespace_count := p_ud^.error_block_forespace_count - 1;
      IF forespace_count = 0 THEN
        RETURN;
      IFEND;
    ELSE
    CASEND;

    REPEAT
      IF forespace_count <= ioc$max_tape_blocks_to_process THEN
        forespace_count_for_request := forespace_count;
        forespace_count := 0;
      ELSE
        forespace_count_for_request := ioc$max_tape_blocks_to_process;
        forespace_count := forespace_count - ioc$max_tape_blocks_to_process;
      IFEND;

      iop$67x_non_data_trans_setup (logical_unit, ioc$tape_forspace, forespace_count_for_request,
            disable_unit, physical_unload, io_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      iop$tape_internal_request_stat (logical_unit, io_id, {buf_release} TRUE, {bid_recovery} TRUE,
            {bid_update} FALSE, osc$wait, io_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF io_status.io_complete AND (NOT io_status.normal_completion) AND
            NOT (io_status.completion_code = ioc$tapemark_read) THEN
        RETURN;  { return error
      ELSEIF NOT io_status.normal_completion AND (io_status.completion_code = ioc$tapemark_read) THEN
        forespace_count := forespace_count + io_status.residual_block_count - 1;
      IFEND;

    UNTIL forespace_count = 0;

  PROCEND iop$locate_block;

?? OLDTITLE ??
?? NEWTITLE := ' iop$read_tape ' ??
?? EJECT ??

  PROCEDURE [XDCL] iop$read_tape (system_file_id: dmt$system_file_id;
        inhibit_error_recovery: boolean;
        max_byte_count: iot$tape_block_length;
        block_description: ^iot$read_tape_description;
        no_of_blocks_to_read: iot$tape_block_count;
    VAR io_id: iot$io_id;
    VAR status: ost$status);

    VAR
      logical_unit_number: iot$logical_unit;

    BEGIN
      status.normal := TRUE;

      #INLINE ('keypoint', osk$entry, osk$m * no_of_blocks_to_read, ioc$tape_entry_ioptrd);
      convert_sfid_to_lun (system_file_id, logical_unit_number, status);
      IF status.normal THEN
        iop$67x_read_setup (logical_unit_number, ioc$tape_read, inhibit_error_recovery, max_byte_count,
              block_description, no_of_blocks_to_read, io_id, status);
      IFEND;
      #INLINE ('keypoint', osk$exit, 0,
            ioc$tape_exit_ioptrd);
    END
  PROCEND iop$read_tape;

?? OLDTITLE ??
?? NEWTITLE := ' iop$read_tape_scan ' ??
?? EJECT ??
? IF system_version THEN

  PROCEDURE [XDCL, #GATE] iop$read_tape_scan (logical_unit_number: iot$logical_unit;
        inhibit_error_recovery: boolean;
        max_byte_count: iot$tape_block_length;
        block_description: ^iot$read_tape_description;
        no_of_blocks_to_read: iot$tape_block_count;
    VAR io_id: iot$io_id;
    VAR status: ost$status);


    BEGIN
      status.normal := TRUE;

      #INLINE ('keypoint', osk$entry, osk$m * no_of_blocks_to_read, ioc$tape_entry_ioptrd);
      iop$67x_read_setup (logical_unit_number, ioc$tape_read, inhibit_error_recovery, max_byte_count,
            block_description, no_of_blocks_to_read, io_id, status);
      #INLINE ('keypoint', osk$exit, 0,
            ioc$tape_exit_ioptrd);
    END
  PROCEND iop$read_tape_scan;
? IFEND

?? OLDTITLE ??
?? NEWTITLE := ' iop$rewind_tape ' ??
?? EJECT ??

  PROCEDURE [XDCL] iop$rewind_tape (system_file_id: dmt$system_file_id;
    VAR io_id: iot$io_id;
    VAR status: ost$status);

    CONST
      disable_unit = TRUE,
      physical_unload = FALSE,
      repeat_count = 1;

    VAR
      logical_unit_number: iot$logical_unit;

    BEGIN
      status.normal := TRUE;

      convert_sfid_to_lun (system_file_id, logical_unit_number, status);
      IF status.normal THEN
        iop$67x_non_data_trans_setup (logical_unit_number, ioc$tape_rewind, repeat_count,
               disable_unit, physical_unload, io_id, status);
      IFEND;

      #INLINE ('keypoint', osk$exit, 0,
            ioc$tape_exit_ioptrew);
    END
  PROCEND iop$rewind_tape;

?? OLDTITLE ??
?? NEWTITLE := ' iop$rewind_tape_scan ' ??
?? EJECT ??
? IF system_version THEN

  PROCEDURE [XDCL, #GATE] iop$rewind_tape_scan (logical_unit_number: iot$logical_unit;
    VAR io_id: iot$io_id;
    VAR status: ost$status);

    CONST
      disable_unit = TRUE,
      physical_unload = FALSE,
      repeat_count = 1;


    BEGIN
      status.normal := TRUE;

        iop$67x_non_data_trans_setup (logical_unit_number, ioc$tape_rewind, repeat_count,
               disable_unit, physical_unload, io_id, status);

      #INLINE ('keypoint', osk$exit, 0,
            ioc$tape_exit_ioptrew);
    END
  PROCEND iop$rewind_tape_scan;
? IFEND

?? OLDTITLE ??
?? NEWTITLE := ' iop$skip_tapemark_backward ' ??
?? EJECT ??

  PROCEDURE iop$skip_tapemark_backward (
        system_file_id: dmt$system_file_id;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

    CONST
      disable_unit = true,
      physical_unload = FALSE;

    VAR
      io_id: iot$io_id,
      logical_unit_number: iot$logical_unit;

{ NOTE - This procedure should be used for cartridge tape only.

    status.normal := TRUE;

    convert_sfid_to_lun (system_file_id, logical_unit_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    iop$67x_non_data_trans_setup (logical_unit_number, ioc$skip_tapemark_backward, {count} 1,
           disable_unit, physical_unload, io_id, status);

    IF status.normal THEN
      iop$tape_internal_request_stat (logical_unit_number, io_id, {buf_release =} TRUE,
            {bid_recovery =} FALSE,  {bid_update =} TRUE, osc$wait, io_status, status);
     IFEND;

    IF NOT status.normal OR (NOT io_status.normal_completion) THEN
      io_status.position_uncertain := TRUE;
    IFEND;

  PROCEND iop$skip_tapemark_backward;

?? OLDTITLE ??
?? NEWTITLE := ' iop$skip_tapemark_forward ' ??
?? EJECT ??

  PROCEDURE iop$skip_tapemark_forward (
        system_file_id: dmt$system_file_id;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

    CONST
      disable_unit = true,
      physical_unload = FALSE;

    VAR
      io_id: iot$io_id,
      logical_unit_number: iot$logical_unit;

{ NOTE - This procedure should be used for cartridge tape only.

    status.normal := TRUE;

    convert_sfid_to_lun (system_file_id, logical_unit_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    iop$67x_non_data_trans_setup (logical_unit_number, ioc$skip_tapemark_forward, {count} 1,
           disable_unit, physical_unload, io_id, status);

    IF status.normal THEN
      iop$tape_internal_request_stat (logical_unit_number, io_id, {buf_release =} TRUE,
            {bid_recovery =} FALSE, {bid_update =} TRUE, osc$wait, io_status, status);
    IFEND;

    IF NOT status.normal OR (NOT io_status.normal_completion) THEN
      io_status.position_uncertain := TRUE;
    IFEND;

  PROCEND iop$skip_tapemark_forward;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_build_pp_req_header ' ??
?? EJECT ??

  PROCEDURE iop$tape_build_pp_req_header (unit_number: iot$logical_unit;
        length: iot$request_length;
    VAR pp_req: ^iot$tape_request;
    VAR status: ost$status);

    VAR
      current_heap: ^ost$heap,
      found: boolean,
      i: iot$no_of_tape_units,
      index: 1 .. ioc$max_multiple_tape_requests + 1,
      p_ud: ^iot$tape_job_unit_descriptor;

    CONST
      m1 = ioc$tape_mode_command_index;

      status.normal := TRUE;
      iop$set_current_heap (current_heap);
      pp_req := NIL;

      i := 1;
      found := FALSE;

      IF iov$p_statistic_data_p_array <> NIL THEN
        WHILE (i <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
          IF unit_number = iov$p_statistic_data_p_array^ [i].logical_unit THEN
            found := TRUE;
          ELSE
            i := i + 1;
          IFEND;
        WHILEND;
      IFEND;

      IF NOT found THEN
        osp$set_status_abnormal ('io', ioc$os_failure,
              'unable to find unit in iop$tape_build_pp_req_header', status);
        RETURN;
      IFEND;

      p_ud := iov$p_statistic_data_p_array^ [i].p_tape_job_unit_descriptor;

{ Find empty slot for request.

      found := FALSE;
    /search_for_request_slot/
      FOR index := 1 to ioc$max_multiple_tape_requests + 1 DO
        IF NOT p_ud^.pageable_tape_requests [index].slot_in_use THEN
          p_ud^.pageable_tape_requests [index].slot_in_use := TRUE;
          pp_req := p_ud^.pageable_tape_requests [index].tape_request_p;
          pp_req^.pp_response_p := p_ud^.pageable_tape_requests [index].pp_response_p;
          pp_req^.pageable_tape_request_index := index;
          pp_req^.must_free_pageable_request := FALSE;
          found := TRUE;
          EXIT /search_for_request_slot/;
        IFEND;
      FOREND /search_for_request_slot/;

      IF NOT found THEN

{ Must allocate new request.  This can occur if recurrsive error recovery is in
{ progress.  The request and response are FREE'ed in iop$tape_internal_request_stat.

        ALLOCATE pp_req IN current_heap^;
        pp_req^.pp_response_p := NIL;
        ALLOCATE pp_req^.pp_response_p IN current_heap^;
        pp_req^.must_free_pageable_request := TRUE;
      IFEND;


{ Initialize the PP request header.

      pp_req^.request.fill1 := 0;
      pp_req^.request.next_pp_request := NIL;
      pp_req^.request.fill2 := 0;
      pp_req^.request.next_pp_request_rma := 0;
      pp_req^.request.request_length := length;
      pp_req^.request.logical_unit := unit_number;
      pp_req^.request.recovery := ioc$attempt_recovery;
      pp_req^.request.interrupt.value := FALSE;
      pp_req^.request.interrupt.port_number := 0;
      pp_req^.request.priority := 0;
      pp_req^.request.alert_mask.compare_not_satisfied := FALSE;
      pp_req^.request.alert_mask.long_input_block := FALSE;
      pp_req^.request.alert_mask.physical_delimiter := FALSE;
      pp_req^.request.alert_mask.logical_delimiter := FALSE;
      pp_req^.request.alert_mask.character_fill := FALSE;
      pp_req^.request.alert_mask.disabled_unit := TRUE;
      pp_req^.request.alert_mask.fill := 0;
      pp_req^.tcu_parity_retry_count := 0;
      pp_req^.parity_retry_count := 0;
      pp_req^.lost_data_retry_count := 0;
      pp_req^.busy_retry_count := 0;
      pp_req^.lateack_retry_count := 0;
      pp_req^.misc_retry_count := 0;
      pp_req^.ipi_retry_count := 0;
      pp_req^.blocks_accessed := 0;
      pp_req^.transfer_count := 0;
      pp_req^.initial_block_count := 0;
      pp_req^.io_status.io_complete := FALSE;
      pp_req^.io_status.normal_completion := FALSE;
      pp_req^.io_status.wait_selected := FALSE;
      pp_req^.io_status.write_ring := FALSE;
      pp_req^.io_status.end_of_tape := FALSE;
      pp_req^.io_status.beginning_of_tape := FALSE;
      pp_req^.io_status.unit_busy := FALSE;
      pp_req^.io_status.unit_ready := FALSE;
      pp_req^.io_status.long_input_block := FALSE;
      pp_req^.io_status.position_uncertain := FALSE;
      pp_req^.io_status.completion_code := ioc$indeterminate;
      pp_req^.io_status.residual_block_count := 0;
      pp_req^.write_block_description := NIL;
      pp_req^.read_block_description := NIL;
      pp_req^.inhibit_error_recovery := FALSE;
      pp_req^.no_of_data_commands := 0;
      pp_req^.no_of_non_data_commands := 0;
      pp_req^.error := FALSE;
      pp_req^.max_input_count := 0;
      pp_req^.last_command_processed := 0;
      pp_req^.first_data_command := 0;
      pp_req^.estimated_address_pair_count := 2;
      pp_req^.recovery_requeue := FALSE;
      pp_req^.ccc_cart_buf_underrun_recovery := FALSE;

      pp_req^.request.mode := p_ud^.format_parameters;
      pp_req^.ud := p_ud;
      pp_req^.io_id := p_ud^.io_id;
      pp_req^.pp_response_p^.controller_type := p_ud^.controller_type;

      p_ud^.io_id := p_ud^.io_id + 1;

      pp_req^.request.tape_command [m1].command_code := ioc$cc_function;
      pp_req^.request.tape_command [m1].flags.store_response := FALSE;
      pp_req^.request.tape_command [m1].flags.indirect_address := FALSE;
      pp_req^.request.tape_command [m1].flags.fill := 0;
      pp_req^.request.tape_command [m1].length := ioc$tape_function_code_length;
      pp_req^.request.tape_command [m1].address := ioc$67x_func_format;

  PROCEND iop$tape_build_pp_req_header;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_error_logging ' ??
?? EJECT ??

  PROCEDURE iop$tape_error_logging (p_tape_request: ^iot$tape_request;
        tape_failure_type: iot$tape_failure_type;
        on_the_fly_correction_logging: boolean;
    VAR status: ost$status);

? IF system_version THEN

{ Procedure iop$tape_error_logging  services as a routine that logs
{ recovered and unrecovered tape errors.  The procedure is  entered
{ from iop$tape_status_check as soon as an error has been detected.
{ Initial  information  is  collected and temporarily stored. After
{ the error has been determined the initial  entry is finalized and
{ transmitted to the engineering log.
{ This  procedure  uses the failure log entry lay out as documented
{ in Design Action Paper ARH6715.
{ On The Fly Correction Logging is treated as a recovered error log
{ entry with the string *IM* replacing the string *RF*.

    CONST
      eliminate_bits = 16,
      format_bytes = 0ffffffffff(16),
      novalue = -1;

    VAR
      bid_area_p: ^iot$unit_communication_buffer,
      channel: cmt$physical_channel,
      concurrent: 0 .. 1,
      found: boolean,
      i: integer,
      iou_number: dst$iou_number,
      logical_unit: iot$logical_unit,
      offset: iot$no_of_tape_units,
      p_counters: sft$counters,
      p_counters_seq: ^SEQ (*),
      p_hardware_status: ^array [1 .. ioc$extended_status_length] of 0 .. 0ffff(16),
      p_tape_failure_data: ^iot$tape_failure_data,
      p_tape_format: ^0 .. format_bytes,
      p_ud: ^iot$tape_job_unit_descriptor,
      path: ost$string,
      pp: 0 .. 0ff(16),
      pp_interface_table_p: ^iot$pp_interface_table,
      statistic_code: sft$statistic_code;

    status.normal := TRUE;

    logical_unit := p_tape_request^.request.logical_unit;
    pp := p_tape_request^.pp_response_p^.pp_no;
    iou_number := cmv$logical_pp_table_p^ [pp].pp_info.channel.iou_number;
    pp_interface_table_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;
    channel.number := pp_interface_table_p^.unit_descriptors [logical_unit].
          physical_path.channel_number;
    IF cmv$logical_pp_table_p^ [pp].pp_info.channel_interlock_p^.
          channel_characteristics [channel.number].concurrent_channel THEN
      concurrent := 1;
    ELSE
      concurrent := 0;
    IFEND;

    CASE tape_failure_type OF

    = ioc$undetermined =

{     Allocate space in the job_pageable_heap for the package that is going to contain
{     the tape_failure_statistic_data.

      p_tape_failure_data := NIL;

      ALLOCATE p_tape_failure_data IN osv$job_pageable_heap^;

{     Save pointer p_tape_failure_data in statistic_data_p_array in a slot that has been
{     reserved for the involved tape unit based on its logical unit number.

      found := FALSE;
      offset := 1;
      WHILE (offset <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
        IF (iov$p_statistic_data_p_array^ [offset].logical_unit = logical_unit) THEN
          iov$p_statistic_data_p_array^ [offset].p_failure_data := p_tape_failure_data;
          found := TRUE;
        ELSE
          offset := offset + 1;
        IFEND;
      WHILEND;

      IF NOT found THEN
        osp$set_status_abnormal ('io', ioc$unrecognized_unit_id,
              'unable to find unit in iop$tape_error_logging', status);
        RETURN;
      IFEND;

{     Obtain the address of the tape job unit descriptor.

      p_ud := iov$p_statistic_data_p_array^ [offset].p_tape_job_unit_descriptor;

{     Collect tape_failure_statistic_data.

      p_tape_failure_data^.package.pp_number.initial_error_status_register := 0;
      p_tape_failure_data^.package.pp_number.final_error_status_register := 0;
      p_tape_failure_data^.package.pp_number.fill1 := 0;
      p_tape_failure_data^.package.pp_number.iou := iou_number;
      p_tape_failure_data^.package.pp_number.fill2 := 0;
      p_tape_failure_data^.package.pp_number.i4_port_a := 0;
      p_tape_failure_data^.package.pp_number.i4_port_b := 0;
      p_tape_failure_data^.package.pp_number.concurrent := concurrent;

      p_tape_failure_data^.package.channel_number.initial_error_status_register :=
            p_tape_request^.pp_response_p^.pp_response.interface_error_code;
      p_tape_failure_data^.package.channel_number.fill1 := 0;
      p_tape_failure_data^.package.channel_number.iou := iou_number;
      p_tape_failure_data^.package.channel_number.fill2 := 0;
      p_tape_failure_data^.package.channel_number.i4_port_a := 0;
      p_tape_failure_data^.package.channel_number.i4_port_b := 0;
      p_tape_failure_data^.package.channel_number.concurrent := concurrent;
      p_tape_failure_data^.package.channel_number.resource_number := channel.number;

      p_tape_failure_data^.package.equipment_number := pp_interface_table_p^.unit_descriptors
                        [logical_unit].physical_path.controller_number;
      p_tape_failure_data^.package.physical_unit_number := pp_interface_table_p^.
                        unit_descriptors [logical_unit].physical_path.physical_unit_number;

      CASE pp_interface_table_p^.unit_descriptors [logical_unit].unit_interface_table^.unit_type OF

      = ioc$dt_mt679_2 =
        p_tape_failure_data^.package.unit_type := 1;

      = ioc$dt_mt679_3 =
        p_tape_failure_data^.package.unit_type := 2;

      = ioc$dt_mt679_4 =
        p_tape_failure_data^.package.unit_type := 3;

      = ioc$dt_mt679_5 =
        p_tape_failure_data^.package.unit_type := 4;

      = ioc$dt_mt679_6 =
        p_tape_failure_data^.package.unit_type := 5;

      = ioc$dt_mt679_7 =
        p_tape_failure_data^.package.unit_type := 6;

      = ioc$dt_mt639_1 =
        p_tape_failure_data^.package.unit_type := 7;

      = ioc$dt_mt698_3x =
        p_tape_failure_data^.package.unit_type := 8;

      ELSE

      CASEND;

      CASE p_tape_request^.request_type OF

      = ioc$tape_clear =
        p_tape_failure_data^.package.operation_code := 5;

      = ioc$tape_rewind =
        p_tape_failure_data^.package.operation_code := 3;

      = ioc$tape_unload =
        p_tape_failure_data^.package.operation_code := 4;

      = ioc$tape_forspace =
        p_tape_failure_data^.package.operation_code := 8;

      = ioc$tape_backspace =
        p_tape_failure_data^.package.operation_code := 9;

      = ioc$tape_cont_backspace =
        p_tape_failure_data^.package.operation_code := 11;

      = ioc$tape_read =
        p_tape_failure_data^.package.operation_code := 1;

      = ioc$tape_write =
        p_tape_failure_data^.package.operation_code := 2;

      = ioc$tape_loop1 =
        p_tape_failure_data^.package.operation_code := 13;

      = ioc$tape_loop2 =
        p_tape_failure_data^.package.operation_code := 14;

      = ioc$tape_loop3 =
        p_tape_failure_data^.package.operation_code := 15;

      = ioc$tape_write_tapemark =
        p_tape_failure_data^.package.operation_code := 6;

      = ioc$tape_erase =
        p_tape_failure_data^.package.operation_code := 7;

      = ioc$tape_data_security_erase =
        p_tape_failure_data^.package.operation_code := 7;

      = ioc$tape_get_status =
        p_tape_failure_data^.package.operation_code := 12;

      = ioc$skip_tapemark_forward =
        p_tape_failure_data^.package.operation_code := 10;

      = ioc$skip_tapemark_backward =
        p_tape_failure_data^.package.operation_code := 11;

      = ioc$tape_master_clear =
        p_tape_failure_data^.package.operation_code := 16;

      ELSE

      CASEND;

      p_tape_failure_data^.package.blocks_written := p_ud^.blocks_written;
      p_tape_failure_data^.package.blocks_read := p_ud^.blocks_read;
      p_tape_failure_data^.package.single_double_track_corrections := p_ud^.single_double_track_corrections;
      p_tape_failure_data^.package.unused_fill1 := novalue;
      p_tape_failure_data^.package.block_count := p_ud^.block_count;
      p_tape_failure_data^.package.tapemark_count := p_ud^.tapemark_count;
      p_tape_format := #LOC (p_tape_request^.request.mode);
      p_tape_failure_data^.package.tape_format_parameters := p_tape_format^ DIV eliminate_bits;

      CASE p_ud^.tape_unit_density OF

      = 0, 1 =
        p_tape_failure_data^.package.density := 1600;

      = 2 =
        p_tape_failure_data^.package.density := 800;

      = 3 =
        p_tape_failure_data^.package.density := 6250;

      ELSE

      CASEND;

      p_hardware_status := #LOC (p_tape_request^.pp_response_p^.device_status);
      FOR i := 1 TO ioc$device_status_length DO
        p_tape_failure_data^.package.initial_hardware_status [i] := p_hardware_status^ [i];
      FOREND;

      CASE pp_interface_table_p^.unit_descriptors [logical_unit].unit_interface_table^.unit_type OF

      = ioc$dt_mt679_5 .. ioc$dt_mt677_4 =

{       Clear the extended device status area for 67x units.

        FOR i := 1 TO ioc$extended_status_length DO
          p_tape_failure_data^.package.initial_extended_status [i] := 0;
        FOREND;

      = ioc$dt_mt639_1, ioc$dt_mt698_3x =

{       Fill out the extended device status.

        IF p_tape_request^.pp_response_p^.pp_response.response_length >
              (ioc$min_response_length + ioc$bid_area_size + ioc$device_status_size) THEN
          p_hardware_status := #LOC (p_tape_request^.pp_response_p^.extended_device_status);
          FOR i := 1 TO ioc$extended_status_length DO
            p_tape_failure_data^.package.initial_extended_status [i] := p_hardware_status^ [i];
          FOREND;
        ELSE {extended status was not returned, so zero the fields}
          FOR i := 1 TO ioc$extended_status_length DO
            p_tape_failure_data^.package.initial_extended_status [i] := 0;
          FOREND;
        IFEND;

      ELSE

      CASEND;

{     Read the Block_Id Window for the active tape unit.

      p_tape_failure_data^.package.historical_bid_index := p_ud^.bid_index;
      p_tape_failure_data^.package.historical_limit := UPPERVALUE(iot$bid_index);
      p_tape_failure_data^.package.historical_reserved_area := 0;
      FOR i := 1 TO ioc$bid_window_length DO
        p_tape_failure_data^.package.historical_bid_window [i] := p_ud^.bid_window [i];
      FOREND;

    = ioc$recovered, ioc$unrecovered =

{     Restore the pointer to the statistic package.

      found := FALSE;
      offset := 1;
      WHILE (offset <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
        IF (iov$p_statistic_data_p_array^ [offset].logical_unit = logical_unit) THEN
          p_tape_failure_data := iov$p_statistic_data_p_array^ [offset].p_failure_data;
          found := TRUE;
        ELSE
          offset := offset + 1;
        IFEND;
      WHILEND;

      IF NOT found THEN
        osp$set_status_abnormal ('io', ioc$unrecognized_unit_id,
              'unable to find unit in iop$tape_error_logging', status);
        RETURN;
      IFEND;

{     Obtain the address of the tape job unit descriptor.

      p_ud := iov$p_statistic_data_p_array^ [offset].p_tape_job_unit_descriptor;

{     Use channel, equipment and IOU number from first occurrence of failure.

      IF (p_tape_failure_data^.package.channel_number.concurrent = 0) THEN
        channel.concurrent := FALSE;
      ELSE
        channel.concurrent := TRUE;
      IFEND;
      iou_number := p_tape_failure_data^.package.channel_number.iou;
      channel.number := p_tape_failure_data^.package.channel_number.resource_number;
      channel.port := cmc$unspecified_port;

      cmp$return_descriptor_data (channel, iou_number, p_tape_failure_data^.package.equipment_number,
            logical_unit, path, pp);

      IF path.size > 226 THEN
        path.size := 226;
      IFEND;
      path.size := path.size + 1;

{     Fill out the pp number in tape_failure_statistic_data.

      p_tape_failure_data^.package.pp_number.resource_number := pp;

      CASE tape_failure_type OF

      = ioc$recovered =
        IF on_the_fly_correction_logging THEN
          p_tape_failure_data^.package.failure_severity := 3;
          p_tape_failure_data^.package.failure_symptom_code := ioc$hardware_correction_logging;
          path.value (path.size, * ) := '*IM*ON THE FLY HARDWARE CORRECTIONS';
        ELSE
          p_tape_failure_data^.package.failure_severity := 0;
          p_tape_failure_data^.package.failure_symptom_code := 0;
          path.value (path.size, * ) := '*RF*';
        IFEND;

{       Clear the device status.

        FOR i := 1 TO ioc$device_status_length DO
          p_tape_failure_data^.package.final_hardware_status [i] := 0;
        FOREND;

{       Clear the BLOCK_ID window.

        p_tape_failure_data^.package.current_bid_index := 0;
        p_tape_failure_data^.package.current_limit := 0;
        p_tape_failure_data^.package.current_reserved_area := 0;
        FOR i := 1 TO ioc$bid_window_length DO
          p_tape_failure_data^.package.current_bid_window [i] := 0;
        FOREND;

        p_tape_failure_data^.package.channel_number.final_error_status_register := 0;

      = ioc$unrecovered =
        p_tape_failure_data^.package.failure_severity := 1;
        CASE p_tape_request^.io_status.completion_code  OF

        = ioc$indeterminate =
          path.value (path.size, * ) := '*UF*INDETERMINATE*';
          p_tape_failure_data^.package.failure_symptom_code := 1;

        = ioc$input_channel_parity =
          path.value (path.size, * ) := '*UF*INPUT_CHANNEL_PARITY*';
          p_tape_failure_data^.package.failure_symptom_code := 2;

        = ioc$output_channel_parity =
          path.value (path.size, * ) := '*UF*OUTPUT_CHANNEL_PARITY*';
          p_tape_failure_data^.package.failure_symptom_code := 3;

        = ioc$controller_failure =
          path.value (path.size, * ) := '*UF*CONTROLLER_FAILURE*';
          p_tape_failure_data^.package.failure_symptom_code := 4;

        = ioc$unit_failure =
          path.value (path.size, * ) := '*UF*UNIT_FAILURE*';
          p_tape_failure_data^.package.failure_symptom_code := 5;

        = ioc$function_timeout =
          path.value (path.size, * ) := '*UF*FUNCTION_TIMEOUT*';
          p_tape_failure_data^.package.failure_symptom_code := 6;

        = ioc$tape_medium_failure =
          path.value (path.size, * ) := '*UF*TAPE_MEDIUM_FAILURE*';
          p_tape_failure_data^.package.failure_symptom_code := 7;

        = ioc$erase_limit_exceeded =
          path.value (path.size, * ) := '*UF*ERASE_LIMIT_EXCEEDED*';
          p_tape_failure_data^.package.failure_symptom_code := 8;

        = ioc$unit_reserved =
          path.value (path.size, * ) := '*UF*UNIT_RESERVED*';
          p_tape_failure_data^.package.failure_symptom_code := 9;

        = ioc$iou_output_parity =
          path.value (path.size, * ) := '*UF*IOU_OUTPUT_PARITY*';
          p_tape_failure_data^.package.failure_symptom_code := 10;

        = ioc$indeterminate_output_parity =
          path.value (path.size, * ) := '*UF*INDETERMINATE_OUTPUT_PARITY*';
          p_tape_failure_data^.package.failure_symptom_code := 11;

        = ioc$unable_to_write_id_burst =
          path.value (path.size, * ) := '*UF*UNABLE_TO_WRITE_ID_BURST*';
          p_tape_failure_data^.package.failure_symptom_code := 12;

        = ioc$unable_to_set_agc =
          path.value (path.size, * ) := '*UF*UNABLE_TO_SET_AGC*';
          p_tape_failure_data^.package.failure_symptom_code := 13;
        ELSE
          path.value (path.size, * ) := '*UF*UNDEFINED_FAILURE_CODE*';
          p_tape_failure_data^.package.failure_symptom_code := p_tape_request^.io_status.
                completion_code;
        CASEND;

{       Fill out the device status.

        p_hardware_status := #LOC (p_tape_request^.pp_response_p^.device_status);
        FOR i := 1 TO ioc$device_status_length DO
          p_tape_failure_data^.package.final_hardware_status [i] := p_hardware_status^ [i];
        FOREND;

{       Fill out the final BLOCK_ID window.

        p_tape_failure_data^.package.current_bid_index := p_ud^.bid_index;
        p_tape_failure_data^.package.current_limit := UPPERVALUE(iot$bid_index);
        p_tape_failure_data^.package.current_reserved_area := 0;
        FOR i := 1 TO ioc$bid_window_length DO
          p_tape_failure_data^.package.current_bid_window [i] := p_ud^.bid_window [i];
        FOREND;

        p_tape_failure_data^.package.channel_number.final_error_status_register :=
              p_tape_request^.pp_response_p^.pp_response.interface_error_code;

      CASEND;

      p_tape_failure_data^.package.recovery_type := novalue;
      p_tape_failure_data^.package.recovery_retry_count := p_tape_request^.tcu_parity_retry_count +
                                                             p_tape_request^.parity_retry_count +
                                                             p_tape_request^.lost_data_retry_count +
                                                             p_tape_request^.lateack_retry_count +
                                                             p_tape_request^.misc_retry_count;

      CASE p_tape_request^.request_type OF

      = ioc$tape_clear =
        p_tape_failure_data^.package.last_requested_function := 5;

      = ioc$tape_rewind =
        p_tape_failure_data^.package.last_requested_function := 3;

      = ioc$tape_unload =
        p_tape_failure_data^.package.last_requested_function := 4;

      = ioc$tape_forspace =
        p_tape_failure_data^.package.last_requested_function := 8;

      = ioc$tape_backspace =
        p_tape_failure_data^.package.last_requested_function := 9;

      = ioc$tape_cont_backspace =
        p_tape_failure_data^.package.last_requested_function := 11;

      = ioc$tape_read =
        p_tape_failure_data^.package.last_requested_function := 1;

      = ioc$tape_write =
        p_tape_failure_data^.package.last_requested_function := 2;

      = ioc$tape_loop1 =
        p_tape_failure_data^.package.last_requested_function := 13;

      = ioc$tape_loop2 =
        p_tape_failure_data^.package.last_requested_function := 14;

      = ioc$tape_loop3 =
        p_tape_failure_data^.package.last_requested_function := 15;

      = ioc$tape_write_tapemark =
        p_tape_failure_data^.package.last_requested_function := 6;

      = ioc$tape_erase =
        p_tape_failure_data^.package.last_requested_function := 7;

      = ioc$tape_data_security_erase =
        p_tape_failure_data^.package.last_requested_function := 7;

      = ioc$tape_get_status =
        p_tape_failure_data^.package.last_requested_function := 12;

      = ioc$skip_tapemark_forward =
        p_tape_failure_data^.package.last_requested_function := 10;

      = ioc$skip_tapemark_backward =
        p_tape_failure_data^.package.last_requested_function := 11;

      = ioc$tape_master_clear =
        p_tape_failure_data^.package.last_requested_function := 16;

      ELSE

      CASEND;


      CASE pp_interface_table_p^.unit_descriptors [logical_unit].unit_interface_table^.unit_type OF

      = ioc$dt_mt679_5 .. ioc$dt_mt677_4 =

{       Clear the extended status area for 67x units.

        FOR i := 1 TO ioc$extended_status_length DO
          p_tape_failure_data^.package.final_extended_status [i] := 0;
        FOREND;

        statistic_code := cml$7021_3x_failure_data;

      = ioc$dt_mt639_1, ioc$dt_mt698_3x =

        CASE tape_failure_type OF

        = ioc$recovered =

{         Clear the extended device status.

          FOR i := 1 TO ioc$extended_status_length DO
            p_tape_failure_data^.package.final_extended_status [i] := 0;
          FOREND;

        = ioc$unrecovered =

{         Fill out the extended device status.

          IF p_tape_request^.pp_response_p^.pp_response.response_length >
                (ioc$min_response_length + ioc$bid_area_size + ioc$device_status_size) THEN
            p_hardware_status := #LOC (p_tape_request^.pp_response_p^.extended_device_status);
            FOR i := 1 TO ioc$extended_status_length DO
              p_tape_failure_data^.package.final_extended_status [i] := p_hardware_status^ [i];
            FOREND;
          ELSE {extended status was not returned, so zero the fields}
            FOR i := 1 TO ioc$extended_status_length DO
              p_tape_failure_data^.package.final_extended_status [i] := 0;
            FOREND;
          IFEND;

        CASEND;

        IF pp_interface_table_p^.unit_descriptors [logical_unit].unit_interface_table^.unit_type =
              ioc$dt_mt639_1 THEN
          statistic_code := cml$7221_1_failure_data;
        ELSE { = ioc$dt_mt698_3x }
          statistic_code := cml$698_1x_failure_data;
        IFEND;

      ELSE

      CASEND;

{     Clear the remaining unused words of tape_failure_statistic_data.

      FOR i := ((#SIZE (p_tape_failure_data^.package) DIV 8) + 1) TO ioc$max_failure_counters DO
        p_tape_failure_data^.counters_array [i] := novalue;
      FOREND;

      path.size := 252;
      /establish_eol/
        FOR i := path.size DOWNTO 1 DO
          IF path.value (i) <> ' ' THEN
            path.size := i + 1;
            EXIT /establish_eol/;
          IFEND;
        FOREND /establish_eol/;

      p_counters_seq := ^p_tape_failure_data^.counters;

      RESET p_counters_seq;
      NEXT p_counters: [1 .. ioc$max_failure_counters] IN p_counters_seq;

      sfp$emit_statistic (statistic_code, path.value (1, path.size), p_counters, status);
{     IF NOT status.normal THEN
{       osp$system_error ('emit error', ^status);
{     IFEND;

{     Return the space allocated to the statistic package in the task private heap and
{     set the pointer to that area to NIL.

      FREE p_tape_failure_data IN osv$job_pageable_heap^;

      iov$p_statistic_data_p_array^ [offset].p_failure_data := NIL;

    ELSE

    CASEND;

? ELSE
    status.normal := TRUE;
? IFEND

  PROCEND iop$tape_error_logging;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_error_logging_ccc_cart ' ??
?? EJECT ??

  PROCEDURE iop$tape_error_logging_ccc_cart (p_tape_request: ^iot$tape_request;
        tape_failure_type: iot$tape_failure_type;
    VAR status: ost$status);

? IF system_version THEN

{ Procedure iop$tape_error_logging_ipi serves as a routine that logs
{ all engineering log entries for CCC Cartridge tape errors.

    CONST
      eliminate_bits = 16,
      format_bytes = 0ffffffffff(16);

    VAR
      channel: cmt$physical_channel,
      concurrent: 0 .. 1,
      found: boolean,
      iou_number: dst$iou_number,
      logical_unit: iot$logical_unit,
      offset: iot$no_of_tape_units,
      p_tape_failure_data: ^iot$ccc_cart_tape_failure_data,
      p_ud: ^iot$tape_job_unit_descriptor,
      pp: 0 .. 0ff(16),
      pp_interface_table_p: ^iot$pp_interface_table;
??EJECT??

      PROCEDURE build_log_entry (failure_type: iot$tape_failure_type);

        VAR
          i: integer,
          p_status: ^array [1 .. 8] of 0 .. 0ff(16),
          p_sense: ^array [1 .. 40] of 0 .. 0ff(16);

        CASE failure_type OF

        = ioc$intermediate =

          p_tape_failure_data^.package.pp_number.initial_error_status_register := 0;
          p_tape_failure_data^.package.pp_number.final_error_status_register := 0;
          p_tape_failure_data^.package.pp_number.fill1 := 0;
          p_tape_failure_data^.package.pp_number.iou := iou_number;
          p_tape_failure_data^.package.pp_number.fill2 := 0;
          p_tape_failure_data^.package.pp_number.i4_port_a := 0;
          p_tape_failure_data^.package.pp_number.i4_port_b := 0;
          p_tape_failure_data^.package.pp_number.concurrent := concurrent;

          p_tape_failure_data^.package.channel_number.initial_error_status_register := 0;
          p_tape_failure_data^.package.channel_number.final_error_status_register := 0;
          p_tape_failure_data^.package.channel_number.fill1 := 0;
          p_tape_failure_data^.package.channel_number.iou := iou_number;
          p_tape_failure_data^.package.channel_number.fill2 := 0;
          p_tape_failure_data^.package.channel_number.i4_port_a := 0;
          p_tape_failure_data^.package.channel_number.i4_port_b := 0;
          p_tape_failure_data^.package.channel_number.concurrent := concurrent;
          p_tape_failure_data^.package.channel_number.resource_number := channel.number;

          p_tape_failure_data^.package.equipment_number := pp_interface_table_p^.unit_descriptors
                [logical_unit].physical_path.controller_number;
          p_tape_failure_data^.package.physical_unit_number := pp_interface_table_p^.
                unit_descriptors [logical_unit].physical_path.physical_unit_number;

          p_tape_failure_data^.package.unit_type := 10;

          CASE p_tape_request^.request_type OF

          = ioc$tape_read =
            p_tape_failure_data^.package.operation_code := 1;

          = ioc$tape_write =
            p_tape_failure_data^.package.operation_code := 2;

          = ioc$tape_rewind =
            p_tape_failure_data^.package.operation_code := 3;

          = ioc$tape_unload =
            p_tape_failure_data^.package.operation_code := 4;

          = ioc$locate_block =
            p_tape_failure_data^.package.operation_code := 5;

          = ioc$tape_write_tapemark =
            p_tape_failure_data^.package.operation_code := 6;

          = ioc$tape_erase =
            p_tape_failure_data^.package.operation_code := 7;

          = ioc$tape_forspace =
            p_tape_failure_data^.package.operation_code := 8;

          = ioc$tape_backspace =
            p_tape_failure_data^.package.operation_code := 9;

          = ioc$skip_tapemark_forward =
            p_tape_failure_data^.package.operation_code := 10;

          = ioc$skip_tapemark_backward =
            p_tape_failure_data^.package.operation_code := 11;

          = ioc$tape_get_status =
            p_tape_failure_data^.package.operation_code := 12;

          ELSE

          CASEND;

          p_tape_failure_data^.package.failure_symptom_code := p_tape_request^.pp_response_p^.
                ccc_cart_device_status.error_id;
          p_tape_failure_data^.package.blocks_written := p_ud^.blocks_written;
          p_tape_failure_data^.package.blocks_read := p_ud^.blocks_read;
          p_tape_failure_data^.package.block_count := p_ud^.block_count;
          p_tape_failure_data^.package.tapemark_count := p_ud^.tapemark_count;
          p_tape_failure_data^.package.last_function.last_not_status := p_tape_request^.
                pp_response_p^.ccc_cart_device_status.last_non_status_function;
          p_tape_failure_data^.package.last_function.last := p_tape_request^.
                pp_response_p^.ccc_cart_device_status.last_function;
          p_tape_failure_data^.package.last_function.fill := 0;
          p_tape_failure_data^.package.first_error_status_register := p_tape_request^.
                pp_response_p^.ccc_cart_device_status.channel_error_register;
          p_tape_failure_data^.package.density := 38000;

          p_status := #LOC (p_tape_request^.pp_response_p^.ccc_cart_device_status);
          FOR i := 1 TO 8 DO
            p_tape_failure_data^.package.initial_status [i] := p_status^ [i];
          FOREND;

          IF p_tape_request^.pp_response_p^.pp_response.response_length >
                ioc$min_ccc_cart_resp_size THEN
            p_sense := #LOC (p_tape_request^.pp_response_p^.ccc_cart_sense_bytes);
            FOR i := 1 TO 40 DO
              p_tape_failure_data^.package.initial_sense_bytes [i] := p_sense^ [i];
            FOREND;
          ELSE { no sense bytes
            FOR i := 1 TO 40 DO
              p_tape_failure_data^.package.initial_sense_bytes [i] := 0;
            FOREND;
          IFEND;

          p_tape_failure_data^.package.res2 := 0;
          p_tape_failure_data^.package.last_failure_info.fill := 0;
          p_tape_failure_data^.package.last_failure_info.error_id := 0;
          p_tape_failure_data^.package.last_failure_info.last_non_status_function := 0;
          p_tape_failure_data^.package.last_failure_info.last_function := 0;

          IF p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id = ioc$ccc_cart_hardware_corr THEN
            FOR i := 1 TO 8 DO
              p_tape_failure_data^.package.initial_status [i] := 0;
            FOREND;
            FOR i := 1 TO 40 DO
              p_tape_failure_data^.package.initial_sense_bytes [i] := 0;
            FOREND;
            p_tape_failure_data^.package.on_the_fly_read_corrections := p_tape_request^.
                  pp_response_p^.ccc_cart_error_log.on_the_fly_read_errors;
            p_tape_failure_data^.package.on_the_fly_write_corrections := p_tape_request^.
                  pp_response_p^.ccc_cart_error_log.on_the_fly_write_errors;
            p_tape_failure_data^.package.read_recovery_count := p_tape_request^.
                  pp_response_p^.ccc_cart_error_log.recovered_read_errors;
            p_tape_failure_data^.package.write_recovery_count := p_tape_request^.
                  pp_response_p^.ccc_cart_error_log.recovered_write_errors;
            p_tape_failure_data^.package.buffer_underruns := p_ud^.ccc_cart_buffer_underruns;
          ELSE
            p_tape_failure_data^.package.on_the_fly_read_corrections := 0;
            p_tape_failure_data^.package.on_the_fly_write_corrections := 0;
            p_tape_failure_data^.package.read_recovery_count := 0;
            p_tape_failure_data^.package.write_recovery_count := 0;
            p_tape_failure_data^.package.buffer_underruns := 0;
          IFEND;

        = ioc$recovered =

          p_tape_failure_data^.package.failure_severity := 0;
          p_tape_failure_data^.package.recovery_retry_count := p_tape_request^.parity_retry_count +
                                                               p_tape_request^.misc_retry_count;

          p_status := #LOC (p_tape_request^.pp_response_p^.ccc_cart_device_status);
          FOR i := 1 TO 8 DO
            p_tape_failure_data^.package.final_status [i] := p_status^ [i];
          FOREND;

          FOR i := 1 TO 40 DO
            p_tape_failure_data^.package.final_sense_bytes [i] := 0;
          FOREND;

          p_tape_failure_data^.package.final_error_status_register := p_tape_request^.
                pp_response_p^.ccc_cart_device_status.channel_error_register;

        = ioc$unrecovered =

          p_tape_failure_data^.package.failure_severity := 1;
          p_tape_failure_data^.package.recovery_retry_count := p_tape_request^.parity_retry_count +
                                                               p_tape_request^.misc_retry_count;

          p_tape_failure_data^.package.last_failure_info.last_non_status_function :=
                p_tape_request^.pp_response_p^.ccc_cart_device_status.last_non_status_function;
          p_tape_failure_data^.package.last_failure_info.last_function :=
                p_tape_request^.pp_response_p^.ccc_cart_device_status.last_function;
          p_tape_failure_data^.package.last_failure_info.error_id :=
                p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id;

          p_status := #LOC (p_tape_request^.pp_response_p^.ccc_cart_device_status);
          FOR i := 1 TO 8 DO
            p_tape_failure_data^.package.final_status [i] := p_status^ [i];
          FOREND;

          IF p_tape_request^.pp_response_p^.pp_response.response_length >
                ioc$min_ccc_cart_resp_size THEN
            p_sense := #LOC (p_tape_request^.pp_response_p^.ccc_cart_sense_bytes);
            FOR i := 1 TO 40 DO
              p_tape_failure_data^.package.final_sense_bytes [i] := p_sense^ [i];
            FOREND;
          ELSE { no sense bytes
            FOR i := 1 TO 40 DO
              p_tape_failure_data^.package.final_sense_bytes [i] := 0;
            FOREND;
          IFEND;

          p_tape_failure_data^.package.final_error_status_register := p_tape_request^.
                pp_response_p^.ccc_cart_device_status.channel_error_register;

        ELSE

        CASEND;

      PROCEND build_log_entry;
?? EJECT ??
    status.normal := TRUE;

    logical_unit := p_tape_request^.request.logical_unit;
    pp := p_tape_request^.pp_response_p^.pp_no;
    iou_number := cmv$logical_pp_table_p^ [pp].pp_info.channel.iou_number;
    pp_interface_table_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;
    channel.number := pp_interface_table_p^.unit_descriptors [logical_unit].
          physical_path.channel_number;
    IF cmv$logical_pp_table_p^ [pp].pp_info.channel_interlock_p^.
          channel_characteristics [channel.number].concurrent_channel THEN
      concurrent := 1;
    ELSE
      concurrent := 0;
    IFEND;

    found := FALSE;
    offset := 1;
    WHILE (offset <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
      IF (iov$p_statistic_data_p_array^ [offset].logical_unit = logical_unit) THEN
        p_tape_failure_data := iov$p_statistic_data_p_array^ [offset].p_ccc_cart_failure_data;
        found := TRUE;
      ELSE
        offset := offset + 1;
      IFEND;
    WHILEND;

    IF NOT found THEN
      osp$set_status_abnormal ('io', ioc$unrecognized_unit_id,
            'unable to find unit in iop$tape_error_logging_ipi', status);
      RETURN;
    IFEND;

{ Obtain the address of the tape job unit descriptor.

    p_ud := iov$p_statistic_data_p_array^ [offset].p_tape_job_unit_descriptor;

    IF p_tape_failure_data = NIL THEN  { no pending entry

{     Allocate space in the job_pageable_heap for the package that is going to contain
{     the tape_failure_statistic_data.

      ALLOCATE p_tape_failure_data IN osv$job_pageable_heap^;

      IF tape_failure_type = ioc$intermediate THEN
        build_log_entry (tape_failure_type);
        iov$p_statistic_data_p_array^ [offset].p_ccc_cart_failure_data := p_tape_failure_data;
        RETURN;
      ELSE  {unrecovered or recovered
        build_log_entry (ioc$intermediate);
        build_log_entry (tape_failure_type);
        iop$issue_ccc_cart_log_entry (p_tape_failure_data, logical_unit, status);
        FREE p_tape_failure_data IN osv$job_pageable_heap^;
        iov$p_statistic_data_p_array^ [offset].p_ccc_cart_failure_data := NIL;
        RETURN;
      IFEND;

    ELSE  { there is a pending error log entry

      IF (tape_failure_type = ioc$unrecovered) OR (tape_failure_type = ioc$recovered) THEN
        IF (tape_failure_type = ioc$recovered) AND p_tape_request^.ccc_cart_buf_underrun_recovery THEN
          p_ud^.ccc_cart_buffer_underruns := p_ud^.ccc_cart_buffer_underruns + 1;
          p_tape_request^.ccc_cart_buf_underrun_recovery := FALSE;
        ELSE
          build_log_entry (tape_failure_type);
          iop$issue_ccc_cart_log_entry (p_tape_failure_data, logical_unit, status);
        IFEND;
        FREE p_tape_failure_data IN osv$job_pageable_heap^;
        iov$p_statistic_data_p_array^ [offset].p_ccc_cart_failure_data := NIL;

      ELSE { ioc$intermediate or ioc$informative are illegal
        osp$set_status_abnormal ('io', ioc$os_failure,
              'Incorrect tape_failure_type in iop$tape_error_logging_ccc_cart', status);

      IFEND;

    IFEND;

? ELSE
    status.normal := TRUE;
? IFEND

  PROCEND iop$tape_error_logging_ccc_cart;
?? OLDTITLE ??
?? NEWTITLE := ' iop$issue_ccc_cart_log_entry ' ??
?? EJECT ??
? IF system_version THEN

  PROCEDURE [XDCL, #GATE] iop$issue_ccc_cart_log_entry (
        p_tape_failure_data: ^iot$ccc_cart_tape_failure_data;
        logical_unit: iot$logical_unit;
    VAR status: ost$status);

    VAR
      bytes_last_word: 0 .. 8,
      channel: cmt$physical_channel,
      iou_number: dst$iou_number,
      p_counters: sft$counters,
      p_counters_seq: ^SEQ ( * ),
      path: ost$string,
      pp: 0 .. 0ff(16),
      statistic_code: sft$statistic_code,
      text: string (ioc$max_ccc_cart_error_text);

    status.normal := TRUE;

    IF iov$establish_tape_statistics THEN
      iop$establish_tape_statistics (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Use channel, equipment and IOU number from first occurrence of failure.

    IF (p_tape_failure_data^.package.channel_number.concurrent = 0) THEN
      channel.concurrent := FALSE;
    ELSE
      channel.concurrent := TRUE;
    IFEND;
    iou_number := p_tape_failure_data^.package.channel_number.iou;
    channel.number := p_tape_failure_data^.package.channel_number.resource_number;
    channel.port := cmc$unspecified_port;

    cmp$return_descriptor_data (channel, iou_number, p_tape_failure_data^.package.equipment_number,
          logical_unit, path, pp);

    IF path.size > 226 THEN
      path.size := 226;
    IFEND;
    path.size := path.size + 1;

{ Fill out the pp number in tape_failure_statistic_data.

    p_tape_failure_data^.package.pp_number.resource_number := pp;

    IF p_tape_failure_data^.package.failure_severity = 0 THEN  { recovered
      path.value (path.size, * ) := '*RF*';
    ELSEIF p_tape_failure_data^.package.failure_severity = 1 THEN  { unrecovered
      path.value (path.size, * ) := '*UF*';
    ELSEIF p_tape_failure_data^.package.failure_severity = 2 THEN  { intermediate
      path.value (path.size, * ) := '*IF*';
    ELSEIF p_tape_failure_data^.package.failure_severity = 3 THEN  { informative
      path.value (path.size, * ) := '*IM*';
    IFEND;

    path.size := path.size + 4;

    iop$determine_err_text_ccc_cart  (p_tape_failure_data^.package.failure_symptom_code, text);
    path.value (path.size, *) := text;
    path.size := path.size + ioc$max_ccc_cart_error_text;

    p_counters_seq := ^p_tape_failure_data^.counters;

    RESET p_counters_seq;
    NEXT p_counters: [1 .. ioc$max_ccc_cart_counters] IN p_counters_seq;
    statistic_code := cml$5680_11_failure_data;

    sfp$emit_statistic (statistic_code, path.value (1, path.size), p_counters, status);

  PROCEND iop$issue_ccc_cart_log_entry;

? IFEND

?? OLDTITLE ??
?? NEWTITLE := ' iop$determine_err_text_ccc_cart ' ??
?? EJECT ??
? IF system_version THEN

  PROCEDURE iop$determine_err_text_ccc_cart (
        error_id: 0 .. ioc$max_ccc_cart_error_id;
    VAR text: string (ioc$max_ccc_cart_error_text));

    CASE error_id OF

    = ioc$ccc_cart_no_pp_eid, ioc$ccc_cart_indeterminate =
      text := 'INDETERMINATE';

    = ioc$ccc_cart_input_chan_parity =
      text := 'INPUT CHANNEL PARITY';

    = ioc$ccc_cart_output_chan_par =
      text := 'OUTPUT CHANNEL PARITY';

    = ioc$ccc_cart_coupler_failure =
      text := 'COUPLER FAILURE';

    = ioc$ccc_cart_cu_failure =
      text := 'CONTROL UNIT FAILURE';

    = ioc$ccc_cart_unit_failure =
      text := 'UNIT FAILURE';

    = ioc$ccc_cart_unit_not_ready =
      text := 'UNIT NOT READY';

    = ioc$ccc_cart_function_timeout =
      text := 'FUNCTION TIMEOUT';

    = ioc$ccc_cart_tape_medium =
      text := 'TAPE MEDIUM FAILURE';

    = ioc$ccc_cart_iou_parity =
      text := 'IOU OUTPUT PARITY';

    = ioc$ccc_cart_indeterminate_par =
      text := 'INDETERMINATE OUTPUT PARITY';

    = ioc$ccc_cart_write_id_mark =
      text := 'UNABLE TO WRITE ID MARK';

    = ioc$ccc_cart_read_id_mark =
      text := 'UNABLE TO READ ID MARK';

    = ioc$ccc_cart_hardware_corr =
      text := 'HARDWARE CORRECTIONS';

    = ioc$ccc_cart_microcode_load =
      text := 'MICROCODE LOAD ERROR';

    = ioc$ccc_cart_invalid_bid =
      text := 'BLOCK ID INVALID';

    = ioc$ccc_cart_inc_trans_in =
      text := 'INCOMPLETE TRANSFER ON INPUT';

    = ioc$ccc_cart_inc_trans_out =
      text := 'INCOMPLETE TRANSFER ON OUTPUT';

    = ioc$ccc_cart_pp_chan_flag =
      text := 'CHANNEL ERROR FLAG';

    = ioc$ccc_cart_single_pp,
      ioc$ccc_cart_unit_type,
      ioc$ccc_cart_ill_command,
      ioc$ccc_cart_ill_comm_buf_lng,
      ioc$ccc_cart_ill_write_sequence,
      ioc$ccc_cart_reserved_1,
      ioc$ccc_cart_ill_abn_status,
      ioc$ccc_cart_no_alert,
      ioc$ccc_cart_no_abn_status =
      text := 'SOFTWARE FAILURE';

    ELSE

      text := 'UNKNOWN ERROR ID';

    CASEND;

  PROCEND iop$determine_err_text_ccc_cart;

? IFEND

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_error_logging_ipi ' ??
?? EJECT ??

  PROCEDURE iop$tape_error_logging_ipi (p_tape_request: ^iot$tape_request;
        tape_failure_type: iot$tape_failure_type;
    VAR status: ost$status);

? IF system_version THEN

{ Procedure iop$tape_error_logging_ipi serves as a routine that logs
{ all engineering log entries for IPI tape errors.

    CONST
      eliminate_bits = 16,
      format_bytes = 0ffffffffff(16);

    VAR
      channel: cmt$physical_channel,
      concurrent: 0 .. 1,
      found: boolean,
      iou_number: dst$iou_number,
      logical_unit: iot$logical_unit,
      offset: iot$no_of_tape_units,
      p_tape_failure_data: ^iot$ipi_tape_failure_data,
      p_ud: ^iot$tape_job_unit_descriptor,
      port_a: 0 .. 1,
      port_b: 0 .. 1,
      pp: 0 .. 0ff(16),
      pp_interface_table_p: ^iot$pp_interface_table;
??EJECT??

      PROCEDURE build_log_entry;

        VAR
          i: integer,
          p_major_status: ^array [1 .. ioc$ipi_max_status_size] of 0 .. 0ff(16),
          p_tape_format: ^0 .. format_bytes,
          status_length: 1 .. ioc$ipi_max_status_size;


        p_tape_failure_data^.package.pp_number.initial_error_status_register := 0;
        p_tape_failure_data^.package.pp_number.final_error_status_register := 0;
        p_tape_failure_data^.package.pp_number.fill1 := 0;
        p_tape_failure_data^.package.pp_number.iou := iou_number;
        p_tape_failure_data^.package.pp_number.fill2 := 0;
        p_tape_failure_data^.package.pp_number.i4_port_a := 0;
        p_tape_failure_data^.package.pp_number.i4_port_b := 0;
        p_tape_failure_data^.package.pp_number.concurrent := concurrent;

        p_tape_failure_data^.package.channel_number.initial_error_status_register := 0;
        p_tape_failure_data^.package.channel_number.final_error_status_register := 0;
        p_tape_failure_data^.package.channel_number.fill1 := 0;
        p_tape_failure_data^.package.channel_number.iou := iou_number;
        p_tape_failure_data^.package.channel_number.fill2 := 0;
        p_tape_failure_data^.package.channel_number.i4_port_a := port_a;
        p_tape_failure_data^.package.channel_number.i4_port_b := port_b;
        p_tape_failure_data^.package.channel_number.concurrent := concurrent;
        p_tape_failure_data^.package.channel_number.resource_number := channel.number;

        p_tape_failure_data^.package.equipment_number := pp_interface_table_p^.unit_descriptors
              [logical_unit].physical_path.controller_number;
        p_tape_failure_data^.package.physical_unit_number := pp_interface_table_p^.
              unit_descriptors [logical_unit].physical_path.physical_unit_number;

        p_tape_failure_data^.package.unit_type := 9;

        CASE p_tape_request^.request_type OF

        = ioc$tape_read =
          p_tape_failure_data^.package.operation_code := 1;

        = ioc$tape_write =
          p_tape_failure_data^.package.operation_code := 2;

        = ioc$tape_rewind =
          p_tape_failure_data^.package.operation_code := 3;

        = ioc$tape_unload =
          p_tape_failure_data^.package.operation_code := 4;

        = ioc$tape_write_tapemark =
          p_tape_failure_data^.package.operation_code := 6;

        = ioc$tape_erase =
          p_tape_failure_data^.package.operation_code := 7;

        = ioc$tape_data_security_erase =
          p_tape_failure_data^.package.operation_code := 7;

        = ioc$tape_forspace =
          p_tape_failure_data^.package.operation_code := 8;

        = ioc$tape_backspace =
          p_tape_failure_data^.package.operation_code := 9;

        = ioc$skip_tapemark_forward =
          p_tape_failure_data^.package.operation_code := 10;

        = ioc$skip_tapemark_backward =
          p_tape_failure_data^.package.operation_code := 11;

        = ioc$tape_get_status =
          p_tape_failure_data^.package.operation_code := 12;

        ELSE

        CASEND;

        CASE tape_failure_type OF

        = ioc$recovered =
          p_tape_failure_data^.package.failure_severity := 0;

        = ioc$unrecovered =
          p_tape_failure_data^.package.failure_severity := 1;

        = ioc$intermediate =
          p_tape_failure_data^.package.failure_severity := 2;

        = ioc$informative =
          p_tape_failure_data^.package.failure_severity := 3;

        ELSE
        CASEND;
        p_tape_failure_data^.package.failure_symptom_code := p_tape_request^.pp_response_p^.
              ipi_tape_status.error_id;
        p_tape_failure_data^.package.blocks_written := p_ud^.blocks_written;
        p_tape_failure_data^.package.blocks_read := p_ud^.blocks_read;
        p_tape_failure_data^.package.single_double_track_corrections := p_ud^.single_double_track_corrections;
        p_tape_failure_data^.package.unused_fill1 := 0;
        p_tape_failure_data^.package.block_count := p_ud^.block_count;
        p_tape_failure_data^.package.tapemark_count := p_ud^.tapemark_count;
        p_tape_format := #LOC (p_tape_request^.request.mode);
        p_tape_failure_data^.package.tape_format_parameters := p_tape_format^ DIV eliminate_bits;

        CASE p_ud^.tape_unit_density OF

        = 0, 1 =
          p_tape_failure_data^.package.density := 1600;

        = 2 =
          p_tape_failure_data^.package.density := 800;

        = 3 =
          p_tape_failure_data^.package.density := 6250;

        ELSE

        CASEND;

        p_tape_failure_data^.package.unused_fill2 := 0;
        p_tape_failure_data^.package.recovery_retry_count := p_tape_request^.parity_retry_count +
                                                             p_tape_request^.ipi_retry_count +
                                                             p_tape_request^.misc_retry_count;
        p_tape_failure_data^.package.last_requested_function := p_tape_request^.pp_response_p^.
              ipi_tape_status.function_with_timeout;
        p_tape_failure_data^.package.ipi_status_register := p_tape_request^.pp_response_p^.
              ipi_tape_status.ipi_status_register;
        p_tape_failure_data^.package.ipi_error_register := p_tape_request^.pp_response_p^.
              ipi_tape_status.ipi_error_register;
        p_tape_failure_data^.package.i4_error_register := p_tape_request^.pp_response_p^.
              ipi_tape_status.i4_dma_error_register;
        p_tape_failure_data^.package.i4_operation_register := p_tape_request^.pp_response_p^.
              ipi_tape_status.i4_dma_operational_status_reg;
        p_tape_failure_data^.package.i4_control_register := p_tape_request^.pp_response_p^.
              ipi_tape_status.i4_dma_control_register;
        p_tape_failure_data^.package.interface_error_code :=
              p_tape_request^.pp_response_p^.pp_response.interface_error_code;
        p_tape_failure_data^.package.unused_fill3 := 0;
        p_tape_failure_data^.package.unused_fill4 := 0;
        p_tape_failure_data^.package.unused_fill5 := 0;
        p_tape_failure_data^.package.unused_fill6 := 0;
        p_tape_failure_data^.package.unused_fill7 := 0;
        p_major_status := #LOC (p_tape_request^.pp_response_p^.ipi_tape_status.major_status_header);

        IF (p_tape_request^.pp_response_p^.pp_response.response_length <=
              ioc$min_ipi_total_resp_size) THEN
          FOR i := 1 to 8 DO
            p_tape_failure_data^.package.ipi_status [i] := 0;
          FOREND;
        ELSE
          status_length := p_tape_request^.pp_response_p^.ipi_tape_status.major_status_header.length + 2;
          FOR i := 1 TO status_length DO
            p_tape_failure_data^.package.ipi_status [i] := p_major_status^ [i];
          FOREND;
        IFEND;

      PROCEND build_log_entry;
?? EJECT ??
    status.normal := TRUE;

    logical_unit := p_tape_request^.request.logical_unit;
    pp := p_tape_request^.pp_response_p^.pp_no;
    iou_number := cmv$logical_pp_table_p^ [pp].pp_info.channel.iou_number;
    pp_interface_table_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;
    channel.number := pp_interface_table_p^.unit_descriptors [logical_unit].
          physical_path.channel_number;
    port_a := 0;
    port_b := 0;
    IF cmv$logical_pp_table_p^ [pp].pp_info.channel_interlock_p^.
          channel_characteristics [channel.number].concurrent_channel THEN
      concurrent := 1;
      IF pp_interface_table_p^.unit_descriptors [logical_unit].physical_path.port = 0 THEN
        port_a := 1;
      ELSE
        port_b := 1;
      IFEND;
    ELSE
      concurrent := 0;
    IFEND;

    found := FALSE;
    offset := 1;
    WHILE (offset <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
      IF (iov$p_statistic_data_p_array^ [offset].logical_unit = logical_unit) THEN
        p_tape_failure_data := iov$p_statistic_data_p_array^ [offset].p_ipi_failure_data;
        found := TRUE;
      ELSE
        offset := offset + 1;
      IFEND;
    WHILEND;

    IF NOT found THEN
      osp$set_status_abnormal ('io', ioc$unrecognized_unit_id,
            'unable to find unit in iop$tape_error_logging_ipi', status);
      RETURN;
    IFEND;

{ Obtain the address of the tape job unit descriptor.

    p_ud := iov$p_statistic_data_p_array^ [offset].p_tape_job_unit_descriptor;

    IF p_tape_failure_data = NIL THEN  { no pending entry

{     Allocate space in the job_pageable_heap for the package that is going to contain
{     the tape_failure_statistic_data.

      ALLOCATE p_tape_failure_data IN osv$job_pageable_heap^;

      build_log_entry;

      IF tape_failure_type = ioc$intermediate THEN
        iov$p_statistic_data_p_array^ [offset].p_ipi_failure_data := p_tape_failure_data;
        RETURN;
      ELSE  {unrecovered, informative or recovered
        iop$issue_ipi_log_entry (p_tape_failure_data, logical_unit, status);
        FREE p_tape_failure_data IN osv$job_pageable_heap^;
        iov$p_statistic_data_p_array^ [offset].p_ipi_failure_data := NIL;
        RETURN;
      IFEND;

    ELSE  { there is a pending error log entry

      IF (tape_failure_type = ioc$unrecovered) OR (tape_failure_type = ioc$informative) THEN
        iop$issue_ipi_log_entry (p_tape_failure_data, logical_unit, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        build_log_entry;
        iop$issue_ipi_log_entry (p_tape_failure_data, logical_unit, status);
        FREE p_tape_failure_data IN osv$job_pageable_heap^;
        iov$p_statistic_data_p_array^ [offset].p_ipi_failure_data := NIL;
        RETURN;

      ELSEIF (tape_failure_type = ioc$intermediate) THEN
        iop$issue_ipi_log_entry (p_tape_failure_data, logical_unit, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        build_log_entry;
        RETURN;

      ELSE  { ioc$recovered
        p_tape_failure_data^.package.failure_severity := 0;

        p_tape_failure_data^.package.recovery_retry_count := p_tape_request^.parity_retry_count +
                                                             p_tape_request^.ipi_retry_count +
                                                             p_tape_request^.misc_retry_count;
        iop$issue_ipi_log_entry (p_tape_failure_data, logical_unit, status);
        FREE p_tape_failure_data IN osv$job_pageable_heap^;
        iov$p_statistic_data_p_array^ [offset].p_ipi_failure_data := NIL;
        RETURN;

      IFEND;

    IFEND;

? ELSE
    status.normal := TRUE;
? IFEND

  PROCEND iop$tape_error_logging_ipi;
?? OLDTITLE ??
?? NEWTITLE := ' iop$issue_ipi_log_entry ' ??
?? EJECT ??
? IF system_version THEN

  PROCEDURE [XDCL, #GATE] iop$issue_ipi_log_entry (
        p_tape_failure_data: ^iot$ipi_tape_failure_data;
        logical_unit: iot$logical_unit;
    VAR status: ost$status);

    VAR
      bytes_last_word: 0 .. 8,
      channel: cmt$physical_channel,
      i: integer,
      iou_number: dst$iou_number,
      number_of_counters : 1 .. ioc$max_failure_counters,
      p_counters: sft$counters,
      p_counters_seq: ^SEQ ( * ),
      path: ost$string,
      pp: 0 .. 0ff(16),
      residual: 0 .. 8,
      statistic_code: sft$statistic_code,
      status_length: 0 .. ioc$ipi_max_status_size,
      text: string (ioc$max_ipi_error_text);

    status.normal := TRUE;

    IF iov$establish_tape_statistics THEN
      iop$establish_tape_statistics (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Use channel, equipment and IOU number from first occurrence of failure.

    IF (p_tape_failure_data^.package.channel_number.concurrent = 0) THEN
      channel.concurrent := FALSE;
    ELSE
      channel.concurrent := TRUE;
    IFEND;
    iou_number := p_tape_failure_data^.package.channel_number.iou;
    channel.number := p_tape_failure_data^.package.channel_number.resource_number;
    IF p_tape_failure_data^.package.channel_number.i4_port_a = 1 THEN
      channel.port := cmc$port_a;
    ELSEIF p_tape_failure_data^.package.channel_number.i4_port_b = 1 THEN
      channel.port := cmc$port_b;
    ELSE
      channel.port := cmc$unspecified_port;
    IFEND;

    cmp$return_descriptor_data (channel, iou_number, p_tape_failure_data^.package.equipment_number,
          logical_unit, path, pp);

    IF path.size > 226 THEN
      path.size := 226;
    IFEND;
    path.size := path.size + 1;

{ Fill out the pp number in tape_failure_statistic_data.

    p_tape_failure_data^.package.pp_number.resource_number := pp;

    IF p_tape_failure_data^.package.failure_severity = 0 THEN  { recovered
      path.value (path.size, * ) := '*RF*';
    ELSEIF p_tape_failure_data^.package.failure_severity = 1 THEN  { unrecovered
      path.value (path.size, * ) := '*UF*';
    ELSEIF p_tape_failure_data^.package.failure_severity = 2 THEN  { intermediate
      path.value (path.size, * ) := '*IF*';
    ELSEIF p_tape_failure_data^.package.failure_severity = 3 THEN  { informative
      path.value (path.size, * ) := '*IM*';
    IFEND;

    path.size := path.size + 4;

    iop$determine_error_text (p_tape_failure_data^.package.failure_symptom_code, text);
    path.value (path.size, *) := text;
    path.size := path.size + ioc$max_ipi_error_text;

    status_length := p_tape_failure_data^.package.ipi_status [2];
    IF status_length = 0 THEN
      number_of_counters := ioc$min_ipi_counters;
    ELSE
      status_length := status_length + 2;
      bytes_last_word := status_length MOD 8;
      IF bytes_last_word = 0 THEN
        number_of_counters := (status_length DIV 8) + ioc$min_ipi_counters - 1;
      ELSE
        number_of_counters := (status_length DIV 8) + ioc$min_ipi_counters;
        residual := 8 - bytes_last_word;
        FOR i := 1 TO residual DO
          p_tape_failure_data^.package.ipi_status [status_length + i] := 0;
        FOREND;
      IFEND;
    IFEND;

    p_counters_seq := ^p_tape_failure_data^.counters;

    RESET p_counters_seq;
    NEXT p_counters: [1 .. number_of_counters] IN p_counters_seq;
    statistic_code := cml$5698_1x_failure_data;

    sfp$emit_statistic (statistic_code, path.value (1, path.size), p_counters, status);

  PROCEND iop$issue_ipi_log_entry;

? IFEND
?? OLDTITLE ??
?? NEWTITLE := ' iop$determine_error_text ' ??
?? EJECT ??
? IF system_version THEN

  PROCEDURE iop$determine_error_text (
        error_id: 0 .. ioc$max_ipi_error_id;
    VAR text: string (ioc$max_ipi_error_text));

    CASE error_id OF

    = ioc$ipi_indeterminate_error =
      text := 'INDETERMINATE';

    = ioc$ipi_function_timeout =
      text := 'FUNCTION TIMEOUT';

    = ioc$chan_empty_when_act =
      text := 'CHANNEL EMPTY WHEN ACTIVATED';

    = ioc$period_counter_error =
      text := 'PERIOD COUNTER ERROR';

    = ioc$upper_ici_parity =
      text := 'UPPER ICI PARITY';

    = ioc$lower_ici_parity =
      text := 'LOWER ICI PARITY';

    = ioc$iou_error =
      text := 'IOU ERROR';

    = ioc$incomplete_i4_transfer =
      text := 'INCOMPLETE I4 TRANSFER';

    = ioc$channel_not_empty =
      text := 'CHANNEL NOT EMPTY';

    = ioc$central_memory_error =
      text := 'CENTRAL MEMORY ERROR';

    = ioc$invalid_cm_resp_code =
      text := 'INVALID CM RESPONSE CODE';

    = ioc$cm_resp_code_parity =
      text := 'CM RESPONSE CODE PARITY ERROR';

    = ioc$cmi_read_data_parity =
      text := 'CMI READ DATA PARITY ERROR';

    = ioc$jy_data_error =
      text := 'JY DATA ERROR';

    = ioc$bas_parity_error =
      text := 'BAS PARITY ERROR';

    = ioc$lz_error =
      text := 'LZ ERROR';

    = ioc$yj_error =
      text := 'JY ERROR';

    = ioc$lx_error =
      text := 'LX ERROR';

    = ioc$dma_test_mode_failure =
      text := 'DMA TEST MODE FAILURE';

    = ioc$illegal_operation =
      text := 'ILLEGAL OPERATION';

    = ioc$can_not_select_controller =
      text := 'CANNOT SELECT CONTROLLER';

    = ioc$bit_sign_response_error =
      text := 'BIT SIGNIFICANT RESPONSE ERROR';

    = ioc$no_sync_in =
      text := 'NO SYNC IN';

    = ioc$sync_in_did_not_drop =
      text := 'SYNC IN DID NOT DROP';

    = ioc$ipi_sequence_error =
      text := 'IPI SEQUENCE ERROR';

    = ioc$upper_ipi_chan_parity =
      text := 'UPPER ICI CHANNEL PARITY';

    = ioc$lower_ipi_chan_parity =
      text := 'LOWER ICI CHANNEL PARITY';

    = ioc$slave_in_not_set =
      text := 'SLAVE IN NOT SET';

    = ioc$slave_in_did_not_drop =
      text := 'SLAVE IN DID NOT DROP';

    = ioc$incomplete_transfer =
      text := 'INCOMPLETE TRANSFER';

    = ioc$channel_stayed_active =
      text := 'CHANNEL STAYED ACTIVE';

    = ioc$buffer_counter_error =
      text := 'BUFFER COUNTER ERROR';

    = ioc$sync_counter_error =
      text := 'SYNC COUNTER ERROR';

    = ioc$lost_data =
      text := 'LOST DATA';

    = ioc$bus_parity =
      text := 'BUS PARITY';

    = ioc$command_reject =
      text := 'COMMAND REJECT';

    = ioc$sync_outs_ne_sync_ins =
      text := 'SYNC OUTS NOT EQUAL SYNC INS';

    = ioc$bus_b_ack_incorrect =
      text := 'BUS B ACKNOWLEDGE INCORRECT';

    = ioc$no_controller_interrupt =
      text := 'NO CONTROLLER INTERRUPT';

    = ioc$ending_status_wrong =
      text := 'ENDING STATUS WRONG';

    = ioc$slave_encoded_end_status =
      text := 'SLAVE ENCODED ENDING STATUS WRONG';

    = ioc$executing_controller_diag =
      text := 'EXECUTING CONTROLLER DIAGNOSTICS';

    = ioc$controller_diag_passed =
      text := 'CONTROLLER DIAGNOSTICS PASSED';

    = ioc$hdw_corrected_errors =
      text := 'ON THE FLY HARDWARE CORRECTIONS';

    = ioc$ipi_controller_failure =
      text := 'CONTROLLER FAILURE';

    = ioc$drive_failure =
      text := 'DRIVE FAILURE';

    = ioc$internal_controller_error =
      text := 'INTERNAL CONTROLLER ERROR';

    = ioc$controller_intervention_req =
      text := 'CONTROLLER INTERVENTION REQUIRED';

    = ioc$controller_mach_excep =
      text := 'CONTROLLER MACHINE EXCEPTION';

    = ioc$command_exception =
      text := 'COMMAND EXCEPTION';

    = ioc$microcode_execution_error =
      text := 'MICROCODE EXECUTION ERROR';

    = ioc$alternate_port_exception =
      text := 'ALTERNATE PORT EXCEPTION';

    = ioc$unexpected_response =
      text := 'UNEXPECTED RESPONSE';

    = ioc$drive_reserved =
      text := 'DRIVE RESERVED TO OTHER CONTROLLER PORT';

    = ioc$no_block_id_returned =
      text := 'NO BLOCK ID PARAMETER RETURNED';

    = ioc$unexpected_class_2 =
      text := 'UNEXPECTED CLASS 2 INTERRUPT';

    = ioc$drive_not_operational =
      text := 'DRIVE NOT OPERATIONAL';

    = ioc$drive_not_ready =
      text := 'DRIVE NOT READY';

    = ioc$drive_intervention_req =
      text := 'DRIVE INTERVENTION REQUIRED';

    = ioc$physical_interface_check =
      text := 'PHYSICAL INTERFACE CHECK';

    = ioc$operation_timeout =
      text := 'OPERATION TIMEOUT';

    = ioc$drive_machine_exception =
      text := 'DRIVE MACHINE EXCEPTION';

    = ioc$fatal_error =
      text := 'FATAL ERROR';

    = ioc$drive_conditional_success =
      text := 'DRIVE CONDITIONAL SUCCESS';

    = ioc$position_lost =
      text := 'POSITION LOST';

    = ioc$drive_res_to_other_cont =
      text := 'DRIVE RESERVED TO OTHER CONTROLLER';

    = ioc$no_end_of_extent =
      text := 'NO END OF EXTENT DETECTED';

    = ioc$data_length_difference =
      text := 'DATA LENGTH DIFFERENCE';

    = ioc$ipi_tape_medium_failure =
      text := 'TAPE MEDIUM FAILURE';

    = ioc$ipi_id_burst_error =
      text := 'UNABLE TO WRITE ID BURST';

    = ioc$ipi_unable_to_set_agc =
      text := 'UNABLE TO SET AGC';

    = ioc$master_slave_data_integrity =
      text := 'MASTER-SLAVE DATA INTEGRITY';

    = ioc$slave_fac_data_integrity =
      text := 'SLAVE-FACILITY DATA INTEGRITY';

    = ioc$pp_detect_software_failure,
      ioc$illegal_abnormal_status,
      ioc$interface_error_wo_eid,
      ioc$invalid_response_type,
      ioc$no_alert_cond_set,
      ioc$no_bits_in_abnormal_status =
      text := 'SOFTWARE FAILURE';


    ELSE

      text := 'UNKNOWN ERROR ID';

    CASEND;

  PROCEND iop$determine_error_text;

? IFEND
?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_initialize_unit ' ??
?? EJECT ??

  PROCEDURE [XDCL] iop$tape_initialize_unit (system_file_id: dmt$system_file_id;
    VAR io_id: iot$io_id;
    VAR status: ost$status);

    CONST
      disable_unit = FALSE,
      physical_unload = FALSE,
      repeat_count = 1;

    VAR
      logical_unit_number: iot$logical_unit;

    status.normal := TRUE;

    convert_sfid_to_lun (system_file_id, logical_unit_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    iop$67x_non_data_trans_setup (logical_unit_number, ioc$tape_get_status,
          repeat_count, disable_unit, physical_unload, io_id, status);

  PROCEND iop$tape_initialize_unit;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_initialize_unit_scan ' ??
?? EJECT ??
? IF system_version THEN
  PROCEDURE [XDCL, #GATE] iop$tape_initialize_unit_scan (logical_unit_number: iot$logical_unit;
    VAR io_id: iot$io_id;
    VAR status: ost$status);

    CONST
      disable_unit = FALSE,
      physical_unload = FALSE,
      repeat_count = 1;

    status.normal := TRUE;

    iop$67x_non_data_trans_setup (logical_unit_number, ioc$tape_get_status,
          repeat_count, disable_unit, physical_unload, io_id, status);

  PROCEND iop$tape_initialize_unit_scan;
? IFEND

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_internal_request_stat ' ??
?? EJECT ??

? IF NOT system_version THEN
  PROCEDURE [XDCL] iop$tape_internal_request_stat (logical_unit: iot$logical_unit;
        io_id: iot$io_id;
        buf_release: boolean;
        bid_recovery: boolean;
        bid_update: boolean;
        wait: ost$wait;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);
? ELSE
  PROCEDURE [XDCL, #GATE] iop$tape_internal_request_stat (logical_unit: iot$logical_unit;
        io_id: iot$io_id;
        buf_release: boolean;
        bid_recovery: boolean;
        bid_update: boolean;
        wait: ost$wait;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);


  PROCEDURE internal_stat_cond_handler (
        condition: pmt$condition;
        p_condition_info: ^pmt$condition_information;
        p_stack: ^ost$stack_frame_save_area;
    VAR condition_status: ost$status);

    CASE condition.selector OF

    = pmc$block_exit_processing =

      IF NOT iov$tape_completion_q_table^ [j].req [k].check_task_id THEN
        iop$tape_enable_taskid_check (j, k);
      IFEND;

      p_ud^.task_terminated_during_recovery := TRUE;
      p_ud^.pending_pageable_requests [1] := NIL;
      p_ud^.tape_error_log_entry := FALSE;

    = pmc$user_defined_condition =
      IF condition.user_condition_name = osc$job_recovery_condition_name THEN
        job_recovery := TRUE;
        #SPOIL (job_recovery);
      IFEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);

    ELSE
      pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
    CASEND;

  PROCEND internal_stat_cond_handler;
? IFEND

    VAR
      current_heap: ^ost$heap,
      found: boolean,
      i: iot$no_of_tape_units,
      io_request_p: ^iot$io_request,
      j: iot$no_of_tape_units,
      job_recovery: boolean,
      k: 1 .. ioc$max_multiple_tape_requests,
      p_tape_request: ^iot$tape_request,
      p_ud: ^iot$tape_job_unit_descriptor,
      ready_task_triggered: boolean;

    BEGIN

      status.normal := TRUE;
      io_status.io_complete := FALSE;
      ready_task_triggered := FALSE;
      job_recovery := FALSE;
      iop$set_current_heap (current_heap);

      #INLINE ('keypoint', osk$entry, osk$m * io_id, ioc$tape_entry_iomtirs);

{Find the Unit_index to the completion_q_table.

      i := 1;
      found := FALSE;
      WHILE (i <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
        IF logical_unit = iov$p_statistic_data_p_array^ [i].logical_unit THEN
          found := TRUE;
        ELSE
          i := i + 1;
        IFEND;
      WHILEND;

      IF NOT found THEN
        osp$set_status_abnormal ('io', ioc$os_failure,
              'unable to find unit in iop$internal_request_stat', status);
        RETURN;
      IFEND;

      p_ud := iov$p_statistic_data_p_array^ [i].p_tape_job_unit_descriptor;
      j := p_ud^.completion_q_index;
      #SPOIL (j, p_ud);

{Find the io_id for the correct completion_packet index and test for a waiting response.

      k := 1;
      WHILE k <= ioc$max_multiple_tape_requests DO
        #SPOIL (k);
        IF iov$tape_completion_q_table^ [j].req [k].io_id = io_id THEN

          WHILE TRUE DO
            IF iov$tape_completion_q_table^ [j].req [k].waiting_response THEN
              IF ready_task_triggered THEN
                osp$disestablish_cond_handler;
              IFEND;
              iop$tape_return_wired_request (j, k, p_tape_request, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              iop$tape_status_check (bid_recovery, bid_update, p_tape_request, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              io_status := p_tape_request^.io_status;

              IF buf_release THEN

{ Update the usage counters in the tape job unit descriptor.

                iop$tape_terminate_io (p_tape_request, bid_recovery, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                io_status.residual_block_count := p_tape_request^.io_status.residual_block_count;

                IF NOT p_tape_request^.must_free_pageable_request THEN
                  p_ud^.pageable_tape_requests [p_tape_request^.pageable_tape_request_index].
                        slot_in_use := FALSE;
                ELSE

{ Must Free the pageable tape request since the pageable_request_table in the unit
{ descriptor was full when the request was queued.  This can only happen if error
{ recovery is performed on an error recovery request (i.e. recursive error recovery).

                  FREE p_tape_request^.pp_response_p IN current_heap^;
                  FREE p_tape_request IN current_heap^;
                IFEND;
              IFEND;
              io_status.io_complete := TRUE;

              RETURN; {<---------

            ELSE {request not complete yet

? IF system_version THEN

              IF NOT ready_task_triggered THEN
                osp$establish_condition_handler (^internal_stat_cond_handler, TRUE);
                iop$tape_enable_ready_task (j, k);
                ready_task_triggered := TRUE;
              ELSE { If second or subsequent time thru loop, check task_id on completion
                IF NOT iov$tape_completion_q_table^ [j].req [k].check_task_id THEN
                  iop$tape_enable_taskid_check (j, k);
                IFEND;
              IFEND;

              IF NOT iov$tape_completion_q_table^ [j].req [k].waiting_response THEN
                IF wait = osc$nowait THEN
                  RETURN;
                IFEND;

                pmp$wait (20000, 750);

                IF job_recovery THEN
                  osp$disestablish_cond_handler;
                  osp$set_status_abnormal ('IO', ioe$tape_job_recovery, ' ', status);
                  RETURN;
                IFEND;
              IFEND;

? ELSE {For boot environment, to not use ready task mechanism

              pmp$delay (100, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
? IFEND
            IFEND;
          WHILEND;
        IFEND;
        k := k + 1;
      WHILEND;

{ Report system failure to job if an io_id cannot be found.  Each request will have the assigned
{ io_id placed in a tape_completion_q_packet entry at time request is posted.

      osp$set_status_abnormal ('io', ioc$os_failure,
            'unable to find io_id in iop$internal_request_stat', status);

      #INLINE ('keypoint', osk$exit, osk$m * ORD (io_status.completion_code), ioc$tape_exit_iomtirs);
    END
  PROCEND iop$tape_internal_request_stat;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_pp_error ' ??
?? EJECT ??

  PROCEDURE iop$tape_pp_error (p_tape_request: ^iot$tape_request;
    VAR status: ost$status);

    status.normal := TRUE;

    #INLINE ('keypoint', osk$entry, 0,
          ioc$tape_entry_ioptppe);

    p_tape_request^.io_status.io_complete := TRUE;
    p_tape_request^.io_status.normal_completion := FALSE;
    p_tape_request^.io_status.completion_code := ioc$system_software_failure;
    p_tape_request^.io_status.position_uncertain := TRUE;

  PROCEND iop$tape_pp_error;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_reposition_b ' ??
?? EJECT ??

  PROCEDURE iop$tape_reposition_b (p_tape_request: ^iot$tape_request;
    VAR status: ost$status);

    CONST
      block_count = 1,
      buf_release = TRUE,
      disable_unit = FALSE,
      physical_unload = FALSE;

    VAR
      bid_offset: iot$bid_index,
      bid_realign_buf: iot$bid_window,
      bid_realign_buf_index: 1 .. ioc$bid_window_length + 1,
      bid_realign_buf_index_plus: 4 .. ioc$bid_window_length,
      bid_recovery: boolean,
      bid_update: boolean,
      bksp_adjust: 0 .. 3,
      bksp_count: 0 .. ioc$bid_window_length,
      bksp_reposition: 0 .. 3,
      count: 0 .. ioc$bid_window_length,
      historical_bid_window: iot$bid_window,
      historical_bid_index: iot$bid_index,
      io_id: iot$io_id,
      io_status: iot$tape_io_status,
      logical_unit_no: iot$logical_unit,
      retry_loop: boolean,
      temp_bid_index: iot$bid_index,
      temp_bid_index_historical: iot$bid_index,
      ud_p: ^iot$tape_job_unit_descriptor,
      unique: boolean,
      unrecoverable_retry: boolean;

    BEGIN

      status.normal := TRUE;

{     Obtain pointer to iot$tape_job_unit_descriptor.
{     Read the current block_id_window and block_id_index for the assigned tape unit.

      logical_unit_no := p_tape_request^.request.logical_unit;
      ud_p := p_tape_request^.ud;
      historical_bid_window := ud_p^.bid_window;
      historical_bid_index := ud_p^.bid_index;
      unique := FALSE;
      bid_realign_buf_index := LOWERVALUE(iot$bid_index);

{ Realign block_id's from the last good BID to the oldest BID in the window.
{ Remember, the index into the bid_window points to the last good block (last entry) plus 1.
{ This realignment simplifies investigation for uniqueness in BID window.

      IF historical_bid_index <> LOWERVALUE(historical_bid_index) THEN
        FOR bid_offset := (historical_bid_index - 1) DOWNTO LOWERVALUE(iot$bid_index) DO
          bid_realign_buf [bid_realign_buf_index] := historical_bid_window [bid_offset];
          bid_realign_buf_index := bid_realign_buf_index + 1;
        FOREND;
      IFEND;

      FOR bid_offset := UPPERVALUE(iot$bid_index) DOWNTO (historical_bid_index) DO
        bid_realign_buf [bid_realign_buf_index] := historical_bid_window [bid_offset];
        bid_realign_buf_index := bid_realign_buf_index + 1;
      FOREND;

    /bksp_calculation/
      BEGIN
? IF system_version THEN
        IF ud_p^.max_block_length < bav$max_bytes_per_tape_io THEN
? IFEND
          FOR bid_realign_buf_index := LOWERVALUE(iot$bid_index) to UPPERVALUE(iot$bid_index) DO
            IF (bid_realign_buf [bid_realign_buf_index] = ioc$loadpoint_bid) THEN
              bid_recovery := true;
              bid_update := true;
              iop$67x_non_data_trans_setup (logical_unit_no, ioc$tape_rewind, block_count,
                     disable_unit, physical_unload, io_id, status);
              IF NOT status.normal THEN
                RETURN;
              ELSE
                iop$tape_internal_request_stat (logical_unit_no, io_id, buf_release, bid_recovery,
                      bid_update, osc$wait, io_status, status);
                p_tape_request^.io_status := io_status;
                IF NOT p_tape_request^.io_status.normal_completion THEN
                  RETURN;
                IFEND;
              IFEND;
              IF  bid_realign_buf_index = 1 THEN;
                RETURN;
              IFEND;
              count := bid_realign_buf_index - 1;
              REPEAT
              IF bid_realign_buf [count] = ioc$error_block_bid THEN
                 bid_update := FALSE
              IFEND;
              count := count - 1;
              iop$67x_non_data_trans_setup (logical_unit_no, ioc$tape_forspace, block_count,
                     disable_unit, physical_unload, io_id, status);
              IF status.normal THEN
                iop$tape_internal_request_stat (logical_unit_no, io_id, buf_release, bid_recovery,
                      bid_update, osc$wait, io_status, status);
                bid_update := TRUE;
                p_tape_request^.io_status := io_status;
                IF NOT (p_tape_request^.io_status.normal_completion) AND NOT (p_tape_request^.io_status.
                      completion_code = ioc$tapemark_read) THEN
                  RETURN;
                IFEND;
              ELSE
                RETURN;
              IFEND;
            UNTIL count = 0;
            IF historical_bid_index <> ud_p^.bid_index THEN
              p_tape_request^.io_status.normal_completion := FALSE;
              p_tape_request^.io_status.position_uncertain := TRUE;
              p_tape_request^.io_status.completion_code := ioc$indeterminate;
            ELSE
              FOR bid_offset := LOWERBOUND(historical_bid_window) TO historical_bid_index - 1 DO
                IF (historical_bid_window [bid_offset] <> ud_p^.bid_window [bid_offset]) AND
                   NOT (historical_bid_window [bid_offset] = ioc$error_block_bid) THEN
                  p_tape_request^.io_status.normal_completion := FALSE;
                  p_tape_request^.io_status.position_uncertain := TRUE;
                  p_tape_request^.io_status.completion_code := ioc$indeterminate;
                  RETURN;
                IFEND;
              FOREND;
            IFEND;
            RETURN;
           IFEND;
          FOREND;
? IF system_version THEN
        IFEND;
? IFEND

        FOR bid_realign_buf_index := 1 TO ioc$min_bksp_count - 1 DO
          IF (bid_realign_buf [bid_realign_buf_index] = ioc$tapemark_bid) THEN
            bksp_count := bid_realign_buf_index;
            unique := TRUE;
            EXIT /bksp_calculation/
          IFEND;
        FOREND;

        FOR bid_realign_buf_index := 1 TO ioc$min_bksp_count - 1 DO
          IF (bid_realign_buf [bid_realign_buf_index] = ioc$unavail_bid) THEN
            EXIT /bksp_calculation/
          IFEND;
        FOREND;

        bksp_count := ioc$min_bksp_count - 1;

        FOR bid_realign_buf_index := ioc$min_bksp_count  TO ioc$bid_window_length DO
          bid_realign_buf_index_plus := bid_realign_buf_index + 1;
          bksp_count := bksp_count + 1;
          IF (bid_realign_buf [bid_realign_buf_index_plus] = ioc$unavail_bid) THEN
            EXIT /bksp_calculation/
          ELSEIF bid_realign_buf [bid_realign_buf_index] <> bid_realign_buf [bid_realign_buf_index_plus] THEN
            unique := TRUE;
            EXIT /bksp_calculation/
          IFEND;
        FOREND;

      END /bksp_calculation/;

      IF NOT unique THEN
        bksp_count := 1;
      IFEND;

      bid_recovery := TRUE;
      bid_update := FALSE;

{ Backspace over bad record.

      iop$67x_non_data_trans_setup (logical_unit_no, ioc$tape_backspace, block_count,
               disable_unit, physical_unload, io_id, status);
      IF status.normal THEN
        iop$tape_internal_request_stat (logical_unit_no, io_id, buf_release, bid_recovery, bid_update,
             osc$wait, io_status, status);
        p_tape_request^.io_status := io_status;
        IF NOT (p_tape_request^.io_status.normal_completion) AND NOT (p_tape_request^.io_status.
              completion_code = ioc$tapemark_read) THEN
          RETURN;
        IFEND;
      ELSE
        RETURN;
      IFEND;

      count := bksp_count;
      bid_update := TRUE;
      retry_loop := TRUE;
      unrecoverable_retry := TRUE;

{ Start of reposition to Last Good Block (Backspace/Forspace the uniquely determined count).

    /unrecoverable_retry_loop/
      WHILE retry_loop DO

        REPEAT
          count := count - 1;
          iop$67x_non_data_trans_setup (logical_unit_no, ioc$tape_backspace, block_count,
                 disable_unit, physical_unload, io_id, status);
          IF status.normal THEN
            iop$tape_internal_request_stat (logical_unit_no, io_id, buf_release, bid_recovery,
                  bid_update, osc$wait, io_status, status);
            p_tape_request^.io_status := io_status;
            IF NOT (p_tape_request^.io_status.normal_completion) AND NOT (p_tape_request^.io_status.
                  completion_code = ioc$tapemark_read) THEN
              RETURN;
            IFEND;
          ELSE
            RETURN;
          IFEND;
        UNTIL count = 0;

        bksp_reposition := 0;
        count := bksp_count;
        REPEAT
          IF bid_realign_buf [count] = ioc$error_block_bid THEN
            bid_update := FALSE;
          IFEND;
          count := count - 1;
          iop$67x_non_data_trans_setup (logical_unit_no, ioc$tape_forspace, block_count,
                 disable_unit, physical_unload, io_id, status);
          IF status.normal THEN
            iop$tape_internal_request_stat (logical_unit_no, io_id, buf_release, bid_recovery,
                  bid_update, osc$wait, io_status, status);
            bid_update := TRUE;
            p_tape_request^.io_status := io_status;
            IF NOT (p_tape_request^.io_status.normal_completion) AND NOT (p_tape_request^.io_status.
                  completion_code = ioc$tapemark_read) THEN
              RETURN;
            IFEND;
          ELSE
            RETURN;
          IFEND;

{ Investigate if this is the 1st forspace in the repositioning attempt.  It is assumed the 1st
{ forspace will be over good data and we will not run into a fragmented record. The variable
{ bksp_reposition will be non-zero if we already tried repositioning on the very 1st forspace.

        IF ((count = bksp_count - 1) AND (bksp_reposition = 0)) THEN

{ Set bid_offset index to point to the block_id that was just obtained with the forspace which is
{ the present window index - 1.  Also adjust for the circular aspects of the bid_window and index.

          IF (ud_p^.bid_index = 1) THEN
            bid_offset := ioc$bid_window_length;
          ELSE
            bid_offset := ud_p^.bid_index - 1;
          IFEND;

{ The block_id's of the current and historical window should be the same at this index.

          IF (ud_p^.bid_window [bid_offset] <> historical_bid_window [bid_offset]) THEN

{ Investigate where the current_window block_id is in the historical_window.
{ If the current bid is found at index + 1 in historical, this means we backspaced one record
{ less than physically expected.
{ Must assure that we observe the circular window limits for looking at the historical window.

            IF (bid_offset = ioc$bid_window_length) THEN
              temp_bid_index := 1;
            ELSE
              temp_bid_index := bid_offset + 1;
            IFEND;
            bksp_adjust := 0;

{ Check for tape having 1 less backspace than expected.

            IF (ud_p^.bid_window [bid_offset] = historical_bid_window [temp_bid_index]) THEN
              bksp_adjust := 2;
              count := bksp_count;
            IFEND;

{ Look ahead 2 records.

            IF (temp_bid_index = ioc$bid_window_length) THEN
              temp_bid_index := 1;
            ELSE
              temp_bid_index := temp_bid_index + 1;
            IFEND;

{ Check for tape having 2 less backspaces than expected.

            IF (ud_p^.bid_window [bid_offset] = historical_bid_window [temp_bid_index]) THEN
              bksp_adjust := 3;
              count := bksp_count;
            IFEND;

{ Issue the determined number of backspaces if bksp_adjust is non-zero.

            FOR bksp_reposition := 1 to bksp_adjust DO
              iop$67x_non_data_trans_setup (logical_unit_no, ioc$tape_backspace, block_count,
                     disable_unit, physical_unload, io_id, status);
              IF status.normal THEN
                iop$tape_internal_request_stat (logical_unit_no, io_id, buf_release, bid_recovery,
                      bid_update, osc$wait, io_status, status);
                bid_update := FALSE;
                p_tape_request^.io_status := io_status;
                IF NOT (p_tape_request^.io_status.normal_completion) AND NOT (p_tape_request^.io_status.
                      completion_code = ioc$tapemark_read) THEN
                  RETURN;
                IFEND;
              ELSE
                RETURN;
              IFEND;
            FOREND;

{ The index in the current window should now be correct and equal the historical bid window index and
{ updating of the block_id index and window must be initiated again.

            bid_update := TRUE;
          IFEND;
        IFEND;
        UNTIL count = 0;

{ Verify that Current and Historical bid_indexes into the bid_windows are equal.

        IF historical_bid_index <> ud_p^.bid_index THEN
          p_tape_request^.io_status.normal_completion := FALSE;
          p_tape_request^.io_status.position_uncertain := TRUE;
          p_tape_request^.io_status.completion_code := ioc$indeterminate;
        ELSE

{ Verify that the elemets/bid's in the Current/Historical Block_id Windows are equal.

        /bid_verify/
          FOR bid_offset := LOWERBOUND(historical_bid_window) TO UPPERBOUND(historical_bid_window) DO
            IF (historical_bid_window [bid_offset] <> ud_p^.bid_window [bid_offset]) AND
               NOT (historical_bid_window [bid_offset] = ioc$error_block_bid) THEN

{ Investigate if current bid_window may be mispositioned due to the hardware not backspacing correctly.
{ We are talking here about the tape having backspaced 1 more record than was physically expected.
{ This mispositioning could also occur if the block in error is not recognized as a legitimate block
{ when attempting to backspace over that bad block.  We are at an unrecoverable position at this
{ point in time, and we may be able to recognize a physical positioning error and correct the situation.

              IF unrecoverable_retry THEN
                count := bksp_count;
                unrecoverable_retry := FALSE;

{ Note that the current and historical bid indexes are identical or we would not try repositioning.
{ If the current window shows the tape position as off 1 block, then tape is moved to correct
{ current window and the original index to the current window is restored.

{ A BID Index always points to next entry in BID Window.
{ Set temp_bid_index to point to actual Last_Good_Block (LGB) in current window (current index - 1).
{ Must allow for wrap_around of circular bid window/index that increments circular from 1 to 32 decimal.

                IF historical_bid_index = LOWERVALUE(iot$bid_index) THEN
                  temp_bid_index := UPPERVALUE(iot$bid_index);
                ELSE
                  temp_bid_index := historical_bid_index  - 1;
                IFEND;

{ Set temp_bid_index_historical as the index used to look at BID entries in the Historical Window.
{ Look at  LGB minus one in the Historical Window.

                IF temp_bid_index = LOWERVALUE(iot$bid_index) THEN
                  temp_bid_index_historical := UPPERVALUE(iot$bid_index);
                ELSE
                  temp_bid_index_historical := temp_bid_index - 1;
                IFEND;

{ Investigate if LGB in Current Window = LGB - 1 in Historical Window.
{ If BID's are identical, forspace tape 1 block, restore current index, and loop to reposition algorithm.

                IF ud_p^.bid_window [temp_bid_index] = historical_bid_window [temp_bid_index_historical] THEN
                  IF historical_bid_window [temp_bid_index] = ioc$error_block_bid THEN
                    bid_update := FALSE;
                  IFEND;

{ Must decrement index into current window so we don't destroy oldest BID in current window with the forspace
{  that is issued to correct 1 block mispositioning by the hardware.

                  ud_p^.bid_index := temp_bid_index;
                  iop$67x_non_data_trans_setup (logical_unit_no, ioc$tape_forspace, block_count,
                         disable_unit, physical_unload, io_id, status);
                  IF status.normal THEN
                    iop$tape_internal_request_stat (logical_unit_no, io_id, buf_release, bid_recovery,
                          bid_update, osc$wait, io_status, status);
                    bid_update := TRUE;
                    p_tape_request^.io_status := io_status;
                    IF NOT p_tape_request^.io_status.normal_completion AND NOT (p_tape_request^.io_status.
                          completion_code = ioc$tapemark_read) THEN
                      RETURN;
                    IFEND;
                  ELSE
                    RETURN;
                  IFEND;

                  ud_p^.bid_index := historical_bid_index;
                  CYCLE /unrecoverable_retry_loop/;
                IFEND;
              IFEND;
              p_tape_request^.io_status.normal_completion := FALSE;
              p_tape_request^.io_status.position_uncertain := TRUE;
              p_tape_request^.io_status.completion_code := ioc$indeterminate;
              EXIT /bid_verify/
            IFEND;
          FOREND /bid_verify/;
        IFEND;

        retry_loop := FALSE;
      WHILEND /unrecoverable_retry_loop/;

      #INLINE ('keypoint', osk$exit, 0,
            ioc$tape_exit_ioptrpb);

    END
  PROCEND iop$tape_reposition_b;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_reposition_f ' ??
?? EJECT ??

  PROCEDURE iop$tape_reposition_f (VAR p_tape_request: ^iot$tape_request;
    VAR status: ost$status);

    CONST
      bid_recovery = FALSE,
      bid_update = TRUE,
      block_count = 1,
      buf_release = TRUE,
      disable_unit = FALSE,
      physical_unload = FALSE;

    VAR
      io_id: iot$io_id,
      io_status: iot$tape_io_status,
      logical_unit_no: iot$logical_unit;

    status.normal := TRUE;
    logical_unit_no := p_tape_request^.request.logical_unit;
    iop$67x_non_data_trans_setup (logical_unit_no, ioc$tape_forspace, block_count,
           disable_unit, physical_unload, io_id, status);
    IF status.normal THEN
      iop$tape_internal_request_stat (logical_unit_no, io_id, buf_release, bid_recovery, bid_update,
            osc$wait, io_status, status);
      p_tape_request^.io_status := io_status;
    IFEND;
    #INLINE ('keypoint', osk$exit, 0, ioc$tape_exit_ioptrpf);

  PROCEND iop$tape_reposition_f;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_request_status ' ??
?? EJECT ??

  PROCEDURE [XDCL] iop$tape_request_status (file_id: dmt$system_file_id;
        io_id: iot$io_id;
        wait_for_completion: boolean;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);


? IF system_version THEN
  PROCEDURE request_status_cond_handler (
        condition: pmt$condition;
        p_condition_info: ^pmt$condition_information;
        p_stack: ^ost$stack_frame_save_area;
    VAR condition_status: ost$status);

    CASE condition.selector OF

    = pmc$block_exit_processing =

      IF NOT iov$tape_completion_q_table^ [j].req [k].check_task_id THEN
        iop$tape_enable_taskid_check (j, k);
      IFEND;

    = pmc$user_defined_condition =
      IF condition.user_condition_name = osc$job_recovery_condition_name THEN
        job_recovery := TRUE;
        #SPOIL (job_recovery);
      IFEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);

    ELSE
      pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
    CASEND;

  PROCEND request_status_cond_handler;
? IFEND

    CONST
      bid_recovery = FALSE,
      bid_update = TRUE;

    VAR
      found: boolean,
      h: 1 .. ioc$max_multiple_tape_requests,
      i: iot$no_of_tape_units,
      io_request_p: ^iot$io_request,
      j: iot$no_of_tape_units,
      job_recovery: boolean,
      k: 1 .. ioc$max_multiple_tape_requests,
      local_status: ost$status,
      logical_unit: iot$logical_unit,
      p_tape_request: ^iot$tape_request,
      p_ud: ^iot$tape_job_unit_descriptor,
      q: 1 .. ioc$max_multiple_tape_requests,
      ready_task_triggered: boolean,
      store_unit_ready_attempt: integer,
      tusl_entry_access: iot$tusl_entry_access,
      unload_request: boolean,
      update_tusl_entry: boolean;

    BEGIN
      status.normal := TRUE;
      io_status.io_complete := FALSE;
      ready_task_triggered := FALSE;
      job_recovery := FALSE;

      #INLINE ('keypoint', osk$entry, osk$m * io_id, ioc$tape_entry_ioptrqs);

{     Get unit number using file name.

      convert_sfid_to_lun (file_id, logical_unit, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{Find the Unit_index to the completion_q_table.

      i := 1;
      found := FALSE;
      WHILE (i <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
        IF logical_unit = iov$p_statistic_data_p_array^ [i]. logical_unit THEN
          found := TRUE;
        ELSE
          i := i + 1;
        IFEND;
      WHILEND;

      IF NOT found THEN
        osp$set_status_abnormal ('io', ioc$os_failure,
              'unable to find unit in iop$tape_request_status', status);
        RETURN;
      IFEND;

      p_ud := iov$p_statistic_data_p_array^ [i].p_tape_job_unit_descriptor;
      j := p_ud^.completion_q_index; {This index is also the correct index into the tusl structure.
      #SPOIL (j);

{ Find the io_id for the correct completion_packet index and test for a waiting response.

      FOR k := 1 TO ioc$max_multiple_tape_requests DO
        IF iov$tape_completion_q_table^ [j].req [k].io_id = io_id THEN

          WHILE TRUE DO
            IF iov$tape_completion_q_table^ [j].req [k].waiting_response THEN
              IF ready_task_triggered THEN
                osp$disestablish_cond_handler;
              IFEND;
              IF iov$tape_completion_q_table^ [j].req [k].request_not_processed THEN
                 io_status.completion_code := ioc$request_not_processed;
                 io_status.normal_completion := FALSE;
                 iop$tape_request_not_processed(0, j, k, status);
                 io_status.io_complete := TRUE;
                 RETURN; {<---------
              IFEND;
              iop$tape_return_wired_request (j, k, p_tape_request, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              iop$tape_status_check (bid_recovery, bid_update, p_tape_request, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

{ Investigate if any pending_requests to be queued.

              IF p_ud^.pending_pageable_requests [1] <> NIL THEN

{ Check if Fatal Error or 'EOT on write'.
{ Note: When EOT is encountered on a write, normal_completion is set to TRUE.  The
{ block_manager uses the io_status.end_of_tape flag to determine when EOT occurred.
{ Also note that multiple requests are only on Writes and Reads at this time.

                IF p_tape_request^.io_status.normal_completion = FALSE OR
                   ((p_tape_request^.io_status.end_of_tape) AND
                    (p_tape_request^.request_type = ioc$tape_write)) THEN

{Return pending pageable requests.
                /loop_1/
                  FOR h := 1 TO ioc$max_multiple_tape_requests DO
                    IF p_ud^.pending_pageable_requests [h] = NIL THEN
                      EXIT /loop_1/
                    IFEND;
                  /loop_2/
                    FOR q := 1 TO ioc$max_multiple_tape_requests DO
                      IF iov$tape_completion_q_table^ [j].req [q].io_id = 0 THEN
                        iop$tape_request_not_processed(p_ud^.pending_pageable_requests [h]^.io_id,j,q,status);
                        EXIT /loop_2/
                      IFEND;
                    FOREND /loop_2/;
                    IF NOT p_ud^.pending_pageable_requests [h]^.must_free_pageable_request THEN
                      p_ud^.pageable_tape_requests [p_ud^.pending_pageable_requests [h]^.
                            pageable_tape_request_index].slot_in_use := FALSE;
                    ELSE  { this should never occur for user initiated requests
                      osp$system_error ('Internal error 1 - iop$tape_request_status', ^status);
                    IFEND;
                    p_ud^.pending_pageable_requests [h] := NIL;
                  FOREND /loop_1/;
                ELSE

{Recovered error - requeue pending_pageable_requests.

                /loop_3/
                  FOR h := 1 TO ioc$max_multiple_tape_requests DO
                    IF p_ud^.pending_pageable_requests [h] = NIL THEN
                      EXIT /loop_3/
                    IFEND;

{ If requeueing more than 1 request, allow the second and subsequent requests
{ to be queued even if unit is disabled.

                    IF h > 1 THEN
                      p_ud^.pending_pageable_requests [h]^.recovery_requeue := TRUE;
                    IFEND;

                    iop$tape_queue_request_setup (p_ud^.pending_pageable_requests [h], status);
                    p_ud^.pending_pageable_requests [h]^.recovery_requeue := FALSE;
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;
                    p_ud^.pending_pageable_requests [h] := NIL;
                  FOREND /loop_3/;
                IFEND;
              IFEND;

{ Update the usage counters in the tape job unit descriptor.
{ If the request is an unload, the io_status from the pageable request must
{ be saved first since the pageable request is FREE'ed in iop$tape_terminate_io.

              unload_request := FALSE;
              IF p_tape_request^.request_type = ioc$tape_unload THEN
                io_status := p_tape_request^.io_status;
                unload_request := TRUE;
              IFEND;

              iop$tape_terminate_io (p_tape_request, bid_recovery, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              IF NOT unload_request THEN
                io_status := p_tape_request^.io_status;
                IF NOT p_tape_request^.must_free_pageable_request THEN
                  p_ud^.pageable_tape_requests [p_tape_request^.pageable_tape_request_index].
                        slot_in_use := FALSE;
                ELSE  { this should never occur for user initiated requests
                  osp$system_error ('Internal error 2 - iop$tape_request_status', ^status);
                IFEND;
              IFEND;

              io_status.io_complete := TRUE;

? IF system_version THEN
{ Update the tusl entry for correct ready status on an assigned unit.
{ This update, of course, requires the functioning of the tape unit by the user.

              tusl_entry_access.operation := ioc$store_unit_ready;
              update_tusl_entry := FALSE;
              IF unload_request OR
                    ((NOT io_status.normal_completion) AND (io_status.completion_code <> ioc$tapemark_read)
                    AND (NOT io_status.long_input_block)) THEN
                IF unload_request THEN
                  tusl_entry_access.store_unit_ready := FALSE;
                ELSE
                  tusl_entry_access.store_unit_ready := io_status.unit_ready;
                IFEND;
                update_tusl_entry := TRUE;
              ELSEIF NOT iov$tusl_p^[j].unit_ready THEN
                tusl_entry_access.store_unit_ready := io_status.unit_ready;
                update_tusl_entry := TRUE;
              IFEND;

              IF update_tusl_entry AND (tusl_entry_access.store_unit_ready <> iov$tusl_p^[j].unit_ready) THEN
              /store_unit_ready_in_tusl/
                FOR store_unit_ready_attempt := 1 TO max_store_unit_ready_attempts DO
                  iop$access_tusl_entry (j, tusl_entry_access, local_status);
                  IF NOT local_status.normal AND (local_status.condition = dme$unable_to_lock_tape_table) THEN
                    pmp$wait (one_second, one_second);
                    CYCLE /store_unit_ready_in_tusl/;
                  ELSE
                    EXIT /store_unit_ready_in_tusl/;
                  IFEND;
                FOREND /store_unit_ready_in_tusl/;
              IFEND;
? IFEND
              RETURN; {<---------

            ELSE {request not complete yet

              IF NOT wait_for_completion THEN
                RETURN; {<---------
              ELSE

? IF system_version THEN

                IF NOT ready_task_triggered THEN
                  osp$establish_condition_handler (^request_status_cond_handler, TRUE);
                  iop$tape_enable_ready_task (j, k);
                  ready_task_triggered := TRUE;
                ELSE { If second or subsequent time thru loop, check task_id on completion
                  IF NOT iov$tape_completion_q_table^ [j].req [k].check_task_id THEN
                    iop$tape_enable_taskid_check (j, k);
                  IFEND;
                IFEND;

                IF NOT iov$tape_completion_q_table^ [j].req [k].waiting_response THEN

                  pmp$wait (20000, 750);

                  IF job_recovery THEN
                    osp$disestablish_cond_handler;
                    osp$set_status_abnormal ('IO', ioe$tape_job_recovery, ' ', status);
                    RETURN;
                  IFEND;
                IFEND;

? ELSE {For boot environment, to not use ready task mechanism

                pmp$delay (100, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
? IFEND
              IFEND;
            IFEND;
          WHILEND;
        IFEND;
      FOREND;

{ Report system failure to job if an io_id cannot be found.  Each request will have the assigned
{ io_id placed in a tape_completion_q_packet entry at time request is posted.
{ If the task was terminated during error recovery, return a unique error status, since
{ in this case not finding the io_id can be expected.

      IF NOT p_ud^.task_terminated_during_recovery THEN
        osp$set_status_abnormal ('io', ioc$os_failure,
              'unable to find io_id in iop$tape_request_status', status);
      ELSE
        osp$set_status_abnormal ('IO', ioe$task_terminated_during_rec, ' ', status);
      IFEND;

      #INLINE ('keypoint', osk$exit, osk$m * ORD (io_status.completion_code), ioc$tape_exit_ioptrqs);
    END
  PROCEND iop$tape_request_status;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_retry_io ' ??
?? EJECT ??

  PROCEDURE iop$tape_retry_io (p_tape_request: ^iot$tape_request;
    bid_recovery: boolean;
    bid_update: boolean;
    VAR status: ost$status);

    CONST
      buf_release = FALSE;

    VAR
      commands_executed: iot$tape_request_length,
      data_transfer_commands_executed: iot$tape_request_length,
      i: iot$tape_request_length,
      io_id: iot$io_id,
      io_status: iot$tape_io_status,
      j: iot$tape_request_length,
      logical_unit_no: iot$logical_unit;

    status.normal := TRUE;

    #INLINE ('keypoint', osk$entry, 0, ioc$tape_entry_ioptrio);
    commands_executed := (p_tape_request^.last_command_processed - ioc$min_request_length) DIV 8 + 1;
    IF commands_executed > 0 THEN
      CASE p_tape_request^.request_type OF
      = ioc$tape_read =
        data_transfer_commands_executed := (commands_executed - ioc$67x_cmd_pos_read +1) DIV
              ioc$read_cmd_per_block;
        IF ((commands_executed - ioc$67x_cmd_pos_read) MOD ioc$read_cmd_per_block) = 0 THEN
{Error on store transfer count.}
          p_tape_request^.io_status.io_complete := TRUE;
          p_tape_request^.io_status.normal_completion := FALSE;
          p_tape_request^.io_status.completion_code := ioc$system_software_failure;
          RETURN;
        IFEND;
        p_tape_request^.no_of_data_commands := p_tape_request^.no_of_data_commands -
              data_transfer_commands_executed;
        FOR i := 1 TO p_tape_request^.no_of_data_commands DO
          p_tape_request^.read_block_description^ [i] := p_tape_request^.read_block_description^
                [data_transfer_commands_executed + i];
        FOREND;
        j := (data_transfer_commands_executed) * ioc$read_cmd_per_block + ioc$67x_cmd_pos_read - 1;
        FOR i := 1 TO p_tape_request^.no_of_data_commands * ioc$read_cmd_per_block DO
          p_tape_request^.request.tape_command [ioc$67x_cmd_pos_read - 1 + i] := p_tape_request^.request.
                tape_command [j + i];
        FOREND;
        p_tape_request^.request.request_length := p_tape_request^.no_of_data_commands * ioc$read_cmd_per_block
              * 8 + iov$67x_command_table [p_tape_request^.request_type].length;
      = ioc$tape_write =
        data_transfer_commands_executed := (commands_executed - ioc$67x_cmd_pos_write) DIV
              ioc$write_cmd_per_block;
        p_tape_request^.no_of_data_commands := p_tape_request^.no_of_data_commands -
              data_transfer_commands_executed;
        FOR i := 1 TO p_tape_request^.no_of_data_commands DO
          p_tape_request^.write_block_description^ [i] := p_tape_request^.write_block_description^
                [data_transfer_commands_executed + i];
        FOREND;
        j := (data_transfer_commands_executed) * ioc$write_cmd_per_block + ioc$67x_cmd_pos_write - 1;
        FOR i := 1 TO p_tape_request^.no_of_data_commands * ioc$write_cmd_per_block DO
          p_tape_request^.request.tape_command [ioc$67x_cmd_pos_write - 1 + i] := p_tape_request^.request.
                tape_command [j + i];
        FOREND;
        p_tape_request^.request.request_length := p_tape_request^.no_of_data_commands *
              ioc$write_cmd_per_block * 8 + iov$67x_command_table [p_tape_request^.request_type].length;

      = ioc$tape_forspace, ioc$tape_backspace, ioc$tape_write_tapemark =
        p_tape_request^.no_of_non_data_commands := p_tape_request^.no_of_non_data_commands -
              commands_executed +1;
        p_tape_request^.request.request_length := (p_tape_request^.no_of_non_data_commands - 1) * 8 +
              iov$67x_command_table [p_tape_request^.request_type].length;
      ELSE
        p_tape_request^.io_status.io_complete := TRUE;
        p_tape_request^.io_status.normal_completion := FALSE;
        p_tape_request^.io_status.completion_code := ioc$system_software_failure;
        RETURN;
      CASEND;
    IFEND;
    iop$tape_queue_request_setup (p_tape_request, status);
    IF status.normal THEN
      io_id := p_tape_request^.io_id;
      logical_unit_no := p_tape_request^.request.logical_unit;
        iop$tape_internal_request_stat (logical_unit_no, io_id, buf_release, bid_recovery, bid_update,
              osc$wait, io_status, status);
      p_tape_request^.io_status := io_status;
    IFEND;

  PROCEND iop$tape_retry_io;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_status_check ' ??
?? EJECT ??

  PROCEDURE iop$tape_status_check (bid_recovery: boolean;
        bid_update: boolean;
    VAR p_tape_request: ^iot$tape_request;
    VAR status: ost$status);

    CONST
      disable_unit = FALSE,
      physical_unload = FALSE,
      repeat_count = 1;

    VAR
      bid_offset: iot$bid_index,
      block_id_status_area: iot$tape_bid_status_response,
      commands_executed: iot$tape_request_length,
      data_transfers: iot$tape_request_length,
      device_status: iot$tape_device_status,
      erasures: 1 .. ioc$tape_max_tape_parity_retry,
      i: integer,
      inhibit_recovery_occurred: boolean,
      ipi_tape_status: iot$ipi_tape_status,
      logical_unit: iot$logical_unit,
      p_ud: ^iot$tape_job_unit_descriptor,
      pp_response: iot$pp_response,
      previous_last_good_bid: iot$cartridge_tape_bid,
      rio_id: iot$io_id,
      rio_status: iot$tape_io_status,
      rstatus: ost$status,
      status_word_3: boolean,
      tape_failure_type: iot$tape_failure_type,
      update_count: 0 .. 0ffff(16);
??EJECT??
{ The following procedure was created because there are numerous places in iop$tape_status_check
{ that require that the block id window be updated after a backspace, forespace, and special cases
{ such as a read if and AGC error code is received for device status on an abnormal response.

      PROCEDURE iop$update_bid_window;

        IF p_tape_request^.request_type = ioc$tape_backspace THEN
          IF p_ud^.bid_index <> LOWERVALUE(iot$bid_index) THEN
            p_ud^.bid_index := p_ud^.bid_index - 1;
          ELSE
            p_ud^.bid_index := UPPERVALUE(iot$bid_index);
          IFEND;
          p_ud^.bid_window [p_ud^.bid_index] := ioc$unavail_bid;
        ELSE
          p_ud^.bid_window [p_ud^.bid_index] := ioc$error_block_bid;
          IF p_ud^.bid_index <> UPPERVALUE(iot$bid_index) THEN
            p_ud^.bid_index := p_ud^.bid_index + 1;
          ELSE
            p_ud^.bid_index := LOWERVALUE(iot$bid_index);
          IFEND;
        IFEND;

      PROCEND iop$update_bid_window;
?? EJECT ??
    BEGIN
      status.normal := TRUE;

      #INLINE ('keypoint', osk$entry, 0, ioc$tape_entry_ioptsck);

      data_transfers := 0;
      logical_unit:= p_tape_request^.request.logical_unit;

{     Get the pointer to the unit descriptor entry for this logical unit.

      p_ud := p_tape_request^.ud;

{     The BLOCK_ID_STATUS_AREA is part of the response returned by the PP and consists of 8 CM words.
{     The 8 CM words are defined as an ARRAY [1 .. 32] OF 0 .. 0ffff(16).
{     The first 30 elements of the array are the possible Block_Id area elements.
{     The 31st element is the Single/Double Track Hardware Correction Count for the last Request.
{     The 32nd element is the count of legitimate Block_Id's in 30 element Block_id area.
{     The Correction Count and the update_count were not defined separately for performance reasons.

      IF p_ud^.controller_type <> cmc$mt5680_xx THEN
        IF p_ud^.controller_type = cmc$mt5698_xx THEN
          p_ud^.single_double_track_corrections := p_ud^.single_double_track_corrections +
                p_tape_request^.pp_response_p^.ipi_block_id_status_area[31];
          update_count := p_tape_request^.pp_response_p^.ipi_block_id_status_area[32];
          block_id_status_area := p_tape_request^.pp_response_p^.ipi_block_id_status_area;
        ELSE { ats, ismt, or 698
          p_ud^.single_double_track_corrections := p_ud^.single_double_track_corrections +
                p_tape_request^.pp_response_p^.block_id_status_area[31];
          update_count := p_tape_request^.pp_response_p^.block_id_status_area[32];
          block_id_status_area := p_tape_request^.pp_response_p^.block_id_status_area;
        IFEND;
      ELSE

      IFEND;

{ Fetch pp_response and device_status for investigation and status updates.
{ If controller type = IPI, set fields in device_status from ipi_tape_status.
{ IF controller type = CTS/CCC, set fields in device_status from ccc_cart_device_status.
{ Device_status is used for the normal completion case.

      pp_response := p_tape_request^.pp_response_p^.pp_response;

      IF (p_ud^.controller_type <> cmc$mt5698_xx) AND (p_ud^.controller_type <> cmc$mt5680_xx) THEN
        device_status := p_tape_request^.pp_response_p^.device_status;

{ Update the tape_job_unit_descriptor with the last density at which the tape unit was operating.

        p_ud^.tape_unit_density := device_status.density;

      ELSEIF p_ud^.controller_type = cmc$mt5698_xx THEN

        ipi_tape_status := p_tape_request^.pp_response_p^.ipi_tape_status;
        device_status.write_ring := NOT ipi_tape_status.special_status.write_protect;
        IF p_tape_request^.request_type = ioc$tape_write THEN
          device_status.end_of_tape := FALSE;  { Assume False on normal write completion }
        ELSE
          device_status.end_of_tape := ipi_tape_status.special_status.end_of_media;
        IFEND;
        device_status.beginning_of_tape := ipi_tape_status.special_status.beginning_of_media;
        device_status.unit_ready := ipi_tape_status.special_status.media_present;
        device_status.unit_busy := FALSE;  { Assume False on normal completion }
        IF ipi_tape_status.special_status.density THEN  { 6250
          p_ud^.tape_unit_density := 3;
        ELSE { 1600
          p_ud^.tape_unit_density := 1;
        IFEND;

      ELSE { cmc$mt5680_xx

        device_status.write_ring := p_tape_request^.pp_response_p^.ccc_cart_device_status.write_enabled;
        IF p_tape_request^.request_type = ioc$tape_write THEN
          device_status.end_of_tape := FALSE;  { Assume False on normal write completion }
        ELSE
          device_status.end_of_tape := p_tape_request^.pp_response_p^.ccc_cart_device_status.end_of_tape;
        IFEND;
        device_status.beginning_of_tape := p_tape_request^.pp_response_p^.ccc_cart_device_status.
              beginning_of_tape;
        device_status.unit_ready := p_tape_request^.pp_response_p^.ccc_cart_device_status.ready;
        device_status.unit_busy := p_tape_request^.pp_response_p^.ccc_cart_device_status.busy;
        p_ud^.tape_unit_density := 4;

      IFEND;


      CASE pp_response.response_code.primary_response OF
        = ioc$unsolicited_response =
          { This should have already been handled and never get here. }
          iop$tape_pp_error (p_tape_request, status);
          RETURN;

        = ioc$intermediate_response =
          { Error since this is not used by the tape handler. }
          iop$tape_pp_error (p_tape_request, status);
          RETURN;

        = ioc$normal_response =

          commands_executed := (p_tape_request^.last_command_processed - ioc$min_request_length) DIV 8 + 1;

{ Update the Block_id current window located in tape job unit descriptor.
{ Presently update on count from PP for all write, read, forspace, and write_tapemark functions.

          IF ((p_tape_request^.request_type = ioc$tape_write) OR
                (p_tape_request^.request_type = ioc$tape_read) OR
                (p_tape_request^.request_type = ioc$tape_write_tapemark) OR
                (p_tape_request^.request_type = ioc$tape_forspace)) AND
                (p_ud^.controller_type <> cmc$mt5680_xx) THEN
            IF update_count > 0 THEN
              FOR i := 1 to update_count DO
                p_ud^.bid_window [p_ud^.bid_index] := block_id_status_area [i];
                IF p_ud^.bid_index = UPPERVALUE(iot$bid_index) THEN
                  p_ud^.bid_index := LOWERVALUE(iot$bid_index);
                ELSE
                  p_ud^.bid_index := p_ud^.bid_index + 1;
                IFEND;
              FOREND;
            IFEND;

          ELSEIF p_ud^.controller_type = cmc$mt5680_xx THEN

            previous_last_good_bid := p_ud^.cartridge_tape_last_good_bid;
            IF (p_tape_request^.request_type = ioc$locate_block) AND (p_ud^.cartridge_tape_last_good_bid.
                  logical_position <> p_tape_request^.pp_response_p^.ccc_cart_device_status.last_good_bid.
                  logical_position) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_invalid_bid;
              p_tape_request^.io_status.normal_completion := FALSE;
              p_tape_request^.io_status.completion_code := ioc$controller_failure;
              p_tape_request^.io_status.position_uncertain := TRUE;
              iop$tape_error_logging_ccc_cart (p_tape_request, ioc$unrecovered, status);
              RETURN;
            IFEND;

{ Do not update the last_good_bid if a forespace is being done with bid_update = FALSE.  This is
{ done to reposition tape after a fatal parity error in buffered mode.  We cannot update the
{ block_id since we need it for potential global error recovery if error recovery is enabled.

            IF NOT ((p_tape_request^.request_type = ioc$tape_forspace) AND (NOT bid_update)) THEN
              p_ud^.cartridge_tape_last_good_bid := p_tape_request^.pp_response_p^.
                    ccc_cart_device_status.last_good_bid;
              IF p_tape_request^.request_type <> ioc$locate_block THEN
                IF (p_tape_request^.request_type = ioc$tape_backspace) AND
                      (p_ud^.error_block_forespace_count > 0) THEN
                  IF commands_executed < p_ud^.error_block_forespace_count THEN
                    p_ud^.cartridge_tape_last_good_bid := previous_last_good_bid;
                    p_ud^.error_block_forespace_count := p_ud^.error_block_forespace_count -
                          commands_executed;
                  ELSE
                    p_ud^.error_block_forespace_count := 0;
                  IFEND;
                ELSE
                  p_ud^.error_block_forespace_count := 0;
                IFEND;
              IFEND;
            IFEND;

          IFEND;

{         Update the tape request for the number of blocks_accessed.

          IF commands_executed > 0 THEN
            CASE p_tape_request^.request_type OF

            = ioc$tape_read =
              data_transfers := (commands_executed) DIV ioc$read_cmd_per_block;

            = ioc$tape_write =
              data_transfers := (commands_executed) DIV ioc$write_cmd_per_block;

            = ioc$tape_forspace, ioc$tape_backspace =
              data_transfers := commands_executed;

            = ioc$tape_write_tapemark =
              data_transfers := commands_executed - ioc$67x_cmd_pos_write_tapemark + 1;

            = ioc$skip_tapemark_forward, ioc$skip_tapemark_backward =
              data_transfers := commands_executed - ioc$67x_cmd_pos_skip_tm_f + 1;

            ELSE
              data_transfers := 0;

            CASEND;
            p_tape_request^.blocks_accessed := p_tape_request^.blocks_accessed + data_transfers;
          IFEND;

          p_tape_request^.io_status.normal_completion := TRUE;
          p_tape_request^.io_status.write_ring := device_status.write_ring;
          p_tape_request^.io_status.end_of_tape := device_status.end_of_tape;
          p_tape_request^.io_status.beginning_of_tape := device_status.beginning_of_tape;
          p_tape_request^.io_status.unit_busy := device_status.unit_busy;
          p_tape_request^.io_status.unit_ready := device_status.unit_ready;

{         IF this is the exit path for a recovered failure at the end of a group of tape
{         operations, log the original failure information, set tape_error_log_entry to
{         FALSE and initialize the block_in_error entry in the unit descriptor.

          IF NOT bid_recovery AND (p_ud^.tape_error_log_entry = TRUE) THEN
            tape_failure_type := ioc$recovered;
            IF p_ud^.controller_type = cmc$mt5698_xx THEN
              iop$tape_error_logging_ipi (p_tape_request, tape_failure_type, status);
            ELSEIF p_ud^.controller_type = cmc$mt5680_xx THEN
              iop$tape_error_logging_ccc_cart (p_tape_request, tape_failure_type, status);
            ELSE  { ats, ismt or 698
              iop$tape_error_logging (p_tape_request, tape_failure_type, {*IM*} FALSE, status);
            IFEND;
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            p_ud^.tape_error_log_entry := FALSE;

          IFEND;

          CASE p_tape_request^.request_type OF
          = ioc$tape_backspace, ioc$tape_read_backwards =
            IF p_ud^.controller_type <> cmc$mt5680_xx THEN
              IF bid_update THEN
                FOR i := 1 TO data_transfers DO
                  iop$update_bid_window;
                FOREND;
              IFEND;
            IFEND;

          = ioc$tape_rewind, ioc$tape_unload, ioc$tape_get_status =

            IF ((p_ud^.tape_unit_density = 0) OR (p_ud^.tape_unit_density = 1)) THEN
              p_tape_request^.io_status.unit_density := rmc$1600;
            ELSEIF p_ud^.tape_unit_density = 2 THEN
              p_tape_request^.io_status.unit_density := rmc$800;
            ELSEIF p_ud^.tape_unit_density = 3 THEN
              p_tape_request^.io_status.unit_density := rmc$6250;
            ELSEIF p_ud^.tape_unit_density = 4 THEN
              p_tape_request^.io_status.unit_density := rmc$38000;
            IFEND;

            IF p_ud^.controller_type <> cmc$mt5680_xx THEN
              p_ud^.bid_index := LOWERVALUE(iot$bid_index) + 1;
              bid_offset := LOWERVALUE(iot$bid_index);
              p_ud^.bid_window [bid_offset] := ioc$loadpoint_bid;
              FOR bid_offset := 2 TO UPPERBOUND(iot$bid_window) DO
                p_ud^.bid_window [bid_offset] := ioc$empty_bid;
              FOREND;
            ELSE { cartridge tape
              p_ud^.cartridge_tape_last_good_bid := zero_ccc_cart_bid;
              p_ud^.error_block_forespace_count := 0;
            IFEND;

          = ioc$skip_tapemark_backward =
            IF p_ud^.controller_type <> cmc$mt5680_xx THEN
              p_ud^.bid_index := LOWERVALUE(iot$bid_index);
              bid_offset := LOWERVALUE(iot$bid_index);
              p_ud^.bid_window [bid_offset] := ioc$tapemark_bid;
              FOR bid_offset := 2 TO UPPERBOUND(iot$bid_window) DO
                p_ud^.bid_window [bid_offset] := ioc$empty_bid;
              FOREND;
            IFEND;

          = ioc$skip_tapemark_forward =
            IF p_ud^.controller_type <> cmc$mt5680_xx THEN
              p_ud^.bid_index := LOWERVALUE(iot$bid_index) + 1;
              bid_offset := LOWERVALUE(iot$bid_index);
              p_ud^.bid_window [bid_offset] := ioc$tapemark_bid;
              FOR bid_offset := 2 TO UPPERBOUND(iot$bid_window) DO
                p_ud^.bid_window [bid_offset] := ioc$empty_bid;
              FOREND;
            IFEND;

          ELSE
          CASEND;

{ The following copy of the present bid_window is to save the last correct bid_index and bid_window in the
{ unit job descriptor as the historical index/window to use in Tape_Fatal_Error_Recovery when we are
{ positioning to the Last_Good_Block.  We have to save this image as it reflects the block_count from
{ loadpoint that indexes to the physical_position of the buffer_group being used at the time of the
{ fatal error.  The recovery algorithm will continue writing from that point in the buffer_group and
{ assumes that we are positioned after the last good block that was written/read  prior to the fatal error.
{ Copying the unit descriptor's index and window in this normal case let's the historical_index and
{ historical_bid_window indicate the actual position of the tape while ignoring recovery positioning. This
{ lets us provide the tape position (current without recovery) in iop$get_position_of_tape_file and not have
{ to ask specifically for the contents of p_ud^.bid_index and p_ud^.bid_window. Using the same algorithm for
{ always getting the position of the tape file has better maintainability.

          IF p_ud^.controller_type <> cmc$mt5680_xx THEN
            IF NOT bid_recovery OR (p_ud^.positioning_to_tapemark) THEN
              p_ud^.historical_bid_index := p_ud^.bid_index;
              p_ud^.historical_bid_window := p_ud^.bid_window;
            IFEND;
          IFEND;

        = ioc$abnormal_response =

{ Update the Block_id current window located in tape job unit descriptor.
{ Presently update on count from PP for all write, read, forspace, and write_tapemark functions.

          IF ((p_tape_request^.request_type = ioc$tape_write) OR
                (p_tape_request^.request_type = ioc$tape_read) OR
                (p_tape_request^.request_type = ioc$tape_write_tapemark) OR
                (p_tape_request^.request_type = ioc$tape_forspace)) AND
                (p_ud^.controller_type <> cmc$mt5680_xx) THEN
            IF update_count > 0 THEN
              FOR i := 1 to update_count DO
                p_ud^.bid_window [p_ud^.bid_index] := block_id_status_area [i];
                IF p_ud^.bid_index = UPPERVALUE(iot$bid_index) THEN
                  p_ud^.bid_index := LOWERVALUE(iot$bid_index);
                ELSE
                  p_ud^.bid_index := p_ud^.bid_index + 1;
                IFEND;
              FOREND;
            IFEND;
          ELSEIF p_ud^.controller_type = cmc$mt5680_xx THEN
            previous_last_good_bid := p_ud^.cartridge_tape_last_good_bid;
            IF (p_tape_request^.pp_response_p^.ccc_cart_device_status.last_good_bid <> zero_ccc_cart_bid) AND
                  NOT (p_tape_request^.request_type = ioc$locate_block) AND
                  NOT ((p_tape_request^.request_type = ioc$tape_write) AND
                  (p_tape_request^.pp_response_p^.pp_response.abnormal_status.hardware_malfunction)) THEN
              IF (p_tape_request^.pp_response_p^.ccc_cart_device_status.last_good_bid.
                    physical_position = 0) THEN
                p_ud^.cartridge_tape_last_good_bid.logical_position := p_tape_request^.pp_response_p^.
                      ccc_cart_device_status.last_good_bid.logical_position;
              ELSE
                p_ud^.cartridge_tape_last_good_bid := p_tape_request^.pp_response_p^.
                      ccc_cart_device_status.last_good_bid;
              IFEND;

            ELSE { determine if detailed status bid present
              commands_executed := (p_tape_request^.last_command_processed - ioc$min_request_length)
                    DIV 8 + 1;
              IF NOT p_tape_request^.pp_response_p^.ccc_cart_device_status.adapter_check AND
                    (p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id = 0) AND
                    (p_tape_request^.pp_response_p^.ccc_cart_device_status.unit_check) AND
                    (p_tape_request^.pp_response_p^.pp_response.response_length >
                          ioc$min_ccc_cart_resp_size) AND
                    (p_tape_request^.pp_response_p^.ccc_cart_sense_bytes.erpa_code <> 41(16)) AND
                    (commands_executed > 0) THEN

                CASE p_tape_request^.request_type OF

                = ioc$tape_read, ioc$tape_forspace, ioc$skip_tapemark_forward =


                  IF NOT ((p_tape_request^.request_type = ioc$tape_forspace) AND (NOT bid_update)) THEN
                    IF p_tape_request^.pp_response_p^.ccc_cart_sense_bytes.block_id_pos_indicator THEN
                      p_ud^.cartridge_tape_last_good_bid.logical_position := p_tape_request^.pp_response_p^.
                            ccc_cart_sense_bytes.logical_error_bid - 1;
                    ELSE
                      p_ud^.cartridge_tape_last_good_bid.logical_position := p_tape_request^.pp_response_p^.
                            ccc_cart_sense_bytes.logical_error_bid;
                    IFEND;
                  IFEND;

                = ioc$tape_write =

                  IF (p_tape_request^.pp_response_p^.ccc_cart_device_status.last_good_bid <>
                        zero_ccc_cart_bid) THEN
                    p_ud^.cartridge_tape_last_good_bid := p_tape_request^.pp_response_p^.
                          ccc_cart_device_status.last_good_bid;
                  ELSE
                    osp$system_error ('Non catastrophic write did not return LGBID', ^status);
                  IFEND;

                = ioc$tape_backspace, ioc$skip_tapemark_backward, ioc$tape_write_tapemark =

                  p_ud^.cartridge_tape_last_good_bid.logical_position := p_tape_request^.pp_response_p^.
                        ccc_cart_sense_bytes.logical_error_bid;

                ELSE { rewind or unload or locate_block

                  ; { DO NOT store block id in unit descriptor!!

                CASEND;

              ELSE { bid not known, must resend entire request
                p_tape_request^.last_command_processed := ioc$min_request_length - 8;
              IFEND;
            IFEND;
          IFEND;

{ The following copy of the present bid_window is to save the last correct bid_index and bid_window in the
{ unit job descriptor as the historical index/window to use in Tape_Fatal_Error_Recovery when we are
{ positioning to the Last_Good_Block.  We have to save this image as it reflects the block_count from
{ loadpoint that corresponds to the physical_position of the buffer_group being used at the time of the
{ fatal error.  The recovery algorithm will continue writing from the that point in the buffer_group and
{ assumes that we are positioned after the last good block that was written/read prior to the fatal error.

          IF p_ud^.controller_type <> cmc$mt5680_xx THEN
            IF NOT bid_recovery OR (p_ud^.positioning_to_tapemark) THEN
              p_ud^.historical_bid_index := p_ud^.bid_index;
              p_ud^.historical_bid_window := p_ud^.bid_window;
            IFEND;
          IFEND;

          /response_code_case/
          BEGIN
          p_tape_request^.io_status.normal_completion := FALSE;
          inhibit_recovery_occurred := FALSE;

{ Update the tape request for the number of blocks_accessed.

          commands_executed := (p_tape_request^.last_command_processed - ioc$min_request_length) DIV 8 + 1;

          IF commands_executed > 0 THEN
            CASE p_tape_request^.request_type OF

            = ioc$tape_read =
              data_transfers := (commands_executed - ioc$67x_cmd_pos_read + 1) DIV
                    ioc$read_cmd_per_block;
              p_ud^.blocks_read := p_ud^.blocks_read + 1;

            = ioc$tape_write =
              data_transfers := (commands_executed - ioc$67x_cmd_pos_write + 1) DIV
                    ioc$write_cmd_per_block;
              p_ud^.blocks_written := p_ud^.blocks_written + 1;

            = ioc$tape_forspace, ioc$tape_backspace =
              data_transfers := commands_executed - ioc$67x_cmd_pos_forspace + 1;
              p_ud^.blocks_read := p_ud^.blocks_read + 1;

            = ioc$tape_write_tapemark =
              data_transfers := commands_executed - ioc$67x_cmd_pos_write_tapemark + 1;
              p_ud^.blocks_written := p_ud^.blocks_written + 1;

            = ioc$skip_tapemark_forward, ioc$skip_tapemark_backward =
              data_transfers := commands_executed - ioc$67x_cmd_pos_skip_tm_f + 1;

            ELSE
              data_transfers := 0;

            CASEND;
            p_tape_request^.blocks_accessed := p_tape_request^.blocks_accessed + data_transfers;
          IFEND;

{ Process abnormal status for 5698_1x and 5680_11 in separate routines.

          IF p_ud^.controller_type = cmc$mt5698_xx THEN   { process 5698_1x abnormal status
            iop$tape_status_check_ipi (bid_recovery, bid_update, commands_executed,
                  data_transfers, inhibit_recovery_occurred, p_tape_request, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            EXIT /response_code_case/;
          ELSEIF p_ud^.controller_type = cmc$mt5680_xx THEN { process 5680_11 abnormal status
            iop$tape_status_check_ccc_cart (bid_recovery, bid_update, commands_executed,
                  data_transfers, previous_last_good_bid, p_tape_request, status);
            RETURN; {<----------
          IFEND;

{ Process non 5698_1x or 5680_11 controller abnormal status.

          p_tape_request^.io_status.write_ring := device_status.write_ring;
          p_tape_request^.io_status.end_of_tape := device_status.end_of_tape;
          p_tape_request^.io_status.beginning_of_tape := device_status.beginning_of_tape;
          p_tape_request^.io_status.unit_busy := device_status.unit_busy;
          p_tape_request^.io_status.unit_ready := device_status.unit_ready;
          IF (pp_response.abnormal_status.abnormal_alert) AND
             (pp_response.alert_conditions.long_input_block) THEN
                p_tape_request^.io_status.long_input_block := TRUE;
                p_tape_request^.io_status.completion_code := ioc$alert_condition_encountered;
          IFEND;
          IF pp_response.abnormal_status.forced_termination THEN
            { Error, since forced termination not used by the tape handler. }
            iop$tape_pp_error (p_tape_request, status);
            EXIT /response_code_case/
          IFEND;
          IF pp_response.abnormal_status.recording_medium_error THEN
            { Error, since pp never should set this. }
            iop$tape_pp_error (p_tape_request, status);
            EXIT /response_code_case/
          IFEND;
          IF pp_response.abnormal_status.intervention_required THEN
            { Error, since pp should never set this. }
            iop$tape_pp_error (p_tape_request, status);
            EXIT /response_code_case/
          IFEND;
          IF pp_response.abnormal_status.interface_error THEN
            { Recovery if any here needs more definition. ***** }
            p_tape_request^.io_status.completion_code := ioc$system_software_failure;
            EXIT /response_code_case/
          IFEND;

{         Check whether an abnormal termination is an unrecovered  error and
{         whether it is the first log entry to be made for this group of tape
{         operations. Save the block number on which the error occurred and
{         make an initial call to iop$tape_error_logging.
{         If this is an abnormal termination on a different block then complete
{         the log entry for the previous block in error, which must have been
{         recovered. After this clear the retry counters and make an initial
{         call to iop$tape_error_logging for the current block in error.

          status_word_3 := device_status.tape_parity_error OR device_status.lost_data OR
                           device_status.unit_check OR device_status.channel_parity_error OR
                           device_status.tcu_parity_error OR (device_status.error_code > 0);
          IF NOT bid_recovery AND
             NOT (pp_response.alert_conditions.long_input_block AND NOT status_word_3) AND
             NOT (pp_response.alert_conditions.logical_delimiter) AND
             NOT (pp_response.alert_conditions.physical_delimiter AND NOT status_word_3) AND
             NOT ((p_tape_request^.request_type = ioc$tape_erase) AND NOT (device_status.unit_check)) AND
             (pp_response.abnormal_status.hardware_malfunction OR
              pp_response.abnormal_status.channel_error OR
              pp_response.abnormal_status.output_channel_parity OR
              pp_response.abnormal_status.function_timeout OR
              pp_response.abnormal_status.data_overrun) AND
             NOT (((p_tape_request^.request_type = ioc$tape_get_status) OR
                   (p_tape_request^.request_type = ioc$tape_unload)) AND
                   (device_status.error_code = 4)) AND
             NOT ((device_status.error_code = 6) OR
                  (device_status.error_code = 7) OR
                  (device_status.error_code = 10(8)) OR
                  (device_status.error_code = 30(8)) OR
                  (device_status.error_code = 32(8))) THEN

{           Check whether a log entry is outstanding.

            IF NOT p_ud^.tape_error_log_entry THEN
              tape_failure_type := ioc$undetermined;
              iop$tape_error_logging (p_tape_request, tape_failure_type, {*IM*} FALSE, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

{             Set tape_error_log_entry to TRUE and save the block number for the block_in_error.

              p_ud^.tape_error_log_entry := TRUE;
              p_ud^.block_in_error := p_tape_request^.blocks_accessed;

            ELSE
              IF p_tape_request^.blocks_accessed <> p_ud^.block_in_error THEN

{               Finalize the outstanding error log entry, which has been recovered.

                tape_failure_type := ioc$recovered;
                iop$tape_error_logging (p_tape_request, tape_failure_type, {*IM*} FALSE, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

{               Clear the retry counters before attempting to recover the next failure.

                p_tape_request^.tcu_parity_retry_count := 0;
                p_tape_request^.parity_retry_count := 0;
                p_tape_request^.lost_data_retry_count := 0;
                p_tape_request^.busy_retry_count := 0;
                p_tape_request^.lateack_retry_count := 0;
                p_tape_request^.misc_retry_count := 0;

{               Make an initial log entry for the next failure.

                tape_failure_type := ioc$undetermined;
                iop$tape_error_logging (p_tape_request, tape_failure_type, {*IM*} FALSE, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

{               Save the block_in _error, tape_error_log_entry is already set to TRUE.

                p_ud^.block_in_error := p_tape_request^.blocks_accessed;

              IFEND;
            IFEND;
          IFEND;

          IF NOT pp_response.abnormal_status.hardware_malfunction THEN
            IF (pp_response.abnormal_status.channel_error) OR
               (pp_response.abnormal_status.output_channel_parity) THEN

            /input_output_parity/
            BEGIN
              IF p_tape_request^.parity_retry_count < ioc$tape_max_chan_parity_retry THEN
                p_tape_request^.parity_retry_count := p_tape_request^.parity_retry_count + 1;
               IF commands_executed > 0 THEN
                CASE p_tape_request^.request_type OF
                = ioc$tape_read, ioc$tape_write, ioc$tape_write_tapemark =
                  iop$tape_reposition_b (p_tape_request, status);
                = ioc$tape_forspace =
                  IF bid_update THEN
                    iop$tape_reposition_b (p_tape_request, status);
                  ELSE
                    iop$update_bid_window;
                    p_tape_request^.io_status.io_complete := TRUE;
                    p_tape_request^.io_status.normal_completion := TRUE;
                    EXIT /response_code_case/
                  IFEND;
                = ioc$tape_read_backwards, ioc$tape_backspace =
                  IF bid_update THEN
                    FOR i := 1 TO data_transfers + 1 DO
                      iop$update_bid_window;
                    FOREND;
                  IFEND;
                  IF NOT bid_recovery THEN
                    iop$tape_reposition_f (p_tape_request, status);
                  ELSE
                    p_tape_request^.io_status.io_complete := TRUE;
                    p_tape_request^.io_status.normal_completion := TRUE;
                    EXIT /response_code_case/
                  IFEND;
                ELSE
                  EXIT /input_output_parity/
                CASEND;
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                IF (p_tape_request^.io_status.io_complete) AND
                   NOT (p_tape_request^.io_status.normal_completion) AND
                   NOT (p_tape_request^.io_status.completion_code = ioc$tapemark_read) THEN

{                 Reposition failed.
{                 Exit with io_status returned from reposition.
                  EXIT /response_code_case/
                IFEND;
               IFEND;
                  iop$tape_retry_io (p_tape_request, bid_recovery, bid_update, status);

{ Exit with io_status returned from retrying the io operation.

                  EXIT /response_code_case/
              IFEND;
            END /input_output_parity/;
              p_tape_request^.io_status.io_complete := TRUE;
              IF pp_response.abnormal_status.channel_error THEN
                p_tape_request^.io_status.completion_code := ioc$input_channel_parity;
              ELSE
                IF device_status.channel_parity_error THEN
                  p_tape_request^.io_status.completion_code := ioc$iou_output_parity;
                ELSE
                  p_tape_request^.io_status.completion_code := ioc$indeterminate_output_parity;
                IFEND;
              IFEND;
              EXIT /response_code_case/
            IFEND;

            IF pp_response.abnormal_status.function_timeout THEN
              p_tape_request^.io_status.completion_code := ioc$function_timeout;
              p_tape_request^.io_status.io_complete := TRUE;
              EXIT /response_code_case/
            IFEND;

            IF pp_response.abnormal_status.data_overrun THEN

            /overrun_loop/
              BEGIN

                IF p_tape_request^.lateack_retry_count < ioc$tape_max_lateack_retry THEN
                  p_tape_request^.lateack_retry_count := p_tape_request^.lateack_retry_count + 1;
                  CASE p_tape_request^.request_type OF
                  = ioc$tape_read, ioc$tape_write, ioc$tape_write_tapemark =
                    iop$tape_reposition_b (p_tape_request, status);
                  = ioc$tape_forspace =
                    IF bid_update THEN
                      iop$tape_reposition_b (p_tape_request, status);
                    ELSE
                      iop$update_bid_window;
                      p_tape_request^.io_status.io_complete := TRUE;
                      p_tape_request^.io_status.normal_completion := TRUE;
                      EXIT /response_code_case/
                    IFEND;
                  = ioc$tape_read_backwards, ioc$tape_backspace =
                    IF bid_update THEN
                      FOR i := 1 TO data_transfers + 1 DO
                        iop$update_bid_window;
                      FOREND;
                    IFEND;
                    IF NOT bid_recovery THEN
                      iop$tape_reposition_f (p_tape_request, status);
                    ELSE
                      p_tape_request^.io_status.io_complete := TRUE;
                      p_tape_request^.io_status.normal_completion := TRUE;
                      EXIT /response_code_case/
                    IFEND;
                  ELSE
                    p_tape_request^.io_status.io_complete := TRUE;
                    p_tape_request^.io_status.completion_code := ioc$unit_failure;
                    EXIT /overrun_loop/
                  CASEND;
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;

                  IF p_tape_request^.io_status.io_complete AND
                     NOT p_tape_request^.io_status.normal_completion AND
                     NOT (p_tape_request^.io_status.completion_code = ioc$tapemark_read) THEN

{                   Reposition failed.
{                   Exit with io_status returned from reposition.
                    EXIT /response_code_case/
                  ELSE
                    iop$tape_retry_io (p_tape_request, bid_recovery, bid_update, status);

{ Exit with io_status returned from retrying the io operation.

                    EXIT /response_code_case/
                  IFEND;
                IFEND;
                p_tape_request^.io_status.io_complete := TRUE;
                p_tape_request^.io_status.completion_code := ioc$unit_failure;
              END /overrun_loop/;
            IFEND;
            IF pp_response.abnormal_status.abnormal_alert THEN
              IF pp_response.alert_conditions.compare_not_satisfied THEN
                { This should never be set for tape. }
                iop$tape_pp_error (p_tape_request, status);
                EXIT /response_code_case/
              IFEND;

{             Investigate whether a tapemark has been encountered.

              IF pp_response.alert_conditions.logical_delimiter THEN
                p_tape_request^.io_status.completion_code := ioc$tapemark_read;

{               Update the block id window index after a tapemark has been encountered
{               during a backward motion operation. Set the block id to ioc$unavail_bid.

                CASE p_tape_request^.request_type OF
                = ioc$tape_backspace, ioc$tape_read_backwards =
                  IF bid_update THEN
                    FOR i := 1 TO data_transfers + 1 DO
                      iop$update_bid_window;
                    FOREND;
                  IFEND;

                ELSE
                CASEND;
                EXIT /response_code_case/
              IFEND;

{             Investigate whether end of tape has been encountered.  IF so, increment
{             blocks_accessed to indicate block is written to tape.

              IF pp_response.alert_conditions.physical_delimiter THEN
                p_tape_request^.blocks_accessed := p_tape_request^.blocks_accessed + 1;
                p_tape_request^.io_status.normal_completion := TRUE;
                p_tape_request^.io_status.io_complete := TRUE;
                EXIT /response_code_case/
              IFEND;

            IFEND;

          ELSE {pp_response.abnormal_status.hardware_malfunction = TRUE}

            IF device_status.tcu_parity_error OR ((device_status.unit_check) AND
                  ((p_ud^.controller_type = cmc$mt7221_1) OR (p_ud^.controller_type = cmc$mt7221_2_s0)) AND
                  (device_status.error_code = 0)) THEN
              IF p_tape_request^.tcu_parity_retry_count < ioc$tape_max_tcu_parity_retry THEN
                p_tape_request^.tcu_parity_retry_count := p_tape_request^.tcu_parity_retry_count + 1;
                CASE p_tape_request^.request_type OF
                = ioc$tape_read, ioc$tape_write, ioc$tape_write_tapemark =
                  iop$tape_reposition_b (p_tape_request, status);
                = ioc$tape_forspace =
                  IF bid_update THEN
                    iop$tape_reposition_b (p_tape_request, status);
                  ELSE
                    iop$update_bid_window;
                    p_tape_request^.io_status.io_complete := TRUE;
                    p_tape_request^.io_status.normal_completion := TRUE;
                    EXIT /response_code_case/
                  IFEND;
                = ioc$tape_read_backwards, ioc$tape_backspace =
                  IF bid_update THEN
                    FOR i := 1 TO data_transfers + 1 DO
                      iop$update_bid_window;
                    FOREND;
                  IFEND;
                  IF NOT bid_recovery THEN
                    iop$tape_reposition_f (p_tape_request, status);
                  ELSE
                    p_tape_request^.io_status.io_complete := TRUE;
                    p_tape_request^.io_status.normal_completion := TRUE;
                    EXIT /response_code_case/
                  IFEND;
                ELSE
                  p_tape_request^.io_status.io_complete := TRUE;
                  p_tape_request^.io_status.completion_code := ioc$unit_failure;
                  EXIT /response_code_case/
                CASEND;
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                IF p_tape_request^.io_status.io_complete AND
                   NOT p_tape_request^.io_status.normal_completion AND
                   NOT (p_tape_request^.io_status.completion_code = ioc$tapemark_read) THEN

{                 Reposition failed.
{                 Exit with io_status returned from reposition.
                  EXIT /response_code_case/
                IFEND;
                iop$tape_retry_io (p_tape_request, bid_recovery, bid_update, status);

{ Exit with io_status returned from retrying the io operation.

                EXIT /response_code_case/
              IFEND;
              p_tape_request^.io_status.io_complete := TRUE;
              p_tape_request^.io_status.completion_code := ioc$unit_failure;
            ELSE
              IF device_status.unit_check THEN
                p_tape_request^.io_status.normal_completion := FALSE;
                p_tape_request^.io_status.completion_code := ioc$unit_failure;
                p_tape_request^.io_status.position_uncertain := TRUE;
              IFEND;
                IF (device_status.error_code = 8 {blank tape}) AND
                      (p_tape_request^.request_type = ioc$tape_write) THEN

{ Attempt recovery in case a 698 CCC drive detected "blank tape" instead of "data parity error".

                  device_status.error_code := 0;
                  device_status.tape_parity_error := TRUE;
                IFEND;
                #INLINE ('keypoint', osk$debug, osk$m * (device_status.error_code), ioc$tape_debug_ioptsck);
                CASE device_status.error_code OF
                = 0 =
                  { No error condition. }
                  IF device_status.channel_parity_error THEN

                  /chan_parity_loop_1/
                    BEGIN

                      IF p_tape_request^.parity_retry_count < ioc$tape_max_chan_parity_retry THEN
                        p_tape_request^.parity_retry_count := p_tape_request^.parity_retry_count + 1;
                        IF commands_executed <> 0 THEN
                          CASE p_tape_request^.request_type OF
                          = ioc$tape_write =
                            iop$tape_reposition_b (p_tape_request, status);
                            IF NOT status.normal THEN
                              RETURN;
                            IFEND;
                            IF p_tape_request^.io_status.io_complete AND
                               NOT p_tape_request^.io_status.normal_completion AND
                               NOT (p_tape_request^.io_status.completion_code = ioc$tapemark_read) THEN

{                             Reposition failed.
{                             Exit with io_status returned from reposition.
                              EXIT /response_code_case/
                            IFEND;
                          ELSE
                            p_tape_request^.io_status.io_complete := TRUE;
                            p_tape_request^.io_status.completion_code := ioc$unit_failure;
                            EXIT /chan_parity_loop_1/
                          CASEND;
                        IFEND;
                          iop$tape_retry_io (p_tape_request, bid_recovery, bid_update, status);

{ Exit with io_status returned from retrying the io operation.

                          EXIT /response_code_case/
                      IFEND;
                      p_tape_request^.io_status.io_complete := TRUE;
                      p_tape_request^.io_status.completion_code := ioc$output_channel_parity;
                    END /chan_parity_loop_1/;

                  ELSE
                    IF device_status.tape_parity_error THEN

                    /tape_parity_error_loop/
                      BEGIN

                        IF p_tape_request^.inhibit_error_recovery AND NOT bid_recovery THEN
                           IF p_tape_request^.request_type = ioc$tape_write THEN
                             p_tape_request^.blocks_accessed := p_tape_request^.blocks_accessed + 1;
                           IFEND;
                           inhibit_recovery_occurred := TRUE;
                           p_tape_request^.io_status.io_complete := TRUE;
                           p_tape_request^.io_status.completion_code := ioc$tape_medium_failure;
                           iop$update_bid_window;
                           EXIT /tape_parity_error_loop/
                        IFEND;

                      /tape_parity_error_loop_2/
                      BEGIN
                        IF p_tape_request^.parity_retry_count < ioc$tape_max_tape_parity_retry THEN
                          p_tape_request^.parity_retry_count := p_tape_request^.parity_retry_count + 1;
                          CASE p_tape_request^.request_type OF
                          = ioc$tape_read, ioc$tape_write, ioc$tape_write_tapemark =
                            iop$tape_reposition_b (p_tape_request, status);
                          = ioc$tape_forspace =
                            IF bid_update THEN
                              iop$tape_reposition_b (p_tape_request, status);
                            ELSE
                              iop$update_bid_window;
                              p_tape_request^.io_status.io_complete := TRUE;
                              p_tape_request^.io_status.normal_completion := TRUE;
                              EXIT /response_code_case/
                            IFEND;

                            {the following case selection presently resolves some recovery problems
                            {when parity error is received while backspacing in BID_RECOVERY mode.
                            {We accept backspace errors during BID_RECOVERY because we will check the
                            {BID windows and correct for mispositioning.
                            {When not in recovery we accept backspaces if only a parity error status is
                            {present and not status bits to indicate possible mispositioning.

                          = ioc$tape_backspace, ioc$tape_read_backwards =
                            IF bid_update THEN
                              FOR i := 1 TO data_transfers + 1 DO
                                iop$update_bid_window;
                              FOREND;
                            IFEND;
                            IF ((device_status.false_eop) OR (device_status.false_gap_bypassed) OR
                                  (device_status.noise_bypassed)) AND NOT (bid_recovery) THEN
                              iop$tape_reposition_f (p_tape_request, status);
                            ELSE
                              p_tape_request^.io_status.normal_completion := TRUE;
                              p_tape_request^.io_status.io_complete := TRUE;
                              IF (p_tape_request^.no_of_non_data_commands = 1) OR
                                    (commands_executed = p_tape_request^.no_of_non_data_commands) THEN

{ Do not attempt iop$tape_retry_io if the number of original backspaces has been completed.

                                EXIT /tape_parity_error_loop/;
                              ELSE

{ Decrement number of original commands by 1 to account for the block which encountered the parity
{ error.  iop$tape_retry_io must be called to complete the original number of backspaces.

                                p_tape_request^.no_of_non_data_commands :=
                                      p_tape_request^.no_of_non_data_commands - 1;
                              IFEND;
                            IFEND;
                          = ioc$tape_erase =
                            IF device_status.erase_current_failure THEN
                              p_tape_request^.io_status.completion_code := ioc$unit_failure;
                            ELSE
                              p_tape_request^.io_status.normal_completion := TRUE;
                            IFEND;
                            p_tape_request^.io_status.io_complete := TRUE;
                            EXIT /tape_parity_error_loop/
                          ELSE
                            p_tape_request^.io_status.io_complete := TRUE;
                            p_tape_request^.io_status.completion_code := ioc$unit_failure;
                            EXIT /tape_parity_error_loop/
                          CASEND;
                          IF NOT status.normal THEN
                            RETURN;
                          IFEND;

                          IF p_tape_request^.io_status.io_complete AND
                             NOT p_tape_request^.io_status.normal_completion AND
                             NOT (p_tape_request^.io_status.completion_code = ioc$tapemark_read) THEN

{                           Reposition failed.
{                           Exit with io_status returned from reposition.
                            EXIT /response_code_case/
                          ELSE
                            IF (p_tape_request^.request_type = ioc$tape_write) OR
                               (p_tape_request^.request_type = ioc$tape_write_tapemark) THEN

                              erasures := p_tape_request^.parity_retry_count;

                              FOR i := 1 TO erasures DO
                                logical_unit := p_tape_request^.request.logical_unit;
                                iop$67x_non_data_trans_setup (logical_unit, ioc$tape_erase, repeat_count,
                                      disable_unit, physical_unload, rio_id, rstatus);
                                IF NOT rstatus.normal THEN

{                                 Set position_uncertain to TRUE.

                                  p_tape_request^.io_status.position_uncertain := TRUE;

                                  EXIT /tape_parity_error_loop_2/
                                ELSE
                                  iop$tape_internal_request_stat (logical_unit, rio_id, {buf_release}
                                        TRUE, {bid_recovery} TRUE, bid_update, osc$wait, rio_status, rstatus);
                                  IF (NOT rstatus.normal) OR (NOT rio_status.normal_completion) THEN

{                                   Set position_uncertain to TRUE.

                                    rio_status.position_uncertain := TRUE;
                                    p_tape_request^.io_status := rio_status;

                                    EXIT /tape_parity_error_loop_2/
                                  IFEND;
                                IFEND;
                              FOREND;
                            IFEND;
                            iop$tape_retry_io (p_tape_request, bid_recovery, bid_update, status);

{ Exit with io_status returned from retrying the io operation.

                            EXIT /response_code_case/
                          IFEND;
                        IFEND;
                      END /tape_parity_error_loop_2/;
                        IF (p_tape_request^.request_type = ioc$tape_read) OR
                            (p_tape_request^.request_type = ioc$tape_forspace) THEN
                          iop$update_bid_window;
                        IFEND;
                        p_tape_request^.io_status.io_complete := TRUE;
                        p_tape_request^.io_status.completion_code := ioc$tape_medium_failure;
                      END /tape_parity_error_loop/;

                    ELSE

                      p_tape_request^.io_status.io_complete := TRUE;
                      p_tape_request^.io_status.completion_code := ioc$unit_failure;

                    IFEND;
                  IFEND;

                = 1, 3 =
{                 1 - Tape unit off_line, powered off or not cabled to controller.
{                 3 - Tape unit access switch in off position for this controller.
{                     Display a 'UNIT OFF-LINE' message on the operator console.

                  p_tape_request^.io_status.normal_completion := FALSE;
                  p_tape_request^.io_status.completion_code := ioc$unit_failure;
                  p_tape_request^.io_status.position_uncertain := TRUE;

                = 2 =
{                 2 - Tape unit already connected to another controller.

                  p_tape_request^.io_status.completion_code := ioc$unit_reserved;

                = 4, 5 =
{                 4 - Tape unit not ready.
{                 5 - Tape unit declared not ready during last operation.
{                     Display a 'UNIT NOT READY' message on the operator console.

                  IF (p_tape_request^.request_type = ioc$tape_get_status) OR
                        (p_tape_request^.request_type = ioc$tape_unload) THEN
                    p_tape_request^.io_status.normal_completion := TRUE;
                    p_tape_request^.io_status.unit_ready := FALSE;
                  ELSE
                    p_tape_request^.io_status.normal_completion := FALSE;
                    p_tape_request^.io_status.completion_code := ioc$unit_failure;
                    p_tape_request^.io_status.position_uncertain := TRUE;
                  IFEND;

                = 6 =
{                 6 - Missing write ring.
{                     Return an error status to the requestor.

                  p_tape_request^.io_status.io_complete := TRUE;
                  p_tape_request^.io_status.completion_code := ioc$no_write_ring;

                = 7 =
{                 7 - Unit not capable of reading density in which the tape is recorded.
{                     Send an error status to the requestor.

                  p_tape_request^.io_status.io_complete := TRUE;
                  p_tape_request^.io_status.completion_code := ioc$not_capable_of_density;

                = 8 =
{                 10(8) - More than 25 feet of blank tape.
{                         Send an error status to the requestor.

                  p_tape_request^.io_status.io_complete := TRUE;
                  p_tape_request^.io_status.completion_code := ioc$blank_tape;

                = 10, 11, 14 =
{                 12(8) - Unable to detect ID burst immediately after writing it.
{                 13(8) - Tape unit AGC could not be set properly on this tape.
{                 16(8) - The tape unit AGC cound not be set in all tracks.
{                 These errors will be retried 2 more times and if it still occurs,
{                 bad status will be returned to the caller, except for an error
{                 code of 14 when write_ring status is FALSE (allow reading).

                    logical_unit := p_tape_request^.request.logical_unit;

                  /bad_id_burst_recovery_loop/
                  BEGIN
                    IF p_tape_request^.misc_retry_count < ioc$tape_max_misc_retry THEN
                      p_tape_request^.misc_retry_count := p_tape_request^.misc_retry_count + 1;
                      rstatus.normal := TRUE;
                      iop$67x_non_data_trans_setup (logical_unit, ioc$tape_rewind, repeat_count,
                             disable_unit, physical_unload, rio_id, rstatus);
                      IF NOT rstatus.normal THEN
                        EXIT /bad_id_burst_recovery_loop/
                      ELSE
                        iop$tape_internal_request_stat (logical_unit, rio_id, {buf_release} TRUE,
                              {bid_recovery} TRUE, bid_update, osc$wait, rio_status, rstatus);
                        IF (NOT rstatus.normal) OR (NOT rio_status.normal_completion) THEN
                          p_tape_request^.io_status := rio_status;
                          EXIT /bad_id_burst_recovery_loop/
                        IFEND;
                      IFEND;
                      iop$tape_retry_io (p_tape_request, bid_recovery, bid_update, status);

{ Exit with io_status returned from retrying the io operation.

                      EXIT /response_code_case/
                    IFEND;
                  END /bad_id_burst_recovery_loop/;

{ Allow error code 16(8) to be accepted for normal completion if the write ring status is FALSE.
{ The tape may be readable, but we do not want the file extended by writing to the tape when the
{ tape unit AGC is not set properly in all tracks.

                    IF (device_status.error_code = 14) AND NOT (device_status.write_ring) THEN

{ Place an error bid indicator in the Bid_Window due to the block_id not being updated on a bad read and
{ set completion status to normal in an attempt to read the tape. An Engineering Log entry has been set up.

                      iop$update_bid_window;
                      p_tape_request^.io_status.normal_completion := TRUE;
                      p_tape_request^.io_status.io_complete := TRUE;
                      EXIT /response_code_case/
                    IFEND;

{ Rewind the tape and send error status to the requestor.

                    rstatus.normal := TRUE;
                    iop$67x_non_data_trans_setup (logical_unit, ioc$tape_rewind, repeat_count,
                           disable_unit, physical_unload, rio_id, rstatus);
                    iop$tape_internal_request_stat (logical_unit, rio_id, {buf_release} TRUE,
                          {bid_recovery} TRUE, bid_update, osc$wait, rio_status, rstatus);

                    p_tape_request^.io_status.io_complete := TRUE;
                    IF device_status.error_code = 10 THEN
                      p_tape_request^.io_status.completion_code := ioc$unable_to_write_id_burst;
                    ELSE

{ Error code at this point is 11 or 14. Case selector only set for 10, 11, 14 in this area.

                      p_tape_request^.io_status.completion_code := ioc$unable_to_set_agc;
                    IFEND;

                = 24 =
{                 30(8) - Backwards motion attempted at load point.
{                         Return load point status to the requestor.

                  p_tape_request^.io_status.io_complete := TRUE;
                  p_tape_request^.io_status.completion_code := ioc$load_point;

{                 Set BID window back to load point.

                  p_ud^.bid_index := LOWERVALUE(iot$bid_index) + 1;
                  bid_offset := LOWERVALUE(iot$bid_index);
                  p_ud^.bid_window [bid_offset] := ioc$loadpoint_bid;
                  FOR bid_offset := 2 TO UPPERBOUND(iot$bid_window) DO
                    p_ud^.bid_window [bid_offset] := ioc$empty_bid;
                  FOREND;

                = 25, 28 .. 30, 40 .. 42 =
{                 31(8) - non-existant tape unit requested.
{                 34(8) - controlled backspace attempted, but last
{                         function was not a write.
{                 35(8) - the controller is not capable of requested density.
{                 36(8) - write attempted at 200 CPI.
{                 50(8) - illegal function code.
{                 51(8) - the unit is not connected.
{                 52(8) - parameters were not issued.
{                 These errors indicate an error in the operating system or
{                 in the tape controller.

                  p_tape_request^.io_status.io_complete := TRUE;
                  p_tape_request^.io_status.completion_code := ioc$indeterminate;

                = 26 =
{                 32(8) - Unit busy rewinding or doing a data security erase.
{                         Retry the failing request until enough time has expired to
{                         insure that the unit should no longer be busy.

                /busy_loop/
                  BEGIN

                  IF (p_tape_request^.request_type = ioc$tape_rewind) OR
                     (p_tape_request^.request_type = ioc$tape_get_status) THEN
                    p_tape_request^.io_status.io_complete := TRUE;
                    p_tape_request^.io_status.normal_completion := TRUE;
                    p_tape_request^.io_status.unit_ready := TRUE;
                    p_tape_request^.io_status.unit_busy := TRUE;
                    EXIT /busy_loop/
                  IFEND;
                    IF p_tape_request^.busy_retry_count < (ioc$tape_max_busy_retry * 4) THEN
                      p_tape_request^.busy_retry_count := p_tape_request^.busy_retry_count + 1;
                      pmp$delay (ioc$tape_long_wait DIV 4, status);
                      IF NOT status.normal THEN
                        EXIT /busy_loop/
                      IFEND;
                      iop$tape_queue_request_setup (p_tape_request, status);
                      IF NOT status.normal THEN
                        EXIT /busy_loop/
                      ELSE
                        logical_unit := p_tape_request^.request.logical_unit;
                        rio_id := p_tape_request^.io_id;
                        iop$tape_internal_request_stat (logical_unit, rio_id, {buf_release} FALSE,
                              bid_recovery, bid_update, osc$wait, rio_status, rstatus);
                        p_tape_request^.io_status := rio_status;
                        EXIT /busy_loop/

                      IFEND;
                    IFEND;
                    p_tape_request^.io_status.io_complete := TRUE;
                    p_tape_request^.io_status.completion_code := ioc$unit_failure;
                  END /busy_loop/;

                = 32, 35..37, 39, 96, 99, 101 =
{                 40(8)  - if gap control status failed to occur within 270 mills.
{                 43(8)  - if erase or write current failed to occur when a write
{                          was requested.
{                 44(8)  - if stop command failed to work.
{                 45(8)  - if reverse status was still indicated after a forward
{                          signal was sent to the unit.
{                 47(8)  - if the tape unit would not select density on command.
{                 140(8) - if tape unit failed to execute a data security erase.
{                 143(8) - if write current failed to turn off for a read operation.
{                 145(8) - if forward status was still indicated after a reverse
{                          signal was sent to the unit.

                  p_tape_request^.io_status.io_complete := TRUE;
                  p_tape_request^.io_status.completion_code := ioc$unit_failure;

{                 Set position_uncertain to TRUE.

                  p_tape_request^.io_status.position_uncertain := TRUE;

                = 45 =
{                 55(8) - Channel parity error during function transmission.
{                         Retry 6 times.
{                 Note, if dual controller the odds are that at least one retry
{                 will occur on the other controller because both
{                 controllers share the same unit queues, but this is not
{                 guaranteed.

                    IF p_tape_request^.parity_retry_count < ioc$tape_max_chan_parity_retry THEN
                      p_tape_request^.parity_retry_count := p_tape_request^.parity_retry_count + 1;
                      iop$tape_retry_io (p_tape_request, bid_recovery, bid_update, status);

{ Exit with io_status returned from retrying the io operation.

                      EXIT /response_code_case/
                    IFEND;
                    p_tape_request^.io_status.io_complete := TRUE;
                    p_tape_request^.io_status.completion_code := ioc$output_channel_parity;

                = 33, 34, 38, 49, 50 =
{                 41(8)  - if velocity failed to reach 95 percent of rated speed
{                          within 270 mills.
{                 42(8)  - if unit failed to move the tape when tape movement was
{                          requested.
{                 46(8)  - if no data was detected in the read_after_write.
{                 61(8) - if late acknowledge.
{                 62(8) - if ppu was not ready to receive data for a read.
{                         Reposition and retry 6 times.
{                 ***** Note check for late ack on 1st word, otherwise block could
{                 be lost by repositioning over previous block and doing retry.

                /late_loop/
                  BEGIN

                    IF p_tape_request^.lateack_retry_count < ioc$tape_max_lateack_retry THEN
                      p_tape_request^.lateack_retry_count := p_tape_request^.lateack_retry_count + 1;
                      CASE p_tape_request^.request_type OF
                      = ioc$tape_read, ioc$tape_write =
                        iop$tape_reposition_b (p_tape_request, status);
                      = ioc$tape_read_backwards, ioc$tape_backspace =
                        IF bid_update THEN
                          FOR i := 1 TO data_transfers + 1 DO
                            iop$update_bid_window;
                          FOREND;
                        IFEND;
                        IF NOT bid_recovery THEN
                          iop$tape_reposition_f (p_tape_request, status);
                        ELSE
                          p_tape_request^.io_status.io_complete := TRUE;
                          p_tape_request^.io_status.normal_completion := TRUE;
                          EXIT /response_code_case/
                        IFEND;
                      ELSE
                        p_tape_request^.io_status.io_complete := TRUE;
                        p_tape_request^.io_status.completion_code := ioc$unit_failure;
                        EXIT /late_loop/
                      CASEND;
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                      IF p_tape_request^.io_status.io_complete AND
                         NOT p_tape_request^.io_status.normal_completion AND
                         NOT (p_tape_request^.io_status.completion_code = ioc$tapemark_read) THEN

{                       Reposition failed.
{                       Exit with io_status returned from reposition.
                        EXIT /response_code_case/
                      ELSE
                        iop$tape_retry_io (p_tape_request, bid_recovery, bid_update, status);

{ Exit with io_status returned from retrying the io operation.

                        EXIT /response_code_case/
                      IFEND;
                    IFEND;
                    p_tape_request^.io_status.io_complete := TRUE;
                    p_tape_request^.io_status.completion_code := ioc$unit_failure;
                  END /late_loop/;

                = 52 =
{                 64(8) - The channel was hung active and empty following a
{                         load or copy code table operation.

                    p_tape_request^.io_status.io_complete := TRUE;
                    p_tape_request^.io_status.completion_code := ioc$controller_failure;

                = 53 =
{                 65(8) - The channel was hung active and full during a status function.

                  p_tape_request^.io_status.io_complete := TRUE;
                  p_tape_request^.io_status.completion_code := ioc$controller_failure;

                = 56 =
{                 70(8) - The control unit detected an internal failure while
{                         executing the internal diagnostics following a master clear.

                  p_tape_request^.io_status.io_complete := TRUE;
                  p_tape_request^.io_status.completion_code := ioc$controller_failure;

                = 72, 81, 108 .. 114, 116, 117, 120 .. 127 =
{                 110(8), 121(8), 154(8) - 162(8), 164(8), 165(8), 170(8) - 177(8) are error
{                   codes returned only for 698_3x units and indicate a CCC internal error.
{                   The operation will be retried 3 times before declaring a fatal error.

                  IF p_tape_request^.misc_retry_count < ioc$tape_max_misc_retry THEN
                        p_tape_request^.misc_retry_count := p_tape_request^.misc_retry_count + 1;
                    IF commands_executed <> 0 THEN
                      CASE p_tape_request^.request_type OF
                      = ioc$tape_read, ioc$tape_write, ioc$tape_write_tapemark =
                        iop$tape_reposition_b (p_tape_request, status);
                      = ioc$tape_forspace =
                        IF bid_update THEN
                          iop$tape_reposition_b (p_tape_request, status);
                        ELSE
                          iop$update_bid_window;
                          p_tape_request^.io_status.io_complete := TRUE;
                          p_tape_request^.io_status.normal_completion := TRUE;
                          EXIT /response_code_case/
                        IFEND;
                      = ioc$tape_read_backwards, ioc$tape_backspace =
                        IF bid_update THEN
                          FOR i := 1 TO data_transfers + 1 DO
                            iop$update_bid_window;
                          FOREND;
                        IFEND;
                        IF NOT bid_recovery THEN
                          iop$tape_reposition_f (p_tape_request, status);
                        ELSE
                          p_tape_request^.io_status.io_complete := TRUE;
                          p_tape_request^.io_status.normal_completion := TRUE;
                          EXIT /response_code_case/
                        IFEND;
                      ELSE
                        p_tape_request^.io_status.io_complete := TRUE;
                        p_tape_request^.io_status.completion_code := ioc$controller_failure;
                        EXIT /response_code_case/
                      CASEND;
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                      IF p_tape_request^.io_status.io_complete AND
                         NOT p_tape_request^.io_status.normal_completion AND
                         NOT (p_tape_request^.io_status.completion_code = ioc$tapemark_read) THEN

{                     Reposition failed.
{                     Exit with io_status returned from reposition.
                      EXIT /response_code_case/
                      IFEND;
                    IFEND;
                    iop$tape_retry_io (p_tape_request, bid_recovery, bid_update, status);

{ Exit with io_status returned from retrying the io operation.

                    EXIT /response_code_case/
                  IFEND;
                  p_tape_request^.io_status.io_complete := TRUE;
                  p_tape_request^.io_status.completion_code := ioc$controller_failure;

                ELSE

{                 Undefined error code.

                  p_tape_request^.io_status.io_complete := TRUE;
                  p_tape_request^.io_status.normal_completion := FALSE;
                  p_tape_request^.io_status.completion_code := ioc$indeterminate;
                CASEND;

            IFEND;
          IFEND;
        END /response_code_case/;

{       Only the last occurence of an unrecovered error will be logged; the intial logging
{       has been done  before. The  status on  recovered  errors will be logged elsewhere.
{       Some recovery operations although terminated abnormally might have been changed to
{       normal completion during status examination.

        IF (NOT p_tape_request^.io_status.normal_completion) AND
           (p_tape_request^.io_status.completion_code <> ioc$tapemark_read) AND
           p_ud^.tape_error_log_entry THEN

          tape_failure_type := ioc$unrecovered;
          IF p_ud^.controller_type = cmc$mt5698_xx THEN
            iop$tape_error_logging_ipi (p_tape_request, tape_failure_type, status);
          ELSEIF p_ud^.controller_type = cmc$mt5680_xx THEN
            ;
          ELSE { ats, ismt or 698
            iop$tape_error_logging (p_tape_request, tape_failure_type, {*IM*} FALSE, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{         Set tape_error_log_entry to FALSE and initialize the block_in_error entry in the
{         unit_descriptor.

          p_ud^.tape_error_log_entry := FALSE;
          p_ud^.block_in_error := -1;

{         Position the tape for a write or write_tapemark operation before the last
{         good block:  only if no position uncertain was encountered.

          IF ((p_tape_request^.request_type = ioc$tape_write) OR
             (p_tape_request^.request_type = ioc$tape_write_tapemark)) AND
             (NOT inhibit_recovery_occurred) AND
             (NOT p_tape_request^.io_status.position_uncertain) THEN

{           Save the last (unrecovered) status before executing
{           the backwards reposition operation.

            rio_status := p_tape_request^.io_status;

            iop$tape_reposition_b (p_tape_request, status);
            IF p_tape_request^.io_status.io_complete AND
               (NOT p_tape_request^.io_status.normal_completion) AND NOT
               (p_tape_request^.io_status.completion_code = ioc$tapemark_read) THEN

{             Reposition failed.

              rio_status.position_uncertain := TRUE;
            IFEND;

{           Restore the unrecovered status for further examination by the caller,
{           keep the end_of_tape indication current.

            rio_status.end_of_tape := p_tape_request^.io_status.end_of_tape;
            p_tape_request^.io_status := rio_status;
          IFEND;

        ELSEIF (p_ud^.controller_type <> cmc$mt5698_xx) AND p_ud^.tape_error_log_entry AND
              ((p_tape_request^.io_status.completion_code = ioc$tapemark_read) OR
              (p_tape_request^.io_status.completion_code = ioc$alert_condition_encountered) OR
              (p_tape_request^.io_status.normal_completion AND pp_response.alert_conditions.
              physical_delimiter)) AND NOT bid_recovery THEN
          iop$tape_error_logging (p_tape_request, ioc$recovered, {*IM*} FALSE, status);
          p_ud^.tape_error_log_entry := FALSE;

        IFEND;

      CASEND;

    END;

  PROCEND iop$tape_status_check;
?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_status_check_ccc_cart ' ??
?? EJECT ??

  PROCEDURE iop$tape_status_check_ccc_cart (bid_recovery: boolean;
        bid_update: boolean;
        commands_executed: iot$tape_request_length;
        data_transfers: iot$tape_request_length;
        previous_last_good_bid: iot$cartridge_tape_bid;
    VAR p_tape_request: ^iot$tape_request;
    VAR status: ost$status);

    CONST
      disable_unit = FALSE,
      physical_unload = FALSE,
      repeat_count = 1;

    VAR
      bid_offset: iot$bid_index,
      device_status: iot$ccc_cart_device_status,
      erasures: 1 .. ioc$tape_max_tape_parity_retry,
      error_id: iot$ccc_cart_error_id,
      i: integer,
      inhibit_recovery_occurred: boolean,
      io_id: iot$io_id,
      logical_unit: iot$logical_unit,
      p_ud: ^iot$tape_job_unit_descriptor,
      pp_response: iot$pp_response,
      rio_id: iot$io_id,
      rio_status: iot$tape_io_status,
      rstatus: ost$status,
      sense_bytes: iot$ccc_cart_sense_bytes;

    status.normal := TRUE;
    inhibit_recovery_occurred := FALSE;

    pp_response := p_tape_request^.pp_response_p^.pp_response;
    logical_unit := p_tape_request^.request.logical_unit;
    p_ud := p_tape_request^.ud;

    device_status := p_tape_request^.pp_response_p^.ccc_cart_device_status;

{ Initialize io_status. Some of the values may be changed as status is analyzed.

    p_tape_request^.io_status.normal_completion := FALSE;
    p_tape_request^.io_status.unit_busy := device_status.busy;
    p_tape_request^.io_status.long_input_block := FALSE;
    p_tape_request^.io_status.position_uncertain := FALSE;
    p_tape_request^.io_status.unit_ready := device_status.ready;
    p_tape_request^.io_status.write_ring := device_status.write_enabled;
    p_tape_request^.io_status.end_of_tape := device_status.end_of_tape;
    p_tape_request^.io_status.beginning_of_tape := device_status.beginning_of_tape;
    p_tape_request^.io_status.unit_density := rmc$38000;

    IF pp_response.abnormal_status.forced_termination OR
          pp_response.abnormal_status.channel_error OR
          pp_response.abnormal_status.data_overrun OR
          pp_response.abnormal_status.recording_medium_error OR
          pp_response.abnormal_status.intervention_required OR
          pp_response.abnormal_status.function_timeout OR
          pp_response.abnormal_status.output_channel_parity THEN

{ Error, since ccc cartridge tape pp driver should never set these conditions.

      iop$tape_pp_error (p_tape_request, status);
      IF device_status.error_id = ioc$ccc_cart_no_pp_eid THEN
        p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_ill_abn_status;
      IFEND;
      iop$tape_error_logging_ccc_cart (p_tape_request, ioc$unrecovered, status);
      RETURN;
    IFEND;

    IF pp_response.abnormal_status.interface_error THEN
      iop$tape_pp_error (p_tape_request, status);
      iop$tape_error_logging_ccc_cart (p_tape_request, ioc$unrecovered, status);
      RETURN;
    IFEND;

    IF device_status.error_id = ioc$ccc_cart_no_pp_eid THEN { PP did not diagnose error
      p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_indeterminate;

      IF NOT pp_response.abnormal_status.hardware_malfunction THEN  {must be alert condition only

        IF pp_response.abnormal_status.abnormal_alert THEN
          IF pp_response.alert_conditions.logical_delimiter THEN
            p_tape_request^.io_status.completion_code := ioc$tapemark_read;

          ELSEIF pp_response.alert_conditions.physical_delimiter THEN

{ End of tape has been encountered.  Increment
{ blocks_accessed to indicate block is written to tape.

            p_tape_request^.blocks_accessed := p_tape_request^.blocks_accessed + 1;
            p_tape_request^.io_status.end_of_tape := TRUE;
            p_tape_request^.io_status.normal_completion := TRUE;

          ELSEIF pp_response.alert_conditions.long_input_block THEN
            p_tape_request^.io_status.long_input_block := TRUE;
            p_tape_request^.io_status.completion_code := ioc$alert_condition_encountered;

          ELSE {no alert condition set
            p_tape_request^.io_status.completion_code := ioc$system_software_failure;
            p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_no_alert;
            iop$tape_error_logging_ccc_cart (p_tape_request, ioc$unrecovered, status);
            RETURN;
          IFEND;

          IF NOT bid_recovery AND (p_ud^.tape_error_log_entry = TRUE) THEN
            iop$tape_error_logging_ccc_cart (p_tape_request, ioc$recovered, status);
            p_ud^.tape_error_log_entry := FALSE;
          IFEND;

          RETURN; {<----------

        ELSE { software error, no bits set in abnormal_status
          p_tape_request^.io_status.completion_code := ioc$system_software_failure;
          p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_no_abn_status;
          iop$tape_error_logging_ccc_cart (p_tape_request, ioc$unrecovered, status);
          RETURN;
        IFEND;

      ELSE {hardware malfunction is set

{ If a hardware or media error occurred and no successful tape motion was done and
{ error_block_forespace_count is not zero, it means that successive error blocks have
{ occurred.  In this case, the last_good_block_id must be reset to what is was prior
{ to the request.  This is done since locate_block to an error block cannot be done.

        IF NOT bid_recovery AND (p_ud^.error_block_forespace_count <> 0) THEN
          IF data_transfers = 0 THEN
            CASE p_tape_request^.request_type OF

            = ioc$tape_read, ioc$tape_forspace, ioc$skip_tapemark_forward, ioc$tape_write,
              ioc$tape_write_tapemark, ioc$tape_backspace, ioc$skip_tapemark_backward =

                p_ud^.cartridge_tape_last_good_bid := previous_last_good_bid;

            ELSE
            CASEND;

          ELSE

            IF (p_tape_request^.request_type = ioc$tape_backspace) THEN
              IF data_transfers < p_ud^.error_block_forespace_count THEN
                p_ud^.cartridge_tape_last_good_bid := previous_last_good_bid;
                p_ud^.error_block_forespace_count := p_ud^.error_block_forespace_count - data_transfers;
              ELSE
                p_ud^.error_block_forespace_count := 0;
              IFEND;
            ELSE
              p_ud^.error_block_forespace_count := 0;
            IFEND;
          IFEND;
        IFEND;

{ Handle conditions that do not require logging or recovery.

        IF ((device_status.error_code = 4) OR (device_status.error_code = 5)) AND
              ((p_tape_request^.request_type = ioc$tape_get_status) OR
              (p_tape_request^.request_type = ioc$tape_unload)) THEN
          p_tape_request^.io_status.unit_ready := FALSE;
          p_tape_request^.io_status.normal_completion := TRUE;
          IF p_ud^.tape_error_log_entry THEN { log as recovered
            iop$tape_error_logging_ccc_cart (p_tape_request, ioc$recovered, status);
          IFEND;
          RETURN;
        IFEND;

        IF device_status.error_code = 30(8) THEN
          p_tape_request^.io_status.beginning_of_tape := TRUE;
          p_tape_request^.io_status.completion_code := ioc$load_point;
          p_ud^.cartridge_tape_last_good_bid := zero_ccc_cart_bid;
          p_ud^.error_block_forespace_count := 0;
          RETURN;
        IFEND;

        IF device_status.error_code = 3 THEN
          IF (p_tape_request^.request_type = ioc$tape_write) OR (p_tape_request^.request_type =
                ioc$tape_write_tapemark) OR (p_tape_request^.request_type = ioc$tape_erase) THEN
            p_tape_request^.io_status.completion_code := ioc$write_past_phys_eot;
          ELSE
            p_tape_request^.io_status.completion_code := ioc$read_past_phys_eot;
          IFEND;
          RETURN;
        IFEND;

        IF device_status.error_code = 10(8) THEN
          p_tape_request^.io_status.completion_code := ioc$blank_tape;
          RETURN;
        IFEND;

        IF device_status.error_code = 6 THEN
          p_tape_request^.io_status.completion_code := ioc$no_write_ring;
          RETURN;
        IFEND;

        IF device_status.error_code = 32(8) THEN
          IF (p_tape_request^.request_type = ioc$tape_rewind) OR
                (p_tape_request^.request_type = ioc$tape_get_status) THEN
            p_tape_request^.io_status.normal_completion := TRUE;
            p_tape_request^.io_status.unit_ready := TRUE;
            p_tape_request^.io_status.unit_busy := TRUE;
            RETURN;
          IFEND;
        IFEND;

{ Conditions starting here require logging and most require retry.
{ The purpose of the following code (up to error logging) is to determine
{ and set error_id in ccc_cart_device_status.

      /determine_error_id/
        BEGIN

        IF device_status.error_code = 1 THEN
          p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_unit_failure;
          EXIT /determine_error_id/;
        ELSEIF (device_status.error_code = 4) OR (device_status.error_code = 5) THEN
          p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_unit_not_ready;
          EXIT /determine_error_id/;
        ELSEIF device_status.error_code = 7 THEN
          p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_read_id_mark;
          EXIT /determine_error_id/;
        ELSEIF device_status.error_code = 12(8) THEN
          p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_write_id_mark;
          EXIT /determine_error_id/;
        ELSEIF (device_status.error_code = 32(8)) OR (device_status.error_code = 33(8)) THEN
          p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_cu_failure;
          EXIT /determine_error_id/;
        IFEND;

        IF device_status.adapter_check THEN
          IF device_status.error_code = 172(8) THEN
            p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_output_chan_par;
          ELSE
            p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_coupler_failure;
          IFEND;
          EXIT /determine_error_id/;
        IFEND;

        IF device_status.unit_check THEN  { If get this far, unit_check SHOULD be set
          sense_bytes := p_tape_request^.pp_response_p^.ccc_cart_sense_bytes;
          IF sense_bytes.erpa_code <> 0 THEN  { ERPA code in sense bytes SHOULD be set
            IF sense_bytes.erpa_code = 21(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_coupler_failure;
            ELSEIF sense_bytes.erpa_code = 22(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_cu_failure;
            ELSEIF sense_bytes.erpa_code = 23(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_tape_medium;
            ELSEIF sense_bytes.erpa_code = 24(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_cu_failure;
            ELSEIF sense_bytes.erpa_code = 25(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_tape_medium;
            ELSEIF sense_bytes.erpa_code = 26(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_tape_medium;
            ELSEIF sense_bytes.erpa_code = 27(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_coupler_failure;
            ELSEIF sense_bytes.erpa_code = 2c(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_cu_failure;
            ELSEIF sense_bytes.erpa_code = 2d(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_unit_failure;
            ELSEIF sense_bytes.erpa_code = 32(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_unit_failure;
            ELSEIF sense_bytes.erpa_code = 33(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_unit_failure;
            ELSEIF sense_bytes.erpa_code = 34(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_unit_failure;
            ELSEIF sense_bytes.erpa_code = 35(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_unit_failure;
            ELSEIF sense_bytes.erpa_code = 36(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_cu_failure;
            ELSEIF sense_bytes.erpa_code = 37(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_tape_medium;
            ELSEIF sense_bytes.erpa_code = 3a(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_unit_not_ready;
            ELSEIF sense_bytes.erpa_code = 3b(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_unit_not_ready;
            ELSEIF sense_bytes.erpa_code = 40(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_coupler_failure;
            ELSEIF sense_bytes.erpa_code = 41(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_invalid_bid;
            ELSEIF sense_bytes.erpa_code = 42(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_cu_failure;
            ELSEIF sense_bytes.erpa_code = 43(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_unit_not_ready;
            ELSEIF sense_bytes.erpa_code = 44(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_invalid_bid;
            ELSEIF sense_bytes.erpa_code = 45(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_cu_failure;
            ELSEIF sense_bytes.erpa_code = 47(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_cu_failure;
            ELSEIF sense_bytes.erpa_code = 49(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_output_chan_par;
            ELSEIF sense_bytes.erpa_code = 4a(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_cu_failure;
            ELSEIF sense_bytes.erpa_code = 4b(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_unit_failure;
            ELSEIF sense_bytes.erpa_code = 4c(16) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_cu_failure;
            IFEND;

          IFEND; { erpa_code <> 0
        IFEND; { device_status.unit_check

        END /determine_error_id/;

      IFEND; { hardware_malfunction check

    IFEND; { error_id = ioc$ccc_cart_no_pp_eid

    IF p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id = ioc$ccc_cart_indeterminate_par THEN
      IF pp_response.response_length > ioc$min_ccc_cart_resp_size THEN
        IF p_tape_request^.pp_response_p^.ccc_cart_sense_bytes.erpa_code = 49(16) THEN
          p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_iou_parity;
        IFEND;
      IFEND;
    IFEND;

{ Log the error in the engineering log.
{ Error_id in p_tape_requests should not be ioc$ccc_cart_indeterminate.  IF it is
{ there is some condition that should be covered in the above /determine_error_id/ block.


    error_id := p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id;

{ Check whether a log entry is outstanding.  Do not log errors if in recovery.

    IF NOT bid_recovery THEN
      IF NOT p_ud^.tape_error_log_entry THEN
        IF (error_id = ioc$ccc_cart_unit_not_ready) OR
              (error_id = ioc$ccc_cart_unit_failure) OR
              (error_id = ioc$ccc_cart_write_id_mark) OR
              (error_id = ioc$ccc_cart_read_id_mark) OR
              (error_id = ioc$ccc_cart_invalid_bid) THEN
          iop$tape_error_logging_ccc_cart (p_tape_request, ioc$unrecovered, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          iop$tape_error_logging_ccc_cart (p_tape_request, ioc$intermediate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Set tape_error_log_entry to TRUE and save the block number for the block_in_error.

          p_ud^.tape_error_log_entry := TRUE;
          p_ud^.block_in_error := p_tape_request^.blocks_accessed;
        IFEND;

      ELSE
        IF p_tape_request^.blocks_accessed <> p_ud^.block_in_error THEN

{ Finalize the outstanding error log entry, which has been recovered.

          iop$tape_error_logging_ccc_cart (p_tape_request, ioc$recovered, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Clear the retry counters before attempting to recover the next failure.

          p_tape_request^.parity_retry_count := 0;
          p_tape_request^.misc_retry_count := 0;
          p_tape_request^.busy_retry_count := 0;

{ Make an initial log entry for the next failure.

          IF (error_id = ioc$ccc_cart_unit_not_ready) OR
                (error_id = ioc$ccc_cart_unit_failure) OR
                (error_id = ioc$ccc_cart_write_id_mark) OR
                (error_id = ioc$ccc_cart_read_id_mark) OR
                (error_id = ioc$ccc_cart_invalid_bid) THEN
            iop$tape_error_logging_ccc_cart (p_tape_request, ioc$unrecovered, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSE
            iop$tape_error_logging_ccc_cart (p_tape_request, ioc$intermediate, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

{ Save the block_in _error, tape_error_log_entry is already set to TRUE.

            p_ud^.block_in_error := p_tape_request^.blocks_accessed;
          IFEND;

        IFEND;
      IFEND;
    IFEND;  { bid_recovery check

{ Attempt retry based on what type of error condition was encountered.
{ Some errors are not retried here because the CU has already attempted recovery.

    CASE error_id OF

    = ioc$ccc_cart_unit_not_ready, ioc$ccc_cart_unit_failure =
      p_tape_request^.io_status.completion_code := ioc$unit_failure;

    = ioc$ccc_cart_write_id_mark, ioc$ccc_cart_read_id_mark =
      IF error_id = ioc$ccc_cart_write_id_mark THEN
        p_tape_request^.io_status.completion_code := ioc$unable_to_write_id_burst;
      ELSE
        p_tape_request^.io_status.completion_code := ioc$unable_to_set_agc;
      IFEND;

{ Currently do not retry erpa codes 41(16) and 44(16).  If the operation was not
{ a read, write or forespace, return ioc$indeterminate along with position_uncertain
{ in io_status.  If the operation is a read, write or forespace attempt to locate
{ to last good block and perform 1 forespace.  If this is successful, return
{ tape_medium_failure, else return ioc$indeterminate.

    = ioc$ccc_cart_invalid_bid =

      IF NOT bid_recovery AND ((p_tape_request^.request_type = ioc$tape_read) OR
            (p_tape_request^.request_type = ioc$tape_write) OR
            (p_tape_request^.request_type = ioc$tape_forspace)) THEN
        p_ud^.cartridge_tape_last_good_bid.logical_position :=
              p_ud^.cartridge_tape_last_good_bid.logical_position + data_transfers;
        p_ud^.error_block_forespace_count := p_ud^.error_block_forespace_count + 1;
        iop$locate_block (logical_unit, p_ud^.cartridge_tape_last_good_bid, {bid_recovery} TRUE,
              0, ioc$lbg_plus_count, rio_status, rstatus);
        IF NOT rstatus.normal OR (NOT rio_status.normal_completion AND (rio_status.completion_code <>
              ioc$tapemark_read)) THEN
          p_ud^.error_block_forespace_count := p_ud^.error_block_forespace_count - 1;
          p_tape_request^.io_status.position_uncertain := TRUE;
          p_tape_request^.io_status.completion_code := ioc$indeterminate;
        ELSE

{ Reposition was successful, return tape medium failure.

          p_tape_request^.io_status.completion_code := ioc$tape_medium_failure;
          p_tape_request^.io_status.position_uncertain := TRUE;
        IFEND;

      ELSE
        p_tape_request^.io_status.completion_code := ioc$indeterminate;
        p_tape_request^.io_status.position_uncertain := TRUE;
      IFEND;

    = ioc$ccc_cart_tape_medium =

    /tape_parity_error_loop/
      BEGIN

        IF p_tape_request^.inhibit_error_recovery AND NOT bid_recovery THEN
          IF p_tape_request^.request_type = ioc$tape_write THEN
            p_tape_request^.blocks_accessed := p_tape_request^.blocks_accessed + 1;
          IFEND;
          inhibit_recovery_occurred := TRUE;
          p_tape_request^.io_status.io_complete := TRUE;
          p_tape_request^.io_status.completion_code := ioc$tape_medium_failure;

{ If unrecovered medium error and inhibit error recovery = TRUE, attempt
{ to position after the bad block by first positioning to last good block and then performing a
{ forespace. The forespace count if incremented first to account for the bad block.

          p_ud^.error_block_forespace_count := p_ud^.error_block_forespace_count + 1;
          iop$locate_block (logical_unit, p_ud^.cartridge_tape_last_good_bid, {bid_recovery} TRUE,
                0, ioc$lbg_plus_count, rio_status, rstatus);
          IF NOT rstatus.normal OR (NOT rio_status.normal_completion AND (rio_status.completion_code <>
                ioc$tapemark_read)) THEN
            p_ud^.error_block_forespace_count := p_ud^.error_block_forespace_count - 1;
            p_tape_request^.io_status.position_uncertain := TRUE;
          IFEND;

          EXIT /tape_parity_error_loop/
        IFEND;

        IF p_tape_request^.pp_response_p^.ccc_cart_sense_bytes.drive_in_sync_mode THEN { attempt recovery
          IF p_tape_request^.parity_retry_count < ioc$tape_max_tape_parity_retry THEN
            p_tape_request^.parity_retry_count := p_tape_request^.parity_retry_count + 1;
            CASE p_tape_request^.request_type OF
            = ioc$tape_read, ioc$tape_write, ioc$tape_write_tapemark, ioc$tape_forspace,
              ioc$tape_backspace, ioc$locate_block =

              iop$locate_block (logical_unit, p_ud^.cartridge_tape_last_good_bid, {bid_recovery} TRUE,
                    0, ioc$lbg_plus_count, rio_status, status);

            ELSE

              p_tape_request^.io_status.completion_code := ioc$unit_failure;
              EXIT /tape_parity_error_loop/

            CASEND;

            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF rio_status.io_complete AND
                  NOT rio_status.normal_completion AND
                  NOT (rio_status.completion_code = ioc$tapemark_read) THEN

{ Reposition failed.
{ Exit with io_status returned from reposition.

              p_tape_request^.io_status := rio_status;
              EXIT /tape_parity_error_loop/
            ELSE
              IF (p_tape_request^.request_type = ioc$tape_write) OR
                    (p_tape_request^.request_type = ioc$tape_write_tapemark) THEN

                erasures := p_tape_request^.parity_retry_count;

                FOR i := 1 TO erasures DO
                  iop$67x_non_data_trans_setup (logical_unit, ioc$tape_erase, repeat_count,
                        disable_unit, physical_unload, rio_id, rstatus);
                  IF NOT rstatus.normal THEN

{ Set position_uncertain to TRUE.

                    p_tape_request^.io_status.position_uncertain := TRUE;
                    p_tape_request^.io_status.completion_code := ioc$tape_medium_failure;

                    EXIT /tape_parity_error_loop/;
                  ELSE
                    iop$tape_internal_request_stat (logical_unit, rio_id, {buf_release} TRUE,
                          {bid_recovery} TRUE, bid_update, osc$wait, rio_status, rstatus);
                    IF (NOT rstatus.normal) OR (NOT rio_status.normal_completion) THEN

{ Set position_uncertain to TRUE.

                      rio_status.position_uncertain := TRUE;
                      p_tape_request^.io_status := rio_status;
                      p_tape_request^.io_status.completion_code := ioc$tape_medium_failure;

                      EXIT /tape_parity_error_loop/;
                    IFEND;
                  IFEND;
                FOREND;
              IFEND;
            IFEND;
            iop$tape_retry_io (p_tape_request, bid_recovery, bid_update, status);

{ Exit with io_status returned from retrying the io operation.

            EXIT /tape_parity_error_loop/;

          IFEND;

        IFEND;

        p_tape_request^.io_status.completion_code := ioc$tape_medium_failure;

{ If unrecovered medium error and the operation is a read or forspace, attempt
{ to position after the bad block by first positioning to last good block and then performing an
{ additional forespace.  The forespace count is incremented to account for the bad block.

        IF ((p_tape_request^.request_type = ioc$tape_read) OR
              (p_tape_request^.request_type = ioc$tape_forspace)) AND
              (NOT p_tape_request^.io_status.position_uncertain) AND
              (NOT bid_recovery) THEN

          p_ud^.error_block_forespace_count := p_ud^.error_block_forespace_count + 1;
          iop$locate_block (logical_unit, p_ud^.cartridge_tape_last_good_bid, {bid_recovery} TRUE,
                0, ioc$lbg_plus_count, rio_status, rstatus);
          IF NOT rstatus.normal OR (NOT rio_status.normal_completion AND (rio_status.completion_code <>
                ioc$tapemark_read)) THEN
            p_ud^.error_block_forespace_count := p_ud^.error_block_forespace_count - 1;
            p_tape_request^.io_status.position_uncertain := TRUE;
            EXIT /tape_parity_error_loop/;
          IFEND;

        IFEND;

      END /tape_parity_error_loop/;

    ELSE

{ Retry all other errors three times.

    /misc_retry_block_1/
      BEGIN

        IF p_tape_request^.misc_retry_count < ioc$tape_max_misc_retry THEN
          p_tape_request^.misc_retry_count := p_tape_request^.misc_retry_count + 1;

          IF (device_status.error_code = 79(16)) AND
                (pp_response.response_length > ioc$min_ccc_cart_resp_size) AND
                (p_tape_request^.pp_response_p^.ccc_cart_sense_bytes.fips_di_status = 180(16)) THEN
            p_tape_request^.ccc_cart_buf_underrun_recovery := TRUE;
          IFEND;

        /misc_retry_block_2/
          BEGIN

            CASE p_tape_request^.request_type OF
            = ioc$tape_read, ioc$tape_write, ioc$tape_write_tapemark, ioc$tape_backspace,
              ioc$tape_forspace =

              iop$locate_block (logical_unit, p_ud^.cartridge_tape_last_good_bid, {bid_recovery} TRUE,
                    0, ioc$lbg_plus_count, rio_status, status);

            = ioc$tape_rewind, ioc$tape_get_status, ioc$locate_block, ioc$tape_unload =

{ Retry the operation without repositioning first.  Only retry ioc$tape_get_status once, since
{ it is most likely the scanner.

              IF (p_tape_request^.request_type = ioc$tape_get_status) AND (p_tape_request^.
                    misc_retry_count > 1) THEN
                EXIT /misc_retry_block_1/;
              ELSE
                rio_status.io_complete := TRUE;
                rio_status.normal_completion := TRUE;
              IFEND;

            ELSE

              EXIT /misc_retry_block_2/;

            CASEND;
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF (rio_status.io_complete) AND
                  NOT (rio_status.normal_completion) AND
                  NOT (rio_status.completion_code = ioc$tapemark_read) THEN

{ Reposition failed.
{ Exit with io_status returned from reposition.

              p_tape_request^.io_status := rio_status;
              EXIT /misc_retry_block_1/;
            IFEND;

            iop$tape_retry_io (p_tape_request, bid_recovery, bid_update, status);

{ Exit with io_status returned from retrying the io operation.

            EXIT /misc_retry_block_1/;

          END /misc_retry_block_2/;

        IFEND;

        IF error_id = ioc$ccc_cart_indeterminate THEN
          p_tape_request^.io_status.completion_code := ioc$indeterminate;
        ELSEIF error_id = ioc$ccc_cart_input_chan_parity THEN
          p_tape_request^.io_status.completion_code := ioc$input_channel_parity;
        ELSEIF error_id = ioc$ccc_cart_output_chan_par THEN
          p_tape_request^.io_status.completion_code := ioc$output_channel_parity;
        ELSEIF (error_id = ioc$ccc_cart_coupler_failure) OR
              (error_id = ioc$ccc_cart_cu_failure) OR
              (error_id = ioc$ccc_cart_inc_trans_in) OR
              (error_id = ioc$ccc_cart_inc_trans_out) OR
              (error_id = ioc$ccc_cart_pp_chan_flag) THEN
          p_tape_request^.io_status.completion_code := ioc$controller_failure;
        ELSEIF error_id = ioc$ccc_cart_function_timeout THEN
          p_tape_request^.io_status.completion_code := ioc$function_timeout;
        ELSEIF error_id = ioc$ccc_cart_iou_parity THEN
          p_tape_request^.io_status.completion_code := ioc$iou_output_parity;
        ELSEIF error_id = ioc$ccc_cart_indeterminate_par THEN
          p_tape_request^.io_status.completion_code := ioc$indeterminate_output_parity;
        ELSE
          p_tape_request^.io_status.completion_code := ioc$indeterminate;
        IFEND;

      END /misc_retry_block_1/;

    CASEND;

    IF (NOT p_tape_request^.io_status.normal_completion) AND
          (p_tape_request^.io_status.completion_code <> ioc$tapemark_read) AND
           p_ud^.tape_error_log_entry THEN

      iop$tape_error_logging_ccc_cart (p_tape_request, ioc$unrecovered, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{         Set tape_error_log_entry to FALSE and initialize the block_in_error entry in the
{         unit_descriptor.

      p_ud^.tape_error_log_entry := FALSE;
      p_ud^.block_in_error := -1;

{         Position the tape for a write or write_tapemark operation before the last
{         good block:  only if no position uncertain was encountered.

      IF ((p_tape_request^.request_type = ioc$tape_write) OR
            (p_tape_request^.request_type = ioc$tape_write_tapemark)) AND
            (NOT inhibit_recovery_occurred) AND
            (NOT p_tape_request^.io_status.position_uncertain) THEN

        iop$locate_block (logical_unit, p_ud^.cartridge_tape_last_good_bid, {bid_recovery} TRUE,
              0, ioc$lbg_plus_count, rio_status, rstatus);
        IF rio_status.io_complete AND
              (NOT rio_status.normal_completion) AND NOT
              (rio_status.completion_code = ioc$tapemark_read) THEN

{             Reposition failed.

          p_tape_request^.io_status.position_uncertain := TRUE;

        IFEND;

      IFEND;

    IFEND;

  PROCEND iop$tape_status_check_ccc_cart;
?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_status_check_ipi ' ??
?? EJECT ??

  PROCEDURE iop$tape_status_check_ipi (bid_recovery: boolean;
        bid_update: boolean;
        commands_executed: iot$tape_request_length;
        data_transfers: iot$tape_request_length;
    VAR inhibit_recovery_occurred: boolean;
    VAR p_tape_request: ^iot$tape_request;
    VAR status: ost$status);

    CONST
      disable_unit = FALSE,
      physical_unload = FALSE,
      repeat_count = 1;

    VAR
      bid_offset: iot$bid_index,
      ipi_tape_status: iot$ipi_tape_status,
      erasures: 1 .. ioc$tape_max_tape_parity_retry,
      error_id: 0 .. ioc$max_ipi_error_id,
      i: integer,
      logical_unit: iot$logical_unit,
      p_ud: ^iot$tape_job_unit_descriptor,
      pp_response: iot$pp_response,
      response_packet: iot$analyzed_ipi_tape_response,
      rio_id: iot$io_id,
      rio_status: iot$tape_io_status,
      rstatus: ost$status;
??EJECT??
{    The following procedure is used to update the block id window after
{    a backspace or forespace.

      PROCEDURE iop$update_bid_window;

        IF p_tape_request^.request_type = ioc$tape_backspace THEN
          IF p_ud^.bid_index <> LOWERVALUE(iot$bid_index) THEN
            p_ud^.bid_index := p_ud^.bid_index - 1;
          ELSE
            p_ud^.bid_index := UPPERVALUE(iot$bid_index);
          IFEND;
          p_ud^.bid_window [p_ud^.bid_index] := ioc$unavail_bid;
        ELSE
          p_ud^.bid_window [p_ud^.bid_index] := ioc$error_block_bid;
          IF p_ud^.bid_index <> UPPERVALUE(iot$bid_index) THEN
            p_ud^.bid_index := p_ud^.bid_index + 1;
          ELSE
            p_ud^.bid_index := LOWERVALUE(iot$bid_index);
          IFEND;
        IFEND;

      PROCEND iop$update_bid_window;
?? EJECT ??

    status.normal := TRUE;
    inhibit_recovery_occurred := FALSE;

    pp_response := p_tape_request^.pp_response_p^.pp_response;
    logical_unit := p_tape_request^.request.logical_unit;
    p_ud := p_tape_request^.ud;

    ipi_tape_status := p_tape_request^.pp_response_p^.ipi_tape_status;
    iop$analyze_response_packets (^ipi_tape_status, pp_response.response_length, response_packet);

{ Initialize io_status. Some of the values may be changed as status is analyzed.

    p_tape_request^.io_status.normal_completion := FALSE;
    p_tape_request^.io_status.unit_busy := FALSE;
    p_tape_request^.io_status.long_input_block := FALSE;
    p_tape_request^.io_status.position_uncertain := FALSE;
    p_tape_request^.io_status.unit_ready := TRUE;
    IF response_packet.sense_bytes_present THEN
      p_tape_request^.io_status.write_ring := NOT response_packet.sense_bytes.file_protect;
      p_tape_request^.io_status.end_of_tape := response_packet.sense_bytes.end_of_tape;
      p_tape_request^.io_status.beginning_of_tape := response_packet.sense_bytes.beginning_of_tape;
      IF response_packet.sense_bytes.not_1600_bpi THEN
        p_tape_request^.io_status.unit_density := rmc$6250;
        p_ud^.tape_unit_density := 3;
      ELSE  { density is 1600
        p_tape_request^.io_status.unit_density := rmc$1600;
        p_ud^.tape_unit_density := 1;
      IFEND;
    ELSE
      p_tape_request^.io_status.write_ring := FALSE;
      p_tape_request^.io_status.end_of_tape := FALSE;
      p_tape_request^.io_status.beginning_of_tape := FALSE;
    IFEND;

    IF pp_response.abnormal_status.forced_termination OR
          pp_response.abnormal_status.channel_error OR
          pp_response.abnormal_status.data_overrun OR
          pp_response.abnormal_status.recording_medium_error OR
          pp_response.abnormal_status.intervention_required OR
          pp_response.abnormal_status.function_timeout OR
          pp_response.abnormal_status.output_channel_parity THEN

{ Error, since IPI pp driver should never set these conditions.

      iop$tape_pp_error (p_tape_request, status);
      IF ipi_tape_status.error_id = ioc$ipi_indeterminate_error THEN
        p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$illegal_abnormal_status;
      IFEND;
      iop$tape_error_logging_ipi (p_tape_request, ioc$unrecovered, status);
      RETURN;
    IFEND;

    IF pp_response.abnormal_status.interface_error THEN
      p_tape_request^.io_status.completion_code := ioc$system_software_failure;
      IF ipi_tape_status.error_id = ioc$ipi_indeterminate_error THEN
        p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$interface_error_wo_eid;
      IFEND;
      iop$tape_error_logging_ipi (p_tape_request, ioc$unrecovered, status);
      RETURN;
    IFEND;

    IF ipi_tape_status.error_id = ioc$ipi_indeterminate_error THEN  { PP did not diagnose error

      IF NOT (ipi_tape_status.major_status.response_type = ioc$standard_command_completion) THEN
        p_tape_request^.io_status.completion_code := ioc$system_software_failure;
        p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$invalid_response_type;
        iop$tape_error_logging_ipi (p_tape_request, ioc$unrecovered, status);
        RETURN;
      IFEND;

      IF NOT pp_response.abnormal_status.hardware_malfunction THEN  {must be alert condition only

        IF pp_response.abnormal_status.abnormal_alert THEN
          IF pp_response.alert_conditions.logical_delimiter THEN
            p_tape_request^.io_status.completion_code := ioc$tapemark_read;

{ Update the block id window index after a tapemark has been encountered
{ during a backward motion operation. Set the block id to ioc$unavail_bid.

            CASE p_tape_request^.request_type OF
            = ioc$tape_backspace, ioc$tape_read_backwards =
              IF bid_update THEN
                FOR i := 1 TO data_transfers + 1 DO
                  iop$update_bid_window;
                FOREND;
              IFEND;
            ELSE
            CASEND;

          ELSEIF pp_response.alert_conditions.physical_delimiter THEN

{ End of tape has been encountered.  Increment
{ blocks_accessed to indicate block is written to tape.

            p_tape_request^.blocks_accessed := p_tape_request^.blocks_accessed + 1;
            p_tape_request^.io_status.end_of_tape := TRUE;
            p_tape_request^.io_status.normal_completion := TRUE;

          ELSEIF pp_response.alert_conditions.long_input_block THEN
            p_tape_request^.io_status.long_input_block := TRUE;
            p_tape_request^.io_status.completion_code := ioc$alert_condition_encountered;

          ELSE {no alert condition set
            p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$no_alert_cond_set;
            p_tape_request^.io_status.completion_code := ioc$system_software_failure;
            iop$tape_error_logging_ipi (p_tape_request, ioc$unrecovered, status);
            RETURN;
          IFEND;

          IF NOT bid_recovery AND (p_ud^.tape_error_log_entry = TRUE) THEN
            iop$tape_error_logging_ipi (p_tape_request, ioc$recovered, status);
            p_ud^.tape_error_log_entry := FALSE;
          IFEND;

          RETURN; {<----------

        ELSE { software error, no bits set in abnormal_status
          p_tape_request^.io_status.completion_code := ioc$system_software_failure;
          p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$no_bits_in_abnormal_status;
          iop$tape_error_logging_ipi (p_tape_request, ioc$unrecovered, status);
          RETURN;
        IFEND;

      ELSE  {hardware_malfuction is set

{ Handle conditions that do not require logging or recovery.

        IF response_packet.id24_present AND response_packet.id24_byte1.not_ready AND
              ((p_tape_request^.request_type = ioc$tape_get_status) OR
              (p_tape_request^.request_type = ioc$tape_unload)) THEN
          p_tape_request^.io_status.unit_ready := FALSE;
          p_tape_request^.io_status.normal_completion := TRUE;
          RETURN;
        IFEND;

        IF response_packet.id2a_present THEN
          IF response_packet.id2a_byte3.beginning_of_media THEN
            p_tape_request^.io_status.beginning_of_tape := TRUE;
            p_tape_request^.io_status.completion_code := ioc$load_point;

{ Set BID window back to load point.

            p_ud^.bid_index := LOWERVALUE(iot$bid_index) + 1;
            bid_offset := LOWERVALUE(iot$bid_index);
            p_ud^.bid_window [bid_offset] := ioc$loadpoint_bid;
            FOR bid_offset := 2 TO UPPERBOUND(iot$bid_window) DO
              p_ud^.bid_window [bid_offset] := ioc$empty_bid;
            FOREND;
            RETURN;
          IFEND;
          IF response_packet.id2a_byte3.blank_tape THEN
            IF p_tape_request^.request_type = ioc$tape_write THEN

{ There's probably a bad spot on the tape that an ATS drive would normally have detected as a
{ tape medium failure.  Setting the tape status error id to tape_medium_failure forces recovery.

              p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$ipi_tape_medium_failure;
            ELSE
              p_tape_request^.io_status.completion_code := ioc$blank_tape;
              RETURN;
            IFEND;
          IFEND;
        IFEND;

        IF response_packet.id26_present THEN
          IF response_packet.id26_byte2.hardware_write_protected THEN
            p_tape_request^.io_status.completion_code := ioc$no_write_ring;
            RETURN;
          IFEND;
          IF response_packet.id26_byte2.fatal_error AND
                response_packet.sense_bytes_present AND
                response_packet.sense_bytes.not_capable_of_density THEN
            p_tape_request^.io_status.completion_code := ioc$not_capable_of_density;
            RETURN;
          IFEND;
        IFEND;

        IF response_packet.id24_present AND response_packet.id24_byte1.addressee_busy THEN

      /busy_loop/
          BEGIN

            IF (p_tape_request^.request_type = ioc$tape_rewind) OR
                  (p_tape_request^.request_type = ioc$tape_get_status) THEN
              p_tape_request^.io_status.normal_completion := TRUE;
              p_tape_request^.io_status.unit_ready := TRUE;
              p_tape_request^.io_status.unit_busy := TRUE;
              EXIT /busy_loop/
            IFEND;
            IF p_tape_request^.busy_retry_count < (ioc$tape_max_busy_retry * 4) THEN
              p_tape_request^.busy_retry_count := p_tape_request^.busy_retry_count + 1;
              pmp$delay (ioc$tape_long_wait DIV 4, status);
              IF NOT status.normal THEN
                EXIT /busy_loop/
              IFEND;
              iop$tape_queue_request_setup (p_tape_request, status);
              IF NOT status.normal THEN
                EXIT /busy_loop/
              ELSE
                logical_unit := p_tape_request^.request.logical_unit;
                rio_id := p_tape_request^.io_id;
                iop$tape_internal_request_stat (logical_unit, rio_id, {buf_release} FALSE,
                      bid_recovery, bid_update, osc$wait, rio_status, rstatus);
                p_tape_request^.io_status := rio_status;
                EXIT /busy_loop/
              IFEND;
            IFEND;
            p_tape_request^.io_status.completion_code := ioc$unit_failure;
            p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$drive_res_to_other_cont;
            iop$tape_error_logging_ipi (p_tape_request, ioc$unrecovered, status);
          END /busy_loop/;

          RETURN;

        IFEND;  { addressee busy check

{
{ Conditions starting here require logging and most require retry.
{ The purpose of the following code (up to error logging) is to determine
{ and set error_id in ipi_tape_status.
{

      /determine_error_id/
        BEGIN

          IF response_packet.id24_present THEN
            IF response_packet.id24_byte1.not_p_available OR
                  response_packet.id24_byte1.not_p_avail_transition THEN
              p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$drive_not_operational;

            ELSEIF response_packet.id24_byte1.not_ready OR
                  response_packet.id24_byte1.not_ready_transition THEN
              p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$drive_not_ready;

            ELSE
              p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$drive_intervention_req;
            IFEND;

            p_tape_request^.io_status.position_uncertain := TRUE;
            p_tape_request^.io_status.unit_ready := FALSE;
            EXIT /determine_error_id/;
          IFEND;

          IF response_packet.id26_present THEN

            IF response_packet.id26_byte1.physical_interface_check THEN
              p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$physical_interface_check;
              EXIT /determine_error_id/;
            IFEND;

            IF response_packet.id26_byte1.operation_timeout THEN
              p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$operation_timeout;
              EXIT /determine_error_id/;
            IFEND;

            IF response_packet.id26_byte4.position_lost THEN
              p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$position_lost;
              EXIT /determine_error_id/;
            IFEND;

            IF response_packet.id26_byte2.data_check OR response_packet.id26_byte2.fatal_error THEN
              IF (p_tape_request^.request_type = ioc$tape_write) OR
                    (p_tape_request^.request_type = ioc$tape_write_tapemark) THEN
                IF response_packet.sense_bytes_present AND response_packet.sense_bytes.id_burst_check THEN
                  p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$ipi_id_burst_error;
                  EXIT /determine_error_id/;
                IFEND;
              IFEND;
              IF response_packet.sense_bytes_present AND response_packet.sense_bytes.control_burst_check THEN
                p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$ipi_unable_to_set_agc;
                EXIT /determine_error_id/;
              IFEND;
              IF response_packet.id26_byte2.data_check THEN
                p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$ipi_tape_medium_failure;
              ELSEIF (response_packet.sense_bytes_present) AND (response_packet.sense_bytes.data_check) THEN
                IF (p_ud^.block_count = 0) AND ((p_tape_request^.request_type = ioc$tape_read) OR
                      (p_tape_request^.request_type = ioc$tape_forspace)) THEN
                  p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$ipi_unable_to_set_agc;
                ELSE
                  p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$ipi_tape_medium_failure;
                IFEND;
              ELSE  { fatal_error
                p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$fatal_error;
              IFEND;
              EXIT /determine_error_id/;
            IFEND;

{ IF id26 is present and an error has not been found yet, set ioc$drive_machine_exception.

            p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$drive_machine_exception;
            EXIT /determine_error_id/;

          IFEND;  { id26_present

          IF response_packet.id2a_present THEN
            IF response_packet.id2a_byte3.block_length_difference OR
                  response_packet.id2a_byte3.data_length_difference THEN
              p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$data_length_difference;
              EXIT /determine_error_id/;
            IFEND;
          IFEND;  { id2a present

          IF response_packet.id29_present OR response_packet.id19_present THEN
            p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$drive_conditional_success;
            EXIT /determine_error_id/;
          IFEND;  { id29_present

        END /determine_error_id/;

      IFEND;  {hardware_malfunction check

    IFEND;  { error_id = ioc$ipi_indeterminate_error

    error_id := p_tape_request^.pp_response_p^.ipi_tape_status.error_id;

{
{ Log the error in the engineering log.
{ Error_id in p_tape_requests should be non-zero.  IF it isn't, there
{ is some condition that should be covered in the above IF statement
{

{ Check whether a log entry is outstanding.  Do not log errors if in recovery.

    IF NOT bid_recovery THEN
      IF NOT p_ud^.tape_error_log_entry THEN
        IF (error_id = ioc$drive_not_operational) OR (error_id = ioc$drive_not_ready) OR
              (error_id = ioc$master_slave_data_integrity) OR
              (error_id = ioc$slave_fac_data_integrity) OR
              (error_id = ioc$pp_detect_software_failure) THEN
          iop$tape_error_logging_ipi (p_tape_request, ioc$unrecovered, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          iop$tape_error_logging_ipi (p_tape_request, ioc$intermediate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Set tape_error_log_entry to TRUE and save the block number for the block_in_error.

          p_ud^.tape_error_log_entry := TRUE;
          p_ud^.block_in_error := p_tape_request^.blocks_accessed;
        IFEND;

      ELSE
        IF p_tape_request^.blocks_accessed <> p_ud^.block_in_error THEN

{ Finalize the outstanding error log entry, which has been recovered.

          iop$tape_error_logging_ipi (p_tape_request, ioc$recovered, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Clear the retry counters before attempting to recover the next failure.

          p_tape_request^.parity_retry_count := 0;
          p_tape_request^.busy_retry_count := 0;
          p_tape_request^.misc_retry_count := 0;
          p_tape_request^.ipi_retry_count := 0;

{ Make an initial log entry for the next failure.

          IF (error_id = ioc$drive_not_operational) OR (error_id = ioc$drive_not_ready) OR
                (error_id = ioc$master_slave_data_integrity) OR
                (error_id = ioc$slave_fac_data_integrity) OR
                (error_id = ioc$pp_detect_software_failure) THEN
            iop$tape_error_logging_ipi (p_tape_request, ioc$unrecovered, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSE
            iop$tape_error_logging_ipi (p_tape_request, ioc$intermediate, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

{ Save the block_in _error, tape_error_log_entry is already set to TRUE.

            p_ud^.block_in_error := p_tape_request^.blocks_accessed;
          IFEND;

        IFEND;
      IFEND;
    IFEND;  { bid_recovery check

{ Attempt retry based on what type of error condition was encountered.

    CASE error_id OF

{ Retry error_id of 0 - 40, 70 - 79, 82 - 88, 90 and 91 six times.

    = ioc$ipi_indeterminate_error .. ioc$slave_encoded_end_status,
            ioc$internal_controller_error .. ioc$unexpected_class_2,
            ioc$drive_intervention_req .. ioc$position_lost,
            ioc$no_end_of_extent, ioc$data_length_difference =

      IF p_tape_request^.ipi_retry_count < ioc$max_ipi_retry THEN
        p_tape_request^.ipi_retry_count := p_tape_request^.ipi_retry_count + 1;
        IF commands_executed > 0 THEN
          CASE p_tape_request^.request_type OF
          = ioc$tape_read, ioc$tape_write, ioc$tape_write_tapemark =
            iop$tape_reposition_b (p_tape_request, status);
          = ioc$tape_forspace =
            IF bid_update THEN
              iop$tape_reposition_b (p_tape_request, status);
            ELSE
              iop$update_bid_window;
              p_tape_request^.io_status.io_complete := TRUE;
              p_tape_request^.io_status.normal_completion := TRUE;
              RETURN;
            IFEND;
          = ioc$tape_read_backwards, ioc$tape_backspace =
            IF bid_update THEN
              FOR i := 1 TO data_transfers + 1 DO
                iop$update_bid_window;
              FOREND;
            IFEND;
            IF NOT bid_recovery THEN
              iop$tape_reposition_f (p_tape_request, status);
            ELSE
              p_tape_request^.io_status.io_complete := TRUE;
              p_tape_request^.io_status.normal_completion := TRUE;
              RETURN;
            IFEND;
          ELSE
            IF error_id = ioc$ipi_indeterminate_error THEN
              p_tape_request^.io_status.completion_code := ioc$indeterminate;
            ELSEIF (error_id <= ioc$unexpected_class_2) THEN
              IF (error_id = ioc$upper_ici_parity) OR (error_id = ioc$lower_ici_parity) OR
                    (error_id = ioc$upper_ipi_chan_parity) OR (error_id = ioc$lower_ipi_chan_parity) OR
                    (error_id = ioc$bus_parity) THEN
                p_tape_request^.io_status.completion_code := ioc$input_channel_parity;
              ELSE
                p_tape_request^.io_status.completion_code := ioc$controller_failure;
              IFEND;
            ELSE
              p_tape_request^.io_status.completion_code := ioc$unit_failure;
            IFEND;
            RETURN;
          CASEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF (p_tape_request^.io_status.io_complete) AND
                NOT (p_tape_request^.io_status.normal_completion) AND
                NOT (p_tape_request^.io_status.completion_code = ioc$tapemark_read) THEN

{ Reposition failed.
{ Exit with io_status returned from reposition.
            RETURN;
          IFEND;

{ If commands_executed = 0, only retry a rewind or unload operation two times if
{ the error is ioc$can_not_select_controller or ioc$no_controller_interrupt, since
{ this is most likely a non-existant or broken slave.

        ELSEIF ((p_tape_request^.request_type = ioc$tape_get_status) OR
              (p_tape_request^.request_type = ioc$tape_rewind) OR
              (p_tape_request^.request_type = ioc$tape_unload)) AND
              ((error_id = ioc$can_not_select_controller) OR
              (error_id = ioc$no_controller_interrupt)) AND
              (p_tape_request^.ipi_retry_count > 2) THEN
          p_tape_request^.ipi_retry_count := 2;
          p_tape_request^.io_status.completion_code := ioc$controller_failure;
          RETURN;
        IFEND;

        iop$tape_retry_io (p_tape_request, bid_recovery, bid_update, status);

{ Exit with io_status returned from retrying the io operation.

        RETURN;
      IFEND;

      IF error_id = ioc$ipi_indeterminate_error THEN
        p_tape_request^.io_status.completion_code := ioc$indeterminate;
      ELSEIF (error_id <= ioc$unexpected_class_2) THEN
        IF (error_id = ioc$upper_ici_parity) OR (error_id = ioc$lower_ici_parity) OR
              (error_id = ioc$upper_ipi_chan_parity) OR (error_id = ioc$lower_ipi_chan_parity) OR
              (error_id = ioc$bus_parity) THEN
          IF (p_tape_request^.request_type = ioc$tape_write) OR
                (p_tape_request^.request_type = ioc$tape_write_tapemark) THEN
            p_tape_request^.io_status.completion_code := ioc$output_channel_parity;
          ELSE
            p_tape_request^.io_status.completion_code := ioc$input_channel_parity;
          IFEND;
        ELSE
          p_tape_request^.io_status.completion_code := ioc$controller_failure;
        IFEND;
      ELSE
        p_tape_request^.io_status.completion_code := ioc$unit_failure;
      IFEND;

    = ioc$drive_not_operational, ioc$drive_not_ready =
      p_tape_request^.io_status.completion_code := ioc$unit_failure;
      RETURN;  { no retry on not ready

    = ioc$ipi_tape_medium_failure =

  /tape_parity_error_loop/
      BEGIN

        IF p_tape_request^.inhibit_error_recovery AND NOT bid_recovery THEN
          IF p_tape_request^.request_type = ioc$tape_write THEN
            p_tape_request^.blocks_accessed := p_tape_request^.blocks_accessed + 1;
          IFEND;
          inhibit_recovery_occurred := TRUE;
          p_tape_request^.io_status.io_complete := TRUE;
          p_tape_request^.io_status.completion_code := ioc$tape_medium_failure;
          iop$update_bid_window;
          EXIT /tape_parity_error_loop/
        IFEND;

      /tape_parity_error_loop_2/
        BEGIN
          IF p_tape_request^.parity_retry_count < ioc$tape_max_tape_parity_retry THEN
            p_tape_request^.parity_retry_count := p_tape_request^.parity_retry_count + 1;
            CASE p_tape_request^.request_type OF
            = ioc$tape_read, ioc$tape_write, ioc$tape_write_tapemark =
              iop$tape_reposition_b (p_tape_request, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              IF p_tape_request^.io_status.completion_code = ioc$load_point THEN
                p_tape_request^.io_status.completion_code := ioc$tape_medium_failure;
                EXIT /tape_parity_error_loop/;
              IFEND;
            = ioc$tape_forspace =
              IF bid_update THEN
                iop$tape_reposition_b (p_tape_request, status);
              ELSE
                iop$update_bid_window;
                p_tape_request^.io_status.io_complete := TRUE;
                p_tape_request^.io_status.normal_completion := TRUE;
                EXIT /tape_parity_error_loop/
              IFEND;

{ The following case selection presently resolves some recovery problems
{ when parity error is received while backspacing in BID_RECOVERY mode.
{ We accept backspace errors during BID_RECOVERY because we will check the
{ BID windows and correct for mispositioning.
{ When not in recovery we accept backspaces if only a parity error status is
{ present and not status bits to indicate possible mispositioning.

            = ioc$tape_backspace, ioc$tape_read_backwards =
              IF bid_update THEN
                FOR i := 1 TO data_transfers + 1 DO
                  iop$update_bid_window;
                FOREND;
              IFEND;
              IF (response_packet.sense_bytes_present) AND (response_packet.sense_bytes.partial_record OR
                    response_packet.sense_bytes.postamble_error) AND NOT (bid_recovery) THEN
                iop$tape_reposition_f (p_tape_request, status);
              ELSE
                p_tape_request^.io_status.normal_completion := TRUE;
                p_tape_request^.io_status.io_complete := TRUE;
                IF (p_tape_request^.no_of_non_data_commands = 1) OR
                      (commands_executed = p_tape_request^.no_of_non_data_commands) THEN

{ Do not attempt iop$tape_retry_io if the number of original backspaces has been completed.

                  EXIT /tape_parity_error_loop/;
                ELSE

{ Decrement number of original commands by 1 to account for the block which encountered the parity
{ error.  iop$tape_retry_io must be called to complete the original number of backspaces.

                  p_tape_request^.no_of_non_data_commands := p_tape_request^.no_of_non_data_commands - 1;
                IFEND;
              IFEND;
            = ioc$tape_erase =
              IF response_packet.sense_bytes_present AND response_packet.sense_bytes.head_failure THEN
                p_tape_request^.io_status.completion_code := ioc$unit_failure;
              ELSE
                p_tape_request^.io_status.normal_completion := TRUE;
              IFEND;
              EXIT /tape_parity_error_loop/
            ELSE
              p_tape_request^.io_status.completion_code := ioc$unit_failure;
              EXIT /tape_parity_error_loop/
            CASEND;
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF p_tape_request^.io_status.io_complete AND
                  NOT p_tape_request^.io_status.normal_completion AND
                  NOT (p_tape_request^.io_status.completion_code = ioc$tapemark_read) THEN

{ Reposition failed.
{ Exit with io_status returned from reposition.

                   EXIT /tape_parity_error_loop/
            ELSE
              IF (p_tape_request^.request_type = ioc$tape_write) OR
                    (p_tape_request^.request_type = ioc$tape_write_tapemark) THEN

                erasures := p_tape_request^.parity_retry_count;

                FOR i := 1 TO erasures DO
                  logical_unit := p_tape_request^.request.logical_unit;
                  iop$67x_non_data_trans_setup (logical_unit, ioc$tape_erase, repeat_count,
                        disable_unit, physical_unload, rio_id, rstatus);
                  IF NOT rstatus.normal THEN

{ Set position_uncertain to TRUE.

                    p_tape_request^.io_status.position_uncertain := TRUE;

                    EXIT /tape_parity_error_loop_2/
                  ELSE
                    iop$tape_internal_request_stat (logical_unit, rio_id, {buf_release} TRUE,
                          {bid_recovery} TRUE, bid_update, osc$wait, rio_status, rstatus);
                    IF (NOT rstatus.normal) OR (NOT rio_status.normal_completion) THEN

{ Set position_uncertain to TRUE.

                      rio_status.position_uncertain := TRUE;
                      p_tape_request^.io_status := rio_status;

                      EXIT /tape_parity_error_loop_2/
                    IFEND;
                  IFEND;
                FOREND;
              IFEND;
            IFEND;
            iop$tape_retry_io (p_tape_request, bid_recovery, bid_update, status);

{ Exit with io_status returned from retrying the io operation.

            EXIT /tape_parity_error_loop/;
          IFEND;
        END /tape_parity_error_loop_2/;

        IF (p_tape_request^.request_type = ioc$tape_read) OR
              (p_tape_request^.request_type = ioc$tape_forspace) THEN
          iop$update_bid_window;
        IFEND;
        p_tape_request^.io_status.completion_code := ioc$tape_medium_failure;
      END /tape_parity_error_loop/;

    = ioc$ipi_id_burst_error, ioc$ipi_unable_to_set_agc =

    /bad_id_burst_recovery_loop/
      BEGIN
        IF p_tape_request^.misc_retry_count < ioc$tape_max_misc_retry THEN
              p_tape_request^.misc_retry_count := p_tape_request^.misc_retry_count + 1;
        rstatus.normal := TRUE;
        iop$67x_non_data_trans_setup (logical_unit, ioc$tape_rewind, repeat_count,
              disable_unit, physical_unload, rio_id, rstatus);
          IF NOT rstatus.normal THEN
            EXIT /bad_id_burst_recovery_loop/
          ELSE
            iop$tape_internal_request_stat (logical_unit, rio_id, {buf_release} TRUE,
                  {bid_recovery} TRUE, bid_update, osc$wait, rio_status, rstatus);
            IF (NOT rstatus.normal) OR (NOT rio_status.normal_completion) THEN
              p_tape_request^.io_status := rio_status;
              EXIT /bad_id_burst_recovery_loop/
            IFEND;
          IFEND;
          iop$tape_retry_io (p_tape_request, bid_recovery, bid_update, status);

{ Exit with io_status returned from retrying the io operation.

          RETURN;
        IFEND;
      END /bad_id_burst_recovery_loop/;

{ Allow ioc$ipi_unable_to_set_agc if neither equipment_check or data_check are set
{ in the sense bytes and no write ring is in the tape.  The tape is readable, but
{ extending the file by writing will not be allowed since the tape unit AGC is not
{ set correctly in all tracks.

      IF (error_id = ioc$ipi_unable_to_set_agc) AND (NOT response_packet.sense_bytes.data_check) AND
            (NOT response_packet.sense_bytes.equip_check) AND (NOT p_tape_request^.io_status.write_ring) THEN

{ Place an error bid indicator in the Bid_Window due to the block_id not being updated on a bad read and
{ set completion status to normal in an attempt to read the tape. An Engineering Log entry has been set up.

        iop$update_bid_window;
        p_tape_request^.io_status.normal_completion := TRUE;
        RETURN;
      IFEND;

{ Rewind the tape and send error status to the requestor.

      rstatus.normal := TRUE;
      iop$67x_non_data_trans_setup (logical_unit, ioc$tape_rewind, repeat_count,
            disable_unit, physical_unload, rio_id, rstatus);
      iop$tape_internal_request_stat (logical_unit, rio_id, {buf_release} TRUE,
            {bid_recovery} TRUE, bid_update, osc$wait, rio_status, rstatus);

      p_tape_request^.io_status.io_complete := TRUE;
      IF error_id = ioc$ipi_id_burst_error THEN
        p_tape_request^.io_status.completion_code := ioc$unable_to_write_id_burst;
      ELSE  { error_id = ioc$ipi_unable_to_set_agc
      p_tape_request^.io_status.completion_code := ioc$unable_to_set_agc;
      IFEND;

    = ioc$master_slave_data_integrity =
      p_tape_request^.io_status.completion_code := ioc$controller_failure;
      RETURN;  { no retry

    = ioc$slave_fac_data_integrity =
      p_tape_request^.io_status.completion_code := ioc$unit_failure;
      RETURN;  { no retry

    = ioc$pp_detect_software_failure =
      p_tape_request^.io_status.completion_code := ioc$system_software_failure;
      RETURN;  { no retry on software failure

    ELSE  {  unrecognized error_id

      p_tape_request^.io_status.completion_code := ioc$indeterminate;
      RETURN;  { no retry on unrecognized error_id

    CASEND;

  PROCEND iop$tape_status_check_ipi;
?? OLDTITLE ??
?? NEWTITLE := ' iop$analyze_response_packets ' ??
?? EJECT ??
  PROCEDURE iop$analyze_response_packets (
        status_p: ^iot$ipi_tape_status;
        response_length: iot$response_length;
    VAR response_packet: iot$analyzed_ipi_tape_response);

    VAR
      base_index: integer,
      dest_p: ^cell,
      next_length: integer,
      next_response_code: integer,
      response_packet_length: integer,
      source_p: ^cell;

    response_packet.id24_present := FALSE;
    response_packet.id26_present := FALSE;
    response_packet.id19_present := FALSE;
    response_packet.id29_present := FALSE;
    response_packet.id2a_present := FALSE;
    response_packet.sense_bytes_present := FALSE;

    IF response_length <= ioc$min_ipi_total_resp_size THEN
      RETURN;  { no ipi major status present
    IFEND;

    response_packet_length := status_p^.major_status_header.length + 2;
    IF response_packet_length <= ioc$major_status_size THEN
      RETURN;  { no parameters present
    IFEND;
    base_index := 11;

  /search_response_codes/
    WHILE base_index < response_packet_length DO
      next_length := status_p^.ipi_status [base_index] + 1;
      next_response_code := status_p^.ipi_status [base_index + 1];
      IF (base_index - 1 + next_length) > response_packet_length THEN
        EXIT /search_response_codes/;
      IFEND;
    /process_response_code/
      BEGIN
        CASE next_response_code OF
        = 24(16) =
          IF response_packet.id24_present THEN
            EXIT /process_response_code/;
          IFEND;
          IF next_length < 3 THEN
            EXIT /process_response_code/;
          IFEND;
          response_packet.id24_present := TRUE;
          source_p := ^status_p^.ipi_status [base_index + 1 + 1];
          dest_p := ^response_packet.id24_byte1;
          i#move (source_p, dest_p, 1);
          IF ((next_length - 1) >= 2f(16)) AND
                (status_p^.ipi_status [base_index + 1 + 5] = 80(16)) AND
                (status_p^.ipi_status [base_index + 1 + 6] = 0) AND
                (NOT response_packet.sense_bytes_present) THEN
            response_packet.sense_bytes_present := TRUE;
            source_p := ^status_p^.ipi_status [base_index + 1 + 19];
            dest_p := ^response_packet.sense_bytes;
            i#move (source_p, dest_p, 10);
          IFEND;
        = 26(16) =
          IF response_packet.id26_present THEN
            EXIT /process_response_code/;
          IFEND;
          IF next_length < 4 THEN
            EXIT /process_response_code/;
          IFEND;
          response_packet.id26_present := TRUE;
          source_p := ^status_p^.ipi_status [base_index + 1 + 1];
          dest_p := ^response_packet.id26_byte1;
          i#move (source_p, dest_p, 1);
          source_p := ^status_p^.ipi_status [base_index + 1 + 2];
          dest_p := ^response_packet.id26_byte2;
          i#move (source_p, dest_p, 1);
          source_p := ^status_p^.ipi_status [base_index + 1 + 4];
          dest_p := ^response_packet.id26_byte4;
          i#move (source_p, dest_p, 1);
          IF ((next_length - 1) >= 2f(16)) AND
                (status_p^.ipi_status [base_index + 1 + 5] = 80(16)) AND
                (status_p^.ipi_status [base_index + 1 + 6] = 0) AND
                (NOT response_packet.sense_bytes_present) THEN
            response_packet.sense_bytes_present := TRUE;
            source_p := ^status_p^.ipi_status [base_index + 1 + 19];
            dest_p := ^response_packet.sense_bytes;
            i#move (source_p, dest_p, 10);
          IFEND;
        = 19(16) =
          IF response_packet.id19_present THEN
            EXIT /process_response_code/;
          IFEND;
          response_packet.id19_present := TRUE;
        = 29(16) =
          IF response_packet.id29_present THEN
            EXIT /process_response_code/;
          IFEND;
          response_packet.id29_present := TRUE;
        = 2a(16) =
          IF response_packet.id2a_present THEN
            EXIT /process_response_code/;
          IFEND;
          IF next_length < 5 THEN
            EXIT /process_response_code/;
          IFEND;
          response_packet.id2a_present := TRUE;
          source_p := ^status_p^.ipi_status [base_index + 1 + 3];
          dest_p := ^response_packet.id2a_byte3;
          i#move (source_p, dest_p, 1);
          IF ((next_length - 1) >= 2f(16)) AND
                (status_p^.ipi_status [base_index + 1 + 5] = 80(16)) AND
                (status_p^.ipi_status [base_index + 1 + 6] = 0) AND
                (NOT response_packet.sense_bytes_present) THEN
            response_packet.sense_bytes_present := TRUE;
            source_p := ^status_p^.ipi_status [base_index + 1 + 19];
            dest_p := ^response_packet.sense_bytes;
            i#move (source_p, dest_p, 10);
          IFEND;
        ELSE
        CASEND;
      END /process_response_code/;
      IF next_length MOD 2 <> 0 THEN
        next_length := next_length + 1;
      IFEND;
      base_index := base_index + next_length;
    WHILEND /search_response_codes/;

  PROCEND iop$analyze_response_packets;
?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_terminate_io ' ??
?? EJECT ??

  PROCEDURE iop$tape_terminate_io (VAR p_tape_request: ^iot$tape_request;
    bid_recovery: boolean;
    VAR status: ost$status);

    VAR
      current_heap: ^ost$heap,
      found: boolean,
      i: iot$no_of_tape_units,
      ignore_status: ost$status,
      p_ud: ^iot$tape_job_unit_descriptor,
      requests_executed: integer,
      tape_failure_type : iot$tape_failure_type,
      tapemark_count: integer;

    #INLINE ('keypoint', osk$entry, osk$m * (p_tape_request^.request_type), ioc$tape_enter_iopterm);

    status.normal := TRUE;
    iop$set_current_heap (current_heap);

{ Obtain the address for the tape job unit descriptor.

    p_ud := p_tape_request^.ud;

{ Increment usage counts.

    requests_executed := (p_tape_request^.last_command_processed - ioc$request_header_length) DIV 8 + 1;
    p_ud^.io_requests_count := p_ud^.io_requests_count + requests_executed;

    CASE p_tape_request^.request_type OF

    = ioc$tape_read =
      p_ud^.blocks_read := p_ud^.blocks_read + p_tape_request^.blocks_accessed;

{ Residual_block_count is initialized to 0 for normal_completion = TRUE.

      IF NOT p_tape_request^.io_status.normal_completion THEN
        p_tape_request^.io_status.residual_block_count := p_tape_request^.
              initial_block_count - p_tape_request^.blocks_accessed;
      IFEND;

{ Blocks_read for accounting and IRG location (block_count) includes any blocks that were read
{ and not involved in recovery.

      IF NOT bid_recovery THEN
        p_ud^.block_count := p_ud^.block_count + p_tape_request^.blocks_accessed;
        p_ud^.blocks_read_for_byte_count := p_ud^.blocks_read_for_byte_count + p_tape_request^.
               blocks_accessed;
        IF (NOT p_tape_request^.io_status.normal_completion) THEN
          IF (p_tape_request^.io_status.completion_code = ioc$tapemark_read) THEN
            p_ud^.tapemark_count := p_ud^.tapemark_count + 1;
            p_ud^.block_count := p_ud^.block_count + 1;
            p_ud^.blocks_read_for_byte_count := p_ud^.blocks_read_for_byte_count + 1;
          ELSEIF (p_tape_request^.io_status.completion_code = ioc$alert_condition_encountered) OR
                ((p_tape_request^.io_status.completion_code = ioc$tape_medium_failure) AND
                (p_tape_request^.inhibit_error_recovery)) THEN
            p_ud^.block_count := p_ud^.block_count + 1;
            p_ud^.blocks_read_for_byte_count := p_ud^.blocks_read_for_byte_count + 1;
          IFEND;
        IFEND;
      IFEND;

? IF system_version THEN
{     IF p_ud^.controller_type = cmc$mt5680_xx THEN
{       IF (p_ud^.block_count <> p_ud^.cartridge_tape_last_good_bid.logical_position) AND
{          (p_ud^.block_count <> p_ud^.cartridge_tape_last_good_bid.logical_position +
{           p_ud^.error_block_forespace_count) THEN
{         osp$system_error ('Block Count incorrect after read', ^status);
{       IFEND;
{     IFEND;
? IFEND

    = ioc$tape_forspace =
      p_ud^.blocks_read := p_ud^.blocks_read + p_tape_request^.blocks_accessed;

{ Residual_block_count is initialized to 0 for normal_completion = TRUE.

      IF NOT p_tape_request^.io_status.normal_completion THEN
        p_tape_request^.io_status.residual_block_count := p_tape_request^.
              initial_block_count - p_tape_request^.blocks_accessed;
      IFEND;

{ Blocks_skipped for accounting and IRG location (block_count) includes any blocks that were
{ forespaced over that were not involved in recovery.

      IF (NOT bid_recovery) OR (p_ud^.positioning_to_tapemark) THEN
        p_ud^.block_count := p_ud^.block_count + p_tape_request^.blocks_accessed;
        p_ud^.blocks_skipped := p_ud^.blocks_skipped + p_tape_request^.
               blocks_accessed;
        IF (NOT p_tape_request^.io_status.normal_completion) THEN
          IF (p_tape_request^.io_status.completion_code = ioc$tapemark_read) THEN
            p_ud^.tapemark_count := p_ud^.tapemark_count + 1;
            p_ud^.block_count := p_ud^.block_count + 1;
            p_ud^.blocks_skipped := p_ud^.blocks_skipped + 1;
          ELSEIF ((p_tape_request^.io_status.completion_code = ioc$tape_medium_failure) AND
                (p_tape_request^.inhibit_error_recovery)) THEN
            p_ud^.block_count := p_ud^.block_count + 1;
            p_ud^.blocks_read_for_byte_count := p_ud^.blocks_read_for_byte_count + 1;
          IFEND;
        IFEND;
      IFEND;

    = ioc$tape_backspace =
      p_ud^.blocks_read := p_ud^.blocks_read + p_tape_request^.blocks_accessed;
      IF NOT p_tape_request^.io_status.normal_completion THEN
        p_tape_request^.io_status.residual_block_count := p_tape_request^.
              initial_block_count - p_tape_request^.blocks_accessed;
      IFEND;

{ Blocks skipped for accounting includes any blocks that were backspaced over and not involved
{ in recovery.

      IF (NOT bid_recovery) OR (p_ud^.positioning_to_tapemark) THEN
        p_ud^.block_count := p_ud^.block_count - p_tape_request^.blocks_accessed;
        p_ud^.blocks_skipped := p_ud^.blocks_skipped + p_tape_request^.
               blocks_accessed;
        IF (NOT p_tape_request^.io_status.normal_completion) AND
           (p_tape_request^.io_status.completion_code = ioc$tapemark_read) THEN
          p_ud^.tapemark_count := p_ud^.tapemark_count - 1;
          p_ud^.block_count := p_ud^.block_count - 1;
          p_ud^.blocks_skipped := p_ud^.blocks_skipped + 1;
        IFEND;
      IFEND;

    = ioc$tape_write =
      p_ud^.blocks_written := p_ud^.blocks_written +  p_tape_request^.blocks_accessed;
      p_ud^.block_count := p_ud^.block_count + p_tape_request^.blocks_accessed;
      p_ud^.blocks_written_for_byte_count := p_ud^.blocks_written_for_byte_count +  p_tape_request^.
             blocks_accessed;

      p_tape_request^.io_status.residual_block_count := p_tape_request^.
            initial_block_count - p_tape_request^.blocks_accessed;

? IF system_version THEN
{     IF p_ud^.controller_type = cmc$mt5680_xx THEN
{       IF (p_ud^.block_count <> p_ud^.cartridge_tape_last_good_bid.logical_position) AND
{          (p_ud^.block_count <> p_ud^.cartridge_tape_last_good_bid.logical_position +
{           p_ud^.error_block_forespace_count) THEN
{         osp$system_error ('Block Count incorrect after write', ^status);
{       IFEND;
{     IFEND;
? IFEND

    = ioc$tape_write_tapemark =

{ Presently only 1 write_tapemark command allowed per request, but this code will allow for
{ future implementation of multiple TM writes in one request and the counts will be correct.

      IF p_tape_request^.io_status.normal_completion THEN
        tapemark_count := requests_executed - ioc$format_cmd_length;
      ELSE
        p_tape_request^.io_status.residual_block_count := p_tape_request^.
              initial_block_count - p_tape_request^.blocks_accessed;
        tapemark_count := requests_executed - ioc$format_cmd_length - ioc$non_data_cmd_length;
      IFEND;

      p_ud^.tapemark_count := p_ud^.tapemark_count + tapemark_count;
      p_ud^.block_count := p_ud^.block_count + tapemark_count;
      p_ud^.blocks_written := p_ud^.blocks_written +  tapemark_count;
      p_ud^.blocks_written_for_byte_count := p_ud^.blocks_written_for_byte_count +  tapemark_count;

    = ioc$tape_unload =

      IF (iov$p_statistic_data_p_array = NIL) THEN
        RETURN;
      IFEND;

      i := 1;
      found := FALSE;
      WHILE (i <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
        IF (p_ud = iov$p_statistic_data_p_array^ [i].p_tape_job_unit_descriptor) AND
              (iov$p_statistic_data_p_array^ [i].slot_in_use) THEN
          found := TRUE;
        ELSE
          i := i + 1;
        IFEND;
      WHILEND;

      IF found THEN
        IF (p_ud^.single_double_track_corrections <> 0) AND (p_ud^.controller_type <> cmc$mt5680_xx) THEN
          IF p_ud^.controller_type = cmc$mt5698_xx THEN
            p_tape_request^.pp_response_p^.ipi_tape_status.error_id := ioc$hdw_corrected_errors;
            iop$tape_error_logging_ipi (p_tape_request, ioc$informative, status);
          ELSE
            tape_failure_type := ioc$undetermined;
            iop$tape_error_logging (p_tape_request, tape_failure_type, {*IM*} FALSE, status);
            tape_failure_type := ioc$recovered;
            iop$tape_error_logging (p_tape_request, tape_failure_type, {*IM*} TRUE, status);
          IFEND;
        ELSEIF p_ud^.controller_type = cmc$mt5680_xx THEN
          IF (p_tape_request^.request.tape_command [2].address = ioc$67x_func_unload) AND
                (p_tape_request^.pp_response_p^.pp_response.response_length = ioc$max_ccc_cart_resp_size) AND
                ((p_tape_request^.pp_response_p^.ccc_cart_error_log.on_the_fly_read_errors > 0) OR
                (p_tape_request^.pp_response_p^.ccc_cart_error_log.on_the_fly_write_errors > 0) OR
                (p_tape_request^.pp_response_p^.ccc_cart_error_log.recovered_read_errors > 0) OR
                (p_tape_request^.pp_response_p^.ccc_cart_error_log.recovered_write_errors > 0) OR
                (p_ud^.ccc_cart_buffer_underruns > 0)) THEN
              p_tape_request^.pp_response_p^.ccc_cart_device_status.error_id := ioc$ccc_cart_hardware_corr;
            iop$tape_error_logging_ccc_cart (p_tape_request, ioc$recovered, status);
          IFEND;
        IFEND;

        iop$tape_usage_logging (p_tape_request, ignore_status);

        iop$free_wired_tape_tables (p_ud^.completion_q_index);
        iop$free_pageable_tape_requests (p_ud);
        FREE p_ud IN current_heap^;

        osp$set_job_signature_lock (statistic_data_lock);

        iov$p_statistic_data_p_array^ [i].logical_unit := 0;
        iov$p_statistic_data_p_array^ [i].p_tape_job_unit_descriptor := NIL;
        iov$p_statistic_data_p_array^ [i].slot_in_use := FALSE;

        found := FALSE;
        /unit_assignment/
          FOR i := 1 TO UPPERBOUND (iov$p_statistic_data_p_array^) DO
            IF iov$p_statistic_data_p_array^ [i].slot_in_use = TRUE THEN
              found := TRUE;
              EXIT /unit_assignment/;
            IFEND;
          FOREND /unit_assignment/;

        IF NOT found THEN
          FREE iov$p_statistic_data_p_array IN current_heap^;
          iov$p_statistic_data_p_array := NIL;
        IFEND;

        osp$clear_job_signature_lock (statistic_data_lock);

      IFEND;

    = ioc$skip_tapemark_forward =

      IF p_tape_request^.io_status.normal_completion THEN
        tapemark_count := requests_executed - ioc$format_cmd_length;
      ELSE
        p_tape_request^.io_status.residual_block_count := p_tape_request^.
              initial_block_count - p_tape_request^.blocks_accessed;
        tapemark_count := requests_executed - ioc$format_cmd_length - ioc$non_data_cmd_length;
      IFEND;
      p_ud^.blocks_read := p_ud^.blocks_read + tapemark_count;
      p_ud^.tapemark_count := p_ud^.tapemark_count + tapemark_count;
      p_ud^.block_count := p_ud^.cartridge_tape_last_good_bid.logical_position;

    = ioc$skip_tapemark_backward =

      IF p_tape_request^.io_status.normal_completion THEN
        tapemark_count := requests_executed - ioc$format_cmd_length;
      ELSE
        p_tape_request^.io_status.residual_block_count := p_tape_request^.
              initial_block_count - p_tape_request^.blocks_accessed;
        tapemark_count := requests_executed - ioc$format_cmd_length - ioc$non_data_cmd_length;
      IFEND;
      p_ud^.blocks_read := p_ud^.blocks_read + tapemark_count;
      p_ud^.tapemark_count := p_ud^.tapemark_count - tapemark_count;
      p_ud^.block_count := p_ud^.cartridge_tape_last_good_bid.logical_position;

    = ioc$tape_rewind =

      IF NOT bid_recovery THEN
        p_ud^.block_count := 0;
        p_ud^.tapemark_count := 0;
      IFEND;

    = ioc$locate_block =

      IF NOT bid_recovery AND p_tape_request^.io_status.normal_completion THEN
        p_ud^.block_count := p_ud^.cartridge_tape_last_good_bid.logical_position;
      IFEND;

    = ioc$tape_data_security_erase, ioc$tape_get_status, ioc$tape_erase =

{ No action, exit.

    ELSE
      osp$set_status_abnormal ('io', ioc$os_failure, 'improper request type in iop$tape_terminate_io',
            status);
    CASEND;

  PROCEND iop$tape_terminate_io;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_terminate_io_scan ' ??
?? EJECT ??

? IF system_version THEN
  PROCEDURE [XDCL, #GATE] iop$tape_terminate_io_scan (logical_unit_number: iot$logical_unit);

    VAR
      current_heap: ^ost$heap,
      found: boolean,
      i: iot$no_of_tape_units;

    iop$set_current_heap (current_heap);

{   find unit descriptor for unit that was scanned

    i := 1;
    found := FALSE;

    osp$set_job_signature_lock (statistic_data_lock);

    WHILE (i <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
      IF logical_unit_number = iov$p_statistic_data_p_array^ [i].logical_unit THEN
        found := TRUE;
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;

    IF found THEN

{   Free the space occupied by the tape unit descriptor and set bit slot_in_use
{   in statistic_data_p_array to FALSE.

      iop$free_wired_tape_tables (iov$p_statistic_data_p_array^ [i].p_tape_job_unit_descriptor^.
            completion_q_index);
      iop$free_pageable_tape_requests (iov$p_statistic_data_p_array^ [i].p_tape_job_unit_descriptor);
      FREE iov$p_statistic_data_p_array^ [i].p_tape_job_unit_descriptor IN current_heap^;
      iov$p_statistic_data_p_array^ [i].logical_unit := 0;
      iov$p_statistic_data_p_array^ [i].slot_in_use := FALSE;
    IFEND;

{ Currently do not FREE iov$p_statistic_data_p_array for the system job since the
{ scanner runs there and there would be excessive allocates and frees if the structure
{ was released after every unit scan.
{
{   found := FALSE;
{   /unit_assignment/
{     FOR i := 1 TO UPPERBOUND (iov$p_statistic_data_p_array^) DO
{       IF iov$p_statistic_data_p_array^ [i].slot_in_use = TRUE THEN
{         found := TRUE;
{         EXIT /unit_assignment/;
{       IFEND;
{     FOREND /unit_assignment/;
{
{   IF NOT found THEN
{     FREE iov$p_statistic_data_p_array IN current_heap^;
{     iov$p_statistic_data_p_array := NIL;
{   IFEND;

    osp$clear_job_signature_lock (statistic_data_lock);

  PROCEND iop$tape_terminate_io_scan;
? IFEND

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_update_byte_counts ' ??
?? EJECT ??
?  IF system_version THEN

  PROCEDURE [XDCL, #GATE] iop$tape_update_byte_counts (system_file_id: dmt$system_file_id;
    max_block_length: amt$max_block_length;
    VAR status: ost$status);

    VAR
      found: boolean,
      i: iot$no_of_tape_units,
      logical_unit: iot$logical_unit,
      ud_p: ^iot$tape_job_unit_descriptor;

      status.normal := TRUE;

{     Get unit number using file name.

      convert_sfid_to_lun (system_file_id, logical_unit, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Obtain pointer to tape job unit descriptor.

      i := 1;
      found := FALSE;
      WHILE (i <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
        IF logical_unit = iov$p_statistic_data_p_array^ [i]. logical_unit THEN
          found := TRUE;
        ELSE
          i := i + 1;
        IFEND;
      WHILEND;

      IF NOT found THEN
        osp$set_status_abnormal ('io', ioc$os_failure,
              'unable to find unit in iop$tape_update_byte_counts', status);
        RETURN;
      IFEND;

      ud_p := iov$p_statistic_data_p_array^ [i].p_tape_job_unit_descriptor;

      ud_p^.blocks_read_for_accounting := ud_p^.blocks_read_for_accounting +
              ud_p^.blocks_read_for_byte_count;
      ud_p^.blocks_written_for_accounting := ud_p^.blocks_written_for_accounting +
              ud_p^.blocks_written_for_byte_count;
      ud_p^.bytes_read := ud_p^.bytes_read + (ud_p^.blocks_read_for_byte_count * max_block_length);
      ud_p^.bytes_written := ud_p^.bytes_written + (ud_p^.blocks_written_for_byte_count * max_block_length);
      ud_p^.blocks_read_for_byte_count := 0;
      ud_p^.blocks_written_for_byte_count := 0;

  PROCEND iop$tape_update_byte_counts;

?  IFEND

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_usage_logging ' ??
?? EJECT ??

  PROCEDURE iop$tape_usage_logging (p_tape_request: ^iot$tape_request;
    VAR status: ost$status);

? IF system_version THEN
*copyc fsp$path_element
*copyc clp$check_name_for_path_handle

    PROCEDURE [INLINE] append_string_data (string_data: string ( * <= 31));

      path.value (i, * ) := string_data;

      WHILE (path.value (i, 1) <> ' ') DO
        i := i + 1;
      WHILEND;

    PROCEND append_string_data;

    CONST
      gcr = 3,
      novalue = -1,
      nrzi = 1,
      pe = 2,
      cart = 4;

    VAR
      channel: cmt$physical_channel,
      cyc_descr: ^fmt$cycle_description,
      efr: fst$evaluated_file_reference,
      equipment_number: cmt$physical_equipment_number,
      element_name: cmt$element_name,
      found: boolean,
      file_name: ost$name,
      file_path_handle: clt$path_handle,
      i: integer,
      iou_number: dst$iou_number,
      logical_unit: iot$logical_unit,
      p_counters: sft$counters,
      p_counters_seq: ^SEQ (*),
      p_pp_interface_table: ^iot$pp_interface_table,
      p_tape_usage_data: ^iot$tape_usage_data,
      p_ud: ^iot$tape_job_unit_descriptor,
      path: ost$string,
      pp: 0 .. 0ff(16),
      results: bat$process_pt_results,
      statistic_code: sft$statistic_code,
      tusl_offset: iot$no_of_tape_units;

    status.normal := TRUE;
    p_ud := p_tape_request^.ud;

{   Push the package that is going to contain the usage statistics onto the stack.

    PUSH p_tape_usage_data;

{   Fill out the last used density for the tape unit in the usage statistic.

    CASE p_ud^.tape_unit_density OF

    = 0, 1 =
      p_tape_usage_data^.package.last_density := pe;

    = 2 =
      p_tape_usage_data^.package.last_density := nrzi;

    = 3 =
      p_tape_usage_data^.package.last_density := gcr;

    = 4 =
      p_tape_usage_data^.package.last_density := cart;

    ELSE

    CASEND;

{   Fill the counters for the usage statistic.

    p_tape_usage_data^.package.total_blocks_written := p_ud^.blocks_written;
    p_tape_usage_data^.package.total_blocks_read := p_ud^.blocks_read;
    p_tape_usage_data^.package.total_io_requests := p_ud^.io_requests_count;
    p_tape_usage_data^.package.accounting_blocks_skipped := p_ud^.blocks_skipped;
    p_tape_usage_data^.package.accounting_blocks_written := p_ud^.blocks_written_for_accounting;
    p_tape_usage_data^.package.accounting_blocks_read := p_ud^.blocks_read_for_accounting;
    p_tape_usage_data^.package.accounting_bytes_written := p_ud^.bytes_written;
    p_tape_usage_data^.package.accounting_bytes_read := p_ud^.bytes_read;

{ Free running clock time was saved at assign time in job unit descriptor.
    i := #free_running_clock (0);
    p_tape_usage_data^.package.seconds_tape_mounted := ((i - p_ud^.free_running_clock) DIV (1000000));

{   The following code was used to clear unused counters that no longer exist.
{   Clear the remaining unused words of tape_usage_statistic_data.
{
{   FOR i := ((#SIZE (p_tape_usage_data^.package) DIV 8) + 1) TO ioc$max_usage_counters DO
{     p_tape_usage_data^.counters_array [i] := novalue;
{   FOREND;

{   Set up the descriptive data for the usage statistic.

    logical_unit := p_tape_request^.request.logical_unit;
    pp := p_tape_request^.pp_response_p^.pp_no;
    iou_number := cmv$logical_pp_table_p^ [pp].pp_info.channel.iou_number;
    p_pp_interface_table := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;
    channel.number := p_pp_interface_table^.unit_descriptors [logical_unit].
          physical_path.channel_number;
    channel.port := cmc$unspecified_port;
    IF cmv$logical_pp_table_p^ [pp].pp_info.channel_interlock_p^.
          channel_characteristics [channel.number].concurrent_channel THEN
      channel.concurrent := TRUE;
      IF p_ud^.controller_type = cmc$mt5698_xx THEN
        IF p_pp_interface_table^.unit_descriptors [logical_unit].
              physical_path.port = 0 THEN
          channel.port := cmc$port_a;
        ELSE
          channel.port := cmc$port_b;
        IFEND;
      IFEND;
    ELSE
      channel.concurrent := FALSE;
    IFEND;

    equipment_number := p_pp_interface_table^.unit_descriptors
          [logical_unit].physical_path.controller_number;

    cmp$get_element_name_via_lun (logical_unit , element_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    found := FALSE;

  /get_tusl_offset/
    FOR tusl_offset := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
      IF element_name = iov$tusl_p^ [tusl_offset].element_name THEN
        found := TRUE;
        EXIT /get_tusl_offset/;
      IFEND;
    FOREND /get_tusl_offset/;

    IF NOT found THEN
      osp$set_status_abnormal ('io', ioc$unrecognized_unit_id,
            'unable to find tusl_entry in iop$tape_usage_logging', status);
      RETURN;
    IFEND;

    clp$check_name_for_path_handle (iov$tusl_p^ [tusl_offset].path_handle_name, file_path_handle);
    efr := fsv$evaluated_file_reference;
    efr.path_handle_info.path_handle := file_path_handle.regular_handle;
    efr.path_handle_info.path_handle_present := TRUE;
    fmp$process_pt_request ($bat$process_pt_work_list [bac$inhibit_locking_pt],
             osc$null_name, efr, cyc_descr, results, status);
    file_name := fsp$path_element (^efr, efr.number_of_path_elements) ^;

    cmp$return_descriptor_data (channel, iou_number, equipment_number, logical_unit, path, pp);

  /asterisk_loop/
    FOR i := path.size DOWNTO LOWERVALUE(path.size) DO
      IF (path.value (i, 1) = '*') THEN
        EXIT /asterisk_loop/
      IFEND;
    FOREND /asterisk_loop/;
    append_string_data (', ');
    append_string_data (iov$tusl_p^ [tusl_offset].evsn);
    append_string_data (', ');
    append_string_data (iov$tusl_p^ [tusl_offset].rvsn);
    append_string_data (', ');
    append_string_data (file_name);

    path.size := i - 1;

    p_counters_seq := ^p_tape_usage_data^.counters;

    RESET p_counters_seq;
    NEXT p_counters: [1 .. ioc$max_usage_counters] IN p_counters_seq;

    statistic_code := cml$tape_subsystem_usage_data;

    sfp$emit_statistic (statistic_code, path.value (1, path.size), p_counters, status);
{   IF NOT status.normal THEN
{     osp$system_error ('tape usage log emit error', ^status);
{   IFEND;

? ELSE
    status.normal := TRUE;
? IFEND

  PROCEND iop$tape_usage_logging;

?? OLDTITLE ??
?? NEWTITLE := ' iop$unload_tape ' ??
?? EJECT ??

  PROCEDURE [XDCL] iop$unload_tape (
        system_file_id: dmt$system_file_id;
        detachment_options: fmt$detachment_options;
    VAR io_id: iot$io_id;
    VAR status: ost$status);

    CONST
      disable_unit = FALSE,
      repeat_count = 1;

    VAR
      logical_unit: iot$logical_unit,
      physical_unload: boolean;

    BEGIN
      status.normal := TRUE;

      #INLINE ('keypoint', osk$entry, 0, ioc$tape_entry_ioptun);
      convert_sfid_to_lun (system_file_id, logical_unit, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF detachment_options.device_class = rmc$magnetic_tape_device THEN
        physical_unload := detachment_options.physical_unload;
      ELSE
        physical_unload := TRUE;
      IFEND;

      iop$67x_non_data_trans_setup (logical_unit, ioc$tape_unload, repeat_count, disable_unit,
            physical_unload, io_id, status);

      #INLINE ('keypoint', osk$exit, 0,
            ioc$tape_exit_ioptun);
    END
  PROCEND iop$unload_tape;

?? OLDTITLE ??
?? NEWTITLE := ' iop$update_block_count ' ??
?? EJECT ??
?  IF system_version THEN

{ The purpose of this procedure is to update the block count from loadpoint
{ after a fatal read parity error in which global error recovery is not attempted.
{ The call is made from bam$tape_block_manager_ring3 if option 2 (no recovery) is
{ made in response to the menu.
{ Note - For reel to reel tape, the block_id window is also updated to account for
{ the bad block.  It is assumed that the tape is positioned after the bad block.

  PROCEDURE [XDCL, #GATE] iop$update_block_count (
    sfid: dmt$system_file_id;
    VAR status: ost$status);

    VAR
      found: boolean,
      i: iot$no_of_tape_units,
      logical_unit: iot$logical_unit,
      p_ud: ^iot$tape_job_unit_descriptor;

      status.normal := TRUE;

      convert_sfid_to_lun (sfid, logical_unit, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Obtain pointer to tape job unit descriptor.

      i := 1;
      found := FALSE;
      WHILE (i <= UPPERBOUND (iov$p_statistic_data_p_array^)) AND (NOT found) DO
        IF logical_unit = iov$p_statistic_data_p_array^ [i]. logical_unit THEN
          found := TRUE;
        ELSE
          i := i + 1;
        IFEND;
      WHILEND;

      IF NOT found THEN
        osp$set_status_abnormal ('io', ioc$os_failure,
              'unable to find unit in iop$update_block_count', status);
        RETURN;
      IFEND;

      p_ud := iov$p_statistic_data_p_array^ [i].p_tape_job_unit_descriptor;

      p_ud^.block_count := p_ud^.block_count + 1;

      IF p_ud^.controller_type <> cmc$mt5680_xx THEN { update bid window for reel to reel tape
        p_ud^.bid_window [p_ud^.bid_index] := ioc$error_block_bid;
        IF p_ud^.bid_index <> UPPERVALUE(iot$bid_index) THEN
          p_ud^.bid_index := p_ud^.bid_index + 1;
        ELSE
          p_ud^.bid_index := LOWERVALUE(iot$bid_index);
        IFEND;
      IFEND;

  PROCEND iop$update_block_count;

?  IFEND

?? OLDTITLE ??
?? NEWTITLE := ' iop$write_tape ' ??
?? EJECT ??

? IF system_version THEN

  PROCEDURE [XDCL] iop$write_tape (system_file_id: dmt$system_file_id;
        inhibit_error_recovery: boolean;
        block_description: ^iot$write_tape_description;
        no_of_blocks_to_write: iot$tape_block_count;
    VAR io_id: iot$io_id;
    VAR status: ost$status);

    CONST
      write_request = TRUE;

    VAR
      address_pair_count: 0 .. mmc$max_rma_list_length,
      i: 0 .. 2 * ioc$max_tape_blocks_to_process,
      j: iot$tape_command_index,
      l: iot$tape_block_count,
      length: iot$transfer_count,
      offset: ost$segment_offset,
      p_tape_request: ^iot$tape_request,
      p_ud: ^iot$tape_job_unit_descriptor,
      page_offset: 0 .. 65536,
      pkt_length: iot$tape_request_length,
      tape_request_type: iot$tape_request_types,
      tape_unit_number: iot$logical_unit;

    BEGIN
      status.normal := TRUE;
      p_tape_request := NIL;
      io_id := 1;

      #INLINE ('keypoint', osk$entry, osk$m * no_of_blocks_to_write, ioc$tape_enter_ioptwr);

      tape_request_type := ioc$tape_write;
      convert_sfid_to_lun (system_file_id, tape_unit_number, status);
      IF status.normal THEN
        pkt_length := iov$67x_command_table [tape_request_type].length + (ioc$write_cmd_per_block * 8) *
              no_of_blocks_to_write;
        iop$tape_build_pp_req_header (tape_unit_number, pkt_length, p_tape_request, status);
      /build_request/
        BEGIN
          IF status.normal THEN

            io_id := p_tape_request^.io_id;
            address_pair_count := 0;
            p_ud := p_tape_request^.ud;
            j := iov$67x_command_table [tape_request_type].index;
            i := 0;
            FOR l := 1 TO no_of_blocks_to_write DO
              length := block_description^ [l].transfer_length;
              IF length > p_ud^.max_block_length THEN
                osp$set_status_abnormal ('IO', ioe$block_size_too_large, 'Block size is too large.', status);
                EXIT /build_request/
              IFEND;
              IF length < p_ud^.min_block_length THEN
                osp$set_status_abnormal ('IO', ioe$block_size_too_small, 'Block size too small.', status);
                EXIT /build_request/
              IFEND;
              offset := #OFFSET (block_description^[l].buffer_area);
              IF ((offset MOD 8) <> 0) THEN
                osp$set_status_abnormal ('IO', ioe$improper_data_address, 'Data buffer not word aligned.',
                     status);
                EXIT /build_request/
              IFEND;
              page_offset := offset MOD osv$page_size;
              address_pair_count := address_pair_count + (((page_offset + length - 1) DIV osv$page_size) + 1);
              p_tape_request^.request.tape_command [j + i].flags.store_response := FALSE;
              p_tape_request^.request.tape_command [j + i].flags.indirect_address := FALSE;
              p_tape_request^.request.tape_command [j + i].flags.fill := 0;
              IF p_ud^.controller_type = cmc$mt5698_xx THEN
                p_tape_request^.request.tape_command [j + i].command_code := ioc$cc_write_record;
                p_tape_request^.request.tape_command [j + i].length := 0;
                p_tape_request^.request.tape_command [j + i].address := length;
              ELSE
                p_tape_request^.request.tape_command [j + i].command_code := ioc$cc_function;
                p_tape_request^.request.tape_command [j + i].length := ioc$tape_function_code_length;
                p_tape_request^.request.tape_command [j + i].address :=
                      iov$67x_command_table [tape_request_type].hardware_command;
                IF ((length MOD 2) = 1) AND (p_ud^.controller_type = cmc$mt7221_2_s0) THEN
                  p_tape_request^.request.tape_command [j + i].address := ioc$67x_func_short_write;
                ELSEIF ((length MOD 3) = 2) AND NOT (p_ud^.controller_type = cmc$mt7221_2_s0) THEN
                  p_tape_request^.request.tape_command [j + i].address := ioc$67x_func_short_write;
                IFEND;
                IF (length > 65536) AND (p_ud^.controller_type = cmc$mt5680_xx) THEN
                  p_tape_request^.request.tape_command [j + i].address :=
                        p_tape_request^.request.tape_command [j + i].address + 100(8);
                IFEND;
              IFEND;
              p_tape_request^.request.tape_command [j + i + 1].command_code := ioc$cc_output_8_bit_data;
              p_tape_request^.request.tape_command [j + i + 1].flags.fill := 0;
              p_tape_request^.request.tape_command [j + i + 1].flags.store_response := FALSE;
              p_tape_request^.request.tape_command [j + i + 1].flags.indirect_address := TRUE;
              i := i + ioc$write_cmd_per_block;
            FOREND;
            IF address_pair_count > (osv$page_size DIV 8) THEN
              osp$set_status_abnormal ('IO', ioe$tape_rma_list_overflow,
                   'Page size will not accommodate RMA list', status);
              EXIT /build_request/
            IFEND;
            p_ud^.consecutive_erases := 0;
            p_tape_request^.estimated_address_pair_count := address_pair_count;
            p_tape_request^.write_block_description := block_description;
            p_tape_request^.no_of_data_commands := no_of_blocks_to_write;
            p_tape_request^.first_data_command := j + 1;
            p_tape_request^.request_type := ioc$tape_write;
            p_tape_request^.io_type := ioc$explicit_write;
            p_tape_request^.request.alert_mask.physical_delimiter := TRUE;
            p_tape_request^.inhibit_error_recovery := inhibit_error_recovery;
            IF inhibit_error_recovery THEN
              p_tape_request^.request.recovery := ioc$terminate_at_error;
            IFEND;
            p_tape_request^.initial_block_count := no_of_blocks_to_write;
            iop$tape_queue_request_setup (p_tape_request, status);
          IFEND;
        END /build_request/;
        IF (p_tape_request <> NIL) AND NOT status.normal THEN
          IF NOT p_tape_request^.must_free_pageable_request THEN
            p_tape_request^.ud^.pageable_tape_requests [p_tape_request^.pageable_tape_request_index].
                  slot_in_use := FALSE;
          ELSE
            FREE p_tape_request^.pp_response_p IN osv$job_pageable_heap^;
            FREE p_tape_request IN osv$job_pageable_heap^;
          IFEND;
        IFEND;
      IFEND;
      #INLINE ('keypoint', osk$exit, 0,
            ioc$tape_exit_ioptwr);
    END

  PROCEND iop$write_tape;

? IFEND

?? OLDTITLE ??
?? NEWTITLE := ' iop$write_tapemark ' ??
?? EJECT ??

? IF system_version THEN

  PROCEDURE [XDCL] iop$write_tapemark (system_file_id: dmt$system_file_id;
    VAR io_id: iot$io_id;
    VAR status: ost$status);

    CONST
      disable_unit = TRUE,
      physical_unload = FALSE,
      repeat_count = 1;

    VAR
      logical_unit_number: iot$logical_unit;

    BEGIN
      status.normal := TRUE;

      convert_sfid_to_lun (system_file_id, logical_unit_number, status);
      IF status.normal THEN
        iop$67x_non_data_trans_setup (logical_unit_number, ioc$tape_write_tapemark, repeat_count,
               disable_unit, physical_unload, io_id, status);
      IFEND;

      #INLINE ('keypoint', osk$exit, 0,
            ioc$tape_exit_ioptwtm);
    END

  PROCEND iop$write_tapemark;

? IFEND

*DECK DECK=IOK$KEYPOINTS EXPAND=FALSE

{ deck is IODKEY
{ PURPOSE:
{   This deck contains all of the physical i/o keypoint constants.

  CONST

{ ENTRY/EXIT CLASS KEYPOINTS

    iok$queue_request = iok$base,
    {E 'iop$queue_request' }
    {X 'iop$queue_request' 'track ' I20 }

    iok$io_completions = iok$base + 1,
    {E 'iop$process_io_completions' }
    {X 'iop$process_io_completions' }

    iok$mass_storage_io = iok$base + 2,
    {E 'iop$mass_storage_io' }
    {X 'iop$mass_storage_io' }

    iok$allocate_image_request = iok$base + 3,
    {E 'iop$allocate_image_requests' }
    {X 'iop$allocate_image_requests' }

    iok$queue_image_request = iok$base + 4,
    {E 'iop$queue_image_request' }
    {X 'iop$queue_image_request' }

    iok$idle = iok$base + 5,
    {E 'iop$idle' }
    {X 'iop$idle' }

    iok$idle_response = iok$base + 6,
    {E 'iop$process_idle_response' }
    {X 'iop$process_idle_response' }

    iok$process_io_response = iok$base + 7,
    {E 'iop$process_io_response' }
    {X 'iop$process_io_response' }

    iok$monitor_request = iok$base + 8,
    {E 'iop$monitor_request_processor' }
    {X 'iop$monitor_request_processor' }


{ UNUSUAL CLASS KEYPOINTS }

    iok$unrecovered_disk_error = iok$base,
    {U 'unrecovered disk error' 'response' I20 }

    iok$requests_full = iok$base + 1,
    {U 'request heap full' }

    iok$interlock_set = iok$base + 2,
    {U 'unit queue interlock set' 'unit_no ' I20 }


{ DEBUG CLASS KEYPOINTS }

    iok$pp_response = iok$base,
    {D 'pp response present' 'resp_len' I20 }

    iok$read_page = iok$base + 1,
    {D 'read disk request' 'length ' I20 }

    iok$write_page = iok$base + 2,
    {D 'write disk request' 'length ' I20 }

    iok$disk_request_1 = iok$base + 3,
    {R 'disk request 1' 'cyl lun ' I20 }

    iok$disk_request_2 = iok$base + 4,
    {R 'disk request 2' 'mau typ ' I20 }

    iok$disk_request_3 = iok$base + 5,
    {R 'disk request 3' 'cyl lun ' I20 }

    iok$disk_request_4 = iok$base + 6;
    {R 'disk request 4' 'ch e trf' I20 }


?? PUSH (LISTEXT := ON) ??
*copyc AMK$BASE_KEYPOINT_VALUES
?? POP ??
*DECK DECK=IOM$5680 EXPAND=TRUE
          IDENT  E2X5680
          CIPPU
          MEMSEL 4
          TITLE  IOM$5680 - 5680-1X CARTRIDGE TAPE SUBSYSTEM (CTS/CCC).
          COMMENT  *SMD* LVL=01
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  2
 PRGNAM   MICRO  1,4,'A680'  1ST 4 CHARACTERS OF OVERLAY NAME
          EJECT

          SPACE  4
***       IOM$5680.
*
*         THIS IS THE PP DRIVER FOR THE 5680-1X CARTRIDGE TAPE SUBSYSTEM/CCC
*         (CTS/CCC) THAT RUNS ON I2 AND I4X IOU-S. THIS DRIVER SUPPORTS BOTH
*         CIO AND NIO 170 CHANNELS. THIS DRIVER ALWAYS RUNS AS A DUAL PP
*         DRIVER AND USES OVERLAYS.
*
*         THE CIP MODULE NAME          = E2X5680
*         THE NOS/VE DECK NAME         = IOM$5680
*         THE NOS/VE IOU PROGRAM NAMES = E2A5680 (CIO)
*                                      = E2C5680 (NIO)
          SPACE  4
**        THE FOLLOWING EQUATE IS FOR OFF-LINE CMSE TESTING.

 OFFLINE  EQU    0           NZ=OFFLINE, 0=ONLINE NOS/VE
          SPACE  4
**        THE FOLLOWING EQUATES CONTROL LISTING OPTIONS, 1=LIST 0=NOLIST.

 LSTIM    EQU    1           LIST IODMAC1 THRU IODMAC5

 LSTRD    EQU    1           LIST CPU AND PP RECORD DESCRIPTORS
          SPACE  4
 .A       IFEQ   LSTIM,0     LSTIM LISTING CONTROL
          LIST   -$
 .A       ENDIF              LSTIM LISTING CONTROL
          TITLE  SYSTEM DEFINED MACRO IODMAC1.
*COPYC IODMAC1
          TITLE  SYSTEM DEFINED MACRO IODMAC2.
*COPYC IODMAC2
          TITLE  SYSTEM DEFINED MACRO IODMAC3.
*COPYC IODMAC3
          TITLE  SYSTEM DEFINED MACRO IODMAC4.
*COPYC IODMAC4
          TITLE  SYSTEM DEFINED MACRO IODMAC5.
*COPYC IODMAC5
          SPACE  4
          LIST   B,L,N,R
 .B       IFEQ   LSTRD,0     LSTRD LISTING CONTROL
          LIST   -$
 .B       ENDIF              LSTRD LISTING CONTROL
          TITLE  CPU RECORD DESCRIPTIONS.
*         PP INTERFACE TABLE.

 PIT      RECORD PACKED

* CM WORD 1
          ALIGN  0,64
 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS

* CM WORD 2
          ALIGN  0,64
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)

* CM WORD 3
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)

* CM WORD 4
          ALIGN  0,64
 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER

* CM WORD 5
          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)

* CM WORD 6
          ALIGN  32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)

* CM WORDS 7-8
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)

* CM WORD 9
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)

* CM WORD 10
          ALIGN  48,64
 IN       PPWORD             IN POINTER

* CM WORD 11
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER

* CM WORD 12
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          EJECT
*         UNIT DESCRIPTOR (CM).

 UD       RECORD PACKED

* CM WORD 1
          ALIGN  0,64
 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)

* CM WORD 2
          ALIGN  0,64
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 UD       RECEND
          SPACE 5
*         PP UNIT DESCRIPTOR (ONLY SECOND CM WORD OF UNIT DESCRIPTOR).

 PUD      RECORD PACKED

          ALIGN  0,64
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 PUD      RECEND
          EJECT
*         PP COMMUNICATION BUFFER.

 CB       RECORD PACKED

* CM WORD 1
          ALIGN  31,64
 SLAVE    BOOLEAN            NONZERO IF SLAVE PP
 PARTNR   RMA                PARTNERS PIT (RMA)

* CM WORD 2
          ALIGN  0,64
 CONTRL   STRUCT 8           LOAD CONTROLWARE COMMAND

* CM WORD 3
          ALIGN  0,64
 CMCMD    STRUCT 8           SLAVE COMMAND        (NOT USED)

* CM WORD 4
          ALIGN  0,64
 ODP      STRUCT 8           OVERLAY DIRECTORY RMA

* CM WORD 5-9
          ALIGN  0,64
 FILL1    STRUCT 40          UNUSED

* CM WORDS 10-11
          ALIGN  0,64
 COMM     STRUCT 16          MASTER/SLAVE COMMUNICATION AREA

* CM WORDS 12-13
          ALIGN  0,64
 SCRAT    STRUCT 16          SCRATCH AREA

* CM WORDS 14-28
          ALIGN  0,64
 ZEROES   STRUCT 120         120 BYTES (15 CM WORDS) OF ZERO
          SPACE  3
          MASKP  SLAVE
 K.SLAVE  EQU    MSK

 CB       RECEND
          EJECT
*         UNIT INTERFACE TABLE.

 UIT      RECORD PACKED

* CM WORD 1
          ALIGN  0,64
 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
                               = 22B, 5680-1X

* CM WORD 2
          ALIGN  16,64
 UBUFL    PPWORD             UNIT COMMUNICATION BUFFER LENGTH
 UBUF     RMA                UNIT COMMUNICATION BUFFER (RMA)

* CM WORD 3
          ALIGN  0,64
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER

* CM WORD 4
          ALIGN  0,64
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER

* CM WORD 5
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)

* CM WORD 6
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

          MASKP  DSABLE
 K.DSABLE EQU    MSK

 UIT      RECEND
          EJECT
*         UNIT COMMUNICATION AREA.

 UCA      RECORD PACKED

* CM WORD 1
          ALIGN  16,64
 SYNC     STRUCT 6           SYNCHRONIZE PVA OF AN OUTSTANDING WRITE WHEN
                              NO MORE DATA IS POSSIBLE OR A FORCED WRITE.
                              THE PP NEVER UPDATES THIS CM WORD.

* CM WORD 2
          ALIGN  0,64
 ACTCNT   PPWORD             ACTIVE COUNT OF BUFFERED WRITE REQUESTS

**        NOTE - THE REMAINDER OF THE UCA IS INVALID IF ACTCNT = 0.

 INP      PPWORD             UCA RESPONSE BUFFER IN POINTER
 OUTP     PPWORD             UCA RESPONSE BUFFER OUT POINTER
 TPF      PPWORD             TAPE POSITION FLAG

* CM WORD 3
          ALIGN  32,64
 PRMA     RMA                PREVIOUS REQUEST RMA

* CM WORD 4
          ALIGN  16,64
 CPVA     STRUCT 6           CURRENT REQUEST PVA

* CM WORD 5
          ALIGN  32,64
 CRMA     RMA                CURRENT REQUEST RMA

* CM WORDS 6-19
          ALIGN  0,64
 URB1     STRUCT 112         FIRST UCA RESPONSE BUFFER

* CM WORDS 20-33
          ALIGN  0,64
 URB2     STRUCT 112         NEXT UCA RESPONSE BUFFER

* CM WORDS 34-47
          ALIGN  0,64
 URB3     STRUCT 112         NEXT UCA RESPONSE BUFFER

* CM WORDS 48-54
          ALIGN  0,64
 ERRSTA   STRUCT 56          ERROR STATUS ON WRITES

* CM WORDS 55-64
          ALIGN  0,64
 FILL1    STRUCT 80          RESERVED

 UCA      RECEND
          EJECT
*         URB RESPONSE BUFFER.

 URB      RECORD PACKED

* CM WORD 1
          ALIGN  0,64
 CONF     PPWORD             CONNECT FUNCTION FOR THIS REQUEST
 WRTCNT   PPWORD             WRITE RECORD COUNTER THIS REQUEST
 UCMDA    PPWORD             SAVED CMDADDR FOR THIS REQUEST
 FILL1    PPWORD             RESERVED

* CM WORD 2
          ALIGN  0,64
 SBID     STRUCT 4           STARTING BLOCK ID OF REQUEST
 EBID     STRUCT 4           ENDING BLOCK ID OF REQUEST

* CM WORDS 3-14
          ALIGN  0,64
 RESP     STRUCT 96          RESPONSE SAVED FOR ACTIVE REQUEST

 URB      RECEND
          EJECT
*         REQUEST QUEUE.

 RQ       RECORD PACKED

* CM WORD 1
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)

* CM WORD 2
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

* CM WORD 3
          ALIGN  0,64
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS
                               0 - ENABLE CU RECOVERY.
                               1 - DISABLE CU RECOVERY.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
 ALRTM    PPWORD             ALERT MASK (SEE *RS* ALERT CONDITIONS)

* CM WORD 4
          ALIGN  0,64
 SECADR   INTEGER            SECONDARY ADDRESS

* CM WORD 5-64               COMMANDS
          ALIGN  0,64
 CMND     INTEGER            COMMANDS

 RQ       RECEND
          SPACE  3
*         COMMANDS.

 CM       RECORD PACKED

* CM WORD OF 5-64 IN THE REQUEST QUEUE
          ALIGN  0,64
 CODE     SUBRANGE 0,377B    COMMAND CODE
 FILL1    BOOLEAN            UNUSED
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$

 CM       RECEND
          EJECT
*         PP RESPONSE.

 RS       RECORD PACKED

* CM WORD 1
          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST

* CM WORD 2
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST

* CM WORD 3
          ALIGN  0,64
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
 ALRTM    PPWORD             ALERT MASK (SEE ALERT CONDITIONS)

* CM WORD 4
          ALIGN  0,64        ABNORMAL STATUS
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED
 INTERR   BOOLEAN            LOGICIAL INTERFACE ERROR
 FILL2    BOOLEAN            UNUSED
 FILL3    BOOLEAN            UNUSED
 FILL4    BOOLEAN            UNUSED
 FILL5    BOOLEAN            UNUSED
 HDWR     BOOLEAN            HARDWARE ERROR DETECTED
          ALIGN  16,64
 FILL6    PPWORD             UNUSED
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE (UNUSED)

          ALIGN  48,64       ALERT CONDITIONS
 LNGBLK   BOOLEAN            LONG INPUT BLOCK
 FILL7    BOOLEAN            UNUSED
 PDLIM    BOOLEAN            PHYSICAL DELIMITER ENCOUNTERED (EOT OR BOT)
 LDLIM    BOOLEAN            LOGICAL DELIMITER ENCOUNTERED (TAPE MARK)
 FILL8    BOOLEAN            UNUSED
 DUNIT    BOOLEAN            UNIT WAS DISABLED BY PP

* CM WORD 5
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)

* CM WORD 6
          ALIGN  0,64
*         GENERAL STATUS WORD 1
 GS1      SUBRANGE 0,17B     UNUSED BITS

 ALERT    BOOLEAN            ALERT CONDITION
 CONT     BOOLEAN            SEND CONTINUE FUNCTION
 ONE      BOOLEAN            ALWAYS SET
 T18      BOOLEAN            18 TRACK DEVICE
 WRTEN    BOOLEAN            WRITE ENABLED
 WFC      BOOLEAN            WAIT FOR *CONT* STATUS
 CHRF     BOOLEAN            CHARACTER FILL
 TM       BOOLEAN            TAPE MARK
 EOT      BOOLEAN            END OF TAPE (LOGICIAL)
 BOT      BOOLEAN            BEGINNING OF TAPE (LOGICIAL)
 BSY      BOOLEAN            BUSY
 RDY      BOOLEAN            READY

                             SPECIAL GS1 WORDS WHEN GS2 = 0000
                             OCTAL
                             7777 = AUTOLOAD FUNCTION TIMEOUT
                             7776 = OUTPUT CHANNEL ERROR FLAG SET
                             7775 = INPUT CHANNEL ERROR FLAG SET
                             7774 = CY170 CIO CHANNEL ADAPTER ERROR
                             7773 = CIO CHANNEL FUNCTION ERROR FLAG SET
                             7772 = STATUS FUNCTION TIMEOUT AFTER AUTOLOAD
                             7771 = INCOMPLETE TRANSFER DURING AUTOLOAD
                             5XXX = AUTOLOAD ERROR CODE

*         GENERAL STATUS WORD 2
 GS2      SUBRANGE 0,17B     UNUSED BITS

 ADPTC    BOOLEAN            ADAPTER CHECK
 UNITC    BOOLEAN            UNIT CHECK
 EQUIPC   BOOLEAN            EQUIPMENT CHECK
 DATAC    BOOLEAN            DATA CHECK
 DFRDC    BOOLEAN            DEFERRED UNIT CHECK

 EC       SUBRANGE 0,177B    ERROR CODE

          ALIGN  32,64
 LGBID    STRUCT 4           LAST GOOD BLOCK-ID

* CM WORD 7
          ALIGN  0,64
 REID     PPWORD             RESPONSE ERROR ID
 LSTF     PPWORD             LAST FUNCTION CODE ISSUED
 LSTNSF   PPWORD             LAST NON STATUS FUNCTION CODE ISSUED
 CESR     PPWORD             CIO CHANNEL ERROR STATUS REGISTER

* CM WORDS 8-12
          ALIGN  0,64
 DSB      STRUCT 40          DETAILED STATUS (112) WORDS 1-26 (12-BIT) PACKED

* CM WORDS 13-18
          ALIGN  0,64
 ELB      STRUCT 48          ERROR LOG (312) WORDS 1-32 (12-BIT) PACKED
          SPACE  4
*         RESPONSE HEADER EQUATES
          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$
          MASKP  ABALRT
 K.ABALRT EQU    MSK
          MASKP  HDWR
 K.HDWR   EQU    MSK
          MASKP  INTERR
 K.INTERR EQU    MSK
          MASKP  LNGBLK
 K.LNGBLK EQU    MSK
          MASKP  PDLIM
 K.PDLIM  EQU    MSK
          MASKP  LDLIM
 K.LDLIM  EQU    MSK
          MASKP  DUNIT
 K.DUNIT  EQU    MSK
          SPACE  3
*         GENERAL STATUS WORD 1 EQUATES
          MASKP  ALERT
 K.ALERT  EQU    MSK
          MASKP  CONT
 K.CONT   EQU    MSK
          MASKP  T18
 K.T18    EQU    MSK
          MASKP  WRTEN
 K.WRTEN  EQU    MSK
          MASKP  WFC
 K.WFC    EQU    MSK
          MASKP  CHRF
 K.CHRF   EQU    MSK
          MASKP  TM
 K.TM     EQU    MSK
          MASKP  EOT
 K.EOT    EQU    MSK
          MASKP  BOT
 K.BOT    EQU    MSK
          MASKP  BSY
 K.BSY    EQU    MSK
          MASKP  RDY
 K.RDY    EQU    MSK
          SPACE  3
*         GENERAL STATUS WORD 2 EQUATES
          MASKP  ADPTC
 K.ADPTC  EQU    MSK
          MASKP  UNITC
 K.UNITC  EQU    MSK
          MASKP  EQUIPC
 K.EQUIPC EQU    MSK
          MASKP  DATAC
 K.DATAC  EQU    MSK
          MASKP  DFRDC
 K.DFRDC  EQU    MSK

          MGEN   N.EC
 M.EC     EQU    MASK$


 RS       RECEND
          EJECT
*         DETAILED STATUS.

 DS       RECORD PACKED

 SBS      STRUCT 32          32 SENSE BYTES
 FILL1    STRUCT 1           UNUSED
 REV      SUBRANGE 0,7B      CCC MICROCODE REVISION NUMBER
 FUN      SUBRANGE 0,777B    LAST CCC FUNCTION CODE
 C170     SUBRANGE 0,7777B   C170-DI STATUS
 FSC      SUBRANGE 0,7777B   FSC-DI STATUS
 FILL2    SUBRANGE 0,3B      UNUSED
 SN       SUBRANGE 0,1777B   CCC SERIAL NUMBER
 FILL3    STRUCT 1           UNUSED


                             DSB+00 = XX (SB00), XX (SB01)
                             DSB+01 = XX (SB02), XX (SB03)
                             DSB+02 = XX (SB04), XX (SB05)
                             DSB+03 = XX (SB06), XX (SB07)
                             DSB+04 = XX (SB08), XX (SB09)
                             DSB+05 = XX (SB10), XX (SB11)
                             DSB+06 = XX (SB12), XX (SB13)
                             DSB+07 = XX (SB14), XX (SB15)
                             DSB+08 = XX (SB16), XX (SB17)
                             DSB+09 = XX (SB18), XX (SB19)
                             DSB+10 = XX (SB20), XX (SB21)
                             DSB+11 = XX (SB22), XX (SB23)
                             DSB+12 = XX (SB24), XX (SB25)
                             DSB+13 = XX (SB26), XX (SB27)
                             DSB+14 = XX (SB28), XX (SB29)
                             DSB+15 = XX (SB30), XX (SB31)
                             DSB+16 = 0 (8 BITS), REV (3 BITS)
                              THRU  = FUN (9 BITS), C170-DI (12 BITS)
                                    = FSC-DI (12 BITS), 0 (2 BITS)
                             DSB+19 = S/N (10 BITS), 0 (8 BITS)


 DS       RECEND
          EJECT
*         BUFFERED ERROR LOG.

 BEL      RECORD PACKED

 TRDC     STRUCT 2           READ DATA CHECKS
 TRBDC    STRUCT 2           READ BACKWARD DATA CHECKS
 TWDC     STRUCT 2           WRITE DATA CHECKS
 RBC      STRUCT 2           READ BLOCKS CORRECTED

 WBC      STRUCT 2           WRITE BLOCKS CORRECTED
 TCUE     STRUCT 2           CU ERRORS
 RBYP     STRUCT 4           READ BYTES PROCESSED

 WBYP     STRUCT 4           WRITE BYTES PROCESSED
 RBLP     STRUCT 2           READ BLOCKS PROCESSED
 WBLP     STRUCT 2           WRITE BLOCKS PROCESSED

 TWCW     STRUCT 2           WRITE DATA CHECKS WITHOUT HARDWARE BIT
 TRCW     STRUCT 2           READ DATA CHECKS WITHOUT HARDWARE BIT
 EG       STRUCT 2           ERASE GAP COUNTS
 TDE      STRUCT 2           DRIVE ERRORS

 CUECL    SUBRANGE 0,3B      CU EC LEVEL
 FILL1    SUBRANGE 0,1B      UNUSED
 CUSNH    SUBRANGE 0,37B     CU S/N HIGH ORDER BITS
 FILL2    STRUCT 1           UNUSED
 CUSNL    STRUCT 2           CU S/N LOW ORDER BITS
 RRRC     STRUCT 1           READ RECOVERY RETRY COUNT
 FILL3    STRUCT 1           UNUSED
 FILL4    STRUCT 2           UNUSED

 FILL5    STRUCT 8           UNUSED


 BEL      RECEND
          SPACE  4
          LIST   B,L,N,R     END OF LISTING CONTROL
          TITLE  LOCAL EQUATES.
*         REQUEST COMMANDS.
 FUNCCMD  EQU    40B         PHYSICAL COMMAND - FUNCTION (20 HEX)
 PWRTCMD  EQU    43B         PHYSICAL COMMAND - OUTPUT 8-BIT DATA (23 HEX)
 IDLCMD   EQU    4           PP IDLE COMMAND (04 HEX)
 RSUMCMD  EQU    5           PP RESUME COMMAND (05 HEX)
 LCREAD   EQU    101B        LOCICAL READ RECORD OF 8-BIT DATA (41 HEX)
 LCSTC    EQU    141B        LOGICAL COMMAND STORE TRANSFER COUNT (61 HEX)
 LCLB     EQU    231B        LOGICIAL COMMAND LOCATE BLOCK (99 HEX)
          SPACE  2
*         COMMAND FLAGS.
 INDFLG   EQU    100B        INDIRECT ADDRESSING FLAG
          SPACE  2
*         RESPONSE CODES.
 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    40000B      INTERMEDIATE RESPONSE
 R.NRM    EQU    100000B     NORMAL REQUEST TERMINATION
 R.ABN    EQU    140000B     ABNORMAL REQUEST TERMINATION
          SPACE  2
*         RESPONSE LENGTHS.
 NORMRES  EQU    /RS/C.DSB*8  LENGTH OF NORMAL RESPONSE BUFFER IN BYTES
 NRESW    EQU    NORMRES/8    LENGTH OF NORMAL RESPONSE BUFFER IN WORDS
 ABNRES   EQU    /RS/C.ELB*8  LENGTH OF ABNORMAL RESPONSE BUFFER IN BYTES
 UNLRES   EQU    B.RS         LENGTH OF UNLOAD RESPONSE BUFFER IN BYTES
          SPACE  2
*         RESPONSE ERROR ID-S.
 REIZERO  EQU    0           NO ERROR ID
 REIIND   EQU    1           INDETERMINATE
 REIICP   EQU    2           INPUT CHANNEL PARITY
 REIOCP   EQU    3           OUTPUT CHANNEL PARITY
 REICF    EQU    4           COUPLER FAILURE
 REICUF   EQU    5           CONTROL UNIT FAILURE
 REIUF    EQU    6           UNIT FAILURE
 REIUNR   EQU    7           UNIT NOT READY
 REIFT    EQU    8           FUNCTION TIMEOUT OR RETRY/CONTINUE LIMIT
 REITMF   EQU    9           TAPE MEDIUM FAILURE
 REIIPE   EQU    10          IOU PARITY ERROR
 REIIOP   EQU    11          INDETERMINATE OUTPUT PARITY
 REIUWI   EQU    12          UNABLE TO WRITE ID MARK
 REIURI   EQU    13          UNABLE TO READ ID MARK
 REIHC    EQU    14          HARDWARE CORRECTIONS
 REIMLE   EQU    15          MICROCODE LOAD ERRORS
 REIBII   EQU    16          BLOCK ID INVALID
 REIRCI   EQU    17          RESIDUAL WORD COUNT INPUT ERROR
 REIRCO   EQU    18          RESIDUAL WORD COUNT OUTPUT ERROR
 REIFE    EQU    19          READ OR WRITE FLAG ERROR
 REISPP   EQU    20          SINGLE PP I/F ERROR
 REIWUT   EQU    21          WRONG UNIT TYPE I/F ERROR
 REINSC   EQU    22          NON-SUPPORTED COMMAND I/F ERROR
 REIBLE   EQU    23          PP OR UNIT COMMUNICATION BUFFER LENGTH ERROR
 REIICS   EQU    24          INVALID COMMAND SEQUENCE WHILE WRITING
          SPACE  2
*         I/O CHANNEL NUMBER.
 TP       EQU    37B         CHANNEL NUMBER
          SPACE  2
*         CIO CHANNEL FUNCTION CODES.
 F.MCLEAR EQU    100000B     MASTER CLEAR CIO ADAPTER BOARD
 F.WRCR   EQU    111000B     WRITE CONTROL REGISTER OF CIO ADAPTER
 F.RDESR  EQU    112000B     READ ERROR STATUS REGISTER OF CIO ADAPTER
          SPACE  2
*         UNIT TYPE.
 T5680    EQU    22B         UIT UNIT TYPE FOR 5680-1X CTS/CCC
          SPACE  2
*         CCC FUNCTION CODES.
 F.CLR    EQU    000B        CLEAR UNIT  (NOT USED)
 F.REL    EQU    001B        RELEASE UNIT
 F.CNT    EQU    002B        CONTINUE
 F.SYN    EQU    003B        SYNCHRONIZE UNIT
 F.REW    EQU    010B        REWIND
 F.UNL    EQU    110B        UNLOAD
 F.SRS    EQU    011B        SELECTIVE RESET UNIT  (NOT USED)
 F.GS     EQU    012B        GENERAL STATUS
 F.DS     EQU    112B        DETAILED STATUS
 F.RBID   EQU    212B        READ BLOCK-ID
 F.RBEL   EQU    312B        READ BUFFERED ERROR LOG
 F.FSB    EQU    013B        FORESPACE BLOCK
 F.BSB    EQU    113B        BACKSPACE BLOCK
 F.FTM    EQU    015B        FORESPACE TAPE MARK
 F.BTM    EQU    115B        BACKSPACE TAPE MARK
 F.LB     EQU    016B        LOCATE BLOCK
 F.SEL    EQU    020B        SELECT UNIT (X2U)
 F.RDF    EQU    040B        READ FORWARD
 F.RDR    EQU    140B        READ REVERSE  (NOT USED)
 F.WRT    EQU    050B        WRITE FORWARD
 F.SWRT   EQU    250B        SHORT WRITE FORWARD
 F.WTM    EQU    051B        WRITE TAPE MARK
 F.ERS    EQU    052B        ERASE
 F.DSE    EQU    252B        DATA SECURITY ERASE  (NOT USED)
 F.MC     EQU    414B        MASTER CLEAR OR AUTOLOAD
          SPACE  2
*         CCC ERROR CODES.
 EC00     EQU    00B         NO ERROR
 EC01     EQU    01B         CONNECT REJECTED, OFF-LINE OR POWER OFF
 EC03     EQU    03B         PHYSICAL END OF TAPE
 EC04     EQU    04B         FUNCTION REJECT, UNIT NOT READY
 EC05     EQU    05B         UNIT DROPPED READY
 EC06     EQU    06B         WRITE REJECT, UNIT NOT WRITE ENABLED
 EC07     EQU    07B         NOT CAPABLE OF READING TAPES DENSITY
 EC10     EQU    10B         BLANK TAPE (TAPE VOID)
 EC12     EQU    12B         UNABLE TO WRITE FROM BOT
 EC30     EQU    30B         BACKWARD MOTION AT BOT
 EC32     EQU    32B         TAPE UNIT BUSY
 EC33     EQU    33B         CONNECT REJECT, CONTROL UNIT BUSY
 EC50     EQU    50B         UNRECOGNIZED FUNCTION CODE
 EC51     EQU    51B         NO TAPE UNIT CONNECTED
 EC52     EQU    52B         NO FUNCTION PARAMETERS SENT
 EC53     EQU    53B         ILLEGAL FUNCTION DURING CMD RETRY IDLE
 EC54     EQU    54B         CONTINUE FUNCTION SENT WHEN NOT IN CMD RETRY IDLE
 EC55     EQU    55B         ILLEGAL FUNCTION SENT DURING BUSY RETRY
                             ERROR CODES 150-177B CCC SPECIFIC.
          SPACE  2
*         MISC.
 CNTLBL   EQU    60*4        CONTROLWARE BUFFER LENGTH IN PP WORDS
 DUALBUFL EQU    480         LENGTH OF PP I/O BUFFER IN PP WORDS
 ENDMEM   EQU    7777B       LARGEST PP MEMORY ADDRESS
 F.FU67   EQU    4B          ATS FORMAT FUNCTION CODE
 HSHAKC   EQU    377B        HAND SHAKE COMMAND
 MAXIND   EQU    5           MAX INDIRECT LIST LENGTH
 MAXREQ   EQU    65          MAX REQUEST LENGTH IN CM WORDS
 NCCOMD   EQU    376B        NEW CHANNEL COMMAND
 RBIDU    EQU    0#0100      REWIND (BOT) BLOCK ID UPPER
 RBIDL    EQU    0#0000      REWIND (BOT) BLOCK ID LOWER
 WDCOUNT  EQU    640         640 CHANNEL WORDS = 960 BYTES
          SPACE  2
*         LDN EQUATES.
 ZERO     EQU    0           VALUE 0
 ONE      EQU    1           VALUE 1
 TWO      EQU    2           VALUE 2
 THREE    EQU    3           VALUE 3
 FOUR     EQU    4           VALUE 4
          SPACE  2
*         PLUGGED INSTRUCTIONS.
 PSNI     EQU    2400B       PSN INSTRUCTION
 INPNI    EQU    102600B     INPN INSTRUCTION
          SPACE  2
*         DRIVER ERROR CODES.
 ERC101   EQU    1           PP REQUEST QUEUE LOCKWORD TIMEOUT
 ERC102   EQU    ERC101+1    UNIT REQUEST QUEUE LOCKWORD TIMEOUT
 ERC103   EQU    ERC102+1    UNIT LOCKWORD TIMEOUT
 ERC104   EQU    ERC103+1    CHANNEL LOCKWORD TIMEOUT
 ERC105   EQU    ERC104+1    BUFFER POOL LOCKWORD TIMEOUT
 ERC106   EQU    ERC105+1    UNIT HARDWARE RESERVE TIMEOUT
 ERC201   EQU    1           RESERVED FIELD OF PP INT TBL HEAD NOT 0
 ERC202   EQU    ERC201+1    RMA OF UNIT ACTIVITY MASK NOT A WORD BOUNDARY
 ERC203   EQU    ERC202+1    RMA OF PP COMM BUF NOT A WORD BOUNDARY
 ERC204   EQU    ERC203+1    RESERVED FIELD OF PP COMM DESCRIPTOR NOT 0
 ERC205   EQU    ERC204+1    RESERVED FIELD OF QUEUE DESCRIPTOR NOT 0
 ERC206   EQU    ERC205+1    RMA OF NEXT PP NOT A WORD BOUNDARY
 ERC207   EQU    ERC206+1    RESERVED FIELD OF RESP BUF DESCRIPTOR NOT 0
 ERC208   EQU    ERC207+1    LOGICAL UNIT OUT OF RANGE
 ERC209   EQU    ERC208+1    RMA OF UIT NOT A WORD BOUNDARY
 ERC301   EQU    1           LOGICAL UNIT NUMBER MISMATCH
 ERC302   EQU    ERC301+1    RMA OF UNIT COMM BUF NOT A WORD BOUNDARY
 ERC303   EQU    ERC302+1    RESERVED FIELD OF UNIT COMM BUF DESCRIPTOR NOT 0
 ERC304   EQU    ERC303+1    RMA OF NEXT UNIT REQUEST NOT WORD BOUNDARY
 ERC305   EQU    ERC304+1    RESERVED FIELD OF QUEUE DESCRIPTOR NOT 0
 ERC306   EQU    ERC305+1    RESERVED FIELD IN HEADER NOT ZERO
 ERC401   EQU    1           RMA OF NEXT REQUEST NOT A WORD BOUNDARY
 ERC402   EQU    ERC401+1    REQUEST LENGTH NOT A MULTIPLE OF 8 BYTES
 ERC403   EQU    ERC402+1    REQUEST LENGTH IS LESS THAN FOURTY BYTES
 ERC404   EQU    ERC403+1    LOGICAL UNIT NO .NE. UNIT NO IN INTERFACE TBL
 ERC405   EQU    ERC404+1    RESERVED LINKAGE FIELD IS NOT ZERO
 ERC406   EQU    ERC405+1    INVALID RECOVERY/INTERFACE SELECTIONS
 ERC407   EQU    ERC406+1    INVALID PRIORITY SELECTION
 ERC408   EQU    ERC407+1    INVALID SECONDARY ADDRESS
 ERC409   EQU    ERC408+1    INVALID ALERT CONDITION
 ERC501   EQU    1           INVALID COMMAND CODE
 ERC502   EQU    ERC501+1    INVALID FLAG SELECTION
 ERC503   EQU    ERC502+1    INVALID FUNCTION
 ERC504   EQU    ERC503+1    FUNCTION NOT SUPPORTED BY HARDWARE
 ERC505   EQU    ERC504+1    INVALID LENGTH SPECIFICATION IN COMMAND
 ERC506   EQU    ERC505+1    INVALID ADDRESS SPECIFICATION IN COMMAND
 ERC507   EQU    ERC506+1    INVALID LENGTH SPECIFICATION IN INDIRECT LIST
 ERC508   EQU    ERC507+1    INVALID ADDRESS SPECIFICATION IN INDIRECT LIST
 ERC509   EQU    ERC508+1    PP COMMAND NOT ALLOWED IN REQUEST TO A UNIT
 ERC50A   EQU    ERC509+1    INVALID SEQUENCE OF COMMANDS
 ERC50B   EQU    ERC50A+1    INVALID PARAMETER SPECIFICATION
          TITLE  LOCAL MACROS.
**        SUBR - DEFINE SUBROUTINE ENTRY/EXIT.
*
*NAME     SUBR
*         DECLARE *NAME* TO BE THE ENTRY POINT TO A PP SUBROUTINE
*         WHICH IS ENTERED VIA *RJM* TO *NAME*.
*
*         THE FOLLOWING CODE IS GENERATED.
*NAMEX    LJM    *
*NAME     EQU    *-1

          PURGMAC  SUBR

          MACRO  SUBR,A
 A_X      LJM    *
 A        EQU    *-1
          ENDM
          TITLE  PP DIRECT CELLS.
 T0       CON    INIT-1      START OF ON-LINE DRIVER

 T1       BSSZ   1           SCRATCH CELLS
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 AREG     BSSZ   1           I/O A REGISTER RESIDUAL
 BYTCNT   BSSZ   1           NUMBER OF BYTES TO TRANSFER THIS I/O
 CHTYPE   BSSZ   1           CHANNEL TYPE  0=NIO  1=CIO
 CM.CHAN  BSSZ   3           CM ADDRESS OF CHANNEL TABLE
 CM.COM   BSSZ   3           CM ADDRESS OF PP COMMUNICATION BUFFER (MASTERS)
 CM.INT   BSSZ   3           CM ADDRESS OF INTERRUPT TABLE
 CM.PIT   BSSZ   3           CM ADDRESS OF PP INTERFACE TABLE (MASTERS)
 CM.RS    BSSZ   3           CM ADDRESS OF RESPONSE BUFFER
 CM.UCA   BSSZ   3           CM ADDRESS OF UNIT COMMUNICATION AREA
 CM.UIT   BSSZ   3           CM ADDRESS OF UNIT INTERFACE TABLE
 CMADR    BSSZ   3           CENTRAL MEMORY ADDRESS
 CMDADR   BSSZ   1           ADDRESS OF ACTIVE COMMAND
 CMDNO    BSSZ   1           NO OF REMAINING COMMANDS
 CONFLG   BSSZ   1           UNIT CONNECTED FLAG
 FRELF    BSSZ   1           FORCE RELEASE FLAG
 IOCNT    BSSZ   1           NUMBER OF PP WORDS TO TRANSFER THIS I/O
 LIM      BSSZ   1           LIMIT OF RESPONSE BUFFER
 LMCFLG   BSSZ   1           LOAD MICROCODE FLAG
 LONG     BSSZ   1           LONG INPUT BLOCK FLAG
 MOTION   BSSZ   1           TAPE MOTION FLAG
 P1       BSSZ   1           PARAMETER CELLS
 P2       BSSZ   1
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 TRNCNT   BSSZ   4           TOTAL TRANSFER COUNT IN BYTES
 UDPNT    BSSZ   1           UNIT DESCRIPTOR POINTER
 UNITP    BSSZ   1           UNIT POINTER
 WC       BSSZ   1           CM WORD COUNT

 ENDDIR   EQU    *-1         END OF CELLS TO CLEAR ON RESUME COMMAND

 ON       CON    ONE         CONSTANT ONE (DO NOT CHANGE THIS CELL)
 TW       CON    TWO         CONSTANT TWO (DO NOT CHANGE THIS CELL)
 DSRTP    CON    0,0         REAL MEMORY WORD-ADDRESS OF PIT (PLUGGED)
 IDLFLG   BSSZ   1           PP IDLE FLAG, 0=RUNNING, 1=IDLE, 2=RESUME
 CHLOCK   BSSZ   1           CHANNEL LOCK FLAG
 PPNO     CON    5           LOGICAL PP NUMBER
 ID       CON    177777B     IDENTIFICATION (DM=MASTER, DS=SLAVE)

          ERRNZ  DSRTP-72B   MUST BE AT LOCATION 72, PLUGGED WHEN LOADED
          TITLE  ID, OFF-LINE ENTRY POINT AND WORKING MEMORY.
          SPACE  4
**        IDENTIFICATION.

          DATA   H*5680*     IDENTIFICATION NAME
          SPACE  4
**        OFF-LINE ENTRY POINT OF DRIVER.

 START    LJM    INIT        GO INITIALIZE DRIVER
          ERRNZ  START-102B  MUST BE AT 102B
          SPACE  4
**        WORKING MEMORY.

 UITHDR   BSSZ   8           UIT HEADER, FIRST TWO CM WORDS

 UCAHDR   BSSZ   /UCA/P.CRMA+2  UCA HEADER TABLE (CM WORDS THRU CRMA)
          TITLE  MASTER PP MAIN IDLE LOOP.
          SPACE 4
**        NOTE - THIS IS THE START OF THE SLAVE CODE OVERLAY BUFFER.
          SPACE  2
 BSCOBUF  BSS    0
          SPACE  4
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*                                                                     *
**        PP MONITOR (MASTER ONLY).                                   *
*                                                                     *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
          SPACE  2
 MAIN     RJM    CHKPR       CHECK FOR ANY PP REQUESTS
          ZJN    MAIN20      IF NO PP REQUESTS

 MAIN10   LJM    DORQ        PROCESS THE PP/UNIT REQUEST

**        *DORQ* RETURNS DIRECTLY TO *MAIN*.

 MAIN20   LDDL   IDLFLG      GET IDLE FLAG
          NJN    MAIN        IF IDLE FLAG SET, RELOOP

          RJM    CHKUR       CHECK FOR ANY UNIT REQUESTS
          NJN    MAIN10      IF THERE IS A UNIT REQUEST

          RJM    CHKCH       CHECK AND PROCESS CHANNEL REQUESTS

          UJN    MAIN        LOOP
          TITLE  MASTER PP REQUEST ROUTINES.
** NAME - CHKPR  (MASTER ONLY)
*
** PURPOSE - TO CHECK IF THERE ARE ANY PP REQUESTS TO PROCESS.  IF THERE
*            ARE, THE FIRST ONE IS COPIED INTO PP MEMORY.
*
** OUTPUT - A=0 IF NO PP REQUESTS.
*           A .NE. 0 IF THERE IS A PP REQUEST TO PROCESS.
*           IF THERE IS A REQUEST, (CMDNO) = NUMBER OF COMMANDS.
*
          SPACE  2
 CHKPR10  LDN    PPLK+40B    UNLOCK PP REQUEST QUEUE
          RJM    SCLK

 CHKPR20  LDK    ZERO        SET EXIT FOR NO REQUESTS FOUND

 CHKPR    SUBR               ENTRY/EXIT

          LOADC  CM.PIT      LOAD A AND R FOR PIT
          ADN    /PIT/C.PPQ
          CRDL   T1          READ REQUEST RMA FROM PIT
          LDDL   T3          HALF 1 OF REQUEST RMA
          ADDL   T4          HALF 2 OF REQUEST RMA
          ZJN    CHKPRX      IF NO REQUEST QUEUED
          LDN    PPLK        LOCK PP REQUEST QUEUE
          RJM    SCLK
          NJK    CHKPR20     RETURN IF PP REQUEST QUEUE ALREADY LOCKED
          LOADC  CM.PIT      CM ADDRESS TO A AND R FOR READ
          ADN    /PIT/C.PPQPVA
          CRML   UCAHDR+/UCA/P.CPVA-1,TW  READ IN REQUEST PVA/RMA FROM PIT
          LDML   UCAHDR+/UCA/P.CRMA  GET HALF 1 OF RMA OF 1ST REQUEST
          ADML   UCAHDR+/UCA/P.CRMA+1
          ZJK    CHKPR10     IF RMA = 0 NO PP REQUEST QUEUED
          LDK    /RQ/C.CMND  LENGTH OF REQUEST HEADER
          STDL   WC
          LOADF  UCAHDR+/UCA/P.CRMA  CM ADDRESS OF REQUEST TO A AND R
          CRML   REQBUF,WC   READ PP REQUEST HEADER
          LDML   REQBUF+/RQ/P.LEN  REQUEST LENGTH IN BYTES
          SHN    -3          REQUEST LENGTH IN CM WORDS
          SBN    /RQ/C.CMND  SUBTRACT HEADER LENGTH
          STDL   CMDNO       NUMBER OF COMMANDS THIS REQUEST
          LDDL   CMADR+2     READ COMMANDS FROM CM
          ADN    /RQ/C.CMND
          LMC    400000B
          CRML   CMDBUF,CMDNO
          LOADC  CM.PIT      SET A AND R TO PP INTERFACE TABLE
          ADN    /PIT/C.PPQPVA  SET A AND R TO PVA IN PP INTERFACE TABLE
          CWML   REQBUF+/RQ/P.NEXTPV-1,TW  RESET PVA AND RMA TO NEXT PVA/RMA
          LDN    PPLK+40B    UNLOCK PP REQUEST QUEUE
          RJM    SCLK
          RJM    RESPSU      SET UP RESPONSE BUFFER
          LDK    ONE         SET GOT REQUEST FLAG
          UJK    CHKPRX      EXIT
          EJECT
** NAME - CHKUR  (MASTER ONLY)
*
** PURPOSE - TO CHECK IF THERE ARE ANY REQUESTS ON THE UNIT QUEUES.
*
** OUTPUT - A = 0 IF THERE ARE NO UNIT REQUESTS.
*           A .NE. 0 IF THERE IS A UNIT REQUEST TO PROCESS,
*           REQBUF = REQUEST, (CMDNO) = NUMBER OF COMMANDS, AND
*           UCA INITIALIZED BUT NOT UPDATED IN CM.
*
** NOTE - THE UIT UNIT REQUEST QUEUE LOCKWORD IS NOT OBTAINED BY THE PP
*         WHEN CHECKING FOR REQUESTS. THE REQUEST IS TO BE DELINKED
*         WHEN COMPLETED, THEN THE LOCKWORD MUST BE OBTAINED BY THE PP.
          SPACE  2
 CHKUR10  LDK    ZERO        SET NO UNIT REQUESTS

 CHKUR    SUBR               ENTRY/EXIT

          LDML   UNITC       GET NUMBER OF ACTIVE UNITS
          STML   CHKURA      SAVE FOR LOOP CONTROL

 CHKUR20  SOML   CHKURA      DECREMENT LOOP CONTROL COUNTER
          MJK    CHKUR10     EXIT IF ALL UNITS CHECKED AND NO FINDS
          AODL   UNITP       INCREMENT UNIT POINTER
          SBML   UNITC       SUBTRACT MAX ACTIVE UNIT POINTER
          MJN    CHKUR30     SKIP IF NO WRAP AROUND
          LDK    ZERO        RESET POINTER TO START OF UNIT LIST
          STDL   UNITP

 CHKUR30  LDDL   UNITP       GET UNIT POINTER
          SHN    2           MULT BY 4 SINCE PUD DESCRIPTOR IS 4 PP WORDS LONG
          STDL   UDPNT       SAVE POINTER INTO UNIT DESCRIPTOR

**        PRESET HAS TAKEN NULL UNIT DESCRIPTORS OUT OF THE PP COPY OF THE
*         UNIT DESCRIPTORS FOR THIS PIT.

**        CHECK IF REQUEST IS QUEUED.

          LOADF  UNITD+/PUD/P.UQT,UDPNT  REFORMAT AND LOAD CM ADDRESS OF UIT
          STDL   CM.UIT+2    SAVE CM ADDRESS OF UIT
          SRD    CM.UIT
          ADN    /UIT/C.NEXT
          CRDL   T1          READ NEXT REQUEST RMA
          LDDL   T3          HALF 1 OF REQUEST RMA
          ADDL   T4          HALF 2 OF REQUEST RMA
          ZJK    CHKUR20     IF NO REQUEST QUEUED

**        CHECK IF UNIT IS DISABLED.

          LOADC  CM.UIT      SET A AND R TO UIT
          CRML   UITHDR,TW   READ UIT HEADER WORDS
          LDML   UITHDR+/UIT/P.DSABLE  GET UNIT STATUS
          SHN    18-16+/UIT/L.DSABLE
          MJK    CHKUR20     IF UNIT DISABLED

**        CHECK IF OUTSTANDING REQUESTS ON UCA.

          REFAD  UITHDR+/UIT/P.UBUF,CM.UCA  REFORMAT AND SAVE UCA ADDRESS
          ADN    /UCA/C.ACTCNT
          CRML   UCAHDR+/UCA/P.ACTCNT,TW  READ UCA HEADER WORDS 2 AND 3
          LDML   UCAHDR+/UCA/P.ACTCNT  CHECK ACTIVE COUNT
          NJN    CHKUR35     IF ACTIVE REQUEST IS OUTSTANDING

**        PROCESS FIRST REQUEST.

          LOADC  CM.UIT      LOAD A AND R FOR UIT
          ADN    /UIT/C.NEXTPV  OFFSET TO NEXT PVA/RMA
          CRML   UCAHDR+/UCA/P.CPVA-1,TW  READ NEXT PVA AND RMA
          UJN    CHKUR50     CONTINUE

**        CHECK FOR OUTSTANDING COMPLETIONS.

 CHKUR35  SHN    -1          CHECK FOR 2 OR MORE OUTSTANDING
          ZJN    CHKUR40     IF NOT
          RJM    CHKWRT      CHECK FOR PREVIOUS COMPLETION
          MJN    CHKUR47     IF ABNORMAL ON ANY COMPLETIONS

**        CHECK IF CHAINED REQUEST IS ACTIVE.

 CHKUR40  LOADF  UCAHDR+/UCA/P.PRMA  SET A AND R TO PREVIOUS REQUEST
          STDL   T5          SAVE A ADDRESS
          ADN    /RQ/C.NEXT  OFFSET TO NEXT RMA FIELD
          CRDL   T1          READ THE NEXT RMA
          LDDL   T3          CHECK IF ACTIVE
          ADDL   T4
          ZJN    CHKUR45     IF NOT ACTIVE
          LDDL   T5          RESTORE A ADDRESS
          LMC    400000B
          CRML   UCAHDR+/UCA/P.CPVA-1,TW  GET NEXT PVA/RMA
          UJN    CHKUR50     PROCESS THE NEXT REQUEST

 CHKUR45  RJM    CHKWRT      ELSE  CHECK FOR PREVIOUS WRITE COMPLETIONS

 CHKUR47  UJK    CHKUR20     GO TO NEXT UNIT

**        READ IN THE REQUEST HEADER.

 CHKUR50  LDK    /RQ/C.CMND  LENGTH OF REQUEST HEADER
          STDL   WC          SAVE LENGTH FOR CM READ
          LOADF  UCAHDR+/UCA/P.CRMA  SET A AND R TO ADDR OF REQUEST
          CRML   REQBUF,WC   READ REQUEST HEADER
          LDML   REQBUF+/RQ/P.LEN  REQUEST LENGTH IN BYTES
          SHN    -3          REQUEST LENGTH IN CM WORDS
          SBN    /RQ/C.CMND  SUBTRACT HEADER LENGTH
          STDL   CMDNO       NUMBER OF COMMANDS THIS REQUEST
          ZJN    *           IF NO COMMANDS HANG

**        READ IN THE REQUEST COMMANDS.

          LDDL   CMADR+2     SET A FOR CM ADDRESS
          ADN    /RQ/C.CMND  ADJUST TO COMMANDS
          LMC    400000B
          CRML   CMDBUF,CMDNO  READ THE COMMANDS

**        SET PREVIOUS REQUEST RMA FROM CURRENT REQUEST RMA

          LDML   UCAHDR+/UCA/P.CRMA
          STML   UCAHDR+/UCA/P.PRMA
          LDML   UCAHDR+/UCA/P.CRMA+1
          STML   UCAHDR+/UCA/P.PRMA+1

**        PRESET THE RESPONSE AND EXIT WITH REQUEST FLAG SET.

          RJM    RESPSU      SET UP RESPONSE BUFFER
          LDK    ONE         SET GOT REQUEST FLAG
          UJK    CHKURX      RETURN
          SPACE  2
 CHKURA   DATA   0           LOOP CONTROL
          EJECT
** NAME - DOPPRQ  (MASTER ONLY)
*
** PURPOSE - PERFORM A PP REQUEST.
*
** INPUT - (T2) = COMMAND, REQUEST ALREADY DELINKED.
*
** OUTPUT - RESPONSE SENT AND COMMAND PROCESSED.
*
** NOTE - THE ONLY PP REQUESTS CURRENTLY SUPPORTED ARE IDLE AND RESUME.
*         THERE CAN ONLY BE 1 PP COMMAND PER REQUEST.
*
          SPACE  2
 DOPPRQ   BSS                ENTRY

          RJM    CCLOCK      RELEASE CONNECTED UNIT AND CLEAR CHANNEL LOCK
          LDK    R.NRM       SET NORMAL REQUEST COMPLETION
          STML   RESBUF+/RS/P.RC
          LDDL   T2          GET COMMAND
          SBN    RSUMCMD
          ZJN    DOPPRQ10    IF RESUME COMMAND
          LDK    ONE         SET PP IDLE
          STDL   IDLFLG
          RJM    RESP        SEND THE RESPONSE
          UJK    MAIN        GO TO MAIN LOOP

 DOPPRQ10 LDK    TWO         SET PP RESUME IN PROGRESS
          STDL   IDLFLG
          RJM    RESP        SEND THE RESPONSE
          LJM    INIT        REINITIALIZE THE DRIVER
          EJECT
** NAME - DORQ  (MASTER ONLY)
*
** PURPOSE - PERFORM THE REQUIRED REQUEST.
*
** INPUT - REQUEST IN REQBUF.
*          (CMDNO) = NUMBER OF COMMANDS IN REQUEST.
*
** OUTPUT - REQUEST PROCESSED AND RESPONSE PLACED IN RESPONSE BUFFER.
*
          SPACE  2
 DORQ     BSS                ENTRY

          LDK    CMDBUF      ADDRESS OF FIRST COMMAND IN REQUEST
          STDL   CMDADR      INITIALIZE COMMAND ADDRESS
          LDK    ZERO
          STDL   TRNCNT+3    INITIALIZE TRANSFER COUNT
          STDL   TRNCNT+2
          STDL   MOTION      INITIALIZE MOTION FLAG
          STDL   LONG        INITIALIZE LONG INPUT BLOCK FLAG
          STML   GETSTAC     CLEAR RETRY/CONTINUE LIMIT COUNTER
          STML   DOUTCNT     CLEAR OUTPUT CONTINUE FLAG

 DORQ10   LDIL   CMDADR      GET COMMAND AND FLAGS
          SHN    -8          SHIFT OFF FLAGS
          STDL   T2          SAVE COMMAND
          LDK    ZERO        INITIALIZE TABLE INDEX
          STDL   T1

 DORQ20   LDML   DORQB,T1    COMPARE TABLE ENTRY WITH CURRENT COMMAND
          LMDL   T2
          ZJN    DORQ30      IF FOUND REQUESTED COMMAND
          LDK    TWO         INCREMENT INDEX
          RADL   T1
          LMN    DORQBL
          NJN    DORQ20      IF NOT END OF TABLE
          RJM    NSC         REPORT NON-SUPPORTED COMMAND  (NO RETURN)

 DORQ30   LDML   DORQB+1,T1  GET PROCESSOR ADDRESS
          STML   DORQA

**        EXIT TO COMMAND PROCESSOR ROUTINE WITH THE FOLLOWING -
*
*         (T2) = COMMAND.
*         ((CMDADR)) = COMMAND AND FLAGS. (BEGINNING OF CURRENT COMMAND)
*         (CMDNO) = NUMBER OF COMMANDS, INCLUDING CURRENT ONE, LEFT
*                   IN THE CURRENT REQUEST.

          LJM    *           PROCESS COMMAND  (PLUGGED)
 DORQA    EQU    *-1

**        AFTER COMMAND IS PROCESSED, THE COMMAND PROCESSOR ROUTINE WILL
*         RETURN TO *CMDONE* IF STATUS CHECKING IS REQUIRED OR TO *NOSTAT*
*         IF STATUS CHECKING IS NOT REQUIRED.
          EJECT
**        PROCESS COMMAND COMPLETION.

 CMDONE   LDDL   P2          FETCH FATAL ERROR FLAG FROM ERRCHK
          NJK    FAIL        IF STATUS BAD, GO TO FAIL

 NOSTAT   SODL   CMDNO       DECREMENT COMMAND COUNTER BY 1
          ZJN    REQDNE      IF NONE LEFT  GO TO REQUEST DONE
          LDK    FOUR        POINT TO THE NEXT COMMAND
          RADL   CMDADR
          UJK    DORQ10      RELOOP TO PERFORM NEXT COMMAND
          SPACE  4
**        PROCESS NORMAL REQUEST COMPLETION.

 REQDNE   RJM    GETBID      GET ENDING BLOCK ID
          PJN    REQDNE05    IF OK
          LDIL   CMDADR      CHECK FOR STORE TRANSFER AS LAST COMMAND
          SHN    -8          REMOVE FLAGS
          LMC    LCSTC
          NJN    FAIL        IF NOT STORE TRANSFER COUNT
          LCN    4           ADJUST POINTER BACK TO READ COMMAND
          RADL   CMDADR
          UJN    FAIL        FAIL THE REQUEST

 REQDNE05 LDML   BIDBUF      PUT HOST BLOCK ID IN RESPONSE
          STML   RESBUF+/RS/P.LGBID
          LDML   BIDBUF+1
          STML   RESBUF+/RS/P.LGBID+1
          LDML   URBHDR+/URB/P.WRTCNT  CHECK IF OUTSTANDING WRITE REQUEST
          ADML   UCAHDR+/UCA/P.ACTCNT
          ZJN    REQDNE10    IF NOT
          LJM    WRDONE      PROCESS WRITE COMPLETION

 REQDNE10 LDK    R.NRM
          STML   RESBUF+/RS/P.RC  SET NORMAL REQUEST TERMINATION INDICATOR
          LJM    IODONE      GO TERMINATE REQUEST
          SPACE  4
**        PROCESS ABNORMAL COMMAND/REQUEST COMPLETION.

 FAIL     LDML   RESBUF+/RS/P.EC  CHECK IF BUSY ERROR
          LPK    /RS/M.EC    MASK THE ERROR CODE
          SBN    EC32        CHECK FOR TAPE UNIT BUSY
          ZJN    FAIL05      IF YES  THEN CHECK SPECIAL CONDITIONS
          SBN    EC33-EC32   CHECK FOR CONTROL UNIT BUSY ON CONNECT
          ZJN    FAIL10      IF YES  PROCESS THE BUSY
          UJN    FAIL20      ELSE PROCESS OTHER ERROR

 FAIL05   LDDL   CMDADR      CHECK IF FIRST COMMAND
          LMK    CMDBUF
          NJK    FAIL30      IF NOT REPORT THE BUSY ERROR

*         CHECK IF IT WAS GOING TO BE A REWIND REQUEST.
          LDDL   CMDNO       CHECK IF MORE THAN 1 COMMAND IN REQUEST
          SBN    1
          ZJN    FAIL30      IF NOT
          LDML   CMDBUF+4    GET COMMAND TYPE
          SHN    -8          POSITION COMMAND CODE
          SBN    0#20
          NJN    FAIL10      IF NOT PHYSICAL FUNCTION COMMAND
          LDML   CMDBUF+7    CHECK IF REWIND FUNCTION CODE
          SBN    F.REW
          ZJN    FAIL30      IF REWIND REQUEST  REPORT THE BUSY ERROR

 FAIL10   UJK    FAIL50      GO PROCESS BUSY CONTROL UNIT OR TAPE UNIT

 FAIL20   LDML   RESBUF+/RS/P.ABALRT  CHECK ABNORMAL STATUS
          LPK    -/RS/K.ABALRT
          NJN    FAIL30      IF OTHER THAN ABNORMAL ALERT
          RJM    GETBID      GET ENDING BLOCK ID
          MJN    FAIL30      IF ERROR OCCURED
          LDML   BIDBUF      PUT HOST BLOCK ID IN RESPONSE
          STML   RESBUF+/RS/P.LGBID
          LDML   BIDBUF+1
          STML   RESBUF+/RS/P.LGBID+1

 FAIL30   LDML   URBHDR+/URB/P.WRTCNT  CHECK IF WRITE REQUEST
          ADML   UCAHDR+/UCA/P.ACTCNT
          ZJN    FAIL40      IF NOT
          RJM    WFAIL       PROCESS WRITE REQUEST FAILURE
          LJM    IODONE20    CHECK IF RELOAD MICROCODE IS REQUIRED

 FAIL40   RJM    DSABLE      CHECK FOR DISABLE UNIT
          LDK    R.ABN       SET ABNORMAL REQUEST TERMINATION
          STML   RESBUF+/RS/P.RC
          LJM    IODONE      GO TERMINATE REQUEST

*         PROCESS BUSY CONTROL UNIT OR TAPE UNIT.
 FAIL50   LDDL   CONFLG      GET THE UNIT NUMBER
          LPN    17B         MASK UNIT NUMBER
          STDL   T1          SET INDEX
          AOML   SCRBUF+8,T1  INCREMENT UNIT BUSY COUNTER
          SHN    1           POSITION CARRY BIT
          MJN    FAIL30      CHECK IF LIMIT (ABOUT 70 SECS) EXCEEDED
          RJM    REL         RELEASE THE BUSY UNIT
          UJK    MAIN        IGNORE THE BUSY THIS TIME
          SPACE  5,25
**        THE FOLLOWING TABLE CONTAINS ONE ENTRY FOR EACH SUPPORTED COMMAND
*         OF THE TAPE SUBSYSTEM.  THE SECOND WORD OF EACH ENTRY IS THE ADDRESS
*         OF THE COMMAND PROCESSOR ROUTINE.
          SPACE  2
 DORQB    BSS    0

**        UNIT COMMANDS.

          CON    FUNCCMD,FUNC     PHYSICAL COMMAND - FUNCTION
          CON    PWRTCMD,DOUT     PHYSICAL COMMAND - OUTPUT 8-BIT DATA
          CON    LCREAD,DREAD     LOGICAL COMMAND - READ FORWARD
          CON    LCSTC,DSTRTC     LOCIGAL COMMAND - STORE TRANSFER COUNT
          CON    LCLB,LOCBLK      LOCIGAL COMMAND - LOCATE BLOCK

**        PP COMMANDS.

          CON    IDLCMD,DOPPRQ    IDLE PP COMMAND
          CON    RSUMCMD,DOPPRQ   RESUME COMMAND

 DORQBL   EQU    *-DORQB     LENGTH OF TABLE
          EJECT
** NAME - DOUT  (MASTER ONLY)
*
** PURPOSE - TO PERFORM THE LOGICAL COMMAND OUTPUT 8-BIT DATA FOR DUAL PP.
*
** INPUT - (CMDADR) = ADDRESS OF COMMAND.
*
          SPACE  2
 DOUT     BSS                ENTRY

          AOML   URBHDR+/URB/P.WRTCNT  INCREMENT WRITE COUNTER
          STML   DOUTCNT     SET OUTPUT CONTINUE FLAG

 DOUT10   LDDL   MOTION      CHECK IF INIBUF ALREADY DONE
          NJN    DOUT20      IF YES
          LDDL   CMDADR      SET LENGTH/ADDRESS PAIR TO CURRENT COMMAND + 1
          STDL   T4
          RJM    INIBUF      INITIALIZE BUFFER POINTERS

 DOUT20   LDN    0           CLEAR MOTION FLAG
          STDL   MOTION
          RJM    GETCM       READ DATA FROM CM FOR FIRST CHUNK
          LDC    0           GET FUNCTION CODE TO USE
 DOUTF    EQU    *-1
          RJM    DOFUNC      PROCESS FUNCTION CODE
          ACN    TP          ACTIVATE CHANNEL
          SCF    FLAGERR,TP  TEST AND SET THE CHANNEL FLAG (TO START MASTER)
          LDK    ZERO
          STDL   AREG        CLEAR MASTER RESIDUAL COUNTER
          STML   DOUTF       CLEAR FUNCTION CODE USED
          LDML   EODATA      CHECK TO SEE IF THE SLAVE MUST BE CALLED
          NJN    DOUT30      IF SLAVE NOT NEEDED
          LDDL   CMDADR      GET THE COMMAND ADDRESS AND SEND THE
          STML   DOUTA        COMMAND TO THE SLAVE
          LOADC  CM.COM      LOAD R AND A OF PP COMMUNICATION BUFFER
          ADN    /CB/C.COMM
          CWML   *,ON        SEND THE COMMAND TO THE SLAVE
 DOUTA    EQU    *-1
          UJN    DOUT40      CONTINUE

 DOUT30   LOADC  CM.COM      CLEAR LAST SLAVE RESIDUAL COUNT
          ADN    /CB/C.COMM
          CWML   ZEROWD,ON

 DOUT40   LDDL   IOCNT       NUMBER OF 12 BIT CHANNEL WORDS

 DOUT50   FCJM   DOUT50,TP   WAIT FOR CHANNEL FLAG TO BE SET BY SLAVE
          OAPM   DIOBUF,TP   WRITE SOME TAPE
          CCF    *+2,TP      CLEAR CHANNEL FLAG TO START THE SLAVE

          ZJN    DOUT60      IF NO RESIDUAL LEFT
          STDL   AREG        SAVE RESIDUAL A REGISTER

 DOUT60   LDML   EODATA      END OF DATA FLAG (SET BY GETCM)
          NJN    DOUT80      ENDED HERE - EXIT
          LDML   ENTHERE     IF IT ENDS IN THE SLAVE, WAIT
          NJN    DOUT70
          RJM    GETCM       GET MORE DATA TO WRITE
          IJM    DOUT80,TP   IF CHANNEL WENT INACTIVE (POSSIBLE RETRY)
          UJN    DOUT40

 DOUT70   IJM    DOUT80,TP   IF CHANNEL WENT INACTIVE (POSSIBLE RETRY)
          FCJM   DOUT70,TP   WAIT FOR SLAVE TO FINISH

 DOUT80   FJM    *,TP        WAIT FOR CHANNEL EMPTY
          PAUSE  10          DELAY 10 MICROSECONDS
          DCN    40B+TP
          SFM    OUTCPE,TP   CHECK AND CLEAR CHANNEL PARITY ON OUTPUT
          RJM    WSC         WAIT FOR SLAVE TO COMPLETE
          LDDL   T1          CHECK FOR SLAVE DETECTED ERRORS
          NJK    SLVERR      IF YES
          LDDL   T4          MERGE SLAVE RESIDUAL WITH MASTERS
          RADL   AREG
          LDDL   CMDNO       CHECK IF ANOTHER WRITE CMD
          SBN    1
          STDL   MOTION      SET MOTION FLAG
          ZJN    DOUT85      IF NOT
          LDDL   CMDADR      SET CMD ADDRESS FOR INIBUF
          ADN    8           INCREMENT TO NEXT CMD
          STDL   T4
          RJM    INIBUF      INITIALIZE NEXT BUFFER POINTERS

 DOUT85   RJM    GETSTA      WAIT FOR END OF OPERATION
          MJN    DOUT100     IF RETRY OCCURED
          LDN    0           CLEAR WRITE CONTINUE FLAG
          STML   DOUTCNT
          RJM    ERRCHK      CHECK FOR ERROR OR TERMINATION CONDITION
          NJN    DOUT90      IF ERROR OR TERMINATION CONDITION
          LDDL   AREG        CHECK IF ANY RESIDUAL WORD COUNT
          NJK    RCNZO       IF YES  PROCESS RESIDUAL WORD COUNT

 DOUT90   UJK    CMDONE      PROCESS WRITE COMPLETION

 DOUT100  LDK    F.CNT       PROCESS CONTINUE (RETRY) FUNCTION
          STML   DOUTF
          LDN    0           CLEAR MOTION FLAG
          STDL   MOTION
          UJK    DOUT10      GO RETRY THE FUNCTION

 DOUTCNT  CON    0           WRITE CONTINUE FLAG
          SPACE  4
 ZEROWD   BSSZ   4           ZERO CM WORD FOR CLEARING RESIDUAL COUNT
          EJECT
** NAME - DREAD  (MASTER ONLY)
*
** PURPOSE - PROCESS LOGICAL READ COMMAND FOR DUAL PP.
*
** INPUT - (CMDADR) = ADDRESS OF COMMAND.
*
          SPACE  2
 DREAD    BSS                ENTRY

          LDML   URBHDR+/URB/P.WRTCNT  CHECK OUTSTANDING WRITES
          ADML   UCAHDR+/UCA/P.ACTCNT
          NJK    ICS         IF YES REPORT INVALID CMD SEQUENCE

          LDDL   MOTION      CHECK TAPE MOTION FLAG
          NJN    DREAD20     IF TAPE ALREADY MOVING
          LDK    F.RDF       ISSUE READ FUNCTION
          RJM    DOFUNC

 DREAD10  ACN    TP          ACTIVATE CHANNEL

 DREAD20  LDK    ZERO        CLEAR TRANSFER COUNTERS
          STDL   TRNCNT+2
          STDL   TRNCNT+3
          STDL   MOTION      CLEAR MOTION FLAG
          STDL   LONG        CLEAR LONG INPUT BLOCK FLAG
          LDDL   CMDADR      SET CURRENT COMMAND ADDRESS
          STDL   T4
          STML   DREADA      MODIFY THE WRITE INSTRUCTION
          RJM    INIBUF      INITIALIZE POINTERS TO CM BUFFERS
          SCF    FLAGERR,TP  TEST AND SET THE CHANNEL FLAG (TO START MASTER)
          LOADC  CM.COM      LOAD R AND A OF PP COMMUNICATION BUFFER
          ADN    /CB/C.COMM
          CWML   *,ON        COMMAND GOES TO THE SLAVE
 DREADA   EQU    *-1

 DREAD30  LDK    WDCOUNT     ALWAYS TRY TO READ A FULL BUFFER

 DREAD40  FCJM   DREAD40,TP  WAIT FOR THE SLAVE TO SET THE FLAG
          IAPM   DIOBUF,TP   INPUT DATA FROM TAPE
          CCF    *+2,TP      CLEAR THE CHANNEL FLAG TO START SLAVE

          STDL   AREG        SAVE THE CONTENTS OF THE A REGISTER
          NJN    DREAD50     SHORT READ PROCESSING
          RJM    WRITCM      WRITE THE DATA TO CM
          LDK    DUALBUFL*2  UPDATE THE TRANSFER COUNT
          RADL   TRNCNT+3
          SHN    -16
          RADL   TRNCNT+2
          IJM    DREAD60,TP  IF CHANNEL WENT INACTIVE
          UJN    DREAD30     DO IT ALL OVER AGAIN

 DREAD50  LDK    WDCOUNT     COMPUTE THE ACTUAL BYTE COUNT
          SBDL   AREG        NUMBER OF 12 BIT CHANNEL WORDS MOVED
          STDL   T5          STORE THIS VALUE
          SHN    1           MULTIPLY BY 3/2 TO GET BYTE COUNT
          ADDL   T5
          SHN    -1          DONE - NOTE ROUNDED DOWN ON PURPOSE
          STML   SHBYTEC     STORE SHORT BYTE COUNT
          ZJN    DREAD60     IF COUNT = 0
          RADL   TRNCNT+3    UPDATE THE TRANSFER COUNT
          SHN    -16
          RADL   TRNCNT+2    UPDATE THE TRANSFER COUNT
          RJM    WRITCM      WRITE SHORT BUFFER TO CM

 DREAD60  DCN    40B+TP      DISCONNECT THE CHANNEL
          SFM    INCPE,TP    CHECK AND CLEAR CHANNEL PARITY ON INPUT
          RJM    WSC         WAIT FOR SLAVE TO COMPLETE COMMAND
          LDDL   T1          CHECK FOR SLAVE DETECTED ERROR
          NJK    SLVERR      IF YES
          LDDL   T4          INCREMENT MASTERS TRANSFER COUNT
          RADL   TRNCNT+3
          SHN    -16
          ADDL   T3
          RADL   TRNCNT+2
          LDDL   T2          MERGE SLAVE LONG INPUT BLOCK FLAG
          RADL   LONG
          SHN    -16
          ZJN    DREAD70     IF NOT OVERFLOW
          LDK    TWO         ENSURE COUNT NOT 0 OR 1
          STDL   LONG

 DREAD70  RJM    GETSTA      WAIT FOR END OF OPERATION
          MJK    DREAD10     IF RETRY OCCURED
          RJM    CKFL        CHECK FOR CHARACTER FILL
          LDDL   LONG        CHECK FOR LONG INPUT OF 1 BYTE
          SBN    1
          NJN    DREAD80     IF NOT 1 BYTE TOO LONG
          LDML   RESBUF+/RS/P.CHRF  CHECK FOR CHARACTER FILL
          LPK    /RS/K.CHRF
          ZJN    DREAD80     IF NO CHARACTER FILL
          LDK    ZERO        INDICATE NOT LONG INPUT BLOCK
          STDL   LONG

 DREAD80  RJM    ERRCHK      CHECK FOR ERRORS OR TERMINATION CONDITION
          NJN    DREAD100    IF ERRORS OR TERMINATION CONDITION
          LDDL   CMDNO       COMMANDS REMAINING
          SBN    2
          ZJN    DREAD90     IF NO MORE POSSIBLE READ COMMANDS
          LDK    F.RDF       START TAPE FOR NEXT BLOCK
          RJM    DOFUNC
          ACN    TP          ACTIVATE CHANNEL
          AODL   MOTION      SET TAPE MOTION FLAG

 DREAD90  UJK    CMDONE      PROCESS NEXT COMMAND

 DREAD100 LOADF  6,CMDADR    RETURN TRANSFER COUNT OF ERROR BLOCK
          CWDL   TRNCNT
          UJN    DREAD90     EXIT
          EJECT
** NAME - DSTRTC  (MASTER ONLY)
*
** PURPOSE - PERFORM LOGICAL COMMAND STORE TRANSFER COUNT FOR DUAL PP.
*
** INPUT - (CMDADR) = ADDRESS OF COMMAND.
*
          SPACE  2
 DSTRTC   BSS                ENTRY

          LOADF  2,CMDADR    CM ADDRESS TO A AND R
          CWDL   TRNCNT      SEND TRANSFER COUNT TO CM
          LDK    ZERO        CLEAR TRANSFER COUNT
          STDL   TRNCNT+2
          STDL   TRNCNT+3
          UJK    NOSTAT      GO TO DO NEXT COMMAND
          EJECT
** NAME - FUNC  (MASTER ONLY)
*
** PURPOSE - TO PERFORM THE PHYSICAL COMMAND FUNCTION.
*
** INPUT -  (CMDADR) = ADDRESS OF COMMAND.
*
** OUTPUT - FUNCTION ISSUED IF NOT WRITE OR FORMAT.
*
          SPACE  2
 FUNC     BSS                ENTRY

          LDML   3,CMDADR    GET HARDWARE FUNCTION TO BE ISSUED
          LPN    77B         MASK MAJOR FUNCTION CODE BITS

**        CHECK FOR FORMAT UNIT FUNCTION CODE.
          SBN    F.FU67
          NJN    FUNC10      IF NOT
          LJM    FORMU       PROCESS FORMAT UNIT FUNCTION

**        CHECK FOR REWIND OR UNLOAD FUNCTION CODES.
 FUNC10   SBN    F.REW-F.FU67
          NJN    FUNC30      IF NOT
          LDML   3,CMDADR    NOW CHECK FOR UNLOAD
          STDL   FRELF       SET THE FORCE RELEASE FLAG
          SHN    17-6
          PJN    FUNC20      IF NOT UNLOAD
          LJM    UNLD        PROCESS UNLOAD

*         PROCESS REWIND.
 FUNC20   LDML   RESBUF+/RS/P.GS1  CHECK IF AT BOT
          LPK    /RS/K.BOT   MASK BOT BIT
          ZJN    FUNC40      IF NOT GO ISSUE REWIND FUNCTION

*         CHECK IF BID (FROM CONNECT) IS 0100 0000(HEX).
          LDML   URBHDR+/URB/P.SBID+1  GET LOWER HALF OF BID
          NJN    FUNC40      IF NOT AT BOT GO ISSUE REWIND FUNCTION
          LDML   URBHDR+/URB/P.SBID  GET UPPER HALF OF BID
          ADC    -RBIDU
          NJN    FUNC40      IF NOT AT BOT GO ISSUE REWIND FUNCTION
          UJN    FUNC60      AT BOT  GO PROCESS NEXT COMMAND

**        CHECK FOR WRITE FUNCTION CODE.
 FUNC30   SBN    F.WRT-F.REW
          NJN    FUNC40      IF NOT
          LDML   3,CMDADR    GET WRITE FUNCTION CODE TO USE
          STML   DOUTF       SET IT
          UJN    FUNC60      GO DO NEXT CMD

**        PROCESS THE FUNCTION CODE.
 FUNC40   LDML   URBHDR+/URB/P.WRTCNT  CHECK OUTSTANDING WRITES
          ADML   UCAHDR+/UCA/P.ACTCNT
          NJK    ICS         IF YES REPORT INVALID CMD SEQUENCE
          LDML   3,CMDADR
          RJM    DOFUNC      SEND FUNCTION

 FUNC50   RJM    GETSTA      GET STATUS
          MJN    FUNC50      IF RETRY OCCURED
          RJM    ERRCHK      CHECK FOR ERRORS
          UJK    CMDONE      COMMAND COMPLETE

 FUNC60   UJK    NOSTAT      EXECUTE NEXT COMMAND
          EJECT
** NAME - LOCBLK  (MASTER ONLY)
*
** PURPOSE - PERFORM LOGICAL COMMAND LOCATE BLOCK.
*
** INPUT - (CMDADR) = ADDRESS OF COMMAND.
*
          SPACE  2
 LOCBLK   BSS                ENTRY

          LDML   URBHDR+/URB/P.WRTCNT  CHECK OUTSTANDING WRITES
          ADML   UCAHDR+/UCA/P.ACTCNT
          NJK    ICS         IF YES REPORT INVALID CMD SEQUENCE
          LDML   2,CMDADR    GET LOCATE BLOCK PARAMETERS
          STML   LOCBLKA
          LDML   3,CMDADR
          STML   LOCBLKB
          LDK    F.LB        LOCATE BLOCK FUNCTION
          RJM    DOFUNC      SEND FUNCTION CODE
          LDK    THREE       LENGTH OF PARAMETERS IN 12-BIT WORDS
          ACN    TP          ACTIVATE CHANNEL
          OAPM   LOCBLKA,TP  OUTPUT THE PARAMETERS
          FJM    *,TP        WAIT UNTIL CHANNEL EMPTY
          DCN    40B+TP      DEACTIVATE CHANNEL
          NJK    RCNZO       PROCESS NON-ZERO RESIDUAL WORD COUNT ERROR
          SFM    OUTCPE,TP   CHECK AND CLEAR CHANNEL ERROR FLAG

 LOCBLK10 RJM    GETSTA      GET STATUS
          MJN    LOCBLK10    IF RETRY OCCURED
          RJM    ERRCHK      CHECK FOR ERRORS
          UJK    CMDONE      COMMAND DONE
          SPACE  4
 LOCBLKA  DATA   0#FFFF      LOCATE BLOCK PARAMETERS (PLUGGED)
 LOCBLKB  DATA   0#FFFF
          CON    0           END FILLER
          EJECT

          SPACE  4
 CONCHM   BSS    0           MASTER PP CHANNEL INSTRUCTIONS
 TTP+40B  HERE
 T40B+TP  HERE
 TTP      HERE
          CON 0              END OF TABLE
          SPACE 4
**        NOTE - THIS IS THE END OF THE SLAVE CODE OVERLAY BUFFER.

 ESCOBUF  EQU    *-5         LEAVE SPACE FOR 1 EXTRA CM OVERLAY WORD
          TITLE  COMMON ROUTINES AND SUBROUTINES.
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*                                                                     *
**        NOTE - ROUTINES AND TABLES FROM HERE TO *OVLBUF*            *
*                MAY BE USED BY BOTH THE MASTER AND SLAVE PP.         *
*                                                                     *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
          SPACE  5,20
** NAME - BUMPIT
*
** PURPOSE - INCREMENT THE LENGTH/ADDRESS RMA.
*
** OUTPUT - CBUFRMA POINTS TO NEW BUFFER ADDRESS FOR THIS PP.  SPACE IS
*           SET APPROPRIATELY.
*
          SPACE  2
 BUMPIT   SUBR               ENTRY/EXIT

          LDK    DUALBUFL*4
          STDL   T4
          LDML   SPACE       THIS IS THE SPACE LEFT IN THE CURRENT
                              BUFFER PRIOR TO THE LAST OPERATION.
          SBDL   T4          SUBTRACT FOR LAST OPERATION AND THE SPACE
                              USED BY THE PARTNER.
          ZJN    BUMPIT20    IF NOT ENOUGH SPACE IN CURRENT RMA
          MJN    BUMPIT20    IF NOT ENOUGH SPACE IN CURRENT RMA
          STML   SPACE

 BUMPIT10 LDDL   T4          INCREMENT THE CURRENT RMA
          RAML   CBUFRMA+1
          SHN    -16         TAKE CARE OF OVERFLOW
          RAML   CBUFRMA
          UJN    BUMPITX     EXIT

 BUMPIT20 LDDL   T4          COMPUTE HOW MUCH SPACE IS NEEDED FROM NEXT
          SBML   SPACE         RMA (IF ANY)
          STDL   T4
          LDML   NUMBUF      ARE THERE ANY BUFFERS LEFT
          NJN    BUMPIT40    AT LEAST ONE LEFT

 BUMPIT30 AOML   ENTHERE     INDICATE IT ENDS IN THE PARTNER
          LDK    ZERO        SET NO SPACE FOR THIS PP NEXT TIME
          STML   SPACE
          UJK    BUMPITX     EXIT

 BUMPIT40 LDML   INDLST+8    MOVE LENGTH/ADDRESS PAIR TO CURRENT
          STML   INDLST+4      L/A PAIR
          LDML   INDLST+9
          STML   INDLST+5
          LDML   INDLST+10
          STML   INDLST+6
          LDML   INDLST+11
          STML   INDLST+7
          RJM    GNEWPR      GET NEXT LENGTH/ADDRESS PAIR
          LDDL   T4          IS THERE ENOUGH ROOM IN THIS BUFFER
          SBML   SPACE       THIS IS THE SPACE IN THE NEW BUFFER
          PJN    BUMPIT30    ENDS IN PARTNER
          LDML   SPACE       DECREMENT NEW SPACE BY WHAT IS NEEDED
          SBDL   T4
          STML   SPACE
          LJM    BUMPIT10    ADJUST THE RMA AND EXIT
          SPACE  5,20
** NAME - CBYTE
*
** PURPOSE - CONVERT 8-BIT BYTE COUNT TO 12-BIT CHANNEL WORD COUNT.
*
** INPUT - (BYTCNT) = 8-BIT BYTE COUNT.
*
** OUTPUT - (IOCNT) = 12-BIT CHANNEL WORD COUNT.
*
** NOTE - MULTIPLY BYTE COUNT BY 2/3 AND ROUND UP.
*
          SPACE  2
 CBYTE10  LDK    WDCOUNT     SET FULL BLOCK CHANNEL WORD COUNT
          STDL   IOCNT

 CBYTE    SUBR               ENTRY/EXIT

          LDDL   BYTCNT      CHECK FOR FULL BLOCK
          ADC    -DUALBUFL*2
          ZJN    CBYTE10     IF FULL BLOCK
          LDK    ZERO
          STDL   IOCNT       INITIALIZE CHANNEL COUNT
          LDDL   BYTCNT      CHECK BYTE COUNT
          ZJK    CBYTEX      IF ZERO BYTE COUNT
          STDL   T1          SET DIVIDEND IN T1 (BYTE COUNT)
          LDK    THREE       SET DIVISOR IN T2  (3)
          SHN    14
          STDL   T2

 CBYTE20  LDDL   IOCNT       DIVIDE LOOP
          SHN    1
          STDL   IOCNT
          LDDL   T1
          SBDL   T2
          MJN    CBYTE30
          STDL   T1
          AODL   IOCNT       INCREMENT CHANNEL COUNT

 CBYTE30  LDDL   T2
          SHN    -1
          STDL   T2
          NJN    CBYTE20     THIS CHECK WILL MULTIPLY BY 2
          LDDL   T1
          ZJK    CBYTEX      IF NO NEED TO ROUND UP
          AODL   IOCNT       ROUND UP IF REMAINDER
          UJK    CBYTEX      EXIT
          SPACE  5,20
** NAME-- CCLOCK
*
** PURPOSE-- CLEARS THE CHANNEL LOCK IN THE CM CHANNEL TABLE.
*            IF A UNIT IS CONNECTED IT WILL BE RELEASED FIRST.
*
** OUTPUT-- THE CHANNEL THAT THIS PP HAD LOCKED, WILL BE UNLOCKED.
*
          SPACE  2
 CCLOCK   SUBR               ENTRY/EXIT

          LDDL   CONFLG
          ZJN    CCLOCK10    IF NO UNIT CURRENTLY CONNECTED
          RJM    REL         RELEASE UNIT

 CCLOCK10 LDDL   CHLOCK      CHECK IF CHANNEL LOCKED
          ZJN    CCLOCKX     IF CHANNEL NOT LOCKED
          LDN    CHLK+40B    CLEAR CHANNEL LOCKWORD
          RJM    SCLK
          LDK    ZERO        CLEAR CHANNEL LOCK FLAG
          STDL   CHLOCK
          UJK    CCLOCKX     EXIT
          SPACE  5,20
** NAME - CHFUNC
*
** PURPOSE - ISSUE A FUNCTION TO THE CIO CHANNEL ADAPTER.
*
** INPUT - (A) = FUNCTION CODE TO ISSUE.
*
** OUTPUT - (A) = 0 IF FUNCTION REJECT.
*
          SPACE  2
 CHFUNC   SUBR               ENTRY/EXIT

          DCN    40B+TP
          FAN    TP          ISSUE FUNCTION CODE
          LCN    ZERO        SET TIMEOUT VALUE

 CHFUNC10 IJM    CHFUNCX,TP  IF RESPONSE  EXIT
          SBN    1
          NJN    CHFUNC10    IF NOT TIMEOUT
          DCN    40B+TP
          UJN    CHFUNCX     RETURN WITH (A) = 0
          SPACE  5,20
** NAME - CHGCH
*
** PURPOSE - CHANGE CHANNEL NUMBER IN CHANNEL INSTRUCTIONS.
*
** INPUT - (CURCH) = CHANNEL NUMBER.
*          (A) = CHANNEL TABLE ADDRESS.
*
** OUTPUT - ALL CHANNEL INSTRUCTIONS MODIFIED.
*
          SPACE  2
 CHGCH    SUBR               ENTRY/EXIT

          STDL   T1          SET ADDRESS MODIFICATION LIST ADDRESS

 CHGCH10  LDIL   T1          READ LIST WORD
          ZJN    CHGCHX      IF END OF LIST
          STDL   T2          SET INSTRUCTION ADDRESS
          LDIL   T2          READ INSTRUCTION WORD
          SCN    37B         CLEAR CHANNEL BITS
          LMML   CURCH       REPLACE WITH NEW CHANNEL
          STIL   T2
          AODL   T1          INCREMENT TO NEXT INSTRUCTION
          UJN    CHGCH10     LOOP
          SPACE  5,20
** NAME - CHKWRT
*
** PURPOSE - CHECK FOR PREVIOUS WRITE REQUEST COMPLETIONS.
*
** INPUT - (UCAHDR) HAS BEEN READ INTO THE PP AND OUTSTANDING REQUESTS
*          ARE ACTIVE.
*          (A) = 0, DO SYNCHRONIZE CHECK.
*          (A) <> 0, BYPASS SYNCHRONIZE CHECK.
*
** OUTPUT - IF THIS UNIT HAS COMPLETED A WRITE REQUEST THEN A RESPONSE
*           WILL BE GENERATED AND SENT.
*          (A) = +, NO ABNORMAL COMPLETIONS.
*          (A) = -, ABNORMAL COMPLETION OCCURED.
*
          SPACE  2
 CHKWRT10 LDN    0           CLEAR CHECK WRITE FLAG
          STML   CHKWRTF     RETURN A=+

 CHKWRT   SUBR               ENTRY/EXIT

          STML   CHKWRTA     SAVE ENTRY PARAMETER
          LDN    1           SET CHECK WRITE FLAG
          STML   CHKWRTF
          LDN    0           CLEAR SYNCHRONIZE SENT FLAG
          STML   CHKWRTS
          STML   RESBUF+/RS/P.ABALRT  CLEAR PREVIOUS ERROR STATUS
          STML   RESBUF+/RS/P.LNGBLK
          RJM    RURBH       READ URB HEADER INTO PP
          LDML   URBHDR+/URB/P.CONF  GET CONNECT FUNCTION TO USE
          RJM    CONNU       CONNECT TO THE UNIT
          MJN    CHKWRT30    IF ERROR
          NJN    CHKWRT20    IF NOT PREVIOUSLY CONNECTED
          LDML   CHKWRTA
          NJN    CHKWRT40    IF BYPASS SYNCHRONIZE IS SET

 CHKWRT20 RJM    GETBID      GET THE CURRENT TAPE POSITION BLOCK ID
          PJN    CHKWRT40    IF NOT ERROR

 CHKWRT30 RJM    WFAIL       GO PROCESS WRITE FAILURE
          LDN    0           CLEAR CHECK WRITE FLAG
          STML   CHKWRTF
          LCN    1           RETURN A=-
          UJK    CHKWRTX     RETURN

*         CHECK IF FIFO REQUEST IS NOW DONE.
 CHKWRT40 LDML   URBHDR+/URB/P.EBID  GET REQUEST UPPER ENDING BLOCK ID
          LPC    0#FF        MASK OUT PHYSICAL REFERENCE
          STDL   T1          SAVE IT
          LDML   BIDBUF+3    GET CURRENT TAPE POSITION UPPER BLOCK ID
          LPC    0#FF        MASK OUT PHYSICAL REFERENCE
          SBDL   T1          COMPARE THEM
          MJK    CHKWRT50    IF REQUEST HAS NOT COMPLETED
*         IF BIDBUF EBID UPPER GT URB EBID UPPER, BID MAY HAVE SURPASSED 16 BITS
          NJN    CHKWRT42    JIF BIDBUF EBID WRAPPED PAST 16 BITS
          LDML   BIDBUF+4    COMPARE LOWER BLOCK ID-S
          SBML   URBHDR+/URB/P.EBID+1
          MJN    CHKWRT50    IF REQUEST HAS NOT COMPLETED

*         PROCESS NORMAL REQUEST COMPLETION.
 CHKWRT42 RJM    RURBR       READ URB RESPONSE FIELD BACK INTO PP
          RJM    DELINK      DELINK THE REQUEST
          LDK    R.NRM       SET NORMAL RESPONSE COMPLETION
          STML   RESBUF+/RS/P.RC
          RJM    RESP        SEND THE RESPONSE
          RJM    UINP        UPDATE IN POINTER OF UCAHDR IN CM
          LDML   CHKWRTS     CHECK IF SYNCHRONIZE SENT
          ZJN    CHKWRT45    IF NOT RETURN
          LDML   UCAHDR+/UCA/P.ACTCNT  CHECK IF ANY MORE ACTIVE REQUESTS
          ZJN    CHKWRT45    IF NONE LEFT  RETURN
          RJM    RURBH       READ NEXT URB HEADER
          UJK    CHKWRT40    GO CHECK IF THIS ONE IS COMPLETE

 CHKWRT45 RJM    REL         RELEASE THE UNIT
          UJK    CHKWRT10    PREPARE TO RETURN

*         CHECK IF CPU HAS SET THE SYNCHRONIZE PVA FLAG,
*         FOR THE OLDEST OUTSTANDING REQUEST.

 CHKWRT50 LDML   CHKWRTA     CHECK ENTRY PARAMETER
          NJN    CHKWRT45    IF BYPASS SYNCHRONIZE CHECK
          LOADC  CM.UCA      LOAD A AND R WITH UCA CM ADDRESS
          CRDL   T4          READ UCA CPU SYNC WORD

 OFL2     IFEQ   OFFLINE,1
          LDDL   T7          CHECK FOR OFFLINE SYNC FLAG
          ZJN    CHKWRT45    IF NOT SET
 OFL2     ELSE
          LDDL   T4          CHECK IF SWAPOUT SYNCHRONIZE IS SET
          NJN    CHKWRT57    IF YES
          LDN    2           SET COMPARE LOOP COUNTER
          STDL   T4

 CHKWRT55 LDML   RESBUF+/RS/P.PVA,T4  GET OLDEST REQUEST PVA
          LMML   T5,T4       COMPARE WITH CPU SYNC PVA WORD
          NJN    CHKWRT45    IF NOT THE SAME RETURN
          SODL   T4          DECREMENT LOOP COUNTER
          PJN    CHKWRT55    IF NOT DONE COMPARING
 OFL2     ENDIF

*         CHECK ACTIVE COUNT OF BUFFERED WRITE REQUESTS.
 CHKWRT57 LDML   UCAHDR+/UCA/P.ACTCNT
          SBN    1           CHECK FOR 1 OUTSTANDING REQUEST
          ZJN    CHKWRT60    IF YES THEN DO SYNCHRONIZE IMMEDIATELY

*         CHECK IF TAPE IS ALREADY MOVING.
          LDML   UCAHDR+/UCA/P.TPF  GET LAST TAPE POSITION FLAG
          SBML   BIDBUF+4    COMPARE WITH CURRENT TAPE POSITION
          ZJN    CHKWRT60    IF STILL AT THE SAME POSITION
          LDML   BIDBUF+4    UPDATE TAPE POSITION FLAG
          STML   UCAHDR+/UCA/P.TPF
          LOADC  CM.UCA
          ADN    /UCA/C.ACTCNT
          CWML   UCAHDR+/UCA/P.ACTCNT,ON  UPDATE TPF IN CM
          UJK    CHKWRT45    RETURN

*         PROCESS SYNCHRONIZE.
 CHKWRT60 LDK    F.SYN       SYNCHRONIZE FUNCTION
          STML   CHKWRTS     SET SYNCHRONIZE SENT FLAG
          RJM    DOFUNC      SEND FUNCTION

 CHKWRT70 RJM    GETSTA      GET STATUS
          MJN    CHKWRT70    IF RETRY OCCURED
          SHN    17-11       POSITION ALERT BIT
          PJK    CHKWRT20    IF NOT ALERT, PROCESS COMPLETION
          LDML   RESBUF+/RS/P.DSB+1   FETCH ERPA CODE FROM DETAILED STATUS
          LPK    0#FF                 MASK OFF THE ERPA CODE
          LMK    0#48                 IS IT ERPA CODE 48
          ZJK    CHKWRT20             TREAT ERROR AS INFORMATIVE
          LDK    /RS/K.HDWR  SET HARDWARE FAILURE
          STML   RESBUF+/RS/P.HDWR
          UJK    CHKWRT30    PROCESS WRITE FAILURE
          SPACE  2
 CHKWRTA  DATA   0           BYPASS SYNCHRONIZE FLAG
 CHKWRTF  DATA   0           CHECK WRITE FLAG
 CHKWRTS  DATA   0           SYNCHRONIZE SENT FLAG
          SPACE  5,20
** NAME-- CHKCH
*
** PURPOSE-- CHECK IF CHANNEL IS REQUESTED BY MALET.  IF SO, RELEASE
*            ANY CONNECTED UNIT AND CHANNEL.
*
          SPACE  2
 CHKCH    SUBR               ENTRY/EXIT

          LOADC  CM.CHAN     ADDRESS OF CHANNEL TABLE
          ADML   CURCH       CHANNEL IS INDEX INTO TABLE
          CRDL   T1          READ CHANNEL CM ENTRY
          LDDL   T2          OBTAIN MAINTENANCE BYTES OF CHANNEL WORD
          SHN    17-0        ALIGN MAINTENANCE BIT REQUEST TO SIGN BIT
          PJN    CHKCHX      IF CHANNEL NOT REQUESTED
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          UJN    CHKCHX      RETURN
          SPACE  5,20
** NAME - CKFL
*
** PURPOSE - CHECK FOR CHARACTER FILL.  IF SET, DECREMENT
*            BYTE COUNT BY 1.
*
** INPUT - RESPONSE HEADER ALREADY SETUP.
*
          SPACE  2
 CKFL     SUBR               ENTRY/EXIT

          LDML   RESBUF+/RS/P.CHRF  CHECK IF CHARACTER FILL IS SET
          LPK    /RS/K.CHRF
          ZJK    CKFLX       IF NO CHARACTER FILL
          LDDL   TRNCNT+3
          ADDL   TRNCNT+2
          ZJN    CKFLX       IF NO DATA READ (PROBABLY TAPE MARK)
          SODL   TRNCNT+3    DECREMENT TRANSFER COUNT
          PJN    CKFLX       IF NOT UNDERFLOW
          LDK    177777B     CORRECT 1-S COMPLEMENT RESULT
          STDL   TRNCNT+3
          SODL   TRNCNT+2    ADJUST MOST SIGNIFICIANT BITS
          UJK    CKFLX
          SPACE  5,20
** NAME-- CLOCK
*
** PURPOSE-- CLEAR A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS CLEARED.
*         A REGISTER .NE. O, IF THE LOCK WAS NOT CLEARED.
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T4 .NE. PPNO, THIS LOCKWORD IS RESERVED TO A
*            DIFFERENT PROCESSOR.
*            RESTORE THE CONTENTS OF THIS CENTRAL MEMORY LOCATION
*            AS IT EXISTED BEFORE THE VALUE FFFF FFFF XXXX XXXX
*            WAS WRITTEN.
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
*
*         4. IF T4 = PPNO, THEN CLEAR THE LOCKWORD IN CENTRAL MEMORY.
*            SET T1 - T4 = 0000 0000 0000 0000.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
*
          SPACE  2
 CLOCK    SUBR               ENTRY/EXIT

**        WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 CLOCK10  LCN    ZERO        SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDK    ZERO
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

**        CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.
*
**        CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJK    CLOCK10     IF THIS PP WAS NOT FIRST TO WRITE THE
                              INTERMEDIATE VALUE, REPEAT RDSL INSTRUCTION

          LDDL   T4          CHECK PP NUMBER
          SBDL   PPNO
          ZJN    CLOCK30     IF THIS PP HAS THE LOCK SET

**        RESTORE THE ORIGINAL CONTENTS.

          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE ORIGINAL CONTENTS
          LDK    ONE

 CLOCK20  UJK    CLOCKX      EXIT, A REGISTER NONZERO

**        CLEAR THE LOCKWORD.

 CLOCK30  LDK    ZERO
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          CLEAR THE LOCKWORD
          LDK    ZERO
          UJK    CLOCK20     EXIT, A REGISTER = 0
          SPACE  5,20
** NAME - CONNU
*
** PURPOSE - TO CONNECT A TAPE UNIT AND CHECK STATUS,
*            CHANNEL LOCK OBTAINED IF NECESSARY.
*
** INPUT - (A) = CONNECT CODE TO USE.
*
** OUTPUT - CHANNEL LOCK SET IF NOT ALREADY SET.
*           (CONFLG) = CURRENT CONNECT FUNCTION CODE OF UNIT.
*           (A) = +  NO ERROR.
*           (A) = -  ERROR, RESPONSE GENERATED.
*           (A) = 0  UNIT IS ALREADY CONNECTED.
*
          SPACE  2
 CONNU    SUBR               ENTRY/EXIT

          STML   CONNUA      SAVE ENTRY PARAMETER
          LDDL   CHLOCK      CHECK IF CHANNEL ALREADY LOCKED
          NJN    CONNU30     IF CHANNEL LOCK SET

 CONNU10  LDN    CHLK        SET CHANNEL LOCKWORD
          RJM    SCLK
          NJN    CONNU10     IF CHANNEL LOCK NOT OBTAINED
          AODL   CHLOCK      SET CHANNEL CURRENTLY LOCKED
          RJM    INICH       INITIALIZE CHANNEL
          ZJN    CONNU30     IF NO ERROR
          LPN    7           MASK ERROR CODE
          SBN    3           CHECK FOR CHANNEL ERROR FLAG ERROR
          NJN    CONNU20     IF NOT
          LJM    OUTCPE      GO PROCESS CHANNEL ERROR FLAG ERROR

 CONNU20  RJM    FTO         GO PROCESS FUNCTION TIMEOUT  (NO RETURN)

 CONNU30  LDK    7777B       FUNCTION CODE  (PLUGGED)
 CONNUA   EQU    *-1
          LMDL   CONFLG      CHECK IF ALREADY CONNECTED IN CORRECT MODE
          ZJN    CONNUX      IF YES, RETURN
          LDDL   CONFLG      CHECK IF PREVIOUS UNIT IS STILL CONNECTED
          ZJN    CONNU40     IF NOT
          RJM    REL         RELEASE PREVIOUS UNIT

 CONNU40  LDML   CONNUA      UPDATE CONNECT FLAG
          STDL   CONFLG
          RJM    DOFUNC      SEND FUNCTION CODE

 CONNU50  RJM    GETSTA      GET STATUS
          MJN    CONNU50     IF RETRY OCCURED
          SHN    17-11       CHECK FOR ALERT
          MJN    CONNU65     IF SET

 CONNU60  UJK    CONNUX      EXIT

 CONNU65  LDML   RESBUF+/RS/P.EC        Get second general status word
          LPK    /RS/M.EC               Mask the error code
          SBN    EC33                   Check control unit busy
          ZJN    CONNU40                If yes, retry connect

 CONNU70  LDK    /RS/K.HDWR  PROCESS ALERT
          STML   RESBUF+/RS/P.HDWR  SET RESPONSE
          LDML   RESBUF+/RS/P.GS1  GET GENERAL STATUS
          SHN    17-11       POSITION ALERT
          UJK    CONNU60     ABNORMAL TERMINATE EXIT
          SPACE  5,20
** NAME - DELINK
*
** PURPOSE - TO DELINK THE FIRST REQUEST ON THE QUEUE,
*            AND TO CLEAR THE UNIT BUSY COUNTER.
*
** INPUT - REQUEST HAS BEEN PROCESSED TO COMPLETION.
*
** OUTPUT - THE FIRST REQUEST ON THE UIT QUEUE IS DELINKED.
*
** NOTE - THE UIT REQUEST QUEUE LOCKWORD IS OBTAINED TO
*         DELINK THE REQUEST.
*
          SPACE  2
 DELINK   SUBR               ENTRY/EXIT

 DELINK10 LDN    QULK        LOCK UIT REQUEST QUEUE
          RJM    SCLK
          NJN    DELINK10    IF NOT SET TRY AGAIN
          LOADC  CM.UIT      SET R AND A TO UIT
          ADN    /UIT/C.NEXT  OFFSET TO FIRST REQUEST RMA
          CRDL   T1          READ FIRST REQUEST RMA
          LOADF  T3          REFORMAT RMA OF FIRST REQUEST
          CRML   SCRBUF,TW   READ IN NEXT REQUEST PVA AND RMA
          LOADC  CM.UIT      RESET R AND A TO UIT
          ADN    /UIT/C.NEXTPV  OFFSET TO NEXT PVA
          CWML   SCRBUF,TW   DELINK FIRST REQUEST
          LDN    QULK+40B    UNLOCK UIT REQUEST QUEUE
          RJM    SCLK
          LDDL   CONFLG      CHECK IF UNIT IS CONNECTED

 DELINK20 ZJN    DELINKX     IF NOT RETURN
          LPN    17B         MASK UNIT NUMBER
          STDL   T1          SET INDEX
          LDN    0           CLEAR UNIT BUSY COUNTER
          STML   SCRBUF+8,T1
          UJN    DELINK20    RETURN
          SPACE  5,20
** NAME - DOFUNC
*
** PURPOSE - PROCESS A FUNCTION WITH A CONTROLLER.
*
** INPUT - (A) = FUNCTION CODE TO ISSUE.
*
** OUTPUT - RETURN IF NO ERRORS OCCURED.
*
          SPACE  2
 DOFUNC   SUBR               ENTRY/EXIT

          STML   RESBUF+/RS/P.LSTF  SAVE LAST FUNCTION CODE
          LPN    77B         MASK LOWER 6 BITS
          SBN    F.CNT
          ZJN    DOFUNC10    IF CONTINUE FUNCTION
          SBN    F.GS-F.CNT
          ZJN    DOFUNC10    IF STATUS REQUEST  (X12)
          LDML   RESBUF+/RS/P.LSTF
          STML   RESBUF+/RS/P.LSTNSF  SAVE LAST NON STATUS FUNCTION

 DOFUNC10 LDML   RESBUF+/RS/P.LSTF  GET FUNCTION CODE
          AJM    DOFUNC20,TP  JUMP IF CHANNEL ACTIVE
          FAN    TP          ISSUE THE FUNCTION
          CFM    DOFUNC30,TP  CONTINUE IF CHANNEL ERROR FLAG IS CLEAR

*         PROCESS CHANNEL ERROR FLAG
 DOFUNC20 DCN    40B+TP      DISCONNECT CHANNEL
          LDML   RESBUF+/RS/P.LSTF  GET FUNCTION CODE
          LMN    F.REL

 DOFUNC25 ZJN    DOFUNCX     IF ERROR OCCURRED ON RELEASE FUNCTION
          LJM    OUTCPE      PROCESS OUTPUT CHANNEL ERROR FLAG

*         WAIT FOR FUNCTION REPLY.
 DOFUNC30 LDN    30          TIMEOUT 3 SECONDS ON ALL FUNCTIONS
          STML   DOFUNCA

 DOFUNC40 LDK    100000      SET FOR MAXIMUM DELAY OF 100 MSEC.

 DOFUNC50 IJM    DOFUNCX,TP  EXIT IF CHANNEL INACTIVE
          SBN    1
          NJN    DOFUNC50    CONTINUE LOOPING UNTIL 100 MSEC EXPIRES
          SOML   DOFUNCA     DECREMENT TIMEOUT COUNTER
          NJN    DOFUNC40    RELOOP UNTIL TIMEOUT

*         PROCESS FUNCTION TIMEOUT.
          DCN    40B+TP      DISCONNECT CHANNEL
          LDML   RESBUF+/RS/P.LSTF  GET FUNCTION CODE
          LMN    F.REL
          ZJN    DOFUNC25    IF TIMEOUT OCCURRED ON RELEASE FUNCTION
          RJM    FTO         PROCESS FUNCTION TIMEOUT  (NO RETURN)
          SPACE  2
 DOFUNCA  DATA   0           FUNCTION TIMEOUT COUNTER
          SPACE  5,20
** NAME - DSABLE
*
** PURPOSE - TO DISABLE A UNIT IF NECESSARY.
*
** INPUT - ABNORMAL RESPONSE GENERATED.
*
** OUTPUT - IF REQUIRED UNIT IS DISABLED IN UIT STATUS
*           AND RESPONSE STATUS.
*
          SPACE  2
 DSABLE   SUBR               ENTRY/EXIT

          LDML   RESBUF+/RS/P.ALRTM   CHECK ALERT MASK IF TO DISABLE UNIT
          SHN    18-16+/RS/L.DUNIT    DISABLE UNIT BIT TO SIGN POSITION
          PJN    DSABLEX              IF NOT  RETURN
          LDK    /RS/K.DUNIT          SET UNIT DISABLED BIT IN RESPONSE
          RAML   RESBUF+/RS/P.LNGBLK  SET RESPONSE ALERT CONDITIONS
          LDK    /UIT/K.DSABLE        SET UNIT DISABLED IN UIT STATUS
          RAML   UITHDR+/UIT/P.DSABLE
          LOADC  CM.UIT
          CWML   UITHDR,ON            UPDATE FIRST WORD OF UIT
          UJN    DSABLEX              RETURN
          SPACE  5,20
** NAME - ERRCHK
*
** PURPOSE - SET ALERT CONDITIONS AND ABNORMAL STATUS FIELDS FOR TAPE.
*
** OUTPUT - (P2) = 0 IF NO ABNORMAL CONDITION.
*           (P2) NON-ZERO IF ERROR DETECTED.
*           (A) = 0 IF NO ERRORS OR TERMINATION CONDITION.
*
          SPACE  2
 ERRCHK   SUBR               ENTRY/EXIT

          LDK    ZERO
          STDL   T1          CLEAR ALERT CONDITIONS
          STDL   P2          CLEAR ABNORMAL STATUS

*         CHECK IF ANY ERRORS OCCURED.

          LDML   RESBUF+/RS/P.GS1
          STDL   T4          SAVE GS1
          LDML   URBHDR+/URB/P.WRTCNT  CHECK IF WRITE OPERATION
          ZJN    ERRCHK10    IF NOT WRITE OPERATION
          LDDL   T4          DONT INCLUDE BOT IN PHYSICAL DELIMETER CHECK
          LPC    /RS/K.ALERT+/RS/K.TM+/RS/K.EOT
          UJN    ERRCHK20

 ERRCHK10 LDDL   T4          INCLUDE BOT IN PHYSICAL DELIMETER CHECK
          LPC    /RS/K.ALERT+/RS/K.TM+/RS/K.EOT+/RS/K.BOT

 ERRCHK20 ADML   RESBUF+/RS/P.GS2
          ADDL   LONG
          ZJN    ERRCHKX     IF NO ERRORS TO LOOK AT

*         CHECK IF LONG BLOCK ERROR.

          LDDL   LONG
          ZJN    ERRCHK30    IF NOT LONG INPUT BLOCK
          LDK    /RS/K.LNGBLK  SET LONG INPUT BLOCK CONDITION
          RADL   T1

*         CHECK FOR PHYSICAL DELIMETERS OF BOT AND EOT.

 ERRCHK30 LDDL   T4          WORD ONE OF GENERAL STATUS
          LPN    /RS/K.EOT+/RS/K.BOT  MASK PHYSICAL DELIMITERS
          ZJN    ERRCHK50    SKIP IF NEITHER EOT OR BOT SET
          LDML   URBHDR+/URB/P.WRTCNT  CHECK IF WRITE OPERATION
          ZJN    ERRCHK40    IF NOT
          LDDL   T4          CHECK FOR EOT ONLY ON WRITE OPERATIONS
          LPN    /RS/K.EOT
          ZJN    ERRCHK50    IF NOT EOT ON WRITE

 ERRCHK40 LDK    /RS/K.PDLIM  SET PHYSICAL DELIMITER
          RADL   T1

*         CHECK FOR LOGICIAL DELIMETER OF TAPE MARK.

 ERRCHK50 LDDL   T4          WORD ONE OF GENERAL STATUS
          LPN    /RS/K.TM    MASK TAPE MARK INDICATOR
          ZJN    ERRCHK60    SKIP IF TAPE MARK NOT INDICATED
          LDK    /RS/K.LDLIM  SET LOGICAL DELIMITER

*         PROCESS ALERT CONDITIONS.

 ERRCHK60 RADL   T1
          LPML   RESBUF+/RS/P.ALRTM  MASK ALERTS WITH ALERT MASK
          STML   RESBUF+/RS/P.LNGBLK  SET ALERT CONDITIONS IN RESPONSE
          ZJN    ERRCHK70    SKIP IF NO ALERT CONDITIONS ENCOUNTERED
          LDK    /RS/K.ABALRT  SET ABNORMAL ALERT INDICATOR
          STDL   P2

 ERRCHK70 LDML   RESBUF+/RS/P.GS2  CHECK GS WORD 2
          ZJN    ERRCHK80    SKIP IF NO ERRORS ARE INDICATED
          LDK    /RS/K.HDWR  SET HARDWARE ERROR

 ERRCHK80 RADL   P2
          STML   RESBUF+/RS/P.ABALRT  SET ABNORMAL STATUS FIELD IN RESPONSE
          UJK    ERRCHKX     RETURN
          SPACE  5,20
** NAME-- FLAGERR
*
** PURPOSE-- TO PROCESS READ/WRITE CHANNEL FLAG ERRORS.
*
** INPUT-- CHANNEL FLAG WAS FOUND TO BE IN THE WRONG STATE.
*
** OUTPUT-- ERROR RESPONSE GENERATED.
*
          SPACE  2
 FLAGERR  BSS                ENTRY

          DCN    40B+TP      DEACTIVATE THE CHANNEL
          CCF    *+2,TP      UNCONDITIONALY CLEAR THE CHANNEL FLAG
          LDK    REIFE       SET RESPONSE ERROR ID
          STML   RESBUF+/RS/P.REID
          STDL   LMCFLG      SET RELOAD MICROCODE FLAG
          LDK    /RS/K.HDWR  SET HARDWARE ERROR
          STML   RESBUF+/RS/P.ABALRT
          UJK    FAIL
          SPACE  5,20
** NAME-- FORMA
*
** PURPOSE-- FORMAT A CM REAL MEMORY ADDRESS.
*
** CALLING SEQUENCE-- LDC    ADDRESS
*                     RJM    FORMA
*
** INPUT-- - A REGISTER- IS THE ADDRESS OF A 2-WORD CM BYTE ADDRESS.
*
** OUTPUT-- -CMADR- IS THE ADDRESS OF THE RESULTING 3-WORD REFORMATED
*                CM ADDRESS.  THE FORMAT CAN BE USED BY THE LOADC MACRO.
*           -ADDRESS-, WORD 0, BITS 0-13 AND
*                      WORD 1, BITS 3-15, ARE REFORMATTED TO-
*           -CMADR-,   WORD 0, BITS 0-9,
*                      WORD 1, BITS 0-11,
*                      WORD 2, BITS 0-5.
*
** USES-- T1,CMADR,CMADR+1,CMADR+2
*
          SPACE  2
 FORMA    SUBR               ENTRY/EXIT

          STDL   T1          SAVE ENTRY PARAMETER

**        REFORMAT THE CM ADDRESS.

          LDML   1,T1
          LPN    7
          NJN    *           RMA ADDRESS ERROR, HALT
          LDIL   T1
          LPN    37B
          SHN    16
          LMML   1,T1
          SHN    9
          STDL   CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   T1
          SHN    -5
          STDL   CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMC    400000B
          UJK    FORMAX      EXIT
          SPACE  5,20
** NAME - FORMU
*
** PURPOSE - TO PROCESS A FORMAT UNIT FUNCTION.
*            CONNECT A TAPE UNIT AND GET CURRENT BLOCK ID.
*
** INPUT - (UDPNT) = CURRENT UD POINTER FOR UNIT.
*
** OUTPUT - URBHDR IS INITIALIZED FOR THIS REQUEST.
*            URBHDR+/URB/P.CONF = CONNECT FUNCTION FOR THIS REQUEST,
*            URBHDR+/URB/P.SBID = STARTING BLOCK ID,
*            ALL OTHER FIELDS ARE CLEARED.
*
          SPACE  2
 FORMU    BSS                ENTRY

          LOADC  CM.COM      LOAD R AND A FOR PP COMMUNICATION BUFFER
          ADN    /CB/C.ZEROES  OFFSET TO ZEROES FIELD
          CRML   URBHDR,TW   CLEAR URB HEADER
          LDML   UNITD+/PUD/P.UNIT,UDPNT  GET UNIT NUMBER
          LPN    17B         MASK 4 BITS
          ADK    F.SEL       SELECT FUNCTION CODE
          STML   URBHDR+/URB/P.CONF  SAVE FUNCTION CODE
          LDML   REQBUF+/RQ/P.RECOV  CHECK FOR RECOVERY ENABLED
          SHN    3
          PJN    FORMU10     IF YES
          LDK    100B        SET RECOVERY DISABLED
          RAML   URBHDR+/URB/P.CONF

 FORMU10  LDML   URBHDR+/URB/P.CONF  GET CONNECT FUNCTION CODE
          RJM    CONNU       CONNECT THE UNIT
          ZJN    FORMU15     IF UNIT PREVIOUSLY CONNECTED
          MJN    FORMU20     IF ERROR  (RESPONSE ALREADY GENERATED)
          RJM    GETBID      GET CURRENT BLOCK ID
          MJN    FORMU20     IF ERROR  (RESPONSE ALREADY GENERATED)
 FORMU15  LDML   BIDBUF      SET STARTING BLOCK ID
          STML   URBHDR+/URB/P.SBID
          LDML   BIDBUF+1
          STML   URBHDR+/URB/P.SBID+1
          UJK    NOSTAT      EXIT OK

 FORMU20  UJK    FAIL        REPORT ERROR
          SPACE  5,20
** NAME - FTO
*
** PURPOSE - PROCESS FUNCTION TIMEOUT ERRORS.
*
** OUTPUT - FUNCTION TIMEOUT ERROR RESPONSE GENERATED.
*
          SPACE  2
 FTO      BSS    1           **ENTRY ONLY** NO EXIT

          SFM    OUTCPE,TP   CHECK AND CLEAR CHANNEL ERROR FLAG
          LDK    REIFT       SET RESPONSE ERROR ID
          STML   RESBUF+/RS/P.REID
          STDL   LMCFLG      SET RELOAD MICROCODE FLAG
          LDK    /RS/K.HDWR  SET HARDWARE ERROR
          STML   RESBUF+/RS/P.ABALRT
          RJM    GETHS       TRY TO GET HARDWARE STATUS
          UJK    FAIL        REPORT ERROR
          SPACE  5,20
** NAME - GETBID
*
** PURPOSE - GET CURRENT BLOCK ID-S.
*
** INPUT - UNIT ALREADY CONNECTED.
*
** OUTPUT - (BIDBUF) FIRST 32 BITS = HOST POSITION BLOCK ID,
*                     NEXT 16 BITS = UNUSED,
*                     NEXT 32 BITS = MEDIA POSITION BLOCK ID,
*                     LAST 16 BITS = UNUSED.
*
*           (A) = +NON-ZERO  NO ERROR.
*           (A) = -NON-ZERO  ERROR, RESPONSE GENERATED.
*
** NOTE - IF THE UNIT IS NOT READY OR IS BUSY THE BLOCK ID WILL
*         BE SET TO ALL ZEROES AND (A) WILL BE +ZERO ON RETURN.
*
          SPACE  2
 GETBID   SUBR               ENTRY/EXIT

          LDML   RESBUF+/RS/P.GS1  CHECK FOR READY AND NOT BUSY
          LPK    /RS/K.BSY+/RS/K.RDY  MASK THE STATUS
          SBN    /RS/K.RDY
          NJK    GETBID30    IF UNIT IS NOT READY OR BUSY
          LDK    F.RBID      ELSE  READ BLOCK ID FUNCTION CODE
          RJM    DOFUNC      SEND THE FUNCTION

 GETBID10 ACN    TP          ACTIVATE THE CHANNEL
          LDK    8           12-BIT WORD COUNT
          IAPM   BIDBUF,TP   INPUT THE BLOCK ID-S
          DCN    40B+TP      DEACTIVATE THE CHANNEL
          STDL   AREG        SAVE RESIDUAL WORD COUNT IF ANY
          SFM    INCPE,TP    CHECK AND CLEAR CHANNEL ERROR FLAG
          RJM    GETSTA      GET STATUS
          MJN    GETBID10    IF RETRY OCCURED
          LDML   RESBUF+/RS/P.GS1
          SHN    17-11       POSITION ALERT BIT
          PJN    GETBID50    IF NO ERROR
          LDK    /RS/K.HDWR  SET HARDWARE ERROR
          STML   RESBUF+/RS/P.ABALRT

*         PREPARE TO RETURN.
 GETBID20 LDML   RESBUF+/RS/P.GS1  GET STATUS WORD
          SHN    17-11       POSITION ALERT BIT
          UJK    GETBIDX     EXIT  (A) = + OR -

*         PROCESS NOT READY OR A BUSY UNIT.
 GETBID30 LDK    ZERO        CLEAR THE BLOCK ID BUFFER
          STDL   T1          INITIALIZE THE INDEX

 GETBID40 LDK    ZERO        CLEAR A BUFFER CELL
          STML   BIDBUF,T1
          AODL   T1          INCREMENT THE INDEX
          SBN    6           CHECK FOR DONE (16-BIT WORDS)
          NJK    GETBID40    IF NOT  LOOP
          UJK    GETBID20    EXIT (A)=0

*         CHECK FOR RESIDUAL INPUT WORD COUNT.
 GETBID50 LDDL   AREG        GET RESIDUAL WORD COUNT
          NJK    RCNZI       PROCESS NON-ZERO RESIDUAL WORD COUNT ERROR
          UJK    GETBID20    PREPARE TO RETURN
          SPACE  5,20
** NAME - GETBL
*
** PURPOSE - DETERMINE THE RMA(S) OF THE CM BUFFER(S) THAT THIS PP
**           WILL USE DURING A TAPE READ.
*
** INPUT - INIBUF CALLED.
*
** OUTPUT - 6 PP WORD TABLE (CMTABLE)
*
          SPACE  2
 GETBL    SUBR               ENTRY/EXIT

          LDK    ZERO
          STML   SPACE1      INITIALIZE RMA(S) AND LENGTHS FOR THIS READ
          STML   SPACE2
          STML   RMA2.1
          STML   RMA2.2
          LDML   CBUFRMA     RMA OF THE CURRENT CENTRAL BUFFER
          STML   RMA1.1
          LDML   CBUFRMA+1
          STML   RMA1.2
          LDML   NADAMAS     CHECK FOR ZERO SPACE LEFT
          NJN    GETBLX      EXIT - NO SPACE LEFT
          LDML   SPACE       SPACE IN CURRENT BUFFER
          ADC    -DUALBUFL*2
          MJN    GETBL30     IF NOT ENOUGH SPACE IN CURRENT BUFFER
          LDK    DUALBUFL*2
          STML   SPACE1      LENGTH TO BE USED IN BUFFER AT RMA1

 GETBL10  RJM    BUMPIT      RESET THE RMA(S) FOR THE NEXT TIME.

 GETBL20  LJM    GETBLX      EXIT

 GETBL30  LDML   SPACE       SET SPACE THIS RMA.
          STML   SPACE1
          LDK    DUALBUFL*2  DETERMINE HOW MUCH IS NEEDED FROM THE
          SBML   SPACE         NEXT (IF ANY) RMA.
          STDL   T1          T1 = HOW MUCH IS NEEDED
          LDML   NUMBUF      SEE IF THERE ARE ANY MORE BUFFERS
          NJN    GETBL40     THERE IS AT LEAST 1 BUFFER MORE
          AOML   NADAMAS     SET THE -NO MORE SPACE- FLAG
          UJN    GETBL20     EXIT

 GETBL40  LDML   NXSPACE     SPACE AVAILABLE IN THE NEXT BUFFER
          SBDL   T1          SUBTRACT HOW MUCH IS NEEDED
          ZJN    GETBL70     IF EQUAL
          MJN    GETBL80     IF STILL NOT ENOUGH

 GETBL50  LDDL   T1          MORE THAN ENOUGH
          STML   SPACE2      PUT THIS AMOUNT IN THE CMTABLE

 GETBL60  LDML   NBUFRMA     PUT THE SECOND RMA IN THE TABLE
          STML   RMA2.1
          LDML   NBUFRMA+1
          STML   RMA2.2
          LJM    GETBL10     UPDATE THE RMA(S) AND EXIT

 GETBL70  AOML   NADAMAS     SET END OF BUFFERS FLAG
          UJN    GETBL50     SET THE TABLE AND EXIT

 GETBL80  LDML   NXSPACE     NOT ENOUGH WITH 2 RMA-S
          STML   SPACE2      SET IT TO WHAT WE HAVE
          AOML   NADAMAS     SET END OF BUFFERS
          UJN    GETBL60     SET THE RMA AND EXIT
          SPACE  5,20
** NAME - GETCM
*
** PURPOSE - GET DATA FROM CENTRAL MEMORY FOR A TAPE WRITE.
*
** DESCRIPTION - THE IDEA IS TO BUFFER INTO THE PP A -CHUNK- OF DATA
*                FROM CENTRAL MEMORY.  THE PP WORD LABELED -SPACE- HAS
*                THE NUMBER OF BYTES REMAINING IN THIS CM BUFFER.  WORD
*                -NUMBUF- IS THE NUMBER OF CM BUFFERS (INCLUDING THE
*                CURRENT ONE).  THE NEXT BUFFER WILL BE AT -CBUFRMA-
*                PLUS 10B (BUFFERS ARE WORD ALIGNED).  SINCE THIS IS A
*                DUAL PP DRIVER, EACH PP USES EVERY OTHER CHUNK (IE. GET
*                A CHUNK, SKIP A CHUNK).
*
          SPACE  2
 GETCM    SUBR               ENTRY/EXIT

          LDK    DUALBUFL*2  LENGTH OF THE BUFFER IN BYTES
          SBML   SPACE       SUBTRACT SPACE REMAINING IN THIS BUFFER
          PJN    GETCM10     IF NOT ENOUGH DATA IN THIS CM BUFFER
          LJM    GETCM40     READ DATA FROM CM

 GETCM10  LDML   SPACE
          STDL   T6          KEEP TRACK OF ACTUAL BYTE COUNT
          ADN    7           ROUND UP JUST IN CASE
          SHN    -3          READ IN WHAT REMAINS OF THIS BUFFER
          STDL   T5          CM WORD COUNT
          LOADF  CBUFRMA     CM BUFFER ADDRESS
          CRML   DIOBUF,T5
          LDML   NUMBUF      CHECK THE BUFFER COUNT
          NJN    GETCM20     MORE BUFFERS IN CM
          AOML   EODATA      SET END OF DATA FLAG
          LDML   SPACE       CONVERT BYTES TO CHANNEL WORDS
          STDL   BYTCNT      SAVE FOR CBYTE ROUTINE
          RJM    CBYTE       CONVERT TO CHANNEL WORDS
          LJM    GETCMX      EXIT

 GETCM20  LDK    DUALBUFL*2  NUMBER OF BYTES IN TOTAL BUFFER
          SBML   SPACE       NUMBER OF BYTES UNREAD
          STDL   T3          SAVE THIS NUMBER
          LDML   SPACE       SAVE OFFSET INTO BUFFER
          STDL   T4
          LDML   NXSPACE     BYTES AVAILABLE FROM NEW CM BUFFER
          SBDL   T3          SUBTRACT THE BYTES NEEDED TO FILL PP BUFFER
          SBN    1           TAKE CARE OF THE ZERO CASE
          PJN    GETCM30     ENOUGH TO FILL PP BUFFER
          LDML   NXSPACE     USE WHAT IS IN CM.  NO MORE THAN 2
                              RMA-S ARE EVER USED TO FILL PP BUFFER.
          STDL   T3
          AOML   EODATA      THIS WILL BE THE LAST ONE

 GETCM30  LDDL   T3
          RADL   T6          BYTE COUNT
          LDDL   T3
          ZJN    GETCM50     IF NO MORE DATA TO FETCH FROM CENTRAL
          ADN    7           CONVERT BYTE COUNT TO CM WORDS
          SHN    -3
          STDL   T5
          LDDL   T4          COMPUTE OFFSET INTO BUFFER
          SHN    -1          BYTES TO PP WORD CONVERSION
          ADC    DIOBUF      ADD BEGINNING OF THE BUFFER
          STML   GETCMA
          LOADF  NBUFRMA
          CRML   *,T5        READ DATA TO PP BUFFER
 GETCMA   EQU    *-1

          UJN    GETCM50     PREPARE TO EXIT

 GETCM40  LDK    DUALBUFL*2  BYTES USED THIS CM BUFFER
          STDL   T6          USED FOR TRANSFER COUNT
          SHN    -3
          STDL   T5          STORE CM WORD COUNT
          LOADF  CBUFRMA     LOAD A/R REGISTERS FOR CM READ
          CRML   DIOBUF,T5   READ THE DATA FROM CENTRAL

 GETCM50  LDDL   T6          CONVERT BYTE COUNT TO CHANNEL WORD COUNT
          STDL   BYTCNT      INPUT TO CBYTE ROUTINE
          RJM    CBYTE
          LDML   EODATA      SKIP BUMPIT AT END
          NJN    GETCM60     IF END OF DATA
          RJM    BUMPIT      ADJUST CBUFRMA

 GETCM60  LJM    GETCMX      EXIT
          SPACE  5,20
** NAME - GETHS
*
** PURPOSE - LOAD AND EXECUTE GETHSO OVERLAY.
*

 GETHS    SUBR               ENTRY/EXIT

          LOADOVL MRO        LOAD THE MISC ROUTINES OVERLAY
          LDK    CONCHMR     SET CHANNEL NUMBERS
          RJM    CHGCH
          RJM    GETHSO      EXECUTE THE OVERLAY ROUTINE
          UJN    GETHSX      RETURN
          SPACE  5,20
** NAME - GETHSC
*
** PURPOSE - GET HARDWARE STATUS (CHANNEL) ON IOU FAILURES.
*
** INPUT - (CHTYPE) = 0 IF NIO CHANNEL OR 1 IF CIO CHANNEL.
*
** OUTPUT - (A) = ZERO IF NO ERROR,
*                 NON-ZERO IF ERROR OCCURED.
*
** NOTE - ERRORS DURING PROCESSING WILL NOT GENERATE ANY NEW
*         ERROR RESPONSE BECAUSE THIS ROUTINE IS BEING USED TO
*         PROCESS AN EXISTING ERROR.
*
          SPACE  2

 GETHSC10 LDK    ONE         EXIT BAD

 GETHSC   SUBR               ENTRY/EXIT

          LDDL   CHTYPE      CHECK IF CIO CHANNEL PRESENT
          ZJK    GETHSCX     IF NOT EXIT
          LDK    F.RDESR     READ ERROR STATUS REGISTER
          RJM    CHFUNC
          ZJK    GETHSC10    IF FUNCTION TIMEOUT
          ACN    TP          INPUT ERROR STATUS REGISTER
          IAN    TP
          DCN    40B+TP
          STML   RESBUF+/RS/P.CESR  RETURN REGISTER IN RESPONSE BUFFER
          LDK    ZERO
          UJK    GETHSCX     EXIT OK
          SPACE  5,20
** NAME - GETSTA
*
** PURPOSE - TO GET AND PROCESS GENERAL STATUS.
*
** OUTPUT - A = GENERAL STATUS WORD 1 IN BITS 11-0,
*           OR
*           A = NEGATIVE IF RETRY OCCURED.
*
** NOTES- 1. GET BOTH WORDS OF GENERAL STATUS.
*         2. IF *ALERT* NOT SET  RETURN.
*         3. IF *CONTINUE* IS SET SEND CONTINUE FUNCTION AND
*            RETURN A = NEGATIVE.
*         4. IF *WAIT FOR CONTINUE* IS SET DELAY AWHILE AND
*            GO TO STEP 1.
*         5. GET DETAILED STATUS.
*         6. RETURN.
*
          SPACE  2
 GETSTA10 LDN    0           CLEAR RETRY AND CONTINUE COUNTERS
          STML   GETSTAC
          STML   GETSTAD
          STML   GETSTAE
          LDML   RESBUF+/RS/P.GS1  EXIT WITH GS1

 GETSTA   SUBR               ENTRY/EXIT

*         SET WAIT END-OF-OPERATION FOR ABOUT 2.5 MINUTES
          LDK    60          WAIT EOP OUTER LOOP TIMER
          STDL   T2

 GETSTA20 LCN    ZERO        WAIT EOP INNER LOOP TIMER
          STDL   T1

 GETSTA30 LDK    F.GS        GET GENERAL STATUS FUNCTION
          RJM    DOFUNC      ISSUE GENERAL STATUS FUNCTION
          ACN    TP          ACTIVATE CHANNEL
          LDK    10          WAIT 10 USEC ON 4X PPU SPEED

 GETSTA40 FJM    GETSTA50,TP  JUMP WHEN 1ST WORD IS AVAILABLE
          SBN    1
          NJN    GETSTA40    IF NOT TIMEOUT
          DCN    TP+40B      DISCONNECT THE CHANNEL
          SODL   T1          DECREMENT WAIT TIME
          NJN    GETSTA30    RELOOP TO REISSUE THE STATUS FUNCTION
          SODL   T2          DECREMENT OUTER LOOP TIME
          NJN    GETSTA20    IF NOT TIMEOUT
          RJM    FTO         PROCESS FUNCTION TIMEOUT ERROR  (NO RETURN)

 GETSTA50 LDK    TWO         INPUT BOTH GENERAL STATUS WORDS
          IAM    RESBUF+/RS/P.GS1,TP  INPUT TO RESPONSE BUFFER
          DCN    TP+40B
          NJK    RCNZI       PROCESS NON-ZERO RESIDUAL WORD COUNT ERROR
          SFM    INCPE,TP    CHECK AND CLEAR CHANNEL PARITY ON INPUT
          LDML   RESBUF+/RS/P.ALERT  CHECK IF ALERT IS SET
          SHN    17-11
          PJK    GETSTA10    IF NOT SET  EXIT
          SHN    17-10-17+11  CHECK FOR CONTINUE BIT 2**10
          PJN    GETSTA60    IF NOT SET
          AOML   GETSTAC     INCREMENT CONTINUE COUNTER
          SHN    1           CHECK FOR LIMIT
          MJN    GETSTA55    IF LIMIT REACHED
          LDML   DOUTCNT     CHECK IF WRITE CONTINUE FLAG IS SET
          NJN    GETSTA52    IF YES, LET WRITE ROUTINE SEND CONTINUE FUNCTION
          LDK    F.CNT       CONTINUE FUNCTION CODE
          RJM    DOFUNC      SEND CONTINUE FUNCTION CODE

 GETSTA52 LDN    0           CLEAR RETRY COUNTERS
          STML   GETSTAD
          STML   GETSTAE
          LCN    ONE         MAKE A = NEGATIVE
          UJK    GETSTAX     EXIT

 GETSTA55 LDK    REIFT       PROCESS RETRY OR CONTINUE LIMIT ERROR
          STML   RESBUF+/RS/P.REID  SET RESPONSE ERROR ID
          STDL   LMCFLG      SET RELOAD MICROCODE FLAG
          LDK    /RS/K.HDWR  SET HARDWARE ERROR
          STML   RESBUF+/RS/P.ABALRT
          UJK    FAIL        REPORT ERROR

 GETSTA60 SHN    4           CHECK FOR RETRY IN PROGRESS BIT 2**6
          PJN    GETSTA70    IF NOT SET
          AOML   GETSTAE     INCREMENT RETRY COUNTER
          SHN    -16
          RAML   GETSTAD
          SHN    9           CHECK FOR LIMIT
          MJN    GETSTA55    IF LIMIT REACHED
          PAUSE  50          DELAY AWHILE
          UJK    GETSTA20    GET STATUS AGAIN

 GETSTA70 LDK    F.DS        DETAILED STATUS FUNCTION
          RJM    DOFUNC      SEND FUNCTION
          LDK    ABNRES      SET ABNORMAL RESPONSE LENGTH
          STML   RESBUF+/RS/P.RESPL
          LDK    26          WORD COUNT
          ACN    TP          ACTIVATE CHANNEL
          IAPM   RESBUF+/RS/P.DSB,TP  INPUT THE DETAILED STATUS
          DCN    40B+TP
          NJK    RCNZI       PROCESS NON-ZERO RESIDUAL WORD COUNT ERROR
          SFM    INCPE,TP    CHECK AND CLEAR CHANNEL ERROR FLAG
          LDML   RESBUF+/RS/P.GS2  CHECK GS WORD 2
          LPC    /RS/M.EC    MASK ERROR CODE FIELD
          ZJN    GETSTA80    IF NOT SET
          SHN    -6          POSITION 1XX(8) BIT OF ERROR CODE
          LPN    1           MASK IT
          ZJN    GETSTA80    IF NOT SET
          STDL   LMCFLG      SET RELOAD MICROCODE FLAG

 GETSTA80 UJK    GETSTA10    EXIT

 GETSTAC  DATA   0           CONTINUE COUNTER
 GETSTAD  DATA   0           RETRY COUNTER UPPER
 GETSTAE  DATA   0           RETRY COUNTER LOWER
          SPACE  5,20
** NAME - GNEWPR
*
** PURPOSE - GET THE NEXT LENGTH/ADDRESS PAIR FROM THE INDIRECT
*            LIST.
*
** INPUT - NUMBUF = NUMBER OF THE BUFFER AT NBUFRMA.
*          BUFLSTPT = RMA OF PAIR AT NBUFRMA.
*
** OUTPUT - NEW LENGTH/ADDRESS PAIR READ OR NBUFRMA ZEROED.
*
          SPACE  2
 GNEWPR   SUBR               ENTRY/EXIT

          SOML   NUMBUF      DECREMENT THE NUMBER OF BUFFERS
          NJN    GNEWPR10
          STML   NBUFRMA     NONE LEFT - ZERO RMA
          STML   NBUFRMA+1
          STML   NXSPACE
          UJN    GNEWPRX     EXIT

 GNEWPR10 LDK    10B         INCREMENT THE BUFFER POINTER
          RAML   BUFLSTPT+1
          SHN    -16
          RAML   BUFLSTPT
          LOADF  BUFLSTPT    FORMAT THE ADDRESS IN A AND R
          CRML   INDLST+8,ON   READ IT INTO THE INDIRECT LIST BUFFER
          UJN    GNEWPRX     EXIT
          SPACE  5,20
**  NAME - ICS
*
**  PURPOSE - REPORT INVALID COMMAND SEQUENCE WHILE WRITES REQUESTS
*             ARE STILL OUTSTANDING.
*
          SPACE  2
 ICS      BSS                ENTRY

          LDK    REIICS      SET RESPONSE ERROR ID
          STML   RESBUF+/RS/P.REID
          LDK    /RS/K.INTERR  SET INTERFACE ERROR
          STML   RESBUF+/RS/P.ABALRT
          UJK    FAIL        PROCESS FAILURE
          SPACE  5,20
**  NAME - INIBUF
*
**  PURPOSE - ESTABLISH THE VALUES THAT WILL BE USED BY THE
*             GETCM AND GETBL SUBROUTINES.
*
**  INPUT - (T4) = ADDR OF LENGTH/ADDR PAIR FOR READ/WRITE TO INITIALIZE.
*
**  OUTPUT - SPACE = THE AMOUNT OF SPACE LEFT IN THE CURRENT CM
*                    BUFFER.
*            CBUFRMA = THE RMA OF THE CURRENT BUFFER.
*            NBUFRMA = THE RMA OF THE NEXT BUFFER.
*            BUFLSTPT = THE RMA POINTER TO THE CM ADDRESS OF THE LAST
*                      LENGTH/ADDRESS PAIR CURRENTLY IN PP MEMORY.
*            NUMBUF = THE NUMBER OF LENGTH/ADDRESS PAIRS ASSOCIATED
*                     WITH THIS COMMAND.
*
          SPACE  2
 INIBUF   SUBR               ENTRY/EXIT

          LDK    ZERO        INITIALIZE SOME FLAGS
          STML   EODATA
          STML   ENTHERE
          STML   NADAMAS
          LDK    DUALBUFL*2  INITIALIZE SHORT BYTE COUNT
          STML   SHBYTEC
          LDIL   T4          GET COMMAND AND FLAGS
          LPC    INDFLG      GET THE INDIRECT FLAG (BIT 6)
          ZJN    INIBUF20    IF DIRECT LIST

**        PROCESS INDIRECT LIST.
          LDML   1,T4        INDIRECT BUFFER LENGTH
          SHN    -3          LENGTH OF BUFFER LIST IS IN BYTES
          SBN    1
          STML   NUMBUF      SET NUMBER OF BUFFERS
          LDML   2,T4        INITIALIZE BUFLSTPT
          STML   BUFLSTPT    THIS WILL BE THE CM ADDRESS (RMA) OF THE LAST
          LDML   3,T4          LENGTH/ADDRESS PAIR CURRENTLY IN PP MEMORY.  IT
          ADN    10B           IS INCREMENTED IN ROUTINE *GNEWPR*
          STML   BUFLSTPT+1
          SHN    -16
          RAML   BUFLSTPT
          LOADF  2,T4        SET UP ADDRESS OF THE INDIRECT LIST
          CRML   INDLST+4,TW  READ THE FIRST TWO LENGTH/
                               ADDRESS PAIRS.  NOTE - CBUFRMA IS EQUATED
                               TO INDLST+6.  SPACE IS EQUATED TO INDLST+5.

**        PREPARE TO EXIT.
 INIBUF10 CCF    *+2,TP      UNCONDITIONALLY CLEAR CHANNEL FLAG
          UJK    INIBUFX     EXIT

**        PROCESS DIRECT LIST.
 INIBUF20 LDML   2,T4        THERE IS ONLY ONE BUFFER
          STML   CBUFRMA     POINT TO THE BUFFER
          LDML   3,T4        RMA'S ARE 2 PP WORDS LONG
          STML   CBUFRMA+1   STORE BOTH HALVES
          LDML   1,T4        GET THE LENGTH
          STML   SPACE       STORE IT AWAY FOR FUTURE USE
          LDK    ZERO        SET NUMBER OF BUFFERS - 1
          STML   NUMBUF      SET THE BUFFER COUNT
          UJK    INIBUF10    PREPARE TO EXIT
          SPACE  5,20
** NAME - INICH
*
** PURPOSE - INITIALIZE THE CHANNEL.
*
** INPUT - (CHTYPE) = 0 IF NIO  OR  1 IF CIO CHANNEL.
*
** OUTPUT - (A) = ZERO IF NO ERROR,
*                 NON-ZERO IF ERROR OCCURED.
*
          SPACE  2
 INICH    SUBR               ENTRY/EXIT

          DCN    40B+TP      DEACTIVATE THE CHANNEL
          SFM    *+2,TP      CLEAR CHANNEL ERROR FLAG
          LDDL   CHTYPE      CHECK IF CIO CHANNEL PRESENT
          ZJK    INICHX      IF NOT EXIT
          LDK    F.MCLEAR    MASTER CLEAR ADAPTER AND CHANNEL
          STML   RESBUF+/RS/P.LSTF  SAVE LAST FUNCTION
          STML   RESBUF+/RS/P.LSTNSF  SAVE LAST NON STATUS FUNCTION
          RJM    CHFUNC
          ZJN    INICH30     IF ERROR ON FUNCTION
          LDK    F.WRCR      WRITE CONTROL REGISTER
          STML   RESBUF+/RS/P.LSTF  SAVE LAST FUNCTION
          STML   RESBUF+/RS/P.LSTNSF  SAVE LAST NON STATUS FUNCTION
          RJM    CHFUNC
          ZJN    INICH30     IF ERROR ON FUNCTION
          ACN    TP
          LDML   INICHA      GET PARAMETER WORD
          OAN    TP
          FJM    *,TP        WAIT FOR EMPTY
          DCN    40B+TP
          CFM    INICHX,TP   EXIT IF CHANNEL ERROR FLAG IS CLEAR

 INICH10  RJM    GETHSC      TRY TO GET HARDWARE STATUS (CHANNEL)
          CFM    *+2,TP      CLEAR CHANNEL ERROR FLAG
          LDK    7773B       REPORT CIO CHANNEL ERROR FLAG WAS SET

 INICH20  UJK    INICHX      EXIT

 INICH30  SFM    INICH10,TP  CHECK AND CLEAR CHANNEL ERROR FLAG
          LDK    7774B       REPORT FUNCTION TIMEOUT ERROR
          UJK    INICH20

 INICHA   CON    400B        PARAMETER FOR WRITE CONTROL REGISTER
          SPACE  5,20
** NAME - IODONE
*
** PURPOSE - TO TERMINATE THE REQUEST.
*
** INPUT - RESPONSE GENERATED.
*
** OUTPUT - REQUEST DELINKED RESPONSE SENT AND
*           UNIT RELEASED IF NECESSARY.
*
** NOTE - ALTERNATE ENTRY POINT AT (IODONE20).
*
          SPACE  2
 IODONE   BSS                ENTRY

          RJM    DELINK      DELINK REQUEST
          RJM    RESP        SEND RESPONSE TO CPU
          LDDL   FRELF       CHECK IF FORCE RELEASE FLAG IS SET
          NJN    IODONE10    IF YES
          LDML   RESBUF+/RS/P.RC  CHECK IF NORMAL RESPONSE
          ADC    -R.NRM
          ZJN    IODONE30    IF YES
          LDDL   CONFLG      CHECK IF UNIT CONNECTED
          ZJN    IODONE20    IF NOT

 IODONE10 LDN    0           CLEAR THE FORCE RELEASE FLAG
          STDL   FRELF
          RJM    REL         RELEASE THE UNIT

*         CHECK IF MICROCODE RELOAD IS REQUIRED.
 IODONE20 BSS                WRITE FAILURE ENTRY POINT
          LDDL   LMCFLG      CHECK LOAD MICROCODE FLAG
          ZJN    IODONE30    IF NOT SET
          RJM    LMC         RELOAD THE MICROCODE

 IODONE30 RJM    CHKCH       CHECK IF CHANNEL REQUESTED BY MALET
          UJK    MAIN        GO TO MAIN LOOP
          SPACE  5,20
** NAME - LMC
*
** PURPOSE - LOAD AND EXECUTE LOAD MICROCODE OVERLAY IF NECESSARY.
*
** INPUT - (LMCFLG) = NZ - LOAD MICROCODE
*                     Z  - BYPASS LOADING MICROCODE
*
** OUTPUT - UNSOLICITED RESPONSE SENT IF MICROCODE LOADED OK.
*           UNSOLICITED RESPONSE SENT IF MICROCODE LOAD ERROR
*           ON THE LAST RETRY .
*
          SPACE  2
 LMC      SUBR               ENTRY/EXIT

          LDDL   LMCFLG      CHECK IF LOAD REQUIRED
          ZJN    LMCX        IF NOT  RETURN

 OFL3     IFEQ   OFFLINE,1   CHECK TESTING ENVIRONMENT
          LDN    0           BYPASS LOAD MICROCODE IN OFFLINE MODE
          STDL   LMCFLG
          UJN    LMCX        RETURN
 OFL3     ENDIF

          LDN    2           SET RETRY LOOP COUNTER
          STML   LMCRC

*         LOAD THE LOAD MICROCODE OVERLAY.
 LMC1     LOADOVL LMO        LOAD THE OVERLAY

*         MODIFY CHANNEL INSTRUCTIONS OF OVERLAY.
          LDK    CONCHL
          RJM    CHGCH       CHANGE CHANNEL INSTRUCTIONS

*         EXECUTE THE LOAD MICROCODE OVERLAY.
          RJM    LMCO        EXECUTE IT

          SHN    17-11       CHECK IF GOOD LOAD
          PJN    LMC2        IF YES
          SOML   LMCRC       DECREMENT RETRY COUNTER
          PJN    LMC1        TRY AGAIN IF NOT EXHAUSTED

 LMC2     UJN    LMCX        EXIT
          SPACE  2
 LMCRC    DATA   0           RETRY COUNTER
          SPACE  5,15
**        REFORMATTED RMA OF OVERLAY DIRECTORY.

 DH       BSSZ   3

*COPYC IODMAC6
          SPACE  5,20
** NAME-- LOCK
*
** PURPOSE-- SET A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS SET.
*         A REGISTER .NE. O, IF THE LOCK COULD NOT BE SET.
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T1 = 0, WRITE THE PP LOCKWORD TO CENTRAL MEMORY,
*            AS DESCRIBED IN THIS STEP.  ELSE IF T1 .NE. 0, GO TO
*            STEP 4.
*            TO WRITE THE PP LOCKWORD ID:
*            SET T1 - T4 = 8000 0000 0000 PPNO, WHERE PPNO IS THE
*            LOGICAL PP NUMBER OF THIS PP.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
*
*         4. IF T1 = 8000 AND T4 = PPNO, THIS LOCKWORD WAS ALREADY
*            RESERVED TO THIS PP.
*            RESTORE THE CENTRAL MEMORY LOCATION  (CWDL   T1).
*            SET THE A REGISTER = 0, AND EXIT.
*
*         5. IF T4 .NE. PPNO, THEN THIS LOCKWORD IS RESERVED TO
*            A DIFFERENT PROCESSOR.
*            SET BIT 16 OF THE LOCKWORD THAT WAS READ WITH THE
*            RDSL INSTRUCTION, AND WRITE THE CONTENTS BACK TO
*            CENTRAL MEMORY.
*            THE PURPOSE OF SETTING BIT 16 IS TO REQUEST THE
*            OTHER PROCESSOR TO GIVE UP THE LOCKWORD.
*            LDDL   T2
*            LPC    77777B
*            ADC    100000B
*            STDL   T2
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
*
          SPACE  2
 LOCK     SUBR               ENTRY/EXIT

**        WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 LOCK10   LCN    ZERO        SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDK    ZERO
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

**        CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.

          LDDL   T1
          ADDL   T4
          ZJN    LOCK40      IF LOCK CAN BE SET

**        CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJK    LOCK10      IF THIS PP WAS NOT FIRST TO WRITE THE
                              INTERMEDIATE VALUE, REPEAT RDSL INSTRUCTION

**        SET BIT 16 IN THE ORIGINAL CONTENTS OF CENTRAL MEMORY AND
*         WRITE IT BACK TO CENTRAL MEMORY.

          LDDL   T2          SET THE 'REQUEST LOCKWORD' FLAG
          LPC    77777B
          ADC    100000B
          STDL   T2
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE LOCKWORD

          LDDL   T4
          SBDL   PPNO        CHECK IF LOCK ALREADY SET
          NJN    LOCK30      IF LOCK COULD NOT BE SET, EXIT A .NE. 0
          LDDL   T1
          ADC    -100000B

 LOCK30   UJK    LOCKX       IF LOCK WAS ALREADY SET, EXIT A = 0
                             IF LOCK COULD NOT BE SET, EXIT A .NE. 0

**        SET THE LOCKWORD.

 LOCK40   LDK    100000B
          STDL   T1
          LDK    ZERO
          STDL   T2
          STDL   T3
          LDDL   PPNO
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          SET THE LOCKWORD
          LDK    ZERO
          UJK    LOCK30      EXIT, A REGISTER = 0
          SPACE  5,20
** NAME - NSC
*
** PURPOSE - PROCESS NON-SUPPORTED COMMAND ERRORS.
*
** OUTPUT - ERROR RESPONSE GENERATED.
*
          SPACE  2
 NSC      BSSZ   1           ENTRY ONLY  **NO EXIT**

          LDK    REINSC      SET RESPONSE ERROR ID
          STML   RESBUF+/RS/P.REID
          LDK    /RS/K.INTERR  SET INTERFACE ERROR
          STML   RESBUF+/RS/P.ABALRT
          UJK    FAIL
          SPACE  5,20
** NAME - OUTCPE/INCPE
*
** PURPOSE - PROCESS ALL CHANNEL ERROR FLAG ERRORS.
*
** INPUT - CHANNEL ERROR FLAG WAS DETECTED SET AND WAS THEN CLEARED.
*
** OUTPUT - IF CIO CHANNEL (CESR) = CH ERROR STATUS REGISTER AND/OR
*           (GS) AND (DSB) = EQUIPMENT STATUS IF IT CAN BE OBTAINED.
*
          SPACE  2
**        OUTPUT ERROR PROCESSING.
 OUTCPE   BSS                ENTRY

          LDK    REIIOP      SET CHANNEL PARITY ON OUTPUT
          UJN    CCEF10      CONTINUE


**        INPUT ERROR PROCESSING.
 INCPE    BSS                ENTRY

          LDK    REIICP      SET CHANNEL PARITY ON INPUT


**        COMMON CHANNEL ERROR FLAG PROCESSING.
 CCEF10   STML   RESBUF+/RS/P.REID  REPORT THE CHANNEL PARITY ERROR
          STDL   LMCFLG      SET RELOAD MICROCODE FLAG
          LDK    /RS/K.HDWR  SET HARDWARE ERROR
          STML   RESBUF+/RS/P.ABALRT
          RJM    GETHS       GET HARDWARE STATUS
          UJK    FAIL        REPORT FAILURE
          SPACE  5,20
** NAME-- PAUS
*
** PURPOSE-- DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*            MICROSECONDS.
*
** INPUT-- A REGISTER SPECIFIES NUMBER OF MICROSECONDS
*          TO BE DELAYED.
*
** OUTPUT-- A = 0.
*
          SPACE  2
 PAUS     SUBR               ENTRY/EXIT

 PAUS10   SBN    1           EACH ITERATION OF THIS SBN-NJN LOOP
          PSN
          PSN
          NJN    PAUS10      UTILIZES 1 MICROSECOND
          UJK    PAUSX
          SPACE  5,20
** NAME - RCNZ
*
** PURPOSE - PROCESS NON-ZERO RESIDUAL WORD COUNT ERRORS.
*
** INPUT - (A) = RESIDUAL WORD COUNT.
*
** OUTPUT - ERROR RESPONSE GENERATED.
*
** NOTE - THIS ROUTINE HAS TWO ENTRY POINTS,
*         *RCNZI* FOR INPUT OPERATIONS AND
*         *RCNZO* FOR OUTPUT OPERATIONS.
          SPACE  2
 RCNZI    BSS                ENTRY POINT FOR INPUT OPERATIONS

          STML   RESBUF+/RS/P.XFER+1  SAVE BAD RESIDUAL COUNT
          LDK    REIRCI      GET RESPONSE ERROR ID CODE
          UJN    RCNZ10      CONTINUE

 RCNZO    BSS                ENTRY POINT FOR OUTPUT OPERATIONS

          STML   RESBUF+/RS/P.XFER+1  SAVE BAD RESIDUAL COUNT
          LDK    REIRCO      GET RESPONSE ERROR ID CODE

 RCNZ10   STML   RESBUF+/RS/P.REID  GENERATE ERROR RESPONSE
          STDL   LMCFLG      SET RELOAD MICROCODE FLAG
          LDK    /RS/K.HDWR  SET HARDWARE ERROR
          STML   RESBUF+/RS/P.ABALRT
          UJK    FAIL        GO TO FAIL
          SPACE  5,20
** NAME - REL
*
** PURPOSE - RELEASE CONNECTED UNIT.
*
          SPACE  2
 REL      SUBR               ENTRY/EXIT

          LDK    ZERO        CLEAR CONNECTED FLAG
          STDL   CONFLG
          LDK    F.REL       RELEASE UNIT
          RJM    DOFUNC
          UJN    RELX        RETURN
          SPACE  5,20
** NAME-- RESP
*
** PURPOSE-- WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
*
** INPUT-- CM.PIT, CM.RS, LIM, /PIT/IN, /PIT/OUT, RS+/RS/P.RESPL.
*
** OUTPUT-- /PIT/IN, RESPONSE BUFFER.
*
          SPACE  2
 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  2
 RESP     SUBR               ENTRY/EXIT

          LDDL   CMDADR      GET PP ADDRESS OF LAST COMMAND
          ADC    -REQBUF     GET PP WORDS INTO REQUEST
          SHN    1           CM BYTES INTO REQUEST
          ADML   RESBUF+/RS/P.REQ+1  ADD ON HALF 2 OF REQUEST BUFFER RMA
          STML   RESBUF+/RS/P.LASTC+1  RMA HALF 2 OF LAST COMMAND
          SHN    -16         GET CARRY IF ANY
          ADML   RESBUF+/RS/P.REQ  ADD ON HALF 1 OF REQUEST BUFFER RMA
          STML   RESBUF+/RS/P.LASTC  RMA OF HALF 1 OF LAST COMMAND

**        READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RESP10   LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF 'IN' POINTER
          CRDL   P1          READ 'IN' POINTER

**        CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDDL   INP
          SBDL   OUTP
          MJN    RESP20      IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP

 RESP20   LDML   RESBUF+/RS/P.RESPL  GET RESPONSE LENGTH
          STDL   T1
          LDK    ZERO
          STDL   T2          FLAG TO DETERMINE IF 1 OR 2 BLOCK WRITES
          LDDL   INP
          RADL   T1          IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          PJK    RESP10      IN NOT ENOUGH ROOM IN BUFFER, LOOP
          LDDL   T1
          SBDL   LIM
          MJN    RESP30      IF IN + RESPONSE LENGTH .LT. LIMIT
          STDL   T1          IN + RESPONSE LENGTH - LIMIT = NEW 'IN' POINTER
          AODL   T2          2 BLOCK WRITES REQUIRED

**        WRITE RESPONSE TO CM.

 RESP30   LDDL   INP
          SHN    -3
          STDL   T3          'IN' POINTER IN WORDS
          LDML   RESBUF+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          STDL   T5
          LDDL   T2
          ZJN    RESP40      IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADC    RESBUF
          STML   RESPA       RESPONSE ADDRESS FOR 2ND BLOCK WRITE

 RESP40   LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD 'IN' OFFSET
          CWML   RESBUF,T4   WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          SBDL   T4
          ZJN    RESP50      IF ONLY 1 BLOCK WRITE REQUIRED
          STDL   T5          RESPONSE LENGTH - (LIMIT - IN)
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          LMC    400000B
          CWML   *,T5        WRITE 2ND PART OF RESPONSE TO CM
 RESPA    EQU    *-1         (BEGINNING OF RESPONSE BUFFER)

 RESP50   LDDL   T1          NEW IN POINTER
          STDL   P4

**        SET UP INTERRUPT PROCESSOR INSTRUCTION IF INTERRUPT IS SELECTED.

          LDML   RESBUF+/RS/P.INT  CHECK IF INTERRUPT WAS SELECTED
          LPK    /RS/K.INT
          NJN    RESP60      IF INTERRUPT SELECTED
          LDK    PSNI        PSN INSTRUCTION
          UJN    RESP70


 RESP60   LDML   RESBUF+/RS/P.PORT  GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RS/L.PORT+/RS/N.PORT
          LPN    /RS/M.PORT
          ADC    INPNI       INPN INSTRUCTION

 RESP70   STML   INTPRC

**        WRITE UPDATED 'IN' POINTER FOR CM RESPONSE BUFFER TO PIT.

          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   P1          WRITE NEW 'IN' POINTER TO CM

**        INTERRUPT PROCESSOR.

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   PPNO-3      SET LAST BYTE NON-ZERO

 INTPRC   INPN   1           INTERRUPT OR PSN
          LJM    RESPX       EXIT
          SPACE  5,20
** NAME - RESPSU
*
** PURPOSE - SET UP RESPONSE BUFFER.
*
** INPUT - REQUEST PVA/RMA AND ENTIRE REQUEST READ INTO PP MEMORY.
*
** OUTPUT - NECESSARY INFORMATION PLACED IN RESPONSE BUFFER. THE REMAINDER
*           OF THE BUFFER IS ZEROED OUT.
*
          SPACE  2
 RESPSU   SUBR               ENTRY/EXIT

**        ZERO OUT RESPONSE BUFFER STARTING AT ABNORMAL STATUS FIELD
*         IN CM WORD 4 TO DETAILED STATUS IN CM WORD 8.

          LDK    /RS/C.DSB-/RS/C.ABALRT  NUMBER OF CM WORDS TO CLEAR
          STDL   T5
          LOADC  CM.COM      LOAD R AND A OF PP COMMUNICATION BUFFER
          ADN    /CB/C.ZEROES  READ FROM ZERO BLOCK
          CRML   RESBUF+/RS/P.ABALRT,T5  ZERO PART OF RESPONSE BUFFER

**        MOVE LOGICAL UNIT, RECOVERY, INTERRUPT, PORT, PRIORITY
*         AND ALERT MASK FROM REQUEST TO RESPONSE BUFFER.

          LDML   REQBUF+/RQ/P.LU
          STML   RESBUF+/RS/P.LU
          LDML   REQBUF+/RQ/P.RECOV
          STML   RESBUF+/RS/P.RECOV
          LDML   REQBUF+/RQ/P.ALRTM
          STML   RESBUF+/RS/P.ALRTM
          LDK    NORMRES     SET LENGTH IN RESPONSE BUFFER
          STML   RESBUF+/RS/P.RESPL

**        MOVE CURRENT REQUEST PVA/RMA TO RESPONSE BUFFER.

          LOADC  CM.COM      LOAD R AND A OF PP COMMUNICATION BUFFER
          ADN    /CB/C.SCRAT  USE SCRATCH AREA
          CWML   UCAHDR+/UCA/P.CPVA-1,TW
          SBN    2
          CRML   RESBUF,TW
          LJM    RESPSUX     RETURN


**        ENSURE THAT NUMBER OF ZERO BYTES IN PP COMMUNICATION BUFFER
*         IS ENOUGH TO ZERO THE NECESSARY PORTION OF THE RESP. BUFFER.

          ERRNG  /CB/B.ZEROES+/RS/C.ABALRT*8-/RS/C.ELB*8
          SPACE  5,20
** NAME - RURBH
*
** PURPOSE - READ URB HEADER AND OLDEST REQUEST PVA BACK INTO PP.
*
** INPUT - (CM.UCA) = CURRENT UNITS UCA.
*
          SPACE  2
 RURBH    SUBR               ENTRY/EXIT

          LDN    3           SET CM WORD COUNT
          STDL   WC
          LOADC  CM.UCA      LOAD R AND A FOR CURRENT UNITS UCA
          ADML   UCAHDR+/UCA/P.INP  OFFSET BY UCA IN POINTER
          CRML   URBHDR,WC   READ THE URB HEADER AND REQUEST PVA
          LDML   URBHDR+/URB/P.UCMDA  RESTORE CMDADR
          STDL   CMDADR
          UJN    RURBHX      RETURN
          SPACE  5,20
** NAME - RURBR
*
** PURPOSE - READ URB RESPONSE BACK INTO PP.
*
** INPUT - (CM.UCA) = CURRENT UNITS UCA.
*
          SPACE  2
 RURBR    SUBR               ENTRY/EXIT

          LDN    NRESW       SET NORMAL RESPONSE CM WORD COUNT
          STDL   WC
          LOADC  CM.UCA      LOAD A AND R WITH CM UCA ADDRESS
          ADML   UCAHDR+/UCA/P.INP  INCREMENT WITH IN POINTER
          ADN    /URB/C.RESP  OFFSET TO RESPONSE FIELD
          CRML   RESBUF,WC   READ RESPONSE BACK INTO PP
          STML   RURBRA      SAVE CM ADDRESS
          LDML   RESBUF+/RS/P.RESPL  CHECK RESPONSE LENGTH
          SBN    NORMRES
          ZJN    RURBRX      RETURN IF NORMAL RESPONSE LENGTH
          LDN    /RS/C.ELB-/RS/C.DSB  REMAINING CM WORD COUNT OF RESPONSE
          STDL   WC
          LDML   RURBRA      GET CM ADDRESS
          LMC    400000B
          CRML   RESBUF+/RS/P.DSB,WC  READ DETAILED STATUS BACK IN TO PP
          UJK    RURBRX      RETURN
          SPACE  2
 RURBRA   DATA   0           SAVE CM ADDRESS
          SPACE  5,20
** NAME - SAVAD
*
** PURPOSE - SAVE RMA THAT IS BEING FORMATTED BY REFAD AND
*            STORE IT IN LOCATIONS GREATER THAN 77.
*
** INPUT - (A) = CM A REGISTER ADDRESS
*          (CMADR) = FORMATTED CM R REGISTER ADDRESS
*          (T2) = DESTINATION PP ADDRESS
*
** OUTPUT - ((T2)) = 3 PP WORD FORMATTED CM ADDRESS
*
          SPACE  2
 SAVAD    SUBR               ENTRY/EXIT
          STML   2,T2
          LDDL   CMADR
          STI    T2
          LDDL   CMADR+1
          STML   1,T2
          UJK    SAVADX      RETURN
          SPACE  5,20
** NAME - SCLK
*
** PURPOSE - SET/CLEAR SPECIFIED LOCKWORD.
*
** INPUT - (A) = 0000XX IF SET LOCK.
*          (A) = 00004X IF CLEAR LOCK.
*          XX = INDEX INTO TABLE *SCLKA* OF LOCK TO SET/CLEAR.
*
** EXIT - (A) = 0 IF LOCK SUCCESSFULLY SET/CLEARED.
*         (A) .NE. 0 IF LOCK NOT SET/CLEARED.
*
** USES - T1, T2, T5, T7.
*
          SPACE  2
 SCLK10   RJM    CLOCK       CLEAR INTERLOCK

 SCLK     SUBR               ENTRY/EXIT

          STDL   T2          SAVE ENTRY
          LPN    37B         MASK OFF SET/CLEAR FLAG
          STDL   T1
          LDML   SCLKA,T1    SET POINTER TO CM ADDRESS OF LOCKWORD
          STDL   T7
          LDML   SCLKA+1,T1  SET INDEX INTO TABLE
          STDL   T5
          LDDL   T2
          SHN    -5
          NJN    SCLK10      IF CLEAR LOCK
          RJM    LOCK        SET LOCK
          UJK    SCLKX       EXIT
          SPACE  3
 SCLKA    BSS    0
          LOC    0
 PPLK     CON    CM.PIT,/PIT/C.LOCK   QUEUE LOCK IN PP INTERFACE TABLE
 QULK     CON    CM.UIT,/UIT/C.QLOCK  QUEUE LOCK IN UNIT INTERFACE TABLE
 CHLK     CON    CM.CHAN,0            CHANNEL LOCK
          LOC    *O

 CURCH    EQU    SCLKA+CHLK+1  LOCATION ALWAYS CONTAINS CURRENT CHANNEL NUMBER
          SPACE  5,20
** NAME - SENCOM
*
** PURPOSE - SEND A COMMAND TO THE SLAVE PP.
*
** INPUT - ADDR OF COMMAND IN A REGISTER.
*
** OUTPUT - COMMAND SENT.
*
          SPACE  2
 SENCOM   SUBR               ENTRY/EXIT

          STML   SENCOMA     INSTRUCTION MODIFICATION
          LOADC  CM.COM      LOAD R AND A OF PP COMMUNICATION BUFFER
          ADN    /CB/C.COMM
          CWML   *,ON        SEND THE COMMAND
 SENCOMA  EQU    *-1

          UJN    SENCOMX     EXIT
          SPACE  4
 HNDSHK   VFD    8/HSHAKC,8/0  HANDSHAKE COMMAND
          BSSZ   3           DO NOT SEPARATE THIS FROM HNDSHK

 NCHANC   VFD    8/NCCOMD,8/0  CHANGE CHANNEL COMMAND
          BSSZ   3           DO NOT SEPARATE THIS FROM NCHANC
          SPACE  5,20
** NAME - SLVERR
*
** PURPOSE - PROCESS A SLAVE DETECTED ERROR.
*
** INPUT - (A) = SLAVE ERROR CODE.
*
          SPACE  2
 SLVERR   BSS                ENTRY

          SBN    REIFE       CHECK IF SLAVE FLAG ERROR
          ZJK    FLAGERR     IF YES  PROCEES IT
          RJM    NSC         ELSE PROCESS NON-SUPPORTED CMD  (NO RETURN)
          SPACE  5,20
** NAME - UINP
*
** PURPOSE - TO UPDATE UCA IN POINTER IN CM.
*
** INPUT - (/UCA/P.ACTCNT) = CURRENT ACTVIVE COUNT OF WRITE REQUESTS.
*
** OUTPUT - (/UCA/P.ACTCNT) = DECREMENTED BY 1 AND
*           (/UCA/P.INP) = UPDATED IN POINTER IN CM.
*
          SPACE  2
 UINP     SUBR               ENTRY/EXIT

          SOML   UCAHDR+/UCA/P.ACTCNT  DECREMENT ACTIVE COUNT
          LDN    C.URB       UPDATE IN POINTER
          RAML   UCAHDR+/UCA/P.INP
          SBN    /UCA/C.ERRSTA  CHECK FOR WRAP AROUND
          MJN    UINP10      IF NOT
          LDK    /UCA/C.URB1  RESET TO FIRST ENTRY
          STML   UCAHDR+/UCA/P.INP

 UINP10   LOADC  CM.UCA      UPDATE UCA HEADER WORD 2 IN CM
          ADN    /UCA/C.ACTCNT  OFFSET TO CM WORD 2
          CWML   UCAHDR+/UCA/P.ACTCNT,ON  UPDATE IT
          UJN    UINPX       RETURN
          SPACE  5,20
** NAME - UNLD
*
** PURPOSE - TO LOAD AND EXECUTE UNLD OVERLAY.
*
          SPACE  2
 UNLD     BSS                ENTRY

          LOADOVL MRO        LOAD THE OVERLAY
          LDK    CONCHMR     SET CHANNEL INSTRUCTIONS
          RJM    CHGCH
          LJM    UNLDO       EXECUTE THE OVERLAY

*         THE OVERLAY WILL EXIT DIRECTLY TO *CMDONE* IF SUCCESSFUL.
          SPACE  5,20
** NAME - WFAIL
*
** PURPOSE - TO LOAD AND EXECUTE WFAIL OVERLAY.
*
          SPACE  2
 WFAIL    SUBR               ENTRY/EXIT

          LOADOVL WFO        LOAD WRITE FAILURE OVERLAY
          RJM    WFAILO      EXECUTE OVERLAY
          RJM    REL         RELEASE THE UNIT
          UJN    WFAILX      RETURN
          SPACE  5,20
** NAME - WRDONE
*
** PURPOSE - TO PROCESS NORMAL WRITE REQUEST COMPLETION.
*
** INPUT - REQUEST ENDING BLOCK ID ALREADY SET INTO RESPONSE (LGBID).
*
** OUTPUT - UCA HEADER AND URB RECORD WRITTEN INTO CM.
*
          SPACE  2
 WRDONE   BSS                ENTRY

 OFL4     IFEQ   OFFLINE,1   CHECK FOR CMSE OFFLINE TESTING
          LDK    R.INT       SET INTERMEDIATE RESPONSE CODE
          STML   RESBUF+/RS/P.RC
          RJM    RESP        SEND INTERMEDIATE RESPONSE
 OFL4     ENDIF

          LDML   RESBUF+/RS/P.LGBID  SET REQUEST ENDING BLOCK ID
          STML   URBHDR+/URB/P.EBID
          LDML   RESBUF+/RS/P.LGBID+1
          STML   URBHDR+/URB/P.EBID+1
          RJM    WRUCA       UPDATE UCA HEADER AND WRITE URB RECORD
          RJM    CHKCH       CHECK IF MALET WANTS THE CHANNEL
          UJK    MAIN        GO TO MAIN IDLE LOOP
          SPACE  5,20
** NAME - WRITCM
*
** PURPOSE - WRITE DATA TO CM DURING A TAPE READ.
*
** DESCRIPTION - THIS SUBROUTINE WILL WRITE A -CHUNK- (SEE GETCM) OF
*                DATA JUST READ FROM TAPE TO CM. IF THE TAPE RECORD IS
*                LONGER THAN THE CM CONTAINER THEN THE EXCESS DATA IS
*                THROWN AWAY AND THE FLAG *LONG* WILL BE SET.
*
          SPACE  2
 WRITCM10 LDML   SHBYTEC     SET LONG INPUT BLOCK FLAG
          RADL   LONG
          SHN    -16
          ZJN    WRITCMX     IF NO OVERFLOW
          LDK    TWO         ENSURE COUNT IS NOT 0 OR 1
          STDL   LONG

 WRITCM   SUBR               ENTRY/EXIT

          RJM    GETBL       DETERMINE THE RMA(S) OF THE BUFFERS
          LDML   SPACE1      SPACE (IN BYTES) AT FIRST RMA
          ZJN    WRITCM10    NO MORE BUFFER SPACE - THROW DATA AWAY
          ADML   SPACE2      CHECK FOR SHORT READ
          SBML   SHBYTEC
          ZJN    WRITCM40    IF NOT SHORT READ AND ENOUGH BUFFER SPACE
          PJN    WRITCM20    IF SHORT READ
          LMC    -0          INDICATE LONG INPUT BLOCK
          STDL   LONG
          UJN    WRITCM40    FILL THE REMAINING BUFFER SPACE

 WRITCM20 LDML   SPACE2      IF SPACE2 = 0 THEN SET SPACE1 = SHBYTEC
          ZJN    WRITCM30
          LDML   SHBYTEC     ELSE SPACE2 = SHBYTEC - SPACE1
          SBML   SPACE1
          STML   SPACE2
          PJN    WRITCM40    IF SECOND RMA INVOLVED
          LDK    ZERO
          STML   SPACE2
          UJN    WRITCM40    PROCESS THE WRITE

 WRITCM30 LDML   SHBYTEC
          STML   SPACE1

 WRITCM40 LDML   SPACE1
          ADN    7           ROUND UP IN CASE THIS IS THE LAST
          SHN    -3          THIS IS THE NUMBER OF CM WORDS
          STDL   T5
          LOADF  RMA1.1      FORMAT THE A AND R REGISTERS
          CWML   DIOBUF,T5
          LDML   SPACE1      COMPUTE THE OFFSET INTO THE PP BUFFER
          SHN    -1            IN CASE THERE ARE TWO CM WRITES
          ADC    DIOBUF
          STML   WRITCMA     MODIFY THE CM WRITE INSTRUCTION
          LDML   SPACE2      WE MAY HAVE TO WRITE TO TWO BUFFERS
          NJN    WRITCM50    IF TWO BUFFERS
          LJM    WRITCMX     ONLY ONE THIS TIME

 WRITCM50 ADN    7           ROUND UP
          SHN    -3          CM WORDS
          STDL   T5
          LOADF  RMA2.1      FORMAT THE SECOND RMA
          CWML   *,T5        WRITE TO THE SECOND BUFFER
 WRITCMA  EQU    *-1

          LJM    WRITCMX     EXIT
          SPACE  5,20
** NAME - WRUCA
*
** PURPOSE - WRITE THE UCA HEADER AND URB RECORD INTO CM.
*
** INPUT - (UCAHDR+/UCA/P.ACTCNT) = PREVIOUS ACTIVE COUNT,
*          (UCAHDR+/UCA/P.OUTP) = CURRENT OUT POINTER.
*
** OUTPUT - (UCAHDR+/UCA/P.ACTCNT) = +1,
*           (UCAHDR+/UCA/P.OUTP) = NEXT OUT POINTER.
*           (UCAHDR+/UCA/P.INP) = INITIALIZED IF FIRST WRITE OPERATION.
*           (UCAHDR+/UCA/P.TPF) = INITIALIZED IF FIRST WRITE OPERATION.
*
          SPACE  2
 WRUCA    SUBR               ENTRY/EXIT

          AOML   UCAHDR+/UCA/P.ACTCNT  INCREMENT ACTIVE COUNT
          SBN    1           CHECK IF FIRST ONE
          NJN    WRUCA10     IF NOT FIRST ONE
          LDK    /UCA/C.URB1  INITIALIZE BOTH INP AND OUTP
          STML   UCAHDR+/UCA/P.INP
          STDL   T1          SAVE IT
          ADN    C.URB       INCREMENT IT FOR THE NEXT OUTP
          STML   UCAHDR+/UCA/P.OUTP
          LDML   BIDBUF+4    INITIALIZE TAPE POSITION FLAG
          STML   UCAHDR+/UCA/P.TPF
          UJN    WRUCA20     CONTINUE

 WRUCA10  LDML   UCAHDR+/UCA/P.OUTP  GET CURRENT OUT POINTER
          STDL   T1          SAVE IT
          ADN    C.URB       INCREMENT IT TO NEXT
          STML   UCAHDR+/UCA/P.OUTP
          SBN    /UCA/C.ERRSTA  CHECK FOR WRAP AROUND
          MJN    WRUCA20     IF NOT
          LDK    /UCA/C.URB1  RESET TO FIRST URB
          STML   UCAHDR+/UCA/P.OUTP

*         WRITE UPDATED UCA HEADER MINUS THE CPU SYNC WORD.
 WRUCA20  LDN    /UCA/C.CRMA-/UCA/C.ACTCNT  CM WORD COUNT
          STDL   WC
          LOADC  CM.UCA      LOAD R AND A OF UNIT COMMUNICATION AREA
          ADN    /UCA/C.ACTCNT  OFFSET PAST CPU SYNC WORD
          CWML   UCAHDR+/UCA/P.ACTCNT,WC  UPDATE THE UCA HEADER

*         WRITE THE URB RECORD WITH CURRENT OUTP OFFSET.
          LDDL   CMDADR      SAVE THE CURRENT COMMAND ADDRESS
          STML   URBHDR+/URB/P.UCMDA
          LDML   RESBUF+/RS/P.RESPL  CALCULATE URB RECORD LENGTH
          SHN    -3          START WITH CM RESPONSE LENGTH
          ADN    /URB/C.RESP-/URB/C.CONF  INCREMENT BY URB HEADER
          STDL   WC          SAVE IT
          LDDL   CM.UCA+2    LOAD CM A ADDRESS
          ADDL   T1          OFFSET WITH CURRENT OUTP
          LMC    400000B
          CWML   URBHDR,WC   WRITE URB RECORD
          UJK    WRUCAX      RETURN
          SPACE  5,20
** NAME - WSC
*
** PURPOSE - WAIT FOR THE SLAVE TO COMPLETE.
*
** OUTPUT - SLAVE RESPONSE IN T1-T4.
*
** NOTE - ON READ  T1 = 00XX  XX=ERROR CODE IF ANY,
*                  T2 = XXXX  SLAVE LONG BLOCK FLAG,
*                  T3-T4 = TRANSFER COUNT.
*
*         ON WRITE T1 = 00XX  XX=ERROR CODE IF ANY,
*                  T2-T3 = NOT USED,
*                  T4 = XXXX RESIDUAL COUNT IF ANY.
*
*         OTHER    T1 = 00XX  XX=ERROR CODE IF ANY,
*                  T2-T4 = NOT USED.
*
          SPACE  2
 WSC      SUBR               ENTRY/EXIT

 WSC10    LOADC  CM.COM      LOAD R AND A FOR PP COMMUNICATION BUFFER
          ADN    /CB/C.COMM
          CRDL   T1
          LDDL   T1          SLAVE WILL CLEAR WHEN DONE
          SHN    -8          POSITION COMMAND BITS
          ZJN    WSCX        COMPLETE
          PAUSE  5           DELAY 5 MICROSECONDS
          UJN    WSC10       TRY AGAIN
          SPACE  5,20
** NAME - INIT
*
** PURPOSE - LOAD AND EXECUTE THE INITIALIZE DRIVER OVERLAY.
*
          SPACE 2
 INIT     BSS                ENTRY

*         CLEAR PP DIRECT CELLS.
          LDK    ENDDIR      CLEAR PP DIRECT CELLS T2 THRU ENDDIR
          STDL   T1

 INIT10   LDK    ZERO        CLEAR CELL
          STIL   T1
          SODL   T1          CHECK FOR DONE
          PJN    INIT10      IF NOT DONE LOOP

*         CLEAR PP MEMORY FROM ENDCODE TO ENDMEM.
          LDK    ENDMEM-ENDCODE
          STDL   T1          SET INDEX

 INIT20   LDN    0
          STML   ENDCODE,T1  CLEAR MEMORY WORD
          SODL   T1          CHECK FOR DONE
          PJN    INIT20      IF NOT  LOOP

*         GET AND REFORMAT OVERLAY DIRECTORY POINTER RMA.
          LDDL   DSRTP       VALIDATE PIT RMA
          ADDL   DSRTP+1
          ZJN    *           IF IN ERROR
          REFAD  DSRTP,CM.PIT  REFORMAT ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.CBUF  OFFSET TO PP COMMUNICATIONS BUFFER RMA
          CRDL   P1          READ THE COMM BUF RMA
          LDDL   P3          VALIDATE PP COMMUNICATION BUFFER RMA
          ADDL   P4
          ZJN    *           IF IN ERROR
          LOADF  P3          REFORMAT ADDRESS OF PP COMM BUFFER
          ADN    /CB/C.ODP   OFFSET TO OVERLAY DIRECTORY RMA
          CRDL   P1          READ THE OVL RMA
          LDDL   P3          VALIDATE OVERLAY DIRECTORY RMA
          ADDL   P4
          ZJN    *           IF IN ERROR
          REFAD  P3,DH       REFORMAT THE OVL RMA

*         LOAD INITIALIZE DRIVER OVERLAY.
          LOADOVL IDO        LOAD THE OVERLAY

*         GO EXECUTE THE INITIALIZE DRIVER OVERLAY.
          RJM    INITO       GO EXECUTE IT

*         OVERLAY WILL RETURN HERE IF IT IS THE MASTER PP.
          RJM    LMC         LOAD CCC MICROCODE IF NECESSARY
          LJM    MAIN        EXIT TO MASTER MAIN IDLE LOOP
          SPACE  4
*         CHANNEL INSTRUCTION MODIFICATION TABLE FOR COMMON CODE.
 CONCHC   BSS    0           START OF TABLE
 TTP+40B  HERE
 T40B+TP  HERE
 TTP      HERE
          CON    0           END OF TABLE
          TITLE  WORKING MEMORY, TABLES AND BUFFERS.

 ENDCODE  EQU    *           END OF PERMANENT PP CODE AREA
          SPACE  2
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*                                                                     *
** NOTE --                                                            *
*                                                                     *
*    MASTER PP - FROM ENDCODE TO ENDMEM ARE CLEARED ON DEADSTARTS     *
*                AND RESUMES, THEN ALL TABLES ARE LOADED.             *
*                                                                     *
*     SLAVE PP - FROM ENDCODE TO ENDMEM ARE CLEARED ON DEADSTARTS     *
*                ONLY. THE SLAVE PP DOES NOT PROCESS RESUMES.         *
*                                                                     *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
          SPACE  2
 UNITC    BSSZ   1           ACTIVE UNIT DESCRIPTOR COUNT

 UNITD    BSSZ   P.PUD*16    PP UNIT DESCRIPTORS FOR 16 ACTIVE UNITS

**        THE FOLLOWING 6 LOCATIONS ARE USED TO PASS RMA(S) AND LENGTH
*         FOR TAPE READS. DO NOT CHANGE THIER POSITIONS.

 SPACE1   BSSZ   1           SPACE IN BYTES AT RMA1
 RMA1.1   BSSZ   1           FIRST HALF OF FIRST RMA
 RMA1.2   BSSZ   1           SECOND HALF OF FIRST RMA
 SPACE2   BSSZ   1           SPACE IN BYTES OF SECOND RMA
 RMA2.1   BSSZ   1           FIRST HALF OF SECOND RMA
 RMA2.2   BSSZ   1           SECOND HALF OF SECOND RMA

 NUMBUF   BSSZ   1           NUMBER OF BUFFERS IN INDIRECT LIST
 BUFLSTPT BSSZ   2           POINTER TO THE INDIRECT LIST OF BUFFERS

 NADAMAS  BSSZ   1           NO MORE CM BUFFER SPACE (TAPE READ)
 EODATA   BSSZ   1           END OF DATA FLAG (USED FOR WRITE)
 ENTHERE  BSSZ   1           FUNCTION ENDS IN PARTNER PP FLAG
 SHBYTEC  BSSZ   1           BYTE COUNT ON A SHORT READ

 INDLST   BSSZ   MAXIND*4    INDIRECT ADDRESS/LENGTH BUFFER
 SPACE    EQU    INDLST+5    USED BY GETBL AND GETCM
 CBUFRMA  EQU    INDLST+6    USED BY GETBL AND GETCM
 NXSPACE  EQU    INDLST+9    SPACE IN THE NEXT BUFFER
 NBUFRMA  EQU    INDLST+10   ADDRESS (RMA) OF NEXT CM BUFFER
          SPACE  3
 SCRBUF   BSSZ   P.PIT       SCRATCH BUFFER
          SPACE  3,5
 REQBUF   BSSZ   MAXREQ*4    SET REQUEST BUFFER LENGTH
 CMDBUF   EQU    REQBUF+/RQ/P.CMND  COMMAND BUFFER
          SPACE  2,5
**        URBHDR AND RESBUF MUST NOT BE SEPERATED.
 URBHDR   BSSZ   8           URB HEADER, FIRST TWO CM WORDS

 RESBUF   BSSZ   P.RS        RESPONSE BUFFER LENGTH (MAXIMUM)
          SPACE  2,5
 BIDBUF   BSSZ   6           BLOCK ID BUFFER
          SPACE  2
**        CHECK IF DRIVER OVERFLOWS INTO OVERLAY BUFFER.

 OVLADD   EQU    6360B       FOR DRIVER EXPANSION

          ERRPL  *-OVLADD    IF DRIVER OVERFLOWS

          BSSZ   OVLADD-*    CLEAR THE DRIVER EXPANSION AREA
          SPACE  2
**        THE FOLLOWING IS THE BUFFER USED TO SUPPORT OVERLAYS.

 OVLBUF   EQU    *           OVERLAY BUFFER
          SPACE  2
**        THE FOLLOWING ARE DATA BUFFERS THAT CAN BE OVERLAPPED.

 DIOBUF   EQU    ENDMEM-DUALBUFL  PP I/O DATA BUFFER TO ENDMEM

 CNTLBUF  EQU    ENDMEM-CNTLBL  PP CONTROLWARE BUFFER TO ENDMEM
          OVERLAY (INITIALIZE DRIVER),OVLBUF
          ROUTINE IDO        INITIALIZE DRIVER OVERLAY
          SPACE  4
** NAME-- INITO
*
** PURPOSE-- INITIALIZE DRIVER OVERLAY.
*            *MASTER,SLAVE* INITIALIZE THE DRIVER AFTER DEADSTART.
*            *MASTER* REINITIALIZE THE DRIVER ON RESUME COMMAND.
*
** INPUT-- (CM.PIT) = REFORMATED ADDRESS OF THE PP INTERFACE TABLE (PIT).
*
*          (IDLFLG)= 0 FOR DEADSTART INITIALIZATION.
*                    2 FOR RESUME REINITIALIZATION.
*
** OUTPUT-- IF MASTER PP, RETURN TO CALLER.
*           IF SLAVE PP, EXIT DIRECTLY TO *SMAIN*.
*
          SPACE  2
 INITO    SUBR               OVERLAY ENTRY/EXIT

**        READ PP INTERFACE TABLE.  NOTE - THIS IS
*         THE ONLY PLACE THE STATIC FIELDS OF THE PIT
*         TABLES ARE READ INTO THE PP.

          LDK    C.PIT       LENGTH OF PIT
          STDL   WC
          LOADC  CM.PIT      LOAD CM ADDRESS OF PIT
          CRML   SCRBUF,WC   READ PIT INTO SCRATCH BUFFER

          LDML   SCRBUF+/PIT/P.PPNO  SAVE PP NUMBER
          STDL   PPNO

**        READ UNIT DESCRIPTOR TABLES.  NOTE - THIS IS
*         THE ONLY PLACE THE STATIC FIELDS OF THE UNIT DESCRIPTOR
*         TABLES ARE READ INTO THE PP.  IF THE UNIT DESCRIPTOR TABLES EVER
*         CONTAIN DYNAMIC FIELDS, THEY MUST BE READ IN WHEN LOOKING FOR UNIT
*         REQUESTS.  ONLY UNIT DESCRIPTORS THAT ARE NOT NULL ENTRIES ARE
*         SAVED IN THE PP COPY.

          LDK    UNITD       INITIALIZE CRML INSTRUCTION
          STML   INITA
          LDML   SCRBUF+/PIT/P.UNITC  GET NUMBER OF UNIT DESCRIPTORS
          STML   UNITC       SAVE IT
          STDL   T1
          ZJK    INIT60      IF NO UNITS DEFINED
          LDK    ZERO        INITIALIZE LOOP CONTROL
          STDL   T2          NUMBER OF NON-NULL UNIT DESCRIPTORS
          STDL   T3          PP WORD OFFSET INTO UNIT DESCRIPTORS
          STDL   T4          CM WORD OFFSET INTO UNIT DESCRIPTORS

 INIT30   LOADC  CM.PIT      LOAD R REGISTER FOR PIT
          ADN    C.PIT+1     ADVANCE TO START OF UNIT DESCRIPTORS +1
          ADDL   T4          CM WORD OFFSET OF CURRENT UD
          CRML   UNITD,ON    READ SECOND CM WORD OF UD ENTRY INTO PP
 INITA    EQU    *-1
          LDML   UNITD+/PUD/P.UQT,T3
          ADML   UNITD+/PUD/P.UQT+1,T3
          ZJN    INIT40      IF DUMMY ENTRY, DO NOT COUNT
          AODL   T2          INCREMENT COUNT OF ACTIVE UNITS
          SBN    16
          ZJN    INIT50      IF REACHED MAX TABLE SPACE FOR UDS
          LDK    P.PUD       INCREMENT TO NEXT PUD
          RADL   T3
          LDK    P.PUD
          RAML   INITA

 INIT40   LDK    C.UD        INCREMENT TO NEXT CM UD
          RADL   T4
          SODL   T1          DECREMENT TOTAL UNITS IN PIT
          NJN    INIT30      IF NOT DONE SCANNING UD TABLES

 INIT50   LDDL   T2          RESET NUMBER OF ACTIVE UNITS
          STML   UNITC

**        REFORMAT ADDRESS OF RESPONSE BUFFER.
*         INITIALIZE LIM.

 INIT60   REFAD  SCRBUF+/PIT/P.RSBUF,CM.RS  REFORMAT ADDRESS OF RESP BUFFER
          LDML   SCRBUF+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STDL   LIM

**        REFORMAT ADDRESS OF THE INTERRUPT WORD.

          REFAD  SCRBUF+/PIT/P.INT,CM.INT

**        REFORMAT ADDRESS OF CHANNEL TABLE.

          REFAD  SCRBUF+/PIT/P.CHAN,CM.CHAN

**        REFORMAT ADDRESS OF PP COMMUNICATION BUFFER.

          REFAD  SCRBUF+/PIT/P.CBUF,CM.COM

**        CHECK FOR DUAL PP.

          CRDL   T1          READ FIRST WORD OF COMM. BUFFER
          LDDL   T3          CHECK IF RMA FIELD NON-ZERO
          ADDL   T4
          ZJK    INIT200     IF NO RMA, THIS IS SINGLE PP ERROR
          LDDL   T2          CHECK IF SLAVE BIT IS SET
          LPK    /CB/K.SLAVE
          ZJK    INIT80      IF THIS PP IS THE MASTER PP

**        INITIALIZE DRIVER FOR SLAVE.

          LDK    0#4453      ID = DS (DUAL SLAVE)
          STDL   ID
          LDK    C.PIT       LENGTH OF PP INTERFACE TABLE
          STDL   WC
          REFAD  T3,CM.PIT   SET UP CM.PIT - CM.PIT+2
          CRML   SCRBUF,WC   READ MASTER PIT
          REFAD  SCRBUF+/PIT/P.CBUF,CM.COM  USE MASTER PP COMM. BUFFER

**        CLEAR SLAVE CODE OVERLAY AREA.

          LDK    ESCOBUF+4-BSCOBUF
          STDL   T1          SET INDEX

 INIT70   LDK    ZERO        CLEAR OVERLAY WORD
          STML   BSCOBUF,T1
          SODL   T1          CHECK FOR DONE
          PJN    INIT70      IF NOT LOOP

**        LOAD AND EXECUTE SLAVE CODE.

          LOADOVL SCO        LOAD SLAVE OVERLAY
          UJK    SMAIN       EXECUTE SLAVE MAIN LOOP

**        INITIALIZE DRIVER FOR MASTER PP.

 INIT80   STDL   IDLFLG      CLEAR THE IDLE FLAG
          LDK    0#444D      ID = DM (DUAL MASTER)
          STDL   ID
          LDK    HNDSHK      WAIT FOR SLAVE PP READY
          RJM    SENCOM      SEND HANDSHAKE COMMAND
          RJM    WSC         WAIT FOR SLAVE TO COMPLETE

**        INITIALIZE CHANNEL INSTRUCTIONS.

          LDML   UNITC
          ZJK    INIT130     IF NO ACTIVE UNITS DEFINED
          LDML   UNITD+/PUD/P.CHAN  OBTAIN PRESENT CHANNEL NUMBER
          SHN    -8
          STML   CURCH
          STML   NCHANC+3    SET SLAVE CHANNEL NUMBER
          LDK    NCHANC
          RJM    SENCOM      SEND SLAVE CHANNEL COMMAND
          LDK    CONCHM      MODIFY MASTER PP  CHANNEL INSTRUCTIONS
          RJM    CHGCH
          LDK    CONCHC      MODIFY COMMON CHANNEL INSTRUCTIONS
          RJM    CHGCH
          RJM    WSC         WAIT FOR SLAVE TO COMPLETE

**        LOCK CHANNEL IN CHANNEL INTERLOCK TABLE.

 INIT90   LDN    CHLK        SET CHANNEL LOCKWORD
          RJM    SCLK
          NJN    INIT90      IF CHANNEL LOCK NOT OBTAINED
          AODL   CHLOCK      SET CHANNEL CURRENTLY LOCKED

**        INITIALIZE CHANNEL.

          LOADC  CM.CHAN     DETERMINE CHANNEL TYPE
          ADK    32          INDEX TO CHANNEL CHARACTERISTICS OF CHANNEL TABLE
          ADML   CURCH       CURRENT CHANNEL NUMBER
          CRDL   T1
          LDDL   T1
          SHN    15          POSITION AS LEAST SIGNIFICANT BIT
          LPN    1           MASK IT
          STDL   CHTYPE      SAVE IT, 0=NIO  1=CIO
          RJM    INICH       INITIALIZE THE CHANNEL
          NJK    INIT300     IF ERROR

**        CHECK UNIT TYPE.

          LOADF  UNITD+/PUD/P.UQT  REFORMAT RMA OF FIRST UIT
          CRML   UITHDR,ON   GET FIRST WORD OF UIT
          LDML   UITHDR+/UIT/P.UTYPE  CHECK UNIT TYPE
          SBN    T5680
          NJK    INIT400     IF WRONG UNIT TYPE
          LDN    1           SET LOAD MICROCODE FLAG
          STDL   LMCFLG

**        CHECK PP COMMUNICATIONS BUFFER LENGTH.

 INIT130  LOADC  CM.PIT      LOAD R AND A FOR PIT
          ADN    /PIT/C.CBUFL  OFFSET TO COMM BUFFER LENGTH
          CRDL   T1          GET THE LENGTH
          LDDL   T2
          ADC    -B.CB       CHECK THE LENGTH
          MJK    INIT500     IF ERROR

**        CHECK UNIT COMMUNICATIONS BUFFER LENGTHS

          LDML   UNITC       GET NUMBER OF ACTIVE UNITS
          STDL   T3          SAVE IT FOR LOOP CONTROL
          LDK    UNITD+/PUD/P.UQT  GET UIT RMA ADDRESS
          STDL   T4

 INIT140  SODL   T3          DECREMENT LOOP COUNT
          MJN    INIT160     IF DONE
          LOADF  0,T4        REFORMAT UIT RMA
          CRML   UITHDR,TW   READ THE UIT HEADER  2 CM WORDS
          LDML   UITHDR+/UIT/P.UBUFL  GET THE BUFFER LENGTH
          ADC    -B.UCA      CHECK THE LENGTH
          MJK    INIT500     IF ERROR
          LDK    P.PUD       INCREMENT RMA ADDRESS POINTER
          RADL   T4
          UJN    INIT140     LOOP

**        INITIALIZE PP COMMUNICATIONS BUFFER.

 INIT160  LDK    ZERO        ZERO OUT *ZEROES* FIELD IN COMM. BUFFER
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDK    /CB/B.ZEROES  LENGTH OF ZERO AREA IN BYTES
          SHN    -3
          STDL   T5          LENGTH OF ZERO AREA IN CM WORDS

 INIT170  LOADC  CM.COM      LOAD R AND A OF COMMUNICATION BUFFER
          ADN    /CB/C.ZEROES-1
          ADDL   T5
          CWDL   T1          ZERO ONE CM WORD
          SODL   T5          DECREMENT INDEX
          NJN    INIT170     IF MORE CM WORDS TO CLEAR

**        INITIALIZE SCRBUF.
          LDK    P.PIT-1     WORD COUNT-1 TO CLEAR
          STDL   T5          SET INDEX

 INIT180  LDN    0           CLEAR SCRBUF
          STML   SCRBUF,T5
          SODL   T5          CHECK FOR DONE
          PJN    INIT180     IF NOT  LOOP
          UJK    INITOX      RETURN TO CALLER

**        PROCESS INITIALIZATION ERRORS.

*         PROCESS SINGLE PP INTERFACE ERROR
 INIT200  LDK    REISPP      SET RESPONSE ERROR ID
          UJN    INIT600     CONTINUE

*         PROCESS CHANNEL INITIALIZATION ERROR
 INIT300  STML   RESBUF+/RS/P.GS1  SAVE ERROR STATUS
          LDN    0           CLEAR GS2
          STML   RESBUF+/RS/P.GS2
          LDK    REIMLE      SET RESPONSE ERROR ID
          STML   RESBUF+/RS/P.REID
          LDK    /RS/K.HDWR  SET HARDWARE MALFUNCTION
          STML   RESBUF+/RS/P.HDWR
          UJN    INIT610     CONTINUE

*         PROCESS WRONG UNIT TYPE INTERFACE ERROR
 INIT400  LDK    REIWUT      SET RESPONSE ERROR ID
          UJN    INIT600     CONTINUE

*         PROCESS BUFFER LENGTH ERROR
 INIT500  LDK    REIBLE      SET RESPONSE ERROR ID

 INIT600  STML   RESBUF+/RS/P.REID
          LDK    /RS/K.INTERR  SET INTERFACE ERROR
          STML   RESBUF+/RS/P.ABALRT
          STDL   IDLFLG      FORCE THE PP TO IDLE STATE

 INIT610  LDK    R.UNS       SET UNSOLICITED RESPONSE CODE
          STML   RESBUF+/RS/P.RC
          LDK    NORMRES     SET RESPONSE LENGTH
          STML   RESBUF+/RS/P.RESPL
          RJM    RESP        SEND THE RESPONSE
          UJK    INIT160     CONTINUE
          SPACE  5,10
 CONCHI   BSS    0           INITIALIZATION CHANNEL INSTRUCTION TABLE
 TTP+40B  HERE
 T40B+TP  HERE
 TTP      HERE

*         CHECK IF THERE ARE ANY I/O INSTRUCTIONS.
          ERRNZ  *-CONCHI
          SPACE  2
*         CHECK IF OVERLAY EXCEEDS THE OVERLAY BUFFER.
          ERRPL  *-DIOBUF
          OVERLAY (LOAD MICROCODE),OVLBUF
          ROUTINE LMO        LOAD MICROCODE OVERLAY
** NAME - LMCO
*
** PURPOSE - LOAD MICROCODE OVERLAY.
*
** EXIT - IF MICROCODE LOADED OK THEN AN UNSOLICITED RESPONSE IS SENT.
*         IF ERROR IN LOADING MICROCODE AN UNSOLICITED RESPONSE WILL
*         ONLY BE SENT WHEN (LMCRC) = 0.
*
*         A = GS1 STATUS.
*
** NOTE - THE FOLLOWING CODES CAN BE IN GS1 OF THE RESPONSE.
*               7777B AUTOLOAD FUNCTION TIMEOUT.
*               7776B OUTPUT CHANNEL ERROR FLAG SET.
*               7775B INPUT CHANNEL ERROR FLAG SET.
*               7772B STATUS FUNCTION TIMEOUT.
*               7771B INCOMPLETE TRANSFER DURING AUTOLOAD.
*               5XXXB AUTOLOAD ERROR CODE.
*               1XXXB NORMAL AUTOLOAD STATUS.
*
          SPACE  2
 LMCO     SUBR               OVERLAY ENTRY/EXIT

**        READ UP CONTROLWARE LOAD COMMAND
*         (LENGTH AND RMA OF CONTROLWARE ADDRESS/LENGTH PAIRS).

 LMC10    LOADC  CM.COM      LOAD R AND A OF PP COMMUNICATION BUFFER
          ADN    /CB/C.CONTRL  ADD CONTROLWARE POINTER OFFSET
          CRML   CNTCMDW,ON  NOW HAVE LENGTH AND PTR TO ADDRESS/PAIR LIST
          LDML   CNTCMDW
          SHN    -10
          LMN    3
          NJN    LMC10       IF CONTROLWARE LIST NOT READY YET
          STDL   CONFLG      CLEAR THE CONNECT FLAG
          DCN    40B+TP      DEACTIVATE CHANNEL
          SFM    *+2,TP      CLEAR CHANNEL ERROR FLAG

**        SEND AUTOLOAD FUNCTION AND ACTIVATE CHANNEL.

          LDK    F.MC        AUTOLOAD FUNCTION
          STML   RESBUF+/RS/P.LSTF  SAVE AS LAST FUNCTION
          STML   RESBUF+/RS/P.LSTNSF  SAVE AS LAST NON STATUS FUNCTION
          FAN    TP          SEND FUNCTION
          LCN    ZERO
          SFM    LMC150,TP   CHECK AND CLEAR CHANNEL ERROR FLAG

 LMC20    IJM    LMC30,TP    WAIT FOR INACTIVE RESPONSE
          SBN    1           DECREMENT COUNTER
          NJN    LMC20       IF TIMEOUT NOT EXPIRED
          DCN    TP+40B      DISCONNECT CHANNEL
          LDK    7777B       SET CCC AUTOLOAD TIMEOUT CODE
          LJM    LMC200      REPORT STATUS IN UNSOLICITED RESPONSE

 LMC30    ACN    TP

**        DOWNLOAD THE MICROCODE.

          LOADF  CNTCMDW+/CM/P.RMA  REFORMAT ADDRESS TO CURRENT PAIR
          CRML   CURPAIR,ON
          LOADF  CURPAIR+/CM/P.RMA
          LDML   CURPAIR+/CM/P.LEN
          ADN    7
          SHN    -3
          STML   WCT         ASSURE CM WORD BOUNDARY
          ZJK    LMC110      **MAYBE ISSUE ERROR

 LMC40    LDML   WCT
          SBN    60          PRESENTLY USE 60 CM BUFFER (240 PP WORDS)
          MJN    LMC60       IF WCT LESS THAN 60 CM BUFFER
          LDK    60
          STDL   WC
          LDML   WCT
          SBDL   WC
          STML   WCT         SET REMAINING WORD COUNT
          LDDL   CMADR+2     SET THE A REGISTER FOR CM ADDRESS OF DATA
          LMC    400000B
          CRML   CNTLBUF,WC
          STDL   CMADR+2     UPDATE ADDRESS TO NEXT DATA
          LDDL   WC

 LMC50    SHN    3
          STDL   BYTCNT      SET BYTE COUNT FOR THIS TRANSFER
          RJM    CBYTE       SET CHANNEL BYTES FOR BYTES IN BUFFER
          LDDL   IOCNT       SET NUMBER OF CHANNEL WORD TO OUTPUT
          OAPM   CNTLBUF,TP  OUTPUT TO CCC ADAPTER
          FJM    *,TP        WAIT TILL LAST WORD TAKEN THIS TRANSFER
          NJK    LMC180      IF NON-ZERO RESIDUAL WORD COUNT
          UJN    LMC40       IF MORE DATA THIS ADDRESS LIST

 LMC60    LDML   WCT
          STDL   WC          SET WC FOR REMAINING WC THIS ADDRESS
          STML   LASTWCT     SAVE THIS AS LAST WORD COUNT
          ZJN    LMC70       IF NO REMAINDER THIS ADDRESS BLOCK
          LDDL   CMADR+2     SET ADDRESS TO INPUT REMAINDER
          LMC    400000B
          CRML   CNTLBUF,WC

 LMC70    LDML   CNTCMDW+/CM/P.LEN  DECREMENT ADDRESS PAIR COUNT
          SBN    8
          ZJK    LMC100             IF NO MORE ADDRESS WITH DATA
          STML   CNTCMDW+/CM/P.LEN  SAVE REMAINING LENGTH
          LDK    8
          RAML   CNTCMDW+/CM/P.RMA+1  UPDATE ADDRESS TO NEXT DATA AREA
          SHN    -16
          RAML   CNTCMDW+/CM/P.RMA
          LOADF  CNTCMDW+/CM/P.RMA  READ UP NEXT CURRENT PAIR
          CRML   CURPAIR,ON
          LOADF  CURPAIR+/CM/P.RMA  SET THE R REGISTER FOR CURRENT PAIR
          LDML   CURPAIR+/CM/P.LEN
          ZJK    LMC90       IF END OF LIST (SEND REMAINDER)
          ADN    7
          SHN    -3
          STML   WCT         SAVE TOTAL CM WORD COUNT THIS ADDRESS
          LDML   LASTWCT
          SHN    2           SET NUMBER PP BYTES IN LAST TRANSFER
          ADC    CNTLBUF     ADDRESS OF START OF BUFFER
          STML   LMCB        RESET CM ADDRESS WHERE TO INPUT DATA
          LDK    60
          SBML   LASTWCT     SET TO INPUT REMAINDER OF BUFFER
          STDL   WC          SET THIS TRANSFER LENGTH
          LDDL   CMADR+2     SET THE A REGISTER FOR CM ADDRESS
          LMC    400000B
          CRML   CNTLBUF,WC  FILL REMAINDER OF BUFFER
 LMCB     EQU    *-1
          STDL   CMADR+2     UPDATE TO NEXT DATA ADDRESS
          LDML   WCT         SET REMAINING WORD COUNT THIS BUFFER
          SBDL   WC
          MJN    LMC80       IF THIS BUFFER IS NOW EMPTY
          STML   WCT
          LDK    60          OUTPUT FULL BUFFER
          UJK    LMC50       ENTER LOOP TO GET/SEND CONTROLWARE

 LMC80    LDML   LASTWCT     SET REMAINING WORD COUNT TO OUTPUT
          ADML   WCT
          STDL   WC
          UJN    LMC100      OUTPUT FINAL DATA

 LMC90    LDML   LASTWCT     MUST SEND REMAINING DATA
          STDL   WC

 LMC100   LDDL   WC          MUST OUTPUT FINAL DATA
          ZJN    LMC110      IF LAST ADDRESS CONTAINED FINAL DATA
          SHN    3           SET NUMBER OF BYTES
          STDL   BYTCNT
          RJM    CBYTE       SET CHANNEL WORDS FOR BYTE COUNT GIVEN
          LDDL   IOCNT       PICK UP NUMBER OF 12 BIT CHANNEL WORDS
          OAPM   CNTLBUF,TP
          FJM    *,TP        WAIT FINAL WORD OFF CHANNEL
          NJN    LMC180      PROCESS NON-ZERO RESIDUAL WORD COUNT

**        GET COUPLER STATUS.

 LMC110   DCN    40B+TP
          SFM    LMC150,TP   CHECK AND CLEAR CHANNEL ERROR FLAG
          LDK    F.GS        ISSUE STATUS FUNCTION
          STML   RESBUF+/RS/P.LSTF  SAVE AS LAST FUNCTION
          FAN    TP
          LCN    ZERO
          SFM    LMC150,TP   CHECK AND CLEAR CHANNEL ERROR FLAG

 LMC120   IJM    LMC130,TP   TIMEOUT WAITING FOR STATUS
          SBN    1
          NJN    LMC120      IF TIMEOUT NOT COMPLETE
          UJN    LMC170      PROCESS FUNCTION TIMEOUT

 LMC130   ACN    TP
          IAN    TP          INPUT GENERAL STATUS
          SFM    LMC160,TP   CHECK AND CLEAR CHANNEL ERROR FLAG
          UJN    LMC200      SEND RESPONSE

*         PROCESS ERRORS

 LMC150   LDK    7776B       REPORT OUTPUT CHANNEL ERROR FLAG
          UJN    LMC200      CONTINUE

 LMC160   LDK    7775B       REPORT INPUT CHANNEL ERROR FLAG
          UJN    LMC200      CONTINUE

 LMC170   LDK    7772B       REPORT STATUS FUNCTION TIMEOUT
          UJN    LMC200      CONTINUE

 LMC180   LDK    7771B       REPORT INCOMPLETE TRANSFER ERROR

*         PREPARE AND SEND THE UNSOLICITED RESPONSE.

 LMC200   STML   LMCA        SAVE STATUS
          DCN    40B+TP      DEACTIVATE CHANNEL
          CFM    *+2,TP      CLEAR CHANNEL ERROR FLAG IF SET

          LDN    NORMRES/2   CLEAR RESPONSE BUFFER
          STDL   WC          NORMAL RESPONSE BUFFER LENGTH

 LMC210   LDN    0           CLEAR RESPONSE BUFFER WORD
          STML   RESBUF,WC
          SODL   WC          CHECK IF DONE
          PJN    LMC210      IF NOT  LOOP

          LDML   LMCA        GET SAVED STATUS
          STML   RESBUF+/RS/P.GS1  PUT IT INTO THE RESPONSE
          SHN    -9          CHECK IF ERROR STATUS
          SBN    1
          ZJN    LMC220      IF GOOD STATUS
          LDML   LMCRC       CHECK IF LAST RETRY
          NJN    LMC230      IF NOT LAST ONE
          LDK    REIMLE      SET RESPONSE ERROR ID
          STML   RESBUF+/RS/P.REID
          LDK    /RS/K.HDWR  SET HARDWARE ERROR
          STML   RESBUF+/RS/P.HDWR
          RJM    GETHSC      GET HARDWARE STATUS CHANNEL
          CFM    *+2,TP      CLEAR CHANNEL ERROR FLAG

 LMC220   LDK    R.UNS       SET UNSOLICITED RESPONSE CODE
          STML   RESBUF+/RS/P.RC
          LDK    NORMRES     SET RESPONSE LENGTH
          STML   RESBUF+/RS/P.RESPL
          RJM    RESP        SEND THE RESPONSE

 LMC230   LDN    0
          STDL   LMCFLG      CLEAR LOAD MICROCODE FLAG
          STDL   CONFLG      CLEAR UNIT CONNECTED FLAG
          LDML   LMCA        GET FINAL STATUS
          UJK    LMCOX       RETURN
          SPACE  2
*         WORKING MEMORY.
 LMCA     CON    0           SAVED STATUS

 WCT      CON    0

 LASTWCT  CON    4567B

 CNTCMDW  BSSZ   4           SECOND WORD OF PP COMM. BUFFER

 CURPAIR  BSSZ   4           LENGTH/ADDRESS FOR CTS/CCC CONTROLWARE
          SPACE  5,10
 CONCHL   BSS    0           LOAD MICROCODE CHANNEL INSTRUCTION TABLE
 TTP+40B  HERE
 T40B+TP  HERE
 TTP      HERE
          CON    0           END OF TABLE
          SPACE  2
*         CHECK IF OVERLAY EXCEEDS THE OVERLAY BUFFER.
          ERRPL  *-DIOBUF
          OVERLAY (SLAVE CODE),BSCOBUF
          ROUTINE SCO        SLAVE CODE OVERLAY
          SPACE  4
*         CHECK IF SLAVE OVERLAY STARTS AT MAIN IDLE.
          ERRNZ  MAIN-*
          SPACE  4
** NAME - SMAIN
*
** PURPOSE - SLAVE PP DRIVER MAIN IDLE LOOP.
*
          SPACE  2
 SMAIN    BSS                ENTRY
          RJM    SREQ        CHECK FOR SLAVE REQUEST
          NJN    SMAIN20     REQUEST FOUND
          LDK    50

 SMAIN10  SBN    1           WAIT AWHILE
          NJN    SMAIN10
          UJN    SMAIN       GO CHECK FOR REQUEST

 SMAIN20  RJM    SIBUF       INITIALIZE THE BUFFERS
          RJM    SDORQ       DO THE SLAVE REQUEST
          RJM    SIODNE      TERMINATE REQUEST
          SCF    *+2,TP      SET THE CHANNEL FLAG WHEN DONE
          UJN    SMAIN       SLAVE MAIN LOOP
          EJECT
** NAME - SDORQ  (SLAVE ONLY)
*
** PURPOSE - PERFORM THE REQUIRED SLAVE REQUEST.
*
** INPUT - REQUEST IN REQBUF.
*
** OUTPUT - REQUEST PROCESSED.
*
          SPACE  2
 SDORQ10  RJM    SOUT        OUTPUT 8-BIT DATA

 SDORQ    SUBR               ENTRY/EXIT

          LDK    ZERO        CLEAR THE SLAVE RESPONSE WORDS
          STDL   P1
          STDL   P2
          STDL   P3
          STDL   P4
          STDL   LONG        CLEAR LONG INPUT BLOCK FLAG
          LDML   CMDBUF      GET COMMAND AND FLAGS
          SHN    -8
          SBN    PWRTCMD
          ZJN    SDORQ10     IF OUTPUT 8-BIT DATA
          SBN    LCREAD-PWRTCMD
          NJN    SDORQ20     IF NOT LOGICAL READ, NON-SUPPORTED COMMAND
          RJM    SIN         INPUT 8-BIT DATA
          UJK    SDORQX      EXIT

 SDORQ20  LDK    REINSC      SET SLAVE ERROR, NON-SUPPORTED COMMAND
          UJN    SERR10      CONTINUE
          EJECT
**  NAME - SFLGERR  (SLAVE ONLY)
*
**  PURPOSE - PROCESS SLAVE DETECTED FLAG ERRORS.
*
**  INPUT - CHANNEL FLAG DETECTED IN WRONG STATE.
*
**  OUTPUT - SLAVE ERROR RESPONSE SENT TO THE MASTER.
*
          SPACE  2
 SFLGERR  BSS                ENTRY

          LDK    REIFE       SET FLAG ERROR

 SERR10   STDL   P1          STORE ERROR CODE
          RJM    SIODNE      SEND RESPONSE
          DCN    40B+TP      DEACTIVATE CHANNEL
          SCF    *+2,TP      SET THE CHANNEL FLAG WHEN DONE
          UJK    SMAIN       GO TO SLAVE MAIN LOOP
          EJECT
**  NAME - SIBUF  (SLAVE ONLY)
*
**  PURPOSE - ESTABLISH THE VALUES THAT WILL BE USED BY THE
*             GETCM AND GETBL SUBROUTINES.
*
**  INPUT - REQUEST IN REQBUF.
*
**  OUTPUT - SPACE = THE AMOUNT OF SPACE LEFT IN THE CURRENT CM
*                    BUFFER.
*            CBUFRMA = THE RMA OF THE CURRENT BUFFER.
*            NBUFRMA = THE RMA OF THE NEXT BUFFER.
*            BUFLSTPT = THE RMA POINTER TO THE CM ADDRESS OF THE LAST
*                      LENGTH/ADDRESS PAIR CURRENTLY IN PP MEMORY.
*            NUMBUF = THE NUMBER OF LENGTH/ADDRESS PAIRS ASSOCIATED
*                     WITH THIS COMMAND.
*
          SPACE  2

 SIBUF    SUBR               ENTRY/EXIT

          LDK    ZERO        INITIALIZE SOME FLAGS
          STML   EODATA
          STML   ENTHERE
          STML   NADAMAS
          LDK    DUALBUFL*2  INITIALIZE SHORT BYTE COUNT
          STML   SHBYTEC
          LDK    CMDBUF      SET UP POINTER TO COMMAND
          STDL   T4          THIS POINTS TO A INPUT OR OUTPUT COMMAND
          LDIL   T4          GET COMMAND AND FLAGS
          LPC    INDFLG      GET THE INDIRECT FLAG (BIT 6)
          NJN    SIBUF10     READ INDIRECT LIST
          LDML   2,T4        THERE IS ONLY ONE BUFFER
          STML   CBUFRMA     POINT TO THE BUFFER
          LDML   3,T4        RMA'S ARE 2 PP WORDS LONG
          STML   CBUFRMA+1   STORE BOTH HALVES
          LDML   1,T4        GET THE LENGTH
          STML   SPACE       STORE IT AWAY FOR FUTURE USE
          LDK    ZERO        NUMBER OF BUFFERS - 1
          STML   NUMBUF      SET THE BUFFER COUNT
          UJN    SIBUF20

 SIBUF10  LDML   1,T4        NUMBER OF LENGTH - ADDRESS PAIRS
          SHN    -3          DIVIDE BY 8
          SBN    1
          STML   NUMBUF
          LOADF  2,T4        SET UP ADDRESS OF THE INDIRECT LIST

**        READ THE FIRST TWO LENGTH/ADDRESS PAIRS.
*
**        NOTE - CBUFRMA IS EQUATED TO INDLST+6.
*                SPACE IS EQUATED TO INDLST+5.

          CRML   INDLST+4,TW  READ THE FIRST TWO LENGTH/ADDRESS PAIRS
          LDML   2,T4        INITIALIZE BUFLSTPT WITH SECOND L/A PAIR
          STML   BUFLSTPT
          LDML   3,T4
          ADN    10B
          STML   BUFLSTPT+1
          SHN    -16
          RAML   BUFLSTPT

 SIBUF20  LDK    -DUALBUFL*2    WILL THE SLAVE START IN THE FIRST BUFFER
          RAML   SPACE       ADJUST SPACE (IN BYTES) LEFT THIS BUFFER
          ZJN    SIBUF40     MUST START IN NEXT BUFFER
          MJN    SIBUF40     DITTO
          LDK    DUALBUFL*2  BEGINNING OFFSET

 SIBUF30  RAML   CBUFRMA+1   ADJUST THE RMA
          SHN    -16
          RAML   CBUFRMA     TAKE CARE OF OVERFLOW
          UJK    SIBUFX      EXIT

 SIBUF40  LDML   SPACE       SLAVE STARTS IN SECOND BUFFER
          ZJN    SIBUF50     IF COULD BE ZERO - SPECIAL CASE
          LMC    177777B     COMPLEMENT THE NUMBER

 SIBUF50  STDL   T5          OFFSET INTO SECOND BUFFER
          LDML   NUMBUF      CHECK NUMBER OF RMA LIST ENTRIES
          NJN    SIBUF60     IF MORE THAN ONE RMA INDIRECT LIST ENTRY
          STML   SPACE       SET NO BUFFER SPACE FOR THIS PP
          UJK    SIBUFX      EXIT

 SIBUF60  LDML   INDLST+8    MOVE LENGTH/ADDRESS PAIR TO CURRENT
          STML   INDLST+4      L/A PAIR
          LDML   INDLST+9
          STML   INDLST+5
          LDML   INDLST+10
          STML   INDLST+6
          LDML   INDLST+11
          STML   INDLST+7
          RJM    GNEWPR      GET NEXT LENGTH/ADDRESS PAIR
          LDML   SPACE       ADJUST SPACE IN THIS BUFFER
          SBDL   T5
          PJN    SIBUF70     IF ENOUGH SPACE FOR MASTER TO FILL
          LDK    ZERO        SET NO BUFFER SPACE FOR THIS PP

 SIBUF70  STML   SPACE
          LDDL   T5          SPACE MASTER WILL USE IN SECOND BUFFER
          UJK    SIBUF30     FINISH UP
          EJECT
** NAME - SIN  (SLAVE ONLY)
*
** PURPOSE - TO PERFORM THE PHYSICAL COMMAND INPUT 8-BIT DATA/PARAMETERS.
*
** OUTPUT - COMMAND COMPLETED.
*
** NOTE - THE MASTER PP WILL CHECK THE CHANNEL ERROR FLAG.
*
          SPACE  2
 SIN      SUBR               ENTRY/EXIT

 SIN10    LDK    WDCOUNT     ALWAYS TRY TO READ A FULL BUFFER
          IJM    SIN40,TP    IF CHANNEL INACTIVE  (POSSIBLE RETRY)

 SIN20    FSJM   SIN20,TP    WAIT UNTIL FLAG IS CLEAR
          IAPM   DIOBUF,TP   INPUT DATA FROM TAPE
          SCF    SFLGERR,TP  SET THE FLAG - FIRE UP THE MASTER

          STDL   AREG        SAVE THE CONTENTS OF THE A REGISTER
          NJN    SIN30       PROCESS SHORT READ
          RJM    WRITCM      WRITE THE DATA TO CM
          LDK    DUALBUFL*2  UPDATE THE TRANSFER COUNT
          RADL   P4
          SHN    -16
          RADL   P3
          UJN    SIN10       DO IT ALL OVER AGAIN

 SIN30    LDK    WDCOUNT     COMPUTE THE ACTUAL BYTE COUNT
          SBDL   AREG        NUMBER OF 12 BIT CHANNEL WORDS MOVED
          STDL   T5          STORE THIS VALUE
          SHN    1           MULTIPLY BY 3/2 TO GET BYTE COUNT
          ADDL   T5
          SHN    -1          DONE - ROUNDED DOWN INTENTIONALLY
          STML   SHBYTEC     STORE BYTE COUNT FOR WRITCM ROUTINE
          ZJN    SIN40       IF COUNT = 0
          RADL   P4          UPDATE THE TRANSFER COUNT
          SHN    -16
          RADL   P3
          RJM    WRITCM      WRITE DATA TO CENTRAL

 SIN40    LDDL   LONG        SET LONG INPUT BLOCK INDICATOR FOR MASTER
          STDL   P2
          UJK    SINX        EXIT
          EJECT
** NAME - SIODNE  (SLAVE ONLY)
*
** PURPOSE - TO TERMINATE THE SLAVE REQUEST.
*
** OUTPUT - RESPONSE SENT TO THE MASTER PP.
*
** NOTE - ON READ  P1 = 00XX  XX=ERROR CODE IF ANY,
*                  P2 = XXXX  SLAVE LONG BLOCK FLAG,
*                  P3-P4 = TRANSFER COUNT.
*
*         ON WRITE P1 = 00XX  XX=ERROR CODE IF ANY,
*                  P2-P3 = NOT USED,
*                  P4 = XXXX RESIDUAL COUNT IF ANY.
*
*         OTHER    P1 = 00XX  XX=ERROR CODE IF ANY,
*                  P2-P4 = NOT USED.
*
          SPACE  2
 SIODNE   SUBR               ENTRY/EXIT

          LOADC  CM.COM      LOAD R AND A OF MASTER PP COMMUNICATION BUFFER
          ADN    /CB/C.COMM
          CWDL   P1          SEND SLAVE RESPONSE TO MASTER
          UJK    SIODNEX     EXIT
          EJECT
** NAME - SOUT  (SLAVE ONLY)
*
** PURPOSE - TO PERFORM THE PHYSICAL COMMAND OUTPUT 8-BIT DATA.
*
** OUTPUT - COMMAND COMPLETED.
*
** NOTE - THE MASTER PP WILL CHECK THE CHANNEL ERROR FLAG.
*
          SPACE  2
 SOUT     SUBR               ENTRY/EXIT

 SOUT10   RJM    GETCM       GET A BUFFER FULL
          LDDL   IOCNT       NUMBER OF 12 BIT CHANNEL WORDS
          IJM    SOUTX,TP    IF CHANNEL WENT INACTIVE  (POSSIBLE RETRY)

 SOUT20   FSJM   SOUT20,TP   WAIT UNTIL FLAG IS CLEAR
          OAPM   DIOBUF,TP   WRITE SOME TAPE
          SCF    SFLGERR,TP  SET THE CHANNEL FLAG TO START THE MASTER

          ZJN    SOUT30      IF NO RESIDUAL WORD COUNT LEFT
          STDL   P4          SAVE THE RESIDUAL FOR THE MASTER

 SOUT30   LDML   EODATA      END OF DATA FLAG (SET BY GETCM)
          ADML   ENTHERE     END IN PARTNER (SET IN BUMPIT)
          ZJN    SOUT10      IF NOT COMPLETE
          UJK    SOUTX       EXIT
          EJECT
** NAME - SREQ  (SLAVE ONLY)
*
** PURPOSE - CHECK FOR SLAVE REQUEST FROM MASTER PP.
*
** OUTPUT - A = 0  NO REQUEST.
*         - A .NE. 0  REQUEST IN CMDBUF.
*
          SPACE  2
 SREQ     SUBR               ENTRY/EXIT

          LOADC  CM.COM      LOAD R AND A OF MASTER PP COMMUNICATION BUFFER
          ADN    /CB/C.COMM
          CRML   CMDBUF,ON
          LDML   CMDBUF      CHECK FOR COMMAND
          SHN    -8          LOOK AT THE COMMAND
          ZJN    SREQX       IF NO COMMAND - EXIT
          ADC    -NCCOMD     CHECK FOR CHANGE CHANNEL COMMAND
          NJN    SREQ10      NOT CHANGE CHANNEL
          LDML   CMDBUF+3    SAVE NEW CHANNEL NUMBER
          STML   CURCH
          LDK    CONCHS      MODIFY SLAVE CHANNEL INSTRUCTIONS
          RJM    CHGCH
          LDK    CONCHC      MODIFY COMMON CHANNEL INSTRUCTIONS
          RJM    CHGCH
          UJN    SREQ20      COMPLETE REQUEST

 SREQ10   ADC    NCCOMD-HSHAKC  CHECK FOR THE HANDSHAKE COMMAND
          NJN    SREQX       NOT A HANDSHAKE - MUST BE DATA MOVE

 SREQ20   LDK    ZERO        SET COMMAND PROCESSED
          STDL   P1
          RJM    SIODNE      SEND SLAVE RESPONSE
          LDK    ZERO        SET NO COMMAND TO PROCESS
          UJK    SREQX       EXIT
          SPACE  4
 CONCHS   BSS                SLAVE CHANNEL INSTRUCTION TABLE
 TTP+40B  HERE
 T40B+TP  HERE
 TTP      HERE
          CON    0           END OF TABLE
          SPACE  4
*         CHECK IF OVERLAY EXCEEDS SLAVE OVERLAY BUFFER.
          ERRPL  *-ESCOBUF
          OVERLAY (WRITE FAILURE),OVLBUF
          ROUTINE WFO        WRITE FAILURE OVERLAY
          SPACE  4
** NAME - WFAILO
*
** PURPOSE - PROCESS ABNORMAL WRITE REQUEST COMPLETION.
*
** INPUT - (CHKWRTF) = 0, REQUEST WAS IN PROGRESS WHEN FAILURE OCCURED,
*                         (ACTCNT) = IF NZ ANY PREVIOUS REQUESTS IN UCA.
*
*          (CHKWRTF) =NZ, POST REQUEST PROCESSING DETECTED THE ERROR,
*                         (ACTCNT) = NUMBER OF ACTIVE REQUESTS IN UCA.
*
** PROCESSING - THE FOLLOWING ERRORS ARE PROCESSED IN THE ORDER LISTED.
*
*         1. CATASTROPHIC ERRORS -
*                CAUSED BY - RESPONSE ERROR ID
*                            OR ADAPTER CHECK
*                            OR ADAPTER ERROR CODE (EC33 IGNORED UP TO LIMIT)
*                            OR NOTHING SET IN ABNORMAL STATUS FIELD
*                            OR ALERT ON RETURN FROM GETBID FROM WFAILO.
*                ACTION    - DELINK AND SEND ABNORMAL RESPONSE TO THE FIRST
*                            REQUEST WITH THE FIRST COMMAND RMA SET AS THE
*                            FAILING COMMAND.
*                (LGBID)   = 0000 0000.
*
*         2. ABNORMAL ALERT (EOT) ONLY -
*                CAUSED BY - ABNORMAL ALERT BIT IN ABNORMAL STATUS FIELD
*                            IS THE ONLY BIT SET.
*                ACTION    - DELINK AND SEND NORMAL RESPONSES TO ANY
*                            COMPLETED REQUESTS.
*                            DELINK AND SEND ABNORMAL RESPONSE TO THE REQUEST
*                            IN ERROR WITH THE COMMAND RMA THAT DETECTED EOT
*                            AS THE FAILING COMMAND.
*                NOTE      - EOT IS NEVER DETECTED IN POST REQUEST PROCESSING,
*                            THE (LGBID) IS SET BY ROUTINE FAIL20.
*                (LGBID)   = SET TO THE END OF THE RECORD THAT DETECTED EOT.
*
*         3. HARDWARE ERROR (UNIT CHECK) -
*                CAUSED BY - HARDWARE ERROR STATUS IN ABNORMAL STATUS FIELD
*                            AND GENERAL STATUS UNIT CHECK IS SET
*                            AND SENSE BYTE DATA CHECK IS SET
*                            AND SENSE BYTE ERPA EQUAL NONZERO
*                            AND BLOCK ID POSITIONING INDICIATOR IS NOT SET.
*                ACTION    - DELINK AND SEND NORMAL RESPONSES TO ANY
*                            COMPLETED REQUESTS.
*                            DELINK AND SEND ABNORMAL RESPONSE TO THE REQUEST
*                            IN ERROR WITH THE COMMAND RMA THAT CAUSED THE
*                            ERROR AS THE FAILING COMMAND.
*                (LGBID)   = TAPE POSITION BLOCK ID FROM READ BLOCK ID COMMAND.
*
*         4. NONE OF THE ABOVE -
*                ACTION    - FORCE CATASTROPHIC ERROR, SEE ABOVE.
*
          SPACE  2
 WFAILO   SUBR               OVERLAY ENTRY/EXIT

*         CHECK FOR CATASTROPHIC ERRORS.
          LDML   RESBUF+/RS/P.REID  CHECK RESPONSE ERROR ID
          NJN    WFAIL20     IF YES
          LDML   RESBUF+/RS/P.GS2  CHECK ADAPTER CHECK AND ERROR CODE
          LPK    /RS/K.ADPTC+/RS/M.EC
          NJN    WFAIL10     IF YES
          LDML   RESBUF+/RS/P.ABALRT  CHECK ABNORMAL STATUS
          NJN    WFAIL30     IF SOMETHING IS ALREADY SET
          LCN    1           ELSE FORCE A CATASTROPHIC ERROR
          UJN    WFAIL20     CONTINUE

*         CHECK FOR AND PROCESS CONTROL UNIT BUSY.
 WFAIL10  LPK    /RS/M.EC    MASK ONLY THE ERROR CODE
          SBN    EC33        CHECK FOR ERROR CODE 33
          NJN    WFAIL15     IF NOT
          LDDL   CONFLG      GET THE UNIT NUMBER
          LPN    17B
          STDL   T1          SET AN INDEX
          AOML   SCRBUF+8,T1  INCREMENT UNIT BUSY COUNTER
          SHN    1           POSITION CARRY BIT
          PJN    WFAILOX     IF NOT EXCEEDED  RETURN

 WFAIL15  LDML   RESBUF+/RS/P.GS2  SET CATASTROPHIC ERROR
          LPK    /RS/K.ADPTC+/RS/M.EC

 WFAIL20  STML   WFCE        SET CATASTROPHIC ERROR FLAG
          UJK    WFAIL60     CONTINUE

*         CHECK FOR ABNORMAL ALERT ( EOT ) ONLY CONDITIONS.
 WFAIL30  LPK    -/RS/K.ABALRT
          NJN    WFAIL40     IF SOMETHING ELSE IS SET
          LDN    1           SET EOT FLAG
          STML   WFEOT
          UJK    WFAIL50     CONTINUE

*         CHECK FOR HARDWARE ERROR.
 WFAIL40  LDML   RESBUF+/RS/P.ABALRT  CHECK FOR HARDWARE ERROR
          LPK    /RS/K.HDWR
          ZJK    WFAIL60     IF NOT SET
          LDML   RESBUF+/RS/P.GS2  CHECK FOR UNIT CHECK
          LPK    /RS/K.UNITC
          ZJK    WFAIL60     IF NOT SET
          LDML   RESBUF+/RS/P.DSB  CHECK FOR DATA CHECK
          SHN    6
          PJK    WFAIL60     IF NOT SET
          LDML   RESBUF+/RS/P.DSB+1  CHECK FOR ANY ERPA CODE
          LPK    0#FF
          ZJK    WFAIL60     IF NOT SET
          LDML   RESBUF+/RS/P.DSB+1  CHECK BLOCK ID POSITIONING INDICATOR
          SHN    9
          MJK    WFAIL60     IF SET (SHOULD NEVER BE SET)

*         SAVE ORIGINAL ERROR STATUS.
          LDN    7           SET WORD COUNT
          STDL   WC
          LOADC  CM.UCA      USE CM UNIT COMM AREA
          ADN    /UCA/C.ERRSTA  OFFSET TO ERROR STATUS FIELD
          CWML   RESBUF+/RS/P.GS1,WC  SAVE IT

*         GET CURRENT TAPE POSITION BLOCK ID.
          LDN    1           FAKE GS1 STATUS FOR ROUTINE GETBID
          STML   RESBUF+/RS/P.GS1
          RJM    GETBID      GET CURRENT HOST AND TAPE POSITION BLOCK ID

*         IF THE GETBID ROUTINE GETS A CATASTROPHIC ERROR DURING PROCESSING
*         THIS OVERLAY WILL BE LOADED AGAIN AND A CATASTROPHIC ERROR WILL BE
*         PROCESSED.

          MJN    WFAIL60     IF STATUS ERROR OCCURED

*         RESTORE ORIGINAL ERROR STATUS.
          LDN    7           SET WORD COUNT
          STDL   WC
          LOADC  CM.UCA      USE CM UNIT COMM AREA
          ADN    /UCA/C.ERRSTA  OFFSET TO ERROR STATUS FIELD
          CRML   RESBUF+/RS/P.GS1,WC  RESTORE IT

*         SET LGBID FROM TAPE POSITION BLOCK ID.
          LDML   BIDBUF+3    GET UPPER BYTES
          STML   RESBUF+/RS/P.LGBID
          LDML   BIDBUF+4    GET LOWER BYTES
          STML   RESBUF+/RS/P.LGBID+1

*         SET WRITE FAIL RECOVER REQUEST (WFRR) FLAG.
          LDN    1           SET RECOVER REQUEST FLAG
          STML   WFRR

*         SET ERROR BLOCK ID FLAGS.
 WFAIL50  LDML   RESBUF+/RS/P.LGBID
          LPK    0#FF        MASK OUT PHYSICAL REFERENCE
          STML   WFBIDU      SET ERROR BID UPPER
          LDML   RESBUF+/RS/P.LGBID+1
          STML   WFBIDL

*         CHECK IF REQUEST WAS IN PROGRESS AT FAILURE.
 WFAIL60  LDML   CHKWRTF     GET THE CHECK WRITE FLAG
          NJN    WFAIL70     IF REQUEST WAS NOT IN PROGRESS AT FAILURE
          LCN    0           SET ENDING BLOCK ID TO MAX
          STML   URBHDR+/URB/P.EBID
          STML   URBHDR+/URB/P.EBID+1
          RJM    WRUCA       UPDATE UCA HEADER AND URB RECORD IN CM

*         SAVE FAILURE STATUS.
 WFAIL70  LDN    /RS/C.ELB-/RS/C.GS1  CM WORD COUNT TO SAVE
          STDL   WC
          LOADC  CM.UCA      LOAD R AND A FOR CURRENT UNIT COMM AREA
          ADN    /UCA/C.ERRSTA  OFFSET TO ERROR STATUS
          CWML   RESBUF+/RS/P.GS1,WC
          LDML   RESBUF+/RS/P.ABALRT  SAVE ABNORMAL STATUS
          STML   WFABNS
          LDML   RESBUF+/RS/P.LNGBLK  SAVE ALERT CONDITIONS
          STML   WFAC

*         CHECK TO INSURE AT LEAST 1 MAIN PROCESSING FLAG IS SET.
          LDML   WFCE        GET CATASTROPHIC ERROR FLAG
          ADML   WFEOT       MERGE EOT FLAG
          ADML   WFRR        MERGE RECOVER REQUEST FLAG
          NJN    WFAIL100    IF SOMETHING IS SET
          LDN    1           ELSE SET CATASTROPHIC ERROR FLAG
          STML   WFCE

*         PROCESS ANY ACTIVE REQUESTS.
 WFAIL100 RJM    RURBH       GET FIFO URB HEADER
          RJM    RURBR       GET FIFO URB RECORD
          LDML   WFCE        CHECK IF CATASTROPHIC ERROR
          NJK    WFAIL200    IF YES

*         CHECK IF THIS REQUEST HAS THE ERROR.
          LDML   URBHDR+/URB/P.EBID  COMPARE BLOCK ID-S
          LPK    0#FF
          STDL   T1
          LDML   WFBIDU
          SBDL   T1          COMPARE UPPER BLOCK ID-S
          MJN    WFAIL200    IF THIS REQUEST IS IN ERROR
          LDML   WFBIDL
          SBML   URBHDR+/URB/P.EBID+1  COMPARE LOWER BLOCK ID-S
          MJN    WFAIL200    IF THIS REQUEST IS IN ERROR

*         PROCESS REQUEST COMPLETED NORMALLY.
          RJM    DELINK      DELINK THIS REQUEST
          LDK    R.NRM       SET NORMAL RESPONSE CODE
          STML   RESBUF+/RS/P.RC
          RJM    RESP        SEND THE RESPONSE
          RJM    UINP        UPDATE UCA IN POINTER
          LDML   UCAHDR+/UCA/P.ACTCNT
          NJK    WFAIL100    CHECK NEXT REQUEST

*         NO MATCHING REQUEST FOUND - UPDATE ACTIVE REQUEST COUNT AND EXIT
          LOADC  CM.UCA      LOAD R AND A FOR CURRENT UNIT COMM AREA
          ADN    /UCA/C.ACTCNT  OFFSET TO ACTCNT CM WORD
          CWML   UCAHDR+/UCA/P.ACTCNT,ON
          UJK    WFAILOX

*         PROCESS FAILING REQUEST.
 WFAIL200 LDML   WFEOT       CHECK IF EOT ONLY ERROR
          NJK    WFAIL300    IF YES
          LDN    /RS/C.ELB-/RS/C.GS1  RESTORE THE ERROR STATUS
          STDL   WC
          LOADC  CM.UCA      LOAD R AND A FOR CURRENT UNIT COMM AREA
          ADN    /UCA/C.ERRSTA  OFFSET TO ERROR STATUS
          CRML   RESBUF+/RS/P.GS1,WC  READ BACK THE ERROR STATUS
          LDK    ABNRES      SET ABNORMAL RESPONSE LENGTH
          STML   RESBUF+/RS/P.RESPL
          LDML   WFABNS      RESTORE ABNORMAL STATUS
          STML   RESBUF+/RS/P.ABALRT
          LDML   WFAC        RESTORE ALERT CONDITIONS
          STML   RESBUF+/RS/P.LNGBLK
          LDML   WFCE        CHECK IF CATASTROPHIC ERROR
          ZJN    WFAIL210    IF NOT

*         PROCESS CATASTROPHIC ERROR.
          LDK    CMDBUF      SET FIRST COMMAND AS FAILING COMMAND
          STML   CMDADR
          LDN    0           CLEAR LGBID ON CATASTROPHIC ERRORS
          STML   RESBUF+/RS/P.LGBID
          STML   RESBUF+/RS/P.LGBID+1
          UJN    WFAIL300    GO SEND THE ABNORMAL RESPONSE

*         PROCESS RECOVER THE REQUEST.
 WFAIL210 LDK    CMDBUF+8    INITIALIZE COMMAND ADDRESS TO FIRST OUTPUT
          STDL   CMDADR
*         CALCULATE NUMBER OF GOOD BLOCKS ON THE MEDIA.
          LDML   WFBIDL      GET ERROR LOWER BLOCK ID
          ADK    0#10000     PREVENT UNDERFLOW
          SBML   URBHDR+/URB/P.SBID+1  DECREMENT BY REQUEST STARTING BID
          STDL   T1          SAVE IT TO REMOVE EXCESS
          LDDL   T1          GET IT BACK WITHOUT EXCESS
          SHN    3           MULTIPLE IT BY 8
          RADL   CMDADR      SET COMMAND ADDRESS TO FAILING COMMAND

*         PROCESS REQUEST TERMINATION.
 WFAIL300 LDN    0           CLEAR CHECK WRITE FLAG
          STML   CHKWRTF
          STML   UCAHDR+/UCA/P.ACTCNT  CLEAR UCA ACTIVE COUNT
          LOADC  CM.UCA      LOAD R AND A FOR CURRENT UNIT COMM AREA
          ADN    /UCA/C.ACTCNT  OFFSET TO ACTCNT CM WORD
          CWML   UCAHDR+/UCA/P.ACTCNT,ON
          LDK    R.ABN       SET ABNORMAL RESPONSE CODE
          STML   RESBUF+/RS/P.RC
          RJM    DSABLE      CHECK FOR DISABLE THE UNIT
          RJM    DELINK      DELINK THE REQUEST
          RJM    RESP        SEND THE RESPONSE
          UJK    WFAILOX     RETURN
          SPACE  2
**        WFAIL PROCESSING FLAGS.

 WFCE     DATA   0           CATASTROPHIC ERROR

 WFEOT    DATA   0           END OF TAPE ONLY

 WFRR     DATA   0           RECOVER REQUEST

 WFBIDU   DATA   0           LOGICIAL BLOCK ID UPPER OF ERROR RECORD

 WFBIDL   DATA   0           LOGICAL BLOCK ID LOWER OF ERROR RECORD

 WFABNS   DATA   0           SAVED ERROR ABNORMAL STATUS FIELD

 WFAC     DATA   0           SAVED ERROR ALERT CONDITIONS
          SPACE  4
*         CHECK IF OVERLAY HAS ANY I/O INSTRUCTIONS.
 CONCHX   BSS
 TTP+40B  HERE
 T40B+TP  HERE
 TTP      HERE
          ERRNZ  *-CONCHX    IF ANY THEN ERROR
          SPACE  4
*         CHECK IF OVERLAY HAS EXCEEDED THE OVERLAY BUFFER.
          ERRPL  *-DIOBUF
          OVERLAY (MISC ROUTINES),OVLBUF
          ROUTINE MRO        MISCELLANEOUS ROUTINES
          SPACE  5,20
** NAME - UNLDO
*
** PURPOSE - TO UNLOAD A TAPE UNIT AND GET ITS BUFFERED ERROR LOG.
*
** OUTPUT - BUFFERED ERROR LOG IN RESPONSE BUFFER.
*
          SPACE  2
 UNLDO    BSS                OVERLAY ENTRY

          LDML   URBHDR+/URB/P.WRTCNT  CHECK OUTSTANDING WRITES
          ADML   UCAHDR+/UCA/P.ACTCNT
          NJK    ICS         IF YES REPORT INVALID CMD SEQUENCE
          LDN    2           SET RETRY COUNTER
          STDL   P1

 UNLD05   LDK    /RS/P.ELB+23-/RS/P.DSB  NUMBER OF RESPONSE WORDS TO CLEAR
          STDL   T1          SET INDEX

 UNLD10   LDK    ZERO        CLEAR THE DETAILED STATUS AND ERROR LOG BUFFERS
          STML   RESBUF+/RS/P.DSB,T1
          SODL   T1          CHECK FOR DONE
          PJN    UNLD10      IF NOT  LOOP
          LDK    F.UNL       UNLOAD FUNCTION CODE
          RJM    DOFUNC      SEND FUNCTION CODE

 UNLD20   RJM    GETSTA      GET STATUS
          MJN    UNLD20      IF RETRY OCCURED
          SHN    17-11       CHECK IF ALERT IS SET
          PJN    UNLD25      IF NOT SET
          SODL   P1          DECREMENT RETRY COUNTER
          PJN    UNLD05      IF NOT EXHAUSTED

 UNLD25   RJM    ERRCHK      CHECK FOR ERRORS
          NJN    UNLD40      IF ERRORS OCCURED
          LDK    F.RBEL      READ BUFFERED ERROR LOG FUNCTION CODE
          RJM    DOFUNC      SEND FUNCTION CODE
          LDK    UNLRES      SET UNLOAD RESPONSE LENGTH
          STML   RESBUF+/RS/P.RESPL

 UNLD30   ACN    TP          ACTIVATE CHANNEL
          LDK    32          12-BIT WORD COUNT
          IAPM   RESBUF+/RS/P.ELB,TP  INPUT THE LOG
          DCN    40B+TP      DEACTIVATE CHANNEL
          STDL   AREG        SAVE RESIDUAL WORD COUNT
          SFM    INCPE,TP    CHECK AND CLEAR CHANNEL ERROR FLAG
          RJM    GETSTA      GET STATUS
          MJK    UNLD30      IF RETRY OCCURED
          RJM    ERRCHK      CHECK FOR ERRORS
          NJN    UNLD40      IF ERRORS OCCURED
          LDDL   AREG        CHECK IF ANY RESIDUAL WORD COUNT
          NJK    RCNZI       IF YES  GO PROCESS INPUT ERROR

 UNLD40   UJK    CMDONE      GOTO COMMAND COMPLETE
          SPACE  5,20
** NAME - GETHSO
*
** PURPOSE - GET HARDWARE STATUS ON IOU FAILURES OVERLAY.
*
** NOTE - THIS ROUTINE SHOULD ONLY BE CALLED WHEN AN IOU ERROR
*         HAS ALREADY BEEN DETECTED, AS THIS SUBROUTINE WILL
*         NOT GENERATE ADDITIONAL ERROR RESPONSES.
*
          SPACE  2
 GETHS10  DCN    40B+TP      DEACTIVATE CHANNEL
          SFM    *+2,TP      CLEAR CHANNEL ERROR FLAG

 GETHSO   SUBR               OVERLAY ENTRY/EXIT

          DCN    40B+TP      DEACTIVATE CHANNEL
          LDK    ZERO        CLEAR STATUS RESPONSE AREAS
          STML   RESBUF+/RS/P.CESR  CIO CHANNEL ERROR STATUS REGISTER
          STML   RESBUF+/RS/P.GS1   GENERAL STATUS
          STML   RESBUF+/RS/P.GS2
          LDK    /RS/B.DSB/2-1  DSB LENGTH IN PP WORDS -1
          STDL   T1          SET INDEX

 GETHS20  LDN    0           CLEAR DSB
          STML   RESBUF+/RS/P.DSB,T1
          SODL   T1          CHECK FOR DONE
          PJN    GETHS20     IF NOT LOOP
          LDK    ABNRES      SET ABNORMAL RESPONSE LENGTH
          STML   RESBUF+/RS/P.RESPL
          RJM    GETHSC      GET CIO CHANNEL STATUS
          NJK    GETHS10     IF ERROR
          LDK    F.GS        GO GET GENERAL STATUS
          RJM    GETHSE
          NJK    GETHS10     IF ERROR
          LDK    F.DS        GO GET DETAILED STATUS
          RJM    GETHSE
          UJK    GETHS10     EXIT
          SPACE  5,20
** NAME - GETHSE
*
** PURPOSE - GET HARDWARE STATUS (EQUIPMENT) ON IOU FAILURES.
*
** INPUT - (A) = GENERAL STATUS OR DETAILED STATUS FUNCTION CODE.
*
** OUTPUT - (A) = ZERO IF NO ERROR,
*                 NON-ZERO IF ERROR OCCURED.
*
** NOTE - ERRORS DURING PROCESSING WILL NOT GENERATE ANY NEW
*         ERROR RESPONSE BECAUSE THIS ROUTINE IS BEING USED TO
*         PROCESS AN EXISTING ERROR.
*
          SPACE  2
 GETHSE   SUBR               ENTRY/EXIT

          STML   GETHSEA     SAVE ENTRY PARAMETER
          LDDL   CONFLG      CHECK IF EQUIPMENT IS CONNECTED
          ZJK    GETHSEX     IF NOT EXIT
          LDN    30          FUNCTION TIMEOUT ABOUT 3 SECONDS
          STDL   T2
          LCN    ZERO        END OF OPERATION LOOP COUNTER
          STDL   T3

 GETHSE10 LDC    7777B       FUNCTION CODE (PLUGGED)
 GETHSEA  EQU    *-1
          FAN    TP          SEND FUNCTION

 GETHSE20 LDK    100000      FUNCTION LOOP COUNTER

 GETHSE30 IJM    GETHSE50,TP  IF INACTIVE RECEIVED
          SBN    1           CHECK FUNCTION LOOP COUNTER
          NJK    GETHSE30    IF NOT EXPIRED
          SODL   T2          CHECK FUNCTION TIMEOUT
          NJK    GETHSE20    IF NOT EXPIRED
          DCN    40B+TP      DEACTIVATE CHANNEL

 GETHSE40 LDK    ONE
          UJK    GETHSEX     ERROR EXIT

 GETHSE50 ACN    TP          ACTIVATE CHANNEL FOR INPUT
          LDK    10          10 MICROSECOND LIMIT FOR FIRST FULL

 GETHSE60 FJM    GETHSE70,TP  CHECK IF FIRST WORD OF STATUS IS READY
          SBN    1           DECREMENT TIMER
          NJK    GETHSE60    IF TIME LIMIT NOT EXPIRED
          DCN    40B+TP      DEACTIVATE CHANNEL
          SODL   T3          DECREMENT EOP LOOP COUNTER
          NJK    GETHSE10    IF NOT EXPIRED
          UJK    GETHSE40    EXIT BAD

 GETHSE70 LDML   GETHSEA     CHECK FOR GENERAL STATUS FUNCTION
          SBN    F.GS
          NJN    GETHSE80    IF NOT
          LDK    TWO         PROCESS GENERAL STATUS FUNCTION
          IAM    RESBUF+/RS/P.GS1,TP  INPUT GENERAL STATUS
          UJN    GETHSE90

 GETHSE80 LDK    26          PROCESS DETAILED STATUS
          IAPM   RESBUF+/RS/P.DSB,TP  INPUT DETAILED STATUS

 GETHSE90 DCN    40B+TP      DEACTIVATE CHANNEL
          UJK    GETHSEX     NORMAL EXIT
          SPACE  5,10
 CONCHMR  BSS    0           MISC ROUTINES CHANNEL INSTRUCTION TABLE
 TTP+40B  HERE
 T40B+TP  HERE
 TTP      HERE
          CON    0           END OF TABLE
          SPACE  2
*         CHECK IF OVERLAY EXCEEDS THE OVERLAY BUFFER.
          ERRPL  *-DIOBUF
          TITLE  END OF DRIVER.
          END
/EOR
*DECK DECK=IOM$ALLOCATE_IMAGE_REQUESTS EXPAND=TRUE
MODULE iom$allocate_image_requests;

*copyc OSD$DEFAULT_PRAGMATS
*copyc IOE$ST_ERRORS
*copyc OSK$KEYPOINTS
*copyc IOK$KEYPOINTS
*copyc OST$STATUS
*copyc OST$HARDWARE_SUBRANGES
*copyc PMP$ZERO_OUT_TABLE
*copyc IOT$NUMBER_OF_REQUESTS
*copyc IOT$COMMAND
*copyc OSV$PAGE_SIZE
*copyc IOT$IMAGE_REQUEST
*copyc osv$mainframe_wired_cb_heap


  PROCEDURE [XDCL, #GATE] iop$allocate_image_requests (number_of_requests:
    iot$number_of_requests;
        commands_per_request: iot$commands_per_request;
    VAR image_request_area: ^SEQ ( * );
    VAR status: ost$status);

    VAR
      request_area: ^SEQ ( * ),
      image_request: iot$image_request,
      command: iot$command,
      image_length: 0 .. 100,
      command_length: 0 .. 100,
      request_size: 1 .. 1000,
      total_size: integer,
      unusable_size: integer,
      unusable_requests: integer,
      loop: boolean;



    status.normal := TRUE;
    #INLINE ('keypoint', osk$entry, 0, iok$allocate_image_request);

    image_length := #SIZE (image_request);
    command_length := #SIZE (command);
    request_size := image_length + (command_length * commands_per_request);
    total_size := request_size * number_of_requests;
    unusable_size := 0;

    loop := TRUE;
    WHILE loop DO
      unusable_requests := ((total_size + unusable_size) DIV osv$page_size) +
            1;
      unusable_size := unusable_requests * request_size;
      IF unusable_requests = (((total_size + unusable_size) DIV osv$page_size)
            + 1) THEN
        loop := FALSE;
      IFEND;
    WHILEND;

    total_size := total_size + unusable_size;

    ALLOCATE request_area: [[REP total_size OF ost$byte]] IN
          osv$mainframe_wired_cb_heap^;
    IF request_area = NIL THEN
      status.normal := FALSE;
      status.condition := ioc$no_space_to_allocate;
      RETURN;
    IFEND;

    pmp$zero_out_table (#LOC (request_area^), #SIZE (request_area^));

    image_request_area := request_area;

    #INLINE ('keypoint', osk$exit, 0, iok$allocate_image_request);




  PROCEND iop$allocate_image_requests;
MODEND iom$allocate_image_requests;
*DECK DECK=IOM$ALLOCATE_USAGE_COUNTERS EXPAND=TRUE
*copyc osd$default_pragmats
?? NEWTITLE := ' IOM$ALLOCATE_USAGE_COUNTERS. ' ??
MODULE iom$allocate_usage_counters;
*copyc cmc$logical_unit_constants
*copyc cmt$controller_type
*copyc cmt$logical_pp_table
*copyc cmt$physical_equipment_number
*copyc iot$disk_type_table
*copyc iot$disk_usage
*copyc iot$logical_unit
*copyc iot$pp_table
*copyc iot$pp_interface_table
*copyc iot$unit_interface_table
*copyc cmp$get_element_name_via_lun
*copyc pmp$zero_out_table
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc iov$disk_pp_usage_p
*copyc iov$disk_unit_usage_p
*copyc iov$disk_type_table
*copyc osv$mainframe_wired_cb_heap

?? EJECT ??
  PROCEDURE [XDCL] iop$allocate_usage_counters (
        VAR status: ost$status);

    VAR
      bytes_per_mau: iot$bytes_per_mau,
      channel: cmt$physical_channel,
      controller_type: cmt$controller_type,
      disk_channel: boolean,
      element_name: cmt$element_name,
      equipment: cmt$physical_equipment_number,
      iou_number: dst$iou_number,
      port_index: 0 .. 1,
      pp: integer,
      pp_count: integer,
      pp_usage_array_p: ^iot$disk_pp_array,
      pp_usage_p: ^iot$disk_pp_usage,
      size: integer,
      unit: iot$logical_unit,
      unit_count: integer,
      unit_type: iot$unit_type,
      unit_usage_array_p: ^iot$disk_unit_array,
      unit_usage_p: ^iot$disk_unit_usage;

    status.normal := TRUE;
    IF (cmv$logical_pp_table_p = NIL) OR (cmv$logical_unit_table = NIL) THEN
      RETURN;
    IFEND;
    pp_count := UPPERBOUND (cmv$logical_pp_table_p^);
    ALLOCATE pp_usage_array_p: [1 .. pp_count] IN osv$mainframe_wired_cb_heap^;
    FOR pp := 1 TO pp_count DO
      pp_usage_array_p^ [pp] := NIL;
    FOREND;
    unit_count := UPPERBOUND (cmv$logical_unit_table^);
    ALLOCATE unit_usage_array_p :[1 .. unit_count] IN osv$mainframe_wired_cb_heap^;
    FOR unit := 1 TO unit_count DO
      unit_usage_array_p^ [unit] := NIL;
    FOREND;
    FOR pp := 1 to pp_count DO
      IF cmv$logical_pp_table_p^ [pp].flags.configured THEN
        controller_type := cmv$logical_pp_table_p^ [pp].controller_info.controller_type;
        CASE controller_type OF
        = cmc$ms7154_x, cmc$ms7155_1, cmc$ms7155_1x,
          cmc$ms7255_1_1, cmc$ms7255_1_2, cmc$mshydra_ct,
          cmc$ms7165_2x, cmc$mscm3_ct, cmc$ms5831_x =
          disk_channel := TRUE;
        ELSE
          disk_channel := FALSE;
        CASEND;
        IF disk_channel AND NOT cmv$logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.slave THEN
          iou_number := cmv$logical_pp_table_p^ [pp].pp_info.channel.iou_number;

       /unit_descriptor_loop/
          FOR unit := LOWERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
                pp_interface_table_p^.unit_descriptors) TO
                UPPERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
                pp_interface_table_p^.unit_descriptors) DO
            IF cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                      unit_descriptors [unit].unit_interface_table_rma = 0 THEN
              CYCLE /unit_descriptor_loop/;
            IFEND;
            equipment := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                  unit_descriptors [unit].physical_path.controller_number;
            channel.number := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                  unit_descriptors [unit].physical_path.channel_number;
            channel.concurrent := cmv$logical_pp_table_p^ [pp].pp_info.
                  channel_interlock_p^.channel_characteristics [channel.number].concurrent_channel;
            port_index := 0;
            IF channel.concurrent THEN
              IF (controller_type = cmc$mshydra_ct) OR (controller_type = cmc$mscm3_ct) OR
                 (controller_type = cmc$ms5831_x) THEN
                IF cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                      unit_descriptors [unit].physical_path.port = 1 THEN
                  channel.port := cmc$port_b;
                  port_index := 1;
                ELSE
                  channel.port := cmc$port_a;
                IFEND;
              ELSE
                channel.port := cmc$unspecified_port;
              IFEND;
            ELSE
              channel.port := cmc$unspecified_port;
            IFEND;
            unit_type := cmv$logical_unit_table^ [unit].unit_interface_table^.unit_type;
            bytes_per_mau := iov$disk_type_table [unit_type - 100(16) + 1].bytes_per_mau;
            IF pp_usage_array_p^ [pp] = NIL THEN
              ALLOCATE pp_usage_p IN osv$mainframe_wired_cb_heap^;
              size := #size (pp_usage_p^);
              pmp$zero_out_table (#loc (pp_usage_p^), size);
              pp_usage_p^.iou_number := iou_number;
              pp_usage_p^.channel:= channel;
              pp_usage_array_p^ [pp] := pp_usage_p;
            IFEND;
            pp_usage_array_p^ [pp]^.path_usage [port_index] [equipment].path_configured := TRUE;
            pp_usage_array_p^ [pp]^.path_usage [port_index] [equipment].path_used := FALSE;
            pp_usage_array_p^ [pp]^.path_usage [port_index] [equipment].logical_unit := unit;
            pp_usage_array_p^ [pp]^.path_usage [port_index] [equipment].bytes_per_mau := bytes_per_mau;
            pp_usage_array_p^ [pp]^.path_usage [port_index] [equipment].path_type :=
                  cmv$logical_pp_table_p^ [pp].controller_info.controller_type;
            IF unit_usage_array_p^ [unit] = NIL THEN
              ALLOCATE unit_usage_p IN osv$mainframe_wired_cb_heap^;
              size := #size (unit_usage_p^);
              pmp$zero_out_table (#loc (unit_usage_p^), size);
              cmp$get_element_name_via_lun (unit, element_name, status);
              unit_usage_p^.unit_configured := TRUE;
              unit_usage_p^.unit_used := FALSE;
              unit_usage_p^.iou_number := iou_number;
              unit_usage_p^.channel := channel;
              unit_usage_p^.equipment := equipment;
              unit_usage_p^.recorded_vsn := '      ';
              unit_usage_p^.unit_type := unit_type;
              unit_usage_p^.bytes_per_mau := bytes_per_mau;
              unit_usage_p^.element_name := element_name;
              unit_usage_p^.last_request_good := TRUE;
              unit_usage_array_p^ [unit] := unit_usage_p;
            IFEND;
          FOREND /unit_descriptor_loop/;
        IFEND;
      IFEND;
    FOREND;
    iov$disk_unit_usage_p := unit_usage_array_p;
    iov$disk_pp_usage_p := pp_usage_array_p;
  PROCEND iop$allocate_usage_counters;
MODEND iom$allocate_usage_counters;

*DECK DECK=IOM$CHECK_ACTIVE_PPS EXPAND=TRUE
*DECK DECK=IOM$CHECK_IDLE_PPS EXPAND=TRUE
*DECK DECK=IOM$CLBTP EXPAND=TRUE
          IDENT  CLBTP
          CIPPU
          MEMSEL 8
          TITLE  CLBTP IPI CHANNEL LOOPBACK TEST PROGRAM FOR I4.
*
*         WORD 6 OF THE FOLLOWING COMMENT MUST BE THE REVISION NUMBER FOR CTI
*
          COMMENT *SMD* LVL=01
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
*
*         THIS IS THE PP DRIVER FOR THE 10 AND 25 MB/S CHANNELS THAT TESTS
*         THE CHANNEL LOOPBACK FEATURE OF THE IPI CHANNEL INTERFACE.
          LIST   -$
          LIST   B,L,N,R
          EJECT
*COPY     DSI$PP_MACROS

*
*         EQUATES FOR IPI ADAPTER
*
 H0000    EQU    0#0000      MASTER CLEAR ADAPTER
 H0009    EQU    0#0009      SET SELECT OUT
 H0029    EQU    0#0029      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H005B    EQU    0#005B      SET SYNC OUT
 H0071    EQU    0#0071      FULL WHEN SLAVE IN IS 0
 H00E1    EQU    0#00E1      READ STATUS REGISTER
 H00F1    EQU    0#00F1      READ ERROR REGISTER
 H0102    EQU    0#0102      READ IPI REVISION REGISTER
 H0122    EQU    0#0122      IPI BUS A OUTPUT PARITY ERROR
 H200     EQU    0#0200      READ CONTROL REGISTER/READ ATTRIBUTES
 H0281    EQU    0#0281      STREAM, READ
 H0300    EQU    0#0300      WRITE CONTROL REGISTER
 H0302    EQU    0#0302      WRITE TRANSMITTER RECEIVER REGISTER
 H0322    EQU    0#0322      IPI BUS A INPUT PARITY ERROR
 H0381    EQU    0#0381      STREAM, WRITE
 H0600    EQU    0#0600      READ DMA ERROR REGISTER
 H0700    EQU    0#0700      READ OPERATIONAL STATUS
 H0711    EQU    0#0711      DROP MASTER OUT
 H0715    EQU    0#0715      REQUEST CLASS 1, 2, OR 3 INTERRUPT
 H0800    EQU    0#0800      DMA TERMINATE/ABORT COMMAND
 H0900    EQU    0#0900      DMA NEW BURST TRANSFER
 H0A00    EQU    0#0A00      READ T REGISTER
 H0B00    EQU    0#0B00      WRITE T PRIME REGISTER
 H0C00    EQU    0#0C00      DMA READ
 H0C22    EQU    0#0C22      ICI OUTPUT PARITY ERROR
 H0D00    EQU    0#0D00      DMA WRITE
 H8025    EQU    0#8025      MASTER OUT, FULL WHEN SLAVE IN IS 1
 H8039    EQU    0#8039      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H8215    EQU    0#8215      SET MASTER OUT, LOGICAL INTERFACE RESET
 H8415    EQU    0#8415      SET MASTER OUT, SLAVE RESET
 H9211    EQU    0#9211      DROP SYNC OUT
 H9213    EQU    0#9213      SET SYNC OUT
          SPACE  5,20
*         ERROR CODES

 E00      EQU    0           CP MUST DETERMINE ERROR CODE
 E01      EQU    1           FUNCTION TIMEOUT
 E02      EQU    2           CHANNEL EMPTY WHEN ACTIVATED
 E03      EQU    3           PERIOD COUNTER PARITY
 E04      EQU    4           PP-IPI PARITY ERROR
 E06      EQU    6           IOU ERROR
 E07      EQU    7           INCOMPLETE I4 TRANSFER
 E08      EQU    8           CHANNEL NOT EMPTY
 E09      EQU    9           CENTRAL MEMORY ERROR
 E10      EQU    10          INVALID CM RESPONSE CODE
 E11      EQU    11          CM RESPONSE CODE PARITY ERROR
 E12      EQU    12          CMI READ DATA PARITY ERROR
 E13      EQU    13          Y DATA ERROR
 E14      EQU    14          BAS PARITY ERROR
 E15      EQU    15          Z ERROR
 E16      EQU    16          Y ERROR
 E17      EQU    17          X ERROR
 E18      EQU    18          DMA TEST MODE FAILURE
 E19      EQU    19          DMA COUNT OVERFLOW
 E20      EQU    20          CANT SELECT CONTROLLER
 E21      EQU    21          BIT SIGNIFICANT RESPONSE ERROR
 E22      EQU    22          NO SYNC IN
 E23      EQU    23          SYNC IN DID NOT DROP
 E24      EQU    24          IPI SEQUENCE ERROR
 E25      EQU    25          IPI CHANNEL PARITY ERROR
 E27      EQU    27          SLAVE IN NOT SET
 E28      EQU    28          SLAVE IN DID NOT DROP
 E29      EQU    29          INCOMPLETE TRANSFER
 E30      EQU    30          CHANNEL STAYED ACTIVE
 E31      EQU    31          BUFFER COUNTER PARITY
 E32      EQU    32          SYNC COUNTER PARITY
 E33      EQU    33          LOST DATA
 E34      EQU    34          BUS PARITY
 E35      EQU    35          COMMAND REJECT
 E36      EQU    36          SYNC OUT NOT EQUAL SYNC INS
 E37      EQU    37          BUS B ACKNOWLEDGE INCORRECT
 E38      EQU    38          NO CONTROLLER RESPONSE
 E39      EQU    39          ENDING STATUS WRONG
 E50      EQU    50          EXECUTING CONTROLLER DIAGNOSTICS
 E51      EQU    51          CONTROLLER DIAGNOSTICS PASSED
 E52      EQU    52          CONTROLLER DIAGNOSTICS PASSES, LAST ERROR CODE RETURNED
 E54      EQU    54          DRIVE ALTERNATE PORT EVENT
 E55      EQU    55          RESTORING DRIVE
 E56      EQU    56          DRIVE RESTORATION COMPLETE
 E57      EQU    57          FORMATTING DRIVE
 E58      EQU    58          FORMAT COMPLETE
 E59      EQU    59          PARITY PROTECTION DISABLED
 E61      EQU    61          DRIVE FAILURE
 E62      EQU    62          MEDIA FAILURE
 E70      EQU    70          LRC ERROR ON READ
 E71      EQU    71          CONTROLLER INTERVENTION REQUIRED
 E72      EQU    72          CONTROLLER MACHINE EXCEPTION
 E73      EQU    73          COMMAND EXCEPTION
 E74      EQU    74          MICROCODE EXECUTION ERROR
 E75      EQU    75          CONTROLLER ALTERNATE PORT EVENT (MAPPED TO 53 BY CP CODE)
 E76      EQU    76          UNEXPECTED RESPONSE
 E110     EQU    110         PP-CONTROLLER DATA INTEGRITY
 E111     EQU    111         CM-DRIVE DATA INTERGRITY
 E120     EQU    120         SOFTWARE FAILURE
 E130     EQU    130         DEFECT MANAGEMENT TASK FAILED
 E140     EQU    140         XXXX CONFIGURED - YYYY FOUND
 E141     EQU    141         DRIVE INITIALIZATION REQUIRED
 E142     EQU    142         CONTROLLER DOES NOT SUPPORT PARALLEL
 E143     EQU    143         CHANNEL ERROR FLAG SET

 DC       EQU    22B         DISK CHANNEL

*         DIRECT CELL DEFINITION.

 T0       EQU    0
 T1       EQU    1
 T2       EQU    2
 T3       EQU    3
 T4       EQU    4
 T5       EQU    5
 T6       EQU    6
 T7       EQU    7
 T8       EQU    10 - 13
 CM       EQU    14 - 17
 D1       EQU    20
 CHAN     EQU    21          CHANNEL TO USE FOR XFER
 JT       EQU    22 - 25
 LF       EQU    26
 OS       EQU    27
 W0       EQU    30          WORKING STORAGE
 W1       EQU    31
 W2       EQU    32
 W3       EQU    33
 W4       EQU    34
 W5       EQU    35
 W6       EQU    36
 W7       EQU    37
 RS       EQU    40 - 43
 BW       EQU    44 - 47
 WC       EQU    50
 ST       EQU    51
 RN       EQU    52
 DO       EQU    53
 DP       EQU    54 - 56
          ORG    70
          CON    0
 DH       EQU    71 - 73
          ORG    74
 ON       CON    1           CONSTANT ONE
 MP       CON    0,0,0
          ORG    100
          TITLE  MAIN LOOP
** NAME-- MAIN
*
** PURPOSE-- MAIN IDLE LOOP.  LOOK FOR REQUESTS FROM CENTRAL MEMORY
*            AND PERFORM CHANNEL LOOPBACK FUNCTIONS.
*
** ENTRY
*         MAIN - AFTER DRIVER IS LOADED, WHEN THE PP IS RESUMED
*         MAIN10 - TO RUN DIAGNOSTICS DURING ERROR RECOVERY
          SPACE  2
          RJM    CHGCH       INITIALIZE CHANNEL INSTRUCTIONS
 MAIN     BSS
          RJM    TRM         TRANSMIT FROM RECEIVERS TO CENTRAL MEMORY
          RJM    DLY         DELAY A SPECIFIED AMOUNT OF TIME
          RJM    TMR         TRANSMIT FROM CENTRAL MEMORY TO RECEIVERS
          RJM    CFC         CHECK IF TO STOP DATA TRANSFERS
          UJN    MAIN
          SPACE  4,10
*         THE FOLLOWING MEMORY DESCRIBES THE PARAMETERS OF THE DMA
*         TRANSFER. NOTE - DO NOT DISTURB BYTC AND RMA ORIENTATION.

 BYTC     CON    0           BYTE COUNT
 RMA      CON    0,0         RMA OF TRANSFER
 SEED     CON    0#1357      SEED VALUE FOR DATA GENERATION
 DELAY    CON    0           TIME TO DELAY BETWEEN DATA XFERS

*         FUNCTION CODES FOR IPI-25 CHANNEL

 TR       DATA   0#FF42      25 MB CHANNEL TRANSFER RATE

 PAS      DATA   0#362       25 MB CHANNEL PORT A SELECT


 WOR      DATA   0#702       25 MB CHANNEL WRITE OPERAND REGISTER FUNCTION

 TMWC     DATA   0#FF9C      25 MB CHANNEL TEST MODE WORD COUNT

 ETMF     CON    H0302       25 MB CHANNEL ENABLE TEST MODE FUNCTION

 EDC      DATA   0#4000      25 MB CHANNEL, USE DOUBLE CMI SLOT

 ETMP     DATA   0#80FF      25 MB CHANNEL, ENABLE TEST MODE PARAMETER

 EOG2     DATA   0           25 MB CHANNEL, EXPECTED OPERAND GENERATOR

 RORF     DATA   0#802       25 MB CHANNEL, READ OPERAND GENERATOR FUNCTION

 CTS      DATA   0           25 MB CHANNEL, CHANNEL TRANSFER SPEED

 EP       SPACE  5,20
**        EP - ERROR PROCESSOR.
*

 EP       SUBR               ENTRY POINT FOR ERROR PROCESSOR
          UJN    *
 CFC      SPACE  4,10
**        CFC - CHECK FOR COMPLETE.
*
*         CHECKS IF A REQUEST TO STOP ACTIVITY HAS BEEN POSTED.
*

 CFC      SUBR
          UJN    CFCX        RETURN


 TIM      SPACE  4,10
**        TIM - MAINTAIN MILLISECOND TIME AND EXECUTE TIMED ROUTINES.
*
*         *TIM* USES THE CHANNEL 14 CLOCK TO ALLOW THE EXECUTION OF
*         CERTAIN ROUTINES ON A TIMED BASIS.  THE ROUTINES TO BE
*         ACTIVATED PERIODICALLY ARE IN *ACTB*.  TO ENSURE ACCURACY,
*         *TIM* SHOULD BE CALLED AT LEAST EVERY TWO MILLISECONDS.
*         *TIMA* SHOULD BE INITIALIZED BEFORE THE FIRST CALL TO *TIM*.
*
*         EXIT   (TIMA) IS WITHIN ONE MILLISECOND OF CHANNEL 14 VALUE.
*
*         USES   T1, T7.
*
*         CALLS  SEE *ACTB*.
*
*         NOTE   CHANGES TO THIS ROUTINE SHOULD BE MADE IN *SCI* ALSO.


 TIM      SUBR               ENTRY/EXIT
 TIM1     IAN    14          READ MICROSECOND COUNTER
 TIMC     SBM    TIMA
          PJN    TIM2        IF NO OVERFLOW
 TIMD     ADC    10000       COMPENSATE FOR CLOCK OVERFLOW
 TIM2     ADC    -1000D
          MJN    TIMX        IF LESS THAN ONE MILLISECOND ELAPSED
          LDC    1000D       ADVANCE BASE TIME BY ONE MILLISECOND
 TIME     RAM    TIMA
          AOM    TIMB        ADVANCE SCAN COUNTER
          LMN    5
          NJN    TIM1        IF SCAN PERIOD NOT UP
          STM    TIMB        RESET SCAN COUNTER
          LDC    ACTB        PRESET ACTION ENTRY
          STD    T7
          STM    TIMF
 TIM3     AOM    2,T7        ADVANCE ENTRY COUNTER
          SBM    1,T7
          MJN    TIM4        IF DELAY NOT COMPLETE
          LDN    0
          STM    2,T7        RESET COUNTER
          LDI    T7          CALL SPECIFIED ROUTINE
          STD    T1
          RJM    0,T1
 TIM4     LDN    3           ADVANCE TABLE INDEX
          RAM    TIMF
          STD    T7
          LMC    ACTBL
          NJN    TIM3        IF MORE ENTRIES TO CHECK
          LJM    TIM1        RETURN

 TIMA     CON    0
 TIMB     CON    0
 TIMF     BSS    1           FWA OF ENTRY BEING PROCESSED
 ACTB     SPACE  4,10
**        ACTB - ACTIVATION TABLE.
*
*         THE FOLLOWING TABLE IS USED BY ROUTINE *TIM* TO DETERMINE
*         WHICH ROUTINES TO CALL ON A PERIOD OF MILLISECONDS BASIS.
*         THE TABLE CONSISTS OF THREE WORD ENTRIES IN THE FOLLOWING
*         FORMAT.
*
*         16/ROUTINE TO CALL, 16/CALL TIME INTERVAL, 16/ELAPSED TIME.

 ACTB     BSS    0           TABLE OF TIMED ROUTINES

 ACTB1    CON    STF,20,0   DELAY FOR TRANSFERS 20 MILLISECONDS
 ACTBL    EQU    *
          SPACE  5,20
 DLY      SPACE  4,10
**        DLY - DELAY FOR A VARAIBLE PERIOD TO ALLOW DATA TRANSFER VARIABILITY.
*

 DLY      SUBR
          LDN    0
          STML   ACTB1+2
          STML   TFLG
 DLY0     RJM    TIM
          LDM    TFLG
          ZJN    DLY0        IF NOT DONE WITH DELAY
          UJN    DLYX        RETURN
 HTO      SPACE  4,10
**        STF - SET TIMEOUT FLAG.
*

 STF      SUBR
          LDN    1
          STML   TFLG        SET TIMEOUT FLAG
          UJN    STFX        RETURN

 TFLG     CON    0           TIMEOUT FLAG
 FAN      SPACE  4,10
** NAME-- FAN
*
** PURPOSE-- SEND A FUNCTION TO THE IPI CHANNEL.
*

 FAN      SUBR
          DCN    DC+40B      ENSURE THE CHANNEL IS INACTIVE
                              THE CHANNEL MAY HAVE BEEN LEFT ACTIVE
                              BY A MASTER CLEAR, A ROUTINE SUCH AS DCM
                              OR AFTER A REPORTED ERROR.
          FAN    DC          SEND THE FUNCTION
          UJN    FANX
          SPACE  5,20
** NAME-- FUNC
*
** PURPOSE-- ISSUE FUNCTION TO IPI CHANNEL
*
** ENTRY-- A REGISTER = FUNCTION CODE.
          SPACE  2
 FUNC     SUBR
          DCN    DC+40B      ENSURE CHANNEL IS INACTIVE
                              THE CHANNEL MAY HAVE BEEN LEFT ACTIVE
                              BY A MASTER CLEAR, A ROUTINE SUCH AS DCM
                              OR AFTER A REPORTED ERROR.
          FAN    DC          ISSUE THE FUNCTION
          STDL   LF          SAVE FUNCTION CODE
          IJM    FUNCX,DC     EXIT IF CHANNEL INACTIVE
          LDN    E01         FUNCTION TIMEOUT
          RJM    EP          ERROR PROCESSING (NO RETURN)
 TMT      SPACE  5,20
** NAME-- TMT
*
** PURPOSE-- TEST MODE TRANSFER
*
** ENTRY
*         A = 0C00 FOR DMA READ
*             0D00 FOR DMA WRITE
          SPACE  2
 TMT      SUBR
          RJM    FUNC
          LDC    200
          STDL   T8          T8 CONTROLS THE TIMEOUT
          STML   BYTC        BYTE COUNT
          ACN    DC
          LDN    3
          OAM    BYTC,DC     BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
 TMT10    BSS
          RJM    ROS         READ OPERATIONAL STATUS
          SFM    TMT40,DC    IF ERROR FLAG SET
          LPN    1
          ZJN    TMTX        IF TRANSFER COMPLETE
          SODL   T8
          NJN    TMT10       IF TIMEOUT NOT EXPIRED
          LDC    H0A00       READ T REGISTER
          RJM    RDRG        READ REGISTER
          SHN    -1
          STDL   WC          SAVE WORD COUNT
          LDC    H0800       DMA TERMINATE
          RJM    FAN
          LDC    H00E1       READ STATUS REGISTER
          RJM    RDRG        READ REGISTER
          STDL   ST          SAVE CONTENTS OF STATUS REGISTER
          LDN    E29         INCOMPLETE TRANSFER
          RJM    EP          ERROR PROCESSING (NO RETURN)
 TMT40    BSS
          LDC    E143        CHANNEL ERROR FLAG SET
          RJM    EP          ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- WOG
*
** PURPOSE-- WRITE OPERAND GENERATOR.  THIS DETERMINES THE NUMBER OF
*            WORDS TO TRANSFER.  FOR READS TO CM IT DETERMINES THE DATA
*            PATTERN AND FOR WRITES IT SETS THE STARTING VALUE FOR ITS
*            CRC CHECK OF THE DATA.
          SPACE  2
 WOG      SUBR
          LDML   WOR
          RJM    FUNC        WRITE OPERAND REGISTER
 WOG10    EQU    *-1         FOR FORCING ERRORS
          LDML   TMWC        TEST MODE WORD COUNT
          STML   WOGP+1
          ACN    DC
          LDN    2
          OAM    WOGP,DC     SEND THE PARAMETERS
          RJM    DCN         DISCONNECT THE CHANNEL
          LDML   ETMF
          STDL   T2          WRITE REGISTER FUNCTION
          LDML   ETMP        ENABLE TEST MODE
          RJM    WR          WRITE REGISTER
          UJN    WOGX
 WOGP     BSS
          DATA   0#1357      STARTING PATTERN
          DATA   0           STREAM 100 PP WORDS (MODIFIED)
          SPACE  5,20
** NAME-- WR
*
** PURPOSE-- WRITE REGISTER
*
** ENTRY--  A = VALUE FOR REGISTER
*          T2 = WRITE REGISTER FUNCTION
          SPACE  2
 WR       SUBR
          STDL   T1
          LDDL   T2          WRITE REGISTER FUNCTION
          RJM    FUNC
          ACN    DC
          LDN    1           OUTPUT ONE WORD
          OAM    T1,DC
          RJM    DCN         DISCONNECT THE CHANNEL
          UJN    WRX
          SPACE  5,20
** NAME-- COG
*
** PURPOSE-- CHECK OPERAND GENERATOR.  THE CRC VALUE GENERATED
*            AFTER A TEST MODE OPERATION IS READ AND COMPARED
*            WITH THE CORRECT VALUE.
*
** NOTE-- THE OPERAND GENERATOR CAN NOT BE READ AFTER A DMA READ
*         ON THE 25 MB CHANNEL
*
** ENTRY  A = EXPECTED OPERAND GENERATOR
          SPACE  2
 COG      SUBR
          STDL   T3
          LDC    H0009
          RJM    FUNC        DROP MASTER OUT
          RJM    DCM         DROP SELECT OUT
          LDML   ETMF
          STDL   T2          WRITE REGISTER FUNCTION
          LDN    0           DISABLE TEST MODE
          RJM    WR          WRITE REGISTER
          LDDL   T3
          ZJN    COGX        IF 25 MB CHANNEL AND DMA READ
          LDML   RORF        READ OPERAND GENERATOR FUNCTION
          RJM    RDRG        READ REGISTER
          LMDL   T3
          ZJN    COGX        IF OPERAND GENERATOR IS CORRECT
          LDN    E18         DMA TEST MODE FAILURE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- TRM
*
** PURPOSE-- TEST DMA PATH FROM RECEIVERS TO CM.
*
** EXIT-- A = 0 IF NO ERROR

          SPACE  2
 TRM      SUBR

*         TRANSFER FROM RECEIVERS TO CENTRAL MEMORY

          RJM    WOG         WRITE OPERAND GENERATOR, ENABLE TEST MODE
          LDN    H0009
          RJM    FUNC        SET SELECT OUT
          LDC    H0281
          RJM    FUNC        IPI TRANSFER FUNCTION (READ)
          LDC    H0C00       DMA READ
          RJM    TMT         TEST MODE TRANSFER
          RJM    COG         DROP MASTER OUT, DESELECT, DISABLE TEST
                              MODE, CHECK OPERAND GENERATOR
          UJN    TRMX        RETURN

 TMR      SPACE  4,10
**        TMR - TRANSMIT FROM CENTRAL MEMORY TO TRANSMITTERS.
*

 TMR      SUBR
          RJM    MCC         MASTER CLEAR CHANNEL.  THIS CLEARS THE LOST DATA
                              ERROR THAT OCCURS ON THE 25 MB CHANNEL WHEN ONLY
                              ONE OF 3 OPERAND GENERATOR WORDS ARE READ.
          RJM    PS          PORT SELECT
          RJM    WOG         WRITE OPERAND GENERATOR, ENABLE TEST MODE
          LDN    H0009
          RJM    FUNC        SET SELECT OUT
          LDC    H0381       IPI TRANSFER FUNCTION (WRITE)
          RJM    FUNC
          LDC    H0D00       DMA WRITE
          RJM    TMT         TEST MODE TRANSFER
          LDML   EOG2        EXPECTED OPERAND GENERATOR
          RJM    COG         DROP MASTER OUT, DESELECT, DISABLE TEST
                              MODE, CHECK OPERAND GENERATOR
          UJP    TMTX
          SPACE  4,10
** NAME-- PS
*
** PURPOSE-- PORT SELECT.  SELECT PORT A OR B OF IPI CHANNEL
          SPACE  2
 PS       SUBR
*         LDML   UNITS,UX
*         SHN    /UN/L.PORT+2
*         PJN    PS5         IF PORT A
*         LDML   PBS,CH      PORT B SELECT
*         UJN    PS10
 PS5      BSS
          LDML   PAS         PORT A SELECT
 PS10     BSS
          RJM    FUNC
          UJN    PSX
          SPACE  5,20
** NAME-- RDRG
*
** PURPOSE-- READ REGISTER
*
** ENTRY--  A = FUNCTION CODE
          SPACE  2
 RDRG10   BSS
          LDN    0
 RDRG     SUBR
          RJM    FAN         SEND FUNCTION
          AJM    RDRG10,DC   IF NO FUNCTION REPLY
          ACN    DC+40B
          EJM    RDRG10,DC   IF WORD COULD NOT BE READ
          IAN    DC
          UJN    RDRGX
          SPACE  5,20
** NAME-- CHGCH
*
** PURPOSE-- SET CHANNEL NUMBER IN CHANNEL INSTRUCTIONS
*
** ENTRY  CHAN = CHANNEL NUMBER
          SPACE  2
 CHGCH    SUBR
          LDN    0
          STDL   T1          CHANGE DISK CHANNEL INSTRUCTIONS
 CHG10    LDML   CONCH,T1    ADDRESS OF CHANNEL INSTRUCTIONS
          ZJN    CHGCHX      END OF LIST
          STDL   T2
          LDIL   T2
          SCN    37B
          LMDL   CHAN        CHANNEL NUMBER
          STIL   T2
          AODL   T1
          UJN    CHG10
 CONCH    BSS                DISK CHANNEL REFERENCES
 TDC+40B  HERE
 T40B+DC  HERE
 TDC      HERE
          CON    0           END OF TABLE
          SPACE  5,20
** NAME-- DCN
*
** PURPOSE-- DISCONNECT THE CHANNEL
          SPACE  2
 DCNX     BSS
          DCN    DC+40B      DISCONNECT THE CHANNEL
          LJM    **
 DCN      EQU    *-1
          STDL   WC          WORDS NOT TRANSFERRED
          SFM    DCN10,DC    IF ERROR FLAG SET
          ZJN    DCN20       IF ALL WORDS TRANSFERRED
          LDN    E07
          UJN    DCN40
 DCN10    BSS
          LDC    E143
          RJM    EP          ERROR FLAG PROCESSING (NO RETURN)
 DCN20    BSS
          EJM    DCNX,DC     IF CHANNEL EMPTY
          LDN    E08         CHANNEL NOT EMPTY
 DCN40    BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  4,10
** NAME-- DCM
*
** PURPOSE-- DESELECT THE CONTROLLER
          SPACE  2
 DCMX     LJM    **
 DCM      EQU    *-1
          LDC    H0071
          RJM    FUNC        DROP SELECT OUT
          ACN    DC
          LDN    77B
 DCM4     FJM    DCMX,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    DCM4        IF TIMEOUT NOT EXPIRED
          LDN    E28         SLAVE IN DID NOT DROP
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- ROS
*
** PURPOSE-- READ OPERATIONAL STATUS
          SPACE  2
 ROSX     LJM    **
 ROS      EQU    *-1
          LDC    H0700       READ OPERATIONAL STATUS
          RJM    FUNC
          ACN    DC
          EJM    ROS10,DC    IF ERROR
          IAN    DC
          STDL   OS          SAVE OPERATIONAL STATUS
          UJN    ROSX
 ROS10    BSS
          LDN    E02         CHANNEL EMPTY WHEN ACTIVATED
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- MCC
*
** PURPOSE-- MASTER CLEAR CHANNEL
          SPACE  2
 MCCX     LJM    **
 MCC      EQU    *-1
          LDN    H0000       MASTER CLEAR CHANNEL
          RJM    FUNC
          LDC    100
          RJM    PAUS        ALLOW CONTROLLER TIME TO DROP LINES
          SFM    MCC10,DC    MASTER CLEAR DOES NOT CLEAR ERROR FLAG ON 25 MB CHANNEL
 MCC10    BSS
          LDN    H0000       MASTER CLEAR CHANNEL
          RJM    FUNC         IN CASE SEQUENCE ERROR OCCURRED
          LDML   TR
          RJM    FUNC        SET IPI CHANNEL TRANSFER RATE
          LDC    H0300
          STDL   T2          WRITE CONTROL REGISTER FUNCTION
          LDML   EDC         ENABLE DOUBLE CMI SLOT IF 25 MB CHANNEL
          RJM    WR          WRITE REGISTER
          UJN    MCCX
          SPACE  5,20
** NAME-- PAUS
*
** PURPOSE-- DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*            MICROSECONDS.
*
** ENTRY  A REGISTER SPECIFIES NUMBER OF MICROSECONDS
*          TO BE DELAYED.
          SPACE  2
 PAUS     SUBR
 PAUS10   SBN    1           EACH ITERATION OF THIS LOOP
          STDL   T1           IS ONE MICROSECOND (I4 ONLY)
          NJN    PAUS10
          UJN    PAUSX

*         THE LAST CARD IN THE DECK MUST BE /EOR SO THAT COMS CAN
*         ASSEMBLE MULTIPLE DECKS.

          END
/EOR
*DECK DECK=IOM$DAS_HEAD_SHIFT_TEST EXPAND=TRUE
MODULE iom$das_head_shift_test;
?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc cme$manage_interface_tables
*copyc cmp$get_mass_storage_info
*copyc ioe$st_errors
*copyc iop$mass_storage_io
*copyc iop$initialize_sectors
*copyc iot$cylinders_to_initialize
*copyc jmp$system_job
*copyc dmt$active_volume_table_index
*copyc dmv$active_volume_table
*copyc pmp$delay
*copyc pmp$wait
*copyc osp$generate_message
*copyc osp$await_activity_completion
*copyc pmt$program_parameters
?? POP ??
{ Purpose:
{ This module is used to invoke a head shift test on all configured
{ DAS units. The test is first run by the DAS driver during it's
{ initialization and thereafter this task will invoke the test once
{ every 28 days of contiguous system run time. The test will warn
{ the customer of a possible head shift problem while the errors are
{ still recoverable. If head shift is detected the driver will return
{ a status that will cause an operator intervention window to be
{ opened which will inform the operator of the condition.
{
{ Design:
{ This module is invoked during system deadstart as a system task by
{ osp$job_template_init_ph2. It will suspend for 672 hours and then
{ execute. At execution it searches the configuration for DAS units.
{ The head shift scan test is started on each configured DAS unit. The
{ task then suspends itself for another 672 hours. If head shift is
{ detected the driver will return a status which is processed by
{ iop$log_disk_error which will cause an operator action window to be
{ opened at the console to inform the operator of the condition.

?? EJECT ??
  PROCEDURE [XDCL, #GATE] iop$das_head_shift_test
    (    p: pmt$program_parameters;
     VAR status: ost$status);

    VAR
      msi: cmt$mass_storage_information,
      avti: dmt$active_volume_table_index,
      cylinders_to_initialize: array [1..1] of iot$cylinders_to_initialize,
      wait_list : array [1..1] of ost$activity,
      hours_to_wait: integer,
      milliseconds_to_wait: integer,
      ready_index: integer,
      ignore: ost$status;

    hours_to_wait := 672;
    milliseconds_to_wait := hours_to_wait * 60 * 60 * 1000;
    wait_list [1].activity := osc$await_time;
    wait_list [1].milliseconds := milliseconds_to_wait;

    IF NOT jmp$system_job () THEN
      RETURN;
    IFEND;

  /forever/
    WHILE TRUE DO


      {Scan the active configuration

    /screen_loop/
      FOR avti := LOWERBOUND (dmv$p_active_volume_table^)
            TO UPPERBOUND (dmv$p_active_volume_table^) DO
        IF NOT dmv$p_active_volume_table^ [avti].entry_available THEN
            cmp$get_mass_storage_info (dmv$p_active_volume_table^ [avti].
                  logical_unit_number, msi, status);
            IF NOT status.normal THEN
              IF (status.condition = cme$it_not_cip_device) OR
                    (status.condition = cme$it_no_cip_access) OR
                    (status.condition = cme$it_unusable_cip_access) THEN
                ;
              ELSE
                CYCLE /screen_loop/;
              IFEND;
            IFEND;
            CASE msi.unit_type OF
            = cmc$ms5833_1, cmc$ms5833_1p, cmc$ms5833_2, cmc$ms5833_3p,
                    cmc$ms5833_4 =

{ Disk requires testing. Send function to the driver to initiate
{ the head shift testing task. A value of 4 in the start_cylinder
{ field will cause the driver to invoke the testing task when the
{ initialize_sectors function is decoded by the driver.

              cylinders_to_initialize [1].start_cylinder := 4;
              iop$initialize_sectors (dmv$p_active_volume_table^ [avti].logical_unit_number,
                    cylinders_to_initialize, status);
              IF status.condition = ioe$unit_disabled THEN
                status.normal := TRUE;
                CYCLE /screen_loop/;
              ELSE
               pmp$delay (100, ignore);
              IFEND;
            ELSE
              CYCLE /screen_loop/;
            CASEND;
        IFEND;
        {Wait 1 minute between issuing commands.
        pmp$wait (60000, 60000);
      FOREND /screen_loop/;
{ Suspend task execution for 28 days.
      osp$await_activity_completion (wait_list, ready_index, ignore);
    WHILEND /forever/;
  PROCEND iop$das_head_shift_test;
MODEND iom$das_head_shift_test;
*DECK DECK=IOM$DEBUG_COMMAND_PROCESSING EXPAND=TRUE

?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? TITLE := '  NOS/VE IO' ??
?? NEWTITLE := '  Module Header' ??
MODULE iom$debug_command_processing;
{
{  PURPOSE :  This module processes the io debug commands.
{
{  DESIGN :
{
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
*copyc ost$status
*copyc ost$wait
*copyc sye$command_processor_errors
*copyc oss$mainframe_pageable
*copyc oss$mainframe_paged_literal
?? POP ??
?? TITLE := '  XREF Variables', EJECT ??
?? TITLE := '  XREF Procedures', EJECT ??
*copyc osp$clear_signature_lock
*copyc osp$set_signature_lock
*copyc osp$set_status_abnormal
?? OLDTITLE ??
MODEND iom$debug_command_processing;

*DECK DECK=IOM$DEVICE_IO EXPAND=TRUE
MODULE iom$device_io;

*copyc OSD$DEFAULT_PRAGMATS
*copyc IOT$DISK_REQUEST
*copyc OST$HARDWARE_SUBRANGES
*copyc OST$PAGE_SIZE
*copyc IOT$RB_DEVICE_IO
*copyc MMP$XTASK_PVA_TO_SVA
*copyc IOT$IO_REQUEST_TYPE
*copyc DMT$MS_LOGICAL_DEVICE_ADDRESS
*copyc OSD$VIRTUAL_ADDRESS
*copyc MMT$BUFFER_DESCRIPTOR
*copyc MTP$ERROR_STOP
*copyc SYT$MONITOR_REQUEST_CODE
*copyc IOP$DISK_REQUEST
*copyc IOT$IO_FUNCTION
*copyc IOT$COMPLETION_STATUS


  PROCEDURE [XDCL] iop$io_processor (VAR request_block: iot$rb_device_io);

    VAR
      m_request_block: iot$rb_device_io,
      pva: ^cell,
      length: ost$byte_count,
      io_function: iot$io_function,
      device_address: dmt$ms_logical_device_address,
      completion: ^iot$completion_status,
      status: syt$monitor_status;

    request_block.status.normal := TRUE;

    m_request_block := request_block;

    pva := m_request_block.pva;
    length := m_request_block.length;
    io_function := m_request_block.io_function;
    device_address := m_request_block.device_address;
    completion := m_request_block.completion;

    iop$device_io (pva, length, io_function, device_address, completion,
          status);
    request_block.status := status;

  PROCEND iop$io_processor;




  PROCEDURE iop$device_io (pva: ^cell;
        length: ost$byte_count;
        io_function: iot$io_function;
        device_address: dmt$ms_logical_device_address;
        completion: ^iot$completion_status;
    VAR status: syt$monitor_status);

    VAR
      osv$page_size: [XREF] ost$page_size,
      initial_request_info: [STATIC] iot$request_info := [0, 0, 0, 0,
        ioc$read_mass_storage, ioc$device_io, [0, 0], [0, gfc$tr_job, 0],
        0, FALSE, NIL, NIL, 0, 0, 0, 0, [FALSE, ioc$read_page, [0, 0], 0]],
      buffer_descriptor: mmt$buffer_descriptor,
      request_info: iot$request_info,
      p_status: syt$monitor_status,
      d_status: syt$monitor_status;

    status.normal := TRUE;

    request_info := initial_request_info;

{Translate pva to sva.}
    IF length <> 0 THEN
      mmp$xtask_pva_to_sva (pva, buffer_descriptor.sva, p_status);
      IF p_status.normal = FALSE THEN
        status := p_status;
        RETURN;
      IFEND;


      request_info.byte_address := buffer_descriptor.sva.offset;
      buffer_descriptor.page_count := ((request_info.byte_address + length +
            ((osv$page_size * 2) - 1)) DIV osv$page_size) - ((request_info.
            byte_address + osv$page_size) DIV osv$page_size);
    ELSE
      request_info.byte_address := 0;
    IFEND;

    buffer_descriptor.buffer_descriptor_type := mmc$bd_paging_io;

{Calculate physical disk address and queue request.}
    request_info.request_type := ioc$device_io;
    request_info.completion := completion;
    request_info.io_function := io_function;
    iop$disk_request (request_info, buffer_descriptor, length, device_address,
          d_status);
    IF d_status.normal = FALSE THEN
      status := d_status;
      RETURN;
    IFEND;


  PROCEND iop$device_io;
MODEND iom$device_io;
*DECK DECK=IOM$DOWN_DISK_UNIT EXPAND=TRUE
?? RIGHT := 110 ??
MODULE iom$down_disk_unit;

?? PUSH (LISTEXT := ON) ??
*copyc clp$trimmed_string_size
*copyc cmp$change_connection_status
*copyc cmp$locate_element_via_adr
*copyc cmp$reenable_unit
*copyc cmp$switch_to_redundant_path
*copyc cmp$verify_active_path_exists
*copyc dfp$fetch_server_iocb
*copyc dmp$transfer_unit_completed
*copyc dmp$volume_down
*copyc dmp$volume_up
*copyc i#real_memory_address
*copyc dpp$display_error
*copyc dsp$mtr_save_disk_error
*copyc dsp$perform_cpu_pp_handshaking
*copyc iop$check_idle_pps
*copyc iop$idle_resume
*copyc iop$process_disk_response
*copyc mmp$mtr_process_io_completion
*copyc mmp$mtr_process_server_complete
*copyc mmp$process_read_ahead_complete
*copyc mmp$unlock_rma_list
*copyc mtp$cst_p
*copyc mtp$error_stop
*copyc tmp$send_signal

*copyc amt$file_byte_address
*copyc cmt$element_capabilities
*copyc cmt$element_name
*copyc cmt$element_state
*copyc cmt$physical_address
*copyc cmt$physical_equipment_number
*copyc cmt$signal_contents
*copyc cmv$controller_address
*copyc cmv$enable_auto_reconfiguration
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc cmv$peripheral_element_table
*copyc cmv$pp_element_table
*copyc dmt$minimum_allocation_unit
*copyc dmt$ms_logical_device_address
*copyc dmt$system_file_id
*copyc ioe$st_errors
*copyc iot$completion_status
*copyc iot$cylinder
*copyc iot$disk_request
*copyc iot$io_function
*copyc iot$io_request
*copyc iot$lockword
*copyc iot$logical_unit
*copyc iot$pp_interface_table
*copyc iot$pp_number
*copyc iot$pp_table
*copyc iot$request_heap_map
*copyc iot$unit_type
*copyc iov$disk_pp_usage_p
*copyc iov$disk_unit_usage_p
*copyc jmt$ijl_ordinal
*copyc mme$condition_codes
*copyc mmt$io_identifier
*copyc mmt$rma_list
*copyc mtv$time_to_call_handshaking
*copyc oss$mainframe_wired
*copyc ost$cpu_state_table
*copyc ost$physical_channel_number
*copyc syt$monitor_status
*copyc tmv$system_job_monitor_gtid
?? POP ??

  VAR
    iov$debug: [XDCL, #GATE] 0..255 := 0,
    iov$requests_dequeued: [XDCL, STATIC, oss$mainframe_wired] integer := 0,
    iov$unit_not_disabled: [XDCL, STATIC, oss$mainframe_wired] integer := 0,
    iov$no_idle_request: [XDCL, STATIC, oss$mainframe_wired] integer := 0,
    iov$no_resume_request: [XDCL, STATIC, oss$mainframe_wired] integer := 0;


?? TITLE := '  iop$down_disk_unit', EJECT ??

  PROCEDURE [XDCL] iop$down_disk_unit
    (    pp: iot$pp_number;
         channel: cmt$physical_channel;
         equipment: cmt$physical_equipment_number;
         unit: cmt$physical_unit_number;
         logical_unit: iot$logical_unit;
     VAR status: syt$monitor_status);

    VAR
      active_controller_path_exists: boolean,
      active_unit_path_exists: boolean,
      controller_path: cmt$physical_address,
      element_p: ^cmt$peripheral_element_entry,
      number_of_units: iot$logical_unit,
      signal_contents: cmt$signal_contents,
      successful: boolean,
      unit_element_p: ^cmt$peripheral_element_entry,
      unit_list_p: ^array [1 .. * ] of iot$logical_unit,
      unit_path: cmt$physical_address;

    status.normal := TRUE;

    controller_path.address_specifier := $cmt$physical_address_specifier [cmc$iou, cmc$channel,
          cmc$channel_address];
    controller_path.iou := cmv$logical_pp_table_p^ [pp].pp_info.channel.iou_number;
    controller_path.channel := channel;
    controller_path.channel_address := equipment;
    controller_path.unit_address := 0;

    unit_path := controller_path;
    unit_path.address_specifier := $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address,
          cmc$unit_address];
    unit_path.unit_address := unit;


  /locate_redundant_path/
    BEGIN
      cmp$change_connection_status (unit_path, cmc$disabled);
      IF NOT cmv$enable_auto_reconfiguration THEN
        EXIT /locate_redundant_path/;
      IFEND;

      cmp$verify_active_path_exists (unit_path, active_unit_path_exists);
      cmp$verify_active_path_exists (controller_path, active_controller_path_exists);

      IF NOT active_controller_path_exists THEN
        signal_contents.signal_type := cmc$disable_element_signal;
        signal_contents.disable_element_address := controller_path;
        signal_contents.fill3 := ' ';

        send_cm_signal (signal_contents);

        {
        { Even though this controller has no active paths the unit may have
        { other controllers connected to it, so attempt reconfiguration.
        {
      ELSEIF NOT active_unit_path_exists THEN
        signal_contents.signal_type := cmc$disable_element_signal;
        signal_contents.disable_element_address := unit_path;
        signal_contents.fill3 := ' ';

        send_cm_signal (signal_contents);

        {
        { If the unit has no active paths, do not attempt reconfiguration.
        {
        EXIT /locate_redundant_path/;
      IFEND;

      cmp$switch_to_redundant_path (pp, unit_path, successful);
      IF successful THEN
        signal_contents.signal_type := cmc$reconfiguration_signal;
        signal_contents.reconfig_element_address := unit_path;
        signal_contents.failing_element_address := unit_path;
        signal_contents.fill1 := ' ';

        send_cm_signal (signal_contents);
        dpp$display_error ('Successfully reconfigured to redundant_access.');
        {
        {If reconfiguration is successful exit without disabling any units.
        {
        RETURN;
      IFEND;

    END /locate_redundant_path/;

    number_of_units := 1;
    PUSH unit_list_p: [1 .. 1];
    unit_list_p^ [1] := logical_unit;
    auto_disable (pp, unit_list_p, number_of_units, status);

  PROCEND iop$down_disk_unit;

?? TITLE := '  iop$down_disk_controller', EJECT ??

  PROCEDURE [XDCL] iop$down_disk_controller
    (    pp: iot$pp_number;
         channel: cmt$physical_channel;
         equipment: cmt$physical_equipment_number;
     VAR status: syt$monitor_status);

    VAR
      controller_path: cmt$physical_address,
      local_status: syt$monitor_status,
      nu: iot$logical_unit,
      number_of_units: iot$logical_unit,
      path: cmt$physical_address,
      signal_contents: cmt$signal_contents,
      successful: boolean,
      unit_list_p: ^array [1 .. * ] of iot$logical_unit;

    status.normal := TRUE;

    controller_path.address_specifier := $cmt$physical_address_specifier [cmc$iou, cmc$channel,
          cmc$channel_address];
    controller_path.iou := cmv$logical_pp_table_p^ [pp].pp_info.channel.iou_number;
    controller_path.channel := channel;
    controller_path.channel_address := equipment;
    controller_path.unit_address := 0;

  /locate_redundant_path/
    BEGIN
      cmp$change_connection_status (controller_path, cmc$disabled);
      IF NOT cmv$enable_auto_reconfiguration THEN
        EXIT /locate_redundant_path/;
      IFEND;

      cmp$switch_to_redundant_path (pp, controller_path, successful);
      IF successful THEN
        signal_contents.signal_type := cmc$reconfiguration_signal;
        signal_contents.reconfig_element_address := controller_path;
        signal_contents.failing_element_address := controller_path;
        signal_contents.fill1 := ' ';

        send_cm_signal (signal_contents);
        dpp$display_error ('Successfully reconfigured to redundant_access.');
        {
        {If reconfiguration is successful exit without disabling any units.
        {
        RETURN;
      IFEND;

    END /locate_redundant_path/;

    nu := UPPERBOUND (cmv$logical_unit_table^);
    PUSH unit_list_p: [1 .. nu];
    get_controller_units (pp, channel.number, equipment, unit_list_p, number_of_units);
    auto_disable (pp, unit_list_p, number_of_units, status);
    {
    { By reaching this point in the code we know that reconfiguration
    { has failed and one or more units have been disabled.
    { We will send a disable controller signal to assist analysis.
    {
    signal_contents.signal_type := cmc$disable_element_signal;
    signal_contents.disable_element_address := controller_path;
    signal_contents.fill3 := ' ';

    send_cm_signal (signal_contents);

  PROCEND iop$down_disk_controller;

?? TITLE := '  iop$down_disk_channel', EJECT ??

  PROCEDURE [XDCL] iop$down_disk_channel
    (    pp: iot$pp_number;
         channel: cmt$physical_channel;
     VAR status: syt$monitor_status);

    VAR
      channel_path: cmt$physical_address,
      signal: pmt$signal,
      signal_contents: cmt$signal_contents,
      successful: boolean,
      unit_list_p: ^array [1 .. *] of iot$logical_unit,
      number_of_units: iot$logical_unit,
      nu: iot$logical_unit;

    status.normal := TRUE;

    channel_path.address_specifier := $cmt$physical_address_specifier [cmc$iou, cmc$channel];
    channel_path.iou := cmv$logical_pp_table_p^ [pp].pp_info.channel.iou_number;
    channel_path.channel := channel;
    channel_path.channel_address := 0;
    channel_path.unit_address := 0;

  /locate_redundant_path/
    BEGIN
      cmp$change_connection_status (channel_path, cmc$disabled);
      IF NOT cmv$enable_auto_reconfiguration THEN
        EXIT /locate_redundant_path/;
      IFEND;

      cmp$switch_to_redundant_path (pp, channel_path, successful);
      IF successful THEN
        signal_contents.signal_type := cmc$reconfiguration_signal;
        signal_contents.reconfig_element_address := channel_path;
        signal_contents.failing_element_address := channel_path;
        signal_contents.fill1 := ' ';

        send_cm_signal (signal_contents);
        dpp$display_error ('Successfully reconfigured to redundant_access.');
        {
        {If reconfiguration is successful exit without disabling any units.
        {
        RETURN;
      IFEND;
    END /locate_redundant_path/;


    nu := UPPERBOUND (cmv$logical_unit_table^);
    PUSH unit_list_p: [1 .. nu];
    get_channel_units (pp, channel.number, unit_list_p, number_of_units);
    auto_disable (pp, unit_list_p, number_of_units, status);
    {
    { By reaching this point in the code we know that reconfiguration
    { has failed and one or more units have been disabled.
    { We will send a disable channel signal to assist analysis.
    {
    signal_contents.signal_type := cmc$disable_element_signal;
    signal_contents.disable_element_address := channel_path;
    signal_contents.fill3 := ' ';

    send_cm_signal (signal_contents);

  PROCEND iop$down_disk_channel;

?? TITLE := '  iop$change_disk_unit', EJECT ??

  PROCEDURE [XDCL] iop$change_disk_unit
     (   new_state: cmt$element_state;
         logical_unit: iot$logical_unit;
     VAR status: syt$monitor_status);

  VAR
      unit_list_p: ^array [1 .. *] of iot$logical_unit,
      number_of_units: iot$logical_unit,
      pp_list_p: ^array [1 .. *] of iot$pp_number,
      np: iot$pp_number,
      msg: string (63),
      number_of_pps: iot$pp_number;



    status.normal := TRUE;

    msg := 'IOP$CHANGE_DISK_UNIT';
{   dpp$display_error (msg);


    number_of_units := 1;
    PUSH unit_list_p: [1 .. 1];
    np := UPPERBOUND (cmv$logical_pp_table_p^);
    PUSH pp_list_p: [1 .. np];

    unit_list_p^ [1] := logical_unit;

    get_pps_to_units (unit_list_p, number_of_units, pp_list_p, number_of_pps);

    enable_disable (pp_list_p, number_of_pps, unit_list_p,
          number_of_units, status);

    IF ((NOT status.normal) AND (status.condition = ioc$critical_device_disabled)) THEN
      RETURN;
    IFEND;

    IF new_state = cmc$down THEN

      cmv$logical_unit_table^ [logical_unit].element_capability :=
            $cmt$element_capabilities [cmc$concurrent_maintenance, cmc$dedicated_maintenance];
    ELSEIF new_state = cmc$off THEN

      cmv$logical_unit_table^ [logical_unit].element_capability :=
            $cmt$element_capabilities [ ];
      cmv$logical_unit_table^ [logical_unit].element_access :=
            $cmt$element_access [ ];

    IFEND;



  PROCEND iop$change_disk_unit;

?? TITLE := '  iop$change_disk_controller', EJECT ??

  PROCEDURE [XDCL] iop$change_disk_controller
    (    new_state: cmt$element_state;
         pp: 1 .. ioc$pp_count;
         channel: ost$physical_channel_number;
         controller: cmt$physical_equipment_number;
     VAR status: syt$monitor_status);

    VAR
      unit_list_p: ^array [1 .. *] of iot$logical_unit,
      number_of_units: iot$logical_unit,
      nu: iot$logical_unit,
      pp_list_p: ^array [1 .. *] of iot$pp_number,
      np: iot$pp_number,
      msg: string (63),
      number_of_pps: iot$pp_number;



    status.normal := TRUE;

    msg := 'IOP$CHANGE_DISK_CONTROLLER';
{   dpp$display_error (msg);


    nu := UPPERBOUND (cmv$logical_unit_table^);
    PUSH unit_list_p: [1 .. nu];
    np := UPPERBOUND (cmv$logical_pp_table_p^);
    PUSH pp_list_p: [1 .. np];

    get_controller_units (pp, channel, controller, unit_list_p, number_of_units);

    get_pps_to_units (unit_list_p, number_of_units,
          pp_list_p, number_of_pps);

    enable_disable (pp_list_p, number_of_pps, unit_list_p,
          number_of_units, status);

  PROCEND iop$change_disk_controller;

?? TITLE := '  iop$change_disk_channel', EJECT ??

  PROCEDURE [XDCL] iop$change_disk_channel
    (    new_state: cmt$element_state;
         pp: 1 .. ioc$pp_count;
         channel: ost$physical_channel_number;
     VAR status: syt$monitor_status);

    VAR
      unit_list_p: ^array [1 .. *] of iot$logical_unit,
      number_of_units: iot$logical_unit,
      nu: iot$logical_unit,
      pp_list_p: ^array [1 .. *] of iot$pp_number,
      msg: string (63),
      number_of_pps: iot$pp_number;

    status.normal := TRUE;

    msg := 'IOP$CHANGE_DISK_CHANNEL';
{   dpp$display_error (msg);

    nu := UPPERBOUND (cmv$logical_unit_table^);
    PUSH unit_list_p: [1 .. nu];
    number_of_pps := 1;
    PUSH pp_list_p: [1 .. number_of_pps];

    get_channel_units (pp, channel, unit_list_p, number_of_units);

    pp_list_p^ [number_of_pps] := pp;

    IF iov$debug = 01(16) THEN
      mtp$error_stop (' Debug stop 01(16) in iop$change_disk_channel');
    IFEND;

    enable_disable (pp_list_p, number_of_pps, unit_list_p,
          number_of_units, status);

  PROCEND iop$change_disk_channel;

?? TITLE := '  iop$enable_all_disk_units', EJECT ??

  PROCEDURE [XDCL] iop$enable_all_disk_units
    (VAR status: syt$monitor_status);

    VAR
      unit_interface_table: ^iot$unit_interface_table,
      pp: iot$pp_number,
      p: iot$pp_number,
      ud: integer,
      logical_unit: iot$logical_unit,
      lu: iot$logical_unit,
      i: integer,
      eu: integer,
      meu: integer,
      l: integer,
      u: integer,
      mep: integer,
      rr: integer,
      ep: integer,
      ed: integer,
      enable_disable_list_p: ^array [1 .. *] of iot$logical_unit,
      enable_unit_list_p: ^array [1 .. *] of iot$logical_unit,
      maybe_enable_unit_list_p: ^array [1 .. *] of iot$logical_unit,
      nu: iot$logical_unit,
      np: iot$pp_number,
      pp_list2_p: ^array [1 .. *] of iot$pp_number,
      maybe_enable_pp_p: ^array [1 .. *] of iot$pp_number,
      enable_pp_list_p: ^array [1 .. *] of iot$pp_number,
      npp: iot$pp_number,
      enabled_path: boolean,
      disabled_pp_path: boolean,
      enabled_unit: boolean,
      path: cmt$physical_address;



    status.normal := TRUE;

    IF cmv$logical_unit_table = NIL THEN
      RETURN;
    IFEND;

    eu := 0;
    meu := 0;
    mep := 0;
    ep := 0;
    ed := 0;

    nu := UPPERBOUND (cmv$logical_unit_table^);
    PUSH enable_disable_list_p: [1 .. nu];
    PUSH enable_unit_list_p: [1 .. nu];
    PUSH maybe_enable_unit_list_p: [1 .. nu];
    np := UPPERBOUND (cmv$logical_pp_table_p^);
    PUSH pp_list2_p: [1 .. np];
    PUSH maybe_enable_pp_p: [1 .. np];
    PUSH enable_pp_list_p: [1 .. np];


{ Get list of units to possibly enable.

    FOR i := 1 TO UPPERBOUND (cmv$logical_unit_table^)  DO
      IF cmv$logical_unit_table^ [i].configured THEN
        unit_interface_table := cmv$logical_unit_table^ [i].unit_interface_table;
        IF unit_interface_table <> NIL THEN
          IF (unit_interface_table^.unit_type >= ioc$lowest_disk_unit) AND
                (unit_interface_table^.unit_type <= ioc$highest_disk_unit) THEN
            lu := unit_interface_table^.logical_unit;
            IF ( NOT (cmc$io_request_submission IN cmv$logical_unit_table^
                  [lu].element_capability) OR
                  unit_interface_table^.unit_status.disabled) THEN
              ed := ed + 1;
              enable_disable_list_p^ [ed] := i;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    FOREND;


{ Determine which units to enable.

    IF ed > 0 THEN
      get_pps_to_units (enable_disable_list_p, ed, pp_list2_p, npp);
    /check2/
      FOR lu := 1 TO ed DO
        logical_unit := enable_disable_list_p^ [lu];
        enabled_path := FALSE;
        disabled_pp_path := FALSE;
        rr := mep;

        IF npp > 0 THEN
        /pp_check/
          FOR p := 1 TO npp DO
            pp := pp_list2_p^ [p];

          /units/
            FOR ud := LOWERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
                  pp_interface_table_p^.unit_descriptors)
                  TO UPPERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
                  pp_interface_table_p^.unit_descriptors) DO
              IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                    unit_descriptors [ud].unit_interface_table_rma <> 0) THEN
                IF cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                      unit_descriptors [ud].logical_unit = logical_unit THEN
                  get_path (pp, ud, path);
                  IF NOT cmv$logical_pp_table_p^ [pp].flags.disabled THEN
                    IF NOT (cmp$reenable_unit (path)) THEN
                      CYCLE /check2/;
                    ELSE
                      enabled_path := TRUE;
                    IFEND;
                  ELSEIF (cmp$reenable_unit (path)) THEN
                    disabled_pp_path := TRUE;
                    IF rr > 0 THEN
                      FOR i := 1 TO rr DO
                        IF (maybe_enable_pp_p^ [i] = pp) THEN
                          CYCLE /units/;
                        IFEND;
                      FOREND;
                    IFEND;
                    rr := rr + 1;
                    maybe_enable_pp_p^ [rr] := pp;
                  IFEND;
                IFEND;
              IFEND;
            FOREND /units/;
          FOREND /pp_check/;
        IFEND;

        IF enabled_path THEN
          eu := eu + 1;
          enable_unit_list_p^ [eu] := logical_unit;
          mep := rr;
        ELSEIF disabled_pp_path THEN
          meu := meu + 1;
          maybe_enable_unit_list_p^ [meu] := logical_unit;
          mep := rr;
        IFEND;
      FOREND /check2/;
    IFEND;


{ Enable units.

    IF eu > 0 THEN
      enable_units (enable_unit_list_p, eu, status);
    IFEND;


{ Determine if any PP should be enabled.

    IF mep > 0 THEN
    /enable_pp/
      FOR p := 1 TO mep DO
        pp := maybe_enable_pp_p^ [p];
        enabled_unit := FALSE;

      /unit_search/
        FOR ud := LOWERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
              pp_interface_table_p^.unit_descriptors)
              TO UPPERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
              pp_interface_table_p^.unit_descriptors) DO
          IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                unit_descriptors [ud].unit_interface_table_rma <> 0) THEN

            get_path (pp, ud, path);
            IF meu > 0 THEN
              FOR u := 1 TO meu DO
                IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                      unit_descriptors [ud].logical_unit = maybe_enable_unit_list_p^ [u]) THEN
                  IF (cmp$reenable_unit (path)) THEN
                    enabled_unit := TRUE;
                    CYCLE /unit_search/;
                  ELSE
                    CYCLE /enable_pp/;
                  IFEND;
                IFEND;
              FOREND;
            IFEND;
            IF NOT cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                  unit_descriptors [ud].unit_interface_table^.unit_status.
                  disabled THEN
              IF NOT (cmp$reenable_unit (path)) THEN
                CYCLE /enable_pp/;
              ELSE
                enabled_unit := TRUE;
              IFEND;
            IFEND;
          IFEND;
        FOREND /unit_search/;

        IF enabled_unit THEN
          ep := ep + 1;
          enable_pp_list_p^ [ep] := pp;


{ Enable units.

          eu := 0;
          IF meu > 0 THEN
            FOR u := 1 TO meu DO
              FOR ud := LOWERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
                    pp_interface_table_p^.unit_descriptors)
                    TO UPPERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
                    pp_interface_table_p^.unit_descriptors) DO
                IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                      unit_descriptors [ud].unit_interface_table_rma <> 0) THEN
                  IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                        unit_descriptors [ud].logical_unit = maybe_enable_unit_list_p^ [u]) THEN
                    get_path (pp, ud, path);
                    IF (cmp$reenable_unit (path)) THEN
                      eu := eu + 1;
                      enable_unit_list_p^ [eu] := maybe_enable_unit_list_p^ [u];
                      maybe_enable_unit_list_p^ [u] := 0;
                    IFEND;
                  IFEND;
                IFEND;
              FOREND;
            FOREND;
          IFEND;
          IF eu > 0 THEN
            enable_units (enable_unit_list_p, eu, status);
          IFEND;
        IFEND;
      FOREND /enable_pp/;
    IFEND;


{ Enable_pps.

    IF ep > 0 THEN
      enable_pps (enable_pp_list_p, ep);
    IFEND;


{ Check for other disabled disk pps.

  /find_pps/
    FOR pp := 1 TO UPPERBOUND (cmv$logical_pp_table_p^) DO
      IF cmv$logical_pp_table_p^ [pp].flags.configured AND
            cmv$logical_pp_table_p^ [pp].flags.pp_loaded AND
            cmv$logical_pp_table_p^ [pp].flags.disabled AND
            (cmv$logical_pp_table_p^ [pp].pp_info.pp_type = cmc$lpt_disk_pp_type) THEN
        IF (cmv$logical_pp_table_p^ [pp].pp_info.logical_partner_pp_index > 0) AND
              cmv$logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.slave THEN
          CYCLE /find_pps/;
        IFEND;

        enabled_unit := FALSE;

        FOR ud := LOWERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
              pp_interface_table_p^.unit_descriptors)
              TO UPPERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
              pp_interface_table_p^.unit_descriptors) DO
          IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                unit_descriptors [ud].unit_interface_table_rma <> 0) THEN
            unit_interface_table := cmv$logical_pp_table_p^ [pp].pp_info.
                  pp_interface_table_p^.unit_descriptors [ud].unit_interface_table;
            IF unit_interface_table <> NIL THEN
              IF (cmv$logical_pp_table_p^ [pp].handlers.response_handler_p <>
                    ^iop$process_disk_response) THEN
                CYCLE /find_pps/;
              IFEND;

              get_path (pp, ud, path);
              IF NOT cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                    unit_descriptors [ud].unit_interface_table^.unit_status.
                    disabled THEN
                IF NOT (cmp$reenable_unit (path)) THEN
                  CYCLE /find_pps/;
                ELSE
                  enabled_unit := TRUE;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        FOREND;

        IF enabled_unit THEN
          ep := 1;
          enable_pp_list_p^ [ep] := pp;
          enable_pps (enable_pp_list_p, ep);
        IFEND;
      IFEND;
    FOREND /find_pps/;



  PROCEND iop$enable_all_disk_units;

?? TITLE := '  get_controller_units', EJECT ??

  PROCEDURE get_controller_units
    (    pp: 1 .. ioc$pp_count;
         channel: ost$physical_channel_number;
         controller: cmt$physical_equipment_number;
     VAR unit_list_p: ^array [1 .. *] of iot$logical_unit;
     VAR number_of_units: iot$logical_unit);

    VAR
      ud: iot$logical_unit,
      ppit_p: ^iot$pp_interface_table;

    number_of_units := 0;
    IF NOT cmv$logical_pp_table_p^ [pp].flags.configured THEN
      RETURN;
    IFEND;

    ppit_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;

  /ud_loop/
    FOR ud := LOWERBOUND (ppit_p^.unit_descriptors) TO UPPERBOUND (ppit_p^.unit_descriptors) DO
      IF ppit_p^.unit_descriptors [ud].unit_interface_table = NIL THEN
        CYCLE /ud_loop/;
      IFEND;

      IF ppit_p^.unit_descriptors [ud].unit_interface_table_rma = 0 THEN
        CYCLE /ud_loop/;
      IFEND;

      IF ppit_p^.unit_descriptors [ud].physical_path.channel_number <> channel THEN
        CYCLE /ud_loop/;
      IFEND;

      IF ppit_p^.unit_descriptors [ud].physical_path.controller_number <> controller THEN
        CYCLE /ud_loop/;
      IFEND;

      number_of_units := number_of_units + 1;
      IF number_of_units <= UPPERBOUND(unit_list_p^) THEN
        unit_list_p^[number_of_units] := ppit_p^.unit_descriptors [ud].logical_unit;
      IFEND;
    FOREND /ud_loop/;

  PROCEND get_controller_units;

?? TITLE := '  get_channel_units', EJECT ??

  PROCEDURE get_channel_units
    (    pp: 1 .. ioc$pp_count;
         channel: ost$physical_channel_number;
     VAR unit_list_p: ^array [1 .. *] of iot$logical_unit;
     VAR number_of_units: iot$logical_unit);

    VAR
      ud: iot$logical_unit,
      ppit_p: ^iot$pp_interface_table;

    number_of_units := 0;
    IF NOT cmv$logical_pp_table_p^ [pp].flags.configured THEN
      RETURN;
    IFEND;

    ppit_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;

  /ud_loop/
    FOR ud := LOWERBOUND (ppit_p^.unit_descriptors) TO UPPERBOUND (ppit_p^.unit_descriptors) DO
      IF ppit_p^.unit_descriptors [ud].unit_interface_table = NIL THEN
        CYCLE /ud_loop/;
      IFEND;

      IF ppit_p^.unit_descriptors [ud].unit_interface_table_rma = 0 THEN
        CYCLE /ud_loop/;
      IFEND;

      IF ppit_p^.unit_descriptors [ud].physical_path.channel_number <> channel THEN
        CYCLE /ud_loop/;
      IFEND;

      number_of_units := number_of_units + 1;
      IF  number_of_units <= UPPERBOUND(unit_list_p^) THEN
        unit_list_p^[number_of_units] := ppit_p^.unit_descriptors [ud].logical_unit;
      IFEND;
    FOREND /ud_loop/;

  PROCEND get_channel_units;

?? TITLE := '  get_pps_to_units', EJECT ??

  PROCEDURE get_pps_to_units
    (    unit_list_p: ^array [1 .. * ] of iot$logical_unit;
         number_of_units: iot$logical_unit;
     VAR pp_list_p: ^array [1 .. * ] of iot$pp_number;
     VAR number_of_pps: iot$pp_number);

    VAR
      i: integer,
      pp: iot$pp_number,
      ppit_p: ^iot$pp_interface_table,
      ud: iot$logical_unit;

    number_of_pps := 0;
    IF cmv$logical_pp_table_p = NIL THEN
      RETURN;
    IFEND;

    IF number_of_units = 0 THEN
      RETURN;
    IFEND;

  /find_pps/
    FOR pp := LOWERBOUND (cmv$logical_pp_table_p^) TO UPPERBOUND (cmv$logical_pp_table_p^) DO
      IF NOT cmv$logical_pp_table_p^ [pp].flags.configured THEN
        CYCLE /find_pps/;
      IFEND;

      IF NOT cmv$logical_pp_table_p^ [pp].flags.pp_loaded THEN
        CYCLE /find_pps/;
      IFEND;

      IF cmv$logical_pp_table_p^ [pp].pp_info.pp_type <> cmc$lpt_disk_pp_type THEN
        CYCLE /find_pps/;
      IFEND;

      IF cmv$logical_pp_table_p^ [pp].pp_info.logical_partner_pp_index <> 0 THEN
        IF cmv$logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.slave THEN
          CYCLE /find_pps/;
        IFEND;
      IFEND;

      ppit_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;

    /ud_loop/
      FOR ud := LOWERBOUND (ppit_p^.unit_descriptors) TO UPPERBOUND (ppit_p^.unit_descriptors) DO
        IF ppit_p^.unit_descriptors [ud].unit_interface_table = NIL THEN
          CYCLE /ud_loop/;
        IFEND;

        IF ppit_p^.unit_descriptors [ud].unit_interface_table_rma = 0 THEN
          CYCLE /ud_loop/;
        IFEND;

      /unit_loop/
        FOR i := 1 TO number_of_units DO
          IF ppit_p^.unit_descriptors [ud].logical_unit = unit_list_p^ [i] THEN
            number_of_pps := number_of_pps + 1;
            IF number_of_pps <= UPPERBOUND (pp_list_p^) THEN
              pp_list_p^ [number_of_pps] := pp;
            IFEND;
            CYCLE /find_pps/;
          IFEND;
        FOREND /unit_loop/;
      FOREND /ud_loop/;
    FOREND /find_pps/;

  PROCEND get_pps_to_units;

?? TITLE := '  get_pps_to_controller', EJECT ??

  PROCEDURE get_pps_to_controller
    (    p: iot$pp_number;
         channel: ost$physical_channel_number;
         controller: cmt$physical_equipment_number;
     VAR pp_list_p: ^array [1 .. * ] of iot$pp_number;
     VAR number_of_pps: iot$pp_number);

    VAR
      channel_interlock_rma: ost$real_memory_address,
      pp: iot$pp_number,
      ppit_p: ^iot$pp_interface_table,
      ud: integer;

    channel_interlock_rma := cmv$logical_pp_table_p^ [p].pp_info.pp_interface_table_p^.channel_interlock_rma;
    number_of_pps := 0;

    IF cmv$logical_pp_table_p = NIL THEN
      RETURN;
    IFEND;

  /find_pps/
    FOR pp := 1 TO UPPERBOUND (cmv$logical_pp_table_p^) DO
      IF NOT cmv$logical_pp_table_p^ [pp].flags.configured THEN
        CYCLE /find_pps/;
      IFEND;

      IF NOT cmv$logical_pp_table_p^ [pp].flags.pp_loaded THEN
        CYCLE /find_pps/;
      IFEND;

      IF cmv$logical_pp_table_p^ [pp].pp_info.pp_type <> cmc$lpt_disk_pp_type THEN
        CYCLE /find_pps/;
      IFEND;

      IF cmv$logical_pp_table_p^ [pp].pp_info.logical_partner_pp_index <> 0 THEN
        IF cmv$logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.slave THEN
          CYCLE /find_pps/;
        IFEND;
      IFEND;

      ppit_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;

    /ud_loop/
      FOR ud := LOWERBOUND (ppit_p^.unit_descriptors) TO UPPERBOUND (ppit_p^.unit_descriptors) DO
        IF ppit_p^.unit_descriptors [ud].unit_interface_table = NIL THEN
          CYCLE /ud_loop/;
        IFEND;

        IF ppit_p^.unit_descriptors [ud].unit_interface_table_rma = 0 THEN
          CYCLE /ud_loop/;
        IFEND;

        IF ppit_p^.unit_descriptors [ud].physical_path.channel_number <> channel THEN
          CYCLE /ud_loop/;
        IFEND;

        IF ppit_p^.unit_descriptors [ud].physical_path.controller_number <> controller THEN
          CYCLE /ud_loop/;
        IFEND;

        IF ppit_p^.channel_interlock_rma = channel_interlock_rma THEN
          number_of_pps := number_of_pps + 1;
          IF number_of_pps <= UPPERBOUND (pp_list_p^) THEN
            pp_list_p^ [number_of_pps] := pp;
          IFEND;
          CYCLE /find_pps/;
        IFEND;

      FOREND /ud_loop/;
    FOREND /find_pps/;

  PROCEND get_pps_to_controller;

?? TITLE := '  enable_disable', EJECT ??

  PROCEDURE enable_disable
  (   pp_list_p: ^array [1 .. *] of iot$pp_number;
      number_of_pps: iot$pp_number;
      unit_list_p: ^array [1 .. *] of iot$logical_unit;
      number_of_units: iot$logical_unit;
  VAR status: syt$monitor_status);

    VAR
      pp: iot$pp_number,
      p: iot$pp_number,
      ud: integer,
      logical_unit: iot$logical_unit,
      lu: iot$logical_unit,
      number_disabled_pps: iot$pp_number,
      i: integer,
      du: integer,
      eu: integer,
      meu: integer,
      l: integer,
      u: integer,
      mep: integer,
      rr: integer,
      ep: integer,
      ed: integer,
      enable_disable_list_p: ^array [1 .. *] of iot$logical_unit,
      enable_unit_list_p: ^array [1 .. *] of iot$logical_unit,
      disable_unit_list_p: ^array [1 .. *] of iot$logical_unit,
      maybe_enable_unit_list_p: ^array [1 .. *] of iot$logical_unit,
      nu: iot$logical_unit,
      np: iot$pp_number,
      pp_disabled_list_p: ^array [1 .. *] of iot$pp_number,
      pp_list2_p: ^array [1 .. *] of iot$pp_number,
      maybe_enable_pp_p: ^array [1 .. *] of iot$pp_number,
      enable_pp_list_p: ^array [1 .. *] of iot$pp_number,
      npp: iot$pp_number,
      enabled_path: boolean,
      disabled_pp_path: boolean,
      enabled_unit: boolean,
      path: cmt$physical_address;

    status.normal := TRUE;


    du := 0;
    eu := 0;
    meu := 0;
    mep := 0;
    ep := 0;
    ed := 0;

    nu := UPPERBOUND (cmv$logical_unit_table^);
    PUSH enable_disable_list_p: [1 .. nu];
    PUSH enable_unit_list_p: [1 .. nu];
    PUSH disable_unit_list_p: [1 .. nu];
    PUSH maybe_enable_unit_list_p: [1 .. nu];
    np := UPPERBOUND (cmv$logical_pp_table_p^);
    PUSH pp_disabled_list_p: [1 .. np];
    PUSH pp_list2_p: [1 .. np];
    PUSH maybe_enable_pp_p: [1 .. np];
    PUSH enable_pp_list_p: [1 .. np];

    IF iov$debug = 10(16) THEN
      mtp$error_stop (' Debug stop 10(16) in enable_disable');
    IFEND;

{ Determine if PP should be disabled.

    number_disabled_pps := 0;
    IF number_of_pps > 0 THEN
    /disable_pps/
      FOR p := 1 TO number_of_pps DO
        pp := pp_list_p^ [p];
        IF NOT cmv$logical_pp_table_p^ [pp].flags.disabled THEN
          FOR ud := LOWERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
                pp_interface_table_p^.unit_descriptors)
                TO UPPERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
                pp_interface_table_p^.unit_descriptors) DO
            IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                  unit_descriptors [ud].unit_interface_table_rma <> 0) THEN
              get_path (pp, ud, path);

              IF number_of_units > 0 THEN
                FOR u := 1 TO number_of_units DO
                  IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                        unit_descriptors [ud].logical_unit = unit_list_p^ [u]) THEN
                    IF cmp$reenable_unit (path) THEN
                      CYCLE /disable_pps/;
                    IFEND;
                  IFEND;
                FOREND;
              IFEND;

              IF NOT cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                    unit_descriptors [ud].unit_interface_table^.unit_status.
                    disabled THEN
                IF cmp$reenable_unit (path) THEN
                  CYCLE /disable_pps/;
                IFEND;
              IFEND;

            IFEND;
          FOREND;
        ELSE
          CYCLE /disable_pps/;
        IFEND;
        disable_pp (pp);
        number_disabled_pps := number_disabled_pps + 1;
        pp_disabled_list_p^ [number_disabled_pps] := pp;
      FOREND /disable_pps/;
    IFEND;

    IF iov$debug = 11(16) THEN
      mtp$error_stop (' Debug stop 11(16) in enable_disable.');
    IFEND;

{ Get list of units to disable or enable.

    IF number_disabled_pps > 0 THEN
      FOR p := 1 TO number_disabled_pps DO
        pp := pp_disabled_list_p^ [p];
      /unit_list/
        FOR ud := LOWERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
              pp_interface_table_p^.unit_descriptors)
              TO UPPERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
              pp_interface_table_p^.unit_descriptors) DO
          IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                unit_descriptors [ud].unit_interface_table_rma <> 0) THEN
            logical_unit := cmv$logical_pp_table_p^ [pp].pp_info.
                  pp_interface_table_p^.unit_descriptors [ud].logical_unit;
            IF ed > 0 THEN
              FOR lu := 1 TO ed DO
                IF (enable_disable_list_p^ [lu] = logical_unit) THEN
                  CYCLE /unit_list/;
                IFEND;
              FOREND;
            IFEND;
            ed := ed + 1;
            enable_disable_list_p^ [ed] := logical_unit;
          IFEND;
        FOREND /unit_list/;
      FOREND;
    ELSE
      IF number_of_units > 0 THEN
        FOR u := 1 TO number_of_units DO
          ed := ed + 1;
          enable_disable_list_p^ [ed] := unit_list_p^ [u];
        FOREND;
      IFEND;
    IFEND;

    IF iov$debug = 12(16) THEN
      mtp$error_stop (' Debug stop 12(16) in enable_disable.');
    IFEND;

{ Determine which units to disable and enable.

    IF ed > 0 THEN
      get_pps_to_units (enable_disable_list_p, ed, pp_list2_p, npp);
    /check2/
      FOR lu := 1 TO ed DO
        logical_unit := enable_disable_list_p^ [lu];
        enabled_path := FALSE;
        disabled_pp_path := FALSE;
        rr := mep;

        IF npp > 0 THEN
        /pp_check/
          FOR p := 1 TO npp DO
            pp := pp_list2_p^ [p];
            IF number_disabled_pps > 0 THEN
              FOR i := 1 TO number_disabled_pps DO
                IF pp_disabled_list_p^ [i] = pp THEN
                  CYCLE /pp_check/;
                IFEND;
              FOREND;
            IFEND;

          /units/
            FOR ud := LOWERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
                  pp_interface_table_p^.unit_descriptors)
                  TO UPPERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
                  pp_interface_table_p^.unit_descriptors) DO
              IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                    unit_descriptors [ud].unit_interface_table_rma <> 0) THEN
                IF cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                      unit_descriptors [ud].logical_unit = logical_unit THEN
                  get_path (pp, ud, path);
                  IF NOT cmv$logical_pp_table_p^ [pp].flags.disabled THEN
                    IF NOT (cmp$reenable_unit (path)) THEN
                      du := du + 1;
                      disable_unit_list_p^ [du] := logical_unit;
                      CYCLE /check2/;
                    ELSE
                      enabled_path := TRUE;
                    IFEND;
                  ELSEIF (cmp$reenable_unit (path)) THEN
                    disabled_pp_path := TRUE;
                    IF rr > 0 THEN
                      FOR i := 1 TO rr DO
                        IF (maybe_enable_pp_p^ [i] = pp) THEN
                          CYCLE /units/;
                        IFEND;
                      FOREND;
                    IFEND;
                    rr := rr + 1;
                    maybe_enable_pp_p^ [rr] := pp;
                  IFEND;
                IFEND;
              IFEND;
            FOREND /units/;
          FOREND /pp_check/;
        IFEND;

        IF enabled_path THEN
          eu := eu + 1;
          enable_unit_list_p^ [eu] := logical_unit;
          mep := rr;
        ELSEIF disabled_pp_path THEN
          meu := meu + 1;
          maybe_enable_unit_list_p^ [meu] := logical_unit;
          mep := rr;
        ELSE
          du := du + 1;
          disable_unit_list_p^ [du] := logical_unit;
        IFEND;
      FOREND /check2/;
    IFEND;

    IF iov$debug = 13(16) THEN
      mtp$error_stop (' Debug stop 13(16) in enable_disable.');
    IFEND;

{ Disable units.

    IF du > 0 THEN
      disable_units (disable_unit_list_p, du, status);

      IF ((NOT status.normal) AND (status.condition = ioc$critical_device_disabled)) THEN
        RETURN;
      IFEND;

    IFEND;


    IF iov$debug = 14(16) THEN
      mtp$error_stop (' Debug stop 14(16) in enable_disable.');
    IFEND;
{ Enable units.

    IF eu > 0 THEN
      enable_units (enable_unit_list_p, eu, status);
    IFEND;


{ Determine if any PP should be enabled.

    IF mep > 0 THEN
    /enable_pp/
      FOR p := 1 TO mep DO
        pp := maybe_enable_pp_p^ [p];
        enabled_unit := FALSE;

      /unit_search/
        FOR ud := LOWERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
              pp_interface_table_p^.unit_descriptors)
              TO UPPERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
              pp_interface_table_p^.unit_descriptors) DO
          IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                unit_descriptors [ud].unit_interface_table_rma <> 0) THEN

            get_path (pp, ud, path);
            IF meu > 0 THEN
              FOR u := 1 TO meu DO
                IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                      unit_descriptors [ud].logical_unit = maybe_enable_unit_list_p^ [u]) THEN
                  IF (cmp$reenable_unit (path)) THEN
                    enabled_unit := TRUE;
                    CYCLE /unit_search/;
                  ELSE
                    CYCLE /enable_pp/;
                  IFEND;
                IFEND;
              FOREND;
            IFEND;

            IF NOT cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                  unit_descriptors [ud].unit_interface_table^.unit_status.
                  disabled THEN
              IF NOT (cmp$reenable_unit (path)) THEN
                CYCLE /enable_pp/;
              ELSE
                enabled_unit := TRUE;
              IFEND;
            IFEND;
          IFEND;
        FOREND /unit_search/;

        IF enabled_unit THEN
          ep := ep + 1;
          enable_pp_list_p^ [ep] := pp;


{ Enable units.

          eu := 0;
          IF meu > 0 THEN
            FOR u := 1 TO meu DO
              FOR ud := LOWERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
                    pp_interface_table_p^.unit_descriptors)
                    TO UPPERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
                    pp_interface_table_p^.unit_descriptors) DO
                IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                      unit_descriptors [ud].unit_interface_table_rma <> 0) THEN
                  IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                        unit_descriptors [ud].logical_unit = maybe_enable_unit_list_p^ [u]) THEN
                    get_path (pp, ud, path);
                    IF (cmp$reenable_unit (path)) THEN
                      eu := eu + 1;
                      enable_unit_list_p^ [eu] := maybe_enable_unit_list_p^ [u];
                      maybe_enable_unit_list_p^ [u] := 0;
                    IFEND;
                  IFEND;
                IFEND;
              FOREND;
            FOREND;
          IFEND;
          IF eu > 0 THEN
            enable_units (enable_unit_list_p, eu, status);
          IFEND;

        IFEND;

      FOREND /enable_pp/;
    IFEND;

    IF iov$debug = 15(16) THEN
      mtp$error_stop (' Debug stop 15(16) in enable_disable.');
    IFEND;

{ Disable units.

    IF meu > 0 THEN
      du := 0;
      FOR u := 1 TO meu DO
        IF (maybe_enable_unit_list_p^ [u] <> 0) THEN
          du := du + 1;
          disable_unit_list_p^ [du] := maybe_enable_unit_list_p^ [u];
        IFEND;
      FOREND;
      IF du > 0 THEN
        disable_units (disable_unit_list_p, du, status);

        IF ((NOT status.normal) AND (status.condition = ioc$critical_device_disabled)) THEN
          RETURN;
        IFEND;

      IFEND;
    IFEND;

    IF iov$debug = 16(16) THEN
      mtp$error_stop (' Debug stop 16(16) in enable_disable.');
    IFEND;

{ Enable_pps.

    IF ep > 0 THEN
      enable_pps (enable_pp_list_p, ep);
    IFEND;

  PROCEND enable_disable;

?? TITLE := '  auto_disable', EJECT ??

  PROCEDURE auto_disable
  (   pp: 1 .. ioc$pp_count;
      unit_list_p: ^array [1 .. *] of iot$logical_unit;
      number_of_units: iot$logical_unit;
  VAR status: syt$monitor_status);

    VAR
      p: iot$pp_number,
      pp2: iot$pp_number,
      ud: integer,
      logical_unit: iot$logical_unit,
      lu: iot$logical_unit,
      i: integer,
      j: integer,
      du: integer,
      eu: integer,
      l: integer,
      u: integer,
      ed: integer,
      enable_disable_list_p: ^array [1 .. *] of iot$logical_unit,
      enable_unit_list_p: ^array [1 .. *] of iot$logical_unit,
      disable_unit_list_p: ^array [1 .. *] of iot$logical_unit,
      nu: iot$logical_unit,
      np: iot$pp_number,
      pp_list2_p: ^array [1 .. *] of iot$pp_number,
      npp: iot$pp_number,
      enabled_path: boolean,
      pp_disabled: boolean,
      path: cmt$physical_address,
      id_status: syt$monitor_status;



    status.normal := TRUE;


    du := 0;
    eu := 0;
    ed := 0;

    nu := UPPERBOUND (cmv$logical_unit_table^);
    PUSH enable_disable_list_p: [1 .. nu];
    PUSH enable_unit_list_p: [1 .. nu];
    PUSH disable_unit_list_p: [1 .. nu];
    np := UPPERBOUND (cmv$logical_pp_table_p^);
    PUSH pp_list2_p: [1 .. np];


{ Determine if PP should be disabled.

  /disable/
    BEGIN
      pp_disabled := FALSE;
      IF NOT cmv$logical_pp_table_p^ [pp].flags.disabled THEN
      /units/
        FOR ud := LOWERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
              pp_interface_table_p^.unit_descriptors)
              TO UPPERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
              pp_interface_table_p^.unit_descriptors) DO
          IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                unit_descriptors [ud].unit_interface_table_rma <> 0) THEN

            logical_unit := cmv$logical_pp_table_p^ [pp].pp_info.
                  pp_interface_table_p^.unit_descriptors [ud].logical_unit;
            IF number_of_units > 0 THEN
              FOR u := 1 TO number_of_units DO
                IF (logical_unit = unit_list_p^ [u]) THEN
                  CYCLE /units/;
                IFEND;
              FOREND;
            IFEND;

            IF NOT cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                  unit_descriptors [ud].unit_interface_table^.unit_status.
                  disabled THEN
              EXIT /disable/;
            ELSEIF (cmc$io_request_submission IN cmv$logical_unit_table^
                  [logical_unit].element_capability) THEN
              EXIT /disable/;
            IFEND;

          IFEND;
        FOREND /units/;
      ELSE
        pp_disabled := TRUE;
        EXIT /disable/;
      IFEND;
      disable_pp (pp);
      pp_disabled := TRUE;
    END /disable/;


{ Idle all the PPs configured to the units which
{ were disabled.
{
{   get_pps_to_units (unit_list_p, number_of_units, pp_list2_p, npp);
{
{   IF npp > 0 THEN
{     iop$idle_pps_and_wait (pp_list2_p, npp, status);
{
{ Resume the pps.
{
{     FOR j := 1 TO npp DO
{       p := pp_list2_p^ [j];
{       IF NOT cmv$logical_pp_table_p^ [p].flags.disabled THEN
{         iop$idle_resume (p, ioc$ira_resume, id_status);
{         IF NOT id_status.normal THEN
{           iov$no_resume_request := iov$no_resume_request + 1;
{         IFEND;
{       IFEND;
{     FOREND;
{   IFEND;



{ Disable units.

    IF NOT pp_disabled THEN
      IF number_of_units > 0 THEN
        disable_units (unit_list_p, number_of_units, status);
      IFEND;
      RETURN;
    IFEND;


{ Get list of units to disable or enable.

    FOR ud := LOWERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
          pp_interface_table_p^.unit_descriptors)
          TO UPPERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
          pp_interface_table_p^.unit_descriptors) DO
      IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
            unit_descriptors [ud].unit_interface_table_rma <> 0) THEN
        logical_unit := cmv$logical_pp_table_p^ [pp].pp_info.
              pp_interface_table_p^.unit_descriptors [ud].logical_unit;
        ed := ed + 1;
        enable_disable_list_p^ [ed] := logical_unit;
      IFEND;
    FOREND;


{ Determine which units to disable and enable.

    IF ed > 0 THEN
      get_pps_to_units (enable_disable_list_p, ed, pp_list2_p, npp);
    /check2/
      FOR lu := 1 TO ed DO
        logical_unit := enable_disable_list_p^ [lu];
        enabled_path := FALSE;
        FOR p := 1 TO npp DO
          pp2 := pp_list2_p^ [p];
          FOR ud := LOWERBOUND (cmv$logical_pp_table_p^ [pp2].pp_info.
                pp_interface_table_p^.unit_descriptors)
                TO UPPERBOUND (cmv$logical_pp_table_p^ [pp2].pp_info.
                pp_interface_table_p^.unit_descriptors) DO
            IF (cmv$logical_pp_table_p^ [pp2].pp_info.pp_interface_table_p^.
                  unit_descriptors [ud].unit_interface_table_rma <> 0) THEN
              IF cmv$logical_pp_table_p^ [pp2].pp_info.pp_interface_table_p^.
                    unit_descriptors [ud].logical_unit = logical_unit THEN
                get_path (pp2, ud, path);
                IF NOT cmv$logical_pp_table_p^ [pp2].flags.disabled THEN
                  IF NOT (cmp$reenable_unit (path)) THEN
                    du := du + 1;
                    disable_unit_list_p^ [du] := logical_unit;
                    CYCLE /check2/;
                  ELSE
                    enabled_path := TRUE;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          FOREND;
        FOREND;
        IF enabled_path THEN
          eu := eu + 1;
          enable_unit_list_p^ [eu] := logical_unit;
        ELSE
          du := du + 1;
          disable_unit_list_p^ [du] := logical_unit;
        IFEND;
      FOREND /check2/;
    IFEND;


{ Disable units.

    IF du > 0 THEN
      disable_units (disable_unit_list_p, du, status);
    IFEND;


{ Enable units.

    IF eu > 0 THEN
      enable_units (enable_unit_list_p, eu, status);
    IFEND;



  PROCEND auto_disable;

?? TITLE := '  iop$idle_pps_and_wait', EJECT ??

  PROCEDURE [XDCL] iop$idle_pps_and_wait
  (   pp_list_p: ^array [1 .. *] of iot$pp_number;
      number_of_pps: iot$pp_number;
  VAR status: syt$monitor_status);

    VAR
      list_p: ^array [1 .. *] of iot$pp_number,
      j: integer,
      pp: iot$pp_number,
      p: iot$pp_number,
      new_time: integer,
      old_time: integer,
      loop: boolean,
      port: integer,
      msg: string (63),
      message_displayed: boolean,
      cpu_state_table_p: ^ost$cpu_state_table,
      id_status: syt$monitor_status;



    status.normal := TRUE;


    IF number_of_pps = 0 THEN
      RETURN;
    IFEND;

    PUSH list_p: [1 .. number_of_pps];
    list_p^ := pp_list_p^;

    FOR p := 1 TO number_of_pps DO
      pp := list_p^ [p];
      IF NOT cmv$logical_pp_table_p^ [pp].flags.disabled THEN
        iop$idle_resume (pp, ioc$ira_idle, id_status);
        IF NOT id_status.normal THEN
          list_p^ [p] := 0ffff(16);
          iov$no_idle_request := iov$no_idle_request + 1;
        IFEND;
      IFEND;
    FOREND;


{Get time request was queued.}

    port := 0;
    old_time := #free_running_clock (port);

{Wait for pps to reply to idle command.}

    loop := TRUE;
    message_displayed := FALSE;

  /wait_for_reply/
    WHILE loop DO

{ Update the clock.

      mtp$cst_p(cpu_state_table_p);
      cpu_state_table_p^.cpu_alive_flag := #free_running_clock(port);


      iop$check_idle_pps;

      loop := FALSE;
      /check_idle_pps/
        FOR j := 1 TO number_of_pps DO
          p := list_p^ [j];
          IF p <> 0ffff(16) THEN
            IF NOT cmv$logical_pp_table_p^ [p].flags.disabled THEN
              #SPOIL (cmv$logical_pp_table_p^ [p].pp_info.pp_interface_table_p^.
                    idle_status);
              IF NOT cmv$logical_pp_table_p^ [p].pp_info.pp_interface_table_p^.
                       idle_status THEN
                loop := TRUE;
                EXIT /check_idle_pps/;
              IFEND;
            IFEND;
          IFEND;
        FOREND /check_idle_pps/;

      new_time := #free_running_clock (port);

      IF (new_time > (old_time +10000000)) THEN
        IF NOT message_displayed THEN
          msg := 'WAITING FOR PP TO IDLE';
          dpp$display_error (msg);
          message_displayed := TRUE;
        IFEND;
      IFEND;

{ Wait up to 1 minute for the pps to idle.

      IF new_time >= old_time + 60000000 THEN
        loop := FALSE;
        msg := 'LOGICAL PP     DID NOT RESPOND TO IDLE REQUEST';
        iop$ascii_hex (^msg(12,*), 2, p);
        dpp$display_error (msg);
        status.normal := FALSE;
        status.condition := ioc$no_idle_response;
      IFEND;

{ Check if monitor timeout word needs updating.

      IF (mtv$time_to_call_handshaking - #free_running_clock (0)) < 0 THEN
        dsp$perform_cpu_pp_handshaking;
      IFEND;

    WHILEND /wait_for_reply/;

    IF (message_displayed AND status.normal) THEN
      dpp$display_error ('PP responded to idle request.');
    IFEND;



  PROCEND iop$idle_pps_and_wait;

?? TITLE := '  get_path', EJECT ??

  PROCEDURE get_path
    (    pp: iot$pp_number;
         ud: integer;
     VAR path: cmt$physical_address);


    VAR
      msg: string (63),
      unit_type: iot$unit_type,
      iou_number: dst$iou_number;



    iou_number := cmv$logical_pp_table_p^ [pp].pp_info.channel.iou_number;

    unit_type := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
          unit_descriptors [ud].unit_interface_table^.unit_type;
    IF unit_type = ioc$dt_mshydra THEN
      path.address_specifier := $cmt$physical_address_specifier
            [cmc$iou, cmc$channel, cmc$unit_address];
    ELSE
      path.address_specifier := $cmt$physical_address_specifier
            [cmc$iou, cmc$channel, cmc$channel_address, cmc$unit_address];
    IFEND;

    path.iou := iou_number;
    path.channel.number := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
          unit_descriptors [ud].physical_path.channel_number;

    path.channel.concurrent := cmv$logical_pp_table_p^ [pp].pp_info.
          channel_interlock_p^.channel_characteristics [path.channel.number].concurrent_channel;

    path.channel.port := cmc$unspecified_port;
    IF path.channel.concurrent THEN
      IF (unit_type = ioc$dt_mshydra) OR (unit_type = ioc$dt_msxmd_3) OR
           (unit_type = ioc$dt_ms5832_1) OR (unit_type = ioc$dt_ms5832_2) OR
           (unit_type = ioc$dt_ms5833_1) OR (unit_type = ioc$dt_ms5833_1P) OR
           (unit_type = ioc$dt_ms5833_2) OR (unit_type = ioc$dt_ms5833_3P) OR
           (unit_type = ioc$dt_ms5833_4) OR
           (unit_type = ioc$dt_ms5838_1) OR (unit_type = ioc$dt_ms5838_1P) OR
           (unit_type = ioc$dt_ms5838_2) OR (unit_type = ioc$dt_ms5838_3P) OR
           (unit_type = ioc$dt_ms5838_4) OR
           (unit_type = ioc$dt_ms47444_1) OR (unit_type = ioc$dt_ms47444_1P) OR
           (unit_type = ioc$dt_ms47444_2) OR (unit_type = ioc$dt_ms47444_3P) OR
           (unit_type = ioc$dt_ms47444_4) THEN
        IF cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
              unit_descriptors [ud].physical_path.port = 0 THEN
          path.channel.port := cmc$port_a;
        ELSE
          path.channel.port := cmc$port_b;
        IFEND;
      IFEND;
    IFEND;

    path.channel_address := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
          unit_descriptors [ud].physical_path.controller_number;
    path.unit_address := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
          unit_descriptors [ud].physical_path.physical_unit_number;

    IF unit_type = ioc$dt_mshydra THEN
      path.unit_address := path.channel_address;
      path.channel_address := 0;
    IFEND;

    msg := '      PP=    LU=    CH=    PORT         CONTROLLER=    UNIT=  ';
    iop$ascii_hex (^msg(10,*), 2, pp);
    iop$ascii_hex (^msg(17,*), 2, cmv$logical_pp_table_p^ [pp].pp_info.
          pp_interface_table_p^.unit_descriptors [ud].logical_unit);
    iop$ascii_octal (^msg(24,*), 2, path.channel.number);
    iop$ascii_octal (^msg(52,*), 2, path.channel_address);
    iop$ascii_octal (^msg(61,*), 2, path.unit_address);
    IF path.channel.concurrent THEN
      msg (36,3) := 'CIO';
    ELSE
      msg (36,3) := 'NIO';
    IFEND;
    IF path.channel.port = cmc$port_a THEN
      msg (33,1) := 'A';
    ELSEIF path.channel.port = cmc$port_b THEN
      msg (33,1) := 'B';
    ELSE
      msg (33,1) := 'U';
    IFEND;
    IF cmp$reenable_unit (path) THEN
      msg (1,4) := 'ON  ';
    ELSE
      msg (1,4) := 'DOWN';
    IFEND;
{   dpp$display_error (msg);



  PROCEND get_path;

?? TITLE := '  enable_pps', EJECT ??

  PROCEDURE enable_pps
    (    pp_list_p: ^array [1 .. *] of iot$pp_number;
         number_of_pps: iot$pp_number);


    VAR
      pp: iot$pp_number,
      status: syt$monitor_status,
      msg: string (63),
      j: integer;



{ Resume the pps.

      IF number_of_pps > 0 THEN
        FOR j := 1 TO number_of_pps DO
          pp := pp_list_p^ [j];
          IF cmv$logical_pp_table_p^ [pp].flags.disabled THEN
            cmv$logical_pp_table_p^ [pp].flags.disabled := FALSE;
            iop$idle_resume (pp, ioc$ira_resume, status);
            IF NOT status.normal THEN
              iov$no_resume_request := iov$no_resume_request + 1;
            IFEND;
            msg := 'ENABLED  PP     ';
            iop$ascii_hex (^msg(15,*), 2, PP);
{           dpp$display_error (msg);
          IFEND;
        FOREND;
      IFEND;




  PROCEND enable_pps;

?? TITLE := '  disable_pp', EJECT ??

  PROCEDURE disable_pp
    (    pp: iot$pp_number);

    VAR
      pp_list_p: ^array [1 .. *] of iot$pp_number,
      number_of_pps: iot$pp_number,
      msg: string (63),
      status: syt$monitor_status;



    IF NOT cmv$logical_pp_table_p^ [pp].flags.disabled THEN

      number_of_pps := 1;
      PUSH pp_list_p: [1 .. number_of_pps];

      pp_list_p^ [1] := pp;
      iop$idle_pps_and_wait (pp_list_p, number_of_pps, status);

{ Set the pp disabled flag.

      cmv$logical_pp_table_p^ [pp].flags.disabled := TRUE;

      msg := 'DISABLED  PP    ';
      iop$ascii_hex (^msg(15,*), 2, pp);
{     dpp$display_error (msg);

    IFEND;



  PROCEND disable_pp;

?? TITLE := '  enable_units', EJECT ??

  PROCEDURE enable_units
    (    unit_list_p: ^array [1 .. *] of iot$logical_unit;
         number_of_units: iot$logical_unit;
     VAR status: syt$monitor_status);

    VAR
      logical_unit: iot$logical_unit,
      lu: iot$logical_unit,
      pp_interface_table: ^iot$pp_interface_table,
      pp_list_p: ^array [1 .. *] of iot$pp_number,
      pp: 1 .. ioc$pp_count,
      p: 1 .. ioc$pp_count,
      number_of_pp: 1 .. ioc$pp_count,
      npp: iot$pp_number,
      j: iot$pp_number,
      u: integer,
      ud: integer,
      msg: string (63),
      id_status: syt$monitor_status;

    IF iov$debug = 02(16) THEN
      mtp$error_stop (' Debug stop 02(16) in enable_units.');
    IFEND;

    status.normal := TRUE;

{ Idle all the PPs configured to the units which
{ are to be enabled.

    IF cmv$logical_pp_table_p = NIL THEN
      RETURN;
    IFEND;

    IF number_of_units = 0 THEN
      RETURN;
    IFEND;

    number_of_pp := UPPERBOUND (cmv$logical_pp_table_p^);
    PUSH pp_list_p: [1 .. number_of_pp];

    npp := 0;

  /idle_pps/
    FOR pp := 1 TO number_of_pp DO
      IF cmv$logical_pp_table_p^ [pp].flags.configured AND
            cmv$logical_pp_table_p^ [pp].flags.pp_loaded AND
            NOT cmv$logical_pp_table_p^ [pp].flags.disabled AND
            (cmv$logical_pp_table_p^ [pp].pp_info.pp_type = cmc$lpt_disk_pp_type) THEN
        pp_interface_table := cmv$logical_pp_table_p^ [pp].pp_info.
              pp_interface_table_p;
        IF pp_interface_table <> NIL THEN
          IF (cmv$logical_pp_table_p^ [pp].pp_info.logical_partner_pp_index > 0) AND
                cmv$logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.slave THEN
            CYCLE /idle_pps/;
          IFEND;

          FOR ud := LOWERBOUND (pp_interface_table^.unit_descriptors)
                TO UPPERBOUND (pp_interface_table^.unit_descriptors) DO
            IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                  unit_descriptors [ud].unit_interface_table_rma <> 0) THEN
              IF cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                    unit_descriptors [ud].unit_interface_table^.unit_status.
                    disabled THEN
                FOR u := 1 to number_of_units DO
                  IF pp_interface_table^.unit_descriptors [ud].logical_unit =
                        unit_list_p^ [u] THEN
                    npp := npp + 1;
                    pp_list_p^ [npp] := pp;
                  IFEND;
                FOREND;
              IFEND;
            IFEND;
          FOREND;

        IFEND;
      IFEND;
    FOREND /idle_pps/;

    iop$idle_pps_and_wait (pp_list_p, npp, status);


{ Clear the disable bit in the unit interface tables.

    FOR u := 1 to number_of_units DO
      lu := unit_list_p^ [u];
      IF cmv$logical_unit_table^ [lu].unit_interface_table^.
            unit_status.disabled THEN
        cmv$logical_unit_table^ [lu].unit_interface_table^.
              unit_status.disabled := FALSE;
      IFEND;
    FOREND;


{ Resume the pps.

    IF npp > 0 THEN
      FOR j := 1 TO npp DO
        p := pp_list_p^ [j];
        IF NOT cmv$logical_pp_table_p^ [p].flags.disabled THEN
          iop$idle_resume (p, ioc$ira_resume, id_status);
          IF NOT id_status.normal THEN
            iov$no_resume_request := iov$no_resume_request + 1;
          IFEND;
        IFEND;
      FOREND;
    IFEND;


{ Set element capabilities.

    FOR u := 1 to number_of_units DO
      lu := unit_list_p^ [u];
      IF NOT (cmc$io_request_submission IN cmv$logical_unit_table^
            [lu].element_capability) THEN
        cmv$logical_unit_table^ [lu].element_capability := $cmt$element_capabilities
              [cmc$volume_assignment, cmc$file_allocation,
              cmc$io_request_submission, cmc$concurrent_maintenance];
        cmv$logical_unit_table^ [lu].element_access :=
              $cmt$element_access [cmc$read, cmc$write];
        dmp$volume_up (lu);
        msg := 'ENABLED  UNIT   ';
        iop$ascii_hex (^msg(15,*), 2, lu);
 {     dpp$display_error (msg);
      IFEND;
    FOREND;

  PROCEND enable_units;

?? TITLE := '  disable_units', EJECT ??

  PROCEDURE disable_units
    (    unit_list_p: ^array [1 .. *] of iot$logical_unit;
         number_of_units: iot$logical_unit;
     VAR status: syt$monitor_status);

    VAR
      logical_unit: iot$logical_unit,
      lu: iot$logical_unit,
      pp_interface_table: ^iot$pp_interface_table,
      pp_list_p: ^array [1 .. *] of iot$pp_number,
      pp: 1 .. ioc$pp_count,
      p: 1 .. ioc$pp_count,
      number_of_pp: 1 .. ioc$pp_count,
      npp: iot$pp_number,
      j: iot$pp_number,
      u: integer,
      ud: integer,
      new_time: integer,
      msg: string (63),
      id_status: syt$monitor_status;



    status.normal := TRUE;

{ Idle all the PPs configured to the units which
{ are to be disabled.

    IF cmv$logical_pp_table_p = NIL THEN
      RETURN;
    IFEND;

    IF number_of_units = 0 THEN
      RETURN;
    IFEND;

    number_of_pp := UPPERBOUND (cmv$logical_pp_table_p^);
    PUSH pp_list_p: [1 .. number_of_pp];

    npp := 0;

  /idle_pps/
    FOR pp := 1 TO number_of_pp DO
      IF cmv$logical_pp_table_p^ [pp].flags.configured AND
            cmv$logical_pp_table_p^ [pp].flags.pp_loaded AND
            NOT cmv$logical_pp_table_p^ [pp].flags.disabled AND
            (cmv$logical_pp_table_p^ [pp].pp_info.pp_type = cmc$lpt_disk_pp_type) THEN
        pp_interface_table := cmv$logical_pp_table_p^ [pp].pp_info.
              pp_interface_table_p;
        IF pp_interface_table <> NIL THEN
          IF (cmv$logical_pp_table_p^ [pp].pp_info.logical_partner_pp_index > 0) AND
                cmv$logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.slave THEN
            CYCLE /idle_pps/;
          IFEND;

          FOR ud := LOWERBOUND (pp_interface_table^.unit_descriptors)
                TO UPPERBOUND (pp_interface_table^.unit_descriptors) DO
            IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                  unit_descriptors [ud].unit_interface_table_rma <> 0) THEN
              IF NOT cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                    unit_descriptors [ud].unit_interface_table^.unit_status.
                    disabled THEN
                FOR u := 1 to number_of_units DO
                  IF pp_interface_table^.unit_descriptors [ud].logical_unit =
                        unit_list_p^ [u] THEN
                    npp := npp + 1;
                    pp_list_p^ [npp] := pp;
                  IFEND;
                FOREND;
              IFEND;
            IFEND;
          FOREND;

        IFEND;
      IFEND;
    FOREND /idle_pps/;

    iop$idle_pps_and_wait (pp_list_p, npp, status);


{ Set the disable bit in the unit interface tables.

    FOR u := 1 to number_of_units DO
      lu := unit_list_p^ [u];
      IF NOT cmv$logical_unit_table^ [lu].unit_interface_table^.
            unit_status.disabled THEN
        cmv$logical_unit_table^ [lu].unit_interface_table^.
              unit_status.disabled := TRUE;
        msg := 'DISABLED UNIT   ';
        iop$ascii_hex (^msg(15,*), 2, lu);
{       dpp$display_error (msg);
      IFEND;
    FOREND;


{ Resume the pps.

    IF npp > 0 THEN
      FOR j := 1 TO npp DO
        p := pp_list_p^ [j];
        IF NOT cmv$logical_pp_table_p^ [p].flags.disabled THEN
          iop$idle_resume (p, ioc$ira_resume, id_status);
          IF NOT id_status.normal THEN
            iov$no_resume_request := iov$no_resume_request + 1;
          IFEND;
        IFEND;
      FOREND;
    IFEND;


{ Return the requests from the unit queues.

    return_requests (unit_list_p, number_of_units, status);

    IF ((NOT status.normal) AND (status.condition = ioc$critical_device_disabled)) THEN
      RETURN;
    IFEND;

  PROCEND disable_units;

?? TITLE := '  return_requests', EJECT ??

  PROCEDURE return_requests
    (    unit_list_p: ^array [1 .. *] of iot$logical_unit;
         number_of_units: iot$logical_unit;
     VAR status: syt$monitor_status);

  VAR
    logical_unit: iot$logical_unit,
    critical: boolean,
    iov$reject_interlock_set: [XREF] integer,
    iov$request_heap_map: [XREF] iot$request_heap_map,
    iov$command_heap_map: [XREF] iot$command_heap_map,
    iov$stream_requests: [XREF] array [0 .. 300] of ^iot$io_request,
    iov$stream_requests_end: [XREF] array [0 .. 300] of ^^iot$io_request,
    iov$empty_requests: [XREF] ^iot$io_request,
    iov$empty_requests_end: [XREF] ^^iot$io_request,
    iov$empty_request_count: [XREF] integer,
    p_unit_table: ^iot$unit_interface_table,
    initial_lock: [STATIC] iot$lockword := [FALSE, 0, [FALSE, 0, 0]],
    new_lock: [STATIC] iot$lockword := [TRUE, 0, [TRUE, FALSE, 0, 0]],
    new_lock2: [STATIC] iot$lockword := [TRUE, 8000(16), [TRUE, FALSE, 0, 0]],
    actual_lock: iot$lockword,
    result: 0 .. 2,
    i: integer,
    search_test: boolean,
    p_lockword: ^iot$lockword,
    port: integer,
    old_time: integer,
    new_time: integer,
    loop: boolean,
    completed_request_p: ^iot$disk_request,
    next_io_request: ^iot$io_request,
    io_function: iot$io_function,
    list_p: ^mmt$rma_list,
    address_pair_count: mmt$rma_list_length,
    job_id: jmt$ijl_ordinal,
    server_iocb_p: ^mmt$server_iocb_entry,
    system_file_id: dmt$system_file_id,
    byte_address: amt$file_byte_address,
    write_tu_status: dmt$write_tu_status,
    media_error: boolean,
    requested_cylinder: iot$cylinder,
    cylinder: iot$cylinder,
    mau_offset_in_cylinder: dmt$maus_per_position,
    au_was_previously_written: boolean,
    t_status: syt$monitor_status,
    c_status: syt$monitor_status,
    m_status: syt$monitor_status,
    normal: iot$io_error,
    m: 0 .. ioc$command_map_count,
    index: 1 .. ioc$request_heap_count,
    c_index: 1 .. ioc$command_map_count;



    status.normal := TRUE;

  /units/
    FOR i := 1 TO number_of_units  DO
      logical_unit := unit_list_p^ [i];
      p_unit_table := cmv$logical_unit_table^ [logical_unit].
            unit_interface_table;
      IF NOT p_unit_table^.unit_status.disabled THEN
        iov$unit_not_disabled := iov$unit_not_disabled + 1;
        status.normal := FALSE;
        CYCLE /units/;
      IFEND;

      IF (iov$disk_unit_usage_p <> NIL) AND (iov$disk_unit_usage_p^ [logical_unit] <> NIL) THEN
        IF iov$disk_unit_usage_p^ [logical_unit]^.last_request_good THEN
          dsp$mtr_save_disk_error (dsc$ssr_sds_disk_request_bad, #free_running_clock (0),
                iov$disk_unit_usage_p^ [logical_unit]^.element_name);
          iov$disk_unit_usage_p^ [logical_unit]^.last_request_good := FALSE;
        IFEND;
      IFEND;


{Set unit queue lockword.}

      p_lockword := ^p_unit_table^.unit_q_lockword;

      port := 0;
      old_time := #FREE_RUNNING_CLOCK (port);
      loop := TRUE;

    /set_lock/
      WHILE loop DO
        #COMPARE_SWAP (p_lockword^, initial_lock, new_lock, actual_lock, result);
        IF result = 0 THEN
          EXIT /set_lock/;
        IFEND;

        new_time := #FREE_RUNNING_CLOCK (port);
        IF new_time >= old_time + 2000000 THEN
          EXIT /set_lock/;
        IFEND;
      WHILEND /set_lock/;

      IF result <> 0 THEN
        IF iov$reject_interlock_set < 0ffffffffffff(16) THEN
          iov$reject_interlock_set := iov$reject_interlock_set + 1;
        IFEND;
      IFEND;

      next_io_request := p_unit_table^.next_request;

      IF p_unit_table^.queue_count <> 0 THEN
        search_test := TRUE;

      /loop1/
        WHILE search_test DO
          IF next_io_request = NIL THEN
            IF (iov$stream_requests [logical_unit] <> NIL) THEN
              iov$empty_requests_end ^ := iov$stream_requests [logical_unit];
              iov$empty_requests_end := iov$stream_requests_end [logical_unit];
              iov$stream_requests_end [logical_unit] := ^iov$stream_requests [logical_unit];
              iov$stream_requests [logical_unit] := NIL;
            IFEND;
            EXIT /loop1/;
          IFEND;

          completed_request_p := next_io_request^.device_request_p;
          cylinder := 0;
          mau_offset_in_cylinder := 0;
          media_error := FALSE;
          IF (completed_request_p^.request_info.request_type <> ioc$device_io) AND
                (NOT completed_request_p^.request_info.au_was_previously_written) THEN
            normal := ioc$unit_down_on_init;
          ELSE
            normal := ioc$unrecovered_error_unit_down;
          IFEND;
          write_tu_status := dmc$tu_not_written;
          c_status.condition := mme$volume_unavailable;


{Unlock pages.

          IF completed_request_p^.request_info.list_length <> 0 THEN
            io_function := completed_request_p^.request_info.io_function;
            list_p := completed_request_p^.request_info.list_p;
            address_pair_count := completed_request_p^.request_info.list_length;
            mmp$unlock_rma_list (io_function, list_p, address_pair_count,
                  completed_request_p^.request_info.io_identifier,
                  (completed_request_p^.request_info.system_file_id.residence =
                  gfc$tr_job), normal, m_status);
            IF m_status.normal = FALSE THEN
              mtp$error_stop ('IO12 - abnormal unlock status');
            IFEND;

{ It is possible that the job has terminated or the file deleted if this is for a local
{ file write.  We do not need to reset the fau state in dmp$transfer_unit_completed if this
{ is the case.  So, we will lie and say write_tu_status is written.
{ Mmp$unlock_rma_list returns ioc$no_error in normal if it has processed the
{ error.  Errors are not processed if the page is in the free queue (i.e. the job
{ had terminated or the file deleted) and normal will still indicate an error.

            IF (completed_request_p^.request_info.system_file_id.residence = gfc$tr_job) AND
                  ((io_function = ioc$write_page) OR (io_function = ioc$write_locked_page)) AND
                  (normal <> ioc$no_error) THEN
              write_tu_status := dmc$tu_written;
            IFEND;
          IFEND;

{Call mmp$mtr_process_io_completion.

          IF completed_request_p^.request_info.io_identifier.specified THEN
            c_status.normal := normal = ioc$no_error;
            CASE io_function OF
            = ioc$read_for_server..ioc$write_to_client =
              dfp$fetch_server_iocb(completed_request_p^.request_info.io_identifier.queue_entry_location,
                    server_iocb_p);
              mmp$mtr_process_server_complete (dfc$completing_previous_request, completed_request_p^.
                    request_info.io_identifier, server_iocb_p, c_status);
            = ioc$read_ahead_on_server =
              mmp$process_read_ahead_complete (completed_request_p^.request_info.io_identifier, c_status);
            ELSE
                mmp$mtr_process_io_completion (completed_request_p^.request_info.
                      io_identifier,
                completed_request_p^.request_info.io_function, c_status);
            CASEND;
          IFEND;

{check if transfer unit was previously written.}
          IF completed_request_p^.request_info.request_type <> ioc$device_io THEN
            job_id := completed_request_p^.request_info.job_id;
            system_file_id := completed_request_p^.request_info.system_file_id;
            byte_address := completed_request_p^.request_info.byte_address;
            au_was_previously_written := completed_request_p^.request_info.
                  au_was_previously_written;
            dmp$transfer_unit_completed (job_id, system_file_id, byte_address,
                  write_tu_status, au_was_previously_written, media_error,
                  cylinder, mau_offset_in_cylinder, io_function, t_status);
            IF t_status.normal = FALSE THEN
              mtp$error_stop ('IO13 - abnormal dmp status');
            IFEND;

{If ioc$device_io request, return completion status.
          ELSE
            completed_request_p^.request_info.completion^ := 2;
          IFEND;

{Clear request packet allocation.}
          completed_request_p^.link := NIL;
          iov$empty_requests_end ^ := next_io_request;
          iov$empty_requests_end := ^completed_request_p^.link;
          index := completed_request_p^.request_index;
          IF iov$request_heap_map [index] = FALSE THEN
            mtp$error_stop ('IO02 - invalid pp response');
          IFEND;
          iov$request_heap_map [index] := FALSE;
          iov$empty_request_count := iov$empty_request_count + 1;
          IF completed_request_p^.request_info.command_group_count <> 0 THEN
            c_index := completed_request_p^.request_info.command_index;
            FOR m := 0 TO completed_request_p^.request_info.command_group_count -
                  1 DO
              IF iov$command_heap_map [c_index + m] = FALSE THEN
                mtp$error_stop ('IO03 - invalid pp response');
              IFEND;
              iov$command_heap_map [c_index + m] := FALSE;
            FOREND;
          IFEND;

          next_io_request := completed_request_p^.request.next_pp_request;

          IF iov$requests_dequeued < 0ffffffffffff(16) THEN
            iov$requests_dequeued := iov$requests_dequeued + 1;
          IFEND;
        WHILEND /loop1/;

        p_unit_table^.next_request_rma := 0;
        p_unit_table^.next_request := NIL;
        p_unit_table^.queue_count := 0;
      IFEND;

{Clear unit queue lockword.}

      result := 2;
      WHILE result = 2 DO
        #COMPARE_SWAP (p_lockword^, new_lock, initial_lock, actual_lock, result);
      WHILEND;
      IF result <> 0 THEN
        result := 2;
        WHILE result = 2 DO
          #COMPARE_SWAP (p_lockword^, new_lock2, initial_lock, actual_lock,
                result);
        WHILEND;
      IFEND;


{ Change element capabilities.
{ Tell device management.

      IF (cmc$io_request_submission IN cmv$logical_unit_table^
            [logical_unit].element_capability) THEN
        cmv$logical_unit_table^ [logical_unit].element_capability :=
              $cmt$element_capabilities [cmc$concurrent_maintenance];
        dmp$volume_down (logical_unit, critical);

        IF critical THEN

          iop$enable_all_disk_units (status);

          status.normal := FALSE;
          status.condition := ioc$critical_device_disabled;
          RETURN;
        IFEND;

      IFEND;

    FOREND /units/;

  PROCEND return_requests;

?? TITLE := '  iop$ascii_octal', EJECT ??

  PROCEDURE iop$ascii_octal (msg: ^string ( * );
        number_of_characters: 1 .. 6;
        word: 0 .. 0ffff(16));

    VAR
      i: integer,
      k: integer,
      divisor: [STATIC] array [1 .. 6] of integer := [1, 8, 64, 512, 4096,
        32768];


    k := 1;
    FOR i := number_of_characters DOWNTO 1 DO
      msg^ (i) := CHR (((word DIV divisor [k]) MOD 8) + ORD ('0'));
      k := k + 1;
    FOREND;

  PROCEND iop$ascii_octal;

?? TITLE := '  iop$ascii_hex', EJECT ??

  PROCEDURE iop$ascii_hex (msg: ^string ( * );
        number_of_characters: 1 .. 4;
        word: 0 .. 0ffff(16));

    VAR
      i: integer,
      k: integer,
      value: integer,
      divisor: [STATIC] array [1 .. 4] of integer := [1, 16, 256, 4096];


    k := 1;
    FOR i := number_of_characters DOWNTO 1 DO
      value := (word DIV divisor [k]) MOD 16;
      IF value > 9 THEN
        value := value + 7;
      IFEND;
      msg^ (i) := CHR (value + ORD ('0'));
      k := k + 1;
    FOREND;
  PROCEND iop$ascii_hex;

?? TITLE := ' send_cm_signal ', EJECT ??

  PROCEDURE send_cm_signal
    (    signal_contents: cmt$signal_contents);

    VAR
      signal: pmt$signal,
      status: syt$monitor_status;

    signal.identifier := cmc$configuration_signal_id;
    #UNCHECKED_CONVERSION (signal_contents, signal.contents);

    send_reconfiguration_message(signal_contents);
    tmp$send_signal (tmv$system_job_monitor_gtid, signal, status);
    IF NOT status.normal THEN
      dpp$display_error ('Unable to send reconfiguration signal to job monitor task.');
    IFEND;

  PROCEND send_cm_signal;

?? TITLE := ' send_reconfiguration_message ', EJECT ??

  PROCEDURE send_reconfiguration_message
    (    signal_contents: cmt$signal_contents);

    VAR
      controller_address: cmt$physical_address,
      msg: ost$string,
      p_downline_element: ^cmt$peripheral_element_entry,
      p_upline_element: ^cmt$peripheral_element_entry,
      status: syt$monitor_status;

      msg.value(1,18) := 'DISABLED ELEMENT: ';
      msg.size := 19;

      CASE signal_contents.signal_type of
      = cmc$disable_element_signal =
        cmp$locate_element_via_adr(signal_contents.disable_element_address, p_downline_element);
        IF p_downline_element = NIL THEN
          RETURN;
        IFEND;
        msg.value(msg.size,31) := p_downline_element^.element_name;
        msg.size := msg.size + clp$trimmed_string_size(p_downline_element^.element_name);

      = cmc$reconfiguration_signal =
        cmp$locate_element_via_adr(signal_contents.reconfig_element_address, p_downline_element);
        IF p_downline_element = NIL THEN
          RETURN;
        IFEND;

        IF p_downline_element^.physical_descriptor.element_type = cmc$storage_device_element THEN
          controller_address := signal_contents.reconfig_element_address;
          controller_address.address_specifier := cmv$controller_address;
          controller_address.unit_address := 0;

          cmp$locate_element_via_adr(controller_address, p_upline_element);
          IF p_upline_element = NIL THEN
            RETURN;
          IFEND;

          msg.value(1,21) := 'DISABLED CONNECTION: ';
          msg.size := 22;

          msg.value(msg.size,31) := p_upline_element^.element_name;
          msg.size := msg.size + clp$trimmed_string_size(p_upline_element^.element_name);

          msg.value(msg.size,1) := '.';
          msg.size := msg.size + 1;

          msg.value(msg.size,31) := p_downline_element^.element_name;
          msg.size := msg.size + clp$trimmed_string_size(p_downline_element^.element_name);
        ELSE
          msg.value(msg.size,31) := p_downline_element^.element_name;
          msg.size := msg.size + clp$trimmed_string_size(p_downline_element^.element_name);
        IFEND;
      ELSE
      CASEND;

      dpp$display_error (msg.value(1, msg.size-1));

  PROCEND send_reconfiguration_message;

MODEND iom$down_disk_unit;
*DECK DECK=IOM$DSKI EXPAND=TRUE
          IDENT  DSKI
          CIPPU
          MEMSEL 16
          TITLE  DSKI - NOS/VE CM3/9836/9853 DISK DRIVER FOR S0
*
*         WORD 6 OF THE FOLLOWING COMMENT MUST BE A REVISION NUMBER
*         FOR CTI.
*
          COMMENT *SMD* LVL=04
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
*
*         THIS IS THE PP DRIVER FOR THE IPI CHANNEL THAT SUPPORTS THE CM3,
*         THE 9836 DRIVE, AND THE 9853 DRIVE ON A CYBER 930 (S0) SYSTEM.
*         THE PROGRAM NAME IS DSKI AND THE DECK NAME IS IOM$DSKI.  WHEN THE
*         PP DRIVER IS LOADED, LOCATIONS 72 AND 73 MUST CONTAIN THE RMA
*         OF THE PP INTERFACE TABLE AND LOCATION 0 MUST BE THE ADDRESS,
*         MINUS ONE, AT WHICH EXECUTION BEGINS.
*
          LIST   -$
*COPYC IODMAC1
*COPYC IODMAC2
*COPYC IODMAC3
*BEGIN IODMAC4
          SPACE  5,20
*
** NAME-- LMK,LPK,LDK,ADK,ZJK,NJK,PJK,MJK,UJK
*
** PURPOSE-- DETERMINE FOR THOSE INSTRUCTIONS HAVING A SHORT AND LONG
*            FORM WHICH INSTRUCTION FORM NEEDS TO BE GENERATED.
*
** CALLING SEQUENCE-- SAME AS THE REGULAR PP INSTRUCTION
*
** RESTRICTIONS-- SYMBOLS REFERENCED BY THESE MACROS SHOULD BE
*                 DEFINED PRIOR TO THE MACRO CALL.
*
* NO-ADDRESS AND CONSTANT INSTRUCTIONS
NEWOP     ECHO   ,I=(LM,LP,LD,AD)
*
I_K       MACRO  P1
L         IF     DEF,P1
L         IFLE   P1,77B
L         IFGE   P1,0
          I_N    P1
L         ELSE   1
          I_C    P1
          ENDM
NEWOP     ENDD
*
*
*
* JUMP INSTRUCTIONS
NEWOP     ECHO   ,I=(ZJ,NJ,PJ,MJ),J=(NJ,ZJ,MJ,PJ)
*
I_K       MACRO  P1
L         IF     DEF,P1
L         IFGE   *-P1,0
L         IFLT   *-P1,40B
          I_N    P1
L         ELSE   2
          J_N    *+3
          LJM    P1
          ENDM
NEWOP     ENDD
*
*
*
UJK       MACRO  P1
L         IF     DEF,P1
L         IFGE   *-P1,0
L         IFLT   *-P1,40B
          UJN    P1
L         ELSE   1
          LJM    P1
          ENDM
          SPACE  5,20
** NAME-- AJM,SCF,IJM,CCF,FJM,SFM,EJM,CFM,IAN,IAM,OAN,OAM,ACN,DCN
*         FAN,FNC,FSJM,FCJM,IAPM,OAPM,CMCH,CHCM,MCLR
*
** PURPOSE-- REDEFINE I/O INSTRUCTIONS SO THAT THE ADDRESS OF CHANNEL
*            INSTRUCTIONS CAN BE SAVED IN A TABLE.
NEWOP     ECHO   ,OP=(AJM,SCF,IJM,DCN,FJM,SFM,EJM,CFM,IAN,IAM,OAN,OAM,AC
,N,FAN,FNC,FSJM,FCJM,IAPM,OAPM,CCF,CMCH,CHCM,MCLR)
*
 OP_.     OPSYN  OP          E.G.  IAN. = IAN
*
          PURGMAC OP
OP        MACRO  P1,P2
          LOCAL  TAG
L         IFC    EQ,$P2$$
TAG       OP_.   P1
T_P1      RMT                IAN,OAN,ACN,DCN,FAN
          CON    TAG
          RMT
L         ELSE
TAG       OP_.   P1,P2
T_P2      RMT                AJM,IJM,FJM,EJM,IAM,OAM,FCN,IAPM,OAPM,
*                            SCF,CCF,SFM,CFM,FSJM,FCJM,CHCM,CMCH,MCLR
          CON    TAG
          RMT
L         ENDIF
OP        ENDM
NEWOP     ENDD
          SPACE  5,20
** NAME-- LOADC
*
** PURPOSE-- LOAD A CM ADDRESS INTO THE R AND A REGISTERS.
*
** CALLING SEQUENCE-- LOADC   CMR,CMA
*     CMR = ADDRESS OF THE WORD TO BE LOADED INTO THE R REGISTER.
*     CMR+1 = ADDRESS OF WORD TO BE LOADED INTO THE A REGISTER.
*     CMA = ADDRESS OF THE VALUE TO BE ADDED TO THE A REGISTER.
*           (CMA IS OPTIONAL)

 LOADC    MACRO  CMR,CMA
 L        IFLE   CMR,76B
 L        IFGE   CMR,0
          LRDL   CMR
          LDDL   CMR+1
 L        ELSE
          LRML   CMR
          LDML   CMR+1
 L        ENDIF
*
 P        IFC    NE,$CMA$$
 M        IFLE   CMA,77B
 M        IFGE   CMA,0
          ADDL   CMA
 M        ELSE
          ADML   CMA
 M        ENDIF
 P        ENDIF
          ENDM
          SPACE  5,20
** NAME--LOADR
*
** PURPOSE-- LOAD A CM ADDRESS INTO THE R AND A REGISTERS.
*            AN INDEXED MEMORY LOCATION SPECIFIES THE ADDRESS.
*
** CALLING SEQUENCE-- LOADR   CMR,INDEX
*     THE CM ADDRESS IS CONTAINED IN THE LOCATIONS STARTING AT
*         CMR INDEXED BY INDEX.

 LOADR    MACRO  CMR,INDEX
          LRML   CMR,INDEX
          LDML   CMR+1,INDEX
          ENDM
          SPACE  5,20
** NAME--LOADF
*
** PURPOSE-- REFORMAT A CM ADDRESS AND LOAD IT INTO THE R AND A REGISTERS.
*
** CALLING SEQUENCE-- LOADF   CMR,INDEX
*     THE UNFORMATTED CM ADDRESS IS CONTAINED IN THE LOCATIONS
*          STARTING AT CMR INDEXED BY INDEX.
*     INDEX IS OPTIONAL.

 LOADF    MACRO  CMR,INDEX
 N        IFC    NE,$INDEX$$
          LRML   CMR,INDEX
          LDML   CMR+1,INDEX
          SHN    -3
 N        ELSE
 P        IFLE   CMR,76B
 P        IFGE   CMR,0
          LRDL   CMR
          LDDL   CMR+1
 P        ELSE
          LRML   CMR
          LDML   CMR+1
 P        ENDIF
          SHN    -3
 N        ENDIF
          ENDM
          SPACE  5,20
** NAME-- REFAD
*
** PURPOSE-- REFORMAT AND SAVE A CM ADDRESS.
*
** CALLING SEQUENCE-- REFAD   CMR,SAV
*     THE UNFORMATTED CM ADDRESS IS CONTAINED IN THE LOCATIONS
*          STARTING AT CMR.
*     THE REFORMATTED CM ADDRESS IS STORED IN THE LOCATIONS
*          STARTING AT SAV.
*
 REFAD    MACRO  CMR,SAV
 L        IFLE   CMR,76B
 L        IFGE   CMR,0
          LDDL   CMR
 M        IFLE   SAV,76B
 M        IFGE   SAV,0
          STDL   SAV
          LDDL   CMR+1
          SHN    -3
          STDL   SAV+1
 M        ELSE
          STML   SAV
          LDDL   CMR+1
          SHN    -3
          STML   SAV+1
 M        ENDIF
 L        ELSE
          LDML   CMR
 P        IFLE   SAV,76B
 P        IFGE   SAV,0
          STDL   SAV
          LDML   CMR+1
          SHN    -3
          STDL   SAV+1
 P        ELSE
          STML   SAV
          LDML   CMR+1
          SHN    -3
          STML   SAV+1
 P        ENDIF
 L        ENDIF
          ENDM
          SPACE  5,20
 PAUSE    MACRO  X           DELAY X MICROSECONDS
 R        IFLE   X,77B
          LDN    X
 R        ELSE
          LDC    X
 R        ENDIF
          HOLD               WAIT INSTRUCTION
          ENDM
          SPACE  5,20
 MASKP    MACRO  FIELD
          LOCAL  X
 X        SET    16-N.FIELD-L.FIELD
          MGEN   N.FIELD
 MSK      SET    MASK$
          DUP    X
 MSK      SET    MSK+MSK
          ENDD
          ENDM
* END IODMAC4
          LIST   B,L,N,R
          EJECT
*
*         EQUATES FOR IPI ADAPTER
*
 H0029    EQU    0#0029      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H005B    EQU    0#005B      SET SYNC OUT
 H0071    EQU    0#0071      FULL WHEN SLAVE IN IS 0
 H00E1    EQU    0#00E1      READ STATUS REGISTER
 H00F1    EQU    0#00F1      READ ERROR REGISTER
 H0122    EQU    0#0122      IPI BUS A OUTPUT PARITY ERROR
 H0281    EQU    0#0281      STREAM, READ
 H0322    EQU    0#0322      IPI BUS A INPUT PARITY ERROR
 H0381    EQU    0#0381      STREAM, WRITE
 H0711    EQU    0#0711      DROP MASTER OUT
 H0715    EQU    0#0715      REQUEST CLASS 1, 2, OR 3 INTERRUPT
 H0A81    EQU    0#0A81      STREAM, READ, DMA
 H0C22    EQU    0#0C22      ICI OUTPUT PARITY ERROR
 H7E42    EQU    0#7E42      IPI CHANNEL TRANSFER RATE
 H8025    EQU    0#8025      MASTER OUT, FULL WHEN SLAVE IN IS 1
 H8039    EQU    0#8039      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H8215    EQU    0#8215      SET MASTER OUT, LOGICAL INTERFACE RESET
 H8415    EQU    0#8415      SET MASTER OUT, SLAVE RESET
 H9211    EQU    0#9211      DROP SYNC OUT
 H9213    EQU    0#9213      SET SYNC OUT
*
*         MISCELLANEOUS EQUATES
*
 UNIX     EQU    1           = 1, TO ENABLE ONE-WORD RESPONSE AND NEW METHOD OF
                                  RESPONDING TO IDLE AND RESUME REQUESTS, ALSO
                                  RELY TOTALLY ON CONFIDENCE TEST FOR ISOLATION
                                  OF MEDIA ERRORS. (=0 FOR UNIX)
 FE       EQU    0           = 1, TO ENABLE FORCE ERROR CODE
 KH       EQU    0           = 1, TO KEEP HISTORY OF REQUESTS AND RESPONSES
 ERRD     EQU    0           = 1, TO READ UNCORRECTED DATA
 DC       EQU    22B         DISK CHANNEL
 MS50     EQU    53475       50 MILLISECOND TIMEOUT FOR CERTAIN LOOPS
 RRL      EQU    3           REQUEST RETRY LIMIT
 SRT      EQU    120         SLAVE RESET TIMEOUT (SECONDS)
 DST      EQU    480         DRIVE SPINUP TIMEOUT (SECONDS)
 FDT      EQU    9000        FORMAT DRIVE TIMEOUT (SECONDS)
 RLIE     EQU    49*8        RESPONSE LENGTH IF ERROR
 NSBS     EQU    3           NUMBER OF SECTORS TO TRANSFER BEFORE
                              SUSPENDING
 C.CHCNT  EQU    37          NUMBER OF REQUESTS TO PROCESS BEFORE
                              CHANNEL LOCK
 RBPL     EQU    0#14        READ BUFFER PACKET LENGTH
 RPL      EQU    0#10        READ, WRITE COMMAND PACKET LENGTH
 H0200    EQU    0#0200      READ ATTRIBUTES OPERATION CODE
 H0209    EQU    0#0209      LOAD ATTRIBUTES OPERATION CODE
 H020A    EQU    0#020A      SAVE ATTRIBUTES OPERATION CODE
 H0400    EQU    0#0400      RESERVE DRIVE
 H0700    EQU    0#0700      SET OPERATING MODE
 H0800    EQU    0#0800      ABORT OPERATION CODE
 H1005    EQU    0#1005      READ OPERATION CODE
 H1107    EQU    0#1107      READ RAW DATA OPERATION CODE
 H2005    EQU    0#2005      WRITE OPERATION CODE
 H5200    EQU    0#5200      WRITE TO BUFFER OPERATION CODE
 H6200    EQU    0#6200      READ FROM BUFFER OPERATION CODE
 H8100    EQU    0#8100      PERFORM DRIVE DIAGNOSTICS OP CODE
 H8400    EQU    0#8400      READ PERFORMANCE LOG OP CODE
 H0931    EQU    0#0931      COMMAND EXTENT PARAMETER
 BPS      EQU    2048        BYTES PER SECTOR
 WPS      EQU    BPS/8       WORDS PER SECTOR
 ID13     EQU    0#13        MESSAGE/MICROCODE EXCEPTION
 ID14     EQU    0#14        INTERVENTION REQUIRED FOR CONTROLLER
 ID15     EQU    0#15        ALTERNATE PORT EXCEPTION
 ID16     EQU    0#16        MACHINE EXCEPTION FOR CONTROLLER
 ID17     EQU    0#17        COMMAND EXCEPTION FOR CONTROLLER
 ID19     EQU    0#19        CONTROLLER CONDITIONAL SUCCESS
 ID23     EQU    0#23        DRIVE MESSAGE EXCEPTION
 ID24     EQU    0#24        INTERVENTION REQUIRED STATUS
 ID26     EQU    0#26        MACHINE EXCEPTION FOR DRIVE
 ID29     EQU    0#29        DRIVE CONDITIONAL SUCCESS
 ID32     EQU    0#32        FAILING ADDRESS
 ID50     EQU    0#50        HAS MICROCODE REVISION
 ID51     EQU    0#51        HAS SECTOR SIZE

* COMMAND/RESPONSE PACKET EQUATES

 CRN      EQU    1           COMMAND REFERENCE NUMBER
 OPCD     EQU    2           OPERATION CODE FOR CONTROL MODULE
 SLAD     EQU    3           SLAVE ADDRESS, UNIT ADDRESS
 MAJST    EQU    4           MAJOR STATUS
 FCP      EQU    4           FIRST COMMAND PARAMETER

* MAJOR STATUS EQUATES
*         RESPONSE TYPES
 CC       EQU    1           COMMAND COMPLETE RESPONSE
 AR       EQU    4           ASYNCHRONOUS RESPONSE
 TN       EQU    5           TRANSFER NOTIFICATION
 CCS      EQU    0#18        COMMAND COMPLETE, SUCCESSFUL
 IVR      EQU    0#1000      INTERVENTION REQUIRED STATUS
* LEFT SHIFTS FOR MAJOR STATUS
 SC       EQU    14          SUCCESSFUL
 CS       EQU    16          CONDITIONAL SUCCESS
          SPACE  5,20
* BUS CONTROL EQUATES
 CMDOUT   EQU    0           COMMAND, INFORMATION OUT
 RSPIN    EQU    1           RESPONSE, INFORMATION IN
 DATAOUT  EQU    2           DATA OUT
 DATAIN   EQU    3           DATA IN
          SPACE  5,20
* IOU/CM3/DRIVE ERROR CODES
 E00      EQU    0           CP MUST DECODE STATUS IN RESPONSE PACKET
 E01      EQU    1           FUNCTION TIMEOUT
 E02      EQU    2           CHANNEL EMPTY WHEN ACTIVATED
 E03      EQU    3           PERIOD COUNTER PARITY
 E04      EQU    4           UPPER ICI PARITY
 E05      EQU    5           LOWER ICI PARITY
 E06      EQU    6           IOU ERROR
 E20      EQU    20          CANT SELECT CM3
 E21      EQU    21          BIT SIGNIFICANT RESPONSE ERROR
 E22      EQU    22          NO SYNC IN
 E23      EQU    23          SYNC IN DID NOT DROP
 E24      EQU    24          IPI SEQUENCE ERROR
 E25      EQU    25          UPPER IPI CHANNEL PARITY
 E26      EQU    26          LOWER IPI CHANNEL PARITY
 E27      EQU    27          SLAVE IN NOT SET
 E28      EQU    28          SLAVE IN DID NOT DROP
 E29      EQU    29          INCOMPLETE TRANSFER
 E30      EQU    30          CHANNEL STAYED ACTIVE
 E31      EQU    31          BUFFER COUNTER PARITY
 E32      EQU    32          SYNC COUNTER PARITY
 E33      EQU    33          LOST DATA
 E34      EQU    34          BUS PARITY
 E35      EQU    35          COMMAND REJECT
 E36      EQU    36          SYNC OUT NOT EQUAL SYNC INS
 E37      EQU    37          BUS B ACKNOWLEDGE INCORRECT
 E38      EQU    38          NO CM3 INTERRUPT
 E39      EQU    39          ENDING STATUS WRONG
 E50      EQU    50          EXECUTING CONTROLLER DIAGNOSTICS
 E51      EQU    51          CM3 DIAGNOSTICS PASSED
 E52      EQU    52          CM3 DIAGNOSTICS PASSED, LAST ERROR CODE RETURNED
 E57      EQU    57          FORMATTING DRIVE
 E58      EQU    58          FORMAT COMPLETE
 E60      EQU    60          CONTROLLER FAILURE
 E61      EQU    61          DRIVE FAILURE (A,B,C,D)
 E62      EQU    62          MEDIA FAILURE
 E70      EQU    70          INTERNAL CONTROLLER ERROR
 E71      EQU    71          CM3 INTERVENTION REQUIRED
 E72      EQU    72          CM3 MACHINE EXCEPTION
 E73      EQU    73          COMMAND EXCEPTION
 E74      EQU    74          MICROCODE EXECUTION ERROR
 E75      EQU    75          ALTERNATE PORT EXCEPTION
 E76      EQU    76          UNEXPECTED RESPONSE
 E77      EQU    77          DRIVE RESERVED TO OTHER CM3 PORT
 E78      EQU    78          CONTROLLER OVER TEMPERATURE
 E95      EQU    95          NO DRIVE OPERATIONAL RESPONSE
 E110     EQU    110         PP-CM3 DATA INTEGRITY
 E111     EQU    111         CM-DRIVE DATA INTERGRITY
 E120     EQU    120         SOFTWARE FAILURE
 E121     EQU    121         WRONG DRIVE TYPE
 E141     EQU    141         UNIT NOT FORMATTED
          SPACE  5,20
* INTERFACE ERROR CODES.
 E208     EQU    1010B       LOGICAL UNIT OF UNIT DESCRIPTOR NOT
                             IN SEQUENCE OR NOT IN RANGE
 E20B     EQU    1013B       COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS OR NOT LONG ENOUGH
 E304     EQU    1404B       RMA OF NEXT UNIT REQUEST
                             NOT A WORD BOUNDARY
 E306     EQU    1406B       INVALID UNIT TYPE
 E308     EQU    1410B       UNIT COMMUNICATION BUFFER IS TOO SMALL
 E501     EQU    2401B       INVALID COMMAND CODE
 E505     EQU    2405B       INVALID LENGTH SPECIFICATION IN COMMAND
          EJECT
* CONFIGURED UNITS.

 UN       RECORD PACKED

* WORD 1
 CIP      BOOLEAN            AT LEAST ONE COMMAND IN PROGRESS
 TCIP     BOOLEAN            TWO COMMANDS IN PROGRESS
 DTIP     BOOLEAN            DATA TRANSFER IN PROGRESS
 NCR      BOOLEAN            NO CONTROLLER RESPONSE
 RD       BOOLEAN            DRIVE RESERVED
 FILL1    SUBRANGE 0,37B
 CM       SUBRANGE 0,7       CONTROL MODULE NUMBER
 UNIT     SUBRANGE 0,7       UNIT NUMBER
* WORD 2
 SSPTR    PPWORD             POINTER TO RESIDENT SS TABLE. IF ZERO
                             THE TABLE IS IN THE UNIT COMM. BUFFER
* WORD 3
 CLK      PPWORD             SECONDS CLOCK OF LAST ACTIVITY
* WORD 4
 UIT      STRUCT 4           RMA OF UNIT INTERFACE TABLE (REFORMATTED)
          MASKP  NCR
 K.NCR    EQU    MSK
          MASKP  RD
 K.RD     EQU    MSK
 UN       RECEND
          SPACE  5,20
* SS TABLE DEFINITIONS. INFORMATION SAVED FOR EACH UNIT.

 SS       RECORD PACKED

* WORD 1

 MREV     SUBRANGE 0,377B    CM3 MICROCODE REVISION
 FILL1    SUBRANGE 0,3
 DT       SUBRANGE 0,3       DEVICE TYPE, O = 9836, 1 = 9853 2 = EMD5
 CRN      SUBRANGE 0,17B     USED TO MAKE COMMAND REFERENCE NUMBER UNIQUE
*
 CMOD     SUBRANGE 0,377B    CONTROL MODULE NUMBER
 UNIT     SUBRANGE 0,377B    UNIT NUMBER
*
 LU       PPWORD             LOGICAL UNIT
*
 FNC      PPWORD             FUNCTION CODE  READ = 0
                                            WRITE = 1
 REQ      STRUCT 4           CURRENT REQUEST (UNFORMATTED RMA)
 PVA      STRUCT 6           PVA OF CURRENT REQUEST

 LASTC    PPWORD             OFFSET OF COMMAND IN REQUEST
 FRST     PPWORD             = 0, IF FIRST TIME THROUGH UNCMND
 NUMCM    PPWORD             NUMBER OF COMMANDS LEFT TO PROCESS IN
                             THIS REQUEST
 LISTL    PPWORD             NUMBER OF CM WORDS IN ADDRESS-LENGTH PAIR LIST.
                             (INCLUDES THE NUMBER OF WORDS WHICH HAVENT
                             BEEN READ FROM CM.)
 TOTAL    STRUCT 4           TOTAL CM WORDS LEFT TO TRANSFER
 MT       EQU    /SS/P.TOTAL MASTER TERMINATE FLAG
                              8XXX IF MASTER TERMINATE BEING USED
                              XXX IS NONZERO IF TRANSFER HAS BEEN TERMINATED
 FCOMRQ   STRUCT 4           FIRST COMPLETED REQUEST (RMA)
 CURRQ    STRUCT 4           CURRENT REQUEST (RMA)
 PRERQ    STRUCT 4           PREVIOUS REQUEST (RMA)
 NCOMRQ   PPWORD             NUMBER OF COMPLETED REQUESTS
 NCOMW    PPWORD             NUMBER OF COMPLETED WRITE REQUESTS
 CURTRK   PPWORD             CURRENT TRACK
 CURSEC   PPWORD             CURRENT SECTOR
 FPVA     STRUCT 6           PVA OF FIRST COMPLETED REQUEST
 XFER     STRUCT 4           TRANSFER COUNT
 PVA2     STRUCT 6           PVA FOR SECOND COMMAND
 RMA2     STRUCT 4           RMA FOR SECOND COMMAND
 TW2      STRUCT 4           TOTAL CM WORDS TO TRANSFER FOR 2ND COMMAND
 MT2      EQU    /SS/P.TW2   MASTER TERMINATE FLAG FOR 2ND COMMAND
 RQTRY    PPWORD             REQUEST RETRY COUNT
 RESET    PPWORD             RESET ISSUED
                              1 SLAVE ASYNCH EXPECTED
                              2 DRIVE ASYNCH EXPECTED AFTER SLAVE RESET
                              3 BOTH 1 AND 2
 CT       PPWORD             NONZERO WHEN CONFIDENCE TEST IS COMPLETE
                              1 IF NO ERROR
                              2 IF ERROR
                              4 IF DATA INTEGRITY ERROR
 RECOV    PPWORD             NONZERO IF IN RECOVERY
 DP       STRUCT 4           DELINK POINTER (REFORMATTED RMA)

 RQ       STRUCT 40          REQUEST

 CMLIST   STRUCT 8           CURRENT DATA ADDRESS OR CURRENT COMMAND

 SS       RECEND

* ALTERNATE USAGE OF LOCATIONS IN SS TABLE DURING CONFIDENCE TEST
 STT      EQU    /SS/P.PVA2   SECTORS TO TRANSFER
 CTME     EQU    /SS/P.PVA2+1 START OF 3 WORD TABLE WITH EACH WORD
                               CONTAINING THE HEAD AND SECTOR NUMBER OF
                               OF A MEDIA ERROR
          SPACE  6
* PP INTERFACE TABLE
 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
 .U       IFEQ   UNIX,1
 ACTCH    BOOLEAN            ACTIVE CHECK, THE PP CLEARS THIS BIT WITHIN 1 MINUTE
 IDLREQ   BOOLEAN            IDLE REQUEST
 RESREQ   BOOLEAN            RESUME REQUEST
 PPIDLE   BOOLEAN            PP IDLE
          SUBRANGE 0,3777B   UNUSED
 LOCK     BOOLEAN            PP TABLE LOCK
 .U       ELSE
          ALIGN  0,64
 .U       ENDIF
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
 .U       IFEQ   UNIX,1
          STRUCT 24          UNUSED
 .U       ELSE
 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER
          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)
          ALIGN 32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)
 .U       ENDIF
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          SPACE  6
* UNIT DESCRIPTORS.

 UD       RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 UD       RECEND
          SPACE  6
* UNIT INTERFACE TABLE

 UIT      RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
                               = 400B, 844-4X
                               = 401B, 885-1X
                               = 402B, 885-42
 QCNT     PPWORD             QUEUE COUNT
*
 SHARE    BOOLEAN            NONZERO IF THIS UNIT IS BEING SHARED WITH MALET OR DFT
 RONLY    BOOLEAN            NONZERO IF THIS UNIT IS A READ-ONLY DEVICE
          ALIGN  16,64
 UBUFL    PPWORD             UNIT COMMUNICATION BUFFER LENGTH
 UBUF     RMA                UNIT COMMUNICATION BUFFER (RMA)
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

          MASKP  DSABLE
 K.DSABLE EQU    MSK
          MASKP  RONLY
 K.RONLY  EQU    MSK

 UIT      RECEND
          SPACE  6
* PP REQUESTS.

 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (NOT USED)
                               0 - ATTEMPT RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY (NOT USED)
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
          ALIGN  0,64
 SWIT     BOOLEAN            SWITCH TO NEXT REQUEST
          ALIGN  16,64
 CYL      PPWORD             CYLINDER ADDRESS
 TRACK    PPWORD             TRACK ADDRESS
 SECTOR   PPWORD             SECTOR ADDRESS
 CMND     INTEGER            COMMAND SEQUENCE


          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$

 RQ       RECEND
          SPACE  6
* PP COMMAND.

 CM       RECORD PACKED

 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$
          SPACE  5,20
* PP RESPONSE.

 RS       RECORD PACKED

* WORD 1.
 .U       IFEQ   UNIX,1
 FILL1    BOOLEAN
 SHORT    BOOLEAN            IF SET, ONE-WORD RESPONSE
          SUBRANGE 0,77B     UNUSED
          SUBRANGE 0,377B    LOGICAL UNIT (FOR DEBUG)
 .U       ENDIF
          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST

* WORD 2.
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST  (NOT USED)

* WORD 3.
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST) (NOT USED)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)  (NOT USED)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS  (NOT USED)
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY  (NOT USED)
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

* WORD 4.
          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED  (NOT USED)
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE INTERFACE
                             ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
                             (NOT USED)
 CHERR    BOOLEAN            CHANNEL PARITY ERROR (NOT USED)
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION
                             OCCURRED ON INPUT OR INADEQUATE DATA RATE ON OUTPUT
                             (NOT USED)
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT  (NOT USED)
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A
                             HARDWARE MALFUNCTION.  EXAMPLE-UNIT NOT
                             READY, UNIT NOT CONNECTED.  (NOT USED)
 FTO      BOOLEAN            FUNCTION TIMEOUT (NOT USED)
 CHERO    BOOLEAN            CHANNEL OUTPUT PARITY ERROR (NOT USED)
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
                               1 - RECOVERED ERROR
                               2 - COMMAND HAD EXPLICIT RESPONSE FLAG SET
                               3 - BOTH CONDITIONS 1 AND 2
 K.REC    EQU    1           RECOVERED ERROR
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE  (NOT USED)
                               1 - UNIT CHANGED FROM READY TO NOT READY
                               2 - UNIT CHANGED FROM NOT READY TO READY
                               3 - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
                               4 - CONTROLLER RESERVED
                               5 - UNIT RESERVED TO ANOTHER ACCESS
                               6 - RECOVERED ABNORMAL CONDITION
          ALIGN  49,64       ALERT CONDITIONS
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

* WORD 5.
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)(NOT USED)

* WORD 6.
 CHAN     PPWORD             CHANNEL NUMBER
 SCYL     PPWORD             STARTING CYLINDER
 STRK     PPWORD             STARTING TRACK
 SSEC     PPWORD             STARTING SECTOR

* WORD 7.
 UNIT     PPWORD             UNIT NUMBER
 RTRY     PPWORD             REQUEST RETRY COUNT
 FTRK     PPWORD             FAILING TRACK
 FSEC     PPWORD             FAILING SECTOR
* WORD 8
 WC       PPWORD             WORDS NOT TRANSFERRED
 FUNTO    PPWORD             FUNCTION WITH TIMEOUT
 ID       PPWORD             ERROR IDENTIFIER
 K.UDN    EQU    3           UNIT DOWN
 K.CMDN   EQU    2           CONTROL MODULE DOWN
 K.CHDN   EQU    1           CHANNEL DOWN
 ERRID    PPWORD             ERROR IDENTIFIER
* WORD 9
 MREV     PPWORD             CM3 MICROCODE REVISION
 STREG    PPWORD             IPI CHIP STATUS REGISTER
 ERREG    PPWORD             IPI CHIP ERROR REGISTER
 FILL1    PPWORD
* WORD 10
          PPWORD             RESERVED FOR FUTURE USE
          PPWORD             RESERVED FOR FUTURE USE
          PPWORD             RESERVED FOR FUTURE USE
 FILL2    PPWORD

          MASKP  INTERR
 K.INTERR EQU    MSK
          MASKP  DATERR
 K.DATERR EQU    MSK
 .U       IFEQ   UNIX,1
          MASKP  SHORT
 K.SHORT  EQU    MSK
 .U       ENDIF

 RS       RECEND


 CM       RECEND
          SPACE  6
* COMMAND CODES.

 C.IDLE   EQU    4           IDLE
 C.RESUME EQU    5           RESUME
 C.READ   EQU    100B        READ
 C.WRITE  EQU    120B        WRITE
 C.FORMAT EQU    164B        FORMAT
          SPACE  5,20
* RESPONSE CODES.

 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    1           INTERMEDIATE RESPONSE
 R.NRM    EQU    2           NORMAL REQUEST TERMINATION
 R.ABN    EQU    3           ABNORMAL REQUEST TERMINATION
          SPACE  10
* PP COMMUNICATION BUFFER.

 CB       RECORD PACKED

          ALIGN  31,64
 SLAVE    BOOLEAN            NONZERO IF SLAVE PP
 PARTNR   RMA                PARTNERS COMMUNICATION BUFER (RMA)

 CONTRL   STRUCT 8           LOAD CONTROLWARE COMMAND
 CMCTRL   STRUCT 8           LOAD CONTROLLER CONTROLWARE
          STRUCT 64
 BUF      STRUCT 5240        DATA BUFFER FOR CONFIDENCE TEST
                              BYTES = SECTOR (2048) + 8 TIMES
                              (SECTORS (21) X TRACKS (19))
 CB       RECEND
 RPBL     EQU    512         MAXIMUM LENGTH OF RESPONSE BUFFER
 EOM      EQU    40000B
 RPB      EQU    EOM-RPBL    RESPONSE PACKET BUFFER
 RS       EQU    RPB-P.RS    DISK RESPONSE

 IPIT     EQU    RPB+64      PP INTERFACE TABLE
 UBUF     EQU    IPIT+P.PIT  UNIT INTERFACE TABLE
 IBUF     EQU    UBUF+P.UIT  UNIT DESCRIPTOR BUFFER
 NRQ      EQU    IPIT+P.SS   NEXT REQUEST
          ERRMI  EOM-NRQ+20  IF TABLE OVERFLOWS MEMORY
 RQT      EQU    NRQ+8
          ERRMI  RPBL-P.PIT-P.UIT-8-64 IF TABLES OVERFLOW MEMORY
 OB       EQU    RPB+64      OUTPUT BUFFER FOR PP/CONTROLLER PATH TEST
 IB       EQU    RPB+128     INPUT BUFFER FOR PP/CONTROLLER PATH TEST
 IBN      EQU    IB+50       END OF INPUT BUFFER
          ERRMI  EOM-IBN     IF TABLES OVERFLOW MEMORY
 RQ       EQU    /SS/P.RQ    REQUEST
 CM       EQU    RQ+/RQ/P.CMND  CURRENT COMMAND
 CMLIST   EQU    /SS/P.CMLIST  INDIRECT RMA LIST
          EJECT
          CON    MAIN-1

* DIRECT CELLS

 CM.PIT   BSSZ   2           CM ADDRESS OF PP INTERFACE TABLE
                              WORD 1 IS UPPER 16 BITS OF RMA
                              WORD 2 TIMES 8 IS LOWER RMA
 T1       BSSZ   1
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1

 CHAN     BSSZ   1           CHANNEL NUMBER
 STATUS   BSSZ   1           IPI CHANNEL STATUS
 CMNDS    BSSZ   1           NUMBER OF OUTSTANDING COMMANDS
 CMOD     BSSZ   1           CONTROL MODULE NUMBER
 UX       BSSZ   1           INDEX TO UNITS TABLE
 FI       BSSZ   1           INDEX TO FUNCTION HISTORY BUFFER
 P1       BSSZ   1
 P2       BSSZ   1
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 P6       BSSZ   1
 WC       BSSZ   1           WORD COUNT FOR DATA TRANSFER
 WD       BSSZ   1           WORD COUNT FOR CM TRANSFER

 FNC      BSSZ   1           FUNCTION CODE (INTERNAL)
 LF       BSSZ   1           LAST FUNCTION TO IPI ADAPTER
 CNUM     BSSZ   1           0 IF ONE COMMAND, 1 IF 2 COMMANDS ISSUED TO
                              THE CONTROL MODULE
 WDS      BSSZ   1           NUMBER OF CM WORDS TO TRANSFER FROM CURRENT SECTOR.
 SBS      BSSZ   1           SECTORS TO TRANSFER BEFORE SUSPENDING
 SECPOS   BSSZ   1           SECTOR BUFFER TRANSFER POSITION (TO CM)
 DELAY    BSSZ   1           DELAY BITS FROM ENDING STATUS
 CSST     BSSZ   1           POINTER TO CURRENT SS TABLE
 LUX      BSSZ   1           VALUE OF UNIT INDEX OF LAST UNIT SELECTED
 TOTAL    BSSZ   2           TOTAL BYTES TO TRANSFER
 UNUML    BSSZ   1           LENGTH OF CONFIGURED UNIT ENTRIES
 .U       IFNE   UNIX,1
 IDLE     BSSZ   1           NONZERO IF IDLE COMMAND RECEIVED,
                              RESUME COMMAND RESETS IT TO 0
 .U       ENDIF
 MALET    BSSZ   1           NONZERO IF MAINTENANCE SOFTWARE WANTS
                              THE CHANNEL
 TBC      BSSZ   1           NONZERO IF TRANSFER RESPONSE RECEIVED BEFORE
                              COMPLETION RESPONSE
 CLF      DATA   1           CHANNEL LOCK FLAG, 0 IF LOCK SET
 CTM      BSSZ   1           USED TO CHANGE TRANSFER MODE TO STREAMING
                             FOR COMMAND AND RESPONSE PACKETS
 CLCUR    BSSZ   1           CHANNEL 14 CLOCK CURRENT VALUE
 CLMCS    BSSZ   1           CLOCK, MICROSECOND
 CLMLS    BSSZ   1           CLOCK, MILLISECOND
 CLSEC    BSSZ   1           CLOCK, SECOND
 CTPAT    BSSZ   1           CONFIDENCE TEST PATTERN FIRST WORD
 DT       BSSZ   1           DEVICE TYPE, O = 9836, 1 = 9853 2 = EMD5
 RONLY    BSSZ   1           NONZERO IF A READ-ONLY DEVICE
 .F       IFEQ   FE,1
 FEST     DATA   0           FORCE ERROR START COUNT
 FEND     DATA   0           FORCE ERROR END COUNT
 FEUN     DATA   0           UNIT NUMBER TO FORCE ERROR ON
 .F       ENDIF
 .K       IFEQ   KH,1
 HBP      DATA   0           HISTORY BUFFER POINTER
 .K       ENDIF
          SPACE  2
          BSS    72B-*
 DSRTP    DATA   2,0         RMA OF PP INTERFACE TABLE AT DEADSTART
 INPNT    EQU    DSRTP+1     IN POINTER FOR RESPONSE BUFFER
 LIM      BSSZ   1           LIMIT OF RESPONSE BUFFER (IN 8-BIT BYTES)
 PPNO     CON    1           LOGICAL PP NUMBER
 PTF      BSSZ   1           IF 0 EXECUTE PATH TEST
 IF       BSSZ   1           INITIALIZATION FLAG
          BSS    100B-*
          LJM    MAIN
          DATA   7           IPI/930 DISK DRIVER (FOR ANAD PROC)
 HANG     CON    0           AN EASY WAY TO SEE CERTAIN HANGS
          UJN    *
          SPACE  2
* THE FOLLOWING CM ADDRESSES ARE SET DURING INITIALIZATION
                              WORD 1 IS UPPER 16 BITS OF RMA
                              WORD 2 TIMES 8 IS LOWER RMA

 CM.CB    BSSZ   2           ADDRESS OF BUFFER WITHIN PP COMM. BUFFER
 CM.RS    BSSZ   2           ADDRESS OF RESPONSE BUFFER
 CM.INT   BSSZ   2           ADDRESS OF INTERRUPT WORD
 CM.CHAN  BSSZ   2           ADDRESS OF CHANNEL INTERLOCK TABLE
*
*         LOCATION DT IS THE INDEX TO THIS DRIVE TABLE
*
 CTC      DATA   701         CONFIDENCE TEST CYLINDER, 9836
          DATA   1410        CONFIDENCE TEST CYLINDER, 9853
          DATA   1625        CONFIDENCE TEST CYLINDER, EMD5
 TPC      DATA   24          TRACKS PER CYLINDER, 9836
          DATA   19          TRACKS PER CYLINDER, 9853
          DATA   15          TRACKS PER CYLINDER, EMD5
 SPT      DATA   12          SECTORS PER TRACK, 9836
          DATA   21          SECTORS PER TRACK, 9853
          DATA   21          SECTORS PER TRACK, EMD5
 SPC      CON    24*12       SECTORS PER CYLINDER, 9836
          CON    19*21       SECTORS PER CYLINDER, 9853
          CON    15*21       SECTORS PER CYLINDER, EMD5
 MN       DATA   0#4653      FIRST 2 CHARACTERS OF MODEL NAME -FS -
          DATA   0#584D      FIRST 2 CHARACTERS OF MODEL NAME -XM -
          DATA   0#454D      FIRST 2 CHARACTERS OF MODEL NAME -EM -

 FIP      DATA   0           FORMAT IN PROGRESS FLAG
 .F       IFEQ   FE,1
          BSS    60          FOR PATCHES DURING CHECKOUT
 .F       ENDIF
          TITLE  MAIN LOOP
** NAME-- MAIN
*
** PURPOSE-- MAIN IDLE LOOP.  LOOK FOR REQUESTS FROM CENTRAL MEMORY
*            AND LOOK FOR INTERRUPTS FROM THE CONTROLLERS.
*
** ENTRY
*         MAIN - AFTER DRIVER IS LOADED
*         MAIN5 - WHEN THE PP IS RESUMED
*         MAIN10 - TO RUN DIAGNOSTICS DURING ERROR RECOVERY
*         MAIN15 - AFTER SEEK, WRITE, OR READ COMMAND STARTED
*         MAIN20 - WHEN A WRITE OR READ COMMMAND COMPLETES
          SPACE  2
 MAIN     BSS
          REFAD  DSRTP,CM.PIT REFORMAT ADDRESS OF PP INTERFACE TABLE
                               AND SAVE IN CM.PIT
 MAIN5    BSS
          RJM    INIT        INITIALIZATION
 MAIN10   BSS
          RJM    PT          PATH TEST
 MAIN15   BSS
 .F       IFEQ   FE,1        FORCE ERROR IN RUNNING PP DRIVER
          RJM    FER         FORCE ERROR ROUTINE
 .F       ENDIF
          RJM    EI          ENABLE INTERRUPTS
          RJM    PPRQ        CHECK FOR ANY PP REQUESTS
          RJM    GETUD       SELECT UNIT REQUESTS, SEEK,
                             AND PROCESS INTERRUPTS
          LDDL   CMNDS
          NJK    MAIN15      IF OUTSTANDING COMMANDS
 MAIN20   BSS
          SOML   CHLCNT
          NJN    MAIN15      IF PP DOESN'T HAVE TO GIVE UP CHANNEL
          LDML   FIP
          NJN    MAIN15      IF FORMAT IN PROGRESS
          RJM    CKC         CHECK IF CHANNEL MUST BE GIVEN UP
          UJK    MAIN15
          SPACE  5,12
 UCMD     BSS                COMMANDS FROM CENTRAL MEMORY
          CON    C.READ
          CON    C.WRITE
          CON    C.IDLE
          CON    C.RESUME
          CON    C.FORMAT
 UCMDL    EQU    *-UCMD
          TITLE  COMMANDS
** NAME-- READ
*
** PURPOSE-- PROCESS READ DATA COMMAND.
*
** INPUT-- LISTL = NUMBER OF ADDRESS-LENGTH-PAIR ENTRIES IN THE
*                    COMMAND WHICH ARE LEFT TO PROCESS.
*          CMLIST  = LIST OF ADDRESS-LENGTH-PAIRS POINTING TO THE
*                    CM DATA AREA.
          SPACE  2
 READX    LJM    **
 READ     EQU    *-1
 READ20   BSS
          LDML   CMLIST+/CM/P.LEN,CSST NUMBER OF BYTES LEFT TO TRANSFER
          SHN    -3
          STDL   WDS         CM WORDS LEFT TO TRANSFER
          ADC    -WPS        CM WORDS PER SECTOR
          ADDL   SECPOS      WORDS PREVIOUSLY TRANSFERRED FROM THIS SECTOR
          MJN    READ30      IF LESS THAN 1 SECTOR LEFT TO TRANSFER
          LDC    WPS         COMPUTE NUMBER OF CM WORDS TO TRANSFER THIS LOOP
          SBDL   SECPOS
          STDL   WDS         NUMBER OF CM WORDS TO TRANSFER TO CURRENT SECTOR
 READ30   BSS
          LDDL   WDS
          SHN    2
          STDL   WC          PP WORDS TO TRANSFER
          LDDL   SECPOS
          NJN    READ36      IF BUS CONTROL ALREADY DONE
          LDN    DATAIN      DATA, INFORMATION IN
          RJM    BCS         BUS CONTROL SEQUENCE
 READ32   EQU    *-1         FOR FORCING ERRORS
          LDC    H0A81       STREAM, READ, DMA
          RJM    FUNC        RAISE MASTER OUT
 READ34   EQU    *-1         FOR FORCING ERRORS
          ACN    DC
 READ36   BSS
          LOADF  CMLIST+/CM/P.RMA,CSST CM ADDRESS OF DATA AREA
          CHCM   WC,DC       TRANSFER DATA
          LDDL   WC
          NJN    READ55      IF NOT ALL WORDS TRANSFERRED
          LDDL   WDS
          RADL   SECPOS      UPDATE SECTOR POSITION
          ADC    -WPS        CHECK FOR END OF SECTOR
          ZJN    READ55      IF END OF SECTOR
          LDML   /SS/P.LISTL,CSST CHECK IF MORE CM ADDRESS-LENGTH-PAIRS
          SBN    1
          NJK    READ120     IF MORE CM DATA TO TRANSFER
          LDC    WPS         CM WORDS PER SECTOR
          SBDL   SECPOS
          SHN    2
          STDL   WC          PP WORDS TO TRANSFER
          LOADC  CM.CB
          CHCM   WC,DC       MUST TRANSFER A FULL SECTOR
 READ55   BSS
          LDC    MS50
 READ60   BSS
          IJM    READ64,DC   IF SLAVE IN DROPPED
          SBN    1
          NJN    READ60      IF TIMEOUT NOT EXPIRED
          RJM    CSI         CHECK SLAVE IN
 READ64   BSS
          RJM    CRS         CHECK FOR REQUEST SWITCH
          NJK    READ20      IF MORE TO TRANSFER
          LJM    READX
 READ120  BSS
          RJM    RNL         READ NEXT LIST
          LJM    READ20
          EJECT
** NAME-- WRITE
*
** PURPOSE-- PROCESS THE WRITE DATA COMMAND.
*
** INPUT-- LISTL = NUMBER OF ADDRESS-LENGTH-PAIR ENTRIES IN THE
*                    COMMAND WHICH ARE LEFT TO PROCESS.
*          CMLIST = LIST OF ADDRESS-LENGTH-PAIRS POINTING TO THE
*                   CM DATA AREA.
          SPACE  2
 WRIX     LJM    **
 WRITE    EQU    *-1
 WRI20    BSS
          LDML   CMLIST+/CM/P.LEN,CSST NUMBER OF BYTES LEFT TO TRANSFER
          SHN    -3
          STDL   WDS         CM WORDS LEFT TO TRANSFER
          ADC    -WPS        CM WORDS PER SECTOR
          ADDL   SECPOS      WORDS PREVIOUSLY TRANSFERRED FROM THIS SECTOR
          MJN    WRI30       IF LESS THAN 1 SECTOR LEFT TO TRANSFER
          LDC    WPS         COMPUTE NUMBER OF CM WORDS TO TRANSFER THIS LOOP
          SBDL   SECPOS
          STDL   WDS         NUMBER OF CM WORDS TO TRANSFER TO CURRENT SECTOR
 WRI30    BSS
          LDDL   WDS
          SHN    2
          STDL   WC          PP WORDS TO TRANSFER
          LDDL   SECPOS
          NJN    WRI36       IF BUS CONTROL ALREADY DONE
          LDN    DATAOUT     DATA, INFORMATION OUT
          RJM    BCS         BUS CONTROL SEQUENCE
 WRI32    EQU    *-1         FOR FORCING ERRORS
          LDC    H0381       STREAM, WRITE, DMA
          RJM    FUNC        RAISE MASTER OUT
 WRI34    EQU    *-1         FOR FORCING ERRORS
          ACN    DC
 WRI36    BSS
          LOADF  CMLIST+/CM/P.RMA,CSST CM ADDRESS OF DATA AREA
          CMCH   WC,DC       TRANSFER DATA
          LDDL   WC
          NJN    WRI55       IF NOT ALL WORDS TRANSFERRED
          LDDL   WDS
          RADL   SECPOS      UPDATE SECTOR POSITION
          ADC    -WPS        CHECK FOR END OF SECTOR
          ZJN    WRI55       IF END OF SECTOR
          LDML   /SS/P.LISTL,CSST CHECK IF MORE CM ADDRESS-LENGTH-PAIRS
          SBN    1
          NJK    WRI120      IF MORE CM DATA TO TRANSFER
          LDC    WPS         CM WORDS PER SECTOR
          SBDL   SECPOS
          SHN    2
          STDL   WC          PP WORDS TO TRANSFER
          LOADC  CM.CB
          CMCH   WC,DC       MUST TRANSFER A FULL SECTOR
 WRI55    BSS
          LDC    MS50
 WRI60    BSS
          IJM    WRI64,DC    IF SLAVE IN DROPPED
          SBN    1
          NJN    WRI60       IF TIMEOUT NOT EXPIRED
          LDN    E30         CHANNEL STAYED ACTIVE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 WRI64    BSS
          RJM    CRS         CHECK FOR REQUEST SWITCH
          NJK    WRI20       IF MORE TO TRANSFER
          LJM    MAIN15
 WRI120   BSS
          RJM    RNL         READ NEXT LIST
          LJM    WRI20
          TITLE  COMMAND SUBROUTINES
** NAME-- BCTB
*
** PURPOSE-- BUILD CONFIDENCE TEST WRITE BUFFER
          SPACE  2
 BCTBX    LJM    **
 BCTB     EQU    *-1
          IAN    14B
          LPC    0#7FFF
          STDL   CTPAT       CONFIDENCE TEST PATTERN FIRST WORD MINUS ONE
          STDL   P1
          LDN    0
          STDL   P3
          LOADC  CM.CB       ADDRESS OF PP COMMUNICATIONS BUFFER
          STDL   P2
 BCTB10   BSS
          AODL   P1          BUILD INCREMENTING PATTERN
          STDL   T1
          AODL   P1
          STDL   T2
          AODL   P1
          STDL   T3
          AODL   P1
          STDL   T4
          SBDL   CTPAT
          ADC    -P.CB-4+/CB/P.BUF
          PJN    BCTBX       IF ALL WORDS STORED
          LDDL   P2
          ADDL   P3
          CWDL   T1          STORE IN PP COMMUNICATIONS BUFFER
          AODL   P3
          UJN    BCTB10
          SPACE  5,20
** NAME-- BPTB
*
** PURPOSE-- BUILD PATH TEST BUFFER
          SPACE  2
 BPTBX    LJM    **
 BPTB     EQU    *-1
          LDN    0
          STDL   T1          INDEX TO OUTPUT BUFFER
          LDN    10
          STDL   T2          TIMES TO REPEAT PATTERN
 BPTB4    BSS
          LCN    0           PATTERN IS FFFF, 0000, AAAA, 5555,
          STML   OB,T1        FEFD REPEATED 10 TIMES
          LDN    0
          STML   OB+1,T1
          LDC    0#AAAA
          STML   OB+2,T1
          SHN    -1
          STML   OB+3,T1
          LDC    0#FEFD
          STML   OB+4,T1
          LDN    5
          RADL   T1
          SODL   T2
          ZJN    BPTBX       IF DONE
          UJN    BPTB4
          SPACE  5,20
** NAME-- CBC
*
** PURPOSE-- COMPUTE BYTE COUNT TO TRANSFER
          SPACE  2
 CBCX     BSS
          LDML   SPT,DT      SECTORS PER TRACK
          SBML   /SS/P.CURSEC,CSST
          RADL   TOTAL+1
          STML   STT,CSST    SECTORS TO TRANSFER
          SHN    -5
          STDL   TOTAL       UPPER 16 BITS OF BYTE COUNT
          LDDL   TOTAL+1
          LPN    37B
          SHN    11
          STDL   TOTAL+1     LOWER 16 BITS OF BYTE COUNT
          LJM    **
 CBC      EQU    *-1
          LDML   /SS/P.CURTRK,CSST
          STDL   T1          TRACK
          SHN    8
          ADML   /SS/P.CURSEC,CSST
          STML   CP+FCP+4    TRACK, SECTOR FOR COMMAND PACKET
          LDML   CTC,DT      CONFIDENCE TEST CYLINDER
          STML   CP+FCP+3    CYLINDER FOR COMMAND PACKET
          LDN    0
          STDL   TOTAL+1
          STML   CP+FCP+1    UPPER WORD OF SECTOR COUNT
          STML   /SS/MT,CSST NO MASTER TERMINATE
 CBC10    BSS
          AODL   T1
          LMML   TPC,DT      TRACKS PER CYLINDER
          ZJK    CBCX        IF LAST TRACK
          LDML   SPT,DT      SECTORS PER TRACK
          RADL   TOTAL+1
          UJN    CBC10
          SPACE  5,20
** NAME-- CCLOCK
*
** PURPOSE-- CLEARS CHANNEL LOCK.
          SPACE  2
 CCLX     LJM    **
 CCLOCK   EQU    *-1
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          STDL   CLF         CHANNEL LOCK FLAG
          LDDL   CHAN        CHANNEL NUMBER = OFFSET IN TABLE
          STDL   T5
          RJM    CLOCK       CLEAR CHANNEL LOCKWORD
          UJK    CCLX
          SPACE  5,20
** NAME-- CDT
*
** PURPOSE-- CHECK DRIVE TYPE
          SPACE  2
 CDTX     LJM    **
 CDT      EQU    *-1
          LDN    10
          STML   CP          COMMAND PACKET LENGTH
          LDC    0#200
          STML   CP+OPCD     ATTRIBUTE COMMAND
          LDC    0#36C
          STML   CP+FCP      PARAMETER TO READ DRIVE TYPE
          LDC    0#4050
          STML   CP+FCP+1    RETURN DRIVE TYPE IN RESPONSE
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          NJN    CDT10       IF NOT SUCCESSFUL
          LDC    ID50
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    CDT10       IF ID 50 NOT FOUND
          LDML   RPB+30,T3
          LMML   MN,DT
          ZJK    CDTX        IF CORRECT DRIVE TYPE
          LDK    E121        WRONG DRIVE TYPE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       IFEQ   UNIX,1
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 .U       ENDIF
          RJM    HANG        (NO RETURN)
 CDT10    BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- CD
*
** PURPOSE-- CHECK DRIVE.  IF COMMAND IS FORMAT GO TO FORMAT ROUTINE
*            ELSE ASSUME THAT CONFIDENCE IS TO BE RUN. ENSURE THAT DRIVE
*            IS FORMATTED BEFORE STARTING THE CONFIDENCE TEST. IF DRIVE
*            IS NOT FORMATTED CHECK IF REQUEST IS A READ OF THE LABEL
*            AREA AND IF SO RETURN WITHOUT DOWNING THE DRIVE. THIS CHECK IS
*            NEEDED BECAUSE NOS/VE ALWAYS ATTEMPTS TO READ THE LABEL EVEN
*            WHEN ATTEMPTING TO FORMAT THE DRIVE.
*
** ENTRY-- FROM GETU IF A REQUEST IS PRESENT AND THE CONFIDENCE TEST
*          HAS NOT BEEN RUN FOR A UNIT AFTER THE PP WAS LOADED OR WHEN A
*          FORMAT COMMAND HAS BEEN ISSUED TO THE UNIT.
*
          SPACE  2
 CDX      LJM    **
 CD       EQU    *-1
          LDML   /SS/P.FNC,CSST
          SBN    4
          NJN    CD05        IF NOT FORMAT COMMAND
          LDML   UNITS,UX
          LPC    0#1FFF
          STML   UNITS,UX    CLEAR COMMAND IN PROGRESS BITS
          LDN    1
          STML   /SS/P.CT,CSST  DISABLE RUNNING CONFIDENCE TEST

*         DRIVE RESET COULD TAKE UP TO 15 SECONDS, SO ONLY DO IT ONCE PER
*         ERROR DURING ERROR PROCESSING.

 CD05     LDML   /SS/P.RECOV,CSST
          LMN    1
          ZJN    CD10        IF RUNNING CONFIDENCE TEST TO ISOLATE TO MEDIA ERROR
          LDML   /SS/P.RQTRY,CSST  RETRY COUNT
          LMN    1
          NJN    CD20        IF NOT FIRST ERROR RETRY
 CD10     BSS
          RJM    DPR         DRIVE POWER ON RESET
 CD20     LDML   /SS/P.DT,CSST
          SHN    -4
          LPN    3
          STDL   DT          DEVICE TYPE
          RJM    RMR         READ MICROCODE REVISION
          RJM    DUSC        DISABLE USAGE STATISTIC COUNTING
          RJM    RD          RESERVE DRIVE
          LDML   /SS/P.FNC,CSST
          SBN    4
          NJN    CD25        IF NOT FORMAT COMMAND
          STDL   IF          CLEAR INITIALIZATION FLAG
          RJM    IU          INITIALIZE UNIT
          LDN    1           ENABLE CT BYPASS
          UJN    CD27
 CD25     RJM    IUF         IS UNIT FORMATTED
          NJN    CD30        UNIT IS NOT FORMATTED
 CD27     UJK    CDX
 CD30     BSS
          LDML   /SS/P.FNC,CSST
          NJN    CD50        IF NOT READ COMMAND
          LDML   RQ+/RQ/P.CYL,CSST
          NJN    CD50        IF NOT CYLINDER WITH LABEL
          LDML   RQ+/RQ/P.TRACK,CSST
          SBN    2
          PJN    CD50        IF NOT TRACK WITH LABEL
          LDN    1
          STDL   CMNDS       SO DCR ROUTINE LEAVES CMNDS EQUAL TO 0
          LDC    E141        ERROR CODE (141)
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LJM    EPF10       SEND ABNORMAL RESPONSE (NO RETURN)
 CD50     BSS
          LDC    E141        ERROR CODE (141)
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- CFME
*
** PURPOSE-- CHECK FOR MEDIA ERROR
*
** EXIT--  A = 0 IF MEDIA ERROR AND FAILING ADDRESS IS PRESENT
          SPACE  2
 CFME20   BSS
          LDN    1           INDICATE MEDIA ERROR NOT FOUND
 CFMEX    LJM    **
 CFME     EQU    *-1
          LDML   RS+/RS/P.ERRID
          NJN    CFMEX       IF NOT MEDIA ERROR
          LDK    ID26        DRIVE MACHINE EXCEPTION
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    CFMEX       IF ID26 NOT FOUND
          LDML   RPB+5,T3
          SHN    -8
          SBN    11
          MJN    CFME20      IF NO EXTENDED SUBSTATUS
          LDML   RPB+10,T3   COMMAND ENDING STATUS
          STDL   T5
          LPN    77B
          SBN    0#11
          ZJN    CFME10      IF ECC ERROR
          SBN    2
          ZJN    CFME10      IF MISSING SYNC
          SBN    6
          NJN    CFMEX       IF NOT SECTOR NOT FOUND
 CFME10   BSS
          LDK    ID32        RESPONSE EXTENT PARAMETER
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    CFMEX       IF PARAMETER 32 NOT FOUND
          LDN    0           INDICATE MEDIA ERROR FOUND
          UJN    CFMEX
          SPACE  5,20
** NAME-- CHGCH
*
** PURPOSE-- SET CHANNEL NUMBER IN CHANNEL INSTRUCTIONS
*
** INPUT-- CHAN = CHANNEL NUMBER
          SPACE  2
 CHGX     LJM    **
 CHGCH    EQU    *-1
          LDN    0
          STDL   T1          CHANGE DISK CHANNEL INSTRUCTIONS
 CHG10    LDML   CONCH,T1    ADDRESS OF CHANNEL INSTRUCTIONS
          ZJN    CHGX        END OF LIST
          STDL   T2
          LDIL   T2
          SCN    37B
          LMDL   CHAN        CHANNEL NUMBER
          STIL   T2
          AODL   T1
          UJK    CHG10
          SPACE  5,20
** NAME-- CKC
*
** PURPOSE-- CHECK IF MAINTENANCE PP WANTS THE CHANNEL.
          SPACE  2
 CKC100   BSS
          STDL   PTF         ENABLE RUNNING PATH TEST
          RJM    PT          PATH TEST
 CKCX     LJM    **
 CKC      EQU    *-1
          LDN    C.CHCNT     NUMBER OF REQUESTS TO PROCESS BEFORE
          STML   CHLCNT       GIVING UP THE CHANNEL
          LOADC  CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          ADDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          CRDL   T1          READ CHANNEL LOCKWORD
          LDDL   T2
          LPN    1
          ZJK    CKCX        IF MAINTENANCE PP DOES NOT WANT THE CHANNEL
          LDDL   UNUML
          ZJK    CKCX        IF NO UNITS
          RJM    CUB         CHECK UNIT BUSY
          STDL   MALET       SETTING MALET NONZERO PREVENTS STARTING
                              NEW DISK REQUESTS
          NJN    CKCX        IF OUTSTANDING COMMANDS
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          PAUSE  130000      DELAY 130 MILLISECONDS TO ALLOW
                             MAINTENANCE PP TO GET THE CHANNEL
          RJM    SCLOCK      SET CHANNEL LOCK
          LDN    0
          STDL   UX
          UJN    CKC20
 CKC10    BSS
          LDN    P.UN
          RADL   UX          UPDATE TO NEXT UNIT TABLE
 CKC20    BSS
          SBDL   UNUML
          ZJK    CKC100      IF ALL RESERVE BITS CLEARED
          LDML   UNITS,UX
          LPC    0#07FF
          STML   UNITS,UX
          UJN    CKC10
 CHLCNT   CON    C.CHCNT     NUMBER OF REQUESTS TO PROCESS BEFORE
                              GIVING UP THE CHANNEL
          SPACE  5,20
** NAME-- CLOCK
*
** PURPOSE-- CLEAR LOCKWORD
*
*  ENTRY
*         T7 = POINTER RMA
*         T5 = OFFSET TO LOCKWORD FROM RMA
          SPACE  2
 CLKX     LJM    **
 CLOCK    EQU    *-1
 CLK14    BSS
          LCN    0
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        RMA OF TABLE
          ADDL   T5          ADD LOCKWORD OFFSET
          STDL   T6
          RDSL   T1          WRITE INTERMEDIATE VALUE
          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJN    CLK14       IF ANOTHER INTERLOCK OPERATION IS IN PROGRESS
          LDDL   PPNO
          SBDL   T4
          ZJN    CLK30       IF LOCK WAS OK
          LDDL   T6
          CWDL   T1          RESTORE THE LOCKWORD
          RJM    HANG        HANG, THE LOCK WAS INCORRECT
 CLK30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6
          CWDL   T1          CLEAR THE LOCKWORD
          UJK    CLKX
 .U       IFNE   UNIX,1
          SPACE  5,20
** NAME-- CPLOCK
*
** PURPOSE-- CLEARS THE PP QUEUE LOCK IN THE PP INTERFACE TABLE
          SPACE  2
 CPLX     LJM    **
 CPLOCK   EQU    *-1
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CPLX
 .U       ENDIF
          SPACE  5,20
** NAME-- CQLOCK
*
** PURPOSE-- CLEARS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
          SPACE  2
 CQLX     LJM    **
 CQLOCK   EQU    *-1
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.QLOCK OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CQLX
          SPACE  5,20
** NAME-- CRS
*
** PURPOSE-- CHECK FOR REQUEST SWITCH
*
** EXIT-- A NOT EQUAL 0 IF MORE TO TRANSFER
          SPACE  2
 CRSX     LJM    **
 CRS      EQU    *-1
          RJM    UBT         UPDATE BYTES TRANSFERRED
          NJK    CRS80       IF NOT END OF REQUEST
          LDML   /SS/MT,CSST
          SHN    2
          PJK    CRS50       IF NOT USING MASTER TERMINATE
          LOADF  /SS/P.REQ,CSST
          STDL   T1
          ADN    3
          CRDL   T4          READ STREAM BIT IN REQUEST
          LDDL   T4
          SHN    2
          MJN    CRS15       IF CONCATENATED REQUEST
          AOML   /SS/MT,CSST INDICATE COMMAND IS TERMINATED
          LDN    1
          STDL   SBS         FORCE DESELECT
          LDN    0#A         MASTER TERMINATE
          UJK    CRS81
 CRS15    BSS
          LDDL   CSST
          ADK    RQ
          STML   CRS20       ADDRESS TO STORE PVA, RMA
          LDN    2
          STDL   T2
          LDDL   T1
          CRML   *,T2        REREAD NEXT PVA AND RMA
 CRS20    EQU    *-1
 CRS50    BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          LDDL   WC
          NJN    CRS82       IF ERROR
          LDDL   STATUS
          SHN    -4
          LPN    3
          STDL   DELAY       SAVE DELAY BITS
          STDL   SECPOS      SECPOS = 0 IF STAYING IN READ
          RJM    UDA         UPDATE DISK ADDRESS
          LDML   /SS/P.TOTAL,CSST TOTAL CM WORDS LEFT TO TRANSFER
          ADML   /SS/P.TOTAL+1,CSST
          ZJN    CRS100      IF END OF TRANSFER
          RJM    CSWIT       SWITCH TO NEXT REQUEST
          UJN    CRS90
 CRS80    BSS
          LDN    0           NO MASTER TERMINATE
 CRS81    BSS
          RJM    GES         GET ENDING STATUS
          LDDL   WC
          ZJN    CRS85       IF ALL WORDS TRANSFERRED
 CRS82    BSS
          RJM    SRR         SHOULD RESPONSE BE READ
          UJN    CRS100      YES, EXIT AND LOOK FOR RESPONSE
 CRS85    BSS
          LDDL   STATUS
          SHN    -4
          LPN    3
          STDL   DELAY       SAVE DELAY BITS
          STDL   SECPOS      SECPOS = 0 IF STAYING IN READ
          RJM    UDA         UPDATE DISK ADDRESS
 CRS90    BSS
          LDDL   DELAY
          NJN    CRS100      IF DELAY
          LDDL   SBS
          ZJN    CRS100      IF TIME TO SUSPEND DATA TRANSFER
          UJK    CRSX        IF MORE TO TRANSFER
 CRS100   BSS
          RJM    DCM         DESECLECT THE CONTROL MODULE
          LDN    0
          LJM    CRSX
          SPACE  5,20
** NAME-- CSI
*
** PURPOSE-- CHECK SLAVE IN.  REPORT SLAVE IN DID NOT DROP, ELSE
*            EXIT TO THE CALLING ROUTINE.  ON READS, IF SLAVE IN
*            DROPS, THE CHANNEL WILL NOT BE INACTIVE UNTIL THE
*            BUFFER IS EMPTY.
          SPACE  2
 CSIX     LJM    **
 CSI      EQU    *-1
          LDC    H00E1       FUNCTION FOR READ STATUS REGISTER
          RJM    RDRG        READ REGISTER
          SHN    6
          PJN    CSIX        IF SLAVE IN NOT SET
          LDN    E30         CHANNEL STAYED ACTIVE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- CSWIT
*
** PURPOSE-- SWITCH TO THE NEXT REQUEST
          SPACE  2
 CSWX     LJM    **
 CSWIT    EQU    *-1
          LDML   RQ+/RQ/P.NEXT,CSST PUT RMA OF NEXT REQUEST IN SS TABLE
          STML   /SS/P.REQ,CSST
          LDML   RQ+/RQ/P.NEXT+1,CSST
          STML   /SS/P.REQ+1,CSST
          LDML   RQ+/RQ/P.NEXTPV,CSST PUT PVA OF NEXT REQUEST IN SS TABLE
          STML   /SS/P.PVA,CSST
          LDML   RQ+/RQ/P.NEXTPV+1,CSST
          STML   /SS/P.PVA+1,CSST
          LDML   RQ+/RQ/P.NEXTPV+2,CSST
          STML   /SS/P.PVA+2,CSST
          LDML   RQ+/RQ/P.CYL,CSST
          STDL   T1          SAVE CYLINDER OF LAST REQUEST
          RJM    UREQ        READ NEXT REQUEST INTO RQ
          LDML   RQ+/RQ/P.CYL,CSST
          SBD    T1
          NJN    *           IF NOT SAME CYLINDER
          LDML   /SS/P.CURSEC,CSST CURRENT SECTOR - 1
          LMML   RQ+/RQ/P.SECTOR,CSST SECTOR OF NEXT REQUEST
          NJN    *           IF SECTOR NUMBER WRONG
          LDML   /SS/P.CURTRK,CSST CURRENT TRACK
          LMML   RQ+/RQ/P.TRACK,CSST TRACK ADDRESS OF NEXT REQUEST
          NJN    *           TRACK NUMBER WRONG
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
          LDDL   FNC
          ZJN    CSW10       IF READ, SEND RESPONSE OF COMPLETED REQUEST

* IF WRITE, DON'T SEND RESPONSES FOR COMPLETED REQUESTS.
* FOR WRITE ERROR RECOVERY, RESTART ALL REQUESTS.

          AOML   /SS/P.NCOMW,CSST INCREMENT NUMBER OF COMPLETED WRITE REQUESTS
          UJN    CSW30
 CSW10    BSS
          RJM    RDWTOK      SEND RESPONSE FOR GOOD READ
 CSW30    BSS
          UJK    CSWX
          SPACE  5,20
** NAME-- CT
*
** PURPOSE-- CONFIDENCE TEST.  RESERVE THE DRIVE, WRITE, READ, AND
*            VERIFY DATA ON A RESERVED CYLINDER.
*
** ENTRY
*         1)  AT INITIALIZATION AFTER PP LOADED
*         2)  DURING REQUEST RECOVERY WITH /SS/P.RECOV = 1
*         3)  WHEN PP RESUMED
          SPACE  2
 CTX      LJM    **
 CT       EQU    *-1
*
*         THIS TEST PREVENTS RERUNNING THE CONFIDENCE TEST ON
*         A UNIT THAT IS DISABLED.  DURING INITIALIZATON THE PP DOES
*         NOT LOOK FOR AN IDLE COMMAND UNITL THE CONFIDENCE TEST HAS
*         BEEN RUN ON ALL UNITS.
*
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T1
          LDDL   T1+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJK    MAIN15      IF UNIT DISABLED
 .U       IFEQ   UNIX,1
          RJM    PPRQ        CHECK FOR IDLE REQUEST
 .U       ENDIF
          LDN    0
          STML   /SS/P.CURTRK,CSST STARTING TRACK
          STML   /SS/P.CURSEC,CSST STARTING SECTOR
          RJM    SFT         SET FACILITY TIMEOUT
          RJM    CDT         CHECK DRIVE TYPE
          RJM    CTDT        CONFIDENCE TEST DATA TRANSFER
          RJM    SFRR        CLEAR CIP AND TCIP
          LDN    1
          STML   /SS/P.CT,CSST INDICATE TEST COMPLETED SUCCESSFULLY
          LDML   /SS/P.RECOV,CSST
          LMN    1
          ZJN    CT50        IF CONFIDENCE TEST IS PART OF RECOVERY
          LDN    0
          STML   /SS/P.RECOV,CSST
          STML   /SS/P.RQTRY,CSST CLEAR REQUEST RETRY COUNTER
 CT50     BSS
          UJK    CTX
          SPACE  5,20
** NAME-- CTDT
*
** PURPOSE-- CONFIDENCE TEST DATA TRANSFER
          SPACE  2
 CTDTX    LJM    **
 CTDT     EQU    *-1

* GET THE READ-ONLY DEVICE FLAG.

          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ADK    /UIT/C.RONLY
          CRDL   T1
          LDDL   T1
          LPK    /UIT/K.RONLY
          STDL   RONLY       NONZERO IF READ-ONLY DEVICE

* WRITE THE CYLINDER

          LCN    0
          STML   CTME,CSST   MAKE MEDIA ERROR TABLE LOOK EMPTY
          STML   CTME+1,CSST
          STML   CTME+2,CSST
          LDN    1
          STDL   FNC         INDICATE WRITE OPERATION
          RJM    BCTB        BUILD CONFIDENCE TEST BUFFER
 CTDT5    BSS                ENTRY IF MEDIA ERROR
          LDDL   RONLY
          NJK    CTDT40      IF READ-ONLY DEVICE
          RJM    CBC         COMPUTE BYTE COUNT TO TRANSFER
          RJM    SCP         SETUP COMMAND PACKET PARAMETERS
          RJM    CPT         COMMAND PACKET TRANSFER
 CTDT7    EQU    *-1         FOR FORCING ERRORS
 CTDT10   BSS
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    CTDT100     IF NOT TRANSFER NOTIFICATION
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAOUT     DATA, INFORMATION OUT
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    WPS*4
          STDL   WC          WORDS PER SECTOR
          LDC    H0381       STREAM, WRITE, DMA
          RJM    FUNC
          ACN    DC
          LOADC  CM.CB
          ADML   SPC,DT      SECTORS PER CYLINDER
          SBML   STT,CSST    SECTORS TO TRANSFER
          CMCH   WC,DC       TRANSFER DATA
          LDC    MS50
 CTDT20   BSS
          IJM    CTDT30,DC   IF SLAVE IN DROPPED
          SBN    1
          NJN    CTDT20      IF TIMEOUT NOT EXPIRED
          LJM    CTDT110
 CTDT30   BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT THE CONTROL MODULE
          LDDL   WC
          ZJN    CTDT35      IF ALL WORDS TRANSFERRED
          RJM    SRR         SHOULD RESPONSE BE READ
          UJK    CTDT10      YES, GO LOOK FOR INTERRUPT
 CTDT35   BSS
          RJM    UDA         UPDATE DISK ADDRESS
          SOML   STT,CSST
          NJK    CTDT10      IF MORE SECTORS TO TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LPN    0#A
          ZJK    CTDT100     IF NOT SUCCESSFUL

* READ THE CYLINDER

 CTDT40   BSS
          LDN    0
          STML   /SS/P.CURTRK,CSST STARTING TRACK
          STML   /SS/P.CURSEC,CSST STARTING SECTOR
          STDL   FNC         INDICATE READ FUNCTION
 CTDT50   BSS                ENTRY IF MEDIA ERROR
          RJM    CBC         COMPUTE BYTE COUNT TO TRANSFER
          RJM    SCP         SETUP COMMAND PACKET PARAMETERS
          RJM    CPT         COMMAND PACKET TRANSFER
 CTDT60   BSS
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    CTDT100     IF NOT TRANSFER NOTIFICATION
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAIN      DATA, INFORMATION IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    WPS*4
          STDL   WC          WORDS PER SECTOR
          LDC    H0A81       STREAM, READ, DMA
          RJM    FUNC
          ACN    DC
          LOADC  CM.CB
          CHCM   WC,DC       TRANSFER DATA
          LDC    MS50
 CTDT70   BSS
          IJM    CTDT80,DC   IF SLAVE IN DROPPED
          SBN    1
          NJN    CTDT70      IF TIMEOUT NOT EXPIRED
          RJM    CSI         CHECK SLAVE IN
 CTDT80   BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT THE CONTROL MODULE
          LDDL   WC
          ZJN    CTDT90      IF ALL WORDS TRANSFERRED
          RJM    SRR         SHOULD RESPONSE BE READ
          UJK    CTDT60      YES, GO LOOK FOR INTERRUPT

* VERIFY THE DATA IN ONE SECTOR

 CTDT90   BSS
          LDDL   RONLY
          NJN    CTDT92      IF READ-ONLY DEVICE
          RJM    VCTD        VERIFY CONFIDENCE TEST DATA
 CTDT92   BSS
          RJM    UDA         UPDATE DISK ADDRESS
          SOML   STT,CSST
          NJK    CTDT60      IF MORE SECTORS TO TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LPN    0#A
          NJK    CTDTX       IF SUCCESSFUL OR CONDITIONAL SUCCESS
 CTDT100  BSS
          LDN    E00         CP MUST ISOLATE THE ERROR
          UJN    CTDT130
 CTDT110  BSS
          LDN    E30         CHANNEL STAYED ACTIVE
 CTDT130  BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- CTR
*
** PURPOSE-- CONFIDENCE TEST RECOVERY
*
** EXIT--  TO CALLING ROUTINE WITH
*             A = 0  IF ERROR LIMIT REACHED
*             A NOT 0  IF NOT MEDIA ERROR
*          TO CTDT ROUTINE IF MEDIA ERROR
          SPACE  2
 CTR100   BSS
          LMN    4           DATA INTEGRITY ERROR
 CTRX     LJM    **
 CTR      EQU    *-1
          LDML   /SS/P.CT,CSST
          NJN    CTR100      IF NOT IN CONFIDENCE TEST
          RJM    CFME        CHECK FOR MEDIA ERROR
          NJN    CTRX        IF NOT A MEDIA ERROR
          LDML   RPB+9,T3    HEAD, SECTOR
          STDL   T4
          LDDL   CSST
          STDL   T5          POINTER TO SS TABLE
          LDN    3
          STDL   T6          NUMBER OF MEDIA ERRORS ALLOWED
 CTR20    BSS
          LDML   CTME,T5
          SHN    2
          MJN    CTR30       IF TABLE ENTRY AVAILABLE
          SHN    -2
          LMDL   T4
          ZJN    CTR40       IF THIS SECTOR IN TABLE
          AODL   T5
          SODL   T6
          NJN    CTR20       IF MORE ENTRIES TO CHECK
          UJK    CTRX
 CTR30    BSS
          LDDL   T4
          STML   CTME,T5
 CTR40    BSS
          LDDL   FNC
          ZJN    CTR50       IF READ
          LDDL   T4
          SHN    -8
          STML   /SS/P.CURTRK,CSST FAILING TRACK
          LDDL   T4
          LPN    77B
          STML   /SS/P.CURSEC,CSST FAILING SECTOR
 CTR50    BSS
          AOML   /SS/P.CURSEC,CSST UPDATE SECTOR NUMBER
          SBML   SPT,DT      SECTORS PER TRACK
          MJN    CTR60       IF SAME TRACK
          STML   /SS/P.CURSEC,CSST
          AOML   /SS/P.CURTRK,CSST UPDATE TRACK NUMBER
          LMML   TPC,DT      TRACKS PER CYLINDER
          NJN    CTR60       IF NOT LAST SECTOR ON CYLINDER
          LDDL   FNC
          NJK    CTDT40      IF WRITE
          LJM    CTDTX
 CTR60    BSS
          LDDL   FNC
          NJK    CTDT5       IF WRITE
          LJM    CTDT50      GO TO READ ENTRY POINT
          SPACE  5,20
** NAME-- CUB
*
** PURPOSE-- CHECK UNIT BUSY.  NOTE IF SLAVE RESET IS IN PROGRESS
*            CMNDS COULD BE 0, BUT ERROR RECOVERY IS STILL IN
*            PROGRESS.
*
** EXIT--  A = 0  IF NO COMMANDS IN PROGRESS
          SPACE  2
 CUB50    BSS
          LDN    1
 CUBX     LJM    **
 CUB      EQU    *-1
          LDN    0
          STDL   UX          POINTER TO UNITS TABLE
          UJN    CUB20
 CUB10    BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UX TABLE
 CUB20    BSS
          SBDL   UNUML
          ZJN    CUBX        IF END OF CONFIGURED UNITS
          LOADR  UNITS+/UN/P.UIT,UX ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T5          READ UNIT DISABLED FLAG
          LDDL   T5+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJN    CUB10       IF UNIT DISABLED
          LDML   UNITS,UX
          SHN    /UN/L.CIP+2
          MJN    CUB50       IF COMMAND IN PROGRESS
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE
          LDML   /SS/P.RQTRY,CSST
          NJK    CUB50       IF IN ERROR RECOVERY FOR THIS UNIT
          UJK    CUB10
          SPACE  5,20
** NAME-- DARH
*
** PURPOSE-- DRIVE ASYNCHRONOUS RESPONSE HANDLER
          SPACE  2
 DARHX    LJM    **
 DARH     EQU    *-1
          LDDL   UX
          STDL   T8          SAVE UX
          LDN    0
          STDL   UX          INDEX TO UX TABLE
          UJN    DARH20
 DARH10   BSS
          LDN    P.UN
          RADL   UX          INDEX TO UX TABLE
 DARH20   BSS
          SBDL   UNUML
          ZJN    DARHX       IF DRIVE NOT FOUND
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE
          LDML   /SS/P.UNIT,CSST
          LMML   RPB+SLAD
          NJN    DARH10      IF DIFFERENT DRIVE
          LDK    ID26
          RJM    SFP         CHECK FOR MACHINE EXCEPTION
          MJN    DARH30      IF MACHINE EXCEPTION ID NOT FOUND
          LDML   RPB+6,T3
          LPC    0#FAF0
          LMC    0#6000
          ZJN    DARH40      IF NO ERROR
 DARH30   BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       IFEQ   UNIX,1
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 .U       ENDIF
 DARH40   BSS
          LDML   /SS/P.RESET,CSST
          ZJK    DARHX       IF RESET NOT ISSUED
          LDN    0
          STML   /SS/P.RESET,CSST  CLEAR RESET ISSUED FLAG
          LDML   UNITS,UX
          LPC    0#1FFF
          STML   UNITS,UX    CLEAR COMMAND IN PROGRESS BITS
          UJK    DARHX
          SPACE  5,20
** NAME-- DCR
*
** PURPOSE-- DELETE COMPLETED REQUEST FROM THE UNIT QUEUE.
*
** INPUTS-- UNITS+/UN/P.UIT = POINTER TO UNIT INTERFACE TABLE
*
** OUTPUT-- P5, T8 ARE UNCHANGED
          SPACE  2
 DCRX     LJM    **
 DCR      EQU    *-1
          LDN    2
          STDL   P6
 DCR2     BSS
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    DCR2        IF LOCK COULD NOT BE SET
          LOADF  /SS/P.CURRQ,CSST RMA OF CURRENT REQUEST
          CRML   RQT,P6      READ RMA CHAIN OF CURRENT REQUEST

          LOADR  UNITS+/UN/P.UIT,UX  LOAD CM ADDRESS OF UNIT INT. TABLE
          STDL   T1
          CRDL   P1          READ QUEUE COUNT
          ERRNZ  /UIT/C.QCNT
          LDDL   P1+/UIT/P.QCNT  DECREMENT QUEUE COUNT
          SBML   /SS/P.NCOMRQ,CSST NUMBER OF COMPLETED REQUESTS
          STDL   P1+/UIT/P.QCNT
          MJN    DCR10       IF INVALID QUEUE COUNT
          LDDL   T1
          CWDL   P1          WRITE QUEUE COUNT
 DCR10    BSS
          LOADR  /SS/P.DP,CSST DELINK POINTER
          STDL   P2
          ADN    1           POINT TO RMA INSTEAD OF PVA
          CRDL   T1          RMA OF A REQUEST
          LDDL   T3
          LMML   /SS/P.FCOMRQ,CSST
          NJN    DCR15       IF NEXT REQUEST IS NOT COMPLETED REQUEST
          LDDL   T4
          LMML   /SS/P.FCOMRQ+1,CSST
          ZJN    DCR30       IF THIS IS A COMPLETED REQUEST
 DCR15    BSS
          LDDL   T3          UPDATE DELINK POINTER TO NEXT
          STML   /SS/P.DP,CSST  REQUEST IN THE CHAIN
          ADDL   T4
          ZJN    DCR20       IF END OF REQUEST QUEUE
          LDDL   T4
          SHN    -3
          STML   /SS/P.DP+1,CSST
          UJK    DCR10
 DCR20    BSS
          LDML   UNITS+/UN/P.UIT+1,UX INITIALIZE DELINK POINTER TO
          ADN    /UIT/C.NEXTPV       FIRST RMA
          STML   /SS/P.DP+1,CSST
          LDML   UNITS+/UN/P.UIT,UX
          STML   /SS/P.DP,CSST
          UJK    DCR10

* DELINK COMPLETED REQUESTS.

 DCR30    BSS
          LDDL   P2          CM ADDRESS OF REQUEST
          CWML   RQT,P6      PVA AND RMA OF NEXT REQUEST IN CHAIN
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          LDML   /SS/P.FNC,CSST
          SBN    4
          NJN    DCR35      IF NOT FORMAT COMMAND
          SODL   CMNDS      CMNDS IS SET TO 2 FOR FORMAT
          LDML   UNITS,UX
          UJK    DCR37
 DCR35    LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          MJN    DCR44       IF 2 COMMANDS ISSUED TO CONTROLLER
          SHN    -/UN/L.TCIP-2
 DCR37    LPC    0#FFF
          STML   UNITS,UX    CLEAR CIP AND DTIP
          LDML   RQT+/RQ/P.NEXT
          STML   /SS/P.REQ,CSST
          LDML   RQT+/RQ/P.NEXT+1
          STML   /SS/P.REQ+1,CSST POSSIBLE NEXT RMA
          ADML   /SS/P.REQ,CSST
          ZJN    DCR40       IF END OF QUEUE
          LDML   RQT+/RQ/P.NEXTPV
          STML   /SS/P.PVA,CSST
          LDML   RQT+/RQ/P.NEXTPV+1
          STML   /SS/P.PVA+1,CSST
          LDML   RQT+/RQ/P.NEXTPV+2
          STML   /SS/P.PVA+2,CSST
 DCR40    BSS
          LJM    DCR50
 DCR44    BSS
          LDML   UNITS,UX
          LPC    0#9FFF
          STML   UNITS,UX    CLEAR TCIP, DTIP

* MOVE (RMA, PVA, TOTAL BYTES) FOR SECOND COMMAND ISSUED TO THE
* TABLE FOR THE FIRST COMMAND

          LDML   /SS/P.RMA2,CSST
          STML   /SS/P.REQ,CSST
          LDML   /SS/P.RMA2+1,CSST
          STML   /SS/P.REQ+1,CSST MOVE RMA
          LDML   /SS/P.PVA2,CSST
          STML   /SS/P.PVA,CSST
          LDML   /SS/P.PVA2+1,CSST
          STML   /SS/P.PVA+1,CSST
          LDML   /SS/P.PVA2+2,CSST
          STML   /SS/P.PVA+2,CSST MOVE PVA
          LDML   /SS/P.TW2,CSST
          STML   /SS/P.TOTAL,CSST
          LDML   /SS/P.TW2+1,CSST
          STML   /SS/P.TOTAL+1,CSST MOVE TOTAL BYTES
          RJM    UREQ        READ UNIT REQUEST FROM CM
          RJM    SRESP       SET UP STATUS FOR RESPONSE BUFFER
          RJM    SETRQ       SET UP FOR FIRST REQUEST
          RJM    UNCMND      GET FIRST COMMAND
 DCR50    BSS
          SODL   CMNDS       OUTSTANDING COMMANDS
          LJM    DCRX
          SPACE  5,20
** NAME-- DPR
*
** PURPOSE-- DRIVE POWER ON RESET.  THIS MASTER CLEARS THE DRIVES,
*            BREAKS AN OPPOSITE ACCESS RESERVE AND RUNS DIAGNOSTICS.
*            IT IS ISSUED BY THE CM3 EVEN IF THE CM3 THINKS THE DRIVE
*            IS NOT OPERATIONAL.
          SPACE  2
 DPRX     LJM    **
 DPR      EQU    *-1
          LDC    H0800       ABORT COMMAND
          STML   CP+OPCD
          LDN    9           COMMAND PACKET LENGTH
          STML   CP
          LDC    0#254
          STML   CP+FCP
          LDC    0#400       RESET AS AT POWER ON
          STML   CP+FCP+1
          LDML   /SS/P.UNIT,CSST
          STML   CP+SLAD     CONTROLLER, UNIT NUMBER
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          NJK    DPR50       IF ERROR
*
*TEMP UNITL FSD II DRIVE PROBLEM IS FIXED
*
          LCN    0           DELAY 500 MILLISECONDS
          HOLD
          LCN    0
          HOLD
*
*         IF THE UNIT IS NOT READY, THE DRIVE RESET COULD RESULT IN A
*         STATE CHANGE.  THE STATE CHANGE TOOK AS LONG AS 22 SECONDS
*         WITH REV 8A OF CM3 MICROCODE.  IF A CM3 IS POWERED ON AND A
*         DRIVE IS RESERVED TO ANOTHER CM3, THE CM3 THAT IS POWERED
*         ON WILL REPORT THAT THE DRIVE IS NOT OPERATIONAL AND NOT READY.
*
          LDML   /SS/P.RQ,CSST
          ZJK    DPRX        IF THERE SHOULD BE NO STATE CHANGE
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,UX  SAVE CLOCK IN TABLE
 DPR10    BSS
          RJM    RI          REQUEST INTERRUPT
          LDML   SELT,CMOD   MASK VALUE
          LPDL   STATUS      INTERRUPT STATUS
          NJN    DPR20       IF INTERRUPT PRESENT
          RJM    UC          UPDATE CLOCK
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    DPR15       IF CLOCK HAS NOT WRAPPED
          ADC    0#10000
 DPR15    BSS
          SBN    32          30 TO 32 SECOND TIMEOUT
          MJN    DPR10       IF TIMEOUT NOT EXPIRED
          LJM    DPRX
 DPR20    BSS
          RJM    SEL         SELECT THE CONTROLLER
          RJM    RPT         RESPONSE PACKET TRANSFER
          RJM    DCM         DESELECT THE CONTROL MODULE
          LDML   RPB+MAJST
          SHN    -4
          LPN    0#F
          LMN    AR
          NJN    DPR50       IF NOT ASYNCHRONOUS RESPONSE
          LDML   RPB+SLAD
          LPC    0#FF
          LMC    0#FF
          ZJN    DPR50       IF ASYNCHRONOUS RESPONSE FOR CONTROLLER
          RJM    DARH        DYNAMIC ASYNCHRONOUS RESPONSE HANDLER
          LDDL   T8
          STDL   UX          RESTORE UX
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO CURRENT SS TABLE
          LJM    DPRX
 DPR50    BSS
          LDN    E00         CPU MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- DUSC
*
** PURPOSE-- DISABLE USAGE STATISTICS COUNTING.  THIS IS SUPPOSE
*            TO SAVE 400 MICROSECONDS PER COMMAND. IT ALSO ELIMINATES
*            THE PROBLEM OF HANDLING STATISTIC COUNTER OVERFLOWS AND
*            HAVING TO CLEAR THE PERFORMANCE LOG.
*
*            ALSO ALLOW FAULT LOG REPORTING AND ALLOW MASTER TERMINATE
*            IF REVISION 8A OR LATER CM3 MICROCODE.
          SPACE  2
 DUSCX    LJM    **
 DUSC     EQU    *-1
          LDML   /SS/P.MREV,CSST
          SHN    -12
          STDL   T1          MICROCODE REVISION
          SBN    7
          MJN    DUSC10      IF MICROCODE REVISION BEFORE 7A
          ZJN    DUSC5       IF MICROCODE REVISION 7A
          LDN    0#13
          UJN    DUSC20
 DUSC5    BSS
          LDN    0#B
          UJN    DUSC20
 DUSC10   BSS
          LDN    8
 DUSC20   BSS
          STML   CP          COMMAND PACKET LENGTH
          LDC    0#209
          STML   CP+OPCD     ATTRIBUTES COMMAND
          LDDL   CMOD
          SHN    8
          LMC    0#FF
          STML   CP+SLAD     SLAVE ADDRESS
          LDC    0#1D1
          STML   CP+FCP      DISABLE COUNTING PARAMETER
          LDC    0#2D4
          STML   CP+FCP+1    DEVICE FAULT LOG REPORTING

*         ENABLING DEVICE FAULT LOG REPORTING BEFORE 8A MICROCODE CAUSED
*         WRITING TO THE WRONG CYLINDER IF THE DRIVE HAD A SLIPPED CYLINDER.

          LDDL   T1
          SBN    8
          MJN    DUSC30      IF MICROCODE REVISION BEFORE 8A
          LDC    0#100       ENABLE REPORTING
          UJN    DUSC40
 DUSC30   BSS
          LDN    0           DISABLE REPORTING
 DUSC40   BSS
          STML   CP+FCP+2
          STML   CP+FCP+4
          STML   CP+FCP+6
          LDC    0#2D2       ALLOW MASTER TERMINATE
          STML   CP+FCP+3
          LDC    0#2D3       SPEED UP MASTER TERMINATE
          STML   CP+FCP+5
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          ZJK    DUSCX       IF SUCCESSFUL
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- EFP
*
** PURPOSE-- ERROR FLAG PROCESSING
          SPACE  2
 EFP      CON    0
          LDC    H00F1       READ ERROR REGISTER
          RJM    RDRG
          SHN    2
          PJN    EFP5        IF NOT BUFFER COUNTER PARITY
          LDN    E31
          UJN    EFP35
 EFP5     BSS
          SHN    2
          PJN    EFP10       IF NOT SYNC COUNTER PARITY
          LDN    E32
          UJN    EFP35
 EFP10    BSS
          SHN    1
          PJN    EFP15       IF NOT PERIOD COUNTER PARITY
          LDN    E03
          UJN    EFP35
 EFP15    BSS
          SHN    1
          MJN    EFP18       IF PARITY ERROR ON FUNCTION
          SHN    1
          PJN    EFP20       IF NOT PARITY ERROR ON FUNCTION
 EFP18    BSS
          LDC    H0715       MOST LIKELY FUNCTION THAT TIMED OUT
          STDL   LF
          LDN    E01         FUNCTION TIMEOUT
          UJN    EFP35
 EFP20    BSS
          SHN    3
          PJN    EFP25       IF NOT LOST DATA
          LDN    E33
          UJN    EFP110
 EFP25    BSS
          SHN    1
          PJN    EFP30       IF NOT UPPER ICI PARITY
          LDN    E04
          UJN    EFP110
 EFP30    BSS
          SHN    1
          PJN    EFP40       IF NOT LOWER ICI PARITY
          LDN    E05
 EFP35    BSS
          UJN    EFP110
 EFP40    BSS
          SHN    1
          PJN    EFP45       IF NOT IPI SEQUENCE ERROR
          LDN    E24
          UJN    EFP110
 EFP45    BSS
          SHN    1
          PJN    EFP50       IF NOT UPPER IPI CHANNEL PARITY
          LDN    E25
          UJN    EFP110
 EFP50    BSS
          SHN    1
          PJN    EFP55       IF NOT LOWER IPI CHANNEL PARITY
          LDN    E26
          UJN    EFP110
 EFP55    BSS
          LDN    E06         IOU ERROR
 EFP110   BSS
          STML   RS+/RS/P.ERRID
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- EP
*
** PURPOSE-- ERROR PROCESSING
          SPACE  2
 EP       CON    0
          LDML   /SS/P.RQTRY,CSST
          NJN    EP5         IF NOT FIRST ERROR FOR REQUEST
          STML   /SS/P.RECOV,CSST
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
 EP5      BSS
 .U       IFEQ   UNIX,1
          RJM    PPRQ        CHECK FOR IDLE REQEST
 .U       ENDIF
          LDN    0
          STML   /SS/P.RQ,CSST  DO NOT WAIT FOR ASYNCH IN DPR
          LDML   RS+/RS/P.ERRID
          NJN    EP7         IF RESPONSE PACKET NOT APPLICABLE
          LDK    ID24
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    EP7         IF PARAMETER 24 NOT FOUND
          LDML   RPB+6,T3
          SHN    3
          PJN    EP7         IF DRIVE WAS READY
          AOML   /SS/P.RQ,CSST  FLAG SAYS WAIT FOR ASYNCH IN DPR
 EP7      BSS
          LDN    0
          STDL   TBC         DO NOT EXPECT 01 ENDING STATUS
          LDML   RS+/RS/P.ERRID
          ZJN    EP20        IF PROBABLY NOT IOU ERROR
          SBN    E20
          PJN    EP20        IF PROBABLY NOT IOU ERROR
          LDML   /SS/P.RQTRY,CSST
          SBN    11
          PJN    EP10        IF RETRY LIMIT REACHED
          RJM    TAC         TERMINATE ALL COMMANDS
          RJM    RAR         RESTART ALL REQUESTS
          LJM    MAIN10
 EP10     BSS
          LDK    /RS/K.CHDN  CHANNEL DOWN
          STML   RS+/RS/P.ID
 .U       IFEQ   UNIX,1
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       ENDIF
          RJM    OFFCH       TURN OFF ALL UNITS ON CHANNEL
 .U       IFEQ   UNIX,1
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 .U       ELSE
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       ENDIF
          LJM    MAIN15
 EP20     BSS
          LDML   /SS/P.RECOV,CSST INDEX TO ERROR PROCESSING PROCEDURE
          STDL   T1
          LDML   EPT,T1
          STML   EP30
          LJM    **          EXECUTE NEXT STEP IN RECOVERY PROCEDURE
 EP30     EQU    *-1

 EPT      BSS    0
          CON    EPA         RETRY THE REQUEST
          CON    EPB         CONFIDENCE TEST
          CON    EPC         SLAVE RESET
          CON    EPD         PATH TEST
          CON    EPE         DRIVE DIAGNOSTICS
          CON    EPF         IF FINAL REQUEST RETRY FAILED
          CON    EPG         IF LOGICAL RESET FAILS AFTER FINAL RETRY
          CON    EPD50       REQUEST RETRY ERROR AFTER SLAVE RESET
          CON    EPC70       AFTER READ PERFORMANCE LOG
          SPACE  5,20
*
* REQUEST RETRY
*
 EPA      BSS
          LDML   /SS/P.RQTRY,CSST REQEST RETRY COUNTER
          ZJN    EPA10       IF INTERMEDIATE RESPONSE ALREADY REPORTED
          LDML   /SS/P.FNC,CSST
          SBN    4
          NJN    EPA05       IF NOT FORMAT COMMAND
          LDML   /SS/P.RQTRY,CSST REQUEST RETRY COUNTER
          SBN    RRL
          NJN    EPA05       CONTINUE WITH ERROR RECOVERY
          LJM    EPF10       SEND ABNORMAL RESPONSE
 EPA05    LDML   /SS/P.RQTRY,CSST REQEST RETRY COUNTER
          SBN    RRL+1
          PJN    EPB         IF FAILURE DURING LOGICAL RESET
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
 EPA10    BSS
          RJM    CTR         CONFIDENCE TEST RECOVERY
          NJN    EPA30       IF ERROR LIMIT NOT REACHED
          AOML   /SS/P.RQTRY,CSST REQUEST RETRY COUNTER
          UJK    EPC
 EPA30    BSS
          AOML   /SS/P.RQTRY,CSST REQUEST RETRY COUNTER
          RJM    LIR         LOGICAL INTERFACE RESET
          RJM    RCC         SETUP FOR RESTART CONTROLLER COMMANDS
          LDML   /SS/P.RQTRY,CSST
          SBN    RRL+1
          MJN    EPB10       IF NOT RETRY LIMIT
          SPACE  5,20
*
* CONFIDENCE TEST
*
 EPB      BSS
          LDML   /SS/P.CT,CSST
          ZJN    EPC         IF IN SUBSYSTEM CONFIDENCE TEST
          LDML   /SS/P.RECOV,CSST
          LMN    1
          ZJN    EPB20       IF CONFIDENCE TEST ALREADY STARTED
          AOML   /SS/P.RECOV,CSST INDEX TO NEXT RECOVERY STEP
          RJM    RCC         RESTART CONTROLLER COMMANDS
          LDN    0
          STML   /SS/P.CT,CSST ENABLE STARTING CONFIDENCE TEST
 EPB10    BSS
          LJM    MAIN10
 EPB20    BSS
          LDML   /SS/P.CT,CSST
          NJN    EPC         IF CONFIDENCE TEST COMPLETE
          RJM    CTR         CONFIDENCE TEST RECOVERY
          SPACE  5,20
*
* SLAVE RESET
*
 EPC      BSS
          LDML   RS+/RS/P.ERRID
          SBN    E20
          ZJN    EPC2        IF -CAN'T SELECT CONTROLLER- ERROR
          SBN    E38-E20
          NJN    EPC5        IF NOT -NO CONTROLLER RESPONSE-
 EPC2     BSS
          LDML   UNITS,UX    IF CONTROLLER HUNG, READ PERFORMANCE
          LPC    0#EFFF       LOG AFTER SLAVE RESET
          LMC    /UN/K.NCR   NO CONTROLLER RESPONSE BIT
          STML   UNITS,UX
 EPC5     BSS
          LDML   /SS/P.RECOV,CSST
          ZJN    EPC15       IF INITIALIZATION CONFIDENCE TEST
          SBN    2
          ZJK    EPC50       IF SLAVE RESET ALREADY ISSUED
          LDML   /SS/P.CT,CSST
          LMN    1
          NJN    EPC8        IF CONFIDENCE TEST FAILED
 .U       IFNE   UNIX,1
          RJM    CFME        CHECK FOR MEDIA ERROR
          NJN    EPC10       IF NOT A MEDIA ERROR
 .U       ENDIF
 .E       IFEQ   ERRD,1      TO READ UNCORRECTABLE DATA
          RJM    RRD         READ RAW DATA
 .E       ENDIF
          LDK    /RS/K.DATERR SOFTWARE FLAW THE ALLOCATION UNIT
          STML   RS+/RS/P.DATERR
          LDN    E62         MEDIA ERROR
          STML   RS+/RS/P.ERRID
          LJM    EPF
 EPC8     BSS
          LMN    1
          NJN    EPC10       IF CONFIDENCE TEST COMPLETE
          RJM    SFRR        CLEAR CIP, IF
          LDN    2
          STML   /SS/P.CT,CSST INDICATE CONFIDENCE TEST FAILED
 EPC10    BSS
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
 EPC15    BSS
          LDN    2
          STML   /SS/P.RECOV,CSST INDEX TO NEXT STEP OF RECOVERY
          LDN    E50         SLAVE RESET STARTED
          STML   RS+/RS/P.ERRID
          RJM    INTRS       INTERMEDIATE RESPONSE
          LDDL   PTF         PATH TEST FLAG
          ZJN    EPC20       IF INITIALIZATION PATH TEST
          RJM    RCC         SETUP FOR RESTART CONTROLLER COMMANDS
          LDC    0#C000      COMMAND IN PROG., 2 COMMANDS IN PROG.
          RJM    SCB         SET COMMAND IN PROGRESS BITS
 EPC20    BSS
          RJM    SRI         SET RESET ISSUED FLAG
          RJM    ISR         ISSUE SLAVE RESET (NO RETURN)
 EPC50    BSS
          LDML   UNITS,UX
          LPC    /UN/K.NCR
          STDL   T5          SAVE NO CONTROLLER RESPONSE FLAG
          LDML   UNITS,UX
          LPC    0#EFFF
          STML   UNITS,UX    CLEAR -NO CONTROLLER RESPONSE- BIT
          LDML   RS+/RS/P.ERRID
          LMC    E72
          NJK    EPC100      IF NOT MACHINE EXCEPTION
          LDN    ID16
          RJM    SFP         SEARCH FOR PARAMETER
          LDML   RPB+6,T3
          LPC    0#FEE0
          LMC    0#6000
          NJK    EPC100      IF SLAVE RESET FAILED
          LDN    2
          STML   /SS/P.RESET,CSST INDICATE ASYNCH FOR SLAVE RECEIVED

*         WITH MICROCODE 9A OR LATER A LOGICAL RESET IMMEDIATELY AFTER
*         SLAVE RESET FAILS.  A DELAY SHOULD PREVENT THIS FAILURE.

          LDC    1000
          STDL   T6          PAUSE 5 SECONDS
 EPC60    BSS
          PAUSE  5000
          RJM    PPRQ        CHECK FOR IDLE REQUEST
          SODL   T6
          NJN    EPC60       IF PAUSE NOT COMPLETE
          LDDL   T5
          ZJN    EPC70       IF CONTROLLER WAS NOT HUNG
          LDN    8           GO TO EPC70 IF ERROR
          STML   /SS/P.RECOV,CSST
          RJM    REL         READ ERROR LOG
          LDK    E52         SLAVE RESET PASSED, ERROR CODE PRESENT
          UJN    EPC80
 EPC70    BSS
          LDN    E51         SLAVE RESET PASSED
 EPC80    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    INTRS       INTERMEDIATE RESPONSE
          LDML   /SS/P.CT,CSST
          LMN    4
          ZJK    EPE40       IF CONFIDENCE TEST DETECTED A DATA
                              INTEGRITY PROBLEM
          LDN    7           INDEX TO NEXT STEP OF RECOVERY (EPD50)
          STML   /SS/P.RECOV,CSST
          RJM    DUSC        DISABLE USAGE STATISTIC COUNTING
          AOML   /SS/P.RQTRY,CSST REQUEST RETRY COUNT
          LJM    MAIN10
 EPC100   BSS
          LDDL   PTF
          ZJN    EPC110      IF IN PATH TEST
          LDML   RS+/RS/P.ERRID
          SBN    E20
          MJN    EPC110      IF PROBABLY NOT CABLE PROBLEM
          SBN    E50-E20
          PJN    EPC110      IF PROBABLY NOT CABLE PROBLEM
          RJM    INTRS       REPORT INTERMEDIATE RESPONSE
          UJN    EPD
 EPC110   BSS
          RJM    OFFCM       TURN OFF ALL UNITS ON CM3 (NO RETURN)

 EPCT     BSS    8           UX FOR RESET CONTROLLER
          SPACE  5,20
*
* PATH TEST (ROUTINE PT WORKED ONCE, SLAVE RESET FAILED, MAY BE DAISY
*            CHAIN PROBLEM.)
*
 EPD      BSS
          LDDL   PTF
          NJN    EPD10       IF NOT IN INITIALIZATION CONFIDENCE TEST
          RJM    CTR         CONFIDENCE TEST RECOVERY
          LDN    2
          STML   /SS/P.CT,CSST INDICATE CONFIDENCE TEST FAILED
          UJK    EPC110
 EPD10    BSS
          LDML   /SS/P.RECOV,CSST
          LMN    3
          ZJN    EPD55       IF PATH TEST ALREADY STARTED
          AOML   /SS/P.RQTRY,CSST REQUEST RETRY COUNT
          LDN    3
          STML   /SS/P.RECOV,CSST INDEX TO NEXT RECOVERY STEP
          RJM    RAR         SETUP FOR RESTARTING ALL REQUESTS
          LDN    0
          STDL   PTF         FORCE RUNNING PATH TEST
          LJM    MAIN10
 EPD50    BSS                ENTER HERE IF ERROR AFTER SLAVE RESET
          LDDL   PTF
          NJN    EPD60       IF PATH TEST SUCCESSFUL
 EPD55    BSS
          RJM    OFFCM       TURN OFF ALL UNITS ON CM3 (NO RETURN)
 EPD60    BSS
          RJM    INTRS       INTERMEDIATE RESPONSE
          SPACE  5,20
*
* DRIVE DIAGNOSTICS
*
 EPE      BSS
          LDML   /SS/P.RECOV,CSST
          LMN    4
          ZJN    EPE50       IF DIAGNOSTIC COMMAND ALREADY ISSUED
          LDN    4           INDEX TO THIS RECOVERY PROCEDURE
          STML   /SS/P.RECOV,CSST
          AOML   /SS/P.RQTRY,CSST REQUEST RETRY COUNT
          RJM    RCC         SETUP FOR RESTART CONTROLLER COMMAND
          RJM    LIR         LOGICAL INTERFACE RESET
          RJM    PDD         PERFORM DRIVE DIAGNOSTICS
          LDML   /SS/P.CT,CSST
          LMN    4
          ZJN    EPE40       IF DATA INTEGRITY ERROR
          LDN    5
          STML   /SS/P.RECOV,CSST INDEX TO RECOVERY PROCEDURE
          LJM    MAIN10
 EPE40    BSS
          LDK    E111        CM-DRIVE DATA INTEGRITY
          STML   RS+/RS/P.ERRID RESET ERROR IDENTIFIER
 EPE50    BSS
          UJN    EPF5
          SPACE  5,20
*
* IF FINAL REQUEST RETRY FAILED
*
 EPF      BSS
          LDML   /SS/P.CT,CSST
          LMN    1
          ZJN    EPF10       IF CONFIDENCE TEST PASSED
 EPF5     BSS
          LDK    /RS/K.UDN   UNIT DOWN
          STML   RS+/RS/P.ID
 .U       IFEQ   UNIX,1
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       ENDIF
          RJM    OFFUN       TURN OFF UNIT
 .U       IFNE   UNIX,1
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       ENDIF
          UJN    EPF20
 EPF10    BSS
          LDC    R.ABN*0#4000 ABNORMAL TERMINATION
          STML   RS+/RS/P.RC RESPONSE CODE
 .U       IFEQ   UNIX,1
          LDN    0
          STML   RS+/RS/P.SHORT   INDICATE ERROR RESPONSE
 .U       ENDIF
          LDC    RLIE
          STML   RS+/RS/P.RESPL BYTE LENGTH OF RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    DCR         DELINK REQUEST
 .U       IFEQ   UNIX,1
 EPF20    BSS
 .U       ENDIF
          RJM    RESPIN      UPDATE -IN- POINTER IN RESPONSE BUFFER
 .U       IFNE   UNIX,1
 EPF20    BSS
 .U       ENDIF
          LDN    6
          STML   /SS/P.RECOV,CSST INDEX TO NEXT RECOVERY STEP
          RJM    LIR         LOGICAL INTERFACE RESET
          SPACE  5,20
*
* ENTER HERE IF PREVIOUS LOGICAL INTERFACE RESET WORKS OR FAILS
*
 EPG      BSS
          RJM    RCC         SETUP FOR RESTART CONTROLLER COMMANDS
          LDN    0
          STDL   IF          CLEAR INITIALIZATION FLAG
          STML   /SS/P.RQTRY,CSST CLEAR RETRY COUNT
          LDML   /SS/P.FNC,CSST
          SBN    4
          NJN    EPG10       IF NOT FORMAT COMMAND
          STML   FIP         CLEAR FORMAT IN PROGRESS FLAG
 EPG10    LJM    MAIN10
 .F       IFEQ   FE,1        FORCE ERROR CODE
          SPACE  5,20
** NAME-- FER
*
** PURPOSE-- FORCE ERROR ROUTINE.  THE ERROR CAN BE FORCED BY CHANGING
*            CENTRAL MEMORY WORD 8.  SOME ROUTINES REQUIRE THE UNIT
*            NUMBER TO BE IN CENTRAL MEMORY WORD 9.
          SPACE  2
 FERX     LJM    **
 FER      EQU    *-1
          LDN    0
          STDL   T1
          LRDL   T1
          LDN    8           READ CENTRAL MEMORY WORD 8
          STDL   P1
          CRDL   P2
          LDDL   P2
          ZJN    FERX        IF NOT FORCING AN ERROR
          STDL   FEST
          LPN    77B
          STDL   P6          INDEX TO TABLE
          SBN    FETND-FET
          PJN    FERX        IF UNDEFINED VALUE
          LDN    0
          STDL   P2
          LDDL   P1
          CWDL   P2          INDICATE ERROR BEING FORCED
          LDDL   FEST
          SHN    -8
          STDL   FEST        FORCE ERROR START COUNT
          LDDL   P3
          STDL   FEND        FORCE ERROR END COUNT OR UNIT NUMBER
          LDDL   P1
          ADN    1
          CRDL   P2
          LDDL   P2
          STDL   FEUN        UNIT TO FORCE ERROR ON
          LDML   FET,P6
          STDL   P2
          LJM    0,P2        JUMP TO FORCE ERROR ROUTINE
* TABLE OF ERRORS TO FORCE
 FET      BSS
          CON    FERX        NO ERROR
          CON    FERA        LOWER ICI PARITY ERROR ON READ
          CON    FERB        DROP SELECT DURING READ
          CON    FERC        LOWER ICI PARITY ERROR ON WRITE
          CON    FERD        DROP SELECT DURING WRITE
          CON    FERE        READ ONE TOO MANY WORDS (RECOVERABLE)
          CON    FERF        READ ONE TOO FEW WORDS (RECOVERABLE)
          CON    FERG        WRITE ONE TOO MANY WORDS (RECOVERABLE)
          CON    FERH        WRITE ONE TOO FEW WORDS (UNRECOVERABLE)
          CON    FERI        READ DATA IPI P.E. (RECOVERABLE)
          CON    FERJ        WRITE DATA IPI P.E. (RECOVERABLE)
          CON    FERK        SPIN DOWN UNIT
          CON    MAIN5       INITIALIZE, RUN PATH, CONF. TEST
          CON    FERM        COMMAND EXCEPTION FOR READ OR WRITE
          CON    FERN        LOWER ICI PARITY ERROR IN PATH TEST
          CON    FERO        UNABLE TO SELECT ERROR IN PATH TEST
          CON    FERP        COMMAND EXCEPTION ERROR IN PATH TEST
          CON    FERQ        LOWER ICI PARITY ERROR IN CONFIDENCE TEST
          CON    FERR        UNABLE TO SELECT ERROR IN CONFIDENCE TEST
          CON    FERS        COMMAND EXCEPTION ERROR IN CONFIDENCE TEST
          CON    FERT        CHANGE ONE MEMORY LOCATION
 FETND    BSS
          SPACE  5,20
** NAME-- FERA
*
** PURPOSE-- FORCE LOWER ICI PARITY ERROR ON READ
*            8 = XX01 YYYY
*            9 = CCDD
*                X = SECTORS TO READ BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*                CC = CM3 NUMBER
*                DD = DRIVE NUMBER
          SPACE  2
 FERA     BSS
          LDC    FERA10
          UJN    FERB5
 FERA10   CON    0
          STDL   T1          SAVE FUNCTION
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJK    FERB20      IF WRONG DRIVE
          SODL   FEST
          PJN    FERB20      IF NOT TIME TO FORCE ERROR
          LDC    H0C22       FORCE LOWER ICI PARITY ERROR
          RJM    FUNC        SEND THE FUNCTION
          UJN    FERB15
          SPACE  5,20
** NAME--FERB
*
** PURPOSE-- DROP SELECT DURING READ
*            8 = XX02 YYYY
*            9 = CCDD
*                X = SECTORS TO READ BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*                CC = CM3 NUMBER
*                DD = DRIVE NUMBER
          SPACE  2
 FERB     BSS
          LDC    FERB10
 FERB5    BSS
          STML   READ34
          LJM    MAIN10
 FERB10   CON    0
          STDL   T1          SAVE FUNCTION
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJN    FERB20      IF WRONG UNIT
          SODL   FEST
          PJN    FERB20      IF NOT TIME TO FORCE ERROR
          RJM    MR          MASTER RESET
 FERB15   BSS
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERB20      IF NOT TIME TO RESTORE INSTRUCTION
          LDC    FUNC
          STML   READ34      RESTORE FUNCTION
 FERB20   BSS
          LDDL   T1
          RJM    FUNC        SEND FUNCTION
          LJM    READ34+1    RETURN TO READ ROUTINE
          SPACE  5,20
** NAME-- FERC
*
** PURPOSE-- FORCE LOWER ICI PARITY ERROR ON WRITE
*            8 = XX03 YYYY
*            9 = CCDD
*                X = SECTORS TO WRITE BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*                CC = CM3 NUMBER
*                DD = DRIVE NUMBER
          SPACE  2
 FERC     BSS
          LDC    FERC10
          UJN    FERD5
 FERC10   CON    0
          STDL   T1
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJK    FERD20      IF WRONG UNIT
          SODL   FEST
          PJN    FERD20      IF NOT TIME TO FORCE ERROR
          LDC    H0C22       FORCE LOWER ICI PARITY ERROR
          RJM    FUNC        SEND THE FUNCTION
          UJN    FERD15
          SPACE  5,20
** NAME-- FERD
*
** PURPOSE-- DROP SELECT DURING WRITE
*            8 = XX04 YYYY
*            9 = CCDD
*                X = SECTORS TO WRITE BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*                CC = CM3 NUMBER
*                DD = DRIVE NUMBER
          SPACE  2
 FERD     BSS
          LDC    FERD10
 FERD5    BSS
          STML   WRI34
          LJM    MAIN10
 FERD10   CON    0
          STDL   T1          SAVE FUNCTION
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJN    FERD20      IF WRONG UNIT
          SODL   FEST        FORCE ERROR START COUNT
          PJN    FERD20      IF NOT TIME TO FORCE ERROR
          RJM    MR          MASTER RESET
 FERD15   BSS
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERD20      IF NOT TIME TO RESTORE INSTRUCTION
          LDC    FUNC
          STML   WRI34       RESTORE THE INSTRUCTION
 FERD20   BSS
          LDDL   T1
          RJM    FUNC        SEND FUNCTION
          LJM    WRI34+1     RETURN TO WRITE ROUTINE
          SPACE  5,20
** NAME-- FERE
*
** PURPOSE-- READ ONE TOO MANY WORDS
*            8 = 0005
          SPACE  2
 FERE     BSS
          LDC    FERE10
          UJN    FERF5
 FERE10   CON    0
          AODL   WC
          UJN    FERF15
          SPACE  5,20
** NAME-- FERF
*
** PURPOSE-- READ ONE TOO FEW WORDS
*            8 = 0006
          SPACE  2
 FERF     BSS
          LDC    FERF10
 FERF5    BSS
          STML   READ32
          LJM    MAIN10
 FERF10   CON    0
          SODL   WC
 FERF15   BSS
          LDC    BCS         RESTORE INSTRUCTION
          STML   READ32
          LJM    READ32-2
          SPACE  5,20
** NAME-- FERG
*
** PURPOSE-- WRITE ONE TOO MANY WORDS
*            8 = 0007
          SPACE  2
 FERG     BSS
          LDC    FERG10
          UJN    FERH5
 FERG10   CON    0
          AODL   WC
          AODL   WC          *TEMP UNTIL ADAPTER FIXED
          UJN    FERH15
          SPACE  5,20
** NAME-- FERH
*
** PURPOSE-- WRITE ONE TOO FEW WORDS
*            8 = 0008
          SPACE  2
 FERH     BSS
          LDC    FERH10
 FERH5    BSS
          STML   WRI32
          LJM    MAIN10
 FERH10   CON    0
          SODL   WC
 FERH15   BSS
          LDC    BCS
          STML   WRI32       RESTORE INSTRUCTION
          LJM    WRI32-2
          SPACE  5,20
** NAME-- FERI
*
** PURPOSE-- FORCE IPI PARITY ERROR ON INPUT DURING READ
*            8 = 0009
          SPACE  2
 FERI     BSS
          LDC    FERI10
          STML   READ34
          LJM    MAIN10
 FERI10   CON    0
          LDC    FUNC
          STML   READ34      RESTORE MODIFIED INSTRUCTION
          LDC    H0322
          RJM    FUNC        FORCE BUS A INPUT PARITY ERROR
          LJM    READ34-3
          SPACE  5,20
** NAME-- FERJ
*
** PURPOSE-- FORCE IPI PARITY ERROR ON OUTPUT DURING WRITE
*            8 = 000A
          SPACE  2
 FERJ     BSS
          LDC    FERJ10
          STML   WRI34
          LJM    MAIN10
 FERJ10   CON    0
          LDC    FUNC
          STML   WRI34       RESTORE MODIFIED INSTRUCTION
          LDC    H0122
          RJM    FUNC        FORCE BUS A OUTPUT PARITY ERROR
          LJM    WRI34-3
          SPACE  5,20
** NAME-- FERK
*
** PURPOSE-- SPIN DOWN UNIT TO FORCE NOT READY ERROR
*            8 = 000B CCDD
*                C = CONTROLLER NUMBER
*                D = DRIVE NUMBER
*         THIS SHOULD ONLY BE USED WHEN THERE ARE NO OUTSTANDING
*         COMMANDS FOR THE CM3.
          SPACE  2
 FERK     BSS
          LDN    0#A
          STML   CP          PACKET LENGTH
          STML   CP+CRN      COMMAND REFERENCE NUMBER
          LDC    H0700       SET OPERATING MODE COMMAND
          STML   CP+OPCD     OPERATION
          LDDL   FEND
          STML   CP+SLAD     CONTROLLER, UNIT NUMBER
          STML   RPB+SLAD
          SHN    -8
          STDL   CMOD        CONTROLLER NUMBER
          LDC    0#351       DISC MODES
          STML   CP+FCP
          LDC    0#4000
          STML   CP+FCP+1    SPIN DOWN UNIT
          RJM    DARH        THIS FINDS UX AND CSST
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          ZJK    MAIN10      IF SUCCESSFUL
          LDN    E00
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSOR (NO RETURN)
          SPACE  5,20
** NAME-- FERM
*
** PURPOSE-- CHANGE CYLINDER NUMBER TO ILLEGAL VALUE
*            TO FORCE AN ERROR ON WRITE OR READ
*            8 = XX0D YYYY
*            9 = CCDD
*                X = COMMANDS TO SEND BEFORE FORCING FIRST ERROR
*                Y + 1 = TIMES TO FORCE THE ERROR
*                CC = CM3 NUMBER
*                DD = DRIVE NUMBER
          SPACE  2
 FERM     BSS
          LDC    FERM10
          STML   SEEK20
          LJM    MAIN10
 FERM10   CON
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJN    FERM20      IF WRONG DRIVE
          SODL   FEST
          PJN    FERM20      IF NOT TIME TO FORCE ERROR
          LCN    0
          STML   CP+FCP+3    ILLEGAL CYLINDER NUMBER
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERM20      IF NOT TIME TO RESTORE INSTRUCTION
          LDC    CPT
          STML   SEEK20      RESTORE INSTRUCTION
 FERM20   BSS
          RJM    CPT         COMMAND PACKET TRANSFER
          LJM    SEEK20+1    RETURN TO SEEK ROUTINE
          SPACE  5,20
** NAME-- FERN
*
** PURPOSE-- FORCE LOWER ICI PARITY ERROR IN PATH TEST
*            8 = XX0E YYYY
*                X = TIMES TO RUN PATH TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERN     BSS
          LDC    FERN10
          UJN    FERP5
 FERN10   CON    0
          SODL   FEST
          PJN    FERP20      IF NOT TIME TO FORCE ERROR
          LDC    H0C22       FORCE LOWER ICI PARITY ERROR
          RJM    FUNC        SEND THE FUNCTION
          UJN    FERP30
          SPACE  5,20
** NAME-- FERO
*
** PURPOSE-- DISABLE THE CONTROLLERS RECEIVERS TO PREVENT SELECTING
*            DURING THE PATH TEST
*            8 = XX0F YYYY
*                X = TIMES TO RUN PATH TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERO     BSS
          LDC    FERO10
          UJN    FERP5
 FERO10   CON    0
          SODL   FEST
          PJN    FERP20      IF NOT TIME TO FORCE ERROR
          RJM    MR          MASTER RESET
          UJN    FERP30
          SPACE  5,20
** NAME--FERP
*
** PURPOSE-- FORCE COMMAND EXCEPTION DURING THE PATH TEST
*            BY SENDING AN ILLEGAL BYTE COUNT
*            8 = XX10 YYYY
*                X = TIMES TO RUN PATH TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERP     BSS
          LDC    FERP10
 FERP5    BSS
          STML   PT40
          LJM    MAIN10
 FERP10   CON    0
          SODL   FEST
 FERP20   BSS
          PJN    FERP40      IF NOT TIME TO FORCE ERROR
          LCN    0
          STML   CP+FCP+1    ILLEGAL BYTE COUNT
 FERP30   BSS
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERP40      IF NOT TIME TO RESTORE INSTRUCTION
          LDC    CPT
          STML   PT40        RESTORE INSTRUCTION
 FERP40   BSS
          RJM    CPT         COMMAND PACKET TRANSFER
          LJM    PT40+1      RETURN TO PATH TEST
          SPACE  5,20
** NAME-- FERQ
*
** PURPOSE-- FORCE LOWER ICI PARITY ERROR IN CONFIDENCE TEST
*            8 = XX11 YYYY
*                X = TIMES TO RUN CONFIDENCE TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERQ     BSS
          LDC    FERQ10
          UJN    FERS5
 FERQ10   CON    0
          SODL   FEST
          PJN    FERS20      IF NOT TIME TO FORCE ERROR
          LDC    H0C22       FORCE LOWER ICI PARITY ERROR
          RJM    FUNC        SEND THE FUNCTION
          UJN    FERS30
          SPACE  5,20
** NAME-- FERR
*
** PURPOSE-- DISABLE THE CONTROLLERS RECEIVERS TO PREVENT SELECTING
*            DURING THE CONFIDENCE TEST
*            8 = XX12 YYYY
*                X = TIMES TO RUN CONFIDENCE TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERR     BSS
          LDC    FERR10
          UJN    FERS5
 FERR10   CON    0
          SODL   FEST
          PJN    FERS20      IF NOT TIME TO FORCE ERROR
          RJM    MR          MASTER RESET
          UJN    FERS30
          SPACE  5,20
** NAME--FERS
*
** PURPOSE-- FORCE COMMAND EXCEPTION DURING THE CONFIDENCE TEST
*            BY SENDING AN ILLEGAL CYLINDER NUMBER
*            8 = XX13 YYYY
*              X = TIMES TO RUN CONFIDENCE TEST BEFORE FORCING FIRST ERROR
*              Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERS     BSS
          LDC    FERS10
 FERS5    BSS
          STML   CTDT7
          LJM    MAIN10
 FERS10   CON    0
          SODL   FEST
 FERS20   BSS
          PJN    FERS40      IF NOT TIME TO FORCE ERROR
          LCN    0
          STML   CP+FCP+3    ILLEGAL CYLINDER NUMBER
 FERS30   BSS
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERS40      IF NOT TIME TO RESTORE INSTRUCTION
          LDC    CPT
          STML   CTDT7       RESTORE INSTRUCTION
 FERS40   BSS
          RJM    CPT         COMMAND PACKET TRANSFER
          LJM    CTDT7+1     RETURN TO CONFIDENCE TEST
          SPACE  5,20
** NAME-- FERT
*
** PURPOSE-- CHANGE ONE MEMORY LOCATION
*            8 = 0014
*            9 = 0000 0000 XXXX YYYY
*              X = ADDRESS
*              Y = VALUE
          SPACE  2
 FERT     BSS
          LDDL   P5
          STIL   P4
          LJM    MAIN20
 .F       ENDIF
          SPACE  5,20
** NAME-- FU
*
** PURPOSE-- FORMAT UNIT
          SPACE  2
 FUX      LJM    **
 FU       EQU    *-1
          LDN    E57         FORMATTING DRIVE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDML   /SS/P.UNIT,CSST
          STML   RS+/RS/P.UNIT  PORT, CONTROLLER, DRIVE ADDRESS
          LDN    0
          STML   RS+/RS/P.SCYL  STARTING CYLINDER
          STML   RS+/RS/P.FTRK  SO TRACK, SECTOR WILL BE 0 IN CRITICAL WINDOW
          STML   RS+/RS/P.FSEC
          RJM    INTRS       SEND INTERMEDIATE RESPONSE

*         FORMAT THE UNIT

          LDN    12
          STML   CP          COMMAND PACKET LENGTH
          LDDL   UX
          STML   CP+CRN
          LDC    0#280D
          STML   CP+OPCD     INITIAL FORMAT COMMAND
          LDC    0#53B
          STML   CP+FCP      LOGICAL SECTOR SIZE
          LDN    0
          STML   CP+FCP+1    UPPER BYTES OF SECTOR SIZE
          LDC    2048        LOWER BYTES OF SECTOR SIZE
          STML   CP+FCP+2
          LDML   /SS/P.UNIT,CSST
          STML   CP+SLAD     CONTROLLER, UNIT NUMBER
          LDN    2           SET COMMANDS ISSUED
          STDL   CMNDS
          STML   FIP         FORMAT IN PROGRESS
          RJM    CPT         COMMAND PACKET TRANSFER
          UJK    FUX
          SPACE  5,20
** NAME-- GETRQ
*
** PURPOSE-- DETERMINE WHETHER OR NOT TO USE MASTER TERMINATE.
*            MASTER TERMINATE MEANS USE A LARGE SECTOR COUNT AND
*            TERMINATE WHEN THERE IS NO MORE DATA TO TRANSFER.
*            MASTER TERMINATE ONLY WORKS WITH MICROCODE LEVEL 8
*            AND LATER.  SINCE THERE IS A PERFORMANCE PENALTY
*            ON READS, ONLY USE MASTER TERMINATE FOR READS WHEN
*            MORE THAN ONE PAGE IS TO BE TRANSFERRED.  IF USING
*            MASTER TERMINATE, SET THE MASTER TERMINATE FLAG AND
*            EXIT.
*
*            IF NOT USING MASTER TERMINATE, COMPUTE
*            THE TOTAL BYTES TO TRANSFER AND SAVE IN SS TABLE.
*            THE PP DRIVER WILL ISSUE UP TO 2 COMMANDS PER DRIVE.
*            IF NO COMMANDS ARE OUTSTANDING, GET THE FIRST REQUEST
*            FROM CM, GET THE FIRST COMMAND FROM THE REQUEST AND SET
*            UP THE STATUS RESPONSE BUFFER.  IF ONE COMMAND IS STILL
*            ACTIVE FOR THE DRIVE, GETTING THE REQUEST INTO THE SS
*            TABLE WILL BE DONE IN ROUTINE DCR.
          SPACE  2
 GETRX    LJM    **
 GETRQ    EQU    *-1
          LDN    0
          STDL   TOTAL
          STDL   TOTAL+1
          STML   CP+FCP+1    UPPER WORD OF SECTOR COUNT
          LDDL   CSST
          STDL   P6          SAVE CURRENT SS TABLE POINTER
          LDC    IPIT
          STDL   CSST        START OF ALTERNATE SS TABLE
          LDDL   CNUM
          ZJN    GETR2       IF FIRST COMMAND
          LDML   /SS/P.RMA2,P6
          STML   /SS/P.REQ,CSST
          LDML   /SS/P.RMA2+1,P6
          UJN    GETR3
 GETR2    BSS
          LDML   /SS/P.REQ,P6
          STML   /SS/P.REQ,CSST
          LDML   /SS/P.REQ+1,P6
 GETR3    BSS
          STML   /SS/P.REQ+1,CSST
          RJM    UREQ        READ UNIT REQUEST FROM CM
          LDML   RQ+/RQ/P.CYL,CSST
          STML   CP+FCP+3    CYLINDER
          LDML   RQ+/RQ/P.TRACK,CSST
          SHN    8
          ADML   RQ+/RQ/P.SECTOR,CSST
          STML   CP+FCP+4    HEAD, SECTOR
          RJM    UNCMND      GET FIRST COMMAND
          LDML   /SS/P.MREV,P6
          SHN    -12
          SBN    8
          MJK    GETR10      IF MASTER TERMINATE NOT SUPPORTED
*
*         IF IN RECOVERY AND USING MASTER TERMINATE, THIS GUARANTEES A
*         WRITE ERROR FOR THE NTH REQUEST DOES NOT RETURN AN ERROR FOR
*         A PREVIOUS REQUEST.
*         WITH 8A MICROCODE AND IF USING MASTER TERMINATE, THE CM3 READS
*         AHEAD AND WILL REPORT AN ERROR FOR A SECTOR READ EVEN IF IT IS
*         NOT SENT TO THE PP.  SOMETIMES AN ERROR ON THE READ AHEAD WILL
*         CAUSE THE CM3 TO NOT SEND A COMPLETION RESPONSE.
*
          LDML   /SS/P.RQTRY,P6
          NJK    GETR10      IF IN ERROR RECOVERY
          LDML   CM+/CM/P.CODE,CSST
          SHN    -12
          SBN    5
          ZJN    GETR6       IF WRITE (USE MASTER TERMINATION)
          LDML   RQ+/RQ/P.SWIT,CSST
          LPC    77777B
          SBN    1
          ZJN    GETR10      IF MAU COUNT = 1 (NO MASTER TERMINATION)
          LDML   /SS/P.LISTL,CSST
          SBN    1
          ZJN    GETR10      IF ONLY ONE LIST
 GETR6    BSS
          LDDL   P6
          STDL   CSST        RESTORE POINTER TO SS TABLE
          LDDL   CNUM
          ZJN    GETR7       IF FIRST COMMAND FOR UNIT
          LDC    0#8000
          STML   /SS/MT2,CSST INDICATE MASTER TERMINATE BEING USED
          LJM    GETRX
 GETR7    BSS
          LDC    0#8000
          STML   /SS/MT,CSST INDICATE MASTER TERMINATE BEING USED
          LJM    GETR45
 GETR9    BSS
          RJM    UNCMND      GET FIRST COMMAND
 GETR10   BSS
          LDML   CMLIST+/CM/P.LEN,CSST NUMBER OF BYTES TO TRANSFER
          RADL   TOTAL+1     TOTAL BYTES TO TRANSFER
          SHN    -16
          RADL   TOTAL
          SOML   /SS/P.LISTL,CSST DECREMENT ADDRESS-LENGTH-PAIR COUNT
          ZJN    GETR20      IF END OF RMA LIST
          RJM    GLIST       READ NEXT INDIRECT ENTRY
          UJN    GETR10
 GETR20   BSS
          RJM    UNCMND      GET NEXT COMMAND
          NJK    GETR10      IF MORE COMMANDS
          LDML   RQ+/RQ/P.SWIT,CSST CHECK IF REQUEST SWITCH FLAG IS SET
          SHN    /RQ/L.SWIT+2
          PJN    GETR30      IF SWITCH FLAG IS NOT SET
          LDML   /SS/P.RQTRY,P6
          NJN    GETR30      IF IN ERROR RECOVERY.  THIS GUARANTEES THAT
                              AN ERROR IN THE NTH CONCATENATED REQUEST DOES
                              NOT CAUSE A PREVIOUS REQUEST TO BE RETURNED
                              AS UNRECOVERABLE.
          LDML   RQ+/RQ/P.NEXT,CSST PUT RMA OF NEXT REQUEST IN SS TABLE
          STML   /SS/P.REQ,CSST
          LDML   RQ+/RQ/P.NEXT+1,CSST
          STML   /SS/P.REQ+1,CSST
          RJM    UREQ        READ UNIT REQUEST FROM CM
          UJK    GETR9

 GETR30   BSS
          LDDL   P6
          STDL   CSST        RESTORE POINTER TO SS TABLE
          LDDL   CNUM
          ZJN    GETR40      IF FIRST COMMAND FOR UNIT
          LDDL   TOTAL+1
          SHN    -3
          STML   /SS/P.TW2+1,CSST TOTAL CM WORDS TO TRANSFER
          LDDL   TOTAL
          LPN    7
          SHN    13
          RAML   /SS/P.TW2+1,CSST
          LDDL   TOTAL
          SHN    -3
          STML   /SS/P.TW2,CSST
          UJN    GETR50
 GETR40   BSS
          LDDL   TOTAL+1
          SHN    -3
          STML   /SS/P.TOTAL+1,CSST TOTAL CM WORDS TO TRANSFER
          LDDL   TOTAL
          LPN    7
          SHN    13
          RAML   /SS/P.TOTAL+1,CSST
          LDDL   TOTAL
          SHN    -3
          STML   /SS/P.TOTAL,CSST
 GETR45   BSS
          RJM    UREQ        READ UNIT REQUEST FROM CM
          RJM    SRESP       SET UP STATUS FOR RESPONSE BUFFER
          RJM    SETRQ       SET UP FOR FIRST REQUEST
          RJM    UNCMND      GET FIRST COMMAND
 GETR50   BSS
          UJK    GETRX
          SPACE  5,20
** NAME-- GETUD
*
** PURPOSE-- GET A UNIT REQUEST FROM CENTRAL, ISSUE ALL
*            SEEKS, AND PROCESS INTERRUPTS FROM THE CM3
          SPACE  2
 GETUDX   LJM    **
 GETUD    EQU    *-1
          LDDL   UNUML
          ZJN    GETUDX      IF NO UNITS
          RJM    UC          UPDATE CLOCK
          PAUSE  6           ALLOW CM3 TIME TO PUT ITS ADDRESS
                             ON THE BUS IF IT HAS AN INTERRUPT
          LDN    0
          AJM    GETU5,DC    IF NO FUNCTION REPLY
          ACN    DC+40B
          EJM    GETU5,DC    IF CHANNEL NOT FULL
          IAN    DC
          LPC    377B
 GETU5    BSS
          STDL   STATUS      SAVE INTERRUPT STATUS
          LDC    H0711
          RJM    FAN         DROP MASTER OUT
          LDDL   LUX         UNIT INDEX OF LAST REQUEST FOUND + 1
          STDL   P6
 GETU10   BSS
          LDDL   LUX
          STDL   UX
          LDN    P.UN
          RADL   LUX         BUMP UNIT ENTRY
          SBDL   UNUML
          MJN    GETU20      IF NOT END OF TABLE
          STDL   LUX
 GETU20   BSS
          LDML   UNITS,UX
          SHN    -/UN/N.UNIT
          LPN    7
          STDL   CMOD        SAVE CONTROL MODULE NUMBER
          LDML   UNITS,UX
          SHN    /UN/L.CIP+2
          PJK    GETU38      IF NO COMMAND IN PROGRESS
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO CURRENT SS TABLE
          LDML   SELT,CMOD   MASK VALUE
          LPDL   STATUS      INTERRUPT STATUS
          ZJN    GETU22      IF NO INTERRUPT FOR THIS CONTROL MODULE
          RJM    PI          PROCESS INTERRUPT (NO RETURN)
 GETU22   LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          MJN    GETU24      IF TWO COMMANDS IN PROGRESS
          SHN    /UN/L.DTIP-/UN/L.TCIP
          MJK    GETU34      IF SECOND COMMAND CAN BE ISSUED
          ERRMI  /UN/L.DTIP-/UN/L.TCIP-1 IF PREVIOUS SHIFT INCORRECT
          LDDL   IF
          NJK    GETU34      ISSUE SECOND COMMAND IF INITIALIZATION
 GETU24   BSS
          LDML   /SS/P.FNC,CSST
          SBN    4
          ZJN    GETU27      IF FORMAT COMMAND
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    GETU25      IF CLOCK HASNT WRAPPED
          ADC    0#10000
 GETU25   SBN    32          30 TO 31 SECOND TIMEOUT
          PJK    GETU100     IF TIMEOUT
          UJK    GETU30
 GETU27   LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    GETU28      IF CLOCK HASNT WRAPPED
          ADC    0#10000
 GETU28   ADC    -FDT        9000 SECOND TIMEOUT VALUE
          PJK    GETU100     IF TIMEOUT

* GO TO NEXT UNIT ENTRY.

 GETU30   BSS
          LDDL   LUX         HAVE ALL ENTRIES BEEN CHECKED
          SBDL   P6
          ZJK    GETUDX      IF NO MORE ENTRIES TO CHECK
          UJK    GETU10

* DETERIMINE IF DRIVE TESTING REQUIRED

 GETU34   BSS
          LDN    1
          STDL   CNUM        INDICATE SECOND COMMAND TO UNIT
          LDDL   IF
          ZJK    GETU40      IF INITIALIZATION NOT REQUIRED
          LDML   /SS/P.CT,CSST
          LPN    7
          NJK    GETU24      IF NO NEED TO RUN CONFIDENCE TEST
          LDDL   CMNDS
          NJK    GETU30      IF MORE CMNDS TO PROCESS
          RJM    CD          CHECK DRIVE
          NJN    GETU36      IF BYPASS CONFIDENCE TEST
          RJM    CT          RUN CONFIDENCE TEST
 GETU36   LJM    GETUDX      EXIT

* NO COMMANDS IN PROGRESS.
* CHECK FOR ANY REQUESTS ON THIS UNIT QUEUE.

 GETU38   BSS
          LDN    0           INDICATE FIRST COMMAND TO UNIT
          STDL   CNUM
          LDDL   IF
          NJK    GETU30      IF CONFIDENCE TEST SHOULD BE RUN
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T5          READ UNIT DISABLED FLAG
          ADN    /UIT/C.NEXT
          CRDL   T1          READ RMA OF NEXT REQUEST FROM UNIT QUEUE
          LDDL   T3
          ADDL   T4
          ZJK    GETU30      IF NO REQUESTS ON THIS QUEUE
          LDDL   T5+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJK    GETU30      IF UNIT DISABLED

* PROCESS COMMAND FOR UNIT

 GETU40   BSS
 .U       IFEQ   UNIX,1
          LDDL   MALET       NONZERO IF MAINTENANCE REQUEST
 .U       ELSE
          LDDL   IDLE        NONZERO IF IDLE COMMAND
          ADDL   MALET       NONZERO IF MAINTENANCE REQUEST
 .U       ENDIF
          NJK    GETU65      IF NOT STARTING REQUESTS
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO CURRENT SS TABLE
          RJM    SR          SELECT REQUEST
          NJN    GETU65      IF REQUEST NOT FOUND
          RJM    GETRQ       GET REQUEST
          LDML   /SS/P.CT,CSST
          LPN    7
          ZJK    GETU50      IF NEED TO RUN CONFIDENCE TEST
          LDDL   FNC
          SBN    4
          NJN    GETU60      IF NOT FORMAT
 GETU50   LDDL   CNUM
          NJK    GETU24      IF SECOND COMMAND
          STML   /SS/P.CT,CSST  ENABLE RUNNING CONFIDENCE TEST
          LDML   UNITS,UX    SET COMMAND IN PROGRESS FLAG
          LMC    0#8000
          STML   UNITS,UX
          STDL   IF          SET INITIALIZATION FLAG
          UJN    GETU62
 GETU60   RJM    SEEK        ISSUE INITIAL SEEK
 GETU62   BSS
          LJM    MAIN15
 GETU65   BSS
          LDDL   CNUM
          NJK    GETU24      IF COMMAND IN PROGRESS, CHECK TIMER
          UJK    GETU30

* TIMEOUT PROCESSING

 GETU100  BSS
          LDML   /SS/P.RESET,CSST
          ZJN    GETU120     IF RESET NOT ISSUED
          LPN    1
          ZJN    GETU104     IF ASYNCH FOR DRIVE EXPECTED
          LDML   EPCT,CMOD
          STDL   UX          UNIT ISSUING RESET
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE
          LDC    SRT         SLAVE RESET TIMEOUT
          UJN    GETU108
 GETU104  BSS
          LDC    DST         DRIVE SPINUP TIMEOUT
 GETU108  BSS
          STDL   T1
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    GETU110     IF CLOCK HASNT WRAPPED
          ADC    0#10000
 GETU110  BSS
          SBDL   T1
          PJN    GETU120     IF TIMEOUT
          LJM    GETU30
 GETU120  BSS
          LDN    E38         NO CM3 INTERRUPT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- GLIST
*
** PURPOSE-- READ ONE ENTRY FROM THE CM ADDRESS LIST PORTION OF A COMMAND.
*
** INPUT-- LISTL
*
** OUTPUT-- CMLIST, CM+/CM/P.RMA
          SPACE  2
 GLIX     LJM    **
 GLIST    EQU    *-1
          LDDL   CSST        ADDRESS OF SS TABLE
          ADK    CMLIST
          STML   GLIST4      ADDRESS TO STORE CM LIST
          LDN    1
          STDL   WD          NUMBER OF CM WORDS TO READ
          LOADF  CM+/CM/P.RMA,CSST LOAD CM ADDRESS AND REFORMAT
          CRML   *,WD        READ ONE ENTRY FROM THE LIST
 GLIST4   EQU    *-1
          LDN    8
          RAML   CM+/CM/P.RMA+1,CSST UPDATE RMA ADDRESS FOR NEXT READ
          SHN    -16
          RAML   CM+/CM/P.RMA,CSST
          LDML   CMLIST+/CM/P.LEN,CSST  ENSURE AN EVEN NUMBER OF WORDS
          ADN    7
          SCN    7
          STML   CMLIST+/CM/P.LEN,CSST
          UJK    GLIX
          SPACE  5,20
** NAME-- IH
*
** PURPOSE-- INTERRUPT HANDLER.  INPUT THE RESPONSE PACKET.  THROW AWAY
*            ASYNCHRONOUS RESPONSES FOR UNITS NOT CONFIGURED.  REPORT
*            ASYNCHRONOUS DRIVE ERROR RESPONSES FOR CONFIGURED UNITS.
*
** EXIT
*         A = MAJOR STATUS
*         THE DRIVE IS DESELECTED
          SPACE  2
 IHX      LJM    **
 IH       EQU    *-1
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,UX SAVE CLOCK IN TABLE
          LDML   CP+OPCD
          NJN    IH1         IF NOT LOGICAL INTERFACE RESET
          LDN    3           2 TO 4 SECOND TIMEOUT
          UJN    IH6
 IH1      BSS
          LMC    H0800
          ZJN    IH5         IF DRIVE POWER ON RESET (NEEDS 45 SECONDS)
          LDML   CP+OPCD
          LMC    8400
          ZJN    IH2         IF READ PERFORMANCE LOG
          LDML   /SS/P.RESET,CSST
          NJN    IH4         IF RESET ISSUED
 IH2      BSS
          LDN    32          APPROXIMATELY 31 SECOND TIMEOUT
          UJN    IH6
 IH4      BSS
          SHN    17
          MJN    IH5         IF SLAVE RESET
          LDC    DST         DRIVE SPINUP TIMEOUT
          UJN    IH6
 IH5      BSS
          LDC    SRT         SLAVE RESET TIMEOUT
 IH6      BSS
          STDL   T7          SAVE TIMEOUT VALUE
 IH10     BSS
          RJM    RI          REQUEST INTERRUPTS
          LDML   SELT,CMOD   MASK VALUE
          LPDL   STATUS      INTERRUPT STATUS
          NJN    IH15        IF INTERRUPT PRESENT
          RJM    UC          UPDATE CLOCK
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    IH12        IF CLOCK HAS NOT WRAPPED
          ADC    0#10000
 IH12     BSS
          SBDL   T7
          MJN    IH10        IF TIMEOUT NOT EXPIRED
          LDK    E38         NO CM3 INTERRUPT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 IH15     BSS
          RJM    DTM         DETERMINE TRANSFER MODE
          RJM    SEL         SELECT THE CONTROLLER
          STDL   CTM         CLEAR CHANNEL TRANSFER MODE FLAG
          RJM    RPT         RESPONSE PACKET TRANSFER
          RJM    DCM         DESELECT THE CONTROL MODULE
          LDML   RPB+MAJST   MAJOR STATUS
          SHN    -4
          LPN    0#F
          LMN    AR
          NJN    IH20        IF NOT ASYNCHRONOUS RESPONSE
          LDML   RPB+SLAD
          LPC    0#FF
          LMC    0#FF
          ZJN    IH30        IF ASYNCHRONOUS RESPONSE FOR CONTROLLER
          RJM    DARH        DRIVE ASYNCHRONOUS RESPONSE HANDLER
          LDDL   T8
          STDL   UX          RESTORE UX
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO CURRENT SS TABLE
          UJN    IH40        GO LOOK FOR ANOTHER INTERRUPT
 IH20     BSS
          LDML   RPB+MAJST   MAJOR STATUS
          LJM    IHX
 IH30     BSS
          LDK    ID16
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    IH20        IF ID 16 NOT FOUND
          LDML   RPB+6,T3
          SHN    8
          PJN    IH20        IF NOT CONTROLLER OVER TEMPERATURE
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 IH40     BSS
          LJM    IH10
          SPACE  5,20
** NAME-- INTERR
*
** PURPOSE-- REPORT AN INTERFACE ERROR
          SPACE  2
 INTERR   CON    0
          STML   RS+/RS/P.IEC INTERFACE ERROR CODE
          LDK    /RS/K.INTERR  INTERFACE ERROR
          STML   RS+/RS/P.INTERR  ABNORMAL STATUS CODE
          LDK    E120        SOFTWARE FAILURE
          STML   RS+/RS/P.ERRID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       IFEQ   UNIX,1
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 .U       ENDIF
          RJM    HANG        (NO RETURN)
          SPACE  5,20
** NAME-- INTRS
*
** PURPOSE-- SEND INTERMEDIATE RESPONSE.
          SPACE  2
 INTRSX   LJM    **
 INTRS    EQU    *-1
          LDDL   PTF
          NJN    INTRS10     IF REQUEST EXISTS
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       IFEQ   UNIX,1
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 .U       ENDIF
          UJK    INTRSX

 INTRS10  BSS
 .U       IFEQ   UNIX,1
          LDN    0
          STML   RS+/RS/P.SHORT   INDICATE ERROR RESPONSE
 .U       ENDIF
          LDC    RLIE
          STML   RS+/RS/P.RESPL BYTE LENGTH OF RESPONSE
          LDN    R.INT       INTERMEDIATE RESPONSE
          SHN    16-/RS/N.RC-/RS/L.RC
          STML   RS+/RS/P.RC RESPONSE CODE
          RJM    TERMP       SEND RESPONSE TO CM
          UJK    INTRSX
          SPACE  5,20
** NAME--ISR
*
** PURPOSE-- ISSUE SLAVE RESET
          SPACE  2
 ISR      CON    0
          LDC    H8415       SLAVE RESET
          STML   CP+OPCD     SO TIMEOUT WILL BE LONG IN IH
          RJM    IR          ISSUE RESET
          LDML   /SS/P.CT,CSST
          ZJN    ISR10       IF IN SUBSYSTEM CONFIDENCE TEST
          LJM    MAIN15
 ISR10    BSS
          RJM    IH          INTERRUPT HANDLER
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETRUN)
          SPACE  5,20
** NAME-- IU
*
** PURPOSE-- INITIALIZE UNIT. CALLED DURING FORMAT OPERATION.
 IUX      LJM    **
 IU       EQU    *-1
          LOADF  CMLIST+/CM/P.RMA,CSST  ADDRESS OF LIST WITH FORMAT PARAMTER
          CRDL   P1          READ WORD WITH PARAMETER
          LDDL   P3
          NJK    IU10        IF UNCONDITIONAL FORMAT
          RJM    IUF         IS UNIT FORMATTED
          NJK    IU10        IF UNIT IS NOT FORMATTED
          LDN    2           CMNDS WILL GET DECREMENTED TWICE
          STDL   CMNDS
          LDN    0
          LJM    TERM20      TERMINATE REQUEST
 IU10     BSS
          LDML   UNITS,UX
          LPC    0#3FFF
          LMC    0#C000      INDICATE TWO COMMANDS ISSUED
          STML   UNITS,UX
          RJM    FU          FORMAT UNIT
          UJK    IUX
          SPACE  5,20
** NAME-- IUF
*
** PURPOSE-- IS UNIT FORMATTED.
*
** EXIT-- A=0 IF UNIT FORMATTED AT CORRECT SECTOR SIZE
          SPACE  2
 IUFX     LJM    **
 IUF      EQU    *-1
          LDN    10
          STML   CP          COMMAND PACKET LENGTH
          LDC    0#200
          STML   CP+OPCD     ATTRIBUTE COMMAND
          LDC    0#36C
          STML   CP+FCP      PARAMETER TO READ REV NUMBER
          LDC    0#4051
          STML   CP+FCP+1    RETURN REV NUMBER IN RESPONSE
          LDML   /SS/P.UNIT,CSST
          STML   CP+SLAD     CONTROLLER, UNIT NUMBER
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          ZJN    IUF05       IF SUCCESSFUL
          LPC    IVR         INTERVENTION REQUIRED
          ZJN    IUF10       IF UNEXPECTED STATUS
          LDK    ID24
          RJM    SFP         SEARCH FOR PARAMETER
          LDML   RPB+8,T3
          SHN    2
          MJK    IUFX        IF DRIVE NOT FORMATTED
          UJN    IUF10       UNEXPECTED STATUS
 IUF05    LDC    ID51
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    IUF10       IF ID 51 NOT FOUND
          LDML   RPB+7,T3    SECTOR SIZE IN BYTES
          ADC    -2048       EXPECTED SECTOR SIZE
          LJM    IUFX
 IUF10    BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- LIR
*
** PURPOSE-- LOGICAL INTERFACE RESET
          SPACE  2
 LIRX     LJM    **
 LIR      EQU    *-1
          LDN    0
          STML   CP+OPCD     SO TIMEOUT WILL BE SHORT IN IH
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE
          LDC    H8215       LOGICAL INTERFACE RESET
          RJM    IR          ISSUE RESET
          RJM    IH          INTERRUPT HANDLER
          SHN    -4
          LPN    0#F
          LMN    AR
          NJN    LIR20       IF NOT ASYNCHRONOUS RESPONSE
          LDN    ID16
          RJM    SFP         CHECK FOR MACHINE EXCEPTION
          MJN    LIR20       IF MACHINE EXCEPTION ID NOT FOUND
          LDML   RPB+6,T3
          LPC    0#FEE0
          LMC    0#6000
          NJN    LIR20       IF ERROR
          UJK    LIRX
 LIR20    BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- LOCK
*
** PURPOSE-- SET THE LOCKWORD
*
** ENTRY
*         T7 = POINTER RMA
*         T5 = OFFSET TO LOCKWORD FROM RMA
*
** EXIT
*         A = 0 IF LOCK SUCCESSFULLY SET
          SPACE  2
 LOCKX    LJM    **
 LOCK     EQU    *-1
 LOCK1    BSS
          LCN    0
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE
          LDDL   T1
          ZJN    LOCK5       IF LOCK COULD BE SET
          ADDL   T2
          ADC    -177777B-177777B
          ZJK    LOCK1       IF INTERMEDIATE VALUE
          LDDL   T2
          LPC    77777B
          ADC    100000B
          STDL   T2          SET THE VE BIT
          LDDL   T6
          CWDL   T1          RESTORE THE LOCKWORD WITH THE VE BIT
          LDDL   T4
          SBDL   PPNO        CHECK IF LOCK ALREADY SET
          NJN    LOCK3       IF LOCK COULD NOT BE SET, EXIT A .NE. 0
          LDDL   T1
          ADC    -100000B
 LOCK3    UJK    LOCKX       IF LOCK WAS ALREADY SET, EXIT A = 0
                             IF LOCK COULD NOT BE SET, EXIT A .NE. 0
 LOCK5    BSS
          LDC    100000B
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          LDDL   PPNO
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          CWDL   T1          SET THE LOCKWORD
          LDN    0
          UJK    LOCKX
          SPACE  5,20
** NAME-- OFFCH
*
** PURPOSE-- TURN OFF ALL UNITS ON A CHANNEL
          SPACE  2
 OFCX     LJM    **
 OFFCH    EQU    *-1
          LDN    0
          STDL   UX          UNITS TABLE INDEX
 OFC10    BSS
          RJM    OFFUN       SET UNIT DISABLE FLAG
          LDN    P.UN
          RADL   UX          BUMP UNITS TABLE INDEX
          SBDL   UNUML
          NJK    OFC10       IF NOT END OF TABLE
          UJK    OFCX
          SPACE  5,20
** NAME-- OFFCM
*
** PURPOSE-- TURN OFF ALL UNITS ON A CONTROL MODULE.
          SPACE  2
 OFFCM    CON    0
 .U       IFEQ   UNIX,1
          LDK    /RS/K.CMDN  CONTROLLER DOWN
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       ENDIF
          LDDL   UX
          STDL   P5          POINTER TO CURRENT UNITS TABLE
          LDN    0
          STDL   UX          UNITS TABLE INDEX
 OFFCM10  BSS
          LDML   UNITS,P5    COMPARE IF SAME CONTROL MODULE
          LMML   UNITS,UX
          LPN    70B
          NJN    OFFCM20     IF NOT THE SAME CONTROL MODULE
          RJM    OFFUN       SET UNIT DISBLE FLAG
 OFFCM20  BSS
          LDN    P.UN
          RADL   UX          BUMP UNITS TABLE INDEX
          SBDL   UNUML
          NJK    OFFCM10     IF NOT END OF TABLE
 .U       IFEQ   UNIX,1
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 .U       ELSE
          LDK    /RS/K.CMDN  CONTROLLER DOWN
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       ENDIF
          LJM    MAIN10
          SPACE  5,20
** NAME-- OFFUN
*
** PURPOSE-- SET THE DISABLE FLAG IN THE UNIT INTERFACE TABLE.
*
** OUTPUT-- P5 IS UNCHANGED
          SPACE  2
 OFUX     LJM    **
 OFFUN    EQU    *-1
          LDK    /UIT/K.DSABLE  SET UNIT DISABLE FLAG
          STDL   T3
          LDN    0
          STDL   T2
          STDL   T4
          STDL   T5
          LOADR  UNITS+/UN/P.UIT,UX ADDRESS OF UNIT INTERFACE TABLE
          RDSL   T2          -LOGICAL OR- THE UNIT DISABLE FLAG

*         NOTE THAT REQUEST RETRIES DO NOT ALLOW STREAMING SO SFRR WILL
*         NOT SEND A RESPONSE.

          RJM    SFRR        SETUP FOR REQUEST RETRY (MAKE CMNDS ACCURATE)
          UJK    OFUX
          SPACE  5,20
** NAME-- PCER
*
** PURPOSE-- PREPARE COMMON ERROR RESPONSE
*
** INPUT  A = ERROR ID
          SPACE  2
 PCERX    LJM    **
 PCER     EQU    *-1
          STDL   P2
          SBN    E20
          ZJN    PCER10      IF ERROR CODE 20
          SBN    E22-E20
          MJN    PCER20      IF ERROR CODE 0-19, 21
          SBN    E23-E22
          MJN    PCER10      IF ERROR CODE 22
          SBN    E27-E23
          MJN    PCER20      IF ERROR CODE 23-26
          SBN    E29-E27
          MJN    PCER10      IF EC 27 OR 28
          ZJN    PCER20      IF EC 29
          SBN    E30-E29
          NJN    PCER20      IF ERROR CODE 31-XX
 PCER10   BSS
          LDC    H00E1       READ STATUS REGISTER
          RJM    RDRG        READ REGISTER
          STDL   STATUS      SAVE CONTENTS OF STATUS REGISTER
 PCER20   BSS
 .U       IFEQ   UNIX,1
          LDML   /SS/P.XFER,CSST BYTES TRANSFERRED
          STML   RS+/RS/P.XFER
          LDML   /SS/P.XFER+1,CSST
          STML   RS+/RS/P.XFER+1
          LDML   /SS/P.LU,CSST PUT LOGICAL UNIT IN RESPONSE
          STML   RS+/RS/P.LU
 .U       ENDIF
          RJM    PDR         PREPARE NORMAL DISK RESPONSE
          LDDL   P2
          LMN    E38
          NJN    PCER26      IF NOT -NO CONTROLLER RESPONSE-
          LDML   /SS/P.RESET,CSST
          SHN    17
          MJN    PCER26      IF NO ASYNCH AFTER SLAVE RESET
          SHN    17
          PJN    PCER26      IF ERROR ALREADY ISOLATED
          LDK    E95         NO DRIVE OPERATIONAL RESPONSE
          UJN    PCER32
 PCER26   BSS
          LDDL   P2
          NJN    PCER32      IF ERROR ALREADY ISOLATED
          LDN    ID14
          RJM    SFP         SEARCH FOR ID 14
          MJN    PCER30      IF NOT CM3 INTERVENTION REQUIRED
          LDK    E71
          UJN    PCER32
 PCER30   BSS
          LDN    ID16
          RJM    SFP         SEARCH FOR ID 16
          MJN    PCER35      IF NOT CM3 MACHINE EXCEPTION
          LDML   RPB+6,T3
          SHN    8
          PJN    PCER31      IF NOT CONTROLLER OVER TEMPERATURE
          LDK    E78
          UJN    PCER32
 PCER31   BSS
          LDK    E72
 PCER32   BSS
          UJN    PCER45
 PCER35   BSS
          LDN    ID17
          RJM    SFP         SEARCH FOR ID 17
          MJN    PCER40      IF NOT CM3 COMMAND EXCEPTION
          LDML   RPB+5,T3
          SHN    -8
          SBN    6
          MJN    PCER38      IF BYTE 5 NOT PRESENT
          LDML   RPB+8,T3
          SHN    6
          PJN    PCER38      IF NOT RESERVED TO OTHER PORT
          LDK    E77         DRIVE RESERVED TO OTHER CM3 PORT
          UJN    PCER45
 PCER38   BSS
          LDK    E73
          UJN    PCER45
 PCER40   BSS
          LDN    ID13
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    PCER55      IF NOT ID13
          LDML   RPB+6,T3    FIRST WORD AFTER ID13
          SHN    5
          PJN    PCER50      IF NOT MESSAGE FROM CONTROLLER
          LDK    E60         CONTROLLER ERROR
 PCER45   BSS
          UJN    PCER70
 PCER50   BSS
          LDK    E74         MICROCODE EXECUTION ERROR
          UJN    PCER70
 PCER55   BSS
          LDN    ID15
          RJM    SFP         SEARCH FOR ID 15
          MJN    PCER60      IF NOT ALTERNATE PORT EXCEPTION
          LDK    E75
          UJN    PCER70
 PCER60   BSS
          LDK    ID23
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    PCER65      IF NOT ID23
          LDML   RPB+6,T3    FIRST WORD AFTER ID23
          SHN    5
          PJN    PCER65      IF NOT MESSAGE FROM DRIVE DIAGNOSTICS
          LDK    E61         DRIVE ERROR
          UJN    PCER70
 PCER65   BSS
          LDN    E00         CP MUST ISOLATE THE ERROR
 PCER70   BSS
          STML   RS+/RS/P.ERRID
          LDDL   WC          WORDS NOT TRANSFERRED
          STML   RS+/RS/P.WC
          LDDL   LF
          STML   RS+/RS/P.FUNTO FAILING FUNCTION IF E01
          LDDL   STATUS      STATUS REGISTER
          STML   RS+/RS/P.STREG
          LDC    H00F1
          RJM    RDRG        READ ERROR REGISTER
          STML   RS+/RS/P.ERREG SAVE ERROR REGISTER
          LDML   /SS/P.MREV,CSST
          SHN    -8
          STML   RS+/RS/P.MREV CM3 MICROCODE REVISION
          RJM    SDA         SAVE DISK ADDRESS
          LDDL   CHAN
          STML   RS+/RS/P.CHAN CHANNEL NUMBER
          LDML   UNITS,UX
          LPN    77B
          STML   RS+/RS/P.UNIT CONTROLLER, UNIT NUMBER
          LDN    0
          STML   RS+/RS/P.ID
          LDML   /SS/P.RQTRY,CSST
          STML   RS+/RS/P.RTRY REQUEST RETRY COUNT
 .F       IFEQ   FE,1
          LDML   SRRC
          STML   RS+/RS/P.FILL1 NO DATA TRANSFERRED ERROR COUNT
 .F       ENDIF
          UJK    PCERX
          SPACE  5,20
** NAME-- PDD
*
** PURPOSE-- PERFORM DRIVE DIAGNOSTICS
          SPACE  2
 PDDX     LJM    **
 PDD      EQU    *-1
          LDN    6           COMMAND PACKET LENGTH
          STML   CP
          LDC    H8100       PERFORM DRIVE DIAGNOSTIC OP CODE
          STML   CP+OPCD
          LDML   /SS/P.UNIT,CSST
          STML   CP+SLAD     CONTROLLER, UNIT NUMBER
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          ZJK    PDDX        IF SUCCESSFUL
          LDN    E00         CP MUST DETERMINE THE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- PDR
*
** PURPOSE-- PREPARE NORMAL DISK RESPONSE
          SPACE  2
 PDRX     LJM    **
 PDR      EQU    *-1
 .U       IFNE   UNIX,1
          LDML   /SS/P.XFER,CSST  BYTES TRANSFERRED
          STML   RS+/RS/P.XFER
          LDML   /SS/P.XFER+1,CSST
          STML   RS+/RS/P.XFER+1
 .U       ENDIF
          LDML   /SS/P.FPVA,CSST PVA OF REQUEST
          STML   RS+/RS/P.PVA
          LDML   /SS/P.FPVA+1,CSST
          STML   RS+/RS/P.PVA+1
          LDML   /SS/P.FPVA+2,CSST
          STML   RS+/RS/P.PVA+2
 .U       IFEQ   UNIX,1
          LDN    8
 .U       ELSE
          LDML   /SS/P.LU,CSST  PUT LOGICAL UNIT IN RESPONSE
          STML   RS+/RS/P.LU
          LDK    /RS/C.LASTC*8+8
 .U       ENDIF
          STML   RS+/RS/P.RESPL NORMAL RESPONSE LENGTH
          LDN    0
          STML   RS+/RS/P.DATERR ABNORMAL STATUS WORD
          STML   RS+/RS/P.IEC INTERFACE ERROR CODE WORD
 .U       IFEQ   UNIX,1
          LDML   /SS/P.LU,CSST
          LPC    0#FF        RIGHT-MOST 8 BITS OF LOGICAL UNIT
          LMC    /RS/K.SHORT  INDICATE ONE-WORD RESPONSE
          STML   RS+/RS/P.SHORT
 .U       ELSE
          LDN    R.NRM
          SHN    16-/RS/N.RC-/RS/L.RC
          STML   RS+/RS/P.RC  NORMAL RESPONSE CODE
 .U       ENDIF
          UJK    PDRX
          SPACE  5,20
** NAME-- PI
*
** PURPOSE-- PROCESS INTERRUPT
          SPACE  2
 PI       CON    0
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE
          LDML   /SS/P.RESET,CSST
          ZJN    PI3         IF RESET NOT ISSUED
          LDML   EPCT,CMOD
          STDL   UX          CORRECT UX FOR RESET
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE
          RJM    DTM         DETERMINE TRANSFER MODE
 PI3      BSS
          RJM    SEL         SELECT CONTROLLER
          STDL   CTM         CLEAR CHANGE TRANSFER MODE FLAG
 PI10     BSS
          RJM    RPT         RESPONSE PACKET TRANSFER
          LDML   RPB+MAJST   MAJOR STATUS
          STDL   T6
          SHN    -4
          LPN    0#F
          SBN    CC
          NJK    PI40        IF NOT STANDARD COMMAND COMPLETION
          RJM    DCM         DESELECT THE CONTROL MODULE
          RJM    STI         SET TABLE INDEXES
          LDDL   T6
          SHN    SC
          MJK    PI25        IF SUCCESSFUL
          SHN    CS-SC
          PJK    PI100       IF NOT CONDITIONAL SUCCESS
          LDML   /SS/MT,CSST
          SHN    2
          PJN    PI20        IF NOT USING MASTER TERMINATE
          LDML   RPB+5
          LPC    0#FF
          LMC    ID19
          NJN    PI20        IF RESPONSE NOT DUE TO MASTER TERMINATE
          LDML   RPB
          SBN    15
          PJN    PI20        IF RESPONSE TOO LONG
          LDML   RPB+7
          SHN    9
          MJK    PI30        IF MASTER TERMINATE
 PI20     BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
 .U       IFEQ   UNIX,1
          LDN    0
          STML   RS+/RS/P.SHORT  INDICATE ERROR RESPONSE
 .U       ENDIF
          LDC    RLIE
          STML   RS+/RS/P.RESPL BYTE LENGTH OF RESPONSE
          LDC    0#5000
          STML   RS+/RS/P.RC RECOVERED, INTERMEDIATE RESPONSE
          RJM    TERMP       SEND RESPONSE TO CM
 .U       IFNE   UNIX,1
          LDN    0                CLEAR BYTES TRANSFERRED
          STML   /SS/P.XFER,CSST
          STML   /SS/P.XFER+1,CSST
 .U       ENDIF
          UJN    PI30
 PI25     BSS
          LDML   RPB+OPCD
          LMC    H0400
          NJN    PI30        IF NOT DRIVE RESERVE
          LDML   UNITS,UX
          LPC    0#17FF
          LMC    /UN/K.RD
          STML   UNITS,UX    SET DRIVE RESERVED BIT
          SODL   CMNDS       OUTSTANDING COMMANDS
          LJM    MAIN15
 PI30     BSS
          RJM    TERM        COMMAND COMPLETED WITHOUT ERROR (NO RETURN)
 PI40     BSS
          SBN    TN-CC
          NJN    PI60        IF NOT TRANSFER NOTIFICATION
          RJM    STI         SET TABLE INDEXES
          RJM    RDWT        READ WRITE SETUP
          NJN    PI45        IF EXPECTED RESPONSE
          AODL   TBC         INDICATE COMPLETION RESPONSE SHOULD BE PRESENT
          LJM    PI10
 PI45     BSS
          LDML   /SS/P.FNC,CSST
          ZJN    PI50        IF READ
          RJM    WRITE       IF WRITE (RETURN IS TO IDLE LOOP)
 PI50     BSS
          RJM    READ        READ
          LJM    MAIN15
 PI60     BSS
          RJM    DCM         DESELECT THE CONTROL MODULE
          LDML   RPB+SLAD
          LPC    0#FF
          LMC    0#FF
          ZJN    PI100       IF ASYNCH FOR CONTROLLER
          RJM    DARH        DRIVE ASYNCHRONOUS RESPONSE HANDLER
          LJM    MAIN20
 PI100    BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 .U       IFEQ   UNIX,1
          SPACE  5,20
** NAME-- PPRQ
*
** PURPOSE-- CHECK FOR ANY PP REQUESTS ON THE PP QUEUE.
          SPACE  2
 PPRQX    LJM    **
 PPRQ     EQU    *-1
          LCN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDC    0#7FFF
          STDL   T4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          RDCL   T1          CLEAR ACTIVE CHECK BIT, READ PPIT WORD 1
          LDDL   T4
          SHN    /PIT/L.IDLREQ+2
          MJN    PPRQ10      IF IDLE REQUEST
          SHN    /PIT/L.RESREQ-/PIT/L.IDLREQ
          PJN    PPRQX       IF NOT RESUME OR IDLE REQUEST
          RJM    SPLOCK      SET PP TABLE LOCK
          LDDL   T4
          LPC    0#4FFE      CLEAR ACTIVE CHECK BIT, RESUME REQUEST BIT,
          STDL   T4           IDLE STATUS BIT, AND LOCK BIT IN PP
          LDDL   CM.PIT+1     INTERFACE TABLE
          CWDL   T1
          LJM    MAIN5
 PPRQ10   BSS
          RJM    SPLOCK      SET PP TABLE LOCK
          RJM    RAR         RESTART ALL REQUESTS SET UP
          LDDL   CLF
          NJN    PPRQ15      IF 2 CONSECUTIVE RESUMES AND CHANNEL LOCK
                              ALREADY CLEAR
          RJM    CCLOCK      CLEAR CHANNEL LOCK
 PPRQ15   BSS
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          CRDL   T1
          LDDL   T4          CLEAR ACTIVE CHECK BIT, IDLE REQUEST BIT,
          LPC    0#2FFE       AND SET IDLE STATUS BIT
          LMC    0#1000
          STDL   T4
          LDDL   CM.PIT+1
          CWDL   T1
 PPRQ20   BSS
          RJM    PPRQ        WAIT FOR RESUME
          UJN    PPRQ20
 .U       ELSE
          SPACE  5,20
** NAME-- PPRQ
*
** PURPOSE-- CHECK FOR ANY PP REQUESTS ON THE PP QUEUE.
          SPACE  2
 PPRQX    LJM    **
 PPRQ     EQU    *-1

*         A ONE WORD READ WITH THE CRDL INSTRUCTION AT THE SAME TIME
*         THE PP IS DEADSTARTED COULD CAUSE AN UNCORRECTED CM ERROR ON
*         AN S0 WITH A 60 NANOSECOND CLOCK.  TO AVOID THIS HARDWARE
*         PROBLEM THE CRML INSTRUCTION IS USED.

          LDN    1           NUMBER OF WORDS TO READ
          STDL   WD
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.PPQ  CM ADDRESS OF PP REQUEST QUEUE POINTER
          CRML   T1,WD       READ PP REQUEST QUEUE POINTER
          LDDL   T3          RMA OF NEXT QUEUED PP REQUEST
          ADDL   T4
          ZJN    PPRQX       IF NO PP REQUESTS
          LDC    SSNR
          STDL   CSST        USE SPARE SS TABLE
          RJM    SPLOCK      SET PP QUEUE LOCKWORD
          NJN    PPRQX       IF LOCK WAS NOT SET
          STML   /SS/P.XFER,CSST CLEAR BYTES TRANSFERRED
          STML   /SS/P.XFER+1,CSST
          STML   /SS/P.LU,CSST CLEAR LOGICAL UNIT
          LDN    2
          STDL   P1
          LOADC  CM.PIT
          ADN    /PIT/C.PPQPVA
          CRML   T1,P1       READ PVA AND RMA OF FIRST REQUEST IN CHAIN
          LDDL   T2          SAVE PVA OF REQUEST
          STML   /SS/P.FPVA,CSST
          LDDL   T3
          STML   /SS/P.FPVA+1,CSST
          LDDL   T4
          STML   /SS/P.FPVA+2,CSST
          LDDL   T7          PUT RMA OF REQUEST IN SS TABLE
          STML   /SS/P.REQ,CSST
          LDDL   T8
          STML   /SS/P.REQ+1,CSST
          RJM    UREQ        READ PP REQUEST
          RJM    PDR         PREPARE RESPONSE
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
          LDDL   FNC
          SBN    3
          STDL   IDLE
          ZJN    PPRQ10      IF RESUME COMMAND
          ADN    1
          ZJN    PPRQ5       IF IDLE COMMAND
          LDC    E501        INVALID COMMAND
          RJM    INTERR      REPORT ERROR (NO RETURN)
 PPRQ5    BSS
          RJM    CUB         CHECK UNIT BUSY
          NJN    PPRQ20      EXIT IF COMMANDS IN PROGRESS
          LDDL   CLF
          NJN    PPRQ10      IF LOCK ALREADY CLEAR
          RJM    CCLOCK      CLEAR CHANNEL LOCK
 PPRQ10   BSS
          LOADC  CM.PIT
          ADN    /PIT/C.PPQPVA  CM ADDRESS OF PP QUEUE POINTER
          CWML   SSNR+RQ,P1  WRITE PVA AND RMA POINTERS OF NEXT REQUEST
          RJM    TERMP       SEND TERMINATION RESPONSE
          RJM    CPLOCK      CLEAR PP QUEUE LOCKWORD
          LDDL   FNC
          SBN    3
          ZJN    PPRQ18      IF RESUME COMMAND
 PPRQ13   BSS
          RJM    PPRQ        WAIT FOR RESUME
          UJN    PPRQ13
 PPRQ18   BSS
          LJM    MAIN5
 PPRQ20   BSS
          RJM    CPLOCK      CLEAR PP QUEUE LOCKWORD
          UJK    PPRQX
 .U       ENDIF
          SPACE  5,20
** NAME-- PT
*
** PURPOSE-- TEST THE PATH BETWEEN THE PP AND THE CONTROLLER.
*            IF A PATH TO A CONTROLLER STILL FAILS AFTER AT LEAST
*            ONE RETRY WITH SLAVE RESET, ALL UNITS ON THE FAILING
*            CONTROLLER WILL BE DISABLED.
*
** ENTRY
*         1)  AT INITIALIZATION AFTER PP LOADED
*         2)  AFTER MAINTENANCE HAS USED THE CHANNEL
*         3)  AFTER THE PP HAS RECEIVED A RESUME
*         4)  DURING REQUEST RETRY IF SLAVE RESET FAILS
          SPACE  2
 PT100    BSS
          AODL   PTF         INDICATE PATH TEST COMPLETE
 PTX      LJM    **
 PT       EQU    *-1
          LDDL   UNUML
          ZJN    PT100       IF NO UNITS
          RJM    SCLOCK      SET CHANNEL LOCK
          LDDL   PTF
          NJN    PTX         IF NOT EXECUTING PATH TEST
          STDL   CMOD        CONTROL MODULE NUMBER
          STDL   UX
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE
          RJM    MR          MASTER RESET
          UJN    PT12
 PT8      BSS
          AODL   CMOD
          SBN    8
          PJN    PT100       IF ALL PATHS TESTED
 PT12     BSS
          LDN    0
          STDL   UX
          UJN    PT20
 PT16     BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
 PT20     BSS
          SBDL   UNUML
          PJN    PT8         IF END OF CONFIGURED UNITS
          LDML   UNITS,UX
          SHN    -/UN/N.UNIT
          LPN    7
          LMDL   CMOD
          NJN    PT16        IF DIFFERENT CONTROLLER
          LOADR  UNITS+/UN/P.UIT,UX ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T1          READ UNIT DISABLED FLAG
          LDDL   T1+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJN    PT16        IF UNIT DISABLED
          RJM    LIR         LOGICAL INTERFACE RESET

* WRITE BUFFER

          LDN    RPL
          STML   CP          COMMAND PACKET LENGTH
          LDC    H6200
          STML   CP+OPCD     WRITE TO BUFFER COMMAND
          LDDL   CMOD
          SHN    8
          LMC    0#FF
          STML   CP+SLAD     CONTROLLER, DRIVE NUMBER
          LDC    H0931
          STML   CP+FCP      COMMAND EXTENT PARAMETER
          LDN    0
          STML   CP+FCP+1    UPPER WORD OF BYTE COUNT
          STML   CP+FCP+3    OFFSET
          STML   CP+FCP+4    OFFSET
          LDC    100
          STML   CP+FCP+2    BYTE LENGTH
          RJM    CPT         COMMAND PACKET TRANSFER
 PT40     EQU    *-1         FOR FORCING ERRORS
          RJM    BPTB        BUILD PATH TEST BUFFER
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    PT90        IF NOT TRANSFER NOTIFICATION
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAOUT     DATA, TRANSFER OUT
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0381       STREAM, WRITE FROM PP
          RJM    FUNC        RAISE MASTER OUT
          ACN    DC
          LDN    50          WORD COUNT
          OAM    OB,DC       OUTPUT DATA
          STDL   WC          WORDS NOT TRANSFERRED
          LDC    MS50
 PT50     BSS
          IJM    PT55,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    PT50        IF TIMEOUT NOT EXPIRED
          LDN    E30         CHANNEL STAYED ACTIVE
          UJK    PT84
 PT55     BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT THE CONTROL MODULE
          LDDL   WC
          NJK    PT80        IF INCOMPLETE TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          NJK    PT90        IF NOT SUCCESSFUL

* READ BUFFER

          LDC    H5200
          STML   CP+OPCD     READ FROM CONTROLLER BUFFER
          LDN    RBPL
          STML   CP          COMMAND PACKET LENGTH
          LDC    0#350
          STML   CP+9        BUFFER ADDRESS PARAMETER
          LDC    0#8020
          STML   CP+10       USE DATA BUFFER
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    PT90        IF NOT TRANSFER NOTIFICATION
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAIN      DATA TRANSFER IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0281       STREAM, READ TO PP MEMORY
          RJM    FUNC        RAISE MASTER OUT
          ACN    DC
          LDN    50          WORD COUNT
          IAM    IB,DC
          STDL   WC          WORDS NOT TRANSFERRED
          LDC    MS50
 PT60     BSS
          IJM    PT65,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    PT60        IF TIMEOUT NOT EXPIRED
          RJM    CSI         CHECK SLAVE IN
 PT65     BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESECLECT THE CONTROL MODULE
          LDDL   WC
          NJN    PT80        IF NOT ALL WORDS TRANSFERRED
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          NJN    PT90        IF NOT SUCCESSFUL
          RJM    VPTD        VERIFY PATH TEST DATA
          LJM    PT8
 PT80     BSS
          LDN    E29         INCOMPLETE TRANSFER
 PT84     BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 PT90     BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- RA6F
*
** PURPOSE-- READ ATTRIBUTE 6F
*
** EXIT   A = 0 IF NO ERROR
          SPACE  2
 RA6FX    BSS
          STDL   T1
          LJM    **
 RA6F     EQU    *-1
          LDN    10
          STML   CP          COMMAND PACKET LENGTH
          LDC    H0200
          STML   CP+OPCD     READ OPERATING MODE COMMAND
          LDC    0#36C
          STML   CP+4
          LDC    0#406F
          STML   CP+5        SELECT READING PARAMETER 6F
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          ZJK    RA6FX       IF NO ERROR
          LDN    E00         CPU MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- RAR
*
** PURPOSE-- RESTART ALL REQUESTS
          SPACE  2
 RARX     BSS
          STDL   CMNDS       NO OUTSTANDING COMMANDS
          LJM    **
 RAR      EQU    *-1
          PAUSE  100000      ALLOW CONTROLLER TIME TO WRITE DATA IN
          LDN    0            ITS BUFFER TO DISK
          STDL   UX          POINTER TO UNITS TABLE
          UJN    RAR20
 RAR10    BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
 RAR20    BSS
          SBDL   UNUML
          ZJN    RARX        IF END OF CONFIGURED UNITS
          RJM    SFRR        SET UP FOR REQUEST RETRY
          UJN    RAR10
          SPACE  5,20
** NAME-- RCC
*
** PURPOSE-- RESTART CONTROLLER COMMANDS
          SPACE  2
 RCCX     BSS
          LDDL   T8
          STDL   UX          RESTORE UNITS TABLE POINTER
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE
          LJM    **
 RCC      EQU    *-1
          LDDL   UX
          STDL   T8          SAVE POINTER TO UNITS TABLE
          LDN    0
          STDL   UX          POINTER TO UNITS TABLE
          UJN    RCC20
 RCC10    BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
 RCC20    BSS
          SBDL   UNUML
          PJN    RCCX        IF END OF CONFIGURED UNITS
          LDML   UNITS,UX
          SHN    2+/UN/L.CIP
          PJN    RCC10       IF NO COMMAND IN PROGRESS
          SHN    -5
          LPN    7
          LMDL   CMOD
          NJN    RCC10       IF DIFFERENT CONTROLLER
          RJM    SFRR        SETUP FOR REQUEST RETRY
          UJK    RCC10
          SPACE  5,20
** NAME-- RDRG
*
** PURPOSE-- READ EITHER THE STATUS OR THE ERROR REGISTER
*
** ENTRY--  A = FUNCTION CODE
          SPACE  2
 RDRG10   BSS
          LDN    0
 RDRGX    LJM    **
 RDRG     EQU    *-1
          RJM    FAN         SEND FUNCTION
          AJM    RDRG10,DC   IF NO FUNCTION REPLY
          ACN    DC+40B
          EJM    RDRG10,DC   IF WORD COULD NOT BE READ
          IAN    DC
          UJN    RDRGX
          SPACE  5,20
** NAME-- RDWT
*
** PURPOSE-- SET UP FOR READ OR WRITE.
*
** EXIT
*         A = 0  IF COMPLETION RESPONSE SHOULD BE PRESENT.  IT IS
*                POSSIBLE FOR A TRANSFER NOTIFICATION RESPONSE FOR A STACKED
*                COMMAND TO BE PRESENT BEFORE OR AT THE SAME TIME AS THE COMPLETION
*                RESPONSE FOR THE COMMAND IN PROGRESS.
          SPACE  2
 RDWX     LJM    **
 RDWT     EQU    *-1
          LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          PJN    RDWT10      IF NOT 2 COMMANDS IN PROGRESS
          LDML   RPB+CRN
          SHN    -14
          LMML   /SS/P.CRN,CSST
          LPN    1
          ZJN    RDWX        IF RESPONSE FOR SECOND COMMAND
          UJN    RDWT20
 RDWT10   BSS
          LDML   RPB+CRN
          SHN    -14
          LMML   /SS/P.CRN,CSST
          LPN    1
          NJK    RDWT80      IF COMMAND REFERENCE NUMBER WRONG
 RDWT20   BSS
          LDML   /SS/MT,CSST TOTAL CM WORDS LEFT TO TRANSFER
          SHN    2
          PJN    RDWT30      IF NOT USING MASTER TERMINATE
          LPN    77B
          NJK    RDWT80      IF UNEXPECTED RESPONSE
          UJN    RDWT40
 RDWT30   BSS
          ADML   /SS/P.TOTAL+1,CSST
          ZJN    RDWT80      IF UNEXPECTED RESPONSE
          LDN    0
 RDWT40   BSS
          STDL   DELAY       CLEAR DELAY BITS
          STDL   SECPOS      SET SECTOR POSITION = 0
          LDML   UNITS,UX
          LPC    0#DFFF
          LMC    0#2000
          STML   UNITS,UX    SET DATA TRANSFER IN PROGRESS BIT
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,UX SET CURRENT CLOCK
          LDML   /SS/P.DT,CSST
          SHN    -4
          LPN    3
          STDL   DT          DEVICE TYPE
          LDN    NSBS
          STDL   SBS         SECTORS TO TRANSFER BEFORE SUSPENDING
          UJK    RDWX
 RDWT80   BSS
          LJM    TERM10      REPORT UNEXPECTED RESPONSE ERROR
          SPACE  5,20
** NAME-- RDWTOK
*
** PURPOSE-- SEND RESPONSE FOR COMPLETED READ REQUEST
          SPACE  2
 RDWTX    LJM    **
 RDWTOK   EQU    *-1
          RJM    PDR         PREPARE DISK RESPONSE
          RJM    SNDRSP      SEND RESPONSE TO CM
          AOML   /SS/P.NCOMRQ,CSST INCREMENT NUMBER OF COMPLETED REQUESTS
          LDML   /SS/P.CURRQ,CSST SAVE RMA OF PREVIOUS REQUEST
          STML   /SS/P.PRERQ,CSST
          LDML   /SS/P.CURRQ+1,CSST
          STML   /SS/P.PRERQ+1,CSST
          LDML   /SS/P.REQ,CSST SAVE RMA OF CURRENT REQUEST
          STML   /SS/P.CURRQ,CSST
          LDML   /SS/P.REQ+1,CSST
          STML   /SS/P.CURRQ+1,CSST
          UJK    RDWTX
          SPACE  5,20
** NAME-- RD
*
** PURPOSE-- RESERVE DRIVE.  LEAVING THE DRIVE RESERVED IS SUPPOSE
*            TO SAVE UP TO 600 MICROSECONDS PER COMMAND.
          SPACE  2
 RDX      LJM    **
 RD       EQU    *-1
          LDC    H0400
          STML   CP+OPCD     OPERATION CODE
          LDN    6           COMMAND PACKET LENGTH
          STML   CP
          LDML   /SS/P.UNIT,CSST
          STML   CP+SLAD     CONTROLLER, UNIT NUMBER
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          NJN    RD10        IF ERROR
          LDML   UNITS,UX    INDICATE DRIVE RESERVED
          LPC    0#F7FF
          LMC    /UN/K.RD
          STML   UNITS,UX
          UJK    RDX
 RD10     BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- REL
*
** PURPOSE-- READ ERROR LOG
          SPACE  2
 RELX     LJM    **
 REL      EQU    *-1
          LDN    9           COMMAND PACKET LENGTH
          STML   CP
          LDC    H8400
          STML   CP+OPCD     READ PERFORMANCE LOG COMMAND
          LDDL   CMOD
          SHN    8
          LMC    0#FF
          STML   CP+SLAD     CONTROLLER NUMBER
          LDC    0#2E0
          STML   CP+FCP
          LDC    0#100       SELECT LAST ERROR LOGGED IN EEPROM
          STML   CP+FCP+1
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          ZJN    RELX        IF NO ERROR
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- RESP
*
** PURPOSE-- WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
*
** INPUT-- CM.PIT, CM.RS, LIM, /PIT/IN, /PIT/OUT, RS+/RS/P.RESPL
*
** OUTPUT-- /PIT/IN, RESPONSE BUFFER
          SPACE  2
 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  2
 RESPX    LJM    **
 RESP     EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDN    0
          STML   STORS       SET FLAG TO STORE RESPONSE
          LDML   CM+/CM/P.STOR,CSST CHECK IF CALLER WANTS RESPONSE
          SHN    /CM/L.STOR+2
          MJN    RESP10      IF STORE RESPONSE FLAG IS SET
 .U       IFEQ   UNIX,1
          LDML   RS+/RS/P.SHORT
          SHN    /RS/L.SHORT+2
          PJN    RESP10      IF NOT NORMAL RESPONSE, STORE RESPONSE
 .U       ELSE
          LDML   RS+/RS/P.RC
          SHN    /RS/N.RC+/RS/L.RC-16
          SBN    R.NRM
          NJN    RESP10      IF NOT NORMAL RESPONSE, STORE RESPONSE
 .U       ENDIF
          AOML   STORS       NONZERO MEANS DO NOT STORE RESPONSE
          UJK    RESPX

* READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RESP10   BSS
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF 'IN' POINTER
          CRDL   P1          READ 'IN' POINTER

* CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDN    0
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE
          LDDL   INP
          SBDL   OUTP
          MJN    RESP20      IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP
 RESP20   BSS
          LDML   RS+/RS/P.RESPL  GET RESPONSE LENGTH
          ADDL   INP
          STDL   INPNT       IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
 .U       IFEQ   UNIX,1
          MJN    RESP30      IF ROOM IN BUFFER
          RJM    PPRQ        CHECK FOR IDLE REQUEST
          UJK    RESP10
 RESP30   BSS
 .U       ELSE
          PJK    RESP10      IF NOT ENOUGH ROOM IN BUFFER, LOOP
 .U       ENDIF
          LDDL   INP
          SHN    -3
          STDL   T3          'IN' POINTER IN WORDS
          LDML   RS+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          LDDL   INPNT
          SBDL   LIM
          MJN    RESP50      IF IN + RESPONSE LENGTH .LT. LIMIT
                             ONLY 1 BLOCK WRITE
          STDL   INPNT       IN + RESPONSE LENGTH - LIMIT = NEW 'IN' POINTER
          SHN    -3
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE

* WRITE RESPONSE TO CM.
          LDML   RS+1
          ADML   RS+2
          ADML   RS+3
          NJN    RESP40      IF PVA FOR REQUEST IS PRESENT
          STML   RS+14       INSURE UNSOLICITED RESPONSE CODE RETURNED

 RESP40   LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADC    RS
          STML   RESP60      RESPONSE ADDRESS FOR 2ND BLOCK WRITE
 RESP50   BSS
          LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD 'IN' OFFSET
          CWML   RS,T4       WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          ZJN    RESP70      IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
                             (BEGINNING OF RESPONSE BUFFER)
 RESP60   EQU    *-1

 RESP70   BSS
          LJM    RESPX
          SPACE  5,20
** NAME-- RESPIN
*
** PURPOSE-- UPDATE THE 'IN' POINTER IN THE CM RESPONSE BUFFER.
*
** INPUT-- INPNT = NEW 'IN' POINTER.
          SPACE  2
 RESNX    LJM    **
 RESPIN   EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDML   STORS       CHECK IF CALLER WANTS RESPONSE
          NJK    RESNX       IF NO RESPONSE WAS SENT

* UPDATE THE 'IN' POINTER.

          LDN    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDDL   INPNT       NEW 'IN' POINTER
          STDL   P4
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   P1          WRITE NEW 'IN' POINTER TO CM

* INTERRUPT PROCESSOR. RESP ROUTINE SETS UP THIS INSTRUCTION.

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   PPNO-3      SET LAST BYTE NONZERO
          LDN    0           SET BANK FOR S0
 INTPRC   PSN    0           INTERRUPT OR PSN (MODIFIED)
          UJK    RESNX
          SPACE  5,20
** NAME-- RMR
*
** PURPOSE-- READ CM3 MICROCODE REVISION
          SPACE  2
 RMRX     LJM    **
 RMR      EQU    *-1
          LDN    10
          STML   CP          COMMAND PACKET LENGTH
          LDC    0#200
          STML   CP+OPCD     ATTRIBUTE COMMAND
          LDC    0#36C
          STML   CP+FCP      PARAMETER TO READ REV NUMBER
          LDC    0#4050
          STML   CP+FCP+1    RETURN REV NUMBER IN RESPONSE
          LDML   /SS/P.UNIT,CSST
          SHN    -8
          STDL   CMOD        CONTROLLER NUMBER
          SHN    8
          LMC    0#FF
          STML   CP+SLAD     SLAVE ADDRESS
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          NJN    RMR10       IF NOT SUCCESSFUL
          LDC    ID50
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    RMR10       IF ID 50 NOT FOUND
          LDML   /SS/P.MREV,CSST
          LPC    0#FF
          STML   /SS/P.MREV,CSST
          LDML   RPB+19,T3
          LPC    377B        MASK MICROCODE REVISION NUMBER
          SHN    8
          RAML   /SS/P.MREV,CSST SAVE CM3 MICROCODE REVISION NUMBER
          LJM    RMRX
 RMR10    BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- RNL
*
** PURPOSE-- READ NEXT LIST
          SPACE  2
 RNLX     LJM    **
 RNL      EQU    *-1
          RJM    UBT         UPDATE BYTES TRANSFERRED
          NJN    RNLX        IF NO ERROR
          LDC    E505        CM HAS CHANGED
          RJM    INTERR      REPORT ERROR (NO RETURN)
 .E       IFEQ   ERRD,1      TO READ UNCORRECTABLE DATA
          SPACE  5,20
** NAME-- RRD
*
** PURPOSE-- READ RAW DATA IF DATA FIELD ECC ERROR.
*            IF THE ERROR CODE IS 62 AND THE OP CODE IN THE
*            RESPONSE IS 1107, THE SECTOR WITH THE UNRECOVERED
*            MEDIA ERROR HAS BEEN TRANSFERRED TO CM.
          SPACE  2
 RRDX     LJM    **
 RRD      EQU    *-1
          LDDL   T5          ENDING STATUS FROM ID26
          LPC    0#FF
          LMC    0#D1
          NJN    RRDX        IF NOT DATA FIELD ECC ERROR
          LDN    5
          STML   /SS/P.RECOV,CSST INDEX TO NEXT RECOVERY STEP
          LDML   RPB+8,T3
          STML   CP+FCP+3    CYLINDER
          LDML   RPB+9,T3
          STML   CP+FCP+4    HEAD, SECTOR
          RJM    LIR         LOGICAL INTERFACE RESET
          RJM    RCC         SETUP FOR RESTART CONTROLLER COMMANDS
          RJM    SCP         SETUP COMMAND PACKET PARAMETERS
          LDC    H1107
          STML   CP+OPCD     OPERATION CODE
          LDN    1
          STML   CP+FCP+2    SECTOR COUNT
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJN    RRD20       IF NOT TRANSFER NOTIFICATION
          STDL   SECPOS      CLEAR SECTOR POSITION
          LDN    1
          STDL   SBS         SECTORS TO TRANSFER
          RJM    SEL         SELECT THE CONTROLLER
          RJM    READ        READ ONE SECTOR
          RJM    IH          INTERRUPT HANDLER
          LPN    0#A
          NJK    RRDX        IF SUCCESSFUL OR CONDITIONAL SUCCESS
 RRD20    BSS
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 .E       ENDIF
          SPACE  5,20
** NAME-- SCB
*
** PURPOSE-- SET COMMAND IN PROGRESS BITS IN (UNITS,UX) FOR ONE
*            CONTROLLER
*
** ENTRY  A = BITS TO SET
*         CMOD = CONTROLLER TO SEARCH FOR UNITS
          SPACE  2
 SCBX     LJM    **
 SCB      EQU    *-1
          STDL   P1
          LDN    0
          STDL   T1
          UJN    SCB20
 SCB10    BSS
          LDN    P.UN
          RADL   T1          UPDATE POINTER TO UNITS TABLE
 SCB20    BSS
          SBDL   UNUML
          PJN    SCBX        IF END OF CONFIGURED UNITS
          LDML   UNITS,T1
          SHN    -3
          LPN    7
          LMDL   CMOD
          NJN    SCB10       IF DIFFERENT CONTROLLER
          LDML   UNITS,T1
          LPC    0#1FFF
          LMDL   P1
          STML   UNITS,T1    SET -2 COMMANDS IN PROGRESS-
          UJN    SCB10
          SPACE  5,20
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
          SPACE  2
 SCLX     LJM    **
 SCLOCK   EQU    *-1
 SCL30    BSS
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    SCL30       IF LOCK WAS NOT SET
          STDL   CLF         CLEAR CHANNEL LOCK FLAG
          UJK    SCLX        EXIT, LOCK WAS SET
          SPACE  5,20
** NAME-- SCP
*
** PURPOSE-- SET UP COMMAND PACKET PARAMETERS FOR A WRITE
*            OR READ
          SPACE  2
 SCPX     LJM    **
 SCP      EQU    *-1
          LDN    RPL
          STML   CP          PACKET LENGTH
          AOML   /SS/P.CRN,CSST
          LPC    0#FFF1
          STML   /SS/P.CRN,CSST CLEAR CARRY BIT
          LPN    1
          SHN    14
          ADDL   UX
          STML   CP+CRN      COMMAND REFERENCE NUMBER
          LDDL   FNC
          ZJN    SCP8        IF READ
          SBN    1
          ZJN    SCP4        IF WRITE
          LDC    E501        INVALID COMMAND
          RJM    INTERR      REPORT ERROR (NO RETURN)
 SCP4     BSS
          LDC    H2005
          UJN    SCP12
 SCP8     BSS
          LDC    H1005
 SCP12    BSS
          STML   CP+OPCD     OPERATION
          LDML   /SS/P.UNIT,CSST
          STML   CP+SLAD     CONTROLLER, UNIT NUMBER
          LDC    H0931
          STML   CP+FCP      COMMAND EXTENT PARAMETER
          LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          MJN    SCP15       IF SECOND COMMAND
          LDML   /SS/MT,CSST
          UJN    SCP18
 SCP15    BSS
          LDML   /SS/MT2,CSST
 SCP18    BSS
          SHN    2
          PJN    SCP30       IF NOT USING MASTER TERMINATE
          LDML   /SS/P.DT,CSST
          SHN    -4
          LPN    3
          STDL   DT          DEVICE TYPE
          LDN    0
          STDL   T3
          LDML   CP+FCP+4
          LPN    77B
          STDL   T1          STARTING SECTOR
          LDML   CP+FCP+4
          SHN    -8
          STDL   T2          STARTING TRACK
          LDML   SPT,DT      SECTORS PER TRACK
          SBDL   T1
 SCP20    BSS
          RADL   T3          COMPUTE SECTORS
          AODL   T2
          SBML   TPC,DT      TRACKS PER CYLINDER
          ZJN    SCP40       IF CALCULATION COMPLETE
          LDML   SPT,DT
          UJN    SCP20
 SCP30    BSS
          LDDL   TOTAL+1
          ADC    BPS-1
          STDL   T1          ENSURE SECTOR BOUNDARY
          SHN    -16
          ADDL   TOTAL
          SHN    5
          STDL   T2
          LDDL   T1
          SHN    -11
          ADDL   T2
          UJN    SCP45
 SCP40    BSS
          LDDL   T3
 SCP45    BSS
          STML   CP+FCP+2    SECTOR COUNT
          UJK    SCPX
          SPACE  5,20
** NAME-- SDA
*
** PURPOSE-- SAVE DISK ADDRESS
          SPACE  2
 SDAX     LJM    **
 SDA      EQU    *-1
          LDDL   PTF
          ZJN    SDA10       IF INITIALIZATION CONFIDENCE TEST
          LDML   /SS/P.CT,CSST
          NJN    SDA20       IF NOT CONFIDENCE TEST FAILURE
 SDA10    BSS
          STML   RS+/RS/P.STRK STARTING TRACK
          STML   RS+/RS/P.SSEC STARTING SECTOR
          LDML   /SS/P.DT,CSST
          SHN    -4
          LPN    3
          STDL   DT          DEVICE TYPE
          LDML   CTC,DT      CONFIDENCE TEST CYLINDER
          STML   RS+/RS/P.SCYL STARTING CYLINDER
          UJN    SDA30
 SDA20    BSS
          LDN    1
          STDL   T1
          LOADF  /SS/P.CURRQ,CSST RMA OF CURRENT REQUEST
          ADN    3
          CRML   RS+/RS/P.CHAN,T1 SAVE CYLINDER, TRACK, SECTOR IN RESPONSE
 SDA30    BSS
          LDML   RS+/RS/P.ERRID
          ZJN    SDA50       IF RESPONSE PACKET PRESENT
          ADC    -E60
          MJN    SDA40       IF RESPONSE PACKET NOT PRESENT
          ADC    -E110+E60
          MJN    SDA50       IF RESPONSE PACKET PRESENT
 SDA40    BSS
          LDML   /SS/P.CURTRK,CSST
          STML   RS+/RS/P.FTRK FAILING TRACK
          LDML   /SS/P.CURSEC,CSST
          UJN    SDA70
 SDA50    BSS
          LDN    ID29        DRIVE CONDITIONAL SUCCESS
          RJM    SFP         SEARCH FOR PARAMETER
          PJN    SDA60       IF ID 29 FOUND
          LDN    ID32        RESPONSE EXTENT
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    SDA40       IF ID32 NOT FOUND
 SDA60    BSS
          LDML   RPB+9,T3
          SHN    -8
          STML   RS+/RS/P.FTRK FAILING TRACK
          LDML   RPB+9,T3
          LPC    0#FF
 SDA70    BSS
          STML   RS+/RS/P.FSEC FAILING SECTOR
          LJM    SDAX
          SPACE  5,20
** NAME-- SEEK
*
** PURPOSE-- ISSUE INITIAL SEEK.
          SPACE  2
 SEEKX    LJM    **
 SEEK     EQU    *-1
          LDML   UNITS,UX
          SHN    /UN/L.CIP+2
          MJN    SEEK4       IF ONE COMMAND ISSUED
          SHN    -/UN/L.CIP-2
          LPC    0#1FFF
          LMC    0#8000      INDICATE ONE COMMAND ISSUED
          UJN    SEEK8
 SEEK4    SHN    -/UN/L.CIP-2
          LPC    0#3FFF
          LMC    0#C000      INDICATE TWO COMMANDS ISSUED
 SEEK8    STML   UNITS,UX
          RJM    SCP         SETUP COMMAND PACKET PARAMETERS
          LDML   UNITS,UX
          SHN    6
          MJN    SEEK12      IF DRIVE ALREADY RESERVED
          LDN    6           COMMAND PACKET LENGTH
          STML   CP
          LDC    H0400       RESERVE DRIVE COMMAND
          STML   CP+OPCD
 SEEK12   BSS
          AODL   CMNDS       COMMAND ISSUED COUNTER
          RJM    CPT         COMMAND PACKET TRANSFER
 SEEK20   EQU    *-1         FOR FORCING ERRORS
          UJK    SEEKX
          SPACE  5,20
** NAME-- SETRQ
*
** PURPOSE-- SET UP FOR FIRST REQUEST.
          SPACE  2
 SETRQX   LJM    **
 SETRQ    EQU    *-1
          LDML   /SS/P.REQ,CSST SAVE RMA OF REQUEST
          STML   /SS/P.FCOMRQ,CSST FIRST COMPLETED REQUEST (RMA)
          STML   /SS/P.CURRQ,CSST CURRENT REQUEST (RMA)
          LDML   /SS/P.REQ+1,CSST
          STML   /SS/P.FCOMRQ+1,CSST
          STML   /SS/P.CURRQ+1,CSST
          LDN    1
          STML   /SS/P.NCOMRQ,CSST NUMBER OF COMPLETED REQUESTS
          LDML   RQ+/RQ/P.TRACK,CSST
          STML   /SS/P.CURTRK,CSST CURRENT TRACK
          LDML   RQ+/RQ/P.SECTOR,CSST
          STML   /SS/P.CURSEC,CSST CURRENT SECTOR
          LDML   RQ+/RQ/P.INT,CSST CHECK IF INTERRUPT WAS SELECTED
          SHN    /RQ/L.INT+2
          MJN    SETR10      IF INTERRUPT SELECTED
          LDC    2400B       PSN INSTRUCTION
          UJN    SETR20
 SETR10   BSS
          LDML   RQ+/RQ/P.PORT,CSST GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RQ/L.PORT+/RQ/N.PORT
          LPN    /RQ/M.PORT
          ADC    102600B     INPN INSTRUCTION
 SETR20   BSS
          STML   INTPRC
          UJK    SETRQX
          SPACE  5,20
** NAME-- SFP
*
** PURPOSE-- SEARCH FOR PARAMETER IDENTIFICATION IN RESPONSE PACKET
*
** INPUT
*         A = ID TO SEARCH FOR
** OUTPUT
*         A = POSITIVE IF ID FOUND
*         T3 = POINTER TO ID IF IT IS FOUND (RPB+5,T3)
          SPACE  2
 SFPX     LJM    **
 SFP      EQU    *-1
          STDL   T1          PARAMETER TO SEARCH FOR
          LDN    0
          STDL   T3          POINTER TO ID BEING SEARCHED FOR
          LDML   RPB
          ADN    1
          SHN    -1
          SBN    5           LENGTH OF MINIMUM RESPONSE PACKET
 SFP4     BSS
          STDL   T2          POINTER TO END OF PARAMETERS
          MJN    SFPX        EXIT, NO ID FOUND
          LDML   RPB+5,T3
          LMDL   T1
          LPC    0#FF
          ZJN    SFPX        IF ID FOUND
          LDML   RPB+5,T3
          SHN    -9
          ADN    1           ADJUST FOR ODD BYTE
          STDL   T4          WORD LENGTH OF PARAMETER
          RADL   T3          UPDATE POINTER TO ID BEING SEARCHED FOR
          LDDL   T2
          SBDL   T4
          UJN    SFP4
          SPACE  5,20
** NAME-- SFRR
*
** PURPOSE-- SETUP FOR REQUEST RETRY FOR ONE UNIT
*
** OUTPUT-- P5, T8 ARE UNCHANGED
          SPACE  2
 SFRRX    BSS
          LDN    0
          STDL   IF
          STML   /SS/P.RESET,CSST CLEAR RESET ISSUED FLAG
          LDML   UNITS,UX
          LPC    0#1FFF
          STML   UNITS,UX    CLEAR COMMAND IN PROGRESS BITS
          LJM    **
 SFRR     EQU    *-1
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE
          LDML   /SS/P.CT,CSST
          ZJN    SFRRX       IF CONFIDENCE TEST JUST RUN
          LDML   /SS/P.RESET,CSST
          NJN    SFRRX       IF SLAVE RESET IN PROGRESS
          LDML   UNITS,UX
          SHN    2
          PJN    SFRRX       IF NO COMMANDS IN PROGRESS
          LDML   /SS/P.CURRQ,CSST RESTORE RMA OF CURRENT REQUEST
          STML   /SS/P.REQ,CSST
          LDML   /SS/P.CURRQ+1,CSST
          STML   /SS/P.REQ+1,CSST
          LDML   /SS/P.FPVA,CSST RESTORE PVA OF CURRENT REQUEST
          STML   /SS/P.PVA,CSST
          LDML   /SS/P.FPVA+1,CSST
          STML   /SS/P.PVA+1,CSST
          LDML   /SS/P.FPVA+2,CSST
          STML   /SS/P.PVA+2,CSST
          LDML   UNITS,UX
          SHN    2+/UN/L.TCIP
          PJN    SFRR5       IF NOT -2 COMMANDS IN PROGRESS-
          SODL   CMNDS       OUTSTANDING COMMANDS
          LDML   UNITS,UX
          LPC    0#9FFF
          STML   UNITS,UX    CLEAR -2 COMMANDS IN PROGRESS-
 SFRR5    BSS
          LDN    0
          STML   /SS/P.NCOMW,CSST ZERO OUT NUMBER OF COMPLETED WRITE REQUESTS
          SOML   /SS/P.NCOMRQ,CSST NUMBER OF COMPLETED REQUESTS
          ZJN    SFRR10      IF NO STREAMED READ REQUESTS
          LDML   /SS/P.PRERQ,CSST SET UP RMA OF LAST GOOD COMPLETED REQUEST
          STML   /SS/P.CURRQ,CSST
          LDML   /SS/P.PRERQ+1,CSST
          STML   /SS/P.CURRQ+1,CSST
          RJM    DCR         DELETE COMPLETED REQUESTS FROM QUEUE
          UJN    SFRR15
 SFRR10   BSS
          SODL   CMNDS       OUTSTANDING COMMANDS
 SFRR15   BSS
          LJM    SFRRX
          SPACE  5,20
** NAME-- SFT
*
** PURPOSE-- SET FACILITY TIMEOUT TO 1/2 SECOND IF 8A OR LATER
*            MICROCODE.  THIS IS THE AMOUNT OF TIME THE CM3 WILL
*            WAIT FOR THE DRIVE TO GO NOT BUSY BEFORE REPORTING
*            AN ERROR.  WITH A TIMEOUT OF ONE HALF SECOND AND
*            VERSION 7 OR EARLIER MICROCODE,  DATA INTEGRITY
*            PROBLEMS OCCURRED.
          SPACE  2
 SFTX     LJM    **
 SFT      EQU    *-1
          RJM    RA6F        READ ATTRIBUTE 6F
          LDML   /SS/P.MREV,CSST
          SHN    -12
          SBN    8
          PJN    SFT2        IF 8A OR LATER MICROCODE
          LDML   RPB+21
          LMC    0#FFFF
          ZJK    SFTX        IF TIMEOUT ALREADY INFINITE
          LCN    0           SET TIMEOUT TO INFINITE
          STML   RPB+21
          LMN    1
          UJN    SFT5
 SFT2     BSS
          LDML   RPB+21
          LMN    7
          ZJK    SFTX        IF TIMEOUT ALREADY 1/2 SECOND
          LDN    7           SET TIMEOUT TO 1/2 SECOND
          STML   RPB+21
          LDC    0#A120
 SFT5     BSS
          STML   RPB+22
          RJM    WA6F        WRITE ATTRIBUTE 6F
          LDN    6
          STML   CP          COMMAND PACKET LENGTH
          LDC    H020A
          STML   CP+OPCD     SAVE OPERATING MODE IN EEPROM
          LDDL   CMOD
          LPN    7
          SHN    8
          LMC    0#FF
          STML   CP+SLAD     SLAVE ADDRESS
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          ZJK    SFTX        IF SUCCESSFUL
          LDN    E00         CPU MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- SNDRSP
*
** PURPOSE-- SEND THE RESPONSE TO CM.
*            USED WHEN SWITCHING TO THE NEXT REQUEST.
          SPACE  2
 SNDX     LJM    **
 SNDRSP   EQU    *-1
          RJM    RESP        SEND RESPONSE TO CM
          RJM    RESPIN      UPDATE -IN- POINTER IN RESPONSE BUFFER
          RJM    SRESP       SET UP RESPONSE BUFFER
          UJK    SNDX
          SPACE  5,20
** NAME-- SNDWRS
*
** PURPOSE-- SEND WRITE RESPONSES FOR WRITE REQUESTS THAT HAVE
*            BEEN SUCCESSFULLY STREAMED.
          SPACE  2
 SNDWX    LJM    **
 SNDWRS   EQU    *-1
          LDML   /SS/P.NCOMW,CSST NUMBER OF COMPLETED WRITE REQUESTS MINUS 1
          ZJN    SNDWX       IF NO COMPLETED STREAMED WRITE REQUESTS
          LDN    2
          STDL   WD
          LOADF  /SS/P.CURRQ,CSST
          CRML   NRQ,WD      READ FIRST REQUEST TO GET START OF CHAIN
 .U       IFNE   UNIX,1
          LDML   /SS/P.REQ,CSST  SET CURRQ TO END OF CHAIN SO DCR WILL
                                  DELINK ALL REQUESTS
          STML   /SS/P.CURRQ,CSST
          LDML   /SS/P.REQ+1,CSST
          STML   /SS/P.CURRQ+1,CSST
 .U       ENDIF
 SNDW10   BSS
          RJM    RESP        SEND RESPONSE TO CM
          RJM    RESPIN      UPDATE -IN- POINTER IN RESPONSE BUFFER
 .U       IFNE   UNIX,1
          LDN    0
          STML   RS+/RS/P.XFER  SET TRANSFER COUNT = 0 FOR ALL OTHER RESPONSES
          STML   RS+/RS/P.XFER+1
 .U       ENDIF
          LDML   NRQ+/RQ/P.NEXTPV  PUT PVA OF NEXT RESPONSE IN RESPONSE BUFFER
          STML   RS+/RS/P.PVA
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   RS+/RS/P.PVA+1
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   RS+/RS/P.PVA+2
 .U       IFEQ   UNIX,1
          LDML   /SS/P.CURRQ,CSST  SAVE RMA OF LAST RESPONSE RETURNED
          STML   /SS/P.PRERQ,CSST
          LDML   /SS/P.CURRQ+1,CSST
          STML   /SS/P.PRERQ+1,CSST
          LDML   NRQ+/RQ/P.NEXT  REQUESTS ARE DELINKED THROUGH CURRQ
          STML   /SS/P.CURRQ,CSST
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.CURRQ+1,CSST
 .U       ENDIF
          LOADF  NRQ+/RQ/P.NEXT  CM ADDRESS OF NEXT REQUEST
          CRML   NRQ,WD      READ NEXT REQUEST CHAIN POINTERS
          AOML   /SS/P.NCOMRQ,CSST INCREMENT NUMBER OF COMPLETED REQUESTS
                             (FOR DCR)
          SOML   /SS/P.NCOMW,CSST DECREMENT COUNT OF RESPONSES LEFT TO SEND
          NJK    SNDW10      IF MORE RESPONSES
          UJK    SNDWX
          SPACE  5,15
** NAME-- SNMSG
*
** PURPOSE-- SEND UNSOLICITED MESSAGE
          SPACE  2
 SNMSGX   LJM    **
 SNMSG    EQU    *-1
 .U       IFEQ   UNIX,1
          LDN    0
          STML   RS+/RS/P.SHORT  INDICATE ERROR RESPONSE
 .U       ENDIF
          LDC    RLIE
          STML   RS+/RS/P.RESPL BYTE LENGTH OF RESPONSE
          LDN    R.UNS       UNSOLICITED MESSAGE
          STML   RS+/RS/P.RC RESPONSE CODE
 .U       IFEQ   UNIX,1
          RJM    RESP        SEND RESPONSE TO CM
 .U       ELSE
          RJM    TERMP       SEND RESPONSE TO CM
 .U       ENDIF
          UJK    SNMSGX
          SPACE  5,20
** NAME-- SPLOCK
*
** PURPOSE-- SETS THE PP TABLE LOCK IN THE
*            PP INTERFACE TABLE.
          SPACE  2
 SPLX     LJM    **
 SPLOCK   EQU    *-1
 .U       IFEQ   UNIX,1
 SPLOCK4  BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDN    1
          STDL   T4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          RDSL   T1          ATTEMPT TO SET PP TABLE LOCK
          LDDL   T4
          LPN    1
          ZJK    SPLX        IF LOCK SET
          UJK    SPLOCK4
 .U       ELSE
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET THE LOCKWORD
          UJK    SPLX
 .U       ENDIF
          SPACE  5,20
** NAME-- SQLOCK
*
** PURPOSE-- SETS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
          SPACE  2
 SQLX     LJM    **
 SQLOCK   EQU    *-1
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          UJK    SQLX
          SPACE  5,20
** NAME-- SRI
*
** PURPOSE-- SET RESET ISSUED FLAG FOR ALL UNITS ON CMOD.
*            IT WILL BE CLEARED WHEN AN ASYNCHRONOUS RESPONSE
*            FOR THE DRIVE IS RECEIVED.
          SPACE  2
 SRIX     LJM    **
 SRI      EQU    *-1
          LDDL   UX
          STML   EPCT,CMOD   SAVE TABLE ISSUING RESET
          LDN    0
          STDL   P1          POINTER TO UNITS TABLE
          UJN    SRI10
 SRI5     BSS
          LDN    P.UN
          RADL   P1          UPDATE POINTER TO UNITS TABLE
 SRI10    BSS
          SBDL   UNUML
          PJN    SRIX        IF END OF CONFIGURED UNITS
          LDML   UNITS,P1
          SHN    -3
          LPN    7
          LMDL   CMOD
          NJN    SRI5        IF DIFFERENT CONTROLLER
          LDML   UNITS,P1
          LPC    0#F7FF
          STML   UNITS,P1    CLEAR DRIVE RESERVE BIT
          LDML   UNITS+/UN/P.SSPTR,P1
          STDL   P2          POINTER TO SS TABLE
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,P1 SET CURRENT CLOCK
          LDN    3
          STML   /SS/P.RESET,P2 INDICATE RESET ISSUED
          UJK    SRI5
          SPACE  5,20
** NAME-- SRR
*
** PURPOSE-- SHOULD RESPONSE BE READ.  CHECK IF RESPONSE PACKET MUST
*            BE READ TO ACCURATELY REPORT THE ERROR AND, IF SO
*            RETURN TO THE CALLING ROUTINE.
*            AFTER THE CM3 HAS PAUSED A TRANSFER, IT MAY SEND TRANSFER
*            NOTIFICATION, THEN DROP SLAVE IN IMMEDIATELY AND RETURN 90
*            HEX AS ENDING STATUS.  THIS INDICATES COMMAND COMPLETE.
*            THE RESPONSE PACKET SHOULD REPORT AN ERROR.  WITH THE 10 MB
*            CHANNEL SLAVE IN DROPS BEFORE THE PP TRANSFERS A WORD, SO
*            THE ERROR FLAG DOES NOT SET.  WITH THE 25 MB CHANNEL, THE
*            ERROR FLAG MAY SET BECAUSE THE TIME BETWEEN RAISING MASTER
*            OUT AND BEING ABLE TO SEND DATA IS MUCH FASTER.
          SPACE  2
 SRRX     BSS
          LCN    0
          STML   /SS/P.LISTL,CSST TO GUARANTEE AN ERROR IS REPORTED
          AOML   SRRC        ERROR COUNTER
          LJM    **
 SRR      EQU    *-1
          LDDL   STATUS
          LPN    60B
          LMN    20B
          ZJN    SRRX        IF NO MORE DATA
          LDN    E29         INCOMPLETE TRANSFER
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 SRRC     CON    0           ERROR COUNTER
          SPACE  5,20
** NAME-- SR
*
** PURPOSE-- SELECT REQUEST FROM UNIT QUEUE
*
** EXIT
*         A = 0 IF REQUEST FOUND
          SPACE  2
 SRX      LJM    **
 SR       EQU    *-1
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    SRX         IF LOCK NOT SET
          LDN    2
          STDL   P5
          LDDL   CNUM
          NJK    SR50        IF ONE COMMAND ALREADY ISSUED
          LDML   /SS/P.REQ,CSST
          ADML   /SS/P.REQ+1,CSST
          NJK    SR24        IF REQUEST PRESENT
          LOADR  UNITS+/UN/P.UIT,UX LOAD CM ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.NEXTPV
          CRML   NRQ,P5      READ FIRST PVA AND RMA
          LDML   NRQ+/RQ/P.NEXT
          STML   /SS/P.REQ,CSST
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.REQ+1,CSST
          ADML   /SS/P.REQ,CSST
          NJN    SR20        IF REQUEST ON QUEUE
 SR16     BSS
          RJM    CQLOCK CLEAR QUEUE LOCKWORD
          LDN    1           NO REQUEST FOUND
          UJK    SRX
 SR20     BSS
          LDML   NRQ+/RQ/P.NEXTPV
          STML   /SS/P.PVA,CSST
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   /SS/P.PVA+1,CSST
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   /SS/P.PVA+2,CSST
 SR24     BSS
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          LDN    0           INDICATE REQUEST FOUND
          UJK    SRX
 SR50     BSS
          LDN    5
          STDL   WD
          LOADF  /SS/P.CURRQ,CSST
 SR54     BSS
          CRML   NRQ,WD      READ NEXT REQUEST
          LDML   NRQ+/RQ/P.NEXT
          STML   /SS/P.RMA2,CSST
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.RMA2+1,CSST
          ADML   /SS/P.RMA2,CSST
          NJK    SR80        IF NOT END OF QUEUE
          LOADR  UNITS+/UN/P.UIT,UX LOAD CM ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.NEXTPV
          CRML   NRQ,P5      READ FIRST PVA AND RMA
          LDML   NRQ+/RQ/P.NEXT
          STML   /SS/P.RMA2,CSST
          LMML   /SS/P.FCOMRQ,CSST
          NJN    SR75        IF REQUEST FOUND
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.RMA2+1,CSST
          LMML   /SS/P.FCOMRQ+1,CSST
          ZJK    SR16        IF NO REQUEST FOUND
 SR75     BSS
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.RMA2+1,CSST
          LDML   NRQ+/RQ/P.NEXTPV
          STML   /SS/P.PVA2,CSST
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   /SS/P.PVA2+1,CSST
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   /SS/P.PVA2+2,CSST
          UJK    SR24
 SR80     BSS
          LDML   NRQ+/RQ/P.NEXTPV
          STML   /SS/P.PVA2,CSST
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   /SS/P.PVA2+1,CSST
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   /SS/P.PVA2+2,CSST
          LDML   NRQ+/RQ/P.SWIT
          SHN    /RQ/L.SWIT+2
          PJK    SR24        IF SWITCH FLAG NOT SET
          UJK    SR16
          SPACE  5,20
** NAME-- SRESP
*
** PURPOSE-- SET UP STATUS FOR RESPONSE BUFFER.
          SPACE  2
 SREX     LJM    **
 SRESP    EQU    *-1
          LDML   /SS/P.PVA,CSST SAVE PVA OF REQUEST
          STML   /SS/P.FPVA,CSST
          LDML   /SS/P.PVA+1,CSST
          STML   /SS/P.FPVA+1,CSST
          LDML   /SS/P.PVA+2,CSST
          STML   /SS/P.FPVA+2,CSST
*
          LDN    0
          STML   /SS/P.XFER,CSST TRANSFER COUNT
          STML   /SS/P.XFER+1,CSST
          UJK    SREX
          SPACE  5,20
** NAME-- STI
*
** PURPOSE-- SET TABLE INDEXES (UX AND CSST).  ALSO VERIFY THIS
*            IS THE CORRECT UNIT.
          SPACE  2
 STIX     LJM    **
 STI      EQU    *-1
          LDML   RPB+CRN
          LPC    777B
          STDL   UX          SET INDEX TO UNITS TABLE
          STDL   T8
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        SET INDEX TO SS TABLE
          LDML   /SS/P.UNIT,CSST
          LMML   RPB+SLAD
          ZJK    STIX        IF CORRECT UNIT
          LDDL   T8
          STDL   UX          SET INDEX TO UNITS TABLE
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        SET POINTER TO SS TABLE
          LJM    TERM10
          SPACE  5,20
** NAME-- TAC
*
** PURPOSE-- TERMINATE ALL COMMANDS ISSUED
          SPACE  2
 TACX     LJM    **
 TAC      EQU    *-1
          PAUSE  170000      DELAY 170 MILLISECONDS TO ALLOW MAX.
                              DATA IN BUFFER TO BE WRITTEN TO DISK
          AOML   /SS/P.RQTRY,CSST
          LDN    0
          STDL   CMOD        CONTROL MODULE NUMBER
          UJN    TAC15
 TAC10    BSS
          AODL   CMOD
          SBN    8
          ZJN    TACX        IF ALL COMMANDS TERMINATED
 TAC15    BSS
          LDN    0
          STDL   P5          RESET NOT ISSUED
          STDL   UX          POINTER TO UNITS TABLE
          UJN    TAC25
 TAC20    BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
 TAC25    BSS
          SBDL   UNUML
          PJN    TAC10       IF END OF CONFIGURED UNITS
          LDML   UNITS,UX
          SHN    -/UN/N.UNIT
          LPN    7
          LMDL   CMOD
          NJN    TAC20       IF DIFFERENT CONTROL MODULE
          LOADR  UNITS+/UN/P.UIT,UX ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T1
          LDDL   T1+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJN    TAC20       IF UNIT DISABLED
          LDML   UNITS,UX
          SHN    2+/UN/L.CIP
          MJN    TAC40       IF COMMAND IN PROGRESS
          LDDL   PTF
          ZJN    TAC40       IF IN PATH TEST
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE
          LDML   /SS/P.CT,CSST
          NJN    TAC20       IF NOT IN CONFIDENCE TEST
 TAC40    BSS
          LDDL   P5
          NJN    TAC20       IF RESET ALREADY DONE
          RJM    LIR         LOGICAL INTERFACE RESET
          AODL   P5          RESET DONE FOR THIS CONTROLLER
          UJK    TAC20
          SPACE  5,20
** NAME-- TERM
*
** PURPOSE-- TERMINATE UNIT REQUEST.
          SPACE  2
 TERM     CON    0           NORMAL TERMINATION
          LDML   /SS/P.FNC,CSST
          SBN    4
          NJN    TERM2       IF NOT FORMAT COMMAND
          LDN    E58         FORMAT COMPLETE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDML   UNITS,UX
          SHN    -3
          LPN    17B
          STML   RS+/RS/P.UNIT  PORT, CONTROLLER, DRIVE ADDRESS
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          LDN    0
          STML   FIP         CLEAR FORMAT IN PROGRESS FLAG
          STML   /SS/P.CT,CSST ENABLE STARTING CONFIDENCE TEST
          UJK    TERM20
 TERM2    LDML   /SS/MT,CSST MAKE SURE ALL BYTES WERE TRANSFERRED
          SHN    2
          PJN    TERM3       IF NOT USING MASTER TERMINATE
          LDML   /SS/P.LISTL,CSST
          UJN    TERM6
 TERM3    BSS
          SHN    -2
          ADML   /SS/P.TOTAL+1,CSST
          ADML   /SS/P.LISTL,CSST
 TERM6    BSS
          ADML   /SS/P.NUMCM,CSST
          ZJN    TERM20      IF TERMINATION IS OK
 TERM10   BSS
          LDK    E76         UNEXPECTED RESPONSE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 TERM20   BSS
          STML   /SS/P.RQTRY,CSST CLEAR RETRY COUNT
          RJM    PDR         PREPARE NORMAL DISK RESPONSE
          RJM    SNDWRS      SEND WRITE RESPONSES
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    DCR         DELETE COMPLETED REQUEST FROM QUEUE
          RJM    RESPIN      UPDATE 'IN' POINTER FOR RESPONSE BUFFER
          LJM    MAIN20
          SPACE  5,20
** NAME-- TERMP
*
** PURPOSE-- TERMINATE PP REQUEST.
          SPACE  2
 TERX     LJM    **
 TERMP    EQU    *-1
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
          UJK    TERX
          SPACE  5,20
** NAME-- UBT
*
** PURPOSE-- UPDATE BYTES TRANSFERRED
*
** EXIT
*         A = 0 IF END OF REQUEST
          SPACE  2
 UBT10    BSS
          RJM    UNCMND      GET NEXT COMMAND
 UBTX     LJM    **
 UBT      EQU    *-1
          LDML   /SS/MT,CSST
          SHN    2
          MJN    UBT5        IF USING MASTER TERMINATE
          LDML   /SS/P.TOTAL+1,CSST
          SBDL   WDS         NUMBER OF CM WORDS TRANSFERRED THIS LOOP
          STML   /SS/P.TOTAL+1,CSST
          PJN    UBT5        IF NOT NECESSARY TO ADJUST SECOND WORD
          ADC    200000B     ADD CARRY BIT
          STML   /SS/P.TOTAL+1,CSST
          SOML   /SS/P.TOTAL,CSST SUBTRACT CARRY BIT FROM FIRST WORD
          PJN    UBT5        IF MORE TO TRANSFER
          LDC    E505        CM HAS CHANGED
          RJM    INTERR      REPORT ERROR (NO RETURN)
 UBT5     BSS
          LDDL   WDS         CM WORDS TRANSFERRED
          SHN    3
          STDL   T1          BYTES TRANSFERRED
          RAML   /SS/P.XFER+1,CSST UPDATE BYTES TRANSFERRED
          SHN    -16
          RAML   /SS/P.XFER,CSST
          LDDL   T1
          RAML   CMLIST+/CM/P.RMA+1,CSST UPDATE CM ADDRESS
          SHN    -16
          RAML   CMLIST+/CM/P.RMA,CSST
          LDML   CMLIST+/CM/P.LEN,CSST UPDATE BYTES LEFT TO TRANSFER
          SBDL   T1
          STML   CMLIST+/CM/P.LEN,CSST
          NJN    UBT8        IF MORE WORDS LEFT TO TRANSFER TO THIS
                              CM ADDRESS
          SOML   /SS/P.LISTL,CSST DECREMENT ADDRESS-LENGTH-PAIR COUNT
          ZJK    UBT10       IF END OF RMA LIST
          RJM    GLIST       READ NEXT SECTION OF THE LIST WHICH POINTS
                             TO THE CM DATA AREA
          LDN    1
 UBT8     BSS
          UJK    UBTX
          SPACE  5,20
** NAME-- UC
*
** PURPOSE-- UPDATE CLOCK.  THE CLOCK IS USED TO TIMEOUT COMMANDS
*            ISSUED TO THE CONTROL MODULE.
          SPACE  2
 UCX      LJM    **
 UC       EQU    *-1
          LDDL   CLCUR
          STDL   P6          SAVE CURRENT CLOCK
          IAN    14B
          STDL   CLCUR
          SBDL   P6
          PJN    UC5         IF CLOCK HASNT WRAPPED
          ADC    0#10000
 UC5      BSS
          RADL   CLMCS       UPDATE MICROSECOND PORTION OF CLOCK
          LDDL   CLMCS
          ADC    -30000
          MJN    UCX         IF LESS THAN 30 MILLISECONDS
          STDL   CLMCS
          LDN    30
          RADL   CLMLS       UPDATE MILLISECOND PORTION OF CLOCK
          ADC    -1000
          MJN    UCX         IF LESS THAN 1 SECOND
          STDL   CLMLS
          AODL   CLSEC       UPDATE SECOND PORTION OF CLOCK
          UJN    UCX
          SPACE  5,20
** NAME-- UDA
*
** PURPOSE-- UPDATE DISK ADDRESS. THIS ALLOWS THE PP TO VERIFY THAT
*            A STREAMED REQUEST IS FOR THE NEXT SEQUENTIAL DISK SECTOR.
          SPACE  2
 UDAX     LJM    **
 UDA      EQU    *-1
          SODL   SBS         SECTORS BEFORE SUSPENDING
          AOML   /SS/P.CURSEC,CSST INCREMENT SECTOR
          SBML   SPT,DT      SECTORS PER TRACK
          MJN    UDAX        IF SAME TRACK
          STML   /SS/P.CURSEC,CSST
          AOML   /SS/P.CURTRK,CSST INCREMENT TRACK
          UJN    UDAX
          SPACE  5,20
** NAME-- UNCMND
*
** PURPOSE-- GET NEXT COMMAND FROM CM.  SET UP CMLIST AND
*            LISTL IN THE SS TABLE.  SET FNC AS THE INDEX TO
*            A TABLE OF COMMANDS FROM CENTRAL MEMORY.
*
** EXIT-- A REGISTER = 0, IF NO MORE COMMANDS.
          SPACE  2
 UNCX     LJM    **
 UNCMND   EQU    *-1
          LDML   /SS/P.NUMCM,CSST
          ZJN    UNCX        IF NO MORE COMMANDS
          SOML   /SS/P.NUMCM,CSST  DECREMENT COMMAND COUNT
          LDML   /SS/P.FRST,CSST HAS FIRST COMMAND BEEN PROCESSED
          ZJN    UNC10       IF FIRST COMMAND HASN'T BEEN PROCESSED

*         READ NEXT COMMAND FROM CM.

          LDDL   CSST        ADDRESS OF SS TABLE
          ADK    CM
          STML   UNC4        ADDRESS TO STORE COMMAND
          AOML   /SS/P.LASTC,CSST INCREMENT OFFSET OF LAST COMMAND
          LDN    C.CM
          STDL   WD
          LOADF  /SS/P.REQ,CSST LOAD CM ADDRESS AND REFORMAT
          ADML   /SS/P.LASTC,CSST ADD OFFSET OF COMMAND
          CRML   *,WD       READ COMMAND FROM CM
 UNC4     EQU    *-1

*         IF INDIRECT ADDRESS, READ CM ADDRESS LIST.

 UNC10    BSS
          LDML   CM+/CM/P.LEN,CSST  ENSURE AN EVEN NUMBER OF CM WORDS
          ADN    7
          SCN    7
          STML   CM+/CM/P.LEN,CSST
          STML   CMLIST+/CM/P.LEN,CSST
          SHN    -3
          STML   /SS/P.LISTL,CSST LENGTH OF CM ADDRESS AREA  (CM WORDS)
          LDML   CM+/CM/P.INDIR,CSST
          SHN    /CM/L.INDIR+2
          MJN    UNC15       IF INDIRECT ADDRESS
          LDN    1
          STML   /SS/P.LISTL,CSST IF NOT INDIRECT, ONLY 1 COMMAND.
          LDML   CM+/CM/P.RMA,CSST
          STML   CMLIST+/CM/P.RMA,CSST
          LDML   CM+/CM/P.RMA+1,CSST
          STML   CMLIST+/CM/P.RMA+1,CSST
          UJN    UNC20

 UNC15    BSS
          RJM    GLIST       GET CM ADDRESS LIST OF DATA AREA
 UNC20    BSS
          LDN    0
          STDL   FNC         SET UP INTERNAL FUNCTION CODE
 UNC30    LDML   CM+/CM/P.CODE,CSST GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          ERRNZ  /CM/L.CODE
          LMML   UCMD,FNC    COMPARE COMMAND CODE
          ZJN    UNC40       IF COMMAND FOUND
          AODL   FNC
          SBN    UCMDL
          MJN    UNC30       IF MORE COMMANDS TO CHECK
 UNC35    BSS
          LDC    E501        ERROR IN COMMAND CODE
          RJM    INTERR      REPORT ERROR (NO RETURN)
 UNC40    BSS
          LDML   /SS/P.FRST,CSST
          ZJN    UNC60       IF FIRST COMMAND
          LDDL   FNC
          LMML   /SS/P.FNC,CSST FUNCTION CODE
          ZJN    UNC70       IF SAME AS LAST COMMAND
          UJN    UNC35
 UNC60    BSS
          LDDL   FNC
          STML   /SS/P.FNC,CSST SAVE COMMAND CODE
 UNC70    BSS
          AOML   /SS/P.FRST,CSST SET FIRST COMMAND FLAG NONZERO
          UJK    UNCX        EXIT A REGISTER NONZERO
          SPACE  5,20
** NAME-- UREQ
*
** PURPOSE-- READ A REQUEST FROM CM.  THE REQUEST IS READ WITH 2
*            3-WORD INPUTS SO THAT THE RMA WILL BE CORRECT IF THE
*            STREAM BIT IS SET.  ROUTINE GETRQ DOES NOT LOCK THE
*            QUEUE FOR PERFORMANCE REASONS, SO THE CP AND PP COULD
*            BE CHANGING THE QUEUE AT THE SAME TIME.
*
* INPUT--
*         CSST = POINTER TO SS TABLE
*
** OUTPUT-- RQ  CONTAINS CURRENT REQUEST.
*           FRST = 0
*           NUMCM = NUMBER OF COMMANDS.
          SPACE  2
 UREQX    LJM    **
 UREQ     EQU    *-1
          LDN    0
          STML   /SS/P.FRST,CSST SET FLAG WHEN REQUEST IS READ
          LDN    3           NUMBER OF WORDS TO READ
          STDL   WD
          LDDL   CSST        ADDRESS OF SS TABLE
          ADK    RQ          LOCATION OF REQUEST IN SS TABLE
          STML   UREQ8       ADDRESS TO PUT REQUEST
          ADN    8
          STML   UREQ4
          LOADF  /SS/P.REQ,CSST LOAD CM REQUEST ADDRESS
          ADN    2
          CRML   *,WD        READ CURRENT REQUEST
 UREQ4    EQU    *-1
          SBN    5
          CRML   *,WD
 UREQ8    EQU    *-1
          LDML   RQ+/RQ/P.LEN,CSST DETERMINE NUMBER OF COMMANDS
          SHN    -3
          SBN    /RQ/C.CMND
          STML   /SS/P.NUMCM,CSST NUMBER OF COMMANDS
          LDN    /RQ/C.CMND
          STML   /SS/P.LASTC,CSST OFFSET OF COMMAND
          UJK    UREQX
          SPACE  5,20
** NAME-- VCTD
*
** PURPOSE-- VERIFY CONFIDENCE TEST DATA
          SPACE  2
 VCTDX    LJM    **
 VCTD     EQU    *-1
          LDN    0
          STDL   P1
          LDML   /SS/P.CURTRK,CSST
          SHN    8
          ADML   /SS/P.CURSEC,CSST
          STDL   P2          PUT CURRENT TRACK, SECTOR IN ONE WORD
          LDDL   CSST
          STDL   P3
 VCTD5    BSS
          LDML   CTME,P3     ADDRESS IN TABLE
          LMDL   P2          CURRENT ADDRESS
          ZJK    VCTDX       IF SECTOR NOT WRITTEN
          AODL   P3
          AODL   P1
          LMN    3
          NJN    VCTD5       IF MORE TABLE LOCATIONS TO CHECK
          LDML   SPC,DT      SECTORS PER CYLINDER
          SBML   STT,CSST    SECTOR NUMBER
          SHN    2
          ADDL   CTPAT       CONFIDENCE TEST PATTERN FIRST WORD MINUS ONE
          STDL   P1          STARTING DATA PATTERN VALUE MINUS ONE
          LDN    0
          STDL   P3
          LOADC  CM.CB       ADDRESS OF PP COMMUNICATIONS BUFFER
          STDL   P2
 VCTD10   BSS
          LDDL   P2
          ADDL   P3
          CRDL   T4          READ WORD OF SECTOR
          AODL   P1
          SBDL   T4
          NJN    VCTD20      IF DATA MISCOMPARE
          AODL   P1
          SBDL   T5
          NJN    VCTD20      IF DATA MISCOMPARE
          AODL   P1
          SBDL   T6
          NJN    VCTD20      IF DATA MISCOMPARE
          AODL   P1
          SBDL   T7
          NJN    VCTD20      IF DATA MISCOMPARE
          AODL   P3          INDEX TO WORD TO READ
          LMC    WPS
          NJN    VCTD10      IF MORE WORDS TO VERIFY
          LJM    VCTDX
 VCTD20   BSS
          LDK    E111        CM-DRIVE DATA INTEGRITY
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDN    4
          STML   /SS/P.CT,CSST INDICATE DATA INTEGRITY ERROR
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- VPTD
*
** PURPOSE-- VERIFY PATH TEST DATA
          SPACE  2
 VPTDX    LJM    **
 VPTD     EQU    *-1
          LDN    0
          STDL   T1          INDEX TO BUFFER
 VPTD4    BSS
          LDML   IB,T1       WORD FROM INPUT BUFFER
          LMML   OB,T1       WORD FROM OUTPUT BUFFER
          NJN    VPTD10      IF ERROR
          AODL   T1
          SBN    50
          ZJN    VPTDX       IF VERIFY OK
          UJN    VPTD4       MORE WORDS TO CHECK
 VPTD10   BSS
          LDK    E110        PP-CM3 DATA INTEGRITY
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- WA6F
*
** PURPOSE-- WRITE ATTRIBUTE PARAMETER 6F
*
** ENTRY  CP+SLAD MUST BE SET
*
** EXIT   TO CALLING PROGRAM IF NO ERROR
          SPACE  2
 WA6FX    LJM    **
 WA6F     EQU    *-1
          LDN    0#2E
          STML   CP          COMMAND PACKET LENGTH
          LDC    H0209
          STML   CP+OPCD     LOAD OPERATING MODE COMMAND
 WA6F10   BSS
          LDML   RPB+5,T1    MOVE COMMAND PACKET
          STML   CP+4,T1
          AODL   T1
          LMN    20
          NJN    WA6F10
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          ZJN    WA6FX       IF NO ERROR
          LDN    E00         CP MUST DETERMINE THE ERROR COD
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          TITLE  IPI CHANNEL SUBROUTINES
** NAME-- BCS
*
** PURPOSE-- PERFORM BUS CONTROL SEQUENCE
*
** INPUT
*         A = BUS A BITS 7,6 IN BITS 1,0 OF ACCUMULATOR
*             BIT 7 = 1 IF DATA ELSE RESPONSE OR COMMAND
*             BIT 6 = 1 IF INFORMATION IN
          SPACE  2
 BCSX     LJM    **
 BCS      EQU    *-1
          SHN    14
          ADC    H005B
          RJM    FUNC        SET SYNC OUT
          ACN    DC
          LDN    77B
 BCS4     FJM    BCS8,DC     IF SYNC IN
          SBN    1
          NJN    BCS4        IF TIMEOUT NOT EXPIRED
          LDN    E22         NO SYNC IN
          UJN    BCS20
 BCS8     IAN    DC
          STDL   STATUS      SAVE BUS ACKNOWLEDGE STATUS
          SFM    BCS25,DC    IF ERROR FLAG SET
          LPC    0#FF
          NJN    BCS16       IF BUS ACKNOWLEDGE IS WRONG
          LDDL   LF          LAST FUNCTION
          LMN    0#32
          RJM    FUNC        DROP SYNC OUT
          ACN    DC
          LDN    77B
 BCS12    FJM    BCSX,DC     IF SYNC IN DROPPED
          SBN    1
          NJN    BCS12       IF TIMEOUT NOT EXPIRED
          LDN    E23         SYNC IN DID NOT DROP
          UJN    BCS20
 BCS16    BSS
          LDN    E37         BUS ACKNOWLEDGE WRONG
 BCS20    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 BCS25    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,15
** NAME-- CPT
*
** PURPOSE-- COMMAND PACKET TRANSFER
*
** INPUT
*         CP - STARTING ADDRESS OF COMMAND PACKET
          SPACE  2
 CPT30    BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT THE CONTROL MODULE
          LDDL   WC
          ZJN    CPTX        IF ALL WORDS TRANSFERRED
          LDN    E29         INCOMPLETE TRANSFER
          UJK    CPT10
 CPTX     LJM    **
 CPT      EQU    *-1
 .K       IFEQ   KH,1        COMMAND HISTORY
 HB       EQU    20000B
          LCN    0           INDICATE COMMAND
          STML   HB,HBP
          LDML   CP+1        COMMAND REFERENCE NUMBER
          STML   HB+1,HBP
          LDML   CP+OPCD     COMMAND
          STML   HB+2,HBP
          LDML   CP+3        UNIT
          STML   HB+3,HBP
          LDML   CP+6        SECTOR COUNT
          STML   HB+4,HBP
          LDML   CP+7        CYLINDER
          STML   HB+5,HBP
          LDML   CP+8        HEAD, SECTOR
          STML   HB+6,HBP
          LDN    8
          RAD    HBP         UPDATE HISTORY BUFFER POINTER
 .K       ENDIF
          RJM    SEL         SELECT THE CONTROLLER
          LDN    CMDOUT      BUS A FOR COMMAND
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0381       STREAM, WRITE
          RJM    FUNC        RAISE MASTER OUT
          ACN    DC
          LDML   CP
          ADN    3
          SHN    -1          CONVERT BYTE COUNT TO WORD COUNT
          OAM    CP,DC       SEND COMMAND PACKET
          STDL   WC          WORDS NOT TRANSFERRED
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,UX SET CURRENT CLOCK
          LDC    MS50
 CPT4     IJM    CPT30,DC    IF SLAVE IN DROPPED
          SBN    1
          NJN    CPT4        IF TIMEOUT NOT EXPIRED
          LDN    E30         CHANNEL STAYED ACTIVE
 CPT10    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,15
** NAME-- DCM
*
** PURPOSE-- DESELECT THE CONTROL MODULE
          SPACE  2
 DCMX     LJM    **
 DCM      EQU    *-1
          LDC    H0071
          RJM    FUNC        DROP SELECT OUT
          ACN    DC
          LDN    77B
 DCM4     FJM    DCMX,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    DCM4        IF TIMEOUT NOT EXPIRED
          LDN    E28         SLAVE IN DID NOT DROP
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,15
** NAME-- DTM
*
** PURPOSE-- DETERMINE TRANSFER MODE
*
** OUTPUT
*         STATUS - TRANSFER SETTINGS, BIT 4 = 1 IF DATA STREAMING
*         CTM - USED TO CHANGE TRANSFER MODE WHEN SELECTING
          SPACE  2
 DTMX     LJM    **
 DTM      EQU    *-1
          LDDL   CMOD        CONTROL MODULE NUMBER
          SHN    12
          ADC    H8025
          RJM    FUNC        REQUEST TRANSFER SETTINGS
          ACN    DC
          LDN    77B
 DTM4     FJM    DTM8,DC     IF SLAVE IN
          SBN    1
          NJN    DTM4        IF TIMEOUT NOT EXPIRED
          LDN    E27         NO SLAVE IN
          UJN    DTM16
 DTM8     IAN    DC
          STDL   STATUS      SAVE TRANSFER SETTING
          SFM    DTM20,DC    IF ERROR FLAG SET
          LPN    0#10
          LMN    0#10
          SHN    7
          STDL   CTM         CHANGE TRANSFER MODE BIT
          LDDL   LF          LAST FUNCTION ISSUED
          LMC    0#54        CODE 7, DROP MASTER OUT
          RJM    FUNC        DROP MASTER OUT
          ACN    DC
          LDN    77B
 DTM12    FJM    DTMX,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    DTM12       IF TIMEOUT NOT EXPIRED
          LDN    E28         SLAVE IN DID NOT DROP
 DTM16    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 DTM20    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- EI
*
** PURPOSE-- ENABLE INTERRUPT FROM CM3.  SINCE IT TAKES UP TO
*            20 MICROSECONDS FOR THE CM3 TO PUT ITS INTERRUPT
*            ON THE BUS, THE ENABLE IS DONE HERE AND THE READ
*            IS DONE IN GETUD
          SPACE  2
 EIX      LJM    **
 EI       EQU    *-1
          LDDL   UNUML
          ZJN    EIX         IF NO CONFIGURED UNITS
          LDC    H0715
          RJM    FAN         REQUEST CLASS 1, 2, OR 3 INTERRUPT
          UJN    EIX
          SPACE  5,20
** NAME-- FAN
*
** PURPOSE-- SEND A FUNCTION TO THE IPI CHANNEL, BUT DONT
*            PUT THE FUNCTION IN THE FUNCTION HISTORY TABLE
          SPACE  2
 FANX     LJM    **
 FAN      EQU    *-1
          DCN    DC+40B      ENSURE THE CHANNEL IS INACTIVE
                              THE CHANNEL MAY HAVE BEEN LEFT ACTIVE
                              BY A MASTER CLEAR, A ROUTINE SUCH AS
                              DCM, OR AFTER A REPORTED ERROR.
          FAN    DC          SEND THE FUNCTION
          UJN    FANX
          SPACE  5,20
** NAME-- FUNC
*
** PURPOSE-- ISSUE FUNCTION TO IPI CHANNEL
*
** INPUT-- A REGISTER = FUNCTION CODE.
          SPACE  2
 FUNX     LJM    **
 FUNC     EQU    *-1
          DCN    DC+40B      ENSURE CHANNEL IS INACTIVE
                              THE CHANNEL MAY HAVE BEEN LEFT ACTIVE
                              BY A MASTER CLEAR, A ROUTINE SUCH AS
                              DCM, OR AFTER A REPORTED ERROR.
          FAN    DC          ISSUE THE FUNCTION
          STDL   LF          SAVE FUNCTION CODE
          STML   FBUF,FI     SAVE HISTORY OF FUNCTIONS ISSUED
          AODL   FI          INCREMENT FUNCTION BUFFER INDEX
          ADC    -FBUFL
          NJN    FUN4        IF NOT END OF BUFFER
          STDL   FI          INITIALIZE INDEX
 FUN4     BSS
          IJM    FUNX,DC     EXIT IF CHANNEL INACTIVE
          LDN    E01         FUNCTION TIMEOUT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- GES
*
** PURPOSE-- GET ENDING STATUS
*
** ENTRY
*         A = 0000  DO ENDING STATUS WITHOUT MASTER TERMINATE
*             000A  DO ENDING STATUS WITH MASTER TERMINATE
** OUTPUT
*         RETURNS TO CALLING PROGRAM IF STATUS IS READ WITHOUT ERROR
*         AND SUCCESSFUL IS SET IN STATUS
          SPACE  2
 GESX     LJM    **
 GES      EQU    *-1
          SHN    8
          ADC    H8039       INDICATE SUCCESSFUL IN BUS A
          RJM    FUNC        DROP MASTER OUT
          ACN    DC
          LDC    1280
 GES4     FJM    GES8,DC     IF SLAVE IN SET
          SBN    1
          NJN    GES4        IF TIMEOUT NOT EXPIRED
          LDN    E27         SLAVE IN NOT SET
          UJK    GES30
 GES8     IAN    DC
          STDL   STATUS      SAVE ENDING STATUS
          SFM    GES40,DC    IF ERROR FLAG SET
          SHN    17-7
          MJN    GESX        IF SUCCESSFUL
          LDDL   STATUS
          SHN    11
          PJN    GES15       IF NOT BUS PARITY
          LDK    E34
          UJK    GES30
 GES15    BSS
          LDDL   STATUS
          LPN    17B
          ZJK    GES25       IF REPORTING -ENDING STATUS WRONG-
          SBN    1
          NJN    GES18       IF NOT BUS CONTROL REJECTED
          LDDL   TBC
          ZJK    GES25       IF REPORTING -ENDING STATUS WRONG-
          LDN    0
          STDL   TBC         INDICATE NOT EXPECTING 01 STATUS
          RJM    DCM         DESELECT CONTROL MODULE
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    GES16       IF CLOCK HASNT WRAPPED
          ADC    0#10000
 GES16    BSS
          SBN    32          COMMAND TIMEOUT OF APPROXIMATELY 32 SECONDS
          PJN    GES24       IF TIMEOUT
          LJM    MAIN15      TRANSFER NOTIFICATION OCCURRED BEFORE
                              THE COMPLETION RESPONSE, WAIT FOR
                              THE COMPLETION RESPONSE
 GES18    BSS
          SBN    8
          NJN    GES20       IF NOT -SYNC OUTS NOT EQUAL SYNC INS-
          LDK    E36
          UJN    GES30
 GES20    BSS
          PJN    GES23       IF NOT COMMAND REJECT
          ADN    6
          NJN    GES21       IF NOT CLASS 3 RESPONSE PRESENT
          RJM    RPT         READ RESPONSE PACKET
*         LDN    E00         RESPONSE MUST BE EVALUATED TO DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 GES21    BSS
          LDK    E35
          UJN    GES30
 GES23    BSS
          SBN    2
          NJN    GES25       IF NOT INTERNAL CONTROLLER ERROR
          LDK    E70
          UJN    GES30
 GES24    BSS
          LDN    E38         NO CONTROLLER RESPONSE
          UJN    GES30
 GES25    BSS
          LDN    E39         ENDING STATUS WRONG
 GES30    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 GES40    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- IR
*
** PURPOSE-- ISSUE INTERFACE RESET TO CM3
*
** ENTRY
*         A = 8215  FOR LOGICAL INTERFACE RESET
*             8415  FOR SLAVE RESET
*         CMOD = CONTROL MODULE NUMBER
          SPACE  2
 IRX      LJM    **
 IR       EQU    *-1
          STDL   P2
          RJM    MCC         MASTER CLEAR CHANNEL
          LDDL   CMOD        CONTROL MODULE NUMBER
          SHN    12
          ADDL   P2
          RJM    FUNC        SET MASTER OUT
          PAUSE  20
          LDDL   LF          LAST FUNCTION ISSUED
          LMN    2
          RJM    FUNC        SET SYNC OUT
          PAUSE  10
          LDDL   LF
          LMN    2
          RJM    FUNC        DROP SYNC OUT
          LDDL   LF
          LMN    4
          RJM    FUNC        DROP MASTER OUT
          UJK    IRX
          SPACE  5,20
** NAME-- MCC
*
** PURPOSE-- MASTER CLEAR CHANNEL
          SPACE  2
 MCCX     LJM    **
 MCC      EQU    *-1
          MCLR   DC          MASTER CLEAR CHANNEL
          PAUSE  100         ALLOW CONTROLLER TIME TO DROP LINES
          MCLR   DC          IN CASE SEQUENCE ERROR OCCURRED
          PAUSE  1
          LDC    H7E42
          RJM    FUNC        SET IPI CHANNEL TRANSFER RATE
          UJN    MCCX
          SPACE  5,20
** NAME-- MR
*
** PURPOSE-- MASTER RESET ALL SLAVES ON THE CHANNEL
          SPACE  2
 MRX      LJM    **
 MR       EQU    *-1
          RJM    MCC         MASTER CLEAR CHANNEL
          LDC    H9213
          RJM    FUNC        BUS A, SET SYNC OUT
          PAUSE  10          MUST DELAY 10 MICROSECONDS MINIMUM
          LDC    H9211
          RJM    FUNC        DROP SYNC OUT
          UJK    MRX
          SPACE  5,20
** NAME-- RI
*
** PURPOSE-- REQUEST INTERRUPTS FROM THE CM3
*
** OUTPUT
*         STATUS - CONTAINS BIT SIGNIFICANT ADDRESS OF CM3 WITH INTERRUPT
          SPACE  2
 RIX      LJM    **
 RI       EQU    *-1
 .U       IFEQ   UNIX,1
          RJM    PPRQ        CHECK FOR IDLE REQUEST
 .U       ENDIF
          LDC    H0715       REQUEST CLASS 1, 2, OR 3 INTERRUPT
          RJM    FUNC        BUS A, MASTER OUT
          PAUSE  20          DELAY
          ACN    DC
          EJM    RI5,DC      IF ERROR
          IAN    DC
          STDL   STATUS      SAVE BIT SIGNIFICANT ADDRESS
          LDC    H0711
          RJM    FUNC        DROP MASTER OUT
          CFM    RIX,DC      IF ERROR FLAG NOT SET
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 RI5      BSS
          LDN    E02         CHANNEL EMPTY WHEN ACTIVATED
          RJM    PCER        PREPARE COMMAND ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- RPT
*
** PURPOSE-- RESPONSE PACKET TRANSFER
*
** OUTPUT
*         RPB - STARTING LOCATION OF RESPONSE PACKET
*         (A) = 0
          SPACE  2
 RPT20    BSS
          STDL   WC          SAVE WORDS NOT TRANSFERRED
 RPT30    BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
 .K       IFEQ   KH,1        RESPONSE HISTORY
          LCN    77B         INDICATE RESPONSE
          STML   HB,HBP
          LDML   RPB+1       COMMAND REFERENCE NUMBER
          STML   HB+1,HBP
          LDML   RPB+2       COMMAND
          STML   HB+2,HBP
          LDML   RPB+3       UNIT
          STML   HB+3,HBP
          LDML   RPB+4       MAJOR STATUS
          STML   HB+4,HBP
          LDN    8
          RAD    HBP         UPDATE HISTORY BUFFER POINTER
 .K       ENDIF
          LDDL   WC
          ZJN    RPTX        IF ALL WORDS TRANSFERRED
          LDN    E29         INCOMPLETE TRANSFER
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 RPTX     LJM    **
 RPT      EQU    *-1
          LDN    RSPIN       BUS A FOR RESPONSE
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0281       STREAM, READ
          RJM    FUNC        SET MASTER OUT
          ACN    DC
          LDN    5
          IAM    RPB,DC      INPUT REQUIRED WORDS
 RPT2     BSS
          NJK    RPT20       IF NOT ALL WORDS RECEIVED
          STDL   TBC         DO NOT EXPECT 01 ENDING STATUS
          LDML   RPB         BYTE COUNT MINUS 2
          ADN    3
          SHN    -1
          SBN    5
          ZJN    RPT4        IF ALL WORDS TRANSFERRED
          LPC    377B        PROTECT AGAINST ILLEGAL LENGTH
          IAM    RPB+5,DC    INPUT REMAINING WORDS
          NJN    RPT2        IF NOT ALL WORDS TRANSFERRED
 RPT4     BSS
          STDL   WC          WORDS NOT TRANSFERRED
          LDC    MS50
 RPT8     BSS
          IJM    RPT30,DC    IF SLAVE IN DROPPED
          SBN    1
          NJN    RPT8        IF TIMEOUT NOT EXPIRED
          RJM    CSI         CHECK SLAVE IN
          LJM    RPT30
          SPACE  5,20
** NAME-- SEL
*
** PURPOSE-- SELECT THE CONTROL MODULE AND VERIFY THE BIT SIGNIFICANT
*            RESPONSE
*
** INPUT
*         CMOD - CONTROL MODULE NUMBER
*         CTM - CHANGE TRANSFER MODE IF BIT 3 SET
*
** OUTPUT-- A = 0 IF NO ERROR
          SPACE  2
 SELX     LJM    **
 SEL      EQU    *-1
          LDDL   CMOD
          SHN    12
          ADDL   CTM         CHANGE TRANSFR MODE MODIFIER
          ADN    H0029
          RJM    FUNC        SET SELECT OUT
          ACN    DC
          LDN    77B
 SEL4     FJM    SEL8,DC     IF SLAVE IN
          SBN    1
          NJN    SEL4        IF TIMEOUT NOT EXPIRED
          LDN    E20         CANT SELECT CM3
          UJN    SEL15
 SEL8     IAN    DC
          STDL   STATUS      SAVE BIT SIGNIFICANT RESPONSE
          LPC    377B
          LMML   SELT,CMOD
          ZJK    SELX        IF BIT SIGNIFICANT RESPONSE CORRECT
          LDN    E21         BIT SIGNIFICANT RESPONSE WRONG
 SEL15    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
*
 SELT     DATA   1,2,4,8
          DATA   16,32,64,128
          SPACE  2,6
 CONCH    BSS                DISK CHANNEL REFERENCES
 TDC+40B  HERE
 T40B+DC  HERE
 TDC      HERE
          CON    0           END OF TABLE
          TITLE  INITIALIZATION
** NAME-- INIT
*
** PURPOSE-- INITIALIZE THE DRIVER
*
** INPUT-- CM.PIT = CM BYTE-ADDRESS OF THE PP INTERFACE TABLE.
          SPACE  2
 INITX    LJM    **
 INIT     EQU    *-1
          LDK    EOM-CP      LENGTH OF BUFFERS
          STDL   T1
 INIT4    BSS
          LDN    0
          STML   CP-1,T1     ZERO OUT BUFFERS
          SODL   T1
          NJN    INIT4
          STDL   UX          INITIALIZE DIRECT CELLS
          STDL   LUX
          STML   FIP
          STDL   MALET
          STDL   P4
          STDL   P5
          STDL   P6
          STDL   PTF         PATH TEST FLAG
          LDN    C.PIT
          STDL   WD
          LOADC  CM.PIT      LOAD CM ADDRESS OF PP INTERFACE TABLE
          CRML   IPIT,WD     READ PP INTERFACE TABLE
          LDML   IPIT+/PIT/P.PPNO  GET PP NUMBER
          STDL   PPNO
          REFAD  IPIT+/PIT/P.RSBUF,CM.RS  REFORMAT CM ADDRESS OF RESPONSE
                                          BUFFER AND SAVE IN CM.RS
          LDML   IPIT+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STDL   LIM
          REFAD  IPIT+/PIT/P.INT,CM.INT  REFORMAT CM ADDRESS OF INTERRUPT
                                         WORD AND SAVE IN CM.INT
          REFAD  IPIT+/PIT/P.CHAN,CM.CHAN  REFORMAT CM ADDRESS OF
                                           CHANNEL TABLE AND SAVE IN CM.CHAN
          REFAD  IPIT+/PIT/P.CBUF,CM.CB  REFORMAT ADDRESS OF COMMUNICATION
                                         BUFFER AND SAVE IN CM.CB
          LDN    /CB/C.BUF
          RAML   CM.CB+1     DISPLACEMENT TO READ/WRITE BUFFER
          LDML   IPIT+/PIT/P.CBUFL  GET LENGTH OF COMMUNICATION BUFFER
          ADC    -P.CB*2
          PJN    INIT8       IF COMMUNICATIONS BUFFER LONG ENOUGH
          LDC    E20B
          RJM    INTERR      REPORT ERROR (NO RETURN)

* INITIALIZE UNITS AND SS TABLES

 INIT8    BSS
          LDML   IPIT+/PIT/P.UNITC NUMBER OF UNIT DESCRIPTIORS
          SHN    1
          STDL   T8          LENGTH OF UNIT DESCRIPTOR (CM WORDS)
          ZJK    INIT30      IF NO UNIT DESCRIPTORS
 INIT10   BSS
          LDN    C.UD        READ 2 CM WORDS
          STDL   WD
          LOADC  CM.PIT
          ADN    C.PIT
          ADDL   P6          INDEX TO UNIT DESCRIPTORS
          CRML   IBUF,WD     READ UNIT DESCRIPTOR
          LDML   IBUF+/UD/P.UQT  RMA = 0 IF NULL ENTRY
          ADML   IBUF+/UD/P.UQT+1
          ZJK    INIT25      IF NULL ENTRY

          LDN    C.UIT
          STDL   WD
          LOADF  IBUF+/UD/P.UQT  REFORMAT RMA OF UNIT INTERFACE TABLE
                                 AND SAVE IN UNITS TABLE
          STML   UNITS+/UN/P.UIT+1,UX
          CRML   UBUF,WD     READ UNIT INTERFACE TABLE
          LDML   IBUF+/UD/P.UQT
          STML   UNITS+/UN/P.UIT,UX
          LDML   UBUF+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJK    INIT25      IF UNIT DISABLED
          LDML   UNITS+/UN/P.UIT+1,UX INITIALIZE DELINK POINTER TO FIRST
          ADN    /UIT/C.NEXTPV       REQUEST IN QUEUE
          STML   SS+/SS/P.DP+1,P4
          LDML   UNITS+/UN/P.UIT,UX
          STML   SS+/SS/P.DP,P4
          LDML   UBUF+/UIT/P.UTYPE  CHECK DEVICE TYPE
          LPN    77B
          SBN    7
          MJN    INIT15      IF INVALID UNIT TYPE
          SBN    3
          MJN    INIT20      IF VALID UNIT TYPE
 INIT15   BSS
          LDC    E306        INVALID UNIT TYPE
          RJM    INTERR      REPORT ERROR (NO RETURN)
 INIT20   BSS
          ADN    3
          SHN    4
          STML   SS+/SS/P.DT,P4 DEVICE TYPE, 0=9836 1=9853, 2=EMD5
          LDML   IBUF+/UD/P.CHAN  GET CHANNEL FROM UNIT DESCRIPTOR
          SHN    /UD/L.CHAN+/UD/N.CHAN+2
          LPN    77B
          STDL   CHAN        CHANNEL NUMBER

          LDML   IBUF+/UD/P.UNIT
          LPN    7
          RAML   SS+/SS/P.UNIT,P4
          STML   UNITS,UX
          LDML   IBUF+/UD/P.CNTRLR
          LPN    7
          STDL   T1
          SHN    8
          RAML   SS+/SS/P.UNIT,P4  PUT UNIT IN SS TABLE
          LDDL   T1
          SHN    /UN/N.UNIT
          RAML   UNITS,UX    PUT UNIT IN UNITS TABLE
          LDML   IBUF+/UD/P.LU  PUT LOGICAL UNIT IN SS TABLE
          STML   SS+/SS/P.LU,P4
          LDC    SS
          ADDL   P4
          STML   UNITS+1,UX  POINTER FROM UNITS TABLE TO SS TABLE
          LDC    P.SS
          RADL   P4          INCREMENT TO NEXT RESIDENT SS TABLE

* BUMP TO NEXT ENTRY.

          AODL   P5          NUMBER OF CONFIGURED UNITS
          LDN    P.UN
          RADL   UX          BUMP CONFIGURED UNIT INDEX
 INIT25   BSS
          LDN    C.UD
          RADL   P6          BUMP TO NEXT UNIT DESCRIPTOR ENTRY
          SBDL   T8          CHECK FOR END OF UNIT DESCRIPTORS
          ZJN    INIT30      IF NO MORE UNIT DESCRIPTORS
          LDDL   P5
          ADC    -UNUM
          NJK    INIT10      IF 64 OR LESS UNITS
          LDC    E208        TOO MANY CONFIGURED UNITS
          RJM    INTERR      REPORT ERROR (NO RETURN)
 INIT30   LDDL   UX
          STDL   UNUML       END OF ACTIVE UNIT TABLE
          RJM    CHGCH       SET CHANNEL INSTRUCTIONS
          LJM    INITX
          SPACE  5,20
 CP       BSS    24          COMMAND PACKET FOR CM3
 STORS    BSS    1           STORE RESPONSE FLAG (USED BY RESPIN)
                               = 0, IF A RESPONSE IS SENT TO CM
                               = NONZERO, IF NO RESPONSE WAS SENT TO CM
 FBUF     BSS    16          FUNCTION HISTORY BUFFER
 FBUFL    EQU    *-FBUF      LENGTH OF FUNCTION BUFFER
          SPACE  2
 UNUM     EQU    64          SUPPORT 64 UNITS
 UNITS    BSS    UNUM*P.UN   RMA OF UNIT INTERFACE TABLE
 SS       BSS    P.SS        INFORMATION SAVED IN UNIT COMMUNICATION BUFFER
 NSS      EQU    RS-SS
 NSST     EQU    NSS/P.SS    NUMBER OF SS TABLES
 RSST     EQU    NSST-1      SS TABLES FOR UNITS
 RSSTL    EQU    RSST*P.SS
 SSNR     EQU    SS+RSSTL    CHANGEABLE SS TABLE
          ERRMI  NSST-65     IF NO ROOM FOR SS TABLES
          END
/EOR
*DECK DECK=IOM$DSKK EXPAND=TRUE
          IDENT  E9P9853
          CIPPU
          MEMSEL 8
          TITLE  DSKK - NOS/VE CM3/9853 DISK DRIVER FOR I4
*
*         WORD 6 OF THE FOLLOWING COMMENT MUST BE THE REVISION NUMBER FOR CTI
*
          COMMENT *SMD* LVL=02
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
*
*         THIS IS THE PP DRIVER FOR THE IPI CHANNEL THAT SUPPORTS THE CM3
*         AND 9853 DRIVE ON A SYSTEM WITH AN I4 IOU.  THE PROGRAM NAME IS
*         E9P9853 AND THE DECK NAME IS IOM$DSKK.  WHEN THE PP DRIVER IS
*         LOADED, LOCATIONS 72 AND 73 MUST CONTAIN THE RMA OF THE PP INTERFACE
*         TABLE AND LOCATION 0 MUST BE THE ADDRESS, MINUS ONE, AT WHICH
*         EXECUTION IS TO BEGIN.
*
*         COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
*
          LIST   -$
*COPYC IODMAC1
*COPYC IODMAC2
*COPYC IODMAC3
*COPYC IODMAC4
          LIST   B,L,N,R
          EJECT
*
*         EQUATES FOR IPI ADAPTER
*
 H0000    EQU    0#0000      MASTER CLEAR ADAPTER
 H0004    EQU    0#0004      READ OPERAND GENERATOR
 H0009    EQU    0#0009      SET SELECT OUT
 H0014    EQU    0#0014      WRITE OPERAND GENERATOR
 H0029    EQU    0#0029      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H005B    EQU    0#005B      SET SYNC OUT
 H0062    EQU    0#0062      PORT A SELECT
 H0071    EQU    0#0071      FULL WHEN SLAVE IN IS 0
 H00E1    EQU    0#00E1      READ STATUS REGISTER
 H00F1    EQU    0#00F1      READ ERROR REGISTER
 H0100    EQU    0#0100      CLEAR DMA ERROR
 H0102    EQU    0#0102      READ IPI REVISION REGISTER
 H0122    EQU    0#0122      IPI BUS A OUTPUT PARITY ERROR
 H0200    EQU    0#0200      READ CONTROL REGISTER/READ ATTRIBUTES
 H0281    EQU    0#0281      STREAM, READ
 H0300    EQU    0#0300      WRITE CONTROL REGISTER
 H0302    EQU    0#0302      WRITE TRANSMITTER RECEIVER REGISTER
 H0322    EQU    0#0322      IPI BUS A INPUT PARITY ERROR
 H0381    EQU    0#0381      STREAM, WRITE
 H0600    EQU    0#0600      READ DMA ERROR REGISTER
 H0700    EQU    0#0700      READ OPERATIONAL STATUS
 H0711    EQU    0#0711      DROP MASTER OUT
 H0715    EQU    0#0715      REQUEST CLASS 1, 2, OR 3 INTERRUPT
 H0800    EQU    0#0800      DMA TERMINATE/ABORT COMMAND
 H0862    EQU    0#0862      PORT B SELECT
 H0A00    EQU    0#0A00      READ T REGISTER
 H0B00    EQU    0#0B00      WRITE T PRIME REGISTER
 H0C00    EQU    0#0C00      DMA READ
 H0C22    EQU    0#0C22      ICI OUTPUT PARITY ERROR
 H0D00    EQU    0#0D00      DMA WRITE
 H7E42    EQU    0#7E42      IPI CHANNEL TRANSFER RATE
 H8025    EQU    0#8025      MASTER OUT, FULL WHEN SLAVE IN IS 1
 H8039    EQU    0#8039      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H8215    EQU    0#8215      SET MASTER OUT, LOGICAL INTERFACE RESET
 H8415    EQU    0#8415      SET MASTER OUT, SLAVE RESET
 H9211    EQU    0#9211      DROP SYNC OUT
 H9213    EQU    0#9213      SET SYNC OUT
*
*         MISCELLANEOUS EQUATES
*
 UNIX     EQU    1           = 1, TO ENABLE ONE-WORD RESPONSE AND NEW METHOD OF
                                  RESPONDING TO IDLE AND RESUME REQUESTS, ALSO
                                  RELY TOTALLY ON CONFIDENCE TEST FOR ISOLATION
                                  OF MEDIA ERRORS. (=0 FOR UNIX)
 FE       EQU    0           = 1, TO ENABLE FORCE ERROR CODE
 FHT      EQU    0           = 1, TO KEEP LAST 16 FUNCTIONS
 ERRD     EQU    0           = 1, TO ENABLE READ RAW DATA
 DC       EQU    22B         DISK CHANNEL
 MS50     EQU    53475       50 MILLISECOND TIMEOUT FOR CERTAIN LOOPS
 RRL      EQU    3           REQUEST RETRY LIMIT
 SRT      EQU    120         SLAVE RESET TIMEOUT (SECONDS)
 FDT      EQU    9000        FORMAT DRIVE TIMEOUT (SECONDS)
 DST      EQU    480         DRIVE SPINUP TIMEOUT (SECONDS)
 RLIE     EQU    49*8        RESPONSE LENGTH IF ERROR
 NSBS     EQU    3           NUMBER OF BURSTS TO TRANSFER BEFORE
                              SUSPENDING
 C.CHCNT  EQU    37          NUMBER OF REQUESTS TO PROCESS BEFORE
                              CHANNEL LOCK
 RBPL     EQU    0#14        READ BUFFER PACKET LENGTH
 RPL      EQU    0#10        READ, WRITE COMMAND PACKET LENGTH
 H0209    EQU    0#0209      LOAD ATTRIBUTES OPERATION CODE
 H020A    EQU    0#020A      SAVE ATTRIBUTES OPERATION CODE
 H0400    EQU    0#0400      RESERVE DRIVE
 H0700    EQU    0#0700      SET OPERATING MODE
 H1005    EQU    0#1005      READ OPERATION CODE
 H1107    EQU    0#1107      READ RAW DATA
 H2005    EQU    0#2005      WRITE OPERATION CODE
 H5200    EQU    0#5200      WRITE TO BUFFER OPERATION CODE
 H6200    EQU    0#6200      READ FROM BUFFER OPERATION CODE
 H8100    EQU    0#8100      PERFORM DRIVE DIAGNOSTICS OP CODE
 H8400    EQU    0#8400      READ PERFORMANCE LOG OP CODE
 H0931    EQU    0#0931      COMMAND EXTENT PARAMETER
 MAXCYL   EQU    1411        MAXIMUM CYLINDER
 MAXTR    EQU    18          MAXIMUM TRACK
 BPS      EQU    2048        BYTES PER SECTOR
 WPS      EQU    BPS/8       WORDS PER SECTOR
 SPT      EQU    21          SECTORS PER TRACK
 ID13     EQU    0#13        MESSAGE/MICROCODE EXCEPTION
 ID14     EQU    0#14        INTERVENTION REQUIRED FOR CONTROLLER
 ID15     EQU    0#15        ALTERNATE PORT EXCEPTION
 ID16     EQU    0#16        MACHINE EXCEPTION FOR CONTROLLER
 ID17     EQU    0#17        COMMAND EXCEPTION FOR CONTROLLER
 ID19     EQU    0#19        CONTROLLER CONDITIONAL SUCCESS
 ID23     EQU    0#23        DRIVE MESSAGE EXCEPTION
 ID24     EQU    0#24        INTERVENTION REQUIRED STATUS
 ID26     EQU    0#26        MACHINE EXCEPTION FOR DRIVE
 ID29     EQU    0#29        DRIVE CONDITIONAL SUCCESS
 ID32     EQU    0#32        FAILING ADDRESS
 ID50     EQU    0#50        HAS MICROCODE REVISION
 ID51     EQU    0#51        HAS SECTOR SIZE

* COMMAND/RESPONSE PACKET EQUATES

 CRN      EQU    1           COMMAND REFERENCE NUMBER
 OPCD     EQU    2           OPERATION CODE FOR CONTROL MODULE
 SLAD     EQU    3           SLAVE ADDRESS, UNIT ADDRESS
 MAJST    EQU    4           MAJOR STATUS
 FCP      EQU    4           FIRST COMMAND PARAMETER

* MAJOR STATUS EQUATES
*         RESPONSE TYPES
 CC       EQU    1           COMMAND COMPLETE RESPONSE
 AR       EQU    4           ASYNCHRONOUS RESPONSE
 TN       EQU    5           TRANSFER NOTIFICATION
 CCS      EQU    0#18        COMMAND COMPLETE, SUCCESSFUL
 IVR      EQU    0#1000      INTERVENTION_REQUIRED_STATUS
* LEFT SHIFTS FOR MAJOR STATUS
 SC       EQU    14          SUCCESSFUL
 CS       EQU    16          CONDITIONAL SUCCESS
          SPACE  5,20
* BUS CONTROL EQUATES
 CMDOUT   EQU    0           COMMAND, INFORMATION OUT
 RSPIN    EQU    1           RESPONSE, INFORMATION IN
 DATAOUT  EQU    2           DATA OUT
 DATAIN   EQU    3           DATA IN
          SPACE  5,20
* IOU/CM3/9853 ERROR CODES
 E00      EQU    0           CP MUST DECODE STATUS IN RESPONSE PACKET
 E01      EQU    1           FUNCTION TIMEOUT
 E02      EQU    2           CHANNEL EMPTY WHEN ACTIVATED
 E03      EQU    3           PERIOD COUNTER PARITY
 E04      EQU    4           UPPER ICI PARITY
 E05      EQU    5           LOWER ICI PARITY
 E06      EQU    6           IOU ERROR
 E07      EQU    7           INCOMPLETE I4 TRANSFER
 E08      EQU    8           CHANNEL NOT EMPTY
 E09      EQU    9           CENTRAL MEMORY ERROR
 E10      EQU    10          INVALID CM RESPONSE CODE
 E11      EQU    11          CM RESPONSE CODE PARITY ERROR
 E12      EQU    12          CMI READ DATA PARITY ERROR
 E13      EQU    13          JY DATA ERROR
 E14      EQU    14          BAS PARITY ERROR
 E15      EQU    15          LZ ERROR
 E16      EQU    16          JY ERROR
 E17      EQU    17          LX ERROR
 E18      EQU    18          DMA TEST MODE FAILURE
 E20      EQU    20          CANT SELECT CM3
 E21      EQU    21          BIT SIGNIFICANT RESPONSE ERROR
 E22      EQU    22          NO SYNC IN
 E23      EQU    23          SYNC IN DID NOT DROP
 E24      EQU    24          IPI SEQUENCE ERROR
 E25      EQU    25          UPPER IPI CHANNEL PARITY
 E26      EQU    26          LOWER IPI CHANNEL PARITY
 E27      EQU    27          SLAVE IN NOT SET
 E28      EQU    28          SLAVE IN DID NOT DROP
 E29      EQU    29          INCOMPLETE TRANSFER
 E30      EQU    30          CHANNEL STAYED ACTIVE
 E31      EQU    31          BUFFER COUNTER PARITY
 E32      EQU    32          SYNC COUNTER PARITY
 E33      EQU    33          LOST DATA
 E34      EQU    34          BUS PARITY
 E35      EQU    35          COMMAND REJECT
 E36      EQU    36          SYNC OUT NOT EQUAL SYNC INS
 E37      EQU    37          BUS B ACKNOWLEDGE INCORRECT
 E38      EQU    38          NO CM3 INTERRUPT
 E39      EQU    39          ENDING STATUS WRONG
 E50      EQU    50          EXECUTING CONTROLLER DIAGNOSTICS
 E51      EQU    51          CONTROLLER DIAGNOSTICS PASSED
 E52      EQU    52          CM3 DIAGNOSTICS PASSES - LAST ERROR CODE RETURNED
 E57      EQU    57          FORMATTING DRIVE
 E58      EQU    58          FORMAT COMPLETE
 E60      EQU    60          CONTROLLER FAILURE
 E61      EQU    61          DRIVE FAILURE (A,B,C,D)
 E62      EQU    62          MEDIA FAILURE
 E70      EQU    70          INTERNAL CONTROLLER ERROR
 E71      EQU    71          CM3 INTERVENTION REQUIRED
 E72      EQU    72          CM3 MACHINE EXCEPTION
 E73      EQU    73          COMMAND EXCEPTION
 E74      EQU    74          MICROCODE EXECUTION ERROR
 E75      EQU    75          ALTERNATE PORT EXCEPTION
 E76      EQU    76          UNEXPECTED RESPONSE
 E77      EQU    77          DRIVER RESERVED TO OTHER CM3 PORT
 E78      EQU    78          CONTROLLER OVER TEMPERATURE
 E95      EQU    95          NO DRIVE OPERATIONAL RESPONSE
 E110     EQU    110         PP-CM3 DATA INTEGRITY
 E111     EQU    111         CM-DRIVE DATA INTERGRITY
 E120     EQU    120         SOFTWARE FAILURE
 E141     EQU    141         UNIT NOT FORMATTED
          SPACE  5,20
* INTERFACE ERROR CODES.
 E208     EQU    1010B       LOGICAL UNIT OF UNIT DESCRIPTOR NOT
                             IN SEQUENCE OR NOT IN RANGE
 E20B     EQU    1013B       COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS OR NOT LONG ENOUGH
 E304     EQU    1404B       RMA OF NEXT UNIT REQUEST
                             NOT A WORD BOUNDARY
 E306     EQU    1406B       INVALID UNIT TYPE
 E308     EQU    1410B       UNIT COMMUNICATION BUFFER IS TOO SMALL
 E501     EQU    2401B       INVALID COMMAND CODE
 E505     EQU    2405B       INVALID LENGTH SPECIFICATION IN COMMAND
          EJECT
* CONFIGURED UNITS.

 UN       RECORD PACKED

* WORD 1
 CIP      BOOLEAN            AT LEAST ONE COMMAND IN PROGRESS
 TCIP     BOOLEAN            TWO COMMANDS IN PROGRESS
 DTIP     BOOLEAN            DATA TRANSFER IN PROGRESS
 NCR      BOOLEAN            NO CONTROLLER RESPONSE
 RD       BOOLEAN            DRIVE RESERVED
 FILL1    SUBRANGE 0,7
 PORT     SUBRANGE 0,3       PORT TO IPI CHANNEL, 0 = PORT A, 1= PORT B
 CM       SUBRANGE 0,7       CONTROL MODULE NUMBER
 UNIT     SUBRANGE 0,7       UNIT NUMBER
* WORD 2
 SSPTR    PPWORD             POINTER TO RESIDENT SS TABLE. IF ZERO
                             THE TABLE IS IN THE UNIT COMM. BUFFER
* WORD 3
 CLK      PPWORD             SECONDS CLOCK OF LAST ACTIVITY
* WORD 4
 UIT      STRUCT 6           RMA OF UNIT INTERFACE TABLE (REFORMATTED)
          MASKP  NCR
 K.NCR    EQU    MSK
          MASKP  RD
 K.RD     EQU    MSK
 UN       RECEND
          SPACE  5,20
* SS TABLE DEFINITIONS. INFORMATION SAVED FOR EACH UNIT.

 SS       RECORD PACKED

* WORD 1

 MREV     SUBRANGE 0,377B    CM3 MICROCODE REVISION
 FILL1    SUBRANGE 0,77B
 CRN      SUBRANGE 0,3       USED TO MAKE COMMAND REFERENCE NUMBER UNIQUE
*
 CMOD     SUBRANGE 0,377B    CONTROL MODULE NUMBER
 UNIT     SUBRANGE 0,377B    UNIT NUMBER
*
 LU       PPWORD             LOGICAL UNIT
*
 FNC      PPWORD             FUNCTION CODE  READ = 0
                                            WRITE = 1
                                            FORMAT = 2
 REQ      STRUCT 4           CURRENT REQUEST (UNFORMATTED RMA)
 PVA      STRUCT 6           PVA OF CURRENT REQUEST

 LASTC    PPWORD             OFFSET OF COMMAND IN REQUEST
 FRST     PPWORD             = 0, IF FIRST TIME THROUGH UNCMND
 NUMCM    PPWORD             NUMBER OF COMMANDS LEFT TO PROCESS IN
                             THIS REQUEST
 LISTL    PPWORD             NUMBER OF CM WORDS IN ADDRESS-LENGTH PAIR LIST.
                             (INCLUDES THE NUMBER OF WORDS WHICH HAVENT
                             BEEN READ FROM CM.)
 TOTAL    STRUCT 4           TOTAL CM BYTES LEFT TO TRANSFER
 MT       EQU    /SS/P.TOTAL MASTER TERMINATE FLAG
                              8XXX IF USING MASTER TERMINATE,
                              XXX NOT 0 IF COMMAND TERMINATED
 FCOMRQ   STRUCT 4           FIRST COMPLETED REQUEST (RMA)
 CURRQ    STRUCT 4           CURRENT REQUEST (RMA)
 PRERQ    STRUCT 4           PREVIOUS REQUEST (RMA)
 NCOMRQ   PPWORD             NUMBER OF COMPLETED REQUESTS
 NCR      PPWORD             NUMBER OF COMPLETED REQUESTS
 CURTRK   PPWORD             CURRENT TRACK
 CURSEC   PPWORD             CURRENT SECTOR
 SWFLG    PPWORD             NONZERO IF A STREAMING REQUEST SWITCH WAS MADE
 FPVA     STRUCT 6           PVA OF FIRST COMPLETED REQUEST
 XFER     STRUCT 4           TRANSFER COUNT
 PVA2     STRUCT 6           PVA FOR SECOND COMMAND
 RMA2     STRUCT 4           RMA FOR SECOND COMMAND
 TW2      STRUCT 4           TOTAL CM BYTES TO TRANSFER FOR 2ND COMMAND
 MT2      EQU    /SS/P.TW2   MASTER TERMINATE FLAG FOR 2ND COMMAND
 RQTRY    PPWORD             REQUEST RETRY COUNT
 RESET    PPWORD             RESET ISSUED
                              1 SLAVE ASYNCH EXPECTED
                              2 DRIVE ASYNCH EXPECTED AFTER SLAVE RESET
                              3 BOTH 1 AND 2
 CT       PPWORD             NONZERO WHEN CONFIDENCE TEST IS COMPLETE
                              1 IF NO ERROR
                              2 IF ERROR
                              4 IF DATA INTEGRITY ERROR
 RECOV    PPWORD             NONZERO IF IN RECOVERY
 DP       STRUCT 6           DELINK POINTER (REFORMATTED RMA)

 RQ       STRUCT 40          REQUEST

 CMLIST   STRUCT 8           CURRENT DATA ADDRESS OR CURRENT COMMAND

 SS       RECEND

* ALTERNATE USAGE OF LOCATIONS IN SS TABLE DURING CONFIDENCE TEST
 STT      EQU    /SS/P.PVA2   SECTORS TO TRANSFER
 CTME     EQU    /SS/P.PVA2+1 START OF 3 WORD TABLE WITH EACH WORD
                               CONTAINING THE HEAD AND SECTOR NUMBER OF
                               OF A MEDIA ERROR
          SPACE  6
* PP INTERFACE TABLE
 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
 .U       IFEQ   UNIX,1
 ACTCH    BOOLEAN            ACTIVE CHECK, THE PP CLEARS THIS BIT WITHIN 1 MINUTE
 IDLREQ   BOOLEAN            IDLE REQUEST
 RESREQ   BOOLEAN            RESUME REQUEST
 PPIDLE   BOOLEAN            PP IDLE
          SUBRANGE 0,3777B   UNUSED
 LOCK     BOOLEAN            PP TABLE LOCK
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
          STRUCT 24          UNUSED
 .U       ELSE
          ALIGN  0,64
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER
          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)
          ALIGN 32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)
 .U       ENDIF
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          SPACE  6
* UNIT DESCRIPTORS.

 UD       RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 UD       RECEND
          SPACE  6
* UNIT INTERFACE TABLE

 UIT      RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
                               = 400B, 844-4X
                               = 401B, 885-1X
                               = 402B, 885-42
 QCNT     PPWORD             QUEUE COUNT
*
          ALIGN  16,64
 UBUFL    PPWORD             UNIT COMMUNICATION BUFFER LENGTH
 UBUF     RMA                UNIT COMMUNICATION BUFFER (RMA)
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

          MASKP  DSABLE
 K.DSABLE EQU    MSK

 UIT      RECEND
          SPACE  6
* PP REQUESTS.

 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (NOT USED)
                               0 - ATTEMPT RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY (NOT USED)
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
          ALIGN  0,64
 SWIT     BOOLEAN            SWITCH TO NEXT REQUEST
          ALIGN  16,64
 CYL      PPWORD             CYLINDER ADDRESS
 TRACK    PPWORD             TRACK ADDRESS
 SECTOR   PPWORD             SECTOR ADDRESS
 CMND     INTEGER            COMMAND SEQUENCE


          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$

 RQ       RECEND
          SPACE  6
* PP COMMAND.

 CM       RECORD PACKED

 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$
          SPACE  5,20
* PP RESPONSE.

 RS       RECORD PACKED

* WORD 1.
 .U       IFEQ   UNIX,1
 FILL1    BOOLEAN
 SHORT    BOOLEAN            IF SET, ONE-WORD RESPONSE
          SUBRANGE 0,77B     UNUSED
          SUBRANGE 0,377B    LOGICAL UNIT (FOR DEBUG)
 .U       ENDIF
          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST

* WORD 2.
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST  (NOT USED)

* WORD 3.
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST) (NOT USED)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)  (NOT USED)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS  (NOT USED)
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY  (NOT USED)
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

* WORD 4.
          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED  (NOT USED)
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE INTERFACE
                             ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
                             (NOT USED)
 CHERR    BOOLEAN            CHANNEL PARITY ERROR (NOT USED)
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION
                             OCCURRED ON INPUT OR INADEQUATE DATA RATE ON OUTPUT
                             (NOT USED)
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT  (NOT USED)
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A
                             HARDWARE MALFUNCTION.  EXAMPLE-UNIT NOT
                             READY, UNIT NOT CONNECTED.  (NOT USED)
 FTO      BOOLEAN            FUNCTION TIMEOUT (NOT USED)
 CHERO    BOOLEAN            CHANNEL OUTPUT PARITY ERROR (NOT USED)
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
                               1 - RECOVERED ERROR
                               2 - COMMAND HAD EXPLICIT RESPONSE FLAG SET
                               3 - BOTH CONDITIONS 1 AND 2
 K.REC    EQU    1           RECOVERED ERROR
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE  (NOT USED)
                               1 - UNIT CHANGED FROM READY TO NOT READY
                               2 - UNIT CHANGED FROM NOT READY TO READY
                               3 - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
                               4 - CONTROLLER RESERVED
                               5 - UNIT RESERVED TO ANOTHER ACCESS
                               6 - RECOVERED ABNORMAL CONDITION
          ALIGN  49,64       ALERT CONDITIONS
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

* WORD 5.
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)(NOT USED)

* WORD 6.
 CHAN     PPWORD             CHANNEL NUMBER
 SCYL     PPWORD             STARTING CYLINDER
 STRK     PPWORD             STARTING TRACK
 SSEC     PPWORD             STARTING SECTOR

* WORD 7.
 UNIT     PPWORD             UNIT NUMBER
 RTRY     PPWORD             REQUEST RETRY COUNT
 FTRK     PPWORD             FAILING TRACK
 FSEC     PPWORD             FAILING SECTOR
* WORD 8
 WC       PPWORD             WORDS NOT TRANSFERRED
 FUNTO    PPWORD             FUNCTION WITH TIMEOUT
 ID       PPWORD             ERROR IDENTIFIER
 K.UDN    EQU    3           UNIT DOWN
 K.CMDN   EQU    2           CONTROL MODULE DOWN
 K.CHDN   EQU    1           CHANNEL DOWN
 ERRID    PPWORD             ERROR IDENTIFIER
* WORD 9
 MREV     PPWORD             CM3 MICROCODE REVISION
 STREG    PPWORD             IPI CHIP STATUS REGISTER
 ERREG    PPWORD             IPI CHIP ERROR REGISTER
 FILL1    PPWORD
* WORD 10
 DMAER    PPWORD             DMA ERROR REGISTER
 OSR      PPWORD             OPERATIONAL STATUS REGISTER
 CR       PPWORD             CONTROL REGISTER
 FILL2    PPWORD

          MASKP  INTERR
 K.INTERR EQU    MSK
          MASKP  DATERR
 K.DATERR EQU    MSK
 .U       IFEQ   UNIX,1
          MASKP  SHORT
 K.SHORT  EQU    MSK
 .U       ENDIF

 RS       RECEND


 CM       RECEND
          SPACE  6
* COMMAND CODES.

 C.IDLE   EQU    4           IDLE
 C.RESUME EQU    5           RESUME
 C.READ   EQU    100B        READ
 C.WRITE  EQU    120B        WRITE
 C.FORMAT EQU    164B        FORMAT
          SPACE  5,20
* RESPONSE CODES.

 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    1           INTERMEDIATE RESPONSE
 R.NRM    EQU    2           NORMAL REQUEST TERMINATION
 R.ABN    EQU    3           ABNORMAL REQUEST TERMINATION
          SPACE  10
* PP COMMUNICATION BUFFER.

 CB       RECORD PACKED

          ALIGN  31,64
 SLAVE    BOOLEAN            NONZERO IF SLAVE PP (NOT USED)
 PARTNR   RMA                PARTNERS COMMUNICATION BUFFER (RMA) (NOT USED)

 CONTRL   STRUCT 8           LOAD CONTROLWARE COMMAND (NOT USED)
 CMCTRL   STRUCT 8           LOAD CONTROLLER CONTROLWARE (NOT USED)
          STRUCT 64          (NOT USED)
          ALIGN  0,64
 BUF      STRUCT 5240        DATA BUFFER FOR CONFIDENCE TEST
                              BYTES = SECTOR (2048) + 8 TIMES
                              (SECTORS (21) X TRACKS (19))
 CB       RECEND
 RPBL     EQU    192         MAXIMUM LENGTH OF RESPONSE BUFFER
 EOM      EQU    20000B
 RPB      EQU    EOM-RPBL    RESPONSE PACKET BUFFER
 RS       EQU    RPB-P.RS    DISK RESPONSE

 IPIT     EQU    RPB+64      PP INTERFACE TABLE
 UBUF     EQU    IPIT+P.PIT  UNIT INTERFACE TABLE
 IBUF     EQU    UBUF+P.UIT  UNIT DESCRIPTOR BUFFER
 NRQ      EQU    IPIT+P.SS   NEXT REQUEST
          ERRMI  EOM-NRQ+20  IF TABLE OVERFLOWS MEMORY
 RQT      EQU    NRQ+8
          ERRMI  RPBL-P.PIT-P.UIT-8-64 IF TABLES OVERFLOW MEMORY
 OB       EQU    RPB+64      OUTPUT BUFFER FOR PP/CONTROLLER PATH TEST
 IB       EQU    RPB+128     INPUT BUFFER FOR PP/CONTROLLER PATH TEST
 IBN      EQU    IB+50       END OF INPUT BUFFER
          ERRMI  EOM-IBN     IF TABLES OVERFLOW MEMORY
 RQ       EQU    /SS/P.RQ    REQUEST
 CM       EQU    RQ+/RQ/P.CMND  CURRENT COMMAND
 CMLIST   EQU    /SS/P.CMLIST  INDIRECT RMA LIST
          EJECT
          CON    MAIN-1

* DIRECT CELLS

 CM.PIT   BSSZ   3           CM ADDRESS OF PP INTERFACE TABLE
                              THE BYTE ADDRESS IS
                               RIGHTMOST 10 BITS OF WORD 0 CONCATENATED WITH
                               RIGHTMOST 12 BITS OF WORD 1 CONCATENATED WITH
                               RIGHTMOST 6 BITS OF WORD 2 CONCATENATED WITH
                               3 BITS OF ZEROS
 T1       BSSZ   1
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1

 CMADR    BSSZ   3           CM ADDRESS
 CHAN     BSSZ   1           CHANNEL NUMBER
 STATUS   BSSZ   2           IPI CHANNEL STATUS
 OS       BSSZ   1           OPERATIONAL STATUS
 CMNDS    BSSZ   1           NUMBER OF OUTSTANDING COMMANDS
 CMOD     BSSZ   1           PORT NUMBER AND CONTROLLER NUMBER (0000PCCC)
 UX       BSSZ   1           INDEX TO UNITS TABLE
 .F       IFEQ   FHT,1       FOR FUNCTION HISTORY TABLE
 FI       BSSZ   1           INDEX TO FUNCTION HISTORY BUFFER
 .F       ENDIF
 P1       BSSZ   1
 P2       BSSZ   1
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 P6       BSSZ   1
* BC, RMA ARE T REGISTER PARAMETERS
 BC       BSSZ   1           BYTE COUNT TO READ/WRITE
 RMA      BSSZ   2           RMA FOR DMA TRANSFER

 FNC      BSSZ   1           FUNCTION CODE (INTERNAL)
 LF       BSSZ   1           LAST FUNCTION TO IPI ADAPTER
 CNUM     BSSZ   1           0 IF ONE COMMAND, 1 IF 2 COMMANDS ISSUED TO
                              THE CONTROL MODULE
 WC       BSSZ   1           WORD COUNT
 BBS      BSSZ   1           BURSTS TO TRANSFER BEFORE SUSPENDING
 BURPOS   BSSZ   1           BURST BUFFER TRANSFER POSITION (TO CM)
 CSST     BSSZ   1           POINTER TO CURRENT SS TABLE
 LUX      BSSZ   1           VALUE OF UNIT INDEX OF LAST UNIT SELECTED
 TOTAL    BSSZ   2           TOTAL BYTES TO TRANSFER
 SSUN     CON    7777B       UX VALUE OF CURRENT SS TABLE
 UNUML    BSSZ   1           LENGTH OF CONFIGURED UNIT ENTRIES
 TMF      BSSZ   1           TEST MODE FLAG, NONZERO IF TEST MODE IN PROGRESS
 .U       IFNE   UNIX,1
 IDLE     BSSZ   1           NONZERO IF IDLE COMMAND RECEIVED,
                              RESUME COMMAND SETS IT TO ZERO
 .U       ENDIF
 MALET    BSSZ   1           NONZERO IF MAINTENANCE SOFTWARE WANTS
                              THE CHANNEL
 TBC      BSSZ   1           NONZERO IF TRANSFER RESPONSE RECEIVED
                              BEFORE COMPLETION RESPONSE
 CLF      DATA   1           CHANNEL LOCK FLAG, 0 IF LOCK IS SET
 CTM      BSSZ   1           USED TO CHANGE TRANSFER MODE TO STREAMING
                             FOR COMMAND AND RESPONSE PACKETS
 CLCUR    BSSZ   1           CHANNEL 14 CLOCK CURRENT VALUE
 CLMCS    BSSZ   1           CLOCK, MICROSECOND
 CLMLS    BSSZ   1           CLOCK, MILLISECOND
 CLSEC    BSSZ   1           CLOCK, SECOND
 CTPAT    DATA   0           CONFIDENCE TEST PATTERN FIRST WORD
 .F       IFEQ   FE,1
 FEST     DATA   0           FORCE ERROR START COUNT
 FEND     DATA   0           FORCE ERROR END COUNT
 FEUN     DATA   0           UNIT NUMBER TO FORCE ERROR ON
 .F       ENDIF
          SPACE  2
          BSS    72B-*
 DSRTP    DATA   2,0         RMA OF PP INTERFACE TABLE AT DEADSTART
 CH       EQU    DSRTP       0 IF 10 MB/S IPI CHANNEL
                              1 IF 25 MB/S IPI CHANNEL
 INPNT    EQU    DSRTP+1     IN POINTER FOR RESPONSE BUFFER
 LIM      BSSZ   1           LIMIT OF RESPONSE BUFFER (IN 8-BIT BYTES)
 PPNO     CON    1           LOGICAL PP NUMBER
 PTF      BSSZ   1           IF 0 EXECUTE PATH TEST
 IF       BSSZ   1           INITIALIZATION FLAG
          BSS    100B-*
          LJM    MAIN
          DATA   8           I4/IPI DRIVER (FOR ANAD PROC)
 HANG     CON    0           AN EASY WAY TO SEE CERTAIN HANGS
          UJN    *
          SPACE  2
* THE FOLLOWING CM ADDRESSES ARE SET DURING INITIALIZATION
*         THE BYTE ADDRESS IS
*          RIGHTMOST 10 BITS OF WORD 0 CONCATENATED WITH
*          RIGHTMOST 12 BITS OF WORD 1 CONCATENATED WITH
*          RIGHTMOST 6 BITS OF WORD 2 CONCATENATED WITH
*          3 BITS OF ZEROS

 CM.CB.T  BSSZ   3           ADDRESS OF PP COMMUNICATION BUFFER (T REG. FORMAT)
 CM.CB    BSSZ   3           ADDRESS OF BUF WITHIN PP COMMUNICATION BUFFER
 CM.RS    BSSZ   3           ADDRESS OF RESPONSE BUFFER
 CM.INT   BSSZ   3           ADDRESS OF INTERRUPT WORD
 CM.CHAN  BSSZ   3           ADDRESS OF CHANNEL INTERLOCK TABLE
          SPACE  5,20
*         LOCATION CH IS THE INDEX INTO THIS CHANNEL TYPE TABLE

 WOR      DATA   0#14        10 MB CHANNEL WRITE OPERAND REGISTER FUNCTION
          DATA   0#702       25 MB CHANNEL WRITE OPERAND REGISTER FUNCTION

 TMWC     DATA   0#8064      10 MB CHANNEL TEST MODE WORD COUNT
          DATA   0#FF9C      25 MB CHANNEL TEST MODE WORD COUNT

 ETMF     CON    H0300       10 MB CHANNEL ENABLE TEST MODE FUNCTION
          CON    H0302       25 MB CHANNEL ENABLE TEST MODE FUNCTION

 ETMP     DATA   0#1000      10 MB CHANNEL, ENABLE TEST MODE PARAMETER
          DATA   0#80FF      25 MB CHANNEL, ENABLE TEST MODE PARAMETER

 EOG1     DATA   0#D79A      10 MB CHANNEL, EXPECTED OPERAND GENERATOR
          DATA   0#71        25 MB CHANNEL, EXPECTED OPERAND GENERATOR

 EOG2     DATA   0#2A92      10 MB CHANNEL, EXPECTED OPERAND GENERATOR
          DATA   0           25 MB CHANNEL, EXPECTED OPERAND GENERATOR

 RORF     DATA   4           10 MB CHANNEL, READ OPERAND GENERATOR FUNCTION
          DATA   0#802       25 MB CHANNEL, READ OPERAND GENERATOR FUNCTION

 EC1      DATA   0#FA15      10 MB CHANNEL, EXPECTED CHECKSUM
          DATA   0#DACF      25 MB CHANNEL, EXPECTED CHECKSUM

 EC2      DATA   0#31        10 MB CHANNEL, EXPECTED CHECKSUM
          DATA   0#36        25 MB CHANNEL, EXPECTED CHECKSUM

 FIP      DATA   0           FORMAT IN PROGRESS FLAG

 .F       IFEQ   FE,1
          BSS    60          FOR PATCHES DURING CHECKOUT
 .F       ENDIF
          TITLE  MAIN LOOP
** NAME-- MAIN
*
** PURPOSE-- MAIN IDLE LOOP.  LOOK FOR REQUESTS FROM CENTRAL MEMORY
*            AND LOOK FOR INTERRUPTS FROM THE CONTROLLERS.
*
** ENTRY
*         MAIN - AFTER DRIVER IS LOADED
*         MAIN5 - WHEN THE PP IS RESUMED
*         MAIN10 - TO RUN DIAGNOSTICS DURING ERROR RECOVERY
*         MAIN15 - AFTER SEEK, WRITE, OR READ COMMAND STARTED
*         MAIN20 - WHEN A WRITE OR READ COMMMAND COMPLETES
          SPACE  2
 MAIN     BSS
          REFAD  DSRTP,CM.PIT REFORMAT ADDRESS OF PP INTERFACE TABLE
                               AND SAVE IN CM.PIT
 MAIN5    BSS
          RJM    INIT        INITIALIZATION
 MAIN10   BSS
          RJM    PT          PATH TEST
 MAIN15   BSS
 .F       IFEQ   FE,1        FORCE ERROR IN RUNNING PP DRIVER
          RJM    FER         FORCE ERROR ROUTINE
 .F       ENDIF
          RJM    EI          ENABLE INTERRUPTS
          RJM    PPRQ        CHECK FOR ANY PP REQUESTS
          RJM    GETUD       SELECT UNIT REQUESTS, SEEK,
                             AND PROCESS INTERRUPTS
          LDDL   CMNDS
          NJK    MAIN15      IF OUTSTANDING COMMANDS
 MAIN20   BSS
          SOML   CHLCNT
          NJN    MAIN15      IF PP DOESN'T HAVE TO GIVE UP CHANNEL
          LDML   FIP
          NJN    MAIN15      IF FORMAT IN PROGRESS
          RJM    CKC         CHECK IF CHANNEL MUST BE GIVEN UP
          UJK    MAIN15
          SPACE  5,12
 UCMD     BSS                COMMANDS FROM CENTRAL MEMORY
          CON    C.READ
          CON    C.WRITE
          CON    C.IDLE
          CON    C.RESUME
          CON    C.FORMAT
 UCMDL    EQU    *-UCMD
          TITLE  COMMANDS
** NAME-- READ
*
** PURPOSE-- PROCESS READ DATA COMMAND.
*
** INPUT-- LISTL = NUMBER OF ADDRESS-LENGTH-PAIR ENTRIES IN THE
*                    COMMAND WHICH ARE LEFT TO PROCESS.
*          CMLIST  = LIST OF ADDRESS-LENGTH-PAIRS POINTING TO THE
*                    CM DATA AREA.
          SPACE  2
 READX    LJM    **
 READ     EQU    *-1
 READ20   BSS
          LDML   CMLIST+/CM/P.LEN,CSST NUMBER OF BYTES LEFT TO TRANSFER
          STDL   BC          CM BYTES LEFT TO TRANSFER
          ADC    -BPS        CM BYTES PER BURST
          ADDL   BURPOS      BYTES PREVIOUSLY TRANSFERRED FROM THIS BURST
          MJN    READ30      IF LESS THAN 1 BURST LEFT TO TRANSFER
          LDC    BPS         COMPUTE NUMBER OF CM BYTES TO TRANSFER THIS LOOP
          SBDL   BURPOS
          STDL   BC          NUMBER OF CM BYTES TO TRANSFER
 READ30   BSS
          LDDL   BURPOS
          NJN    READ36      IF BUS CONTROL ALREADY DONE
          LDN    DATAIN      DATA, INFORMATION IN
          RJM    BCS         BUS CONTROL SEQUENCE
 READ32   EQU    *-1         FOR FORCING ERRORS
          LDC    H0281       STREAM, READ
          RJM    FUNC        RAISE MASTER OUT
 READ34   EQU    *-1         FOR FORCING ERRORS
          UJN    READ38
 READ36   BSS
          RJM    WFTE        WAIT FOR T PRIME REGISTER EMPTY
 READ38   BSS
          LDC    H0C00       DMA READ
          RJM    FUNC
          ACN    DC
          LDML   CMLIST+/CM/P.RMA,CSST
          STDL   RMA         CM ADDRESS OF DATA AREA
          LDML   CMLIST+/CM/P.RMA+1,CSST
          STDL   RMA+1
          LDN    3
          OAM    BC,DC       BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
 READ40   EQU    *-1         FOR FORCING ERRORS
          LDML   /SS/P.NCR,CSST NUMBER OF COMPLETED REQUESTS
          ZJN    READ42      IF NO COMPLETED REQUESTS
          RJM    RDWTOK      SEND RESPONSE FOR GOOD READ
 READ42   BSS
          LDDL   BC
          RADL   BURPOS      UPDATE BURST POSITION
          ADC    -BPS        CHECK FOR END OF BURST
          ZJN    READ55      IF END OF BURST
          LDML   /SS/P.LISTL,CSST CHECK IF MORE CM ADDRESS-LENGTH-PAIRS
          SBN    1
          ZJN    READ45      IF ALL DATA FOR THIS BURST TRANSFERRED
          RJM    UBT         UPDATE BYTES TRANSFERRED
          UJN    READ100
 READ45   BSS
          LDC    BPS         CM BYTES PER BURST
          SBDL   BURPOS
          STML   CM.CB.T     BYTES TO TRANSFER
          RJM    WFTE        WAIT FOR T PRIME REGISTER EMPTY
          LDC    H0B00       WRITE T PRIME REGISTER
          RJM    FUNC
          ACN    DC
          LDN    3
          OAM    CM.CB.T,DC  BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
 READ55   BSS
          RJM    UBT         UPDATE BYTES TRANSFERRED
          RJM    WFTC        WAIT FOR TRANSFER COMPLETE
          NJN    READ80      IF NO ERROR
          LJM    READ160     EXIT, RESPONSE PACKET WILL HAVE ERROR STATUS
 READ80   BSS
          RJM    UDA         UPDATE DISK ADDRESS
 READ100  BSS
          RJM    CRS         CHECK FOR REQUEST SWITCH
          NJK    READ20      IF MORE DATA TO TRANSFER
 READ160  BSS
          LJM    READX
          EJECT
** NAME-- WRITE
*
** PURPOSE-- PROCESS THE WRITE DATA COMMAND.
*
** INPUT-- LISTL = NUMBER OF ADDRESS-LENGTH-PAIR ENTRIES IN THE
*                    COMMAND WHICH ARE LEFT TO PROCESS.
*          CMLIST = LIST OF ADDRESS-LENGTH-PAIRS POINTING TO THE
*                   CM DATA AREA.
          SPACE  2
 WRITE    CON    0
 WRI20    BSS
          LDML   CMLIST+/CM/P.LEN,CSST NUMBER OF BYTES LEFT TO TRANSFER
          STDL   BC          CM BYTES LEFT TO TRANSFER
          ADC    -BPS        CM BYTES PER BURST
          ADDL   BURPOS      BYTES PREVIOUSLY TRANSFERRED FROM THIS BURST
          MJN    WRI30       IF LESS THAN 1 BURST LEFT TO TRANSFER
          LDC    BPS         COMPUTE NUMBER OF CM BYTES TO TRANSFER THIS LOOP
          SBDL   BURPOS
          STDL   BC          NUMBER OF CM BYTES TO TRANSFER
 WRI30    BSS
          LDDL   BURPOS
          NJN    WRI36       IF BUS CONTROL ALREADY DONE
          LDN    DATAOUT     DATA, INFORMATION OUT
          RJM    BCS         BUS CONTROL SEQUENCE
 WRI32    EQU    *-1         FOR FORCING ERRORS
          LDC    H0381       STREAM, WRITE
          RJM    FUNC        RAISE MASTER OUT
 WRI34    EQU    *-1         FOR FORCING ERRORS
          UJN    WRI38
 WRI36    BSS
          RJM    WFTE        WAIT FOR T PRIME REGISTER EMPTY
 WRI38    BSS
          LDC    H0D00       DMA WRITE
          RJM    FUNC
          ACN    DC
          LDML   CMLIST+/CM/P.RMA,CSST
          STDL   RMA         CM ADDRESS OF DATA AREA
          LDML   CMLIST+/CM/P.RMA+1,CSST
          STDL   RMA+1
          LDN    3
          OAM    BC,DC       BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
 WRI40    EQU    *-1         FOR FORCING ERRORS
          LDDL   BC
          RADL   BURPOS      UPDATE BURST POSITION
          ADC    -BPS        CHECK FOR END OF BURST
          ZJN    WRI55       IF END OF BURST
          LDML   /SS/P.LISTL,CSST CHECK IF MORE CM ADDRESS-LENGTH-PAIRS
          SBN    1
          ZJN    WRI45       IF ALL DATA FOR THIS BURST TRANSFERRED
          RJM    UBT         UPDATE BYTES TRANSFERRED
          UJN    WRI100
 WRI45    BSS
          LDC    BPS         CM BYTES PER BURST
          SBDL   BURPOS
          STML   CM.CB.T     BYTES TO TRANSFER
          RJM    WFTE        WAIT FOR T PRIME REGISTER EMPTY
          LDC    H0B00       WRITE T PRIME REGISTER
          RJM    FUNC
          ACN    DC
          LDN    3
          OAM    CM.CB.T,DC  BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
 WRI55    BSS
          RJM    UBT         UPDATE BYTES TRANSFERRED
          RJM    WFTC        WAIT FOR TRANSFER COMPLETE
          NJN    WRI80       IF NO ERROR
          UJN    WRI160      EXIT, RESPONSE PACKET WILL HAVE ERROR STATUS
 WRI80    BSS
          RJM    UDA         UPDATE DISK ADDRESS
 WRI100   BSS
          RJM    CRS         CHECK FOR REQUEST SWITCH
          NJK    WRI20       IF MORE DATA TO TRANSFER
 WRI160   BSS
          LJM    MAIN15
          TITLE  COMMAND SUBROUTINES
** NAME-- BCTB
*
** PURPOSE-- BUILD CONFIDENCE TEST WRITE BUFFER
          SPACE  2
 BCTBX    LJM    **
 BCTB     EQU    *-1
          IAN    14B
          STDL   CTPAT       CONFIDENCE TEST PATTERN FIRST WORD MINUS ONE
          STDL   P1
          LOADC  CM.CB       ADDRESS OF PP COMMUNICATIONS BUFFER
          STDL   P2
 BCTB10   BSS
          AODL   P1          BUILD INCREMENTING PATTERN
          STDL   T1
          AODL   P1
          STDL   T2
          AODL   P1
          STDL   T3
          AODL   P1
          STDL   T4
          SBDL   CTPAT
          ADC    -P.CB-4+/CB/P.BUF
          PJN    BCTBX       IF ALL WORDS STORED
          LDDL   P2
          LMC    400000B
          CWDL   T1          STORE IN PP COMMUNICATIONS BUFFER
          AODL   P2
          UJN    BCTB10
          SPACE  5,20
** NAME-- BPTB
*
** PURPOSE-- BUILD PATH TEST BUFFER
          SPACE  2
 BPTBX    LJM    **
 BPTB     EQU    *-1
          LDN    0
          STDL   T1          INDEX TO OUTPUT BUFFER
          LDN    10
          STDL   T2          TIMES TO REPEAT PATTERN
 BPTB4    BSS
          LCN    0           PATTERN IS FFFF, 0000, AAAA, 5555,
          STML   OB,T1        FEFD REPEATED 10 TIMES
          LDN    0
          STML   OB+1,T1
          LDC    0#AAAA
          STML   OB+2,T1
          SHN    -1
          STML   OB+3,T1
          LDC    0#FEFD
          STML   OB+4,T1
          LDN    5
          RADL   T1
          SODL   T2
          ZJN    BPTBX       IF DONE
          UJN    BPTB4
          SPACE  5,20
** NAME-- CBC
*
** PURPOSE-- COMPUTE BYTE COUNT TO TRANSFER
          SPACE  2
 CBCX     BSS
          LDN    SPT         SECTORS PER TRACK
          SBML   /SS/P.CURSEC,CSST
          RADL   TOTAL+1
          STML   STT,CSST    SECTORS TO TRANSFER
          SHN    -5
          STDL   TOTAL       UPPER 16 BITS OF BYTE COUNT
          LDDL   TOTAL+1
          LPN    37B
          SHN    11
          STDL   TOTAL+1     LOWER 16 BITS OF BYTE COUNT
          LJM    **
 CBC      EQU    *-1
          LDML   /SS/P.CURTRK,CSST
          STDL   T1          TRACK
          SHN    8
          ADML   /SS/P.CURSEC,CSST
          STML   CP+FCP+4    TRACK, SECTOR FOR COMMAND PACKET
          LDC    MAXCYL-1
          STML   CP+FCP+3    CYLINDER FOR COMMAND PACKET
          LDN    0
          STDL   TOTAL+1
          STML   CP+FCP+1    UPPER WORD OF SECTOR COUNT
          STML   /SS/MT,CSST NO MASTER TERMINATION
 CBC10    BSS
          AODL   T1
          LMN    MAXTR+1
          ZJK    CBCX        IF LAST TRACK
          LDN    SPT         SECTORS PER TRACK
          RADL   TOTAL+1
          UJN    CBC10
          SPACE  5,20
** NAME-- CCLOCK
*
** PURPOSE-- CLEARS CHANNEL LOCK.
          SPACE  2
 CCLX     LJM    **
 CCLOCK   EQU    *-1
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          STDL   CLF         CHANNEL LOCK FLAG
          LDDL   CHAN        CHANNEL NUMBER = OFFSET IN TABLE
          STDL   T5
          RJM    CLOCK       CLEAR CHANNEL LOCKWORD
          UJK    CCLX
          SPACE  5,20
** NAME-- CD
*
** PURPOSE-- CHECK DRIVE.  IF COMMAND IS FORMAT GO TO FORMAT ROUTINE
*            ELSE ASSUME THAT CONFIDENCE IS TO BE RUN. ENSURE THAT DRIVE
*            IS FORMATTED BEFORE STARTING THE CONFIDENCE TEST. IF DRIVE
*            IS NOT FORMATTED CHECK IF REQUEST IS A READ OF THE LABEL
*            AREA AND IF SO RETURN WITHOUT DOWNING THE DRIVE. THIS CHECK IS
*            NEEDED BECAUSE NOS/VE ALWAYS ATTEMPTS TO READ THE LABEL EVEN
*            WHEN ATTEMPTING TO FORMAT THE DRIVE.
*
** ENTRY-- FROM GETU IF A REQUEST IS PRESENT AND THE CONFIDENCE TEST
*          HAS NOT BEEN RUN FOR A UNIT AFTER THE PP WAS LOADED OR WHEN A
*          FORMAT COMMAND HAS BEEN ISSUED TO THE UNIT.
*
          SPACE  2
 CDX      LJM    **
 CD       EQU    *-1
          LDML   /SS/P.FNC,CSST
          SBN    4
          NJN    CD05        IF NOT FORMAT COMMAND
          LDML   UNITS,UX
          LPC    0#1FFF
          STML   UNITS,UX    CLEAR COMMAND IN PROGRESS BITS
          LDN    1
          STML   /SS/P.CT,CSST  DISABLE RUNNING CONFIDENCE TEST

*         DRIVE RESET COULD TAKE UP TO 15 SECONDS, SO ONLY DO IT ONCE PER
*         ERROR DURING ERROR PROCESSING.

 CD05     LDML   /SS/P.RECOV,CSST
          LMN    1
          ZJN    CD10        IF RUNNING CONFIDENCE TEST TO ISOLATE TO MEDIA ERROR
          LDML   /SS/P.RQTRY,CSST  RETRY COUNT
          LMN    1
          NJN    CD20        IF NOT FIRST ERROR RETRY
 CD10     BSS
          RJM    DPR         DRIVE POWER ON RESET
 CD20     RJM    RMR         READ MICROCODE REVISION
          RJM    DUSC        DISABLE USAGE STATISTIC COUNTING
          RJM    RD          RESERVE DRIVE
          LDML   /SS/P.FNC,CSST
          SBN    4
          NJN    CD25        IF NOT FORMAT COMMAND
          STDL   IF          CLEAR INITIALIZATION FLAG
          RJM    IU          INITIALIZE UNIT
          LDN    1           ENABLE CT BYPASS
          UJN    CD27
 CD25     RJM    IUF         IS UNIT FORMATTED
          NJN    CD30        UNIT IS NOT FORMATTED
 CD27     UJK    CDX
 CD30     BSS
          LDML   /SS/P.FNC,CSST
          NJN    CD50        IF NOT READ COMMAND
          LDML   RQ+/RQ/P.CYL,CSST
          NJN    CD50        IF NOT CYLINDER WITH LABEL
          LDML   RQ+/RQ/P.TRACK,CSST
          NJN    CD50        IF NOT TRACK WITH LABEL
          LDN    1
          STDL   CMNDS       SO DCR ROUTINE LEAVES CMNDS EQUAL TO 0
          LDC    E141        ERROR CODE (141)
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LJM    EPF10       SEND ABNORMAL RESPONSE (NO RETURN)
 CD50     BSS
          LDC    E141        ERROR CODE (141)
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- CFME
*
** PURPOSE-- CHECK FOR MEDIA ERROR
*
** EXIT--  A = 0 IF MEDIA ERROR AND FAILING ADDRESS IS PRESENT
          SPACE  2
 CFME20   BSS
          LDN    1           INDICATE MEDIA ERROR NOT FOUND
 CFMEX    LJM    **
 CFME     EQU    *-1
          LDML   RS+/RS/P.ERRID
          NJN    CFMEX       IF NOT MEDIA ERROR
          LDK    ID26        DRIVE MACHINE EXCEPTION
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    CFMEX       IF ID26 NOT FOUND
          LDML   RPB+5,T3
          SHN    -8
          SBN    11
          MJN    CFME20      IF NO EXTENDED SUBSTATUS
          LDML   RPB+10,T3   COMMAND ENDING STATUS
          STDL   T5
          LPN    77B
          SBN    0#11
          ZJN    CFME10      IF ECC ERROR
          SBN    2
          ZJN    CFME10      IF MISSING SYNC
          SBN    6
          NJN    CFMEX       IF NOT (SECTOR NOT FOUND) ERROR
 CFME10   BSS
          LDK    ID32        RESPONSE EXTENT PARAMETER
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    CFMEX       IF PARAMETER 32 NOT FOUND
          LDN    0           INDICATE MEDIA ERROR FOUND
          UJN    CFMEX
          SPACE  5,20
** NAME-- CHGCH
*
** PURPOSE-- SET CHANNEL NUMBER IN CHANNEL INSTRUCTIONS
*
** INPUT-- CHAN = CHANNEL NUMBER
          SPACE  2
 CHGX     LJM    **
 CHGCH    EQU    *-1
          LDN    0
          STDL   T1          CHANGE DISK CHANNEL INSTRUCTIONS
 CHG10    LDML   CONCH,T1    ADDRESS OF CHANNEL INSTRUCTIONS
          ZJN    CHGX        END OF LIST
          STDL   T2
          LDIL   T2
          SCN    37B
          LMDL   CHAN        CHANNEL NUMBER
          STIL   T2
          AODL   T1
          UJK    CHG10
          SPACE  5,20
** NAME-- CKC
*
** PURPOSE-- CHECK IF MAINTENANCE PP WANTS THE CHANNEL.
          SPACE  2
 CKC100   BSS
          STDL   PTF         ENABLE RUNNING PATH TEST
          RJM    PT          PATH TEST
 CKCX     LJM    **
 CKC      EQU    *-1
          LDN    C.CHCNT     NUMBER OF REQUESTS TO PROCESS BEFORE
          STML   CHLCNT       GIVING UP THE CHANNEL
          LOADC  CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          ADDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          CRDL   T1          READ CHANNEL LOCKWORD
          LDDL   T2
          LPN    1
          ZJK    CKCX        IF MAINTENANCE PP DOES NOT WANT THE CHANNEL
          LDDL   UNUML
          ZJK    CKCX        IF NO UNITS
          RJM    CUB         CHECK UNIT BUSY
          STDL   MALET       SETTING MALET NONZERO PREVENTS STARTING
                              NEW DISK REQUESTS
          NJN    CKCX        IF OUTSTANDING COMMANDS
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          PAUSE  130000      DELAY 130 MILLISECONDS TO ALLOW
                             MAINTENANCE PP TO GET THE CHANNEL
          RJM    SCLOCK      SET CHANNEL LOCK
          LDN    0
          STDL   UX
          UJN    CKC20
 CKC10    BSS
          LDN    P.UN
          RADL   UX          UPDATE TO NEXT UNIT TABLE
 CKC20    BSS
          SBDL   UNUML
          ZJK    CKC100      IF ALL UNIT RESERVED FLAGS CLEARED
          LDML   UNITS,UX
          LPC    0#07FF
          STML   UNITS,UX
          UJK    CKC10
 CHLCNT   CON    C.CHCNT     NUMBER OF REQUESTS TO PROCESS BEFORE
                              GIVING UP THE CHANNEL
          SPACE  5,20
** NAME-- CLOCK
*
** PURPOSE-- CLEAR LOCKWORD
*
*  ENTRY
*         T7 = POINTER RMA
*         T5 = OFFSET TO LOCKWORD FROM RMA
          SPACE  2
 CLKX     LJM    **
 CLOCK    EQU    *-1
 CLK14    BSS
          LCN    0
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        RMA OF TABLE
          ADDL   T5          ADD LOCKWORD OFFSET
          STDL   T6
          RDSL   T1          WRITE INTERMEDIATE VALUE
          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJN    CLK14       IF INTERMEDIATE VALUE
          LDDL   T4
          SBDL   PPNO
          ZJN    CLK30       IF THIS PP HAS THE LOCK SET
          LDDL   T6
          LMC    400000B
          CWDL   T1          RESTORE THE ORIGINAL CONTENTS
          RJM    HANG        HANG, THE LOCKWORD WAS WRONG
 CLK30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6
          LMC    400000B
          CWDL   T1          CLEAR THE LOCKWORD
          UJK    CLKX
          SPACE  5,20
** NAME-- COG
*
** PURPOSE-- CHECK OPERAND GENERATOR.  THE CRC VALUE GENERATED
*            AFTER A TEST MODE OPERATION IS READ AND COMPARED
*            WITH THE CORRECT VALUE.
*
** ENTRY  A = EXPECTED OPERAND GENERATOR
          SPACE  2
 COGX     LJM    **
 COG      EQU    *-1
          STDL   T3
          LDC    H0009
          RJM    FUNC        DROP MASTER OUT
          RJM    DCM         DROP SELECT OUT
          LDML   ETMF,CH
          STDL   T2          WRITE REGISTER FUNCTION
          LDN    0           DISABLE TEST MODE
          RJM    WR          WRITE REGISTER
          LDDL   T3
          ZJN    COGX        IF 25 MB CHANNEL AND DMA READ
          LDML   RORF,CH     READ OPERAND GENERATOR FUNCTION
          RJM    RDRG        READ REGISTER
          LMDL   T3
          ZJN    COGX        IF OPERAND GENERATOR IS CORRECT
          LDN    E18         DMA TEST MODE FAILURE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 .U       IFNE   UNIX,1
          SPACE  5,20
** NAME-- CPLOCK
*
** PURPOSE-- CLEARS THE PP QUEUE LOCK IN THE PP INTERFACE TABLE
          SPACE  2
 CPLX     LJM    **
 CPLOCK   EQU    *-1
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CPLX
 .U       ENDIF
          SPACE  5,20
** NAME-- CQLOCK
*
** PURPOSE-- CLEARS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
          SPACE  2
 CQLX     LJM    **
 CQLOCK   EQU    *-1
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.QLOCK OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CQLX
          SPACE  5,20
** NAME-- CRS
*
** PURPOSE-- CHECK FOR REQUEST SWITCH
*
** EXIT
*         A NOT EQUAL 0 IF MORE DATA TO TRANSFER
          SPACE  2
 CRSX     LJM    **
 CRS      EQU    *-1
          LDDL   T2          SET BY ROUTINES UBT AND WFTC
          NJN    CRS10       IF NO REQUEST SWITCH
          LDML   /SS/P.TOTAL,CSST TOTAL CM BYTES LEFT TO TRANSFER
          NJN    CRS5        IF NOT END OF TRANSFER
          LDML   /SS/P.TOTAL+1,CSST
          SBDL   BC          NUMBER OF CM BYTES TRANSFERRED THIS LOOP
          ZJK    CRS30       IF END OF TRANSFER
          MJN    CRS20       IF CM HAS CHANGED
 CRS5     BSS
          RJM    CSWIT       SWITCH TO NEXT REQUEST
 CRS10    BSS
          LDML   /SS/MT,CSST
          SHN    2
          PJN    CRS15       IF NOT USING MASTER TERMINATE
          LPN    77B
          NJN    CRS35       IF ALL DATA TRANSFERRED
          UJN    CRS25
 CRS15    BSS
          LDML   /SS/P.TOTAL+1,CSST DECREMENT CM BYTES LEFT TO TRANSFER
          SBDL   BC          NUMBER OF CM BYTES TRANSFERRED THIS LOOP
          STML   /SS/P.TOTAL+1,CSST
          PJN    CRS25       IF NOT NECESSARY TO ADJUST SECOND WORD
          ADC    200000B     ADD CARRY BIT
          STML   /SS/P.TOTAL+1,CSST
          SOML   /SS/P.TOTAL,CSST SUBTRACT CARRY BIT FROM FIRST WORD
          PJN    CRS25       IF MORE TO TRANSFER
 CRS20    BSS
          LDC    E505        CM HAS CHANGED
          RJM    INTERR      REPORT ERROR (NO RETURN)
 CRS25    BSS
          LDDL   STATUS
          LPN    0#30
          NJN    CRS35       IF DELAY
          LDDL   BBS
          ZJN    CRS35       IF TIME TO SUSPEND DATA TRANSFER
          UJK    CRSX        IF MORE TO TRANSFER
 CRS30    BSS
          STML   /SS/P.TOTAL+1,CSST ALL BYTES TRANSFERRED
 CRS35    BSS
          RJM    DCM         DESELECT THE CONTROL MODULE
          LDN    0
          LJM    CRSX
          SPACE  5,20
** NAME-- CSWIT
*
** PURPOSE-- SWITCH TO THE NEXT REQUEST
          SPACE  2
 CSWX     LJM    **
 CSWIT    EQU    *-1
          LDML   RQ+/RQ/P.NEXT,CSST PUT RMA OF NEXT REQUEST IN SS TABLE
          STML   /SS/P.REQ,CSST
          LDML   RQ+/RQ/P.NEXT+1,CSST
          STML   /SS/P.REQ+1,CSST
          LDML   RQ+/RQ/P.NEXTPV,CSST PUT PVA OF NEXT REQUEST IN SS TABLE
          STML   /SS/P.PVA,CSST
          LDML   RQ+/RQ/P.NEXTPV+1,CSST
          STML   /SS/P.PVA+1,CSST
          LDML   RQ+/RQ/P.NEXTPV+2,CSST
          STML   /SS/P.PVA+2,CSST
          LDML   RQ+/RQ/P.CYL,CSST
          STDL   T2          SAVE CYLINDER OF LAST REQUEST
          RJM    UREQ        READ NEXT REQUEST INTO RQ
          LDML   RQ+/RQ/P.CYL,CSST
          SBD    T2
          NJN    *           IF NOT SAME CYLINDER
          LDML   /SS/P.CURSEC,CSST CURRENT SECTOR - 1
          LMML   RQ+/RQ/P.SECTOR,CSST SECTOR OF NEXT REQUEST
          NJN    *           IF SECTOR NUMBER WRONG
          LDML   /SS/P.CURTRK,CSST CURRENT TRACK
          LMML   RQ+/RQ/P.TRACK,CSST TRACK ADDRESS OF NEXT REQUEST
          NJN    *           TRACK NUMBER WRONG
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
          AOML   /SS/P.NCR,CSST INCREMENT NUMBER OF COMPLETED REQUESTS
          UJK    CSWX
          SPACE  5,20
** NAME-- CT
*
** PURPOSE-- CONFIDENCE TEST.  RESERVE THE DRIVE, WRITE, READ, AND
*            VERIFY DATA ON A RESERVED CYLINDER.
*
** ENTRY
*         1)  AT INITIALIZATION AFTER PP LOADED
*         2)  DURING REQUEST RECOVERY WITH /SS/P.RECOV = 1
*         3)  WHEN PP RESUMED
          SPACE  2
 CTX      LJM    **
 CT       EQU    *-1
          LOADR  UNITS+/UN/P.UIT,UX ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T1
          LDDL   T1+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJK    MAIN15      IF UNIT DISABLED
 .U       IFEQ   UNIX,1
          RJM    PPRQ        CHECK FOR IDLE REQUEST
 .U       ENDIF
          LDN    0
          STML   /SS/P.CURTRK,CSST STARTING TRACK
          STML   /SS/P.CURSEC,CSST STARTING SECTOR
          RJM    SFT         SET FACILITY TIMEOUT
          RJM    CTDT        CONFIDENCE TEST DATA TRANSFER
          RJM    SFRR        CLEAR CIP AND TCIP
          LDN    1
          STML   /SS/P.CT,CSST INDICATE TEST COMPLETED SUCCESSFULLY
 CT45     LDML   /SS/P.RECOV,CSST
          LMN    1
          ZJN    CT50        IF CONFIDENCE TEST IS PART OF REQUEST RECOVERY
          LDN    0
          STML   /SS/P.RECOV,CSST
          STML   /SS/P.RQTRY,CSST CLEAR REQUEST RETRY COUNTER
 CT50     BSS
          UJK    CTX
          SPACE  5,20
** NAME-- CTDT
*
** PURPOSE-- CONFIDENCE TEST DATA TRANSFER
          SPACE  2
 CTDTX    LJM    **
 CTDT     EQU    *-1

* WRITE THE CYLINDER

          LCN    0
          STML   CTME,CSST   MAKE MEDIA ERROR TABLE LOOK EMPTY
          STML   CTME+1,CSST
          STML   CTME+2,CSST
          LDN    1
          STDL   FNC         INDICATE WRITE OPERATION
          RJM    BCTB        BUILD CONFIDENCE TEST BUFFER
 CTDT5    BSS                ENTRY IF MEDIA ERROR
          RJM    CBC         COMPUTE BYTE COUNT TO TRANSFER
          RJM    SCP         SETUP COMMAND PACKET PARAMETERS
          RJM    CPT         COMMAND PACKET TRANSFER
 CTDT7    EQU    *-1         FOR FORCING ERRORS
 CTDT10   BSS
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    CTDT100     IF NOT TRANSFER NOTIFICATION
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAOUT     DATA, INFORMATION OUT
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    BPS
          STDL   BC          BYTES PER SECTOR
          LDC    H0381       STREAM, WRITE
          RJM    FUNC
          LDC    H0D00       DMA WRITE
          RJM    FUNC
          ACN    DC
          LDC    SPT*MAXTR+SPT SECTORS PER CYLINDER
          SBML   STT,CSST    SECTORS TO TRANSFER
          SHN    3
          ADML   CM.CB.T+2
          STDL   RMA+1       LOWER RMA
          SHN    -16
          ADML   CM.CB.T+1
          STDL   RMA         UPPER RMA
          LDN    3
          OAM    BC,DC       BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
          RJM    WFTC        WAIT FOR TRANSFER COMPLETE
          ZJK    CTDT10      IF ERROR, STATUS WILL BE IN NEXT RESPONSE
          RJM    DCM         DESELECT THE CONTROL MODULE
          RJM    UDA         UPDATE DISK ADDRESS
          SOML   STT,CSST
          NJK    CTDT10      IF MORE SECTORS TO TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LPN    0#A
          ZJK    CTDT100     IF NOT SUCCESSFUL

* READ THE CYLINDER

 CTDT40   BSS
          LDN    0
          STML   /SS/P.CURTRK,CSST STARTING TRACK
          STML   /SS/P.CURSEC,CSST STARTING SECTOR
          STDL   FNC         INDICATE READ FUNCTION
 CTDT50   BSS                ENTRY IF MEDIA ERROR
          RJM    CBC         COMPUTE BYTE COUNT TO TRANSFER
          RJM    SCP         SETUP COMMAND PACKET PARAMETERS
          RJM    CPT         COMMAND PACKET TRANSFER
 CTDT60   BSS
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    CTDT100     IF NOT TRANSFER NOTIFICATION
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAIN      DATA, INFORMATION IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    BPS
          STML   CM.CB.T     BYTES PER SECTOR
          LDC    H0281       STREAM, READ
          RJM    FUNC
          LDC    H0C00       DMA READ
          RJM    FUNC
          ACN    DC
          LDN    3
          OAM    CM.CB.T,DC  BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
          RJM    WFTC        WAIT FOR TRANSFER TO COMPLETE
          ZJK    CTDT60      IF ERROR, STATUS WILL BE IN NEXT RESPONSE

* VERIFY THE DATA IN ONE SECTOR

          RJM    DCM         DESELECT THE CONTROL MODULE
          RJM    VCTD        VERIFY CONFIDENCE TEST DATA
          RJM    UDA         UPDATE DISK ADDRESS
          SOML   STT,CSST
          NJK    CTDT60      IF MORE SECTORS TO TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LPN    0#A
          NJK    CTDTX       IF SUCCESSFUL OR CONDITIONAL SUCCESS
 CTDT100  BSS
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- CTR
*
** PURPOSE-- CONFIDENCE TEST RECOVERY
*
** EXIT--  TO CALLING ROUTINE WITH
*             A = 0  IF ERROR LIMIT REACHED
*             A NOT 0  IF NOT MEDIA ERROR
*          TO CTDT ROUTINE IF MEDIA ERROR
          SPACE  2
 CTR100   BSS
          LMN    4           DATA INTEGRITY ERROR
 CTRX     LJM    **
 CTR      EQU    *-1
          LDML   /SS/P.CT,CSST
          NJN    CTR100      IF NOT IN CONFIDENCE TEST
          RJM    CFME        CHECK FOR MEDIA ERROR
          NJN    CTRX        IF NOT A MEDIA ERROR
          LDML   RPB+9,T3    HEAD, SECTOR
          STDL   T4
          LDDL   CSST
          STDL   T5          POINTER TO SS TABLE
          LDN    3
          STDL   T6          NUMBER OF MEDIA ERRORS ALLOWED
 CTR20    BSS
          LDML   CTME,T5
          SHN    2
          MJN    CTR30       IF TABLE ENTRY AVAILABLE
          SHN    -2
          LMDL   T4
          ZJN    CTR40       IF THIS SECTOR IN TABLE
          AODL   T5
          SODL   T6
          NJN    CTR20       IF MORE ENTRIES TO CHECK
          UJK    CTRX
 CTR30    BSS
          LDDL   T4
          STML   CTME,T5
 CTR40    BSS
          RJM    MCC         MASTER CLEAR CHANNEL
          LDDL   FNC
          ZJN    CTR50       IF READ
          LDDL   T4
          SHN    -8
          STML   /SS/P.CURTRK,CSST FAILING TRACK
          LDDL   T4
          LPN    77B
          STML   /SS/P.CURSEC,CSST FAILING SECTOR
 CTR50    BSS
          AOML   /SS/P.CURSEC,CSST UPDATE SECTOR NUMBER
          SBN    SPT         SECTORS PER TRACK
          MJN    CTR60       IF SAME TRACK
          STML   /SS/P.CURSEC,CSST
          AOML   /SS/P.CURTRK,CSST UPDATE TRACK NUMBER
          LMN    MAXTR+1
          NJN    CTR60       IF NOT LAST SECTOR ON CYLINDER
          LDDL   FNC
          NJK    CTDT40      IF WRITE
          LJM    CTDTX
 CTR60    BSS
          LDDL   FNC
          NJK    CTDT5       IF WRITE
          LJM    CTDT50      GO TO READ ENTRY POINT
          SPACE  5,20
** NAME-- CUB
*
** PURPOSE-- CHECK UNIT BUSY.  NOTE IF SLAVE RESET IS IN PROGRESS
*            CMNDS COULD BE 0, BUT ERROR RECOVERY IS STILL IN PROGRESS.
*
** EXIT  A = 0  IF NO COMMANDS IN PROGRESS
          SPACE  2
 CUB50    BSS
          LDN    1
 CUBX     LJM    **
 CUB      EQU    *-1
          LDN    0
          STDL   UX          POINTER TO UNITS TABLE
          UJN    CUB20
 CUB10    BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
 CUB20    BSS
          SBDL   UNUML
          ZJN    CUBX        IF END OF CONFIGURED UNITS
          LOADR  UNITS+/UN/P.UIT,UX ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T5
          LDDL   T5+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJN    CUB10       IF UNIT DISABLED
          LDML   UNITS,UX
          SHN    /UN/L.CIP+2
          MJN    CUB50       IF COMMAND IN PROGRESS
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LDML   /SS/P.RQTRY,CSST
          NJK    CUB50       IF IN ERROR RECOVERY FOR THIS UNIT
          UJK    CUB10
          SPACE  5,20
** NAME-- DARH
*
** PURPOSE-- DRIVE ASYNCHRONOUS RESPONSE HANDLER
          SPACE  2
 DARHX    LJM    **
 DARH     EQU    *-1
          LDDL   UX
          STDL   T8          SAVE UX
          LDN    0
          STDL   UX          INDEX TO UX TABLE
          UJN    DARH20
 DARH10   BSS
          LDN    P.UN
          RADL   UX          INDEX TO UX TABLE
 DARH20   BSS
          SBDL   UNUML
          ZJN    DARHX       IF DRIVE NOT FOUND
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LDML   /SS/P.UNIT,CSST
          LMML   RPB+SLAD
          NJN    DARH10      IF DIFFERENT DRIVE
          LDML   UNITS,UX
          LMML   UNITS,T8
          LPC    100B
          NJN    DARH10      IF DIFFERENT CHANNEL PORT
          LDK    ID26
          RJM    SFP         CHECK FOR MACHINE EXCEPTION
          MJN    DARH30      IF MACHINE EXCEPTION ID NOT FOUND
          LDML   RPB+6,T3
          LPC    0#FAF0
          LMC    0#6000
          ZJN    DARH40      IF NO ERROR
 DARH30   BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       IFEQ   UNIX,1
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 .U       ENDIF
 DARH40   BSS
          LDML   /SS/P.RESET,CSST
          ZJK    DARHX       IF RESET NOT ISSUED
          RJM    SFRR        SET UP FOR REQUEST RETRY
          UJK    DARHX
          SPACE  5,20
** NAME-- DCR
*
** PURPOSE-- DELETE COMPLETED REQUEST FROM THE UNIT QUEUE.
*
** INPUTS-- UNITS+/UN/P.UIT = POINTER TO UNIT INTERFACE TABLE
*
** OUTPUT-- P5, T8 ARE UNCHANGED
          SPACE  2
 DCRX     LJM    **
 DCR      EQU    *-1
          LDN    2
          STDL   P6
 DCR2     BSS
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    DCR2        IF LOCK COULD NOT BE SET
          LOADF  /SS/P.CURRQ,CSST RMA OF CURRENT REQUEST
          CRML   RQT,P6      READ RMA CHAIN OF CURRENT REQUEST

          LOADR  UNITS+/UN/P.UIT,UX  LOAD CM ADDRESS OF UNIT INT. TABLE
          STDL   T1
          CRDL   P1          READ QUEUE COUNT
          ERRNZ  /UIT/C.QCNT
          LDDL   P1+/UIT/P.QCNT  DECREMENT QUEUE COUNT
          SBML   /SS/P.NCOMRQ,CSST NUMBER OF COMPLETED REQUESTS
          STDL   P1+/UIT/P.QCNT
          MJN    DCR10       IF INVALID QUEUE COUNT
          LDDL   T1
          LMC    400000B
          CWDL   P1          WRITE QUEUE COUNT
 DCR10    BSS
          LOADR  /SS/P.DP,CSST DELINK POINTER
 DCR12    BSS
          STDL   P2
          ADN    1           POINT TO RMA INSTEAD OF PVA
          CRDL   T1          RMA OF A REQUEST
          LDDL   T3
          LMML   /SS/P.FCOMRQ,CSST
          NJN    DCR15       IF NEXT REQUEST IS NOT COMPLETED REQUEST
          LDDL   T4
          LMML   /SS/P.FCOMRQ+1,CSST
          ZJK    DCR30       IF THIS IS A COMPLETED REQUEST
 DCR15    BSS
          LOADF  T3          UPDATE DELINK POINTER TO NEXT
          STML   /SS/P.DP+2,CSST  REQUEST IN THE CHAIN
          LDDL   CMADR
          STML   /SS/P.DP,CSST
          ADDL   CMADR+1
          ADDL   CMADR+2
          ZJN    DCR20       IF END OF REQUEST QUEUE
          LDDL   CMADR+1
          STML   /SS/P.DP+1,CSST
          LDDL   CMADR+2
          LMC    400000B
          UJN    DCR12
 DCR20    BSS
          LDML   UNITS+/UN/P.UIT,UX INITIALIZE DELINK POINTER TO
          STML   /SS/P.DP,CSST       FIRST RMA
          LDML   UNITS+/UN/P.UIT+1,UX
          STML   /SS/P.DP+1,CSST
          LDML   UNITS+/UN/P.UIT+2,UX
          ADN    /UIT/C.NEXTPV
          STML   /SS/P.DP+2,CSST
          UJK    DCR10

* DELINK COMPLETED REQUESTS.

 DCR30    BSS
          LDDL   P2          CM ADDRESS OF REQUEST
          LMC    400000B
          CWML   RQT,P6      PVA AND RMA OF NEXT REQUEST IN CHAIN
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          LDML   /SS/P.FNC,CSST
          SBN    4
          NJN    DCR35      IF NOT FORMAT COMMAND
          SODL   CMNDS       CMNDS IS SET TO 2 FOR FORMAT
          LDML   UNITS,UX
          UJK    DCR37
 DCR35    LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          MJN    DCR44       IF 2 COMMANDS ISSUED TO CONTROLLER
          SHN    -/UN/L.TCIP-2
 DCR37    LPC    0#1FFF
          STML   UNITS,UX    CLEAR CIP AND DTIP
          LDML   RQT+/RQ/P.NEXT
          STML   /SS/P.REQ,CSST
          LDML   RQT+/RQ/P.NEXT+1
          STML   /SS/P.REQ+1,CSST POSSIBLE NEXT RMA
          ADML   /SS/P.REQ,CSST
          ZJN    DCR40       IF END OF QUEUE
          LDML   RQT+/RQ/P.NEXTPV
          STML   /SS/P.PVA,CSST
          LDML   RQT+/RQ/P.NEXTPV+1
          STML   /SS/P.PVA+1,CSST
          LDML   RQT+/RQ/P.NEXTPV+2
          STML   /SS/P.PVA+2,CSST
 DCR40    BSS
          LJM    DCR50
 DCR44    BSS
          LDML   UNITS,UX
          LPC    0#9FFF
          STML   UNITS,UX    CLEAR TCIP, DTIP

* MOVE (RMA, PVA, TOTAL BYTES) FOR SECOND COMMAND ISSUED TO THE
* TABLE FOR THE FIRST COMMAND

          LDML   /SS/P.RMA2,CSST
          STML   /SS/P.REQ,CSST
          LDML   /SS/P.RMA2+1,CSST
          STML   /SS/P.REQ+1,CSST MOVE RMA
          LDML   /SS/P.PVA2,CSST
          STML   /SS/P.PVA,CSST
          LDML   /SS/P.PVA2+1,CSST
          STML   /SS/P.PVA+1,CSST
          LDML   /SS/P.PVA2+2,CSST
          STML   /SS/P.PVA+2,CSST MOVE PVA
          LDML   /SS/P.TW2,CSST
          STML   /SS/P.TOTAL,CSST
          LDML   /SS/P.TW2+1,CSST
          STML   /SS/P.TOTAL+1,CSST MOVE TOTAL BYTES
          RJM    UREQ        READ UNIT REQUEST FROM CM
          RJM    SRESP       SET UP STATUS FOR RESPONSE BUFFER
          RJM    SETRQ       SET UP FOR FIRST REQUEST
          RJM    UNCMND      GET FIRST COMMAND
 DCR50    BSS
          SODL   CMNDS       OUTSTANDING COMMANDS
          LJM    DCRX
          SPACE  5,20
** NAME-- DPR
*
** PURPOSE-- DRIVE POWER ON RESET.  THIS MASTER CLEARS THE DRIVES,
*            BREAKS AN OPPOSITE ACCESS RESERVE AND RUNS DIAGNOSTICS.
*            IT IS ISSUED BY THE CM3 EVEN IF THE CM3 THINKS THE DRIVE
*            IS NOT OPERATIONAL.
          SPACE  2
 DPRX     LJM    **
 DPR      EQU    *-1
          LDC    H0800       ABORT COMMAND
          STML   CP+OPCD
          LDN    9           COMMAND PACKET LENGTH
          STML   CP
          LDC    0#254
          STML   CP+FCP
          LDC    0#400       RESET AS AT POWER ON
          STML   CP+FCP+1
          LDML   /SS/P.UNIT,CSST
          STML   CP+SLAD     CONTROLLER, UNIT NUMBER
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          NJK    DPR50       IF ERROR
*
*         IF THE UNIT IS NOT READY, THE DRIVE RESET COULD RESULT IN A
*         STATE CHANGE.  THE STATE CHANGE TOOK AS LONG AS 22 SECONDS
*         WITH REV 8A OF CM3 MICROCODE.  IF A CM3 IS POWERED ON AND A
*         DRIVE IS RESERVED TO ANOTHER CM3, THE CM3 THAT IS POWERED
*         ON WILL REPORT THAT THE DRIVE IS NOT OPERATIONAL AND NOT READY.
*
          LDML   /SS/P.RQ,CSST
          ZJK    DPRX        IF THERE SHOULD BE NO STATE CHANGE
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,UX  SAVE CLOCK IN TABLE
 DPR10    BSS
          RJM    RI          REQUEST INTERRUPT
          LDML   SELT,CMOD   MASK VALUE
          LPDL   STATUS      INTERRUPT STATUS
          NJN    DPR20       IF INTERRUPT PRESENT
          RJM    UC          UPDATE CLOCK
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    DPR15       IF CLOCK HAS NOT WRAPPED
          ADC    0#10000
 DPR15    BSS
          SBN    32          30 TO 32 SECOND TIMEOUT
          MJN    DPR10       IF TIMEOUT NOT EXPIRED
          LJM    DPRX
 DPR20    BSS
          RJM    SEL         SELECT THE CONTROLLER
          RJM    RPT         RESPONSE PACKET TRANSFER
          RJM    DCM         DESELECT THE CONTROL MODULE
          LDML   RPB+MAJST
          SHN    -4
          LPN    0#F
          LMN    AR
          NJN    DPR50       IF NOT ASYNCHRONOUS RESPONSE
          LDML   RPB+SLAD
          LPC    0#FF
          LMC    0#FF
          ZJN    DPR50       IF ASYNCHRONOUS RESPONSE FOR CONTROLLER
          RJM    DARH        DYNAMIC ASYNCHRONOUS RESPONSE HANDLER
          LDDL   T8
          STDL   UX          RESTORE UX
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LJM    DPRX
 DPR50    BSS
          LDN    E00         CPU MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- DUSC
*
** PURPOSE-- DISABLE USAGE STATISTICS COUNTING.  THIS IS SUPPOSE
*            TO SAVE 400 MICROSECONDS PER COMMAND. IT ALSO ELIMINATES
*            THE PROBLEM OF HANDLING STATISTIC COUNTER OVERFLOWS AND
*            HAVING TO CLEAR THE PERFORMANCE LOG.
*
*            ALSO ALLOW FAULT LOG REPORTING AND ALLOW MASTER TERMINATE
*            IF REVISION 8A OR LATER CM3 MICROCODE.
          SPACE  2
 DUSCX    LJM    **
 DUSC     EQU    *-1
          LDML   /SS/P.MREV,CSST
          SHN    -12
          STDL   T1          MICROCODE REVISION
          SBN    7
          MJN    DUSC10      IF MICROCODE REVISION BEFORE 7A
          ZJN    DUSC5       IF MICROCODE REVISION BEFORE 8A
          LDN    0#13
          UJN    DUSC20
 DUSC5    BSS
          LDN    0#B
          UJN    DUSC20
 DUSC10   BSS
          LDN    8
 DUSC20   BSS
          STML   CP          COMMAND PACKET LENGTH
          LDC    0#209
          STML   CP+OPCD     ATTRIBUTES COMMAND
          LDDL   CMOD
          LPN    7
          SHN    8
          LMC    0#FF
          STML   CP+SLAD     SLAVE ADDRESS
          LDC    0#1D1
          STML   CP+FCP      DISABLE COUNTING PARAMETER
          LDC    0#2D4
          STML   CP+FCP+1    DEVICE FAULT LOG REPORTING

*         ENABLING DEVICE FAULT LOG REPORTING BEFORE 8A MICROCODE CAUSED
*         WRITING TO THE WRONG CYLINDER IF THE DRIVE HAD A SLIPPED CYLINDER.

          LDDL   T1
          SBN    8
          MJN    DUSC30      IF MICROCODE REVISION BEFORE 8A
          LDC    0#100       ENABLE REPORTING
          UJN    DUSC40
 DUSC30   BSS
          LDN    0           DISABLE REPORTING
 DUSC40   BSS
          STML   CP+FCP+2
          STML   CP+FCP+4
          STML   CP+FCP+6
          LDC    0#2D2       ALLOW MASTER TERMINATE
          STML   CP+FCP+3
          LDC    0#2D3       SPEED UP MASTER TERMINATE
          STML   CP+FCP+5
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          ZJK    DUSCX       IF SUCCESSFUL
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- EFP
*
** PURPOSE-- ERROR FLAG PROCESSING
          SPACE  2
 EFP      CON    0
          LDC    H0800       DMA TERMINATE
          RJM    FAN
          LDC    H0600       READ DMA ERROR REGISTER
          RJM    RDRG
          SHN    9
          MJK    EFP60       IF IPI ERROR
          SHN    12
          MJK    EFP85       IF ILLEGAL FUNCTION
          SHN    1
          MJN    EFP5        IF UNCORRECTED CM ERROR
          SHN    1
          PJN    EFP10       IF NOT CM REJECT
 EFP5     BSS
          LDN    E09         CENTRAL MEMORY ERROR
          UJN    EFP40
 EFP10    BSS
          SHN    1
          PJN    EFP15       IF NOT INVALID CM RESPONSE CODE
          LDN    E10
          UJN    EFP40
 EFP15    BSS
          SHN    1
          PJN    EFP20       IF NOT CM RESPONSE CODE PARITY ERROR
          LDN    E11
          UJN    EFP40
 EFP20    BSS
          SHN    1
          PJN    EFP25       IF NOT CMI READ DATA PARITY ERROR
          LDN    E12
          UJN    EFP40
 EFP25    BSS
          SHN    5
          PJN    EFP35       IF NOT JY DATA ERROR
          LDN    E13
          UJN    EFP40
 EFP35    BSS
          SHN    1
          PJN    EFP45       IF NOT BAS PARITY ERROR
          LDN    E14
 EFP40    BSS
          UJN    EFP75
 EFP45    BSS
          SHN    1
          PJN    EFP50       IF NOT LZ ERROR
          LDN    E15
          UJN    EFP75
 EFP50    BSS
          SHN    1
          PJN    EFP55       IF NOT JY ERROR
          LDN    E16
          UJN    EFP75
 EFP55    BSS
          SHN    1
          PJK    EFP130      IF NOT LX ERROR
          LDN    E17
          UJN    EFP75
 EFP60    BSS
          LDC    H00F1       READ IPI ERROR REGISTER
          RJM    RDRG
          SHN    2
          PJN    EFP65       IF NOT BUFFER COUNTER PARITY
          LDN    E31
          UJN    EFP75
 EFP65    BSS
          SHN    2
          PJN    EFP70       IF NOT SYNC COUNTER PARITY
          LDN    E32
          UJN    EFP75
 EFP70    BSS
          SHN    1
          PJN    EFP80       IF NOT PERIOD COUNTER PARITY
          LDN    E03
 EFP75    BSS
          UJN    EFP120
 EFP80    BSS
          SHN    1
          MJN    EFP85       IF PARITY ERROR ON FUNCTION
          SHN    1
          PJN    EFP95       IF NOT PARITY ERROR ON FUNCTION
 EFP85    BSS
          LDN    E01         FUNCTION TIMEOUT
          UJN    EFP120
 EFP95    BSS
          SHN    3
          PJN    EFP100      IF NOT LOST DATA
          LDN    E33
          UJN    EFP150
 EFP100   BSS
          SHN    1
          PJN    EFP105      IF NOT UPPER ICI PARITY
          LDN    E04
          UJN    EFP150
 EFP105   BSS
          SHN    1
          PJN    EFP110      IF NOT LOWER ICI PARITY
          LDN    E05
          UJN    EFP150
 EFP110   BSS
          SHN    1
          PJN    EFP115      IF NOT IPI SEQUENCE ERROR
          LDN    E24
          UJN    EFP150
 EFP115   BSS
          SHN    1
          PJN    EFP125      IF NOT UPPER IPI CHANNEL PARITY
          LDN    E25
 EFP120   BSS
          UJN    EFP150
 EFP125   BSS
          SHN    1
          PJN    EFP130      IF NOT LOWER IPI CHANNEL PARITY
          LDN    E26
          UJN    EFP150
 EFP130   BSS
          LDN    E06         IOU ERROR
 EFP150   BSS
          STML   RS+/RS/P.ERRID
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- EP
*
** PURPOSE-- ERROR PROCESSING
          SPACE  2
 EP       CON    0
          LDML   /SS/P.RQTRY,CSST
          NJN    EP5         IF NOT FIRST ERROR FOR REQUEST
          STML   /SS/P.RECOV,CSST
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
 EP5      BSS
 .U       IFEQ   UNIX,1
          RJM    PPRQ        CHECK FOR IDLE REQUEST
 .U       ENDIF
          LDN    0
          STML   /SS/P.RQ,CSST  DO NOT WAIT FOR ASYNCH IN DPR
          LDML   RS+/RS/P.ERRID
          NJN    EP7         IF RESPONSE PACKET NOT APPLICABLE
          LDK    ID24
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    EP7         IF PARAMETER 24 NOT FOUND
          LDML   RPB+6,T3
          SHN    3
          PJN    EP7         IF DRIVE WAS READY
          AOML   /SS/P.RQ,CSST  FLAG SAYS WAIT FOR ASYNCH IN DPR
 EP7      BSS
          LDN    0
          STDL   TBC         DO NOT EXPECT 01 ENDING STATUS
          LDDL   TMF
          NJN    EP10        IF ERROR DURING TEST MODE
          LDML   RS+/RS/P.ERRID
          ZJK    EP25        IF PROBABLY NOT IOU ERROR
          SBN    E20
          PJK    EP25        IF PROBABLY NOT IOU ERROR
 EP10     BSS
          LDML   /SS/P.RQTRY,CSST
          SBN    11
          PJN    EP20        IF RETRY LIMIT REACHED
          AOML   /SS/P.RQTRY,CSST INCREMENT RETRY COUNT
          PAUSE  200000      MUST RETRY FOR 2 SECONDS BEFORE
                              DOWNING UNIT. THIS ALSO ALLOWS TIME
                              FOR THE CM3 TO WRITE ANY DATA IN ITS
                              BUFFER TO DISK
          LDDL   TMF
          NJN    EP15        IF ERROR DURING TEST MODE
          RJM    TAC         TERMINATE ALL COMMANDS
          RJM    RAR         RESTART ALL REQUESTS
 EP15     BSS
          LJM    MAIN10
 EP20     BSS
          LDK    /RS/K.CHDN  CHANNEL DOWN
          STML   RS+/RS/P.ID
 .U       IFEQ   UNIX,1
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       ENDIF
          RJM    OFFCH       TURN OFF ALL UNITS ON CHANNEL
 .U       IFEQ   UNIX,1
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 .U       ELSE
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       ENDIF
          LJM    MAIN15
 EP25     BSS
          LDML   /SS/P.RECOV,CSST INDEX TO ERROR PROCESSING PROCEDURE
          STDL   T1
          LDML   EPT,T1
          STML   EP30
          LJM    **          EXECUTE NEXT STEP IN RECOVERY PROCEDURE
 EP30     EQU    *-1

 EPT      BSS    0
          CON    EPA         RETRY THE REQUEST
          CON    EPB         CONFIDENCE TEST
          CON    EPC         SLAVE RESET
          CON    EPD         PATH TEST
          CON    EPE         DRIVE DIAGNOSTICS
          CON    EPF         IF FINAL REQUEST RETRY FAILED
          CON    EPG         IF LOGICAL RESET FAILS AFTER FINAL RETRY
          CON    EPD50       REQUEST RETRY ERROR AFTER SLAVE RESET
          CON    EPC70       AFTER READ PERFORMANCE LOG
          SPACE  5,20
*
* REQUEST RETRY
*
 EPA      BSS
          LDML   /SS/P.RQTRY,CSST REQEST RETRY COUNTER
          ZJN    EPA10       IF INTERMEDIATE RESPONSE ALREADY REPORTED
          LDML   /SS/P.FNC,CSST
          SBN    4
          NJN    EPA05       IF NOT FORMAT COMMAND
          LDML   /SS/P.RQTRY,CSST REQUEST RETRY COUNTER
          SBN    RRL
          NJN    EPA05       CONTINUE WITH ERROR RECOVERY
          LJM    EPF10       SEND ABNORMAL RESPONSE
 EPA05    LDML   /SS/P.RQTRY,CSST REQEST RETRY COUNTER
          SBN    RRL+1
          PJN    EPB         IF FAILURE DURING LOGICAL RESET
          RJM    INTRS       REPORT INTERMEDIATE RESPONSE
 EPA10    BSS
          RJM    CTR         CONFIDENCE TEST RECOVERY
          NJN    EPA30       IF ERROR LIMIT NOT REACHED
          AOML   /SS/P.RQTRY,CSST REQUEST RETRY COUNTER
          UJK    EPC
 EPA30    BSS
          AOML   /SS/P.RQTRY,CSST REQUEST RETRY COUNTER
          RJM    LIR         LOGICAL INTERFACE RESET
          RJM    RCC         SETUP FOR RESTART CONTROLLER COMMANDS
          LDML   /SS/P.RQTRY,CSST
          SBN    RRL+1
          MJN    EPB10       IF NOT RETRY LIMIT
          SPACE  5,20
*
* CONFIDENCE TEST
*
 EPB      BSS
          LDML   /SS/P.FNC,CSST
          SBN    4
          ZJK    EPF10       IF FORMAT COMMAND, SEND ABNORMAL RESPONSE
          LDML   /SS/P.CT,CSST
          ZJN    EPC         IF IN INITIALIZATION CONFIDENCE TEST
          LDML   /SS/P.RECOV,CSST
          LMN    1
          ZJN    EPB20       IF CONFIDENCE TEST ALREADY STARTED
          AOML   /SS/P.RECOV,CSST INDEX TO NEXT RECOVERY STEP
          RJM    RCC         RESTART CONTROLLER COMMANDS
          LDN    0
          STML   /SS/P.CT,CSST ENABLE STARTING CONFIDENCE TEST
 EPB10    BSS
          LJM    MAIN10
 EPB20    BSS
          LDML   /SS/P.CT,CSST
          NJN    EPC         IF CONFIDENCE TEST COMPLETE
          RJM    CTR         CONFIDENCE TEST RECOVERY
          SPACE  5,20
*
* SLAVE RESET
*
 EPC      BSS
          LDML   RS+/RS/P.ERRID
          SBN    E20
          ZJN    EPC2        IF -CAN'T SELECT CONTROLLER- ERROR
          SBN    E38-E20
          NJN    EPC5        IF NOT -NO CONTROLLER RESPONSE-
 EPC2     BSS
          LDML   UNITS,UX    IF CONTROLLER HUNG, READ PERFORMANCE
          LPC    0#EFFF       LOG AFTER SLAVE RESET
          LMC    /UN/K.NCR   NO CONTROLLER RESPONSE BIT
          STML   UNITS,UX
 EPC5     BSS
          LDML   /SS/P.RECOV,CSST
          ZJN    EPC15       IF INITIALIZATION CONFIDENCE TEST
          SBN    2
          ZJK    EPC50       IF SLAVE RESET ALREADY ISSUED
          LDML   /SS/P.CT,CSST
          LMN    1
          NJN    EPC8        IF CONFIDENCE TEST FAILED
 .U       IFNE   UNIX,1
          RJM    CFME        CHECK FOR MEDIA ERROR
          NJN    EPC10       IF NOT A MEDIA ERROR
 .U       ENDIF
 .E       IFEQ   ERRD,1      READ RAW DATA
          RJM    RRD         READ RAW DATA
 .E       ENDIF
          LDK    /RS/K.DATERR SOFTWARE FLAW THE ALLOCATION UNIT
          STML   RS+/RS/P.DATERR
          LDN    E62         MEDIA ERROR
          STML   RS+/RS/P.ERRID
          LJM    EPF
 EPC8     BSS
          LMN    1
          NJN    EPC10       IF CONFIDENCE TEST COMPLETE
          RJM    SFRR       CLEAR CIP, IF
          LDN    2
          STML   /SS/P.CT,CSST INDICATE CONFIDENCE TEST FAILED
 EPC10    BSS
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
 EPC15    BSS
          LDN    2
          STML   /SS/P.RECOV,CSST INDEX TO NEXT STEP OF RECOVERY
          LDN    E50         SLAVE RESET STARTED
          STML   RS+/RS/P.ERRID
          RJM    INTRS       INTERMEDIATE RESPONSE
          LDDL   PTF         PATH TEST FLAG
          ZJN    EPC20       IF INITIALIZATION PATH TEST
          RJM    RCC         SETUP FOR RESTART CONTROLLER COMMANDS
          LDC    0#C000      COMMAND IN PROG., 2 COMMANDS IN PROG.
          RJM    SCB         SET COMMAND IN PROGRESS BITS
 EPC20    BSS
          RJM    SRI         SET RESET ISSUED FLAG
          RJM    ISR         ISSUE SLAVE RESET (NO RETURN)
 EPC50    BSS
          LDML   UNITS,UX
          LPC    /UN/K.NCR
          STDL   T5          SAVE NO CONTROLLER RESPONSE FLAG
          LDML   UNITS,UX
          LPC    0#EFFF
          STML   UNITS,UX    CLEAR -NO CONTROLLER RESPONSE- BIT
          LDML   RS+/RS/P.ERRID
          LMC    E72
          NJK    EPC100      IF NOT MACHINE EXCEPTION
          LDN    ID16
          RJM    SFP         SEARCH FOR PARAMETER
          LDML   RPB+6,T3
          LPC    0#FEE0
          LMC    0#6000
          NJK    EPC100      IF SLAVE RESET FAILED
          LDN    2
          STML   /SS/P.RESET,CSST INDICATE ASYNCH FOR SLAVE RECEIVED

*         WITH MICROCODE 9A OR LATER A LOGICAL RESET IMMEDIATELY AFTER
*         SLAVE RESET FAILS.  A DELAY SHOULD PREVENT THIS FAILURE.

          LDC    1000
          STDL   T6          PAUSE 5 SECONDS
 EPC60    BSS
          PAUSE  5000
          RJM    PPRQ        CHECK FOR IDLE REQUEST
          SODL   T6
          NJN    EPC60       IF PAUSE NOT COMPLETE
          LDDL   T5
          ZJN    EPC70       IF CONTROLLER WAS NOT HUNG
          LDN    8           GO TO EPC70 IF ERROR
          STML   /SS/P.RECOV,CSST
          RJM    REL         READ ERROR LOG
          LDK    E52         SLAVE RESET PASSED, ERROR CODE PRESENT
          UJN    EPC80
 EPC70    BSS
          LDN    E51         SLAVE RESET PASSED
 EPC80    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    INTRS       INTERMEDIATE RESPONSE
          LDML   /SS/P.CT,CSST
          LMN    4
          ZJK    EPE40       IF DATA INTEGRITY PROBLEM
          LDN    7           INDEX TO NEXT STEP OF RECOVERY (EPD50)
          STML   /SS/P.RECOV,CSST
          RJM    DUSC        DISABLE USAGE STATISTIC COUNTING
          AOML   /SS/P.RQTRY,CSST REQUEST RETRY COUNT
          LJM    MAIN10
 EPC100   BSS
          LDDL   PTF
          ZJN    EPC110      IF IN PATH TEST
          LDML   RS+/RS/P.ERRID
          SBN    E20
          MJN    EPC110      IF PROBABLY NOT A CABLE PROBLEM
          SBN    E50-E20
          PJN    EPC110      IF PROBABLY NOT A CABLE PROBLEM
          RJM    INTRS       INTERMEDIATE RESPONSE
          UJN    EPD
 EPC110   BSS
          RJM    OFFCM       TURN OFF ALL UNITS ON CM3 (NO RETURN)

 EPCT     BSS    16          UX FOR RESET CONTROLLER
          SPACE  5,20
*
* PATH TEST (ROUTINE PT WORKED ONCE, SLAVE RESET FAILED, MAY BE DAISY
*            CHAIN PROBLEM.)
 EPD      BSS
          LDDL   PTF
          NJN    EPD10       IF NOT IN INITIALIZATION CONFIDENCE TEST
          RJM    CTR         CONFIDENCE TEST RECOVERY
          LDN    2
          STML   /SS/P.CT,CSST INDICATE CONFIDENCE TEST FAILED
          UJK    EPC110
 EPD10    BSS
          LDML   /SS/P.RECOV,CSST
          LMN    3
          ZJN    EPD55       IF PATH TEST ALREADY STARTED
          AOML   /SS/P.RQTRY,CSST REQUEST RETRY COUNT
          LDN    3
          STML   /SS/P.RECOV,CSST INDEX TO NEXT RECOVERY STEP
          RJM    RAR         SETUP FOR RESTARTING ALL REQUESTS
          LDN    0
          STDL   PTF         FORCE RUNNING PATH TEST
          LJM    MAIN10
 EPD50    BSS                ENTER HERE IF ERROR AFTER SLAVE RESET
          LDDL   PTF
          NJN    EPD60       IF PATH TEST SUCCESSFUL
 EPD55    BSS
          RJM    OFFCM       TURN OFF ALL UNITS ON CM3 (NO RETURN)
 EPD60    BSS
          RJM    INTRS       INTERMEDIATE RESPONSE
          SPACE  5,20
*
* DRIVE DIAGNOSTICS
*
 EPE      BSS
          LDML   /SS/P.RECOV,CSST
          LMN    4
          ZJN    EPE50       IF DIAGNOSTIC COMMAND ALREADY ISSUED
          LDN    4           INDEX TO THIS RECOVERY PROCEDURE
          STML   /SS/P.RECOV,CSST
          AOML   /SS/P.RQTRY,CSST REQUEST RETRY COUNT
          RJM    RCC         SETUP FOR RESTART CONTROLLER COMMAND
          RJM    LIR         LOGICAL INTERFACE RESET
          RJM    PDD         PERFORM DRIVE DIAGNOSTICS
          LDML   /SS/P.CT,CSST
          LMN    4
          ZJN    EPE40       IF DATA INTEGRITY ERROR
          LDN    5
          STML   /SS/P.RECOV,CSST INDEX TO RECOVERY PROCEDURE (EPF)
          LJM    MAIN10
 EPE40    BSS
          LDK    E111        CM-DRIVE DATA INTEGRITY
          STML   RS+/RS/P.ERRID RESET ERROR IDENTIFIER
 EPE50    BSS
          UJN    EPF5
          SPACE  5,20
*
* IF FINAL REQUEST RETRY FAILED
*
 EPF      BSS
          LDML   /SS/P.CT,CSST
          LMN    1
          ZJN    EPF10       IF CONFIDENCE TEST PASSED
 EPF5     BSS
          LDK    /RS/K.UDN   UNIT DOWN
          STML   RS+/RS/P.ID
 .U       IFEQ   UNIX,1
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       ENDIF
          RJM    OFFUN       TURN OFF UNIT
 .U       IFNE   UNIX,1
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       ENDIF
          UJN    EPF20
 EPF10    BSS
          LDC    R.ABN*0#4000 ABNORMAL TERMINATION
          STML   RS+/RS/P.RC RESPONSE CODE
 .U       IFEQ   UNIX,1
          LDN    0
          STML   RS+/RS/P.SHORT   INDICATE ERROR RESPONSE
 .U       ENDIF
          LDC    RLIE
          STML   RS+/RS/P.RESPL BYTE LENGTH OF RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    DCR         DELINK REQUEST
 .U       IFEQ   UNIX,1
 EPF20    BSS
 .U       ENDIF
          RJM    RESPIN      UPDATE -IN- POINTER IN RESPONSE BUFFER
 .U       IFNE   UNIX,1
 EPF20    BSS
 .U       ENDIF
          LDN    6
          STML   /SS/P.RECOV,CSST INDEX TO NEXT RECOVERY STEP
          RJM    LIR         LOGICAL INTERFACE RESET
          SPACE  5,20
*
* ENTER HERE IF PREVIOUS LOGICAL INTERFACE RESET WORKS OR FAILS
*
 EPG      BSS
          RJM    RCC         SETUP FOR RESTART CONTROLLER COMMANDS
          LDN    0
          STDL   IF          CLEAR INITIALIZATION FLAG
          STML   /SS/P.RQTRY,CSST CLEAR RETRY COUNT
          LDML   /SS/P.FNC,CSST
          SBN    4
          NJN    EPG10       IF NOT FORMAT COMMAND
          STML   FIP         CLEAR FORMAT IN PROGRESS FLAG
 EPG10    LJM    MAIN10
 .F       IFEQ   FE,1        FORCE ERROR CODE
          SPACE  5,20
** NAME-- FER
*
** PURPOSE-- FORCE ERROR ROUTINE.  THE ERROR CAN BE FORCED BY CHANGING
*            CENTRAL MEMORY WORD 8.  SOME ROUTINES REQUIRE THE UNIT
*            NUMBER TO BE IN CENTRAL MEMORY WORD 9.
          SPACE  2
 FERX     LJM    **
 FER      EQU    *-1
          LDN    8
          CRDL   P2          READ LOCATION WITH ERROR ROUTINE
          LDDL   P2
          ZJN    FERX        IF NOT FORCING AN ERROR
          STDL   FEST
          LPN    77B
          STDL   P6          INDEX TO TABLE
          SBN    FETND-FET
          PJN    FERX        IF UNDEFINED VALUE
          LDN    0
          STDL   P2
          LDN    8
          CWDL   P2          INDICATE ERROR BEING FORCED
          LDDL   FEST
          SHN    -8
          STDL   FEST        FORCE ERROR START COUNT
          LDDL   P3
          STDL   FEND        FORCE ERROR END COUNT OR UNIT NUMBER
          LDN    9
          CRDL   P2          READ WORD WITH UNIT NUMBER
          LDDL   P2
          STDL   FEUN        UNIT TO FORCE ERROR ON
          LDML   FET,P6
          STDL   P2
          LJM    0,P2        JUMP TO FORCE ERROR ROUTINE
* TABLE OF ERRORS TO FORCE
 FET      BSS
          CON    FERX        NO ERROR
          CON    FERA        LOWER ICI PARITY ERROR ON READ
          CON    FERB        DROP SELECT DURING READ
          CON    FERC        LOWER ICI PARITY ERROR ON WRITE
          CON    FERD        DROP SELECT DURING WRITE
          CON    FERE        READ ONE TOO MANY WORDS (RECOVERABLE)
          CON    FERF        READ ONE TOO FEW WORDS (RECOVERABLE)
          CON    FERG        WRITE ONE TOO MANY WORDS (RECOVERABLE)
          CON    FERH        WRITE ONE TOO FEW WORDS (UNRECOVERABLE)
          CON    FERI        READ DATA IPI P.E. (RECOVERABLE)
          CON    FERJ        WRITE DATA IPI P.E. (RECOVERABLE)
          CON    FERK        SPIN DOWN UNIT
          CON    MAIN5       INITIALIZE, RUN PATH, CONF. TEST
          CON    FERM        ILLEGAL CYLINDER FOR READ OR WRITE
          CON    FERN        LOWER ICI PARITY ERROR IN PATH TEST
          CON    FERO        UNABLE TO SELECT ERROR IN PATH TEST
          CON    FERP        ILLEGAL COUNT ERROR IN PATH TEST
          CON    FERQ        LOWER ICI PARITY ERROR IN CONFIDENCE TEST
          CON    FERR        UNABLE TO SELECT ERROR IN CONFIDENCE TEST
          CON    FERS        ILLEGAL CYLINDER ERROR IN CONFIDENCE TEST
          CON    FERT        CHANGE ONE MEMORY LOCATION
          CON    FERU        PARITY ERROR ON READ
          CON    FERV        BYTE COUNT EQUAL ZERO ON READ
          CON    FERW        PARITY ERROR ON WRITE
          CON    FERY        BYTE COUNT EQUAL ZERO ON WRITE
          CON    FERZ        TEST MODE READ 1 TOO MANY WORDS
 FETND    BSS
          SPACE  5,20
** NAME-- FERA
*
** PURPOSE-- FORCE LOWER ICI PARITY ERROR ON READ
*            8 = XX01 YYYY
*            9 = CCDD
*                X = BURSTS TO READ BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*                CC = CM3 NUMBER
*                DD = DRIVE NUMBER
          SPACE  2
 FERA     BSS
          LDC    FERA10
          UJN    FERB5
 FERA10   CON    0
          STDL   T3          SAVE FUNCTION
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJK    FERB25      IF WRONG DRIVE
          SODL   FEST
          PJN    FERB25      IF NOT TIME TO FORCE ERROR
          LDC    H0C22       FORCE LOWER ICI PARITY ERROR
          RJM    FUNC        SEND THE FUNCTION
          UJN    FERB15
          SPACE  5,20
** NAME--FERB
*
** PURPOSE-- DROP SELECT DURING READ
*            8 = XX02 YYYY
*            9 = CCDD
*                X = BURSTS TO READ BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*                CC = CM3 NUMBER
*                DD = DRIVE NUMBER
          SPACE  2
 FERB     BSS
          LDC    FERB10
 FERB5    BSS
          STML   READ34
          LJM    MAIN10
 FERB10   CON    0
          STDL   T3          SAVE FUNCTION
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJN    FERB25      IF WRONG DRIVE
          SODL   FEST
          PJN    FERB25      IF NOT TIME TO FORCE ERROR
          RJM    MR          MASTER RESET
 FERB15   BSS
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERB25      IF NOT TIME TO RESTORE INSTRUCTION
 FERB20   BSS
          LDC    FUNC
          STML   READ34      RESTORE FUNCTION
 FERB25   BSS
          LDDL   T3
          RJM    FUNC        SEND FUNCTION
          LJM    READ34+1    RETURN TO READ ROUTINE
          SPACE  5,20
** NAME-- FERC
*
** PURPOSE-- FORCE LOWER ICI PARITY ERROR ON WRITE
*            8 = XX03 YYYY
*            9 = CCDD
*                X = BURSTS TO WRITE BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*                CC = CM3 NUMBER
*                DD = DRIVE NUMBER
          SPACE  2
 FERC     BSS
          LDC    FERC10
          UJN    FERD5
 FERC10   CON    0
          STDL   T3
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJK    FERD25      IF WRONG DRIVE
          SODL   FEST
          PJN    FERD25      IF NOT TIME TO FORCE ERROR
          LDC    H0C22       FORCE LOWER ICI PARITY ERROR
          RJM    FUNC        SEND THE FUNCTION
          UJN    FERD15
          SPACE  5,20
** NAME-- FERD
*
** PURPOSE-- DROP SELECT DURING WRITE
*            8 = XX04 YYYY
*            9 = CCDD
*                X = BURSTS TO WRITE BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*                CC = CM3 NUMBER
*                DD = DRIVE NUMBER
          SPACE  2
 FERD     BSS
          LDC    FERD10
 FERD5    BSS
          STML   WRI34
          LJM    MAIN10
 FERD10   CON    0
          STDL   T3          SAVE FUNCTION
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJN    FERD25      IF WRONG DRIVE
          SODL   FEST        FORCE ERROR START COUNT
          PJN    FERD25      IF NOT TIME TO FORCE ERROR
          RJM    MR          MASTER RESET
 FERD15   BSS
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERD25      IF NOT TIME TO RESTORE INSTRUCTION
 FERD20   BSS
          LDC    FUNC
          STML   WRI34       RESTORE THE INSTRUCTION
 FERD25   BSS
          LDDL   T3
          RJM    FUNC        SEND FUNCTION
          LJM    WRI34+1     RETURN TO WRITE ROUTINE
          SPACE  5,20
** NAME-- FERE
*
** PURPOSE-- READ ONE TOO MANY WORDS
*            8 = 0005
          SPACE  2
 FERE     BSS
          LDC    FERE15
          STML   READ40
          LDC    FERE10
          UJN    FERF5
 FERE10   CON    0
          AODL   BC          INCREMENT BY ONE BYTE
          AODL   BC
          UJN    FERF15
 FERE15   CON    0
          STDL   T3          SAVE WORDS NOT TRANSFERRED
          SODL   BC          RESTORE BYTE COUNT
          SODL   BC
          UJN    FERF25
          SPACE  5,20
** NAME-- FERF
*
** PURPOSE-- READ ONE TOO FEW WORDS
*            8 = 0006
          SPACE  2
 FERF     BSS
          LDC    FERF20
          STML   READ40
          LDC    FERF10
 FERF5    BSS
          STML   READ32
          LJM    MAIN10
 FERF10   CON    0
          SODL   BC          DECREMENT BY ONE BYTE
          SODL   BC
 FERF15   BSS
          LDC    BCS         RESTORE INSTRUCTION
          STML   READ32
          LJM    READ32-2
 FERF20   CON    0
          STDL   T3          SAVE WORDS NOT TRANSFERRED
          AODL   BC          RESTORE BYTE COUNT
          AODL   BC
 FERF25   BSS
          LDC    DCN         RESTORE INSTRUCTION
          STML   READ40
          LDDL   T3
          LJM    READ40-1
          SPACE  5,20
** NAME-- FERG
*
** PURPOSE-- WRITE ONE TOO MANY WORDS
*            8 = 0007
          SPACE  2
 FERG     BSS
          LDC    FERG15
          STML   WRI40
          LDC    FERG10
          UJN    FERH5
 FERG10   CON    0
          LDN    2
          RADL   BC
          UJN    FERH15
 FERG15   CON    0
          STDL   T3          SAVE WORDS NOT TRANSFERRED
          LCN    2
          RADL   BC
          UJN    FERH25
          SPACE  5,20
** NAME-- FERH
*
** PURPOSE-- WRITE ONE TOO FEW WORDS
*            8 = 0008
          SPACE  2
 FERH     BSS
          LDC    FERH20
          STML   WRI40
          LDC    FERH10
 FERH5    BSS
          STML   WRI32
          LJM    MAIN10
 FERH10   CON    0
          SODL   BC          DECREMENT BY ONE BYTE
          SODL   BC
 FERH15   BSS
          LDC    BCS
          STML   WRI32       RESTORE INSTRUCTION
          LJM    WRI32-2
 FERH20   CON    0
          STDL   T3          SAVE WORDS NOT TRANSFERRED
          AODL   BC          RESTORE BYTE COUNT
          AODL   BC
 FERH25   BSS
          LDC    DCN         RESTORE INSTRUCTION
          STML   WRI40
          LDDL   T3
          LJM    WRI40-1
          SPACE  5,20
** NAME-- FERI
*
** PURPOSE-- FORCE IPI PARITY ERROR ON INPUT DURING READ
*            8 = 0009
          SPACE  2
 FERI     BSS
          LDC    FERI10
          LJM    FERB5
 FERI10   CON    0
          STDL   T3          SAVE FUNCTION
          LDC    H0322
          RJM    FUNC        FORCE BUS A INPUT PARITY ERROR
          LJM    FERB20
          SPACE  5,20
** NAME-- FERJ
*
** PURPOSE-- FORCE IPI PARITY ERROR ON OUTPUT DURING WRITE
*            8 = 000A
          SPACE  2
 FERJ     BSS
          LDC    FERJ10
          LJM    FERD5
 FERJ10   CON    0
          STDL   T3          SAVE FUNCTION CODE
          LDC    H0122
          RJM    FUNC        FORCE BUS A OUTPUT PARITY ERROR
          LJM    FERD20
          SPACE  5,20
** NAME-- FERK
*
** PURPOSE-- SPIN DOWN UNIT TO FORCE NOT READY ERROR
*            8 = 000B CCDD
*                C = CONTROLLER NUMBER
*                D = DRIVE NUMBER
*         THIS SHOULD ONLY BE USED WHEN THERE ARE NO OUTSTANDING
*         COMMANDS TO THE CM3.
          SPACE  2
 FERK     BSS
          LDN    0#A
          STML   CP          PACKET LENGTH
          STML   CP+CRN      COMMAND REFERENCE NUMBER
          LDC    H0700       SET OPERATING MODE COMMAND
          STML   CP+OPCD     OPERATION
          LDDL   FEND
          STML   CP+SLAD     CONTROLLER, UNIT NUMBER
          STML   RPB+SLAD
          SHN    -8
          STDL   CMOD        CONTROLLER NUMBER
          LDC    0#351       DISC MODES
          STML   CP+FCP
          LDC    0#4000
          STML   CP+FCP+1    SPIN DOWN UNIT
          RJM    DARH        THIS FINDS UX AND CSST
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          ZJK    MAIN10      IF SUCCESSFUL
          LDN    E00
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSOR (NO RETURN)
          SPACE  5,20
** NAME-- FERM
*
** PURPOSE-- CHANGE CYLINDER NUMBER TO ILLEGAL VALUE
*            TO FORCE AN ERROR ON WRITE OR READ
*            8 = XX0D YYYY
*            9 = CCDD
*                X = COMMANDS TO SEND BEFORE FORCING FIRST ERROR
*                Y + 1 = TIMES TO FORCE THE ERROR
*                CC = CM3 NUMBER
*                DD = DRIVE NUMBER
          SPACE  2
 FERM     BSS
          LDC    FERM10
          STML   SEEK20
          LJM    MAIN10
 FERM10   CON
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJN    FERM20      IF WRONG DRIVE
          SODL   FEST
          PJN    FERM20      IF NOT TIME TO FORCE ERROR
          LCN    0
          STML   CP+FCP+3    ILLEGAL CYLINDER NUMBER
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERM20      IF NOT TIME TO RESTORE INSTRUCTION
          LDC    CPT
          STML   SEEK20      RESTORE INSTRUCTION
 FERM20   BSS
          RJM    CPT         COMMAND PACKET TRANSFER
          LJM    SEEK20+1    RETURN TO SEEK ROUTINE
          SPACE  5,20
** NAME-- FERN
*
** PURPOSE-- FORCE LOWER ICI PARITY ERROR IN PATH TEST
*            8 = XX0E YYYY
*                X = TIMES TO RUN PATH TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERN     BSS
          LDC    FERN10
          UJN    FERP5
 FERN10   CON    0
          SODL   FEST
          PJN    FERP20      IF NOT TIME TO FORCE ERROR
          LDC    H0C22       FORCE LOWER ICI PARITY ERROR
          RJM    FUNC        SEND THE FUNCTION
          UJN    FERP30
          SPACE  5,20
** NAME-- FERO
*
** PURPOSE-- DISABLE THE CONTROLLERS RECEIVERS TO PREVENT SELECTING
*            DURING THE PATH TEST
*            8 = XX0F YYYY
*                X = TIMES TO RUN PATH TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERO     BSS
          LDC    FERO10
          UJN    FERP5
 FERO10   CON    0
          SODL   FEST
          PJN    FERP20      IF NOT TIME TO FORCE ERROR
          RJM    MR          MASTER RESET
          UJN    FERP30
          SPACE  5,20
** NAME--FERP
*
** PURPOSE-- FORCE COMMAND EXCEPTION DURING THE PATH TEST
*            BY SENDING AN ILLEGAL BYTE COUNT
*            8 = XX10 YYYY
*                X = TIMES TO RUN PATH TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERP     BSS
          LDC    FERP10
 FERP5    BSS
          STML   PT40
          LJM    MAIN10
 FERP10   CON    0
          SODL   FEST
 FERP20   BSS
          PJN    FERP40      IF NOT TIME TO FORCE ERROR
          LCN    0
          STML   CP+FCP+1    ILLEGAL COUNT
 FERP30   BSS
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERP40      IF NOT TIME TO RESTORE INSTRUCTION
          LDC    CPT
          STML   PT40        RESTORE INSTRUCTION
 FERP40   BSS
          RJM    CPT         COMMAND PACKET TRANSFER
          LJM    PT40+1      RETURN TO PATH TEST
          SPACE  5,20
** NAME-- FERQ
*
** PURPOSE-- FORCE LOWER ICI PARITY ERROR IN CONFIDENCE TEST
*            8 = XX11 YYYY
*                X = TIMES TO RUN CONFIDENCE TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERQ     BSS
          LDC    FERQ10
          UJN    FERS5
 FERQ10   CON    0
          SODL   FEST
          PJN    FERS20      IF NOT TIME TO FORCE ERROR
          LDC    H0C22       FORCE LOWER ICI PARITY ERROR
          RJM    FUNC        SEND THE FUNCTION
          UJN    FERS30
          SPACE  5,20
** NAME-- FERR
*
** PURPOSE-- DISABLE THE CONTROLLERS RECEIVERS TO PREVENT SELECTING
*            DURING THE CONFIDENCE TEST
*            8 = XX12 YYYY
*                X = TIMES TO RUN CONFIDENCE TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERR     BSS
          LDC    FERR10
          UJN    FERS5
 FERR10   CON    0
          SODL   FEST
          PJN    FERS20      IF NOT TIME TO FORCE ERROR
          RJM    MR          MASTER RESET
          UJN    FERS30
          SPACE  5,20
** NAME--FERS
*
** PURPOSE-- FORCE COMMAND EXCEPTION DURING THE CONFIDENCE TEST
*            BY SENDING AN ILLEGAL CYLINDER NUMBER
*            8 = XX13 YYYY
*              X = TIMES TO RUN CONFIDENCE TEST BEFORE FORCING FIRST ERROR
*              Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERS     BSS
          LDC    FERS10
 FERS5    BSS
          STML   CTDT7
          LJM    MAIN10
 FERS10   CON    0
          SODL   FEST
 FERS20   BSS
          PJN    FERS40      IF NOT TIME TO FORCE ERROR
          LCN    0
          STML   CP+FCP+3    ILLEGAL CYLINDER NUMBER
 FERS30   BSS
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERS40      IF NOT TIME TO RESTORE INSTRUCTION
          LDC    CPT
          STML   CTDT7       RESTORE INSTRUCTION
 FERS40   BSS
          RJM    CPT         COMMAND PACKET TRANSFER
          LJM    CTDT7+1     RETURN TO CONFIDENCE TEST
          SPACE  5,20
** NAME-- FERT
*
** PURPOSE-- CHANGE ONE MEMORY LOCATION
*            8 = 0014
*            9 = 0000 0000 XXXX YYYY
*              X = ADDRESS
*              Y = VALUE
          SPACE  2
 FERT     BSS
          LDDL   P5
          STIL   P4
          LJM    MAIN10
          SPACE  5,20
** NAME-- FERU
*
** PURPOSE-- FORCE DMA TO IPI INPUT DATA PARITY ERROR UPPER ON A READ
*            8 = 0015
          SPACE  2
 FERU     BSS
          LDC    FERU5
          UJN    FERV5
 FERU5    CON
          STDL   T3          SAVE FUNCTION CODE
          LDC    H0300       WRITE CONTROL REGISTER
          RJM    FAN
          LDC    0#8A        FORCE PARITY ERROR
          UJN    FERV15
          SPACE  5,20
** NAME-- FERV
*
** PURPOSE-- FORCE BYTE COUNT EQUAL 0 ON JY BOARD ON A READ
*            8 = 0016
          SPACE  2
 FERV     BSS
          LDC    FERV10
 FERV5    BSS
          LJM    FERB5
 FERV10   CON    0
          STDL   T3          SAVE FUNCTION CODE
          LDC    H0300       WRITE CONTROL REGISTER
          RJM    FAN
          LDC    0#96        FORCE BYTE COUNT EQUAL 0
 FERV15   BSS
          ACN    DC
          OAN    DC
          LJM    FERB20
          SPACE  5,20
** NAME-- FERW
*
** PURPOSE-- FORCE OUTPUT DATA PARITY ERROR UPPER FROM THE DMA
*            ARRAY ON A WRITE
*            8 = 0017
          SPACE  2
 FERW     BSS
          LDC    FERW5
          UJN    FERY5
 FERW5    CON    0
          STDL   T3          SAVE FUNCTION CODE
          LDC    H0300       WRITE CONTROL REGISTER
          RJM    FAN
          LDC    0#8C        FORCE PARITY ERROR
          UJN    FERY15
          SPACE  5,20
** NAME-- FERY
*
** PURPOSE-- FORCE BYTE COUNT EQUAL 0 ON JY BOARD ON A WRITE
*            8 = 0018
          SPACE  2
 FERY     BSS
          LDC    FERY10
 FERY5    BSS
          LJM    FERD5
 FERY10   CON    0
          STDL   T3          SAVE FUNCTION CODE
          LDC    H0300       WRITE CONTROL REGISTER
          RJM    FAN
          LDC    0#96        FORCE BYTE COUNT EQUAL 0
 FERY15   BSS
          ACN    DC
          OAN    DC
          LJM    FERD20
          SPACE  5,20
** NAME-- FERZ
*
** PURPOSE-- FORCE ERROR IN TEST MODE BY READING ONE MORE WORD
*            THAN THE TRANSFER COUNT EXPECTS.
*            8 = XX19
*                XX = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERZ     BSS
          LDC    FERZ5
          STML   WOG10
          LJM    MAIN10
 FERZ5    CON    0
          STDL   T3          SAVE FUNCTION
          LDC    0#8081
          STML   WOGP+1      INCREMENT SYNC COUNT
          LDDL   FEST
          ZJN    FERZ10      IF NOT FORCING AN ERROR
          SODL   FEST
          UJN    FERZ15
 FERZ10   BSS
          LDC    FUNC        RESTORE INSTRUCTION
          STML   WOG10
          SOML   WOGP+1      RESTORE BYTE COUNT
 FERZ15   BSS
          LDDL   T3
          RJM    FUNC
          LJM    WOG10+1
 .F       ENDIF
          SPACE  5,20
** NAME-- FORMA
*
** PURPOSE-- FORMAT A CM REAL MEMORY ADDRESS.
*
** CALLING SEQUENCE-- LDC    ADDRESS
*                     RJM    FORMA
*
** INPUT-- - A REGISTER- IS THE ADDRESS OF A 2-WORD CM BYTE ADDRESS.
*
** OUTPUT-- -CMADR- IS THE ADDRESS OF THE RESULTING 3-WORD REFORMATED
*                CM ADDRESS.  THE FORMAT CAN BE USED BY THE LOADC MACRO.
*           -ADDRESS-, WORD 0, BITS 0-13 AND
*                      WORD 1, BITS 3-15, ARE REFORMATTED TO-
*           -CMADR-,   WORD 0, BITS 0-9,
*                      WORD 1, BITS 0-11,
*                      WORD 2, BITS 0-5.
          SPACE  2
 FORX     LJM    **
 FORMA    EQU    *-1
          STDL   T1
          LDML   1,T1
          LPN    7
          NJN    FOR10       RMA ADDRESS ERROR
          LDIL   T1
          LPN    37B
          SHN    16
          LMML   1,T1
          SHN    9
          STD    CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   T1
          SHN    -5
          STD    CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMC    400000B
          UJK    FORX
 FOR10    BSS
          LDC    E304        RMA NOT WORD BOUNDARY
          RJM    INTERR      REPORT ERROR (NO RETURN)
          SPACE  5,20
          SPACE  5,20
** NAME-- FU
*
** PURPOSE-- FORMAT UNIT
          SPACE  2
 FUX      LJM    **
 FU       EQU    *-1
          LDN    E57         FORMATTING DRIVE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDML   /SS/P.UNIT,CSST
          STML   RS+/RS/P.UNIT  PORT, CONTROLLER, DRIVE ADDRESS
          LDN    0
          STML   RS+/RS/P.SCYL  STARTING CYLINDER
          STML   RS+/RS/P.FTRK  SO TRACK, SECTOR WILL BE 0 IN CRITICAL WINDOW
          STML   RS+/RS/P.FSEC
          RJM    INTRS       SEND INTERMEDIATE RESPONSE

*         FORMAT THE UNIT

          LDN    12
          STML   CP          COMMAND PACKET LENGTH
          LDDL   UX
          STML   CP+CRN
          LDC    0#280D
          STML   CP+OPCD     INITIAL FORMAT COMMAND
          LDC    0#53B
          STML   CP+FCP      LOGICAL SECTOR SIZE
          LDN    0
          STML   CP+FCP+1    UPPER BYTES OF SECTOR SIZE
          LDC    2048        LOWER BYTES OF SECTOR SIZE
          STML   CP+FCP+2
          LDML   /SS/P.UNIT,CSST
          STML   CP+SLAD     CONTROLLER, UNIT NUMBER
          LDN    2           SET COMMANDS ISSUED
          STDL   CMNDS
          STML   FIP         FORMAT IN PROGRESS
          RJM    CPT         COMMAND PACKET TRANSFER
          UJK    FUX
** NAME-- GETRQ
*
** PURPOSE-- DETERMINE WHETHER OR NOT TO USE MASTER TERMINATE.
*            MASTER TERMINATE MEANS USE A LARGE SECTOR COUNT AND
*            TERMINATE WHEN THERE IS NO MORE DATA TO TRANSFER.
*            MASTER TERMINATE ONLY WORKS WITH MICROCODE LEVEL 8
*            AND LATER.  SINCE THERE IS A PERFORMANCE PENALTY
*            ON READS, ONLY USE MASTER TERMINATE FOR READS WHEN
*            MORE THAN ONE PAGE IS TO BE TRANSFERRED.  IF USING
*            MASTER TERMINATE, SET THE MASTER TERMINATE FLAG AND
*            EXIT.
*
*            IF NOT USING MASTER TERMINATE, COMPUTE
*            THE TOTAL BYTES TO TRANSFER AND SAVE IN SS TABLE.
*            THE PP DRIVER WILL ISSUE UP TO 2 COMMANDS PER DRIVE.
*            IF NO COMMANDS ARE OUTSTANDING, GET THE FIRST REQUEST
*            FROM CM, GET THE FIRST COMMAND FROM THE REQUEST AND SET
*            UP THE STATUS RESPONSE BUFFER.  IF ONE COMMAND IS STILL
*            ACTIVE FOR THE DRIVE, GETTING THE REQUEST INTO THE SS
*            TABLE WILL BE DONE IN ROUTINE DCR.
          SPACE  2
 GETRX    LJM    **
 GETRQ    EQU    *-1
          LDN    0
          STDL   TOTAL
          STDL   TOTAL+1
          STML   CP+FCP+1    UPPER WORD OF SECTOR COUNT
          LDDL   CSST
          STDL   P6          SAVE CURRENT SS TABLE POINTER
          LDC    IPIT
          STDL   CSST        START OF ALTERNATE SS TABLE
          LDDL   CNUM
          ZJN    GETR2       IF FIRST COMMAND
          LDML   /SS/P.RMA2,P6
          STML   /SS/P.REQ,CSST
          LDML   /SS/P.RMA2+1,P6
          UJN    GETR3
 GETR2    BSS
          LDML   /SS/P.REQ,P6
          STML   /SS/P.REQ,CSST
          LDML   /SS/P.REQ+1,P6
 GETR3    BSS
          STML   /SS/P.REQ+1,CSST
          RJM    UREQ        READ UNIT REQUEST FROM CM
          LDML   RQ+/RQ/P.CYL,CSST
          STML   CP+FCP+3    CYLINDER
          LDML   RQ+/RQ/P.TRACK,CSST
          SHN    8
          ADML   RQ+/RQ/P.SECTOR,CSST
          STML   CP+FCP+4    HEAD, SECTOR
          RJM    UNCMND      GET FIRST COMMAND
          LDML   /SS/P.MREV,P6
          SHN    -12
          SBN    8
          MJK    GETR10      IF MASTER TERMINATE NOT SUPPORTED
*
*         IF IN RECOVERY AND USING MASTER TERMINATE, THIS GUARANTEES A
*         WRITE ERROR FOR THE NTH REQUEST DOES NOT RETURN AN ERROR FOR
*         A PREVIOUS REQUEST.
*         WITH 8A MICROCODE AND IF USING MASTER TERMINATE, THE CM3 READS
*         AHEAD AND WILL REPORT AN ERROR FOR A SECTOR READ EVEN IF IT IS
*         NOT SENT TO THE PP.  SOMETIMES AN ERROR ON THE READ AHEAD WILL
*         CAUSE THE CM3 TO NOT SEND A COMPLETION RESPONSE.
*
          LDML   /SS/P.RQTRY,P6
          NJK    GETR10      IF IN ERROR RECOVERY
          LDML   CM+/CM/P.CODE,CSST
          SHN    -12
          SBN    5
          ZJN    GETR6       IF WRITE (USE MASTER TERMINATION)
          LDML   RQ+/RQ/P.SWIT,CSST
          LPC    77777B
          SBN    1
          ZJN    GETR10      IF MAU COUNT = 1 (NO MASTER TERMINATION)
          LDML   /SS/P.LISTL,CSST
          SBN    1
          ZJN    GETR10      IF ONLY ONE LIST
 GETR6    BSS
          LDDL   P6
          STDL   CSST        RESTORE POINTER TO SS TABLE
          LDDL   CNUM
          ZJN    GETR7       IF FIRST COMMAND FOR UNIT
          LDC    0#8000
          STML   /SS/MT2,CSST INDICATE MASTER TERMINATE BEING USED
          UJK    GETRX
 GETR7    BSS
          LDC    0#8000
          STML   /SS/MT,CSST INDICATE MASTER TERMINATE BEING USED
          LJM    GETR45
 GETR9    BSS
          RJM    UNCMND      GET FIRST COMMAND
 GETR10   BSS
          LDML   CMLIST+/CM/P.LEN,CSST NUMBER OF BYTES TO TRANSFER
          RADL   TOTAL+1     TOTAL BYTES TO TRANSFER
          SHN    -16
          RADL   TOTAL
          SOML   /SS/P.LISTL,CSST DECREMENT ADDRESS-LENGTH-PAIR COUNT
          ZJN    GETR20      IF END OF RMA LIST
          RJM    GLIST       READ NEXT INDIRECT ENTRY
          UJN    GETR10
 GETR20   BSS
          RJM    UNCMND      GET NEXT COMMAND
          NJK    GETR10      IF MORE COMMANDS
          LDML   RQ+/RQ/P.SWIT,CSST CHECK IF REQUEST SWITCH FLAG IS SET
          SHN    /RQ/L.SWIT+2
          PJN    GETR30      IF SWITCH FLAG IS NOT SET
          LDML   /SS/P.RQTRY,P6
          NJN    GETR30      IF IN ERROR RECOVERY.  THIS GUARANTEES THAT
                              A WRITE ERROR IN THE NTH CONCATENATED REQUEST
                              DOES NOT CAUSE A PREVIOUS REQUEST TO BE
                              RETURNED AS UNRECOVERABLE
          LDML   RQ+/RQ/P.NEXT,CSST PUT RMA OF NEXT REQUEST IN SS TABLE
          STML   /SS/P.REQ,CSST
          LDML   RQ+/RQ/P.NEXT+1,CSST
          STML   /SS/P.REQ+1,CSST
          RJM    UREQ        READ NEXT STREAMED UNIT REQUEST FROM CM
          UJK    GETR9

 GETR30   BSS
          LDDL   P6
          STDL   CSST        RESTORE POINTER TO SS TABLE
          LDDL   CNUM
          ZJN    GETR40      IF FIRST COMMAND FOR UNIT
          LDDL   TOTAL+1
          STML   /SS/P.TW2+1,CSST TOTAL CM BYTES TO TRANSFER
          LDDL   TOTAL
          STML   /SS/P.TW2,CSST
          UJN    GETR50
 GETR40   BSS
          LDDL   TOTAL+1
          STML   /SS/P.TOTAL+1,CSST TOTAL CM BYTES TO TRANSFER
          LDDL   TOTAL
          STML   /SS/P.TOTAL,CSST
 GETR45   BSS
          RJM    UREQ        READ UNIT REQUEST FROM CM
          RJM    SRESP       SET UP STATUS FOR RESPONSE BUFFER
          RJM    SETRQ       SET UP FOR FIRST REQUEST
          RJM    UNCMND      GET FIRST COMMAND
 GETR50   BSS
          UJK    GETRX
          SPACE  5,20
** NAME-- GETSS
*
** PURPOSE-- READ SS TABLE FROM UNIT COMMUNICATION BUFFER IN
*            CM UNIT INTERFACE TABLE IF IT IS NOT ALREADY IN MEMORY
*
          SPACE  2
 GETSSX   LJM    **
 GETSS    EQU    *-1
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        SET INDEX TO SS TABLE
          NJN    GETSSX      IF TABLE IN MEMORY
          LDC    SSNR
          STDL   CSST        POINTER TO CURRENT SS TABLE
          LDDL   UX
          SBDL   SSUN        UX OF CURRENT SS TABLE
          ZJN    GETSSX      IF SS TABLE ALREADY IN MEMORY
          RJM    SAVSS       SAVE SS TABLE BEFORE READING ANOTHER SS TABLE
          LDDL   UX
          STDL   SSUN        SAVE UX OF NEW SS TABLE
          LOADR  UNITS+/UN/P.UIT,UX
          ADN    /UIT/C.UBUF OFFSET OF COMMUNICATION BUFFER
          CRDL   T1          GET ADDRESS OF COMMUNICATION BUFFER
          LOADF  T3          REFORMAT IT AND LOAD R REGISTER
          CRML   SSNR,WC     READ SS TABLE
          UJK    GETSSX
          SPACE  5,20
** NAME-- GETUD
*
** PURPOSE-- GET A UNIT REQUEST FROM CENTRAL, ISSUE ALL
*            SEEKS, AND PROCESS INTERRUPTS FROM THE CM3
          SPACE  2
 GETUDX   LJM    **
 GETUD    EQU    *-1
          LDDL   UNUML
          ZJN    GETUDX      IF NO UNITS
          RJM    UC          UPDATE CLOCK
          RJM    SIS         SAVE INTERRUPT STATUS
          LDDL   LUX         UNIT INDEX OF LAST REQUEST FOUND + 1
          STDL   P6
 GETU5    BSS
          LDDL   LUX
          STDL   UX
          LDN    P.UN
          RADL   LUX         BUMP UNIT ENTRY
          SBDL   UNUML
          MJN    GETU10      IF NOT END OF TABLE
          STDL   LUX
 GETU10   BSS
          LDML   UNITS,UX
          SHN    -/UN/N.UNIT
          LPN    17B
          STDL   CMOD        SAVE CONTROL MODULE NUMBER AND PORT NUMBER
          LDML   UNITS,UX
          SHN    /UN/L.CIP+2
          PJK    GETU38      IF NO COMMAND IN PROGRESS
          RJM    GETSS       GET SS TABLE
          LDML   UNITS,UX
          SHN    11
          PJN    GETU15      IF PORT A
          LDML   SELT,CMOD
          LPDL   STATUS+1
          UJN    GETU20
 GETU15   BSS
          LDML   SELT,CMOD   MASK VALUE
          LPDL   STATUS      INTERRUPT STATUS
 GETU20   BSS
          ZJN    GETU22      IF NO INTERRUPT FOR THIS CONTROL MODULE
          RJM    PI          PROCESS INTERRUPT (NO RETURN)
 GETU22   BSS
          LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          MJN    GETU24      IF TWO COMMANDS IN PROGRESS
          SHN    /UN/L.DTIP-/UN/L.TCIP
          MJK    GETU34      IF SECOND COMMAND CAN BE ISSUED
          ERRMI  /UN/L.DTIP-/UN/L.TCIP-1 IF PREVIOUS SHIFT INCORRECT
          LDDL   IF
          NJK    GETU34      IF INITIALIZATION, SECOND COMMAND CAN BE ISSUED
 GETU24   BSS
          LDML   /SS/P.FNC,CSST
          SBN    4
          ZJN    GETU27      IF FORMAT COMMAND
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    GETU25      IF CLOCK HASNT WRAPPED
          ADC    0#10000
 GETU25   SBN    42          40 TO 41 SECOND TIMEOUT
          PJK    GETU100     IF TIMEOUT
          UJK    GETU30
 GETU27   LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    GETU28      IF CLOCK HASNT WRAPPED
          ADC    0#10000
 GETU28   ADC    -FDT        9000 SECOND TIMEOUT VALUE
          PJK    GETU100     IF TIMEOUT

* GO TO NEXT UNIT ENTRY.

 GETU30   BSS
          LDDL   LUX         HAVE ALL ENTRIES BEEN CHECKED
          SBDL   P6
          ZJK    GETUDX      IF NO MORE ENTRIES TO CHECK
          UJK    GETU5

* DETERMINE IF DRIVE TESTING IS REQUIRED

 GETU34   BSS
          LDN    1
          STDL   CNUM        INDICATE SECOND COMMAND TO UNIT
          LDDL   IF
          ZJK    GETU40      IF INITIALIZATION NOT REQUIRED
          LDML   /SS/P.CT,CSST
          LPN    7
          NJK    GETU24      IF NO NEED TO RUN CONFIDENCE TEST
          LDDL   CMNDS
          NJK    GETU30      IF MORE CMNDS TO PROCESS
          RJM    CD          CHECK DRIVE
          NJN    GETU36      IF BYPASS CONFIDENCE TEST
          RJM    CT          RUN CONFIDENCE TEST
 GETU36   LJM    GETUDX      EXIT


* NO COMMANDS IN PROGRESS.
* CHECK FOR ANY REQUESTS ON THIS UNIT QUEUE.

 GETU38   BSS
          LDN    0           INDICATE FIRST COMMAND TO UNIT
          STDL   CNUM
          LDDL   IF
          NJK    GETU30      IF CONFIDENCE TEST SHOULD BE RUN
          LOADR  UNITS+/UN/P.UIT,UX ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T5
          ADN    /UIT/C.NEXT
          CRDL   T1          READ RMA OF NEXT REQUEST FROM UNIT QUEUE
          LDDL   T3
          ADDL   T4
          ZJK    GETU30      IF NO REQUESTS ON THIS QUEUE
          LDDL   T5+/UIT/P.DSABLE CHECK IF UNIT IS DISABLED
          SHN    /UIT/L.DSABLE+2
          MJK    GETU30      IF UNIT IS DISABLED

* PROCESS COMMAND FOR UNIT

 GETU40   BSS
 .U       IFEQ   UNIX,1
          LDDL   MALET       NONZERO IF MAINTENANCE REQUEST
 .U       ELSE
          LDDL   IDLE        NONZERO IF IDLE COMMAND
          ADDL   MALET       NONZERO IF MAINTENANCE REQUEST
 .U       ENDIF
          NJK    GETU65      IF NOT STARTING REQUESTS
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          RJM    SR          SELECT REQUEST
          NJN    GETU65      IF REQUEST NOT FOUND
          RJM    GETRQ       GET REQUEST
          LDML   /SS/P.CT,CSST
          LPN    7
          ZJK    GETU50      IF NEED TO RUN CONFIDENCE TEST
          LDDL   FNC
          SBN    4
          NJN    GETU60      IF NOT FORMAT
 GETU50   LDDL   CNUM
          NJK    GETU24      IF SECOND COMMAND
          STML   /SS/P.CT,CSST  ENABLE RUNNING CONFIDENCE TEST
          LDML   UNITS,UX    SET COMMAND IN PROGRESS FLAG
          LMC    0#8000
          STML   UNITS,UX
          STDL   IF          SET INITIALIZATION FLAG
          UJN    GETU62
 GETU60   RJM    SEEK        ISSUE INITIAL SEEK
 GETU62   BSS
          LJM    MAIN15
 GETU65   BSS
          LDDL   CNUM
          NJK    GETU24      IF COMMAND IN PROGRESS, CHECK TIMER
          UJK    GETU30

* TIMEOUT PROCESSING

 GETU100  BSS
          LDML   /SS/P.RESET,CSST
          ZJN    GETU120     IF RESET NOT ISSUED
          LPN    1
          ZJN    GETU104     IF ASYNCH FOR DRIVE EXPECTED
          LDML   EPCT,CMOD
          STDL   UX          UNIT ISSUING RESET
          RJM    GETSS       GET SS TABLE IF NECESSARY
          LDC    SRT         SLAVE RESET TIMEOUT
          UJN    GETU108
 GETU104  BSS
          LDC    DST         DRIVE SPINUP TIMEOUT
 GETU108  BSS
          STDL   T1
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    GETU110     IF CLOCK HASNT WRAPPED
          ADC    0#10000
 GETU110  BSS
          SBDL   T1
          PJN    GETU120     IF TIMEOUT
          LJM    GETU30
 GETU120  BSS
          LDN    E38         NO CM3 INTERRUPT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- GLIST
*
** PURPOSE-- READ ONE ENTRY FROM THE CM ADDRESS LIST PORTION OF A COMMAND.
*
** INPUT-- LISTL
*
** OUTPUT-- CMLIST, CM+/CM/P.RMA
          SPACE  2
 GLIX     LJM    **
 GLIST    EQU    *-1
          LDDL   CSST        ADDRESS OF SS TABLE
          ADK    CMLIST
          STML   GLIST4      ADDRESS TO STORE CM LIST
          LDN    1
          STDL   WC          NUMBER OF CM WORDS TO READ
          LOADF  CM+/CM/P.RMA,CSST LOAD CM ADDRESS AND REFORMAT
          CRML   *,WC        READ ONE ENTRY FROM THE CM LIST
 GLIST4   EQU    *-1
          LDN    8
          RAML   CM+/CM/P.RMA+1,CSST UPDATE RMA ADDRESS FOR NEXT READ
          SHN    -16
          RAML   CM+/CM/P.RMA,CSST
          LDML   CMLIST+/CM/P.LEN,CSST MAKE SURE IT IS AN EVEN NUMBER OF CM WORDS
          ADN    7
          SCN    7
          STML   CMLIST+/CM/P.LEN,CSST
          UJK    GLIX
          SPACE  5,20
** NAME-- IH
*
** PURPOSE-- INTERRUPT HANDLER.  INPUT THE RESPONSE PACKET.  THROW AWAY
*            ASYNCHRONOUS RESPONSES FOR UNITS NOT CONFIGURED.  REPORT
*            ASYNCHRONOUS DRIVE ERROR RESPONSES FOR CONFIGURED UNITS.
*
** EXIT
*         A = MAJOR STATUS
*         THE DRIVE IS DESELECTED
          SPACE  2
 IHX      LJM    **
 IH       EQU    *-1
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,UX SAVE CLOCK IN TABLE
          LDML   CP+OPCD
          NJN    IH1         IF NOT LOGICAL INTERFACE RESET
          LDN    3           2 TO 4 SECOND TIMEOUT
          UJN    IH6
 IH1      BSS
          LMC    H0800
          ZJN    IH5         IF DRIVE POWER ON RESET (NEEDS 45 SECONDS)
          LDML   CP+OPCD
          LMC    8400
          ZJN    IH2         IF READ PERFORMANCE LOG
          LDML   /SS/P.RESET,CSST
          NJN    IH4         IF RESET ISSUED
 IH2      BSS
          LDN    32          APPROXIMATELY 31 SECOND TIMEOUT
          UJN    IH6
 IH4      BSS
          SHN    17
          MJN    IH5         IF SLAVE RESET
          LDC    DST         DRIVE SPINUP TIMEOUT
          UJN    IH6
 IH5      BSS
          LDC    SRT         SLAVE RESET TIMEOUT
 IH6      BSS
          STDL   T7          SAVE TIMEOUT VALUE
 IH10     BSS
          RJM    RI          REQUEST INTERRUPTS
          LDML   SELT,CMOD   MASK VALUE
          LPDL   STATUS      INTERRUPT STATUS
          NJN    IH15        IF INTERRUPT PRESENT
          RJM    UC          UPDATE CLOCK
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    IH12        IF CLOCK HAS NOT WRAPPED
          ADC    0#10000
 IH12     BSS
          SBDL   T7
          MJN    IH10        IF TIMEOUT NOT EXPIRED
          LDK    E38         NO CM3 INTERRUPT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 IH15     BSS
          RJM    DTM         DETERMINE TRANSFER MODE
          RJM    SEL         SELECT THE CONTROLLER
          STDL   CTM         CLEAR CHANNEL TRANSFER MODE FLAG
          RJM    RPT         RESPONSE PACKET TRANSFER
          RJM    DCM         DESELECT THE CONTROL MODULE
          LDML   RPB+MAJST   MAJOR STATUS
          SHN    -4
          LPN    0#F
          LMN    AR
          NJN    IH20        IF NOT ASYNCHRONOUS RESPONSE
          LDML   RPB+SLAD
          LPC    0#FF
          LMC    0#FF
          ZJN    IH30        IF ASYNCHRONOUS RESPONSE FOR CONTROLLER
          RJM    DARH        DRIVE ASYNCHRONOUS RESPONSE HANDLER
          LDDL   T8
          STDL   UX          RESTORE UX
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          UJN    IH40        GO LOOK FOR ANOTHER INTERRUPT
 IH20     BSS
          LDML   RPB+MAJST   MAJOR STATUS
          LJM    IHX
 IH30     BSS
          LDK    ID16
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    IH20        IF ID 16 NOT FOUND
          LDML   RPB+6,T3
          SHN    8
          PJN    IH20        IF NOT CONTROLLER OVER TEMPERATURE
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 IH40     BSS
          LJM    IH10
          SPACE  5,20
** NAME-- INTERR
*
** PURPOSE-- REPORT AN INTERFACE ERROR
          SPACE  2
 INTERR   CON    0
          STML   RS+/RS/P.IEC INTERFACE ERROR CODE
          LDK    /RS/K.INTERR  INTERFACE ERROR
          STML   RS+/RS/P.INTERR  ABNORMAL STATUS CODE
          LDK    E120        SOFTWARE FAILURE
          STML   RS+/RS/P.ERRID SET ERROR IDENTIFIER
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       IFEQ   UNIX,1
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 .U       ENDIF
          RJM    HANG
          SPACE  5,20
** NAME-- INTRS
*
** PURPOSE-- SEND INTERMEDIATE RESPONSE.
          SPACE  2
 INTRSX   LJM    **
 INTRS    EQU    *-1
          LDDL   PTF
          NJN    INTRS10     IF REQUEST EXISTS
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       IFEQ   UNIX,1
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 .U       ENDIF
          UJK    INTRSX
 INTRS10  BSS
 .U       IFEQ   UNIX,1
          LDN    0
          STML   RS+/RS/P.SHORT   INDICATE ERROR RESPONSE
 .U       ENDIF
          LDC    RLIE
          STML   RS+/RS/P.RESPL BYTE LENGTH OF RESPONSE
          LDN    R.INT       INTERMEDIATE RESPONSE
          SHN    16-/RS/N.RC-/RS/L.RC
          STML   RS+/RS/P.RC RESPONSE CODE
          RJM    TERMP       SEND RESPONSE TO CM
          UJK    INTRSX
          SPACE  5,20
** NAME--ISR
*
** PURPOSE-- ISSUE SLAVE RESET
          SPACE  2
 ISR      CON    0
          LDC    H8415       SLAVE RESET
          STML   CP+OPCD     SO TIMEOUT WILL BE LONG IN IH
          RJM    IR          ISSUE RESET
          LDML   /SS/P.CT,CSST
          ZJN    ISR10       IF IN SUBSYSTEM CONFIDENCE TEST
          LJM    MAIN15
 ISR10    BSS
          RJM    IH          INTERRUPT HANDLER
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETRUN)
          SPACE  5,20
** NAME-- IU
*
** PURPOSE-- INITIALIZE UNIT. CALLED DURING FORMAT OPERATION.
 IUX      LJM    **
 IU       EQU    *-1
          LOADF  CMLIST+/CM/P.RMA,CSST  ADDRESS OF LIST WITH FORMAT PARAMTER
          CRDL   P1          READ WORD WITH PARAMETER
          LDDL   P3
          NJK    IU10        IF UNCONDITIONAL FORMAT
          RJM    IUF         IS UNIT FORMATTED
          NJK    IU10        IF UNIT IS NOT FORMATTED
          LDN    2           CMNDS WILL GET DECREMENTED TWICE
          STDL   CMNDS
          LDN    0
          LJM    TERM20      TERMINATE REQUEST
 IU10     BSS
          LDML   UNITS,UX
          LPC    0#3FFF
          LMC    0#C000      INDICATE TWO COMMANDS ISSUED
          STML   UNITS,UX
          RJM    FU          FORMAT UNIT
          UJK    IUX
          SPACE  5,20
** NAME-- IUF
*
** PURPOSE-- IS UNIT FORMATTED.
*
** EXIT-- A=0 IF UNIT FORMATTED AT CORRECT SECTOR SIZE
          SPACE  2
 IUFX     LJM    **
 IUF      EQU    *-1
          LDN    10
          STML   CP          COMMAND PACKET LENGTH
          LDC    0#200
          STML   CP+OPCD     ATTRIBUTE COMMAND
          LDC    0#36C
          STML   CP+FCP      PARAMETER TO READ SECTOR SIZE
          LDC    0#4051
          STML   CP+FCP+1    RETURN SECTOR SIZE IN RESPONSE
          LDML   /SS/P.UNIT,CSST
          STML   CP+SLAD     CONTROLLER, UNIT NUMBER
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          ZJN    IUF05       IF SUCCESSFUL
          LPC    IVR         INTERVENTION REQUIRED
          ZJN    IUF10       IF UNEXPECTED STATUS
          LDK    ID24
          RJM    SFP         SEARCH FOR PARAMETER
          LDML   RPB+8,T3
          SHN    2
          MJK    IUFX        IF DRIVE NOT FORMATTED
          UJN    IUF10       UNEXPECTED STATUS
 IUF05    LDC    ID51
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    IUF10       IF ID 51 NOT FOUND
          LDML   RPB+7,T3    SECTOR SIZE IN BYTES
          ADC    -2048       EXPECTED SECTOR SIZE
          LJM    IUFX
 IUF10    BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- LIR
*
** PURPOSE-- LOGICAL INTERFACE RESET
          SPACE  2
 LIRX     LJM    **
 LIR      EQU    *-1
          LDN    0
          STML   CP+OPCD     SO TIMEOUT WILL BE SHORT IN IH
          RJM    GETSS       GET SS TABLE IF NECESSARY
          LDC    H8215       LOGICAL INTERFACE RESET
          RJM    IR          ISSUE RESET
          RJM    IH          INTERRUPT HANDLER
          SHN    -4
          LPN    0#F
          LMN    AR
          NJN    LIR20       IF NOT ASYNCHRONOUS RESPONSE
          LDN    ID16
          RJM    SFP         CHECK FOR MACHINE EXCEPTION
          MJN    LIR20       IF MACHINE EXCEPTION ID NOT FOUND
          LDML   RPB+6,T3
          LPC    0#FEE0
          LMC    0#6000
          NJN    LIR20       IF ERROR
          UJK    LIRX
 LIR20    BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- LOCK
*
** PURPOSE-- SET THE LOCKWORD
*
** ENTRY
*         T7 = RMA POINTER
*         T5 = OFFSET TO LOCKWORD FROM RMA
*
** EXIT
*         A = 0 IF LOCK SUCCESSFULLY SET
          SPACE  2
 LOCKX    LJM    **
 LOCK     EQU    *-1
 LOCK1    BSS
          LCN    0
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          SET INTERMEDIATE VALUE
          LDDL   T1
          ZJN    LOCK5       IF LOCK COULD BE SET
          ADDL   T2
          ADC    -177777B-177777B
          ZJN    LOCK1       IF INTERMEDIATE VALUE
          LDDL   T2
          LPC    77777B
          ADC    100000B
          STDL   T2          SET THE VE BIT
          LDDL   T6
          LMC    400000B
          CWDL   T1          RESTORE THE LOCKWORD AND SET THE VE BIT
          LDDL   T4
          SBDL   PPNO        CHECK IF LOCK ALREADY SET
          NJN    LOCK3       IF LOCK COULD NOT BE SET, EXIT A .NE. 0
          LDDL   T1
          ADC    -100000B
 LOCK3    UJK    LOCKX       IF LOCK WAS ALREADY SET, EXIT A = 0
                             IF LOCK COULD NOT BE SET, EXIT A .NE. 0
 LOCK5    BSS
          LDC    100000B
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          LDDL   PPNO
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          SET THE LOCKWORD
          LDN    0
          UJK    LOCKX
          SPACE  5,20
** NAME-- OFFCH
*
** PURPOSE-- TURN OFF ALL UNITS ON A CHANNEL
          SPACE  2
 OFCX     LJM    **
 OFFCH    EQU    *-1
          LDN    0
          STDL   UX          UNITS TABLE INDEX
 OFC10    BSS
          RJM    OFFUN       SET UNIT DISABLE FLAG
          LDN    P.UN
          RADL   UX          BUMP UNITS TABLE INDEX
          SBDL   UNUML
          NJK    OFC10       IF NOT END OF TABLE
          UJK    OFCX
          SPACE  5,20
** NAME-- OFFCM
*
** PURPOSE-- TURN OFF ALL UNITS ON A CONTROL MODULE.
          SPACE  2
 OFFCM    CON    0
 .U       IFEQ   UNIX,1
          LDK    /RS/K.CMDN  CONTROLLER DOWN
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       ENDIF
          LDDL   UX
          STDL   P5          POINTER TO CURRENT UNITS TABLE
          LDN    0
          STDL   UX          UNITS TABLE INDEX
 OFFCM10  BSS
          LDML   UNITS,P5    COMPARE IF SAME CONTROL MODULE
          LMML   UNITS,UX
          LPN    70B
          NJN    OFFCM20     IF NOT THE SAME CONTROL MODULE
          RJM    OFFUN       SET UNIT DISBLE FLAG
 OFFCM20  BSS
          LDN    P.UN
          RADL   UX          BUMP UNITS TABLE INDEX
          SBDL   UNUML
          NJK    OFFCM10     IF NOT END OF TABLE
 .U       IFEQ   UNIX,1
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 .U       ELSE
          LDK    /RS/K.CMDN  CONTROLLER DOWN
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
 .U       ENDIF
          LJM    MAIN10
          SPACE  5,20
** NAME-- OFFUN
*
** PURPOSE-- SET THE DISABLE FLAG IN THE UNIT INTERFACE TABLE.
*
** OUTPUT-- P5 IS UNCHANGED
          SPACE  2
 OFUX     LJM    **
 OFFUN    EQU    *-1
          LDK    /UIT/K.DSABLE  SET UNIT DISABLE FLAG
          STDL   T3
          LDN    0
          STDL   T2
          STDL   T4
          STDL   T5
          LOADR  UNITS+/UN/P.UIT,UX ADDRESS OF UNIT INTERFACE TABLE
          RDSL   T2          -LOGICAL OR- THE UNIT DISABLE FLAG

*         NOTE THAT REQUEST RETRIES DO NOT ALLOW STREAMING SO SFRR WILL
*         NOT SEND A RESPONSE.

          RJM    SFRR        SETUP FOR REQUEST RETRY (MAKE CMNDS ACCURATE)
          UJK    OFUX
          SPACE  5,20
** NAME-- PAUS
*
** PURPOSE-- DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*            MICROSECONDS.
*
** INPUT-- A REGISTER SPECIFIES NUMBER OF MICROSECONDS
*          TO BE DELAYED.
          SPACE  2
 PAUSX    LJM    **
 PAUS     EQU    *-1
 PAUS10   SBN    1           EACH ITERATION OF THIS LOOP
          STDL   T1           IS ONE MICROSECOND (I4 ONLY)
          NJN    PAUS10
          UJK    PAUSX
          SPACE  5,20
** NAME-- PCER
*
** PURPOSE-- PREPARE COMMON ERROR RESPONSE
*
** INPUT  A = ERROR ID
          SPACE  2
 PCERX    LJM    **
 PCER     EQU    *-1
          STDL   P2
          SBN    E18
          MJN    PCER20      IF ERROR CODE 0-17
          SBN    E21-E18
          MJN    PCER10      IF ERROR CODE 18-20
          SBN    E22-E21
          MJN    PCER20      IF ERROR CODE 21
          SBN    E23-E22
          MJN    PCER10      IF ERROR CODE 22
          SBN    E27-E23
          MJN    PCER20      IF ERROR CODE 23-26
          SBN    E29-E27
          MJN    PCER10      IF ERROR CODE 27, 28
          ZJN    PCER20      IF ERROR CODE 29
          SBN    E30-E29
          NJN    PCER20      IF ERROR CODE 31-XX
 PCER10   BSS
          LDC    H00E1       READ STATUS REGISTER
          RJM    RDRG        READ REGISTER
          STDL   STATUS      SAVE CONTENTS OF STATUS REGISTER
 PCER20   BSS
 .U       IFEQ   UNIX,1
          LDML   /SS/P.XFER,CSST BYTES TRANSFERRED
          STML   RS+/RS/P.XFER
          LDML   /SS/P.XFER+1,CSST
          STML   RS+/RS/P.XFER+1
          LDML   /SS/P.LU,CSST PUT LOGICAL UNIT IN RESPONSE
          STML   RS+/RS/P.LU
 .U       ENDIF
          RJM    PDR         PREPARE NORMAL DISK RESPONSE
          LDDL   P2
          LMN    E38
          NJN    PCER26      IF NOT -NO CONTROLLER RESPONSE-
          LDML   /SS/P.RESET,CSST
          SHN    17
          MJN    PCER26      IF NO ASYNCH AFTER SLAVE RESET
          SHN    17
          PJN    PCER26      IF ERROR ALREADY ISOLATED
          LDK    E95         NO DRIVE OPERATIONAL RESPONSE
          UJN    PCER32
 PCER26   BSS
          LDDL   P2
          NJN    PCER32      IF ERROR ALREADY ISOLATED
          LDN    ID14
          RJM    SFP         SEARCH FOR ID 14
          MJN    PCER30      IF NOT CM3 INTERVENTION REQUIRED
          LDK    E71
          UJN    PCER32
 PCER30   BSS
          LDN    ID16
          RJM    SFP         SEARCH FOR ID 16
          MJN    PCER35      IF NOT CM3 MACHINE EXCEPTION
          LDML   RPB+6,T3
          SHN    8
          PJN    PCER31      IF NOT CONTROLLER OVER TEMPERATURE
          LDK    E78
          UJN    PCER32
 PCER31   BSS
          LDK    E72
 PCER32   BSS
          UJN    PCER45
 PCER35   BSS
          LDN    ID17
          RJM    SFP         SEARCH FOR ID 17
          MJN    PCER40      IF NOT CM3 COMMAND EXCEPTION
          LDML   RPB+5,T3
          SHN    -8
          SBN    6
          MJN    PCER38      IF BYTE 5 NOT PRESENT
          LDML   RPB+8,T3
          SHN    6
          PJN    PCER38      IF NOT RESERVED TO OTHER PORT
          LDK    E77         DRIVE RESERVED TO OTHER CM3 PORT
          UJN    PCER45
 PCER38   BSS
          LDK    E73
          UJN    PCER45
 PCER40   BSS
          LDN    ID13
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    PCER55      IF NOT ID13
          LDML   RPB+6,T3    FIRST WORD AFTER ID13
          SHN    5
          PJN    PCER50      IF NOT MESSAGE FROM CONTROLLER
          LDK    E60         CONTROLLER ERROR
 PCER45   BSS
          UJN    PCER70
 PCER50   BSS
          LDK    E74         MICROCODE EXECUTION ERROR
          UJN    PCER70
 PCER55   BSS
          LDN    ID15
          RJM    SFP         SEARCH FOR ID 15
          MJN    PCER60      IF NOT ALTERNATE PORT EXCEPTION
          LDK    E75
          UJN    PCER70
 PCER60   BSS
          LDK    ID23
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    PCER65      IF NOT ID23
          LDML   RPB+6,T3    FIRST WORD AFTER ID23
          SHN    5
          PJN    PCER65      IF NOT MESSAGE FROM DRIVE DIAGNOSTICS
          LDK    E61         DRIVE ERROR
          UJN    PCER70
 PCER65   BSS
          LDN    E00         CP MUST ISOLATE THE ERROR
 PCER70   BSS
          STML   RS+/RS/P.ERRID
          LDDL   WC          WORDS NOT TRANSFERRED
          STML   RS+/RS/P.WC
          LDDL   LF
          STML   RS+/RS/P.FUNTO FAILING FUNCTION IF E01
          LDC    H0200       CONTROL REGISTER
          RJM    RDRG
          STML   RS+/RS/P.CR SAVE CONTROL REGISTER
          LDC    H00F1
          RJM    RDRG        READ IPI ERROR REGISTER
          STML   RS+/RS/P.ERREG SAVE ERROR REGISTER
          LDC    H0600       DMA ERROR REGISTER
          RJM    RDRG
          STML   RS+/RS/P.DMAER SAVE DMA ERROR REGISTER
          ZJN    PCER80      IF ERROR FLAG WAS NOT SET
          LDML   RS+/RS/P.CR CONTROL REGISTER
          SHN    5
          PJN    PCER80      IF TEST MODE NOT SET
          LDC    H00E1       READ STATUS REGISTER
          RJM    RDRG        READ REGISTER
          STDL   STATUS
 PCER80   BSS
          LDDL   STATUS      STATUS REGISTER
          STML   RS+/RS/P.STREG
          LDDL   OS
          STML   RS+/RS/P.OSR SAVE OPERATIONAL STATUS REGISTER
          LDML   /SS/P.MREV,CSST
          SHN    -8
          STML   RS+/RS/P.MREV CM3 MICROCODE REVISION
          RJM    SDA         SAVE DISK ADDRESS
          LDDL   CHAN
          STML   RS+/RS/P.CHAN CHANNEL NUMBER
          LDML   UNITS,UX
          LPC    177B
          STML   RS+/RS/P.UNIT PORT, CONTROLLER, UNIT NUMBER
          LDN    0
          STML   RS+/RS/P.ID
          LDML   /SS/P.RQTRY,CSST
          STML   RS+/RS/P.RTRY REQUEST RETRY COUNT
 .F       IFEQ   FE,1
          LDML   WFTCC
          ADML   WFTEC
          STML   RS+/RS/P.FILL1 NO DATA TRANSFERRED ERROR
 .F       ENDIF
          UJK    PCERX
          SPACE  5,20
** NAME-- PDD
*
** PURPOSE-- PERFORM DRIVE DIAGNOSTICS
          SPACE  2
 PDDX     LJM    **
 PDD      EQU    *-1
          LDN    6           COMMAND PACKET LENGTH
          STML   CP
          LDC    H8100       PERFORM DRIVE DIAGNOSTIC OP CODE
          STML   CP+OPCD
          LDML   /SS/P.UNIT,CSST
          STML   CP+SLAD     CONTROLLER, UNIT NUMBER
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          ZJK    PDDX        IF SUCCESSFUL
          LDN    E00         CP MUST DETERMINE THE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- PDR
*
** PURPOSE-- PREPARE NORMAL DISK RESPONSE
          SPACE  2
 PDRX     LJM    **
 PDR      EQU    *-1
          LDML   /SS/P.FPVA,CSST PVA OF REQUEST
          STML   RS+/RS/P.PVA
          LDML   /SS/P.FPVA+1,CSST
          STML   RS+/RS/P.PVA+1
          LDML   /SS/P.FPVA+2,CSST
          STML   RS+/RS/P.PVA+2
 .U       IFNE   UNIX,1
          LDML   /SS/P.XFER,CSST BYTES TRANSFERRED
          STML   RS+/RS/P.XFER
          LDML   /SS/P.XFER+1,CSST
          STML   RS+/RS/P.XFER+1
          LDML   /SS/P.LU,CSST PUT LOGICAL UNIT IN RESPONSE
          STML   RS+/RS/P.LU
          LDK    /RS/C.LASTC*8+8
 .U       ELSE
          LDN    8
 .U       ENDIF
          STML   RS+/RS/P.RESPL NORMAL RESPONSE LENGTH
          LDN    0
          STML   RS+/RS/P.DATERR ABNORMAL STATUS WORD
          STML   RS+/RS/P.IEC INTERFACE ERROR CODE WORD
 .U       IFEQ   UNIX,1
          LDML   /SS/P.LU,CSST  LOGICAL UNIT
          LPC    0#FF
          LMC    /RS/K.SHORT  INDICATE ONE-WORD RESPONSE
          STML   RS+/RS/P.SHORT
 .U       ELSE
          LDN    R.NRM
          SHN    16-/RS/N.RC-/RS/L.RC
          STML   RS+/RS/P.RC  NORMAL RESPONSE CODE
 .U       ENDIF
          UJK    PDRX
          SPACE  5,20
** NAME-- PI
*
** PURPOSE-- PROCESS INTERRUPT
          SPACE  2
 PI       CON    0
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LDML   /SS/P.RESET,CSST
          ZJN    PI3         IF RESET NOT ISSUED
          LDML   EPCT,CMOD
          STDL   UX          CORRECT UX FOR RESET
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          RJM    DTM         DETERMINE TRANSFER MODE
 PI3      BSS
          RJM    SEL         SELECT CONTROLLER
          STDL   CTM         CLEAR CHANGE TRANSFER MODE FLAG
 PI10     BSS
          RJM    RPT         RESPONSE PACKET TRANSFER
          LDML   RPB+MAJST   MAJOR STATUS
          STDL   T6
          SHN    -4
          LPN    0#F
          SBN    CC
          NJK    PI40        IF NOT STANDARD COMMAND COMPLETION
          RJM    DCM         DESELECT THE CONTROL MODULE
          RJM    STI         SET TABLE INDEXES
          LDDL   T6
          SHN    SC
          MJK    PI25        IF SUCCESSFUL
          SHN    CS-SC
          PJK    PI100       IF NOT CONDITIONAL SUCCESS
          LDML   /SS/MT,CSST
          SHN    2
          PJN    PI20        IF NOT USING MASTER TERMINATE
          LDML   RPB+5
          LPC    0#FF
          LMC    ID19
          NJN    PI20        IF RESPONSE NOT DUE TO MASTER TERMINATE
          LDML   RPB
          SBN    15
          PJN    PI20        IF RESPONSE TOO LONG
          LDML   RPB+7
          SHN    9
          MJK    PI30        IF MASTER TERMINATE
 PI20     BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
 .U       IFEQ   UNIX,1
          LDN    0
          STML   RS+/RS/P.SHORT  INDICATE ERROR RESPONSE
 .U       ENDIF
          LDC    RLIE
          STML   RS+/RS/P.RESPL BYTE LENGTH OF RESPONSE
          LDC    0#5000
          STML   RS+/RS/P.RC RECOVERED, INTERMEDIATE RESPONSE
          RJM    TERMP       SEND RESPONSE TO CM
 .U       IFNE   UNIX,1
          LDN    0
          STML   /SS/P.XFER,CSST
          STML   /SS/P.XFER+1,CSST
 .U       ENDIF
          UJN    PI30
 PI25     BSS
          LDML   RPB+OPCD
          LMC    H0400
          NJN    PI30        IF NOT DRIVE RESERVE
          LDML   UNITS,UX
          LPC    0#17FF
          LMC    /UN/K.RD
          STML   UNITS,UX    SET DRIVE RESERVED BIT
          SODL   CMNDS       OUTSTANDING COMMANDS
          LJM    MAIN15
 PI30     BSS
          RJM    TERM        COMMAND COMPLETED WITHOUT ERROR (NO RETURN)
 PI40     BSS
          SBN    TN-CC
          NJN    PI60        IF NOT TRANSFER NOTIFICATION
          RJM    STI         SET TABLE INDEXES
          RJM    RDWT        READ WRITE SETUP
          NJN    PI45        IF EXPECTED RESPONSE
          AODL   TBC         INDICATE COMPLETION RESPONSE SHOULD BE PRESENT
          LJM    PI10
 PI45     BSS
          LDML   /SS/P.FNC,CSST
          ZJN    PI50        IF READ
          RJM    WRITE       IF WRITE (RETURN IS TO IDLE LOOP)
 PI50     BSS
          RJM    READ        READ
          LJM    MAIN15
 PI60     BSS
          RJM    DCM         DESELECT THE CONTROL MODULE
          LDML   RPB+SLAD
          LPC    0#FF
          LMC    0#FF
          ZJN    PI100       IF ASYNCH FOR CONTROLLER
          RJM    DARH        DRIVE ASYNCHRONOUS RESPONSE HANDLER
          LJM    MAIN20
 PI100    BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
 .U       IFEQ   UNIX,1
** NAME-- PPRQ
*
** PURPOSE-- CHECK FOR ANY PP REQUESTS
          SPACE  2
 PPRQX    LJM    **
 PPRQ     EQU    *-1
          LCN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDC    0#7FFF
          STDL   T4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          RDCL   T1          CLEAR ACTIVE CHECK BIT, READ PPIT WORD 1
          LDDL   T4
          SHN    /PIT/L.IDLREQ+2
          MJN    PPRQ10      IF IDLE REQUEST
          SHN    /PIT/L.RESREQ-/PIT/L.IDLREQ
          PJN    PPRQX       IF NOT RESUME OR IDLE REQUEST
          RJM    SPLOCK      SET PP TABLE LOCK
          LDDL   T4
          LPC    0#4FFE      CLEAR ACTIVE CHECK BIT, RESUME REQUEST BIT,
          STDL   T4           IDLE STATUS BIT, AND LOCK BIT IN PP
          LDDL   CM.PIT+2     INTERFACE TABLE
          LMC    400000B
          CWDL   T1
          LJM    MAIN5
 PPRQ10   BSS
          RJM    SPLOCK      SET PP TABLE LOCK
          RJM    RAR         RESTART ALL REQUESTS SET UP
          LDDL   CLF
          NJN    PPRQ15      IF 2 CONSECUTIVE RESUMES AND CHANNEL LOCK
                              ALREADY CLEAR
          RJM    CCLOCK      CLEAR CHANNEL LOCK
 PPRQ15   BSS
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          CRDL   T1
          LDDL   T4          CLEAR ACTIVE CHECK BIT, IDLE REQUEST BIT,
          LPC    0#2FFE       AND SET IDLE STATUS BIT
          LMC    0#1000
          STDL   T4
          LDDL   CM.PIT+2
          LMC    400000B
          CWDL   T1
 PPRQ20   BSS
          RJM    PPRQ        WAIT FOR RESUME
          UJN    PPRQ20
 .U       ELSE
** NAME-- PPRQ
*
** PURPOSE-- CHECK FOR ANY PP REQUESTS ON THE PP QUEUE.
          SPACE  2
 PPRQX    LJM    **
 PPRQ     EQU    *-1
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.PPQ  CM ADDRESS OF PP REQUEST QUEUE POINTER
          CRDL   T1          READ PP QUEUE POINTER
          LDDL   T3          RMA OF NEXT QUEUED PP REQUEST
          ADDL   T4
          ZJN    PPRQX       IF NO PP REQUESTS
          LDC    SSNR
          STDL   CSST        USE SPARE SS TABLE
          RJM    SAVSS       SAVE SS TABLE
          LCN    0
          STDL   SSUN        INVALIDATE TABLE AT SSNR
          RJM    SPLOCK      SET PP QUEUE LOCKWORD
          NJN    PPRQX       IF LOCK WAS NOT SET
          STML   /SS/P.XFER,CSST CLEAR BYTES TRANSFERRED
          STML   /SS/P.XFER+1,CSST
          STML   /SS/P.LU,CSST CLEAR LOGICAL UNIT
          LDN    2
          STDL   P1
          LOADC  CM.PIT
          ADN    /PIT/C.PPQPVA
          CRML   T1,P1       READ PVA AND RMA OF FIRST REQUEST IN CHAIN
          LDDL   T2          SAVE PVA OF REQUEST
          STML   /SS/P.FPVA,CSST
          LDDL   T3
          STML   /SS/P.FPVA+1,CSST
          LDDL   T4
          STML   /SS/P.FPVA+2,CSST
          LDDL   T7          PUT RMA OF REQUEST IN SS TABLE
          STML   /SS/P.REQ,CSST
          LDDL   T8
          STML   /SS/P.REQ+1,CSST
          RJM    UREQ        READ PP REQUEST
          RJM    PDR         PREPARE RESPONSE
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
          LDDL   FNC
          SBN    3
          STDL   IDLE
          ZJN    PPRQ10      IF RESUME COMMAND
          ADN    1
          ZJN    PPRQ5       IF IDLE COMMAND
          LDC    E501        INVALID COMMAND
          RJM    INTERR      REPORT ERROR (NO RETURN)
 PPRQ5    BSS
          RJM    CUB         CHECK UNIT BUSY
          NJN    PPRQ20      EXIT IF COMMANDS IN PROGRESS
          LDDL   CLF
          NJN    PPRQ10      IF LOCK ALREADY CLEAR
          RJM    CCLOCK      CLEAR CHANNEL LOCK
 PPRQ10   BSS
          LOADC  CM.PIT
          ADN    /PIT/C.PPQPVA  CM ADDRESS OF PP QUEUE POINTER
          CWML   SSNR+RQ,P1  WRITE PVA AND RMA POINTERS OF NEXT REQUEST
          RJM    TERMP       SEND TERMINATION RESPONSE
          RJM    CPLOCK      CLEAR PP QUEUE LOCKWORD
          LDDL   FNC
          SBN    3
          ZJN    PPRQ18      IF RESUME COMMAND
 PPRQ13   BSS
          RJM    PPRQ        WAIT FOR RESUME
          UJN    PPRQ13
 PPRQ18   BSS
          LJM    MAIN5
 PPRQ20   BSS
          RJM    CPLOCK      CLEAR PP QUEUE LOCKWORD
          UJK    PPRQX
 .U       ENDIF
          SPACE  5,20
** NAME-- PT
*
** PURPOSE-- PATH TEST.  FIRST TEST THE DMA PATH BETWEEN CENTRAL
*            MEMORY AND THE RECEIVERS AND TRANSMITTERS, THEN
*            TEST THE PATH BETWEEN THE PP AND THE CONTROLLER.
*            IF A PATH TO A CONTROLLER STILL FAILS AFTER AT LEAST
*            ONE RETRY WITH SLAVE RESET, ALL UNITS ON THE FAILING
*            CONTROLLER WILL BE DISABLED.
*
** ENTRY
*         1)  AT INITIALIZATION AFTER PP LOADED
*         2)  AFTER MAINTENANCE HAS USED THE CHANNEL
*         3)  AFTER THE PP HAS RECEIVED A RESUME
*         4)  DURING REQUEST RETRY IF SLAVE RESET FAILS
          SPACE  2
 PT100    BSS
          AODL   PTF         INDICATE PATH TEST COMPLETE
 PTX      LJM    **
 PT       EQU    *-1
          LDDL   UNUML
          ZJN    PT100       IF NO UNITS
          RJM    SCLOCK      SET CHANNEL LOCK
          LDDL   PTF
          NJN    PTX         IF NOT EXECUTING PATH TEST
          STDL   CMOD        CONTROL MODULE NUMBER
          STDL   UX
          RJM    GETSS       GET SS TABLE IF NECESSARY
          RJM    MR          MASTER RESET
          UJN    PT12
 PT8      BSS
          AODL   CMOD
          SBN    16
          PJN    PT100       IF ALL PATHS TESTED
 PT12     BSS
          LDN    0
          STDL   UX
          UJN    PT20
 PT16     BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
 PT20     BSS
          SBDL   UNUML
          PJN    PT8         IF END OF CONFIGURED UNITS
          LDML   UNITS,UX
          SHN    -/UN/N.UNIT
          LPN    17B
          LMDL   CMOD
          NJN    PT16        IF DIFFERENT CONTROLLER
          LOADR  UNITS+/UN/P.UIT,UX ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T1
          LDDL   T1+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJN    PT16        IF UNIT DISABLED
          RJM    GETSS       GET SS TABLE IF NECESSARY
          RJM    PS          PORT SELECT
          AODL   TMF         INDICATE TEST MODE IN PROGRESS
          RJM    TDP         TEST DMA PATH
          STDL   TMF         TMF = 0, TEST MODE COMPLETE
 PT30     BSS
          RJM    LIR         LOGICAL INTERFACE RESET

* WRITE BUFFER

          LDN    RPL
          STML   CP          COMMAND PACKET LENGTH
          LDC    H6200
          STML   CP+OPCD     WRITE TO BUFFER COMMAND
          LDDL   CMOD
          LPN    7
          SHN    8
          LMC    0#FF
          STML   CP+SLAD     CONTROLLER, DRIVE NUMBER
          LDC    H0931
          STML   CP+FCP      COMMAND EXTENT PARAMETER
          LDN    0
          STML   CP+FCP+1    UPPER WORD OF BYTE COUNT
          STML   CP+FCP+3    OFFSET
          STML   CP+FCP+4    OFFSET
          LDC    100
          STML   CP+FCP+2    BYTE LENGTH
          RJM    CPT         COMMAND PACKET TRANSFER
 PT40     EQU    *-1         FOR FORCING ERRORS
          RJM    BPTB        BUILD PATH TEST BUFFER
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    PT90        IF NOT TRANSFER NOTIFICATION
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAOUT     DATA, TRANSFER OUT
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0381       STREAM, WRITE FROM PP
          RJM    FUNC        RAISE MASTER OUT
          ACN    DC
          LDN    50          WORD COUNT
          OAM    OB,DC       OUTPUT DATA
          STDL   WC          WORDS NOT TRANSFERRED
          LDC    MS50
 PT50     BSS
          IJM    PT55,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    PT50        IF TIMEOUT NOT EXPIRED
          LDN    E30         CHANNEL STAYED ACTIVE
          UJK    PT84
 PT55     BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT THE CONTROL MODULE
          LDDL   WC
          NJK    PT80        IF INCOMPLETE TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          NJK    PT90        IF NOT SUCCESSFUL

* READ BUFFER

          LDC    H5200
          STML   CP+OPCD     READ FROM CONTROLLER BUFFER
          LDN    RBPL
          STML   CP          COMMAND PACKET LENGTH
          LDC    0#350
          STML   CP+9        BUFFER ADDRESS PARAMETER
          LDC    0#8020
          STML   CP+10       USE DATA BUFFER
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    PT90        IF NOT TRANSFER NOTIFICATION
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAIN      DATA TRANSFER IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0281       STREAM, READ TO PP MEMORY
          RJM    FUNC        RAISE MASTER OUT
          ACN    DC
          LDN    50          WORD COUNT
          IAM    IB,DC
          STDL   WC          WORDS NOT TRANSFERRED
          LDC    MS50
 PT60     BSS
          IJM    PT65,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    PT60        IF TIMEOUT NOT EXPIRED
          LDN    E30         CHANNEL STAYED ACTIVE
          UJN    PT84
 PT65     BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT THE CONTROL MODULE
          LDDL   WC
          NJN    PT80        IF NOT ALL WORDS TRANSFERRED
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          NJN    PT90        IF NOT SUCCESSFUL
          RJM    VPTD        VERIFY PATH TEST DATA
          LJM    PT8
 PT80     BSS
          LDN    E29         INCOMPLETE TRANSFER
 PT84     BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 PT90     BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- RA6F
*
** PURPOSE-- READ ATTRIBUTE 6F
*
** EXIT   A = 0 IF NO ERROR
          SPACE  2
 RA6FX    BSS
          STDL   T1
          LJM    **
 RA6F     EQU    *-1
          LDN    10
          STML   CP          COMMAND PACKET LENGTH
          LDC    H0200
          STML   CP+OPCD     READ ATTRIBUTE COMMAND
          LDC    0#36C
          STML   CP+4
          LDC    0#406F
          STML   CP+5        SELECT READING PARAMETER 6F
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          ZJK    RA6FX       IF NO ERROR
          LDN    E00         CPU MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- RAR
*
** PURPOSE-- RESTART ALL REQUESTS
          SPACE  2
 RARX     BSS
          STDL   CMNDS       NO OUTSTANDING COMMANDS
          LJM    **
 RAR      EQU    *-1
          PAUSE  100000      ALLOW CONTROLLER TIME TO WRITE DATA IN
          LDN    0            ITS BUFFER TO DISK
          STDL   UX          POINTER TO UNITS TABLE
          UJN    RAR20
 RAR10    BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
 RAR20    BSS
          SBDL   UNUML
          ZJN    RARX        IF END OF CONFIGURED UNITS
          RJM    SFRR        SET UP FOR REQUEST RETRY
          UJN    RAR10
          SPACE  5,20
** NAME-- RCC
*
** PURPOSE-- RESTART CONTROLLER COMMANDS
          SPACE  2
 RCCX     BSS
          LDDL   T8
          STDL   UX          RESTORE UNITS TABLE POINTER
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LJM    **
 RCC      EQU    *-1
          LDDL   UX
          STDL   T8          SAVE POINTER TO UNITS TABLE
          LDN    0
          STDL   UX          POINTER TO UNITS TABLE
          UJN    RCC20
 RCC10    BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
 RCC20    BSS
          SBDL   UNUML
          PJN    RCCX        IF END OF CONFIGURED UNITS
          LDML   UNITS,UX
          SHN    2+/UN/L.CIP
          PJN    RCC10       IF NO COMMAND IN PROGRESS
          SHN    -5
          LPN    17B
          LMDL   CMOD
          NJN    RCC10       IF DIFFERENT CONTROLLER
          RJM    SFRR        SETUP FOR REQUEST RETRY
          UJK    RCC10
          SPACE  5,20
** NAME-- RDRG
*
** PURPOSE-- READ REGISTER
*
** ENTRY--  A = FUNCTION CODE
          SPACE  2
 RDRG10   BSS
          LDN    0
 RDRGX    LJM    **
 RDRG     EQU    *-1
          RJM    FAN         SEND FUNCTION
          AJM    RDRG10,DC   IF NO FUNCTION REPLY
          ACN    DC+40B
          EJM    RDRG10,DC   IF WORD COULD NOT BE READ
          IAN    DC
          UJN    RDRGX
          SPACE  5,20
** NAME-- RDWT
*
** PURPOSE-- SET UP FOR READ OR WRITE.
*
** EXIT
*         A = 0  IF COMPLETION RESPONSE SHOULD BE PRESENT.  IT IS
*                POSSIBLE FOR A TRANSFER NOTIFICATION RESPONSE FOR A STACKED
*                COMMAND TO BE PRESENT BEFORE OR AT THE SAME TIME AS THE COMPLETION
*                RESPONSE FOR THE COMMAND IN PROGRESS.
          SPACE  2
 RDWX     LJM    **
 RDWT     EQU    *-1
          LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          PJN    RDWT10      IF NOT 2 COMMANDS IN PROGRESS
          LDML   RPB+CRN
          SHN    -14
          LMML   /SS/P.CRN,CSST
          LPN    1
          ZJN    RDWX        IF RESPONSE FOR SECOND COMMAND
          UJN    RDWT20
 RDWT10   BSS
          LDML   RPB+CRN
          SHN    -14
          LMML   /SS/P.CRN,CSST
          LPN    1
          NJN    RDWT80      IF COMMAND REFERENCE NUMBER WRONG
 RDWT20   BSS
          LDML   /SS/MT,CSST TOTAL CM WORDS LEFT TO TRANSFER
          SHN    2
          PJN    RDWT30      IF NOT USING MASTER TERMINATE
          LPN    77B
          NJK    RDWT80      IF UNEXPECTED RESPONSE
          UJN    RDWT40
 RDWT30   BSS
          ADML   /SS/P.TOTAL+1,CSST
          ZJN    RDWT80      IF UNEXPECTED RESPONSE
          LDN    0
 RDWT40   BSS
          STDL   BURPOS      SET BURST POSITION = 0
          LDML   UNITS,UX
          LPC    0#DFFF
          LMC    0#2000
          STML   UNITS,UX    SET DATA TRANSFER IN PROGRESS BIT
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,UX SET CURRENT CLOCK
          LDN    NSBS
          STDL   BBS         BURSTS TO TRANSFER BEFORE SUSPENDING
          UJK    RDWX
 RDWT80   BSS
          LJM    TERM10      REPORT UNEXPECTED RESPONSE ERROR
          SPACE  5,20
** NAME-- RDWTOK
*
** PURPOSE-- SEND RESPONSE FOR COMPLETED READ REQUEST
          SPACE  2
 RDWTX    LJM    **
 RDWTOK   EQU    *-1
          SOML   /SS/P.NCR,CSST NUMBER OF RESPONSES TO BE SENT
          RJM    PDR         PREPARE DISK RESPONSE
          RJM    SNDRSP      SEND RESPONSE TO CM
          AOML   /SS/P.NCOMRQ,CSST INCREMENT NUMBER OF COMPLETED REQUESTS
          LDML   /SS/P.CURRQ,CSST SAVE RMA OF PREVIOUS REQUEST
          STML   /SS/P.PRERQ,CSST
          LDML   /SS/P.CURRQ+1,CSST
          STML   /SS/P.PRERQ+1,CSST
          LDML   /SS/P.REQ,CSST SAVE RMA OF CURRENT REQUEST
          STML   /SS/P.CURRQ,CSST
          LDML   /SS/P.REQ+1,CSST
          STML   /SS/P.CURRQ+1,CSST
          UJK    RDWTX
          SPACE  5,20
** NAME-- RD
*
** PURPOSE-- RESERVE DRIVE.  LEAVING THE DRIVE RESERVED IS SUPPOSE
*            TO SAVE UP TO 600 MICROSECONDS PER COMMAND.
*            ALSO SET THE BURST AND INTERRUPT SIZE FOR EACH UNIT.
*            NOTE THAT NOS USES A DIFFERENT BURST SIZE THAN NOS/VE.
          SPACE  2
 RDX      LJM    **
 RD       EQU    *-1
          LDC    H0400
          STML   CP+OPCD     OPERATION CODE
          LDN    6           COMMAND PACKET LENGTH
          STML   CP
          LDML   /SS/P.UNIT,CSST
          STML   CP+SLAD     CONTROLLER, UNIT NUMBER
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          NJN    RD10        IF ERROR
          LDML   UNITS,UX    INDICATE DRIVE RESERVED
          LPC    0#F7FF
          LMC    /UN/K.RD
          STML   UNITS,UX
          RJM    IUF         IS UNIT FORMATTED
          NJN    RDX         IF UNIT NOT FORMATTED
          RJM    RA6F        READ ATTRIBUTE 6F
          STML   RPB+13      SET THE INTERRUPT AND BURST SIZE TO 2048
          STML   RPB+15
          LDC    0#800
          STML   RPB+14
          STML   RPB+16
          RJM    WA6F        WRITE ATTRIBUTE 6F
          UJK    RDX
 RD10     BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- REL
*
** PURPOSE-- READ ERROR LOG
          SPACE  2
 RELX     LJM    **
 REL      EQU    *-1
          LDN    9           COMMAND PACKET LENGTH
          STML   CP
          LDC    H8400
          STML   CP+OPCD     READ ERROR LOG COMMAND
          LDDL   CMOD
          SHN    8
          LMC    0#FF
          STML   CP+SLAD     CONTROLLER NUMBER
          LDC    0#2E0
          STML   CP+FCP
          LDC    0#100       SELECT LAST ERROR LOGGED IN EEPROM
          STML   CP+FCP+1
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          ZJN    RELX        IF NO ERROR
          LDN    E00         CP MUST DETERMINE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- RESP
*
** PURPOSE-- WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
*
** INPUT-- CM.PIT, CM.RS, LIM, /PIT/IN, /PIT/OUT, RS+/RS/P.RESPL
*
** OUTPUT-- /PIT/IN, RESPONSE BUFFER
          SPACE  2
 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  2
 RESPX    LJM    **
 RESP     EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDN    0
          STML   STORS       SET FLAG TO STORE RESPONSE
          LDML   CM+/CM/P.STOR,CSST CHECK IF CALLER WANTS RESPONSE
          SHN    /CM/L.STOR+2
          MJN    RESP10      IF STORE RESPONSE FLAG IS SET
 .U       IFEQ   UNIX,1
          LDML   RS+/RS/P.SHORT
          SHN    /RS/L.SHORT+2
          PJN    RESP10      IF NOT NORMAL RESPONSE, STORE RESPONSE
 .U       ELSE
          LDML   RS+/RS/P.RC
          SHN    /RS/N.RC+/RS/L.RC-16
          SBN    R.NRM
          NJN    RESP10      IF NOT NORMAL RESPONSE, STORE RESPONSE
 .U       ENDIF
          AOML   STORS       NONZERO MEANS DO NOT STORE RESPONSE
          UJK    RESPX

* READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RESP10   BSS
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF 'IN' POINTER
          CRDL   P1          READ 'IN' POINTER

* CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDN    0
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE
          LDDL   INP
          SBDL   OUTP
          MJN    RESP20      IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP
 RESP20   BSS
          LDML   RS+/RS/P.RESPL  GET RESPONSE LENGTH
          ADDL   INP
          STDL   INPNT       IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
 .U       IFEQ   UNIX,1
          MJN    RESP30      IF ROOM IN BUFFER
          RJM    PPRQ        CHECK FOR IDLE REQUEST
          UJK    RESP10
 RESP30   BSS
 .U       ELSE
          PJK    RESP10      IF NOT ENOUGH ROOM IN BUFFER, LOOP
 .U       ENDIF
          LDDL   INP
          SHN    -3
          STDL   T3          'IN' POINTER IN WORDS
          LDML   RS+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          LDDL   INPNT
          SBDL   LIM
          MJN    RESP50      IF IN + RESPONSE LENGTH .LT. LIMIT
                             ONLY 1 BLOCK WRITE
          STDL   INPNT       IN + RESPONSE LENGTH - LIMIT = NEW 'IN' POINTER
          SHN    -3
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE

* WRITE RESPONSE TO CM.
          LDML   RS+1
          ADML   RS+2
          ADML   RS+3
          NJN    RESP40      IF PVA FOR REQUEST IS PRESENT
          STML   RS+14       INSURE UNSOLICITED RESPONSE CODE RETURNED

 RESP40   LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADC    RS
          STML   RESP60      RESPONSE ADDRESS FOR 2ND BLOCK WRITE
 RESP50   BSS
          LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD 'IN' OFFSET
          CWML   RS,T4       WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          ZJN    RESP70      IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          LMC    400000B
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
                             (BEGINNING OF RESPONSE BUFFER)
 RESP60   EQU    *-1

 RESP70   BSS
          LJM    RESPX
          SPACE  5,20
** NAME-- RESPIN
*
** PURPOSE-- UPDATE THE 'IN' POINTER IN THE CM RESPONSE BUFFER.
*
** INPUT-- INPNT = NEW 'IN' POINTER.
          SPACE  2
 RESNX    LJM    **
 RESPIN   EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDML   STORS       CHECK IF CALLER WANTS RESPONSE
          NJK    RESNX       IF NO RESPONSE WAS SENT

* UPDATE THE 'IN' POINTER.

          LDN    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDDL   INPNT       NEW 'IN' POINTER
          STDL   P4
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   P1          WRITE NEW 'IN' POINTER TO CM

* INTERRUPT PROCESSOR. RESP ROUTINE SETS UP THIS INSTRUCTION.

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   PPNO-3      SET LAST BYTE NONZERO
 INTPRC   PSN    0           INTERRUPT OR PSN (MODIFIED)
          UJK    RESNX
          SPACE  5,20
** NAME-- RMR
*
** PURPOSE-- READ CM3 MICROCODE REVISION
          SPACE  2
 RMRX     LJM    **
 RMR      EQU    *-1
          LDN    10
          STML   CP          COMMAND PACKET LENGTH
          LDC    0#200
          STML   CP+OPCD     ATTRIBUTE COMMAND
          LDC    0#36C
          STML   CP+FCP      PARAMETER TO READ REV NUMBER
          LDC    0#4050
          STML   CP+FCP+1    RETURN REV NUMBER IN RESPONSE
          LDML   UNITS,UX
          SHN    -3
          LPN    17B
          STDL   CMOD        CONTROLLER NUMBER AND DRIVER NUMBER
          LPN    7
          SHN    8
          LMC    0#FF
          STML   CP+SLAD     SLAVE ADDRESS
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          NJN    RMR10       IF NOT SUCCESSFUL
          LDC    ID50
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    RMR10       IF ID 50 NOT FOUND
          LDML   RPB+19,T3
          LPC    377B        MASK MICROCODE REVISION NUMBER
          SHN    8
          STML   /SS/P.MREV,CSST
          LJM    RMRX
 RMR10    BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 .E       IFEQ   ERRD,1      READ RAW DATA
          SPACE  5,20
** NAME-- RRD
*
** PURPOSE-- READ RAW DATA IF DATA FIELD ECC ERROR.  IF THE ERROR
*            CODE IS 62 AND THE OP CODE IN THE RESPONSE IS 1107,
*            THE SECTOR WITH THE UNCORRECTED MEDIA ERROR HAS BEEN
*            TRANSFERRED TO CENTRAL MEMORY.
          SPACE  2
 RRDX     LJM    **
 RRD      EQU    *-1
          LDDL   T5          ENDING STATUS FROM ID26
          LPC    0#FF
          LMC    0#D1
          NJN    RRDX        IF NOT DATA FIELD ECC ERROR
          LDML   RPB+8,T3
          STML   CP+FCP+3    CYLINDER
          LDML   RPB+9,T3
          STML   CP+FCP+4    HEAD, SECTOR
          LDN    5
          STML   /SS/P.RECOV,CSST INDEX TO NEXT RECOVERY STEP
          RJM    LIR         LOGICAL INTERFACE RESET
          RJM    RCC         SETUP FOR RESTART CONTROLLER COMMANDS
          RJM    SCP         SETUP COMMAND PACKET PARAMETERS
          LDC    H1107
          STML   CP+OPCD     OPERATION CODE
          LDN    1           WRITE READ SECTORS PER BURST
          STML   CP+FCP+2    SECTOR COUNT
*
*         FIND THE CENTRAL MEMORY ADDRESS WHERE THE SECTOR WITH THE
*         MEDIA ERROR SHOULD BE STORED.
*
          RJM    UREQ        READ UNIT REQUEST FROM CM
          RJM    SETRQ       SETUP FOR 1ST REQUEST
          RJM    UNCMND      GET FIRST COMMAND
 RRD5     BSS
          LDML   /SS/P.CURTRK,CSST
          SHN    8
          ADML   /SS/P.CURSEC,CSST
          SBML   CP+FCP+4    ADDRESS OF MEDIA ERROR
          ZJN    RRD10       IF CORRECT ADDRESS
          PJK    RRDX        IF ADDRESS NOT FOUND
          RJM    UBT         UPDATE BYTES TRANSFERRED
          ZJK    RRDX        IF NO MORE COMMANDS
          RJM    UDA         UPDATE DISK ADDRESS
          UJN    RRD5

 RRD10    BSS
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJN    RRD20       IF NOT TRANSFER NOTIFICATION
          STDL   BURPOS      CLEAR BURST POSITION
          LDN    1
          STDL   BBS         BURSTS BEFORE SUSPEND
          RJM    SEL         SELECT THE CONTROLLER
          RJM    READ        READ ONE BURST
          RJM    IH          INTERRUPT HANDLER
          LPN    0#A
          NJK    RRDX        IF SUCCESSFUL OR CONDITIONAL SUCCESS
 RRD20    BSS
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 .E       ENDIF
          SPACE  5,20
** NAME-- SAVSS
*
** PURPOSE-- WRITE THE SS TABLE TO THE COMMUNICATION BUFFER
*            IN THE UNIT INTERFACE TABLE.
*
          SPACE  2
 SAVX     LJM    **
 SAVSS    EQU    *-1
          LDN    C.SS        NUMBER OF WORDS TO WRITE
          STDL   WC
          LDDL   SSUN
          SBDL   UNUML
          PJN    SAVX        IF INVALID SS TABLE
          LOADR  UNITS+/UN/P.UIT,SSUN
          ADN    /UIT/C.UBUF OFFSET OF COMMUNICATION BUFFER
          CRDL   T1          GET ADDRESS OF COMMUNICATION BUFFER
          LOADF  T3          REFORMAT IT AND LOAD R REGISTER
          CWML   SSNR,WC     WRITE NON RESIDENT SS TABLE
          UJK    SAVX
          SPACE  5,20
** NAME-- SCB
*
** PURPOSE-- SET COMMAND IN PROGRESS BITS IN (UNITS,UX) FOR ONE
*            CONTROLLER
*
** ENTRY  A = BITS TO SET
*         CMOD = CONTROLLER TO SEARCH FOR UNITS
          SPACE  2
 SCBX     LJM    **
 SCB      EQU    *-1
          STDL   P1
          LDN    0
          STDL   T1
          UJN    SCB20
 SCB10    BSS
          LDN    P.UN
          RADL   T1          UPDATE POINTER TO UNITS TABLE
 SCB20    BSS
          SBDL   UNUML
          PJN    SCBX        IF END OF CONFIGURED UNITS
          LDML   UNITS,T1
          SHN    -3
          LPN    17B
          LMDL   CMOD
          NJN    SCB10       IF DIFFERENT CONTROLLER
          LDML   UNITS,T1
          LPC    0#1FFF
          LMDL   P1
          STML   UNITS,T1    SET -2 COMMANDS IN PROGRESS-
          UJN    SCB10
          SPACE  5,20
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
          SPACE  2
 SCLX     LJM    **
 SCLOCK   EQU    *-1
 SCL30    BSS
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    SCL30       IF LOCK WAS NOT SET
          STDL   CLF         CHANNEL LOCK FLAG
          UJK    SCLX        EXIT, LOCK WAS SET
          SPACE  5,20
** NAME-- SCP
*
** PURPOSE-- SET UP COMMAND PACKET PARAMETERS FOR A WRITE
*            OR READ
          SPACE  2
 SCPX     LJM    **
 SCP      EQU    *-1
          LDN    RPL
          STML   CP          PACKET LENGTH
          AOML   /SS/P.CRN,CSST
          LPC    0#FFF1
          STML   /SS/P.CRN,CSST CLEAR CARRY BIT
          LPN    1
          SHN    14
          ADDL   UX
          STML   CP+CRN      COMMAND REFERENCE NUMBER
          LDDL   FNC
          ZJN    SCP8        IF READ
          SBN    1
          ZJN    SCP4        IF WRITE
          LDC    E501        INVALID COMMAND
          RJM    INTERR      REPORT ERROR (NO RETURN)
 SCP4     BSS
          LDC    H2005
          UJN    SCP12
 SCP8     BSS
          LDC    H1005
 SCP12    BSS
          STML   CP+OPCD     OPERATION
          LDML   /SS/P.UNIT,CSST
          STML   CP+SLAD     CONTROLLER, UNIT NUMBER
          LDC    H0931
          STML   CP+FCP      COMMAND EXTENT PARAMETER
          LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          MJN    SCP15       IF SECOND COMMAND
          LDML   /SS/MT,CSST
          UJN    SCP18
 SCP15    BSS
          LDML   /SS/MT2,CSST
 SCP18    BSS
          SHN    2
          PJN    SCP30       IF NOT USING MASTER TERMINATE
          LDN    0
          STDL   T3
          LDML   CP+FCP+4
          LPN    77B
          STDL   T1          STARTING SECTOR
          LDML   CP+FCP+4
          SHN    -8
          STDL   T2          STARTING TRACK
          LDN    SPT         SECTORS PER TRACK
          SBDL   T1
 SCP20    BSS
          RADL   T3          COMPUTE SECTORS
          AODL   T2
          SBN    MAXTR+1     TRACKS PER CYLINDER
          ZJN    SCP28       IF CALCULATION COMPLETE
          LDN    SPT         SECTORS PER TRACK
          UJN    SCP20
 SCP28    BSS
          LDDL   T3
          STML   CP+FCP+2    SECTOR COUNT
          UJK    SCPX
 SCP30    BSS
          LDC    BPS-1       ENSURE BURST BOUNDARY
          ADDL   TOTAL+1
          STDL   T1
          SHN    -16
          ADDL   TOTAL
          SHN    5
          STML   CP+FCP+2
          LDDL   T1
          SHN    -11
          RAML   CP+FCP+2    SECTOR COUNT
          UJK    SCPX
          SPACE  5,20
** NAME-- SDA
*
** PURPOSE-- SAVE DISK ADDRESS
          SPACE  2
 SDAX     LJM    **
 SDA      EQU    *-1
          LDDL   PTF
          ZJN    SDA10       IF INITIALIZATION CONFIDENCE TEST
          LDML   /SS/P.CT,CSST
          NJN    SDA20       IF NOT CONFIDENCE TEST FAILURE
 SDA10    BSS
          STML   RS+/RS/P.STRK STARTING TRACK
          STML   RS+/RS/P.SSEC STARTING SECTOR
          LDC    MAXCYL-1
          STML   RS+/RS/P.SCYL STARTING CYLINDER
          UJN    SDA30
 SDA20    BSS
          LDN    1
          STDL   T2
          LOADF  /SS/P.CURRQ,CSST RMA OF CURRENT REQUEST
          ADN    3
          CRML   RS+/RS/P.CHAN,T2 SAVE CYLINDER, TRACK, SECTOR IN RESPONSE
 SDA30    BSS
          LDML   RS+/RS/P.ERRID
          ZJN    SDA50       IF RESPONSE PACKET PRESENT
          ADC    -E60
          MJN    SDA40       IF RESPONSE PACKET NOT PRESENT
          ADC    -E110+E60
          MJN    SDA50       IF RESPONSE PACKET PRESENT
 SDA40    BSS
          LDML   /SS/P.CURTRK,CSST
          STML   RS+/RS/P.FTRK FAILING TRACK
          LDML   /SS/P.CURSEC,CSST
          UJN    SDA70
 SDA50    BSS
          LDN    ID29        DRIVE CONDITIONAL SUCCESS
          RJM    SFP         SEARCH FOR PARAMETER
          PJN    SDA60       IF ID 29 FOUND
          LDN    ID32        RESPONSE EXTENT
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    SDA40       IF ID32 NOT FOUND
 SDA60    BSS
          LDML   RPB+9,T3
          SHN    -8
          STML   RS+/RS/P.FTRK FAILING TRACK
          LDML   RPB+9,T3
          LPC    0#FF
 SDA70    BSS
          STML   RS+/RS/P.FSEC FAILING SECTOR                                                                                      F
          LJM    SDAX
          SPACE  5,20
** NAME-- SEEK
*
** PURPOSE-- ISSUE INITIAL SEEK.
          SPACE  2
 SEEKX    LJM    **
 SEEK     EQU    *-1
          LDML   UNITS,UX
          SHN    /UN/L.CIP+2
          MJN    SEEK4       IF ONE COMMAND ISSUED
          SHN    -/UN/L.CIP-2
          LPC    0#1FFF
          LMC    0#8000      INDICATE ONE COMMAND ISSUED
          UJN    SEEK8
 SEEK4    SHN    -/UN/L.CIP-2
          LPC    0#3FFF
          LMC    0#C000      INDICATE TWO COMMANDS ISSUED
 SEEK8    STML   UNITS,UX
          RJM    SCP         SETUP COMMAND PACKET PARAMETERS
          LDML   UNITS,UX
          SHN    6
          MJN    SEEK12      IF DRIVE ALREADY RESERVED
          LDN    6           COMMAND PACKET LENGTH
          STML   CP
          LDC    H0400       RESERVE DRIVE COMMAND
          STML   CP+OPCD
 SEEK12   BSS
          AODL   CMNDS       COMMAND ISSUED COUNTER
          RJM    CPT         COMMAND PACKET TRANSFER
 SEEK20   EQU    *-1         FOR FORCING ERRORS
          UJK    SEEKX
          SPACE  5,20
** NAME-- SETRQ
*
** PURPOSE-- SET UP FOR FIRST REQUEST.
          SPACE  2
 SETRQX   LJM    **
 SETRQ    EQU    *-1
          LDML   /SS/P.REQ,CSST SAVE RMA OF REQUEST
          STML   /SS/P.FCOMRQ,CSST FIRST COMPLETED REQUEST (RMA)
          STML   /SS/P.CURRQ,CSST CURRENT REQUEST (RMA)
          LDML   /SS/P.REQ+1,CSST
          STML   /SS/P.FCOMRQ+1,CSST
          STML   /SS/P.CURRQ+1,CSST
          LDN    1
          STML   /SS/P.NCOMRQ,CSST NUMBER OF COMPLETED REQUESTS
          LDML   RQ+/RQ/P.TRACK,CSST
          STML   /SS/P.CURTRK,CSST CURRENT TRACK
          LDML   RQ+/RQ/P.SECTOR,CSST
          STML   /SS/P.CURSEC,CSST CURRENT SECTOR
          LDML   RQ+/RQ/P.INT,CSST CHECK IF INTERRUPT WAS SELECTED
          SHN    /RQ/L.INT+2
          MJN    SETR10      IF INTERRUPT SELECTED
          LDC    2400B       PSN INSTRUCTION
          UJN    SETR20
 SETR10   BSS
          LDML   RQ+/RQ/P.PORT,CSST GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RQ/L.PORT+/RQ/N.PORT
          LPN    /RQ/M.PORT
          ADC    102600B     INPN INSTRUCTION
 SETR20   BSS
          STML   INTPRC
          UJK    SETRQX
          SPACE  5,20
** NAME-- SFP
*
** PURPOSE-- SEARCH FOR PARAMETER IDENTIFICATION IN RESPONSE PACKET
*
** INPUT
*         A = ID TO SEARCH FOR
** OUTPUT
*         A = POSITIVE IF ID FOUND
*         T3 = POINTER TO ID IF IT IS FOUND (RPB+5,T3)
          SPACE  2
 SFPX     LJM    **
 SFP      EQU    *-1
          STDL   T1          PARAMETER TO SEARCH FOR
          LDN    0
          STDL   T3          POINTER TO ID BEING SEARCHED FOR
          LDML   RPB
          ADN    1
          SHN    -1
          SBN    5           LENGTH OF MINIMUM RESPONSE PACKET
 SFP4     BSS
          STDL   T2          POINTER TO END OF PARAMETERS
          MJN    SFPX        EXIT, NO ID FOUND
          LDML   RPB+5,T3
          LMDL   T1
          LPC    0#FF
          ZJN    SFPX        IF ID FOUND
          LDML   RPB+5,T3
          SHN    -9
          ADN    1           ADJUST FOR ODD BYTE
          STDL   T4          WORD LENGTH OF PARAMETER
          RADL   T3          UPDATE POINTER TO ID BEING SEARCHED FOR
          LDDL   T2
          SBDL   T4
          UJN    SFP4
          SPACE  5,20
** NAME-- SFRR
*
** PURPOSE-- SETUP FOR REQUEST RETRY FOR ONE UNIT
*
** OUTPUT-- P5, T8 ARE UNCHANGED
          SPACE  2
 SFRRX    BSS
          LDN    0
          STDL   IF
          STML   /SS/P.RESET,CSST CLEAR RESET ISSUED FLAG
          LDML   UNITS,UX
          LPC    0#1FFF
          STML   UNITS,UX    CLEAR COMMAND IN PROGRESS BITS
          LJM    **
 SFRR     EQU    *-1
          RJM    GETSS       GET SS TABLE IF NECESSARY
          LDML   /SS/P.CT,CSST
          ZJN    SFRRX       IF CONFIDENCE TEST JUST RUN
          LDML   /SS/P.RESET,CSST
          NJN    SFRRX       IF SLAVE RESET IN PROGRESS
          LDML   UNITS,UX
          SHN    2
          PJN    SFRRX       IF NO COMMAND IN PROGRESS
          LDML   /SS/P.FNC,CSST
          NJN    SFRR3       IF NOT READ COMMAND
          LDML   /SS/P.NCR,CSST
          ZJN    SFRR3       IF NO RESPONSES TO SEND
          RJM    RDWTOK      SEND READ RESPONSE
 SFRR3    BSS
          LDML   /SS/P.CURRQ,CSST RESTORE RMA OF CURRENT REQUEST
          STML   /SS/P.REQ,CSST
          LDML   /SS/P.CURRQ+1,CSST
          STML   /SS/P.REQ+1,CSST
          LDML   /SS/P.FPVA,CSST RESTORE PVA OF CURRENT REQUEST
          STML   /SS/P.PVA,CSST
          LDML   /SS/P.FPVA+1,CSST
          STML   /SS/P.PVA+1,CSST
          LDML   /SS/P.FPVA+2,CSST
          STML   /SS/P.PVA+2,CSST
          LDML   UNITS,UX
          SHN    2+/UN/L.TCIP
          PJN    SFRR5       IF NOT -2 COMMANDS IN PROGRESS-
          SODL   CMNDS       OUTSTANDING COMMANDS
          LDML   UNITS,UX
          LPC    0#9FFF
          STML   UNITS,UX    CLEAR -2 COMMANDS IN PROGRESS-
 SFRR5    BSS
          LDN    0
          STML   /SS/P.NCR,CSST ZERO OUT NUMBER OF COMPLETED WRITE REQUESTS
          SOML   /SS/P.NCOMRQ,CSST NUMBER OF COMPLETED REQUESTS
          ZJN    SFRR10      IF NO STREAMED READ REQUESTS
          LDML   /SS/P.PRERQ,CSST SET UP RMA OF LAST GOOD COMPLETED REQUEST
          STML   /SS/P.CURRQ,CSST
          LDML   /SS/P.PRERQ+1,CSST
          STML   /SS/P.CURRQ+1,CSST
          RJM    DCR         DELETE COMPLETED REQUESTS FROM QUEUE
          UJN    SFRR15
 SFRR10   BSS
          SODL   CMNDS       OUTSTANDING COMMANDS
 SFRR15   BSS
          LJM    SFRRX
          SPACE  5,20
** NAME-- SFT
*
** PURPOSE-- SET FACILITY TIMEOUT TO 1/2 SECOND IF 8A OR LATER
*            MICROCODE.  THIS IS THE AMOUNT OF TIME THE CM3 WILL
*            WAIT FOR THE DRIVE TO GO NOT BUSY BEFORE REPORTING
*            AN ERROR.  WITH A TIMEOUT OF ONE HALF SECOND AND
*            VERSION 7 OR EARLIER MICROCODE,  DATA INTEGRITY
*            PROBLEMS OCCURRED.
          SPACE  2
 SFTX     LJM    **
 SFT      EQU    *-1
          RJM    RA6F        READ ATTRIBUTE 6F
          LDML   /SS/P.MREV,CSST
          SHN    -12
          SBN    8
          PJN    SFT2        IF 8A OR LATER MICROCODE
          LDML   RPB+21
          LMC    0#FFFF
          ZJK    SFTX        IF TIMEOUT ALREADY INFINITE
          LCN    0           SET TIMEOUT TO INFINITE
          STML   RPB+21
          LMN    1
          UJN    SFT5
 SFT2     BSS
          LDML   RPB+21
          LMN    7
          ZJK    SFTX        IF TIMEOUT ALREADY 1/2 SECOND
          LDN    7           SET TIMEOUT TO 1/2 SECOND
          STML   RPB+21
          LDC    0#A120
 SFT5     BSS
          STML   RPB+22
          RJM    WA6F        WRITE ATTRIBUTE 6F
          LDN    6
          STML   CP          COMMAND PACKET LENGTH
          LDC    H020A
          STML   CP+OPCD     SAVE OPERATING MODE IN EEPROM
          LDDL   CMOD
          LPN    7
          SHN    8
          LMC    0#FF
          STML   CP+SLAD     SLAVE ADDRESS
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          ZJK    SFTX        IF SUCCESSFUL
          LDN    E00         CPU MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- SNDRSP
*
** PURPOSE-- SEND THE RESPONSE TO CM.
*            USED WHEN SWITCHING TO THE NEXT REQUEST.
          SPACE  2
 SNDX     LJM    **
 SNDRSP   EQU    *-1
          RJM    RESP        SEND RESPONSE TO CM
          RJM    RESPIN      UPDATE -IN- POINTER IN RESPONSE BUFFER
          RJM    SRESP       SET UP RESPONSE BUFFER
          UJK    SNDX
          SPACE  5,20
** NAME-- SNDWRS
*
** PURPOSE-- SEND WRITE RESPONSES FOR WRITE REQUESTS THAT HAVE
*            BEEN SUCCESSFULLY STREAMED.
          SPACE  2
 SNDWX    LJM    **
 SNDWRS   EQU    *-1
          LDML   /SS/P.NCR,CSST NUMBER OF COMPLETED WRITE REQUESTS MINUS 1
          ZJN    SNDWX       IF NO COMPLETED STREAMED WRITE REQUESTS
          LDN    2
          STDL   WC
          LOADF  /SS/P.CURRQ,CSST
          CRML   NRQ,WC      READ FIRST REQUEST TO GET START OF CHAIN
 .U       IFNE   UNIX,1
          LDML   /SS/P.REQ,CSST  SET CURRQ TO END OF CHAIN SO DCR WILL
                                  DELINK ALL REQUESTS
          STML   /SS/P.CURRQ,CSST
          LDML   /SS/P.REQ+1,CSST
          STML   /SS/P.CURRQ+1,CSST
 .U       ENDIF
 SNDW10   BSS
          RJM    RESP        SEND RESPONSE TO CM
          RJM    RESPIN      UPDATE -IN- POINTER IN RESPONSE BUFFER
 .U       IFNE   UNIX,1
          LDN    0
          STML   RS+/RS/P.XFER  SET TRANSFER COUNT = 0 FOR ALL OTHER RESPONSES
          STML   RS+/RS/P.XFER+1
 .U       ENDIF
          LDML   NRQ+/RQ/P.NEXTPV  PUT PVA OF NEXT RESPONSE IN RESPONSE BUFFER
          STML   RS+/RS/P.PVA
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   RS+/RS/P.PVA+1
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   RS+/RS/P.PVA+2
 .U       IFEQ   UNIX,1
          LDML   /SS/P.CURRQ,CSST  SAVE RMA OF LAST RESPONSE RETURNED
          STML   /SS/P.PRERQ,CSST
          LDML   /SS/P.CURRQ+1,CSST
          STML   /SS/P.PRERQ+1,CSST
          LDML   NRQ+/RQ/P.NEXT  REQUESTS ARE DELINKED THROUGH CURRQ
          STML   /SS/P.CURRQ,CSST
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.CURRQ+1,CSST
 .U       ENDIF
          LOADF  NRQ+/RQ/P.NEXT  CM ADDRESS OF NEXT REQUEST
          CRML   NRQ,WC      READ NEXT REQUEST CHAIN POINTERS
          AOML   /SS/P.NCOMRQ,CSST INCREMENT NUMBER OF COMPLETED REQUESTS
                             (FOR DCR)
          SOML   /SS/P.NCR,CSST DECREMENT COUNT OF RESPONSES LEFT TO SEND
          NJK    SNDW10      IF MORE RESPONSES
          UJK    SNDWX
          SPACE  5,15
** NAME-- SNMSG
*
** PURPOSE-- SEND UNSOLICITED MESSAGE
          SPACE  2
 SNMSGX   LJM    **
 SNMSG    EQU    *-1
 .U       IFEQ   UNIX,1
          LDN    0
          STML   RS+/RS/P.SHORT  INDICATE ERROR RESPONSE
 .U       ENDIF
          LDC    RLIE
          STML   RS+/RS/P.RESPL BYTE LENGTH OF RESPONSE
          LDN    R.UNS       UNSOLICITED MESSAGE
          STML   RS+/RS/P.RC RESPONSE CODE
 .U       IFEQ   UNIX,1
          RJM    RESP        SEND RESPONSE TO CM
 .U       ELSE
          RJM    TERMP       SEND RESPONSE TO CM
 .U       ENDIF
          UJK    SNMSGX
          SPACE  5,20
** NAME-- SPLOCK
*
** PURPOSE-- SETS THE PP TABLE LOCK IN THE
*            PP INTERFACE TABLE.
          SPACE  2
 SPLX     LJM    **
 SPLOCK   EQU    *-1
 .U       IFEQ   UNIX,1
 SPLOCK4  BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDN    1
          STDL   T4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          RDSL   T1          ATTEMPT TO SET PP TABLE LOCK
          LDDL   T4
          LPN    1
          ZJK    SPLX        IF LOCK SET
          UJK    SPLOCK4
 .U       ELSE
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET THE LOCKWORD
          UJK    SPLX
 .U       ENDIF
          SPACE  5,20
** NAME-- SQLOCK
*
** PURPOSE-- SETS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
          SPACE  2
 SQLX     LJM    **
 SQLOCK   EQU    *-1
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          UJK    SQLX
          SPACE  5,20
** NAME-- SRESP
*
** PURPOSE-- SET UP STATUS FOR RESPONSE BUFFER.
          SPACE  2
 SREX     LJM    **
 SRESP    EQU    *-1
          LDML   /SS/P.PVA,CSST SAVE PVA OF REQUEST
          STML   /SS/P.FPVA,CSST
          LDML   /SS/P.PVA+1,CSST
          STML   /SS/P.FPVA+1,CSST
          LDML   /SS/P.PVA+2,CSST
          STML   /SS/P.FPVA+2,CSST
*
          LDN    0
          STML   /SS/P.XFER,CSST TRANSFER COUNT
          STML   /SS/P.XFER+1,CSST
          UJK    SREX
          SPACE  5,20
** NAME-- SRI
*
** PURPOSE-- SET RESET ISSUED FLAG FOR ALL UNITS ON CMOD.
*            IT WILL BE CLEARED WHEN AN ASYNCHRONOUS RESPONSE
*            FOR THE DRIVE IS RECEIVED.
          SPACE  2
 SRIX     BSS
          LDDL   P1
          STDL   UX          RESTORE UX
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LJM    **
 SRI      EQU    *-1
          LDDL   UX
          STML   EPCT,CMOD   SAVE TABLE ISSUING THE RESET
          STDL   P1          SAVE UX
          LDN    0
          STDL   UX          POINTER TO UNITS TABLE
          UJN    SRI10
 SRI5     BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
 SRI10    BSS
          SBDL   UNUML
          PJN    SRIX        IF END OF CONFIGURED UNITS
          LDML   UNITS,UX
          SHN    -3
          LPN    17B
          LMDL   CMOD
          NJN    SRI5        IF DIFFERENT CONTROLLER
          LDML   UNITS,UX
          LPC    0#F7FF
          STML   UNITS,UX    CLEAR DRIVE RESERVE BIT
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,UX SET CURRENT CLOCK
          LDN    3
          STML   /SS/P.RESET,CSST INDICATE RESET ISSUED
          UJK    SRI5
          SPACE  5,20
** NAME-- SR
*
** PURPOSE-- SELECT REQUEST FROM UNIT QUEUE
*
** EXIT
*         A = 0 IF REQUEST FOUND
          SPACE  2
 SRX      LJM    **
 SR       EQU    *-1
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    SRX         IF LOCK NOT SET
          LDN    2
          STDL   P5
          LDDL   CNUM
          NJK    SR50        IF ONE COMMAND ALREADY ISSUED
          LDML   /SS/P.REQ,CSST
          ADML   /SS/P.REQ+1,CSST
          NJK    SR24        IF REQUEST PRESENT
          LOADR  UNITS+/UN/P.UIT,UX LOAD CM ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.NEXTPV
          CRML   NRQ,P5      READ FIRST PVA AND RMA
          LDML   NRQ+/RQ/P.NEXT
          STML   /SS/P.REQ,CSST
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.REQ+1,CSST
          ADML   /SS/P.REQ,CSST
          NJN    SR20        IF REQUEST ON QUEUE
 SR16     BSS
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          LDN    1           NO REQUEST FOUND
          UJK    SRX
 SR20     BSS
          LDML   NRQ+/RQ/P.NEXTPV
          STML   /SS/P.PVA,CSST
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   /SS/P.PVA+1,CSST
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   /SS/P.PVA+2,CSST
 SR24     BSS
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          LDN    0           INDICATE REQUEST FOUND
          UJK    SRX
 SR50     BSS
          LDN    5
          STDL   WC
          LOADF  /SS/P.CURRQ,CSST
 SR54     BSS
          CRML   NRQ,WC      READ NEXT REQUEST
          LDML   NRQ+/RQ/P.NEXT
          STML   /SS/P.RMA2,CSST
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.RMA2+1,CSST
          ADML   /SS/P.RMA2,CSST
          NJK    SR80        IF NOT END OF QUEUE
          LOADR  UNITS+/UN/P.UIT,UX LOAD CM ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.NEXTPV
          CRML   NRQ,P5      READ FIRST PVA AND RMA
          LDML   NRQ+/RQ/P.NEXT
          STML   /SS/P.RMA2,CSST
          LMML   /SS/P.FCOMRQ,CSST
          NJN    SR75        IF REQUEST FOUND
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.RMA2+1,CSST
          LMML   /SS/P.FCOMRQ+1,CSST
          ZJK    SR16        IF NO REQUEST FOUND
 SR75     BSS
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.RMA2+1,CSST
          LDML   NRQ+/RQ/P.NEXTPV
          STML   /SS/P.PVA2,CSST
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   /SS/P.PVA2+1,CSST
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   /SS/P.PVA2+2,CSST
          UJK    SR24
 SR80     BSS
          LDML   NRQ+/RQ/P.NEXTPV
          STML   /SS/P.PVA2,CSST
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   /SS/P.PVA2+1,CSST
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   /SS/P.PVA2+2,CSST
          LDML   NRQ+/RQ/P.SWIT
          SHN    /RQ/L.SWIT+2
          PJK    SR24        IF SWITCH FLAG NOT SET
          UJK    SR16
          SPACE  5,20
** NAME-- STI
*
** PURPOSE-- SET TABLE INDEXES (UX AND CSST).  ALSO VERIFY THIS
*            IS THE CORRECT UNIT.
          SPACE  2
 STIX     LJM    **
 STI      EQU    *-1
          LDML   RPB+CRN
          LPC    777B
          STDL   UX          SET INDEX TO UNITS TABLE
          STDL   T8
          RJM    GETSS       GET SS TABLE FROM CM
          LDML   /SS/P.UNIT,CSST
          LMML   RPB+SLAD
          ZJK    STIX        IF CORRECT UNIT
          LDDL   T8
          STDL   UX          SET INDEX TO UNITS TABLE
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LJM    TERM10
          SPACE  5,20
** NAME-- TAC
*
** PURPOSE-- TERMINATE ALL COMMANDS ISSUED
          SPACE  2
 TACX     LJM    **
 TAC      EQU    *-1
          LDN    0
          STDL   CMOD        CONTROL MODULE NUMBER
          UJN    TAC15
 TAC10    BSS
          AODL   CMOD
          SBN    16
          ZJN    TACX        IF ALL COMMANDS TERMINATED
 TAC15    BSS
          LDN    0
          STDL   P5          RESET NOT ISSUED
          STDL   UX          POINTER TO UNITS TABLE
          UJN    TAC25
 TAC20    BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
 TAC25    BSS
          SBDL   UNUML
          PJN    TAC10       IF END OF CONFIGURED UNITS
          LDML   UNITS,UX
          SHN    -/UN/N.UNIT
          LPN    17B
          LMDL   CMOD
          NJN    TAC20       IF DIFFERENT CONTROL MODULE
          LOADR  UNITS+/UN/P.UIT,UX ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T1
          LDDL   T1+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJN    TAC20       IF UNIT DISABLED
          LDML   UNITS,UX
          SHN    2+/UN/L.CIP
          MJN    TAC40       IF COMMAND IN PROGRESS
          LDDL   PTF
          ZJN    TAC40       IF IN PATH TEST
          RJM    GETSS       GET SS TABLE FROM UNIT COMMUNICATIONS BUFFER
          LDML   /SS/P.CT,CSST
          NJN    TAC50       IF NOT IN CONFIDENCE TEST
 TAC40    BSS
          LDDL   P5
          NJN    TAC50       IF RESET ALREADY DONE
          RJM    LIR         LOGICAL INTERFACE RESET
          AODL   P5          RESET DONE FOR THIS CONTROLLER
 TAC50    BSS
          UJK    TAC20
          SPACE  5,20
** NAME-- TDP
*
** PURPOSE-- TEST DMA PATH
*
** EXIT-- A = 0 IF NO ERROR

          SPACE  2
 TDPX     LJM    **
 TDP      EQU    *-1

* TRANSFER FROM RECEIVERS TO CENTRAL MEMORY

          RJM    WOG         WRITE OPERAND GENERATOR, ENABLE TEST MODE
          LDN    H0009
          RJM    FUNC        SET SELECT OUT
          LDC    H0281
          RJM    FUNC        IPI TRANSFER FUNCTION (READ)
          LDC    H0C00       DMA READ
          RJM    TMT         TEST MODE TRANSFER
          LDML   EOG1,CH     EXPECTED OPERAND GENERATOR
          RJM    COG         DROP MASTER OUT, DESELECT, DISABLE TEST
                              MODE, CHECK OPERAND GENERATOR
          RJM    VTMD        VERIFY TEST MODE DATA

* TRANSFER FROM CENTRAL MEMORY TO TRANSMITTERS

          RJM    MCC         MASTER CLEAR CHANNEL.  THIS CLEARS THE LOST DATA
                              ERROR THAT OCCURS ON THE 25 MB CHANNEL WHEN ONLY
                              ONE OF 3 OPERAND GENERATOR WORDS ARE READ.
          RJM    PS          PORT SELECT
          RJM    WOG         WRITE OPERAND GENERATOR, ENABLE TEST MODE
          LDN    H0009
          RJM    FUNC        SET SELECT OUT
          LDC    H0381       IPI TRANSFER FUNCTION (WRITE)
          RJM    FUNC
          LDC    H0D00       DMA WRITE
          RJM    TMT         TEST MODE TRANSFER
          LDML   EOG2,CH     EXPECTED OPERAND GENERATOR
          RJM    COG         DROP MASTER OUT, DESELECT, DISABLE TEST
                              MODE, CHECK OPERAND GENERATOR
          UJK    TDPX
          SPACE  5,20
** NAME-- TERM
*
** PURPOSE-- TERMINATE UNIT REQUEST.
          SPACE  2
 TERM     CON    0           NORMAL TERMINATION
          LDML   /SS/P.FNC,CSST
          SBN    4
          NJN    TERM2       IF NOT FORMAT COMMAND
          LDN    E58         FORMAT COMPLETE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDML   UNITS,UX
          SHN    -3
          LPN    17B
          STML   RS+/RS/P.UNIT  PORT, CONTROLLER, DRIVE ADDRESS
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          LDN    0
          STML   FIP         CLEAR FORMAT IN PROGRESS
          STML   /SS/P.CT,CSST  ENABLE RUNNING CONFIDENCE TEST
          UJK    TERM20
 TERM2    LDML   /SS/MT,CSST MAKE SURE ALL BYTES WERE TRANSFERRED
          SHN    2
          PJN    TERM3       IF NOT USING MASTER TERMINATE
          LDML   /SS/P.LISTL,CSST
          UJN    TERM6
 TERM3    BSS
          SHN    -2
          ADML   /SS/P.TOTAL+1,CSST
          ADML   /SS/P.LISTL,CSST
 TERM6    BSS
          ADML   /SS/P.NUMCM,CSST
          ZJN    TERM20      IF TERMINATION IS OK
 TERM10   BSS
          LDK    E76         UNEXPECTED RESPONSE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 TERM20   BSS
          STML   /SS/P.RQTRY,CSST CLEAR RETRY COUNT
          RJM    PDR         PREPARE NORMAL DISK RESPONSE
          RJM    SNDWRS      SEND WRITE RESPONSES
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    DCR         DELETE COMPLETED REQUEST FROM QUEUE
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
          LJM    MAIN20
          SPACE  5,20
** NAME-- TERMP
*
** PURPOSE-- TERMINATE PP REQUEST.
          SPACE  2
 TERX     LJM    **
 TERMP    EQU    *-1
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    RESPIN      UPDATE 'IN' POINTER FOR RESPONSE BUFFER
          UJK    TERX
          SPACE  5,20
** NAME-- UBT
*
** PURPOSE-- UPDATE BYTES TRANSFERRED
*
** EXIT--  T2 = 0 IF CHECK FOR REQUEST SWITCH IS NECESSARY
          SPACE  2
 UBTX     BSS
          STDL   T2
          LJM    **
 UBT      EQU    *-1
          LDDL   BC          CM BYTES TRANSFERRED
          RAML   /SS/P.XFER+1,CSST UPDATE BYTES TRANSFERRED
          SHN    -16
          RAML   /SS/P.XFER,CSST
          LDDL   BC
          RAML   CMLIST+/CM/P.RMA+1,CSST UPDATE CM ADDRESS
          SHN    -16
          RAML   CMLIST+/CM/P.RMA,CSST
          LDML   CMLIST+/CM/P.LEN,CSST UPDATE BYTES LEFT TO TRANSFER
          SBDL   BC
          STML   CMLIST+/CM/P.LEN,CSST
          NJN    UBT10       IF MORE BYTES LEFT TO TRANSFER TO THIS
                             CM ADDRESS
          SOML   /SS/P.LISTL,CSST DECREMENT ADDRESS-LENGTH-PAIR COUNT
          ZJN    UBT20       IF END OF RMA LIST
          RJM    GLIST       READ NEXT SECTION OF THE LIST WHICH POINTS
                             TO THE CM DATA AREA
 UBT10    BSS
          LDN    1           INDICATE NO REQUEST SWITCH
          UJN    UBTX
 UBT20    BSS
          RJM    UNCMND      GET NEXT COMMAND
          ZJN    UBTX        IF NO MORE COMMANDS
          UJN    UBT10
          SPACE  5,20
** NAME-- UC
*
** PURPOSE-- UPDATE CLOCK.  THE CLOCK IS USED TO TIMEOUT COMMANDS
*            ISSUED TO THE CONTROL MODULE.
          SPACE  2
 UCX      LJM    **
 UC       EQU    *-1
          LDDL   CLCUR
          STDL   P6          SAVE CURRENT CLOCK
          IAN    14B
          STDL   CLCUR
          SBDL   P6
          PJN    UC5         IF CLOCK HASNT WRAPPED
          ADC    10000B
 UC5      BSS
          RADL   CLMCS       UPDATE MICROSECOND PORTION OF CLOCK
          LDDL   CLMCS
          ADC    -2000
          MJN    UCX         IF LESS THAN 2 MILLISECONDS
          STDL   CLMCS
          LDN    2
          RADL   CLMLS       UPDATE MILLISECOND PORTION OF CLOCK
          ADC    -1000
          MJN    UCX         IF LESS THAN 1 SECOND
          STDL   CLMLS
          AODL   CLSEC       UPDATE SECOND PORTION OF CLOCK
          UJN    UCX
          SPACE  5,20
** NAME-- UDA
*
** PURPOSE-- UPDATE DISK ADDRESS. THIS ALLOWS THE PP TO VERIFY THAT
*            A STREAMED REQUEST IS FOR THE NEXT SEQUENTIAL DISK SECTOR.
          SPACE  2
 UDAX     LJM    **
 UDA      EQU    *-1
          AOML   /SS/P.CURSEC,CSST INCREMENT SECTOR
          SBN    SPT
          MJN    UDAX        IF SAME TRACK
          STML   /SS/P.CURSEC,CSST
          AOML   /SS/P.CURTRK,CSST INCREMENT TRACK
          UJN    UDAX
          SPACE  5,20
** NAME-- UNCMND
*
** PURPOSE-- GET NEXT COMMAND FROM CM.  SET UP CMLIST AND LISTL
*            IN THE SS TABLE.  SET FNC AS THE INDEX TO A TABLE OF
*            COMMANDS FROM CM.
*
** EXIT-- A REGISTER = 0, IF NO MORE COMMANDS.
          SPACE  2
 UNCX     LJM    **
 UNCMND   EQU    *-1
          LDML   /SS/P.NUMCM,CSST
          ZJN    UNCX        IF NO MORE COMMANDS
          SOML   /SS/P.NUMCM,CSST  DECREMENT COMMAND COUNT
          LDML   /SS/P.FRST,CSST HAS FIRST COMMAND BEEN PROCESSED
          ZJN    UNC10       IF FIRST COMMAND HASN'T BEEN PROCESSED

*         READ NEXT COMMAND FROM CM.

          LDDL   CSST        ADDRESS OF SS TABLE
          ADK    CM
          STML   UNC4        ADDRESS TO STORE COMMAND
          AOML   /SS/P.LASTC,CSST INCREMENT OFFSET OF LAST COMMAND
          LDN    C.CM
          STDL   WC
          LOADF  /SS/P.REQ,CSST LOAD CM ADDRESS AND REFORMAT
          ADML   /SS/P.LASTC,CSST ADD OFFSET OF COMMAND
          CRML   *,WC       READ COMMAND FROM CM
 UNC4     EQU    *-1

*         IF INDIRECT ADDRESS, READ CM ADDRESS LIST.

 UNC10    BSS
          LDML   CM+/CM/P.LEN,CSST MAKE SURE IT IS AN EVEN NUMBER OF CM WORDS
          ADN    7
          SCN    7
          STML   CM+/CM/P.LEN,CSST
          STML   CMLIST+/CM/P.LEN,CSST
          SHN    -3
          STML   /SS/P.LISTL,CSST LENGTH OF CM ADDRESS AREA  (CM WORDS)
          LDML   CM+/CM/P.INDIR,CSST
          SHN    /CM/L.INDIR+2
          MJN    UNC15       IF INDIRECT ADDRESS
          LDN    1
          STML   /SS/P.LISTL,CSST IF NOT INDIRECT, ONLY 1 COMMAND.
          LDML   CM+/CM/P.RMA,CSST
          STML   CMLIST+/CM/P.RMA,CSST
          LDML   CM+/CM/P.RMA+1,CSST
          STML   CMLIST+/CM/P.RMA+1,CSST
          UJN    UNC20

 UNC15    BSS
          RJM    GLIST       GET CM ADDRESS LIST OF DATA AREA
 UNC20    BSS
          LDN    0
          STDL   FNC         SET UP INTERNAL FUNCTION CODE
 UNC30    LDML   CM+/CM/P.CODE,CSST GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          ERRNZ  /CM/L.CODE
          LMML   UCMD,FNC    COMPARE COMMAND CODE
          ZJN    UNC40       IF COMMAND FOUND
          AODL   FNC
          SBN    UCMDL
          MJN    UNC30       IF MORE COMMANDS TO CHECK
 UNC35    BSS
          LDC    E501        ERROR IN COMMAND CODE
          RJM    INTERR      REPORT ERROR (NO RETURN)
 UNC40    BSS
          LDML   /SS/P.FRST,CSST
          ZJN    UNC60       IF FIRST COMMAND
          LDDL   FNC
          LMML   /SS/P.FNC,CSST FUNCTION CODE
          ZJN    UNC70       IF SAME AS LAST COMMAND
          UJN    UNC35
 UNC60    BSS
          LDDL   FNC
          STML   /SS/P.FNC,CSST SAVE COMMAND CODE
 UNC70    BSS
          AOML   /SS/P.FRST,CSST SET FIRST COMMAND FLAG NONZERO
          UJK    UNCX        EXIT A REGISTER NONZERO
          SPACE  5,20
** NAME-- UREQ
*
** PURPOSE-- READ A UNIT REQUEST FROM CM.
*
* INPUT--
*         CSST = POINTER TO SS TABLE
*
** OUTPUT-- RQ  CONTAINS CURRENT REQUEST.
*           FRST = 0
*           NUMCM = NUMBER OF COMMANDS.
          SPACE  2
 UREQX    LJM    **
 UREQ     EQU    *-1
          LDN    0
          STML   /SS/P.FRST,CSST SET FLAG WHEN REQUEST IS READ
          LDN    3           NUMBER OF WORDS TO READ
          STDL   WC
          LDDL   CSST        ADDRESS OF SS TABLE
          ADK    RQ          LOCATION OF REQUEST IN SS TABLE
          STML   UREQ8       ADDRESS TO PUT REQUEST
          ADN    8
          STML   UREQ4       ADDRESS TO PUT REQUEST
          LOADF  /SS/P.REQ,CSST LOAD CM REQUEST ADDRESS
          ADN    2
*
*         THE CP SAVES THE RMA BEFORE IT SETS THE STREAM BIT.  READING
*         THE STREAM BIT FIRST GUARANTEES THE RMA IS CORRECT WHEN THE
*         STREAM BIT IS SET.
*
          CRML   *,WC        READ CURRENT REQUEST
 UREQ4    EQU    *-1
          SBN    5
          CRML   *,WC        READ CURRENT REQUEST
 UREQ8    EQU    *-1
          LDML   RQ+/RQ/P.LEN,CSST DETERMINE NUMBER OF COMMANDS
          SHN    -3
          SBN    /RQ/C.CMND
          STML   /SS/P.NUMCM,CSST NUMBER OF COMMANDS
          LDN    /RQ/C.CMND
          STML   /SS/P.LASTC,CSST OFFSET OF COMMAND
          UJK    UREQX
          SPACE  5,20
** NAME-- VCTD
*
** PURPOSE-- VERIFY CONFIDENCE TEST DATA
          SPACE  2
 VCTDX    LJM    **
 VCTD     EQU    *-1
          LDN    0
          STDL   P1
          LDML   /SS/P.CURTRK,CSST
          SHN    8
          ADML   /SS/P.CURSEC,CSST
          STDL   P2          PUT CURRENT TRACK, SECTOR IN ONE WORD
          LDDL   CSST
          STDL   P3
 VCTD5    BSS
          LDML   CTME,P3     ADDRESS IN TABLE
          LMDL   P2          CURRENT ADDRESS
          ZJK    VCTDX       IF SECTOR NOT WRITTEN
          AODL   P3
          AODL   P1
          LMN    3
          NJN    VCTD5       IF MORE TABLE LOCATIONS TO CHECK
          LDC    WPS         64-BIT WORDS PER SECTOR
          STDL   P3
          LDC    SPT*MAXTR+SPT SECTORS PER CYLINDER
          SBML   STT,CSST    SECTOR NUMBER
          SHN    2
          ADDL   CTPAT       CONFIDENCE TEST PATTERN FIRST WORD MINUS ONE
          STDL   P1          STARTING DATA PATTERN VALUE MINUS ONE
          LOADC  CM.CB       ADDRESS OF PP COMMUNICATIONS BUFFER
          STDL   P2
 VCTD10   BSS
          LDDL   P2
          LMC    400000B
          CRDL   T4          READ WORD OF SECTOR
          AODL   P1
          SBDL   T4
          NJN    VCTD20      IF DATA MISCOMPARE
          AODL   P1
          SBDL   T5
          NJN    VCTD20      IF DATA MISCOMPARE
          AODL   P1
          SBDL   T6
          NJN    VCTD20      IF DATA MISCOMPARE
          AODL   P1
          SBDL   T7
          NJN    VCTD20      IF DATA MISCOMPARE
          AODL   P2          INDEX TO WORD TO READ
          SODL   P3
          NJN    VCTD10      IF MORE WORDS TO VERIFY
          LJM    VCTDX
 VCTD20   BSS
          LDK    E111        CM-DRIVE DATA INTEGRITY
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDN    4
          STML   /SS/P.CT,CSST INDICATE DATA INTEGRITY ERROR
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- VPTD
*
** PURPOSE-- VERIFY PATH TEST DATA
          SPACE  2
 VPTDX    LJM    **
 VPTD     EQU    *-1
          LDN    0
          STDL   T1          INDEX TO BUFFER
 VPTD4    BSS
          LDML   IB,T1       WORD FROM INPUT BUFFER
          LMML   OB,T1       WORD FROM OUTPUT BUFFER
          NJN    VPTD10      IF ERROR
          AODL   T1
          SBN    50
          ZJN    VPTDX       IF VERIFY OK
          UJN    VPTD4       MORE WORDS TO CHECK
 VPTD10   BSS
          LDK    E110        PP-CM3 DATA INTEGRITY
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- VTMD
*
** PURPOSE-- VERIFY TEST MODE DATA.  DATA GENERATED FROM A
*            TEST MODE READ IS CHECKSUMMED AND COMPARED
*            AGAINST THE CORRECT VALUE.
          SPACE  2
 VTMDX    LJM    **
 VTMD     EQU    *-1
          LDN    25
          STDL   P1          CM WORDS TO TRANSFER
          LOADC  CM.CB
          CRML   RPB+32,P1   READ TEST MODE PATTERN
          LDN    0
          STDL   P2
          STDL   P3
          LDC    100         PP WORDS TO CHECKSUM
          STDL   P1
 VTMD10   BSS
          LDML   RPB+31,P1
          RADL   P2
          SHN    -16
          RADL   P3
          SODL   P1
          NJN    VTMD10      IF MORE WORDS TO CHECKSUM
          LDDL   P2
          LMML   EC1,CH
          NJN    VTMD20      IF ERROR
          LDDL   P3
          LMML   EC2,CH
          ZJK    VTMDX       IF NO ERROR
 VTMD20   BSS
          LDN    E18         DMA TEST MODE FAILURE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- WA6F
*
** PURPOSE-- WRITE ATTRIBUTE PARAMETER 6F
*
** ENTRY  CP+SLAD MUST BE SET
*
** EXIT   TO CALLING PROGRAM IF NO ERROR
          SPACE  2
 WA6FX    LJM    **
 WA6F     EQU    *-1
          LDN    0#2E
          STML   CP          COMMAND PACKET LENGTH
          LDC    H0209
          STML   CP+OPCD     LOAD ATTRIBUTE COMMAND
 WA6F10   BSS
          LDML   RPB+5,T1    MOVE COMMAND PACKET
          STML   CP+4,T1
          AODL   T1
          LMN    20
          NJN    WA6F10
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          ZJN    WA6FX       IF NO ERROR
          LDN    E00         CP MUST DETERMINE THE ERROR COD
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          TITLE  IPI CHANNEL SUBROUTINES
** NAME-- BCS
*
** PURPOSE-- PERFORM BUS CONTROL SEQUENCE
*
** INPUT
*         A = BUS A BITS 7,6 IN BITS 1,0 OF ACCUMULATOR
*             BIT 7 = 1 IF DATA ELSE RESPONSE OR COMMAND
*             BIT 6 = 1 IF INFORMATION IN
          SPACE  2
 BCSX     LJM    **
 BCS      EQU    *-1
          SHN    14
          ADC    H005B
          RJM    FUNC        SET SYNC OUT
          ACN    DC
          LDN    77B
 BCS4     FJM    BCS8,DC     IF SYNC IN
          SBN    1
          NJN    BCS4        IF TIMEOUT NOT EXPIRED
          LDN    E22         NO SYNC IN
          UJN    BCS20
 BCS8     IAN    DC
          STDL   STATUS      SAVE BUS ACKNOWLEDGE STATUS
          SFM    BCS25,DC    IF ERROR FLAG SET
          LPC    0#FF
          NJN    BCS16       IF BUS ACKNOWLEDGE IS WRONG
          LDDL   LF          LAST FUNCTION
          LMN    0#32
          RJM    FUNC        DROP SYNC OUT
          ACN    DC
          LDN    77B
 BCS12    FJM    BCSX,DC     IF SYNC IN DROPPED
          SBN    1
          NJN    BCS12       IF TIMEOUT NOT EXPIRED
          LDN    E23         SYNC IN DID NOT DROP
          UJN    BCS20
 BCS16    BSS
          LDN    E37         BUS ACKNOWLEDGE WRONG
 BCS20    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 BCS25    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,15
** NAME-- CPT
*
** PURPOSE-- COMMAND PACKET TRANSFER
*
** INPUT
*         CP - STARTING ADDRESS OF COMMAND PACKET
          SPACE  2
 CPT30    BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT THE CONTROL MODULE
          LDDL   WC
          ZJN    CPTX        IF ALL WORDS TRANSFERRED
          LDN    E29         INCOMPLETE TRANSFER
          UJN    CPT10
 CPTX     LJM    **
 CPT      EQU    *-1
          RJM    SEL         SELECT THE CONTROLLER
          LDN    CMDOUT      BUS A FOR COMMAND
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0381       STREAM, WRITE
          RJM    FUNC        RAISE MASTER OUT
          ACN    DC
          LDML   CP
          ADN    3
          SHN    -1          CONVERT BYTE COUNT TO WORD COUNT
          OAM    CP,DC       SEND COMMAND PACKET
          STDL   WC          WORDS NOT TRANSFERRED
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,UX SET CURRENT CLOCK
          LDC    MS50
 CPT4     IJM    CPT30,DC    IF SLAVE IN DROPPED
          SBN    1
          NJN    CPT4        IF TIMEOUT NOT EXPIRED
          LDN    E30         CHANNEL STAYED ACTIVE
 CPT10    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,15
** NAME-- DCM
*
** PURPOSE-- DESELECT THE CONTROL MODULE
          SPACE  2
 DCM10    CFM    DCMX,DC     IF ERROR FLAG NOT SET

*         ON A 25 MB CHANNEL A DESELECT SEQUENCE COULD CAUSE
*         A SEQUENCE ERROR.  THIS CODE CHANGE TO CLEAR ERROR
*         STATUS WAS DONE INSTEAD OF A HARDWARE FIX.

          LDC    H0100
          RJM    FUNC        CLEAR THE DMA ERROR
 DCMX     LJM    **
 DCM      EQU    *-1
          LDC    H0071
          RJM    FUNC        DROP SELECT OUT
          ACN    DC
          LDN    77B
 DCM4     FJM    DCM10,DC    IF SLAVE IN DROPPED
          SBN    1
          NJN    DCM4        IF TIMEOUT NOT EXPIRED
          LDN    E28         SLAVE IN DID NOT DROP
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- DCN
*
** PURPOSE-- DISCONNECT THE CHANNEL
          SPACE  2
 DCNX     BSS
          DCN    DC+40B      DISCONNECT THE CHANNEL
          LJM    **
 DCN      EQU    *-1
          STDL   WC          WORDS NOT TRANSFERRED
          SFM    DCN10,DC    IF ERROR FLAG SET
          ZJN    DCN20       IF ALL WORDS TRANSFERRED
          LDN    E07
          UJN    DCN40
 DCN10    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 DCN20    BSS
          EJM    DCNX,DC     IF CHANNEL EMPTY
          LDN    E08         CHANNEL NOT EMPTY
 DCN40    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- DCT
*
** PURPOSE-- DETERMINE CHANNEL TYPE
*
** EXIT   CH = 0 IF 10 MB CHANNEL
*              1 IF 25 MB CHANNEL
          SPACE  2
 DCTX     BSS
          STDL   CH
          LJM    **
 DCT      EQU    *-1
          LDC    H0102
          RJM    FUNC        READ IPI REVISION REGISTER
          ACN    DC
          LDN    0
          EJM    DCTX,DC     IF 10 MB/S IPI CHANNEL
          LDN    1
          UJN    DCTX
          SPACE  5,15
** NAME-- DTM
*
** PURPOSE-- DETERMINE TRANSFER MODE
*
** OUTPUT
*         STATUS - TRANSFER SETTINGS, BIT 4 = 1 IF DATA STREAMING
*         CTM - USED TO CHANGE TRANSFER MODE WHEN SELECTING
          SPACE  2
 DTM30    CFM    DTMX,DC     IF ERROR FLAG NOT SET

*         ON A 25 MB CHANNEL A REQUEST TRANSFER SETTINGS SEQUENCE
*         COULD CAUSE A SEQUENCE ERROR.  THIS CODE CHANGE TO
*         CLEAR ERROR STATUS WAS DONE INSTEAD OF A HARDWARE FIX.

          LDC    H0100
          RJM    FUNC        CLEAR THE DMA ERROR
 DTMX     LJM    **
 DTM      EQU    *-1
          RJM    PS          PORT SELECT
          LDDL   CMOD        CONTROL MODULE NUMBER
          LPN    7
          SHN    12
          ADC    H8025
          RJM    FUNC        REQUEST TRANSFER SETTINGS
          ACN    DC
          LDN    77B
 DTM4     FJM    DTM8,DC     IF SLAVE IN
          SBN    1
          NJN    DTM4        IF TIMEOUT NOT EXPIRED
          LDN    E27         NO SLAVE IN
          UJN    DTM16
 DTM8     IAN    DC
          STDL   STATUS      SAVE TRANSFER SETTING
          SFM    DTM20,DC    IF ERROR FLAG SET
          LPN    0#10
          LMN    0#10
          SHN    7
          STDL   CTM         CHANGE TRANSFER MODE BIT
          LDDL   LF          LAST FUNCTION ISSUED
          LMC    0#54        CODE 7, DROP MASTER OUT
          RJM    FUNC        DROP MASTER OUT
          ACN    DC
          LDN    77B
 DTM12    FJM    DTM30,DC    IF SLAVE IN DROPPED
          SBN    1
          NJN    DTM12       IF TIMEOUT NOT EXPIRED
          LDN    E28         SLAVE IN DID NOT DROP
 DTM16    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 DTM20    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- EI
*
** PURPOSE-- ENABLE INTERRUPT FROM CM3.  SINCE IT TAKES UP TO
*            20 MICROSECONDS FOR THE CM3 TO PUT ITS INTERRUPT
*            ON THE BUS, THE ENABLE IS DONE HERE AND THE READ
*            IS DONE IN GETUD
          SPACE  2
 EIX      LJM    **
 EI       EQU    *-1
          LDDL   UNUML
          ZJN    EIX         IF NO UNITS
          LDC    H0062       SELECT PORT A
          RJM    FAN
          LDC    H0715
          RJM    FAN         REQUEST CLASS 1, 2, OR 3 INTERRUPT
          UJN    EIX
          SPACE  5,20
** NAME-- FAN
*
** PURPOSE-- SEND A FUNCTION TO THE IPI CHANNEL, BUT DONT
*            PUT THE FUNCTION IN THE FUNCTION HISTORY TABLE
          SPACE  2
 FANX     LJM    **
 FAN      EQU    *-1
          DCN    DC+40B      ENSURE THE CHANNEL IS INACTIVE
                              THE CHANNEL MAY HAVE BEEN LEFT ACTIVE
                              BY A MASTER CLEAR, A ROUTINE SUCH AS DCM
                              OR AFTER A REPORTED ERROR.
          FAN    DC          SEND THE FUNCTION
          UJN    FANX
          SPACE  5,20
** NAME-- FUNC
*
** PURPOSE-- ISSUE FUNCTION TO IPI CHANNEL
*
** INPUT-- A REGISTER = FUNCTION CODE.
          SPACE  2
 FUNX     LJM    **
 FUNC     EQU    *-1
          DCN    DC+40B      ENSURE CHANNEL IS INACTIVE
                              THE CHANNEL MAY HAVE BEEN LEFT ACTIVE
                              BY A MASTER CLEAR, A ROUTINE SUCH AS DCM
                              OR AFTER A REPORTED ERROR.
          FAN    DC          ISSUE THE FUNCTION
          STDL   LF          SAVE FUNCTION CODE
 .F       IFEQ   FHT,1       FUNCTION HISTORY TABLE
          STML   FBUF,FI     SAVE HISTORY OF FUNCTIONS ISSUED
          AODL   FI          INCREMENT FUNCTION BUFFER INDEX
          ADC    -FBUFL
          NJN    FUN4        IF NOT END OF BUFFER
          STDL   FI          INITIALIZE INDEX
 FUN4     BSS
 .F       ENDIF
          IJM    FUNX,DC     EXIT IF CHANNEL INACTIVE
          LDN    E01         FUNCTION TIMEOUT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- GES
*
** PURPOSE-- GET ENDING STATUS
*
** ENTRY
*         A = 0000  DO ENDING STATUS WITHOUT MASTER TERMINATE
*             000A  DO ENDING STATUS WITH MASTER TERMINATE
*
** OUTPUT
*         RETURNS TO CALLING PROGRAM IF STATUS IS READ WITHOUT ERROR
*         AND SUCCESSFUL IS SET IN STATUS
          SPACE  2
 GESX     LJM    **
 GES      EQU    *-1
          SHN    8
          ADC    H8039       INDICATE SUCCESSFUL IN BUS A
          RJM    FUNC        DROP MASTER OUT
          ACN    DC
          LDC    1024
 GES4     FJM    GES8,DC     IF SLAVE IN SET
          SBN    1
          NJN    GES4        IF TIMEOUT NOT EXPIRED
          LDN    E27         SLAVE IN NOT SET
          UJK    GES30
 GES8     IAN    DC
          STDL   STATUS      SAVE ENDING STATUS
          SFM    GES40,DC    IF ERROR FLAG SET
          SHN    17-7
          MJN    GESX        IF SUCCESSFUL
          LDDL   STATUS
          SHN    11
          PJN    GES15       IF NOT BUS PARITY
          LDK    E34
          UJK    GES30
 GES15    BSS
          LDDL   STATUS
          LPN    17B
          ZJK    GES25       IF REPORTING -ENDING STATUS WRONG-
          SBN    1
          NJN    GES18       IF NOT BUS CONTROL REJECTED
          LDDL   TBC
          ZJK    GES25       IF REPORTING -ENDING STATUS WRONG-
          LDN    0
          STDL   TBC         INDICATE NOT EXPECTING 01 STATUS
          RJM    DCM         DESELECT CONTROL MODULE
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    GES16       IF CLOCK HASNT WRAPPED
          ADC    0#10000
 GES16    BSS
          SBN    42          COMMAND TIMEOUT OF APPROXIAMTELY 42 SECONDS
          PJN    GES24       IF TIMEOUT
          LJM    MAIN15      TRANSFER NOTIFICATION OCCURRED BEFORE
                              THE COMPLETION RESPONSE, WAIT FOR
                              THE COMPLETION RESPONSE
 GES18    BSS
          SBN    8
          NJN    GES20       IF NOT -SYNC OUTS NOT EQUAL SYNC INS-
          LDK    E36
          UJN    GES30
 GES20    BSS
          PJN    GES23       IF NOT COMMAND REJECT
          ADN    6
          NJN    GES21       IF NOT CLASS 3 RESPONSE PRESENT
          RJM    RPT         READ RESPONSE PACKET
*         LDN    E00         RESPONSE MUST BE EVALUATED TO DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 GES21    BSS
          LDK    E35
          UJN    GES30
 GES23    BSS
          SBN    2
          NJN    GES25       IF NOT INTERNAL CONTROLLER ERROR
          LDK    E70
          UJN    GES30
 GES24    BSS
          LDN    E38         NO CONTROLLER RESPONSE
          UJN    GES30
 GES25    BSS
          LDN    E39         ENDING STATUS WRONG
 GES30    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 GES40    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- IR
*
** PURPOSE-- ISSUE INTERFACE RESET TO CM3
*
** ENTRY
*         A = 8215  FOR LOGICAL INTERFACE RESET
*             8415  FOR SLAVE RESET
*         CMOD = CONTROL MODULE NUMBER
          SPACE  2
 IRX      LJM    **
 IR       EQU    *-1
          STDL   P2
          RJM    MCC         MASTER CLEAR CHANNEL
          RJM    PS          PORT SELECT
          LDDL   CMOD        CONTROL MODULE NUMBER
          LPN    7
          SHN    12
          ADDL   P2
          RJM    FUNC        SET MASTER OUT
          PAUSE  20
          LDDL   LF          LAST FUNCTION ISSUED
          LMN    2
          RJM    FUNC        SET SYNC OUT
          PAUSE  10
          LDDL   LF
          LMN    2
          RJM    FUNC        DROP SYNC OUT
          LDDL   LF
          LMN    4
          RJM    FUNC        DROP MASTER OUT
          UJK    IRX
          SPACE  5,20
** NAME-- MCC
*
** PURPOSE-- MASTER CLEAR CHANNEL
          SPACE  2
 MCCX     LJM    **
 MCC      EQU    *-1
          LDN    H0000       MASTER CLEAR CHANNEL
          RJM    FUNC
          PAUSE  100         ALLOW CONTROLLER TIME TO DROP LINES
          SFM    MCC10,DC    CLEAR ERROR FLAG (MASTER CLEAR DOES NOT CLEAR ERROR
 MCC10    BSS                 FLAG ON THE 25 MB CHANNEL
          LDN    H0000       MASTER CLEAR CHANNEL
          RJM    FUNC         IN CASE SEQUENCE ERROR OCCURRED
          RJM    DCT         DETERMINE CHANNEL TYPE
          LDC    H7E42
          RJM    FUNC        SET IPI CHANNEL TRANSFER RATE
          UJN    MCCX
          SPACE  5,20
** NAME-- MR
*
** PURPOSE-- MASTER RESET ALL SLAVES ON THE CHANNEL
          SPACE  2
 MRX      LJM    **
 MR       EQU    *-1
          RJM    MCC         MASTER CLEAR CHANNEL
          LDN    1
          STDL   T2
 MR10     BSS
          LDC    H9213
          RJM    FUNC        BUS A, SET SYNC OUT
          PAUSE  10          MUST DELAY 10 MICROSECONDS MINIMUM
          LDC    H9211
          RJM    FUNC        DROP SYNC OUT
          SODL   T2
          MJN    MRX         IF BOTH PORTS RESET
          LDC    H0862       SELECT PORT B
          RJM    FUNC
          UJN    MR10
          SPACE  5,20
** NAME-- PS
*
** PURPOSE-- PORT SELECT.  SELECT PORT A OR B OF IPI CHANNEL
          SPACE  2
 PSX      LJM    **
 PS       EQU    *-1
          LDML   UNITS,UX
          SHN    11
          PJN    PS5         IF PORT A
          LDC    H0862       PORT B SELECT
          UJN    PS10
 PS5      BSS
          LDC    H0062       PORT A SELECT
 PS10     BSS
          RJM    FUNC
          UJN    PSX
          SPACE  5,20
** NAME--RI
*
** PURPOSE-- REQUEST INTERRUPTS FROM THE CM3
*
** OUTPUT
*         STATUS - CONTAINS BIT SIGNIFICANT ADDRESS OF CM3 WITH INTERRUPT
          SPACE  2
 RIX      LJM    **
 RI       EQU    *-1
 .U       IFEQ   UNIX,1
          RJM    PPRQ        CHECK FOR IDLE REQUEST
 .U       ENDIF
          LDC    H0715       REQUEST CLASS 1, 2, OR 3 INTERRUPT
          RJM    FUNC        BUS A, MASTER OUT
          PAUSE  20          DELAY
          ACN    DC
          EJM    RI5,DC      IF ERROR
          IAN    DC
          STDL   STATUS      SAVE BIT SIGNIFICANT ADDRESS
          LDC    H0711
          RJM    FUNC        DROP MASTER OUT
          CFM    RIX,DC      IF ERROR FLAG NOT SET
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 RI5      BSS
          LDN    E02         CHANNEL EMPTY WHEN ACTIVATED
          RJM    PCER        PREPARE COMMAND ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- RPT
*
** PURPOSE-- RESPONSE PACKET TRANSFER
*
** OUTPUT
*         RPB - STARTING LOCATION OF RESPONSE PACKET
*         (A) = 0
          SPACE  2
 RPT20    BSS
          STDL   WC          SAVE WORDS NOT TRANSFERRED
 RPT30    BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          LDDL   WC
          ZJN    RPTX        IF ALL WORDS TRANSFERRED
          LDN    E29         INCOMPLETE TRANSFER
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 RPTX     LJM    **
 RPT      EQU    *-1
          LDN    RSPIN       BUS A FOR RESPONSE
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0281       STREAM, READ
          RJM    FUNC        SET MASTER OUT
          ACN    DC
          LDN    5
          IAM    RPB,DC      INPUT REQUIRED WORDS
 RPT2     BSS
          NJN    RPT20       IF NOT ALL WORDS RECEIVED
          STDL   TBC         DO NOT EXPECT 01 ENDING STATUS
          LDML   RPB         BYTE COUNT MINUS 2
          ADN    3
          SHN    -1
          SBN    5
          ZJN    RPT4        IF ALL WORDS TRANSFERRED
          ADC    6-RPBL
          PJN    RPT2A       IF RESPONSE TOO LONG
          ADC    RPBL-6      INPUT EXACT LENGTH
          UJN    RPT3
 RPT2A    BSS
          LDC    RPBL-6
 RPT3     BSS
          IAM    RPB+5,DC    INPUT REMAINING WORDS
          NJN    RPT2        IF NOT ALL WORDS TRANSFERRED
 RPT4     BSS
          STDL   WC          WORDS NOT TRANSFERRED
          LDC    MS50
 RPT8     BSS
          IJM    RPT30,DC    IF SLAVE IN DROPPED
          SBN    1
          NJN    RPT8        IF TIMEOUT NOT EXPIRED
          LDN    E30         CHANNEL STAYED ACTIVE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- SEL
*
** PURPOSE-- SELECT THE CONTROL MODULE AND VERIFY THE BIT SIGNIFICANT
*            RESPONSE
*
** INPUT
*         CMOD - CONTROL MODULE NUMBER
*         CTM - CHANGE TRANSFER MODE IF BIT 3 SET
*
** OUTPUT-- A = 0 IF NO ERROR
          SPACE  2
 SELX     LJM    **
 SEL      EQU    *-1
          RJM    PS          PORT SELECT
          LDDL   CMOD
          LPN    7
          SHN    12
          ADDL   CTM         CHANGE TRANSFR MODE MODIFIER
          ADN    H0029
          RJM    FUNC        SET SELECT OUT
          ACN    DC
          LDN    77B
 SEL4     FJM    SEL8,DC     IF SLAVE IN
          SBN    1
          NJN    SEL4        IF TIMEOUT NOT EXPIRED
          LDN    E20         CANT SELECT CM3
          UJN    SEL15
 SEL8     IAN    DC
          STDL   STATUS      SAVE BIT SIGNIFICANT RESPONSE
          LPC    377B
          LMML   SELT,CMOD
          ZJK    SELX        IF BIT SIGNIFICANT RESPONSE CORRECT
          LDN    E21         BIT SIGNIFICANT RESPONSE WRONG
 SEL15    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 SELT     BSS
          DATA   1,2,4,8     CONTROL MODULES ON PORT A
          DATA   16,32,64,128
          DATA   1,2,4,8     CONTROL MODULES ON PORT B
          DATA   16,32,64,128
          SPACE  5,20
** NAME-- SIS
*
** PURPOSE-- SAVE INTERRUPT STATUS
          SPACE  2
 SISX     LJM    **
 SIS      EQU    *-1
          PAUSE  1           ALLOW CM3 TIME TO PUT ITS ADDRESS
                              ON THE BUS
          AJM    SIS10,DC    IF NO FUNCTION REPLY
          ACN    DC+40B
          EJM    SIS10,DC    IF CHANNEL NOT FULL
          IAN    DC
 SIS10    BSS
          STDL   STATUS
          LDC    H0711
          RJM    FAN         DROP MASTER OUT
          LDC    H0862
          RJM    FAN         PORT B SELECT
          LDC    H0715
          RJM    FAN         REQUEST CLASS 1, 2, OR 3 INTERRTUP
          PAUSE  17          ALLOW CM3 TIME TO PUT ITS ADDRESS ON THE
                              BUS IF IT HAS AN INTERRUPT
          AJM    SIS20,DC    IF NO FUNCTION REPLY
          ACN    DC+40B
          EJM    SIS20,DC    IF CHANNEL NOT FULL
          IAN    DC
 SIS20    BSS
          STDL   STATUS+1
          LDC    H0711       DROP MASTER OUT
          RJM    FAN
          UJK    SISX
          SPACE  5,20
** NAME-- TMT
*
** PURPOSE-- TEST MODE TRANSFER
*
** ENTRY
*         A = 0C00 FOR DMA READ
*             0D00 FOR DMA WRITE
          SPACE  2
 TMTX     LJM    **
 TMT      EQU    *-1
          RJM    FUNC
          LDC    200
          STDL   T8          T8 CONTROLS THE TIMEOUT
          STML   CM.CB.T     BYTE COUNT
          ACN    DC
          LDN    3
          OAM    CM.CB.T,DC  BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
 TMT10    BSS
          LDC    H0700       READ OPERATIONAL STATUS
          RJM    FUNC
          ACN    DC
          EJM    TMT20,DC    IF ERROR
          IAN    DC
          STDL   OS          SAVE OPERATIONAL STATUS
          SFM    TMT40,DC    IF ERROR FLAG SET
          LPN    1
          ZJN    TMTX        IF TRANSFER COMPLETE
          SODL   T8
          NJN    TMT10       IF TIMEOUT NOT EXPIRED
          LDC    H0A00       READ T REGISTER
          RJM    RDRG        READ REGISTER
          SHN    -1
          STDL   WC          SAVE WORD COUNT
          LDC    H0800       DMA TERMINATE
          RJM    FAN
          LDC    H00E1       READ STATUS REGISTER
          RJM    RDRG        READ REGISTER
          STDL   STATUS      SAVE CONTENTS OF STATUS REGISTER
          LDN    E29         INCOMPLETE TRANSFER
          UJN    TMT30
 TMT20    BSS
          LDN    E02         CHANNEL EMPTY WHEN ACTIVATED
 TMT30    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 TMT40    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- WR
*
** PURPOSE-- WRITE REGISTER
*
** ENTRY--  A = VALUE FOR REGISTER
*          T2 = WRITE REGISTER FUNCTION
          SPACE  2
 WRX      LJM    **
 WR       EQU    *-1
          STDL   T1
          LDDL   T2          WRITE REGISTER FUNCTION
          RJM    FUNC
          ACN    DC
          LDN    1           OUTPUT ONE WORD
          OAM    T1,DC
          RJM    DCN         DISCONNECT THE CHANNEL
          UJN    WRX
          SPACE  5,20
** NAME-- WFTC
*
** PURPOSE-- WAIT FOR TRANSFER COMPLETE
*
** EXIT-- TO CALLING ROUTINE WITH
*          A = 1 IF TRANSFER COMPLETE
*          A = 0 IF ERROR AND RESPONSE PACKET MUST BE READ FOR STATUS
          SPACE  2
 WFTC100  BSS
          STDL   BURPOS      BURST POSITION = 0
          SODL   BBS         BURSTS BEFORE SUSPENDING
          LDML   /SS/MT,CSST
          SHN    2
          MJN    WFTC110     IF USING MASTER TERMINATE
          LDN    0           NO MASTER TERMINATE
          UJN    WFTC120
 WFTC110  BSS
          SHN    -2
          LPN    77B
 WFTC120  BSS
          RJM    GES         GET ENDING STATUS
          LDN    1
 WFTCX    LJM    **
 WFTC     EQU    *-1
          LDC    6400
          STDL   T8          T8 CONTROLS THE TIMEOUT
          LDML   /SS/MT,CSST
          SHN    2
          PJK    WFTC11      IF NOT USING MASTER TERMINATE
          LDDL   T2
          NJK    WFTC11      IF NOT LAST SECTOR OF REQUEST
          LOADF  /SS/P.REQ,CSST
          ADN    3
          CRDL   T4          READ STREAM BIT IN REQUEST
          LDDL   T4
          SHN    2
          MJN    WFTC7       IF CONCATENATED REQEST
          AODL   T2          INDICATE NO REQUEST SWITCH
          LDC    0#800A
          STML   /SS/MT,CSST INDICATE THIS IS THE LAST SECTOR
          UJN    WFTC11
 WFTC7    BSS
          LDN    2
          STDL   T1          WORDS TO READ
          LDDL   CSST
          ADK    RQ
          STML   WFTC9       ADDRESS TO SAVE RMA AND PVA
          LDDL   CMADR+2
          LMC    400000B
          CRML   *,T1        REREAD RMA AND PVA
 WFTC9    EQU    *-1
 WFTC11   BSS
          LDC    H0700
          RJM    FUNC        READ OPERATIONAL STATUS
          ACN    DC
          EJM    WFTC40,DC   IF ERROR
          IAN    DC
          STDL   OS          SAVE OPERATIONAL STATUS
          LPN    1
          ZJK    WFTC100     IF TRANSFER COMPLETE
          SODL   T8
          NJN    WFTC11      IF TIMEOUT NOT EXPIRED
          LDC    H0A00       READ T REGISTER
          RJM    RDRG        READ REGISTER
          SHN    -1
          STDL   WC          SAVE WORD COUNT
          LDC    H0800       DMA TERMINATE FUNCTION
          RJM    FAN         SEND THE FUNCTION
          LDC    H00E1       READ STATUS REGISTER FUNCTION
          RJM    RDRG        READ REGISTER
          STDL   STATUS
          SHN    6
          PJN    WFTC30      IF SLAVE IN DROPPED
          LDN    E30         SLAVE IN DID NOT DROP
          UJN    WFTC45
 WFTC30   BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          LDDL   STATUS
          LPN    60B
          LMN    20B
          ZJN    WFTC60      IF NO MORE DATA
          LDN    E29         INCOMPLETE TRANSFER
          UJN    WFTC45
 WFTC40   BSS
          LDN    E02         CHANNEL EMPTY WHEN ACTIVATED
 WFTC45   BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 WFTC60   BSS
*
*         AFTER THE CM3 HAS PAUSED A TRANSFER, IT MAY SEND TRANSFER
*         NOTIFICATION, THEN DROP SLAVE IN IMMEDIATELY AND RETURN 90
*         HEX AS ENDING STATUS.  THIS INDICATES COMMAND COMPLETE.
*         THE RESPONSE PACKET SHOULD REPORT AN ERROR.  WITH THE 10 MB
*         CHANNEL SLAVE IN DROPS BEFORE THE PP TRANSFERS A WORD, SO
*         THE ERROR FLAG DOES NOT SET.  WITH THE 25 MB CHANNEL, THE
*         ERROR FLAG MAY SET BECAUSE THE TIME BETWEEN RAISING MASTER
*         OUT AND BEING ABLE TO SEND DATA IS MUCH FASTER.
*
          LCN    0
          STML   /SS/P.LISTL,CSST TO GUARANTEE AN ERROR IS REPORTED
          AOML   WFTCC       ERROR COUNTER
          RJM    DCM         DESELECT THE CONTROL MODULE
          LDN    0
          LJM    WFTCX
 WFTCC    CON    0           ERROR COUNTER
          SPACE  5,20
** NAME-- WFTE
*
** PURPOSE-- WAIT FOR T PRIME REGISTER EMPTY
*
** EXIT - TO CALLING ROUTINE IF T PRIME REGISTER GOES EMPTY,
*         ELSE REPORT AN ERROR
          SPACE  2
 WFTEX    LJM    **
 WFTE     EQU    *-1
          LDC    6666
          STDL   T8          T8 CONTROLS THE TIMEOUT
 WFTE10   BSS
          LDC    H0700
          RJM    FUNC        READ OPERATIONAL STATUS
          ACN    DC
          EJM    WFTE40,DC   IF ERROR
          IAN    DC
          STDL   OS          SAVE OPERATIONAL STATUS
          LPN    2
          NJN    WFTEX       IF T PRIME REGISTER EMPTY
          SODL   T8
          NJN    WFTE10      IF TIMEOUT NOT EXPIRED
          AOML   WFTEC       ERROR COUNTER
          LDC    H0A00       READ T REGISTER
          RJM    RDRG        READ REGISTER
          SHN    -1
          STDL   WC          SAVE WORD COUNT
          LDC    H0800       DMA TERMINATE FUNCTION
          RJM    FAN         SEND THE FUNCTION
          LDC    H00E1       READ STATUS REGISTER FUNCTION
          RJM    RDRG        READ REGISTER
          STDL   STATUS
          SHN    6
          PJN    WFTE30      IF SLAVE IN DROPPED
          LDN    E30         SLAVE IN DID NOT DROP
          UJN    WFTE45
 WFTE30   BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          LDN    E29         INCOMPLETE TRANSFER
          UJN    WFTE45
 WFTE40   BSS
          LDN    E02         CHANNEL EMPTY WHEN ACTIVATED
 WFTE45   BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 WFTEC    CON    0           ERROR COUNTER
          SPACE  5,20
** NAME-- WOG
*
** PURPOSE-- WRITE OPERAND GENERATOR.  THIS DETERMINES THE NUMBER OF
*            WORDS TO TRANSFER.  FOR READS TO CM IT DETERMINES THE DATA
*            PATTERN AND FOR WRITES IT SETS THE STARTING VALUE FOR ITS
*            CRC CHECK OF THE DATA.
          SPACE  2
 WOGX     LJM    **
 WOG      EQU    *-1
          LDML   WOR,CH
          RJM    FUNC
 WOG10    EQU    *-1         FOR FORCING ERRORS
          LDML   TMWC,CH     TEST MODE WORD COUNT
          STML   WOGP+1
          ACN    DC
          LDN    2
          OAM    WOGP,DC     SEND THE PARAMETERS
          RJM    DCN         DISCONNECT THE CHANNEL
          LDML   ETMF,CH
          STDL   T2          WRITE REGISTER FUNCTION
          LDML   ETMP,CH     ENABLE TEST MODE
          RJM    WR          WRITE REGISTER
          UJN    WOGX
 WOGP     BSS
          DATA   0#1357      STARTING PATTERN
          DATA   0           STREAM 100 PP WORDS (MODIFIED)
          SPACE  2,6
 CONCH    BSS                DISK CHANNEL REFERENCES
 TDC+40B  HERE
 T40B+DC  HERE
 TDC      HERE
          CON    0           END OF TABLE
          TITLE  INITIALIZATION
** NAME-- INIT
*
** PURPOSE-- INITIALIZE THE DRIVER
          SPACE  2
 INITX    LJM    **
 INIT     EQU    *-1
          LDK    EOM-CP      LENGTH OF BUFFERS
          STDL   T1
 INIT4    BSS
          LDN    0
          STML   CP-1,T1     ZERO OUT BUFFERS
          SODL   T1
          NJN    INIT4
          STDL   UX          INITIALIZE DIRECT CELLS
          STDL   LUX
          STML   FIP
          STDL   MALET
          STDL   P4
          STDL   P5
          STDL   P6
          STDL   PTF         PATH TEST
          LDN    C.PIT
          STDL   WC
          LOADC  CM.PIT      LOAD CM ADDRESS OF PP INTERFACE TABLE
          CRML   IPIT,WC     READ PP INTERFACE TABLE
          LDML   IPIT+/PIT/P.PPNO  GET PP NUMBER
          STDL   PPNO
          REFAD  IPIT+/PIT/P.RSBUF,CM.RS  REFORMAT CM ADDRESS OF RESPONSE
                                          BUFFER AND SAVE IN CM.RS
          LDML   IPIT+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STDL   LIM
          REFAD  IPIT+/PIT/P.INT,CM.INT  REFORMAT CM ADDRESS OF INTERRUPT
                                         WORD AND SAVE IN CM.INT
          REFAD  IPIT+/PIT/P.CHAN,CM.CHAN  REFORMAT CM ADDRESS OF
                                           CHANNEL TABLE AND SAVE IN CM.CHAN
          REFAD  IPIT+/PIT/P.CBUF,CM.CB  REFORMAT ADDRESS OF COMMUNICATION
                                         BUFFER AND SAVE IN CM.CB
          LDN    /CB/C.BUF
          RAML   CM.CB+2     DISPLACEMENT TO READ/WRITE BUFFER
          LDK    /CB/P.BUF*2 ADD BYTE DISPLACEMENT FOR READ/WRITE BUFFER
          ADML   IPIT+/PIT/P.CBUF+1
          STML   CM.CB.T+2
          SHN    -16
          ADML   IPIT+/PIT/P.CBUF
          STML   CM.CB.T+1 PP COMM. BUFFER IN T REGISTER FORMAT
          LDML   IPIT+/PIT/P.CBUFL  GET LENGTH OF COMMUNICATION BUFFER
          ADC    -P.CB*2
          PJN    INIT8       IF COMMUNICATION BUFFER LONG ENOUGH
          LDC    E20B
          RJM    INTERR      REPORT ERROR (NO RETURN)

* INITIALIZE UNITS AND SS TABLES

 INIT8    BSS
          LDML   IPIT+/PIT/P.UNITC NUMBER OF UNIT DESCRIPTIORS
          SHN    1
          STDL   T8          LENGTH OF UNIT DESCRIPTOR (CM WORDS)
          ZJK    INIT30      IF NO UNIT DESCRIPTORS
 INIT10   BSS
          LDN    C.UD        READ 2 CM WORDS
          STDL   WC
          LOADC  CM.PIT
          ADN    C.PIT
          ADDL   P6          INDEX TO UNIT DESCRIPTORS
          CRML   IBUF,WC     READ UNIT DESCRIPTOR
          LDML   IBUF+/UD/P.UQT  RMA = 0 IF NULL ENTRY
          ADML   IBUF+/UD/P.UQT+1
          ZJK    INIT25      IF NULL ENTRY

          LDN    C.UIT
          STDL   WC
          LOADF  IBUF+/UD/P.UQT  REFORMAT RMA OF UNIT INTERFACE TABLE
                                 AND SAVE IN UNITS TABLE
          STML   UNITS+/UN/P.UIT+2,UX
          CRML   UBUF,WC     READ UNIT INTERFACE TABLE
          LDDL   CMADR
          STML   UNITS+/UN/P.UIT,UX
          STML   SS+/SS/P.DP,P4 INITIALIZE DELINK POINTER
          LDDL   CMADR+1
          STML   UNITS+/UN/P.UIT+1,UX
          STML   SS+/SS/P.DP+1,P4
          LDDL   CMADR+2
          ADN    4
          STML   SS+/SS/P.DP+2,P4
          LDML   UBUF+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJK    INIT25      IF UNIT DISABLED
          LDML   UBUF+/UIT/P.UTYPE  CHECK DEVICE TYPE
          ADC    -410B       CHECK FOR 9853
          ZJN    INIT12      IF 9853
          LDC    E306        INVALID UNIT TYPE
          RJM    INTERR      REPORT ERROR (NO RETURN)
 INIT12   BSS
          LDML   IBUF+/UD/P.CHAN  GET CHANNEL FROM UNIT DESCRIPTOR
          STDL   T2
          SHN    /UD/L.CHAN+/UD/N.CHAN+2
          LPN    77B
          STDL   CHAN        CHANNEL NUMBER

          LDML   IBUF+/UD/P.UNIT
          LPN    7
          STML   SS+/SS/P.UNIT,P4
          STML   UNITS,UX
          LDDL   T2          CONTROLLER NUMBER
          LPN    7
          STDL   T1
          SHN    8
          RAML   SS+/SS/P.UNIT,P4  PUT UNIT IN SS TABLE
          LDDL   T1
          SHN    /UN/N.UNIT
          RAML   UNITS,UX    PUT UNIT IN UNITS TABLE
          LDDL   T2          PORT NUMBER
          LPC    100B
          RAML   UNITS,UX    PUT PORT IN UNITS TABLE
          LDML   IBUF+/UD/P.LU  PUT LOGICAL UNIT IN SS TABLE
          STML   SS+/SS/P.LU,P4
          LDC    RS-SS-P.SS-P.SS
          SBDL   P4
          MJN    INIT15      IF NO ROOM FOR A RESIDENT TABLE
          LDC    SS
          ADDL   P4
          STML   UNITS+1,UX  POINTER FROM UNITS TABLE TO SS TABLE
          LDC    P.SS
          RADL   P4          INCREMENT TO NEXT RESIDENT SS TABLE
          UJN    INIT20
 INIT15   LDML   UBUF+/UIT/P.UBUFL  NUMBER OF 8-BIT BYTES IN COMMUNICATION BUFFER
          SHN    -3          NUMBER OF CM WORDS
          SBN    C.SS        MUST BE LARGER THAN SS ENTRY
          PJN    INIT18      IF BUFFER LARGE ENOUGH
          LDC    E308
          RJM    INTERR      REPORT ERROR (NO RETURN)
 INIT18   BSS
          LDN    C.SS
          STDL   WC
          LOADF  UBUF+/UIT/P.UBUF  LOAD ADDRESS OF COMMUNICATION BUFFER
          CWML   SSNR,WC       WRITE SS ENTRY TO COMMUNICATION BUFFER

* BUMP TO NEXT ENTRY.

 INIT20   BSS
          AODL   P5          NUMBER OF CONFIGURED UNITS
          LDN    P.UN
          RADL   UX          BUMP CONFIGURED UNIT INDEX
 INIT25   BSS
          LDN    C.UD
          RADL   P6          BUMP TO NEXT UNIT DESCRIPTOR ENTRY
          SBDL   T8          CHECK FOR END OF UNIT DESCRIPTORS
          ZJN    INIT30      IF NO MORE UNIT DESCRIPTORS
          LDDL   P5
          ADC    -UNUM
          NJK    INIT10      IF 64 OR LESS UNITS
          LDC    E208        TOO MANY CONFIGURED UNITS
          RJM    INTERR      REPORT ERROR (NO RETURN)
 INIT30   LDDL   UX
          STDL   UNUML       END OF ACTIVE UNIT TABLE
          STDL   SSUN        INVALIDATE TABLE AT SSNR
          RJM    CHGCH       SET CHANNEL INSTRUCTIONS
          LJM    INITX
          SPACE  5,20
 SAVAX    LJM    **
 SAVAD    EQU    *-1
          STML   2,T2
          LDDL   CMADR
          STI    T2
          LDDL   CMADR+1
          STML   1,T2
          UJK    SAVAX
          SPACE  5,20
 CP       BSS    24          COMMAND PACKET FOR CM3
 STORS    BSS    1           STORE RESPONSE FLAG (USED BY RESPIN)
                               = 0, IF A RESPONSE IS SENT TO CM
                               = NONZERO, IF NO RESPONSE WAS SENT TO CM
 .F       IFEQ   FHT,1       FUNCTION HISTORY TABLE
 FBUF     BSS    16          FUNCTION HISTORY BUFFER
 FBUFL    EQU    *-FBUF      LENGTH OF FUNCTION BUFFER
 .F       ENDIF
          SPACE  2
 UNUM     EQU    64          SUPPORT 64 UNITS
 UNITS    BSS    UNUM*P.UN   RMA OF UNIT INTERFACE TABLE
 SS       BSS    P.SS        INFORMATION SAVED IN UNIT COMMUNICATION BUFFER
 NSS      EQU    RS-SS
 NSST     EQU    NSS/P.SS    NUMBER OF SS TABLES
 RSST     EQU    NSST-1
 RSSTL    EQU    RSST*P.SS
 SSNR     EQU    SS+RSSTL    CHANGEABLE SS TABLE
          ERRMI  NSST-1      IF NO ROOM FOR SS TABLES
*
*         THE LAST CARD IN THE DECK MUST BE /EOR SO THAT COMS CAN
*         ASSEMBLE MULTIPLE DECKS.
*
          END
/EOR
*DECK DECK=IOM$E5P5831 EXPAND=TRUE
          IDENT  E5P5831
          CIPPU
          MEMSEL 16
          TITLE  E5P5831 NOS/VE HPS DISK DRIVER FOR S0
*
*         WORD 6 OF THE FOLLOWING COMMENT MUST BE A REVISION NUMBER
*         FOR CTI.
*
          COMMENT *SMD* LVL=02
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
*
*         THIS IS THE PP DRIVER FOR THE 10 MB/S IPI CHANNEL THAT SUPPORTS
*         THE 5830 DISK SUBSYSTEM ON A CYBER 930 SYSTEM. THE DRIVER SUPPORTS
*         THE FOLLOWING LOGICAL UNITS, 5832_1, 5832_2, 5833_1, 5833_1P, 5833_2,
*         5833_3P, 5833_4, 5838_1, 5838_1P, 5838_2, 5838_3P, 5838_4, 47444_1,
*         47444_1P, 47444_2, 47444_3P, AND 47444_4.
*         THE PROGRAM NAME IS E5P5831 AND THE DECK NAME IS IOM$E5P5831. WHEN
*         THE PP DRIVER IS  LOADED, LOCATIONS 72 AND 73 MUST CONTAIN THE RMA
*         OF THE PP INTERFACE TABLE AND LOCATION 0 MUST BE THE ADDRESS, MINUS
*         ONE, AT WHICH EXECUTION IS TO BEGIN.
*         THE FOLLOWING LOGICAL UNITS, 5833_1, 5833_1P, 5833_2, 5833_3P,
*         5833_4, 5832_1, AND 5832_2.  THE PROGRAM NAME IS E5P5831 AND THE
*         DECK NAME IS IOM$E5P5831.  WHEN THE PP DRIVER IS LOADED, LOCATIONS
*         72 AND 73 MUST CONTAIN THE RMA OF THE PP INTERFACE TABLE AND
*         LOCATION 0 MUST BE THE ADDRESS, MINUS ONE, AT WHICH EXECUTION BEGINS.
*
          LIST   -$
* BEGIN IODMAC1
          SPACE  5
** THE FOLLOWING SET OF MACROS PROVIDE A MEANS OF AIDING THE PP COMPASS
** PROGRAMMER IN MAKING REFERENCES TO CYBIL STRUCTURES.  A PARALLEL DEF-
** INITION DECK IS CREATED TO MATCH THE CYBIL DECLARATIONS.  THIS DECK IS
** INPUT TO PP ASSEMBLIES WHICH REFERENCE THE STRUCTURES.
** REFERENCES TO FIELDS OF A RECORD ARE MADE ACCORDING TO THE FOLLOWING
**
**   1.ALL FIELD NAMES ARE QUALIFIED BY THE RECORD NAME.
**      B.RECORD=BYTE LENGTH OF RECORD
**      P.RECORD=LENGTH OF RECORD IN PP WORDS
**      C.RECORD=LENGTH OF RECORD IN CP WORDS
**
**   2.FIELD DEFINITIONS PRODUCE A SET OF SYMBOLS FOR CODE REFERENCE...
**      /RECORD/C.FIELD=CP WORD OFFSET OF FIELD WITHIN RECORD
**      /RECORD/P.FIELD=PP WORD OFFSET OF FIELD WITHIN RECORD
**      /RECORD/L.FIELD=LEFTMOST BIT OF FIELD IN FIRST PP WORD (0=2**15)
**                      IN UNPACKED RECORDS, FIELDS NOT DESCRIBED AS
**                      MULTIPLES OF BYTES ARE ASSUMED TO BE RIGHT ALIGNED
**                      WITHIN AN INTEGRAL NUMBER OF BYTES.  GARBAGE IS
**                      ASSUMED IN THE LEFT (UNUSED) BIT POSITIONS.
**      /RECORD/N.FIELD=NUMBER OF BITS IN THE FIELD (INCLUDING UNUSED BITS
**                      IN JUSTIFIED FIELDS).
**      /RECORD/B.FIELD=BYTE COUNT OF FIELD.
          SPACE  5
** RECORD DEFINITION MACRO
** NAME IS NAME WITH WHICH THE REFERENCES TO THE FIELDS OF THE RECORD
** MUST BE QUALIFIED.  PACKING IS *PACKED* OR OTHER TO INDICATE THE
** ATTRIBUTE OF THE CYBIL RECORD DEFINITION.
          SPACE  3
          MACRO  RECORD,NAME,PACKING
          QUAL   NAME
BITC      SET    0
PACKED    SET    0
          IFC    EQ,*PACKING*PACKED*,1
PACKED    SET    1
          ENDM
          SPACE  5
** RECEND MACRO
** DEFINE THE END OF A RECORD
          SPACE  3
          MACRO  RECEND,NAME
          QUAL
B.NAME    SET    /NAME/BITC+7
B.NAME    SET    B.NAME/8
P.NAME    SET    B.NAME+1
P.NAME    SET    P.NAME/2
C.NAME    SET    P.NAME+3
C.NAME    SET    C.NAME/4
          ENDM
          SPACE  5
** FIELD DEFINITION MACRO
** THIS MACRO DEFINES A FIELD WITHIN A RECORD IN TERMS OF ITS STARTING
** PP WORD NUMBER, LEFTMOST BIT WITHIN THE PP WORD, NUMBER OF BITS IN
** THE FIELD, AND NUMBER OF BYTES IN THE FIELD.
** NAME-NAME OF FIELD FOR QUALIFIED REFERENCES
** LENGTH-NUMBER OF BITS IN FIELD
          SPACE  3
          MACRO  FIELD,NAME,LENGTH
*PP WORD OFFSET
P.NAME    SET    BITC/16

* CP WORD OFFSET
C.NAME    SET    BITC/64

* LEFTMOST BIT IN WORD 0 (0 FROM LEFTMOST, 15=RIGHTMOST)
L.NAME    SET    BITC-P.NAME*16

* BIT LENGTH
N.NAME    SET    LENGTH

* BYTE COUNT
B.NAME    SET    LENGTH+7
B.NAME    SET    B.NAME/8

* INCREMENT BIT COUNTER
BITC      SET    BITC+N.NAME
          ENDM
          SPACE  5
** LOG2 MACRO
** THIS IS A SUPPORT MACRO TO ASSIST IN DETERMINING SUBRANGE STORAGE
** REQUIREMENTS.  THE PARAMETER IS THE VALUE WHICH MUST BE SIZED.
** THE BIT COUNT REQUIRED TO REPRESENT THE PARAMETER VALUE IS RETURNED
** IN ASSEMBLY VARIABLE LOG2$.
          SPACE  3
LOG2      MACRO  N
          LOCAL  J
LOG2$     SET    1
J         SET    N/2
          DUP    32
          IFGT   J,0,2
LOG2$     SET    LOG2$+1
J         SET    J/2
          ENDD
          ENDM
          SPACE  5
** MGEN MACRO
** THIS IS A SUPPORT MACRO FOR THE LOAD/STORE MACROS
** THE LENGTH PARAMETER IS THE LENGTH OF A FIELD OF RJ BITS IN A
** 16 BIT WORD.  THE VALUE OF MASK$ UPON EXIT FROM THE MACRO IS
** A 16 BIT MASK TO ZERO FILL THE RIGHT JUSTIFIED BIT PATTERN.
          SPACE  3
MGEN      MACRO  LENGTH
MASK$     SET    0
          DUP    LENGTH
MASK$     SET    MASK$+MASK$+1
          ENDD
          ENDM
          SPACE  5
** ALIGN MACRO
** MACRO TO ALIGN THE CURRENT BIT COUNTER TO BE *OFFSET* MOD *MODULUS*
** EXAMPLE ALIGN 0,8 FORCES BYTE BOUNDARY.
          SPACE  3
ALIGN     MACRO  OFFSET,MODULUS
          LOCAL M

* VERIFY PARAMETERS
          IFGE   OFFSET,MODULUS,1
M         ERR                      MODULUS MUST EXCEED OFFSET
          IFLE   MODULUS,0,1
M         ERR                      MODULUS MUST EXCEED 0

M         SET    BITC+MODULUS-OFFSET-1
M         SET    M/MODULUS*MODULUS
BITC      SET    M+OFFSET
          ENDM
          SPACE  5
** INTEGER MACRO
** THIS MACRO DEFINES THE NAMED FIELD AS A CYBIL INTEGER
          SPACE  3
          MACRO  INTEGER,NAME
          ALIGN  0,8
NAME      FIELD  64
          ENDM
          SPACE  5
** CHARACTER MACRO
** THIS MACRO DEFINES THE NAMED FIELD AS AN EIGHT BIT CHARACTER
          SPACE  3
          MACRO  CHARC,NAME
          IFEQ   PACKED,0,1
          ALIGN  0,8               BYTE ALIGNED IF UNPACKED
NAME      FIELD  8
          ENDM
          SPACE  5
** ORDINAL MACRO
** THIS MACRO DEFINES THE NAMED FIELD AS AN ORDINAL OF RANGE 0..N
          SPACE  3
          MACRO  ORDINAL,NAME,N
          LOCAL Q
Q         SET    N-1
NAME      SUBRANGE 0,Q
          ENDM
          SPACE  5
** BOOLEAN MACRO
** THIS MACRO DEFINES THE NAMED FIELD AS A BOOLEAN VALUE
          SPACE  3
          MACRO  BOOLEAN,NAME
PK        IFEQ   PACKED,1
* PACKED RECORD
NAME      FIELD  1
PK        ELSE
* NOT PACKED, FORCE BYTE BOUNDARY THEN RIGHT ALIGNMENT
          ALIGN  0,8
          ALIGN  7,8
NAME      FIELD  1
PK        ENDIF
          ENDM
          SPACE  5
** STRING MACRO
** THIS MACRO GENERATES A STRING OF SPECIFIED LENGTH
          SPACE  3
          MACRO  STRING,NAME,LENGTH
          ALIGN  0,8               STRINGS ARE ALWAYS BYTE ALIGNED
NAME      FIELD  LENGTH*8
          ENDM
          SPACE  5
** STRUCT MACRO
** THIS MACRO IS USED WHEN A STRUCTURE (BYTE ALIGNED) AND OF SPECIFIED
** BYTE LENGTH IS EMBEDDED IN A RECORD.
          SPACE  3
          MACRO  STRUCT,NAME,LENGTH
          ALIGN  0,8
NAME      FIELD  LENGTH*8
          ENDM
          SPACE  5
** SUBRANGE MACRO
** THIS MACRO DEFINES THE NAMED FIELD AS A SUBRANGE OF A..B
          SPACE  3
          MACRO  SUBRANGE,NAME,A,B
          LOCAL Q
PK        IFEQ   PACKED,1
* PACKED RECORD
ANEGP     IFLT   A,0
Q         SET    -A
          IFLE   Q,B,1
Q         SET    B+1
          LOG2   Q
Q         SET    LOG2$+1
ANEGP     ELSE
          LOG2   B
Q         SET    LOG2$
ANEGP     ENDIF

NAME      FIELD  Q
PK        ELSE

* UNPACKED RECORD
          ALIGN  0,8
ANEGU     IFLT   A,0
* NEGATIVE LOWER BOUNT REQUIRES 8 BYTES
NAME      FIELD  64
ANEGU     ELSE

* USE UPPER BOUND
          LOG2   B
Q         SET    LOG2$+7
Q         SET    Q/8*8
NAME      FIELD  Q
ANEGU     ENDIF

PK        ENDIF
          ENDM
          SPACE  5
** PPWORD MACRO
** THIS MACRO CAUSES THE NAMED FIELD TO BE DEFINED AS AN ALIGNED PP WORD
** IT IS USED AS A DOCUMENTATION AID TO REMIND THE PROGRAMMER THAT THE
** CYBIL STRUCTURE IS DESIGNED TO ACCOMODATE PP REFERENCE.
          SPACE  3
          MACRO  PPWORD,NAME
          ALIGN  0,16
NAME      FIELD  16
          ENDM
          SPACE  5
** RMA MACRO
** THIS IS A CONVENIENCE MACRO FOR RMA FIELD DEFINITION (BYTE ALIGNMENT
** IS ASSUMED).
          SPACE  3
          MACRO  RMA,NAME
          ALIGN  0,8
NAME      FIELD  32
          ENDM
          SPACE  5
** MLOAD MACRO
** MACRO TO PERFORM A 16 BIT LOAD FROM PP MEMORY USING THE LDDL OR LDML
** INSTRUCTION.  USED TO SUPPORT THE LOAD MACRO.
          SPACE  3
MLOAD     MACRO  W
M         IFLE   W,77B
          LDDL   W
M         ELSE
          LDML   W
M         ENDIF
          ENDM
          SPACE  5
** MSTORE MACRO
** MACRO TO PERFORM A 16 BIT STORE TO PP MEMORY USING THE STDL OR STML
** INSTRUCTION.  USED TO SUPPORT THE STORE MACRO.
          SPACE  3
MSTORE    MACRO  W
M         IFLE   W,77B
          STDL   W
M         ELSE
          STML   W
M         ENDIF
          ENDM
* END IODMAC1
* BEGIN IODMAC2
          SPACE  5
** THESE MACROS MAY USE T1-T8 WITH IN LINE CODE GENERATION OR INDIRECTLY
** THROUGH CALLS TO THE LOAD/STORE SUPPORT ROUTINES
          SPACE  5
** LOAD MACRO
** LOAD A FIELD INTO A AND RIGHT JUSTIFY, ZERO FILL THE REGISTER
** INPUT..RLOC=LOCATION OF BEGINNING OF RECORD
**        RNAME=RECORD NAME
**        FIELD=FIELD NAME (MUST BE LESS THAN 17 BITS LONG)
** OUTPUT..(A)=/RECORD/FIELD RJZF
** USES T1, T2 WHEN FIELDS CROSS PP WORD BOUNDARIES
          SPACE  3
LOAD      MACRO  RLOC,RNAME,FIELD
          LOCAL T
ERCHK     IFGT   /RNAME/N.FIELD,16
M         ERR    FIELD TOO LARGE
ERCHK     ELSE

* TEST WHETHER FIELD CROSSES PP WORD BOUNDARIES AND IF IT DOES NOT,
* GENERATE THE LOAD IN LINE.
L1        IFLE   /RNAME/N.FIELD+/RNAME/L.FIELD,16

* LOAD IT
          LDML   /RNAME/P.FIELD+RLOC

* SHIFT IT
T         SET    16-/RNAME/N.FIELD-/RNAME/L.FIELD
          IFNE   T,0,1
          SHN    -T

* MASK IT
M0        IFNE   /RNAME/L.FIELD,0
M1        IFNE   /RNAME/N.FIELD,16
          MGEN   /RNAME/N.FIELD
M2        IFGT   MASK$,77B
          LPC    MASK$
M2        ELSE
          LPN    MASK$
M2        ENDIF
M1        ENDIF
M0        ENDIF

L1        ELSE

* CROSSES WORD BOUNDARIES
          RJM    LOADF
          VFD    4/0,12/RLOC+/RNAME/P.FIELD
          VFD    4//RNAME/L.FIELD,12//RNAME/N.FIELD

L1        ENDIF

ERCHK     ENDIF

          ENDM
          SPACE  5
** STORE MACRO
** THIS MACRO STORES THE CONTENTS OF A INTO A FIELD IN PP MEMORY.
** THE FIELD MAY CROSS PP WORD BOUNDARIES BUT MUST NOT EXCEED 16
** BITS IN LENGTH.
** INPUT...RLOC=LOCATION OF BEGINNING OF RECORD
**         RNAME=RECORD NAME
**         FIELD=FIELD NAME (MUST BE A FIELD OF 16 OR LESS BITS IN LENGTH)
**         (A)=RJZF VALUE TO STORE.  (IT MUST NOT EXCEED FIELD WIDTH OR
**             UNPREDICTABLE RESULTS WILL OCCUR).
**
** OUTPUT..RECORD UPDATED IN PP MEMORY.
**
** USES T1, T2 PLUS REFERENCE STOREF
          SPACE  3
STORE     MACRO  RLOC,RNAME,FIELD
          LOCAL  X
ERCHK     IFGT   /RNAME/N.FIELD,16
M         ERR    FIELD TOO LARGE
ERCHK     ELSE

* TEST WHETHER FIELD CROSSES PP WORD BOUNDARIES AND IF IT DOES NOT,
* GENERATE IN LINE CODE.
L1        IFLE   /RNAME/N.FIELD+/RNAME/L.FIELD,16
L2        IFEQ   /RNAME/N.FIELD,16

* FULL PP WORD
          STML   /RNAME/P.FIELD+RLOC

L2        ELSE

* ALIGN SOURCE VALUE
X         SET    16-/RNAME/N.FIELD-/RNAME/L.FIELD
          IFNE   X,0,1
          SHN    X

* STORE ALIGNED VALUE
          STDL   T1

* LOAD DEST. FIELD
          LDML   /RNAME/P.FIELD+RLOC

* FORM SHIFTED MASK VALUE
          MGEN   /RNAME/N.FIELD

          DUP    X
MASK$     SET    MASK$+MASK$
          ENDD

* GENERATE MASK INSTRUCTION
          LPC    -MASK$

* INSERT DATA
          ADDL   T1

* REPLACE
          STML   /RNAME/P.FIELD+RLOC

L2        ENDIF

L1        ELSE

* FIELD CROSSES WORD BOUNDARIES
          RJM    STOREF
          VFD    4/0,12/RLOC+/RNAME/P.FIELD
          VFD    4//RNAME/L.FIELD,12//RNAME/N.FIELD

L1        ENDIF
ERCHK     ENDIF
          ENDM
* END IODMAC2
*BEGIN IODMAC3
          SPACE  5
** COMMON PP ROUTINE AID MACROS
          SPACE  2
** MACRO TO DEFINE A SUBROUTINE ENTRY POINT TO BE CALLED BY RJM NAME
          PURGMAC  SUBR
          MACRO  SUBR,NAME
QQQ$RET   SET    *
          LJM    *
          ORG    *-1
NAME      DATA   0
          ENDM
          SPACE  5
** MACRO TO EXECUTE A RETURN FROM A SUBROUTINE
** IT MUST FOLLOW A SUBR DECLARATION
          PURGMAC  RETURN
RETURN    MACRO
M         IFGT   *-QQQ$RET,37B
          LJM    QQQ$RET
M         ELSE
          UJN    QQQ$RET
M         ENDIF
          ENDM
          SPACE  5
** MACRO TO PROVIDE QUALIFIED SYMBOL DEFINITION (HEX)
**  NAME=NAME TO QUALIFY IN DEFINITION
**  QUAL=QUALIFIES NAME
**  VALUE=HEX DIGIT STRING (0-9,A-F)
          SPACE  3
          MACRO  SYMDEFH,NAME,QUALS,VALUE
          QUAL   QUALS
NAME      EQU    0#_VALUE
          QUAL   *
          ENDM
          SPACE  5
** MACRO TO PROVIDE QUALIFIED SYMBOL DEFINITION (DEFAULT BASE)
** NAME=NAME TO QUALIFY IN DEFINITION
** QUALS=QUALIFIES NAME
** VALUE=DIGIT STRING (OCTAL OR DECIMAL OR HEX)
          SPACE  3
          MACRO  SYMDEF,NAME,QUALS,VALUE
          QUAL   QUALS
NAME      EQU    VALUE
          QUAL   *
          ENDM


* END IODMAC3
*BEGIN IODMAC4
          SPACE  5,20
*
** NAME-- LMK,LPK,LDK,ADK,ZJK,NJK,PJK,MJK,UJK
*
** PURPOSE-- DETERMINE FOR THOSE INSTRUCTIONS HAVING A SHORT AND LONG
*            FORM WHICH INSTRUCTION FORM NEEDS TO BE GENERATED.
*
** CALLING SEQUENCE-- SAME AS THE REGULAR PP INSTRUCTION
*
** RESTRICTIONS-- SYMBOLS REFERENCED BY THESE MACROS SHOULD BE
*                 DEFINED PRIOR TO THE MACRO CALL.

*        NO-ADDRESS AND CONSTANT INSTRUCTIONS

NEWOP     ECHO   ,I=(LM,LP,LD,AD)

I_K       MACRO  P1
L         IF     DEF,P1
L         IFLE   P1,77B
L         IFGE   P1,0
          I_N    P1
L         ELSE   1
          I_C    P1
          ENDM
NEWOP     ENDD

*         JUMP INSTRUCTIONS

NEWOP     ECHO   ,I=(ZJ,NJ,PJ,MJ),J=(NJ,ZJ,MJ,PJ)
*
I_K       MACRO  P1
L         IF     DEF,P1
L         IFGE   *-P1,0
L         IFLT   *-P1,40B
          I_N    P1
L         ELSE   2
          J_N    *+3
          LJM    P1
          ENDM
NEWOP     ENDD

UJK       MACRO  P1
L         IF     DEF,P1
L         IFGE   *-P1,0
L         IFLT   *-P1,40B
          UJN    P1
L         ELSE   1
          LJM    P1
          ENDM
          SPACE  5,20
** NAME-- AJM,SCF,IJM,CCF,FJM,SFM,EJM,CFM,IAN,IAM,OAN,OAM,ACN,DCN
*         FAN,FNC,FSJM,FCJM,IAPM,OAPM,CMCH,CHCM,MCLR
*
** PURPOSE-- REDEFINE I/O INSTRUCTIONS SO THAT THE ADDRESS OF CHANNEL
*            INSTRUCTIONS CAN BE SAVED IN A TABLE.
NEWOP     ECHO   ,OP=(AJM,SCF,IJM,DCN,FJM,SFM,EJM,CFM,IAN,IAM,OAN,OAM,AC
,N,FAN,FNC,FSJM,FCJM,IAPM,OAPM,CCF,CMCH,CHCM,MCLR)
*
 OP_.     OPSYN  OP          E.G.  IAN. = IAN
*
          PURGMAC OP
OP        MACRO  P1,P2
          LOCAL  TAG
L         IFC    EQ,$P2$$
TAG       OP_.   P1
T_P1      RMT                IAN,OAN,ACN,DCN,FAN
          CON    TAG
          RMT
L         ELSE
TAG       OP_.   P1,P2
T_P2      RMT                AJM,IJM,FJM,EJM,IAM,OAM,FCN,IAPM,OAPM,
*                            SCF,CCF,SFM,CFM,FSJM,FCJM,CHCM,CMCH,MCLR
          CON    TAG
          RMT
L         ENDIF
OP        ENDM
NEWOP     ENDD
          SPACE  5,20
** NAME-- LOADC
*
** PURPOSE-- LOAD A CM ADDRESS INTO THE R AND A REGISTERS.
*
** CALLING SEQUENCE-- LOADC   CMR,CMA
*     CMR = ADDRESS OF THE WORD TO BE LOADED INTO THE R REGISTER.
*     CMR+1 = ADDRESS OF WORD TO BE LOADED INTO THE A REGISTER.
*     CMA = ADDRESS OF THE VALUE TO BE ADDED TO THE A REGISTER.
*           (CMA IS OPTIONAL)

 LOADC    MACRO  CMR,CMA
 L        IFLE   CMR,76B
 L        IFGE   CMR,0
          LRDL   CMR
          LDDL   CMR+1
 L        ELSE
          LRML   CMR
          LDML   CMR+1
 L        ENDIF

 P        IFC    NE,$CMA$$
 M        IFLE   CMA,77B
 M        IFGE   CMA,0
          ADDL   CMA
 M        ELSE
          ADML   CMA
 M        ENDIF
 P        ENDIF
          ENDM
          SPACE  5,20
** NAME--LOADR
*
** PURPOSE-- LOAD A CM ADDRESS INTO THE R AND A REGISTERS.
*            AN INDEXED MEMORY LOCATION SPECIFIES THE ADDRESS.
*
** CALLING SEQUENCE-- LOADR   CMR,INDEX
*     THE CM ADDRESS IS CONTAINED IN THE LOCATIONS STARTING AT
*         CMR INDEXED BY INDEX.

 LOADR    MACRO  CMR,INDEX
          LRML   CMR,INDEX
          LDML   CMR+1,INDEX
          ENDM
          SPACE  5,20
** NAME--LOADF
*
** PURPOSE-- REFORMAT A CM ADDRESS AND LOAD IT INTO THE R AND A REGISTERS.
*
** CALLING SEQUENCE-- LOADF   CMR,INDEX
*     THE UNFORMATTED CM ADDRESS IS CONTAINED IN THE LOCATIONS
*          STARTING AT CMR INDEXED BY INDEX.
*     INDEX IS OPTIONAL.

 LOADF    MACRO  CMR,INDEX
 N        IFC    NE,$INDEX$$
          LRML   CMR,INDEX
          LDML   CMR+1,INDEX
          SHN    -3
 N        ELSE
 P        IFLE   CMR,76B
 P        IFGE   CMR,0
          LRDL   CMR
          LDDL   CMR+1
 P        ELSE
          LRML   CMR
          LDML   CMR+1
 P        ENDIF
          SHN    -3
 N        ENDIF
          ENDM
          SPACE  5,20
** NAME-- REFAD
*
** PURPOSE-- REFORMAT AND SAVE A CM ADDRESS.
*
** CALLING SEQUENCE-- REFAD   CMR,SAV
*     THE UNFORMATTED CM ADDRESS IS CONTAINED IN THE LOCATIONS
*          STARTING AT CMR.
*     THE REFORMATTED CM ADDRESS IS STORED IN THE LOCATIONS
*          STARTING AT SAV.
*
 REFAD    MACRO  CMR,SAV
 L        IFLE   CMR,76B
 L        IFGE   CMR,0
          LDDL   CMR
 M        IFLE   SAV,76B
 M        IFGE   SAV,0
          STDL   SAV
          LDDL   CMR+1
          SHN    -3
          STDL   SAV+1
 M        ELSE
          STML   SAV
          LDDL   CMR+1
          SHN    -3
          STML   SAV+1
 M        ENDIF
 L        ELSE
          LDML   CMR
 P        IFLE   SAV,76B
 P        IFGE   SAV,0
          STDL   SAV
          LDML   CMR+1
          SHN    -3
          STDL   SAV+1
 P        ELSE
          STML   SAV
          LDML   CMR+1
          SHN    -3
          STML   SAV+1
 P        ENDIF
 L        ENDIF
          ENDM
          SPACE  5,20
 PAUSE    MACRO  X           DELAY X MICROSECONDS
 R        IFLE   X,77B
          LDN    X
 R        ELSE
          LDC    X
 R        ENDIF
          HOLD               WAIT INSTRUCTION
          ENDM
          SPACE  5,20
 MASKP    MACRO  FIELD
          LOCAL  X
 X        SET    16-N.FIELD-L.FIELD
          MGEN   N.FIELD
 MSK      SET    MASK$
          DUP    X
 MSK      SET    MSK+MSK
          ENDD
          ENDM
* END IODMAC4
          LIST   B,L,N,R
          EJECT

*         EQUATES FOR IPI ADAPTER

 H0029    EQU    0#0029      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H005B    EQU    0#005B      SET SYNC OUT
 H0071    EQU    0#0071      FULL WHEN SLAVE IN IS 0
 H00E1    EQU    0#00E1      READ STATUS REGISTER
 H00F1    EQU    0#00F1      READ ERROR REGISTER
 H0122    EQU    0#0122      IPI BUS A OUTPUT PARITY ERROR
 H0281    EQU    0#0281      STREAM, READ
 H0322    EQU    0#0322      IPI BUS A INPUT PARITY ERROR
 H0381    EQU    0#0381      STREAM, WRITE
 H0711    EQU    0#0711      DROP MASTER OUT
 H0715    EQU    0#0715      REQUEST CLASS 1, 2, OR 3 INTERRUPT
 H0A81    EQU    0#0A81      STREAM, READ, DMA
 H0C22    EQU    0#0C22      ICI OUTPUT PARITY ERROR
 H7E42    EQU    0#7E42      IPI CHANNEL TRANSFER RATE
 H8025    EQU    0#8025      MASTER OUT, FULL WHEN SLAVE IN IS 1
 H8039    EQU    0#8039      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H8215    EQU    0#8215      SET MASTER OUT, LOGICAL INTERFACE RESET
 H8415    EQU    0#8415      SET MASTER OUT, SLAVE RESET
 H9211    EQU    0#9211      DROP SYNC OUT
 H9213    EQU    0#9213      SET SYNC OUT

*         MISCELLANEOUS EQUATES

 FE       EQU    0           = 1, TO ENABLE FORCE ERROR CODE
 TB       EQU    0           = 1, TO ENABLE TRACE BUFFER OF COMMANDS AND RESPONSES
 DC       EQU    22B         DISK CHANNEL
 DRNUM    EQU    0#FE        INITIALIZE VALUE FOR OFF-LINE DRIVE NUMBER (OFFLD)
 C.CHCNT  EQU    100         NUMBER OF REQUESTS TO PROCESS IF BUSY BEFORE
                              GIVING UP THE CHANNEL
 MS50     EQU    53475       50 MILLISECOND TIMEOUT FOR CERTAIN LOOPS
 RRL      EQU    3           REQUEST RETRY LIMIT
 SRT      EQU    720         SLAVE RESET TIMEOUT (SECONDS)
 FPT      EQU    600         FORMAT PACK TIMEOUT (SECONDS)
 CMT      EQU    32          COMMAND TIMEOUT (SECONDS)
 RLIE     EQU    26*8        RESPONSE LENGTH IF ERROR
 RPL      EQU    0#10        READ, WRITE COMMAND PACKET LENGTH
 H0200    EQU    0#0200      REPORT ATTRIBUTES OPERATION CODE
 H0202    EQU    0#0202      RESTORE ATTRIBUTES OPERATION CODE
 H0209    EQU    0#0209      LOAD ATTRIBUTES OPERATION CODE
 H020A    EQU    0#020A      SAVE ATTRIBUTES OPERATION CODE
 H0700    EQU    0#0700      SET OPERATING MODE
 H0800    EQU    0#0800      ABORT OPERATION CODE
 H1005    EQU    0#1005      READ OPERATION CODE
 H2005    EQU    0#2005      WRITE OPERATION CODE
 H5200    EQU    0#5200      WRITE TO BUFFER OPERATION CODE
 H6200    EQU    0#6200      READ FROM BUFFER OPERATION CODE
 H8100    EQU    0#8100      PERFORM DRIVE DIAGNOSTICS OP CODE
 H8101    EQU    0#8101      PERFORM DRIVE HEAD SHIFT TEST OP CODE
 H8400    EQU    0#8400      READ PERFORMANCE LOG OP CODE
 H0931    EQU    0#0931      COMMAND EXTENT PARAMETER
 ID12     EQU    0#12        DEFECT MANAGEMENT
 ID13     EQU    0#13        MESSAGE/MICROCODE EXCEPTION
 ID14     EQU    0#14        INTERVENTION REQUIRED FOR CONTROLLER
 ID15     EQU    0#15        ALTERNATE PORT EXCEPTION
 ID16     EQU    0#16        MACHINE EXCEPTION FOR CONTROLLER
 ID17     EQU    0#17        COMMAND EXCEPTION FOR CONTROLLER
 ID22     EQU    0#22        DEFECT MANAGEMENT
 ID23     EQU    0#23        DRIVE MESSAGE EXCEPTION
 ID24     EQU    0#24        INTERVENTION REQUIRED STATUS
 ID25     EQU    0#25        DRIVE ALTERNATE PORT EXCEPTION
 ID26     EQU    0#26        MACHINE EXCEPTION FOR DRIVE
 ID29     EQU    0#29        DRIVE CONDITIONAL SUCCESS
 ID32     EQU    0#32        FAILING ADDRESS
 ID6D     EQU    0#6D        HAS TRANSFER LENGTH

*         COMMAND/RESPONSE PACKET EQUATES

 CRN      EQU    1           COMMAND REFERENCE NUMBER
 OPCD     EQU    2           OPERATION CODE FOR CONTROLLER
 SLAD     EQU    3           SLAVE ADDRESS, UNIT ADDRESS
 MAJST    EQU    4           MAJOR STATUS
 FCP      EQU    4           FIRST COMMAND PARAMETER

*         RESPONSE TYPES FOR MAJOR STATUS

 CC       EQU    1           COMMAND COMPLETE RESPONSE
 AR       EQU    4           ASYNCHRONOUS RESPONSE
 TN       EQU    5           TRANSFER NOTIFICATION
 CCS      EQU    0#18        COMMAND COMPLETE, SUCCESSFUL

*         LEFT SHIFTS FOR MAJOR STATUS

 CS       EQU    16          CONDITIONAL SUCCESS

*         BUS CONTROL EQUATES

 CMDOUT   EQU    0           COMMAND, INFORMATION OUT
 RSPIN    EQU    1           RESPONSE, INFORMATION IN
 DATAOUT  EQU    2           DATA OUT
 DATAIN   EQU    3           DATA IN
          SPACE  5,20
*         IOU/CONTROLLER/DRIVE ERROR CODES

 E00      EQU    0           CP MUST DETERMINE ERROR CODE
 E01      EQU    1           FUNCTION TIMEOUT
 E02      EQU    2           CHANNEL EMPTY WHEN ACTIVATED
 E03      EQU    3           PERIOD COUNTER PARITY
 E04      EQU    4           PP-IPI PARITY ERROR
 E06      EQU    6           IOU ERROR
 E20      EQU    20          CAN'T SELECT CONTROLLER
 E21      EQU    21          BIT SIGNIFICANT RESPONSE ERROR
 E22      EQU    22          NO SYNC IN
 E23      EQU    23          SYNC IN DID NOT DROP
 E24      EQU    24          IPI SEQUENCE ERROR
 E25      EQU    25          IPI CHANNEL PARITY ERROR
 E27      EQU    27          SLAVE IN NOT SET
 E28      EQU    28          SLAVE IN DID NOT DROP
 E29      EQU    29          INCOMPLETE TRANSFER
 E30      EQU    30          CHANNEL STAYED ACTIVE
 E31      EQU    31          BUFFER COUNTER PARITY
 E32      EQU    32          SYNC COUNTER PARITY
 E33      EQU    33          LOST DATA
 E34      EQU    34          BUS PARITY
 E35      EQU    35          COMMAND REJECT
 E36      EQU    36          SYNC OUT NOT EQUAL SYNC INS
 E37      EQU    37          BUS B ACKNOWLEDGE INCORRECT
 E38      EQU    38          NO CONTROLLER RESPONSE
 E39      EQU    39          ENDING STATUS WRONG
 E50      EQU    50          EXECUTING CONTROLLER DIAGNOSTICS
 E51      EQU    51          CONTROLLER DIAGNOSTICS PASSED
 E52      EQU    52          CONTROLLER DIAGNOSTICS PASSED, LAST ERROR CODE RETURNED
 E54      EQU    54          DRIVE ALTERNATE PORT EVENT
 E55      EQU    55          RESTORING DRIVE
 E56      EQU    56          DRIVE RESTORATION COMPLETE
 E57      EQU    57          FORMATTING DRIVE
 E58      EQU    58          FORMAT COMPLETE
 E59      EQU    59          PARITY PROTECTION DISABLED
 E61      EQU    61          DRIVE FAILURE
 E62      EQU    62          MEDIA FAILURE
 E70      EQU    70          LRC ERROR ON READ
 E71      EQU    71          CONTROLLER INTERVENTION REQUIRED
 E72      EQU    72          CONTROLLER MACHINE EXCEPTION
 E73      EQU    73          COMMAND EXCEPTION
 E74      EQU    74          MICROCODE EXECUTION ERROR
 E75      EQU    75          CONTROLLER ALTERNATE PORT EVENT (MAPPED TO 53 BY CP CODE)
 E76      EQU    76          UNEXPECTED RESPONSE
 E78      EQU    78          CONTROLLER OVER TEMPERATURE
 E96      EQU    96          DRIVE HEAD SHIFT ERROR
 E110     EQU    110         PP-CONTROLLER DATA INTEGRITY
 E111     EQU    111         CM-DRIVE DATA INTERGRITY
 E120     EQU    120         SOFTWARE FAILURE
 E130     EQU    130         DEFECT MANAGEMENT TASK FAILED
 E140     EQU    140         XXXX CONFIGURED - YYYY FOUND
 E141     EQU    141         DRIVE INITIALIZATION REQUIRED
 E142     EQU    142         CONTROLLER DOES NOT SUPPORT PARALLEL
          SPACE  5,20
*         INTERFACE ERROR CODES.

 E208     EQU    1010B       LOGICAL UNIT OF UNIT DESCRIPTOR NOT
                             IN SEQUENCE OR NOT IN RANGE
 E20B     EQU    1013B       COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS OR NOT LONG ENOUGH
 E306     EQU    1406B       INVALID UNIT TYPE
 E501     EQU    2401B       INVALID COMMAND CODE
 E505     EQU    2405B       INVALID LENGTH SPECIFICATION IN COMMAND
          EJECT
*         CONFIGURED UNITS.

 UN       RECORD PACKED

*         WORD 1

 CIP      BOOLEAN            AT LEAST ONE COMMAND IN PROGRESS
 TCIP     BOOLEAN            TWO COMMANDS IN PROGRESS
 ACIP     BOOLEAN            ALTERNATE COMMAND IN PROGRESS
 NCR      BOOLEAN            NO CONTROLLER RESPONSE
 RIP      BOOLEAN            RESTORE IN PROGRESS
 FILL1    BOOLEAN            UNUSED (TABLE INDEX FOR I4)
 PDCE     BOOLEAN            PARITY DRIVE CORRECTION ENABLED
 FILL2    BOOLEAN            UNUSED (PORT FOR I4)
 CM       SUBRANGE 0,7       CONTROLLER NUMBER
 UNIT     SUBRANGE 0,37B     UNIT NUMBER

*         WORD 2

 SSPTR    PPWORD             POINTER TO RESIDENT SS TABLE. IF ZERO
                             THE TABLE IS IN THE UNIT COMM. BUFFER
*         WORD 3

 CLK      PPWORD             SECONDS CLOCK OF LAST ACTIVITY

*         WORD 4

 UIT      STRUCT 4           RMA OF UNIT INTERFACE TABLE (REFORMATTED)
          MASKP  NCR
 K.NCR    EQU    MSK
 UN       RECEND
          SPACE  5,20
*         SS TABLE DEFINITIONS.  INFORMATION SAVED FOR EACH UNIT.

 SS       RECORD PACKED

 DOAR     BOOLEAN            DRIVE OPERATIONAL ASYNCH RECEIVED
 FILL1    SUBRANGE 0,377B    UNUSED
 DT       SUBRANGE 0,7       DEVICE TYPE
 CRN      SUBRANGE 0,17B     USED TO MAKE COMMAND REFERENCE NUMBER UNIQUE

 CMOD     SUBRANGE 0,377B    CONTROLLER NUMBER
 UNIT     SUBRANGE 0,377B    UNIT NUMBER

 LU       PPWORD             LOGICAL UNIT
 FNC      PPWORD             FUNCTION CODE  READ = 0
                                            WRITE = 1
 REQ      STRUCT 4           CURRENT REQUEST (UNFORMATTED RMA)
 PVA      STRUCT 6           PVA OF CURRENT REQUEST

 LASTC    PPWORD             OFFSET OF COMMAND IN REQUEST
 FRST     PPWORD             = 0, IF FIRST TIME THROUGH UNCMND
 NUMCM    PPWORD             NUMBER OF COMMANDS LEFT TO PROCESS IN
                             THIS REQUEST
 LISTL    PPWORD             NUMBER OF CM WORDS IN ADDRESS-LENGTH PAIR LIST.
                             (INCLUDES THE NUMBER OF WORDS WHICH HAVE NOT
                             BEEN READ FROM CM.)
 TOTAL    STRUCT 2           TOTAL SECTORS LEFT TO TRANSFER
                              8XXX IF MASTER TERMINATE BEING USED
 FCOMRQ   STRUCT 4           FIRST COMPLETED REQUEST (RMA)
 CURRQ    STRUCT 4           CURRENT REQUEST (RMA)
 PRERQ    STRUCT 4           PREVIOUS REQUEST (RMA)
 NCOMRQ   PPWORD             NUMBER OF COMPLETED REQUESTS
 NCOMW    PPWORD             NUMBER OF COMPLETED WRITE REQUESTS
 CURTRK   PPWORD             CURRENT TRACK
 CURSEC   PPWORD             CURRENT SECTOR
 FPVA     STRUCT 6           PVA OF FIRST COMPLETED REQUEST
 XFER     STRUCT 4           TRANSFER COUNT
 PVA2     STRUCT 6           PVA FOR SECOND COMMAND
 RMA2     STRUCT 4           RMA FOR SECOND COMMAND
 TW2      STRUCT 2           TOTAL SECTORS TO TRANSFER FOR 2ND COMMAND
 SC       PPWORD             SET NONZERO IF POSSIBLE STATE CHANGE FOR DRIVE
 CRTS     PPWORD             CURRENT TRACK, SECTOR BEING RESTORED
 RQTRY    PPWORD             REQUEST RETRY COUNT
 RESET    PPWORD             RESET ISSUED IF NONZERO
 CT       PPWORD             NONZERO WHEN CONFIDENCE TEST IS COMPLETE
                              1 IF NO ERROR
                              2 IF ERROR
                              4 IF DATA INTEGRITY ERROR
                             40 IF OPERATIONAL ASYNCH RECEIVED FOR PARITY DRIVE
 RECOV    PPWORD             NONZERO IF IN RECOVERY
 DP       STRUCT 4           DELINK POINTER (REFORMATTED RMA)
 MREV     STRUCT 4           CONTROLLER MICROCODE 8-DIGIT PART NUMBER

 RQ       STRUCT 40          REQUEST

 CMLIST   STRUCT 8           CURRENT DATA ADDRESS OR CURRENT COMMAND

 SS       RECEND

*         ALTERNATE USAGE OF LOCATIONS IN SS TABLE DURING CONFIDENCE TEST

 CTME     EQU    /SS/P.PVA2  START OF 3 WORD TABLE WITH EACH WORD
                              CONTAINING THE HEAD AND SECTOR NUMBER OF
                              OF A MEDIA ERROR
 CRC      EQU    /SS/P.RMA2  CURRENT CYLINDER BEING RESTORED
 RTM      EQU    /SS/P.RMA2+1  REQUESTS TO MULTIPLEX PER CYLINDER DURING RESTORE
 ODN      EQU    /SS/P.TW2   OFF LINED DRIVE NUMBER
          SPACE  5,20
*         PP INTERFACE TABLE

 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
 ACTCH    BOOLEAN            ACTIVE CHECK, THE PP CLEARS THIS BIT WITHIN 1 MINUTE
 IDLREQ   BOOLEAN            IDLE REQUEST
 RESREQ   BOOLEAN            RESUME REQUEST
 PPIDLE   BOOLEAN            PP IDLE
          SUBRANGE 0,3777B   UNUSED
 LOCK     BOOLEAN            PP TABLE LOCK
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
          STRUCT 24          UNUSED
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          SPACE  5,20
*         UNIT DESCRIPTORS.

 UD       RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 UD       RECEND
          SPACE  5,20
*         UNIT INTERFACE TABLE

 UIT      RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
 FRCFMT   BOOLEAN            FORCE FORMAT FLAG
 PARPRO   BOOLEAN            PARITY PROTECTION STATUS
                               0 = PROTECTION DISABLED
                               1 = PROTECTION ENABLED
 RESTDR   BOOLEAN            RESTORING DRIVE FLAG
                               O = NOT RESTORING
                               1 = RESTORING DRIVE
 FILL1    SUBRANGE 0,17B
 OFFLD    SUBRANGE 0,377B     OFF-LINE DRIVE NUMBER

          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
                               = 400B, 844-4X   = 411B, 5832_1   = 422B, 5838_2
                               = 401B, 885-1X   = 412B, 5832_2   = 423B, 5838_3P
                               = 402B, 885-42   = 413B, 5833_1   = 424B, 5838_4
                               = 403B, 834      = 414B, 5833_1P  = 425B, 47444_1
                               = 404B, 836      = 415B, 5833_2   = 426B, 47444_1P
                               = 405B, 895      = 416B, 5833_3P  = 427B, 47444_2
                               = 406B, 887      = 417B, 5833_4   = 430B, 47444_3P
                               = 407B, 9836     = 420B, 5838_1   = 431B, 47444_4
                               = 410B, 9853     = 421B, 5838_1P
 QCNT     PPWORD             QUEUE COUNT
 SHARE    BOOLEAN            NONZERO IF THIS UNIT IS BEING SHARED WITH MALET OR DFT
          ALIGN  16,64
 UBUFL    PPWORD             UNIT COMMUNICATION BUFFER LENGTH
 UBUF     RMA                UNIT COMMUNICATION BUFFER (RMA)
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

          MASKP  DSABLE
 K.DSABLE EQU    MSK
          MASKP  FRCFMT
 K.FRCFMT EQU    MSK
          MASKP  PARPRO
 K.PARPRO EQU    MSK
          MASKP  RESTDR
 K.RESTDR EQU    MSK
          MASKP  OFFLD
 K.OFFLD  EQU    MSK

 K.PBITS  EQU    K.PARPRO+K.RESTDR+K.OFFLD

 UIT      RECEND
          SPACE  5,20
*         REQUESTS

 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (NOT USED)
                               0 - ATTEMPT RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY (NOT USED)
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
          ALIGN  0,64
 SWIT     BOOLEAN            SWITCH TO NEXT REQUEST
          ALIGN  16,64
 CYL      PPWORD             CYLINDER ADDRESS
 TRACK    PPWORD             TRACK ADDRESS
 SECTOR   PPWORD             SECTOR ADDRESS
 CMND     INTEGER            COMMAND SEQUENCE

          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$

 RQ       RECEND
          SPACE  5,20
*         COMMAND PART OF REQUEST

 CM       RECORD PACKED

 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$
          SPACE  5,20
*         PP RESPONSE

 RS       RECORD PACKED

*         WORD 1

 FILL1    BOOLEAN
 SHORT    BOOLEAN            IF SET, ONE-WORD RESPONSE
          SUBRANGE 0,77B     UNUSED
          SUBRANGE 0,377B    LOGICAL UNIT (FOR DEBUG)
          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST

*         WORD 2
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST  (NOT USED)

*         WORD 3

 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST) (NOT USED)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)  (NOT USED)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS  (NOT USED)
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY  (NOT USED)
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

*         WORD 4

          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED  (NOT USED)
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE INTERFACE
                             ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
                             (NOT USED)
 CHERR    BOOLEAN            CHANNEL PARITY ERROR (NOT USED)
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION
                             OCCURRED ON INPUT OR INADEQUATE DATA RATE ON OUTPUT
                             (NOT USED)
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT  (NOT USED)
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A
                             HARDWARE MALFUNCTION.  EXAMPLE-UNIT NOT
                             READY, UNIT NOT CONNECTED.  (NOT USED)
 FTO      BOOLEAN            FUNCTION TIMEOUT (NOT USED)
 CHERO    BOOLEAN            CHANNEL OUTPUT PARITY ERROR (NOT USED)
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
                               1 - RECOVERED ERROR
                               2 - COMMAND HAD EXPLICIT RESPONSE FLAG SET
                               3 - BOTH CONDITIONS 1 AND 2
 K.REC    EQU    1           RECOVERED ERROR
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE  (NOT USED)
                               1 - UNIT CHANGED FROM READY TO NOT READY
                               2 - UNIT CHANGED FROM NOT READY TO READY
                               3 - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
                               4 - CONTROLLER RESERVED
                               5 - UNIT RESERVED TO ANOTHER ACCESS
                               6 - RECOVERED ABNORMAL CONDITION
          ALIGN  49,64       ALERT CONDITIONS
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

*         WORD 5

          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)(NOT USED)

*         WORD 6

 CHAN     PPWORD             CHANNEL NUMBER
 SCYL     PPWORD             STARTING CYLINDER
 STRK     PPWORD             STARTING TRACK
 SSEC     PPWORD             STARTING SECTOR

*         WORD 7

 UNIT     PPWORD             UNIT NUMBER
 RTRY     PPWORD             REQUEST RETRY COUNT
 FTRK     PPWORD             FAILING TRACK
 FSEC     PPWORD             FAILING SECTOR

*         WORD 8

 WC       PPWORD             WORDS NOT TRANSFERRED
 FUNTO    PPWORD             FUNCTION WITH TIMEOUT
 ID       PPWORD             ERROR IDENTIFIER
 K.PPD    EQU    4           PARITY PROTECTION DISABLED
 K.UDN    EQU    3           UNIT DOWN
 K.CMDN   EQU    2           CONTROLLER DOWN
 K.CHDN   EQU    1           CHANNEL DOWN
 ERRID    PPWORD             ERROR IDENTIFIER

*         WORD 9

 MREVU    PPWORD             CONTROLLER MICROCODE PART NUMBER (UPPER)
 STREG    PPWORD             IPI CHIP STATUS REGISTER
 ERREG    PPWORD             IPI CHIP ERROR REGISTER
 MREVL    PPWORD             CONTROLLER MICROCODE PART NUMBER (LOWER)

*         WORD 10

          PPWORD             DMA ERROR REGISTER (I4 ONLY)
          PPWORD             OPERATIONAL STATUS REGISTER (I4 ONLY)
          PPWORD             CONTROL REGISTER (I4 ONLY)
 ADT      PPWORD             ACTUAL DRIVE TYPE IF ERROR CODE IS 140

          MASKP  INTERR
 K.INTERR EQU    MSK
          MASKP  DATERR
 K.DATERR EQU    MSK
          MASKP  SHORT
 K.SHORT  EQU    MSK

 RS       RECEND


 CM       RECEND
          SPACE  5,20
*         COMMAND CODES

 C.READ   EQU    100B        READ
 C.WRITE  EQU    120B        WRITE
 C.FORMAT EQU    164B        FORMAT
          SPACE  5,20
*         RESPONSE CODES

 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    1           INTERMEDIATE RESPONSE
 R.ABN    EQU    3           ABNORMAL REQUEST TERMINATION
          SPACE  5,20
*         PP COMMUNICATION BUFFER

 CB       RECORD PACKED

          ALIGN  31,64
 SLAVE    BOOLEAN            NONZERO IF SLAVE PP (UNUSED)
 PARTNR   RMA                PARTNERS COMMUNICATION BUFER (RMA)(UNUSED)

 CONTRL   STRUCT 8           LOAD CONTROLWARE COMMAND (UNUSED)
 CMCTRL   STRUCT 8           LOAD CONTROLLER CONTROLWARE (UNUSED)
 ODP      STRUCT 8           OVERLAY DIRECTORY (UNUSED)
          STRUCT 56
 BUF      STRUCT 11192       DATA BUFFER FOR CONFIDENCE TEST
                              BYTES = SECTOR (8192) + 8 TIMES
                              (SECTORS (25) X TRACKS (15))
 CB       RECEND

*         THE RESPONSE BUFFER MUST BE 32 X 3 + 5 WORDS LONG TO
*         HOLD THE DATA FROM REPORTING ATTRIBUTE 68.

 RPBL     EQU    200         MAXIMUM LENGTH OF RESPONSE BUFFER
 EOM      EQU    40000B
 RPB      EQU    37400B      RESPONSE PACKET BUFFER
 RS       EQU    RPB-P.RS    DISK RESPONSE
          ERRMI  EOM-RPB-RPBL  IF RESPONSE BUFFER OVERFLOWS MEMORY
 IPIT     EQU    RPB+64      PP INTERFACE TABLE
 UBUF     EQU    IPIT+P.PIT  UNIT INTERFACE TABLE
 IBUF     EQU    UBUF+P.UIT  UNIT DESCRIPTOR BUFFER
 NRQ      EQU    IPIT        NEXT REQUEST
 RQT      EQU    NRQ+8
          ERRMI  EOM-IPIT-P.SS  IF TABLE OVERFLOWS MEMORY
          ERRMI  EOM-IBUF-P.UD  IF TABLE OVERFLOWS MEMORY
 OB       EQU    RPB+64      OUTPUT BUFFER FOR PP/CONTROLLER PATH TEST
 IB       EQU    RPB+128     INPUT BUFFER FOR PP/CONTROLLER PATH TEST
 IBN      EQU    IB+50       END OF INPUT BUFFER
          ERRMI  EOM-IBN     IF TABLES OVERFLOW MEMORY
 RQ       EQU    /SS/P.RQ    REQUEST
 CM       EQU    RQ+/RQ/P.CMND  CURRENT COMMAND
 CMLIST   EQU    /SS/P.CMLIST  INDIRECT RMA LIST
          EJECT
          CON    MAIN-1

*         DIRECT CELLS

 CM.PIT   BSSZ   2           CM ADDRESS OF PP INTERFACE TABLE
                              WORD 1 IS UPPER 16 BITS OF RMA
                              WORD 2 TIMES 8 IS LOWER RMA
 T1       BSSZ   1
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1
 T9       BSSZ   1
 SBS      EQU    T9          SECTORS TO TRANSFER BEFORE SUSPENDING

 CHAN     BSSZ   1           CHANNEL NUMBER
 STATUS   BSSZ   1           IPI CHANNEL STATUS
 CMNDS    BSSZ   1           NUMBER OF OUTSTANDING COMMANDS
 CMOD     BSSZ   1           CONTROLLER NUMBER
 UX       BSSZ   1           INDEX TO UNITS TABLE
 FI       BSSZ   1           INDEX TO FUNCTION HISTORY BUFFER
 P1       BSSZ   1
 P2       BSSZ   1
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 P6       BSSZ   1
 WC       BSSZ   1           WORD COUNT FOR DATA TRANSFER
 WD       BSSZ   1           WORD COUNT FOR CM TRANSFER

 FNC      BSSZ   1           FUNCTION CODE (INTERNAL)
 LF       BSSZ   1           LAST FUNCTION TO IPI ADAPTER
 CNUM     BSSZ   1           0 IF ONE COMMAND, OTHERWISE 2 COMMANDS ISSUED TO
                              THE CONTROLLER
 BYTES    BSSZ   1           NUMBER OF BYTES TO TRANSFER FROM CURRENT SECTOR
 SECPOS   BSSZ   1           SECTOR BUFFER TRANSFER POSITION (TO CM)
 DELAY    BSSZ   1           DELAY BITS FROM ENDING STATUS
 CSST     BSSZ   1           POINTER TO CURRENT SS TABLE
 LUX      BSSZ   1           VALUE OF UNIT INDEX OF LAST UNIT SELECTED
 TOTAL    BSSZ   1           TOTAL SECTORS TO TRANSFER
 UNUML    BSSZ   1           LENGTH OF CONFIGURED UNIT ENTRIES
 TBC      BSSZ   1           NONZERO IF TRANSFER RESPONSE RECEIVED BEFORE
                              COMPLETION RESPONSE
 MALET    BSSZ   1           NONZERO IF MAINTENANCE SOFTWARE WANTS
                              THE CHANNEL
 CLF      DATA   1           CHANNEL LOCK FLAG, 0 IF LOCK SET
 CTM      BSSZ   1           USED TO CHANGE TRANSFER MODE TO STREAMING
                             FOR COMMAND AND RESPONSE PACKETS
 CLCUR    BSSZ   1           CHANNEL 14 CLOCK CURRENT VALUE
 CLMCS    BSSZ   1           CLOCK, MICROSECOND
 CLMLS    BSSZ   1           CLOCK, MILLISECOND
 CLSEC    BSSZ   1           CLOCK, SECOND
 CTPAT    BSSZ   1           CONFIDENCE TEST PATTERN FIRST WORD
 DT       BSSZ   1           DRIVE TYPE
 PD       BSSZ   1           PHYSICAL DRIVE
 MFID     BSSZ   1           MASK FOR TRANSFER MODE  0 = STREAM ALL
                                                     1 = INTERLOCK DATA
                                                   200 = INTERLOCK COMMANDS AND RESPONSES
                                                   201 = INTERLOCK ALL
 STORS    BSS    1           STORE RESPONSE FLAG (USED BY RESPIN)
                               = 0, IF A RESPONSE IS SENT TO CM
                               = NONZERO, IF NO RESPONSE WAS SENT TO CM
 .F       IFEQ   FE,1
 FEST     DATA   0           FORCE ERROR START COUNT
 FEND     DATA   0           FORCE ERROR END COUNT
 FEUN     DATA   0           UNIT NUMBER TO FORCE ERROR ON
 .F       ENDIF
          IFEQ   TB,1
 Z1       BSSZ   6           RMA POINTER TO TRACE BUFFER
          ENDIF
          SPACE  2
          BSS    72B-*
 DSRTP    DATA   2,0         RMA OF PP INTERFACE TABLE AT DEADSTART
 INPNT    EQU    DSRTP+1     IN POINTER FOR RESPONSE BUFFER
 LIM      BSSZ   1           LIMIT OF RESPONSE BUFFER (IN 8-BIT BYTES)
 LPN      CON    1           LOGICAL PP NUMBER
 PTF      BSSZ   1           IF 0 EXECUTE PATH TEST
 IF       BSSZ   1           INITIALIZE FLAG, IF NOT 0 EITHER THE CONFIDENCE
                              TEST SHOULD BE RUN OR A UNIT SHOULD BE FORMATTED
          BSS    100B-*
          LJM    MAIN
          DATA   9           IPI/930 5830  DISK DRIVER (FOR ANAD PROC)
 HANG     CON    0           AN EASY WAY TO SEE CERTAIN HANGS
          UJN    *
 FPD      DATA   0           FAILING PHYSICAL DRIVE
 IDLE     DATA   0           NUMBER OF TIMES DRIVER WAS IDLED
          SPACE  2
*         THE FOLLOWING CM ADDRESSES ARE SET DURING INITIALIZATION
*                WORD 1 IS UPPER 16 BITS OF RMA
*                WORD 2 TIMES 8 IS LOWER RMA

 CM.CB    BSSZ   2           ADDRESS OF BUFFER WITHIN PP COMM. BUFFER
 CM.RS    BSSZ   2           ADDRESS OF RESPONSE BUFFER
 CM.INT   BSSZ   2           ADDRESS OF INTERRUPT WORD
 CM.CHAN  BSSZ   2           ADDRESS OF CHANNEL INTERLOCK TABLE

 T10      DATA   0
 T11      DATA   0
 T12      DATA   0

*         LOCATION DT IS THE INDEX TO THIS DRIVE TABLE

*         CONFIDENCE TEST CYLINDER

 CTC      DATA   843         5832_1
          DATA   834         5832_2
          DATA   1628        5833_1
          DATA   1628        5833_1P
          DATA   1628        5833_2
          DATA   1628        5833_3P
          DATA   1628        5833_4
          DATA   2619        5838_1
          DATA   2619        5838_1P
          DATA   2619        5838_2
          DATA   2619        5838_3P
          DATA   2619        5838_4
          DATA   2289        47444_1
          DATA   2289        47444_1P
          DATA   2289        47444_2
          DATA   2289        47444_3P
          DATA   2289        47444_4
 DTS      EQU    *-CTC       DRIVE TYPES SUPPORTED

*         TRACKS PER CYLINDER

 TPC      DATA   4           5832_1
          DATA   4           5832_2
          DATA   7           5833_1
          DATA   7           5833_1P
          DATA   7           5833_2
          DATA   7           5833_3P
          DATA   7           5833_4
          DATA   9           5838_1
          DATA   9           5838_1P
          DATA   9           5838_2
          DATA   9           5838_3P
          DATA   9           5838_4
          DATA   15          47444_1
          DATA   15          47444_1P
          DATA   15          47444_2
          DATA   15          47444_3P
          DATA   15          47444_4

*         SECTORS PER TRACK

 SPT      DATA   12          5832_1
          DATA   24          5832_2
          DATA   22          5833_1
          DATA   22          5833_1P
          DATA   42          5833_2
          DATA   33          5833_3P
          DATA   42          5833_4
          DATA   18          5838_1
          DATA   18          5838_1P
          DATA   35          5838_2
          DATA   27          5838_3P
          DATA   35          5838_4
          DATA   13          47444_1
          DATA   13          47444_1P
          DATA   25          47444_2
          DATA   19          47444_3P
          DATA   25          47444_4

*         SECTORS PER CYLINDER

 SPC      CON    12*4        5832_1
          CON    24*4        5832_2
          CON    22*7-2      5833_1
          CON    22*7-2      5833_1P
          CON    42*7-2      5833_2
          CON    33*7-2      5833_3P
          CON    42*7-2      5833_4
          CON    18*9-4      5838_1
          CON    18*9-4      5838_1P
          CON    35*9-4      5838_2
          CON    27*9-4      5838_3P
          CON    35*9-4      5838_4
          CON    13*15-7     47444_1
          CON    13*15-7     47444_1P
          CON    25*15-7     47444_2
          CON    19*15-7     47444_3P
          CON    25*15-7     47444_4

*         BYTES PER SECTOR

 BPS      CON    4096        5832_1
          CON    4096        5832_2
          CON    4096        5833_1
          CON    4096        5833_1P
          CON    4096        5833_2
          CON    8192        5833_3P
          CON    8192        5833_4
          CON    4096        5838_1
          CON    4096        5838_1P
          CON    4096        5838_2
          CON    8192        5838_3P
          CON    8192        5838_4
          CON    4096        47444_1
          CON    4096        47444_1P
          CON    4096        47444_2
          CON    8192        47444_3P
          CON    8192        47444_4

*         DATA DRIVES PER LOGICAL UNIT

 DD       DATA   1           5832_1
          DATA   2           5833_2
          DATA   1           5833_1
          DATA   1           5833_1P
          DATA   2           5833_2
          DATA   3           5833_3P
          DATA   4           5833_4
          DATA   1           5838_1
          DATA   1           5838_1P
          DATA   2           5838_2
          DATA   3           5838_3P
          DATA   4           5838_4
          DATA   1           47444_1
          DATA   1           47444_1P
          DATA   2           47444_2
          DATA   3           47444_3P
          DATA   4           47444_4

*         SPARE SECTORS PER CYLINDER

 SSPC     DATA   0           5832_1
          DATA   0           5832_2
          DATA   2           5833_1
          DATA   2           5833_1P
          DATA   2           5833_2
          DATA   2           5833_3P
          DATA   2           5833_4
          DATA   4           5838_1
          DATA   4           5838_1P
          DATA   4           5838_2
          DATA   4           5838_3P
          DATA   4           5838_4
          DATA   7           47444_1
          DATA   7           47444_1P
          DATA   7           47444_2
          DATA   7           47444_3P
          DATA   7           47444_4

*         INTERRUPT SIZE

 IS       DATA   0           5832_1
          DATA   0           5832_2
          DATA   8192        5833_1
          DATA   8192        5833_1P
          DATA   8192        5833_2
          DATA   8192        5833_3P
          DATA   8192        5833_4
          DATA   8192        5838_1
          DATA   8192        5838_1P
          DATA   8192        5838_2
          DATA   8192        5838_3P
          DATA   8192        5838_4
          DATA   12288       47444_1
          DATA   12288       47444_1P
          DATA   12288       47444_2
          DATA   16384       47444_3P
          DATA   16384       47444_4

*         SUSPEND INTERVAL (IN SECTORS)

 SI       DATA   1000        5832_1
          DATA   1000        5832_2
          DATA   2           5833_1
          DATA   2           5833_1P
          DATA   1000        5833_2
          DATA   1000        5833_3P
          DATA   1000        5833_4
          DATA   2           5833_1
          DATA   2           5833_1P
          DATA   1000        5833_2
          DATA   1000        5833_3P
          DATA   1000        5833_4
          DATA   2           47444_1
          DATA   2           47444_1P
          DATA   1000        47444_2
          DATA   1000        47444_3P
          DATA   1000        47444_4

*         MODEL NUMBER.  THIS IS TWO BYTES FROM THE MODEL NUMBER
*         FIELD THAT IS UNIQUE FOR EACH DRIVE TYPE.

 MN       DATA   0#3137      5832_1
          DATA   0#3136      5832_2
          DATA   0#4C32      5833_1
          DATA   0#4C32      5833_1P
          DATA   0#4C32      5833_2
          DATA   0#4C32      5833_3P
          DATA   0#4C32      5833_4
          DATA   0#4C31      5838_1
          DATA   0#4C31      5838_1P
          DATA   0#4C31      5838_2
          DATA   0#4C31      5838_3P
          DATA   0#4C31      5838_4
          DATA   0#3153      47444_1
          DATA   0#3153      47444_1P
          DATA   0#3153      47444_2
          DATA   0#3153      47444_3P
          DATA   0#3153      47444_4

 .F       IFEQ   FE,1
          BSS    60          FOR PATCHES DURING CHECKOUT
 .F       ENDIF
          TITLE  MAIN LOOP
** NAME-- MAIN
*
** PURPOSE-- MAIN IDLE LOOP.  LOOK FOR REQUESTS FROM CENTRAL MEMORY
*            AND LOOK FOR INTERRUPTS FROM THE CONTROLLERS.
*
** ENTRY
*         MAIN - AFTER DRIVER IS LOADED
*         MAIN5 - WHEN THE PP IS RESUMED
*         MAIN10 - TO RUN DIAGNOSTICS DURING ERROR RECOVERY
*         MAIN15 - AFTER SEEK, WRITE, OR READ COMMAND STARTED,
*         MAIN20 - WHEN A WRITE, READ,OR RESTORE COMMMAND COMPLETES
          SPACE  2
 MAIN     BSS
          REFAD  DSRTP,CM.PIT REFORMAT ADDRESS OF PP INTERFACE TABLE
                               AND SAVE IN CM.PIT
 MAIN5    BSS
          RJM    IT          INITIALIZE TABLES
 MAIN10   BSS
          RJM    PT          PATH TEST
 MAIN15   BSS
 .F       IFEQ   FE,1        FORCE ERROR IN RUNNING PP DRIVER
          RJM    FER         FORCE ERROR ROUTINE
 .F       ENDIF
          RJM    EI          ENABLE INTERRUPTS
          RJM    PPRQ        CHECK FOR ANY PP REQUESTS
          RJM    GETU        SELECT UNIT REQUESTS, SEEK,
                             AND PROCESS INTERRUPTS
          LDDL   CMNDS
          NJN    MAIN15      IF OUTSTANDING COMMANDS
 MAIN20   BSS
          SOML   CHLCNT
          NJN    MAIN15      IF PP DOESN'T HAVE TO GIVE UP CHANNEL
          RJM    CKC         CHECK IF CHANNEL MUST BE GIVEN UP
          UJN    MAIN15
          SPACE  5,10
 UCMD     BSS                COMMANDS FROM CENTRAL MEMORY
          CON    C.READ
          CON    C.WRITE
          CON    C.FORMAT
 UCMDL    EQU    *-UCMD
          TITLE  COMMANDS
** NAME-- READ
*
** PURPOSE-- PROCESS READ DATA COMMAND.  A TRANSFER NOTIFICATION RESPONSE
*            HAS BEEN RECEIVED AND THE CONTROLLER HAS AT LEAST ONE SECTOR
*            OF DATA IN ITS BUFFER.  TRANSFER THE DATA FROM THE CONTROLLER
*            BUFFER TO CM.
*
** ENTRY  LISTL = NUMBER OF ADDRESS-LENGTH-PAIR ENTRIES IN THE
*                 COMMAND WHICH ARE LEFT TO PROCESS.
*         CMLIST  = LIST OF ADDRESS-LENGTH-PAIRS POINTING TO THE
*                   CM DATA AREA.
          SPACE  2
 READ     CON    0
 READ10   BSS
          LDML   CMLIST+/CM/P.LEN,CSST NUMBER OF BYTES LEFT TO TRANSFER
          STDL   BYTES       BYTES LEFT TO TRANSFER
          SBML   BPS,DT      BYTES PER SECTOR
          ADDL   SECPOS      BYTES PREVIOUSLY TRANSFERRED FROM THIS SECTOR
          MJN    READ20      IF LESS THAN 1 SECTOR LEFT TO TRANSFER
          LDML   BPS,DT      COMPUTE NUMBER OF BYTES TO TRANSFER THIS LOOP
          SBDL   SECPOS
          STDL   BYTES       NUMBER OF BYTES TO TRANSFER TO CURRENT SECTOR
 READ20   BSS
          LDDL   BYTES
          SHN    -1
          STDL   WC          PP WORDS TO TRANSFER
          LDDL   SECPOS
          NJN    READ50      IF BUS CONTROL ALREADY DONE
          LDN    DATAIN      DATA, INFORMATION IN
          RJM    BCS         BUS CONTROL SEQUENCE
 READ30   EQU    *-1         FOR FORCING ERRORS
          LDC    H0A81       STREAM, READ, DMA
          RJM    FUNC        RAISE MASTER OUT
 READ40   EQU    *-1         FOR FORCING ERRORS
          ACN    DC
 READ50   BSS
          LOADF  CMLIST+/CM/P.RMA,CSST CM ADDRESS OF DATA AREA
          CHCM   WC,DC       TRANSFER DATA
          LDDL   WC
          NJN    READ60      IF NOT ALL WORDS TRANSFERRED
          LDDL   BYTES
          RADL   SECPOS      UPDATE SECTOR POSITION
          SBML   BPS,DT      CHECK FOR END OF SECTOR
          ZJN    READ60      IF END OF SECTOR
          LDML   /SS/P.LISTL,CSST CHECK IF MORE CM ADDRESS-LENGTH-PAIRS
          SBN    1
          NJN    READ90      IF MORE CM DATA TO TRANSFER
          LDML   BPS,DT      BYTES PER SECTOR
          SBDL   SECPOS
          SHN    -1
          STDL   WC          PP WORDS TO TRANSFER
          LOADC  CM.CB
          CHCM   WC,DC       MUST TRANSFER A FULL SECTOR
 READ60   BSS
          LDC    MS50
 READ70   BSS
          IJM    READ80,DC   IF SLAVE IN DROPPED
          SBN    1
          NJN    READ70      IF TIMEOUT NOT EXPIRED
          RJM    CSI         CHECK SLAVE IN
 READ80   BSS
          RJM    CRS         CHECK FOR REQUEST SWITCH
          NJN    READ100     IF MORE TO TRANSFER
          LJM    MAIN15
 READ90   BSS
          RJM    UBT         UPDATE BYTES TRANSFERRED
 READ100  BSS
          LJM    READ10
          EJECT
** NAME-- WRITE
*
** PURPOSE-- PROCESS THE WRITE DATA COMMAND.  A TRANSFER NOTIFICATION RESPONSE
*            HAS BEEN RECEIVED.  TRANSFER DATA FROM CM TO THE CONTROLLER BUFFER.
*
** ENTRY  LISTL = NUMBER OF ADDRESS-LENGTH-PAIR ENTRIES IN THE
*                 COMMAND WHICH ARE LEFT TO PROCESS.
*         CMLIST = LIST OF ADDRESS-LENGTH-PAIRS POINTING TO THE
*                  CM DATA AREA.
          SPACE  2
 WRITE    CON    0
 WRI10    BSS
          LDML   CMLIST+/CM/P.LEN,CSST NUMBER OF BYTES LEFT TO TRANSFER
          STDL   BYTES       BYTES LEFT TO TRANSFER
          SBML   BPS,DT      BYTES PER SECTOR
          ADDL   SECPOS      BYTES PREVIOUSLY TRANSFERRED FROM THIS SECTOR
          MJN    WRI20       IF LESS THAN 1 SECTOR LEFT TO TRANSFER
          LDML   BPS,DT      COMPUTE NUMBER OF BYTES TO TRANSFER THIS LOOP
          SBDL   SECPOS
          STDL   BYTES       NUMBER OF BYTES TO TRANSFER TO CURRENT SECTOR
 WRI20    BSS
          LDDL   BYTES
          SHN    -1
          STDL   WC          PP WORDS TO TRANSFER
          LDDL   SECPOS
          NJN    WRI50       IF BUS CONTROL ALREADY DONE
          LDN    DATAOUT     DATA, INFORMATION OUT
          RJM    BCS         BUS CONTROL SEQUENCE
 WRI30    EQU    *-1         FOR FORCING ERRORS
          LDC    H0381       STREAM, WRITE, DMA
          RJM    FUNC        RAISE MASTER OUT
 WRI40    EQU    *-1         FOR FORCING ERRORS
          ACN    DC
 WRI50    BSS
          LOADF  CMLIST+/CM/P.RMA,CSST CM ADDRESS OF DATA AREA
          CMCH   WC,DC       TRANSFER DATA
          LDDL   WC
          NJN    WRI60       IF NOT ALL WORDS TRANSFERRED
          LDDL   BYTES
          RADL   SECPOS      UPDATE SECTOR POSITION
          SBML   BPS,DT      CHECK FOR END OF SECTOR
          ZJN    WRI60       IF END OF SECTOR
          LDML   /SS/P.LISTL,CSST CHECK IF MORE CM ADDRESS-LENGTH-PAIRS
          SBN    1
          NJN    WRI90       IF MORE CM DATA TO TRANSFER
          LDML   BPS,DT      BYTES PER SECTOR
          SBDL   SECPOS
          SHN    -1
          STDL   WC          PP WORDS TO TRANSFER
          LOADC  CM.CB
          CMCH   WC,DC       MUST TRANSFER A FULL SECTOR
 WRI60    BSS
          LDC    MS50
 WRI70    BSS
          IJM    WRI80,DC    IF SLAVE IN DROPPED
          SBN    1
          NJN    WRI70       IF TIMEOUT NOT EXPIRED
          LDN    E30         CHANNEL STAYED ACTIVE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 WRI80    BSS
          RJM    CRS         CHECK FOR REQUEST SWITCH
          NJN    WRI100      IF MORE TO TRANSFER
          LJM    MAIN15
 WRI90    BSS
          RJM    UBT         UPDATE BYTES TRANSFERRED
 WRI100   BSS
          LJM    WRI10
          TITLE  COMMAND SUBROUTINES
** NAME-- ALN
*
** PURPOSE-- ADD LOGICAL PP NUMBER TO UNIT INTERFACE TABLE LOCKWORD.
*            IT IS USED TO DETERMINE IF THE DRIVE IS BEING SUPPORTED
*            IN ALTERNATE OR REDUNDANT ACCESS MODE.
*
** ENTRY
*         UNIT MUST BE LOCKED
          SPACE  2
 ALNX     LJM    **
 ALN      EQU    *-1
          RJM    LUT         LOAD R REGISTER FOR UNIT INTERFACE TABLE
          LDDL   T6          INDEX TO LOCKWORD
          CRDL   T1          READ LOCKWORD
          LDDL   T2
          NJN    ALN10       IF PP NUMBER PRESENT
          LDDL   T3
          LMDL   LPN
          ZJN    ALNX        IF PP NUMBER ALREADY IN LOCKWORD
          LDDL   LPN
          STDL   T2
          UJN    ALN20
 ALN10    BSS
          LMDL   LPN
          ZJN    ALNX        IF PP NUMBER ALREADY IN LOCKWORD
          LDDL   T3
          NJN    ALN30       IF 2ND PP NUMBER PRESENT
          LDDL   LPN
          STDL   T3
 ALN20    BSS
          LDDL   T6
          CWDL   T1
          UJK    ALNX
 ALN30    BSS
          LMDL   LPN
          ZJN    ALNX        IF PP NUMBER ALREADY IN LOCKWORD
          LDC    E505        CM HAS CHANGED
          RJM    INTERR      REPORT ERROR (NO RETURN)
          SPACE  5,20
** NAME-- BCTB
*
** PURPOSE-- BUILD CONFIDENCE TEST WRITE BUFFER
          SPACE  2
 BCTBX    LJM    **
 BCTB     EQU    *-1
          IAN    14B
          LPC    0#7FFF
          STDL   CTPAT       CONFIDENCE TEST PATTERN FIRST WORD MINUS ONE
          STDL   P1
          LDN    0
          STDL   P3
          LOADC  CM.CB       ADDRESS OF PP COMMUNICATIONS BUFFER
          STDL   P2
 BCTB10   BSS
          AODL   P1          BUILD INCREMENTING PATTERN
          STDL   T1
          AODL   P1
          STDL   T2
          AODL   P1
          STDL   T3
          AODL   P1
          STDL   T4
          SBDL   CTPAT
          ADC    -P.CB-4+/CB/P.BUF
          PJN    BCTBX       IF ALL WORDS STORED
          LDDL   P2
          ADDL   P3
          CWDL   T1          STORE IN PP COMMUNICATIONS BUFFER
          AODL   P3
          UJN    BCTB10
          SPACE  5,20
** NAME-- BPTB
*
** PURPOSE-- BUILD PATH TEST BUFFER
          SPACE  2
 BPTBX    LJM    **
 BPTB     EQU    *-1
          LDN    0
          STDL   T1          INDEX TO OUTPUT BUFFER
          LDN    10
          STDL   T2          TIMES TO REPEAT PATTERN
 BPTB10   BSS
          LCN    0           PATTERN IS FFFF, 0000, AAAA, 5555,
          STML   OB,T1        FEFD REPEATED 10 TIMES
          LDN    0
          STML   OB+1,T1
          LDC    0#AAAA
          STML   OB+2,T1
          SHN    -1
          STML   OB+3,T1
          LDC    0#FEFD
          STML   OB+4,T1
          LDN    5
          RADL   T1
          SODL   T2
          ZJN    BPTBX       IF DONE
          UJN    BPTB10
          SPACE  5,20
** NAME-- CCA
*
** PURPOSE-- CHECK CONTROLLER ATTRIBUTES
*          - DISABLE USAGE STATISTIC COUNTING
*          - ENABLE MASTER TERMINATE
*          - DISABLE EXTENT RESPONSE FOR MASTER TERMINATE
*          - ENABLE REPORTING DEVICE FAULT LOG
*          - SET SPEED SELECTION TO 10 MB/S
          SPACE  2
 CCAX     LJM    **
 CCA      EQU    *-1
          LDDL   CMOD
          SHN    8
          LMC    0#FF
          STML   CP+SLAD     CONTROLLER ADDRESS
          LDC    0#201
          STDL   MFID        INTERLOCK COMMANDS, RESPONSES AND DATA
          RJM    LIR         LOGICAL INTERFACE RESET

*         RESTORE CONTROLLER ATTRIBUTES

          LDC    H0202
          STML   CP+OPCD     RESTORE ATTRIBUTES OPERATION CODE
          LDN    6           COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          RJM    SDTM        SET DATA TRANSFER MODE FOR INTERLOCK

*         CHECK ATTRIBUTE PARAMETERS D1, D2, D3, D4, AND D6

          LDC    H0200
          STML   CP+OPCD     REPORT ATTRIBUTES OPERATION CODE
          LDC    0#76C
          STML   CP+FCP
          LDC    0#80D1      REPORT PARAMETERS D1,D2,D3,D4,D6
          STML   CP+FCP+1
          LDC    0#D2D3
          STML   CP+FCP+2
          LDC    0#D4D6
          STML   CP+FCP+3
          LDN    14          COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDN    0
          STDL   T1
          STDL   T2
 CCA10    BSS
          LDML   RPB+8,T1
          LMML   CCAT,T1
          NJK    CCA80       IF PARAMETER ID NOT FOUND
          AODL   T1
          AODL   T1
          SBN    10
          MJN    CCA10       IF NOT ALL PARAMETER IDS CHECKED
 CCA20    BSS
          LDML   RPB+8+1,T2
          LMML   CCAT+1,T2
          NJN    CCA30       IF PARAMETER SET WRONG
          AODL   T2
          AODL   T2
          SBN    8
          MJN    CCA20       IF NOT ALL PARAMETERS CHECKED
          LDML   RPB+8+11
          LPC    0#F02
          LMC    0#F02
          ZJK    CCA70       IF ATTRIBUTE D6 CORRECT

*         LOAD/SAVE ATTRIBUTES

 CCA30    BSS
          LDN    0
          STDL   T1
 CCA40    BSS
          LDML   CCAT,T1     BUILD COMMAND PACKET
          STML   CP+4,T1
          AODL   T1
          LMN    9
          NJN    CCA40       IF FIRST 11 PARAMETER WORDS NOT MOVED
          LDML   RPB+8+9
          STML   CP+FCP+9    PORT A,B CONTROLLER ADDRESS
          LDML   RPB+8+10
          STML   CP+FCP+10   PORT C,D CONTROLLER ADDRESS
          LDML   RPB+8+11
          LPC    0#F0FD
          LMC    0#F02
          STML   CP+FCP+11   SELECT 10 MB/S RATE
          LDC    H0209
          STML   CP+OPCD     LOAD ATTRIBUTES OPERATION CODE
          LDN    30          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          LDC    0#200
          STDL   MFID        INTERLOCK COMMANDS AND RESPONSES ONLY
          RJM    SDTM        SET DATA TRANSFER MODE
          RJM    SA          SAVE ATTRIBUTES
          LDML   RPB+8+11
          LPC    0#F02
          LMC    0#F02
          ZJN    CCA70       IF CHANNEL TRANSFER SPEED CORRECT
          LDC    H8415       SLAVE RESET
          STML   /SS/P.RESET,CSST  INDICATE RESET ISSUED
          RJM    IR          ISSUE RESET
          RJM    IH          INTERRUPT HANDLER
          LDN    0
          STML   /SS/P.RESET,CSST  INDICATE RESET COMPLETE
          LDN    ID16
          RJM    SFP         SEARCH FOR PARAMETER
          MJK    CCA80       IF PARAMETER NOT FOUND
          LDML   RPB+6,T3
          LPC    0#FEE0
          LMC    0#6000
          NJK    CCA80       IF SLAVE RESET FAILED
 CCA70    BSS
          STDL   MFID        CLEAR MASK FOR INTERLOCK DATA
          RJM    DTM         DETERMINE TRANSFER MODE
          RJM    SEL         ENSURE STREAMING FOR COMMANDS AND RESPONSES
          STDL   CTM         CLEAR CHANGE TRANSFER MODE FLAG
          RJM    DCM         DESELECT THE CONTROLLER
          RJM    SDTM        SET DATA TRANSFER MODE FOR STREAMING
          LJM    CCAX
 CCA80    BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 CCAT     BSS                EXPECTED CONTROLLER ATTRIBUTES
          DATA   0#2D1,0#100
          DATA   0#2D2,0#100
          DATA   0#2D3,0#100
          DATA   0#2D4,0#100
          DATA   0#7D6
          SPACE  5,20
** NAME-- CCLOCK
*
** PURPOSE-- CLEARS CHANNEL LOCK
          SPACE  2
 CCLX     LJM    **
 CCLOCK   EQU    *-1
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          STDL   CLF         CHANNEL LOCK FLAG
          LDDL   CHAN        CHANNEL NUMBER = OFFSET IN TABLE
          STDL   T5
          RJM    CLOCK       CLEAR CHANNEL LOCKWORD
          UJK    CCLX
          SPACE  5,20
** NAME-- CDA
*
** PURPOSE-- CHECK DRIVE ATTRIBUTES
*          - ENSURE PARITY DRIVE CORRECTION DISABLED
*          - ENSURE FACILITY TIMEOUT IS 20 SECONDS
*          - ENSURE DRIVE INTERRUPT SIZE IS CORRECT FOR WRITES
          SPACE  2
 CDAX     LJM    **
 CDA      EQU    *-1

*         RESTORE DRIVE ATTRIBUTES

          LDC    H0202       RESTORE ATTRIBUTES OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDN    6
          RJM    ODFP        OUTPUT DATA FROM PP

*         CHECK ATTRIBUTE 6E.  ENSURE PARITY DRIVE CORRECTION IS DISABLED.

          LDC    H0200
          STML   CP+OPCD     REPORT ATTRIBUTE OPERATION CODE
          LDC    0#36C
          STML   CP+FCP      REPORT ATTRIBUTE 6E
          LDC    0#806E
          STML   CP+FCP+1
          LDN    10          COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDML   RPB+8
          LMC    0#46E
          NJK    CDA50       IF RESPONSE INCORRECT
          LDML   UNITS,UX    INDICATE PARITY DRIVE CORRECTION DISABLED
          LPC    0#FDFF
          STML   UNITS,UX
          LDML   RPB+9
          LMC    0#C0A0
          ZJN    CDA10       IF PARITY DRIVE CORRECTION DISABLED
          RJM    LA6E        LOAD ATTRIBUTE 6E
          RJM    SA          SAVE ATTRIBUTES

*         CHECK ATTRIBUTE PARAMETER 6F

 CDA10    BSS
          LDC    H0200
          STML   CP+OPCD     REPORT ATTRIBUTES OPERATION CODE
          LDC    0#36C
          STML   CP+FCP      REPORT PARAMETER 6F
          LDC    0#806F
          STML   CP+FCP+1
          LDN    10          COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDML   RPB+8
          LMC    0#276F
          NJK    CDA50       IF RESPONSE INCORRECT
          LDML   RPB+8+11
          LMML   BPS,DT
          NJN    CDA15       IF BURST SIZE WRONG
          LDML   RPB+8+16
          LMC    0#131
          ZJK    CDA30       IF FACILITY TIMEOUT CORRECT
 CDA15    BSS
          LDN    0
          STDL   T1
 CDA20    BSS
          LCN    0           PARAMETERS WITH FFFF WILL NOT BE CHANGED
          STML   CP+4,T1
          AODL   T1
          LMN    20
          NJN    CDA20       IF MORE WORDS TO MOVE
          STML   CP+FCP+8    SET INTERRUPT AND BURST SIZE
          STML   CP+FCP+10
          LDML   BPS,DT
          STML   CP+FCP+9
          STML   CP+FCP+11
          LDC    0#131       SET FACILITY TIMEOUT TO 20 SECONDS
          STML   CP+FCP+16
          LDC    0#2D00
          STML   CP+FCP+17
          LDC    H0209
          STML   CP+OPCD     LOAD ATTRIBUTES OPERATION CODE
          LDC    0#276F
          STML   CP+FCP      PARAMETER 6F
          LDN    46          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          RJM    SA          SAVE ATTRIBUTES

*         CHECK ATTRIBUTE PARAMETER D8

 CDA30    BSS
          LDDL   DT          DRIVE TYPE
          SBN    2
          MJK    CDAX        IF INTERRUPT SIZE NOT USED
          LDC    H0200
          STML   CP+OPCD     REPORT ATTRIBUTES OPERATION CODE
          LDC    0#36C
          STML   CP+FCP      REPORT PARAMETER D8
          LDC    0#80D8
          STML   CP+FCP+1
          LDN    10          COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDML   RPB+8
          LMC    0#09D8
          NJK    CDA50       IF RESPONSE INCORRECT
          LDML   RPB+8+2
          LMML   IS,DT
          NJN    CDA40       IF INTERRUPT SIZE FOR WRITES IS WRONG
          LDML   RPB+8+4
          LMML   BPS,DT
          ZJK    CDAX        IF BURST SIZE FOR WRITES IS CORRECT
 CDA40    BSS
          LDN    0
          STML   CP+FCP+1
          STML   CP+FCP+3
          LDML   BPS,DT
          STML   CP+FCP+4    BURST SIZE FOR WRITES
          LDC    0#9D8
          STML   CP+FCP      PARAMETER D8
          LDML   IS,DT       SET INTERRUPT SIZE FOR WRITES
          STML   CP+FCP+2
          LDC    H0209
          STML   CP+OPCD     LOAD ATTRIBUTES OPERATION CODE
          LDN    16          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          RJM    SA          SAVE ATTRIBUTES
          UJK    CDAX
 CDA50    BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- CFME
*
** PURPOSE-- CHECK FOR MEDIA ERROR
*
** EXIT   A = 0 IF MEDIA ERROR AND FAILING ADDRESS IS PRESENT
          SPACE  2
 CFME20   BSS
          LDN    1           INDICATE MEDIA ERROR NOT FOUND
 CFMEX    LJM    **
 CFME     EQU    *-1
          LDML   RS+/RS/P.ERRID
          NJN    CFMEX       IF NOT MEDIA ERROR
          LDK    ID26        DRIVE MACHINE EXCEPTION
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    CFMEX       IF ID26 NOT FOUND
          LDML   RPB+5,T3
          SHN    -8
          SBN    17
          MJN    CFME20      IF NO COMMAND ENDING STATUS
          LDML   RPB+13,T3   COMMAND ENDING STATUS
          LPN    77B
          SBN    0#11
          ZJN    CFMEX       IF ECC ERROR
          SBN    2
          ZJN    CFMEX       IF MISSING SYNC
          SBN    6           CHECK SECTOR NOT FOUND
          UJN    CFMEX
          SPACE  5,20
** NAME-- CHGCH
*
** PURPOSE-- SET CHANNEL NUMBER IN CHANNEL INSTRUCTIONS
*
** ENTRY  CHAN = CHANNEL NUMBER
          SPACE  2
 CHGX     LJM    **
 CHGCH    EQU    *-1
          LDN    0
          STDL   T1          CHANGE DISK CHANNEL INSTRUCTIONS
 CHG10    LDML   CONCH,T1    ADDRESS OF CHANNEL INSTRUCTIONS
          ZJN    CHGX        END OF LIST
          STDL   T2
          LDIL   T2
          SCN    37B
          LMDL   CHAN        CHANNEL NUMBER
          STIL   T2
          AODL   T1
          UJK    CHG10
          SPACE  5,20
** NAME-- CKC
*
** PURPOSE-- CHECK IF MAINTENANCE PP WANTS THE CHANNEL.
          SPACE  2
 CKCX     LJM    **
 CKC      EQU    *-1
          LDK    C.CHCNT     NUMBER OF REQUESTS TO PROCESS BEFORE
          STML   CHLCNT       GIVING UP THE CHANNEL
          LOADC  CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          ADDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          CRDL   T1          READ CHANNEL LOCKWORD
          LDDL   T2
          LPN    1
          ZJK    CKCX        IF MAINTENANCE PP DOES NOT WANT THE CHANNEL
          LDDL   UNUML
          ZJK    CKCX        IF NO UNITS
          RJM    CUB         CHECK UNIT BUSY
          STDL   MALET       SETTING MALET NONZERO PREVENTS STARTING
                              NEW DISK REQUESTS
          NJN    CKCX        IF OUTSTANDING COMMANDS
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          PAUSE  130000      DELAY 130 MILLISECONDS TO ALLOW
                             MAINTENANCE PP TO GET THE CHANNEL
          RJM    SCLOCK      SET CHANNEL LOCK
          UJK    CKCX
 CHLCNT   CON    C.CHCNT     NUMBER OF REQUESTS TO PROCESS BEFORE
                              GIVING UP THE CHANNEL
          SPACE  5,20
** NAME-- CLOCK
*
** PURPOSE-- CLEAR LOCKWORD
*
** ENTRY
*         T7 = POINTER RMA
*         T5 = OFFSET TO LOCKWORD FROM RMA
          SPACE  2
 CLKX     LJM    **
 CLOCK    EQU    *-1
 CLK10    BSS
          LCN    0
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        RMA OF TABLE
          ADDL   T5          ADD LOCKWORD OFFSET
          STDL   T6
          RDSL   T1          WRITE INTERMEDIATE VALUE
          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJN    CLK10       IF ANOTHER INTERLOCK OPERATION IS IN PROGRESS
          LDDL   LPN
          SBDL   T4
          ZJN    CLK20       IF LOCK WAS OK
          LDDL   T6
          CWDL   T1          RESTORE THE LOCKWORD
          RJM    HANG        HANG, THE LOCK WAS INCORRECT
 CLK20    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6
          CWDL   T1          CLEAR THE LOCKWORD
          UJK    CLKX
          SPACE  5,20
** NAME-- CLR
*
** PURPOSE-- CHECK FOR LABEL READ.  NOS/VE ATTEMPTS TO READ THE LABEL
*            BEFORE IT FORMATS.  THE DRIVER DOES NOT KNOW WHETHER THE
*            DRIVE IS TO BE FORMATTED.  THUS, IF AN ERROR OCCURS READING
*            THE LABEL, THE DRIVE CAN NOT ALWAYS BE DOWNED.
*
** EXIT   (A) .LT. 0 IF NOT LABEL READ AT DEADSTART, OTHERWISE
*         (A) .EQ. SECTOR NUMBER TO BE READ
          SPACE  2
 CLR20    BSS
          LCN    0
 CLRX     LJM    **
 CLR      EQU    *-1
          LDDL   PTF
          ZJN    CLR20       IF INITIALIZATION PATH TEST
          LDML   /SS/P.CT,CSST
          NJN    CLR20       IF NOT INITIALIZATION CONFIDENCE TEST
          LDML   RS+/RS/P.ERRID
          ADC    -E140
          ZJN    CLR10       IF WRONG DRIVE TYPE CONFIGURED
          SBN    E141-E140
          NJN    CLR20       IF NOT *DRIVE INITIALIZATION REQUIRED*
 CLR10    BSS
          LDML   /SS/P.FNC,CSST
          ADML   RQ+/RQ/P.CYL,CSST
          ADML   RQ+/RQ/P.TRACK,CSST
          NJN    CLR20       IF NOT NOS/VE LABEL
          LDML   RQ+/RQ/P.SECTOR,CSST
          UJN    CLRX
          SPACE  5,20
** NAME-- CFFMT
*
** PURPOSE-- CLEAR THE FORCE FORMAT FLAG IN THE UNIT INTERFACE TABLE.
*
** EXIT   P5 IS UNCHANGED
          SPACE  2
 CFFMTX   LJM    **
 CFFMT    EQU    *-1
 CFFMT10  BSS
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    CFFMT10     IF LOCK COULD NOT BE SET
          LDK    -/UIT/K.FRCFMT  CLEAR FORCE FORMAT FLAG
          STDL   T3
          LCN    0
          STDL   T2
          STDL   T4
          STDL   T5
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          RDCL   T2          -LOGICAL OR- THE FORCE FORMAT FLAG
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          UJK    CFFMTX
          SPACE  5,20
** NAME-- COD
*
** PURPOSE-- CHECK FOR OFF LINED DRIVE.  THIS ROUTINE CHECKS FOR AN
*            OFF LINED DRIVE OF A PARITY UNIT.  IT WILL ISSUE A SPIN UP DRIVE
*            COMMAND TO SEE IF THE DRIVE IS USEABLE, AND IF SO, FORMAT
*            THE UNIT IF NECESSARY, THEN SET UP TABLES SO THAT ROUTINE GETU
*            WILL RESTORE THE DISK IN THE BACKGROUND.
*
** EXIT-- A NONZERO IF DRIVE OFF LINE
          SPACE  2
 COD200   BSS
          LDN    1
          UJN    CODX
 COD100   BSS
          LDN    0
 CODX     LJM    **
 COD      EQU    *-1
          LDDL   DT          DRIVE TYPE
          SBN    3
          ZJN    COD10       IF 5833_1P
          SBN    5
          ZJN    COD10       IF 5838_1P
          SBN    2
          ZJN    COD10       IF 5838_3P
          SBN    3
          ZJN    COD10       IF 47444_1P
          SBN    2
          ZJN    COD10       IF 47444_3P
          ADN    10
          NJN    COD100      IF NOT 5833_3P
 COD10    BSS

*         THE RESET FORCES THE CONTROLLER TO CHECK FOR A PENDING INTERRUPT.
*         THE PENDING INTERRUPT COULD INDICATE THAT A RESTORE HAS COMPLETED
*         AND PREVENT THIS SIDE FROM STARTING A RESTORE.

          RJM    LIR         LOGICAL INTERFACE RESET
          RJM    RAS         REPORT ADDRESSEE STATUS
          SHN    8
          MJN    COD15       IF OFF LINE DRIVE
          LDC    /UIT/K.PARPRO+DRNUM  PARITY PROTECTION ENABLED
          RJM    UPPS        UPDATE PARITY PROTECTION STATUS
          UJN    COD100      EXIT - NO OFF LINE DRIVE
 COD15    SHN    1
          PJN    COD20       IF RESTORE NOT IN PROGRESS
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          MJK    COD200      IF THIS PP DOING THE RESTORE
 COD20    BSS
          LDML   /SS/P.RECOV,CSST
          ADML   /SS/P.RQTRY,CSST
          ZJN    COD23       IF FIRST TIME FOR CONFIDENCE TEST
          LDDL   PD
          RJM    UPPS        UPDATE PARITY PROTECTION STATUS
          UJK    COD200
 COD23    LDML   RPB+9
          LPN    77B
          STDL   PD
          STML   ODN,CSST    OFF LINED DRIVE NUMBER
          RJM    SUD         SPIN UP DRIVE
          ZJK    COD200      IF ERROR
          LDC    /UIT/K.RESTDR   SET RESTORING DRIVE FLAG
          ADDL   PD              DRIVE NUMBER BEING RESTORED
          RJM    UPPS        UPDATE PARITY PROTECTION STATUS
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T5          READ UNIT FORCE FORMAT FLAG
          LDDL   T5+/UIT/P.FRCFMT
          SHN    /UIT/L.FRCFMT+2
          PJK    COD25       IF NOT FORCE FORMAT
          LDN    1           INDICATE UNIT CLUSTERED
          RJM    FU          FORMAT UNIT
          RJM    CFFMT       CLEAR FORCE FORMAT FLAG IN UIT
          UJK    COD40
 COD25    LDC    0#302
          STML   CP+OPCD     REPORT ADDRESSEE STATUS OPERATION CODE
          LDN    10          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          LDML   RPB+9
          SHN    3
          PJN    COD30       IF UNIT NOT FORMATTED
          LDML   RPB+7
          LPN    77B
          LMML   DD,DT
          NJN    COD30       IF WRONG NUMBER OF DATA DRIVES
          LDML   RPB+11
          LMML   BPS,DT
          ZJN    COD40       IF CORRECT SECTOR SIZE
 COD30    BSS
          LDN    1           INDICATE UNIT CLUSTERED
          RJM    FU          FORMAT UNIT
 COD40    BSS
          LDML   UNITS,UX
          LPC    0#F7FF
          LMC    0#800
          STML   UNITS,UX    SET RESTORE IN PROGRESS
          LDN    E55         RESTORING DRIVE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDML   UNITS,UX
          LPC    340B
          ADML   ODN,CSST
          STML   RS+/RS/P.UNIT  CONTROLLER, DRIVE ADDRESS
          LDN    0
          STML   CRC,CSST    CURRENT RESTORE CYLINDER
          STML   /SS/P.CRTS,CSST  CURRENT TRACK, SECTOR TO RESTORE
          STML   RTM,CSST    REQUESTS TO MULTIPLEX PER CYLINDER DURING RESTORE
          STML   RS+/RS/P.SCYL  STARTING CYLINDER
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          LJM    COD200
          SPACE  5,20
** NAME-- COR
*
** PURPOSE-- CHECK OPERATIONAL AND READY
*
** EXIT
*         A = NEGATIVE VALUE IF ANY PHYSICAL DRIVE OF THE LOGICAL UNIT
*             IS NOT OPERATIONAL OR NOT READY.
          SPACE  2
 CORX     LJM    **
 COR      EQU    *-1
          LCN    0
          STML   CORF        INDICATE NO OFF-LINE DRIVE
          LDML   /SS/P.UNIT,CSST
          LPN    77B
          STDL   PD          PHYSICAL DRIVE
          LPN    70B
          NJN    COR5        IF NOT DRIVE NUMBER 0-7
          RJM    RAS         REPORT ADDRESSEE STATUS
          LPN    77B
          STML   CORF        FAILING DRIVE
 COR5     BSS
          RJM    DDT         DETERMINE DRIVE TYPE
          MJN    CORX        IF ERROR
          LDC    0#301+400000B  REPORT CONDITION OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDC    0#2D5
          STML   CP+FCP
          LDDL   PD
          SHN    8
          STML   CP+FCP+1    PHYSICAL DRIVE OF LOGICAL UNIT
          LDML   TD          TOTAL DRIVES IN CLUSTER
          LMN    1
          ZJN    COR10       IF 1X DRIVE
          LDML   /SS/P.UNIT,CSST
          SCN    0#38
          STML   CP+SLAD     LOGICAL ADDRESS
 COR10    BSS
          LDN    10          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          LDML   CORF
          LMD    PD
          ZJN    COR25       IF THIS DRIVE IS OFF LINE
          LDML   RPB+6
          SHN    10
          MJN    COR30       IF NOT OPERATIONAL
          SHN    1
          MJN    COR30       IF NOT READY
 COR25    BSS
          RJM    UPD         UPDATE DRIVE NUMBER
          NJK    COR5        IF MORE DRIVES TO CHECK
 COR30    BSS
          LJM    CORX
 CORF     DATA   0
          SPACE  5,20
** NAME-- CQLOCK
*
** PURPOSE-- CLEARS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE
          SPACE  2
 CQLX     LJM    **
 CQLOCK   EQU    *-1
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CQLX
          SPACE  5,20
** NAME-- CRS
*
** PURPOSE-- CHECK FOR REQUEST SWITCH
*
** EXIT   A NOT EQUAL 0 IF MORE TO TRANSFER
          SPACE  2
 CRSX     LJM    **
 CRS      EQU    *-1
          LDDL   WC
          NJK    CRS40       IF NOT ALL DATA TRANSFERRED
          RJM    UBT         UPDATE BYTES TRANSFERRED
          LDN    0
          STDL   T2
          LDML   /SS/P.TOTAL,CSST
          SHN    2
          PJK    CRS40       IF NOT USING MASTER TERMINATE
          SHN    -2
          LPC    777B
          SBN    1
          NJN    CRS40       IF MORE SECTORS TO TRANSFER
          LOADF  /SS/P.REQ,CSST
          STDL   T1
          ADN    3
          CRDL   T4          READ STREAM BIT IN REQUEST
          LDDL   T4
          SHN    2
          MJN    CRS20       IF CONCATENATED REQUEST
          LDN    0#A         MASTER TERMINATE
          UJN    CRS42
 CRS20    BSS
          LDDL   CSST
          ADK    RQ
          STML   CRS30       ADDRESS TO STORE PVA, RMA
          LDN    2
          STDL   T2
          LDDL   T1
          CRML   *,T2        REREAD NEXT PVA AND RMA
 CRS30    EQU    *-1
 CRS40    BSS
          LDN    0           NO MASTER TERMINATE
 CRS42    BSS
          RJM    GES         GET ENDING STATUS
          LDDL   WC
          ZJN    CRS45       IF ALL WORDS TRANSFERRED
          RJM    SRR         SHOULD RESPONSE BE READ
          UJN    CRS60
 CRS45    BSS
          LDDL   STATUS
          SHN    -4
          LPN    3
          STDL   DELAY       SAVE DELAY BITS
          STDL   SECPOS      SECPOS = 0 IF STAYING IN READ
          RJM    UDA         UPDATE DISK ADDRESS
          LDDL   T2
          ZJN    CRS50       IF NOT REQUEST CONCATENATION
          RJM    CSWIT       SWITCH TO NEXT REQUEST
 CRS50    BSS
          LDDL   DELAY
          NJN    CRS60       IF DELAY
          LDDL   SBS
          ZJN    CRS60       IF TIME TO SUSPEND DATA TRANSFER
          LDML   /SS/P.TOTAL,CSST
          LPC    777B
          ZJN    CRS60       IF LAST SECTOR TRANSFERRED
          UJK    CRSX
 CRS60    BSS
          RJM    DCM         DESELECT THE CONTROLLER
          LDN    0
          LJM    CRSX
          SPACE  5,20
** NAME-- CSC
*
** PURPOSE-- COMPUTE SECTOR COUNT TO TRANSFER
          SPACE  2
 CSCX     BSS
          LDML   SPT,DT      SECTORS PER TRACK
          SBML   /SS/P.CURSEC,CSST
          SBML   SSPC,DT     SPARE SECTORS PER CYLINDER
          RADL   TOTAL
          STML   /SS/P.TOTAL,CSST  SECTORS TO TRANSFER
          LJM    **
 CSC      EQU    *-1
          LDML   /SS/P.CURTRK,CSST
          STDL   T1          TRACK
          SHN    8
          ADML   /SS/P.CURSEC,CSST
          STML   CP+FCP+4    TRACK, SECTOR FOR COMMAND PACKET
          LDML   CTC,DT      CONFIDENCE TEST CYLINDER
          STML   CP+FCP+3    CYLINDER FOR COMMAND PACKET
          LDN    0
          STDL   TOTAL
          STML   CP+FCP+1    UPPER WORD OF SECTOR COUNT
 CSC10    BSS
          AODL   T1
          LMML   TPC,DT      TRACKS PER CYLINDER
          ZJK    CSCX        IF LAST TRACK
          LDML   SPT,DT      SECTORS PER TRACK
          RADL   TOTAL
          UJN    CSC10
          SPACE  5,20
** NAME-- CSI
*
** PURPOSE-- CHECK SLAVE IN.  REPORT SLAVE IN DID NOT DROP, ELSE
*            EXIT TO THE CALLING ROUTINE.  ON READS, IF SLAVE IN
*            DROPS, THE CHANNEL WILL NOT BE INACTIVE UNTIL THE
*            BUFFER IS EMPTY.
          SPACE  2
 CSIX     LJM    **
 CSI      EQU    *-1
          LDC    H00E1       FUNCTION FOR READ STATUS REGISTER
          RJM    RDRG        READ REGISTER
          SHN    6
          PJN    CSIX        IF SLAVE IN NOT SET
          LDN    E30         CHANNEL STAYED ACTIVE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- CSWIT
*
** PURPOSE-- SWITCH TO THE NEXT REQUEST
          SPACE  2
 CSWX     LJM    **
 CSWIT    EQU    *-1
          LDML   RQ+/RQ/P.NEXT,CSST  PUT RMA OF NEXT REQUEST IN SS TABLE
          STML   /SS/P.REQ,CSST
          LDML   RQ+/RQ/P.NEXT+1,CSST
          STML   /SS/P.REQ+1,CSST
          LDML   RQ+/RQ/P.NEXTPV,CSST  PUT PVA OF NEXT REQUEST IN SS TABLE
          STML   /SS/P.PVA,CSST
          LDML   RQ+/RQ/P.NEXTPV+1,CSST
          STML   /SS/P.PVA+1,CSST
          LDML   RQ+/RQ/P.NEXTPV+2,CSST
          STML   /SS/P.PVA+2,CSST
          LDML   RQ+/RQ/P.CYL,CSST
          STDL   T1          SAVE CYLINDER OF LAST REQUEST
          RJM    UREQ        READ NEXT REQUEST INTO RQ
          LDML   RQ+/RQ/P.SWIT,CSST
          LPC    777B
          LMC    0#8000      INDICATE MASTER TERMINATE
          STML   /SS/P.TOTAL,CSST  SECTORS TO TRANSFER
          LDML   RQ+/RQ/P.CYL,CSST
          SBD    T1
          NJN    *           IF NOT SAME CYLINDER
          LDML   /SS/P.CURSEC,CSST CURRENT SECTOR - 1
          LMML   RQ+/RQ/P.SECTOR,CSST SECTOR OF NEXT REQUEST
          NJN    *           IF SECTOR NUMBER WRONG
          LDML   /SS/P.CURTRK,CSST  CURRENT TRACK
          LMML   RQ+/RQ/P.TRACK,CSST  TRACK ADDRESS OF NEXT REQUEST
          NJN    *           TRACK NUMBER WRONG
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
          LDDL   FNC
          ZJN    CSW10       IF READ, SEND RESPONSE OF COMPLETED REQUEST

*         IF WRITE, DON'T SEND RESPONSES FOR COMPLETED REQUESTS.
*         FOR WRITE ERROR RECOVERY, RESTART ALL REQUESTS.

          AOML   /SS/P.NCOMW,CSST  INCREMENT NUMBER OF COMPLETED WRITE REQUESTS
          UJN    CSW30
 CSW10    BSS
          RJM    RDWTOK      SEND RESPONSE FOR GOOD READ
 CSW30    BSS
          UJK    CSWX
          SPACE  5,20
** NAME-- CT
*
** PURPOSE-- CONFIDENCE TEST.  CHECK TO SEE IF THE DRIVE IS CLUSTERED AND
*            FORMATTED TO MATCH THE EXPECTED DRIVE TYPE.  IF THE COMMAND
*            IS FORMAT, FORMAT AND CLUSTER THE DRIVE.  IF A DRIVE OF A
*            PARITY UNIT IS OFF LINED, ISSUE A SPIN UP DRIVE COMMAND TO
*            DETERMINE IF THE DRIVE IS USEABLE, FORMAT THE OFF LINED DRIVE
*            IF NECESSARY, AND SET FLAG BITS TO INITIATE A RESTORE OF THE
*            DRIVE.  ENSURE ALL DRIVE ATTRIBUTES ARE LOADED AND SAVED, THEN
*            WRITE, READ, AND VERIFY DATA ON A RESERVED CYLINDER.
*
** ENTRY
*         FROM GETU IF A REQUEST IS PRESENT AND THE CONFIDENCE TEST
*         HAS NOT BEEN RUN FOR A UNIT AFTER THE PP WAS LOADED OR RECEIVED
*         A RESUME.  ALSO, FROM GETU IF A REQUEST IS PRESENT AND THE CAUSE
*         OF AN ERROR MUST BE ISOLATED BETWEEN MEDIA AND OTHER.
          SPACE  2
 CTX      LJM    **
 CT       EQU    *-1
          RJM    ALN         ADD LOGICAL PP NUMBER TO LOCKWORD
          LDM    /SS/P.DT,CSST
          SHN    -4
          STDL   DT          DEVICE TYPE

*         DRIVE RESET COULD TAKE UP TO 15 SECONDS, SO ONLY DO IT ONCE PER
*         ERROR DURING ERROR PROCESSING.

          LDML   /SS/P.RECOV,CSST
          LMN    1
          ZJN    CT10        IF RUNNING CONFIDENCE TEST TO ISOLATE TO MEDIA ERROR
          LDML   /SS/P.RQTRY,CSST  RETRY COUNT
          LMN    1
          NJN    CT20        IF NOT FIRST ERROR RETRY
 CT10     BSS
          RJM    DPR         DRIVE POWER ON RESET

*         IF THE LOGICAL UNIT HAS PARALLEL DATA DRIVES, ENSURE THAT THE
*         CONTROLLER SUPPORTS PARALLEL MODE.

 CT20     BSS
          LDML   DD,DT       DATA DRIVES PER LOGICAL UNIT
          SBN    1
          ZJN    CT30        IF THIS DRIVE WILL WORK IN SERIAL MODE
          LDC    H0200       REPORT ATTRIBUTE OPERATION CODE
          RJM    SOC         SET OPERATION CODE AND CONTROLLER
*         LDC    0#36C
          STML   CP+FCP
          LDC    0#80DA
          STML   CP+FCP+1    REPORT PARAMETER DA
          LDN    10          COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDML   RPB+8+1
          SHN    9
          MJN    CT30        IF CONTROLLER SUPPORTS PARALLEL DRIVES
          LDC    E142        CONTROLLER DOES NOT SUPPORT PARALLEL
          LJM    CT75

*         ENSURE MODEL NUMBER OF DRIVE IS CORRECT.  IF THE DRIVE IS 5833_1P OR
*         5833_3P AND THE DRIVE IS OFF LINED, IT MAY BE NECESSARY TO OBTAIN THE
*         MODEL NUMBER FROM THE SECOND DRIVE.

 CT30     BSS
          LDML   /SS/P.UNIT,CSST
          LPN    77B
          STDL   PD          PHYSICAL DRIVE
          RJM    DDT         DETERMINE DRIVE TYPE
          MJK    CT160       IF ERROR
          LDC    H0200
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDC    0#36C
          STML   CP+FCP
          LDC    0#8050
          STML   CP+FCP+1
          LDML   TD          TOTAL DRIVES
          LMN    1
          ZJN    CT37        IF SINGLE DRIVE
          LDML   CP+SLAD
          SCN    0#38
          STML   CP+SLAD     ENSURE STRING BIT CLEAR
 CT37     BSS
          LDK    77
          STDL   T1
 CT38     BSS
          STML   RPB-1,T1    INITIALIZE RESPONSE BUFFER
          SODL   T1
          NJN    CT38        IF MORE WORDS TO INITIALIZE
          LDN    10          COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDML   TD
          STDL   T1
          LDN    0
          STDL   T2
 CT39     BSS
          LDML   RPB+8+26,T2
          NJN    CT40        IF MODEL NUMBER PRESENT
          SODL   T1
          ZJN    CT50        IF NO MODEL NUMBER
          LDN    12
          RADL   T2
          UJN    CT39
 CT40     LDML   RPB+8+26,T2
          LMML   MN,DT       EXPECTED MODEL NUMBER
          ZJK    CT80        IF CORRECT MODEL NUMBER
 CT50     BSS
          LDN    0
          STDL   T1
 CT60     BSS
          LDML   RPB+8+26    SEARCH FOR ACTUAL MODEL NUMBER
          LMML   MN,T1
          ZJN    CT70        IF ACTUAL MODEL NUMBER FOUND
          AODL   T1
          SBN    17
          MJN    CT60        IF MORE MODELS TO CHECK
          LDC    E141        DRIVE INITIALIZATION REQUIRED
          STML   RS+/RS/P.ADT
          UJN    CT80
 CT70     BSS
          LDDL   T1
          STML   RS+/RS/P.ADT  ACTUAL DRIVE TYPE
          LDC    E140        XXXX CONFIGURED YYYY FOUND
 CT75     BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LJM    EPF8        SEND ABNORMAL RESPONSE
 CT80     BSS
          LDML   /SS/P.FNC,CSST
          SBN    2
          NJN    CT110       IF NOT FORMAT COMMAND
          LDML   HSTF
          ZJN    CT90        IF NOT HEAD SHIFT DETECT
          RJM    HSDT        INVOKE HEAD SHIFT DETECTION TEST
          UJK    CT165
 CT90     RJM    IU          INITIALIZE UNIT
          UJK    CT150
 CT110    BSS
          RJM    COR         CHECK OPERATIONAL AND READY
 CT112    MJK    CT160       IF NOT OPERATIONAL OR NOT READY
          LDML   RS+/RS/P.ADT
          LMC    E141
          ZJN    CT118       IF NOT CLUSTERED OR WRONG MODEL
          LDM    RS+/RS/P.ADT
          SBDL   DT
          NJN    CT118       IF WRONG TYPE
          LDML   /SS/P.UNIT,CSST
          LPN    77B
          STDL   PD          PHYSICAL DRIVE
          RJM    DDT         DETERMINE DRIVE TYPE
          MJK    CT112       IF ERROR
          RJM    IUF         IS UNIT FORMATTED
          ZJN    CT118       IF UNIT FORMATTED CORRECTLY
          STML   RS+/RS/P.ADT  ACTUAL DRIVE TYPE
 CT118    BSS
          LDML   RS+/RS/P.ADT  ACTUAL DRIVE TYPE
          STDL   T1
          SBDL   DT          EXPECTED DRIVE TYPE
          ZJN    CT150       IF CORRECT DRIVE TYPE
          LDDL   T1          ACTUAL DRIVE TYPE
          SBN    17
          PJN    CT120       IF DRIVE TYPE WAS NOT DETERMINED
          LDC    E140        XXXX CONFIGURED - FOUND YYYY
          STDL   T1
 CT120    BSS
          LDDL   T1          ERROR CODE (140 OR 141)
          RJM    EP          ERROR PROCESSING (NO RETURN)
 CT150    BSS
          RJM    COD         CHECK FOR OFF LINE DRIVE
          NJN    CT160       IF DRIVE OFF LINE
          RJM    CDA         CHECK DRIVE ATTRIBUTES
 CT160    BSS
          RJM    CTDT        CONFIDENCE TEST DATA TRANSFER
 CT165    LDML   /SS/P.FNC,CSST
          SBN    2
          NJN    CT170       IF NOT FORMAT COMMAND
          STDL   IF          CLEAR INITIALIZATION FLAG
          RJM    PDR         PREPARE NORMAL DISK RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          LDN    1
          STDL   CMNDS       ONE COMMAND IN PROGRESS
          RJM    DCR         DELINK COMPLETED REQUEST
          RJM    RESPIN      UPDATE -IN- POINTER FOR RESPONSE BUFFER
          RJM    UUT         UNLOCK UNIT TABLE
          UJN    CT180
 CT170    BSS
          RJM    SFRR        CLEAR CIP, IF, UPSB
 CT180    BSS
          LDN    1
          STML   /SS/P.CT,CSST  INDICATE TEST COMPLETED SUCCESSFULLY
          LDML   /SS/P.RECOV,CSST
          LMN    1
          ZJN    CT190       IF CONFIDENCE TEST PART OF REQUEST RECOVERY
          LDN    0
          STML   /SS/P.RQTRY,CSST  CLEAR REQUEST RETRY COUNTER
          STML   /SS/P.RECOV,CSST  SO SPIN UP CAN OCCUR IN ROUTINE COD
 CT190    BSS
          UJK    CTX
          SPACE  5,20
** NAME-- CTDT
*
** PURPOSE-- CONFIDENCE TEST DATA TRANSFER
          SPACE  2
 CTDTX    LJM    **
 CTDT     EQU    *-1

*         WRITE THE CYLINDER

          LCN    0
          STML   CTME,CSST   MAKE MEDIA ERROR TABLE LOOK EMPTY
          STML   CTME+1,CSST
          STML   CTME+2,CSST
          LDN    1
          STDL   FNC         INDICATE WRITE OPERATION
          RJM    SSA         SET STARTING ADDRESS
          IFNE   TB,1        SO TRACE BUFFER NOT OVERWRITTEN
          RJM    BCTB        BUILD CONFIDENCE TEST BUFFER
          ENDIF
 CTDT10   BSS                ENTRY IF MEDIA ERROR
          RJM    CSC         COMPUTE SECTOR COUNT TO TRANSFER
          RJM    SCP         SETUP COMMAND PACKET PARAMETERS
          RJM    CPT         COMMAND PACKET TRANSFER
 CTDT20   EQU    *-1         FOR FORCING ERRORS
 CTDT30   BSS
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    CTDT130     IF NOT TRANSFER NOTIFICATION
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAOUT     DATA, INFORMATION OUT
          RJM    BCS         BUS CONTROL SEQUENCE
          LDML   BPS,DT
          SHN    -1
          STDL   WC          PP WORDS PER SECTOR
          LDC    H0381       STREAM, WRITE, DMA
          RJM    FUNC
          ACN    DC
          LOADC  CM.CB
          ADML   SPC,DT      SECTORS PER CYLINDER
          SBML   /SS/P.TOTAL,CSST  SECTORS TO TRANSFER
          CMCH   WC,DC       TRANSFER DATA
          LDC    MS50
 CTDT40   BSS
          IJM    CTDT50,DC   IF SLAVE IN DROPPED
          SBN    1
          NJN    CTDT40      IF TIMEOUT NOT EXPIRED
          LJM    CTDT140
 CTDT50   BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT THE CONTROLLER
          LDDL   WC
          ZJN    CTDT60      IF ALL WORDS TRANSFERRED
          RJM    SRR         SHOULD RESPONSE BE READ
          UJK    CTDT30      YES, GO LOOK FOR INTERRUPT
 CTDT60   BSS
          RJM    UDA         UPDATE DISK ADDRESS
          NJK    CTDT30      IF MORE SECTORS TO TRANSFER
 CTDT65   BSS
          RJM    IH          INTERRUPT HANDLER
          SBN    0#12
          ZJN    CTDT70      IF COMPLETE AND CONDITIONAL SUCCESS
          SBN    0#18-0#12
          ZJN    CTDT70      IF COMPLETE AND SUCCESSFUL
          SBN    0#42-0#18
          ZJN    CTDT65      IF ASYNCH AND CONDITIONAL SUCCESS
          LJM    CTDT130

*         READ THE CYLINDER

 CTDT70   BSS
          LDN    0
          STDL   FNC         INDICATE READ FUNCTION
          RJM    SSA         SET STARTING ADDRESS
 CTDT80   BSS                ENTRY IF MEDIA ERROR
          RJM    CSC         COMPUTE SECTOR COUNT TO TRANSFER
          RJM    SCP         SETUP COMMAND PACKET PARAMETERS
          RJM    CPT         COMMAND PACKET TRANSFER
 CTDT90   BSS
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    CTDT130     IF NOT TRANSFER NOTIFICATION
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAIN      DATA, INFORMATION IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDML   BPS,DT
          SHN    -1
          STDL   WC          PP WORDS PER SECTOR
          LDC    H0A81       STREAM, READ, DMA
          RJM    FUNC
          ACN    DC
          LOADC  CM.CB
          CHCM   WC,DC       TRANSFER DATA
          LDC    MS50
 CTDT100  BSS
          IJM    CTDT110,DC  IF SLAVE IN DROPPED
          SBN    1
          NJN    CTDT100     IF TIMEOUT NOT EXPIRED
          RJM    CSI         CHECK SLAVE IN
 CTDT110  BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT THE CONTROLLER
          LDDL   WC
          ZJN    CTDT120     IF ALL WORDS TRANSFERRED
          RJM    SRR         SHOULD RESPONSE BE READ
          UJK    CTDT90      YES, GO LOOK FOR INTERRUPT

*         VERIFY THE DATA IN ONE SECTOR

 CTDT120  BSS
          IFNE   TB,1        SO TRACE DOES NOT CAUSE MISCOMPARE
          RJM    VCTD        VERIFY CONFIDENCE TEST DATA
          ENDIF
          RJM    UDA         UPDATE DISK ADDRESS
          NJK    CTDT90      IF MORE SECTORS TO TRANSFER
 CTDT125  BSS
          RJM    IH          INTERRUPT HANDLER
          SBN    0#12
          ZJN    CTDT160     IF COMPLETE AND CONDITIONAL SUCCESS
          SBN    0#18-0#12
          ZJN    CTDT160     IF COMPLETE AND SUCCESSFUL
          SBN    0#42-0#18
          ZJN    CTDT125     IF ASYNCH AND CONDITIONAL SUCCESS
 CTDT130  BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          UJN    CTDT150
 CTDT140  BSS
          LDN    E30         CHANNEL STAYED ACTIVE
 CTDT150  BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
 CTDT160  BSS
          LJM    CTDTX
          SPACE  5,20
** NAME-- CTR
*
** PURPOSE-- CONFIDENCE TEST RECOVERY
*
** EXIT   TO CALLING ROUTINE WITH
*            A = 0  IF ERROR LIMIT REACHED
*            A NOT 0  IF NOT MEDIA ERROR
*         TO CTDT ROUTINE IF MEDIA ERROR
          SPACE  2
 CTR100   BSS
          LMN    4           DATA INTEGRITY ERROR
 CTRX     LJM    **
 CTR      EQU    *-1
          LDML   /SS/P.CT,CSST
          NJN    CTR100      IF NOT IN CONFIDENCE TEST
          RJM    CFME        CHECK FOR MEDIA ERROR
          NJN    CTRX        IF NOT A MEDIA ERROR
          LDML   RPB+11,T3   HEAD, SECTOR
          STDL   T4
          LDDL   CSST
          STDL   T5          POINTER TO SS TABLE
          LDN    3
          STDL   T6          NUMBER OF MEDIA ERRORS ALLOWED
 CTR20    BSS
          LDML   CTME,T5
          SHN    2
          MJN    CTR30       IF TABLE ENTRY AVAILABLE
          SHN    -2
          LMDL   T4
          ZJN    CTR40       IF THIS SECTOR IN TABLE
          AODL   T5
          SODL   T6
          NJN    CTR20       IF MORE ENTRIES TO CHECK
          UJK    CTRX
 CTR30    BSS
          LDDL   T4
          STML   CTME,T5
 CTR40    BSS
          LDDL   FNC
          ZJN    CTR50       IF READ
          LDDL   T4
          SHN    -8
          STML   /SS/P.CURTRK,CSST  FAILING TRACK
          LDDL   T4
          LPN    77B
          STML   /SS/P.CURSEC,CSST  FAILING SECTOR
 CTR50    BSS
          LDML   TPC,DT
          SBML   /SS/P.CURTRK,CSST
          SBN    1
          NJN    CTR52       IF NOT LAST TRACK
          LDML   SPT,DT      SECTORS PER TRACK
          SBML   SSPC,DT     SPARE SECTORS PER CYLINDER
          UJN    CTR54
 CTR52    BSS
          LDML   SPT,DT      SECTORS PER TRACK
 CTR54    BSS
          STDL   T3          SECTORS PER TRACK
          AOML   /SS/P.CURSEC,CSST  UPDATE SECTOR NUMBER
          SBDL   T3
          MJN    CTR60       IF SAME TRACK
          STML   /SS/P.CURSEC,CSST
          AOML   /SS/P.CURTRK,CSST  UPDATE TRACK NUMBER
          LMML   TPC,DT      TRACKS PER CYLINDER
          NJN    CTR60       IF NOT LAST SECTOR ON CYLINDER
          RJM    LIR         LOGICAL INTERFACE RESET (TO CLEAR ASYNCH)
          LDDL   FNC
          NJK    CTDT70      IF WRITE
          LJM    CTDTX
 CTR60    BSS
          RJM    LIR         LOGICAL INTERFACE RESET (TO CLEAR ASYNCHS)
          LDDL   FNC
          NJK    CTDT10      IF WRITE
          LJM    CTDT80      GO TO READ ENTRY POINT
          SPACE  5,20
** NAME-- CU
*
** PURPOSE-- CLUSTER UNIT
          SPACE  2
 CUX      LJM    **
 CU       EQU    *-1
          LDC    0#968
          STML   CP+FCP      CLUSTER PARAMETER
          LDC    H0209
          RJM    SOU         SET OPERATION CODE AND UNIT
          LPN    37B
          SHN    8
          ADN    1
          STML   CP+FCP+1    FIRST DRIVE
          ADC    0#800
          STML   CP+FCP+3    SECOND DRIVE
          ADC    0#800
          STML   CP+FCP+5    3RD DRIVE
          ADC    0#800
          STML   CP+FCP+7    4TH DRIVE
          LDC    0#8A80
          STML   CP+FCP+2
          STML   CP+FCP+4
          STML   CP+FCP+6
          STML   CP+FCP+8
          LDDL   DT
          NJN    CU10        IF NOT 5832_1
          LDC    0#8600
          UJK    CU60
 CU10     BSS
          SBN    1
          ZJK    CU70        IF 5832_2
          SBN    6
          MJN    CU12        IF 5833_
          SBN    5
          MJN    CU12        IF 5838_
          ADN    1           BIAS FOR 47444_
          UJN    CU17
 CU12     ADN    6
 CU17     SBN    2
          MJN    CU50        IF 5833_1 OR 5838_1 OR 47444_1
          NJN    CU20        IF NOT 5833_1P OR 5838_1P OR 47444_1P
          LDC    0#1000
          RAML   CP+FCP+3
          LDC    0#8A10
          UJK    CU80
 CU20     BSS
          SBN    2
          MJK    CU90        IF 5833_2 OR 5838_2 OR 47444_2
          NJN    CU40        IF NOT 5833_3P OR 5838_3P OR 47444_3P
          LDC    0#8A10
          STML   CP+FCP+8
 CU40     BSS
          LDC    0#1168
          STML   CP+FCP      CLUSTER PARAMETER
          LDN    0#18        COMMAND PACKET LENGTH
          UJN    CU100
 CU50     BSS
          LDC    0#8A00
 CU60     BSS
          STML   CP+FCP+2
          LDC    0#568
          STML   CP+FCP      CLUSTER PARAMETER
          LDN    0#C         COMMAND PACKET LENGTH
          UJN    CU100
 CU70     BSS
          LDC    0#8680
          STML   CP+FCP+2
 CU80     BSS
          STML   CP+FCP+4
 CU90     BSS
          LDN    0#10        COMMAND PACKET LENGTH
 CU100    BSS
          STML   CP
          RJM    ODFP        OUTPUT DATA FROM PP

*         WAIT FOR ASYNCHRONOUS RESPONSE FROM DRIVE

          LDC    0#100       SO IH EXPECTS AN ASYNCHRONOUS RESPONSE
          STML   CP+OPCD
          RJM    IH          INTERRUPT HANDLER
          LJM    CUX
          SPACE  5,20
** NAME-- CUB
*
** PURPOSE-- CHECK UNIT BUSY.  NOTE IF SLAVE RESET IS IN PROGRESS
*            CMNDS COULD BE 0, BUT ERROR RECOVERY IS STILL IN
*            PROGRESS.
*
** EXIT--  A = 0  IF NO COMMANDS IN PROGRESS
          SPACE  2
 CUB50    BSS
          LDN    1
 CUBX     LJM    **
 CUB      EQU    *-1
          LDN    0
          STDL   UX          POINTER TO UNITS TABLE
          UJN    CUB20
 CUB10    BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UX TABLE
 CUB20    BSS
          SBDL   UNUML
          ZJN    CUBX        IF END OF CONFIGURED UNITS
          LOADR  UNITS+/UN/P.UIT,UX ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T5          READ UNIT DISABLED FLAG
          LDDL   T5+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJN    CUB10       IF UNIT DISABLED
          LDML   UNITS,UX
          SHN    /UN/L.CIP+2
          MJN    CUB50       IF COMMAND IN PROGRESS
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE
          LDML   /SS/P.RQTRY,CSST
          NJK    CUB50       IF IN ERROR PROCESSING FOR THIS UNIT
          UJN    CUB10
          SPACE  5,20
** NAME-- DARH
*
** PURPOSE-- DRIVE ASYNCHRONOUS RESPONSE HANDLER
          SPACE  2
 DARHX    LJM    **
 DARH     EQU    *-1

*         SEARCH UNITS TABLE TO SEE IF THIS UNIT IS CONFIGURED

          LDDL   UX
          STDL   T8          SAVE INDEX TO UNITS TABLE
          LDN    0
          STDL   UX
          UJN    DARH20
 DARH10   BSS
          LDN    P.UN
          RADL   UX          INCREMENT TO NEXT UNITS TABLE
 DARH20   BSS
          SBDL   UNUML
          ZJK    DARH60      IF END OF CONFIGURED UNITS
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE
          LDML   RPB+SLAD
          LMML   /SS/P.UNIT,CSST
          NJN    DARH10      IF RESPONSE NOT FOR THIS CONFIGURED UNIT
          LDK    ID26
          RJM    SFP         CHECK FOR MACHINE EXCEPTION
          MJK    DARH35      IF MACHINE EXCEPTION ID NOT FOUND
          LDM    /SS/P.DT,CSST
          SHN    -4
          LPN    17B
          SBN    3
          ZJN    DARH30      IF 5833_1P
          SBN    5
          ZJN    DARH30      IF 5838_1P
          SBN    2
          ZJN    DARH30      IF 5838_3P
          SBN    3
          ZJN    DARH30      IF 47444_1P
          SBN    2
          ZJN    DARH30      IF 47444_3P
          ADN    10
          NJK    DARH40      IF NOT 5833_3P
 DARH30   BSS
          LDML   RPB+5,T3
          SHN    -8
          SBN    8
          MJK    DARH40      IF RESPONSE FOR LOGICAL UNIT
          LDML   RPB+9,T3
          SHN    -8
          LMC    0#FE
          ZJK    DARH40      IF RESPONSE FOR LOGICAL UNIT

*         AN OPERATIONAL RESPONSE FOR A PHYSICAL DRIVE OF A PARITY UNIT
*         COULD MEAN AN OFF LINED DRIVE WAS REPAIRED.  THE CONFIDENCE TEST
*         WILL FORMAT THE DRIVE IF NECESSARY AND START THE RESTORE OF THE DRIVE.
*         DRIVE RESET FROM THE OTHER ACCESS CAUSES AN OPERATIONAL, READY
*         TRANSITION.  DON'T INITIATE A RESTORE DUE TO A DRIVE RESET.

          LDML   RPB+6,T3
          SHN    3
          PJK    DARH55      IF NOT OPERATIONAL TRANSITION
          SHN    1
          MJK    DARH60      IF READY TRANSISTION
          LDML   /SS/P.RQTRY,CSST
          NJN    DARH40      IF IN ERROR RECOVERY
          LDML   DARH
          LMC    PI75
          NJN    DARH40      IF CALLING ROUTINE IS NOT PI (PREVENT INFINITE LOOP)
          LDN    40B
          STML   /SS/P.CT,CSST  FORCE CONFIDENCE TEST TO BE RUN
          LDM    /SS/P.DOAR,CSST
          LMC    0#8000      INDICATE OPERATIONAL ASYNCH RECEIVED
          STML   /SS/P.DOAR,CSST
          UJN    DARH60

*         DRIVE RESET FROM THE OTHER ACCESS CAUSES A NOT OPERATIONAL, NOT
*         READY TRANSITION RESPONSE.  DON'T LOG THIS ASYNCHRONOUS RESPONSE.

 DARH35   BSS
          LDK    ID24
          RJM    SFP         SEARCH FOR PARAMETER 24
          MJN    DARH55      IF PARAMETER NOT FOUND
          LDML   RPB+6
          LPC    0#3000
          LMC    0#3000
          ZJN    DARH60      IF NOT OPERATIONAL, NOT READY ASYNCH
          UJN    DARH55
 DARH40   BSS
          LDML   RPB+6,T3
          LPC    0#FAF0
          LMC    0#6000
          ZJN    DARH60      IF NO ERROR
 DARH55   BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 DARH60   BSS
          LDDL   T8
          STDL   UX
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST
          UJK    DARHX
          SPACE  5,20
** NAME-- DCR
*
** PURPOSE-- DELETE COMPLETED REQUEST FROM THE UNIT QUEUE.
*
** ENTRY  UNITS+/UN/P.UIT = POINTER TO UNIT INTERFACE TABLE
*         IF A = 0, ISSUE SEEK IF REQUEST AND NO COMMAND ISSUED
*
** EXIT   P5, T8 ARE UNCHANGED
          SPACE  2
 DCRX     LJM    **
 DCR      EQU    *-1
          STDL   T9
          LDN    2
          STDL   P6
 DCR10    BSS
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    DCR10       IF LOCK COULD NOT BE SET
          LOADF  /SS/P.CURRQ,CSST  RMA OF CURRENT REQUEST
          CRML   RQT,P6      READ RMA CHAIN OF CURRENT REQUEST

          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          STDL   T1
          CRDL   P1          READ QUEUE COUNT
          ERRNZ  /UIT/C.QCNT
          LDDL   P1+/UIT/P.QCNT  DECREMENT QUEUE COUNT
          SBML   /SS/P.NCOMRQ,CSST  NUMBER OF COMPLETED REQUESTS
          STDL   P1+/UIT/P.QCNT
          MJN    DCR20       IF INVALID QUEUE COUNT
          LDDL   T1
          CWDL   P1          WRITE QUEUE COUNT
 DCR20    BSS
          LOADR  /SS/P.DP,CSST  DELINK POINTER
          STDL   P2
          ADN    1           POINT TO RMA INSTEAD OF PVA
          CRDL   T1          RMA OF A REQUEST
          LDDL   T3
          LMML   /SS/P.FCOMRQ,CSST
          NJN    DCR30       IF NEXT REQUEST IS NOT COMPLETED REQUEST
          LDDL   T4
          LMML   /SS/P.FCOMRQ+1,CSST
          ZJN    DCR50       IF THIS IS A COMPLETED REQUEST
 DCR30    BSS
          LDDL   T3          UPDATE DELINK POINTER TO NEXT
          STML   /SS/P.DP,CSST  REQUEST IN THE CHAIN
          ADDL   T4
          ZJN    DCR40       IF END OF REQUEST QUEUE
          LDDL   T4
          SHN    -3
          STML   /SS/P.DP+1,CSST
          UJK    DCR20
 DCR40    BSS
          LDML   UNITS+/UN/P.UIT+1,UX  INITIALIZE DELINK POINTER TO
          ADN    /UIT/C.NEXTPV       FIRST RMA
          STML   /SS/P.DP+1,CSST
          LDML   UNITS+/UN/P.UIT,UX
          STML   /SS/P.DP,CSST
          UJK    DCR20

*         DELINK COMPLETED REQUESTS.

 DCR50    BSS
          LDDL   P2          CM ADDRESS OF REQUEST
          CWML   RQT,P6      PVA AND RMA OF NEXT REQUEST IN CHAIN
          LDML   RQT+/RQ/P.NEXT
          ADML   RQT+/RQ/P.NEXT+1
          NJN    DCR52       IF NOT END OF QUEUE
          LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          MJN    DCR52       IF 2 COMMANDS ISSUED TO CONTROLLER
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.NEXTPV
          CRML   RQT,P6      READ FIRST PVA AND RMA
          LDML   UNITS+/UN/P.UIT,UX  INITIALIZE DELINK POINTER TO FIRST REQUEST
          STML   /SS/P.DP,CSST
          LDML   UNITS+/UN/P.UIT+1,UX
          ADN    /UIT/C.NEXTPV
          STML   /SS/P.DP+1,CSST
 DCR52    BSS
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD

          LDDL   T9
          NJK    DCR58       IF NOT CHECKING REQUEST QUEUE
          LDDL   P4
          ZJK    DCR56       IF QUEUE EMPTY
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          LDML   /SS/P.CT,CSST
          LPN    7
          ZJK    DCR58       IF CONFIDENCE TEST SHOULD BE RUN
          LDML   /SS/P.RQTRY,CSST
          NJK    DCR58       IF IN ERROR RECOVERY
          LDDL   IF
          NJK    DCR58       IF CONFIDENCE TEST SHOULD BE RUN
          LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          MJK    DCR60       IF 2 COMMANDS ISSUED TO CONTROLLER
          LDML   RQT+/RQ/P.NEXTPV  PUT PVA OF NEXT REQUEST IN SS TABLE
          STML   /SS/P.PVA,CSST
          LDML   RQT+/RQ/P.NEXTPV+1
          STML   /SS/P.PVA+1,CSST
          LDML   RQT+/RQ/P.NEXTPV+2
          STML   /SS/P.PVA+2,CSST
          LDML   RQT+/RQ/P.NEXT  PUT RMA OF NEXT REQUEST IN SS TABLE
          STML   /SS/P.REQ,CSST
          LDML   RQT+/RQ/P.NEXT+1
          STML   /SS/P.REQ+1,CSST
          LDN    0
          STDL   CNUM        INDICATE FIRST COMMAND
          RJM    GETR        GET REQUEST
          LDDL   FNC
          SBN    2
          ZJN    DCR58       IF FORMAT
          RJM    SCP         SETUP COMMAND PACKET PARAMETERS
          RJM    CPT         COMMAND PACKET TRANSFER
          LJM    DCRX
 DCR56    BSS
          RJM    RESPIN
 DCR58    BSS
          LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          MJN    DCR60       IF 2 COMMANDS ISSUED TO CONTROLLER
          SHN    -/UN/L.TCIP-2
          LPC    0#3FFF
          STML   UNITS,UX    CLEAR CIP
          RJM    DUBC        DECREMENT UNIT BUSY COUNTER
          LJM    DCR70
 DCR60    BSS
          LDML   UNITS,UX
          LPC    0#BFFF
          STML   UNITS,UX    CLEAR TCIP

*         MOVE (RMA, PVA, TOTAL SECTORS) FOR SECOND COMMAND ISSUED TO THE
*         TABLE FOR THE FIRST COMMAND

          LDML   /SS/P.RMA2,CSST
          STML   /SS/P.REQ,CSST
          LDML   /SS/P.RMA2+1,CSST
          STML   /SS/P.REQ+1,CSST  MOVE RMA
          LDML   /SS/P.PVA2,CSST
          STML   /SS/P.PVA,CSST
          LDML   /SS/P.PVA2+1,CSST
          STML   /SS/P.PVA+1,CSST
          LDML   /SS/P.PVA2+2,CSST
          STML   /SS/P.PVA+2,CSST  MOVE PVA
          LDML   /SS/P.TW2,CSST
          STML   /SS/P.TOTAL,CSST  MOVE SECTOR COUNT
          RJM    UREQ        READ UNIT REQUEST FROM CM
          RJM    SRESP       SET UP STATUS FOR RESPONSE BUFFER
          RJM    SETRQ       SET UP FOR FIRST REQUEST
          RJM    UNCMND      GET FIRST COMMAND
 DCR70    BSS
          SODL   CMNDS       OUTSTANDING COMMANDS
          LJM    DCRX
          SPACE  5,20
** NAME-- DDT
*
** PURPOSE-- DETERMINE DRIVE TYPE FOR DRIVE SPECIFIED BY LOCATION PD
*
** EXIT
*         A = DRIVE TYPE (0-6) IF DRIVE FOUND AND CLUSTERED
*           = 141(10) IF NOT CLUSTERED AS NOS/VE DEFINED DRIVE
*           = NEGATIVE VALUE IF DRIVE NOT FOUND OR ERROR
*        T3 = POINTER TO PARAMETER 68
*        TD = NUMBER OF PHYSICAL DRIVES PER LOGICAL UNIT IF THE DRIVE
*             IS CLUSTERED
          SPACE  2
 DDTX     LJM    **
 DDT      EQU    *-1
          RJM    RMR         READ MICROCODE REVISION
          LDC    0#8068
          STML   CP+FCP+1    REPORT PARAMETER 68
          LDN    10          COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDML   RPB+5+2
          SHN    -1
          STDL   T1
          LDDL   PD          PHYSICAL DRIVE
          SHN    8
          ADN    1
          STDL   T2          EXPECTED PARAMETER WORD WITH UNIT NUMBER
          LDN    0
          STDL   T3          INDEX TO PARAMETER 68
          LDN    1
          STML   TD          PHYSICAL DRIVES PER LOGICAL UNIT
 DDT10    BSS
          LDML   RPB+8,T3
          LMC    0#568
          NJN    DDT25       IF NOT SINGLE UNIT
          LDML   RPB+8+1,T3
          LMDL   T2
          NJK    DDT55       IF DIFFERENT UNIT
          LDML   RPB+8+2,T3
          SHN    8
          PJK    DDT80       IF NOT CLUSTERED
          SHN    17
          MJN    DDT15       IF SOLID STATE DISK
          LDN    2           583X_1 OR 47444_1
          UJN    DDT20
 DDT15    BSS
          LDN    0           5832_1
 DDT20    BSS
          LJM    DDT100
 DDT25    BSS
          LDML   RPB+8,T3
          LMC    0#968
          NJN    DDT40       IF NOT 2 UNITS
          LDML   RPB+8+1,T3
          LMDL   T2
          ZJN    DDT28       IF UNIT FOUND
          LDML   RPB+8+3,T3
          LMDL   T2
          NJK    DDT60       IF DIFFERENT UNIT
 DDT28    BSS
          LDN    2
          STML   TD          PHYSICAL DRIVES PER LOGICAL UNIT
          LDML   RPB+8+4,T3
          SHN    6
          MJN    DDT30       IF NOT SSD
          LDN    1
          UJN    DDT38
 DDT30    BSS
          SHN    4
          PJN    DDT35       IF PARITY DRIVE
          LDN    4           583X_2 OR 47444_2
          UJN    DDT38
 DDT35    BSS
          LDN    3           583X_1P OR 47444_1P
 DDT38    BSS
          UJK    DDT50
 DDT40    BSS
          LDML   RPB+8,T3
          LMC    0#D68
          NJN    DDT42       IF NOT 3 UNITS
          LDML   RPB+8+1,T3
          LMDL   T2
          ZJN    DDT41       IF UNIT FOUND
          LDML   RPB+8+3,T3
          LMDL   T2
          ZJN    DDT41       IF UNIT FOUND
          LDML   RPB+8+5,T3
          LMDL   T2
          NJK    DDT63       IF DIFFERENT UNIT
 DDT41    BSS
          LDN    3
          STML   TD          PHYSICAL DRIVES PER LOGICAL UNIT
          UJK    DDT80
 DDT42    BSS
          LDML   RPB+8,T3
          LMC    0#1168
          NJK    DDT75       IF ILLEGAL PARAMETER
          LDML   RPB+8+1,T3
          LMDL   T2
          ZJN    DDT43       IF UNIT FOUND
          LDML   RPB+8+3,T3
          LMDL   T2
          ZJN    DDT43       IF UNIT FOUND
          LDML   RPB+8+5,T3
          LMDL   T2
          ZJN    DDT43       IF UNIT FOUND
          LDML   RPB+8+7,T3
          LMDL   T2
          NJN    DDT65       IF DIFFERENT UNIT
 DDT43    BSS
          LDN    4
          STML   TD          PHYSICAL DRIVES PER LOGICAL UNIT
          LDML   RPB+8+8,T3
          SHN    10
          PJN    DDT45       IF PARITY DRIVE
          LDN    6           583X_4
          UJN    DDT50
 DDT45    BSS
          LDN    5           583X_3P
 DDT50    BSS
          UJN    DDT100
 DDT55    BSS
          LDN    3
          UJN    DDT70
 DDT60    BSS
          LDN    5
          UJN    DDT70
 DDT63    BSS
          LDN    7
          UJN    DDT70
 DDT65    BSS
          LDN    9
 DDT70    BSS
          RADL   T3          UPDATE POINTER TO PARAMETER 68
          SBDL   T1
          MJK    DDT10       IF MORE PARAMETERS TO CHECK
 DDT75    BSS
          LCN    0           DRIVE NOT FOUND OR ERROR
          UJN    DDT100
 DDT80    BSS
          LDC    E141        DRIVE NOT CLUSTERED OR NOT FORMATTED
 DDT100   BSS
          STML   RS+/RS/P.ADT
          MJN    DDT120      IF DRIVE NOT FOUND OR ERROR
          ADC    -E141
          ZJN    DDT110      IF DRIVE NOT CLUSTERED OR NOT FORMATTED
          LDDL   DT
          SBN    7
          MJN    DDT110      IF 5832 OR 5833
          SBN    5
          MJN    DDT105      IF 5838
          LDN    10
          UJN    DDT107      47444
 DDT105   LDN    5
 DDT107   RAML   RS+/RS/P.ADT  BIAS ADT FOR MODEL 5838
 DDT110   LDML   RS+/RS/P.ADT
 DDT120   LJM    DDTX
 TD       DATA   0           TOTAL PHYSICAL DRIVES PER LOGICAL UNIT
          SPACE  5,20
** NAME-- DLN
*
** PURPOSE-- DELETE LOGICAL PP NUMBER FROM UNIT INTERFACE TABLE LOCKWORD.
*            IT IS USED TO DETERMINE IF THE DRIVE IS BEING SUPPORTED IN
*            ALTERNATE OR REDUNDANT ACCESS MODE.  ALSO ENSURE THAT THE UNIT
*            LOCK IS CLEAR.
          SPACE  2
 DLNX     LJM    **
 DLN      EQU    *-1
          LDN    0
          STDL   UX          POINTER TO UNITS TABLE
          UJN    DLN20
 DLN10    BSS
          LDN    P.UN
          RADL   UX          UPDATE TO NEXT UNITS TABLE
 DLN20    BSS
          SBDL   UNUML
          ZJN    DLNX        IF END OF CONFIGURED UNITS
          RJM    LUT         LOCK UNIT TABLE
          NJN    DLN30       IF ALTERNATE PP HAS THE LOCK
          RJM    UUT         UNLOCK UNIT TABLE
 DLN30    BSS
          LCN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.ULOCK  INDEX TO UNIT LOCKWORD
          STDL   T6
          CRDL   P1          READ UNIT LOCKWORD
          LDDL   P2
          SBDL   LPN
          NJN    DLN40       IF 1ST PP NOT THIS ONE
          STDL   T2
          UJN    DLN50
 DLN40    BSS
          LDDL   P3
          SBDL   LPN
          NJN    DLN10       IF 2ND PP NOT THIS ONE
          STDL   T3
 DLN50    BSS
          LDDL   T6
          RDCL   T1          DELETE LOGICAL PP NUMBER FROM LOCKWORD
          PAUSE  4           IN CASE ALTERNATE PP LOCKING UNIT AT THE
                              SAME TIME
          UJK    DLN30       ENSURE PP NUMBER DELETED
          SPACE  5,20
** NAME-- DPR
*
** PURPOSE-- DRIVE POWER ON RESET.  THIS MASTER CLEARS THE DRIVE(S),
*            BREAKS AN OPPOSITE ACCESS RESERVE AND RUNS DIAGNOSTICS.
*            IT IS ISSUED BY THE CONTROLLER EVEN IF THE DRIVE IS NOT
*            OPERATIONAL.  IT IS ISSUED BY THE CONTROLLER TO THE OFF
*            LINE DRIVE OF A LOGICAL UNIT.
          SPACE  2
 DPRX     LJM    **
 DPR      EQU    *-1
          LDML   /SS/P.UNIT,CSST
          LPN    77B
          STDL   PD          PHYSICAL DRIVE
 DPR10    BSS
          RJM    DDT         DETERMINE DRIVE TYPE
          MJN    DPR20       IF ERROR
          LDML   TD          TOTAL DRIVES IN LOGICAL UNIT
          LMN    1
          ZJN    DPR20       IF 1X DRIVE
          LDDL   DT
          ZJN    DPR13       IF 1X DRIVE EXPECTED
          SBN    2
          ZJN    DPR13       IF 5833_1 DRIVE
          SBN    5
          ZJN    DPR13       IF 5838_1 DRIVE
          SBN    5
          NJK    DPR16       IF NOT 47444_1 DRIVE
 DPR13    BSS
          LDML   /SS/P.UNIT,CSST
          SCN    0#38
          UJN    DPR30
 DPR16    BSS
          LDDL   PD
          LPN    70B
          NJN    DPR40       IF RESET ALREADY ISSUED
          LDML   /SS/P.UNIT,CSST
          UJN    DPR30
 DPR20    BSS
          LDDL   CMOD
          SHN    8
          ADDL   PD
 DPR30    BSS
          STML   CP+SLAD     LOGICAL ADDRESS
          LDC    H0800       ABORT COMMAND
          STML   CP+OPCD
          LDC    0#254
          STML   CP+FCP
          LDC    0#400       RESET AS AT POWER ON
          STML   CP+FCP+1
          LDN    10
          STML   CP          COMMAND PACKET LENGTH
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          RJM    LIR         LOGICAL INTERFACE RESET (IN CASE OF MULTIPLE RESPONSES)
 DPR40    BSS
          RJM    UPD         UPDATE PHYSICAL DRIVE ADDRESS
          NJK    DPR10       IF MORE PHYSICAL UNITS IN LOGICAL UNIT

*         IF THE UNIT IS NOT READY, THE DRIVE RESET COULD RESULT IN A
*         STATE CHANGE.  THE STATE CHANGE COULD TAKE AS LONG AS 15 SECONDS.
*         IF A CONTROLLER IS POWERED ON AND A DRIVE IS RESERVED TO ANOTHER
*         CONTROLLER, THE CONTROLLER THAT IS POWERED ON WILL REPORT THAT
*         THE DRIVE IS NOT OPERATIONAL AND NOT READY.

          LDML   /SS/P.SC,CSST
          ZJN    DPR70       IF THERE SHOULD BE NO STATE CHANGE
 DPR50    BSS
          RJM    RI          REQUEST INTERRUPTS
          LDML   SELT,CMOD   MASK VALUE
          LPDL   STATUS      INTERRUPT STATUS
          NJN    DPR70       IF INTERRUPT PRESENT
          RJM    UC          UPDATE CLOCK
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    DPR60       IF CLOCK HASN'T WRAPPED
          ADC    0#10000
 DPR60    BSS
          SBN    15          COMMAND TIMEOUT
          MJN    DPR50       IF TIMEOUT NOT EXPIRED
 DPR70    BSS
          LJM    DPRX
          SPACE  5,20
** NAME-- DU
*
** PURPOSE-- DECLUSTER UNIT
*
** ENTRY -- TD = PHYSICAL DRIVES PER LOGICAL UNIT
          SPACE  2
 DUX      LJM    **
 DU       EQU    *-1
          LDC    H0209+400000B  LOAD ATTRIBUTE OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDML   TD
          SBN    1
          ZJN    DU10        IF ONE PHYSICAL DRIVE PER LOGICAL UNIT
          LDML   CP+SLAD
          SCN    0#38        CLEAR STRING NUMBER
          STML   CP+SLAD
 DU10     BSS
          LDC    0#568
          STML   CP+FCP
          LDML   CP+SLAD
          LPN    77B         MASK DRIVE NUMBER
          SHN    8
          ADN    1
          STML   CP+FCP+1    PARAMETER WORD WITH DRIVE NUMBER
          LDDL   DT
          SBN    2
          PJN    DU20        IF 5833 OR 5838 OR 47444
          LDC    0#8500      DECLUSTER 5832
          UJN    DU30
 DU20     BSS
          LDC    0#8900      DECLUSTER NON 5832
 DU30     BSS
          STML   CP+FCP+2
          LDN    12          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          LDC    0#100       SO IH EXPECTS AN ASYNCHRONOUS RESPONSE
          STML   CP+OPCD
 DU40     BSS
          RJM    IH          INTERRUPT HANDLER
          SOML   TD
          NJN    DU40        IF ANOTHER ASYNCHRONOUS RESPONSE EXPECTED
          UJK    DUX
          SPACE  5,20
** NAME-- DUBC
*
** PURPOSE-- DECREMENT UNIT BUSY COUNTER
          SPACE  2
 DUBCX    LJM    **
 DUBC     EQU    *-1
          LDML   UNITS,UX
          SHN    -3
          LPN    37B
          STDL   P1          POINTER TO UPSB TABLE
          LDML   UPSB,P1
          ZJN    DUBCX       IF NO DECREMENT NECESSARY
          SOML   UPSB,P1     DECREMENT UNITS PER PATH STRING BUSY COUNTER
          NJN    DUBCX       IF OTHER BUSY UNITS
          LDML   PSB
          ZJN    DUBCX       IF NO DECREMENT NECESSARY
          SOML   PSB         DECREMENT PATH STRINGS BUSY
          UJN    DUBCX
          SPACE  5,20
** NAME-- EFP
*
** PURPOSE-- ERROR FLAG PROCESSING
          SPACE  2
 EFP      CON    0
          LDC    H00F1       READ ERROR REGISTER
          RJM    RDRG
          SHN    2
          PJN    EFP5        IF NOT BUFFER COUNTER PARITY
          LDN    E31
          UJN    EFP40
 EFP5     BSS
          SHN    2
          PJN    EFP10       IF NOT SYNC COUNTER PARITY
          LDN    E32
          UJN    EFP40
 EFP10    BSS
          SHN    1
          PJN    EFP15       IF NOT PERIOD COUNTER PARITY
          LDN    E03
          UJN    EFP40
 EFP15    BSS
          SHN    1
          MJN    EFP20       IF PARITY ERROR ON FUNCTION
          SHN    1
          PJN    EFP25       IF NOT PARITY ERROR ON FUNCTION
 EFP20    BSS
          LDC    H0715       MOST LIKELY FUNCTION THAT TIMED OUT
          STDL   LF
          LDN    E01         FUNCTION TIMEOUT
          UJN    EFP40
 EFP25    BSS
          SHN    3
          PJN    EFP30       IF NOT LOST DATA
          LDN    E33
          UJN    EFP65
 EFP30    BSS
          SHN    1
          MJN    EFP35       IF UPPER ICI PARITY ERROR
          SHN    1
          PJN    EFP45       IF NOT LOWER ICI PARITY ERROR
 EFP35    BSS
          LDN    E04
 EFP40    BSS
          UJN    EFP65
 EFP45    BSS
          SHN    1
          PJN    EFP50       IF NOT IPI SEQUENCE ERROR
          LDN    E24
          UJN    EFP65
 EFP50    BSS
          SHN    1
          MJN    EFP55       IF UPPER IPI CHANNEL PARITY ERROR
          SHN    1
          PJN    EFP60       IF NOT LOWER IPI CHANNEL PARITY ERROR
 EFP55    BSS
          LDN    E25
          UJN    EFP65
 EFP60    BSS
          LDN    E06         IOU ERROR
 EFP65    BSS
          STML   RS+/RS/P.ERRID
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- EP
*
** PURPOSE-- ERROR PROCESSING
          SPACE  2
 EP       CON    0
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDML   /SS/P.RQTRY,CSST
          NJN    EP10        IF NOT FIRST ERROR FOR REQUEST
          STML   /SS/P.RECOV,CSST  INDEX TO FIRST RECOVERY STEP (EPA)
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
 EP10     BSS
          LDDL   UX          TO FORCE CONFIDENCE TEST OR FORMAT ERROR RECOVERY
          STDL   LUX          TO COMPLETE BEFORE GOING TO ANOTHER UNIT
          RJM    PPRQ        CHECK FOR IDLE REQUEST
          LDN    0
          STML   /SS/P.SC,CSST  DO NOT WAIT FOR ASYNCH IN DPR
          STDL   MFID        MASK FOR INTERLOCK DATA IF 200 HEX
          LDML   RS+/RS/P.ERRID
          NJN    EP20        IF RESPONSE PACKET NOT APPLICABLE
          LDK    ID24
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    EP20        IF PARAMETER 24 NOT FOUND
          LDML   RPB+6,T3
          SHN    3
          PJN    EP20        IF DRIVE WAS READY
          AOML   /SS/P.SC,CSST  FLAG SAYS WAIT FOR ASYNCH IN DPR
 EP20     BSS
          LDN    0
          STDL   TBC         DO NOT EXPECT 01 ENDING STATUS
          LDML   RS+/RS/P.ERRID
          ZJN    EP40        IF PROBABLY NOT IOU ERROR
          SBN    E20
          PJN    EP40        IF PROBABLY NOT IOU ERROR
          LDML   /SS/P.RQTRY,CSST
          SBN    11
          PJN    EP30        IF RETRY LIMIT REACHED
          RJM    TAC         TERMINATE ALL COMMANDS
          LJM    MAIN10
 EP30     BSS
          LDK    /RS/K.CHDN  CHANNEL DOWN
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    OFFCH       TURN OFF ALL UNITS ON CHANNEL
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          LJM    MAIN15
 EP40     BSS
          LDML   /SS/P.RECOV,CSST  INDEX TO ERROR PROCESSING PROCEDURE
          STDL   T1
          LDML   EPT,T1
          STML   EP50
          LJM    **          EXECUTE NEXT STEP IN RECOVERY PROCEDURE
 EP50     EQU    *-1

 EPT      BSS    0
          CON    EPA         RETRY THE REQUEST
          CON    EPB         CONFIDENCE TEST
          CON    EPC         SLAVE RESET
          CON    EPD         PATH TEST
          CON    EPF         IF FINAL REQUEST RETRY FAILED
          CON    EPG         IF LOGICAL RESET FAILS AFTER FINAL RETRY
          CON    EPD50       REQUEST RETRY ERROR AFTER SLAVE RESET
          CON    EPC70       AFTER READ PERFORMANCE LOG
          SPACE  5,20
*         REQUEST RETRY

 EPA      BSS
          LDML   /SS/P.RQTRY,CSST  REQUEST RETRY COUNTER
          STDL   T2
          ZJN    EPA10       IF INTERMEDIATE RESPONSE ALREADY REPORTED
          LDML   UNITS,UX
          SHN    /UN/L.PDCE+2
          MJN    EPA3        IF PARITY DRIVE CORRECTION ENABLED
          LDDL   T2
          SBN    RRL+1
          UJN    EPA6
 EPA3     BSS
          LDDL   T2
          SBN    RRL+3+1
 EPA6     BSS
          PJK    EPC         IF FAILURE DURING LOGICAL RESET
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
 EPA10    BSS
          RJM    CTR         CONFIDENCE TEST RECOVERY
          NJN    EPA30       IF ERROR LIMIT NOT REACHED
          AOML   /SS/P.RQTRY,CSST  REQUEST RETRY COUNTER
          UJK    EPC
 EPA30    BSS
          AOML   /SS/P.RQTRY,CSST  REQUEST RETRY COUNTER
          RJM    LIR         LOGICAL INTERFACE RESET
          RJM    RCC         RESTART CONTROLLER COMMANDS
          LDML   UNITS,UX
          SHN    /UN/L.PDCE+2
          MJN    EPA35       IF PARITY DRIVE CORRECTION ENABLED
          LDML   /SS/P.RQTRY,CSST
          SBN    RRL+1
          UJN    EPA40
 EPA35    BSS
          LDML   /SS/P.RQTRY,CSST
          SBN    RRL+3+1
 EPA40    BSS
          MJN    EPB10       IF NOT RETRY LIMIT
          SPACE  5,20
*         CONFIDENCE TEST

 EPB      BSS
          LDML   /SS/P.RECOV,CSST
          LMN    1
          ZJN    EPB20       IF CONFIDENCE TEST ALREADY STARTED
          LDML   /SS/P.CT,CSST
          ZJN    EPC         IF INITIALIZATION CONFIDENCE TEST
          AOML   /SS/P.RECOV,CSST  INDEX TO NEXT RECOVERY STEP (EPB)
          LDN    0
          STML   /SS/P.CT,CSST  ENABLE STARTING CONFIDENCE TEST
 EPB10    BSS
          LJM    MAIN10
 EPB20    BSS
          RJM    CTR         CONFIDENCE TEST RECOVERY
          SPACE  5,20
*         SLAVE RESET

 EPC      BSS
          LDML   RS+/RS/P.ERRID
          SBN    E38
          NJN    EPC3        IF NOT -NO CONTROLLER RESPONSE-
          LDML   UNITS,UX    IF CONTROLLER HUNG, READ PERFORMANCE
          LPC    0#EFFF       LOG AFTER SLAVE RESET
          LMC    /UN/K.NCR   NO CONTROLLER RESPONSE BIT
          STML   UNITS,UX
 EPC3     BSS
          LDML   /SS/P.RECOV,CSST
          ZJK    EPC15       IF INITIALIZATION CONFIDENCE TEST OR NO RESPONSE
          SBN    2            TO LOGICAL RESET
          ZJK    EPC50       IF SLAVE RESET ALREADY ISSUED
          LDML   /SS/P.CT,CSST
          ZJK    EPC8        IF NO COMPLETION CODE FOR CONFIDENCE TEST
          LMN    1
          NJK    EPC10       IF FAILURE ALREADY INDICATED
          LDK    /RS/K.DATERR  SOFTWARE FLAW THE ALLOCATION UNIT
          STML   RS+/RS/P.DATERR
          LDML   RS+/RS/P.ERRID
          SBN    E38
          NJN    EPC4        IF FAILURE ADDRESS SHOULD BE VALID
          LDML   RQ+/RQ/P.TRACK,CSST
          STML   RS+/RS/P.FTRK  FAILIING TRACK ADDRESS
          LDML   RQ+/RQ/P.SECTOR,CSST
          STML   RS+/RS/P.FSEC  FAILING SECTOR ADDRESS
 EPC4     LDN    E62         MEDIA ERROR
          STML   RS+/RS/P.ERRID
          LDN    0           INDEX TO NEXT RECOVERY STEP (EPA)
          STML   /SS/P.RECOV,CSST  TO PREVENT INFINITE LOOP IF RESET FAILS
          RJM    IPDE        IS PARITY DRIVE ENABLED
          NJN    EPC5        IF NO PARITY DRIVE OR NO FAILING DRIVE
          LDDL   T2
          SHN    9
          MJN    EPC5        IF RESTORE IN PROGRESS
          LDML   /SS/P.RQTRY,CSST
          SBN    RRL+3+1
          MJN    EPC6        IF RECOVERY HASN'T BEEN TRIED WITH PARITY DRIVE CORRECTION
 EPC5     BSS
          LJM    EPF10
 EPC6     BSS
          LDML   UNITS,UX
          LMC    0#200
          STML   UNITS,UX    SET PARITY DRIVE CORRECTION ENABLED BIT (PDCE)
          RJM    LA6E        LOAD ATTRIBUTE PARAMETER 6E
          RJM    LIR         LOGICAL INTERFACE RESET
          RJM    RCC         RESTART CONTROLLER COMMANDS
          LJM    MAIN15
 EPC8     BSS
          RJM    SFRR        CLEAR CIP, IF
          LDN    2
          STML   /SS/P.CT,CSST  INDICATE CONFIDENCE TEST FAILED
 EPC10    BSS
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
 EPC15    BSS
          LDML   RS+/RS/P.ERRID
          NJN    EPC18       IF NOT DRIVE ERROR
          LDML   /SS/P.FNC,CSST
          SBN    2
          ZJN    EPC18       IF FORMAT COMMAND
          RJM    IPDE        IS PARITY DRIVE ENABLED
          NJN    EPC18       IF NO PARITY DRIVE OR NO FAILING DRIVE
          LDML   /SS/P.CT,CSST
          ZJN    EPC16       IF INITIALIZATION CONFIDENCE TEST
          LDML   RQ+/RQ/P.TRACK,CSST
          STML   /SS/P.CURTRK,CSST
          LDML   RQ+/RQ/P.SECTOR,CSST  SO THE CORRECT ADDRESS IS LOGGED WHEN
          STML   /SS/P.CURSEC,CSST     THE DRIVE IS SET OFF LINE
 EPC16    BSS
          LJM    EPE
 EPC18    BSS
          LDN    2
          STML   /SS/P.RECOV,CSST  INDEX TO NEXT STEP OF RECOVERY (EPC)

*         BEFORE FORMATTING, AN ATTEMPT IS MADE TO READ THE LABEL IN
*         EACH OF THE FIRST 3 DAUS.  THIS CODE SKIPS THE SLAVE RESET
*         FOR THE LAST 2 DAUS.  SLAVE RESET TAKES APPROXIMATELY 3
*         MINUTES.

          RJM    CLR         CHECK FOR LABEL READ
          MJN    EPC19       IF RESET SHOULD BE ISSUED
          NJK    EPF6        IF SKIPPING SLAVE RESET
 EPC19    BSS
          LDN    E50         SLAVE RESET STARTED
          STML   RS+/RS/P.ERRID
          RJM    INTRS       INTERMEDIATE RESPONSE
          LDDL   PTF         PATH TEST FLAG
          ZJN    EPC20       IF INITIALIZATION PATH TEST
          RJM    RCC         RESTART CONTROLLER COMMANDS
          LDC    0#C000      COMMAND IN PROG., 2 COMMANDS IN PROG.
          RJM    SCB         SET COMMAND IN PROGRESS BITS
 EPC20    BSS
          RJM    SRI         SET RESET ISSUED FLAG
          RJM    ISR         ISSUE SLAVE RESET (NO RETURN)
 EPC50    BSS
          LDML   UNITS,UX
          LPC    /UN/K.NCR
          STDL   T5          SAVE NO CONTROLLER RESPONSE FLAG
          LDML   UNITS,UX
          LPC    0#EFFF
          STML   UNITS,UX    CLEAR -NO CONTROLLER RESPONSE- BIT
          LDML   RS+/RS/P.ERRID
          LMC    E72
          NJK    EPC100      IF NOT MACHINE EXCEPTION
          LDN    ID16
          RJM    SFP         SEARCH FOR PARAMETER
          LDML   RPB+6,T3
          LPC    0#FEE0
          LMC    0#6000
          NJK    EPC100      IF SLAVE RESET FAILED
          RJM    RCC         RESTART CONTROLLER COMMANDS
          LDDL   T5
          ZJN    EPC70       IF CONTROLLER WAS NOT HUNG
          LDN    7           GO TO EPC70 IF ERROR
          STML   /SS/P.RECOV,CSST
          LDML   /SS/P.MREV+1,CSST
          LPN    77B
          SBN    0#15        REV LEVEL 15
          PJN    EPC70       SKIP REL IF REV 15. FC HANG WORK AROUND
          RJM    REL         READ ERROR LOG
          ZJN    EPC70       IF NO ERROR CODE
          LDK    E52         SLAVE RESET PASSED, ERROR CODE PRESENT
          UJN    EPC80
 EPC70    BSS
          LDN    E51         SLAVE RESET PASSED
 EPC80    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    INTRS       INTERMEDIATE RESPONSE
          LDML   /SS/P.CT,CSST
          LMN    4
          ZJK    EPE40       IF DATA INTEGRITY PROBLEM
          LDN    6           INDEX TO NEXT STEP OF RECOVERY (EPD50)
          STML   /SS/P.RECOV,CSST
          AOML   /SS/P.RQTRY,CSST  REQUEST RETRY COUNT
          LJM    MAIN10
 EPC100   BSS
          LDDL   PTF
          ZJN    EPC110      IF IN PATH TEST
          LDML   /SS/P.CT,CSST
          ZJN    EPC110      IF INITIALIZATION CONFIDENCE TEST
          LDML   RS+/RS/P.ERRID
          SBN    E20
          MJN    EPC110      IF PROBABLY NOT CABLE PROBLEM
          SBN    E50-E20
          PJN    EPC110      IF PROBABLY NOT CABLE PROBLEM
          RJM    INTRS       REPORT INTERMEDIATE RESPONSE
          UJN    EPD
 EPC110   BSS
          RJM    OFFCM       TURN OFF ALL UNITS ON CONTROLLER (NO RETURN)

 EPCT     BSS    8           UX FOR RESET CONTROLLER
          SPACE  5,20
*         PATH TEST (ROUTINE PT WORKED ONCE, SLAVE RESET FAILED, MAY BE
*         DAISY CHAIN PROBLEM.)

 EPD      BSS
          LDML   /SS/P.RECOV,CSST
          LMN    3
          ZJN    EPD55       IF PATH TEST ALREADY STARTED
          AOML   /SS/P.RQTRY,CSST  REQUEST RETRY COUNT
          LDN    3
          STML   /SS/P.RECOV,CSST  INDEX TO THIS RECOVERY STEP (EPD)
          RJM    RAR         SETUP FOR RESTARTING ALL REQUESTS
          LDN    0
          STDL   PTF         FORCE RUNNING PATH TEST
          LJM    MAIN10
 EPD50    BSS                ENTER HERE IF ERROR AFTER SLAVE RESET
          LDDL   PTF
          NJN    EPD60       IF PATH TEST SUCCESSFUL
 EPD55    BSS
          RJM    OFFCM       TURN OFF ALL UNITS ON CONTROLLER (NO RETURN)
 EPD60    BSS
          RJM    INTRS       INTERMEDIATE RESPONSE
          RJM    CTR         CONFIDENCE TEST RECOVERY
          SPACE  5,20
*         DRIVE DIAGNOSTICS

 EPE      BSS
          LDN    4           INDEX TO NEXT RECOVERY PROCEDURE (EPF)
          STML   /SS/P.RECOV,CSST
          LDN    0
          STML   T11         RETRY COUNT FOR OFF LINING DRIVE
          AOML   /SS/P.RQTRY,CSST  REQUEST RETRY COUNT
          RJM    RCC         RESTART CONTROLLER COMMAND
          RJM    LIR         LOGICAL INTERFACE RESET
          RJM    CLR         CHECK FOR LABEL READ
          PJN    EPE30       IF LABEL READ AND NOT CLUSTERED CORRECTLY
          RJM    PDD         PERFORM DRIVE DIAGNOSTICS
          LDML   /SS/P.CT,CSST
          LMN    4
          ZJN    EPE40       IF DATA INTEGRITY ERROR
 EPE30    BSS
          LJM    MAIN10
 EPE40    BSS
          LDK    E111        CM-DRIVE DATA INTEGRITY
          STML   RS+/RS/P.ERRID  RESET ERROR IDENTIFIER
          SPACE  5,20
*         IF FINAL REQUEST RETRY FAILED

 EPF      BSS
          RJM    CTR         CONFIDENCE TEST RECOVERY
          RJM    IPDE        IS PARITY DRIVE ENABLED
          NJK    EPF6        IF NO PARITY DRIVE OR NO FAILING DRIVE
          LDDL   T2
          SHN    9
          PJN    EPF4        IF RESTORE NOT IN PROGRESS
          LDDL   T2
          LMML   RS+/RS/P.UNIT  FAILING DRIVE
          LPN    37B
          NJK    EPF6        IF ERROR NOT ON DRIVE BEING RESTORED
 EPF4     BSS
          LDML   /SS/P.FNC,CSST
          SBN    2
          ZJK    EPF6        IF FORMAT COMMAND
          LDML   T11
          SBN    2           ALLOW 2 RETRIES TO OFF LINE DRIVE
          PJK    EPF6        IF RETRIES EXHAUSTED
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          LDN    4
          STML   /SS/P.RECOV,CSST  INDEX TO NEXT RECOVERY STEP (EPF)
          AOML   T11         RETRY COUNT FOR OFF LINING DRIVE
          RJM    OFD         OFF LINE FAILING DRIVE
          LDN    /RS/K.PPD   PARITY PROTECTION DISABLED
          STML   RS+/RS/P.ID
          LDML   RS+/RS/P.UNIT
          LPC    37B
          RJM    UPPS        UPDATE PARITY PROTECTION STATUS IN UIT
          LDK    E59         PARITY PROTECTION DISABLED
          STML   RS+/RS/P.ERRID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          RJM    RCC         RESTART CONTROLLER COMMANDS
          LDML   UNITS,UX
          LPC    0#F7FF
          STML   UNITS,UX    ENSURE RESTORE IN PROGRESS IS CLEAR
          UJK    EPG10
 EPF6     BSS
          RJM    CLR         CHECK FOR LABEL READ
          PJN    EPF8        IF LABEL READ AT DEADSTART
          LDK    /RS/K.UDN   UNIT DOWN
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    OFFUN       TURN OFF UNIT
          UJN    EPF20
 EPF8     BSS
          LDN    1
          STDL   CMNDS       SO DCR ROUTINE LEAVES CMNDS EQUAL TO 0
 EPF10    BSS
          LDC    R.ABN*0#4000  ABNORMAL TERMINATION
          STML   RS+/RS/P.RC  RESPONSE CODE
          LDN    0
          STML   RS+/RS/P.SHORT   INDICATE ERROR RESPONSE
          LDC    RLIE
          STML   RS+/RS/P.RESPL  BYTE LENGTH OF RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          LDN    1           SO DCR DOES NO SEEK
          RJM    DCR         DELINK REQUEST
 EPF20    BSS
          RJM    RESPIN      UPDATE -IN- POINTER IN RESPONSE BUFFER
          LDN    5
          STML   /SS/P.RECOV,CSST  INDEX TO NEXT RECOVERY STEP (EPG)
          RJM    LIR         LOGICAL INTERFACE RESET
          SPACE  5,20
*         ENTER HERE IF PREVIOUS LOGICAL INTERFACE RESET WORKS OR FAILS

 EPG      BSS
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          MJN    EPG5        IF RESTORE IN PROGRESS
          RJM    UUT         UNLOCK UNIT TABLE
 EPG5     BSS
          RJM    RCC         RESTART CONTROLLER COMMANDS
 EPG10    BSS
          LDN    0
          STDL   IF          CLEAR INITIALIZATION FLAG
          STML   /SS/P.RQTRY,CSST  CLEAR RETRY COUNT
          LJM    MAIN10
 .F       IFEQ   FE,1        FORCE ERROR CODE
          SPACE  5,20
** NAME-- FER
*
** PURPOSE-- FORCE ERROR ROUTINE.  THE ERROR CAN BE FORCED BY CHANGING
*            CENTRAL MEMORY WORD 8.  SOME ROUTINES REQUIRE THE UNIT
*            NUMBER TO BE IN CENTRAL MEMORY WORD 9.
          SPACE  2
 FERX     LJM    **
 FER      EQU    *-1
          LDN    0
          STDL   T1
          LRDL   T1
          LDN    8           READ CENTRAL MEMORY WORD 8
          STDL   P1
          CRDL   P2
          LDDL   P2
          ZJN    FERX        IF NOT FORCING AN ERROR
          STDL   FEST
          LPN    77B
          STDL   P6          INDEX TO TABLE
          SBN    FETND-FET
          PJN    FERX        IF UNDEFINED VALUE
          LDN    0
          STDL   P2
          LDDL   P1
          CWDL   P2          INDICATE ERROR BEING FORCED
          LDDL   FEST
          SHN    -8
          STDL   FEST        FORCE ERROR START COUNT
          LDDL   P3
          STDL   FEND        FORCE ERROR END COUNT OR UNIT NUMBER
          LDN    9
          CRDL   P2          READ FROM BYTE ADDRESS 48(16)
          LDDL   P2
          STDL   FEUN        UNIT TO FORCE ERROR ON
          LDML   FET,P6
          STDL   P2
          LJM    0,P2        JUMP TO FORCE ERROR ROUTINE

*         TABLE OF ERRORS TO FORCE

 FET      BSS
          CON    FERX        NO ERROR
          CON    FERA        LOWER ICI PARITY ERROR ON READ
          CON    FERB        DROP SELECT DURING READ
          CON    FERC        LOWER ICI PARITY ERROR ON WRITE
          CON    FERD        DROP SELECT DURING WRITE
          CON    FERE        READ ONE TOO MANY WORDS (RECOVERABLE)
          CON    FERF        READ ONE TOO FEW WORDS (RECOVERABLE)
          CON    FERG        WRITE ONE TOO MANY WORDS (RECOVERABLE)
          CON    FERH        WRITE ONE TOO FEW WORDS (UNRECOVERABLE)
          CON    FERI        READ DATA IPI P.E. (RECOVERABLE)
          CON    FERJ        WRITE DATA IPI P.E. (RECOVERABLE)
          CON    FERK        SPIN DOWN UNIT
          CON    MAIN5       INITIALIZE, RUN PATH, CONF. TEST
          CON    FERM        COMMAND EXCEPTION FOR READ OR WRITE
          CON    FERN        LOWER ICI PARITY ERROR IN PATH TEST
          CON    FERO        UNABLE TO SELECT ERROR IN PATH TEST
          CON    FERP        COMMAND EXCEPTION ERROR IN PATH TEST
          CON    FERQ        LOWER ICI PARITY ERROR IN CONFIDENCE TEST
          CON    FERR        UNABLE TO SELECT ERROR IN CONFIDENCE TEST
          CON    FERS        COMMAND EXCEPTION ERROR IN CONFIDENCE TEST
          CON    FERT        CHANGE ONE MEMORY LOCATION
 FETND    BSS
          SPACE  5,20
** NAME-- FERA
*
** PURPOSE-- FORCE LOWER ICI PARITY ERROR ON READ
*            EB,40,XX01 YYYY
*            EB,48,CCDD
*                X = SECTORS TO READ BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*                CC = CONTROLLER NUMBER
*                DD = DRIVE NUMBER
*
** NOTE-- IF Y = 0 .. A  RECOVERABLE ERROR
*                B  CHANNEL DOWNED
*         EXPECTED ERROR CODE = 04
*
*         DON'T FORCE THIS WITH A RUNNING SYSTEM.  IT CAUSES NOS/VE TO
*         HANG.
          SPACE  2
 FERA     BSS
          LDC    FERA10
          UJN    FERB5
 FERA10   CON    0
          STDL   T1          SAVE FUNCTION
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJK    FERB20      IF WRONG DRIVE
          SODL   FEST
          PJN    FERB20      IF NOT TIME TO FORCE ERROR
          LDC    H0C22       FORCE LOWER ICI PARITY ERROR
          RJM    FUNC        SEND THE FUNCTION
          UJN    FERB15
          SPACE  5,20
** NAME--FERB
*
** PURPOSE-- DROP SELECT DURING READ
*            EB,40,XX02 YYYY
*            EB,48,CCDD
*                X = SECTORS TO READ BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*                CC = CONTROLLER NUMBER
*                DD = DRIVE NUMBER
*
** NOTE-- IF Y = 0 .. 3  RECOVERABLE ERROR
*                4  MEDIA FAILURE
*         EXPECTED ERROR CODE = 1B
          SPACE  2
 FERB     BSS
          LDC    FERB10
 FERB5    BSS
          STML   READ40
          LJM    MAIN10
 FERB10   CON    0
          STDL   T1          SAVE FUNCTION
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJN    FERB20      IF WRONG UNIT
          SODL   FEST
          PJN    FERB20      IF NOT TIME TO FORCE ERROR
          RJM    MR          MASTER RESET
 FERB15   BSS
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERB20      IF NOT TIME TO RESTORE INSTRUCTION
          LDC    FUNC
          STML   READ40      RESTORE FUNCTION
 FERB20   BSS
          LDDL   T1
          RJM    FUNC        SEND FUNCTION
          LJM    READ40+1    RETURN TO READ ROUTINE
          SPACE  5,20
** NAME-- FERC
*
** PURPOSE-- FORCE LOWER ICI PARITY ERROR ON WRITE
*            EB,40,XX03 YYYY
*            EB,48,CCDD
*                X = SECTORS TO WRITE BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*                CC = CONTROLLER NUMBER
*                DD = DRIVE NUMBER
*
** NOTE-- IF Y = 0 .. A  RECOVERABLE ERROR
*                B  CHANNEL DOWNED
*         EXPECTED ERROR CODE = 4
*
*         DON'T FORCE THIS ERROR WITH A RUNNING SYSTEM.  IT WILL CAUSE
*         NOS/VE GO HANG.
          SPACE  2
 FERC     BSS
          LDC    FERC10
          UJN    FERD5
 FERC10   CON    0
          STDL   T1
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJK    FERD20      IF WRONG UNIT
          SODL   FEST
          PJN    FERD20      IF NOT TIME TO FORCE ERROR
          LDC    H0C22       FORCE LOWER ICI PARITY ERROR
          RJM    FUNC        SEND THE FUNCTION
          UJN    FERD15
          SPACE  5,20
** NAME-- FERD
*
** PURPOSE-- DROP SELECT DURING WRITE
*            EB,40,XX04 YYYY
*            EB,48,CCDD
*                X = SECTORS TO WRITE BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*                CC = CONTROLLER NUMBER
*                DD = DRIVE NUMBER
*
** NOTE-- IF Y = 0 .. 3  RECOVERABLE ERROR
*                4  MEDIA ERROR
*         EXPECTED ERROR CODE = 1B(16)
          SPACE  2
 FERD     BSS
          LDC    FERD10
 FERD5    BSS
          STML   WRI40
          LJM    MAIN10
 FERD10   CON    0
          STDL   T1          SAVE FUNCTION
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJN    FERD20      IF WRONG UNIT
          SODL   FEST        FORCE ERROR START COUNT
          PJN    FERD20      IF NOT TIME TO FORCE ERROR
          RJM    MR          MASTER RESET
 FERD15   BSS
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERD20      IF NOT TIME TO RESTORE INSTRUCTION
          LDC    FUNC
          STML   WRI40       RESTORE THE INSTRUCTION
 FERD20   BSS
          LDDL   T1
          RJM    FUNC        SEND FUNCTION
          LJM    WRI40+1     RETURN TO WRITE ROUTINE
          SPACE  5,20
** NAME-- FERE
*
** PURPOSE-- READ ONE TOO MANY WORDS
*            EB,40,0005
*
** NOTE-- THIS SHOULD ALWAYS RECOVER WITH ONE RETRY
*         EXPECTED ERROR CODE = 1D(16)
          SPACE  2
 FERE     BSS
          LDC    FERE10
          UJN    FERF5
 FERE10   CON    0
          AODL   WC
          UJN    FERF15
          SPACE  5,20
** NAME-- FERF
*
** PURPOSE-- READ ONE TOO FEW WORDS
*            EB,40,0006
*
** NOTE-- THIS SHOULD ALWAYS RECOVER WITH ONE RETRY
*         EXPECTED ERROR CODE = 21(16)
          SPACE  2
 FERF     BSS
          LDC    FERF10
 FERF5    BSS
          STML   READ30
          LJM    MAIN10
 FERF10   CON    0
          SODL   WC
 FERF15   BSS
          LDC    BCS         RESTORE INSTRUCTION
          STML   READ30
          LJM    READ30-2
          SPACE  5,20
** NAME-- FERG
*
** PURPOSE-- WRITE ONE TOO MANY WORDS
*            EB,40,0007
*
** NOTE-- THIS SHOULD ALWAYS RECOVER WITH ONE RETRY
*         EXPECTED ERROR CODE = 21(16)
          SPACE  2
 FERG     BSS
          LDC    FERG10
          UJN    FERH5
 FERG10   CON    0
          AODL   WC
          UJN    FERH15
          SPACE  5,20
** NAME-- FERH
*
** PURPOSE-- WRITE ONE TOO FEW WORDS
*            EB,40,0008
*
** NOTE-- THIS SHOULD ALWAYS RECOVER WITH ONE RETRY
*         EXPECTED ERROR CODE = 20(16)
          SPACE  2
 FERH     BSS
          LDC    FERH10
 FERH5    BSS
          STML   WRI30
          LJM    MAIN10
 FERH10   CON    0
          SODL   WC
 FERH15   BSS
          LDC    BCS
          STML   WRI30       RESTORE INSTRUCTION
          LJM    WRI30-2
          SPACE  5,20
** NAME-- FERI
*
** PURPOSE-- FORCE IPI PARITY ERROR ON INPUT DURING READ
*            EB,40,0009
*
** NOTE-- THIS ERROR SHOULD ALWAYS BE RECOVERABLE
*         THE EXPECTED ERROR CODE IS 19(16)
          SPACE  2
 FERI     BSS
          LDC    FERI10
          STML   READ40
          LJM    MAIN10
 FERI10   CON    0
          LDC    FUNC
          STML   READ40      RESTORE MODIFIED INSTRUCTION
          LDC    H0322
          RJM    FUNC        FORCE BUS A INPUT PARITY ERROR
          LJM    READ40-3
          SPACE  5,20
** NAME-- FERJ
*
** PURPOSE-- FORCE IPI PARITY ERROR ON OUTPUT DURING WRITE
*            EB,40,000A
*
** NOTE-- THIS SHOULD ALWAYS RECOVER WITH ONE RETRY
*         EXPECTED ERROR CODE = 19(16)
          SPACE  2
 FERJ     BSS
          LDC    FERJ10
          STML   WRI40
          LJM    MAIN10
 FERJ10   CON    0
          LDC    FUNC
          STML   WRI40       RESTORE MODIFIED INSTRUCTION
          LDC    H0122
          RJM    FUNC        FORCE BUS A OUTPUT PARITY ERROR
          LJM    WRI40-3
          SPACE  5,20
** NAME-- FERK
*
** PURPOSE-- SPIN DOWN UNIT TO FORCE NOT READY ERROR
*            EB,40,000B CCDD
*                C = CONTROLLER NUMBER
*                D = LOGICAL UNIT NUMBER
*            EB,4C,EE00
*                E = DRIVE TO BE SPUN DOWN
*         THIS SHOULD ONLY BE USED WHEN THERE ARE NO OUTSTANDING
*         COMMANDS FOR THE CONTROLLER.
          SPACE  2
 FERK     BSS
          STML   CP+CRN      COMMAND REFERENCE NUMBER
          LDC    H0700       SET OPERATING MODE COMMAND
          STML   CP+OPCD     OPERATION
          LDDL   FEND
          STML   CP+SLAD     CONTROLLER, UNIT NUMBER
          SHN    -8
          STDL   CMOD        CONTROLLER NUMBER
          LDC    0#351       DISC MODES
          STML   CP+FCP
          LDC    0#4000
          STML   CP+FCP+1    SPIN DOWN UNIT
          LDC    0#2D5
          STML   CP+FCP+2
          LDDL   P4
          STML   CP+FCP+3    UNIT TO SPIN DOWN
          LDN    14
          RJM    ODFP        OUTPUT DATA FROM PP
          LJM    MAIN10
          SPACE  5,20
** NAME-- FERM
*
** PURPOSE-- CHANGE CYLINDER NUMBER TO ILLEGAL VALUE
*            TO FORCE AN ERROR ON WRITE OR READ
*            EB,40,XX0D YYYY
*            EB,48,CCDD
*                X = COMMANDS TO SEND BEFORE FORCING FIRST ERROR
*                Y + 1 = TIMES TO FORCE THE ERROR
*                CC = CONTROLLER NUMBER
*                DD = DRIVE NUMBER
*
** NOTE-- IF Y = 0 .. 3  RECOVERABLE ERROR
*                4  MEDIA ERROR
*         EXPECTED ERROR CODE = 49(16)
          SPACE  2
 FERM     BSS
          LDC    FERM10
          STML   SEEK20
          LJM    MAIN10
 FERM10   CON
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJN    FERM20      IF WRONG DRIVE
          SODL   FEST
          PJN    FERM20      IF NOT TIME TO FORCE ERROR
          LCN    0
          STML   CP+FCP+3    ILLEGAL CYLINDER NUMBER
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERM20      IF NOT TIME TO RESTORE INSTRUCTION
          LDC    CPT
          STML   SEEK20      RESTORE INSTRUCTION
 FERM20   BSS
          RJM    CPT         COMMAND PACKET TRANSFER
          LJM    SEEK20+1    RETURN TO SEEK ROUTINE
          SPACE  5,20
** NAME-- FERN
*
** PURPOSE-- FORCE LOWER ICI PARITY ERROR IN PATH TEST
*            EB,40,XX0E YYYY
*                X = TIMES TO RUN PATH TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*
** NOTE-- IF Y = 0 .. A  RECOVERABLE ERROR
*                B  CHANNEL DOWNED
*         EXPECTED ERROR CODE = 04
          SPACE  2
 FERN     BSS
          LDC    FERN10
          UJN    FERP5
 FERN10   CON    0
          SODL   FEST
          PJN    FERP20      IF NOT TIME TO FORCE ERROR
          LDC    H0C22       FORCE LOWER ICI PARITY ERROR
          RJM    FUNC        SEND THE FUNCTION
          UJN    FERP30
          SPACE  5,20
** NAME-- FERO
*
** PURPOSE-- DISABLE THE CONTROLLERS RECEIVERS TO PREVENT SELECTING
*            DURING THE PATH TEST
*            EB,40,XX0F YYYY
*                X = TIMES TO RUN PATH TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*
** NOTE-- IF Y = 4  CONTROLLER WILL BE DOWNED
*              = 0..3  RECOVERABLE ERROR
*         EXPECTED ERROR CODE = 14(16)
          SPACE  2
 FERO     BSS
          LDC    FERO10
          UJN    FERP5
 FERO10   CON    0
          SODL   FEST
          PJN    FERP20      IF NOT TIME TO FORCE ERROR
          RJM    MR          MASTER RESET
          UJN    FERP30
          SPACE  5,20
** NAME--FERP
*
** PURPOSE-- FORCE COMMAND EXCEPTION DURING THE PATH TEST
*            BY SENDING AN ILLEGAL BYTE COUNT
*            EB,40,XX10 YYYY
*                X = TIMES TO RUN PATH TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
** NOTE-- IF Y = 4  CONTROLLER WILL BE DOWNED
*              = 0..3  RECOVERABLE ERROR
*         EXPECTED ERROR CODE = 49(16)
          SPACE  2
 FERP     BSS
          LDC    FERP10
 FERP5    BSS
          STML   PT40
          LJM    MAIN10
 FERP10   CON    0
          SODL   FEST
 FERP20   BSS
          PJN    FERP40      IF NOT TIME TO FORCE ERROR
          LCN    0
          STML   CP+FCP+1    ILLEGAL BYTE COUNT
 FERP30   BSS
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERP40      IF NOT TIME TO RESTORE INSTRUCTION
          LDC    CPT
          STML   PT40        RESTORE INSTRUCTION
 FERP40   BSS
          RJM    CPT         COMMAND PACKET TRANSFER
          LJM    PT40+1      RETURN TO PATH TEST
          SPACE  5,20
** NAME-- FERQ
*
** PURPOSE-- FORCE LOWER ICI PARITY ERROR IN CONFIDENCE TEST
*            EB,40,XX11 YYYY
*                X = TIMES TO RUN CONFIDENCE TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*
** NOTE- IF Y = 0 .. A  RECOVERABLE ERROR
*             = B  UNIT DOWNED
*         EXPECTED ERROR CODE = 4
          SPACE  2
 FERQ     BSS
          LDC    FERQ10
          UJN    FERS5
 FERQ10   CON    0
          SODL   FEST
          PJN    FERS20      IF NOT TIME TO FORCE ERROR
          LDC    H0C22       FORCE LOWER ICI PARITY ERROR
          RJM    FUNC        SEND THE FUNCTION
          UJN    FERS30
          SPACE  5,20
** NAME-- FERR
*
** PURPOSE-- DISABLE THE CONTROLLERS RECEIVERS TO PREVENT SELECTING
*            DURING THE CONFIDENCE TEST
*            EB,40,XX12 YYYY
*                X = TIMES TO RUN CONFIDENCE TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*
** NOTE- IF Y = 0 .. 4  RECOVERABLE ERROR
*             = 5  UNIT DOWNED
*         EXPECTED ERROR CODE = 14(16)
          SPACE  2
 FERR     BSS
          LDC    FERR10
          UJN    FERS5
 FERR10   CON    0
          SODL   FEST
          PJN    FERS20      IF NOT TIME TO FORCE ERROR
          RJM    MR          MASTER RESET
          UJN    FERS30
          SPACE  5,20
** NAME--FERS
*
** PURPOSE-- FORCE COMMAND EXCEPTION DURING THE CONFIDENCE TEST
*            BY SENDING AN ILLEGAL CYLINDER NUMBER
*            EB,40,XX13 YYYY
*              X = TIMES TO RUN CONFIDENCE TEST BEFORE FORCING FIRST ERROR
*              Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*
** NOTE- IF Y = 0 .. 4  RECOVERABLE ERROR
*             = 5  UNIT DOWNED
*         EXPECTED ERROR CODE = 49(16)
          SPACE  2
 FERS     BSS
          LDC    FERS10
 FERS5    BSS
          STML   CTDT20
          LJM    MAIN10
 FERS10   CON    0
          SODL   FEST
 FERS20   BSS
          PJN    FERS40      IF NOT TIME TO FORCE ERROR
          LCN    0
          STML   CP+FCP+3    ILLEGAL CYLINDER NUMBER
 FERS30   BSS
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERS40      IF NOT TIME TO RESTORE INSTRUCTION
          LDC    CPT
          STML   CTDT20      RESTORE INSTRUCTION
 FERS40   BSS
          RJM    CPT         COMMAND PACKET TRANSFER
          LJM    CTDT20+1    RETURN TO CONFIDENCE TEST
          SPACE  5,20
** NAME-- FERT
*
** PURPOSE-- CHANGE ONE MEMORY LOCATION
*            EB,4C,XXXX YYYY
*              X = ADDRESS (HEX)
*              Y = VALUE (HEX)
*            EB,40,0014
          SPACE  2
 FERT     BSS
          LDDL   P5
          STIL   P4
          LJM    MAIN15
 .F       ENDIF
          SPACE  5,20
** NAME-- FS
*
** PURPOSE-- FORMAT ONE SECTOR.  FOR A 1P LOGICAL UNIT, THIS GUARANTEES
*            THAT A LATER READ TO THIS SECTOR WILL GET AN LRC ERROR RATHER
*            THAN RETURNING OLD DATA DUE TO PARITY DRIVE CORRECTION.
          SPACE  2
 FSX      LJM    **
 FS       EQU    *-1
          LDML   RPB+9,T3
          SHN    -8
          LMML   ODN,CSST
          ZJN    FSX         IF ERROR ON OFF LINE DRIVE
          RJM    LIR         LOGICAL INTERFACE RESET
          LDC    0#2807      FORMAT OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDC    H0931
          STML   CP+FCP      COMMAND EXTENT PARAMETER
          LDN    0
          STML   CP+FCP+1
          LDN    1
          STML   CP+FCP+2    SECTOR COUNT
          LDML   RS+/RS/P.SCYL
          STML   CP+FCP+3    CYLINDER TO FORMAT
          LDML   /SS/P.CURTRK,CSST
          SHN    8
          ADML   /SS/P.CURSEC,CSST
          STML   CP+FCP+4    TRACK, SECTOR TO FORMAT
          LDC    0#1E5
          STML   CP+FCP+5    DON'T READ HEADERS
          LDC    0#2D5
          STML   CP+FCP+6    PARAMETER TO SELECT PHYSICAL DRIVE
          LDML   ODN,CSST
          SHN    8
          STML   CP+FCP+7    DRIVE TO FORMAT
          LDN    0#16        COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          UJK    FSX
          SPACE  5,20
** NAME-- FU
*
** PURPOSE-- FORMAT UNIT
*
** ENTRY
*         - A = 0  IF DRIVE IS DECLUSTERED
*         - PD MUST BE THE PHYSICAL DRIVE TO FORMAT
          SPACE  2
 FUX      LJM    **
 FU       EQU    *-1
          STML   T10
          LDN    E57         FORMATTING DRIVE
          RJM    PER         PREPARE ERROR RESPONSE
          LDN    0
          STML   RS+/RS/P.SCYL  STARTING CYLINDER
          STML   RS+/RS/P.FTRK  SO TRACK, SECTOR WILL BE 0 IN CRITICAL WINDOW
          STML   RS+/RS/P.FSEC
          RJM    INTRS       SEND INTERMEDIATE RESPONSE

*         FORMAT THE DIAGNOSTIC CYLINDER

          LDC    0#280E+400000B  FORMAT OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDC    0#2D5       PARAMETER TO SELECT DRIVE
          STML   CP+FCP
          LDDL   PD
          SHN    8
          STML   CP+FCP+1    DRIVE TO FORMAT
          LDC    0#1E5
          STML   CP+FCP+2    DON'T READ HEADERS
          LDC    0#1DF
          STML   CP+FCP+3    FORMAT THE DIAGNOSTIC CYLINDER
          LDDL   DT          DRIVE TYPE
          SBN    2
          MJN    FU10        IF 5832
          LDML   T10
          ZJN    FU5         IF DRIVE DECLUSTERED
          LDML   /SS/P.UNIT,CSST
          STML   CP+SLAD     LOGICAL ADDRESS
 FU5      BSS
          LDN    0#E         COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP

*         FORMAT THE DATA CYLINDERS

 FU10     BSS
          LDC    0#7DD       FACTORY FORMAT PARAMETER
          STML   CP+FCP+3
          LDML   DD,DT
          STML   CP+FCP+4    DATA DRIVES PER LOGICAL UNIT
          LDN    0
          STML   CP+FCP+5    UPPER BYTES OF SECTOR SIZE
          LDML   BPS,DT      BYTES PER SECTOR
          STML   CP+FCP+6
          LDML   T10
          ZJN    FU20        IF DRIVE DECLUSTERED
          LDC    0#53B
          STML   CP+FCP+3    LOGICAL SECTOR SIZE
          LDN    0
          STML   CP+FCP+4    UPPER BYTES OF SECTOR SIZE
          LDML   BPS,DT
          STML   CP+FCP+5
          LDN    0#12        COMMAND PACKET LENGTH
          UJN    FU30
 FU20     BSS
          LDN    0#14        COMMAND PACKET LENGTH
 FU30     BSS
          RJM    ODFP        OUTPUT DATA FROM PP
          LDN    E58         FORMAT COMPLETE
          RJM    PER         PREPARE ERROR RESPONSE
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          UJK    FUX
          SPACE  5,20
** NAME-- GETR
*
** PURPOSE-- DETERMINE WHETHER OR NOT TO USE MASTER TERMINATE.
*            MASTER TERMINATE MEANS USE A LARGE SECTOR COUNT AND
*            TERMINATE WHEN THERE IS NO MORE DATA TO TRANSFER.
*            SINCE THERE IS A PERFORMANCE PENALTY ON READS, ONLY
*            USE MASTER TERMINATE FOR READS WHEN MORE THAN ONE PAGE
*            IS TO BE TRANSFERRED.  IF USING MASTER TERMINATE, SET
*            THE MASTER TERMINATE FLAG AND EXIT.
*
*            IF NOT USING MASTER TERMINATE, COMPUTE THE TOTAL SECTORS
*            TO TRANSFER AND SAVE IN SS TABLE.  THE PP DRIVER WILL
*            ISSUE UP TO 2 COMMANDS PER DRIVE.  IF NO COMMANDS ARE
*            OUTSTANDING, GET THE FIRST REQUEST FROM CM, GET THE FIRST
*            COMMAND FROM THE REQUEST AND SET UP THE STATUS RESPONSE
*            BUFFER.  IF ONE COMMAND IS STILL ACTIVE FOR THE DRIVE,
*            GETTING THE REQUEST INTO THE SS TABLE WILL BE DONE IN
*            ROUTINE DCR.
          SPACE  2
 GETRX    LJM    **
 GETR     EQU    *-1
          LDN    0
          STML   CP+FCP+1    UPPER WORD OF SECTOR COUNT
          LDDL   CSST
          STDL   P5          SAVE CURRENT SS TABLE POINTER
          LDC    IPIT
          STDL   CSST        START OF ALTERNATE SS TABLE
          LDDL   CNUM
          ZJN    GETR5       IF FIRST COMMAND
          LDML   /SS/P.RMA2,P5
          STML   /SS/P.REQ,CSST
          LDML   /SS/P.RMA2+1,P5
          UJN    GETR10
 GETR5    BSS
          LDML   /SS/P.REQ,P5
          STML   /SS/P.REQ,CSST
          LDML   /SS/P.REQ+1,P5
 GETR10   BSS
          STML   /SS/P.REQ+1,CSST
          RJM    UREQ        READ UNIT REQUEST FROM CM
          LDML   CM+/CM/P.CODE,CSST
          SHN    -12
          SBN    4
          STDL   FNC         SAVE FUNCTION
          LDML   RQ+/RQ/P.CYL,CSST
          STML   CP+FCP+3    CYLINDER
          LDML   RQ+/RQ/P.TRACK,CSST
          SHN    8
          ADML   RQ+/RQ/P.SECTOR,CSST
          STML   CP+FCP+4    HEAD, SECTOR

*         IF IN RECOVERY AND USING MASTER TERMINATE, THIS GUARANTEES A
*         WRITE ERROR FOR THE NTH REQUEST DOES NOT RETURN AN ERROR FOR
*         A PREVIOUS REQUEST.

          LDML   RQ+/RQ/P.SWIT,CSST
          LPC    777B
          STDL   TOTAL       SECTOR COUNT FOR REQUEST
          LDML   /SS/P.RQTRY,P5
          NJN    GETR30      IF IN ERROR RECOVERY
          LDM    /SS/P.DT,P5
          SHN    -4
          SBN    2
          MJN    GETR30      NO MASTER TERMINATE IF 5832
          LDDL   FNC
          SBN    1
          ZJN    GETR15      IF WRITE (USE MASTER TERMINATION)
          LDDL   TOTAL
          SBN    1
          ZJN    GETR30      IF MAU COUNT = 1 (NO MASTER TERMINATION)
          LDML   CM+/CM/P.LEN,CSST
          SBN    8
          ZJN    GETR30      IF ONLY ONE LIST
 GETR15   BSS
          LDDL   P5
          STDL   CSST        RESTORE POINTER TO SS TABLE
          LDDL   CNUM
          ZJN    GETR38      IF FIRST COMMAND FOR UNIT
          LDC    0#8000      INDICATE MASTER TERMINATE BEING USED
          ADDL   TOTAL
          UJN    GETR35
 GETR30   BSS
          LDDL   P5
          STDL   CSST        RESTORE POINTER TO SS TABLE
          LDDL   CNUM
          ZJN    GETR40      IF FIRST COMMAND FOR UNIT
          LDDL   TOTAL
 GETR35   BSS
          STML   /SS/P.TW2,CSST
          UJN    GETR50
 GETR38   BSS
          LDC    0#8000      INDICATE MASTER TERMINATE BEING USED
 GETR40   BSS
          ADDL   TOTAL
          STML   /SS/P.TOTAL,CSST
          RJM    UREQ        READ UNIT REQUEST FROM CM
          RJM    SRESP       SET UP STATUS FOR RESPONSE BUFFER
          RJM    SETRQ       SET UP FOR FIRST REQUEST
          RJM    UNCMND      GET FIRST COMMAND
 GETR50   BSS
          UJK    GETRX
          SPACE  5,20
** NAME-- GETU
*
** PURPOSE-- GET A UNIT REQUEST FROM CENTRAL, ISSUE ALL
*            SEEKS, AND PROCESS INTERRUPTS FROM THE CONTROLLER
          SPACE  2
 GETUX    LJM    **
 GETU     EQU    *-1
          LDDL   UNUML
          ZJN    GETUX       IF NO UNITS
          RJM    UC          UPDATE CLOCK
          LDDL   LUX         UNIT INDEX OF LAST REQUEST FOUND + 1
          STDL   P6
          LDN    0
          AJM    GETU5,DC    IF NO FUNCTION REPLY
          ACN    DC+40B
          EJM    GETU5,DC    IF CHANNEL NOT FULL
          IAN    DC
          LPC    377B
 GETU5    BSS
          STDL   STATUS      SAVE INTERRUPT STATUS
          LDC    H0711
          RJM    FAN         DROP MASTER OUT
 GETU10   BSS
          LDDL   LUX
          STDL   UX
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE
          LDN    P.UN
          RADL   LUX         BUMP UNIT ENTRY
          SBDL   UNUML
          MJN    GETU15      IF NOT END OF TABLE
          STDL   LUX
 GETU15   BSS
          LDML   /SS/P.UNIT,CSST
          SHN    -8
          STDL   CMOD        SAVE CONTROLLER NUMBER
          LDML   UNITS,UX
          SHN    /UN/L.CIP+2
          PJK    GETU50      IF NO COMMAND IN PROGRESS
          LDML   SELT,CMOD   MASK VALUE
          LPDL   STATUS      INTERRUPT STATUS
          ZJN    GETU20      IF NO INTERRUPT FOR THIS CONTROLLER
          RJM    PI          PROCESS INTERRUPT (NO RETURN)
 GETU20   BSS
          LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          PJN    GETU40      IF 2ND COMMAND CAN BE ISSUED
 GETU25   BSS
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    GETU30      IF CLOCK HASNT WRAPPED
          ADC    0#10000
 GETU30   BSS
          SBN    CMT         COMMAND TIMEOUT
          PJK    GETU95      IF TIMEOUT

*         GO TO NEXT UNIT ENTRY.

 GETU35   BSS
          LDDL   LUX         HAVE ALL ENTRIES BEEN CHECKED
          SBDL   P6
          ZJK    GETUX       IF NO MORE ENTRIES TO CHECK
          UJK    GETU10

*         ONE COMMAND IN PROGRESS

 GETU40   BSS
          LDDL   CMNDS
          SBN    32
          PJK    GETU25      IF 32 SEEKS ISSUED
          STDL   CNUM        INDICATE SECOND COMMAND TO UNIT
          LDDL   IF
          ZJK    GETU45      IF NO INITIALIZATION NECESSARY
          LDML   /SS/P.CT,CSST
          LPN    7
          NJN    GETU25      IF CONFIDENCE TEST ALREADY RUN
          LDDL   CMNDS
          NJN    GETU35      IF OUTSTANDING COMMANDS
          STML   /SS/P.CT,CSST  IN CASE ASYNCH FOR PARITY DRIVE
          RJM    CT          RUN CONFIDENCE TEST
 GETU44   LJM    GETUX
 GETU45   BSS
          LDML   /SS/P.CT,CSST
          LPN    7
          ZJK    GETU25      IF CONFIDENCE TEST SHOULD BE RUN
          LDDL   MALET
          NJK    GETU25      IF MAINTENANCE REQUEST
          LDML   UNITS,UX
          LPC    0#A00
          NJK    GETU25      IF RESTORE OR INITIALIZE ATTRIBUTES
          LDML   /SS/P.RQTRY,CSST
          NJK    GETU25      IF IN ERROR RECOVERY
          RJM    SR          SELECT REQUEST
          NJK    GETU25      IF REQUEST NOT FOUND
          RJM    GETR        GET REQUEST
          LDML   IPIT+CM+/CM/P.CODE
          SHN    -8
          LMC    C.FORMAT
          ZJK    GETU25      IF FORMAT COMMAND
          LJM    GETU85

*         NO COMMAND IN PROGRESS

 GETU50   BSS
          LDDL   IF
          NJK    GETU35      IF INITIALIZATION FLAG SET
          LDML   UNITS,UX
          SHN    /UN/L.ACIP+2
          PJK    GETU55      IF NO COMMAND IN PROGRESS FOR ALTERNATE ACCESS
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.ULOCK  INDEX TO LOCKWORD
          CRDL   T1          READ LOCKWORD
          LDDL   T1
          ZJN    GETU52      IF UNIT NOT LOCKED
          LDDL   T4
          SBDL   LPN
          NJK    GETU35      IF ALTERNATE PP HAS THE LOCK
 GETU52   BSS
          LDML   UNITS,UX
          LPC    0#DFFF
          STML   UNITS,UX    CLEAR ALTERNATE COMMAND IN PROGRESS BIT
          SHN    -3
          LPN    37B
          STDL   P1          INDEX TO UPASB TABLE
          SOML   UPASB,P1    DECREMENT UNITS PER ALTERNATE PATH STRING BUSY COUNTER
          NJN    GETU55      IF OTHER UNITS ON ALTERNATE STRING ARE BUSY
          SOML   APSB        DECREMENT ALTERNATE PATH STRINGS BUSY COUNTER

*         CHECK FOR ANY REQUESTS ON THIS UNIT QUEUE.

 GETU55   BSS
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T5          READ UNIT DISABLED FLAG
          ADN    /UIT/C.ULOCK  INDEX TO LOCKWORD
          CRDL   T1          READ LOCKWORD
          LDDL   T8          QUEUE COUNT
          NJN    GETU56      IF REQUEST ON QUEUE
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          PJK    GETU35      IF RESTORE NOT IN PROGRESS
          LDN    0
          STML   RTM,CSST    REQUESTS TO MULTIPLEX
 GETU56   BSS
          LDDL   T5+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJK    GETU35      IF UNIT DISABLED
          LDML   UNITS,UX
          SHN    -3
          LPN    37B
          STDL   P1          INDEX TO UPSB AND UPASB TABLES
          LDDL   T2
          ADDL   T3
          ZJN    GETU60      IF NO ALTERNATE ACCESS
          SBDL   LPN
          ZJN    GETU60      IF NO ALTERNATE ACCESS
          LDDL   T1
          ZJN    GETU58      IF UNIT NOT LOCKED
          LDDL   T4
          SBDL   LPN
          NJK    GETU65      IF ALTERNATE PP HAS THE UNIT
          UJN    GETU60
 GETU58   BSS
          LDML   UPSB,P1
          SBML   UPASB,P1
          MJN    GETU60      IF THIS PP SHOULD ISSUE THE SEEK
          NJN    GETU65      IF ALTERNATE PP SHOULD ISSUE THE SEEK
          LDML   APSB
          SBML   PSB
          MJN    GETU65      IF ALTERNATE PP SHOULD ISSUE THE SEEK
 GETU60   BSS
          LDDL   CMNDS
          SBN    32
          PJN    GETU65      IF 32 SEEKS ISSUED
          LDML   /SS/P.RQTRY,CSST
          NJN    GETU62      IF IN ERROR PROCESSING FOR THIS UNIT
          LDDL   MALET
          NJN    GETU70      IF MAINTENANCE REQUEST
 GETU62   BSS
          RJM    LUT         LOCK UNIT TABLE
          NJN    GETU65      IF LOCK UNSUCCESSFUL
          STDL   CNUM        INDICATE 1ST COMMAND TO UNIT
          AOML   UPSB,P1     INCREMENT UNITS PER STRING BUSY COUNTER
          SBN    1
          NJN    GETU75      IF STRING ALREADY HAS A BUSY UNIT
          AOML   PSB         INCREMENT PATH STRINGS BUSY
          UJN    GETU75
 GETU65   BSS
          LDML   UNITS,UX
          LMC    0#2000
          STML   UNITS,UX    SET ALTERNATE COMMAND IN PROGRESS
          AOML   UPASB,P1    INCREMENT UNITS PER ALTERNATE STRING BUSY COUNTER
          SBN    1
          NJK    GETU70      IF NOT 1ST BUSY UNIT ON ALTERNATE STRING
          AOML   APSB        INCREMENT ALTERNATE PATH STRINGS BUSY COUNTER
 GETU70   BSS
          UJK    GETU35
 GETU75   BSS
          LDML   UNITS,UX
          SHN    /UN/L.PDCE+2
          PJN    GETU76      IF PARITY DRIVE CORRECTION DISABLED
          LDML   /SS/P.RQTRY,CSST
          NJN    GETU76      IF IN ERROR PROCESSING FOR THIS UNIT

*         INITIALIZE DRIVE ATTRIBUTES TO DISABLE PARITY DRIVE CORRECTION.

          LDC    H0202       RESTORE ATTRIBUTES OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
*         LDML   UNITS,UX    INDICATE ONE COMMAND IN PROGRESS
          LMC    0#8000
          STML   UNITS,UX
          AODL   CMNDS
          LDDL   UX
          STML   CP+CRN      COMMAND REFERENCE NUMBER
          LDN    6
          STML   CP          COMMAND PACKET LENGTH
          RJM    CPT         COMMAND PACKET TRANSFER
          UJK    GETU90
 GETU76   BSS
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          PJN    GETU78      IF NOT RESTORING DRIVE
          LDML   RTM,CSST    REQUESTS TO MULTIPLEX
          NJN    GETU78      IF NOT TIME TO RESTORE
          LDML   /SS/P.CT,CSST
          LPN    7
          NJN    GETU77      IF DON'T NEED TO RUN CONFIDENCE TEST
          AOML   RTM,CSST    FORCE REQUEST TO BE PRESENT TO RUN CONFIDENCE TEST
          RJM    DUBC        DECREMENT UNIT BUSY COUNTER
          UJN    GETU90
 GETU77   BSS
          RJM    IRD         ISSUE RESTORE DRIVE
          UJN    GETU90
 GETU78   BSS
          RJM    SR          SELECT REQUEST
          NJN    GETU78      IF QUEUE LOCK NOT OBTAINED
          RJM    GETR        GET REQUEST
          LDML   /SS/P.CT,CSST
          LPN    7
          ZJN    GETU80      IF CONFIDENCE TEST NOT RUN
          LDDL   FNC
          SBN    2
          NJN    GETU85      IF NOT FORMAT
          RJM    PFMT        PROCESS FORMAT PARAMETER
          NJN    GETU90      IF FORCE FORMAT FUNCTION
 GETU80   BSS
          LDML   UNITS,UX    SET COMMAND IN PROGRESS
          LMC    0#8000
          STML   UNITS,UX
          STDL   IF          SET INITIALIZATION FLAG
          UJN    GETU90
 GETU85   BSS
          RJM    SEEK        ISSUE INITIAL SEEK
 GETU90   BSS
          LJM    GETUX
 GETU95   BSS
          LDML   /SS/P.RESET,CSST
          ZJN    GETU120     IF RESET NOT ISSUED
          LDML   EPCT,CMOD
          SBDL   UX
          NJN    GETU115     IF DIFFERENT UNIT
          LDC    SRT         SLAVE RESET TIMEOUT
          STDL   T1
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    GETU110     IF CLOCK HASNT WRAPPED
          ADC    0#10000
 GETU110  BSS
          SBDL   T1
          PJN    GETU120     IF TIMEOUT
 GETU115  BSS
          LJM    GETU35
 GETU120  BSS
          LDN    E38         NO CONTROLLER RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 HSTF     BSSZ   1           HEAD SHIFT TEST FLAG
          SPACE  5,20
** NAME-- GLIST
*
** PURPOSE-- READ ONE ENTRY FROM THE CM ADDRESS LIST PORTION OF A COMMAND.
*
** ENTRY  LISTL
*
** EXIT   CMLIST, CM+/CM/P.RMA
          SPACE  2
 GLIX     LJM    **
 GLIST    EQU    *-1
          LDDL   CSST        ADDRESS OF SS TABLE
          ADK    CMLIST
          STML   GLIST4      ADDRESS TO STORE CM LIST
          LDN    1
          STDL   WD          NUMBER OF CM WORDS TO READ
          LOADF  CM+/CM/P.RMA,CSST  LOAD CM ADDRESS AND REFORMAT
          CRML   *,WD        READ ONE ENTRY FROM THE LIST
 GLIST4   EQU    *-1
          LDN    8
          RAML   CM+/CM/P.RMA+1,CSST  UPDATE RMA ADDRESS FOR NEXT READ
          SHN    -16
          RAML   CM+/CM/P.RMA,CSST
          LDML   CMLIST+/CM/P.LEN,CSST  ENSURE AN EVEN NUMBER OF WORDS
          ADN    7
          SCN    7
          STML   CMLIST+/CM/P.LEN,CSST
          UJK    GLIX
          SPACE  5,20
** NAME-- HSDT
*
** PURPOSE-- RUN HEAD SHIFT DETECTION TEST
*         SPACE  2
 HSDTX    LJM    **
 HSDT     EQU    *-1
          LDML   /SS/P.MREV+1,CSST
          LPN    77B
          SBN    0#14        REV LEVEL 14
          PJN    HSDT5       IF MICROCODE SUPPORTS HEAD SHIFT SCREEN
          LDN    0
          UJK    HSDT35      EXIT
 HSDT5    LCN    0
          STML   HSDDR       INDICATE NO OFF-LINE DRIVE
          LDML   /SS/P.UNIT,CSST
          LPN    77B
          STDL   PD          PHYSICAL DRIVE
          LPN    70B
          NJN    HSDT15      IF NOT DRIVE NUMBER 0-7
          RJM    RAS         REPORT ADDRESSEE STATUS
          LPN    77B
          STML   HSDDR       OFF-LINE DRIVE NUMBER
 HSDT10   LDML   HSDDR
          MJN    HSDT15      IF NO OFF-LINE DRIVE
          LMD    PD
          ZJK    HSDT30      IF THIS DRIVE IS OFF-LINE
 HSDT15   LDC    H8101       PERFORM HEAD SHIFT TEST OP CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDC    0#2D5
          STML   CP+FCP      PARAMETER TO SELECT DRIVE
          LDDL   PD
          LPN    37B
          SHN    8
          STML   CP+FCP+1    PHYSICAL DRIVE NUMBER
          LDN    10
          STML   CP          COMMAND PACKET LENGTH
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LPN    0#A
          NJN    HSDT30      IF COMMAND SUCCESSFUL
          LDK    ID23
          RJM    SFP         SEARCH FOR PARAMETER
          PJN    HSDT20      IF ID23
          LDN    E00
          UJN    HSDT25      CP MUST DETERMINE ERROR
 HSDT20   LDML   RPB+8,T3    OCTET 5/6
          LPN    20B
          ZJN    HSDT26      IF NOT HEAD SHIFT ERROR
          LDK    E96         DRIVE HEAD SHIFT ERROR
 HSDT25   RJM    PCER        PREPARE COMMON ERROR RESPONSE
 HSDT26   RJM    INTRS       SEND INTERMEDIATE RESPONSE
          RJM    LIR         LOGICAL INTERFACE RESET
 HSDT30   RJM    UPD         UPDATE DRIVE NUMBER
          NJK    HSDT10      IF MORE DRIVES TO TEST
 HSDT35   STML   HSTF        CLEAR HEAD SHIFT TEST FLAG
          UJK    HSDTX
 HSDDR    DATA   0
          SPACE  5,20
** NAME-- IDTP
*
** PURPOSE-- INPUT DATA TO PP (RPB+8)
*
** ENTRY  A = COMMAND PACKET LENGTH
*
** EXIT   TO CALLING ROUTINE IF NO ERROR
          SPACE  5,20
 IDTPX    LJM    **
 IDTP     EQU    *-1
          STML   CP          COMMAND PACKET LENGTH
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    IDTP50      IF NOT TRANSFER NOTIFICATION RESPONSE
          RJM    VRP         VERIFY RESPONSE PACKET
          LDC    ID6D
          RJM    SFP         SEARCH FOR PARAMETER
          MJK    IDTP50      IF ID 6D NOT FOUND
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAIN      DATA TRANSFER IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDML   CP+OPCD
          LMC    0#8400
          NJN    IDTP10      IF NOT READ ERROR LOG
          LDC    H0A81       STREAM, READ TO CM
          RJM    FUNC        RAISE MASTER OUT
          ACN    DC
          LDML   RPB+5+2,T3  BYTE LENGTH OF RESPONSE
          STDL   T5
          ADN    1           IN CASE OF ODD BYTE LENGTH
          SHN    -1
          LPC    0#FFF       ENSURE BUFFER IS NOT OVERFLOWED
          STDL   WC          16-BIT WORDS TO INPUT
          LOADC  CM.CB       ADDRESS TO PUT DATA
          CHCM   WC,DC       TRANSFER DATA TO CM
          UJN    IDTP20
 IDTP10   BSS
          LDDL   MFID        MASK FOR INTERLOCK DATA
          LPN    1
          SHN    9
          LMC    H0281       STREAM, READ
          RJM    FUNC        RAISE MASTER OUT
          ACN    DC
          LDML   RPB+5+2,T3
          STDL   T5
          ADN    1           IN CASE OF ODD BYTE LENGTH
          SHN    -1          PP WORDS TO INPUT
          LPC    377B        PROTECT AGAINST ILLEGAL LENGTH
          IAM    RPB+8,DC
          STDL   WC          WORDS NOT TRANSFERRED
 IDTP20   BSS
          LDC    MS50
 IDTP30   BSS
          IJM    IDTP40,DC   IF SLAVE IN DROPPED
          SBN    1
          NJN    IDTP30      IF TIMEOUT NOT EXPIRED
          RJM    CSI         CHECK SLAVE IN
 IDTP40   BSS
          LDN    0
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT THE CONTROLLER
          LDDL   WC
          NJN    IDTP60      IF NOT ALL WORDS TRANSFERRED
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          NJN    IDTP50      IF NOT SUCCESSFUL
          RJM    VRP         VERIFY RESPONSE PACKET
          LJM    IDTPX
 IDTP50   BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          UJN    IDTP70
 IDTP60   BSS
          LDN    E29         INCOMPLETE TRANSFER
 IDTP70   BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- IH
*
** PURPOSE-- INTERRUPT HANDLER.  INPUT THE RESPONSE PACKET.  REPORT
*            ASYNCHRONOUS DRIVE ERROR RESPONSES FOR CONFIGURED UNITS.
*
** EXIT
*         A = MAJOR STATUS
*         THE DRIVE IS DESELECTED
          SPACE  2
 IHX      LJM    **
 IH       EQU    *-1
          LDDL   MFID        MASK FOR INTERLOCK DATA
          ZJN    IH10        IF STREAMING MODE

*         IF 10 MB CHANNEL AND INTERLOCK MODE, SOMETIMES AFTER SENDING
*         A COMMAND PACKET, THE ERROR FLAG WILL SET DURING THE FOLLOWING
*         BUS CONTROL SEQUENCE (IPI ERROR REGISTER = 0004).  MASTER
*         CLEARING THE CHANNEL AFTER THE COMMAND PACKET PREVENTS THIS PROBLEM.

          RJM    MCC         MASTER CLEAR CHANNEL
 IH10     BSS
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,UX  SAVE CLOCK IN TABLE
          LDML   CP+OPCD
          SHN    -8
          ZJN    IH40        IF LOGICAL INTERFACE RESET
          SBN    7
          NJN    IH20        IF NOT SPIN UP DRIVE
          LDC    115         115 SECOND TIMEOUT FOR SPIN UP DRIVE
          UJN    IH60
 IH20     BSS
          SBN    1
          ZJN    IH40        IF DRIVE RESET
          SBN    0#20
          NJN    IH30        IF NOT FORMAT
          LDML   CP
          LMN    0#E
          ZJN    IH40        IF NOT FORMAT OF ENTIRE DRIVE
          LDC    FPT         FORMAT PACK TIMEOUT
          UJN    IH60
 IH30     BSS
          LDML   /SS/P.RESET,CSST
          NJN    IH50        IF RESET ISSUED
 IH40     BSS
          LDN    CMT         COMMAND TIMEOUT
          UJN    IH60
 IH50     BSS
          LDC    SRT         SLAVE RESET TIMEOUT
 IH60     BSS
          STDL   T7          SAVE TIMEOUT VALUE
 IH70     BSS
          RJM    RI          REQUEST INTERRUPTS
          LDML   SELT,CMOD   MASK VALUE
          LPDL   STATUS      INTERRUPT STATUS
          NJN    IH90        IF INTERRUPT PRESENT
          RJM    UC          UPDATE CLOCK
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    IH80        IF CLOCK HAS NOT WRAPPED
          ADC    0#10000
 IH80     BSS
          SBDL   T7
          MJN    IH70        IF TIMEOUT NOT EXPIRED
          LDK    E38         NO CONTROLLER RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 IH90     BSS
          RJM    DTM         DETERMINE TRANSFER MODE
          RJM    SEL         SELECT THE CONTROLLER
          STDL   CTM         CLEAR CHANGE TRANSFER MODE FLAG
          RJM    RPT         RESPONSE PACKET TRANSFER
          RJM    DCM         DESELECT THE CONTROLLER
          LDML   RPB+MAJST   MAJOR STATUS
          SHN    -4
          LPN    0#F
          LMN    AR
          NJN    IH100       IF NOT ASYNCHRONOUS RESPONSE
          LDML   RPB+SLAD
          LPC    0#FF
          LMC    0#FF
          ZJN    IH110       IF ASYNCHRONOUS RESPONSE FOR CONTROLLER
          LDML   RPB+OPCD
          SHN    -8
          LMC    0#FF
          NJN    IH100       IF ASYNCH ASSOCIATED WITH A COMMAND
          RJM    DARH        DRIVE ASYNCHRONOUS RESPONSE HANDLER
          LDML   CP+OPCD
          LMC    0#100
          ZJN    IH100       IF ASYNCHRONOUS RESPONSE EXPECTED
          UJN    IH120       GO LOOK FOR ANOTHER INTERRUPT
 IH100    BSS
          LDML   RPB+MAJST   MAJOR STATUS
          LJM    IHX
 IH110    BSS
          LDK    ID16
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    IH100       IF ID16 NOT FOUND
          LDML   RPB+6,T3
          SHN    -8
          PJN    IH100       IF NOT CONTROLLER OVER TEMPERATURE
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 IH120    BSS
          LJM    IH70        GO LOOK FOR ANOTHER INTERRUPT
          SPACE  5,20
** NAME-- INTERR
*
** PURPOSE-- REPORT AN INTERFACE ERROR
          SPACE  2
 INTERR   CON    0
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LDK    /RS/K.INTERR  INTERFACE ERROR
          STML   RS+/RS/P.INTERR  ABNORMAL STATUS CODE
          LDK    E120        SOFTWARE FAILURE
          STML   RS+/RS/P.ERRID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          RJM    HANG        (NO RETURN)
          SPACE  5,20
** NAME-- INTRS
*
** PURPOSE-- SEND INTERMEDIATE RESPONSE.
          SPACE  2
 INTRSX   LJM    **
 INTRS    EQU    *-1
          LDDL   PTF
          NJN    INTRS20     IF NOT PATH TEST
 INTRS10  BSS
          RJM    SNMSG       SEND UNSOLICTED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          UJN    INTRSX
 INTRS20  BSS
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          PJN    INTRS30     IF NOT RESTORING DRIVE
          LDML   RTM,CSST
          ZJN    INTRS10     IF RESPONSE FOR RESTORE
 INTRS30  BSS
          LDN    0
          STML   RS+/RS/P.SHORT   INDICATE ERROR RESPONSE
          LDC    RLIE
          STML   RS+/RS/P.RESPL  BYTE LENGTH OF RESPONSE
          LDN    R.INT       INTERMEDIATE RESPONSE
          SHN    16-/RS/N.RC-/RS/L.RC
          STML   RS+/RS/P.RC  RESPONSE CODE
          RJM    TERMP       SEND RESPONSE TO CM
          UJK    INTRSX
          SPACE  5,20
**NAME-- IPDE
*
** PURPOSE-- IS PARITY DRIVE ENABLED
*
** EXIT-- A NONZERO IF NO PARITY DRIVE OR NO FAILING DRIVE
*         T2 = RESPONSE BUFFER + 9  FROM REPORT ADDRESSEE STATUS IF A = 0
          SPACE  2
 IPDE50   BSS
          LDN    1
 IPDEX    LJM    **
 IPDE     EQU    *-1
          LDM    /SS/P.DT,CSST
          SHN    -4
          STDL   DT          DEVICE TYPE
          SBN    3
          ZJN    IPDE10      IF 5833_1P
          SBN    5
          ZJN    IPDE10      IF 5838_1P
          SBN    2
          ZJN    IPDE10      IF 5838_3P
          SBN    3
          ZJN    IPDE10      IF 47444_1P
          SBN    2
          ZJN    IPDE10      IF 47444_3P
          ADN    10
          NJK    IPDEX       IF NOT 5833_3P
 IPDE10   BSS
          LDML   FPD
          SHN    10
          MJN    IPDEX       IF NO FAILING DRIVE
          LDN    0
          STDL   T1
 IPDE15   BSS
          LDML   RPB,T1      SAVE RESPONSE BUFFER
          STML   IPIT,T1
          AODL   T1
          SBN    50
          NJN    IPDE15      IF MORE WORDS TO SAVE
          RJM    LIR         LOGICAL INTERFACE RESET
          LDC    0#302       REPORT ADDRESSEE STATUS OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDN    6           COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          LDML   RPB+9
          STDL   T2
          LDN    0
          STDL   T1
 IPDE20   BSS
          LDML   IPIT,T1     RESTORE RESPONSE BUFFER
          STML   RPB,T1
          AODL   T1
          SBN    50
          NJN    IPDE20      IF MORE WORDS TO RESTORE
          LDDL   T2
          SHN    3
          PJK    IPDE50      IF LOGICAL UNIT IS NOT READ READY
          SHN    1
          PJK    IPDE50      IF NO PARITY DRIVE
          SHN    4
          PJN    IPDE30      IF NO OFF LINED DRIVE
          SHN    1
          PJK    IPDE50      IF RESTORE NOT IN PROGRESS
 IPDE30   BSS
          LDN    0
          UJK    IPDEX
          SPACE  5,20
** NAME-- IRD
*
** PURPOSE-- ISSUE RESTORE DRIVE
          SPACE  2
 IRDX     LJM    **
 IRD      EQU    *-1
          LDM    /SS/P.DT,CSST
          SHN    -4
          STDL   DT          DEVICE TYPE
          LDML   UNITS,UX    INDICATE ONE COMMAND IN PROGRESS
          LMC    0#8000
          STML   UNITS,UX
          AODL   CMNDS       COMMANDS ISSUED TO CONTROLLER
          LDN    0#18
          STML   CP          COMMAND PACKET LENGTH
          LDDL   UX
          STML   CP+CRN      COMMAND REFERENCE NUMBER
          LDC    H0931
          STML   CP+FCP      COMMAND EXTENT PARAMETER
          LDC    0#E005      RESTORE DRIVE OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDC    0#2D5
          STML   CP+FCP+5    SELECT PHYSICAL DRIVE PARAMETER
          LDML   ODN,CSST
          SHN    8
          STML   CP+FCP+6    DRIVE NUMBER TO RESTORE
          LDC    0#2E3
          STML   CP+FCP+7    RESTORE OPTION PARAMETER
          LDML   /SS/P.CRTS,CSST
          LPN    77B
          STML   /SS/P.CURSEC,CSST
          LDML   /SS/P.CRTS,CSST
          SHN    -8
          STML   /SS/P.CURTRK,CSST
          RJM    CSC         COMPUTE SECTOR COUNT TO TRANSFER
          STML   CP+FCP+2    SECTORS TO RESTORE
          LDML   CRC,CSST
          STML   CP+FCP+3    CYLINDER TO RESTORE
          LMML   CTC,DT      LAST CYLINDER
          NJN    IRD20       IF NOT LAST CYLINDER
          LDC    0#901       NO OP PARAMETER
          STML   CP+FCP
          LDC    0#100       ON LINE DRIVE
          UJN    IRD30
 IRD20    BSS
          LDC    0#200       RESTORE DRIVE
 IRD30    BSS
          STML   CP+FCP+8
          RJM    CPT         COMMAND PACKET TRANSFER
          LJM    IRDX
          SPACE  5,20
** NAME--ISR
*
** PURPOSE-- ISSUE SLAVE RESET
          SPACE  2
 ISR      CON    0
          LDC    H8415       SLAVE RESET
          STML   CP+OPCD     SO TIMEOUT WILL BE LONG IN IH
          RJM    IR          ISSUE RESET
          LDML   /SS/P.CT,CSST
          ZJN    ISR10       IF IN SUBSYSTEM CONFIDENCE TEST
          LJM    MAIN15
 ISR10    BSS
          RJM    IH          INTERRUPT HANDLER
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    EP          ERROR PROCESSING (NO RETRUN)
          SPACE  5,20
** NAME-- IU
*
** PURPOSE-- INITIALIZE UNIT.  DECLUSTER UNIT IF CLUSTERED, FORMAT
*            ALL THE PHYSICAL UNITS OF THE LOGICAL UNIT AS NECESSARY,
*            THEN CLUSTER THE UNIT.
          SPACE  2
 IUX      LJM    **
 IU       EQU    *-1
          LDML   /SS/P.UNIT,CSST
          LPN    77B
          STDL   PD          PHYSICAL DRIVE
 IU10     BSS
          RJM    DDT         DETERMINE DRIVE TYPE
          MJN    IU30        IF DRIVE NOT IN CONTROLLER TABLE
          LDML   RPB+8+2,T3
          SHN    8
          PJN    IU20        IF UNIT NOT CLUSTERED
          RJM    DU          DECLUSTER UNIT
 IU20     BSS
          LOADF  CMLIST+/CM/P.RMA,CSST  ADDRESS OF LIST WITH FORMAT PARAMETER
          CRDL   P1          READ WORD WITH PARAMETER
          LDDL   P3
          SBN    1
          ZJN    IU30        IF UNCONDITIONAL FORMAT
          RJM    DDT         DETERMINE DRIVE TYPE
          RJM    IUF         IS UNIT FORMATTED
          ZJN    IU40        IF UNIT FORMATTED
 IU30     BSS
          LDN    0           TO INDICATE DRIVE DECLUSTERED
          RJM    FU          FORMAT UNIT
 IU40     BSS
          RJM    UPD         UPDATE DRIVE NUMBER
          NJN    IU10        IF MORE DRIVES TO CHECK
          RJM    CU          CLUSTER UNIT
          UJK    IUX
          SPACE  5,20
** NAME-- IUF
*
** PURPOSE-- IS UNIT FORMATTED
*
** EXIT   A = 0 IF DRIVE FORMATTED WITH CORRECT SECTOR SIZE
*           = 141 IF NOT CORRECTLY FORMATTED
          SPACE  2
 IUFX     LJM    **
 IUF      EQU    *-1
          LDML   RPB+8+2,T3  PARAMETER 68 BYTE 3
          SHN    8
          PJN    IUF2        IF UNIT NOT CLUSTERED
          LDML   /SS/P.UNIT,CSST
          UJN    IUF3
 IUF2     BSS
          LDDL   CMOD
          SHN    8
          ADDL   PD
 IUF3     BSS
          STML   CP+SLAD     CONTROLLER, DRIVE ADDRESS
          LDC    0#302
          STML   CP+OPCD     REPORT ADDRESSEE STATUS OPERATION CODE
          LDN    6           COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          LDML   RPB+9
          SHN    3
          PJN    IUF10       IF NOT FORMATTED
          LDML   RS+/RS/P.ADT
          STDL   T1          ACTUAL DRIVE TYPE
          SBN    DTS
          MJN    IUF5        IF RS+/RS/P.ADT CONTAINS DRIVE TYPE
          LDDL   DT
          STDL   T1          EXPECTED DRIVE TYPE
 IUF5     BSS
          LDML   RPB+9
          SHN    2
          MJN    IUF7        IF CLUSTERED
 IUF6     BSS
          LDML   RPB+7
          UJN    IUF8
 IUF7     BSS
          SHN    2
          PJN    IUF6        IF NO PARITY DRIVE
          LDML   RPB+7
          SBN    1
 IUF8     BSS
          LPN    77B         MASK ACTUAL DATA DRIVES FOR FORMAT
          LMML   DD,T1       EXPECTED DATA DRIVES
          NJN    IUF10       IF WRONG NUMBER OF DATA DRIVES
          LDML   RPB+11      ACTUAL SECTOR SIZE
          LMML   BPS,T1      EXPECTED SECTOR SIZE
          ZJK    IUFX        IF CORRECT SECTOR SIZE
 IUF10    BSS
          LDC    E141        INDICATE NOT FORMATTED
          UJK    IUFX
          SPACE  5,20
** NAME-- LA6E
*
** PURPOSE-- LOAD ATTRIBUTE PARAMETER 6E.  DISABLING UNANTICIPATED PAUSES
*            DISABLES CORRECTION OF READ ERRORS WITH A PARITY DRIVE.
          SPACE  2
 LA6EX    LJM    **
 LA6E     EQU    *-1
          LDC    0#46E
          STML   CP+FCP      PARAMETER 6E
          LDC    H0209
          RJM    SOU         SET OPERATION CODE AND UNIT
*         LDML   UNITS,UX
          SHN    /UN/L.PDCE+2
          PJN    LA6E10      IF PARITY DRIVE CORRECTION DISABLED
          LDC    0#C080      ALLOW PARITY DRIVE CORRECTION
          UJN    LA6E20
 LA6E10   BSS
          LDC    0#C0A0      DISABLE UNANTICIPATED PAUSES
 LA6E20   BSS
          STML   CP+FCP+1    MODE FOR DATA
          LDN    0
          STML   CP+FCP+2
          LDN    12          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          UJK    LA6EX
          SPACE  5,20
** NAME-- LIR
*
** PURPOSE-- LOGICAL INTERFACE RESET
          SPACE  2
 LIRX     LJM    **
 LIR      EQU    *-1
          LDN    0
          STML   CP+OPCD     SO TIMEOUT WILL BE SHORT IN IH
          LDC    H8215       LOGICAL INTERFACE RESET
          RJM    IR          ISSUE RESET
          RJM    IH          INTERRUPT HANDLER
          SHN    -4
          LPN    0#F
          LMN    AR
          NJN    LIR20       IF NOT ASYNCHRONOUS RESPONSE
          LDN    ID16
          RJM    SFP         CHECK FOR MACHINE EXCEPTION
          MJN    LIR20       IF MACHINE EXCEPTION ID NOT FOUND
          LDML   RPB+6,T3
          LPC    0#FEE0
          LMC    0#6000
          NJN    LIR20       IF ERROR
          UJK    LIRX
 LIR20    BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- LOCK
*
** PURPOSE-- SET THE LOCKWORD
*
** ENTRY
*         T7 = POINTER RMA
*         T5 = OFFSET TO LOCKWORD FROM RMA
*
** EXIT
*         A = 0 IF LOCK SUCCESSFULLY SET
          SPACE  2
 LOCKX    LJM    **
 LOCK     EQU    *-1
 LOCK10   BSS
          LCN    0
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE
          LDDL   T1
          ZJN    LOCK30      IF LOCK COULD BE SET
          ADDL   T2
          ADC    -177777B-177777B
          ZJK    LOCK10      IF INTERMEDIATE VALUE
          LDDL   T2
          LPC    77777B
          ADC    100000B
          STDL   T2          SET THE VE BIT
          LDDL   T6
          CWDL   T1          RESTORE THE LOCKWORD WITH THE VE BIT
          LDDL   T4
          SBDL   LPN         CHECK IF LOCK ALREADY SET
          NJN    LOCK20      IF LOCK COULD NOT BE SET, EXIT A .NE. 0
          LDDL   T1
          ADC    -100000B
 LOCK20   UJK    LOCKX       IF LOCK WAS ALREADY SET, EXIT A = 0
                             IF LOCK COULD NOT BE SET, EXIT A .NE. 0
 LOCK30   BSS
          LDC    100000B
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          LDDL   LPN
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          CWDL   T1          SET THE LOCKWORD
          LDN    0
          UJK    LOCKX
          SPACE  5,20
** NAME-- LUT
*
** PURPOSE-- LOCK UNIT TABLE
*
** EXIT   A = 0 IF UNIT LOCKED TO THIS PP
          SPACE  2
 LUT10    BSS
          LDDL   T4
          SBDL   LPN
 LUTX     LJM    **
 LUT      EQU    *-1
          LDC    0#8000
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          STDL   T4
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.ULOCK  INDEX TO LOCKWORD
          STDL   T6
          RDSL   T1          ATTEMPT TO LOCK UNIT
          LDDL   T1
          NJN    LUT10       IF ALREADY LOCKED
          LDC    0#8000
          STDL   T1
          LDDL   LPN
          STDL   T4          LOGICAL PP NUMBER
          LDDL   T6
          CWDL   T1          WRITE THE LOCKWORD
          LDN    0
          UJK    LUTX
          SPACE  5,20
** NAME-- ODFP
*
** PURPOSE-- OUTPUT DATA FROM PP
*
** ENTRY  A = COMMAND PACKET LENGTH
          SPACE  2
 ODFPX    BSS
          RJM    VRP         VERIFY RESPONSE PACKET
          LJM    **
 ODFP     EQU    *-1
          STML   CP          COMMAND PACKET LENGTH
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LPN    0#A
          NJN    ODFPX       IF COMMAND SUCCESSFUL
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- OFD
*
** PURPOSE-- OFF LINE FAILING DRIVE
          SPACE  2
 OFDX     LJM    **
 OFD      EQU    *-1
          LDC    H0209
          STML   CP+OPCD     LOAD ATTRIBUTE OPERATION CODE
          LDC    0#2D5
          STML   CP+FCP      PARAMETER WITH FAILING DRIVE NUMBER
          LDML   RS+/RS/P.UNIT
          LPN    37B
          SHN    8
          STML   CP+FCP+1    FAILING DRIVE NUMBER
          LDC    0#1D9
          STML   CP+FCP+2    PARAMETER TO OFF LINE DRIVE
          LDN    12          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          UJN    OFDX
          SPACE  5,20
** NAME-- OFFCH
*
** PURPOSE-- TURN OFF ALL UNITS ON A CHANNEL
          SPACE  2
 OFCX     LJM    **
 OFFCH    EQU    *-1
          LDN    0
          STDL   UX          UNITS TABLE INDEX
 OFC10    BSS
          RJM    OFFUN       SET UNIT DISABLE FLAG
          LDN    P.UN
          RADL   UX          BUMP UNITS TABLE INDEX
          SBDL   UNUML
          NJK    OFC10       IF NOT END OF TABLE
          UJK    OFCX
          SPACE  5,20
** NAME-- OFFCM
*
** PURPOSE-- TURN OFF ALL UNITS ON A CONTROLLER.
          SPACE  2
 OFFCM    CON    0
          LDK    /RS/K.CMDN  CONTROLLER DOWN
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          LDDL   UX
          STDL   P5          POINTER TO CURRENT UNITS TABLE
          LDN    0
          STDL   UX          UNITS TABLE INDEX
 OFFCM10  BSS
          LDML   UNITS,P5    COMPARE IF SAME CONTROLLER
          LMML   UNITS,UX
          LPC    340B
          NJN    OFFCM20     IF NOT THE SAME CONTROLLER
          RJM    OFFUN       SET UNIT DISBLE FLAG
 OFFCM20  BSS
          LDN    P.UN
          RADL   UX          BUMP UNITS TABLE INDEX
          SBDL   UNUML
          NJK    OFFCM10     IF NOT END OF TABLE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          LJM    MAIN10
          SPACE  5,20
** NAME-- OFFUN
*
** PURPOSE-- SET THE DISABLE FLAG IN THE UNIT INTERFACE TABLE.
*
** EXIT   P5 IS UNCHANGED
          SPACE  2
 OFUX     LJM    **
 OFFUN    EQU    *-1
 OFFUN10  BSS
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    OFFUN10     IF LOCK COULD NOT BE SET
          LDK    /UIT/K.DSABLE  SET UNIT DISABLE FLAG
          STDL   T3
          LDN    0
          STDL   T2
          STDL   T4
          STDL   T5
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          RDSL   T2          -LOGICAL OR- THE UNIT DISABLE FLAG
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD

*         NOTE THAT REQUEST RETRIES DO NOT ALLOW STREAMING SO SFRR WILL
*         NOT SEND A RESPONSE.

          RJM    SFRR        SETUP FOR REQUEST RETRY (MAKE CMNDS ACCURATE)
          LPC    0#F7FF
          STML   UNITS,UX    CLEAR RESTORE IN PROGRESS FLAG
          UJK    OFUX
          SPACE  5,20
** NAME-- PCER
*
** PURPOSE-- PREPARE COMMON ERROR RESPONSE
*
** ENTRY  A = ERROR ID
          SPACE  2
 PCERX    LJM    **
 PCER     EQU    *-1
          STDL   P2
          SBN    E20
          ZJN    PCER10      IF ERROR CODE 20
          SBN    E22-E20
          MJN    PCER20      IF ERROR CODE 0-19, 21
          SBN    E23-E22
          MJN    PCER10      IF ERROR CODE 22
          SBN    E27-E23
          MJN    PCER20      IF ERROR CODE 23-26
          SBN    E29-E27
          MJN    PCER10      IF EC 27 OR 28
          ZJN    PCER20      IF EC 29
          SBN    E30-E29
          NJN    PCER20      IF ERROR CODE 31-XX
 PCER10   BSS
          LDC    H00E1       READ STATUS REGISTER
          RJM    RDRG        READ REGISTER
          STDL   STATUS      SAVE CONTENTS OF STATUS REGISTER
 PCER20   BSS
          LDML   /SS/P.XFER,CSST BYTES TRANSFERRED
          STML   RS+/RS/P.XFER
          LDML   /SS/P.XFER+1,CSST
          STML   RS+/RS/P.XFER+1
          LDML   /SS/P.LU,CSST  PUT LOGICAL UNIT IN RESPONSE
          STML   RS+/RS/P.LU
          RJM    PDR         PREPARE NORMAL DISK RESPONSE
          LDDL   P2
          NJN    PCER50      IF ERROR ALREADY ISOLATED
          LDN    ID14
          RJM    SFP         SEARCH FOR ID 14
          MJN    PCER30      IF NOT CONTROLLER INTERVENTION REQUIRED
          LDK    E71
          UJN    PCER50
 PCER30   BSS
          LDN    ID16
          RJM    SFP         SEARCH FOR ID 16
          MJN    PCER40      IF NOT CONTROLLER MACHINE EXCEPTION
          LDML   RPB+6,T3
          SHN    8
          PJN    PCER31      IF NOT CONTROLLER OVER TEMPERATURE
          LDK    E78
          UJN    PCER50
 PCER31   BSS
          LDK    E72
          UJN    PCER50
 PCER40   BSS
          LDN    ID17
          RJM    SFP         SEARCH FOR ID 17
          MJN    PCER70      IF NOT CONTROLLER COMMAND EXCEPTION
          LDK    E73         COMMAND EXCEPTION
 PCER50   BSS
          UJN    PCER100
 PCER70   BSS
          LDN    ID13
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    PCER90      IF NOT ID13
          LDK    E74         MICROCODE EXECUTION ERROR
          UJN    PCER100
 PCER90   BSS
          LDN    ID15
          RJM    SFP         SEARCH FOR ID 15
          MJN    PCER110     IF NOT ALTERNATE PORT EXCEPTION
          LDK    E75
 PCER100  BSS
          UJN    PCER160
 PCER110  BSS
          LDN    ID12
          RJM    SFP         SEARCH FOR PARAMETER
          PJN    PCER120     IF ID12 FOUND
          LDK    ID22
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    PCER130     IF NOT ID22
 PCER120  BSS
          LDK    E130        DEFECT MANAGEMENT TASK FAILED
          UJN    PCER160
 PCER130  BSS
          LDK    ID23
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    PCER140     IF NOT ID23
          LDML   RPB+6,T3    FIRST WORD AFTER ID23
          SHN    5
          PJN    PCER150     IF NOT MESSAGE FROM DRIVE DIAGNOSTICS
          LDK    E61         DRIVE ERROR
          UJN    PCER160
 PCER140  BSS
          LDK    ID25
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    PCER150     IF NOT ID25
          LDK    E54         DRIVE ALTERNATE PORT ERROR
          UJN    PCER160
 PCER150  BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
 PCER160  BSS
          STML   RS+/RS/P.ERRID
          LDDL   WC          WORDS NOT TRANSFERRED
          STML   RS+/RS/P.WC
          LDDL   LF
          STML   RS+/RS/P.FUNTO  FAILING FUNCTION IF E01
          LDDL   STATUS      STATUS REGISTER
          STML   RS+/RS/P.STREG
          LDC    H00F1
          RJM    RDRG        READ ERROR REGISTER
          STML   RS+/RS/P.ERREG  SAVE ERROR REGISTER
          LDML   /SS/P.MREV,CSST  CONTROLLER MICROCODE PART NUMBER
          STML   RS+/RS/P.MREVU
          LDML   /SS/P.MREV+1,CSST
          STML   RS+/RS/P.MREVL
          LDML   /SS/P.RQTRY,CSST
          STML   RS+/RS/P.RTRY  REQUEST RETRY COUNT
          RJM    SDA         SAVE DISK ADDRESS
          LDDL   CHAN
          STML   RS+/RS/P.CHAN  CHANNEL NUMBER
          RJM    SPA         SAVE PHYSICAL ADDRESS
          LDN    0
          STML   RS+/RS/P.ID
 .F       IFEQ   FE,1
          LDML   SRRC
          STML   RS+/RS/P.FILL1  NO DATA TRANSFERRED ERROR COUNT
 .F       ENDIF
          UJK    PCERX
          SPACE  5,20
** NAME-- PDD
*
** PURPOSE-- PERFORM DRIVE DIAGNOSTICS
          SPACE  2
 PDDX     LJM    **
 PDD      EQU    *-1
          LDC    H8100       PERFORM DRIVE DIAGNOSTIC OP CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDC    0#2D5
          STML   CP+FCP      PARAMETER TO SELECT DRIVE
          LDML   RS+/RS/P.UNIT
          LPN    37B
          SHN    8
          STML   CP+FCP+1    PHYSICAL DRIVE NUMBER
          LDN    10          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          UJN    PDDX
          SPACE  5,20
** NAME-- PDR
*
** PURPOSE-- PREPARE NORMAL DISK RESPONSE
          SPACE  2
 PDRX     LJM    **
 PDR      EQU    *-1
          LDML   /SS/P.FPVA,CSST  PVA OF REQUEST
          STML   RS+/RS/P.PVA
          LDML   /SS/P.FPVA+1,CSST
          STML   RS+/RS/P.PVA+1
          LDML   /SS/P.FPVA+2,CSST
          STML   RS+/RS/P.PVA+2
          LDN    8
          STML   RS+/RS/P.RESPL  NORMAL RESPONSE LENGTH
          LDN    0
          STML   RS+/RS/P.DATERR  ABNORMAL STATUS WORD
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE WORD
          LDML   /SS/P.LU,CSST
          LPC    0#FF        RIGHT-MOST 8 BITS OF LOGICAL UNIT
          LMC    /RS/K.SHORT  INDICATE ONE-WORD RESPONSE
          STML   RS+/RS/P.SHORT
          UJK    PDRX
          SPACE  5,20
** NAME-- PFMT
*
** PURPOSE-- PROCESS FORMAT PARAMETER.
          SPACE  2
 PFMTX    LJM    **
 PFMT     EQU    *-1
          LOADF  CMLIST+/CM/P.RMA,CSST  ADDRESS OF LIST WITH FORMAT PARAMETER
          CRDL   P1          READ WORD WITH PARAMETER
          LDDL   P3
          SBN    2
          PJK    PFMT10      IF SET/CLEAR FORCE, HS DETECT, OR RUN CT
          UJK    PFMT27
 PFMT10   NJN    PFMT20      IF NOT CLEAR FORCE FORMAT BIT
          RJM    CFFMT       CLEAR FORCE FORMAT BIT
          UJN    PFMT35
 PFMT20   SBN    1
          NJN    PFMT25      IF NOT SET FORCE FORMAT BIT
          RJM    SFFMT       SET FORCE FORMAT BIT
          UJN    PFMT35
 PFMT25   SBN    1
          NJN    PFMT30      IF RUN CT TO ENABLE RESTORE
          LDN    1
          STML   HSTF        SET FLAG TO RUN HEAD SHIFT TEST
 PFMT27   LDN    0
          STML   /SS/P.CT,CSST  ENABLE RUNNING CONFIDENCE TEST
          UJK    PFMTX       EXIT
 PFMT30   LDN    40B
          STML   /SS/P.CT,CSST  FORCE CONFIDENCE TEST TO BE RUN
          LDM    /SS/P.DOAR,CSST
          LMC    0#8000      INDICATE OPERATIONAL ASYNCH RECEIVED
          STML   /SS/P.DOAR,CSST
 PFMT35   RJM    PDR         PREPARE NORMAL DISK RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          AODL   CMNDS       DCR WILL DECREMENT CMNDS
          RJM    DCR         DELINK COMPLETED REQUEST
          RJM    RESPIN      UPDATE -IN- POINTER FOR RESPONSE BUFFER
          RJM    UUT         UNLOCK UNIT TABLE
          LDN    1           FORCE EXIT FROM -GETU-
          UJK    PFMTX
          SPACE  5,20
** NAME-- PER
*
** PURPOSE-- PREPARE ERROR RESPONSE
*
** ENTRY  (A) = ERROR CODE
          SPACE  2
 PERX     LJM    **
 PER      EQU    *-1
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDML   UNITS,UX
          LPC    740B
          ADDL   PD
          STML   RS+/RS/P.UNIT  PORT, CONTROLLER, DRIVE ADDRESS
          UJN    PERX
          SPACE  5,20
** NAME-- PI
*
** PURPOSE-- PROCESS INTERRUPT
          SPACE  2
 PI       CON    0
          LDML   /SS/P.RESET,CSST
          ZJN    PI3         IF RESET NOT ISSUED
          LDML   EPCT,CMOD
          STDL   UX          CORRECT UX FOR RESET
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE
          RJM    DTM         DETERMINE TRANSFER MODE
 PI3      BSS
          RJM    SEL         SELECT CONTROLLER
          STDL   CTM         CLEAR CHANGE TRANSFER MODE FLAG
 PI10     BSS
          RJM    RPT         RESPONSE PACKET TRANSFER
          LDML   RPB+MAJST   MAJOR STATUS
          STDL   T6
          SHN    -4
          LPN    0#F
          SBN    CC
          NJK    PI40        IF NOT STANDARD COMMAND COMPLETION
          RJM    DCM         DESELECT THE CONTROLLER
          RJM    STI         SET TABLE INDEXES
          LDDL   T6
          LPN    0#A
          ZJK    PI100       IF NOT SUCCESSFUL OR NOT CONDITIONAL SUCCESS
          LPN    2
 PI12     ZJK    PI20        IF SUCCESSFUL
          LDN    ID29
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    PI14        IF ID29 NOT FOUND
          LDML   RPB+5,T3
          SHN    -8
          SBN    11
 PI14     MJK    PI20        IF BYTE CONTAINING CORRECTION BITS NOT PRESENT
          LDML   RPB+8,T3
          LPC    0#C0
          ZJN    PI12        IF NOT PARITY DRIVE CORRECTION
          LDML   RPB+OPCD
          SHN    -8
          SBN    0#10
          ZJN    PI16        IF READ
          SBN    0#10
          NJN    PI20        IF NOT WRITE
 PI16     BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDN    0
          STML   RS+/RS/P.SHORT  INDICATE ERROR RESPONSE
          LDC    RLIE
          STML   RS+/RS/P.RESPL  BYTE LENGTH OF RESPONSE
          LDC    0#8000
          STML   RS+/RS/P.RC  NORMAL RESPONSE
          LDN    E62         MEDIA ERROR
          STML   RS+/RS/P.ERRID
          LDML   /SS/P.RQTRY,CSST
          ZJN    PI19        MICROCODE ERROR, DO NOT FLAW
          LDK    /RS/K.DATERR  SOFTWARE FLAW THE ALLOCATION UNIT
          STML   RS+/RS/P.DATERR
 PI19     LJM    TERM6       GO SEND RESPONSE AND DELINK THE REQUEST
 PI20     BSS
          RJM    TERM        COMMAND COMPLETED WITHOUT ERROR (NO RETURN)
 PI40     BSS
          SBN    TN-CC
          NJN    PI60        IF NOT TRANSFER NOTIFICATION
          RJM    STI         SET TABLE INDEXES
          RJM    RDWT        READ WRITE SETUP
          NJN    PI45        IF EXPECTED RESPONSE
          AODL   TBC         INDICATE COMPLETION RESPONSE SHOULD BE PRESENT
          LJM    PI10
 PI45     BSS
          LDML   /SS/P.FNC,CSST
          ZJN    PI50        IF READ
          RJM    WRITE       IF WRITE (RETURN IS TO IDLE LOOP)
 PI50     BSS
          RJM    READ        READ (RETURN IS TO IDLE LOOP)
 PI60     BSS
          RJM    DCM         DESELECT THE CONTROLLER
          LDML   RPB+SLAD
          LPC    0#FF
          LMC    0#FF
          ZJK    PI100       IF ASYNCH FOR CONTROLLER
          LDML   RPB+OPCD
          SHN    -8
          SBN    0#10
          ZJN    PI65        IF READ
          SBN    0#10
          NJN    PI70        IF NOT WRITE
 PI65     BSS
          RJM    STI         SET TABLE INDEXES
          LDDL   T6
          SHN    CS
          PJN    PI100       IF NOT CONDITIONAL SUCCESS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDN    0
          STML   RS+/RS/P.SHORT  INDICATE ERROR RESPONSE
          LDC    RLIE
          STML   RS+/RS/P.RESPL  BYTE LENGTH OF RESPONSE
          LDC    0#5000
          STML   RS+/RS/P.RC  RECOVERED, INTERMEDIATE RESPONSE
          RJM    TERMP       SEND RESPONSE TO CM
          UJN    PI75
 PI70     BSS
          RJM    DARH        DRIVE ASYNCHRONOUS RESPONSE HANDLER
 PI75     BSS                MUST BE TAG FOR FIRST LOCATION AFTER RJM DARH
          LJM    MAIN15
 PI100    BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- PPRQ
*
** PURPOSE-- CHECK FOR ANY PP REQUESTS ON THE PP QUEUE.
          SPACE  2
 PPRQX    LJM    **
 PPRQ     EQU    *-1
          LCN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDC    0#7FFF
          STDL   T4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          RDCL   T1          CLEAR ACTIVE CHECK BIT, READ PPIT WORD 1
          LDDL   T4
          SHN    /PIT/L.IDLREQ+2
          MJN    PPRQ10      IF IDLE REQUEST
          SHN    /PIT/L.RESREQ-/PIT/L.IDLREQ
          PJN    PPRQX       IF NOT RESUME OR IDLE REQUEST
          RJM    SPLOCK      SET PP TABLE LOCK
          LDDL   T4
          LPC    0#4FFE      CLEAR ACTIVE CHECK BIT, RESUME REQUEST BIT,
          STDL   T4           IDLE STATUS BIT, AND LOCK BIT IN PP
          LDDL   CM.PIT+1     INTERFACE TABLE
          CWDL   T1
          LJM    MAIN5
 PPRQ10   BSS
          AOML   IDLE        NUMBER OF TIMES DRIVER IDLED
          RJM    SPLOCK      SET PP TABLE LOCK
          RJM    RAR         RESTART ALL REQUESTS SET UP
          RJM    DLN         DELETE LOGICAL PP NUMBER FROM LOCKWORD
          LDDL   CLF
          NJN    PPRQ15      IF 2 CONSECUTIVE IDLES AND CHANNEL LOCK
                              ALREADY CLEAR
          RJM    CCLOCK      CLEAR CHANNEL LOCK
 PPRQ15   BSS
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          CRDL   T1
          LDDL   T4          CLEAR ACTIVE CHECK BIT, IDLE REQUEST BIT,
          LPC    0#2FFE       AND SET IDLE STATUS BIT
          LMC    0#1000
          STDL   T4
          LDDL   CM.PIT+1
          CWDL   T1
 PPRQ20   BSS
          RJM    PPRQ        WAIT FOR RESUME
          UJN    PPRQ20
          SPACE  5,20
** NAME-- PT
*
** PURPOSE-- TEST THE PATH BETWEEN THE PP AND THE CONTROLLER.
*            IF A PATH TO A CONTROLLER STILL FAILS AFTER AT LEAST
*            ONE RETRY WITH SLAVE RESET, ALL UNITS ON THE FAILING
*            CONTROLLER WILL BE DISABLED.
*
** ENTRY
*         1)  AT INITIALIZATION AFTER PP LOADED
*         2)  AFTER THE PP HAS RECEIVED A RESUME
*         3)  DURING REQUEST RETRY IF SLAVE RESET FAILS
          SPACE  2
 PT100    BSS
          AODL   PTF         INDICATE PATH TEST COMPLETE
 PTX      LJM    **
 PT       EQU    *-1
          LDDL   UNUML
          ZJN    PT100       IF NO UNITS
          RJM    SCLOCK      SET CHANNEL LOCK
          LDDL   PTF
          NJN    PTX         IF NOT EXECUTING PATH TEST
          STDL   CMOD        CONTROLLER NUMBER
          STDL   UX
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE
          RJM    MR          MASTER RESET
          UJN    PT20
 PT8      BSS
          AODL   CMOD
          UJN    PT20
 PT16     BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
          SBDL   UNUML
          PJN    PT100       IF END OF CONFIGURED UNITS
 PT20     BSS
          LDML   UNITS,UX
          SHN    -/UN/N.UNIT
          LPN    7
          SBDL   CMOD
          MJN    PT16        IF THIS CONTROLLER ALREADY TESTED
          NJN    PT8         IF CMOD TOO SMALL
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T1          READ UNIT DISABLED FLAG
          LDDL   T1+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJN    PT16        IF UNIT DISABLED
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE
          RJM    CCA         CHECK CONTROLLER ATTRIBUTES

*         WRITE BUFFER

          LDN    12
          STML   CP          COMMAND PACKET LENGTH
          LDC    H6200
          STML   CP+OPCD     WRITE TO BUFFER COMMAND
          LDC    0#531
          STML   CP+FCP      COMMAND EXTENT PARAMETER
          LDN    0
          STML   CP+FCP+1    UPPER WORD OF BYTE COUNT
          LDC    100
          STML   CP+FCP+2    BYTE LENGTH
          RJM    CPT         COMMAND PACKET TRANSFER
 PT40     EQU    *-1         FOR FORCING ERRORS
          RJM    BPTB        BUILD PATH TEST BUFFER
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    PT90        IF NOT TRANSFER NOTIFICATION
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAOUT     DATA, TRANSFER OUT
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0381       STREAM, WRITE FROM PP
          RJM    FUNC        RAISE MASTER OUT
          ACN    DC
          LDN    50          WORD COUNT
          OAM    OB,DC       OUTPUT DATA
          STDL   WC          WORDS NOT TRANSFERRED
          LDC    MS50
 PT50     BSS
          IJM    PT55,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    PT50        IF TIMEOUT NOT EXPIRED
          LDN    E30         CHANNEL STAYED ACTIVE
          UJK    PT94
 PT55     BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT THE CONTROLLER
          LDDL   WC
          NJK    PT80        IF INCOMPLETE TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          NJK    PT90        IF NOT SUCCESSFUL

*         READ BUFFER

          LDC    H5200
          STML   CP+OPCD     READ FROM CONTROLLER BUFFER
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    PT90        IF NOT TRANSFER NOTIFICATION
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAIN      DATA TRANSFER IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0281       STREAM, READ TO PP MEMORY
          RJM    FUNC        RAISE MASTER OUT
          ACN    DC
          LDN    50          WORD COUNT
          IAM    IB,DC
          STDL   WC          WORDS NOT TRANSFERRED
          LDC    MS50
 PT60     BSS
          IJM    PT65,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    PT60        IF TIMEOUT NOT EXPIRED
          RJM    CSI         CHECK SLAVE IN
 PT65     BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT THE CONTROLLER
          LDDL   WC
          NJN    PT80        IF NOT ALL WORDS TRANSFERRED
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          NJN    PT90        IF NOT SUCCESSFUL
          RJM    VPTD        VERIFY PATH TEST DATA
          LDML   /SS/P.RECOV,CSST
          LMN    3
          ZJN    PT70        IF PATH TEST PART OF RECOVERY FOR I/O REQUEST
          LDN    0
          STML   /SS/P.RQTRY,CSST  CLEAR REQUEST RETRY COUNTER
 PT70     BSS
          LJM    PT8
 PT80     BSS
          LDN    E29         INCOMPLETE TRANSFER
          UJN    PT94
 PT90     BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
 PT94     BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- RAR
*
** PURPOSE-- RESTART ALL REQUESTS
          SPACE  2
 RARX     BSS
          STDL   CMNDS       NO OUTSTANDING COMMANDS
          LJM    **
 RAR      EQU    *-1
          PAUSE  100000      ALLOW CONTROLLER TIME TO WRITE DATA IN
          LDN    0            ITS BUFFER TO DISK
          STDL   UX          POINTER TO UNITS TABLE
          UJN    RAR20
 RAR10    BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
 RAR20    BSS
          SBDL   UNUML
          ZJN    RARX        IF END OF CONFIGURED UNITS
          RJM    SFRR        SET UP FOR REQUEST RETRY
          UJN    RAR10
          SPACE  5,20
** NAME-- RAS
*
** PURPOSE-- REPORT ADDRESSEE STATUS
*
** EXIT   (A) = RPB+9
          SPACE  2
 RASX     LJM    **
 RAS      EQU    *-1
          LDC    0#302       REPORT ADDRESSEE STATUS OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDN    6           COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          LDML   RPB+9
          UJN    RASX
          SPACE  5,20
** NAME-- RCC
*
** PURPOSE-- RESTART CONTROLLER COMMANDS.  SET UP TABLES SO THAT
*            ROUTINE GETUD WILL RESTART ALL CONTROLLER COMMANDS.
          SPACE  2
 RCCX     BSS
          LDML   T12
          STDL   UX          RESTORE UNITS TABLE POINTER
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE
          LJM    **
 RCC      EQU    *-1
          LDDL   UX
          STML   T12         SAVE POINTER TO UNITS TABLE
          LDN    0
          STDL   UX          POINTER TO UNITS TABLE
          UJN    RCC20
 RCC10    BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
 RCC20    BSS
          SBDL   UNUML
          PJN    RCCX        IF END OF CONFIGURED UNITS
          LDML   UNITS,UX
          SHN    2+/UN/L.CIP
          PJN    RCC10       IF NO COMMAND IN PROGRESS
          SHN    -7
          LPN    7
          LMDL   CMOD
          NJN    RCC10       IF DIFFERENT CONTROLLER
          RJM    SFRR        SETUP FOR REQUEST RETRY
          UJK    RCC10
          SPACE  5,20
** NAME-- RDWT
*
** PURPOSE-- SET UP FOR READ OR WRITE.
*
** EXIT
*         A = 0  IF COMPLETION RESPONSE SHOULD BE PRESENT.  IT IS
*                POSSIBLE FOR A TRANSFER NOTIFICATION RESPONSE FOR THE
*                STACKED COMMAND TO BE PRESENT BEFORE OR AT THE SAME
*                TIME AS THE COMPLETION RESPONSE FOR THE COMMAND IN PROGRESS.
          SPACE  2
 RDWX     LJM    **
 RDWT     EQU    *-1
          LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          PJN    RDWT10      IF NOT 2 COMMANDS IN PROGRESS
          LDML   RPB+CRN
          SHN    -14
          LMML   /SS/P.CRN,CSST
          LPN    1
          ZJN    RDWX        IF RESPONSE FOR 2ND COMMAND
          UJN    RDWT20
 RDWT10   BSS
          LDML   RPB+CRN
          SHN    -14
          LMML   /SS/P.CRN,CSST
          LPN    1
          NJN    RDWT80      IF COMMAND REFERENCE NUMBER WRONG
 RDWT20   BSS
          LDML   /SS/P.TOTAL,CSST  TOTAL SECTORS LEFT TO TRANSFER
          LPC    777B
          ZJN    RDWT80      IF UNEXPECTED RESPONSE
          LDML   /SS/P.FNC,CSST
          STDL   FNC         SAVE FUNCTION
          LDN    0
          STDL   DELAY       CLEAR DELAY BITS
          STDL   SECPOS      SET SECTOR POSITION = 0
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,UX  SET CURRENT CLOCK
          LDM    /SS/P.DT,CSST
          SHN    -4
          STDL   DT          DEVICE TYPE
          LDML   SI,DT       SUSPEND INTERVAL
          STDL   SBS         SECTORS TO TRANSFER BEFORE SUSPENDING
          UJK    RDWX
 RDWT80   BSS
          LJM    TERM10      REPORT UNEXPECTED RESPONSE ERROR
          SPACE  5,20
** NAME-- RDWTOK
*
** PURPOSE-- SEND RESPONSE FOR COMPLETED READ REQUEST
          SPACE  2
 RDWTX    LJM    **
 RDWTOK   EQU    *-1
          RJM    PDR         PREPARE DISK RESPONSE
          RJM    SNDRSP      SEND RESPONSE TO CM
          AOML   /SS/P.NCOMRQ,CSST  INCREMENT NUMBER OF COMPLETED REQUESTS
          LDML   /SS/P.CURRQ,CSST  SAVE RMA OF PREVIOUS REQUEST
          STML   /SS/P.PRERQ,CSST
          LDML   /SS/P.CURRQ+1,CSST
          STML   /SS/P.PRERQ+1,CSST
          LDML   /SS/P.REQ,CSST  SAVE RMA OF CURRENT REQUEST
          STML   /SS/P.CURRQ,CSST
          LDML   /SS/P.REQ+1,CSST
          STML   /SS/P.CURRQ+1,CSST
          UJK    RDWTX
          SPACE  5,20
** NAME-- REL
*
** PURPOSE-- READ ERROR LOG
*
** EXIT
*         WC = ERROR CODE OR ZERO IF NO ERROR CODE
          SPACE  2
 RELX     LJM    **
 REL      EQU    *-1
          LDC    H8400
          STML   CP+OPCD     READ PERFORMANCE LOG COMMAND
          LDDL   CMOD
          SHN    8
          LMC    0#FF
          STML   CP+SLAD     CONTROLLER NUMBER
          LDN    6           COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDN    1
          STDL   T3          CM WORDS TO INPUT
          LDN    0
          STDL   T1          POINTER TO ERROR INFORMATION
          STDL   T2          PREVIOUS ERROR NUMBER
          STDL   WC          ERROR CODE
          LOADC  CM.CB       ADDRESS OF FIRST ERROR BUFFER
          STDL   T4
 REL10    BSS
          LDDL   T1
          SHN    7
          ADDL   T4
          CRML   RPB+15,T3   INPUT FIRST WORD OF ERROR BUFFER
          LDML   RPB+15
          SHN    -8
          ZJN    REL20       IF NO ERROR
          SBDL   T2
          MJN    REL20       IF PREVIOUS ERROR WAS LAST ONE
          ADDL   T2
          STDL   T2          SAVE ERROR NUMBER
          LDML   RPB+15
          LPC    0#FF
          ADC    -0#FA
          MJN    REL14       IF 2ND WORD HAS ERROR CODE
          SBN    3
          PJN    REL14       IF 2ND WORD HAS ERROR CODE
          ADC    0#FA+3
          SHN    8
          UJN    REL16
 REL14    BSS
          LDML   RPB+16
 REL16    BSS
          STDL   WC          SAVE ERROR CODE
          AODL   T1
          LMN    4
          NJK    REL10       IF NOT ALL ERROR BUFFERS CHECKED
 REL20    BSS
          LDDL   WC          ERROR CODE (IF NONZERO)
          LJM    RELX
          SPACE  5,20
** NAME-- RESP
*
** PURPOSE-- WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
          SPACE  2
 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  2
 RESPX    LJM    **
 RESP     EQU    *-1

*         CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDN    0
          STDL   STORS       SET FLAG TO STORE RESPONSE
          LDML   CM+/CM/P.STOR,CSST  CHECK IF CALLER WANTS RESPONSE
          SHN    /CM/L.STOR+2
          MJN    RESP10      IF STORE RESPONSE FLAG IS SET
          LDML   RS+/RS/P.SHORT
          SHN    /RS/L.SHORT+2
          PJN    RESP10      IF NOT NORMAL RESPONSE, STORE RESPONSE
          AODL   STORS       NONZERO MEANS DO NOT STORE RESPONSE
          UJK    RESPX

*         READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RESP10   BSS
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF 'IN' POINTER
          CRDL   P1          READ 'IN' POINTER

*         CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDN    0
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE
          LDDL   INP
          SBDL   OUTP
          MJN    RESP20      IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP
 RESP20   BSS
          LDML   RS+/RS/P.RESPL  GET RESPONSE LENGTH
          ADDL   INP
          STDL   INPNT       IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          MJN    RESP30      IF ROOM IN BUFFER
          RJM    PPRQ        CHECK FOR IDLE REQUEST
          UJK    RESP10
 RESP30   BSS
          LDDL   INP
          SHN    -3
          STDL   T3          'IN' POINTER IN WORDS
          LDML   RS+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          LDDL   INPNT
          SBDL   LIM
          MJN    RESP50      IF IN + RESPONSE LENGTH .LT. LIMIT
                             ONLY 1 BLOCK WRITE
          STDL   INPNT       IN + RESPONSE LENGTH - LIMIT = NEW 'IN' POINTER
          SHN    -3
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE

*         WRITE RESPONSE TO CM.

          LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADC    RS
          STML   RESP60      RESPONSE ADDRESS FOR 2ND BLOCK WRITE
 RESP50   BSS
          LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD 'IN' OFFSET
          CWML   RS,T4       WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          ZJN    RESP70      IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
                             (BEGINNING OF RESPONSE BUFFER)
 RESP60   EQU    *-1
 RESP70   BSS
          LJM    RESPX
          SPACE  5,20
** NAME-- RESPIN
*
** PURPOSE-- UPDATE THE 'IN' POINTER IN THE CM RESPONSE BUFFER.
*
** ENTRY  INPNT = NEW 'IN' POINTER.
          SPACE  2
 RESNX    LJM    **
 RESPIN   EQU    *-1

*         CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDDL   STORS       CHECK IF CALLER WANTS RESPONSE
          NJK    RESNX       IF NO RESPONSE WAS SENT

*         UPDATE THE 'IN' POINTER.

          LDN    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDDL   INPNT       NEW 'IN' POINTER
          STDL   P4
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   P1          WRITE NEW 'IN' POINTER TO CM

*         INTERRUPT PROCESSOR. RESP ROUTINE SETS UP THIS INSTRUCTION.

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   LPN-3       SET LAST BYTE NONZERO
          LDN    0           SET BANK FOR S0
 INTPRC   PSN    0           INTERRUPT OR PSN (MODIFIED)
          UJK    RESNX
          SPACE  5,20
** NAME-- RMR
*
** PURPOSE-- READ CONTROLLER MICROCODE REVISION
          SPACE  2
 RMRX     LJM    **
 RMR      EQU    *-1
          LDC    H0200       REPORT ATTRIBUTE OPERATION CODE
          RJM    SOC         SET OPERATION CODE AND CONTROLLER
*         LDC    0#36C
          STML   CP+FCP      PARAMETER TO READ REV NUMBER
          LDC    0#8050
          STML   CP+FCP+1    REPORT PARAMETER 50
          LDN    10          COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDML   RPB+8+13    SAVE MICROCODE PART NUMBER
          STML   /SS/P.MREV,CSST
          LDML   RPB+8+14
          STML   /SS/P.MREV+1,CSST
          LDDL   DT
          ZJN    RMR20       IF 1X UNIT
          SBN    2
          ZJN    RMR20       IF 5833_1X UNIT
          SBN    5
          ZJN    RMR20       IF 5838_1X UNIT
          SBN    5
          ZJN    RMR20       IF 47444_1X UNIT
          LDML   /SS/P.MREV+1,CSST
          LPN    77B
          SBN    2
          PJN    RMR20       IF MICROCODE SUPPORTS PARALLEL AND PARITY
 RMR10    BSS
          LDK    E142        MICROCODE DOES NOT SUPPORT PARALLEL
          RJM    EP          ERROR PROCESSING (NO RETURN)
 RMR20    BSS
          LJM    RMRX
          SPACE  5,20
** NAME-- SA
*
** PURPOSE-- SAVE ATTRIBUTES
          SPACE  2
 SAX      LJM    **
 SA       EQU    *-1
          LDC    H020A
          STML   CP+OPCD     SAVE ATTRIBUTES OPERATION CODE
          LDN    6           COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          UJN    SAX
          SPACE  5,20
** NAME-- SCB
*
** PURPOSE-- SET COMMAND IN PROGRESS BITS IN (UNITS,UX) FOR ONE
*            CONTROLLER
*
** ENTRY  A = BITS TO SET
*         CMOD = CONTROLLER TO SEARCH FOR UNITS
          SPACE  2
 SCBX     LJM    **
 SCB      EQU    *-1
          STDL   P1
          LDN    0
          STDL   T1
          UJN    SCB20
 SCB10    BSS
          LDN    P.UN
          RADL   T1          UPDATE POINTER TO UNITS TABLE
 SCB20    BSS
          SBDL   UNUML
          PJN    SCBX        IF END OF CONFIGURED UNITS
          LDML   UNITS,T1
          SHN    -/UN/N.UNIT
          LPN    7
          LMDL   CMOD
          NJN    SCB10       IF DIFFERENT CONTROLLER
          LDML   UNITS,T1
          LPC    0#3FFF
          LMDL   P1
          STML   UNITS,T1    SET -2 COMMANDS IN PROGRESS-
          UJN    SCB10
          SPACE  5,20
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
          SPACE  2
 SCLX     LJM    **
 SCLOCK   EQU    *-1
 SCL30    BSS
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    SCL30       IF LOCK WAS NOT SET
          STDL   CLF         CLEAR CHANNEL LOCK FLAG
          UJK    SCLX        EXIT, LOCK WAS SET
          SPACE  5,20
** NAME-- SCP
*
** PURPOSE-- SET UP COMMAND PACKET PARAMETERS FOR A WRITE
*            OR READ
          SPACE  2
 SCPX     LJM    **
 SCP      EQU    *-1
          LDN    RPL
          STML   CP          COMMAND PACKET LENGTH
          AOML   /SS/P.CRN,CSST
          SCN    0#E
          STML   /SS/P.CRN,CSST  CLEAR CARRY BIT
          LPN    1
          SHN    14
          ADDL   UX
          STML   CP+CRN      COMMAND REFERENCE NUMBER
          LDC    H0931
          STML   CP+FCP      COMMAND EXTENT PARAMETER
          LDDL   FNC
          ZJN    SCP20       IF READ
          SBN    1
          ZJN    SCP10       IF WRITE
          LDC    E501        INVALID COMMAND
          RJM    INTERR      REPORT ERROR (NO RETURN)
 SCP10    BSS
          LDC    H2005
          UJN    SCP30
 SCP20    BSS
          LDC    H1005
 SCP30    BSS
          RJM    SOU         SET OPERATION CODE AND UNIT
*         LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          MJN    SCP40       IF SECOND COMMAND
          LDML   /SS/P.TOTAL,CSST
          UJN    SCP50
 SCP40    BSS
          LDML   /SS/P.TW2,CSST
 SCP50    BSS
          SHN    2
          PJN    SCP70       IF NOT USING MASTER TERMINATE
          LDM    /SS/P.DT,CSST
          SHN    -4
          STDL   DT          DEVICE TYPE
          LDN    0
          STDL   T3
          LDML   CP+FCP+4
          LPN    77B
          STDL   T1          STARTING SECTOR
          LDML   CP+FCP+4
          SHN    -8
          STDL   T2          STARTING TRACK
          LDML   SPT,DT      SECTORS PER TRACK
          SBDL   T1
 SCP60    BSS
          RADL   T3          COMPUTE SECTORS
          AODL   T2
          SBML   TPC,DT      TRACKS PER CYLINDER
          ZJN    SCP80       IF CALCULATION COMPLETE
          LDML   SPT,DT
          UJN    SCP60
 SCP70    BSS
          LDDL   TOTAL
          UJN    SCP90
 SCP80    BSS
          LDDL   T3
          SBML   SSPC,DT     SPARE SECTORS PER CYLINDER
 SCP90    BSS
          STML   CP+FCP+2    SECTOR COUNT
          UJK    SCPX
          SPACE  5,20
** NAME-- SDA
*
** PURPOSE-- SAVE DISK ADDRESS
          SPACE  2
 SDAX     LJM    **
 SDA      EQU    *-1
          LDDL   PTF
          ZJN    SDA10       IF INITIALIZATION CONFIDENCE TEST

*         MAKE THE CYLINDER NUMBER MATCH THE ONE IN THE REQUEST IF THE
*         DRIVE NEEDS INITIALIZED.

          LDML   RS+/RS/P.ERRID
          ADC    -E140
          MJN    SDA5        IF ERROR CODE NOT E140 OR E141
          SBN    E141-E140+1
          MJN    SDA20       IF ERROR CODE IS E140 OR E141
 SDA5     BSS
          LDML   /SS/P.CT,CSST
          ZJN    SDA10       IF CONFIDENCE TEST FAILURE
          LMN    4
          NJN    SDA20       IF NOT CONFIDENCE TEST FAILURE
 SDA10    BSS
          STML   RS+/RS/P.STRK  STARTING TRACK
          STML   RS+/RS/P.SSEC  STARTING SECTOR
          LDM    /SS/P.DT,CSST
          SHN    -4
          STDL   DT          DEVICE TYPE
          LDML   CTC,DT      CONFIDENCE TEST CYLINDER
          STML   RS+/RS/P.SCYL  STARTING CYLINDER
          LDML   RS+/RS/P.ERRID
          ZJK    SDA50       IF RESPONSE PACKET PRESENT
          RJM    SSA         SET STARTING TRACK, SECTOR
          UJN    SDA30
 SDA20    BSS
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          PJN    SDA25       IF NOT RESTORE
          LDML   RTM,CSST
          NJN    SDA25       IF NOT RESTORE
          STML   RS+/RS/P.STRK  SAVE STARTING AND FAILING ADDRESS
          STML   RS+/RS/P.SSEC
          STML   RS+/RS/P.FTRK
          STML   RS+/RS/P.FSEC
          LDML   CRC,CSST    CURRENT RESTORE CYLINDER
          STML   RS+/RS/P.SCYL
          UJN    SDA30
 SDA25    BSS
          LDN    1
          STDL   T2
          LOADF  /SS/P.CURRQ,CSST  RMA OF CURRENT REQUEST
          ADN    3
          CRML   RS+/RS/P.CHAN,T2  SAVE CYLINDER, TRACK, SECTOR IN RESPONSE
 SDA30    BSS
          LDML   RS+/RS/P.ERRID
          ZJN    SDA50       IF RESPONSE PACKET PRESENT
          ADC    -E61
          MJN    SDA40       IF RESPONSE PACKET NOT PRESENT
          ADC    -E110+E61
          MJN    SDA50       IF RESPONSE PACKET PRESENT
 SDA40    BSS
          LDML   /SS/P.CURTRK,CSST
          STML   RS+/RS/P.FTRK  FAILING TRACK
          LDML   /SS/P.CURSEC,CSST
          UJK    SDA70
 SDA50    BSS
          LDN    ID29        DRIVE CONDITIONAL SUCCESS
          RJM    SFP         SEARCH FOR PARAMETER
          PJK    SDA54       IF ID 29 FOUND
          LDN    ID26
          RJM    SFP         SEARCH FOR PARAMETER
          MJK    SDA58       IF ID26 NOT FOUND
          LDML   RPB+5,T3
          SHN    -8
          SBN    17
          MJK    SDA58       IF NO COMMAND ENDING STATUS
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          PJK    SDA53       IF NOT DOING RESTORE
          LDML   RTM,CSST
          NJK    SDA53       IF NOT DOING RESTORE
          LDML   /SS/P.RQTRY,CSST
          SBN    3
          NJN    SDA53       IF NOT TIME TO SKIP MEDIA ERROR
          RJM    SMD         SKIP MEDIA DEFECT
          UJN    SDA80
 SDA53    BSS
          AODL   T3
 SDA54    BSS
          AODL   T3
          UJN    SDA60
 SDA58    BSS
          LDN    ID32        RESPONSE EXTENT
          RJM    SFP         SEARCH FOR PARAMETER
          MJK    SDA40       IF ID32 NOT FOUND
 SDA60    BSS
          LDML   RPB+9,T3
          SHN    2
          MJK    SDA40       IF NO ADDRESS PRESENT
          SHN    -10
          STML   RS+/RS/P.FTRK  FAILING TRACK
          LDML   RPB+9,T3
 SDA70    BSS
          LPC    0#FF
          STML   RS+/RS/P.FSEC  FAILING SECTOR
 SDA80    BSS
          LJM    SDAX
          SPACE  5,20
** NAME-- SDTM
*
** PURPOSE-- SET DATA TRANSFER MODE
          SPACE  2
 SDTMX    LJM    **
 SDTM     EQU    *-1
          LDC    H0209
          STML   CP+OPCD     LOAD ATTRIBUTES OPERATION CODE
          LDC    0#46E
          STML   CP+FCP      PARAMETER 6E
          LDDL   MFID
          LPN    1
          ADC    0#C080
          STML   CP+FCP+1    MODE FOR DATA
          LDN    0
          STML   CP+FCP+2
          LDN    12          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          UJK    SDTMX
          SPACE  5,20
** NAME-- SEEK
*
** PURPOSE-- ISSUE INITIAL SEEK.
          SPACE  2
 SEEKX    LJM    **
 SEEK     EQU    *-1
          LDML   UNITS,UX
          SHN    /UN/L.CIP+2
          MJN    SEEK4       IF ONE COMMAND ISSUED
          SHN    -/UN/L.CIP-2
          LPC    0#3FFF
          LMC    0#8000      INDICATE ONE COMMAND ISSUED
          UJN    SEEK8
 SEEK4    BSS
          SHN    -/UN/L.CIP-2
          LPC    0#3FFF
          LMC    0#C000      INDICATE TWO COMMANDS ISSUED
 SEEK8    BSS
          STML   UNITS,UX
          RJM    SCP         SETUP COMMAND PACKET PARAMETERS
          AODL   CMNDS       COMMAND ISSUED COUNTER
          RJM    CPT         COMMAND PACKET TRANSFER
 SEEK20   EQU    *-1         FOR FORCING ERRORS
          UJK    SEEKX
          SPACE  5,20
** NAME-- SFFMT
*
** PURPOSE-- SET THE FORCE FORMAT FLAG IN THE UNIT INTERFACE TABLE.
*
          SPACE  2
 SFFMTX   LJM    **
 SFFMT    EQU    *-1
 SFFMT10  BSS
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    SFFMT10     IF LOCK COULD NOT BE SET
          LDK    /UIT/K.FRCFMT  SET FORCE FORMAT FLAG
          STDL   T3
          LDN    0
          STDL   T2
          STDL   T4
          STDL   T5
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          RDSL   T2          -LOGICAL OR- THE FORCE FORMAT FLAG
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          UJK    SFFMTX
          SPACE  5,20
** NAME-- SETRQ
*
** PURPOSE-- SET UP FOR FIRST REQUEST.
          SPACE  2
 SETRQX   LJM    **
 SETRQ    EQU    *-1
          LDML   /SS/P.REQ,CSST  SAVE RMA OF REQUEST
          STML   /SS/P.FCOMRQ,CSST  FIRST COMPLETED REQUEST (RMA)
          STML   /SS/P.CURRQ,CSST  CURRENT REQUEST (RMA)
          LDML   /SS/P.REQ+1,CSST
          STML   /SS/P.FCOMRQ+1,CSST
          STML   /SS/P.CURRQ+1,CSST
          LDN    1
          STML   /SS/P.NCOMRQ,CSST  NUMBER OF COMPLETED REQUESTS
          LDML   RQ+/RQ/P.TRACK,CSST
          STML   /SS/P.CURTRK,CSST  CURRENT TRACK
          LDML   RQ+/RQ/P.SECTOR,CSST
          STML   /SS/P.CURSEC,CSST  CURRENT SECTOR
          LDML   RQ+/RQ/P.INT,CSST  CHECK IF INTERRUPT WAS SELECTED
          SHN    /RQ/L.INT+2
          MJN    SETR10      IF INTERRUPT SELECTED
          LDC    2400B       PSN INSTRUCTION
          UJN    SETR20
 SETR10   BSS
          LDML   RQ+/RQ/P.PORT,CSST  GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RQ/L.PORT+/RQ/N.PORT
          LPN    /RQ/M.PORT
          ADC    102600B     INPN INSTRUCTION
 SETR20   BSS
          STML   INTPRC
          UJK    SETRQX
          SPACE  5,20
** NAME-- SFP
*
** PURPOSE-- SEARCH FOR PARAMETER IDENTIFICATION IN RESPONSE PACKET
*
** ENTRY
*         A = ID TO SEARCH FOR
** EXIT
*         A = POSITIVE IF ID FOUND
*         T3 = POINTER TO ID IF IT IS FOUND (RPB+5,T3)
          SPACE  2
 SFPX     LJM    **
 SFP      EQU    *-1
          STDL   T1          PARAMETER TO SEARCH FOR
          LDN    0
          STDL   T3          POINTER TO ID BEING SEARCHED FOR
          LDML   RPB
          ADN    1
          SHN    -1
          SBN    5           LENGTH OF MINIMUM RESPONSE PACKET
 SFP4     BSS
          STDL   T2          POINTER TO END OF PARAMETERS
          MJN    SFPX        EXIT, NO ID FOUND
          LDML   RPB+5,T3
          LMDL   T1
          LPC    0#FF
          ZJN    SFPX        IF ID FOUND
          LDML   RPB+5,T3
          SHN    -9
          ADN    1           ADJUST FOR ODD BYTE
          STDL   T4          WORD LENGTH OF PARAMETER
          RADL   T3          UPDATE POINTER TO ID BEING SEARCHED FOR
          LDDL   T2
          SBDL   T4
          UJN    SFP4
          SPACE  5,20
** NAME-- SFRR
*
** PURPOSE-- SETUP FOR REQUEST RETRY FOR ONE UNIT
*
** EXIT   P5, T8 ARE UNCHANGED
*         A = UNITS,UX
          SPACE  2
 SFRR100  BSS
          RJM    DUBC        DECREMENT UNITS BUSY COUNTER
 SFRRX    BSS
          LDN    0
          STML   /SS/P.RESET,CSST  CLEAR RESET ISSUED FLAG
          STDL   IF          CLEAR INITIALIZATION FLAG
          LDML   UNITS,UX
          LPC    0#3FFF
          STML   UNITS,UX    CLEAR COMMAND IN PROGRESS BITS
          LJM    **
 SFRR     EQU    *-1
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        POINTER TO SS TABLE

*         IF INITIALIZATION, FORMAT, OR CONFIDENCE TEST, COMMAND IN
*         PROGRESS CAN SET WITHOUT INCREMENTING CMNDS

          LDML   /SS/P.CT,CSST
          ZJN    SFRR100     IF ERROR DURING CONFIDENCE TEST
          LDML   /SS/P.RESET,CSST
          NJN    SFRR100     IF SLAVE RESET IN PROGRESS
          LDML   UNITS,UX
          SHN    /UN/L.CIP+2
          PJN    SFRRX       IF NO COMMANDS IN PROGRESS
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          PJN    SFRR2       IF RESTORE NOT IN PROGRESS
          LDML   RTM,CSST
          ZJN    SFRR3       IF THIS COMMAND IS A RESTORE
          UJN    SFRR4
 SFRR2    BSS
          SHN    /UN/L.PDCE-/UN/L.RIP
          PJN    SFRR4       IF NOT ATTRIBUTE COMMAND
 SFRR3    BSS
          LJM    SFRR10
 SFRR4    BSS
          LDML   /SS/P.CURRQ,CSST  RESTORE RMA OF CURRENT REQUEST
          STML   /SS/P.REQ,CSST
          LDML   /SS/P.CURRQ+1,CSST
          STML   /SS/P.REQ+1,CSST
          LDML   /SS/P.FPVA,CSST  RESTORE PVA OF CURRENT REQUEST
          STML   /SS/P.PVA,CSST
          LDML   /SS/P.FPVA+1,CSST
          STML   /SS/P.PVA+1,CSST
          LDML   /SS/P.FPVA+2,CSST
          STML   /SS/P.PVA+2,CSST
          LDML   UNITS,UX
          SHN    2+/UN/L.TCIP
          PJN    SFRR5       IF NOT -2 COMMANDS IN PROGRESS-
          SODL   CMNDS       OUTSTANDING COMMANDS
          LDML   UNITS,UX
          LPC    0#BFFF
          STML   UNITS,UX    CLEAR -2 COMMANDS IN PROGRESS-
 SFRR5    BSS
          LDN    0
          STML   /SS/P.NCOMW,CSST  ZERO OUT NUMBER OF COMPLETED WRITE REQUESTS
          SOML   /SS/P.NCOMRQ,CSST  NUMBER OF COMPLETED REQUESTS
          ZJN    SFRR10      IF NO STREAMED READ REQUESTS
          LDML   /SS/P.PRERQ,CSST  SET UP RMA OF LAST GOOD COMPLETED REQUEST
          STML   /SS/P.CURRQ,CSST
          LDML   /SS/P.PRERQ+1,CSST
          STML   /SS/P.CURRQ+1,CSST
          LDN    1           SO DCR DOES NO SEEK
          RJM    DCR         DELETE COMPLETED REQUESTS FROM QUEUE
          UJN    SFRR15
 SFRR10   BSS
          RJM    DUBC        DECREMENT UNIT BUSY COUNTER
          SODL   CMNDS       OUTSTANDING COMMANDS
 SFRR15   BSS
          LJM    SFRRX
          SPACE  5,20
** NAME-- SMD
*
** PURPOSE-- SKIP MEDIA DEFECT
          SPACE  2
 SMDX     LJM    **
 SMD      EQU    *-1
          LDML   RPB+11,T3   SECTOR IN ERROR
          STML   /SS/P.CRTS,CSST
          SHN    -8
          STML   /SS/P.CURTRK,CSST
          STML   RS+/RS/P.FTRK  FAILING TRACK
          LDML   RPB+11,T3
          LPN    77B
          STML   /SS/P.CURSEC,CSST
          STML   RS+/RS/P.FSEC  FAILING SECTOR
          AOML   /SS/P.CRTS,CSST  UPDATE RESTORE ADDRESS TO NEXT SECTOR
          LPN    77B
          SBML   SPT,DT
          NJN    SMD10       IF NOT LAST SECTOR
          LDML   /SS/P.CRTS,CSST
          LPC    0#FF00
          ADC    0#100
          STML   /SS/P.CRTS,CSST
 SMD10    BSS
          LDML   /SS/P.CRTS,CSST  8/TRACK, 8/SECTOR
          ADC    -0#600
          SBML   SPT,DT      SECTORS PER TRACK
          ADN    2           SPARE SECTORS PER CYLINDER
          NJN    SMD20       IF NOT LAST SECTOR OF CYLINDER
          STML   /SS/P.CRTS,CSST  SET CURRENT RESTORE TRACK, SECTOR
          AOML   CRC,CSST    INCREMENT CURRENT RESTORE CYLINDER
 SMD20    BSS
          LDDL   DT
          SBN    3
          NJN    SMD30       IF NOT 1P UNIT
          RJM    FS          FORMAT 1 SECTOR
 SMD30    BSS
          UJK    SMDX
          SPACE  5,20
** NAME-- SNDRSP
*
** PURPOSE-- SEND THE RESPONSE TO CM.
*            USED WHEN SWITCHING TO THE NEXT REQUEST.
          SPACE  2
 SNDX     LJM    **
 SNDRSP   EQU    *-1
          RJM    RESP        SEND RESPONSE TO CM
          RJM    RESPIN      UPDATE -IN- POINTER IN RESPONSE BUFFER
          RJM    SRESP       SET UP RESPONSE BUFFER
          UJK    SNDX
          SPACE  5,20
** NAME-- SNDWRS
*
** PURPOSE-- SEND WRITE RESPONSES FOR WRITE REQUESTS THAT HAVE
*            BEEN SUCCESSFULLY STREAMED.
          SPACE  2
 SNDWX    LJM    **
 SNDWRS   EQU    *-1
          LDML   /SS/P.NCOMW,CSST  NUMBER OF COMPLETED WRITE REQUESTS MINUS 1
          ZJN    SNDWX       IF NO COMPLETED STREAMED WRITE REQUESTS
          LDN    2
          STDL   WD
          LOADF  /SS/P.CURRQ,CSST
          CRML   NRQ,WD      READ FIRST REQUEST TO GET START OF CHAIN
 SNDW10   BSS
          RJM    RESP        SEND RESPONSE TO CM
          RJM    RESPIN      UPDATE -IN- POINTER IN RESPONSE BUFFER
          LDML   NRQ+/RQ/P.NEXTPV  PUT PVA OF NEXT RESPONSE IN RESPONSE BUFFER
          STML   RS+/RS/P.PVA
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   RS+/RS/P.PVA+1
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   RS+/RS/P.PVA+2
          LDML   /SS/P.CURRQ,CSST  SAVE RMA OF LAST RESPONSE RETURNED
          STML   /SS/P.PRERQ,CSST
          LDML   /SS/P.CURRQ+1,CSST
          STML   /SS/P.PRERQ+1,CSST
          LDML   NRQ+/RQ/P.NEXT  REQUESTS ARE DELINKED THROUGH CURRQ
          STML   /SS/P.CURRQ,CSST
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.CURRQ+1,CSST
          LOADF  NRQ+/RQ/P.NEXT  CM ADDRESS OF NEXT REQUEST
          CRML   NRQ,WD      READ NEXT REQUEST CHAIN POINTERS
          AOML   /SS/P.NCOMRQ,CSST  INCREMENT NUMBER OF COMPLETED REQUESTS
                             (FOR DCR)
          SOML   /SS/P.NCOMW,CSST  DECREMENT COUNT OF RESPONSES LEFT TO SEND
          NJK    SNDW10      IF MORE RESPONSES
          UJK    SNDWX
          SPACE  5,15
** NAME-- SNMSG
*
** PURPOSE-- SEND UNSOLICITED MESSAGE
          SPACE  2
 SNMSGX   LJM    **
 SNMSG    EQU    *-1
          LDN    0
          STML   RS+/RS/P.SHORT  INDICATE ERROR RESPONSE
          LDC    RLIE
          STML   RS+/RS/P.RESPL  BYTE LENGTH OF RESPONSE
          LDN    R.UNS       UNSOLICITED MESSAGE
          STML   RS+/RS/P.RC  RESPONSE CODE
          RJM    RESP        SEND RESPONSE TO CM
          UJK    SNMSGX
          SPACE  5,20
** NAME-- SOC
*
** PURPOSE-- SET OPERATION CODE AND CONTROLLER
*
** ENTRY  (A) = OPERATION CODE
*
** EXIT   (A) = 36C(16)
          SPACE  2
 SOCX     LJM    **
 SOC      EQU    *-1
          STML   CP+OPCD     OPERATION CODE
          LDDL   CMOD
          LPN    7
          SHN    8
          LMC    0#FF
          STML   CP+SLAD     SLAVE ADDRESS
          LDC    0#36C
          UJN    SOCX
          SPACE  5,20
** NAME-- SOU
*
** PURPOSE-- SET OPERATION CODE AND UNIT
*
** ENTRY  (A) = 1/UNIT TYPE, 17/OPERATION CODE
*
** EXIT   (A) = (UNITS,UX)
          SPACE  2
 SOUX     LJM    **
 SOU      EQU    *-1
          STML   CP+OPCD     OPERATION CODE
          MJN    SOU10       IF USING (PD) FOR THE DRIVE NUMBER
          LDML   /SS/P.UNIT,CSST
          UJN    SOU20
 SOU10    BSS
          LDDL   CMOD
          LPN    7           GET RID OF PORT NUMBER
          SHN    8
          ADDL   PD
 SOU20    BSS
          STML   CP+SLAD     ADDRESS FOR COMMAND PACKET
          LDML   UNITS,UX
          UJN    SOUX
          SPACE  5,20
** NAME-- SPA
*
** PURPOSE-- SAVE PHYSICAL ADDRESS.  IF THE FAILING LOGICAL UNIT CONSISTS
*            OF MULTIPLE PHYSICAL DRIVES, THE FAILING DRIVE NUMBER COULD BE
*            DIFFERENT THAN THE LOGICAL UNIT NUMBER.  THIS SAVES THE ADDRESS
*            OF THE FAILING PHYSICAL DRIVE.
*
** EXIT   FPD = FAILING PHYSICAL DRIVE
          SPACE  2
 SPAX     LJM    **
 SPA      EQU    *-1
          LCN    0
          STML   FPD         INDICATE NO FAILING PHYSICAL DRIVE
          LDML   UNITS,UX
          LPC    377B
          STML   RS+/RS/P.UNIT  CONTROLLER, DRIVE NUMBER
          LDML   RS+/RS/P.ERRID
          ZJN    SPA10       IF DRIVE ERROR
          SBN    E54
          MJN    SPAX        IF NOT DRIVE ERROR (ERROR ID < 53)
          SBN    E62-E54
          MJN    SPA10       IF DRIVE ERROR (ERROR ID 54 - 61)
          SBN    E96-E62
          ZJN    SPA10       IF DRIVE ERROR (ERROR ID 96)
          SBN    E130-E96
          NJN    SPAX        IF NOT ERROR ID 130
 SPA10    BSS
          LDN    ID22
          RJM    SFP         SEARCH FOR PARAMETER
          PJN    SPA20       IF ID22 FOUND
          LDN    ID23
          RJM    SFP         SEARCH FOR PARAMETER
          PJN    SPA20       IF ID 23 FOUND
          LDN    ID29
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    SPA30       IF ID29 NOT FOUND
 SPA20    BSS
          LDML   RPB+5+3,T3  PHYSICAL DRIVE NUMBER IN BYTE 5
          UJN    SPA55
 SPA30    BSS
          LDN    ID24
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    SPA40       IF NOT ID24
          LDML   RPB+5,T3
          SHN    -8
          SBN    7
          MJK    SPA70       IF NO PHYSICAL DRIVE NUMBER
          LDML   RPB+5+3,T3  PHYSICAL DRIVE NUMBER IN BYTE 6
          UJN    SPA60
 SPA40    BSS
          LDN    ID25
          RJM    SFP         SEARCH FOR PARAMETER
          PJN    SPA50       IF ID25 FOUND
          LDN    ID26
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    SPA70       IF ID26 NOT FOUND
          LDML   RPB+5,T3
          SHN    -8
          SBN    8
          MJN    SPA70       IF NO PHYSICAL DRIVE
 SPA50    BSS
          LDML   RPB+5+4,T3  PHYSICAL DRIVE IN BYTE 7
 SPA55    BSS
          SHN    -8
 SPA60    BSS
          LPC    0#FF
          STML   FPD         FAILING PHYSICAL DRIVE
          LMC    0#FE
          ZJN    SPA70       IF ERROR FOR LOGICAL UNIT
          LDML   UNITS,UX
          LPC    340B
          LMML   FPD
          STML   RS+/RS/P.UNIT  CONTROLLER, DRIVE NUMBER
 SPA70    BSS
          LJM    SPAX
          SPACE  5,20
** NAME-- SPLOCK
*
** PURPOSE-- SETS THE PP TABLE LOCK IN THE
*            PP INTERFACE TABLE.
          SPACE  2
 SPLX     LJM    **
 SPLOCK   EQU    *-1
 SPLOCK4  BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDN    1
          STDL   T4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          RDSL   T1          ATTEMPT TO SET PP TABLE LOCK
          LDDL   T4
          LPN    1
          ZJK    SPLX        IF LOCK SET
          UJK    SPLOCK4
          SPACE  5,20
** NAME-- SQLOCK
*
** PURPOSE-- SETS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
*
** EXIT   A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
          SPACE  2
 SQLX     LJM    **
 SQLOCK   EQU    *-1
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          UJK    SQLX
          SPACE  5,20
** NAME-- SR
*
** PURPOSE-- SELECT REQUEST FROM UNIT QUEUE
*
** EXIT
*         A = 0 IF REQUEST FOUND
          SPACE  2
 SRX      LJM    **
 SR       EQU    *-1
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    SRX         IF LOCK NOT SET
          LDN    2
          STDL   P5
          LDDL   CNUM
          NJK    SR50        IF ONE COMMAND ALREADY ISSUED
          LDML   /SS/P.REQ,CSST
          ADML   /SS/P.REQ+1,CSST
          NJK    SR24        IF REQUEST ALREADY SELECTED
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.NEXTPV
          CRML   NRQ,P5      READ FIRST PVA AND RMA
          LDML   NRQ+/RQ/P.NEXT
          STML   /SS/P.REQ,CSST
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.REQ+1,CSST
          ADML   /SS/P.REQ,CSST
          NJN    SR20        IF REQUEST ON QUEUE
 SR16     BSS
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          LDN    1           NO REQUEST FOUND
          UJK    SRX
 SR20     BSS
          LDML   NRQ+/RQ/P.NEXTPV
          STML   /SS/P.PVA,CSST
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   /SS/P.PVA+1,CSST
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   /SS/P.PVA+2,CSST
          LDML   UNITS+/UN/P.UIT,UX  INITIALIZE DELINK POINTER TO FIRST REQUEST
          STML   /SS/P.DP,CSST
          LDML   UNITS+/UN/P.UIT+1,UX
          ADN    /UIT/C.NEXTPV
          STML   /SS/P.DP+1,CSST
 SR24     BSS
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          LDN    0           INDICATE REQUEST FOUND
          UJK    SRX
 SR50     BSS
          LDN    5
          STDL   WD
          LOADF  /SS/P.CURRQ,CSST
          CRML   NRQ,WD      READ NEXT REQUEST
          LDML   NRQ+/RQ/P.NEXT
          STML   /SS/P.RMA2,CSST
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.RMA2+1,CSST
          ADML   /SS/P.RMA2,CSST
          NJK    SR80        IF NOT END OF QUEUE
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.NEXTPV
          CRML   NRQ,P5      READ FIRST PVA AND RMA
          LDML   NRQ+/RQ/P.NEXT
          STML   /SS/P.RMA2,CSST
          LMML   /SS/P.FCOMRQ,CSST
          NJN    SR75        IF REQUEST FOUND
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.RMA2+1,CSST
          LMML   /SS/P.FCOMRQ+1,CSST
          ZJK    SR16        IF NO REQUEST FOUND
 SR75     BSS
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.RMA2+1,CSST
          LDML   NRQ+/RQ/P.NEXTPV
          STML   /SS/P.PVA2,CSST
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   /SS/P.PVA2+1,CSST
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   /SS/P.PVA2+2,CSST
          UJK    SR24
 SR80     BSS
          LDML   NRQ+/RQ/P.NEXTPV
          STML   /SS/P.PVA2,CSST
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   /SS/P.PVA2+1,CSST
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   /SS/P.PVA2+2,CSST
          LDML   NRQ+/RQ/P.SWIT
          SHN    /RQ/L.SWIT+2
          PJK    SR24        IF SWITCH FLAG NOT SET
          UJK    SR16
          SPACE  5,20
** NAME-- SRESP
*
** PURPOSE-- SET UP STATUS FOR RESPONSE BUFFER.
          SPACE  2
 SREX     LJM    **
 SRESP    EQU    *-1
          LDML   /SS/P.PVA,CSST  SAVE PVA OF REQUEST
          STML   /SS/P.FPVA,CSST
          LDML   /SS/P.PVA+1,CSST
          STML   /SS/P.FPVA+1,CSST
          LDML   /SS/P.PVA+2,CSST
          STML   /SS/P.FPVA+2,CSST
          LDN    0
          STML   /SS/P.XFER,CSST  TRANSFER COUNT
          STML   /SS/P.XFER+1,CSST
          UJK    SREX
          SPACE  5,20
** NAME-- SRI
*
** PURPOSE-- SET RESET ISSUED FLAG FOR ALL UNITS ON CMOD.
*            IT WILL BE CLEARED WHEN AN ASYNCHRONOUS RESPONSE
*            FOR THE DRIVE IS RECEIVED.
          SPACE  2
 SRIX     LJM    **
 SRI      EQU    *-1
          LDDL   UX
          STML   EPCT,CMOD   SAVE TABLE ISSUING RESET
          LDN    0
          STDL   P1          POINTER TO UNITS TABLE
          UJN    SRI10
 SRI5     BSS
          LDN    P.UN
          RADL   P1          UPDATE POINTER TO UNITS TABLE
 SRI10    BSS
          SBDL   UNUML
          PJN    SRIX        IF END OF CONFIGURED UNITS
          LDML   UNITS,P1
          SHN    -/UN/N.UNIT
          LPN    7
          LMDL   CMOD
          NJN    SRI5        IF DIFFERENT CONTROLLER
          LDML   UNITS+/UN/P.SSPTR,P1
          STDL   P2          POINTER TO SS TABLE
          STML   /SS/P.RESET,P2  INDICATE RESET ISSUED
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,P1  SET CURRENT CLOCK
          UJK    SRI5
          SPACE  5,20
** NAME-- SRR
*
** PURPOSE-- SHOULD RESPONSE BE READ.  CHECK IF RESPONSE PACKET MUST
*            BE READ TO ACCURATELY REPORT THE ERROR AND, IF SO
*            RETURN TO THE CALLING ROUTINE.  THE CONTROLLER MAY DROP SLAVE
*            IN ANYTIME DURING THE TRANSFER AND RETURN 90 HEX AS ENDING
*            STATUS.  THIS INDICATES COMMAND COMPLETE.  THE RESPONSE PACKET
*            SHOULD REPORT AN ERROR.
*            ALSO HANDLE AN UNANTICIPATED PAUSE.  THIS CAN OCCUR ON A READ FROM
*            A LOGICAL UNIT WITH PARITY IF MORE THAN ONE DRIVE HAS A MEDIA ERROR.
*            THE CONTROLLER WILL RETURN A TRANSFER NOTIFICATION RESPONSE, THEN
*            DROP SLAVE IN WITHOUT SENDING ANY DATA.  THIS IS NOT AN ERROR, PAUSE
*            IS SET AND THE HOST MUST BE ABLE TO WAIT FOR ANOTHER TRANSFER NOTIFICATION
*            RESPONSE AND REREAD THE SAME SECTOR.
          SPACE  2
 SRRX     BSS
          LCN    0
          STML   /SS/P.LISTL,CSST  TO GUARANTEE AN ERROR IS REPORTED
 SRR10    BSS
          AOML   SRRC        ERROR COUNTER
          LJM    **
 SRR      EQU    *-1
          LDDL   STATUS
          LPN    60B
          LMN    20B
          ZJN    SRRX        IF NO MORE DATA
          LDDL   FNC
          NJN    SRRX        IF NOT READ
          LDDL   STATUS
          LPN    60B
          NJN    SRR10       IF UNANTICIPATED PAUSE
          LDN    E29         INCOMPLETE TRANSFER
          RJM    EP          ERROR PROCESSING (NO RETURN)
 SRRC     CON    0           ERROR COUNTER
          SPACE  5,20
** NAME-- SSA
*
** PURPOSE-- SET STARTING ADDRESS FOR CONFIDENCE TEST
          SPACE  2
 SSAX     LJM    **
 SSA      EQU    *-1
          LDDL   DT
          SBN    2
          PJN    SSA10       IF NOT SSD
          LDML   TPC,DT
          SBN    1
          STML   /SS/P.CURTRK,CSST  CURRENT TRACK
          LDML   SPT,DT
          SBN    4
          UJN    SSA20
 SSA10    BSS
          LDN    0
          STML   /SS/P.CURTRK,CSST  CURRENT TRACK
 SSA20    BSS
          STML   /SS/P.CURSEC,CSST  CURRENT SECTOR
          UJK    SSAX
          SPACE  5,20
** NAME-- STI
*
** PURPOSE-- SET TABLE INDEXES (UX AND CSST).  ALSO VERIFY THIS
*            IS THE CORRECT UNIT.
          SPACE  2
 STIX     LJM    **
 STI      EQU    *-1
          LDML   RPB+CRN
          LPC    777B
          STDL   UX          SET INDEX TO UNITS TABLE
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        SET INDEX TO SS TABLE
          LDML   /SS/P.UNIT,CSST
          LMML   RPB+SLAD
          ZJK    STIX        IF CORRECT UNIT
          LJM    TERM10
          SPACE  5,20
** NAME-- SUD
*
** PURPOSE-- SPIN UP DRIVE.  THIS ROUTINE WILL ALSO REPORT
*            THAT PARITY PROTECTION IS DISABLED IF THIS IS THE
*            FIRST TIME THE DRIVE IS CHECKED AFTER THE DRIVER
*            IS LOADED.
*
** ENTRY-- A = PHYSICAL DRIVE TO SPIN UP
*
** EXIT-- A = NONZERO IF COMMAND SUCCESSFUL
          SPACE  2
 SUDX     LJM    **
 SUD      EQU    *-1
          SHN    8
          STML   CP+FCP+1    DRIVE TO SPIN UP
          LDML   /SS/P.DOAR,CSST
          LPC    0#8000
          ADML   IDLE
          NJN    SUD5        IF NOT REPORTING DRIVE OFF-LINE
          LDDL   PD          FAILING PHYSICAL DRIVE
          LPC    37B
          RJM    UPPS        UPDATE PARITY PROTECTION STATUS IN UIT
          LDK    E59         PARITY PROTECTION DISABLED
          RJM    PER         PREPARE ERROR RESPONSE
          LDN    /RS/K.PPD   PARITY PROTECTION DISABLED
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 SUD5     BSS
          LDC    0#2D5
          STML   CP+FCP      PHYSICAL DRIVE PARAMETER
          LDC    0#301
          STML   CP+OPCD     REPORT CONDITION OPERATION CODE
          LDN    10          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          LDML   RPB+6
          SHN    10
          MJK    SUD10       IF DRIVE NOT OPERATIONAL
          LDC    0#700
          STML   CP+OPCD     SET OPERATING MODE OPERATION CODE
          LDC    0#351
          STML   CP+FCP+2
          LDC    0#8000
          STML   CP+FCP+3    PARAMETER TO SELECT SPIN UP
          LDN    14
          STML   CP          COMMAND PACKET LENGTH
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LPN    8
          NJK    SUDX        IF COMMAND SUCCESSFUL
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          RJM    LIR         LOGICAL INTERFACE RESET (TO CLEAR ERROR RESPONSE)
 SUD10    BSS
          LDN    0
          UJK    SUDX
          SPACE  5,20
** NAME-- TAC
*
** PURPOSE-- TERMINATE ALL COMMANDS ISSUED
          SPACE  2
 TACX     LJM    **
 TAC      EQU    *-1
          PAUSE  100000      DELAY 170 MILLISECONDS TO ALLOW MAX.
                              DATA IN BUFFER TO BE WRITTEN TO DISK
                              AND TO GUARANTEE AT LEAST 2 SECONDS
                              ELAPSES BEFORE CHANNEL IS DOWNED
          AOML   /SS/P.RQTRY,CSST
          LDDL   PTF
          ZJN    TACX        IF IN PATH TEST
          LDN    0
          STDL   CMOD        CONTROLLER NUMBER
          STDL   UX
          UJN    TAC25
 TAC10    BSS
          AODL   CMOD
          UJN    TAC25
 TAC20    BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
          SBDL   UNUML
          PJN    TACX        IF END OF CONFIGURED UNITS
 TAC25    BSS
          LDML   UNITS,UX
          SHN    -/UN/N.UNIT
          LPN    7
          SBDL   CMOD
          MJN    TAC20       IF THIS CONTROLLER ALREADY RESET
          NJN    TAC10       IF CMOD TOO SMALL
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T1
          LDDL   T1+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJN    TAC20       IF UNIT DISABLED
          RJM    RCC         RESTART CONTROLLER COMMANDS
          RJM    LIR         LOGICAL INTERFACE RESET
          UJK    TAC10
          SPACE  5,20
** NAME-- TERM
*
** PURPOSE-- TERMINATE UNIT REQUEST.
          SPACE  2
 TERM     CON    0           NORMAL TERMINATION
          LDML   RPB+OPCD
          ADC    -H0202
          NJN    TERM2       IF NOT RESTORE ATTRIBUTE COMMAND
          LDML   UNITS,UX
          SHN    /UN/L.PDCE+2
          PJN    TERM10      IF ATTRIBUTE RESPONSE NOT EXPECTED
          UJK    TERM60
 TERM2    BSS
          ADC    H0202-0#E005
          NJN    TERM5       IF NOT RESTORE COMMAND
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          PJN    TERM10      IF RESTORE RESPONSE NOT EXPECTED
          UJK    TERM40
 TERM5    BSS
          RJM    PDR         PREPARE NORMAL DISK RESPONSE
 TERM6    BSS
          LDML   /SS/P.TOTAL,CSST  MAKE SURE ALL BYTES WERE TRANSFERRED
          LPC    777B
          ADML   /SS/P.LISTL,CSST
          ADML   /SS/P.NUMCM,CSST
          ZJN    TERM20      IF TERMINATION IS OK
 TERM10   BSS
          LDK    E76         UNEXPECTED RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 TERM20   BSS
          RJM    SNDWRS      SEND WRITE RESPONSES
          RJM    RESP        SEND RESPONSE TO CPU
          LDML   UNITS,UX
          LPC    0#800       RESTORE IN PROGESS BIT
          RJM    DCR         DELETE COMPLETED REQUEST FROM QUEUE
          LDN    0
          STML   /SS/P.RQTRY,CSST  CLEAR RETRY COUNT
          STML   /SS/P.RECOV,CSST  SO SPIN UP CAN OCCUR IN ROUTINE COD
          LDML   UNITS,UX
          SHN    /UN/L.CIP+2
          MJN    TERM30      IF COMMAND IN PROGRESS
          SHN    /UN/L.RIP-/UN/L.CIP
          PJN    TERM25      IF RESTORE NOT IN PROGRESS
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          SOML   RTM,CSST    UPDATE COUNT OF REQUESTS TO MULTIPLEX
          LDN    0
          STML   /SS/P.REQ,CSST  SO SR ROUTINE STARTS AT BEGINNING OF QUEUE
          STML   /SS/P.REQ+1,CSST
          UJN    TERM30
 TERM25   BSS
          RJM    UUT         UNLOCK UNIT TABLE
 TERM30   BSS
          LJM    MAIN20
 TERM40   BSS
          LDM    /SS/P.DT,CSST
          SHN    -4
          STDL   DT          DRIVE TYPE
          LDN    0
          STML   /SS/P.CRTS,CSST  SET CURRENT RESTORE TRACK, SECTOR
          AOML   CRC,CSST    INCREMENT CURRENT RESTORE CYLINDER
          SBML   CTC,DT
          MJN    TERM50      IF MORE CYLINDERS TO RESTORE
          ZJN    TERM50      IF MORE CYLINDERS TO RESTORE
          LDC    /UIT/K.PARPRO+DRNUM  PARITY PROTECTION ENABLED
          RJM    UPPS        UPDATE PARITY PROTECTION STATUS
          LDN    E56         RESTORE COMPLETE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDML   UNITS,UX
          LPC    340B
          ADML   ODN,CSST
          STML   RS+/RS/P.UNIT  CONTROLLER, DRIVE ADDRESS
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          LDML   UNITS,UX
          LPC    0#F7FF
          STML   UNITS,UX    CLEAR RESTORE IN PROGRESS
          RJM    UUT         UNLOCK UNIT TABLE
 TERM50   BSS
          LDN    5
          STML   RTM,CSST    REQUESTS TO MULTIPLEX
 TERM60   BSS
          LDML   UNITS,UX    CLEAR COMMAND IN PROGRESS, CLEAR PDCE
          LPC    0#DFF
          STML   UNITS,UX
          RJM    DUBC        DECREMENT UNIT BUSY COUNTER
          SODL   CMNDS       COMMANDS ISSUED COUNTER
          LJM    MAIN20
          SPACE  5,20
** NAME-- TERMP
*
** PURPOSE-- TERMINATE PP REQUEST.
          SPACE  2
 TERX     LJM    **
 TERMP    EQU    *-1
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
          UJK    TERX
          SPACE  5,20
** NAME-- UBT
*
** PURPOSE-- UPDATE BYTES TRANSFERRED
          SPACE  2
 UBT10    BSS
          RJM    UNCMND      GET NEXT COMMAND
 UBTX     LJM    **
 UBT      EQU    *-1
          LDDL   BYTES       BYTES TRANSFERRED
          RAML   /SS/P.XFER+1,CSST  UPDATE BYTES TRANSFERRED
          SHN    -16
          RAML   /SS/P.XFER,CSST
          LDDL   BYTES
          RAML   CMLIST+/CM/P.RMA+1,CSST  UPDATE CM ADDRESS
          SHN    -16
          RAML   CMLIST+/CM/P.RMA,CSST
          LDML   CMLIST+/CM/P.LEN,CSST  UPDATE BYTES LEFT TO TRANSFER
          SBDL   BYTES
          STML   CMLIST+/CM/P.LEN,CSST
          NJN    UBTX        IF MORE WORDS LEFT TO TRANSFER TO THIS
                              CM ADDRESS
          SOML   /SS/P.LISTL,CSST  DECREMENT ADDRESS-LENGTH-PAIR COUNT
          ZJK    UBT10       IF END OF RMA LIST
          RJM    GLIST       READ NEXT SECTION OF THE LIST WHICH POINTS
                             TO THE CM DATA AREA
          UJK    UBTX
          SPACE  5,20
** NAME-- UC
*
** PURPOSE-- UPDATE CLOCK.  THE CLOCK IS USED TO TIMEOUT COMMANDS
*            ISSUED TO THE CONTROLLER.
          SPACE  2
 UCX      LJM    **
 UC       EQU    *-1
          LDDL   CLCUR
          STDL   P6          SAVE CURRENT CLOCK
          IAN    14B
          STDL   CLCUR
          SBDL   P6
          PJN    UC5         IF CLOCK HASNT WRAPPED
          ADC    0#10000
 UC5      BSS
          RADL   CLMCS       UPDATE MICROSECOND PORTION OF CLOCK
          LDDL   CLMCS
          ADC    -30000
          MJN    UCX         IF LESS THAN 30 MILLISECONDS
          STDL   CLMCS
          LDN    30
          RADL   CLMLS       UPDATE MILLISECOND PORTION OF CLOCK
          ADC    -1000
          MJN    UCX         IF LESS THAN 1 SECOND
          STDL   CLMLS
          AODL   CLSEC       UPDATE SECOND PORTION OF CLOCK
          UJN    UCX
          SPACE  5,20
** NAME-- UDA
*
** PURPOSE-- UPDATE DISK ADDRESS. THIS ALLOWS THE PP TO VERIFY THAT
*            A STREAMED REQUEST IS FOR THE NEXT SEQUENTIAL DISK SECTOR.
          SPACE  2
 UDAX     BSS
          SOML   /SS/P.TOTAL,CSST  SECTORS TO TRANSFER
          LJM    **
 UDA      EQU    *-1
          SODL   SBS         SECTORS BEFORE SUSPENDING
          AOML   /SS/P.CURSEC,CSST  INCREMENT SECTOR
          SBML   SPT,DT      SECTORS PER TRACK
          MJN    UDAX        IF SAME TRACK
          STML   /SS/P.CURSEC,CSST
          AOML   /SS/P.CURTRK,CSST  INCREMENT TRACK
          UJN    UDAX
          SPACE  5,20
** NAME-- UNCMND
*
** PURPOSE-- GET NEXT COMMAND FROM CM.  SET UP CMLIST AND
*            LISTL IN THE SS TABLE.  SET FNC AS THE INDEX TO
*            A TABLE OF COMMANDS FROM CENTRAL MEMORY.
*
** EXIT   A REGISTER = 0, IF NO MORE COMMANDS.
          SPACE  2
 UNCX     LJM    **
 UNCMND   EQU    *-1
          LDML   /SS/P.NUMCM,CSST
          ZJN    UNCX        IF NO MORE COMMANDS
          SOML   /SS/P.NUMCM,CSST  DECREMENT COMMAND COUNT
          LDML   /SS/P.FRST,CSST  HAS FIRST COMMAND BEEN PROCESSED
          ZJN    UNC10       IF FIRST COMMAND HASN'T BEEN PROCESSED

*         READ NEXT COMMAND FROM CM.

          LDDL   CSST        ADDRESS OF SS TABLE
          ADK    CM
          STML   UNC4        ADDRESS TO STORE COMMAND
          AOML   /SS/P.LASTC,CSST  INCREMENT OFFSET OF LAST COMMAND
          LDN    C.CM
          STDL   WD
          LOADF  /SS/P.REQ,CSST  LOAD CM ADDRESS AND REFORMAT
          ADML   /SS/P.LASTC,CSST  ADD OFFSET OF COMMAND
          CRML   *,WD       READ COMMAND FROM CM
 UNC4     EQU    *-1

*         IF INDIRECT ADDRESS, READ CM ADDRESS LIST.

 UNC10    BSS
          LDML   CM+/CM/P.LEN,CSST  ENSURE AN EVEN NUMBER OF CM WORDS
          ADN    7
          SCN    7
          STML   CM+/CM/P.LEN,CSST
          STML   CMLIST+/CM/P.LEN,CSST
          SHN    -3
          STML   /SS/P.LISTL,CSST  LENGTH OF CM ADDRESS AREA  (CM WORDS)
          LDML   CM+/CM/P.INDIR,CSST
          SHN    /CM/L.INDIR+2
          MJN    UNC15       IF INDIRECT ADDRESS
          LDN    1
          STML   /SS/P.LISTL,CSST  IF NOT INDIRECT, ONLY 1 COMMAND.
          LDML   CM+/CM/P.RMA,CSST
          STML   CMLIST+/CM/P.RMA,CSST
          LDML   CM+/CM/P.RMA+1,CSST
          STML   CMLIST+/CM/P.RMA+1,CSST
          UJN    UNC20
 UNC15    BSS
          RJM    GLIST       GET CM ADDRESS LIST OF DATA AREA
 UNC20    BSS
          LDN    0
          STDL   FNC         SET UP INTERNAL FUNCTION CODE
 UNC30    LDML   CM+/CM/P.CODE,CSST  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          ERRNZ  /CM/L.CODE
          LMML   UCMD,FNC    COMPARE COMMAND CODE
          ZJN    UNC40       IF COMMAND FOUND
          AODL   FNC
          SBN    UCMDL
          MJN    UNC30       IF MORE COMMANDS TO CHECK
 UNC35    BSS
          LDC    E501        ERROR IN COMMAND CODE
          RJM    INTERR      REPORT ERROR (NO RETURN)
 UNC40    BSS
          LDML   /SS/P.FRST,CSST
          ZJN    UNC60       IF FIRST COMMAND
          LDDL   FNC
          LMML   /SS/P.FNC,CSST  FUNCTION CODE
          ZJN    UNC70       IF SAME AS LAST COMMAND
          UJN    UNC35
 UNC60    BSS
          LDDL   FNC
          STML   /SS/P.FNC,CSST  SAVE COMMAND CODE
 UNC70    BSS
          AOML   /SS/P.FRST,CSST  SET FIRST COMMAND FLAG NONZERO
          UJK    UNCX        EXIT A REGISTER NONZERO
          SPACE  5,20
** NAME-- UPD
*
** PURPOSE-- UPDATE PHYSICAL DRIVE NUMBER
*
** EXIT
*         A NOT 0 IF NUMBER UPDATED
*         A = 0   DONE, NO UPDATE MADE
          SPACE  2
 UPDX     LJM    **
 UPD      EQU    *-1
          LDDL   DT
          ZJN    UPDX        IF NO UPDATE NECESSARY (5832_1)
          SBN    2
          ZJN    UPDX        IF NO UPDATE NECESSARY (5833_1)
          SBN    5
          ZJN    UPDX        IF NO UPDATE NECESSARY (5838_1)
          SBN    5
          ZJN    UPDX        IF NO UPDATE NECESSARY (47444_1)
          LDDL   PD
          SHN    -3
          SBN    3
          ZJN    UPDX        IF NO UPDATE NECESSARY
          LDDL   DT
          SBN    4
          ZJN    UPD10       IF 5833_2
          ADN    3
          ZJN    UPD10       IF 5832_2
          SBN    8
          ZJN    UPD10       IF 5838_2
          SBN    5
          NJK    UPD20       IF NOT 47444_2
 UPD10    BSS
          LDDL   PD
          SHN    -3
          SBN    1
          ZJN    UPDX        IF NO UPDATE NECESSARY
 UPD20    BSS
          LDDL   DT
          SBN    3
          ZJN    UPD25       IF 5833_1P
          SBN    5
          ZJN    UPD25       IF 5838_1P
          SBN    5
          NJN    UPD30       IF NOT 47444_1P
 UPD25    LDN    30B         STRING 3
          UJN    UPD40
 UPD30    BSS
          LDN    10B         UPDATE TO NEXT STRING
 UPD40    BSS
          RADL   PD
          LJM    UPDX
          SPACE  5,20
** NAME-- UPPS
*
** PURPOSE-- UPDATE PARITY PROTECTION STATUS TO UIT.
*
*
          SPACE  2
 UPPSX    LJM    **
 UPPS     EQU    *-1
          STDL   T1          NEW STATUS
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          STDL   T2
          CRDL   T5          READ UNIT INTERFACE TABLE
          LDDL   T5+/UIT/P.PARPRO
          LPC    -/UIT/K.PBITS MASK OUT OLD PARITY PROTECTION STATUS
          ADDL   T1          NEW PARITY PROTECTION STATUS
          STDL   T5+/UIT/P.PARPRO
          LDDL   T2
          CWDL   T5          REWRITE UPDATED PARITY PROTECTION STATUS
          UJK    UPPSX
          SPACE  5,20
** NAME-- UREQ
*
** PURPOSE-- READ A REQUEST FROM CM.  THE REQUEST IS READ WITH 2
*            3-WORD INPUTS SO THAT THE RMA WILL BE CORRECT IF THE
*            STREAM BIT IS SET.  ROUTINE GETR DOES NOT LOCK THE
*            QUEUE FOR PERFORMANCE REASONS, SO THE CP AND PP COULD
*            BE CHANGING THE QUEUE AT THE SAME TIME.
*
** ENTRY  CSST = POINTER TO SS TABLE
*
** EXIT   RQ  CONTAINS CURRENT REQUEST.
*         FRST = 0
*         NUMCM = NUMBER OF COMMANDS.
          SPACE  2
 UREQX    LJM    **
 UREQ     EQU    *-1
          LDN    0
          STML   /SS/P.FRST,CSST  SET FLAG WHEN REQUEST IS READ
          LDN    3           NUMBER OF WORDS TO READ
          STDL   WD
          LDDL   CSST        ADDRESS OF SS TABLE
          ADK    RQ          LOCATION OF REQUEST IN SS TABLE
          STML   UREQ8       ADDRESS TO PUT REQUEST
          ADN    8
          STML   UREQ4
          LOADF  /SS/P.REQ,CSST  LOAD CM REQUEST ADDRESS
          ADN    2
          CRML   *,WD        READ CURRENT REQUEST
 UREQ4    EQU    *-1
          SBN    5
          CRML   *,WD
 UREQ8    EQU    *-1
          LDML   RQ+/RQ/P.LEN,CSST  DETERMINE NUMBER OF COMMANDS
          SHN    -3
          SBN    /RQ/C.CMND
          STML   /SS/P.NUMCM,CSST  NUMBER OF COMMANDS
          LDN    /RQ/C.CMND
          STML   /SS/P.LASTC,CSST  OFFSET OF COMMAND
          UJK    UREQX
          IFEQ   TB,1
          SPACE  5,20
** NAME-- UT
*
** PURPOSE-- UPDATE TRACE
*            CM.CB      UPPER 16 BITS OF RMA
*            (Z1+1) * 8 LOWER 16 BITS OF RMA
*
*     COMMAND      0000      :   OP CODE    :   DRIVE ADDRESS     : CLOCK
*              --------------:--------------:---------------------:------
*               SECTOR COUNT :  CYLINDER    :   HEAD, SECTOR      : CRN
*                                           :                     :
*     RESPONSE     FFFF      :   OP CODE    :   DRIVE ADDRESS     : CLOCK
*              --------------:--------------:---------------------:------
*               SECTOR CNT   : MAJOR STATUS : SECTORS TRANSFERRED : CRN
*                REMAINING   :              :                     :
          SPACE  2
 UTX      LJM    **
 UT       EQU    *-1
          LRML   CM.CB
          LDDL   Z1+1
          CWDL   Z1+2
          AODL   Z1+1
          AODL   Z1
          LMC    0#200
          NJN    UTX
          STDL   Z1
          LDML   CM.CB+1
          ADC    0#200
          STDL   Z1+1
          UJN    UTX
          ENDIF
          SPACE  5,20
** NAME-- UUT
*
** PURPOSE-- UNLOCK UNIT TABLE
          SPACE  2
 UUTX     LJM    **
 UUT      EQU    *-1
          LDN    0
          STDL   T1
          STDL   T4
          STML   /SS/P.REQ,CSST
          STML   /SS/P.REQ+1,CSST  SO SR ROUTINE STARTS AT BEGINNING OF REQUEST
          LCN    0
          STDL   T2
          STDL   T3
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.ULOCK  INDEX TO LOCKWORD
          RDCL   T1          CLEAR THE LOCK
          UJN    UUTX
          SPACE  5,20
** NAME-- VCTD
*
** PURPOSE-- VERIFY CONFIDENCE TEST DATA
          SPACE  2
 VCTDX    LJM    **
 VCTD     EQU    *-1
          LDN    0
          STDL   P1
          LDML   /SS/P.CURTRK,CSST
          SHN    8
          ADML   /SS/P.CURSEC,CSST
          STDL   P2
          LDDL   CSST
          STDL   P3
 VCTD5    BSS
          LDML   CTME,P3     ADDRESS IN TABLE
          LMDL   P2          CURRENT ADDRESS
          ZJK    VCTDX       IF SECTOR NOT WRITTEN
          AODL   P3
          AODL   P1
          LMN    3
          NJN    VCTD5       IF MORE TABLE LOCATIONS TO CHECK
          LDML   SPC,DT      SECTORS PER CYLINDER
          SBML   /SS/P.TOTAL,CSST  SECTORS TO TRANSFER
          SHN    2
          ADDL   CTPAT       CONFIDENCE TEST PATTERN FIRST WORD MINUS ONE
          STDL   P1          STARTING DATA PATTERN VALUE MINUS ONE
          LDML   BPS,DT      BYTES PER SECTOR
          SHN    -3
          STDL   P6          CM WORDS PER SECTOR
          LDN    0
          STDL   P3
          LOADC  CM.CB       ADDRESS OF PP COMMUNICATIONS BUFFER
          STDL   P2
 VCTD10   BSS
          LDDL   P2
          ADDL   P3
          CRDL   T4          READ WORD OF SECTOR
          AODL   P1
          SBDL   T4
          NJN    VCTD20      IF DATA MISCOMPARE
          AODL   P1
          SBDL   T5
          NJN    VCTD20      IF DATA MISCOMPARE
          AODL   P1
          SBDL   T6
          NJN    VCTD20      IF DATA MISCOMPARE
          AODL   P1
          SBDL   T7
          NJN    VCTD20      IF DATA MISCOMPARE
          AODL   P3          INDEX TO WORD TO READ
          LMDL   P6
          NJN    VCTD10      IF MORE WORDS TO VERIFY
          LJM    VCTDX
 VCTD20   BSS
          RJM    SFRR        CLEAR CIP, IF
          LDN    4
          STML   /SS/P.CT,CSST  INDICATE DATA INTEGRITY ERROR
          LDK    E111        CM-DRIVE DATA INTEGRITY
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- VPTD
*
** PURPOSE-- VERIFY PATH TEST DATA
          SPACE  2
 VPTDX    LJM    **
 VPTD     EQU    *-1
          LDN    0
          STDL   T1          INDEX TO BUFFER
 VPTD4    BSS
          LDML   IB,T1       WORD FROM INPUT BUFFER
          LMML   OB,T1       WORD FROM OUTPUT BUFFER
          NJN    VPTD10      IF ERROR
          AODL   T1
          SBN    50
          ZJN    VPTDX       IF VERIFY OK
          UJN    VPTD4       MORE WORDS TO CHECK
 VPTD10   BSS
          LDK    E110        PP-CONTROLLER DATA INTEGRITY
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- VRP
*
** PURPOSE-- VERIFY RESPONSE PACKET
*
** EXIT-- TO CALLER IF 2ND, 3RD, AND 4TH WORDS OF RESPONSE CORRECT
          SPACE  2
 VRPX     LJM    **
 VRP      EQU    *-1
          LDML   RPB+CRN
          LMML   CP+CRN
          NJN    VRP10       IF COMMAND REFERENCE NUMBER WRONG
          LDML   RPB+OPCD
          LMML   CP+OPCD
          NJN    VRP10       IF OPERATION CODE WRONG
          LDML   RPB+SLAD
          LMML   CP+SLAD
          ZJN    VRPX        IF SLAVE ADDRESS CORRECT
 VRP10    BSS
          LDK    E76         UNEXPECTED RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          TITLE  IPI CHANNEL SUBROUTINES
** NAME-- BCS
*
** PURPOSE-- PERFORM BUS CONTROL SEQUENCE
*
** ENTRY
*         A = BUS A BITS 7,6 IN BITS 1,0 OF ACCUMULATOR
*             BIT 7 = 1 IF DATA ELSE RESPONSE OR COMMAND
*             BIT 6 = 1 IF INFORMATION IN
          SPACE  2
 BCSX     LJM    **
 BCS      EQU    *-1
          SHN    14
          ADC    H005B
          RJM    FUNC        SET SYNC OUT
          ACN    DC
          LDN    77B
 BCS4     BSS
          FJM    BCS8,DC     IF SYNC IN
          SBN    1
          NJN    BCS4        IF TIMEOUT NOT EXPIRED
          LDN    E22         NO SYNC IN
          UJN    BCS20
 BCS8     BSS
          IAN    DC
          STDL   STATUS      SAVE BUS ACKNOWLEDGE STATUS
          SFM    BCS25,DC    IF ERROR FLAG SET
          LPC    0#FF
          NJN    BCS16       IF BUS ACKNOWLEDGE IS WRONG
          LDDL   LF          LAST FUNCTION
          LMN    0#32
          RJM    FUNC        DROP SYNC OUT
          ACN    DC
          LDN    77B
 BCS12    BSS
          FJM    BCSX,DC     IF SYNC IN DROPPED
          SBN    1
          NJN    BCS12       IF TIMEOUT NOT EXPIRED
          LDN    E23         SYNC IN DID NOT DROP
          UJN    BCS20
 BCS16    BSS
          LDN    E37         BUS ACKNOWLEDGE WRONG
 BCS20    BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
 BCS25    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,15
** NAME-- CPT
*
** PURPOSE-- COMMAND PACKET TRANSFER
*
** ENTRY
*         CP - STARTING ADDRESS OF COMMAND PACKET
          SPACE  2
 CPT30    BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT THE CONTROLLER
          IFEQ   TB,1
          LDN    0
          STDL   Z1+2        INDICATE COMMAND
          LDML   CP+OPCD
          STDL   Z1+3        OP CODE
          LDML   CP+SLAD
          STDL   Z1+4        ADDRESS
          LDDL   CLSEC
          STDL   Z1+5        CLOCK
          RJM    UT          UPDATE TRACE
          LDML   CP+FCP+2
          STDL   Z1+2        SECTOR COUNT
          LDML   CP+FCP+3
          STDL   Z1+3        CYLINDER
          LDML   CP+FCP+4
          STDL   Z1+4        TRACK, SECTOR
          LDML   CP+CRN
          STDL   Z1+5        COMMAND REFERENCE NUMBER
          RJM    UT          UPDATE TRACE
          ENDIF
          LDDL   WC
          ZJN    CPTX        IF ALL WORDS TRANSFERRED
          LDN    E29         INCOMPLETE TRANSFER
          UJK    CPT10
 CPTX     LJM    **
 CPT      EQU    *-1
          RJM    SEL         SELECT THE CONTROLLER
          LDN    CMDOUT      BUS A FOR COMMAND
          RJM    BCS         BUS CONTROL SEQUENCE
          LDDL   MFID        MASK FOR INTERLOCK DATA
          LPC    0#200
          LMC    H0381       STREAM, WRITE
          RJM    FUNC        RAISE MASTER OUT
          ACN    DC
          LDML   CP
          ADN    3
          SHN    -1          CONVERT BYTE COUNT TO WORD COUNT
          OAM    CP,DC       SEND COMMAND PACKET
          STDL   WC          WORDS NOT TRANSFERRED
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,UX  SET CURRENT CLOCK
          LDC    MS50
 CPT4     IJM    CPT30,DC    IF SLAVE IN DROPPED
          SBN    1
          NJN    CPT4        IF TIMEOUT NOT EXPIRED
          LDN    E30         CHANNEL STAYED ACTIVE
 CPT10    BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,15
** NAME-- DCM
*
** PURPOSE-- DESELECT THE CONTROLLER
          SPACE  2
 DCMX     LJM    **
 DCM      EQU    *-1
          LDC    H0071
          RJM    FUNC        DROP SELECT OUT
          ACN    DC
          LDN    77B
 DCM4     FJM    DCMX,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    DCM4        IF TIMEOUT NOT EXPIRED
          LDN    E28         SLAVE IN DID NOT DROP
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,15
** NAME-- DTM
*
** PURPOSE-- DETERMINE TRANSFER MODE
*
** ENTRY
*         MFID - MASK FOR INTERLOCK DATA
*
** EXIT
*         STATUS - TRANSFER SETTINGS, BIT 4 = 1 IF DATA STREAMING
*         CTM - USED TO CHANGE TRANSFER MODE WHEN SELECTING
          SPACE  2
 DTMX     LJM    **
 DTM      EQU    *-1
          LDDL   CMOD        CONTROLLER NUMBER
          SHN    12
          ADC    H8025
          RJM    FUNC        REQUEST TRANSFER SETTINGS
          ACN    DC
          LDN    77B
 DTM4     FJM    DTM8,DC     IF SLAVE IN
          SBN    1
          NJN    DTM4        IF TIMEOUT NOT EXPIRED
          LDN    E27         NO SLAVE IN
          UJN    DTM16
 DTM8     BSS
          IAN    DC
          STDL   STATUS      SAVE TRANSFER SETTING
          SFM    DTM20,DC    IF ERROR FLAG SET
          LPN    0#10
          LMN    0#10
          SHN    5
          LMDL   MFID        MASK FOR INTERLOCK DATA
          LPC    0#200
          SHN    2
          STDL   CTM         CHANGE TRANSFER MODE BIT
          LDDL   LF          LAST FUNCTION ISSUED
          LMC    0#54        CODE 7, DROP MASTER OUT
          RJM    FUNC        DROP MASTER OUT
          ACN    DC
          LDN    77B
 DTM12    FJM    DTMX,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    DTM12       IF TIMEOUT NOT EXPIRED
          LDN    E28         SLAVE IN DID NOT DROP
 DTM16    BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
 DTM20    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- EI
*
** PURPOSE-- ENABLE INTERRUPT FROM CONTROLLER.  SINCE IT TAKES UP TO
*            20 MICROSECONDS FOR THE CONTROLLER TO PUT ITS INTERRUPT
*            ON THE BUS, THE ENABLE IS DONE HERE AND THE READ
*            IS DONE IN GETU
          SPACE  2
 EIX      LJM    **
 EI       EQU    *-1
          LDDL   UNUML
          ZJN    EIX         IF NO CONFIGURED UNITS
          LDC    H0715
          RJM    FAN         REQUEST CLASS 1, 2, OR 3 INTERRUPT
          UJN    EIX
          SPACE  5,20
** NAME-- FAN
*
** PURPOSE-- SEND A FUNCTION TO THE IPI CHANNEL.
          SPACE  2
 FANX     LJM    **
 FAN      EQU    *-1
          DCN    DC+40B      ENSURE THE CHANNEL IS INACTIVE
                              THE CHANNEL MAY HAVE BEEN LEFT ACTIVE
                              BY A MASTER CLEAR, A ROUTINE SUCH AS
                              DCM, OR AFTER A REPORTED ERROR.
          FAN    DC          SEND THE FUNCTION
          UJN    FANX
          SPACE  5,20
** NAME-- FUNC
*
** PURPOSE-- ISSUE FUNCTION TO IPI CHANNEL
*
** ENTRY  A REGISTER = FUNCTION CODE.
          SPACE  2
 FUNX     LJM    **
 FUNC     EQU    *-1
          DCN    DC+40B      ENSURE CHANNEL IS INACTIVE
                              THE CHANNEL MAY HAVE BEEN LEFT ACTIVE
                              BY A MASTER CLEAR, A ROUTINE SUCH AS
                              DCM, OR AFTER A REPORTED ERROR.
          FAN    DC          ISSUE THE FUNCTION
          STDL   LF          SAVE FUNCTION CODE
          STML   FBUF,FI     SAVE HISTORY OF FUNCTIONS ISSUED
          AODL   FI          INCREMENT FUNCTION BUFFER INDEX
          ADC    -FBUFL
          NJN    FUN4        IF NOT END OF BUFFER
          STDL   FI          INITIALIZE INDEX
 FUN4     BSS
          IJM    FUNX,DC     EXIT IF CHANNEL INACTIVE
          LDN    E01         FUNCTION TIMEOUT
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- GES
*
** PURPOSE-- GET ENDING STATUS
*
** ENTRY
*         A = 0000  DO ENDING STATUS WITHOUT MASTER TERMINATE
*             000A  DO ENDING STATUS WITH MASTER TERMINATE
** EXIT
*         RETURNS TO CALLING PROGRAM IF STATUS IS READ WITHOUT ERROR
*         AND SUCCESSFUL IS SET IN STATUS
          SPACE  2
 GESX     LJM    **
 GES      EQU    *-1
          SHN    8
          ADC    H8039       INDICATE SUCCESSFUL IN BUS A
          RJM    FUNC        DROP MASTER OUT
          ACN    DC
          LDC    1280
 GES5     BSS
          FJM    GES10,DC    IF SLAVE IN SET
          SBN    1
          NJN    GES5        IF TIMEOUT NOT EXPIRED
          LDN    E27         SLAVE IN NOT SET
          UJN    GES12
 GES10    BSS
          IAN    DC
          STDL   STATUS      SAVE ENDING STATUS
          SFM    GES55,DC    IF ERROR FLAG SET
          SHN    17-7
          MJN    GESX        IF SUCCESSFUL
          LDDL   STATUS
          SHN    11
          PJN    GES15       IF NOT BUS PARITY
          LDK    E34
 GES12    BSS
          UJN    GES22
 GES15    BSS
          LDDL   STATUS
          LPN    17B
          ZJN    GES16       IF REPORTING -ENDING STATUS WRONG-
          SBN    1
          NJN    GES20       IF NOT BUS CONTROL REJECTED
          LDDL   TBC
 GES16    ZJK    GES40       IF REPORTING -ENDING STATUS WRONG-
          LDN    0
          STDL   TBC         INDICATE NOT EXPECTING 01 STATUS
          RJM    DCM         DESELECT THE CONTROLLER
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    GES17       IF CLOCK HASNT WRAPPED
          ADC    0#10000
 GES17    BSS
          SBN    CMT         COMMAND TIMEOUT
          PJN    GES38       IF TIMEOUT
          LJM    MAIN15      TRANSFER NOTIFICATION OCCURRED BEFORE
                              THE COMPLETION RESPONSE, WAIT FOR
                              THE COMPLETION RESPONSE
 GES20    BSS
          SBN    8
          NJN    GES25       IF NOT -SYNC OUTS NOT EQUAL SYNC INS-
          LDK    E36
 GES22    BSS
          UJN    GES50
 GES25    BSS
          PJN    GES35       IF NOT COMMAND REJECT
          ADN    6
          NJN    GES27       IF NOT CLASS 3 RESPONSE PRESENT
          RJM    RPT         READ RESPONSE PACKET
*         LDN    E00         RESPONSE MUST BE EVALUATED TO DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 GES27    BSS
          LDK    E35
 GES30    BSS
          UJN    GES50
 GES35    BSS
          SBN    2
          NJN    GES40       IF NOT LRC ERROR
          LDK    E70
          UJN    GES50
 GES38    BSS
          LDN    E38         NO CONTROLLER RESPONSE
          UJN    GES50
 GES40    BSS
          LDN    E39         ENDING STATUS WRONG
 GES50    BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
 GES55    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- IR
*
** PURPOSE-- ISSUE INTERFACE RESET TO CONTROLLER
*
** ENTRY
*         A = 8215  FOR LOGICAL INTERFACE RESET
*             8415  FOR SLAVE RESET
*         CMOD = CONTROLLER NUMBER
          SPACE  2
 IRX      LJM    **
 IR       EQU    *-1
          STDL   P2
          RJM    MCC         MASTER CLEAR CHANNEL
          LDDL   CMOD        CONTROLLER NUMBER
          SHN    12
          ADDL   P2
          RJM    FUNC        SET MASTER OUT
          PAUSE  20
          LDDL   LF          LAST FUNCTION ISSUED
          LMN    2
          RJM    FUNC        SET SYNC OUT
          PAUSE  10
          LDDL   LF
          LMN    2
          RJM    FUNC        DROP SYNC OUT
          LDDL   LF
          LMN    4
          RJM    FUNC        DROP MASTER OUT
          UJK    IRX
          SPACE  5,20
** NAME-- MCC
*
** PURPOSE-- MASTER CLEAR CHANNEL
          SPACE  2
 MCCX     LJM    **
 MCC      EQU    *-1
          MCLR   DC          MASTER CLEAR CHANNEL
          PAUSE  100         ALLOW CONTROLLER TIME TO DROP LINES
          MCLR   DC          IN CASE SEQUENCE ERROR OCCURRED
          PAUSE  1
          LDC    H7E42
          RJM    FUNC        SET IPI CHANNEL TRANSFER RATE
          UJN    MCCX
          SPACE  5,20
** NAME-- MR
*
** PURPOSE-- MASTER RESET ALL SLAVES ON THE CHANNEL
          SPACE  2
 MRX      LJM    **
 MR       EQU    *-1
          RJM    MCC         MASTER CLEAR CHANNEL
          LDC    H9213
          RJM    FUNC        BUS A, SET SYNC OUT
          PAUSE  10          MUST DELAY 10 MICROSECONDS MINIMUM
          LDC    H9211
          RJM    FUNC        DROP SYNC OUT
          UJK    MRX
          SPACE  5,20
** NAME-- RDRG
*
** PURPOSE-- READ REGISTER
*
** ENTRY  A = FUNCTION CODE
          SPACE  2
 RDRG10   BSS
          LDN    0
 RDRGX    LJM    **
 RDRG     EQU    *-1
          RJM    FAN         SEND FUNCTION
          AJM    RDRG10,DC   IF NO FUNCTION REPLY
          ACN    DC+40B
          EJM    RDRG10,DC   IF WORD COULD NOT BE READ
          IAN    DC
          UJN    RDRGX
          SPACE  5,20
** NAME--RI
*
** PURPOSE-- REQUEST INTERRUPTS FROM THE CONTROLLER
*
** EXIT
*         STATUS - CONTAINS BIT SIGNIFICANT ADDRESS OF CONTROLLER WITH INTERRUPT
          SPACE  2
 RIX      LJM    **
 RI       EQU    *-1
          RJM    PPRQ        CHECK FOR IDLE REQUEST
          LDC    H0715       REQUEST CLASS 1, 2, OR 3 INTERRUPT
          RJM    FUNC        BUS A, MASTER OUT
          PAUSE  20          DELAY
          ACN    DC
          EJM    RI5,DC      IF ERROR
          IAN    DC
          STDL   STATUS      SAVE BIT SIGNIFICANT ADDRESS
          LDC    H0711
          RJM    FUNC        DROP MASTER OUT
          CFM    RIX,DC      IF ERROR FLAG NOT SET
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 RI5      BSS
          LDN    E02         CHANNEL EMPTY WHEN ACTIVATED
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- RPT
*
** PURPOSE-- RESPONSE PACKET TRANSFER
*
** EXIT
*         RPB - STARTING LOCATION OF RESPONSE PACKET
*         (A) = 0
          SPACE  2
 RPT20    BSS
          STDL   WC          SAVE WORDS NOT TRANSFERRED
 RPT30    BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          IFEQ   TB,1
          LCN    0
          STDL   Z1+2        INDICATE RESPONSE
          LDML   RPB+OPCD
          STDL   Z1+3        OP CODE
          LDML   RPB+SLAD
          STDL   Z1+4        ADDRESS
          LDDL   CLSEC
          STDL   Z1+5        CLOCK
          RJM    UT          UPDATE TRACE
          LDML   /SS/P.TOTAL,CSST
          STDL   Z1+2        SECTORS LEFT TO TRANSFER
          LDML   RPB+MAJST
          STDL   Z1+3        MAJOR STATUS
          LDML   /SS/P.XFER,CSST
          SHN    4
          STDL   Z1+4
          LDML   /SS/P.XFER+1,CSST
          SHN    -12
          RADL   Z1+4        SECTORS TRANSFERRED
          LDML   RPB+CRN
          STDL   Z1+5        COMMAND REFERENCE NUMBER
          RJM    UT          UPDATE TRACE
          ENDIF
          LDDL   WC
          ZJN    RPTX        IF ALL WORDS TRANSFERRED
          LDN    E29         INCOMPLETE TRANSFER
          RJM    EP          ERROR PROCESSING (NO RETURN)
 RPTX     LJM    **
 RPT      EQU    *-1
          LDN    RSPIN       BUS A FOR RESPONSE
          RJM    BCS         BUS CONTROL SEQUENCE
          LDDL   MFID        MASK FOR INTERLOCK DATA
          LPC    0#200
          LMC    H0281       STREAM, READ
          RJM    FUNC        SET MASTER OUT
          ACN    DC
          LDN    5
          IAM    RPB,DC      INPUT REQUIRED WORDS
 RPT2     BSS
          NJK    RPT20       IF NOT ALL WORDS RECEIVED
          STDL   TBC         DO NOT EXPECT 01 ENDING STATUS
          LDML   RPB         BYTE COUNT MINUS 2
          ADN    3
          SHN    -1
          SBN    5
          ZJN    RPT4        IF ALL WORDS TRANSFERRED
          LPN    77B         PROTECT AGAINST ILLEGAL RESPONSE LENGTH
          IAM    RPB+5,DC    INPUT REMAINING WORDS
          NJN    RPT2        IF NOT ALL WORDS TRANSFERRED
 RPT4     BSS
          STDL   WC          WORDS NOT TRANSFERRED
          LDC    MS50
 RPT8     BSS
          IJM    RPT30,DC    IF SLAVE IN DROPPED
          SBN    1
          NJN    RPT8        IF TIMEOUT NOT EXPIRED
          RJM    CSI         CHECK SLAVE IN
          LJM    RPT30
          SPACE  5,20
** NAME-- SEL
*
** PURPOSE-- SELECT THE CONTROLLER AND VERIFY THE BIT SIGNIFICANT
*            RESPONSE
*
** ENTRY
*         CMOD - CONTROLLER NUMBER
*         CTM - CHANGE TRANSFER MODE IF BIT 3 SET
*
** EXIT   A = 0 IF NO ERROR
          SPACE  2
 SELX     LJM    **
 SEL      EQU    *-1
          LDDL   CMOD
          SHN    12
          ADDL   CTM         CHANGE TRANSFR MODE MODIFIER
          ADN    H0029
          RJM    FUNC        SET SELECT OUT
          ACN    DC
          LDN    77B
 SEL4     BSS
          FJM    SEL8,DC     IF SLAVE IN
          SBN    1
          NJN    SEL4        IF TIMEOUT NOT EXPIRED
          LDN    E20         CAN'T SELECT CONTROLLER
          UJN    SEL15
 SEL8     BSS
          IAN    DC
          STDL   STATUS      SAVE BIT SIGNIFICANT RESPONSE
          LPC    377B
          LMML   SELT,CMOD
          ZJK    SELX        IF BIT SIGNIFICANT RESPONSE CORRECT
          LDN    E21         BIT SIGNIFICANT RESPONSE WRONG
 SEL15    BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
 SELT     BSS
          DATA   1,2,4,8
          DATA   16,32,64,128
          SPACE  2,6
 CONCH    BSS                DISK CHANNEL REFERENCES
 TDC+40B  HERE
 T40B+DC  HERE
 TDC      HERE
          CON    0           END OF TABLE
          TITLE  INITIALIZATION
** NAME-- IT
*
** PURPOSE-- INITIALIZE TABLES
*
** ENTRY  CM.PIT = CM BYTE ADDRESS OF THE PP INTERFACE TABLE.
          SPACE  2
 ITX      LJM    **
 IT       EQU    *-1
          LDK    EOM-CP      LENGTH OF BUFFERS
          STDL   T1
 IT10     BSS
          LDN    0
          STML   CP-1,T1     ZERO OUT BUFFERS
          SODL   T1
          NJN    IT10
          STDL   UX          INITIALIZE DIRECT CELLS
          STDL   LUX
          STDL   MALET
          STDL   P4
          STDL   P5
          STDL   P6
          STDL   T7
          STDL   CMOD
          STDL   PTF         PATH TEST FLAG
          LDN    C.PIT
          STDL   WD
          LOADC  CM.PIT      LOAD CM ADDRESS OF PP INTERFACE TABLE
          CRML   IPIT,WD     READ PP INTERFACE TABLE
          LDML   IPIT+/PIT/P.PPNO  GET LOGICAL PP NUMBER
          STDL   LPN
          REFAD  IPIT+/PIT/P.RSBUF,CM.RS  REFORMAT CM ADDRESS OF RESPONSE
                                          BUFFER AND SAVE IN CM.RS
          LDML   IPIT+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STDL   LIM
          REFAD  IPIT+/PIT/P.INT,CM.INT  REFORMAT CM ADDRESS OF INTERRUPT
                                         WORD AND SAVE IN CM.INT
          REFAD  IPIT+/PIT/P.CHAN,CM.CHAN  REFORMAT CM ADDRESS OF
                                           CHANNEL TABLE AND SAVE IN CM.CHAN
          REFAD  IPIT+/PIT/P.CBUF,CM.CB  REFORMAT ADDRESS OF COMMUNICATION
                                         BUFFER AND SAVE IN CM.CB
          LDN    /CB/C.BUF
          RAML   CM.CB+1     DISPLACEMENT TO READ/WRITE BUFFER
          IFEQ   TB,1
          ADC    0#200
          STDL   Z1+1
          ENDIF
          LDML   IPIT+/PIT/P.CBUFL  GET LENGTH OF COMMUNICATION BUFFER
          ADC    -P.CB*2
          PJN    IT20        IF COMMUNICATIONS BUFFER LONG ENOUGH
          LDC    E20B
          RJM    INTERR      REPORT ERROR (NO RETURN)

*         INITIALIZE UNITS AND SS TABLES.  THE TABLES WILL BE IN ASCENDING ORDER
*         BY CONTROLLER NUMBER.  FOR EACH CONTROLLER TABLES WILL BE IN ASCENDING
*         ORDER FOR ITS DRIVES.

 IT20     BSS
          LDML   IPIT+/PIT/P.UNITC  NUMBER OF UNIT DESCRIPTIORS
          SHN    1
          STDL   T8          LENGTH OF UNIT DESCRIPTOR (CM WORDS)
          ZJK    IT90        IF NO UNIT DESCRIPTORS
 IT30     BSS
          LDN    C.UD        READ 2 CM WORDS
          STDL   WD
          LOADC  CM.PIT
          ADN    C.PIT
          ADDL   P6          INDEX TO UNIT DESCRIPTORS
          CRML   IBUF,WD     READ UNIT DESCRIPTOR
          LDML   IBUF+/UD/P.UQT  RMA = 0 IF NULL ENTRY
          ADML   IBUF+/UD/P.UQT+1
          ZJK    IT70        IF NULL ENTRY
          LDML   IBUF+/UD/P.CNTRLR
          LPN    7
          LMDL   CMOD
          NJK    IT70        IF DIFFERENT CONTROLLER
          LDML   IBUF+/UD/P.UNIT
          LPN    37B
          LMDL   T7
          NJK    IT70        IF DIFFERENT DRIVE
          LDDL   P5
          ADC    -UNUM
          NJN    IT40        IF 64 OR LESS UNITS
          LDC    E208        TOO MANY CONFIGURED UNITS
          RJM    INTERR      REPORT ERROR (NO RETURN)
 IT40     BSS
          LDN    C.UIT
          STDL   WD
          LOADF  IBUF+/UD/P.UQT  REFORMAT RMA OF UNIT INTERFACE TABLE
                                 AND SAVE IN UNITS TABLE
          STML   UNITS+/UN/P.UIT+1,UX
          CRML   UBUF,WD     READ UNIT INTERFACE TABLE
          LDML   IBUF+/UD/P.UQT
          STML   UNITS+/UN/P.UIT,UX
          LDML   UBUF+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJK    IT70        IF UNIT DISABLED
          LDML   UBUF+/UIT/P.UTYPE  CHECK DEVICE TYPE
          LPN    77B
          SBN    9
          MJN    IT50        IF INVALID UNIT TYPE
          SBN    17
          MJN    IT60        IF VALID UNIT TYPE
 IT50     BSS
          LDC    E306        INVALID UNIT TYPE
          RJM    INTERR      REPORT ERROR (NO RETURN)
 IT60     BSS
          ADN    17
          SHN    4
          STML   SS+/SS/P.DT,P4  DEVICE TYPE
          LDML   IBUF+/UD/P.CHAN  GET CHANNEL FROM UNIT DESCRIPTOR
          SHN    -8
          STDL   CHAN        CHANNEL NUMBER
          LDDL   CMOD
          SHN    8
          ADDL   T7
          STML   SS+/SS/P.UNIT,P4  PUT CONTROLLER, UNIT NUMBER IN SS TABLE
          LDDL   CMOD
          SHN    5
          ADDL   T7
          STML   UNITS,UX    PUT CONTROLLER, UNIT NUMBER IN UNITS TABLE
          LDML   IBUF+/UD/P.LU  PUT LOGICAL UNIT IN SS TABLE
          STML   SS+/SS/P.LU,P4
          LDC    SS
          ADDL   P4
          STML   UNITS+/UN/P.SSPTR,UX  POINTER FROM UNITS TABLE TO SS TABLE
          LDC    P.SS
          RADL   P4          INCREMENT TO NEXT RESIDENT SS TABLE
          AODL   P5          NUMBER OF CONFIGURED UNITS
          LDN    P.UN
          RADL   UX          BUMP CONFIGURED UNIT INDEX
          UJN    IT80
 IT70     BSS
          LDN    C.UD
          RADL   P6          NEXT UNIT DESCRIPTOR ENTRY
          SBDL   T8
          NJK    IT30        IF MORE UNIT DESCRIPTORS
 IT80     BSS
          LDN    0
          STDL   P6          INDEX TO UNIT DESCRIPTORS
          AODL   T7          INCREMENT DRIVE NUMBER
          SBN    32
          MJK    IT30        IF LEGAL UNIT NUMBER
          STDL   T7
          AODL   CMOD        INCREMENT CONTROLLER NUMBER
          SBN    8
          MJK    IT30        IF LEGAL CONTROLLER NUMBER
 IT90     BSS
          LDDL   UX
          STDL   UNUML       END OF ACTIVE UNIT TABLE
          RJM    CHGCH       SET CHANNEL INSTRUCTIONS
          LJM    ITX
          SPACE  5,20
 CP       BSS    0           COMMAND PACKET FOR CONTROLLER
 CPL      EQU    48          MAXIMUM COMMAND PACKET LENGTH

*         THE FOLLOWING TABLE OF VALUES IS NEEDED TO SUPPORT ALTERNATE
*         ACCESS TO THE DRIVES.

 PSB      EQU    CP+CPL      PATH STRINGS BUSY.  INCREMENTED WHEN UPSB GOES
                              FROM 0 TO 1.  DECREMENTED WHEN UPSB GOES FROM 1
                              TO 0.
 APSB     EQU    PSB+1       ALTERNATE PATH STRINGS BUSY.  INCREMENTED WHEN
                              UPASB GOES FROM 0 TO 1.  DECREMENTED WHEN UPASB
                              GOES FROM 1 TO 0.
 UPSB     EQU    APSB+1      UNITS PER STRING BUSY.  INCREMENTED WHEN THE FIRST
                              SEEK TO A UNIT IS ISSUED.  DECREMENTED WHEN ALL
                              COMMANDS FOR A UNIT HAVE COMPLETED.
                                 WORD 0  CONTROLLER 0  STRING 0
                                      1             0         1
                                      2             0         2
                                      3             0         3
                                      4             1         0
                                      5             1         1
                                      .             .         .
                                      .             .         .
                                      .             .         .
                                     31             7         3
 UPSBL    EQU    32          UPSB TABLE LENGTH
 UPASB    EQU    UPSB+UPSBL  UNITS PER ALTERNATE STRING BUSY.  INCREMENTED IF
                              LOCAL TABLE SAYS NO SEEK ISSUED AND ALGORITHM
                              DETERMINES ALTERNATE PP SHOULD OR HAS ISSUED THE
                              SEEK.  DECREMENTED IF LOCAL TABLE SAYS ALTERNATE
                              PATH ISSUED SEEK AND UNIT NOT LOCKED.
 UPASBL   EQU    32          UPASB TABLE LENGTH

 FBUF     EQU    UPASB+UPASBL  FUNCTION HISTORY BUFFER
 FBUFL    EQU    16          LENGTH OF FUNCTION BUFFER

 UNUM     EQU    64          SUPPORT 64 UNITS
 UNITS    EQU    FBUF+FBUFL  START OF UNITS TABLE
 UNITSL   EQU    UNUM*P.UN   LENGTH OF UNITS TABLE
 SS       EQU    UNITS+UNITSL  INFORMATION SAVED IN UNIT COMMUNICATION BUFFER
 NSS      EQU    RS-SS
 NSST     EQU    NSS/P.SS    NUMBER OF SS TABLES
          ERRMI  NSST-64     IF NO ROOM FOR SS TABLES

*         THE LAST CARD OF THE DECK MUST BE /EOR SO THAT COMS CAN
*         ASSEMBLE MULTIPLE DECKS.

          END
/EOR
*DECK DECK=IOM$E9P5831 EXPAND=TRUE
          IDENT  E9P5831
          CIPPU
          MEMSEL 8
          TITLE  E9P5831 NOS/VE 5830 DISK DRIVER FOR I4
*
*         WORD 6 OF THE FOLLOWING COMMENT MUST BE THE REVISION NUMBER FOR CTI
*
          COMMENT *SMD* LVL=02
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 PRGNAM   MICRO  1,4,'F830'  1ST 4 CHARACTERS OF OVERLAY NAME
*
*         THIS IS THE PP DRIVER FOR THE 10 AND 25 MB/S CHANNELS THAT SUPPORT
*         THE 5830 DISK SUBSYSTEM WITH AN I4 IOU.  THE DRIVER SUPPORTS THE
*         FOLLOWING LOGICAL UNITS, 5832_1, 5832_2, 5833_1, 5833_1P, 5833_2,
*         5833_3P, 5833_4, 5838_1, 5838_1P, 5838_2, 5838_3P, 5838_4, 47444_1,
*         47444_1P, 47444_2, 47444_3P, AND 47444_4.
*         THE PROGRAM NAME IS E9P5831 AND THE DECK NAME IS IOM$E9P5831. WHEN
*         THE PP DRIVER IS  LOADED, LOCATIONS 72 AND 73 MUST CONTAIN THE RMA
*         OF THE PP INTERFACE TABLE AND LOCATION 0 MUST BE THE ADDRESS, MINUS
*         ONE, AT WHICH EXECUTION IS TO BEGIN.
*
          LIST   -$
*COPYC IODMAC1
*COPYC IODMAC2
*COPYC IODMAC3
*COPYC IODMAC4
*COPYC IODMAC5
          LIST   B,L,N,R
          EJECT
*
*         EQUATES FOR IPI ADAPTER
*
 H0000    EQU    0#0000      MASTER CLEAR ADAPTER
 H0009    EQU    0#0009      SET SELECT OUT
 H0029    EQU    0#0029      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H005B    EQU    0#005B      SET SYNC OUT
 H0071    EQU    0#0071      FULL WHEN SLAVE IN IS 0
 H00E1    EQU    0#00E1      READ STATUS REGISTER
 H00F1    EQU    0#00F1      READ ERROR REGISTER
 H0100    EQU    0#0100      CLEAR DMA ERROR
 H0102    EQU    0#0102      READ IPI REVISION REGISTER
 H0122    EQU    0#0122      IPI BUS A OUTPUT PARITY ERROR
 H200     EQU    0#0200      READ CONTROL REGISTER/READ ATTRIBUTES
 H0281    EQU    0#0281      STREAM, READ
 H0300    EQU    0#0300      WRITE CONTROL REGISTER
 H0302    EQU    0#0302      WRITE TRANSMITTER RECEIVER REGISTER
 H0322    EQU    0#0322      IPI BUS A INPUT PARITY ERROR
 H0381    EQU    0#0381      STREAM, WRITE
 H0600    EQU    0#0600      READ DMA ERROR REGISTER
 H0700    EQU    0#0700      READ OPERATIONAL STATUS
 H0711    EQU    0#0711      DROP MASTER OUT
 H0715    EQU    0#0715      REQUEST CLASS 1, 2, OR 3 INTERRUPT
 H0800    EQU    0#0800      DMA TERMINATE/ABORT COMMAND
 H0900    EQU    0#0900      DMA NEW BURST TRANSFER
 H0A00    EQU    0#0A00      READ T REGISTER
 H0B00    EQU    0#0B00      WRITE T PRIME REGISTER
 H0C00    EQU    0#0C00      DMA READ
 H0C22    EQU    0#0C22      ICI OUTPUT PARITY ERROR
 H0D00    EQU    0#0D00      DMA WRITE
 H8025    EQU    0#8025      MASTER OUT, FULL WHEN SLAVE IN IS 1
 H8039    EQU    0#8039      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H8215    EQU    0#8215      SET MASTER OUT, LOGICAL INTERFACE RESET
 H8415    EQU    0#8415      SET MASTER OUT, SLAVE RESET
 H9211    EQU    0#9211      DROP SYNC OUT
 H9213    EQU    0#9213      SET SYNC OUT
*
*         MISCELLANEOUS EQUATES
*
 FE       EQU    0           = 1, TO ENABLE FORCE ERROR CODE
 DC       EQU    22B         DISK CHANNEL
 DRNUM    EQU    0#FE        INITIALIZE VALUE FOR OFF-LINE DRIVE NUMBER (OFFLD)
 C.CHCNT  EQU    100         NUMBER OF REQUESTS TO PROCESS IF BUSY BEFORE
                              GIVING UP THE CHANNEL
 MS50     EQU    53475       50 MILLISECOND TIMEOUT FOR CERTAIN LOOPS
 RRL      EQU    3           REQUEST RETRY LIMIT
 SRT      EQU    720         SLAVE RESET TIMEOUT (SECONDS)
 FPT      EQU    600         FORMAT PACK TIMEOUT (SECONDS)
 CMT      EQU    32          COMMAND TIMEOUT (SECONDS)
 RLIE     EQU    26*8        RESPONSE LENGTH IF ERROR
 RPL      EQU    0#10        READ, WRITE COMMAND PACKET LENGTH
 H0041    EQU    0#0041      READ BUS B AND STATUS
 H0200    EQU    0#0200      REPORT ATTRIBUTES OPERATION CODE
 H0202    EQU    0#0202      RESTORE ATTRIBUTES OPERATION CODE
 H0209    EQU    0#0209      LOAD ATTRIBUTES OPERATION CODE
 H020A    EQU    0#020A      SAVE ATTRIBUTES OPERATION CODE
 H0700    EQU    0#0700      SET OPERATING MODE
 H1005    EQU    0#1005      READ OPERATION CODE
 H2005    EQU    0#2005      WRITE OPERATION CODE
 H5200    EQU    0#5200      WRITE TO BUFFER OPERATION CODE
 H6200    EQU    0#6200      READ FROM BUFFER OPERATION CODE
 H8100    EQU    0#8100      PERFORM DRIVE DIAGNOSTICS OP CODE
 H8101    EQU    0#8101      PERFORM DRIVE HEAD SHIFT TEST OP CODE
 H8400    EQU    0#8400      READ PERFORMANCE LOG OP CODE
 H0931    EQU    0#0931      COMMAND EXTENT PARAMETER
 ID12     EQU    0#12        DEFECT MANAGEMENT
 ID13     EQU    0#13        MESSAGE/MICROCODE EXCEPTION
 ID14     EQU    0#14        INTERVENTION REQUIRED FOR CONTROLLER
 ID15     EQU    0#15        ALTERNATE PORT EXCEPTION
 ID16     EQU    0#16        MACHINE EXCEPTION FOR CONTROLLER
 ID17     EQU    0#17        COMMAND EXCEPTION FOR CONTROLLER
 ID22     EQU    0#22        DEFECT MANAGEMENT
 ID23     EQU    0#23        DRIVE MESSAGE EXCEPTION
 ID24     EQU    0#24        INTERVENTION REQUIRED STATUS
 ID25     EQU    0#25        DRIVE ALTERNATE PORT EXCEPTION
 ID26     EQU    0#26        MACHINE EXCEPTION FOR DRIVE
 ID29     EQU    0#29        DRIVE CONDITIONAL SUCCESS
 ID32     EQU    0#32        FAILING ADDRESS
 ID6D     EQU    0#6D        HAS TRANSFER LENGTH

*         COMMAND/RESPONSE PACKET EQUATES

 CRN      EQU    1           COMMAND REFERENCE NUMBER
 OPCD     EQU    2           OPERATION CODE FOR CONTROLLER
 SLAD     EQU    3           SLAVE ADDRESS, UNIT ADDRESS
 MAJST    EQU    4           MAJOR STATUS
 FCP      EQU    4           FIRST COMMAND PARAMETER

*         MAJOR STATUS EQUATES

 CC       EQU    1           COMMAND COMPLETE RESPONSE
 AR       EQU    4           ASYNCHRONOUS RESPONSE
 TN       EQU    5           TRANSFER NOTIFICATION
 CCS      EQU    0#18        COMMAND COMPLETE, SUCCESSFUL

*         LEFT SHIFTS FOR MAJOR STATUS

 CS       EQU    16          CONDITIONAL SUCCESS
          SPACE  5,20
*         BUS CONTROL EQUATES

 CMDOUT   EQU    0           COMMAND, INFORMATION OUT
 RSPIN    EQU    1           RESPONSE, INFORMATION IN
 DATAOUT  EQU    2           DATA OUT
 DATAIN   EQU    3           DATA IN
          SPACE  5,20
*         IOU/CONTROLLER/DRIVE ERROR CODES

 E00      EQU    0           CP MUST DETERMINE ERROR CODE
 E01      EQU    1           FUNCTION TIMEOUT
 E02      EQU    2           CHANNEL EMPTY WHEN ACTIVATED
 E03      EQU    3           PERIOD COUNTER PARITY
 E04      EQU    4           PP-IPI PARITY ERROR
 E06      EQU    6           IOU ERROR
 E07      EQU    7           INCOMPLETE I4 TRANSFER
 E08      EQU    8           CHANNEL NOT EMPTY
 E09      EQU    9           CENTRAL MEMORY ERROR
 E10      EQU    10          INVALID CM RESPONSE CODE
 E11      EQU    11          CM RESPONSE CODE PARITY ERROR
 E12      EQU    12          CMI READ DATA PARITY ERROR
 E13      EQU    13          Y DATA ERROR
 E14      EQU    14          BAS PARITY ERROR
 E15      EQU    15          Z ERROR
 E16      EQU    16          Y ERROR
 E17      EQU    17          X ERROR
 E18      EQU    18          DMA TEST MODE FAILURE
 E19      EQU    19          DMA COUNT OVERFLOW
 E20      EQU    20          CANT SELECT CONTROLLER
 E21      EQU    21          BIT SIGNIFICANT RESPONSE ERROR
 E22      EQU    22          NO SYNC IN
 E23      EQU    23          SYNC IN DID NOT DROP
 E24      EQU    24          IPI SEQUENCE ERROR
 E25      EQU    25          IPI CHANNEL PARITY ERROR
 E27      EQU    27          SLAVE IN NOT SET
 E28      EQU    28          SLAVE IN DID NOT DROP
 E29      EQU    29          INCOMPLETE TRANSFER
 E30      EQU    30          CHANNEL STAYED ACTIVE
 E31      EQU    31          BUFFER COUNTER PARITY
 E32      EQU    32          SYNC COUNTER PARITY
 E33      EQU    33          LOST DATA
 E34      EQU    34          BUS PARITY
 E35      EQU    35          COMMAND REJECT
 E36      EQU    36          SYNC OUT NOT EQUAL SYNC INS
 E37      EQU    37          BUS B ACKNOWLEDGE INCORRECT
 E38      EQU    38          NO CONTROLLER RESPONSE
 E39      EQU    39          ENDING STATUS WRONG
 E50      EQU    50          EXECUTING CONTROLLER DIAGNOSTICS
 E51      EQU    51          CONTROLLER DIAGNOSTICS PASSED
 E52      EQU    52          CONTROLLER DIAGNOSTICS PASSES, LAST ERROR CODE RETURNED
 E54      EQU    54          DRIVE ALTERNATE PORT EVENT
 E55      EQU    55          RESTORING DRIVE
 E56      EQU    56          DRIVE RESTORATION COMPLETE
 E57      EQU    57          FORMATTING DRIVE
 E58      EQU    58          FORMAT COMPLETE
 E59      EQU    59          PARITY PROTECTION DISABLED
 E61      EQU    61          DRIVE FAILURE
 E62      EQU    62          MEDIA FAILURE
 E70      EQU    70          LRC ERROR ON READ
 E71      EQU    71          CONTROLLER INTERVENTION REQUIRED
 E72      EQU    72          CONTROLLER MACHINE EXCEPTION
 E73      EQU    73          COMMAND EXCEPTION
 E74      EQU    74          MICROCODE EXECUTION ERROR
 E75      EQU    75          CONTROLLER ALTERNATE PORT EVENT (MAPPED TO 53 BY CP CODE)
 E76      EQU    76          UNEXPECTED RESPONSE
 E78      EQU    78          CONTROLLER OVER TEMPERATURE
 E96      EQU    96          DRIVE HEAD SHIFT ERROR
 E110     EQU    110         PP-CONTROLLER DATA INTEGRITY
 E111     EQU    111         CM-DRIVE DATA INTERGRITY
 E120     EQU    120         SOFTWARE FAILURE
 E130     EQU    130         DEFECT MANAGEMENT TASK FAILED
 E140     EQU    140         XXXX CONFIGURED - YYYY FOUND
 E141     EQU    141         DRIVE INITIALIZATION REQUIRED
 E142     EQU    142         CONTROLLER DOES NOT SUPPORT PARALLEL
          SPACE  5,20
*         INTERFACE ERROR CODES.

 E208     EQU    1010B       LOGICAL UNIT OF UNIT DESCRIPTOR NOT
                             IN SEQUENCE OR NOT IN RANGE
 E20B     EQU    1013B       COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS OR NOT LONG ENOUGH
 E304     EQU    1404B       RMA OF NEXT UNIT REQUEST
                             NOT A WORD BOUNDARY
 E306     EQU    1406B       INVALID UNIT TYPE
 E308     EQU    1410B       UNIT COMMUNICATION BUFFER IS TOO SMALL
 E501     EQU    2401B       INVALID COMMAND CODE
 E505     EQU    2405B       INVALID LENGTH SPECIFICATION IN COMMAND
          EJECT
*         CONFIGURED UNITS.

 UN       RECORD PACKED

*         WORD 1

 CIP      BOOLEAN            AT LEAST ONE COMMAND IN PROGRESS
 TCIP     BOOLEAN            TWO COMMANDS IN PROGRESS
 ACIP     BOOLEAN            ALTERNATE COMMAND IN PROGRESS
 NCR      BOOLEAN            NO CONTROLLER RESPONSE
 RIP      BOOLEAN            RESTORE IN PROGRESS
 SSTP     BOOLEAN            SS TABLE POINTER, EQUAL 1 IF INDEX INTO UNIT
                              COMMUNICATIONS BUFFER IS 100(16) BYTES
 PDCE     BOOLEAN            PARITY DRIVE CORRECTION ENABLED
 PORT     BOOLEAN            PORT TO IPI CHANNEL, 0 = PORT A, 1= PORT B
 CM       SUBRANGE 0,7       CONTROLLER NUMBER
 UNIT     SUBRANGE 0,37B     UNIT NUMBER

*         WORD 2

 SSPTR    PPWORD             POINTER TO RESIDENT SS TABLE. IF ZERO
                             THE TABLE IS IN THE UNIT COMM. BUFFER

*         WORD 3

 CLK      PPWORD             SECONDS CLOCK OF LAST ACTIVITY

*         WORD 4

 UIT      STRUCT 6           RMA OF UNIT INTERFACE TABLE (REFORMATTED)
          MASKP  NCR
 K.NCR    EQU    MSK
 UN       RECEND
          SPACE  5,20
*         SS TABLE DEFINITIONS. INFORMATION SAVED FOR EACH UNIT.

 SS       RECORD PACKED

*         IF THE SS TABLE IS NOT PP RESIDENT, IT IS SAVED IN THE UNIT COMMUNICATIONS
*         BUFFER.  THE BIT LABELED SSTP IN THE UNITS TABLE DETERMINES THE INDEX INTO
*         THE BUFFER THAT THE SS TABLED IS STORED.

 LOCK     BOOLEAN            ONLY USED WHEN INITIALLY WRITING THE SS TABLE TO CM
 LPN      SUBRANGE 0,77777B  LOGICAL PP NUMBER

 DOAR     BOOLEAN            DRIVE OPERATIONAL ASYNCH RECEIVED
 FILL1    SUBRANGE 0,377B    UNUSED
 DT       SUBRANGE 0,7       DRIVE TYPE
 CRN      SUBRANGE 0,17B     USED TO MAKE COMMAND REFERENCE NUMBER UNIQUE

 CMOD     SUBRANGE 0,377B    CONTROLLER NUMBER
 UNIT     SUBRANGE 0,377B    UNIT NUMBER

 LU       PPWORD             LOGICAL UNIT
 FNC      PPWORD             FUNCTION CODE  READ = 0
                                            WRITE = 1
 REQ      STRUCT 4           CURRENT REQUEST (UNFORMATTED RMA)
 PVA      STRUCT 6           PVA OF CURRENT REQUEST

 LASTC    PPWORD             OFFSET OF COMMAND IN REQUEST
 FRST     PPWORD             = 0, IF FIRST TIME THROUGH UNCMND
 NUMCM    PPWORD             NUMBER OF COMMANDS LEFT TO PROCESS IN
                             THIS REQUEST
 LISTL    PPWORD             NUMBER OF CM WORDS IN ADDRESS-LENGTH PAIR LIST.
                             (INCLUDES THE NUMBER OF WORDS WHICH HAVE NOT
                             BEEN READ FROM CM.)
 TOTAL    STRUCT 2           TOTAL SECTORS LEFT TO TRANSFER
                              8XXX IF USING MASTER TERMINATE
 FCOMRQ   STRUCT 4           FIRST COMPLETED REQUEST (RMA)
 CURRQ    STRUCT 4           CURRENT REQUEST (RMA)
 PRERQ    STRUCT 4           PREVIOUS REQUEST (RMA)
 NCOMRQ   PPWORD             NUMBER OF COMPLETED REQUESTS
 NCR      PPWORD             NUMBER OF COMPLETED REQUESTS
 CURTRK   PPWORD             CURRENT TRACK
 CURSEC   PPWORD             CURRENT SECTOR
 FPVA     STRUCT 6           PVA OF FIRST COMPLETED REQUEST
 XFER     STRUCT 4           TRANSFER COUNT
 PVA2     STRUCT 6           PVA FOR SECOND COMMAND
 RMA2     STRUCT 4           RMA FOR SECOND COMMAND
 TW2      STRUCT 2           TOTAL CM BYTES TO TRANSFER FOR 2ND COMMAND
 SC       PPWORD             SET NONZERO IF POSSIBLE STATE CHANGE FOR DRIVE
 CRTS     PPWORD             CURRENT TRACK, SECTOR BEING RESTORED
 RQTRY    PPWORD             REQUEST RETRY COUNT
 RESET    PPWORD             RESET ISSUED IF NONZERO
 CT       PPWORD             NONZERO WHEN CONFIDENCE TEST IS COMPLETE
                              1 IF NO ERROR
                              2 IF ERROR
                              4 IF DATA INTEGRITY ERROR
                             40 IF OPERATIONAL ASYNCH RECEIVED FOR PARITY DRIVE
 RECOV    PPWORD             NONZERO IF IN RECOVERY
 DP       STRUCT 6           DELINK POINTER (REFORMATTED RMA)
 MREV     STRUCT 4           CONTROLLER MICROCODE 8-DIGIT PART NUMBER

 RQ       STRUCT 40          REQUEST

 CMLIST   STRUCT 8           CURRENT DATA ADDRESS OR CURRENT COMMAND

 SS       RECEND

*         ALTERNATE USAGE OF LOCATIONS IN SS TABLE DURING CONFIDENCE TEST

 CTME     EQU    /SS/P.PVA2  START OF 3 WORD TABLE WITH EACH WORD
                              CONTAINING THE HEAD AND SECTOR NUMBER OF
                              OF A MEDIA ERROR
 CRC      EQU    /SS/P.RMA2  CURRENT CYLINDER BEING RESTORED
 RTM      EQU    /SS/P.RMA2+1  REQUESTS TO MULTIPLEX PER CYLINDER DURING RESTORE
 ODN      EQU    /SS/P.TW2   OFF LINED DRIVE NUMBER
          SPACE  5,20
*         PP INTERFACE TABLE

 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
 ACTCH    BOOLEAN            ACTIVE CHECK, THE PP CLEARS THIS BIT WITHIN 1 MINUTE
 IDLREQ   BOOLEAN            IDLE REQUEST
 RESREQ   BOOLEAN            RESUME REQUEST
 PPIDLE   BOOLEAN            PP IDLE
          SUBRANGE 0,3777B   UNUSED
 LOCK     BOOLEAN            PP TABLE LOCK
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
          STRUCT 24          UNUSED
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          SPACE  5,20
*         UNIT DESCRIPTORS.

 UD       RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 UD       RECEND
          SPACE  5,20
*         UNIT INTERFACE TABLE

 UIT      RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
 FRCFMT   BOOLEAN            FORCE FORMAT FLAG
 PARPRO   BOOLEAN            PARITY PROTECTION STATUS
                               0 = PROTECTION DISABLED
                               1 = PROTECTION ENABLED
 RESTDR   BOOLEAN            RESTORING DRIVE FLAG
                               O = NOT RESTORING
                               1 = RESTORING DRIVE
 FILL1    SUBRANGE 0,17B
 OFFLD    SUBRANGE 0,377B     OFF-LINE DRIVE NUMBER

          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
                               = 400B, 844-4X   = 411B, 5832_1   = 422B, 5838_2
                               = 401B, 885-1X   = 412B, 5832_2   = 423B, 5838_3P
                               = 402B, 885-42   = 413B, 5833_1   = 424B, 5838_4
                               = 403B, 834      = 414B, 5833_1P  = 425B, 47444_1
                               = 404B, 836      = 415B, 5833_2   = 426B, 47444_1P
                               = 405B, 895      = 416B, 5833_3P  = 427B, 47444_2
                               = 406B, 887      = 417B, 5833_4   = 430B, 47444_3P
                               = 407B, 9836     = 420B, 5838_1   = 431B, 47444_4
                               = 410B, 9853     = 421B, 5838_1P
 QCNT     PPWORD             QUEUE COUNT
 SHARE    BOOLEAN            NONZERO IF THIS UNIT IS BEING SHARED WITH MALET OR DFT
          ALIGN  16,64
 UBUFL    PPWORD             UNIT COMMUNICATION BUFFER LENGTH
 UBUF     RMA                UNIT COMMUNICATION BUFFER (RMA)
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

          MASKP  DSABLE
 K.DSABLE EQU    MSK
          MASKP  FRCFMT
 K.FRCFMT EQU    MSK
          MASKP  PARPRO
 K.PARPRO EQU    MSK
          MASKP  RESTDR
 K.RESTDR EQU    MSK
          MASKP  OFFLD
 K.OFFLD  EQU    MSK

 K.PBITS  EQU    K.PARPRO+K.RESTDR+K.OFFLD

 UIT      RECEND
          SPACE  5,20
*         PP REQUESTS.

 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (NOT USED)
                               0 - ATTEMPT RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY (NOT USED)
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
          ALIGN  0,64
 SWIT     BOOLEAN            SWITCH TO NEXT REQUEST
          ALIGN  16,64
 CYL      PPWORD             CYLINDER ADDRESS
 TRACK    PPWORD             TRACK ADDRESS
 SECTOR   PPWORD             SECTOR ADDRESS
 CMND     INTEGER            COMMAND SEQUENCE

          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$

 RQ       RECEND
          SPACE  5,20
*         COMMAND PART OF REQUEST

 CM       RECORD PACKED

 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                              LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$
          SPACE  5,20
*         PP RESPONSE.

 RS       RECORD PACKED

*         WORD 1.

 FILL1    BOOLEAN
 SHORT    BOOLEAN            IF SET, ONE-WORD RESPONSE
          SUBRANGE 0,77B     UNUSED
          SUBRANGE 0,377B    LOGICAL UNIT (FOR DEBUG)
          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST

*         WORD 2.
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST  (NOT USED)

*         WORD 3

 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST) (NOT USED)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)  (NOT USED)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS  (NOT USED)
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY  (NOT USED)
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

*         WORD 4.

          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED  (NOT USED)
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE INTERFACE
                             ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
                             (NOT USED)
 CHERR    BOOLEAN            CHANNEL PARITY ERROR (NOT USED)
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION
                             OCCURRED ON INPUT OR INADEQUATE DATA RATE ON OUTPUT
                             (NOT USED)
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT  (NOT USED)
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A
                             HARDWARE MALFUNCTION.  EXAMPLE-UNIT NOT
                             READY, UNIT NOT CONNECTED.  (NOT USED)
 FTO      BOOLEAN            FUNCTION TIMEOUT (NOT USED)
 CHERO    BOOLEAN            CHANNEL OUTPUT PARITY ERROR (NOT USED)
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
                               1 - RECOVERED ERROR
                               2 - COMMAND HAD EXPLICIT RESPONSE FLAG SET
                               3 - BOTH CONDITIONS 1 AND 2
 K.REC    EQU    1           RECOVERED ERROR
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE  (NOT USED)
                               1 - UNIT CHANGED FROM READY TO NOT READY
                               2 - UNIT CHANGED FROM NOT READY TO READY
                               3 - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
                               4 - CONTROLLER RESERVED
                               5 - UNIT RESERVED TO ANOTHER ACCESS
                               6 - RECOVERED ABNORMAL CONDITION
          ALIGN  49,64       ALERT CONDITIONS
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

*         WORD 5

          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)(NOT USED)

*         WORD 6.

 CHAN     PPWORD             CHANNEL NUMBER
 SCYL     PPWORD             STARTING CYLINDER
 STRK     PPWORD             STARTING TRACK
 SSEC     PPWORD             STARTING SECTOR

*         WORD 7

 UNIT     PPWORD             UNIT NUMBER
 RTRY     PPWORD             REQUEST RETRY COUNT
 FTRK     PPWORD             FAILING TRACK
 FSEC     PPWORD             FAILING SECTOR

*         WORD 8

 WC       PPWORD             WORDS NOT TRANSFERRED
 FUNTO    PPWORD             FUNCTION WITH TIMEOUT
 ID       PPWORD             ERROR IDENTIFIER
 K.PPD    EQU    4           PARITY PROTECTION DISABLED
 K.UDN    EQU    3           UNIT DOWN
 K.CMDN   EQU    2           CONTROLLER DOWN
 K.CHDN   EQU    1           CHANNEL DOWN
 ERRID    PPWORD             ERROR IDENTIFIER

*         WORD 9

 MREVU    PPWORD             CONTROLLER MICROCODE PART NUMBER (UPPER)
 STREG    PPWORD             IPI CHIP STATUS REGISTER
 ERREG    PPWORD             IPI CHIP ERROR REGISTER
 MREVL    PPWORD             CONTROLLER MICROCODE PART NUMBER (LOWER)

*         WORD 10

 DMAER    PPWORD             DMA ERROR REGISTER
 OSR      PPWORD             OPERATIONAL STATUS REGISTER
 CR       PPWORD             CONTROL REGISTER
 ADT      PPWORD             ACTUAL DRIVE TYPE IF ERROR CODE IS 140

          MASKP  INTERR
 K.INTERR EQU    MSK
          MASKP  DATERR
 K.DATERR EQU    MSK
          MASKP  SHORT
 K.SHORT  EQU    MSK

 RS       RECEND


 CM       RECEND
          SPACE  5,20
*         COMMAND CODES.

 C.READ   EQU    100B        READ
 C.WRITE  EQU    120B        WRITE
 C.FORMAT EQU    164B        FORMAT
          SPACE  5,20
*         RESPONSE CODES

 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    1           INTERMEDIATE RESPONSE
 R.ABN    EQU    3           ABNORMAL REQUEST TERMINATION
          SPACE  5,20
*         PP COMMUNICATION BUFFER

 CB       RECORD PACKED

          ALIGN  31,64
 SLAVE    BOOLEAN            NONZERO IF SLAVE PP (NOT USED)
 PARTNR   RMA                PARTNERS COMMUNICATION BUFFER (RMA) (NOT USED)

 CONTRL   STRUCT 8           LOAD CONTROLWARE COMMAND (NOT USED)
 CMCTRL   STRUCT 8           LOAD CONTROLLER CONTROLWARE (NOT USED)
 ODP      STRUCT 8           OVERLAY DIRECTORY
          STRUCT 56
 BUF      STRUCT 11192       DATA BUFFER FOR CONFIDENCE TEST
                              BYTES = SECTOR (8192) + 8 TIMES
                              (SECTORS (25) X TRACKS (15))
 CB       RECEND

*         THE RESPONSE BUFFER MUST BE 32 X 3 + 5 WORDS LONG TO HOLD
*         THE DATA FROM REPORTING ATTRIBUTE 68.

 RPBL     EQU    104         MAXIMUM LENGTH OF RESPONSE BUFFER
 CPL      EQU    48          MAXIMUM COMMAND PACKET LENGTH
 OVST     EQU    15460B      OVERLAY STARTING ADDRESS
 EOM      EQU    20000B
 CP       EQU    OVST-CPL    COMMAND PACKET FOR CONTROLLER
 RPB      EQU    CP-RPBL     RESPONSE PACKET BUFFER
 RS       EQU    RPB-P.RS    DISK RESPONSE

 IPIT     EQU    EOM-200B    PP INTERFACE TABLE
 UBUF     EQU    IPIT+P.PIT  UNIT INTERFACE TABLE
 IBUF     EQU    UBUF+P.UIT  UNIT DESCRIPTOR BUFFER
 NRQ      EQU    IPIT        NEXT REQUEST
 RQT      EQU    NRQ+8
          ERRMI  EOM-IPIT-P.SS  IF TABLE OVERFLOWS MEMORY
          ERRMI  EOM-IBUF-P.UD  IF TABLE OVERFLOWS MEMORY
 OB       EQU    EOM-128     OUTPUT BUFFER FOR PP/CONTROLLER PATH TEST
 IB       EQU    OB+64       INPUT BUFFER FOR PP/CONTROLLER PATH TEST
 IBL      EQU    50          LENGTH OF INPUT BUFFER
          ERRMI  EOM-IB-IBL  IF INPUT BUFFER OVERFLOWS MEMORY
 RQ       EQU    /SS/P.RQ    REQUEST
 CM       EQU    RQ+/RQ/P.CMND  CURRENT COMMAND
 CMLIST   EQU    /SS/P.CMLIST  INDIRECT RMA LIST
          EJECT
          CON    INIT-1

*         DIRECT CELLS

 DH       BSSZ   3           REFORMATTED RMA OF OVERLAY DIRECTORY
 CM.PIT   BSSZ   3           CM ADDRESS OF PP INTERFACE TABLE
                              THE BYTE ADDRESS IS
                               RIGHTMOST 10 BITS OF WORD 0 CONCATENATED WITH
                               RIGHTMOST 12 BITS OF WORD 1 CONCATENATED WITH
                               RIGHTMOST 6 BITS OF WORD 2 CONCATENATED WITH
                               3 BITS OF ZEROS
 T1       BSSZ   1
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1
 T9       BSSZ   1
 SBS      EQU    T9          SECTORS TO TRANSFER BEFORE SUSPENDING

 CMADR    BSSZ   3           CM ADDRESS
 CHAN     BSSZ   1           CHANNEL NUMBER
 STATUS   BSSZ   2           IPI CHANNEL STATUS
 OS       BSSZ   1           OPERATIONAL STATUS
 CMNDS    BSSZ   1           NUMBER OF OUTSTANDING COMMANDS
 CMOD     BSSZ   1           PORT NUMBER AND CONTROLLER NUMBER (0000PCCC)
 UX       BSSZ   1           INDEX TO UNITS TABLE
 P1       BSSZ   1
 P2       BSSZ   1
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 P6       BSSZ   1

*         BC, RMA ARE T REGISTER PARAMETERS

 BC       BSSZ   1           BYTE COUNT TO READ/WRITE
 RMA      BSSZ   2           RMA FOR DMA TRANSFER

 FNC      BSSZ   1           FUNCTION CODE (INTERNAL)
 LF       BSSZ   1           LAST FUNCTION TO IPI ADAPTER
 CNUM     BSSZ   1           0 IF ONE COMMAND, 1 IF 2 COMMANDS ISSUED TO
                              THE CONTROLLER
 WC       BSSZ   1           WORD COUNT
 SECPOS   BSSZ   1           SECTOR BUFFER TRANSFER POSITION (TO CM)
 CSST     BSSZ   1           POINTER TO CURRENT SS TABLE
 LUX      BSSZ   1           VALUE OF UNIT INDEX OF LAST UNIT SELECTED
 TOTAL    BSSZ   1           TOTAL SECTORS TO TRANSFER
 SSUN     CON    7777B       UX VALUE OF CURRENT SS TABLE
 UNUML    BSSZ   1           LENGTH OF CONFIGURED UNIT ENTRIES
 TBC      BSSZ   1           NONZERO IF TRANSFER RESPONSE RECEIVED
                              BEFORE COMPLETION RESPONSE
 MALET    BSSZ   1           NONZERO IF MAINTENANCE SOFTWARE WANTS
                              THE CHANNEL
 CTM      BSSZ   1           USED TO CHANGE TRANSFER MODE TO STREAMING
                             FOR COMMAND AND RESPONSE PACKETS
 CLCUR    BSSZ   1           CHANNEL 14 CLOCK CURRENT VALUE
 CLMCS    BSSZ   1           CLOCK, MICROSECOND
 CLMLS    BSSZ   1           CLOCK, MILLISECOND
 CLSEC    BSSZ   1           CLOCK, SECOND
 DT       BSSZ   1           DRIVE TYPE
 PD       BSSZ   1           PHYSICAL DRIVE
 MFID     BSSZ   1           MASK FOR TRANSFER MODE  0 = STREAM ALL
                                                     1 = INTERLOCK DATA
                                                   200 = INTERLOCK COMMANDS AND RESPONSES
                                                   201 = INTERLOCK ALL
 .F       IFEQ   FE,1
 FEST     DATA   0           FORCE ERROR START COUNT
 FEND     DATA   0           FORCE ERROR END COUNT
 FEUN     DATA   0           UNIT NUMBER TO FORCE ERROR ON
 .F       ENDIF
          SPACE  2
          BSS    72B-*
 DSRTP    DATA   2,0         RMA OF PP INTERFACE TABLE AT DEADSTART
 CH       EQU    DSRTP       0 IF 10 MB/S IPI CHANNEL
                              1 IF 25 MB/S IPI CHANNEL
 INPNT    EQU    DSRTP+1     IN POINTER FOR RESPONSE BUFFER
 LIM      BSSZ   1           LIMIT OF RESPONSE BUFFER (IN 8-BIT BYTES)
 LPN      CON    1           LOGICAL PP NUMBER
 PTF      BSSZ   1           IF 0 EXECUTE PATH TEST
 IF       BSSZ   1           INITIALIZE FLAG, IF NOT 0 EITHER THE CONFIDENCE
                              TEST SHOULD BE RUN OR A UNIT SHOULD BE FORMATTED
          BSS    100B-*
          LJM    INIT
          DATA   10          I4/5830 DRIVER (FOR ANAD PROC)
 HANG     CON    0           AN EASY WAY TO SEE CERTAIN HANGS
          UJN    *
 FPD      DATA   0           FAILING PHYSICAL DRIVE
 STORS    BSS    1           STORE RESPONSE FLAG (USED BY RESPIN)
                               = 0, IF A RESPONSE IS SENT TO CM
                               = NONZERO, IF NO RESPONSE WAS SENT TO CM
 TMF      BSSZ   1           TEST MODE FLAG, NONZERO IF TEST MODE IN PROGRESS
 CLF      DATA   1           CHANNEL LOCK FLAG, 0 IF LOCK IS SET
 CTPAT    DATA   0           CONFIDENCE TEST PATTERN FIRST WORD
 IDLE     DATA   0           NUMBER OF TIMES DRIVER WAS IDLED
 T10      DATA   0
 T11      DATA   0
 T12      DATA   0

*         THIS TABLE CONTAINS LOCATIONS THAT ALLOW THE CODE TO BACK UP AND
*         RETRY A READ TO THE SAME SECTOR AFTER AN UNANTICIPATED PAUSE.

 BAT      BSSZ   6
          SPACE  2
*         THE FOLLOWING CM ADDRESSES ARE SET DURING INITIALIZATION
*         THE BYTE ADDRESS IS
*          RIGHTMOST 10 BITS OF WORD 0 CONCATENATED WITH
*          RIGHTMOST 12 BITS OF WORD 1 CONCATENATED WITH
*          RIGHTMOST 6 BITS OF WORD 2 CONCATENATED WITH
*          3 BITS OF ZEROS

 CM.CB.T  BSSZ   3           ADDRESS OF PP COMMUNICATION BUFFER (T REG. FORMAT)
 CM.CB    BSSZ   3           ADDRESS OF BUFFER WITHIN PP COMMUNICATION BUFFER
 CM.RS    BSSZ   3           ADDRESS OF RESPONSE BUFFER
 CM.INT   BSSZ   3           ADDRESS OF INTERRUPT WORD
 CM.CHAN  BSSZ   3           ADDRESS OF CHANNEL INTERLOCK TABLE

*         LOCATION DT IS THE INDEX TO THIS DRIVE TABLE

*         CONFIDENCE TEST CYLINDER

 CTC      DATA   843         5832_1
          DATA   834         5832_2
          DATA   1628        5833_1
          DATA   1628        5833_1P
          DATA   1628        5833_2
          DATA   1628        5833_3P
          DATA   1628        5833_4
          DATA   2619        5838_1
          DATA   2619        5838_1P
          DATA   2619        5838_2
          DATA   2619        5838_3P
          DATA   2619        5838_4
          DATA   2289        47444_1
          DATA   2289        47444_1P
          DATA   2289        47444_2
          DATA   2289        47444_3P
          DATA   2289        47444_4
 DTS      EQU    *-CTC       DRIVE TYPES SUPPORTED

*         TRACKS PER CYLINDER

 TPC      DATA   4           5832_1
          DATA   4           5832_2
          DATA   7           5833_1
          DATA   7           5833_1P
          DATA   7           5833_2
          DATA   7           5833_3P
          DATA   7           5833_4
          DATA   9           5838_1
          DATA   9           5838_1P
          DATA   9           5838_2
          DATA   9           5838_3P
          DATA   9           5838_4
          DATA   15          47444_1
          DATA   15          47444_1P
          DATA   15          47444_2
          DATA   15          47444_3P
          DATA   15          47444_4

*         SECTORS PER TRACK

 SPT      DATA   12          5832_1
          DATA   24          5832_2
          DATA   22          5833_1
          DATA   22          5833_1P
          DATA   42          5833_2
          DATA   33          5833_3P
          DATA   42          5833_4
          DATA   18          5838_1
          DATA   18          5838_1P
          DATA   35          5838_2
          DATA   27          5838_3P
          DATA   35          5838_4
          DATA   13          47444_1
          DATA   13          47444_1P
          DATA   25          47444_2
          DATA   19          47444_3P
          DATA   25          47444_4

*         SECTORS PER CYLINDER

 SPC      CON    12*4        5832_1
          CON    24*4        5832_2
          CON    22*7-2      5833_1
          CON    22*7-2      5833_1P
          CON    42*7-2      5833_2
          CON    33*7-2      5833_3P
          CON    42*7-2      5833_4
          CON    18*9-4      5838_1
          CON    18*9-4      5838_1P
          CON    35*9-4      5838_2
          CON    27*9-4      5838_3P
          CON    35*9-4      5838_4
          CON    13*15-7     47444_1
          CON    13*15-7     47444_1P
          CON    25*15-7     47444_2
          CON    19*15-7     47444_3P
          CON    25*15-7     47444_4

*         BYTES PER SECTOR

 BPS      CON    4096        5832_1
          CON    4096        5832_2
          CON    4096        5833_1
          CON    4096        5833_1P
          CON    4096        5833_2
          CON    8192        5833_3P
          CON    8192        5833_4
          CON    4096        5838_1
          CON    4096        5838_1P
          CON    4096        5838_2
          CON    8192        5838_3P
          CON    8192        5838_4
          CON    4096        47444_1
          CON    4096        47444_1P
          CON    4096        47444_2
          CON    8192        47444_3P
          CON    8192        47444_4

*         DATA DRIVES PER LOGICAL UNIT

 DD       DATA   1           5832_1
          DATA   2           5833_2
          DATA   1           5833_1
          DATA   1           5833_1P
          DATA   2           5833_2
          DATA   3           5833_3P
          DATA   4           5833_4
          DATA   1           5838_1
          DATA   1           5838_1P
          DATA   2           5838_2
          DATA   3           5838_3P
          DATA   4           5838_4
          DATA   1           47444_1
          DATA   1           47444_1P
          DATA   2           47444_2
          DATA   3           47444_3P
          DATA   4           47444_4

*         SPARE SECTORS PER CYLINDER

 SSPC     DATA   0           5832_1
          DATA   0           5832_2
          DATA   2           5833_1
          DATA   2           5833_1P
          DATA   2           5833_2
          DATA   2           5833_3P
          DATA   2           5833_4
          DATA   4           5838_1
          DATA   4           5838_1P
          DATA   4           5838_2
          DATA   4           5838_3P
          DATA   4           5838_4
          DATA   7           47444_1
          DATA   7           47444_1P
          DATA   7           47444_2
          DATA   7           47444_3P
          DATA   7           47444_4

*         INTERRUPT SIZE FOR 10 MB CHANNEL.  THESE VALUES ARE INITIALIZED
*         BY ROUTINE IIS.

 ISL      DATA   0           5832_1
          DATA   0           5832_2
          DATA   8192        5833_1
          DATA   8192        5833_1P
          DATA   8192        5833_2
          DATA   24576       5833_3P
          DATA   24576       5833_4
          DATA   8192        5838_1
          DATA   8192        5838_1P
          DATA   8192        5838_2
          DATA   24576       5838_3P
          DATA   24576       5838_4
          DATA   12288       47444_1
          DATA   12288       47444_1P
          DATA   12288       47444_2
          DATA   16384       47444_3P
          DATA   16384       47444_4

*         INTERRUPT SIZE FOR 25 MB CHANNEL.  THESE VALUES ARE INITIALIZED
*         BY ROUTINE IIS.

 ISH      DATA   0           5832_1
          DATA   0           5832_2
          DATA   8192        5833_1
          DATA   8192        5833_1P
          DATA   8192        5833_2
          DATA   24576       5833_3P
          DATA   24576       5833_4
          DATA   8192        5838_1
          DATA   8192        5838_1P
          DATA   8192        5838_2
          DATA   24576       5838_3P
          DATA   24576       5838_4
          DATA   12288       47444_1
          DATA   12288       47444_1P
          DATA   12288       47444_2
          DATA   24576       47444_3P
          DATA   24576       47444_4

*         SUSPEND INTERVAL FOR 10 MB CHANNEL (IN SECTORS)

 SIL      DATA   1000        5832_1
          DATA   1000        5832_2
          DATA   2           5833_1
          DATA   2           5833_1P
          DATA   1000        5833_2
          DATA   1000        5833_3P
          DATA   1000        5833_4
          DATA   2           5838_1
          DATA   2           5838_1P
          DATA   1000        5838_2
          DATA   1000        5838_3P
          DATA   1000        5838_4
          DATA   2           47444_1
          DATA   2           47444_1P
          DATA   1000        47444_2
          DATA   1000        47444_3P
          DATA   1000        47444_4

*         SUSPEND INTERVAL FOR 25 MB CHANNEL (IN SECTORS)

 SIH      DATA   6           5832_1
          DATA   1000        5832_2
          DATA   6           5833_1
          DATA   6           5833_1P
          DATA   6           5833_2
          DATA   3           5833_3P
          DATA   1000        5833_4
          DATA   6           5838_1
          DATA   6           5838_1P
          DATA   6           5838_2
          DATA   3           5838_3P
          DATA   1000        5838_4
          DATA   6           47444_1
          DATA   6           47444_1P
          DATA   6           47444_2
          DATA   3           47444_3P
          DATA   1000        47444_4

*         MODEL NUMBER.  THIS IS TWO BYTES FROM THE MODEL NUMBER
*         FIELD THAT IS UNIQUE FOR EACH DRIVE TYPE.

 MN       DATA   0#3137      5832_1
          DATA   0#3136      5832_2
          DATA   0#4C32      5833_1
          DATA   0#4C32      5833_1P
          DATA   0#4C32      5833_2
          DATA   0#4C32      5833_3P
          DATA   0#4C32      5833_4
          DATA   0#4C31      5838_1
          DATA   0#4C31      5838_1P
          DATA   0#4C31      5838_2
          DATA   0#4C31      5838_3P
          DATA   0#4C31      5838_4
          DATA   0#3153      47444_1
          DATA   0#3153      47444_1P
          DATA   0#3153      47444_2
          DATA   0#3153      47444_3P
          DATA   0#3153      47444_4
          SPACE  5,20
*         LOCATION CH IS THE INDEX INTO THIS CHANNEL TYPE TABLE

 TR       DATA   0#7E42      10 MB CHANNEL TRANSFER RATE
          DATA   0#FF42      25 MB CHANNEL TRANSFER RATE

 PAS      DATA   0#62        10 MB CHANNEL PORT A SELECT
          DATA   0#362       25 MB CHANNEL PORT A SELECT

 PBS      DATA   0#862       10 MB CHANNEL PORT B SELECT
          DATA   0#B62       25 MB CHANNEL PORT B SELECT

 WOR      DATA   0#14        10 MB CHANNEL WRITE OPERAND REGISTER FUNCTION
          DATA   0#702       25 MB CHANNEL WRITE OPERAND REGISTER FUNCTION

 TMWC     DATA   0#8064      10 MB CHANNEL TEST MODE WORD COUNT
          DATA   0#FF9C      25 MB CHANNEL TEST MODE WORD COUNT

 ETMF     CON    H0300       10 MB CHANNEL ENABLE TEST MODE FUNCTION
          CON    H0302       25 MB CHANNEL ENABLE TEST MODE FUNCTION

 EDC      DATA   0           10 MB CHANNEL, USE SINGLE CMI SLOT
          DATA   0#4000      25 MB CHANNEL, USE DOUBLE CMI SLOT

 ETMP     DATA   0#1000      10 MB CHANNEL, ENABLE TEST MODE PARAMETER
          DATA   0#80FF      25 MB CHANNEL, ENABLE TEST MODE PARAMETER

 EOG1     DATA   0#D79A      10 MB CHANNEL, EXPECTED OPERAND GENERATOR
          DATA   0#71        25 MB CHANNEL, EXPECTED OPERAND GENERATOR

 EOG2     DATA   0#2A92      10 MB CHANNEL, EXPECTED OPERAND GENERATOR
          DATA   0           25 MB CHANNEL, EXPECTED OPERAND GENERATOR

 RORF     DATA   4           10 MB CHANNEL, READ OPERAND GENERATOR FUNCTION
          DATA   0#802       25 MB CHANNEL, READ OPERAND GENERATOR FUNCTION

 EC1      DATA   0#FA15      10 MB CHANNEL, EXPECTED CHECKSUM
          DATA   0#DACF      25 MB CHANNEL, EXPECTED CHECKSUM

 EC2      DATA   0#31        10 MB CHANNEL, EXPECTED CHECKSUM
          DATA   0#36        25 MB CHANNEL, EXPECTED CHECKSUM

 CTS      DATA   0#F02       10 MB CHANNEL, CHANNEL TRANSFER SPEED
          DATA   0           25 MB CHANNEL, CHANNEL TRANSFER SPEED
          SPACE  5,20
*         FNC IS THE INDEX INTO THESE TABLES.  THE TABLES WERE CREATED
*         SO THAT WRITE AND READ COULD BE A COMMON ROUTINE.

 BAV      DATA   3           BUS CONTROL FOR DATA IN
          DATA   2           BUS CONTROL FOR DATA OUT

 TF1      DATA   0#281       TRANSFER FUNCTION TO STREAM, READ
          DATA   0#381       TRANSFER FUNCTION TO STREAM, WRITE

 TF2      DATA   0#0C00      LOAD T REGISTER FOR DMA READ
          DATA   0#0D00      LOAD T REGISTER FOR DMA WRITE

 TF3      DATA   0#A287      READ LAST SECTOR ON 25 MB CHANNEL (MASTER TERMINATE)
          DATA   0#A387      WRITE LAST SECTOR ON 25 MB CHANNEL (MASTER TERMINATE)

 TF4      DATA   0#2287      READ SECTOR ON 25 MB CHANNEL (NO MASTER TERMINATE)
          DATA   0#2387      WRITE SECTOR ON 25 MB CHANNEL (NO MASTER TERMINATE)

 .F       IFEQ   FE,1
          BSS    60          FOR PATCHES DURING CHECKOUT
 .F       ENDIF
          TITLE  MAIN LOOP
** NAME-- MAIN
*
** PURPOSE-- MAIN IDLE LOOP.  LOOK FOR REQUESTS FROM CENTRAL MEMORY
*            AND LOOK FOR INTERRUPTS FROM THE CONTROLLERS.
*
** ENTRY
*         MAIN - AFTER DRIVER IS LOADED, WHEN THE PP IS RESUMED
*         MAIN10 - TO RUN DIAGNOSTICS DURING ERROR RECOVERY
*         MAIN15 - AFTER SEEK, WRITE, OR READ COMMAND STARTED
*         MAIN20 - WHEN A WRITE, READ,OR RESTORE COMMMAND COMPLETES
          SPACE  2
 MAIN     BSS
          LOADOVL ITO        LOAD INITIALIZE TABLE OVERLAY
          RJM    IT          INITIALIZE TABLES
 MAIN10   BSS
          LOADOVL PTO        LOAD PATH TEST OVERLAY
          RJM    PT          PATH TEST
 MAIN15   BSS
 .F       IFEQ   FE,1        FORCE ERROR IN RUNNING PP DRIVER
          RJM    FER         FORCE ERROR ROUTINE
 .F       ENDIF
          RJM    EI          ENABLE INTERRUPTS
          RJM    PPRQ        CHECK FOR ANY PP REQUESTS
          RJM    GETU        SELECT UNIT REQUESTS, SEEK,
                             AND PROCESS INTERRUPTS
          LDDL   CMNDS
          NJN    MAIN15      IF OUTSTANDING COMMANDS
 MAIN20   BSS
          SOML   CHLCNT
          NJN    MAIN15      IF PP DOESN'T HAVE TO GIVE UP CHANNEL
          RJM    CKC         CHECK IF CHANNEL MUST BE GIVEN UP
          UJN    MAIN15
          SPACE  5,10
 UCMD     BSS                COMMANDS FROM CENTRAL MEMORY
          CON    C.READ
          CON    C.WRITE
          CON    C.FORMAT
 UCMDL    EQU    *-UCMD
          TITLE  COMMANDS
** NAME-- LST
*
** PURPOSE-- LOW SPEED TRANSFER (10 MB CHANNEL).  A TRANSFER NOTIFICATION
*            RESPONSE HAS BEEN RECEIVED.  IF FNC IS 0 THIS IS A READ
*            OPERATION AND DATA WILL BE TRANSFERRED FROM THE CONTROLLER
*            BUFFER TO CM.  IF FNC IS NOT ZERO THIS IS A WRITE OPERATION
*            AND DATA WILL BE TRANSFERRED FROM CM TO THE CONTROLLER BUFFER.
*
** ENTRY  LISTL = NUMBER OF ADDRESS-LENGTH-PAIR ENTRIES IN THE
*                 COMMAND WHICH ARE LEFT TO PROCESS.
*         CMLIST  = LIST OF ADDRESS-LENGTH-PAIRS POINTING TO THE
*                   CM DATA AREA.
*         FNC = 0  IF READ, 1 IF WRITE
          SPACE  2
 LST      CON    0
 LST20    BSS
          LDML   CMLIST+/CM/P.LEN,CSST  NUMBER OF BYTES LEFT TO TRANSFER
          STDL   BC          CM BYTES LEFT TO TRANSFER
          SBML   BPS,DT      BYTES PER SECTOR
          ADDL   SECPOS      BYTES PREVIOUSLY TRANSFERRED FROM THIS SECTOR
          MJN    LST30       IF LESS THAN 1 SECTOR LEFT TO TRANSFER
          LDML   BPS,DT      COMPUTE NUMBER OF CM BYTES TO TRANSFER THIS LOOP
          SBDL   SECPOS
          STDL   BC          NUMBER OF CM BYTES TO TRANSFER
 LST30    BSS
          LDDL   SECPOS
          NJN    LST60       IF BUS CONTROL ALREADY DONE
          LDML   BAV,FNC     BUS A VALUE
          RJM    BCS         BUS CONTROL SEQUENCE
 LST40    EQU    *-1         FOR FORCING ERRORS
          LDML   TF1,FNC     TRANSFER FUNCTION TO STREAM DATA
          RJM    FUNC        RAISE MASTER OUT
 LST50    EQU    *-1         FOR FORCING ERRORS
          UJN    LST70
 LST60    BSS
          RJM    WFTE        WAIT FOR T PRIME REGISTER EMPTY
          ZJK    LST110      IF TIMEOUT
 LST70    BSS
          LDML   TF2,FNC     FUNCTION TO LOAD T REGISTERS
          RJM    FUNC
          ACN    DC
          LDML   CMLIST+/CM/P.RMA,CSST
          STDL   RMA         CM ADDRESS OF DATA AREA
          LDML   CMLIST+/CM/P.RMA+1,CSST
          STDL   RMA+1
          LDN    3
          OAM    BC,DC       BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
 LST80    EQU    *-1         FOR FORCING ERRORS
          LDML   /SS/P.NCR,CSST  NUMBER OF COMPLETED REQUESTS
          ZJN    LST90       IF NO COMPLETED REQUESTS
          LDDL   FNC
          NJN    LST90       IF WRITE
          RJM    RDWTOK      SEND RESPONSE FOR GOOD READ
 LST90    BSS
          RJM    SFUP        SAVE FOR UNANTICIPATED PAUSE
          LDDL   BC
          RADL   SECPOS      UPDATE SECTOR POSITION
          SBML   BPS,DT      CHECK FOR END OF SECTOR
          ZJN    LST110      IF END OF SECTOR
          LDML   /SS/P.LISTL,CSST  CHECK IF MORE CM ADDRESS-LENGTH-PAIRS
          SBN    1
          ZJN    LST100      IF ALL USER DATA FOR THIS SECTOR TRANSFERRED
          RJM    UBT         UPDATE BYTES TRANSFERRED
          UJK    LST20
 LST100   BSS
          LDML   BPS,DT      BYTES PER SECTOR
          SBDL   SECPOS
          STML   CM.CB.T     BYTES TO TRANSFER
          RJM    WFTE        WAIT FOR T PRIME REGISTER EMPTY
          ZJN    LST110      IF TIMEOUT
          LDC    H0B00       WRITE T PRIME REGISTER
          RJM    FUNC
          ACN    DC
          LDN    3
          OAM    CM.CB.T,DC  BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
 LST110   BSS
          RJM    UBT         UPDATE BYTES TRANSFERRED
          RJM    WFTC        WAIT FOR TRANSFER COMPLETE
          ZJN    LST130      IF ERROR OR UNANTICIPATED PAUSE
          RJM    UDA         UPDATE DISK ADDRESS
          RJM    CRS         CHECK FOR REQUEST SWITCH
          NJK    LST20       IF MORE DATA TO TRANSFER
 LST130   BSS
          LJM    MAIN15
          EJECT
** NAME-- HST
*
** PURPOSE-- HIGH SPEED TRANSFER (25 MB CHANNEL).  A TRANSFER NOTIFICATION
*            RESPONSE HAS BEEN RECEIVED.  IF FNC IS 0 THIS IS A READ
*            OPERATION AND DATA WILL BE TRANSFERRED FROM THE CONTROLLER
*            BUFFER TO CM.  IF FNC IS 1 THIS IS A WRITE OPERATION AND
*            DATA WILL BE TRANSFERRED FROM CM TO THE CONTROLLER BUFFER.
*
** ENTRY  LISTL = NUMBER OF ADDRESS-LENGTH-PAIR ENTRIES IN THE
*                 COMMAND WHICH ARE LEFT TO PROCESS.
*         CMLIST = LIST OF ADDRESS-LENGTH-PAIRS POINTING TO THE
*                  CM DATA AREA.
*         FNC = 0  IF READ, 1 IF WRITE
          SPACE  2
 HST      CON    0
 HST5     BSS
          LDML   /SS/P.TOTAL,CSST
          LPC    777B
          SBN    1
          NJK    HST30       IF NOT LAST SECTOR
          LDML   /SS/P.TOTAL,CSST
          SHN    2
          PJN    HST30       IF NO REQUEST CONCATENATION
          LOADF  /SS/P.REQ,CSST  ADDRESS OF REQUEST
          ADN    /RQ/C.SWIT
          CRDL   T4          READ STREAM BIT IN REQUEST
          LDDL   T4
          SHN    2
          MJN    HST25       IF CONCATENATED REQUEST
 HST10    BSS
          LDML   /SS/P.TOTAL,CSST
          LPC    777B
          STML   /SS/P.TOTAL,CSST  CLEAR MASTER TERMINATE BIT
 HST20    BSS
          LDML   TF3,FNC     SOFTWARE MASTER TERMINATE
          UJN    HST40
 HST25    BSS
          LDN    2
          STDL   T1          CM WORDS TO READ
          LDDL   CSST
          ADK    RQ
          STML   HST27       ADDRESS TO STORE PVA, RMA
          LDDL   CMADR+2
          LMC    400000B
          CRML   *,T1        REREAD PVA AND RMA
 HST27    EQU    *-1
 HST30    BSS
          LDML   TF4,FNC     NO SOFTWARE MASTER TERMINATE
 HST40    BSS
          RJM    FUNC        TRANSFER FUNCTION
 HST50    BSS
          LDC    H0C00       DMA TRANSFER FUNCTION
 HST60    BSS
          RJM    FUNC        SEND FUNCTION
 HST65    EQU    *-1         FOR FORCING ERRORS
          LDML   CMLIST+/CM/P.LEN,CSST  NUMBER OF BYTES LEFT TO TRANSFER
          STDL   BC
          SBML   BPS,DT      BYTES PER SECTOR
          ADDL   SECPOS      BYTES PREVIOUSLY TRANSFERRED FROM THIS SECTOR
          MJN    HST76       IF LESS THAN ONE SECTOR LEFT TO TRANSFER
          LDML   BPS,DT
          SBDL   SECPOS
          STDL   BC          NUMBER OF BYTES TO TRANSFER
          IFEQ   FE,1
          LJM    HST76
 HST75    EQU    *-1         FOR FORCING ERRORS
          ENDIF
 HST76    BSS
          ACN    DC
          LDML   CMLIST+/CM/P.RMA,CSST
          STDL   RMA         CM ADDRESS OF DATA AREA
          LDML   CMLIST+/CM/P.RMA+1,CSST
          STDL   RMA+1
          LDN    3
          OAM    BC,DC       BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
 HST78    EQU    *-1         FOR FORCING ERRORS
          LDML   /SS/P.NCR,CSST  NUMBER OF COMPLETED REQUESTS
          ZJN    HST80       IF NO COMPLETED REQUESTS
          LDDL   FNC
          NJN    HST80       IF WRITE
          RJM    RDWTOK      SEND RESPONSE FOR COMPLETED READ REQUEST
 HST80    BSS
          RJM    SFUP        SAVE FOR UNANTICIPATED PAUSE
          LDDL   BC
          RADL   SECPOS      UPDATE SECTOR POSITION
          SBML   BPS,DT
          ZJN    HST100      IF END OF SECTOR
          RJM    WFTE        WAIT FOR T PRIME REGISTER EMPTY
          ZJN    HST100      IF TIMEOUT
          LDML   /SS/P.LISTL,CSST  CHECK IF MORE CM ADDRESS LENGTH PAIRS
          SBN    1
          ZJN    HST90       IF ALL USER DATA FOR THIS SECTOR TRANSFERRED
          RJM    UBT         UPDATE BYTES TRANSFERRED
          UJK    HST50
 HST90    BSS
          LDML   BPS,DT
          SBDL   SECPOS
          STML   CM.CB.T     BYTES TO TRANSFER
          RJM    WFTE        WAIT FOR T PRIME REGISTER EMPTY
          ZJN    HST100      IF TIMEOUT
          LDC    H0C00       WRITE T PRIME REGISTER
          RJM    FUNC
          ACN    DC
          LDN    3
          OAM    CM.CB.T,DC  BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
 HST100   BSS
          LDN    0
          STDL   SECPOS      CLEAR SECTOR POSITION
          RJM    UBT         UPDATE BYTES TRANSFERRED
          RJM    WFC         WAIT FOR COMPLETION
          NJK    HST150      IF PAUSE
          RJM    UDA         UPDATE DISK ADDRESS
          LPC    777B
          NJN    HST110      IF NOT LAST SECTOR
          LDML   /SS/P.TOTAL,CSST
          SHN    2
          PJK    HST150      IF LAST SECTOR
          RJM    CSWIT       SWITCH TO NEXT REQUEST
 HST110   BSS
          SODL   SBS         SECTORS BEFORE SUSPEND
          ZJK    HST150      IF TIME TO SUSPEND
          LDDL   OS
          LPN    20B
          ZJK    HST5        IF NO PAUSE
 HST150   BSS
          RJM    DCM         DESELECT THE CONTROLLER
          LJM    MAIN15
          TITLE  COMMAND SUBROUTINES
** NAME-- CFFMT
*
** PURPOSE-- CLEAR THE FORCE FORMAT FLAG IN THE UNIT INTERFACE TABLE.
*
** EXIT   P5 IS UNCHANGED
          SPACE  2
 CFFMTX   LJM    **
 CFFMT    EQU    *-1
 CFFMT10  BSS
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    CFFMT10     IF LOCK COULD NOT BE SET
          LDK    -/UIT/K.FRCFMT  CLEAR FORCE FORMAT FLAG
          STDL   T3
          LCN    0
          STDL   T2
          STDL   T4
          STDL   T5
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          RDCL   T2          -LOGICAL OR- THE FORCE FORMAT FLAG
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          UJK    CFFMTX
          SPACE  5,20
** NAME-- CFME
*
** PURPOSE-- CHECK FOR MEDIA ERROR
*
** EXIT--  A = 0 IF MEDIA ERROR AND FAILING ADDRESS IS PRESENT
          SPACE  2
 CFME20   BSS
          LDN    1           INDICATE MEDIA ERROR NOT FOUND
 CFMEX    LJM    **
 CFME     EQU    *-1
          LDML   RS+/RS/P.ERRID
          NJN    CFMEX       IF NOT MEDIA ERROR
          LDK    ID26        DRIVE MACHINE EXCEPTION
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    CFMEX       IF ID26 NOT FOUND
          LDML   RPB+5,T3
          SHN    -8
          SBN    17
          MJN    CFME20      IF NO COMMAND ENDING STATUS
          LDML   RPB+13,T3   COMMAND ENDING STATUS
          LPN    77B
          SBN    0#11
          ZJN    CFMEX       IF ECC ERROR
          SBN    2
          ZJN    CFMEX       IF MISSING SYNC
          SBN    6           CHECK SECTOR NOT FOUND
          UJN    CFMEX
          SPACE  5,20
** NAME-- CKC
*
** PURPOSE-- CHECK IF MAINTENANCE PP WANTS THE CHANNEL.
          SPACE  2
 CKCX     LJM    **
 CKC      EQU    *-1
          LDK    C.CHCNT     NUMBER OF REQUESTS TO PROCESS BEFORE
          STML   CHLCNT       GIVING UP THE CHANNEL
          LOADC  CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          ADDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          CRDL   T1          READ CHANNEL LOCKWORD
          LDDL   T2
          LPN    1
          ZJK    CKCX        IF MAINTENANCE PP DOES NOT WANT THE CHANNEL
          LDDL   UNUML
          ZJK    CKCX        IF NO UNITS
          LOADOVL IDRO       LOAD IDLE/RESUME OVERLAY
          RJM    CUB         CHECK UNIT BUSY
          STDL   MALET       SETTING MALET NONZERO PREVENTS STARTING
                              NEW DISK REQUESTS
          NJN    CKCX        IF OUTSTANDING COMMANDS
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          PAUSE  130000      DELAY 130 MILLISECONDS TO ALLOW
                             MAINTENANCE PP TO GET THE CHANNEL
          LOADOVL PTO        OVERLAY CONTAINING ROUTINE SCLOCK
          RJM    SCLOCK      SET CHANNEL LOCK
          UJK    CKCX
 CHLCNT   CON    C.CHCNT     NUMBER OF REQUESTS TO PROCESS BEFORE
                              GIVING UP THE CHANNEL
          SPACE  5,20
** NAME-- CLOCK
*
** PURPOSE-- CLEAR LOCKWORD
*
*  ENTRY
*         T7 = POINTER RMA
*         T5 = OFFSET TO LOCKWORD FROM RMA
          SPACE  2
 CLKX     LJM    **
 CLOCK    EQU    *-1
 CLK14    BSS
          LCN    0
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        RMA OF TABLE
          ADDL   T5          ADD LOCKWORD OFFSET
          STDL   T6
          RDSL   T1          WRITE INTERMEDIATE VALUE
          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJN    CLK14       IF INTERMEDIATE VALUE
          LDDL   T4
          SBDL   LPN
          ZJN    CLK30       IF THIS PP HAS THE LOCK SET
          LDDL   T6
          LMC    400000B
          CWDL   T1          RESTORE THE ORIGINAL CONTENTS
          RJM    HANG        HANG, THE LOCKWORD WAS WRONG
 CLK30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6
          LMC    400000B
          CWDL   T1          CLEAR THE LOCKWORD
          UJK    CLKX
          SPACE  5,20
** NAME-- CQLOCK
*
** PURPOSE-- CLEARS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE
          SPACE  2
 CQLX     LJM    **
 CQLOCK   EQU    *-1
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CQLX
          SPACE  5,20
** NAME-- CRS
*
** PURPOSE-- CHECK FOR REQUEST SWITCH
*
** EXIT
*         A NOT EQUAL 0 IF MORE DATA TO TRANSFER
          SPACE  2
 CRSX     LJM    **
 CRS      EQU    *-1
          LDDL   T3
          NJN    CRS5        IF REQUEST SWITCH
          LDML   /SS/P.TOTAL,CSST
          LPC    777B
          NJN    CRS10       IF NOT END OF TRANSFER
          UJN    CRS30
 CRS5     BSS
          RJM    CSWIT       SWITCH TO NEXT REQUEST
 CRS10    BSS
          LDDL   STATUS
          LPN    0#30
          NJN    CRS30       IF DELAY
          LDDL   SBS
          NJN    CRSX        IF MORE TO TRANSFER
 CRS30    BSS
          RJM    DCM         DESECLECT THE CONTROLLER
          LDN    0
          LJM    CRSX
          SPACE  5,20
** NAME-- CSWIT
*
** PURPOSE-- SWITCH TO THE NEXT REQUEST
          SPACE  2
 CSWX     LJM    **
 CSWIT    EQU    *-1
          LDML   RQ+/RQ/P.NEXT,CSST  PUT RMA OF NEXT REQUEST IN SS TABLE
          STML   /SS/P.REQ,CSST
          LDML   RQ+/RQ/P.NEXT+1,CSST
          STML   /SS/P.REQ+1,CSST
          LDML   RQ+/RQ/P.NEXTPV,CSST  PUT PVA OF NEXT REQUEST IN SS TABLE
          STML   /SS/P.PVA,CSST
          LDML   RQ+/RQ/P.NEXTPV+1,CSST
          STML   /SS/P.PVA+1,CSST
          LDML   RQ+/RQ/P.NEXTPV+2,CSST
          STML   /SS/P.PVA+2,CSST
          LDML   RQ+/RQ/P.CYL,CSST
          STDL   T2          SAVE CYLINDER OF LAST REQUEST
          RJM    UREQ        READ NEXT REQUEST INTO RQ
          LDML   RQ+/RQ/P.SWIT,CSST
          LPC    777B
          LMC    0#8000      INDICATE MASTER TERMINATE
          STML   /SS/P.TOTAL,CSST  SECTORS TO TRANSFER
          LDML   RQ+/RQ/P.CYL,CSST
          SBD    T2
          NJN    *           IF NOT SAME CYLINDER
          LDML   /SS/P.CURSEC,CSST  CURRENT SECTOR - 1
          LMML   RQ+/RQ/P.SECTOR,CSST  SECTOR OF NEXT REQUEST
          NJN    *           IF SECTOR NUMBER WRONG
          LDML   /SS/P.CURTRK,CSST  CURRENT TRACK
          LMML   RQ+/RQ/P.TRACK,CSST  TRACK ADDRESS OF NEXT REQUEST
          NJN    *           TRACK NUMBER WRONG
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
          AOML   /SS/P.NCR,CSST  INCREMENT NUMBER OF COMPLETED REQUESTS
          UJK    CSWX
          SPACE  5,20
** NAME-- CTR
*
** PURPOSE-- CONFIDENCE TEST RECOVERY
*
** EXIT--  TO CALLING ROUTINE WITH
*             A = 0  IF ERROR LIMIT REACHED
*             A NOT 0  IF NOT MEDIA ERROR
*          TO CTDT ROUTINE IF MEDIA ERROR
          SPACE  2
 CTR100   BSS
          LMN    4           DATA INTEGRITY ERROR
 CTRX     LJM    **
 CTR      EQU    *-1
          LDML   /SS/P.CT,CSST
          NJN    CTR100      IF NOT IN CONFIDENCE TEST
          RJM    CFME        CHECK FOR MEDIA ERROR
          NJN    CTRX        IF NOT A MEDIA ERROR
          RJM    CTRS        CONFIDENCE TEST RECOVERY SUBROUTINE (NO RETURN)
          SPACE  5,20
** NAME-- DARH
*
** PURPOSE-- DRIVE ASYNCHRONOUS RESPONSE HANDLER
          SPACE  2
 DARHX    LJM    **
 DARH     EQU    *-1

*         SEARCH UNITS TABLE TO SEE IF THIS UNIT IS CONFIGURED

          LDDL   UX
          STDL   T8          SAVE INDEX TO UNITS TABLE
          LDN    0
          STDL   UX
          UJN    DARH20
 DARH10   BSS
          LDN    P.UN
          RADL   UX          INCREMENT TO NEXT UNITS TABLE
 DARH20   BSS
          SBDL   UNUML
          ZJK    DARH60      IF END OF CONFIGURED UNITS
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LDML   RPB+SLAD
          LMML   /SS/P.UNIT,CSST
          NJN    DARH10      IF RESPONSE NOT FOR THIS CONFIGURED UNIT
          LDML   UNITS,UX
          LMML   UNITS,T8
          LPC    400B
          NJN    DARH10      IF RESPONSE NOT FOR THIS CHANNEL PORT
          LDK    ID26
          RJM    SFP         CHECK FOR MACHINE EXCEPTION
          MJK    DARH35      IF MACHINE EXCEPTION ID NOT FOUND
          LDM    /SS/P.DT,CSST
          SHN    -4
          SBN    3
          ZJN    DARH30      IF 5833_1P
          SBN    5
          ZJN    DARH30      IF 5838_1P
          SBN    2
          ZJN    DARH30      IF 5838_3P
          SBN    3
          ZJN    DARH30      IF 47444_1P
          SBN    2
          ZJN    DARH30      IF 47444_3P
          ADN    10
          NJK    DARH40      IF NOT 5833_3P
 DARH30   BSS
          LDML   RPB+5,T3
          SHN    -8
          SBN    8
          MJK    DARH40      IF RESPONSE FOR LOGICAL UNIT
          LDML   RPB+9,T3
          SHN    -8
          LMC    0#FE
          ZJK    DARH40      IF RESPONSE FOR LOGICAL UNIT

*         AN OPERATIONAL RESPONSE FOR A PHYSICAL DRIVE OF A PARITY UNIT
*         COULD MEAN AN OFF LINED DRIVE WAS REPAIRED.  THE CONFIDENCE TEST
*         WILL FORMAT THE DRIVE IF NECESSARY AND START THE RESTORE OF THE DRIVE.
*         DRIVE RESET FROM THE OTHER ACCESS CAUSES AN OPERATIONAL, READY
*         TRANSITION.  DON'T INITIATE A RESTORE DUE TO A DRIVE RESET.

          LDML   RPB+6,T3
          SHN    3
          PJK    DARH55      IF NOT OPERATIONAL TRANSITION
          SHN    1
          MJK    DARH60      IF READY TRANSISTION
          LDML   /SS/P.RQTRY,CSST
          NJN    DARH40      IF IN ERROR RECOVERY
          LDML   DARH
          LMC    PI75
          NJN    DARH40      IF CALLING ROUTINE IS NOT PI (PREVENT INFINITE LOOP)
          LDN    40B
          STML   /SS/P.CT,CSST  FORCE CONFIDENCE TEST TO BE RUN
          LDM    /SS/P.DOAR,CSST
          LMC    0#8000      INDICATE OPERATIONAL ASYNCH RECEIVED
          STML   /SS/P.DOAR,CSST
          UJN    DARH60

*         DRIVE RESET FROM THE OTHER ACCESS CAUSES A NOT OPERATIONAL, NOT
*         READY TRANSITION RESPONSE.  DON'T LOG THIS ASYNCHRONOUS RESPONSE.

 DARH35   BSS
          LDK    ID24
          RJM    SFP         SEARCH FOR PARAMETER 24
          MJN    DARH55      IF PARAMETER NOT FOUND
          LDML   RPB+6
          LPC    0#3000
          LMC    0#3000
          ZJN    DARH60      IF NOT OPERATIONAL, NOT READY ASYNCH
          UJN    DARH55
 DARH40   BSS
          LDML   RPB+6,T3
          LPC    0#FAF0
          LMC    0#6000
          ZJN    DARH60      IF NO ERROR
 DARH55   BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 DARH60   BSS
          LDDL   T8
          STDL   UX
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          UJK    DARHX
          SPACE  5,20
** NAME-- DCR
*
** PURPOSE-- DELETE COMPLETED REQUEST FROM THE UNIT QUEUE.
*
** ENTRY  UNITS+/UN/P.UIT = POINTER TO UNIT INTERFACE TABLE
*         IF A = 0, ISSUE SEEK IF REQUEST AND NO COMMAND ISSUED
*
** EXIT   P5, T8 ARE UNCHANGED
          SPACE  2
 DCRX     LJM    **
 DCR      EQU    *-1
          STDL   T9
          LDN    2
          STDL   P6
 DCR5     BSS
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    DCR5        IF LOCK COULD NOT BE SET
          LOADF  /SS/P.CURRQ,CSST  RMA OF CURRENT REQUEST
          CRML   RQT,P6      READ RMA CHAIN OF CURRENT REQUEST

          LOADR  UNITS+/UN/P.UIT,UX  LOAD CM ADDRESS OF UNIT INT. TABLE
          STDL   T1
          CRDL   P1          READ QUEUE COUNT
          ERRNZ  /UIT/C.QCNT
          LDDL   P1+/UIT/P.QCNT  DECREMENT QUEUE COUNT
          SBML   /SS/P.NCOMRQ,CSST  NUMBER OF COMPLETED REQUESTS
          STDL   P1+/UIT/P.QCNT
          MJN    DCR10       IF INVALID QUEUE COUNT
          LDDL   T1
          LMC    400000B
          CWDL   P1          WRITE QUEUE COUNT
 DCR10    BSS
          LOADR  /SS/P.DP,CSST  DELINK POINTER
 DCR12    BSS
          STDL   P2
          ADN    1           POINT TO RMA INSTEAD OF PVA
          CRDL   T1          RMA OF A REQUEST
          LDDL   T3
          LMML   /SS/P.FCOMRQ,CSST
          NJN    DCR15       IF NEXT REQUEST IS NOT COMPLETED REQUEST
          LDDL   T4
          LMML   /SS/P.FCOMRQ+1,CSST
          ZJK    DCR30       IF THIS IS A COMPLETED REQUEST
 DCR15    BSS
          LOADF  T3          UPDATE DELINK POINTER TO NEXT
          STML   /SS/P.DP+2,CSST  REQUEST IN THE CHAIN
          LDDL   CMADR
          STML   /SS/P.DP,CSST
          ADDL   CMADR+1
          ADDL   CMADR+2
          ZJN    DCR20       IF END OF REQUEST QUEUE
          LDDL   CMADR+1
          STML   /SS/P.DP+1,CSST
          LDDL   CMADR+2
          LMC    400000B
          UJN    DCR12
 DCR20    BSS
          LDML   UNITS+/UN/P.UIT,UX  INITIALIZE DELINK POINTER TO
          STML   /SS/P.DP,CSST        FIRST RMA
          LDML   UNITS+/UN/P.UIT+1,UX
          STML   /SS/P.DP+1,CSST
          LDML   UNITS+/UN/P.UIT+2,UX
          ADN    /UIT/C.NEXTPV
          STML   /SS/P.DP+2,CSST
          UJK    DCR10

*         DELINK COMPLETED REQUESTS.

 DCR30    BSS
          LDDL   P2          CM ADDRESS OF REQUEST
          LMC    400000B
          CWML   RQT,P6      PVA AND RMA OF NEXT REQUEST IN CHAIN
          LDML   RQT+/RQ/P.NEXT
          ADML   RQT+/RQ/P.NEXT+1
          NJK    DCR32       IF NOT END OF QUEUE
          LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          MJN    DCR32       IF 2 COMMANDS ISSUED TO CONTROLLER
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.NEXTPV
          CRML   RQT,P6      READ FIRST PVA AND RMA
          LDML   UNITS+/UN/P.UIT,UX  INITIALIZE DELINK POINTER TO FIRST REQUEST
          STML   /SS/P.DP,CSST
          LDML   UNITS+/UN/P.UIT+1,UX
          STML   /SS/P.DP+1,CSST
          LDML   UNITS+/UN/P.UIT+2,UX
          ADN    /UIT/C.NEXTPV
          STML   /SS/P.DP+2,CSST
 DCR32    BSS
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD

          LDDL   T9
          NJK    DCR38       IF NOT CHECKING REQUEST QUEUE
          LDDL   P4
          ZJK    DCR36       IF QUEUE EMPTY
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          LDML   /SS/P.CT,CSST
          LPN    7
          ZJK    DCR38       IF CONFIDENCE TEST SHOULD BE RUN
          LDML   /SS/P.RQTRY,CSST
          NJK    DCR38       IF IN ERROR RECOVERY
          LDDL   IF
          NJK    DCR38       IF CONFIDENCE TEST SHOULD BE RUN
          LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          MJK    DCR44       IF 2 COMMANDS ISSUED TO CONTROLLER
          LDML   RQT+/RQ/P.NEXTPV  PUT PVA OF NEXT REQUEST IN SS TABLE
          STML   /SS/P.PVA,CSST
          LDML   RQT+/RQ/P.NEXTPV+1
          STML   /SS/P.PVA+1,CSST
          LDML   RQT+/RQ/P.NEXTPV+2
          STML   /SS/P.PVA+2,CSST
          LDML   RQT+/RQ/P.NEXT  PUT RMA OF NEXT REQUEST IN SS TABLE
          STML   /SS/P.REQ,CSST
          LDML   RQT+/RQ/P.NEXT+1
          STML   /SS/P.REQ+1,CSST
          LDN    0
          STDL   CNUM        INDICATE FIRST COMMAND
          RJM    GETR        GET REQUEST
          LDDL   FNC
          SBN    2
          ZJN    DCR38       IF FORMAT
          RJM    SCP         SETUP COMMAND PACKET PARAMETERS
          RJM    CPT         COMMAND PACKET TRANSFER
          LJM    DCRX
 DCR36    BSS
          RJM    RESPIN
 DCR38    BSS
          LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          MJN    DCR44       IF 2 COMMANDS ISSUED TO CONTROLLER
          SHN    -/UN/L.TCIP-2
          LPC    0#3FFF
          STML   UNITS,UX    CLEAR CIP
          RJM    DUBC        DECREMENT UNIT BUSY COUNTER
          LJM    DCR50
 DCR44    BSS
          LDML   UNITS,UX
          LPC    0#BFFF
          STML   UNITS,UX    CLEAR TCIP

*         MOVE (RMA, PVA, TOTAL SECTORS) FOR SECOND COMMAND ISSUED TO THE
*         TABLE FOR THE FIRST COMMAND

          LDML   /SS/P.RMA2,CSST
          STML   /SS/P.REQ,CSST
          LDML   /SS/P.RMA2+1,CSST
          STML   /SS/P.REQ+1,CSST MOVE RMA
          LDML   /SS/P.PVA2,CSST
          STML   /SS/P.PVA,CSST
          LDML   /SS/P.PVA2+1,CSST
          STML   /SS/P.PVA+1,CSST
          LDML   /SS/P.PVA2+2,CSST
          STML   /SS/P.PVA+2,CSST  MOVE PVA
          LDML   /SS/P.TW2,CSST
          STML   /SS/P.TOTAL,CSST
          RJM    UREQ        READ UNIT REQUEST FROM CM
          RJM    SRESP       SET UP STATUS FOR RESPONSE BUFFER
          RJM    SETRQ       SET UP FOR FIRST REQUEST
          RJM    UNCMND      GET FIRST COMMAND
 DCR50    BSS
          SODL   CMNDS       OUTSTANDING COMMANDS
          LJM    DCRX
          SPACE  5,20
** NAME-- DUBC
*
** PURPOSE-- DECREMENT UNIT BUSY COUNTER
          SPACE  2
 DUBCX    LJM    **
 DUBC     EQU    *-1
          LDML   UNITS,UX
          SHN    -3
          LPN    77B
          STDL   P1          POINTER TO UPSB TABLE
          LDML   UPSB,P1
          ZJN    DUBCX       IF NO DECREMENT NECESSARY
          SOML   UPSB,P1     DECREMENT UNITS PER PATH STRING BUSY COUNTER
          NJN    DUBCX       IF OTHER BUSY UNITS
          LDML   PSB
          ZJN    DUBCX       IF NO DECREMENT NECESSARY
          SOML   PSB         DECREMENT PATH STRINGS BUSY
          UJN    DUBCX
          SPACE  5,20
** NAME-- EFP
*
** PURPOSE-- ERROR FLAG PROCESSING
          SPACE  2
 EFP      CON    0
          LOADOVL ER1O       LOAD ERROR RECOVERY OVERLAY NUMBER 1
          LJM    EFP1
          SPACE  5,20
** NAME-- EP
*
** PURPOSE-- ERROR PROCESSING
          SPACE  2
 EP       CON    0
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDML   /SS/P.RQTRY,CSST
          NJN    EP5         IF NOT FIRST ERROR FOR REQUEST
          STML   /SS/P.RECOV,CSST  INDEX TO FIRST RECOVERY STEP (EPA)
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
 EP5      BSS
          LDDL   UX          TO FORCE CONFIDENCE TEST OR FORMAT ERROR RECOVERY
          STDL   LUX          TO COMPLETE BEFORE GOING TO ANOTHER UNIT
          RJM    PPRQ        CHECK FOR IDLE REQUEST
          LDN    0
          STML   /SS/P.SC,CSST  DO NOT WAIT FOR ASYNCH IN DPR
          STDL   MFID        MASK FOR INTERLOCK DATA IF 200 HEX
          LDML   RS+/RS/P.ERRID
          NJN    EP10        IF RESPONSE PACKET NOT APPLICABLE
          LDK    ID24
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    EP10        IF PARAMETER 24 NOT FOUND
          LDML   RPB+6,T3
          SHN    3
          PJN    EP10        IF DRIVE WAS READY
          AOML   /SS/P.SC,CSST  FLAG SAYS WAIT FOR ASYNCH IN DPR
 EP10     BSS
          LDN    0
          STDL   TBC         DO NOT EXPECT 01 ENDING STATUS
          LDML   TMF
          NJN    EP15        IF ERROR DURING TEST MODE
          LDML   RS+/RS/P.ERRID
          ZJN    EP25        IF PROBABLY NOT IOU ERROR
          SBN    E20
          PJN    EP25        IF PROBABLY NOT IOU ERROR
 EP15     BSS
          LOADOVL ER2O       LOAD ERROR RECOVERY OVERLAY NUMBER 2
          LJM    EP40
 EP25     BSS
          LDML   /SS/P.RECOV,CSST  INDEX TO ERROR PROCESSING PROCEDURE
          STDL   T1
          LDML   EPT,T1
          STML   EP30
          LJM    **          EXECUTE NEXT STEP IN RECOVERY PROCEDURE
 EP30     EQU    *-1

 EPT      BSS    0
          CON    EPA         RETRY THE REQUEST
          CON    EPB         CONFIDENCE TEST
          CON    EPC         SLAVE RESET
          CON    EPD         PATH TEST
          CON    EPF         IF FINAL REQUEST RETRY FAILED
          CON    EPG         IF LOGICAL RESET FAILS AFTER FINAL RETRY
          CON    EPD20       REQUEST RETRY ERROR AFTER SLAVE RESET
          CON    EPC10       AFTER READ PERFORMANCE LOG
          SPACE  5,20
*         REQUEST RETRY

 EPA      BSS
          LDML   /SS/P.RQTRY,CSST  REQUEST RETRY COUNTER
          STDL   T2
          ZJN    EPA10       IF INTERMEDIATE RESPONSE ALREADY REPORTED
          LDML   UNITS,UX
          SHN    /UN/L.PDCE+2
          MJN    EPA3        IF PARITY DRIVE CORRECTION ENABLED
          LDDL   T2
          SBN    RRL+1
          UJN    EPA6
 EPA3     BSS
          LDDL   T2
          SBN    RRL+3+1
 EPA6     BSS
          PJK    EPC         IF FAILURE DURING LOGICAL RESET
          RJM    INTRS       REPORT INTERMEDIATE RESPONSE
 EPA10    BSS
          RJM    CTR         CONFIDENCE TEST RECOVERY
          NJN    EPA30       IF ERROR LIMIT NOT REACHED
          AOML   /SS/P.RQTRY,CSST  REQUEST RETRY COUNTER
          UJN    EPC
 EPA30    BSS
          LOADOVL ER2O       LOAD ERROR RECOVERY OVERLAY NUMBER 2
          LJM    EPA40

*         CONFIDENCE TEST

 EPB      BSS
          RJM    CTR         CONFIDENCE TEST RECOVERY

*         SLAVE RESET

 EPC      BSS
          LOADOVL ER2O       LOAD ERROR RECOVERY OVERLAY NUMBER 2
          LJM    EPC20
 EPC10    BSS
          LOADOVL ER2O       LOAD ERROR RECOVERY OVERLAY NUMBER 2
          LJM    EPC70

 EPCT     BSS    16          UX FOR RESET CONTROLLER

*         PATH TEST (ROUTINE PT WORKED ONCE, SLAVE RESET FAILED, MAY BE
*         DAISY CHAIN PROBLEM.)

 EPD      BSS
          LOADOVL ER2O       LOAD ERROR RECOVERY OVERLAY NUMBER 2
          LJM    EPD30
 EPD20    BSS                ENTER HERE IF ERROR AFTER SLAVE RESET
          LDDL   PTF
          NJN    EPD25       IF PATH TEST SUCCESSFUL
          LOADOVL ER2O       LOAD ERROR RECOVERY OVERLAY NUMBER 2
          RJM    OFFCM       TURN OFF ALL UNITS ON CONTROLLER (NO RETURN)
 EPD25    BSS
          RJM    INTRS       INTERMEDIATE RESPONSE
          RJM    CTR         CONFIDENCE TEST RECOVERY
          LOADOVL ER2O       LOAD ERROR RECOVERY OVERLAY NUMBER 2
          LJM    EPE10

*         IF FINAL REQUEST RETRY FAILED

 EPF      BSS
          RJM    CTR         CONFIDENCE TEST RECOVERY
          LOADOVL ER2O       LOAD ERROR RECOVERY OVERLAY NUMBER 2
          LJM    EPF20
 EPF10    BSS
          LOADOVL ER2O       LOAD ERROR RECOVERY OVERLAY NUMBER 2
          LJM    EPF28

*         ENTER HERE IF PREVIOUS LOGICAL INTERFACE RESET WORKS OR FAILS

 EPG      BSS
          LOADOVL ER2O       LOAD ERROR RECOVERY OVERLAY NUMBER 2
          LJM    EPG10
 .F       IFEQ   FE,1        FORCE ERROR CODE
          SPACE  5,20
** NAME-- FER
*
** PURPOSE-- FORCE ERROR ROUTINE.  THE ERROR CAN BE FORCED BY CHANGING
*            CENTRAL MEMORY WORD 8.  SOME ROUTINES REQUIRE THE UNIT
*            NUMBER TO BE IN CENTRAL MEMORY WORD 9.
          SPACE  2
 FERX     LJM    **
 FER      EQU    *-1
          LDN    8
          CRDL   P2          READ LOCATION WITH ERROR ROUTINE
          LDDL   P2
          ZJN    FERX        IF NOT FORCING AN ERROR
          STDL   FEST
          LPN    77B
          STDL   P6          INDEX TO TABLE
          SBN    FETND-FET
          PJN    FERX        IF UNDEFINED VALUE
          LDN    0
          STDL   P2
          LDN    8
          CWDL   P2          INDICATE ERROR BEING FORCED
          LDDL   FEST
          SHN    -8
          STDL   FEST        FORCE ERROR START COUNT
          LDDL   P3
          STDL   FEND        FORCE ERROR END COUNT OR UNIT NUMBER
          LDN    9
          CRDL   P2          READ WORD WITH UNIT NUMBER
          LDDL   P2
          STDL   FEUN        UNIT TO FORCE ERROR ON
          LDML   FET,P6
          STDL   P2
          LJM    0,P2        JUMP TO FORCE ERROR ROUTINE

*         TABLE OF ERRORS TO FORCE

 FET      BSS
          CON    FERX        NO ERROR
          CON    FERA        LOWER ICI PARITY ERROR ON READ OR WRITE
          CON    FERB        DROP SELECT DURING READ OR WRITE
          CON    FERC        LOWER ICI PARITY ERROR ON READ OR WRITE
          CON    FERD        DROP SELECT DURING READ OR WRITE
          CON    FERE        READ OR WRITE ONE TOO MANY WORDS
          CON    FERF        READ OR WRITE ONE TOO FEW WORDS
          CON    FERG        READ OR WRITE ONE TOO MANY WORDS
          CON    FERH        READ OR WRITE ONE TOO FEW WORDS
          CON    FERI        READ DATA IPI P.E. (RECOVERABLE)
          CON    FERJ        WRITE DATA IPI P.E. (RECOVERABLE)
          CON    FERK        SPIN DOWN UNIT
          CON    MAIN        INITIALIZE, RUN PATH, CONF. TEST
          CON    FERM        ILLEGAL CYLINDER FOR READ OR WRITE
          CON    FERN        LOWER ICI PARITY ERROR IN PATH TEST
          CON    FERO        UNABLE TO SELECT ERROR IN PATH TEST
          CON    FERP        ILLEGAL COUNT ERROR IN PATH TEST
          CON    FERQ        LOWER ICI PARITY ERROR IN CONFIDENCE TEST
          CON    FERR        UNABLE TO SELECT ERROR IN CONFIDENCE TEST
          CON    FERS        ILLEGAL CYLINDER ERROR IN CONFIDENCE TEST
          CON    FERT        CHANGE ONE MEMORY LOCATION
          CON    FERU        PARITY ERROR ON READ
          CON    FERV        BYTE COUNT EQUAL ZERO ON READ OR WRITE
          CON    FERW        PARITY ERROR ON WRITE
          CON    FERY        PARITY ERROR ON WRITE
          CON    FERZ        TEST MODE READ 1 TOO MANY WORDS
          CON    FERAA       PARITY ERROR ON INPUT
          CON    FERAB       PARITY ERROR ON OUTPUT
          CON    FERAC       DMA PARITY ERROR
          CON    FERAD       BYTE COUNT EQUAL ZERO ON READ OR WRITE
 FETND    BSS
          SPACE  5,20
** NAME-- FERA
*
** PURPOSE-- FORCE LOWER ICI PARITY ERROR ON READ OR WRITE (10 MB CHANNEL)
*            EB,40,XX01 YYYY
*            EB,48,CCDD
*                X = SECTORS TO TRANSFER BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*                CC = CONTROLLER NUMBER
*                DD = DRIVE NUMBER
*
** NOTE-- Y = 0 .. A  RECEOVERABLE ERROR
*             B  CHANNEL DOWNED
*         EXPECTED ERROR CODE = 0F(16)
          SPACE  2
 FERA     BSS
          LDC    FERA10
          UJN    FERB5
 FERA10   CON    0
          STDL   T3          SAVE FUNCTION
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJK    FERB25      IF WRONG DRIVE
          SODL   FEST
          PJN    FERB25      IF NOT TIME TO FORCE ERROR
          LDC    H0C22       FORCE LOWER ICI PARITY ERROR
          RJM    FUNC        SEND THE FUNCTION
          UJN    FERB15
          SPACE  5,20
** NAME--FERB
*
** PURPOSE-- DROP SELECT DURING READ OR WRITE (10 MB CHANNEL)
*            EB,40,XX02 YYYY
*            EB,48,CCDD
*                X = SECTORS TO TRANSFER BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*                CC = CONTROLLER NUMBER
*                DD = DRIVE NUMBER
          SPACE  2
 FERB     BSS
          LDC    FERB10
 FERB5    BSS
          STML   LST50
          LJM    MAIN10
 FERB10   CON    0
          STDL   T3          SAVE FUNCTION
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJN    FERB25      IF WRONG DRIVE
          SODL   FEST
          PJN    FERB25      IF NOT TIME TO FORCE ERROR
          RJM    MR          MASTER RESET
 FERB15   BSS
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERB25      IF NOT TIME TO RESTORE INSTRUCTION
 FERB20   BSS
          LDC    FUNC
          STML   LST50       RESTORE FUNCTION
 FERB25   BSS
          LDDL   T3
          RJM    FUNC        SEND FUNCTION
          LJM    LST50+1     RETURN TO CALLING ROUTINE
          SPACE  5,20
** NAME-- FERC
*
** PURPOSE-- FORCE LOWER ICI PARITY ERROR ON READ OR WRITE (25 MB CHANNEL)
*            EB,40,XX03 YYYY
*            EB,48,CCDD
*                X = SECTORS TO TRANSFER BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*                CC = CONTROLLER NUMBER
*                DD = DRIVE NUMBER
          SPACE  2
 FERC     BSS
          LDC    FERC10
          UJN    FERD5
 FERC10   CON    0
          STDL   T3          SAVE FUNCTION
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJK    FERD25      IF WRONG DRIVE
          SODL   FEST
          PJN    FERD25      IF NOT TIME TO FORCE ERROR
          LDC    H0C22       FORCE LOWER ICI PARITY ERROR
          RJM    FUNC        SEND THE FUNCTION
          UJN    FERD15
          SPACE  5,20
** NAME--FERB
*
** PURPOSE-- DROP SELECT DURING READ OR WRITE (25 MB CHANNEL)
*            EB,40,XX04 YYYY
*            EB,48,CCDD
*                X = SECTORS TO TRANSFER BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*                CC = CONTROLLER NUMBER
*                DD = DRIVE NUMBER
          SPACE  2
 FERD     BSS
          LDC    FERD10
 FERD5    BSS
          STML   HST65
          LJM    MAIN10
 FERD10   CON    0
          STDL   T3          SAVE FUNCTION
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJN    FERD25      IF WRONG DRIVE
          SODL   FEST
          PJN    FERD25      IF NOT TIME TO FORCE ERROR
          RJM    MR          MASTER RESET
 FERD15   BSS
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERD25      IF NOT TIME TO RESTORE INSTRUCTION
 FERD20   BSS
          LDC    FUNC
          STML   HST65       RESTORE FUNCTION
 FERD25   BSS
          LDDL   T3
          RJM    FUNC        SEND FUNCTION
          LJM    HST65+1     RETURN TO CALLING ROUTINE
          SPACE  5,20
** NAME-- FERE
*
** PURPOSE-- TRANSFER ONE TOO MANY WORDS (10 MB CHANNEL)
*            EB,40,0005
          SPACE  2
 FERE     BSS
          LDC    FERE15
          STML   LST80
          LDC    FERE10
          UJN    FERF5
 FERE10   CON    0
          AODL   BC          INCREMENT BY ONE BYTE
          AODL   BC
          UJN    FERF15
 FERE15   CON    0
          STDL   T3          SAVE WORDS NOT TRANSFERRED
          SODL   BC          RESTORE BYTE COUNT
          SODL   BC
          UJN    FERF25
          SPACE  5,20
** NAME-- FERF
*
** PURPOSE-- TRANSFER ONE TOO FEW WORDS (10 MB CHANNEL)
*            EB,40,0006
*
** NOTE-- EXPECTED ERROR CODE = 1B(16)
          SPACE  2
 FERF     BSS
          LDC    FERF20
          STML   LST80
          LDC    FERF10
 FERF5    BSS
          STML   LST40
          LJM    MAIN15
 FERF10   CON    0
          SODL   BC          DECREMENT BY ONE BYTE
          SODL   BC
 FERF15   BSS
          LDC    BCS         RESTORE INSTRUCTION
          STML   LST40
          LJM    LST40-3
 FERF20   CON    0
          STDL   T3          SAVE WORDS NOT TRANSFERRED
          AODL   BC          RESTORE BYTE COUNT
          AODL   BC
 FERF25   BSS
          LDC    DCN         RESTORE INSTRUCTION
          STML   LST80
          LDDL   T3
          LJM    LST80-1
          SPACE  5,20
** NAME-- FERE
*
** PURPOSE-- TRANSFER ONE TOO MANY WORDS (25 MB CHANNEL)
*            EB,40,0007
          SPACE  2
 FERG     BSS
          LDC    FERG15
          STML   HST78
          LDC    FERG10
          UJN    FERH5
 FERG10   CON    0
          AODL   BC          INCREMENT BY ONE BYTE
          AODL   BC
          UJN    FERH15
 FERG15   CON    0
          STDL   T3          SAVE WORDS NOT TRANSFERRED
          SODL   BC          RESTORE BYTE COUNT
          SODL   BC
          UJN    FERH25
          SPACE  5,20
** NAME-- FERF
*
** PURPOSE-- TRANSFER ONE TOO FEW WORDS (25 MB CHANNEL)
*            EB,40,0008
          SPACE  2
 FERH     BSS
          LDC    FERH20
          STML   HST78
          LDC    FERH10
 FERH5    BSS
          STML   HST75
          LJM    MAIN15
 FERH10   CON    0
          SODL   BC          DECREMENT BY ONE BYTE
          SODL   BC
 FERH15   BSS
          LDC    HST75+1     RESTORE INSTRUCTION
          STML   HST75
          LJM    HST75+1
 FERH20   CON    0
          STDL   T3          SAVE WORDS NOT TRANSFERRED
          AODL   BC          RESTORE BYTE COUNT
          AODL   BC
 FERH25   BSS
          LDC    DCN         RESTORE INSTRUCTION
          STML   HST78
          LDDL   T3
          LJM    HST78-1
          SPACE  5,20
** NAME-- FERI
*
** PURPOSE-- FORCE IPI PARITY ERROR ON INPUT DURING READ (10 MB CHANNEL)
*            EB,40,0009
** NOTE-- EXPECTED ERROR CODE = 19(16)
          SPACE  2
 FERI     BSS
          LDC    FERI10
          UJN    FERJ5
 FERI10   CON    0
          STDL   T3          SAVE FUNCTION
          LDC    H0322       FORCE BUS A INPUT PARITY ERROR
          UJN    FERJ20
          SPACE  5,20
** NAME-- FERJ
*
** PURPOSE-- FORCE IPI PARITY ERROR ON OUTPUT DURING WRITE (10 MB CHANNEL)
*            EB,40,000A
          SPACE  2
 FERJ     BSS
          LDC    FERJ10
 FERJ5    BSS
          LJM    FERB5
 FERJ10   CON    0
          STDL   T3          SAVE FUNCTION CODE
          LDC    H0122
 FERJ20   BSS
          RJM    FUNC        FORCE BUS A OUTPUT PARITY ERROR
          LJM    FERB20
          SPACE  5,20
** NAME-- FERK
*
** PURPOSE-- SPIN DOWN UNIT TO FORCE NOT READY ERROR
*            EB,40,000B CCDD
*                C = CONTROLLER NUMBER
*                D = LOGICAL UNIT
*            EB,4C,EE00
*                E = DRIVE TO SPIN DOWN
*         THIS SHOULD ONLY BE USED WHEN THERE ARE NO OUTSTANDING
*         COMMANDS TO THE CONTROLLER.
          SPACE  2
 FERK     BSS
          LDN    14
          STML   CP          PACKET LENGTH
          STML   CP+CRN      COMMAND REFERENCE NUMBER
          LDC    H0700       SET OPERATING MODE COMMAND
          STML   CP+OPCD     OPERATION
          LDDL   FEND
          STML   CP+SLAD     CONTROLLER, UNIT NUMBER
          SHN    -8
          STDL   CMOD        CONTROLLER NUMBER
          LDC    0#351       DISC MODES
          STML   CP+FCP
          LDC    0#4000
          STML   CP+FCP+1    SPIN DOWN UNIT
          LDC    0#2D5
          STML   CP+FCP+2
          LDDL   P4
          STML   CP+FCP+3    DRIVE TO SPIN DOWN
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LJM    MAIN15
          SPACE  5,20
** NAME-- FERM
*
** PURPOSE-- CHANGE CYLINDER NUMBER TO ILLEGAL VALUE
*            TO FORCE AN ERROR ON WRITE OR READ
*            EB,40,XX0D YYYY
*            EB,48,CCDD
*                X = COMMANDS TO SEND BEFORE FORCING FIRST ERROR
*                Y + 1 = TIMES TO FORCE THE ERROR
*                CC = CONTROLLER NUMBER
*                DD = DRIVE NUMBER
*
** NOTE-- Y = 0 .. 3  RECOVERABLE ERROR
*             4  MEDIA ERROR
*         EXPECTED ERROR CODE = 49(16)
          SPACE  2
 FERM     BSS
          LDC    FERM10
          STML   SEEK20
          LJM    MAIN10
 FERM10   CON
          LDDL   FEUN
          LMML   /SS/P.UNIT,CSST
          NJN    FERM20      IF WRONG DRIVE
          SODL   FEST
          PJN    FERM20      IF NOT TIME TO FORCE ERROR
          LCN    0
          STML   CP+FCP+3    ILLEGAL CYLINDER NUMBER
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERM20      IF NOT TIME TO RESTORE INSTRUCTION
          LDC    CPT
          STML   SEEK20      RESTORE INSTRUCTION
 FERM20   BSS
          RJM    CPT         COMMAND PACKET TRANSFER
          LJM    SEEK20+1    RETURN TO SEEK ROUTINE
          SPACE  5,20
** NAME-- FERN
*
** PURPOSE-- FORCE LOWER ICI PARITY ERROR IN PATH TEST
*            EB,40,XX0E YYYY
*                X = TIMES TO RUN PATH TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERN     BSS
          LDC    FERN10
          UJN    FERP5
 FERN10   CON    0
          SODL   FEST
          PJN    FERP20      IF NOT TIME TO FORCE ERROR
          LDC    H0C22       FORCE LOWER ICI PARITY ERROR
          RJM    FUNC        SEND THE FUNCTION
          UJN    FERP30
          SPACE  5,20
** NAME-- FERO
*
** PURPOSE-- DISABLE THE CONTROLLERS RECEIVERS TO PREVENT SELECTING
*            DURING THE PATH TEST
*            EB,40,XX0F YYYY
*                X = TIMES TO RUN PATH TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERO     BSS
          LDC    FERO10
          UJN    FERP5
 FERO10   CON    0
          SODL   FEST
          PJN    FERP20      IF NOT TIME TO FORCE ERROR
          RJM    MR          MASTER RESET
          UJN    FERP30
          SPACE  5,20
** NAME--FERP
*
** PURPOSE-- FORCE COMMAND EXCEPTION DURING THE PATH TEST
*            BY SENDING AN ILLEGAL BYTE COUNT
*            EB,40,XX10 YYYY
*                X = TIMES TO RUN PATH TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*
** NOTE-- Y = 0 .. 3  RECOVERABLE ERROR
*             4  CONTROLLER DOWNED
*         EXPECTED ERROR CODE = 49(16)
          SPACE  2
 FERP     BSS
          LDC    FERP10
 FERP5    BSS
          STML   CPTB10
          LJM    MAIN10
 FERP10   CON    0
          SODL   FEST
 FERP20   BSS
          PJN    FERP40      IF NOT TIME TO FORCE ERROR
          LCN    0
          STML   CP+FCP+1    ILLEGAL COUNT
 FERP30   BSS
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERP40      IF NOT TIME TO RESTORE INSTRUCTION
          LDC    CPT
          STML   CPTB10      RESTORE INSTRUCTION
 FERP40   BSS
          RJM    CPT         COMMAND PACKET TRANSFER
          LJM    CPTBX       RETURN TO PATH TEST
          SPACE  5,20
** NAME-- FERQ
*
** PURPOSE-- FORCE LOWER ICI PARITY ERROR IN CONFIDENCE TEST
*            EB,40,XX11 YYYY
*                X = TIMES TO RUN CONFIDENCE TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERQ     BSS
          LDC    FERQ10
          UJN    FERS5
 FERQ10   CON    0
          SODL   FEST
          PJN    FERS20      IF NOT TIME TO FORCE ERROR
          LDC    H0C22       FORCE LOWER ICI PARITY ERROR
          RJM    FUNC        SEND THE FUNCTION
          UJN    FERS30
          SPACE  5,20
** NAME-- FERR
*
** PURPOSE-- DISABLE THE CONTROLLERS RECEIVERS TO PREVENT SELECTING
*            DURING THE CONFIDENCE TEST
*            EB,40,XX12 YYYY
*                X = TIMES TO RUN CONFIDENCE TEST BEFORE FORCING FIRST ERROR
*                Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERR     BSS
          LDC    FERR10
          UJN    FERS5
 FERR10   CON    0
          SODL   FEST
          PJN    FERS20      IF NOT TIME TO FORCE ERROR
          RJM    MR          MASTER RESET
          UJN    FERS30
          SPACE  5,20
** NAME--FERS
*
** PURPOSE-- FORCE COMMAND EXCEPTION DURING THE CONFIDENCE TEST
*            BY SENDING AN ILLEGAL CYLINDER NUMBER
*            EB,40,XX13 YYYY
*              X = TIMES TO RUN CONFIDENCE TEST BEFORE FORCING FIRST ERROR
*              Y + 1 = NUMBER OF TIMES TO FORCE THE ERROR
*
** NOTE-- Y = 0 .. 4  RECOVERABLE ERROR
*             5  DRIVE DOWNED
*         EXPECTED ERROR CODE = 49(16)
          SPACE  2
 FERS     BSS
          LDC    FERS10
 FERS5    BSS
          STML   CPTA10
          LJM    MAIN15
 FERS10   CON    0
          SODL   FEST
 FERS20   BSS
          PJN    FERS40      IF NOT TIME TO FORCE ERROR
          LCN    0
          STML   CP+FCP+3    ILLEGAL CYLINDER NUMBER
 FERS30   BSS
          LDN    0
          STDL   FEST        TO CONTINUE FORCING ERROR
          SODL   FEND
          PJN    FERS40      IF NOT TIME TO RESTORE INSTRUCTION
          LDC    CPT
          STML   CPTA10      RESTORE INSTRUCTION
 FERS40   BSS
          RJM    CPT         COMMAND PACKET TRANSFER
          LJM    CPTAX       RETURN TO CONFIDENCE TEST
          SPACE  5,20
** NAME-- FERT
*
** PURPOSE-- CHANGE ONE MEMORY LOCATION
*            EB,40,0014
*            EB,48,0000 0000 XXXX YYYY
*              X = ADDRESS
*              Y = VALUE
          SPACE  2
 FERT     BSS
          LDDL   P5
          STIL   P4
          LJM    MAIN10
          SPACE  5,20
** NAME-- FERU
*
** PURPOSE-- FORCE DMA INPUT DATA PARITY ERROR UPPER (10 MB CHANNEL)
*            EB,40,0015
          SPACE  2
 FERU     BSS
          LDC    FERU5
          UJN    FERV5
 FERU5    CON    0
          STDL   T3          SAVE FUNCTION CODE
          LDC    H0300       WRITE CONTROL REGISTER
          RJM    FAN
          LDC    0#8A        FORCE PARITY ERROR
          UJN    FERV15
          SPACE  5,20
** NAME-- FERV
*
** PURPOSE-- FORCE BYTE COUNT EQUAL 0 ON JY BOARD (10 MB CHANNEL)
*            EB,40,0016
          SPACE  2
 FERV     BSS
          LDC    FERV10
 FERV5    BSS
          LJM    FERB5
 FERV10   CON    0
          STDL   T3          SAVE FUNCTION CODE
          LDC    H0300       WRITE CONTROL REGISTER
          RJM    FAN
          LDC    0#96        FORCE BYTE COUNT EQUAL 0
 FERV15   BSS
          ACN    DC
          OAN    DC
          LJM    FERB20
          SPACE  5,20
** NAME-- FERW
*
** PURPOSE-- FORCE OUTPUT DATA PARITY ERROR UPPER (10 MB CHANNEL)
*            EB,40,0017
          SPACE  2
 FERW     BSS
          LDC    FERW5
          UJN    FERY5
 FERW5    CON    0
          STDL   T3          SAVE FUNCTION CODE
          LDC    H0300       WRITE CONTROL REGISTER
          RJM    FAN
          LDC    0#8C        FORCE PARITY ERROR
          UJN    FERY15
          SPACE  5,20
** NAME-- FERY
*
** PURPOSE-- FORCE DMA OUTPUT PARITY ERROR (25 MB CHANNEL)
*            EB,40,0018
          SPACE  2
 FERY     BSS
          LDC    FERY10
 FERY5    BSS
          LJM    FERD5
 FERY10   CON    0
          STDL   T3          SAVE FUNCTION CODE
          LDC    H0300       WRITE CONTROL REGISTER
          RJM    FAN
          LDC    0#4013      FORCE PARITY ERROR
 FERY15   BSS
          ACN    DC
          OAN    DC
          LJM    FERD20
          SPACE  5,20
** NAME-- FERZ
*
** PURPOSE-- FORCE ERROR IN TEST MODE BY READING ONE MORE WORD
*            THAN THE TRANSFER COUNT EXPECTS.
*            EB,40,XX19
*                XX = NUMBER OF TIMES TO FORCE THE ERROR
*
** NOTE-- EXPECTED ERROR CODE = 1D(16) FOR THE RECOVERABLE ERROR
          SPACE  2
 FERZ     BSS
          LDC    FERZ5
          STML   WOG10
          LJM    MAIN10
 FERZ5    CON    0
          STDL   T3          SAVE FUNCTION
          LDML   TMWC,CH
          ADN    1
          STML   WOGP+1      INCREMENT SYNC COUNT
          LDDL   FEST
          ZJN    FERZ10      IF NOT FORCING AN ERROR
          SODL   FEST
          UJN    FERZ15
 FERZ10   BSS
          LDC    FUNC        RESTORE INSTRUCTION
          STML   WOG10
          SOML   WOGP+1      RESTORE BYTE COUNT
 FERZ15   BSS
          LDDL   T3
          RJM    FUNC
          LJM    WOG10+3
          SPACE  5,20
** NAME-- FERAA
*
** PURPOSE-- FORCE IPI PARITY ERROR ON INPUT (25 MB CHANNEL)
*                EB,40,001A
          SPACE  2
 FERAA    BSS
          LDC    FERAA10
          UJN    FERAB5
 FERAA10  CON    0
          STDL   T3          SAVE FUNCTION
          LDC    H0322       FORCE BUS A INPUT PARITY ERROR
          UJN    FERAB20
          SPACE  5,20
** NAME-- FERAA
*
** PURPOSE-- FORCE IPI PARITY ERROR ON OUTPUT (25 MB CHANNEL)
*                EB,40,001B
          SPACE  2
 FERAB    BSS
          LDC    FERAB10
 FERAB5   BSS
          LJM    FERD5
 FERAB10  CON    0
          STDL   T3          SAVE FUNCTION
          LDC    H0122       FORCE BUS A OUTPUT PARITY ERROR
 FERAB20  BSS
          RJM    FUNC
          LJM    FERD20
          SPACE  5,20
** NAME-- FERAC
*
** PURPOSE-- FORCE UPPER DMA PARITY ERROR (25 MB CHANNEL)
*                EB,40,001C
          SPACE  2
 FERAC    BSS
          LDC    FERAC5
          UJN    FERAD5
 FERAC5   CON    0
          STDL   T3          SAVE FUNCTION CODE
          LDC    H0300       WRITE CONTROL REGISTER
          RJM    FAN
          LDC    0#4090      FORCE PARITY ERROR
          UJN    FERAD20
          SPACE  5,20
** NAME-- FERAD
*
** PURPOSE-- FORCE BYTE COUNT EQUAL 0 (25 MB CHANNEL)
*                EB,40,001D
          SPACE  2
 FERAD    BSS
          LDC    FERAD10
 FERAD5   BSS
          LJM    FERD5
 FERAD10  CON    0
          STDL   T3          SAVE FUNCTION CODE
          LDC    H0300       WRITE CONTROL REGISTER
          RJM    FAN
          LDC    0#4096      FORCE BYTE COUNT EQUAL 0
 FERAD20  BSS
          ACN    DC
          OAN    DC
          LJM    FERD20
 .F       ENDIF
          SPACE  5,20
** NAME-- FORMA
*
** PURPOSE-- FORMAT A CM REAL MEMORY ADDRESS.
*
** ENTRY--  A = ADDRESS OF A 2-WORD CM BYTE ADDRESS.
*
** EXIT--  CMADR- IS THE ADDRESS OF THE RESULTING 3-WORD REFORMATED
*          CM ADDRESS.  THE FORMAT CAN BE USED BY THE LOADC MACRO.
*           -ADDRESS-, WORD 0, BITS 0-13 AND
*                      WORD 1, BITS 3-15, ARE REFORMATTED TO-
*           -CMADR-,   WORD 0, BITS 0-9,
*                      WORD 1, BITS 0-11,
*                      WORD 2, BITS 0-5.
          SPACE  2
 FORX     LJM    **
 FORMA    EQU    *-1
          STDL   T1
          LDML   1,T1
          LPN    7
          NJN    FOR10       RMA ADDRESS ERROR
          LDIL   T1
          LPN    37B
          SHN    16
          LMML   1,T1
          SHN    9
          STD    CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   T1
          SHN    -5
          STD    CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMC    400000B
          UJK    FORX
 FOR10    BSS
          LDC    E304        RMA NOT WORD BOUNDARY
          RJM    INTERR      REPORT ERROR (NO RETURN)
          SPACE  5,20
** NAME-- GETR
*
** PURPOSE-- DETERMINE WHETHER OR NOT TO USE MASTER TERMINATE.
*            MASTER TERMINATE MEANS USE A LARGE SECTOR COUNT AND
*            TERMINATE WHEN THERE IS NO MORE DATA TO TRANSFER.
*            SINCE THERE IS A PERFORMANCE PENALTY ON READS, ONLY
*            USE MASTER TERMINATE FOR READS WHEN MORE THAN ONE PAGE
*            IS TO BE TRANSFERRED.  IF USING MASTER TERMINATE, SET
*            THE MASTER TERMINATE FLAG AND EXIT.
*
*            IF NOT USING MASTER TERMINATE, COMPUTE
*            THE TOTAL SECTORS TO TRANSFER AND SAVE IN SS TABLE.
*            THE PP DRIVER WILL ISSUE UP TO 2 COMMANDS PER DRIVE.
*            IF NO COMMANDS ARE OUTSTANDING, GET THE FIRST REQUEST
*            FROM CM, GET THE FIRST COMMAND FROM THE REQUEST AND SET
*            UP THE STATUS RESPONSE BUFFER.  IF ONE COMMAND IS STILL
*            ACTIVE FOR THE DRIVE, GETTING THE REQUEST INTO THE SS
*            TABLE WILL BE DONE IN ROUTINE DCR.
          SPACE  2
 GETRX    LJM    **
 GETR     EQU    *-1
          LDN    0
          STML   CP+FCP+1    UPPER WORD OF SECTOR COUNT
          LDDL   CSST
          STDL   P5          SAVE CURRENT SS TABLE POINTER
          LDC    IPIT
          STDL   CSST        START OF ALTERNATE SS TABLE
          LDDL   CNUM
          ZJN    GETR5       IF FIRST COMMAND
          LDML   /SS/P.RMA2,P5
          STML   /SS/P.REQ,CSST
          LDML   /SS/P.RMA2+1,P5
          UJN    GETR10
 GETR5    BSS
          LDML   /SS/P.REQ,P5
          STML   /SS/P.REQ,CSST
          LDML   /SS/P.REQ+1,P5
 GETR10   BSS
          STML   /SS/P.REQ+1,CSST
          RJM    UREQ        READ UNIT REQUEST FROM CM
          LDML   CM+/CM/P.CODE,CSST
          SHN    -12
          SBN    4
          STDL   FNC         SAVE FUNCTION
          LDML   RQ+/RQ/P.CYL,CSST
          STML   CP+FCP+3    CYLINDER
          LDML   RQ+/RQ/P.TRACK,CSST
          SHN    8
          ADML   RQ+/RQ/P.SECTOR,CSST
          STML   CP+FCP+4    HEAD, SECTOR

*         IF IN RECOVERY AND USING MASTER TERMINATE, THIS GUARANTEES A
*         WRITE ERROR FOR THE NTH REQUEST DOES NOT RETURN AN ERROR FOR
*         A PREVIOUS REQUEST.

          LDML   RQ+/RQ/P.SWIT,CSST
          LPC    777B
          STDL   TOTAL       SECTOR COUNT FOR REQUEST
          LDML   /SS/P.RQTRY,P5
          NJN    GETR30      IF IN ERROR RECOVERY
          LDM    /SS/P.DT,P5
          SHN    -4
          SBN    2
          MJN    GETR30      NO MASTER TERMINATE IF 5832
          LDDL   FNC
          SBN    1
          ZJN    GETR15      IF WRITE (USE MASTER TERMINATION)
          LDDL   TOTAL
          SBN    1
          ZJN    GETR30      IF MAU COUNT = 1 (NO MASTER TERMINATION)
          LDML   CM+/CM/P.LEN,CSST
          SBN    8
          ZJN    GETR30      IF ONLY ONE LIST
 GETR15   BSS
          LDDL   P5
          STDL   CSST        RESTORE POINTER TO SS TABLE
          LDDL   CNUM
          ZJN    GETR38      IF FIRST COMMAND FOR UNIT
          LDC    0#8000
          ADDL   TOTAL
          UJN    GETR35
 GETR30   BSS
          LDDL   P5
          STDL   CSST        RESTORE POINTER TO SS TABLE
          LDDL   CNUM
          ZJN    GETR40      IF FIRST COMMAND FOR UNIT
          LDDL   TOTAL
 GETR35   BSS
          STML   /SS/P.TW2,CSST
          UJN    GETR50
 GETR38   BSS
          LDC    0#8000
 GETR40   BSS
          ADDL   TOTAL
          STML   /SS/P.TOTAL,CSST
          RJM    UREQ        READ UNIT REQUEST FROM CM
          RJM    SRESP       SET UP STATUS FOR RESPONSE BUFFER
          RJM    SETRQ       SET UP FOR FIRST REQUEST
          RJM    UNCMND      GET FIRST COMMAND
 GETR50   BSS
          UJK    GETRX
          SPACE  5,20
** NAME-- GETSS
*
** PURPOSE-- READ SS TABLE FROM UNIT COMMUNICATION BUFFER IN
*            CM UNIT INTERFACE TABLE IF IT IS NOT ALREADY IN MEMORY
          SPACE  2
 GETSSX   LJM    **
 GETSS    EQU    *-1
          LDML   UNITS+/UN/P.SSPTR,UX
          STDL   CSST        SET INDEX TO SS TABLE
          NJN    GETSSX      IF TABLE IN MEMORY
          LDC    SSNR
          STDL   CSST        POINTER TO CURRENT SS TABLE
          LDDL   UX
          SBDL   SSUN        UX OF CURRENT SS TABLE
          ZJN    GETSSX      IF SS TABLE ALREADY IN MEMORY
          RJM    SAVSS       SAVE SS TABLE BEFORE READING ANOTHER SS TABLE
          LDDL   UX
          STDL   SSUN        SAVE UX OF NEW SS TABLE
          LOADR  UNITS+/UN/P.UIT,UX
          ADN    /UIT/C.UBUF  OFFSET OF COMMUNICATION BUFFER
          CRDL   T1          GET ADDRESS OF COMMUNICATION BUFFER
          LDML   UNITS,UX
          SHN    -5
          LPN    40B
          STDL   T2          COMPUTE OFFSET INTO UNIT COMMUNICATIONS BUFFER
          LOADF  T3          REFORMAT IT AND LOAD R REGISTER
          ADDL   T2          OFFSET 0 OR 100(16) BYTES INTO BUFFER
          CRML   SSNR,WC     READ SS TABLE
          UJK    GETSSX
          SPACE  5,20
** NAME-- GETU
*
** PURPOSE-- GET A UNIT REQUEST FROM CENTRAL, ISSUE ALL
*            SEEKS, AND PROCESS INTERRUPTS FROM THE CONTROLLER
          SPACE  2
 GETUX    LJM    **
 GETU     EQU    *-1
          LDDL   UNUML
          ZJN    GETUX       IF NO UNITS
          RJM    UC          UPDATE CLOCK
          RJM    SIS         SAVE INTERRUPT STATUS
          LDDL   LUX         UNIT INDEX OF LAST REQUEST FOUND + 1
          STDL   P6
 GETU5    BSS
          LDDL   LUX
          STDL   UX
          LDN    P.UN
          RADL   LUX         BUMP UNIT ENTRY
          SBDL   UNUML
          MJN    GETU10      IF NOT END OF TABLE
          STDL   LUX
 GETU10   BSS
          LDML   UNITS,UX
          SHN    -/UN/N.UNIT
          LPN    17B
          STDL   CMOD        SAVE CONTROLLER NUMBER AND PORT NUMBER
          LDML   UNITS,UX
          SHN    /UN/L.CIP+2
          PJK    GETU50      IF NO COMMAND IN PROGRESS
          LDML   UNITS,UX
          SHN    /UN/L.PORT+2
          PJN    GETU15      IF PORT A
          LDML   SELT,CMOD
          LPDL   STATUS+1
          UJN    GETU20
 GETU15   BSS
          LDML   SELT,CMOD   MASK VALUE
          LPDL   STATUS      INTERRUPT STATUS
 GETU20   BSS
          ZJN    GETU24      IF NO INTERRUPT FOR THIS CONTROLLER
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          RJM    PI          PROCESS INTERRUPT (NO RETURN)
 GETU24   BSS
          LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          PJN    GETU40      IF 2ND COMMAND CAN BE ISSUED
 GETU25   BSS
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    GETU30      IF CLOCK HASNT WRAPPED
          ADC    0#10000
 GETU30   BSS
          SBN    CMT         COMMAND TIMEOUT
          PJK    GETU95      IF TIMEOUT

*         GO TO NEXT UNIT ENTRY.

 GETU35   BSS
          LDDL   LUX         HAVE ALL ENTRIES BEEN CHECKED
          SBDL   P6
          ZJK    GETUX       IF NO MORE ENTRIES TO CHECK
          UJK    GETU5

*         ONE COMMAND IN PROGRESS

 GETU40   BSS
          LDDL   CMNDS
          SBN    32
          PJK    GETU25      IF 32 SEEKS ISSUED
          STDL   CNUM        INDICATE SECOND COMMAND TO UNIT
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LDDL   IF
          ZJN    GETU45      IF NO INITIALIZATION NECESSARY
          LDML   /SS/P.CT,CSST
          LPN    7
          NJN    GETU25      IF CONFIDENCE TEST ALREADY RUN
          LDDL   CMNDS
          NJN    GETU35      IF OUTSTANDING COMMANDS
          STML   /SS/P.CT,CSST  IN CASE ASYNCH FOR PARITY DRIVE
          LOADOVL CDO        LOAD CHECK DRIVE OVERLAY
          RJM    CD          CHECK DRIVE
          STDL   T5
          LOADOVL CTO        LOAD CONFIDENCE TEST OVERLAY
          LDDL   T5
          NJN    GETU42      IF ERROR OR OFF LINED DRIVE
          RJM    CDA         CHECK DRIVE ATTRIBUTES
 GETU42   BSS
          RJM    CT          CONFIDENCE TEST
          LJM    GETUX
 GETU45   BSS
          LDML   /SS/P.CT,CSST
          LPN    7
          ZJK    GETU25      IF CONFIDENCE TEST SHOULD BE RUN
          LDDL   MALET
          NJK    GETU25      IF MAINTENANCE REQUEST
          LDML   UNITS,UX
          LPC    0#A00
          NJK    GETU25      IF RESTORE OR INITIALIZE ATTRIBUTES
          LDML   /SS/P.RQTRY,CSST
          NJK    GETU25      IF IN ERROR RECOVERY
          RJM    SR          SELECT REQUEST
          NJK    GETU25      IF REQUEST NOT FOUND
          RJM    GETR        GET REQUEST
          LDML   IPIT+CM+/CM/P.CODE
          SHN    -8
          LMC    C.FORMAT
          ZJK    GETU25      IF FORMAT COMMAND
          LJM    GETU85

*         NO COMMAND IN PROGRESS

 GETU50   BSS
          LDDL   IF
          NJK    GETU35      IF INITIALIZATION FLAG SET
          LDML   UNITS,UX
          SHN    /UN/L.ACIP+2
          PJK    GETU55      IF NO COMMAND IN PROGRESS FOR ALTERNATE ACCESS
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.ULOCK  INDEX TO LOCKWORD
          CRDL   T1          READ LOCKWORD
          LDDL   T1
          ZJN    GETU52      IF UNIT NOT LOCKED
          LDDL   T4
          SBDL   LPN
          NJK    GETU35      IF ALTERNATE PP HAS THE LOCK
 GETU52   BSS
          LDML   UNITS,UX
          LPC    0#DFFF
          STML   UNITS,UX    CLEAR ALTERNATE COMMAND IN PROGRESS BIT
          SHN    -3
          LPN    77B
          STDL   P1          INDEX TO UPASB TABLE
          SOML   UPASB,P1    DECREMENT UNITS PER ALTERNATE PATH STRING BUSY COUNTER
          NJN    GETU55      IF OTHER UNITS ON ALTERNATE STRING ARE BUSY
          SOML   APSB        DECREMENT ALTERNATE PATH STRINGS BUSY COUNTER

*         CHECK FOR ANY REQUESTS ON THIS UNIT QUEUE.

 GETU55   BSS
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T5          READ UNIT DISABLED FLAG
          ADN    /UIT/C.ULOCK  INDEX TO LOCKWORD
          CRDL   P2          READ LOCKWORD
          LDDL   T8          QUEUE COUNT
          NJN    GETU56      IF REQUEST ON QUEUE
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          PJK    GETU35      IF RESTORE NOT IN PROGRESS
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LDN    0
          STML   RTM,CSST    REQUESTS TO MULTIPLEX
 GETU56   BSS
          LDDL   T5+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJK    GETU35      IF UNIT DISABLED
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LDML   UNITS,UX
          SHN    -3
          LPN    77B
          STDL   P1          INDEX TO UPSB AND UPASB TABLES
          LDDL   P3
          ADDL   P4
          ZJN    GETU60      IF NO ALTERNATE ACCESS
          SBDL   LPN
          ZJN    GETU60      IF NO ALTERNATE ACCESS
          LDDL   P2
          ZJN    GETU58      IF UNIT NOT LOCKED
          LDDL   P5
          SBDL   LPN
          NJK    GETU65      IF ALTERNATE PP HAS THE UNIT
          UJN    GETU60
 GETU58   BSS
          LDML   UPSB,P1
          SBML   UPASB,P1
          MJN    GETU60      IF THIS PP SHOULD ISSUE THE SEEK
          NJN    GETU65      IF ALTERNATE PP SHOULD ISSUE THE SEEK
          LDML   APSB
          SBML   PSB
          MJN    GETU65      IF ALTERNATE PP SHOULD ISSUE THE SEEK
 GETU60   BSS
          LDDL   CMNDS
          SBN    32
          PJN    GETU65      IF 32 SEEKS ISSUED
          LDML   /SS/P.RQTRY,CSST
          NJN    GETU62      IF IN ERROR PROCESSING FOR THIS UNIT
          LDDL   MALET
          NJN    GETU70      IF MAINTENANCE REQUEST
 GETU62   BSS
          RJM    LUT         LOCK UNIT TABLE
          NJN    GETU65      IF LOCK UNSUCCESSFUL
          STDL   CNUM        INDICATE 1ST COMMAND TO UNIT
          AOML   UPSB,P1     INCREMENT UNITS PER STRING BUSY COUNTER
          SBN    1
          NJN    GETU75      IF STRING ALREADY HAS A BUSY UNIT
          AOML   PSB         INCREMENT PATH STRINGS BUSY
          UJN    GETU75
 GETU65   BSS
          LDML   UNITS,UX
          LMC    0#2000
          STML   UNITS,UX    SET ALTERNATE COMMAND IN PROGRESS
          AOML   UPASB,P1    INCREMENT UNITS PER ALTERNATE STRING BUSY COUNTER
          SBN    1
          NJN    GETU70      IF NOT 1ST BUSY UNIT ON ALTERNATE STRING
          AOML   APSB        INCREMENT ALTERNATE PATH STRINGS BUSY COUNTER
 GETU70   BSS
          UJK    GETU35
 GETU75   BSS
          LDML   UNITS,UX
          SHN    /UN/L.PDCE+2
          PJN    GETU76      IF PARITY DRIVE CORRECTION DISABLED
          LDML   /SS/P.RQTRY,CSST
          NJN    GETU76      IF IN ERROR PROCESSING FOR THIS UNIT

*         INITIALIZE DRIVE ATTRIBUTES TO DISABLE PARITY DRIVE CORRECTION.

          LDC    H0202       RESTORE ATTRIBUTES OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
*         LDML   UNITS,UX    INDICATE ONE COMMAND IN PROGRESS
          LMC    0#8000
          STML   UNITS,UX
          AODL   CMNDS
          LDDL   UX
          STML   CP+CRN      COMMAND REFERENCE NUMBER
          LDN    6
          STML   CP          COMMAND PACKET LENGTH
          RJM    CPT         COMMAND PACKET TRANSFER
          UJK    GETU90
 GETU76   BSS
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          PJN    GETU78      IF NOT RESTORING DRIVE
          LDML   RTM,CSST    REQUESTS TO MULTIPLEX
          NJN    GETU78      IF NOT TIME TO RESTORE
          LDML   /SS/P.CT,CSST
          LPN    7
          NJN    GETU77      IF DON'T NEED TO RUN CONFIDENCE TEST
          AOML   RTM,CSST    FORCE REQUEST TO BE PRESENT TO RUN CONFIDENCE TEST
          RJM    DUBC        DECREMENT UNIT BUSY COUNTER
          UJK    GETU90
 GETU77   BSS
          LOADOVL CTO        LOAD CONFIDENCE TEST OVERLAY
          RJM    IRD         ISSUE RESTORE DRIVE
          UJN    GETU90
 GETU78   BSS
          RJM    SR          SELECT REQUEST
          NJK    GETU75      IF QUEUE LOCK NOT OBTAINED
          RJM    GETR        GET REQUEST
          LDML   /SS/P.CT,CSST
          LPN    7
          ZJN    GETU80      IF CONFIDENCE TEST NOT RUN
          LDDL   FNC
          SBN    2
          NJN    GETU85      IF NOT FORMAT
          LOADOVL CTO
          RJM    PFMT        PROCESS FORMAT PARAMETER
          NJN    GETU90      IF FORCE FORMAT FUNCTION
 GETU80   BSS
          LDML   UNITS,UX    SET COMMAND IN PROGRESS
          LMC    0#8000
          STML   UNITS,UX
          STDL   IF          SET INITIALIZATION FLAG
          UJN    GETU90
 GETU85   BSS
          RJM    SEEK        ISSUE INITIAL SEEK
 GETU90   BSS
          LJM    GETUX
 GETU95   BSS
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LDML   /SS/P.RESET,CSST
          ZJN    GETU120     IF RESET NOT ISSUED
          LDML   EPCT,CMOD
          SBDL   UX
          NJN    GETU115     IF DIFFERENT UNIT
          LDC    SRT         SLAVE RESET TIMEOUT
          STDL   T1
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    GETU110     IF CLOCK HASNT WRAPPED
          ADC    0#10000
 GETU110  BSS
          SBDL   T1
          PJN    GETU120     IF TIMEOUT
 GETU115  BSS
          LJM    GETU35
 GETU120  BSS
          LDN    E38         NO CONTROLLER RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 HSTF     BSSZ   1           HEAD SHIFT TEST FLAG
          SPACE  5,20
** NAME-- GLIST
*
** PURPOSE-- READ ONE ENTRY FROM THE CM ADDRESS LIST PORTION OF A COMMAND.
*
** ENTRY-- LISTL
*
** EXIT-- CMLIST, CM+/CM/P.RMA
          SPACE  2
 GLIX     LJM    **
 GLIST    EQU    *-1
          LDDL   CSST        ADDRESS OF SS TABLE
          ADK    CMLIST
          STML   GLIST4      ADDRESS TO STORE CM LIST
          LDN    1
          STDL   WC          NUMBER OF CM WORDS TO READ
          LOADF  CM+/CM/P.RMA,CSST  LOAD CM ADDRESS AND REFORMAT
          CRML   *,WC        READ ONE ENTRY FROM THE CM LIST
 GLIST4   EQU    *-1
          LDN    8
          RAML   CM+/CM/P.RMA+1,CSST  UPDATE RMA ADDRESS FOR NEXT READ
          SHN    -16
          RAML   CM+/CM/P.RMA,CSST
          LDML   CMLIST+/CM/P.LEN,CSST  MAKE SURE IT IS AN EVEN NUMBER OF CM WORDS
          ADN    7
          SCN    7
          STML   CMLIST+/CM/P.LEN,CSST
          UJK    GLIX
          SPACE  5,20
** NAME-- IDTP
*
** PURPOSE-- INPUT DATA TO PP (RPB+8)
*
** ENTRY  A = COMMAND PACKET LENGTH
*
** EXIT   TO CALLING ROUTINE IF NO ERROR
          SPACE  2
 IDTPX    LJM    **
 IDTP     EQU    *-1
          STML   CP          COMMAND PACKET LENGTH
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    IDTP50      IF NOT TRANSFER NOTIFICATION RESPONSE
          RJM    VRP         VERIFY RESPONSE PACKET
          LDC    ID6D
          RJM    SFP         SEARCH FOR PARAMETER
          MJK    IDTP50      IF ID 6D NOT FOUND
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAIN      DATA TRANSFER IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDDL   MFID        MASK FOR INTERLOCK DATA
          LPN    1
          SHN    9
          LMC    H0281       STREAM, READ
          RJM    FUNC        RAISE MASTER OUT
          LDML   CP+OPCD
          LMC    0#8400
          NJN    IDTP10      IF NOT READ ERROR LOG
          LDC    H0C00       DMA READ
          RJM    FUNC
          ACN    DC
          LDML   RPB+5+2,T3  BYTE LENGTH OF RESPONSE
          LPC    0#1FFF      ENSURE BUFFER IS NOT OVERFLOWED
          STDL   T5
          STML   CM.CB.T
          LDN    3
          OAM    CM.CB.T,DC  BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
          LDN    0
          STDL   WC
          STML   /SS/P.TOTAL,CSST  SO THERE IS NO SOFTWARE MASTER TERMINATE
          RJM    WFTC        WAIT FOR TRANSFER COMPLETE
          UJN    IDTP45
 IDTP10   BSS
          ACN    DC
          LDML   RPB+5+2,T3
          STDL   T5
          ADN    1           IN CASE OF ODD BYTE LENGTH
          SHN    -1          PP WORDS TO INPUT
          LPC    377B        PROTECT AGAINST ILLEGAL LENGTH
          IAM    RPB+8,DC
          STDL   WC          WORDS NOT TRANSFERRED
          LDC    MS50
 IDTP30   BSS
          IJM    IDTP40,DC   IF SLAVE IN DROPPED
          SBN    1
          NJN    IDTP30      IF TIMEOUT NOT EXPIRED
          LDN    E30         CHANNEL STAYED ACTIVE
          UJN    IDTP70
 IDTP40   BSS
          LDN    0
          RJM    GES         GET ENDING STATUS
 IDTP45   BSS
          RJM    DCM         DESELECT THE CONTROLLER
          LDDL   WC
          NJN    IDTP60      IF NOT ALL WORDS TRANSFERRED
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          NJN    IDTP50      IF NOT SUCCESSFUL
          RJM    VRP         VERIFY RESPONSE PACKET
          LJM    IDTPX
 IDTP50   BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          UJN    IDTP70
 IDTP60   BSS
          LDN    E29         INCOMPLETE TRANSFER
 IDTP70   BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- IH
*
** PURPOSE-- INTERRUPT HANDLER.  INPUT THE RESPONSE PACKET.  REPORT
*            ASYNCHRONOUS DRIVE ERROR RESPONSES FOR CONFIGURED UNITS.
*
** EXIT
*         A = MAJOR STATUS
*         THE DRIVE IS DESELECTED
          SPACE  2
 IHX      LJM    **
 IH       EQU    *-1
          LDDL   MFID        MASK FOR INTERLOCK DATA
          ZJN    IH10        IF STREAMING MODE

*         IF 10 MB CHANNEL AND INTERLOCK MODE, SOMETIMES AFTER SENDING
*         A COMMAND PACKET, THE ERROR FLAG WILL SET DURING THE FOLLOWING
*         BUS CONTROL SEQUENCE (IPI ERROR REGISTER = 0004).  MASTER
*         CLEARING THE CHANNEL AFTER THE COMMAND PACKET PREVENTS THIS PROBLEM.

          RJM    MCC         MASTER CLEAR CHANNEL
          RJM    PS          PORT SELECT
 IH10     BSS
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,UX  SAVE CLOCK IN TABLE
          LDML   CP+OPCD
          SHN    -8
          ZJN    IH40        IF LOGICAL INTERFACE RESET
          SBN    7
          NJN    IH20        IF NOT SPIN UP DRIVE
          LDC    115         115 SECOND TIMEOUT FOR SPIN UP DRIVE
          UJN    IH60
 IH20     BSS
          SBN    1
          ZJN    IH40        IF DRIVE RESET
          SBN    0#20
          NJN    IH30        IF NOT FORMAT
          LDML   CP
          LMN    0#E
          ZJN    IH40        IF NOT FORMAT OF ENTIRE DRIVE
          LDC    FPT         FORMAT PACK TIMEOUT
          UJN    IH60
 IH30     BSS
          LDML   /SS/P.RESET,CSST
          NJN    IH50        IF RESET ISSUED
 IH40     BSS
          LDN    CMT         COMMAND TIMEOUT
          UJN    IH60
 IH50     BSS
          LDC    SRT         SLAVE RESET TIMEOUT
 IH60     BSS
          STDL   T7          SAVE TIMEOUT VALUE
 IH70     BSS
          RJM    RI          REQUEST INTERRUPTS
          LDML   SELT,CMOD   MASK VALUE
          LPDL   STATUS      INTERRUPT STATUS
          NJN    IH90        IF INTERRUPT PRESENT
          RJM    UC          UPDATE CLOCK
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    IH80        IF CLOCK HAS NOT WRAPPED
          ADC    0#10000
 IH80     BSS
          SBDL   T7
          MJN    IH70        IF TIMEOUT NOT EXPIRED
          LDK    E38         NO CONTROLLER RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 IH90     BSS
          RJM    DTM         DETERMINE TRANSFER MODE
          RJM    SEL         SELECT THE CONTROLLER
          STDL   CTM         CLEAR CHANGE TRANSFER MODE FLAG
          RJM    RPT         RESPONSE PACKET TRANSFER
          RJM    DCM         DESELECT THE CONTROLLER
          LDML   RPB+MAJST   MAJOR STATUS
          SHN    -4
          LPN    0#F
          LMN    AR
          NJN    IH100       IF NOT ASYNCHRONOUS RESPONSE
          LDML   RPB+SLAD
          LPC    0#FF
          LMC    0#FF
          ZJN    IH110       IF ASYNCHRONOUS RESPONSE FOR CONTROLLER
          LDML   RPB+OPCD
          SHN    -8
          LMC    0#FF
          NJN    IH100       IF ASYNCH ASSOCIATED WITH A COMMAND
          RJM    DARH        DRIVE ASYNCHRONOUS RESPONSE HANDLER
          LDML   CP+OPCD
          LMC    0#100
          ZJN    IH100       IF ASYNCHRONOUS RESPONSE EXPECTED
          UJN    IH120       GO LOOK FOR ANOTHER INTERRUPT
 IH100    BSS
          LDML   RPB+MAJST   MAJOR STATUS
          LJM    IHX
 IH110    BSS
          LDK    ID16
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    IH100       IF ID16 NOT FOUND
          LDML   RPB+6,T3
          SHN    -8
          PJN    IH100       IF NOT CONTROLLER OVER TEMPERATURE
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 IH120    BSS
          LJM    IH70        GO LOOK FOR ANOTHER INTERRUPT
          SPACE  5,20
** NAME-- INTERR
*
** PURPOSE-- REPORT AN INTERFACE ERROR
          SPACE  2
 INTERR   CON    0
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LDK    /RS/K.INTERR  INTERFACE ERROR
          STML   RS+/RS/P.INTERR  ABNORMAL STATUS CODE
          LDK    E120        SOFTWARE FAILURE
          STML   RS+/RS/P.ERRID  SET ERROR IDENTIFIER
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          RJM    HANG
          SPACE  5,20
** NAME-- INTRS
*
** PURPOSE-- SEND INTERMEDIATE RESPONSE.
          SPACE  2
 INTRSX   LJM    **
 INTRS    EQU    *-1
          LDDL   PTF
          ZJN    INTRS10     JUMP IF PATH TEST
          LDML   RS+/RS/P.ERRID
          LMC    E76         IF UNEXPECTED, PROCESS AS UNSOLICITED
          NJN    INTRS20     JUMP IF ERROR NOT UNEXPECTED RESPONSE
 INTRS10  BSS
          RJM    SNMSG       SEND UNSOLICTED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          UJN    INTRSX
 INTRS20  BSS
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          PJN    INTRS30     IF NOT RESTORING DRIVE
          LDML   RTM,CSST
          ZJN    INTRS10     IF RESPONSE FOR RESTORE
 INTRS30  BSS
          LDN    0
          STML   RS+/RS/P.SHORT   INDICATE ERROR RESPONSE
          LDC    RLIE
          STML   RS+/RS/P.RESPL  BYTE LENGTH OF RESPONSE
          LDN    R.INT       INTERMEDIATE RESPONSE
          SHN    16-/RS/N.RC-/RS/L.RC
          STML   RS+/RS/P.RC  RESPONSE CODE
          RJM    TERMP       SEND RESPONSE TO CM
          UJK    INTRSX
          SPACE  5,20
** NAME-- LA6E
*
** PURPOSE-- LOAD ATTRIBUTE PARAMETER 6E.  DISABLING UNANTICIPATED PAUSES
*            DISABLES CORRECTION OF READ ERRORS WITH A PARITY DRIVE.
          SPACE  2
 LA6EX    LJM    **
 LA6E     EQU    *-1
          LDC    0#46E
          STML   CP+FCP      PARAMETER 6E
          LDC    H0209
          RJM    SOU         SET OPERATION CODE AND UNIT
*         LDML   UNITS,UX
          SHN    /UN/L.PDCE+2
          PJN    LA6E10      IF PARITY DRIVE CORRECTION DISABLED
          LDC    0#C080      ALLOW PARITY DRIVE CORRECTION
          UJN    LA6E20
 LA6E10   BSS
          LDC    0#C0A0      DISABLE UNANTICIPATED PAUSES
 LA6E20   BSS
          STML   CP+FCP+1    MODE FOR DATA
          LDN    0
          STML   CP+FCP+2
          LDN    12          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          UJK    LA6EX
          SPACE  5,20
** NAME-- LIR
*
** PURPOSE-- LOGICAL INTERFACE RESET
          SPACE  2
 LIRX     LJM    **
 LIR      EQU    *-1
          LDN    0
          STML   CP+OPCD     SO TIMEOUT WILL BE SHORT IN IH
          LDC    H8215       LOGICAL INTERFACE RESET
          RJM    IR          ISSUE RESET
          RJM    IH          INTERRUPT HANDLER
          SHN    -4
          LPN    0#F
          LMN    AR
          NJN    LIR20       IF NOT ASYNCHRONOUS RESPONSE
          LDN    ID16
          RJM    SFP         CHECK FOR MACHINE EXCEPTION
          MJN    LIR20       IF MACHINE EXCEPTION ID NOT FOUND
          LDML   RPB+6,T3
          LPC    0#FEE0
          LMC    0#6000
          NJN    LIR20       IF ERROR
          UJK    LIRX
 LIR20    BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    EP          ERROR PROCESSING (NO RETURN)
*COPYC IODMAC6
          SPACE  5,20
** NAME-- LOCK
*
** PURPOSE-- SET THE LOCKWORD
*
** ENTRY
*         T7 = RMA POINTER
*         T5 = OFFSET TO LOCKWORD FROM RMA
*
** EXIT
*         A = 0 IF LOCK SUCCESSFULLY SET
          SPACE  2
 LOCKX    LJM    **
 LOCK     EQU    *-1
 LOCK10   BSS
          LCN    0
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          SET INTERMEDIATE VALUE
          LDDL   T1
          ZJN    LOCK30      IF LOCK COULD BE SET
          ADDL   T2
          ADC    -177777B-177777B
          ZJN    LOCK10      IF INTERMEDIATE VALUE
          LDDL   T2
          LPC    77777B
          ADC    100000B
          STDL   T2          SET THE VE BIT
          LDDL   T6
          LMC    400000B
          CWDL   T1          RESTORE THE LOCKWORD AND SET THE VE BIT
          LDDL   T4
          SBDL   LPN         CHECK IF LOCK ALREADY SET
          NJN    LOCK20      IF LOCK COULD NOT BE SET, EXIT A .NE. 0
          LDDL   T1
          ADC    -100000B
 LOCK20   UJK    LOCKX       IF LOCK WAS ALREADY SET, EXIT A = 0
                             IF LOCK COULD NOT BE SET, EXIT A .NE. 0
 LOCK30   BSS
          LDC    100000B
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          LDDL   LPN
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          SET THE LOCKWORD
          LDN    0
          UJK    LOCKX
          SPACE  5,20
** NAME-- LUT
*
** PURPOSE-- LOCK UNIT TABLE
*
** EXIT   A = 0 IF UNIT LOCKED TO THIS PP
          SPACE  2
 LUT10    BSS
          LDDL   T4
          SBDL   LPN
 LUTX     LJM    **
 LUT      EQU    *-1
          LDC    0#8000
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          STDL   T4
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.ULOCK  INDEX TO LOCKWORD
          STDL   T6
          RDSL   T1          ATTEMPT TO LOCK UNIT
          LDDL   T1
          NJN    LUT10       IF ALREADY LOCKED
          LDC    0#8000
          STDL   T1
          LDDL   LPN
          STDL   T4          LOGICAL PP NUMBER
          LDDL   T6
          LMC    400000B
          CWDL   T1          WRITE THE LOCKWORD
          LDN    0
          UJK    LUTX
          SPACE  5,20
** NAME-- ODFP
*
** PURPOSE-- OUTPUT DATA FROM PP
*
** ENTRY  A = COMMAND PACKET LENGTH
          SPACE  2
 ODFPX    BSS
          RJM    VRP         VERIFY RESPONSE PACKET
          LJM    **
 ODFP     EQU    *-1
          STML   CP          COMMAND PACKET LENGTH
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LPN    0#A
          NJN    ODFPX       IF COMMAND SUCCESSFUL
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- PAUS
*
** PURPOSE-- DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*            MICROSECONDS.
*
** ENTRY  A REGISTER SPECIFIES NUMBER OF MICROSECONDS
*          TO BE DELAYED.
          SPACE  2
 PAUSX    LJM    **
 PAUS     EQU    *-1
 PAUS10   SBN    1           EACH ITERATION OF THIS LOOP
          STDL   T1           IS ONE MICROSECOND (I4 ONLY)
          NJN    PAUS10
          UJK    PAUSX
          SPACE  5,20
** NAME-- PCER
*
** PURPOSE-- PREPARE COMMON ERROR RESPONSE
*
** ENTRY  A = ERROR ID
          SPACE  2
 PCERX    LJM    **
 PCER     EQU    *-1
          STDL   P2
          SBN    E18
          MJN    PCER20      IF ERROR CODE 0-17
          SBN    E21-E18
          MJN    PCER10      IF ERROR CODE 18-20
          SBN    E22-E21
          MJN    PCER20      IF ERROR CODE 21
          SBN    E23-E22
          MJN    PCER10      IF ERROR CODE 22
          SBN    E27-E23
          MJN    PCER20      IF ERROR CODE 23-26
          SBN    E29-E27
          MJN    PCER10      IF ERROR CODE 27, 28
          ZJN    PCER20      IF ERROR CODE 29
          SBN    E30-E29
          NJN    PCER20      IF ERROR CODE 31-XX
 PCER10   BSS
          LDC    H00E1       READ STATUS REGISTER
          RJM    RDRG        READ REGISTER
          STDL   STATUS      SAVE CONTENTS OF STATUS REGISTER
 PCER20   BSS
          LDML   /SS/P.XFER,CSST  BYTES TRANSFERRED
          STML   RS+/RS/P.XFER
          LDML   /SS/P.XFER+1,CSST
          STML   RS+/RS/P.XFER+1
          LDML   /SS/P.LU,CSST  PUT LOGICAL UNIT IN RESPONSE
          STML   RS+/RS/P.LU
          RJM    PDR         PREPARE NORMAL DISK RESPONSE
          LDDL   P2
          NJN    PCER50      IF ERROR ALREADY ISOLATED
          LDN    ID14
          RJM    SFP         SEARCH FOR ID 14
          MJN    PCER30      IF NOT CONTROLLER INTERVENTION REQUIRED
          LDK    E71
          UJN    PCER50
 PCER30   BSS
          LDN    ID16
          RJM    SFP         SEARCH FOR ID 16
          MJN    PCER40      IF NOT CONTROLLER MACHINE EXCEPTION
          LDML   RPB+6,T3
          SHN    8
          PJN    PCER31      IF NOT CONTROLLER OVER TEMPERATURE
          LDK    E78
          UJN    PCER50
 PCER31   BSS
          LDK    E72
          UJN    PCER50
 PCER40   BSS
          LDN    ID17
          RJM    SFP         SEARCH FOR ID 17
          MJN    PCER70      IF NOT CONTROLLER COMMAND EXCEPTION
          LDK    E73         COMMAND EXCEPTION
 PCER50   BSS
          UJN    PCER100
 PCER70   BSS
          LDN    ID13
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    PCER90      IF NOT ID13
          LDK    E74         MICROCODE EXECUTION ERROR
          UJN    PCER100
 PCER90   BSS
          LDN    ID15
          RJM    SFP         SEARCH FOR ID 15
          MJN    PCER110     IF NOT ALTERNATE PORT EXCEPTION
          LDK    E75
 PCER100  BSS
          UJN    PCER160
 PCER110  BSS
          LDN    ID12
          RJM    SFP         SEARCH FOR PARAMETER
          PJN    PCER120     IF ID12 FOUND
          LDK    ID22
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    PCER130     IF NOT ID22
 PCER120  BSS
          LDK    E130        DEFECT MANAGEMENT TASK FAILED
          UJN    PCER160
 PCER130  BSS
          LDK    ID23
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    PCER140     IF NOT ID23
          LDML   RPB+6,T3    FIRST WORD AFTER ID23
          SHN    5
          PJN    PCER150     IF NOT MESSAGE FROM DRIVE DIAGNOSTICS
          LDK    E61         DRIVE ERROR
          UJN    PCER160
 PCER140  BSS
          LDK    ID25
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    PCER150     IF NOT ID25
          LDK    E54         DRIVE ALTERNATE PORT ERROR
          UJN    PCER160
 PCER150  BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
 PCER160  BSS
          STML   RS+/RS/P.ERRID
          LDDL   WC          WORDS NOT TRANSFERRED
          STML   RS+/RS/P.WC
          LDDL   LF
          STML   RS+/RS/P.FUNTO  FAILING FUNCTION IF E01
          LDC    H200        CONTROL REGISTER
          RJM    RDRG
          STML   RS+/RS/P.CR  SAVE CONTROL REGISTER
          LDC    H00F1
          RJM    RDRG        READ IPI ERROR REGISTER
          STML   RS+/RS/P.ERREG  SAVE ERROR REGISTER
          LDC    H0600       DMA ERROR REGISTER
          RJM    RDRG
          STML   RS+/RS/P.DMAER  SAVE DMA ERROR REGISTER
          ZJN    PCER170     IF ERROR FLAG WAS NOT SET
          LDML   RS+/RS/P.CR  CONTROL REGISTER
          SHN    5
          PJN    PCER170     IF TEST MODE NOT SET
          LDC    H00E1       READ STATUS REGISTER
          RJM    RDRG        READ REGISTER
          STDL   STATUS
 PCER170  BSS
          LDDL   STATUS      STATUS REGISTER
          STML   RS+/RS/P.STREG
          LDDL   OS
          STML   RS+/RS/P.OSR  SAVE OPERATIONAL STATUS REGISTER
          LDML   /SS/P.MREV,CSST  CONTROLLER MICROCODE PART NUMBER
          STML   RS+/RS/P.MREVU
          LDML   /SS/P.MREV+1,CSST
          STML   RS+/RS/P.MREVL
          LDML   /SS/P.RQTRY,CSST
          STML   RS+/RS/P.RTRY  REQUEST RETRY COUNT
          RJM    SDA         SAVE DISK ADDRESS
          LDDL   CHAN
          STML   RS+/RS/P.CHAN  CHANNEL NUMBER
          RJM    SPA         SAVE PHYSICAL ADDRESS
          LDN    0
          STML   RS+/RS/P.ID
          UJK    PCERX
          SPACE  5,20
** NAME-- PDR
*
** PURPOSE-- PREPARE NORMAL DISK RESPONSE
          SPACE  2
 PDRX     LJM    **
 PDR      EQU    *-1
          LDML   /SS/P.FPVA,CSST  PVA OF REQUEST
          STML   RS+/RS/P.PVA
          LDML   /SS/P.FPVA+1,CSST
          STML   RS+/RS/P.PVA+1
          LDML   /SS/P.FPVA+2,CSST
          STML   RS+/RS/P.PVA+2
          LDN    8
          STML   RS+/RS/P.RESPL  NORMAL RESPONSE LENGTH
          LDN    0
          STML   RS+/RS/P.DATERR  ABNORMAL STATUS WORD
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE WORD
          LDML   /SS/P.LU,CSST  LOGICAL UNIT
          LPC    0#FF
          LMC    /RS/K.SHORT  INDICATE ONE-WORD RESPONSE
          STML   RS+/RS/P.SHORT
          UJK    PDRX
          SPACE  5,20
** NAME-- PI
*
** PURPOSE-- PROCESS INTERRUPT
          SPACE  2
 PI       CON    0
          LDML   /SS/P.RESET,CSST
          ZJN    PI3         IF RESET NOT ISSUED
          LDML   EPCT,CMOD
          STDL   UX          CORRECT UX FOR RESET
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          RJM    DTM         DETERMINE TRANSFER MODE
 PI3      BSS
          RJM    SEL         SELECT CONTROLLER
          STDL   CTM         CLEAR CHANGE TRANSFER MODE FLAG
 PI10     BSS
          RJM    RPT         RESPONSE PACKET TRANSFER
          LDML   RPB+MAJST   MAJOR STATUS
          STDL   T6
          SHN    -4
          LPN    0#F
          SBN    CC
          NJK    PI40        IF NOT STANDARD COMMAND COMPLETION
          RJM    DCM         DESELECT THE CONTROLLER
          RJM    STI         SET TABLE INDEXES
          LDDL   T6
          LPN    0#A
          ZJK    PI100       IF NOT SUCCESSFUL OR NOT CONDITIONAL SUCCESS
          LPN    2
 PI12     ZJK    PI20        IF SUCCESSFUL
          LDN    ID29
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    PI14        IF ID29 NOT FOUND
          LDML   RPB+5,T3
          SHN    -8
          SBN    11
 PI14     MJK    PI20        IF BYTE CONTAINING CORRECTION BITS NOT PRESENT
          LDML   RPB+8,T3
          LPC    0#C0
          ZJN    PI12        IF NOT PARITY DRIVE CORRECTION
          LDML   RPB+OPCD
          SHN    -8
          SBN    0#10
          ZJN    PI16        IF READ
          SBN    0#10
          NJN    PI20        IF NOT WRITE
 PI16     BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDN    0
          STML   RS+/RS/P.SHORT  INDICATE ERROR RESPONSE
          LDC    RLIE
          STML   RS+/RS/P.RESPL  BYTE LENGTH OF RESPONSE
          LDC    0#8000
          STML   RS+/RS/P.RC  NORMAL RESPONSE
          LDN    E62         MEDIA ERROR
          STML   RS+/RS/P.ERRID
          LDML   /SS/P.RQTRY,CSST
          ZJN    PI19        MUST BE MICRCODE ERROR, DO NOT FLAW
          LDK    /RS/K.DATERR  SOFTWARE FLAW THE ALLOCATION UNIT
          STML   RS+/RS/P.DATERR
 PI19     LJM    TERM6       GO SEND RESPONSE AND DELINK THE REQUEST
 PI20     BSS
          RJM    TERM        COMMAND COMPLETED WITHOUT ERROR (NO RETURN)
 PI40     BSS
          SBN    TN-CC
          NJN    PI60        IF NOT TRANSFER NOTIFICATION
          RJM    STI         SET TABLE INDEXES
          RJM    RDWT        READ WRITE SETUP
          NJN    PI45        IF EXPECTED RESPONSE
          AODL   TBC         INDICATE COMPLETION RESPONSE SHOULD BE PRESENT
          LJM    PI10
 PI45     BSS
          LDML   /SS/P.FNC,CSST
          STDL   FNC         0 IF READ, 1 IF WRITE
          LDDL   CH
          ZJN    PI50        IF 10 MB CHANNEL
          RJM    HST         HIGH SPEED TRANSFER (NO RETURN)
 PI50     BSS
          RJM    LST         LOW SPEED TRANSFER (NO RETURN)
 PI60     BSS
          RJM    DCM         DESELECT THE CONTROLLER
          LDML   RPB+SLAD
          LPC    0#FF
          LMC    0#FF
          ZJK    PI100       IF ASYNCH FOR CONTROLLER
          LDML   RPB+OPCD
          SHN    -8
          SBN    0#10
          ZJN    PI65        IF READ
          SBN    0#10
          NJN    PI70        IF NOT WRITE
 PI65     BSS
          RJM    STI         SET TABLE INDEXES
          LDDL   T6
          SHN    CS
          PJN    PI100       IF NOT CONDITIONAL SUCCESS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDN    0
          STML   RS+/RS/P.SHORT  INDICATE ERROR RESPONSE
          LDC    RLIE
          STML   RS+/RS/P.RESPL  BYTE LENGTH OF RESPONSE
          LDC    0#5000
          STML   RS+/RS/P.RC  RECOVERED, INTERMEDIATE RESPONSE
          RJM    TERMP       SEND RESPONSE TO CM
          UJN    PI75
 PI70     BSS
          RJM    DARH        DRIVE ASYNCHRONOUS RESPONSE HANDLER
 PI75     BSS                MUST BE TAG FOR FIRST LOCATION AFTER RJM DARH
          LJM    MAIN15
 PI100    BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- PPRQ
*
** PURPOSE-- CHECK FOR ANY PP REQUESTS
          SPACE  2
 PPRQX    LJM    **
 PPRQ     EQU    *-1
          LCN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDC    0#7FFF
          STDL   T4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          RDCL   T1          CLEAR ACTIVE CHECK BIT, READ PPIT WORD 1
          LDDL   T4
          LPC    0#6000
          ZJN    PPRQX       IF NOT IDLE OR RESUME
          LOADOVL IDRO       LOAD IDLE/RESUME OVERLAY
          RJM    PIR         PROCESS IDLE RESUME (NO RETURN)
          SPACE  5,20
** NAME-- RAUP
*
** PURPOSE-- RESTORE AFTER UNANTICIPATED PAUSE.  RESTORING THESE
*            LOCATIONS ALLOWS A READ TO BE RETRIED FOR THE SECTOR
*            THAT GOT THE UNANTICIPATED PAUSE.
          SPACE  2
 RAUPX    LJM    **
 RAUP     EQU    *-1
          LDML   BAT
          STML   CMLIST+/CM/P.RMA,CSST
          LDML   BAT+1
          STML   CMLIST+/CM/P.RMA+1,CSST
          LDML   BAT+2
          STML   CMLIST+/CM/P.LEN,CSST
          LDML   BAT+3
          STML   /SS/P.LISTL,CSST
          LDML   BAT+4
          STML   CM+/CM/P.RMA,CSST
          LDML   BAT+5
          STML   CM+/CM/P.RMA+1,CSST
          UJN    RAUPX
          SPACE  5,20
** NAME-- RDWT
*
** PURPOSE-- SET UP FOR READ OR WRITE.
*
** EXIT
*         A = 0  IF COMPLETION RESPONSE SHOULD BE PRESENT.  IT IS
*                POSSIBLE FOR A TRANSFER NOTIFICATION RESPONSE FOR THE
*                STACKED COMMAND TO BE PRESENT BEFORE OR AT THE SAME
*                TIME AS THE COMPLETION RESPONSE FOR THE COMMAND IN PROGRESS.
          SPACE  2
 RDWX     LJM    **
 RDWT     EQU    *-1
          LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          PJN    RDWT10      IF NOT 2 COMMANDS IN PROGRESS
          LDML   RPB+CRN
          SHN    -14
          LMML   /SS/P.CRN,CSST
          LPN    1
          ZJN    RDWX        IF RESPONSE FOR 2ND COMMAND
          UJN    RDWT20
 RDWT10   BSS
          LDML   RPB+CRN
          SHN    -14
          LMML   /SS/P.CRN,CSST
          LPN    1
          NJN    RDWT80      IF COMMAND REFERENCE NUMBER WRONG
 RDWT20   BSS
          LDML   /SS/P.TOTAL,CSST  TOTAL SECTORS LEFT TO TRANSFER
          LPC    777B
          ZJN    RDWT80      IF UNEXPECTED RESPONSE
          LDN    0
          STDL   SECPOS      SET SECTOR POSITION = 0
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,UX  SET CURRENT CLOCK
          LDM    /SS/P.DT,CSST
          SHN    -4
          STDL   DT          DEVICE TYPE
          LDDL   CH
          ZJN    RDWT40      IF 10 MB CHANNEL
          LDML   SIH,DT      SUSPEND INTERVAL
          UJN    RDWT50
 RDWT40   BSS
          LDML   SIL,DT      SUSPEND INTERVAL
 RDWT50   BSS
          STDL   SBS         SECTORS TO TRANSFER BEFORE SUSPENDING
          UJK    RDWX
 RDWT80   BSS
          LJM    TERM10
          SPACE  5,20
** NAME-- RDWTOK
*
** PURPOSE-- SEND RESPONSE FOR COMPLETED READ REQUEST
          SPACE  2
 RDWTX    LJM    **
 RDWTOK   EQU    *-1
          SOML   /SS/P.NCR,CSST  NUMBER OF RESPONSES TO BE SENT
          RJM    PDR         PREPARE DISK RESPONSE
          RJM    SNDRSP      SEND RESPONSE TO CM
          AOML   /SS/P.NCOMRQ,CSST  INCREMENT NUMBER OF COMPLETED REQUESTS
          LDML   /SS/P.CURRQ,CSST  SAVE RMA OF PREVIOUS REQUEST
          STML   /SS/P.PRERQ,CSST
          LDML   /SS/P.CURRQ+1,CSST
          STML   /SS/P.PRERQ+1,CSST
          LDML   /SS/P.REQ,CSST  SAVE RMA OF CURRENT REQUEST
          STML   /SS/P.CURRQ,CSST
          LDML   /SS/P.REQ+1,CSST
          STML   /SS/P.CURRQ+1,CSST
          UJK    RDWTX
          SPACE  5,20
** NAME-- RESP
*
** PURPOSE-- WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
          SPACE  2
 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  2
 RESPX    LJM    **
 RESP     EQU    *-1

*         CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDN    0
          STML   STORS       SET FLAG TO STORE RESPONSE
          LDML   CM+/CM/P.STOR,CSST  CHECK IF CALLER WANTS RESPONSE
          SHN    /CM/L.STOR+2
          MJN    RESP10      IF STORE RESPONSE FLAG IS SET
          LDML   RS+/RS/P.SHORT
          SHN    /RS/L.SHORT+2
          PJN    RESP10      IF NOT NORMAL RESPONSE, STORE RESPONSE
          AOML   STORS       NONZERO MEANS DO NOT STORE RESPONSE
          UJK    RESPX

*         READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RESP10   BSS
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF 'IN' POINTER
          CRDL   P1          READ 'IN' POINTER

*         CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDN    0
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE
          LDDL   INP
          SBDL   OUTP
          MJN    RESP20      IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP
 RESP20   BSS
          LDML   RS+/RS/P.RESPL  GET RESPONSE LENGTH
          ADDL   INP
          STDL   INPNT       IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          MJN    RESP30      IF ROOM IN BUFFER
          RJM    PPRQ        CHECK FOR IDLE REQUEST
          UJK    RESP10
 RESP30   BSS
          LDDL   INP
          SHN    -3
          STDL   T3          'IN' POINTER IN WORDS
          LDML   RS+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          LDDL   INPNT
          SBDL   LIM
          MJN    RESP50      IF IN + RESPONSE LENGTH .LT. LIMIT
                             ONLY 1 BLOCK WRITE
          STDL   INPNT       IN + RESPONSE LENGTH - LIMIT = NEW 'IN' POINTER
          SHN    -3
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE

*         WRITE RESPONSE TO CM.

          LDML   RS+1
          ADML   RS+2
          ADML   RS+3
          NJN    RESP40      IF PVA FOR REQUEST IS PRESENT
          STML   RS+14       INSURE UNSOLICITED RESPONSE CODE RETURNED

 RESP40   LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADC    RS
          STML   RESP60      RESPONSE ADDRESS FOR 2ND BLOCK WRITE
 RESP50   BSS
          LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD 'IN' OFFSET
          CWML   RS,T4       WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          ZJN    RESP70      IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          LMC    400000B
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
                             (BEGINNING OF RESPONSE BUFFER)
 RESP60   EQU    *-1
 RESP70   BSS
          LJM    RESPX
          SPACE  5,20
** NAME-- RESPIN
*
** PURPOSE-- UPDATE THE 'IN' POINTER IN THE CM RESPONSE BUFFER.
*
** ENTRY  INPNT = NEW 'IN' POINTER.
          SPACE  2
 RESNX    LJM    **
 RESPIN   EQU    *-1

*         CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDML   STORS       CHECK IF CALLER WANTS RESPONSE
          NJK    RESNX       IF NO RESPONSE WAS SENT

*         UPDATE THE 'IN' POINTER.

          LDN    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDDL   INPNT       NEW 'IN' POINTER
          STDL   P4
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   P1          WRITE NEW 'IN' POINTER TO CM

*         INTERRUPT PROCESSOR. RESP ROUTINE SETS UP THIS INSTRUCTION.

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   LPN-3       SET LAST BYTE NONZERO
 INTPRC   PSN    0           INTERRUPT OR PSN (MODIFIED)
          UJK    RESNX
          SPACE  5,20
** NAME-- SA
*
** PURPOSE-- SAVE ATTRIBUTES
          SPACE  2
 SAX      LJM    **
 SA       EQU    *-1
          LDC    H020A
          STML   CP+OPCD     SAVE ATTRIBUTES OPERATION CODE
          LDN    6           COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          UJN    SAX
          SPACE  5,20
** NAME-- SAVSS
*
** PURPOSE-- WRITE THE SS TABLE TO THE COMMUNICATION BUFFER
*            IN THE UNIT INTERFACE TABLE.
*
          SPACE  2
 SAVX     LJM    **
 SAVSS    EQU    *-1
          LDN    C.SS        NUMBER OF WORDS TO WRITE
          STDL   WC
          LDDL   SSUN
          SBDL   UNUML
          PJN    SAVX        IF INVALID SS TABLE
          LOADR  UNITS+/UN/P.UIT,SSUN
          ADN    /UIT/C.UBUF  OFFSET OF COMMUNICATION BUFFER
          CRDL   T1          GET ADDRESS OF COMMUNICATION BUFFER
          LDML   UNITS,UX
          SHN    -5
          LPN    40B
          STDL   T2          COMPUTE OFFSET INTO UNIT COMMUNICATIONS BUFFER
          LOADF  T3          REFORMAT IT AND LOAD R REGISTER
          ADDL   T2          OFFSET, 0 OR 100(16) BYTES
          CWML   SSNR,WC     WRITE NON RESIDENT SS TABLE
          UJK    SAVX
          SPACE  5,20
** NAME-- SCP
*
** PURPOSE-- SET UP COMMAND PACKET PARAMETERS FOR A WRITE
*            OR READ
          SPACE  2
 SCPX     LJM    **
 SCP      EQU    *-1
          LDN    RPL
          STML   CP          PACKET LENGTH
          AOML   /SS/P.CRN,CSST
          SCN    0#E
          STML   /SS/P.CRN,CSST  CLEAR CARRY BIT
          LPN    1
          SHN    14
          ADDL   UX
          STML   CP+CRN      COMMAND REFERENCE NUMBER
          LDC    H0931
          STML   CP+FCP      COMMAND EXTENT PARAMETER
          LDDL   FNC
          ZJN    SCP20       IF READ
          SBN    1
          ZJN    SCP10       IF WRITE
          LDC    E501        INVALID COMMAND
          RJM    INTERR      REPORT ERROR (NO RETURN)
 SCP10    BSS
          LDC    H2005
          UJN    SCP30
 SCP20    BSS
          LDC    H1005
 SCP30    BSS
          RJM    SOU         SET OPERATION CODE AND UNIT
*         LDML   UNITS,UX
          SHN    /UN/L.TCIP+2
          MJN    SCP40       IF SECOND COMMAND
          LDML   /SS/P.TOTAL,CSST
          UJN    SCP50
 SCP40    BSS
          LDML   /SS/P.TW2,CSST
 SCP50    BSS
          SHN    2
          PJN    SCP70       IF NOT USING MASTER TERMINATE
          LDM    /SS/P.DT,CSST
          SHN    -4
          STDL   DT          DEVICE TYPE
          LDN    0
          STDL   T3
          LDML   CP+FCP+4
          LPN    77B
          STDL   T1          STARTING SECTOR
          LDML   CP+FCP+4
          SHN    -8
          STDL   T2          STARTING TRACK
          LDML   SPT,DT      SECTORS PER TRACK
          SBDL   T1
 SCP60    BSS
          RADL   T3          COMPUTE SECTORS
          AODL   T2
          SBML   TPC,DT      TRACKS PER CYLINDER
          ZJN    SCP80       IF CALCULATION COMPLETE
          LDML   SPT,DT
          UJN    SCP60
 SCP70    BSS
          LDDL   TOTAL
          UJN    SCP90
 SCP80    BSS
          LDDL   T3
          SBML   SSPC,DT     SPARE SECTORS PER CYLINDER
 SCP90    BSS
          STML   CP+FCP+2    SECTOR COUNT
          UJK    SCPX
          SPACE  5,20
** NAME-- SDA
*
** PURPOSE-- SAVE DISK ADDRESS
          SPACE  2
 SDAX     LJM    **
 SDA      EQU    *-1
          LDDL   PTF
          ZJN    SDA10       IF INITIALIZATION CONFIDENCE TEST

*         MAKE THE CYLINDER NUMBER MATCH THE ONE IN THE REQUEST IF THE
*         DRIVE NEEDS INITIALIZED.

          LDML   RS+/RS/P.ERRID
          ADC    -E140
          MJN    SDA5        IF ERROR CODE NOT E140 OR E141
          SBN    E141-E140+1
          MJN    SDA20       IF ERROR CODE IS E140 OR E141
 SDA5     BSS
          LDML   /SS/P.CT,CSST
          ZJN    SDA10       IF CONFIDENCE TEST FAILURE
          LMN    4
          NJN    SDA20       IF NOT CONFIDENCE TEST FAILURE
 SDA10    BSS
          STML   RS+/RS/P.STRK  STARTING TRACK
          STML   RS+/RS/P.SSEC  STARTING SECTOR
          LDM    /SS/P.DT,CSST
          SHN    -4
          STDL   DT          DEVICE TYPE
          LDML   CTC,DT      CONFIDENCE TEST CYLINDER
          STML   RS+/RS/P.SCYL  STARTING CYLINDER
          LDML   RS+/RS/P.ERRID
          ZJK    SDA50       IF RESPONSE PACKET PRESENT
          RJM    SSA         SET STARTING TRACK, SECTOR
          UJN    SDA30
 SDA20    BSS
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          PJN    SDA25       IF NOT RESTORE
          LDML   RTM,CSST
          NJN    SDA25       IF NOT RESTORE
          STML   RS+/RS/P.STRK  SAVE STARTING AND FAILING ADDRESS
          STML   RS+/RS/P.SSEC
          STML   RS+/RS/P.FTRK
          STML   RS+/RS/P.FSEC
          LDML   CRC,CSST    CURRENT RESTORE CYLINDER
          STML   RS+/RS/P.SCYL
          UJN    SDA30
 SDA25    BSS
          LDN    1
          STDL   T2
          LOADF  /SS/P.CURRQ,CSST  RMA OF CURRENT REQUEST
          ADN    3
          CRML   RS+/RS/P.CHAN,T2  SAVE CYLINDER, TRACK, SECTOR IN RESPONSE
 SDA30    BSS
          LDML   RS+/RS/P.ERRID
          ZJN    SDA50       IF RESPONSE PACKET PRESENT
          ADC    -E61
          MJN    SDA40       IF RESPONSE PACKET NOT PRESENT
          ADC    -E110+E61
          MJN    SDA50       IF RESPONSE PACKET PRESENT
 SDA40    BSS
          LDML   /SS/P.CURTRK,CSST
          STML   RS+/RS/P.FTRK  FAILING TRACK
          LDML   /SS/P.CURSEC,CSST
          UJK    SDA70
 SDA50    BSS
          LDN    ID29        DRIVE CONDITIONAL SUCCESS
          RJM    SFP         SEARCH FOR PARAMETER
          PJK    SDA54       IF ID 29 FOUND
          LDN    ID26
          RJM    SFP         SEARCH FOR PARAMETER
          MJK    SDA58       IF ID26 NOT FOUND
          LDML   RPB+5,T3
          SHN    -8
          SBN    17
          MJK    SDA58       IF NO COMMAND ENDING STATUS
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          PJN    SDA53       IF NOT DOING RESTORE
          LDML   RTM,CSST
          NJN    SDA53       IF NOT DOING RESTORE
          LDML   /SS/P.RQTRY,CSST
          SBN    3
          NJN    SDA53       IF NOT TIME TO SKIP MEDIA ERROR
          LOADOVL ER1O       LOAD ERROR RECOVERY OVERLAY 1
          RJM    SMD         SKIP MEDIA DEFECT
          UJN    SDA80
 SDA53    BSS
          AODL   T3
 SDA54    BSS
          AODL   T3
          UJN    SDA60
 SDA58    BSS
          LDN    ID32        RESPONSE EXTENT
          RJM    SFP         SEARCH FOR PARAMETER
          MJK    SDA40       IF ID32 NOT FOUND
 SDA60    BSS
          LDML   RPB+9,T3
          SHN    2
          MJK    SDA40       IF NO ADDRESS PRESENT
          SHN    -10
          STML   RS+/RS/P.FTRK  FAILING TRACK
          LDML   RPB+9,T3
 SDA70    BSS
          LPC    0#FF
          STML   RS+/RS/P.FSEC  FAILING SECTOR
 SDA80    BSS
          LJM    SDAX
          SPACE  5,20
** NAME-- SEEK
*
** PURPOSE-- ISSUE INITIAL SEEK.
          SPACE  2
 SEEKX    LJM    **
 SEEK     EQU    *-1
          LDML   UNITS,UX
          SHN    /UN/L.CIP+2
          MJN    SEEK4       IF ONE COMMAND ISSUED
          SHN    -/UN/L.CIP-2
          LPC    0#3FFF
          LMC    0#8000      INDICATE ONE COMMAND ISSUED
          UJN    SEEK8
 SEEK4    BSS
          SHN    -/UN/L.CIP-2
          LPC    0#3FFF
          LMC    0#C000      INDICATE TWO COMMANDS ISSUED
 SEEK8    BSS
          STML   UNITS,UX
          RJM    SCP         SETUP COMMAND PACKET PARAMETERS
          AODL   CMNDS       COMMAND ISSUED COUNTER
          RJM    CPT         COMMAND PACKET TRANSFER
 SEEK20   EQU    *-1         FOR FORCING ERRORS
          UJK    SEEKX
          SPACE  5,20
** NAME-- SFFMT
*
** PURPOSE-- SET THE FORCE FORMAT FLAG IN THE UNIT INTERFACE TABLE.
*
          SPACE  2
 SFFMTX   LJM    **
 SFFMT    EQU    *-1
 SFFMT10  BSS
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    SFFMT10     IF LOCK COULD NOT BE SET
          LDK    /UIT/K.FRCFMT  SET FORCE FORMAT FLAG
          STDL   T3
          LDN    0
          STDL   T2
          STDL   T4
          STDL   T5
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          RDSL   T2          -LOGICAL OR- THE FORCE FORMAT FLAG
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          UJK    SFFMTX
          SPACE  5,20
** NAME-- SETRQ
*
** PURPOSE-- SET UP FOR FIRST REQUEST.
          SPACE  2
 SETRQX   LJM    **
 SETRQ    EQU    *-1
          LDML   /SS/P.REQ,CSST  SAVE RMA OF REQUEST
          STML   /SS/P.FCOMRQ,CSST  FIRST COMPLETED REQUEST (RMA)
          STML   /SS/P.CURRQ,CSST  CURRENT REQUEST (RMA)
          LDML   /SS/P.REQ+1,CSST
          STML   /SS/P.FCOMRQ+1,CSST
          STML   /SS/P.CURRQ+1,CSST
          LDN    1
          STML   /SS/P.NCOMRQ,CSST  NUMBER OF COMPLETED REQUESTS
          LDML   RQ+/RQ/P.TRACK,CSST
          STML   /SS/P.CURTRK,CSST  CURRENT TRACK
          LDML   RQ+/RQ/P.SECTOR,CSST
          STML   /SS/P.CURSEC,CSST  CURRENT SECTOR
          LDML   RQ+/RQ/P.INT,CSST  CHECK IF INTERRUPT WAS SELECTED
          SHN    /RQ/L.INT+2
          MJN    SETR10      IF INTERRUPT SELECTED
          LDC    2400B       PSN INSTRUCTION
          UJN    SETR20
 SETR10   BSS
          LDML   RQ+/RQ/P.PORT,CSST  GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RQ/L.PORT+/RQ/N.PORT
          LPN    /RQ/M.PORT
          ADC    102600B     INPN INSTRUCTION
 SETR20   BSS
          STML   INTPRC
          UJK    SETRQX
          SPACE  5,20
** NAME-- SFP
*
** PURPOSE-- SEARCH FOR PARAMETER IDENTIFICATION IN RESPONSE PACKET
*
** ENTRY
*         A = ID TO SEARCH FOR
** EXIT
*         A = POSITIVE IF ID FOUND
*         T3 = POINTER TO ID IF IT IS FOUND (RPB+5,T3)
          SPACE  2
 SFPX     LJM    **
 SFP      EQU    *-1
          STDL   T1          PARAMETER TO SEARCH FOR
          LDN    0
          STDL   T3          POINTER TO ID BEING SEARCHED FOR
          LDML   RPB
          ADN    1
          SHN    -1
          SBN    5           LENGTH OF MINIMUM RESPONSE PACKET
 SFP4     BSS
          STDL   T2          POINTER TO END OF PARAMETERS
          MJN    SFPX        EXIT, NO ID FOUND
          LDML   RPB+5,T3
          LMDL   T1
          LPC    0#FF
          ZJN    SFPX        IF ID FOUND
          LDML   RPB+5,T3
          SHN    -9
          ADN    1           ADJUST FOR ODD BYTE
          STDL   T4          WORD LENGTH OF PARAMETER
          RADL   T3          UPDATE POINTER TO ID BEING SEARCHED FOR
          LDDL   T2
          SBDL   T4
          UJN    SFP4
          SPACE  5,20
** NAME-- SFRR
*
** PURPOSE-- SETUP FOR REQUEST RETRY FOR ONE UNIT
*
** EXIT   P5, T8 ARE UNCHANGED
*         A = UNITS,UX
          SPACE  2
 SFRR100  BSS
          RJM    DUBC        DECREMENT UNITS BUSY COUNTER
 SFRRX    BSS
          LDN    0
          STML   /SS/P.RESET,CSST  CLEAR RESET ISSUED FLAG
          STDL   IF          CLEAR INITIALIZATION FLAG
          LDML   UNITS,UX
          LPC    0#3FFF
          STML   UNITS,UX    CLEAR COMMAND IN PROGRESS BITS
          LJM    **
 SFRR     EQU    *-1
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY

*         IF INITIALIZATION, FORMAT, OR CONFIDENCE TEST, COMMAND IN
*         PROGRESS CAN SET WITHOUT INCREMENTING CMNDS

          LDML   /SS/P.CT,CSST
          ZJN    SFRR100     IF ERROR DURING CONFIDENCE TEST
          LDML   /SS/P.RESET,CSST
          NJN    SFRR100     IF SLAVE RESET IN PROGRESS
          LDML   UNITS,UX
          SHN    /UN/L.CIP+2
          PJN    SFRRX       IF NO COMMAND IN PROGRESS
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          PJN    SFRR2       IF RESTORE NOT IN PROGRESS
          LDML   RTM,CSST
          ZJN    SFRR3       IF THIS COMMAND IS A RESTORE
          UJN    SFRR4
 SFRR2    BSS
          SHN    /UN/L.PDCE-/UN/L.RIP
          PJN    SFRR4       IF NOT ATTRIBUTE COMMAND
 SFRR3    BSS
          LJM    SFRR10
 SFRR4    BSS
          LDML   /SS/P.CURRQ,CSST  RESTORE RMA OF CURRENT REQUEST
          STML   /SS/P.REQ,CSST
          LDML   /SS/P.CURRQ+1,CSST
          STML   /SS/P.REQ+1,CSST
          LDML   /SS/P.FPVA,CSST  RESTORE PVA OF CURRENT REQUEST
          STML   /SS/P.PVA,CSST
          LDML   /SS/P.FPVA+1,CSST
          STML   /SS/P.PVA+1,CSST
          LDML   /SS/P.FPVA+2,CSST
          STML   /SS/P.PVA+2,CSST
          LDML   UNITS,UX
          SHN    2+/UN/L.TCIP
          PJN    SFRR5       IF NOT -2 COMMANDS IN PROGRESS-
          SODL   CMNDS       OUTSTANDING COMMANDS
          LDML   UNITS,UX
          LPC    0#BFFF
          STML   UNITS,UX    CLEAR -2 COMMANDS IN PROGRESS-
 SFRR5    BSS
          LDN    0
          STML   /SS/P.NCR,CSST  ZERO OUT NUMBER OF COMPLETED REQUESTS
          SOML   /SS/P.NCOMRQ,CSST  NUMBER OF COMPLETED REQUESTS
          ZJN    SFRR10      IF NO STREAMED READ REQUESTS
          LDML   /SS/P.PRERQ,CSST  SET UP RMA OF LAST GOOD COMPLETED REQUEST
          STML   /SS/P.CURRQ,CSST
          LDML   /SS/P.PRERQ+1,CSST
          STML   /SS/P.CURRQ+1,CSST
          LDN    1           SO DCR DOES NO SEEK
          RJM    DCR         DELETE COMPLETED REQUESTS FROM QUEUE
          UJN    SFRR15
 SFRR10   BSS
          RJM    DUBC        DECREMENT UNIT BUSY COUNTER
          SODL   CMNDS       OUTSTANDING COMMANDS
 SFRR15   BSS
          LJM    SFRRX
          SPACE  5,20
** NAME-- SFUP
*
** PURPOSE-- SAVE FOR UNANTICIPATED PAUSE.  THE LOCATIONS SAVED
*            WILL ALLOW THE CODE TO BACK UP ONE SECTOR AFTER AN
*            UNANTICIPATED PAUSE.
          SPACE  2
 SFUPX    LJM    **
 SFUP     EQU    *-1
          LDDL   SECPOS
          NJN    SFUPX       IF NOT AT A SECTOR BOUNDARY
          LDML   CMLIST+/CM/P.RMA,CSST
          STML   BAT
          LDML   CMLIST+/CM/P.RMA+1,CSST
          STML   BAT+1
          LDML   CMLIST+/CM/P.LEN,CSST
          STML   BAT+2
          LDML   /SS/P.LISTL,CSST
          STML   BAT+3
          LDML   CM+/CM/P.RMA,CSST
          STML   BAT+4
          LDML   CM+/CM/P.RMA+1,CSST
          STML   BAT+5
          UJN    SFUPX
          SPACE  5,20
** NAME-- SNDRSP
*
** PURPOSE-- SEND THE RESPONSE TO CM.
*            USED WHEN SWITCHING TO THE NEXT REQUEST.
          SPACE  2
 SNDX     LJM    **
 SNDRSP   EQU    *-1
          RJM    RESP        SEND RESPONSE TO CM
          RJM    RESPIN      UPDATE -IN- POINTER IN RESPONSE BUFFER
          RJM    SRESP       SET UP RESPONSE BUFFER
          UJK    SNDX
          SPACE  5,20
** NAME-- SNDWRS
*
** PURPOSE-- SEND WRITE RESPONSES FOR WRITE REQUESTS THAT HAVE
*            BEEN SUCCESSFULLY STREAMED.
          SPACE  2
 SNDWX    LJM    **
 SNDWRS   EQU    *-1
          LDML   /SS/P.NCR,CSST  NUMBER OF COMPLETED WRITE REQUESTS MINUS 1
          ZJN    SNDWX       IF NO COMPLETED STREAMED WRITE REQUESTS
          LDN    2
          STDL   WC
          LOADF  /SS/P.CURRQ,CSST
          CRML   NRQ,WC      READ FIRST REQUEST TO GET START OF CHAIN
 SNDW10   BSS
          RJM    RESP        SEND RESPONSE TO CM
          RJM    RESPIN      UPDATE -IN- POINTER IN RESPONSE BUFFER
          LDML   NRQ+/RQ/P.NEXTPV  PUT PVA OF NEXT RESPONSE IN RESPONSE BUFFER
          STML   RS+/RS/P.PVA
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   RS+/RS/P.PVA+1
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   RS+/RS/P.PVA+2
          LDML   /SS/P.CURRQ,CSST  SAVE RMA OF LAST RESPONSE RETURNED
          STML   /SS/P.PRERQ,CSST
          LDML   /SS/P.CURRQ+1,CSST
          STML   /SS/P.PRERQ+1,CSST
          LDML   NRQ+/RQ/P.NEXT  REQUESTS ARE DELINKED THROUGH CURRQ
          STML   /SS/P.CURRQ,CSST
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.CURRQ+1,CSST
          LOADF  NRQ+/RQ/P.NEXT  CM ADDRESS OF NEXT REQUEST
          CRML   NRQ,WC      READ NEXT REQUEST CHAIN POINTERS
          AOML   /SS/P.NCOMRQ,CSST  INCREMENT NUMBER OF COMPLETED REQUESTS
                             (FOR DCR)
          SOML   /SS/P.NCR,CSST  DECREMENT COUNT OF RESPONSES LEFT TO SEND
          NJK    SNDW10      IF MORE RESPONSES
          UJK    SNDWX
          SPACE  5,15
** NAME-- SNMSG
*
** PURPOSE-- SEND UNSOLICITED MESSAGE
          SPACE  2
 SNMSGX   LJM    **
 SNMSG    EQU    *-1
          LDN    0
          STML   RS+/RS/P.SHORT  INDICATE ERROR RESPONSE
          LDC    RLIE
          STML   RS+/RS/P.RESPL  BYTE LENGTH OF RESPONSE
          LDN    R.UNS       UNSOLICITED MESSAGE
          STML   RS+/RS/P.RC  RESPONSE CODE
          RJM    RESP        SEND RESPONSE TO CM
          UJK    SNMSGX
          SPACE  5,20
** NAME-- SOU
*
** PURPOSE-- SET OPERATION CODE AND UNIT
*
** ENTRY  (A) = 1/UNIT TYPE, 17/OPERATION CODE
*
** EXIT   (A) = (UNITS,UX)
          SPACE  2
 SOUX     LJM    **
 SOU      EQU    *-1
          STML   CP+OPCD     OPERATION CODE
          MJN    SOU10       IF USING (PD) FOR THE DRIVE NUMBER
          LDML   /SS/P.UNIT,CSST
          UJN    SOU20
 SOU10    BSS
          LDDL   CMOD
          LPN    7           GET RID OF PORT NUMBER
          SHN    8
          ADDL   PD
 SOU20    BSS
          STML   CP+SLAD     ADDRESS FOR COMMAND PACKET
          LDML   UNITS,UX
          UJN    SOUX
          SPACE  5,20
** NAME-- SPA
*
** PURPOSE-- SAVE PHYSICAL ADDRESS.  IF THE FAILING LOGICAL UNIT CONSISTS
*            OF MULTIPLE PHYSICAL DRIVES, THE FAILING DRIVE NUMBER COULD BE
*            DIFFERENT THAN THE LOGICAL UNIT NUMBER.  THIS SAVES THE ADDRESS
*            OF THE FAILING PHYSICAL DRIVE.
*
** EXIT   FPD = FAILING PHYSICAL DRIVE
          SPACE  2
 SPAX     LJM    **
 SPA      EQU    *-1
          LCN    0
          STML   FPD         INDICATE NO FAILING PHYSICAL DRIVE
          LDML   UNITS,UX
          LPC    777B
          STML   RS+/RS/P.UNIT  PORT, CONTROLLER, DRIVE NUMBER
          LDML   RS+/RS/P.ERRID
          ZJN    SPA10       IF DRIVE ERROR
          SBN    E54
          MJN    SPAX        IF NOT DRIVE ERROR (ERROR ID < 53)
          SBN    E62-E54
          MJN    SPA10       IF DRIVE ERROR (ERROR ID 54 - 61)
          SBN    E96-E62
          ZJN    SPA10       IF DRIVE ERROR (ERROR ID 96)
          SBN    E130-E96
          NJN    SPAX        IF NOT ERROR ID 130
 SPA10    BSS
          LDN    ID22
          RJM    SFP         SEARCH FOR PARAMETER
          PJN    SPA20       IF ID22 FOUND
          LDN    ID23
          RJM    SFP         SEARCH FOR PARAMETER
          PJN    SPA20       IF ID 23 FOUND
          LDN    ID29
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    SPA30       IF ID29 NOT FOUND
 SPA20    BSS
          LDML   RPB+5+3,T3  PHYSICAL DRIVE NUMBER IN BYTE 5
          UJN    SPA55
 SPA30    BSS
          LDN    ID24
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    SPA40       IF NOT ID24
          LDML   RPB+5,T3
          SHN    -8
          SBN    7
          MJK    SPA70       IF NO PHYSICAL DRIVE NUMBER
          LDML   RPB+5+3,T3  PHYSICAL DRIVE NUMBER IN BYTE 6
          UJN    SPA60
 SPA40    BSS
          LDN    ID25
          RJM    SFP         SEARCH FOR PARAMETER
          PJN    SPA50       IF ID25 FOUND
          LDN    ID26
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    SPA70       IF ID26 NOT FOUND
          LDML   RPB+5,T3
          SHN    -8
          SBN    8
          MJN    SPA70       IF NO PHYSICAL DRIVE
 SPA50    BSS
          LDML   RPB+5+4,T3  PHYSICAL DRIVE IN BYTE 7
 SPA55    BSS
          SHN    -8
 SPA60    BSS
          LPC    0#FF
          STML   FPD         FAILING PHYSICAL DRIVE
          LMC    0#FE
          ZJN    SPA70       IF ERROR FOR LOGICAL UNIT
          LDML   UNITS,UX
          LPC    740B
          LMML   FPD
          STML   RS+/RS/P.UNIT  PORT, CONTROLLER, DRIVE NUMBER
 SPA70    BSS
          LJM    SPAX
          SPACE  5,20
** NAME-- SQLOCK
*
** PURPOSE-- SETS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
          SPACE  2
 SQLX     LJM    **
 SQLOCK   EQU    *-1
          LDC    UNITS+/UN/P.UIT  UNIT INTERFACE TABLE ADDRESS
          ADDL   UX
          STDL   T7
          LDN    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          UJK    SQLX
          SPACE  5,20
** NAME-- SR
*
** PURPOSE-- SELECT REQUEST FROM UNIT QUEUE
*
** EXIT
*         A = 0 IF REQUEST FOUND
          SPACE  2
 SRX      LJM    **
 SR       EQU    *-1
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    SRX         IF LOCK NOT SET
          LDN    2
          STDL   P5
          LDDL   CNUM
          NJK    SR50        IF ONE COMMAND ALREADY ISSUED
          LDML   /SS/P.REQ,CSST
          ADML   /SS/P.REQ+1,CSST
          NJK    SR24        IF REQUEST ALREADY SELECTED
          LOADR  UNITS+/UN/P.UIT,UX  LOAD CM ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.NEXTPV
          CRML   NRQ,P5      READ FIRST PVA AND RMA
          LDML   NRQ+/RQ/P.NEXT
          STML   /SS/P.REQ,CSST
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.REQ+1,CSST
          ADML   /SS/P.REQ,CSST
          NJN    SR20        IF REQUEST ON QUEUE
 SR16     BSS
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          LDN    1           NO REQUEST FOUND
          UJK    SRX
 SR20     BSS
          LDML   NRQ+/RQ/P.NEXTPV
          STML   /SS/P.PVA,CSST
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   /SS/P.PVA+1,CSST
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   /SS/P.PVA+2,CSST
          LDML   UNITS+/UN/P.UIT,UX  INITIALIZE DELINK POINTER TO FIRST REQUEST
          STML   /SS/P.DP,CSST
          LDML   UNITS+/UN/P.UIT+1,UX
          STML   /SS/P.DP+1,CSST
          LDML   UNITS+/UN/P.UIT+2,UX
          ADN    /UIT/C.NEXTPV
          STML   /SS/P.DP+2,CSST
 SR24     BSS
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
          LDN    0           INDICATE REQUEST FOUND
          UJK    SRX
 SR50     BSS
          LDN    5
          STDL   WC
          LOADF  /SS/P.CURRQ,CSST
          CRML   NRQ,WC      READ NEXT REQUEST
          LDML   NRQ+/RQ/P.NEXT
          STML   /SS/P.RMA2,CSST
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.RMA2+1,CSST
          ADML   /SS/P.RMA2,CSST
          NJK    SR80        IF NOT END OF QUEUE
          LOADR  UNITS+/UN/P.UIT,UX  LOAD CM ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.NEXTPV
          CRML   NRQ,P5      READ FIRST PVA AND RMA
          LDML   NRQ+/RQ/P.NEXT
          STML   /SS/P.RMA2,CSST
          LMML   /SS/P.FCOMRQ,CSST
          NJN    SR75        IF REQUEST FOUND
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.RMA2+1,CSST
          LMML   /SS/P.FCOMRQ+1,CSST
          ZJK    SR16        IF NO REQUEST FOUND
 SR75     BSS
          LDML   NRQ+/RQ/P.NEXT+1
          STML   /SS/P.RMA2+1,CSST
          LDML   NRQ+/RQ/P.NEXTPV
          STML   /SS/P.PVA2,CSST
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   /SS/P.PVA2+1,CSST
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   /SS/P.PVA2+2,CSST
          UJK    SR24
 SR80     BSS
          LDML   NRQ+/RQ/P.NEXTPV
          STML   /SS/P.PVA2,CSST
          LDML   NRQ+/RQ/P.NEXTPV+1
          STML   /SS/P.PVA2+1,CSST
          LDML   NRQ+/RQ/P.NEXTPV+2
          STML   /SS/P.PVA2+2,CSST
          LDML   NRQ+/RQ/P.SWIT
          SHN    /RQ/L.SWIT+2
          PJK    SR24        IF SWITCH FLAG NOT SET
          UJK    SR16
          SPACE  5,20
** NAME-- SRESP
*
** PURPOSE-- SET UP STATUS FOR RESPONSE BUFFER.
          SPACE  2
 SREX     LJM    **
 SRESP    EQU    *-1
          LDML   /SS/P.PVA,CSST  SAVE PVA OF REQUEST
          STML   /SS/P.FPVA,CSST
          LDML   /SS/P.PVA+1,CSST
          STML   /SS/P.FPVA+1,CSST
          LDML   /SS/P.PVA+2,CSST
          STML   /SS/P.FPVA+2,CSST
          LDN    0
          STML   /SS/P.XFER,CSST  TRANSFER COUNT
          STML   /SS/P.XFER+1,CSST
          UJK    SREX
          SPACE  5,20
** NAME-- SSA
*
** PURPOSE-- SET STARTING ADDRESS FOR CONFIDENCE TEST
          SPACE  2
 SSAX     LJM    **
 SSA      EQU    *-1
          LDDL   DT
          SBN    2
          PJN    SSA10       IF NOT SSD
          LDML   TPC,DT
          SBN    1
          STML   /SS/P.CURTRK,CSST  CURRENT TRACK
          LDML   SPT,DT
          SBN    4
          UJN    SSA20
 SSA10    BSS
          LDN    0
          STML   /SS/P.CURTRK,CSST  CURRENT TRACK
 SSA20    BSS
          STML   /SS/P.CURSEC,CSST  CURRENT SECTOR
          UJK    SSAX
          SPACE  5,20
** NAME-- STI
*
** PURPOSE-- SET TABLE INDEXES (UX AND CSST).  ALSO VERIFY THIS
*            IS THE CORRECT UNIT.
          SPACE  2
 STIX     LJM    **
 STI      EQU    *-1
          LDML   RPB+CRN
          LPC    777B
          STDL   UX          SET INDEX TO UNITS TABLE
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LDML   /SS/P.UNIT,CSST
          LMML   RPB+SLAD
          ZJK    STIX        IF CORRECT UNIT
          LJM    TERM10
          SPACE  5,20
** NAME-- TERM
*
** PURPOSE-- TERMINATE UNIT REQUEST.
          SPACE  2
 TERM     CON    0
          LDML   RPB+OPCD
          ADC    -H0202
          NJN    TERM2       IF NOT RESTORE ATTRIBUTE COMMAND
          LDML   UNITS,UX
          SHN    /UN/L.PDCE+2
          PJN    TERM10      IF ATTRIBUTE RESPONSE NOT EXPECTED
          UJK    TERM60
 TERM2    BSS
          ADC    H0202-0#E005
          NJN    TERM5       IF NOT RESTORE COMMAND
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          PJN    TERM10      IF RESTORE RESPONSE NOT EXPECTED
          UJK    TERM40
 TERM5    BSS
          RJM    PDR         PREPARE NORMAL DISK RESPONSE
 TERM6    BSS
          LDML   /SS/P.TOTAL,CSST  MAKE SURE ALL BYTES WERE TRANSFERRED
          LPC    777B
          ADML   /SS/P.LISTL,CSST
          ADML   /SS/P.NUMCM,CSST
          ZJN    TERM20      IF TERMINATION IS OK
 TERM10   BSS
          LDK    E76         UNEXPECTED RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 TERM20   BSS
          RJM    SNDWRS      SEND WRITE RESPONSES
          RJM    RESP        SEND RESPONSE TO CPU
          LDML   UNITS,UX
          LPC    0#800       RESTORE IN PROGESS BIT
          RJM    DCR         DELETE COMPLETED REQUEST FROM QUEUE
          LDN    0
          STML   /SS/P.RQTRY,CSST  CLEAR RETRY COUNT
          STML   /SS/P.RECOV,CSST  SO SPIN UP CAN OCCUR IN ROUTINE COD
          LDML   UNITS,UX
          SHN    /UN/L.CIP+2
          MJN    TERM30      IF COMMAND IN PROGRESS
          SHN    /UN/L.RIP-/UN/L.CIP
          PJN    TERM25      IF RESTORE NOT IN PROGRESS
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          SOML   RTM,CSST    UPDATE COUNT OF REQUESTS TO MULTIPLEX
          LDN    0
          STML   /SS/P.REQ,CSST  SO SR ROUTINE STARTS AT BEGINNING OF QUEUE
          STML   /SS/P.REQ+1,CSST
          UJN    TERM30
 TERM25   BSS
          RJM    UUT         UNLOCK UNIT TABLE
 TERM30   BSS
          LJM    MAIN20
 TERM40   BSS
          LDM    /SS/P.DT,CSST
          SHN    -4
          STDL   DT          DRIVE TYPE
          LDN    0
          STML   /SS/P.CRTS,CSST  SET CURRENT RESTORE TRACK, SECTOR
          AOML   CRC,CSST    INCREMENT CURRENT RESTORE CYLINDER
          SBML   CTC,DT
          MJN    TERM50      IF MORE CYLINDERS TO RESTORE
          ZJN    TERM50      IF MORE CYLINDERS TO RESTORE
          LDC    /UIT/K.PARPRO+DRNUM  PARITY PROTECTION ENABLED
          RJM    UPPS        UPDATE PARITY PROTECTION STATUS
          LDN    E56         RESTORE COMPLETE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDML   UNITS,UX
          LPC    740B
          ADML   ODN,CSST
          STML   RS+/RS/P.UNIT  PORT, CONTROLLER, DRIVE ADDRESS
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          LDML   UNITS,UX
          LPC    0#F7FF
          STML   UNITS,UX    CLEAR RESTORE IN PROGRESS
          RJM    UUT         UNLOCK UNIT TABLE
 TERM50   BSS
          LDN    5
          STML   RTM,CSST    REQUESTS TO MULTIPLEX
 TERM60   BSS
          LDML   UNITS,UX    CLEAR COMMAND IN PROGRESS, CLEAR PDCE
          LPC    0#DFF
          STML   UNITS,UX
          RJM    DUBC        DECREMENT UNIT BUSY COUNTER
          SODL   CMNDS       COMMANDS ISSUED COUNTER
          LJM    MAIN20
          SPACE  5,20
** NAME-- TERMP
*
** PURPOSE-- TERMINATE PP REQUEST.
          SPACE  2
 TERX     LJM    **
 TERMP    EQU    *-1
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    RESPIN      UPDATE 'IN' POINTER FOR RESPONSE BUFFER
          UJK    TERX
          SPACE  5,20
** NAME-- UBT
*
** PURPOSE-- UPDATE BYTES TRANSFERRED
          SPACE  2
 UBT20    BSS
          RJM    UNCMND      GET NEXT COMMAND
 UBTX     LJM    **
 UBT      EQU    *-1
          LDDL   BC          BYTES TRANSFERRED
          RAML   /SS/P.XFER+1,CSST  UPDATE BYTES TRANSFERRED
          SHN    -16
          RAML   /SS/P.XFER,CSST
          LDDL   BC
          RAML   CMLIST+/CM/P.RMA+1,CSST  UPDATE CM ADDRESS
          SHN    -16
          RAML   CMLIST+/CM/P.RMA,CSST
          LDML   CMLIST+/CM/P.LEN,CSST  UPDATE BYTES LEFT TO TRANSFER
          SBDL   BC
          STML   CMLIST+/CM/P.LEN,CSST
          NJN    UBTX        IF MORE BYTES LEFT TO TRANSFER TO THIS
                             CM ADDRESS
          SOML   /SS/P.LISTL,CSST  DECREMENT ADDRESS-LENGTH-PAIR COUNT
          ZJN    UBT20       IF END OF RMA LIST
          RJM    GLIST       READ NEXT SECTION OF THE LIST WHICH POINTS
                             TO THE CM DATA AREA
          UJN    UBTX
          SPACE  5,20
** NAME-- UC
*
** PURPOSE-- UPDATE CLOCK.  THE CLOCK IS USED TO TIMEOUT COMMANDS
*            ISSUED TO THE CONTROLLER.
          SPACE  2
 UCX      LJM    **
 UC       EQU    *-1
          LDDL   CLCUR
          STDL   P6          SAVE CURRENT CLOCK
          IAN    14B
          STDL   CLCUR
          SBDL   P6
          PJN    UC5         IF CLOCK HASNT WRAPPED
          ADC    10000B
 UC5      BSS
          RADL   CLMCS       UPDATE MICROSECOND PORTION OF CLOCK
          LDDL   CLMCS
          ADC    -2000
          MJN    UCX         IF LESS THAN 2 MILLISECONDS
          STDL   CLMCS
          LDN    2
          RADL   CLMLS       UPDATE MILLISECOND PORTION OF CLOCK
          ADC    -1000
          MJN    UCX         IF LESS THAN 1 SECOND
          STDL   CLMLS
          AODL   CLSEC       UPDATE SECOND PORTION OF CLOCK
          UJN    UCX
          SPACE  5,20
** NAME-- UDA
*
** PURPOSE-- UPDATE DISK ADDRESS. THIS ALLOWS THE PP TO VERIFY THAT
*            A STREAMED REQUEST IS FOR THE NEXT SEQUENTIAL DISK SECTOR.
          SPACE  2
 UDAX     BSS
          SOML   /SS/P.TOTAL,CSST  SECTORS TO TRANSFER
          LJM    **
 UDA      EQU    *-1
          AOML   /SS/P.CURSEC,CSST  INCREMENT SECTOR
          SBML   SPT,DT      SECTORS PER TRACK
          MJN    UDAX        IF SAME TRACK
          STML   /SS/P.CURSEC,CSST
          AOML   /SS/P.CURTRK,CSST  INCREMENT TRACK
          UJN    UDAX
          SPACE  5,20
** NAME-- UNCMND
*
** PURPOSE-- GET NEXT COMMAND FROM CM.  SET UP CMLIST AND LISTL
*            IN THE SS TABLE.  SET FNC AS THE INDEX TO A TABLE OF
*            COMMANDS FROM CENTRAL MEMORY.
*
** EXIT-- A REGISTER = 0, IF NO MORE COMMANDS.
          SPACE  2
 UNCX     LJM    **
 UNCMND   EQU    *-1
          LDML   /SS/P.NUMCM,CSST
          ZJN    UNCX        IF NO MORE COMMANDS
          SOML   /SS/P.NUMCM,CSST  DECREMENT COMMAND COUNT
          LDML   /SS/P.FRST,CSST  HAS FIRST COMMAND BEEN PROCESSED
          ZJN    UNC10       IF FIRST COMMAND HASN'T BEEN PROCESSED

*         READ NEXT COMMAND FROM CM.

          LDDL   CSST        ADDRESS OF SS TABLE
          ADK    CM
          STML   UNC4        ADDRESS TO STORE COMMAND
          AOML   /SS/P.LASTC,CSST  INCREMENT OFFSET OF LAST COMMAND
          LDN    C.CM
          STDL   WC
          LOADF  /SS/P.REQ,CSST  LOAD CM ADDRESS AND REFORMAT
          ADML   /SS/P.LASTC,CSST  ADD OFFSET OF COMMAND
          CRML   *,WC       READ COMMAND FROM CM
 UNC4     EQU    *-1

*         IF INDIRECT ADDRESS, READ CM ADDRESS LIST.

 UNC10    BSS
          LDML   CM+/CM/P.LEN,CSST  MAKE SURE IT IS AN EVEN NUMBER OF CM WORDS
          ADN    7
          SCN    7
          STML   CM+/CM/P.LEN,CSST
          STML   CMLIST+/CM/P.LEN,CSST
          SHN    -3
          STML   /SS/P.LISTL,CSST  LENGTH OF CM ADDRESS AREA  (CM WORDS)
          LDML   CM+/CM/P.INDIR,CSST
          SHN    /CM/L.INDIR+2
          MJN    UNC15       IF INDIRECT ADDRESS
          LDN    1
          STML   /SS/P.LISTL,CSST  IF NOT INDIRECT, ONLY 1 COMMAND.
          LDML   CM+/CM/P.RMA,CSST
          STML   CMLIST+/CM/P.RMA,CSST
          LDML   CM+/CM/P.RMA+1,CSST
          STML   CMLIST+/CM/P.RMA+1,CSST
          UJN    UNC20
 UNC15    BSS
          RJM    GLIST       GET CM ADDRESS LIST OF DATA AREA
 UNC20    BSS
          LDN    0
          STDL   FNC         SET UP INTERNAL FUNCTION CODE
 UNC30    LDML   CM+/CM/P.CODE,CSST  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          ERRNZ  /CM/L.CODE
          LMML   UCMD,FNC    COMPARE COMMAND CODE
          ZJN    UNC40       IF COMMAND FOUND
          AODL   FNC
          SBN    UCMDL
          MJN    UNC30       IF MORE COMMANDS TO CHECK
 UNC35    BSS
          LDC    E501        ERROR IN COMMAND CODE
          RJM    INTERR      REPORT ERROR (NO RETURN)
 UNC40    BSS
          LDML   /SS/P.FRST,CSST
          ZJN    UNC60       IF FIRST COMMAND
          LDDL   FNC
          LMML   /SS/P.FNC,CSST  FUNCTION CODE
          ZJN    UNC70       IF SAME AS LAST COMMAND
          UJN    UNC35
 UNC60    BSS
          LDDL   FNC
          STML   /SS/P.FNC,CSST  SAVE COMMAND CODE
 UNC70    BSS
          AOML   /SS/P.FRST,CSST  SET FIRST COMMAND FLAG NONZERO
          UJK    UNCX        EXIT A REGISTER NONZERO
          SPACE  5,20
** NAME-- UPPS
*
** PURPOSE-- UPDATE PARITY PROTECTION STATUS TO UIT.
*
*
          SPACE  2
 UPPSX    LJM    **
 UPPS     EQU    *-1
          STDL   T1          NEW STATUS
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          STDL   T2
          CRDL   T5          READ UNIT INTERFACE TABLE
          LDDL   T5+/UIT/P.PARPRO
          LPC    -/UIT/K.PBITS MASK OUT OLD PARITY PROTECTION STATUS
          ADDL   T1          NEW PARITY PROTECTION STATUS
          STDL   T5+/UIT/P.PARPRO
          LDDL   T2
          LMC    400000B
          CWDL   T5          REWRITE UPDATED PARITY PROTECTION STATUS
          UJK    UPPSX
          SPACE  5,20
** NAME-- UREQ
*
** PURPOSE-- READ A REQUEST FROM CM.  THE REQUEST IS READ WITH 2
*            3-WORD INPUTS SO THAT THE RMA WILL BE CORRECT IF THE
*            STREAM BIT IS SET.  ROUTINE GETR DOES NOT LOCK THE
*            QUEUE FOR PERFORMANCE REASONS, SO THE CP AND PP COULD
*            BE CHANGING THE QUEUE AT THE SAME TIME.
*
** ENTRY  CSST = POINTER TO SS TABLE
*
** EXIT   RQ  CONTAINS CURRENT REQUEST.
*         FRST = 0
*         NUMCM = NUMBER OF COMMANDS.
          SPACE  2
 UREQX    LJM    **
 UREQ     EQU    *-1
          LDN    0
          STML   /SS/P.FRST,CSST  SET FLAG WHEN REQUEST IS READ
          LDN    3           NUMBER OF WORDS TO READ
          STDL   WC
          LDDL   CSST        ADDRESS OF SS TABLE
          ADK    RQ          LOCATION OF REQUEST IN SS TABLE
          STML   UREQ8       ADDRESS TO PUT REQUEST
          ADN    8
          STML   UREQ4       ADDRESS TO PUT REQUEST
          LOADF  /SS/P.REQ,CSST  LOAD CM REQUEST ADDRESS
          ADN    2
          CRML   *,WC        READ CURRENT REQUEST
 UREQ4    EQU    *-1
          SBN    5
          CRML   *,WC        READ CURRENT REQUEST
 UREQ8    EQU    *-1
          LDML   RQ+/RQ/P.LEN,CSST  DETERMINE NUMBER OF COMMANDS
          SHN    -3
          SBN    /RQ/C.CMND
          STML   /SS/P.NUMCM,CSST  NUMBER OF COMMANDS
          LDN    /RQ/C.CMND
          STML   /SS/P.LASTC,CSST  OFFSET OF COMMAND
          UJK    UREQX
          SPACE  5,20
** NAME-- UUT
*
** PURPOSE-- UNLOCK UNIT TABLE
          SPACE  2
 UUTX     LJM    **
 UUT      EQU    *-1
          LDN    0
          STDL   T1
          STDL   T4
          STML   /SS/P.REQ,CSST
          STML   /SS/P.REQ+1,CSST  SO SR ROUTINE STARTS AT BEGINNING OF QUEUE
          LCN    0
          STDL   T2
          STDL   T3
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.ULOCK  INDEX TO LOCKWORD
          RDCL   T1          CLEAR THE LOCK
          UJN    UUTX
          SPACE  5,20
** NAME-- VRP
*
** PURPOSE-- VERIFY RESPONSE PACKET
*
** EXIT-- TO CALLER IF 2ND, 3RD, AND 4TH WORDS OF RESPONSE CORRECT
          SPACE  2
 VRPX     LJM    **
 VRP      EQU    *-1
          LDML   RPB+CRN
          LMML   CP+CRN
          NJN    VRP10       IF COMMAND REFERENCE NUMBER WRONG
          LDML   RPB+OPCD
          LMML   CP+OPCD
          NJN    VRP10       IF OPERATION CODE WRONG
          LDML   RPB+SLAD
          LMML   CP+SLAD
          ZJN    VRPX        IF SLAVE ADDRESS CORRECT
 VRP10    BSS
          LDK    E76         UNEXPECTED RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          TITLE  IPI CHANNEL SUBROUTINES
** NAME-- BCS
*
** PURPOSE-- PERFORM BUS CONTROL SEQUENCE
*
** ENTRY
*         A = BUS A BITS 7,6 IN BITS 1,0 OF ACCUMULATOR
*             BIT 7 = 1 IF DATA ELSE RESPONSE OR COMMAND
*             BIT 6 = 1 IF INFORMATION IN
          SPACE  2
 BCSX     LJM    **
 BCS      EQU    *-1
          SHN    14
          ADC    H005B
          RJM    FUNC        SET SYNC OUT
          ACN    DC
          LDN    77B
 BCS4     BSS
          FJM    BCS8,DC     IF SYNC IN
          SBN    1
          NJN    BCS4        IF TIMEOUT NOT EXPIRED
          LDN    E22         NO SYNC IN
          UJN    BCS20
 BCS8     BSS
          IAN    DC
          STDL   STATUS      SAVE BUS ACKNOWLEDGE STATUS
          SFM    BCS25,DC    IF ERROR FLAG SET
          LPC    0#FF
          NJN    BCS16       IF BUS ACKNOWLEDGE IS WRONG
          LDDL   LF          LAST FUNCTION
          LMN    0#32
          RJM    FUNC        DROP SYNC OUT
          ACN    DC
          LDN    77B
 BCS12    BSS
          FJM    BCSX,DC     IF SYNC IN DROPPED
          SBN    1
          NJN    BCS12       IF TIMEOUT NOT EXPIRED
          LDN    E23         SYNC IN DID NOT DROP
          UJN    BCS20
 BCS16    BSS
          LDN    E37         BUS ACKNOWLEDGE WRONG
 BCS20    BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
 BCS25    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,15
** NAME-- CPT
*
** PURPOSE-- COMMAND PACKET TRANSFER
*
** ENTRY
*         CP - STARTING ADDRESS OF COMMAND PACKET
          SPACE  2
 CPT30    BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT THE CONTROLLER
          LDDL   WC
          ZJN    CPTX        IF ALL WORDS TRANSFERRED
          LDN    E29         INCOMPLETE TRANSFER
          UJK    CPT10
 CPTX     LJM    **
 CPT      EQU    *-1
          RJM    SEL         SELECT THE CONTROLLER
          LDN    CMDOUT      BUS A FOR COMMAND
          RJM    BCS         BUS CONTROL SEQUENCE
          LDDL   MFID        MASK FOR INTERLOCK DATA
          LPC    0#200
          LMC    H0381       STREAM, WRITE
          RJM    FUNC        RAISE MASTER OUT
          ACN    DC
          LDML   CP
          ADN    3
          SHN    -1          CONVERT BYTE COUNT TO WORD COUNT
          OAM    CP,DC       SEND COMMAND PACKET
          STDL   WC          WORDS NOT TRANSFERRED
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,UX  SET CURRENT CLOCK
          LDC    MS50
 CPT4     IJM    CPT30,DC    IF SLAVE IN DROPPED
          SBN    1
          NJN    CPT4        IF TIMEOUT NOT EXPIRED
          LDN    E30         CHANNEL STAYED ACTIVE
 CPT10    BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)

          IFEQ   FE,1
 CPTAX    LJM    **
 CPTA     EQU    *-1
          RJM    CPT         COMMAND PACKET TRANSFER
 CPTA10   EQU    *-1
          UJN    CPTAX
 CPTBX    LJM    **
 CPTB     EQU    *-1
          RJM    CPT         COMMAND PACKET TRANSFER
 CPTB10   EQU    *-1
          UJN    CPTBX
          ENDIF
          SPACE  5,20
** NAME-- DCM
*
** PURPOSE-- DESELECT THE CONTROLLER
          SPACE  2
 DCM10    CFM    DCMX,DC     IF ERROR FLAG NOT SET

*         ON A 25 MB CHANNEL A DESELECT SEQUENCE COULD CAUSE
*         A SEQUENCE ERROR.  THIS CODE CHANGE TO CLEAR ERROR
*         STATUS WAS DONE INSTEAD OF A HARDWARE FIX.

          LDC    H0100
          RJM    FUNC        CLEAR THE DMA ERROR
 DCMX     LJM    **
 DCM      EQU    *-1
          LDC    H0071
          RJM    FUNC        DROP SELECT OUT
          ACN    DC
          LDN    77B
 DCM4     FJM    DCM10,DC    IF SLAVE IN DROPPED
          SBN    1
          NJN    DCM4        IF TIMEOUT NOT EXPIRED
          LDN    E28         SLAVE IN DID NOT DROP
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- DCN
*
** PURPOSE-- DISCONNECT THE CHANNEL
          SPACE  2
 DCNX     BSS
          DCN    DC+40B      DISCONNECT THE CHANNEL
          LJM    **
 DCN      EQU    *-1
          STDL   WC          WORDS NOT TRANSFERRED
          SFM    DCN10,DC    IF ERROR FLAG SET
          ZJN    DCN20       IF ALL WORDS TRANSFERRED
          LDN    E07
          UJN    DCN40
 DCN10    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 DCN20    BSS
          EJM    DCNX,DC     IF CHANNEL EMPTY
          LDN    E08         CHANNEL NOT EMPTY
 DCN40    BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- DCT
*
** PURPOSE-- DETERMINE CHANNEL TYPE
*
** EXIT   CH = 0 IF 10 MB CHANNEL
*              1 IF 25 MB CHANNEL
          SPACE  2
 DCTX     BSS
          STDL   CH
          LJM    **
 DCT      EQU    *-1
          LDC    H0102
          RJM    FUNC        READ IPI REVISION REGISTER
          ACN    DC
          LDN    0
          EJM    DCTX,DC     IF 10 MB/S IPI CHANNEL
          LDN    1
          UJN    DCTX
          SPACE  5,20
** NAME-- DCW
*
** PURPOSE-- DISCARD CHANNEL WORD
          SPACE  2
 DCWX     LJM    **
 DCW      EQU    *-1
          EJM    DCWX,DC     IF NO WORD PRESENT
          IAN    DC          INPUT CHANNEL WORD
          UJN    DCWX
          SPACE  5,20
** NAME-- DTM
*
** PURPOSE-- DETERMINE TRANSFER MODE
*
** EXIT
*         STATUS - TRANSFER SETTINGS, BIT 4 = 1 IF DATA STREAMING
*         CTM - USED TO CHANGE TRANSFER MODE WHEN SELECTING
          SPACE  2
 DTM30    CFM    DTMX,DC     IF ERROR FLAG NOT SET

*         ON A 25 MB CHANNEL A REQUEST TRANSFER SETTINGS SEQUENCE
*         COULD CAUSE A SEQUENCE ERROR.  THIS CODE CHANGE TO
*         CLEAR ERROR STATUS WAS DONE INSTEAD OF A HARDWARE FIX.

          LDC    H0100
          RJM    FUNC        CLEAR THE DMA ERROR
 DTMX     LJM    **
 DTM      EQU    *-1
          RJM    PS          PORT SELECT
          LDDL   CMOD        CONTROLLER NUMBER
          LPN    7
          SHN    12
          ADC    H8025
          RJM    FUNC        REQUEST TRANSFER SETTINGS
          ACN    DC
          LDN    77B
 DTM4     FJM    DTM8,DC     IF SLAVE IN
          SBN    1
          NJN    DTM4        IF TIMEOUT NOT EXPIRED
          LDN    E27         NO SLAVE IN
          UJN    DTM16
 DTM8     BSS
          IAN    DC
          STDL   STATUS      SAVE TRANSFER SETTING
          SFM    DTM20,DC    IF ERROR FLAG SET
          LPN    0#10
          LMN    0#10
          SHN    5
          LMDL   MFID        MASK FOR INTERLOCK DATA
          LPC    0#200
          SHN    2
          STDL   CTM         CHANGE TRANSFER MODE BIT
          LDDL   LF          LAST FUNCTION ISSUED
          LMC    0#54        CODE 7, DROP MASTER OUT
          RJM    FUNC        DROP MASTER OUT
          ACN    DC
          LDN    77B
 DTM12    FJM    DTM30,DC    IF SLAVE IN DROPPED
          SBN    1
          NJN    DTM12       IF TIMEOUT NOT EXPIRED
          LDN    E28         SLAVE IN DID NOT DROP
 DTM16    BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
 DTM20    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- EI
*
** PURPOSE-- ENABLE INTERRUPT FROM CONTROLLER.  SINCE IT TAKES UP TO
*            20 MICROSECONDS FOR THE CONTROLLER TO PUT ITS INTERRUPT
*            ON THE BUS, THE ENABLE IS DONE HERE AND THE READ
*            IS DONE IN GETU
          SPACE  2
 EIX      LJM    **
 EI       EQU    *-1
          LDDL   UNUML
          ZJN    EIX         IF NO UNITS
          LDML   PAS,CH      SELECT PORT A
          RJM    FAN
          LDC    H0715
          RJM    FAN         REQUEST CLASS 1, 2, OR 3 INTERRUPT
          UJN    EIX
          SPACE  5,20
** NAME-- FAN
*
** PURPOSE-- SEND A FUNCTION TO THE IPI CHANNEL.
          SPACE  2
 FANX     LJM    **
 FAN      EQU    *-1
          DCN    DC+40B      ENSURE THE CHANNEL IS INACTIVE
                              THE CHANNEL MAY HAVE BEEN LEFT ACTIVE
                              BY A MASTER CLEAR, A ROUTINE SUCH AS DCM
                              OR AFTER A REPORTED ERROR.
          FAN    DC          SEND THE FUNCTION
          UJN    FANX
          SPACE  5,20
** NAME-- FUNC
*
** PURPOSE-- ISSUE FUNCTION TO IPI CHANNEL
*
** ENTRY-- A REGISTER = FUNCTION CODE.
          SPACE  2
 FUNX     LJM    **
 FUNC     EQU    *-1
          DCN    DC+40B      ENSURE CHANNEL IS INACTIVE
                              THE CHANNEL MAY HAVE BEEN LEFT ACTIVE
                              BY A MASTER CLEAR, A ROUTINE SUCH AS DCM
                              OR AFTER A REPORTED ERROR.
          FAN    DC          ISSUE THE FUNCTION
          STDL   LF          SAVE FUNCTION CODE
          IJM    FUNX,DC     EXIT IF CHANNEL INACTIVE
          LDN    E01         FUNCTION TIMEOUT
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- GES
*
** PURPOSE-- GET ENDING STATUS
*
** ENTRY
*         A = 0000  DO ENDING STATUS WITHOUT MASTER TERMINATE
*             000A  DO ENDING STATUS WITH MASTER TERMINATE
** EXIT
*         RETURNS TO CALLING PROGRAM IF STATUS IS READ WITHOUT ERROR
*         AND SUCCESSFUL IS SET IN STATUS
          SPACE  2
 GESX     LJM    **
 GES      EQU    *-1
          SHN    8
          ADC    H8039       INDICATE SUCCESSFUL IN BUS A
          RJM    FUNC        DROP MASTER OUT
          ACN    DC
          LDC    1024
 GES5     BSS
          FJM    GES10,DC    IF SLAVE IN SET
          SBN    1
          NJN    GES5        IF TIMEOUT NOT EXPIRED
          LDN    E27         SLAVE IN NOT SET
          RJM    EP          ERROR PROCESSING (NO RETURN)
 GES10    BSS
          IAN    DC
          STDL   STATUS      SAVE ENDING STATUS
          SFM    GES20,DC    IF ERROR FLAG SET
          SHN    17-7
          MJN    GESX        IF SUCCESSFUL
          LOADOVL ER1O       LOAD ERROR RECOVERY OVERLAY NUMBER 1
          RJM    IEE         ISOLATE ENDING STATUS ERRORS (NO RETURN)
 GES20    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- ID
*
** PURPOSE-- INPUT DATA
          SPACE  2
 IDX      LJM    **
 ID       EQU    *-1
          ACN    DC
          IAM    IB,DC
          UJN    IDX
          SPACE  5,20
** NAME-- IR
*
** PURPOSE-- ISSUE INTERFACE RESET TO CONTROLLER
*
** ENTRY
*         A = 8215  FOR LOGICAL INTERFACE RESET
*             8415  FOR SLAVE RESET
*         CMOD = CONTROLLER NUMBER
          SPACE  2
 IRX      LJM    **
 IR       EQU    *-1
          STDL   P2
          RJM    MCC         MASTER CLEAR CHANNEL
          RJM    PS          PORT SELECT
          LDDL   CMOD        CONTROLLER NUMBER
          LPN    7
          SHN    12
          ADDL   P2
          RJM    FUNC        SET MASTER OUT
          PAUSE  20
          LDDL   LF          LAST FUNCTION ISSUED
          LMN    2
          RJM    FUNC        SET SYNC OUT
          PAUSE  10
          LDDL   LF
          LMN    2
          RJM    FUNC        DROP SYNC OUT
          LDDL   LF
          LMN    4
          RJM    FUNC        DROP MASTER OUT
          UJK    IRX
          SPACE  5,20
** NAME-- LTR
*
** PURPOSE-- LOAD T REGISTERS
*
** ENTRY  A = 0C00 FOR READ OR 0D00 FOR WRITE
          SPACE  2
 LTRX     LJM    **
 LTR      EQU    *-1
          RJM    FUNC        SEND FUNCTION
          ACN    DC
          LDN    3
          OAM    BC,DC       BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
          UJN    LTRX
          SPACE  5,20
** NAME-- MCC
*
** PURPOSE-- MASTER CLEAR CHANNEL
          SPACE  2
 MCCX     LJM    **
 MCC      EQU    *-1
          LDN    H0000       MASTER CLEAR CHANNEL
          RJM    FUNC
          PAUSE  100         ALLOW CONTROLLER TIME TO DROP LINES
          SFM    MCC10,DC    MASTER CLEAR DOES NOT CLEAR ERROR FLAG ON 25 MB CHANNEL
 MCC10    BSS
          LDN    H0000       MASTER CLEAR CHANNEL
          RJM    FUNC         IN CASE SEQUENCE ERROR OCCURRED
          RJM    DCT         DETERMINE CHANNEL TYPE
          LDML   TR,CH
          RJM    FUNC        SET IPI CHANNEL TRANSFER RATE
          LDC    H0300
          STDL   T2          WRITE CONTROL REGISTER FUNCTION
          LDML   EDC,CH      ENABLE DOUBLE CMI SLOT IF 25 MB CHANNEL
          RJM    WR          WRITE REGISTER
          UJN    MCCX
          SPACE  5,20
** NAME-- MR
*
** PURPOSE-- MASTER RESET ALL SLAVES ON THE CHANNEL
          SPACE  2
 MRX      LJM    **
 MR       EQU    *-1
          RJM    MCC         MASTER CLEAR CHANNEL
          LDML   PAS,CH
          RJM    FUNC        SELECT PORT A
          LDN    1
          STDL   T2
 MR10     BSS
          LDC    H9213
          RJM    FUNC        BUS A, SET SYNC OUT
          PAUSE  10          MUST DELAY 10 MICROSECONDS MINIMUM
          LDC    H9211
          RJM    FUNC        DROP SYNC OUT
          SODL   T2
          MJN    MRX         IF BOTH PORTS RESET
          LDML   PBS,CH
          RJM    FUNC        SELECT PORT B
          UJN    MR10
          SPACE  5,20
** NAME-- OD
*
** PURPOSE-- OUTPUT DATA
          SPACE  2
 ODX      LJM    **
 OD       EQU    *-1
          ACN    DC
          OAM    OB,DC
          UJN    ODX
          SPACE  5,20
** NAME-- PS
*
** PURPOSE-- PORT SELECT.  SELECT PORT A OR B OF IPI CHANNEL
          SPACE  2
 PSX      LJM    **
 PS       EQU    *-1
          LDML   UNITS,UX
          SHN    /UN/L.PORT+2
          PJN    PS5         IF PORT A
          LDML   PBS,CH      PORT B SELECT
          UJN    PS10
 PS5      BSS
          LDML   PAS,CH      PORT A SELECT
 PS10     BSS
          RJM    FUNC
          UJN    PSX
          SPACE  5,20
** NAME-- RDRG
*
** PURPOSE-- READ REGISTER
*
** ENTRY--  A = FUNCTION CODE
          SPACE  2
 RDRG10   BSS
          LDN    0
 RDRGX    LJM    **
 RDRG     EQU    *-1
          RJM    FAN         SEND FUNCTION
          AJM    RDRG10,DC   IF NO FUNCTION REPLY
          ACN    DC+40B
          EJM    RDRG10,DC   IF WORD COULD NOT BE READ
          IAN    DC
          UJN    RDRGX
          SPACE  5,20
** NAME--RI
*
** PURPOSE-- REQUEST INTERRUPTS FROM THE CONTROLLER
*
** EXIT
*         STATUS - CONTAINS BIT SIGNIFICANT ADDRESS OF CONTROLLER WITH INTERRUPT
          SPACE  2
 RIX      LJM    **
 RI       EQU    *-1
          RJM    PPRQ        CHECK FOR IDLE REQUEST
          LDC    H0715       REQUEST CLASS 1, 2, OR 3 INTERRUPT
          RJM    FUNC        BUS A, MASTER OUT
          PAUSE  20          DELAY
          ACN    DC
          EJM    RI5,DC      IF ERROR
          IAN    DC
          STDL   STATUS      SAVE BIT SIGNIFICANT ADDRESS
          LDC    H0711
          RJM    FUNC        DROP MASTER OUT
          CFM    RIX,DC      IF ERROR FLAG NOT SET
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 RI5      BSS
          LDN    E02         CHANNEL EMPTY WHEN ACTIVATED
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- ROS
*
** PURPOSE-- READ OPERATIONAL STATUS
          SPACE  2
 ROSX     LJM    **
 ROS      EQU    *-1
          LDC    H0700       READ OPERATIONAL STATUS
          RJM    FUNC
          ACN    DC
          EJM    ROS10,DC    IF ERROR
          IAN    DC
          STDL   OS          SAVE OPERATIONAL STATUS
          UJN    ROSX
 ROS10    BSS
          LDN    E02         CHANNEL EMPTY WHEN ACTIVATED
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- RPT
*
** PURPOSE-- RESPONSE PACKET TRANSFER
*
** EXIT
*         RPB - STARTING LOCATION OF RESPONSE PACKET
*         (A) = 0
          SPACE  2
 RPT20    BSS
          STDL   WC          SAVE WORDS NOT TRANSFERRED
 RPT30    BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          LDDL   WC
          ZJN    RPTX        IF ALL WORDS TRANSFERRED
          LDN    E29         INCOMPLETE TRANSFER
          RJM    EP          ERROR PROCESSING (NO RETURN)
 RPTX     LJM    **
 RPT      EQU    *-1
          LDN    RSPIN       BUS A FOR RESPONSE
          RJM    BCS         BUS CONTROL SEQUENCE
          LDDL   MFID        MASK FOR INTERLOCK DATA
          LPC    0#200
          LMC    H0281       STREAM, READ
          RJM    FUNC        SET MASTER OUT
          ACN    DC
          LDN    5
          IAM    RPB,DC      INPUT REQUIRED WORDS
 RPT2     BSS
          NJN    RPT20       IF NOT ALL WORDS RECEIVED
          STDL   TBC         DO NOT EXPECT 01 ENDING STATUS
          LDML   RPB         BYTE COUNT MINUS 2
          ADN    3
          SHN    -1
          SBN    5
          ZJN    RPT4        IF ALL WORDS TRANSFERRED
          LPN    77B         PROTECT AGAINST ILLEGAL RESPONSE LENGTH
          IAM    RPB+5,DC    INPUT REMAINING WORDS
          NJN    RPT2        IF NOT ALL WORDS TRANSFERRED
 RPT4     BSS
          STDL   WC          WORDS NOT TRANSFERRED
          LDC    MS50
 RPT8     BSS
          IJM    RPT30,DC    IF SLAVE IN DROPPED
          SBN    1
          NJN    RPT8        IF TIMEOUT NOT EXPIRED
          LDN    E30         CHANNEL STAYED ACTIVE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- SEL
*
** PURPOSE-- SELECT THE CONTROLLER AND VERIFY THE BIT SIGNIFICANT
*            RESPONSE
*
** ENTRY
*         CMOD - CONTROLLER NUMBER
*         CTM - CHANGE TRANSFER MODE IF BIT 3 SET
*
** EXIT   A = 0 IF NO ERROR
          SPACE  2
 SELX     LJM    **
 SEL      EQU    *-1
          RJM    PS          PORT SELECT
          LDDL   CMOD
          LPN    7
          SHN    12
          ADDL   CTM         CHANGE TRANSFR MODE MODIFIER
          ADN    H0029
          RJM    FUNC        SET SELECT OUT
          ACN    DC
          LDN    77B
 SEL4     BSS
          FJM    SEL8,DC     IF SLAVE IN
          SBN    1
          NJN    SEL4        IF TIMEOUT NOT EXPIRED
          LDN    E20         CAN'T SELECT CONTROLLER
          UJN    SEL15
 SEL8     BSS
          IAN    DC
          STDL   STATUS      SAVE BIT SIGNIFICANT RESPONSE
          LPC    377B
          LMML   SELT,CMOD
          ZJK    SELX        IF BIT SIGNIFICANT RESPONSE CORRECT
          LDN    E21         BIT SIGNIFICANT RESPONSE WRONG
 SEL15    BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
 SELT     BSS
          DATA   1,2,4,8     CONTROLLERS ON PORT A
          DATA   16,32,64,128
          DATA   1,2,4,8     CONTROLLERS ON PORT B
          DATA   16,32,64,128
          SPACE  5,20
** NAME-- SIS
*
** PURPOSE-- SAVE INTERRUPT STATUS
          SPACE  2
 SISX     LJM    **
 SIS      EQU    *-1
          LDN    0
          AJM    SIS10,DC    IF NO FUNCTION REPLY
          ACN    DC+40B
          EJM    SIS10,DC    IF CHANNEL NOT FULL
          IAN    DC
 SIS10    BSS
          STDL   STATUS
          LDC    H0711
          RJM    FAN         DROP MASTER OUT
          LDML   PBS,CH
          RJM    FAN         PORT B SELECT
          LDC    H0715
          RJM    FAN         REQUEST CLASS 1, 2, OR 3 INTERRUPT
          PAUSE  5           ALLOW CONTROLLER TIME TO PUT ITS ADDRESS ON THE
                              BUS IF IT HAS AN INTERRUPT
          AJM    SIS20,DC    IF NO FUNCTION REPLY
          ACN    DC+40B
          EJM    SIS20,DC    IF CHANNEL NOT FULL
          IAN    DC
 SIS20    BSS
          STDL   STATUS+1
          LDC    H0711       DROP MASTER OUT
          RJM    FAN
          UJK    SISX
          SPACE  5,20
** NAME-- TMT
*
** PURPOSE-- TEST MODE TRANSFER
*
** ENTRY
*         A = 0C00 FOR DMA READ
*             0D00 FOR DMA WRITE
          SPACE  2
 TMTX     LJM    **
 TMT      EQU    *-1
          RJM    FUNC
          LDC    200
          STDL   T8          T8 CONTROLS THE TIMEOUT
          STML   CM.CB.T     BYTE COUNT
          ACN    DC
          LDN    3
          OAM    CM.CB.T,DC  BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
 TMT10    BSS
          RJM    ROS         READ OPERATIONAL STATUS
          SFM    TMT40,DC    IF ERROR FLAG SET
          LPN    1
          ZJN    TMTX        IF TRANSFER COMPLETE
          SODL   T8
          NJN    TMT10       IF TIMEOUT NOT EXPIRED
          LDC    H0A00       READ T REGISTER
          RJM    RDRG        READ REGISTER
          SHN    -1
          STDL   WC          SAVE WORD COUNT
          LDC    H0800       DMA TERMINATE
          RJM    FAN
          LDC    H00E1       READ STATUS REGISTER
          RJM    RDRG        READ REGISTER
          STDL   STATUS      SAVE CONTENTS OF STATUS REGISTER
          LDN    E29         INCOMPLETE TRANSFER
          RJM    EP          ERROR PROCESSING (NO RETURN)
 TMT40    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- WFC
*
** PURPOSE-- WAIT FOR COMPLETION.
*
** EXIT   TO CALLING ROUTINE IF NO ERROR WITH
*         A = 0  IF ENTRY CONDITION MET
*         OS =  OPERATIONAL STATUS
          SPACE  2
 WFCX     BSS
          SFM    WFC30,DC    IF ERROR FLAG SET
          LJM    **
 WFC      EQU    *-1
          LDC    6400
          STDL   T8          T8 CONTROLS THE TIMEOUT
 WFC10    BSS
          RJM    ROS         READ OPERATIONAL STATUS
          LPN    1
          ZJK    WFCX        IF TRANSFER COMPLETE
          SODL   T8
          NJN    WFC10       IF TIMEOUT NOT EXPIRED
          LDC    H0A00       READ T REGISTER
          RJM    RDRG        READ REGISTER
          SHN    -1
          STDL   WC          SAVE WORD COUNT

*         FOR THE CASE OF A 0-WORD TRANSFER, THE CONTROLLER DOES NOT READ
*         ENDING STATUS.  CLEAR THE T REGISTER SO HARDWARE WILL READ ENDING
*         STATUS.

          LDC    0#E00       CLEAR T REGISTER FUNCTION
          RJM    FUNC        SEND FUNCTION
          PAUSE  25          ALLOW TIME FOR ENDING STATUS SEQUENCE TO COMPLETE
          RJM    ROS         READ OPERATIONAL STATUS
          LDC    H0800       DMA TERMINATE FUNCTION
          RJM    FAN         SEND THE FUNCTION
          SFM    WFC30,DC    IF ERROR FLAG SET
          LDC    H00E1       READ STATUS REGISTER FUNCTION
          RJM    RDRG        READ REGISTER
          STDL   STATUS
          LDDL   OS          OPERATIONAL STATUS
          LPN    20B
          NJN    WFC20       IF PAUSE
 WFC15    LDN    E29         INCOMPLETE TRANSFER
          RJM    EP          ERROR PROCESSING (NO RETURN)
*
*         AFTER THE CONTROLLER HAS PAUSED A TRANSFER, IT MAY SEND TRANSFER
*         NOTIFICATION, THEN DROP SLAVE IN IMMEDIATELY AND RETURN 90
*         HEX AS ENDING STATUS.  THIS INDICATES COMMAND COMPLETE.
*         THE RESPONSE PACKET SHOULD REPORT AN ERROR.  IT MAY ALSO SEND
*         AN ENDING STATUS OF A0 OR B0.  THIS INDICATES PAUSE AND THE CONTROLLER
*         WANTS TO RESEND THE SAME SECTOR.
*
 WFC20    BSS
          LDC    H0041       READ BUS B FUNCTION
          RJM    RDRG        READ REGISTER
          STDL   STATUS
          LPN    60B
          LMN    20B
          ZJN    WFC25       IF NO MORE DATA
          LDDL   FNC
          NJN    WFC15       IF NOT READ
          RJM    RAUP        RESTORE AFTER UNANTICIPATED PAUSE
          UJN    WFC28
 WFC25    BSS
          LCN    0
          STML   /SS/P.LISTL,CSST  TO GUARANTEE AN ERROR IS REPORTED
          LDN    0
          STML   /SS/P.TOTAL,CSST  TO GUARANTEE AN ERROR IS REPORTED
 WFC28    BSS
          LDN    1
          LJM    WFCX
 WFC30    BSS
          LOADOVL ER1O       LOAD ERROR RECOVERY OVERLAY NUMBER 1
          RJM    EFH         ERROR FLAG HANDLING (NO RETURN)
          SPACE  5,20
** NAME-- WFI
*
** PURPOSE-- WAIT FOR INACTIVE
          SPACE  2
 WFIX     LJM    **
 WFI      EQU    *-1
 WFI10    BSS
          IJM    WFIX,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    WFI10       IF TIMEOUT NOT EXPIRED
          LDN    E30         CHANNEL STAYED ACTIVE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- WFTC
*
** PURPOSE-- WAIT FOR TRANSFER COMPLETE
*
** EXIT-- TO CALLING ROUTINE WITH
*          A = 1  IF TRANSFER COMPLETE
*          A = 0  IF ERROR WHICH REQUIRES RESPONSE TO BE READ OR PAUSE
*          T3 = 0  IF NO REQUEST SWITCH
          SPACE  2
 WFTC100  BSS
          STDL   SECPOS      SECTOR POSITION = 0
          SODL   SBS         SECTORS BEFORE SUSPENDING
          LDDL   T2
          RJM    GES         GET ENDING STATUS
          LDN    1
 WFTCX    LJM    **
 WFTC     EQU    *-1
          LDN    0
          STDL   T2          RIGHT MOST 4 BITS OF MASTER STATUS
          STDL   T3          INDICATE NO REQUEST SWITCH
          LDC    6400
          STDL   T8          T8 CONTROLS THE TIMEOUT
          LDML   /SS/P.TOTAL,CSST
          SHN    2
          PJK    WFTC11      IF NOT USING MASTER TERMINATE
          SHN    -2
          LPC    777B
          SBN    1
          NJN    WFTC11      IF NOT LAST SECTOR OF REQUEST
          LOADF  /SS/P.REQ,CSST
          ADN    /RQ/C.SWIT
          CRDL   T4          READ STREAM BIT IN REQUEST
          LDDL   T4
          SHN    2
          MJN    WFTC7       IF CONCATENATED REQUEST
          LDN    0#A
          STDL   T2          RIGHT MOST 4 BITS OF MASTER STATUS
          UJN    WFTC11
 WFTC7    BSS
          LDN    2
          STDL   T1          WORDS TO READ
          STDL   T3          INDICATE REQUEST SWITCH
          LDDL   CSST
          ADK    RQ
          STML   WFTC9       ADDRESS TO SAVE RMA AND PVA
          LDDL   CMADR+2
          LMC    400000B
          CRML   *,T1        REREAD RMA AND PVA
 WFTC9    EQU    *-1
 WFTC11   BSS
          RJM    ROS         READ OPERATIONAL STATUS
          LPN    1
          ZJK    WFTC100     IF TRANSFER COMPLETE
          SODL   T8
          NJN    WFTC11      IF TIMEOUT NOT EXPIRED
          LDC    H0A00       READ T REGISTER
          RJM    RDRG        READ REGISTER
          SHN    -1
          STDL   WC          SAVE WORD COUNT
          LDC    H0800       DMA TERMINATE FUNCTION
          RJM    FAN         SEND THE FUNCTION
          LDC    H00E1       READ STATUS REGISTER FUNCTION
          RJM    RDRG        READ REGISTER
          STDL   STATUS
          SHN    6
          PJN    WFTC30      IF SLAVE IN DROPPED
          LDN    E30         SLAVE IN DID NOT DROP
          UJN    WFTC45
 WFTC30   BSS
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          LDDL   STATUS
          LPN    60B
          LMN    20B
          ZJN    WFTC60      IF NO MORE DATA
          LDDL   FNC
          NJN    WFTC35      IF NOT READ
          LDDL   STATUS
          LPN    60B
          ZJN    WFTC35      IF NOT PAUSE
          RJM    RAUP        RESTORE AFTER UNANTICIPATED PAUSE
          UJN    WFTC70
 WFTC35   BSS
          LDN    E29         INCOMPLETE TRANSFER
 WFTC45   BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
 WFTC60   BSS
*
*         THE CONTROLLER MAY DROP SLAVE IN ANYTIME DURING THE TRANSFER AND
*         RETURN 90 HEX AS ENDING STATUS.  THIS INDICATES COMMAND COMPLETE.
*         THE RESPONSE PACKET SHOULD REPORT AN ERROR.
*
          LCN    0
          STML   /SS/P.LISTL,CSST  TO GUARANTEE AN ERROR IS REPORTED
          LDN    0
          STML   /SS/P.TOTAL,CSST  TO GUARANTEE AN ERROR IS REPORTED
 WFTC70   BSS
          RJM    MCC         DESELECT, CLEAR T REGISTERS
          LDN    0
          LJM    WFTCX
          SPACE  5,20
** NAME-- WFTE
*
** PURPOSE-- WAIT FOR T PRIME REGISTER EMPTY
*
** EXIT - (A) .NE. 0 IF T PRIME REGISTER GOES EMPTY
          SPACE  2
 WFTEX    LJM    **
 WFTE     EQU    *-1
          LDC    6666
          STDL   T8          T8 CONTROLS THE TIMEOUT
 WFTE10   BSS
          RJM    ROS         READ OPERATIONAL STATUS
          LPN    2
          NJN    WFTEX       IF T PRIME REGISTER EMPTY
          SODL   T8
          NJN    WFTE10      IF TIMEOUT NOT EXPIRED
          UJN    WFTEX
          SPACE  5,20
** NAME-- WOG
*
** PURPOSE-- WRITE OPERAND GENERATOR.  THIS DETERMINES THE NUMBER OF
*            WORDS TO TRANSFER.  FOR READS TO CM IT DETERMINES THE DATA
*            PATTERN AND FOR WRITES IT SETS THE STARTING VALUE FOR ITS
*            CRC CHECK OF THE DATA.
          SPACE  2
 WOGX     LJM    **
 WOG      EQU    *-1
          LDML   WOR,CH
          RJM    FUNC        WRITE OPERAND REGISTER
 WOG10    EQU    *-1         FOR FORCING ERRORS
          LDML   TMWC,CH     TEST MODE WORD COUNT
          STML   WOGP+1
          ACN    DC
          LDN    2
          OAM    WOGP,DC     SEND THE PARAMETERS
          RJM    DCN         DISCONNECT THE CHANNEL
          LDML   ETMF,CH
          STDL   T2          WRITE REGISTER FUNCTION
          LDML   ETMP,CH     ENABLE TEST MODE
          RJM    WR          WRITE REGISTER
          UJN    WOGX
 WOGP     BSS
          DATA   0#1357      STARTING PATTERN
          DATA   0           STREAM 100 PP WORDS (MODIFIED)
          SPACE  5,20
** NAME-- WR
*
** PURPOSE-- WRITE REGISTER
*
** ENTRY--  A = VALUE FOR REGISTER
*          T2 = WRITE REGISTER FUNCTION
          SPACE  2
 WRX      LJM    **
 WR       EQU    *-1
          STDL   T1
          LDDL   T2          WRITE REGISTER FUNCTION
          RJM    FUNC
          ACN    DC
          LDN    1           OUTPUT ONE WORD
          OAM    T1,DC
          RJM    DCN         DISCONNECT THE CHANNEL
          UJN    WRX
          SPACE  5,20

*         THE FOLLOWING TABLE OF VALUES IS NEEDED TO SUPPORT ALTERNATE
*         ACCESS TO THE DRIVES.

 PSB      BSS    0           PATH STRINGS BUSY.  INCREMENTED WHEN UPSB GOES
                              FROM 0 TO 1.  DECREMENTED WHEN UPSB GOES FROM 1
                              TO 0.
 APSB     EQU    PSB+1       ALTERNATE PATH STRINGS BUSY.  INCREMENTED WHEN
                              UPASB GOES FROM 0 TO 1.  DECREMENTED WHEN UPASB
                              GOES FROM 1 TO 0.
 UPSB     EQU    APSB+1      UNITS PER STRING BUSY.  INCREMENTED WHEN THE FIRST
                              SEEK TO A UNIT IS ISSUED.  DECREMENTED WHEN ALL
                              COMMANDS FOR A UNIT HAVE COMPLETED.
                                 WORD 0  PORT 0  CONTROLLER 0  STRING 0
                                      1       0             0         1
                                      2       0             0         2
                                      3       0             0         3
                                      4       0             1         0
                                      5       0             1         1
                                      .       .             .         .
                                      .       .             .         .
                                      .       .             .         .
                                     63       1             7         3
 UPSBL    EQU    64          UPSB TABLE LENGTH
 UPASB    EQU    UPSB+UPSBL  UNITS PER ALTERNATE STRING BUSY.  INCREMENTED IF
                              LOCAL TABLE SAYS NO SEEK ISSUED AND ALGORITHM
                              DETERMINES ALTERNATE PP SHOULD OR HAS ISSUED THE
                              SEEK.  DECREMENTED IF LOCAL TABLE SAYS ALTERNATE
                              PATH ISSUED SEEK AND UNIT NOT LOCKED.
 UPASBL   EQU    64          UPASB TABLE LENGTH
 UNUM     EQU    64          SUPPORT 64 UNITS
 UNITS    EQU    UPASB+UPASBL  START OF UNITS TABLE
 UNITSL   EQU    UNUM*P.UN   LENGTH OF UNITS TABLES
 SS       EQU    UNITS+UNITSL  START OF SS TABLE
 NSS      EQU    RS-SS       LOCATIONS AVAILABLE FOR SS TABLES
 NSST     EQU    NSS/P.SS    NUMBER OF SS TABLES
 RSST     EQU    NSST-1      RESIDENT SS TABLES
 RSSTL    EQU    RSST*P.SS   LENGTH OF RESIDENT SS TABLES
 SSNR     EQU    SS+RSSTL    CHANGEABLE SS TABLE


          ERRMI  NSST-1      IF NO ROOM FOR SS TABLES
          SPACE  5,20
** NAME-- INIT
*
** PURPOSE-- REFORMAT AND SAVE ADDRESS OF PPIT AND OVERLAY
*            DIRECTORY.  THIS CODE MAY BE OVERLAYED AFTER IT
*            IS EXECUTED.
          SPACE  2
 INIT     BSS
          REFAD  DSRTP,CM.PIT  REFORMAT ADDRESS OF PP INTERFACE TABLE
                                AND SAVE IN CM.PIT
          ADN    /PIT/C.CBUF
          CRDL   P1          READ RMA OF PP COMMUNICATIONS BUFFER
          LOADF  P3          REFORMAT ADDRESS OF COMMUNICATIONS BUFFER
          ADN    /CB/C.ODP
          CRDL   T1          READ RMA OF OVERLAY DIRECTORY
          REFAD  T3,DH       REFORMAT ADDRESS OF OVERLAY DIRECTORY
                              AND SAVE AT DH
          LJM    MAIN
          OVERLAY (CHECK DRIVE),OVST
          ROUTINE CDO        CHECK DRIVE OVERLAY
** NAME-- ALN
*
** PURPOSE-- ADD LOGICAL PP NUMBER TO UNIT INTERFACE TABLE LOCKWORD.
*            IT IS USED TO DETERMINE IF THE DRIVE IS BEING SUPPORTED
*            IN ALTERNATE OR REDUNDANT ACCESS MODE.
*
** ENTRY
*         UNIT MUST BE LOCKED
          SPACE  2
 ALNX     LJM    **
 ALN      EQU    *-1
          RJM    LUT         LOAD R REGISTER FOR UNIT INTERFACE TABLE
          LDDL   T6          INDEX TO LOCKWORD
          LMC    400000B
          CRDL   T1          READ LOCKWORD
          LDDL   T2
          NJN    ALN10       IF PP NUMBER PRESENT
          LDDL   T3
          LMDL   LPN
          ZJN    ALNX        IF PP NUMBER ALREADY IN LOCKWORD
          LDDL   LPN
          STDL   T2
          UJN    ALN20
 ALN10    BSS
          LMDL   LPN
          ZJN    ALNX        IF PP NUMBER ALREADY IN LOCKWORD
          LDDL   T3
          NJN    ALN30       IF 2ND PP NUMBER PRESENT
          LDDL   LPN
          STDL   T3
 ALN20    BSS
          LDDL   T6
          LMC    400000B
          CWDL   T1
          UJK    ALNX
 ALN30    BSS
          LMDL   LPN
          ZJN    ALNX        IF PP NUMBER ALREADY IN LOCKWORD
          LDC    E505        CM HAS CHANGED
          RJM    INTERR      REPORT ERROR (NO RETURN)
          SPACE  5,20
** NAME-- CD
*
** PURPOSE-- CHECK DRIVE.  CHECK TO SEE IF THE DRIVE IS CLUSTERED AND
*            FORMATTED TO MATCH THE EXPECTED DRIVE TYPE.  IF THE COMMAND
*            IS FORMAT, FORMAT AND CLUSTER THE DRIVE.  IF A DRIVE OF A
*            PARITY UNIT IS OFF LINED, ISSUE A SPIN UP DRIVE COMMAND TO
*            DETERMINE IF THE DRIVE IS USEABLE, FORMAT THE OFF LINED DRIVE
*            IF NECESSARY, AND SET FLAG BITS TO INITIATE A RESTORE OF THE
*            DRIVE.
*
** ENTRY
*         FROM GETU IF A REQUEST IS PRESENT AND THE CONFIDENCE TEST
*         HAS NOT BEEN RUN FOR A UNIT AFTER THE PP WAS LOADED OR RECEIVED
*         A RESUME.  ALSO, FROM GETU IF A REQUEST IS PRESENT AND THE CAUSE
*         OF AN ERROR MUST BE ISOLATED BETWEEN MEDIA AND OTHER.
*
** EXIT   A NONZERO IF ERROR OR DRIVE OFF LINED
          SPACE  2
 CDX      LJM    **
 CD       EQU    *-1
          RJM    ALN         ADD LOGICAL PP NUMBER TO LOCKWORD
          LDM    /SS/P.DT,CSST
          SHN    -4
          STDL   DT          DEVICE TYPE

*         DRIVE RESET COULD TAKE UP TO 15 SECONDS, SO ONLY DO IT ONCE PER
*         ERROR DURING ERROR PROCESSING.

          LDML   /SS/P.RECOV,CSST
          LMN    1
          ZJN    CD10        IF RUNNING CONFIDENCE TEST TO ISOLATE TO MEDIA ERROR
          LDML   /SS/P.RQTRY,CSST  RETRY COUNT
          LMN    1
          NJN    CD20        IF NOT FIRST ERROR RETRY
 CD10     BSS
          RJM    DPR         DRIVE POWER ON RESET

*         IF THE LOGICAL UNIT HAS PARALLEL DATA DRIVES, ENSURE THAT THE
*         CONTROLLER SUPPORTS PARALLEL MODE.

 CD20     BSS
          LDML   DD,DT       DATA DRIVES PER LOGICAL UNIT
          SBN    1
          ZJN    CD30        IF THIS DRIVE WILL WORK IN SERIAL MODE
          LDC    H0200       REPORT ATTRIBUTE OPERATION CODE
          RJM    SOC         SET OPERATION CODE AND CONTROLLER
*         LDC    0#36C
          STML   CP+FCP
          LDC    0#80DA
          STML   CP+FCP+1    REPORT PARAMETER DA
          LDN    10          COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDML   RPB+8+1
          SHN    9
          MJN    CD30        IF CONTROLLER SUPPORTS PARALLEL DRIVES
          LDC    E142        CONTROLLER DOES NOT SUPPORT PARALLEL
          LJM    CD75

*         ENSURE MODEL NUMBER OF DRIVE IS CORRECT.  IF THE DRIVE IS 5833_1P OR
*         5833_3P AND THE DRIVE IS OFF LINED, IT MAY BE NECESSARY TO OBTAIN THE
*         MODEL NUMBER FROM THE SECOND DRIVE.

 CD30     BSS
          LDML   /SS/P.UNIT,CSST
          LPN    77B
          STDL   PD          PHYSICAL DRIVE
          RJM    DDT         DETERMINE DRIVE TYPE
          PJN    CD35        IF DRIVE DEFINED IN ATTRIBUTE 68
 CD32     BSS
          LDN    1
          UJK    CDX
 CD35     BSS
          LDC    H0200
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDC    0#36C
          STML   CP+FCP
          LDC    0#8050
          STML   CP+FCP+1
          LDML   TD          TOTAL DRIVES
          LMN    1
          ZJN    CD37        IF SINGLE DRIVE
          LDML   CP+SLAD
          SCN    0#38
          STML   CP+SLAD     ENSURE STRING BIT CLEAR
 CD37     BSS
          LDK    77
          STDL   T1
 CD38     BSS
          STML   RPB-1,T1    INITIALIZE RESPONSE BUFFER
          SODL   T1
          NJN    CD38        IF MORE WORDS TO INITIALIZE
          LDN    10          COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDML   TD
          STDL   T1
          LDN    0
          STDL   T2
 CD39     BSS
          LDML   RPB+8+26,T2
          NJN    CD40        IF MODEL NUMBER PRESENT
          SODL   T1
          ZJN    CD50        IF NO MODEL NUMBER
          LDN    12
          RADL   T2
          UJN    CD39
 CD40     BSS
          LMML   MN,DT       EXPECTED MODEL NUMBER
          ZJN    CD80        IF CORRECT MODEL NUMBER
 CD50     BSS
          LDN    0
          STDL   T1
 CD60     BSS
          LDML   RPB+8+26    SEARCH FOR ACTUAL MODEL NUMBER
          LMML   MN,T1
          ZJN    CD70        IF ACTUAL MODEL NUMBER FOUND
          AODL   T1
          SBN    17
          MJN    CD60        IF MORE MODELS TO CHECK
          LDC    E141        DRIVE INITIALIZATION REQUIRED
          STML   RS+/RS/P.ADT
          UJN    CD80
 CD70     BSS
          LDDL   T1
          STML   RS+/RS/P.ADT  ACTUAL DRIVE TYPE
          LDC    E140        XXXX CONFIGURED YYYY FOUND
 CD75     BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LJM    EPF10       SEND ABNORMAL RESPONSE
 CD80     BSS
          LDML   /SS/P.FNC,CSST
          SBN    2
          NJN    CD110       IF NOT FORMAT COMMAND
          LDML   HSTF
          ZJN    CT90        IN NOT HEAD SHIFT DETECT
          LDN    0
          LJM    CDX
 CT90     RJM    IU          INITIALIZE UNIT
          UJK    CD150
 CD110    BSS
          RJM    COR         CHECK OPERATIONAL AND READY
 CD112    MJK    CD32        IF ERROR
          LDML   RS+/RS/P.ADT
          LMC    E141
          ZJN    CD118       IF NOT CLUSTERED OR WRONG MODEL
          LDM    RS+/RS/P.ADT
          SBDL   DT
          NJN    CD118       IF WRONG TYPE
          LDML   /SS/P.UNIT,CSST
          LPN    77B
          STDL   PD          PHYSICAL DRIVE
          RJM    DDT         DETERMINE DRIVE TYPE
          MJK    CD112       IF ERROR
          RJM    IUF         IS UNIT FORMATTED
          ZJN    CD118       IF UNIT FORMATTED CORRECTLY
          STML   RS+/RS/P.ADT  ACTUAL DRIVE TYPE
 CD118    BSS
          LDML   RS+/RS/P.ADT  ACTUAL DRIVE TYPE
          STDL   T1
          SBDL   DT          EXPECTED DRIVE TYPE
          ZJN    CD150       IF CORRECT DRIVE TYPE
          LDDL   T1          ACTUAL DRIVE TYPE
          SBN    17
          PJN    CD120       IF DRIVE TYPE WAS NOT DETERMINED
          LDC    E140        XXXX CONFIGURED - FOUND YYYY
          STDL   T1
 CD120    BSS
          LDDL   T1          ERROR CODE (140 OR 141)
          RJM    EP          ERROR PROCESSING (NO RETURN)
 CD150    BSS
          RJM    COD         CHECK FOR OFF LINE DRIVE
          LJM    CDX
          SPACE  5,20
** NAME-- COD
*
** PURPOSE-- CHECK FOR OFF LINED DRIVE.  THIS ROUTINE CHECKS FOR AN
*            OFF LINED DRIVE OF A PARITY UNIT.  IT WILL ISSUE A SPIN UP DRIVE
*            COMMAND TO SEE IF THE DRIVE IS USEABLE, AND IF SO, FORMAT
*            THE UNIT IF NECESSARY, THEN SET UP TABLES SO THAT ROUTINE GETU
*            WILL RESTORE THE DISK IN THE BACKGROUND.
*
** EXIT-- A NONZERO IF DRIVE OFF LINE
          SPACE  2
 COD200   BSS
          LDN    1
          UJN    CODX
 COD100   BSS
          LDN    0
 CODX     LJM    **
 COD      EQU    *-1
          LDDL   DT          DRIVE TYPE
          SBN    3
          ZJN    COD10       IF 5833_1P
          SBN    5
          ZJN    COD10       IF 5838_1P
          SBN    2
          ZJN    COD10       IF 5838_3P
          SBN    3
          ZJN    COD10       IF 47444_1P
          SBN    2
          ZJN    COD10       IF 47444_3P
          ADN    10
          NJN    COD100      IF NOT 5833_3P
 COD10    BSS

*         THE RESET FORCES THE CONTROLLER TO CHECK FOR A PENDING INTERRUPT.
*         THE PENDING INTERRUPT COULD INDICATE THAT A RESTORE HAS COMPLETED
*         AND PREVENT THIS SIDE FROM STARTING A RESTORE.

          RJM    LIR         LOGICAL INTERFACE RESET
          RJM    RAS         REPORT ADDRESSEE STATUS
          SHN    8
          MJN    COD15       IF OFF LINE DRIVE
          LDC    /UIT/K.PARPRO+DRNUM  PARITY PROTECTION ENABLED
          RJM    UPPS        UPDATE PARITY PROTECTION STATUS
          UJN    COD100      EXIT - NO OFF LINE DRIVE
 COD15    SHN    1
          PJN    COD20       IF RESTORE NOT IN PROGRESS
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          MJK    COD200      IF THIS PP DOING THE RESTORE
 COD20    BSS
          LDML   /SS/P.RECOV,CSST
          ADML   /SS/P.RQTRY,CSST
          ZJN    COD23       IF FIRST TIME FOR CONFIDENCE TEST
          LDDL   PD
          RJM    UPPS        UPDATE PARITY PROTECTION STATUS
          UJK    COD200
 COD23    LDML   RPB+9
          LPN    77B
          STDL   PD
          STML   ODN,CSST    OFF LINED DRIVE NUMBER
          RJM    SUD         SPIN UP DRIVE
          ZJK    COD200      IF ERROR
          LDC    /UIT/K.RESTDR   SET RESTORING DRIVE FLAG
          ADDL   PD              DRIVE NUMBER BEING RESTORED
          RJM    UPPS        UPDATE PARITY PROTECTION STATUS
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T5          READ UNIT FORCE FORMAT FLAG
          LDDL   T5+/UIT/P.FRCFMT
          SHN    /UIT/L.FRCFMT+2
          PJK    COD25       IF NOT FORCE FORMAT
          LDN    1           INDICATE UNIT CLUSTERED
          RJM    FU          FORMAT UNIT
          RJM    CFFMT       CLEAR FORCE FORMAT FLAG IN UIT
          UJK    COD40
 COD25    LDC    0#302
          STML   CP+OPCD     REPORT ADDRESSEE STATUS OPERATION CODE
          LDN    10          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          LDML   RPB+9
          SHN    3
          PJN    COD30       IF UNIT NOT FORMATTED
          LDML   RPB+7
          LPN    77B
          LMML   DD,DT
          NJN    COD30       IF WRONG NUMBER OF DATA DRIVES
          LDML   RPB+11
          LMML   BPS,DT
          ZJN    COD40       IF CORRECT SECTOR SIZE
 COD30    BSS
          LDN    1           INDICATE UNIT CLUSTERED
          RJM    FU          FORMAT UNIT
 COD40    BSS
          LDML   UNITS,UX
          LPC    0#F7FF
          LMC    0#800
          STML   UNITS,UX    SET RESTORE IN PROGRESS
          LDN    E55         RESTORING DRIVE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDML   UNITS,UX
          LPC    740B
          ADML   ODN,CSST
          STML   RS+/RS/P.UNIT  PORT, CONTROLLER, DRIVE ADDRESS
          LDN    0
          STML   CRC,CSST    CURRENT RESTORE CYLINDER
          STML   /SS/P.CRTS,CSST  CURRENT TRACK, SECTOR TO RESTORE
          STML   RTM,CSST    REQUESTS TO MULTIPLEX PER CYLINDER DURING RESTORE
          STML   RS+/RS/P.SCYL  STARTING CYLINDER
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          LJM    COD200
          SPACE  5,20
** NAME-- COR
*
** PURPOSE-- CHECK OPERATIONAL AND READY
*
** EXIT
*         A = NEGATIVE VALUE IF ANY PHYSICAL DRIVE OF THE LOGICAL UNIT
*             IS NOT OPERATIONAL OR NOT READY.
          SPACE  2
 CORX     LJM    **
 COR      EQU    *-1
          LCN    0
          STML   CORF        INDICATE NO OFF-LINE DRIVE
          LDML   /SS/P.UNIT,CSST
          LPN    77B
          STDL   PD          PHYSICAL DRIVE
          LPN    70B
          NJN    COR5        IF NOT DRIVE NUMBER 0-7
          RJM    RAS         REPORT ADDRESSEE STATUS
          LPN    77B
          STML   CORF        FAILING DRIVE
 COR5     BSS
          RJM    DDT         DETERMINE DRIVE TYPE
          MJN    CORX        IF ERROR
          LDC    0#301+400000B  REPORT CONDITION OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDC    0#2D5
          STML   CP+FCP
          LDDL   PD
          SHN    8
          STML   CP+FCP+1    PHYSICAL DRIVE OF LOGICAL UNIT
          LDML   TD          TOTAL DRIVES IN CLUSTER
          LMN    1
          ZJN    COR10       IF 1X DRIVE
          LDML   /SS/P.UNIT,CSST
          SCN    0#38
          STML   CP+SLAD     LOGICAL ADDRESS
 COR10    BSS
          LDN    10          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          LDML   CORF
          LMD    PD
          ZJN    COR25       IF THIS DRIVE IS OFF LINE
          LDML   RPB+6
          SHN    10
          MJN    COR30       IF NOT OPERATIONAL
          SHN    1
          MJN    COR30       IF NOT READY
 COR25    BSS
          RJM    UPD         UPDATE DRIVE NUMBER
          NJK    COR5        IF MORE DRIVES TO CHECK
 COR30    BSS
          LJM    CORX
 CORF     DATA   0
          SPACE  5,20
** NAME-- CU
*
** PURPOSE-- CLUSTER UNIT
          SPACE  2
 CUX      LJM    **
 CU       EQU    *-1
          LDC    0#968
          STML   CP+FCP      CLUSTER PARAMETER
          LDC    H0209
          RJM    SOU         SET OPERATION CODE AND UNIT
          LPN    37B
          SHN    8
          ADN    1
          STML   CP+FCP+1    FIRST DRIVE
          ADC    0#800
          STML   CP+FCP+3    SECOND DRIVE
          ADC    0#800
          STML   CP+FCP+5    3RD DRIVE
          ADC    0#800
          STML   CP+FCP+7    4TH DRIVE
          LDC    0#8A80
          STML   CP+FCP+2
          STML   CP+FCP+4
          STML   CP+FCP+6
          STML   CP+FCP+8
          LDDL   DT
          NJN    CU10        IF NOT 5832_1
          LDC    0#8600
          UJK    CU60
 CU10     BSS
          SBN    1
          ZJK    CU70        IF 5832_2
          SBN    6
          MJN    CU12        IF 5833_
          SBN    5
          MJN    CU12        IF 5838_
          ADN    1           BIAS FOR 47444_
          UJN    CU17
 CU12     ADN    6
 CU17     SBN    2
          MJN    CU50        IF 5833_1 OR 5838_1 OR 47444_1
          NJN    CU20        IF NOT 5833_1P OR 5838_1P OR 47444_1P
          LDC    0#1000
          RAML   CP+FCP+3
          LDC    0#8A10
          UJK    CU80
 CU20     BSS
          SBN    2
          MJK    CU90        IF 5833_2 OR 5838_2 OR 47444_2
          NJN    CU40        IF NOT 5833_3P OR 5838_3P OR 47444_3P
          LDC    0#8A10
          STML   CP+FCP+8
 CU40     BSS
          LDC    0#1168
          STML   CP+FCP      CLUSTER PARAMETER
          LDN    0#18        COMMAND PACKET LENGTH
          UJN    CU100
 CU50     BSS
          LDC    0#8A00
 CU60     BSS
          STML   CP+FCP+2
          LDC    0#568
          STML   CP+FCP      CLUSTER PARAMETER
          LDN    0#C         COMMAND PACKET LENGTH
          UJN    CU100
 CU70     BSS
          LDC    0#8680
          STML   CP+FCP+2
 CU80     BSS
          STML   CP+FCP+4
 CU90     BSS
          LDN    0#10        COMMAND PACKET LENGTH
 CU100    BSS
          STML   CP
          RJM    ODFP        OUTPUT DATA FROM PP

*         WAIT FOR ASYNCHRONOUS RESPONSE FROM DRIVE

          LDC    0#100       SO IH EXPECTS AN ASYNCHRONOUS RESPONSE
          STML   CP+OPCD
          RJM    IH          INTERRUPT HANDLER
          LJM    CUX
          SPACE  5,20
** NAME-- DDT
*
** PURPOSE-- DETERMINE DRIVE TYPE FOR DRIVE SPECIFIED BY LOCATION PD
*
** EXIT
*         A = DRIVE TYPE (0-6) IF DRIVE FOUND AND CLUSTERED
*           = 141(10) IF NOT CLUSTERED AS NOS/VE DEFINED DRIVE
*           = NEGATIVE VALUE IF DRIVE NOT FOUND OR ERROR
*        T3 = POINTER TO PARAMETER 68
*        TD = NUMBER OF PHYSICAL DRIVES PER LOGICAL UNIT IF THE DRIVE
*             IS CLUSTERED
          SPACE  2
 DDTX     LJM    **
 DDT      EQU    *-1
          RJM    RMR         READ MICROCODE REVISION
          LDC    0#8068
          STML   CP+FCP+1    REPORT PARAMETER 68
          LDN    10          COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDML   RPB+5+2
          SHN    -1
          STDL   T1
          LDDL   PD          PHYSICAL DRIVE
          SHN    8
          ADN    1
          STDL   T2          EXPECTED PARAMETER WORD WITH UNIT NUMBER
          LDN    0
          STDL   T3          INDEX TO PARAMETER 68
          LDN    1
          STML   TD          PHYSICAL DRIVES PER LOGICAL UNIT
 DDT10    BSS
          LDML   RPB+8,T3
          LMC    0#568
          NJN    DDT25       IF NOT SINGLE UNIT
          LDML   RPB+8+1,T3
          LMDL   T2
          NJK    DDT55       IF DIFFERENT UNIT
          LDML   RPB+8+2,T3
          SHN    8
          PJK    DDT80       IF NOT CLUSTERED
          SHN    17
          MJN    DDT15       IF SOLID STATE DISK
          LDN    2           5833_1
          UJN    DDT20
 DDT15    BSS
          LDN    0           5832_1
 DDT20    BSS
          LJM    DDT100
 DDT25    BSS
          LDML   RPB+8,T3
          LMC    0#968
          NJN    DDT40       IF NOT 2 UNITS
          LDML   RPB+8+1,T3
          LMDL   T2
          ZJN    DDT28       IF UNIT FOUND
          LDML   RPB+8+3,T3
          LMDL   T2
          NJK    DDT60       IF DIFFERENT UNIT
 DDT28    BSS
          LDN    2
          STML   TD          PHYSICAL DRIVES PER LOGICAL UNIT
          LDML   RPB+8+4,T3
          SHN    6
          MJN    DDT30       IF NOT SSD
          LDN    1
          UJN    DDT38
 DDT30    BSS
          SHN    4
          PJN    DDT35       IF PARITY DRIVE
          LDN    4           5833_2
          UJN    DDT38
 DDT35    BSS
          LDN    3           5833_1P
 DDT38    BSS
          UJK    DDT50
 DDT40    BSS
          LDML   RPB+8,T3
          LMC    0#D68
          NJN    DDT42       IF NOT 3 UNITS
          LDML   RPB+8+1,T3
          LMDL   T2
          ZJN    DDT41       IF UNIT FOUND
          LDML   RPB+8+3,T3
          LMDL   T2
          ZJN    DDT41       IF UNIT FOUND
          LDML   RPB+8+5,T3
          LMDL   T2
          NJK    DDT63       IF DIFFERENT UNIT
 DDT41    BSS
          LDN    3
          STML   TD          PHYSICAL DRIVES PER LOGICAL UNIT
          UJK    DDT80
 DDT42    BSS
          LDML   RPB+8,T3
          LMC    0#1168
          NJK    DDT75       IF ILLEGAL PARAMETER
          LDML   RPB+8+1,T3
          LMDL   T2
          ZJN    DDT43       IF UNIT FOUND
          LDML   RPB+8+3,T3
          LMDL   T2
          ZJN    DDT43       IF UNIT FOUND
          LDML   RPB+8+5,T3
          LMDL   T2
          ZJN    DDT43       IF UNIT FOUND
          LDML   RPB+8+7,T3
          LMDL   T2
          NJN    DDT65       IF DIFFERENT UNIT
 DDT43    BSS
          LDN    4
          STML   TD          PHYSICAL DRIVES PER LOGICAL UNIT
          LDML   RPB+8+8,T3
          SHN    10
          PJN    DDT45       IF PARITY DRIVE
          LDN    6           5833_4
          UJN    DDT50
 DDT45    BSS
          LDN    5           5833_3P
 DDT50    BSS
          UJN    DDT100
 DDT55    BSS
          LDN    3
          UJN    DDT70
 DDT60    BSS
          LDN    5
          UJN    DDT70
 DDT63    BSS
          LDN    7
          UJN    DDT70
 DDT65    BSS
          LDN    9
 DDT70    BSS
          RADL   T3          UPDATE POINTER TO PARAMETER 68
          SBDL   T1
          MJK    DDT10       IF MORE PARAMETERS TO CHECK
 DDT75    BSS
          LCN    0           DRIVE NOT FOUND OR ERROR
          UJN    DDT100
 DDT80    BSS
          LDC    E141        DRIVE NOT CLUSTERED OR NOT FORMATTED
 DDT100   BSS
          STML   RS+/RS/P.ADT
          MJN    DDT120      IF DRIVE NOT FOUND OR ERROR
          ADC    -E141
          ZJN    DDT110      IF DRIVE NOT CLUSTERED OR FORMATTED
          LDDL   DT
          SBN    7
          MJN    DDT110      IF 5832 OR 5833
          SBN    5
          MJN    DDT105      IF 5838
          LDN    10
          UJN    DDT107      47444
 DDT105   LDN    5
 DDT107   RAML   RS+/RS/P.ADT  BIAS ADT FOR MODEL 5838
 DDT110   LDML   RS+/RS/P.ADT
 DDT120   LJM    DDTX
 TD       DATA   0           TOTAL PHYSICAL DRIVES PER LOGICAL UNIT
          SPACE  5,20
** NAME-- DPR
*
** PURPOSE-- DRIVE POWER ON RESET.  THIS MASTER CLEARS THE DRIVE(S),
*            BREAKS AN OPPOSITE ACCESS RESERVE AND RUNS DIAGNOSTICS.
*            IT IS ISSUED BY THE CONTROLLER EVEN IF THE DRIVE IS NOT
*            OPERATIONAL.  IT IS ISSUED BY THE CONTROLLER TO THE OFF
*            LINE DRIVE OF A LOGICAL UNIT.
          SPACE  2
 DPRX     LJM    **
 DPR      EQU    *-1
          LDML   /SS/P.UNIT,CSST
          LPN    77B
          STDL   PD          PHYSICAL DRIVE
 DPR10    BSS
          RJM    DDT         DETERMINE DRIVE TYPE
          MJN    DPR20       IF ERROR
          LDML   TD          TOTAL DRIVES IN LOGICAL UNIT
          LMN    1
          ZJN    DPR20       IF 1X DRIVE
          LDDL   DT
          ZJN    DPR13       IF 1X DRIVE EXPECTED
          SBN    2
          ZJN    DPR13       IF 5833_1 DRIVE
          SBN    5
          ZJN    DPR13       IF 5838_1 DRIVE
          SBN    5
          NJK    DPR16       IF NOT 47444_1 DRIVE
 DPR13    BSS
          LDML   /SS/P.UNIT,CSST
          SCN    0#38
          UJN    DPR30
 DPR16    BSS
          LDDL   PD
          LPN    70B
          NJN    DPR40       IF RESET ALREADY ISSUED
          LDML   /SS/P.UNIT,CSST
          UJN    DPR30
 DPR20    BSS
          LDDL   CMOD
          LPN    7
          SHN    8
          ADDL   PD
 DPR30    BSS
          STML   CP+SLAD     LOGICAL ADDRESS
          LDC    H0800       ABORT COMMAND
          STML   CP+OPCD
          LDC    0#254
          STML   CP+FCP
          LDC    0#400       RESET AS AT POWER ON
          STML   CP+FCP+1
          LDN    10
          STML   CP          COMMAND PACKET LENGTH
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          RJM    LIR         LOGICAL INTERFACE RESET (IN CASE OF MULTIPLE RESPONSES)
 DPR40    BSS
          RJM    UPD         UPDATE PHYSICAL DRIVE ADDRESS
          NJK    DPR10       IF MORE PHYSICAL UNITS IN LOGICAL UNIT

*         IF THE UNIT IS NOT READY, THE DRIVE RESET COULD RESULT IN A
*         STATE CHANGE.  THE STATE CHANGE COULD TAKE AS LONG AS 15 SECONDS.
*         IF A CONTROLLER IS POWERED ON AND A DRIVE IS RESERVED TO ANOTHER
*         CONTROLLER, THE CONTROLLER THAT IS POWERED ON WILL REPORT THAT
*         THE DRIVE IS NOT OPERATIONAL AND NOT READY.

          LDML   /SS/P.SC,CSST
          ZJN    DPR70       IF THERE SHOULD BE NO STATE CHANGE
 DPR50    BSS
          RJM    RI          REQUEST INTERRUPTS
          LDML   SELT,CMOD   MASK VALUE
          LPDL   STATUS      INTERRUPT STATUS
          NJN    DPR70       IF INTERRUPT PRESENT
          RJM    UC          UPDATE CLOCK
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    DPR60       IF CLOCK HASN'T WRAPPED
          ADC    0#10000
 DPR60    BSS
          SBN    15          COMMAND TIMEOUT
          MJN    DPR50       IF TIMEOUT NOT EXPIRED
 DPR70    BSS
          LJM    DPRX
          SPACE  5,20
** NAME-- DU
*
** PURPOSE-- DECLUSTER UNIT
*
** ENTRY -- TD = PHYSICAL DRIVES PER LOGICAL UNIT
          SPACE  2
 DUX      LJM    **
 DU       EQU    *-1
          LDC    H0209+400000B  LOAD ATTRIBUTE OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDML   TD
          SBN    1
          ZJN    DU10        IF ONE PHYSICAL DRIVE PER LOGICAL UNIT
          LDML   CP+SLAD
          SCN    0#38        CLEAR STRING NUMBER
          STML   CP+SLAD
 DU10     BSS
          LDC    0#568
          STML   CP+FCP
          LDML   CP+SLAD
          LPN    77B         MASK DRIVE NUMBER
          SHN    8
          ADN    1
          STML   CP+FCP+1    PARAMETER WORD WITH DRIVE NUMBER
          LDDL   DT
          SBN    2
          PJN    DU20        IF 5833 OR 5838 OR 47444
          LDC    0#8500      DECLUSTER 5832
          UJN    DU30
 DU20     BSS
          LDC    0#8900      DECLUSTER NON 5832
 DU30     BSS
          STML   CP+FCP+2
          LDN    12          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          LDC    0#100       SO IH EXPECTS AN ASYNCHRONOUS RESPONSE
          STML   CP+OPCD
 DU40     BSS
          RJM    IH          INTERRUPT HANDLER
          SOML   TD
          NJN    DU40        IF ANOTHER ASYNCHRONOUS RESPONSE EXPECTED
          UJK    DUX
          SPACE  5,20
** NAME-- FU
*
** PURPOSE-- FORMAT UNIT
*
** ENTRY
*         - A = 0  IF DRIVE IS DECLUSTERED
*         - PD MUST BE THE PHYSICAL DRIVE TO FORMAT
          SPACE  2
 FUX      LJM    **
 FU       EQU    *-1
          STML   T10
          LDN    E57         FORMATTING DRIVE
          RJM    PER         PREPARE ERROR RESPONSE
          LDN    0
          STML   RS+/RS/P.SCYL  STARTING CYLINDER
          STML   RS+/RS/P.FTRK  SO TRACK, SECTOR WILL BE 0 IN CRITICAL WINDOW
          STML   RS+/RS/P.FSEC
          RJM    INTRS       SEND INTERMEDIATE RESPONSE

*         FORMAT THE DIAGNOSTIC CYLINDER

          LDC    0#280E+400000B  FORMAT OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDC    0#2D5       PARAMETER TO SELECT DRIVE
          STML   CP+FCP
          LDDL   PD
          SHN    8
          STML   CP+FCP+1    DRIVE TO FORMAT
          LDC    0#1E5
          STML   CP+FCP+2    DON'T READ HEADERS
          LDC    0#1DF
          STML   CP+FCP+3    FORMAT THE DIAGNOSTIC CYLINDER
          LDDL   DT          DRIVE TYPE
          SBN    2
          MJN    FU10        IF 5832
          LDML   T10
          ZJN    FU5         IF DRIVE DECLUSTERED
          LDML   /SS/P.UNIT,CSST
          STML   CP+SLAD     LOGICAL ADDRESS
 FU5      BSS
          LDN    0#E         COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP

*         FORMAT THE DATA CYLINDERS

 FU10     BSS
          LDC    0#7DD       FACTORY FORMAT PARAMETER
          STML   CP+FCP+3
          LDML   DD,DT
          STML   CP+FCP+4    DATA DRIVES PER LOGICAL UNIT
          LDN    0
          STML   CP+FCP+5    UPPER BYTES OF SECTOR SIZE
          LDML   BPS,DT      BYTES PER SECTOR
          STML   CP+FCP+6
          LDML   T10
          ZJN    FU20        IF DRIVE DECLUSTERED
          LDC    0#53B
          STML   CP+FCP+3    LOGICAL SECTOR SIZE
          LDN    0
          STML   CP+FCP+4    UPPER BYTES OF SECTOR SIZE
          LDML   BPS,DT
          STML   CP+FCP+5
          LDN    0#12        COMMAND PACKET LENGTH
          UJN    FU30
 FU20     BSS
          LDN    0#14        COMMAND PACKET LENGTH
 FU30     BSS
          RJM    ODFP        OUTPUT DATA FROM PP
          LDN    E58         FORMAT COMPLETE
          RJM    PER         PREPARE ERROR RESPONSE
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          UJK    FUX
          SPACE  5,20
** NAME-- IU
*
** PURPOSE-- INITIALIZE UNIT.  DECLUSTER UNIT IF CLUSTERED, FORMAT
*            ALL THE PHYSICAL UNITS OF THE LOGICAL UNIT AS NECESSARY,
*            THEN CLUSTER THE UNIT.
          SPACE  2
 IUX      LJM    **
 IU       EQU    *-1
          LDML   /SS/P.UNIT,CSST
          LPN    77B
          STDL   PD          PHYSICAL DRIVE
 IU10     BSS
          RJM    DDT         DETERMINE DRIVE TYPE
          MJN    IU30        IF DRIVE NOT IN CONTROLLER TABLE
          LDML   RPB+8+2,T3
          SHN    8
          PJN    IU20        IF UNIT NOT CLUSTERED
          RJM    DU          DECLUSTER UNIT
 IU20     BSS
          LOADF  CMLIST+/CM/P.RMA,CSST  ADDRESS OF LIST WITH FORMAT PARAMETER
          CRDL   P1          READ WORD WITH PARAMETER
          LDDL   P3
          SBN    1
          ZJN    IU30        IF UNCONDITIONAL FORMAT
          RJM    DDT         DETERMINE DRIVE TYPE
          RJM    IUF         IS UNIT FORMATTED
          ZJN    IU40        IF UNIT FORMATTED
 IU30     BSS
          LDN    0           TO INDICATE DRIVE DECLUSTERED
          RJM    FU          FORMAT UNIT
 IU40     BSS
          RJM    UPD         UPDATE DRIVE NUMBER
          NJN    IU10        IF MORE DRIVES TO CHECK
          RJM    CU          CLUSTER UNIT
          UJK    IUX
          SPACE  5,20
** NAME-- IUF
*
** PURPOSE-- IS UNIT FORMATTED
*
** EXIT   A = 0 IF DRIVE FORMATTED WITH CORRECT SECTOR SIZE
*           = 141 IF NOT CORRECTLY FORMATTED
          SPACE  2
 IUFX     LJM    **
 IUF      EQU    *-1
          LDML   RPB+8+2,T3  PARAMETER 68 BYTE 3
          SHN    8
          PJN    IUF2        IF UNIT NOT CLUSTERED
          LDML   /SS/P.UNIT,CSST
          UJN    IUF3
 IUF2     BSS
          LDDL   CMOD
          LPN    7           GET RID OF PORT NUMBER
          SHN    8
          ADDL   PD
 IUF3     BSS
          STML   CP+SLAD     CONTROLLER, DRIVE ADDRESS
          LDC    0#302
          STML   CP+OPCD     REPORT ADDRESSEE STATUS OPERATION CODE
          LDN    6           COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          LDML   RPB+9
          SHN    3
          PJN    IUF10       IF NOT FORMATTED
          LDML   RS+/RS/P.ADT
          STDL   T1          ACTUAL DRIVE TYPE
          SBN    DTS
          MJN    IUF5        IF RS+/RS/P.ADT CONTAINS DRIVE TYPE
          LDDL   DT
          STDL   T1          EXPECTED DRIVE TYPE
 IUF5     BSS
          LDML   RPB+9
          SHN    2
          MJN    IUF7        IF CLUSTERED
 IUF6     BSS
          LDML   RPB+7
          UJN    IUF8
 IUF7     BSS
          SHN    2
          PJN    IUF6        IF NO PARITY DRIVE
          LDML   RPB+7
          SBN    1
 IUF8     BSS
          LPN    77B         MASK ACTUAL DATA DRIVES FOR FORMAT
          LMML   DD,T1       EXPECTED DATA DRIVES
          NJN    IUF10       IF WRONG NUMBER OF DATA DRIVES
          LDML   RPB+11      ACTUAL SECTOR SIZE
          LMML   BPS,T1      EXPECTED SECTOR SIZE
          ZJK    IUFX        IF CORRECT SECTOR SIZE
 IUF10    BSS
          LDC    E141        INDICATE NOT FORMATTED
          UJK    IUFX
          SPACE  5,20
** NAME-- PER
*
** PURPOSE-- PREPARE ERROR RESPONSE
*
** ENTRY  (A) = ERROR CODE
          SPACE  2
 PERX     LJM    **
 PER      EQU    *-1
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDML   UNITS,UX
          LPC    740B
          ADDL   PD
          STML   RS+/RS/P.UNIT  PORT, CONTROLLER, DRIVE ADDRESS
          UJN    PERX
          SPACE  5,20
** NAME-- RAS
*
** PURPOSE-- REPORT ADDRESSEE STATUS
*
** EXIT   (A) = RPB+9
          SPACE  2
 RASX     LJM    **
 RAS      EQU    *-1
          LDC    0#302       REPORT ADDRESSEE STATUS OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDN    6           COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          LDML   RPB+9
          UJN    RASX
          SPACE  5,20
** NAME-- RMR
*
** PURPOSE-- READ CONTROLLER MICROCODE REVISION
          SPACE  2
 RMRX     LJM    **
 RMR      EQU    *-1
          LDC    H0200       REPORT ATTRIBUTE OPERATION CODE
          RJM    SOC         SET OPERATION CODE AND CONTROLLER
*         LDC    0#36C
          STML   CP+FCP      PARAMETER TO READ REV NUMBER
          LDC    0#8050
          STML   CP+FCP+1    REPORT PARAMETER 50
          LDN    10          COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDML   RPB+8+13    SAVE MICROCODE PART NUMBER
          STML   /SS/P.MREV,CSST
          LDML   RPB+8+14
          STML   /SS/P.MREV+1,CSST
          LDDL   DT
          ZJN    RMR20       IF 1X UNIT
          SBN    2
          ZJN    RMR20       IF 5833_1X UNIT
          SBN    5
          ZJN    RMR20       IF 5838_1X UNIT
          SBN    5
          ZJN    RMR20       IF 47444_1X UNIT
          LDML   /SS/P.MREV+1,CSST
          LPN    77B
          SBN    2
          PJN    RMR20       IF MICROCODE SUPPORTS PARALLEL AND PARITY
 RMR10    BSS
          LDK    E142        MICROCODE DOES NOT SUPPORT PARALLEL
          RJM    EP          ERROR PROCESSING (NO RETURN)
 RMR20    BSS
          LJM    RMRX
          SPACE  5,20
** NAME-- SOC
*
** PURPOSE-- SET OPERATION CODE AND CONTROLLER
*
** ENTRY  (A) = OPERATION CODE
*
** EXIT   (A) = 36C(16)
          SPACE  2
 SOCX     LJM    **
 SOC      EQU    *-1
          STML   CP+OPCD     OPERATION CODE
          LDDL   CMOD
          LPN    7
          SHN    8
          LMC    0#FF
          STML   CP+SLAD     SLAVE ADDRESS
          LDC    0#36C
          UJN    SOCX
          SPACE  5,20
** NAME-- SUD
*
** PURPOSE-- SPIN UP DRIVE.  THIS ROUTINE WILL ALSO REPORT
*            THAT PARITY PROTECTION IS DISABLED IF THIS IS THE
*            FIRST TIME THE DRIVE IS CHECKED AFTER THE DRIVER
*            IS LOADED.
*
** ENTRY-- A = PHYSICAL DRIVE TO SPIN UP
*
** EXIT-- A = NONZERO IF COMMAND SUCCESSFUL
          SPACE  2
 SUDX     LJM    **
 SUD      EQU    *-1
          SHN    8
          STML   CP+FCP+1    DRIVE TO SPIN UP
          LDML   /SS/P.DOAR,CSST
          LPC    0#8000
          ADML   IDLE
          NJN    SUD5        IF NOT REPORTING DRIVE OFF-LINE
          LDDL   PD          FAILING PHYSICAL DRIVE
          LPC    37B
          RJM    UPPS        UPDATE PARITY PROTECTION STATUS IN UIT
          LDK    E59         PARITY PROTECTION DISABLED
          RJM    PER         PREPARE ERROR RESPONSE
          LDN    /RS/K.PPD   PARITY PROTECTION DISABLED
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 SUD5     BSS
          LDC    0#2D5
          STML   CP+FCP      PHYSICAL DRIVE PARAMETER
          LDC    0#301
          STML   CP+OPCD     REPORT CONDITION OPERATION CODE
          LDN    10          COMMAND PACKET LENGTH
          RJM    ODFP        INPUT DATA TO PP
          LDML   RPB+6
          SHN    10
          MJK    SUD10       IF DRIVE NOT OPERATIONAL
          LDC    0#700
          STML   CP+OPCD     SET OPERATING MODE OPERATION CODE
          LDC    0#351
          STML   CP+FCP+2
          LDC    0#8000
          STML   CP+FCP+3    PARAMETER TO SELECT SPIN UP
          LDN    14
          STML   CP          COMMAND PACKET LENGTH
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LPN    8
          NJK    SUDX        IF COMMAND SUCCESSFUL
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          RJM    LIR         LOGICAL INTERFACE RESET (TO CLEAR ERROR RESPONSE)
 SUD10    BSS
          LDN    0
          UJK    SUDX
          SPACE  5,20
** NAME-- UPD
*
** PURPOSE-- UPDATE PHYSICAL DRIVE NUMBER
*
** EXIT
*         A NOT 0 IF NUMBER UPDATED
*         A = 0   DONE, NO UPDATE MADE
          SPACE  2
 UPDX     LJM    **
 UPD      EQU    *-1
          LDDL   DT
          ZJN    UPDX        IF NO UPDATE NECESSARY (5832_1)
          SBN    2
          ZJN    UPDX        IF NO UPDATE NECESSARY (5833_1)
          SBN    5
          ZJN    UPDX        IF NO UPDATE NECESSARY (5838_1)
          SBN    5
          ZJN    UPDX        IF NO UPDATE NECESSARY (47444_1)
          LDDL   PD
          SHN    -3
          SBN    3
          ZJN    UPDX        IF NO UPDATE NECESSARY
          LDDL   DT
          SBN    4
          ZJN    UPD10       IF 5833_2
          ADN    3
          ZJN    UPD10       IF 5832_2
          SBN    8
          ZJN    UPD10       IF 5838_2
          SBN    5
          NJK    UPD20       IF NOT 47444_2
 UPD10    BSS
          LDDL   PD
          SHN    -3
          SBN    1
          ZJN    UPDX        IF NO UPDATE NECESSARY
 UPD20    BSS
          LDDL   DT
          SBN    3
          ZJN    UPD25       IF 5833_1P
          SBN    5
          ZJN    UPD25       IF 5838_1P
          SBN    5
          NJN    UPD30       IF NOT 47444_1P
 UPD25    LDN    30B         STRING 3
          UJN    UPD40
 UPD30    BSS
          LDN    10B         UPDATE TO NEXT STRING
 UPD40    BSS
          RADL   PD
          LJM    UPDX
          ERRMI  EOM-*       IF OVERLAY OVERFLOWS MEMORY
          OVERLAY (CONFIDENCE TEST),OVST
          ROUTINE CTO        CONFIDENCE TEST OVERLAY
** NAME-- BCTB
*
** PURPOSE-- BUILD CONFIDENCE TEST WRITE BUFFER
          SPACE  2
 BCTBX    LJM    **
 BCTB     EQU    *-1
          IAN    14B
          STML   CTPAT       CONFIDENCE TEST PATTERN FIRST WORD MINUS ONE
          STDL   P1
          LOADC  CM.CB       ADDRESS OF PP COMMUNICATIONS BUFFER
          STDL   P2
 BCTB10   BSS
          AODL   P1          BUILD INCREMENTING PATTERN
          STDL   T1
          AODL   P1
          STDL   T2
          AODL   P1
          STDL   T3
          AODL   P1
          STDL   T4
          SBML   CTPAT
          ADC    -P.CB-4+/CB/P.BUF
          PJN    BCTBX       IF ALL WORDS STORED
          LDDL   P2
          LMC    400000B
          CWDL   T1          STORE IN PP COMMUNICATIONS BUFFER
          AODL   P2
          UJN    BCTB10
          SPACE  5,20
** NAME-- CDA
*
** PURPOSE-- CHECK DRIVE ATTRIBUTES
*          - ENSURE PARITY DRIVE CORRECTION DISABLED
*          - ENSURE FACILITY TIMEOUT IS 20 SECONDS
*          - ENSURE DRIVE INTERRUPT SIZE IS CORRECT FOR WRITES
          SPACE  2
 CDAX     LJM    **
 CDA      EQU    *-1

*         SHOULD HEAD SHIFT SCREEN BE RUN

          LDML   HSTF
          ZJN    CDA05       PROCEED WITH CHECK ATTRIBUTES
          RJM    HSDT        RUN HEAD SCREEN DETECTION TEST
          UJN    CDAX        EXIT

*         RESTORE DRIVE ATTRIBUTES

 CDA05    LDC    H0202       RESTORE ATTRIBUTES OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDN    6
          RJM    ODFP        OUTPUT DATA FROM PP

*         CHECK ATTRIBUTE 6E.  ENSURE PARITY DRIVE CORRECTION IS DISABLED.

          LDC    H0200
          STML   CP+OPCD     REPORT ATTRIBUTE OPERATION CODE
          LDC    0#36C
          STML   CP+FCP      REPORT ATTRIBUTE 6E
          LDC    0#806E
          STML   CP+FCP+1
          LDN    10          COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDML   RPB+8
          LMC    0#46E
          NJK    CDA50       IF RESPONSE INCORRECT
          LDML   UNITS,UX    INDICATE PARITY DRIVE CORRECTION DISABLED
          LPC    0#FDFF
          STML   UNITS,UX
          LDML   RPB+9
          LMC    0#C0A0
          ZJN    CDA10       IF PARITY DRIVE CORRECTION DISABLED
          RJM    LA6E        LOAD ATTRIBUTE 6E
          RJM    SA          SAVE ATTRIBUTES

*         CHECK ATTRIBUTE PARAMETER 6F

 CDA10    BSS
          LDC    H0200
          STML   CP+OPCD     REPORT ATTRIBUTES OPERATION CODE
          LDC    0#36C
          STML   CP+FCP      REPORT PARAMETER 6F
          LDC    0#806F
          STML   CP+FCP+1
          LDN    10          COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDML   RPB+8
          LMC    0#276F
          NJK    CDA50       IF RESPONSE INCORRECT
          LDML   RPB+8+11
          LMML   BPS,DT
          NJN    CDA15       IF BURST SIZE WRONG
          LDML   RPB+8+16
          LMC    0#131
          ZJK    CDA30       IF FACILITY TIMEOUT CORRECT
 CDA15    BSS
          LDN    0
          STDL   T1
 CDA20    BSS
          LCN    0           PARAMETERS WITH FFFF WILL NOT BE CHANGED
          STML   CP+4,T1
          AODL   T1
          LMN    20
          NJN    CDA20       IF MORE WORDS TO MOVE
          STML   CP+FCP+8    SET INTERRUPT SIZE AND BURST SIZE
          STML   CP+FCP+10
          LDML   BPS,DT
          STML   CP+FCP+9
          STML   CP+FCP+11
          LDC    0#131       SET FACILITY TIMEOUT TO 20 SECONDS
          STML   CP+FCP+16
          LDC    0#2D40
          STML   CP+FCP+17
          LDC    H0209
          STML   CP+OPCD     LOAD ATTRIBUTES OPERATION CODE
          LDC    0#276F
          STML   CP+FCP      PARAMETER 6F
          LDN    46          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          RJM    SA          SAVE ATTRIBUTES

*         CHECK ATTRIBUTE PARAMETER D8

 CDA30    BSS
          LDDL   DT          DRIVE TYPE
          SBN    2
          MJK    CDAX        IF INTERRUPT SIZE NOT USED
          LDC    H0200
          STML   CP+OPCD     REPORT ATTRIBUTES OPERATION CODE
          LDC    0#36C
          STML   CP+FCP      REPORT PARAMETER D8
          LDC    0#80D8
          STML   CP+FCP+1
          LDN    10          COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDML   RPB+8
          LMC    0#09D8
          NJK    CDA50       IF RESPONSE INCORRECT
          LDDL   CH
          ZJN    CDA32       IF 10 MB CHANNEL
          LDML   ISH,DT      INTERRUPT SIZE FOR 25 MB CHANNEL
          UJN    CDA34
 CDA32    BSS
          LDML   ISL,DT      INTERRUPT SIZE FOR 10 MB CHANNEL
 CDA34    BSS
          STDL   T2
          LDML   RPB+8+2
          LMDL   T2
          NJN    CDA40       IF INTERRUPT SIZE FOR WRITES IS WRONG
          LDML   RPB+8+4
          LMML   BPS,DT
          ZJK    CDAX        IF BURST SIZE FOR WRITES IS CORRECT
 CDA40    BSS
          LDN    0
          STML   CP+FCP+1
          STML   CP+FCP+3
          LDML   BPS,DT
          STML   CP+FCP+4    BURST SIZE FOR WRITES
          LDDL   T2          SET INTERRUPT SIZE FOR WRITES
          STML   CP+FCP+2
          LDC    H0209
          STML   CP+OPCD     LOAD ATTRIBUTES OPERATION CODE
          LDC    0#9D8
          STML   CP+FCP      PARAMETER D8
          LDN    16          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          RJM    SA          SAVE ATTRIBUTES
          UJK    CDAX
 CDA50    BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- CSC
*
** PURPOSE-- COMPUTE SECTOR COUNT TO TRANSFER
          SPACE  2
 CSCX     BSS
          LDML   SPT,DT      SECTORS PER TRACK
          SBML   /SS/P.CURSEC,CSST
          SBML   SSPC,DT     SPARE SECTORS PER CYLINDER
          RADL   TOTAL
          STML   /SS/P.TOTAL,CSST  SECTORS TO TRANSFER
          LJM    **
 CSC      EQU    *-1
          LDDL   DT
          SBN    2
          PJN    CSC5        IF NOT SSD
          LDML   TPC,DT
          SBN    1
          STML   /SS/P.CURTRK,CSST  CURRENT TRACK
          LDML   SPT,DT      SECTORS PER TRACK
          SBN    1
          STML   /SS/P.CURSEC,CSST  CURRENT SECTOR
 CSC5     BSS
          LDML   /SS/P.CURTRK,CSST
          STDL   T1          TRACK
          SHN    8
          ADML   /SS/P.CURSEC,CSST
          STML   CP+FCP+4    TRACK, SECTOR FOR COMMAND PACKET
          LDML   CTC,DT      CONFIDENCE TEST CYLINDER
          STML   CP+FCP+3    CYLINDER FOR COMMAND PACKET
          LDN    0
          STDL   TOTAL
          STML   CP+FCP+1    UPPER WORD OF SECTOR COUNT
 CSC10    BSS
          AODL   T1
          LMML   TPC,DT      TRACKS PER CYLINDER
          ZJK    CSCX        IF LAST TRACK
          LDML   SPT,DT      SECTORS PER TRACK
          RADL   TOTAL
          UJN    CSC10
          SPACE  5,20
** NAME-- CT
*
** PURPOSE-- CONFIDENCE TEST.  ENSURE DRIVE ATTRIBUTES ARE LOADED AND
*            SAVED, THEN WRITE, READ, AND VERIFY DATA ON A RESERVED CYLINDER.
*
** ENTRY
*         FROM GETU IF A REQUEST IS PRESENT AND THE CONFIDENCE TEST
*         HAS NOT BEEN RUN FOR A UNIT AFTER THE PP WAS LOADED OR RECEIVED
*         A RESUME.  ALSO, FROM GETU IF A REQUEST IS PRESENT AND THE CAUSE
*         OF AN ERROR MUST BE ISOLATED BETWEEN MEDIA AND OTHER.
          SPACE  2
 CTX      LJM    **
 CT       EQU    *-1
          LDML   HSTF
          NJN    CT05        IF IN HEAD SHIFT TEST
          RJM    CTDT        CONFIDENCE TEST DATA TRANSFER
 CT05     LDML   /SS/P.FNC,CSST
          SBN    2
          NJN    CT10        IF NOT FORMAT COMMAND
          STML   HSTF        CLEAF HEAD SHIFT FLAG
          STDL   IF          CLEAR INITIALIZATION FLAG
          RJM    PDR         PREPARE NORMAL DISK RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          LDN    1
          STDL   CMNDS       ONE COMMAND IN PROGRESS
          RJM    DCR         DELINK COMPLETED REQUEST
          RJM    RESPIN      UPDATE -IN- POINTER FOR RESPONSE BUFFER
          RJM    UUT         UNLOCK UNIT TABLE
          UJN    CT20
 CT10     BSS
          RJM    SFRR        CLEAR CIP, IF, UPSB
 CT20     BSS
          LDN    1
          STML   /SS/P.CT,CSST  INDICATE TEST COMPLETED SUCCESSFULLY
          LDML   /SS/P.RECOV,CSST
          LMN    1
          ZJN    CT30        IF CONFIDENCE TEST PART OF REQUEST RECOVERY
          LDN    0
          STML   /SS/P.RQTRY,CSST  CLEAR REQUEST RETRY COUNTER
          STML   /SS/P.RECOV,CSST  SO SPIN UP CAN OCCUR IN ROUTINE COD
 CT30     BSS
          UJK    CTX
          SPACE  5,20
** NAME-- CTDT
*
** PURPOSE-- CONFIDENCE TEST DATA TRANSFER
          SPACE  2
 CTDTX    LJM    **
 CTDT     EQU    *-1

*         WRITE THE CYLINDER

          LCN    0
          STML   CTME,CSST   MAKE MEDIA ERROR TABLE LOOK EMPTY
          STML   CTME+1,CSST
          STML   CTME+2,CSST
          LDN    1
          STDL   FNC         INDICATE WRITE OPERATION
          RJM    SSA         SET STARTING ADDRESS
          RJM    BCTB        BUILD CONFIDENCE TEST BUFFER
 CTDT5    BSS                ENTRY IF MEDIA ERROR
          RJM    CSC         COMPUTE SECTOR COUNT TO TRANSFER
          RJM    SCP         SETUP COMMAND PACKET PARAMETERS
          IFEQ   FE,1
          RJM    CPTA        FOR FORCING ERRORS
          ELSE
          RJM    CPT         COMMAND PACKET TRANSFER
          ENDIF
 CTDT10   BSS
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    CTDT100     IF NOT TRANSFER NOTIFICATION
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAOUT     DATA, INFORMATION OUT
          RJM    BCS         BUS CONTROL SEQUENCE
          LDML   BPS,DT      BYTES PER SECTOR
          STDL   BC
          LDC    H0381       STREAM, WRITE
          RJM    FUNC
          LDML   SPC,DT      SECTORS PER CYLINDER
          SBML   /SS/P.TOTAL,CSST  SECTORS TO TRANSFER
          SHN    3
          ADML   CM.CB.T+2
          STDL   RMA+1       LOWER RMA
          SHN    -16
          ADML   CM.CB.T+1
          STDL   RMA         UPPER RMA
          LDC    H0D00       DMA WRITE
          RJM    LTR         LOAD T REGISTERS
          RJM    WFTC        WAIT FOR TRANSFER COMPLETE
          ZJK    CTDT10      IF PAUSE
          RJM    DCM         DESELECT THE CONTROLLER
          RJM    UDA         UPDATE DISK ADDRESS
          NJK    CTDT10      IF MORE SECTORS TO TRANSFER
 CTDT20   BSS
          RJM    IH          INTERRUPT HANDLER
          SBN    0#12
          ZJN    CTDT40      IF COMPLETE AND CONDITIONAL SUCCESS
          SBN    0#18-0#12
          ZJN    CTDT40      IF COMPLETE AND SUCCESSFUL
          SBN    0#42-0#18
          ZJN    CTDT20      IF ASYNCH AND CONDITIONAL SUCCESS
          LJM    CTDT100

*         READ THE CYLINDER

 CTDT40   BSS
          LDN    0
          STDL   FNC         INDICATE READ FUNCTION
          RJM    SSA         SET STARTING ADDRESS
 CTDT50   BSS                ENTRY IF MEDIA ERROR
          RJM    CSC         COMPUTE SECTOR COUNT TO TRANSFER
          RJM    SCP         SETUP COMMAND PACKET PARAMETERS
          RJM    CPT         COMMAND PACKET TRANSFER
 CTDT60   BSS
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    CTDT100     IF NOT TRANSFER NOTIFICATION
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAIN      DATA, INFORMATION IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDML   CM.CB.T+1   SET RMA TO SAVE DATA READ
          STDL   RMA
          LDML   CM.CB.T+2
          STDL   RMA+1
          LDC    H0281       STREAM, READ
          RJM    FUNC
          LDC    H0C00       DMA READ
          RJM    LTR         LOAD T REGISTERS
          RJM    WFTC        WAIT FOR TRANSFER TO COMPLETE
          ZJK    CTDT60      IF PAUSE

*         VERIFY THE DATA IN ONE SECTOR

          RJM    DCM         DESELECT THE CONTROLLER
          RJM    VCTD        VERIFY CONFIDENCE TEST DATA
          RJM    UDA         UPDATE DISK ADDRESS
          NJK    CTDT60      IF MORE SECTORS TO TRANSFER
 CTDT70   BSS
          RJM    IH          INTERRUPT HANDLER
          SBN    0#12
          ZJN    CTDT110     IF COMPLETE AND CONDITIONAL SUCCESS
          SBN    0#18-0#12
          ZJN    CTDT110     IF COMPLETE AND SUCCESSFUL
          SBN    0#42-0#18
          ZJN    CTDT70      IF ASYNCH AND CONDITIONAL SUCCESS
 CTDT100  BSS
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    EP          ERROR PROCESSING (NO RETURN)
 CTDT110  BSS
          LJM    CTDTX
          SPACE  5,20
** NAME-- CTRS
*
** PURPOSE-- CONFIDENCE TEST RECOVERY SUBROUTINE
          SPACE  2
 CTRS     CON    0
          LDML   RPB+11,T3   HEAD, SECTOR
          STDL   T4
          LDDL   CSST
          STDL   T5          POINTER TO SS TABLE
          LDN    3
          STDL   T6          NUMBER OF MEDIA ERRORS ALLOWED
 CTR20    BSS
          LDML   CTME,T5
          SHN    2
          MJN    CTR30       IF TABLE ENTRY AVAILABLE
          SHN    -2
          LMDL   T4
          ZJN    CTR40       IF THIS SECTOR IN TABLE
          AODL   T5
          SODL   T6
          NJN    CTR20       IF MORE ENTRIES TO CHECK
          UJK    CTRX
 CTR30    BSS
          LDDL   T4
          STML   CTME,T5
 CTR40    BSS
          LDDL   FNC
          ZJN    CTR50       IF READ
          LDDL   T4
          SHN    -8
          STML   /SS/P.CURTRK,CSST  FAILING TRACK
          LDDL   T4
          LPN    77B
          STML   /SS/P.CURSEC,CSST  FAILING SECTOR
 CTR50    BSS
          LDML   TPC,DT
          SBML   /SS/P.CURTRK,CSST
          SBN    1
          NJN    CTR52       IF NOT LAST TRACK
          LDML   SPT,DT      SECTORS PER TRACK
          SBML   SSPC,DT     SPARE SECTORS PER CYLINDER
          UJN    CTR54
 CTR52    BSS
          LDML   SPT,DT      SECTORS PER TRACK
 CTR54    BSS
          STDL   T3          SECTORS PER TRACK
          AOML   /SS/P.CURSEC,CSST  UPDATE SECTOR NUMBER
          SBDL   T3
          MJN    CTR60       IF SAME TRACK
          STML   /SS/P.CURSEC,CSST
          AOML   /SS/P.CURTRK,CSST  UPDATE TRACK NUMBER
          LMML   TPC,DT      TRACKS PER CYLINDER
          NJN    CTR60       IF NOT LAST SECTOR ON CYLINDER
          RJM    LIR         LOGICAL INTERFACE RESET (TO CLEAR ASYNCH)
          LDDL   FNC
          NJK    CTDT40      IF WRITE
          LJM    CTDTX
 CTR60    BSS
          RJM    LIR         LOGICAL INTERFACE RESET (TO CLEAR ASYNCHS)
          LDDL   FNC
          NJK    CTDT5       IF WRITE
          LJM    CTDT50      GO TO READ ENTRY POINT
          SPACE  5,20
** NAME-- GAS
*
** PURPOSE-- GET ADDRESSEE STATUS
*
** EXIT   (A) = RPB+9
          SPACE  2
 GASX     LJM    **
 GAS      EQU    *-1
          LDC    0#302       REPORT ADDRESSEE STATUS OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDN    6           COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          LDML   RPB+9
          UJN    GASX
          SPACE  5,20
** NAME-- HSDT
*
** PURPOSE-- RUN HEAD SHIFT DETECTION TEST
*         SPACE  2
 HSDTX    LJM    **
 HSDT     EQU    *-1
          LDML   /SS/P.MREV+1,CSST
          LPN    77B
          SBN    0#14        REV LEVEL 14
          PJN    HSDT5       IF MICROCODE SUPPORTS HEAD SHIFT SCREEN
          UJK    HSDT35      EXIT
 HSDT5    LCN    0
          STML   HSDDR       INDICATE NO OFF-LINE DRIVE
          LDML   /SS/P.UNIT,CSST
          LPN    77B
          STDL   PD          PHYSICAL DRIVE
          LPN    70B
          NJN    HSDT15      IF NOT DRIVE NUMBER 0-7
          RJM    GAS         REPORT ADDRESSEE STATUS
          LPN    77B
          STML   HSDDR       OFF-LINE DRIVE NUMBER
 HSDT10   LDML   HSDDR
          MJN    HSDT15      IF NO OFF-LINE DRIVE
          LMD    PD
          ZJK    HSDT30      IF THIS DRIVE IS OFF-LINE
 HSDT15   LDC    H8101       PERFORM HEAD SHIFT TEST OP CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDC    0#2D5
          STML   CP+FCP      PARAMETER TO SELECT DRIVE
          LDDL   PD
          LPN    37B
          SHN    8
          STML   CP+FCP+1    PHYSICAL DRIVE NUMBER
          LDN    10
          STML   CP          COMMAND PACKET LENGTH
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LPN    0#A
          NJN    HSDT30      IF COMMAND SUCCESSFUL
          LDK    ID23
          RJM    SFP         SEARCH FOR PARAMETER
          PJN    HSDT20      IF ID23
          LDN    E00
          UJN    HSDT25      CP MUST DETERMINE ERROR
 HSDT20   LDML   RPB+8,T3    OCTET 5/6
          LPN    20B
          ZJN    HSDT26      IF NOT HEAD SHIFT ERROR
          LDK    E96         DRIVE HEAD SHIFT ERROR
 HSDT25   RJM    PCER        PREPARE COMMON ERROR RESPONSE
 HSDT26   RJM    INTRS       SEND INTERMEDIATE RESPONSE
          RJM    LIR         LOGICAL INTERFACE RESET
 HSDT30   RJM    IPD         UPDATE DRIVE NUMBER
          NJK    HSDT10      IF MORE DRIVES TO TEST
 HSDT35   UJK    HSDTX
 HSDDR    DATA   0
          SPACE  5,20
** NAME-- IPD
*
** PURPOSE-- INCREMENT PHYSICAL DRIVE NUMBER
*
** EXIT
*         A NOT 0 IF NUMBER UPDATED
*         A = 0   DONE, NO UPDATE MADE
          SPACE  2
 IPDX     LJM    **
 IPD      EQU    *-1
          LDDL   DT
          SBN    2
          ZJN    IPDX        IF NO INCREMENT NECESSARY (5833_1)
          LDDL   PD
          SHN    -3
          SBN    3
          ZJN    IPDX        IF NO INCREMENT NECESSARY
          LDDL   DT
          SBN    4
          ZJN    IPD10       IF 5833_2
          ADN    3
          NJN    IPD20       IF NOT 5832_2
 IPD10    BSS
          LDDL   PD
          SHN    -3
          SBN    1
          ZJN    IPDX        IF NO INCREMENT NECESSARY
 IPD20    BSS
          LDDL   DT
          SBN    3
          NJN    IPD30       IF NOT 5833_1P
          LDN    30B         STRING 3
          UJN    IPD40
 IPD30    BSS
          LDN    10B         INCREMENT TO NEXT STRING
 IPD40    BSS
          RADL   PD
          UJN    IPDX
          SPACE  5,20
** NAME-- IRD
*
** PURPOSE-- ISSUE RESTORE DRIVE
          SPACE  2
 IRDX     LJM    **
 IRD      EQU    *-1
          LDM    /SS/P.DT,CSST
          SHN    -4
          STDL   DT          DEVICE TYPE
          LDML   UNITS,UX    INDICATE ONE COMMAND IN PROGRESS
          LMC    0#8000
          STML   UNITS,UX
          AODL   CMNDS       COMMANDS ISSUED TO CONTROLLER
          LDN    0#18
          STML   CP          COMMAND PACKET LENGTH
          LDDL   UX
          STML   CP+CRN      COMMAND REFERENCE NUMBER
          LDC    H0931
          STML   CP+FCP      COMMAND EXTENT PARAMETER
          LDC    0#E005      RESTORE DRIVE OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDC    0#2D5
          STML   CP+FCP+5    SELECT PHYSICAL DRIVE PARAMETER
          LDML   ODN,CSST
          SHN    8
          STML   CP+FCP+6    DRIVE NUMBER TO RESTORE
          LDC    0#2E3
          STML   CP+FCP+7    RESTORE OPTION PARAMETER
          LDML   /SS/P.CRTS,CSST
          LPN    77B
          STML   /SS/P.CURSEC,CSST
          LDML   /SS/P.CRTS,CSST
          SHN    -8
          STML   /SS/P.CURTRK,CSST
          RJM    CSC         COMPUTE SECTOR COUNT TO TRANSFER
          STML   CP+FCP+2    SECTORS TO RESTORE
          LDML   CRC,CSST
          STML   CP+FCP+3    CYLINDER TO RESTORE
          LMML   CTC,DT      LAST CYLINDER
          NJN    IRD20       IF NOT LAST CYLINDER
          LDC    0#901       NO OP PARAMETER
          STML   CP+FCP
          LDC    0#100       ON LINE DRIVE
          UJN    IRD30
 IRD20    BSS
          LDC    0#200       RESTORE DRIVE
 IRD30    BSS
          STML   CP+FCP+8
          RJM    CPT         COMMAND PACKET TRANSFER
          LJM    IRDX
          SPACE  5,20
          SPACE  5,20
** NAME-- PFMT
*
** PURPOSE-- PROCESS FORMAT PARAMETER.
          SPACE  2
 PFMTX    LJM    **
 PFMT     EQU    *-1
          LOADF  CMLIST+/CM/P.RMA,CSST  ADDRESS OF LIST WITH FORMAT PARAMETER
          CRDL   P1          READ WORD WITH PARAMETER
          LDDL   P3
          SBN    2
          PJK    PFMT10      IF SET/CLEAR FORCE, HS DETECT, OR RUN CT
          UJK    PFMT27
 PFMT10   NJN    PFMT20      IF NOT CLEAR FORCE FORMAT BIT
          RJM    CFFMT       CLEAR FORCE FORMAT BIT
          UJN    PFMT35
 PFMT20   SBN    1
          NJN    PFMT25      IF NOT SET FORCE FORMAT BIT
          RJM    SFFMT       SET FORCE FORMAT BIT
          UJN    PFMT35
 PFMT25   SBN    1
          NJN    PFMT30      IF RUN CT TO ENABLE RESTORE
          LDN    1
          STML   HSTF        SET FLAG TO RUN HEAD SHIFT TEST
 PFMT27   LDN    0
          STML   /SS/P.CT,CSST  ENABLE RUNNING CONFIDENCE TEST
          UJK    PFMTX       EXIT
 PFMT30   LDN    40B
          STML   /SS/P.CT,CSST  FORCE CONFIDENCE TEST TO BE RUN
          LDM    /SS/P.DOAR,CSST
          LMC    0#8000      INDICATE OPERATIONAL ASYNCH RECEIVED
          STML   /SS/P.DOAR,CSST
 PFMT35   RJM    PDR         PREPARE NORMAL DISK RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          AODL   CMNDS       DCR WILL DECREMENT CMNDS
          RJM    DCR         DELINK COMPLETED REQUEST
          RJM    RESPIN      UPDATE -IN- POINTER FOR RESPONSE BUFFER
          RJM    UUT         UNLOCK UNIT TABLE
          LDN    1           FORCE EXIT FROM -GETU-
          UJK    PFMTX
          SPACE  5,20
** NAME-- VCTD
*
** PURPOSE-- VERIFY CONFIDENCE TEST DATA
          SPACE  2
 VCTDX    LJM    **
 VCTD     EQU    *-1
          LDN    0
          STDL   P1
          LDML   /SS/P.CURTRK,CSST
          SHN    8
          ADML   /SS/P.CURSEC,CSST
          STDL   P2
          LDDL   CSST
          STDL   P3
 VCTD5    BSS
          LDML   CTME,P3     ADDRESS IN TABLE
          LMDL   P2          CURRENT ADDRESS
          ZJK    VCTDX       IF SECTOR NOT WRITTEN
          AODL   P3
          AODL   P1
          LMN    3
          NJN    VCTD5       IF MORE TABLE LOCATIONS TO CHECK
          LDML   BPS,DT      BYTES PER SECTOR
          SHN    -3
          STDL   P3          CM WORDS PER SECTOR
          LDML   SPC,DT      SECTORS PER CYLINER
          SBML   /SS/P.TOTAL,CSST  SECTOR NUMBER
          SHN    2
          ADML   CTPAT       CONFIDENCE TEST PATTERN FIRST WORD MINUS ONE
          STDL   P1          STARTING DATA PATTERN VALUE MINUS ONE
          LOADC  CM.CB       ADDRESS OF PP COMMUNICATIONS BUFFER
          STDL   P2
 VCTD10   BSS
          LDDL   P2
          LMC    400000B
          CRDL   T4          READ WORD OF SECTOR
          AODL   P1
          SBDL   T4
          NJN    VCTD20      IF DATA MISCOMPARE
          AODL   P1
          SBDL   T5
          NJN    VCTD20      IF DATA MISCOMPARE
          AODL   P1
          SBDL   T6
          NJN    VCTD20      IF DATA MISCOMPARE
          AODL   P1
          SBDL   T7
          NJN    VCTD20      IF DATA MISCOMPARE
          AODL   P2          INDEX TO WORD TO READ
          SODL   P3
          NJN    VCTD10      IF MORE WORDS TO VERIFY
          LJM    VCTDX
 VCTD20   BSS
          RJM    SFRR        CLEAR CIP, IF
          LDN    4
          STML   /SS/P.CT,CSST  INDICATE DATA INTEGRITY ERROR
          LDK    E111        CM-DRIVE DATA INTEGRITY
          RJM    EP          ERROR PROCESSING (NO RETURN)
          ERRMI  EOM-*       IF OVERLAY OVERFLOWS MEMORY
          OVERLAY (ERROR RECOVERY OVERLAY ONE),OVST
          ROUTINE ER1O       ERROR RECOVERY OVERLAY NUMBER ONE
** NAME-- EFH
*
** PURPOSE-- ERROR FLAG HANDLING
          SPACE  5,20
 EFH      CON    0
          LDC    H00F1       READ IPI ERROR REGISTER FUNCTION
          RJM    RDRG        READ REGISTER
          STDL   T1
          LPC    0#300
          NJN    EFH10       IF BUS ACKNOWLEDGE OR ENDING STATUS ERROR
          LDC    H00E1       READ STATUS REGISTER FUNCTION
          RJM    RDRG        READ REGISTER
          STDL   STATUS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 EFH10    BSS
          LDC    H0041       READ BUS B FUNCTION
          RJM    RDRG        READ REGISTER
          STDL   STATUS
          LDDL   T1
          LPC    0#100
          ZJN    EFH20       IF ENDING STATUS ERROR
          LDN    E37         BUS B ACKNOWLEDGE INCORRECT
          UJN    EFH30
 EFH20    BSS
          RJM    IEE         ISOLATE ENDING STATUS ERRORS (NO RETURN)
 EFH30    BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- EFP
*
** PURPOSE-- ERROR FLAG PROCESSING.  THIS IS THE PORTION OF EFP
*            THAT CAN BE IN AN OVERLAY.
          SPACE  2
 EFP1     BSS
          LDC    H0800       DMA TERMINATE
          RJM    FAN
          LDC    H0600       READ DMA ERROR REGISTER
          RJM    RDRG
          STDL   T1
          SHN    9
          MJK    EFP60       IF IPI ERROR
          SHN    11
 EFP2     BSS
          PJN    EFP3        IF NOT DMA COUNT OVERFLOW
          LDN    E19         DMA COUNT OVERFLOW
          UJN    EFP40
 EFP3     BSS
          SHN    1
          MJK    EFP85       IF ILLEGAL FUNCTION
          SHN    1
          MJN    EFP5        IF UNCORRECTED CM ERROR
          SHN    1
          PJN    EFP10       IF NOT CM REJECT
 EFP5     BSS
          LDN    E09         CENTRAL MEMORY ERROR
          UJN    EFP40
 EFP10    BSS
          SHN    1
          PJN    EFP15       IF NOT INVALID CM RESPONSE CODE
          LDN    E10
          UJN    EFP40
 EFP15    BSS
          SHN    1
          PJN    EFP20       IF NOT CM RESPONSE CODE PARITY ERROR
          LDN    E11
          UJN    EFP40
 EFP20    BSS
          SHN    1
          PJN    EFP25       IF NOT CMI READ DATA PARITY ERROR
          LDN    E12
          UJN    EFP40
 EFP25    BSS
          SHN    5
          PJN    EFP35       IF NOT Y BOARD DATA ERROR
          LDN    E13
          UJN    EFP40
 EFP35    BSS
          SHN    1
          PJN    EFP45       IF NOT BAS PARITY ERROR
          LDN    E14
 EFP40    BSS
          UJN    EFP75
 EFP45    BSS
          SHN    1
          PJN    EFP50       IF NOT Z BOARD ERROR
          LDN    E15
          UJN    EFP75
 EFP50    BSS
          SHN    1
          PJN    EFP55       IF NOT J BOARD ERROR
          LDN    E16
          UJN    EFP75
 EFP55    BSS
          SHN    1
          PJK    EFP130      IF NOT L BOARD ERROR
          LDN    E17
          UJN    EFP75
 EFP60    BSS
          LDC    H00F1       READ IPI ERROR REGISTER
          RJM    RDRG
          SHN    2
          PJN    EFP65       IF NOT BUFFER COUNTER PARITY
          LDN    E31
          UJN    EFP75
 EFP65    BSS
          SHN    2
          PJN    EFP70       IF NOT SYNC COUNTER PARITY
          LDN    E32
          UJN    EFP75
 EFP70    BSS
          SHN    1
          PJN    EFP80       IF NOT PERIOD COUNTER PARITY
          LDN    E03
 EFP75    BSS
          UJN    EFP108
 EFP80    BSS
          SHN    1
          MJN    EFP85       IF PARITY ERROR ON FUNCTION
          SHN    1
          PJN    EFP95       IF NOT PARITY ERROR ON FUNCTION
 EFP85    BSS
          LDN    E01         FUNCTION TIMEOUT
          UJN    EFP108
 EFP95    BSS
          SHN    3
          PJN    EFP100      IF NOT LOST DATA
          LDN    E33
          UJN    EFP150
 EFP100   BSS
          SHN    1
          MJN    EFP105      IF UPPER ICI PARITY ERROR
          SHN    1
          PJN    EFP110      IF NOT LOWER ICI PARITY ERROR
 EFP105   BSS
          LDN    E04
 EFP108   BSS
          UJN    EFP150
 EFP110   BSS
          SHN    1
          PJN    EFP115      IF NOT IPI SEQUENCE ERROR
          LDN    E24
          UJN    EFP150
 EFP115   BSS
          SHN    1
          MJN    EFP128      IF UPPER IPI CHANNEL PARITY ERROR
          SHN    1
          MJN    EFP128      IF LOWER IPI CHANNEL PARITY ERROR
          LDDL   CH
          ZJN    EFP130      IF 10 MB CHANNEL
          LDDL   T1          DMA ERROR REGISTER
          SHN    3
          LJM    EFP2
 EFP128   BSS
          LDN    E25
          UJN    EFP150
 EFP130   BSS
          LDN    E06         IOU ERROR
 EFP150   BSS
          STML   RS+/RS/P.ERRID
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- FS
*
** PURPOSE-- FORMAT ONE SECTOR.  FOR A 1P LOGICAL UNIT, THIS GUARANTEES
*            THAT A LATER READ TO THIS SECTOR WILL GET AN LRC ERROR RATHER
*            THAN RETURNING OLD DATA DUE TO PARITY DRIVE CORRECTION.
          SPACE  2
 FSX      LJM    **
 FS       EQU    *-1
          LDML   RPB+9,T3
          SHN    -8
          LMML   ODN,CSST
          ZJN    FSX         IF ERROR ON OFF LINE DRIVE
          RJM    LIR         LOGICAL INTERFACE RESET
          LDC    0#2807      FORMAT OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDC    H0931
          STML   CP+FCP      COMMAND EXTENT PARAMETER
          LDN    0
          STML   CP+FCP+1
          LDN    1
          STML   CP+FCP+2    SECTOR COUNT
          LDML   RS+/RS/P.SCYL
          STML   CP+FCP+3    CYLINDER TO FORMAT
          LDML   /SS/P.CURTRK,CSST
          SHN    8
          ADML   /SS/P.CURSEC,CSST
          STML   CP+FCP+4    TRACK, SECTOR TO FORMAT
          LDC    0#1E5
          STML   CP+FCP+5    DON'T READ HEADERS
          LDC    0#2D5
          STML   CP+FCP+6    PARAMETER TO SELECT PHYSICAL DRIVE
          LDML   ODN,CSST
          SHN    8
          STML   CP+FCP+7    DRIVE TO FORMAT
          LDN    0#16        COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          UJK    FSX
          SPACE  5,20
** NAME-- IEE
*
** PURPOSE-- ISOLATE ENDING STATUS ERRORS
          SPACE  2
 IEE      CON    0
          LDDL   STATUS
          SHN    11
          PJN    IEE10       IF NOT BUS PARITY
          LDK    E34
          UJN    IEE25
 IEE10    BSS
          LDDL   STATUS
          LPN    17B
          ZJN    IEE12       IF REPORTING -ENDING STATUS WRONG-
          SBN    1
          NJN    IEE20       IF NOT BUS CONTROL REJECTED
          LDDL   TBC
 IEE12    ZJK    IEE60       IF REPORTING -ENDING STATUS WRONG-
          LDN    0
          STDL   TBC         INDICATE NOT EXPECTING 01 STATUS
          RJM    DCM         DESELECT THE CONTROLLER
          LDDL   CLSEC
          SBML   UNITS+/UN/P.CLK,UX
          PJN    IEE15       IF CLOCK HASNT WRAPPED
          ADC    0#10000
 IEE15    BSS
          SBN    CMT         COMMAND TIMEOUT
          PJN    IEE55       IF TIMEOUT
          LJM    MAIN15      TRANSFER NOTIFICATION OCCURRED BEFORE
                              THE COMPLETION RESPONSE, WAIT FOR
                              THE COMPLETION RESPONSE
 IEE20    BSS
          SBN    8
          NJN    IEE30       IF NOT -SYNC OUTS NOT EQUAL SYNC INS-
          LDK    E36
 IEE25    BSS
          UJN    IEE70
 IEE30    BSS
          PJN    IEE50       IF NOT COMMAND REJECT
          ADN    6
          NJN    IEE35       IF NOT CLASS 3 RESPONSE PRESENT
          RJM    RPT         READ RESPONSE PACKET
*         LDN    E00         RESPONSE MUST BE EVALUATED TO DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
 IEE35    BSS
          LDK    E35
          UJN    IEE70
 IEE50    BSS
          SBN    2
          NJN    IEE60       IF NOT LRC ERROR
          LDK    E70
          UJN    IEE70
 IEE55    BSS
          LDN    E38         NO CONTROLLER RESPONSE
          UJN    IEE70
 IEE60    BSS
          LDN    E39         ENDING STATUS WRONG
 IEE70    BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- SMD
*
** PURPOSE-- SKIP MEDIA DEFECT
          SPACE  2
 SMDX     LJM    **
 SMD      EQU    *-1
          LDN    ID26
          RJM    SFP         SEARCH FOR PARAMETER
          LDML   RPB+11,T3   SECTOR IN ERROR
          STML   /SS/P.CRTS,CSST
          SHN    -8
          STML   /SS/P.CURTRK,CSST
          STML   RS+/RS/P.FTRK  FAILING TRACK
          LDML   RPB+11,T3
          LPN    77B
          STML   /SS/P.CURSEC,CSST
          STML   RS+/RS/P.FSEC  FAILING SECTOR
          AOML   /SS/P.CRTS,CSST  UPDATE RESTORE ADDRESS TO NEXT SECTOR
          LPN    77B
          SBML   SPT,DT
          NJN    SMD10       IF NOT LAST SECTOR
          LDML   /SS/P.CRTS,CSST
          LPC    0#FF00
          ADC    0#100
          STML   /SS/P.CRTS,CSST
 SMD10    BSS
          LDML   /SS/P.CRTS,CSST  8/TRACK, 8/SECTOR
          ADC    -0#600
          SBML   SPT,DT      SECTORS PER TRACK
          ADN    2           SPARE SECTORS PER CYLINDER
          NJN    SMD20       IF NOT LAST SECTOR OF CYLINDER
          STML   /SS/P.CRTS,CSST  SET CURRENT RESTORE TRACK, SECTOR
          AOML   CRC,CSST    INCREMENT CURRENT RESTORE CYLINDER
 SMD20    BSS
          LDDL   DT
          SBN    3
          NJN    SMD30       IF NOT 1P UNIT
          RJM    FS          FORMAT 1 SECTOR
 SMD30    BSS
          UJK    SMDX
          ERRMI  EOM-*       IF OVERLAY OVERFLOWS MEMORY
          OVERLAY (ERROR RECOVERY OVERLAY TWO),OVST
          ROUTINE ER2O       ERROR RECOVERY OVERLAY NUMBER 2
** NAME-- CLR
*
** PURPOSE-- CHECK FOR LABEL READ.  NOS/VE ATTEMPTS TO READ THE LABEL
*            BEFORE IT FORMATS.  THE DRIVER DOES NOT KNOW WHETHER THE
*            DRIVE IS TO BE FORMATTED.  THUS, IF AN ERROR OCCURS READING
*            THE LABEL, THE DRIVE CAN NOT ALWAYS BE DOWNED.
*
** EXIT   (A) .LT. 0 IF NOT LABEL READ AT DEADSTART, OTHERWISE
*         (A) .EQ. SECTOR NUMBER TO BE READ
          SPACE  2
 CLR20    BSS
          LCN    0
 CLRX     LJM    **
 CLR      EQU    *-1
          LDDL   PTF
          ZJN    CLR20       IF INITIALIZATION PATH TEST
          LDML   /SS/P.CT,CSST
          NJN    CLR20       IF NOT INITIALIZATION CONFIDENCE TEST
          LDML   RS+/RS/P.ERRID
          ADC    -E140
          ZJN    CLR10       IF WRONG DRIVE TYPE CONFIGURED
          SBN    E141-E140
          NJN    CLR20       IF NOT *DRIVE INITIALIZATION REQUIRED*
 CLR10    BSS
          LDML   /SS/P.FNC,CSST
          ADML   RQ+/RQ/P.CYL,CSST
          ADML   RQ+/RQ/P.TRACK,CSST
          NJN    CLR20       IF NOT NOS/VE LABEL
          LDML   RQ+/RQ/P.SECTOR,CSST
          UJN    CLRX
          SPACE  5,20
** NAME-- EP
*
** PURPOSE-- ERROR PROCESSING.  THIS IS THE PORTION OF ERROR RECOVERY
*            THAT CAN BE IN AN OVERLAY.
          SPACE  2
 EP40     BSS
          LDML   /SS/P.RQTRY,CSST
          SBN    11
          PJN    EP50        IF RETRY LIMIT REACHED
          RJM    TAC         TERMINATE ALL COMMANDS
          LJM    MAIN10
 EP50     BSS
          LDK    /RS/K.CHDN  CHANNEL DOWN
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    OFFCH       TURN OFF ALL UNITS ON CHANNEL
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          LJM    MAIN15

*         REQUEST RETRY

 EPA40    BSS
          AOML   /SS/P.RQTRY,CSST  REQUEST RETRY COUNTER
          RJM    LIR         LOGICAL INTERFACE RESET
          RJM    RCC         RESTART CONTROLLER COMMANDS
          LDML   UNITS,UX
          SHN    /UN/L.PDCE+2
          MJN    EPA45       IF PARITY DRIVE CORRECTION ENABLED
          LDML   /SS/P.RQTRY,CSST
          SBN    RRL+1
          UJN    EPA50
 EPA45    BSS
          LDML   /SS/P.RQTRY,CSST
          SBN    RRL+3+1
 EPA50    BSS
          MJN    EPB40       IF NOT RETRY LIMIT

*         CONFIDENCE TEST

          LDML   /SS/P.CT,CSST
          ZJN    EPC20       IF INITIALIZATION CONFIDENCE TEST
          AOML   /SS/P.RECOV,CSST  INDEX TO NEXT RECOVERY STEP (EPB)
          LDN    0
          STML   /SS/P.CT,CSST  ENABLE STARTING CONFIDENCE TEST
 EPB40    BSS
          LJM    MAIN10

*         SLAVE RESET

 EPC20    BSS
          LDML   RS+/RS/P.ERRID
          SBN    E38
          NJN    EPC25       IF NOT -NO CONTROLLER RESPONSE-
          LDML   UNITS,UX    IF CONTROLLER HUNG, READ PERFORMANCE
          LPC    0#EFFF       LOG AFTER SLAVE RESET
          LMC    /UN/K.NCR   NO CONTROLLER RESPONSE BIT
          STML   UNITS,UX
 EPC25    BSS
          LDML   /SS/P.RECOV,CSST
          ZJK    EPC37       IF INITIALIZATION CONFIDENCE TEST OR NO RESPONSE
          SBN    2            TO LOGICAL RESET
          ZJK    EPC50       IF SLAVE RESET ALREADY ISSUED
          LDML   /SS/P.CT,CSST
          ZJK    EPC30       IF NO COMPLETION CODE FOR CONFIDENCE TEST
          LMN    1
          NJK    EPC35       IF FAILURE ALREADY INDICATED
          LDK    /RS/K.DATERR  SOFTWARE FLAW THE ALLOCATION UNIT
          STML   RS+/RS/P.DATERR
          LDML   RS+/RS/P.ERRID
          SBN    E38
          NJN    EPC25.1     IF FAILURE ADDRESS SHOULD BE VALID
          LDML   RQ+/RQ/P.TRACK,CSST
          STML   RS+/RS/P.FTRK  FAILIING TRACK ADDRESS
          LDML   RQ+/RQ/P.SECTOR,CSST
          STML   RS+/RS/P.FSEC  FAILING SECTOR ADDRESS
 EPC25.1  LDN    E62         MEDIA ERROR
          STML   RS+/RS/P.ERRID
          LDN    0           INDEX TO NEXT RECOVERY STEP (EPA)
          STML   /SS/P.RECOV,CSST  TO PREVENT INFINITE LOOP IF RESET FAILS
          RJM    IPDE        IS PARITY DRIVE ENABLED
          NJN    EPC26       IF NO PARITY DRIVE OR NO FAILING DRIVE
          LDDL   T2
          SHN    9
          MJN    EPC26       IF RESTORE IN PROGRESS
          LDML   /SS/P.RQTRY,CSST
          SBN    RRL+3+1
          MJN    EPC27       IF RECOVERY HASN'T BEEN TRIED WITH PARITY DRIVE CORRECTION
 EPC26    BSS
          LJM    EPF30
 EPC27    BSS
          LDML   UNITS,UX
          LMC    0#200
          STML   UNITS,UX    SET PARITY DRIVE CORRECTION ENABLED BIT (PDCE)
          RJM    LA6E        LOAD ATTRIBUTE PARAMETER 6E
          RJM    LIR         LOGICAL INTERFACE RESET
          RJM    RCC         RESTART CONTROLLER COMMANDS
          LJM    MAIN15
 EPC30    BSS
          RJM    SFRR        CLEAR CIP, IF
          LDN    2
          STML   /SS/P.CT,CSST  INDICATE CONFIDENCE TEST FAILED
 EPC35    BSS
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
 EPC37    BSS
          LDML   RS+/RS/P.ERRID
          NJN    EPC40       IF NOT DRIVE ERROR
          LDML   /SS/P.FNC,CSST
          SBN    2
          ZJN    EPC40       IF FORMAT COMMAND
          RJM    IPDE        IS PARITY DRIVE ENABLED
          NJN    EPC40       IF NO PARITY DRIVE OR NO FAILING DRIVE
          LDML   /SS/P.CT,CSST
          ZJN    EPC38       IF INITIALIZATION CONFIDENCE TEST
          LDML   RQ+/RQ/P.TRACK,CSST
          STML   /SS/P.CURTRK,CSST
          LDML   RQ+/RQ/P.SECTOR,CSST  SO THE CORRECT ADDRESS IS LOGGED WHEN
          STML   /SS/P.CURSEC,CSST     THE DRIVE IS SET OFF LINE
 EPC38    BSS
          LJM    EPE10
 EPC40    BSS
          LDN    2
          STML   /SS/P.RECOV,CSST  INDEX TO NEXT STEP OF RECOVERY (EPC)

*         BEFORE FORMATTING, AN ATTEMPT IS MADE TO READ THE LABEL IN
*         EACH OF THE FIRST 3 DAUS.  THIS CODE SKIPS THE SLAVE RESET
*         FOR THE LAST 2 DAUS.  SLAVE RESET TAKES APPROXIMATELY 3
*         MINUTES.

          RJM    CLR         CHECK FOR LABEL READ
          MJN    EPC43       IF RESET SHOULD BE ISSUED
          NJK    EPF26       IF SKIPPING SLAVE RESET
 EPC43    BSS
          LDN    E50         SLAVE RESET STARTED
          STML   RS+/RS/P.ERRID
          RJM    INTRS       INTERMEDIATE RESPONSE
          LDDL   PTF         PATH TEST FLAG
          ZJN    EPC45       IF INITIALIZATION PATH TEST
          RJM    RCC         RESTART CONTROLLER COMMANDS
          LDC    0#C000      COMMAND IN PROG., 2 COMMANDS IN PROG.
          RJM    SCB         SET COMMAND IN PROGRESS BITS
 EPC45    BSS
          RJM    SRI         SET RESET ISSUED FLAG
          RJM    ISR         ISSUE SLAVE RESET (NO RETURN)
 EPC50    BSS
          LDML   UNITS,UX
          LPC    /UN/K.NCR
          STDL   T5          SAVE NO CONTROLLER RESPONSE FLAG
          LDML   UNITS,UX
          LPC    0#EFFF
          STML   UNITS,UX    CLEAR -NO CONTROLLER RESPONSE- BIT
          LDML   RS+/RS/P.ERRID
          LMC    E72
          NJK    EPC100      IF NOT MACHINE EXCEPTION
          LDN    ID16
          RJM    SFP         SEARCH FOR PARAMETER
          LDML   RPB+6,T3
          LPC    0#FEE0
          LMC    0#6000
          NJK    EPC100      IF SLAVE RESET FAILED
          RJM    RCC         RESTART CONTROLLER COMMANDS
          LDDL   T5
          ZJN    EPC70       IF CONTROLLER WAS NOT HUNG
          LDN    7           GO TO EPC70 IF ERROR
          STML   /SS/P.RECOV,CSST
          LDML   /SS/P.MREV+1,CSST
          LPN    77B
          SBN    0#15        REV LEVEL 15
          PJN    EPC70       SKIP REL IF REV 15. FC HANG WORK AROUND
          RJM    REL         READ ERROR LOG
          ZJN    EPC70       IF NO ERROR CODE
          LDK    E52         SLAVE RESET PASSED, ERROR CODE PRESENT
          UJN    EPC80
 EPC70    BSS
          LDN    E51         SLAVE RESET PASSED
 EPC80    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    INTRS       INTERMEDIATE RESPONSE
          LDML   /SS/P.CT,CSST
          LMN    4
          ZJK    EPE40       IF DATA INTEGRITY PROBLEM
          LDN    6           INDEX TO NEXT STEP OF RECOVERY (EPD20)
          STML   /SS/P.RECOV,CSST
          AOML   /SS/P.RQTRY,CSST  REQUEST RETRY COUNT
          LJM    MAIN10
 EPC100   BSS
          LDDL   PTF
          ZJN    EPC110      IF IN PATH TEST
          LDML   /SS/P.CT,CSST
          ZJN    EPC110      IF INITIALIZATION CONFIDENCE TEST
          LDML   RS+/RS/P.ERRID
          SBN    E20
          MJN    EPC110      IF PROBABLY NOT A CABLE PROBLEM
          SBN    E50-E20
          PJN    EPC110      IF PROBABLY NOT A CABLE PROBLEM
          RJM    INTRS       INTERMEDIATE RESPONSE
          UJN    EPD30
 EPC110   BSS
          RJM    OFFCM       TURN OFF ALL UNITS ON CONTROLLER (NO RETURN)

*         PATH TEST (ROUTINE PT WORKED ONCE, SLAVE RESET FAILED, MAY BE
*         DAISY CHAIN PROBLEM.)

 EPD30    BSS
          LDML   /SS/P.RECOV,CSST
          LMN    3
          ZJN    EPD40       IF PATH TEST ALREADY STARTED
          AOML   /SS/P.RQTRY,CSST  REQUEST RETRY COUNT
          LDN    3
          STML   /SS/P.RECOV,CSST  INDEX TO THIS RECOVERY STEP (EPD)
          LDN    0            ITS BUFFER TO DISK
          STDL   UX          POINTER TO UNITS TABLE
          UJN    EPD35
 EPD32    BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
 EPD35    BSS
          SBDL   UNUML
          ZJN    EPD37       IF END OF CONFIGURED UNITS
          RJM    SFRR        SET UP FOR REQUEST RETRY
          UJN    EPD32
 EPD37    BSS
          STDL   CMNDS       NO OUTSTANDING COMMANDS
          STDL   PTF         FORCE RUNNING PATH TEST
          LJM    MAIN10
 EPD40    BSS
          RJM    OFFCM       TURN OFF ALL UNITS ON CONTROLLER (NO RETURN)

*         DRIVE DIAGNOSTICS

 EPE10    BSS
          LDN    4           INDEX TO NEXT RECOVERY PROCEDURE (EPF)
          STML   /SS/P.RECOV,CSST
          LDN    0
          STML   T11         RETRY COUNT FOR OFF LINING DRIVE
          AOML   /SS/P.RQTRY,CSST  REQUEST RETRY COUNT
          RJM    RCC         RESTART CONTROLLER COMMAND
          RJM    LIR         LOGICAL INTERFACE RESET
          RJM    CLR         CHECK FOR LABEL READ
          PJN    EPE30       IF LABEL READ AND NOT CLUSTERED CORRECTLY
          RJM    PDD         PERFORM DRIVE DIAGNOSTICS
          LDML   /SS/P.CT,CSST
          LMN    4
          ZJN    EPE40       IF DATA INTEGRITY ERROR
 EPE30    BSS
          LJM    MAIN10
 EPE40    BSS
          LDK    E111        CM-DRIVE DATA INTEGRITY
          STML   RS+/RS/P.ERRID  RESET ERROR IDENTIFIER

*         IF FINAL REQUEST RETRY FAILED

 EPF20    BSS
          RJM    IPDE        IS PARITY DRIVE ENABLED
          NJK    EPF26       IF NO PARITY DRIVE OR NO FAILING DRIVE
          LDDL   T2
          SHN    9
          PJN    EPF24       IF RESTORE NOT IN PROGRESS
          LDDL   T2
          LMML   RS+/RS/P.UNIT  FAILING DRIVE
          LPN    37B
          NJK    EPF26       IF ERROR NOT ON DRIVE BEING RESTORED
 EPF24    BSS
          LDML   /SS/P.FNC,CSST
          SBN    2
          ZJK    EPF26       IF FORMAT COMMAND
          LDML   T11
          SBN    2           ALLOW 2 RETRIES TO OFF LINE DRIVE
          PJK    EPF26       IF RETRIES EXHAUSTED
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          LDN    4
          STML   /SS/P.RECOV,CSST  INDEX TO NEXT RECOVERY STEP (EPF)
          AOML   T11         RETRY COUNT FOR OFF LINING DRIVE
          RJM    OFD         OFF LINE FAILING DRIVE
          LDN    /RS/K.PPD   PARITY PROTECTION DISABLED
          STML   RS+/RS/P.ID
          LDML   RS+/RS/P.UNIT
          LPC    37B
          RJM    UPPS        UPDATE PARITY PROTECTION STATUS IN UIT
          LDK    E59         PARITY PROTECTION DISABLED
          STML   RS+/RS/P.ERRID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          RJM    RCC         RESTART CONTROLLER COMMANDS
          LDML   UNITS,UX
          LPC    0#F7FF
          STML   UNITS,UX    ENSURE RESTORE IN PROGRESS IS CLEAR
          UJK    EPG15
 EPF26    BSS
          RJM    CLR         CHECK FOR LABEL READ
          PJN    EPF28       IF LABEL READ AT DEADSTART
          LDK    /RS/K.UDN   UNIT DOWN
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    OFFUN       TURN OFF UNIT
          UJN    EPF40
 EPF28    BSS
          LDN    1
          STDL   CMNDS       SO DCR ROUTINE LEAVES CMNDS EQUAL TO 0
 EPF30    BSS
          LDC    R.ABN*0#4000  ABNORMAL TERMINATION
          STML   RS+/RS/P.RC  RESPONSE CODE
          LDN    0
          STML   RS+/RS/P.SHORT   INDICATE ERROR RESPONSE
          LDC    RLIE
          STML   RS+/RS/P.RESPL  BYTE LENGTH OF RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          LDN    1           SO DCR DOES NO SEEK
          RJM    DCR         DELINK REQUEST
 EPF40    BSS
          RJM    RESPIN      UPDATE -IN- POINTER IN RESPONSE BUFFER
          LDN    5
          STML   /SS/P.RECOV,CSST  INDEX TO NEXT RECOVERY STEP (EPG)
          RJM    LIR         LOGICAL INTERFACE RESET

*         ENTER HERE IF PREVIOUS LOGICAL INTERFACE RESET WORKS OR FAILS

 EPG10    BSS
          LDML   UNITS,UX
          SHN    /UN/L.RIP+2
          MJN    EPG12       IF RESTORE IN PROGRESS
          RJM    UUT         UNLOCK UNIT TABLE
 EPG12    BSS
          RJM    RCC         RESTART CONTROLLER COMMANDS
 EPG15    BSS
          LDN    0
          STDL   IF          CLEAR INITIALIZATION FLAG
          STML   /SS/P.RQTRY,CSST  CLEAR RETRY COUNT
          LJM    MAIN10
          SPACE  5,20
**NAME-- IPDE
*
** PURPOSE-- IS PARITY DRIVE ENABLED
*
** EXIT-- A NONZERO IF NO PARITY DRIVE OR NO FAILING DRIVE
*         T2 = RESPONSE BUFFER + 9  FROM REPORT ADDRESSEE STATUS IF A = 0
          SPACE  2
 IPDE50   BSS
          LDN    1
 IPDEX    LJM    **
 IPDE     EQU    *-1
          LDM    /SS/P.DT,CSST
          SHN    -4
          STDL   DT          DEVICE TYPE
          SBN    3
          ZJN    IPDE10      IF 5833_1P
          SBN    5
          ZJN    IPDE10      IF 5838_1P
          SBN    2
          ZJN    IPDE10      IF 5838_3P
          SBN    3
          ZJN    IPDE10      IF 47444_1P
          SBN    2
          ZJN    IPDE10      IF 47444_3P
          ADN    10
          NJK    IPDEX       IF NOT 5833_3P
 IPDE10   BSS
          LDML   FPD
          SHN    10
          MJN    IPDEX       IF NO FAILING DRIVE
          LDN    0
          STDL   T1
 IPDE15   BSS
          LDML   RPB,T1      SAVE RESPONSE BUFFER
          STML   IPIT,T1
          AODL   T1
          SBN    50
          NJN    IPDE15      IF MORE WORDS TO SAVE
          RJM    LIR         LOGICAL INTERFACE RESET
          LDC    0#302       REPORT ADDRESSEE STATUS OPERATION CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDN    6           COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          LDML   RPB+9
          STDL   T2
          LDN    0
          STDL   T1
 IPDE20   BSS
          LDML   IPIT,T1     RESTORE RESPONSE BUFFER
          STML   RPB,T1
          AODL   T1
          SBN    50
          NJN    IPDE20      IF MORE WORDS TO RESTORE
          LDDL   T2
          SHN    3
          PJK    IPDE50      IF LOGICAL UNIT IS NOT READ READY
          SHN    1
          PJK    IPDE50      IF NO PARITY DRIVE
          SHN    4
          PJN    IPDE30      IF NO OFF LINED DRIVE
          SHN    1
          PJK    IPDE50      IF RESTORE NOT IN PROGRESS
 IPDE30   BSS
          LDN    0
          UJK    IPDEX
          SPACE  5,20
** NAME--ISR
*
** PURPOSE-- ISSUE SLAVE RESET
          SPACE  2
 ISR      CON    0
          LDC    H8415       SLAVE RESET
          STML   CP+OPCD     SO TIMEOUT WILL BE LONG IN IH
          RJM    IR          ISSUE RESET
          LDML   /SS/P.CT,CSST
          ZJN    ISR10       IF IN SUBSYSTEM CONFIDENCE TEST
          LJM    MAIN15
 ISR10    BSS
          RJM    IH          INTERRUPT HANDLER
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    EP          ERROR PROCESSING (NO RETRUN)
          SPACE  5,20
** NAME-- OFD
*
** PURPOSE-- OFF LINE FAILING DRIVE
          SPACE  2
 OFDX     LJM    **
 OFD      EQU    *-1
          LDC    H0209
          STML   CP+OPCD     LOAD ATTRIBUTE OPERATION CODE
          LDC    0#2D5
          STML   CP+FCP      PARAMETER WITH FAILING DRIVE NUMBER
          LDML   RS+/RS/P.UNIT
          LPN    37B
          SHN    8
          STML   CP+FCP+1    FAILING DRIVE NUMBER
          LDC    0#1D9
          STML   CP+FCP+2    PARAMETER TO OFF LINE DRIVE
          LDN    12          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          UJN    OFDX
          SPACE  5,20
** NAME-- OFFCH
*
** PURPOSE-- TURN OFF ALL UNITS ON A CHANNEL
          SPACE  2
 OFCX     LJM    **
 OFFCH    EQU    *-1
          LDN    0
          STDL   UX          UNITS TABLE INDEX
 OFC10    BSS
          RJM    OFFUN       SET UNIT DISABLE FLAG
          LDN    P.UN
          RADL   UX          BUMP UNITS TABLE INDEX
          SBDL   UNUML
          NJK    OFC10       IF NOT END OF TABLE
          UJK    OFCX
          SPACE  5,20
** NAME-- OFFCM
*
** PURPOSE-- TURN OFF ALL UNITS ON A CONTROLLER.
          SPACE  2
 OFFCM    CON    0
          LDK    /RS/K.CMDN  CONTROLLER DOWN
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          LDDL   UX
          STDL   P5          POINTER TO CURRENT UNITS TABLE
          LDN    0
          STDL   UX          UNITS TABLE INDEX
 OFFCM10  BSS
          LDML   UNITS,P5    COMPARE IF SAME CONTROLLER
          LMML   UNITS,UX
          LPC    740B
          NJN    OFFCM20     IF NOT THE SAME CONTROLLER
          RJM    OFFUN       SET UNIT DISBLE FLAG
 OFFCM20  BSS
          LDN    P.UN
          RADL   UX          BUMP UNITS TABLE INDEX
          SBDL   UNUML
          NJK    OFFCM10     IF NOT END OF TABLE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          LJM    MAIN10
          SPACE  5,20
** NAME-- OFFUN
*
** PURPOSE-- SET THE DISABLE FLAG IN THE UNIT INTERFACE TABLE.
*
** EXIT   P5 IS UNCHANGED
          SPACE  2
 OFUX     LJM    **
 OFFUN    EQU    *-1
 OFFUN10  BSS
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    OFFUN10     IF LOCK COULD NOT BE SET
          LDK    /UIT/K.DSABLE  SET UNIT DISABLE FLAG
          STDL   T3
          LDN    0
          STDL   T2
          STDL   T4
          STDL   T5
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          RDSL   T2          -LOGICAL OR- THE UNIT DISABLE FLAG
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD

*         NOTE THAT REQUEST RETRIES DO NOT ALLOW STREAMING SO SFRR WILL
*         NOT SEND A RESPONSE.

          RJM    SFRR        SETUP FOR REQUEST RETRY (MAKE CMNDS ACCURATE)
          LPC    0#F7FF
          STML   UNITS,UX    CLEAR RESTORE IN PROGRESS FLAG
          UJK    OFUX
          SPACE  5,20
** NAME-- PDD
*
** PURPOSE-- PERFORM DRIVE DIAGNOSTICS
          SPACE  2
 PDDX     LJM    **
 PDD      EQU    *-1
          LDC    H8100       PERFORM DRIVE DIAGNOSTIC OP CODE
          RJM    SOU         SET OPERATION CODE AND UNIT
          LDC    0#2D5
          STML   CP+FCP      PARAMETER TO SELECT DRIVE
          LDML   RS+/RS/P.UNIT
          LPN    37B
          SHN    8
          STML   CP+FCP+1    PHYSICAL DRIVE NUMBER
          LDN    10          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          UJN    PDDX
          SPACE  5,20
** NAME-- RCC
*
** PURPOSE-- RESTART CONTROLLER COMMANDS.  SET UP TABLES SO THAT
*            ROUTINE GETUD WILL RESTART ALL CONTROLLER COMMANDS.
          SPACE  2
 RCCX     BSS
          LDML   T12
          STDL   UX          RESTORE UNITS TABLE POINTER
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LJM    **
 RCC      EQU    *-1
          LDDL   UX
          STML   T12         SAVE POINTER TO UNITS TABLE
          LDN    0
          STDL   UX          POINTER TO UNITS TABLE
          UJN    RCC20
 RCC10    BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
 RCC20    BSS
          SBDL   UNUML
          PJN    RCCX        IF END OF CONFIGURED UNITS
          LDML   UNITS,UX
          SHN    2+/UN/L.CIP
          PJN    RCC10       IF NO COMMAND IN PROGRESS
          SHN    -7
          LPN    17B
          LMDL   CMOD
          NJN    RCC10       IF DIFFERENT CONTROLLER
          RJM    SFRR        SETUP FOR REQUEST RETRY
          UJK    RCC10
          SPACE  5,20
** NAME-- REL
*
** PURPOSE-- READ ERROR LOG
*
** EXIT
*         WC = ERROR CODE OR ZERO IF NO ERROR CODE
          SPACE  2
 RELX     LJM    **
 REL      EQU    *-1
          LDC    H8400
          STML   CP+OPCD     READ PERFORMANCE LOG COMMAND
          LDDL   CMOD
          LPN    7           GET RID OF PORT NUMBER
          SHN    8
          LMC    0#FF
          STML   CP+SLAD     CONTROLLER NUMBER
          LDN    6           COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDN    1
          STDL   T3          CM WORDS TO INPUT
          LDN    0
          STDL   T1          POINTER TO ERROR INFORMATION
          STDL   T2          PREVIOUS ERROR NUMBER
          STDL   WC          ERROR CODE
          LOADC  CM.CB       ADDRESS OF FIRST ERROR BUFFER
          STDL   T4
 REL10    BSS
          LDDL   T1
          SHN    7
          ADDL   T4
          LMC    400000B
          CRML   RPB+15,T3   INPUT FIRST WORD OF ERROR BUFFER
          LDML   RPB+15
          SHN    -8
          ZJN    REL20       IF NO ERROR
          SBDL   T2
          MJN    REL20       IF PREVIOUS ERROR WAS LAST ONE
          ADDL   T2
          STDL   T2          SAVE ERROR NUMBER
          LDML   RPB+15
          LPC    0#FF
          ADC    -0#FA
          MJN    REL14       IF 2ND WORD HAS ERROR CODE
          SBN    3
          PJN    REL14       IF 2ND WORD HAS ERROR CODE
          ADC    0#FA+3
          SHN    8
          UJN    REL16
 REL14    BSS
          LDML   RPB+16
 REL16    BSS
          STDL   WC          SAVE ERROR CODE
          AODL   T1
          LMN    4
          NJK    REL10       IF NOT ALL ERROR BUFFERS CHECKED
 REL20    BSS
          LDDL   WC          ERROR CODE (IF NONZERO)
          LJM    RELX
          SPACE  5,20
** NAME-- SCB
*
** PURPOSE-- SET COMMAND IN PROGRESS BITS IN (UNITS,UX) FOR ONE
*            CONTROLLER
*
** ENTRY  A = BITS TO SET
*         CMOD = CONTROLLER TO SEARCH FOR UNITS
          SPACE  2
 SCBX     LJM    **
 SCB      EQU    *-1
          STDL   P1
          LDN    0
          STDL   T1
          UJN    SCB20
 SCB10    BSS
          LDN    P.UN
          RADL   T1          UPDATE POINTER TO UNITS TABLE
 SCB20    BSS
          SBDL   UNUML
          PJN    SCBX        IF END OF CONFIGURED UNITS
          LDML   UNITS,T1
          SHN    -/UN/N.UNIT
          LPN    17B
          LMDL   CMOD
          NJN    SCB10       IF DIFFERENT CONTROLLER
          LDML   UNITS,T1
          LPC    0#3FFF
          LMDL   P1
          STML   UNITS,T1    SET -2 COMMANDS IN PROGRESS-
          UJN    SCB10
          SPACE  5,20
** NAME-- SRI
*
** PURPOSE-- SET RESET ISSUED FLAG FOR ALL UNITS ON CMOD.
*            IT WILL BE CLEARED WHEN AN ASYNCHRONOUS RESPONSE
*            FOR THE DRIVE IS RECEIVED.
          SPACE  2
 SRIX     BSS
          LDML   EPCT,CMOD
          STDL   UX          RESTORE UX
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LJM    **
 SRI      EQU    *-1
          LDDL   UX
          STML   EPCT,CMOD   SAVE TABLE ISSUING THE RESET
          LDN    0
          STDL   UX          POINTER TO UNITS TABLE
          UJN    SRI10
 SRI5     BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
 SRI10    BSS
          SBDL   UNUML
          PJN    SRIX        IF END OF CONFIGURED UNITS
          LDML   UNITS,UX
          SHN    -/UN/N.UNIT
          LPN    17B
          LMDL   CMOD
          NJN    SRI5        IF DIFFERENT CONTROLLER
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LDDL   CLSEC
          STML   UNITS+/UN/P.CLK,UX SET CURRENT CLOCK
          LDN    3
          STML   /SS/P.RESET,CSST  INDICATE RESET ISSUED
          UJK    SRI5
          SPACE  5,20
** NAME-- TAC
*
** PURPOSE-- TERMINATE ALL COMMANDS ISSUED
          SPACE  2
 TACX     LJM    **
 TAC      EQU    *-1
          PAUSE  100000      DELAY 170 MILLISECONDS TO ALLOW MAX.
                              DATA IN BUFFER TO BE WRITTEN TO DISK
                              AND TO GUARANTEE AT LEAST 2 SECONDS
                              ELAPSES BEFORE CHANNEL IS DOWNED
          AOML   /SS/P.RQTRY,CSST
          LDDL   PTF
          ZJN    TACX        IF IN PATH TEST
          LDN    0
          STDL   CMOD        CONTROLLER NUMBER
          STDL   UX
          UJN    TAC25
 TAC10    BSS
          AODL   CMOD
          UJN    TAC25
 TAC20    BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
          SBDL   UNUML
          PJN    TACX        IF END OF CONFIGURED UNITS
 TAC25    BSS
          LDML   UNITS,UX
          SHN    -/UN/N.UNIT
          LPN    17B
          SBDL   CMOD
          MJN    TAC20       IF THIS CONTROLLER ALREADY RESET
          NJN    TAC10       IF CMOD TOO SMALL
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T1
          LDDL   T1+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJN    TAC20       IF UNIT DISABLED
          RJM    RCC         RESTART CONTROLLER COMMANDS
          RJM    LIR         LOGICAL INTERFACE RESET
          UJK    TAC10
          ERRMI  EOM-*       IF OVERLAY OVERFLOWS MEMORY
          OVERLAY (IDLE/RESUME),OVST
          ROUTINE IDRO       IDLE REQUEST, RESUME REQUEST OVERLAY
** NAME-- CCLOCK
*
** PURPOSE-- CLEARS CHANNEL LOCK
          SPACE  2
 CCLX     LJM    **
 CCLOCK   EQU    *-1
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          STML   CLF         CHANNEL LOCK FLAG
          LDDL   CHAN        CHANNEL NUMBER = OFFSET IN TABLE
          STDL   T5
          RJM    CLOCK       CLEAR CHANNEL LOCKWORD
          UJK    CCLX
          SPACE  5,20
** NAME-- CUB
*
** PURPOSE-- CHECK UNIT BUSY.  NOTE IF SLAVE RESET IS IN PROGRESS
*            CMNDS COULD BE 0, BUT ERROR RECOVERY IS STILL IN
*            PROGRESS.
*
** EXIT--  A = 0  IF NO COMMANDS IN PROGRESS
          SPACE  2
 CUB50    BSS
          LDN    1
 CUBX     LJM    **
 CUB      EQU    *-1
          LDN    0
          STDL   UX          POINTER TO UNITS TABLE
          UJN    CUB20
 CUB10    BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UX TABLE
 CUB20    BSS
          SBDL   UNUML
          ZJN    CUBX        IF END OF CONFIGURED UNITS
          LOADR  UNITS+/UN/P.UIT,UX ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T5          READ UNIT DISABLED FLAG
          LDDL   T5+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJN    CUB10       IF UNIT DISABLED
          LDML   UNITS,UX
          SHN    /UN/L.CIP+2
          MJN    CUB50       IF COMMAND IN PROGRESS
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          LDML   /SS/P.RQTRY,CSST
          NJK    CUB50       IF IN ERROR PROCESSING FOR THIS UNIT
          UJN    CUB10
          SPACE  5,20
** NAME-- DLN
*
** PURPOSE-- DELETE LOGICAL PP NUMBER FROM UNIT INTERFACE TABLE LOCKWORD.
*            IT IS USED TO DETERMINE IF THE DRIVE IS BEING SUPPORTED IN
*            ALTERNATE OR REDUNDANT ACCESS MODE.  ALSO ENSURE THAT THE UNIT
*            LOCK IS CLEAR.
          SPACE  2
 DLNX     LJM    **
 DLN      EQU    *-1
          LDN    0
          STDL   UX          POINTER TO UNITS TABLE
          UJN    DLN20
 DLN10    BSS
          LDN    P.UN
          RADL   UX          UPDATE TO NEXT UNITS TABLE
 DLN20    BSS
          SBDL   UNUML
          ZJN    DLNX        IF END OF CONFIGURED UNITS
          RJM    LUT         LOCK UNIT TABLE
          NJN    DLN30       IF ALTERNATE PP HAS THE LOCK
          RJM    UUT         UNLOCK UNIT TABLE
 DLN30    BSS
          LCN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.ULOCK  INDEX TO UNIT LOCKWORD
          STDL   T6
          CRDL   P1          READ UNIT LOCKWORD
          LDDL   P2
          SBDL   LPN
          NJN    DLN40       IF 1ST PP NOT THIS ONE
          STDL   T2
          UJN    DLN50
 DLN40    BSS
          LDDL   P3
          SBDL   LPN
          NJK    DLN10       IF 2ND PP NOT THIS ONE
          STDL   T3
 DLN50    BSS
          LDDL   T6
          LMC    400000B
          RDCL   T1          DELETE LOGICAL PP NUMBER FROM LOCKWORD
          PAUSE  4           IN CASE ALTERNATE PP LOCKING UNIT AT THE
                              SAME TIME
          UJK    DLN30       ENSURE PP NUMBER DELETED
          SPACE  5,20
** NAME-- PIR
*
** PURPOSE-- PROCESS IDLE RESUME
          SPACE  2
 PIR      CON    0
          RJM    SPLOCK      SET PP TABLE LOCK
          LDDL   T4
          SHN    /PIT/L.IDLREQ+2
          MJN    PIR10       IF IDLE REQUEST
          LDDL   T4
          LPC    0#4FFE      CLEAR ACTIVE CHECK BIT, RESUME REQUEST BIT,
          STDL   T4           IDLE STATUS BIT, AND LOCK BIT IN PP
          LDDL   CM.PIT+2     INTERFACE TABLE
          LMC    400000B
          CWDL   T1
          LJM    MAIN
 PIR10    BSS
          AOML   IDLE        NUMBER OF TIMES DRIVER IDLED
          LDN    0            ITS BUFFER TO DISK
          STDL   UX          POINTER TO UNITS TABLE
          UJN    PIR12
 PIR11    BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
 PIR12    BSS
          SBDL   UNUML
          ZJN    PIR13       IF END OF CONFIGURED UNITS
          RJM    SFRR        SET UP FOR REQUEST RETRY
          UJN    PIR11
 PIR13    BSS
          STDL   CMNDS       NO OUTSTANDING COMMANDS
          RJM    DLN         DELETE LOGICAL PP NUMBER FROM LOCKWORD
          LDML   CLF
          NJN    PIR15       IF 2 CONSECUTIVE IDLES AND CHANNEL LOCK
                              ALREADY CLEAR
          RJM    CCLOCK      CLEAR CHANNEL LOCK
 PIR15    BSS
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          CRDL   T1
          LDDL   T4          CLEAR ACTIVE CHECK BIT, IDLE REQUEST BIT,
          LPC    0#2FFE       AND SET IDLE STATUS BIT
          LMC    0#1000
          STDL   T4
          LDDL   CM.PIT+2
          LMC    400000B
          CWDL   T1
 PIR20    BSS
          RJM    PPRQ        WAIT FOR RESUME
          UJN    PIR20
          SPACE  5,20
** NAME-- SPLOCK
*
** PURPOSE-- SETS THE PP TABLE LOCK IN THE
*            PP INTERFACE TABLE.
          SPACE  2
 SPLX     LJM    **
 SPLOCK   EQU    *-1
 SPLOCK4  BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDN    1
          STDL   T4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          RDSL   T1          ATTEMPT TO SET PP TABLE LOCK
          LDDL   T4
          LPN    1
          ZJK    SPLX        IF LOCK SET
          UJK    SPLOCK4
          ERRMI  EOM-*       IF OVERLAY OVERFLOWS MEMORY
          OVERLAY (INITIALIZE TABLES),OVST
          ROUTINE ITO        INITIALIZE TABLES
** NAME-- CHGCH
*
** PURPOSE-- SET CHANNEL NUMBER IN CHANNEL INSTRUCTIONS
*
** ENTRY  CHAN = CHANNEL NUMBER
          SPACE  2
 CHGX     LJM    **
 CHGCH    EQU    *-1
          LDN    0
          STDL   T1          CHANGE DISK CHANNEL INSTRUCTIONS
 CHG10    LDML   CONCH,T1    ADDRESS OF CHANNEL INSTRUCTIONS
          ZJN    CHGX        END OF LIST
          STDL   T2
          LDIL   T2
          SCN    37B
          LMDL   CHAN        CHANNEL NUMBER
          STIL   T2
          AODL   T1
          UJK    CHG10
 CONCH    BSS                DISK CHANNEL REFERENCES
 TDC+40B  HERE
 T40B+DC  HERE
 TDC      HERE
          CON    0           END OF TABLE
          SPACE  5,20
** NAME-- IIS
*
** PURPOSE-- INITIALIZE INTERRUPT SIZE.  INTERRUPT SIZE CONTROLS
*            THE LENGTH OF TIME BEFORE THE TARGET SECTOR THAT THE
*            CONTROLLER LOOKS FOR RPS.
*
** ENTRY-- P5 = NUMBER OF CONFIGURED UNITS
          SPACE  2
 IISX     LJM    **
 IIS      EQU    *-1
          LDDL   P5
          STDL   T1
 IIS10    BSS
          LDDL   T1
          SBN    1
          STDL   T1
          SBN    17
          PJN    IIS10       IF UNUML BIGGER THAN TABLE
          LDML   IS4K10M,T1
          STML   ISL+2
          STML   ISL+3
          STML   ISL+4
          LDML   IS8K10M,T1
          STML   ISL+5
          STML   ISL+6
          LDML   IS4K25M,T1
          STML   ISH+2
          STML   ISH+3
          STML   ISH+4
          LDML   IS8K25M,T1
          STML   ISH+5
          STML   ISH+6
          UJK    IISX

*         INTERRUPT SIZE USED BASED ON UNITS CONFIGURED IF
*         10 MB CHANNEL AND 4096 BYTE SECTOR SIZE.

 IS4K10M  DATA   8192,8192,8192,8192
          DATA   12288,12288,12288,12288
          DATA   12288,12288,12288,12288
          DATA   16384,16384,16384,16384,20480

*         INTERRUPT SIZE USED BASED ON UNITS CONFIGURED IF
*         10 MB CHANNEL AND 8192 BYTE SECTOR SIZE.

 IS8K10M  DATA   8192,8192,8192,16384
          DATA   16384,16384,16384,16384
          DATA   16384,16384,16384,16384
          DATA   16384,16384,16384,16384,16384

*         INTERRUPT SIZE USED BASED ON UNITS CONFIGURED IF
*         25 MB CHANNEL AND 4096 BYTE SECTOR SIZE.

 IS4K25M  DATA   8192,8192,12288,16384
          DATA   16384,16384,16384,16384
          DATA   24576,24576,24576,24576
          DATA   28672,28672,28672,32768,40960

*         INTERRUPT SIZE USED BASED ON UNITS CONFIGURED IF
*         25 MB CHANNEL AND 8192 BYTE SECTOR SIZE.

 IS8K25M  DATA   8192,16384,16384,16384
          DATA   16384,16384,16384,24576
          DATA   24576,24576,24576,24576
          DATA   24576,24576,32768,32768,32768
          SPACE  5,20
** NAME-- IT
*
** PURPOSE-- INITIALIZE TABLES
*
** ENTRY  CM.PIT = CM BYTE ADDRESS OF THE PP INTERFACE TABLE.
          SPACE  2
 ITX      LJM    **
 IT       EQU    *-1
          LDK    OVST-PSB    LENGTH OF BUFFERS
          STDL   T1
 IT10     BSS
          LDN    0
          STML   PSB-1,T1    ZERO OUT BUFFERS
          SODL   T1
          NJN    IT10
          STDL   UX          INITIALIZE DIRECT CELLS
          STDL   LUX
          STDL   MALET
          STDL   P4
          STDL   P5
          STDL   P6
          STDL   T7
          STDL   CMOD
          STDL   PTF         PATH TEST
          LDN    C.PIT
          STDL   WC
          LOADC  CM.PIT      LOAD CM ADDRESS OF PP INTERFACE TABLE
          CRML   IPIT,WC     READ PP INTERFACE TABLE
          LDML   IPIT+/PIT/P.PPNO  GET PP NUMBER
          STDL   LPN
          REFAD  IPIT+/PIT/P.RSBUF,CM.RS  REFORMAT CM ADDRESS OF RESPONSE
                                          BUFFER AND SAVE IN CM.RS
          LDML   IPIT+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STDL   LIM
          REFAD  IPIT+/PIT/P.INT,CM.INT  REFORMAT CM ADDRESS OF INTERRUPT
                                         WORD AND SAVE IN CM.INT
          REFAD  IPIT+/PIT/P.CHAN,CM.CHAN  REFORMAT CM ADDRESS OF
                                           CHANNEL TABLE AND SAVE IN CM.CHAN
          REFAD  IPIT+/PIT/P.CBUF,CM.CB  REFORMAT ADDRESS OF COMMUNICATION
                                         BUFFER AND SAVE IN CM.CB
          LDN    /CB/C.BUF
          RAML   CM.CB+2     DISPLACEMENT TO READ/WRITE BUFFER
          LDK    /CB/P.BUF*2  ADD BYTE DISPLACEMENT FOR READ/WRITE BUFFER
          ADML   IPIT+/PIT/P.CBUF+1
          STML   CM.CB.T+2
          SHN    -16
          ADML   IPIT+/PIT/P.CBUF
          STML   CM.CB.T+1   PP COMM. BUFFER IN T REGISTER FORMAT
          LDML   IPIT+/PIT/P.CBUFL  GET LENGTH OF COMMUNICATION BUFFER
          ADC    -P.CB*2
          PJN    IT20        IF COMMUNICATION BUFFER LONG ENOUGH
          LDC    E20B
          RJM    INTERR      REPORT ERROR (NO RETURN)

*         INITIALIZE UNITS AND SS TABLES.  THE TABLES WILL BE IN ASCENDING ORDER
*         BY CONTROLLER NUMBER.  FOR EACH CONTROLLER TABLES WILL BE IN ASCENDING
*         ORDER FOR ITS DRIVES.

 IT20     BSS
          LDML   IPIT+/PIT/P.UNITC  NUMBER OF UNIT DESCRIPTIORS
          SHN    1
          STDL   T8          LENGTH OF UNIT DESCRIPTOR (CM WORDS)
          ZJK    IT90        IF NO UNIT DESCRIPTORS
 IT30     BSS
          LDN    C.UD        READ 2 CM WORDS
          STDL   WC
          LOADC  CM.PIT
          ADN    C.PIT
          ADDL   P6          INDEX TO UNIT DESCRIPTORS
          CRML   IBUF,WC     READ UNIT DESCRIPTOR
          LDML   IBUF+/UD/P.UQT  RMA = 0 IF NULL ENTRY
          ADML   IBUF+/UD/P.UQT+1
          ZJK    IT70        IF NULL ENTRY
          LDML   IBUF+/UD/P.CNTRLR
          STDL   T2
          SHN    -3
          ADDL   T2
          LPN    17B
          LMDL   CMOD
          NJK    IT70        IF DIFFERENT CONTROLLER
          LDML   IBUF+/UD/P.UNIT
          LPN    37B
          LMDL   T7
          NJK    IT70        IF DIFFERENT DRIVE
          LDDL   P5
          ADC    -UNUM
          NJN    IT40        IF 64 OR LESS UNITS
          LDC    E208        TOO MANY CONFIGURED UNITS
          RJM    INTERR      REPORT ERROR (NO RETURN)
 IT40     BSS
          LDN    C.UIT
          STDL   WC
          LOADF  IBUF+/UD/P.UQT  REFORMAT RMA OF UNIT INTERFACE TABLE
                                  AND SAVE IN UNITS TABLE
          STML   UNITS+/UN/P.UIT+2,UX
          CRML   UBUF,WC     READ UNIT INTERFACE TABLE
          LDDL   CMADR
          STML   UNITS+/UN/P.UIT,UX
          LDDL   CMADR+1
          STML   UNITS+/UN/P.UIT+1,UX
          LDML   UBUF+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJK    IT70        IF UNIT DISABLED
          LDML   UBUF+/UIT/P.UTYPE  CHECK DEVICE TYPE
          LPN    77B
          SBN    9
          MJN    IT50        IF INVALID UNIT TYPE
          SBN    17
          MJN    IT60        IF VALID UNIT TYPE
 IT50     BSS
          LDC    E306        INVALID UNIT TYPE
          RJM    INTERR      REPORT ERROR (NO RETURN)
 IT60     BSS
          ADN    17
          SHN    4
          STML   SS+/SS/P.DT,P4  DEVICE TYPE
          LDDL   T2
          SHN    -8
          STDL   CHAN        CHANNEL NUMBER
          LDDL   CMOD
          LPN    7
          SHN    8
          ADDL   T7
          STML   SS+/SS/P.UNIT,P4  PUT CONTROLLER, UNIT NUMBER IN SS TABLE
          LDDL   CMOD
          SHN    5
          ADDL   T7
          STML   UNITS,UX    PUT PORT, CONTROLLER, UNIT NUMBER IN UNITS TABLE
          LDML   IBUF+/UD/P.LU  PUT LOGICAL UNIT IN SS TABLE
          STML   SS+/SS/P.LU,P4
          LDDL   LPN
          STML   SS+/SS/P.LPN,P4  SAVE LOGICAL PP NUMBER
          LDK    RSST-1      RESIDENT SS TABLES MINUS ONE
          SBDL   P5
          MJN    IT65        IF NO ROOM FOR A RESIDENT TABLE
          LDC    SS
          ADDL   P4
          STML   UNITS+/UN/P.SSPTR,UX  POINTER FROM UNITS TABLE TO SS TABLE
          LDC    P.SS
          RADL   P4          INCREMENT TO NEXT RESIDENT SS TABLE
          UJN    IT69
 IT65     BSS
          LDML   UBUF+/UIT/P.UBUFL  NUMBER OF 8-BIT BYTES IN COMMUNICATION BUFFER
          SHN    -3          NUMBER OF CM WORDS
          SBN    C.SS        MUST BE LARGER THAN SS ENTRY
          PJN    IT68        IF BUFFER LARGE ENOUGH
          LDC    E308
          RJM    INTERR      REPORT ERROR (NO RETURN)
 IT68     BSS
          RJM    WST         WRITE SS TABLE TO UNIT COMMUNICATIONS BUFFER
 IT69     BSS
          AODL   P5          NUMBER OF CONFIGURED UNITS
          LDN    P.UN
          RADL   UX          BUMP CONFIGURED UNIT INDEX
          UJN    IT80
 IT70     BSS
          LDN    C.UD
          RADL   P6          BUMP TO NEXT UNIT DESCRIPTOR ENTRY
          SBDL   T8          CHECK FOR END OF UNIT DESCRIPTORS
          NJK    IT30        IF MORE UNIT DESCRIPTORS
 IT80     BSS
          LDN    0
          STDL   P6          INDEX TO UNIT DESCRIPTORS
          AODL   T7          INCREMENT DRIVE NUMBER
          SBN    32
          MJK    IT30        IF LEGAL UNIT NUMBER
          STDL   T7
          AODL   CMOD        INCREMENT CONTROLLER NUMBER
          SBN    16
          MJK    IT30        IF LEGAL CONTROLLER NUMBER
 IT90     BSS
          LDDL   UX
          STDL   UNUML       END OF ACTIVE UNIT TABLE
          STDL   SSUN        INVALIDATE TABLE AT SSNR
          RJM    CHGCH       SET CHANNEL INSTRUCTIONS
          RJM    IIS         INITIALIZE INTERRUPT SIZE
          LJM    ITX
          SPACE  5,20
 SAVAX    LJM    **
 SAVAD    EQU    *-1
          STML   2,T2
          LDDL   CMADR
          STI    T2
          LDDL   CMADR+1
          STML   1,T2
          UJK    SAVAX
          SPACE  5,20
** NAME-- WST
*
** PURPOSE-- WRITE SS TABLE TO UNIT COMMUNICATIONS BUFFER
          SPACE  2
 WSTX     LJM    **
 WST      EQU    *-1
          LDN    C.SS
          STDL   WC
 WST10    BSS
          LDC    0#8000
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          STDL   T5
          LOADF  UBUF+/UIT/P.UBUF  LOAD ADDRESS OF COMMUNICATION BUFFER
          STDL   T1
          RDSL   T2          TRY TO LOCK THE BUFFER
          LDDL   T2
          SHN    /SS/L.LOCK+2
          MJN    WST10       IF ANOTHER PP HAS THE LOCK
          ZJN    WST20       IF 1ST HALF OF BUFFER AVAILABLE
          LDDL   T2
          SBDL   LPN
          ZJN    WST20       IF THIS PP OWNS THE 1ST HALF OF THE BUFFER
          LDDL   T1
          LMC    400000B
          CWDL   T2          CLEAR THE LOCK
          LDML   UNITS,UX
          LMC    0#400
          STML   UNITS,UX
          LDN    0#20
 WST20    BSS
          ADDL   T1
          LMC    400000B
          CWML   SSNR,WC     WRITE SS ENTRY TO COMMUNICATION BUFFER
          LJM    WSTX
          ERRMI  IPIT-*      IF CODE OVERFLOWS INTO TABLES
          OVERLAY (PATH TEST),OVST
          ROUTINE PTO        PATH TEST OVERLAY
** NAME-- BPTB
*
** PURPOSE-- BUILD PATH TEST BUFFER
          SPACE  2
 BPTBX    LJM    **
 BPTB     EQU    *-1
          LDN    0
          STDL   T1          INDEX TO OUTPUT BUFFER
          LDN    10
          STDL   T2          TIMES TO REPEAT PATTERN
 BPTB10   BSS
          LCN    0           PATTERN IS FFFF, 0000, AAAA, 5555,
          STML   OB,T1        FEFD REPEATED 10 TIMES
          LDN    0
          STML   OB+1,T1
          LDC    0#AAAA
          STML   OB+2,T1
          SHN    -1
          STML   OB+3,T1
          LDC    0#FEFD
          STML   OB+4,T1
          LDN    5
          RADL   T1
          SODL   T2
          ZJN    BPTBX       IF DONE
          UJN    BPTB10
          SPACE  5,20
** NAME-- CCA
*
** PURPOSE-- CHECK CONTROLLER ATTRIBUTES
*          - DISABLE USAGE STATISTIC COUNTING
*          - ENABLE MASTER TERMINATE
*          - DISABLE EXTENT RESPONSE FOR MASTER TERMINATE
*          - ENABLE REPORTING DEVICE FAULT LOG
*          - SET SPEED SELECTION TO 10 MB/S IF 10 MB CHANNEL
*          - SET SPEED SELECTION TO 25 MB/S IF 25 MB CHANNEL
          SPACE  2
 CCAX     LJM    **
 CCA      EQU    *-1
          LDDL   CMOD
          LPN    7           GET RID OF CHANNEL PORT
          SHN    8
          LMC    0#FF
          STML   CP+SLAD     CONTROLLER ADDRESS
          LDC    0#201
          STDL   MFID        INTERLOCK COMMANDS, RESPONSES AND DATA
          RJM    LIR         LOGICAL INTERFACE RESET

*         RESTORE CONTROLLER ATTRIBUTES

          LDC    H0202
          STML   CP+OPCD     RESTORE ATTRIBUTES OPERATION CODE
          LDN    6           COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          RJM    SDTM        SET DATA TRANSFER MODE FOR INTERLOCK

*         CHECK ATTRIBUTE PARAMETERS D1, D2, D3, D4, AND D6

          LDC    H0200
          STML   CP+OPCD     REPORT ATTRIBUTES OPERATION CODE
          LDC    0#76C
          STML   CP+FCP
          LDC    0#80D1      REPORT PARAMETERS D1,D2,D3,D4,D6
          STML   CP+FCP+1
          LDC    0#D2D3
          STML   CP+FCP+2
          LDC    0#D4D6
          STML   CP+FCP+3
          LDN    14          COMMAND PACKET LENGTH
          RJM    IDTP        INPUT DATA TO PP
          LDN    0
          STDL   T1
          STDL   T2
 CCA10    BSS
          LDML   RPB+8,T1
          LMML   CCAT,T1
          NJK    CCA80       IF PARAMETER ID NOT FOUND
          AODL   T1
          AODL   T1
          SBN    10
          MJN    CCA10       IF NOT ALL PARAMETER IDS CHECKED
 CCA20    BSS
          LDML   RPB+8+1,T2
          LMML   CCAT+1,T2
          NJN    CCA30       IF PARAMETER SET WRONG
          AODL   T2
          AODL   T2
          SBN    8
          MJN    CCA20       IF NOT ALL PARAMETERS CHECKED
          LDML   RPB+8+11
          LPC    0#F02
          LMML   CTS,CH
          ZJK    CCA70       IF ATTRIBUTE D6 CORRECT

*         LOAD/SAVE ATTRIBUTES

 CCA30    BSS
          LDN    0
          STDL   T1
 CCA40    BSS
          LDML   CCAT,T1     BUILD COMMAND PACKET
          STML   CP+4,T1
          AODL   T1
          LMN    9
          NJN    CCA40       IF FIRST 11 PARAMETER WORDS NOT MOVED
          LDML   RPB+8+9
          STML   CP+FCP+9    PORT A,B CONTROLLER ADDRESS
          LDML   RPB+8+10
          STML   CP+FCP+10   PORT C,D CONTROLLER ADDRESS
          LDML   RPB+8+11
          LPC    0#F0FD
          LMML   CTS,CH
          STML   CP+FCP+11   SELECT CHANNEL TRANSFER RATE
          LDC    H0209
          STML   CP+OPCD     LOAD ATTRIBUTES OPERATION CODE
          LDN    30          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          LDC    0#200
          STDL   MFID        INTERLOCK COMMANDS AND RESPONSES ONLY
          RJM    SDTM        SET DATA TRANSFER MODE
          RJM    SA          SAVE ATTRIBUTES
          LDML   RPB+8+11
          LPC    0#F02
          LMML   CTS,CH
          ZJN    CCA70       IF CHANNEL TRANSFER SPEED CORRECT
          LDC    H8415       SLAVE RESET
          STML   /SS/P.RESET,CSST  INDICATE RESET ISSUED
          RJM    IR          ISSUE RESET
          RJM    IH          INTERRUPT HANDLER
          LDN    0
          STML   /SS/P.RESET,CSST  INDICATE RESET COMPLETE
          LDN    ID16
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    CCA80       IF PARAMETER NOT FOUND
          LDML   RPB+6,T3
          LPC    0#FEE0
          LMC    0#6000
          NJN    CCA80       IF SLAVE RESET FAILED
 CCA70    BSS
          STDL   MFID        CLEAR MASK FOR INTERLOCK DATA
          RJM    DTM         DETERMINE TRANSFER MODE
          RJM    SEL         ENSURE STREAMING FOR COMMANDS AND RESPONSES
          STDL   CTM         CLEAR CHANGE TRANSFER MODE FLAG
          RJM    DCM         DESELECT THE CONTROLLER
          RJM    SDTM        SET DATA TRANSFER MODE TO STREAMING
          LJM    CCAX
 CCA80    BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 CCAT     BSS                EXPECTED CONTROLLER ATTRIBUTES
          DATA   0#2D1,0#100
          DATA   0#2D2,0#100
          DATA   0#2D3,0#100
          DATA   0#2D4,0#100
          DATA   0#7D6
          SPACE  5,20
** NAME-- COG
*
** PURPOSE-- CHECK OPERAND GENERATOR.  THE CRC VALUE GENERATED
*            AFTER A TEST MODE OPERATION IS READ AND COMPARED
*            WITH THE CORRECT VALUE.
*
** ENTRY  A = EXPECTED OPERAND GENERATOR
          SPACE  2
 COG10    BSS
          LDDL   CH
          ZJN    COGX        IF 10 MB CHANNEL

*         THE OPERAND GENERATOR FOR THE 25 MB CHANNEL IS 3 WORDS.
*         IF NOT ALL WORDS ARE READ, A CHANNEL ERROR MAY OCCUR.

          RJM    DCW         DISCARD SECOND WORD
          RJM    DCW         DISCARD THIRD WORD
 COGX     LJM    **
 COG      EQU    *-1
          STDL   T3
          LDC    H0009
          RJM    FUNC        DROP MASTER OUT
          RJM    DCM         DROP SELECT OUT
          LDML   ETMF,CH
          STDL   T2          WRITE REGISTER FUNCTION
          LDN    0           DISABLE TEST MODE
          RJM    WR          WRITE REGISTER
          LDDL   T3
          ZJN    COGX        IF 25 MB CHANNEL AND DMA READ
          LDML   RORF,CH     READ OPERAND GENERATOR FUNCTION
          RJM    RDRG        READ REGISTER
          LMDL   T3
          ZJN    COG10       IF OPERAND GENERATOR IS CORRECT
          LDN    E18         DMA TEST MODE FAILURE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- PT
*
** PURPOSE-- PATH TEST.  FIRST TEST THE DMA PATH BETWEEN CENTRAL
*            MEMORY AND THE RECEIVERS AND TRANSMITTERS, THEN
*            TEST THE PATH BETWEEN THE PP AND THE CONTROLLER.
*            IF A PATH TO A CONTROLLER STILL FAILS AFTER AT LEAST
*            ONE RETRY WITH SLAVE RESET, ALL UNITS ON THE FAILING
*            CONTROLLER WILL BE DISABLED.
*
** ENTRY
*         1)  AT INITIALIZATION AFTER PP LOADED
*         2)  AFTER THE PP HAS RECEIVED A RESUME
*         3)  DURING REQUEST RETRY IF SLAVE RESET FAILS
          SPACE  2
 PT100    BSS
          AODL   PTF         INDICATE PATH TEST COMPLETE
 PTX      LJM    **
 PT       EQU    *-1
          LDDL   UNUML
          ZJN    PT100       IF NO UNITS
          RJM    SCLOCK      SET CHANNEL LOCK
          LDDL   PTF
          NJN    PTX         IF NOT EXECUTING PATH TEST
          STDL   CMOD        CONTROLLER NUMBER
          STDL   UX
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          RJM    MR          MASTER RESET
          UJN    PT20
 PT8      BSS
          AODL   CMOD
          UJN    PT20
 PT16     BSS
          LDN    P.UN
          RADL   UX          UPDATE POINTER TO UNITS TABLE
          SBDL   UNUML
          PJN    PT100       IF END OF CONFIGURED UNITS
 PT20     BSS
          LDML   UNITS,UX
          SHN    -/UN/N.UNIT
          LPN    17B
          SBDL   CMOD
          MJN    PT16        IF THIS CONTROLLER ALREADY TESTED
          NJN    PT8         IF CMOD TOO SMALL
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T1
          LDDL   T1+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJN    PT16        IF UNIT DISABLED
          RJM    GETSS       GET SS TABLE FROM CM IF NECESSARY
          RJM    PS          PORT SELECT
          AOML   TMF         INDICATE TEST MODE IN PROGRESS
          RJM    TDP         TEST DMA PATH
          STML   TMF         TMF = 0, TEST MODE COMPLETE
          RJM    CCA         CHECK CONTROLLER ATTRIBUTES

*         WRITE BUFFER

          LDN    12
          STML   CP          COMMAND PACKET LENGTH
          LDC    H6200
          STML   CP+OPCD     WRITE TO BUFFER COMMAND
          LDC    0#531
          STML   CP+FCP      COMMAND EXTENT PARAMETER
          LDN    0
          STML   CP+FCP+1    UPPER WORD OF BYTE COUNT
          LDC    IBL*2
          STML   CP+FCP+2    BYTE LENGTH
          IFEQ   FE,1
          RJM    CPTB        FOR FORCING ERRORS
          ELSE
          RJM    CPT         COMMAND PACKET TRANSFER
          ENDIF
          RJM    BPTB        BUILD PATH TEST BUFFER
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    PT90        IF NOT TRANSFER NOTIFICATION
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAOUT     DATA, TRANSFER OUT
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0381       STREAM, WRITE FROM PP
          RJM    FUNC        RAISE MASTER OUT
          LDN    IBL         WORD COUNT
          RJM    OD          OUTPUT DATA
          STDL   WC          WORDS NOT TRANSFERRED
          LDC    MS50
          RJM    WFI         WAIT FOR INACTIVE
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT THE CONTROLLER
          LDDL   WC
          NJK    PT80        IF INCOMPLETE TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          NJK    PT90        IF NOT SUCCESSFUL

*         READ BUFFER

          LDC    H5200
          STML   CP+OPCD     READ FROM CONTROLLER BUFFER
          RJM    CPT         COMMAND PACKET TRANSFER
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16
          NJK    PT90        IF NOT TRANSFER NOTIFICATION
          RJM    SEL         SELECT THE CONTROLLER
          LDN    DATAIN      DATA TRANSFER IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0281       STREAM, READ TO PP MEMORY
          RJM    FUNC        RAISE MASTER OUT
          LDN    IBL         WORD COUNT
          RJM    ID          INPUT DATA
          STDL   WC          WORDS NOT TRANSFERRED
          LDC    MS50
          RJM    WFI         WAIT FOR INACTIVE
          LDN    0           NO MASTER TERMINATE
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT THE CONTROLLER
          LDDL   WC
          NJN    PT80        IF NOT ALL WORDS TRANSFERRED
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS
          NJN    PT90        IF NOT SUCCESSFUL

*         DON'T VERIFY DATA.  THE CONTROLLER BUFFER CAN BE CHANGED
*         BETWEEN THE WRITE AND READ OF THE BUFFER.

          LDML   /SS/P.RECOV,CSST
          LMN    3
          ZJN    PT70        IF PATH TEST PART OF RECOVERY FOR I/O REQUEST
          LDN    0
          STML   /SS/P.RQTRY,CSST  CLEAR REQUEST RETRY COUNTER
 PT70     BSS
          LJM    PT8
 PT80     BSS
          LDN    E29         INCOMPLETE TRANSFER
          UJN    PT94
 PT90     BSS
          LDN    E00         CP MUST DETERMINE ERROR CODE
 PT94     BSS
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
          SPACE  2
 SCLX     LJM    **
 SCLOCK   EQU    *-1
 SCL30    BSS
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    SCL30       IF LOCK WAS NOT SET
          STML   CLF         CHANNEL LOCK FLAG
          UJK    SCLX        EXIT, LOCK WAS SET
          SPACE  5,20
** NAME-- SDTM
*
** PURPOSE-- SET DATA TRANSFER MODE
          SPACE  2
 SDTMX    LJM    **
 SDTM     EQU    *-1
          LDC    H0209
          STML   CP+OPCD     LOAD ATTRIBUTES OPERATION CODE
          LDC    0#46E
          STML   CP+FCP      PARAMETER 6E
          LDDL   MFID
          LPN    1
          ADC    0#C080
          STML   CP+FCP+1    MODE FOR DATA
          LDN    0
          STML   CP+FCP+2
          LDN    12          COMMAND PACKET LENGTH
          RJM    ODFP        OUTPUT DATA FROM PP
          UJK    SDTMX
          SPACE  5,20
** NAME-- TDP
*
** PURPOSE-- TEST DMA PATH
*
** EXIT-- A = 0 IF NO ERROR

          SPACE  2
 TDPX     LJM    **
 TDP      EQU    *-1

*         TRANSFER FROM RECEIVERS TO CENTRAL MEMORY

          RJM    WOG         WRITE OPERAND GENERATOR, ENABLE TEST MODE
          LDN    H0009
          RJM    FUNC        SET SELECT OUT
          LDC    H0281
          RJM    FUNC        IPI TRANSFER FUNCTION (READ)
          LDC    H0C00       DMA READ
          RJM    TMT         TEST MODE TRANSFER
          LDML   EOG1,CH     EXPECTED OPERAND GENERATOR
          RJM    COG         DROP MASTER OUT, DESELECT, DISABLE TEST
                              MODE, CHECK OPERAND GENERATOR
          RJM    VTMD        VERIFY TEST MODE DATA

*         TRANSFER FROM CENTRAL MEMORY TO TRANSMITTERS

          RJM    WOG         WRITE OPERAND GENERATOR, ENABLE TEST MODE
          LDN    H0009
          RJM    FUNC        SET SELECT OUT
          LDC    H0381       IPI TRANSFER FUNCTION (WRITE)
          RJM    FUNC
          LDC    H0D00       DMA WRITE
          RJM    TMT         TEST MODE TRANSFER
          LDML   EOG2,CH     EXPECTED OPERAND GENERATOR
          RJM    COG         DROP MASTER OUT, DESELECT, DISABLE TEST
                              MODE, CHECK OPERAND GENERATOR
          UJK    TDPX
          SPACE  5,20
** NAME-- VTMD
*
** PURPOSE-- VERIFY TEST MODE DATA.  DATA GENERATED FROM A
*            TEST MODE READ IS CHECKSUMMED AND COMPARED
*            AGAINST THE CORRECT VALUE.
          SPACE  2
 VTMDX    LJM    **
 VTMD     EQU    *-1
          LDN    25
          STDL   P1          CM WORDS TO TRANSFER
          LOADC  CM.CB
          CRML   OB,P1       READ TEST MODE PATTERN
          LDN    0
          STDL   P2
          STDL   P3
          LDC    100         PP WORDS TO CHECKSUM
          STDL   P1
 VTMD10   BSS
          LDML   OB-1,P1
          RADL   P2
          SHN    -16
          RADL   P3
          SODL   P1
          NJN    VTMD10      IF MORE WORDS TO CHECKSUM
          LDDL   P2
          LMML   EC1,CH
          NJN    VTMD20      IF ERROR
          LDDL   P3
          LMML   EC2,CH
          ZJK    VTMDX       IF NO ERROR
 VTMD20   BSS
          LDN    E18         DMA TEST MODE FAILURE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          ERRMI  OB-*        IF CODE OVERFLOWS INTO TABLES

*         THE LAST CARD IN THE DECK MUST BE /EOR SO THAT COMS CAN
*         ASSEMBLE MULTIPLE DECKS.

          END
/EOR
*DECK DECK=IOM$E9Q5698 EXPAND=TRUE
          IDENT  E9Q5698
          CIPPU
          MEMSEL 8
          TITLE  E9Q5698 - 5698-1X TAPE DRIVER FOR I4-43
          COMMENT  *SMD* LVL=04
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4
*         THIS IS THE PP DRIVER FOR THE 25 MB IPI CHANNEL THAT SUPPORTS THE
*         5698-1X IPI TAPE SLAVE WITH 698-3X TAPE FACILITIES ON THE CYBER
*         I4_43 IOU SYSTEMS. THE PROGRAM NAME IS E9Q5698 AND THE DECK NAME IS
*         IOM$E9Q5698.
*
*         WHEN THE PP DRIVER IS LOADED THE FOLLOWING LOCATIONS ARE REQUIRED.
*         72 AND 73 MUST CONTAIN THE RMA OF THE PP INTERFACE TABLE (PIT).
*         0 MUST CONTAIN THE ADDRESS-1 AT WHICH EXECUTION BEGINS.
          TITLE  IODMAC1 MACROS
*COPYC IODMAC1
          TITLE  IODMAC2 MACROS
*COPYC IODMAC2
          TITLE  IODMAC3 MACROS
*COPYC IODMAC3
          TITLE  IODMAC4 MACROS
*COPYC IODMAC4
          TITLE  SPECIAL MACROS
          SPACE  4
**        SUBR - DEFINE SUBROUTINE ENTRY/EXIT.
*
*NAME     SUBR
*         DECLARE *NAME* TO BE THE ENTRY POINT TO A PP SUBROUTINE
*         WHICH IS ENTERED VIA *RJM* TO *NAME*.
*
*         THE FOLLOWING CODE IS GENERATED.
*NAMEX    LJM    *
*NAME     EQU    *-1

          PURGMAC  SUBR

          MACRO  SUBR,A
 A_X      LJM    *
 A        EQU    *-1
          ENDM
          TITLE  CPU RECORD DEFINITIONS AND EQUATES
*
* PP INTERFACE TABLE
*

 PIT      RECORD PACKED

* WORD 1
 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
* WORD 2
          ALIGN  0,64
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
* WORD 3
 FILL1    PPWORD             UNUSED
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
* WORD 4
 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER
* WORD 5
          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)
* WORD 6
          ALIGN  32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)
* WORDS 7-8
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
* WORD 9
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
* WORD 10
          ALIGN  48,64
 IN       PPWORD             IN POINTER
* WORD 11
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
* WORD 12
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          EJECT
*
* UNIT DESCRIPTORS.
*

 UD       RECORD PACKED

* WORD 1
 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
* WORD 2
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 UD       RECEND
          SPACE  4
*
* UNIT INTERFACE TABLE
*

 UIT      RECORD PACKED

* WORD 1
 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
 QCNT     PPWORD             NOT USED
* WORD 2
          ALIGN  16,64
 UBUFL    PPWORD             UNIT COMMUNICATION BUFFER LENGTH
 UBUF     RMA                UNIT COMMUNICATION BUFFER (RMA)
* WORD 3
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
* WORD 4
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
* WORD 5
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
* WORD 6
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

          MASKP  DSABLE
 K.DSABLE EQU    MSK

 UIT      RECEND
          EJECT
*
* UNIT COMMUNICATION AREA
*

 UCA      RECORD PACKED

* WORD 1
 IN       PPWORD
 LIMIT    PPWORD
* WORDS 2-5
          ALIGN  0,64
 FILL1    STRUCT 32          RESERVED

 UCA      RECEND
          SPACE  5
*
* REQUEST QUEUE
*

 RQ       RECORD PACKED

* WORD 1
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
* WORD 2
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
* WORD 3
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS
                               0 - ENABLE RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
 LONGB    BOOLEAN            LONG INPUT BLOCK
* WORD 4
          ALIGN  0,64
 SECADR   INTEGER            SECONDARY ADDRESS
* WORDS 5-64  COMMANDS

 RQ       RECEND
          EJECT
*
* COMMANDS
*

 CM       RECORD PACKED

* WORD 1
 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$

 CM       RECEND
          EJECT
*
* PP RESPONSE.
*

 RS       RECORD PACKED

* WORD 1
          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST
* WORD 2
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST
* WORD 3
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64       ALERT MASK
 LONGB    BOOLEAN            LONG INPUT BLOCK
* WORD 4
          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE I/F ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
 CHERR    BOOLEAN            CHANNEL PARITY ERROR ON INPUT
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION OCCURRED ON
                               INPUT OR INADEQUATE DATA RATE ON OUTPUT
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR ON AN
                               ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A CONTROLLER
                               OR UNIT
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A HARDWARE
                               MALFUNCTION.  EXAMPLE- UNIT NOT READY.
 FTO      BOOLEAN            FUNCTION TIMEOUT
 CHERO    BOOLEAN            CHANNEL PARITY ERROR ON OUTPUT
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
                               1 - RECOVERED ERROR
                               2 - COMMAND HAD EXPLICIT RESPONSE FLAG SET
                               3 - BOTH CONDITIONS 1 AND 2
 K.REC    EQU    1           RECOVERED ERROR
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE
                               1 - UNIT CHANGED FROM READY TO NOT READY
                               2 - UNIT CHANGED FROM NOT READY TO READY
                               3 - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
                               4 - CONTROLLER RESERVED TO ANOTHER ACCESS
                               5 - UNIT RESERVED TO ANOTHER ACCESS
                               6 - RECOVERED ABNORMAL CONDITION
                               7 - DEADSTART RESPONSE
                               8 - INITIALIZATION ERROR
                                   (CHECK ERRID FOR CONDITION)
          ALIGN  48,64       ALERT CONDITIONS
 LNGBLK   BOOLEAN            LONG INPUT BLOCK
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
 PDLIM    BOOLEAN            PHYSICAL DELIMITER ENCOUNTERED (EOT OR BOT)
 LDLIM    BOOLEAN            LOGICAL DELIMITER ENCOUNTERED (TAPE MARK)
 CHARF    BOOLEAN            CHARACTER FILL PERFORMED
 DUNIT    BOOLEAN            UNIT WAS DISABLED BY PP
* WORD 5
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)
* WORD 6-13
 IOR      STRUCT 64          INDIVIDUAL OPERATION RESULTS
                             (BLOCK ID AND ON-THE-FLY CORRECTIONS)
* WORD 14
 ERRID    PPWORD             ERROR IDENTIFICATION
 FUNTO    PPWORD             FUNCTION WITH TIMEOUT
 STREG    PPWORD             STATUS REGISTER IPI CHANNEL
 ERREG    PPWORD             ERROR REGISTER IPI CHANNEL
* WORD 15
 DOWNST   PPWORD             DOWN STATUS
 K.PDN    EQU    8           PP IDLED ITSELF
 K.FDN    EQU    4           PP DOWNED THE FACILITY
 K.SDN    EQU    2           PP DOWNED THE SLAVE
 K.CDN    EQU    1           PP DOWNED THE CHANNEL
 K.NDN    EQU    0           PP DOWNED NOTHING

 CR       PPWORD             CONTROL REGISTER
 OSR      PPWORD             OPERATIONAL STATUS REGISTER
 DMAER    PPWORD             DMA ERROR REGISTER
* WORD 16
 FACSTA   STRUCT 4           FACILITY STATUS, IPI ID52
 WC       PPWORD             WORDS NOT TRANSFERED (PP USAGE ONLY)
 FILL1    PPWORD             RESERVED

* WORDS 17-48                IPI RESPONSE PACKET IF PRESENT
*                            VARIABLE LENGTH
          EJECT

          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$
          MASKP  ABALRT
 K.ABALRT EQU    MSK
          MASKP  INTERR
 K.INTERR EQU    MSK
          MASKP  HDWR
 K.HDWR   EQU    MSK
          MASKP  CHERR
 K.CHERR  EQU    MSK
          MASKP  DATOV
 K.DATOV  EQU    MSK
          MASKP  FTO
 K.FTO    EQU    MSK
          MASKP  LNGBLK
 K.LNGBLK EQU    MSK
          MASKP  PDLIM
 K.PDLIM  EQU    MSK
          MASKP  LDLIM
 K.LDLIM  EQU    MSK
          MASKP  CHARF
 K.CHARF  EQU    MSK
          MASKP  DUNIT
 K.DUNIT  EQU    MSK
          MASKP  CHERO
 K.CHERO  EQU    MSK

 RS       RECEND
          EJECT
*
* PP COMMUNICATION BUFFER.
*

 CB       RECORD PACKED

* WORD 1
          ALIGN  31,64
 SLAVE    BOOLEAN            NONZERO IF SLAVE PP
 PARTNR   RMA                PARTNERS PIT (RMA)
* WORD 2
 CONTRL   STRUCT 8           LOAD CONTROLWARE COMMAND
* WORD 3
 CMCMD    STRUCT 8           SLAVE COMMAND
* WORD 4
 OVRLAY   STRUCT 8           OVERLAY RMA
* WORDS 5-8
 FILL1    STRUCT 32          RESERVED
* WORDS 9-13
 SCRAT    STRUCT 40          SCRATCH AREA
* WORDS 14-28
 ZEROES   STRUCT 120         120 BYTES (15 CM WORDS) OF ZERO
* WORDS 29-544
 PTD      STRUCT 4128        PATH TEST DATA (516 CM WORDS)


          MASKP  SLAVE
K.SLAVE   EQU    MSK


 CB       RECEND
          TITLE  PP RECORD DEFINITIONS AND EQUATES
          SPACE  3
*
* CONFIGURED SLAVES.
*

 SL       RECORD PACKED

* PP WORD 1
 FBA      PPWORD             FACILITIES (BY ADDRESS BIT) ON THIS SLAVE

* PP WORD 2
 SIU      PPWORD             SLAVE IN USE FLAG

* PP WORD 3
 FACLCK   SUBRANGE 0,1777B   CURRENT FACILITY LOCKED FLAG
 CURFAC   SUBRANGE 0,77B     CURRENT FACILITY NUMBER (FOR USE IN SCANNING)

* PP WORD 4
 SLVTST   PPWORD             SLAVE TESTING REQUIRED = 1
*                               ATTRIBUTES REQUIRED = 2

 SL       RECEND
          SPACE  4
*
* CONFIGURED UNITS.
*

 UN       RECORD PACKED

* PP WORD 1
 FILL1    SUBRANGE 0,37B     RESERVED
 PORT     SUBRANGE 0,3       IPI CHANNEL PORT, 0=PORT A, 1=PORT B
 FC       BOOLEAN            FACILITY CONFIGURED
 FD       BOOLEAN            FACILITY DISABLED
 CTF      BOOLEAN            CONFIDENCE TEST REQUIRED FLAG
 SN       SUBRANGE 0,7       SLAVE NUMBER
 FN       SUBRANGE 0,7       FACILITY NUMBER

* PP WORD 2
 LU       PPWORD             LOGICIAL UNIT NUMBER

* PP WORDS 3-5
 UIT      STRUCT 6           RMA OF UNIT INTERFACE TABLE (REFORMATTED)


          MASKP  PORT
 K.PORT   EQU    MSK
          MASKP  FC
 K.FC     EQU    MSK
          MASKP  FD
 K.FD     EQU    MSK
          MASKP  CTF
 K.CTF    EQU    MSK

 UN       RECEND
          EJECT
 MBID     EQU    30          MAX. NUMBER OF BLOCK ID-S TO SUPPORT (PP WORDS)
 MAXREQ   EQU    65          MAX. REQUEST LENGTH (CM WORDS)
 MAXSDC   EQU    10          MAX. NUMBER OF DIRECT CELLS TO SAVE IN TS TABLE
          SPACE  2
*
* TS TABLE DEFINITIONS.
*

 TS       RECORD PACKED

* PP WORD 1
 CRN      PPWORD             USED TO MAKE COMMAND REFERENCE NUMBER UNIQUE
*                            CRN MUST BE THE FIRST WORD OF THE TS TABLE

* PP WORD 2
 SN       SUBRANGE 0,377B    SLAVE NUMBER
 FN       SUBRANGE 0,377B    FACILITY NUMBER

* PP WORDS 3-6
 CPVACM   STRUCT 2           FILL FOR CM BOUNDARY
 CPVA     STRUCT 6           CURRENT REQUEST PVA (UNFORMATTED)

* PP WORDS 7-10
 CREQCM   STRUCT 4           FILL FOR CM BOUNDARY
 CREQ     STRUCT 4           CURRENT REQUEST RMA (UNFORMATTED)

* PP WORD 11
 LASTC    PPWORD             OFFSET OF COMMAND IN REQUEST

* PP WORD 12
 NUMCM    PPWORD             NUMBER OF COMMANDS LEFT TO PROCESS

* PP WORD 13
 ILSTL    PPWORD             NUMBER OF INDIRECT LIST ADDRESS-LENGTH PAIRS

* PP WORDS 14-15
 XFER     STRUCT 4           TRANSFER COUNT

* PP WORD 16
 CLK      PPWORD             STARTING OPERATION CLOCK VALUE

* PP WORD 17
 SECLIM   PPWORD             SECONDS LIMIT FOR CURRENT OPERATION

* PP WORDS 18-21
 CURCMD   STRUCT 8           CURRENT COMMAND

* PP WORD 22
 DENSEL   PPWORD             DENSITY SELECTION
                              1 = 1600 (PE)
                              2 = 6250 (GCR)
* PP WORD 23
 ECSEL    PPWORD             ERROR CORRECTION SELECTION
                              1 = EC ENABLED
                              2 = EC DISABLED
* PP WORD 24
 BIDEF    PPWORD             BLOCK ID EXPECTED FLAG
                              0 = NONE
                              1 = BID EXPECTED
                              2 = TAPE MARK EXPECTED
                              3 = EITHER TM OR BID EXPECTED
* PP WORD 25
 SCOND    PPWORD             STATUS CONDITIONS
                             100000 = LONG BLOCK
                              20000 = PHYSICAL DELIMITER (EOT)
                              10000 = LOGICIAL DELIMITER (TAPE MARK)
                               4000 = CHARACTER FILL
* PP WORD 26
 CHAIN    PPWORD             IPI COMMAND CHAINING FLAG
                             X0 = LAST COMMAND CHAIN WAS NOT ABORTED
                             X1 = LAST COMMAND CHAIN WAS ABORTED
                             0X = LAST COMMAND SENT WAS NOT CHAINED
                             2X = LAST COMMAND SENT WAS CHAINED
* PP WORDS 27-28
 FACSTA   STRUCT 4           FACILITY STATUS, IPI ID52

* PP WORDS 29-30
 ILSTA    STRUCT 4           INDIRECT LIST RMA (UNFORMATTED) ADDRESS

* PP WORDS 31-34
 ILSTP    STRUCT 8           INDIRECT LIST LENGTH/ADDRESS PAIR

* PP WORD 35
 CBURBC   PPWORD             CURRENT BURST BYTE COUNT

* PP WORD 36
 PARLAP   PPWORD             PARTIAL LENGTH/ADDRESS PAIR FLAG

* PP WORD 37
 RESBC    PPWORD             RESIDUAL BYTE COUNT FROM TRANSFER

* PP WORD 38
 SLVEES   PPWORD             SLAVE ENCODED ENDING STATUS

* PP WORD 39
 RETRY    PPWORD             RETRY COUNTER

* PP WORD 40
 NSCA     PPWORD             NON-STOP COMMAND ADDRESS (PP ADDRESS)

* PP WORD 41
 NSWC     PPWORD             NON-STOP WRITE COUNTER

* PP WORD 42
 NSRC     PPWORD             NON-STOP READ COUNTER

* PP WORD 43
 NSCRN    PPWORD             NON-STOP COMMAND REFERENCE NUMBER

* PP WORD 44
 WSTNF    PPWORD             WAIT SPECIAL TRANSFER NOTIFICATION FLAG

* PP WORD 45
 GNSCRN   PPWORD             GROUP NON-STOP COMMAND REFERENCE NUMBER

* PP WORD 46
 GNUMCM   PPWORD             GROUP NUMBER OF COMMANDS LEFT

* PP WORD 47
 GNSCA    PPWORD             GROUP NON-STOP PP COMMAND ADDRESS
          SPACE  4
* TS BUFFERS

*         BLOCK ID BUFFERS
 BIDB     STRUCT MBID*2      BLOCK ID BUFFER
 OTFC     PPWORD             ON-THE-FLY ERROR CORRECTION COUNTER
 BIDBP    PPWORD             BLOCK ID BUFFER POINTER

*         RECORD TRANSFER COUNT CIRCULAR BUFFER
 RTCIP    PPWORD             IN POINTER
 RTCOP    PPWORD             OUT POINTER
 RTCB     STRUCT 16          BUFFER FOR 4 32-BIT RECORD TRANSFER COUNTS


*         NOTE - ALL TS TABLE CELLS UP TO HERE ARE CLEARED DURING
*                NEW REQUEST INITIALIZATION PROCESSING.

*         SWITCH BUFFERS
 SAVEDC   STRUCT MAXSDC*2    SAVED DIRECT CELLS WHEN SWITCHING TS TABLES
 SATTR    PPWORD             SAVED SUBROUTINE ADDRESSES WHEN SWITCHING
 SOPMO    PPWORD
 SCFC     PPWORD
 SGFS     PPWORD
 SRSEL    PPWORD
 SRFEL    PPWORD
 SCLREQ   PPWORD
 SPTW     PPWORD
 SPTR     PPWORD
 SSLVT    PPWORD
 SISR     PPWORD
 SLIR     PPWORD
 SPTWOD   PPWORD
 SPTRID   PPWORD
 SREL     PPWORD
 SFACT    PPWORD
 SIH      PPWORD
 SWSTN    PPWORD

 RQB      STRUCT C.RQ*8      UNIT REQUEST HEADER BUFFER

 CQB      STRUCT C.CM*8*MAXREQ  UNIT COMMAND SEQUENCE BUFFER

 SPARE    STRUCT 14          SPARE BYTES

 TS       RECEND
          EJECT
* DEFINED RECORD EQUATES

* PP INTERFACE TABLE
 EBPIT    EQU    B.PIT       BYTE LENGTH
 EPPIT    EQU    P.PIT       PP WORD LENGTH
 ECPIT    EQU    C.PIT       CM WORD LENGTH

* UNIT DESCRIPTOR
 EBUD     EQU    B.UD        BYTE LENGTH
 EPUD     EQU    P.UD        PP WORD LENGTH
 ECUD     EQU    C.UD        CM WORD LENGTH

* UNIT INTERFACE TABLE
 EBUIT    EQU    B.UIT       BYTE LENGTH
 EPUIT    EQU    P.UIT       PP WORD LENGTH
 ECUIT    EQU    C.UIT       CM WORD LENGTH

* UNIT COMMUNICATIONS BUFFER
 EBUCA    EQU    B.UCA       BYTE LENGTH
 EPUCA    EQU    P.UCA       PP WORD LENGTH
 ECUCA    EQU    C.UCA       CM WORD LENGTH

* REQUEST QUEUE
 EBRQ     EQU    B.RQ        BYTE LENGTH
 EPRQ     EQU    P.RQ        PP WORD LENGTH
 ECRQ     EQU    C.RQ        CM WORD LENGTH

* COMMAND QUEUE
 EBCM     EQU    B.CM        BYTE LENGTH
 EPCM     EQU    P.CM        PP WORD LENGTH
 ECCM     EQU    C.CM        CM WORD LENGTH

* RESPONSE BUFFER (IPI RESPONSE BUFFER NOT INCLUDED)
 EBRS     EQU    B.RS        BYTE LENGTH
 EPRS     EQU    P.RS        PP WORD LENGTH
 ECRS     EQU    C.RS        CM WORD LENGTH

* PP COMMNUNICATIONS BUFFER
 EBCB     EQU    B.CB        BYTE LENGTH
 EPCB     EQU    P.CB        PP WORD LENGTH
 ECCB     EQU    C.CB        CM WORD LENGTH

* CONFIGURED SLAVES
 EBSL     EQU    B.SL        BYTE LENGTH
 EPSL     EQU    P.SL        PP WORD LENGTH
 ECSL     EQU    C.SL        CM WORD LENGTH

* CONFIGURED UNITS
 EBUN     EQU    B.UN        BYTE LENGTH
 EPUN     EQU    P.UN        PP WORD LENGTH
 ECUN     EQU    C.UN        CM WORD LENGTH

* TAPES SUPPORTED TABLE
 EBTS     EQU    B.TS        BYTE LENGTH
 EPTS     EQU    P.TS        PP WORD LENGTH
 ECTS     EQU    C.TS        CM WORD LENGTH
          TITLE  BUFFER EQUATES
*
* RESPONSE BUFFER EQUATES
*
 HRESPL   EQU    P.RS        NORMAL RESPONSE LENGTH (IN PP WORDS)
 NRL      EQU    HRESPL*2    NORMAL RESPONSE LENGTH (IN BYTES)

 SRESPL   EQU    128+1       MAX. IPI RESPONSE LENGTH +1 (IN PP WORDS)

 MRESPL   EQU    HRESPL+SRESPL  MAX. TOTAL RESPONSE BUFFER +1 (IN PP WORDS)
          SPACE  4
*
* CONFIGURATION EQUATES
*
 MAXCHP   EQU    1           MAX. NUMBER OF CHANNEL PORTS TO SUPPORT
 SLVPCH   EQU    8           MAX. NUMBER OF SLAVES PER CHANNEL PORT TO SUPPORT

 MAXSL    EQU    MAXCHP*SLVPCH  MAX. TOTAL SL TABLES TO SUPPORT

 FACPSL   EQU    8           MAX. NUMBER OF FACILITIES PER SLAVE TO SUPPORT
 MAXUD    EQU    MAXSL*FACPSL  MAX. TOTAL FACILITIES TO SUPPORT

 MCSLV    EQU    2           MAX. NUMBER OF CONCURRENT SLAVES TO SUPPORT
 MAXTS    EQU    1+MCSLV     MAX. NUMBER OF TS TABLES TO SUPPORT
          SPACE  4
*
* BUFFER EQUATES
*

 ENDMEM   EQU    17771B            LARGEST DRIVER ADDRESS

 RPB      EQU    ENDMEM-SRESPL     IPI RESPONSE PACKET BUFFER

 RS       EQU    RPB-P.RS          PP RESPONSE BUFFER

 PITB     EQU    RS-P.PIT          PP INTERFACE TABLE

 SLB      EQU    PITB-P.SL*MAXSL   SLAVES CONFIGURED TABLE

 UNITS    EQU    SLB-P.UN*MAXUD    FACILITIES CONFIGURED TABLE

 TS       EQU    UNITS-P.TS*MAXTS  TS TABLES
*         NOTE   THE FIRST TS TABLE IS FOR PP REQUESTS

 STRTBUF  EQU    TS                STARTING BUFFER ADDRESS


 UNITD    EQU    RPB+1       TRANSIENT UNIT DESCRIPTOR
 UITB     EQU    UNITD+P.UD  TRANSIENT UIT BUFFER
          TITLE  EQUATES
* CONDITIONAL ASSEMBLY EQUATES
 FH       EQU    0           1= KEEP FUNCTION HISTORY TABLE

 KH       EQU    0           1= KEEP HISTORY OF IPI COMMAND/RESPONSE PACKETS
 KHC      EQU    0           1= KEEP HISTORY OF IPI COMMAND PACKETS ONLY
 KHR      EQU    0           1= KEEP HISTORY OF IPI RESPONSE PACKETS ONLY

 VALID    EQU    0           1= VALIDATE CPU TABLES AND BUFFERS

* RESPONSE CODES (AA).
 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    40000B      INTERMEDIATE RESPONSE
 R.NRM    EQU    100000B     NORMAL REQUEST TERMINATION
 R.ABN    EQU    140000B     ABNORMAL REQUEST TERMINATION

* RESPONSE CODES (BB).
 R.RCV    EQU    10000B      RECOVERED ERROR CAUSED RESPONSE
 R.FLG    EQU    20000B      FLAG FIELD CAUSED RESPONSE
 R.RPF    EQU    R.RCV+R.FLG BOTH CONDITIONS OCCURRED

* UNSOLICITED RESPONSE CODES
 URC.RN   EQU    1           CHANGE FROM READY TO NOT READY
 URC.NR   EQU    2           CHANGE FROM NOT READY TO READY
 URC.IE   EQU    3           INTERNAL OR INTERFACE ERROR
 URC.CR   EQU    4           SLAVE RESERVED TO ANOTHER ACCESS
 URC.UR   EQU    5           FACILITY RESERVED TO ANOTHER ACCESS
 URC.RA   EQU    6           RECOVERED ABNORMAL CONDITION
 URC.DS   EQU    7           DEADSTART COMPLETED
 URC.IN   EQU    8           INITIALIZATION ERROR

* COMMAND EQUATES
 PSNI     EQU    2400B       PSN INSTRUCTION
 INPNI    EQU    102600B     INPN INSTRUCTION

 INDFLG   EQU    100B        INDIRECT ADDRESSING FLAG
 STRSP    EQU    200B        STORE RESPONSE FLAG

 IDLCMD   EQU    4           PP IDLE COMMAND
 RSUMCMD  EQU    5           PP RESUME COMMAND
 FUNCCMD  EQU    0#20        PHYSICAL COMMAND - FUNCTION (20 HEX)
 PWRTCMD  EQU    0#23        PHYSICAL COMMAND - OUTPUT 8-BIT DATA (23 HEX)
 LCREAD   EQU    0#41        LOCICAL READ RECORD OF 8-BIT DATA (41 HEX)
 LCWRITE  EQU    0#51        LOGICAL WRITE RECORD COMMAND (51 HEX)
 LCSTC    EQU    0#61        LOGICAL COMMAND STORE TRANSFER COUNT (61 HEX)

*         ATS PHYSICAL FUNCTION CODES
 F.FU     EQU    04B         FORMAT UNIT
 F.REW    EQU    10B         REWIND/UNLOAD UNIT
 F.SB     EQU    13B         FORESPACE/BACKSPACE BLOCK
 F.STM    EQU    15B         SEARCH TAPE MARK FWD/REV
 F.WTM    EQU    51B         WRITE TAPE MARK
 F.ERS    EQU    52B         ERASE TAPE
          EJECT
*
*         EQUATES FOR IPI ADAPTER
*
 H0000    EQU    0#0000      MASTER CLEAR ADAPTER
 H0009    EQU    0#0009      SET SELECT OUT
 H0X15    EQU    0#0015      REQUEST CLASS (X=PLUGGED) INTERRUPTS
 H0022    EQU    0#0022      CLEAR IPI ERROR
 H0029    EQU    0#0029      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H005B    EQU    0#005B      SET SYNC OUT
 H0071    EQU    0#0071      FULL WHEN SLAVE IN IS 0
 H00E1    EQU    0#00E1      READ STATUS REGISTER
 H00F1    EQU    0#00F1      READ ERROR REGISTER
 H0062    EQU    0#0062      PORT A SELECT (20 MHZ INT CLK)
 H0100    EQU    0#0100      CLEAR ERROR
 H0122    EQU    0#0122      IPI BUS A OUTPUT PARITY ERROR
 H0162    EQU    0#0162      PORT A SELECT (12 MHZ EXT CLK)
 H0200    EQU    0#0200      READ CONTROL REGISTER/READ ATTRIBUTES
 H0281    EQU    0#0281      STREAM, READ
 H0300    EQU    0#0300      WRITE CONTROL REGISTER
 H0302    EQU    0#0302      ENABLE ALL RECEIVERS AND TRANSMITTERS
 H0322    EQU    0#0322      IPI BUS A INPUT PARITY ERROR
 H0381    EQU    0#0381      STREAM, WRITE
 H0600    EQU    0#0600      READ DMA ERROR REGISTER
 H0700    EQU    0#0700      READ OPERATIONAL STATUS
 H0702    EQU    0#0702      SET OPERAND GENERATOR
 H0711    EQU    0#0711      DROP MASTER OUT
 H0715    EQU    0#0715      REQUEST CLASS 1, 2, OR 3 INTERRUPT
 H0800    EQU    0#0800      DMA TERMINATE/ABORT COMMAND
 H0802    EQU    0#0802      READ OPERAND REGISTER
 H0A00    EQU    0#0A00      READ T REGISTER
 H0B00    EQU    0#0B00      WRITE T PRIME REGISTER
 H0C00    EQU    0#0C00      DMA READ
 H0C22    EQU    0#0C22      ICI OUTPUT PARITY ERROR
 H0D00    EQU    0#0D00      DMA WRITE
 H0E00    EQU    0#0E00      CLEAR T-REGISTERS
 H7C42    EQU    0#7C42      IPI CHANNEL TRANSFER RATE (5.00 MB)
 H8025    EQU    0#8025      MASTER OUT, FULL WHEN SLAVE IN IS 1
 H8039    EQU    0#8039      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H8115    EQU    0#8115      SET MASTER OUT, PHYSICAL INTERFACE RESET
 H8215    EQU    0#8215      SET MASTER OUT, LOGICAL INTERFACE RESET
 H8415    EQU    0#8415      SET MASTER OUT, SLAVE RESET
 H9211    EQU    0#9211      DROP SYNC OUT
 H9213    EQU    0#9213      SET SYNC OUT
 HFE42    EQU    0#FE42      IPI CHANNEL TRANSFER RATE (6.00 MB)
          SPACE  2
*
* BUS CONTROL EQUATES
*
 CMDOUT   EQU    0           COMMAND, INFORMATION OUT
 RSPIN    EQU    1           RESPONSE, INFORMATION IN
 DATAOUT  EQU    2           DATA OUT
 DATAIN   EQU    3           DATA IN
          SPACE  2
*
* ENDING STATUS EQUATES
*
 EVENOT   EQU    0#0         EVEN OCTET TRANSFER
 ODDOT    EQU    0#F         ODD OCTET TRANSFER
          EJECT
*
* IPI COMMAND EQUATES
*
 OCNOP    EQU    0#0000      NOP
 OCATT    EQU    0#0200      ATTRIBUTES
 OCRAS    EQU    0#0300      REPORT ADDRESSEE STATUS
 OCPA     EQU    0#0400      PORT ADDRESS
 OCPC     EQU    0#0500      PATH CONTROL
 OCAC     EQU    0#0600      ATTENTION CONTROL
 OCOM     EQU    0#0700      OPERATING MODE
 OCABT    EQU    0#0800      ABORT
 OCREAD   EQU    0#1000      READ
 OCWRITE  EQU    0#2000      WRITE
 OCSPACE  EQU    0#4000      SPACE BLOCK/FILE
 OCPOSC   EQU    0#4100      POSITION CONTROL
 OCREPP   EQU    0#4200      REPORT POSITION
 OCRECP   EQU    0#4300      RECORD POSITION
 OCREADV  EQU    0#5000      READ VERIFY
 OCRFB    EQU    0#5200      READ FROM BUFFER
 OCRFDTB  EQU    0#5300      READ FACILITY DATA TO BUFFER
 OCWTB    EQU    0#6200      WRITE TO BUFFER
 OCWBTF   EQU    0#6300      WRITE BUFFER TO FACILITY
 OCIML    EQU    0#6600      LOAD SLAVE IML
 OCERASE  EQU    0#6700      ERASE
 OCPSD    EQU    0#8000      PERFORM SLAVE DIAGNOSTICS
 OCPFD    EQU    0#8100      PERFORM FACILITY DIAGNOSTICS
 OCREL    EQU    0#8400      READ ERROR LOG
          SPACE  4
*
* IPI COMMON MODIFIER EQUATES
*
 CMPRI    EQU    0#40        PRIORITY
 CMCHN    EQU    0#10        CHAIN
          SPACE  4
*
* IPI OPCODE MODIFIER EQUATES
*
 OMRF     EQU    0#2         READ FORWARD
 OMRR     EQU    0#A         READ REVERSE
 OMRVF    EQU    0#0         READ VERIFY FORWARD
 OMRVR    EQU    0#8         READ VERIFY REVERSE
 OMSFF    EQU    0#1         SEARCH FILE FORWARD
 OMSFR    EQU    0#9         SEARCH FILE REVERSE
 OMDSE    EQU    0#0         ERASE - DSE
 OMGAP    EQU    0#6         ERASE - GAP
 OMOMS    EQU    0#4         OPERATION MODE - SET
 OMAL     EQU    0#9         ATTRIBUTE - LOAD
 OMRELC   EQU    0#0         READ ERROR LOG - CLEAR
 OMRASC   EQU    0#1         REPORT ADDRESSEE STATUS - CONDITION
          EJECT
*
* IPI COMMON PARAMETER EQUATES
*
 CPTP     EQU    0#0251      TAPE POSITION
 CPTM     EQU    0#0251      TAPE MARK
 CPSRB    EQU    0#026E      SLAVE RECONFIGURATION BIT
 CPSRF    EQU    0#176F      SLAVE RECONFIGURATION FIELD
 CPNOP    EQU    0#0301      NOP
 CPBA     EQU    0#0350      BUFFER ADDRESS
 CPPM     EQU    0#0450      PORT MASK
 CPCE     EQU    0#0531      COMMAND EXTENT
 CPSCE    EQU    0#05D2      MAXIMUM BLOCK LENGTH (READ)
 CPTMB    EQU    0#0552      TAPE MODE BIT
 CPBCE    EQU    0#0931      BUFFER COMMAND EXTENT
 CPTMF    EQU    0#0953      TAPE MODE FIELD
 CPBID    EQU    0#02D0      ENABLE/DISABLE BID
          SPACE  4
*
* IPI ID EQUATES
*
 ID13     EQU    0#13        MICROCODE EXCEPTION FOR SLAVE
 ID14     EQU    0#14        INTERVENTION REQUIRED FOR SLAVE
 ID15     EQU    0#15        ALTERNATE PORT EXCEPTION
 ID16     EQU    0#16        MACHINE EXCEPTION FOR SLAVE
 ID17     EQU    0#17        COMMAND EXCEPTION FOR SLAVE
 ID18     EQU    0#18        COMMAND ABORTED FOR SLAVE
 ID19     EQU    0#19        SLAVE CONDITIONAL SUCCESS
 ID24     EQU    0#24        INTERVENTION REQUIRED FOR FACILITY
 ID26     EQU    0#26        MACHINE EXCEPTION FOR FACILITY
 ID29     EQU    0#29        FACILITY CONDITIONAL SUCCESS
 ID2A     EQU    0#2A        INCOMPLETE STATUS FOR FACILITY
 ID32     EQU    0#32        RESPONSE EXTENT PARAMETER
 ID51     EQU    0#51        CONDITION PARAMETER
 ID52     EQU    0#52        MEDIA STATUS PARAMETER
 IDD0     EQU    0#D0        BLOCK ID PARAMETER
 IDD2     EQU    0#D2        MAXIMUM BLOCK LENGTH PARAMETER
          EJECT
*
* IPI COMMAND/RESPONSE PACKET EQUATES
*
 CRN      EQU    1           COMMAND REFERENCE NUMBER
 OPCD     EQU    2           OPERATION CODE FOR SLAVE
 SLAD     EQU    3           SLAVE ADDRESS, FACILITY ADDRESS
 MAJST    EQU    4           MAJOR STATUS
          SPACE  4
*
* IPI MAJOR STATUS EQUATES
*         RESPONSE TYPES
 CC       EQU    1           COMMAND COMPLETE RESPONSE
 AR       EQU    4           ASYNCHRONOUS RESPONSE
 TN       EQU    5           TRANSFER NOTIFICATION
 CCS      EQU    0#18        COMMAND COMPLETE, SUCCESSFUL
          SPACE  4
*
* IPI LEFT SHIFTS FOR MAJOR STATUS
*
 LSCE     EQU    2           COMMAND EXCEPTION
 LSME     EQU    3           MACHINE EXCEPTION
 LSAPE    EQU    4           ALTERNATE PORT EXCEPTION
 LSIR     EQU    5           INTERVENTION REQUIRED
 LSMME    EQU    6           MESSAGE/MICROCODE EXCEPTION
 LSS      EQU    14          SUCCESSFUL
 LSI      EQU    15          INCOMPLETE
 LSCS     EQU    16          CONDITIONAL SUCCESS
 LSCA     EQU    17          COMMAND ABORTED
          SPACE  4
*
* IPI MISCELLANEOUS EQUATES
*
 BURST    EQU    8192        IPI BURST SIZE (MUST BE MULTIPLE OF 8)
          SPACE  4
*
*         MISCELLANEOUS EQUATES
*
 DC       EQU    37B         DEVICE CHANNEL NUMBER
 T698.1   EQU    21B         5698 UIT UNIT TYPE FOR 698-3X TAPE FACILITY
 MALETVE  EQU    1           MALET/VE CHANNEL REQUEST VALUE IN WORD (T2)
 MS25     EQU    26738*2     25 MILLISECOND TIMEOUT FOR CERTAIN LOOPS
 SRT      EQU    45          SLAVE RESET TIMEOUT (SECONDS)
 BYPSD    EQU    400000B     BYPASS SELECT/DESELECT IN ROUTINE CPT
          EJECT
*
* IOU/SLAVE/FACILITY ERROR CODES    *** DEC ***
*
 E00      EQU    0           CP MUST DECODE STATUS IN RESPONSE PACKET
 E01      EQU    1           FUNCTION TIMEOUT
 E02      EQU    2           CHANNEL EMPTY WHEN ACTIVATED
 E03      EQU    3           PERIOD COUNTER PARITY
 E04      EQU    4           UPPER ICI PARITY
 E05      EQU    5           LOWER ICI PARITY
 E06      EQU    6           IOU ERROR
 E07      EQU    7           INCOMPLETE I4 TRANSFER
 E08      EQU    8           CHANNEL NOT EMPTY
 E09      EQU    9           CENTRAL MEMORY ERROR
 E10      EQU    10          INVALID CM RESPONSE CODE
 E11      EQU    11          CM RESPONSE CODE PARITY ERROR
 E12      EQU    12          CMI READ DATA PARITY ERROR
 E13      EQU    13          JY DATA ERROR
 E14      EQU    14          BAS PARITY ERROR
 E15      EQU    15          LZ ERROR
 E16      EQU    16          JY ERROR
 E17      EQU    17          LX ERROR
 E18      EQU    18          DMA TEST MODE FAILURE
 E19      EQU    19          ILLEGAL OPERATION
 E20      EQU    20          CANT SELECT SLAVE
 E21      EQU    21          BIT SIGNIFICANT RESPONSE ERROR
 E22      EQU    22          NO SYNC IN
 E23      EQU    23          SYNC IN DID NOT DROP
 E24      EQU    24          IPI SEQUENCE ERROR
 E25      EQU    25          UPPER IPI CHANNEL PARITY
 E26      EQU    26          LOWER IPI CHANNEL PARITY
 E27      EQU    27          SLAVE IN NOT SET
 E28      EQU    28          SLAVE IN DID NOT DROP
 E29      EQU    29          INCOMPLETE TRANSFER
 E30      EQU    30          CHANNEL STAYED ACTIVE
 E31      EQU    31          BUFFER COUNTER PARITY
 E32      EQU    32          SYNC COUNTER PARITY
 E33      EQU    33          LOST DATA
 E34      EQU    34          BUS PARITY
 E35      EQU    35          COMMAND REJECT
 E36      EQU    36          SYNC OUT NOT EQUAL SYNC INS
 E37      EQU    37          BUS B ACKNOWLEDGE INCORRECT
 E38      EQU    38          NO SLAVE INTERRUPT
 E39      EQU    39          ENDING STATUS WRONG
 E40      EQU    40          SLAVE ENCODED ENDING STATUS WRONG
 E50      EQU    50          EXECUTING SLAVE DIAGNOSTICS
 E51      EQU    51          SLAVE DIAGNOSTICS PASSED
 E60      EQU    60          SLAVE FAILURE
 E61      EQU    61          FACILITY FAILURE
 E70      EQU    70          INTERNAL SLAVE ERROR
 E71      EQU    71          SLAVE INTERVENTION REQUIRED
 E72      EQU    72          SLAVE MACHINE EXCEPTION
 E73      EQU    73          COMMAND EXCEPTION
 E74      EQU    74          MICROCODE EXECUTION ERROR
 E75      EQU    75          ALTERNATE PORT EXCEPTION
 E76      EQU    76          UNEXPECTED RESPONSE
 E77      EQU    77          FACILITY RESERVED TO OTHER SLAVE
 E78      EQU    78          NO BLOCK ID PARAMETER RETURNED
 E79      EQU    79          UNEXPECTED CLASS 2 INTERRUPT
 E90      EQU    90          NO END OF EXTENT (TAPE MARK) DETECTED
 E110     EQU    110         PP-SLAVE DATA INTEGRITY
 E111     EQU    111         SLAVE-FACILITY DATA INTERGRITY
 E120     EQU    120         SOFTWARE FAILURE
          EJECT
*
* INTERFACE ERROR CODES.     *** HEX ***
*
 E201     EQU    1001B       CHANNEL RESERVATION TABLE RMA NOT ON WORD BOUNDARY
 E202     EQU    1002B       RMA OF UNIT ACTIVITY MASK NOT ON WORD BOUNDARY
 E203     EQU    1003B       RMA OF PP COMMUNICATION BUFFER NOT ON WORD BOUNDARY
 E204     EQU    1004B       RESERVED FIELD OF THE PP COMMUNICATION BUFFER
                               DESCRIPTOR IS NOT ZERO
 E205     EQU    1005B       RESERVED FIELD OF THE PP REQUEST QUEUE DESCRIPTOR
                               IS NOT ZERO
 E206     EQU    1006B       RMA OF NEXT PP NOT A WORD BOUNDARY
 E207     EQU    1007B       RESERVED FIELD OF THE PP RESPONSE BUFFER DESCRIPTOR
                               IS NOT ZERO
 E208     EQU    1010B       LOGICAL UNIT OF UNIT DESCRIPTOR NOT IN SEQUENCE OR
                               NOT IN RANGE
 E209     EQU    1011B       RMA OF UNIT INTERFACE TABLE NOT ON WORD BOUNDARY
 E20A     EQU    1012B       INVALID CHANNEL NUMBER SPECIFIED IN UNIT DESCRIPTOR
 E20B     EQU    1013B       COMMUNICATION BUFFER LENGTH NOT A MULTIPLE OF WORDS
                               OR NOT LONG ENOUGH
 E20D     EQU    1015B       RESERVED FIELD OF IN POINTER IS NOT ZERO
 E20E     EQU    1016B       RESERVED FIELD OF OUT POINTER IS NOT ZERO
 E20F     EQU    1017B       RESERVED FIELD OF LIMIT POINTER IS NOT ZERO
 E210     EQU    1020B       INVALID PHYSICAL UNIT NUMBER
 E211     EQU    1021B       RMA OF INTERRUPT WORD NOT ON WORD BOUNDARY
 E212     EQU    1022B       RMA OF CHANNEL TABLE NOT ON WORD BOUNDARY
 E213     EQU    1023B       NO ACTIVE (NON NULL) UNIT DESCRIPTORS DEFINED
 E301     EQU    1401B       LOGICAL UNIT NUMBER NOT EQUAL TO LOGICAL UNIT OF
                               UNIT DESCRIPTOR
 E302     EQU    1402B       UNIT COMMUNICATION BUFFER RMA NOT ON WORD BOUNDARY
 E303     EQU    1403B       A RESERVED FIELD OF THE UNIT COMMUNICATION BUFFER
                               DESCRIPTOR IS NOT ZERO
 E304     EQU    1404B       RMA OF NEXT UNIT REQUEST NOT ON WORD BOUNDARY
 E305     EQU    1405B       RESERVED FIELD OF UNIT REQUEST QUEUE DESCRIPTOR IS
                               NOT ZERO
 E306     EQU    1406B       INVALID UNIT TYPE
 E307     EQU    1407B       UNIT COMMUNICATION BUFFER LENGTH NOT A MULTIPLE OF
                               CM WORDS
 E308     EQU    1410B       UNIT COMMUNICATION BUFFER IS TOO SMALL
 E501     EQU    2401B       INVALID COMMAND CODE
 E505     EQU    2405B       INVALID LENGTH SPECIFICATION IN COMMAND
 E50A     EQU    2412B       INVALID SEQUENCE OF COMMANDS
          TITLE  DIRECT CELLS
 T0       CON    START-1     START OF DRIVER-1
 T1       BSSZ   1           SCRATCH CELLS
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1
 P1       BSSZ   1
 P2       BSSZ   1
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 P6       BSSZ   1
          SPACE  2
 CLCUR    BSSZ   1           CURRENT CHANNEL 14 CLOCK VALUE
 CLMCS    BSSZ   1           CLOCK, MICROSECOND
 CLMLS    BSSZ   1           CLOCK, MILLISECOND
 CLSEC    BSSZ   1           CLOCK, SECOND
 CPTBP    BSSZ   1           CPT BYPASS PARAMETER
 CTM      BSSZ   1           IPI CHANGE TRANSFER MODE FLAG
 CURCH    BSSZ   1           CURRENT CHANNEL NUMBER
 FI       BSSZ   1           FUNCTION HISTORY BUFFER INDEX
 HBP      BSSZ   1           HISTORY BUFFER POINTER
 LF       BSSZ   1           LAST FUNCTION TO IPI ADAPTER
 LIM      BSSZ   1           LIMIT OF CM RESPONSE BUFFER
 MALREQF  BSSZ   1           MALET CHANNEL REQUEST FLAG
 TIU      BSSZ   1           TS TABLES IN USE BY BIT ADDRESS
 TSLVS    BSSZ   1           TOTAL NUMBER OF SLAVES CONFIGURED
 WC       BSSZ   1           WORD COUNTER
          SPACE  4
*         THE FOLLOWING DIRECT CELLS ARE SAVED/LOADED WITH THE TS TABLE
 SAVEFWA  EQU    *
 ASYNCP   BSSZ   1           ASYNCHRONUS PROCESSING FLAG
 CTST     BSSZ   1           CURRENT TS TABLE INDEX
 FACN     BSSZ   1           CURRENT FACILITY NUMBER
 OS       BSSZ   1           OPERATIONAL STATUS
 SLVN     BSSZ   1           CURRENT SLAVE NUMBER
*                            0X = PORT A  SLAVE X
 STATUS   BSSZ   1           IPI CHANNEL STATUS
 SX       BSSZ   1           SLAVES TABLE INDEX
 UX       BSSZ   1           UNITS TABLE INDEX
 SAVELWA  EQU    *-1
          ERRPL  SAVELWA-SAVEFWA-MAXSDC  INSURE TS SAVE AREA IS ENOUGH
*         THIS IS THE END OF THE SAVED TS TABLE DIRECT CELLS
          EJECT
 CMADR    BSSZ   3           CM ADDRESS
 AT1      BSSZ   1           ALTERNATE T1 DIRECT CELL
 CM.PIT   BSSZ   3           CM ADDRESS OF PP INTERFACE TABLE (REFORMATTED)

* BC, RMA ARE T REGISTER PARAMETERS
 BC       BSSZ   1           BYTE COUNT TO READ/WRITE
 RMA      BSSZ   2           RMA FOR DMA TRANSFER

* NOTE   DIRECT CELLS T1 THRU DCCEND WILL BE CLEARED ON DEADSTART/RESUMES
 DCCEND   EQU    *-1
          BSSZ   4           UNUSED
          SPACE  2
 BURSTSZ  CON    BURST       IPI BURST SIZE
 INITFLG  DATA   1           INITIALIZATION FLAG 1=DS, 2=RESUME, 3=MALET
 PPREQF   DATA   0           PP REQUEST FLAG
 ONE      CON    1           CONSTANT ONE (DO NOT CHANGE THIS CELL)
 TWO      CON    2           CONSTANT TWO (DO NOT CHANGE THIS CELL)
 FF       CON    0#FF        CONSTANT HEX FF (DO NOT CHANGE THIS CELL)
 DSRTP    DATA   2,0         REAL MEMORY WORD-ADDRESS OF PIT (PLUGGED)

          ERRNZ  DSRTP-72B   MUST BE AT LOCATION 72

 IDLFLG   DATA   0           PP IDLE FLAG, IF NONZERO ONLY PP REQUESTS ARE DONE.
 CLF      DATA   1           CHANNEL LOCK FLAG  ** 0 = LOCKED **
 PPNO     DATA   5           LOGICAL PP NUMBER
          BSSZ   1           UNUSED

 ID       DATA   H*E9Q5*     IDENTIFICATION FOR E9Q5698
          ERRNZ  ID-100B     MUST BE AT LOCATION 100B
          SPACE  2
*
*         ENTRY POINT
*
          SPACE  2
 START    LJM    INIT        ENTRY POINT OF DRIVER

          ERRNZ  START-102B  MUST BE AT LOCATION 102B
          SPACE  2
* THE FOLLOWING CM.XXX ARE REFORMATTED CM ADDRESSES
*         THE BYTE ADDRESS IS
*          RIGHTMOST 10 BITS OF WORD 0 CONCATENATED WITH
*          RIGHTMOST 12 BITS OF WORD 1 CONCATENATED WITH
*          RIGHTMOST  6 BITS OF WORD 2 CONCATENATED WITH
*          3 BITS OF ZEROS

 CM.INT   BSSZ   3           CM ADDRESS OF INTERRUPT TABLE
 CM.CHAN  BSSZ   3           CM ADDRESS OF CHANNEL TABLE
 CM.COM   BSSZ   3           CM ADDRESS OF PP COMMUNICATION BUFFER
 CM.RS    BSSZ   3           CM ADDRESS OF RESPONSE BUFFER

* THE FOLLOWING CM ADDRESS IS REFORMATTED FOR DMA T REGISTER
 CM.CB.T  BSSZ   3           CM ADDRESS OF COM. BUFFER TEST MODE AREA
          TITLE  PP MONITOR

          SPACE  4
*
* PP MONITOR
*
          SPACE  2
 MAIN     BSS
          RJM    CKIT        CHECK FOR INITIALIZATION REQUIRED

          RJM    CKPPRQ      CHECK FOR ANY PP REQUESTS
          ZJN    MAIN10      IF NONE
          RJM    DOPPRQ      PROCESS PP REQUEST

 MAIN10   BSS
          LDDL   IDLFLG      CHECK IF PP IS IDLED
          NJN    MAIN        IF YES

 MAIN20   BSS
          RJM    CKCREQ      CHECK FOR MALET REQUESTING THE CHANNEL
          ZJN    MAIN30      IF NOT
          RJM    DOCREQ      PROCESS MALET CHANNEL REQUEST

 MAIN30   BSS
          RJM    CKUR        CHECK FOR UNIT REQUESTS
          ZJN    MAIN40      IF NONE
          LJM    DOUR        PROCESS UNIT REQUEST

 MAIN40   BSS
          RJM    CKINT       CHECK/PROCESS SLAVE ASYNCHRONUS INTERRUPTS

          LJM    MAIN        RELOOP
          TITLE  MONITOR SUBROUTINES
** NAME-- CKIT
*
** PURPOSE-- CHECK IF INITIALIZATION TESTING REQUIRED
*
** EXIT-- IMMEDIATELY IF TESTING ALREADY COMPLETED.
*         AFTER TESTING ALL SLAVES WITH AT LEAST ONE CONFIGURED NON-DISABLED
*           FACILITY.
          SPACE  2
 CKIT     SUBR               ENTRY/EXIT
          LDDL   INITFLG     CHECK IF TESTING IS COMPLETE
          ZJN    CKITX       IF YES EXIT
          LDDL   IDLFLG      CHECK IF PP IS IDLE
          NJK    CKIT110     IF YES BYPASS TESTING
          LDDL   CTST        CHECK IF FIRST PASS THRU
          LMML   TS1
          NJN    CKIT10      IF NOT
          STDL   SLVN        START WITH PORT A  SLAVE 0
          RJM    SCLOCK      GET CHANNEL LOCKED
          LDML   TS2         USE FIRST SLAVE TS TABLE
          STDL   CTST
          RJM    MR          MASTER RESET
          UJN    CKIT20      CONT.
 CKIT10   BSS
          AODL   SLVN        INCREMENT SLAVE NUMBER
          SBN    MAXSL       CHECK FOR DONE
          PJK    CKIT100     IF YES
 CKIT20   BSS
          RJM    SETSX       SETUP SLAVE TABLE INDEX
          ZJN    CKIT10      IF NO CONFIGURED FACILITIES
          LDN    3           SET SLAVE TESTING/ATTRIBUTES REQUIRED FLAG
          STML   SLB+/SL/P.SLVTST,SX
          LDN    0
          STDL   FACN        START WITH FACILITY NUMBER 0
          UJN    CKIT40      CONT.
 CKIT30   BSS
          AODL   FACN        INCREMENT FACILITY NUMBER
          SBN    FACPSL      CHECK FOR LIMIT
          PJN    CKIT10      IF YES
 CKIT40   BSS
          RJM    SETUX       SETUP UNITS TABLE INDEX
          ZJN    CKIT30      IF UNIT NOT CONFIGURED
          LDML   UNITS+/UN/P.FD,UX
          SHN    /UN/L.FD+2  CHECK FOR DISABLED
          MJN    CKIT30      IF YES
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UIT
          CRDL   T1          GET UIT DISABLE BIT
          LDDL   T1+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJN    CKIT30      IF DISABLED
          LDML   TS2         USE FIRST SLAVE TS TABLE
          STDL   CTST
          RJM    INTS        INITIALIZE TS TABLE
          LDML   UNITS+/UN/P.LU,UX  GET LOGICIAL UNIT NUMBER
          STML   /TS/P.RQB+/RQ/P.LU,CTST  PUT INTO TS TABLE
          RJM    PS          PORT SELECT
          RJM    TICP        TEST IPI CHANNEL PATH
          LDDL   INITFLG     CHECK IF DEADSTART INITIALIZATION
          SBN    1
          NJN    CKIT50      IF NOT
 CKIT45   BSS
          LDN    2           SET RETRY LEVEL
          STML   /TS/P.RETRY,CTST
          RJM    ISR         ISSUE SLAVE RESET
          UJN    CKIT60      CONT.
 CKIT50   BSS
          LDML   SRTAB,SLVN  CHECK IF SLAVE RESET EVER EXECUTED
          ZJN    CKIT45      IF NOT
          LDN    1           SET RETRY LEVEL
          STML   /TS/P.RETRY,CTST
          RJM    LIR         LOGICIAL INTERFACE RESET
 CKIT60   BSS
          LDN    0           SET RETRY LEVEL
          STML   /TS/P.RETRY,CTST
          LDN    1           ENABLE ERROR CORRECTION
          STML   /TS/P.ECSEL,CTST
          RJM    ATTRIB      SET ALL SLAVE ATTRIBUTES
          RJM    PTW         PATH TEST WRITE
          RJM    PTR         PATH TEST READ
          LDN    0           CLR SLAVE TESTING REQUIRED FLAG
          STML   SLB+/SL/P.SLVTST,SX
          UJK    CKIT10      GO DO NEXT SLAVE

*         INITIALIZATION TESTING COMPLETE
 CKIT100  BSS
          LDN    0           CLEAR SLAVE TS TABLE
          STDL   SLVN
          STDL   FACN
          RJM    CLRTS       CLEAR TS2 SLAVE TABLE
 CKIT110  BSS
          LDML   TS1         RESET TO TS1 IF PP RESUME
          STDL   CTST
          LDDL   INITFLG     DETERMINE WHAT CAUSED PP INITIALIZATION
          SBN    3
          ZJN    CKIT120     IF MALET
          RJM    CLRTS       CLEAR TS1 PP TABLE
          LDN    0
          STDL   TIU         CLEAR TS TABLES IN USE FLAG
          STDL   PPREQF      CLEAR IF FROM RESUME
          STML   RPB         CLEAR IPI RESPONSE LENGTH
          STDL   SX          CLEAR SLAVE INDEX
          STDL   UX          CLEAR UNIT INDEX
          UJN    CKIT130     CONT.
 CKIT120  BSS
          LDDL   IDLFLG      MALET PROCESSING
          NJN    CKIT140     IF PP IS IDLE (TESTING DONE BY RESUME)
 CKIT130  BSS
          LDN    0
          STDL   INITFLG     CLR INITIALIZATION FLAG
 CKIT140  BSS
          UJK    CKITX       EXIT
          EJECT
** NAME-- CKPPRQ
*
** PURPOSE-- CHECK IF THERE ARE ANY PP REQUESTS QUEUED.
*
** EXIT-- A = NZ IF NEW OR PENDING REQUEST ACTIVE (PPREQF = NZ).
*         A = 0  IF NO REQUEST ACTIVE (PPREQF = 0).
          SPACE  2
 CKPPRQ2  RJM    CPLOCK      UNLOCK PP REQUEST QUEUE IN PIT
 CKPPRQ4  LDN    0           NO NEW REQUESTS


 CKPPRQ   SUBR               ENTRY/EXIT


          LDDL   PPREQF      CHECK IF PENDING REQUEST
          NJN    CKPPRQX     IF YES EXIT
          LOADC  CM.PIT      LOAD A AND R FOR PIT
          ADK    /PIT/C.PPQ
          CRML   T1,ONE      READ REQUEST RMA FROM PIT
          LDDL   T3          HALF 1 OF REQUEST RMA
          ADDL   T4          HALF 2 OF REQUEST RMA
          ZJN    CKPPRQX     IF NO REQUEST QUEUED
          RJM    SPLOCK      LOCK PP REQUEST QUEUE IN PIT
          NJK    CKPPRQ4     RETURN IF PP REQUEST QUEUE ALREADY LOCKED
          LOADC  CM.PIT      CM ADDRESS TO A AND R FOR READ
          ADK    /PIT/C.PPQPVA
          CRML   PITB+/PIT/P.PPQPVA-1,TWO  READ IN REQUEST PVA/RMA FROM PIT
          LDML   PITB+/PIT/P.PPQ  GET HALF 1 OF RMA OF 1ST REQUEST
          ADML   PITB+/PIT/P.PPQ+1
          ZJK    CKPPRQ2     IF RMA = 0 NO PP REQUEST QUEUED
          LDN    1           SET PP REQUEST FLAG
          STDL   PPREQF
          UJK    CKPPRQX     EXIT
          EJECT
** NAME-- DOPPRQ
*
** PURPOSE-- PROCESS THE WAITING PP REQUEST IF POSSIBLE.
*
** NOTE-- THE ONLY PP COMMANDS SUPPORTED ARE IDLE AND RESUME.
*         THERE CAN BE ONLY ONE COMMAND PER PP REQUEST.
          SPACE  2
 DOPPRQ   SUBR               ENTRY/EXIT
          LDDL   TIU         CHECK IF ANY SLAVE USING TS TABLES
          LPN    76B         MASK OUT PP TS TABLE
          NJN    DOPPRQX     IF YES EXIT
          STDL   PPREQF      CLEAR THE PP REQUEST FLAG
          STDL   SLVN        CLEAR SLAVE NUMBER
          STDL   FACN        CLEAR FACILITY NUMBER
          LDN    1           SET PP TS TABLE IN USE
          STDL   TIU
          LDML   TS1         USE TS TABLE 1 FOR THE PP REQUEST
          STDL   CTST
          LDK    CM.PIT      SETUP SOURCE OF REQUEST
          STDL   T7
          RJM    LDTS        LOAD THE TS TABLE AND UNLOCK QUEUE
          LDML   /TS/P.NUMCM,CTST  CHECK NUMBER OF COMMANDS
          SBN    1           PP CAN ONLY HAVE 1 ACTIVE COMMAND
          ZJN    DOPPRQ5     IF OK
          LDK    E50A        INVALID SEQUENCE OF COMMANDS
          RJM    SWFAIL      REPORT SOFTWARE FAILURE (NO RETURN)
 DOPPRQ5  BSS
          LDML   /TS/P.CQB,CTST  GET THE PP COMMAND
          SHN    -8          POSITION IT
          SBN    IDLCMD      CHECK FOR IDLE COMMAND
          ZJK    IDLE        IF YES
          SBN    RSUMCMD-IDLCMD  CHECK FOR RESUME COMMAND
          ZJK    RESUME      IF YES
          LDK    E501        INVALID COMMAND CODE
          RJM    SWFAIL      REPORT SOFTWARE FAILURE (NO RETURN)
          EJECT
** NAME-- CKCREQ
*
** PURPOSE-- CHECK IF CHANNEL IS REQUESTED BY MALET.
*
** EXIT-- A = NZ IF NEW OR PENDING REQUEST ACTIVE (MALREQF = NZ).
*         A = 0  IF NO REQUEST ACTIVE (MALREQF = 0).
          SPACE  2
 CKCREQ1  LDN    0           EXIT A = 0
          STDL   MALREQF     CLEAR MALET REQUEST FLAG

 CKCREQ   SUBR               ENTRY/EXIT


          LDDL   MALREQF     CHECK IF REQUEST ALREADY ACTIVE
          NJK    CKCREQX     IF YES, EXIT
          LDDL   CLF         CHECK IF CHANNEL IS CURRENTLY LOCKED
          NJN    CKCREQ1     IF NOT, EXIT
          LOADC  CM.CHAN     ADDRESS OF CM CHANNEL TABLE
          ADDL   CURCH       CHANNEL NUMBER IS INDEX INTO TABLE
          CRML   T1,ONE      READ CM CHANNEL ENTRY
          LDDL   T2          GET MAINTENANCE BYTES OF CHANNEL WORD
          LMK    MALETVE     CHECK IF REQUESTED
          NJK    CKCREQ1     IF CHANNEL IS NOT REQUESTED
          LDDL   T2          SET MALREQF
          STDL   MALREQF
          UJK    CKCREQX     EXIT A = NZ
          EJECT
** NAME-- DOCREQ
*
** PURPOSE-- PROCESS MALET CHANNEL REQUEST IF POSSIBLE
*
          SPACE  2
 DOCREQ   SUBR               ENTRY/EXIT
          LDDL   TIU         CHECK IF ANY SLAVE TABLES STILL IN USE
          LPN    76B         EXCEPT PP TS TABLE
          NJN    DOCREQX     IF YES EXIT
          DCN    DC+40B      INSURE CHANNEL IS INACTIVE
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          LDN    0
          STDL   MALREQF     CLEAR MALET REQUEST FLAG
          PAUSE  25000       GIVE MAINTENANCE PP THE CHANNEL
          LDDL   IDLFLG      CHECK IF PP IS IDLE
          NJN    DOCREQX     IF YES EXIT
*                            RESUME WILL CAUSE INITIALIZATION TESTING
          LDDL   INITFLG     CHECK IF TESTING ALREADY ESTABLISHED
          NJN    DOCREQ5     IF YES
          LDN    3           SET MALET REQUIRED INIT TESTING
          STDL   INITFLG
 DOCREQ5  BSS
          LDML   TS1         ENABLE TESTING
          STDL   CTST
          LJM    MAIN        GO DO TESTING
          EJECT
** NAME-- CKUR
*
** PURPOSE-- CHECK FOR ANY NEW OR CURRENT UNIT REQUESTS
*
** EXIT-- A = 0 IF NO REQUESTS ARE ACTIVE.
*         A = 1 IF CURRENT REQUEST ACTIVE.
*         A = 2 IF NEW LOCKABLE REQUEST IS ACTIVE.
          SPACE  2
 CKUR     SUBR               ENTRY/EXIT
          LDDL   TIU         GET TABLES IN USE
          LPN    76B         MASK WITH SLAVE TABLES USABLE
          ZJN    CKUR20      IF NONE ACTIVE

 CKUR10   RJM    SCANT       SCAN TABLES FOR NEXT ACTIVE ONE
          ZJN    CKUR10      IF NOT THIS ONE
          LDN    1           SET A=1, ACTIVE CURRENT REQUEST
          UJN    CKURX       EXIT

 CKUR20   LDDL   PPREQF      CHECK FOR ACTIVE PP REQUEST
          ADDL   MALREQF     ALSO MALET CHANNEL REQUEST
          ZJN    CKUR30      IF NOT
          LDN    0           SET A=0, DO NOT START ANY NEW REQUESTS
          UJN    CKURX       EXIT

 CKUR30   RJM    SNXTAB      SELECT NEXT SLAVE TS TABLE TO USE
          RJM    SCANAS      SCAN ALL SLAVES FOR A LOCKABLE REQUEST
          ZJN    CKURX       IF NONE ACTIVE, EXIT A=0

          LDN    2           SET A=2, NEW REQUEST TO PROCESS
          UJN    CKURX       EXIT
          EJECT
** NAME-- DOUR
*
** PURPOSE-- PROCESS CURRENT OR NEW UNIT REQUESTS
*
** ENTRY--A = 1 IF CURRENT REQUEST TO BE PROCESSED
*         A = 2 IF NEW REQUEST TO BE PROCESSED
          SPACE  2
 DOUR     BSS                ENTRY
          SBN    1           CHECK FOR CURRENT ACTIVE REQUEST
          NJN    DOUR20      IF NOT

          RJM    RELDTAB     RELOAD CURRENT REQUEST TS TABLE
          LDML   SLB+/SL/P.SIU,SX  GET PROCESSING ADDRESS
          STML   DOURA       STORE JUMP ADDRESS
          LJM    *           GO PROCESS REQUEST
 DOURA    EQU    *-1

 DOUR20   RJM    INITNR      INITIALIZE NEW REQUEST
 DOUR30   SOML   /TS/P.NUMCM,CTST  DECREMENT COMMANDS REMAINING
          LDN    0           DO NOT INCREMENT COMMAND OFFSET
          RJM    NEXTCMD     GET NEXT (FIRST) COMMAND
          EJECT
*         DECODE AND EXECUTE THE NEXT COMMAND
 CMDEXEC  LDN    0
          STML   RPB         CLEAR IPI RESPONSE PACKET LENGTH
          STML   /TS/P.SCOND,CTST  CLEAR LAST STATUS CONDITIONS

          LDML   /TS/P.CURCMD,CTST  GET COMMAND CODE
          SHN    -8          POSITION IT

*         CHECK FOR PHYSICAL FUNCTION COMMAND (20 HEX)
 CMDEX20  SBN    FUNCCMD
          NJN    CMDEX23     IF NOT
          LJM    PFUNC

*         CHECK FOR OUTPUT 8-BIT DATA COMMAND (23 HEX)
 CMDEX23  SBN    PWRTCMD-FUNCCMD
          NJN    CMDEX41     IF NOT
          LJM    OUT8D

*         CHECK FOR LOGICIAL READ COMMAND (41 HEX)
 CMDEX41  SBN    LCREAD-PWRTCMD
          NJN    CMDEX51     IF NOT
          LJM    READ

*         CHECK FOR LOGICIAL WRITE COMMAND (51 HEX)
 CMDEX51  SBN    LCWRITE-LCREAD
          NJN    CMDEX61     IF NOT
          LJM    WRITE

*         CHECK FOR STORE TRANSFER COUNT COMMAND (61 HEX)
 CMDEX61  SBN    LCSTC-LCWRITE
          NJN    CMDEX99     IF NOT
          LJM    STRTC

*         INVLAID COMMAND
 CMDEX99  LDK    E501        INVALID COMMAND CODE
          RJM    SWFAIL      REPORT SOFTWARE FAILURE (NO RETURN)
          EJECT
*         CURRENT COMMAND HAS COMPLETED
 CMDCOMP  BSS
          RJM    ERRCHK      CHECK FOR ERRORS
          NJK    FAIL        IF ERRORS

 NOSTAT   LDML   /TS/P.CURCMD,CTST  CHECK FOR STORE RESPONSE REQUESTED
          SHN    17-7
          PJN    NOSTR       IF NOT REQUESTED
          LDML   /TS/P.NUMCM,CTST  CHECK IF THIS IS LAST COMMAND
          ZJN    REQCOMP     IF YES
          RJM    PNR         PREPARE NORMAL RESPONSE
          LDC    R.FLG       SET FLAG CAUSED RESPONSE BIT
          RAML   RS+/RS/P.RC
          RJM    RESP        SEND RESPONSE

 NOSTR    LDML   /TS/P.NUMCM,CTST  CHECK IF MORE COMMANDS
          ZJN    REQCOMP     IF NONE LEFT
          SOML   /TS/P.NUMCM,CTST  DECREMENT COMMANDS LEFT
          LDN    8           INCREMENT COMMAND OFFSET TO GET NEXT COMMAND
          RJM    NEXTCMD     GET NEXT COMMAND
          UJK    CMDEXEC     GO EXECUTE NEXT COMMAND

*         REQUEST HAS BEEN COMPLETED
 REQCOMP  BSS
          RJM    GFS         GET FACILITY ID52 STATUS
          RJM    PNR         PREPARE NORMAL RESPONSE

 FAIL     LJM    IODONE      PROCESS END OF REQUEST
          EJECT
** NAME-- CKINT
*
** PURPOSE-- CHECK FOR ANY ASYNCHRONUS SLAVE INTERRUPTS
*            AND PROCESS THEM
          SPACE  2
 CKINT1   LDML   CKINTA      RESTORE ORIGINAL SLVN AND FACN
          STDL   SLVN
          LDML   CKINTB
          STDL   FACN
          RJM    CLRTS       CLEAR TS TABLE
          LDN    0           CLEAR ASYNCHRONUS PROCESSING FLAG
          STDL   ASYNCP
          LDDL   TIU         CLEAR TS TABLE IN USE
          LPN    73B
          STDL   TIU

 CKINT    SUBR               ENTRY/EXIT

          LDDL   TIU         CHECK IF ANY TS TABLES ARE IN USE
          NJN    CKINTX      IF YES EXIT
          LDN    4           SET TS3 TABLE IN USE
          STDL   TIU
          LDML   TS3         SET CURRENT TS TABLE TO TS3
          STDL   CTST
          STDL   ASYNCP      SET ASYNCHRONUS PROCESSING FLAG
          LDDL   SLVN        SAVE ORIGINAL SLVN AND FACN
          STML   CKINTA
          LDDL   FACN
          STML   CKINTB
          LDN    0           INITIALIZE RPB AND SLAVE NUMBER
          STML   RPB
          STDL   SLVN
          RJM    INTS        INITIALIZE CURRENT TS TABLE
          RJM    MCC         MASTER CLEAR CHANNEL
          UJN    CKINT20     CONT.

 CKINT10  AODL   SLVN        INCREMENT SLAVE NUMBER
          SBN    MAXSL       CHECK FOR DONE
          ZJK    CKINT1      IF YES

 CKINT20  RJM    SETSX       CHECK IF SLAVE IS CONFIGURED
          ZJN    CKINT10     IF NOT
          LDN    0           INITIALIZE FACILITY NUMBER
          STDL   FACN

 CKINT30  RJM    SETUX       CHECK IF FACILITY IS CONFIGURED
          NJN    CKINT40     IF YES
          AODL   FACN        INCREMENT FACILITY NUMBER
          UJN    CKINT30     TRY NEXT ONE

 CKINT40  BSS

*         CHECK FOR CLASS 2 INTERRUPTS
          LDN    2           CLASS 2 INTERRUPTS
          RJM    RI          REQUEST INTERRUPTS
          ZJN    CKINT50     IF NONE

*         PROCESS CLASS 2 INTERRUPTS
          RJM    SARF        SET ATTRIBUTES REQUIRED FLAG
          LDN    0           NO IPI STATUS IN RESPONSE
          STML   RPB
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          LDK    E79         UNEXPECTED CLASS 2 INTERRUPT
          STML   RS+/RS/P.ERRID
          LDDL   STATUS      SHOW SLAVE ADDRESSES WITH CLASS 2 INTERRUPTS
          STML   RS+/RS/P.STREG
          RJM    RESP        SEND RESPONSE
          RJM    LIR         LOGICIAL INTERFACE RESET TO CLEAR INTERRUPTS
          UJK    CKINT10     LOOP

*         CHECK FOR CLASS 1 OR 3 INTERRUPTS
 CKINT50  LDN    5           CLASS 1 AND 3 INTERRUPTS
          RJM    RI          REQUEST INTERRUPTS
          ZJK    CKINT10     IF NONE

*         PROCESS CLASS 1 OR 3 INTERRUPTS
          RJM    DTM         DETERMINE TRANSFER MODE
          RJM    SEL         SELECT SLAVE
          STDL   CTM         CLEAR CHANGE TRANSFER MODE FLAG
          RJM    RPT         RESPONSE PACKET TRANSFER
          RJM    DCM         DESELECT SLAVE
          LDML   RPB+MAJST   CHECK FOR ASYNC RESPONSE
          SHN    -4
          LPN    0#F
          LMK    AR
          NJN    CKINT60     IF NOT ASYNC RESPONSE
          LDML   RPB+SLAD    CHECK IF FACILITY ASYNC
          LPDL   FF
          LMDL   FF
          NJN    CKINT50     IF YES CHECK FOR OTHER INTERRUPTS
          RJM    SARF        SET ATTRIBUTES REQUIRED FLAG
 CKINT60  RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    RESP        SEND RESPONSE
          UJK    CKINT50     CHECK FOR OTHER INTERRUPTS THIS SLAVE
          SPACE  2
 CKINTA   BSSZ   1           ORIGINAL SLVN
 CKINTB   BSSZ   1           ORIGINAL FACN
          TITLE  COMMAND ROUTINES
** NAME-- IDLE
*
** PURPOSE-- PROCESS PP IDLE COMMAND
*            (LOGICIAL COMMAND 04)
          SPACE  2
 IDLE     BSS                ENTRY
          RJM    CCLOCK      CLEAR THE CHANNEL LOCK
          LDN    76B
          STDL   IDLFLG      SET THE PP IDLE FLAG
          LDN    0           NO IPI STATUS IN RESPONSE
          STML   RPB
          RJM    PNR         PREPARE NORMAL RESPONSE
          LDK    /RS/K.PDN   PP IDLED
          STML   RS+/RS/P.DOWNST
          RJM    RESP        SEND THE RESPONSE
          RJM    CLREQ       CLEAR THE REQUEST
          LJM    MAIN        GO TO MAIN AND WAIT FOR RESUME COMMAND
          EJECT
** NAME-- RESUME
*
** PURPOSE-- PROCESS PP RESUME COMMAND
*            (LOGICIAL COMMAND 05)
*
** NOTE-- RESPONSE TO RESUME COMMAND WILL BE SENT AFTER INITIALIZATION
*         TESTING HAS COMPLETED.
          SPACE  2
 RESUME   BSS                ENTRY
          LDN    0
          STDL   IDLFLG      CLEAR THE PP IDLE FLAG
          LDN    2
          STDL   INITFLG     SET INITIALIZATION FLAG TO RESUME
          LJM    INIT        REINITIALIZE THIS DRIVER
          EJECT
** NAME - PFUNC
*
** PURPOSE - TO PERFORM THE PHYSICAL COMMAND FUNCTION.
*            (LOGICIAL COMMAND 20)
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PFUNC    BSS                ENTRY
          LDML   /TS/P.CURCMD+3,CTST  GET FUNCTION CODE TO PROCESS
          LPN    77B         MASK MAJOR FUNCTION CODE BITS
* DECODE ATS FUNCTION CODE
          SBN    F.FU
          NJN    PFUNC10
          LJM    PFORM       IF FORMAT UNIT
 PFUNC10  BSS
          SBN    F.REW-F.FU
          NJN    PFUNC20
          LJM    PREW        IF REWIND/UNLOAD
 PFUNC20  BSS
          SBN    F.SB-F.REW
          NJN    PFUNC30
          LJM    PSPB        IF SPACE BLOCK FWD/REV
 PFUNC30  BSS
          SBN    F.STM-F.SB
          NJN    PFUNC40
          LJM    PSTM        IF SEARCH TAPE MARK FWD/REV
 PFUNC40  BSS
          SBN    F.WTM-F.STM
          NJN    PFUNC50
          LJM    PWTM        IF WRITE TAPE MARK
 PFUNC50  BSS
          SBN    F.ERS-F.WTM
          NJN    PFUNC90
          LJM    PERS        IF ERASE TAPE

*         NON-SUPPORTED COMMAND
 PFUNC90  BSS
          LDK    E501        NON-SUPPORTED COMMAND
          RJM    SWFAIL      REPORT SOFTWARE FAILURE (NO RETURN)
          EJECT
** NAME - OUT8D
*
** PURPOSE - PROCESS THE OUTPUT 8-BIT DATA COMMAND.
*            (LOGICIAL COMMAND 23)
*
** NOTE - THE WRITE COMMAND PACKET HAS ALREADY BEEN SENT BY THE
*         WRITE (LOGICIAL 51) COMMAND. THE TRANSFER NOTIFICATION
*         HAS NOT BEEN RECEIVED YET.
          SPACE  2
 OUT8D    BSS                ENTRY

 O8D05    LDML   /TS/P.WSTNF,CTST  CHECK WSTN FLAG
          NJK    O8D440      IF SET, CONTINUE CURRENT RECORD
          SPACE  2
*         PROCESS IPI INTERRUPTS
 O8D10    LDN    10          SECONDS LIMIT  (INCLUDES ID RETRY)
          RJM    IH          INTERRUPT HANDLER
          SHN    -4          POSITION RESPONSE TYPE
          LPN    0#F         MASK IT
          SBN    1           CHECK FOR COMMAND COMPLETION
          ZJK    O8D600      IF YES
          SBN    4           CHECK FOR TRANSFER NOTIFICATION
          ZJN    O8D20       IF YES
          LDN    0           ELSE MUST BE ASYNCHRONUS RESPONSE
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    O8D05       LOOP
          SPACE  2
*         INITIALIZE DATA TRANSFER
 O8D20    LDML   /TS/P.WSTNF,CTST CHECK WSTN FLAG
          ZJN    O8D25       IF NOT SET, START NEW RECORD
          LDN    0           CLEAR WSTN FLAG
          STML   /TS/P.WSTNF,CTST
          UJN    O8D30       CONTINUE CURRENT RECORD

 O8D25    RJM    NSI         NON-STOP INITIALIZATION
          LDML   /TS/P.NSCRN,CTST  COMPARE COMMAND REFERENCE NUMBERS
          LMML   RPB+CRN
          ZJN    O8D30       IF OK
          LDK    E76         REPORT UNEXPECTED STATUS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE (NO RETURN)
          SPACE  2
*         START DATA TRANSFER
 O8D30    RJM    SEL         SELECT SLAVE

 O8D40    LDN    DATAOUT     BUS A DATA OUT
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0381       STREAM AND WRITE
          RJM    FUNC
          LDN    0           CLEAR CURRENT BURST BYTE COUNT
          STML   /TS/P.CBURBC,CTST

*         DETERMINE BURST CHARACTERISTICS
 O8D50    LDML   /TS/P.ILSTP+1,CTST  GET REQUESTED BYTE COUNT THIS PAIR
          STDL   T1          SAVE IT
          ADML   /TS/P.CBURBC,CTST  ADD CURRENT BURST BYTE COUNT
          SBDL   BURSTSZ     SUBTRACT SLAVE BURST SIZE
          ZJN    O8D200      IF TRANSFER IS TO BURST BOUNDARY
          PJK    O8D300      IF TRANSFER IS GREATER THAN BURST BOUNDARY

*         PROCESS TRANSFER OF LESS THAN BURST BOUNDARY
          LDN    0           CLEAR PARTIAL L/A PAIR FLAG
          STML   /TS/P.PARLAP,CTST
          LDDL   T1          GET REQUESTED BYTE COUNT THIS PAIR
          ADN    1           ROUND UP (IF LAST PAIR HAS ODD BYTE COUNT)
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNEL WORD COUNT
          LDDL   T1          INCREMENT CURRENT BURST BYTE COUNT
          RAML   /TS/P.CBURBC,CTST
          RJM    DDO         DMA DATA OUTPUT OPERATION
          RJM    WFTE        WAIT FOR T PRIME REGISTER EMPTY
          NJN    O8D400      IF PARTIAL RECORD
          RJM    GETNP       GET NEXT L/A PAIR
          ZJN    O8D400      IF NO MORE L/A PAIRS
          UJN    O8D50       CONTINUE TO OUTPUT

*         PROCESS TRANSFER TO BURST BOUNDARY
 O8D200   LDN    0           CLEAR PARTIAL L/A PAIR FLAG
          STML   /TS/P.PARLAP,CTST
          LDDL   T1          GET REQUESTED BYTE COUNT THIS PAIR
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNNEL WORD COUNT
          LDDL   BURSTSZ     INCREMENT CURRENT BURST BYTE COUNT
          STML   /TS/P.CBURBC,CTST
          RJM    DDO         DMA DATA OUTPUT OPERATION
          UJN    O8D400      PROCESS END OF BURST

*         PROCESS TRANSFER OF GREATER THAN BURST BOUNDARY
 O8D300   LDDL   BURSTSZ     COMPUTE BYTE COUNT TO BURST BOUNDARY
          SBML   /TS/P.CBURBC,CTST  DECREMENT BY BYTES TRANSFERED ALREADY
          STML   /TS/P.PARLAP,CTST  SET PARTIAL L/A PAIR FLAG
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNEL WORD COUNT
          LDDL   BURSTSZ
          STML   /TS/P.CBURBC,CTST  SET CURRENT BURST BYTE COUNT
          RJM    DDO         DMA DATA OUTPUT OPERATION

*         PROCESS END OF BURST
 O8D400   RJM    WFTC        WAIT FOR TRANSFER COMPLETE
          LDML   /TS/P.CBURBC,CTST  CHECK FOR ODD/EVEN TRANSFER
          LPN    1
          ZJN    O8D420      IF EVEN, USE EVEN OCTET MASTER ENDING STATUS
          LDN    ODDOT       ELSE USE ODD OCTET STATUS
 O8D420   RJM    GES         GET ENDING STATUS
          LDDL   STATUS      SAVE SLAVE ENCODED ENDING STATUS
          STML   /TS/P.SLVEES,CTST
          RJM    URECTC      UPDATE RECORD TRANSFER COUNT
          NJN    O8D460      IF PARTIAL RECORD, REPORT ERROR
          LDML   /TS/P.SLVEES,CTST  CHECK FOR END OF RECORD
          LPN    60B         MASK PAUSE AND TDO BITS
          SBN    20B
          ZJN    O8D500      IF END OF RECORD
          RJM    GETNP       GET NEXT L/A PAIR
          ZJN    O8D460      IF NO PAIRS LEFT, REPORT ERROR
          LDML   /TS/P.SLVEES,CTST  CHECK FOR SLAVE PAUSE
          LPN    60B         MASK PAUSE AND TDO BITS
          ZJK    O8D40       IF NO PAUSE
          RJM    DCM         DESELECT SLAVE

 O8D440   RJM    WSTN        WAIT FOR SPECIAL TRANSFER NOTIFICATION
          ZJK    O8D30       IF NEXT BURST IS READY
          UJK    O8D10       ELSE PROCESS OTHER INTERRUPT

 O8D460   LDK    E505        INVALID LENGTH SPECIFICATION
          RJM    SWFAIL      REPORT ERROR (NO RETURN)
          SPACE  2
*         PROCESS END OF RECORD
 O8D500   RJM    DCM         DESELECT SLAVE
          LDML   /TS/P.RTCIP,CTST  INCREMENT RECORD XFER COUNT IN POINTER
          ADN    2
          LPN    7
          STML   /TS/P.RTCIP,CTST
          LDN    2           SEND 2 MORE WRITE COMMANDS IF ANY LEFT
          RJM    GWRT
          UJK    O8D10       WAIT FOR INTERRUPT
          SPACE  2
*         PROCESS COMMAND COMPLETION
 O8D600   AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          SOML   /TS/P.NSWC,CTST  DECREMENT NON-STOP WRITE COUNTER
          RJM    UREQTC      UPDATE REQUEST TRANSFER COUNTS
          LDML   RPB+MAJST   GET MAJOR STATUS
          LMN    CCS         CHECK FOR SUCCESSFUL
          NJN    O8D610      IF NOT
          LDML   /TS/P.CRN,CTST  CHECK THE CRN
          LMML   RPB+CRN
          NJN    O8D620      IF MISCOMPARE
          RJM    GBID        GET AND STORE BLOCK ID
          LJM    CMDCOMP     COMMAND COMPLETE

 O8D610   LDN    1           EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE (NO RETURN)

 O8D620   LDK    E76         REPORT UNEXPECTED RESPONSE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE (NO RETURN)
          EJECT
** NAME - READ
*
** PURPOSE - PROCESS LOGICAL READ RECORD COMMAND.
*            (LOGICIAL COMMAND 41)
*
** INPUT - THE SECONDARY ADDRESS FIELD OF THE REQUEST HEADER MUST HAVE A
*          MAXIMUM BYTE COUNT IN THE LEAST SIGNIFICANT 32 BITS. THIS
*          BYTE COUNT IS USED FOR THE IPI READ COMMAND EXTENT PARAMETER.
          SPACE  2
 READ     BSS                ENTRY

          LDML   /TS/P.NSRC,CTST  CHECK IF FIRST READ COMMAND
          NJK    READ40      IF NOT
          SPACE  2
*         SEND ALL READ COMMANDS TO SLAVE
          LDIL   CTST        GET COMMAND REFERENCE NUMBER
          STML   /TS/P.NSCRN,CTST  SET NON-STOP COMMAND REFERENCE NUMBER
          ADN    1           INCREMENT IT
          STML   READCP1     SAVE IT
          LDML   /TS/P.SN,CTST  GET ADDRESSEE
          STML   READCP5
          LDML   /TS/P.RQB+/RQ/P.SECADR+2,CTST  GET MAX. BYTE COUNT
          STML   READCP9     SET IN READ COMMAND PACKET
          LDML   /TS/P.RQB+/RQ/P.SECADR+3,CTST
          STML   READCPB
          ADML   READCP9     CHECK IF NON ZERO BYTE COUNT
          NJN    READ10      IF OK
          LDK    E505        INVALID LENGTH SPECIFICATION
          RJM    SWFAIL      REPORT SOFTWARE FAILURE (NO RETURN)

 READ10   LDML   /TS/P.NUMCM,CTST  GET NUMBER OF COMMANDS LEFT
          ADN    1           ADJUST FOR THIS COMMAND
          STDL   P5          SAVE IT
          LDML   /TS/P.LASTC,CTST  BUILD PP COMMAND ADDRESS
          SHN    -1
          ADDL   CTST
          ADK    /TS/P.CQB
          STDL   P6          SAVE IT
          STML   /TS/P.NSCA,CTST  SAVE FIRST NON-STOP COMMAND ADDRESS
          UJN    READ30

 READ20   LDN    8           INCREMENT PP ADDRESS TO NEXT COMMAND
          RADL   P6
          LDIL   P6          GET NEXT COMMAND
          SHN    -8          POSITION COMMAND CODE
          ADK    -LCREAD     CHECK FOR LOGICIAL READ
          NJN    READ40      IF NOT

 READ30   LDC    READCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
          AOML   /TS/P.NSRC,CTST  INCREMENT NON-STOP READ COUNTER
          LDDL   P5          DECREMENT COMMANDS LEFT COUNTER
          SBN    2
          STDL   P5
          ZJN    READ40      IF DONE
          AOML   READCP1     INCREMENT COMMAND REFERENCE NUMBER
          UJN    READ20      LOOP
          SPACE  4
*         PROCESS IPI INTERRUPTS
 READ40   LDML   /TS/P.WSTNF,CTST  CHECK WSTN FLAG
          NJK    READ440     IF SET, CONTINUE CURRENT RECORD

 READ50   LDK    100         SECS LIMIT (PARTIAL READ OF MAX 32K PE REC)
          RJM    IH          INTERRUPT HANDLER
          SHN    -4          POSITION RESPONSE TYPE
          LPN    0#F         MASK IT
          SBN    1           CHECK FOR COMMAND COMPLETION
          ZJK    READ600     IF YES
          SBN    4           CHECK FOR TRANSFER NOTIFICATION
          ZJN    READ60      IF YES
          LDN    0           ELSE MUST BE ASYNCHRONUS RESPONSE
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    READ40      LOOP
          SPACE  2
*         INITIALIZE DATA TRANSFER
 READ60   LDML   /TS/P.WSTNF,CTST  CHECK WSTN FLAG
          ZJN    READ65      IF NOT SET, START NEW RECORD
          LDN    0           CLEAR WSTN FLAG
          STML   /TS/P.WSTNF,CTST
          UJN    READ70      CONTINUE CURRENT RECORD

 READ65   RJM    NSI         NON-STOP INITIALIZATION
          LDML   /TS/P.NSCRN,CTST  COMPARE COMMAND REFERENCE NUMBERS
          LMML   RPB+CRN
          ZJN    READ70      IF OK
          LDK    E76         REPORT UNEXPECTED RESPONSE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE (NO RETURN)
          SPACE  2
*         START DATA TRANSFER
 READ70   RJM    SEL         SELECT SLAVE

 READ80   LDN    DATAIN      BUS A DATA IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0281       STREAM AND READ
          RJM    FUNC
          LDN    0           CLEAR CURRENT BURST BYTE COUNT
          STML   /TS/P.CBURBC,CTST
          STDL   BC          CLEAR PREVIOUS T PRIME REGISTERS
          STDL   RMA
          STDL   RMA+1

*         DETERMINE BURST CHARACTERISTICS
 READ90   LDML   /TS/P.ILSTP+1,CTST  GET REQUESTED BYTE COUNT THIS PAIR
          STDL   T1          SAVE IT
          ADML   /TS/P.CBURBC,CTST  ADD CURRENT BURST BYTE COUNT
          SBDL   BURSTSZ     SUBTRACT SLAVE BURST SIZE
          ZJN    READ200     IF TRANSFER IS TO BURST BOUNDARY
          PJK    READ300     IF TRANSFER IS GREATER THAN BURST BOUNDARY

*         PROCESS TRANSFER OF LESS THAN BURST BOUNDARY
 READ100  LDN    0           CLEAR PARTIAL L/A PAIR FLAG
          STML   /TS/P.PARLAP,CTST
          LDDL   T1          GET REQUESTED BYTE COUNT THIS PAIR
          ADN    1           ROUND UP (IF LAST PAIR HAS ODD BYTE COUNT)
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNEL WORD COUNT
          SHN    1           INCREMENT CURRENT BURST BYTE COUNT
          RAML   /TS/P.CBURBC,CTST
          RJM    DDI         DMA DATA INPUT
          RJM    WFTE        WAIT FOR T PRIME REGISTER EMPTY
          NJN    READ400     IF PARTIAL RECORD
          RJM    GETNP       GET NEXT L/A PAIR
          ZJN    READ400     IF NO MORE L/A PAIRS
          UJN    READ90      CONTINUE TO INPUT

*         PROCESS TRANSFER TO BURST BOUNDARY
 READ200  LDN    0           CLEAR PARTIAL L/A PAIR FLAG
          STML   /TS/P.PARLAP,CTST
          LDDL   T1          GET REQUESTED BYTE COUNT THIS PAIR
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNNEL WORD COUNT
          LDDL   BURSTSZ     INCREMENT CURRENT BURST BYTE COUNT
          STML   /TS/P.CBURBC,CTST
          RJM    DDI         DMA DATA INPUT
          UJN    READ400     PROCESS END OF BURST

*         PROCESS TRANSFER OF GREATER THAN BURST BOUNDARY
 READ300  LDDL   BURSTSZ     COMPUTE BYTE COUNT TO BURST BOUNDARY
          SBML   /TS/P.CBURBC,CTST  DECREMENT BY BYTES TRANSFERED ALREADY
          STML   /TS/P.PARLAP,CTST  SET PARTIAL L/A PAIR FLAG
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNEL WORD COUNT
          LDDL   BURSTSZ
          STML   /TS/P.CBURBC,CTST  SET CURRENT BURST BYTE COUNT
          RJM    DDI         DMA DATA INPUT

*         PROCESS END OF BURST
 READ400  RJM    WVTC        WAIT VARIABLE TRANSFER COMPLETE
          LDN    0           MASTER ENCODED ENDING STATUS
          RJM    GES         GET ENDING STATUS
          LDDL   STATUS      SAVE SLAVE ENCODED ENDING STATUS
          STML   /TS/P.SLVEES,CTST
          RJM    URECTC      UPDATE RECORD TRANSFER COUNT
          LDML   /TS/P.SLVEES,CTST  CHECK FOR END OF RECORD
          LPN    60B         MASK PAUSE AND TDO BITS
          SBN    20B
          ZJN    READ500     IF END OF RECORD
          RJM    GETNP       GET NEXT L/A PAIR
          ZJN    READ460     IF NO PAIRS LEFT, REPORT ERROR
          LDML   /TS/P.SLVEES,CTST  CHECK FOR SLAVE PAUSE
          LPN    60B         MASK PAUSE AND TDO BITS
          ZJK    READ80      IF NO PAUSE
          RJM    DCM         DESELECT SLAVE

 READ440  RJM    WSTN        WAIT FOR SPECIAL TRANSFER NOTIFICATION
          ZJK    READ70      IF NEXT BURST IS READY
          UJK    READ50      PROCESS OTHER INTERRUPT

 READ460  LDK    E505        INVALID LENGTH SPECIFICATION
          RJM    SWFAIL      REPORT ERROR (NO RETURN)
          SPACE  2
*         PROCESS END OF RECORD
 READ500  RJM    DCM         DESELECT SLAVE
          LDML   /TS/P.RTCIP,CTST  INCREMENT RECORD XFER COUNT IN POINTER
          ADN    2
          LPN    7
          STML   /TS/P.RTCIP,CTST
          UJK    READ50      WAIT FOR INTERRUPT
          SPACE  2
*         PROCESS COMMAND COMPLETION
 READ600  AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          SOML   /TS/P.NSRC,CTST  DECREMENT NON-STOP READ COUNTER
          RJM    UREQTC      UPDATE REQUEST TRANSFER COUNTS
          LDML   RPB+MAJST   GET MAJOR STATUS
          LMN    CCS         CHECK FOR SUCCESSFUL
          NJN    READ610     IF NOT
          LDML   /TS/P.CRN,CTST  CHECK THE CRN
          LMML   RPB+CRN
          NJN    READ620     IF MISCOMPARE
          RJM    GBID        GET AND STORE BLOCK ID
          LJM    CMDCOMP     COMMAND COMPLETE

 READ610  LDN    3           EXPECT BLOCK ID OR TAPE MARK
          RJM    CMDRESP     COMMAND RESPONSE DECODE (NO RETURN)

 READ620  LDK    E76         REPORT UNEXPECTED RESPONSE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE (NO RETURN)
          SPACE  4
*         -READ-  COMMAND PACKET
 READCP   DATA   0#000C      PACKET LENGTH
 READCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCREAD+CMCHN+OMRF  OP-CODE, CHAIN AND READ FORWARD
 READCP5  DATA   0#FFFF      ADDRESSEE
          CON    CPSCE       SPECIAL COMMAND EXTENT PARAMETER
 READCP9  DATA   0#FFFF        COUNT FIELD UPPER
 READCPB  DATA   0#FFFF        COUNT FIELD LOWER
          EJECT
** NAME - WRITE
*
** PURPOSE - TO PROCESS LOGICIAL WRITE COMMAND.
*            (LOGICIAL COMMAND 51 MODIFIED)
*
** NOTE-- THE ACTUAL DATA TRANSFER WILL BE DONE IN THE
*         OUTPUT 8-BIT DATA LOGICIAL COMMAND 23.
          SPACE  2
 WRITE    BSS                ENTRY

          LDML   /TS/P.NSWC,CTST  CHECK IF FIRST WRITE COMMAND
          NJN    WRITE10     IF NOT

*         INITIALIZE FIRST GROUP OF NON-STOP WRITE COMMANDS
          LDIL   CTST        GET COMMAND REFERENCE NUMBER
          STML   /TS/P.NSCRN,CTST  SET FIRST-1 NON-STOP CRN
          STML   /TS/P.GNSCRN,CTST  SET WORKING GROUP NON-STOP CRN
          LDML   /TS/P.NUMCM,CTST  GET NUMBER OF COMMANDS LEFT
          ADN    1           ADJUST FOR THIS COMMAND
          STML   /TS/P.GNUMCM,CTST  SAVE AS GROUP NUMBER OF CMDS LEFT
          LDML   /TS/P.LASTC,CTST  BUILD PP COMMAND ADDRESS
          SHN    -1
          ADDL   CTST
          ADK    /TS/P.CQB
          STML   /TS/P.GNSCA,CTST  SAVE AS GROUP NON-STOP PP ADDRESS
          ADN    4           SET FIRST NON-STOP COMMAND ADDRESS
          STML   /TS/P.NSCA,CTST
          LDN    4           SEND 4 WRITE COMMANDS IN FIRST GROUP
          RJM    GWRT        GO SEND A GROUP OF WRITE COMMANDS
 WRITE10  LJM    CMDCOMP     GOTO COMMAND COMPLETION
          SPACE  4
 GWRT     SUBR               ENTRY/EXIT
          STDL   P5          SET LOOP COUNTER FROM A
*         INITIALIZE THIS GROUP OF NON-STOP WRITE COMMANDS
 GWRT10   LDML   /TS/P.GNUMCM,CTST  CHECK IF ALL GROUPS DONE
          ZJN    GWRTX       IF YES
          LDML   /TS/P.GNSCA,CTST  GET PP CMD ADDRESS
          STDL   P6          SAVE IT
          LDIL   P6          GET THE COMMAND
          SHN    -8          POSITION COMMAND CODE
          ADC    -LCWRITE    CHECK FOR LOGICIAL WRITE COMMAND
          NJN    GWRTX       IF NOT
          LDML   /TS/P.SN,CTST  GET ADDRESSEE
          STML   WRTCP5      PUT INTO IPI COMMAND PACKAGE
          RJM    SEL         SELECT THE SLAVE

*         SEND THIS GROUP OF NON-STOP WRITE COMMANDS
 GWRT20   LDN    2           INCREMENT PP ADDRESS TO BYTE COUNT UPPER
          RADL   P6
          LDIL   P6          GET BYTE COUNT UPPER
          STML   WRTCP9      SET IT
          AODL   P6          INCREMENT PP ADDRESS TO BYTE COUNT LOWER
          LDIL   P6          GET BYTE COUNT LOWER
          STML   WRTCPB      SET IT
          AOML   /TS/P.GNSCRN,CTST  INCREMENT GROUP NON-STOP CRN
          STML   WRTCP1      SET IT
          LDC    WRTCP+BYPSD  COMMAND PACKET FWA AND BYPASS SEL/DCM
          RJM    CPT         COMMAND PACKET TRANSFER
          LDN    5           INCREMENT PP ADDRESS TO NEXT WRITE COMMAND
          RADL   P6
          AOML   /TS/P.NSWC,CTST  INCREMENT NON-STOP WRITE COUNTER
          LCN    2           DECREMENT GROUP NUMBER OF CMDS LEFT
          RAML   /TS/P.GNUMCM,CTST
          ZJN    GWRT30      IF DONE
          SODL   P5          DECREMENT LOOP COUNTER
          ZJN    GWRT30      IF DONE
          LDIL   P6          GET NEXT COMMAND
          SHN    -8          POSITION COMMAND CODE
          ADC    -LCWRITE    CHECK FOR LOGICIAL WRITE
          ZJN    GWRT20      IF YES

 GWRT30   RJM    DCM         DESELECT SLAVE
          LDDL   P6          SAVE WORKING PP CMD ADDRESS
          STML   /TS/P.GNSCA,CTST
          UJK    GWRTX       EXIT
          SPACE  4
*         -WRITE-  COMMAND PACKET
 WRTCP    DATA   0#000C      PACKET LENGTH
 WRTCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCWRITE+CMCHN  OP-CODE AND CHAIN
 WRTCP5   DATA   0#FFFF      ADDRESSEE
          CON    CPCE        COMMAND EXTENT PARAMETER
 WRTCP9   DATA   0#FFFF        COUNT (UPPER)
 WRTCPB   DATA   0#FFFF        COUNT (LOWER)
          EJECT
** NAME - STRTC
*
** PURPOSE - TO PERFORM THE LOGICAL COMMAND STORE TRANSFER COUNT.
*            (LOGICIAL COMMAND 61)
          SPACE  2
 STRTC    BSS                ENTRY
          LDN    0           INITIALIZE DIRECT CELLS
          STDL   T1
          STDL   T2
          LDML   /TS/P.XFER,CTST  GET TRANSFER COUNT
          STDL   T3          MOVE TO DIRECT CELLS
          LDML   /TS/P.XFER+1,CTST
          STDL   T4
          LOADF  /TS/P.CURCMD+2,CTST  LOAD R+A FROM COMMAND
          CWDL   T1          STORE TRANSFER COUNT
          LDN    0           CLEAR TRANSFER COUNTERS
          STML   /TS/P.XFER,CTST
          STML   /TS/P.XFER+1,CTST
          LJM    NOSTAT      COMMAND COMPLETE, NO STATUS TO CHECK
          TITLE  COMMAND SUBROUTINES
** NAME - PFORM
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF FORMAT UNIT
*            (FUNCTION CODE 004)
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
*
*          FORMAT FUNCTION PARAMETERS (LIKE ATS) ARE LOCATED IN THE
*          SECONDARY ADDRESS FIELD OF THE PERIPHERAL REQUEST.
          SPACE  2
 PFORM    BSS                ENTRY
          LDDL   CLF         CHECK IF CHANNEL IS ALREADY LOCKED
          ZJN    PFORM10     IF YES
          RJM    SCLOCK      LOCK CHANNEL LOCKWORD IN CHANNEL TABLE
 PFORM10  BSS
          RJM    SLVTST      CHECK FOR SLAVE TESTING REQUIRED
          LDML   SLB+/SL/P.SLVTST,SX  CHECK IF ATTRIBUTES REQUIRED
          ZJN    PFORM20     IF NOT
          LDN    1           ENABLE ERROR CORRECTION
          STML   /TS/P.ECSEL,CTST  SAVE SELECTION
          RJM    ATTRIB      SET ATTRIBUTES
          LDN    0
 PFORM20  BSS
          STML   /TS/P.FACSTA,CTST  CLEAR SPECIAL STATUS
          RJM    GFS         GET FACILITY STATUS TO CHECK FOR BUSY
          LDML   /TS/P.FACSTA+1,CTST  CHECK IF AT BOT
          SHN    17-15
          MJN    PFORM30     IF YES THEN DO DENSITY SELECTION
          LDML   SLB+/SL/P.SLVTST,SX  CHECK IF ATTRIBUTES WERE REQUIRED
          ZJN    PFORM60     IF NOT THEN BYPASS DENSITY SELECTION
 PFORM30  BSS
*         GET PARAMETER WORD 2 BIT 8  (DEFINE DENSITY SELECTION)
          LDML   /TS/P.RQB+/RQ/P.SECADR,CTST
          LPN    1           MASK DEFINE BIT
          ZJN    PFORM40     IF NOT SET USE DEFAULT DENSITY
*         GET PARAMETER WORD 2 BITS 7-6  (DENSITY SELECTION)
          LDML   /TS/P.RQB+/RQ/P.SECADR+1,CTST
          SHN    3           POSITION DENSITY SELECT BITS
          MJN    PFORM40     IF 6250 (GCR) SELECTED
          LDN    1           ELSE USE 1600 (PE) DENSITY
          UJN    PFORM50
 PFORM40  BSS
          LDN    2           USE 6250
 PFORM50  BSS
          STML   /TS/P.DENSEL,CTST  SAVE SELECTION
          RJM    OPMODE      SELECT DENSITY
 PFORM60  BSS
          LDN    0           CLEAR SPECIAL STATUS
          STML   /TS/P.FACSTA,CTST
          STML   SLB+/SL/P.SLVTST,SX  CLEAR TESTING/ATTRIBUTES REQUIRED
          RJM    FACTST      CHECK FOR FACILITY TESTING
          UJK    CMDCOMP     COMMAND COMPLETE
          EJECT
** NAME - PREW
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF REWIND/UNLOAD
*            (FUNCTION CODE X10)
*             X = 0 10 REWIND
*             X = 1 10 UNLOAD
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PREW     BSS                ENTRY
          RJM    RFEL        READ FACILITY ERROR LOG
          RJM    GFS         GET FACILITY STATUS ID52
          LDML   /TS/P.CURCMD+3,CTST  GET PHYSICAL FUNCTION CODE
          SHN    17-6
          MJK    PUNL        IF 110 UNLOAD
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PREWCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PREWCP5
          LDC    PREWCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PREW10   LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PREW20      IF NOT
          RJM    RSEL        READ SLAVE ERROR LOG
          LDN    0           CLEAR RESPONSE PACKET LENGTH
          STML   RPB
          LJM    CMDCOMP     COMMAND COMPLETE
 PREW20   LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PREW10      IF ASYNC RESPONSE
          SPACE  4
*         -POSITION CONTROL-  COMMAND PACKET
 PREWCP   DATA   0#0009      PACKET LENGTH
 PREWCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCPOSC      OP-CODE AND END OF CHAIN
 PREWCP5  DATA   0#FFFF      ADDRESSEE
          CON    CPTP        TAPE POSITION PARAMETER
          DATA   0#0800        REWIND
          EJECT
** NAME - PUNL
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF 110 UNLOAD
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PUNL     BSS                ENTRY
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PUNLCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PUNLCP5
          LDC    PUNLCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PUNL10   LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PUNL20      IF NOT
          RJM    RSEL        READ SLAVE ERROR LOG
          LDN    0           CLEAR RESPONSE PACKET LENGTH
          STML   RPB
          LJM    CMDCOMP     COMMAND COMPLETE
 PUNL20   LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PUNL10      IF ASYNC RESPONSE
          SPACE  4
*         -POSITION CONTROL-  COMMAND PACKET
 PUNLCP   DATA   0#0009      PACKET LENGTH
 PUNLCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCPOSC      OP-CODE AND END OF CHAIN
 PUNLCP5  DATA   0#FFFF      ADDRESSEE
          CON    CPTP        TAPE POSITION PARAMETER
          DATA   0#2000        UNLOAD
          EJECT
** NAME - PSPB
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF SPACE BLOCK FWD/REV
*            (FUNCTION CODE X13)
*             X = 0 13 SPACE BLOCK FORWARD
*             X = 1 13 SPACE BLOCK BACKWARD
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PSPB     BSS                ENTRY
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PSPBCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PSPBCP5
          LDML   /TS/P.CURCMD+3,CTST  GET PHYSICAL FUNCTION CODE
          SHN    17-6
          PJN    PSPB10      IF 013 (FORWARD) FUNCTION
          LDC    OCREADV+CMCHN+OMRVR  ELSE 113 (REVERSE)
          UJN    PSPB20      CONT.
 PSPB10   LDC    OCREADV+CMCHN+OMRVF
 PSPB20   STML   PSPBCP3     STORE OP-CODE
          LDC    PSPBCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PSPB30   LDK    150         SECONDS LIMIT (FULL LENGTH TAPE RECORD)
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PSPB40      IF NOT SUCCESSFUL
          RJM    GBID        GET BLOCK ID AND STORE INTO BID TABLE
          LJM    CMDCOMP     GOTO COMMAND COMPLETE
 PSPB40   LDN    3           EXPECT BLOCK ID OR END OF EXTENT (TAPE MARK)
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PSPB30      IF ASYNC RESPONSE
          SPACE  4
*         -READ VERIFY-  COMMAND PACKET
 PSPBCP   DATA   0#0006      PACKET LENGTH
 PSPBCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
 PSPBCP3  CON    OCREADV+CMCHN+OMRVF   OP-CODE AND CHAIN
 PSPBCP5  DATA   0#FFFF      ADDRESSEE
          EJECT
** NAME - PSTM
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF SEARCH TAPE MARK FWD/REV
*            (FUNCTION CODE X15)
*             X = 015 SEARCH TAPE MARK FORWARD
*             X = 115 SEARCH TAPE MARK BACKWARD
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PSTM     BSS                ENTRY
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PSTMCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PSTMCP5
          LDML   /TS/P.CURCMD+3,CTST  GET PHYSICAL FUNCTION CODE
          SHN    17-6
          PJN    PSTM10      IF 015 (FORWARD) FUNCTION
          LDC    OCSPACE+CMCHN+OMSFR  ELSE 115 (BACKWARD)
          UJN    PSTM20      CONT.
 PSTM10   LDC    OCSPACE+CMCHN+OMSFF  OP-CODE FWD AND CHAIN
 PSTM20   STML   PSTMCP3     STORE OP-CODE
          LDC    PSTMCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PSTM30   LDK    150         SECONDS LIMIT (FULL LENGTH TAPE)
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PSTM40      IF NOT
          RJM    TMBID       STORE TAPE MARK BLOCK ID
          LDK    /RS/K.LDLIM  SET LOGICIAL DELIMITER STATUS CONDITION
          STML   /TS/P.SCOND,CTST
          LJM    CMDCOMP     GOTO COMMAND COMPLETE
 PSTM40   LDN    2           EXPECT END OF EXTENT (TAPE MARK)
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PSTM30      IF ASYNC RESPONSE
          SPACE  4
*         -SPACE FILE MARK-  COMMAND PACKET
 PSTMCP   DATA   0#0006      PACKET LENGTH
 PSTMCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
 PSTMCP3  CON    OCSPACE+CMCHN+OMSFF  OP-CODE AND CHAIN
 PSTMCP5  DATA   0#FFFF      ADDRESSEE
          EJECT
** NAME - PWTM
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF WRITE TAPE MARK
*            (FUNCTION CODE 051)
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PWTM     BSS                ENTRY
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PWTMCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PWTMCP5
          LDC    PWTMCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PWTM10   LDN    10          SECONDS LIMIT (INCLUDES ID RECOVERY)
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PWTM20      IF NOT
          RJM    TMBID       STORE TAPE MARK BLOCK ID
          LDK    /RS/K.LDLIM  SET LOGICIAL DELIMITER STATUS CONDITION
          STML   /TS/P.SCOND,CTST
          LJM    CMDCOMP     GOTO COMMAND COMPLETE
 PWTM20   LDN    2           EXPECT END OF EXTENT (TAPE MARK)
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PWTM10      IF ASYNC RESPONSE
          SPACE  4
*         -RECORD POSITION-  COMMAND PACKET
 PWTMCP   DATA   0#0009      PACKET LENGTH
 PWTMCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCRECP      OP-CODE AND NO CHAIN
 PWTMCP5  DATA   0#FFFF      ADDRESSEE
          CON    CPTM        TAPE MARK PARAMETER
          DATA   0#8000        FILE MARK
          EJECT
** NAME - PERS
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF ERASE TAPE
*            (FUNCTION CODE X52)
*             X = 052 - ERASE GAP
*             X = 252 - DATA SECURITY ERASE
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PERS     BSS                ENTRY
          LDML   /TS/P.CURCMD+3,CTST  GET PHYSICAL FUNCTION CODE
          SHN    17-7
          MJK    PDSE        IF 252 DATA SECURITY ERASE FUNCTION
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PERSCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PERSCP5
          LDC    PERSCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PERS10   LDN    10          SECONDS LIMIT (INCLUDES ID RECOVERY)
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          ZJK    CMDCOMP     IF YES, GOTO COMMAND COMPLETE
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PERS10      IF ASYNC RESPONSE
          SPACE  4
*         -ERASE-  COMMAND PACKET
 PERSCP   DATA   0#0006      PACKET LENGTH
 PERSCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCERASE+OMGAP  OP-CODE, NO CHAIN AND GAP ERASE
 PERSCP5  DATA   0#FFFF      ADDRESSEE
          EJECT
** NAME - PDSE
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF DATA SECURITY ERASE
*            (FUNCTION CODE 252)
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PDSE     BSS                ENTRY
          RJM    GFS         GET FACILITY STATUS ID52
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PDSECP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PDSECP5
          LDC    PDSECP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PDSE10   LDN    10          SECONDS LIMIT (INCLUDES ID RECOVERY)
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PDSE20      IF NOT
          LDN    0           CLEAR IPI RESPONSE LENGTH
          STML   RPB
          LJM    CMDCOMP     COMMAND COMPLETE
 PDSE20   LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PDSE10      IF ASYNC RESPONSE
          SPACE  4
*         -ERASE-  COMMAND PACKET
 PDSECP   DATA   0#0006      PACKET LENGTH
 PDSECP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCERASE+OMDSE  OP-CODE, NO CHAIN AND DSE
 PDSECP5  DATA   0#FFFF      ADDRESSEE
          TITLE  SUPPORT SUBROUTINES
** NAME-- SCANT
*
** PURPOSE-- SCAN TS TABLES
*
** EXIT-- A =  0 NEXT TS TABLE NOT IN USE
*         A = NZ NEXT TS TABLE IN USE
          SPACE  2
 SCANT    SUBR               ENTRY/EXIT
          RJM    SNXTAB      SELECT NEXT SLAVE TS TABLE
          LPDL   TIU         MASK WITH TS TABLES IN USE
          UJN    SCANTX      EXIT
          SPACE  5,20
** NAME-- SNXTAB
*
** PURPOSE-- SELECT NEXT SLAVE TS TABLE
*
** ENTRY-- CTST = CURRENT TS TABLE IN USE
*
** EXIT-- A = NEXT TS TABLE BIT ADDRESS
*         CTST = NEXT TS TABLE INDEX
          SPACE  2
 SNXTAB   SUBR               ENTRY/EXIT
          LDDL   CTST        GET CURRENT TS TABLE IN USE
          SBML   TS1         CHECK IF TS1 IN USE
          ZJN    SNXTAB2     IF TS2 IS NEXT
          ADK    -P.TS       CHECK IF TS2 IN USE
          ZJN    SNXTAB3     IF TS3 IS NEXT
*                            ELSE TS2 IS NEXT

 SNXTAB2  LDN    1           USE TS2 NEXT
          UJN    SNXTAB9     CONT.

 SNXTAB3  LDN    2           USE TS3 NEXT

 SNXTAB9  STDL   T1          SAVE INDEX INTO NEXT TS TABLE TO USE
          LDML   TS1,T1      GET NEXT TS TABLE ADDRESS
          STDL   CTST
          LDML   SELT,T1     USE SLAVE BIT ADDRESS TABLE
          UJN    SNXTABX     EXIT
          SPACE  2
          ERRNZ  2-MCSLV     IF NUMBER OF SLAVE TS TABLES CHANGES
          SPACE  5,20
** NAME-- SCANAS
*
** PURPOSE-- SCAN ALL SLAVES FOR A NEW LOCKABLE REQUEST
*
** EXIT-- A =  0 NO NEW REQUESTS
*         A = NZ NEW REQUEST FOUND, UNIT AND UIT REQUEST QUEUE LOCKED
*
** NOTE-- NREQSN = SLAVE NUMBER THAT HAS REQUEST ACTIVE
*         NREQFN = FACILITY NUMBER THAT HAS REQUEST ACTIVE
          SPACE  2
 SCANAS   SUBR               ENTRY/EXIT
          LDDL   SLVN        START SEARCH FROM LAST SLAVE USED
          LPN    MAXSL-1     MASK IT
          STML   NREQSN
          LDDL   FACN        START SEARCH FROM LAST FACILITY+1
          ADN    1
          LPN    FACPSL-1    MASK IT
          STML   NREQFN
          LDN    MAXSL       LOOP COUNT
          STDL   P1

 SCANAS5  LDN    0           DISABLE SCANING SLAVE IF FACILITY LOCKED
          RJM    SCANS       SCAN ALL FACILITITES ON THE SLAVE
          NJN    SCANASX     FOUND ONE, EXIT A=NZ

          SODL   P1          CHECK FOR DONE
          ZJN    SCANASX     IF YES, EXIT A=0

          AOML   NREQSN      INCREMENT TO NEXT SLAVE
          LPN    MAXSL-1     MASK IT
          STML   NREQSN

          LDN    0           START FROM FIRST FACILITY THIS TIME
          STML   NREQFN

          UJN    SCANAS5     SCAN NEXT SLAVE
          SPACE  2
          ERRNZ  8-FACPSL    IF FACILITIES PER SLAVE CHANGES
          ERRNZ  8-SLVPCH    IF SLAVES PER CHANNEL CHANGES
          SPACE  5,20
** NAME-- SCANS
*
** PURPOSE-- SCAN ALL FACILITIES ON A SLAVE FOR A ACTIVE REQUEST
*
** ENTRY--A =  0 DO NOT SCAN A SLAVE THAT HAS A FACILITY LOCKED
*         A = NZ SCAN A SLAVE THAT HAS A FACILITY LOCKED
*
** EXIT-- A =  0 NO NEW REQUESTS
*         A = NZ NEW REQUEST FOUND, UNIT AND UIT REQUEST QUEUE LOCKED
*
** USES-- T1-T6, P2-P5
*
** NOTE-- NREQSN = SLAVE NUMBER THAT HAS REQUEST ACTIVE
*         NREQFN = FACILITY NUMBER THAT HAS REQUEST ACTIVE
          SPACE  2
 SCANS0   LDN    0           EXIT, NO NEW REQUEST

 SCANS    SUBR               ENTRY/EXIT
          STML   SCANSA      SAVE ENTRY PARAMETER
          LDML   NREQSN      GET SLAVE NUMBER TO SEARCH
          SHN    2           BUILD SLAVE TABLE INDEX
          STDL   P3          P3 = SX INDEX
          LDML   SLB+/SL/P.FBA,P3  CHECK FOR ANY FACILITIES CONFIGURED
          ZJN    SCANSX      IF NONE,  EXIT A=0
          LDML   SCANSA      CHECK IF SCAN IS ENABLED FOR LOCKED FACILITY
          NJN    SCANS5      IF YES, CONTINUE
          LDML   SLB+/SL/P.FACLCK,P3  CHECK IF A FACILITY IS LOCKED
          SHN    -6
          NJN    SCANS0      IF YES, DO NOT SCAN THIS SLAVE

 SCANS5   LDDL   UX          SAVE THE ORIGINAL UX
          STDL   P5          P5 = ORIGINAL UX
          LDN    FACPSL
          STDL   P2          P2 = LOOP COUNT

 SCANS10  LDDL   P3          BUILD UNITS TABLE INDEX
          SHN    -2
          ADDL   P3
          SHN    3
          STDL   P4
          LDML   NREQFN
          SHN    2
          RADL   P4
          LDML   NREQFN
          RADL   P4          P4 = UX INDEX
          LDML   UNITS+/UN/P.LU,P4  CHECK IF FACILITY IS CONFIGURED
          ZJK    SCANS60     IF NOT
          LOADR  UNITS+/UN/P.UIT,P4  LOAD REFORMATTED R+A OF UIT
          ERRNZ  /UIT/C.DSABLE
          CRDL   T1          READ UNIT STATUS INTO T2
          ADN    /UIT/C.NEXT  OFFSET TO NEXT REQUEST RMA
          CRDL   T3          READ NEXT REQUEST RMA WORD
          LDDL   T2          CHECK IF UNIT IS DISABLED
          ERRNZ  /UIT/P.DSABLE-1
          SHN    18-16+/UIT/L.DSABLE
          MJK    SCANS60     IF UNIT IS DISABLED
          LDDL   T5          CHECK HALF 1 OF REQUEST RMA
          ADDL   T6          AND HALF 2 OF REQUEST RMA
          ZJK    SCANS60     IF NO REQUEST
          LDML   SLB+/SL/P.FACLCK,P3  CHECK IF SLAVE HAS A FACILITY LOCKED
          SHN    -6
          ZJN    SCANS20     IF NONE
          LDML   SLB+/SL/P.CURFAC,P3  CHECK IF SAME FACILITY AS SCANED
          LPN    17B
          SBML   NREQFN
          ZJK    SCANS60     IF YES

*         TRY TO LOCK UNIT AND REQUEST QUEUE THEN VERIFY ACTIVE REQUEST
 SCANS20  LDDL   P4          SET UX = P4
          STDL   UX          LOCK ROUTINES USE UX
          RJM    SULOCK      TRY TO SET UNIT LOCKWORD
          NJK    SCANS60     IF COULD NOT GET THE LOCK
          RJM    SQLOCK      TRY TO SET REQUEST QUEUE LOCKWORD
          NJK    SCANS50     IF COULD NOT GET THE LOCK
          LOADR  UNITS+/UN/P.UIT,P4  LOAD REFORMATTED R+A OF UIT
          CRDL   T1          READ UNIT STATUS INTO T2
          ADN    /UIT/C.NEXT  OFFSET TO NEXT REQUEST RMA
          CRDL   T3          READ NEXT REQUEST RMA WORD
          LDDL   T2          VERIFY IF UNIT IS DISABLED
          SHN    18-16+/UIT/L.DSABLE
          MJN    SCANS40     IF UNIT IS DISABLED
          LDDL   T5          VERIFY HALF 1 OF REQUEST RMA
          ADDL   T6          AND HALF 2 OF REQUEST RMA
          ZJK    SCANS40     IF NOT VALID LOCKED REQUEST
          LDN    1           SET FACILITY LOCKED IN SL TABLE
          SHN    6
          STML   SLB+/SL/P.FACLCK,P3
          LDML   NREQFN      SET FACILITY NUMBER LOCKED
          LPN    17B
          RAML   SLB+/SL/P.CURFAC,P3
          LDDL   P5          RESTORE ORIGINAL UX
          STDL   UX
          LDN    1
          UJK    SCANSX      EXIT WITH REQUEST FOUND AND LOCKED, A=NZ

 SCANS40  RJM    CQLOCK      UNLOCK UNIT REQUEST QUEUE LOCKWORD

 SCANS50  RJM    CULOCK      UNLOCK UNIT LOCKWORD

 SCANS60  SODL   P2          CHECK FOR DONE SEARCHING
          ZJN    SCANS70     IF YES
          LDML   NREQFN      INCREMENT FACILITY NUMBER
          ADN    1
          LPN    FACPSL-1    MASK IT
          STML   NREQFN
          UJK    SCANS10     SEARCH AGAIN

 SCANS70  LDDL   P5          RESORE ORIGINAL UX
          STDL   UX
          LDN    0
          UJK    SCANSX      EXIT A=0, NONE FOUND

 SCANSA   BSSZ   1           SAVED ENTRY PARAMETER
          SPACE  2
          ERRNZ  4-P.SL      IF SL CHANGES
          ERRNZ  5-P.UN      IF UN CHANGES
          ERRNZ  40-FACPSL*P.UN  IF UNITS TABLE CHANGES
          ERRNZ  8-FACPSL    IF FACILITIES PER SLAVE CHANGES
          SPACE  4
 NREQSN   DATA   0           NEXT REQUEST SLAVE NUMBER
 NREQFN   DATA   0           NEXT REQUEST FACILITY NUMBER
          SPACE  5,20
** NAME-- NEXTCMD
*
** PURPOSE-- GET THE NEXT COMMAND TO PROCESS
*
** ENTRY-- A = BYTE INCREMENT VALUE FOR LASTC OFFSET
*              0=FIRST COMMAND
*              8=NEXT COMMAND
          SPACE  2
 NEXTCMD  SUBR               ENTRY/EXIT
          RAML   /TS/P.LASTC,CTST  INCREMENT COMMAND OFFSET
          SHN    -1          ADJUST TO PP WORD OFFSET
          ADDL   CTST        BUILD SOURCE ADDRESS
          ADK    /TS/P.CQB
          STML   NXTCA
          LDN    0           INITIALIZE LOOP COUNTER
          STDL   T1
          LDDL   CTST        INITIALIZE DESTINATION ADDRESS INDEX
          STDL   T2

 NXTC10   LDML   *,T1        GET THE NEXT COMMAND
 NXTCA    EQU    *-1
          STML   /TS/P.CURCMD,T2  PUT INTO TS TABLE CURRENT COMMAND
          AODL   T1          CHECK FOR DONE
          SBN    4
          ZJN    NEXTCMDX    IF YES, EXIT
          AODL   T2          INCREMENT DESTINATION ADDRESS INDEX
          UJN    NXTC10      LOOP
          SPACE  5,20
** NAME-- SWITCH
*
** PURPOSE-- SWITCH PROCESSING TO OTHER TS TABLES AS REQUIRED
*
** EXIT-- RETURN TO CALLER IF NO OTHER TS TABLES IN USE,
*         ELSE PROCESS OTHER TS TABLES.
          SPACE  2
 SWITCH   SUBR               ENTRY/EXIT

          LDDL   INITFLG     CHECK FOR INITIALIZATION
          NJN    SWITCHX     IF YES, EXIT

 SWI05    LDML   TNTAB       CHECK NUMBER OF SLAVE TS TABLES SUPPORTED
          SBN    1
          ZJN    SWITCHX     IF ONLY 1, RETURN TO CALLER
          LDML   SWITCH      GET CURRENT CALLERS RETURN ADDRESS
          STML   SLB+/SL/P.SIU,SX  SAVE ADDRESS IN SLAVE IN USE FLAG
          RJM    SAVETAB     SAVE CURRENT TS TABLE DIRECT CELLS

 SWI10    RJM    SCANT       SCAN NEXT SLAVE TS TABLE
          ZJN    SWI20       IF NOT IN USE
          RJM    RELDTAB     RELOAD THIS TS TABLE DIRECT CELLS
          LDML   SLB+/SL/P.SIU,SX  GET RETURN ADDRESS
          STML   SWITCH      STORE AS EXIT ADDRESS
          UJK    SWITCHX     GO PROCESS A TS TABLE

 SWI20    LDDL   ASYNCP      CHECK IF ASYNC PROCESSING
          ADDL   PPREQF       OR PP REQUEST WAITING
          ADDL   MALREQF      OR MALET CHANNEL REQUEST WAITING
          NJN    SWI10       IF YES, BYPASS LOOKING FOR NEW REQUESTS
          RJM    SCANAS      SCAN ALL SLAVES FOR NEW REQUESTS
          ZJN    SWI10       IF NONE
          RJM    INITNR      INITIALIZE THE NEW REQUEST
          LDC    DOUR30      STARTING ADDRESS FOR NEW REQUEST
          STML   SWITCH      SIMULATE A SWITCH CALL FROM NEW REQUEST
          UJK    SWI05       SWITCH TO NEXT TS TABLE

 TNTAB    DATA   0           TOTAL SLAVE TS TABLES SUPPORTED (PLUGGED)
          SPACE  5,20
** NAME-- ERRCHK
*
** PURPOSE-- CHECK FOR ALERT MASK STATUS CONDITIONS
*
** EXIT-- A = 0 IF NO MASKABLE ERRORS
*         A =NZ IF MASKABLE ERRORS
          SPACE  2
 ERRCHK   SUBR               ENTRY/EXIT
          LDML   /TS/P.SCOND,CTST  GET CURRENT STATUS CONDITIONS
          LPML   /TS/P.RQB+/RQ/P.LONGB,CTST  MASK WITH REQUEST ALERT MASK
          ZJN    ERRCHKX     IF NONE, EXIT A=0

          RJM    PAR         PREPARE ABNORMAL RESPONSE
          LDK    /RS/K.ABALRT  SET ABNORMAL ALERT
          STML   RS+/RS/P.ABALRT
          LDML   /TS/P.SCOND,CTST  GET CONDITIONS
          LPML   /TS/P.RQB+/RQ/P.LONGB,CTST  MASK THEM AGAIN
          STML   RS+/RS/P.LNGBLK  SET MASKED ALERT CONDITIONS
          RJM    CDUNIT      CHECK FOR DOWNING UNIT
          LDN    1
          UJN    ERRCHKX     ERROR EXIT, A=NZ
          SPACE  5,20
** NAME-- IODONE
*
** PURPOSE-- PROCESS IO REQUEST DONE
*
** ENTRY-- RESPONSE ALREADY GENERATED AND CDUNIT CALLED
*          IF NEEDED.
*
** EXIT-- *MAIN* IF NO OTHER NEW REQUESTS OR THIS REQUEST
*         IS NOT CHAINED.
*         *DOUR20* IF NEW OR CHAINED REQUEST IS PROCESSABLE.
          SPACE  2
 IODONE   BSS                ENTRY ONLY
          RJM    RESP        SEND THE PREPARED RESPONSE
          RJM    CKPPRQ      CHECK FOR EXISTING OR NEW PP REQUEST
          NJN    IODONE10    IF YES
          RJM    CKCREQ      CHECK FOR EXISTING OR NEW MALET CH REQUEST
          ZJN    IODONE20    IF NOT

 IODONE10 RJM    CLREQ       CLEAR UNIT REQUEST ACTIVE
          LJM    MAIN        GO TO MAIN IDLE LOOP

*         CHECK IF UNIT IS NOW DOWN OR CHAINED REQUEST
 IODONE20 LOADR  UNITS+/UN/P.UIT,UX  LOAD REFORMATTED R+A OF UIT
          ERRNZ  /UIT/C.DSABLE
          CRDL   T1          READ UNIT STATUS INTO T2
          ADN    /UIT/C.NEXT  OFFSET TO NEXT REQUEST RMA
          CRDL   T3          READ NEXT REQUEST RMA WORD
          LDDL   T2          CHECK IF UNIT IS DISABLED
          ERRNZ  /UIT/P.DSABLE-1
          SHN    18-16+/UIT/L.DSABLE
          MJN    IODONE10    IF UNIT IS DISABLED
          LDDL   T5          CHECK HALF 1 OF REQUEST RMA
          ADDL   T6          AND HALF 2 OF REQUEST RMA
          ZJN    IODONE10    IF NO CHAINED REQUEST
          RJM    CFC         CHECK IF FACILITY STILL CHAINED
          STDL   ASYNCP      CLEAR ASYNCHRONUS PROCESSING FLAG
          LDDL   TSLVS       CHECK IF MORE THAN 1 SLAVE CONFIGURED
          SBN    1
          NJK    IODONE60    IF YES

*         CHECK FOR ACTIVE REQUESTS ON OTHER UNITS OF THIS SLAVE
 IODONE30 LDDL   SLVN        PREPARE FOR SCAN
          STML   NREQSN      SLAVE NUMBER TO SCAN
          LDDL   FACN        START SCAN FROM NEXT UNIT NUMBER
          ADN    1
          LPN    FACPSL-1    MASK IT
          STML   NREQFN      FACILITY NUMBER TO SCAN FIRST
          LDN    1           ENABLE SCAN WITH LOCKED FACILITY
          RJM    SCANS       SCAN SLAVE FOR LOCKABLE REQUESTS
          NJK    IODONE40    IF ONE FOUND, PROCESS THE OTHER REQUEST
          RJM    CLRPTS      CLEAR PARTIAL TS TABLE
          RJM    SQLOCK      TRY TO SET UIT REQUEST QUEUE LOCK AGAIN
          NJK    IODONE10    IF COULD NOT SET LOCK
*         VERIFY CHAINED REQUEST WHILE QUEUE IS LOCKED
          LOADR  UNITS+/UN/P.UIT,UX  LOAD REFORMATTED R+A OF UIT
          ERRNZ  /UIT/C.DSABLE
          CRDL   T1          READ UNIT STATUS INTO T2
          ADN    /UIT/C.NEXT  OFFSET TO NEXT REQUEST RMA
          CRDL   T3          READ NEXT REQUEST RMA WORD
          LDDL   T2          CHECK IF UNIT IS DISABLED
          ERRNZ  /UIT/P.DSABLE-1
          SHN    18-16+/UIT/L.DSABLE
          MJK    IODONE10    IF UNIT IS DISABLED
          LDDL   T5          CHECK HALF 1 OF REQUEST RMA
          ADDL   T6          AND HALF 2 OF REQUEST RMA
          ZJK    IODONE10    IF NO CHAINED REQUEST
          RJM    LDTS        LOAD CHAINED REQUEST AND UNLOCK QUEUE
          LDN    70B         SET ASYNCHRONUS PROCESSING FLAG
          STDL   ASYNCP        SO SWITCH WILL NOT START A NEW REQUEST
          RJM    SWITCH      SWITCH, IF ANY CLASS 2 INTERRUPTS WAITING
          LDN    0           CLEAR ASYNCHRONUS PROCESSING FLAG
          STDL   ASYNCP
          LDML   /TS/P.NUMCM,CTST  DECREMENT NUMBER OF COMMANDS
          SBN    2
          STML   /TS/P.NUMCM,CTST
          LDN    8           BYPASS FORMAT COMMAND
          RJM    NEXTCMD     GET NEXT COMMAND
          LJM    CMDEXEC     GO EXECUTE THE COMMAND

*         PROCESS A DIFFERENT UNIT REQUEST
 IODONE40 RJM    CULOCK      UNLOCK OLD UNIT LOCKWORD
          RJM    CLRPTS      CLEAR PARTIAL TS TABLE
          UJK    DOUR20      GO PROCESS NEW REQUEST

*         CHECK FOR REQUESTS ON OTHER SLAVES
 IODONE60 LDDL   SLVN        START SCAN FROM NEXT SLAVE NUMBER
          ADN    1
          LPN    MAXSL-1     MASK IT
          STML   NREQSN      SLAVE NUMBER TO SCAN FIRST
          LDN    0           FACILITY NUMBER TO SCAN FIRST
          STML   NREQFN
          LDN    MAXSL-1     LOOP COUNT MINUS CURRENT SLAVE
          STDL   P1          P1 = LOOP COUNTER

 IODONE70 LDN    0           DISABLE SCAN IF A FACILITY IS LOCKED
          RJM    SCANS       SCAN SLAVE FOR NEW LOCKABLE REQUEST
          ZJN    IODONE80    IF NONE FOUND
          LDML   SLB+/SL/P.FACLCK,SX  CLEAR ORIGINAL FACILITY LOCK
          LPN    17B
          STML   SLB+/SL/P.FACLCK,SX
          UJK    IODONE40    GO PROCESS NEW REQUEST

 IODONE80 SODL   P1          DECREMENT LOOP COUNT
          ZJK    IODONE30    IF ALL OTHER SLAVES SCANED
          AOML   NREQSN      INCREMENT SLAVE NUMBER
          LPN    MAXSL-1     MASK IT
          STML   NREQSN
          LDN    0
          STML   NREQFN      START SCAN FROM FACILITY 0
          UJN    IODONE70    LOOP
          ERRNZ  8-FACPSL    IF FACILITIES PER SLAVE CHANGES
          ERRNZ  8-SLVPCH    IF SLAVES PER CHANNEL CHANGES
          SPACE  5,20
** NAME-- CMDRESP
*
** PURPOSE-- COMMAND RESPONSE DECODE
*
** INPUT-- RPB HAS COMMAND RESPONSE PACKET
*          A = 0 DO NOT EXPECT BLOCK ID
*          A = 1 EXPECT BLOCK ID, IF NOT ERROR
*          A = 2 EXPECT END OF EXTENT (TAPE MARK), IF NOT ERROR
*          A = 3 EXPECT EITHER BLOCK ID OR END OF EXTENT, IF NOT ERROR
          SPACE  2
 CMDRESP  SUBR               ENTRY/EXIT
          STML   /TS/P.BIDEF,CTST  SAVE BLOCK ID EXPECTED FLAG
          LDN    0
          STDL   P1          CLEAR ERROR FLAG
          STML   /TS/P.SCOND,CTST  CLEAR ALERT CONDITIONS FLAG
          LDML   RPB+MAJST   DECODE RESPONSE TYPE
          SHN    -4
          LPN    0#F
          SBN    CC          CHECK FOR COMMAND COMPLETION
          ZJN    CMDR100     IF YES
          SBN    AR-CC       CHECK FOR ASYNCHRONUS
          ZJK    CMDR200     IF YES
          SBN    TN-AR       CHECK FOR TRANSFER NOTIFICATION
          ZJK    CMDR300     IF YES
          UJK    CMDR476     UNDEFINED RESPONSE TYPE (E76)
          SPACE  2
*         PROCESS COMMAND COMPLETION RESPONSE TYPE
 CMDR100  LDIL   CTST        COMPARE COMMAND REFERENCE NUMBERS
          LMML   RPB+CRN
          NJK    CMDR476     REPORT UNEXPECTED STATUS (E76)

          LDML   RPB+MAJST   DECODE MAJOR STATUS
          SHN    LSCS        CHECK FOR CONDITIONAL
          PJK    CMDR130     IF NOT
          LDK    ID29        SEARCH FOR FAC CONDITIONAL PARAMETER
          RJM    SFP
          PJN    CMDR110     IF FOUND
          LDK    ID19        ELSE SEARCH FOR SLAVE CONDITIONAL PARAMETER
          RJM    SFP
          PJN    CMDR110     IF FOUND
          UJK    CMDR476     REPORT UNEXPECTED STATUS (E76)

 CMDR110  LDML   RPB+6,T3    DECODE CONDITIONAL OCTETS 1 AND 2
          STDL   T1          SAVE IT
          LPC    0#7002      CHECK FOR ERRORS
          ZJN    CMDR115     IF NOT
          AODL   P1          SET ERROR FLAG

 CMDR115  LDDL   T1          CHECK FOR ON-THE-FLY CORRECTION
          LPN    0#8
          ZJN    CMDR120     IF NOT
          AOML   /TS/P.OTFC,CTST  REPORT ON-THE-FLY CORRECTION

 CMDR120  LDML   RPB+7,T3    DECODE CONDITIONAL OCTETS 3 AND 4
          SHN    -8          POSITION OCTET 3
          STDL   T1          SAVE OCTET 3
          LPN    1           CHECK FOR MASTER TERMINATED TRANSFER
          ZJN    CMDR125     IF NOT
          AODL   P1          SET ERROR FLAG

 CMDR125  LDDL   T1          GET OCTET 3
          LPN    0#10        CHECK FOR EOM WARNING (EOT)
          ZJN    CMDR130     IF NOT
          LDK    /RS/K.PDLIM  SET PHYSICAL DELIMITER IN STATUS CONDITIONS
          RAML   /TS/P.SCOND,CTST

 CMDR130  LDML   RPB+MAJST   CHECK FOR OTHER MAJOR STATUS BITS
          LPC    0#F805
          ZJK    CMDR165     IF NONE

          SHN    LSI         CHECK FOR INCOMPLETE
          PJK    CMDR160     IF NOT
          LDK    ID2A        SEARCH FOR INCOMPLETE PARAMETER
          RJM    SFP
          MJK    CMDR476     IF NOT FOUND REPORT ERROR (E76)

          LDML   RPB+7,T3    DECODE INCOMPLETE OCTETS 3 AND 4
          STDL   T1          SAVE IT
          SHN    -8          POSITION OCTET 3
          LPK    0#8C        CHECK FOR ERRORS
          ZJN    CMDR132     IF NOT
          AODL   P1          SET ERROR FLAG

 CMDR132  LDDL   T1          CHECK FOR BLOCK LENGTH DIFFERENCE
          SHN    -8          POSITION OCTET 3
          LPN    0#10        MASK IT
          ZJN    CMDR140     IF NOT SET
          LDML   RPB+OPCD    CHECK IF READ OPERATION
          SHN    -8          POSITION OP-CODE
          SBN    0#10
          ZJN    CMDR134     IF YES
          AODL   P1          SET ERROR FLAG
          UJN    CMDR140     CONT.

 CMDR134  LDK    ID32        SEARCH FOR RESPONSE EXTENT
          RJM    SFP
          MJK    CMDR476     IF PARAMETER NOT FOUND  (E76)
          LDML   RPB+6,T3    CHECK FOR SHORT OR LONG RECORD
          ADML   RPB+7,T3
          NJN    CMDR140     IF SHORT BLOCK, OK
          LDK    /RS/K.LNGBLK  SET LONG BLOCK IN STATUS CONDITIONS
          RAML   /TS/P.SCOND,CTST

 CMDR140  LDDL   T1          GET OCTET 3 AND 4
          SHN    17-14       CHECK FOR EOM WARNING (EOT)
          PJN    CMDR150     IF NOT
          LDK    /RS/K.PDLIM  SET PHYSICAL DELIMITER IN STATUS CONDITIONS
          RAML   /TS/P.SCOND,CTST

 CMDR150  LDDL   T1          GET OCTETS 3 AND 4
          SHN    17-13       CHECK FOR END OF EXTENT (TM) DETECTED
          PJN    CMDR160     IF NOT
          LDK    /RS/K.LDLIM  SET LOGICIAL DELIMITER IN STATUS CONDITIONS
          RAML   /TS/P.SCOND,CTST

 CMDR160  LDML   RPB+MAJST   CHECK FOR OTHER STATUS BITS
          LPC    0#F800
          ZJN    CMDR162     IF NOT
          AODL   P1          SET ERROR FLAG

 CMDR162  LDML   RPB+MAJST   CHECK FOR COMMAND ABORT
          LPN    1
          ZJN    CMDR165     IF NOT
          AOML   /TS/P.CHAIN,CTST  SET COMMAND CHAINING ABORT FLAG

 CMDR165  LDDL   P1          CHECK IF ERROR FLAG IS SET
          NJK    CMDR400     IF YES, BYPASS TM OR BID
          LDML   /TS/P.BIDEF,CTST  CHECK FOR BID OR TM EXPECTED
          ZJK    CMDR195     IF NOT GOTO COMMAND COMPLETE
          SBN    1           CHECK FOR BID EXPECTED
          ZJN    CMDR170     IF YES
          SBN    1           CHECK FOR END OF EXTENT (TM) EXPECTED
          ZJN    CMDR180     IF YES

          LDML   /TS/P.SCOND,CTST  ELSE EITHER
          SHN    17-12
          MJK    CMDR190     IF END OF EXTENT FOUND

 CMDR170  LDK    IDD0        SEARCH FOR BLOCK ID PARAMETER
          RJM    SFP
          MJK    CMDR478     IF NOT FOUND REPORT ERROR (E78)
          RJM    GBID        PUT BLOCK ID INTO TABLE
          UJN    CMDR195     GOTO COMMAND COMPLETE

 CMDR180  LDML   /TS/P.SCOND,CTST  CHECK FOR END OF EXTENT DETECTED
          SHN    17-12
          MJK    CMDR190     IF YES
*         CHECK FOR X15 OR 051 ATS PHYSICAL FUNCTIONS
          LDML   /TS/P.CURCMD+3,CTST
          LPN    77B         MASK MAJOR FUNCTION CODE BITS
          SBN    F.STM       CHECK FOR SEARCH TAPE MARK (X15)
          ZJN    CMDR185     IF YES
          SBN    F.WTM-F.STM  CHECK FOR WRITE TAPE MARK (X15)
          NJK    CMDR490     IF NOT, REPORT ERROR (E90)

 CMDR185  LDK    /RS/K.LDLIM  SET LOGICIAL DELIMITER IN STATUS CONDITIONS
          RAML   /TS/P.SCOND,CTST

 CMDR190  RJM    TMBID       SET END OF EXTENT IN BLOCK ID TABLE

 CMDR195  LDDL   P1          CHECK IF ERROR FLAG IS SET
          NJN    CMDR400     IF YES
          LJM    CMDCOMP     ELSE,  GOTO COMMAND COMPLETE
          SPACE  4
*         PROCESSING ASYNCHRONUS RESPONSE TYPE
 CMDR200  BSS
          LDML   RPB+SLAD    CHECK FOR FACILITY ASYNC RESPONSE
          LPDL   FF
          LMDL   FF
          NJK    CMDRESPX    IF YES, RETURN TO CALLER
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDK    R.UNS       CHANGE TO UNSOLICITED
          STML   RS+/RS/P.RC
          LDN    0           SET LOGICIAL UNIT NUMBER = 0
          STML   RS+/RS/P.LU
          RJM    RESP        SEND RESPONSE
          UJK    CMDRESPX    NOW RETURN TO CALLER
          SPACE  4
*         PROCESS TRANSFER NOTIFICATION RESPONSE TYPE
 CMDR300  UJN    CMDR476     REPORT UNEXPECTED STATUS (E76)
          SPACE  4
*         ERROR CODES
 CMDR400  LDN    E00         CPU MUST DETERMINE
          UJN    CMDR500

 CMDR476  LDK    E76         UNEXPECTED STATUS
          UJN    CMDR500

 CMDR478  LDDL   P1          CHECK IF ERROR FLAG IS SET
          NJN    CMDR400     IF YES
          LDK    E78         ELSE, NO BLOCK ID RETURNED
          UJN    CMDR500

 CMDR490  LDDL   P1          CHECK IF ERROR FLAG IS SET
          NJN    CMDR400     IF YES
          LDK    E90         ELSE, NO END OF EXTENT STATUS

 CMDR500  RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDML   /TS/P.SCOND,CTST  GET CURRENT STATUS CONDITIONS
          LPML   /TS/P.RQB+/RQ/P.LONGB,CTST  MASK WITH REQUEST ALERT MASK
          ZJN    CMDR510     IF NONE ACTIVE

          STML   RS+/RS/P.LNGBLK  SET MASKED CONDITIONS

          LDK    /RS/K.ABALRT  SET ABNORMAL ALERT BIT
          STML   RS+/RS/P.ABALRT

 CMDR510  LDDL   P1          CHECK IF ERROR FLAG IS SET
          ZJN    CMDR520     IF NOT
          LDML   RS+/RS/P.ERRID  CHECK IF ERROR ID IS NONZERO
          NJN    CMDR520     IF YES

          LDK    /RS/K.HDWR  SET HARDWARE MALFUNCTION BIT
          RAML   RS+/RS/P.ABALRT

 CMDR520  RJM    CMDTERM     COMMAND TERMINATE  (NO RETURN)
          SPACE  5,20
** NAME-- ATTRIB
*
** PURPOSE-- SEND ATTRIBUTE COMMAND TO SLAVE
*
** INPUT-- (/TS/P.ECSEL,CTST) =
*              0 DO NOTHING
*              1 ERROR CORRECTION ENABLED
*              2 ERROR CORRECTION DISABLED
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 ATT1     LDML   /TS/P.SATTR,CTST  RESTORE RETURN ADDRESS
          STML   ATTRIB

 ATTRIB   SUBR               ENTRY/EXIT
          LDML   ATTRIB      SAVE RETURN ADDRESS
          STML   /TS/P.SATTR,CTST
          LDML   /TS/P.ECSEL,CTST  CHECK FOR SELECTION
          ZJN    ATTRIBX     IF NOT DEFINED EXIT
          SBN    1
          ZJN    ATT10       IF ERROR CORRECTION ENABLED
          LDC    0#8000      DISABLE ERROR CORRECTION PARAM
          UJN    ATT20       CONT.
 ATT10    LDC    0#C000      ENABLE ERROR CORRECTION PARAM
 ATT20    STML   ATTCP9      STORE PARAMETER
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   ATTCP1
          LDML   /TS/P.SN,CTST  GET SLAVE ADDRESS
          SHN    -8
          SHN    8
          ADDL   FF          NO FACILITY ADDRESS
          STML   ATTCP5
          LDC    ATTCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 ATT30    LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          ZJK    ATT1        IF YES, EXIT
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    ATT30       IF ASYNC RESPONSE
          SPACE  4
*         -ATTRIBUTES-  COMMAND PACKET
 ATTCP    DATA   0#0025      PACKET LENGTH
 ATTCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCATT+OMAL  OP-CODE, LOAD AND NO CHAINING
 ATTCP5   DATA   0#FFFF      ADDRESSEE (NO FACILITY)
          CON    CPSRB       SLAVE RECONFIGURATION BIT PARAMETER
 ATTCP9   DATA   0#FF00        C000=EC ENABLED, 8000=EC DISABLED
          CON    CPSRF       SLAVE RECONFIGURATION FIELD PARAMETER
          DATA   0,0,0,0       OCTETS 01-08
          DATA   0,0,0,0              09-10
 ATTCP1D  CON    BURST                11-12 GENERATE CLASS 2 INTERRUPTS
          DATA   0                    13-14
 ATTCP21  CON    BURST                15-16 DATA BURST SIZE
          CON    CPBID       ENABLE/DISABLE BID PARAMETER
          DATA   0#8000        BID ENABLED
          SPACE  5,20
** NAME-- OPMODE
*
** PURPOSE-- SEND OPMODE COMMAND TO SLAVE/FACILITY
*
** INPUT-- (/TS/P.DENSEL,CTST) =
*              0 DO NOTHING
*              1 SELECT 1600 (PE) OPERATION
*              2 SELECT 6250 (GCR) OPERATION
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 OPM1     LDML   /TS/P.SOPMO,CTST  RESTORE RETURN ADDRESS
          STML   OPMODE

 OPMODE   SUBR               ENTRY/EXIT
          LDML   OPMODE      SAVE RETURN ADDRESS
          STML   /TS/P.SOPMO,CTST
          LDML   /TS/P.DENSEL,CTST  CHECK FOR SELECTION
          ZJN    OPMODEX     IF NOT DEFINED EXIT
          SBN    1
          ZJN    OPM10       IF 1600 (PE)
          LDC    0#030C      SET 6250 (GCR) PARAMETERS
          STML   OPMCP13
          LDC    0#186A
          STML   OPMCP15
          UJN    OPM20       CONT.
 OPM10    LDC    0#0607      SET 1600 (PE) PARAMETERS
          STML   OPMCP13
          LDC    0#0640
          STML   OPMCP15
 OPM20    AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   OPMCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   OPMCP5
          LDC    OPMCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 OPM30    LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK IF COMMAND COMPLETE SUCCESSFUL
          ZJK    OPM1        IF YES, EXIT
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    OPM30       IF ASYNC RESPONSE
          SPACE  4
*         -OPERATING MODE-  COMMAND PACKET
 OPMCP    DATA   0#0016      PACKET LENGTH
 OPMCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCOM+CMCHN+OMOMS  OP-CODE, CHAIN AND SET
 OPMCP5   DATA   0#FFFF      ADDRESSEE
          CON    CPTMB       TAPE MODE BIT PARAMETER
          DATA   0#0000
          DATA   0#0100        DISABLE COMPRESSION
          CON    CPTMF       TAPE MODE FIELD PARAMETER
          DATA   0#0000
          DATA   0#0000
 OPMCP13  DATA   0#FFFF        PE=0607, GCR=030C
 OPMCP15  DATA   0#FFFF        PE=0640, GCR=186A
          SPACE  5,20
** NAME-- GBID
*
** PURPOSE-- GET BLOCK ID FROM RESPONSE PACKET
*            AND STORE INTO CURRENT TS BIDB BUFFER.
          SPACE  2
 GBID     SUBR               ENTRY/EXIT
          LDK    IDD0        FIND BLOCK ID PARAMETER IN RESPONSE PACKET
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    GBID10      IF NOT FOUND
          LDK    /TS/P.BIDB  BUILD DESTINATION ADDRESS
          ADDL   CTST        CURRENT TS TABLE BASE ADDRESS
          ADML   /TS/P.BIDBP,CTST  BLOCK ID BUFFER POINTER
          STML   GBIDA       SET DESTINATION ADDRESS
          LDML   RPB+6,T3    GET BLOCK ID VALUE
          SHN    3           POSITION IT LIKE ATS BID
          STML   *           PUT INTO BLOCK ID BUFFER
 GBIDA    EQU    *-1
          AOML   /TS/P.BIDBP,CTST  INCREMENT POINTER
          UJN    GBIDX       EXIT

 GBID10   RJM    PAR         PREPARE ABNORMAL RESPONSE
          LDK    E78         NO BLOCK ID PARAMETER RETURNED
          STML   RS+/RS/P.ERRID
          RJM    CMDTERM     TERMINATE COMMAND (NO RETURN)
          SPACE  5,10
** NAME-- CFC
*
** PURPOSE-- CHECK FOR CHAINING STILL ACTIVE
*
** EXIT-- A = 0
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 CFC      SUBR               ENTRY/EXIT
          LDML   /TS/P.CHAIN,CTST  GET CHAIN FLAG
          ZJN    CFCX        IF NOT ACTIVE EXIT
          STDL   ASYNCP      SET ASYNCHRONOUS PROCESSING FLAG
          LDML   CFC         SAVE RETURN ADDRESS
          STML   /TS/P.SCFC,CTST
          RJM    LIR         LOGICIAL INTERFACE RESET TO CLEAR CHAINING
          LDML   /TS/P.SCFC,CTST  RESTORE RETURN ADDRESS
          STML   CFC
          LDN    0           CLEAR RESPONSE PACKET LENGTH
          STML   RPB
          UJN    CFCX        EXIT
          SPACE  5,20
** NAME-- TMBID
*
** PURPOSE-- SET TAPE MARK BLOCK ID INTO BLOCK ID BUFFER.
          SPACE  2
 TMBID    SUBR               ENTRY/EXIT
          LDK    /TS/P.BIDB  BUILD DESTINATION ADDRESS
          ADDL   CTST        CURRENT TS TABLE BASE ADDRESS
          ADML   /TS/P.BIDBP,CTST  BLOCK ID BUFFER POINTER
          STML   TMBIDA      SET DESTINATION ADDRESS
          LDN    0#01        TAPE MARK IDENTIFIER
          STML   *           PUT INTO BLOCK ID BUFFER
 TMBIDA   EQU    *-1
          AOML   /TS/P.BIDBP,CTST  INCREMENT POINTER
          UJN    TMBIDX      EXIT
          SPACE  5,20
** NAME-- GFS
*
** PURPOSE-- GET FACILITY STATUS ID52 FOR RESPONSE.
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 GFS1     LDML   /TS/P.SGFS,CTST  RESTORE RETURN ADDRESS
          STML   GFS

 GFS      SUBR               ENTRY/EXIT
          LDML   /TS/P.FACSTA,CTST  CHECK IF ALREADY SET
          NJN    GFSX        IF YES
          LDML   GFS         SAVE RETURN ADDRESS
          STML   /TS/P.SGFS,CTST
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   GFSCP1
          LDML   /TS/P.SN,CTST  ADDRESSEE
          STML   GFSCP5
          SHN    -8          BUILD SLAVE PARAMETER
          SHN    8
          ADDL   FF
          STML   GFSCP9
          LDC    GFSCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER

 GFS10    LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR SUCCESSFUL
          ZJN    GFS20       IF YES
          LDN    0           DO NOT EXPECT BID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    GFS10       IF ASYNC RESPONSE

 GFS20    LDK    ID52        LOCATE PARAM 52
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    GFS30       IF NOT FOUND
          LDML   RPB+5,T3    SAVE PARAMETERS IN TS TABLE
          STML   /TS/P.FACSTA,CTST
          LDML   RPB+6,T3
          STML   /TS/P.FACSTA+1,CTST
          LDN    0           CLEAR RESPONSE PACKET LENGTH
          STML   RPB
          UJK    GFS1        EXIT

 GFS30    LDK    E76         REPORT UNEXPECTED STATUS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE (NO RETURN)
          SPACE  2,10
*         -REPORT ADDRESSEE STATUS-  COMMAND PACKET
 GFSCP    DATA   0#000B      PACKET LENGTH
 GFSCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCRAS+OMRASC  OP-CODE AND CONDITION
 GFSCP5   DATA   0#FFFF      ADDRESSEE
          CON    CPPM        PORT MASK PARAMETER
 GFSCP9   DATA   0#00FF        SLAVE ADDRESS
          DATA   0#0100        PORT MASK
          SPACE  5,20
** NAME-- RSEL
*
** PURPOSE-- READ SLAVE ERROR LOG TO PREVENT IT
*            FROM OVERFLOWING.
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 RSEL1    LDML   /TS/P.SRSEL,CTST  RESTORE RETURN ADDRESS
          STML   RSEL

 RSEL     SUBR               ENTRY/EXIT
          LDML   RSEL        SAVE RETURN ADDRESS
          STML   /TS/P.SRSEL,CTST
          LDML   RELCP3      CLEAR CHAINING COMMON MODIFIER
          LPC    0#FF0F
          STML   RELCP3
          LDML   /TS/P.SN,CTST  GET SLAVE ADDRESS
          SHN    -8
          SHN    8
          ADDL   FF          NO FACILITY ADDRESS
          STML   RELCP5
          RJM    REL         READ THE SLAVE ERROR LOG
          UJN    RSEL1       EXIT
          SPACE  4,15
** NAME-- RFEL
*
** PURPOSE-- READ FACILITY ERROR LOG TO PREVENT IT
*            FROM OVERFLOWING.
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 RFEL1    LDML   /TS/P.SRFEL,CTST  RESTORE RETURN ADDRESS
          STML   RFEL

 RFEL     SUBR               ENTRY/EXIT
          LDML   RFEL        SAVE RETURN ADDRESS
          STML   /TS/P.SRFEL,CTST
          LDML   RELCP3      SET CHAINING COMMON MODIFIER
          LPC    0#FF0F
          ADN    CMCHN
          STML   RELCP3
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   RELCP5
          RJM    REL         READ THE FACILITY ERROR LOG
          UJN    RFEL1       EXIT
          SPACE  5,20
** NAME-- NSI
*
** PURPOSE-- NON-STOP INITIALIZATION FOR READ OR OUTPUT 8-BIT DATA COMMANDS.
*
** INPUT-- (/TS/P.NSCA,CTST) HAS CURRENT PP COMMAND ADDRESS TO SET UP.
*
** OUTPUT-- (/TS/P.ILSTL,CTST) HAS NUMBER OF INDIRECT LENGTH/ADDRESS PAIRS
*           (/TS/P.ILSTA,CTST) HAS RMA (UNFORMATTED) OF INDIRECT LEN/ADD PAIR
*           (/TS/P.ILSTP,CTST) HAS INDIRECT LENGTH/ADDRESS PAIR
*           (/TS/P.NSCRN,CTST) HAS UPDATED NON-STOP CMD REFERENCE NUMBER
*           ((/TS/P.RTCB,CTST)+(/TS/P.RTCIP,CTST)) REC XFER COUNT CLEARED
*
** NOTE-- IF THE COMMAND DOES NOT HAVE THE INDIRECT ADDRESS BIT SET, THE
*         COMMAND LENGTH/ADDRESS IS MOVED INTO (/TS/P.ILSTP,CTST) AND
*         (/TS/P.ILSTL,CTST) IS SET TO 1. (/TS/P.ILSTA,CTST) IS NOT SET.
          SPACE  2
 NSI10    AODL   P4          INCREMENT PP ADDRESS
          LDIL   P4          GET NUMBER OF PAIRS
          SHN    -3
          STML   /TS/P.ILSTL,CTST
          AODL   P4          INCREMENT PP ADDRESS
          LDIL   P4          SET RMA OF FIRST PAIR
          STML   /TS/P.ILSTA,CTST
          AODL   P4
          LDIL   P4
          STML   /TS/P.ILSTA+1,CTST
          LDK    /TS/P.ILSTP  BUILD CRML PP ADDRESS
          ADDL   CTST
          STML   NSIA
          LOADF  /TS/P.ILSTA,CTST  SET R+A OF FIRST PAIR
          CRML   *,ONE       READ THE FIRST INDIRECT LEN/ADD PAIR
 NSIA     EQU    *-1

 NSI20    LDN    8           INCREMENT TO NEXT NON-STOP COMMAND ADDRESS
          RAML   /TS/P.NSCA,CTST


 NSI      SUBR               ENTRY/EXIT


          LDK    /TS/P.RTCB  BUILD CURRENT REC XFER COUNT ADDRESS
          ADDL   CTST
          ADML   /TS/P.RTCIP,CTST  INCREMENT WITH IN POINTER
          STML   NSIB        SAVE IT (UPPER HALF)
          ADN    1           BUILD LOWER HALF ADDRESS
          STML   NSIC
          LDN    0           CLEAR CURRENT REC XFER COUNTER
          STML   *           UPPER HALF
 NSIB     EQU    *-1
          STML   *           LOWER HALF
 NSIC     EQU    *-1

          AOML   /TS/P.NSCRN,CTST  UPDATE NON-STOP COMMAND REFERENCE NUMBER
          LDML   /TS/P.NSCA,CTST  GET NON-STOP COMMAND PP ADDRESS
          STDL   P4          SAVE IT
          LDIL   P4          GET COMMAND
          SHN    17-6        CHECK FOR INDIRECT BIT
          MJK    NSI10       IF YES

*         ELSE PROCESS DIRECT
          LDN    1           SET NUMBER OF PAIRS
          STML   /TS/P.ILSTL,CTST
          AODL   P4          INCREMENT PP ADDRESS
          LDIL   P4          GET LENGTH/ADDRESS
          STML   /TS/P.ILSTP+1,CTST
          AODL   P4
          LDIL   P4
          STML   /TS/P.ILSTP+2,CTST
          AODL   P4
          LDIL   P4
          STML   /TS/P.ILSTP+3,CTST
          UJK    NSI20       EXIT
          SPACE  5,20
** NAME-- URECTC
*
** PURPOSE-- UPDATE RECORD TRANSFER COUNT
*
** INPUT-- (/TS/P.CBURBC,CTST) = CURRENT BURST BYTE COUNT
*          (/TS/P.RESBC,CTST)  = RESIDUAL BYTE COUNT
*          (/TS/P.SLVEES,CTST) = SLAVE ENCODED ENDING STATUS
*          (/TS/P.RTCIP,CTST)  = REC XFER COUNT BUFFER IN POINTER
*
** OUTPUT--(/TS/P.RTCB,CTST)+IN POINTER=UPDATED BY ACTUAL TRANSFER COUNT
*           A = 0  ALL DATA TRANSFERED
*               NZ RESIDUAL BYTE COUNT
          SPACE  2
 URECTC   SUBR               ENTRY/EXIT
          LDML   /TS/P.CBURBC,CTST  GET CURRENT BURST BYTE COUNT
          SBML   /TS/P.RESBC,CTST  DECREMENT BY RESIDUAL BYTE COUNT
          STDL   T1          SAVE IT
          LDML   /TS/P.SLVEES,CTST  CHECK FOR ODD OR EVEN TRANSFER
          LPN    0#F
          LMN    0#F
          NJN    URECTC2     IF EVEN TRANSFER
          SODL   T1          DECREMENT COUNT BY 1 ON ODD TRANSFERS

 URECTC2  LDK    /TS/P.RTCB  BUILD REC XFER COUNTER BUFFER ADDRESS
          ADDL   CTST
          ADML   /TS/P.RTCIP,CTST  ADJUST WITH IN POINTER
          STML   URECTCA     SAVE UPPER HALF ADDRESS
          ADN    1
          STML   URECTCB     SAVE LOWER HALF ADDRESS

          LDDL   T1          GET CURRENT TRANSFER COUNT
          RAML   *           UPDATE LOWER HALF
 URECTCB  EQU    *-1
          SHN    -16         ADJUST FOR CARRY BIT
          RAML   *           UPDATE UPPER HALF
 URECTCA  EQU    *-1

          LDML   /TS/P.RESBC,CTST  (A) = RESIDUAL BYTE COUNT
          UJN    URECTCX     EXIT
          SPACE  5,20
** NAME-- UREQTC
*
** PURPOSE-- UPDATE REQUEST TRANSFER COUNT
*
** INPUT-- (/TS/P.RTCB,CTST)+OUT POINTER = THIS RECORD XFER COUNT
*
** OUTPUT--(/TS/P.XFER,CTST) UPDATED BY RECORD TRANSFER COUNT
          SPACE  2
 UREQTC   SUBR               ENTRY/EXIT

          LDK    /TS/P.RTCB  BUILD RECORD XFER COUNT BUFFER ADDRESS
          ADDL   CTST
          ADML   /TS/P.RTCOP,CTST  ADJUST WITH OUT POINTER
          STML   UREQTCB     SAVE UPPER HALF ADDRESS
          ADN    1
          STML   UREQTCA     SAVE LOWER HALF ADDRESS

          LDML   *           GET RECORD XFER COUNT LOWER
 UREQTCA  EQU    *-1
          RAML   /TS/P.XFER+1,CTST  UPDATE REQUEST XFER COUNT LOWER
          SHN    -16         ADJUST FOR CARRY BIT
          ADML   *           ADD RECORD XFER COUNT UPPER
 UREQTCB  EQU    *-1
          RAML   /TS/P.XFER,CTST  UPDATE REQUEST XFER COUNT UPPER

          LDML   /TS/P.RTCOP,CTST  INCREMENT OUT POINTER
          ADN    2
          LPN    7
          STML   /TS/P.RTCOP,CTST

          UJN    UREQTCX     EXIT
          SPACE  5,30
** NAME-- GETNP
*
** PURPOSE-- GET NEXT LENGTH/ADDRESS PAIR
*
** INPUT-- (/TS/P.PARLAP,CTST) = PARTIAL L/A PAIR FLAG
*
** OUTPUT--(/TS/P.ILSTL,CTST) INDIRECT L/A PAIR LENGTH DECREMENTED
*          (/TS/P.ILSTA,CTST) INDIRECT L/A PAIR RMA UPDATED
*          (/TS/P.ILSTP,CTST) NEW INDIRECT L/A PAIR
*           A =  0 NO MORE L/A PAIRS
*               NZ VALID L/A PAIR
          SPACE  2
 GETNP    SUBR               ENTRY/EXIT
          LDML   /TS/P.PARLAP,CTST  CHECK FOR PARTIAL L/A PAIR
          NJN    GETNP10     IF YES
          SOML   /TS/P.ILSTL,CTST  DECREMENT NUMBER OF L/A PAIRS
          ZJN    GETNPX      EXIT IF NONE LEFT
          LDN    8           UPDATE L/A PAIR (UNFORMATTED) RMA
          RAML   /TS/P.ILSTA+1,CTST
          SHN    -16
          RAML   /TS/P.ILSTA,CTST
          LDK    /TS/P.ILSTP  BUILD CRML PP ADDRESS
          ADDL   CTST
          STML   GETNPA
          LOADF  /TS/P.ILSTA,CTST  SET R+A OF NEXT PAIR
          CRML   *,ONE       GET THE NEXT L/A PAIR
 GETNPA   EQU    *-1
          LDN    1           SET A = NZ
          UJN    GETNPX      EXIT

*         PROCESS PARTIAL L/A PAIR STILL ACTIVE
 GETNP10  STDL   T1          SAVE BYTES ALREADY USED FROM THIS PAIR
          LDML   /TS/P.ILSTP+1,CTST  DECREMENT L/A PAIR DATA LENGTH
          SBDL   T1
          STML   /TS/P.ILSTP+1,CTST
          LDDL   T1          INCREMENT L/A PAIR DATA (UNFORMATTED) RMA
          RAML   /TS/P.ILSTP+3,CTST
          SHN    -16
          RAML   /TS/P.ILSTP+2,CTST
          LDN    2           SET A = NZ
          UJK    GETNPX      EXIT
          SPACE  5,20
** NAME-- WSTN
*
** PURPOSE-- WAIT FOR SPECIAL TRANSFER NOTIFICATION
*
** NOTE -- THE SLAVE ONLY GENERATES A CLASS 2 RESPONSE
*          PACKET ON THE FIRST TRANSFER NOTIFICATION.
*
*          IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*          ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
*
** EXIT -- A =  0  SPECIAL CLASS 2 INTERRUPT ACTIVE
*            = NZ  CLASS 1 OR 3 INTERRUPT ACTIVE
*          WSTNF IS SET WITH (A) ON EXIT
          SPACE  2
 WSTN1    STML   /TS/P.WSTNF,CTST  SET WSTN FLAG WITH EXIT VALUE

 WSTN     SUBR               ENTRY/EXIT
          LDN    10          SECONDS LIMITS (INCLUDES ID RECOVERY)
          STML   /TS/P.SECLIM,CTST
          RJM    UC          UPDATE THE TIME CLOCK
          LDDL   CLSEC       SET CURRENT TIME IN SECONDS
          STML   /TS/P.CLK,CTST
          LDML   WSTN        SAVE RETURN ADDRESS
          STML   /TS/P.SWSTN,CTST

 WSTN10   RJM    SWITCH      SWITCH TO OTHER TS TABLES
          LDML   /TS/P.SWSTN,CTST  RESTORE RETURN ADDRESS
          STML   WSTN
          LDN    2           REQUEST CLASS 2 INTERRUPT
          RJM    RI          REQUEST INTERRUPTS
          ZJN    WSTN15      IF NOT
          LDN    0
          UJN    WSTN1       EXIT A = 0

 WSTN15   LDN    5           REQUEST CLASS 1 OR 3 INTERRUPTS
          RJM    RI          REQUEST INTERRUPTS
          ZJN    WSTN20      IF NONE ACTIVE
          LDN    1
          UJK    WSTN1       CLASS 1 OR 3 ACTIVE, EXIT A = NZ

 WSTN20   RJM    UC          UPDATE THE TIME CLOCK
          LDDL   CLSEC       GET CURRENT SECONDS
          SBML   /TS/P.CLK,CTST  ELAPSED SECONDS
          PJN    WSTN30      IF CLOCK HAS NOT WRAPPED
          ADK    0#10000

 WSTN30   SBML   /TS/P.SECLIM,CTST  CHECK IF TIME LIMIT EXPIRED
          MJK    WSTN10      IF NOT
          LDK    E38         NO SLAVE INTERRUPT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- SPLOCK
*
** PURPOSE-- SETS THE PP REQUEST QUEUE LOCK IN THE
*            PP INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                     NZ, IF LOCK WAS NOT SET.
          SPACE  2
 SPLOCK   SUBR               ENTRY/EXIT
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDK    /PIT/C.LOCK OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET THE LOCKWORD
          UJK    SPLOCKX
          SPACE  5,15
** NAME-- CPLOCK
*
** PURPOSE-- CLEARS THE PP REQUEST QUEUE LOCK IN THE
*            PP INTERFACE TABLE.
          SPACE  2
 CPLOCK   SUBR               ENTRY/EXIT
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDK    /PIT/C.LOCK OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CPLOCKX
          SPACE  5,15
** NAME-- SULOCK
*
** PURPOSE-- SETS UNIT LOCKWORD IN UNIT INTERFACE TABLE
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                     NZ, IF LOCK WAS NOT SET.
          SPACE  2
 SULOCK   SUBR               ENTRY/EXIT
          LDK    UNITS+/UN/P.UIT  BUILD ADDRESS OF UIT
          ADDL   UX          INCREMENT BY THE INDEX
          STDL   T7          CURRENT UNIT INTERFACE TABLE ADDRESS
          LDK    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          UJK    SULOCKX
          SPACE  5,15
** NAME-- CULOCK
*
** PURPOSE-- CLEARS UNIT LOCKWORD IN UNIT INTERFACE TABLE.
          SPACE  2
 CULOCK   SUBR               ENTRY/EXIT
          LDK    UNITS+/UN/P.UIT  BUILD ADDRESS OF UIT
          ADDL   UX          INCREMENT BY THE INDEX
          STDL   T7          CURRENT UNIT INTERFACE TABLE ADDRESS
          LDK    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CULOCKX
          SPACE  5,15
** NAME-- SQLOCK
*
** PURPOSE-- SETS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                     NZ, IF LOCK WAS NOT SET.
          SPACE  2
 SQLOCK   SUBR               ENTRY/EXIT
          LDK    UNITS+/UN/P.UIT  BUILD ADDRESS OF UIT
          ADDL   UX          INCREMENT BY THE INDEX
          STDL   T7          CURRENT UNIT INTERFACE TABLE ADDRESS
          LDK    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          UJK    SQLOCKX
          SPACE  5,15
** NAME-- CQLOCK
*
** PURPOSE-- CLEARS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
          SPACE  2
 CQLOCK   SUBR               ENTRY/EXIT
          LDK    UNITS+/UN/P.UIT  BUILD ADDRESS OF UIT
          ADDL   UX          INCREMENT BY THE INDEX
          STDL   T7          CURRENT UNIT INTERFACE TABLE ADDRESS
          LDK    /UIT/C.QLOCK OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CQLOCKX
          SPACE  5,15
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
*
** NOTE-- THIS ROUTINE WILL ONLY RETURN WHEN THE CHANNEL LOCK IS OBTAINED.
          SPACE  2
 SCLOCK   SUBR               ENTRY/EXIT

 SCL10    BSS
          LDK    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CURCH       CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    SCL10       IF LOCK WAS NOT SET
          STDL   CLF         CHANNEL LOCK FLAG = LOCKED NOW
          UJK    SCLOCKX     EXIT, LOCK WAS SET
          SPACE  5,15
** NAME-- CCLOCK
*
** PURPOSE-- CLEARS CHANNEL LOCK.
          SPACE  2
 CCLOCK   SUBR               ENTRY/EXIT
          LDDL   CLF         CHECK IF CHANNEL IS LOCKED
          NJN    CCLOCKX     IF NOT RETURN
          LDK    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          STDL   CLF         CHANNEL LOCK FLAG = NOT LOCKED
          LDDL   CURCH       CHANNEL NUMBER = OFFSET IN TABLE
          STDL   T5
          RJM    CLOCK       CLEAR CHANNEL LOCKWORD
          UJK    CCLOCKX     EXIT
          SPACE  5,30
** NAME-- LOCK
*
** PURPOSE-- SET A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS SET.
*         A REGISTER .NE. O, IF THE LOCK COULD NOT BE SET.
*
** USES-- T1-T7
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T1 = 0, WRITE THE PP LOCKWORD TO CENTRAL MEMORY,
*            AS DESCRIBED IN THIS STEP.  ELSE IF T1 .NE. 0, GO TO
*            STEP 4.
*            TO WRITE THE PP LOCKWORD ID:
*            SET T1 - T4 = 8000 0000 0000 PPNO, WHERE PPNO IS THE
*            LOGICAL PP NUMBER OF THIS PP.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
*
*         4. IF T1 = 8000 AND T4 = PPNO, THIS LOCKWORD WAS ALREADY
*            RESERVED TO THIS PP.
*            RESTORE THE CENTRAL MEMORY LOCATION  (CWDL   T1).
*            SET THE A REGISTER = 0, AND EXIT.
*
*         5. IF T4 .NE. PPNO, THEN THIS LOCKWORD IS RESERVED TO
*            A DIFFERENT PROCESSOR.
*            SET BIT 16 OF THE LOCKWORD THAT WAS READ WITH THE
*            RDSL INSTRUCTION, AND WRITE THE CONTENTS BACK TO
*            CENTRAL MEMORY.
*            THE PURPOSE OF SETTING BIT 16 IS TO REQUEST THE
*            OTHER PROCESSOR TO GIVE UP THE LOCKWORD.
*            LDDL   T2
*            LPC    77777B
*            ADC    100000B
*            STDL   T2
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
          SPACE  4
 LOCK     SUBR               ENTRY/EXIT

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 LOCK10   BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.

          LDDL   T1
          ADDL   T4
          ZJN    LOCK40      IF LOCK CAN BE SET

* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJK    LOCK10      IF THIS PP WAS NOT FIRST TO WRITE
*                            THE INTERMEDIATE VALUE, REPEAT RDSL INSTRUCTION

* SET BIT 16 IN THE ORIGINAL CONTENTS OF CENTRAL MEMORY AND
* WRITE IT BACK TO CENTRAL MEMORY.

          LDDL   T2          SET THE 'REQUEST LOCKWORD' FLAG
          LPC    77777B
          ADC    100000B
          STDL   T2
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE LOCKWORD

          LDDL   T4
          SBDL   PPNO        CHECK IF LOCK ALREADY SET
          NJN    LOCK30      IF LOCK COULD NOT BE SET, EXIT A .NE. 0
          LDDL   T1
          ADC    -100000B
 LOCK30   UJK    LOCKX       IF LOCK WAS ALREADY SET, EXIT A = 0
                             IF LOCK COULD NOT BE SET, EXIT A .NE. 0

* SET THE LOCKWORD.

 LOCK40   BSS
          LDC    100000B
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          LDDL   PPNO
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          SET THE LOCKWORD
          LDN    0
          UJK    LOCK30      EXIT, A REGISTER = 0
          SPACE  5,20
** NAME-- CLOCK
*
** PURPOSE-- CLEAR A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS CLEARED.
*         A REGISTER .NE. O, IF THE LOCK WAS NOT CLEARED.
*
** USES-- T1-T7
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T4 .NE. PPNO, THIS LOCKWORD IS RESERVED TO A
*            DIFFERENT PROCESSOR.
*            RESTORE THE CONTENTS OF THIS CENTRAL MEMORY LOCATION
*            AS IT EXISTED BEFORE THE VALUE FFFF FFFF XXXX XXXX
*            WAS WRITTEN.
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
*
*         4. IF T4 = PPNO, THEN CLEAR THE LOCKWORD IN CENTRAL MEMORY.
*            SET T1 - T4 = 0000 0000 0000 0000.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
          SPACE  4
 CLOCK    SUBR               ENTRY/EXIT

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 CLK10    BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.
* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJK    CLK10       IF THIS PP WAS NOT FIRST TO WRITE
*                            THE INTERMEDIATE VALUE, REPEAT RSDL INSTRUCTION

          LDDL   T4          CHECK PP NUMBER
          SBDL   PPNO
          ZJN    CLK30       IF THIS PP HAS THE LOCK SET

* RESTORE THE ORIGINAL CONTENTS.

          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE ORIGINAL CONTENTS
          LDN    1
 CLK20    UJK    CLOCKX      EXIT, A REGISTER NONZERO

* CLEAR THE LOCKWORD.

 CLK30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          CLEAR THE LOCKWORD
          LDN    0
          UJK    CLK20       EXIT, A REGISTER = 0
          SPACE  5,20
** NAME-- SWFAIL
*
** PURPOSE-- REPORT A SOFTWARE FAILURE AND TERMINATE A REQUEST.
*
** ENTRY-- A REGISTER HAS INTERFACE ERROR CODE
*
** EXIT-- TO MAIN IDLE LOOP.
          SPACE  2
 SWFAIL   BSSZ   1           ENTRY ONLY  NO RETURN
          STDL   T7          SAVE ERRID VALUE
          LDN    0           NO IPI STATUS IN RESPONSE
          STML   RPB
          RJM    PAR         PREPARE ABNORMAL RESPONSE
          LDDL   T7
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LDK    /RS/K.INTERR  INTERFACE ERROR
          STML   RS+/RS/P.INTERR
          LDK    E120        SOFTWARE FAILURE
          STML   RS+/RS/P.ERRID
          RJM    CMDTERM     COMMAND TERMINATE  (NO RETURN)
          SPACE  5,20
** NAME-- SETSX
*
** PURPOSE-- SET SLAVE TABLE INDEX
*
** INPUT--SLVN CONTAINS CURRENT SLAVE ADDRESS
*          0X = PORT A  SLAVE X
*
** OUTPUT-- SX SET
*           A = FACILITIES CONFIGURED ON THIS SLAVE
          SPACE  3
 SETSX    SUBR               ENTRY/EXIT
          LDDL   SLVN        GET SLAVE NUMBER
          SHN    2           POSITION IT
          STDL   SX          SET IT
          LDML   SLB+/SL/P.FBA,SX  GET CONFIGURED FACILITIES ON THIS SLAVE
          UJK    SETSXX      EXIT
          SPACE  2
          ERRNZ  4-P.SL      IF SL CHANGES
          SPACE  5,20
** NAME-- SETUX
*
** PURPOSE-- SET UNITS TABLE INDEX
*
** INPUT--FACN CONTAINS CURRENT FACILITY ADDRESS
*         SX MUST ALREADY BE SET
*
** OUTPUT--UX SET
*          A = LOGICIAL UNIT NUMBER
          SPACE  2
 SETUX    SUBR               ENTRY/EXIT
          LDDL   SX          START WITH SLAVE OFFSET
          SHN    -2
          ADDL   SX
          SHN    3           REPOSITION IT
          STDL   UX
          LDDL   FACN        GET FACILITY NUMBER
          SHN    2           POSITION IT
          RADL   UX          SAVE IT
          LDDL   FACN
          RADL   UX          MERGE FINAL
          LDML   UNITS+/UN/P.LU,UX  GET LOGICIAL UNIT NUMBER
          UJK    SETUXX      EXIT
          SPACE  2
          ERRNZ  5-P.UN      IF UN CHANGES
          ERRNZ  40-FACPSL*P.UN  IF MAX FACILITIES PER SLAVE IS NOT 8
          SPACE  5,20
** NAME-- INITNR
*
** PURPOSE-- INITIALIZE NEW UNIT REQUEST
*
** INPUT--NREQSN = NEW SLAVE NUMBER
*         NREQFN = NEW FACILITY NUMBER
*         CTST   = NEW TS TABLE INDEX
          SPACE  2
 INITNR   SUBR               ENTRY/EXIT
          LDN    0           CLEAR ASYNCHRONUS PROCESSING FLAG
          STDL   ASYNCP
          STML   RPB         CLEAR IPI RESPONSE PACKET BUFFER
          LDML   NREQSN      INIT SLVN
          STDL   SLVN
          RJM    SETSX       INIT SX INDEX
          LDML   NREQFN      INIT FACN
          STDL   FACN
          RJM    SETUX       INIT UX INDEX
          LDC    UNITS+/UN/P.UIT  BUILD POINTER TO UIT REFORMATTED RMA
          ADDL   UX
          STDL   T7          T7 = POINTER TO UIT RMA
          RJM    LDTS        LOAD REQUEST AND UNLOCK IT
          LDDL   CTST        CHECK WHICH TS TO USE
          SBML   TS2
          NJN    INITNR1     IF NOT TS2
          LDDL   TIU         SET TS2 BIT IN TS TABLES IN USE
          LPN    75B
          ADN    2
          UJN    INITNR9     CONT.
 INITNR1  BSS
          LDDL   TIU         SET TS3 BIT IN TS TABLES IN USE
          LPN    73B
          ADN    4
 INITNR9  BSS
          STDL   TIU         SAVE UPDATED TS TABLES IN USE
          RJM    INTS        INIT TS TABLE
          UJK    INITNRX     EXIT
          SPACE  5,20
** NAME-- CLREQ
*
** PURPOSE-- CLEAR THE CURRENT REQUEST FROM THE ACTIVE TS TABLE
*            AND UNLOCK UNIT LOCKWORD.
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 CLREQ1   LDML   /TS/P.SCLREQ,CTST  RESTORE RETURN ADDRESS
          STML   CLREQ
          RJM    CLRTS       CLEAR TS TABLE

 CLREQ    SUBR               ENTRY/EXIT
          LDML   CLREQ       SAVE RETURN ADDRESS
          STML   /TS/P.SCLREQ,CTST
          LDDL   CTST        CLR TS TABLE IN USE BIT
          SBML   TS1
          ZJN    CLREQ10     IF PP TABLE IN USE
          ADK    -P.TS
          ZJN    CLREQ20     IF TS2 IN USE
          UJN    CLREQ30     IF TS3 IN USE
 CLREQ10  BSS
          LDN    0
          STDL   TIU         CLEAR ALL TS TABLES IN USE
          STDL   ASYNCP      CLEAR ASYNCHRONUS PROCESSING FLAG
          UJN    CLREQ1      EXIT
 CLREQ20  BSS
          RJM    CFC         CHECK FOR CHAINING STILL
          LDDL   TIU         CLEAR TS2 IN USE
          LPN    75B
          UJN    CLREQ90     CONT.
 CLREQ30  BSS
          RJM    CFC         CHECK FOR CHAINING STILL
          LDDL   TIU         CLEAR TS3 IN USE
          LPN    73B
 CLREQ90  BSS
          STDL   TIU         RESTORE TIU
          RJM    CULOCK      UNLOCK UNIT LOCKWORD IN UIT
          LDN    0
          STDL   ASYNCP      CLEAR ASYNCHRONUS PROCESSING FLAG
          STML   RPB         CLR ACTIVE IPI RESPONSE LENGTH
          STML   SLB+/SL/P.SIU,SX  CLR SLAVE IN USE FLAG
          LDML   SLB+/SL/P.FACLCK,SX  CLEAR FACILITY LOCKED FLAG
          LPN    77B
          STML   SLB+/SL/P.FACLCK,SX
          UJK    CLREQ1      EXIT
          SPACE  2
          ERRNZ  2-MCSLV     IF NUMBER OF CONCURRENT SLAVE TS TABLES CHANGE
          SPACE  5,20
** NAME-- SAVETAB
*
** PURPOSE-- SAVE THE CURRENT TS TABLE FOR USE LATER
*
** INPUT--CTST = CURRENT TS TABLE IN USE
          SPACE  2
 SAVETAB  SUBR               ENTRY/EXIT
          LDK    /TS/P.SAVEDC  BUILD DESTINATAION ADDRESS
          ADDL   CTST
          STML   SAVTA
          LDN    0           INIT LOOP COUNTER
          STDL   T1

 SAVT10   LDML   SAVEFWA,T1  GET DIRECT CELL TO SAVE
          STML   *,T1        SAVE IT
 SAVTA    EQU    *-1
          AODL   T1
          SBN    SAVELWA+1-SAVEFWA  CHECK FOR DONE
          NJN    SAVT10      IF NOT, LOOP
          UJN    SAVETABX    ELSE EXIT
          SPACE  5,20
** NAME-- RELDTAB
*
** PURPOSE-- RELOAD A SAVED TS TABLE FOR USE NOW
*
** INPUT--CTST = TS TABLE TO RELOAD
          SPACE  2
 RELDTAB  SUBR               ENTRY/EXIT
          LDK    /TS/P.SAVEDC  BUILD SOURCE ADDRESS
          ADDL   CTST
          STML   RELDTA
          LDN    0           INIT LOOP COUNTER
          STDL   T1

 RELDT10  LDML   *,T1        GET SAVED DIRECT CELL
 RELDTA   EQU    *-1
          STML   SAVEFWA,T1  PUT IT BACK IN DIRECT CELL
          AODL   T1          CHECK FOR DONE
          SBN    SAVELWA+1-SAVEFWA
          NJN    RELDT10     IF NOT, LOOP
          UJN    RELDTABX    ELSE, EXIT
          SPACE  5,20
** NAME-- INTS
*
** PURPOSE-- INITIALIZE TS TABLE
*
** INPUT-- CTST,SLVN AND FACN INITIALIZED
*
          SPACE  2
 INTS     SUBR               ENTRY/EXIT
          LDDL   SLVN        SET SLAVE NUMBER
          SHN    8
          STML   /TS/P.SN,CTST
          LDDL   FACN        SET FACILITY NUMBER
          RAML   /TS/P.FN,CTST
          UJK    INTSX       EXIT
          SPACE  5,20
** NAME-- CLRTS
*
** PURPOSE-- CLEAR THE SELECTED TS TABLE
*
** INPUT-- CTST INITIALIZED
          SPACE  2
 CLRTS    SUBR               ENTRY/EXIT
          LDK    /TS/P.SAVEDC  NUMBER OF WORDS TO CLEAR
          STDL   T1
          LDDL   CTST        TS TABLE FWA
          STDL   T2

 CLRTS10  LDN    0           CLEAR TS TABLE ENTRY
          STIL   T2
          AODL   T2          INCREMENT ADDRESS
          SODL   T1          DECREMENT COUNTER
          NJN    CLRTS10     LOOP IF NOT DONE
          STML   /TS/P.RQB+/RQ/P.LU,CTST  CLEAR LOGICIAL UNIT NUMBER
          UJN    CLRTSX      EXIT
          SPACE  5,20
** NAME-- CLRPTS
*
** PURPOSE-- CLEAR PARTIAL TS TABLE
*
** INPUT-- CTST INITIALIZED
          SPACE  2
 CLRPTS   SUBR               ENTRY/EXIT
          LDN    0           CLEAR SELECTED TS TABLE ENTRIES
          STIL   CTST
          STML   /TS/P.LASTC,CTST
          STML   /TS/P.XFER,CTST
          STML   /TS/P.XFER+1,CTST
          STML   /TS/P.SCOND,CTST
          STML   /TS/P.FACSTA,CTST
          STML   /TS/P.NSWC,CTST
          STML   /TS/P.NSRC,CTST
          STML   /TS/P.OTFC,CTST
          STML   /TS/P.BIDBP,CTST
          STML   /TS/P.RTCIP,CTST
          STML   /TS/P.RTCOP,CTST
          UJN    CLRPTSX     EXIT
          SPACE  5,20
** NAME-- LDTS
*
** PURPOSE-- LOAD TS TABLE WITH CURRENT REQUEST, INITIALIZE TS TABLE
*            ENTRIES AND UPDATE PIT/UIT NEXT PVA-RMA AND UNLOCK QUEUE.
*
** INPUT--T7 = ADDRESS OF REFORMATTED CM ADDRESS OF EITHER PIT OR UIT.
*
          SPACE  2
 LDTS     SUBR               ENTRY/EXIT
*         GET THE PVA/RMA OF THE REQUEST
          LDDL   CTST        BUILD CRML ADDRESS
          ADK    /TS/P.CPVACM
          STML   LDTSA
          LOADR  0,T7        LOAD R AND A OF PIT OR UIT
          ADK    /PIT/C.PPQPVA  OFFSET TO REQUEST PVA/RMA
          CRML   *,TWO       READ THE PVA/RMA OF THE QUEUED REQUEST
                             INTO SELECTED TS TABLE LOCATION CPVACM
 LDTSA    EQU    *-1
*         GET THE REQUEST HEADER
          LDDL   CTST        BUILD CRML/CWML ADDRESSES
          ADK    /TS/P.RQB
          STML   LDTSB
          STML   LDTSC
          ADK    /TS/P.CQB-/TS/P.RQB  ANOTHER CRML ADDRESS
          STML   LDTSD
          LDK    /RQ/C.SECADR+1  LENGTH OF REQUEST HEADER
          STDL   WC
          LOADF  /TS/P.CREQ,CTST  LOAD R AND A OF REQUEST
          CRML   *,WC        READ THE REQUEST HEADER
                             INTO SELECTED TS TABLE LOCATIONS RQB
 LDTSB    EQU    *-1
*         UPDATE THE NEXT PVA/RMA
          LOADR  0,T7        LOAD R AND A OF PIT OR UIT
          ADK    /PIT/C.PPQPVA  OFFSET TO NEXT PVA/RMA
          CWML   *,TWO       RESET TO NEXT PVA/RMA IN PIT OR UIT
 LDTSC    EQU    *-1
*         CLEAR THE UIT/PIT QUEUE LOCKWORD
          LDK    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE PIT/UIT LOCKWORD
*         GET THE REQUEST COMMANDS
          LDML   /TS/P.RQB+/RQ/P.LEN,CTST  REQUEST LENGTH IN BYTES
          SHN    -3          TO CM WORDS
          SBN    /RQ/C.SECADR+1  DECREMENT BY HEADER LENGTH
          ZJN    *           IF NO COMMANDS
          STML   /TS/P.NUMCM,CTST  SAVE NUMBER OF COMMANDS
          STDL   WC
          LOADF  /TS/P.CREQ,CTST  LOAD R AND A OF REQUEST
          ADK    /RQ/C.SECADR+1  OFFSET TO COMMANDS
          CRML   *,WC        READ COMMANDS
                             INTO SELECTED TS TABLE LOCATIONS CQB
 LDTSD    EQU    *-1
          UJK    LDTSX       EXIT
          SPACE  5,20
** NAME-- PTW
*
** PURPOSE-- PATH TEST WRITING
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 PTW1     LDML   /TS/P.SPTW,CTST  RESTORE RETURN ADDRESS
          STML   PTW

 PTW      SUBR               ENTRY/EXIT
          LDML   PTW         SAVE RETURN ADDRESS
          STML   /TS/P.SPTW,CTST
          RJM    GDP         GENERATE DATA PATTERN
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PTWCP1
          LDDL   SLVN        BUILD ADDRESSEE
          SHN    8
          ADDL   FF          NO FACILITY ADDRESS
          STML   PTWCP5
          LDN    0           USE BUFFER 0 FIRST
          STML   PTWCPD
          RJM    PTWOD       OUTPUT TO FIRST DATA BUFFER
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PTWCP1
          LDN    1           USE BUFFER 1 NOW
          STML   PTWCPD
          RJM    PTWOD       OUTPUT TO SECOND DATA BUFFER
          UJK    PTW1        EXIT OK
          SPACE  5,20
*         -WRITE TO BUFFER-  COMMAND PACKET
 PTWCP    DATA   0#0014      PACKET LENGTH
 PTWCP1   DATA   0#FFFF      CMD REFERENCE NUMBER
          CON    OCWTB+CMCHN  OP-CODE AND CHAIN
 PTWCP5   DATA   0#00FF      ADDRESSEE
          CON    CPBCE       CMD EXTENT PARAM
          DATA   0#0000       COUNT
          DATA   0#1020       COUNT = 4128(DEC) BYTES
 PTWCPD   DATA   0#0000       DATA ADDRESS = BUFFER 0
          DATA   0#0000       DATA ADDRESS = 0
          CON    CPBA        BUFFER ADDRESS PARAM
          DATA   0#8020       GENERIC, SLAVE DATA BUFFER
          SPACE  5,20
** NAME-- PTWOD
*
** PURPOSE-- PATH TEST WRITE OUTPUT DATA
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 PTWO1    LDML   /TS/P.SPTWOD,CTST  RESTORE RETURN ADDRESS
          STML   PTWOD

 PTWOD    SUBR               ENTRY/EXIT
          LDML   PTWOD       SAVE RETURN ADDRESS
          STML   /TS/P.SPTWOD,CTST
          LDC    PTWCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PTWO10   LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16       CHECK FOR TRANSFER NOTIFICATION
          ZJN    PTWO20      IF YES
          LDML   RPB+MAJST   CHECK FOR ASYNC
          SHN    -4
          LPN    0#F
          LMK    AR
          ZJN    PTWO10      IF YES
          UJK    PTWO50      ELSE REPORT ERROR (E00)
 PTWO20   LDIL   CTST        CHECK IF CMD REFERENCE NUMBERS AGREE
          LMML   RPB+CRN
          NJK    PTWO60      IF NOT, REPORT ERROR (E76)
          RJM    SEL         SELECT SLAVE
          LDN    DATAOUT     BUS A FOR DATA OUT
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0381       STREAM, WRITE
          RJM    FUNC
          LDC    4128/2      SET WORD COUNT
          STDL   WC
          LDML   CM.CB.T+1   BUILD SPECIAL INDIRECT LIST PAIR
          STML   /TS/P.ILSTP+2,CTST
          LDML   CM.CB.T+2
          STML   /TS/P.ILSTP+3,CTST
          RJM    DDO         DMA DATA OUTPUT
          RJM    WFTC        WAIT FOR TRANSFER COMPLETE
          LDN    EVENOT      EVEN OCTET MASTER ENCODED ENDING STATUS
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT SLAVE
          UJN    PTWO90      CONTINUE

 PTWO50   LDN    E00         CP MUST DETERMINE ERROR
          UJN    PTWO80

 PTWO60   LDK    E76         UNEXPECTED RESPONSE

 PTWO80   RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)

 PTWO90   LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR SUCCESSFUL
          ZJK    PTWO1       IF YES, EXIT OK
          LDML   RPB+MAJST   CHECK FOR ASYNC
          SHN    -4
          LPN    0#F
          LMK    AR
          ZJN    PTWO90      IF YES
          UJN    PTWO50      ELSE REPORT ERROR (E00)
          SPACE  5,20
** NAME-- PTR
*
** PURPOSE-- PATH TEST READING
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 PTR1     LDML   /TS/P.SPTR,CTST  RESTORE RETURN ADDRESS
          STML   PTR

 PTR      SUBR               ENTRY/EXIT
          LDML   PTR         SAVE RETURN ADDRESS
          STML   /TS/P.SPTR,CTST
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PTRCP1
          LDC    OCRFB+CMCHN  OP-CODE AND CHAIN
          STML   PTRCP3
          LDDL   SLVN        BUILD ADDRESSEE
          SHN    8
          ADDL   FF          NO FACILITY
          STML   PTRCP5
          LDN    0           USE BUFFER 0 FIRST
          STML   PTRCPD
          RJM    PTRID       INPUT FIRST BUFFER
          RJM    VDP         VERIFY DATA PATTERN
          NJN    PTR10       IF DATA ERROR
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PTRCP1
          LDC    OCRFB       OP-CODE AND END OF CHAIN
          STML   PTRCP3
          LDN    1           USE BUFFER 1
          STML   PTRCPD
          RJM    PTRID       INPUT SECOND BUFFER
          RJM    VDP         VERIFY DATA PATTERN
          ZJK    PTR1        IF OK, EXIT
 PTR10    LDK    E110        MASTER-SLAVE DATA INTEGRITY ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING  (NO RETURN)
          SPACE  5,12
*         -READ FROM BUFFER-  COMMAND PACKET
 PTRCP    DATA   0#0014      PACKET LENGTH
 PTRCP1   DATA   0#FFFF      CMD REFERENCE NUMBER
 PTRCP3   CON    OCRFB+CMCHN  OP-CODE AND CHAIN
 PTRCP5   DATA   0#00FF      ADDRESSEE
          CON    CPBCE       CMD EXTENT PARAM
          DATA   0#0000       COUNT
          DATA   0#1020       COUNT = 4128(DEC) BYTES
 PTRCPD   DATA   0#0000       DATA ADDRESS = BUFFER 0
          DATA   0#0000       DATA ADDRESS = 0
          CON    CPBA        BUFFER ADDRESS PARAM
          DATA   0#8020       GENERIC, SLAVE DATA BUFFER
          SPACE  5,20
** NAME-- PTRID
*
** PURPOSE-- PATH TEST READ INPUT DATA
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 PTRI1    LDML   /TS/P.SPTRID,CTST  RESTORE RETURN ADDRESS
          STML   PTRID

 PTRID    SUBR               ENTRY/EXIT
          LDML   PTRID       SAVE RETURN ADDRESS
          STML   /TS/P.SPTRID,CTST
          LDC    PTRCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PTRI10   LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16       CHECK FOR TRANSFER NOTIFICATION
          ZJN    PTRI20      IF YES
          LDML   RPB+MAJST   CHECK FOR ASYNC
          SHN    -4
          LPN    0#F
          LMK    AR
          ZJN    PTRI10      IF YES
          UJK    PTRI50      ELSE, REPORT ERROR (E00)
 PTRI20   LDIL   CTST        COMPARE COMMAND REFERENCE NUMBERS
          LMML   RPB+CRN
          NJK    PTRI60      IF NOT THE SAME
          RJM    SEL         SELECT SLAVE
          LDN    DATAIN      BUS A FOR DATA IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0281       STREAM AND READ
          RJM    FUNC
          LDC    4128/2      SET WORD COUNT
          STDL   WC
          LDML   CM.CB.T+1   BUILD SPECIAL INDIRECT LIST PAIR
          STML   /TS/P.ILSTP+2,CTST
          LDML   CM.CB.T+2
          STML   /TS/P.ILSTP+3,CTST
          RJM    DDI         DMA DATA INPUT
          RJM    WFTC        WAIT FOR TRANSFER COMPLETE
          LDN    EVENOT      USE EVEN OCTET MASTER ENCODED ENDING STATUS
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT SLAVE
          LDDL   STATUS      CHECK SLAVE ENCODED ENDING STATUS
          LPN    0#F
          NJN    PTRI80      IF NOT EVEN
          UJN    PTRI100     CONTINUE
 PTRI50   LDN    E00         CP MUST DETERMINE ERROR
          UJN    PTRI90
 PTRI60   LDK    E76         UNEXPECTED STATUS
          UJN    PTRI90
 PTRI80   LDN    E40         SLAVE ENCODED ENDING STATUS ERROR
 PTRI90   RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING  (NO RETURN)

 PTRI100  LDN    1           SECONDS LIMIT
          RJM    IH          GET COMMAND COMPLETION
          LMN    CCS         CHECK FOR SUCCESSFUL
          ZJK    PTRI1       IF YES, EXIT
          LDML   RPB+MAJST   CHECK FOR ASYNC
          SHN    -4
          LPN    0#F
          LMK    AR
          ZJN    PTRI100     IF YES
          UJN    PTRI50      ELSE, REPORT ERROR (E00)
          SPACE  5,20
** NAME-- GDP
*
** PURPOSE-- GENERATE DATA PATTERN IN CM PP COMMUNICATIONS BUFFER
*
** USES-- T1-T4 = DATA
*         T8 = COUNTER
*         P5 = RMA OFFSET
          SPACE  2
 GDP      SUBR               ENTRY/EXIT
          LDK    /CB/C.PTD   INITIALIZE OFFSET TO PATH TEST DATA AREA
          STDL   P5
          LDK    516         CM WORD COUNT = 4128 DEC. BYTES
          STDL   T8

* BUILD CM DATA PATTERN IN T1-T4 = FFFF 0000 AAAA 5555
          LCN    0           FFFF
          STDL   T1
          LDN    0           0000
          STDL   T2
          LDC    0#AAAA      AAAA
          STDL   T3
          SHN    -1          5555
          STDL   T4

* STORE DATA PATTERN IN CM
 GDP10    LOADC  CM.COM      LOAD R+A OF COMMUNICATIONS BUFFER
          ADDL   P5          INCLUDE OFFSET TO TEST DATA AREA
          CWDL   T1          WRITE THE PATTERN
          AODL   P5          INCREMENT THE OFFSET
          SODL   T8          CHECK FOR DONE
          NJN    GDP10       IF NOT LOOP

          UJK    GDPX        EXIT
          SPACE  5,20
** NAME-- VDP
*
** PURPOSE-- VERIFY DATA PATTERN
*
** EXIT-- A = 0  NO ERROR
*             NZ DATA MISCOMPARE ERROR
*
** USES-- T1-T4 = DATA
*         T5-T7 = EXPECTED VALUES
*         T8 = COUNTER
*         P5 = RMA OFFSET
          SPACE  2
 VDP      SUBR               ENTRY/EXIT
          LDK    /CB/C.PTD   INITIALIZE OFFSET TO PATH TEST DATA
          STDL   P5
          LDK    516         CM WORD COUNT = 4128 BYTES
          STDL   T8

* INITIALIZE EXPECTED VALUES
          LCN    0           FFFF
          STDL   T5
*                            0000 CHECKED DIRECTLY
          LDC    0#AAAA      AAAA
          STDL   T6
          SHN    -1          5555
          STDL   T7

* GET A CM WORD
 VDP10    LOADC  CM.COM      LOAD R+A OF COMMUNICATIONS BUFFER
          ADDL   P5          INCLUDE OFFSET
          CRDL   T1          READ THE CM WORD
          AODL   P5          INCREMENT RMA OFFSET

* CHECK THE DATA PATTERN
          LDDL   T1          FFFF
          LMDL   T5
          NJN    VDP20       IF ERROR
          LDDL   T2          0000
          NJN    VDP20       IF ERROR
          LDDL   T3          AAAA
          LMDL   T6
          NJN    VDP20       IF ERROR
          LDDL   T4          5555
          LMDL   T7
          NJN    VDP20

          SODL   T8          CHECK FOR DONE
          NJN    VDP10       IF NOT LOOP

 VDP20    UJK    VDPX        EXIT A=0 OK, NZ=ERROR
          SPACE  5,20
** NAME-- RERESP
*
** PURPOSE-- PROCESS RESUME RESPONSE
*
          SPACE  2
 RERESP   SUBR               ENTRY/EXIT
          LDN    0           NO IPI STATUS IN RESPONSE
          STML   RPB
          RJM    PNR         PREPARE NORMAL RESPONSE
          RJM    RESP        SEND RESPONSE
          UJN    RERESPX     EXIT
          SPACE  4,20
** NAME-- PNR
*
** PURPOSE-- PREPARE NORMAL RESPONSE
          SPACE  2
 PNR      SUBR               ENTRY/EXIT
          RJM    BBR         BUILD BASIC RESPONSE
          RJM    MVBID       MOVE BLOCK ID BUFFER TO RESPONSE
          LDK    R.NRM       NORMAL RESPONSE
          STML   RS+/RS/P.RC
          UJK    PNRX        EXIT
          SPACE  4,20
** NAME-- PAR
*
** PURPOSE-- PREPARE ABNORMAL RESPONSE
          SPACE  2
 PAR      SUBR               ENTRY/EXIT
          RJM    BBR         BUILD BASIC RESPONSE
          RJM    MVBID       MOVE BLOCK ID BUFFER TO RESPONSE
          LDK    R.ABN       ABNORMAL RESPONSE
          STML   RS+/RS/P.RC
          UJK    PARX        EXIT
          SPACE  4,10
** NAME-- PUR
*
** PURPOSE-- PREPARE UNSOLICITED RESPONSE
          SPACE  2
 PUR      SUBR               ENTRY/EXIT
          RJM    BBR         BUILD BASIC RESPONSE
          LDK    R.UNS       UNSOLICITED RESPONSE CODE
          STML   RS+/RS/P.RC
          UJK    PURX        EXIT
          SPACE  5,30
** NAME-- BBR
*
** PURPOSE-- BUILD BASIC RESPONSE

 BBR      SUBR               ENTRY/EXIT
          LDN    C.RS-/RS/C.ABALRT  ZERO OUT MOST OF RESPONSE BUFFER
          STDL   T5          NUMBER OF CM ZERO WORDS TO USE
          LOADC  CM.COM      USE PP COMMUNICIATIONS BUFFER
          ADN    /CB/C.ZEROES  START FORM CLEARED AREA
          CRML   RS+/RS/P.ABALRT,T5  CLEAR FROM C.ABALRT TO THE END

          LDML   /TS/P.CPVA,CTST   PVA OF REQUEST
          STML   RS+/RS/P.PVA
          LDML   /TS/P.CPVA+1,CTST
          STML   RS+/RS/P.PVA+1
          LDML   /TS/P.CPVA+2,CTST
          STML   RS+/RS/P.PVA+2

          LDML   /TS/P.CREQ,CTST  RMA OF REQUEST
          STML   RS+/RS/P.REQ
          LDML   /TS/P.CREQ+1,CTST
          STML   RS+/RS/P.REQ+1

          LDK    NRL         NORMAL RESPONSE LENGTH IN BYTES
          STML   RS+/RS/P.RESPL
          LDML   RPB         CHECK IF IPI RESPONSE IS TO BE INCLUDED
          LPC    377B        INSURE VALID LENGTH
          ZJN    BBR10       IF NOT
          ADN    9           INCREMENT FOR PACKET LENGTH BYTES AND
*                            TO ROUND UP TO CM WORD BOUNDARY
          LPK    -7
          RAML   RS+/RS/P.RESPL  INCREMENT RESPONSE LENGTH
 BBR10    LDML   /TS/P.RQB+/RQ/P.LU,CTST  LOGICIAL UNIT NUMBER
          STML   RS+/RS/P.LU

          LDML   /TS/P.RQB+/RQ/P.RECOV,CTST  R/I AND PRIORITY
          STML   RS+/RS/P.RECOV

          LDML   /TS/P.RQB+/RQ/P.LONGB,CTST   ALERT MASK
          STML   RS+/RS/P.LONGB

          LDML   /TS/P.XFER,CTST   BYTES TRANSFERRED
          STML   RS+/RS/P.XFER
          LDML   /TS/P.XFER+1,CTST
          STML   RS+/RS/P.XFER+1

          LDML   /TS/P.CREQ,CTST  CHECK IF A REQUEST IS LOADED
          ADML   /TS/P.CREQ+1,CTST
          ZJK    BBRX        IF NOT BYPASS LAST CMD RMA
          LDML   /TS/P.CREQ+1,CTST  BUILD RMA OF LAST COMMAND
          ADN    B.RQ        OFFSET TO FIRST COMMAND
          ADML   /TS/P.LASTC,CTST
          STML   RS+/RS/P.LASTC+1  2ND HALF RMA
          SHN    -16
          ADML   /TS/P.CREQ,CTST
          STML   RS+/RS/P.LASTC    1ST HALF RMA

          LDML   /TS/P.FACSTA,CTST  MOVE FACILITY STATUS ID52, IF ANY
          ZJK    BBRX        IF NONE, EXIT
          STML   RS+/RS/P.FACSTA
          LDML   /TS/P.FACSTA+1,CTST
          STML   RS+/RS/P.FACSTA+1

          UJK    BBRX        EXIT
* ENSURE THAT THE NUMBER OF ZERO BYTES IN THE PP COMMUNICATION BUFFER
* IS ENOUGH TO CLEAR THE RESPONSE BUFFER.
          ERRNG  /CB/B.ZEROES-B.RS+/RS/P.ABALRT*2
          SPACE  5,30
** NAME-- MVBID
*
** PURPOSE-- MOVE BLOCK ID FROM TS TABLE TO RESPONSE BUFFER.
*
          SPACE  4
 MVBID    SUBR               ENTRY/EXIT
          LDML   /TS/P.BIDBP,CTST  GET THE POINTER
          ZJN    MVBIDX      IF NONE TO MOVE
          STML   RS+/RS/P.IOR+MBID+1  PUT POINTER IN RESPONSE
          STDL   T1          COUNT TO MOVE
          LDML   /TS/P.OTFC,CTST  GET ON-THE-FLY CORRECTION COUNT
          STML   RS+/RS/P.IOR+MBID  PUT IN RESPONSE
          LDK    /TS/P.BIDB  BUILD SOURCE ADDRESS
          ADDL   CTST
          STDL   T2          T2 HAS SOURCE ADDRESS
          LDK    RS+/RS/P.IOR
          STDL   T3          T3 IS DESTINATION ADDRESS

 MVBID10  LDIL   T2          GET BLOCK ID ENTRY
          STIL   T3          PUT IT INTO RESPONSE
          SODL   T1          DECREMENT COUNT
          ZJN    MVBIDX      IF DONE EXIT
          AODL   T2          INCREMENT SOURCE ADDRESS
          AODL   T3          INCREMENT DESTINATION ADDRESS
          UJN    MVBID10     LOOP
          SPACE  2
          ERRNZ  30-MBID     IF MAX NUMBER OF BLOCK ID CHANGE
          SPACE  5,30
** NAME-- RESP
*
** PURPOSE-- WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
*
** INPUT-- CM.PIT, CM.RS, LIM, /PIT/IN, /PIT/OUT, RS+/RS/P.RESPL
*
** OUTPUT-- /PIT/IN, RESPONSE BUFFER
          SPACE  2
 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  2
 RESP     SUBR               ENTRY/EXIT

* READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RESP10   LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADK    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ  OUT  POINTER INTO P5
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF  IN  POINTER
          CRDL   P1          READ  IN  POINTER INTO P4

* CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDDL   INP
          SBDL   OUTP
          MJN    RESP20      IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP

 RESP20   LDML   RS+/RS/P.RESPL  GET RESPONSE LENGTH
          STDL   T1
          LDN    0
          STDL   T2          FLAG TO DETERMINE IF 1 OR 2 BLOCK WRITES
          LDDL   INP
          RADL   T1          IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          PJK    RESP10      IN NOT ENOUGH ROOM IN BUFFER, LOOP
          LDDL   T1
          SBDL   LIM
          MJN    RESP40      IF IN + RESPONSE LENGTH .LT. LIMIT
          STDL   T1          IN + RESPONSE LENGTH - LIMIT = NEW  IN  POINTER
          AODL   T2          2 BLOCK WRITES REQUIRED

* WRITE RESPONSE TO CM.

 RESP40   BSS
          LDDL   INP
          SHN    -3
          STDL   T3           IN  POINTER IN WORDS
          LDML   RS+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          STDL   T5
          LDDL   T2
          ZJN    RESP50      IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADK    RS
          STML   RESPA       RESPONSE ADDRESS FOR 2ND BLOCK WRITE

 RESP50   LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD  IN  OFFSET
          CWML   RS,T4       WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          SBDL   T4
          ZJN    RESP70      IF ONLY 1 BLOCK WRITE REQUIRED
          STDL   T5          RESPONSE LENGTH - (LIMIT - IN)
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          LMC    400000B
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
 RESPA    EQU    *-1         (BEGINNING OF RESPONSE BUFFER)

 RESP70   LDDL   T1          NEW IN POINTER
          STDL   P4

* SET UP INTERRUPT PROCESSOR INSTRUCTION IF INTERRUPT IS SELECTED.

          LDML   RS+/RS/P.INT  CHECK IF INTERRUPT WAS SELECTED
          SHN    17-13
          MJN    RESP80      IF INTERRUPT SELECTED
          LDK    PSNI        PSN INSTRUCTION
          UJN    RESP90

 RESP80   BSS
          LDML   RS+/RS/P.PORT  GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RS/L.PORT+/RS/N.PORT
          LPK    /RS/M.PORT
          ADK    INPNI       INPN INSTRUCTION

 RESP90   STML   INTPRC

*  WRITE UPDATED  IN  POINTER FOR CM RESPONSE BUFFER TO PIT.

          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADK    /PIT/C.IN   OFFSET OF  IN  POINTER
          CWDL   P1          WRITE NEW  IN  POINTER TO CM

*  INTERRUPT PROCESSOR.

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   PPNO-3      SET LAST BYTE NON-ZERO

 INTPRC   INPN   1           INTERRUPT OR PSN
          LDN    0           CLEAR IPI RESPONSE LENGTH
          STML   RPB
          LJM    RESPX       EXIT
          SPACE  5,20
** NAME - CHGCH
*
** PURPOSE - CHANGE CHANNEL NUMBER IN CHANNEL INSTRUCTIONS
*
** INPUT - (CURCH) = CHANNEL NUMBER.
*          (A) = CHANNEL TABLE ADDRESS.
*
          SPACE  4
 CHGCH    SUBR               ENTRY/EXIT
          STDL   T1          SET ADDRESS MODIFICATION LIST ADDRESS

 CHG10    LDIL   T1          READ LIST WORD
          ZJN    CHGCHX      IF END OF LIST
          STDL   T2          SET INSTRUCTION ADDRESS
          LDIL   T2          READ INSTRUCTION WORD
          SCN    37B         CLEAR CHANNEL BITS
          LMDL   CURCH       REPLACE WITH NEW CHANNEL
          STIL   T2
          AODL   T1          INCREMENT TO NEXT INSTRUCTION
          UJN    CHG10       LOOP
          SPACE  5,20
** NAME-- SFP
*
** PURPOSE-- SEARCH FOR PARAMETER IDENTIFICATION IN RESPONSE PACKET
*
** INPUT
*         A = ID TO SEARCH FOR
** OUTPUT
*         A = POSITIVE IF ID FOUND
*         T3 = POINTER TO ID IF IT IS FOUND (RPB+5,T3)
          SPACE  2
 SFP      SUBR               ENTRY/EXIT
          STDL   T1          PARAMETER TO SEARCH FOR
          LDN    0
          STDL   T3          POINTER TO ID BEING SEARCHED FOR
          LDML   RPB
          ADN    1
          SHN    -1
          SBN    5           LENGTH OF MINIMUM RESPONSE PACKET
 SFP4     BSS
          STDL   T2          POINTER TO END OF PARAMETERS
          MJN    SFPX        EXIT, NO ID FOUND
          LDML   RPB+5,T3
          LMDL   T1
          LPDL   FF
          ZJN    SFPX        IF ID FOUND
          LDML   RPB+5,T3
          SHN    -9
          ADN    1           ADJUST FOR ODD BYTE
          STDL   T4          WORD LENGTH OF PARAMETER
          RADL   T3          UPDATE POINTER TO ID BEING SEARCHED FOR
          LDDL   T2
          SBDL   T4
          UJN    SFP4
          SPACE  5,20
** NAME-- PCER
*
** PURPOSE-- PREPARE COMMON ERROR RESPONSE
*
** INPUT  A = ERROR ID
          SPACE  2
 PCER     SUBR               ENTRY/EXIT
          STDL   P2
          SBN    E18
          MJN    PCER20      IF ERROR CODE 0-17
          SBN    E21-E18
          MJN    PCER10      IF ERROR CODE 18-20
          SBN    E22-E21
          MJN    PCER20      IF ERROR CODE 21
          SBN    E23-E22
          MJN    PCER10      IF ERROR CODE 22
          SBN    E27-E23
          MJN    PCER20      IF ERROR CODE 23-26
          SBN    E29-E27
          MJN    PCER10      IF ERROR CODE 27, 28
          ZJN    PCER20      IF ERROR CODE 29
          SBN    E30-E29
          NJN    PCER20      IF ERROR CODE 31-XX
 PCER10   BSS
          LDC    H00E1       READ STATUS REGISTER
          RJM    RDRG        READ REGISTER
          STDL   STATUS      SAVE CONTENTS OF STATUS REGISTER
 PCER20   BSS
          LDDL   INITFLG     CHECK IF FROM INITIALIZATION
          ZJN    PCER22      IF NOT
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          LDK    URC.IN      INITIALIZATION ERROR
          RAML   RS+/RS/P.URC
          UJN    PCER28      CONT.
 PCER22   LDDL   ASYNCP      CHECK IF ASYNCHRONUS PROCESSING
          ZJN    PCER24      IF NOT
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          UJN    PCER28      CONT.
 PCER24   BSS
          RJM    PAR         PREPARE ABNORMAL RESPONSE
 PCER28   BSS
          LDDL   P2
          NJN    PCER45      IF ERROR ALREADY ISOLATED
          LDK    ID14
          RJM    SFP         SEARCH FOR ID 14
          MJN    PCER30      IF NOT SLAVE INTERVENTION REQUIRED
          LDK    E71
          UJN    PCER45
 PCER30   BSS
          LDK    ID16
          RJM    SFP         SEARCH FOR ID 16
          MJN    PCER35      IF NOT SLAVE MACHINE EXCEPTION
          LDK    E72
          UJN    PCER45
 PCER35   BSS
          LDK    ID17
          RJM    SFP         SEARCH FOR ID 17
          MJN    PCER40      IF NOT SLAVE COMMAND EXCEPTION
          LDK    E73
          UJN    PCER70
 PCER40   BSS
          LDK    ID13
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    PCER50      IF NOT ID13
          LDK    E74         MICROCODE EXECUTION ERROR
 PCER45   BSS
          UJN    PCER70
 PCER50   BSS
          LDK    ID15
          RJM    SFP         SEARCH FOR ID 15
          MJN    PCER60      IF NOT ALTERNATE PORT EXCEPTION
          LDK    E75
          UJN    PCER70
 PCER60   BSS
          LDK    E00         CP MUST ISOLATE THE ERROR
 PCER70   BSS
          STML   RS+/RS/P.ERRID
          LDDL   WC          WORDS NOT TRANSFERRED
          STML   RS+/RS/P.WC
          LDDL   LF
          STML   RS+/RS/P.FUNTO FAILING FUNCTION IF E01
          LDC    H0200       CONTROL REGISTER
          RJM    RDRG
          STML   RS+/RS/P.CR SAVE CONTROL REGISTER
          LDC    H00F1
          RJM    RDRG        READ IPI ERROR REGISTER
          STML   RS+/RS/P.ERREG SAVE ERROR REGISTER
          LDC    H0600       DMA ERROR REGISTER
          RJM    RDRG
          STML   RS+/RS/P.DMAER SAVE DMA ERROR REGISTER
          ZJN    PCER80      IF ERROR FLAG WAS NOT SET
          LDML   RS+/RS/P.CR CONTROL REGISTER
          SHN    17-12
          PJN    PCER80      IF TEST MODE NOT SET
          LDC    H00E1       READ STATUS REGISTER
          RJM    RDRG        READ REGISTER
          STDL   STATUS
 PCER80   BSS
          LDDL   STATUS      STATUS REGISTER
          STML   RS+/RS/P.STREG
          LDDL   OS
          STML   RS+/RS/P.OSR SAVE OPERATIONAL STATUS REGISTER
          UJK    PCERX
          SPACE  5,20
** NAME-- EP / CMDTERM
*
** PURPOSE-- ERROR PROCESSING
*
** NOTE-- DOES NOT RETURN TO CALLER
          SPACE  2
 CMDTERM  EQU    *
 EP       BSSZ   1           ENTRY
          LDDL   INITFLG     CHECK IF FROM INITIALIZATION
          ADDL   ASYNCP      OR FROM ASYNCHRONUS PROCESSING
          NJN    EP10        IF YES
          RJM    CDUNIT      CHECK IF UNIT IS TO BE DISABLED
 EP10     RJM    RESP        SEND THE RESPONSE
          LDN    76B         SET ASYNCHRONUS PROCESSING FLAG
          STDL   ASYNCP
          AOML   /TS/P.RETRY,CTST  INCREMENT RETRY COUNTER
          SBN    1           CHECK IF FIRST RETRY EXECUTED
          NJN    EP200       IF YES

 EP100    RJM    LIR         LOGICIAL INTERFACE RESET
          UJN    EP900       CONTINUE

 EP200    SBN    1           CHECK IF SECOND RETRY EXECUTED
          NJN    EP900       IF YES
          LDN    0           CLEAR IPI RESPONSE PACKET BUFFER
          STML   RPB
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          LDK    E50         EXECUTING CONTROLLER DIAGNOSTICS
          STML   RS+/RS/P.ERRID  SET ERROR ID FIELD
          RJM    RESP        SEND THE RESPONSE
          RJM    ISR         ISSUE SLAVE RESET
          LDN    0           CLEAR IPI RESPONSE PACKET BUFFER
          STML   RPB
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          LDK    E51         CONTROLLER DIAGNOSTICS PASSED
          STML   RS+/RS/P.ERRID  SET ERROR ID FIELD
          RJM    RESP        SEND THE RESPONSE

 EP900    SBN    1           CHECK IF CLREQ HAS FAILED
          NJN    EP920       IF YES

 EP910    RJM    CLREQ       CLEAR THE REQUEST FROM THE TS TABLE
          LJM    MAIN        GO TO MAIN LOOP

 EP920    LDN    0           CLEAR CHAIN FLAG SO CLREQ WONT FAIL AGAIN
          STML   /TS/P.CHAIN,CTST
          UJN    EP910       GO CLEAR REQUEST
          SPACE  5,20
** NAME - SLVTST
*
** PURPOSE - TO CHECK IF SLAVE TESTING IS REQUIRED
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 SLVTST   SUBR               ENTRY/EXIT
          LDML   SLB+/SL/P.SLVTST,SX  GET SLAVE TESTING REQUIRED FLAG
          LPN    1           MASK TESTING REQUIRED BIT
          ZJN    SLVTSTX     IF NOT, EXIT
          LDML   SLVTST      SAVE RETURN ADDRESS
          STML   /TS/P.SSLVT,CTST
          LDML   SRTAB,SLVN  CHECK IF SLAVE RESET EVER EXECUTED
          ZJN    SLVTST2     IF NOT
          LDN    1           SET RETRY COUNTER
          STML   /TS/P.RETRY,CTST
          RJM    LIR         LOGICAL INTERFACE RESET
          UJN    SLVTST4
 SLVTST2  BSS
          LDN    2           SET RETRY COUNTER
          STML   /TS/P.RETRY,CTST
          RJM    ISR         ISSUE SLAVE RESET
 SLVTST4  BSS
          RJM    PTW         PATH TEST WRITE
          RJM    PTR         PATH TEST READ
          LDN    2           SET ATTRIBUTES REQUIRED FLAG
          STML   SLB+/SL/P.SLVTST,SX
          LDN    0           CLEAR RETRY COUNTER
          STML   /TS/P.RETRY,CTST
          LDML   /TS/P.SSLVT,CTST  RESTORE RETURN ADDRESS
          STML   SLVTST
          UJK    SLVTSTX     EXIT
          SPACE  5,20
** NAME - FACTST
*
** PURPOSE - TO CHECK IF FACILITY TESTING IS REQUIRED
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 FACTST0  LDML   UNITS+/UN/P.CTF,UX  CLEAR FACILITY TESTING REQUIRED FLAG
          LPK    -/UN/K.CTF  MASK OUT BIT
          STML   UNITS+/UN/P.CTF,UX
          LDML   /TS/P.SFACT,CTST  RESTORE RETURN ADDRESS
          STML   FACTST

 FACTST   SUBR               ENTRY/EXIT
          LDML   UNITS+/UN/P.CTF,UX  GET FACILITY TESTING REQUIRED FLAG
          SHN    17-6
          PJN    FACTSTX     IF NOT SET, EXIT
          LDML   FACTST      SAVE RETURN ADDRESS
          STML   /TS/P.SFACT,CTST
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PFDCP1
          LDML   /TS/P.SN,CTST  GET SLAVE AND FACILITY ADDRESS
          STML   PFDCP5
          LDC    PFDCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER

 FACTST2  LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK IF SUCCESSFUL
          ZJK    FACTST0     IF YES
          LDML   RPB+MAJST   CHECK IF COMMAND COMPLETION RESPONSE
          SHN    -4
          LPN    0#F
          LMN    CC
          ZJN    FACTST4     IF YES, BUT WAS NOT SUCCESSFUL
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     PROCESS ASYNCHRONUS RESPONSE
          UJN    FACTST2     WAIT FOR COMMAND COMPLETE RESPONSE

 FACTST4  LDML   RPB+MAJST   CHECK IF DIAGNOSTIC FAILURE
          SHN    LSME          LOOK FOR MACHINE EXCEPTION
          MJN    FACTST6     IF YES
          LDN    0           DO NOT EXPECT BID OR TAPE MARK
          RJM    CMDRESP     PROCESS RESPONSE (NO RETURN)

 FACTST6  LDK    E61         REPORT DRIVE FAILURE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE  (NO RETURN)
          SPACE  4
*         -PERFORM FACILITY DIAGNOSTICS-  COMMAND PACKET
 PFDCP    DATA   0#0010      PACKET LENGTH
 PFDCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCPFD+CMCHN  OP-CODE AND CHAIN
 PFDCP5   DATA   0#FFFF      ADDRESSEE
          DATA   0#0953      FACILITY DIAGNOSTIC PARAMETER
          DATA   0#8000        LOOP WRITE/READ SECTION
          DATA   0#0000        DIAG MODE
          DATA   0#0000        RETRY COUNT
          DATA   0#0001        EXECUTION LOOP COUNT
          SPACE  5,20
** NAME - CDUNIT
*
** PURPOSE - TO SET THE DISABLED UNIT BIT IN THE UIT IF THE MASK BIT IS SET.
*
*  INPUT - RESPONSE BUFFER HEADER ALERT MASK IS IMAGE OF REQUEST
*
** OUTPUT - THE DISABLE UNIT BIT IS SET IN THE STATUS FIELD OF THE UNIT
*           INTERFACE TABLE IF THE ALERT MASK DISABLE BIT WAS SET.
*
          SPACE  2
 CDUNIT   SUBR               ENTRY/EXIT
          LDML   RS+/RS/P.LONGB  CHECK ALERT MASK
          SHN    18-16+/RS/L.DUNIT  DISABLE UNIT BIT TO SIGN POSITION
          PJN    CDUNITX     IF NOT DISABLE UNIT BIT IN ALERT MASK
          LDK    /RS/K.DUNIT   SET UNIT DISABLED BIT IN RESPONSE
          RAML   RS+/RS/P.LNGBLK  SET RESPONSE ALERT CONDITIONS
          LOADR  UNITS+/UN/P.UIT,UX  LOAD R AND A OF UIT
          STDL   CMADR+2     SAVE CM ADDRESS
          CRDL   T1          READ UIT UNIT STATUS INTO T2
          LDK    /UIT/K.DSABLE  SET UNIT DISABLED IN UIT STATUS
          STDL   T2
          LDDL   CMADR+2     RESTORE CM ADDRESS
          LMC    400000B
          CWDL   T1          UPDATE UIT UNIT STATUS
          UJK    CDUNITX     EXIT
          SPACE  5,20
** NAME-- MR
*
** PURPOSE-- MASTER RESET ALL SLAVES ON THE CHANNEL
          SPACE  2
 MR       SUBR               ENTRY/EXIT
          RJM    MCC         MASTER CLEAR CHANNEL
          LDC    H9213
          RJM    FUNC        BUS A, SET SYNC OUT
          PAUSE  10          MUST DELAY 10 MICROSECONDS MINIMUM
          LDC    H9211
          RJM    FUNC        DROP SYNC OUT
          UJK    MRX
          SPACE  5,20
** NAME--ISR
*
** PURPOSE-- ISSUE SLAVE RESET
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 ISR      SUBR               ENTRY/EXIT
          LDML   ISR         SAVE RETURN ADDRESS
          STML   /TS/P.SISR,CTST
          LDK    H8415       SLAVE RESET
          RJM    IR          ISSUE RESET
          LDK    SRT         SLAVE RESET SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          SHN    -4
          LPN    0#F
          LMK    AR
          NJN    ISR20       IF NOT ASYNCHRONOUS RESPONSE
          LDK    ID16
          RJM    SFP         CHECK FOR MACHINE EXCEPTION
          MJN    ISR20       IF MACHINE EXCEPTION ID NOT FOUND
          LDML   RPB+6,T3
          LPK    0#FEE0
          LMK    0#6000
          NJN    ISR20       IF ERROR
          STML   /TS/P.CHAIN,CTST  CLEAR IPI CHAIN/ABORTED FLAG
          LDML   /TS/P.SISR,CTST  RESTORE RETURN ADDRESS
          STML   ISR
          STML   SRTAB,SLVN  SET SLAVE RESET EXECUTED
          UJK    ISRX
 ISR20    BSS
          LDK    E60         CONTROLLER FAILURE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- LIR
*
** PURPOSE-- LOGICAL INTERFACE RESET.
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 LIR      SUBR               ENTRY/EXIT
          LDML   LIR         SAVE RETURN ADDRESS
          STML   /TS/P.SLIR,CTST
          LDK    H8215       LOGICAL INTERFACE RESET
          RJM    IR          ISSUE RESET
          LDN    3           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          SHN    -4
          LPN    0#F
          LMK    AR
          NJN    LIR20       IF NOT ASYNCHRONOUS RESPONSE
          LDK    ID16
          RJM    SFP         CHECK FOR MACHINE EXCEPTION
          MJN    LIR20       IF MACHINE EXCEPTION ID NOT FOUND
          LDML   RPB+6,T3
          LPK    0#FEE0
          LMK    0#6000
          NJN    LIR20       IF ERROR
          STML   /TS/P.CHAIN,CTST  CLEAR IPI CHAIN/ABORTED FLAG
          LDML   /TS/P.SLIR,CTST  RESTORE RETURN ADDRESS
          STML   LIR
          UJK    LIRX
 LIR20    BSS
          LDK    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- IR
*
** PURPOSE-- ISSUE INTERFACE RESET TO SLAVE
*
** ENTRY
*         A = 8115  FOR PHYSICAL INTERFACE RESET
*             8215  FOR LOGICAL INTERFACE RESET
*             8415  FOR SLAVE RESET
*         SLVN = SLAVE NUMBER
          SPACE  2
 IR       SUBR               ENTRY/EXIT
          STDL   P2
          RJM    SARF        SET ATTRIBUTES REQUIRED FLAG
          RJM    MCC         MASTER CLEAR CHANNEL
          LDDL   SLVN        SLAVE NUMBER
          SHN    12
          ADDL   P2
          RJM    FUNC        SET MASTER OUT
          PAUSE  20
          LDDL   LF          LAST FUNCTION ISSUED
          LMN    2
          RJM    FUNC        SET SYNC OUT
          PAUSE  10
          LDDL   LF
          LMN    2
          RJM    FUNC        DROP SYNC OUT
          LDDL   LF
          LMN    4
          RJM    FUNC        DROP MASTER OUT
          UJK    IRX
          SPACE  5,20
** NAME-- IH
*
** PURPOSE-- INTERRUPT HANDLER.  INPUT THE RESPONSE PACKET.  THROW AWAY
*            ASYNCHRONOUS RESPONSES (UP TO 8) FROM THE FACILITIES.
*
** ENTRY--A = MAXIMUM SECONDS TO WAIT FOR THE INTERRUPT
*
** EXIT
*         A = MAJOR STATUS
*         THE SLAVE IS DESELECTED
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 IH       SUBR               ENTRY/EXIT
          ADN    1           ADJUST TIME LIMIT
          STML   /TS/P.SECLIM,CTST  SAVE THE SECONDS LIMIT
          RJM    UC          UPDATE THE CLOCK
          LDDL   CLSEC
          STML   /TS/P.CLK,CTST  SAVE CURRENT CLOCK IN TS TABLE
          LDML   IH          SAVE ROUTINE CALLER
          STML   /TS/P.SIH,CTST
 IH10     BSS
          RJM    SWITCH      SWITCH TO OTHER TS TABLE
          LDML   /TS/P.SIH,CTST  RESTORE RETURN ADDRESS
          STML   IH
          LDN    7           CLASS 1, 2 AND 3 INTERRUPTS
          RJM    RI          REQUEST INTERRUPTS
          NJN    IH15        IF INTERRUPT PRESENT
          RJM    UC          UPDATE CLOCK
          LDDL   CLSEC
          SBML   /TS/P.CLK,CTST
          PJN    IH12        IF CLOCK HAS NOT WRAPPED
          ADK    0#10000
 IH12     BSS
          SBML   /TS/P.SECLIM,CTST
          MJN    IH10        IF TIMEOUT NOT EXPIRED
          LDK    E38         NO SLAVE INTERRUPT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 IH15     BSS
          RJM    DTM         DETERMINE TRANSFER MODE
          RJM    SEL         SELECT THE SLAVE
          STDL   CTM         CLEAR CHANGE TRANSFER MODE FLAG
          RJM    RPT         RESPONSE PACKET TRANSFER
          RJM    DCM         DESELECT THE SLAVE
          LDML   RPB+MAJST   MAJOR STATUS
          SHN    -4
          LPN    0#F
          LMK    AR
          NJN    IH20        IF NOT ASYNCHRONOUS RESPONSE
          LDML   RPB+SLAD
          LPDL   FF
          LMDL   FF
          ZJN    IH20        IF ASYNCHRONOUS RESPONSE FOR SLAVE
          LJM    IH10        GO LOOK FOR ANOTHER INTERRUPT
 IH20     BSS
          LDML   RPB+MAJST   MAJOR STATUS
          LJM    IHX
          SPACE  5,20
** NAME-- UC
*
** PURPOSE-- UPDATE CLOCK.  THE CLOCK IS USED TO TIMEOUT COMMANDS
*            ISSUED TO THE SLAVE.
          SPACE  2
 UC       SUBR               ENTRY/EXIT
          LDDL   CLCUR
          STDL   P6          SAVE CURRENT CLOCK
          IAN    14B
          STDL   CLCUR
          SBDL   P6
          PJN    UC5         IF CLOCK HASNT WRAPPED
          ADK    10000B
 UC5      BSS
          RADL   CLMCS       UPDATE MICROSECOND PORTION OF CLOCK
          LDDL   CLMCS
          ADK    -2000
          MJN    UCX         IF LESS THAN 2 MILLISECONDS
          STDL   CLMCS
          LDN    2
          RADL   CLMLS       UPDATE MILLISECOND PORTION OF CLOCK
          ADK    -1000
          MJN    UCX         IF LESS THAN 1 SECOND
          STDL   CLMLS
          AODL   CLSEC       UPDATE SECOND PORTION OF CLOCK
          UJN    UCX         EXIT
          SPACE  5,20
** NAME-- EFP
*
** PURPOSE-- ERROR FLAG PROCESSING
          SPACE  2
 EFP      DATA   0
          LDC    H0800       DMA TERMINATE
          RJM    FAN
          LDC    H0600       READ DMA ERROR REGISTER
          RJM    RDRG
          SHN    9
          MJK    EFP60       IF IPI ERROR
          SHN    12
          MJK    EFP85       IF ILLEGAL FUNCTION
          SHN    1
          MJN    EFP5        IF UNCORRECTED CM ERROR
          SHN    1
          PJN    EFP10       IF NOT CM REJECT
 EFP5     BSS
          LDN    E09         CENTRAL MEMORY ERROR
          UJN    EFP40
 EFP10    BSS
          SHN    1
          PJN    EFP15       IF NOT INVALID CM RESPONSE CODE
          LDN    E10
          UJN    EFP40
 EFP15    BSS
          SHN    1
          PJN    EFP20       IF NOT CM RESPONSE CODE PARITY ERROR
          LDN    E11
          UJN    EFP40
 EFP20    BSS
          SHN    1
          PJN    EFP25       IF NOT CMI READ DATA PARITY ERROR
          LDN    E12
          UJN    EFP40
 EFP25    BSS
          SHN    5
          PJN    EFP35       IF NOT JY DATA ERROR
          LDN    E13
          UJN    EFP40
 EFP35    BSS
          SHN    1
          PJN    EFP45       IF NOT BAS PARITY ERROR
          LDN    E14
 EFP40    BSS
          UJN    EFP75
 EFP45    BSS
          SHN    1
          PJN    EFP50       IF NOT LZ ERROR
          LDN    E15
          UJN    EFP75
 EFP50    BSS
          SHN    1
          PJN    EFP55       IF NOT JY ERROR
          LDN    E16
          UJN    EFP75
 EFP55    BSS
          SHN    1
          PJK    EFP130      IF NOT LX ERROR
          LDN    E17
          UJN    EFP75
 EFP60    BSS
          LDC    H00F1       READ IPI ERROR REGISTER
          RJM    RDRG
          SHN    2
          PJN    EFP65       IF NOT BUFFER COUNTER PARITY
          LDN    E31
          UJN    EFP75
 EFP65    BSS
          SHN    2
          PJN    EFP70       IF NOT SYNC COUNTER PARITY
          LDN    E32
          UJN    EFP75
 EFP70    BSS
          SHN    1
          PJN    EFP80       IF NOT PERIOD COUNTER PARITY
          LDN    E03
 EFP75    BSS
          UJN    EFP120
 EFP80    BSS
          SHN    1
          MJN    EFP85       IF PARITY ERROR ON FUNCTION
          SHN    1
          PJN    EFP95       IF NOT PARITY ERROR ON FUNCTION
 EFP85    BSS
          LDN    E01         FUNCTION TIMEOUT
          UJN    EFP120
 EFP95    BSS
          SHN    3
          PJN    EFP100      IF NOT LOST DATA
          LDN    E33
          UJN    EFP150
 EFP100   BSS
          SHN    1
          PJN    EFP105      IF NOT UPPER ICI PARITY
          LDN    E04
          UJN    EFP150
 EFP105   BSS
          SHN    1
          PJN    EFP110      IF NOT LOWER ICI PARITY
          LDN    E05
          UJN    EFP150
 EFP110   BSS
          SHN    1
          PJN    EFP115      IF NOT IPI SEQUENCE ERROR
          LDN    E24
          UJN    EFP150
 EFP115   BSS
          SHN    1
          PJN    EFP125      IF NOT UPPER IPI CHANNEL PARITY
          LDN    E25
 EFP120   BSS
          UJN    EFP150
 EFP125   BSS
          SHN    1
          PJN    EFP127      IF NOT LOWER IPI CHANNEL PARITY
          LDN    E26
          UJN    EFP150
 EFP127   SHN    1
          PJN    EFP130      IF NOT ILLEGAL OPERATION
          LDK    E19
          UJN    EFP150
 EFP130   BSS
          LDN    E06         IOU ERROR
 EFP150   BSS
          STML   RS+/RS/P.ERRID
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- INTERR
*
** PURPOSE-- REPORT AN INTERFACE ERROR
*
** ENTRY-- A REGISTER HAS INTERFACE ERROR CODE
*
** EXIT-- TO MAIN IDLE LOOP WITH IDLFLG FORCED SET.
*         PP WILL ONLY PROCESS IDLE/RESUME COMMANDS.
          SPACE  2
 INTERR   DATA   0
          STDL   T7          SAVE ERROR CODE
          LDN    0           NO IPI STATUS IN RESPONSE
          STML   RPB
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          LDDL   T7          GET INTERFACE ERROR CODE
          STML   RS+/RS/P.IEC INTERFACE ERROR CODE
          LDK    /RS/K.INTERR  INTERFACE ERROR
          STML   RS+/RS/P.INTERR  ABNORMAL STATUS CODE
          LDK    E120        SOFTWARE FAILURE
          STML   RS+/RS/P.ERRID
          LDK    /RS/K.PDN   PP IDLED
          STML   RS+/RS/P.DOWNST
          RJM    RESP        SEND THE RESPONSE
          LDN    77B         FORCE SET PP IDLE FLAG
          STDL   IDLFLG
          LJM    MAIN        EXIT TO MAIN IDLE LOOP
          SPACE  5,20
** NAME-- PAUS
*
** PURPOSE-- DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*            MICROSECONDS.
*
** INPUT-- A REGISTER SPECIFIES NUMBER OF MICROSECONDS
*          TO BE DELAYED.
          SPACE  2
 PAUS     SUBR               ENTRY/EXIT
 PAUS10   SBN    1           EACH ITERATION OF THIS LOOP
          STDL   AT1          IS ONE MICROSECOND (I4 ONLY)
          NJN    PAUS10
          UJK    PAUSX
          SPACE  5,20
** NAME-- FORMA
*
** PURPOSE-- FORMAT A CM REAL MEMORY ADDRESS.
*
** CALLING SEQUENCE-- LDC    ADDRESS
*                     RJM    FORMA
*
** INPUT-- - A REGISTER- IS THE ADDRESS OF A 2-WORD CM BYTE ADDRESS.
*
** OUTPUT-- -CMADR- IS THE ADDRESS OF THE RESULTING 3-WORD REFORMATED
*                CM ADDRESS.  THE FORMAT CAN BE USED BY THE LOADC MACRO.
*           -ADDRESS-, WORD 0, BITS 0-13 AND
*                      WORD 1, BITS 3-15, ARE REFORMATTED TO-
*           -CMADR-,   WORD 0, BITS 0-9,
*                      WORD 1, BITS 0-11,
*                      WORD 2, BITS 0-5.
*
** NOTE-- THIS SUBROUTINE USES DIRECT CELL AT1 INSTEAD OF T1
          SPACE  2
 FORMA    SUBR               ENTRY/EXIT
          STDL   AT1
          LDML   1,AT1
          LPN    7
          NJN    FORMA10     RMA ADDRESS ERROR
          LDIL   AT1
          LPN    37B
          SHN    16
          LMML   1,AT1
          SHN    9
          STD    CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   AT1
          SHN    -5
          STD    CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMC    400000B
          UJK    FORMAX      EXIT
 FORMA10  BSS
          LDC    E304        RMA NOT WORD BOUNDARY
          RJM    INTERR      REPORT ERROR (NO RETURN)
          SPACE  5,20
** NAME-- SAVAD
*
** PURPOSE-- SAVE A REFORMATTED CM ADDRESS.
*
** INPUT--  -A REGISTER- IS THE REFORMATTED A OF R+A
*           -T2- ADDRESS TO SAVE THE 3-WORD REFORMATTED CM ADDRESS
*           -CMADR-,   WORD 0, BITS 0-9,    SOURCE REFORMATTED CM ADDRESS
*                      WORD 1, BITS 0-11,
*                      WORD 2, BITS 0-5.
*
** NOTE-- THIS SUBROUTINE USES DIRECT CELL T2
          SPACE  2
 SAVAD    SUBR               ENTRY/EXIT
          STML   2,T2
          LDDL   CMADR
          STI    T2
          LDDL   CMADR+1
          STML   1,T2
          UJK    SAVADX
          SPACE  5,20
** NAME-- PS
*
** PURPOSE-- PORT SELECT.  SELECT PORT A OF IPI CHANNEL
          SPACE  2
 PS       SUBR               ENTRY/EXIT
          LDC    H0062       PORT A SELECT (20 MHZ INT CLK)
*         LDC    H0162       PORT A SELECT (12 MHX EXT CLK)
          RJM    FUNC
          UJN    PSX
          SPACE  5,20
** NAME-- TICP
*
** PURPOSE-- TEST IPI CHANNEL PATH
*
** EXIT-- RETURN TO CALLER IF NO ERRORS DETECTED
          SPACE  2
 TICP     SUBR               ENTRY/EXIT
* TRANSFER FROM RECEIVERS TO CENTRAL MEMORY
          RJM    WOG         WRITE OPERAND GENERATOR, ENABLE TEST MODE
          LDN    H0009
          RJM    FUNC        SET SELECT OUT
          LDC    H0281
          RJM    FUNC        IPI TRANSFER FUNCTION (READ)
          LDC    H0C00       DMA READ
          RJM    TMT         TEST MODE TRANSFER
          LDC    0#71        EXPECTED OPERAND GENERATOR
          RJM    COG         DROP MASTER OUT, DESELECT, DISABLE TEST
                              MODE, CHECK OPERAND GENERATOR
          RJM    VTMD        VERIFY TEST MODE DATA

* TRANSFER FROM CENTRAL MEMORY TO TRANSMITTERS

          RJM    MCC         MASTER CLEAR CHANNEL - CLEARS THE LOST DATA ERROR
                               THAT OCCURS WHEN ONLY ONE OF THE 3 OPERAND
                               GENERATOR WORDS ARE READ
          RJM    WOG         WRITE OPERAND GENERATOR, ENABLE TEST MODE
          LDN    H0009
          RJM    FUNC        SET SELECT OUT
          LDC    H0381       IPI TRANSFER FUNCTION (WRITE)
          RJM    FUNC
          LDC    H0D00       DMA WRITE
          RJM    TMT         TEST MODE TRANSFER
          LDC    0#0         EXPECTED OPERAND GENERATOR
          RJM    COG         DROP MASTER OUT, DESELECT, DISABLE TEST
                              MODE, CHECK OPERAND GENERATOR
          UJK    TICPX       EXIT
          SPACE  5,20
** NAME-- COG
*
** PURPOSE-- CHECK OPERAND GENERATOR.  THE CRC VALUE GENERATED
*            AFTER A TEST MODE OPERATION IS READ AND COMPARED
*            WITH THE CORRECT VALUE.
*
** ENTRY  A = EXPECTED OPERAND GENERATOR
          SPACE  2
 COG      SUBR               ENTRY/EXIT
          STDL   T2
          LDK    H0009
          RJM    FUNC        DROP MASTER OUT
          RJM    DCM         DROP SELECT OUT
          LDN    0           DISABLE TEST MODE
          RJM    WCR         WRITE CONTROL REGISTER
          LDDL   T2
          ZJN    COGX        JUMP IF DMA READ

          LDK    H0802       READ OPERAND GENERATOR
          RJM    RDRG        READ REGISTER
          LMDL   T2
          ZJN    COGX        IF OPERAND GENERATOR IS CORRECT

          LDN    E18         DMA TEST MODE FAILURE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- VTMD
*
** PURPOSE-- VERIFY TEST MODE DATA.  DATA GENERATED FROM A
*            TEST MODE READ IS CHECKSUMMED AND COMPARED
*            AGAINST THE CORRECT VALUE.
          SPACE  2
 VTMD1    STML   RPB         CLEAR RPB LENGTH

 VTMD     SUBR               ENTRY/EXIT
          LDN    25
          STDL   P1          CM WORDS TO TRANSFER
          LOADC  CM.COM
          ADK    /CB/C.PTD   OFFSET TO TEST MODE AREA
          CRML   RPB,P1      READ TEST MODE PATTERN
          LDN    0
          STDL   P2
          STDL   P3
          LDC    100-1       PP WORD COUNT MINUS 1
          STDL   P1
 VTMD10   BSS
          LDML   RPB,P1
          RADL   P2
          SHN    -16
          RADL   P3
          SODL   P1
          PJN    VTMD10      IF MORE WORDS TO CHECKSUM
          LDDL   P2
          LMK    0#DACF      CHECK THE LOWER CHECKSUM
          NJN    VTMD20      IF ERROR
          LDDL   P3
          LMK    0#0036      CHECK THE UPPER CHECKSUM
          ZJK    VTMD1       IF NO ERROR
 VTMD20   BSS
          LDN    E18         DMA TEST MODE FAILURE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- SARF
*
** PURPOSE-- SET ATTRIBUTES REQUIRED FLAG
          SPACE  2
 SARF     SUBR               ENTRY/EXIT
          LDML   SLB+/SL/P.SLVTST,SX  GET FLAG WORD
          LPN    1           MASK TESTING REQUIRED
          ADN    2           SET ATTRIBUTES REQUIRED BIT
          STML   SLB+/SL/P.SLVTST,SX  RESTORE FLAG WORD
          UJN    SARFX       EXIT
          TITLE  CHANNEL SUBROUTINES
** NAME-- MCC
*
** PURPOSE-- MASTER CLEAR CHANNEL
          SPACE  2
 MCC      SUBR               ENTRY/EXIT
          LDN    H0000       MASTER CLEAR CHANNEL
          RJM    FUNC
          PAUSE  100         ALLOW CONTROLLER TIME TO DROP LINES
          SFM    MCC10,DC    CLEAR CHANNEL ERROR FLAG
 MCC10    BSS
          LDN    H0000       MASTER CLEAR CHANNEL
          RJM    FUNC         IN CASE SEQUENCE ERROR OCCURRED
          LDC    H0062       SELECT 20 MHZ INT CLK
*         LDC    H0162       SELECT 12 MHZ EXT CLK
          RJM    FUNC
          LDK    H7C42       SET TRANSFER RATE TO 5.00 MB
*         LDK    HFE42       SET TRANSFER RATE TO 6.00 MB
          RJM    FUNC
          UJN    MCCX
          SPACE  5,20
** NAME-- FUNC
*
** PURPOSE-- ISSUE FUNCTION TO IPI CHANNEL
*
** INPUT-- A REGISTER = FUNCTION CODE.
          SPACE  2
 FUNC     SUBR               ENTRY/EXIT
          DCN    DC+40B      ENSURE CHANNEL IS INACTIVE
                              THE CHANNEL MAY HAVE BEEN LEFT ACTIVE
                              BY A ROUTINE SUCH AS DCM,
                              OR AFTER A REPORTED ERROR.
          CFM    FUNC10,DC   IF CHANNEL ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 FUNC10   BSS
          FAN    DC          ISSUE THE FUNCTION
          STDL   LF          SAVE FUNCTION CODE
 FH1      IFEQ   FH,1        FUNCTION HISTORY TABLE
          STML   FBUF,FI     SAVE HISTORY OF FUNCTIONS ISSUED
          AODL   FI          INCREMENT FUNCTION BUFFER INDEX
          ADK    -FBUFL
          NJN    FUNC20      IF NOT END OF BUFFER
          STDL   FI          INITIALIZE INDEX
 FUNC20   BSS
 FH1      ENDIF
          CFM    FUNC30,DC   IF CHANNEL ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 FUNC30   BSS
          IJM    FUNCX,DC    EXIT IF CHANNEL INACTIVE
          LDK    E01         FUNCTION TIMEOUT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- FAN
*
** PURPOSE-- SEND A FUNCTION TO THE IPI CHANNEL, BUT DONT
*            PUT THE FUNCTION IN THE FUNCTION HISTORY TABLE
          SPACE  2
 FAN      SUBR               ENTRY/EXIT
          DCN    DC+40B      ENSURE THE CHANNEL IS INACTIVE
                              THE CHANNEL MAY HAVE BEEN LEFT ACTIVE
                              BY A MASTER CLEAR, A ROUTINE SUCH AS
                              DCM, OR AFTER A REPORTED ERROR.
          FAN    DC          SEND THE FUNCTION
          UJN    FANX
          SPACE  5,20
** NAME-- RDRG
*
** PURPOSE-- READ EITHER THE IPI STATUS OR IPI ERROR REGISTER
*
** ENTRY--  A = FUNCTION CODE
          SPACE  2
 RDRG10   BSS
          LDN    0

 RDRG     SUBR               ENTRY/EXIT
          RJM    FAN         SEND FUNCTION
          AJM    RDRG10,DC   IF NO FUNCTION REPLY
          ACN    DC+40B
          EJM    RDRG10,DC   IF WORD COULD NOT BE READ
          IAN    DC
          UJN    RDRGX
          SPACE  5,20
** NAME-- DCN
*
** PURPOSE-- DISCONNECT THE CHANNEL
          SPACE  2
 DCN05    DCN    DC+40B      DISCONNECT THE CHANNEL

 DCN      SUBR               ENTRY/EXIT

          SFM    DCN10,DC    IF ERROR FLAG SET
          ZJN    DCN20       IF ALL WORDS TRANSFERRED
          STDL   WC          WORDS NOT TRANSFERRED
          LDN    E07         INCOMPLETE I4 TRANSFER
          UJN    DCN40
 DCN10    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 DCN20    BSS
          EJM    DCN05,DC    IF CHANNEL EMPTY
          LDN    E08         CHANNEL NOT EMPTY
 DCN40    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME--RI
*
** PURPOSE-- REQUEST INTERRUPTS FROM ALL SLAVES ON THIS CHANNEL
*
** INPUT-- A = BIT 0 SET CLASS 1
*                  1 SET CLASS 2
*                  2 SET CLASS 3
*
** OUTPUT-- A = LOGICIAL PRODUCT OF CURRENT SLAVE AND SLAVE INTERRUPTS
*         STATUS =  BIT SIGNIFICANT ADDRESS OF SLAVES WITH INTERRUPTS
          SPACE  2
 RI       SUBR               ENTRY/EXIT
          LPN    7           MASK CALLER SELECTION
          SHN    8           POSITION THEM
          ADK    H0X15       REQUEST SELECTED INTERRUPTS
          RJM    FUNC        BUS A, MASTER OUT
          PAUSE  20          DELAY
          ACN    DC
          EJM    RI5,DC      IF ERROR
          IAN    DC
          STDL   STATUS      SAVE BIT SIGNIFICANT ADDRESS
          LDDL   LF
          LMN    4
          RJM    FUNC        DROP MASTER OUT
          LDML   SELT,SLVN   MASK VALUE
          LPDL   STATUS      LOGICIAL PRODUCT WITH INTERRUPT STATUS
          UJN    RIX         EXIT
 RI5      BSS
          LDK    E02         CHANNEL EMPTY WHEN ACTIVATED
          RJM    PCER        PREPARE COMMAND ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,15
** NAME-- DTM
*
** PURPOSE-- DETERMINE TRANSFER MODE
*
** OUTPUT
*         STATUS - TRANSFER SETTINGS, BIT 4 = 1 IF DATA STREAMING
*         CTM - USED TO CHANGE TRANSFER MODE WHEN SELECTING
          SPACE  2
 DTM      SUBR               ENTRY/EXIT
          LDDL   SLVN        SLAVE NUMBER
          SHN    12
          ADK    H8025
          RJM    FUNC        REQUEST TRANSFER SETTINGS
          ACN    DC
          LDN    77B
 DTM4     FJM    DTM8,DC     IF SLAVE IN
          SBN    1
          NJN    DTM4        IF TIMEOUT NOT EXPIRED
          LDK    E27         NO SLAVE IN
          UJN    DTM16
 DTM8     IAN    DC
          STDL   STATUS      SAVE TRANSFER SETTING
          SFM    DTM20,DC    IF ERROR FLAG SET
          LPN    0#10
          LMN    0#10
          SHN    7
          STDL   CTM         CHANGE TRANSFER MODE BIT
          LDDL   LF          LAST FUNCTION ISSUED
          LMK    0#54        CODE 7, DROP MASTER OUT
          RJM    FUNC        DROP MASTER OUT
          ACN    DC
          LDN    77B
 DTM12    FJM    DTMX,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    DTM12       IF TIMEOUT NOT EXPIRED
          LDK    E28         SLAVE IN DID NOT DROP
 DTM16    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 DTM20    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- SEL
*
** PURPOSE-- SELECT THE SLAVE AND VERIFY THE BIT SIGNIFICANT RESPONSE
*
** INPUT
*         SLVN - SLAVE NUMBER
*         CTM - CHANGE TRANSFER MODE IF BIT 3 SET
*
** OUTPUT-- A = 0 IF NO ERROR
          SPACE  2
 SEL      SUBR               ENTRY/EXIT
          LDDL   SLVN
          SHN    12
          ADDL   CTM         CHANGE TRANSFER MODE MODIFIER
          ADK    H0029
          RJM    FUNC        SET SELECT OUT
          ACN    DC
          LDN    77B
 SEL4     FJM    SEL8,DC     IF SLAVE IN
          SBN    1
          NJN    SEL4        IF TIMEOUT NOT EXPIRED
          LDK    E20         CANT SELECT SLAVE
          UJN    SEL15
 SEL8     IAN    DC
          STDL   STATUS      SAVE BIT SIGNIFICANT RESPONSE
          CFM    SEL10,DC    IF ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 SEL10    BSS
          LPK    377B
          LMML   SELT,SLVN
          ZJK    SELX        IF BIT SIGNIFICANT RESPONSE CORRECT
          LDK    E21         BIT SIGNIFICANT RESPONSE WRONG
 SEL15    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- BCS
*
** PURPOSE-- PERFORM BUS CONTROL SEQUENCE
*
** INPUT
*         A = BUS A BITS 7,6 IN BITS 1,0 OF ACCUMULATOR
*             BIT 7 = 1 IF DATA ELSE RESPONSE OR COMMAND
*             BIT 6 = 1 IF INFORMATION IN
          SPACE  2
 BCS      SUBR               ENTRY/EXIT
          SHN    14
          ADK    H005B
          RJM    FUNC        SET SYNC OUT
          ACN    DC
          LDN    77B
 BCS4     FJM    BCS8,DC     IF SYNC IN
          SBN    1
          NJN    BCS4        IF TIMEOUT NOT EXPIRED
          LDK    E22         NO SYNC IN
          UJN    BCS20
 BCS8     IAN    DC
          STDL   STATUS      SAVE BUS ACKNOWLEDGE STATUS
          SFM    BCS25,DC    IF ERROR FLAG SET
          LPDL   FF
          NJN    BCS16       IF BUS ACKNOWLEDGE IS WRONG
          LDDL   LF          LAST FUNCTION
          LMN    0#32
          RJM    FUNC        DROP SYNC OUT
          ACN    DC
          LDN    77B
 BCS12    FJM    BCSX,DC     IF SYNC IN DROPPED
          SBN    1
          NJN    BCS12       IF TIMEOUT NOT EXPIRED
          LDK    E23         SYNC IN DID NOT DROP
          UJN    BCS20
 BCS16    BSS
          LDK    E37         BUS ACKNOWLEDGE WRONG
 BCS20    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 BCS25    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- CPT
*
** PURPOSE-- COMMAND PACKET TRANSFER
*
** INPUT-- A = COMMAND PACKET FWA
*              BIT 17 - BYPASS SEL AND DCM SUBROUTINES
          SPACE  2
 CPT30    LDN    EVENOT      USE EVEN OCTET TRANSFER ENCODED STATUS
          RJM    GES         GET ENDING STATUS
          LDDL   CPTBP       CHECK FOR BYPASS DCM
          LPN    1
          NJN    CPT35       IF YES
          RJM    DCM         DESELECT THE SLAVE

 CPT35    LDDL   WC
          ZJN    CPT40       IF ALL WORDS TRANSFERRED
          LDK    E29         INCOMPLETE TRANSFER
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)

 CPT40    LDML   *           GET COMMAND CODE SENT
 CPTA     EQU    *-1
          LPN    CMCHN       CHECK FOR COMMAND CHAINING
          STML   /TS/P.CHAIN,CTST  SET CHAINING FLAG

 CPT      SUBR               ENTRY/EXIT

          SHN    1           SAVE BYPASS BIT AS BIT 0
          STDL   CPTBP       SAVE IT
          SHN    17          RESTORE ORIGINAL FWA
          STML   CPTC        INITIALIZE INSTRUCTIONS
          STML   CPTD
          ADN    OPCD        ADJUST TO OPCODE
          STML   CPTA        FOR CHAINING FLAG

 KHCPT    EQU    KH+KHC
 KH1      IFNE   KHCPT,0     COMMAND HISTORY
          SBN    OPCD        RESET ADDRESS
          STML   CPTB        INITIALIZE INSTRUCTION ADDRESS
          LCN    0           INDICATE COMMAND
          STML   HB,HBP
          AODL   HBP         INCREMENT DESTINATION INDEX
          ADN    7           COMPUTE LOOP LIMIT
          STML   CPTE        SET LOOP LIMIT

 CPT10    LDML   *           GET COMMAND WORD
 CPTB     EQU    *-1
          STML   HB,HBP      PUT INTO HISTORY LIST
          AOML   CPTB        INCREMENT SOURCE ADDRESS
          AODL   HBP         INCREMENT DESTINATION INDEX
          SBML   CPTE        CHECK FOR ENTRY LIMIT
          NJN    CPT10       IF NOT, LOOP
          LDDL   HBP         CHECK FOR BUFFER LIMIT
          ADK    -HBL
          NJN    CPT15       IF NOT
          STDL   HBP
 CPT15    BSS
 KH1      ENDIF

          LDDL   CPTBP       CHECK FOR BYPASS SEL
          LPN    1
          NJN    CPT18       IF YES
          RJM    SEL         SELECT THE SLAVE

 CPT18    LDK    CMDOUT      BUS A FOR COMMAND
          RJM    BCS         BUS CONTROL SEQUENCE
          LDK    H0381       STREAM, WRITE
          RJM    FUNC        RAISE MASTER OUT
          ACN    DC
          LDML   *           GET PACKET LENGTH
 CPTC     EQU    *-1
          ADN    3
          SHN    -1          CONVERT BYTE COUNT TO WORD COUNT
          OAM    *,DC        SEND COMMAND PACKET
 CPTD     EQU    *-1
          CFM    CPT20,DC    IF CHANNEL ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 CPT20    BSS
          STDL   WC          SAVE RESIDUAL WORD COUNT
          RJM    WSID        WAIT FOR SLAVE IN TO DROP
          UJK    CPT30
          SPACE  2
 KHLIM    EQU    KH+KHC+KHR
 KH1A     IFNE   KHLIM,0     COMMAND HISTORY
 CPTE     BSSZ   1           LIMIT ADDRESS
 KH1A     ENDIF
          SPACE  5,20
** NAME-- RPT
*
** PURPOSE-- RESPONSE PACKET TRANSFER
*
** OUTPUT
*         RPB - STARTING LOCATION OF RESPONSE PACKET
          SPACE  2
 RPT20    BSS
          STDL   WC          SAVE WORDS NOT TRANSFERRED
 RPT30    BSS
          LDN    EVENOT      USE EVEN OCTET TRANSFER ENCODED STATUS
          RJM    GES         GET ENDING STATUS

 KHRPT    EQU    KH+KHR
 KH2      IFNE   KHRPT,0     RESPONSE HISTORY
          LCN    77B         INDICATE RESPONSE
          STML   HB,HBP
          LDML   RPB         PACKET LENGTH
          STML   HB+1,HBP
          LDML   RPB+1       COMMAND REFERENCE NUMBER
          STML   HB+2,HBP
          LDML   RPB+2       COMMAND
          STML   HB+3,HBP
          LDML   RPB+3       SLAVE/FACILITY
          STML   HB+4,HBP
          LDML   RPB+4       MAJOR STATUS
          STML   HB+5,HBP
          LDML   RPB+5       PARAMETERS (IF ANY)
          STML   HB+6,HBP
          LDML   RPB+6
          STML   HB+7,HBP
          LDN    8
          RADL   HBP         UPDATE HISTORY BUFFER POINTER
          ADK    -HBL        CHECK IF FULL
          NJN    RPT35       IF NOT FULL YET
          STDL   HBP         RESET POINTER
 RPT35    BSS
 KH2      ENDIF

          LDDL   WC
          ZJN    RPTX        IF ALL WORDS TRANSFERRED
          LDK    E29         INCOMPLETE TRANSFER
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)

 RPT      SUBR               ENTRY/EXIT

          LDK    RSPIN       BUS A FOR RESPONSE
          RJM    BCS         BUS CONTROL SEQUENCE
          LDK    H0281       STREAM, READ
          RJM    FUNC        SET MASTER OUT
          ACN    DC
          LDN    5
          IAM    RPB,DC      INPUT REQUIRED WORDS
          CFM    RPT2,DC     IF CHANNEL ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 RPT2     BSS
          NJK    RPT20       IF NOT ALL WORDS RECEIVED
          LDML   RPB         BYTE COUNT MINUS 2
          ADN    3
          SHN    -1
          SBN    5
          ZJN    RPT4        IF ALL WORDS TRANSFERRED
          LPK    377B        PROTECT AGAINST ILLEGAL LENGTH
          IAM    RPB+5,DC    INPUT REMAINING WORDS
          CFM    RPT3,DC     IF CHANNEL ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 RPT3     BSS
          NJN    RPT2        IF NOT ALL WORDS TRANSFERRED
 RPT4     BSS
          STDL   WC          WORDS NOT TRANSFERRED
          RJM    WSID        WAIT FOR SLAVE IN TO DROP
          UJK    RPT30
          SPACE  5,20
** NAME-- GES
*
** PURPOSE-- GET ENDING STATUS
*
** INPUT-- A = MASTER ENCODED ENDING STATUS IN LOWER 4 BITS
*
** OUTPUT--
*         RETURNS TO CALLING PROGRAM IF STATUS IS READ WITHOUT ERROR
*         AND SUCCESSFUL IS SET IN STATUS
          SPACE  2
 GES      SUBR               ENTRY/EXIT
          SHN    8           POSITION MASTER ENCODED ENDING STATUS
          ADK    H8039       INDICATE SUCCESSFUL IN BUS A
          RJM    FUNC        DROP MASTER OUT
          ACN    DC
          LDK    2000        ABOUT 2 MILLISECOND TIMELIMIT
 GES4     FJM    GES8,DC     IF SLAVE IN SET
          SBN    1
          NJN    GES4        IF TIMEOUT NOT EXPIRED
          LDK    E27         SLAVE IN NOT SET
          UJK    GES30
 GES8     IAN    DC
          STDL   STATUS      SAVE ENDING STATUS
          SFM    GES40,DC    IF ERROR FLAG SET
          SHN    17-7
          MJN    GESX        IF SUCCESSFUL
          LDDL   STATUS
          SHN    17-6
          PJN    GES15       IF NOT BUS PARITY
          LDK    E34
          UJN    GES30
 GES15    BSS
          LDDL   STATUS
          LPN    17B
          SBN    2
          MJN    GES25       IF REPORTING -ENDING STATUS WRONG-
          SBN    7
          NJN    GES20       IF NOT -SYNC OUTS NOT EQUAL SYNC INS-
          LDK    E36
          UJN    GES30
 GES20    BSS
          PJN    GES23       IF NOT COMMAND REJECT
 GES22    LDK    E35
          UJN    GES30
 GES23    BSS
          SBN    2
          NJN    GES25       IF NOT INTERNAL SLAVE ERROR
          LDK    E70
          UJN    GES30
 GES25    BSS
          SBN    1           CHECK FOR COMMAND REJECT
          ZJN    GES22       IF YES
          LDK    E39         ENDING STATUS WRONG
 GES30    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 GES40    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- DCM
*
** PURPOSE-- DESELECT THE SLAVE
          SPACE  2
 DCM1     DCN    DC+40B      DEACTIVATE CHANNEL
          SFM    DCM10,DC    IF CHANNEL ERROR FLAG IS SET

 DCM      SUBR               ENTRY/EXIT
          LDK    H0071
          RJM    FUNC        DROP SELECT OUT
          ACN    DC
          LDN    77B
 DCM4     FJM    DCM1,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    DCM4        IF TIMEOUT NOT EXPIRED
          SFM    DCM10,DC    IF CHANNEL ERROR FLAG IS SET
          LDK    E28         SLAVE IN DID NOT DROP
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 DCM10    RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- WOG
*
** PURPOSE-- WRITE OPERAND GENERATOR.  THIS DETERMINES THE NUMBER OF
*            WORDS TO TRANSFER.  FOR READS TO CM IT DETERMINES THE DATA
*            PATTERN AND FOR WRITES IT SETS THE STARTING VALUE FOR ITS
*            CRC CHECK OF THE DATA.
          SPACE  2
 WOG      SUBR               ENTRY/EXIT
          LDC    H0702       WRITE OPERAND GENERATOR FUNCTION
          RJM    FUNC
          ACN    DC
          LDN    2
          OAM    WOGP,DC     SEND THE PARAMETERS
          RJM    DCN         DISCONNECT THE CHANNEL
          LDC    0#80FF      ENABLE TEST MODE
          RJM    WCR         WRITE CONTROL REGISTER
          UJN    WOGX
 WOGP     BSS
          DATA   0#1357      STARTING PATTERN
          DATA   0#FF9C      STREAM 100 PP WORDS
          SPACE  5,20
** NAME-- TMT
*
** PURPOSE-- TEST MODE TRANSFER
*
** ENTRY
*         A = 0C00 FOR DMA READ
*             0D00 FOR DMA WRITE
          SPACE  2
 TMT      SUBR               ENTRY/EXIT
          RJM    FUNC
          LDC    200
          STDL   T8          T8 CONTROLS THE TIMEOUT
          STML   CM.CB.T     BYTE COUNT
          ACN    DC
          LDN    3
          OAM    CM.CB.T,DC  BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
 TMT10    BSS
          LDC    H0700       READ OPERATIONAL STATUS
          RJM    FUNC
          ACN    DC
          EJM    TMT20,DC    IF ERROR
          IAN    DC
          STDL   OS          SAVE OPERATIONAL STATUS
          SFM    TMT40,DC    IF ERROR FLAG SET
          LPN    1
          ZJN    TMTX        IF TRANSFER COMPLETE
          SODL   T8
          NJN    TMT10       IF TIMEOUT NOT EXPIRED
          LDC    H0A00       READ T REGISTER
          RJM    RDRG        READ REGISTER
          STML   /TS/P.RESBC,CTST  SAVE RESIDUAL BYTE COUNT
          SHN    -1
          STDL   WC          SAVE RESIDUAL WORD COUNT
          LDC    H0800       DMA TERMINATE
          RJM    FAN
          LDC    H00E1       READ STATUS REGISTER
          RJM    RDRG        READ REGISTER
          STDL   STATUS      SAVE CONTENTS OF STATUS REGISTER
          LDN    E29         INCOMPLETE TRANSFER
          UJN    TMT30
 TMT20    BSS
          LDN    E02         CHANNEL EMPTY WHEN ACTIVATED
 TMT30    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 TMT40    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- WCR
*
** PURPOSE-- WRITE CONTROL REGISTER
*
** ENTRY--  A = VALUE TO WRITE INTO CONTROL REGISTER
          SPACE  2
 WCR      SUBR               ENTRY/EXIT
          STDL   AT1
          LDC    H0302       WRITE CONTROL REGISTER
          RJM    FUNC
          ACN    DC
          LDDL   AT1
          OAN    DC
          LDN    0
          RJM    DCN         DISCONNECT THE CHANNEL
          UJN    WCRX
          SPACE  5,20
** NAME-- WSID
*
** PURPOSE-- WAIT FOR SLAVE IN TO DROP
*
** EXIT -- RETURN TO CALLER IF SLAVE IN DROPPED BEFORE TIMEOUT.
*          ELSE REPORT ERROR E30 AND DO NOT RETURN TO CALLER.
          SPACE  2
 WSID     SUBR               ENTRY/EXIT
          LDK    MS25        TIMEOUT VALUE (ABOUT 25 MS)
 WSID10   IJM    WSIDX,DC    IF SLAVE IN DROPPED, EXIT
          SBN    1
          NJN    WSID10      IF TIMEOUT NOT EXPIRED
          LDK    E30         CHANNEL STAYED ACTIVE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- DDI
*
** PURPOSE-- DMA DATA INPUT
*
** INPUT-- (/TS/P.ILSTP,CTST) HAS CURRENT INDIRECT LENGTH/ADDRESS PAIR
*          (WC) HAS CHANNEL WORD COUNT TO TRANSFER
*
** EXIT-- PREVIOUS T PRIME (BC THRU RMA) MOVED TO (TBC THRU TRMA+1).
*         RETURN WITH A=0.
          SPACE  2
 DDI      SUBR               ENTRY/EXIT
          LDC    H0C00       DMA READ
          RJM    FUNC
          ACN    DC
          LDDL   WC          GET REQUESTED WORD COUNT
          SHN    1           CONVERT TO BYTE COUNT
          STDL   BC          SET T REGISTER BYTE COUNT PARAMETER
          LDML   /TS/P.ILSTP+2,CTST  INITIALIZE T REG. DATA RMA
          STDL   RMA
          LDML   /TS/P.ILSTP+3,CTST
          STDL   RMA+1
          LDN    3
          OAM    BC,DC       OUTPUT T REGISTER PARAMETERS
          RJM    DCN         DISCONNECT THE CHANNEL
          UJN    DDIX        EXIT
          SPACE  5,20
** NAME-- DDO
*
** PURPOSE-- DMA DATA OUTPUT
*
** INPUT-- (/TS/P.ILSTP,CTST) HAS CURRENT INDIRECT LENGTH/ADDRESS PAIR
*          (WC) HAS CHANNEL WORD COUNT TO TRANSFER
*
** EXIT-- A=0
          SPACE  2
 DDO      SUBR               ENTRY/EXIT
          LDC    H0D00       DMA WRITE
          RJM    FUNC
          ACN    DC
          LDDL   WC          GET REQUESTED WORD COUNT
          SHN    1           CONVERT TO BYTE COUNT
          STDL   BC          SET T REGISTER BYTE COUNT PARAMETER
          LDML   /TS/P.ILSTP+2,CTST  INITIALIZE T REG. DATA RMA
          STDL   RMA
          LDML   /TS/P.ILSTP+3,CTST
          STDL   RMA+1
          LDN    3
          OAM    BC,DC       OUTPUT T REGISTER PARAMETERS
          RJM    DCN         DISCONNECT THE CHANNEL
          UJN    DDOX        EXIT
          SPACE  5,20
** NAME-- WFTE
*
** PURPOSE-- WAIT FOR T PRIME REGISTER EMPTY
*
** EXIT -- A = 0 IF OK
*             NZ IF INCOMPLETE TRANSFER
          SPACE  2
 WFTE5    LDN    0           EXIT A=0

 WFTE     SUBR               ENTRY/EXIT

          LDC    6666
          STDL   T8          T8 CONTROLS THE TIMEOUT

 WFTE10   RJM    ROSR        READ OPERATIONAL STATUS REGISTER
          SHN    17-1        CHECK T PRIME REGISTER EMPTY
          MJN    WFTE5       IF YES
          SHN    2+17-8      CHECK DMA TRANSFER COMPLETE (BIT 8)
          MJN    WFTE20      JUMP IF DMA TRANSFER COMPLETE (SHORT BLOCK)
          SHN    8-0         CHECK CHANNEL TRANSFER IN PROGRESS
          PJN    WFTE20      JUMP IF NO TRANSFER IN PROGRESS
          SODL   T8
          NJN    WFTE10      IF TIMEOUT NOT EXPIRED

 WFTE20   LDN    1           INDICATE INCOMPLETE TRANSFER
          UJK    WFTEX       EXIT
          SPACE  5,20
** NAME-- ROSR
*
** PURPOSE-- READ OPERATIONAL STATUS REGISTER
*
** EXIT -- A AND (OS) = OPERATIONAL STATUS
          SPACE  2
 ROSR     SUBR               ENTRY/EXIT
          LDC    H0700
          RJM    FAN         READ OPERATIONAL STATUS
          AJM    ROSR30,DC   IF NO ADAPTER FUNCTION REPLY
          ACN    DC          ACTIVATE CHANNEL FOR INPUT
          EJM    ROSR10,DC   IF ADAPTER IS NOT RESPONDING
          IAN    DC
          STDL   OS          SAVE OPERATIONAL STATUS
          UJN    ROSRX       EXIT

 ROSR10   LDN    E02         CHANNEL EMPTY WHEN ACTIVATED

 ROSR20   RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)

 ROSR30   LDN    E01         FUNCTION TIMEOUT
          UJN    ROSR20      PROCESS THIS ERROR
          SPACE  5,20
** NAME-- WFTC
*
** PURPOSE-- WAIT FOR TRANSFER COMPLETE ON FIXED LENGTH RECORD.
*
** ENTRY-- A = 0 WAIT FOR COMPLETION,
*             NZ PROCESS INCOMPLETE TRANSFER.
*
** EXIT-- RETURN TO CALLING ROUTINE IF TRANSFER COMPLETED,
*         ELSE TO ERROR PROCESSING.
          SPACE  2
 WFTC10   STML   /TS/P.RESBC,CTST  CLEAR RESIDUAL BYTE COUNT

 WFTC     SUBR               ENTRY/EXIT
          NJN    WFTC30      IF PROCESS INCOMPLETE TRANSFER
          LDC    6400
          STDL   T8          T8 CONTROLS THE TIMEOUT

 WFTC20   RJM    ROSR        READ OPERATIONAL STATUS REGISTER
          LPN    1           CHECK TRANSFER IN PROGRESS
          ZJN    WFTC10      IF DONE
          SODL   T8
          NJN    WFTC20      IF TIMEOUT NOT EXPIRED

 WFTC30   UJN    ITVLR       PROCESS INCOMPLETE TRANSFER
          SPACE  5,20
** NAME-- ITVLR
*
** PURPOSE-- PROCESS INCOMPLETE TRANSFER VARIABLE LENGTH READ.
*
** NOTE-- THE DMA LOGIC WILL BE HARDWARE MASTER CLEARED WHEN ROUTINE *EP*
*         CALLS FOR A LOGICIAL INTERFACE RESET.
          SPACE  2
 ITVLR    LDC    H0800       DMA TERMINATE FUNCTION
          RJM    FAN
          LDC    H0E00       CLEAR T REGISTER FUNCTION
          RJM    FAN
          LDC    H00E1       READ IPI STATUS REGISTER FUNCTION
          RJM    RDRG        READ THE REGISTER
          STDL   STATUS      SAVE IT
          SHN    17-11       CHECK FOR SLAVE IN
          MJN    ITVLR10     IF SLAVE IN DID NOT DROP
          LDN    E29         REPORT INCOMPLETE TRANSFER
          UJN    ITVLR20

 ITVLR10  LDN    E30         REPORT SLAVE IN DID NOT DROP

 ITVLR20  RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING  (NO RETURN)
          SPACE  5,20
** NAME-- WVTC
*
** PURPOSE-- WAIT FOR VARIABLE LENGTH TRANSFER TO COMPLETE.
*
** EXIT-- RETURN TO CALLER WHEN TRANSFER COMPLETES WITH (/TS/P.RESBC,CTST)
*         SET TO RESIDUAL BYTE COUNT IF ANY.
*         ELSE GO TO ERROR PROCESSING.
          SPACE  2
 WVTC     SUBR               ENTRY/EXIT
          LDC    6400        MAXIMUM LOOP COUNT = ABOUT 1 MILLISECOND
          STDL   T8
 WVTC10   RJM    ROSR        READ OPERATIONAL STATUS REGISTER
          SHN    17-8        CHECK DMA TRANSFER COMPLETE
          MJN    WVTC40      JUMP IF DMA TRANSFER COMPLETE (SHORT BLOCK)
          SHN    8-0         CHECK CHANNEL TRANSFER IN PROGRESS
          PJN    WVTC20      JUMP IF TRANSFER COMPLETE

          SODL   T8
          NJN    WVTC10      IF TIMEOUT NOT EXPIRED
          UJK    ITVLR       PROCESS ERROR

WVTC20    LDN    0
          STML   /TS/P.RESBC,CTST   CLEAR RESIDUAL BYTE COUNT
          UJK WVTCX                 RETURN - I/O COMPLETE

*         CHECK IF VARIABLE LENGTH DMA READ HAS COMPLETED.
 WVTC40   LDC    H0A00       READ T REGISTER FUNCTION
          RJM    FAN
          AJM    ROSR30,DC   IF NO ADAPTER FUNCTION REPLY
          ACN    DC          ACTIVATE CHANNEL FOR INPUT
          EJM    ROSR10,DC   IF ADAPTER IS NOT RESPONDING
          LDN    3           INPUT WORD COUNT
          IAM    TREG,DC     INPUT ACTUAL T REGISTER
          NJK    ITVLR       IF INPUT ERROR

*         PROCESS DMA OPERATION COMPLETION.

          LDML   TREG        SET RESIDUAL BYTE COUNT IF ANY
          STML   /TS/P.RESBC,CTST
          LDDL   OS          CHECK IF T PRIME IS EMPTY
          SHN    17-1
          MJN    WVTC50      IF IT IS EMPTY

*         CONTINUE PROCESSING END OF OPERATION.
          LDDL   WC          INCLUDE T PRIME IN RESIDUAL BYTE COUNT
          SHN    1           CONVERT TO BYTES
          RAML   /TS/P.RESBC,CTST

*         CLEAN UP DMA HARDWARE FROM THE PARTIAL READ OPERATION.
 WVTC50   LDC    H0800       DMA TERMINATE TO CLEAR DMA LOGIC
          RJM    FAN
          LDC    H0E00       CLEAR T REGISTER FUNCTION
          RJM    FAN
          UJK    WVTCX       EXIT
          SPACE  2
*         T REGISTER RESIDUE FOLLOWING DMA READ OPERATION
 TREG     BSSZ   3
          SPACE  5,20
** NAME-- REL
*
** PURPOSE-- READ ERROR LOG
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 REL1     LDML   /TS/P.SREL,CTST  RESTORE RETURN ADDRESS
          STML   REL

 REL      SUBR               ENTRY/EXIT
          LDML   REL         SAVE RETURN ADDRESS
          STML   /TS/P.SREL,CTST
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   RELCP1
          LDC    RELCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 REL5     LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16       CHECK FOR TRANSFER NOTIFICATION
          ZJN    REL20       IF YES
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    REL5        IF ASYNC
 REL20    LDIL   CTST        CHECK IF COMMAND REFERENCE NUMBERS AGREE
          LMML   RPB+CRN
          NJK    REL50       IF NOT
          RJM    SEL         SELECT SLAVE
          LDN    DATAIN      BUS A FOR DATA IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0281       STREAM AND READ
          RJM    FUNC
          ACN    DC
          LDN    17          WORD COUNT
          IAM    RPB+72,DC   INPUT TO THE RESPONSE PACKET BUFFER
          STDL   WC          SAVE RESIDUAL WORD COUNT
          RJM    WSID        WAIT FOR SLAVE IN TO DROP
          LDN    EVENOT      USE EVEN OCTET MASTER ENCODED ENDING STATUS
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT SLAVE
          LDDL   WC          CHECK IF INCOMPLETE TRANSFER
          NJN    REL80       IF YES
 REL40    LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          ZJK    REL1        IF YES  EXIT
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    REL40       IF ASYNC

 REL50    LDK    E76         UNEXPECTED STATUS
          UJN    REL90
 REL80    LDN    E29         INCOMPLETE TRANSFER
 REL90    RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  4
*         -READ ERROR LOG-  COMMAND PACKET
 RELCP    DATA   0#0006      PACKET LENGTH
 RELCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
 RELCP3   CON    OCREL+CMCHN+OMRELC  OP-CODE, CLEAR LOG AND CHAIN
 RELCP5   DATA   0#FFFF      ADDRESSEE
          SPACE  2
 V1       IFEQ   VALID,1     VALIDATE CPU TABLES/BUFFERS
          TITLE  VALIDATE CPU TABLES/BUFFERS
** NAME-- CHKPIT
*
** PURPOSE-- CHECK FOR VALID PP INTERFACE TABLE
          SPACE  2
 CHKPIT   SUBR               ENTRY/EXIT
          LDN    0
          STDL   T8
          LDML   PITB+/PIT/P.CBUFL  COMMUNICATION BUFFER LENGTH
          LPN    7
          NJK    CHKP100     IF LENGTH NOT A MULTIPLE OF WORDS

          AODL   T8
          LDML   PITB+/PIT/P.CBUFL-1  RESERVED WORD OF PP COMMUNICATION
                             BUFFER DESCRIPTOR
          NJK    CHKP100     IF RESERVED WORD NOT ZERO

          AODL   T8
          LDML   PITB+/PIT/P.CBUF+1  COMMUNICATION BUFFER (RMA)
          LPN    7
          NJK    CHKP100     IF PP COMMUNICATION BUFFER NOT A WORD BOUNDARY

          AODL   T8
          LDML   PITB+/PIT/P.PPQPVA-1  RESERVED FIELD OF PP REQUEST
                             QUEUE DESCRIPTOR
          ADML   PITB+/PIT/P.PPQ-1
          NJK    CHKP100     IF RESERVED FIELD NOT ZERO

          AODL   T8
          LDML   PITB+/PIT/P.INT+1  INTERRUPT WORD (RMA)
          LPN    7
          NJK    CHKP100     IF INTERRUPT WORD NOT A WORD BOUNDARY
          AODL   T8
          LDML   PITB+/PIT/P.CHAN+1  CHANNEL TABLE (RMA)
          LPN    7
          NJN    CHKP100     IF CHANNEL TABLE NOT ON A WORD BOUNDARY

          AODL   T8
          LDML   PITB+/PIT/P.IN-3  IN POINTER RESERVED FIELD
          ADML   PITB+/PIT/P.IN-2
          ADML   PITB+/PIT/P.IN-1
          NJN    CHKP100     IF NON ZERO

          AODL   T8
          LDML   PITB+/PIT/P.OUT-3  OUT POINTER RESERVED FIELD
          ADML   PITB+/PIT/P.OUT-2
          ADML   PITB+/PIT/P.OUT-1
          NJN    CHKP100     IF NON ZERO

          AODL   T8
          LDML   PITB+/PIT/P.LIMIT-3  LIMIT POINTER RESERVED FIELD
          ADML   PITB+/PIT/P.LIMIT-2
          ADML   PITB+/PIT/P.LIMIT-1
          ZJK    CHKPITX     IF OK, EXIT

 CHKP100  BSS
          LDML   CHKPA,T8    INTERFACE ERROR CODE
          RJM    INTERR      SEND ERROR TO CM (NO RETURN)

 CHKPA    BSS
          CON    E20B        COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS
          CON    E204        RESERVED WORD OF PP COMMUNICATION
                             BUFFER DESCRIPTOR NOT ZERO
          CON    E203        PP COMMUNICATION BUFFER NOT A WORD BOUNDARY
          CON    E205        RESERVED FIELD OF PP REQUEST QUEUE
                             DESCRIPTOR NOT ZERO
          CON    E211        RMA OF INTERRUPT WORD NOT A WORD BOUNDARY
          CON    E212        RMA OF CHANNEL TABLE NOT A WORD BOUNDARY
          CON    E20D        RESERVED FIELD OF IN POINTER IS NOT ZERO
          CON    E20E        RESERVED FIELD OF OUT POINTER IS NOT ZERO
          CON    E20F        RESERVED FIELD OF LIMIT POINTER IS NOT ZERO
          SPACE  5,20
** NAME-- CHKUD
*
** PUPOSE-- CHECK FOR VALID UNIT DESCRIPTOR
*
** ENTRY-- UX IS INDEX INTO UNITS TABLE
*          UNIT DESCRIPTOR IS IN UNITD BUFFER
          SPACE  2
 CHKUD    SUBR               ENTRY/EXIT
          LDML   UNITS+/UN/P.UIT,UX   CHECK IF DUPLICIATE UNIT
          ADML   UNITS+/UN/P.UIT+1,UX
          ADML   UNITS+/UN/P.UIT+2,UX
          ZJN    CHKUD10     IF NOT DUPLICIATE UNIT
          LDK    E208
          UJN    CHKUD30     GO REPORT ERROR

 CHKUD10  LDML   UNITD+/UD/P.UQT+1   UNIT INTERFACE TABLE RMA
          LPN    7
          ZJN    CHKUD20     IF OK
          LDK    E209        UNIT INTERFACE TABLE NOT A WORD BOUNDARY
          UJN    CHKUD30     GO REPORT ERROR

 CHKUD20  LDML   UNITD+/UD/P.UNIT  CHECK PHYSICAL UNIT NUMBER
          SHN    -3
          ZJN    CHKUDX      IF OK, EXIT
          LDK    E210        INVALID PHYSICAL UNIT NUMBER

 CHKUD30  RJM    INTERR      SEND ERROR TO CM (NO RETURN)
          SPACE  5,20
** NAME-- CHKRS
*
** PURPOSE-- CHECK FOR VALID PP RESPONSE BUFFER
          SPACE  2
 CHKRS    SUBR               ENTRY/EXIT
          LDML   PITB+/PIT/P.RSBUF-2  RESERVED WORD OF RESPONSE
                             BUFFER DESCRIPTOR
          ADML   PITB+/PIT/P.RSBUF-1
          ADML   PITB+/PIT/P.RSPVA-1
          NJN    CHKR100     IF RESERVED FIELD NOT ZERO

          LDML   PITB+/PIT/P.IN-3  RESERVED FIELD OF IN POINTER
          ADML   PITB+/PIT/P.IN-2
          ADML   PITB+/PIT/P.IN-1
          NJN    CHKR100     IF RESERVED FIELD NOT ZERO

          LDML   PITB+/PIT/P.OUT-3  RESERVED FIELD OF OUT POINTER
          ADML   PITB+/PIT/P.OUT-2
          ADML   PITB+/PIT/P.OUT-1
          NJN    CHKR100     IF RESERVED FIELD NOT ZERO

          LDML   PITB+/PIT/P.LIMIT-3
          ADML   PITB+/PIT/P.LIMIT-2
          ADML   PITB+/PIT/P.LIMIT-1
          ZJK    CHKRSX      IF RESERVED FIELD NOT ZERO

 CHKR100  LDK    E207        RESERVED FIELD NOT ZERO
          RJM    INTERR      REPORT ERROR (NO RETURN)
          SPACE  5,20
** NAME-- CHKUIT
*
** PURPOSE-- CHECK FOR VALID UNIT INTERFACE TABLE
*
** ENTRY-- UIT IS IN THE TS TABLE FOR THE PP
          SPACE  2
 CHKUIT   SUBR               ENTRY/EXIT
          LDN    0
          STDL   T8
          LDML   UITB+/UIT/P.LU  UIT UNIT NUMBER
          LMML   UNITD+/UD/P.LU  UD UNIT NUMBER
          NJN    CUT100      LOGICAL UNIT NUMBER MISMATCH
          AODL   T8
          LDML   UITB+/UIT/P.UBUFL-1  RESERVED FIELD OF UNIT
                             COMMUNICATION BUFFER DESCRIPTOR
          NJN    CUT100      RESERVED FIELD IS NOT ZERO

          AODL   T8
          LDML   UITB+/UIT/P.UBUFL  UNIT COMMUNICATION BUFFER LENGTH
          LPN    7
          NJN    CUT100
          AODL   T8
          LDML   UITB+/UIT/P.UBUF+1  UNIT COMMUNICATION BUFFER
          LPN    7
          NJN    CUT100      NOT A WORD BOUNDARY
          AODL   T8
          LDML   UITB+/UIT/P.NEXTPV-1  RESERVED FIELD OF UNIT
                             REQUEST QUEUE DESCRIPTOR
          ADML   UITB+/UIT/P.NEXT-2
          ADML   UITB+/UIT/P.NEXT-1
          ZJK    CHKUITX     IF OK

 CUT100   LDML   CUTA,T8     INTERFACE ERROR CODE
          RJM    INTERR      SEND ERROR TO CM (NO RETURN)

 CUTA     BSS
          CON    E301        LOGICAL UNIT NUMBER MISMATCH
          CON    E303        RESERVED FIELD OF UNIT COMMUNICATION
                             BUFFER DESCRIPTOR IS NOT ZERO
          CON    E307        UNIT COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS
          CON    E302        UNIT COMMUNICATION BUFFER NOT A WORD BOUNDARY
          CON    E305        RESERVED FIELD OF UNIT REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 V1       ENDIF
          TITLE  INITIALIZATION
** NAME-- INIT
*
** PURPOSE-- INITIALIZE DRIVER
*
** INPUT-- DSRTP = CM BYTE-ADDRESS OF THE WORD CONTAINING A POINTER
*                  TO THE PP INTERFACE TABLE.
          SPACE  2
 INIT     BSS                ENTRY POINT

* CLEAR MOST OF PP DIRECT CELLS

          LDK    DCCEND      CLEAR DCCEND DOWN THRU P1
          STDL   T8          SET INDIRECT CELL

 INIT10   LDN    0
          STIL   T8          CLEAR DIRECT CELL
          SODL   T8          CHECK FOR DONE
          PJN    INIT10      IF NOT DONE

* CLEAR PP MEMORY LOCATIONS

*    ON DEADSTART, ALL PP LOCATIONS FROM ENDCODE THRU ENDMEM ARE CLEARED.
*    ON RESUME, ALL THE ABOVE EXCEPT THE PP TS TABLE IS CLEARED.

          LDDL   INITFLG     CHECK IF DEADSTART INITIALIZE
          SBN    2
          ZJN    INIT30      IF RESUME

*         PROCESS DEADSTART INITIALIZE
          LDK    ENDMEM-ENDCODE
          STDL   T1          SET INDEX

 INIT20   LDN    0
          STML   ENDCODE,T1  CLR PP WORD
          SODL   T1          DECREMENT INDEX
          PJN    INIT20      IF NOT DONE LOOP
          UJN    INIT60      CONT.

 INIT30   BSS
*         PROCESS RESUME INITIALIZE
          LDK    ENDMEM-TS-P.TS
          STDL   T1          SET INDEX

 INIT40   LDN    0
          STML   TS+P.TS,T1  CLR PP WORD
          SODL   T1          DECREMENT INDEX
          PJN    INIT40      IF NOT DONE LOOP

          LDK    TS-ENDCODE-1
          STDL   T1          SET INDEX

 INIT50   LDN    0
          STML   ENDCODE,T1  CLR PP WORD
          SODL   T1          DECREMENT INDEX
          PJN    INIT50      IF NOT DONE LOOP

*  READ PP-INTERFACE-TABLE AND UNIT DESCRIPTOR TABLES.  NOTE - THIS IS
*  THE ONLY PLACE THE STATIC FIELDS OF THE PIT AND THE UNIT DESCRIPTOR
*  TABLES ARE READ INTO THE PP.  IF THE UNIT DESCRIPTOR TABLES EVER
*  CONTAIN DYNAMIC FIELDS, THEY MUST BE READ IN WHEN LOOKING FOR UNIT
*  REQUESTS.  ONLY UNIT DESCRIPTORS THAT ARE NOT NULL ENTRIES ARE
*  CONVERETED TO *UN* ENTRIES IN THE PP UNITS TABLE.

 INIT60   LDK    C.PIT       LENGTH OF PIT
          STDL   WC
          REFAD  DSRTP,CM.PIT  REFORMAT CM ADDRESS OF PIT
          LOADC  CM.PIT      LOAD R+A OF PIT
          CRML   PITB,WC     READ PIT

*  REFORMAT ADDRESS OF THE INTERRUPT WORD.

          REFAD  PITB+/PIT/P.INT,CM.INT

*  REFORMAT ADDRESS OF CHANNEL TABLE.

          REFAD  PITB+/PIT/P.CHAN,CM.CHAN

*  REFORMAT ADDRESS OF PP COMMUNICATIONS BUFFER

          REFAD  PITB+/PIT/P.CBUF,CM.COM

*  BUILD T REGISTER FORMAT OF COM BUFFER TEST MODE AREA RMA

          LDML   PITB+/PIT/P.CBUF+1  GET ORIGINAL RMA
          ADK    /CB/P.PTD*2  ADJUST WITH OFFSET TO PATH TEST AREA
          STML   CM.CB.T+2  SAVE IT
          SHN    -16
          ADML   PITB+/PIT/P.CBUF
          STML   CM.CB.T+1
          LDN    0           INITIALIZE BYTE COUNT
          STML   CM.CB.T

*  CHECK LENGTH OF COMMUNICATIONS BUFFER

          LDML   PITB+/PIT/P.CBUFL  GET THE LENGTH
          ADK    -B.CB
          PJN    INIT65      IF OK
          LDK    E20B        REPORT LENGTH ERROR
          RJM    INTERR      INTERFACE ERROR  (NO RETURN)
 INIT65   BSS

*  REFORMAT ADDRESS OF RESPONSE BUFFER.
*  INITIALIZE LIM.

          REFAD  PITB+/PIT/P.RSBUF,CM.RS  REFORMAT ADDRESS OF RESP. BUFFER
          LDML   PITB+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STDL   LIM

          LDML   PITB+/PIT/P.PPNO   SET PP NUMBER
          STDL   PPNO

          LDML   TS1         USE PP TS TABLE
          STDL   CTST

          LDDL   INITFLG     CHECK IF INITIALIZATION IS FROM A RESUME
          SBN    2
          NJN    INIT70      IF NOT
          RJM    RERESP      SEND RESUME RESPONSE
 INIT70   BSS

 V2       IFEQ   VALID,1     VALIDATE CPU TABLES/BUFFERS
          RJM    CHKPIT      VALIDATE PIT
          RJM    CHKRS       VALIDATE RESPONSE BUFFER
 V2       ENDIF

          LDN    0           INITIALIZE LOOP CONTROL
          STDL   T2          NUMBER OF NON-NULL UNIT DESCRIPTORS
          STDL   T4          CM WORD OFFSET INTO UNIT DESCRIPTORS
          LDML   PITB+/PIT/P.UNITC  NUMBER OF UNIT DESCRIPTORS
          STDL   T1
          NJN    INIT80      IF UNITS DEFINED
          LDK    E213        NO DEFINED ACTIVE UNITS
          RJM    INTERR      INTERFACE ERROR (NO RETURN)

 INIT80   LOADC  CM.PIT      LOAD R REGISTER FOR PIT
          ADK    C.PIT       ADVANCE TO START OF UNIT DESCRIPTORS
          ADDL   T4          CM WORD OFFSET OF CURRENT UD
          CRML   UNITD,TWO   READ UD ENTRY INTO PP
          SODL   T1          DECREMENT TOTAL UNIT COUNT FROM PIT
          LDML   UNITD+/UD/P.UQT
          ADML   UNITD+/UD/P.UQT+1
          ZJK    INIT110     IF DUMMY ENTRY, DO NOT COUNT

*         BUILD SLAVE AND UNITS TABLE INDEXES

          LDML   UNITD+/UD/P.CNTRLR  GET SLAVE NUMBER
          LPN    7B
          STDL   SX
          LDML   UNITD+/UD/P.CNTRLR  GET PORT NUMBER
          SHN    -3
          LPN    10B
          ADDL   SX
          SHN    2
          STDL   SX          SET SLAVES CONFIGURED INDEX
          SHN    -2
          ADDL   SX
          SHN    3
          STDL   UX          SAVE SLAVE OFFSET FOR UNITS TABLE INDEX
          LDML   UNITD+/UD/P.UNIT  GET FACILITY NUMBER
          LPN    7B
          SHN    2
          RADL   UX
          LDML   UNITD+/UD/P.UNIT
          LPN    7B
          RADL   UX          SET UNITS TABLE INDEX

* CHECK FOR CHANGES IN SL AND UN
          ERRNZ  4-P.SL      IF SL HAS CHANGED
          ERRNZ  5-P.UN      IF UN HAS CHANGED
          ERRNZ  40-FACPSL*P.UN  IF FACILITIES PER SLAVE HAS CHANGED

 V3       IFEQ   VALID,1     VALIDATE CPU TABLES/BUFFERS
          RJM    CHKUD       VALIDATE UNIT DESCRIPTORS
          LDK    C.UIT       READ IN UIT AND VALIDATE
          STDL   WC          SAVE WORD COUNT
          LOADF  UNITD+/UD/P.UQT
          CRML   UITB,WC     READ UIT INTO TRANSIENT BUFFER
          RJM    CHKUIT      VALIDATE UIT
          LDML   UITB+/UIT/P.UTYPE   CHECK UNIT TYPE
          ADK    -T698.1
          ZJN    INIT85      IF OK
          LDK    E306        INVALID UNIT TYPE
          RJM    INTERR      REPORT ERROR  (NO RETURN)
 INIT85   BSS
 V3       ENDIF

* BUILD UNITS TABLE

          LDML   UNITD+/UD/P.LU  LOGICIAL UNIT NUMBER
          STML   UNITS+/UN/P.LU,UX

          LOADF  UNITD+/UD/P.UQT  REFORMAT UIT RMA
          LDDL   CMADR       SAVE REFORMATTED UIT RMA
          STML   UNITS+/UN/P.UIT,UX
          LDDL   CMADR+1
          STML   UNITS+/UN/P.UIT+1,UX
          LDDL   CMADR+2
          STML   UNITS+/UN/P.UIT+2,UX

          LDML   UNITD+/UD/P.CHAN      GET CHANNEL NUMBER
          SHN    /UD/L.CHAN+/UD/N.CHAN+2  POSITION IT
          LPN    37B         MASK IT
          STDL   T3          SAVE IT

          LDDL   T2          CHECK IF FIRST ENTRY
          NJN    INIT90      IF NOT
          LDDL   T3          GET CHANNEL NUMBER
          STDL   CURCH       SET CURRENT CHANNEL

 INIT90   LDDL   T3          COMPARE CHANNEL NUMBERS
          LMDL   CURCH
          ZJN    INIT100     IF THE SAME
          LDK    E20A        INVALID CHANNEL NUMBER
          RJM    INTERR      REPORT ERROR (NO RETURN)

 INIT100  LDML   UNITD+/UD/P.UNIT   GET UNIT NUMBER
          LPN    7B
          STDL   T3          SAVE AS BIT SIGNIFICIANT INDEX
          LMK    /UN/K.CTF   SET CONFIDENCE TESTING REQUIRED FLAG
          STML   UNITS+/UN/P.FN,UX  SET FACILITY NUMBER

          LDML   SELT,T3     GET FACILITY BIT ADDRESS
          LMML   SLB+/SL/P.FBA,SX  MERGE WITH EXISTING FACILITIES
          STML   SLB+/SL/P.FBA,SX  SAVE THE UPDATE

          LDML   UNITD+/UD/P.CNTRLR  GET CONTROLER NUMBER
          LPN    7B
          SHN    /UN/N.FN  POSITION IT
          RAML   UNITS+/UN/P.SN,UX   SET SLAVE NUMBER

          LDML   UNITD+/UD/P.CHAN  GET CHANNEL PORT NUMBER
          LPC    100B        MASK IT
          SHN    3           POSITION IT
          RAML   UNITS+/UN/P.PORT,UX  SAVE PORT NUMBER

          AODL   T2          INCREMENT COUNT OF TOTAL ACTIVE UNITS
          ADK    -MAXUD
          ZJN    INIT120     IF REACHED MAX TABLE SPACE FOR UD-S

 INIT110  LDK    C.UD        INCREMENT TO NEXT CM UD
          RADL   T4
          LDDL   T1          CHECK TOTAL UNITS COUNT FROM PIT
          NJK    INIT80      IF NOT DONE SCANNING UD TABLES

 INIT120  LDDL   T1          CHECK IF MORE UD-S
          ZJN    INIT130     IF NONE LEFT
          LDK    E208        TO MANY CONFIGURED UNITS
          RJM    INTERR      REPORT ERROR  (NO RETURN)

 INIT130  LDDL   T2          RESET NUMBER OF ACTIVE UNITS
          STML   PITB+/PIT/P.UNITC
          NJN    INIT150     IF ANY ACTIVE UNITS DEFINED

          LDN    75B         NO ACTIVE UNITS
          STDL   IDLFLG      FORCE SET IDLE FLAG
*         DO NOT GENERATE ANY RESPONSE, WAIT FOR RESUME COMMAND
          LJM    MAIN        GO TO MAIN

*  INITIALIZE CONFIGURED SLAVES BY BIT ADDRESS (CSLVS)
*  AND TOTAL SLAVES CONFIGURED NUMBER (TSLVS) CELLS.

 INIT150  LDN    MAXSL       INITIALIZE LOOP COUNT
          STDL   T1
          LDN    0           INITIALIZE INDEX
          STDL   T2
          STDL   TSLVS       INIT TOTAL SLAVES CONFIGURED

 INIT160  LDML   SLB+/SL/P.FBA,T2  CHECK IF SLAVE IS CONFIGURED
          ZJN    INIT170     IF NOT
          AODL   TSLVS       INCREMENT TOTAL SLAVES CONFIGURED

 INIT170  LDN    P.SL        INCREMENT INDEX
          RADL   T2
          SODL   T1          CHECK FOR DONE
          NJN    INIT160     IF NOT

* INITIALIZE SLAVE TS TABLES USABLE

          LDN    MCSLV       MAXIMUM CONCURRENT SLAVES TO SUPPORT
          SBDL   TSLVS       TOTAL CONFIGURED SLAVES
          MJN    INIT180     USE MAXIMUM VALUE
          LDDL   TSLVS       ELSE USE TOTAL SLAVES CONFIGURED
          UJN    INIT190

 INIT180  LDN    MCSLV       SET MAXIMUM VALUE

 INIT190  BSS
          STML   TNTAB       SAVE TOTAL NUMBER OF SLAVE TABLES TO SUPPORT

*  INITIALIZE CHANNEL INSTRUCTIONS.

          LDK    CONCH       MODIFY CHANNEL INSTRUCTIONS
          RJM    CHGCH

*  CLEAR PP COMMUNICATIONS BUFFER

          LDN    0           ZERO OUT *ZEROES* FIELD IN COMM. BUFFER
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDK    /CB/B.ZEROES  LENGTH OF ZERO AREA IN BYTES
          SHN    -3
          STDL   T5          LENGTH OF ZERO AREA IN CM WORDS

 INIT200  LOADC  CM.COM      LOAD R AND A OF COMMUNICATION BUFFER
          ADK    /CB/C.ZEROES-1
          ADDL   T5
          CWDL   T1          ZERO ONE CM WORD
          SODL   T5          DECREMENT INDEX
          NJN    INIT200     IF MORE CM WORDS TO CLEAR

* CLEAR REMAINING DIRECT CELLS

          LDN    T8          STARTING ADDRESS
          STDL   T1          SET INDIRECT CELL

 INIT210  LDN    0
          STIL   T1          CLEAR DIRECT CELL
          SODL   T1          CHECK FOR DONE
          PJN    INIT210     IF NOT
          LDN    0           CLEAR THE LAST CELL
          STDL   T1

*  EXIT TO MAIN IDLE LOOP

          LJM    MAIN        EXIT
          TITLE  PP TABLES AND BUFFERS
 CONCH    BSS                CHANNEL MODIFICATION LIST
 TDC+40B  HERE
 T40B+DC  HERE
 TDC      HERE
          CON    0           END OF TABLE
          SPACE  2
* BIT SIGNIFICANT SELECTION ADDRESS TABLE
 SELT     DATA   1,2,4,8     PORT A SLAVES
          DATA   16,32,64,128

          ERRNZ  8-SLVPCH    IF NUMBER OF SLAVES PER CHANNEL CHANGES
          SPACE  2
* SLAVE RESET EXECUTED TABLE, INDEXED BY SLAVE ADDRESS PLUS PORT (SLVN)
 SRTAB    BSSZ   MAXSL       NON ZERO ENTRY = SLAVE RESET EXECUTED
          SPACE  2
* TS TABLE ADDRESSES
 TS1      CON    TS          PP TS TABLE
 TS2      CON    TS+1*P.TS   FIRST SLAVE TS TABLE
 TS3      CON    TS+2*P.TS   NEXT TABLE

          ERRNZ  3-MAXTS     IF NUMBER OF TS TABLES CHANGE
          SPACE  2
 ENDCODE  EQU    *           END OF PP CODE AREA

 FH2      IFEQ   FH,1        FUNCTION HISTORY TABLE
          SPACE  2
*
*         WORKING MEMORY
*
 FBUF     BSSZ   64          FUNCTION HISTORY BUFFER
 FBUFL    EQU    *-FBUF      FUNCTION HISTORY BUFFER LENGTH
 FH2      ENDIF
 KHTAB    EQU    KH+KHC+KHR
 KH3      IFNE   KHTAB,0     COMMAND/RESPONSE HISTORY
          SPACE  2
 HB       BSSZ   80          IPI COMMAND/RESPONSE HISTORY BUFFER
*         HB LENGTH MUST BE A MULTIPLE OF 8
 HBL      EQU    *-HB        HISTORY BUFFER LENGTH
 KH3      ENDIF
          SPACE  2
*
*         CHECK FOR BUFFER OVERLAP
*
          ERRNG  STRTBUF-*
          EJECT
          END
/EOR

*DECK DECK=IOM$ENABLE_ALL_DISK_UNITS EXPAND=TRUE

MODULE iom$enable_all_disk_units;
MODEND iom$enable_all_disk_units;
*DECK DECK=IOM$EXCEPTION_CONDITIONS EXPAND=TRUE
MODULE iomecc;
*copyc IODECC
MODEND
*DECK DECK=IOM$IDLE EXPAND=TRUE
*DECK DECK=IOM$IDLE_ALL_PATHS EXPAND=TRUE
*DECK DECK=IOM$IDLE_PATH EXPAND=TRUE
*DECK DECK=IOM$INITIALIZE_SECTORS EXPAND=TRUE

MODULE iom$initialize_sectors;

*copyc osd$default_pragmats
*copyc iot$cylinders_to_initialize
*copyc iot$logical_unit
*copyc iot$io_function
*copyc dmt$ms_logical_device_address
*copyc iot$completion_status
*copyc ost$hardware_subranges
*copyc osk$keypoints
*copyc iok$keypoints
*copyc iop$mass_storage_io
*copyc osv$mainframe_wired_cb_heap
*copyc ost$status
*copyc ioe$st_errors


  PROCEDURE [XDCL, #GATE] iop$initialize_sectors (logical_unit:
    iot$logical_unit;
        cylinders: array [ * ] OF iot$cylinders_to_initialize;
    VAR status: ost$status);

    VAR
      initialize_sector_list_p: ^iot$initialize_sector_list,
      length: ost$byte_count,
      io_function: iot$io_function,
      i: integer,
      device_address: dmt$ms_logical_device_address,
      completion_status: iot$completion_status,
      p_completion_status: ^iot$completion_status;


    status.normal := TRUE;

    ALLOCATE initialize_sector_list_p: [1 .. UPPERBOUND (cylinders)] IN
          osv$mainframe_wired_cb_heap^;

    FOR i := 1 TO UPPERBOUND (cylinders) DO
      initialize_sector_list_p^.list [i].cylinders := cylinders [i];
      initialize_sector_list_p^.list [i].fill1 := 0;
    FOREND;
    length := #SIZE (initialize_sector_list_p^);
    io_function := ioc$initialize_sectors;
    device_address.allocation_unit_mau_address := 0;
    device_address.maus_per_position := 264;
    device_address.logical_unit_number := logical_unit;
    device_address.transfer_length := length;
    device_address.transfer_mau_offset := 0;
    device_address.write_translation := TRUE;
    device_address.au_was_previously_written := TRUE;
    device_address.preset_value := 0;
    completion_status := 0;
    p_completion_status := ^completion_status;

    iop$mass_storage_io (initialize_sector_list_p, length, io_function,
          device_address, TRUE, p_completion_status, status);

    FREE initialize_sector_list_p IN osv$mainframe_wired_cb_heap^;



  PROCEND iop$initialize_sectors;
MODEND iom$initialize_sectors;
*DECK DECK=IOM$LOG_DISK_DATA EXPAND=TRUE
MODULE iom$log_disk_data;

*copyc osd$default_pragmats
*copyc sfp$activate_system_statistic
*copyc sfp$emit_statistic
*copyc cmp$return_descriptor_data
*copyc iot$unit_type
*copyc iot$disk_statistics
*copyc iot$pp_response
*copyc oss$job_paged_literal
*copyc ost$status
*copyc cml$disk_device_usage_data
*copyc cml$disk_path_usage_data
*copyc cml$end_disk_usage_interval
?? EJECT ??
*copyc oss$task_shared
*copyc iov$disk_pp_usage_p
*copyc iov$disk_unit_usage_p

  VAR
    iov$time_to_log_usage_stats: [XDCL, oss$task_shared] integer := 0;

  PROCEDURE establish_statistics (VAR status: ost$status);

    CONST
      number_of_statistics = 7;

    VAR
      statistics: array [1 .. number_of_statistics] of sft$statistic_code,
      i: integer;


    statistics [1] := cml$10395_11_failure_data;
    statistics [2] := cml$7154_failure_data;
    statistics [3] := cml$7155_1x_failure_data;
    statistics [4] := cml$fa7b4_d_failure_data;
    statistics [5] := cml$7165_2x_failure_data;
    statistics [6] := cml$887_failure_data;
    statistics [7] := cml$9836_1_failure_data;

    FOR i := 1 TO number_of_statistics DO
      sfp$activate_system_statistic (statistics [i], $sft$binary_logset [pmc$engineering_log], status);
      IF status.normal = FALSE THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND establish_statistics;



  PROCEDURE [XDCL] iop$log_disk_data (p_datap: ^SEQ ( * );
    VAR status: ost$status);

    CONST
      status_length = ioc$disk_detailed_status_length * 4;

    VAR
      datap: ^SEQ ( * ),
      i: integer,
      j: integer,
      cell_p: ^cell,
      packets_p: ^array [0 .. 38] of ost$word,
      status_bytes_p: ^array [1 .. status_length] of 0 .. 0ffff(16),
      seq_p: ^SEQ ( * ),
      detail_status: SEQ (REP status_length of 0 .. 0ffff(16)),
      detailed_status_p: ^iot$common_disk_status,
      disk_885_status_p: ^iot$disk_detailed_status_885,
      disk_895_status_p: ^iot$895_detailed_status,
      hydra_status_p: ^iot$hydra_status,
      disk_9836_status_p: ^iot$detailed_status_9836_1,
      statistics_established: [STATIC] boolean := FALSE,
      length: integer,
      disk_log_data_p: ^iot$disk_log_data,
      counters_p: ^array [1 .. * ] of sft$counter,
      counters_p2: ^array [1 .. * ] of sft$counter,
      statistic_code: sft$statistic_code,
      symptom_code: integer,
      descriptor_data: ost$string,
      pp_number: 0 .. 0ff(16),
      iou_number: dst$iou_number,
      channel: cmt$physical_channel,
      equipment: cmt$physical_equipment_number,
      logical_unit: iot$logical_unit;


    status.normal := TRUE;
    IF NOT statistics_established THEN
      establish_statistics (status);
      IF status.normal THEN
        statistics_established := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;
    datap := p_datap;

    NEXT disk_log_data_p IN datap;

    seq_p := ^detail_status;
    RESET seq_p;
    NEXT detailed_status_p IN seq_p;
    detailed_status_p^ := disk_log_data_p^.detailed_status;
    RESET seq_p;
    NEXT status_bytes_p IN seq_p;
    RESET seq_p;
    NEXT disk_885_status_p IN seq_p;
    RESET seq_p;
    NEXT disk_895_status_p IN seq_p;
    RESET seq_p;
    NEXT disk_9836_status_p IN seq_p;

{Get descriptor data.

    iou_number := disk_log_data_p^.iou_number;
    channel := disk_log_data_p^.channel;
    equipment := disk_log_data_p^.equipment;
    logical_unit := disk_log_data_p^.logical_unit;

    cmp$return_descriptor_data (channel, iou_number, equipment, logical_unit,
          descriptor_data, pp_number);


    CASE disk_log_data_p^.controller_type OF
    = 1 =
      statistic_code := cml$7154_failure_data;
    = 2 =
      statistic_code := cml$7155_1x_failure_data;
    = 3 =
      statistic_code := cml$10395_11_failure_data;
    = 4 =
      statistic_code := cml$fa7b4_d_failure_data;
    = 5 =
      statistic_code := cml$7165_2x_failure_data;
    = 6 =
      statistic_code := cml$887_failure_data;
    = 7, 8 =
      statistic_code := cml$9836_1_failure_data;
    ELSE
    CASEND;


    CASE statistic_code OF
    = cml$7154_failure_data, cml$7155_1x_failure_data, cml$10395_11_failure_data,
      cml$fa7b4_d_failure_data =
      IF disk_log_data_p^.failure_severity = 0 THEN
        length := 39;
      ELSE
        length := 60;
      IFEND;
    = cml$7165_2x_failure_data =
      IF disk_log_data_p^.failure_severity = 0 THEN
        length := 40;
      ELSE
        length := 62;
      IFEND;
    = cml$887_failure_data =
      length := 59;
    = cml$9836_1_failure_data =
      length := 40;
    ELSE
    CASEND;

    PUSH counters_p: [1 .. length];

    {   Set counter [1] to the PP number. Set bit 57 for an I4 concurrent PP.
    {                                     Set bits 46 - 51 to IOU number.
    {   Set counter [2] to the Channel number.  Set bit 57 if an I4 concurrent channel.
    {                                           Set bit 56 if I4 concurrent PORT B.
    {                                           Set bit 55 if I4 concurrent PORT A.
    {                                           Set bits 46 - 51 to IOU number.
    CASE disk_log_data_p^.channel.port OF
    = cmc$port_a =
      counters_p^ [1] := pp_number + 40(16);
      counters_p^ [2] := disk_log_data_p^.channel.number + 40(16) + 100(16);
    = cmc$port_b =
      counters_p^ [1] := pp_number + 40(16);
      counters_p^ [2] := disk_log_data_p^.channel.number + 40(16) + 80(16);
    ELSE
      IF channel.concurrent THEN
        counters_p^ [1] := pp_number + 40(16);
        counters_p^ [2] := disk_log_data_p^.channel.number + 40(16);
      ELSE
        counters_p^ [1] := pp_number;
        counters_p^ [2] := disk_log_data_p^.channel.number;
      IFEND;
    CASEND;
    counters_p^ [1] := counters_p^ [1] + iou_number * 1000(16);
    counters_p^ [2] := counters_p^ [2] + iou_number * 1000(16);

    CASE disk_log_data_p^.disk_type OF
    = ioc$dt_ms895_2 =
      counters_p^ [3] := disk_log_data_p^.equipment * 2;
      counters_p^ [4] := disk_log_data_p^.physical_unit;
      IF disk_log_data_p^.physical_unit > 15 THEN
        counters_p^ [3] := counters_p^ [3] + 1;
        counters_p^ [4] := counters_p^ [4] - 16;
      IFEND;
    ELSE
      counters_p^ [3] := disk_log_data_p^.equipment;
      counters_p^ [4] := disk_log_data_p^.physical_unit;
    CASEND;

    counters_p^ [5] := disk_log_data_p^.disk_type MOD 100(16);
    IF counters_p^ [5] < 2 THEN
      counters_p^ [5] := counters_p^ [5] + 1;
    IFEND;

    counters_p^ [6] := disk_log_data_p^.logical_operation;

    counters_p^ [7] := disk_log_data_p^.failure_severity;
    IF (counters_p^[7] = 1) AND (statistic_code = cml$9836_1_failure_data) THEN
      counters_p^ [7] := disk_log_data_p^.isolation_code * 10000(16) + counters_p^ [7];
    IFEND;
    IF (statistic_code = cml$9836_1_failure_data) AND (disk_log_data_p^.isolation_code = 4) THEN
      counters_p^ [7] := 40001(16);
    IFEND;

    counters_p^ [8] := disk_log_data_p^.symptom_code;

    counters_p^ [9] := disk_log_data_p^.detailed_status.general_status.
          request_retry;
    CASE statistic_code OF
    = cml$7154_failure_data, cml$7155_1x_failure_data =
      counters_p^ [10] := disk_log_data_p^.detailed_status.general_status.
            sector_retry_count;
    = cml$10395_11_failure_data, cml$fa7b4_d_failure_data, cml$887_failure_data,
      cml$7165_2x_failure_data =
      counters_p^ [10] := 0;
    = cml$9836_1_failure_data =
      IF (disk_log_data_p^.diagnostic_code = 0) OR (counters_p^ [8] = ioc$9836_1_cont_diag_passed_2)
          OR (disk_log_data_p^.diagnostic_code DIV 10000(16) = 80(16)) THEN
        counters_p^ [10] := ioc$no_value;
      ELSE
        counters_p^ [10] := disk_log_data_p^.diagnostic_code;
      IFEND;
    ELSE
      counters_p^ [10] := ioc$no_value;
    CASEND;
    counters_p^ [11] := disk_log_data_p^.detailed_status.general_status.
          starting_cylinder;
    counters_p^ [12] := disk_log_data_p^.detailed_status.general_status.
          starting_track;
    counters_p^ [13] := disk_log_data_p^.detailed_status.general_status.
          starting_sector;
    counters_p^ [14] := disk_log_data_p^.detailed_status.general_status.
          starting_cylinder;
    counters_p^ [15] := disk_log_data_p^.detailed_status.general_status.
          failing_track;
    counters_p^ [16] := disk_log_data_p^.detailed_status.general_status.
          failing_sector;
    IF statistic_code = cml$9836_1_failure_data THEN
      counters_p^ [17] := disk_9836_status_p^.residual_word_count;
    ELSE
      IF disk_log_data_p^.detailed_status.general_status.
            incomplete_sector_transfer THEN
        counters_p^ [17] := disk_log_data_p^.detailed_status.general_status.
            function_timeout;
      ELSE
        counters_p^ [17] := ioc$no_value;
      IFEND;
    IFEND;
    IF statistic_code = cml$9836_1_failure_data THEN
      counters_p^ [18] := disk_9836_status_p^.failing_function;
    ELSE
      IF disk_log_data_p^.pp_response.abnormal_status.function_timeout THEN
        counters_p^ [18] := disk_log_data_p^.detailed_status.general_status.
            function_timeout;
      ELSEIF statistic_code <> cml$887_failure_data THEN
        IF disk_log_data_p^.detailed_status.general_status.
            detailed_status_present THEN
          counters_p^ [18] := disk_885_status_p^.part1.pp_command;
        ELSE
          counters_p^ [18] := ioc$no_value;
        IFEND;
      ELSE
        counters_p^ [18] := ioc$no_value;
      IFEND;
    IFEND;

{Log general and detailed status.

    CASE statistic_code OF
    = cml$7154_failure_data, cml$7155_1x_failure_data, cml$10395_11_failure_data,
      cml$fa7b4_d_failure_data =
      counters_p^ [19] := disk_log_data_p^.detailed_status.general_status.
            first_general_status;
      IF disk_log_data_p^.failure_severity <> 0 THEN
        counters_p^ [40] := disk_log_data_p^.detailed_status.general_status.
              last_general_status;
      IFEND;

      FOR i := 1 TO 20 DO
        counters_p^ [19 + i] := status_bytes_p^ [16 + i];
        IF disk_log_data_p^.failure_severity <> 0 THEN
          counters_p^ [40 + i] := status_bytes_p^ [36 + i];
        IFEND;
      FOREND;
    = cml$7165_2x_failure_data =
      counters_p^ [19] := disk_log_data_p^.detailed_status.general_status.
            first_general_status;
      IF disk_log_data_p^.channel.concurrent THEN
        counters_p^ [40] := disk_895_status_p^.op_status * 10000(16) +
              disk_895_status_p^.first_error_register;
      ELSE
        counters_p^ [40] := ioc$no_value;
      IFEND;

      FOR i := 1 TO 20 DO
        counters_p^ [19 + i] := status_bytes_p^ [20 + i];
      FOREND;

      IF disk_log_data_p^.failure_severity <> 0 THEN
        FOR i := 1 TO 22 DO
          counters_p^ [40 + i] := counters_p^ [18+i];
        FOREND;
      IFEND;
    = cml$887_failure_data =
      RESET seq_p;
      NEXT hydra_status_p IN seq_p;

      counters_p^ [19] := status_bytes_p^ [9];
      counters_p^ [20] := status_bytes_p^ [10];
      counters_p^ [21] := status_bytes_p^ [11];
      counters_p^ [22] := status_bytes_p^ [16];
      counters_p^ [23] := status_bytes_p^ [13];
      counters_p^ [24] := hydra_status_p^.operational_status;
      counters_p^ [25] := hydra_status_p^.t_register;
      counters_p^ [26] := hydra_status_p^.control_register;
      counters_p^ [27] := hydra_status_p^.flag_mask_register;
      counters_p^ [28] := hydra_status_p^.idle_status;
      counters_p^ [29] := hydra_status_p^.bit_significant_response;
      counters_p^ [30] := (((((status_bytes_p^ [25] * 10000(16)) + status_bytes_p^ [26]) * 10000(16))
                          + status_bytes_p^ [27]) * 10000(16)) + status_bytes_p^ [28];
      counters_p^ [31] := ((status_bytes_p^ [29] * 10000(16)) + status_bytes_p^ [30]) * 100000000(16);
      counters_p^ [32] := (((((status_bytes_p^ [31] * 10000(16)) + status_bytes_p^ [32]) * 10000(16))
                          + status_bytes_p^ [33]) * 10000(16)) + status_bytes_p^ [34];
      counters_p^ [33] := (((((status_bytes_p^ [35] * 10000(16)) + status_bytes_p^ [36]) * 10000(16))
                          + status_bytes_p^ [37]) * 10000(16)) + status_bytes_p^ [38];
      counters_p^ [34] := ((status_bytes_p^ [39] * 10000(16)) + status_bytes_p^ [40]) * 100000000(16);
      counters_p^ [35] := (((((status_bytes_p^ [41] * 10000(16)) + status_bytes_p^ [42]) * 10000(16))
                          + status_bytes_p^ [43]) * 10000(16)) + status_bytes_p^ [44];
      FOR i := 1 TO 12 DO
        counters_p^ [35+i] := hydra_status_p^.error_register_image [i];
      FOREND;
      FOR i := 1 TO 12 DO
        counters_p^ [47+i] := hydra_status_p^.error_log [i];
      FOREND;
    = cml$9836_1_failure_data =
      counters_p^ [19] := disk_9836_status_p^.ipi_channel_status_register;
      counters_p^ [20] := disk_9836_status_p^.ipi_channel_error_register;
      IF disk_log_data_p^.channel.concurrent THEN
        counters_p^ [21] := disk_9836_status_p^.ipi_dma_error_register;
        counters_p^ [22] := disk_9836_status_p^.operational_status_register;
        counters_p^ [23] := disk_9836_status_p^.control_register;
      ELSE
        counters_p^ [21] := ioc$no_value;
        counters_p^ [22] := ioc$no_value;
        counters_p^ [23] := ioc$no_value;
      IFEND;
      IF disk_log_data_p^.controller_type = 8 THEN
        counters_p^ [24] := disk_9836_status_p^.microcode_revision * 10000(16) +
                            disk_9836_status_p^.lower_code_part_number;
      ELSE
        counters_p^ [24] := disk_9836_status_p^.microcode_revision;
      IFEND;
      cell_p := ^disk_9836_status_p^.response_packets;
      packets_p := cell_p;
      FOR i := 0 TO 15 DO
        counters_p^ [25 + i] := packets_p^ [i];
      FOREND;
    ELSE
    CASEND;

    iop$emit_statistic (statistic_code, counters_p, descriptor_data,
          disk_log_data_p, status);

  PROCEND iop$log_disk_data;


  PROCEDURE [XDCL] iop$log_usage_statistics;

    CONST
      emit_usage_interval = 30*60000000, { 30 minutes in micro-seconds}
      number_of_statistics = 3;

    VAR
      countu: array [1 .. 3] of integer,
      countc: array [1 .. 2] of integer,
      unit: integer,
      channel: cmt$physical_channel,
      usage_log_enabled: [STATIC] boolean := FALSE,
      statistics: array [1 .. number_of_statistics] of sft$statistic_code,
      status: ost$status,
      descriptor_data: ost$string,
      mainframe_data: ost$string,
      path_data: ost$string,
      unit_data: ost$string,
      size1: integer,
      size2: integer,
      channel_msg_p: ^string (*),
      unit_msg_p: ^string (*),
      end_msg_p: ^string(*),
      path_count: integer,
      path_index: integer,
      field_count: integer,
      i: integer,
      pp_number: 0 .. 0ff(16),
      pp: 1 .. ioc$pp_count,
      port_index: 0 .. 1,
      iou_number: dst$iou_number,
      active_pp: ^iot$disk_pp_usage,
      active_unit: ^iot$disk_unit_usage,
      equipment: 0 .. 7;

    IF not usage_log_enabled THEN
      statistics [1] := cml$disk_device_usage_data;
      statistics [2] := cml$disk_path_usage_data;
      statistics [3] := cml$end_disk_usage_interval;
      FOR i:= 1 TO number_of_statistics DO
        sfp$activate_system_statistic (statistics [i], $sft$binary_logset [pmc$engineering_log], status);
        IF not status.normal THEN
          RETURN;
        IFEND;
      FOREND;
      usage_log_enabled := TRUE;
      iov$time_to_log_usage_stats := #free_running_clock (0) +
          emit_usage_interval;
      RETURN;
    IFEND;
    iov$time_to_log_usage_stats := iov$time_to_log_usage_stats +
          emit_usage_interval;
    IF (iov$disk_unit_usage_p = NIL) OR (iov$disk_pp_usage_p = NIL) THEN
      RETURN;
    IFEND;
    FOR pp := LOWERBOUND (iov$disk_pp_usage_p^) TO UPPERBOUND (iov$disk_pp_usage_p^) DO
      active_pp := iov$disk_pp_usage_p^ [pp];
      IF active_pp <> NIL THEN
        iou_number := active_pp^.iou_number;
        channel := active_pp^.channel;
        FOR port_index := 0 TO 1 Do
          FOR equipment := 0 TO 7 DO
            IF active_pp^.path_usage [port_index] [equipment].path_used THEN
              unit := active_pp^.path_usage [port_index] [equipment].logical_unit;
              countc [1] := active_pp^.path_usage [port_index] [equipment].read_maus +
                  active_pp^.path_usage [port_index] [equipment].written_and_preset_maus;
              countc [2] := active_pp^.path_usage [port_index] [equipment].read_requests +
                  active_pp^.path_usage [port_index] [equipment].write_requests;
              cmp$return_descriptor_data (channel, iou_number, equipment, unit,
                  descriptor_data, pp_number);
              get_mainframe_string (descriptor_data, mainframe_data);
              get_path_string (descriptor_data, 4, path_data);
              size1  := mainframe_data.size;
              size2 := path_data.size;
              PUSH channel_msg_p:[size1 + size2 + 1];
              channel_msg_p^ (1, size1) := mainframe_data.value (1, size1);
              channel_msg_p^ (size1+1, 1) := '.';
              channel_msg_p^ (size1+2, size2) := path_data.value (1, size2);
              sfp$emit_statistic (cml$disk_path_usage_data, channel_msg_p^, ^countc, status);
            IFEND;
          FOREND;
        FOREND;
      IFEND;
    FOREND;
    FOR unit := 1 TO UPPERBOUND (iov$disk_unit_usage_p^) DO
      active_unit := iov$disk_unit_usage_p^ [unit];
      IF active_unit <> NIL THEN
        IF active_unit^.unit_used THEN
          countu [1] := active_unit^.read_mau_count + active_unit^.swap_in_mau_count;
          countu [2] := active_unit^.write_data_mau_count + active_unit^.write_data_and_preset_maus +
                        active_unit^.swap_out_data_mau_count + active_unit^.swap_out_data_and_preset_maus;
          countu [3] := active_unit^.read_requests + active_unit^.write_requests +
              active_unit^.swap_in_requests + active_unit^.swap_out_requests;
          iou_number := active_unit^.iou_number;
          channel := active_unit^.channel;
          equipment := active_unit^.equipment;
          IF active_unit^.unit_type = ioc$dt_mshydra THEN
            field_count := 3;
          ELSE
            field_count := 4;
          IFEND;
          cmp$return_descriptor_data (channel, iou_number, equipment, unit,
              descriptor_data, pp_number);
          get_mainframe_string (descriptor_data, mainframe_data);
          get_unit_string (descriptor_data, field_count, unit_data);
          size1  := mainframe_data.size;
          size2 := unit_data.size;
          PUSH unit_msg_p:[size1 + size2 + 1];
          unit_msg_p^ (1, size1) := mainframe_data.value (1, size1);
          unit_msg_p^ (size1+1, 1) := '.';
          unit_msg_p^ (size1+2, size2) := unit_data.value (1, size2);
          sfp$emit_statistic (cml$disk_device_usage_data, unit_msg_p^, ^countu, status);
        IFEND;
      IFEND;
    FOREND;
    size1 := mainframe_data.size;
    push end_msg_p: [size1 + 24];
    end_msg_p^(1,size1) := mainframe_data.value(1,size1);
    end_msg_p^(size1+1,24) := '*END DISK USAGE INTERVAL';
    sfp$emit_statistic (cml$end_disk_usage_interval, end_msg_p^, NIL, status);
  PROCEND iop$log_usage_statistics;


  PROCEDURE get_mainframe_string (
        descriptor_data: ost$string;
    VAR mainframe_data: ost$string);

    VAR
      i: integer,
      period_found: boolean,
      size: integer;

    i := 0;
    period_found := FALSE;
    size := descriptor_data.size;
    IF size < 0 THEN
      size := 0;
    IFEND;
    IF size > 1 THEN
   /first_period/
      FOR i := 1 TO size DO
        IF descriptor_data.value (i, 1) = '.' THEN
          period_found := TRUE;
          EXIT /first_period/;
        IFEND;
      FOREND /first_period/;
    IFEND;
    IF period_found AND (i > 1) THEN
      mainframe_data.value (1, i - 1) := descriptor_data.value (1, i - 1);
      mainframe_data.size := i - 1;
    ELSEIF size > 0 THEN
      mainframe_data.value (1, size) := descriptor_data.value (1, size);
      mainframe_data.size := size;
    ELSE
      mainframe_data.value (1, 17) := 'UNKNOWN_MAINFRAME';
      mainframe_data.size := 17;
    IFEND;
  PROCEND get_mainframe_string;


  PROCEDURE get_unit_string (
        descriptor_data: ost$string;
        field_count: integer;
    VAR unit_data: ost$string);

    VAR
      i: integer,
      j: integer,
      unit_found: boolean,
      size: integer,
      new_size: integer;

    i := 0;
    size := descriptor_data.size;
    IF size < 0 THEN
      size := 0;
    IFEND;
    unit_found := FALSE;
    IF size > field_count+2 THEN
      j := 0;
    /skip_path_fields/
      FOR i := 1 TO size DO
        IF descriptor_data.value(i, 1) = '.' THEN
          j := j + 1;
          IF j = field_count + 1 THEN
            unit_found := TRUE;
            EXIT /skip_path_fields/;
          IFEND;
        IFEND;
      FOREND /skip_path_fields/;
    IFEND;
    new_size := size - i;
    IF unit_found AND (new_size > 0) AND (i > 0) THEN
      unit_data.value (1, new_size) := descriptor_data.value (i + 1, new_size);
      unit_data.size := new_size;
    ELSEIF size > 0 THEN
      unit_data.value (1, size) := descriptor_data.value (1, size);
      unit_data.size := size;
    ELSE
      unit_data.value (1, 19) := 'UNKNOWN_UNIT*UUUUUU';
      unit_data.size := 19;
    IFEND;
  PROCEND get_unit_string;


  PROCEDURE get_path_string (
        descriptor_data: ost$string;
        field_count: integer;
    VAR path_data: ost$string);

    VAR
      length: integer,
      i: integer,
      j: integer,
      path_found: boolean,
      size: integer,
      start: integer;

    size := descriptor_data.size;
    start := 0;
    i := 0;
    IF size < 0 THEN
      size := 0;
    IFEND;
    path_found := FALSE;
    IF size > field_count+2 THEN
    /find_first_period/
      FOR i := 1 TO size DO
        IF descriptor_data.value(i, 1) = '.' THEN
          EXIT /find_first_period/;
        IFEND;
      FOREND /find_first_period/;
      start := i + 1;
      IF start < size THEN
        j := 0;
      /find_path_fields/
        FOR i := start TO size DO
          IF (descriptor_data.value (i, 1) = '.') OR
             (descriptor_data.value (i, 1) = '*') THEN
            j := j + 1;
            IF j = field_count THEN
              path_found := TRUE;
              EXIT /find_path_fields/;
            IFEND;
          IFEND;
        FOREND /find_path_fields/;
      IFEND;
    IFEND;
    length := i - start;
    IF path_found AND (length > 0) AND (start > 0) AND (i <= size) THEN
      path_data.value (1, length) := descriptor_data.value (start, length);
      path_data.size := length;
    ELSEIF size > 0 THEN
      path_data.value (1, size) := descriptor_data.value (1,size);
      path_data.size := size;
    ELSE
      path_data.value (1, 46) := 'UNKNOWN_IOU.UNKNOWN_PP.UNKNOWN_CH.UNKNOWN_CONT';
      path_data.size := 46;
    IFEND;
  PROCEND get_path_string;


  PROCEDURE iop$emit_statistic (statistic_code: sft$statistic_code;
        counters_p: ^array [1 .. * ] OF sft$counter;
        descriptor_data: ost$string;
        disk_log_data_p: ^iot$disk_log_data;
    VAR status: ost$status);

    CONST
      symptom_length = 56;

    VAR
      msg: string (symptom_length),
      das_type: [STATIC] string(136) := '5832_1  5832_2  'cat
                                        '5833_1  5833_1P 5833_2  5833_3P 5833_4  'cat
                                        '5838_1  5838_1P 5838_2  5838_3P 5838_4  'cat
                                        '47444_1 47444_1P47444_2 47444_3P47444_4 ',
      size: integer,
      m_length: integer,
      message_p: ^string ( * ),
      i: integer,
      j: integer,
      k: integer;


    status.normal := TRUE;

{Create symptom message.

    CASE statistic_code OF
    = cml$887_failure_data =
      CASE counters_p^ [8] OF
      = ioc$hydra_indeterminate =
        msg := 'INDETERMINATE';
      = ioc$h_exec_level_i_diagnostics =
        msg := 'EXECUTING LEVEL I DIAGNOSTICS';
      = ioc$h_lev_i_diagnostics_passed =
        msg := 'LEVEL I DIAGNOSTICS PASSED';
      = ioc$h_exec_level_ii_diagnostics =
        msg := 'EXECUTING LEVEL II DIAGNOSTICS';
      = ioc$h_lev_ii_diagnostics_passed =
        msg := 'LEVEL II DIAGNOSTICS PASSED';
      = ioc$h_spindle_powered_up =
        msg := 'SPINDLE POWERED UP';
      = ioc$h_sector_size_not_4096 =
        msg := 'SECTOR SIZE IS NOT 4096';
      = ioc$h_not_same_host_id =
        msg := 'HOST IDS ARE DIFFERENT';
      = ioc$h_function_timeout =
        msg := 'FUNCTION TIMEOUT';
      = ioc$h_channel_doesnt_go_empty =
        msg := 'CHANNEL DOESNT GO EMPTY';
      = ioc$h_incomplete_i4_transfer =
        msg := 'INCOMPLETE I4 TRANSFER';
      = ioc$h_pp_timed_out_a_command =
        msg := 'PP TIMED OUT A COMMAND';
      = ioc$h_cannot_select_controller =
        msg := 'CANNOT SELECT THE CONTROLLER';
      = ioc$h_incorrect_controller =
        msg := 'INCORRECT CONTROLLER WAS SELECTED';
      = ioc$h_channel_init_error =
        msg := 'CHANNEL INITIALIZATION ERROR';
      = ioc$h_controller_reserved =
        msg := 'CONTROLLER RESERVED';
      = ioc$h_software_failure =
        msg := 'SOFTWARE FAILURE';
      = ioc$h_drive_not_ready =
        msg := 'DRIVE NOT READY - MIC1';
      = ioc$h_media_failure =
        msg := 'MEDIA FAILURE - C    T   S  ';
        iop$ascii_decimal (^msg (18, * ), 3, counters_p^ [14]);
        iop$ascii_decimal (^msg (23, * ), 2, counters_p^ [15]);
        iop$ascii_decimal (^msg (27, * ), 2, counters_p^ [16]);
      = ioc$h_uncorrected_cm_error =
        msg := 'UNCORRECTED CM ERROR';
      = ioc$h_cm_reject =
        msg := 'CM REJECT';
      = ioc$h_invalid_response_code =
        msg := 'INVALID CM RESPONSE CODE';
      = ioc$h_cm_response_code_pe =
        msg := 'CM RESPONSE CODE PARITY ERROR';
      = ioc$h_cmi_read_data_pe =
        msg := 'CMI READ DATA PARITY ERROR';
      = ioc$h_input_buffer_overflow =
        msg := 'INPUT BUFFER OVERFLOW';
      = ioc$h_isi_input_error =
        msg := 'ISI INPUT ERROR';
      = ioc$h_isi_timeout =
        msg := 'ISI TIMEOUT';
      = ioc$h_jp_jy_data_parity_error =
        msg := 'JP/JY DATA PARITY ERROR';
      = ioc$h_bas_parity_error =
        msg := 'BAS PARITY ERROR';
      = ioc$h_output_isi_parity =
        msg := 'OUTPUT ISI PARITY ERROR';
      = ioc$h_jz_error =
        msg := 'JZ ERROR';
      = ioc$h_jp_jy_error =
        msg := 'JP/JY ERROR';
      = ioc$h_jn_jx_error =
        msg := 'JN/JX ERROR';
      = ioc$h_incomplete_dma_transfer =
        msg := 'INCOMPLETE DMA TRANSFER';
      = ioc$h_t_register_byte_count =
        msg := 'T REGISTER BYTE COUNT NONZERO';
      = ioc$h_invalid_controller_status =
        msg := 'INVALID CONTROLLER STATUS';
      = ioc$h_controller_interface_err =
        msg := 'CONTROLLER INTERFACE ERROR';
      = ioc$h_seek_error =
        msg := 'SEEK ERROR - SI21';
      = ioc$h_unable_to_read_header =
        msg := 'UNABLE TO READ HEADER - SI41';
      = ioc$h_header_miscompare =
        msg := 'HEADER MISCOMPARE - SI42';
      = ioc$h_unable_to_read_data =
        msg := 'UNABLE TO READ DATA - SI43';
      = ioc$h_transfer_count_error =
        msg := 'TRANSFER COUNT ERROR - SI68';
      = ioc$h_disk_not_formatted =
        msg := 'DISK NOT FORMATTED - SI82';
      = ioc$h_diagnostic_fault_detected =
        msg := 'DIAGNOSTIC FAULT DETECTED';
      = ioc$h_command_block_negated =
        msg := 'COMMAND BLOCK NEGATED - SIC1';
      = ioc$h_command_block_overwrite =
        msg := 'COMMAND BLOCK OVERWRITE - MI21';
      = ioc$h_illegal_command_byte =
        msg := 'ILLEGAL COMMAND BYTE - MI22';
      = ioc$h_illegal_sec_seek_address =
        msg := 'ILLEGAL SECONDARY SEEK ADDRESS - MI23';
      = ioc$h_illegal_pri_seek_address =
        msg := 'ILLEGAL PRIMARY SEEK ADDRESS - MI24';
      = ioc$h_illegal_command_parameter =
        msg := 'ILLEGAL COMMAND PARAMETER - MI25';
      = ioc$h_io_illegal_write_error =
        msg := 'I/O ILLEGAL WRITE ERROR - MI27';
      = ioc$h_end_of_disk_reached =
        msg := 'END OF DISK REACHED - MI28';
      = ioc$h_illegal_device_number =
        msg := 'ILLEGAL DEVICE NUMBER - MI29';
      = ioc$h_illegal_control_field =
        msg := 'ILLEGAL CONTROL FIELD - MI2A';
      = ioc$h_io_illegal_disconnect =
        msg := 'I/O ILLEGAL DISCONNECT - MI41';
      = ioc$h_isi_io_parity_error =
        msg := 'ISI I/O PARITY ERROR - MI63';
      = ioc$h_rw_sequencer_ram_parity =
        msg := 'R/W SEQUENCER RAM PARITY ERROR - MI64';
      = ioc$h_mpu_parity_error =
        msg := 'MPU PARITY ERROR - MI65';
      = ioc$h_ecc_fault =
        msg := 'ECC FAULT - MI66';
      = ioc$h_voltage_fault =
        msg := 'VOLTAGE FAULT - MI67';
      = ioc$h_write_transfer_count =
        msg := 'WRITE TRANSFER COUNT ERROR - MI68';
      = ioc$h_over_temperature_fault =
        msg := 'OVER TEMPERATURE FAULT - MI6B';
      = ioc$h_no_rw_sequencer_response =
        msg := 'NO READ/WRITE SEQUENCER RESPONSE - MI6C';
      = ioc$h_invalid_rw_sequencer_rsp =
        msg := 'INVALID READ/WRITE SEQUENCER RESPONSE - MI6D';
      = ioc$h_rw_sequencer_status_overw =
        msg := 'READ/WRITE SEQUENCER STATUS OVERWRITE - MI6E';
      = ioc$h_hydra_hardware_fault =
        msg := 'HYDRA HARDWARE FAULT - MI6F';
      = ioc$h_rw_sequencer_fault =
        msg := 'READ/WRITE SEQUENCER FAULT - MI70';
      = ioc$h_zerofill_timeout =
        msg := 'ZEROFILL TIMEOUT - MI71';
      = ioc$h_function_buffer_pe =
        msg := 'FUNCTION BUFFER PARITY ERROR - MI72';
      = ioc$h_partial_sector_error =
        msg := 'PARTIAL SECTOR ERROR - MI73';
      = ioc$h_disk_fault =
        msg := 'DISK FAULT - MI81';
      = ioc$h_no_sector_pulse =
        msg := 'NO SECTOR PULSE - MI90';
      = ioc$h_no_index_pulse =
        msg := 'NO INDEX PULSE - MI91';
      = ioc$h_cyl_head_sec_wrap_error =
        msg := 'CYLINDER/HEAD/SECTOR WRAP ERROR - MI92';
      = ioc$h_no_disk_response =
        msg := 'NO DISK RESPONSE - MIC3';
      = ioc$h_pause_timeout =
        msg := 'PAUSE TIME OUT';
      = ioc$h_tip_didnt_clear =
        msg := 'TRANSFER IN PROGRESS DID NOT CLEAR';
      = ioc$h_incomplete_cb_xfer =
        msg := 'INCOMPLETE COMMAND BLOCK TRANSFER';
      = ioc$h_incomplete_status_xfer =
        msg := 'INCOMPLETE STATUS TRANSFER';
      = ioc$h_sa_dropped_hydra_status =
        msg := 'SELECT ACTIVE DROPPED WHEN READING CONTROLLER STATUS';
      = ioc$h_incomplete_device_st_xfer =
        msg := 'INCOMPLETE DEVICE STATUS TRANSFER';
      = ioc$h_sa_dropped_device_status =
        msg := 'SELECT ACTIVE DROPPED WHEN READING DEVICE STATUS';
      = ioc$h_incomplete_eri_xfer =
        msg := 'INCOMPLETE ERROR REGISTER IMAGE TRANSFER';
      = ioc$h_sa_dropped_err_reg_image =
        msg := 'SELECT ACTIVE DROPPED WHEN READING ERROR REGISTER IMAGE';
      = ioc$h_incomplete_error_log_xfer =
        msg := 'INCOMPLETE ERROR LOG TRANSFER';
      = ioc$h_sa_dropped_error_log =
        msg := 'SELECT ACTIVE DROPPED WHEN READING ERROR LOG';
      = ioc$h_sa_dropped_data =
        msg := 'SELECT ACTIVE DROPPED WHEN TRANSFERRING DATA';
      = ioc$h_host_if_integrity_error =
        msg := 'HOST I/F INTEGRITY ERROR';
      = ioc$h_drive_if_integrity_error =
        msg := 'DRIVE I/F INTEGRITY ERROR';
      = ioc$h_seek_error_retried =
        msg := 'SEEK ERROR - DS22';
      = ioc$h_power_up_complete =
        msg := 'POWER-UP INITIALIZATION COMPLETE - DS81';
      = ioc$h_reset_complete =
        msg := 'HOST-GENERATED RESET COMPLETE - DS83';
      = ioc$h_priority_override =
        msg := 'PRIORITY OVERRIDE COMPLETE - DS84';
      = ioc$h_hydra_on_line =
        msg := 'HYDRA ON LINE - DS85';
      ELSE
        msg := ' ';
      CASEND;

    = cml$7165_2x_failure_data =
      CASE counters_p^ [8] OF
      = ioc$895_storage_director_retry =
        msg := 'STORAGE DIRECTOR RETRY';
      = ioc$895_undocumented_format_msg =
        msg := 'UNDOCUMENTED FORMAT x MESSAGE';
        iop$ascii_hex (^msg (21), 1, disk_log_data_p^.diagnostic_code);
      = ioc$895_invalid_command =
        msg := 'INVALID COMMAND';
      = ioc$895_invalid_command_to_7165 =
        msg := 'INVALID COMMAND ISSUED TO 7165';
      = ioc$895_ccw_count_too_small =
        msg := 'CCW COUNT TOO SMALL';
      = ioc$895_invalid_data_argument =
        msg := 'INVALID DATA ARGUMENT';
      = ioc$895_chaining_not_indicated =
        msg := 'CHAINING NOT INDICATED';
      = ioc$895_command_mismatch =
        msg := 'COMMAND MISMATCH';
      = ioc$895_defective_track_pointer =
        msg := 'DEFECTIVE TRACK POINTER';
      = ioc$895_device_status_1_not_exp =
        msg := 'DEVICE STATUS 1 NOT EXPECTED';
      = ioc$895_index_missing =
        msg := 'INDEX MISSING';
      = ioc$895_unresettable_interrupt =
        msg := 'UNRESETTABLE INTERRUPT';
      = ioc$895_device_does_not_respond =
        msg := 'DEVICE DOES NOT RESPOND';
      = ioc$895_incomplete_set_sector =
        msg := 'INCOMPLETE SET SECTOR';
      = ioc$895_head_address_miscompare =
        msg := 'HEAD ADDRESS MISCOMPARE';
      = ioc$895_invalid_device_status_1 =
        msg := 'INVALID DEVICE STATUS 1';
      = ioc$895_device_not_ready =
        msg := 'DEVICE NOT READY';
      = ioc$895_track_addr_miscompare =
        msg := 'TRACK ADDRESS MISCOMPARE';
      = ioc$895_drive_motor_off =
        msg := 'DRIVE MOTOR OFF';
      = ioc$895_seek_incomplete =
        msg := 'SEEK INCOMPLETE';
      = ioc$895_cyl_addr_miscompare =
        msg := 'CYLINDER_ADDRESS_MISCOMPARE';
      = ioc$895_unresettable_offset =
        msg := 'UNRESETTABLE OFFSET ACTIVE';
      = ioc$895_selective_reset =
        msg := 'SELECTIVE RESET WHILE SELECTED';
      = ioc$895_sync_latch_failure =
        msg := 'SYNC LATCH FAILURE';
      = ioc$895_micro_detected_check =
        msg := 'MICROCODE DETECTED CHECK';
      = ioc$895_clock_stopped_check_1 =
        msg := 'CLOCK STOPPED CHECK 1';
      = ioc$895_alternate_sd_failure =
        msg := 'ALTERNATE STORAGE DIRECTOR FAILURE';
      = ioc$895_error_uncorr_by_ecc =
        msg := 'ERROR UNCORRECTABLE BY ECC';
      = ioc$895_data_sync_unsuccessful =
        msg := 'DATA SYNCRONIZATION UNSUCCESSFUL';
      = ioc$895_error_corrected_by_ecc =
        msg := 'ERROR CORRECTABLE BY ECC';
      = ioc$895_rcc_initiated_by_cca =
        msg := 'RCC INITIATED BY CCA';
      = ioc$895_rcc1_not_successful =
        msg := 'RCC1 NOT SUCCESSFUL';
      = ioc$895_rcc1_rcc2_unsuccessful =
        msg := 'RCC1 AND RCC2 NOT SUCCESSFUL';
      = ioc$895_invalid_ddc_tag_seq =
        msg := 'INVALID DDC TAG SEQUENCE';
      = ioc$895_extra_rcc_required =
        msg := 'EXTRA RCC REQUIRED';
      = ioc$895_invalid_ddc_selection =
        msg := 'INVALID DDC SELECTION';
      = ioc$895_missing_end_op =
        msg := 'MISSING END OP';
      = ioc$895_invalid_tag =
        msg := 'INVALID TAG';
      = ioc$895_deselection =
        msg := 'DESELECTION';
      = ioc$895_no_controller_response =
        msg := 'NO CONTROLLER RESPONSE';
      = ioc$895_controller_unavailable =
        msg := 'CONTROLLER NOT AVAILABLE';
      = ioc$895_ecc_hardware_failure =
        msg := 'ECC HARDWARE FAILURE';
      = ioc$895_unexpected_end_op =
        msg := 'UNEXPECTED END OP';
      = ioc$895_end_op_active =
        msg := 'END OP ACTIVE';
      = ioc$895_command_reject =
        msg := 'COMMAND REJECT';
      = ioc$895_intervention_req =
        msg := 'INTERVENTION REQUIRED';
      = ioc$895_bus_out_parity =
        msg := 'BUS OUT PARITY';
      = ioc$895_equipment_check =
        msg := 'EQUIPMENT CHECK';
      = ioc$895_data_check =
        msg := 'DATA CHECK';
      = ioc$895_overrun =
        msg := 'OVERRUN';
      = ioc$895_permanent_device_error =
        msg := 'PERMANENT DEVICE ERROR';
      = ioc$895_end_of_cylinder =
        msg := 'END OF CYLINDER';
      = ioc$895_message_to_operator =
        msg := 'MESSAGE TO OPERATOR';
      = ioc$895_no_record_found =
        msg := 'NO RECORD FOUND';
      = ioc$895_file_protected =
        msg := 'FILE PROTECTED';
      = ioc$895_first_logged_error =
        msg := 'FIRST LOGGED ERROR';
      = ioc$895_environmental_data =
        msg := 'ENVIRONMENTAL DATA';
      = ioc$895_path_error =
        msg := 'PATH ERROR';
      = ioc$895_invalid_track_format =
        msg := 'INVALID TRACK FORMAT';
      = ioc$895_undocumented_sd_resp =
        msg := 'UNDOCUMENTED STORAGE DIRECTOR RESPONSE';
      = ioc$895_no_request_in_cmd =
        msg := 'REQUEST IN NOT RECEIVED DURING COMMAND RETRY';
      = ioc$895_illegal_write =
        msg := 'ILLEGAL WRITE';
      = ioc$895_fips_error =
        msg := 'CCC-STORAGE DIRECTOR INTERFACE ERROR';
      = ioc$895_full_empty_count =
        msg := 'FULL/EMPTY COUNT INCORRECT';
      = ioc$895_address_miscompare =
        msg := 'ADDRESS MISCOMPARE ON SELECT SEQUENCE';
      = ioc$895_no_request_in_poll =
        msg := 'NO REQUEST IN ON POLLING SEQUENCE';
      = ioc$895_select_in_received =
        msg := 'SELECT IN RECEIVED ON SELECT SEQUENCE';
      = ioc$895_bus_in_parity =
        msg := 'BUS IN PARITY ERROR';
      = ioc$895_read_path_parity =
        msg := 'READ PATH PARITY ERROR';
      = ioc$895_write_path_parity =
        msg := 'WRITE PATH PARITY ERROR';
      = ioc$895_incomplete_transfer =
        msg := 'INCOMPLETE DATA TRANSFER';
      = ioc$895_output_chan_parity =
        msg := 'CHANNEL PARITY DURING PP OUTPUT';
      = ioc$895_parity_err_on_input =
        msg := 'COUPLER MEMORY PARITY ERROR DURING PP INPUT';
      = ioc$895_deadman_timeout =
        msg := 'DEADMAN TIMEOUT STATUS';
      = ioc$895_memory_parity =
        msg := 'COUPLER MEMORY PARITY ERROR';
      = ioc$895_excess_data_xfered =
        msg := 'EXCESS DATA TRANSFERED';
      = ioc$895_data_packing_wrong =
        msg := 'DATA PACKING FOR CHANNEL DID NOT COME OUT EVEN';
      = ioc$895_normal_end_not_set =
        msg := 'NORMAL END NOT SET';
      = ioc$895_function_timeout =
        msg := 'FUNCTION TIMEOUT';
      = ioc$895_soft_sectoring =
        msg := 'SOFT SECTORING UNIT';
      = ioc$895_unit_soft_sectored =
        msg := 'UNIT SOFT SECTORED';
      = ioc$895_interface_error =
        msg := 'INTERFACE ERROR';
      = ioc$895_kz_board_error =
        msg := 'KZ BOARD ERROR';
      = ioc$895_kx_board_error =
        msg := 'KX BOARD ERROR';
      = ioc$895_channel_error =
        msg := 'CHANNEL ERROR';
      = ioc$895_media_failure =
        msg := 'MEDIA FAILURE';
      = ioc$895_incomplete_chan_xfer =
        msg := 'INCOMPLETE CHANNEL TRANSFER';
      = ioc$895_ccc_failure =
        msg := 'CCC FAILURE';
      = ioc$895_pp_ccc_data_integrity =
        msg := 'PP-CCC DATA INTEGRITY';
      = ioc$895_pp_drive_data_integrity =
        msg := 'PP-DRIVE DATA INTEGRITY';
      = ioc$895_seek_command_timeout =
        msg := 'SEEK COMMAND TIMEOUT';
      = ioc$895_indeterminate =
        msg := 'INDETERMINATE 895 ERROR';
      = ioc$895_uncorrected_cm_error =
        msg := 'UNCORRECTED CM ERROR';
      = ioc$895_cm_reject =
        msg := 'CM REJECT';
      = ioc$895_invalid_cm_response =
        msg := 'INVALID CM RESPONSE';
      = ioc$895_cm_response_pe =
        msg := 'CM RESPONSE CODE PARITY ERROR';
      = ioc$895_cmi_read_pe =
        msg := 'CMI READ DATA PARITY ERROR';
      = ioc$895_overflow_error =
        msg := 'OVERFLOW ERROR';
      = ioc$895_jy_board_error =
        msg := 'JY BOARD ERROR';
      = ioc$895_iou_failure_st_err =
        msg := 'IOU FAILURE - OPERATIONAL STATUS WRONG';
      = ioc$895_iou_failure_data_err =
        msg := 'IOU FAILURE - TEST MODE DATA MISCOMPARE';
      = ioc$895_tip_not_clear =
        msg := 'TRANSFER IN PROGRESS DID NOT CLEAR';
      = ioc$895_t_reg_not_empty =
        msg := 'T PRIME REGISTER NOT EMPTY';
      ELSE
        msg := ' ';
      CASEND;

    = cml$10395_11_failure_data, cml$fa7b4_d_failure_data =
      CASE counters_p^ [8] OF
      = ioc$pp_timed_out_a_command =
        msg := 'PP TIMED OUT A COMMAND';
      = ioc$isd_indeterminate =
        msg := 'INDETERMINATE';
      = ioc$adapter_failure =
        msg := 'ADAPTER FAILURE      ';
        IF disk_log_data_p^.diagnostic_code > 0 THEN
          iop$ascii_hex (^msg (19, * ), 3, disk_log_data_p^.diagnostic_code);
        IFEND;
      = ioc$isd_controller_failure =
        msg := 'CONTROL MODULE FAILURE     ';
        IF disk_log_data_p^.diagnostic_code > 0 THEN
          iop$ascii_hex (^msg (26, * ), 2, disk_log_data_p^.diagnostic_code);
        IFEND;
      = ioc$drive_failure =
        msg := 'DRIVE FAILURE     ';
        IF disk_log_data_p^.diagnostic_code > 0 THEN
          iop$ascii_hex (^msg (17, * ), 2, disk_log_data_p^.diagnostic_code);
        IFEND;
      = ioc$drive_not_present =
        msg := 'DRIVE NOT PRESENT';
      = ioc$drive_not_ready =
        msg := 'DRIVE NOT READY';
      = ioc$media_failure =
        msg := 'MEDIA FAILURE - C    T   S  ';
        iop$ascii_decimal (^msg (18, * ), 3, counters_p^ [14]);
        iop$ascii_decimal (^msg (23, * ), 2, counters_p^ [15]);
        iop$ascii_decimal (^msg (27, * ), 2, counters_p^ [16]);
      = ioc$function_failure_class_2 =
        msg := 'FUNCTION FAILURE CLASS 2';
      = ioc$function_failure_class_3 =
        msg := 'FUNCTION FAILURE CLASS 3';
      = ioc$input_ici_parity =
        msg := 'INPUT ICI PARITY';
      = ioc$output_ici_parity_class_1 =
        msg := 'OUTPUT ICI PARITY CLASS 1';
      = ioc$output_ici_parity_class_3 =
        msg := 'OUTPUT ICI PARITY CLASS 3';
      = ioc$adapter_ram_parity =
        msg := 'ADAPTER RAM PARITY';
      = ioc$adapter_buffer_parity =
        msg := 'ADAPTER BUFFER PARITY';
      = ioc$adapter_rom_parity =
        msg := 'ADAPTER ROM PARITY';
      = ioc$isi_parity =
        msg := 'ISI PARITY';
      = ioc$output_isi_parity_class_1 =
        msg := 'OUTPUT ISI PARITY CLASS 1';
      = ioc$output_isi_parity_class_3 =
        msg := 'OUTPUT ISI PARITY CLASS 3';
      = ioc$seek_error =
        msg := 'SEEK ERROR';
      = ioc$unable_to_read_header =
        msg := 'UNABLE TO READ HEADER';
      = ioc$unable_to_read_data =
        msg := 'UNABLE TO READ DATA';
      = ioc$incomplete_ici_transfer =
        msg := 'INCOMPLETE ICI TRANSFER';
      = ioc$isi_deadman_time_out =
        msg := 'ISI DEADMAN TIME-OUT';
      = ioc$loopback_compare_error =
        msg := 'LOOPBACK COMPARE ERROR';
      = ioc$loopback_select_active =
        msg := 'LOOPBACK SELECT ACTIVE';
      = ioc$loopback_attention =
        msg := 'LOOPBACK ATTENTION';
      = ioc$loopback_check_failure =
        msg := 'LOOPBACK CHECK FAILURE';
      = ioc$cm_scheduler_parity =
        msg := 'CM SCHEDULER PARITY';
      = ioc$cm_mpu_parity =
        msg := 'CM MPU PARITY';
      = ioc$cm_rw_hardware_fault =
        msg := 'CM R/W HARDWARE FAULT';
      = ioc$drive_voltage_fault =
        msg := 'DRIVE VOLTAGE FAULT';
      = ioc$over_temperature_fault =
        msg := 'OVER TEMPERATURE FAULT';
      = ioc$drive_write_protected =
        msg := 'DRIVE WRITE PROTECTED';
      = ioc$control_module_reserved =
        msg := 'CONTROL MODULE RESERVED';
      = ioc$isd_software_failure =
        msg := 'SOFTWARE FAILURE';
      = ioc$invalid_bootstrap_error =
        msg := 'INVALID BOOTSTRAP ERROR';
      = ioc$start_switch_not_depressed =
        msg := 'START SWITCH NOT DEPRESSED';
      = ioc$reloading_control_module =
        msg := 'RELOADING CONTROL MODULE';
      = ioc$control_module_reloaded =
        msg := 'CONTROL MODULE RELOADED';
      = ioc$executing_level_ii =
        msg := 'EXECUTING LEVEL II DIAGNOSTICS';
      = ioc$level_ii_passed =
        msg := 'LEVEL II DIAGNOSTICS PASSED';
      = ioc$adapter_controlware_error =
        msg := 'ADAPTER CONTROLWARE ERROR';
      = ioc$i_host_if_integrity_error =
        msg := 'PP - ADAPTER DATA INTEGRITY';
      = ioc$i_drive_if_integrity_error =
        msg := 'PP - DRIVE DATA INTEGRITY';
      ELSE
        msg := ' ';
      CASEND;

    = cml$7154_failure_data, cml$7155_1x_failure_data =
      CASE counters_p^ [8] OF
      = ioc$indeterminate =
        msg := 'INDETERMINATE';
      = ioc$input_channel_parity =
        msg := 'INPUT CHANNEL PARITY';
      = ioc$output_channel_parity =
        msg := 'OUTPUT CHANNEL PARITY';
      = ioc$controller_failure =
        msg := 'CONTROLLER FAILURE';
      = ioc$unit_failure =
        msg := 'UNIT FAILURE';
      = ioc$function_timeout =
        msg := 'FUNCTION TIMEOUT';
      = ioc$unit_is_reserved =
        msg := 'UNIT RESERVED';
      = ioc$controller_is_reserved =
        msg := 'CONTROLLER RESERVED';
      = ioc$seek_failure =
        msg := 'SEEK FAILURE';
      = ioc$checkword_error =
        msg := 'ERROR IN CHECKWORD - C    T   S  ';
        iop$ascii_decimal (^msg (23, * ), 3, counters_p^ [14]);
        iop$ascii_decimal (^msg (28, * ), 2, counters_p^ [15]);
        iop$ascii_decimal (^msg (32, * ), 2, counters_p^ [16]);
      = ioc$ram_parity =
        msg := 'CONTROLLER RAM PARITY';
      = ioc$incomplete_sector_transfer =
        msg := 'INCOMPLETE SECTOR TRANSFER';
      = ioc$unit_not_ready =
        msg := 'UNIT NOT READY';
      = ioc$unit_off_line_or_not_cabled =
        msg := 'UNIT OFF LINE OR NOT CABLED';
      = ioc$read_only_switch_on =
        msg := 'UNIT READ ONLY SWITCH ON';
      = ioc$ch_enable_off_or_not_cabled =
        msg := 'CHAN ENABLE SWITCH OFF OR UNIT NOT CABLED';
      = ioc$flawed_track =
        msg := 'FLAWED TRACK';
      = ioc$flawed_sector =
        msg := 'FLAWED SECTOR';
      = ioc$sector_address_miscompare =
        msg := 'SECTOR ADDRESS MISCOMPARE';
      = ioc$cylinder_address_miscompare =
        msg := 'CYLINDER ADDRESS MISCOMPARE';
      = ioc$lost_control_word =
        msg := 'LOST CONTROL WORD';
      = ioc$iou_output_parity =
        msg := 'IOU OUTPUT PARITY';
      = ioc$indeterminate_output_parity =
        msg := 'INDETERMINATE OUTPUT PARITY';
      = ioc$7155_software_failure =
        msg := 'SOFTWARE FAILURE';
      = ioc$address_error =
        msg := 'ADDRESS ERROR';
      = ioc$track_address_miscompare =
        msg := 'TRACK ADDRESS MISCOMPARE';
      = ioc$drive_not_selected =
        msg := 'DRIVE NOT SELECTED';
      = ioc$controller_drive_interface =
        msg := 'CONTROLLER - DRIVE INTERFACE ERROR';
      = ioc$host_if_integrity_error =
        msg := 'PP - CONTROLLER DATA INTEGRITY';
      = ioc$drive_if_integrity_error =
        msg := 'PP - DRIVE DATA INTEGRITY';
      = ioc$write_buffer_to_disk_error =
        msg := 'WRITE BUFFER TO DISK ERROR';
      = ioc$processor_instruction_timeo =
        msg := 'PROCESSOR INSTRUCTION TIMEOUT';
      = ioc$bm_register_parity_error =
        msg := 'BM REGISTER PARITY ERROR';
      = ioc$write_verify_error =
        msg := 'WRITE VERIFY ERROR';
      = ioc$7155_media_error =
        msg := 'MEDIA FAILURE';
      = ioc$conf_cylinder_is_flawed =
        msg := 'CONFIDENCE CYLINDER IS FLAWED';
      = ioc$loading_controlware =
        msg := 'LOADING CONTROLWARE';
      ELSE
        msg := ' ';
      CASEND;
    = cml$9836_1_failure_data =
      CASE counters_p^ [8] OF
      = ioc$9836_1_function_timeout =
        msg := 'FUNCTION TIMEOUT';
      = ioc$9836_1_ch_empty_when_act =
        msg := 'CHANNEL EMPTY WHEN ACTIVATED';
      = ioc$9836_1_period_c_error =
        msg := 'PERIOD COUNTER ERROR';
      = ioc$9836_1_upper_ici_parity =
        msg := 'PP-IPI PARITY ERROR';
      = ioc$9836_1_iou_error =
        msg := 'IOU ERROR';
      = ioc$9836_1_incomplete_i4_xfer =
        msg := 'INCOMPLETE I4 TRANSFER';
      = ioc$9836_1_channel_not_empty =
        msg := 'CHANNEL NOT EMPTY';
      = ioc$9836_1_central_memory_error =
        msg := 'CENTRAL MEMORY ERROR';
      = ioc$9836_1_invalid_cm_response =
        msg := 'INVALID CM RESPONSE CODE';
      = ioc$9836_1_cm_response_error =
        msg := 'CM RESPONSE CODE ERROR';
      = ioc$9836_1_cmi_read_parity =
        msg := 'CMI READ DATA PARITY ERROR';
      = ioc$9836_1_jy_data_error =
        msg := 'Y BOARD DATA ERROR';
      = ioc$9836_1_bas_parity_error =
        msg := 'BAS PARITY ERROR';
      = ioc$9836_1_lz_error =
        msg := 'Z BOARD ERROR';
      = ioc$9836_1_jy_error =
        msg := 'Y BOARD ERROR';
      = ioc$9836_1_lx_error =
        msg := 'X BOARD ERROR';
      = ioc$9836_1_dma_test_failure =
        msg := 'DMA TEST MODE FAILURE';
      = ioc$9836_1_count_overflow =
        msg := 'DMA COUNT OVERFLOW';
      = ioc$9836_1_cant_select_cont =
        msg := 'CAN NOT SELECT CONTROLLER';
      = ioc$9836_1_bit_sig_response_err =
        msg := 'BIT SIGNIFICANT RESPONSE ERROR';
      = ioc$9836_1_no_sync_in =
        msg := 'NO SYNC IN';
      = ioc$9836_1_sync_in_did_not_drop =
        msg := 'SYNC IN DID NOT DROP';
      = ioc$9836_1_ipi_sequence_error =
        msg := 'IPI SEQUENCE ERROR';
      = ioc$9836_1_upper_ipi_ch_parity =
        msg := 'IPI CHANNEL PARITY ERROR';
      = ioc$9836_1_slave_in_not_set =
        msg := 'SLAVE IN NOT SET';
      = ioc$9836_1_slave_in_not_drop =
        msg := 'SLAVE IN DID NOT DROP';
      = ioc$9836_1_incomplete_transfer =
        msg := 'INCOMPLETE TRANSFER';
      = ioc$9836_1_ch_stayed_active =
        msg := 'CHANNEL STAYED ACTIVE';
      = ioc$9836_1_buffer_counter_e =
        msg := 'BUFFER COUNTER_ERROR';
      = ioc$9836_1_sync_counter_error =
        msg := 'SYNC COUNTER ERROR';
      = ioc$9836_1_lost_data =
        msg := 'LOST DATA';
      = ioc$9836_1_bus_parity =
        msg := 'BUS PARITY';
      = ioc$9836_1_command_reject =
        msg := 'COMMAND REJECT';
      = ioc$9836_1_sync_out_not_sync_in =
        msg := 'SYNC OUTS NOT EQUAL SYNC INS';
      = ioc$9836_1_bus_b_ack_incorrect =
        msg := 'BUS B ACKNOWLEGE INCORRECT';
      = ioc$9836_1_no_cont_response =
        msg := 'NO CONTROLLER RESPONSE';
      = ioc$9836_1_ending_status_wrong =
        msg := 'ENDING STATUS WRONG';
      = ioc$9836_1_executing_cont_diag =
        msg := 'EXECUTING CONTROLLER DIAGNOSTICS - IOU   CH    C ';
        CASE disk_log_data_p^.channel.port OF
        = cmc$port_a =
          msg (41,1) := 'C';      { CIO Channel }
          msg (46,1) := 'A';      { Change to CIO channel PORT A }
        = cmc$port_b =
          msg (41,1) := 'C';      { CIO Channel }
          msg (46,1) := 'B';      { Change to CIO channel PORT B }
        ELSE
          IF disk_log_data_p^.channel.concurrent THEN
            msg (41,1) := 'C'        { CIO Channel }
          IFEND;
        CASEND;
        iop$ascii_decimal (^msg (39, *), 1, disk_log_data_p^.iou_number);
        iop$ascii_decimal (^msg (44, *), 2, disk_log_data_p^.channel.number);
        iop$ascii_decimal (^msg (49, *), 1, disk_log_data_p^.equipment);
      = ioc$9836_1_cont_diag_passed =
        msg := 'CONTROLLER DIAGNOSTICS PASSED - IOU   CH    C ';
        CASE disk_log_data_p^.channel.port OF
        = cmc$port_a =
          msg (38,1) := 'C';      { CIO Channel }
          msg (53,1) := 'A';      { Change to CIO channel PORT A }
        = cmc$port_b =
          msg (38,1) := 'C';      { CIO Channel }
          msg (53,1) := 'B';      { Change to CIO channel PORT B }
        ELSE
          IF disk_log_data_p^.channel.concurrent THEN
            msg (38,1) := 'C'        { CIO Channel }
          IFEND;
        CASEND;
        iop$ascii_decimal (^msg (41, *), 1, disk_log_data_p^.iou_number);
        iop$ascii_decimal (^msg (46, *), 2, disk_log_data_p^.channel.number);
        iop$ascii_decimal (^msg (51, *), 1, disk_log_data_p^.equipment);
      = ioc$9836_1_cont_diag_passed_2 =
        msg := 'CONTROLLER DIAGS PASSED - IOU   CH    C  LAST EC IS     ';
        CASE disk_log_data_p^.channel.port OF
        = cmc$port_a =
          msg (32,1) := 'C';      { CIO Channel }
          msg (37,1) := 'A';      { Change to CIO channel PORT A }
        = cmc$port_b =
          msg (32,1) := 'C';      { CIO Channel }
          msg (37,1) := 'B';      { Change to CIO channel PORT B }
        ELSE
          IF disk_log_data_p^.channel.concurrent THEN
            msg (32,1) := 'C'        { CIO Channel }
          IFEND;
        CASEND;
        iop$ascii_decimal (^msg (30, *), 1, disk_log_data_p^.iou_number);
        iop$ascii_decimal (^msg (35, *), 2, disk_log_data_p^.channel.number);
        iop$ascii_decimal (^msg (40, *), 1, disk_log_data_p^.equipment);
        iop$ascii_hex (^msg (53, *), 4, disk_log_data_p^.diagnostic_code);
      = ioc$9836_1_cont_alt_port_event =
        msg := 'CONTROLLER ALTERNATE PORT EVENT';
      = ioc$9836_1_dr_alt_port_event =
        msg := 'DRIVE ALTERNATE PORT EVENT';
      = ioc$9836_1_restoring_drive =
        msg := 'RESTORING DRIVE - IOU   CH    C  U  ';
        CASE disk_log_data_p^.channel.port OF
        = cmc$port_a =
          msg (24,1) := 'C';      { CIO Channel }
          msg (29,1) := 'A';      { Change to CIO channel PORT A }
        = cmc$port_b =
          msg (24,1) := 'C';      { CIO Channel }
          msg (29,1) := 'B';      { Change to CIO channel PORT B }
        ELSE
          IF disk_log_data_p^.channel.concurrent THEN
            msg (24,1) := 'C'        { CIO Channel }
          IFEND;
        CASEND;
        iop$ascii_decimal (^msg (22, *), 1, disk_log_data_p^.iou_number);
        iop$ascii_decimal (^msg (27, *), 2, disk_log_data_p^.channel.number);
        iop$ascii_decimal (^msg (32, *), 1, disk_log_data_p^.equipment);
        iop$ascii_decimal (^msg (35, *), 2, disk_log_data_p^.physical_unit);
      = ioc$9836_1_restore_complete =
        msg := 'DRIVE RESTORATION COMPLETE - IOU   CH    C  U  ';
        CASE disk_log_data_p^.channel.port OF
        = cmc$port_a =
          msg (35,1) := 'C';      { CIO Channel }
          msg (40,1) := 'A';      { Change to CIO channel PORT A }
        = cmc$port_b =
          msg (35,1) := 'C';      { CIO Channel }
          msg (40,1) := 'B';      { Change to CIO channel PORT B }
        ELSE
          IF disk_log_data_p^.channel.concurrent THEN
            msg (35,1) := 'C'        { CIO Channel }
          IFEND;
        CASEND;
        iop$ascii_decimal (^msg (33, *), 1, disk_log_data_p^.iou_number);
        iop$ascii_decimal (^msg (38, *), 2, disk_log_data_p^.channel.number);
        iop$ascii_decimal (^msg (43, *), 1, disk_log_data_p^.equipment);
        iop$ascii_decimal (^msg (46, *), 2, disk_log_data_p^.physical_unit);
      = ioc$9836_1_formatting_drive =
        msg := 'FORMATTING DRIVE - IOU   CH    C  U  ';
        CASE disk_log_data_p^.channel.port OF
        = cmc$port_a =
          msg (25,1) := 'C';      { CIO Channel }
          msg (30,1) := 'A';      { Change to CIO channel PORT A }
        = cmc$port_b =
          msg (25,1) := 'C';      { CIO Channel }
          msg (30,1) := 'B';      { Change to CIO channel PORT B }
        ELSE
          IF disk_log_data_p^.channel.concurrent THEN
            msg (25,1) := 'C'        { CIO Channel }
          IFEND;
        CASEND;
        iop$ascii_decimal (^msg (23, *), 1, disk_log_data_p^.iou_number);
        iop$ascii_decimal (^msg (28, *), 2, disk_log_data_p^.channel.number);
        iop$ascii_decimal (^msg (33, *), 1, disk_log_data_p^.equipment);
        iop$ascii_decimal (^msg (36, *), 2, disk_log_data_p^.physical_unit);
      = ioc$9836_1_format_complete =
        msg := 'FORMAT COMPLETE - IOU   CH    C  U  ';
        CASE disk_log_data_p^.channel.port OF
        = cmc$port_a =
          msg (24,1) := 'C';      { CIO Channel }
          msg (29,1) := 'A';      { Change to CIO channel PORT A }
        = cmc$port_b =
          msg (24,1) := 'C';      { CIO Channel }
          msg (29,1) := 'B';      { Change to CIO channel PORT B }
        ELSE
          IF disk_log_data_p^.channel.concurrent THEN
            msg (24,1) := 'C'        { CIO Channel }
          IFEND;
        CASEND;
        iop$ascii_decimal (^msg (22, *), 1, disk_log_data_p^.iou_number);
        iop$ascii_decimal (^msg (27, *), 2, disk_log_data_p^.channel.number);
        iop$ascii_decimal (^msg (32, *), 1, disk_log_data_p^.equipment);
        iop$ascii_decimal (^msg (35, *), 2, disk_log_data_p^.physical_unit);
      = ioc$9836_1_par_prot_disabled =
        IF counters_p^[5] = 12 THEN
          msg := '5833_1P PARITY PROTECTION DISABLED';
        ELSEIF counters_p^[5] = 14 THEN
          msg := '5833_3P PARITY PROTECTION DISABLED';
        ELSEIF counters_p^[5] = 17 THEN
          msg := '5838_1P PARITY PROTECTION DISABLED';
        ELSEIF counters_p^[5] = 19 THEN
          msg := '5838_3P PARITY PROTECTION DISABLED';
        ELSEIF counters_p^[5] = 22 THEN
          msg := '47444_1P PARITY PROTECTION DISABLED';
        ELSE
          msg := '47444_3P PARITY PROTECTION DISABLED';
        IFEND;
      = ioc$9836_1_drive_failure =
        msg := 'DRIVE FAILURE';
      = ioc$9836_1_media_failure =
        msg := 'MEDIA FAILURE';
      = ioc$9836_1_lrc_error =
        msg := 'LRC ERROR';
      = ioc$9836_1_cont_intervention =
        msg := 'CONTROLLER INTERVENTION REQUIRED';
      = ioc$9836_1_cont_machine_exc =
        msg := 'CONTROLLER MACHINE EXCEPTION';
      = ioc$9836_1_command_exception =
        msg := 'COMMAND EXCEPTION';
      = ioc$9836_1_controller_failure, ioc$9836_1_microcode_exec_error =
        msg := 'MICROCODE EXECUTION ERROR';
      = ioc$9836_1_unexpected_response =
        msg := 'UNEXPECTED RESPONSE';
      = ioc$9836_1_drive_rsvd_other_p =
        msg := 'DRIVE RESERVED TO OTHER CONTROLLER PORT';
      = ioc$9836_1_controller_over_temp =
        msg := 'CONTROLLER OVER TEMPERATURE';
      = ioc$9836_1_drive_not_operable =
        msg := 'DRIVE NOT OPERATIONAL';
      = ioc$9836_1_drive_not_ready =
        msg := 'DRIVE NOT READY';
      = ioc$9836_1_drive_intervention =
        msg := 'DRIVE INTERVENTION REQUIRED';
      = ioc$9836_1_uncorr_data_ck =
        msg := 'UNCORRECTABLE DATA CHECK';
      = ioc$9836_1_drive_fatal_error =
        msg := 'DRIVE FATAL ERROR';
      = ioc$9836_1_hw_write_protect =
        msg := 'HARDWARE WRITE PROTECTED';
      = ioc$9836_1_drive_rsvd_other_c =
        msg := 'DRIVE RESERVED TO OTHER CONTROLLER';
      = ioc$9836_1_drive_ecc_error=
        msg := 'DRIVE ECC ERROR';
      = ioc$9836_1_missing_sync =
        msg := 'MISSING SYNC OCTET ON DRIVE';
      = ioc$9836_1_sector_not_found =
        msg := 'SECTOR NOT FOUND';
      = ioc$9836_1_drive_exception =
        msg := 'DRIVE MACHINE EXCEPTION';
      = ioc$9836_1_no_unit_oper_resp =
        msg := 'NO UNIT OPERATIONAL RESPONSE';
      = ioc$9836_1_das_head_shift =
        msg := 'DAS DRIVE HEAD SHIFT DETECTED - IOU   CH    C  U  ';
        CASE disk_log_data_p^.channel.port OF
        = cmc$port_a =
          msg (38,1) := 'C';      { CIO Channel }
          msg (43,1) := 'A';      { Change to CIO channel PORT A }
        = cmc$port_b =
          msg (38,1) := 'C';      { CIO Channel }
          msg (43,1) := 'B';      { Change to CIO channel PORT B }
        ELSE
          IF disk_log_data_p^.channel.concurrent THEN
            msg (38,1) := 'C'        { CIO Channel }
          IFEND;
        CASEND;
        iop$ascii_decimal (^msg (36, *), 1, disk_log_data_p^.iou_number);
        iop$ascii_decimal (^msg (41, *), 2, disk_log_data_p^.channel.number);
        iop$ascii_decimal (^msg (46, *), 1, disk_log_data_p^.equipment);
        iop$ascii_decimal (^msg (49, *), 2, disk_log_data_p^.physical_unit);
      = ioc$9836_1_ssd_battery_to_low =
        msg := 'SSD BATTERY TOO LOW FOR BACKUP - IOU   CH    C  U  ';
        CASE disk_log_data_p^.channel.port OF
        = cmc$port_a =
          msg (39,1) := 'C';      { CIO Channel }
          msg (44,1) := 'A';      { Change to CIO channel PORT A }
        = cmc$port_b =
          msg (39,1) := 'C';      { CIO Channel }
          msg (44,1) := 'B';      { Change to CIO channel PORT B }
        ELSE
          IF disk_log_data_p^.channel.concurrent THEN
            msg (39,1) := 'C'        { CIO Channel }
          IFEND;
        CASEND;
        iop$ascii_decimal (^msg (37, *), 1, disk_log_data_p^.iou_number);
        iop$ascii_decimal (^msg (42, *), 2, disk_log_data_p^.channel.number);
        iop$ascii_decimal (^msg (47, *), 1, disk_log_data_p^.equipment);
        iop$ascii_decimal (^msg (50, *), 2, disk_log_data_p^.physical_unit);
      = ioc$9836_1_ssd_battery_test =
        msg := 'SSD BATTERY TEST FAILED - IOU   CH    C  U  ';
        CASE disk_log_data_p^.channel.port OF
        = cmc$port_a =
          msg (32,1) := 'C';      { CIO Channel }
          msg (37,1) := 'A';      { Change to CIO channel PORT A }
        = cmc$port_b =
          msg (32,1) := 'C';      { CIO Channel }
          msg (37,1) := 'B';      { Change to CIO channel PORT B }
        ELSE
          IF disk_log_data_p^.channel.concurrent THEN
            msg (32,1) := 'C'        { CIO Channel }
          IFEND;
        CASEND;
        iop$ascii_decimal (^msg (30, *), 1, disk_log_data_p^.iou_number);
        iop$ascii_decimal (^msg (35, *), 2, disk_log_data_p^.channel.number);
        iop$ascii_decimal (^msg (40, *), 1, disk_log_data_p^.equipment);
        iop$ascii_decimal (^msg (43, *), 2, disk_log_data_p^.physical_unit);
      = ioc$9836_1_ssd_battery_old =
        msg := 'SSD BATTERY OLD - REPLACE - IOU   CH    C  U  ';
        CASE disk_log_data_p^.channel.port OF
        = cmc$port_a =
          msg (34,1) := 'C';      { CIO Channel }
          msg (39,1) := 'A';      { Change to CIO channel PORT A }
        = cmc$port_b =
          msg (34,1) := 'C';      { CIO Channel }
          msg (39,1) := 'B';      { Change to CIO channel PORT B }
        ELSE
          IF disk_log_data_p^.channel.concurrent THEN
            msg (34,1) := 'C'        { CIO Channel }
          IFEND;
        CASEND;
        iop$ascii_decimal (^msg (32, *), 1, disk_log_data_p^.iou_number);
        iop$ascii_decimal (^msg (37, *), 2, disk_log_data_p^.channel.number);
        iop$ascii_decimal (^msg (42, *), 1, disk_log_data_p^.equipment);
        iop$ascii_decimal (^msg (45, *), 2, disk_log_data_p^.physical_unit);
      = ioc$9836_1_error_retry =
        msg := 'ERROR RETRY';
      = ioc$9836_1_data_retry =
        msg := 'DATA RETRY';
      = ioc$9836_1_motion_retry =
        msg := 'MOTION RETRY';
      = ioc$9836_1_data_correction =
        msg := 'DATA CORRECTION';
      = ioc$9836_1_soft_error =
        msg := 'SOFT ERROR';
      = ioc$9836_1_parity_dr_corr =
        msg := 'PARITY DRIVE CORRECTION';
      = ioc$9836_1_pp_cont_data_integ =
        msg := 'PP-CONTROLLER DATA INTEGRITY';
      = ioc$9836_1_cm_drive_data_integ =
        msg := 'CM-DRIVE DATA INTEGRITY';
      = ioc$9836_1_software_failure =
        msg := 'SOFTWARE FAILURE';
      = ioc$9836_1_wrong_drive_config =
        msg := 'WRONG DRIVE TYPE';
      = ioc$9836_1_defect_mgmt_failure =
        msg := 'DEFECT MANAGEMENT TASK FAILED';
      = ioc$9836_1_wrong_drive_type =
        msg := '         CONFIGURED -          FOUND';
        j := disk_log_data_p^.actual_drive_type * 8;
        k := (counters_p^[5] - 9) * 8;
        FOR i := 1 TO 8 DO
          msg(i) := das_type(i+k);
          msg(i+22) := das_type(i+j);
        FOREND;
      = ioc$9836_1_drive_init_required =
        msg := 'DRIVE INITIALIZATON REQUIRED';
      = ioc$9836_1_no_parallel_support =
        msg := 'CONTROLLER DOES NOT SUPPORT PARALLEL';
      = ioc$9836_1_indeterminate =
        msg := 'INDETERMINATE';
      ELSE
      msg := ' ';
      CASEND;
    ELSE
      msg := ' ';
    CASEND;

{Combine descriptor data with symptom message.

    IF (descriptor_data.size <= (252 - 4 - symptom_length)) THEN
      size := descriptor_data.size;
    ELSE
      size := 252 - 4 - symptom_length;
    IFEND;
    m_length := size + 4 + symptom_length;
    PUSH message_p: [m_length];
    message_p^ (1, size) := descriptor_data.value;
    k := size + 1;
    CASE counters_p^ [7] MOD 8 OF
    = 0 =
      message_p^ (k, 4) := '*RF*';
    = 1 =
      message_p^ (k, 4) := '*UF*';
    = 2 =
      message_p^ (k, 4) := '*IF*';
    = 3 =
      message_p^ (k, 4) := '*IM*';
    ELSE
    CASEND;
    k := k + 4;
    message_p^ (k, * ) := msg;

    sfp$emit_statistic (statistic_code, message_p^, counters_p, status);

  PROCEND iop$emit_statistic;



  PROCEDURE iop$ascii_decimal (msg: ^string ( * );
        number_of_characters: 1 .. 4;
        word: 0 .. 0ffff(16));

    VAR
      i: integer,
      k: integer,
      divisor: [STATIC, READ, oss$job_paged_literal] array [1 .. 4] of integer := [1, 10, 100, 1000];


    k := 1;
    FOR i := number_of_characters DOWNTO 1 DO
      msg^ (i) := CHR (((word DIV divisor [k]) MOD 10) + ORD ('0'));
      k := k + 1;
    FOREND;
  PROCEND iop$ascii_decimal;



  PROCEDURE iop$ascii_hex (msg: ^string ( * );
        number_of_characters: 1 .. 4;
        word: 0 .. 0ffff(16));

    VAR
      i: integer,
      k: integer,
      value: integer,
      divisor: [STATIC, READ, oss$job_paged_literal] array [1 .. 4] of integer := [1, 16, 256, 4096];


    k := 1;
    FOR i := number_of_characters DOWNTO 1 DO
      value := (word DIV divisor [k]) MOD 16;
      IF value > 9 THEN
        value := value + 7;
      IFEND;
      msg^ (i) := CHR (value + ORD ('0'));
      k := k + 1;
    FOREND;
  PROCEND iop$ascii_hex;



MODEND iom$log_disk_data;
*DECK DECK=IOM$LOG_TAPE_DATA EXPAND=TRUE

?? RIGHT := 110 ??
?? NEWTITLE := ' IOM$LOG_TAPE_DATA ' ??
MODULE iom$log_tape_data;
{
{  This module contains the processes which construct the Engineering log entry
{  for IPI or Cartridge tape errors logged from monitor.
{  If the error is a microcode load error for Cartridge tape, an attempt is made
{  to DOWN the controller.
{
?? TITLE := '    Type Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc iot$ipi_tape_log_data
*copyc iot$tape_failure_statistic_data
*copyc ost$status
?? POP ??
?? TITLE := '    Xref Declarations ', EJECT ??
*copyc cmp$convert_channel_number
*copyc cmp$convert_iou_number
*copyc cmp$get_element_name
*copyc cmp$process_state_change
*copyc cmp$state_change_pending
*copyc iop$issue_ccc_cart_log_entry
*copyc iop$issue_ipi_log_entry
?? TITLE := '    [XDCL] iop$log_tape_data', EJECT ??
  PROCEDURE [XDCL] iop$log_tape_data (p_data: ^SEQ ( * );
    VAR status: ost$status);

    VAR
      data_p: ^SEQ ( * ),
      i: integer,
      p_major_status: ^array [1 .. ioc$ipi_max_status_size] of 0 .. 0ff(16),
      tape_log_data: iot$ipi_tape_log_data,
      seq_p: ^SEQ ( * ),
      status_length: 0 .. ioc$ipi_max_status_size,
      tape_failure_data: iot$ipi_tape_failure_data;

    status.normal := TRUE;

    seq_p := #SEQ (tape_log_data);
    RESET seq_p;
    NEXT data_p: [[REP #SIZE (p_data^) of cell]] IN seq_p;
    RESET data_p;
    data_p^ := p_data^;

    IF tape_log_data.unit_type = ioc$ccc_cart THEN
      process_ccc_cart_log (tape_log_data, status);
      RETURN;
    IFEND;

    tape_failure_data.package.pp_number.initial_error_status_register := 0;
    tape_failure_data.package.pp_number.final_error_status_register := 0;
    tape_failure_data.package.pp_number.fill1 := 0;
    tape_failure_data.package.pp_number.iou := tape_log_data.iou_number;
    tape_failure_data.package.pp_number.fill2 := 0;
    tape_failure_data.package.pp_number.i4_port_a := 0;
    tape_failure_data.package.pp_number.i4_port_b := 0;

    IF tape_log_data.channel.concurrent THEN
      tape_failure_data.package.pp_number.concurrent := 1;
    ELSE
      tape_failure_data.package.pp_number.concurrent := 0;
    IFEND;

    tape_failure_data.package.channel_number.initial_error_status_register := 0;
    tape_failure_data.package.channel_number.final_error_status_register := 0;
    tape_failure_data.package.channel_number.fill1 := 0;
    tape_failure_data.package.channel_number.iou := tape_log_data.iou_number;
    tape_failure_data.package.channel_number.fill2 := 0;

    IF tape_log_data.channel.concurrent THEN
      tape_failure_data.package.channel_number.concurrent := 1;
      IF tape_log_data.channel.port = cmc$port_a THEN
        tape_failure_data.package.channel_number.i4_port_a := 1;
        tape_failure_data.package.channel_number.i4_port_b := 0;
      ELSE
        tape_failure_data.package.channel_number.i4_port_a := 0;
        tape_failure_data.package.channel_number.i4_port_b := 1;
      IFEND;
    ELSE
      tape_failure_data.package.channel_number.i4_port_a := 0;
      tape_failure_data.package.channel_number.i4_port_b := 0;
      tape_failure_data.package.channel_number.concurrent := 0;
    IFEND;

    tape_failure_data.package.channel_number.resource_number := tape_log_data.channel.number;
    tape_failure_data.package.equipment_number := tape_log_data.controller_number;
    tape_failure_data.package.physical_unit_number := tape_log_data.unit_number;
    tape_failure_data.package.unit_type := 9;
    tape_failure_data.package.operation_code := 0;

    IF (tape_log_data.ipi_status.error_id = ioc$executing_controller_diag) OR
          (tape_log_data.ipi_status.error_id = ioc$controller_diag_passed)  THEN
      tape_failure_data.package.failure_severity := 3;  { informative
    ELSEIF tape_log_data.logical_unit <> 0 THEN  { set intermediate
      tape_failure_data.package.failure_severity := 2;
    ELSEIF (tape_log_data.ipi_status.error_id = ioc$ipi_controller_failure) OR
          (tape_log_data.ipi_status.error_id = ioc$drive_failure) OR
          (tape_log_data.ipi_status.error_id = ioc$internal_controller_error) OR
          (tape_log_data.ipi_status.error_id = ioc$controller_intervention_req) OR
          (tape_log_data.ipi_status.error_id = ioc$command_exception) OR
          (tape_log_data.ipi_status.error_id = ioc$microcode_execution_error) OR
          (tape_log_data.ipi_status.error_id = ioc$master_slave_data_integrity) OR
          (tape_log_data.ipi_status.error_id = ioc$slave_fac_data_integrity) THEN
      tape_failure_data.package.failure_severity := 1;       { set to unrecovered
    ELSE  { set to informative
      tape_failure_data.package.failure_severity := 3;
    IFEND;

    tape_failure_data.package.failure_symptom_code := tape_log_data.ipi_status.error_id;
    tape_failure_data.package.blocks_written := 0;
    tape_failure_data.package.blocks_read := 0;
    tape_failure_data.package.single_double_track_corrections := 0;
    tape_failure_data.package.unused_fill1 := 0;
    tape_failure_data.package.block_count := 0;
    tape_failure_data.package.tapemark_count := 0;
    tape_failure_data.package.tape_format_parameters := 0;
    tape_failure_data.package.density := 0;
    tape_failure_data.package.unused_fill2 := 0;
    tape_failure_data.package.recovery_retry_count := 0;
    tape_failure_data.package.last_requested_function := tape_log_data.ipi_status.
          function_with_timeout;
    tape_failure_data.package.ipi_status_register := tape_log_data.ipi_status.ipi_status_register;
    tape_failure_data.package.ipi_error_register := tape_log_data.ipi_status.ipi_error_register;
    tape_failure_data.package.i4_error_register := tape_log_data.ipi_status.i4_dma_error_register;
    tape_failure_data.package.i4_operation_register := tape_log_data.ipi_status.
          i4_dma_operational_status_reg;
    tape_failure_data.package.i4_control_register := tape_log_data.ipi_status.
          i4_dma_control_register;
    tape_failure_data.package.interface_error_code := tape_log_data.interface_error_code;
    tape_failure_data.package.unused_fill3 := 0;
    tape_failure_data.package.unused_fill4 := 0;
    tape_failure_data.package.unused_fill5 := 0;
    tape_failure_data.package.unused_fill6 := 0;
    tape_failure_data.package.unused_fill7 := 0;
    p_major_status := #LOC (tape_log_data.ipi_status.major_status_header);

    IF (tape_log_data.response_length <= ioc$min_ipi_total_resp_size) THEN
      FOR i := 1 to 8 DO
        tape_failure_data.package.ipi_status [i] := 0;
      FOREND;
    ELSE
      status_length := tape_log_data.ipi_status.major_status_header.length + 2;
      FOR i := 1 TO status_length DO
        tape_failure_data.package.ipi_status [i] := p_major_status^ [i];
      FOREND;
    IFEND;

    iop$issue_ipi_log_entry (^tape_failure_data, tape_log_data.logical_unit,
          status);

  PROCEND iop$log_tape_data;
?? OLDTITLE ??
?? NEWTITLE := '    process_ccc_cart_log', EJECT ??
  PROCEDURE process_ccc_cart_log (
        tape_log_data: iot$ipi_tape_log_data;
    VAR status: ost$status);

    VAR
      channel_name: cmt$element_name,
      channel_ordinal: cmt$channel_ordinal,
      element_descriptor: cmt$element_descriptor,
      i: integer,
      ignore_status: ost$status,
      iou_name: cmt$element_name,
      p_status: ^array [1 .. 8] of 0 .. 0ff(16),
      physical_id: cmt$physical_identification ,
      tape_failure_data: iot$ccc_cart_tape_failure_data,
      valid_channel: boolean;

    status.normal := TRUE;

    tape_failure_data.package.pp_number.initial_error_status_register := 0;
    tape_failure_data.package.pp_number.final_error_status_register := 0;
    tape_failure_data.package.pp_number.fill1 := 0;
    tape_failure_data.package.pp_number.iou := tape_log_data.iou_number;
    tape_failure_data.package.pp_number.fill2 := 0;
    tape_failure_data.package.pp_number.i4_port_a := 0;
    tape_failure_data.package.pp_number.i4_port_b := 0;

    IF tape_log_data.channel.concurrent THEN
      tape_failure_data.package.pp_number.concurrent := 1;
    ELSE
      tape_failure_data.package.pp_number.concurrent := 0;
    IFEND;

    tape_failure_data.package.channel_number.initial_error_status_register := 0;
    tape_failure_data.package.channel_number.final_error_status_register := 0;
    tape_failure_data.package.channel_number.fill1 := 0;
    tape_failure_data.package.channel_number.iou := tape_log_data.iou_number;
    tape_failure_data.package.channel_number.fill2 := 0;

    IF tape_log_data.channel.concurrent THEN
      tape_failure_data.package.channel_number.concurrent := 1;
    ELSE
      tape_failure_data.package.channel_number.concurrent := 0;
    IFEND;
    tape_failure_data.package.channel_number.i4_port_a := 0;
    tape_failure_data.package.channel_number.i4_port_b := 0;

    tape_failure_data.package.channel_number.resource_number := tape_log_data.channel.number;
    tape_failure_data.package.equipment_number := tape_log_data.controller_number;
    tape_failure_data.package.physical_unit_number := tape_log_data.unit_number;
    tape_failure_data.package.unit_type := 10;
    tape_failure_data.package.operation_code := 0;
    tape_failure_data.package.failure_severity := 1;       { set to unrecovered
    tape_failure_data.package.failure_symptom_code := tape_log_data.ccc_cart_status.error_id;
    tape_failure_data.package.blocks_written := 0;
    tape_failure_data.package.blocks_read := 0;
    tape_failure_data.package.on_the_fly_read_corrections := 0;
    tape_failure_data.package.on_the_fly_write_corrections := 0;
    tape_failure_data.package.block_count := 0;
    tape_failure_data.package.tapemark_count := 0;
    tape_failure_data.package.read_recovery_count := 0;
    tape_failure_data.package.write_recovery_count := 0;
    tape_failure_data.package.last_function.last_not_status := tape_log_data.ccc_cart_status.
          last_non_status_function;
    tape_failure_data.package.last_function.last := tape_log_data.ccc_cart_status.last_function;
    tape_failure_data.package.last_function.fill := 0;
    tape_failure_data.package.recovery_retry_count := 0;
    tape_failure_data.package.first_error_status_register := tape_log_data.ccc_cart_status.
          channel_error_register;
    tape_failure_data.package.final_error_status_register := tape_log_data.ccc_cart_status.
          channel_error_register;
    p_status := #LOC(tape_log_data.ccc_cart_status);
    FOR i := 1 TO 8 DO
      tape_failure_data.package.initial_status [i] := p_status^ [i];
      tape_failure_data.package.final_status [i] := p_status^ [i];
    FOREND;
    FOR i := 1 TO 40 DO
      tape_failure_data.package.initial_sense_bytes [i] := 0;
      tape_failure_data.package.final_sense_bytes [i] := 0;
    FOREND;
    tape_failure_data.package.density := 0;
    tape_failure_data.package.buffer_underruns := 0;
    tape_failure_data.package.res2 := 0;
    tape_failure_data.package.last_failure_info.fill := 0;
    tape_failure_data.package.last_failure_info.error_id := 0;
    tape_failure_data.package.last_failure_info.last_non_status_function := 0;
    tape_failure_data.package.last_failure_info.last_function := 0;

    iop$issue_ccc_cart_log_entry (^tape_failure_data, tape_log_data.logical_unit,
          status);

    IF tape_log_data.ccc_cart_status.error_id = ioc$ccc_cart_microcode_load THEN

{ Attempt to DOWN the controller.

      cmp$convert_channel_number (tape_log_data.channel.number, tape_log_data.channel.concurrent,
            tape_log_data.channel.port, channel_ordinal, channel_name, valid_channel);

      cmp$convert_iou_number (tape_log_data.iou_number, iou_name, status);

      IF status.normal AND valid_channel THEN
        physical_id.product_identification.product_number := '     ';
        physical_id.product_identification.underscore := ' ';
        physical_id.product_identification.model_number := '   ';
        physical_id.serial_number := '   ';
        physical_id.hardware_address.physical_address_specifier :=
              $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address];
        physical_id.hardware_address.iou := iou_name;
        physical_id.hardware_address.channel.ordinal := channel_ordinal;
        physical_id.hardware_address.channel.iou := iou_name;
        physical_id.hardware_address.channel_address :=
              tape_log_data.controller_number;
        cmp$get_element_name (physical_id, element_descriptor, ignore_status);
        IF ignore_status.normal AND NOT (cmp$state_change_pending (element_descriptor)) THEN
          cmp$process_state_change ({tape=} TRUE, {clear_lock_behind=} TRUE, {system_call=} TRUE,
              element_descriptor, {system_critical} FALSE,
              cmc$on, cmc$down, ignore_status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND process_ccc_cart_log;

MODEND iom$log_tape_data;

*DECK DECK=IOM$MANAGE_RVL_TUSL_STRUCTURES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Tape Management: Manage Mainframe Tape Tables', EJECT ??
MODULE iom$manage_rvl_tusl_structures;

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_states
*copyc cmv$logical_unit_table
*copyc dme$tape_errors
*copyc dmt$global_file_name
*copyc iot$density_states
*copyc iot$new_vsns_online
*copyc iot$requested_volume_attributes
*copyc iot$requested_vsn_list_entry
*copyc iot$robotic_server_entry
*copyc iot$robotic_server_index
*copyc iot$rvl_entry_information
*copyc iot$set_assignment_results
*copyc iot$tape_unit_status_list
*copyc iot$tusl_ordinal
*copyc iot$tusl_entry_access
*copyc osd$integer_limits
*copyc oss$mainframe_pageable
*copyc oss$mainframe_paged_literal
*copyc ost$name
*copyc rmc$unspecified_vsn
*copyc rme$condition_codes
*copyc rmt$rbt_server_attribute
*copyc rmt$volume_list
*copyc rmt$write_ring
?? POP ??

*copyc clp$construct_path_handle_name
*copyc cmp$get_element_name_via_lun
*copyc cmp$get_element_state
*copyc cmp$get_logical_unit_number
*copyc cmp$lock_lun_entry
*copyc cmp$unlock_lun_entry
*copyc dmv$null_sfid
*copyc iop$determine_density_support
*copyc iov$tusl_lock
*copyc iov$tusl_p
*copyc jmp$find_jsn
*copyc jmv$jcb
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$clear_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$test_set_main_sig_lock
*copyc osp$test_sig_lock
*copyc osv$mainframe_pageable_heap
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_time
*copyc pmp$ready_task
*copyc tmv$null_global_task_id

?? OLDTITLE ??
?? NEWTITLE := 'Global Variables Declared by This Module', EJECT ??

  CONST
    include_radix = TRUE,
    radix = 10;

  VAR
    iov$backward_rvl_p: [XDCL, oss$mainframe_pageable] ^iot$requested_vsn_list_entry := NIL,
    iov$forward_rvl_p: [XDCL, oss$mainframe_pageable] ^iot$requested_vsn_list_entry := NIL,
    iov$last_robotic_tusl_ordinal: [XDCL, oss$mainframe_pageable] iot$tusl_ordinal := 1,
    iov$robotic_request_id: [XDCL, oss$mainframe_pageable] rmt$rbt_request_id := 0,
    iov$robotic_server_array_p: [XDCL, oss$mainframe_pageable] ^array [ 1 .. * ]
          OF iot$robotic_server_entry := NIL,
    iov$rvl_lock: [XDCL, oss$mainframe_pageable] ost$signature_lock := [0];

  VAR
    rvl_entry_template: [READ, oss$mainframe_paged_literal] iot$requested_vsn_list_entry := [
          {ssn} osc$null_name,
          {sfid} [0, gfc$tr_null_residence, gfc$null_file_hash],
          {path_handle_name} osc$null_name,
          {global_file_name} [
            {serial_number} 0,
            {model_number} 0,
            {year} 1980,
            {month} 1,
            {day} 1,
            {hour} 0,
            {minute} 0,
            {second} 0,
            {sequence_number} 0,
            {fill} 0],
          {forward_link} NIL,
          {backward_link} NIL,
          {vsn_state} ioc$unassigned,
          {gtid} [0, 0],
          {assigned_element_name} osc$null_name,
          {assignment_terminated} FALSE,
          {recovery_assignment} FALSE,
          {message} '',
          {time_of_mount_request} '',
          {operator_assignment_type} ioc$unknown_assignment_type,
          {next_in_vsn_queue} NIL,
          {previous_in_vsn_queue} NIL,
          {current_vsn_p} NIL,
          {first_vsn_entry_p} NIL,
          {last_vsn_entry_p} NIL,
          {requested_tape_characteristics} [
            {label_type} amc$labelled,
            {character_set} amc$ascii,
            {write_ring} FALSE,
            {density} rmc$6250],
          {requested_volume_attributes } [
            {account } osc$null_name,
            {family } osc$null_name,
            {project } osc$null_name,
            {removable_media_group } osc$null_name,
            {removable_media_location } osc$null_name,
            {slot: } osc$null_name,
            {user:  } osc$null_name],
          {robotic_communication} NIL];

?? OLDTITLE ??
?? NEWTITLE := 'Pictorial Overview of the RVL.', EJECT ??
{
{
{                                      PICTORIAL REPRESENTATION OF RVL
{
{
{
{
{ iov$backward_rvl_p ________________________________________________________
{ iov$forward_rvl_p ___                                                      |
{                      |   ____________________________________________      |
{  ____________________|  |                                            |     |
{ |                       |                           _________________|_____|_________________________
{ |                       |                          |                 |     |                         |
{ |    ___________________V____          ____________V___________      |    _V______________________   |
{ --->|REQUESTED_VSN_LIST_ENTRY|  ----->|REQUESTED_VSN_LIST_ENTRY|  ---|-->|REQUESTED_VSN_LIST_ENTRY|  |
{     |------------------------|  |     |------------------------|  |  |   |------------------------|  |
{     |forward_link            |__|     |forward_link            |__|  |   |forward_link      = NIL |  |
{     |backward_link     = NIL |        |backward_link           |_____|   |backward_link           |__|
{     |      .                 |        |      .                 |         |      .                 |
{     |      .                 |        |      .                 |         |      .                 |
{     |first_vsn_entry_p       |____    |first_vsn_entry_p       |____     |first_vsn_entry_p       |____
{     |last_vsn_entry_p        |__  |   |last_vsn_entry_p        |__  |    |last_vsn_entry_p        |__  |
{     |________________________|  | |   |________________________|  | |    |________________________|  | |
{  _______________________________| |    ___________________________| |  ______________________________| |
{ |    _____________________________|   |  ___________________________| |   _____________________________|
{ |   |  ____________________________   | |                             |  |   ______________________________
{ |   | |                            |  | |                             |  |  |                              |
{ |   V_V______________________      |  V_V______________________       |  V__V_____________________         |
{ |   |       VSN_ENTRY        |     |  |       VSN_ENTRY        |      |  |       VSN_ENTRY        |        |
{ |   |------------------------|     |  |------------------------|      |  |------------------------|        |
{ |   |next_vsn_p              |__   |  |next_vsn_p        =NIL  |      |  |next_vsn_p              |__      |
{ |   |previous_vsn_p    =NIL  |  |  |  |previous_vsn_p    =NIL  |      |  |previous_vsn_p    =NIL  |  |     |
{ |   |________________________|  |  |  |________________________|      |  |________________________|  |     |
{ |                               |  |                                  |   ___________________________|     |
{ |    ___________________________|  |                                  |  |   ___________________________   |
{ |   |                              |                                  |  |  |                           |  |
{ |   V________________________      |                                  |  V__V_____________________      |  |
{ --->|       VSN_ENTRY        |     |                                  |  |       VSN_ENTRY        |     |  |
{     |------------------------|     |                                  |  |------------------------|     |  |
{     |next_vsn_p        =NIL  |     |                                  |  |next_vsn_p              |__   |  |
{     |previous_vsn_p          |_____|                                  |  |previous_vsn_p          |__|__|__|
{     |________________________|                                        |  |________________________|  |  |
{                                                                       |   ___________________________|  |
{                                                                       |  |                              |
{                                                                       |  |                              |
{                                                                       |  V________________________      |
{                                                                       -->|       VSN_ENTRY        |     |
{                                                                          |------------------------|     |
{                                                                          |next_vsn_p        =NIL  |     |
{                                                                          |previous_vsn_p          |_____|
{                                                                          |________________________|
{
{
{

?? OLDTITLE ??
?? NEWTITLE := 'clear_mainframe_sig_lock', EJECT ??

  PROCEDURE clear_mainframe_sig_lock
    (VAR lock: ost$signature_lock);

    VAR
      lock_status: ost$signature_lock_status,
      locked: boolean;

      osp$test_sig_lock (lock, lock_status);
      IF lock_status = osc$sls_locked_by_current_task THEN
        osp$clear_mainframe_sig_lock  (lock);
      IFEND;

  PROCEND clear_mainframe_sig_lock;

?? OLDTITLE ??
?? NEWTITLE := 'delete_rvl_entry', EJECT ??

  PROCEDURE delete_rvl_entry
    (    path_handle: fmt$path_handle;
     VAR status: ost$status);

    VAR
      local_path_handle: fmt$path_handle,
      path_handle_name: fst$path_handle_name,
      rvl_p: ^iot$requested_vsn_list_entry,
      tusl_entry_found: boolean,
      tusl_ordinal: iot$tusl_ordinal,
      unit_type: iot$unit_type,
      vsn_p: ^iot$vsn_entry;

    status.normal := TRUE;

    local_path_handle := path_handle;
    local_path_handle.open_position.specified := FALSE;
    clp$construct_path_handle_name (local_path_handle, path_handle_name);

  /rvl_search/
    BEGIN
      rvl_p := iov$forward_rvl_p;
      WHILE rvl_p <> NIL DO
        IF (rvl_p^.ssn = jmv$jcb.system_name) AND (rvl_p^.path_handle_name = path_handle_name) THEN
          EXIT /rvl_search/;
        IFEND;
        rvl_p := rvl_p^.forward_link;
      WHILEND;
      osp$set_status_abnormal (rmc$resource_management_id, rme$cant_find_rvl_entry, 'delete_rvl_entry',
            status);
      RETURN;
    END /rvl_search/;

    WHILE rvl_p^.first_vsn_entry_p <> NIL DO
      vsn_p := rvl_p^.last_vsn_entry_p;
      IF rvl_p^.first_vsn_entry_p = rvl_p^.last_vsn_entry_p THEN
        rvl_p^.first_vsn_entry_p := NIL;
        rvl_p^.last_vsn_entry_p := NIL;
      ELSE
        rvl_p^.last_vsn_entry_p := rvl_p^.last_vsn_entry_p^.previous_vsn_p;
        rvl_p^.last_vsn_entry_p^.next_vsn_p := NIL;
      IFEND;
      FREE vsn_p IN osv$mainframe_pageable_heap^;
    WHILEND;

    IF iov$forward_rvl_p = iov$backward_rvl_p THEN
      iov$forward_rvl_p := NIL;
      iov$backward_rvl_p := NIL;
    ELSEIF iov$forward_rvl_p = rvl_p THEN
      iov$forward_rvl_p := rvl_p^.forward_link;
      iov$forward_rvl_p^.backward_link := NIL;
    ELSEIF iov$backward_rvl_p = rvl_p THEN
      iov$backward_rvl_p := rvl_p^.backward_link;
      iov$backward_rvl_p^.forward_link := NIL;
    ELSE
      rvl_p^.backward_link^.forward_link := rvl_p^.forward_link;
      rvl_p^.forward_link^.backward_link := rvl_p^.backward_link;
    IFEND;

    FREE rvl_p IN osv$mainframe_pageable_heap^;

  PROCEND delete_rvl_entry;

?? OLDTITLE ??
?? NEWTITLE := 'delete_rvl_entry_from_vsn_queue ', EJECT ??

  PROCEDURE delete_rvl_entry_from_vsn_queue
    (    rvl_p: ^iot$requested_vsn_list_entry);

    VAR
      current_time: ost$time,
      ignore_status: ost$status;;

      IF rvl_p^.next_in_vsn_queue = NIL THEN
        IF rvl_p^.previous_in_vsn_queue <> NIL THEN
          rvl_p^.previous_in_vsn_queue^.next_in_vsn_queue := NIL;
          rvl_p^.previous_in_vsn_queue := NIL;
        IFEND;
      ELSE
        IF rvl_p^.previous_in_vsn_queue = NIL THEN
          rvl_p^.next_in_vsn_queue^.previous_in_vsn_queue := NIL;
          IF rvl_p^.next_in_vsn_queue^.gtid <> tmv$null_global_task_id THEN
            pmp$ready_task (rvl_p^.next_in_vsn_queue^.gtid, ignore_status);
          IFEND;
          rvl_p^.next_in_vsn_queue := NIL;
        ELSE
          rvl_p^.next_in_vsn_queue^.previous_in_vsn_queue := rvl_p^.previous_in_vsn_queue;
          rvl_p^.previous_in_vsn_queue^.next_in_vsn_queue := rvl_p^.next_in_vsn_queue;
          rvl_p^.next_in_vsn_queue := NIL;
          rvl_p^.previous_in_vsn_queue := NIL;
        IFEND;
      IFEND;

  PROCEND delete_rvl_entry_from_vsn_queue;

?? OLDTITLE ??
?? NEWTITLE := 'locate_element_in_tusl', EJECT ??

  PROCEDURE locate_element_in_tusl
    (    element_name: cmt$element_name;
     VAR tusl_ordinal: iot$tusl_ordinal;
     VAR status: ost$status);

    VAR
      local_tusl_ordinal: iot$tusl_ordinal;

    status.normal := TRUE;

    FOR local_tusl_ordinal := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
      IF iov$tusl_p^ [local_tusl_ordinal].element_name = element_name THEN
        tusl_ordinal := local_tusl_ordinal;
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal (rmc$resource_management_id, dme$tape_unit_undefined, element_name,
          status);

  PROCEND locate_element_in_tusl;

?? OLDTITLE ??
?? NEWTITLE := 'locate_first_queued_rvl_p ', EJECT ??

  PROCEDURE locate_first_queued_rvl_p
    (    requested_density: rmt$density;
         requested_evsn: rmt$external_vsn;
         requested_rvsn: rmt$recorded_vsn;
     VAR first_queued_rvl_p: ^iot$requested_vsn_list_entry);

    VAR
      rvl_p: ^iot$requested_vsn_list_entry;

    first_queued_rvl_p := NIL;
    rvl_p := iov$forward_rvl_p;
    WHILE rvl_p <> NIL DO
      IF (rvl_p^.requested_tape_characteristics.density = requested_density) AND
            (rvl_p^.current_vsn_p <> NIL) AND
            (rvl_p^.current_vsn_p^.rvsn = requested_rvsn) AND
            (rvl_p^.current_vsn_p^.evsn = requested_evsn) AND
            (rvl_p^.vsn_state >= ioc$queued_for_assignment) THEN
        WHILE rvl_p^.previous_in_vsn_queue <> NIL DO
          rvl_p := rvl_p^.previous_in_vsn_queue;
        WHILEND;
        first_queued_rvl_p := rvl_p;
        RETURN;
      ELSE
        rvl_p := rvl_p^.forward_link;
      IFEND;
    WHILEND;
  PROCEND locate_first_queued_rvl_p;

?? OLDTITLE ??
?? NEWTITLE := 'locate_new_request_in_rvl', EJECT ??

  PROCEDURE locate_new_request_in_rvl
    (VAR rvl_p: ^iot$requested_vsn_list_entry;
     VAR status: ost$status);

    status.normal := TRUE;
    rvl_p := iov$forward_rvl_p;

  /locate_new_client_request/
    WHILE rvl_p <> NIL DO
      IF (rvl_p^.robotic_communication <> NIL) AND
            NOT rvl_p^.robotic_communication^.server_received_request THEN
        EXIT /locate_new_client_request/;
      IFEND;
      rvl_p := rvl_p^.forward_link;
    WHILEND /locate_new_client_request/;

    IF rvl_p = NIL THEN
      osp$set_status_abnormal (rmc$resource_management_id, rme$no_requests_available,
            'LOCATE_NEW_REQUEST_IN_RVL', status);
    IFEND;

  PROCEND locate_new_request_in_rvl;

?? OLDTITLE ??
?? NEWTITLE := 'locate_request_id_in_rvl', EJECT ??

  PROCEDURE locate_request_id_in_rvl
    (    request_id: rmt$rbt_request_id;
     VAR rvl_p: ^iot$requested_vsn_list_entry;
     VAR status: ost$status);

    status.normal := TRUE;
    rvl_p := iov$forward_rvl_p;

  /locate_request_id/
    WHILE rvl_p <> NIL DO
      IF (rvl_p^.robotic_communication <> NIL) AND
            (rvl_p^.robotic_communication^.client_request.request_id = request_id) THEN
        EXIT /locate_request_id/;
      IFEND;
      rvl_p := rvl_p^.forward_link;
    WHILEND /locate_request_id/;

    IF rvl_p = NIL THEN
      osp$set_status_abnormal (rmc$resource_management_id, rme$request_not_found, 'LOCATE_REQUEST_ID_IN_RVL',
            status);
      osp$append_status_integer (osc$status_parameter_delimiter, request_id, radix, NOT include_radix,
            status);
    IFEND;

  PROCEND locate_request_id_in_rvl;

?? OLDTITLE ??
?? NEWTITLE := 'locate_robotic_server_entry', EJECT ??

  PROCEDURE locate_robotic_server_entry
    (    server_name: ost$name;
     VAR p_robotic_server_entry: ^iot$robotic_server_entry;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      robotic_server_index: ost$positive_integers;

    status.normal := TRUE;
    p_robotic_server_entry := NIL;

    IF iov$robotic_server_array_p = NIL THEN
      osp$set_status_abnormal (rmc$resource_management_id, rme$server_not_defined,
            'LOCATE_ROBOTIC_SERVER_ENTRY', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, server_name, status);
      RETURN;
    IFEND;

    FOR robotic_server_index := LOWERBOUND (iov$robotic_server_array_p^)
          TO UPPERBOUND (iov$robotic_server_array_p^) DO
      IF iov$robotic_server_array_p^ [robotic_server_index].server_name = server_name THEN
        p_robotic_server_entry := ^iov$robotic_server_array_p^ [robotic_server_index];
        jmp$find_jsn (iov$robotic_server_array_p^ [robotic_server_index].server_job_name, ijle_p,
              ijl_ordinal);
        IF ijle_p = NIL THEN
          remove_robotic_server_entry (p_robotic_server_entry, ignore_status);
          osp$set_status_abnormal (rmc$resource_management_id, rme$server_not_defined,
                'LOCATE_ROBOTIC_SERVER_ENTRY', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, server_name, status);
        IFEND;
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal (rmc$resource_management_id, rme$server_not_defined,
          'LOCATE_ROBOTIC_SERVER_ENTRY', status);
    osp$append_status_parameter (osc$status_parameter_delimiter, server_name, status);

  PROCEND locate_robotic_server_entry;

?? OLDTITLE ??
?? NEWTITLE := 'locate_rvl_entry_by_sfid', EJECT ??

  PROCEDURE locate_rvl_entry_by_sfid
    (    sfid: dmt$system_file_id;
         ssn: jmt$system_supplied_name;
     VAR rvl_p: ^iot$requested_vsn_list_entry;
     VAR status: ost$status);

    VAR
      sfid_string: string (13),
      sfid_string_length: integer;

    status.normal := TRUE;
    rvl_p := iov$forward_rvl_p;

    WHILE rvl_p <> NIL DO
      IF (rvl_p^.ssn = ssn) AND (rvl_p^.sfid = sfid) THEN
        RETURN;
      IFEND;
      rvl_p := rvl_p^.forward_link;
    WHILEND;

    IF rvl_p = NIL THEN
      osp$set_status_abnormal (rmc$resource_management_id, rme$sfid_not_found,
            'LOCATE_RVL_ENTRY_BY_SFID', status);
      STRINGREP (sfid_string, sfid_string_length, '[', sfid.file_entry_index, ',', sfid.residence, ',',
            sfid.file_hash, ']');
      osp$append_status_parameter (osc$status_parameter_delimiter, sfid_string, status);
    IFEND;

  PROCEND locate_rvl_entry_by_sfid;

?? OLDTITLE ??
?? NEWTITLE := 'locate_volume_in_rvl_entry', EJECT ??

  PROCEDURE locate_volume_in_rvl_entry
    (    rvl_p: ^iot$requested_vsn_list_entry;
         requested_density: rmt$density;
         requested_evsn: rmt$external_vsn;
         requested_rvsn: rmt$recorded_vsn;
     VAR volume_p: ^iot$vsn_entry;
     VAR status: ost$status);

    status.normal := TRUE;
    volume_p := rvl_p^.first_vsn_entry_p;
    IF (rvl_p^.requested_tape_characteristics.density = requested_density) THEN
      WHILE volume_p <> NIL DO
        IF (volume_p^.rvsn = requested_rvsn) AND (volume_p^.evsn = requested_evsn) THEN
          RETURN;
        IFEND;
        volume_p := volume_p^.next_vsn_p;
      WHILEND;
    IFEND;
    osp$set_status_abnormal (rmc$resource_management_id, rme$cant_find_specified_vsn,
          'LOCATE_RVL_ENTRY_BY_VOLUME', status);

  PROCEND locate_volume_in_rvl_entry;

?? OLDTITLE ??
?? NEWTITLE := 'remove_robotic_server_entry', EJECT ??

  PROCEDURE remove_robotic_server_entry
    (    p_robotic_server_entry: ^iot$robotic_server_entry;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      new_robotic_server_array_p: ^array [1 .. * ] of iot$robotic_server_entry,
      new_robotic_server_index: ost$positive_integers,
      old_robotic_server_index: ost$positive_integers,
      rvl_p: ^iot$requested_vsn_list_entry;

    IF p_robotic_server_entry^.managed_elements_p <> NIL THEN
      FREE p_robotic_server_entry^.managed_elements_p IN osv$mainframe_pageable_heap^;
    IFEND;

    IF UPPERBOUND (iov$robotic_server_array_p^) = 1 THEN
      new_robotic_server_array_p := NIL;
    ELSE
      ALLOCATE new_robotic_server_array_p: [1 .. (UPPERBOUND (iov$robotic_server_array_p^) - 1)] IN
            osv$mainframe_pageable_heap^;
      new_robotic_server_index := 1;
      FOR old_robotic_server_index := 1 TO UPPERBOUND (iov$robotic_server_array_p^) DO
        IF iov$robotic_server_array_p^ [old_robotic_server_index].server_name <>
              p_robotic_server_entry^.server_name THEN
          new_robotic_server_array_p^ [new_robotic_server_index] :=
                iov$robotic_server_array_p^ [old_robotic_server_index];
          new_robotic_server_index := new_robotic_server_index + 1;
        IFEND;
      FOREND;
    IFEND;

    rvl_p := iov$forward_rvl_p;
    WHILE rvl_p <> NIL DO
      IF (rvl_p^.robotic_communication <> NIL) AND (rvl_p^.gtid <> tmv$null_global_task_id) AND
            (rvl_p^.robotic_communication^.server_name = p_robotic_server_entry^.server_name) THEN
        pmp$ready_task (rvl_p^.gtid, ignore_status);
      IFEND;
      rvl_p := rvl_p^.forward_link;
    WHILEND;

    FREE iov$robotic_server_array_p IN osv$mainframe_pageable_heap^;

    iov$robotic_server_array_p := new_robotic_server_array_p;

  PROCEND remove_robotic_server_entry;

?? OLDTITLE ??
?? NEWTITLE := 'set_mainframe_sig_lock', EJECT ??

  PROCEDURE set_mainframe_sig_lock
    (    lock_string: string ( * <= osc$max_string_size);
     VAR lock: ost$signature_lock;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      lock_status: ost$signature_lock_status,
      locked: boolean;

      status.normal := TRUE;

      osp$test_sig_lock (lock, lock_status);
      IF lock_status = osc$sls_locked_by_current_task THEN
        clear_mainframe_sig_lock  (lock);
      ELSEIF lock_status = osc$sls_locked_by_another_task THEN
        osp$set_status_abnormal (rmc$resource_management_id, dme$unable_to_lock_tape_table, lock_string,
              status);
      IFEND;

      IF status.normal THEN
        osp$test_set_main_sig_lock (lock, locked);
        IF NOT locked THEN
          osp$set_status_abnormal (rmc$resource_management_id, dme$unable_to_lock_tape_table, lock_string,
                status);
        IFEND;
      IFEND;

  PROCEND set_mainframe_sig_lock;

?? OLDTITLE ??
?? NEWTITLE := 'validate_candidate_element', EJECT ??

  PROCEDURE validate_candidate_element
    (    candidate_element: cmt$element_name;
         acceptable_states: set of cmt$element_state;
     VAR status: ost$status);

    VAR
      element_state: cmt$element_state,
      tusl_ordinal: iot$tusl_ordinal;

    status.normal := TRUE;

  /validate_candidate_state/
    BEGIN

      cmp$get_element_state (candidate_element, {iou_name} osc$null_name, element_state, status);
      IF NOT status.normal THEN
        EXIT /validate_candidate_state/;
      IFEND;

      IF NOT (element_state IN acceptable_states) THEN
        osp$set_status_abnormal (rmc$resource_management_id, rme$element_not_available,
              'VALIDATE_CANDIDATE_ELEMENT', status);
        EXIT /validate_candidate_state/;
      IFEND;

      FOR tusl_ordinal := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
        IF (iov$tusl_p^ [tusl_ordinal].element_name = candidate_element) THEN
          IF (iov$tusl_p^ [tusl_ordinal].assignment_state = ioc$not_assigned) AND
             (iov$tusl_p^ [tusl_ordinal].tape_unit_state = cmc$on) THEN
            EXIT /validate_candidate_state/;
          ELSE
            osp$set_status_abnormal (rmc$resource_management_id, rme$element_not_available,
              'VALIDATE_CANDIDATE_ELEMENT', status);
            EXIT /validate_candidate_state/;
          IFEND;
        IFEND;
      FOREND;

      osp$set_status_abnormal (rmc$resource_management_id, rme$element_not_available,
            'VALIDATE_CANDIDATE_ELEMENT', status);

    END /validate_candidate_state/;

  PROCEND validate_candidate_element;

?? OLDTITLE ??
?? NEWTITLE := 'iop$access_tusl_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$access_tusl_entry
    (    tusl_ordinal: iot$tusl_ordinal;
     VAR tusl_entry_access: iot$tusl_entry_access;
     VAR status: ost$status);

    VAR
      global_task_id: ost$global_task_id,
      ignore_status: ost$status;

    set_mainframe_sig_lock ('IOV$TUSL_LOCK', iov$tusl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    set_mainframe_sig_lock ('TUSL_ENTRY_LOCK', iov$tusl_p^ [tusl_ordinal].lock, status);
    IF NOT status.normal THEN
      clear_mainframe_sig_lock (iov$tusl_lock);
      RETURN;
    IFEND;

    CASE tusl_entry_access.operation OF

      = ioc$disable_operator_reassign =
        iov$tusl_p^ [tusl_ordinal].reassign_device_control.command_allowed := FALSE;

      = ioc$enable_operator_reassign =
        pmp$get_executing_task_gtid (global_task_id);
        iov$tusl_p^ [tusl_ordinal].reassign_device_control.command_allowed := TRUE;
        iov$tusl_p^ [tusl_ordinal].reassign_device_control.command_entered := FALSE;
        iov$tusl_p^ [tusl_ordinal].reassign_device_control.global_task_id:= global_task_id;

      = ioc$fetch_operator_reassign =
        tusl_entry_access.fetch_operator_reassign :=
              iov$tusl_p^ [tusl_ordinal].reassign_device_control.command_entered;

      = ioc$set_operator_reassign =
        IF iov$tusl_p^ [tusl_ordinal].reassign_device_control.command_allowed THEN
          IF (iov$tusl_p^ [tusl_ordinal].assignment_state = ioc$manually_assigned) OR
                (iov$tusl_p^ [tusl_ordinal].assignment_state = ioc$automatically_assigned) THEN
            iov$tusl_p^ [tusl_ordinal].reassign_device_control.command_entered := TRUE;
            pmp$ready_task (iov$tusl_p^ [tusl_ordinal].reassign_device_control.global_task_id, ignore_status);
          ELSE
            osp$set_status_abnormal (rmc$resource_management_id, rme$element_name_not_assigned,
                  iov$tusl_p^ [tusl_ordinal].element_name, status);
          IFEND;
        ELSE
          osp$set_status_abnormal (rmc$resource_management_id, rme$reassign_not_allowed,
                iov$tusl_p^ [tusl_ordinal].element_name, status);
        IFEND;

      = ioc$store_tape_characteristics =
        iov$tusl_p^ [tusl_ordinal].detected_tape_characteristics.write_ring :=
              tusl_entry_access.store_write_ring;
        iov$tusl_p^ [tusl_ordinal].detected_tape_characteristics.density :=
              tusl_entry_access.store_density;

      = ioc$store_unit_ready =
        iov$tusl_p^ [tusl_ordinal].unit_ready := tusl_entry_access.store_unit_ready;
      ELSE
    CASEND;

    clear_mainframe_sig_lock (iov$tusl_p^ [tusl_ordinal].lock);
    clear_mainframe_sig_lock (iov$tusl_lock);

  PROCEND iop$access_tusl_entry;

?? OLDTITLE ??
?? NEWTITLE := 'iop$any_task_waiting_assignment', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$any_task_waiting_assignment
    (VAR tasks_are_waiting: boolean;
     VAR status: ost$status);

    VAR
      rvl_p: ^iot$requested_vsn_list_entry;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    tasks_are_waiting := FALSE;

  /search_rvl/
    BEGIN
      rvl_p := iov$forward_rvl_p;
      WHILE rvl_p <> NIL DO
        IF (rvl_p^.vsn_state = ioc$ready_for_assignment) AND
              (rvl_p^.operator_assignment_type = ioc$expecting_auto_assignment) THEN
          tasks_are_waiting := TRUE;
          EXIT /search_rvl/
        IFEND;
        rvl_p := rvl_p^.forward_link;
      WHILEND;
    END /search_rvl/;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$any_task_waiting_assignment;

?? OLDTITLE ??
?? NEWTITLE := 'iop$assign_tape_unit', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$assign_tape_unit
    (    sfid: gft$system_file_identifier;
         element_name: cmt$element_name;
         acceptable_states: cmt$element_states;
         label_type: amt$label_type;
     VAR logical_unit: iot$logical_unit;
     VAR status: ost$status);

    VAR
      entry_locked: boolean,
      entry_unlocked: boolean,
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      multiple_volumes_with_same_vsn: boolean,
      rvl_p: ^iot$requested_vsn_list_entry,
      tusl_ordinal: iot$tusl_ordinal;

    entry_locked := FALSE;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    set_mainframe_sig_lock ('IOV$TUSL_LOCK', iov$tusl_lock, status);
    IF NOT status.normal THEN
      clear_mainframe_sig_lock (iov$rvl_lock);
      RETURN;
    IFEND;

  /assign_tape_unit/
    BEGIN
      IF sfid <> dmv$null_sfid THEN
        locate_rvl_entry_by_sfid (sfid, jmv$jcb.system_name, rvl_p, status);
        IF NOT status.normal THEN
          EXIT /assign_tape_unit/;
        IFEND;

        locate_element_in_tusl (element_name, tusl_ordinal, status);
        IF NOT status.normal THEN
          EXIT /assign_tape_unit/;
        IFEND;
      IFEND;

      cmp$get_logical_unit_number (element_name, logical_unit, status);
      IF NOT status.normal THEN
        EXIT /assign_tape_unit/;
      IFEND;

      cmp$lock_lun_entry (logical_unit, entry_locked);
      IF NOT entry_locked THEN
        osp$set_status_abnormal (rmc$resource_management_id, dme$unable_to_lock_tape_table,
              'MAINFRAME LUN ENTRY', status);
        EXIT /assign_tape_unit/;
      IFEND;

      IF NOT (cmv$logical_unit_table^ [logical_unit].configured AND
            cmv$logical_unit_table^ [logical_unit].status.assignable_device) THEN
        osp$set_status_abnormal (rmc$resource_management_id, dme$tape_unit_undefined, '', status);
        EXIT /assign_tape_unit/;
      IFEND;

      IF cmv$logical_unit_table^ [logical_unit].element_capability = $cmt$element_capabilities [] THEN
        osp$set_status_abnormal (rmc$resource_management_id, dme$tape_unit_off, element_name, status);
        EXIT /assign_tape_unit/;
      IFEND;

      IF (cmc$volume_assignment IN cmv$logical_unit_table^ [logical_unit].element_capability) AND
            (acceptable_states * $cmt$element_states [cmc$on] = $cmt$element_states []) THEN
        osp$set_status_abnormal (rmc$resource_management_id, rme$element_not_available,
              'IOP$ASSIGN_TAPE_UNIT', status);
        EXIT /assign_tape_unit/;
      IFEND;

      IF (cmv$logical_unit_table^ [logical_unit].element_capability =
            $cmt$element_capabilities [cmc$concurrent_maintenance,
            cmc$dedicated_maintenance]) AND (acceptable_states * $cmt$element_states [cmc$down] =
            $cmt$element_states []) THEN
        osp$set_status_abnormal (rmc$resource_management_id, dme$tape_unit_down, element_name, status);
        EXIT /assign_tape_unit/;
      IFEND;

      IF cmv$logical_unit_table^ [logical_unit].status.assigned THEN
        jmp$find_jsn (cmv$logical_unit_table^ [logical_unit].status.assigned_jsn, ijle_p, ijl_ordinal);
        IF ijle_p <> NIL THEN
          osp$set_status_abnormal (rmc$resource_management_id, dme$unit_assigned, element_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                cmv$logical_unit_table^ [logical_unit].status.assigned_jsn, status);
          EXIT /assign_tape_unit/;
        IFEND;
      IFEND;

      IF sfid <> dmv$null_sfid THEN
        IF rvl_p^.current_vsn_p = NIL THEN
          osp$set_status_abnormal (rmc$resource_management_id, dme$no_vsn_selected,
                'IOP$ASSIGN_TAPE_UNIT', status);
          EXIT /assign_tape_unit/;
        IFEND;
        rvl_p^.vsn_state := ioc$assigned;
        rvl_p^.assigned_element_name := element_name;
        rvl_p^.assignment_terminated := FALSE;

        IF label_type = amc$labelled THEN
          rvl_p^.requested_tape_characteristics.label_type := amc$labelled;
        ELSE
          rvl_p^.requested_tape_characteristics.label_type := amc$unlabelled;
        IFEND;

        iov$tusl_p^ [tusl_ordinal].sfid := rvl_p^.sfid;
        iov$tusl_p^ [tusl_ordinal].assignment_state := ioc$automatically_assigned;
        iov$tusl_p^ [tusl_ordinal].ssn := rvl_p^.ssn;
        iov$tusl_p^ [tusl_ordinal].evsn := rvl_p^.current_vsn_p^.evsn;
        iov$tusl_p^ [tusl_ordinal].rvsn := rvl_p^.current_vsn_p^.rvsn;
        iov$tusl_p^ [tusl_ordinal].path_handle_name := rvl_p^.path_handle_name;
      IFEND;

      cmv$logical_unit_table^ [logical_unit].status.assigned := TRUE;
      cmv$logical_unit_table^ [logical_unit].status.assigned_jsn := jmv$jcb.system_name;

    END /assign_tape_unit/;

    IF entry_locked THEN
      cmp$unlock_lun_entry (logical_unit, entry_unlocked);
      IF status.normal AND (NOT entry_unlocked) THEN
        osp$set_status_abnormal (rmc$resource_management_id, dme$unable_to_release_lun_lock,
              'Unable to release lun entry in IOP$ASSIGN_TAPE_UNIT', status);
      IFEND;
    IFEND;

    clear_mainframe_sig_lock (iov$tusl_lock);
    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$assign_tape_unit;

?? OLDTITLE ??
?? NEWTITLE := 'iop$client_cancel_request', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$client_cancel_request
    (    server_name: ost$name;
         sfid: gft$system_file_identifier;
     VAR status: ost$status);

    VAR
      p_robotic_server_entry: ^iot$robotic_server_entry,
      rvl_p: ^iot$requested_vsn_list_entry,
      sfid_string: string (13),
      sfid_string_length: integer;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /client_cancel_request/
    BEGIN
      locate_robotic_server_entry (server_name, p_robotic_server_entry, status);
      IF NOT status.normal THEN
        EXIT /client_cancel_request/;
      IFEND;

      locate_rvl_entry_by_sfid (sfid, jmv$jcb.system_name, rvl_p, status);
      IF NOT status.normal THEN
        EXIT /client_cancel_request/;
      IFEND;

      IF rvl_p^.robotic_communication = NIL THEN
        EXIT /client_cancel_request/;
      IFEND;

      IF NOT (rvl_p^.ssn = jmv$jcb.system_name) AND (rvl_p^.robotic_communication^.server_name = server_name)
            THEN
        osp$set_status_abnormal (rmc$resource_management_id, rme$sfid_not_found, 'LOCATE_SFID_IN_RVL',
              status);
        STRINGREP (sfid_string, sfid_string_length, '[', sfid.file_entry_index, ',', sfid.residence, ',',
              sfid.file_hash, ']');
        osp$append_status_parameter (osc$status_parameter_delimiter, sfid_string, status);
        EXIT /client_cancel_request/;
      IFEND;

      IF rvl_p^.robotic_communication^.server_received_request AND
            rvl_p^.robotic_communication^.server_response_received THEN
        IF rvl_p^.robotic_communication^.server_response.request_processed AND
              (rvl_p^.robotic_communication^.server_response.processed_request = rmc$rbt_query) AND
              rvl_p^.robotic_communication^.server_response.query.volume_located AND
              NOT rvl_p^.robotic_communication^.server_response.query.already_mounted THEN

          IF rvl_p^.robotic_communication^.server_response.query.preferred_candidates <> NIL THEN
            FREE rvl_p^.robotic_communication^.server_response.query.preferred_candidates IN
                  osv$mainframe_pageable_heap^;
          IFEND;

          IF rvl_p^.robotic_communication^.server_response.query.remaining_candidates <> NIL THEN
            FREE rvl_p^.robotic_communication^.server_response.query.remaining_candidates IN
                  osv$mainframe_pageable_heap^;
          IFEND;
        IFEND;

        IF NOT rvl_p^.robotic_communication^.server_response.request_processed AND
              (rvl_p^.robotic_communication^.server_response.server_messages <> NIL) THEN
          FREE rvl_p^.robotic_communication^.server_response.server_messages IN osv$mainframe_pageable_heap^
        IFEND;
      IFEND;

      FREE rvl_p^.robotic_communication IN osv$mainframe_pageable_heap^;
    END /client_cancel_request/;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$client_cancel_request;

?? OLDTITLE ??
?? NEWTITLE := 'iop$client_delete_request', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$client_delete_request
    (    server_name: ost$name;
         request_id: rmt$rbt_request_id;
     VAR status: ost$status);

    VAR
      p_robotic_server_entry: ^iot$robotic_server_entry,
      rvl_p: ^iot$requested_vsn_list_entry;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /client_delete_request/
    BEGIN
      locate_robotic_server_entry (server_name, p_robotic_server_entry, status);
      IF NOT status.normal THEN
        EXIT /client_delete_request/;
      IFEND;

      locate_request_id_in_rvl (request_id, rvl_p, status);
      IF NOT status.normal THEN
        EXIT /client_delete_request/;
      IFEND;

      IF NOT ((rvl_p^.ssn = jmv$jcb.system_name) AND (rvl_p^.robotic_communication^.server_name =
            server_name) AND rvl_p^.robotic_communication^.server_received_request AND
            rvl_p^.robotic_communication^.server_response_received) THEN
        osp$set_status_abnormal (rmc$resource_management_id, rme$request_not_found,
              'IOP$CLIENT_DELETE_REQUEST', status);
        osp$append_status_integer (osc$status_parameter_delimiter, request_id, radix, NOT include_radix,
              status);
        EXIT /client_delete_request/;
      IFEND;

      IF rvl_p^.robotic_communication^.server_received_request AND
            rvl_p^.robotic_communication^.server_response_received THEN
        IF rvl_p^.robotic_communication^.server_response.request_processed AND
              (rvl_p^.robotic_communication^.server_response.processed_request = rmc$rbt_query) AND
              rvl_p^.robotic_communication^.server_response.query.volume_located AND
              NOT rvl_p^.robotic_communication^.server_response.query.already_mounted THEN

          IF rvl_p^.robotic_communication^.server_response.query.preferred_candidates <> NIL THEN
            FREE rvl_p^.robotic_communication^.server_response.query.preferred_candidates IN
                  osv$mainframe_pageable_heap^;
          IFEND;

          IF rvl_p^.robotic_communication^.server_response.query.remaining_candidates <> NIL THEN
            FREE rvl_p^.robotic_communication^.server_response.query.remaining_candidates IN
                  osv$mainframe_pageable_heap^;
          IFEND;
        IFEND;

        IF NOT rvl_p^.robotic_communication^.server_response.request_processed AND
              (rvl_p^.robotic_communication^.server_response.server_messages <> NIL) THEN
          FREE rvl_p^.robotic_communication^.server_response.server_messages IN osv$mainframe_pageable_heap^
        IFEND;
      IFEND;

      FREE rvl_p^.robotic_communication IN osv$mainframe_pageable_heap^;
    END /client_delete_request/;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$client_delete_request;

?? OLDTITLE ??
?? NEWTITLE := 'iop$client_get_response', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$client_get_response
    (    server_name: ost$name;
         request_id: rmt$rbt_request_id;
     VAR server_response: iot$formatted_server_response;
     VAR status: ost$status);

    VAR
      p_robotic_server_entry: ^iot$robotic_server_entry,
      rvl_p: ^iot$requested_vsn_list_entry;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /client_get_response/
    BEGIN
      locate_robotic_server_entry (server_name, p_robotic_server_entry, status);
      IF NOT status.normal THEN
        EXIT /client_get_response/;
      IFEND;

      locate_request_id_in_rvl (request_id, rvl_p, status);
      IF NOT status.normal THEN
        EXIT /client_get_response/;
      IFEND;

      IF NOT ((rvl_p^.ssn = jmv$jcb.system_name) AND (rvl_p^.robotic_communication^.server_name =
            server_name)) THEN
        osp$set_status_abnormal (rmc$resource_management_id, rme$request_not_found, 'IOP$CLIENT_GET_RESPONSE',
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, request_id, radix, NOT include_radix,
              status);
        EXIT /client_get_response/;
      IFEND;

      IF NOT (rvl_p^.robotic_communication^.server_received_request AND
            rvl_p^.robotic_communication^.server_response_received) THEN
        osp$set_status_abnormal (rmc$resource_management_id, rme$response_unavailable,
              'IOP$CLIENT_GET_RESPONSE', status);
        osp$append_status_integer (osc$status_parameter_delimiter, request_id, radix, NOT include_radix,
              status);
        EXIT /client_get_response/;
      IFEND;

      server_response := rvl_p^.robotic_communication^.server_response;

    END /client_get_response/;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$client_get_response;

?? OLDTITLE ??
?? NEWTITLE := 'iop$client_put_request', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$client_put_request
    (    server_name: ost$name;
         sfid: dmt$system_file_id;
         client_request: rmt$rbt_request;
     VAR request_id: rmt$rbt_request_id;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      p_robotic_server_entry: ^iot$robotic_server_entry,
      rvl_p: ^iot$requested_vsn_list_entry,
      waiting_tasks_index: ost$positive_integers;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /client_put_request/
    BEGIN
      locate_robotic_server_entry (server_name, p_robotic_server_entry, status);
      IF NOT status.normal THEN
        EXIT /client_put_request/;
      IFEND;

      locate_rvl_entry_by_sfid (sfid, jmv$jcb.system_name, rvl_p, status);
      IF NOT status.normal THEN
        EXIT /client_put_request/;
      IFEND;

      IF rvl_p^.robotic_communication <> NIL THEN
        osp$set_status_abnormal (rmc$resource_management_id, rme$client_request_active,
              'IOP$CLIENT_PUT_REQUEST', status);
        EXIT /client_put_request/;
      IFEND;

      ALLOCATE rvl_p^.robotic_communication IN osv$mainframe_pageable_heap^;
      rvl_p^.robotic_communication^.server_received_request := FALSE;
      rvl_p^.robotic_communication^.server_name := server_name;
      rvl_p^.robotic_communication^.client_request := client_request;
      iov$robotic_request_id := (iov$robotic_request_id + 1) MOD rmc$rbt_max_request_id;
      request_id := iov$robotic_request_id;
      rvl_p^.robotic_communication^.client_request.request_id := request_id;
      pmp$get_executing_task_gtid (rvl_p^.robotic_communication^.requesting_task);
      rvl_p^.robotic_communication^.server_response_received := FALSE;

      FOR waiting_tasks_index := LOWERBOUND (p_robotic_server_entry^.waiting_tasks)
            TO UPPERBOUND (p_robotic_server_entry^.waiting_tasks) DO
        IF p_robotic_server_entry^.waiting_tasks [waiting_tasks_index] <> tmv$null_global_task_id THEN
          pmp$ready_task (p_robotic_server_entry^.waiting_tasks [waiting_tasks_index], ignore_status);
        IFEND;
      FOREND;

    END /client_put_request/;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$client_put_request;

?? OLDTITLE ??
?? NEWTITLE := 'iop$create_rvl_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$create_rvl_entry
    (    sfid: dmt$system_file_id;
         density: rmt$density;
         global_file_name: dmt$global_file_name;
         path_handle: fmt$path_handle;
         requested_volume_attributes: iot$requested_volume_attributes,
         volume_list: rmt$volume_list;
         write_ring: rmt$write_ring;
     VAR status: ost$status);

    VAR
      alloc_vsn_p: ^iot$vsn_entry,
      ignore_status: ost$status,
      local_path_handle: fmt$path_handle,
      path_handle_name: fst$path_handle_name,
      rvl_p: ^iot$requested_vsn_list_entry,
      volume_list_index: ost$positive_integers;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    delete_rvl_entry (path_handle, ignore_status);

    local_path_handle := path_handle;
    local_path_handle.open_position.specified := FALSE;
    clp$construct_path_handle_name (local_path_handle, path_handle_name);

    ALLOCATE rvl_p IN osv$mainframe_pageable_heap^;

    rvl_p^ := rvl_entry_template;
    rvl_p^.ssn := jmv$jcb.system_name;
    rvl_p^.sfid := sfid;
    rvl_p^.global_file_name := global_file_name;
    rvl_p^.path_handle_name := path_handle_name;
    IF write_ring = rmc$no_write_ring THEN
      rvl_p^.requested_tape_characteristics.write_ring := FALSE;
    ELSE
      rvl_p^.requested_tape_characteristics.write_ring := TRUE;
    IFEND;
    rvl_p^.requested_tape_characteristics.density := density;
    rvl_p^.requested_volume_attributes := requested_volume_attributes;

    FOR volume_list_index := LOWERBOUND (volume_list) TO UPPERBOUND (volume_list) DO
      ALLOCATE alloc_vsn_p IN osv$mainframe_pageable_heap^;
      IF rvl_p^.first_vsn_entry_p = NIL THEN
        rvl_p^.first_vsn_entry_p := alloc_vsn_p;
        alloc_vsn_p^.previous_vsn_p := NIL;
      ELSE
        rvl_p^.last_vsn_entry_p^.next_vsn_p := alloc_vsn_p;
        alloc_vsn_p^.previous_vsn_p := rvl_p^.last_vsn_entry_p;
      IFEND;
      alloc_vsn_p^.next_vsn_p := NIL;
      rvl_p^.last_vsn_entry_p := alloc_vsn_p;
      rvl_p^.last_vsn_entry_p^.rvsn := volume_list [volume_list_index].recorded_vsn;
      rvl_p^.last_vsn_entry_p^.evsn := volume_list [volume_list_index].external_vsn;
    FOREND;

    IF iov$forward_rvl_p = NIL THEN
      iov$forward_rvl_p := rvl_p;
      iov$backward_rvl_p := rvl_p;
    ELSE
      rvl_p^.backward_link := iov$backward_rvl_p;
      iov$backward_rvl_p^.forward_link := rvl_p;
      iov$backward_rvl_p := rvl_p;
    IFEND;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$create_rvl_entry;

?? OLDTITLE ??
?? NEWTITLE := 'iop$define_robotic_server', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$define_robotic_server
    (    server_name: ost$name;
         managed_elements: array [1 .. * ] of cmt$element_name;
         server_attributes: iot$robotic_server_attributes;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      managed_densities: iot$managed_densities,
      managed_element_index: ost$positive_integers,
      new_robotic_server_array_p: ^array [1 .. * ] of iot$robotic_server_entry,
      new_robotic_server_index: ost$positive_integers,
      p_robotic_server_entry: ^iot$robotic_server_entry,
      rvl_p: ^iot$requested_vsn_list_entry,
      tusl_index: ost$positive_integers,
      unit_type: iot$unit_type,
      waiting_tasks_index: ost$positive_integers;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /define_robotic_server/
    BEGIN

      locate_robotic_server_entry (server_name, p_robotic_server_entry, status);

      IF status.normal THEN
        osp$set_status_abnormal (rmc$resource_management_id, rme$duplicate_server,
              'IOP$DEFINE_ROBOTIC_SERVER', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, server_name, status);
        EXIT /define_robotic_server/;
      ELSEIF status.condition = rme$server_not_defined THEN
        status.normal := TRUE;
      ELSE
        EXIT /define_robotic_server/;
      IFEND;

      managed_densities := $iot$managed_densities [];

    /validate_managed_elements/
      FOR managed_element_index := LOWERBOUND (managed_elements) TO UPPERBOUND (managed_elements) DO
        FOR tusl_index := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
          IF iov$tusl_p^ [tusl_index].element_name = managed_elements [managed_element_index] THEN
            unit_type := iov$tusl_p^ [tusl_index].unit_type;
            IF (unit_type = ioc$dt_mt679_2) OR (unit_type = ioc$dt_mt679_3) OR
                  (unit_type = ioc$dt_mt679_4) THEN
              managed_densities := managed_densities + $iot$managed_densities [rmc$800];
            IFEND;
            IF (unit_type <> ioc$dt_mt5682_1x) THEN
              managed_densities := managed_densities + $iot$managed_densities [rmc$1600];
            IFEND;
            IF NOT ((unit_type = ioc$dt_mt679_2) OR (unit_type = ioc$dt_mt679_3) OR
                  (unit_type = ioc$dt_mt679_4) OR (unit_type = ioc$dt_mt5682_1x)) THEN
              managed_densities := managed_densities + $iot$managed_densities [rmc$6250];
            IFEND;
            IF (unit_type = ioc$dt_mt5682_1x) THEN
              managed_densities := managed_densities + $iot$managed_densities [rmc$38000];
            IFEND;
            CYCLE /validate_managed_elements/;
          IFEND;
        FOREND;
        osp$set_status_abnormal (rmc$resource_management_id, rme$invalid_element_name,
              'IOP$DEFINE_ROBOTIC_SERVER', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, managed_elements [managed_element_index],
              status);
        EXIT /define_robotic_server/;
      FOREND /validate_managed_elements/;

      IF iov$robotic_server_array_p = NIL THEN
        ALLOCATE new_robotic_server_array_p: [1 .. 1] IN osv$mainframe_pageable_heap^;
        new_robotic_server_index := 1;
      ELSE
        ALLOCATE new_robotic_server_array_p: [1 .. (UPPERBOUND (iov$robotic_server_array_p^) + 1)] IN
              osv$mainframe_pageable_heap^;
        FOR new_robotic_server_index := 1 TO UPPERBOUND (iov$robotic_server_array_p^) DO
          new_robotic_server_array_p^ [new_robotic_server_index] :=
                iov$robotic_server_array_p^ [new_robotic_server_index];
        FOREND;
        new_robotic_server_index := UPPERBOUND (new_robotic_server_array_p^);
      IFEND;

      new_robotic_server_array_p^ [new_robotic_server_index].server_name := server_name;

      ALLOCATE new_robotic_server_array_p^ [new_robotic_server_index].managed_elements_p:
            [1 .. UPPERBOUND (managed_elements)] IN osv$mainframe_pageable_heap^;

      FOR managed_element_index := LOWERBOUND (managed_elements) TO UPPERBOUND (managed_elements) DO
        new_robotic_server_array_p^ [new_robotic_server_index].managed_elements_p^ [managed_element_index] :=
              managed_elements [managed_element_index];
      FOREND;

      new_robotic_server_array_p^ [new_robotic_server_index].managed_densities := managed_densities;
      new_robotic_server_array_p^ [new_robotic_server_index].server_attributes := server_attributes;
      new_robotic_server_array_p^ [new_robotic_server_index].server_job_name := jmv$jcb.system_name;

      FOR waiting_tasks_index := LOWERBOUND (new_robotic_server_array_p^ [new_robotic_server_index].
            waiting_tasks) TO UPPERBOUND (new_robotic_server_array_p^ [new_robotic_server_index].
            waiting_tasks) DO
        new_robotic_server_array_p^ [new_robotic_server_index].waiting_tasks [waiting_tasks_index] :=
              tmv$null_global_task_id
      FOREND;

      IF iov$robotic_server_array_p <> NIL THEN
        FREE iov$robotic_server_array_p IN osv$mainframe_pageable_heap^;
      IFEND;

      iov$robotic_server_array_p := new_robotic_server_array_p;

      rvl_p := iov$forward_rvl_p;

      WHILE rvl_p <> NIL DO
        CASE rvl_p^.vsn_state OF
          = ioc$queued_for_assignment, ioc$ready_for_assignment=
            IF (rvl_p^.requested_tape_characteristics.density IN managed_densities) AND
               (rvl_p^.gtid <> tmv$null_global_task_id) THEN
              pmp$ready_task (rvl_p^.gtid, ignore_status);
            IFEND;
          = ioc$assigned, ioc$unassigned =
            {no need to ready these};
        CASEND;
        rvl_p := rvl_p^.forward_link;
      WHILEND;

    END /define_robotic_server/;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$define_robotic_server;

?? OLDTITLE ??
?? NEWTITLE := 'iop$delete_rvl_entries_via_ssn', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$delete_rvl_entries_via_ssn
    (VAR status: ost$status);

    VAR
      next_rvl_p: ^iot$requested_vsn_list_entry,
      rvl_p: ^iot$requested_vsn_list_entry,
      vsn_p: ^iot$vsn_entry;

    status.normal := TRUE;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /delete_rvl_entries_via_ssn/
    BEGIN

      rvl_p := iov$forward_rvl_p;
      WHILE rvl_p <> NIL DO
        next_rvl_p := rvl_p^.forward_link;
        IF rvl_p^.ssn = jmv$jcb.system_name THEN

          delete_rvl_entry_from_vsn_queue (rvl_p);

          WHILE rvl_p^.first_vsn_entry_p <> NIL DO
            vsn_p := rvl_p^.last_vsn_entry_p;
            IF rvl_p^.first_vsn_entry_p = rvl_p^.last_vsn_entry_p THEN
              rvl_p^.first_vsn_entry_p := NIL;
              rvl_p^.last_vsn_entry_p := NIL;
            ELSE
              rvl_p^.last_vsn_entry_p := rvl_p^.last_vsn_entry_p^.previous_vsn_p;
              rvl_p^.last_vsn_entry_p^.next_vsn_p := NIL;
            IFEND;
            FREE vsn_p IN osv$mainframe_pageable_heap^;
          WHILEND;

          IF iov$forward_rvl_p = iov$backward_rvl_p THEN
            iov$forward_rvl_p := NIL;
            iov$backward_rvl_p := NIL;
          ELSEIF iov$forward_rvl_p = rvl_p THEN
            iov$forward_rvl_p := rvl_p^.forward_link;
            iov$forward_rvl_p^.backward_link := NIL;
          ELSEIF iov$backward_rvl_p = rvl_p THEN
            iov$backward_rvl_p := rvl_p^.backward_link;
            iov$backward_rvl_p^.forward_link := NIL;
          ELSE
            rvl_p^.backward_link^.forward_link := rvl_p^.forward_link;
            rvl_p^.forward_link^.backward_link := rvl_p^.backward_link;
          IFEND;

          FREE rvl_p IN osv$mainframe_pageable_heap^;

        IFEND;
        rvl_p := next_rvl_p;
      WHILEND;

    END /delete_rvl_entries_via_ssn/;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$delete_rvl_entries_via_ssn;

?? OLDTITLE ??
?? NEWTITLE := 'iop$delete_rvl_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$delete_rvl_entry
    (    sfid: dmt$system_file_id;
     VAR status: ost$status);

    VAR
      rvl_p: ^iot$requested_vsn_list_entry,
      vsn_p: ^iot$vsn_entry;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /delete_rvl_entry/
    BEGIN
      locate_rvl_entry_by_sfid (sfid, jmv$jcb.system_name, rvl_p, status);
      IF NOT status.normal THEN
        EXIT /delete_rvl_entry/;
      IFEND;

      delete_rvl_entry_from_vsn_queue (rvl_p);

      WHILE rvl_p^.first_vsn_entry_p <> NIL DO
        vsn_p := rvl_p^.last_vsn_entry_p;
        IF rvl_p^.first_vsn_entry_p = rvl_p^.last_vsn_entry_p THEN
          rvl_p^.first_vsn_entry_p := NIL;
          rvl_p^.last_vsn_entry_p := NIL;
        ELSE
          rvl_p^.last_vsn_entry_p := rvl_p^.last_vsn_entry_p^.previous_vsn_p;
          rvl_p^.last_vsn_entry_p^.next_vsn_p := NIL;
        IFEND;
        FREE vsn_p IN osv$mainframe_pageable_heap^;
      WHILEND;

      IF iov$forward_rvl_p = iov$backward_rvl_p THEN
        iov$forward_rvl_p := NIL;
        iov$backward_rvl_p := NIL;
      ELSEIF iov$forward_rvl_p = rvl_p THEN
        iov$forward_rvl_p := rvl_p^.forward_link;
        iov$forward_rvl_p^.backward_link := NIL;
      ELSEIF iov$backward_rvl_p = rvl_p THEN
        iov$backward_rvl_p := rvl_p^.backward_link;
        iov$backward_rvl_p^.forward_link := NIL;
      ELSE
        rvl_p^.backward_link^.forward_link := rvl_p^.forward_link;
        rvl_p^.forward_link^.backward_link := rvl_p^.backward_link;
      IFEND;

      FREE rvl_p IN osv$mainframe_pageable_heap^;

    END /delete_rvl_entry/;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$delete_rvl_entry;

?? OLDTITLE ??
?? NEWTITLE := 'iop$extend_volume_list_in_rvl', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$extend_volume_list_in_rvl
    (    sfid: dmt$system_file_id;
         evsn: rmt$external_vsn;
         rvsn: rmt$recorded_vsn;
         requested_volume_attributes: iot$requested_volume_attributes,
         vsn_number: integer;
     VAR status: ost$status);

    VAR
      alloc_vsn_p: ^iot$vsn_entry,
      rvl_p: ^iot$requested_vsn_list_entry,
      temp_vsn_p: ^iot$vsn_entry,
      volume_index: ost$positive_integers;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /extend_volume_list_in_rvl/
    BEGIN
      locate_rvl_entry_by_sfid (sfid, jmv$jcb.system_name, rvl_p, status);
      IF NOT status.normal THEN
        EXIT /extend_volume_list_in_rvl/;
      IFEND;

      IF vsn_number = 1 THEN
        IF rvl_p^.first_vsn_entry_p <> NIL THEN { change first entry
          rvl_p^.first_vsn_entry_p^.evsn := evsn;
          rvl_p^.first_vsn_entry_p^.rvsn := rvsn;
          rvl_p^.requested_volume_attributes := requested_volume_attributes;
          EXIT /extend_volume_list_in_rvl/;
        IFEND;
      ELSE
        temp_vsn_p := rvl_p^.first_vsn_entry_p;

      /determine_if_change/
        FOR volume_index := 1 TO vsn_number - 1 DO
          IF temp_vsn_p <> NIL THEN
            temp_vsn_p := temp_vsn_p^.next_vsn_p;
          ELSE
            EXIT /determine_if_change/;
          IFEND;
        FOREND /determine_if_change/;

        IF temp_vsn_p <> NIL THEN
          temp_vsn_p^.evsn := evsn;
          temp_vsn_p^.rvsn := rvsn;
          rvl_p^.requested_volume_attributes := requested_volume_attributes;
          EXIT /extend_volume_list_in_rvl/;
        IFEND;
      IFEND;

      ALLOCATE alloc_vsn_p IN osv$mainframe_pageable_heap^;

      IF rvl_p^.first_vsn_entry_p = NIL THEN
        rvl_p^.first_vsn_entry_p := alloc_vsn_p;
        alloc_vsn_p^.previous_vsn_p := NIL;
      ELSE
        rvl_p^.last_vsn_entry_p^.next_vsn_p := alloc_vsn_p;
        alloc_vsn_p^.previous_vsn_p := rvl_p^.last_vsn_entry_p;
      IFEND;

      alloc_vsn_p^.next_vsn_p := NIL;
      rvl_p^.last_vsn_entry_p := alloc_vsn_p;
      rvl_p^.last_vsn_entry_p^.evsn := evsn;
      rvl_p^.last_vsn_entry_p^.rvsn := rvsn;
      rvl_p^.requested_volume_attributes := requested_volume_attributes;

    END /extend_volume_list_in_rvl/;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$extend_volume_list_in_rvl;

?? OLDTITLE ??
?? NEWTITLE := 'iop$get_density_states', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$get_density_states
    (VAR density_states: array [rmc$800 .. rmc$38000] of iot$density_states;
     VAR status: ost$status);

    VAR
      density_state_index: rmc$800 .. rmc$38000,
      tusl_index: ost$positive_integers,
      unit_type: iot$unit_type;

    set_mainframe_sig_lock ('IOV$TUSL_LOCK', iov$tusl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR density_state_index := LOWERBOUND (density_states) TO UPPERBOUND (density_states) DO
      density_states [density_state_index].down_count := 0;
      density_states [density_state_index].off_count := 0;
      density_states [density_state_index].on_count := 0;
    FOREND;

  /scan_tusl_entries/
    FOR tusl_index := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
      unit_type := iov$tusl_p^ [tusl_index].unit_type;
      IF (unit_type = ioc$dt_mt679_2) OR (unit_type = ioc$dt_mt679_3) OR (unit_type = ioc$dt_mt679_4) THEN
        CASE iov$tusl_p^ [tusl_index].tape_unit_state OF
        = cmc$down =
          density_states [rmc$800].down_count := density_states [rmc$800].down_count + 1;
        = cmc$off =
          density_states [rmc$800].off_count := density_states [rmc$800].off_count + 1;
        = cmc$on =
          density_states [rmc$800].on_count := density_states [rmc$800].on_count + 1;
        CASEND;
      IFEND;
      IF (unit_type <> ioc$dt_mt5682_1x) THEN
        CASE iov$tusl_p^ [tusl_index].tape_unit_state OF
        = cmc$down =
          density_states [rmc$1600].down_count := density_states [rmc$1600].down_count + 1;
        = cmc$off =
          density_states [rmc$1600].off_count := density_states [rmc$1600].off_count + 1;
        = cmc$on =
          density_states [rmc$1600].on_count := density_states [rmc$1600].on_count + 1;
        CASEND;
      IFEND;
      IF NOT ((unit_type = ioc$dt_mt679_2) OR (unit_type = ioc$dt_mt679_3) OR
            (unit_type = ioc$dt_mt679_4) OR (unit_type = ioc$dt_mt5682_1x)) THEN
        CASE iov$tusl_p^ [tusl_index].tape_unit_state OF
        = cmc$down =
          density_states [rmc$6250].down_count := density_states [rmc$6250].down_count + 1;
        = cmc$off =
          density_states [rmc$6250].off_count := density_states [rmc$6250].off_count + 1;
        = cmc$on =
          density_states [rmc$6250].on_count := density_states [rmc$6250].on_count + 1;
        CASEND;
      IFEND;
      IF (unit_type = ioc$dt_mt5682_1x) THEN
        CASE iov$tusl_p^ [tusl_index].tape_unit_state OF
        = cmc$down =
          density_states [rmc$38000].down_count := density_states [rmc$38000].down_count + 1;
        = cmc$off =
          density_states [rmc$38000].off_count := density_states [rmc$38000].off_count + 1;
        = cmc$on =
          density_states [rmc$38000].on_count := density_states [rmc$38000].on_count + 1;
        CASEND;
      IFEND;
      CYCLE /scan_tusl_entries/;

    FOREND /scan_tusl_entries/;

    clear_mainframe_sig_lock (iov$tusl_lock);

  PROCEND iop$get_density_states;

?? OLDTITLE ??
?? NEWTITLE := 'iop$get_selected_element', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$get_selected_element
    (    sfid: gft$system_file_identifier;
         external_vsn: rmt$external_vsn;
         recorded_vsn: rmt$recorded_vsn;
         density: rmt$density;
     VAR element_name: cmt$element_name;
     VAR status: ost$status);

?? NEWTITLE := '  select_by_external_vsn', EJECT ??

  PROCEDURE select_by_external_vsn
    (    sfid: gft$system_file_identifier;
         system_supplied_name: jmt$system_supplied_name;
         external_vsn: rmt$external_vsn;
         density: rmt$density;
     VAR tusl_ordinal: iot$tusl_ordinal;
     VAR status: ost$status);

    VAR
      density_supported: boolean,
      local_tusl_ordinal: iot$tusl_ordinal;

    status.normal := TRUE;

    IF (external_vsn <> rmc$unspecified_vsn) THEN
      FOR local_tusl_ordinal := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
        IF (iov$tusl_p^ [local_tusl_ordinal].sfid = sfid) AND
              (iov$tusl_p^ [local_tusl_ordinal].ssn = system_supplied_name) AND
              (iov$tusl_p^ [local_tusl_ordinal].evsn = external_vsn) AND
              (iov$tusl_p^ [local_tusl_ordinal].tape_unit_state = cmc$on) AND
              (iov$tusl_p^ [local_tusl_ordinal].assignment_state = ioc$man_assignment_in_progress) THEN
          iop$determine_density_support (iov$tusl_p^ [local_tusl_ordinal].unit_type, density,
                density_supported);
          IF density_supported THEN
            tusl_ordinal := local_tusl_ordinal;
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;
    osp$set_status_abnormal (rmc$resource_management_id, rme$volume_not_mounted, '', status);

  PROCEND select_by_external_vsn;

?? OLDTITLE ??
?? NEWTITLE := '  select_by_recorded_vsn', EJECT ??

  PROCEDURE select_by_recorded_vsn
    (    recorded_vsn: rmt$recorded_vsn;
         density: rmt$density;
     VAR multiple_volumes_with_same_vsn: boolean;
     VAR tusl_ordinal: iot$tusl_ordinal;
     VAR status: ost$status);

    VAR
      all_tape_units_assigned: boolean,
      density_supported: boolean,
      local_tusl_ordinal: iot$tusl_ordinal,
      volume_found: boolean,
      vsns_match: boolean;

    status.normal := TRUE;

    all_tape_units_assigned := TRUE;
    multiple_volumes_with_same_vsn := FALSE;
    volume_found := FALSE;

    IF (recorded_vsn <> rmc$unspecified_vsn) THEN
      FOR local_tusl_ordinal := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
        IF (iov$tusl_p^ [local_tusl_ordinal].tape_unit_state = cmc$on) AND
              (iov$tusl_p^ [local_tusl_ordinal].assignment_state = ioc$not_assigned) THEN
          iop$determine_density_support (iov$tusl_p^ [local_tusl_ordinal].unit_type, density,
                density_supported);
          IF (recorded_vsn = iov$tusl_p^ [local_tusl_ordinal].rvsn) AND density_supported THEN
            IF volume_found THEN
              multiple_volumes_with_same_vsn := TRUE;
            ELSE
              volume_found := TRUE;
              tusl_ordinal := local_tusl_ordinal;
            IFEND;
          ELSEIF density_supported THEN
            all_tape_units_assigned := FALSE;
          IFEND;
        IFEND;
      FOREND;
    IFEND;
    IF NOT volume_found THEN
      IF all_tape_units_assigned THEN
        osp$set_status_abnormal (rmc$resource_management_id, rme$tape_unit_available, '', status);
      ELSE
        osp$set_status_abnormal (rmc$resource_management_id, rme$volume_not_mounted, '', status);
      IFEND;
    IFEND;

  PROCEND select_by_recorded_vsn;

?? OLDTITLE ??
?? EJECT ??

    VAR
      multiple_volumes_with_same_vsn: boolean,
      rvl_p: ^iot$requested_vsn_list_entry,
      tusl_ordinal: iot$tusl_ordinal;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    set_mainframe_sig_lock ('IOV$TUSL_LOCK', iov$tusl_lock, status);
    IF NOT status.normal THEN
      clear_mainframe_sig_lock (iov$rvl_lock);
      RETURN;
    IFEND;

  /get_selected_element/
    BEGIN
      locate_rvl_entry_by_sfid (sfid, jmv$jcb.system_name, rvl_p, status);
      IF NOT status.normal THEN
        EXIT /get_selected_element/;
      IFEND;

      IF rvl_p^.assignment_terminated THEN
        osp$set_status_abnormal (rmc$resource_management_id, dme$operator_stop, rvl_p^.message, status);
        EXIT /get_selected_element/;
      IFEND;

      IF (rvl_p^.operator_assignment_type = ioc$expecting_auto_assignment) THEN
        select_by_recorded_vsn (recorded_vsn, density, multiple_volumes_with_same_vsn, tusl_ordinal,
            status);
        IF status.normal THEN
          IF multiple_volumes_with_same_vsn THEN
            rvl_p^.operator_assignment_type := ioc$expecting_manual_assignment;
            select_by_external_vsn (rvl_p^.sfid, rvl_p^.ssn, external_vsn, density, tusl_ordinal, status);
            IF status.normal THEN
              element_name := iov$tusl_p^ [tusl_ordinal].element_name;
            IFEND;
          ELSE
            element_name := iov$tusl_p^ [tusl_ordinal].element_name;
          IFEND;
        IFEND;
      ELSEIF status.normal AND (rvl_p^.operator_assignment_type = ioc$expecting_manual_assignment) THEN
        select_by_external_vsn (rvl_p^.sfid, rvl_p^.ssn, external_vsn, density, tusl_ordinal, status);
        IF status.normal THEN
          element_name := iov$tusl_p^ [tusl_ordinal].element_name;
        IFEND;
      ELSE
        osp$set_status_abnormal (rmc$resource_management_id, dme$improper_op_assign_state,
              'IOP$GET_SELECTED_ELEMENT', status);
      IFEND;

    END /get_selected_element/;

    clear_mainframe_sig_lock (iov$tusl_lock);
    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$get_selected_element;

?? OLDTITLE ??
?? NEWTITLE := 'iop$get_server_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$get_server_entry
    (    server_index: iot$robotic_server_index;
     VAR server_entry: iot$robotic_server_entry;
     VAR status: ost$status);

    VAR
      p_robotic_server_entry: ^iot$robotic_server_entry;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (iov$robotic_server_array_p = NIL) OR (server_index > UPPERBOUND (iov$robotic_server_array_p^)) THEN
      osp$set_status_abnormal (rmc$resource_management_id, rme$invalid_server_index, 'IOP$GET_SERVER_ENTRY',
            status);
      osp$append_status_integer (osc$status_parameter_delimiter, server_index, radix, NOT include_radix,
            status);
    ELSE
      server_entry := iov$robotic_server_array_p^ [server_index];
    IFEND;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$get_server_entry;

?? OLDTITLE ??
?? NEWTITLE := 'iop$get_tape_mount_information', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$get_tape_mount_information
    (    rvl_info_array_p: ^array [1 .. * ] of iot$rvl_entry_information;
     VAR all_tape_mounts_found: boolean;
     VAR status: ost$status);

    VAR
      info_array_index: ost$non_negative_integers,
      rvl_p: ^iot$requested_vsn_list_entry;

    all_tape_mounts_found := TRUE;
    info_array_index := 0;

    IF rvl_info_array_p = NIL THEN
      osp$set_status_abnormal (rmc$resource_management_id, rme$nil_rvl_info_array_p,
            'iop$get_tape_mount_information', status);
      RETURN;
    IFEND;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rvl_p := iov$forward_rvl_p;
  /search_rvl/
    BEGIN
      WHILE rvl_p <> NIL DO
        IF rvl_p^.vsn_state = ioc$ready_for_assignment THEN
          IF info_array_index < UPPERBOUND (rvl_info_array_p^) THEN
            info_array_index := info_array_index + 1;
          ELSE
            all_tape_mounts_found := FALSE;
            EXIT /search_rvl/;
          IFEND;

          rvl_info_array_p^ [info_array_index].null_entry := FALSE;
          rvl_info_array_p^ [info_array_index].ssn := rvl_p^.ssn;
          rvl_info_array_p^ [info_array_index].sfid := rvl_p^.sfid;
          rvl_info_array_p^ [info_array_index].path_handle_name := rvl_p^.path_handle_name;
          rvl_info_array_p^ [info_array_index].vsn_state := rvl_p^.vsn_state;
          rvl_info_array_p^ [info_array_index].gtid := rvl_p^.gtid;
          rvl_info_array_p^ [info_array_index].assigned_element_name := rvl_p^.assigned_element_name;
          rvl_info_array_p^ [info_array_index].time_of_mount_request := rvl_p^.time_of_mount_request;
          rvl_info_array_p^ [info_array_index].operator_assignment_type := rvl_p^.operator_assignment_type;

          IF rvl_p^.current_vsn_p <> NIL THEN
            rvl_info_array_p^ [info_array_index].current_vsn := rvl_p^.current_vsn_p^.evsn;
            IF rvl_p^.current_vsn_p^.previous_vsn_p = NIL THEN
              rvl_info_array_p^ [info_array_index].previous_vsn := rmc$unspecified_vsn;
            ELSE
              rvl_info_array_p^ [info_array_index].previous_vsn := rvl_p^.current_vsn_p^.previous_vsn_p^.evsn;
            IFEND;
            IF rvl_p^.current_vsn_p^.next_vsn_p = NIL THEN
              rvl_info_array_p^ [info_array_index].next_vsn := rmc$unspecified_vsn;
            ELSE
              rvl_info_array_p^ [info_array_index].next_vsn := rvl_p^.current_vsn_p^.next_vsn_p^.evsn;
            IFEND;
          ELSE
            rvl_info_array_p^ [info_array_index].current_vsn := rmc$unspecified_vsn;
            rvl_info_array_p^ [info_array_index].previous_vsn := rmc$unspecified_vsn;
            rvl_info_array_p^ [info_array_index].next_vsn := rmc$unspecified_vsn;
          IFEND;
          rvl_info_array_p^ [info_array_index].requested_tape_characteristics :=
                rvl_p^.requested_tape_characteristics;
          rvl_info_array_p^ [info_array_index].requested_volume_attributes := rvl_p^.
                requested_volume_attributes;
        IFEND;
        rvl_p := rvl_p^.forward_link;
      WHILEND;

    END /search_rvl/;

    IF info_array_index < UPPERBOUND (rvl_info_array_p^) THEN
      info_array_index := info_array_index + 1;
      rvl_info_array_p^ [info_array_index].null_entry := TRUE;
    IFEND;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$get_tape_mount_information;

?? OLDTITLE ??
?? NEWTITLE := 'iop$job_tape_mounts_active', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$job_tape_mounts_active
    (    job_name: jmt$system_supplied_name;
     VAR job_tape_mounts_active: boolean;
     VAR status: ost$status);

    VAR
      rvl_p: ^iot$requested_vsn_list_entry;

    status.normal := TRUE;
    job_tape_mounts_active := FALSE;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rvl_p := iov$forward_rvl_p;
  /search/
    WHILE rvl_p <> NIL DO
      IF (rvl_p^.ssn = job_name) AND (rvl_p^.vsn_state = ioc$ready_for_assignment) THEN
        job_tape_mounts_active := TRUE;
        EXIT /search/;
      IFEND;
      rvl_p := rvl_p^.forward_link;
    WHILEND /search/;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$job_tape_mounts_active;

?? OLDTITLE ??
?? NEWTITLE := 'iop$queue_volume_assignment', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$queue_volume_assignment
    (    sfid: dmt$system_file_id;
         label_type: amt$label_type;
         requested_density: rmt$density;
         requested_evsn: rmt$external_vsn;
         requested_rvsn: rmt$recorded_vsn;
         requested_volume_attributes: iot$requested_volume_attributes;
     VAR first_in_queue: boolean;
     VAR status: ost$status);

    VAR
      first_queued_rvl_p: ^iot$requested_vsn_list_entry,
      last_queued_rvl_p: ^iot$requested_vsn_list_entry,
      requestor_rvl_p: ^iot$requested_vsn_list_entry;

    first_in_queue := FALSE;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /table_locked/
    BEGIN
      locate_rvl_entry_by_sfid (sfid, jmv$jcb.system_name, requestor_rvl_p, status);

      IF status.normal THEN
        locate_volume_in_rvl_entry (requestor_rvl_p, requested_density,
              requested_evsn, requested_rvsn, requestor_rvl_p^.current_vsn_p,
              status);
        locate_first_queued_rvl_p (requested_density, requested_evsn,
              requested_rvsn, first_queued_rvl_p);
        IF status.normal THEN
          CASE requestor_rvl_p^.vsn_state OF
          = ioc$unassigned =
            requestor_rvl_p^.vsn_state := ioc$queued_for_assignment;
            pmp$get_executing_task_gtid (requestor_rvl_p^.gtid);
            IF (label_type = amc$labelled) THEN
              requestor_rvl_p^.requested_tape_characteristics.label_type := amc$labelled;
              IF (requested_rvsn = requested_evsn) THEN
                requestor_rvl_p^.operator_assignment_type := ioc$expecting_auto_assignment;
              ELSE
                requestor_rvl_p^.operator_assignment_type := ioc$expecting_manual_assignment;
              IFEND;
            ELSE
              requestor_rvl_p^.requested_tape_characteristics.label_type := amc$unlabelled;
              requestor_rvl_p^.operator_assignment_type := ioc$expecting_manual_assignment;
            IFEND;
             requestor_rvl_p^.requested_volume_attributes := requested_volume_attributes;
          = ioc$queued_for_assignment =
            {ignore redundant call}
          ELSE {ioc$ready_for_assignment, ioc$assigned }
            osp$set_status_abnormal (rmc$resource_management_id, dme$improper_vsn_transition,
                  'IOP$QUEUE_VOLUME_ASSIGNMENT - READY FOR ASSIGNMENT OR ASSIGNED', status);
          CASEND;
        IFEND;
      IFEND;

      IF status.normal THEN
        IF (first_queued_rvl_p = NIL) OR (first_queued_rvl_p = requestor_rvl_p) THEN
          first_in_queue := TRUE;
          EXIT /table_locked/;
        ELSE {queue requestor if not already queued}
          last_queued_rvl_p := first_queued_rvl_p;
          WHILE last_queued_rvl_p^.next_in_vsn_queue <> NIL DO
            IF last_queued_rvl_p^.next_in_vsn_queue = requestor_rvl_p THEN
              EXIT /table_locked/;
            ELSE
              last_queued_rvl_p := last_queued_rvl_p^.next_in_vsn_queue;
            IFEND;
          WHILEND;

          last_queued_rvl_p^.next_in_vsn_queue := requestor_rvl_p;
          requestor_rvl_p^.previous_in_vsn_queue := last_queued_rvl_p;
          requestor_rvl_p^.next_in_vsn_queue := NIL;
        IFEND;
      IFEND;

    END /table_locked/;
    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$queue_volume_assignment;

?? OLDTITLE ??
?? NEWTITLE := 'iop$rdy_task_waiting_assignment', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$rdy_task_waiting_assignment
    (VAR new_vsns_online_p: iot$new_vsns_online;
     VAR status: ost$status);

    VAR
      density_supported: boolean,
      ignore_status: ost$status,
      new_vsns_online_index: ost$positive_integers,
      rvl_p: ^iot$requested_vsn_list_entry;

    IF new_vsns_online_p = NIL THEN
      osp$set_status_abnormal (rmc$resource_management_id, rme$nil_new_vsns_online_p,
            'iop$rdy_task_waiting_assignment', status);
      RETURN;
    IFEND;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rvl_p := iov$forward_rvl_p;
    WHILE rvl_p <> NIL DO
      IF (rvl_p^.current_vsn_p <> NIL) AND (rvl_p^.vsn_state = ioc$ready_for_assignment) AND
            (rvl_p^.operator_assignment_type = ioc$expecting_auto_assignment) THEN
      /new_vsn_search/
        BEGIN
          FOR new_vsns_online_index := LOWERBOUND (new_vsns_online_p^) TO UPPERBOUND (new_vsns_online_p^) DO
            IF new_vsns_online_p^ [new_vsns_online_index].rvsn = rmc$unspecified_vsn THEN
              EXIT /new_vsn_search/;
            IFEND;
            IF new_vsns_online_p^ [new_vsns_online_index].rvsn = rvl_p^.current_vsn_p^.rvsn THEN
              iop$determine_density_support (new_vsns_online_p^ [new_vsns_online_index].unit_type,
                    rvl_p^.requested_tape_characteristics.density, density_supported);
              IF density_supported AND (rvl_p^.gtid <> tmv$null_global_task_id) THEN
                pmp$ready_task (rvl_p^.gtid, ignore_status);
              IFEND;
            IFEND;
          FOREND;
        END /new_vsn_search/;
      IFEND;
      rvl_p := rvl_p^.forward_link;
    WHILEND;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$rdy_task_waiting_assignment;

?? OLDTITLE ??
?? NEWTITLE := 'iop$ready_waiting_tape_tasks', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$ready_waiting_tape_tasks
    (    unit_type: iot$unit_type);

    VAR
      density_supported: boolean,
      ignore_status: ost$status,
      managed_densities: iot$managed_densities,
      robotic_server_index: ost$positive_integers,
      rvl_p: ^iot$requested_vsn_list_entry;

    IF iov$robotic_server_array_p <> NIL THEN

      managed_densities := $iot$managed_densities [];
      FOR robotic_server_index := LOWERBOUND (iov$robotic_server_array_p^)
            TO UPPERBOUND (iov$robotic_server_array_p^) DO
        managed_densities := managed_densities + iov$robotic_server_array_p^ [robotic_server_index].
              managed_densities;
      FOREND;

      rvl_p := iov$forward_rvl_p;
      WHILE rvl_p <> NIL DO
        iop$determine_density_support (unit_type, rvl_p^.requested_tape_characteristics.density,
              density_supported);
        IF density_supported AND (rvl_p^.requested_tape_characteristics.density IN managed_densities) AND
          (rvl_p^.gtid <> tmv$null_global_task_id) THEN
          pmp$ready_task (rvl_p^.gtid, ignore_status);
        IFEND;
        rvl_p := rvl_p^.forward_link;
      WHILEND;
    IFEND;

  PROCEND iop$ready_waiting_tape_tasks;

?? OLDTITLE ??
?? NEWTITLE := 'iop$read_lock_tusl_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$read_lock_tusl_entry
    (    tusl_ordinal: iot$tusl_ordinal;
     VAR tusl_entry_template: iot$tape_unit_status_entry;
     VAR status: ost$status);

    set_mainframe_sig_lock ('IOV$TUSL_LOCK', iov$tusl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    set_mainframe_sig_lock ('TUSL_ENTRY_LOCK', iov$tusl_p^ [tusl_ordinal].lock, status);
    IF NOT status.normal THEN
      clear_mainframe_sig_lock (iov$tusl_lock);
      RETURN;
    IFEND;

    tusl_entry_template := iov$tusl_p^ [tusl_ordinal];

    clear_mainframe_sig_lock (iov$tusl_lock);

  PROCEND iop$read_lock_tusl_entry;

?? OLDTITLE ??
?? NEWTITLE := 'iop$release_assignment_in_rvl', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$release_assignment_in_rvl
    (    sfid: dmt$system_file_id;
     VAR status: ost$status);

    VAR
      current_time: ost$time,
      ignore_status: ost$status,
      rvl_p: ^iot$requested_vsn_list_entry,
      tusl_ordinal: iot$tusl_ordinal,
      unit_type: iot$unit_type;

    current_time.hms := '';

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    set_mainframe_sig_lock ('IOV$TUSL_LOCK', iov$tusl_lock, status);
    IF NOT status.normal THEN
      clear_mainframe_sig_lock (iov$rvl_lock);
      RETURN;
    IFEND;

  /release_assignment_in_rvl/
    BEGIN
      locate_rvl_entry_by_sfid (sfid, jmv$jcb.system_name, rvl_p, status);
      IF NOT status.normal THEN
        EXIT /release_assignment_in_rvl/;
      IFEND;

      delete_rvl_entry_from_vsn_queue (rvl_p);

      rvl_p^.vsn_state := ioc$unassigned;
      rvl_p^.assigned_element_name := osc$null_name;
      rvl_p^.assignment_terminated := FALSE;
      rvl_p^.time_of_mount_request := '';
      rvl_p^.operator_assignment_type := ioc$unknown_assignment_type;

    /tusl_search/
      BEGIN
        FOR tusl_ordinal := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
          IF (iov$tusl_p^ [tusl_ordinal].sfid = sfid) AND
                (iov$tusl_p^ [tusl_ordinal].ssn = jmv$jcb.system_name) THEN
            unit_type := iov$tusl_p^ [tusl_ordinal].unit_type;
            iov$tusl_p^ [tusl_ordinal].assignment_state := ioc$not_assigned;
            iov$tusl_p^ [tusl_ordinal].sfid := dmv$null_sfid;
            iov$tusl_p^ [tusl_ordinal].evsn := rmc$unspecified_vsn;
            iov$tusl_p^ [tusl_ordinal].rvsn := rmc$unspecified_vsn;
            iov$tusl_p^ [tusl_ordinal].ssn := jmc$blank_system_supplied_name;
            iop$ready_waiting_tape_tasks (unit_type);
            EXIT /tusl_search/;
          IFEND;
        FOREND;
      END /tusl_search/;

    END /release_assignment_in_rvl/;

    clear_mainframe_sig_lock (iov$tusl_lock);
    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$release_assignment_in_rvl;

?? OLDTITLE ??
?? NEWTITLE := 'iop$release_tape_unit', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$release_tape_unit
    (    sfid: gft$system_file_identifier;
         logical_unit: iot$logical_unit;
         delete_request_from_vsn_queue: boolean;
     VAR status: ost$status);

    VAR
      element_name: cmt$element_name,
      entry_locked: boolean,
      entry_unlocked: boolean,
      rvl_p: ^iot$requested_vsn_list_entry,
      tusl_ordinal: iot$tusl_ordinal;

    entry_locked := FALSE;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    set_mainframe_sig_lock ('IOV$TUSL_LOCK', iov$tusl_lock, status);
    IF NOT status.normal THEN
      clear_mainframe_sig_lock (iov$rvl_lock);
      RETURN;
    IFEND;

  /release_tape_unit/
    BEGIN

      IF sfid <> dmv$null_sfid THEN
        locate_rvl_entry_by_sfid (sfid, jmv$jcb.system_name, rvl_p, status);
        IF NOT status.normal THEN
          EXIT /release_tape_unit/;
        IFEND;

        locate_element_in_tusl (rvl_p^.assigned_element_name, tusl_ordinal, status);
        IF NOT status.normal THEN
          EXIT /release_tape_unit/;
        IFEND;
      IFEND;

      cmp$lock_lun_entry (logical_unit, entry_locked);
      IF NOT entry_locked THEN
        osp$set_status_abnormal (rmc$resource_management_id, dme$unable_to_lock_tape_table,
              'MAINFRAME LUN ENTRY', status);
        EXIT /release_tape_unit/;
      IFEND;

      IF NOT (cmv$logical_unit_table^ [logical_unit].configured AND
            cmv$logical_unit_table^ [logical_unit].status.assignable_device) THEN
        osp$set_status_abnormal (rmc$resource_management_id, dme$tape_unit_undefined, '', status);
        EXIT /release_tape_unit/;
      IFEND;

      IF NOT cmv$logical_unit_table^ [logical_unit].status.assigned THEN
        cmp$get_element_name_via_lun (logical_unit, element_name, status);
        IF NOT status.normal THEN
          element_name := osc$null_name;
        IFEND;
        osp$set_status_abnormal (rmc$resource_management_id, dme$tape_unit_unassigned,
              element_name, status);
        EXIT /release_tape_unit/;
      IFEND;

      IF cmv$logical_unit_table^ [logical_unit].status.assigned_jsn <> jmv$jcb.system_name THEN
        cmp$get_element_name_via_lun (logical_unit, element_name, status);
        IF NOT status.normal THEN
          element_name := osc$null_name;
        IFEND;
        osp$set_status_abnormal (rmc$resource_management_id, dme$unit_assigned, element_name, status);
        EXIT /release_tape_unit/;
      IFEND;


      IF sfid <> dmv$null_sfid THEN
        IF delete_request_from_vsn_queue THEN
          delete_rvl_entry_from_vsn_queue (rvl_p);
          rvl_p^.current_vsn_p := NIL;
          rvl_p^.vsn_state := ioc$unassigned;
          rvl_p^.operator_assignment_type := ioc$unknown_assignment_type;
        ELSE
          rvl_p^.vsn_state := ioc$queued_for_assignment;
          {This allows cases of dme$operator_reassign to remount volume}
        IFEND;

        rvl_p^.assigned_element_name := osc$null_name;
        rvl_p^.assignment_terminated := FALSE;
        rvl_p^.time_of_mount_request := '';

        iov$tusl_p^ [tusl_ordinal].assignment_state := ioc$not_assigned;
        iov$tusl_p^ [tusl_ordinal].evsn := rmc$unspecified_vsn;
        iov$tusl_p^ [tusl_ordinal].rvsn := rmc$unspecified_vsn;
        iov$tusl_p^ [tusl_ordinal].sfid := dmv$null_sfid;
        iov$tusl_p^ [tusl_ordinal].ssn := jmc$blank_system_supplied_name;

        iop$ready_waiting_tape_tasks (iov$tusl_p^ [tusl_ordinal].unit_type);
      IFEND;

      cmv$logical_unit_table^ [logical_unit].status.assigned := FALSE;
      cmv$logical_unit_table^ [logical_unit].status.assigned_jsn := jmc$blank_system_supplied_name;

    END /release_tape_unit/;

    IF entry_locked THEN
      cmp$unlock_lun_entry (logical_unit, entry_unlocked);
      IF status.normal AND (NOT entry_unlocked) THEN
        osp$set_status_abnormal (rmc$resource_management_id, dme$unable_to_release_lun_lock,
              'Unable to release lun entry in IOP$RELEASE_TAPE_UNIT', status);
      IFEND;
    IFEND;

    clear_mainframe_sig_lock (iov$tusl_lock);
    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$release_tape_unit;

?? OLDTITLE ??
?? NEWTITLE := 'iop$remove_robotic_server', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$remove_robotic_server
    (    server_name: ost$name;
     VAR status: ost$status);

    VAR
      p_robotic_server_entry: ^iot$robotic_server_entry;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    locate_robotic_server_entry (server_name, p_robotic_server_entry, status);

    IF status.normal THEN
      remove_robotic_server_entry (p_robotic_server_entry, status);
    IFEND;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$remove_robotic_server;

?? OLDTITLE ??
?? NEWTITLE := 'iop$request_assignment_in_rvl', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$request_assignment_in_rvl
    (    sfid: dmt$system_file_id;
         requested_density: rmt$density;
         requested_evsn: rmt$external_vsn;
         requested_rvsn: rmt$recorded_vsn;
     VAR status: ost$status);

    VAR
      current_time: ost$time,
      first_queued_rvl_p: ^iot$requested_vsn_list_entry,
      requestor_rvl_p: ^iot$requested_vsn_list_entry;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /request_assignment_in_rvl/
    BEGIN
      locate_rvl_entry_by_sfid (sfid, jmv$jcb.system_name, requestor_rvl_p, status);
      IF NOT status.normal THEN
        EXIT /request_assignment_in_rvl/;
      IFEND;

      CASE requestor_rvl_p^.vsn_state OF

      = ioc$unassigned, ioc$queued_for_assignment =
        locate_first_queued_rvl_p (requested_density, requested_evsn, requested_rvsn, first_queued_rvl_p);
        IF (first_queued_rvl_p = requestor_rvl_p) THEN
          requestor_rvl_p^.vsn_state := ioc$ready_for_assignment;

          pmp$get_time (osc$hms_time, current_time, status);
          IF NOT status.normal THEN
            EXIT /request_assignment_in_rvl/;
          IFEND;
          requestor_rvl_p^.time_of_mount_request := current_time.hms;
        ELSE
          osp$set_status_abnormal (rmc$resource_management_id, dme$improper_vsn_transition,
                'IOP$REQUEST_ASSIGNMENT_IN_RVL - NOT FIRST IN QUEUE', status);
          EXIT /request_assignment_in_rvl/;
        IFEND;

      = ioc$ready_for_assignment =
        {ignore redundant call}

      ELSE {ioc$assigned}
        osp$set_status_abnormal (rmc$resource_management_id, dme$improper_vsn_transition,
              'IOP$REQUEST_ASSIGNMENT_IN_RVL - ASSIGNED', status);
        EXIT /request_assignment_in_rvl/;
      CASEND;

    END /request_assignment_in_rvl/;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$request_assignment_in_rvl;

?? OLDTITLE ??
?? NEWTITLE := 'iop$select_best_element', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$select_best_element
    (    preferred_elements: ^array [1 .. * ] of cmt$element_name;
         remaining_elements: ^array [1 .. * ] of cmt$element_name;
     VAR selected_element: cmt$element_name;
     VAR status: ost$status);

?? NEWTITLE := '  get_next_element', EJECT ??

    PROCEDURE get_next_element
      (VAR selected_element: cmt$element_name;
       VAR tusl_ordinal {input/output} : iot$tusl_ordinal;
       VAR tusl_scan_count {input/output} : integer);

      selected_element := osc$null_name;

      REPEAT
        IF tusl_ordinal = UPPERBOUND (iov$tusl_p^) THEN
          tusl_ordinal := LOWERBOUND (iov$tusl_p^);
        ELSE
          tusl_ordinal := tusl_ordinal + 1;
        IFEND;

        validate_candidate_element (iov$tusl_p^ [tusl_ordinal].element_name, $cmt$element_states [cmc$on],
              status);
        IF status.normal THEN
          selected_element := iov$tusl_p^ [tusl_ordinal].element_name;
          RETURN;
        IFEND;
        tusl_scan_count := tusl_scan_count + 1;
      UNTIL tusl_scan_count > (UPPERBOUND (iov$tusl_p^) - LOWERBOUND (iov$tusl_p^));

    PROCEND get_next_element;
?? OLDTITLE ??

    VAR
      candidate_element_index: ost$positive_integers,
      managed_element_index: ost$positive_integers,
      managed_elements_p: ^array [1 .. * ] of cmt$element_name,
      robotic_element_monopoly: boolean,
      robotic_server_index: iot$robotic_server_index,
      tusl_scan_count: integer,
      tusl_ordinal: iot$tusl_ordinal;

    selected_element := osc$null_name;

    set_mainframe_sig_lock ('IOV$TUSL_LOCK', iov$tusl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /select_best_element/
    BEGIN

      IF preferred_elements <> NIL THEN
        tusl_scan_count := 0;
        tusl_ordinal := iov$last_robotic_tusl_ordinal;

        get_next_element (selected_element, tusl_ordinal, tusl_scan_count);
        WHILE selected_element <> osc$null_name DO
          FOR candidate_element_index := LOWERBOUND (preferred_elements^)
                TO UPPERBOUND (preferred_elements^) DO
            IF preferred_elements^ [candidate_element_index] = selected_element THEN
              iov$last_robotic_tusl_ordinal := tusl_ordinal;
              EXIT /select_best_element/;
            IFEND;
          FOREND;
          get_next_element (selected_element, tusl_ordinal, tusl_scan_count);
        WHILEND;
      IFEND;

      IF remaining_elements <> NIL THEN
        tusl_scan_count := 0;
        tusl_ordinal := iov$last_robotic_tusl_ordinal;

        get_next_element (selected_element, tusl_ordinal, tusl_scan_count);
        WHILE selected_element <> osc$null_name DO
          FOR candidate_element_index := LOWERBOUND (remaining_elements^)
                TO UPPERBOUND (remaining_elements^) DO
            IF remaining_elements^ [candidate_element_index] = selected_element THEN
              iov$last_robotic_tusl_ordinal := tusl_ordinal;
              EXIT /select_best_element/;
            IFEND;
          FOREND;
          get_next_element (selected_element, tusl_ordinal, tusl_scan_count);
        WHILEND;
      IFEND;

      IF selected_element = osc$null_name THEN
        robotic_element_monopoly := FALSE;
        IF iov$robotic_server_array_p <> NIL THEN
          robotic_element_monopoly := TRUE;
          FOR robotic_server_index := LOWERBOUND (iov$robotic_server_array_p^)
                TO UPPERBOUND (iov$robotic_server_array_p^) DO
            managed_elements_p := iov$robotic_server_array_p^ [robotic_server_index].managed_elements_p;
            IF managed_elements_p <> NIL THEN
              FOR managed_element_index := LOWERBOUND (managed_elements_p^)
                    TO UPPERBOUND (managed_elements_p^) DO
                FOR tusl_ordinal := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
                  IF managed_elements_p^ [managed_element_index] = iov$tusl_p^ [tusl_ordinal].
                        element_name THEN
                    robotic_element_monopoly := robotic_element_monopoly AND
                          ((iov$tusl_p^ [tusl_ordinal].assignment_state <> ioc$not_assigned) AND
                          (iov$tusl_p^ [tusl_ordinal].ssn = jmv$jcb.system_name));
                  IFEND;
                FOREND;
              FOREND;
            IFEND;
          FOREND;
        IFEND;

        IF robotic_element_monopoly THEN
          osp$set_status_abnormal (rmc$resource_management_id, rme$robotic_element_monopoly,
                'IOP$SELECT_BEST_ELEMENT', status);
          EXIT /select_best_element/;
        ELSE
          osp$set_status_abnormal (rmc$resource_management_id, rme$element_not_available,
                'IOP$SELECT_BEST_ELEMENT', status);
          EXIT /select_best_element/;
        IFEND;
      IFEND;

    END /select_best_element/;

    clear_mainframe_sig_lock (iov$tusl_lock);

  PROCEND iop$select_best_element;

?? OLDTITLE ??
?? NEWTITLE := 'iop$server_get_request', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$server_get_request
    (    server_name: ost$name;
         wait: boolean;
     VAR client_request: rmt$rbt_request;
     VAR status: ost$status);

    VAR
      global_task_id: ost$global_task_id,
      p_robotic_server_entry: ^iot$robotic_server_entry,
      rvl_p: ^iot$requested_vsn_list_entry,
      waiting_tasks_index: ost$positive_integers;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /server_get_request/
    BEGIN
      locate_robotic_server_entry (server_name, p_robotic_server_entry, status);
      IF NOT status.normal THEN
        EXIT /server_get_request/;
      IFEND;

      locate_new_request_in_rvl (rvl_p, status);

      IF status.normal THEN
        client_request := rvl_p^.robotic_communication^.client_request;
        rvl_p^.robotic_communication^.server_received_request := TRUE;
      ELSE
        IF wait THEN
          pmp$get_executing_task_gtid (global_task_id);
          FOR waiting_tasks_index := LOWERBOUND (p_robotic_server_entry^.waiting_tasks)
                TO UPPERBOUND (p_robotic_server_entry^.waiting_tasks) DO
            IF p_robotic_server_entry^.waiting_tasks [waiting_tasks_index] = global_task_id THEN
              EXIT /server_get_request/;
            IFEND;
          FOREND;
          FOR waiting_tasks_index := LOWERBOUND (p_robotic_server_entry^.waiting_tasks)
                TO UPPERBOUND (p_robotic_server_entry^.waiting_tasks) DO
            IF p_robotic_server_entry^.waiting_tasks [waiting_tasks_index] = tmv$null_global_task_id THEN
              p_robotic_server_entry^.waiting_tasks [waiting_tasks_index] := global_task_id;
              EXIT /server_get_request/;
            IFEND;
          FOREND;
        IFEND;
      IFEND;

    END /server_get_request/;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$server_get_request;

?? OLDTITLE ??
?? NEWTITLE := 'iop$server_put_response', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$server_put_response
    (    server_name: ost$name;
         server_response: iot$formatted_server_response;
     VAR status: ost$status);

    VAR
      element_index: ost$positive_integers,
      ignore_status: ost$status,
      p_robotic_server_entry: ^iot$robotic_server_entry,
      rvl_p: ^iot$requested_vsn_list_entry;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /server_put_response/
    BEGIN
      locate_robotic_server_entry (server_name, p_robotic_server_entry, status);
      IF NOT status.normal THEN
        EXIT /server_put_response/;
      IFEND;

      locate_request_id_in_rvl (server_response.request_id, rvl_p, status);
      IF NOT status.normal THEN
        EXIT /server_put_response/;
      IFEND;

      IF rvl_p^.robotic_communication^.server_name <> server_name THEN
        osp$set_status_abnormal (rmc$resource_management_id, rme$request_not_found, 'IOP$SERVER_PUT_RESPONSE',
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, server_response.request_id, radix,
              NOT include_radix, status);
        EXIT /server_put_response/;
      IFEND;

      IF NOT rvl_p^.robotic_communication^.server_received_request THEN
        osp$set_status_abnormal (rmc$resource_management_id, rme$premature_server_response,
              'IOP$SERVER_PUT_RESPONSE', status);
        osp$append_status_integer (osc$status_parameter_delimiter, server_response.request_id, radix,
              NOT include_radix, status);
        EXIT /server_put_response/;
      IFEND;

      IF rvl_p^.robotic_communication^.server_response_received THEN
        osp$set_status_abnormal (rmc$resource_management_id, rme$redundant_server_response,
              'IOP$SERVER_PUT_RESPONSE', status);
        osp$append_status_integer (osc$status_parameter_delimiter, server_response.request_id, radix,
              NOT include_radix, status);
        EXIT /server_put_response/;
      IFEND;

      rvl_p^.robotic_communication^.server_response := server_response;
      rvl_p^.robotic_communication^.server_response_received := TRUE;

      IF server_response.request_processed THEN
        IF (server_response.processed_request = rmc$rbt_query) AND
              server_response.query.volume_located AND NOT server_response.query.already_mounted THEN
          IF server_response.query.preferred_candidates <> NIL THEN
            ALLOCATE rvl_p^.robotic_communication^.server_response.query.preferred_candidates:
                  [1 .. UPPERBOUND (server_response.query.preferred_candidates^)] IN
                  osv$mainframe_pageable_heap^;
            FOR element_index := LOWERBOUND (server_response.query.preferred_candidates^)
                  TO UPPERBOUND (server_response.query.preferred_candidates^) DO
              rvl_p^.robotic_communication^.server_response.query.preferred_candidates^ [element_index] :=
                    server_response.query.preferred_candidates^ [element_index];
            FOREND;
          IFEND;
          IF server_response.query.remaining_candidates <> NIL THEN
            ALLOCATE rvl_p^.robotic_communication^.server_response.query.remaining_candidates:
                  [1 .. UPPERBOUND (server_response.query.remaining_candidates^)] IN
                  osv$mainframe_pageable_heap^;
            FOR element_index := LOWERBOUND (server_response.query.remaining_candidates^)
                  TO UPPERBOUND (server_response.query.remaining_candidates^) DO
              rvl_p^.robotic_communication^.server_response.query.remaining_candidates^ [element_index] :=
                    server_response.query.remaining_candidates^ [element_index];
            FOREND;
          IFEND;
        IFEND;
      ELSE
        IF server_response.server_messages <> NIL THEN
          ALLOCATE rvl_p^.robotic_communication^.server_response.server_messages IN
                osv$mainframe_pageable_heap^;
          rvl_p^.robotic_communication^.server_response.server_messages^ := server_response.server_messages^;
        ELSE
          rvl_p^.robotic_communication^.server_response.server_messages := NIL;
        IFEND;
      IFEND;

      pmp$ready_task (rvl_p^.robotic_communication^.requesting_task, ignore_status);

    END /server_put_response/;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$server_put_response;

?? OLDTITLE ??
?? NEWTITLE := 'iop$set_assignment_in_tusl', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$set_assignment_in_tusl
    (    tusl_ordinal: iot$tusl_ordinal;
         sfid: dmt$system_file_id;
         ssn: jmt$system_supplied_name;
         external_vsn: rmt$external_vsn;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      rvl_p: ^iot$requested_vsn_list_entry;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    set_mainframe_sig_lock ('IOV$TUSL_LOCK', iov$tusl_lock, status);
    IF NOT status.normal THEN
      clear_mainframe_sig_lock (iov$rvl_lock);
      RETURN;
    IFEND;

  /set_assignment_in_tusl/
    BEGIN
    locate_rvl_entry_by_sfid (sfid, ssn, rvl_p, status);
    IF NOT status.normal THEN
      EXIT /set_assignment_in_tusl/;
    IFEND;

    IF iov$tusl_p^ [tusl_ordinal].tape_unit_state = cmc$on THEN
      IF iov$tusl_p^ [tusl_ordinal].assignment_state = ioc$not_assigned THEN
        IF rvl_p^.operator_assignment_type = ioc$expecting_auto_assignment THEN
          rvl_p^.operator_assignment_type := ioc$expecting_manual_assignment;
        IFEND;
        iov$tusl_p^ [tusl_ordinal].assignment_state := ioc$man_assignment_in_progress;
        iov$tusl_p^ [tusl_ordinal].sfid := rvl_p^.sfid;
        iov$tusl_p^ [tusl_ordinal].evsn := external_vsn;
        iov$tusl_p^ [tusl_ordinal].ssn := rvl_p^.ssn;
        iov$tusl_p^ [tusl_ordinal].path_handle_name := rvl_p^.path_handle_name;
        rvl_p^.assigned_element_name := iov$tusl_p^ [tusl_ordinal].element_name;
        pmp$ready_task (rvl_p^.gtid, ignore_status);
      ELSE
        osp$set_status_abnormal (rmc$resource_management_id, rme$element_name_assigned,
              iov$tusl_p^ [tusl_ordinal].element_name, status);
        EXIT /set_assignment_in_tusl/;
      IFEND;
    ELSE
      osp$set_status_abnormal (rmc$resource_management_id, rme$element_name_not_on,
            iov$tusl_p^ [tusl_ordinal].element_name, status);
      EXIT /set_assignment_in_tusl/;
    IFEND;

    END /set_assignment_in_tusl/;

    clear_mainframe_sig_lock (iov$tusl_lock);
    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$set_assignment_in_tusl;

?? OLDTITLE ??
?? NEWTITLE := 'iop$tape_file_attached', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$tape_file_attached
    (    global_file_name: dmt$global_file_name;
     VAR tape_file_attached: boolean;
     VAR status: ost$status);

    VAR
      rvl_p: ^iot$requested_vsn_list_entry;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    tape_file_attached := FALSE;
    rvl_p := iov$forward_rvl_p;
  /search_rvl/
    WHILE rvl_p <> NIL DO
      IF rvl_p^.global_file_name = global_file_name THEN
        tape_file_attached := TRUE;
        EXIT /search_rvl/
      IFEND;
      rvl_p := rvl_p^.forward_link;
    WHILEND /search_rvl/;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$tape_file_attached;

?? OLDTITLE ??
?? NEWTITLE := 'iop$tape_mounts_pending', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$tape_mounts_pending
    (VAR tape_mounts_pending: boolean;
     VAR status: ost$status);

    VAR
      rvl_p: ^iot$requested_vsn_list_entry;

    status.normal := TRUE;
    tape_mounts_pending := FALSE;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rvl_p := iov$forward_rvl_p;
  /search/
    WHILE rvl_p <> NIL DO
      IF rvl_p^.vsn_state = ioc$ready_for_assignment THEN
        tape_mounts_pending := TRUE;
        EXIT /search/;
      IFEND;

      rvl_p := rvl_p^.forward_link;
    WHILEND /search/;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$tape_mounts_pending;

?? OLDTITLE ??
?? NEWTITLE := 'iop$tape_mount_count', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$tape_mount_count
    (VAR tape_mount_count: integer;
     VAR status: ost$status);

    VAR
      rvl_p: ^iot$requested_vsn_list_entry;

    status.normal := TRUE;
    tape_mount_count := 0;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    tape_mount_count := 0;
    rvl_p := iov$forward_rvl_p;
  /search/
    WHILE rvl_p <> NIL DO
      IF rvl_p^.vsn_state = ioc$ready_for_assignment THEN
        tape_mount_count := tape_mount_count + 1;
      IFEND;
      rvl_p := rvl_p^.forward_link;
    WHILEND /search/;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$tape_mount_count;

?? OLDTITLE ??
?? NEWTITLE := 'iop$terminate_assignment', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$terminate_assignment
    (    sfid: dmt$system_file_id;
         ssn: jmt$system_supplied_name;
         message: string (osc$max_string_size);
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      rvl_p: ^iot$requested_vsn_list_entry;

    set_mainframe_sig_lock ('IOV$RVL_LOCK', iov$rvl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /terminate_assignment/
    BEGIN
      locate_rvl_entry_by_sfid (sfid, ssn, rvl_p, status);
      IF NOT status.normal THEN
        EXIT /terminate_assignment/;
      IFEND;

      IF rvl_p^.vsn_state = ioc$assigned THEN
        IF rvl_p^.current_vsn_p = NIL THEN
          osp$set_status_abnormal (rmc$resource_management_id, rme$volume_already_assigned, ' ', status);
          EXIT /terminate_assignment/;
        ELSE
          osp$set_status_abnormal (rmc$resource_management_id, rme$volume_already_assigned,
                rvl_p^.current_vsn_p^.evsn, status);
          EXIT /terminate_assignment/;
        IFEND;
      IFEND;

      rvl_p^.assignment_terminated := TRUE;
      rvl_p^.message := message;

      IF rvl_p^.gtid <> tmv$null_global_task_id THEN
        pmp$ready_task (rvl_p^.gtid, ignore_status);
      IFEND;

    END /terminate_assignment/;

    clear_mainframe_sig_lock (iov$rvl_lock);

  PROCEND iop$terminate_assignment;

?? OLDTITLE ??
?? NEWTITLE := 'iop$validate_candidate_element', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$validate_candidate_element
    (    candidate_element: cmt$element_name;
         acceptable_states: set of cmt$element_state;
     VAR status: ost$status);

    set_mainframe_sig_lock ('IOV$TUSL_LOCK', iov$tusl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    validate_candidate_element (candidate_element, acceptable_states, status);

    clear_mainframe_sig_lock (iov$tusl_lock);

  PROCEND iop$validate_candidate_element;

?? OLDTITLE ??
?? NEWTITLE := 'iop$write_unlock_tusl_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$write_unlock_tusl_entry
    (    update_entry: boolean;
         tusl_ordinal: iot$tusl_ordinal;
         tusl_entry_template: iot$tape_unit_status_entry;
     VAR status: ost$status);

    set_mainframe_sig_lock ('IOV$TUSL_LOCK', iov$tusl_lock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF update_entry THEN
      iov$tusl_p^ [tusl_ordinal] := tusl_entry_template;
    IFEND;

    clear_mainframe_sig_lock (iov$tusl_p^ [tusl_ordinal].lock);
    clear_mainframe_sig_lock (iov$tusl_lock);

  PROCEND iop$write_unlock_tusl_entry;

MODEND iom$manage_rvl_tusl_structures;
*DECK DECK=IOM$MASS_STORAGE_IO EXPAND=TRUE
MODULE iom$mass_storage_io;


*copyc OSD$DEFAULT_PRAGMATS
*copyc OSK$KEYPOINTS
*copyc IOK$KEYPOINTS
*copyc osv$mainframe_wired_cb_heap
*copyc SYC$MONITOR_REQUEST_CODES
*copyc mmp$wait_io_completion
*copyc pmp$delay
*copyc OST$STATUS
*copyc IOT$RB_DEVICE_IO
*copyc OST$HARDWARE_SUBRANGES
*copyc IOT$IO_FUNCTION
*copyc DMT$MS_LOGICAL_DEVICE_ADDRESS
*copyc IOT$COMPLETION_STATUS
*copyc I#CALL_MONITOR
*copyc IOE$ST_ERRORS
*copyc osp$set_status_abnormal


  PROCEDURE [XDCL, #GATE] iop$mass_storage_io (pva: ^cell;
        length: ost$byte_count;
        io_function: iot$io_function;
        device_address: dmt$ms_logical_device_address;
        wait_completion: boolean;
    VAR p_completion_status: ^iot$completion_status;
    VAR status: ost$status);

    VAR
      request_block: iot$rb_device_io,
      completion_status_p: ^iot$completion_status,
      wait: boolean;


    status.normal := TRUE;
    #INLINE ('keypoint', osk$entry, 0, iok$mass_storage_io);

  /process_request/
    BEGIN
      IF wait_completion THEN
        ALLOCATE completion_status_p IN osv$mainframe_wired_cb_heap^;
      IFEND;

      /queue_request/
        WHILE TRUE DO
          status.normal := TRUE;
          request_block.request_code := syc$rc_device_io;
          request_block.pva := pva;
          request_block.length := length;
          request_block.io_function := io_function;
          request_block.device_address := device_address;
          IF wait_completion THEN
            request_block.completion := completion_status_p;
          ELSE
            request_block.completion := p_completion_status;
          IFEND;
          request_block.completion^ := 0;

          i#call_monitor (#LOC (request_block), #SIZE (request_block));
          IF request_block.status.normal = TRUE THEN
            EXIT /queue_request/;
          ELSEIF request_block.status.condition = ioe$unit_disabled THEN
            osp$set_status_abnormal ('IO', request_block.status.condition, '  ',
                  status);
            EXIT /process_request/;
          IFEND;
        WHILEND /queue_request/;

      wait := wait_completion;

    /wait_for_completion/
      WHILE wait DO
        IF pva <> NIL THEN
          mmp$wait_io_completion (pva, status);
        ELSE
          pmp$delay (1, status);
        IFEND;
        IF status.normal = FALSE THEN
          EXIT /process_request/;
        IFEND;
        IF request_block.completion^ <> 0 THEN
          EXIT /wait_for_completion/;
        IFEND;
      WHILEND /wait_for_completion/;

      IF (request_block.completion^ <> 1) AND wait_completion THEN
        osp$set_status_abnormal ( 'IO', ioe$unrecovered_disk_error,
              'UNRECOVERED DISK ERROR', status);
      IFEND;
    END /process_request/;

    IF wait_completion THEN
      FREE completion_status_p IN osv$mainframe_wired_cb_heap^;
    IFEND;

    #INLINE ('keypoint', osk$exit, 0, iok$mass_storage_io);


  PROCEND iop$mass_storage_io;
MODEND iom$mass_storage_io;
*DECK DECK=IOM$MEDIA_INTERFACES_113 EXPAND=TRUE
*DECK DECK=IOM$MTR_MANAGE_PP_PROCESS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'IO: Monitor Manage PP Process' ??
MODULE iom$mtr_manage_pp_process;

{ PURPOSE:
{   This module contains the procedures used to manage the PP process in Monitor mode.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dft$moved_fs_response_buffer
*copyc ioc$unsolicited_response_codes
*copyc ioe$st_errors
*copyc iok$keypoints
*copyc iot$command
*copyc iot$disk_request
*copyc iot$idle_resume_action
*copyc iot$io_request
*copyc iot$moved_response_buffer
*copyc iot$pp_response
*copyc iot$request_heap_map
*copyc osk$keypoints
?? POP ??
*copyc dsp$mtr_process_hung_pp
*copyc i#move
*copyc i#test_set_bit
*copyc iop$find_empty_request
*copyc iop$process_disk_response
*copyc iop$process_idle_response
*copyc iop$queue_pp_request
*copyc mtp$error_stop
*copyc mtp$set_status_abnormal
?? EJECT ??
*copyc cmv$logical_pp_table_p
*copyc cmv$max_number_of_pp
*copyc dsv$turn_dft_logging_off
  VAR
    iov$empty_requests: [XREF] ^iot$io_request,
    iov$empty_requests_end: [XREF] ^^iot$io_request,
    iov$empty_request_count: [XREF] integer,
    iov$request_heap_map: [XREF] iot$request_heap_map;
?? OLDTITLE ??
?? NEWTITLE := 'iop$check_active_pps', EJECT ??

{ PURPOSE:
{   This procedure handshakes with all supported PPs.  If it detects a hung PP it initiates the Reload
{   process.

  PROCEDURE [XDCL] iop$check_active_pps;

    VAR
      count: 0 .. 0ff(16),
      current_time: integer,
      pp: iot$pp_number,
      previously_set: boolean,
      time: integer,
      timeout: integer;

    IF dsv$turn_dft_logging_off THEN
      RETURN;
    IFEND;

    IF cmv$logical_pp_table_p = NIL THEN
      RETURN;
    IFEND;

    current_time := #FREE_RUNNING_CLOCK (0);

    { Check all PPs.

  /check_active_pp/
    FOR pp := 1 TO cmv$max_number_of_pp DO
      IF NOT cmv$logical_pp_table_p^ [pp].flags.pp_handshaking_supported THEN
        CYCLE /check_active_pp/;
      IFEND;

      IF NOT cmv$logical_pp_table_p^ [pp].flags.configured OR
            NOT cmv$logical_pp_table_p^ [pp].flags.pp_loaded OR
            cmv$logical_pp_table_p^ [pp].flags.disabled THEN
        CYCLE /check_active_pp/;
      IFEND;

      IF cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p = NIL THEN
        CYCLE /check_active_pp/;
      IFEND;

      IF cmv$logical_pp_table_p^ [pp].flags.pp_hung THEN
        CYCLE /check_active_pp/;
      IFEND;

      { Do not handshake with the slave.  The Master will do the handshaking with the slave.

      IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_type = cmc$lpt_disk_pp_type) OR
            (cmv$logical_pp_table_p^ [pp].pp_info.pp_type = cmc$lpt_tape_pp_type) THEN
        IF (cmv$logical_pp_table_p^ [pp].pp_info.logical_partner_pp_index > 0) AND
              cmv$logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.slave THEN
          CYCLE /check_active_pp/;
        IFEND;
      IFEND;

      { Check if the PP has NOT cleared the active_check flag.

      IF cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.active_check THEN
        IF (current_time - cmv$logical_pp_table_p^ [pp].active_check.timestamp) >
              cmv$logical_pp_table_p^ [pp].active_check.timeout THEN
          dsp$mtr_process_hung_pp (pp);
        IFEND;
      ELSE

        { The PP has cleared the active_check flag.  Interlock the PP interface table and set
        { the active_check flag.

        time := #FREE_RUNNING_CLOCK (0);
        timeout := time + 2000000;
        count := 0;
        REPEAT
          i#test_set_bit (^cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^,
                ioc$pp_interface_table_lock_bit, previously_set);
          count := count + 1;
          IF count >= 100 THEN
            time := #FREE_RUNNING_CLOCK (0);
            count := 0;
          IFEND;
        UNTIL (NOT previously_set) OR (time > timeout);

        IF NOT previously_set THEN
          cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.active_check := TRUE;
          cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.lock := FALSE;
          cmv$logical_pp_table_p^ [pp].active_check.timestamp := current_time;
        ELSE
          dsp$mtr_process_hung_pp (pp);
        IFEND;
      IFEND;
    FOREND /check_active_pp/;

  PROCEND iop$check_active_pps;
?? OLDTITLE ??
?? NEWTITLE := 'iop$check_idle_pps', EJECT ??

{ PURPOSE:
{   This procedure checks the idle status for PPs that do not support the new method of idle/resume requests.

  PROCEDURE [XDCL] iop$check_idle_pps;

    VAR
      completed_request_p: ^iot$disk_request,
      count: 0 .. 0ff(16),
      current_response_p: ^cell,
      in_pointer_offset: iot$response_buffer_offset,
      moved_response_buffer: iot$moved_response_buffer,
      one_word_response_p: ^dft$fs_pp_response,
      out_pointer_offset: integer,
      pp: iot$pp_number,
      pp_interface_table_p: ^iot$pp_interface_table,
      pp_response_p: ^iot$pp_response,
      previously_set: boolean,
      remain: integer,
      response_length: 0 .. 0ffff(16),
      rest: integer,
      short_response_p: ^iot$short_response,
      special_response: boolean,
      time: integer,
      timeout: integer,
      total_response_length: iot$response_buffer_offset;

    IF cmv$logical_pp_table_p = NIL THEN
      RETURN;
    IFEND;

   /check_idle_pps/
    FOR pp := 1 TO cmv$max_number_of_pp DO
      IF cmv$logical_pp_table_p^ [pp].flags.pp_idle_resume_supported THEN
        CYCLE /check_idle_pps/;
      IFEND;

      IF NOT cmv$logical_pp_table_p^ [pp].flags.configured OR
            NOT cmv$logical_pp_table_p^ [pp].flags.pp_loaded OR
            cmv$logical_pp_table_p^ [pp].flags.disabled THEN
        CYCLE /check_idle_pps/;
      IFEND;

      IF cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p = NIL THEN
        CYCLE /check_idle_pps/;
      IFEND;

      pp_interface_table_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;
      IF pp_interface_table_p^.inn = pp_interface_table_p^.out THEN
        CYCLE /check_idle_pps/;
      IFEND;

      { Note, pp_interface_table_p^.inn must be moved to a different location because otherwise the
      { pp can change the value, and thereby, cause a problem.

      in_pointer_offset := pp_interface_table_p^.inn;
      out_pointer_offset := pp_interface_table_p^.out;
      IF in_pointer_offset > out_pointer_offset THEN
        total_response_length := in_pointer_offset - out_pointer_offset;
      ELSE
        total_response_length := pp_interface_table_p^.limit - out_pointer_offset + in_pointer_offset;
      IFEND;

      { Retrieve the pp_response.

     /retrieve_response/
      WHILE total_response_length > 0 DO
        current_response_p := ^pp_interface_table_p^.response_buffer^ [out_pointer_offset];

        { Look for short disk responses.

        IF cmv$logical_pp_table_p^ [pp].handlers.response_handler_p = ^iop$process_disk_response THEN
          short_response_p := current_response_p;
          IF short_response_p^.flags.one_word_response THEN
            IF short_response_p^.request^.response_processor_p = ^iop$process_idle_response THEN
              completed_request_p := short_response_p^.request^.device_request_p;
              IF (completed_request_p^.request.command [1].command_code = ioc$cc_idle) AND
                    (pp_interface_table_p^.pp_request_queue = NIL) THEN

                { Interlock the PP interface table and set the idle status.

                time := #FREE_RUNNING_CLOCK(0);
                timeout := time + 2000000;
                count := 0;
                REPEAT
                  i#test_set_bit (^pp_interface_table_p^, ioc$pp_interface_table_lock_bit, previously_set);
                  count := count + 1;
                  IF count >= 100 THEN
                    time := #FREE_RUNNING_CLOCK(0);
                    count := 0;
                  IFEND;
                UNTIL (NOT previously_set) OR (time > timeout);
                IF NOT previously_set THEN
                  pp_interface_table_p^.idle_status := TRUE;
                  pp_interface_table_p^.lock := FALSE;
                IFEND;
              IFEND;
            IFEND;

            out_pointer_offset := out_pointer_offset + 8;
            IF out_pointer_offset = pp_interface_table_p^.limit THEN
              out_pointer_offset := 0;
            IFEND;
            total_response_length := total_response_length - 8;
            CYCLE /retrieve_response/;
          IFEND;
        IFEND;

        { Look for special responses.

        special_response := FALSE;
        IF cmv$logical_pp_table_p^ [pp].handlers.one_word_response_allowed THEN
          one_word_response_p := current_response_p;
          IF one_word_response_p^.response_flags.special_response THEN
            special_response := TRUE;
            response_length := one_word_response_p^.response_length;
            IF response_length > dfc$max_fs_pp_response_length THEN
              mtp$error_stop ('IO01 - invalid pp response');
            IFEND;
          IFEND;
        IFEND;

        IF NOT special_response THEN
          IF pp_interface_table_p^.limit - out_pointer_offset >= ioc$min_response_length THEN
            pp_response_p := current_response_p;
          ELSE { Move is necessary.
            remain := (pp_interface_table_p^.limit - out_pointer_offset);
            i#move (current_response_p, ^moved_response_buffer.bytes [0], remain);
            rest := ioc$min_response_length - remain;
            i#move (pp_interface_table_p^.response_buffer, ^moved_response_buffer.bytes [remain], rest);
            pp_response_p := ^moved_response_buffer.response;
          IFEND;

          response_length := pp_response_p^.response_length;
          IF (response_length < ioc$min_response_length) OR (response_length > total_response_length) THEN
            mtp$error_stop ('IO01 - invalid pp response');
          IFEND;

          IF (pp_response_p^.response_code.primary_response = ioc$normal_response) AND
                (pp_response_p^.request^.response_processor_p = ^iop$process_idle_response) THEN
            completed_request_p := pp_response_p^.request^.device_request_p;
            IF (completed_request_p^.request.command [1].command_code = ioc$cc_idle) AND
                  (pp_interface_table_p^.pp_request_queue = NIL) THEN

              { Interlock the PP interface table and set the idle_status.

              time := #FREE_RUNNING_CLOCK (0);
              timeout := time + 2000000;
              count := 0;
              REPEAT
                i#test_set_bit (^pp_interface_table_p^, ioc$pp_interface_table_lock_bit, previously_set);
                count := count + 1;
                IF count >= 100 THEN
                  time := #FREE_RUNNING_CLOCK (0);
                  count := 0;
                IFEND;
              UNTIL (NOT previously_set) OR (time > timeout);
              IF NOT previously_set THEN
                pp_interface_table_p^.idle_status := TRUE;
                pp_interface_table_p^.lock := FALSE;
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        { Update the out pointer offset for the response buffer.

        IF out_pointer_offset + response_length < pp_interface_table_p^.limit THEN
          out_pointer_offset := out_pointer_offset + response_length;
        ELSE
          out_pointer_offset := out_pointer_offset + response_length - pp_interface_table_p^.limit;
        IFEND;

        { Loop if there are more requests to process.

        total_response_length := total_response_length - response_length;
      WHILEND /retrieve_response/;
    FOREND;

  PROCEND iop$check_idle_pps;
?? OLDTITLE ??
?? NEWTITLE := 'iop$idle_all_paths', EJECT ??

{ PURPOSE:
{   This procedure idles all PPs.

  PROCEDURE [XDCL] iop$idle_all_paths
    (    wait: boolean;
     VAR status: syt$monitor_status);

    VAR
      loop: boolean,
      new_time: integer,
      old_time: integer,
      pp: iot$pp_number;

    status.normal := TRUE;

    IF cmv$logical_pp_table_p = NIL THEN
      mtp$set_status_abnormal (ioc$subsystem_io_manager, ioc$pp_not_configured, status);
      RETURN;
    IFEND;

    { Idle all PPs.

  /idle/
    FOR pp := 1 TO cmv$max_number_of_pp DO
      IF cmv$logical_pp_table_p^ [pp].flags.configured AND cmv$logical_pp_table_p^ [pp].flags.pp_loaded AND
            NOT cmv$logical_pp_table_p^ [pp].flags.disabled AND
            (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p <> NIL) THEN

        { Do not idle the slave.  The Master will take care of the slave.

        IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_type = cmc$lpt_disk_pp_type) OR
              (cmv$logical_pp_table_p^ [pp].pp_info.pp_type = cmc$lpt_tape_pp_type) THEN
          IF (cmv$logical_pp_table_p^ [pp].pp_info.logical_partner_pp_index > 0) AND
                cmv$logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.slave THEN
            CYCLE /idle/;
          IFEND;
        IFEND;

        iop$idle_resume (pp, ioc$ira_idle, status);
        IF NOT status.normal AND (status.condition <> ioc$pp_not_configured) THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND /idle/;

    status.normal := TRUE;
    IF NOT wait THEN
      RETURN;
    IFEND;

    { Get the time that the request was queued and wait for the pp to reply to the idle command.

    old_time := #FREE_RUNNING_CLOCK (0);
    loop := TRUE;

    WHILE loop DO
      iop$check_idle_pps;
      loop := FALSE;

     /check_idle_status/
      FOR pp := 1 TO cmv$max_number_of_pp DO
        IF cmv$logical_pp_table_p^ [pp].flags.configured AND cmv$logical_pp_table_p^ [pp].flags.pp_loaded AND
              NOT cmv$logical_pp_table_p^ [pp].flags.disabled AND
              (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p <> NIL) THEN

          { Ignore the slave.

          IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_type = cmc$lpt_disk_pp_type) OR
                (cmv$logical_pp_table_p^ [pp].pp_info.pp_type = cmc$lpt_tape_pp_type) THEN
            IF (cmv$logical_pp_table_p^ [pp].pp_info.logical_partner_pp_index > 0) AND
                  cmv$logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.slave THEN
              CYCLE /check_idle_status/;
            IFEND;
          IFEND;

          IF NOT cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.idle_status THEN
            loop := TRUE;
          IFEND;
        IFEND;
      FOREND /check_idle_status/;

      new_time := #FREE_RUNNING_CLOCK (0);
      IF new_time >= old_time + 2000000 THEN
        loop := FALSE;
      IFEND;
    WHILEND;

  PROCEND iop$idle_all_paths;
?? OLDTITLE ??
?? NEWTITLE := 'iop$idle_path', EJECT ??

{ PURPOSE:
{   This procedure idles one PP.

  PROCEDURE [XDCL] iop$idle_path
    (    pp: iot$pp_number;
     VAR status: syt$monitor_status);

    VAR
      count: 0 .. 0ff(16),
      time: integer,
      timeout: integer;

    status.normal := TRUE;

    iop$idle_resume (pp, ioc$ira_idle, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Get the time that the request was queued and wait for the pp to reply to the idle command.

    time := #FREE_RUNNING_CLOCK (0);
    timeout := time + 2000;
    count := 0;
    REPEAT
      count := count + 1;
      IF count >= 100 THEN
        time := #FREE_RUNNING_CLOCK (0);
        count := 0;
      IFEND;
    UNTIL (time > timeout);

  PROCEND iop$idle_path;
?? OLDTITLE ??
?? NEWTITLE := 'iop$idle_resume', EJECT ??

{ PURPOSE:
{   This procedure idles or resumes a PP.

  PROCEDURE [XDCL] iop$idle_resume
    (    pp: iot$pp_number;
         action: iot$idle_resume_action;
     VAR status: syt$monitor_status);

    VAR
      count: 0 .. 0ff(16),
      disk_request_p: ^iot$disk_request,
      initial_idle_command: [STATIC] iot$command := [ioc$cc_idle, [TRUE, FALSE, 0], 0, 0],
      initial_resume_command: [STATIC] iot$command := [ioc$cc_resume, [TRUE, FALSE, 0], 0, 0],
      io_request_p: ^iot$io_request,
      pp_interface_table_p: ^iot$pp_interface_table,
      previously_set: boolean,
      request_allocated: boolean,
      request_index: 1 .. ioc$request_heap_count,
      retry: 0 .. 0ff(16),
      time: integer,
      timeout: integer;

    status.normal := TRUE;
    IF action = ioc$ira_idle THEN
      #INLINE ('keypoint', osk$entry, 0, iok$idle);
    IFEND;

  /idle_resume/
    BEGIN
      request_allocated := FALSE;

      IF cmv$logical_pp_table_p = NIL THEN
        mtp$set_status_abnormal (ioc$subsystem_io_manager, ioc$pp_not_configured, status);
        EXIT /idle_resume/;
      IFEND;

      IF NOT cmv$logical_pp_table_p^ [pp].flags.configured OR
            NOT cmv$logical_pp_table_p^ [pp].flags.pp_loaded OR
            cmv$logical_pp_table_p^ [pp].flags.disabled THEN
        mtp$set_status_abnormal (ioc$subsystem_io_manager, ioc$pp_not_configured, status);
        EXIT /idle_resume/;
      IFEND;

      pp_interface_table_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;
      IF pp_interface_table_p = NIL THEN
        mtp$set_status_abnormal (ioc$subsystem_io_manager, ioc$pp_not_configured, status);
        EXIT /idle_resume/;
      IFEND;

      { Interlock the PP interface table and set the idle or resume information.

      time := #FREE_RUNNING_CLOCK (0);
      timeout := time + 2000000;
      count := 0;
      REPEAT
        i#test_set_bit (^pp_interface_table_p^, ioc$pp_interface_table_lock_bit, previously_set);
        count := count + 1;
        IF count >= 100 THEN
          time := #FREE_RUNNING_CLOCK (0);
          count := 0;
        IFEND;
      UNTIL (NOT previously_set) OR (time > timeout);
      IF previously_set THEN
        mtp$set_status_abnormal (ioc$subsystem_io_manager, ioc$pp_not_configured, status);
        EXIT /idle_resume/;
      IFEND;

      IF cmv$logical_pp_table_p^ [pp].flags.pp_idle_resume_supported THEN
        IF action = ioc$ira_idle THEN
          pp_interface_table_p^.idle_request := TRUE;
          pp_interface_table_p^.resume_request := FALSE;
          pp_interface_table_p^.idle_status := FALSE;
        ELSE  {action = ioc$ira_resume}
          pp_interface_table_p^.idle_request := FALSE;
          pp_interface_table_p^.resume_request := TRUE;
        IFEND;
        pp_interface_table_p^.lock := FALSE;

      ELSE
        pp_interface_table_p^.idle_status := (action = ioc$ira_resume);
        pp_interface_table_p^.lock := FALSE;

        { Find an empty slot for request.

        iop$find_empty_request (io_request_p, status);
        IF NOT status.normal THEN
          EXIT /idle_resume/;
        IFEND;

        disk_request_p := io_request_p^.device_request_p;
        request_index := disk_request_p^.request_index;
        request_allocated := TRUE;

        { Prepare the request.

        io_request_p^.response_processor_p := ^iop$process_idle_response;
        IF action = ioc$ira_idle THEN
          disk_request_p^.request.command [1] := initial_idle_command;
        ELSE {action = ioc$ira_resume}
          disk_request_p^.request.command [1] := initial_resume_command;
        IFEND;

        retry := 1;
        REPEAT
          iop$queue_pp_request (pp_interface_table_p, io_request_p, status);
          IF NOT status.normal THEN
            IF status.condition = ioc$pp_interlock_set THEN
              retry := retry + 1;
              IF retry > 10 THEN
                EXIT /idle_resume/;
              IFEND;
            ELSE
              EXIT /idle_resume/;
            IFEND;
          IFEND;
        UNTIL status.normal;

        iov$request_heap_map [request_index] := TRUE;
        iov$empty_request_count := iov$empty_request_count - 1;
      IFEND;
    END /idle_resume/;

    IF request_allocated AND (NOT status.normal) THEN
      disk_request_p^.link := iov$empty_requests;
      iov$empty_requests := io_request_p;
      IF iov$empty_requests_end = ^iov$empty_requests THEN
        iov$empty_requests_end := ^disk_request_p^.link;
      IFEND;
      iov$request_heap_map [request_index] := FALSE;
    IFEND;

    IF action = ioc$ira_idle THEN
      #INLINE ('keypoint', osk$exit, 0, iok$idle);
    IFEND;

  PROCEND iop$idle_resume;
?? OLDTITLE ??
?? NEWTITLE := 'iop$resume_all_paths', EJECT ??

{ PURPOSE:
{   This procedure resumes all PPs.

  PROCEDURE [XDCL] iop$resume_all_paths
    (VAR status: syt$monitor_status);

    VAR
      pp: iot$pp_number;

    status.normal := TRUE;

    IF cmv$logical_pp_table_p = NIL THEN
      mtp$set_status_abnormal (ioc$subsystem_io_manager, ioc$pp_not_configured, status);
      RETURN;
    IFEND;

   /resume/
    FOR pp := 1 TO cmv$max_number_of_pp DO
      IF cmv$logical_pp_table_p^ [pp].flags.configured AND cmv$logical_pp_table_p^ [pp].flags.pp_loaded AND
            NOT cmv$logical_pp_table_p^ [pp].flags.disabled AND
            (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p <> NIL) THEN

        { Do not resume the slave.  The Master will take care of the slave.

        IF (cmv$logical_pp_table_p^ [pp].pp_info.pp_type = cmc$lpt_disk_pp_type) OR
              (cmv$logical_pp_table_p^ [pp].pp_info.pp_type = cmc$lpt_tape_pp_type) THEN
          IF (cmv$logical_pp_table_p^ [pp].pp_info.logical_partner_pp_index > 0) AND
                cmv$logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.slave THEN
            CYCLE /resume/;
          IFEND;
        IFEND;

        iop$idle_resume (pp, ioc$ira_resume, status);
        IF NOT status.normal AND (status.condition <> ioc$pp_not_configured) THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND /resume/;
    status.normal := TRUE;

  PROCEND iop$resume_all_paths;
?? OLDTITLE ??
MODEND iom$mtr_manage_pp_process;
*DECK DECK=IOM$PROCESS_IDLE_RESPONSE EXPAND=TRUE
MODULE iom$process_idle_response;

*copyc OSD$DEFAULT_PRAGMATS
*copyc IOK$KEYPOINTS
*copyc OSK$KEYPOINTS
*copyc MTP$ERROR_STOP
*copyc IOT$PP_TABLE
*copyc syt$monitor_status
*copyc IOT$PP_INTERFACE_TABLE
*copyc IOT$PP_RESPONSE
*copyc IOT$DISK_REQUEST
*copyc IOT$REQUEST_HEAP_MAP
*copyc cmv$logical_pp_table_p
*copyc I#TEST_SET_BIT
*copyc IOE$ST_ERRORS



  PROCEDURE [XDCL] iop$process_idle_response (pp_response_p: ^iot$pp_response;
        detailed_status_p: ^iot$detailed_status;
        pp: 1 .. ioc$pp_count;
    VAR status: syt$monitor_status);

    VAR
      iov$unrecovered_disk_errors: [XREF] integer,
      iov$request_heap_map: [XREF] iot$request_heap_map,
      iov$empty_requests: [XREF] ^iot$io_request,
      iov$empty_requests_end: [XREF] ^^iot$io_request,
      iov$empty_request_count: [XREF] integer,
      completed_request_p: ^iot$disk_request,
      pp_interface_table_p: ^iot$pp_interface_table,
      count: integer,
      time: integer,
      timeout: integer,
      previously_set: boolean,
      index: 1 .. ioc$request_heap_count;


    status.normal := TRUE;
    #INLINE ('keypoint', osk$entry, 0, iok$idle_response);

    IF pp_response_p^.response_code.primary_response =
          ioc$intermediate_response THEN
      RETURN;
    IFEND;

    completed_request_p := pp_response_p^.request^.device_request_p;

{Check for unrecovered disk errors.

    IF pp_response_p^.response_code.primary_response = ioc$abnormal_response
          THEN
      IF iov$unrecovered_disk_errors < 0ffffffffffff(16) THEN
        iov$unrecovered_disk_errors := iov$unrecovered_disk_errors + 1;
      IFEND;
      #INLINE ('keypoint', osk$unusual, pp_response_p^.response_code.
            primary_response * osk$m, iok$unrecovered_disk_error);
    IFEND;

{Set idle_status flag in pp_interface_table.}

    pp_interface_table_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;

{  Interlock the pp_interface_table.

    time := #free_running_clock (0);
    timeout := time + 2000000;
    count := 0;

    REPEAT
      i#test_set_bit (^pp_interface_table_p^, ioc$pp_interface_table_lock_bit, previously_set);
      count := count + 1;
      IF count >= 100 THEN
        time := #free_running_clock (0);
        count := 0;
      IFEND;
    UNTIL (NOT previously_set) OR (time > timeout);

    CASE completed_request_p^.request.command[1].command_code OF
    = ioc$cc_idle =
      IF NOT previously_set THEN
        pp_interface_table_p^.idle_status := TRUE;
      IFEND;
    = ioc$cc_resume =
      IF NOT previously_set THEN
        pp_interface_table_p^.idle_status := FALSE;
      IFEND;
    ELSE
    CASEND;

    IF NOT previously_set THEN
      pp_interface_table_p^.lock := FALSE;
    ELSE
      status.normal := FALSE;
      status.condition := ioc$pp_interlock_set;
    IFEND;

{Clear request packet allocation.}

    completed_request_p^.link := NIL;
    iov$empty_requests_end ^ := pp_response_p^.request;
    iov$empty_requests_end := ^completed_request_p^.link;
    index := completed_request_p^.request_index;
    IF iov$request_heap_map [index] = FALSE THEN
      mtp$error_stop ('IO02 - invalid pp response');
    IFEND;
    iov$request_heap_map [index] := FALSE;
    iov$empty_request_count := iov$empty_request_count + 1;

    #INLINE ('keypoint', osk$exit, 0, iok$idle_response);



  PROCEND iop$process_idle_response;
MODEND iom$process_idle_response;
*DECK DECK=IOM$PROCESS_IO_COMPLETIONS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE iom$process_io_completions;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc amt$preset_value
*copyc cmt$controller_type
*copyc cmt$element_access
*copyc cmt$element_capabilities
*copyc cmt$signal_contents
*copyc cmv$controller_address
*copyc cmv$enable_head_shift_message
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc cmv$max_number_of_pp
*copyc dfp$fetch_server_iocb
*copyc dfp$process_error_log_response
*copyc dft$moved_fs_response_buffer
*copyc dfv$monitor_io_start_time
*copyc dmp$get_recorded_vsn
*copyc dmp$transfer_unit_completed
*copyc dmp$volume_down
*copyc dmp$volume_up
*copyc dmt$minimum_allocation_unit
*copyc dmt$ms_logical_device_address
*copyc dmt$system_file_id
*copyc dpp$display_error
*copyc dsp$mtr_save_disk_error
*copyc dsp$report_system_message
*copyc i$real_memory_address
*copyc ioc$unsolicited_response_codes
*copyc ioe$st_errors
*copyc iok$keypoints
*copyc iop$down_disk_channel
*copyc iop$down_disk_controller
*copyc iop$down_disk_unit
*copyc iop$tape_process_pp_response
*copyc iot$completion_status
*copyc iot$cylinder
*copyc iot$disk_detailed_status_844
*copyc iot$disk_request
*copyc iot$disk_statistics
*copyc iot$disk_type_table
*copyc iot$disk_usage
*copyc iot$down_status
*copyc iot$io_function
*copyc iot$io_request
*copyc iot$logical_unit
*copyc iot$moved_response_buffer
*copyc iot$pp_interface_table
*copyc iot$pp_response
*copyc iot$pp_table
*copyc iot$request_heap_map
*copyc iot$unit_type
*copyc iov$disk_type_table
*copyc jmt$ijl_ordinal
*copyc mmp$determine_error_state
*copyc mmp$mtr_process_io_completion
*copyc mmp$mtr_process_server_complete
*copyc mmp$process_read_ahead_complete
*copyc mmp$unlock_rma_list
*copyc mmt$io_identifier
*copyc mmt$rma_list
*copyc mtt$smu_communications_block
*copyc mtv$scb
*copyc mtp$error_stop
*copyc osk$keypoints
*copyc oss$mainframe_wired
*copyc ost$simulated_disk_fault
*copyc syt$monitor_status
*copyc tmp$send_signal
*copyc tmv$system_job_monitor_gtid
?? POP ??

  VAR
    iov$stream_requests: [XDCL, #GATE, oss$mainframe_wired] array [0 .. 300] of ^iot$io_request,
    iov$invalid_pp_count: [XDCL, #GATE, oss$mainframe_wired] integer := 0,
    iov$invalid_2: [XDCL,#GATE,oss$mainframe_wired] integer := 0,
    iov$invalid_3: [XDCL,#GATE,oss$mainframe_wired] integer := 0,

    iov$start_ioc: [XDCL, #GATE,oss$mainframe_wired] integer := 0,
    iov$stop_ioc: [XDCL, #GATE, oss$mainframe_wired] integer := 0,


    iov$stream_requests_end: [XDCL, #GATE, oss$mainframe_wired] array [0 .. 300] of ^^iot$io_request,

    iov$empty_requests: [XREF] ^iot$io_request,

    iov$empty_requests_end: [XREF] ^^iot$io_request,

    iov$empty_request_count: [XREF] integer,

    iov$request_heap_map: [XREF] iot$request_heap_map,

    iov$command_heap_map: [XREF] iot$command_heap_map,

    iov$process_disk_response: [XDCL, #GATE, oss$mainframe_wired] iot$response_processor :=
          ^iop$process_disk_response,

    osv$simulated_disk_fault: [XDCL, #GATE] array [1 .. osc$max_simulated_faults] of
      ost$simulated_disk_fault := [REP 5 of [FALSE, *, *, *, *, *, *, *, *, *, *]],

    osv$disk_fault_simulation: [XDCL, #GATE] boolean := FALSE,


    iov$disk_pp_usage_p: [XDCL, STATIC, #GATE, oss$mainframe_wired] ^iot$disk_pp_array := NIL,

    iov$disk_unit_usage_p: [XDCL, STATIC, #GATE, oss$mainframe_wired] ^iot$disk_unit_array := NIL;

  VAR
    iov$unrecovered_disk_errors: [XDCL, oss$mainframe_wired] integer := 0,

    iov$error_count: [XDCL, oss$mainframe_wired] integer := 0,

    iov$detailed_status_buffer: [XDCL, oss$mainframe_wired] array [1 .. 20] of iot$disk_log_data_full;
  VAR
    cmv$invalid_pp_count: [XREF, oss$mainframe_wired] integer;


?? TITLE := 'iop$process_io_completions', EJECT ??
  PROCEDURE [XDCL] iop$process_io_completions;


  PROCEDURE [INLINE] move_bytes (source: ^cell;
        dest: ^cell;
        length: 0 .. ioc$response_buffer_length_b);

    VAR
      str1: ^string (ioc$response_buffer_length_b),
      str2: ^string (ioc$response_buffer_length_b);

?? PUSH (CHKRNG := OFF, CHKSUB := OFF) ??
    IF length <> 0 THEN
      str1 := source;
      str2 := dest;
      str2^ (1, length) := str1^ (1, length);
      #SPOIL (str2^);
    IFEND;
?? POP ??
  PROCEND move_bytes;




    VAR
      dmv$external_interrupt_selector: [XREF] 0 .. 0ff(16),
      response_p: ^array [0 .. ioc$response_buffer_length_b] of ost$byte,
      detailed_p: ^cell,
      current_response_p: ^cell,
      cell_p: ^cell,
      pp_response_p: ^iot$pp_response,
      short_response_p: ^iot$short_response,
      pp_response: [STATIC] iot$pp_response := [0, NIL, 0, 0,
            40, 0, ioc$attempt_recovery, [FALSE, 1], 1,
            [FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, 0],
            [FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
            FALSE, FALSE, 0], 0, [ioc$normal_response, 0, 0], 0,
            [FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, 0], 0, 0],
      pp_interface_table_p: ^iot$pp_interface_table,
      moved_fs_response_buffer: dft$moved_fs_response_buffer,
      moved_response_buffer: iot$moved_response_buffer,
      detailed_seq_p: ^iot$detailed_seq,
      detailed_status_buffer: iot$detailed,
      detailed_status_buffer_p: ^iot$detailed,
      detailed_status_p: ^iot$detailed_status,
      special_response: boolean,
      p_fs_error_log_response: ^dft$fs_error_log_response,
      p_one_word_response: ^dft$fs_pp_response,
      total_response_length: iot$response_buffer_offset,
      in_pointer: iot$response_buffer_offset,
      new_out: iot$response_buffer_offset,
      response_length: 0 .. 0ffff(16),
      detailed_length: 0 .. 0ffff(16),
      rest: integer,
      d_status: syt$monitor_status,
      pp: 1 .. ioc$pp_count,
      remain: integer,
      valid_response: boolean;


    BEGIN

      #INLINE ('keypoint', osk$entry, 0, iok$io_completions);

      IF iov$start_ioc < 0ffffffffffff(16) THEN
          iov$start_ioc := iov$start_ioc + 1;
      IFEND;

      IF cmv$logical_pp_table_p = NIL THEN
        RETURN;
      IFEND;

      FOR pp := 1 TO cmv$max_number_of_pp DO
        IF cmv$logical_pp_table_p^ [pp].flags.configured THEN
          pp_interface_table_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;
          IF pp_interface_table_p <> NIL THEN

            IF pp_interface_table_p^.inn <> pp_interface_table_p^.out THEN
              {Note, pp_interface_table_p^.inn must be moved to a different
              {location because otherwise the pp can change the value, and
              {thereby, cause a problem.}
              in_pointer := pp_interface_table_p^.inn;
              IF in_pointer > pp_interface_table_p^.out THEN
                total_response_length := in_pointer - pp_interface_table_p^.out;
              ELSE
                total_response_length := pp_interface_table_p^.limit -
                      pp_interface_table_p^.out + in_pointer;
              IFEND;

{get pp_response.}

            /loop1/
              WHILE total_response_length > 0 DO

                #INLINE ('keypoint', osk$debug, total_response_length * osk$m,
                      iok$pp_response);

                current_response_p := ^pp_interface_table_p^.response_buffer^
                      [pp_interface_table_p^.out];

{ Look for short disk responses.

                IF cmv$logical_pp_table_p^ [pp].handlers.response_handler_p =
                      ^iop$process_disk_response THEN
                  short_response_p := current_response_p;
                  IF short_response_p^.flags.one_word_response THEN
                    pp_response.request := short_response_p^.request;
                    pp_response.request^.response_processor_p^
                          (^pp_response, NIL, pp, d_status);

                    IF NOT d_status.normal THEN
                      EXIT /loop1/;
                    IFEND;

                    pp_interface_table_p^.out := pp_interface_table_p^.out + 8;
                    IF pp_interface_table_p^.out = pp_interface_table_p^.limit THEN
                      pp_interface_table_p^.out := 0;
                    IFEND;
                    total_response_length := total_response_length - 8;
                    CYCLE /loop1/;
                  IFEND;
                IFEND;


{ Look for file server responses.

                special_response := FALSE;
                IF cmv$logical_pp_table_p^ [pp].handlers.one_word_response_allowed THEN
                  dfv$monitor_io_start_time := #free_running_clock (0);

                  p_one_word_response := current_response_p;
                  IF p_one_word_response^.response_flags.special_response THEN
                    special_response := TRUE;
                    response_length := p_one_word_response^.response_length;
                    IF (response_length > dfc$max_fs_pp_response_length) OR
                          (response_length > total_response_length) THEN
                      mtp$error_stop ('IO01 - invalid pp response');
                    IFEND;

                    IF p_one_word_response^.response_flags.one_word_response THEN
                      cmv$logical_pp_table_p^ [pp].handlers.one_word_response_handler_p^ (
                            p_one_word_response, pp, d_status);

                    ELSEIF p_one_word_response^.response_flags.error_log_response THEN
                      response_p := current_response_p;
                      IF pp_interface_table_p^.limit - pp_interface_table_p^.out >= response_length THEN
                        cell_p := ^response_p^ [#SIZE(p_one_word_response^)];
                        p_fs_error_log_response := cell_p;
                      ELSE { Move necessary.
                        remain := ((pp_interface_table_p^.limit - pp_interface_table_p^.out) -
                                     #SIZE(p_one_word_response^));
                        move_bytes (^response_p^ [#SIZE(p_one_word_response^)],
                              ^moved_fs_response_buffer.bytes [0], remain);
                        rest := response_length - #SIZE(p_one_word_response^) - remain;
                        move_bytes (pp_interface_table_p^.response_buffer, ^moved_fs_response_buffer.bytes
                              [remain], rest);
                        p_fs_error_log_response := ^moved_fs_response_buffer.response;
                      IFEND;
                      dfp$process_error_log_response (p_one_word_response, p_fs_error_log_response,
                            pp, d_status);

                    ELSE { Invalid special response.
                      mtp$error_stop ('IO01 - invalid pp response');
                    IFEND;

                  IFEND;
                IFEND;


{ General response format.

                IF NOT special_response THEN
                  IF pp_interface_table_p^.limit - pp_interface_table_p^.out >=
                        ioc$min_response_length THEN
                    pp_response_p := current_response_p;
                  ELSE { Move is necessary.
                    remain := (pp_interface_table_p^.limit - pp_interface_table_p^.out);
                    move_bytes (current_response_p, ^moved_response_buffer.bytes [0], remain);
                    rest := ioc$min_response_length - remain;
                    move_bytes (pp_interface_table_p^.response_buffer, ^moved_response_buffer.bytes
                          [remain], rest);
                    pp_response_p := ^moved_response_buffer.response;
                  IFEND;

                  response_length := pp_response_p^.response_length;
                  IF (response_length < ioc$min_response_length) OR
                        (response_length > total_response_length) THEN
                    mtp$error_stop ('IO01 - invalid pp response');
                  IFEND;

{ Process detailed status.}

                  IF response_length = ioc$min_response_length THEN
                    detailed_status_p := NIL;

                  ELSE
                    new_out := pp_interface_table_p^.out + ioc$min_response_length;
                    IF new_out >= pp_interface_table_p^.limit THEN
                      new_out := new_out - pp_interface_table_p^.limit;
                    IFEND;
                    detailed_p := ^pp_interface_table_p^.response_buffer^
                          [new_out];

                    detailed_length := response_length - ioc$min_response_length;
                    IF pp_interface_table_p^.limit - new_out >= detailed_length THEN
                      move_bytes (detailed_p, ^detailed_status_buffer.bytes [0], detailed_length);
                      detailed_status_p := ^detailed_status_buffer.detailed_status;
                    ELSE
                      detailed_status_p := ^detailed_status_buffer.detailed_status;
                      remain := (pp_interface_table_p^.limit - new_out);
                      move_bytes (detailed_p, ^detailed_status_buffer.bytes [0], remain);
                      rest := detailed_length - remain;
                      move_bytes (pp_interface_table_p^.response_buffer, ^detailed_status_buffer.bytes
                            [remain], rest);
                    IFEND;
                    RESET detailed_status_p;
                  IFEND;

    IF iov$stop_ioc < 0ffffffffffff(16) THEN
        iov$stop_ioc := iov$stop_ioc + 1;
    IFEND;

{ Call response processor for each io_type.

       valid_response := TRUE;
              IF pp_response_p^.abnormal_status.interface_error THEN

{ We can't call the response processor if there's an interface error
{ because the request address might be garbage.

                   valid_response := FALSE;
                   iov$invalid_2 := iov$invalid_2 + 1;

             IFEND;

             IF (pp_response_p^.request_rma = 0) OR (pp_response_p^.request = NIL) THEN
                 valid_response := FALSE;
{ We can't call a zero or Nil response address without crashing.
                        iov$invalid_3 := iov$invalid_3 + 1;
             IFEND;
                  IF (pp_response_p^.response_code.primary_response <>
                        ioc$unsolicited_response) AND (valid_response) THEN
                    pp_response_p^.request^.response_processor_p^ (pp_response_p,
                          detailed_status_p, pp, d_status);

                  ELSE

                    cmv$logical_pp_table_p^ [pp].handlers.response_handler_p^ (pp_response_p,
                          detailed_status_p, pp, d_status);
                  IFEND;
                IFEND { end NOT special_response };

                IF NOT d_status.normal THEN
                  EXIT /loop1/;
                IFEND;


{ Update out pointer for response buffer.}

                IF (pp_interface_table_p^.out + response_length) <
                      pp_interface_table_p^.limit THEN
                  pp_interface_table_p^.out := pp_interface_table_p^.out +
                        response_length;
                ELSE
                  pp_interface_table_p^.out := pp_interface_table_p^.out +
                        response_length - pp_interface_table_p^.limit;
                IFEND;

{ Loop if more requests to process.}

                total_response_length := total_response_length -
                      response_length;
              WHILEND /loop1/;

            IFEND;
          IFEND;
        IFEND;
      FOREND;


      #INLINE ('keypoint', osk$exit, 0, iok$io_completions);
    END;

  PROCEND iop$process_io_completions;
?? TITLE := 'iop$process_disk_response', EJECT ??

  PROCEDURE [XDCL] iop$process_disk_response (pp_response_p: ^iot$pp_response;
        detailed_status_p: ^iot$detailed_status;
        pp: 1 .. ioc$pp_count;
    VAR status: syt$monitor_status);

    CONST
      osk$class_5 = osk$system_class + 5;

    VAR
      completed_request_p: ^iot$disk_request,
      io_function: iot$io_function,
      list_p: ^mmt$rma_list,
      address_pair_count: mmt$rma_list_length,
      job_id: jmt$ijl_ordinal,
      system_file_id: dmt$system_file_id,
      byte_address: amt$file_byte_address,
      write_tu_status: dmt$write_tu_status,
      media_error: boolean,
      power_failing: boolean,
      requested_cylinder: iot$cylinder,
      cylinder: iot$cylinder,
      track: iot$track,
      sector: iot$sector,
      mau_offset_in_cylinder: dmt$maus_per_position,
      au_was_previously_written: boolean,
      logical_unit: iot$logical_unit,
      t_status: syt$monitor_status,
      m_status: syt$monitor_status,
      c_status: syt$monitor_status,
      normal: iot$io_error,
      m: 0 .. ioc$command_map_count,
      index: 1 .. ioc$request_heap_count,
      c_index: 1 .. ioc$command_map_count,
      data_maus: dmt$mau_address,
      data_and_preset_maus: dmt$mau_address,
      ud: integer,
      equipment: 0 .. 0ff(16),
      active_pp: ^iot$disk_pp_usage,
      active_unit: ^iot$disk_unit_usage,
      channel: cmt$physical_channel,
      iou_number: dst$iou_number,
      physical_unit: 0 .. 0ff(16),
      port_index: 0 .. 1,
      time: integer,
      qtime: integer,
      data_transfer_time: integer,
      response_time: integer,
      seek_and_latency_time: integer,
      lud: integer,
      u: iot$logical_unit,
      down_status: iot$down_status,
      critical: boolean,
      d_index: 0 .. 0ffff(16),
      server_iocb_p: ^mmt$server_iocb_entry;


    IF iov$start_ioc < 0ffffffffffff(16) THEN
          iov$start_ioc := iov$start_ioc + 1;
    IFEND;

    status.normal := TRUE;

    IF pp_response_p^.response_code.primary_response <>
          ioc$unsolicited_response THEN
      completed_request_p := pp_response_p^.request^.device_request_p;
      logical_unit := completed_request_p^.request.logical_unit;
      ud := logical_unit;
    ELSE
      completed_request_p := NIL;
      logical_unit := pp_response_p^.logical_unit;

    /find_ud/
      BEGIN
        FOR ud := UPPERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
              pp_interface_table_p^.unit_descriptors) DOWNTO
              LOWERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.unit_descriptors) DO
          IF cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                unit_descriptors [ud].logical_unit = logical_unit THEN
            EXIT /find_ud/;
          IFEND;
        FOREND;
        logical_unit := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
              unit_descriptors [ud].logical_unit;
      END /find_ud/;
    IFEND;


    d_index := cmv$logical_unit_table^ [logical_unit].unit_interface_table^.
          unit_type - 100(16) + 1;
    iou_number := cmv$logical_pp_table_p^ [pp].pp_info.channel.iou_number;
    channel.number := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
          unit_descriptors [ud].physical_path.channel_number;
    channel.concurrent := cmv$logical_pp_table_p^ [pp].pp_info.channel_interlock_p^.
          channel_characteristics [channel.number].concurrent_channel;
    port_index := 0;
    channel.port := cmc$unspecified_port;
    IF channel.concurrent THEN
      IF (d_index = (ioc$dt_mshydra - 100(16) +1 )) OR
          ((d_index > (ioc$dt_msxmd_3 - 100(16))) AND
          (d_index < (ioc$dt_ms47444_4 - 100(16) + 2))) THEN
        IF cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
              unit_descriptors [ud].physical_path.port = 0 THEN
          channel.port := cmc$port_a;
        ELSE
          channel.port := cmc$port_b;
          port_index := 1;
        IFEND;
      IFEND;
    IFEND;
    equipment := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
          unit_descriptors [ud].physical_path.controller_number;
    physical_unit := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
          unit_descriptors [ud].physical_path.physical_unit_number;
    cylinder := 0;
    mau_offset_in_cylinder := 0;

    c_status.condition := 0;
    normal := ioc$no_error;
    media_error := FALSE;
    write_tu_status := dmc$tu_written;
    IF osv$disk_fault_simulation AND (completed_request_p <> NIL) THEN
      simulate_disk_fault (completed_request_p, normal);
      IF normal <> ioc$no_error THEN
        write_tu_status := dmc$tu_not_written;
        cylinder := completed_request_p^.request.cylinder;
        track := completed_request_p^.request.track;
        sector := completed_request_p^.request.sector;
        mau_offset_in_cylinder := (track * iov$disk_type_table [d_index].
              sectors_per_track + sector) DIV iov$disk_type_table [d_index].
              sectors_per_mau;
        IF normal = ioc$media_error THEN
          media_error := TRUE;
          c_status.condition := ioc$disk_media_error;
        ELSEIF normal = ioc$unrecovered_error_unit_down THEN
          c_status.condition := ioe$unit_disabled;
        ELSE
          c_status.condition := ioc$unrecovered_disk_error;
        IFEND;
      IFEND;
    IFEND;

    power_failing := (mtv$scb.nos_180_status.idle_code = syc$ic_long_power);

{If the system is attempting to idle due to failing power then don't
{be concerned about errors on devices that don't have UPS power backup.
{We need all the CPU resources at this time just to get the processor
{idled down.

    IF (pp_response_p^.response_code.primary_response <> ioc$normal_response)
          OR (detailed_status_p <> NIL) AND (NOT power_failing) THEN

{Log error.
      iop$log_disk_error (pp_response_p, detailed_status_p, pp, iou_number,
            completed_request_p, logical_unit, channel, equipment,
            physical_unit, ud, mau_offset_in_cylinder, cylinder, down_status);

      IF down_status <> ioc$no_change THEN
        CASE down_status OF
        = ioc$channel_down =
          iop$down_disk_channel (pp, channel, t_status);
          RETURN;
        = ioc$controller_down =
          iop$down_disk_controller (pp, channel, equipment, t_status);
          RETURN;
        = ioc$unit_down =
          iop$down_disk_unit (pp, channel, equipment, physical_unit, logical_unit, t_status);
          RETURN;
{       = ioc$executing_diagnostics =
{         IF pp_response_p^.response_code.primary_response <>
{               ioc$unsolicited_response THEN
{           cmv$logical_unit_table^ [logical_unit].element_capability :=
{                 $cmt$element_capabilities [cmc$concurrent_maintenance];
{           dmp$volume_down (logical_unit, critical);
{         IFEND;
        ELSE
        CASEND;
      IFEND;


      IF (pp_response_p^.response_code.primary_response =
            ioc$intermediate_response) OR (pp_response_p^.response_code.
            primary_response = ioc$unsolicited_response) THEN
        RETURN;
      IFEND;


      IF pp_response_p^.response_code.primary_response = ioc$abnormal_response
            THEN
        normal := ioc$unrecovered_error;
        write_tu_status := dmc$tu_not_written;
        c_status.condition := ioc$unrecovered_disk_error;
        IF (pp_response_p^.abnormal_status.recording_medium_error = TRUE) THEN
          normal := ioc$media_error;
          media_error := TRUE;
          c_status.condition := ioc$disk_media_error;
        IFEND;
        IF (completed_request_p^.request_info.request_type <> ioc$device_io) AND
              (NOT completed_request_p^.request_info.au_was_previously_written) THEN
          normal := ioc$error_on_init;
        IFEND;
        IF (iov$disk_unit_usage_p <> NIL) AND (iov$disk_unit_usage_p^ [logical_unit] <> NIL) THEN
          IF iov$disk_unit_usage_p^ [logical_unit]^.last_request_good THEN
            dsp$mtr_save_disk_error (dsc$ssr_sds_disk_request_bad, #free_running_clock (0),
                  iov$disk_unit_usage_p^ [logical_unit]^.element_name);
            iov$disk_unit_usage_p^ [logical_unit]^.last_request_good := FALSE;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF (d_index = ioc$dt_ms5833_3p - 0ff(16)) OR (d_index = ioc$dt_ms5833_1p - 00ff(16)) OR
          (d_index = ioc$dt_ms5838_3p - 0ff(16)) OR (d_index = ioc$dt_ms5838_1p - 00ff(16)) OR
          (d_index = ioc$dt_ms47444_3p - 0ff(16)) OR (d_index = ioc$dt_ms47444_1p - 00ff(16)) THEN
      IF (detailed_status_p <> NIL) AND
           (pp_response_p^.abnormal_status.recording_medium_error = true) THEN
        media_error := true;
      IFEND;
    IFEND;

    requested_cylinder := completed_request_p^.request.cylinder;
    data_maus := completed_request_p^.request_info.data_maus;
    data_and_preset_maus:= completed_request_p^.request.mau_count;
    #INLINE ('keypoint', osk$class_5, (((logical_unit MOD 100(16)) *
          1000(16)) + (requested_cylinder MOD 1000(16))) * osk$m,
          iok$disk_request_3);
    #INLINE ('keypoint', osk$class_5, (((channel.number MOD 20(16)) * 10(16) +
          (equipment MOD 10(16))) * 200(16) + (data_and_preset_maus MOD 200(16)))
          * osk$m, iok$disk_request_4);


{Unlock pages.

    IF completed_request_p^.request_info.list_length <> 0 THEN
      io_function := completed_request_p^.request_info.io_function;
      list_p := completed_request_p^.request_info.list_p;
      address_pair_count := completed_request_p^.request_info.list_length;
      system_file_id := completed_request_p^.request_info.system_file_id;
      mmp$unlock_rma_list (io_function, list_p, address_pair_count,
            completed_request_p^.request_info.io_identifier,
            (system_file_id.residence = gfc$tr_job),
            normal, m_status);
      IF m_status.normal = FALSE THEN
        mtp$error_stop ('IO12 - abnormal unlock status');
      IFEND;

{ It is possible that the job has terminated or the file deleted if this io completion is
{ for a local file write.  If it completed normally we are ok.  If there was an error we
{ do not want to try and flaw it in dmp$transfer_unit_completed. So, we will lie and say
{ write_tu_status is written.  Mmp$unlock_rma_list sets normal to ioc$no_error after
{ it has processed the error.  The error will not be processed if the page is in the
{ free queue (i.e. the job had terminated or the file deleted) and normal will not be
{ reset.

      IF (write_tu_status = dmc$tu_not_written) AND
            (completed_request_p^.request_info.system_file_id.residence = gfc$tr_job) AND
            ((io_function = ioc$write_page) OR (io_function = ioc$write_locked_page)) AND
            (normal <> ioc$no_error) THEN
        write_tu_status := dmc$tu_written;
      IFEND;
    IFEND;

{Call mmp$mtr_process_io_completion.
{ Possible file server completion handling is determined by IO_FUNCTION.

    IF completed_request_p^.request_info.io_identifier.specified THEN
      c_status.normal := normal = ioc$no_error;
      CASE io_function OF
      = ioc$read_for_server..ioc$write_to_client =
        dfv$monitor_io_start_time := #free_running_clock (0);
        dfp$fetch_server_iocb(completed_request_p^.request_info.io_identifier.queue_entry_location,
              server_iocb_p);
        mmp$mtr_process_server_complete (dfc$completing_previous_request, completed_request_p^.request_info.
              io_identifier, server_iocb_p, c_status);
      = ioc$read_ahead_on_server =
        mmp$process_read_ahead_complete (completed_request_p^.request_info.io_identifier, c_status);
      ELSE
        mmp$mtr_process_io_completion (completed_request_p^.request_info.io_identifier, io_function,
              c_status);
      CASEND;
    IFEND;

{check if transfer unit was previously written.}
    IF completed_request_p^.request_info.request_type <> ioc$device_io THEN
      job_id := completed_request_p^.request_info.job_id;
      system_file_id := completed_request_p^.request_info.system_file_id;
      byte_address := completed_request_p^.request_info.byte_address;
      au_was_previously_written := completed_request_p^.request_info.
            au_was_previously_written;
      dmp$transfer_unit_completed (job_id, system_file_id, byte_address,
            write_tu_status, au_was_previously_written, media_error, cylinder,
            mau_offset_in_cylinder, io_function, t_status);
      IF t_status.normal = FALSE THEN
        mtp$error_stop ('IO13 - abnormal dmp status');
      IFEND;

{If ioc$device_io request, return completion status.
    ELSE
      IF normal = ioc$no_error THEN
        completed_request_p^.request_info.completion^ := 1;
      ELSE
        completed_request_p^.request_info.completion^ := 2;
      IFEND;
    IFEND;

{ Put request on empty chain.
{ Clear request packet allocation.}

    completed_request_p^.link := NIL;

    IF NOT completed_request_p^.request.pp_switch THEN
      IF (iov$stream_requests [logical_unit] <> NIL) AND
            (cmv$logical_unit_table ^ [logical_unit].unit_interface_table^.
            queue_count = 0) THEN
        iov$empty_requests_end ^ := iov$stream_requests [logical_unit];
        iov$empty_requests_end := iov$stream_requests_end [logical_unit];
        iov$stream_requests_end [logical_unit] := ^iov$stream_requests [logical_unit];
        iov$stream_requests [logical_unit] := NIL;
      IFEND;

      iov$empty_requests_end ^ := pp_response_p^.request;
      iov$empty_requests_end := ^completed_request_p^.link;
    ELSE
      iov$stream_requests_end [logical_unit] ^ := pp_response_p^.request;
      iov$stream_requests_end [logical_unit] := ^completed_request_p^.link;
    IFEND;

    index := completed_request_p^.request_index;
    IF iov$request_heap_map [index] = FALSE THEN
      mtp$error_stop ('IO02 - invalid pp response');
    IFEND;
    iov$request_heap_map [index] := FALSE;
    iov$empty_request_count := iov$empty_request_count + 1;

    IF completed_request_p^.request_info.command_group_count <> 0 THEN
      c_index := completed_request_p^.request_info.command_index;
      FOR m := 0 TO completed_request_p^.request_info.command_group_count - 1
            DO
        IF iov$command_heap_map [c_index + m] = FALSE THEN
          mtp$error_stop ('IO03 - invalid pp response');
        IFEND;
        iov$command_heap_map [c_index + m] := FALSE;
      FOREND;
    IFEND;

{Update usage counters.

    IF pp_response_p^.response_code.primary_response = ioc$normal_response THEN
      IF (iov$disk_unit_usage_p <> NIL) AND (iov$disk_pp_usage_p <> NIL) THEN
        active_pp := iov$disk_pp_usage_p^ [pp];
        active_unit := iov$disk_unit_usage_p^ [logical_unit];
        IF (active_pp <> NIL) AND (active_unit <> NIL) THEN
          active_unit^.unit_used := TRUE;
          active_pp^.path_usage [port_index] [equipment].path_used := TRUE;
          time := #free_running_clock (0);
          qtime := time - completed_request_p^.request_info.time;
          IF completed_request_p^.request.command [1].command_code = ioc$cc_read_bytes THEN
            active_pp^.path_usage [port_index] [equipment].read_requests :=
                active_pp^.path_usage [port_index] [equipment].read_requests + 1;
            active_pp^.path_usage [port_index] [equipment].read_maus :=
                active_pp^.path_usage [port_index] [equipment].read_maus + data_maus;
            IF completed_request_p^.request_info.io_function = ioc$swap_in THEN
              active_unit^.swap_in_requests := active_unit^.swap_in_requests + 1;
              active_unit^.swap_in_qtime := active_unit^.swap_in_qtime + qtime;
              active_unit^.swap_in_mau_count := active_unit^.swap_in_mau_count + data_maus;
            ELSE
              active_unit^.read_requests := active_unit^.read_requests + 1;
              active_unit^.read_qtime := active_unit^.read_qtime + qtime;
              active_unit^.read_mau_count := active_unit^.read_mau_count + data_maus;
            IFEND;
          ELSE
            active_pp^.path_usage [port_index] [equipment].write_requests :=
                active_pp^.path_usage [port_index] [equipment].write_requests + 1;
            active_pp^.path_usage [port_index] [equipment].written_and_preset_maus :=
                active_pp^.path_usage [port_index] [equipment].written_and_preset_maus +
                data_and_preset_maus;
            IF completed_request_p^.request_info.io_function = ioc$swap_out THEN
              active_unit^.swap_out_requests := active_unit^.swap_out_requests + 1;
              active_unit^.swap_out_qtime := active_unit^.swap_out_qtime + qtime;
              active_unit^.swap_out_data_mau_count := active_unit^.swap_out_data_mau_count + data_maus;
              active_unit^.swap_out_data_and_preset_maus := active_unit^.swap_out_data_and_preset_maus +
                  data_and_preset_maus;
            ELSE
              active_unit^.write_requests := active_unit^.write_requests + 1;
              active_unit^.write_qtime := active_unit^.write_qtime + qtime;
              active_unit^.write_data_mau_count := active_unit^.write_data_mau_count + data_maus;
              active_unit^.write_data_and_preset_maus := active_unit^.write_data_and_preset_maus +
                  data_and_preset_maus;
            IFEND;
          IFEND;
          active_pp^.path_usage [port_index] [equipment].total_request_qtime :=
                active_pp^.path_usage [port_index] [equipment].total_request_qtime + qtime;
          IF requested_cylinder <> active_unit^.current_cylinder THEN
            active_unit^.requests_causing_skipped_cyl := active_unit^.
                  requests_causing_skipped_cyl + 1;
            IF requested_cylinder > active_unit^.current_cylinder THEN
              active_unit^.total_cylinders_skipped := active_unit^.total_cylinders_skipped +
                  requested_cylinder - active_unit^.current_cylinder;
            ELSE
              active_unit^.total_cylinders_skipped := active_unit^.total_cylinders_skipped +
                  active_unit^.current_cylinder - requested_cylinder;
            IFEND;
            active_unit^.current_cylinder := requested_cylinder;
          IFEND;
          response_time := time - active_pp^.last_response_time;
          IF qtime < response_time THEN
            response_time := qtime;
          IFEND;
          active_pp^.last_response_time := time;
          data_transfer_time := data_and_preset_maus * iov$disk_type_table [d_index].mau_time;
          seek_and_latency_time := response_time - data_transfer_time;
          active_pp^.computed_data_transfer_time := active_pp^.
               computed_data_transfer_time + data_transfer_time;
          active_pp^.seek_and_latency_time := active_pp^.seek_and_latency_time +
               seek_and_latency_time;
          IF active_unit^.streamed_request_possible THEN
            IF seek_and_latency_time > 16000 THEN
              IF completed_request_p^.request.command [1].command_code = ioc$cc_read_bytes THEN
                active_unit^.streamed_req_failed_count_read := active_unit^.
                     streamed_req_failed_count_read + 1;
                active_pp^.streamed_req_failed_count_read := active_pp^.
                     streamed_req_failed_count_read + 1;
              ELSE
                active_unit^.streamed_req_failed_count_write := active_unit^.
                     streamed_req_failed_count_write + 1;
                active_pp^.streamed_req_failed_count_write := active_pp^.
                     streamed_req_failed_count_write + 1;
              IFEND;
            ELSE
              IF completed_request_p^.request.command [1].command_code = ioc$cc_read_bytes THEN
                active_unit^.streamed_req_count_read := active_unit^.
                     streamed_req_count_read + 1;
                active_pp^.streamed_req_count_read := active_pp^.
                     streamed_req_count_read + 1;
              ELSE
                active_unit^.streamed_req_count_write := active_unit^.
                     streamed_req_count_write + 1;
                active_pp^.streamed_req_count_write := active_pp^.
                     streamed_req_count_write + 1;
              IFEND;
            IFEND;
          IFEND;
          active_unit^.streamed_request_possible := completed_request_p^.
              request.pp_switch;
          IF NOT active_unit^.last_request_good THEN
            dsp$mtr_save_disk_error (dsc$ssr_sds_disk_request_good, 0, active_unit^.element_name);
            active_unit^.last_request_good := TRUE;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
      IF iov$stop_ioc < 0ffffffffffff(16) THEN
          iov$stop_ioc := iov$stop_ioc + 1;
      IFEND;

  PROCEND iop$process_disk_response;
?? TITLE := 'iop$log_disk_error', EJECT ??

  PROCEDURE iop$log_disk_error (pp_response_p: ^iot$pp_response;
        detailed_status_p: ^iot$detailed_status;
        pp: 1 .. ioc$pp_count;
        iou_number: dst$iou_number,
        completed_request_p: ^iot$disk_request;
        logical_unit: iot$logical_unit;
        channel: cmt$physical_channel,
        equipment: 0 .. 0ff(16);
        physical_unit: 0 .. 0ff(16);
        ud: integer;
    VAR mau_offset_in_cylinder: dmt$maus_per_position;
    VAR cylinder: iot$cylinder;
    VAR down_status: iot$down_status);



    VAR
      bi: integer,
      detail_status_p: ^SEQ ( * ),
      track: iot$track,
      sector: iot$sector,
      disk_type: iot$unit_type,
      controller_type: integer,
      das_type: [STATIC] string(136) := '5832_1  5832_2  'cat
                                        '5833_1  5833_1P 5833_2  5833_3P 5833_4  'cat
                                        '5838_1  5838_1P 5838_2  5838_3P 5838_4  'cat
                                        '47444_1 47444_1P47444_2 47444_3P47444_4 ',
      loop: boolean,
      port_index: 0 .. 1,
      d_index: 1 .. ioc$disk_type_count,
      disk_status_p: ^iot$common_disk_status,
      disk_885_status_p: ^iot$disk_detailed_status_885,
      disk_status_844_p: ^iot$disk_detailed_status_844,
      isd_status_p: ^iot$isd_status,
      hydra_status_p: ^iot$hydra_status,
      disk_status_895_p: ^iot$895_detailed_status,
      disk_status_9836_1_p: ^iot$detailed_status_9836_1,
      response_packet: iot$9836_analyzed_response_pkt,
      disk_error_9836: boolean,
      msg_type: dst$system_logging_types,
      msg_level: dst$system_message_levels,
      msg_recorded: boolean,
      unrecovered_error: 0 .. 3,
      msg: string (65),
      msg1: string (65),
      msg2: string (65),
      msg3: string (65),
      disk_log_data_p: ^iot$disk_log_data,
      seq_p: ^SEQ ( * ),
      disk_log_seq: SEQ (REP ioc$disk_log_data_length of ost$word),
      status_bytes_p: ^array [1 .. ioc$disk_detailed_status_words] of 0 ..
        0ffff(16),
      i: integer,
      j: integer,
      m: integer,
      packet_length: integer,
      line_index: integer,
      word1: 0 .. 0ffff(16),
      word_p: ^ost$word,
      message_found: boolean,
      manual_intervention_code: 0 .. 0ff(16),
      system_intervention_code: 0 .. 0ff(16),
      delay_status_code: 0 .. 0ff(16),
      adapter_diagnostic_code: integer,
      level_i_diagnostic_code: 0 .. 0ff(16),
      level_ii_diagnostic_code: 0 .. 0ff(16),
      display_message: boolean,
      cell_p: ^cell,
      error_status_p: ^iot$channel_error_status,
      previous_error: boolean,
      format_message: 0 .. 0ff(16),
      signal_contents: cmt$signal_contents,
      signal: pmt$signal,
      mtr_status: syt$monitor_status,
      send_ssd_battery_signal: boolean,
      k: integer;


    down_status := ioc$no_change;


{Put disk_log_data in a sequence.

    seq_p := ^disk_log_seq;
    RESET seq_p;
    NEXT disk_log_data_p IN seq_p;
    RESET seq_p;

    disk_log_data_p^.pp_response := pp_response_p^;
    disk_log_data_p^.iou_number := iou_number;
    disk_log_data_p^.channel := channel;
    disk_log_data_p^.equipment := equipment;
    disk_log_data_p^.logical_unit := logical_unit;
    disk_log_data_p^.diagnostic_code := 0;
    port_index := 0;
    IF channel.port = cmc$port_b THEN
      port_index := 1;
    IFEND;
    IF logical_unit >= LOWERBOUND (cmv$logical_unit_table^) THEN
      IF cmv$logical_unit_table^ [logical_unit].configured THEN
        disk_type := cmv$logical_unit_table^ [logical_unit].
              unit_interface_table^.unit_type;
        d_index := disk_type - 100(16) + 1;
      IFEND;
    ELSE
      disk_type := 0;
      d_index := 1;
    IFEND;
    disk_log_data_p^.disk_type := disk_type;

{Make a status area if no detailed status was provided.

    PUSH detail_status_p: [[REP ioc$disk_detailed_status_length OF
          ost$word]];
    IF detailed_status_p <> NIL THEN
      detail_status_p^ := detailed_status_p^;
    ELSE
      RESET detail_status_p;
      FOR i := 1 TO ioc$disk_detailed_status_length DO
        NEXT word_p IN detail_status_p;
        word_p^ := 0;
      FOREND;
    IFEND;
    RESET detail_status_p;
    NEXT disk_status_p IN detail_status_p;
    RESET detail_status_p;

    CASE disk_type OF
    = ioc$dt_ms885_1x, ioc$dt_ms885_42 =
      NEXT disk_885_status_p IN detail_status_p;
      cylinder := disk_885_status_p^.general_status.starting_cylinder;
      track := disk_885_status_p^.general_status.failing_track;
      sector := disk_885_status_p^.general_status.failing_sector;
      IF disk_885_status_p^.general_status.detailed_status_present AND
            (cylinder = disk_885_status_p^.status_885.cylinder1 * 16 + disk_885_status_p^.
            status_885.cylinder2) THEN
        track := disk_885_status_p^.status_885.track;
        sector := disk_885_status_p^.status_885.sector;
        IF ((sector - disk_885_status_p^.general_status.failing_sector) <= 3) AND
              ((sector - disk_885_status_p^.general_status.failing_sector) >= - 4)
              THEN
          disk_885_status_p^.general_status.failing_sector := sector;
        IFEND;
      IFEND;

    = ioc$dt_ms844_4x =
      NEXT disk_status_844_p IN detail_status_p;
      RESET detail_status_p;
      NEXT disk_885_status_p IN detail_status_p;
      cylinder := disk_status_844_p^.general_status.starting_cylinder;
      track := disk_status_844_p^.general_status.failing_track;
      sector := disk_status_844_p^.general_status.failing_sector;
      IF disk_status_844_p^.general_status.detailed_status_present AND
            (cylinder = disk_status_844_p^.status_844.cylinder1 * 512 +
            disk_status_844_p^.status_844.cylinder2) THEN
        track := disk_status_844_p^.status_844.track1 * 4 + disk_status_844_p^.
              status_844.track2;
        sector := disk_status_844_p^.status_844.sector;
      IFEND;

    = ioc$dt_ms834_2, ioc$dt_msfsd_2 =
      NEXT isd_status_p IN detail_status_p;

      cylinder := isd_status_p^.general_status.starting_cylinder;
      track := isd_status_p^.general_status.failing_track;
      sector := isd_status_p^.general_status .failing_sector;
      IF isd_status_p^.general_status.detailed_status_present AND
            (cylinder = isd_status_p^.detailed_status1.cylinder) THEN
        track := isd_status_p^.detailed_status1.track;
        sector := isd_status_p^.detailed_status1.sector1 * 8 + isd_status_p^.
              detailed_status1.sector2;
        isd_status_p^.general_status.failing_track := track;
        isd_status_p^.general_status.failing_sector := sector;
      IFEND;

    = ioc$dt_ms895_2 =
      NEXT disk_status_895_p IN detail_status_p;
      cylinder := disk_status_895_p^.general_status.starting_cylinder;
      track := disk_status_895_p^.general_status.failing_track;
      sector := disk_status_895_p^.general_status.failing_sector;

    = ioc$dt_mshydra =
      NEXT hydra_status_p IN detail_status_p;
      cylinder := hydra_status_p^.general_status.starting_cylinder;
      track := hydra_status_p^.general_status.failing_track;
      sector := hydra_status_p^.general_status.failing_sector;
      IF hydra_status_p^.general_status.device_status_present AND
            (cylinder = hydra_status_p^.device_status1.cylinder) THEN
        track := hydra_status_p^.device_status1.track;
        sector := hydra_status_p^.device_status1.sector;
        hydra_status_p^.general_status.failing_track := track;
        hydra_status_p^.general_status.failing_sector := sector;
      IFEND;

    = ioc$dt_ms9836_1, ioc$dt_msxmd_3, ioc$dt_ms5832_1,
        ioc$dt_ms5832_2, ioc$dt_ms5833_1, ioc$dt_ms5833_1p,
        ioc$dt_ms5833_2, ioc$dt_ms5833_3p, ioc$dt_ms5833_4,
        ioc$dt_ms5838_1, ioc$dt_ms5838_1p, ioc$dt_ms5838_2,
        ioc$dt_ms5838_3p, ioc$dt_ms5838_4,
        ioc$dt_ms47444_1, ioc$dt_ms47444_1p, ioc$dt_ms47444_2,
        ioc$dt_ms47444_3p, ioc$dt_ms47444_4 =
      NEXT disk_status_9836_1_p IN detail_status_p;
      cylinder := disk_status_9836_1_p^.starting_cylinder;
      track := disk_status_9836_1_p^.failing_track;
      sector := disk_status_9836_1_p^.failing_sector;
    ELSE
    CASEND;

    disk_log_data_p^.detailed_status := disk_status_p^;

{Compute mau_offset.

    IF disk_type <> 0 THEN
      mau_offset_in_cylinder := (track * iov$disk_type_table [d_index].
            sectors_per_track + sector) DIV iov$disk_type_table [d_index].
            sectors_per_mau;
    IFEND;

{Determine if unrecovered error.

    IF (pp_response_p^.response_code.primary_response = ioc$normal_response) OR
          (pp_response_p^.response_code.secondary_response =
          ioc$recovered_error) THEN
      unrecovered_error := 0;
    ELSE
  /unrecovered_error_block/
      BEGIN
        IF (disk_type = ioc$dt_ms9836_1) OR (disk_type = ioc$dt_msxmd_3) OR
              (disk_type = ioc$dt_ms5832_1) OR (disk_type = ioc$dt_ms5832_2) OR
              (disk_type = ioc$dt_ms5833_1) OR (disk_type = ioc$dt_ms5833_1p) OR
              (disk_type = ioc$dt_ms5833_2) OR (disk_type = ioc$dt_ms5833_3p) OR
              (disk_type = ioc$dt_ms5833_4) OR
              (disk_type = ioc$dt_ms5838_1) OR (disk_type = ioc$dt_ms5838_1p) OR
              (disk_type = ioc$dt_ms5838_2) OR (disk_type = ioc$dt_ms5838_3p) OR
              (disk_type = ioc$dt_ms5838_4) OR
              (disk_type = ioc$dt_ms47444_1) OR (disk_type = ioc$dt_ms47444_1p) OR
              (disk_type = ioc$dt_ms47444_2) OR (disk_type = ioc$dt_ms47444_3p) OR
              (disk_type = ioc$dt_ms47444_4) THEN
          IF (pp_response_p^.response_code.primary_response = ioc$abnormal_response) OR
             (disk_status_9836_1_p^.id=1) OR (disk_status_9836_1_p^.id=2) OR
              (disk_status_9836_1_p^.id=3) THEN
            unrecovered_error := 1;
          ELSE
            unrecovered_error := 2;
            EXIT /unrecovered_error_block/;
          IFEND;
        ELSE
          IF (pp_response_p^.response_code.primary_response =
              ioc$abnormal_response) OR disk_status_p^.general_status.
              channel_down OR disk_status_p^.general_status.control_module_down
              OR disk_status_p^.general_status.unit_down THEN
            unrecovered_error := 1;
          ELSE
            unrecovered_error := 2;
            EXIT /unrecovered_error_block/;
          IFEND;
        IFEND;
        IF iov$unrecovered_disk_errors < 0ffffffffffff(16) THEN
          iov$unrecovered_disk_errors := iov$unrecovered_disk_errors + 1;
        IFEND;
      END /unrecovered_error_block/;
    IFEND;
    disk_log_data_p^.failure_severity := unrecovered_error;
    msg_type := dsc$disk_errors;
    IF unrecovered_error = 0 THEN
      msg_level := dsc$recovered_error;
    ELSE
      msg_level := dsc$unrecovered_error;
    IFEND;

{Determine controller type.

    CASE cmv$logical_pp_table_p^ [pp].controller_info.controller_type OF
    = cmc$ms7154_x =
      disk_log_data_p^.controller_type := 1;
    = cmc$ms7155_1, cmc$ms7155_1x =
      disk_log_data_p^.controller_type := 2;
    = cmc$ms7255_1_1 =
      disk_log_data_p^.controller_type := 3;
    = cmc$ms7255_1_2 =
      disk_log_data_p^.controller_type := 4;
    = cmc$ms7165_2x =
      disk_log_data_p^.controller_type := 5;
    = cmc$mshydra_ct =
      disk_log_data_p^.controller_type := 6;
    = cmc$mscm3_ct =
      disk_log_data_p^.controller_type := 7;
    = cmc$ms5831_x =
      disk_log_data_p^.controller_type := 8;
      disk_log_data_p^.isolation_code := disk_status_9836_1_p^.id MOD 100(16);
    ELSE
      mtp$error_stop ('IO - invalid controller type');
    CASEND;


    IF pp_response_p^.response_code.primary_response <>
          ioc$unsolicited_response THEN
      CASE completed_request_p^.request.command [1].command_code OF
      = ioc$cc_read_bytes =
        disk_log_data_p^.logical_operation := ioc$log_read;
      = ioc$cc_write_bytes, ioc$cc_write_initialize =
        disk_log_data_p^.logical_operation := ioc$log_write;
      = ioc$cc_read_flaws =
        disk_log_data_p^.logical_operation := ioc$log_read_flaw_map;
      = ioc$cc_initialize_sectors =
        disk_log_data_p^.logical_operation := ioc$log_initialize_sectors;
      ELSE
        disk_log_data_p^.logical_operation := ioc$no_value;
      CASEND;
    ELSE
      disk_log_data_p^.logical_operation := ioc$no_value;
    IFEND;

{Determine physical unit, symptom code and MDD message.

    display_message := FALSE;
    msg := 'INDETERMINATE';
    CASE disk_type OF
    = ioc$dt_ms844_4x, ioc$dt_ms885_1x, ioc$dt_ms885_42 =
      disk_log_data_p^.physical_unit := disk_log_data_p^.equipment * 8 +
            physical_unit;
      disk_log_data_p^.equipment := 0;
      message_found := TRUE;
      IF pp_response_p^.abnormal_status.recording_medium_error THEN
        msg := 'MEDIA FAILURE';
        disk_log_data_p^.symptom_code := ioc$7155_media_error;
      ELSEIF disk_885_status_p^.general_status.confidence_cylinder_is_flawed THEN
        msg := 'CONFIDENCE CYLINDER IS FLAWED';
        disk_log_data_p^.symptom_code := ioc$conf_cylinder_is_flawed;
      ELSEIF (disk_885_status_p^.general_status.controller_reserved) OR
            (disk_885_status_p^.general_status.last_general_status = 2000(8)) THEN
        display_message := TRUE;
        msg := 'CONTROLLER RESERVED';
        disk_log_data_p^.symptom_code := ioc$controller_is_reserved;
      ELSEIF (disk_885_status_p^.general_status.unit_reserved) OR (disk_885_status_p^.
            general_status.last_general_status = 10(8)) THEN
        msg := 'UNIT RESERVED';
        disk_log_data_p^.symptom_code := ioc$unit_is_reserved;

      ELSEIF pp_response_p^.abnormal_status.interface_error THEN
        display_message := TRUE;
        msg := 'SOFTWARE FAILURE';
        disk_log_data_p^.symptom_code := ioc$7155_software_failure;
      ELSEIF pp_response_p^.abnormal_status.channel_error THEN
        msg := 'INPUT CHANNEL PARITY';
        disk_log_data_p^.symptom_code := ioc$input_channel_parity;
      ELSEIF pp_response_p^.abnormal_status.function_timeout THEN
        IF disk_885_status_p^.general_status.ram_parity_error THEN
          disk_log_data_p^.symptom_code := ioc$ram_parity;
          msg := 'CONTROLLER RAM PARITY';
        ELSE
          disk_log_data_p^.symptom_code := ioc$function_timeout;
          msg := 'FUNCTION TIMEOUT';
        IFEND;
      ELSEIF disk_885_status_p^.general_status.incomplete_sector_transfer THEN
        msg := 'INCOMPLETE SECTOR TRANSFER';
        disk_log_data_p^.symptom_code := ioc$incomplete_sector_transfer;
      ELSEIF pp_response_p^.abnormal_status.output_channel_parity THEN
        IF disk_885_status_p^.part3.channel_parity_error AND
              (cmv$logical_pp_table_p^ [pp].controller_info.controller_type <> cmc$ms7154_x) THEN
          msg := 'IOU OUTPUT PARITY';
          disk_log_data_p^.symptom_code := ioc$iou_output_parity;
        ELSE
          msg := 'INDETERMINATE OUTPUT PARITY';
          disk_log_data_p^.symptom_code := ioc$indeterminate_output_parity;
        IFEND;
      ELSEIF disk_885_status_p^.part3.channel_parity_error AND
            (cmv$logical_pp_table_p^ [pp].controller_info.controller_type <> cmc$ms7154_x)
            THEN
        msg := 'OUTPUT CHANNEL PARITY';
        disk_log_data_p^.symptom_code := ioc$output_channel_parity;
      ELSEIF disk_885_status_p^.part3.data_parity_error THEN
        msg := 'OUTPUT CHANNEL PARITY';
        disk_log_data_p^.symptom_code := ioc$output_channel_parity;

      ELSEIF disk_885_status_p^.general_status.host_if_integrity_error  THEN
        msg := 'PP - CONTROLLER DATA INTEGRITY';
        disk_log_data_p^.symptom_code := ioc$host_if_integrity_error;
      ELSEIF disk_885_status_p^.general_status.drive_if_integrity_error  THEN
        msg := 'PP - DRIVE DATA INTEGRITY';
        disk_log_data_p^.symptom_code := ioc$drive_if_integrity_error;


      ELSEIF disk_type = ioc$dt_ms844_4x THEN
        IF (disk_status_844_p^.status_844.unit_on_line = FALSE) AND
              disk_status_844_p^.general_status.detailed_status_present THEN
          msg := 'UNIT OFF LINE OR NOT CABLED';
          disk_log_data_p^.symptom_code :=
            ioc$unit_off_line_or_not_cabled;
        ELSEIF (disk_status_844_p^.status_844.unit_selected = FALSE) AND
              disk_status_844_p^.general_status.detailed_status_present THEN
          msg := 'DRIVE NOT SELECTED';
          disk_log_data_p^.symptom_code := ioc$drive_not_selected;
        ELSEIF (disk_status_844_p^.status_844.unit_ready = FALSE) AND
              disk_status_844_p^.general_status.detailed_status_present THEN
          msg := 'UNIT NOT READY';
          disk_log_data_p^.symptom_code := ioc$unit_not_ready;
        ELSEIF disk_status_844_p^.status_844.seek_error THEN
          msg := 'SEEK FAILURE';
          disk_log_data_p^.symptom_code := ioc$seek_failure;
        ELSEIF disk_status_844_p^.status_844.pack_unsafe THEN
          msg := 'UNIT FAILURE';
          disk_log_data_p^.symptom_code := ioc$unit_failure;
        ELSEIF disk_status_844_p^.status_844.track_flaw_bit AND
              (disk_status_844_p^.part1.address_checkword_error = FALSE) AND
              disk_status_844_p^.general_status.detailed_status_present THEN
          msg := 'FLAWED TRACK';
          disk_log_data_p^.symptom_code := ioc$flawed_track;
        ELSEIF disk_status_844_p^.status_844.sector_flaw_bit AND
              (disk_status_844_p^.part1.address_checkword_error = FALSE) THEN
          msg := 'FLAWED SECTOR';
          disk_log_data_p^.symptom_code := ioc$flawed_sector;
        ELSE
          message_found := FALSE;
        IFEND;


      ELSEIF disk_885_status_p^.part3.status_not_valid THEN
        msg := 'CONTROLLER - DRIVE INTERFACE ERROR';
        disk_log_data_p^.symptom_code := ioc$controller_drive_interface;
      ELSEIF (disk_885_status_p^.status_885.selected_and_reserved = FALSE) AND
            disk_885_status_p^.general_status.detailed_status_present THEN
        IF disk_885_status_p^.part3.lost_dsu_clock THEN
          msg := 'CHAN ENABLE SWITCH OFF OR UNIT NOT CABLED';
          disk_log_data_p^.symptom_code := ioc$ch_enable_off_or_not_cabled;
        ELSE
          msg := 'DRIVE NOT SELECTED';
          disk_log_data_p^.symptom_code := ioc$drive_not_selected;
        IFEND;
      ELSEIF ((disk_885_status_p^.status_885.start_switch_on = FALSE)
            OR (disk_885_status_p^.status_885.motor_at_speed = FALSE))
            AND disk_885_status_p^.status_885.selected_and_reserved
            AND (disk_885_status_p^.part3.status_not_valid = FALSE) THEN
        msg := 'UNIT NOT READY';
        disk_log_data_p^.symptom_code := ioc$unit_not_ready;
      ELSEIF (disk_885_status_p^.status_885.write_enable = FALSE)
            AND disk_885_status_p^.status_885.selected_and_reserved
            AND (disk_885_status_p^.part3.status_not_valid = FALSE)
            AND (disk_885_status_p^.part1.pp_command = 5) THEN
        msg := 'UNIT READ ONLY SWITCH ON';
        disk_log_data_p^.symptom_code := ioc$read_only_switch_on;
      ELSEIF disk_885_status_p^.status_885.drive_check_error OR
             disk_885_status_p^.status_885.read_write_error OR
             disk_885_status_p^.status_885.access_check THEN
        msg := 'UNIT FAILURE';
        disk_log_data_p^.symptom_code := ioc$unit_failure;
      ELSEIF (disk_885_status_p^.part1.pp_command = 1) AND
             (disk_885_status_p^.part3.word_address > 0) THEN
        msg := 'CONTROLLER - DRIVE INTERFACE ERROR';
        disk_log_data_p^.symptom_code := ioc$controller_drive_interface;
      ELSEIF disk_885_status_p^.status_885.track_flaw_bit AND
            (disk_885_status_p^.part1.address_checkword_error = FALSE) THEN
        msg := 'FLAWED TRACK';
        disk_log_data_p^.symptom_code := ioc$flawed_track;
      ELSE
        message_found := FALSE;
      IFEND;

      IF message_found = FALSE THEN
        IF disk_885_status_p^.part1.cylinder_number_error THEN
          msg := 'CYLINDER ADDRESS MISCOMPARE';
          disk_log_data_p^.symptom_code := ioc$cylinder_address_miscompare;
        ELSEIF disk_885_status_p^.part1.track_number_error THEN
          msg := 'TRACK ADDRESS MISCOMPARE';
          disk_log_data_p^.symptom_code := ioc$track_address_miscompare;
        ELSEIF disk_885_status_p^.part1.sector_number_error THEN
          msg := 'SECTOR ADDRESS MISCOMPARE';
          disk_log_data_p^.symptom_code := ioc$sector_address_miscompare;
        ELSEIF disk_885_status_p^.part1.address_error THEN
          msg := 'ADDRESS ERROR';
          disk_log_data_p^.symptom_code := ioc$address_error;
        ELSEIF disk_885_status_p^.part3.lost_control_word AND
              (cmv$logical_pp_table_p^ [pp].controller_info.controller_type <> cmc$ms7154_x) THEN
          msg := 'LOST CONTROL WORD';
          disk_log_data_p^.symptom_code := ioc$lost_control_word;
        ELSEIF disk_885_status_p^.part1.pp_command = ioc$seek_function THEN
          msg := 'SEEK FAILURE';
          disk_log_data_p^.symptom_code := ioc$seek_failure;
        ELSEIF (disk_885_status_p^.part1.address_checkword_error) OR
              ((disk_885_status_p^.part1.data_checkword_error) AND
              (disk_885_status_p^.part1.pp_command = 4)) THEN
          msg := 'ERROR IN CHECKWORD';
          disk_log_data_p^.symptom_code := ioc$checkword_error;
        ELSEIF disk_885_status_p^.part3.write_buffer_to_disk_error THEN
          msg := 'WRITE BUFFER TO DISK ERROR';
          disk_log_data_p^.symptom_code := ioc$write_buffer_to_disk_error;
        ELSEIF disk_885_status_p^.part3.processor_instruction_timeout THEN
          msg := 'PROCESSOR INSTRUCTION TIMEOUT';
          disk_log_data_p^.symptom_code := ioc$processor_instruction_timeo;
        ELSEIF disk_885_status_p^.part3.bm_register_parity_error THEN
          msg := 'BM REGISTER PARITY ERROR';
          disk_log_data_p^.symptom_code := ioc$bm_register_parity_error;
        ELSEIF disk_885_status_p^.part3.write_verify_error THEN
          msg := 'WRITE VERIFY ERROR';
          disk_log_data_p^.symptom_code := ioc$write_verify_error;
        ELSEIF disk_885_status_p^.general_status.controlware_load_attempted THEN
          msg := 'LOADING CONTROLWARE';
          disk_log_data_p^.symptom_code := ioc$loading_controlware;
          disk_log_data_p^.failure_severity := 3;
        ELSE
          disk_log_data_p^.symptom_code := ioc$indeterminate;
        IFEND;
      IFEND;


{Determine ISD symptom message.}

    = ioc$dt_ms834_2, ioc$dt_msfsd_2 =
      disk_log_data_p^.physical_unit := physical_unit;
      manual_intervention_code := isd_status_p^.detailed_status1.
            manual_intervention_code;
      level_i_diagnostic_code := isd_status_p^.detailed_status1.
            level_i_diagnostic_code;
      level_ii_diagnostic_code := isd_status_p^.detailed_status1.
            level_ii_diagnostic_code_1 * 10(16) + isd_status_p^.
            detailed_status1.level_ii_diagnostic_code_2;
      adapter_diagnostic_code := isd_status_p^.general_status.
            first_general_status - 5000(8);
      IF (adapter_diagnostic_code > 777(8)) OR (adapter_diagnostic_code < 0)
            THEN
        adapter_diagnostic_code := 0;
      IFEND;
      disk_log_data_p^.diagnostic_code := adapter_diagnostic_code;
      IF level_i_diagnostic_code > 0 THEN
        disk_log_data_p^.diagnostic_code := level_i_diagnostic_code;
      IFEND;
      IF level_ii_diagnostic_code > 0 THEN
        disk_log_data_p^.diagnostic_code := level_ii_diagnostic_code;
      IFEND;

      IF pp_response_p^.abnormal_status.recording_medium_error THEN
        msg := 'MEDIA FAILURE';
        disk_log_data_p^.symptom_code := ioc$media_failure;
      ELSEIF isd_status_p^.general_status.pp_timed_out_a_command THEN
        msg := 'PP TIMED OUT A COMMAND';
        disk_log_data_p^.symptom_code := ioc$pp_timed_out_a_command;
      ELSEIF isd_status_p^.general_status.adapter_controlware_error OR
            isd_status_p^.general_status.load_attention_delay_error OR
            isd_status_p^.general_status.bad_status_loading_controlware OR
            isd_status_p^.general_status.read_error OR isd_status_p^.
            general_status.input_channel_active OR isd_status_p^.
            general_status.output_channel_full THEN
        msg := 'ADAPTER CONTROLWARE ERROR';
        disk_log_data_p^.symptom_code := ioc$adapter_controlware_error;
      ELSEIF (isd_status_p^.general_status.controller_reserved) OR
            (isd_status_p^.general_status.last_general_status = 10(8)) THEN
        msg := 'CONTROL MODULE RESERVED';
        disk_log_data_p^.symptom_code := ioc$control_module_reserved;
      ELSEIF pp_response_p^.abnormal_status.interface_error THEN
        display_message := TRUE;
        msg := 'SOFTWARE FAILURE';
        disk_log_data_p^.symptom_code := ioc$isd_software_failure;
      ELSEIF isd_status_p^.general_status.power_up_spindle_started THEN
        CASE unrecovered_error OF
        = 1 =
          display_message := TRUE;
          msg := 'DRIVE NOT READY';
        = 2 =
          display_message := TRUE;
          msg := 'POWERING UP SPINDLE';
        ELSE
        CASEND;
        disk_log_data_p^.symptom_code := ioc$drive_not_ready;
      ELSEIF isd_status_p^.general_status.spindle_powered_up THEN
        display_message := TRUE;
        msg := 'SPINDLE POWERED UP';
        disk_log_data_p^.symptom_code := ioc$drive_not_ready;
        disk_log_data_p^.failure_severity := 3;
      ELSEIF isd_status_p^.general_status.control_module_reload_started AND
            ((unrecovered_error = 2) OR (pp_response_p^.response_code.
            primary_response = ioc$unsolicited_response) AND
            (unrecovered_error <> 1))  THEN
        msg := 'RELOADING CONTROL MODULE';
        disk_log_data_p^.symptom_code := ioc$reloading_control_module;
        disk_log_data_p^.failure_severity := 3;
      ELSEIF isd_status_p^.general_status.control_module_reload_completed THEN
        msg := 'CONTROL MODULE RELOADED';
        disk_log_data_p^.symptom_code := ioc$control_module_reloaded;
        disk_log_data_p^.failure_severity := 3;
      ELSEIF isd_status_p^.general_status.level_2_diagnostics_started
            AND ((unrecovered_error  = 2) OR (pp_response_p^.response_code.
            primary_response = ioc$unsolicited_response)) THEN
        display_message := TRUE;
        msg := 'EXECUTING LEVEL II DIAGNOSTICS';
        disk_log_data_p^.symptom_code := ioc$executing_level_ii;
        down_status := ioc$executing_diagnostics;
      ELSEIF isd_status_p^.general_status.level_2_diagnostics_passed THEN
        display_message := TRUE;
        msg := 'LEVEL II DIAGNOSTICS PASSED';
        disk_log_data_p^.symptom_code := ioc$level_ii_passed;
        disk_log_data_p^.failure_severity := 3;
      ELSEIF manual_intervention_code = 0c3(16) THEN
        msg := 'DRIVE NOT PRESENT';
        disk_log_data_p^.symptom_code := ioc$drive_not_present;
      ELSEIF isd_status_p^.general_status.media_failure OR
            isd_status_p^.general_status.unrecovered_media_error THEN
        msg := 'MEDIA FAILURE';
        disk_log_data_p^.symptom_code := ioc$media_failure;
      ELSEIF (isd_status_p^.general_status.first_general_status = 5002(8)) OR
            (isd_status_p^.general_status.first_general_status = 5013(8)) THEN
        msg := 'ADAPTER RAM PARITY';
        disk_log_data_p^.symptom_code := ioc$adapter_ram_parity;
      ELSEIF pp_response_p^.abnormal_status.function_timeout THEN
        IF pp_response_p^.abnormal_status.output_channel_parity THEN
          msg := 'FUNCTION FAILURE CLASS 2';
          disk_log_data_p^.symptom_code := ioc$function_failure_class_2;
        ELSE
          msg := 'FUNCTION FAILURE CLASS 3';
          disk_log_data_p^.symptom_code := ioc$function_failure_class_3;
        IFEND;
      ELSEIF pp_response_p^.abnormal_status.channel_error THEN
        msg := 'INPUT ICI PARITY';
        disk_log_data_p^.symptom_code := ioc$input_ici_parity;
      ELSEIF pp_response_p^.abnormal_status.output_channel_parity THEN
        IF isd_status_p^.detailed_status1.ici_parity_error THEN
          msg := 'OUTPUT ICI PARITY CLASS 1';
          disk_log_data_p^.symptom_code := ioc$output_ici_parity_class_1;
        ELSE
          msg := 'OUTPUT ICI PARITY CLASS 2';
          disk_log_data_p^.symptom_code := ioc$output_ici_parity_class_2;
        IFEND;
      ELSEIF isd_status_p^.detailed_status1.ici_parity_error THEN
        msg := 'OUTPUT ICI PARITY CLASS 3';
        disk_log_data_p^.symptom_code := ioc$output_ici_parity_class_3;
      ELSEIF isd_status_p^.detailed_status1.buffer_memory_parity_error THEN
        msg := 'ADAPTER BUFFER PARITY';
        disk_log_data_p^.symptom_code := ioc$adapter_buffer_parity;
      ELSEIF isd_status_p^.general_status.first_general_status = 5014(8) THEN
        msg := 'ADAPTER ROM PARITY';
        disk_log_data_p^.symptom_code := ioc$adapter_rom_parity;
      ELSEIF isd_status_p^.detailed_status1.level_i_diagnostic_code = 90(16) THEN
        msg := 'START SWITCH NOT DEPRESSED';
        disk_log_data_p^.symptom_code := ioc$start_switch_not_depressed;
      ELSEIF isd_status_p^.detailed_status1.isi_parity_error THEN
        IF manual_intervention_code = 63(16) THEN
          msg := 'OUTPUT ISI PARITY CLASS 1';
          disk_log_data_p^.symptom_code := ioc$output_isi_parity_class_1;
        ELSE
          msg := 'ISI PARITY';
          disk_log_data_p^.symptom_code := ioc$isi_parity;
        IFEND;
      ELSEIF manual_intervention_code = 63(16) THEN
        msg := 'OUTPUT ISI PARITY CLASS 3';
        disk_log_data_p^.symptom_code := ioc$output_isi_parity_class_3;
      ELSEIF isd_status_p^.detailed_status1.system_intervention_code = 21(16) THEN
        msg := 'SEEK ERROR';
        disk_log_data_p^.symptom_code := ioc$seek_error;
      ELSEIF isd_status_p^.general_status.host_if_integrity_error  THEN
        msg := 'PP - ADAPTER DATA INTEGRITY';
        disk_log_data_p^.symptom_code := ioc$i_host_if_integrity_error;
      ELSEIF isd_status_p^.general_status.drive_if_integrity_error  THEN
        msg := 'PP - DRIVE DATA INTEGRITY';
        disk_log_data_p^.symptom_code := ioc$i_drive_if_integrity_error;
      ELSEIF isd_status_p^.detailed_status1.system_intervention_code = 41(16) THEN
        msg := 'UNABLE TO READ HEADER';
        disk_log_data_p^.symptom_code := ioc$unable_to_read_header;
      ELSEIF isd_status_p^.detailed_status1.system_intervention_code = 43(16) THEN
        msg := 'UNABLE TO READ DATA';
        disk_log_data_p^.symptom_code := ioc$unable_to_read_data;
      ELSEIF isd_status_p^.detailed_status1.isi_deadman_time_out THEN
        msg := 'ISI DEADMAN TIME-OUT';
        disk_log_data_p^.symptom_code := ioc$isi_deadman_time_out;
      ELSEIF manual_intervention_code = 64(16) THEN
        msg := 'CM SCHEDULER PARITY';
        disk_log_data_p^.symptom_code := ioc$cm_scheduler_parity;
      ELSEIF manual_intervention_code = 65(16) THEN
        msg := 'CM MPU PARITY';
        disk_log_data_p^.symptom_code := ioc$cm_mpu_parity;
      ELSEIF manual_intervention_code = 66(16) THEN
        msg := 'CM R/W HARDWARE FAULT';
        disk_log_data_p^.symptom_code := ioc$cm_rw_hardware_fault;
      ELSEIF manual_intervention_code = 67(16) THEN
        msg := 'DRIVE VOLTAGE FAULT';
        disk_log_data_p^.symptom_code := ioc$drive_voltage_fault;
      ELSEIF manual_intervention_code = 68(16) THEN
        msg := 'OVER TEMPERATURE FAULT';
        disk_log_data_p^.symptom_code := ioc$over_temperature_fault;
      ELSEIF manual_intervention_code = 69(16) THEN
        msg := 'INVALID BOOTSTRAP ERROR';
        disk_log_data_p^.symptom_code := ioc$invalid_bootstrap_error;
      ELSEIF (manual_intervention_code = 0c2(16))
          OR (level_ii_diagnostic_code = 0dc(16))
          OR (level_ii_diagnostic_code = 0dd(16)) THEN
        msg := 'DRIVE WRITE PROTECTED';
        disk_log_data_p^.symptom_code := ioc$drive_write_protected;
      ELSEIF isd_status_p^.general_status.incomplete_sector_transfer THEN
        msg := 'INCOMPLETE ICI TRANSFER';
        disk_log_data_p^.symptom_code := ioc$incomplete_ici_transfer;
      ELSEIF isd_status_p^.detailed_status1.cm_failure THEN
        CASE isd_status_p^.detailed_status1.failure_code OF
        = 1 =
          msg := 'LOOPBACK COMPARE ERROR';
          disk_log_data_p^.symptom_code := ioc$loopback_compare_error;
        = 2 =
          msg := 'LOOPBACK SELECT ACTIVE';
          disk_log_data_p^.symptom_code := ioc$loopback_select_active;
        = 3 =
          msg := 'LOOPBACK ATTENTION';
          disk_log_data_p^.symptom_code := ioc$loopback_attention;
        = 4 =
          msg := 'LOOPBACK CHECK FAILURE';
          disk_log_data_p^.symptom_code := ioc$loopback_check_failure;
        ELSE
          msg := 'CONTROL MODULE FAILURE     ';
          disk_log_data_p^.symptom_code := ioc$isd_controller_failure;
          IF level_ii_diagnostic_code > 0 THEN
            iop$ascii_hex (^msg (26, * ), 2, level_ii_diagnostic_code);
            disk_log_data_p^.diagnostic_code := level_ii_diagnostic_code;
          ELSEIF level_i_diagnostic_code > 0 THEN
            iop$ascii_hex (^msg (26, * ), 2, level_i_diagnostic_code);
            disk_log_data_p^.diagnostic_code := level_i_diagnostic_code;
          IFEND;
        CASEND;
      ELSEIF isd_status_p^.detailed_status1.adapter_failure THEN
        msg := 'ADAPTER FAILURE      ';
        disk_log_data_p^.symptom_code := ioc$adapter_failure;
        IF adapter_diagnostic_code > 0 THEN
          iop$ascii_hex (^msg (19, * ), 3, adapter_diagnostic_code);
          disk_log_data_p^.diagnostic_code := adapter_diagnostic_code;
        IFEND;
      ELSEIF isd_status_p^.detailed_status1.drive_failure THEN
        msg := 'DRIVE FAILURE     ';
        disk_log_data_p^.symptom_code := ioc$drive_failure;
        IF level_ii_diagnostic_code > 0 THEN
          iop$ascii_hex (^msg (17, * ), 2, level_ii_diagnostic_code);
          disk_log_data_p^.diagnostic_code := level_ii_diagnostic_code;
        ELSEIF level_i_diagnostic_code > 0 THEN
          iop$ascii_hex (^msg (17, * ), 2, level_i_diagnostic_code);
          disk_log_data_p^.diagnostic_code := level_i_diagnostic_code;
        IFEND;
      ELSE
        disk_log_data_p^.symptom_code := ioc$isd_indeterminate;
      IFEND;

{  Process 895 disk errors }

    = ioc$dt_ms895_2 =
      disk_log_data_p^.physical_unit := physical_unit;
      disk_log_data_p^.diagnostic_code := 0;

      IF pp_response_p^.abnormal_status.recording_medium_error THEN
         msg := 'MEDIA FAILURE';
         disk_log_data_p^.symptom_code := ioc$895_media_failure;

      ELSEIF (disk_status_895_p^.general_status.first_general_status = 900(16)) AND
         (detailed_status_p <> NIL) AND
         (disk_status_895_p^.controller_status_1.ccc_status_byte_error) AND
         (disk_status_895_p^.controller_status_1.bit_6) AND
         (disk_status_895_p^.controller_status_1.bit_3) AND
         (disk_status_895_p^.controller_status_1.bit_1) THEN
        disk_log_data_p^.symptom_code := ioc$895_storage_director_retry;
        msg := 'STORAGE DIRECTOR RETRY';

      ELSEIF ((disk_status_895_p^.general_status.first_general_status = 0a10(16)) AND
             (detailed_status_p <> NIL))
             OR
             ((disk_status_895_p^.general_status.first_general_status = 900(16)) AND
             (detailed_status_p <> NIL) AND
             (disk_status_895_p^.controller_status_1.ccc_status_byte_error) AND
             (disk_status_895_p^.controller_status_1.bit_1))
             THEN
        format_message := disk_status_895_p^.detailed_status_1.format_code *16 +
                          disk_status_895_p^.detailed_status_1.message_code;
        IF (format_message = 0) OR
           (format_message = 10(16)) OR
           (format_message = 28(16)) OR
           (format_message = 80(16)) OR
           (disk_status_895_p^.detailed_status_1.format_code = 6) THEN
          IF disk_status_895_p^.detailed_status_1.command_reject THEN
            msg := 'COMMAND REJECT';
            disk_log_data_p^.symptom_code := ioc$895_command_reject;
          ELSEIF disk_status_895_p^.detailed_status_1.intervention_required THEN
            msg := 'INTERVENTION REQUIRED';
            disk_log_data_p^.symptom_code := ioc$895_intervention_req;
          ELSEIF disk_status_895_p^.detailed_status_1.bus_out_parity THEN
            msg := 'BUS OUT PARITY';
            disk_log_data_p^.symptom_code := ioc$895_bus_out_parity;
          ELSEIF disk_status_895_p^.detailed_status_1.equipment_check THEN
            msg := 'EQUIPMENT CHECK';
            disk_log_data_p^.symptom_code := ioc$895_equipment_check;
          ELSEIF disk_status_895_p^.detailed_status_1.data_check THEN
            msg := 'DATA CHECK';
            disk_log_data_p^.symptom_code := ioc$895_data_check;
          ELSEIF disk_status_895_p^.detailed_status_1.overrun THEN
            msg := 'OVERRUN';
            disk_log_data_p^.symptom_code := ioc$895_overrun;
          ELSEIF disk_status_895_p^.detailed_status_1.permanent_device_error THEN
            msg := 'PERMANENT DEVICE ERROR';
            disk_log_data_p^.symptom_code := ioc$895_permanent_device_error;
          ELSEIF disk_status_895_p^.detailed_status_1.end_of_cylinder THEN
            msg := 'END OF CYLINDER';
            disk_log_data_p^.symptom_code := ioc$895_end_of_cylinder;
          ELSEIF disk_status_895_p^.detailed_status_1.message_to_operator THEN
            msg := 'MESSAGE TO OPERATOR';
            disk_log_data_p^.symptom_code := ioc$895_message_to_operator;
          ELSEIF disk_status_895_p^.detailed_status_1.no_record_found THEN
            msg := 'NO RECORD FOUND';
            disk_log_data_p^.symptom_code := ioc$895_no_record_found;
          ELSEIF disk_status_895_p^.detailed_status_1.file_protected THEN
            msg := 'FILE PROTECTED';
            disk_log_data_p^.symptom_code := ioc$895_file_protected;
          ELSEIF disk_status_895_p^.detailed_status_1.first_logged_error THEN
            msg := 'FIRST LOGGED ERROR';
            disk_log_data_p^.symptom_code := ioc$895_first_logged_error;
          ELSEIF disk_status_895_p^.detailed_status_1.environmental_data_present THEN
            msg := 'ENVIRONMENTAL DATA';
            disk_log_data_p^.symptom_code := ioc$895_environmental_data;
          ELSEIF disk_status_895_p^.detailed_status_1.path_error THEN
            msg := 'PATH ERROR';
            disk_log_data_p^.symptom_code := ioc$895_path_error;
          ELSEIF disk_status_895_p^.detailed_status_1.invalid_track_format THEN
            msg := 'INVALID TRACK FORMAT';
            disk_log_data_p^.symptom_code := ioc$895_invalid_track_format;
          ELSE
            disk_log_data_p^.symptom_code := ioc$895_undocumented_sd_resp;
            msg := 'UNDOCUMENTED STORAGE DIRECTOR RESPONSE';
          IFEND;
        ELSE
          CASE disk_status_895_p^.detailed_status_1.format_code OF
          = 0 =
            CASE disk_status_895_p^.detailed_status_1.message_code OF
            = 1 =
              msg := 'INVALID COMMAND';
              disk_log_data_p^.symptom_code := ioc$895_invalid_command;
            = 2 =
              msg := 'INVALID COMMAND ISSUED TO 7165';
              disk_log_data_p^.symptom_code := ioc$895_invalid_command_to_7165;
            = 3 =
              msg := 'CCW COUNT TOO SMALL';
              disk_log_data_p^.symptom_code := ioc$895_ccw_count_too_small;
            = 4 =
              msg := 'INVALID DATA ARGUMENT';
              disk_log_data_p^.symptom_code := ioc$895_invalid_data_argument;
            = 6 =
              msg := 'CHAINING NOT INDICATED';
              disk_log_data_p^.symptom_code := ioc$895_chaining_not_indicated;
            = 7 =
              msg := 'COMMAND MISMATCH';
              disk_log_data_p^.symptom_code := ioc$895_command_mismatch;
            = 11 =
              msg := 'DEFECTIVE TRACK POINTER';
              disk_log_data_p^.symptom_code := ioc$895_defective_track_pointer;
            ELSE
              msg := 'UNDOCUMENTED FORMAT 0 MESSAGE';
              disk_log_data_p^.symptom_code := ioc$895_undocumented_format_msg;
            CASEND;
          = 1 =
            CASE disk_status_895_p^.detailed_status_1.message_code OF
            = 1 =
              msg := 'DEVICE STATUS 1 NOT EXPECTED';
              disk_log_data_p^.symptom_code := ioc$895_device_status_1_not_exp;
            = 3 =
              msg := 'INDEX MISSING';
              disk_log_data_p^.symptom_code := ioc$895_index_missing;
            = 4 =
              msg := 'UNRESETTABLE INTERRUPT';
              disk_log_data_p^.symptom_code := ioc$895_unresettable_interrupt;
            = 5 =
              msg := 'DEVICE DOES NOT RESPOND';
              disk_log_data_p^.symptom_code := ioc$895_device_does_not_respond;
            = 6 =
              msg := 'INCOMPLETE SET SECTOR';
              disk_log_data_p^.symptom_code := ioc$895_incomplete_set_sector;
            = 7 =
              msg := 'HEAD ADDRESS MISCOMPARE';
              disk_log_data_p^.symptom_code := ioc$895_head_address_miscompare;
            = 8 =
              msg := 'INVALID DEVICE STATUS 1';
              disk_log_data_p^.symptom_code := ioc$895_invalid_device_status_1;
            = 9 =
              msg := 'DEVICE NOT READY';
              disk_log_data_p^.symptom_code := ioc$895_device_not_ready;
            = 10 =
              msg := 'TRACK ADDRESS MISCOMPARE';
              disk_log_data_p^.symptom_code := ioc$895_track_addr_miscompare;
            = 12 =
              msg := 'DRIVE MOTOR OFF';
              disk_log_data_p^.symptom_code := ioc$895_drive_motor_off;
            = 13 =
              msg := 'SEEK INCOMPLETE';
              disk_log_data_p^.symptom_code := ioc$895_seek_incomplete;
            = 14 =
              msg := 'CYLINDER ADDRESS MISCOMPARE';
              disk_log_data_p^.symptom_code := ioc$895_cyl_addr_miscompare;
            = 15 =
              msg := 'UNRESETTABLE OFFSET ACTIVE';
              disk_log_data_p^.symptom_code := ioc$895_unresettable_offset;
            ELSE
              msg := 'UNDOCUMENTED FORMAT 1 MESSAGE';
              disk_log_data_p^.symptom_code := ioc$895_undocumented_format_msg;
              disk_log_data_p^.diagnostic_code := 1;
            CASEND;
          = 2 =
            CASE disk_status_895_p^.detailed_status_1.message_code OF
            = 9 =
              msg := 'SELECTIVE RESET WHILE SELECTED';
              disk_log_data_p^.symptom_code := ioc$895_selective_reset;
            = 10 =
              msg := 'SYNC LATCH FAILURE';
              disk_log_data_p^.symptom_code := ioc$895_sync_latch_failure;
            = 15 =
              msg := 'MICROCODE DETECTED CHECK';
              disk_log_data_p^.symptom_code := ioc$895_micro_detected_check;
            ELSE
              msg := 'UNDOCUMENTED FORMAT 2 MESSAGE';
              disk_log_data_p^.symptom_code := ioc$895_undocumented_format_msg;
              disk_log_data_p^.diagnostic_code := 2;
            CASEND;
          = 3 =
            CASE disk_status_895_p^.detailed_status_1.message_code OF
            = 8 =
              msg := 'CLOCK STOPPED CHECK 1';
              disk_log_data_p^.symptom_code := ioc$895_clock_stopped_check_1;
            = 9, 11, 12, 13, 14, 15 =
              msg := 'ALTERNATE STORAGE DIRECTOR FAILURE';
              disk_log_data_p^.symptom_code := ioc$895_alternate_sd_failure;
            ELSE
              msg := 'UNDOCUMENTED FORMAT 3 MESSAGE';
              disk_log_data_p^.symptom_code := ioc$895_undocumented_format_msg;
              disk_log_data_p^.diagnostic_code := 3;
            CASEND;
          = 4 =
            CASE disk_status_895_p^.detailed_status_1.message_code OF
            = 0, 1, 2, 3, 8, 9, 10, 11 =
              msg := 'ERROR UNCORRECTABLE BY ECC';
              disk_log_data_p^.symptom_code := ioc$895_error_uncorr_by_ecc;
            = 4, 5, 6, 7, 12, 13, 14, 15 =
              msg := 'DATA SYNCHRONIZATION UNSUCCESSFUL';
              disk_log_data_p^.symptom_code := ioc$895_data_sync_unsuccessful;
            ELSE
              msg := 'UNDOCUMENTED FORMAT 4 MESSAGE';
              disk_log_data_p^.symptom_code := ioc$895_undocumented_format_msg;
              disk_log_data_p^.diagnostic_code := 4;
            CASEND;
          = 5 =
            CASE disk_status_895_p^.detailed_status_1.message_code OF
            = 0, 1, 2, 3, 8, 9, 10, 11 =
              msg := 'ERROR CORRECTABLE BY ECC';
              disk_log_data_p^.symptom_code := ioc$895_error_corrected_by_ecc;
            ELSE
              msg := 'UNDOCUMENTED FORMAT 5 MESSAGE';
              disk_log_data_p^.symptom_code := ioc$895_undocumented_format_msg;
              disk_log_data_p^.diagnostic_code := 5;
            CASEND;
          = 7 =
            CASE disk_status_895_p^.detailed_status_1.message_code OF
            = 0 =
              msg := 'RCC INITIATED BY CCA';
              disk_log_data_p^.symptom_code := ioc$895_rcc_initiated_by_cca;
            = 1 =
              msg := 'RCC1 NOT SUCCESSFUL';
              disk_log_data_p^.symptom_code := ioc$895_rcc1_not_successful;
            = 2 =
              msg := 'RCC1 AND RCC2 NOT SUCCESSFUL';
              disk_log_data_p^.symptom_code := ioc$895_rcc1_rcc2_unsuccessful;
            = 3 =
              msg := 'INVALID DDC TAG SEQUENCE';
              disk_log_data_p^.symptom_code := ioc$895_invalid_ddc_tag_seq;
            = 4 =
              msg := 'EXTRA RCC REQUIRED';
              disk_log_data_p^.symptom_code := ioc$895_extra_rcc_required;
            = 5 =
              msg := 'INVALID DDC SELECTION';
              disk_log_data_p^.symptom_code := ioc$895_invalid_ddc_selection;
            = 6, 7 =
              msg := 'MISSING END OP';
              disk_log_data_p^.symptom_code := ioc$895_missing_end_op;
            = 8, 9 =
              msg := 'INVALID TAG';
              disk_log_data_p^.symptom_code := ioc$895_invalid_tag;
            = 10 =
              msg := 'DESELECTION';
              disk_log_data_p^.symptom_code := ioc$895_deselection;
            = 11 =
              msg := 'NO CONTROLLER RESPONSE';
              disk_log_data_p^.symptom_code := ioc$895_no_controller_response;
            = 12, 13 =
              msg := 'CONTROLLER NOT AVAILABLE';
              disk_log_data_p^.symptom_code := ioc$895_controller_unavailable;
            ELSE
              msg := 'UNDOCUMENTED FORMAT 7 MESSAGE';
              disk_log_data_p^.symptom_code := ioc$895_undocumented_format_msg;
              disk_log_data_p^.diagnostic_code := 7;
            CASEND;
          = 8 =
            CASE disk_status_895_p^.detailed_status_1.message_code OF
            = 1 =
              msg := 'ECC HARDWARE FAILURE';
              disk_log_data_p^.symptom_code := ioc$895_ecc_hardware_failure;
            = 3 =
              msg := 'UNEXPECTED END OP';
              disk_log_data_p^.symptom_code := ioc$895_unexpected_end_op;
            = 4, 5 =
              msg := 'END OP ACTIVE';
              disk_log_data_p^.symptom_code := ioc$895_end_op_active;
            ELSE
              msg := 'UNDOCUMENTED FORMAT 8 MESSAGE';
              disk_log_data_p^.symptom_code := ioc$895_undocumented_format_msg;
              disk_log_data_p^.diagnostic_code := 8;
            CASEND;
          ELSE
            msg := 'UNDOCUMENTED FORMAT x MESSAGE';
            disk_log_data_p^.symptom_code := ioc$895_undocumented_format_msg;
            disk_log_data_p^.diagnostic_code := disk_status_895_p^.detailed_status_1.
                     format_code;
            iop$ascii_hex (^msg (21), 1, disk_log_data_p^.diagnostic_code);
          CASEND;
        IFEND;

      ELSEIF (disk_status_895_p^.general_status.first_general_status = 0a00(16)) AND
              (detailed_status_p <> NIL) THEN
        IF (disk_status_895_p^.controller_status_1.controlware_detected_error) AND
           (disk_status_895_p^.controller_status_1.bit_4) THEN
          msg := 'REQUEST IN NOT RECEIVED DURING COMMAND RETRY';
          disk_log_data_p^.symptom_code := ioc$895_no_request_in_cmd;
        ELSEIF (disk_status_895_p^.controller_status_1.controlware_detected_error) AND
               (disk_status_895_p^.controller_status_1.bit_3) THEN
          msg := 'ILLEGAL WRITE';
          disk_log_data_p^.symptom_code := ioc$895_illegal_write;
        ELSEIF (disk_status_895_p^.controller_status_1.controlware_detected_error) AND
               ((disk_status_895_p^.controller_status_1.bit_2) OR
               (disk_status_895_p^.controller_status_1.bit_1)) THEN
          msg := 'CCC-STORAGE DIRECTOR INTERFACE ERROR';
          disk_log_data_p^.symptom_code := ioc$895_fips_error;
        ELSEIF (disk_status_895_p^.controller_status_1.controlware_detected_error) AND
               (disk_status_895_p^.controller_status_1.bit_0) THEN
          msg := 'FULL/EMPTY COUNT INCORRECT';
          disk_log_data_p^.symptom_code := ioc$895_full_empty_count;
        ELSEIF (disk_status_895_p^.controller_status_1.fsc_sequence_error) AND
               (disk_status_895_p^.controller_status_1.bit_2) THEN
          msg := 'ADDRESS MISCOMPARE ON SELECT SEQUENCE';
          disk_log_data_p^.symptom_code := ioc$895_address_miscompare;
        ELSEIF (disk_status_895_p^.controller_status_1.fsc_sequence_error) AND
               (disk_status_895_p^.controller_status_1.bit_1) THEN
          msg := 'NO REQUEST IN ON POLLING SEQUENCE';
          disk_log_data_p^.symptom_code := ioc$895_no_request_in_poll;
        ELSEIF (disk_status_895_p^.controller_status_1.fsc_sequence_error) AND
               (disk_status_895_p^.controller_status_1.bit_0) THEN
          msg := 'SELECT IN RECEIVED ON SELECT SEQUENCE';
          disk_log_data_p^.symptom_code := ioc$895_select_in_received;
        ELSEIF (disk_status_895_p^.controller_status_1.parity_error) AND
               (disk_status_895_p^.controller_status_1.bit_3) THEN
          msg := 'BUS IN PARITY ERROR';
          disk_log_data_p^.symptom_code := ioc$895_bus_in_parity;
        ELSEIF (disk_status_895_p^.controller_status_1.parity_error) AND
               (disk_status_895_p^.controller_status_1.bit_2) THEN
          msg := 'READ PATH PARITY ERROR';
          disk_log_data_p^.symptom_code := ioc$895_read_path_parity;
        ELSEIF (disk_status_895_p^.controller_status_1.parity_error) AND
               (disk_status_895_p^.controller_status_1.bit_0) THEN
          msg := 'WRITE PATH PARITY ERROR';
          disk_log_data_p^.symptom_code := ioc$895_write_path_parity;
        ELSEIF (disk_status_895_p^.controller_status_1.normal_end) AND
               (disk_status_895_p^.controller_status_1.transfer_indicator) THEN
          msg := 'INCOMPLETE DATA TRANSFER';
          disk_log_data_p^.symptom_code := ioc$895_incomplete_transfer;
        ELSEIF disk_status_895_p^.controller_status_1.channel_parity THEN
          msg := 'CHANNEL PARITY DURING PP OUTPUT';
          disk_log_data_p^.symptom_code := ioc$895_output_chan_parity;
        ELSEIF disk_status_895_p^.controller_status_1.memory_parity THEN
          msg := 'COUPLER MEMORY PARITY ERROR DURING PP INPUT';
          disk_log_data_p^.symptom_code := ioc$895_parity_err_on_input;
        ELSEIF disk_status_895_p^.controller_status_1.deadman_timeout THEN
          msg := 'DEADMAN TIMEOUT STATUS';
          disk_log_data_p^.symptom_code := ioc$895_deadman_timeout;
        ELSEIF (disk_status_895_p^.controller_status_1.coupler_memory_parity) OR
               ((disk_status_895_p^.controller_status_1.parity_error) AND
               (disk_status_895_p^.controller_status_1.bit_1)) THEN
          msg := 'COUPLER MEMORY PARITY ERROR';
          disk_log_data_p^.symptom_code := ioc$895_memory_parity;
        ELSEIF disk_status_895_p^.controller_status_1.transfer_indicator THEN
          msg := 'EXCESS DATA TRANSFERRED';
          disk_log_data_p^.symptom_code := ioc$895_excess_data_xfered;
        ELSEIF disk_status_895_p^.controller_status_1.character_fill THEN
          msg := 'DATA PACKING FOR CHANNEL DID NOT COME OUT EVEN';
          disk_log_data_p^.symptom_code := ioc$895_data_packing_wrong;
        ELSEIF NOT disk_status_895_p^.controller_status_1.normal_end THEN
          msg := 'NORMAL END NOT SET';
          disk_log_data_p^.symptom_code := ioc$895_normal_end_not_set;
        ELSE
          disk_log_data_p^.symptom_code := ioc$895_indeterminate;
        IFEND;
      ELSE
        IF pp_response_p^.abnormal_status.function_timeout THEN
          msg := 'FUNCTION TIMEOUT';
          disk_log_data_p^.symptom_code := ioc$895_function_timeout;
        ELSEIF disk_status_895_p^.general_status.soft_sectoring_started THEN
          display_message := TRUE;
          disk_log_data_p^.failure_severity := 3;
          msg := 'SOFT SECTORING UNIT';
          disk_log_data_p^.symptom_code := ioc$895_soft_sectoring;
        ELSEIF disk_status_895_p^.general_status.soft_sectoring_complete THEN
          display_message := TRUE;
          disk_log_data_p^.failure_severity := 3;
          msg := 'UNIT SOFT SECTORED';
          disk_log_data_p^.symptom_code := ioc$895_unit_soft_sectored;
        ELSEIF disk_status_895_p^.error_code = 1 THEN
          display_message := TRUE;
          msg :='INTERFACE ERROR';
          disk_log_data_p^.symptom_code := ioc$895_interface_error;
        ELSEIF disk_status_895_p^.error_code = 2 THEN
          msg :='KZ BOARD ERROR';
          disk_log_data_p^.symptom_code := ioc$895_kz_board_error;
        ELSEIF disk_status_895_p^.error_code = 3 THEN
          msg :='KX BOARD ERROR';
          disk_log_data_p^.symptom_code := ioc$895_kx_board_error;
        ELSEIF disk_status_895_p^.error_code = 4 THEN
          msg :='CHANNEL ERROR';
          disk_log_data_p^.symptom_code := ioc$895_channel_error;
        ELSEIF disk_status_895_p^.error_code = 5 THEN
          msg :='INCOMPLETE CHANNEL TRANSFER';
          disk_log_data_p^.symptom_code := ioc$895_incomplete_chan_xfer;
        ELSEIF disk_status_895_p^.error_code = 9 THEN
          msg :='CCC FAILURE';
          disk_log_data_p^.symptom_code := ioc$895_ccc_failure;
        ELSEIF disk_status_895_p^.error_code = 6 THEN
          msg :='PP-CCC DATA INTEGRITY';
          disk_log_data_p^.symptom_code := ioc$895_pp_ccc_data_integrity;
        ELSEIF disk_status_895_p^.error_code = 7 THEN
          msg :='PP-DRIVE DATA INTEGRITY';
          disk_log_data_p^.symptom_code := ioc$895_pp_drive_data_integrity;
        ELSEIF disk_status_895_p^.error_code = 8 THEN
          msg :='SEEK COMMAND TIMEOUT';
          disk_log_data_p^.symptom_code := ioc$895_seek_command_timeout;
        ELSEIF disk_status_895_p^.error_code = 12 THEN
          msg :='UNCORRECTED CM ERROR';
          disk_log_data_p^.symptom_code := ioc$895_uncorrected_cm_error;
        ELSEIF disk_status_895_p^.error_code = 13 THEN
          msg :='CM REJECT';
          disk_log_data_p^.symptom_code := ioc$895_cm_reject;
        ELSEIF disk_status_895_p^.error_code = 14 THEN
          msg :='INVALID CM RESPONSE';
          disk_log_data_p^.symptom_code := ioc$895_invalid_cm_response;
        ELSEIF disk_status_895_p^.error_code = 15 THEN
          msg :='CM RESPONSE CODE PARITY ERROR';
          disk_log_data_p^.symptom_code := ioc$895_cm_response_pe;
        ELSEIF disk_status_895_p^.error_code = 16 THEN
          msg :='CMI READ DATA PARITY ERROR';
          disk_log_data_p^.symptom_code := ioc$895_cmi_read_pe;
        ELSEIF disk_status_895_p^.error_code = 17 THEN
          msg :='OVERFLOW ERROR';
          disk_log_data_p^.symptom_code := ioc$895_overflow_error;
        ELSEIF disk_status_895_p^.error_code = 18 THEN
          msg :='JY BOARD ERROR';
          disk_log_data_p^.symptom_code := ioc$895_jy_board_error;
        ELSEIF disk_status_895_p^.error_code = 10 THEN
          msg :='IOU FAILURE - OPERATIONAL STATUS WRONG';
          disk_log_data_p^.symptom_code := ioc$895_iou_failure_st_err;
        ELSEIF disk_status_895_p^.error_code = 11 THEN
          msg :='IOU FAILURE - TEST MODE FAILURE';
          disk_log_data_p^.symptom_code := ioc$895_iou_failure_data_err;
        ELSEIF disk_status_895_p^.error_code = 19 THEN
          msg :='TRANSFER IN PROGRESS DID NOT CLEAR';
          disk_log_data_p^.symptom_code := ioc$895_tip_not_clear;
        ELSEIF disk_status_895_p^.error_code = 20 THEN
          msg :='T PRIME REGISTER NOT EMPTY';
          disk_log_data_p^.symptom_code := ioc$895_t_reg_not_empty;
        ELSE
          disk_log_data_p^.symptom_code := ioc$895_indeterminate;
        IFEND;
      IFEND;

{Determine Hydra symptom message.}

    = ioc$dt_mshydra =
      disk_log_data_p^.physical_unit := physical_unit;
      IF hydra_status_p^.cm_status1.manual_intervention_code_valid THEN
        manual_intervention_code := hydra_status_p^.cm_status1.manual_intervention_code;
      ELSE
        manual_intervention_code := 0;
      IFEND;
      IF hydra_status_p^.cm_status1.system_intervention_code_valid THEN
        system_intervention_code := hydra_status_p^.cm_status1.system_intervention_code;
      ELSE
        system_intervention_code := 0;
      IFEND;
      IF hydra_status_p^.cm_status1.delay_status_valid THEN
        delay_status_code := hydra_status_p^.cm_status1.delay_code;
      ELSE
        delay_status_code := 0;
      IFEND;
      IF hydra_status_p^.cm_status2.manual_intervention_code_valid THEN
        manual_intervention_code := hydra_status_p^.cm_status2.manual_intervention_code;
      ELSE
        manual_intervention_code := 0;
      IFEND;
      IF hydra_status_p^.cm_status2.system_intervention_code_valid THEN
        system_intervention_code := hydra_status_p^.cm_status2.system_intervention_code;
      ELSE
        system_intervention_code := 0;
      IFEND;
      IF hydra_status_p^.cm_status2.delay_status_valid THEN
        delay_status_code := hydra_status_p^.cm_status2.delay_code;
      ELSE
        delay_status_code := 0;
      IFEND;
      cell_p := ^hydra_status_p^.general_status.first_general_status;
      error_status_p := cell_p;

      IF hydra_status_p^.general_status.level_2_diagnostics_started
             AND ((unrecovered_error = 2) OR (pp_response_p^.response_code.
             primary_response = ioc$unsolicited_response)) THEN
        display_message := TRUE;
        msg := 'EXECUTING LEVEL II DIAGNOSTICS';
        disk_log_data_p^.symptom_code := ioc$h_exec_level_ii_diagnostics;
        down_status := ioc$executing_diagnostics;
      ELSEIF hydra_status_p^.general_status.level_2_diagnostics_passed THEN
        display_message := TRUE;
        msg := 'LEVEL II DIAGNOSTICS PASSED';
        disk_log_data_p^.symptom_code := ioc$h_lev_ii_diagnostics_passed;
        disk_log_data_p^.failure_severity := 3;
      ELSEIF hydra_status_p^.general_status.level_1_diagnostics_started
             AND ((unrecovered_error = 2) OR (pp_response_p^.response_code.
             primary_response = ioc$unsolicited_response)) THEN
        display_message := TRUE;
        msg := 'EXECUTING LEVEL I DIAGNOSTICS';
        disk_log_data_p^.symptom_code := ioc$h_exec_level_i_diagnostics;
        down_status := ioc$executing_diagnostics;
      ELSEIF hydra_status_p^.general_status.level_1_diagnostics_passed THEN
        display_message := TRUE;
        msg := 'LEVEL I DIAGNOSTICS PASSED';
        disk_log_data_p^.symptom_code := ioc$h_lev_i_diagnostics_passed;
        disk_log_data_p^.failure_severity := 3;
      ELSEIF hydra_status_p^.general_status.spindle_powered_up THEN
        display_message := TRUE;
        msg := 'SPINDLE POWERED UP';
        disk_log_data_p^.symptom_code := ioc$h_spindle_powered_up;
        disk_log_data_p^.failure_severity := 3;
      ELSEIF hydra_status_p^.general_status.sector_size_not_4096 THEN
        display_message := TRUE;
        msg := 'SECTOR SIZE IS NOT 4096';
        disk_log_data_p^.symptom_code := ioc$h_sector_size_not_4096;
      ELSEIF hydra_status_p^.general_status.not_same_host_id THEN
        display_message := TRUE;
        msg := 'HOST IDS ARE DIFFERENT';
        disk_log_data_p^.symptom_code := ioc$h_not_same_host_id;
      ELSEIF pp_response_p^.abnormal_status.recording_medium_error THEN
        msg := 'MEDIA FAILURE';
        disk_log_data_p^.symptom_code := ioc$h_media_failure;
      ELSEIF pp_response_p^.abnormal_status.function_timeout THEN
        msg := 'FUNCTION TIMEOUT';
        disk_log_data_p^.symptom_code := ioc$h_function_timeout;
      ELSEIF hydra_status_p^.general_status.output_channel_full THEN
        msg := 'CHANNEL DOESNT GO EMPTY';
        disk_log_data_p^.symptom_code := ioc$h_channel_doesnt_go_empty;
      ELSEIF hydra_status_p^.general_status.incomplete_sector_transfer THEN
        msg := 'INCOMPLETE I4 TRANSFER';
        disk_log_data_p^.symptom_code := ioc$h_incomplete_i4_transfer;
      ELSEIF hydra_status_p^.general_status.channel_initialization_error THEN
        msg := 'CHANNEL INITIALIZATION ERROR';
        disk_log_data_p^.symptom_code := ioc$h_channel_init_error;
      ELSEIF hydra_status_p^.general_status.cannot_select_controller THEN
        msg := 'CANNOT SELECT THE CONTROLLER';
        disk_log_data_p^.symptom_code := ioc$h_cannot_select_controller;
      ELSEIF hydra_status_p^.general_status.incorrect_controller_selected THEN
        msg := 'INCORRECT CONTROLLER WAS SELECTED';
        disk_log_data_p^.symptom_code := ioc$h_incorrect_controller;
      ELSEIF hydra_status_p^.general_status.pp_timed_out_a_command THEN
        msg := 'PP TIMED OUT A COMMAND';
        disk_log_data_p^.symptom_code := ioc$h_pp_timed_out_a_command;
      ELSEIF hydra_status_p^.general_status.controller_reserved THEN
        msg := 'CONTROLLER RESERVED';
        disk_log_data_p^.symptom_code := ioc$h_controller_reserved;
      ELSEIF pp_response_p^.abnormal_status.interface_error THEN
        display_message := TRUE;
        msg := 'SOFTWARE FAILURE';
        disk_log_data_p^.symptom_code := ioc$h_software_failure;
      ELSEIF manual_intervention_code = 0C1(16) THEN
        msg := 'DRIVE NOT READY - MIC1';
        disk_log_data_p^.symptom_code := ioc$h_drive_not_ready;
      ELSEIF error_status_p^.uncorrected_cm_error THEN
        msg := 'UNCORRECTED CM ERROR';
        disk_log_data_p^.symptom_code := ioc$h_uncorrected_cm_error;
      ELSEIF error_status_p^.cm_reject THEN
        msg := 'CM REJECT';
        disk_log_data_p^.symptom_code := ioc$h_cm_reject;
      ELSEIF error_status_p^.invalid_cm_response THEN
        msg := 'INVALID CM RESPONSE CODE';
        disk_log_data_p^.symptom_code := ioc$h_invalid_response_code;
      ELSEIF error_status_p^.response_code_parity_error THEN
        msg := 'CM RESPONSE CODE PARITY ERROR';
        disk_log_data_p^.symptom_code := ioc$h_cm_response_code_pe;
      ELSEIF error_status_p^.cmi_read_data_parity_error THEN
        msg := 'CMI READ DATA PARITY ERROR';
        disk_log_data_p^.symptom_code := ioc$h_cmi_read_data_pe;
      ELSEIF error_status_p^.overflow_error THEN
        msg := 'INPUT BUFFER OVERFLOW';
        disk_log_data_p^.symptom_code := ioc$h_input_buffer_overflow;
      ELSEIF error_status_p^.jp_jy_data_error THEN
        msg := 'JP/JY DATA PARITY ERROR';
        disk_log_data_p^.symptom_code := ioc$h_jp_jy_data_parity_error;
      ELSEIF error_status_p^.bas_parity_error THEN
        msg := 'BAS PARITY ERROR';
        disk_log_data_p^.symptom_code := ioc$h_bas_parity_error;
      ELSEIF error_status_p^.jz_error THEN
        IF manual_intervention_code = 63(16) THEN
          msg := 'OUTPUT ISI PARITY ERROR';
          disk_log_data_p^.symptom_code := ioc$h_output_isi_parity;
        ELSE
          msg := 'JZ ERROR';
          disk_log_data_p^.symptom_code := ioc$h_jz_error;
        IFEND;
      ELSEIF error_status_p^.jp_jy_error THEN
        msg := 'JP/JY ERROR';
        disk_log_data_p^.symptom_code := ioc$h_jp_jy_error;
      ELSEIF error_status_p^.jn_jx_error THEN
        msg := 'JN/JX ERROR';
        disk_log_data_p^.symptom_code := ioc$h_jn_jx_error;
      ELSEIF hydra_status_p^.general_status.timeout_tip_or_t_reg_not_empty THEN
        msg := 'INCOMPLETE DMA TRANSFER';
        disk_log_data_p^.symptom_code := ioc$h_incomplete_dma_transfer;
      ELSEIF hydra_status_p^.general_status.timeout_t_register_byte_count THEN
        msg := 'T REGISTER BYTE COUNT NONZERO';
        disk_log_data_p^.symptom_code := ioc$h_t_register_byte_count;
      ELSEIF hydra_status_p^.general_status.invalid_execution_status THEN
        msg := 'INVALID CONTROLLER STATUS';
        disk_log_data_p^.symptom_code := ioc$h_invalid_controller_status;
      ELSEIF hydra_status_p^.general_status.adapter_controlware_error THEN
        msg := 'CONTROLLER INTERFACE ERROR';
        disk_log_data_p^.symptom_code := ioc$h_controller_interface_err;
      ELSE
        CASE system_intervention_code OF
        = 21(16) =
          msg := 'SEEK ERROR - SI21';
          disk_log_data_p^.symptom_code := ioc$h_seek_error;
        = 41(16) =
          msg := 'UNABLE TO READ HEADER - SI41';
          disk_log_data_p^.symptom_code := ioc$h_unable_to_read_header;
        = 42(16) =
          msg := 'HEADER MISCOMPARE - SI42';
          disk_log_data_p^.symptom_code := ioc$h_header_miscompare;
        = 43(16) =
          msg := 'UNABLE TO READ DATA - SI43';
          disk_log_data_p^.symptom_code := ioc$h_unable_to_read_data;
        = 68(16) =
          msg := 'TRANSFER COUNT ERROR - SI68';
          disk_log_data_p^.symptom_code := ioc$h_transfer_count_error;
        = 82(16) =
          msg := 'DISK NOT FORMATTED - SI82';
          disk_log_data_p^.symptom_code := ioc$h_disk_not_formatted;
        = 0A6(16) =
          msg := 'DIAGNOSTIC FAULT DETECTED - SIA6';
          disk_log_data_p^.symptom_code := ioc$h_diagnostic_fault_detected;
        = 0C1(16) =
          msg := 'COMMAND BLOCK NEGATED - SIC1';
          disk_log_data_p^.symptom_code := ioc$h_command_block_negated;
        ELSE
          CASE manual_intervention_code OF
          = 21(16) =
            msg := 'COMMAND BLOCK OVERWRITE - MI21';
            disk_log_data_p^.symptom_code := ioc$h_command_block_overwrite;
          = 22(16) =
            msg := 'ILLEGAL COMMAND BYTE - MI22';
            disk_log_data_p^.symptom_code := ioc$h_illegal_command_byte;
          = 23(16) =
            msg := 'ILLEGAL SECONDARY SEEK ADDRESS - MI23';
            disk_log_data_p^.symptom_code := ioc$h_illegal_sec_seek_address;
          = 24(16) =
            msg := 'ILLEGAL PRIMARY SEEK ADDRESS - MI24';
            disk_log_data_p^.symptom_code := ioc$h_illegal_pri_seek_address;
          = 25(16) =
            msg := 'ILLEGAL COMMAND PARAMETER - MI25';
            disk_log_data_p^.symptom_code := ioc$h_illegal_command_parameter;
          = 27(16) =
            msg := 'I/O ILLEGAL WRITE ERROR - MI27';
            disk_log_data_p^.symptom_code := ioc$h_io_illegal_write_error;
          = 28(16) =
            msg := 'END OF DISK REACHED - MI28';
            disk_log_data_p^.symptom_code := ioc$h_end_of_disk_reached;
          = 29(16) =
            msg := 'ILLEGAL DEVICE NUMBER - MI29';
            disk_log_data_p^.symptom_code := ioc$h_illegal_device_number;
          = 2A(16) =
            msg := 'ILLEGAL CONTROL FIELD - MI2A';
            disk_log_data_p^.symptom_code := ioc$h_illegal_control_field;
          = 41(16) =
            msg := 'I/O ILLEGAL DISCONNECT - MI41';
            disk_log_data_p^.symptom_code := ioc$h_io_illegal_disconnect;
          = 63(16) =
            msg := 'ISI I/O PARITY ERROR - MI63';
            disk_log_data_p^.symptom_code := ioc$h_isi_io_parity_error;
          = 64(16) =
            msg := 'R/W SEQUENCER RAM PARITY ERROR - MI64';
            disk_log_data_p^.symptom_code := ioc$h_rw_sequencer_ram_parity;
          = 65(16) =
            msg := 'MPU PARITY ERROR - MI65';
            disk_log_data_p^.symptom_code := ioc$h_mpu_parity_error;
          = 66(16) =
            msg := 'ECC FAULT - MI66';
            disk_log_data_p^.symptom_code := ioc$h_ecc_fault;
          = 67(16) =
            msg := 'VOLTAGE FAULT - MI67';
            disk_log_data_p^.symptom_code := ioc$h_voltage_fault;
          = 68(16) =
            msg := 'WRITE TRANSFER COUNT ERROR - MI68';
            disk_log_data_p^.symptom_code := ioc$h_write_transfer_count;
          = 6A(16) =
            msg := 'DIAGNOSTIC FAULT DETECTED - MI6A';
            disk_log_data_p^.symptom_code := ioc$h_diagnostic_fault_detected;
          = 6B(16) =
            msg := 'OVER TEMPERATURE FAULT - MI6B';
            disk_log_data_p^.symptom_code := ioc$h_over_temperature_fault;
          = 6C(16) =
            msg := 'NO READ/WRITE SEQUENCER RESPONSE - MI6C';
            disk_log_data_p^.symptom_code := ioc$h_no_rw_sequencer_response;
          = 6D(16) =
            msg := 'INVALID READ/WRITE SEQUENCER RESPONSE - MI6D';
            disk_log_data_p^.symptom_code := ioc$h_invalid_rw_sequencer_rsp;
          = 6E(16) =
            msg := 'READ/WRITE SEQUENCER STATUS OVERWRITE - MI6E';
            disk_log_data_p^.symptom_code := ioc$h_rw_sequencer_status_overw;
          = 6F(16) =
            msg := 'HYDRA HARDWARE FAULT - MI6F';
            disk_log_data_p^.symptom_code := ioc$h_hydra_hardware_fault;
          = 70(16) =
            msg := 'READ/WRITE SEQUENCER FAULT - MI70';
            disk_log_data_p^.symptom_code := ioc$h_rw_sequencer_fault;
          = 71(16) =
            msg := 'ZEROFILL TIMEOUT - MI71';
            disk_log_data_p^.symptom_code := ioc$h_zerofill_timeout;
          = 72(16) =
            msg := 'FUNCTION BUFFER PARITY ERROR - MI72';
            disk_log_data_p^.symptom_code := ioc$h_function_buffer_pe;
          = 73(16) =
            msg := 'PARTIAL SECTOR ERROR - MI73';
            disk_log_data_p^.symptom_code := ioc$h_partial_sector_error;
          = 81(16) =
            msg := 'DISK FAULT - MI81';
            disk_log_data_p^.symptom_code := ioc$h_disk_fault;
          = 90(16) =
            msg := 'NO SECTOR PULSE - MI90';
            disk_log_data_p^.symptom_code := ioc$h_no_sector_pulse;
          = 91(16) =
            msg := 'NO INDEX PULSE - MI91';
            disk_log_data_p^.symptom_code := ioc$h_no_index_pulse;
          = 92(16) =
            msg := 'CYLINDER/HEAD/SECTOR WRAP ERROR - MI92';
            disk_log_data_p^.symptom_code := ioc$h_cyl_head_sec_wrap_error;
          = 0C3(16) =
            msg := 'NO DISK RESPONSE - MIC3';
            disk_log_data_p^.symptom_code := ioc$h_no_disk_response;
          ELSE
            IF hydra_status_p^.general_status.timeout_pause  THEN
              msg := 'PAUSE TIME OUT';
              disk_log_data_p^.symptom_code := ioc$h_pause_timeout;
            ELSEIF hydra_status_p^.general_status.timeout_tip  THEN
              msg := 'TRANSFER IN PROGRESS DID NOT CLEAR';
              disk_log_data_p^.symptom_code := ioc$h_tip_didnt_clear;
            ELSEIF hydra_status_p^.general_status.incomplete_command_block_xfer  THEN
              msg := 'INCOMPLETE COMMAND BLOCK TRANSFER';
              disk_log_data_p^.symptom_code := ioc$h_incomplete_cb_xfer;
            ELSEIF hydra_status_p^.general_status.incomplete_status_transfer  THEN
              msg := 'INCOMPLETE STATUS TRANSFER';
              disk_log_data_p^.symptom_code := ioc$h_incomplete_status_xfer;
            ELSEIF hydra_status_p^.general_status.sa_dropped_hydra_status  THEN
              msg := 'SELECT ACTIVE DROPPED WHEN READING CONTROLLER STATUS';
              disk_log_data_p^.symptom_code := ioc$h_sa_dropped_hydra_status;
            ELSEIF hydra_status_p^.general_status.incomplete_device_status_xfer  THEN
              msg := 'INCOMPLETE DEVICE STATUS TRANSFER';
              disk_log_data_p^.symptom_code := ioc$h_incomplete_device_st_xfer;
            ELSEIF hydra_status_p^.general_status.sa_dropped_device_status  THEN
              msg := 'SELECT ACTIVE DROPPED WHEN READING DEVICE STATUS';
              disk_log_data_p^.symptom_code := ioc$h_sa_dropped_device_status;
            ELSEIF hydra_status_p^.general_status.incomplete_error_reg_image_xfer  THEN
              msg := 'INCOMPLETE ERROR REGISTER IMAGE TRANSFER';
              disk_log_data_p^.symptom_code := ioc$h_incomplete_eri_xfer;
            ELSEIF hydra_status_p^.general_status.sa_dropped_error_register_image  THEN
              msg := 'SELECT ACTIVE DROPPED WHEN READING ERROR REGISTER IMAGE';
              disk_log_data_p^.symptom_code := ioc$h_sa_dropped_err_reg_image;
            ELSEIF hydra_status_p^.general_status.incomplete_error_log_transfer  THEN
              msg := 'INCOMPLETE ERROR LOG TRANSFER';
              disk_log_data_p^.symptom_code := ioc$h_incomplete_error_log_xfer;
            ELSEIF hydra_status_p^.general_status.select_active_dropped_error_log  THEN
              msg := 'SELECT ACTIVE DROPPED WHEN READING ERROR LOG';
              disk_log_data_p^.symptom_code := ioc$h_sa_dropped_error_log;
            ELSEIF hydra_status_p^.general_status.select_active_dropped_data  THEN
              msg := 'SELECT ACTIVE DROPPED WHEN TRANSFERRING DATA';
              disk_log_data_p^.symptom_code := ioc$h_sa_dropped_data;
            ELSEIF hydra_status_p^.general_status.host_if_integrity_error  THEN
              msg := 'HOST I/F INTEGRITY ERROR';
              disk_log_data_p^.symptom_code := ioc$h_host_if_integrity_error;
            ELSEIF hydra_status_p^.general_status.drive_if_integrity_error  THEN
              msg := 'DRIVE I/F INTEGRITY ERROR';
              disk_log_data_p^.symptom_code := ioc$h_drive_if_integrity_error;
            ELSEIF error_status_p^.isi_input_error THEN
              msg := 'ISI INPUT ERROR';
              disk_log_data_p^.symptom_code := ioc$h_isi_input_error;
            ELSEIF error_status_p^.isi_timeout THEN
              msg := 'ISI TIMEOUT';
              disk_log_data_p^.symptom_code := ioc$h_isi_timeout;
            ELSEIF hydra_status_p^.general_status.media_failure OR
                    hydra_status_p^.general_status.unrecovered_media_error THEN
              msg := 'MEDIA FAILURE';
              disk_log_data_p^.symptom_code := ioc$h_media_failure;



            ELSE
              CASE delay_status_code OF
              = 21(16) =
                msg := 'MEDIA FAILURE';
                disk_log_data_p^.symptom_code := ioc$h_media_failure;
              = 22(16) =
                msg := 'SEEK ERROR - DS22';
                disk_log_data_p^.symptom_code := ioc$h_seek_error_retried;
              = 23(16), 24(16), 25(16), 26(16), 27(16) =
                msg := 'MEDIA FAILURE';
                disk_log_data_p^.symptom_code := ioc$h_media_failure;
              = 42(16) =
                msg := 'MEDIA FAILURE';
                disk_log_data_p^.symptom_code := ioc$h_media_failure;
              = 81(16) =
                msg := 'POWER-UP INITIALIZATION COMPLETE - DS81';
                disk_log_data_p^.symptom_code := ioc$h_power_up_complete;
                disk_log_data_p^.failure_severity := 3;
              = 83(16) =
                msg := 'HOST-GENERATED RESET COMPLETE - DS83';
                disk_log_data_p^.symptom_code := ioc$h_reset_complete;
                disk_log_data_p^.failure_severity := 3;
              = 84(16) =
                msg := 'PRIORITY OVERRIDE COMPLETE - DS84';
                disk_log_data_p^.symptom_code := ioc$h_priority_override;
                disk_log_data_p^.failure_severity := 3;
              = 85(16) =
                msg := 'HYDRA ON LINE - DS85';
                disk_log_data_p^.symptom_code := ioc$h_hydra_on_line;
                disk_log_data_p^.failure_severity := 3;


              ELSE
                disk_log_data_p^.symptom_code := ioc$hydra_indeterminate;
              CASEND;
            IFEND;
          CASEND;
        CASEND;
      IFEND;

  { Determine 9836/9853/5832/5833/5838/47444 symptom code

    = ioc$dt_ms9836_1, ioc$dt_msxmd_3, ioc$dt_ms5832_1,
         ioc$dt_ms5832_2, ioc$dt_ms5833_1, ioc$dt_ms5833_1p,
         ioc$dt_ms5833_2, ioc$dt_ms5833_3p, ioc$dt_ms5833_4,
         ioc$dt_ms5838_1, ioc$dt_ms5838_1p, ioc$dt_ms5838_2,
         ioc$dt_ms5838_3p, ioc$dt_ms5838_4,
         ioc$dt_ms47444_1, ioc$dt_ms47444_1p, ioc$dt_ms47444_2,
         ioc$dt_ms47444_3p, ioc$dt_ms47444_4 =
  { Process PP isolated symptom codes }
      disk_log_data_p^.diagnostic_code := 0;
      IF cmv$logical_pp_table_p^[pp].controller_info.controller_type = cmc$ms5831_x THEN
        disk_log_data_p^.physical_unit := disk_status_9836_1_p^.unit MOD 40(8);
      ELSE
        disk_log_data_p^.physical_unit := physical_unit;
      IFEND;
      CASE disk_status_9836_1_p^.error_id OF
      = 1 =
        disk_log_data_p^.symptom_code := ioc$9836_1_function_timeout;
        msg := 'FUNCTION TIMEOUT';
      = 2 =
        disk_log_data_p^.symptom_code := ioc$9836_1_ch_empty_when_act;
        msg := 'CHANNEL EMPTY WHEN ACTIVATED';
      = 3 =
        disk_log_data_p^.symptom_code := ioc$9836_1_period_c_error;
        msg := 'PERIOD COUNTER ERROR';
      = 4, 5 =
        disk_log_data_p^.symptom_code := ioc$9836_1_upper_ici_parity;
        msg := 'PP-IPI PARITY ERROR';
      = 6 =
        disk_log_data_p^.symptom_code := ioc$9836_1_iou_error;
        msg := 'IOU ERROR';
      = 7 =
        disk_log_data_p^.symptom_code := ioc$9836_1_incomplete_i4_xfer;
        msg := 'INCOMPLETE I4 TRANSFER';
      = 8 =
        disk_log_data_p^.symptom_code := ioc$9836_1_channel_not_empty;
        msg := 'CHANNEL NOT EMPTY';
      = 9 =
        disk_log_data_p^.symptom_code := ioc$9836_1_central_memory_error;
        msg := 'CENTRAL MEMORY ERROR';
      = 10 =
        disk_log_data_p^.symptom_code := ioc$9836_1_invalid_cm_response;
        msg := 'INVALID CM RESPONSE CODE';
      = 11 =
        disk_log_data_p^.symptom_code := ioc$9836_1_cm_response_error;
        msg := 'CM RESPONSE CODE ERROR';
      = 12 =
        disk_log_data_p^.symptom_code := ioc$9836_1_cmi_read_parity;
        msg := 'CMI READ DATA PARITY ERROR';
      = 13 =
        disk_log_data_p^.symptom_code := ioc$9836_1_jy_data_error;
        msg := 'Y BOARD DATA ERROR';
      = 14 =
        disk_log_data_p^.symptom_code := ioc$9836_1_bas_parity_error;
        msg := 'BAS PARITY ERROR';
      = 15 =
        disk_log_data_p^.symptom_code := ioc$9836_1_lz_error;
        msg := 'Z BOARD ERROR';
      = 16 =
        disk_log_data_p^.symptom_code := ioc$9836_1_jy_error;
        msg := 'Y BOARD ERROR';
      = 17 =
        disk_log_data_p^.symptom_code := ioc$9836_1_lx_error;
        msg := 'X BOARD ERROR';
      = 18 =
        disk_log_data_p^.symptom_code := ioc$9836_1_dma_test_failure;
        msg := 'DMA TEST MODE FAILURE';
      = 19 =
        disk_log_data_p^.symptom_code := ioc$9836_1_count_overflow;
        msg := 'DMA COUNT OVERFLOW';
      = 20 =
        disk_log_data_p^.symptom_code := ioc$9836_1_cant_select_cont;
        msg := 'CAN NOT SELECT CONTROLLER';
      = 21 =
        disk_log_data_p^.symptom_code := ioc$9836_1_bit_sig_response_err;
        msg := 'BIT SIGNIFICANT RESPONSE ERROR';
      = 22 =
        disk_log_data_p^.symptom_code := ioc$9836_1_no_sync_in;
        msg := 'NO SYNC IN';
      = 23 =
        disk_log_data_p^.symptom_code := ioc$9836_1_sync_in_did_not_drop;
        msg := 'SYNC IN DID NOT DROP';
      = 24 =
        disk_log_data_p^.symptom_code := ioc$9836_1_ipi_sequence_error;
        msg := 'IPI SEQUENCE ERROR';
      = 25, 26 =
        disk_log_data_p^.symptom_code := ioc$9836_1_upper_ipi_ch_parity;
        msg := 'IPI CHANNEL PARITY ERROR';
      = 27 =
        disk_log_data_p^.symptom_code := ioc$9836_1_slave_in_not_set;
        msg := 'SLAVE IN NOT SET';
      = 28 =
        disk_log_data_p^.symptom_code := ioc$9836_1_slave_in_not_drop;
        msg := 'SLAVE IN DID NOT DROP';
      = 29 =
        disk_log_data_p^.symptom_code := ioc$9836_1_incomplete_transfer;
        msg := 'INCOMPLETE TRANSFER';
      = 30 =
        disk_log_data_p^.symptom_code := ioc$9836_1_ch_stayed_active;
        msg := 'CHANNEL STAYED ACTIVE';
      = 31 =
        disk_log_data_p^.symptom_code := ioc$9836_1_buffer_counter_e;
        msg := 'BUFFER COUNTER_ERROR';
      = 32 =
        disk_log_data_p^.symptom_code := ioc$9836_1_sync_counter_error;
        msg := 'SYNC COUNTER ERROR';
      = 33 =
        disk_log_data_p^.symptom_code := ioc$9836_1_lost_data;
        msg := 'LOST DATA';
      = 34 =
        disk_log_data_p^.symptom_code := ioc$9836_1_bus_parity;
        msg := 'BUS PARITY';
      = 35 =
        disk_log_data_p^.symptom_code := ioc$9836_1_command_reject;
        msg := 'COMMAND REJECT';
      = 36 =
        disk_log_data_p^.symptom_code := ioc$9836_1_sync_out_not_sync_in;
        msg := 'SYNC OUTS NOT EQUAL SYNC INS';
      = 37 =
        disk_log_data_p^.symptom_code := ioc$9836_1_bus_b_ack_incorrect;
        msg := 'BUS B ACKNOWLEGE INCORRECT';
      = 38 =
        disk_log_data_p^.symptom_code := ioc$9836_1_no_cont_response;
        msg := 'NO CONTROLLER RESPONSE';
      = 39 =
        disk_log_data_p^.symptom_code := ioc$9836_1_ending_status_wrong;
        msg := 'ENDING STATUS WRONG';
      = 50 =
        disk_log_data_p^.symptom_code := ioc$9836_1_executing_cont_diag;
        msg := 'EXECUTING_CONTROLLER_DIAGNOSTICS';
        display_message := TRUE;
        disk_log_data_p^.failure_severity := 3;
        down_status := ioc$executing_diagnostics;
      = 51 =
        disk_log_data_p^.symptom_code := ioc$9836_1_cont_diag_passed;
        msg := 'CONTROLLER DIAGNOSTICS PASSED';
        display_message := TRUE;
        disk_log_data_p^.failure_severity := 3;
      = 52 =
        disk_log_data_p^.symptom_code := ioc$9836_1_cont_diag_passed_2;
        msg := 'CONTROLLER DIAGNOSTICS PASSED - LAST ERROR CODE IS     ';
        display_message := TRUE;
        disk_log_data_p^.failure_severity := 3;
        IF cmv$logical_pp_table_p^[pp].controller_info.controller_type = cmc$ms5831_x THEN
          iop$ascii_hex (^msg (52, * ), 4, disk_status_9836_1_p^.residual_word_count);
          disk_log_data_p^.diagnostic_code := disk_status_9836_1_p^.residual_word_count;
        ELSE
          IF (disk_status_9836_1_p^.response_packets [5] = 84(16)) AND
               (disk_status_9836_1_p^.response_packets [29] <> 0) THEN
            disk_log_data_p^.diagnostic_code := disk_status_9836_1_p^.response_packets [29] * 100(16) +
              disk_status_9836_1_p^.response_packets [30];
            iop$ascii_hex (^msg (52, * ), 4, disk_log_data_p^.diagnostic_code);
          ELSE
            disk_log_data_p^.symptom_code := ioc$9836_1_cont_diag_passed;
            msg := 'CONTROLLER DIAGNOSTICS PASSED';
          IFEND;
        IFEND;
      = 54 =
        disk_log_data_p^.symptom_code := ioc$9836_1_dr_alt_port_event;
        disk_log_data_p^.failure_severity := 3;
      = 55 =
        disk_log_data_p^.symptom_code := ioc$9836_1_restoring_drive;
        msg := 'RESTORING DRIVE';
        display_message := TRUE;
        disk_log_data_p^.failure_severity := 3;
      = 56 =
        disk_log_data_p^.symptom_code := ioc$9836_1_restore_complete;
        msg := 'DRIVE RESTORATION COMPLETE';
        display_message := TRUE;
        disk_log_data_p^.failure_severity := 3;
      = 57 =
        disk_log_data_p^.symptom_code := ioc$9836_1_formatting_drive;
        msg := 'FORMATTING DRIVE';
        display_message := TRUE;
        disk_log_data_p^.failure_severity := 3;
      = 58 =
        disk_log_data_p^.symptom_code := ioc$9836_1_format_complete;
        msg := 'FORMAT COMPLETE';
        display_message := TRUE;
        disk_log_data_p^.failure_severity := 3;
      = 59 =
        disk_log_data_p^.symptom_code := ioc$9836_1_par_prot_disabled;
        display_message := TRUE;
        disk_log_data_p^.failure_severity := 3;
        IF disk_type = 010c(16) THEN
          msg := '5833_1P PARITY PROTECTION DISABLED';
        ELSEIF disk_type = 010e(16) THEN
          msg := '5833_3P PARITY PROTECTION DISABLED';
        ELSEIF disk_type = 0111(16) THEN
          msg := '5838_1P PARITY PROTECTION DISABLED';
        ELSEIF disk_type = 0113(16) THEN
          msg := '5838_3P PARITY PROTECTION DISABLED';
        ELSEIF disk_type = 0116(16) THEN
          msg := '47444_1P PARITY PROTECTION DISABLED';
        ELSE
          msg := '47444_3P PARITY PROTECTION DISABLED';
        IFEND;
        signal_contents.signal_type := cmc$parity_disabled_signal;
        signal_contents.parity_logical_unit := logical_unit;
        signal_contents.parity_physical_unit := disk_status_9836_1_p^.unit MOD 20(16);
        signal_contents.fill5 := ' ';
        signal.identifier := cmc$configuration_signal_id;
        #UNCHECKED_CONVERSION(signal_contents, signal.contents);
        tmp$send_signal(tmv$system_job_monitor_gtid, signal, mtr_status);
      = 61 =
        analyze_response_packets (disk_status_9836_1_p, pp_response_p^.response_length,
                disk_log_data_p^.controller_type, disk_log_data_p^.disk_type,
                response_packet);
        display_message := TRUE;
        disk_log_data_p^.symptom_code := ioc$9836_1_drive_failure;
        disk_log_data_p^.diagnostic_code := response_packet.id23_error_code;
        msg := 'DRIVE FAILURE';
        CASE disk_type OF
        = ioc$dt_ms5832_1, ioc$dt_ms5832_2 =
          IF (response_packet.id23_facility_status <> 0) AND
             (response_packet.id23_error_code = 0) THEN
            send_ssd_battery_signal := TRUE;
            IF response_packet.id23_facility_status = 83(16) THEN
              disk_log_data_p^.symptom_code := ioc$9836_1_ssd_battery_to_low;
              msg := 'SSD BATTERY TOO LOW FOR BACKUP';
            ELSEIF response_packet.id23_facility_status = 84(16) THEN
              disk_log_data_p^.symptom_code := ioc$9836_1_ssd_battery_test;
              msg := 'SSD BATTERY TEST FAILED';
            ELSEIF response_packet.id23_facility_status = 85(16) THEN
              disk_log_data_p^.symptom_code := ioc$9836_1_ssd_battery_old;
              msg := 'SSD BATTERY OLD - REPLACE';
            ELSE
              send_ssd_battery_signal := FALSE;
            IFEND;
            IF send_ssd_battery_signal = TRUE THEN
              disk_log_data_p^.failure_severity := 3;
              signal_contents.signal_type := cmc$ssd_battery_alert_signal;
              signal_contents.battery_alert_logical_unit := logical_unit;
              signal_contents.battery_alert_physical_unit := disk_status_9836_1_p^.unit MOD 20(16);
              signal_contents.battery_alert_condition := disk_log_data_p^.symptom_code;
              signal_contents.fill7 := ' ';
              signal.identifier := cmc$configuration_signal_id;
              #UNCHECKED_CONVERSION(signal_contents, signal.contents);
              tmp$send_signal(tmv$system_job_monitor_gtid, signal, mtr_status);
              send_ssd_battery_signal := FALSE;
            IFEND;
          IFEND;
        CASEND;
      = 62 =
        disk_log_data_p^.symptom_code := ioc$9836_1_media_failure;
        msg := 'MEDIA FAILURE';
      = 70 =
        disk_log_data_p^.symptom_code := ioc$9836_1_lrc_error;
        msg := 'LRC ERROR';
      = 71 =
        disk_log_data_p^.symptom_code := ioc$9836_1_cont_intervention;
        msg := 'CONTROLLER INTERVENTION REQUIRED';
      = 72 =
        disk_log_data_p^.symptom_code := ioc$9836_1_cont_machine_exc;
        msg := 'CONTROLLER MACHINE EXCEPTION';
      = 73 =
        disk_log_data_p^.symptom_code := ioc$9836_1_command_exception;
        msg := 'COMMAND EXCEPTION';
      = 60, 74 =
        disk_log_data_p^.symptom_code := ioc$9836_1_microcode_exec_error;
        msg := 'MICROCODE EXECUTION ERROR';
      = 53, 75 =
        disk_log_data_p^.symptom_code := ioc$9836_1_cont_alt_port_event;
        disk_log_data_p^.failure_severity := 3;
      = 76 =
        disk_log_data_p^.symptom_code := ioc$9836_1_unexpected_response;
        msg := 'UNEXPECTED RESPONSE';
      = 77 =
        disk_log_data_p^.symptom_code := ioc$9836_1_drive_rsvd_other_p;
        msg := 'DRIVE RESERVED TO OTHER CONTROLLER PORT';
      = 78 =
        disk_log_data_p^.symptom_code := ioc$9836_1_controller_over_temp;
        msg := 'CONTROLLER OVER TEMPERATURE';
        display_message := TRUE;

        signal_contents.signal_type := cmc$controller_overtemp_signal;
        signal_contents.overtemp_element_address.address_specifier := cmv$controller_address;
        signal_contents.overtemp_element_address.channel := channel;
        signal_contents.overtemp_element_address.channel_address := equipment;
        signal_contents.overtemp_element_address.unit_address := 0;
        signal_contents.fill4 := ' ';
        signal.identifier := cmc$configuration_signal_id;
        #UNCHECKED_CONVERSION(signal_contents, signal.contents);
        tmp$send_signal(tmv$system_job_monitor_gtid, signal, mtr_status);
      = 95 =
        disk_log_data_p^.symptom_code := ioc$9836_1_no_unit_oper_resp;
        msg := 'NO UNIT OPERATIONAL RESPONSE';
      = 96 =
        disk_log_data_p^.symptom_code := ioc$9836_1_das_head_shift;
        msg := 'DAS HEAD SHIFT DETECTED';
        disk_log_data_p^.failure_severity := 3;
        IF cmv$enable_head_shift_message THEN
          display_message := TRUE;
          signal_contents.signal_type := cmc$das_head_shift_signal;
          signal_contents.hd_shift_logical_unit := logical_unit;
          signal_contents.hd_shift_physical_unit := disk_status_9836_1_p^.unit MOD 20(16);
          signal_contents.fill6 := ' ';
          signal.identifier := cmc$configuration_signal_id;
          #UNCHECKED_CONVERSION(signal_contents, signal.contents);
          tmp$send_signal(tmv$system_job_monitor_gtid, signal, mtr_status);
        IFEND;
      = 110 =
        disk_log_data_p^.symptom_code := ioc$9836_1_pp_cont_data_integ;
        msg := 'PP-CONTROLLER DATA INTEGRITY';
      = 111 =
        disk_log_data_p^.symptom_code := ioc$9836_1_cm_drive_data_integ;
        msg := 'CM-DRIVE DATA INTEGRITY';
      = 120 =
        disk_log_data_p^.symptom_code := ioc$9836_1_software_failure;
        IF disk_status_9836_1_p^.request_retry = 0 THEN
          display_message := TRUE;
        IFEND;
        msg := 'SOFTWARE FAILURE';
      = 121 =
        disk_log_data_p^.symptom_code := ioc$9836_1_wrong_drive_config;
        msg := 'WRONG DRIVE TYPE';
        display_message := TRUE;
      = 130 =
        disk_log_data_p^.symptom_code := ioc$9836_1_defect_mgmt_failure;
        IF disk_status_9836_1_p^.request_retry = 0 THEN
          display_message := TRUE;
        IFEND;
        msg := 'DEFECT MANAGEMENT FAILURE';
      = 140 =
        disk_log_data_p^.symptom_code := ioc$9836_1_wrong_drive_type;
        msg := '         CONFIGURED -          FOUND';
        disk_log_data_p^.actual_drive_type := disk_status_9836_1_p^.actual_drive_type MOD 17;
        j := (disk_status_9836_1_p^.actual_drive_type MOD 17) * 8;
        k := ((disk_type MOD 100(16)) - 9) * 8;
        FOR i := 1 TO 8 DO
          msg(i) := das_type(i+k);
          msg(i+22) := das_type(i+j);
        FOREND;
      = 141 =
        disk_log_data_p^.symptom_code := ioc$9836_1_drive_init_required;
        msg := 'DRIVE INITIALIZATION REQUIRED';
      = 142 =
        disk_log_data_p^.symptom_code := ioc$9836_1_no_parallel_support;
        msg := 'CONTROLLER DOES NOT SUPPORT PARALLEL';
      = 0 =
    {Process CPU isolated symptom codes if none found in PP
        analyze_response_packets (disk_status_9836_1_p, pp_response_p^.response_length,
                disk_log_data_p^.controller_type, disk_log_data_p^.disk_type,
                response_packet);
        IF response_packet.id24_present THEN
          IF response_packet.id24_byte1_bit7 THEN
            disk_log_data_p^.symptom_code := ioc$9836_1_drive_not_operable;
            msg := 'DRIVE NOT OPERATIONAL';
            IF pp_response_p^.response_code.primary_response =
                ioc$unsolicited_response THEN
              display_message := true;
            IFEND;
          ELSEIF response_packet.id24_byte1_bit6 THEN
            disk_log_data_p^.symptom_code := ioc$9836_1_drive_not_ready;
            msg := 'DRIVE NOT READY';
            IF pp_response_p^.response_code.primary_response =
                ioc$unsolicited_response THEN
              display_message := true;
            IFEND;
          ELSEIF response_packet.id24_byte1_bit1 THEN
            disk_log_data_p^.symptom_code := ioc$9836_1_drive_rsvd_other_c;
            msg := 'DRIVE RESERVED TO OTHER CONTROLLER';
          ELSE
            disk_log_data_p^.symptom_code := ioc$9836_1_drive_intervention;
            msg := 'DRIVE INTERVENTION REQUIRED';
          IFEND;
        ELSEIF response_packet.id26_present THEN
          disk_log_data_p^.diagnostic_code := response_packet.id26_error_code;
          IF response_packet.id26_byte2_bit6 THEN
            disk_log_data_p^.symptom_code := ioc$9836_1_uncorr_data_ck;
            msg := 'UNCORRECTABLE DATA CHECK';
          ELSEIF response_packet.id26_byte2_bit4 THEN
            disk_log_data_p^.symptom_code := ioc$9836_1_hw_write_protect;
            msg := 'HARDWARE WRITE PROTECTED';
          ELSEIF response_packet.id26_byte10 = 11(16) THEN
            disk_log_data_p^.symptom_code := ioc$9836_1_drive_ecc_error;
            msg := 'DRIVE ECC ERROR';
          ELSEIF response_packet.id26_byte10 = 13(16) THEN
            disk_log_data_p^.symptom_code := ioc$9836_1_missing_sync;
            msg := 'MISSING SYNC OCTET ON DRIVE';
          ELSEIF response_packet.id26_byte10 = 19(16) THEN
            disk_log_data_p^.symptom_code := ioc$9836_1_sector_not_found;
            msg := 'SECTOR NOT FOUND';
          ELSEIF response_packet.id26_byte2_bit5 THEN
            IF response_packet.id26_byte10 = 0e1(16) THEN
              disk_log_data_p^.symptom_code := ioc$9836_1_drive_rsvd_other_c;
              msg := 'DRIVE RESERVED TO OTHER CONTROLLER';
            ELSE
              disk_log_data_p^.symptom_code := ioc$9836_1_drive_fatal_error;
              msg := 'DRIVE FATAL ERROR';
            IFEND;
          ELSE
            disk_log_data_p^.symptom_code := ioc$9836_1_drive_exception;
            msg := 'DRIVE MACHINE EXCEPTION';
          IFEND;
        ELSEIF response_packet.id29_present THEN
          disk_log_data_p^.diagnostic_code := response_packet.id29_error_code;
          IF response_packet.id29_byte2_bit6 THEN
            disk_log_data_p^.symptom_code := ioc$9836_1_error_retry;
          ELSEIF response_packet.id29_byte2_bit5 THEN
            disk_log_data_p^.symptom_code := ioc$9836_1_data_retry;
          ELSEIF response_packet.id29_byte2_bit4 THEN
            disk_log_data_p^.symptom_code := ioc$9836_1_motion_retry;
          ELSEIF response_packet.id29_byte2_bit3 THEN
            disk_log_data_p^.symptom_code := ioc$9836_1_data_correction;
          ELSEIF response_packet.id29_byte6_bit7 THEN
            disk_log_data_p^.symptom_code := ioc$9836_1_parity_dr_corr;
          ELSEIF response_packet.id29_byte2_bit2 THEN
            disk_log_data_p^.symptom_code := ioc$9836_1_soft_error;
          ELSE
            disk_log_data_p^.symptom_code := ioc$9836_1_indeterminate;
          IFEND;
        ELSE
          disk_log_data_p^.symptom_code := ioc$9836_1_indeterminate;
        IFEND;
      ELSE
        disk_log_data_p^.symptom_code := ioc$9836_1_indeterminate;
      CASEND;
    ELSE
      disk_log_data_p^.physical_unit := 0;
      CASE cmv$logical_pp_table_p^ [pp].controller_info.controller_type OF
      = cmc$ms7154_x, cmc$ms7155_1, cmc$ms7155_1x =
        disk_log_data_p^.symptom_code := ioc$indeterminate;
      = cmc$ms7255_1_1, cmc$ms7255_1_2 =
        disk_log_data_p^.symptom_code := ioc$isd_indeterminate;
      = cmc$ms7165_2x =
        disk_log_data_p^.symptom_code := ioc$895_indeterminate;
      = cmc$mshydra_ct =
        disk_log_data_p^.symptom_code := ioc$hydra_indeterminate;
      = cmc$mscm3_ct, cmc$ms5831_x =
        disk_log_data_p^.symptom_code := ioc$9836_1_indeterminate;
      ELSE
      CASEND;
    CASEND;

{Save detailed status.

    bi := iov$error_count MOD (UPPERBOUND (iov$detailed_status_buffer) -
          LOWERBOUND (iov$detailed_status_buffer) + 1) + LOWERBOUND (iov$detailed_status_buffer);
    iov$error_count := iov$error_count + 1;
    IF completed_request_p <> NIL THEN
      iov$detailed_status_buffer [bi].request := completed_request_p^;
    IFEND;
    iov$detailed_status_buffer [bi].resp := disk_log_data_p^;
    iov$detailed_status_buffer [bi].msg := msg;

{Update error counters.

    IF (iov$disk_pp_usage_p <> NIL) AND (iov$disk_unit_usage_p <> NIL) THEN
      IF (pp <> 0) AND (logical_unit <> 0) THEN
        IF (iov$disk_pp_usage_p^ [pp] <> NIL) AND (iov$disk_unit_usage_p^ [logical_unit] <> NIL) THEN
          CASE disk_log_data_p^.failure_severity OF
          = 0 =
            iov$disk_unit_usage_p^ [logical_unit]^.recovered_errors :=
               iov$disk_unit_usage_p^ [logical_unit]^.recovered_errors + 1;
            iov$disk_pp_usage_p^ [pp]^.path_usage [port_index] [equipment].recovered_errors :=
               iov$disk_pp_usage_p^ [pp]^.path_usage [port_index] [equipment].recovered_errors + 1;
          = 1 =
            iov$disk_unit_usage_p^ [logical_unit]^.unrecovered_errors :=
               iov$disk_unit_usage_p^ [logical_unit]^.unrecovered_errors + 1;
            iov$disk_pp_usage_p^ [pp]^.path_usage [port_index] [equipment].unrecovered_errors :=
               iov$disk_pp_usage_p^ [pp]^.path_usage [port_index] [equipment].unrecovered_errors + 1;
          = 2 =
            iov$disk_unit_usage_p^ [logical_unit]^.intermediate_errors :=
               iov$disk_unit_usage_p^ [logical_unit]^.intermediate_errors + 1;
            iov$disk_pp_usage_p^ [pp]^.path_usage [port_index] [equipment].intermediate_errors :=
               iov$disk_pp_usage_p^ [pp]^.path_usage [port_index] [equipment].intermediate_errors + 1;
          ELSE;
          CASEND;
        IFEND;
      IFEND;
    IFEND;
{Display mdd message.

    IF (completed_request_p <> NIL) AND (completed_request_p^.request_info.list_length > 0) THEN
      mmp$determine_error_state (completed_request_p^.request_info.list_p,
        completed_request_p^.request_info.list_length, previous_error);
    ELSE
      previous_error := FALSE;
    IFEND;

    IF (((unrecovered_error = 1) OR display_message)
          AND (NOT previous_error)) OR
          (down_status <> ioc$no_change) THEN
      disk_log_data_p^.display_message := TRUE;

      msg1 := 'IOU   CH    C  U   -      -                     C     T   S  ';
      iop$ascii_decimal (^msg1 (4, *), 1, iou_number);
      iop$ascii_decimal (^msg1 (9, *), 2, channel.number);

      CASE channel.port OF
      = cmc$port_a =
        msg1 (6,1) := 'C';       { CIO Channel }
        msg1 (11,1) := 'A';      { Change to CIO channel PORT A }
      = cmc$port_b =
        msg1 (6,1) := 'C';       { CIO Channel }
        msg1 (11,1) := 'B';      { Change to CIO channel PORT B }
      ELSE
        IF channel.concurrent THEN
          msg1 (6,1) := 'C'        { CIO Channel }
        IFEND;
      CASEND;
      IF logical_unit <> 0 THEN
        iop$ascii_decimal (^msg1 (14, *), 1, disk_log_data_p^.equipment);
        iop$ascii_decimal (^msg1 (17, *), 2, disk_log_data_p^.physical_unit);
        dmp$get_recorded_vsn (logical_unit, msg1 (21,6));
      IFEND;
      IF disk_type = ioc$dt_mshydra THEN
        msg1 (16, 3) := '   ';   { Remove Unit field for HYDRA }
      IFEND;

      IF unrecovered_error = 1 THEN
        msg1 (29, 11) := 'UNRECOVERED';
      IFEND;

      CASE disk_log_data_p^.logical_operation OF
      = ioc$log_read =
        msg1 (41, 5) := 'READ,';
      = ioc$log_read_flaw_map =
        msg1 (41, 4) := 'RFM,';
      = ioc$log_write =
        msg1 (41, 6) := 'WRITE,';
      = ioc$log_initialize_sectors =
        IF disk_type = ioc$dt_ms9836_1 THEN
          CASE disk_status_9836_1_p^.error_id OF
          = 96 =
            msg1 (41, 7) := 'SCREEN,';
          ELSE
            msg1 (41, 7) := 'FORMAT,';
          CASEND;
        ELSE
         msg1 (41, 7) := 'FORMAT,';
        IFEND;
      ELSE
      CASEND;

      iop$ascii_decimal (^msg1 (50, * ), 4, disk_status_p^.general_status.
            starting_cylinder);
      iop$ascii_decimal (^msg1 (56, * ), 2, disk_status_p^.general_status.
            failing_track);
      iop$ascii_decimal (^msg1 (60, * ), 2, disk_status_p^.general_status.
            failing_sector);

      dpp$display_error (msg1);

{Display symptom message.

      dpp$display_error (msg);

{Display execution time for formatting disk or executing controller diagnostics.

      CASE cmv$logical_pp_table_p^[pp].controller_info.controller_type OF
      = cmc$mscm3_ct =
        CASE disk_log_data_p^.symptom_code OF
        = ioc$9836_1_formatting_drive =
          dpp$display_error('MAXIMUM EXECUTION TIME: 90 MINUTES');
        = ioc$9836_1_executing_cont_diag =
          dpp$display_error('MAXIMUM EXECUTION TIME: 2 MINUTES');
        ELSE
        CASEND;
      = cmc$ms5831_x =
        CASE disk_log_data_p^.symptom_code OF
        = ioc$9836_1_formatting_drive =
          CASE disk_type OF
          = ioc$dt_ms5838_1, ioc$dt_ms5838_1p, ioc$dt_ms5838_2,
              ioc$dt_ms5838_3p, ioc$dt_ms5838_4 =
            dpp$display_error('MAXIMUM EXECUTION TIME: 6.5 MINUTES');
          = ioc$dt_ms47444_1, ioc$dt_ms47444_1p, ioc$dt_ms47444_2,
              ioc$dt_ms47444_3p, ioc$dt_ms47444_4 =
            dpp$display_error('MAXIMUM EXECUTION TIME: 9 MINUTES');
          ELSE
            dpp$display_error('MAXIMUM EXECUTION TIME: 5 MINUTES');
          CASEND;
        = ioc$9836_1_executing_cont_diag =
          dpp$display_error('MAXIMUM EXECUTION TIME: 12 MINUTES');
        ELSE
        CASEND;
      ELSE
      CASEND;

{Check if channel, control module, or unit was downed.}

      IF (cmv$logical_pp_table_p^[pp].controller_info.controller_type = cmc$mscm3_ct) OR
            (cmv$logical_pp_table_p^[pp].controller_info.controller_type = cmc$ms5831_x) THEN
        IF disk_status_9836_1_p^.id = 1 THEN
          msg := 'CHANNEL DISABLED';
          dpp$display_error (msg);
          down_status := ioc$channel_down;
        IFEND;
        IF disk_status_9836_1_p^.id = 2 THEN
          msg := 'CONTROLLER DISABLED';
          dpp$display_error (msg);
          down_status:= ioc$controller_down;
        IFEND;
        IF disk_status_9836_1_p^.id = 3 THEN
          msg := 'DRIVE DISABLED';
          dpp$display_error (msg);
          down_status:= ioc$unit_down;
        IFEND;
      ELSE
        IF disk_status_p^.general_status.channel_down THEN
          CASE disk_type OF
          = ioc$dt_ms844_4x, ioc$dt_ms885_1x, ioc$dt_ms885_42 =
            msg := 'CONTROLLER DISABLED';
          = ioc$dt_ms834_2, ioc$dt_msfsd_2 =
            msg := 'ADAPTER DISABLED';
          = ioc$dt_mshydra =
            msg := 'CHANNEL DISABLED';
          = ioc$dt_ms895_2 =
            msg := 'CYBER COUPLER DISABLED';
          ELSE
          CASEND;
          dpp$display_error (msg);
          down_status := ioc$channel_down;
        IFEND;
        IF disk_status_p^.general_status.control_module_down THEN
          CASE disk_type OF
          = ioc$dt_mshydra =
          msg := 'CONTROLLER DISABLED';
          = ioc$dt_ms895_2 =
          msg := 'STORAGE DIRECTOR DISABLED';
          ELSE
          msg := 'CONTROL MODULE DISABLED';
          CASEND;
          dpp$display_error (msg);
          down_status:= ioc$controller_down;
        IFEND;
        IF disk_status_p^.general_status.unit_down THEN
          msg := 'DRIVE DISABLED';
          dpp$display_error (msg);
          down_status:= ioc$unit_down;
        IFEND;
      IFEND;

{Display detailed status.

      CASE disk_type OF
      = ioc$dt_ms844_4x, ioc$dt_ms885_1x, ioc$dt_ms885_42, ioc$dt_ms834_2, ioc$dt_msfsd_2,
        ioc$dt_ms895_2 =
        IF disk_status_p^.general_status.detailed_status_present THEN
          msg2 :=
            'GS       , DS                                                  ';
          msg3 :=
            '                                                               ';
          IF (channel.concurrent) AND (disk_type = ioc$dt_ms895_2) THEN
            msg3 :=
              'ES                                                             ';
          IFEND;
          RESET detail_status_p;
          NEXT status_bytes_p IN detail_status_p;

          CASE disk_type OF
          = ioc$dt_ms844_4x, ioc$dt_ms885_1x, ioc$dt_ms885_42 =
            IF unrecovered_error = 1 THEN
              iop$ascii_octal (^msg2 (4, * ), 4, status_bytes_p^ [14]);
            ELSE
              iop$ascii_octal (^msg2 (4, * ), 4, status_bytes_p^ [13]);
            IFEND;

            FOR i := 1 TO 10 DO
              k := i * 5 + 10;
              IF unrecovered_error = 1 THEN
                iop$ascii_octal (^msg2 (k, * ), 4, status_bytes_p^ [i + 36]);
                iop$ascii_octal (^msg3 (k, * ), 4, status_bytes_p^ [i + 46]);
              ELSE
                iop$ascii_octal (^msg2 (k, * ), 4, status_bytes_p^ [i + 16]);
                iop$ascii_octal (^msg3 (k, * ), 4, status_bytes_p^ [i + 26]);
              IFEND;
            FOREND;
          = ioc$dt_ms834_2, ioc$dt_msfsd_2 =
            IF unrecovered_error = 1 THEN
              iop$ascii_hex (^msg2 (4, * ), 4, status_bytes_p^ [14]);
            ELSE
              iop$ascii_hex (^msg2 (4, * ), 4, status_bytes_p^ [13]);
            IFEND;

            FOR i := 1 TO 10 DO
              k := i * 5 + 10;
              IF unrecovered_error = 1 THEN
                iop$ascii_hex (^msg2 (k, * ), 3, status_bytes_p^ [i + 36]);
                iop$ascii_hex (^msg3 (k, * ), 3, status_bytes_p^ [i + 46]);
              ELSE
                iop$ascii_hex (^msg2 (k, * ), 3, status_bytes_p^ [i + 16]);
                iop$ascii_hex (^msg3 (k, * ), 3, status_bytes_p^ [i + 26]);
              IFEND;
            FOREND;
          ELSE
            IF unrecovered_error = 1 THEN
              iop$ascii_hex (^msg2 (4, * ), 4, status_bytes_p^ [14]);
              IF channel.concurrent THEN
                iop$ascii_hex (^msg3 (4, * ), 4, status_bytes_p^ [18]);
              IFEND;
            ELSE
              iop$ascii_hex (^msg2 (4, * ), 4, status_bytes_p^ [13]);
              IF channel.concurrent THEN
                iop$ascii_hex (^msg3 (4, * ), 4, status_bytes_p^ [17]);
              IFEND;
            IFEND;

            FOR i := 1 TO 10 DO
              k := i * 5 + 10;
              IF unrecovered_error = 1 THEN
                iop$ascii_hex (^msg2 (k, * ), 3, status_bytes_p^ [i + 40]);
                iop$ascii_hex (^msg3 (k, * ), 3, status_bytes_p^ [i + 50]);
              ELSE
                iop$ascii_hex (^msg2 (k, * ), 3, status_bytes_p^ [i + 20]);
                iop$ascii_hex (^msg3 (k, * ), 3, status_bytes_p^ [i + 30]);
              IFEND;
            FOREND;
          CASEND;

          dpp$display_error (msg2);

          dpp$display_error (msg3);

        IFEND;

      = ioc$dt_mshydra =
        IF (system_intervention_code = 0A6(16)) OR (manual_intervention_code = 6A(16)) THEN
          msg := 'FAILING FRUS =           ';
          IF hydra_status_p^.cm_status2.fru1 <> 0 THEN
            iop$ascii_decimal (^msg (16, * ), 1, hydra_status_p^.cm_status2.fru1);
          IFEND;
          IF hydra_status_p^.cm_status2.fru2 <> 0 THEN
            iop$ascii_decimal (^msg (18, * ), 1, hydra_status_p^.cm_status2.fru2);
          IFEND;
          IF hydra_status_p^.cm_status2.fru3 <> 0 THEN
            iop$ascii_decimal (^msg (20, * ), 1, hydra_status_p^.cm_status2.fru3);
          IFEND;
          IF hydra_status_p^.cm_status2.fru4 <> 0 THEN
            iop$ascii_decimal (^msg (22, * ), 1, hydra_status_p^.cm_status2.fru4);
          IFEND;
          dpp$display_error (msg);
        IFEND;

        msg2 := 'CS                              ';
        msg3 := 'ES                              ';
        RESET detail_status_p;
        NEXT status_bytes_p IN detail_status_p;

        FOR i := 1 TO 6 DO
          k := i * 5 - 1;
          IF unrecovered_error = 1 THEN
            iop$ascii_hex (^msg2 (k, * ), 4, status_bytes_p^ [i + 34]);
          ELSE
            iop$ascii_hex (^msg2 (k, * ), 4, status_bytes_p^ [i + 24]);
          IFEND;
        FOREND;

        IF disk_status_p^.general_status.device_status_present THEN
          msg3 := 'ES        DS                    ';
          FOR i := 1 TO 4 DO
            k := i * 5 + 9;
            IF unrecovered_error = 1 THEN
              iop$ascii_hex (^msg3 (k, * ), 4, status_bytes_p^ [i + 40]);
            ELSE
              iop$ascii_hex (^msg3 (k, * ), 4, status_bytes_p^ [i + 30]);
            IFEND;
          FOREND;
        IFEND;

        iop$ascii_hex (^msg3 (4, * ), 4, status_bytes_p^ [13]);

        IF disk_status_p^.general_status.detailed_status_present THEN
          dpp$display_error (msg2);
        IFEND;
        dpp$display_error (msg3);

        IF disk_status_p^.general_status.error_register_image_present AND
              ((manual_intervention_code = 27(16)) OR
              (manual_intervention_code = 41(16)) OR
              (manual_intervention_code = 63(16)) OR
              (manual_intervention_code = 64(16)) OR
              (manual_intervention_code = 65(16)) OR
              (manual_intervention_code = 66(16)) OR
              (manual_intervention_code = 67(16)) OR
              (manual_intervention_code = 6E(16)) OR
              (manual_intervention_code = 6F(16)) OR
              (manual_intervention_code = 70(16)) OR
              (manual_intervention_code = 72(16)) OR
              (manual_intervention_code = 81(16))) THEN
          msg3 := 'ERI                                                              ';
          FOR j := 1 TO 4 DO
            FOR i := 1 TO 12 DO
              k := i * 5;
              m := i + ((j - 1) * 12);
              iop$ascii_hex (^msg3 (k, * ), 4, status_bytes_p^ [m + 44]);
            FOREND;
            dpp$display_error (msg3);
            msg3 := '                                                               ';
          FOREND;
        IFEND;

    = ioc$dt_ms9836_1, ioc$dt_msxmd_3, ioc$dt_ms5832_1,
         ioc$dt_ms5832_2, ioc$dt_ms5833_1, ioc$dt_ms5833_1p,
         ioc$dt_ms5833_2, ioc$dt_ms5833_3p, ioc$dt_ms5833_4,
         ioc$dt_ms5838_1, ioc$dt_ms5838_1p, ioc$dt_ms5838_2,
         ioc$dt_ms5838_3p, ioc$dt_ms5838_4 =
        IF pp_response_p^.response_length > ioc$min_response_length THEN
          msg := 'SR    ,  RP                                                  ';
          iop$ascii_hex (^msg (3, *), 4, disk_status_9836_1_p^.ipi_channel_status_register);
          IF cmv$logical_pp_table_p^ [pp].controller_info.controller_type = cmc$ms5831_x THEN
            msg(1,8) := 'PU  (16)';
            i := disk_status_9836_1_p^.unit MOD 40(8);
            iop$ascii_hex (^msg (3, *), 2, i);
          ELSE
            iop$ascii_hex (^msg (3, *), 4, disk_status_9836_1_p^.ipi_channel_status_register);
          IFEND;
          packet_length :=  disk_status_9836_1_p^.response_packets [1]*100(16) +
                     disk_status_9836_1_p^.response_packets [2];
          FOR i := 0 TO 3 DO
            line_index := 13;
            FOR j := 0 TO 9 DO
              IF packet_length > (i*20 + j*2 - 2) THEN
                word1 := disk_status_9836_1_p^.response_packets [i*20 + j*2 + 1]*100(16) +
                         disk_status_9836_1_p^.response_packets [i*20 + j*2 + 2];
                iop$ascii_hex (^msg (line_index, *), 4, word1);
                line_index := line_index + 5;
              IFEND;
            FOREND;
            IF packet_length > (i*20 - 2) THEN
              dpp$display_error (msg);
              msg := '                                                            ';
            IFEND;
          FOREND;
        IFEND;
      ELSE
      CASEND;
    IFEND;



{Call dsp$report_system_message.

    IF (NOT previous_error) OR (down_status <> ioc$no_change) THEN
      dsp$report_system_message (seq_p, msg_type, msg_level,
            msg_recorded);
    IFEND;




  PROCEND iop$log_disk_error;
?? TITLE := 'iop$ascii_octal', EJECT ??

  PROCEDURE iop$ascii_octal (msg: ^string ( * );
        number_of_characters: 1 .. 6;
        word: 0 .. 0ffff(16));

    VAR
      i: integer,
      k: integer,
      divisor: [STATIC] array [1 .. 6] of integer := [1, 8, 64, 512, 4096,
        32768];


    k := 1;
    FOR i := number_of_characters DOWNTO 1 DO
      msg^ (i) := CHR (((word DIV divisor [k]) MOD 8) + ORD ('0'));
      k := k + 1;
    FOREND;

  PROCEND iop$ascii_octal;
?? TITLE := 'iop$ascii_decimal', EJECT ??

  PROCEDURE iop$ascii_decimal (msg: ^string ( * );
        number_of_characters: 1 .. 4;
        word: 0 .. 0ffff(16));

    VAR
      i: integer,
      k: integer,
      divisor: [STATIC] array [1 .. 4] of integer := [1, 10, 100, 1000];


    k := 1;
    FOR i := number_of_characters DOWNTO 1 DO
      msg^ (i) := CHR (((word DIV divisor [k]) MOD 10) + ORD ('0'));
      k := k + 1;
    FOREND;
  PROCEND iop$ascii_decimal;
?? TITLE := 'iop$ascii_hex', EJECT ??

  PROCEDURE iop$ascii_hex (msg: ^string ( * );
        number_of_characters: 1 .. 4;
        word: 0 .. 0ffff(16));

    VAR
      i: integer,
      k: integer,
      value: integer,
      divisor: [STATIC] array [1 .. 4] of integer := [1, 16, 256, 4096];


    k := 1;
    FOR i := number_of_characters DOWNTO 1 DO
      value := (word DIV divisor [k]) MOD 16;
      IF value > 9 THEN
        value := value + 7;
      IFEND;
      msg^ (i) := CHR (value + ORD ('0'));
      k := k + 1;
    FOREND;
  PROCEND iop$ascii_hex;
?? TITLE := 'analyze_response_packets', EJECT ??

  PROCEDURE analyze_response_packets (
        disk_status_9836_1_p: ^iot$detailed_status_9836_1;
        response_length: iot$response_length;
        controller_type: 0 .. 0ff(16);
        disk_type: iot$unit_type;
    VAR response_packet: iot$9836_analyzed_response_pkt);

    VAR
      base_index: integer,
      next_length: integer,
      next_response_code: integer,
      temp: integer,
      response_packet_length: integer;

    response_packet.id23_present := FALSE;
    response_packet.id23_error_code := 0;
    response_packet.id23_facility_status := 0;
    response_packet.id24_present := FALSE;
    response_packet.id24_byte1_bit7 := FALSE;
    response_packet.id24_byte1_bit6 := FALSE;
    response_packet.id24_byte1_bit1 := FALSE;
    response_packet.id24_byte1_not_bit7_or_6 := FALSE;
    response_packet.id26_present := FALSE;
    response_packet.id26_byte2_bit6 := FALSE;
    response_packet.id26_byte2_bit5 := FALSE;
    response_packet.id26_byte2_bit4 := FALSE;
    response_packet.id26_byte10 := 0;
    response_packet.id26_error_code := 0;
    response_packet.id29_present := FALSE;
    response_packet.id29_byte2_bit6 := FALSE;
    response_packet.id29_byte2_bit5 := FALSE;
    response_packet.id29_byte2_bit4 := FALSE;
    response_packet.id29_byte2_bit3 := FALSE;
    response_packet.id29_byte2_bit2 := FALSE;
    response_packet.id29_byte6_bit7 := FALSE;
    response_packet.id29_error_code := 0;

    response_packet_length := disk_status_9836_1_p^.response_packets [1] *100(16) +
             disk_status_9836_1_p^.response_packets [2] + 2;
    IF response_packet_length > response_length - 80 THEN
      RETURN;
    IFEND;
    base_index := 11;
  /search_response_codes/
    WHILE base_index < response_packet_length DO
      next_length := disk_status_9836_1_p^.response_packets [base_index] + 1;
      next_response_code := disk_status_9836_1_p^.response_packets [base_index + 1];
      IF (base_index - 1 + next_length) > response_packet_length THEN
        EXIT /search_response_codes/;
      IFEND;
    /process_response_code/
      BEGIN
        CASE next_response_code OF
        = 23(16) =
          IF response_packet.id23_present THEN
            EXIT /process_response_code/;
          IFEND;
          IF next_length < 3b(16) THEN
            EXIT /process_response_code/;
          IFEND;
          response_packet.id23_present := TRUE;
          CASE disk_type OF
          = ioc$dt_ms9836_1, ioc$dt_msxmd_3, ioc$dt_ms5832_1,
            ioc$dt_ms5832_2, ioc$dt_ms5833_1, ioc$dt_ms5833_1p,
            ioc$dt_ms5833_2, ioc$dt_ms5833_3p, ioc$dt_ms5833_4,
            ioc$dt_ms5838_1, ioc$dt_ms5838_1p, ioc$dt_ms5838_2,
            ioc$dt_ms5838_3p, ioc$dt_ms5838_4 =
            IF (disk_status_9836_1_p^.response_packets [base_index + 1 + 1b(16)] MOD 80(16)) <> 0 THEN
              response_packet.id23_error_code := disk_status_9836_1_p^.response_packets
                       [base_index + 1 + 1b(16)] * 10000(16);
            ELSE
              response_packet.id23_error_code := disk_status_9836_1_p^.response_packets
                       [base_index + 1 + 38(16)];
            IFEND;
          ELSE
          CASEND;
          IF (disk_status_9836_1_p^.response_packets [base_index + 1 + 11(16)]) <> 0 THEN
            response_packet.id23_facility_status := disk_status_9836_1_p^.response_packets
                     [base_index + 1 + 11(16)];
          IFEND;
        = 24(16) =
          IF response_packet.id24_present THEN
            EXIT /process_response_code/;
          IFEND;
          IF next_length < 2 THEN
            EXIT /process_response_code/;
          IFEND;
          response_packet.id24_present := TRUE;
          IF (next_length > 8) AND (controller_type = 8)
                AND (disk_status_9836_1_p^.response_packets [base_index + 1 + 6] <> 0fe(16)) THEN
             IF disk_status_9836_1_p^.response_packets [base_index + 1 + 7] DIV 80(16) <> 0 THEN
               response_packet.id24_byte1_bit7 := TRUE;
               EXIT /process_response_code/;
             IFEND;
             IF disk_status_9836_1_p^.response_packets [base_index + 1 + 7] DIV 40(16) <> 0 THEN
               response_packet.id24_byte1_bit6 := TRUE;
               EXIT /process_response_code/;
             IFEND;
             response_packet.id24_byte1_not_bit7_or_6 := TRUE;
             EXIT /process_response_code/;
          IFEND;
          IF disk_status_9836_1_p^.response_packets [base_index + 1 + 1] DIV 80(16) <> 0 THEN
            response_packet.id24_byte1_bit7 := TRUE;
            EXIT /process_response_code/;
          IFEND;
          IF disk_status_9836_1_p^.response_packets [base_index + 1 + 1] DIV 40(16) <> 0 THEN
            response_packet.id24_byte1_bit6 := TRUE;
            EXIT /process_response_code/;
          IFEND;
          temp := disk_status_9836_1_p^.response_packets [base_index + 1 + 1] MOD 4(16);
          IF temp DIV 2 <> 0 THEN
            response_packet.id24_byte1_bit1 := TRUE;
            EXIT /process_response_code/;
          IFEND;
          response_packet.id24_byte1_not_bit7_or_6 := TRUE;
        = 26(16) =
          IF response_packet.id26_present THEN
            EXIT /process_response_code/;
          IFEND;
          IF next_length < 5 THEN
            EXIT /process_response_code/;
          IFEND;
          response_packet.id26_present := TRUE;
          temp := 0;
          IF controller_type = 8 THEN
            IF next_length > 11(16) THEN
              temp := disk_status_9836_1_p^.response_packets [base_index + 1 + 10(16)];
            IFEND;
            CASE disk_type OF
            = ioc$dt_ms9836_1, ioc$dt_msxmd_3, ioc$dt_ms5832_1,
              ioc$dt_ms5832_2, ioc$dt_ms5833_1, ioc$dt_ms5833_1p,
              ioc$dt_ms5833_2, ioc$dt_ms5833_3p, ioc$dt_ms5833_4,
              ioc$dt_ms5838_1, ioc$dt_ms5838_1p, ioc$dt_ms5838_2,
              ioc$dt_ms5838_3p, ioc$dt_ms5838_4 =
              IF next_length > 22(16) THEN
                response_packet.id26_error_code := disk_status_9836_1_p^.response_packets
                       [base_index + 1 + 21(16)] * 10000(16);
              IFEND;
            ELSE
            CASEND;
          ELSE
            IF next_length > 0b(16) THEN
              temp := disk_status_9836_1_p^.response_packets [base_index + 1 + 0a(16)];
            IFEND;
            IF next_length > 0c(16) THEN
              response_packet.id26_error_code := disk_status_9836_1_p^.response_packets
                       [base_index + 1 + 0b(16)] * 10000(16);
            IFEND;
          IFEND;
          response_packet.id26_byte10 := temp;
          temp := disk_status_9836_1_p^.response_packets [base_index + 1 + 2] MOD 80(16);
          IF temp DIV 40(16) <> 0 THEN
            response_packet.id26_byte2_bit6 := TRUE;
            EXIT /process_response_code/;
          IFEND;
          IF temp DIV 20(16) <> 0 THEN
            response_packet.id26_byte2_bit5 := TRUE;
            EXIT /process_response_code/;
          IFEND;
          IF temp DIV 10(16) <> 0 THEN
            response_packet.id26_byte2_bit4 := TRUE;
            EXIT /process_response_code/;
          IFEND;
        = 29(16) =
          IF response_packet.id29_present THEN
            EXIT /process_response_code/;
          IFEND;
          IF next_length < 3 THEN
            EXIT /process_response_code/;
          IFEND;
          response_packet.id29_present := TRUE;
          IF controller_type = 8 THEN
            IF next_length > 22(16) THEN
              response_packet.id29_error_code := disk_status_9836_1_p^.response_packets
                       [base_index + 1 + 21(16)] * 10000(16);
            IFEND;
            IF next_length > 6 THEN
              IF disk_status_9836_1_p^.response_packets [base_index + 1 + 6] DIV 40(16) <> 0 THEN
                response_packet.id29_byte6_bit7 := TRUE;
              IFEND;
            IFEND;
          ELSE
            IF next_length > 10(16) THEN
              response_packet.id29_error_code := disk_status_9836_1_p^.response_packets
                       [base_index + 1 + 0f(16)] * 10000(16);
            IFEND;
          IFEND;
          temp := disk_status_9836_1_p^.response_packets [base_index + 1 + 2] MOD 80(16);
          IF temp DIV 40(16) <> 0 THEN
            response_packet.id29_byte2_bit6 := TRUE;
            EXIT /process_response_code/;
          IFEND;
          IF temp DIV 20(16) <> 0 THEN
            response_packet.id29_byte2_bit5 := TRUE;
            EXIT /process_response_code/;
          IFEND;
          IF temp DIV 10(16) <> 0 THEN
            response_packet.id29_byte2_bit4 := TRUE;
            EXIT /process_response_code/;
          IFEND;
          IF temp DIV 8 <> 0 THEN
            response_packet.id29_byte2_bit3 := TRUE;
            EXIT /process_response_code/;
          IFEND;
          IF temp DIV 4 <> 0 THEN
            response_packet.id29_byte2_bit2 := TRUE;
            EXIT /process_response_code/;
          IFEND;
        ELSE
        CASEND;
      END /process_response_code/;
      IF next_length MOD 2 <> 0 THEN
        next_length := next_length + 1;
      IFEND;
      base_index := base_index + next_length;
    WHILEND /search_response_codes/;

  PROCEND analyze_response_packets;
?? TITLE := 'simulate_disk_fault', EJECT ??

  PROCEDURE simulate_disk_fault (completed_request_p: ^iot$disk_request;
                                 VAR normal: iot$io_error);
    VAR
      disk_fault: integer;

    IF normal <> ioc$no_error THEN
      RETURN;
    IFEND;
    FOR disk_fault := LOWERBOUND (osv$simulated_disk_fault)
          TO UPPERBOUND (osv$simulated_disk_fault) DO
      IF osv$simulated_disk_fault [disk_fault].in_use THEN
        IF osv$simulated_disk_fault [disk_fault].sfid =
              completed_request_p^.request_info.system_file_id THEN
          IF (osv$simulated_disk_fault [disk_fault].read_fault AND
                ((completed_request_p^.request_info.io_function =
                ioc$read_page) OR (completed_request_p^.request_info.io_function =
                ioc$swap_in) OR (completed_request_p^.request_info.io_function =
                ioc$read_for_server))) OR (osv$simulated_disk_fault [disk_fault].
                write_fault AND ((completed_request_p^.request_info.io_function =
                ioc$write_page) OR (completed_request_p^.request_info.io_function =
                ioc$write_locked_page) OR (completed_request_p^.request_info.io_function =
                ioc$swap_out) OR (completed_request_p^.request_info.io_function =
                ioc$write_for_server))) THEN
            IF (osv$simulated_disk_fault [disk_fault].first_byte <=
                  completed_request_p^.request_info.byte_address) AND
                  (osv$simulated_disk_fault [disk_fault].last_byte >=
                  completed_request_p^.request_info.byte_address) THEN
              IF osv$simulated_disk_fault [disk_fault].skip_count > 0 THEN
                osv$simulated_disk_fault [disk_fault].skip_count :=
                      osv$simulated_disk_fault [disk_fault].skip_count - 1;
              ELSE
                IF osv$simulated_disk_fault [disk_fault].count > 0 THEN
                  osv$simulated_disk_fault [disk_fault].count :=
                        osv$simulated_disk_fault [disk_fault].count - 1;
                  normal := osv$simulated_disk_fault [disk_fault].error_type;
                  RETURN;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    FOREND;
  PROCEND simulate_disk_fault;
MODEND iom$process_io_completions;
*DECK DECK=IOM$QUEUE_IMAGE_REQUEST EXPAND=TRUE
MODULE iom$queue_image_request;

*copyc OSD$DEFAULT_PRAGMATS
*copyc CMV$LOGICAL_UNIT_TABLE
*copyc OSK$KEYPOINTS
*copyc IOK$KEYPOINTS
*copyc SYC$MONITOR_REQUEST_CODES
*copyc IOT$RB_TRANSLATE_BYTE_ADDRESS
*copyc I#CALL_MONITOR
*copyc IOT$DEVICE_TABLE
*copyc IOE$ST_ERRORS
*copyc IOT$LOGICAL_UNIT
*copyc IOT$DISK_TYPE_TABLE
*copyc IOT$UNIT_TYPE
*copyc IOT$CYLINDER
*copyc DMT$MS_LOGICAL_DEVICE_ADDRESS
*copyc AMT$FILE_BYTE_ADDRESS
*copyc I$REAL_MEMORY_ADDRESS
*copyc JMT$AJL_ORDINAL
*copyc DMT$SYSTEM_FILE_ID
*copyc OST$HARDWARE_SUBRANGES
*copyc IOT$DISK_REQUEST
*copyc IOT$COMMAND
*copyc IOT$IMAGE_REQUEST
*copyc IOT$IO_REQUEST
*copyc OST$STATUS
*copyc IOT$NUMBER_OF_REQUESTS


  PROCEDURE [XDCL, #GATE] iop$queue_image_request (system_file_id:
    dmt$system_file_id;
        file_byte_address: amt$file_byte_address;
        length: ost$byte_count;
        image_request_area: ^SEQ ( * );
    VAR status: ost$status);

    VAR
      dmv$external_interrupt_selector: [XREF] 0 .. 0ff(16),
      osv$external_interrupt_selector: [XREF] 0 .. 0ff(16),
      iov$disk_type_table: [XREF] array [1 .. ioc$disk_type_count] of
        iot$disk_type_table,
      request_area: ^SEQ ( * ),
      image_request: iot$image_request,
      image_request_p: ^iot$image_request,
      image_disk_request: iot$image_disk_request,
      number_of_commands: iot$commands_per_request,
      command: iot$command,
      i: integer,
      command_p: ^iot$command,
      rma: integer,
      last_rma: integer,
      job_id: jmt$ajl_ordinal,
      cylinder: iot$cylinder,
      track: iot$track,
      sector: iot$sector,
      sector_offset_within_cylinder: 0 .. 1280,
      device_address: dmt$ms_logical_device_address,
      logical_unit: iot$logical_unit,
      index: 1 .. ioc$disk_type_count,
      request_block: iot$rb_translate_byte_address,
      dm_status: syt$monitor_status,
      next_io_request: ^iot$io_request,
      pva: ^cell,
      first: boolean,
      previous_io_request: ^iot$io_request,
      previous_request: ^iot$image_disk_request,
      search_test: boolean,
      p_unit_table: ^iot$unit_interface_table,
      word_boundary: integer;



    status.normal := TRUE;
    #INLINE ('keypoint', osk$entry, 0, iok$queue_image_request);

  /image/
    BEGIN

      request_area := image_request_area;
      NEXT image_request_p IN request_area;

      word_boundary := image_request_p^.image_disk_request.request_length -
            (image_request_p^.image_disk_request.request_length DIV 8) * 8;
      IF word_boundary <> 0 THEN
        status.normal := FALSE;
        status.condition := ioc$invalid_image_request;
        EXIT /image/;
      IFEND;

      image_request_p^.image_disk_request.recovery := ioc$attempt_recovery;
      image_request_p^.image_disk_request.interrupt.value := FALSE;
      image_request_p^.image_disk_request.interrupt.port_number :=
          osv$external_interrupt_selector;
      image_request_p^.image_disk_request.priority := 1;
      image_request_p^.image_disk_request.alert_mask.long_input_block := FALSE;
      image_request_p^.image_disk_request.alert_mask.compare_not_satisfied :=
            TRUE;
      image_request_p^.image_disk_request.alert_mask.physical_delimiter :=
            FALSE;
      image_request_p^.image_disk_request.alert_mask.logical_delimiter :=
            FALSE;
      image_request_p^.image_disk_request.alert_mask.character_fill := FALSE;
      image_request_p^.io_request.device_request_p := ^image_request_p^.
            image_disk_request;



      number_of_commands := (image_request_p^.image_disk_request.request_length
            - #SIZE (image_disk_request)) DIV #SIZE (command);
      FOR i := 1 TO number_of_commands DO
        NEXT command_p IN request_area;
        CASE command_p^.command_code OF
        = ioc$cc_write_bytes, ioc$cc_read_bytes =
        ELSE
          status.normal := FALSE;
          status.condition := ioc$invalid_image_request;
          EXIT /image/;
        CASEND;
        word_boundary := command_p^.length - (command_p^.length DIV 8) * 8;
        IF word_boundary <> 0 THEN
          status.normal := FALSE;
          status.condition := ioc$invalid_image_request;
          EXIT /image/;
        IFEND;
        word_boundary := command_p^.address - (command_p^.address DIV 8) * 8;
        IF word_boundary <> 0 THEN
          status.normal := FALSE;
          status.condition := ioc$invalid_image_request;
          EXIT /image/;
        IFEND;
      FOREND;

{Check if request crosses a page boundary.
      i#real_memory_address (#LOC (image_request_p^.image_disk_request), rma);
      i#real_memory_address (#LOC (command_p^), last_rma);
      IF last_rma - rma - image_request_p^.image_disk_request.request_length +
            #SIZE (command) <> 0 THEN
        status.normal := FALSE;
        status.condition := ioc$invalid_image_request;
        EXIT /image/;
      IFEND;

{Call a monitor process to issue dmp$write.}
      request_block.request_code := syc$rc_translate_byte_address;
      request_block.system_file_id := system_file_id;
      request_block.file_byte_address := file_byte_address;
      request_block.length := length;

      i#call_monitor (#LOC (request_block), #SIZE (request_block));
      IF request_block.status.normal = FALSE THEN
        status.normal := FALSE;
        status.condition := request_block.status.condition;
        EXIT /image/;
      IFEND;

      device_address := request_block.device_address;


      logical_unit := image_request_p^.image_disk_request.logical_unit;
      index := cmv$logical_unit_table^ [logical_unit].
            unit_interface_table^.unit_type - 100(16) + 1;

      IF device_address.transfer_length * iov$disk_type_table [index].
            bytes_per_mau < length THEN
        status.normal := FALSE;
        status.condition := ioc$invalid_image_request;
        EXIT /image/;
      IFEND;

{Calculate cylinder, track, and sector.}
      cylinder := device_address.allocation_unit_mau_address DIV
            (device_address.maus_per_position);
      sector_offset_within_cylinder := (device_address.
            allocation_unit_mau_address - (cylinder * device_address.
            maus_per_position)) * iov$disk_type_table [index].sectors_per_mau;
      sector_offset_within_cylinder := sector_offset_within_cylinder +
            device_address.transfer_mau_offset * iov$disk_type_table [index].
            sectors_per_mau;
      track := sector_offset_within_cylinder DIV iov$disk_type_table [index].
            sectors_per_track;

      sector := sector_offset_within_cylinder - (track * iov$disk_type_table
            [index].sectors_per_track);
      image_request_p^.image_disk_request.cylinder := cylinder;
      image_request_p^.image_disk_request.track := track;
      image_request_p^.image_disk_request.sector := sector;

{Insert request in queue.}
      p_unit_table := cmv$logical_unit_table^ [logical_unit].
            unit_interface_table;
      p_unit_table^.unit_status.fill4 := 1;
      next_io_request := p_unit_table^.next_request;
      i#real_memory_address (#LOC (image_request_p^.image_disk_request), rma);
      image_request_p^.image_disk_request.next_pp_request := NIL;
      image_request_p^.image_disk_request.next_pp_request_rma := 0;
      search_test := TRUE;
      first := TRUE;

    /loop4/
      WHILE search_test DO
        IF next_io_request = NIL THEN
          IF first THEN
            pva := image_request_p;
            p_unit_table^.next_request := pva;
            p_unit_table^.next_request_rma := rma;
          ELSE
            pva := image_request_p;
            previous_request^.next_pp_request := pva;
            previous_request^.next_pp_request_rma := rma;
          IFEND;
          search_test := FALSE;
          EXIT /loop4/;
        IFEND;

        previous_io_request := next_io_request;
        previous_request := previous_io_request^.device_request_p;
        next_io_request := previous_request^.next_pp_request;
        first := FALSE;
      WHILEND /loop4/;

{Increment queue count.}
      IF p_unit_table^.queue_count = 0ffff(16) THEN
        p_unit_table^.queue_count := 0;
      IFEND;
      p_unit_table^.queue_count := p_unit_table^.queue_count + 1;

    END /image/;

    #INLINE ('keypoint', osk$exit, 0, iok$queue_image_request);



  PROCEND iop$queue_image_request;
MODEND iom$queue_image_request;
*DECK DECK=IOM$QUEUE_PP_REQUEST EXPAND=TRUE
MODULE iom$queue_pp_request;

*copyc osd$default_pragmats
*copyc mtp$error_stop
*copyc i$real_memory_address
*copyc syt$monitor_request_code
*copyc iot$disk_request
*copyc ioe$st_errors
*copyc iot$io_request
*copyc iot$lockword
*copyc iot$pp_interface_table



  PROCEDURE [XDCL] iop$queue_pp_request (ppit_p: ^iot$pp_interface_table;
        request_p: ^iot$io_request;
    VAR status: syt$monitor_status);

    VAR
      iov$reject_interlock_set: [XREF] integer,
      p_lockword: ^iot$lockword,
      initial_lock: [STATIC] iot$lockword := [FALSE, 0, [FALSE, 0, 0]],
      new_lock: [STATIC] iot$lockword := [TRUE, 0, [TRUE, FALSE, 0, 0]],
      new_lock2: [STATIC] iot$lockword := [TRUE, 8000(16), [TRUE, FALSE, 0, 0]],
      actual_lock: iot$lockword,
      result: 0 .. 2,
      pp_request_p: ^iot$link,
      next_io_request: ^iot$io_request,
      previous_io_request: ^iot$io_request,
      previous_request: ^iot$link,
      count: integer,
      search_test: boolean,
      first: boolean,
      port: integer,
      time: integer,
      timeout: integer,
      rma: integer;


    status.normal := TRUE;


{Set pp queue lockword.}

    p_lockword := ^ppit_p^.lockword;
    port := 0;
    time := #free_running_clock (port);
    timeout := time + 10000;
    count := 0;

    REPEAT
      #compare_swap (p_lockword^, initial_lock, new_lock, actual_lock, result);
      count := count + 1;
      IF count >= 100 THEN
        time := #free_running_clock (port);
        count := 0;
      IFEND;
    UNTIL (result = 0) OR (time > timeout);

    IF result <> 0 THEN
      IF iov$reject_interlock_set < 0ffffffffffff(16) THEN
        iov$reject_interlock_set := iov$reject_interlock_set + 1;
      IFEND;
      status.normal := FALSE;
      status.condition := ioc$pp_interlock_set;
      RETURN;
    IFEND;


{Insert request in queue.}

    next_io_request := ppit_p^.pp_request_queue;
    pp_request_p := request_p^.pp_request_p;
    i#real_memory_address (#LOC (pp_request_p^), rma);
    pp_request_p^.next_pp_request := NIL;
    pp_request_p^.next_pp_request_rma := 0;
    search_test := TRUE;
    first := TRUE;

  /loop4/
    WHILE search_test DO
      IF next_io_request = NIL THEN
        IF first THEN
          ppit_p^.pp_request_queue := request_p;
          ppit_p^.pp_request_queue_rma := rma;
        ELSE
          previous_request^.next_pp_request := request_p;
          previous_request^.next_pp_request_rma := rma;
        IFEND;
        search_test := FALSE;
        EXIT /loop4/;
      IFEND;

      previous_io_request := next_io_request;
      previous_request := previous_io_request^.pp_request_p;
      next_io_request := previous_request^.next_pp_request;
      first := FALSE;
    WHILEND /loop4/;

{Clear pp queue lockword.}

    result := 2;
    WHILE result = 2 DO
      #compare_swap (p_lockword^, new_lock, initial_lock, actual_lock, result);
    WHILEND;
    IF result <> 0 THEN
      result := 2;
      WHILE result = 2 DO
        #compare_swap (p_lockword^, new_lock2, initial_lock, actual_lock,
                   result);
      WHILEND;
      IF result <> 0 THEN
        mtp$error_stop ('IO05 - invalid pp queue lockword');
      IFEND;
    IFEND;




  PROCEND iop$queue_pp_request;
MODEND iom$queue_pp_request;
*DECK DECK=IOM$QUEUE_REQUEST EXPAND=TRUE
?? RIGHT := 110 ??
MODULE iom$queue_request;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc amt$preset_value
*copyc cmc$logical_unit_constants
*copyc cmt$element_access
*copyc cmt$element_capabilities
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc dct$disk_cache_info
*copyc dfd$file_server_info
*copyc dfk$file_server_info_keypoints
*copyc dfv$file_server_info_enabled
*copyc dmp$read
*copyc dmp$transfer_unit_completed
*copyc dmp$write
*copyc dmt$chapter_number
*copyc dmt$error_condition_codes
*copyc dmt$minimum_allocation_unit
*copyc dmt$ms_logical_device_address
*copyc dpp$display_error
*copyc dsp$mtr_dft_puf_request
*copyc gfp$mtr_get_fde_p
*copyc gfp$mtr_get_sfid_from_fde_p
*copyc gft$file_desc_entry_p
*copyc gft$locked_file_desc_entry_p
*copyc gft$system_file_identifier
*copyc i$real_memory_address
*copyc ioe$st_errors
*copyc iok$keypoints
*copyc iop$process_disk_response
*copyc iop$process_io_completions
*copyc iot$command
*copyc iot$cylinder
*copyc iot$device_table
*copyc iot$disk_request
*copyc iot$disk_type_table
*copyc iot$io_function
*copyc iot$io_request
*copyc iot$io_request_type
*copyc iot$lockword
*copyc iot$logical_unit
*copyc iot$pp_interface_table
*copyc iot$request_heap_map
*copyc iot$request_recovery
*copyc iot$unit_interface_table
*copyc iot$unit_type
*copyc iov$disk_type_table_xdcl
*copyc jmp$get_ijle_p
*copyc jmt$ijl_ordinal
*copyc jmv$ajl_p
*copyc jmv$ijl_p
*copyc jmv$null_ijl_ordinal
*copyc mmp$aste_pointer
*copyc mmp$build_lock_rma_list
*copyc mmt$buffer_descriptor
*copyc mmt$io_identifier
*copyc mmt$rma_list
*copyc mtp$error_stop
*copyc osd$cybil_structure_definitions
*copyc osd$default_pragmats
*copyc osd$virtual_address
*copyc osk$keypoints
*copyc oss$mainframe_wired
*copyc oss$mainframe_wired_cb
*copyc ost$cpu_state_table
*copyc ost$hardware_subranges
*copyc ost$page_size
*copyc osv$simulated_disk_fault
*copyc ptk$performance_keypoints
*copyc syt$monitor_request_code
*copyc syv$perf_keypoints_enabled
?? POP ??

  VAR
    iov$actual_requests_resolved: [XDCL,#GATE, STATIC, oss$mainframe_wired] integer := 0,
    iov$command_heap: [XDCL, STATIC, oss$mainframe_wired_cb] iot$command_heap,

    iov$command_heap_map: [XDCL, STATIC, oss$mainframe_wired] iot$command_heap_map :=
          [REP ioc$command_map_count of FALSE],
    iov$empty_request_count: [XDCL, STATIC, oss$mainframe_wired] integer := ioc$request_heap_count,

    iov$empty_requests: [XDCL, STATIC, oss$mainframe_wired] ^iot$io_request := NIL,
    iov$empty_requests_end: [XDCL, STATIC, oss$mainframe_wired] ^^iot$io_request := ^iov$empty_requests,
    iov$enforce_read_priority: [XDCL,#GATE,STATIC, oss$mainframe_wired] boolean := FALSE,
    iov$read_priority_invoked: [XDCL,#GATE, STATIC, oss$mainframe_wired] integer := 0,
    iov$total_queue_calls: [XDCL,#GATE, STATIC,oss$mainframe_wired] integer := 0,

    iov$reject_address_buffer_full: [XDCL, STATIC, oss$mainframe_wired] integer := 0,
    iov$reject_down_unit: [XDCL, STATIC, oss$mainframe_wired] integer := 0,
    iov$reject_element_access: [XDCL, STATIC, oss$mainframe_wired] integer := 0,
    iov$reject_interlock_set: [XDCL, STATIC, oss$mainframe_wired] integer := 0,
    iov$reject_requests_full: [XDCL, STATIC, oss$mainframe_wired] integer := 0,
    iov$reject_unit_queue_limit: [XDCL, STATIC, oss$mainframe_wired] integer := 0,

    iov$request_heap: [XDCL, STATIC, oss$mainframe_wired_cb] iot$request_heap,

    iov$request_heap_map: [XDCL, STATIC, oss$mainframe_wired] iot$request_heap_map :=
          [REP ioc$request_heap_count of FALSE],

    iov$stream_requests: [XREF] array [0 .. 300] of ^iot$io_request,
    iov$stream_requests_end: [XREF] array [0 .. 300] of ^^iot$io_request,
    iov$stream_requests_search: [XDCL, STATIC, oss$mainframe_wired] integer := 0;
?? TITLE := 'iop$pager_io', EJECT ??

  PROCEDURE [XDCL] iop$pager_io
    (   fde_p: gft$locked_file_desc_entry_p;
        chapter_offset: ost$segment_offset;
        buffer_descriptor: mmt$buffer_descriptor;
        length: ost$byte_count;
        io_function: iot$io_function;
        io_identifier: mmt$io_identifier;
    VAR status: syt$monitor_status);

    VAR
      initial_request_info: [STATIC] iot$request_info := [0, 0, 0, 0,
        ioc$read_page, ioc$pager_io, [0, 0], [0, gfc$tr_job, 0], 0,
        FALSE, NIL, NIL, 0, 0, 0, 0, [FALSE, ioc$read_page, [0, 0], 0]],
      device_address: dmt$ms_logical_device_address,
      ijl_ordinal: jmt$ijl_ordinal,
      transfer_length: ost$byte_count,
      index: 1 .. ioc$disk_type_count,
      keypoint_pager_io: dft$keypoint_pager_io,
      keypoint_sfid: dft$keypoint_sfid,
      request_info: iot$request_info,
      system_file_id: gft$system_file_identifier;

    status.normal := TRUE;

    gfp$mtr_get_sfid_from_fde_p (fde_p, system_file_id, ijl_ordinal);

    IF dfv$file_server_info_enabled THEN
      keypoint_pager_io.io_function := io_function;
      keypoint_pager_io.pages := buffer_descriptor.page_count;
      keypoint_sfid.file_entry_index := system_file_id.file_entry_index;
      keypoint_sfid.residence := system_file_id.residence;
      #keypoint (dfk$file_server_info_class, osk$m * keypoint_pager_io.
            keypoint_data, dfk$pager_io_info);
      #keypoint (dfk$file_server_info_class, osk$m * keypoint_sfid.
            keypoint_data, dfk$sfid);
    IFEND;

{Call device management to translate the chapter_offset to a device_address.}

    CASE io_function OF
    = ioc$write_page, ioc$write_locked_page, ioc$explicit_write,
          ioc$compare_swap, ioc$write_verify, ioc$write_mass_storage,
            ioc$swap_out, ioc$keypoint_io, ioc$write_for_server  =
      dmp$write (fde_p, chapter_offset, length, io_function,
            device_address, status);
    = ioc$read_page, ioc$explicit_read, ioc$swap_in, ioc$read_uft, ioc$explicit_read_no_purge,
          ioc$read_mass_storage, ioc$read_for_server, ioc$read_ahead_on_server =
      dmp$read (fde_p, chapter_offset, length, device_address,
            status);
    ELSE
      mtp$error_stop ('IO14 - invalid io_function');
    CASEND;

    IF status.normal = FALSE THEN
      RETURN;
    IFEND;

    index := cmv$logical_unit_table^ [device_address.logical_unit_number].
          unit_interface_table^.unit_type - 100(16) + 1;
    transfer_length := device_address.transfer_length * iov$disk_type_table
          [index].bytes_per_mau;

{Calculate physical disk address and queue request.}
    request_info := initial_request_info;
    { request_info.request_type := ioc$pager_io;
    request_info.job_id := ijl_ordinal;
    request_info.system_file_id := system_file_id;
    request_info.byte_address := chapter_offset;
    request_info.io_function := io_function;
    request_info.preset_value := device_address.preset_value;
    request_info.io_identifier := io_identifier;
    iop$disk_request (request_info, buffer_descriptor, transfer_length, device_address, status);
  PROCEND iop$pager_io;
?? TITLE := 'iop$disk_request', EJECT ??

  PROCEDURE [XDCL] iop$disk_request (request_inf: iot$request_info;
        buffer_descriptor: mmt$buffer_descriptor;
        length: ost$byte_count;
        device_address: dmt$ms_logical_device_address;
    VAR status: syt$monitor_status);

    CONST
      osk$class_5 = osk$system_class + 5;

    VAR
      request_info: iot$request_info,
      starting_mau: dmt$mau_address,
      write_initialize: 0 .. 1,
      transfer_type: 0 .. 1,
      logical_unit: iot$logical_unit,
      cylinder: iot$cylinder,
      track: iot$track,
      sector: iot$sector,
      index: 1 .. ioc$disk_type_count,
      sector_offset_within_cylinder: 0 .. 1280,
      stream_ok: boolean,
      mau_count: 0 .. 3ff(16),
      next_sector_offset: 0 .. 1280;

    status.normal := TRUE;

    request_info := request_inf;
    logical_unit := device_address.logical_unit_number;
    index := cmv$logical_unit_table^ [logical_unit].unit_interface_table^.
          unit_type - 100(16) + 1;
    stream_ok := TRUE;

    IF device_address.write_translation = TRUE THEN
      request_info.au_was_previously_written := device_address.
            au_was_previously_written;
      transfer_type := 1;
    ELSE
      request_info.au_was_previously_written := TRUE;
      transfer_type := 0;
    IFEND;

{Calculate mau count.
    IF length <> 0 THEN
      mau_count := length DIV iov$disk_type_table [index].bytes_per_mau;
      IF (mau_count * iov$disk_type_table [index].bytes_per_mau) <> length THEN
        stream_ok := FALSE;
        mau_count := mau_count + 1;
      IFEND;
    ELSE
      mau_count := 0;
    IFEND;
    request_info.data_maus := mau_count;

{Calculate cylinder, track, and sector.}
    cylinder := device_address.allocation_unit_mau_address DIV (device_address.
          maus_per_position);
    sector_offset_within_cylinder := (device_address.
          allocation_unit_mau_address - (cylinder * device_address.
          maus_per_position)) * iov$disk_type_table [index].sectors_per_mau;
    IF request_info.au_was_previously_written = TRUE THEN
      sector_offset_within_cylinder := sector_offset_within_cylinder +
            device_address.transfer_mau_offset * iov$disk_type_table [index].
            sectors_per_mau;
      starting_mau := device_address.allocation_unit_mau_address +
            device_address.transfer_mau_offset;
      write_initialize := 0;
    ELSE
      IF length <> 0 THEN
        mau_count := device_address.maus_per_allocation_unit + mau_count
              - device_address.transfer_length;
      ELSE
        mau_count := device_address.maus_per_allocation_unit;
      IFEND;
      starting_mau := device_address.allocation_unit_mau_address;
      write_initialize := 1;
    IFEND;
    next_sector_offset := sector_offset_within_cylinder + (mau_count
          * iov$disk_type_table [index].sectors_per_mau);
    track := sector_offset_within_cylinder DIV iov$disk_type_table [index].
          sectors_per_track;

    sector := sector_offset_within_cylinder - (track * iov$disk_type_table
          [index].sectors_per_track);
    IF stream_ok THEN
      request_info.next_track := next_sector_offset DIV iov$disk_type_table
            [index].sectors_per_track;
      request_info.next_sector := next_sector_offset - (request_info.next_track *
            iov$disk_type_table [index].sectors_per_track);
    ELSE
      request_info.next_track := 0ffff(16);
      request_info.next_sector := 0ffff(16);
    IFEND;

{Check for errors in disk address.

    IF sector >= iov$disk_type_table [index].sectors_per_track THEN
      mtp$error_stop ('IO06 - invalid sector address');
    IFEND;
    IF track >= iov$disk_type_table [index].tracks_per_cylinder THEN
      mtp$error_stop ('IO07 - invalid track address');
    IFEND;
    IF cylinder >= iov$disk_type_table [index].cylinders_per_unit THEN
      mtp$error_stop ('IO08 - invalid cylinder address');
    IFEND;


    #INLINE ('keypoint', osk$class_5, (((logical_unit MOD 100(16)) * 1000(16))
          + (cylinder MOD 1000(16))) * osk$m, iok$disk_request_1);
    #INLINE ('keypoint', osk$class_5, (((((starting_mau MOD 200(16)) * 2) +
          transfer_type) * 2 + write_initialize) * 100(16) + request_info.
          system_file_id.file_hash MOD 100(16)) * osk$m, iok$disk_request_2);


{Queue request.}
    iop$queue_request (request_info, buffer_descriptor, length, logical_unit,
          cylinder, track, sector, mau_count, device_address, status);

  PROCEND iop$disk_request;
?? TITLE := 'iop$queue_request', EJECT ??

  PROCEDURE [XDCL] iop$queue_request (request_info: iot$request_info;
        buffer_descriptor: mmt$buffer_descriptor;
        length: ost$byte_count;
        logical_unit: iot$logical_unit;
        cylinder: iot$cylinder;
        track: iot$track;
        sector: iot$sector;
        mau_count: 0 .. 3ff(16);
        device_address: dmt$ms_logical_device_address;
    VAR status: syt$monitor_status);

    CONST
      ioc$preset_length = dmc$max_bytes_per_mau,
      ioc$preset_length_1 = dmc$max_bytes_per_mau DIV 8;

    TYPE
      iot$preset_buffer = packed record
        buffer: ALIGNED [0 MOD 4096]
            array [1 .. ioc$preset_length] of ost$byte,
      recend,

      iot$preset_buffer_1 = packed record
        buffer: ALIGNED [0 MOD 4096]
            array [1 .. ioc$preset_length_1] of integer,
      recend;

    VAR
      initial_lock: [STATIC] iot$lockword := [FALSE, 0, [FALSE, 0, 0]],
      new_lock: [STATIC] iot$lockword := [TRUE, 0, [TRUE, FALSE, 0, 0]],
      new_lock2: [STATIC] iot$lockword := [TRUE, 8000(16), [TRUE, FALSE, 0, 0]],

      preset_buffer: [STATIC, oss$mainframe_wired] iot$preset_buffer,
      preset_rma: [STATIC] integer,
      initialize_preset: [STATIC] boolean := FALSE,

      preset_buffer_1: [STATIC, oss$mainframe_wired] iot$preset_buffer_1,
      preset_rma_1: [STATIC] integer,
      initialize_preset_1: [STATIC] boolean := FALSE,
      cst_p: ^ost$cpu_state_table,
      fde_p: gft$file_desc_entry_p,
      actual_lock: iot$lockword,
      result: 0 .. 2,
      disk_request_p: ^iot$disk_request,
      io_request_p: ^iot$io_request,
      command_code: iot$command_code,
      r: 1 .. ioc$request_heap_count,
      ix: 1 .. 2 * ioc$command_map_count,
      jj: 1 .. 2 * ioc$command_heap_count,
      gr: 0 .. ioc$command_map_count,
      m: integer,
      command_group_count: 0 .. ioc$command_map_count,
      queue_count: integer,
      search_cylinder: integer,
      search_test: boolean,
      search_test2: boolean,
      found: boolean,
      last_command_index: [STATIC] 1 .. ioc$command_map_count := 1,
      address_pair_count: 0 .. mmc$max_rma_list_length,
      rma: integer,
      p_unit_table: ^iot$unit_interface_table,
      next_request: ^iot$disk_request,
      next_io_request: ^iot$io_request,
      index: 1 .. ioc$disk_type_count,
      previous_request: ^iot$disk_request,
      p_lockword: ^iot$lockword,
      wrap: boolean,
      cm: 1 .. 3,
      preset_length: 0 .. dmc$max_maus_per_transfer * 2048,
      first_preset_length: 0 .. dmc$max_maus_per_transfer * 2048,
      remaining_preset_length: 0 .. dmc$max_maus_per_transfer * 2048,
      preset_count: 0 .. ioc$command_map_count,
      first_preset_count: 0 .. ioc$command_map_count,
      remaining_preset_count: 0 .. ioc$command_map_count,
      total_address_pair_count: 0 .. ioc$command_map_count,
      i: 1 .. ioc$command_map_count,
      media_error: boolean,
      mau_offset_in_cylinder: dmt$maus_per_position,
      write_tu_status: dmt$write_tu_status,
      port: integer,
      time: integer,
      special: boolean,
      timeout: integer,
      count: integer,
      request_allocated: boolean,
      read_group: boolean,
      asid: ost$asid,
      aste_p: ^mmt$active_segment_table_entry,
      ijle_p: ^jmt$initiated_job_list_entry,
      keypt_unit_cyl: dct$keypoint_unit_cylinder,
      keypt_maus_preset: dct$keypoint_data,
      keypt_sfid: dct$keypoint_sfid,
      keypt_functions: dct$keypoint_functions,
      keypt_ijlo: dct$keypoint_ijlo,
      keypt_taskid: dct$keypoint_taskid,
      keypt_aste_data: dct$keypoint_aste_data,
      keypt_req_info: dct$keypoint_request_info,
      osv$disk_fault_simulation: [XREF] boolean,
      sfid: gft$system_file_identifier,
      t_status: syt$monitor_status;


    PROCEDURE iop$make_preset_command;
      disk_request_p^.request.command [cm].command_code :=
            ioc$cc_write_bytes;
{     disk_request_p^.request.command [cm].flags.store_response := TRUE;
      disk_request_p^.request.request_length := disk_request_p^.request.
            request_length + 8;
        disk_request_p^.request.command [cm].flags.indirect_address := TRUE;
        i#real_memory_address (#LOC (iov$command_heap [jj]), rma);
        disk_request_p^.request.command [cm].address := rma;
        FOR i := 1 TO preset_count DO
          iov$command_heap [jj].fill := 0;
         IF special THEN
          iov$command_heap [jj].rma := preset_rma_1;
         ELSE
          iov$command_heap [jj].rma := preset_rma;
         IFEND;
          IF preset_length > ioc$preset_length THEN
            iov$command_heap [jj].length := ioc$preset_length;
            preset_length := preset_length - ioc$preset_length;
          ELSE
            iov$command_heap [jj].length := preset_length;
          IFEND;
          jj := jj + 1;
        FOREND;
        disk_request_p^.request.command [cm].length := preset_count * 8;
    PROCEND iop$make_preset_command;





    #INLINE ('keypoint', osk$entry, 0, iok$queue_request);

  /queue_request/
    BEGIN


    /queue_request_error/
      BEGIN


        status.normal := TRUE;
        media_error := FALSE;
        mau_offset_in_cylinder := 0;
        request_allocated := FALSE;

        IF NOT (cmc$io_request_submission IN cmv$logical_unit_table^ [logical_unit].
              element_capability) THEN
          IF iov$reject_down_unit < 0ffffffffffff(16) THEN
            iov$reject_down_unit := iov$reject_down_unit
                  + 1;
          IFEND;
          status.condition := ioe$unit_disabled;
          EXIT /queue_request_error/;
        IFEND;

        IF iov$empty_request_count <= 10 THEN
          IF iov$reject_requests_full < 0ffffffffffff(16) THEN
            iov$reject_requests_full := iov$reject_requests_full + 1;
          IFEND;
          #INLINE ('keypoint', osk$unusual, 0, iok$requests_full);
          status.condition := ioe$requests_full;
          EXIT /queue_request_error/;
        IFEND;

        IF cmv$logical_unit_table^ [logical_unit].unit_interface_table^.
              queue_count >= 100 THEN
          IF iov$reject_unit_queue_limit < 0ffffffffffff(16) THEN
            iov$reject_unit_queue_limit := iov$reject_unit_queue_limit+ 1;
          IFEND;
          #INLINE ('keypoint', osk$unusual, 0, iok$requests_full);
          status.condition := ioe$requests_full;
          EXIT /queue_request_error/;
        IFEND;

         IF request_info.preset_value <>  0 THEN
           special := TRUE;
         ELSE
           special := FALSE;
         IFEND;

{Check for 0 words to transfer.

        IF request_info.au_was_previously_written = TRUE THEN
          IF (length = 0) OR (device_address.transfer_length = 0) THEN
            EXIT /queue_request/;
          IFEND;
        IFEND;

{Set command_code.

        CASE request_info.io_function OF
        = ioc$read_page, ioc$explicit_read, ioc$swap_in, ioc$read_mass_storage, ioc$explicit_read_no_purge,
             ioc$read_for_server, ioc$read_ahead_on_server =
          command_code := ioc$cc_read_bytes;
          IF NOT (cmc$read IN cmv$logical_unit_table^ [logical_unit].
                 element_access) THEN
            IF iov$reject_element_access < 0ffffffffffff(16) THEN
              iov$reject_element_access := iov$reject_element_access
                    + 1;
            IFEND;
            status.condition := ioe$unit_disabled;
            EXIT /queue_request_error/;
          IFEND;
          #INLINE ('keypoint', osk$debug, length * osk$m, iok$read_page);
        = ioc$write_page, ioc$write_locked_page, ioc$explicit_write,
              ioc$swap_out, ioc$write_mass_storage, ioc$keypoint_io,
              ioc$write_for_server =
          command_code := ioc$cc_write_bytes;
          IF NOT (cmc$write IN cmv$logical_unit_table^ [logical_unit].
                 element_access) THEN
            IF iov$reject_element_access < 0ffffffffffff(16) THEN
              iov$reject_element_access := iov$reject_element_access
                    + 1;
            IFEND;
            status.condition := ioe$unit_disabled;
            EXIT /queue_request_error/;
          IFEND;
          #INLINE ('keypoint', osk$debug, length * osk$m, iok$write_page);
        = ioc$compare_swap =
          command_code := ioc$cc_compare_swap;
          IF cmv$logical_unit_table^ [logical_unit].element_access <>
                 $cmt$element_access [cmc$read, cmc$write] THEN
            IF iov$reject_element_access < 0ffffffffffff(16) THEN
              iov$reject_element_access := iov$reject_element_access
                    + 1;
            IFEND;
            status.condition := ioe$unit_disabled;
            EXIT /queue_request_error/;
          IFEND;
        = ioc$write_verify =
          command_code := ioc$cc_write_verify;
          IF cmv$logical_unit_table^ [logical_unit].element_access <>
                 $cmt$element_access [cmc$read, cmc$write] THEN
            IF iov$reject_element_access < 0ffffffffffff(16) THEN
              iov$reject_element_access := iov$reject_element_access
                    + 1;
            IFEND;
            status.condition := ioe$unit_disabled;
            EXIT /queue_request_error/;
          IFEND;
        = ioc$read_uft =
          command_code := ioc$cc_read_flaws;
        = ioc$initialize_sectors =
          command_code := ioc$cc_initialize_sectors;
        ELSE
        CASEND;

{Find empty slot for request.}

        iop$find_empty_request (io_request_p, status);
        IF status.normal = FALSE THEN
          EXIT /queue_request_error/;
        IFEND;
        disk_request_p := io_request_p^.device_request_p;
        r := disk_request_p^.request_index;
        iov$request_heap_map [r] := TRUE;
        iov$empty_request_count := iov$empty_request_count - 1;
        request_allocated := TRUE;


{Prepare request.}
        disk_request_p^.request_info := request_info;
        disk_request_p^.request.logical_unit := logical_unit;
        disk_request_p^.request.cylinder := cylinder;
        disk_request_p^.request.track := track;
        disk_request_p^.request.sector := sector;
        disk_request_p^.request.mau_count := mau_count;
        IF request_info.request_type = ioc$device_io THEN
          disk_request_p^.request.interrupt.value := TRUE;
        IFEND;
        io_request_p^.response_processor_p :=
              ^iop$process_disk_response;

{Compute total number of address_pair_lengths required for command.

        index := cmv$logical_unit_table^ [logical_unit].unit_interface_table^.
              unit_type - 100(16) + 1;
        IF request_info.au_was_previously_written = FALSE THEN
          IF length = 0 THEN
            first_preset_length := device_address.maus_per_allocation_unit *
                  iov$disk_type_table [index].bytes_per_mau;
            remaining_preset_length := 0;
          ELSE
            first_preset_length := device_address.transfer_mau_offset *
                  iov$disk_type_table [index].bytes_per_mau;
            remaining_preset_length := (device_address.maus_per_allocation_unit
                  - (device_address.transfer_mau_offset + device_address.
                  transfer_length)) * iov$disk_type_table [index].
                  bytes_per_mau;
          IFEND;
        ELSE
          first_preset_length := 0;
          remaining_preset_length := 0;
        IFEND;

        IF first_preset_length <> 0 THEN
          first_preset_count := ((first_preset_length - 1) DIV ioc$preset_length) +
                1;
        ELSE
          first_preset_count := 0;
        IFEND;
        IF remaining_preset_length <> 0 THEN
          remaining_preset_count := ((remaining_preset_length - 1) DIV
                ioc$preset_length) + 1;
        ELSE
          remaining_preset_count := 0;
        IFEND;

        IF length <> 0 THEN
          address_pair_count := buffer_descriptor.page_count;
        ELSE
          address_pair_count := 0;
        IFEND;

        total_address_pair_count := address_pair_count + first_preset_count +
              remaining_preset_count;
        IF total_address_pair_count = 0 THEN

          command_group_count := 0;
        ELSE

{find empty slot for address_length_pairs.}
          found := FALSE;
          wrap := FALSE;
          search_test := TRUE;
          IF last_command_index + 1 <= ioc$command_map_count THEN
            ix := last_command_index + 1;
          ELSE
            ix := 1;
            wrap := TRUE;
          IFEND;
          command_group_count := (total_address_pair_count + ioc$command_group
                - 1) DIV ioc$command_group;

        /loop2/
          WHILE search_test DO
            IF ix + command_group_count - 1 <= ioc$command_map_count THEN
              search_test2 := TRUE;

            /loop3/
              WHILE search_test2 DO
                FOR gr := 0 TO command_group_count - 1 DO
                  IF iov$command_heap_map [ix + gr] = TRUE THEN
                    EXIT /loop3/;
                  IFEND;
                FOREND;
                found := TRUE;
                EXIT /loop2/;
              WHILEND /loop3/;
              ix := ix + gr + 1;
            ELSE
              ix := 1;
              wrap := TRUE;
            IFEND;
            IF wrap THEN
              IF ix >= (last_command_index - command_group_count + 1) THEN
                EXIT /loop2/;
              IFEND;
            IFEND;
          WHILEND /loop2/;


{Check if room was found for address_length pairs.

          IF found = FALSE THEN
{reject request.}
            IF iov$reject_address_buffer_full < 0ffffffffffff(16) THEN
              iov$reject_address_buffer_full := iov$reject_address_buffer_full
                    + 1;
            IFEND;
            #INLINE ('keypoint', osk$unusual, 0, iok$requests_full);
            status.condition := ioe$requests_full;
            EXIT /queue_request_error/;

          IFEND;

        IFEND;
        disk_request_p^.request_info.command_group_count :=
              command_group_count;

{Set up preset commands.

        IF initialize_preset = FALSE THEN
          FOR m := 1 to ioc$preset_length DO
            preset_buffer.buffer [m] := 0;
          FOREND;
          initialize_preset := TRUE;
          i#real_memory_address (#LOC (preset_buffer), preset_rma);
        IFEND;

        IF initialize_preset_1 = FALSE THEN
          FOR m := 1 to ioc$preset_length_1 DO
            preset_buffer_1.buffer [m] := 7000000000000000(16);
          FOREND;
          initialize_preset_1 := TRUE;
          i#real_memory_address (#LOC (preset_buffer_1), preset_rma_1);
        IFEND;


        jj := ((ix - 1) * ioc$command_group) + 1;
        cm := 1;
        IF first_preset_length + remaining_preset_length > 0 THEN
          IF first_preset_length > 0 THEN
            preset_length := first_preset_length;
            preset_count := first_preset_count;

            iop$make_preset_command;

            cm := cm + 1;
          IFEND;
          IF remaining_preset_length > 0 THEN
            preset_length := remaining_preset_length;
            preset_count := remaining_preset_count;
            cm := cm + 1;

            iop$make_preset_command;
            cm := cm - 1;
          IFEND;
        IFEND;

{Set up main command.

        IF length <> 0 THEN
          disk_request_p^.request.command [cm].command_code := command_code;
{       disk_request_p^.request.command [cm].flags.store_response := TRUE;
          disk_request_p^.request.command [cm].flags.indirect_address := TRUE;
          disk_request_p^.request_info.list_p := #LOC (iov$command_heap [jj]);
          disk_request_p^.request_info.list_length := address_pair_count;
          disk_request_p^.request.command [cm].length := address_pair_count *
                8;
          i#real_memory_address (disk_request_p^.request_info.list_p, rma);
          disk_request_p^.request.command [cm].address := rma;
        ELSE
{       disk_request_p^.request_info.list_length := 0;
          disk_request_p^.request.request_length := disk_request_p^.request.
                request_length - 8;
        IFEND;

{Set unit queue lockword.}

        p_lockword := ^cmv$logical_unit_table^ [logical_unit].
              unit_interface_table^.unit_q_lockword;

        port := 0;
        time := #free_running_clock (port);
        timeout := time + 10000;
        count := 0;

        REPEAT
          #compare_swap (p_lockword^, initial_lock, new_lock, actual_lock,
                result);
          count := count + 1;
          IF count >= 100 THEN
            time := #free_running_clock (port);
            count := 0;
          IFEND;
        UNTIL (result = 0) OR (time > timeout);

        IF result <> 0 THEN
          IF iov$reject_interlock_set < 0ffffffffffff(16) THEN
            iov$reject_interlock_set := iov$reject_interlock_set + 1;
          IFEND;
          #INLINE ('keypoint', osk$unusual, logical_unit * osk$m,
                iok$interlock_set);
          status.condition := dme$transient_error;
          EXIT /queue_request_error/;
        IFEND;


{Lock pages.}

        IF length <> 0 THEN
          mmp$build_lock_rma_list (buffer_descriptor, length, request_info.
                io_function, disk_request_p^.request_info.list_p,
                address_pair_count, status);
          IF status.normal = FALSE THEN
            result := 2;
            WHILE result = 2 DO
              #compare_swap (p_lockword^, new_lock, initial_lock, actual_lock,
                    result);
            WHILEND;
            IF result <> 0 THEN
              result := 2;
              WHILE result = 2 DO
                #compare_swap (p_lockword^, new_lock2, initial_lock, actual_lock,
                   result);
              WHILEND;
              IF result <> 0 THEN
                mtp$error_stop ('IO04 - invalid unit queue lockword');
              IFEND;
            IFEND;
            #INLINE ('keypoint', osk$unusual, 0, iok$requests_full);
            EXIT /queue_request_error/;

          IFEND;
        IFEND;

{Set flags for space allocated.}

        IF command_group_count <> 0 THEN
          last_command_index := ix;
          FOR gr := 0 TO command_group_count - 1 DO

            iov$command_heap_map [ix + gr] := TRUE;
          FOREND;
          disk_request_p^.request_info.command_index := ix;
        IFEND;




{Insert request in queue.}
        p_unit_table := cmv$logical_unit_table^ [logical_unit].
              unit_interface_table;
        next_io_request := p_unit_table^.next_request;
        search_cylinder := cylinder;
        previous_request := NIL;

        iov$total_queue_calls := iov$total_queue_calls + 1;
      /loop4/
        WHILE next_io_request <> NIL DO
          next_request := next_io_request^.device_request_p;
{         IF iov$enforce_read_priority THEN

{ Check for read priority

{           IF (command_code = ioc$cc_read_bytes) AND
{                 (next_request^.request_info.io_function <> ioc$read_page) THEN
{             iov$read_priority_invoked := iov$read_priority_invoked + 1;
{             EXIT /loop4/;
{           IFEND;
{         IFEND;

          IF next_request^.request.cylinder > search_cylinder THEN
            EXIT /loop4/;
          IFEND;

          previous_request := next_request;
          next_io_request := next_request^.request.next_pp_request;

        WHILEND /loop4/;
        IF next_io_request <> NIL THEN
          disk_request_p^.request.next_pp_request := next_io_request;

          IF previous_request <> NIL THEN
            disk_request_p^.request.next_pp_request_rma :=
                  previous_request^.request.next_pp_request_rma;
          ELSE
            disk_request_p^.request.next_pp_request_rma :=
                  p_unit_table^.next_request_rma;
          IFEND;
        IFEND;

        i#real_memory_address (#LOC (disk_request_p^.request), rma);
        IF previous_request = NIL THEN
          p_unit_table^.next_request := io_request_p;
          p_unit_table^.next_request_rma := rma;
        ELSE
          previous_request^.request.next_pp_request := io_request_p;
          previous_request^.request.next_pp_request_rma := rma;
        IFEND;

{Increment queue count.}
        p_unit_table^.queue_count := p_unit_table^.queue_count + 1;

{Check if the pp should make an automatic switch to this request.
{(For streaming data between requests.)}

      /stream_test/
        BEGIN
          IF previous_request <> NIL THEN
            IF (previous_request^.request.cylinder = cylinder)
                  AND (previous_request^.request_info.next_track = track) AND
                  (previous_request^.request_info.next_sector = sector) THEN
              cm := (previous_request^.request.request_length -
                    ioc$min_request_length + 8) DIV 8;
              CASE previous_request^.request.command [cm].command_code OF
              = ioc$cc_read_bytes =
                IF disk_request_p^.request.command [1].command_code <>
                      ioc$cc_read_bytes THEN
                  EXIT /stream_test/;
                IFEND;
              = ioc$cc_write_bytes, ioc$cc_write_initialize =
                IF (disk_request_p^.request.command [1].command_code <>
                      ioc$cc_write_bytes) AND (disk_request_p^.request.command
                      [1].command_code <> ioc$cc_write_initialize) THEN
                  EXIT /stream_test/;
                IFEND;
              ELSE
                EXIT /stream_test/;
              CASEND;
              previous_request^.request.pp_switch := TRUE;
              iov$actual_requests_resolved := iov$actual_requests_resolved + 1;
            IFEND;
          IFEND;
        END /stream_test/;

{Clear unit queue lockword.}

        result := 2;
        WHILE result = 2 DO
          #compare_swap (p_lockword^, new_lock, initial_lock, actual_lock,
                result);
        WHILEND;
        IF result <> 0 THEN
          result := 2;
          WHILE result = 2 DO
            #compare_swap (p_lockword^, new_lock2, initial_lock, actual_lock,
                   result);
          WHILEND;
          IF result <> 0 THEN
            mtp$error_stop ('IO05 - invalid unit queue lockword');
          IFEND;
        IFEND;

        disk_request_p^.request_info.time := #free_running_clock (port);

        IF syv$perf_keypoints_enabled.disk_cache THEN
          keypt_unit_cyl.unit := logical_unit;
          keypt_unit_cyl.cylinder := cylinder;
          keypt_maus_preset := (first_preset_length + remaining_preset_length) DIV
                iov$disk_type_table[index].bytes_per_mau;
          keypt_functions.io_function := request_info.io_function;
          keypt_functions.command_code := command_code;
          keypt_functions.disk_type_index := index;

          CASE buffer_descriptor.buffer_descriptor_type OF
          = mmc$bd_paging_io, mmc$bd_explicit_io =
            asid := buffer_descriptor.sva.asid;
            mmp$aste_pointer (asid, aste_p);
            sfid := aste_p^.sfid;
            keypt_sfid.file_entry_index := sfid.file_entry_index;
            keypt_sfid.residence := sfid.residence;
            jmp$get_ijle_p (aste_p^.ijl_ordinal, ijle_p);
            gfp$mtr_get_fde_p (sfid, ijle_p, fde_p);
            keypt_ijlo.ijlo := aste_p^.ijl_ordinal;
            keypt_taskid.index := fde_p^.global_task_id.index;
            keypt_taskid.seqno := fde_p^.global_task_id.seqno;
            keypt_aste_data.segnum := fde_p^.last_segment_number;
            IF aste_p^.queue_id < mmc$pq_shared_first_site THEN
              keypt_aste_data.queue_id := aste_p^.queue_id;
            ELSEIF aste_p^.queue_id > mmc$pq_shared_last_site THEN
              keypt_aste_data.queue_id := aste_p^.queue_id - mmc$pq_shared_num_sites;
            ELSE { a shared site queue }
              keypt_aste_data.queue_id := 0f(16);
            IFEND;
            keypt_aste_data.stack_for_ring := fde_p^.stack_for_ring;

          = mmc$bd_job_swapping_io =
            keypt_sfid.file_entry_index := request_info.system_file_id.file_entry_index;
            keypt_sfid.residence := request_info.system_file_id.residence;
            keypt_ijlo.ijlo := buffer_descriptor.ijl_ordinal;
            keypt_taskid.keypoint_data := 0fffff(16);
            keypt_aste_data.keypoint_data := 0fffff(16);
          CASEND;

          keypt_req_info.request_type := request_info.request_type;
          IF device_address.write_translation THEN
            keypt_req_info.au_previously_written := device_address.au_was_previously_written;
          ELSE
            keypt_req_info.au_previously_written := TRUE;
          IFEND;

          #keypoint (osk$performance, osk$m * keypt_unit_cyl.keypoint_data, ptk$disk_unit);
          #keypoint (osk$performance, osk$m * device_address.allocation_unit_mau_address,
               ptk$disk_allocation_address);
          #keypoint (osk$performance, osk$m * device_address.transfer_mau_offset, ptk$disk_mau_offset);
          #keypoint (osk$performance, osk$m * device_address.transfer_length, ptk$disk_transfer_length);
          #keypoint (osk$performance, osk$m * keypt_maus_preset, ptk$disk_mau_preset);
          #keypoint (osk$performance, osk$m * keypt_sfid.keypoint_data, ptk$disk_sfid);
          #keypoint (osk$performance, osk$m * (request_info.byte_address MOD 100000(16)),
              ptk$disk_byte_address);
          #keypoint (osk$performance, osk$m * keypt_functions.keypoint_data, ptk$disk_function);
          #keypoint (osk$performance, osk$m * keypt_ijlo.keypoint_data, ptk$disk_ijlo);
          #keypoint (osk$performance, osk$m * keypt_taskid.keypoint_data, ptk$disk_task_id);
          #keypoint (osk$performance, osk$m * keypt_aste_data.keypoint_data, ptk$disk_aste);
          #keypoint (osk$performance, osk$m * keypt_req_info.keypoint_data, ptk$disk_request_info);
        IFEND;

        EXIT /queue_request/;

      END /queue_request_error/;

      status.normal := FALSE;

      IF request_allocated THEN
        disk_request_p^.link := iov$empty_requests;
        iov$empty_requests := io_request_p;
        IF iov$empty_requests_end = ^iov$empty_requests THEN
          iov$empty_requests_end := ^disk_request_p^.link;
        IFEND;
        iov$request_heap_map [r] := FALSE;
        iov$empty_request_count := iov$empty_request_count + 1;
      IFEND;

      IF request_info.request_type <> ioc$device_io THEN
        write_tu_status := dmc$tu_not_written;
        dmp$transfer_unit_completed (request_info.job_id, request_info.
              system_file_id, request_info.byte_address, write_tu_status,
              request_info.au_was_previously_written, media_error, cylinder,
              mau_offset_in_cylinder, request_info.io_function, t_status);
      IFEND;

    END /queue_request/;

    #INLINE ('keypoint', osk$exit, track * osk$m, iok$queue_request);
  PROCEND iop$queue_request;
?? TITLE := 'iop$find_empty_request', EJECT ??

  PROCEDURE [XDCL] iop$find_empty_request (VAR io_request_p:
        ^ iot$io_request;
    VAR status: syt$monitor_status);


    VAR
      initial_pp_request: [STATIC] iot$disk_pp_request := [0, NIL, 0, 0,
        ioc$min_request_length, 0, ioc$attempt_recovery, [FALSE, 1], 1,
        [FALSE, TRUE, FALSE, FALSE, FALSE,FALSE,0], FALSE, 0, 0, 0, 0, 0, [[0, [TRUE,
        FALSE, 0], 8, 0], [0, [TRUE, FALSE, 0], 8, 0], [0, [TRUE, FALSE, 0], 8,
        0]]],
      r: 1 .. ioc$request_heap_count,
      ix: 1 .. 2 * ioc$command_map_count,
      jj: 1 .. ioc$command_heap_count,
      i: integer,
      dmv$external_interrupt_selector: [XREF] 0 .. 0ff(16),
      osv$external_interrupt_selector: [XREF] 0 .. 0ff(16),
      initialize: [STATIC] boolean := FALSE,
      disk_request_p: ^iot$disk_request,
      first_rma: integer,
      last_rma: integer,
      rma: integer;







    status.normal := TRUE;

{Check for any request slots that cross a page boundary.}

    IF initialize = FALSE THEN
      initialize := TRUE;
      FOR r := 1 TO ioc$request_heap_count DO
        disk_request_p := ^iov$request_heap [r].disk_request;
        disk_request_p^.request_index := r;
        i#real_memory_address (#LOC (disk_request_p^.request), first_rma);
        i#real_memory_address (#LOC (disk_request_p^.request.command
              [ioc$command_count]), last_rma);

{set up device_request pointers.
        iov$request_heap [r].io_request.pp_request_p := ^iov$request_heap [r].
              disk_request.request;
        iov$request_heap [r].io_request.device_request_p := ^iov$request_heap [r].
              disk_request;

        IF first_rma + ioc$min_request_length + ioc$command_count * 8 - 16 <>
              last_rma THEN
          iov$request_heap_map [r] := TRUE;
          iov$empty_request_count := iov$empty_request_count - 1;
        ELSE
          iov$empty_requests_end^ := ^iov$request_heap [r].io_request;
          iov$empty_requests_end := ^iov$request_heap [r].disk_request.link;
          iov$empty_requests_end^ := NIL;
        IFEND;


      FOREND;

{Check for any indirect address_length slots that cross a page
{boundary.}

      i#real_memory_address (#LOC (iov$command_heap [1]), first_rma);
      FOR ix := 2 TO ioc$command_map_count DO
        jj := ((ix - 1) * ioc$command_group) + 1;
        i#real_memory_address (#LOC (iov$command_heap [jj]), last_rma);
        IF first_rma + (ioc$command_group * 8) <> last_rma THEN
          i#real_memory_address (#LOC (iov$command_heap [jj + ioc$command_group -
                1]), rma);
          IF last_rma + ((ioc$command_group - 1) * 8) <> rma THEN
            iov$command_heap_map [ix] := TRUE;
          ELSE
            iov$command_heap_map [ix - 1] := TRUE;
          IFEND;
        IFEND;
        first_rma := last_rma;
      FOREND;

{ Initialize iov$stream_requests.

      FOR i := 0 to 300 DO
        iov$stream_requests [i] := NIL;
        iov$stream_requests_end [i] := ^iov$stream_requests [i];
      FOREND;
    IFEND;


{ Check if there is an empty request.

    IF iov$empty_requests = NIL THEN
      check_stream_requests;
    IFEND;

    io_request_p := iov$empty_requests;
    IF (io_request_p <> NIL) THEN

{ Delink the request from the beginning of the chain.

      disk_request_p := io_request_p^.device_request_p;
      iov$empty_requests := disk_request_p^.link;
      IF iov$empty_requests = NIL THEN
        iov$empty_requests_end := ^iov$empty_requests;
      IFEND;
    ELSE

{No more empty request slots. Reject the request.}

      IF iov$reject_requests_full < 0ffffffffffff(16) THEN
        iov$reject_requests_full := iov$reject_requests_full + 1;
      IFEND;
      #INLINE ('keypoint', osk$unusual, 0, iok$requests_full);
      status.normal := FALSE;
      status.condition := ioe$requests_full;
      RETURN;

    IFEND;


{Set up part of the request.}

    disk_request_p^.request := initial_pp_request;
    IF dmv$external_interrupt_selector = 1 THEN
      disk_request_p^.request.interrupt.value := TRUE;
      disk_request_p^.request.interrupt.port_number :=
         osv$external_interrupt_selector;
    IFEND;
  PROCEND iop$find_empty_request;
?? TITLE := 'iop$reload_hung_disk_pp', EJECT ??

  PROCEDURE [XDCL] iop$reload_hung_disk_pp (
        hung_pp: iot$pp_number);

    VAR
      done: boolean,
      first_pp: iot$pp_number,
      first_unit: iot$logical_unit,
      index: integer,
      last_pp: iot$pp_number,
      last_unit: iot$logical_unit,
      partner_pp: iot$pp_number,
      pp: iot$pp_number,
      pp_com_p: ^iot$communication_buffer,
      pp_marks_p: ^array [*] of boolean,
      ppit_p: ^iot$pp_interface_table,
      uit_p: ^iot$unit_interface_table,
      unit: iot$logical_unit,
      unit_marks_p: ^array [*] of boolean;

    { Initialize marked PP list.

    first_pp := LOWERBOUND (cmv$logical_pp_table_p^);
    last_pp := UPPERBOUND (cmv$logical_pp_table_p^);
    PUSH pp_marks_p: [first_pp .. last_pp];

    FOR pp := first_pp TO last_pp DO
      pp_marks_p^ [pp] := FALSE;
    FOREND;

    { Initialize marked unit list.

    first_unit := LOWERBOUND (cmv$logical_unit_table^);
    last_unit := UPPERBOUND (cmv$logical_unit_table^);
    PUSH unit_marks_p: [first_unit .. last_unit];

    FOR unit := first_unit TO last_unit DO
      unit_marks_p^ [unit] := FALSE;
    FOREND;

    { Mark all PPs and units that are in common with the hung PP.  The goal is
    { to identify all PPs that must be reloaded and all units that must be
    { cleaned up.  A PP is marked for reload if it is the one that is hung or
    { if it shares units with another PP that is to be reloaded.  A unit is
    { marked for cleanup if it can be accessed by a PP that is being reloaded.
    { Note that the marking can ripple from PP to unit to PP to unit etc.,
    { depending on the configuration.

    pp_marks_p^ [hung_pp] := TRUE;
    mark_units (hung_pp, unit_marks_p^);

    REPEAT
      done := TRUE;
      FOR pp := first_pp TO last_pp DO
        IF NOT pp_marks_p^ [pp] AND unit_marked (pp, unit_marks_p^) THEN
          done := FALSE;
          pp_marks_p^ [pp] := TRUE;
          mark_units (pp, unit_marks_p^);
        IFEND;
      FOREND;
    UNTIL done;

    { For each marked PP:
    {   Hardware idle the PP.
    {   Hardware idle the partner PP, if applicable.
    {   Master clear the channel for the PP.
    {   Clear channel locks held by the PP.
    {   Clear the PP hung flag.
    {   Clear the PP communication buffer.
    {   Initialize appropriate fields in the PP interface table.

    FOR pp := first_pp TO last_pp DO
      IF pp_marks_p^ [pp] THEN
        idle_pp (pp);

        partner_pp := cmv$logical_pp_table_p^ [pp].pp_info.logical_partner_pp_index;
        IF (partner_pp <> 0) THEN
          idle_pp (partner_pp);
        IFEND;

        master_clear_channel (pp);

        clear_channel_locks (pp, cmv$logical_pp_table_p^ [pp].pp_info.channel_interlock_p^);

        cmv$logical_pp_table_p^ [pp].flags.pp_hung := FALSE;

        pp_com_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p;
        FOR index := LOWERBOUND (pp_com_p^.pp_usage) TO UPPERBOUND (pp_com_p^.pp_usage) DO
          pp_com_p^.pp_usage [index] := 0;
        FOREND;

        empty_response_buffer (pp);

        ppit_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;

        ppit_p^.active_check := FALSE;
        ppit_p^.idle_request := FALSE;
        ppit_p^.resume_request := FALSE;
        ppit_p^.idle_status := FALSE;
        ppit_p^.lock := FALSE;
        ppit_p^.lockword.lock := FALSE;
        ppit_p^.lockword.fill := 0;
        ppit_p^.lockword.lock_owner.cpu_lock := FALSE;
        ppit_p^.lockword.lock_owner.fill := 0;
        ppit_p^.lockword.lock_owner.pp_number := 0;
      IFEND;
    FOREND;

    { For each marked unit:
    {   Clear unit locks.
    {   Rebuild the unit queue.
    {   Clear the unit communication buffer.

    FOR unit := first_unit TO last_unit DO
      IF unit_marks_p^ [unit] THEN
        uit_p := cmv$logical_unit_table^ [unit].unit_interface_table;
        clear_unit_locks (uit_p^);
        rebuild_unit_queue (uit_p^);
        clear_unit_buffer (cmv$logical_unit_table^ [unit].unit_communication_buffer_pva^);
      IFEND;
    FOREND;

    { For each marked PP:
    {   Reload the PP.
    {   Reload the partner PP, if applicable.

    FOR pp := first_pp TO last_pp DO
      IF pp_marks_p^ [pp] THEN
        reload_pp (pp);

        partner_pp := cmv$logical_pp_table_p^ [pp].pp_info.logical_partner_pp_index;
        IF (partner_pp <> 0) THEN
          reload_pp (partner_pp);
        IFEND;
      IFEND;
    FOREND;
  PROCEND iop$reload_hung_disk_pp;
?? TITLE := 'ascii_octal', EJECT ??

  PROCEDURE ascii_octal (
        word: 0 .. 0ffff(16);
        number_of_characters: 1 .. 6;
    VAR msg: string ( * ));

    VAR
      i: integer,
      k: integer,
      divisor: [STATIC] array [1 .. 6] of integer := [1, 8, 64, 512, 4096,
        32768];

    k := 1;
    FOR i := number_of_characters DOWNTO 1 DO
      msg (i) := CHR (((word DIV divisor [k]) MOD 8) + ORD ('0'));
      k := k + 1;
    FOREND;
  PROCEND ascii_octal;
?? TITLE := 'check_stream_requests', EJECT ??

  PROCEDURE check_stream_requests;


    VAR
      disk_request_p: ^iot$disk_request,
      j: iot$logical_unit,
      p_unit_table: ^iot$unit_interface_table,
      next_request: ^iot$disk_request,
      next_io_request: ^iot$io_request;


    /loop/
      FOR j := cmc$job_template_unit_ordinal TO UPPERBOUND
            (cmv$logical_unit_table^) DO
        IF iov$stream_requests [j] <> NIL THEN
          p_unit_table := cmv$logical_unit_table^ [j].unit_interface_table;
          IF (p_unit_table <> NIL) AND (cmv$logical_unit_table^ [j].configured
                = TRUE) THEN
            IF (p_unit_table^.unit_type >= 100(16)) AND (p_unit_table^.
                  unit_type < (ioc$disk_type_count + 100(16))) THEN
              next_io_request := p_unit_table^.next_request;

              WHILE next_io_request <> NIL DO
                IF next_io_request = iov$stream_requests [j] THEN
                  CYCLE /loop/;
                IFEND;
                next_request := next_io_request^.device_request_p;
                next_io_request := next_request^.request.next_pp_request;
              WHILEND;

              iov$stream_requests_search := iov$stream_requests_search + 1;
              iov$empty_requests := iov$stream_requests [j];
              disk_request_p := iov$stream_requests [j] ^.device_request_p;
              iov$stream_requests [j] := disk_request_p^.link;
              IF iov$stream_requests [j] = NIL THEN
                iov$stream_requests_end [j] := ^iov$stream_requests [j];
              IFEND;
              disk_request_p^.link := NIL;
              iov$empty_requests_end := ^ disk_request_p^.link;
              EXIT /loop/;
            IFEND;
          IFEND;
        IFEND;
      FOREND /loop/;
  PROCEND check_stream_requests;
?? TITLE := 'clear_channel_locks', EJECT ??

  PROCEDURE clear_channel_locks (
        pp: iot$pp_number;
    VAR chit: iot$channel_interlock_table);

    VAR
      channel: integer,
      count: integer,
      lock: iot$table_lock_entry,
      result: 0 .. 2,
      time: integer,
      timeout: integer,
      unlocked: iot$table_lock_entry;

    unlocked.channel_locked := FALSE;
    unlocked.fill_1 := 0;
    unlocked.ve_need_channel := FALSE;
    unlocked.fill_2 := 0;
    unlocked.maintenance_need_channel := FALSE;
    unlocked.fill_3 := 0;
    unlocked.locking_pp := 0;

    time := #FREE_RUNNING_CLOCK (0);

    FOR channel := LOWERBOUND (chit.channel_table) TO UPPERBOUND (chit.channel_table) DO
      timeout := time + 100000;
      count := 0;
      lock := unlocked;

      REPEAT
        #COMPARE_SWAP (chit.channel_table [channel], lock, unlocked, lock, result);
        IF (result = 1) AND (lock.locking_pp <> pp) THEN
          result := 0;
        IFEND;
        count := count + 1;
        IF (count >= 100) THEN
          count := 0;
          time := #FREE_RUNNING_CLOCK (0);
        IFEND;
      UNTIL (result = 0) OR (time > timeout);
    FOREND;
  PROCEND clear_channel_locks;
?? TITLE := 'clear_unit_buffer', EJECT ??

  PROCEDURE clear_unit_buffer (
    VAR unit_buffer: iot$unit_communication_buffer);

    VAR
      buffer_p: ^array [1 .. *] of ost$byte,
      index: integer,
      unit_buffer_p: ^iot$unit_communication_buffer;

    unit_buffer_p := ^unit_buffer;
    RESET unit_buffer_p;
    NEXT buffer_p: [1 .. #SIZE (unit_buffer)] in unit_buffer_p;

    FOR index := LOWERBOUND (buffer_p^) TO UPPERBOUND (buffer_p^) DO
      buffer_p^ [index] := 0;
    FOREND;
  PROCEND clear_unit_buffer;
?? TITLE := 'clear_unit_locks', EJECT ??

  PROCEDURE clear_unit_locks (
    VAR uit: iot$unit_interface_table);

    VAR
      count: integer,
      lock: iot$lockword,
      result: 0 .. 2,
      time: integer,
      timeout: integer,
      unlocked: iot$lockword;

    unlocked.lock := FALSE;
    unlocked.fill := 0;
    unlocked.lock_owner.cpu_lock := FALSE;
    unlocked.lock_owner.fill := 0;
    unlocked.lock_owner.pp_number := 0;

    { Clear unit lock.

    uit.unit_lockword := unlocked;

    { Clear unit queue lock.

    time := #FREE_RUNNING_CLOCK (0);
    timeout := time + 100000;
    count := 0;
    lock := unlocked;

    REPEAT
      #COMPARE_SWAP (uit.unit_q_lockword, lock, unlocked, lock, result);
      IF (result = 1) AND lock.lock_owner.cpu_lock THEN
        result := 0;
      IFEND;
      count := count + 1;
      IF (count >= 100) THEN
        count := 0;
        time := #FREE_RUNNING_CLOCK (0);
      IFEND;
    UNTIL (result = 0) OR (time > timeout);

    IF (result = 2) THEN

      { The compare swap lock pattern must have been left set by a dead PP
      { or another CPU that died in the middle of a compare swap instruction.
      { In either case, clear the lock.

      uit.unit_q_lockword := unlocked;
    IFEND;
  PROCEND clear_unit_locks;
?? TITLE := 'empty_response_buffer', EJECT ??

  PROCEDURE empty_response_buffer (
        pp: iot$pp_number);

    VAR
      msg: string (40),
      ppit_p: ^iot$pp_interface_table;

    ppit_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;

    IF (ppit_p^.inn <> ppit_p^.out) THEN
      msg := 'In <> Out for PP __, IOU _, _CH ___.';
      get_pp_id_string (pp, msg (15, 21));

      dpp$display_error (msg);

      iop$process_io_completions;

      IF (ppit_p^.inn <> ppit_p^.out) THEN
        mtp$error_stop (msg);
      IFEND;
    IFEND;
  PROCEND empty_response_buffer;
?? TITLE := 'get_pp_id_string', EJECT ??

  PROCEDURE get_pp_id_string (
        pp: iot$pp_number;
    VAR id_string: string (21));

    VAR
      channel: dst$iou_resource,
      physical_pp: dst$iou_resource,
      port: cmt$channel_port;

    channel := cmv$logical_pp_table_p^ [pp].pp_info.channel;
    physical_pp := cmv$logical_pp_table_p^ [pp].pp_info.physical_pp;
    port := cmv$logical_pp_table_p^ [pp].pp_info.channel_port;

    id_string := 'PP __, IOU _,  CH __ ';

    ascii_octal (physical_pp.number, 2, id_string (4, 2));

    ascii_octal (physical_pp.iou_number, 1, id_string (12, 1));

    IF (channel.channel_protocol = dsc$cpt_cio) THEN
      id_string (15, 1) := 'C';
    IFEND;

    ascii_octal (channel.number, 2, id_string (19, 2));

    IF (port = cmc$port_a) THEN
      id_string (21, 1) := 'A';
    ELSEIF (port = cmc$port_b) THEN
      id_string (21, 1) := 'B';
    IFEND;
  PROCEND get_pp_id_string;
?? TITLE := 'idle_pp', EJECT ??

  PROCEDURE idle_pp (
        pp: iot$pp_number);

    VAR
      msg: string (40),
      seq_p: ^SEQ ( * ),
      status: syt$monitor_status;

    seq_p := NIL;

    dsp$mtr_dft_puf_request (dsc$dpuf_idle_pp, pp, 0, seq_p, status);

    IF NOT status.normal THEN
      msg := 'Idle of PP __, IOU _, _CH ___ failed.';
      get_pp_id_string (pp, msg (9, 21));
      mtp$error_stop (msg);
    IFEND;
  PROCEND idle_pp;
?? TITLE := 'mark_units', EJECT ??

  PROCEDURE mark_units (
        pp: iot$pp_number;
    VAR unit_marks: array [*] of boolean);

    VAR
      ppit_p: ^iot$pp_interface_table,
      unit: iot$logical_unit;

    ppit_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;

    FOR unit := LOWERBOUND (ppit_p^.unit_descriptors) TO UPPERBOUND (ppit_p^.unit_descriptors) DO
      IF (ppit_p^.unit_descriptors [unit].unit_interface_table_rma <> 0) THEN
        unit_marks [unit] := TRUE;
      IFEND;
    FOREND;
  PROCEND mark_units;
?? TITLE := 'master_clear_channel', EJECT ??

  PROCEDURE master_clear_channel (
        pp: iot$pp_number);

    VAR
      msg: string (50),
      seq_p: ^SEQ ( * ),
      status: syt$monitor_status;

    seq_p := NIL;

    dsp$mtr_dft_puf_request (dsc$dpuf_master_clear_channel, pp, 0, seq_p, status);

    IF NOT status.normal THEN
      msg := 'Master clear of PP __, IOU _, _CH ___ failed.';
      get_pp_id_string (pp, msg (17, 21));
      mtp$error_stop (msg);
    IFEND;
  PROCEND master_clear_channel;
?? TITLE := 'rebuild_unit_queue', EJECT ??

  PROCEDURE rebuild_unit_queue (
    VAR uit: iot$unit_interface_table);

    VAR
      count: integer,
      index: integer,
      lock: iot$lockword,
      cpu_lock: iot$lockword,
      msg: string (50),
      result: 0 .. 2,
      time: integer,
      timeout: integer,
      unlocked: iot$lockword;

    { Lock unit queue.

    cpu_lock.lock := TRUE;
    cpu_lock.fill := 0;
    cpu_lock.lock_owner.cpu_lock := TRUE;
    cpu_lock.lock_owner.processor_id := FALSE;
    cpu_lock.lock_owner.module_id := 0;
    cpu_lock.lock_owner.condition_handler := 0;

    unlocked.lock := FALSE;
    unlocked.fill := 0;
    unlocked.lock_owner.cpu_lock := FALSE;
    unlocked.lock_owner.fill := 0;
    unlocked.lock_owner.pp_number := 0;

    time := #FREE_RUNNING_CLOCK (0);
    timeout := time + 10000;
    count := 0;

    REPEAT
      #COMPARE_SWAP (uit.unit_q_lockword, unlocked, cpu_lock, lock, result);
      count := count + 1;
      IF (count >= 100) THEN
        count := 0;
        time := #FREE_RUNNING_CLOCK (0);
      IFEND;
    UNTIL (result = 0) OR (time > timeout);

    IF (result <> 0) THEN { Unable to lock unit queue }
      RETURN;
    IFEND;

    { Rebuild unit queue.

    uit.queue_count := 0;
    uit.next_request := NIL;
    uit.next_request_rma := 0;

    FOR index := LOWERBOUND (iov$request_heap) TO UPPERBOUND (iov$request_heap) DO
      IF iov$request_heap_map [index] AND (uit.logical_unit = iov$request_heap [index].disk_request.
            request.logical_unit) THEN
        requeue_request (iov$request_heap [index], uit);
      IFEND;
    FOREND;

    { Unlock unit queue.

    time := #FREE_RUNNING_CLOCK (0);
    timeout := time + 10000;
    count := 0;

    REPEAT
      #COMPARE_SWAP (uit.unit_q_lockword, cpu_lock, unlocked, lock, result);
      count := count + 1;
      IF (count >= 100) THEN
        count := 0;
        time := #FREE_RUNNING_CLOCK (0);
      IFEND;
    UNTIL (result <> 2) OR (time > timeout);

    IF (result <> 0) THEN
      timeout := time + 10000;
      cpu_lock.fill := 8000(16);
      REPEAT
        #COMPARE_SWAP (uit.unit_q_lockword, cpu_lock, unlocked, lock, result);
        IF (count >= 100) THEN
          count := 0;
          time := #FREE_RUNNING_CLOCK (0);
        IFEND;
      UNTIL (result <> 2) OR (time > timeout);
      IF (result <> 0) THEN
        mtp$error_stop ('IO05 - invalid unit queue lockword.');
      IFEND;
    IFEND;
  PROCEND rebuild_unit_queue;
?? TITLE := 'reload_pp', EJECT ??

  PROCEDURE reload_pp (
        pp: iot$pp_number);

    VAR
      msg: string (40),
      seq_p: ^SEQ ( * ),
      status: syt$monitor_status;

    seq_p := NIL;

    dsp$mtr_dft_puf_request (dsc$dpuf_load_pp, pp, 0, seq_p, status);

    IF status.normal THEN
      msg := 'Reloaded PP __, IOU _, _CH ___.';
      get_pp_id_string (pp, msg (10, 21));
      dpp$display_error (msg);
    ELSE
      msg := 'Reload of PP __, IOU _, _CH ___ failed.';
      get_pp_id_string (pp, msg (11, 21));
      mtp$error_stop (msg);
    IFEND;
  PROCEND reload_pp;
?? TITLE := 'requeue_request', EJECT ??

  PROCEDURE requeue_request (
    VAR request: iot$io_disk_request;
    VAR uit: iot$unit_interface_table);

    VAR
      current_p: ^iot$disk_request,
      cylinder: iot$cylinder,
      insert_p: ^iot$disk_request,
      next_p: ^iot$io_request,
      q_cylinder: iot$cylinder,
      q_time: integer,
      request_pva: ^iot$io_request,
      request_rma: integer,
      time: integer;

    cylinder := request.disk_request.request.cylinder;
    time := request.disk_request.request_info.time;
    request_pva := ^request.io_request;
    i#real_memory_address (#LOC (request.disk_request.request), request_rma);

    next_p := uit.next_request;
    insert_p := NIL;

    WHILE (next_p <> NIL) DO
      current_p := next_p^.device_request_p;
      q_cylinder := current_p^.request.cylinder;
      q_time := current_p^.request_info.time;
      IF (cylinder < q_cylinder) OR ((cylinder = q_cylinder) and (time < q_time)) THEN
        next_p := NIL;
      ELSE
        insert_p := current_p;
        next_p := current_p^.request.next_pp_request;
      IFEND;
    WHILEND;

    IF (insert_p = NIL) THEN
      request.disk_request.request.next_pp_request := uit.next_request;
      request.disk_request.request.next_pp_request_rma := uit.next_request_rma;
      uit.next_request := request_pva;
      uit.next_request_rma := request_rma;
    ELSE
      request.disk_request.request.next_pp_request := insert_p^.request.next_pp_request;
      request.disk_request.request.next_pp_request_rma := insert_p^.request.next_pp_request_rma;
      insert_p^.request.next_pp_request := request_pva;
      insert_p^.request.next_pp_request_rma := request_rma;
    IFEND;

    uit.queue_count := uit.queue_count + 1;
  PROCEND requeue_request;
?? TITLE := 'simulate_disk_fault', EJECT ??

  PROCEDURE simulate_disk_fault (request_info: iot$request_info;
                                 VAR status: syt$monitor_status);
    VAR
      disk_fault: integer;

    status.normal := TRUE;
    FOR disk_fault := LOWERBOUND (osv$simulated_disk_fault)
          TO UPPERBOUND (osv$simulated_disk_fault) DO
      IF osv$simulated_disk_fault [disk_fault].in_use THEN
        IF osv$simulated_disk_fault [disk_fault].sfid =
              request_info.system_file_id THEN
          IF (osv$simulated_disk_fault [disk_fault].
                write_fault AND ((request_info.io_function =
                ioc$write_page) OR (request_info.io_function =
                ioc$write_locked_page) OR (request_info.io_function =
                ioc$swap_out) OR (request_info.io_function =
                ioc$write_for_server))) OR (osv$simulated_disk_fault [disk_fault].
                read_fault AND (request_info.io_function =
                ioc$swap_in)) THEN
            IF (osv$simulated_disk_fault [disk_fault].first_byte <=
                  request_info.byte_address) AND
                  (osv$simulated_disk_fault [disk_fault].last_byte >=
                  request_info.byte_address) THEN
              IF osv$simulated_disk_fault [disk_fault].error_type =
                  ioc$unrecovered_error_unit_down THEN
                IF osv$simulated_disk_fault [disk_fault].skip_count > 0 THEN
                  osv$simulated_disk_fault [disk_fault].skip_count :=
                        osv$simulated_disk_fault [disk_fault].skip_count - 1;
                ELSE
                  IF osv$simulated_disk_fault [disk_fault].count > 0 THEN
                    osv$simulated_disk_fault [disk_fault].count :=
                          osv$simulated_disk_fault [disk_fault].count - 1;
                    status.normal := FALSE;
                    status.condition := ioe$unit_disabled;
                    RETURN;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    FOREND;
  PROCEND simulate_disk_fault;
?? TITLE := 'unit_marked', EJECT ??

  FUNCTION unit_marked (
        pp: iot$pp_number;
        unit_marks: array [*] of boolean): boolean;

    VAR
      ppit_p: ^iot$pp_interface_table,
      unit: iot$logical_unit;

    unit_marked := FALSE;

    IF NOT cmv$logical_pp_table_p^ [pp].flags.entry_in_use OR NOT
          cmv$logical_pp_table_p^ [pp].flags.configured OR
          (cmv$logical_pp_table_p^ [pp].pp_info.pp_type <> cmc$lpt_disk_pp_type) THEN
      RETURN;
    IFEND;

    IF (cmv$logical_pp_table_p^ [pp].pp_info.logical_partner_pp_index <> 0) AND
          cmv$logical_pp_table_p^ [pp].pp_info.pp_communication_buffer_p^.slave THEN
      RETURN;
    IFEND;

    ppit_p := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;

    FOR unit := LOWERBOUND (ppit_p^.unit_descriptors) TO UPPERBOUND (ppit_p^.unit_descriptors) DO
      IF (ppit_p^.unit_descriptors [unit].unit_interface_table_rma <> 0) AND unit_marks [unit] THEN
        unit_marked := TRUE;
        RETURN;
      IFEND;
    FOREND;
  FUNCEND unit_marked;
MODEND iom$queue_request;
*DECK DECK=IOM$REQUEST_PROCESSOR EXPAND=TRUE
?? RIGHT := 110 ??
*copy OSD$DEFAULT_PRAGMATS
?? TITLE := 'NOSVE Subsystem IO' ??
?? NEWTITLE := 'Module Header' ??
MODULE iom$request_processor;
{
{ PURPOSE :  This module processes monitor requests for the io subsystem.
{
{ DESIGN :  The subsystem request code is used to determine the monitor
{           request processor that will process the request.
{
?? TITLE := 'Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc OSK$KEYPOINTS
*copyc ioe$st_errors
*copyc iok$keypoints
*copyc iot$monitor_request_block
*copyc ost$global_task_id
*copyc SYT$MONITOR_REQUEST_CODE
?? POP ??
  ?? TITLE := 'XREF Procedures and Functions', EJECT ??
*copyc iop$mtr_set_status_abnormal
*copyc iop$subsystem_queue_request
*copyc cmp$unlock_wired_rma_list
?? TITLE := '  [XDCL] iop$request_processor', EJECT ??

      PROCEDURE [XDCL] iop$request_processor (VAR subsystem_request_block:
    iot$monitor_request_block);

    #keypoint (osk$entry, osk$m * ORD (subsystem_request_block.subsystem_request_code),
          iok$monitor_request);

    CASE subsystem_request_block.subsystem_request_code OF

     = ioc$queue_io_request =
       iop$subsystem_queue_request (subsystem_request_block);

     = ioc$unlock_rma_list=
       cmp$unlock_wired_rma_list (subsystem_request_block);

    ELSE
       iop$mtr_set_status_abnormal (ioe$unsupported_monitor_request,
            'Unsupported monitor request - IOMMREQ', subsystem_request_block.status);
    CASEND;

    #keypoint (osk$exit, 0,
          iok$monitor_request);

PROCEND iop$request_processor;

?? OLDTITLE ??
MODEND iom$request_processor;
*DECK DECK=IOM$RESUME EXPAND=TRUE
*DECK DECK=IOM$RESUME_ALL_PATHS EXPAND=TRUE
*DECK DECK=IOM$SDPD EXPAND=TRUE
          IDENT  SDPD
          CIPPU
          MEMSEL 16
          TITLE  SDPD - NOS/VE STORNET/ESM SDP PP DRIVER
*
*         WORD 6 OF THE FOLLOWING COMMENT MUST BE A REVISION NUMBER
*         FOR CTI.
*
          COMMENT *SMD* LVL=01
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
*
*         THIS IS THE PP DRIVER THAT SUPPORTS SIDE DOOR PORT ACCESS
*         TO STORNET/ESM. THIS DRIVER ASSUMES THAT THE CHANNEL CABLED TO
*         THE SIDE DOOR PORT IS A CYBER 170 CHANNEL. THIS DRIVER SUPPORTS
*         BOTH THE I4 AND I0 IOU'S. LOCATIONS 72-73 MUST CONTAIN THE RMA
*         OF THE PP INTERFACE TABLE AND LOCATION 0 MUST CONTAIN THE
*         STARTING ADDRESS MINUS ONE, AT WHICH EXECUTION BEGINS.
*
          LIST   -$
*COPYC IODMAC1
*COPYC IODMAC2
*COPYC IODMAC3
*COPYC IODMAC4

          LIST   B,L,N,R,G
          EJECT
*
*         GENERAL EQUATES
*
 UPKBFL   EQU    123B        LENGTH OF UNPACKED DATA BUFFER
 PKBFL    EQU    100B        LENGTH OF PACKED ERROR DATA BUFFER
 BUFFCM   EQU    21B         LENGTH OF PACKED BUFFER (CM WORDS)
 DC       EQU    22B         CHANNEL EQUATE FOR I/O INSTRUCTIONS
 PPNORM   EQU    1           NORMAL PP RESPONSE CODE
*
*         ERROR CODE EQUATES
*
 ER.CAE   EQU    2           CHANNEL ACTIVE ON ENTRY
 ER.NIF   EQU    3           NO INACTIVE TO FUNCTION
 ER.LDI   EQU    4           LOST DATA ON INPUT
 ER.CPE   EQU    5           CHANNEL PARITY ERROR ON INPUT
 ER.CNE   EQU    6           CHANNEL NOT EMPTY
 ER.CLE   EQU    7           CHANNEL LOCKWORD ERROR
*
*      SDP FUNCTION EQUATES
*
 FRSR     EQU    1040B       READ STATUS BITS REGISTERS
 FCLR     EQU    1203B       CLEAR SIDE DOOR PORT STATUS
 FREL     EQU    1010B       READ ERROR LOG
 FCEL     EQU    1011B       RESET ERROR LOG
 DCSP     EQU    1000B       DATA - SELECT CLEAR SDP STATUS
*
*      CYBER 930 ICI/C170 CHANNEL CONVERTER FUNCTION EQUATES
*
 ICI.DES  EQU    100000B     DESELECT C170 CHANNEL CONVERTER
 ICI.SEL  EQU    170000B     SELECT C170 CHANNEL CONVERTER
 ICI.12B  EQU    120000B     SET 12 BIT MODE

          SPACE  6
**
*         PPIT MEMORY MAP (SHOWS INFO ACCESSED BY SDPD)
*
*                  1 1          3 3          4 4 4 5 5 .. 6
*       0          5 6          1 2          7 8 9 0 1 .. 3
*      +------------+------------+------------+-+-+-+-+--+-+
*      |            |////////////|////////////|A|I|R|P|//|L|
* WD00 | PP NUMBER  |////////////|////////////|C|D|E|P|//|C|
*      |            |////////////|////////////|T|L|S|I|//|K|
*      +------------+------------+------------+-+-+-+-+--+-+
* WD01 |/////////////////////////|   CHANNEL TABLE RMA     |
*      +------------+------------+-------------------------+
* WD02 |////////////|////////////|   CM COMM BUFFER RMA    |
*      +-------------------------+-------------------------+
*
*         DEFINITIONS:
*          PP NUMBER  = LOGICAL PP NUMBER OF SDPD PP
*          ACT        = ACTIVE CHECK FLAG
*          IDL        = IDLE REQUEST FLAG
*          RES        = RESUME REQUEST FLAG
*          PPI        = PP IDLE STATUS FLAG
*          LCK        = LOCK FLAG

**
*         PP INTERFACE TABLE
 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
 ACTCH    BOOLEAN            ACTIVE CHECK, THE PP CLEARS THIS BIT WITHIN 1 MINUTE
 IDLREQ   BOOLEAN            IDLE REQUEST
 RESREQ   BOOLEAN            RESUME REQUEST
 PPIDLE   BOOLEAN            PP IDLE
          SUBRANGE 0,3777B   UNUSED
 LOCK     BOOLEAN            PP TABLE LOCK
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
 PIT      RECEND

          SPACE  10
**
*                CM COMMUNICATION BUFFER MAP
*
*      +------------+------------+-----------+------------+
* WD00 | CPU STATUS |  IOU TYPE  |  CHANNEL  |  0 0 0 0   |
*      +------------+-+----------+-----------+-+----------+
*      |            |C|          |           |C|          |
* WD01 | PPU STATUS |P| PP NUM.  |  IOU NUM. |C| CHANNEL  |
*      |            |P|          |           |H|          |
*      +------------+-+----------+-----------+-+----------+
* WD02 |                                                  |
*   :  |                  ERROR LOG DATA                  |
* WD16 |                                                  |
*      +---------------------------+----------------------+
* WD17 |   ERROR LOG DATA(36BITS)  |   000000000(28BITS)  |
*      +------------+--------------+----------------------+
* WD18 |  0 0 0 0   |    SIDE DOOR PORT STATUS(48BITS)    |
*      +------------+-------------------------------------+
*
*         DEFINITIONS:
*          CPU STATUS = 0000 CM BUFFER NOT INITIALIZED
*                       0001 CM BUFFER INITIALIZED
*          IOU TYPE       = 0000 IF I0 IOU
*                           0001 IF NON-I0 IOU
*          CHANNEL        = SIDE DOOR PORT CHANNEL NUMBER
*          PPU STATUS     = 0001 NORMAL COMPLETION STATUS
*                           0002 CHANNEL ACTIVE ON ENTRY ERROR
*                           0003 NO INACTIVE TO FUNCTION ERROR
*                           0004 LOST DATA ON INPUT ERROR
*                           0005 CHANNEL PARITY ERROR ON INPUT
*                           0006 CHANNEL NOT EMPTY ERROR
*                           0007 CHANNEL LOCKWORD ERROR
*          CPP            = 1 IF CIO PP
*                           0 IF NIO PP
*
*          PP             = PHYSICAL PP NUMBER FOR SDP DRIVER
*          IOU            = IOU NUMBER
*          CCH            = 1 IF CIO CHANNEL
*                           0 IF NIO CHANNEL
*          ERROR LOG DATA = 123(8) 12 BIT PP WORDS OF ERROR DATA
*          SDP STATUS     = 4 12 BIT PP WORDS OF SDP STATUS
*

**
*         CM COMMUNICATION RECORD STRUCTURE
*
 CB       RECORD PACKED

*         CB - WORD1
*
          ALIGN  0,64
 CPSTAT   BOOLEAN            1=COMMUNICATION BUFFER HAS BEEN INITIALIZED
          ALIGN  16,64
 IOUTYP   PPWORD             0=I0, 1=I4
 CHAN     PPWORD             LOGICAL CHANNEL NUMBER OF SDP

*         CB - WORD 2
*
          ALIGN  0,64
 PPSTAT   PPWORD             PP REQUEST STATUS
 CONPP    BOOLEAN            1=I4 CONCURRENT PP
          SUBRANGE 0,777B    UNUSED BITS
 PPNUM    SUBRANGE 0,77B     LOGICAL PP NUMBER OF PP USED TO ACCESS SDP
          SUBRANGE 0,1777B   UNUSED BITS
 IOUNO    SUBRANGE 0,77B     IOU NUMBER THAT SDP IS CONNECTED TO
 CONCH    BOOLEAN            1=CONCURRENT CHANNEL
          SUBRANGE 0,777B    UNUSED BITS
 CHNUM    SUBRANGE 0,77B     LOGICAL CHANNEL NUMBER OF SDP

*         CB - WORDS 3-18
*
 DATA     STRUCT   175B      15+ CM WORDS FOR ERROR LOG DATA

*         CB - WORD 19
*
          ALIGN    16,64
 STAT     STRUCT   6         RESERVE 48 BITS FOR SDP STATUS

 CB       RECEND

          EJECT
          CON    MAIN-1

* DIRECT CELLS

 T1       BSSZ   1
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1

 CMADR    BSSZ   3           CENTRAL MEMORY ADDRESS
 IOUTYP   BSSZ   1           TYPE OF IOU, 0=I0 1=NON-I0
 PPNO     BSSZ   1           LOGICAL PP NUMBER FROM PPIT
 CHAN     BSSZ   1           SIDE DOOR PORT CHANNEL NUMBER
 WC       BSSZ   1           WORD COUNT FOR DATA TRANSFER
 WD       BSSZ   1           WORD COUNT FOR CM TRANSFER

 FNC      BSSZ   1           FUNCTION CODE (INTERNAL)
 LF       BSSZ   1           LAST FUNCTION
 IDLE     BSSZ   1           NONZERO IF IDLE COMMAND RECEIVED,
                             RESUME COMMAND RESETS IT TO 0
 CLF      DATA   1           CHANNEL LOCK FLAG, 0 IF LOCK SET
 ERRCODE  BSSZ   1

* REFORMATTED CENTRAL MEMORY ADDRESSES
          ORG    50B
 CM.PPIT  BSSZ   3           CM ADDRESS OF PP INTERFACE TABLE
 CM.CIT   BSSZ   3           CM ADDRESS OF CHANNEL INTERLOCK TABLE
 CM.CMB   BSSZ   3           CM ADDRESS OF CM COMMUNICATIONS BUFFER

* LOCATIONS 72-73B CONTAIN PPIT RMA AT TIME PP IS LOADED
          ORG    72B
 PITRMA   BSSZ   2

          EJECT
          ORG    100B
          TITLE  MAIN LOOP
** NAME    - MAIN
*
** PURPOSE - SDPD EXECUTION CONTROL
*
** ENTRY   - NONE
*
** EXIT    - NONE
*
 MAIN     BSS
          RJM    INIT        PP INITIALIZATION

          RJM    SCLOCK      SET CHANNEL LOCK
          LDD    IOUTYP
          NJN    MAIN5       IF NOT I0 IOU
          RJM    SEL         SELECT CYBER ICI/C170 CHANNEL CONVERTER
 MAIN5    RJM    RDSTAT      READ SIDE DOOR PORT STATUS
          RJM    CSDP        CLEAR SIDE DOOR PORT STATUS
          RJM    PKSTAT      PACK STATUS DATA
          RJM    RDLOG       READ SIDE DOOR PORT ERROR LOG
          RJM    RELOG       RESET ERROR LOG
          LDD    IOUTYP
          NJN    MAIN10      IF NOT I0 IOU
          RJM    DESEL       DESELECT ICI/C170 CHANNEL CONVERTER
 MAIN10   RJM    CCLOCK      CLEAR CHANNEL LOCK
          RJM    PKLOG       PACK ERROR LOG DATA
          RJM    TRCMB       TRANSFER DATA TO CM COMM BUFFER
          LDK    PPNORM      NORMAL PP COMPLETION STATUS
          RJM    PPSTAT      REPORT PP STATUS

 MAIN20   RJM    PPRQ        SCAN PP REQUEST QUEUE
 MAIN35   UJK    MAIN20      HANG IN SCAN LOOP

          EJECT
          TITLE  SUBROUTINES
** NAME    - CCLOCK
*
** PURPOSE - CLEARS CHANNEL LOCK.
*
** ENTRY   - NONE
*
** EXIT    - CHANNEL LOCK CLEARED
*
 CCLOCK   SUBR               SUBROUTINE ENTRY/EXIT
          LDC    CM.CIT      CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          STDL   CLF         CHANNEL LOCK FLAG
          LDDL   CHAN        CHANNEL NUMBER = OFFSET IN TABLE
          STDL   T5
          RJM    CLOCK       CLEAR CHANNEL LOCKWORD
          RETURN             EXIT

          SPACE  5,20
** NAME    - CHGCH
*
** PURPOSE - SET CHANNEL NUMBER IN CHANNEL INSTRUCTIONS
*
** ENTRY   - (CHAN) = CHANNEL NUMBER
*
** EXIT    - CHANNEL IN ALL I/O INSTRUCTIONS SET TO SDP
*            CHANNEL NUMBER.
*
 CHGCH    SUBR               SUBROUTINE ENRTY/EXIT
          LDN    0
          STDL   T1          CHANGE DISK CHANNEL INSTRUCTIONS
 CHG10    LDML   CHTAB,T1    ADDRESS OF CHANNEL INSTRUCTIONS
          NJK    CHG12       IF MORE INSTRUCTIONS IN TABLE
          RETURN             EXIT
 CHG12    STDL   T2
          LDIL   T2
          SCN    37B
          LMDL   CHAN        CHANNEL NUMBER
          STIL   T2
          AODL   T1
          UJK    CHG10

          SPACE  5,20
** NAME    - CLOCK
*
** PURPOSE - CLEAR LOCKWORD
*
** ENTRY   - T7 = POINTER RMA
*            T5 = OFFSET TO LOCKWORD FROM RMA
*
** EXIT    - CHANNEL LOCK CLEARED.
*
 CLOCK    SUBR               SUBROUTINE ENTRY/EXIT
 CLK14    BSS
          LCN    0
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        RMA OF TABLE
          ADDL   T5          ADD LOCKWORD OFFSET
          STDL   T6
          RDSL   T1          WRITE INTERMEDIATE VALUE
          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJN    CLK14       IF ANOTHER INTERLOCK OPERATION IS IN PROGRESS
          LDDL   PPNO
          SBDL   T4
          ZJN    CLK30       IF LOCK WAS OK
          LDDL   T6
          LMC    400000B     USE R REGISTER
          CWDL   T1          RESTORE THE LOCKWORD
          LDC    ER.CLE      CHANNEL LOCKWORD ERROR
          UJK    ERR         PROCESS ERROR
 CLK30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6
          LMC    400000B     USE R REGISTER
          CWDL   T1           CLEAR THE LOCKWORD
          RETURN             EXIT


          SPACE  5,20
** NAME    - CSDP
*
** PURPOSE - CLEAR SIDE DOOR PORT STATUS.
*
** ENTRY   - NONE
*
** EXIT    - SDP STATUS WORDS ARE CLEARED.
*
 CSDP     SUBR               SUBROUTINE ENTRY/EXIT
 CSDP2    LDK    FCLR        FUNCTION CODE TO CLEAR
                             (PLUS ICI.12B IF CYBER 930)
          RJM    FAN         SEND FUNCTION CODE
          NJK    CSDP5       IF FUNCTION ACCEPTED
          LDK    ER.NIF      NO INATIVE TO FUNCTION
          UJK    ERR         PROCESS ERROR CODE
 CSDP5    LDK    DCSP        SELECT SDP CLEAR
          ACN    DC
          OAN    DC
          RJM    WCE         WAIT FOR CHANNEL EMPTY
          NJK    CSDP10      IF EMPTY RECEIVED
          LDK    ER.CNE      CHANNEL NOT EMPTY
          UJK    ERR         PROCESS ERROR CODE
 CSDP10   DCN    DC+40B      DEACTIVATE CHANNEL
          RETURN             EXIT

          SPACE  5,20
** NAME    - DESEL
*
** PURPOSE - DELSELECT THE CHANNEL CONVERTER ON CYBER 930
*
** ENTRY   - NONE
*
** EXIT    - CYBER 930 CHANNEL CONVERTER DESELECTED
*
 DESEL    SUBR               SUBROUTINE ENTRY/EXIT
          LDK    ICI.DES     DESELECT CHANNEL CONVERTER
          RJM    FAN         SEND FUNCTION
          NJN    DESEL10     IF FUNCTION ACCEPTED
          LDK    ER.NIF      NO INACTIVE TO FUNCTION
          UJK    ERR
 DESEL10  RETURN             EXIT

          SPACE  5,20
** NAME    - ERR
*
** PURPOSE - PROCESS DRIVER ERRORS
*
** ENTRY   - (A) = ERROR CODE
*
** EXIT    - PP STATUS WORD IN CM = ERROR CODE
*
 ERR      SUBR               SUBROUTINE ENTRY/EXIT
          STDL   ERRCODE
          LDDL   CLF         CHANNEL LOCK FLAG
          NJK    ERR5        IF CHANNEL NOT LOCKED
          DCN    DC+40B      UNCONDITIONALLY DISCONNECT CHANNEL
          RJM    CCLOCK      CLEAR CHANNEL LOCK
 ERR5     LDDL   ERRCODE
          RJM    PPSTAT      SET ERROR CODE IN PP STATUS WORD
          UJK    MAIN20      GOTO PP REQ LOOP

          SPACE  5,20
** NAME    - FAN
*
** PURPOSE - SEND A FUNCTION TO THE IPI CHANNEL, BUT DONT
*            PUT THE FUNCTION IN THE FUNCTION HISTORY TABLE
*
** ENTRY   - (A) = FUNCTION CODE
*
** EXIT    - FUNCTION CODE SENT TO SDP.
*
 FAN      SUBR               SUBROUTINE ENTRY/EXIT
          STDL   LF          CAPTURE LAST FUNCTION
          DCN    DC+40B      ENSURE THE CHANNEL IS INACTIVE
          FAN    DC          SEND THE FUNCTION
          RJM    IJM         WAIT FOR INACTIVE
          RETURN             EXIT

          SPACE  5,20
** NAME    - FORMA
*
** PURPOSE - FORMAT A CM REAL MEMORY ADDRESS.
*
** ENTRY   - A REGISTER- IS THE ADDRESS OF A 2-WORD CM BYTE ADDRESS.
*
** EXIT    - CMADR IS THE ADDRESS OF THE RESULTING 3-WORD REFORMATED
*            CM ADDRESS.  THE FORMAT CAN BE USED BY THE LOADC MACRO.
*            ADDRESS - WORD 0, BITS 0-13 AND
*                      WORD 1, BITS 3-15, ARE REFORMATTED TO-
*            CMADR   - WORD 0, BITS 0-9,
*                      WORD 1, BITS 0-11,
*                      WORD 2, BITS 0-5.
*
 FORMA    SUBR               ENTRY/EXIT
          STDL   T1

* REFORMAT CM ADDRESS.

          LDML   1,T1
          LPN    7
          NJN    *           RMA ADDRESS ERROR, TEMPORARY HALT
          LDIL   T1
          LPN    37B
          SHN    16
          LMML   1,T1
          SHN    9
          STD    CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   T1
          SHN    -5
          STD    CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMC    400000B
          RETURN             EXIT

          SPACE  5,20
** NAME    - IJM
*
** PURPOSE - WAIT FOR THE INACTIVE TO BE SENT BACK ON
*            THE CHANNEL.
*
** ENTRY   - NONE
*
** EXIT    - (A) = NONZERO IF INACTIVE RECEIVED
*            (A) = ZERO IF NO INACTIVE
*
 IJM      SUBR               SUBROUTINE ENTRY/EXIT
          LCN    3
 IJM5     IJM    IJM10,DC    IF INACTIVE, EXIT
          SBN    1
          NJN    IJM5        IF NOT TIMED OUT
 IJM10    RETURN             EXIT

          SPACE  5,20
** NAME    - LOCK
*
** PURPOSE - SET THE LOCKWORD
*
** ENTRY   - T7 = POINTER RMA
*            T5 = OFFSET TO LOCKWORD FROM RMA
*
** EXIT    - A = 0 IF LOCK SUCCESSFULLY SET
*
 LOCK     SUBR               SUBROUTINE ENTRY/EXIT
 LOCK1    BSS
          LCN    0
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        CIT/PPIT TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE
          LDDL   T1
          ZJN    LOCK5       IF LOCK COULD BE SET
          ADDL   T2
          ADC    -177777B-177777B
          ZJK    LOCK1       IF INTERMEDIATE VALUE
          LDDL   T2
          LPC    77777B
          ADC    100000B
          STDL   T2          SET THE VE BIT
          LDDL   T6
          LMC    400000B     USE R REGISTER
          CWDL   T1          RESTORE THE LOCKWORD WITH THE VE BIT
          LDDL   T4
          SBDL   PPNO        CHECK IF LOCK ALREADY SET
          NJN    LOCK3       IF LOCK COULD NOT BE SET, EXIT A .NE. 0
          LDDL   T1
          ADC    -100000B
 LOCK3    RETURN             EXIT
 LOCK5    BSS
          LDC    100000B
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          LDDL   PPNO
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B     USE R REGISTER
          CWDL   T1          SET THE LOCKWORD
          LDN    0
          UJK    LOCK3       GOTO EXIT WITH A=0

          SPACE  5,20
** NAME    - PKLOG
*
** PURPOSE - TAKES 4 12 BIT PP WORDS FROM UNPACKED BUFFER
*            BUFFER AND PACKS IT INTO 3 16 BIT PP WORDS.
*
** ENTRY   - UNPACKED BUFFER CONTAINS ERROR LOG DATA.
*
** EXIT    - PACKED BUFFER CONTAINS ERROR LOG DATA
*
 PKLOG    SUBR               SUBROUTINE ENTRY/EXIT
          LDN    0
          STDL   T1
          STDL   T2
          LDN    25B         INTERATION COUNT
          STDL   T3
 PKLOG5   BSS                LOOP ENTRY POINT
          LDM    UPKBFWA,T1
          SHN    4
          STML   PKBDAT,T2         |    A12     |XXXX|
          LDM    UPKBFWA+1,T1
          SHN    -8
          RAML   PKBDAT,T2         |    A12     | B4 |
          LDM    UPKBFWA+1,T1
          LPK    377B
          SHN    8
          STML   PKBDAT+1,T2       |   B8   |XXXXXXXX|
          LDM    UPKBFWA+2,T1
          SHN    -4
          RAML   PKBDAT+1,T2       |   B8   |   C8   |
          LDM    UPKBFWA+2,T1
          LPN    17B
          SHN    12
          STML   PKBDAT+2,T2       | C4 |XXXXXXXXXXXX|
          LDM    UPKBFWA+3,T1
          RAML   PKBDAT+2,T2       | C4 |    D12     |
          LDN    4
          RAD    T1          UPDATE UNPACKED BUFFER WORD COUNT
          LDN    3
          RAD    T2          UPDATE PACKED BUFFER WORD COUNT
          SOD    T3          DECREMENT ITERATION COUNT
          NJK    PKLOG5      IF MORE DATA TO PACK
          RETURN             EXIT

          SPACE  5,20
** NAME    - PKSTAT
*
** PURPOSE - PACKS SIDE DOOR PORT STATUS INTO 4 16 BIT
*            WORDS. THE FIRST 16 BITS ARE ZERO FOLLOWED
*            FOLLOWED BY 48 BITS OF PACKED SIDE DOOR PORT
*            STATUS.
** ENTRY   - UNPACKED BUFFER CONTAINS SIDE DOOR PORT STATUS.
*
** EXIT    - PACKED BUFFER CONTAINS SIDE DOOR PORT STATUS
*
 PKSTAT   SUBR               SUBROUTINE ENTRY/EXIT
          BSS                LOOP ENTRY POINT
          LDN    0
          STML   PKBSTAT           |00000000|00000000| WORD1
          LDM    UPKBFWA
          SHN    4
          STML   PKBSTAT+1         |    A12     |XXXX|
          LDM    UPKBFWA+1
          SHN    -8
          RAML   PKBSTAT+1         |    A12     | B4 | WORD2
          LDM    UPKBFWA+1
          LPK    377B
          SHN    8
          STML   PKBSTAT+2         |   B8   |XXXXXXXX|
          LDM    UPKBFWA+2
          SHN    -4
          RAML   PKBSTAT+2         |   B8   |   C8   | WORD3
          LDM    UPKBFWA+2
          LPN    17B
          SHN    12
          STML   PKBSTAT+3         | C4 |XXXXXXXXXXXX|
          LDM    UPKBFWA+3
          RAML   PKBSTAT+3         | C4 |    D12     | WORD4
          RETURN             EXIT

          SPACE  5,20
** NAME    - PPRQ
*
** PURPOSE - CHECK FOR ANY PP REQUESTS ON THE PP QUEUE.
*
*                             +----+----+----+-----+
** ENTRY   - WORD 0 OF PPIT = |PPNO|FLUN|NOUN|FLAGS|
*                             +----+----+----+-----+
*              WHERE PPNO IS: LOGICAL PP NUMBER
*                    FLUN IS: FIRST LOGICAL UNIT
*                    NOUN IS: NUMBER OF UNITS
*                  FLAGS ARE: BIT 15 = ACTIVE CHECK
*                             BIT 14 = IDLE REQUEST
*                             BIT 13 = RESUME REQUEST
*                             BIT 12 = PP IDLE STATUS
*                             BIT 11
*                                :
*                             BIT 01 = UNUSED
*                             BIT 00 = LOCK
*
** EXIT    - FLAGS HAVE BEEN CHECKED/CHANGED AS APPROPRIATE
*
 PPRQ     SUBR               SUBROUTINE ENTRY/EXIT
          LCN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDC    0#7FFF
          STDL   T4
          LOADC  CM.PPIT     CM ADDRESS OF PP INTERFACE TABLE
          RDCL   T1          CLEAR ACTIVE CHECK BIT, READ PPIT WORD 1
          LDDL   T4
          SHN    /PIT/L.IDLREQ+2
          MJN    PPRQ10      IF IDLE REQUEST
          SHN    /PIT/L.RESREQ-/PIT/L.IDLREQ
          MJK    PPRQ5       IF RESUME
          RETURN             EXIT
 PPRQ5    RJM    SPLOCK      SET PP TABLE LOCK
          LDDL   T4
          LPC    0#4FFE      CLEAR ACTIVE CHECK BIT, RESUME REQUEST BIT,
          STDL   T4           IDLE STATUS BIT, AND LOCK BIT IN PP
          LDDL   CM.PPIT+2    INTERFACE TABLE
          LMC    400000B     USE R REGISTER
          CWDL   T1
          UJK    MAIN20      RESUME RECEIVED - EXIT
 PPRQ10   BSS
          RJM    SPLOCK      SET PP TABLE LOCK
          LOADC  CM.PPIT     CM ADDRESS OF PP INTERFACE TABLE
          CRDL   T1
          LDDL   T4          CLEAR ACTIVE CHECK BIT, IDLE REQUEST BIT,
          LPC    0#2FFE       AND SET IDLE STATUS BIT
          LMC    0#1000
          STDL   T4
          LDDL   CM.PPIT+2
          LMC    400000B     USE R REGISTER
          CWDL   T1
 PPRQ20   BSS
          RJM    PPRQ        WAIT FOR RESUME
          UJN    PPRQ20

          SPACE  5,20
** NAME    - PPSTAT
*
** PURPOSE - SETS PP STATUS WORD IN COMMUNICATION BUFFER
*
** ENTRY   - (A) = PP STATUS WORD
*
** EXIT    - PP STATUS SET TO NORMAL COMPLETION OR ERROR CODE
*
 PPSTAT   SUBR               SUBROUTINE ENTRY/EXIT
          STDL   T1          PP STATUS
          LDN    1
          STD    WD
          LOADC  CM.CMB
          ADN    /CB/C.PPSTAT INDEX TO CM WORD FOR PP STATUS
          CRML   CMDATA,WD    READ CM WORD
          LDDL   T1
          STML   CMDATA       SET PP STATUS
          LDN    1
          STD    WD
          LOADC  CM.CMB
          ADN    /CB/C.PPSTAT INDEX TO CM WORD WHICH CONTAINS PP STATUS
          CWML   CMDATA,WD    WRITE WORD BACK TO CM
          RETURN

          SPACE  5,20
** NAME    - RDLOG
*
** PURPOSE - RETRIEVE DATA FROM SDP ERROR LOG
*
** ENTRY   - NONE
*
** EXIT    - UNPACKED ERROR LOG HAS CONTAINS SDP ERROR LOG DATA
*
 RDLOG    SUBR               SUBROUTINE ENTRY/EXIT
          IJM    RDLOG5,DC   IF CHANNEL INACTIVE
          LDK    ER.CAE      CHANNEL ACTIVE ON ENTRY
          UJK    ERR         PROCESS ERROR
 RDLOG5   LDK    FREL        FUNCTION CODE READ ERROR LOG
                             (PLUS ICI.12B IF CYBER 930)
          RJM    FAN         SEND FUNCTION
          NJN    RDLOG10     IF FUNCTION ACCEPTED
          LDK    ER.NIF      NO INACTIVE TO FUNCTION
          UJK    ERR         PROCESS ERROR
 RDLOG10  ACN    DC+40B
          LDK    123B
          IAM    UPKBFWA,DC  INPUT ERROR LOG DATA
          DCN    DC+40B
          ZJN    RDLOG20     IF ALL WORDS INPUT
          LDK    ER.LDI      LOST DATA ON INPUT
          UJK    ERR
 RDLOG20  SFM    RDLOG30,DC  CHECK FOR CHANNEL PARITY ERROR
          RETURN             EXIT
 RDLOG30  LDK    ER.CPE      PARITY ERROR ON DATA INPUT
          UJK    ERR         PROCESS ERROR

          SPACE  5,20
** NAME    - RELOG
*
** PURPOSE - RESET ERROR LOG
*
** ENTRY   - NONE
*
** EXIT    - ERROR LOG RESET
*
 RELOG    SUBR               SUBROUTINE ENTRY/EXIT
          LDK    FCEL        FUNCTION CODE TO RESET ERROR LOG
          RJM    FAN         SEND FUNCTION CODE
          NJK    RELOG5      IF FUNCTION ACCEPTED
          LDK    ER.NIF      NO INACTIVE TO FUNCTION
          UJK    ERR         PROCESS ERROR CODE
 RELOG5   RETURN             EXIT

          SPACE  5,20
** NAME    - RDSTAT
*
** PURPOSE - RETRIEVE STATUS FROM THE SIDE DOOR PORT
*
** ENTRY   - NONE
*
** EXIT    - UNPACKED ERROR LOG CONTAINS SDP STATUS
*
 RDSTAT   SUBR               SUBROUTINE ENTRY/EXIT
          IJM    RDSTAT5,DC  IF CHANNEL INACTIVE
          LDK    ER.CAE      CHANNEL ACTIVE ON ENTRY
          UJK    ERR         PROCESS ERROR
 RDSTAT5  LDK    FRSR        FUNCTION CODE READ STATUS BITS
                             (PLUS ICI.12B IF CYBER 930)
          RJM    FAN         SEND FUNCTION
          NJN    RDSTAT10    IF FUNCTION ACCEPTED
          LDK    ER.NIF      NO INACTIVE TO FUNCTION
          UJK    ERR
 RDSTAT10 ACN    DC+40B
          LDN    4
          IAM    UPKBFWA,DC  INPUT SDP STATUS
          DCN    DC+40B
          ZJN    RDSTAT20    IF ALL WORDS INPUT
          LDK    ER.LDI      LOST DATA ON INPUT
          UJK    ERR
 RDSTAT20 SFM    RDSTAT30,DC CHECK FOR CHANNEL PARITY ERROR
          RETURN             EXIT
 RDSTAT30 LDK    ER.CPE      CHANNEL PARITY ERROR ON INPUT
          UJK    ERR

          SPACE  5,20
** NAME    - SCLOCK
*
** PURPOSE - SETS THE CHANNEL LOCK.
*
** ENTRY   - NONE
*
*  EXIT    - CHANNEL LOCK HAS BEEN SET
*
 SCLOCK   SUBR               SUBROUTINE ENTRY/EXIT
 SCL30    BSS
          LDC    CM.CIT      CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    SCL30       IF LOCK WAS NOT SET
          STDL   CLF         CLEAR CHANNEL LOCK FLAG
          RETURN             EXIT, LOCK WAS SET

          SPACE  5,20
** NAME    - SEL
*
** PURPOSE - SELECT THE CHANNEL CONVERTER ON CYBER 930
*
** ENTRY   - NONE
*
** EXIT    - CYBER 930 CHANNEL CONVERTER SELECTED
*
 SEL      SUBR               SUBROUTINE ENTRY/EXIT
          IJM    SEL5,DC     IF CHANNEL INACTIVE
          LDK    ER.CAE      CHANNEL ACTIVE ON ENTRY
          UJK    ERR         PROCESS ERROR
 SEL5     LDK    ICI.SEL+FRSR  FUNCTION CODE SELECT CONVERTER
                               (FRSR CONCANTENATED TO ICI.SEL
                                TO INSURE INACTIVE RETURNED)
          RJM    FAN         SEND FUNCTION
          NJN    SEL10       IF FUNCTION ACCEPTED
          LDK    ER.NIF      NO INACTIVE TO FUNCTION
          UJK    ERR
 SEL10    ACN    DC+40B
          LDN    3
          IAM    UPKBFWA,DC  INPUT SDP STATUS (THROW AWAY)
          DCN    DC+40B
          RETURN             EXIT

          SPACE  5,20
** NAME    - SPLOCK
*
** PURPOSE - SETS THE PP TABLE LOCK IN THE
*            PP INTERFACE TABLE.
*
** ENTRY   - NONE
*
** EXIT    - PPIT LOCK HAS BEEN SET
*
*
 SPLOCK   SUBR               SUBROUTINE ENTRY/EXIT
 SPLOCK4  BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDN    1
          STDL   T4
          LOADC  CM.PPIT     CM ADDRESS OF PP INTERFACE TABLE
          RDSL   T1          ATTEMPT TO SET PP TABLE LOCK
          LDDL   T4
          LPN    1
          NJK    SPLOCK4     IF LOCK NOT SET
          RETURN             EXIT WITH LOCK SET

          SPACE  5,20
** NAME    - TRCMB
*
** PURPOSE - TRANSFER PACKED BUFFER TO CM COMMUNICATION BUFFER.
*
** ENTRY   - PACKED BUFFER CONTAINS ERROR LOG DATA
*
** EXIT    - CM BUFFER CONTAINS ERROR LOG DATA
*
 TRCMB    SUBR               SUBROUTINE ENTRY/EXIT
          LDK    BUFFCM      LENGTH OF ERROR DATA+STATUS
          STD    WD
          LOADC  CM.CMB
          ADN    /CB/C.DATA  INDEX TO FWA OF ERROR LOG DATA FIELD
          CWML   PKBDAT,WD   WRITE ERROR LOG/STATUS TO CM
          RETURN             EXIT

          SPACE  5,20
** NAME    - WCE
*
** PURPOSE - WAIT FOR THE CHANNEL TO GO EMPTY
*
** ENTRY   - NONE
*
** EXIT    - (A) = NONZERO IF CHANNEL EMPTY
*            (A) = ZERO IF NO EMPTY RECEIVED
*
 WCE      SUBR               SUBROUTINE ENTRY/EXIT
          LCN    3
 WCE5     EJM    WCE10,DC    IF CHANNEL EMPTY - EXIT
          SBN    1
          NJN    WCE5        IF NOT TIMED OUT
 WCE10    RETURN             EXIT

          SPACE  5,20
** NAME    - WCF
*
** PURPOSE - WAIT FOR THE CHANNEL TO GO FULL.
*
** ENTRY   - NONE
*
** EXIT    - (A) = NONZERO IF CHANNEL EMPTY
*            (A) = ZERO IF NO EMPTY RECEIVED
*
 WCF      SUBR               SUBROUTINE ENTRY/EXIT
          LCN    3
 WCF5     FJM    WCF10,DC    IF CHANNEL FULL - EXIT
          SBN    1
          NJN    WCF5        IF NOT TIMED OUT
 WCF10    RETURN             EXIT

          SPACE  5,20
**
* EQUATES FOR BUFFER LOCATIONS
*
 UPKBFWA  EQU    *               UNPACKED BUFFER FWA
 PPTBL    EQU    UPKBFWA         TEMP LOCATION FOR PPIT
 PKBDAT   EQU    UPKBFWA+UPKBFL  PACKED BUFFER ERROR LOG DATA
 PKBSTAT  EQU    PKBDAT+PKBFL    PACKED BUFFER SDP STATUS
 BUFFL    EQU    UPKBFL+PKBFL+4  LENGTH OF BUFFER AREA

          ORG    *+BUFFL         ALLOCATE BUFFER SPACE
 CMDATA   BSSZ   4               BUFFER SPACE FOR 1 CM WORD

          SPACE  5,20
          TITLE  INITIALIZATION
** NAME    - INIT
*
** PURPOSE - INITIALIZE THE DRIVER
*
** ENTRY   - NONE
*
** EXIT    - PP IS INITIALIZED
*
 INIT     SUBR               SUBROUTINE ENTRY/EXIT
          REFAD  PITRMA,CM.PPIT  REFORMAT ADDRESS OF PP INTERFACE TABLE
                                 AND SAVE IN CM.PPIT
          LDK    BUFFL       LENGTH OF BUFFERS
          STDL   T1
 INIT4    BSS                                                                  *

* ZERO DATA BUFFERS

          LDN    0
          STML   UPKBFWA,T1  ZERO OUT BUFFERS
          SODL   T1
          NJN    INIT4

* PICK UP CM STRUCTURE POINTERS

          LDN    C.PIT
          STDL   WD
          LOADC  CM.PPIT     LOAD CM ADDRESS OF PP INTERFACE TABLE
          CRML   PPTBL,WD    READ PP INTERFACE TABLE
          LDML   PPTBL+/PIT/P.PPNO   GET PP NUMBER
          STDL   PPNO
          REFAD  PPTBL+/PIT/P.CHAN,CM.CIT  REFORMAT CM ADDRESS OF CHANNEL
                                            TABLE AND SAVE IN CM.CIT
          REFAD  PPTBL+/PIT/P.CBUF,CM.CMB  REFORMAT ADDRESS OF COMMUNICATION
                                           BUFFER AND SAVE IN CM.CMB

* WAIT FOR CM COMMUNICATIONS BUFFER INITIALIZATION

 INIT8    BSS
          LDN    1
          STD    WD
          LOADC  CM.CMB
          CRML   CMDATA,WD   READ FIRST WORD OF CM COMM BUFFER
          LDML   CMDATA+/CB/P.CPSTAT
          ZJK    INIT8       IF INITIALIZATION NOT COMPLETE

* PICK UP IOU AND CHANNEL INFORMATION

          LDML   CMDATA+/CB/P.IOUTYP
          STDL   IOUTYP      TYPE OF IOU 0=I0 1=NON-I0
          LDML   CMDATA+/CB/P.CHAN
          STDL   CHAN        SIDE DOOR PORT CHANNEL NUMBER

* MODIFY CODE THAT IS IOU DEPENDENT

          LDDL   IOUTYP
          NJN    INIT15      IF NOT I0 IOU
          LDK    ICI.12B/10000B
          RAML   RDSTAT5
          STML   RDLOG5
          STML   CSDP2

* PLUG CHANNEL INSTRUCTIONS WITH SDP CHANNEL

 INIT15   RJM    CHGCH       CHANGE CHANNEL IN I/O INSTRUCTIONS

          RETURN             EXIT PP INITIALIZATION

 CHTAB    BSS    0           CHANNEL TABLE FOR I/O INSTRUCTIONS
 TDC+40B  HERE
 T40B+TDC HERE
 TDC      HERE
          CON    0
          END
/EOR
*DECK DECK=IOM$STATUS_ROUTINES_JOB_MODE EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? TITLE := 'NOS/VE : IO' ??
?? NEWTITLE := '  Module Header' ??
MODULE iom$status_routines_job_mode;

{
{PURPOSE:
{  This module is responsible for setting an error condition in a status
{  record.
{DESIGN:
{  The setting of the status record is done by calling osp$set_status_abnormal.
{
?? PUSH (LISTEXT := ON) ??
?? TITLE := '  Declarations', EJECT ??
*copyc ost$status
*copyc ioe$st_errors
?? POP ??
?? TITLE := '  XREF Procedures', EJECT ??
*copyc osp$set_status_abnormal
*copyc osp$system_error
?? TITLE := '  XREF Variables', EJECT ??
?? TITLE := '  [XDCL, #GATE] iop$set_status_abnormal', EJECT ??

*copyc ioh$set_status_abnormal

  PROCEDURE [XDCL, #GATE] iop$set_status_abnormal (condition: ost$status_condition;
        text: string ( * <= osc$max_string_size);
    VAR status: ost$status);


    osp$set_status_abnormal ('IO', condition, text, status);

  PROCEND iop$set_status_abnormal;

?? OLDTITLE ??
MODEND iom$status_routines_job_mode;

*DECK DECK=IOM$STATUS_ROUTINES_MTR_MODE EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? TITLE := 'NOSVE IO' ??
?? NEWTITLE := 'Module Header' ??
MODULE iom$status_routines_mtr_mode;
{
{ PURPOSE:
{      The purpose of this module is to provide a mechanism for setting
{  an abnormal status in a monitor status record.
{
{ DESIGN:
{      The setting of the status record is determined by the definition
{  of the monitor status record.
{
?? TITLE := 'Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ioe$st_errors
*copyc syt$monitor_status
?? POP ??
?? TITLE := '  XREF Procedures', EJECT ??
*copyc mtp$error_stop
?? TITLE := '  XREF Variables', EJECT ??
?? TITLE := '  [XDCL] iop$mtr_set_status_abnormal', EJECT ??

*copy ioh$mtr_set_status_abnormal

  PROCEDURE [XDCL] iop$mtr_set_status_abnormal (condition: ost$status_condition;
        text: string ( * );
    VAR status: syt$monitor_status);

    status.normal := FALSE;
    status.condition := condition;


  PROCEND iop$mtr_set_status_abnormal;

?? OLDTITLE ??
MODEND iom$status_routines_mtr_mode;
*DECK DECK=IOM$SUBSYSTEM_IO_COMPLETION_TBL EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? TITLE := 'NOS/VE Subsystem IO' ??
?? NEWTITLE := '  Module Header', EJECT ??
MODULE iom$subsystem_io_completion_tbl;
{
{   PURPOSE: This module contains the procedures used to access
{            the subsystem io completion table.
{
{   Design: An io completion table is allocated, upon demand, for each job.
{           The table is allocated in a job fixed segment and is a
{           fixed size.  A pointer in each job fixed segment is used to
{           associate the job with its io completion table.
{
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc iot$io_completion_table
*copyc cmt$io_completion_queue_index
*copyc cmt$scan_variable
*copyc oss$job_fixed
*copyc oss$mainframe_pageable
*copyc oss$mainframe_wired
*copyc ost$global_task_id
*copyc ost$status
*copyc ost$signature_lock_status
*copyc ioe$st_errors
?? POP ??
?? TITLE := 'XREF Procedures', EJECT ??
*copyc cmp$unlock_the_rma_list
*copyc cmt$element_name
*copyc iop$set_status_abnormal
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc osp$clear_job_signature_lock
*copyc osp$test_signature_lock
*copyc osp$set_job_signature_lock
*copyc osp$initialize_signature_lock
*copyc osp$set_signature_lock
*copyc osp$clear_signature_lock
*copyc osp$test_sig_lock
*copyc osp$system_error
*copyc pmp$get_job_names
*copyc pmp$get_executing_task_gtid
?? TITLE := 'XREF Variables', EJECT ??
*copyc cmv$subsys_io_scan_character
*copyc osv$job_fixed_heap
*copyc osv$mainframe_wired_heap
*copyc osv$mainframe_wired_cb_heap
*copyc osv$mainframe_wired_heap
?? TITLE := '  XDCL Variables', EJECT ??
*copyc cmd$io_completion_table
*copyc cmd$default_ioct_entry
      VAR
        cmv$ioct_serial_lock: [XDCL, #GATE, oss$mainframe_pageable]
                  ost$signature_lock,
        cmv$foreign_interface_down: [XDCL, #GATE, oss$mainframe_pageable] boolean,
        cmv$downed_foreign_element: [XDCL, #GATE, oss$mainframe_pageable] cmt$element_name,
        cmv$foreign_down_time: [XDCL, #GATE, oss$mainframe_pageable] integer,
        cmv$throwaway_count: [XDCL, #GATE, oss$mainframe_pageable] integer :=0,
        cmv$subsys_io_responses_p: [#GATE, XDCL, STATIC, oss$job_fixed]
                          ^cmt$subsys_io_response_area := NIL,
        cmv$subsys_io_scan_variable: [#GATE, XDCL, STATIC, oss$job_fixed]
                          cmt$scan_variable := $cmt$scan_character_set [];

?? TITLE := '  create_io_completion_table', EJECT ??

  PROCEDURE create_io_completion_table (VAR able_to_create_table: boolean);

    VAR
      io_completion_table_p: ^cmt$io_completion_table,
      table_index: cmt$io_completion_queue_index,
      local_status: ost$status;

    ALLOCATE io_completion_table_p IN osv$job_fixed_heap^;

    ALLOCATE cmv$subsys_io_responses_p:[cmc$max_subsystem_io_requests]
             IN osv$mainframe_wired_cb_heap^;

    FOR table_index := 1 TO cmc$max_subsystem_io_requests DO
      io_completion_table_p^.header.entries_available (table_index, 1) := 'A';
      cmv$subsys_io_responses_p^ (table_index, 1) := 'N';
      io_completion_table_p^.entries [table_index] := cmv$default_ioct_entry;
      io_completion_table_p^.entries [table_index].entry_index := table_index;
    FOREND;

    io_completion_table_p^.header.available_entries := cmc$max_subsystem_io_requests;
    io_completion_table_p^.header.entries_in_use := 0;
    io_completion_table_p^.header.recovery_action_required := 0;
    osp$initialize_signature_lock (io_completion_table_p^.header.table_lock, local_status);
    IF NOT local_status.normal THEN
      FREE io_completion_table_p IN osv$job_fixed_heap^;
    IFEND;
    osp$initialize_signature_lock (cmv$ioct_serial_lock, local_status);
    IF NOT local_status.normal THEN
      FREE io_completion_table_p IN osv$job_fixed_heap^;
    IFEND;

    cmv$throwaway_count := 0;

    cmv$subsys_io_scan_variable := $cmt$scan_character_set [cmv$subsys_io_scan_character];

    io_completion_table_p^.header.responses_available := cmv$subsys_io_responses_p;

    cmv$io_completion_table_p := io_completion_table_p;

    able_to_create_table := (io_completion_table_p <> NIL);

  PROCEND create_io_completion_table;

?? TITLE := '  get_io_completion_table_address', EJECT ??


  PROCEDURE [INLINE] get_io_completion_table_address (
              VAR io_completion_table_p: ^cmt$io_completion_table);

    io_completion_table_p := cmv$io_completion_table_p;

  PROCEND get_io_completion_table_address;

?? TITLE := '  [XDCL, #GATE] cmp$add_jioct_entry_avail_queue', EJECT ??

*copyc cmh$add_ssiot_entry_avail_queue

  PROCEDURE [XDCL, #GATE] cmp$add_ssiot_entry_avail_queue (VAR job_io_completion_queue_index:
    cmt$io_completion_queue_index);

    VAR
      io_completion_table_entry_p: ^cmt$io_completion_table_entry,
      io_completion_table_entry_index: cmt$io_completion_queue_index,
      wired_request_p: ^cmt$wired_unit_queue_request,
      io_completion_table_p: ^cmt$io_completion_table,
      local_status: ost$status;

    get_io_completion_table_address (io_completion_table_p);

    cmp$get_io_completion_tbl_entry (job_io_completion_queue_index, io_completion_table_entry_p);


    osp$set_job_signature_lock (io_completion_table_p^.header.table_lock);
      io_completion_table_entry_index := io_completion_table_entry_p^.entry_index;
      wired_request_p := io_completion_table_entry_p^.wired_unit_queue_request_p;
      io_completion_table_entry_p^ := cmv$default_ioct_entry;
      io_completion_table_entry_p^.entry_index := io_completion_table_entry_index;
      io_completion_table_entry_p^.wired_unit_queue_request_p := wired_request_p;
      io_completion_table_p^.header.entries_available (io_completion_table_entry_index ,1) := 'A';
      io_completion_table_p^.header.entries_in_use := io_completion_table_p^.header.entries_in_use - 1;

      osp$clear_job_signature_lock (io_completion_table_p^.header.table_lock);

    job_io_completion_queue_index := 0;

  PROCEND cmp$add_ssiot_entry_avail_queue;
?? TITLE := '  [XDCL, #GATE] cmp$ssiot_recovery_condition', EJECT ??

*copyc cmh$ssiot_recovery_condition

    PROCEDURE [XDCL, #GATE] cmp$ssiot_recovery_condition (
           VAR status: ost$status);

       VAR
         io_completion_table_p: ^cmt$io_completion_table;

      status.normal := TRUE;

      get_io_completion_table_address (io_completion_table_p);
      IF io_completion_table_p <> NIL THEN
         osp$set_job_signature_lock (io_completion_table_p^.header.table_lock);
         IF io_completion_table_p^.header.recovery_action_required > 0 THEN
              iop$set_status_abnormal (ioe$ssiot_recovery_required,
                   'Recovery action required on outstanding io requests - IOMSSIOCT',
                    status);
         IFEND;
           osp$clear_job_signature_lock (io_completion_table_p^.header.table_lock);
      IFEND;

    PROCEND cmp$ssiot_recovery_condition;
?? TITLE := '  [XDCL, #GATE] cmp$ssiot_recovery_complete', EJECT ??

*copyc cmh$ssiot_recovery_complete

    PROCEDURE [XDCL, #GATE] cmp$ssiot_recovery_complete (
           VAR status: ost$status);

       VAR
         io_index: cmt$io_completion_queue_index,
         number_of_io_entries: cmt$io_completion_queue_index,
         global_task_id: ost$global_task_id,
         io_completion_table_entry_p: ^cmt$io_completion_table_entry,
         io_completion_table_p: ^cmt$io_completion_table;

      status.normal := TRUE;

      pmp$get_executing_task_gtid (global_task_id);

      get_io_completion_table_address (io_completion_table_p);
      IF io_completion_table_p <> NIL THEN
         osp$set_job_signature_lock (io_completion_table_p^.header.table_lock);
         IF io_completion_table_p^.header.recovery_action_required > 0 THEN
            cmp$get_number_of_io_entries (number_of_io_entries);
            /search_for_task_io/
            FOR io_index := 1 TO number_of_io_entries DO
              cmp$get_io_completion_tbl_entry (io_index, io_completion_table_entry_p);
              IF NOT io_completion_table_entry_p^.available THEN
                  IF io_completion_table_entry_p^.global_task_id = global_task_id THEN
                    iop$set_status_abnormal (ioe$ssiot_recovery_required,
                       'Recovery action required on outstanding io requests - IOMSSIOCT',
                       status);
                    EXIT /search_for_task_io/;
                  IFEND;
              IFEND;
            FOREND /search_for_task_io/;
         IFEND;
         osp$clear_job_signature_lock (io_completion_table_p^.header.table_lock);
      IFEND;

    PROCEND cmp$ssiot_recovery_complete;
?? TITLE := '  [XDCL, #GATE] cmp$destroy_io_completion_tb_r1', EJECT ??

*copyc cmh$destroy_io_completion_tb_r1

  PROCEDURE [XDCL, #GATE] cmp$destroy_io_completion_tb_r1 (VAR status: ost$status);

    VAR
      table_index: cmt$io_completion_queue_index,
      wired_heap_p: ^ost$heap,
      io_completion_table_p: ^cmt$io_completion_table;

    status.normal := TRUE;

    get_io_completion_table_address (io_completion_table_p);
    IF io_completion_table_p = NIL THEN
      RETURN;
    IFEND;

    IF io_completion_table_p^.header.entries_in_use <> 0 THEN
      iop$set_status_abnormal (ioe$io_completion_table_error,
        'Trying to destroy io completion table with outstanding io - IOMSSIOCT', status);
    IFEND;

    wired_heap_p := osv$mainframe_wired_cb_heap;

    FOR table_index := 1 TO cmc$max_subsystem_io_requests DO
       IF io_completion_table_p^.entries [table_index].wired_unit_queue_request_p <> NIL THEN
          FREE io_completion_table_p^.entries [table_index].wired_unit_queue_request_p^.
               wired_pp_response_p IN wired_heap_p^;
          FREE io_completion_table_p^.entries [table_index].wired_unit_queue_request_p^.
               wired_io_request_p IN wired_heap_p^;
          FREE io_completion_table_p^.entries [table_index].wired_unit_queue_request_p^.
               wired_data_command_descript_p IN wired_heap_p^;
          FREE io_completion_table_p^.entries [table_index].wired_unit_queue_request_p^.
               wired_command_heap_p IN wired_heap_p^;
          FREE io_completion_table_p^.entries [table_index].wired_unit_queue_request_p^.
               monitor_request_block_p IN wired_heap_p^;
          FREE io_completion_table_p^.entries [table_index].wired_unit_queue_request_p IN wired_heap_p^;
       IFEND;
    FOREND;

{   FREE io_completion_table_p IN osv$job_fixed_heap^;
{   cmv$io_completion_table_p := io_completion_table_p;

    FREE cmv$subsys_io_responses_p IN osv$mainframe_wired_cb_heap^;

  PROCEND cmp$destroy_io_completion_tb_r1;
?? TITLE := '  [XDCL, #GATE] cmp$ssiot_recovery_processing', EJECT ??

*copyc cmh$ssiot_recovery_processing

    PROCEDURE [XDCL, #GATE] cmp$ssiot_recovery_processing (
           VAR status: ost$status);

       VAR
         clear_table_lock: boolean,
         lock_status: ost$signature_lock_status,
         io_completion_queue_index: cmt$io_completion_queue_index,
         number_of_io_entries: cmt$io_completion_queue_index,
         io_completion_table_entry_p: ^cmt$io_completion_table_entry,
         io_completion_table_p: ^cmt$io_completion_table;

      status.normal := TRUE;

      clear_table_lock := FALSE;

      get_io_completion_table_address (io_completion_table_p);
      IF io_completion_table_p <> NIL THEN
         osp$test_sig_lock (io_completion_table_p^.header.table_lock,
                            lock_status);
         IF lock_status <> osc$sls_locked_by_current_task THEN
            osp$set_job_signature_lock (io_completion_table_p^.header.table_lock);
            clear_table_lock := TRUE;
         IFEND;
         cmp$get_number_of_io_entries (number_of_io_entries);
         FOR io_completion_queue_index := 1 to number_of_io_entries DO
           cmp$get_io_completion_tbl_entry (io_completion_queue_index,
                              io_completion_table_entry_p);
           IF NOT io_completion_table_entry_p^.available THEN
              IF (io_completion_table_entry_p^.io_status = cmc$subsystem_io_started) OR
                 (io_completion_table_entry_p^.io_status = cmc$subsystem_io_completing) THEN
                 io_completion_table_p^.header.recovery_action_required :=
                       io_completion_table_p^.header.recovery_action_required + 1;
                 io_completion_table_entry_p^.io_status :=
                       cmc$subsystem_io_term_by_rec;
              IFEND;
           IFEND;
                 io_completion_table_entry_p^.wired_unit_queue_request_p := NIL;
         FOREND;
    ALLOCATE cmv$subsys_io_responses_p:[cmc$max_subsystem_io_requests]
             IN osv$mainframe_wired_cb_heap^;



         IF clear_table_lock THEN
           osp$clear_job_signature_lock (io_completion_table_p^.header.table_lock);
         IFEND;
      IFEND;

    PROCEND cmp$ssiot_recovery_processing;
?? TITLE := '  [XDCL, #GATE] cmp$get_io_completion_tbl_entry', EJECT ??

*copyc cmh$get_io_completion_tbl_entry

  PROCEDURE [INLINE] cmp$get_io_completion_tbl_entry (io_completion_queue_index:
    cmt$io_completion_queue_index;
    VAR io_completion_table_entry_p: ^cmt$io_completion_table_entry);

    VAR
      io_completion_table_p: ^cmt$io_completion_table;

    io_completion_table_entry_p := NIL;

    get_io_completion_table_address (io_completion_table_p);

    io_completion_table_entry_p := ^io_completion_table_p^.entries [io_completion_queue_index];

  PROCEND cmp$get_io_completion_tbl_entry;
?? TITLE := '  [XDCL, #GATE] cmp$get_number_of_io_entries', EJECT ??

*copyc cmh$get_number_of_io_entries

  PROCEDURE [INLINE] cmp$get_number_of_io_entries (VAR number_of_entries: cmt$io_completion_queue_index);

    number_of_entries := UPPERBOUND (cmv$io_completion_table_p^.entries);

  PROCEND cmp$get_number_of_io_entries;

?? TITLE := '  [XDCL, #GATE] cmp$get_ssiot_entry_avail_queue', EJECT ??

*copyc cmh$get_ssiot_entry_avail_queue

  PROCEDURE [XDCL, #GATE] cmp$get_ssiot_entry_avail_queue (VAR job_io_completion_queue_index:
    cmt$io_completion_queue_index);

    VAR
      io_completion_table_p: ^cmt$io_completion_table,
      global_task_id: ost$global_task_id,
      able_to_create_table: boolean,
      available_scan_variable: cmt$scan_variable,
      available_table_entry_p: ^cmt$io_completion_table_entry,
      available_entry_found: boolean,
      user_supplied_name: jmt$user_supplied_name,
      system_supplied_name: jmt$system_supplied_name,
      scan_index: integer,
      local_status: ost$status;

    job_io_completion_queue_index := 0;
    available_scan_variable := $cmt$scan_character_set ['A'];

    IF cmv$io_completion_table_p = NIL THEN
      create_io_completion_table (able_to_create_table);
      IF NOT able_to_create_table THEN
        iop$set_status_abnormal (ioe$io_completion_table_error,
          'Unable to create io completion table - IOMSSIOCT', local_status);
        RETURN;
      IFEND;
    IFEND;

    pmp$get_executing_task_gtid (global_task_id);
    pmp$get_job_names (user_supplied_name, system_supplied_name, local_status);
    get_io_completion_table_address (io_completion_table_p);

    osp$set_job_signature_lock (io_completion_table_p^.header.table_lock);

      #scan (available_scan_variable, io_completion_table_p^.header.entries_available,
             scan_index, available_entry_found);

        IF available_entry_found  THEN
          job_io_completion_queue_index := scan_index;
          io_completion_table_p^.header.entries_in_use := io_completion_table_p^.header.entries_in_use + 1;
          io_completion_table_p^.header.entries_available (job_io_completion_queue_index, 1) := 'N';
          cmp$get_io_completion_tbl_entry (job_io_completion_queue_index, available_table_entry_p);
          available_table_entry_p^.available := FALSE;
          available_table_entry_p^.global_task_id := global_task_id;
          available_table_entry_p^.job_name := system_supplied_name;
        ELSE
          iop$set_status_abnormal (ioe$io_completion_table_error,
            'available ssiot entry not free - IOMSSIOCT', local_status);
        IFEND;

      osp$clear_job_signature_lock (io_completion_table_p^.header.table_lock);

  PROCEND cmp$get_ssiot_entry_avail_queue;
?? TITLE := '  [XDCL, #GATE] cmp$ssiot_end_handler', EJECT ??

   PROCEDURE [XDCL, #GATE] cmp$ssiot_end_handler (termination_status: ost$status;
                      VAR status: ost$status);

      VAR
        lock_status: ost$signature_lock_status,
        number_of_io_entries: cmt$io_completion_queue_index,
        io_completion_queue_index: cmt$io_completion_queue_index,
        io_completion_table_entry_p: ^cmt$io_completion_table_entry,
        termination_with_outstanding_io: boolean,
        global_task_id: ost$global_task_id,
        io_completion_table_p: ^cmt$io_completion_table;

      status.normal := TRUE;

      termination_with_outstanding_io := FALSE;

      pmp$get_executing_task_gtid (global_task_id);

      get_io_completion_table_address (io_completion_table_p);
      IF io_completion_table_p <> NIL THEN
         osp$test_sig_lock (io_completion_table_p^.header.table_lock,
                            lock_status);
         IF lock_status <> osc$sls_locked_by_current_task THEN
           osp$set_job_signature_lock (io_completion_table_p^.header.table_lock);
         IFEND;

         cmp$get_number_of_io_entries (number_of_io_entries);

         /search_io_table/
         FOR io_completion_queue_index := 1 to number_of_io_entries DO
           cmp$get_io_completion_tbl_entry (io_completion_queue_index,
                              io_completion_table_entry_p);
           IF NOT io_completion_table_entry_p^.available THEN
              termination_with_outstanding_io :=
                 (io_completion_table_entry_p^.global_task_id = global_task_id);
                 IF termination_with_outstanding_io THEN
                    EXIT /search_io_table/;
                 IFEND;
           IFEND;
         FOREND /search_io_table/;

         osp$clear_job_signature_lock (io_completion_table_p^.header.table_lock);


    IFEND;

PROCEND cmp$ssiot_end_handler;
  ?? TITLE := '  [XDCL, #GATE] cmp$store_ssiot_entry_info', EJECT ??

*copyc cmh$store_ssiot_entry_info

  PROCEDURE [XDCL, #GATE] cmp$store_ssiot_entry_info (io_completion_queue_index:
    cmt$io_completion_queue_index;
        entry_information_p: ^cmt$ssiot_entry_information;
    VAR status: ost$status);

    VAR
      io_completion_table_entry_p: ^cmt$io_completion_table_entry,
      index: integer;

    status.normal := TRUE;

    cmp$get_io_completion_tbl_entry (io_completion_queue_index, io_completion_table_entry_p);
    IF io_completion_table_entry_p^.available THEN
      iop$set_status_abnormal (ioe$io_completion_table_error,
        'Trying to store information in available ssiot entry - IOMSSIOCT', status);
      RETURN;
    IFEND;



    FOR index := LOWERBOUND (entry_information_p^) TO UPPERBOUND (entry_information_p^) DO
      CASE entry_information_p^ [index].keyword OF

      = cmc$ssiote_io_status =
        io_completion_table_entry_p^.io_status := entry_information_p^ [index].io_status;

      = cmc$ssiote_null_entry =
        ;

      = cmc$ssiote_request =
        io_completion_table_entry_p^.io_request_type.kind :=
                                entry_information_p^ [index].io_type;
        io_completion_table_entry_p^.io_request_type.element_name :=
                                entry_information_p^ [index].element_name;

      = cmc$ssiote_request_created =
        io_completion_table_entry_p^.time_request_created :=
                    entry_information_p^ [index].time_request_created;

      = cmc$ssiote_request_id =
        io_completion_table_entry_p^.request_identification := entry_information_p^ [index].request_id;
        io_completion_table_entry_p^.subsystem_response_p :=
                    entry_information_p^ [index].subsystem_response_p;
        io_completion_table_entry_p^.data_command_descriptors_p :=
                    entry_information_p^ [index].data_command_descriptors_p;

      = cmc$ssiote_wait_for_io_complete =
        io_completion_table_entry_p^.io_request_type.wait_for_io_completion :=
                              entry_information_p^ [index].wait_for_io_completion;

      = cmc$ssiote_wired_request =
        io_completion_table_entry_p^.wired_unit_queue_request_p :=
                                entry_information_p^ [index].wired_request_p;

      ELSE
        iop$set_status_abnormal (ioe$io_completion_table_error,
          'Attempt to store unsupported ssiot entry field - IOMSSIOCT', status);
        RETURN;
      CASEND;

    FOREND;


  PROCEND cmp$store_ssiot_entry_info;

?? OLDTITLE ??


?? TITLE := '  [XDCL, #GATE] cmp$ssiot_termination_cleanup', EJECT ??


  PROCEDURE [XDCL, #GATE] cmp$ssiot_termination (VAR status: ost$status);

    VAR
      table_index: cmt$io_completion_queue_index,
      wired_heap_p: ^ost$heap,
      count: integer,
      limit: integer,
      io_completion_table_p: ^cmt$io_completion_table,
      total_entries: integer,
      queue_index: cmt$io_completion_queue_index;


    status.normal := TRUE;
    get_io_completion_table_address (io_completion_table_p);
    IF io_completion_table_p = NIL THEN
      RETURN;
    IFEND;

    IF io_completion_table_p^.header.entries_in_use = 0 THEN
      RETURN;
    ELSE
      total_entries := io_completion_table_p^.header.entries_in_use;
    IFEND;

    wired_heap_p := osv$mainframe_wired_cb_heap;

    limit := io_completion_table_p^.header.available_entries;
     count := 0;
     table_index := 1;

    WHILE  count < total_entries  DO
       IF (io_completion_table_p^.entries [table_index].wired_unit_queue_request_p <> NIL) AND
         (NOT io_completion_table_p^.entries [table_index].available) THEN
        queue_index := io_completion_table_p^.entries[table_index].request_identification.system_supplied;
        io_completion_table_p^.entries [table_index].io_status := cmc$subsystem_cleanup_req;
        iop$unlock_the_rma_list (queue_index,status);
          IF NOT status.normal THEN
{            RETURN;
{ Even if status is bad try to Free the table space
          IFEND;

          FREE io_completion_table_p^.entries [table_index].wired_unit_queue_request_p^.
               wired_pp_response_p IN wired_heap_p^;
          FREE io_completion_table_p^.entries [table_index].wired_unit_queue_request_p^.
               wired_io_request_p IN wired_heap_p^;
          FREE io_completion_table_p^.entries [table_index].wired_unit_queue_request_p^.
               wired_data_command_descript_p IN wired_heap_p^;
          FREE io_completion_table_p^.entries [table_index].wired_unit_queue_request_p^.
               wired_command_heap_p IN wired_heap_p^;
          FREE io_completion_table_p^.entries [table_index].wired_unit_queue_request_p^.
               monitor_request_block_p IN wired_heap_p^;
          FREE io_completion_table_p^.entries [table_index].wired_unit_queue_request_p IN wired_heap_p^;
       IFEND;
       count := count + 1;
       table_index := table_index + 1;
    WHILEND;

  cmv$io_completion_table_p := io_completion_table_p;

  IF cmv$subsys_io_responses_p <> NIL THEN
    FREE cmv$subsys_io_responses_p IN osv$mainframe_wired_cb_heap^;
  IFEND;

  PROCEND cmp$ssiot_termination;



 PROCEDURE [XDCL] iop$unlock_the_rma_list (job_io_completion_queue_index:
        cmt$io_completion_queue_index;
    VAR status: ost$status);


  status.normal := TRUE;

  cmp$unlock_the_rma_list (job_io_completion_queue_index, status);

 PROCEND iop$unlock_the_rma_list;




 PROCEDURE [XDCL, #GATE] cmp$check_foreign_io (system_job_name:
  jmt$system_supplied_name;
  user_job_name: jmt$user_supplied_name;
 VAR match: boolean);


 VAR
   number_of_entries: cmt$io_completion_queue_index,
   io_completion_table_p: ^cmt$io_completion_table,
   completion_queue_index: cmt$io_completion_queue_index,
   completion_table_entry: ^cmt$io_completion_table_entry;

   match := FALSE;


{Special case archive for now.
               IF user_job_name (1,8) = '$_CSS__$' THEN
                  match := true;
                   RETURN;
               IFEND;


  get_io_completion_table_address (io_completion_table_p);
    IF io_completion_table_p = NIL THEN
      RETURN;
    IFEND;


   cmp$get_number_of_io_entries (number_of_entries);

   FOR  completion_queue_index := 1 TO number_of_entries DO
     cmp$get_io_completion_tbl_entry (completion_queue_index,
       completion_table_entry);
        IF NOT completion_table_entry^.available THEN
           IF completion_table_entry^.job_name = system_job_name THEN
              match := TRUE;
              RETURN;


           IFEND;
        IFEND;
   FOREND;



 PROCEND cmp$check_foreign_io;

 ?? OLDTITLE ??
?? NEWTITLE :=   'cmp$set_ioct_serial_lock', EJECT ??

PROCEDURE [XDCL, #GATE] cmp$set_ioct_serial_lock
          (VAR status: ost$status);

        status.normal := TRUE;
        osp$set_signature_lock (cmv$ioct_serial_lock, osc$wait, status);
PROCEND cmp$set_ioct_serial_lock;

?? OLDTITLE ??
?? NEWTITLE := 'cmp$clear_ioct_serial_lock', EJECT ??

PROCEDURE  [XDCL, #GATE] cmp$clear_ioct_serial_lock
           (VAR status: ost$status);

        status.normal := TRUE;
        osp$clear_signature_lock (cmv$ioct_serial_lock, status);

PROCEND cmp$clear_ioct_serial_lock;
?? OLDTITLE ??
?? NEWTITLE := 'cmp$update_error_count' , EJECT ??

PROCEDURE [XDCL, #GATE] cmp$update_error_count
          (VAR status: ost$status);

         status.normal := TRUE;
         cmv$throwaway_count := cmv$throwaway_count + 1;
PROCEND cmp$update_error_count;

?? NEWTITLE := 'cmp$test_ioct_serial_lock', EJECT ??

PROCEDURE  [XDCL, #GATE] cmp$test_and_clear_ioct_lock
           (VAR status: ost$status);

        VAR
          lock_status: ost$signature_lock_status;

        status.normal := TRUE;
        osp$test_signature_lock (cmv$ioct_serial_lock, lock_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IF lock_status = osc$sls_locked_by_current_task THEN
        osp$clear_signature_lock (cmv$ioct_serial_lock, status);
        IFEND;


PROCEND cmp$test_and_clear_ioct_lock;

?? NEWTITLE := 'cmp$down_foreign_io', EJECT ??


  PROCEDURE [XDCL, #GATE] cmp$down_foreign_io (request_id: cmt$subsystem_io_request_id;
                                            VAR status: ost$status);

    VAR
      element_name: cmt$element_name,
      job_io_completion_queue_index: cmt$io_completion_queue_index,
      io_completion_table_entry_p: ^cmt$io_completion_table_entry,
      logical_pp_number: iot$pp_number;



      status.normal := TRUE;

      job_io_completion_queue_index := request_id.system_supplied;

      cmp$get_io_completion_tbl_entry (job_io_completion_queue_index, io_completion_table_entry_p);

      element_name := io_completion_table_entry_p^.io_request_type.element_name;

      cmv$downed_foreign_element := element_name;
      cmv$foreign_interface_down := TRUE;
      cmv$foreign_down_time := #free_running_clock (0);

PROCEND cmp$down_foreign_io;


PROCEDURE [XDCL, #GATE] cmp$enable_foreign_io (VAR status: ost$status);

      status.normal := TRUE;

      cmv$downed_foreign_element := osc$null_name;
      cmv$foreign_interface_down := FALSE;
      cmv$foreign_down_time := 0;

PROCEND cmp$enable_foreign_io;



MODEND iom$subsystem_io_completion_tbl;
*DECK DECK=IOM$SUBSYSTEM_IO_MTR_PROCESSING EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Strange IO : Subsystem IO Processing in Monitor' ??
MODULE iom$subsystem_io_mtr_processing;

{ PURPOSE:
{   This module contains the monitor code to queue subsystem io requests and to process the associated
{   pp response.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc iot$monitor_request_block
?? PUSH (LISTEXT := ON) ??
*copyc cmk$keypoints
*copyc cmt$foreign_equipment_error_log
*copyc cmt$io_commands
*copyc cmt$physical_equipment_number
*copyc ioe$st_errors
*copyc iot$disk_statistics
*copyc iot$io_request
*copyc iot$logical_unit
*copyc iot$monitor_request_block
*copyc iot$pp_interface_table
*copyc iot$pp_number
*copyc iot$pp_response
*copyc iot$unit_interface_table
*copyc iot$wired_unit_queue_request
*copyc mmt$io_type
*copyc mmt$page_frame_table
*copyc osk$keypoints
*copyc oss$mainframe_wired_cb
*copyc oss$mainframe_wired_literal
*copyc ost$hardware_subranges
*copyc tmt$ptl_lock
?? POP ??
*copyc dsp$report_system_message
*copyc iop$mtr_set_status_abnormal
*copyc iop$set_queue_lockword
*copyc i#real_memory_address
*copyc mmp$build_lock_rma_list
*copyc mmp$xtask_pva_to_sva
*copyc mmp$unlock_rma_list
*copyc mmp$verify_pva
*copyc mtp$error_stop
*copyc mtp$get_date_time_at_timestamp
*copyc tmp$set_system_flag
*copyc tmp$set_task_ready
*copyc tmp$set_lock
*copyc tmp$clear_lock
*copyc tmp$check_taskid
?? EJECT ??
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc osv$external_interrupt_selector
*copyc osv$page_size
*copyc tmv$null_global_task_id

  VAR
    dmv$external_interrupt_selector: [XREF] 0 .. 0ff(16),
    iov$response_trace_1: [XDCL, #GATE] integer := 0,
    iov$invalid_pp_count: [XREF] integer;

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    cmv$subsys_io_scan_character: [XDCL, STATIC, READ, #GATE, oss$mainframe_wired_literal] char := 'Y',
    iov$initial_queue_lock: [XDCL, STATIC, READ, #GATE] iot$lockword := [FALSE, 0, [FALSE, 0, 0]],
    iov$new_queue_lock: [XDCL, STATIC, READ, #GATE] iot$lockword := [TRUE, 0, [TRUE, FALSE, 0, 0]];

?? TITLE := 'iop$subsys_process_pp_response', EJECT ??

  PROCEDURE [XDCL] iop$subsys_process_pp_response
    (    pp_response_header_p: ^iot$pp_response;
         detailed_status_p: ^iot$detailed_status;
         pp_number: 1 .. ioc$pp_count;
     VAR monitor_status: syt$monitor_status);

    VAR
      address_word_pair_count: 0 .. mmc$max_rma_list_length,
      io_request_p: ^iot$io_request,
      system_flag: ost$system_flag,
      global_task_id: ost$global_task_id,
      response_area_p: ^cmt$subsys_io_response_area,
      io_completion_queue_index: cmt$io_completion_queue_index,
      need_to_unlock_data_descriptors: boolean,
      normal_io_termination: boolean,
      wired_subsystem_request_p: ^cmt$max_wired_unit_queue_req,
      date_time: ost$date_time,
      wired_subsystem_pp_response_p: ^cmt$collected_pp_response,
      iov$subsys_process_pp_response: [XDCL, #GATE, oss$mainframe_wired_cb]
                          iot$response_processor := ^iop$subsys_process_pp_response;


  /process_request/
    BEGIN

      monitor_status.normal := TRUE;




      normal_io_termination := TRUE;
      system_flag := ioc$subsystem_io_completed;
      io_request_p := pp_response_header_p^.request;
      wired_subsystem_request_p := io_request_p^.device_request_p;
      wired_subsystem_pp_response_p := wired_subsystem_request_p^.wired_pp_response_p;

      IF wired_subsystem_pp_response_p = NIL THEN
        RETURN;
      IFEND;

      global_task_id := wired_subsystem_request_p^.task_id;
         tmp$check_taskid (global_task_id, tmc$opt_return, monitor_status);
             IF NOT monitor_status.normal THEN
{         Task no longer lives.
            iov$response_trace_1 := iov$response_trace_1 + 1;
            monitor_status.normal := TRUE;
{  Keep a record of the number of times we reject a response so we can determine
{  how often this occurs. Set monitor status to normal here in order to force
{  process_io_completions to update the in/out pointers.
               EXIT /process_request/;
             IFEND;

      io_completion_queue_index := wired_subsystem_request_p^.io_identification.system_supplied;
      response_area_p := wired_subsystem_request_p^.response_area_p;
      address_word_pair_count := wired_subsystem_request_p^.address_word_pair_count;
      need_to_unlock_data_descriptors := (wired_subsystem_request_p^.
                  wired_data_command_descript_p <> NIL) AND
                  (wired_subsystem_request_p^.number_of_data_descriptors > 0) AND
                  (address_word_pair_count > 0);

{
{        Move response to wired response area.
{
      wired_subsystem_pp_response_p^.pp_number := pp_number;
      wired_subsystem_pp_response_p^.pp_response := pp_response_header_p^;
{
{         Move detailed status to wired response area.
{
      IF detailed_status_p <> NIL THEN
        wired_subsystem_pp_response_p^.detailed_status := detailed_status_p^;
      IFEND;

      IF (wired_subsystem_pp_response_p^.pp_response.response_code.primary_response = ioc$normal_response) OR
            (wired_subsystem_pp_response_p^.pp_response.response_code.primary_response =
            ioc$abnormal_response) THEN
        {
        { Unlock pages for data transfer request.
        {

        IF need_to_unlock_data_descriptors THEN
              cmp$unlock_wired_req_rma_list (wired_subsystem_request_p,
                  normal_io_termination, address_word_pair_count, monitor_status);
              IF NOT monitor_status.normal THEN
                iop$mtr_set_status_abnormal (ioe$unable_to_unlock_rma_list,
                  'Unable to unlock rma list - IOMMSSIO', monitor_status);
                EXIT /process_request/;
              IFEND;

        IFEND;

      IFEND;


      wired_subsystem_pp_response_p^.response_status := cmc$subsys_io_resp_completed;

      response_area_p^ (io_completion_queue_index,1) := cmv$subsys_io_scan_character;

      IF NOT wired_subsystem_request_p^.task_is_to_be_readied THEN
         tmp$set_system_flag (global_task_id, system_flag, monitor_status);
         IF NOT monitor_status.normal THEN
           iop$mtr_set_status_abnormal (ioe$unable_to_set_system_flag,
             'Unable to set monitor flag for subsystem io - IOMMSSIO', monitor_status);
         IFEND;
      ELSE
         tmp$check_taskid (global_task_id, tmc$opt_return, monitor_status);
             IF NOT monitor_status.normal THEN
               iop$mtr_set_status_abnormal (ioe$task_missing,
                'Attempt to Ready a terminated task', monitor_status);
               EXIT /process_request/;
             IFEND;




         tmp$set_task_ready (global_task_id, 0 {readying_task_priority},
           tmc$rc_ready_conditional_wi);
      IFEND;

    END /process_request/;


  PROCEND iop$subsys_process_pp_response;

?? TITLE := 'iop$subsystem_queue_request', EJECT ??

*copyc ioh$subsystem_queue_request

  PROCEDURE [XDCL] iop$subsystem_queue_request
    (VAR request_block: iot$monitor_request_block);

    VAR
      data_length: ost$byte_count,
      pp_request_p: ^cmt$pp_request,
      buffer_descriptor: mmt$buffer_descriptor,
      io_identifier: mmt$io_identifier,
      data_pva: ^cell,
      sva: ost$system_virtual_address,
      io_type: iot$io_function,
      access_mode: mmt$segment_access_type,
      logical_unit: iot$logical_unit,
      page_size: ost$page_size,
      page_offset: ost$segment_offset,
      data_command_descriptor_index: integer,
      rma_list_index: 0 .. mmc$max_rma_list_length,
      command_index: 0 .. mmc$max_rma_list_length,
      command_address_word_pair_count: 0 .. mmc$max_rma_list_length,
      unit_queuing_option: cmt$unit_queuing_options,
      io_request_p: ^iot$io_request,
      number_of_data_commands: cmt$command_index,
      data_command_description_p: ^cmt$wired_data_descriptors,
      address_word_pair_count: 0 .. mmc$max_rma_list_length,
      rma: integer,
      pva_rma_translation_required: boolean,
      normal_io_termination: boolean,
      command_rma_list_p: ^mmt$rma_list,
      lock_result: 0 .. 2,
      date_time: ost$date_time,
      wired_unit_queue_request_p: ^cmt$max_wired_unit_queue_req,
      wired_subsystem_pp_response_p: ^cmt$collected_pp_response,
      command_heap_p: ^cmt$subsystem_command_heap,
      able_to_queue_unit_request: boolean,
      command_length: cmt$command_length,
      number_of_commands_available: cmt$command_index,
      create_indirect_rma_list: boolean,
      ignore_status: syt$monitor_status,
      monitor_status: syt$monitor_status;


  /process_request/
    BEGIN

      request_block.status.normal := TRUE;


      io_request_p := request_block.io_request_p;
      io_request_p^.response_processor_p := ^iop$subsys_process_pp_response;

      io_identifier.specified := FALSE;
      io_identifier.io_function := ioc$no_io;
      page_size := osv$page_size;
      normal_io_termination := TRUE;
      access_mode := mmc$sat_none;

      wired_unit_queue_request_p := io_request_p^.device_request_p;
      wired_subsystem_pp_response_p := wired_unit_queue_request_p^.wired_pp_response_p;

      unit_queuing_option := wired_unit_queue_request_p^.unit_queuing_control;
      logical_unit := wired_unit_queue_request_p^.request.logical_unit;
      address_word_pair_count := wired_unit_queue_request_p^.address_word_pair_count;
      pp_request_p := ^wired_unit_queue_request_p^.request;

      pp_request_p^.next_pp_request := NIL;
      IF dmv$external_interrupt_selector = 1 THEN
        pp_request_p^.interrupt.value := TRUE;
      ELSE
        pp_request_p^.interrupt.value := FALSE;
      IFEND;
      pp_request_p^.interrupt.port_number := osv$external_interrupt_selector;

      data_command_description_p := wired_unit_queue_request_p^.wired_data_command_descript_p;
      number_of_data_commands := wired_unit_queue_request_p^.number_of_data_descriptors;
      pva_rma_translation_required := (data_command_description_p <> NIL) AND (number_of_data_commands > 0);
      command_heap_p := wired_unit_queue_request_p^.wired_command_heap_p;
      number_of_commands_available := wired_unit_queue_request_p^.number_of_commands;
      rma_list_index := address_word_pair_count + 1;
      {
      { Create rma lists and lock pages.
      {
      IF pva_rma_translation_required THEN

          buffer_descriptor.buffer_descriptor_type := mmc$bd_explicit_io;

          /lock_data_pages/
          FOR data_command_descriptor_index := 1 TO number_of_data_commands DO
            IF NOT data_command_description_p^ [data_command_descriptor_index].lock_data_pages THEN
              CYCLE /lock_data_pages/;
            IFEND;

            command_index := data_command_description_p^ [data_command_descriptor_index].command_index;
            IF command_index > number_of_commands_available THEN
              IF address_word_pair_count <> 0 THEN
                cmp$unlock_wired_req_rma_list (wired_unit_queue_request_p,
                      normal_io_termination, address_word_pair_count, monitor_status);
              IFEND;
              iop$mtr_set_status_abnormal (ioe$io_request_error,
                'PP command array not large enough - IOMMSSIO', monitor_status);
              EXIT /process_request/;
            IFEND;

            create_indirect_rma_list := pp_request_p^.commands [command_index].flags.indirect_address;
            CASE data_command_description_p^ [data_command_descriptor_index].io_direction OF
              = cmc$read_into_memory, cmc$read_write_memory =
                   io_type := ioc$explicit_read;
                   access_mode := mmc$sat_read_or_write;
              = cmc$write_from_memory =
                   io_type := ioc$explicit_write;
                   access_mode := mmc$sat_read_or_write;
              = cmc$no_memory_reference =
                   CYCLE /lock_data_pages/;
            CASEND;
            data_length := data_command_description_p^ [data_command_descriptor_index].length;
            data_pva := data_command_description_p^ [data_command_descriptor_index].address;
            command_rma_list_p := #LOC (command_heap_p^.rma_list [rma_list_index]);


            mmp$xtask_pva_to_sva (data_pva, sva, monitor_status);
            IF NOT monitor_status.normal THEN
              IF address_word_pair_count <> 0 THEN
                  cmp$unlock_wired_req_rma_list (wired_unit_queue_request_p,
                        normal_io_termination, address_word_pair_count, ignore_status);
              IFEND;
              iop$mtr_set_status_abnormal (ioe$address_error, 'Subsystem address error - IOMMSSIO',
                    monitor_status);
              EXIT /process_request/;
            IFEND;

            IF create_indirect_rma_list THEN
              command_address_word_pair_count := (((sva.offset + data_length + (page_size * 2) - 1)) DIV
                    page_size) - ((sva.offset + page_size) DIV page_size);
            ELSE
              command_address_word_pair_count := 1;
            IFEND;

            page_offset := sva.offset MOD page_size;
            buffer_descriptor.page_count := ((page_offset + data_length - 1) DIV page_size) + 1;
            buffer_descriptor.sva := sva;

            mmp$build_lock_rma_list (buffer_descriptor, data_length, io_type, command_rma_list_p,
                  command_address_word_pair_count, monitor_status);
            IF NOT monitor_status.normal THEN
                IF address_word_pair_count > 0 THEN
              {
              { Unlock locked pages.
              {
                   cmp$unlock_wired_req_rma_list (wired_unit_queue_request_p,
                       normal_io_termination, address_word_pair_count, ignore_status);
                IFEND;
              EXIT /process_request/;
            IFEND;

            data_command_description_p^ [data_command_descriptor_index].rma_list_index := rma_list_index;
            address_word_pair_count := address_word_pair_count + command_address_word_pair_count;

            IF create_indirect_rma_list THEN
              i#real_memory_address (command_rma_list_p, rma);
              command_length := command_address_word_pair_count * 8;
            ELSE
              rma := command_heap_p^.rma_list [rma_list_index].rma;
              command_length := command_heap_p^.rma_list [rma_list_index].length;
            IFEND;

            pp_request_p^.commands [command_index].length := command_length;
            pp_request_p^.commands [command_index].address := rma;

            rma_list_index := rma_list_index + command_address_word_pair_count;

          FOREND /lock_data_pages/;

          wired_unit_queue_request_p^.address_word_pair_count := address_word_pair_count;

      IFEND;

      cmp$queue_unit_request_entry (logical_unit, unit_queuing_option, io_request_p,
            able_to_queue_unit_request);
      IF NOT able_to_queue_unit_request THEN
        {
        { Unlock locked pages. }
        {
        IF address_word_pair_count <> 0 THEN
          cmp$unlock_wired_req_rma_list (wired_unit_queue_request_p,
                normal_io_termination, address_word_pair_count, monitor_status);
        IFEND;
        iop$mtr_set_status_abnormal (ioe$unable_to_queue_io_request,
          'Unable to queue subsystem request - IOMMSSIO', monitor_status);
      IFEND;


    END /process_request/;

    request_block.status := monitor_status;


  PROCEND iop$subsystem_queue_request;

?? TITLE := 'cmp$queue_unit_request_entry', EJECT ??

  PROCEDURE cmp$queue_unit_request_entry
    (    logical_unit: iot$logical_unit;
         unit_queuing_option: cmt$unit_queuing_options;
     VAR io_request_p: ^iot$io_request;
     VAR able_to_queue_unit_request: boolean);

    VAR
      p_unit_queue_lockword: ^iot$lockword,
      new_lock_p: ^iot$lockword,
      p_unit_interface_table: ^iot$unit_interface_table,
      actual_lock: iot$lockword,
      lock_set: boolean,
      lock_cleared: boolean,
      first_entry_in_queue: boolean,
      current_request_p: ^cmt$max_wired_unit_queue_req,
      queue_count: integer,
      next_io_request_p: ^iot$io_request,
      next_request_p: ^cmt$max_wired_unit_queue_req,
      rma: integer,
      next_request_rma: ost$word,
      previous_request_p: ^cmt$max_wired_unit_queue_req,
      pp_request_p: ^cmt$pp_request;

  /process_request/
    BEGIN

      able_to_queue_unit_request := TRUE;

      queue_count := 0;

      current_request_p := io_request_p^.device_request_p;
      pp_request_p := ^current_request_p^.request;

      pp_request_p^.next_pp_request := NIL;
      pp_request_p^.next_pp_request_rma := 0;

      p_unit_interface_table := cmv$logical_unit_table^ [logical_unit].unit_interface_table;
      p_unit_queue_lockword := ^p_unit_interface_table^.unit_q_lockword;
{
{ Set unit queue lockword. }
{

      new_lock_p := #LOC (iov$new_queue_lock);

     iop$set_queue_lockword (p_unit_queue_lockword^, iov$initial_queue_lock, new_lock_p^,
                actual_lock, lock_set);

      IF NOT lock_set THEN
        able_to_queue_unit_request := FALSE;
        EXIT /process_request/;
      IFEND;

    /unit_queue_lock_set/
      BEGIN

        IF p_unit_interface_table^.unit_status.disabled THEN
           able_to_queue_unit_request := FALSE;
           EXIT /unit_queue_lock_set/;
        IFEND;


        {
        {Insert request in unit queue.}
        {
        next_io_request_p := p_unit_interface_table^.next_request;
        next_request_rma := p_unit_interface_table^.next_request_rma;
        first_entry_in_queue := (next_io_request_p = NIL);

        i#real_memory_address (#LOC (pp_request_p^), rma);

        IF NOT first_entry_in_queue THEN
          CASE unit_queuing_option OF

          = cmc$first_in_first_out_queue =

          /insert_request_loop/
            WHILE next_io_request_p <> NIL DO
              previous_request_p := next_io_request_p^.device_request_p;
              next_io_request_p := previous_request_p^.request.next_pp_request;
            WHILEND /insert_request_loop/;

          ELSE
            able_to_queue_unit_request := FALSE;
            EXIT /unit_queue_lock_set/;
          CASEND;
        IFEND;

        IF first_entry_in_queue THEN
          p_unit_interface_table^.next_request := io_request_p;
          p_unit_interface_table^.next_request_rma := rma;
        ELSE
          previous_request_p^.request.next_pp_request := io_request_p;
          previous_request_p^.request.next_pp_request_rma := rma;
        IFEND;

        able_to_queue_unit_request := TRUE;

        {
        {Increment unit_queue count.}
        {
        p_unit_interface_table^.queue_count := (p_unit_interface_table^.queue_count + 1)
                      MOD #SIZE (p_unit_interface_table^.queue_count);

      END /unit_queue_lock_set/;

{
{ Clear unit queue lockword. }
{

      REPEAT

         iop$set_queue_lockword (p_unit_queue_lockword^, new_lock_p^, iov$initial_queue_lock,
                   actual_lock, lock_cleared);

      UNTIL lock_cleared;

    END /process_request/;

  PROCEND cmp$queue_unit_request_entry;
?? TITLE := 'iop$unsolicited_subsystem_resp', EJECT ??

*copyc ioh$unsolicited_subsystem_resp

  PROCEDURE [XDCL] iop$unsolicited_subsystem_resp
    (    pp_response_p: ^iot$pp_response;
         detailed_status_p: ^iot$detailed_status;
         pp: 1 .. ioc$pp_count;
     VAR status: syt$monitor_status);

      VAR
        equipment: cmt$physical_equipment_number,
        logical_unit: iot$logical_unit,
        unit_descriptor_index: integer,
        physical_unit: iot$physical_unit_number,
        physical_channel: iot$channel_number,
        unit_descriptor_entry_p: ^iot$unit_descriptor_entry,
        unit_descriptor_found: boolean,
        symptom_code: integer,
        logical_operation: iot$io_function,
        unrecovered_error: 0 .. 2,
        unit_type: iot$unit_type,
        msg_type: dst$system_logging_types,
        msg_level: dst$system_message_levels,
        msg_recorded: boolean,
        msg_descriptor_p: ^SEQ (*),
        foreign_equipment_error_log_p: ^cmt$foreign_equipment_error_log,
        iov$process_subsystem_response: [XDCL, STATIC, #GATE, oss$mainframe_wired_cb]
                          iot$response_processor := ^iop$unsolicited_subsystem_resp;

      status.normal := TRUE;


  /process_request/ BEGIN
      IF NOT cmv$logical_pp_table_p^ [pp].flags.configured THEN
        EXIT /process_request/;
      IFEND;

      logical_unit := pp_response_p^.logical_unit;
      unit_descriptor_found := FALSE;

      /locate_unit_descriptor/
          FOR unit_descriptor_index := UPPERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.
                pp_interface_table_p^.unit_descriptors) DOWNTO
                LOWERBOUND (cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p^.
                unit_descriptors) DO
             unit_descriptor_entry_p := ^cmv$logical_pp_table_p^ [pp].pp_info.
                   pp_interface_table_p^.unit_descriptors [unit_descriptor_index];
             IF unit_descriptor_entry_p^.logical_unit = logical_unit THEN
                          unit_descriptor_found := TRUE;
                          EXIT /locate_unit_descriptor/;
             IFEND;
          FOREND /locate_unit_descriptor/;

          IF NOT unit_descriptor_found THEN
               EXIT /process_request/;
          IFEND;

          physical_channel := unit_descriptor_entry_p^.physical_path.channel_number;
          physical_unit := unit_descriptor_entry_p^.physical_path.physical_unit_number;
          equipment := unit_descriptor_entry_p^.physical_path.controller_number;
          symptom_code := 0;
          unrecovered_error := 1;
          IF cmv$logical_unit_table^ [logical_unit].configured THEN
              unit_type := cmv$logical_unit_table^ [logical_unit].
                           unit_interface_table^.unit_type;
          ELSE
              unit_type := 0;
          IFEND;

          PUSH msg_descriptor_p: [[REP #SIZE (cmt$foreign_equipment_error_log) OF ost$byte]];
          RESET msg_descriptor_p;

          NEXT foreign_equipment_error_log_p IN msg_descriptor_p;
          foreign_equipment_error_log_p^.pp_response := pp_response_p^;
          foreign_equipment_error_log_p^.channel := physical_channel;
          foreign_equipment_error_log_p^.equipment := equipment;
          foreign_equipment_error_log_p^.logical_unit := logical_unit;
          foreign_equipment_error_log_p^.symptom_code := symptom_code;
          foreign_equipment_error_log_p^.unit_type := unit_type;
          foreign_equipment_error_log_p^.logical_operation := ioc$no_value;
          foreign_equipment_error_log_p^.controller_type :=
                ORD (cmv$logical_pp_table_p^ [pp].controller_info.controller_type);
          foreign_equipment_error_log_p^.display_message := FALSE;
          foreign_equipment_error_log_p^.physical_unit := physical_unit;
          foreign_equipment_error_log_p^.failure_severity := unrecovered_error;
          foreign_equipment_error_log_p^.detailed_status := detailed_status_p^;

          msg_type := dsc$general_io_error;
          msg_level := dsc$unrecovered_error;
        dsp$report_system_message  (msg_descriptor_p, msg_type,
                          msg_level, msg_recorded);

    END /process_request/;

  PROCEND iop$unsolicited_subsystem_resp;
?? TITLE := 'cmp$unlock_wired_req_rma_list', EJECT ??
  PROCEDURE [XDCL] cmp$unlock_wired_req_rma_list
    (    wired_subsystem_request_p: ^cmt$max_wired_unit_queue_req;
         normal_io_termination: boolean;
     VAR address_word_pair_count: 0 ..mmc$max_rma_list_length;
     VAR monitor_status: syt$monitor_status);

     VAR
      io_error: iot$io_error,
      io_identifier: mmt$io_identifier,
      rma_list_p: ^mmt$rma_list,
      io_type: iot$io_function,
      command_address_word_pair_count: 0 .. mmc$max_rma_list_length,
      page_offset: 0 .. 65535,
      pfti: mmt$page_frame_index,
      pfte_p: ^mmt$page_frame_table_entry,
      data_pva: ^cell,
      data_length: ost$byte_count,
      rma_list_index: 0 .. mmc$max_rma_list_length,
      number_of_data_commands: cmt$command_index,
      data_command_descriptor_index: integer,
      data_command_description_p: ^cmt$wired_data_descriptors,
      command_heap_p: ^cmt$subsystem_command_heap,
      mmv$pft_p: [XREF] ^mmt$page_frame_table,
      pp_request_p: ^cmt$pp_request;

      monitor_status.normal := TRUE;

      io_identifier.specified := FALSE;
      pp_request_p := ^wired_subsystem_request_p^.request;
      data_command_description_p := wired_subsystem_request_p^.wired_data_command_descript_p;
      number_of_data_commands := wired_subsystem_request_p^.number_of_data_descriptors;
      command_heap_p := wired_subsystem_request_p^.wired_command_heap_p;

      /unlock_data_pages/
      FOR data_command_descriptor_index := 1 TO number_of_data_commands DO
          IF NOT data_command_description_p^ [data_command_descriptor_index].lock_data_pages THEN
            CYCLE /unlock_data_pages/;
          IFEND;
          CASE data_command_description_p^ [data_command_descriptor_index].io_direction OF
              =cmc$read_into_memory, cmc$read_write_memory =
                io_type := ioc$explicit_read;
              = cmc$write_from_memory =
                io_type := ioc$explicit_write;
              = cmc$no_memory_reference =
                CYCLE /unlock_data_pages/;
          CASEND;
          rma_list_index := data_command_description_p^ [data_command_descriptor_index].rma_list_index;
          IF rma_list_index = 0 THEN
            CYCLE /unlock_data_pages/;
          IFEND;
          data_pva := data_command_description_p^ [data_command_descriptor_index].address;
          data_length := data_command_description_p^ [data_command_descriptor_index].length;
          rma_list_p := #LOC (command_heap_p^.rma_list [rma_list_index]);
          page_offset := #offset (data_pva) MOD osv$page_size;
          command_address_word_pair_count := ((page_offset + data_length + osv$page_size - 1) DIV
                osv$page_size);

          IF normal_io_termination THEN
            io_error := ioc$no_error;
          ELSE
            io_error := ioc$unrecovered_error;
          IFEND;
          io_identifier.io_function := io_type;
{
{ Make sure there is a reason to unlock before calling monitor.
        pfti := rma_list_p^ [command_address_word_pair_count].rma DIV osv$page_size;
        pfte_p := ^mmv$pft_p^ [pfti];
        IF pfte_p^.active_io_count = 0 THEN
          iop$mtr_set_status_abnormal (ioe$unable_to_unlock_rma_list,
             'No entry to unlock in rma list - ',monitor_status);

          EXIT /unlock_data_pages/;
        IFEND;
{
          mmp$unlock_rma_list (io_type, rma_list_p, command_address_word_pair_count, io_identifier,
                {MF_JOB_FILE} FALSE, io_error, monitor_status);
          IF NOT monitor_status.normal THEN
            iop$mtr_set_status_abnormal (ioe$unable_to_unlock_rma_list,
                  'Unable to unlock rma list - IOMMSSIO', monitor_status);
            EXIT /unlock_data_pages/;
          IFEND;

          address_word_pair_count := address_word_pair_count - command_address_word_pair_count;
          IF address_word_pair_count <= 0 THEN
            EXIT /unlock_data_pages/;
          IFEND;

        FOREND /unlock_data_pages/;

        wired_subsystem_request_p^.address_word_pair_count := address_word_pair_count;

  PROCEND cmp$unlock_wired_req_rma_list;





  PROCEDURE [XDCL] cmp$unlock_wired_rma_list
    (VAR request_block: iot$monitor_request_block);

    VAR
       wired_request: ^cmt$max_wired_unit_queue_req,
       normal_termination: boolean,
       address_count: 0 .. mmc$max_rma_list_length,
       monitor_status: syt$monitor_status;

      normal_termination := TRUE;
      address_count := 1;
      monitor_status.normal := TRUE;
      wired_request := request_block.wired_request;

      cmp$unlock_wired_req_rma_list (wired_request,
         normal_termination, address_count, monitor_status);

  PROCEND cmp$unlock_wired_rma_list;

MODEND iom$subsystem_io_mtr_processing;
*DECK DECK=IOM$SUBSYSTEM_IO_R113 EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? TITLE := 'NOS/VE Subsystem IO' ??
?? NEWTITLE := '  Module Header', EJECT ??
MODULE iom$subsystem_io_r113;
{
{  PURPOSE: This module contains the ring 1 code to support subsystem io.
{           The code consists of procedures involved in queuing requests
{           to io queues.
{
{  DESIGN:  An io request has an associated wired io request which is used
{           to communicate between the PP system and the CP system.  The
{           wired io request is dynamically allocated in the mainframe wired
{           heap.  Currently, for unit requests, io pages are locked and
{           converted to rmas via a monitor request.  For pp requests, io
{           pages are assumed to be in mainframe wired (thus no locking is
{           required), the io page rma translation is done in ring 1 and
{           the request is queued by ring 1 code.
{
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cyd$cybil_structure_definitions
*copyc cmt$io_commands
*copyc cmt$io_command_table
*copyc cmt$subsystem_equip_description
*copyc iot$request_recovery
*copyc iot$pva_list
*copyc iot$pp_interface_table
*copyc iot$io_completion_table
*copyc iot$io_request
*copyc iot$logical_unit
*copyc mme$condition_codes
*copyc osc$purge_map_and_cache
*copyc osd$virtual_address
*copyc ost$signature_lock
*copyc ost$hardware_subranges
*copyc ost$page_size
*copyc ioe$st_errors
?? POP ??
?? TITLE := '  XREF Procedures', EJECT ??
*copyc i#real_memory_address
*copyc pmp$cycle
*copyc pmp$zero_out_table
*copyc cmp$get_logical_pp_number
*copyc cmp$get_logical_unit_number
*copyc cmp$set_ioct_serial_lock
*copyc cmp$clear_ioct_serial_lock
*copyc iop$set_queue_lockword
*copyc cmp$get_io_completion_tbl_entry
*copyc osp$begin_system_activity
*copyc osp$clear_mainframe_sig_lock
*copyc osp$end_system_activity
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc pmp$get_compact_date_time
*copyc i#build_adaptable_seq_pointer
*copyc i#call_monitor
*copyc iop$set_status_abnormal
?? TITLE := '  XREF Variables', EJECT ??
*copyc cmv$subsys_io_responses
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc osv$mainframe_wired_heap
*copyc osv$mainframe_wired_cb_heap
*copyc iov$subsys_process_pp_response
*copyc iov$queue_lockword_values
*copyc osv$external_interrupt_selector
*copyc osv$page_size
    VAR
      dmv$external_interrupt_selector: [XREF] 0 .. 0ff(16);
?? TITLE := '  build_wired_unit_queue_request', EJECT ??

  PROCEDURE build_wired_queue_request (io_request_id: cmt$subsystem_io_request_id;
        data_command_descriptors_p: ^cmt$data_command_descriptors;
        command_table_p: ^cmt$io_command_table;
    VAR status: ost$status);

    VAR
      wired_queue_request_p: ^cmt$wired_unit_queue_request,
      io_request_p: ^iot$io_request,
      pp_response_p: ^cmt$collected_pp_response,
      wired_data_command_descript_p: ^cmt$wired_data_descriptors,
      command_table_index: cmt$command_index,
      number_of_wired_descriptors: cmt$command_index,
      lock_data_pages: boolean,
      data_cannot_span_pages: boolean,
      number_of_command_entries: integer,
      command_heap_p: ^cmt$subsystem_command_heap,
      number_of_command_heap_entries: integer,
      data_p: ^SEQ ( * ),
      move_data_from_wired_area: boolean,
      request_block_p: ^iot$monitor_request_block,
      pva: ^cell,
      move_data_to_wired_area: boolean,
      length: ost$segment_length,
      io_completion_queue_index: cmt$io_completion_queue_index,
      io_completion_table_entry_p: ^cmt$io_completion_table_entry,
      data_command_descriptor_index: integer,
      page_offset: 0 .. 65535,
      wired_data_descriptor_area_p: ^cmt$wired_descriptor_area,
      wired_data_area_p: ^SEQ ( * ),
      global_task_id: ost$global_task_id,
      wired_heap_p: ^ost$heap,
      number_data_command_descriptors: cmt$command_index;

  /process_request/
    BEGIN

      status.normal := TRUE;

      wired_data_command_descript_p := NIL;
      command_heap_p := NIL;
      wired_heap_p := osv$mainframe_wired_cb_heap;
      number_of_command_heap_entries := 0;
      number_of_wired_descriptors := 0;
      io_completion_queue_index := io_request_id.system_supplied;
      number_of_command_entries := UPPERBOUND (command_table_p^);

      cmp$get_io_completion_tbl_entry (io_completion_queue_index, io_completion_table_entry_p);

      wired_queue_request_p := io_completion_table_entry_p^.wired_unit_queue_request_p;
      IF wired_queue_request_p = NIL THEN
         ALLOCATE wired_queue_request_p: [1 .. cmc$max_command_index] IN wired_heap_p^;
         ALLOCATE pp_response_p IN wired_heap_p^;
         ALLOCATE io_request_p IN wired_heap_p^;
         io_request_p^.device_request_p := wired_queue_request_p;
         io_request_p^.response_processor_p := iov$subsys_process_pp_response;
         ALLOCATE wired_data_command_descript_p: [1 .. cmc$max_command_index] IN wired_heap_p^;
         ALLOCATE command_heap_p: [1 .. mmc$max_rma_list_length] IN wired_heap_p^;
         ALLOCATE request_block_p IN wired_heap_p^;

         wired_queue_request_p^.wired_pp_response_p := pp_response_p;
         wired_queue_request_p^.wired_io_request_p := io_request_p;
         wired_queue_request_p^.wired_data_command_descript_p := wired_data_command_descript_p;
         wired_queue_request_p^.wired_command_heap_p := command_heap_p;
         wired_queue_request_p^.response_area_p := cmv$subsys_io_responses_p;
         wired_queue_request_p^.monitor_request_block_p := request_block_p;

         io_completion_table_entry_p^.wired_unit_queue_request_p :=
                                                  wired_queue_request_p;
      IFEND;
      pp_response_p := wired_queue_request_p^.wired_pp_response_p;
      pp_response_p^.response_status := cmc$subsys_io_resp_not_avail;
      pp_response_p^.pp_number := 0;
      pmp$zero_out_table (#LOC (pp_response_p^.pp_response), #SIZE (pp_response_p^.pp_response));
      pmp$zero_out_table (#LOC (pp_response_p^.detailed_status), #SIZE (pp_response_p^.detailed_status));

      cmp$create_io_queue_request (command_table_p,
                                   wired_queue_request_p, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      global_task_id := io_completion_table_entry_p^.global_task_id;

      IF data_command_descriptors_p <> NIL THEN

        number_data_command_descriptors := UPPERBOUND (data_command_descriptors_p^);

        wired_data_command_descript_p := wired_queue_request_p^.wired_data_command_descript_p;

        FOR data_command_descriptor_index := 1 TO number_data_command_descriptors DO
          move_data_to_wired_area := data_command_descriptors_p^ [data_command_descriptor_index].
                move_data_to_wired_area;
          move_data_from_wired_area := data_command_descriptors_p^ [data_command_descriptor_index].
                move_data_from_wired_area;
          lock_data_pages := data_command_descriptors_p^ [data_command_descriptor_index].
                             lock_data_pages;
          pva := data_command_descriptors_p^ [data_command_descriptor_index].address;
          length := data_command_descriptors_p^ [data_command_descriptor_index].length;
          command_table_index := data_command_descriptors_p^ [data_command_descriptor_index].command_index;

          IF  move_data_to_wired_area OR  move_data_from_wired_area OR lock_data_pages THEN
              number_of_wired_descriptors := number_of_wired_descriptors + 1;
              wired_data_command_descript_p^ [number_of_wired_descriptors].command_index :=
                                                  command_table_index;
              wired_data_command_descript_p^ [number_of_wired_descriptors].rma_list_index := 0;
              wired_data_command_descript_p^ [number_of_wired_descriptors].lock_data_pages :=
                                     lock_data_pages;
              wired_data_command_descript_p^ [number_of_wired_descriptors].io_direction :=
                     data_command_descriptors_p^[data_command_descriptor_index].io_direction;
              wired_data_command_descript_p^ [number_of_wired_descriptors].data_descriptor_index :=
                                               data_command_descriptor_index;
              wired_data_command_descript_p^ [number_of_wired_descriptors].length := length;
              wired_data_command_descript_p^ [number_of_wired_descriptors].address := pva;

              IF move_data_to_wired_area OR move_data_from_wired_area THEN
                 data_cannot_span_pages := NOT command_table_p^ [command_table_index].flags.indirect_address;
                 get_wired_data_seq (data_cannot_span_pages, length, wired_data_descriptor_area_p);
                 wired_data_area_p := ^wired_data_descriptor_area_p^.data_area;
                 RESET wired_data_area_p;
                 IF move_data_to_wired_area THEN
                    i#build_adaptable_seq_pointer (#ring (pva), #segment (pva), #offset (pva),
                                                   length, 0, data_p);
                    RESET data_p;
                    wired_data_area_p^ := data_p^;
                 ELSE
                    pmp$zero_out_table (#LOC (wired_data_area_p^), length);
                 IFEND;
                 wired_data_command_descript_p^ [number_of_wired_descriptors].address := #LOC
                        (wired_data_descriptor_area_p^);
              IFEND;
              page_offset := #offset (wired_data_command_descript_p^
                                     [number_of_wired_descriptors].address) MOD osv$page_size;
              number_of_command_heap_entries := number_of_command_heap_entries + ((page_offset +
                                                length + osv$page_size - 1) DIV osv$page_size);
            IFEND;
         FOREND;

      IFEND;

      IF number_of_command_heap_entries > 0 THEN

        command_heap_p := wired_queue_request_p^.wired_command_heap_p;

        pmp$zero_out_table ( #LOC(command_heap_p^), #SIZE (command_heap_p^));

      IFEND;

      wired_queue_request_p^.io_identification := io_request_id;
      wired_queue_request_p^.task_id := global_task_id;
      wired_queue_request_p^.number_of_commands := number_of_command_entries;
      wired_queue_request_p^.unit_queuing_control := cmc$first_in_first_out_queue;
      wired_queue_request_p^.task_is_to_be_readied := FALSE;
      wired_queue_request_p^.number_of_data_descriptors := number_of_wired_descriptors;
      IF dmv$external_interrupt_selector = 1 THEN
          wired_queue_request_p^.request.interrupt.value := TRUE;
      ELSE
          wired_queue_request_p^.request.interrupt.value := FALSE;
      IFEND;
      wired_queue_request_p^.request.interrupt.port_number :=
            osv$external_interrupt_selector;
      wired_queue_request_p^.address_word_pair_count := 0;

    END /process_request/;

  PROCEND build_wired_queue_request;
?? TITLE := '  create_peripheral_request', EJECT ??

  PROCEDURE create_peripheral_request (
        pp_request_p: ^cmt$pp_request;
    VAR status: ost$status);

    status.normal := TRUE;

    pp_request_p^.fill1 := 0;
    pp_request_p^.next_pp_request := NIL;
    pp_request_p^.fill2 := 0;
    pp_request_p^.next_pp_request_rma := 0;
    pp_request_p^.request_length := #SIZE (pp_request_p^);
    pp_request_p^.logical_unit := 0;
    pp_request_p^.recovery := ioc$terminate_at_error;
    pp_request_p^.interrupt.value := FALSE;
    pp_request_p^.interrupt.port_number := 1;
    pp_request_p^.priority := 0;
    pp_request_p^.alert_mask.compare_not_satisfied := FALSE;
    pp_request_p^.alert_mask.long_input_block := FALSE;
    pp_request_p^.alert_mask.physical_delimiter := FALSE;
    pp_request_p^.alert_mask.logical_delimiter := FALSE;
    pp_request_p^.alert_mask.character_fill := FALSE;
    pp_request_p^.alert_mask.fill := 0;
    pp_request_p^.current_command_index := 0;
    pp_request_p^.fill3 := 0;

    pmp$zero_out_table (#LOC (pp_request_p^.commands),
                        #SIZE (pp_request_p^.commands));

  PROCEND create_peripheral_request;
?? TITLE := '  get_wired_data_seq', EJECT ??

  PROCEDURE get_wired_data_seq (data_cannot_span_pages: boolean;
        data_length: ost$segment_length;
    VAR wired_data_descriptor_area_p: ^cmt$wired_descriptor_area);

    VAR
      wired_data_area_p: ^SEQ (*);

    wired_data_area_p := NIL;

      ALLOCATE wired_data_descriptor_area_p: [[REP data_length OF ost$byte]] IN osv$mainframe_wired_cb_heap^;

      wired_data_area_p := ^wired_data_descriptor_area_p^.data_area;

  PROCEND get_wired_data_seq;

?? TITLE := '  [XDCL, #GATE] cmp$build_wired_queue_request', EJECT ??

*copyc cmh$build_wired_queue_request

  PROCEDURE [XDCL, #GATE] cmp$build_wired_queue_request (element_name: cmt$element_name;
        request_type: cmt$io_request_type;
        command_table_p: ^cmt$io_command_table;
        data_command_descriptors_p: ^cmt$data_command_descriptors;
        request_id: cmt$subsystem_io_request_id;
        io_response_p: ^cmt$os_subsystem_io_response;
    VAR status: ost$status);

    VAR
      io_completion_table_entry_p: ^cmt$io_completion_table_entry;


    status.normal := TRUE;

  /process_request/
    BEGIN

      build_wired_queue_request (request_id, data_command_descriptors_p, command_table_p,
                                 status);
      IF NOT status.normal THEN
         EXIT /process_request/;
      IFEND;

      cmp$get_io_completion_tbl_entry (request_id.system_supplied, io_completion_table_entry_p);

      io_completion_table_entry_p^.io_request_type.kind := request_type;
      io_completion_table_entry_p^.io_request_type.element_name := element_name;

    END /process_request/;


  PROCEND cmp$build_wired_queue_request;
?? TITLE := '  cmp$build_rma_list', EJECT ??

*copyc ioh$build_rma_list

  PROCEDURE cmp$build_rma_list (pva_list_p: ^iot$pva_list;
        rma_list_p: ^mmt$rma_list;
        rma_list_length: mmt$rma_list_length);

    VAR
      rma_list_index: mmt$rma_list_index,
      length: ost$segment_length,
      page_offset: ost$segment_offset,
      unused_rma_list_index: mmt$rma_list_index,
      pva: ^cell,
      rma: integer,
      pva_list_index: integer;

    rma_list_index := LOWERBOUND (rma_list_p^);

    FOR pva_list_index := 1 TO UPPERBOUND (pva_list_p^) DO
      pva := pva_list_p^ [pva_list_index].address;
      length := pva_list_p^ [pva_list_index].length;
      page_offset := #offset (pva) MOD osv$page_size;

      WHILE length <> 0 DO
        i#real_memory_address (pva, rma);

        rma_list_p^ [rma_list_index].rma := rma;
        rma_list_p^ [rma_list_index].fill := 0;

        IF page_offset + length > osv$page_size THEN
          rma_list_p^ [rma_list_index].length := osv$page_size - page_offset;
        ELSE
          rma_list_p^ [rma_list_index].length := length;
        IFEND;

        length := length - rma_list_p^ [rma_list_index].length;
        page_offset := 0;
        pva := #address (#ring (pva),  #segment (pva),
                          rma_list_p^ [rma_list_index].length);
        rma_list_index := rma_list_index + 1;
        IF rma_list_index > (rma_list_length + 1) THEN
          osp$system_error ('RMA list length error - IOMSSIOR113', NIL);
        IFEND;

      WHILEND;

    FOREND;

    {
    { Fill unused rma list entries.
    {
    unused_rma_list_index := rma_list_index;
    WHILE unused_rma_list_index <= rma_list_length DO
      rma_list_p^ [unused_rma_list_index].rma := 0;
      rma_list_p^ [unused_rma_list_index].length := 0;
      rma_list_p^ [unused_rma_list_index].fill := 0;
      unused_rma_list_index := unused_rma_list_index + 1;
    WHILEND;

  PROCEND cmp$build_rma_list;
?? TITLE := '  cmp$create_io_queue_request', EJECT ??

  PROCEDURE cmp$create_io_queue_request (
        command_table_p: ^cmt$io_command_table;
    VAR queue_request_p: ^cmt$wired_unit_queue_request;
    VAR status: ost$status);

    VAR
      command_index: cmt$command_index,
      command_code: cmt$command_code,
      command_table_size: cmt$command_index,
      pp_request_p: ^cmt$pp_request;

    status.normal := TRUE;

  /process_request/
    BEGIN

      command_table_size := UPPERBOUND (command_table_p^);

      pp_request_p := ^queue_request_p^.request;

      create_peripheral_request ( pp_request_p, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      FOR command_index := LOWERBOUND (command_table_p^) TO command_table_size DO
        command_code := command_table_p^ [command_index].command_code;
        pp_request_p^.commands [command_index].command_code := command_code;
        pp_request_p^.commands [command_index].flags := command_table_p^ [command_index].
              flags;
        CASE command_code OF
        = cmc$cc_acknowledge .. cmc$cc_resume, cmc$cc_start_ready_scan .. cmc$cc_select_pp_address,
          cmc$cc_enable_unit .. cmc$cc_master_clear_controller, cmc$cc_function,
          cmc$cc_select_density, cmc$first_pp_dependent_cc .. cmc$last_pp_dependent_cc,
          cmc$first_unit_Dependent_cc .. cmc$last_unit_dependent_cc =
          pp_request_p^.commands [command_index].length := command_table_p^ [command_index].
                length;
          pp_request_p^.commands [command_index].address := command_table_p^ [command_index].
                value;
        ELSE
        CASEND;
      FOREND;

      pp_request_p^.request_length := pp_request_p^.request_length -
           (cmc$max_command_index - command_table_size) * #SIZE (cmt$command);

    END /process_request/;

  PROCEND cmp$create_io_queue_request;
?? TITLE := '  [XDCL, #GATE] cmp$get_subsys_equip_desc_r1', EJECT ??

*copyc cmh$get_subsys_equip_desc_r1

      PROCEDURE [XDCL, #GATE] cmp$get_subsys_equip_desc_r1 (
                        pp_number: iot$pp_number;
                        logical_unit: iot$logical_unit;
                    VAR equipment_description: cmt$subsystem_equip_description;
                    VAR status: ost$status);

      VAR
        equipment: cmt$physical_equipment_number,
        controller_type: cmt$controller_type,
        unit_descriptor_index: integer,
        physical_unit: iot$physical_unit_number,
        physical_channel: iot$channel_number,
        unit_descriptor_found: boolean,
        unit_descriptor_entry_p: ^iot$unit_descriptor_entry,
        unit_type: iot$unit_type;

      status.normal := TRUE;

      unit_type := 0;
      unit_descriptor_found := FALSE;

/locate_unit_descriptor/
      FOR unit_descriptor_index := UPPERBOUND (cmv$logical_pp_table_p^
             [pp_number].pp_info.pp_interface_table_p^.unit_descriptors) DOWNTO
             LOWERBOUND (cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p^.
             unit_descriptors) DO
         unit_descriptor_entry_p := ^cmv$logical_pp_table_p^ [pp_number].pp_info.
                pp_interface_table_p^.unit_descriptors [unit_descriptor_index];
         IF unit_descriptor_entry_p^.logical_unit = logical_unit THEN
            unit_descriptor_found := TRUE;
            EXIT /locate_unit_descriptor/;
         IFEND;
      FOREND /locate_unit_descriptor/;

      IF NOT unit_descriptor_found THEN
        iop$set_status_abnormal (ioe$unable_to_destroy_io_req,
                   'Unable to locate unit descriptor - IOMSSIOR113', status);
        RETURN;
      IFEND;

      equipment_description.physical_channel := unit_descriptor_entry_p^.physical_path.
                                    channel_number;
      equipment_description.physical_unit := unit_descriptor_entry_p^.physical_path.
                                    physical_unit_number;
      equipment_description.equipment := unit_descriptor_entry_p^.physical_path.
                                    controller_number;
      equipment_description.unit_type := cmv$logical_unit_table^ [logical_unit].
                                    unit_interface_table^.unit_type;
      equipment_description.controller_type :=
            cmv$logical_pp_table_p^ [pp_number].controller_info.controller_type;
      equipment_description.pp_number := pp_number;
      equipment_description.logical_unit := logical_unit;

PROCEND cmp$get_subsys_equip_desc_r1;
?? TITLE := '  [XDCL, #GATE] cmp$queue_request_r1', EJECT ??

*copyc cmh$queue_request_r1

  PROCEDURE [XDCL, #GATE] cmp$queue_request_r1 (request_id: cmt$subsystem_io_request_id;
                                                queue_control: cmt$unit_queuing_options;
                                                recovery_options: iot$request_recovery;
                                                ready_task_upon_io_completion: boolean;
                                            VAR status: ost$status);

    VAR
      wired_queue_request_p: ^cmt$wired_unit_queue_request,
      element_name: cmt$element_name,
      job_io_completion_queue_index: cmt$io_completion_queue_index,
      io_completion_table_entry_p: ^cmt$io_completion_table_entry,
      binary_time: ost$date_time,
      command_table_index: cmt$command_index,
      data_command_descriptors_p: ^cmt$data_command_descriptors,
      logical_pp_number: iot$pp_number,
      logical_unit_number: iot$logical_unit,
      command_code: cmt$command_code,
      data_command_descriptor_index: cmt$command_index,
      request_type: cmt$io_request_type;


  /process_request/
    BEGIN

      status.normal := TRUE;


      job_io_completion_queue_index := request_id.system_supplied;

      cmp$get_io_completion_tbl_entry (job_io_completion_queue_index, io_completion_table_entry_p);

      wired_queue_request_p := io_completion_table_entry_p^.wired_unit_queue_request_p;

      IF (request_id.system_supplied = 0) OR
         (request_id <> wired_queue_request_p^.io_identification) THEN
        iop$set_status_abnormal (ioe$request_id_mismatch,
          'Request id mismatch when queuing pp request - IOMSSIOR113', status);
        EXIT /process_request/;
      IFEND;

      request_type := io_completion_table_entry_p^.io_request_type.kind;
      data_command_descriptors_p := io_completion_table_entry_p^.data_command_descriptors_p;

      element_name := io_completion_table_entry_p^.io_request_type.element_name;

{ Check if PP is already loaded.

      cmp$get_logical_pp_number (element_name, logical_pp_number, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;
      IF NOT cmv$logical_pp_table_p^ [logical_pp_number].flags.pp_loaded THEN
        iop$set_status_abnormal (ioc$pp_not_configured,
              'IO queue request aborted, PP not loaded/assigned - IOMSSIOR113', status);
        EXIT /process_request/;
      IFEND;

      cmp$get_logical_unit_number (element_name, logical_unit_number, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;
      wired_queue_request_p^.task_is_to_be_readied := ready_task_upon_io_completion;
      wired_queue_request_p^.unit_queuing_control := queue_control;
      wired_queue_request_p^.request.recovery := recovery_options;
      wired_queue_request_p^.request.logical_unit := logical_unit_number;

      CASE request_type OF
      = cmc$pp_io =
          queue_pp_request (element_name, wired_queue_request_p, status);
      = cmc$unit_io =
          queue_unit_request (element_name, wired_queue_request_p, status);
      CASEND;


    END /process_request/;


PROCEND cmp$queue_request_r1;

?? TITLE := '  queue_pp_request', EJECT ??
  PROCEDURE queue_pp_request (element_name: cmt$element_name;
                              wired_pp_queue_request_p: ^cmt$wired_unit_queue_request;
                          VAR status: ost$status);

    VAR
      pp_interface_queue_lockword_p: ^iot$lockword,
      pp_interface_table_p: ^iot$pp_interface_table,
      pp_number: iot$pp_number,
      pp_request_p: ^cmt$pp_request,
      data_length: cmt$data_descriptor_length,
      command_heap_p: ^cmt$subsystem_command_heap,
      command_length: cmt$command_length,
      pva_list_p: ^iot$pva_list,
      rma_list_index: 0 .. mmc$max_rma_list_length,
      command_index: 0 .. mmc$max_rma_list_length,
      command_address_word_pair_count: 0 .. mmc$max_rma_list_length,
      address_word_pair_count: 0 .. mmc$max_rma_list_length,
      rma: integer,
      command_rma_list_p: ^mmt$rma_list,
      create_indirect_rma_list: boolean,
      data_command_descriptors_p: ^cmt$data_command_descriptors,
      wired_data_descriptors_p: ^cmt$wired_data_descriptors,
      byte_p: ^ost$byte,
      ring: ost$ring,
      segment: ost$segment,
      offset: ost$segment_offset,
      number_data_command_descriptors: integer,
      data_in_wired_area: boolean,
      address_p: ^cell,
      first_byte_in_page_to_touch: ost$byte,
      io_completion_table_entry_p: ^cmt$io_completion_table_entry,
      job_io_completion_queue_index: cmt$io_completion_queue_index,
      last_byte_to_touch: ost$byte,
      wired_data_descriptor_index: cmt$command_index,
      data_command_descriptor_index: cmt$command_index,
      page_index: 0 .. osc$max_segment_length DIV osc$min_page_size,
      number_of_pages: 0 .. osc$max_segment_length DIV osc$min_page_size,
      lock_data_pages: boolean,
      command_code: cmt$command_code,
      request_id_to_terminate_p: ^cmt$subsystem_io_request_id,
      jcq_index_to_terminate: cmt$io_completion_queue_index,
      ioct_entry_to_terminate_p: ^cmt$io_completion_table_entry,
      jcq_request_rma_to_terminate: integer,
      page_size: ost$page_size;


  /process_request/
    BEGIN

      status.normal := TRUE;

      page_size := osv$page_size;
      job_io_completion_queue_index := wired_pp_queue_request_p^.io_identification.system_supplied;
      wired_data_descriptors_p := wired_pp_queue_request_p^.wired_data_command_descript_p;
      wired_data_descriptor_index := 0;

      cmp$get_io_completion_tbl_entry (job_io_completion_queue_index, io_completion_table_entry_p);

      data_command_descriptors_p := io_completion_table_entry_p^.data_command_descriptors_p;

      cmp$get_logical_pp_number (element_name, pp_number, status);
      IF NOT status.normal THEN
          EXIT /process_request/;
      IFEND;

      IF data_command_descriptors_p <> NIL THEN
        number_data_command_descriptors := UPPERBOUND (data_command_descriptors_p^);
        PUSH pva_list_p: [1 .. 1];
        pp_request_p := ^wired_pp_queue_request_p^.request;
        command_heap_p := wired_pp_queue_request_p^.wired_command_heap_p;
        address_word_pair_count := 0;
        {
        {  Create rma lists
        {
        rma_list_index := 1;

        /process_data_descriptors/
        FOR data_command_descriptor_index := 1 TO number_data_command_descriptors DO
           command_index := data_command_descriptors_p^
                            [data_command_descriptor_index].command_index;
           command_code := pp_request_p^.commands [command_index].command_code;
           data_in_wired_area := (data_command_descriptors_p^ [data_command_descriptor_index].
                    move_data_from_wired_area) OR (data_command_descriptors_p^
                   [data_command_descriptor_index].move_data_to_wired_area);
           lock_data_pages := data_command_descriptors_p^ [data_command_descriptor_index].
                              lock_data_pages;
           data_length := data_command_descriptors_p^
                         [data_command_descriptor_index].length;
           CASE command_code OF
             = cmc$cc_stop_unit =
               request_id_to_terminate_p :=
                     data_command_descriptors_p^ [data_command_descriptor_index].address;
               jcq_index_to_terminate := request_id_to_terminate_p^.system_supplied;
               cmp$get_io_completion_tbl_entry (jcq_index_to_terminate, ioct_entry_to_terminate_p);
               IF ioct_entry_to_terminate_p^.wired_unit_queue_request_p = NIL THEN
                  iop$set_status_abnormal (ioe$unable_to_queue_io_request,
                      'Trying to terminate invalid request id - IOMSSIOR113', status);
                  EXIT /process_request/;
               IFEND;
               address_p := #LOC (ioct_entry_to_terminate_p^.wired_unit_queue_request_p^.request);
               i#real_memory_address (address_p, jcq_request_rma_to_terminate);
               IF (ioct_entry_to_terminate_p^.wired_unit_queue_request_p^.io_identification <>
                  request_id_to_terminate_p^) THEN
                   iop$set_status_abnormal (ioe$unable_to_queue_io_request,
                       'Trying to terminate invalid request id - IOMSSIOR113', status);
                EXIT /process_request/;
            IFEND;
           ELSE
            address_p := data_command_descriptors_p^
                         [data_command_descriptor_index].address;
           CASEND;

           command_rma_list_p := #LOC (command_heap_p^.rma_list [rma_list_index]);

           IF lock_data_pages THEN
             iop$set_status_abnormal (ioe$unable_to_queue_io_request,
                    'Locking pages for PP IO not supported - IOMSSIOR113', status);
             EXIT /process_request/;
           IFEND;

           IF data_in_wired_area THEN
             wired_data_descriptor_index := wired_data_descriptor_index + 1;
             address_p := wired_data_descriptors_p^ [wired_data_descriptor_index].address;
           IFEND;

           create_indirect_rma_list := pp_request_p^.commands [command_index].flags.indirect_address;

           IF create_indirect_rma_list THEN
               offset := #offset (address_p);
               command_address_word_pair_count := (((offset + data_length + (page_size * 2) -1))
                                        DIV page_size) - ((offset + page_size) DIV page_size);
           ELSE
               command_address_word_pair_count := 1;
           IFEND;

           pva_list_p^ [1].address := address_p;
           pva_list_p^ [1].length := data_length;

           cmp$build_rma_list (pva_list_p, command_rma_list_p, command_address_word_pair_count);

           address_word_pair_count := address_word_pair_count + command_address_word_pair_count;

           IF create_indirect_rma_list THEN
               i#real_memory_address (command_rma_list_p, rma);
               command_length := command_address_word_pair_count * 8;
           ELSE
               rma := command_heap_p^.rma_list [rma_list_index].rma;
               command_length := command_heap_p^.rma_list [rma_list_index].length;
           IFEND;

           pp_request_p^.commands [command_index].length := command_length;
           pp_request_p^.commands [command_index].address := rma;

           IF data_in_wired_area THEN
             wired_data_descriptors_p^ [wired_data_descriptor_index].rma_list_index := rma_list_index;
           IFEND;

           rma_list_index := rma_list_index + command_address_word_pair_count;

           FOREND /process_data_descriptors/;

           wired_pp_queue_request_p^.address_word_pair_count := address_word_pair_count;

       IFEND;

      pp_interface_table_p := cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p;
      pp_interface_queue_lockword_p := ^pp_interface_table_p^.lockword;

      cmp$queue_request (wired_pp_queue_request_p, wired_pp_queue_request_p^.unit_queuing_control,
            pp_interface_queue_lockword_p, ^pp_interface_table_p^.pp_request_queue, NIL,
            ^pp_interface_table_p^.pp_request_queue_rma, status);

    END /process_request/;


  PROCEND queue_pp_request;
?? TITLE := '  [XDCL] cmp$queue_request', EJECT ??
  PROCEDURE [XDCL] cmp$queue_request (request_p: ^cmt$wired_unit_queue_request;
        queue_control: cmt$unit_queuing_options;
        lockword_p: ^iot$lockword;
        request_queue_p: ^^iot$io_request;
        request_queue_count_p: ^ 0 .. 0FFFF(16);
        request_queue_rma_p: ^ost$real_memory_address;
    VAR status: ost$status);

    VAR
      actual_lock: iot$lockword,
      lock_set: boolean,
      lock_cleared: boolean,
      new_lock_p: ^iot$lockword,
      io_request_p: ^iot$io_request,
      request_queue_is_empty: boolean,
      next_io_request_p: ^iot$io_request,
      rma: integer,
      previous_request_p: ^cmt$max_wired_unit_queue_req,
      pp_request_p: ^cmt$pp_request;

    status.normal := TRUE;

    request_queue_is_empty := TRUE;
    next_io_request_p := NIL;
    previous_request_p := NIL;

    io_request_p := request_p^.wired_io_request_p;
    pp_request_p := ^request_p^.request;

    pp_request_p^.next_pp_request := NIL;
    pp_request_p^.next_pp_request_rma := 0;

    i#real_memory_address (#LOC (pp_request_p^), rma);

{
{ Set queue lockword. }
{

    new_lock_p := #LOC (iov$new_queue_lock);

    REPEAT

      osp$begin_system_activity;

      iop$set_queue_lockword (lockword_p^, iov$initial_queue_lock, new_lock_p^, actual_lock,
               lock_set);
      IF NOT lock_set THEN
        osp$end_system_activity;
        pmp$cycle (status);
      IFEND;

    UNTIL lock_set;

  /queue_lock_set/
    BEGIN
      {
      {Insert request in queue.}
      {
      request_queue_is_empty := (request_queue_p^ = NIL);

      IF request_queue_is_empty THEN
        request_queue_p^ := io_request_p;
        request_queue_rma_p^ := rma;
      ELSE
        next_io_request_p := request_queue_p^;

        CASE queue_control OF

        = cmc$first_in_first_out_queue =

        /insert_request_loop/
          WHILE next_io_request_p <> NIL DO
            previous_request_p := next_io_request_p^.device_request_p;
            next_io_request_p := previous_request_p^.request.next_pp_request;
          WHILEND /insert_request_loop/;

        ELSE
          iop$set_status_abnormal (ioe$io_completion_table_error, 'Unsupported queuing option - IOMSSIOR113',
                status);
          EXIT /queue_lock_set/;
        CASEND;

        previous_request_p^.request.next_pp_request := io_request_p;
        previous_request_p^.request.next_pp_request_rma := rma;
      IFEND;

    END /queue_lock_set/;

    IF request_queue_count_p <> NIL THEN
      request_queue_count_p^ := (request_queue_count_p^ + 1) MOD (0FFFF(16) + 1);
    IFEND;

{
{ Clear queue lockword. }
{
    REPEAT

      iop$set_queue_lockword (lockword_p^, new_lock_p^, iov$initial_queue_lock, actual_lock,
                              lock_cleared);
    UNTIL lock_cleared;

    osp$end_system_activity;

  PROCEND cmp$queue_request;
?? TITLE := '  queue_unit_request', EJECT ??
  PROCEDURE queue_unit_request (element_name: cmt$element_name;
                                wired_unit_queue_request_p: ^cmt$wired_unit_queue_request;
                            VAR status: ost$status);

    VAR
      pp_request_p: ^cmt$pp_request,
      data_length: cmt$data_descriptor_length,
      command_heap_p: ^cmt$subsystem_command_heap,
      command_length: cmt$command_length,
      pva_list_p: ^iot$pva_list,
      rma_list_index: 0 .. mmc$max_rma_list_length,
      command_index: 0 .. mmc$max_rma_list_length,
      command_address_word_pair_count: 0 .. mmc$max_rma_list_length,
      address_word_pair_count: 0 .. mmc$max_rma_list_length,
      rma: integer,
      command_rma_list_p: ^mmt$rma_list,
      create_indirect_rma_list: boolean,
      request_block_p: ^iot$monitor_request_block,
      unit_interface_table_p: ^iot$unit_interface_table,
      unit_queue_lockword_p: ^iot$lockword,
      queue_entry_in_monitor: boolean,
      data_command_descriptors_p: ^cmt$data_command_descriptors,
      wired_data_descriptors_p: ^cmt$wired_data_descriptors,
      byte_p: ^ost$byte,
      ring: ost$ring,
      segment: ost$segment,
      offset: ost$segment_offset,
      number_data_command_descriptors: integer,
      data_in_wired_area: boolean,
      address_p: ^cell,
      first_byte_in_page_to_touch: ost$byte,
      io_completion_table_entry_p: ^cmt$io_completion_table_entry,
      job_io_completion_queue_index: cmt$io_completion_queue_index,
      last_byte_to_touch: ost$byte,
      wired_data_descriptor_index: cmt$command_index,
      data_command_descriptor_index: cmt$command_index,
      page_index: 0 .. osc$max_segment_length DIV osc$min_page_size,
      null_sva: 0 .. 0ffffffffffff(16),
      number_of_pages: 0 .. osc$max_segment_length DIV osc$min_page_size,
      lock_data_pages: boolean,
      page_size: ost$page_size;


  /process_request/
    BEGIN

      status.normal := TRUE;

      page_size := osv$page_size;
      job_io_completion_queue_index := wired_unit_queue_request_p^.io_identification.system_supplied;
      wired_data_descriptors_p := wired_unit_queue_request_p^.wired_data_command_descript_p;
      wired_data_descriptor_index := 0;

      cmp$get_io_completion_tbl_entry (job_io_completion_queue_index, io_completion_table_entry_p);

      data_command_descriptors_p := io_completion_table_entry_p^.data_command_descriptors_p;

      queue_entry_in_monitor := FALSE;

      IF data_command_descriptors_p <> NIL THEN
        number_data_command_descriptors := UPPERBOUND (data_command_descriptors_p^);
        PUSH pva_list_p: [1 .. 1];
        pp_request_p := ^wired_unit_queue_request_p^.request;
        command_heap_p := wired_unit_queue_request_p^.wired_command_heap_p;
        address_word_pair_count := 0;
        {
        {  Create rma lists
        {
        rma_list_index := 1;

        /process_data_descriptors/
        FOR data_command_descriptor_index := 1 TO number_data_command_descriptors DO
           data_in_wired_area := (data_command_descriptors_p^ [data_command_descriptor_index].
                    move_data_from_wired_area) OR (data_command_descriptors_p^
                   [data_command_descriptor_index].move_data_to_wired_area);
           lock_data_pages := data_command_descriptors_p^ [data_command_descriptor_index].
                              lock_data_pages;
           data_length := data_command_descriptors_p^
                         [data_command_descriptor_index].length;
           address_p := data_command_descriptors_p^
                        [data_command_descriptor_index].address;
           command_rma_list_p := #LOC (command_heap_p^.rma_list [rma_list_index]);

           queue_entry_in_monitor := queue_entry_in_monitor OR lock_data_pages;

           IF lock_data_pages THEN
               wired_data_descriptor_index := wired_data_descriptor_index + 1;
               {
               { Reference each page to cause a load.
               {
               byte_p := address_p;
               ring := #ring (address_p);
               segment := #segment (address_p);
               offset := #offset (address_p);
               first_byte_in_page_to_touch := byte_p^;

               IF (offset MOD page_size + data_length) > page_size THEN
                  number_of_pages := ((offset + data_length - 1) DIV page_size) -
                                     ((offset + page_size) DIV page_size);
                  offset := (offset DIV page_size) * page_size;
                  page_index := number_of_pages;

                  /touch_full_pages/
                    WHILE page_index > 0 DO
                       offset := offset + page_size;
                       byte_p := #address (ring, segment, offset);
                       first_byte_in_page_to_touch := byte_p^;
                       page_index := page_index - 1;
                    WHILEND /touch_full_pages/;
                IFEND;
                offset := #offset (address_p) + data_length - 1;
                byte_p := #address (ring, segment, offset);
                last_byte_to_touch := byte_p^;
                CYCLE /process_data_descriptors/;
           IFEND;

           IF data_in_wired_area THEN
             wired_data_descriptor_index := wired_data_descriptor_index + 1;
             address_p := wired_data_descriptors_p^ [wired_data_descriptor_index].address;
           IFEND;

           command_index := data_command_descriptors_p^
                            [data_command_descriptor_index].command_index;
           create_indirect_rma_list := pp_request_p^.commands [command_index].flags.indirect_address;

           IF create_indirect_rma_list THEN
               offset := #offset (address_p);
               command_address_word_pair_count := (((offset + data_length + (page_size * 2) -1))
                                        DIV page_size) - ((offset + page_size) DIV page_size);
           ELSE
               command_address_word_pair_count := 1;
           IFEND;

           pva_list_p^ [1].address := address_p;
           pva_list_p^ [1].length := data_length;

           cmp$build_rma_list (pva_list_p, command_rma_list_p, command_address_word_pair_count);

           address_word_pair_count := address_word_pair_count + command_address_word_pair_count;

           IF create_indirect_rma_list THEN
               i#real_memory_address (command_rma_list_p, rma);
               command_length := command_address_word_pair_count * 8;
           ELSE
               rma := command_heap_p^.rma_list [rma_list_index].rma;
               command_length := command_heap_p^.rma_list [rma_list_index].length;
           IFEND;

           pp_request_p^.commands [command_index].length := command_length;
           pp_request_p^.commands [command_index].address := rma;

           IF data_in_wired_area THEN
              wired_data_descriptors_p^ [wired_data_descriptor_index].rma_list_index := rma_list_index;
           IFEND;

           rma_list_index := rma_list_index + command_address_word_pair_count;

           FOREND /process_data_descriptors/;

           wired_unit_queue_request_p^.address_word_pair_count := address_word_pair_count;

       IFEND;

       IF queue_entry_in_monitor THEN
         request_block_p := wired_unit_queue_request_p^.monitor_request_block_p;
         request_block_p^.request_code := syc$rc_subsystem_request;
         request_block_p^.subsystem_request_code := ioc$queue_io_request;
         request_block_p^.io_request_p := wired_unit_queue_request_p^.wired_io_request_p;

         /touch_pages/
         WHILE TRUE DO
           i#call_monitor (#LOC (request_block_p^), #SIZE (request_block_p^));
           status.normal := request_block_p^.status.normal;
           status.condition := request_block_p^.status.condition;
           IF status.normal THEN
              EXIT /touch_pages/;
           IFEND;
           IF (status.condition <> mme$page_frame_not_assigned) AND (status.condition <>
                ioe$unable_to_queue_io_request) THEN
              EXIT /touch_pages/;
           IFEND;

           #purge_buffer (osc$purge_all_cache, null_sva);


           number_data_command_descriptors := wired_unit_queue_request_p^.
                                              number_of_data_descriptors;

           /touch_data/
           FOR wired_data_descriptor_index := 1 TO number_data_command_descriptors DO
               data_length := wired_data_descriptors_p^ [wired_data_descriptor_index].length;
               address_p := wired_data_descriptors_p^ [wired_data_descriptor_index].address;
               IF NOT wired_data_descriptors_p^ [wired_data_descriptor_index].lock_data_pages THEN
                 CYCLE /touch_data/;
               IFEND;
               {
               { Reference each page to cause a load.
               {
               byte_p := address_p;
               ring := #ring (address_p);
               segment := #segment (address_p);
               offset := #offset (address_p);
               first_byte_in_page_to_touch := byte_p^;

               IF (offset MOD page_size + data_length) > page_size THEN
                  number_of_pages := ((offset + data_length - 1) DIV page_size) -
                                     ((offset + page_size) DIV page_size);
                  offset := (offset DIV page_size) * page_size;
                  page_index := number_of_pages;

                    WHILE page_index > 0 DO
                       offset := offset + page_size;
                       byte_p := #address (ring, segment, offset);
                       first_byte_in_page_to_touch := byte_p^;
                       page_index := page_index - 1;
                    WHILEND;
                IFEND;
                offset := #offset (address_p) + data_length - 1;
                byte_p := #address (ring, segment, offset);
                last_byte_to_touch := byte_p^;

             FOREND /touch_data/;

         WHILEND /touch_pages/;

         IF NOT status.normal THEN
            iop$set_status_abnormal (request_block_p^.status.condition, 'Bad monitor status from IOMSSRQP ',
                   status);
         IFEND;

        ELSE
           unit_interface_table_p := cmv$logical_unit_table^ [
                   wired_unit_queue_request_p^.request.logical_unit].unit_interface_table;

           IF unit_interface_table_p^.unit_status.disabled THEN
             iop$set_status_abnormal (ioe$unable_to_queue_io_request,
                       'Unit queuing disabled - IOMSSIOR113', status);
             EXIT /process_request/;
           IFEND;

           unit_queue_lockword_p := ^unit_interface_table_p^.unit_q_lockword;
           cmp$queue_request (wired_unit_queue_request_p , wired_unit_queue_request_p^.unit_queuing_control,
                             unit_queue_lockword_p, ^unit_interface_table_p^.next_request, NIL,
                             ^unit_interface_table_p^.next_request_rma, status);
        IFEND;
    END /process_request/;


  PROCEND queue_unit_request;
?? TITLE := '  [XDCL, #GATE] iop$return_wired_request', EJECT ??

*copyc ioh$return_wired_request

  PROCEDURE [XDCL, #GATE] iop$return_wired_request (job_io_completion_queue_index:
    cmt$io_completion_queue_index;
    VAR status: ost$status);

    VAR
      io_completion_table_entry_p: ^cmt$io_completion_table_entry,
      wired_request_p: ^cmt$wired_unit_queue_request,
      data_command_descriptor_index: integer,
      move_data_from_wired_area: boolean,
      move_data_to_wired_area: boolean,
      data_pages_were_locked: boolean,
      wired_data_pva: ^cell,
      data_pva: ^cell,
      data_p: ^SEQ ( * ),
      wired_data_length: ost$segment_length,
      wired_data_seq_p: ^SEQ ( * ),
      number_of_data_descriptors: integer,
      wired_heap_p: ^ost$heap,
      descriptor_index: cmt$command_index,
      data_command_descriptors_p: ^cmt$data_command_descriptors,
      wired_data_command_descript_p: ^cmt$wired_data_descriptors;

  /process_request/
    BEGIN

      status.normal := TRUE;

      cmp$get_io_completion_tbl_entry (job_io_completion_queue_index, io_completion_table_entry_p);

      wired_request_p := io_completion_table_entry_p^.wired_unit_queue_request_p;

      wired_heap_p := osv$mainframe_wired_cb_heap;
      wired_data_command_descript_p := wired_request_p^.wired_data_command_descript_p;
      number_of_data_descriptors := wired_request_p^.number_of_data_descriptors;
      data_command_descriptors_p := io_completion_table_entry_p^.data_command_descriptors_p;
      data_pages_were_locked := FALSE;


      IF (wired_data_command_descript_p <> NIL) AND (number_of_data_descriptors > 0) THEN
        FOR data_command_descriptor_index := 1 TO number_of_data_descriptors DO
          descriptor_index := wired_data_command_descript_p^ [data_command_descriptor_index].
                              data_descriptor_index;
          move_data_from_wired_area := data_command_descriptors_p^ [descriptor_index].
                move_data_from_wired_area;
          move_data_to_wired_area := data_command_descriptors_p^ [descriptor_index].
                move_data_to_wired_area;
          IF move_data_from_wired_area OR move_data_to_wired_area THEN
            wired_data_pva := wired_data_command_descript_p^ [data_command_descriptor_index].address;
            wired_data_length := wired_data_command_descript_p^ [data_command_descriptor_index].length;
            i#build_adaptable_seq_pointer (#ring (wired_data_pva), #segment (wired_data_pva), #offset
                  (wired_data_pva), wired_data_length, 0, wired_data_seq_p);
            RESET wired_data_seq_p;
          IFEND;
          IF move_data_from_wired_area THEN
            data_pva := data_command_descriptors_p^ [descriptor_index].address;

            i#build_adaptable_seq_pointer (#ring (data_pva), #segment (data_pva), #offset (data_pva),
                  wired_data_length, 0, data_p);
            RESET data_p;

            data_p^ := wired_data_seq_p^;

          IFEND;

          IF move_data_to_wired_area OR move_data_from_wired_area THEN
              FREE wired_data_seq_p IN osv$mainframe_wired_cb_heap^;
          IFEND;

        FOREND;

      IFEND;

      wired_request_p^.request.next_pp_request := NIL;
      wired_request_p^.request.next_pp_request_rma := 0;
      wired_request_p^.io_identification.user_supplied := 0;
      wired_request_p^.io_identification.system_supplied := 0;
      wired_request_p^.number_of_commands := 0;
      wired_request_p^.number_of_data_descriptors := 0;
      wired_request_p^.response_area_p^ (job_io_completion_queue_index, 1) := 'N';

    END /process_request/;

  PROCEND iop$return_wired_request;

?? OLDTITLE ??
  PROCEDURE [XDCL, #GATE] cmp$unlock_the_rma_list (job_io_completion_queue_index:
        cmt$io_completion_queue_index;
    VAR status: ost$status);

    VAR
      io_completion_table_entry_p: ^cmt$io_completion_table_entry,
      wired_request_p: ^cmt$wired_unit_queue_request,
      data_index: integer,
      normal_termination: boolean,
      request_block_p: ^iot$monitor_request_block,
      address_word_pair_count: 0 .. mmc$max_rma_list_length,
      monitor_status: syt$monitor_status,
      number_of_data_descriptors: integer,
      descriptor_index: cmt$command_index,
      data_command_descriptors_p: ^cmt$data_command_descriptors,
      wired_data_command_descript_p: ^cmt$wired_data_descriptors;


      status.normal := TRUE;
      normal_termination := TRUE;

      cmp$get_io_completion_tbl_entry (job_io_completion_queue_index, io_completion_table_entry_p);
      wired_request_p := io_completion_table_entry_p^.wired_unit_queue_request_p;

      IF wired_request_p <> NIL THEN
      number_of_data_descriptors := wired_request_p^.number_of_data_descriptors;
         IF number_of_data_descriptors = 0 THEN
           RETURN;
         IFEND;
      data_command_descriptors_p := io_completion_table_entry_p^.data_command_descriptors_p;
      address_word_pair_count  := wired_request_p^.address_word_pair_count;
      IF address_word_pair_count <> 0 THEN
        wired_data_command_descript_p := wired_request_p^.wired_data_command_descript_p;
        FOR data_index := 1 TO number_of_data_descriptors DO

         request_block_p := wired_request_p^.monitor_request_block_p;
         request_block_p^.request_code := syc$rc_subsystem_request;
         request_block_p^.subsystem_request_code := ioc$unlock_rma_list;
         request_block_p^.wired_request := wired_request_p;

           i#call_monitor (#LOC (request_block_p^), #SIZE (request_block_p^));
           status.normal := request_block_p^.status.normal;
           status.condition := request_block_p^.status.condition;
              IF NOT status.normal THEN
              osp$set_status_abnormal ('IO',ioe$unable_to_unlock_rma_list,
                'Unable to unlock rma list in cleanup', status);
               RETURN;
             IFEND;
        FOREND;
      IFEND;
     IFEND;


  PROCEND cmp$unlock_the_rma_list;








?? TITLE := '  [XDCL, #GATE] cmp$check_io_status', EJECT ??


  PROCEDURE [XDCL, #GATE] cmp$check_io_status (request_id: cmt$subsystem_io_request_id;
                                            VAR status: ost$status);

    VAR
      element_name: cmt$element_name,
      job_io_completion_queue_index: cmt$io_completion_queue_index,
      io_completion_table_entry_p: ^cmt$io_completion_table_entry,
      logical_pp_number: iot$pp_number;



      status.normal := TRUE;

      job_io_completion_queue_index := request_id.system_supplied;

      cmp$get_io_completion_tbl_entry (job_io_completion_queue_index, io_completion_table_entry_p);

      element_name := io_completion_table_entry_p^.io_request_type.element_name;

{ Check if PP is loaded.

      cmp$get_logical_pp_number (element_name, logical_pp_number, status);

  PROCEND cmp$check_io_status;

?? TITLE := '  [XDCL, #GATE] iop$clear_response_p', EJECT ??


  PROCEDURE [XDCL, #GATE] iop$clear_response_ptr (job_io_completion_queue_index:
    cmt$io_completion_queue_index;
    VAR status: ost$status);

    VAR
      io_completion_table_entry_p: ^cmt$io_completion_table_entry,
      wired_request_p: ^cmt$wired_unit_queue_request,
      wired_heap_p: ^ost$heap;

      status.normal := TRUE;

      cmp$get_io_completion_tbl_entry (job_io_completion_queue_index, io_completion_table_entry_p);
        IF NOT status.normal THEN
         RETURN;
        IFEND;
       IF io_completion_table_entry_p^.available THEN
{  Entry not in use.
         RETURN;
       IFEND;

      wired_request_p := io_completion_table_entry_p^.wired_unit_queue_request_p;
      wired_request_p^.response_area_p^ (job_io_completion_queue_index, 1) := 'N';

  PROCEND iop$clear_response_ptr;

  PROCEDURE [XDCL, #GATE] iop$get_in_out_ptrs (pp: iot$pp_number;
                           VAR inn: iot$response_buffer_offset;
                           VAR out: iot$response_buffer_offset);


      VAR
       ppit: ^iot$pp_interface_table;


       ppit := cmv$logical_pp_table_p^ [pp].pp_info.pp_interface_table_p;
       inn := ppit^.inn;
       out := ppit^.out;

 PROCEND iop$get_in_out_ptrs;

MODEND iom$subsystem_io_r113;
*DECK DECK=IOM$SUBSYSTEM_IO_R223 EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? TITLE := 'NOS/VE Subsystem IO' ??
?? NEWTITLE := '  Module Header', EJECT ??
MODULE iom$subsystem_io_r223;
{
{  PURPOSE: This module contains the ring 223 code to support subsystem io.
{
{  DESIGN:
{
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ioe$st_errors
?? POP ??
?? TITLE := '  XREF Procedures', EJECT ??
*copyc iop$set_status_abnormal
*copyc cmp$get_io_completion_tbl_entry
*copyc cmp$get_number_of_io_entries
*copyc cmp$destroy_io_completion_tb_r1
*copyc cmp$ssiot_termination
*copyc iop$ssiot_recovery_processing
?? TITLE := '  [XDCL, #GATE] cmp$recover_subsystem_io_table', EJECT ??

*copyc cmh$recover_subsystem_io_table

  PROCEDURE [XDCL, #GATE] cmp$recover_subsystem_io_table ( VAR status: ost$status);


      status.normal := TRUE;

      cmp$ssiot_recovery_processing (status);


PROCEND cmp$recover_subsystem_io_table;
?? TITLE := '  [XDCL, #GATE] cmp$destroy_io_completion_tb_r2', EJECT ??

*copyc cmh$destroy_io_completion_tb_r2

  PROCEDURE [XDCL, #GATE] cmp$destroy_io_completion_tb_r2 (VAR status: ost$status);

     VAR
       io_completion_table_entry_p: ^cmt$io_completion_table_entry,
       index: cmt$io_completion_queue_index,
       number_of_ioct_entries: cmt$io_completion_queue_index;

      status.normal := TRUE;

      cmp$get_number_of_io_entries (number_of_ioct_entries);
      IF number_of_ioct_entries = 0 THEN
         RETURN;
      IFEND;

      FOR index := 1 TO number_of_ioct_entries DO
         cmp$get_io_completion_tbl_entry (index, io_completion_table_entry_p);
         IF NOT io_completion_table_entry_p^.available THEN
            iop$set_status_abnormal (ioe$io_completion_table_error,
              'Trying to destroy io completion table with outstanding requests - IOMSSIOR223',
              status);
            RETURN;
         IFEND;
      FOREND;

      cmp$destroy_io_completion_tb_r1 (status);

  PROCEND cmp$destroy_io_completion_tb_r2;
?? TITLE := '  [XDCL, #GATE] cmp$subsystem_io_job_exit', EJECT ??

*copyc cmh$subsystem_io_job_exit

 PROCEDURE [XDCL, #GATE] cmp$subsystem_io_job_exit (VAR status: ost$status);

      status.normal := TRUE;

      cmp$destroy_io_completion_tb_r2 (status);

 PROCEND cmp$subsystem_io_job_exit;


 PROCEDURE [XDCL, #GATE] cmp$ssiot_termination_r2 (VAR status: ost$status);


  status.normal := TRUE;


  cmp$ssiot_termination (status);

 PROCEND cmp$ssiot_termination_r2;


MODEND iom$subsystem_io_r223;
*DECK DECK=IOM$SUBSYSTEM_IO_R236 EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? TITLE := 'NOS/VE Subsystem IO' ??
?? NEWTITLE := '  Module Header', EJECT ??
MODULE iom$subsystem_io_r236;
{
{  PURPOSE: This module contains the ring 236 code to support subsystem io.
{
{  DESIGN:
{
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmt$io_commands
*copyc cmt$subsystem_io_request_id
*copyc cme$physical_configuration_mgr
*copyc jmt$name
*copyc ost$system_flag
*copyc ost$execution_control_block
*copyc ioe$st_errors
*copyc oss$mainframe_paged_literal
*copyc oss$mainframe_wired
*copyc pmt$task_id
*copyc pmp$long_term_wait
*copyc oss$task_private
?? POP ??
?? TITLE := '  XREF Procedures', EJECT ??
*copyc cmp$get_ssiot_entry_avail_queue
*copyc cmp$add_ssiot_entry_avail_queue
*copyc cmp$clear_ioct_serial_lock
*copyc cmp$enable_foreign_io
*copyc cmp$test_and_clear_ioct_lock
*copyc cmp$get_element_information
*copyc cmp$down_foreign_io
*copyc cmp$pc_get_element
*copyc cmp$update_error_count
*copyc cmp$get_logical_pp_number
*copyc cmp$get_io_completion_tbl_entry
*copyc cmp$get_number_of_io_entries
*copyc cmp$get_subsys_equip_desc_r1
*copyc cmp$get_unit_type
*copyc cmp$hardware_idle_pp
*copyc cmp$set_ioct_serial_lock
*copyc cmp$ssiot_end_handler
*copyc cmp$ssiot_termination
*copyc cmp$store_ssiot_entry_info
*copyc cmp$build_wired_queue_request
*copyc cmp$queue_request_r1
*copyc cmp$destroy_io_completion_tb_r2
*copyc iop$set_status_abnormal
*copyc iop$clear_response_ptr
*copyc cmp$check_io_status
*copyc cmp$ssiot_recovery_condition
*copyc cmp$ssiot_recovery_complete
*copyc iop$return_wired_request
*copyc jmp$job_exists
*copyc mmp$fetch_segment_attributes
*copyc mmp$verify_access
*copyc osp$fetch_locked_variable
*copyc osp$set_locked_variable
*copyc pmp$cause_task_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$disestablish_end_handler
*copyc pmp$establish_condition_handler
*copyc pmp$establish_end_handler
*copyc pmp$format_compact_time
*copyc pmp$get_executing_task_gtid_r6
*copyc pmp$get_time
*copyc pmp$log
*copyc pmp$long_term_wait
*copyc pmp$wait
?? TITLE := '  XREF Variables', EJECT ??
*copyc cmv$logical_pp_table_p
*copyc cmv$subsys_io_responses
*copyc cmv$subsys_io_scan_variable
*copyc osv$page_size
?? TITLE := '  Global Variables', EJECT ??

     VAR
       data_descriptor_error_msg: [STATIC, READ, oss$mainframe_paged_literal] string(100) :=
              'IOMSSIOR236 Data Descriptor Entry - ',
       command_code_error_msg: [STATIC, READ, oss$mainframe_paged_literal] string(100) :=
                'IOMSSIOR236 Command Code Entry - ',
       job_recovery_condition: [STATIC, READ, oss$mainframe_paged_literal]
     pmt$condition := [pmc$user_defined_condition,'OSC$JOB_RECOVERY'],
       interactive_terminate_condition: [STATIC, READ, oss$mainframe_paged_literal]
     pmt$condition := [ifc$interactive_condition,ifc$terminate_break],
       task_end_handler_established: [STATIC,oss$task_private] boolean := FALSE;

   VAR
     cmv$free_trap: [XREF] boolean;


?? TITLE := '  [XDCL, #GATE] cmp$check_initiated_io_status', EJECT ??

*copyc cmh$check_initiated_io_status
*copyc iop$get_in_out_ptrs


  PROCEDURE [XDCL, #GATE] cmp$check_initiated_io_status (io_status_p: ^cmt$subsystem_io_status;
    VAR index: integer;
    VAR status: ost$status);

    VAR
      io_completed: boolean,
      number_of_ssio_table_entries: cmt$io_completion_queue_index,
      global_task_id: ost$global_task_id,
      subsystem_io_request_id: cmt$subsystem_io_request_id,
      io_completion_table_entry_p: ^cmt$io_completion_table_entry,
      io_status_index: integer,
      job_completion_queue_index: cmt$io_completion_queue_index,
      io_status: cmt$subsystem_io_completion_sta,
      ignore_status: ost$status;






/process_request/
  BEGIN
      status.normal := TRUE;
      index := 0;

      pmp$get_executing_task_gtid_r6 (global_task_id);

      iop$mfh_subsystem_io_completion (ioc$subsystem_io_completed);

      IF io_status_p <> NIL THEN



        /io_status_loop/
        FOR io_status_index := 1 TO UPPERBOUND (io_status_p^) DO

          subsystem_io_request_id := io_status_p^ [io_status_index].request_identification;
          job_completion_queue_index := subsystem_io_request_id.system_supplied;

          cmp$get_io_completion_tbl_entry (job_completion_queue_index, io_completion_table_entry_p);

          io_status := io_completion_table_entry_p^.io_status;

          IF io_completion_table_entry_p^.available THEN
            io_status_p^ [io_status_index].completion_status := io_status;
            CYCLE /io_status_loop/;
          IFEND;

          IF io_completion_table_entry_p^.global_task_id <> global_task_id THEN
            iop$set_status_abnormal (ioe$request_id_mismatch,
                'Request id not available to current task - IOMSSIOR236', status);
            index := io_status_index;
            EXIT /process_request/;
          IFEND;

          IF io_completion_table_entry_p^.request_identification <> subsystem_io_request_id THEN
            iop$set_status_abnormal (ioe$request_id_mismatch,
                       'Mismatch in request ids - IOMSSIOR236', status);
            index := io_status_index;
            EXIT /process_request/;
          IFEND;


          io_status_p^ [io_status_index].completion_status := io_status;

          io_completed := (io_status = cmc$subsystem_io_complete);
          IF io_completed THEN
            IF index <= 0 THEN
              index := io_status_index;
            IFEND;
          IFEND;
        FOREND /io_status_loop/;

      ELSE
        cmp$get_number_of_io_entries (number_of_ssio_table_entries);

        FOR job_completion_queue_index := 1 TO number_of_ssio_table_entries DO
          cmp$get_io_completion_tbl_entry (job_completion_queue_index, io_completion_table_entry_p);
          IF NOT io_completion_table_entry_p^.available THEN
            IF io_completion_table_entry_p^.global_task_id = global_task_id THEN
              io_status := io_completion_table_entry_p^.io_status;
              io_completed := (io_status = cmc$subsystem_io_complete);
              IF io_completed THEN
                IF index <= 0 THEN
                index := job_completion_queue_index;
              IFEND;

            IFEND;
           IFEND;
          IFEND;
        FOREND;
      IFEND;

    END /process_request/;

  PROCEND cmp$check_initiated_io_status;
?? TITLE := '  [XDCL, #GATE] cmp$complete_ssiot_recovery', EJECT ??

*copyc cmh$complete_ssiot_recovery

  PROCEDURE [XDCL, #GATE] cmp$complete_ssiot_recovery (
               VAR status: ost$status);


    status.normal := TRUE;

    cmp$ssiot_recovery_complete (status);


PROCEND cmp$complete_ssiot_recovery;
?? TITLE := '  [XDCL, #GATE] cmp$create_and_submit_io_req', EJECT ??

*copyc cmh$create_and_submit_io_req

  PROCEDURE [XDCL, #GATE] cmp$create_and_submit_io_req (request_type: cmt$io_request_type;
        element_name: cmt$element_name;
        command_table_p: ^cmt$io_command_table;
        data_command_descriptors_p: ^cmt$data_command_descriptors;
        unit_queue_control: cmt$unit_queuing_options;
        recovery_options: iot$request_recovery;
        wait_for_io_completion: cmt$wait_for_io_completion;
        io_identification: cmt$user_io_identification;
        io_response_p: ^cmt$os_subsystem_io_response;
    VAR request_id: cmt$subsystem_io_request_id;
    VAR status: ost$status);

    VAR
      logical_pp_number: iot$pp_number,
      cmv$foreign_interface_down: [XREF] boolean,
      ignore_status: ost$status;


    status.normal := TRUE;

   IF cmv$foreign_interface_down THEN
       cmp$get_logical_pp_number (element_name, logical_pp_number, status);
         IF status.condition = cme$pc_not_logically_conf THEN
          iop$set_status_abnormal (ioe$foreign_interface_down,
               'Subsystem PP not available', status);
             RETURN;
         ELSE
           cmp$enable_foreign_io ( status);
         IFEND;
   IFEND;


  /process_request/
    BEGIN

      cmp$create_io_request (request_type, element_name, command_table_p,
              data_command_descriptors_p, io_identification, io_response_p,
              request_id, status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      cmp$queue_io_request (request_id, unit_queue_control, recovery_options,
                            wait_for_io_completion, status);
      IF NOT status.normal THEN
        cmp$destroy_io_request (request_id, ignore_status);
      IFEND;

    END /process_request/;


  PROCEND cmp$create_and_submit_io_req;

?? TITLE := '  [XDCL, #GATE] cmp$create_io_request', EJECT ??

*copyc cmh$create_io_request

  PROCEDURE [XDCL, #GATE] cmp$create_io_request (request_type: cmt$io_request_type;
        element_name: cmt$element_name;
        command_table_p: ^cmt$io_command_table;
        data_command_descriptors_p: ^cmt$data_command_descriptors;
        io_identification: cmt$user_io_identification;
        io_response_p: ^cmt$os_subsystem_io_response;
    VAR request_id: cmt$subsystem_io_request_id;
    VAR status: ost$status);

    VAR
      data_descriptor_index: integer,
      data_pva_p: ^cell,
      data_length: cmt$data_descriptor_length,
      command_index: cmt$command_index,
      command_code: cmt$command_code,
      lock_data_pages: boolean,
      verify_access_mode: boolean,
      data_cannot_span_pages: boolean,
      request_id_to_terminate_p: ^cmt$subsystem_io_request_id,
      io_completion_table_entry_p: ^cmt$io_completion_table_entry,
      iou_name: cmt$element_name,
      access_mode: mmt$va_access_mode,
      ssiot_entry_information_p: ^cmt$ssiot_entry_information,
      ssiot_entry_timing_info_p: ^cmt$ssiot_entry_information,
      time_format: ost$time_formats,
      time: ost$time,
      move_data_to_wired_area: boolean,
      move_data_from_wired_area: boolean,
      need_to_lock_data_descriptors: boolean,
      computed_io_direction: cmt$io_direction,
      io_direction: cmt$io_direction,
      job_completion_queue_index: cmt$io_completion_queue_index,
      product_identification: cmt$product_identification,
      element_information_p: ^cmt$element_information,
      element_descriptor: cmt$element_descriptor,
      last_element_name: [STATIC] cmt$element_name := ' ',
      cm_unit_type: [STATIC] cmt$unit_type,
      command_sequence: boolean,
      sequence_of_commands_allowed: boolean,
      unit_command_sequence: boolean,
      io_unit_type: [STATIC] iot$unit_type,
      verify_not_code_segment: boolean,
      verify_wired_cache_bypass_seg: boolean,
      number_of_ioct_entries: cmt$io_completion_queue_index,
      segment_attributes_p: ^array [*] of mmt$attribute_descriptor,
      unit_class: [STATIC] cmt$unit_class,
      number_of_commands: cmt$command_index,
      element_found: [STATIC] boolean,
      data_descriptor_error: string(100),
      command_code_error: string(100),
      element : ^cmt$element_definition,
      conversion_length: integer,
      ignore_status: ost$status;


    status.normal := TRUE;

  /process_request/
    BEGIN
      need_to_lock_data_descriptors := FALSE;

      io_response_p^.io_status := ORD (cmc$subsys_io_resp_not_avail);

      IF NOT task_end_handler_established THEN
         pmp$establish_end_handler (^cmp$subsystem_io_end_handler, status);
         IF NOT status.normal THEN
            EXIT /process_request/;
         IFEND;
         task_end_handler_established := TRUE;
      IFEND;

      IF element_name <> last_element_name THEN
        element := NIL;
        cmp$pc_get_element (element_name, {not used} iou_name, element, status);
        IF NOT status.normal THEN
          iop$set_status_abnormal (ioe$unable_to_build_io_request,
               'Subsystem io not defined for element - IOMSSIOR236', status);
          EXIT /process_request/;
        IFEND;
        IF element <> NIL THEN
          last_element_name := element_name;
          product_identification := element^.product_id;

          cmp$get_unit_type (product_identification, cm_unit_type, io_unit_type,
                   unit_class, element_found);
        ELSE
          iop$set_status_abnormal (ioe$unable_to_build_io_request,
             'Subsystem io not defined for element - IOMSSIOR236', status);
          EXIT /process_request/;
        IFEND;
      IFEND;

      IF (NOT element_found) AND (io_unit_type <> ioc$dt_foreign_device)
         AND (unit_class <> cmc$network_unit) THEN
        iop$set_status_abnormal (ioe$unable_to_build_io_request,
             'Subsystem io not defined for element - IOMSSIOR236', status);
        EXIT /process_request/;
      IFEND;

      IF (unit_class <> cmc$map_unit) AND (io_unit_type <> ioc$dt_foreign_device)
         AND (unit_class <> cmc$network_unit) THEN

        iop$set_status_abnormal (ioe$unable_to_build_io_request,
             'Subsystem io not defined for element - IOMSSIOR236', status);
        EXIT /process_request/;
      IFEND;

      cmp$ssiot_recovery_condition (status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      request_id.system_supplied := 0;
      request_id.user_supplied := 0;

      PUSH ssiot_entry_information_p: [1 .. 1];

      PUSH segment_attributes_p: [1 .. 2];
      segment_attributes_p^ [1].keyword := mmc$kw_hardware_attributes;
      segment_attributes_p^ [2].keyword := mmc$kw_software_attributes;

      CASE request_type OF
      = cmc$pp_io, cmc$unit_io =
      ELSE
        iop$set_status_abnormal (ioe$unable_to_build_io_request,
           'Unsupported io request type - IOMSSIOR236', status);
        EXIT /process_request/;
      CASEND;

      IF io_response_p = NIL THEN
        iop$set_status_abnormal (ioe$unable_to_build_io_request,
          'Subsystem response not specified - IOMSSIOR236', status);
        EXIT /process_request/;
      IFEND;





      IF command_table_p = NIL THEN
         iop$set_status_abnormal (ioe$unable_to_build_io_request,
                 'IO command table not specified - IOMSSIOR236', status);
         EXIT /process_request/;
      IFEND;

      number_of_commands := UPPERBOUND (command_table_p^);
      sequence_of_commands_allowed := TRUE;
      command_sequence := FALSE;
      unit_command_sequence := TRUE;


      cmp$get_ssiot_entry_avail_queue (job_completion_queue_index);
      IF job_completion_queue_index = 0 THEN
        iop$set_status_abnormal (ioe$unable_to_build_io_request,
          'Unable to get job completion queue entry - IOMSSIOR236', status);
        EXIT /process_request/;
      IFEND;

      request_id.system_supplied := job_completion_queue_index;
      request_id.user_supplied := io_identification;

      cmp$build_wired_queue_request (element_name, request_type, command_table_p,
               data_command_descriptors_p,
               request_id, io_response_p, status);
      IF NOT status.normal THEN
        ssiot_entry_information_p^ [1].keyword := cmc$ssiote_io_status;
        ssiot_entry_information_p^ [1].io_status := cmc$subsystem_io_not_active;
        cmp$store_ssiot_entry_info (job_completion_queue_index, ssiot_entry_information_p,
                                    ignore_status);
        cmp$add_ssiot_entry_avail_queue (job_completion_queue_index);

        request_id.system_supplied := 0;
        request_id.user_supplied := 0;
        EXIT /process_request/;
      IFEND;


      ssiot_entry_information_p^ [1].keyword := cmc$ssiote_request_id;
      ssiot_entry_information_p^ [1].request_id := request_id;
      ssiot_entry_information_p^ [1].subsystem_response_p := io_response_p;
      ssiot_entry_information_p^ [1].data_command_descriptors_p :=
                         data_command_descriptors_p;
      cmp$store_ssiot_entry_info (job_completion_queue_index, ssiot_entry_information_p,
                                  ignore_status);

    END /process_request/;


  PROCEND cmp$create_io_request;

?? TITLE := '  [XDCL,#GATE] cmp$destroy_io_completion_table', EJECT ??

*copyc cmh$destroy_io_completion_table

  PROCEDURE [XDCL, #GATE] cmp$destroy_io_completion_table (VAR status: ost$status);


    status.normal := TRUE;

/process_request/ BEGIN

    cmp$ssiot_recovery_condition (status);
    IF status.normal THEN
      cmp$destroy_io_completion_tb_r2 (status);
      IF status.normal THEN
        IF task_end_handler_established THEN
          pmp$disestablish_end_handler (^cmp$subsystem_io_end_handler, status);
          task_end_handler_established := FALSE;
        IFEND;
      IFEND;
    IFEND;

END /process_request/;


  PROCEND cmp$destroy_io_completion_table;
?? TITLE := '  [XDCL, #GATE] cmp$destroy_io_request', EJECT ??

*copyc cmh$destroy_io_request

  PROCEDURE [XDCL, #GATE] cmp$destroy_io_request (VAR request_id: cmt$subsystem_io_request_id;
    VAR status: ost$status);

    VAR
      actual_pp_memory_size: cmt$pp_memory_length,
      logical_pp_number: iot$pp_number,
      physical_pp: dst$iou_resource,
      pp_registers: cmt$pp_registers,
      time_format: ost$time_formats,
      time: ost$time,
      user_id: string(8),
      user_id_length: integer,
      request_created_p: ^pmt$log_msg_text,
      request_queued_p: ^pmt$log_msg_text,
      request_entered_mtr_p: ^pmt$log_msg_text,
      request_queued_by_mtr_p: ^pmt$log_msg_text,
      request_destroyed_p: ^pmt$log_msg_text,
      response_seen_by_mtr_p: ^pmt$log_msg_text,
      response_sent_to_job_by_mtr_p: ^pmt$log_msg_text,
      response_received_p: ^pmt$log_msg_text,
      response_returned_p: ^pmt$log_msg_text,
      io_completion_queue_index: cmt$io_completion_queue_index,
      io_completion_table_entry_p: ^cmt$io_completion_table_entry;



  /process_request/
    BEGIN

      status.normal := TRUE;

      user_id := ' ';

      cmp$ssiot_recovery_condition (status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      io_completion_queue_index := request_id.system_supplied;
      cmp$get_io_completion_tbl_entry (io_completion_queue_index, io_completion_table_entry_p);

      IF io_completion_table_entry_p^.available THEN
        request_id.system_supplied := 0;
        EXIT /process_request/;
      IFEND;

      IF io_completion_table_entry_p^.request_identification <> request_id THEN
        iop$set_status_abnormal (ioe$unable_to_destroy_io_req, 'Request id mismatch - IOMSSIOR236', status);
        EXIT /process_request/;
      IFEND;


      IF io_completion_table_entry_p^.io_status <> cmc$subsystem_io_complete THEN

        cmp$get_logical_pp_number (io_completion_table_entry_p^.io_request_type.element_name,
                 logical_pp_number, status);
        IF NOT status.normal THEN
          EXIT /process_request/;
        IFEND;

 { Hardware idle the PP first.

        IF cmv$logical_pp_table_p^ [logical_pp_number].flags.pp_loaded THEN
          physical_pp := cmv$logical_pp_table_p^ [logical_pp_number].pp_info.physical_pp;
          cmp$hardware_idle_pp (physical_pp, FALSE, FALSE, NIL, actual_pp_memory_size,
              pp_registers, status);
          IF NOT status.normal THEN
            EXIT /process_request/;
          IFEND;
        IFEND;
      IFEND;

        cmp$add_ssiot_entry_avail_queue (request_id.system_supplied);

        request_id.system_supplied := 0;


    END /process_request/;


  PROCEND cmp$destroy_io_request;
?? TITLE := '  [XDCL, #GATE] cmp$get_subsys_equipment_desc', EJECT ??

*copyc cmh$get_subsys_equipment_desc

      PROCEDURE [XDCL, #GATE] cmp$get_subsys_equipment_desc (
                        pp_number: iot$pp_number;
                        logical_unit: iot$logical_unit;
                    VAR equipment_description: cmt$subsystem_equip_description;
                    VAR status: ost$status);

      status.normal := TRUE;

      cmp$get_subsys_equip_desc_r1 (pp_number, logical_unit, equipment_description, status);

PROCEND cmp$get_subsys_equipment_desc;
?? TITLE := '  [XDCL, #GATE] cmp$initiated_job_status',  EJECT ??

*copyc cmh$initiated_job_status

  PROCEDURE [XDCL, #GATE] cmp$initiated_job_status (job_name: jmt$name;
                       VAR job_executing: boolean);

    VAR
      job_exists: boolean,
      job_state_set: jmt$job_state_set,
      local_status: ost$status,
      name: ost$name;

    local_status.normal := TRUE;
    job_executing := FALSE;

    job_state_set := $jmt$job_state_set [jmc$initiated_job,
          jmc$terminating_job];
    IF job_name.kind = jmc$system_supplied_name THEN
      name := job_name.system_supplied_name;
    ELSE
      name := job_name.user_supplied_name;
    IFEND;

    jmp$job_exists (name, job_state_set, job_exists, local_status);
    job_executing := job_exists  AND local_status.normal;
  PROCEND cmp$initiated_job_status;
?? TITLE := '  [XDCL, #GATE] cmp$queue_io_request', EJECT ??

*copyc cmh$queue_io_request

 PROCEDURE [XDCL, #GATE] cmp$queue_io_request (VAR request_id: cmt$subsystem_io_request_id;
                                          queue_control: cmt$unit_queuing_options;
                                          recovery_options: iot$request_recovery;
                                          wait_for_io_completion: cmt$wait_for_io_completion;
                                      VAR status: ost$status);

    VAR
      user_io_status: integer,
      caller_io_response_p: ^cmt$os_subsystem_io_response,
      wired_pp_response_p: ^cmt$collected_pp_response,
      ssiot_entry_information_p: ^cmt$ssiot_entry_information,
      ssiot_entry_timing_info_p: ^cmt$ssiot_entry_information,
      job_completion_queue_index: cmt$io_completion_queue_index,
      job_recovery_handler_in_effect: boolean,
      io_completion_table_entry_p: ^cmt$io_completion_table_entry,
      terminal_condition_descriptor_p: ^pmt$established_handler,
      io_response_available: boolean,
      io_request: cmt$io_request,
      try_count: integer,
      starting_wait_time: ost$free_running_clock,
      requested_wait_time: ost$free_running_clock,
      elapsed_wait_time: ost$free_running_clock,
      time_format: ost$time_formats,
      time: ost$time,
      ignore_status: ost$status;


      PROCEDURE cmp$job_recovery_handler (job_recovery_condition: pmt$condition;
                         condition_descriptor_p: ^pmt$condition_information;
                         save_area_p: ^ost$stack_frame_save_area;
                     VAR status: ost$status);

        status.normal := TRUE;

        pmp$continue_to_cause (pmc$execute_standard_procedure, status);

      PROCEND cmp$job_recovery_handler;

      PROCEDURE cmp$interactive_handler (interactive_condition: pmt$condition;
                         condition_descriptor_p: ^pmt$condition_information;
                         save_area_p: ^ost$stack_frame_save_area;
                     VAR status: ost$status);

        status.normal := TRUE;

        pmp$continue_to_cause (pmc$execute_standard_procedure, status);

      PROCEND cmp$interactive_handler;


/process_request/
  BEGIN

      status.normal := TRUE;


      PUSH terminal_condition_descriptor_p;

      cmp$ssiot_recovery_condition (status);
      IF NOT status.normal THEN
        EXIT /process_request/;
      IFEND;

      job_completion_queue_index := request_id.system_supplied;
      PUSH ssiot_entry_information_p: [1 .. 2];

      cmp$get_io_completion_tbl_entry (job_completion_queue_index, io_completion_table_entry_p);

      IF io_completion_table_entry_p^.request_identification <> request_id THEN
        iop$set_status_abnormal (ioe$unable_to_queue_io_request, 'Request id mismatch - IOMSSIOR236', status);
        EXIT /process_request/;
      IFEND;



      wired_pp_response_p := io_completion_table_entry_p^.wired_unit_queue_request_p^.wired_pp_response_p;
      caller_io_response_p := io_completion_table_entry_p^.subsystem_response_p;
      io_request := io_completion_table_entry_p^.io_request_type;


      ssiot_entry_information_p^ [1].keyword := cmc$ssiote_io_status;
      ssiot_entry_information_p^ [1].io_status := cmc$subsystem_io_started;
      ssiot_entry_information_p^ [2].keyword := cmc$ssiote_wait_for_io_complete;
      ssiot_entry_information_p^ [2].wait_for_io_completion := wait_for_io_completion;

      cmp$store_ssiot_entry_info (job_completion_queue_index, ssiot_entry_information_p,
                                  ignore_status);

      job_recovery_handler_in_effect := FALSE;

      cmp$queue_request_r1 (request_id, queue_control, recovery_options,
                            wait_for_io_completion.wait_for_io_completion, status);

      IF job_recovery_handler_in_effect THEN
        pmp$disestablish_cond_handler (job_recovery_condition, ignore_status);
      IFEND;

      IF NOT status.normal THEN
        ssiot_entry_information_p^ [1].io_status := cmc$subsystem_io_not_active;
        ssiot_entry_information_p^ [2].keyword := cmc$ssiote_null_entry;

        cmp$store_ssiot_entry_info (job_completion_queue_index, ssiot_entry_information_p,
                            ignore_status);
        EXIT /process_request/;
      IFEND;

      starting_wait_time := #free_running_clock (0); {us}


      IF wait_for_io_completion.wait_for_io_completion THEN
         pmp$establish_condition_handler (interactive_terminate_condition,
            ^cmp$interactive_handler, terminal_condition_descriptor_p, status);
         IF NOT status.normal THEN
             EXIT /process_request/;
         IFEND;

         requested_wait_time := wait_for_io_completion.requested_wait_time;
         elapsed_wait_time := 0;
         try_count := 0;

         /wait_for_response/
         REPEAT
           io_response_available := (wired_pp_response_p^.response_status = cmc$subsys_io_resp_completed);
           IF io_response_available THEN
             EXIT /wait_for_response/;
           IFEND;
           IF elapsed_wait_time >= requested_wait_time THEN
              EXIT /wait_for_response/;
           IFEND;
           pmp$wait (5000, 5000);
           elapsed_wait_time := elapsed_wait_time + 5000;
            cmp$check_io_status (request_id, status);
              IF NOT status.normal THEN
                IF status.condition = cme$pc_not_logically_conf THEN
                   cmp$down_foreign_io (request_id, status);
                IFEND;
                 EXIT /wait_for_response/;
              IFEND;

         UNTIL io_response_available;


         IF io_response_available THEN
           iop$mfh_subsystem_io_completion (ioc$subsystem_io_completed);
         IFEND;

         pmp$disestablish_cond_handler (interactive_terminate_condition, ignore_status);

         osp$fetch_locked_variable (caller_io_response_p^.io_status, user_io_status);

         IF user_io_status = ORD (cmc$subsys_io_resp_available) THEN
            request_id.system_supplied := 0;
         IFEND;

      IFEND;
    END /process_request/;


  PROCEND cmp$queue_io_request;
?? TITLE := '  cmp$subsystem_io_end_handler', EJECT ??

     PROCEDURE cmp$subsystem_io_end_handler (termination_status: ost$status;
                            VAR status: ost$status);

     status.normal := TRUE;

     cmp$ssiot_end_handler (termination_status, status);

PROCEND cmp$subsystem_io_end_handler;
?? TITLE := '  [XDCL] iop$mfh_subsystem_io_completion', EJECT ??

*copyc ioh$mfh_subsystem_io_completion

  PROCEDURE [XDCL] iop$mfh_subsystem_io_completion (flag_id: ost$system_flag);

    VAR
      last_in6: iot$response_buffer_offset,
      last_out6: iot$response_buffer_offset,
      last_in7: iot$response_buffer_offset,
      last_out7: iot$response_buffer_offset,
      active_task_count: integer,
      destroy_io_request: boolean,
      found: boolean,
      id_index: integer,
      wait_for_io_completion: boolean,
      ssiot_entry_information_p: ^cmt$ssiot_entry_information,
      ssiot_entry_timing_info_p: ^cmt$ssiot_entry_information,
      wired_unit_queue_request_p: ^cmt$wired_unit_queue_request,
      wired_pp_response_p: ^cmt$collected_pp_response,
      scan_index: integer,
      subsystem_response_p: ^cmt$os_subsystem_io_response,
      job_completion_queue_index: cmt$io_completion_queue_index,
      new_io_status: cmt$subsys_io_response_status,
      pp_response_p: ^cmt$os_subsystem_response,
      global_task_id: ost$global_task_id,
      local_status: ost$status,
      temp_gtid: ost$global_task_id,
      job_recovery_handler_in_effect: boolean,
      lock_status: ost$status,
      response_to_be_processed: boolean,
      io_response_complete_area_p: ^cmt$subsys_io_response_area,
      response_complete_flag: char,
      clear_complete_flag : char,
      cause_user_condition_for_io: boolean,
      stop: cell,
      kill: ^cell,
      request_id: cmt$subsystem_io_request_id,
      new_subsystem_io_status_set: boolean,
      io_completion_table_entry_p: ^cmt$io_completion_table_entry,
      current_task_id: ost$global_task_id,
      task_list: array [0 .. 255] of ost$global_task_id,
      time_format: ost$time_formats,
      time: ost$time,
      try_count: integer,
      xcb: ^ost$execution_control_block,

      status: ost$status;


      VAR
        job_xcb_list: [XREF, oss$job_fixed] record
         head: ^ost$execution_control_block,
         lock: ost$signature_lock,
         recend;





  /process_request/
    BEGIN
      new_io_status := cmc$subsys_io_resp_available;

      PUSH ssiot_entry_information_p: [1 .. 1];
      ssiot_entry_information_p^ [1].keyword := cmc$ssiote_io_status;

      pmp$get_executing_task_gtid_r6 (global_task_id);

      cause_user_condition_for_io := FALSE;

            active_task_count := 0;
            xcb := job_xcb_list.head;
            WHILE (xcb <> NIL) AND (active_task_count < 255) DO
              task_list [active_task_count] := xcb^.global_task_id;
              active_task_count := active_task_count + 1;
              xcb := xcb^.link;
            WHILEND;


    /move_response/
      REPEAT
{    cmp$set_ioct_serial_lock (lock_status);
{     IF NOT lock_status.normal THEN
{       RETURN;
{     IFEND;

        #scan (cmv$subsys_io_scan_variable, cmv$subsys_io_responses_p^,
               scan_index, response_to_be_processed);

        IF response_to_be_processed THEN
          job_completion_queue_index := scan_index;

          cmp$get_io_completion_tbl_entry (job_completion_queue_index, io_completion_table_entry_p);

{  Check the global task id to ensure that the table entry is associated with this task.
{  If it is not, do not move the wired response, skip it and continue scanning.

          IF io_completion_table_entry_p^.global_task_id <> global_task_id  THEN

{   Make sure that this task is still active in the system. If not, get rid
{   of the response.
            IF io_completion_table_entry_p^.available THEN
{   This entry is no longer in use.

              iop$clear_response_ptr (scan_index, status);
               IF NOT status.normal THEN
                 RETURN;
               IFEND;

{           cmv$subsys_io_responses_p^ (scan_index,1) := 'N';
            cmp$update_error_count (local_status);

           IF cmv$free_trap THEN
{            stop := kill^;
           IFEND;

{           cmp$clear_ioct_serial_lock (lock_status);
            CYCLE /move_response/;
            IFEND;
            temp_gtid := io_completion_table_entry_p^.global_task_id;

            current_task_id := io_completion_table_entry_p^.global_task_id;
            found := false;
              FOR id_index := 0 TO active_task_count DO
                 IF temp_gtid = task_list [id_index] THEN
                         found := true;
                IFEND;
              FOREND;

            IF NOT found THEN

{  Either the task no longer lives or the
{  Completion table entry has been released by another asychronous task.  In
{  either case, ignore the response residue and continue.

              iop$clear_response_ptr (scan_index, status);
               IF NOT status.normal THEN
                 RETURN;
               IFEND;

{             cmv$subsys_io_responses_p^ (scan_index,1) := 'N';
              cmp$update_error_count (local_status);
            IFEND;
 {            cmp$clear_ioct_serial_lock (lock_status);
              pmp$long_term_wait (0,0);
              CYCLE /move_response/;
           IFEND;



          wired_unit_queue_request_p := io_completion_table_entry_p^.wired_unit_queue_request_p;
          wired_pp_response_p := wired_unit_queue_request_p^.wired_pp_response_p;

          ssiot_entry_information_p^ [1].io_status := cmc$subsystem_io_completing;
          cmp$store_ssiot_entry_info (job_completion_queue_index, ssiot_entry_information_p, status);

          request_id := io_completion_table_entry_p^.request_identification;
          wait_for_io_completion := io_completion_table_entry_p^.io_request_type.
                                    wait_for_io_completion.wait_for_io_completion;

          IF wait_for_io_completion THEN
              destroy_io_request := TRUE;
          ELSE
              destroy_io_request := io_completion_table_entry_p^.io_request_type.
                                    wait_for_io_completion.destroy_io_req_upon_completion;
          IFEND;

          io_response_complete_area_p := io_completion_table_entry_p^.io_request_type.
                                         wait_for_io_completion.io_complete_response_p;
          response_complete_flag := io_completion_table_entry_p^.io_request_type.
                                    wait_for_io_completion.io_complete_flag;
          {
          { Move wired response to subsystem response area.
          {
          subsystem_response_p := io_completion_table_entry_p^.subsystem_response_p;
          pp_response_p := ^subsystem_response_p^.pp_response;
          pp_response_p^.pp_number := wired_pp_response_p^.pp_number;
          pp_response_p^.pp_response := wired_pp_response_p^.pp_response;
          subsystem_response_p^.detailed_status := wired_pp_response_p^.detailed_status;

          iop$return_wired_request (job_completion_queue_index, status);

          IF NOT wait_for_io_completion THEN
             cause_user_condition_for_io := TRUE;
          IFEND;

          ssiot_entry_information_p^ [1].io_status := cmc$subsystem_io_complete;
          cmp$store_ssiot_entry_info (job_completion_queue_index, ssiot_entry_information_p, status);

          cmp$set_subsystem_io_status (^subsystem_response_p^.io_status, new_io_status,
                new_subsystem_io_status_set);
          IF new_subsystem_io_status_set THEN
            IF (io_response_complete_area_p <> NIL) THEN
               io_response_complete_area_p^ ((request_id.user_supplied MOD
                       (STRLENGTH (io_response_complete_area_p^)+1)), 1) := response_complete_flag;
            IFEND;


            IF destroy_io_request THEN
               cmp$destroy_io_request (request_id, status);
            IFEND;
          IFEND;

        IFEND;
{     cmp$clear_ioct_serial_lock (lock_status);

      UNTIL NOT response_to_be_processed;


      IF cause_user_condition_for_io THEN
         pmp$cause_task_condition ('SUBSYSTEM_IO_COMPLETION        ', NIL,
                                FALSE, FALSE, FALSE, FALSE, status);
      IFEND;

    END /process_request/;

{   cmp$test_and_clear_ioct_lock (status);


  PROCEND iop$mfh_subsystem_io_completion;
?? TITLE := '  [XDCL] cmp$set_subsystem_io_status', EJECT ??

*copyc ioh$set_subsystem_io_status

  PROCEDURE [XDCL] cmp$set_subsystem_io_status (
        io_status_p: ^cmt$subsystem_io_comp_status;
        new_subsystem_io_status: cmt$subsys_io_response_status;
    VAR new_subsystem_io_status_set: boolean);

    VAR
      last_io_status: ost$compare_swap_lock,
      current_io_status: ost$compare_swap_lock;

    new_subsystem_io_status_set := FALSE;

    osp$fetch_locked_variable (io_status_p^, current_io_status);

    REPEAT
      last_io_status := current_io_status;
      osp$set_locked_variable (io_status_p^, last_io_status, ORD (new_subsystem_io_status),
                               current_io_status, new_subsystem_io_status_set);
    UNTIL new_subsystem_io_status_set;

  PROCEND cmp$set_subsystem_io_status;

?? OLDTITLE ??

PROCEDURE [XDCL, #GATE] cmp$ssiot_termination_cleanup ( VAR status: ost$status);

  VAR
    killer: cell,
    stop_it: ^cell;

   status.normal := TRUE;
   cmp$ssiot_termination (status);

PROCEND cmp$ssiot_termination_cleanup;

MODEND iom$subsystem_io_r236;
*DECK DECK=IOM$SWEEP_DISK_UNITS EXPAND=TRUE
MODULE iom$sweep_disk_units;
?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc cmp$get_mass_storage_info
*copyc ioe$st_errors
*copyc iop$mass_storage_io
*copyc jmp$system_job
*copyc dmt$active_volume_table_index
*copyc dmv$active_volume_table
*copyc dmp$open_dat
*copyc dmp$close_file
*copyc pmp$wait
*copyc osp$generate_message
*copyc pmt$program_parameters
*copyc cmv$logical_unit_table
*copyc pmp$delay
?? POP ??
{ Purpose:
{  The purpose of this module is to perform read i/o on
{  disks of a particular type on a periodic basis
{  to extend the HDA life.  The i/o must cause the heads
{  to position across the entire disk surface.
{  The product which require this are: 885, 834, 836.
{ Design:
{  The configuration is scanned every X seconds to find all disks
{  that require sweeping.  Every Y seconds each of those disk has
{  a read operation performed on a different address so that if
{  the disk were idle during this time the head would repeatedly
{  sweep across the disk surface.
{ Notes:
{  885 disks have a special requirement that they only be read from
{  areas that have been written by NOS/VE.  To do this, the device
{  management file tables are used.  This implies that the sweeping
{  of 885 disks depends upon the distribution of permanent files on
{  a given 885 disk.
?? EJECT ??

  TYPE
    iot$sweep_info = record
      valid: boolean,
      lda: dmt$ms_logical_device_address,
      last_maui: integer,
      maus: array [1 .. (dmc$max_device_position DIV cylinders_per_sweep) +
            2] of integer,
    recend;

  CONST
    cylinders_per_sweep = 12;

  PROCEDURE [XDCL, #GATE] iop$sweep_disk_units
    (    p: pmt$program_parameters;
     VAR status: ost$status);

    VAR
      rpt,
      stl,
      io,
      maua,
      count,
      daua,
      maui,
      i,
      next_daua: integer,
      st: string (100),
      msi: cmt$mass_storage_information,
      avti: dmt$active_volume_table_index,
      sweep_info: ^array [ * ] of iot$sweep_info,
      cs: ^iot$completion_status,
      p_data: ^integer,
      ignore: ost$status,
      p_dat: ^dmt$ms_device_allocation_table;

    IF NOT jmp$system_job () THEN
      RETURN;
    IFEND;

{ Setup control parameters

    PUSH sweep_info: [LOWERBOUND (dmv$p_active_volume_table^
          ) .. UPPERBOUND (dmv$p_active_volume_table^)];
    PUSH cs;
    PUSH p_data;

  /forever/
    WHILE TRUE DO

      {Scan the active configuration

      count := 0;

    /initialize/
      FOR avti := LOWERBOUND (dmv$p_active_volume_table^)
            TO UPPERBOUND (dmv$p_active_volume_table^) DO
        sweep_info^ [avti].valid := FALSE;
        IF NOT dmv$p_active_volume_table^ [avti].entry_available THEN
            cmp$get_mass_storage_info (dmv$p_active_volume_table^ [avti].
                  logical_unit_number, msi, status);
            IF NOT status.normal THEN
    { Ignore the status, since the given logical unit could belong
    { to some devices that does not support CIP. In this case, an abnormal
    { status will be returned from cmp$get_mass_storage_info
              CYCLE /initialize/;
            IFEND;
            CASE msi.unit_type OF
            = cmc$ms885_1x, cmc$ms885_4x, cmc$ms834_2,
                  cmc$msfsd_2 =

              {Disk requires sweeping - build data structures to drive sweep

              dmp$open_dat (dmv$p_active_volume_table^ [avti].mass_storage.
                    p_device_allocation_table, 1, 3, mmc$sar_read,
                    mmc$as_sequential, p_dat, status);
              IF NOT status.normal THEN
                osp$generate_message (status, status);
                CYCLE /initialize/;
              IFEND;
              sweep_info^ [avti].lda.allocation_unit_mau_address := 0;
              sweep_info^ [avti].lda.maus_per_position :=
                    p_dat^.header.maus_per_dau * p_dat^.header.
                    daus_per_position;
              sweep_info^ [avti].lda.logical_unit_number :=
                    dmv$p_active_volume_table^ [avti].logical_unit_number;
              sweep_info^ [avti].lda.transfer_length :=
                    p_dat^.header.maus_per_dau;
              sweep_info^ [avti].lda.transfer_mau_offset := 0;
              sweep_info^ [avti].lda.write_translation := FALSE;
              sweep_info^ [avti].last_maui := 0;

              {Determine mau addresses to read.  Special case 885.

              daua := 0;
              maui := 1;
              next_daua := 0;
              WHILE next_daua >= 0 DO
                CASE msi.unit_type OF
                = cmc$ms885_1x, cmc$ms885_4x =
                  find_dau (p_dat, daua, next_daua);
                ELSE
                  {OK to read anywhere - every cylinders_per_sweep cylinders
                  IF daua < p_dat^.header.positions_per_device *
                        p_dat^.header.daus_per_position THEN
                    next_daua := daua;
                  ELSE
                    next_daua := -1;
                  IFEND;
                CASEND;
                sweep_info^ [avti].maus [maui] :=
                      next_daua * p_dat^.header.maus_per_dau;
                daua := next_daua + cylinders_per_sweep *
                      p_dat^.header.daus_per_position;
                maui := maui + 1;
              WHILEND;
              dmp$close_file (p_dat, status);
            ELSE
              CYCLE /initialize/;
            CASEND;
            sweep_info^ [avti].valid := TRUE;
            count := count + 1;
        IFEND;
      FOREND /initialize/;

      IF count = 0 THEN
        {If there are no disks to sweep
        pmp$wait (3600000, 3600000);
        CYCLE /forever/;
      IFEND;

      {Do X reads, then resynchronize.

      FOR io := 1 TO 12 DO

        {Do all volumes

        FOR avti := LOWERBOUND (sweep_info^) TO UPPERBOUND (sweep_info^) DO
          IF sweep_info^ [avti].valid THEN

            {Check for unit activity - avoid if busy

            FOR rpt := 1 TO 3 DO

            IF cmv$logical_unit_table^ [sweep_info^ [avti].lda.
                  logical_unit_number].unit_interface_table^.next_request =
                  NIL THEN

              {Go to next disk address, or start list over.

              sweep_info^ [avti].last_maui := sweep_info^ [avti].last_maui + 1;
              maua := sweep_info^ [avti].maus [sweep_info^ [avti].last_maui];
              IF maua < 0 THEN
                {Reset to first address
                sweep_info^ [avti].last_maui := 1;
                maua := sweep_info^ [avti].maus [sweep_info^ [avti].last_maui];
              IFEND;
              IF maua >= 0 THEN
                sweep_info^ [avti].lda.allocation_unit_mau_address := maua;
                REPEAT
                  {Read a token amount.  p_data^ must be in memory or the
                  { request
                  {will fail - hence the loop.
                  p_data^ := 0;
                  status.condition := 0;
                  iop$mass_storage_io (p_data, 8, ioc$read_mass_storage,
                        sweep_info^ [avti].lda, TRUE, cs, status);
                  IF (NOT status.normal) THEN
                    IF status.condition = ioe$unrecovered_disk_error THEN

                      {Move to next dau (transfer_length is maus_per_dau)

                      sweep_info^ [avti].maus [sweep_info^ [avti].last_maui] :=
                            sweep_info^ [avti].maus [sweep_info^ [avti].
                            last_maui] + sweep_info^ [avti].lda.transfer_length;
                      status.normal := TRUE;
                    ELSEIF status.condition = ioe$unit_disabled THEN
                      {Skip unit this pass
                      status.normal := TRUE;
                    ELSE
                      pmp$delay (100, ignore);
                    IFEND;
                  IFEND;
                UNTIL status.normal;
              IFEND;
            IFEND;
            {Use magic number
            pmp$wait (17, 17);
            FOREND;
          IFEND;
        FOREND;

        {Wait between each read

        {10 minutes
        pmp$wait (600000, 600000);
      FOREND;

    WHILEND /forever/;

  PROCEND iop$sweep_disk_units;
?? EJECT ??

  PROCEDURE [INLINE] find_dau
    (    p_dat: ^dmt$ms_device_allocation_table;
         start_dau: integer;
     VAR next_dau: integer);

{ Purpose:
{  The purpose of the procedure is to find the next dau address that is
{  both assigned to file and initialized.
{ Design:
{  This is required on 885 disks
{  due to the fact that they can have a combination of small and large
{  sectors written on them.  NOS/VE must never read a small sector.

    VAR
      daua: integer;

    daua := start_dau;
    next_dau := -1;
    WHILE daua < UPPERBOUND (p_dat^.body) DO
      IF p_dat^.body [daua].dau_status = dmc$dau_assigned_to_file THEN
        IF p_dat^.body [daua].data_status = dmc$dau_data_initialized THEN
          next_dau := daua;
          RETURN;
        IFEND;
      IFEND;
      daua := daua + 1;
    WHILEND;
  PROCEND find_dau;
MODEND iom$sweep_disk_units
*DECK DECK=IOM$TAPC EXPAND=TRUE
          IDENT  TAPC
          CIPPU
          MEMSEL 16
          TITLE  IOM$TAPC - 5698-1X IPI TAPE DRIVER FOR I0.
          COMMENT  *SMD* LVL=02
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4
*         THIS IS THE PP DRIVER FOR THE IPI CHANNEL THAT SUPPORTS THE
*         5698-1X IPI TAPE SLAVE WITH 698-3X TAPE FACILITIES ON THE
*         CYBER 180-930 SYSTEM. THE PROGRAM NAME IS E5P5698 AND THE DECK
*         NAME IS IOM$TAPC.
*
*         WHEN THE PP DRIVER IS LOADED THE FOLLOWING LOCATIONS ARE REQUIRED.
*         72 AND 73 MUST CONTAIN THE RMA OF THE PP INTERFACE TABLE (PIT).
*         0 MUST CONTAIN THE ADDRESS-1 AT WHICH EXECUTION BEGINS.
          SPACE  4
*         IODMAC4 HAS BEEN MODIFIED FOR USE WITH CYBER 180-930 SYSTEMS.
*         THE NEW R-REGISTER INSTRUCTION AND THE NEW HOLD (WAIT)
*         INSTRUCTION ARE BEING USED.
          TITLE  IODMAC1 MACROS
*COPYC IODMAC1
          TITLE  IODMAC2 MACROS
*COPYC IODMAC2
          TITLE  IODMAC3 MACROS
*COPYC IODMAC3
          TITLE  MODIFIED IODMAC4 MACROS
*BEGIN IODMAC4
          SPACE  5,20
*
** NAME-- LMK,LPK,LDK,ADK,ZJK,NJK,PJK,MJK,UJK
*
** PURPOSE-- DETERMINE FOR THOSE INSTRUCTIONS HAVING A SHORT AND LONG
*            FORM WHICH INSTRUCTION FORM NEEDS TO BE GENERATED.
*
** CALLING SEQUENCE-- SAME AS THE REGULAR PP INSTRUCTION
*
** RESTRICTIONS-- SYMBOLS REFERENCED BY THESE MACROS SHOULD BE
*                 DEFINED PRIOR TO THE MACRO CALL.
*
* NO-ADDRESS AND CONSTANT INSTRUCTIONS
NEWOP     ECHO   ,I=(LM,LP,LD,AD)
*
I_K       MACRO  P1
L         IF     DEF,P1
L         IFLE   P1,77B
L         IFGE   P1,0
          I_N    P1
L         ELSE   1
          I_C    P1
          ENDM
NEWOP     ENDD
*
*
*
* JUMP INSTRUCTIONS
NEWOP     ECHO   ,I=(ZJ,NJ,PJ,MJ),J=(NJ,ZJ,MJ,PJ)
*
I_K       MACRO  P1
L         IF     DEF,P1
L         IFGE   *-P1,0
L         IFLT   *-P1,40B
          I_N    P1
L         ELSE   2
          J_N    *+3
          LJM    P1
          ENDM
NEWOP     ENDD
*
*
*
UJK       MACRO  P1
L         IF     DEF,P1
L         IFGE   *-P1,0
L         IFLT   *-P1,40B
          UJN    P1
L         ELSE   1
          LJM    P1
          ENDM
          SPACE  5,20
** NAME-- AJM,SCF,IJM,CCF,FJM,SFM,EJM,CFM,IAN,IAM,OAN,OAM,ACN,DCN
*         FAN,FNC,FSJM,FCJM,IAPM,OAPM,CMCH,CHCM,MCLR
*
** PURPOSE-- REDEFINE I/O INSTRUCTIONS SO THAT THE ADDRESS OF CHANNEL
*            INSTRUCTIONS CAN BE SAVED IN A TABLE.
NEWOP     ECHO   ,OP=(AJM,SCF,IJM,DCN,FJM,SFM,EJM,CFM,IAN,IAM,OAN,OAM,AC
,N,FAN,FNC,FSJM,FCJM,IAPM,OAPM,CCF,CMCH,CHCM,MCLR)
*
 OP_.     OPSYN  OP          E.G.  IAN. = IAN
*
          PURGMAC OP
OP        MACRO  P1,P2
          LOCAL  TAG
L         IFC    EQ,$P2$$
TAG       OP_.   P1
T_P1      RMT                IAN,OAN,ACN,DCN,FAN
          CON    TAG
          RMT
L         ELSE
TAG       OP_.   P1,P2
T_P2      RMT                AJM,IJM,FJM,EJM,IAM,OAM,FCN,IAPM,OAPM,
*                            SCF,CCF,SFM,CFM,FSJM,FCJM,CHCM,CMCH,MCLR
          CON    TAG
          RMT
L         ENDIF
OP        ENDM
NEWOP     ENDD
          SPACE  5,20
** NAME-- LOADC      ** MODIFIED **
*
** PURPOSE-- LOAD A CM ADDRESS INTO THE R AND A REGISTERS.
*
** CALLING SEQUENCE-- LOADC   CMR,CMA
*     CMR = ADDRESS OF THE WORD(S) TO BE LOADED INTO THE R REGISTER.
*           (IF CMA IS ABSENT, THEN THE FIRST WORD FOLLOWING CMR THAT WAS
*           NOT LOADED INTO THE R REGISTER IS LOADED INTO THE A REGISTER.
*     CMA = ADDRESS OF THE CONTENTS TO BE LOADED INTO THE A REGISTER.
*     CMA IS OPTIONAL.

 LOADC    MACRO  CMR,CMA
 L        IFLE   CMR,76B
 L        IFGE   CMR,0
          LRDL   CMR
          LDDL   CMR+1
 L        ELSE
          LRML   CMR
          LDML   CMR+1
 L        ENDIF
*
 P        IFC    NE,$CMA$$
 M        IFLE   CMA,76B
 M        IFGE   CMA,0
          ADDL   CMA
 M        ELSE
          ADML   CMA
 M        ENDIF
 P        ENDIF
          ENDM
          SPACE  5,20
** NAME--LOADR    ** MODIFIED **
*
** PURPOSE-- LOAD A CM ADDRESS INTO THE R AND A REGISTERS.
*            AN INDEXED MEMORY LOCATION SPECIFIES THE ADDRESS.
*
** CALLING SEQUENCE-- LOADR   CMR,INDEX
*     THE CM ADDRESS IS CONTAINED IN THE LOCATIONS STARTING AT
*         CMR INDEXED BY INDEX.

 LOADR    MACRO  CMR,INDEX
 M        IFC    NE,$INDEX$$
          LRML   CMR,INDEX
          LDML   CMR+1,INDEX
 M        ELSE
 X        IFNE   CMR,CMADR
          LRML   CMR
          LDML   CMR+1
 X        ENDIF
          LRDL   CMR
          LDDL   CMR+1
 M        ENDIF
          ENDM
          SPACE  5,20
** NAME--LOADF    ** MODIFIED **
*
** PURPOSE-- REFORMAT A CM ADDRESS AND LOAD IT INTO THE R AND A REGISTERS.
*
** CALLING SEQUENCE-- LOADF   CMR,INDEX
*     THE UNFORMATTED CM ADDRESS IS CONTAINED IN THE LOCATIONS
*          STARTING AT CMR INDEXED BY INDEX.
*     INDEX IS OPTIONAL.

 LOADF    MACRO  CMR,INDEX
 N        IFC    NE,$INDEX$$
          LRML   CMR,INDEX
          LDML   CMR+1,INDEX
          SHN    -3
 N        ELSE
 P        IFLE   CMR,76B
 P        IFGE   CMR,0
          LRDL   CMR
          LDDL   CMR+1
 P        ELSE
          LRML   CMR
          LDML   CMR+1
 P        ENDIF
          SHN    -3
 N        ENDIF
          ENDM
          SPACE  5,20
** NAME-- REFAD    ** MODIFIED **
*
** PURPOSE-- REFORMAT AND SAVE A CM ADDRESS.
*
** NOTE-- R IS NOT LOADED.
*
** CALLING SEQUENCE-- REFAD   CMR,SAV
*     THE UNFORMATTED CM ADDRESS IS CONTAINED IN THE LOCATIONS
*          STARTING AT CMR.
*     THE REFORMATTED CM ADDRESS IS STORED IN THE LOCATIONS
*          STARTING AT SAV.
*
 REFAD    MACRO  CMR,SAV
 L        IFLE   CMR,76B
 L        IFGE   CMR,0
          LDDL   CMR
 M        IFLE   SAV,76B
 M        IFGE   SAV,0
          STDL   SAV
          LDDL   CMR+1
          SHN    -3
          STDL   SAV+1
 M        ELSE
          STML   SAV
          LDDL   CMR+1
          SHN    -3
          STML   SAV+1
 M        ENDIF
 L        ELSE
          LDML   CMR
 P        IFLE   SAV,76B
 P        IFGE   SAV,0
          STDL   SAV
          LDML   CMR+1
          SHN    -3
          STDL   SAV+1
 P        ELSE
          STML   SAV
          LDML   CMR+1
          SHN    -3
          STML   SAV+1
 P        ENDIF
 L        ENDIF
          ENDM
          SPACE  5,20
*
*         PAUSE   ** MODIFIED **
*
 PAUSE    MACRO  X           DELAY X MICROSECONDS
 R        IFLE   X,77B
          LDN    X
 R        ELSE
          LDC    X
 R        ENDIF
          HOLD               WAIT INSTRUCTION
          ENDM
          SPACE  5,20
 MASKP    MACRO  FIELD
          LOCAL  X
 X        SET    16-N.FIELD-L.FIELD
          MGEN   N.FIELD
 MSK      SET    MASK$
          DUP    X
 MSK      SET    MSK+MSK
          ENDD
          ENDM
          ENDIF
* END IODMAC4
          TITLE  SPECIAL MACROS
          SPACE  4
**        SUBR - DEFINE SUBROUTINE ENTRY/EXIT.
*
*NAME     SUBR
*         DECLARE *NAME* TO BE THE ENTRY POINT TO A PP SUBROUTINE
*         WHICH IS ENTERED VIA *RJM* TO *NAME*.
*
*         THE FOLLOWING CODE IS GENERATED.
*NAMEX    LJM    *
*NAME     EQU    *-1

          PURGMAC  SUBR

          MACRO  SUBR,A
 A_X      LJM    *
 A        EQU    *-1
          ENDM
          TITLE  CPU RECORD DEFINITIONS AND EQUATES
*
* PP INTERFACE TABLE
*

 PIT      RECORD PACKED

* WORD 1
 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
* WORD 2
          ALIGN  0,64
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
* WORD 3
 FILL1    PPWORD             UNUSED
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
* WORD 4
 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER
* WORD 5
          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)
* WORD 6
          ALIGN  32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)
* WORDS 7-8
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
* WORD 9
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
* WORD 10
          ALIGN  48,64
 IN       PPWORD             IN POINTER
* WORD 11
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
* WORD 12
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          EJECT
*
* UNIT DESCRIPTORS.
*

 UD       RECORD PACKED

* WORD 1
 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
* WORD 2
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 UD       RECEND
          SPACE  4
*
* UNIT INTERFACE TABLE
*

 UIT      RECORD PACKED

* WORD 1
 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
 QCNT     PPWORD             NOT USED
* WORD 2
          ALIGN  16,64
 UBUFL    PPWORD             UNIT COMMUNICATION BUFFER LENGTH
 UBUF     RMA                UNIT COMMUNICATION BUFFER (RMA)
* WORD 3
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
* WORD 4
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
* WORD 5
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
* WORD 6
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

          MASKP  DSABLE
 K.DSABLE EQU    MSK

 UIT      RECEND
          EJECT
*
* UNIT COMMUNICATION AREA
*

 UCA      RECORD PACKED

* WORD 1
 IN       PPWORD
 LIMIT    PPWORD
* WORDS 2-5
          ALIGN  0,64
 FILL1    STRUCT 32          RESERVRD

 UCA      RECEND
          SPACE  5
*
* REQUEST QUEUE
*

 RQ       RECORD PACKED

* WORD 1
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
* WORD 2
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
* WORD 3
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS
                               0 - ENABLE RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
 LONGB    BOOLEAN            LONG INPUT BLOCK
* WORD 4
          ALIGN  0,64
 SECADR   INTEGER            SECONDARY ADDRESS
* WORDS 5-64 COMMANDS

 RQ       RECEND
          EJECT
*
* COMMANDS
*

 CM       RECORD PACKED

* WORD 1
 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$

 CM       RECEND
          EJECT
*
* PP RESPONSE.
*

 RS       RECORD PACKED

* WORD 1
          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST
* WORD 2
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST
* WORD 3
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64       ALERT MASK
 LONGB    BOOLEAN            LONG INPUT BLOCK
* WORD 4
          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE INTERFACE
                             ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
 CHERR    BOOLEAN            CHANNEL PARITY ERROR ON INPUT
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION
                             OCCURRED ON INPUT OR INADEQUATE DATA RATE ON OUTPUT
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A
                             HARDWARE MALFUNCTION.  EXAMPLE- UNIT NOT READY.
 FTO      BOOLEAN            FUNCTION TIMEOUT
 CHERO    BOOLEAN            CHANNEL PARITY ERROR ON OUTPUT
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
                               1 - RECOVERED ERROR
                               2 - COMMAND HAD EXPLICIT RESPONSE FLAG SET
                               3 - BOTH CONDITIONS 1 AND 2
 K.REC    EQU    1           RECOVERED ERROR
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE
                               1 - UNIT CHANGED FROM READY TO NOT READY
                               2 - UNIT CHANGED FROM NOT READY TO READY
                               3 - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
                               4 - CONTROLLER RESERVED TO ANOTHER ACCESS
                               5 - UNIT RESERVED TO ANOTHER ACCESS
                               6 - RECOVERED ABNORMAL CONDITION
                               7 - DEADSTART RESPONSE
                               8 - INITIALIZATION ERROR
                                   (CHECK ERRID FOR CONDITION)
          ALIGN  48,64       ALERT CONDITIONS
 LNGBLK   BOOLEAN            LONG INPUT BLOCK
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
 PDLIM    BOOLEAN            PHYSICAL DELIMITER ENCOUNTERED (EOT OR BOT)
 LDLIM    BOOLEAN            LOGICAL DELIMITER ENCOUNTERED (TAPE MARK)
 CHARF    BOOLEAN            CHARACTER FILL PERFORMED
 DUNIT    BOOLEAN            UNIT WAS DISABLED BY PP
* WORD 5
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)
* WORD 6-13
 IOR      STRUCT 64          INDIVIDUAL OPERATION RESULTS
                             (BLOCK ID AND ON-THE-FLY CORRECTIONS)
* WORD 14
 ERRID    PPWORD             ERROR IDENTIFICATION
 FUNTO    PPWORD             FUNCTION WITH TIMEOUT
 STREG    PPWORD             STATUS REGISTER IPI CHANNEL
 ERREG    PPWORD             ERROR REGISTER IPI CHANNEL
* WORD 15
 DOWNST   PPWORD             DOWN STATUS
 K.PDN    EQU    8           PP IDLED ITSELF
 K.FDN    EQU    4           PP DOWNED THE FACILITY
 K.SDN    EQU    2           PP DOWNED THE SLAVE
 K.CDN    EQU    1           PP DOWNED THE CHANNEL
 K.NDN    EQU    0           PP DOWNED NOTHING

 FILL1    PPWORD             RESERVED
 FILL2    PPWORD             RESERVED
 FILL3    PPWORD             RESERVED
* WORD 16
 FACSTA   STRUCT 4           FACILITY STATUS, IPI ID52

 FILL4    PPWORD             RESERVED
 FILL5    PPWORD             RESERVED

* WORDS 17-48                IPI RESPONSE PACKET IF PRESENT
*                            VARIABLE LENGTH
          EJECT

          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$
          MASKP  ABALRT
 K.ABALRT EQU    MSK
          MASKP  INTERR
 K.INTERR EQU    MSK
          MASKP  HDWR
 K.HDWR   EQU    MSK
          MASKP  CHERR
 K.CHERR  EQU    MSK
          MASKP  DATOV
 K.DATOV  EQU    MSK
          MASKP  FTO
 K.FTO    EQU    MSK
          MASKP  LNGBLK
 K.LNGBLK EQU    MSK
          MASKP  PDLIM
 K.PDLIM  EQU    MSK
          MASKP  LDLIM
 K.LDLIM  EQU    MSK
          MASKP  CHARF
 K.CHARF  EQU    MSK
          MASKP  DUNIT
 K.DUNIT  EQU    MSK
          MASKP  CHERO
 K.CHERO  EQU    MSK

 RS       RECEND
          EJECT
*
* PP COMMUNICATION BUFFER.
*

 CB       RECORD PACKED

* WORD 1
          ALIGN  31,64
 SLAVE    BOOLEAN            NONZERO IF SLAVE PP
 PARTNR   RMA                PARTNERS PIT (RMA)
* WORD 2
 CONTRL   STRUCT 8           LOAD CONTROLWARE COMMAND
* WORD 3
 CMCMD    STRUCT 8           SLAVE COMMAND
* WORD 4
 OVRLAY   STRUCT 8           OVERLAY RMA
* WORDS 5-8
 FILL1    STRUCT 32          RESERVED
* WORDS 9-13
 SCRAT    STRUCT 40          SCRATCH AREA
* WORDS 14-28
 ZEROES   STRUCT 120         120 BYTES (15 CM WORDS) OF ZERO
* WORDS 29-544
 PTD      STRUCT 4128        PATH TEST DATA (516 CM WORDS)


          MASKP  SLAVE
K.SLAVE   EQU    MSK


 CB       RECEND
          TITLE  PP RECORD DEFINITIONS AND EQUATES
          SPACE  3
*
* CONFIGURED SLAVES.
*

 SL       RECORD PACKED

* PP WORD 1
 FBA      PPWORD             FACILITITES (BY ADDRESS BIT) ON THIS SLAVE

* PP WORD 2
 SIU      PPWORD             SLAVE IN USE FLAG

* PP WORD 3
 FACLCK   SUBRANGE 0,1777B   CURRENT FACILITY LOCKED FLAG
 CURFAC   SUBRANGE 0,77B     CURRENT FACILITY NUMBER (FOR USE IN SCANNING)

* PP WORD 4
 SLVTST   PPWORD             SLAVE TESTING REQUIRED  = 1
*                                ATTRIBUTES REQUIRED = 2

 SL       RECEND
          SPACE  4
*
* CONFIGURED UNITS.
*

 UN       RECORD PACKED

* PP WORD 1
 FILL1    SUBRANGE 0,177B    RESERVED
 FC       BOOLEAN            FACILITY CONFIGURED
 FD       BOOLEAN            FACILITY DISABLED
 CTF      BOOLEAN            CONFIDENCE TEST REQUIRED FLAG
 SN       SUBRANGE 0,7       SLAVE NUMBER
 FN       SUBRANGE 0,7       FACILITY NUMBER

* PP WORD 2
 LU       PPWORD             LOGICIAL UNIT NUMBER

* PP WORDS 3-4
 UIT      STRUCT 4           RMA OF UNIT INTERFACE TABLE (REFORMATTED)


          MASKP  FC
 K.FC     EQU    MSK
          MASKP  FD
 K.FD     EQU    MSK
          MASKP  CTF
 K.CTF    EQU    MSK

 UN       RECEND
          EJECT
 MBID     EQU    30          MAX. NUMBER OF BLOCK ID-S TO SUPPORT (PP WORDS)
 MAXREQ   EQU    65          MAX. REQUEST LENGTH (CM WORDS)
 MAXSDC   EQU    10          MAX. NUMBER OF DIRECT CELLS TO SAVE IN TS TABLE
          SPACE  2
*
* TS TABLE DEFINITIONS.
*

 TS       RECORD PACKED

* PP WORD 1
 CRN      PPWORD             USED TO MAKE COMMAND REFERENCE NUMBER UNIQUE

* PP WORD 2
 SN       SUBRANGE 0,377B    SLAVE NUMBER
 FN       SUBRANGE 0,377B    FACILITY NUMBER

* PP WORDS 3-6
 CPVACM   STRUCT 2           FILL FOR CM BOUNDARY
 CPVA     STRUCT 6           CURRENT REQUEST PVA (UNFORMATTED)

* PP WORDS 7-10
 CREQCM   STRUCT 4           FILL FOR CM BOUNDARY
 CREQ     STRUCT 4           CURRENT REQUEST RMA (UNFORMATTED)

* PP WORD 11
 LASTC    PPWORD             OFFSET OF COMMAND IN REQUEST

* PP WORD 12
 NUMCM    PPWORD             NUMBER OF COMMANDS LEFT TO PROCESS

* PP WORD 13
 ILSTL    PPWORD             NUMBER OF INDIRECT LIST ADDRESS-LENGTH PAIRS

* PP WORDS 14-15
 XFER     STRUCT 4           TRANSFER COUNT

* PP WORD 16
 CLK      PPWORD             STARTING OPERATION CLOCK VALUE

* PP WORD 17
 SECLIM   PPWORD             SECONDS LIMIT FOR CURRENT OPERATION

* PP WORDS 18-21
 CURCMD   STRUCT 8           CURRENT COMMAND

* PP WORD 22
 DENSEL   PPWORD             DENSITY SELECTION
                              1 = 1600 (PE)
                              2 = 6250 (GCR)
* PP WORD 23
 ECSEL    PPWORD             ERROR CORRECTION SELECTION
                              1 = EC ENABLED
                              2 = EC DISABLED
* PP WORD 24
 BIDEF    PPWORD             BLOCK ID EXPECTED FLAG
                              0 = NONE
                              1 = BID EXPECTED
                              2 = TAPE MARK EXPECTED
                              3 = EITHER TM OR BID EXPECTED
* PP WORD 25
 SCOND    PPWORD             STATUS CONDITIONS
                             100000 = LONG BLOCK
                              20000 = PHYSICAL DELIMITER (EOT)
                              10000 = LOGICIAL DELIMITER (TAPE MARK)
                               4000 = CHARACTER FILL
* PP WORD 26
 CHAIN    PPWORD             IPI COMMAND CHAINING FLAG
                             X0 = LAST COMMAND CHAIN WAS NOT ABORTED
                             X1 = LAST COMMAND CHAIN WAS ABORTED
                             0X = LAST COMMAND SENT WAS NOT CHAINED
                             2X = LAST COMMAND SENT WAS CHAINED
* PP WORDS 27-28
 FACSTA   STRUCT 4           FACILITY STATUS, IPI ID52

* PP WORDS 29-30
 ILSTA    STRUCT 4           INDIRECT LIST RMA (UNFORMATTED) ADDRESS

* PP WORDS 31-34
 ILSTP    STRUCT 8           INDIRECT LIST LENGTH/ADDRESS PAIR

* PP WORD 35
 CBURBC   PPWORD             CURRENT BURST BYTE COUNT

* PP WORD 36
 PARLAP   PPWORD             PARTIAL LENGTH/ADDRESS PAIR FLAG

* PP WORD 37
 RESBC    PPWORD             RESIDUAL BYTE COUNT FROM TRANSFER

* PP WORD 38
 SLVEES   PPWORD             SLAVE ENCODED ENDING STATUS

* PP WORD 39
 RETRY    PPWORD             RETRY COUNTER

* PP WORD 40
 NSCA     PPWORD             NON-STOP COMMAND ADDRESS (PP ADDRESS)

* PP WORD 41
 NSWC     PPWORD             NON-STOP WRITE COUNTER

* PP WORD 42
 NSRC     PPWORD             NON-STOP READ COUNTER

* PP WORD 43
 NSCRN    PPWORD             NON-STOP COMMAND REFERENCE NUMBER

* PP WORD 44
 WSTNF    PPWORD             WAIT SPECIAL TRANSFER NOTIFICATION FLAG

* PP WORD 45
 GNSCRN   PPWORD             GROUP NON-STOP COMMAND REFERENCE NUMBER

* PP WORD 46
 GNUMCM   PPWORD             GROUP NUMBER OF COMMANDS LEFT

* PP WORD 47
 GNSCA    PPWORD             GROUP NON-STOP PP COMMAND ADDRESS
          SPACE  4
* TS BUFFERS

*         BLOCK ID BUFFER
 BIDB     STRUCT MBID*2      BLOCK ID BUFFER
 OTFC     PPWORD             ON-THE-FLY ERROR CORRECTION COUNTER
 BIDBP    PPWORD             BLOCK ID BUFFER POINTER

*         RECORD TRANSFER COUNT CIRCULAR BUFFER
 RTCIP    PPWORD             IN POINTER
 RTCOP    PPWORD             OUT POINTER
 RTCB     STRUCT 16          BUFFER FOR 4 32-BIT RECORD TRANSFER COUNTS


*         NOTE - ALL TS TABLE CELLS UP TO HERE ARE CLEARED DURING
*                REQUEST INITIALIZATION PROCESSING.

*         SWITCH BUFFERS
 SAVEDC   STRUCT MAXSDC*2    SAVED DIRECT CELLS WHEN SWITCHING TS TABLES
 SATTR    PPWORD             SAVED SUBROUTINE ADDRESSES WHEN SWITCHING
 SOPMO    PPWORD
 SCFC     PPWORD
 SGFS     PPWORD
 SRSEL    PPWORD
 SRFEL    PPWORD
 SCLREQ   PPWORD
 SPTW     PPWORD
 SPTR     PPWORD
 SSLVT    PPWORD
 SISR     PPWORD
 SLIR     PPWORD
 SPTWOD   PPWORD
 SPTRID   PPWORD
 SREL     PPWORD
 SFACT    PPWORD
 SIH      PPWORD
 SWSTN    PPWORD

 RQB      STRUCT C.RQ*8      UNIT REQUEST HEADER BUFFER

 CQB      STRUCT C.CM*8*MAXREQ  UNIT COMMAND SEQUENCE BUFFER

 SPARE    STRUCT 14          SPARE BYTES

 TS       RECEND
          EJECT
* DEFINED RECORD EQUATES

* PP INTERFACE TABLE
 EBPIT    EQU    B.PIT       BYTE LENGTH
 EPPIT    EQU    P.PIT       PP WORD LENGTH
 ECPIT    EQU    C.PIT       CM WORD LENGTH

* UNIT DESCRIPTOR
 EBUD     EQU    B.UD        BYTE LENGTH
 EPUD     EQU    P.UD        PP WORD LENGTH
 ECUD     EQU    C.UD        CM WORD LENGTH

* UNIT INTERFACE TABLE
 EBUIT    EQU    B.UIT       BYTE LENGTH
 EPUIT    EQU    P.UIT       PP WORD LENGTH
 ECUIT    EQU    C.UIT       CM WORD LENGTH

* UNIT COMMUNICATIONS BUFFER
 EBUCA    EQU    B.UCA       BYTE LENGTH
 EPUCA    EQU    P.UCA       PP WORD LENGTH
 ECUCA    EQU    C.UCA       CM WORD LENGTH

* REQUEST QUEUE
 EBRQ     EQU    B.RQ        BYTE LENGTH
 EPRQ     EQU    P.RQ        PP WORD LENGTH
 ECRQ     EQU    C.RQ        CM WORD LENGTH

* COMMAND QUEUE
 EBCM     EQU    B.CM        BYTE LENGTH
 EPCM     EQU    P.CM        PP WORD LENGTH
 ECCM     EQU    C.CM        CM WORD LENGTH

* RESPONSE BUFFER (IPI RESPONSE BUFFER NOT INCLUDED)
 EBRS     EQU    B.RS        BYTE LENGTH
 EPRS     EQU    P.RS        PP WORD LENGTH
 ECRS     EQU    C.RS        CM WORD LENGTH

* PP COMMNUNICATIONS BUFFER
 EBCB     EQU    B.CB        BYTE LENGTH
 EPCB     EQU    P.CB        PP WORD LENGTH
 ECCB     EQU    C.CB        CM WORD LENGTH

* CONFIGURED SLAVES
 EBSL     EQU    B.SL        BYTE LENGTH
 EPSL     EQU    P.SL        PP WORD LENGTH
 ECSL     EQU    C.SL        CM WORD LENGTH

* CONFIGURED UNITS
 EBUN     EQU    B.UN        BYTE LENGTH
 EPUN     EQU    P.UN        PP WORD LENGTH
 ECUN     EQU    C.UN        CM WORD LENGTH

* TAPES SUPPORTED TABLE
 EBTS     EQU    B.TS        BYTE LENGTH
 EPTS     EQU    P.TS        PP WORD LENGTH
 ECTS     EQU    C.TS        CM WORD LENGTH
          TITLE  BUFFER EQUATES
*
* RESPONSE BUFFER EQUATES
*
 HRESPL   EQU    P.RS        NORMAL RESPONSE LENGTH (IN PP WORDS)
 NRL      EQU    HRESPL*2    NORMAL RESPONSE LENGTH (IN BYTES)

 SRESPL   EQU    128+1       MAX. IPI RESPONSE LENGTH +1 (IN PP WORDS)

 MRESPL   EQU    HRESPL+SRESPL  MAX. TOTAL RESPONSE BUFFER +1 (IN PP WORDS)
          SPACE  4
*
* CONFIGURATION EQUATES
*
 MAXCHP   EQU    1           MAX. NUMBER OF CHANNEL PORTS TO SUPPORT
 SLVPCH   EQU    8           MAX. NUMBER OF SLAVES PER CHANNEL PORT TO SUPPORT

 MAXSL    EQU    MAXCHP*SLVPCH  MAX. TOTAL SL TABLES TO SUPPORT

 FACPSL   EQU    8           MAX. NUMBER OF FACILITIES PER SLAVE TO SUPPORT
 MAXUD    EQU    MAXSL*FACPSL  MAX. TOTAL FACILITIES TO SUPPORT

 MCSLV    EQU    2           MAX. NUMBER OF CONCURRENT SLAVES TO SUPPORT
 MAXTS    EQU    1+MCSLV     MAX. NUMBER OF TS TABLES TO SUPPORT
          SPACE  4
*
* BUFFER EQUATES
*

* NOTE  CMSE FROM 37400-37777B
 ENDMEM   EQU    37371B            LARGEST DRIVER ADDRESS

 RPB      EQU    ENDMEM-SRESPL     IPI RESPONSE PACKET BUFFER

 RS       EQU    RPB-P.RS          PP RESPONSE BUFFER

 PITB     EQU    RS-P.PIT          PP INTERFACE TABLE

 SLB      EQU    PITB-P.SL*MAXSL   SLAVES CONFIGURED TABLE

 UNITS    EQU    SLB-P.UN*MAXUD    FACILITIES CONFIGURED TABLE

 TS       EQU    UNITS-P.TS*MAXTS  TS TABLES
*         NOTE   THE FIRST TS TABLE IS FOR PP REQUESTS

 STRTBUF  EQU    TS                STARTING BUFFER ADDRESS

 UNITD    EQU    RPB+1             TRANSIENT UNIT DESCRIPTOR
 UITB     EQU    UNITD+P.UD        TRANSIENT UIT BUFFER
          TITLE  EQUATES
* CONDITIONAL ASSEMBLY EQUATES
 FH       EQU    0           1= KEEP FUNCTION HISTORY TABLE
 KH       EQU    0           1= KEEP HISTORY OF IPI COMMAND/RESPONSE PACKETS
 VALID    EQU    1           1= VALIDATE CPU TABLES AND BUFFERS

* RESPONSE CODES (AA).
 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    40000B      INTERMEDIATE RESPONSE
 R.NRM    EQU    100000B     NORMAL REQUEST TERMINATION
 R.ABN    EQU    140000B     ABNORMAL REQUEST TERMINATION

* RESPONSE CODES (BB).
 R.RCV    EQU    10000B      RECOVERED ERROR CAUSED RESPONSE
 R.FLG    EQU    20000B      FLAG FIELD CAUSED RESPONSE
 R.RPF    EQU    R.RCV+R.FLG  BOTH CONDITIONS OCCURED

* UNSOLICITED RESPONSE CODES
 URC.RN   EQU    1           CHANGE FROM READY TO NOT READY
 URC.NR   EQU    2           CHANGE FROM NOT READY TO READY
 URC.IE   EQU    3           INTERNAL OR INTERFACE ERROR
 URC.CR   EQU    4           SLAVE RESERVED TO ANOTHER ACCESS
 URC.UR   EQU    5           FACILITY RESERVED TO ANOTHER ACCESS
 URC.RA   EQU    6           RECOVERED ABNORMAL CONDITION
 URC.DS   EQU    7           DEADSTART COMPLETED
 URC.IN   EQU    8           INITIALIZATION ERROR

* COMMAND EQUATES
 PSNI     EQU    2400B       PSN INSTRUCTION
 INPNI    EQU    102600B     INPN INSTRUCTION

 INDFLG   EQU    100B        INDIRECT ADDRESSING FLAG
 STRSP    EQU    200B        STORE RESPONSE FLAG

 IDLCMD   EQU    4           PP IDLE COMMAND
 RSUMCMD  EQU    5           PP RESUME COMMAND
 FUNCCMD  EQU    0#20        PHYSICAL COMMAND - FUNCTION (20 HEX)
 PWRTCMD  EQU    0#23        PHYSICAL COMMAND - OUTPUT 8-BIT DATA (23 HEX)
 LCREAD   EQU    0#41        LOCICAL READ RECORD OF 8-BIT DATA (41 HEX)
 LCWRITE  EQU    0#51        LOGICAL WRITE RECORD COMMAND (51 HEX)
 LCSTC    EQU    0#61        LOGICAL COMMAND STORE TRANSFER COUNT (61 HEX)

*         ATS PHYSICAL FUNCTION CODES
 F.FU     EQU    04B         FORMAT UNIT
 F.REW    EQU    10B         REWIND/UNLOAD UNIT
 F.SB     EQU    13B         FORESPACE/BACKSPACE BLOCK
 F.STM    EQU    15B         SEARCH TAPE MARK FWD/REV
 F.WTM    EQU    51B         WRITE TAPE MARK
 F.ERS    EQU    52B         ERASE TAPE
          EJECT
*
*         EQUATES FOR IPI ADAPTER
*
 H0X15    EQU    0#0015      REQUEST CLASS (X=PLUGGED) INTERRUPTS
 H0022    EQU    0#0022      CLEAR IPI ERROR REGISTER
 H0029    EQU    0#0029      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H005B    EQU    0#005B      SET SYNC OUT
 H0071    EQU    0#0071      FULL WHEN SLAVE IN IS 0
 H00E1    EQU    0#00E1      READ STATUS REGISTER
 H00F1    EQU    0#00F1      READ ERROR REGISTER
 H0281    EQU    0#0281      STREAM, READ
 H0381    EQU    0#0381      STREAM, WRITE
 H0A81    EQU    0#0A81      STREAM, READ, DMA
 H7C42    EQU    0#7C42      IPI CHANNEL TRANSFER RATE (5.00 MB)
 H8025    EQU    0#8025      MASTER OUT, FULL WHEN SLAVE IN IS 1
 H8039    EQU    0#8039      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H8115    EQU    0#8115      SET MASTER OUT, PHYSICAL INTERFACE RESET
 H8215    EQU    0#8215      SET MASTER OUT, LOGICAL INTERFACE RESET
 H8415    EQU    0#8415      SET MASTER OUT, SLAVE RESET
 H9211    EQU    0#9211      DROP SYNC OUT
 H9213    EQU    0#9213      SET SYNC OUT
          SPACE  2
*
* BUS CONTROL EQUATES
*
 CMDOUT   EQU    0           COMMAND, INFORMATION OUT
 RSPIN    EQU    1           RESPONSE, INFORMATION IN
 DATAOUT  EQU    2           DATA OUT
 DATAIN   EQU    3           DATA IN
          SPACE  2
*
* ENDING STATUS EQUATES
*
 EVENOT   EQU    0#0         EVEN OCTET TRANSFER
 ODDOT    EQU    0#F         ODD OCTET TRANSFER
          EJECT
*
* IPI COMMAND EQUATES
*
 OCNOP    EQU    0#0000      NOP
 OCATT    EQU    0#0200      ATTRIBUTES
 OCRAS    EQU    0#0300      REPORT ADDRESSEE STATUS
 OCPA     EQU    0#0400      PORT ADDRESS
 OCPC     EQU    0#0500      PATH CONTROL
 OCAC     EQU    0#0600      ATTENTION CONTROL
 OCOM     EQU    0#0700      OPERATING MODE
 OCABT    EQU    0#0800      ABORT
 OCREAD   EQU    0#1000      READ
 OCWRITE  EQU    0#2000      WRITE
 OCSPACE  EQU    0#4000      SPACE BLOCK/FILE
 OCPOSC   EQU    0#4100      POSITION CONTROL
 OCREPP   EQU    0#4200      REPORT POSITION
 OCRECP   EQU    0#4300      RECORD POSITION
 OCREADV  EQU    0#5000      READ VERIFY
 OCRFB    EQU    0#5200      READ FROM BUFFER
 OCRFDTB  EQU    0#5300      READ FACILITY DATA TO BUFFER
 OCWTB    EQU    0#6200      WRITE TO BUFFER
 OCWBTF   EQU    0#6300      WRITE BUFFER TO FACILITY
 OCIML    EQU    0#6600      LOAD SLAVE IML
 OCERASE  EQU    0#6700      ERASE
 OCPSD    EQU    0#8000      PERFORM SLAVE DIAGNOSTICS
 OCPFD    EQU    0#8100      PERFORM FACILITY DIAGNOSTICS
 OCREL    EQU    0#8400      READ ERROR LOG
          SPACE  4
*
* IPI COMMON MODIFIER EQUATES
*
 CMPRI    EQU    0#40        PRIORITY
 CMCHN    EQU    0#10        CHAIN
          SPACE  4
*
* IPI OPCODE MODIFIER EQUATES
*
 OMRF     EQU    0#2         READ FORWARD
 OMRR     EQU    0#A         READ REVERSE
 OMRVF    EQU    0#0         READ VERIFY FORWARD
 OMRVR    EQU    0#8         READ VERIFY REVERSE
 OMSFF    EQU    0#1         SEARCH FILE FORWARD
 OMSFR    EQU    0#9         SEARCH FILE REVERSE
 OMDSE    EQU    0#0         ERASE - DSE
 OMGAP    EQU    0#6         ERASE - GAP
 OMOMS    EQU    0#4         OPERATION MODE - SET
 OMAL     EQU    0#9         ATTRIBUTE - LOAD
 OMRELC   EQU    0#0         READ ERROR LOG - CLEAR
 OMRASC   EQU    0#1         REPORT ADDRESSEE STATUS - CONDITION
          EJECT
*
* IPI COMMON PARAMETER EQUATES
*
 CPTP     EQU    0#0251      TAPE POSITION PARAM
 CPTM     EQU    0#0251      TAPE MARK PARAM
 CPSRB    EQU    0#026E      SLAVE RECONFIGURATION BIT PARAM
 CPSRF    EQU    0#176F      SLAVE RECONFIGURATION FIELD PARAM
 CPNOP    EQU    0#0301      NOP PARAM
 CPBA     EQU    0#0350      BUFFER ADDRESS PARAM
 CPPM     EQU    0#0450      PORT MASK PARAM
 CPCE     EQU    0#0531      COMMAND EXTENT PARAM
 CPSCE    EQU    0#05D2      MAXIMUM BLOCK LENGTH (READ) PARAM
 CPTMB    EQU    0#0552      TAPE MODE BIT PARAM
 CPBCE    EQU    0#0931      BUFFER COMMAND EXTENT PARAM
 CPTMF    EQU    0#0953      TAPE MODE FIELD PARAM
 CPBID    EQU    0#02D0      ENABLE/DISABLE BID PARAM
          SPACE  4
*
* IPI ID EQUATES
*
 ID13     EQU    0#13        MICROCODE EXCEPTION FOR SLAVE
 ID14     EQU    0#14        INTERVENTION REQUIRED FOR SLAVE
 ID15     EQU    0#15        ALTERNATE PORT EXCEPTION
 ID16     EQU    0#16        MACHINE EXCEPTION FOR SLAVE
 ID17     EQU    0#17        COMMAND EXCEPTION FOR SLAVE
 ID18     EQU    0#18        COMMAND ABORTED FOR SLAVE
 ID19     EQU    0#19        SLAVE CONDITIONAL SUCCESS
 ID24     EQU    0#24        INTERVENTION REQUIRED FOR FACILITY
 ID26     EQU    0#26        MACHINE EXCEPTION FOR FACILITY
 ID29     EQU    0#29        FACILITY CONDITIONAL SUCCESS
 ID2A     EQU    0#2A        INCOMPLETE STATUS FOR FACILITY
 ID32     EQU    0#32        RESPONSE EXTENT PARAMETER
 ID51     EQU    0#51        CONDITION PARAMETER
 ID52     EQU    0#52        MEDIA STATUS PARAMETER
 IDD0     EQU    0#D0        BLOCK ID PARAMETER
 IDD2     EQU    0#D2        MAXIMUM BLOCK LENGTH PARAMETER
          EJECT
*
* IPI COMMAND/RESPONSE PACKET EQUATES
*
 CRN      EQU    1           COMMAND REFERENCE NUMBER
 OPCD     EQU    2           OPERATION CODE FOR SLAVE
 SLAD     EQU    3           SLAVE ADDRESS, FACILITY ADDRESS
 MAJST    EQU    4           MAJOR STATUS
          SPACE  4
*
* IPI MAJOR STATUS EQUATES
*         RESPONSE TYPES
 CC       EQU    1           COMMAND COMPLETE RESPONSE
 AR       EQU    4           ASYNCHRONOUS RESPONSE
 TN       EQU    5           TRANSFER NOTIFICATION
 CCS      EQU    0#18        COMMAND COMPLETE, SUCCESSFUL
          SPACE  4
*
* IPI LEFT SHIFTS FOR MAJOR STATUS
*
 LSCE     EQU    2           COMMAND EXCEPTION
 LSME     EQU    3           MACHINE EXCEPTION
 LSAPE    EQU    4           ALTERNATE PORT EXCEPTION
 LSIR     EQU    5           INTERVENTION REQUIRED
 LSMME    EQU    6           MESSAGE/MICROCODE EXCEPTION
 LSS      EQU    14          SUCCESSFUL
 LSI      EQU    15          INCOMPLETE
 LSCS     EQU    16          CONDITIONAL SUCCESS
 LSCA     EQU    17          COMMAND ABORTED
          SPACE  4
*
* IPI MISCELLANEOUS EQUATES
*
 BURST    EQU    8192        IPI BURST SIZE (MUST BE MULTIPLE OF 8)
          SPACE  4
*
*         MISCELLANEOUS EQUATES
*
 DC       EQU    37B         DEVICE CHANNEL NUMBER
 T698.1   EQU    21B         5698 UIT UNIT TYPE FOR 698-3X TAPE FACILITY
 MALETVE  EQU    1           MALVET/VE CHANNEL REQUEST VALUE IN WORD (T2)
 MS25     EQU    26738       25 MILLISECOND TIMEOUT FOR CERTAIN LOOPS
 SRT      EQU    45          SLAVE RESET TIMEOUT (SECONDS)
 BYPSD    EQU    400000B     BYPASS SELECT/DESELECT IN ROUTINE CPT
          EJECT
*
* IOU/SLAVE/FACILITY ERROR CODES    *** DEC ***
*
 E00      EQU    0           CP MUST DECODE STATUS IN RESPONSE PACKET
 E01      EQU    1           FUNCTION TIMEOUT
 E02      EQU    2           CHANNEL EMPTY WHEN ACTIVATED
 E03      EQU    3           PERIOD COUNTER PARITY
 E04      EQU    4           UPPER ICI PARITY
 E05      EQU    5           LOWER ICI PARITY
 E06      EQU    6           IOU ERROR
 E19      EQU    19          ILLEGAL OPERATION
 E20      EQU    20          CANT SELECT SLAVE
 E21      EQU    21          BIT SIGNIFICANT RESPONSE ERROR
 E22      EQU    22          NO SYNC IN
 E23      EQU    23          SYNC IN DID NOT DROP
 E24      EQU    24          IPI SEQUENCE ERROR
 E25      EQU    25          UPPER IPI CHANNEL PARITY
 E26      EQU    26          LOWER IPI CHANNEL PARITY
 E27      EQU    27          SLAVE IN NOT SET
 E28      EQU    28          SLAVE IN DID NOT DROP
 E29      EQU    29          INCOMPLETE TRANSFER
 E30      EQU    30          CHANNEL STAYED ACTIVE
 E31      EQU    31          BUFFER COUNTER PARITY
 E32      EQU    32          SYNC COUNTER PARITY
 E33      EQU    33          LOST DATA
 E34      EQU    34          BUS PARITY
 E35      EQU    35          COMMAND REJECT
 E36      EQU    36          SYNC OUT NOT EQUAL SYNC INS
 E37      EQU    37          BUS B ACKNOWLEDGE INCORRECT
 E38      EQU    38          NO SLAVE INTERRUPT
 E39      EQU    39          ENDING STATUS WRONG
 E40      EQU    40          SLAVE ENCODED ENDING STATUS WRONG
 E50      EQU    50          EXECUTING SLAVE DIAGNOSTICS
 E51      EQU    51          SLAVE DIAGNOSTICS PASSED
 E60      EQU    60          SLAVE FAILURE
 E61      EQU    61          FACILITY FAILURE
 E70      EQU    70          INTERNAL SLAVE ERROR
 E71      EQU    71          SLAVE INTERVENTION REQUIRED
 E72      EQU    72          SLAVE MACHINE EXCEPTION
 E73      EQU    73          COMMAND EXCEPTION
 E74      EQU    74          MICROCODE EXECUTION ERROR
 E75      EQU    75          ALTERNATE PORT EXCEPTION
 E76      EQU    76          UNEXPECTED RESPONSE
 E77      EQU    77          FACILITY RESERVED TO OTHER SLAVE
 E78      EQU    78          NO BLOCK ID PARAMETER RETURNED
 E79      EQU    79          UNEXPECTED CLASS 2 INTERRUPT
 E90      EQU    90          NO END OF EXTENT (TAPE MARK) DETECTED
 E110     EQU    110         PP-SLAVE DATA INTEGRITY
 E111     EQU    111         SLAVE-FACILITY DATA INTERGRITY
 E120     EQU    120         SOFTWARE FAILURE
          EJECT
*
* INTERFACE ERROR CODES.     *** HEX ***
*
 E201     EQU    1001B       RMA OF CHANNEL RESERVATION TABLE NOT
                              A WORD BOUNDARY
 E202     EQU    1002B       RMA OF UNIT ACTIVITY MASK NOT A
                              WORD BOUNDARY
 E203     EQU    1003B       RMA OF PP COMMUNICATION BUFFER NOT A
                              WORD BOUNDARY
 E204     EQU    1004B       RESERVED FIELD OF THE PP COMMUNICATION
                             BUFFER DESCRIPTOR IS NOT ZERO
 E205     EQU    1005B       RESERVED FIELD OF THE PP REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 E206     EQU    1006B       RMA OF NEXT PP NOT A WORD BOUNDARY
 E207     EQU    1007B       RESERVED FIELD OF THE PP RESPONSE
                             BUFFER DESCRIPTOR IS NOT ZERO
 E208     EQU    1010B       LOGICAL UNIT OF UNIT DESCRIPTOR NOT
                             IN SEQUENCE OR NOT IN RANGE
 E209     EQU    1011B       RMA OF UNIT INTERFACE TABLE NOT A
                             WORD BOUNDARY
 E20A     EQU    1012B       INVALID CHANNEL NUMBER SPECIFIED
                             IN UNIT DESCRIPTOR
 E20B     EQU    1013B       COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS OR NOT LONG ENOUGH
 E20D     EQU    1015B       RESERVED FIELD OF IN POINTER
                             IS NOT ZERO
 E20E     EQU    1016B       RESERVED FIELD OF OUT POINTER
                             IS NOT ZERO
 E20F     EQU    1017B       RESERVED FIELD OF LIMIT POINTER
                             IS NOT ZERO
 E210     EQU    1020B       INVALID PHYSICAL UNIT NUMBER
 E211     EQU    1021B       RMA OF INTERRUPT WORD NOT A WORD
                             BOUNDARY
 E212     EQU    1022B       RMA OF CHANNEL TABLE NOT A WORD
                             BOUNDARY
 E213     EQU    1023B       NO ACTIVE (NON NULL) UNIT DESCRIPTORS DEFINED
 E301     EQU    1401B       LOGICAL UNIT NUMBER NOT EQUAL TO LOGICAL
                             UNIT OF UNIT DESCRIPTOR
 E302     EQU    1402B       RMA OF UNIT COMMUNICATION BUFFER
                             NOT A WORD BOUNDARY
 E303     EQU    1403B       A RESERVED FIELD OF THE UNIT COMMUNICATION BUFFER
                             DESCRIPTOR IS NOT ZERO
 E304     EQU    1404B       RMA OF NEXT UNIT REQUEST
                             NOT A WORD BOUNDARY
 E305     EQU    1405B       RESERVED FIELD OF UNIT REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 E306     EQU    1406B       INVALID UNIT TYPE
 E307     EQU    1407B       UNIT COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF CM WORDS
 E308     EQU    1410B       UNIT COMMUNICATION BUFFER IS TOO SMALL
 E501     EQU    2401B       INVALID COMMAND CODE
 E505     EQU    2405B       INVALID LENGTH SPECIFICATION IN COMMAND
 E50A     EQU    2412B       INVALID SEQUENCE OF COMMANDS
          TITLE  DIRECT CELLS
 T0       CON    START-1     START OF DRIVER-1
 T1       BSSZ   1           SCRATCH CELLS
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1
 P1       BSSZ   1
 P2       BSSZ   1
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 P6       BSSZ   1
          SPACE  2
 CLCUR    BSSZ   1           CURRENT CHANNEL 14 CLOCK VALUE
 CLMCS    BSSZ   1           CLOCK, MICROSECOND
 CLMLS    BSSZ   1           CLOCK, MILLISECOND
 CLSEC    BSSZ   1           CLOCK, SECOND
 CPTBP    BSSZ   1           CPT BYPASS PARAMETER
 CSLVS    BSSZ   1           CONFIGURED SLAVES BY BIT ADDRESS
 CTM      BSSZ   1           IPI CHANGE TRANSFER MODE FLAG
 CURCH    BSSZ   1           CURRENT CHANNEL NUMBER
 FI       BSSZ   1           FUNCTION HISTORY BUFFER INDEX
 HBP      BSSZ   1           HISTORY BUFFER POINTER
 LF       BSSZ   1           LAST FUNCTION TO IPI ADAPTER
 LIM      BSSZ   1           LIMIT OF CM RESPONSE BUFFER
 MALREQF  BSSZ   1           MALET CHANNEL REQUEST FLAG
 TIU      BSSZ   1           TS TABLES IN USE BY BIT ADDRESS
 TSLVS    BSSZ   1           TOTAL NUMBER OF SLAVES CONFIGURED
 WC       BSSZ   1           WORD COUNTER

          BSSZ   4           UNUSED
          SPACE  4
*         THE FOLLOWING DIRECT CELLS ARE SAVED/LOADED WITH THE TS TABLE
 SAVEFWA  EQU    *
 ASYNCP   BSSZ   1           ASYNCHRONUS PROCESSING FLAG
 CTST     BSSZ   1           CURRENT TS TABLE INDEX
 FACN     BSSZ   1           CURRENT FACILITY NUMBER
 SLVN     BSSZ   1           CURRENT SLAVE NUMBER
 STATUS   BSSZ   1           IPI CHANNEL STATUS
 SX       BSSZ   1           SLAVES TABLE INDEX
 UX       BSSZ   1           UNITS TABLE INDEX
 SAVELWA  EQU    *-1
          ERRPL  SAVELWA-SAVEFWA-MAXSDC  INSURE TS SAVE AREA IS ENOUGH
*         THIS IS THE END OF THE SAVED TS TABLE DIRECT CELLS
          EJECT
* THE FOLLOWING CM.XXX ARE REFORMATTED CM ADDRESSES
 CM.PIT   BSSZ   2           CM ADDRESS OF PP INTERFACE TABLE
 CM.INT   BSSZ   2           CM ADDRESS OF INTERRUPT TABLE
 CM.CHAN  BSSZ   2           CM ADDRESS OF CHANNEL TABLE
 CM.COM   BSSZ   2           CM ADDRESS OF PP COMMUNICATION BUFFER
 CM.RS    BSSZ   2           CM ADDRESS OF RESPONSE BUFFER

* NOTE   DIRECT CELLS T1 THRU DCCEND WILL BE CLEARED ON DEADSTART/RESUMES
 DCCEND   EQU    *-1
          SPACE  4
 BURSTSZ  CON    BURST       IPI BURST SIZE
 INITFLG  DATA   1           INITIALIZATION FLAG 1=DS, 2=RESUME, 3=MALET
 PPREQF   DATA   0           PP REQUEST FLAG
 ONE      CON    1           CONSTANT ONE (DO NOT CHANGE THIS CELL)
 TWO      CON    2           CONSTANT TWO (DO NOT CHANGE THIS CELL)
 FF       CON    0#FF        CONSTANT HEX FF (DO NOT CHANGE THIS CELL)
 DSRTP    DATA   2,0         REAL MEMORY WORD-ADDRESS OF PIT (PLUGGED)

          ERRNZ  DSRTP-72B   MUST BE AT LOCATION 72

 IDLFLG   DATA   0           PP IDLE FLAG, IF NONZERO ONLY PP REQUESTS ARE DONE.
 CLF      DATA   1           CHANNEL LOCK FLAG  ** 0 = LOCKED **
 PPNO     DATA   5           LOGICAL PP NUMBER
          BSSZ   1           UNUSED


 ID       DATA   H*TAPC*     IDENTIFICATION

          ERRNZ  ID-100B     ID MUST BE AT LOCATION 100B
          SPACE  5
*
*         ENTRY POINT
*
          SPACE  2
 START    LJM    INIT        ENTRY POINT OF DRIVER

          ERRNZ  START-102B  ENTRY MUST BE AT LOCATION 102B
          TITLE  PP MONITOR

          SPACE  4
*
* PP MONITOR
*
          SPACE  2
 MAIN     BSS
          RJM    CKIT        CHECK FOR INITIALIZATION REQUIRED

          RJM    CKPPRQ      CHECK FOR ANY PP REQUESTS
          ZJN    MAIN10      IF NONE
          RJM    DOPPRQ      PROCESS PP REQUEST

 MAIN10   BSS
          LDDL   IDLFLG      CHECK IF PP IS IDLED
          NJN    MAIN        IF YES

 MAIN20   BSS
          RJM    CKCREQ      CHECK FOR MALET REQUESTING THE CHANNEL
          ZJN    MAIN30      IF NOT
          RJM    DOCREQ      PROCESS MALET CHANNEL REQUEST

 MAIN30   BSS
          RJM    CKUR        CHECK FOR UNIT REQUESTS
          ZJN    MAIN40      IF NONE
          LJM    DOUR        PROCESS UNIT REQUEST

 MAIN40   BSS
          RJM    CKINT       CHECK/PROCESS SLAVE ASYNCHRONUS INTERRUPTS

          LJM    MAIN        RELOOP
          TITLE  MONITOR SUBROUTINES
** NAME-- CKIT
*
** PURPOSE-- CHECK IF INITIALIZATION TESTING REQUIRED
*
** EXIT-- IMEDIATELY IF TESTING ALREADY COMPLETED.
*         AFTER TESTING ALL SLAVES WITH AT LEAST ONE
*         CONFIGURED NON-DISABLED FACILITY.
          SPACE  4
 CKIT     SUBR   ENTRY/EXIT
          LDDL   INITFLG     CHECK IF TESTING IS COMPLETE
          ZJN    CKITX       IF YES EXIT
          LDDL   IDLFLG      CHECK IF PP IS IDLE
          NJK    CKIT110     IF YES BYPASS TESTING
          LDDL   CTST        CHECK IF FIRST PASS THRU
          LMML   TS1
          NJN    CKIT10      IF NOT
          STDL   SLVN        START WITH SLAVE 0
          RJM    SCLOCK      GET CHANNEL LOCKED
          LDML   TS2         USE FIRST SLAVE TS TABLE
          STDL   CTST
          RJM    MR          MASTER RESET
          UJN    CKIT20      CONT.
 CKIT10   BSS
          AODL   SLVN        INCREMENT SLAVE NUMBER
          SBN    SLVPCH      CHECK FOR DONE
          PJK    CKIT100     IF YES
 CKIT20   BSS
          RJM    SETSX       SETUP SLAVE TABLE INDEX
          ZJN    CKIT10      IF NO CONFIGURED FACILITIES
          LDN    3           SET SLAVE TESTING/ATTRIBUTES REQUIRED FLAG
          STML   SLB+/SL/P.SLVTST,SX
          LDN    0
          STDL   FACN        START WITH FACILITY NUMBER 0
          UJN    CKIT40      CONT.
 CKIT30   BSS
          AODL   FACN        INCREMENT FACILITY NUMBER
          SBN    FACPSL      CHECK FOR LIMIT
          PJN    CKIT10      IF YES
 CKIT40   BSS
          RJM    SETUX       SETUP UNITS TABLE INDEX
          ZJN    CKIT30      IF UNIT NOT CONFIGURED
          LDML   UNITS+/UN/P.FD,UX
          SHN    /UN/L.FD+2  CHECK FOR DISABLED
          MJN    CKIT30      IF YES
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UIT
          CRDL   T1          GET UIT DISABLE BIT
          LDDL   T1+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJN    CKIT30      IF DISABLED
          LDML   TS2         USE FIRST SLAVE TS TABLE
          STDL   CTST
          RJM    INTS        INITIALIZE TS TABLE
          LDML   UNITS+/UN/P.LU,UX  GET LOGICIAL UNIT NUMBER
          STML   /TS/P.RQB+/RQ/P.LU,CTST  PUT INTO TS TABLE
          LDDL   INITFLG     CHECK IF DEADSTART INITIALIZATION
          SBN    1
          NJN    CKIT50      IF NOT
 CKIT45   BSS
          LDN    2           SET RETRY LEVEL
          STML   /TS/P.RETRY,CTST
          RJM    ISR         ISSUE SLAVE RESET
          UJN    CKIT60      CONT.
 CKIT50   BSS
          LDML   SRTAB,SLVN  CHECK IF SLAVE RESET EVER ISSUED
          ZJN    CKIT45      IF NOT
          LDN    1           SET RETRY LEVEL
          STML   /TS/P.RETRY,CTST
          RJM    LIR         LOGICIAL INTERFACE RESET
 CKIT60   BSS
          LDN    0           SET RETRY LEVEL
          STML   /TS/P.RETRY,CTST
          LDN    1           ENABLE ERROR CORRECTION
          STML   /TS/P.ECSEL,CTST
          RJM    ATTRIB      SET ALL SLAVE ATTRIBUTES
          RJM    PTW         PATH TEST WRITE
          RJM    PTR         PATH TEST READ
          LDN    0           CLR SLAVE TESTING/ATTRIBUTES REQUIRED FLAG
          STML   SLB+/SL/P.SLVTST,SX
          UJK    CKIT10      GO DO NEXT SLAVE

*         INITIALIZATION TESTING COMPLETE
 CKIT100  BSS
          LDN    0           CLEAR SLAVE TS TABLE
          STDL   SLVN
          STDL   FACN
          RJM    CLRTS       CLEAR TS2 SLAVE TABLE
 CKIT110  BSS
          LDML   TS1         RESET TO TS1 IF PP RESUME
          STDL   CTST
          LDDL   INITFLG     DETERMINE WHAT CAUSED PP INITIALIZATION
          SBN    3
          ZJN    CKIT120     IF MALET
          RJM    CLRTS       CLEAR TS1 PP TABLE
          LDN    0
          STDL   TIU         CLEAR TS TABLES IN USE FLAG
          STDL   PPREQF      CLEAR IF FROM RESUME
          STML   RPB         CLEAR IPI RESPONSE LENGTH
          STDL   SX          CLEAR SLAVE INDEX
          STDL   UX          CLEAR UNIT INDEX
          UJN    CKIT130     CONT.
 CKIT120  BSS
          LDDL   IDLFLG      MALET PROCESSING
          NJN    CKIT140     IF PP IS IDLE (TESTING DONE BY RESUME)
 CKIT130  BSS
          LDN    0
          STDL   INITFLG     CLR INITIALIZATION FLAG
 CKIT140  BSS
          UJK    CKITX       EXIT
          EJECT
** NAME-- CKPPRQ
*
** PURPOSE-- CHECK IF THERE ARE ANY PP REQUESTS QUEUED.
*
** EXIT-- A = NZ IF NEW OR PENDING REQUEST ACTIVE (PPREQF = NZ).
*         A = 0  IF NO REQUEST ACTIVE (PPREQF = 0).
          SPACE  2
 CKPPRQ2  RJM    CPLOCK      UNLOCK PP REQUEST QUEUE IN PIT
 CKPPRQ4  LDN    0           NO NEW REQUESTS


 CKPPRQ   SUBR               ENTRY/EXIT


          LDDL   PPREQF      CHECK IF PENDING REQUEST
          NJN    CKPPRQX     IF YES EXIT
          LOADC  CM.PIT      LOAD A AND R FOR PIT
          ADK    /PIT/C.PPQ
          CRML   T1,ONE      READ REQUEST RMA FROM PIT
          LDDL   T3          HALF 1 OF REQUEST RMA
          ADDL   T4          HALF 2 OF REQUEST RMA
          ZJN    CKPPRQX     IF NO REQUEST QUEUED
          RJM    SPLOCK      LOCK PP REQUEST QUEUE IN PIT
          NJK    CKPPRQ4     RETURN IF PP REQUEST QUEUE ALREADY LOCKED
          LOADC  CM.PIT      CM ADDRESS TO A AND R FOR READ
          ADK    /PIT/C.PPQPVA
          CRML   PITB+/PIT/P.PPQPVA-1,TWO  READ IN REQUEST PVA/RMA FROM PIT
          LDML   PITB+/PIT/P.PPQ  GET HALF 1 OF RMA OF 1ST REQUEST
          ADML   PITB+/PIT/P.PPQ+1
          ZJK    CKPPRQ2     IF RMA = 0 NO PP REQUEST QUEUED
          LDN    1           SET PP REQUEST FLAG
          STDL   PPREQF
          UJK    CKPPRQX     EXIT
          EJECT
** NAME-- DOPPRQ
*
** PURPOSE-- PROCESS THE WAITING PP REQUEST IF POSSIBLE.
*
** NOTE-- THE ONLY PP COMMANDS SUPPORTED ARE IDLE AND RESUME.
*         THERE CAN BE ONLY ONE COMMAND PER PP REQUEST.
          SPACE  2
 DOPPRQ   SUBR               ENTRY/EXIT
          LDDL   TIU         CHECK IF ANY SLAVE USING TS TABLES
          LPN    76B         MASK OUT PP TS TABLE
          NJN    DOPPRQX     IF YES EXIT
          STDL   PPREQF      CLEAR THE PP REQUEST FLAG
          STDL   SLVN        CLEAR SLAVE NUMBER
          STDL   FACN        CLEAR FACILITY NUMBER
          LDN    1           SET PP TS TABLE IN USE
          STDL   TIU
          LDML   TS1         USE TS TABLE 1 FOR THE PP REQUEST
          STDL   CTST
          LDK    CM.PIT      SETUP SOURCE OF REQUEST
          STDL   T7
          RJM    LDTS        LOAD THE TS TABLE AND UNLOCK QUEUE
          LDML   /TS/P.NUMCM,CTST  CHECK NUMBER OF COMMANDS
          SBN    1           PP CAN ONLY HAVE 1 ACTIVE COMMAND
          ZJN    DOPPRQ5     IF OK
          LDK    E50A        INVALID SEQUENCE OF COMMANDS
          RJM    SWFAIL      REPORT SOFTWARE FAILURE (NO RETURN)
 DOPPRQ5  BSS
          LDML   /TS/P.CQB,CTST  GET THE PP COMMAND
          SHN    -8          POSITION IT
          SBN    IDLCMD      CHECK FOR IDLE COMMAND
          ZJK    IDLE        IF YES
          SBN    RSUMCMD-IDLCMD  CHECK FOR RESUME COMMAND
          ZJK    RESUME      IF YES
          LDK    E501        INVALID COMMAND CODE
          RJM    SWFAIL      REPORT SOFTWARE FAILURE (NO RETURN)
          EJECT
** NAME-- CKCREQ
*
** PURPOSE-- CHECK IF CHANNEL IS REQUESTED BY MALET.
*
** EXIT-- A = NZ IF NEW OR PENDING REQUEST ACTIVE (MALREQF = NZ).
*         A = 0  IF NO REQUEST ACTIVE (MALREQF = 0).
          SPACE  2
 CKCREQ1  LDN    0           EXIT A = 0
          STDL   MALREQF     CLEAR MALET REQUEST FLAG

 CKCREQ   SUBR               ENTRY/EXIT


          LDDL   MALREQF     CHECK IF REQUEST ALREADY ACTIVE
          NJK    CKCREQX     IF YES, EXIT
          LDDL   CLF         CHECK IF CHANNEL IS CURRENTLY LOCKED
          NJN    CKCREQ1     IF NOT, EXIT
          LOADC  CM.CHAN     ADDRESS OF CM CHANNEL TABLE
          ADDL   CURCH       CHANNEL NUMBER IS INDEX INTO TABLE
          CRML   T1,ONE      READ CM CHANNEL ENTRY
          LDDL   T2          GET MAINTENANCE BYTES OF CHANNEL WORD
          LMK    MALETVE     CHECK IF REQUESTED
          NJK    CKCREQ1     IF CHANNEL IS NOT REQUESTED
          LDDL   T2          SET MALREQF
          STDL   MALREQF
          UJK    CKCREQX     EXIT A = NZ
          EJECT
** NAME-- DOCREQ
*
** PURPOSE-- PROCESS MALET CHANNEL REQUEST IF POSSIBLE
*
          SPACE  2
 DOCREQ   SUBR               ENTRY/EXIT
          LDDL   TIU         CHECK IF ANY SLAVE TABLES STILL IN USE
          LPN    76B         EXCEPT PP TS TABLE
          NJN    DOCREQX     IF YES EXIT
          DCN    DC+40B      INSURE CHANNEL IS INACTIVE
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          LDN    0
          STDL   MALREQF     CLEAR MALET REQUEST FLAG
          PAUSE  25000       GIVE MAINTENANCE PP THE CHANNEL
          LDDL   IDLFLG      CHECK IF PP IS IDLE
          NJN    DOCREQX     IF YES EXIT
*                            RESUME WILL CAUSE INITIALIZATION TESTING
          LDDL   INITFLG     CHECK IF TESTING ALREADY ESTABLISHED
          NJN    DOCREQ5     IF YES
          LDN    3           SET MALET REQUIRED INIT TESTING
          STDL   INITFLG
 DOCREQ5  BSS
          LDML   TS1         ENABLE TESTING
          STDL   CTST
          LJM    MAIN        GO DO TESTING
          EJECT
** NAME-- CKUR
*
** PURPOSE-- CHECK FOR ANY NEW OR CURRENT UNIT REQUESTS
*
** EXIT-- A = 0 IF NO REQUESTS ARE ACTIVE.
*         A = 1 IF CURRENT REQUEST ACTIVE.
*         A = 2 IF NEW LOCKABLE REQUEST IS ACTIVE.
          SPACE  2
 CKUR     SUBR               ENTRY/EXIT
          LDDL   TIU         GET TABLES IN USE
          LPN    76B         MASK WITH SLAVE TABLES USABLE
          ZJN    CKUR20      IF NONE ACTIVE

 CKUR10   RJM    SCANT       SCAN TABLES FOR NEXT ACTIVE ONE
          ZJN    CKUR10      IF NOT THIS ONE
          LDN    1           SET A=1, ACTIVE CURRENT REQUEST
          UJN    CKURX       EXIT

 CKUR20   LDDL   PPREQF      CHECK FOR ACTIVE PP REQUEST
          ADDL   MALREQF     ALSO MALET CHANNEL REQUEST
          ZJN    CKUR30      IF NOT
          LDN    0           SET A=0, DO NOT START ANY NEW REQUESTS
          UJN    CKURX       EXIT

 CKUR30   RJM    SNXTAB      SELECT NEXT SLAVE TS TABLE TO USE
          RJM    SCANAS      SCAN ALL SLAVES FOR A LOCKABLE REQUEST
          ZJN    CKURX       IF NONE ACTIVE, EXIT A=0

          LDN    2           SET A=2, NEW REQUEST TO PROCESS
          UJN    CKURX       EXIT
          EJECT
** NAME-- DOUR
*
** PURPOSE-- PROCESS CURRENT OR NEW UNIT REQUESTS
*
** ENTRY--A = 1 IF CURRENT REQUEST TO BE PROCESSED
*         A = 2 IF NEW REQUEST TO BE PROCESSED
          SPACE  2
 DOUR     BSS                ENTRY
          SBN    1           CHECK FOR CURRENT ACTIVE REQUEST
          NJN    DOUR20      IF NOT

          RJM    RELDTAB     RELOAD CURRENT REQUEST TS TABLE
          LDML   SLB+/SL/P.SIU,SX  GET PROCESSING ADDRESS
          STML   DOURA       STORE JUMP ADDRESS
          LJM    *           GO PROCESS REQUEST
 DOURA    EQU    *-1

 DOUR20   RJM    INITNR      INITIALIZE NEW REQUEST
 DOUR30   SOML   /TS/P.NUMCM,CTST  DECREMENT COMMANDS REMAINING
          LDN    0           DO NOT INCREMENT COMMAND OFFSET
          RJM    NEXTCMD     GET NEXT (FIRST) COMMAND
          EJECT
*         DECODE AND EXECUTE THE NEXT COMMAND
 CMDEXEC  LDN    0
          STML   RPB         CLEAR IPI RESPONSE PACKET LENGTH
          STML   /TS/P.SCOND,CTST  CLEAR LAST STATUS CONDITIONS

          LDML   /TS/P.CURCMD,CTST  GET COMMAND CODE
          SHN    -8          POSITION IT

*         CHECK FOR PHYSICAL FUNCTION COMMAND (20 HEX)
 CMDEX20  SBN    FUNCCMD
          NJN    CMDEX23     IF NOT
          LJM    PFUNC

*         CHECK FOR OUTPUT 8-BIT DATA COMMAND (23 HEX)
 CMDEX23  SBN    PWRTCMD-FUNCCMD
          NJN    CMDEX41     IF NOT
          LJM    OUT8D

*         CHECK FOR LOGICIAL READ COMMAND (41 HEX)
 CMDEX41  SBN    LCREAD-PWRTCMD
          NJN    CMDEX51     IF NOT
          LJM    READ

*         CHECK FOR LOGICIAL WRITE COMMAND (51 HEX)
 CMDEX51  SBN    LCWRITE-LCREAD
          NJN    CMDEX61     IF NOT
          LJM    WRITE

*         CHECK FOR STORE TRANSFER COUNT COMMAND (61 HEX)
 CMDEX61  SBN    LCSTC-LCWRITE
          NJN    CMDEX99     IF NOT
          LJM    STRTC

*         INVLAID COMMAND
 CMDEX99  LDK    E501        INVALID COMMAND CODE
          RJM    SWFAIL      REPORT SOFTWARE FAILURE (NO RETURN)
          EJECT
*         CURRENT COMMAND HAS COMPLETED
 CMDCOMP  BSS
          RJM    ERRCHK      CHECK FOR ERRORS
          NJK    FAIL        IF ERRORS

 NOSTAT   LDML   /TS/P.CURCMD,CTST  CHECK FOR STORE RESPONSE REQUESTED
          LPK    STRSP
          ZJN    NOSTR       IF NOT REQUESTED
          LDML   /TS/P.NUMCM,CTST  CHECK IF THIS IS LAST COMMAND
          ZJN    REQCOMP     IF YES
          RJM    PNR         PREPARE NORMAL RESPONSE
          LDC    R.FLG       SET FLAG CAUSED RESPONSE BIT
          RAML   RS+/RS/P.RC
          RJM    RESP        SEND RESPONSE

 NOSTR    LDML   /TS/P.NUMCM,CTST  CHECK IF MORE COMMANDS
          ZJN    REQCOMP     IF NONE LEFT
          SOML   /TS/P.NUMCM,CTST  DECREMENT COMMANDS LEFT
          LDN    8           INCREMENT COMMAND OFFSET TO GET NEXT COMMAND
          RJM    NEXTCMD     GET NEXT COMMAND
          UJK    CMDEXEC     GO EXECUTE NEXT COMMAND

*         REQUEST HAS BEEN COMPLETED
 REQCOMP  BSS
          RJM    GFS         GET FACILITY ID52 STATUS
          RJM    PNR         PREPARE NORMAL RESPONSE

 FAIL     LJM    IODONE      PROCESS END OF REQUEST
          EJECT
** NAME-- CKINT
*
** PURPOSE-- CHECK FOR ANY ASYNCHRONUS SLAVE INTERRUPTS
*            AND PROCESS THEM
          SPACE  2
 CKINT1   LDML   CKINTA      RESTORE ORIGINAL SLVN AND FACN
          STDL   SLVN
          LDML   CKINTB
          STDL   FACN
          RJM    CLRTS       CLEAR TS TABLE
          LDN    0           CLEAR ASYNCHRONUS PROCESSING FLAG
          STDL   ASYNCP
          LDDL   TIU         CLEAR TS TABLE IN USE
          LPN    73B
          STDL   TIU

 CKINT    SUBR               ENTRY/EXIT

          LDDL   TIU         CHECK IF ANY TS TABLES ARE IN USE
          NJN    CKINTX      IF YES EXIT
          LDN    4           SET TS3 TABLE IN USE
          STDL   TIU
          LDML   TS3         SET CURRENT TS TABLE TO TS3
          STDL   CTST
          STDL   ASYNCP      SET ASYNCHRONUS PROCESSING FLAG
          LDDL   SLVN        SAVE ORIGINAL SLVN AND FACN
          STML   CKINTA
          LDDL   FACN
          STML   CKINTB
          LDN    0           INITIALIZE RPB AND SLAVE NUMBER
          STML   RPB
          STDL   SLVN
          RJM    INTS        INITIALIZE CURRENT TS TABLE
          RJM    MCC         MASTER CLEAR CHANNEL
          UJN    CKINT20     CONT.

 CKINT10  AODL   SLVN        INCREMENT SLAVE NUMBER
          SBN    SLVPCH      CHECK FOR DONE
          ZJK    CKINT1      IF YES

 CKINT20  RJM    SETSX       CHECK IF SLAVE IS CONFIGURED
          ZJN    CKINT10     IF NOT
          LDN    0           INITIALIZE FACILITY NUMBER
          STDL   FACN

 CKINT30  RJM    SETUX       CHECK IF FACILITY IS CONFIGURED
          NJN    CKINT40     IF YES
          AODL   FACN        INCREMENT FACILITY NUMBER
          UJN    CKINT30     TRY NEXT ONE

*         CHECK FOR CLASS 2 INTERRUPTS
 CKINT40  LDN    2           CLASS 2 INTERRUPTS
          RJM    RI          REQUEST INTERRUPTS
          LDML   SELT,SLVN   GET SLAVE ADDRESS MASK
          LPDL   STATUS      MASK WITH ACTIVE SLAVE INTERRUPTS
          ZJN    CKINT50     IF NONE

*         PROCESS CLASS 2 INTERRUPTS
          RJM    SARF        SET ATTRIBUTES REQUIRED FLAG
          LDN    0           NO IPI STATUS IN RESPONSE
          STML   RPB
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          LDK    E79         UNEXPECTED CLASS 2 INTERRUPT
          STML   RS+/RS/P.ERRID
          LDDL   STATUS      SHOW SLAVE ADDRESSES WITH CLASS 2 INTERRUPTS
          STML   RS+/RS/P.STREG
          RJM    RESP        SEND RESPONSE
          RJM    LIR         LOGICIAL INTERFACE RESET TO CLEAR INTERRUPTS
          UJK    CKINT10     LOOP

*         CHECK FOR CLASS 1 OR 3 INTERRUPTS
 CKINT50  LDN    5           CLASS 1 AND 3 INTERRUPTS
          RJM    RI          REQUEST INTERRUPTS
          LDML   SELT,SLVN   GET SLAVE ADDRESS MASK
          LPDL   STATUS      MASK WITH ACTIVE SLAVE INTERRUPTS
          ZJK    CKINT10     IF NONE

*         PROCESS CLASS 1 OR 3 INTERRUPTS
          RJM    DTM         DETERMINE TRANSFER MODE
          RJM    SEL         SELECT SLAVE
          STDL   CTM         CLEAR CHANGE TRANSFER MODE FLAG
          RJM    RPT         RESPONSE PACKET TRANSFER
          RJM    DCM         DESELECT SLAVE
          LDML   RPB+MAJST   CHECK FOR ASYNC RESPONSE
          SHN    -4
          LPN    0#F
          LMK    AR
          NJN    CKINT60     IF NOT ASYNC RESPONSE
          LDML   RPB+SLAD    CHECK IF FACILITY ASYNC
          LPDL   FF
          LMDL   FF
          NJN    CKINT50     IF YES CHECK FOR OTHER INTERRUPTS
          RJM    SARF        SET ATTRIBUTES REQUIRED FLAG
 CKINT60  RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    RESP        SEND RESPONSE
          UJK    CKINT50     CHECK FOR OTHER INTERRUPTS THIS SLAVE
          SPACE  2
 CKINTA   BSSZ   1           ORIGINAL SLVN
 CKINTB   BSSZ   1           ORIGINAL FACN
          TITLE  COMMAND ROUTINES
** NAME-- IDLE
*
** PURPOSE-- PROCESS PP IDLE COMMAND
*            (LOGICIAL COMMAND 04)
          SPACE  2
 IDLE     BSS                ENTRY
          RJM    CCLOCK      CLEAR THE CHANNEL LOCK
          LDN    76B
          STDL   IDLFLG      SET THE PP IDLE FLAG
          LDN    0           NO IPI STATUS IN RESPONSE
          STML   RPB
          RJM    PNR         PREPARE NORMAL RESPONSE
          LDK    /RS/K.PDN   PP IDLED
          STML   RS+/RS/P.DOWNST
          RJM    RESP        SEND THE RESPONSE
          RJM    CLREQ       CLEAR THE REQUEST
          LJM    MAIN        GO TO MAIN AND WAIT FOR RESUME COMMAND
          EJECT
** NAME-- RESUME
*
** PURPOSE-- PROCESS PP RESUME COMMAND
*            (LOGICIAL COMMAND 05)
*
** NOTE-- RESPONSE TO RESUME COMMAND WILL BE SENT AFTER INITIALIZATION
*         TESTING HAS COMPLETED.
          SPACE  2
 RESUME   BSS                ENTRY
          LDN    0
          STDL   IDLFLG      CLEAR THE PP IDLE FLAG
          LDN    2
          STDL   INITFLG     SET INITIALIZATION FLAG TO RESUME
          LJM    INIT        REINITIALIZE THIS DRIVER
          EJECT
** NAME - PFUNC
*
** PURPOSE - TO PERFORM THE PHYSICAL COMMAND FUNCTION.
*            (LOGICIAL COMMAND 20)
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PFUNC    BSS                ENTRY
          LDML   /TS/P.CURCMD+3,CTST  GET FUNCTION CODE TO PROCESS
          LPN    77B         MASK MAJOR FUNCTION CODE BITS
* DECODE ATS FUNCTION CODE
          SBN    F.FU
          NJN    PFUNC10
          LJM    PFORM       IF FORMAT UNIT
 PFUNC10  BSS
          SBN    F.REW-F.FU
          NJN    PFUNC20
          LJM    PREW        IF REWIND/UNLOAD
 PFUNC20  BSS
          SBN    F.SB-F.REW
          NJN    PFUNC30
          LJM    PSPB        IF SPACE BLOCK FWD/REV
 PFUNC30  BSS
          SBN    F.STM-F.SB
          NJN    PFUNC40
          LJM    PSTM        IF SEARCH TAPE MARK FWD/REV
 PFUNC40  BSS
          SBN    F.WTM-F.STM
          NJN    PFUNC50
          LJM    PWTM        IF WRITE TAPE MARK
 PFUNC50  BSS
          SBN    F.ERS-F.WTM
          NJN    PFUNC90
          LJM    PERS        IF ERASE TAPE

*         NON-SUPPORTED COMMAND
 PFUNC90  BSS
          LDK    E501        NON-SUPPORTED COMMAND
          RJM    SWFAIL      REPORT SOFTWARE FAILURE (NO RETURN)
          EJECT
** NAME - OUT8D
*
** PURPOSE - PROCESS THE OUTPUT 8-BIT DATA COMMAND.
*            (LOGICIAL COMMAND 23)
*
** NOTE - THE WRITE COMMAND PACKET HAS ALREADY BEEN SENT BY THE
*         WRITE (LOGICIAL 51) COMMAND. THE TRANSFER NOTIFICATION
*         HAS NOT BEEN RECEIVED YET.
          SPACE  2
 OUT8D    BSS                ENTRY

 O8D05    LDML   /TS/P.WSTNF,CTST  CHECK WSTN FLAG
          NJK    O8D440      IF SET, CONTINUE CURRENT RECORD
          SPACE  2
*         PROCESS IPI INTERRUPTS
 O8D10    LDN    10          SECONDS LIMIT  (INCLUDES ID RETRY)
          RJM    IH          INTERRUPT HANDLER
          SHN    -4          POSITION RESPONSE TYPE
          LPN    0#F         MASK IT
          SBN    1           CHECK FOR COMMAND COMPLETION
          ZJK    O8D600      IF YES
          SBN    4           CHECK FOR TRANSFER NOTIFICATION
          ZJN    O8D20       IF YES
          LDN    0           ELSE MUST BE ASYNCHRONUS RESPONSE
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    O8D05       LOOP
          SPACE  2
*         INITIALIZE DATA TRANSFER
 O8D20    LDML   /TS/P.WSTNF,CTST CHECK WSTN FLAG
          ZJN    O8D25       IF NOT SET, START NEW RECORD
          LDN    0           CLEAR WSTN FLAG
          STML   /TS/P.WSTNF,CTST
          UJN    O8D30       CONTINUE CURRENT RECORD

 O8D25    RJM    NSI         NON-STOP INITIALIZATION
          LDML   /TS/P.NSCRN,CTST  COMPARE COMMAND REFERENCE NUMBERS
          LMML   RPB+CRN
          ZJN    O8D30       IF OK
          LDK    E76         REPORT UNEXPECTED STATUS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE (NO RETURN)
          SPACE  2
*         START DATA TRANSFER
 O8D30    RJM    SEL         SELECT SLAVE

 O8D40    LDN    DATAOUT     BUS A DATA OUT
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0381       STREAM AND WRITE
          RJM    FUNC
          ACN    DC          ACTIVATE CHANNEL
          LDN    0           CLEAR CURRENT BURST BYTE COUNT
          STML   /TS/P.CBURBC,CTST

*         DETERMINE BURST CHARACTERISTICS
 O8D50    LDML   /TS/P.ILSTP+1,CTST  GET REQUESTED BYTE COUNT THIS PAIR
          STDL   T1          SAVE IT
          ADML   /TS/P.CBURBC,CTST  ADD CURRENT BURST BYTE COUNT
          SBDL   BURSTSZ     SUBTRACT SLAVE BURST SIZE
          ZJN    O8D200      IF TRANSFER IS TO BURST BOUNDARY
          PJN    O8D300      IF TRANSFER IS GREATER THAN BURST BOUNDARY

*         PROCESS TRANSFER OF LESS THAN BURST BOUNDARY
          LDN    0           CLEAR PARTIAL L/A PAIR FLAG
          STML   /TS/P.PARLAP,CTST
          LDDL   T1          GET REQUESTED BYTE COUNT THIS PAIR
          ADN    1           ROUND UP (IF LAST PAIR HAS ODD BYTE COUNT)
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNEL WORD COUNT
          LDDL   T1          INCREMENT CURRENT BURST BYTE COUNT
          RAML   /TS/P.CBURBC,CTST
          RJM    OUTPUT      OUTPUT THE DATA
          NJN    O8D400      IF PARTIAL RECORD
          RJM    GETNP       GET NEXT L/A PAIR
          ZJN    O8D400      IF NO MORE L/A PAIRS
          UJN    O8D50       CONTINUE TO OUTPUT

*         PROCESS TRANSFER TO BURST BOUNDARY
 O8D200   LDN    0           CLEAR PARTIAL L/A PAIR FLAG
          STML   /TS/P.PARLAP,CTST
          LDDL   T1          GET REQUESTED BYTE COUNT THIS PAIR
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNNEL WORD COUNT
          LDDL   BURSTSZ     INCREMENT CURRENT BURST BYTE COUNT
          STML   /TS/P.CBURBC,CTST
          RJM    OUTPUT      OUTPUT THE DATA
          UJN    O8D400      PROCESS END OF BURST

*         PROCESS TRANSFER OF GREATER THAN BURST BOUNDARY
 O8D300   LDDL   BURSTSZ     COMPUTE BYTE COUNT TO BURST BOUNDARY
          SBML   /TS/P.CBURBC,CTST  DECREMENT BY BYTES TRANSFERED ALREADY
          STML   /TS/P.PARLAP,CTST  SET PARTIAL L/A PAIR FLAG
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNEL WORD COUNT
          LDDL   BURSTSZ
          STML   /TS/P.CBURBC,CTST  SET CURRENT BURST BYTE COUNT
          RJM    OUTPUT      OUTPUT THE DATA

*         PROCESS END OF BURST
 O8D400   RJM    WSID        WAIT FOR SLAVE IN TO DROP
          LDML   /TS/P.CBURBC,CTST  CHECK FOR ODD/EVEN TRANSFER
          LPN    1
          ZJN    O8D420      IF EVEN, USE EVEN OCTET MASTER ENDING STATUS
          LDN    ODDOT       ELSE USE ODD OCTET STATUS
 O8D420   RJM    GES         GET ENDING STATUS
          LDDL   STATUS      SAVE SLAVE ENCODED ENDING STATUS
          STML   /TS/P.SLVEES,CTST
          RJM    URECTC      UPDATE RECORD TRANSFER COUNT
          NJN    O8D460      IF PARTIAL RECORD, REPORT ERROR
          LDML   /TS/P.SLVEES,CTST  CHECK FOR END OF RECORD
          LPN    60B         MASK PAUSE AND TDO BITS
          SBN    20B
          ZJN    O8D500      IF END OF RECORD
          RJM    GETNP       GET NEXT L/A PAIR
          ZJN    O8D460      IF NO PAIRS LEFT, REPORT ERROR
          LDML   /TS/P.SLVEES,CTST  CHECK FOR SLAVE PAUSE
          LPN    60B         MASK PAUSE AND TDO BITS
          ZJK    O8D40       IF NO PAUSE
          RJM    DCM         DESELECT SLAVE

 O8D440   RJM    WSTN        WAIT FOR SPECIAL TRANSFER NOTIFICATION
          ZJK    O8D30       IF NEXT BURST IS READY
          UJK    O8D10       ELSE PROCESS OTHER INTERRUPT

 O8D460   LDK    E505        INVALID LENGTH SPECIFICATION
          RJM    SWFAIL      REPORT ERROR (NO RETURN)
          SPACE  2
*         PROCESS END OF RECORD
 O8D500   RJM    DCM         DESELECT SLAVE
          LDML   /TS/P.RTCIP,CTST  INCREMENT RECORD XFER COUNT IN POINTER
          ADN    2
          LPN    7
          STML   /TS/P.RTCIP,CTST
          LDN    2           SEND 2 MORE WRITE COMMANDS IF ANY LEFT
          RJM    GWRT
          UJK    O8D10       WAIT FOR INTERRUPT
          SPACE  2
*         PROCESS COMMAND COMPLETION
 O8D600   AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          SOML   /TS/P.NSWC,CTST  DECREMENT NON-STOP WRITE COUNTER
          RJM    UREQTC      UPDATE REQUEST TRANSFER COUNTS
          LDML   RPB+MAJST   GET MAJOR STATUS
          LMN    CCS         CHECK FOR SUCCESSFUL
          NJN    O8D610      IF NOT
          LDML   /TS/P.CRN,CTST  CHECK THE CRN
          LMML   RPB+CRN
          NJN    O8D620      IF MISCOMPARE
          RJM    GBID        GET AND STORE BLOCK ID
          LJM    CMDCOMP     COMMAND COMPLETE

 O8D610   LDN    1           EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE (NO RETURN)

 O8D620   LDK    E76         REPORT UNEXPECTED RESPONSE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE (NO RETURN)
          EJECT
** NAME - READ
*
** PURPOSE - PROCESS LOGICAL READ RECORD COMMAND.
*            (LOGICIAL COMMAND 41)
*
** INPUT - THE SECONDARY ADDRESS FIELD OF THE REQUEST HEADER MUST HAVE A
*          MAXIMUM BYTE COUNT IN THE LEAST SIGNIFICANT 32 BITS. THIS
*          BYTE COUNT IS USED FOR THE IPI READ COMMAND EXTENT PARAMETER.
          SPACE  2
 READ     BSS                ENTRY

          LDML   /TS/P.NSRC,CTST  CHECK IF FIRST READ COMMAND
          NJK    READ40      IF NOT
          SPACE  2
*         SEND ALL READ COMMANDS TO SLAVE
          LDML   /TS/P.CRN,CTST  GET COMMAND REFERENCE NUMBER
          STML   /TS/P.NSCRN,CTST  SET NON-STOP COMMAND REFERENCE NUMBER
          ADN    1           INCREMENT IT
          STML   READCP1     SAVE IT
          LDML   /TS/P.SN,CTST  GET ADDRESSEE
          STML   READCP5
          LDML   /TS/P.RQB+/RQ/P.SECADR+2,CTST  GET MAX. BYTE COUNT
          STML   READCP9     SET IN READ COMMAND PACKET
          LDML   /TS/P.RQB+/RQ/P.SECADR+3,CTST
          STML   READCPB
          ADML   READCP9     CHECK IF NON ZERO BYTE COUNT
          NJN    READ10      IF OK
          LDK    E505        INVALID LENGTH SPECIFICATION
          RJM    SWFAIL      REPORT SOFTWARE FAILURE (NO RETURN)

 READ10   LDML   /TS/P.NUMCM,CTST  GET NUMBER OF COMMANDS LEFT
          ADN    1           ADJUST FOR THIS COMMAND
          STDL   P5          SAVE IT
          LDML   /TS/P.LASTC,CTST  BUILD PP COMMAND ADDRESS
          SHN    -1
          ADDL   CTST
          ADK    /TS/P.CQB
          STDL   P6          SAVE IT
          STML   /TS/P.NSCA,CTST  SAVE FIRST NON-STOP COMMAND ADDRESS
          UJN    READ30

 READ20   LDN    8           INCREMENT PP ADDRESS TO NEXT COMMAND
          RADL   P6
          LDIL   P6          GET NEXT COMMAND
          SHN    -8          POSITION COMMAND CODE
          ADK    -LCREAD     CHECK FOR LOGICIAL READ
          NJN    READ40      IF NOT

 READ30   LDC    READCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
          AOML   /TS/P.NSRC,CTST  INCREMENT NON-STOP READ COUNTER
          LDDL   P5          DECREMENT COMMANDS LEFT COUNTER
          SBN    2
          STDL   P5
          ZJN    READ40      IF DONE
          AOML   READCP1     INCREMENT COMMAND REFERENCE NUMBER
          UJN    READ20      LOOP
          SPACE  4
*         PROCESS IPI INTERRUPTS
 READ40   LDML   /TS/P.WSTNF,CTST  CHECK WSTN FLAG
          NJK    READ440     IF SET, CONTINUE CURRENT RECORD

 READ50   LDK    100         SECS LIMIT (PARTIAL READ OF MAX 32K PE REC)
          RJM    IH          INTERRUPT HANDLER
          SHN    -4          POSITION RESPONSE TYPE
          LPN    0#F         MASK IT
          SBN    1           CHECK FOR COMMAND COMPLETION
          ZJK    READ600     IF YES
          SBN    4           CHECK FOR TRANSFER NOTIFICATION
          ZJN    READ60      IF YES
          LDN    0           ELSE MUST BE ASYNCHRONUS RESPONSE
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    READ40      LOOP
          SPACE  2
*         INITIALIZE DATA TRANSFER
 READ60   LDML   /TS/P.WSTNF,CTST  CHECK WSTN FLAG
          ZJN    READ65      IF NOT SET, START NEW RECORD
          LDN    0           CLEAR WSTN FLAG
          STML   /TS/P.WSTNF,CTST
          UJN    READ70      CONTINUE CURRENT RECORD

 READ65   RJM    NSI         NON-STOP INITIALIZATION
          LDML   /TS/P.NSCRN,CTST  COMPARE COMMAND REFERENCE NUMBERS
          LMML   RPB+CRN
          ZJN    READ70      IF OK
          LDK    E76         REPORT UNEXPECTED RESPONSE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE (NO RETURN)
          SPACE  2
*         START DATA TRANSFER
 READ70   RJM    SEL         SELECT SLAVE

 READ80   LDN    DATAIN      BUS A DATA IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0A81       STREAM, READ AND DMA(I0)
          RJM    FUNC
          ACN    DC          ACTIVATE CHANNEL
          LDN    0           CLEAR CURRENT BURST BYTE COUNT
          STML   /TS/P.CBURBC,CTST

*         DETERMINE BURST CHARACTERISTICS
 READ90   LDML   /TS/P.ILSTP+1,CTST  GET REQUESTED BYTE COUNT THIS PAIR
          STDL   T1          SAVE IT
          ADML   /TS/P.CBURBC,CTST  ADD CURRENT BURST BYTE COUNT
          SBDL   BURSTSZ     SUBTRACT SLAVE BURST SIZE
          ZJN    READ200     IF TRANSFER IS TO BURST BOUNDARY
          PJN    READ300     IF TRANSFER IS GREATER THAN BURST BOUNDARY

*         PROCESS TRANSFER OF LESS THAN BURST BOUNDARY
 READ100  LDN    0           CLEAR PARTIAL L/A PAIR FLAG
          STML   /TS/P.PARLAP,CTST
          LDDL   T1          GET REQUESTED BYTE COUNT THIS PAIR
          ADN    1           ROUND UP (IF LAST PAIR HAS ODD BYTE COUNT)
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNEL WORD COUNT
          SHN    1           INCREMENT CURRENT BURST BYTE COUNT
          RAML   /TS/P.CBURBC,CTST
          RJM    INPUT       INPUT THE DATA
          NJN    READ400     IF PARTIAL RECORD
          RJM    GETNP       GET NEXT L/A PAIR
          ZJN    READ400     IF NO MORE L/A PAIRS
          UJN    READ90      CONTINUE TO INPUT

*         PROCESS TRANSFER TO BURST BOUNDARY
 READ200  LDN    0           CLEAR PARTIAL L/A PAIR FLAG
          STML   /TS/P.PARLAP,CTST
          LDDL   T1          GET REQUESTED BYTE COUNT THIS PAIR
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNNEL WORD COUNT
          LDDL   BURSTSZ     INCREMENT CURRENT BURST BYTE COUNT
          STML   /TS/P.CBURBC,CTST
          RJM    INPUT       INPUT THE DATA
          UJN    READ400     PROCESS END OF BURST

*         PROCESS TRANSFER OF GREATER THAN BURST BOUNDARY
 READ300  LDDL   BURSTSZ     COMPUTE BYTE COUNT TO BURST BOUNDARY
          SBML   /TS/P.CBURBC,CTST  DECREMENT BY BYTES TRANSFERED ALREADY
          STML   /TS/P.PARLAP,CTST  SET PARTIAL L/A PAIR FLAG
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNEL WORD COUNT
          LDDL   BURSTSZ
          STML   /TS/P.CBURBC,CTST  SET CURRENT BURST BYTE COUNT
          RJM    INPUT       INPUT THE DATA

*         PROCESS END OF BURST
 READ400  RJM    WSID        WAIT FOR SLAVE IN TO DROP
          LDN    0           MASTER ENCODED ENDING STATUS
          RJM    GES         GET ENDING STATUS
          LDDL   STATUS      SAVE SLAVE ENCODED ENDING STATUS
          STML   /TS/P.SLVEES,CTST
          RJM    URECTC      UPDATE RECORD TRANSFER COUNT
          LDML   /TS/P.SLVEES,CTST  CHECK FOR END OF RECORD
          LPN    60B         MASK PAUSE AND TDO BITS
          SBN    20B
          ZJN    READ500     IF END OF RECORD
          RJM    GETNP       GET NEXT L/A PAIR
          ZJN    READ460     IF NO PAIRS LEFT, REPORT ERROR
          LDML   /TS/P.SLVEES,CTST  CHECK FOR SLAVE PAUSE
          LPN    60B         MASK PAUSE AND TDO BITS
          ZJK    READ80      IF NO PAUSE
          RJM    DCM         DESELECT SLAVE

 READ440  RJM    WSTN        WAIT FOR SPECIAL TRANSFER NOTIFICATION
          ZJK    READ70      IF NEXT BURST IS READY
          UJK    READ50      PROCESS OTHER INTERRUPT

 READ460  LDK    E505        INVALID LENGTH SPECIFICATION
          RJM    SWFAIL      REPORT ERROR (NO RETURN)
          SPACE  2
*         PROCESS END OF RECORD
 READ500  RJM    DCM         DESELECT SLAVE
          LDML   /TS/P.RTCIP,CTST  INCREMENT RECORD XFER COUNT IN POINTER
          ADN    2
          LPN    7
          STML   /TS/P.RTCIP,CTST
          UJK    READ50      WAIT FOR INTERRUPT
          SPACE  2
*         PROCESS COMMAND COMPLETION
 READ600  AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          SOML   /TS/P.NSRC,CTST  DECREMENT NON-STOP READ COUNTER
          RJM    UREQTC      UPDATE REQUEST TRANSFER COUNTS
          LDML   RPB+MAJST   GET MAJOR STATUS
          LMN    CCS         CHECK FOR SUCCESSFUL
          NJN    READ610     IF NOT
          LDML   /TS/P.CRN,CTST  CHECK THE CRN
          LMML   RPB+CRN
          NJN    READ620     IF MISCOMPARE
          RJM    GBID        GET AND STORE BLOCK ID
          LJM    CMDCOMP     COMMAND COMPLETE

 READ610  LDN    3           EXPECT BLOCK ID OR TAPE MARK
          RJM    CMDRESP     COMMAND RESPONSE DECODE (NO RETURN)

 READ620  LDK    E76         REPORT UNEXPECTED RESPONSE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE (NO RETURN)
          SPACE  4
*         -READ-  COMMAND PACKET
 READCP   DATA   0#000C      PACKET LENGTH
 READCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCREAD+CMCHN+OMRF  OP-CODE, CHAIN AND READ FORWARD
 READCP5  DATA   0#FFFF      ADDRESSEE
          CON    CPSCE       SPECIAL COMMAND EXTENT PARAMETER
 READCP9  DATA   0#FFFF        COUNT FIELD UPPER
 READCPB  DATA   0#FFFF        COUNT FIELD LOWER
          EJECT
** NAME - WRITE
*
** PURPOSE - TO PROCESS LOGICIAL WRITE COMMAND.
*            (LOGICIAL COMMAND 51 MODIFIED)
*
** NOTE-- THE ACTUAL DATA TRANSFER WILL BE DONE IN THE
*         OUTPUT 8-BIT DATA LOGICIAL COMMAND 23.
          SPACE  2
 WRITE    BSS                ENTRY

          LDML   /TS/P.NSWC,CTST  CHECK IF FIRST WRITE COMMAND
          NJN    WRITE10     IF NOT

*         INITIALIZE FIRST GROUP OF NON_STOP WRITE COMMANDS
          LDML   /TS/P.CRN,CTST  GET COMMAND REFERENCE NUMBER
          STML   /TS/P.NSCRN,CTST  SET FIRST-1 NON-STOP CRN
          STML   /TS/P.GNSCRN,CTST  SET WORKING GROUP NON-STOP CRN
          LDML   /TS/P.NUMCM,CTST  GET NUMBER OF COMMANDS LEFT
          ADN    1           ADJUST FOR THIS COMMAND
          STML   /TS/P.GNUMCM,CTST  SAVE AS GROUP NUMBER OF CMDS LEFT
          LDML   /TS/P.LASTC,CTST  BUILD PP COMMAND ADDRESS
          SHN    -1
          ADDL   CTST
          ADK    /TS/P.CQB
          STML   /TS/P.GNSCA,CTST  SAVE AS GROUP NON-STOP PP ADDRESS
          ADN    4           SET FIRST NON-STOP COMMAND ADDRESS
          STML   /TS/P.NSCA,CTST
          LDN    4           SEND 4 WRITE COMMANDS IN FIRST GROUP
          RJM    GWRT        GO SEND THE GROUP
 WRITE10  LJM    CMDCOMP     EXIT
          SPACE  4
 GWRT     SUBR               ENTRY/EXIT
          STDL   P5          SET LOOP COUNTER FROM A
*         INITIALIZE THIS GROUP OF NON-STOP WRITE COMMANDS
 GWRT10   LDML   /TS/P.GNUMCM,CTST  CHECK IF ALL DONE
          ZJN    GWRTX       IF YES
          LDML   /TS/P.GNSCA,CTST  GET PP CMD ADDRESS
          STDL   P6          SET WORKING ADDRESS
          LDIL   P6          GET THE COMMAND
          SHN    -8          POSITION COMMAND CODE
          ADC    -LCWRITE    CHECK FOR LOGICIAL WRITE COMMAND
          NJN    GWRTX       IF NOT
          LDML   /TS/P.SN,CTST  GET ADDRESSEE
          STML   WRTCP5      PUT INTO IPI COMMAND PACKET
          RJM    SEL         SELECT THE SLAVE

*         SEND THIS GROUP OF NON-STOP WRITE COMMANDS
 GWRT20   LDN    2           INCREMENT PP ADDRESS TO BYTE COUNT UPPER
          RADL   P6
          LDIL   P6          GET BYTE COUNT UPPER
          STML   WRTCP9      SET IT
          AODL   P6          INCREMENT PP ADDRESS TO BYTE COUNT LOWER
          LDIL   P6          GET BYTE COUNT LOWER
          STML   WRTCPB      SET IT
          AOML   /TS/P.GNSCRN,CTST  INCREMENT GROUP NON-STOP CRN
          STML   WRTCP1      SET IT
          LDC    WRTCP+BYPSD  COMMAND PACKET FWA PLUS BYPASS PARAMETER
          RJM    CPT         COMMAND PACKET TRANSFER
          LDN    5           INCREMENT PP ADDRESS TO NEXT WRITE COMMAND
          RADL   P6
          AOML   /TS/P.NSWC,CTST  INCREMENT NON-STOP WRITE COUNTER
          LCN    2           DECREMENT GROUP NUMBER OF CMDS LEFT
          RAML   /TS/P.GNUMCM,CTST
          ZJN    GWRT30      IF DONE
          SODL   P5          DECREMENT LOOP COUNTER
          ZJN    GWRT30      IF DONE
          LDIL   P6          GET NEXT COMMAND
          SHN    -8          POSITION COMMAND CODE
          ADC    -LCWRITE    CHECK FOR LOGICIAL WRITE
          ZJN    GWRT20      IF YES

 GWRT30   RJM    DCM         DESELECT SLAVE
          LDDL   P6          SAVE WORKING PP CMD ADDRESS
          STML   /TS/P.GNSCA,CTST
          UJK    GWRTX       EXIT
          SPACE  4
*         -WRITE-  COMMAND PACKET
 WRTCP    DATA   0#000C      PACKET LENGTH
 WRTCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCWRITE+CMCHN  OP-CODE AND CHAIN
 WRTCP5   DATA   0#FFFF      ADDRESSEE
          CON    CPCE        COMMAND EXTENT PARAMETER
 WRTCP9   DATA   0#FFFF        COUNT (UPPER)
 WRTCPB   DATA   0#FFFF        COUNT (LOWER)
          EJECT
** NAME - STRTC
*
** PURPOSE - TO PERFORM THE LOGICAL COMMAND STORE TRANSFER COUNT.
*            (LOGICIAL COMMAND 61)
          SPACE  2
 STRTC    BSS                ENTRY
          LDN    0           INITIALIZE DIRECT CELLS
          STDL   T1
          STDL   T2
          LDML   /TS/P.XFER,CTST  GET TRANSFER COUNT
          STDL   T3          MOVE TO DIRECT CELLS
          LDML   /TS/P.XFER+1,CTST
          STDL   T4
          LOADF  /TS/P.CURCMD+2,CTST  LOAD R+A FROM COMMAND
          CWDL   T1          STORE TRANSFER COUNT
          LDN    0           CLEAR TRANSFER COUNTERS
          STML   /TS/P.XFER,CTST
          STML   /TS/P.XFER+1,CTST
          LJM    NOSTAT      COMMAND COMPLETE, NO STATUS TO CHECK
          TITLE  COMMAND SUBROUTINES
** NAME - PFORM
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF FORMAT UNIT
*            (FUNCTION CODE 004)
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
*
*          FORMAT FUNCTION PARAMETERS (LIKE ATS) ARE LOCATED IN THE
*          SECONDARY ADDRESS FIELD OF THE PERIPHERAL REQUEST.
          SPACE  2
 PFORM    BSS                ENTRY
          LDDL   CLF         CHECK IF CHANNEL IS ALREADY LOCKED
          ZJN    PFORM10     IF YES
          RJM    SCLOCK      LOCK CHANNEL LOCKWORD IN CHANNEL TABLE
 PFORM10  BSS
          RJM    SLVTST      CHECK FOR SLAVE TESTING REQUIRED
          LDML   SLB+/SL/P.SLVTST,SX  CHECK IF ATTRIBUTES REQUIRED
          ZJN    PFORM20     IF NOT
          LDN    1           ENABLE ERROR CORRECTION
          STML   /TS/P.ECSEL,CTST  SAVE SELECTION
          RJM    ATTRIB      SET ATTRIBUTES
          LDN    0
 PFORM20  BSS
          STML   /TS/P.FACSTA,CTST  CLEAR SPECIAL STATUS
          RJM    GFS         GET FACILITY STATUS TO CHECK FOR BUSY
          LDML   /TS/P.FACSTA+1,CTST  CHECK IF AT BOT
          SHN    17-15
          MJN    PFORM30     IF YES THEN DO DENSITY SELECTION
          LDML   SLB+/SL/P.SLVTST,SX  CHECK IF ATTRIBUTES WERE REQUIRED
          ZJN    PFORM60     IF NOT THEN BYPASS DENSITY SELECTION
 PFORM30  BSS
*         GET PARAMETER WORD 2 BIT 8  (DEFINE DENSITY SELECTION)
          LDML   /TS/P.RQB+/RQ/P.SECADR,CTST
          LPN    1           MASK DEFINE BIT
          ZJN    PFORM40     IF NOT SET USE DEFAULT DENSITY
*         GET PARAMETER WORD 2 BITS 7-6  (DENSITY SELECTION)
          LDML   /TS/P.RQB+/RQ/P.SECADR+1,CTST
          SHN    3           POSITION DENSITY SELECT BITS
          MJN    PFORM40     IF 6250 (GCR) SELECTED
          LDN    1           ELSE USE 1600 (PE) DENSITY
          UJN    PFORM50
 PFORM40  BSS
          LDN    2           USE 6250
 PFORM50  BSS
          STML   /TS/P.DENSEL,CTST  SAVE SELECTION
          RJM    OPMODE      SELECT DENSITY
 PFORM60  BSS
          LDN    0           CLEAR SPECIAL STATUS
          STML   /TS/P.FACSTA,CTST
          STML   SLB+/SL/P.SLVTST,SX  CLEAR TESTING/ATTRIBUTES REQUIRED
          RJM    FACTST      CHECK FOR FACILITY TESTING
          UJK    CMDCOMP     COMMAND COMPLETE
          EJECT
** NAME - PREW
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF REWIND/UNLOAD
*            (FUNCTION CODE X10)
*             X = 0 10 REWIND
*             X = 1 10 UNLOAD
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PREW     BSS                ENTRY
          RJM    RFEL        READ FACILITY ERROR LOG
          RJM    GFS         GET FACILITY STATUS ID52
          LDML   /TS/P.CURCMD+3,CTST  GET PHYSICAL FUNCTION CODE
          SHN    17-6
          MJK    PUNL        IF 110 UNLOAD
          AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          STML   PREWCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PREWCP5
          LDC    PREWCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PREW10   LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PREW20      IF NOT
          RJM    RSEL        READ SLAVE ERROR LOG
          LDN    0           CLEAR RESPONSE PACKET LENGTH
          STML   RPB
          LJM    CMDCOMP     COMMAND COMPLETE
 PREW20   LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PREW10      IF ASYNC RESPONSE
          SPACE  4
*         -POSITION CONTROL-  COMMAND PACKET
 PREWCP   DATA   0#0009      PACKET LENGTH
 PREWCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCPOSC      OP-CODE AND END OF CHAIN
 PREWCP5  DATA   0#FFFF      ADDRESSEE
          CON    CPTP        TAPE POSITION PARAMETER
          DATA   0#0800        REWIND
          EJECT
** NAME - PUNL
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF 110 UNLOAD
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PUNL     BSS                ENTRY
          AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          STML   PUNLCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PUNLCP5
          LDC    PUNLCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PUNL10   LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PUNL20      IF NOT
          RJM    RSEL        READ SLAVE ERROR LOG
          LDN    0           CLEAR RESPONSE PACKET LENGTH
          STML   RPB
          LJM    CMDCOMP     COMMAND COMPLETE
 PUNL20   LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PUNL10      IF ASYNC RESPONSE
          SPACE  4
*         -POSITION CONTROL-  COMMAND PACKET
 PUNLCP   DATA   0#0009      PACKET LENGTH
 PUNLCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCPOSC      OP-CODE AND END OF CHAIN
 PUNLCP5  DATA   0#FFFF      ADDRESSEE
          CON    CPTP        TAPE POSITION PARAMETER
          DATA   0#2000        UNLOAD
          EJECT
** NAME - PSPB
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF SPACE BLOCK FWD/REV
*            (FUNCTION CODE X13)
*             X = 0 13 SPACE BLOCK FORWARD
*             X = 1 13 SPACE BLOCK BACKWARD
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PSPB     BSS                ENTRY
          AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          STML   PSPBCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PSPBCP5
          LDML   /TS/P.CURCMD+3,CTST  GET PHYSICAL FUNCTION CODE
          SHN    17-6
          PJN    PSPB10      IF 013 (FORWARD) FUNCTION
          LDC    OCREADV+CMCHN+OMRVR  ELSE 113 (REVERSE)
          UJN    PSPB20      CONT.
 PSPB10   LDC    OCREADV+CMCHN+OMRVF
 PSPB20   STML   PSPBCP3     STORE OP-CODE
          LDC    PSPBCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PSPB30   LDK    150         SECONDS LIMIT (FULL LENGTH TAPE RECORD)
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PSPB40      IF NOT SUCCESSFUL
          RJM    GBID        GET BLOCK ID AND STORE INTO BID TABLE
          LJM    CMDCOMP     GOTO COMMAND COMPLETE
 PSPB40   LDN    3           EXPECT BLOCK ID OR END OF EXTENT (TAPE MARK)
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PSPB30      IF ASYNC RESPONSE
          SPACE  4
*         -READ VERIFY-  COMMAND PACKET
 PSPBCP   DATA   0#0006      PACKET LENGTH
 PSPBCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
 PSPBCP3  CON    OCREADV+CMCHN+OMRVF   OP-CODE AND CHAIN
 PSPBCP5  DATA   0#FFFF      ADDRESSEE
          EJECT
** NAME - PSTM
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF SEARCH TAPE MARK FWD/REV
*            (FUNCTION CODE X15)
*             X = 015 SEARCH TAPE MARK FORWARD
*             X = 115 SEARCH TAPE MARK BACKWARD
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PSTM     BSS                ENTRY
          AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          STML   PSTMCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PSTMCP5
          LDML   /TS/P.CURCMD+3,CTST  GET PHYSICAL FUNCTION CODE
          SHN    17-6
          PJN    PSTM10      IF 015 (FORWARD) FUNCTION
          LDC    OCSPACE+CMCHN+OMSFR  ELSE 115 (BACKWARD)
          UJN    PSTM20      CONT.
 PSTM10   LDC    OCSPACE+CMCHN+OMSFF  OP-CODE FWD AND CHAIN
 PSTM20   STML   PSTMCP3     STORE OP-CODE
          LDC    PSTMCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PSTM30   LDK    150         SECONDS LIMIT (FULL LENGTH TAPE)
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PSTM40      IF NOT
          RJM    TMBID       STORE TAPE MARK BLOCK ID
          LDK    /RS/K.LDLIM  SET LOGICIAL DELIMITER STATUS CONDITION
          STML   /TS/P.SCOND,CTST
          LJM    CMDCOMP     GOTO COMMAND COMPLETE
 PSTM40   LDN    2           EXPECT END OF EXTENT (TAPE MARK)
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PSTM30      IF ASYNC RESPONSE
          SPACE  4
*         -SPACE FILE MARK-  COMMAND PACKET
 PSTMCP   DATA   0#0006      PACKET LENGTH
 PSTMCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
 PSTMCP3  CON    OCSPACE+CMCHN+OMSFF  OP-CODE AND CHAIN
 PSTMCP5  DATA   0#FFFF      ADDRESSEE
          EJECT
** NAME - PWTM
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF WRITE TAPE MARK
*            (FUNCTION CODE 051)
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PWTM     BSS                ENTRY
          AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          STML   PWTMCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PWTMCP5
          LDC    PWTMCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PWTM10   LDN    10          SECONDS LIMIT (INCLUDES ID RECOVERY)
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PWTM20      IF NOT
          RJM    TMBID       STORE TAPE MARK BLOCK ID
          LDK    /RS/K.LDLIM  SET LOGICIAL DELIMITER STATUS CONDITION
          STML   /TS/P.SCOND,CTST
          LJM    CMDCOMP     GOTO COMMAND COMPLETE
 PWTM20   LDN    2           EXPECT END OF EXTENT (TAPE MARK)
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PWTM10      IF ASYNC RESPONSE
          SPACE  4
*         -RECORD POSITION-  COMMAND PACKET
 PWTMCP   DATA   0#0009      PACKET LENGTH
 PWTMCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCRECP      OP-CODE, NO CHAIN
 PWTMCP5  DATA   0#FFFF      ADDRESSEE
          CON    CPTM        TAPE MARK PARAMETER
          DATA   0#8000        FILE MARK
          EJECT
** NAME - PERS
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF ERASE TAPE
*            (FUNCTION CODE X52)
*             X = 052 - ERASE GAP
*             X = 252 - DATA SECURITY ERASE
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PERS     BSS                ENTRY
          LDML   /TS/P.CURCMD+3,CTST  GET PHYSICAL FUNCTION CODE
          SHN    17-7
          MJK    PDSE        IF 252 DATA SECURITY ERASE FUNCTION
          AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          STML   PERSCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PERSCP5
          LDC    PERSCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PERS10   LDN    10          SECONDS LIMIT (INCLUDES ID RECOVERY)
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          ZJK    CMDCOMP     IF YES, GOTO COMMAND COMPLETE
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PERS10      IF ASYNC RESPONSE
          SPACE  4
*         -ERASE-  COMMAND PACKET
 PERSCP   DATA   0#0006      PACKET LENGTH
 PERSCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCERASE+OMGAP  OP-CODE, NO CHAIN AND GAP ERASE
 PERSCP5  DATA   0#FFFF      ADDRESSEE
          EJECT
** NAME - PDSE
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF DATA SECURITY ERASE
*            (FUNCTION CODE 252)
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PDSE     BSS                ENTRY
          RJM    GFS         GET FACILITY STATUS ID52
          AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          STML   PDSECP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PDSECP5
          LDC    PDSECP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PDSE10   LDN    10          SECONDS LIMIT (INCLUDES ID RECOVERY)
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PDSE20      IF NOT
          LDN    0           CLEAR IPI RESPONSE LENGTH
          STML   RPB
          LJM    CMDCOMP     COMMAND COMPLETE
 PDSE20   LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PDSE10      IF ASYNC RESPONSE
          SPACE  4
*         -ERASE-  COMMAND PACKET
 PDSECP   DATA   0#0006      PACKET LENGTH
 PDSECP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCERASE+OMDSE  OP-CODE, NO CHAIN AND DSE
 PDSECP5  DATA   0#FFFF      ADDRESSEE
          TITLE  SUPPORT SUBROUTINES
** NAME-- SCANT
*
** PURPOSE-- SCAN TS TABLES
*
** EXIT-- A =  0 NEXT TS TABLE NOT IN USE
*         A = NZ NEXT TS TABLE IN USE
          SPACE  2
 SCANT    SUBR               ENTRY/EXIT
          RJM    SNXTAB      SELECT NEXT SLAVE TS TABLE
          LPDL   TIU         MASK WITH TS TABLES IN USE
          UJN    SCANTX      EXIT
          SPACE  5,20
** NAME-- SNXTAB
*
** PURPOSE-- SELECT NEXT SLAVE TS TABLE
*
** ENTRY-- CTST = CURRENT TS TABLE IN USE
*
** EXIT-- A = NEXT TS TABLE BIT ADDRESS
*         CTST = NEXT TS TABLE INDEX
          SPACE  2
 SNXTAB   SUBR               ENTRY/EXIT
          LDDL   CTST        GET CURRENT TS TABLE IN USE
          SBML   TS1         CHECK IF TS1 IN USE
          ZJN    SNXTAB2     IF TS2 IS NEXT
          ADK    -P.TS       CHECK IF TS2 IN USE
          ZJN    SNXTAB3     IF TS3 IS NEXT
*                            ELSE TS2 IS NEXT

 SNXTAB2  LDN    1           USE TS2 NEXT
          UJN    SNXTAB9     CONT.

 SNXTAB3  LDN    2           USE TS3 NEXT

 SNXTAB9  STDL   T1          SAVE INDEX INTO NEXT TS TABLE TO USE
          LDML   TS1,T1      GET NEXT TS TABLE ADDRESS
          STDL   CTST
          LDML   SELT,T1     USE SLAVE BIT ADDRESS TABLE
          UJN    SNXTABX     EXIT
          SPACE  2
          ERRNZ  2-MCSLV     IF NUMBER OF SLAVE TS TABLES CHANGES
          SPACE  5,20
** NAME-- SCANAS
*
** PURPOSE-- SCAN ALL SLAVES FOR A NEW LOCKABLE REQUEST
*
** EXIT-- A =  0 NO NEW REQUESTS
*         A = NZ NEW REQUEST FOUND, UNIT AND UIT REQUEST QUEUE LOCKED
*
** NOTE-- NREQSN = SLAVE NUMBER THAT HAS REQUEST ACTIVE
*         NREQFN = FACILITY NUMBER THAT HAS REQUEST ACTIVE
          SPACE  2
 SCANAS   SUBR               ENTRY/EXIT
          LDDL   SLVN        START SEARCH FROM LAST SLAVE USED
          LPN    SLVPCH-1    MASK IT
          STML   NREQSN
          LDDL   FACN        START SEARCH FROM LAST FACILITY+1
          ADN    1
          LPN    FACPSL-1    MASK IT
          STML   NREQFN
          LDN    SLVPCH      LOOP COUNT
          STDL   P1

 SCANAS5  LDN    0           DISABLE SCANING SLAVE IF FACILITY LOCKED
          RJM    SCANS       SCAN ALL FACILITITES ON THE SLAVE
          NJN    SCANASX     FOUND ONE, EXIT A=NZ

          SODL   P1          CHECK FOR DONE
          ZJN    SCANASX     IF YES, EXIT A=0

          AOML   NREQSN      INCREMENT TO NEXT SLAVE
          LPN    SLVPCH-1    MASK IT
          STML   NREQSN

          LDN    0           START FROM FIRST FACILITY THIS TIME
          STML   NREQFN

          UJN    SCANAS5     SCAN NEXT SLAVE
          SPACE  2
          ERRNZ  8-FACPSL    IF FACILITIES PER SLAVE CHANGES
          ERRNZ  8-SLVPCH    IF SLAVES PER CHANNEL CHANGES
          SPACE  5,20
** NAME-- SCANS
*
** PURPOSE-- SCAN ALL FACILITIES ON A SLAVE FOR A ACTIVE REQUEST
*
** ENTRY--A =  0 DO NOT SCAN A SLAVE THAT HAS A FACILITY LOCKED
*         A = NZ SCAN A SLAVE THAT HAS A FACILITY LOCKED
*
** EXIT-- A =  0 NO NEW REQUESTS
*         A = NZ NEW REQUEST FOUND, UNIT AND UIT REQUEST QUEUE LOCKED
*
** USES-- T1-T6, P2-P5
*
** NOTE-- NREQSN = SLAVE NUMBER THAT HAS REQUEST ACTIVE
*         NREQFN = FACILITY NUMBER THAT HAS REQUEST ACTIVE
          SPACE  2
 SCANS0   LDN    0           EXIT, NO NEW REQUEST

 SCANS    SUBR               ENTRY/EXIT
          STML   SCANSA      SAVE ENTRY PARAMETER
          LDML   NREQSN      GET SLAVE NUMBER TO SEARCH
          SHN    2           BUILD SLAVE TABLE INDEX
          STDL   P3          P3 = SX INDEX
          LDML   SLB+/SL/P.FBA,P3  CHECK FOR ANY FACILITIES CONFIGURED
          ZJN    SCANSX      IF NONE,  EXIT A=0
          LDML   SCANSA      CHECK IF SCAN IS ENABLED FOR LOCKED FACILITY
          NJN    SCANS5      IF YES, CONTINUE
          LDML   SLB+/SL/P.FACLCK,P3  CHECK IF A FACILITY IS LOCKED
          SHN    -6
          NJN    SCANS0      IF YES, DO NOT SCAN THIS SLAVE

 SCANS5   LDDL   UX          SAVE THE ORIGINAL UX
          STDL   P5          P5 = ORIGINAL UX
          LDN    FACPSL
          STDL   P2          P2 = LOOP COUNT

 SCANS10  LDDL   P3          BUILD UNITS TABLE INDEX
          SHN    3
          STDL   P4
          LDML   NREQFN
          SHN    2
          RADL   P4          P4 = UX INDEX
          LDML   UNITS+/UN/P.LU,P4  CHECK IF FACILITY IS CONFIGURED
          ZJK    SCANS60     IF NOT
          LOADR  UNITS+/UN/P.UIT,P4  LOAD REFORMATTED R+A OF UIT
          ERRNZ  /UIT/C.DSABLE
          CRDL   T1          READ UNIT STATUS INTO T2
          ADN    /UIT/C.NEXT  OFFSET TO NEXT REQUEST RMA
          CRDL   T3          READ NEXT REQUEST RMA WORD
          LDDL   T2          CHECK IF UNIT IS DISABLED
          ERRNZ  /UIT/P.DSABLE-1
          SHN    18-16+/UIT/L.DSABLE
          MJK    SCANS60     IF UNIT IS DISABLED
          LDDL   T5          CHECK HALF 1 OF REQUEST RMA
          ADDL   T6          AND HALF 2 OF REQUEST RMA
          ZJK    SCANS60     IF NO REQUEST
          LDML   SLB+/SL/P.FACLCK,P3  CHECK IF SLAVE HAS A FACILITY LOCKED
          SHN    -6
          ZJN    SCANS20     IF NONE
          LDML   SLB+/SL/P.CURFAC,P3  CHECK IF SAME FACILITY AS SCANED
          LPN    17B
          SBML   NREQFN
          ZJK    SCANS60     IF YES

*         TRY TO LOCK UNIT AND REQUEST QUEUE THEN VERIFY ACTIVE REQUEST
 SCANS20  LDDL   P4          SET UX = P4
          STDL   UX          LOCK ROUTINES USE UX
          RJM    SULOCK      TRY TO SET UNIT LOCKWORD
          NJK    SCANS60     IF COULD NOT GET THE LOCK
          RJM    SQLOCK      TRY TO SET REQUEST QUEUE LOCKWORD
          NJK    SCANS50     IF COULD NOT GET THE LOCK
          LOADR  UNITS+/UN/P.UIT,P4  LOAD REFORMATTED R+A OF UIT
          CRDL   T1          READ UNIT STATUS INTO T2
          ADN    /UIT/C.NEXT  OFFSET TO NEXT REQUEST RMA
          CRDL   T3          READ NEXT REQUEST RMA WORD
          LDDL   T2          VERIFY IF UNIT IS DISABLED
          SHN    18-16+/UIT/L.DSABLE
          MJN    SCANS40     IF UNIT IS DISABLED
          LDDL   T5          VERIFY HALF 1 OF REQUEST RMA
          ADDL   T6          AND HALF 2 OF REQUEST RMA
          ZJK    SCANS40     IF NOT VALID LOCKED REQUEST
          LDN    1           SET FACILITY LOCKED IN SL TABLE
          SHN    6
          STML   SLB+/SL/P.FACLCK,P3
          LDML   NREQFN      SET FACILITY NUMBER LOCKED
          LPN    17B
          RAML   SLB+/SL/P.CURFAC,P3
          LDDL   P5          RESTORE ORIGINAL UX
          STDL   UX
          LDN    1
          UJK    SCANSX      EXIT WITH REQUEST FOUND AND LOCKED, A=NZ

 SCANS40  RJM    CQLOCK      UNLOCK UNIT REQUEST QUEUE LOCKWORD

 SCANS50  RJM    CULOCK      UNLOCK UNIT LOCKWORD

 SCANS60  SODL   P2          CHECK FOR DONE SEARCHING
          ZJN    SCANS70     IF YES
          LDML   NREQFN      INCREMENT FACILITY NUMBER
          ADN    1
          LPN    FACPSL-1    MASK IT
          STML   NREQFN
          UJK    SCANS10     SEARCH AGAIN

 SCANS70  LDDL   P5          RESORE ORIGINAL UX
          STDL   UX
          LDN    0
          UJK    SCANSX      EXIT A=0, NONE FOUND

 SCANSA   BSSZ   1           SAVED ENTRY PARAMETER
          SPACE  2
          ERRNZ  4-P.SL      IF SL CHANGES
          ERRNZ  4-P.UN      IF UN CHANGES
          ERRNZ  32-FACPSL*P.UN  IF UNITS TABLE CHANGES
          ERRNZ  8-FACPSL    IF FACILITIES PER SLAVE CHANGES
          SPACE  4
 NREQSN   DATA   0           NEXT REQUEST SLAVE NUMBER
 NREQFN   DATA   0           NEXT REQUEST FACILITY NUMBER
          SPACE  5,20
** NAME-- NEXTCMD
*
** PURPOSE-- GET THE NEXT COMMAND TO PROCESS
*
** ENTRY-- A = BYTE INCREMENT VALUE FOR LASTC OFFSET
*              0=FIRST COMMAND
*              8=NEXT COMMAND
          SPACE  2
 NEXTCMD  SUBR               ENTRY/EXIT
          RAML   /TS/P.LASTC,CTST  INCREMENT COMMAND OFFSET
          SHN    -1          ADJUST TO PP WORD OFFSET
          ADDL   CTST        BUILD SOURCE ADDRESS
          ADK    /TS/P.CQB
          STML   NXTCA
          LDN    0           INITIALIZE LOOP COUNTER
          STDL   T1
          LDDL   CTST        INITIALIZE DESTINATION ADDRESS INDEX
          STDL   T2

 NXTC10   LDML   *,T1        GET THE NEXT COMMAND
 NXTCA    EQU    *-1
          STML   /TS/P.CURCMD,T2  PUT INTO TS TABLE CURRENT COMMAND
          AODL   T1          CHECK FOR DONE
          SBN    4
          ZJN    NEXTCMDX    IF YES, EXIT
          AODL   T2          INCREMENT DESTINATION ADDRESS INDEX
          UJN    NXTC10      LOOP
          SPACE  5,20
** NAME-- SWITCH
*
** PURPOSE-- SWITCH PROCESSING TO OTHER TS TABLES AS REQUIRED
*
** EXIT-- RETURN TO CALLER IF NO OTHER TS TABLES IN USE,
*         ELSE PROCESS OTHER TS TABLES.
          SPACE  2
 SWITCH   SUBR               ENTRY/EXIT

          LDDL   INITFLG     CHECK FOR INITIALIZATION
          NJN    SWITCHX     IF YES, EXIT

 SWI05    LDML   TNTAB       CHECK NUMBER OF SLAVE TS TABLES SUPPORTED
          SBN    1
          ZJN    SWITCHX     IF ONLY 1, RETURN TO CALLER
          LDML   SWITCH      GET CURRENT CALLERS RETURN ADDRESS
          STML   SLB+/SL/P.SIU,SX  SAVE ADDRESS IN SLAVE IN USE FLAG
          RJM    SAVETAB     SAVE CURRENT TS TABLE DIRECT CELLS

 SWI10    RJM    SCANT       SCAN NEXT SLAVE TS TABLE
          ZJN    SWI20       IF NOT IN USE
          RJM    RELDTAB     RELOAD THIS TS TABLE DIRECT CELLS
          LDML   SLB+/SL/P.SIU,SX  GET RETURN ADDRESS
          STML   SWITCH      STORE AS EXIT ADDRESS
          UJK    SWITCHX     GO PROCESS A TS TABLE

 SWI20    LDDL   ASYNCP      CHECK IF ASYNC PROCESSING
          ADDL   PPREQF       OR PP REQUEST WAITING
          ADDL   MALREQF      OR MALET WANTING THE CHANNEL
          NJN    SWI10       IF YES, BYPASS LOOKING FOR NEW REQUESTS
          RJM    SCANAS      SCAN ALL SLAVES FOR NEW REQUESTS
          ZJN    SWI10       IF NONE
          RJM    INITNR      INITIALIZE THE NEW REQUEST
          LDC    DOUR30      STARTING ADDRESS FOR NEW REQUEST
          STML   SWITCH      SIMULATE A SWITCH CALL FROM NEW REQUEST
          UJK    SWI05       SWITCH TO NEXT TS TABLE

 TNTAB    DATA   0           TOTAL SLAVE TS TABLES SUPPORTED (PLUGGED)
          SPACE  5,20
** NAME-- ERRCHK
*
** PURPOSE-- CHECK FOR ALERT MASK STATUS CONDITIONS
*
** EXIT-- A = 0 IF NO MASKABLE ERRORS
*         A =NZ IF MASKABLE ERRORS
          SPACE  2
 ERRCHK   SUBR               ENTRY/EXIT
          LDML   /TS/P.SCOND,CTST  GET CURRENT STATUS CONDITIONS
          LPML   /TS/P.RQB+/RQ/P.LONGB,CTST  MASK WITH REQUEST ALERT MASK
          ZJN    ERRCHKX     IF NONE, EXIT A=0

          RJM    PAR         PREPARE ABNORMAL RESPONSE
          LDK    /RS/K.ABALRT  SET ABNORMAL ALERT
          STML   RS+/RS/P.ABALRT
          LDML   /TS/P.SCOND,CTST  GET CONDITIONS
          LPML   /TS/P.RQB+/RQ/P.LONGB,CTST  MASK THEM AGAIN
          STML   RS+/RS/P.LNGBLK  SET MASKED ALERT CONDITIONS
          RJM    CDUNIT      CHECK FOR DOWNING UNIT
          LDN    1
          UJN    ERRCHKX     ERROR EXIT, A=NZ
          SPACE  5,20
** NAME-- IODONE
*
** PURPOSE-- PROCESS IO REQUEST DONE
*
** ENTRY-- RESPONSE ALREADY GENERATED AND CDUNIT CALLED
*          IF NEEDED.
*
** EXIT-- *MAIN* IF NO OTHER NEW REQUESTS OR THIS REQUEST
*         IS NOT CHAINED.
*         *DOUR20* IF NEW OR CHAINED REQUEST IS PROCESSABLE.
          SPACE  2
 IODONE   BSS                ENTRY ONLY
          RJM    RESP        SEND THE PREPARED RESPONSE
          RJM    CKPPRQ      CHECK FOR EXISTING OR NEW PP REQUEST
          NJN    IODONE10    IF YES
          RJM    CKCREQ      CHECK FOR EXISTING OR NEW MALET CH REQUEST
          ZJN    IODONE20    IF NOT

 IODONE10 RJM    CLREQ       CLEAR UNIT REQUEST ACTIVE
          LJM    MAIN        GO TO MAIN IDLE LOOP

*         CHECK IF UNIT IS NOW DOWN OR CHAINED REQUEST
 IODONE20 LOADR  UNITS+/UN/P.UIT,UX  LOAD REFORMATTED R+A OF UIT
          ERRNZ  /UIT/C.DSABLE
          CRDL   T1          READ UNIT STATUS INTO T2
          ADN    /UIT/C.NEXT  OFFSET TO NEXT REQUEST RMA
          CRDL   T3          READ NEXT REQUEST RMA WORD
          LDDL   T2          CHECK IF UNIT IS DISABLED
          ERRNZ  /UIT/P.DSABLE-1
          SHN    18-16+/UIT/L.DSABLE
          MJN    IODONE10    IF UNIT IS DISABLED
          LDDL   T5          CHECK HALF 1 OF REQUEST RMA
          ADDL   T6          AND HALF 2 OF REQUEST RMA
          ZJN    IODONE10    IF NO CHAINED REQUEST
          RJM    CFC         CHECK IF FACILITY STILL CHAINED
          STDL   ASYNCP      CLEAR ASYNCHRONUS PROCESSING FLAG
          LDDL   TSLVS       CHECK IF MORE THAN 1 SLAVE CONFIGURED
          SBN    1
          NJK    IODONE60    IF YES

*         CHECK FOR ACTIVE REQUESTS ON OTHER UNITS OF THIS SLAVE
 IODONE30 LDDL   SLVN        PREPARE FOR SCAN
          STML   NREQSN      SLAVE NUMBER TO SCAN
          LDDL   FACN        START SCAN FROM NEXT UNIT NUMBER
          ADN    1
          LPN    FACPSL-1    MASK IT
          STML   NREQFN      FACILITY NUMBER TO SCAN FIRST
          LDN    1           ENABLE SCAN WITH LOCKED FACILITY
          RJM    SCANS       SCAN SLAVE FOR LOCKABLE REQUESTS
          NJK    IODONE40    IF ONE FOUND, PROCESS THE OTHER REQUEST
          RJM    CLRPTS      CLEAR PARTIAL TS TABLE
          RJM    SQLOCK      TRY TO SET UIT REQUEST QUEUE LOCK AGAIN
          NJK    IODONE10    IF COULD NOT SET LOCK
*         VERIFY CHAINED REQUEST WHILE QUEUE IS LOCKED
          LOADR  UNITS+/UN/P.UIT,UX  LOAD REFORMATTED R+A OF UIT
          ERRNZ  /UIT/C.DSABLE
          CRDL   T1          READ UNIT STATUS INTO T2
          ADN    /UIT/C.NEXT  OFFSET TO NEXT REQUEST RMA
          CRDL   T3          READ NEXT REQUEST RMA WORD
          LDDL   T2          CHECK IF UNIT IS DISABLED
          ERRNZ  /UIT/P.DSABLE-1
          SHN    18-16+/UIT/L.DSABLE
          MJK    IODONE10    IF UNIT IS DISABLED
          LDDL   T5          CHECK HALF 1 OF REQUEST RMA
          ADDL   T6          AND HALF 2 OF REQUEST RMA
          ZJK    IODONE10    IF NO CHAINED REQUEST
          RJM    LDTS        LOAD CHAINED REQUEST AND UNLOCK QUEUE
          LDN    70B         SET ASYNCHRONUS PROCESSING FLAG
          STDL   ASYNCP        SO SWITCH WILL NOT START A NEW REQUEST
          RJM    SWITCH      SWITCH, IN CASE ANY WAITING CLASS 2 INTS
          LDN    0           CLEAR ASYNCHRONUS PROCESSING FLAG
          STDL   ASYNCP
          LDML   /TS/P.NUMCM,CTST  DECREMENT NUMBER OF COMMANDS
          SBN    2
          STML   /TS/P.NUMCM,CTST
          LDN    8           BYPASS FORMAT COMMAND
          RJM    NEXTCMD     GET NEXT COMMAND
          LJM    CMDEXEC     GO EXECUTE THE COMMAND

*         PROCESS A DIFFERENT UNIT REQUEST
 IODONE40 RJM    CULOCK      UNLOCK OLD UNIT LOCKWORD
          RJM    CLRPTS      CLEAR PARTIAL TS TABLE
          UJK    DOUR20      GO PROCESS NEW REQUEST

*         CHECK FOR REQUESTS ON OTHER SLAVES
 IODONE60 LDDL   SLVN        START SCAN FROM NEXT SLAVE NUMBER
          ADN    1
          LPN    SLVPCH-1    MASK IT
          STML   NREQSN      SLAVE NUMBER TO SCAN FIRST
          LDN    0           FACILITY NUMBER TO SCAN FIRST
          STML   NREQFN
          LDN    SLVPCH-1    LOOP COUNT MINUS CURRENT SLAVE
          STDL   P1          P1 = LOOP COUNTER

 IODONE70 LDN    0           DISABLE SCAN IF A FACILITY IS LOCKED
          RJM    SCANS       SCAN SLAVE FOR NEW LOCKABLE REQUEST
          ZJN    IODONE80    IF NONE FOUND
          LDML   SLB+/SL/P.FACLCK,SX  CLEAR ORIGINAL FACILITY LOCK
          LPN    17B
          STML   SLB+/SL/P.FACLCK,SX
          UJK    IODONE40    GO PROCESS NEW REQUEST

 IODONE80 SODL   P1          DECRECMENT LOOP COUNT
          ZJK    IODONE30    IF ALL OTHER SLAVES SCANED
          AOML   NREQSN      INCREMENT SLAVE NUMBER
          LPN    SLVPCH-1    MASK IT
          STML   NREQSN
          LDN    0
          STML   NREQFN      START SCAN FROM FACILITY 0
          UJN    IODONE70    LOOP
          ERRNZ  8-FACPSL    IF FACILITIES PER SLAVE CHANGES
          ERRNZ  8-SLVPCH    IF SLAVES PER CHANNEL CHANGES
          SPACE  5,20
** NAME-- CMDRESP
*
** PURPOSE-- COMMAND RESPONSE DECODE
*
** INPUT-- RPB HAS COMMAND RESPONSE PACKET
*          A = 0 DO NOT EXPECT BLOCK ID
*          A = 1 EXPECT BLOCK ID, IF NOT ERROR
*          A = 2 EXPECT END OF EXTENT (TAPE MARK), IF NOT ERROR
*          A = 3 EXPECT EITHER BLOCK ID OR END OF EXTENT, IF NOT ERROR
          SPACE  2
 CMDRESP  SUBR               ENTRY/EXIT
          STML   /TS/P.BIDEF,CTST  SAVE BLOCK ID EXPECTED FLAG
          LDN    0
          STDL   P1          CLEAR ERROR FLAG
          STML   /TS/P.SCOND,CTST  CLEAR ALERT CONDITIONS FLAG
          LDML   RPB+MAJST   DECODE RESPONSE TYPE
          SHN    -4
          LPN    0#F
          SBN    CC          CHECK FOR COMMAND COMPLETION
          ZJN    CMDR100     IF YES
          SBN    AR-CC       CHECK FOR ASYNCHRONUS
          ZJK    CMDR200     IF YES
          SBN    TN-AR       CHECK FOR TRANSFER NOTIFICATION
          ZJK    CMDR300     IF YES
          UJK    CMDR476     UNDEFINED RESPONSE TYPE (E76)
          SPACE  2
*         PROCESS COMMAND COMPLETION RESPONSE TYPE
 CMDR100  LDML   /TS/P.CRN,CTST  COMPARE COMMAND REFERENCE NUMBERS
          LMML   RPB+CRN
          NJK    CMDR476     REPORT UNEXPECTED STATUS (E76)

          LDML   RPB+MAJST   DECODE MAJOR STATUS
          SHN    LSCS        CHECK FOR CONDITIONAL
          PJK    CMDR130     IF NOT
          LDK    ID29        SEARCH FOR FAC CONDITIONAL PARAMETER
          RJM    SFP
          PJN    CMDR110     IF FOUND
          LDK    ID19        ELSE SEARCH FOR SLAVE CONDITIONAL PARAMETER
          RJM    SFP
          PJN    CMDR110     IF FOUND
          UJK    CMDR476     REPORT UNEXPECTED STATUS (E76)

 CMDR110  LDML   RPB+6,T3    DECODE CONDITIONAL OCTETS 1 AND 2
          STDL   T1          SAVE IT
          LPC    0#7002      CHECK FOR ERRORS
          ZJN    CMDR115     IF NOT
          AODL   P1          SET ERROR FLAG

 CMDR115  LDDL   T1          CHECK FOR ON-THE-FLY CORRECTION
          LPN    0#8
          ZJN    CMDR120     IF NOT
          AOML   /TS/P.OTFC,CTST  REPORT ON-THE-FLY CORRECTION

 CMDR120  LDML   RPB+7,T3    DECODE CONDITIONAL OCTETS 3 AND 4
          SHN    -8          POSITION OCTET 3
          STDL   T1          SAVE OCTET 3
          LPN    1           CHECK FOR MASTER TERMINATED TRANSFER
          ZJN    CMDR125     IF NOT
          AODL   P1          SET ERROR FLAG

 CMDR125  LDDL   T1          GET OCTET 3
          LPN    0#10        CHECK FOR EOM WARNING (EOT)
          ZJN    CMDR130     IF NOT
          LDK    /RS/K.PDLIM  SET PHYSICAL DELIMITER IN STATUS CONDITIONS
          RAML   /TS/P.SCOND,CTST

 CMDR130  LDML   RPB+MAJST   CHECK FOR OTHER MAJOR STATUS BITS
          LPC    0#F805
          ZJK    CMDR165     IF NONE

          SHN    LSI         CHECK FOR INCOMPLETE
          PJK    CMDR160     IF NOT
          LDK    ID2A        SEARCH FOR INCOMPLETE PARAMETER
          RJM    SFP
          MJK    CMDR476     IF NOT FOUND REPORT ERROR (E76)

          LDML   RPB+7,T3    DECODE INCOMPLETE OCTETS 3 AND 4
          STDL   T1          SAVE IT
          SHN    -8          POSITION OCTET 3
          LPK    0#8C        CHECK FOR ERRORS
          ZJN    CMDR132     IF NOT
          AODL   P1          SET ERROR FLAG

 CMDR132  LDDL   T1          CHECK FOR BLOCK LENGTH DIFFERENCE
          SHN    -8          POSITION OCTET 3
          LPN    0#10        MASK IT
          ZJN    CMDR140     IF NOT SET
          LDML   RPB+OPCD    CHECK IF READ OPERATION
          SHN    -8          POSITION OP-CODE
          SBN    0#10
          ZJN    CMDR134     IF YES
          AODL   P1          SET ERROR FLAG
          UJN    CMDR140     CONT.

 CMDR134  LDK    ID32        SEARCH FOR RESPONSE EXTENT
          RJM    SFP
          MJK    CMDR476     IF PARAMETER NOT FOUND  (E76)
          LDML   RPB+6,T3    CHECK FOR SHORT OR LONG RECORD
          ADML   RPB+7,T3
          NJN    CMDR140     IF SHORT BLOCK, OK
          LDK    /RS/K.LNGBLK  SET LONG BLOCK IN STATUS CONDITIONS
          RAML   /TS/P.SCOND,CTST

 CMDR140  LDDL   T1          GET OCTET 3 AND 4
          SHN    17-14       CHECK FOR EOM WARNING (EOT)
          PJN    CMDR150     IF NOT
          LDK    /RS/K.PDLIM  SET PHYSICAL DELIMITER IN STATUS CONDITIONS
          RAML   /TS/P.SCOND,CTST

 CMDR150  LDDL   T1          GET OCTETS 3 AND 4
          SHN    17-13       CHECK FOR END OF EXTENT (TM) DETECTED
          PJN    CMDR160     IF NOT
          LDK    /RS/K.LDLIM  SET LOGICIAL DELIMITER IN STATUS CONDITIONS
          RAML   /TS/P.SCOND,CTST

 CMDR160  LDML   RPB+MAJST   CHECK FOR OTHER STATUS BITS
          LPC    0#F800
          ZJN    CMDR162     IF NOT
          AODL   P1          SET ERROR FLAG

 CMDR162  LDML   RPB+MAJST   CHECK FOR COMMAND ABORT
          LPN    1
          ZJN    CMDR165     IF NOT
          AOML   /TS/P.CHAIN,CTST  SET COMMAND CHAINING ABORT FLAG

 CMDR165  LDDL   P1          CHECK IF ERROR FLAG IS SET
          NJK    CMDR400     IF YES, BYPASS TM OR BID
          LDML   /TS/P.BIDEF,CTST  CHECK FOR BID OR TM EXPECTED
          ZJK    CMDR195     IF NOT GOTO COMMAND COMPLETE
          SBN    1           CHECK FOR BID EXPECTED
          ZJN    CMDR170     IF YES
          SBN    1           CHECK FOR END OF EXTENT (TM) EXPECTED
          ZJN    CMDR180     IF YES

          LDML   /TS/P.SCOND,CTST  ELSE EITHER
          LPK    /RS/K.LDLIM
          NJK    CMDR190     IF END OF EXTENT FOUND

 CMDR170  LDK    IDD0        SEARCH FOR BLOCK ID PARAMETER
          RJM    SFP
          MJK    CMDR478     IF NOT FOUND REPORT ERROR (E78)
          RJM    GBID        PUT BLOCK ID INTO TABLE
          UJN    CMDR195     GOTO COMMAND COMPLETE

 CMDR180  LDML   /TS/P.SCOND,CTST  CHECK FOR END OF EXTENT DETECTED
          LPK    /RS/K.LDLIM
          NJK    CMDR190     IF YES
*         CHECK FOR X15 OR 051 ATS PHYSICAL FUNCTIONS
          LDML   /TS/P.CURCMD+3,CTST
          LPC    77B         MASK MAJOR FUNCTION CODE BITS
          SBN    F.STM       CHECK FOR SEARCH TAPE MARK (X15)
          ZJN    CMDR185     IF YES
          SBN    F.WTM-F.STM  CHECK FOR WRITE TAPE MARK (X15)
          NJK    CMDR490     IF NOT, REPORT ERROR (E90)

 CMDR185  LDK    /RS/K.LDLIM  SET LOGICIAL DELIMITER IN STATUS CONDITIONS
          RAML   /TS/P.SCOND,CTST

 CMDR190  RJM    TMBID       SET END OF EXTENT IN BLOCK ID TABLE

 CMDR195  LDDL   P1          CHECK IF ERROR FLAG IS SET
          NJN    CMDR400     IF YES
          LJM    CMDCOMP     ELSE,  GOTO COMMAND COMPLETE
          SPACE  4
*         PROCESSING ASYNCHRONUS RESPONSE TYPE
 CMDR200  BSS
          LDML   RPB+SLAD    CHECK FOR FACILITY ASYNC RESPONSE
          LPDL   FF
          LMDL   FF
          NJK    CMDRESPX    IF YES, RETURN TO CALLER
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDK    R.UNS       CHANGE TO UNSOLICITED
          STML   RS+/RS/P.RC
          LDN    0           SET LOGICIAL UNIT NUMBER = 0
          STML   RS+/RS/P.LU
          RJM    RESP        SEND RESPONSE
          UJK    CMDRESPX    NOW RETURN TO CALLER
          SPACE  4
*         PROCESS TRANSFER NOTIFICATION RESPONSE TYPE
 CMDR300  UJN    CMDR476     REPORT UNEXPECTED STATUS (E76)
          SPACE  4
*         ERROR CODES
 CMDR400  LDN    E00         CPU MUST DETERMINE
          UJN    CMDR500

 CMDR476  LDK    E76         UNEXPECTED STATUS
          UJN    CMDR500

 CMDR478  LDDL   P1          CHECK IF ERROR FLAG IS SET
          NJN    CMDR400     IF YES
          LDK    E78         ELSE, NO BLOCK ID RETURNED
          UJN    CMDR500

 CMDR490  LDDL   P1          CHECK IF ERROR FLAG IS SET
          NJN    CMDR400     IF YES
          LDK    E90         ELSE, NO END OF EXTENT STATUS

 CMDR500  RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDML   /TS/P.SCOND,CTST  GET CURRENT STATUS CONDITIONS
          LPML   /TS/P.RQB+/RQ/P.LONGB,CTST  MASK WITH REQUEST ALERT MASK
          ZJN    CMDR510     IF NONE ACTIVE

          STML   RS+/RS/P.LNGBLK  SET MASKED CONDITIONS

          LDK    /RS/K.ABALRT  SET ABNORMAL ALERT BIT
          STML   RS+/RS/P.ABALRT

 CMDR510  LDDL   P1          CHECK IF ERROR FLAG IS SET
          ZJN    CMDR520     IF NOT
          LDML   RS+/RS/P.ERRID  CHECK IF ERROR ID IS NONZERO
          NJN    CMDR520     IF YES

          LDK    /RS/K.HDWR  SET HARDWARE MALFUNCTION BIT
          RAML   RS+/RS/P.ABALRT

 CMDR520  RJM    CMDTERM     COMMAND TERMINATE  (NO RETURN)
          SPACE  5,20
** NAME-- ATTRIB
*
** PURPOSE-- SEND ATTRIBUTE COMMAND TO SLAVE
*
** INPUT-- (/TS/P.ECSEL,CTST) =
*              0 DO NOTHING
*              1 ERROR CORRECTION ENABLED
*              2 ERROR CORRECTION DISABLED
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 ATT1     LDML   /TS/P.SATTR,CTST  RESTORE RETURN ADDRESS
          STML   ATTRIB

 ATTRIB   SUBR               ENTRY/EXIT
          LDML   ATTRIB      SAVE RETURN ADDRESS
          STML   /TS/P.SATTR,CTST
          LDML   /TS/P.ECSEL,CTST  CHECK FOR SELECTION
          ZJN    ATTRIBX     IF NOT DEFINED EXIT
          SBN    1
          ZJN    ATT10       IF ERROR CORRECTION ENABLED
          LDC    0#8000      DISABLE ERROR CORRECTION PARAM
          UJN    ATT20       CONT.
 ATT10    LDC    0#C000      ENABLE ERROR CORRECTION PARAM
 ATT20    STML   ATTCP9      STORE PARAMETER
          AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          STML   ATTCP1
          LDML   /TS/P.SN,CTST  GET SLAVE ADDRESS
          SHN    -8
          SHN    8
          ADDL   FF          NO FACILITY ADDRESS
          STML   ATTCP5
          LDC    ATTCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 ATT30    LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          ZJK    ATT1        IF YES, EXIT
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    ATT30       IF ASYNC RESPONSE
          SPACE  4
*         -ATTRIBUTES-  COMMAND PACKET
 ATTCP    DATA   0#0025      PACKET LENGTH
 ATTCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCATT+OMAL  OP-CODE, LOAD AND NO CHAINING
 ATTCP5   DATA   0#FFFF      ADDRESSEE (NO FACILITY)
          CON    CPSRB       SLAVE RECONFIGURATION BIT PARAMETER
 ATTCP9   DATA   0#FF00        C000=EC ENABLED, 8000=EC DISABLED
          CON    CPSRF       SLAVE RECONFIGURATION FIELD PARAMETER
          DATA   0,0,0,0       OCTETS 01-08
          DATA   0,0,0,0              09-10
 ATTCP1D  CON    BURST                11-12 GENERATE CLASS 2 INTERRUPTS
          DATA   0                    13-14
 ATTCP21  CON    BURST                15-16 DATA BURST SIZE
          CON    CPBID       ENABLE/DISABLE BID PARAMETER
          DATA   0#8000        BID ENABLED
          SPACE  5,20
** NAME-- OPMODE
*
** PURPOSE-- SEND OPMODE COMMAND TO SLAVE/FACILITY
*
** INPUT-- (/TS/P.DENSEL,CTST) =
*              0 DO NOTHING
*              1 SELECT 1600 (PE) OPERATION
*              2 SELECT 6250 (GCR) OPERATION
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 OPM1     LDML   /TS/P.SOPMO,CTST  RESTORE RETURN ADDRESS
          STML   OPMODE

 OPMODE   SUBR               ENTRY/EXIT
          LDML   OPMODE      SAVE RETURN ADDRESS
          STML   /TS/P.SOPMO,CTST
          LDML   /TS/P.DENSEL,CTST  CHECK FOR SELECTION
          ZJN    OPMODEX     IF NOT DEFINED EXIT
          SBN    1
          ZJN    OPM10       IF 1600 (PE)
          LDC    0#030C      SET 6250 (GCR) PARAMETERS
          STML   OPMCP13
          LDC    0#186A
          STML   OPMCP15
          UJN    OPM20       CONT.
 OPM10    LDC    0#0607      SET 1600 (PE) PARAMETERS
          STML   OPMCP13
          LDC    0#0640
          STML   OPMCP15
 OPM20    AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          STML   OPMCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   OPMCP5
          LDC    OPMCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 OPM30    LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK IF COMMAND COMPLETE SUCCESSFUL
          ZJK    OPM1        IF YES, EXIT
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    OPM30       IF ASYNC RESPONSE
          SPACE  4
*         -OPERATING MODE-  COMMAND PACKET
 OPMCP    DATA   0#0016      PACKET LENGTH
 OPMCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCOM+CMCHN+OMOMS  OP-CODE, CHAIN AND SET
 OPMCP5   DATA   0#FFFF      ADDRESSEE
          CON    CPTMB       TAPE MODE BIT PARAMETER
          DATA   0#0000
          DATA   0#0100        DISABLE COMPRESSION
          CON    CPTMF       TAPE MODE FIELD PARAMETER
          DATA   0#0000
          DATA   0#0000
 OPMCP13  DATA   0#FFFF        PE=0607, GCR=030C
 OPMCP15  DATA   0#FFFF        PE=0640, GCR=186A
          SPACE  5,20
** NAME-- GBID
*
** PURPOSE-- GET BLOCK ID FROM RESPONSE PACKET
*            AND STORE INTO CURRENT TS BIDB BUFFER.
          SPACE  2
 GBID     SUBR               ENTRY/EXIT
          LDK    IDD0        FIND BLOCK ID PARAMETER IN RESPONSE PACKET
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    GBID10      IF NOT FOUND
          LDK    /TS/P.BIDB  BUILD DESTINATION ADDRESS
          ADDL   CTST        CURRENT TS TABLE BASE ADDRESS
          ADML   /TS/P.BIDBP,CTST  BLOCK ID BUFFER POINTER
          STML   GBIDA       SET DESTINATION ADDRESS
          LDML   RPB+6,T3    GET BLOCK ID VALUE
          SHN    3           POSITION IT LIKE ATS BID
          STML   *           PUT INTO BLOCK ID BUFFER
 GBIDA    EQU    *-1
          AOML   /TS/P.BIDBP,CTST  INCREMENT POINTER
          UJN    GBIDX       EXIT

 GBID10   RJM    PAR         PREPARE ABNORMAL RESPONSE
          LDK    E78         NO BLOCK ID PARAMETER RETURNED
          STML   RS+/RS/P.ERRID
          RJM    CMDTERM     TERMINATE COMMAND (NO RETURN)
          SPACE  5,10
** NAME-- CFC
*
** PURPOSE-- CHECK FOR CHAINING STILL ACTIVE
*
** EXIT-- A = 0
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 CFC      SUBR               ENTRY/EXIT
          LDML   /TS/P.CHAIN,CTST  GET CHAIN FLAG
          ZJN    CFCX        IF NOT ACTIVE EXIT
          STDL   ASYNCP      SET ASYNCHRONUS PROCESSING FLAG
          LDML   CFC         SAVE RETURN ADDRESS
          STML   /TS/P.SCFC,CTST
          RJM    LIR         LOGICIAL INTERFACE RESET TO CLEAR CHAINING
          LDML   /TS/P.SCFC,CTST  RESTORE RETURN ADDRESS
          STML   CFC
          LDN    0           CLEAR RESPONSE PACKET LENGTH
          STML   RPB
          UJN    CFCX        EXIT
          SPACE  5,20
** NAME-- TMBID
*
** PURPOSE-- SET TAPE MARK BLOCK ID INTO BLOACK ID BUFFER.
          SPACE  2
 TMBID    SUBR               ENTRY/EXIT
          LDK    /TS/P.BIDB  BUILD DESTINATION ADDRESS
          ADDL   CTST        CURRENT TS TABLE BASE ADDRESS
          ADML   /TS/P.BIDBP,CTST  BLOCK ID BUFFER POINTER
          STML   TMBIDA      SET DESTINATION ADDRESS
          LDN    0#01        TAPE MARK IDENTIFIER
          STML   *           PUT INTO BLOCK ID BUFFER
 TMBIDA   EQU    *-1
          AOML   /TS/P.BIDBP,CTST  INCREMENT POINTER
          UJN    TMBIDX      EXIT
          SPACE  5,20
** NAME-- GFS
*
** PURPOSE-- GET FACILITY STATUS ID52 FOR RESPONSE.
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 GFS1     LDML   /TS/P.SGFS,CTST  RESTORE RETURN ADDRESS
          STML   GFS

 GFS      SUBR               ENTRY/EXIT
          LDML   /TS/P.FACSTA,CTST  CHECK IF ALREADY SET
          NJN    GFSX        IF YES
          LDML   GFS         SAVE RETURN ADDRESS
          STML   /TS/P.SGFS,CTST
          AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          STML   GFSCP1
          LDML   /TS/P.SN,CTST  ADDRESSEE
          STML   GFSCP5
          SHN    -8          BUILD SLAVE PARAMETER
          SHN    8
          ADDL   FF
          STML   GFSCP9
          LDC    GFSCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER

 GFS10    LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR SUCCESSFUL
          ZJN    GFS20       IF YES
          LDN    0           DO NOT EXPECT BID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    GFS10       IF ASYNC RESPONSE

 GFS20    LDK    ID52        LOCATE PARAM 52
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    GFS30       IF NOT FOUND
          LDML   RPB+5,T3    SAVE PARAMETERS IN TS TABLE
          STML   /TS/P.FACSTA,CTST
          LDML   RPB+6,T3
          STML   /TS/P.FACSTA+1,CTST
          LDN    0           CLEAR RESPONSE PACKET LENGTH
          STML   RPB
          UJK    GFS1        EXIT

 GFS30    LDK    E76         REPORT UNEXPECTED STATUS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE (NO RETURN)
          SPACE  2,10
*         -REPORT ADDRESSEE STATUS-  COMMAND PACKET
 GFSCP    DATA   0#000B      PACKET LENGTH
 GFSCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCRAS+OMRASC  OP-CODE AND CONDITION
 GFSCP5   DATA   0#FFFF      ADDRESSEE
          CON    CPPM        PORT MASK PARAMETER
 GFSCP9   DATA   0#00FF        SLAVE ADDRESS
          DATA   0#0100        PORT MASK
          SPACE  5,20
** NAME-- RSEL
*
** PURPOSE-- READ SLAVE ERROR LOG TO PREVENT IT
*            FROM OVERFLOWING.
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 RSEL1    LDML   /TS/P.SRSEL,CTST  RESTORE RETURN ADDRESS
          STML   RSEL

 RSEL     SUBR               ENTRY/EXIT
          LDML   RSEL        SAVE RETURN ADDRESS
          STML   /TS/P.SRSEL,CTST
          LDML   RELCP3      CLEAR CHAINING COMMON MODIFIER
          LPC    0#FF0F
          STML   RELCP3
          LDML   /TS/P.SN,CTST  GET SLAVE ADDRESS
          SHN    -8
          SHN    8
          ADDL   FF          NO FACILITY ADDRESS
          STML   RELCP5
          RJM    REL         READ THE SLAVE ERROR LOG
          UJN    RSEL1       EXIT
          SPACE  4,15
** NAME-- RFEL
*
** PURPOSE-- READ FACILITY ERROR LOG TO PREVENT IT
*            FROM OVERFLOWING.
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 RFEL1    LDML   /TS/P.SRFEL,CTST  RESTORE RETURN ADDRESS
          STML   RFEL

 RFEL     SUBR               ENTRY/EXIT
          LDML   RFEL        SAVE RETURN ADDRESS
          STML   /TS/P.SRFEL,CTST
          LDML   RELCP3      SET CHAINING COMMON MODIFIER
          LPC    0#FF0F
          ADN    CMCHN
          STML   RELCP3
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   RELCP5
          RJM    REL         READ THE FACILITY ERROR LOG
          UJN    RFEL1       EXIT
          SPACE  5,20
** NAME-- NSI
*
** PURPOSE-- NON-STOP INITIALIZATION FOR READ OR OUTPUT 8-BIT DATA COMMANDS.
*
** INPUT-- (/TS/P.NSCA,CTST) HAS CURRENT PP COMMAND ADDRESS TO SET UP.
*
** OUTPUT-- (/TS/P.ILSTL,CTST) HAS NUMBER OF INDIRECT LENGTH/ADDRESS PAIRS
*           (/TS/P.ILSTA,CTST) HAS RMA (UNFORMATTED) OF INDIRECT LEN/ADD PAIR
*           (/TS/P.ILSTP,CTST) HAS INDIRECT LENGTH/ADDRESS PAIR
*           (/TS/P.NSCRN,CTST) HAS UPDATED NON-STOP CMD REFERENCE NUMBER
*           ((/TS/P.RTCB,CTST)+(/TS/P.RTCIP,CTST)) REC XFER COUNT CLEARED
*
** NOTE-- IF THE COMMAND DOES NOT HAVE THE INDIRECT ADDRESS BIT SET, THE
*         COMMAND LENGTH/ADDRESS IS MOVED INTO (/TS/P.ILSTP,CTST) AND
*         (/TS/P.ILSTL,CTST) IS SET TO 1. (/TS/P.ILSTA,CTST) IS NOT SET.
          SPACE  2
 NSI10    AODL   P4          INCREMENT PP ADDRESS
          LDIL   P4          GET NUMBER OF PAIRS
          SHN    -3
          STML   /TS/P.ILSTL,CTST
          AODL   P4          INCREMENT PP ADDRESS
          LDIL   P4          SET RMA OF FIRST PAIR
          STML   /TS/P.ILSTA,CTST
          AODL   P4
          LDIL   P4
          STML   /TS/P.ILSTA+1,CTST
          LDK    /TS/P.ILSTP  BUILD CRML PP ADDRESS
          ADDL   CTST
          STML   NSIA
          LOADF  /TS/P.ILSTA,CTST  SET R+A OF FIRST PAIR
          CRML   *,ONE       READ THE FIRST INDIRECT LEN/ADD PAIR
 NSIA     EQU    *-1

 NSI20    LDN    8           INCREMENT TO NEXT NON-STOP COMMAND ADDRESS
          RAML   /TS/P.NSCA,CTST


 NSI      SUBR               ENTRY/EXIT


          LDK    /TS/P.RTCB  BUILD CURRENT REC XFER COUNT ADDRESS
          ADDL   CTST
          ADML   /TS/P.RTCIP,CTST  INCREMENT WITH IN POINTER
          STML   NSIB        SAVE IT (UPPER HALF)
          ADN    1           BUILD LOWER HALF ADDRESS
          STML   NSIC
          LDN    0           CLEAR CURRENT REC XFER COUNTER
          STML   *           UPPER HALF
 NSIB     EQU    *-1
          STML   *           LOWER HALF
 NSIC     EQU    *-1

          AOML   /TS/P.NSCRN,CTST  UPDATE NON-STOP COMMAND REFERENCE NUMBER
          LDML   /TS/P.NSCA,CTST  GET NON-STOP COMMAND PP ADDRESS
          STDL   P4          SAVE IT
          LDIL   P4          GET COMMAND
          LPC    INDFLG      CHECK FOR INDIRECT BIT
          NJK    NSI10       IF YES

*         ELSE PROCESS DIRECT
          LDN    1           SET NUMBER OF PAIRS
          STML   /TS/P.ILSTL,CTST
          AODL   P4          INCREMENT PP ADDRESS
          LDIL   P4          GET LENGTH/ADDRESS
          STML   /TS/P.ILSTP+1,CTST
          AODL   P4
          LDIL   P4
          STML   /TS/P.ILSTP+2,CTST
          AODL   P4
          LDIL   P4
          STML   /TS/P.ILSTP+3,CTST
          UJK    NSI20       EXIT
          SPACE  5,20
** NAME-- URECTC
*
** PURPOSE-- UPDATE RECORD TRANSFER COUNT
*
** INPUT-- (/TS/P.CBURBC,CTST) = CURRENT BURST BYTE COUNT
*          (/TS/P.RESBC,CTST)  = RESIDUAL BYTE COUNT
*          (/TS/P.SLVEES,CTST) = SLAVE ENCODED ENDING STATUS
*          (/TS/P.RTCIP,CTST)  = REC XFER COUNT BUFFER IN POINTER
*
** OUTPUT--(/TS/P.RTCB,CTST)+IN POINTER=UPDATED BY ACTUAL TRANSFER COUNT
*           A = 0  ALL DATA TRANSFERED
*               NZ RESIDUAL BYTE COUNT
          SPACE  2
 URECTC   SUBR               ENTRY/EXIT
          LDML   /TS/P.CBURBC,CTST  GET CURRENT BURST BYTE COUNT
          SBML   /TS/P.RESBC,CTST  DECREMENT BY RESIDUAL BYTE COUNT
          STDL   T1          SAVE IT
          LDML   /TS/P.SLVEES,CTST  CHECK FOR ODD OR EVEN TRANSFER
          LPN    0#F
          LMN    0#F
          NJN    URECTC2     IF EVEN TRANSFER
          SODL   T1          DECREMENT COUNT BY 1 ON ODD TRANSFERS

 URECTC2  LDK    /TS/P.RTCB  BUILD REC XFER COUNTER BUFFER ADDRESS
          ADDL   CTST
          ADML   /TS/P.RTCIP,CTST  ADJUST WITH IN POINTER
          STML   URECTCA     SAVE UPPER HALF ADDRESS
          ADN    1
          STML   URECTCB     SAVE LOWER HALF ADDRESS

          LDDL   T1          GET CURRENT TRANSFER COUNT
          RAML   *           UPDATE LOWER HALF
 URECTCB  EQU    *-1
          SHN    -16         ADJUST FOR CARRY BIT
          RAML   *           UPDATE UPPER HALF
 URECTCA  EQU    *-1

          LDML   /TS/P.RESBC,CTST  (A) = RESIDUAL BYTE COUNT
          UJN    URECTCX     EXIT
          SPACE  5,20
** NAME-- UREQTC
*
** PURPOSE-- UPDATE REQUEST TRANSFER COUNT
*
** INPUT-- (/TS/P.RTCB,CTST)+OUT POINTER = THIS RECORD XFER COUNT
*
** OUTPUT--(/TS/P.XFER,CTST) UPDATED BY RECORD TRANSFER COUNT
          SPACE  2
 UREQTC   SUBR               ENTRY/EXIT

          LDK    /TS/P.RTCB  BUILD RECORD XFER COUNT BUFFER ADDRESS
          ADDL   CTST
          ADML   /TS/P.RTCOP,CTST  ADJUST WITH OUT POINTER
          STML   UREQTCB     SAVE UPPER HALF ADDRESS
          ADN    1
          STML   UREQTCA     SAVE LOWER HALF ADDRESS

          LDML   *           GET RECORD XFER COUNT LOWER
 UREQTCA  EQU    *-1
          RAML   /TS/P.XFER+1,CTST  UPDATE REQUEST XFER COUNT LOWER
          SHN    -16         ADJUST FOR CARRY BIT
          ADML   *           ADD RECORD XFER COUNT UPPER
 UREQTCB  EQU    *-1
          RAML   /TS/P.XFER,CTST  UPDATE REQUEST XFER COUNT UPPER

          LDML   /TS/P.RTCOP,CTST  INCREMENT OUT POINTER
          ADN    2
          LPN    7
          STML   /TS/P.RTCOP,CTST

          UJN    UREQTCX     EXIT
          SPACE  5,30
** NAME-- GETNP
*
** PURPOSE-- GET NEXT LENGTH/ADDRESS PAIR
*
** INPUT-- (/TS/P.PARLAP,CTST) = PARTIAL L/A PAIR FLAG
*
** OUTPUT--(/TS/P.ILSTL,CTST) INDIRECT L/A PAIR LENGTH DECREMENTED
*          (/TS/P.ILSTA,CTST) INDIRECT L/A PAIR RMA UPDATED
*          (/TS/P.ILSTP,CTST) NEW INDIRECT L/A PAIR
*           A =  0 NO MORE L/A PAIRS
*               NZ VALID L/A PAIR
          SPACE  2
 GETNP    SUBR               ENTRY/EXIT
          LDML   /TS/P.PARLAP,CTST  CHECK FOR PARTIAL L/A PAIR
          NJN    GETNP10     IF YES
          SOML   /TS/P.ILSTL,CTST  DECREMENT NUMBER OF L/A PAIRS
          ZJN    GETNPX      EXIT IF NONE LEFT
          LDN    8           UPDATE L/A PAIR (UNFORMATTED) RMA
          RAML   /TS/P.ILSTA+1,CTST
          SHN    -16
          RAML   /TS/P.ILSTA,CTST
          LDK    /TS/P.ILSTP  BUILD CRML PP ADDRESS
          ADDL   CTST
          STML   GETNPA
          LOADF  /TS/P.ILSTA,CTST  SET R+A OF NEXT PAIR
          CRML   *,ONE       GET THE NEXT L/A PAIR
 GETNPA   EQU    *-1
          LDN    1           SET A = NZ
          UJN    GETNPX      EXIT

*         PROCESS PARTIAL L/A PAIR STILL ACTIVE
 GETNP10  STDL   T1          SAVE BYTES ALREADY USED FROM THIS PAIR
          LDML   /TS/P.ILSTP+1,CTST  DECREMENT L/A PAIR DATA LENGTH
          SBDL   T1
          STML   /TS/P.ILSTP+1,CTST
          LDDL   T1          INCREMENT L/A PAIR DATA (UNFORMATTED) RMA
          RAML   /TS/P.ILSTP+3,CTST
          SHN    -16
          RAML   /TS/P.ILSTP+2,CTST
          LDN    2           SET A = NZ
          UJK    GETNPX      EXIT
          SPACE  5,20
** NAME-- WSTN
*
** PURPOSE-- WAIT FOR SPECIAL TRANSFER NOTIFICATION
*
** NOTE -- THE SLAVE ONLY GENERATES A CLASS 2 RESPONSE
*          PACKET ON THE FIRST TRANSFER NOTIFICATION.
*
*          IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*          ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
*
** EXIT -- A =  0  SPECIAL CLASS 2 INTERRUPT ACTIVE
*            = NZ  CLASS 1 OR 3 INTERRUPT ACTIVE
*          WSTNF IS SET WITH (A) ON EXIT
          SPACE  2
 WSTN1    STML   /TS/P.WSTNF,CTST  SET WSTN FLAG WITH EXIT VALUE

 WSTN     SUBR               ENTRY/EXIT
          LDN    10          SECONDS LIMITS (INCLUDES ID RECOVERY)
          STML   /TS/P.SECLIM,CTST
          RJM    UC          UPDATE THE TIME CLOCK
          LDDL   CLSEC       SET CURRENT TIME IN SECONDS
          STML   /TS/P.CLK,CTST
          LDML   WSTN        SAVE RETURN ADDRESS
          STML   /TS/P.SWSTN,CTST

 WSTN10   RJM    SWITCH      SWITCH TO OTHER TS TABLES
          LDML   /TS/P.SWSTN,CTST  RESTORE RETURN ADDRESS
          STML   WSTN
          LDN    2           REQUEST CLASS 2 INTERRUPT
          RJM    RI          REQUEST INTERRUPTS
          LDML   SELT,SLVN   CHECK IF INTERRUPT IS FROM THIS SLAVE
          LPDL   STATUS
          ZJN    WSTN15      IF NOT
          LDN    0
          UJN    WSTN1       EXIT A = 0

 WSTN15   LDN    5           REQUEST CLASS 1 OR 3 INTERRUPTS
          RJM    RI          REQUEST INTERRUPTS
          LDML   SELT,SLVN   CHECK IF INTERRUPT IS FROM THIS SLAVE
          LPDL   STATUS
          ZJN    WSTN20      IF NONE ACTIVE
          LDN    1
          UJK    WSTN1       CLASS 1 OR 3 ACTIVE, EXIT A = NZ

 WSTN20   RJM    UC          UPDATE THE TIME CLOCK
          LDDL   CLSEC       GET CURRENT SECONDS
          SBML   /TS/P.CLK,CTST  ELAPSED SECONDS
          PJN    WSTN30      IF CLOCK HAS NOT WRAPPED
          ADK    0#10000

 WSTN30   SBML   /TS/P.SECLIM,CTST  CHECK IF TIME LIMIT EXPIRED
          MJK    WSTN10      IF NOT
          LDK    E38         NO SLAVE INTERRUPT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- SPLOCK
*
** PURPOSE-- SETS THE PP REQUEST QUEUE LOCK IN THE
*            PP INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                     NZ, IF LOCK WAS NOT SET.
          SPACE  2
 SPLOCK   SUBR               ENTRY/EXIT
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDK    /PIT/C.LOCK OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET THE LOCKWORD
          UJK    SPLOCKX
          SPACE  5,15
** NAME-- CPLOCK
*
** PURPOSE-- CLEARS THE PP REQUEST QUEUE LOCK IN THE
*            PP INTERFACE TABLE.
          SPACE  2
 CPLOCK   SUBR               ENTRY/EXIT
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDK    /PIT/C.LOCK OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CPLOCKX
          SPACE  5,15
** NAME-- SULOCK
*
** PURPOSE-- SETS UNIT LOCKWORD IN UNIT INTERFACE TABLE
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                     NZ, IF LOCK WAS NOT SET.
          SPACE  2
 SULOCK   SUBR               ENTRY/EXIT
          LDK    UNITS+/UN/P.UIT  BUILD ADDRESS OF UIT
          ADDL   UX          INCREMENT BY THE INDEX
          STDL   T7          CURRENT UNIT INTERFACE TABLE ADDRESS
          LDK    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          UJK    SULOCKX
          SPACE  5,15
** NAME-- CULOCK
*
** PURPOSE-- CLEARS UNIT LOCKWORD IN UNIT INTERFACE TABLE.
          SPACE  2
 CULOCK   SUBR               ENTRY/EXIT
          LDK    UNITS+/UN/P.UIT  BUILD ADDRESS OF UIT
          ADDL   UX          INCREMENT BY THE INDEX
          STDL   T7          CURRENT UNIT INTERFACE TABLE ADDRESS
          LDK    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CULOCKX
          SPACE  5,15
** NAME-- SQLOCK
*
** PURPOSE-- SETS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                     NZ, IF LOCK WAS NOT SET.
          SPACE  2
 SQLOCK   SUBR               ENTRY/EXIT
          LDK    UNITS+/UN/P.UIT  BUILD ADDRESS OF UIT
          ADDL   UX          INCREMENT BY THE INDEX
          STDL   T7          CURRENT UNIT INTERFACE TABLE ADDRESS
          LDK    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          UJK    SQLOCKX
          SPACE  5,15
** NAME-- CQLOCK
*
** PURPOSE-- CLEARS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
          SPACE  2
 CQLOCK   SUBR               ENTRY/EXIT
          LDK    UNITS+/UN/P.UIT  BUILD ADDRESS OF UIT
          ADDL   UX          INCREMENT BY THE INDEX
          STDL   T7          CURRENT UNIT INTERFACE TABLE ADDRESS
          LDK    /UIT/C.QLOCK OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CQLOCKX
          SPACE  5,15
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
*
** NOTE-- THIS ROUTINE WILL ONLY RETURN WHEN THE CHANNEL LOCK IS OBTAINED.
          SPACE  2
 SCLOCK   SUBR               ENTRY/EXIT

 SCL10    BSS
          LDK    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CURCH       CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    SCL10       IF LOCK WAS NOT SET
          STDL   CLF         CHANNEL LOCK FLAG = LOCKED NOW
          UJK    SCLOCKX     EXIT, LOCK WAS SET
          SPACE  5,15
** NAME-- CCLOCK
*
** PURPOSE-- CLEARS CHANNEL LOCK.
          SPACE  2
 CCLOCK   SUBR               ENTRY/EXIT
          LDDL   CLF         CHECK IF CHANNEL IS LOCKED
          NJN    CCLOCKX     IF NOT RETURN
          LDK    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          STDL   CLF         CHANNEL LOCK FLAG = NOT LOCKED
          LDDL   CURCH       CHANNEL NUMBER = OFFSET IN TABLE
          STDL   T5
          RJM    CLOCK       CLEAR CHANNEL LOCKWORD
          UJK    CCLOCKX     EXIT
          SPACE  5,30
** NAME-- LOCK
*
** PURPOSE-- SET A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS SET.
*         A REGISTER .NE. O, IF THE LOCK COULD NOT BE SET.
*
** USES-- T1-T7
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T1 = 0, WRITE THE PP LOCKWORD TO CENTRAL MEMORY,
*            AS DESCRIBED IN THIS STEP.  ELSE IF T1 .NE. 0, GO TO
*            STEP 4.
*            TO WRITE THE PP LOCKWORD ID:
*            SET T1 - T4 = 8000 0000 0000 PPNO, WHERE PPNO IS THE
*            LOGICAL PP NUMBER OF THIS PP.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
*
*         4. IF T1 = 8000 AND T4 = PPNO, THIS LOCKWORD WAS ALREADY
*            RESERVED TO THIS PP.
*            RESTORE THE CENTRAL MEMORY LOCATION  (CWDL   T1).
*            SET THE A REGISTER = 0, AND EXIT.
*
*         5. IF T4 .NE. PPNO, THEN THIS LOCKWORD IS RESERVED TO
*            A DIFFERENT PROCESSOR.
*            SET BIT 16 OF THE LOCKWORD THAT WAS READ WITH THE
*            RDSL INSTRUCTION, AND WRITE THE CONTENTS BACK TO
*            CENTRAL MEMORY.
*            THE PURPOSE OF SETTING BIT 16 IS TO REQUEST THE
*            OTHER PROCESSOR TO GIVE UP THE LOCKWORD.
*            LDDL   T2
*            LPC    77777B
*            ADC    100000B
*            STDL   T2
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
          SPACE  4
 LOCK     SUBR               ENTRY/EXIT

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 LOCK10   BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.

          LDDL   T1
          ADDL   T4
          ZJN    LOCK40      IF LOCK CAN BE SET

* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJK    LOCK10      IF THIS PP WAS NOT FIRST TO WRITE
*                            THE INTERMEDIATE VALUE, REPEAT RDSL INSTRUCTION

* SET BIT 16 IN THE ORIGINAL CONTENTS OF CENTRAL MEMORY AND
* WRITE IT BACK TO CENTRAL MEMORY.

          LDDL   T2          SET THE 'REQUEST LOCKWORD' FLAG
          LPC    77777B
          ADC    100000B
          STDL   T2
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE LOCKWORD

          LDDL   T4
          SBDL   PPNO        CHECK IF LOCK ALREADY SET
          NJN    LOCK30      IF LOCK COULD NOT BE SET, EXIT A .NE. 0
          LDDL   T1
          ADC    -100000B
 LOCK30   UJK    LOCKX       IF LOCK WAS ALREADY SET, EXIT A = 0
                             IF LOCK COULD NOT BE SET, EXIT A .NE. 0

* SET THE LOCKWORD.

 LOCK40   BSS
          LDC    100000B
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          LDDL   PPNO
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          SET THE LOCKWORD
          LDN    0
          UJK    LOCK30      EXIT, A REGISTER = 0
          SPACE  5,20
** NAME-- CLOCK
*
** PURPOSE-- CLEAR A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS CLEARED.
*         A REGISTER .NE. O, IF THE LOCK WAS NOT CLEARED.
*
** USES-- T1-T7
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T4 .NE. PPNO, THIS LOCKWORD IS RESERVED TO A
*            DIFFERENT PROCESSOR.
*            RESTORE THE CONTENTS OF THIS CENTRAL MEMORY LOCATION
*            AS IT EXISTED BEFORE THE VALUE FFFF FFFF XXXX XXXX
*            WAS WRITTEN.
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
*
*         4. IF T4 = PPNO, THEN CLEAR THE LOCKWORD IN CENTRAL MEMORY.
*            SET T1 - T4 = 0000 0000 0000 0000.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
          SPACE  4
 CLOCK    SUBR               ENTRY/EXIT

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 CLK10    BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.
* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJK    CLK10       IF THIS PP WAS NOT FIRST TO WRITE
*                            THE INTERMEDIATE VALUE, REPEAT RSDL INSTRUCTION

          LDDL   T4          CHECK PP NUMBER
          SBDL   PPNO
          ZJN    CLK30       IF THIS PP HAS THE LOCK SET

* RESTORE THE ORIGINAL CONTENTS.

          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE ORIGINAL CONTENTS
          LDN    1
 CLK20    UJK    CLOCKX      EXIT, A REGISTER NONZERO

* CLEAR THE LOCKWORD.

 CLK30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          CLEAR THE LOCKWORD
          LDN    0
          UJK    CLK20       EXIT, A REGISTER = 0
          SPACE  5,20
** NAME-- SWFAIL
*
** PURPOSE-- REPORT A SOFTWARE FAILURE AND TERMINATE A REQUEST.
*
** ENTRY-- A REGISTER HAS INTERFACE ERROR CODE
*
** EXIT-- TO MAIN IDLE LOOP.
          SPACE  2
 SWFAIL   BSSZ   1           ENTRY ONLY  NO RETURN
          STDL   T7          SAVE ERRID VALUE
          LDN    0           NO IPI STATUS IN RESPONSE
          STML   RPB
          RJM    PAR         PREPARE ABNORMAL RESPONSE
          LDDL   T7
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LDK    /RS/K.INTERR  INTERFACE ERROR
          STML   RS+/RS/P.INTERR
          LDK    E120        SOFTWARE FAILURE
          STML   RS+/RS/P.ERRID
          RJM    CMDTERM     COMMAND TERMINATE  (NO RETURN)
          SPACE  5,20
** NAME-- SETSX
*
** PURPOSE-- SET SLAVE TABLE INDEX
*
** INPUT--SLVN CONTAINS CURRENT SLAVE ADDRESS
*
** OUTPUT-- SX SET
*           A = FACILITIES CONFIGURED ON THIS SLAVE
          SPACE  3
 SETSX    SUBR               ENTRY/EXIT
          LDDL   SLVN        GET SLAVE NUMBER
          SHN    2           POSITION IT
          STDL   SX          SET IT
          LDML   SLB+/SL/P.FBA,SX  GET CONFIGURED FACILITIES ON THIS SLAVE
          UJK    SETSXX      EXIT
          SPACE  2
          ERRNZ  4-P.SL      IF SL ENTRY IS NOT 4 PP WORDS LONG
          SPACE  5,20
** NAME-- SETUX
*
** PURPOSE-- SET UNITS TABLE INDEX
*
** INPUT--FACN CONTAINS CURRENT FACILITY ADDRESS
*         SX MUST ALREADY BE SET
*
** OUTPUT--UX SET
*          A = LOGICIAL UNIT NUMBER
          SPACE  2
 SETUX    SUBR               ENTRY/EXIT
          LDDL   SX          START WITH SLAVE OFFSET
          SHN    3           REPOSITION IT
          STDL   UX
          LDDL   FACN        GET FACILITY NUMBER
          SHN    2           POSITION IT
          RADL   UX          MERGE IT
          LDML   UNITS+/UN/P.LU,UX  GET LOGICIAL UNIT NUMBER
          UJK    SETUXX      EXIT
          SPACE  2
          ERRNZ  4-P.UN      IF UN ENTRY IS NOT 4 PP WORDS LONG
          ERRNZ  32-FACPSL*P.UN  IF MAX FACILITIES PER SLAVE IS NOT 8
          SPACE  5,20
** NAME-- INITNR
*
** PURPOSE-- INITIALIZE NEW UNIT REQUEST
*
** INPUT--NREQSN = NEW SLAVE NUMBER
*         NREQFN = NEW FACILITY NUMBER
*         CTST   = NEW TS TABLE INDEX
          SPACE  2
 INITNR   SUBR               ENTRY/EXIT
          LDN    0           CLEAR ASYNCHRONUS PROCESSING FLAG
          STDL   ASYNCP
          STML   RPB         CLEAR IPI RESPONSE PACKET BUFFER
          LDML   NREQSN      INIT SLVN
          STDL   SLVN
          RJM    SETSX       INIT SX INDEX
          LDML   NREQFN      INIT FACN
          STDL   FACN
          RJM    SETUX       INIT UX INDEX
          LDC    UNITS+/UN/P.UIT  BUILD POINTER TO UIT REFORMATTED RMA
          ADDL   UX
          STDL   T7          T7 = POINTER TO UIT RMA
          RJM    LDTS        LOAD TS TABLE WITH REQUEST FROM UIT
          LDDL   CTST        CHECK WHICH TS TO USE
          SBML   TS2
          NJN    INITNR1     IF NOT TS2
          LDDL   TIU         SET TS2 BIT IN TS TABLES IN USE
          LPN    75B
          ADN    2
          UJN    INITNR9     CONT.
 INITNR1  BSS
          LDDL   TIU         SET TS3 BIT IN TS TABLES IN USE
          LPN    73B
          ADN    4
 INITNR9  BSS
          STDL   TIU         SAVE UPDATED TS TABLES IN USE
          RJM    INTS        INIT TS TABLE
          UJK    INITNRX     EXIT
          SPACE  5,20
** NAME-- CLREQ
*
** PURPOSE-- CLEAR THE CURRENT REQUEST FROM THE ACTIVE TS TABLE
*            AND UNLOCK UNIT LOCKWORD.
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 CLREQ1   LDML   /TS/P.SCLREQ,CTST  RESTORE RETURN ADDRESS
          STML   CLREQ
          RJM    CLRTS       CLEAR TS TABLE

 CLREQ    SUBR               ENTRY/EXIT
          LDML   CLREQ       SAVE RETURN ADDRESS
          STML   /TS/P.SCLREQ,CTST
          LDDL   CTST        CLR TS TABLE IN USE BIT
          SBML   TS1
          ZJN    CLREQ10     IF PP TABLE IN USE
          ADK    -P.TS
          ZJN    CLREQ20     IF TS2 IN USE
          UJN    CLREQ30     IF TS3 IN USE
 CLREQ10  BSS
          LDN    0
          STDL   TIU         CLEAR ALL TS TABLES IN USE
          STDL   ASYNCP      CLEAR ASYNCHRONUS PROCESSING FLAG
          UJN    CLREQ1      EXIT
 CLREQ20  BSS
          RJM    CFC         CHECK FOR CHAINING STILL
          LDDL   TIU         CLEAR TS2 IN USE
          LPN    75B
          UJN    CLREQ90     CONT.
 CLREQ30  BSS
          RJM    CFC         CHECK FOR CHAINING STILL
          LDDL   TIU         CLEAR TS3 IN USE
          LPN    73B
 CLREQ90  BSS
          STDL   TIU         RESTORE TIU
          RJM    CULOCK      UNLOCK UNIT LOCKWORD IN UIT
          LDN    0
          STDL   ASYNCP      CLEAR ASYNCHRONUS PROCESSING FLAG
          STML   RPB         CLR ACTIVE IPI RESPONSE LENGTH
          STML   SLB+/SL/P.SIU,SX  CLR SLAVE IN USE FLAG
          LDML   SLB+/SL/P.FACLCK,SX  CLEAR FACILITY LOCKED FLAG
          LPN    77B
          STML   SLB+/SL/P.FACLCK,SX
          UJK    CLREQ1      EXIT
          SPACE  2
          ERRNZ  2-MCSLV     IF NUMBER OF CONCURRENT SLAVE TS TABLES CHANGE
          SPACE  5,20
** NAME-- SAVETAB
*
** PURPOSE-- SAVE THE CURRENT TS TABLE FOR USE LATER
*
** INPUT--CTST = CURRENT TS TABLE IN USE
          SPACE  2
 SAVETAB  SUBR               ENTRY/EXIT
          LDK    /TS/P.SAVEDC  BUILD DESTINATAION ADDRESS
          ADDL   CTST
          STML   SAVTA
          LDN    0           INIT LOOP COUNTER
          STDL   T1

 SAVT10   LDML   SAVEFWA,T1  GET DIRECT CELL TO SAVE
          STML   *,T1        SAVE IT
 SAVTA    EQU    *-1
          AODL   T1
          SBN    SAVELWA+1-SAVEFWA  CHECK FOR DONE
          NJN    SAVT10      IF NOT, LOOP
          UJN    SAVETABX    ELSE EXIT
          SPACE  5,20
** NAME-- RELDTAB
*
** PURPOSE-- RELOAD A SAVED TS TABLE FOR USE NOW
*
** INPUT--CTST = TS TABLE TO RELOAD
          SPACE  2
 RELDTAB  SUBR               ENTRY/EXIT
          LDK    /TS/P.SAVEDC  BUILD SOURCE ADDRESS
          ADDL   CTST
          STML   RELDTA
          LDN    0           INIT LOOP COUNTER
          STDL   T1

 RELDT10  LDML   *,T1        GET SAVED DIRECT CELL
 RELDTA   EQU    *-1
          STML   SAVEFWA,T1  PUT IT BACK IN DIRECT CELL
          AODL   T1          CHECK FOR DONE
          SBN    SAVELWA+1-SAVEFWA
          NJN    RELDT10     IF NOT, LOOP
          UJN    RELDTABX    ELSE, EXIT
          SPACE  5,20
** NAME-- INTS
*
** PURPOSE-- INITIALIZE TS TABLE
*
** INPUT-- CTST,SLVN AND FACN INITIALIZED
*
          SPACE  2
 INTS     SUBR               ENTRY/EXIT
          LDDL   SLVN        SET SLAVE NUMBER
          SHN    8
          STML   /TS/P.SN,CTST
          LDDL   FACN        SET FACILITY NUMBER
          RAML   /TS/P.FN,CTST
          UJK    INTSX       EXIT
          SPACE  5,20
** NAME-- CLRTS
*
** PURPOSE-- CLEAR TS TABLE
*
** INPUT-- CTST INITIALIZED
*
          SPACE  2
 CLRTS    SUBR               ENTRY/EXIT
          LDK    /TS/P.SAVEDC  NUMBER OF WORDS TO CLEAR
          STDL   T1
          LDDL   CTST        TS TABLE FWA
          STDL   T2

 CLRTS10  LDN    0           CLEAR TS TABLE ENTRY
          STIL   T2
          AODL   T2          INCREMENT ADDRESS
          SODL   T1          DECREMENT COUNTER
          NJN    CLRTS10     LOOP IF NOT DONE
          STML   /TS/P.RQB+/RQ/P.LU,CTST  CLEAR LOGICIAL UNIT NUMBER
          UJN    CLRTSX      EXIT
          SPACE  5,20
** NAME-- CLRPTS
*
** PURPOSE-- CLEAR PARTIAL TS TABLE
*
** INPUT-- CTST INITIALIZED
*
          SPACE  2
 CLRPTS   SUBR               ENTRY/EXIT
          LDN    0           CLEAR SELECTED TS TABLE ENTRIES
          STIL   CTST
          STML   /TS/P.LASTC,CTST
          STML   /TS/P.XFER,CTST
          STML   /TS/P.XFER+1,CTST
          STML   /TS/P.SCOND,CTST
          STML   /TS/P.FACSTA,CTST
          STML   /TS/P.NSWC,CTST
          STML   /TS/P.NSRC,CTST
          STML   /TS/P.OTFC,CTST
          STML   /TS/P.BIDBP,CTST
          STML   /TS/P.RTCIP,CTST
          STML   /TS/P.RTCOP,CTST
          UJN    CLRPTSX     EXIT
          SPACE  5,20
** NAME-- LDTS
*
** PURPOSE-- LOAD TS TABLE WITH CURRENT REQUEST, INITIALIZE TS TABLE
*            ENTRIES AND UPDATE PIT/UIT NEXT PVA-RMA AND UNLOCK QUEUE.
*
** INPUT--T7 = ADDRESS OF REFORMATTED CM ADDRESS OF EITHER PIT OR UIT.
*
          SPACE  2
 LDTS     SUBR               ENTRY/EXIT
*         GET THE PVA/RMA OF THE REQUEST
          LDDL   CTST        BUILD CRML ADDRESS
          ADK    /TS/P.CPVACM
          STML   LDTSA
          LOADR  0,T7        LOAD R AND A OF PIT OR UIT
          ADK    /PIT/C.PPQPVA  OFFSET TO REQUEST PVA/RMA
          CRML   *,TWO       READ THE PVA/RMA OF THE QUEUED REQUEST
                             INTO SELECTED TS TABLE LOCATION CPVACM
 LDTSA    EQU    *-1
*         GET THE REQUEST HEADER
          LDDL   CTST        BUILD CRML/CWML ADDRESSES
          ADK    /TS/P.RQB
          STML   LDTSB
          STML   LDTSC
          ADK    /TS/P.CQB-/TS/P.RQB  ANOTHER CRML ADDRESS
          STML   LDTSD
          LDK    /RQ/C.SECADR+1  LENGTH OF REQUEST HEADER
          STDL   WC
          LOADF  /TS/P.CREQ,CTST  LOAD R AND A OF REQUEST
          CRML   *,WC        READ THE REQUEST HEADER
                             INTO SELECTED TS TABLE LOCATIONS RQB
 LDTSB    EQU    *-1
*         UPDATE THE NEXT PVA/RMA
          LOADR  0,T7        LOAD R AND A OF PIT OR UIT
          ADK    /PIT/C.PPQPVA  OFFSET TO NEXT PVA/RMA
          CWML   *,TWO       RESET TO NEXT PVA/RMA IN PIT OR UIT
 LDTSC    EQU    *-1
*         CLEAR THE PIT/UIT QUEUE LOCKWORD
          LDK    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE PIT/UIT LOCKWORD
*         GET THE REQUEST COMMANDS
          LDML   /TS/P.RQB+/RQ/P.LEN,CTST  REQUEST LENGTH IN BYTES
          SHN    -3          TO CM WORDS
          SBN    /RQ/C.SECADR+1  DECREMENT BY HEADER LENGTH
          ZJN    *           IF NO COMMANDS
          STML   /TS/P.NUMCM,CTST  SAVE NUMBER OF COMMANDS
          STDL   WC
          LOADF  /TS/P.CREQ,CTST  LOAD R AND A OF REQUEST
          ADK    /RQ/C.SECADR+1  OFFSET TO COMMANDS
          CRML   *,WC        READ COMMANDS
                             INTO SELECTED TS TABLE LOCATIONS CQB
 LDTSD    EQU    *-1
          UJK    LDTSX       EXIT
          SPACE  5,20
** NAME-- PTW
*
** PURPOSE-- PATH TEST WRITING
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 PTW1     LDML   /TS/P.SPTW,CTST  RESTORE RETURN ADDRESS
          STML   PTW

 PTW      SUBR               ENTRY/EXIT
          LDML   PTW         SAVE RETURN ADDRESS
          STML   /TS/P.SPTW,CTST
          RJM    GDP         GENERATE DATA PATTERN
          AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          STML   PTWCP1
          LDDL   SLVN        BUILD ADDRESSEE
          SHN    8
          ADDL   FF          NO FACILITY ADDRESS
          STML   PTWCP5
          LDN    0           USE BUFFER 0 FIRST
          STML   PTWCPD
          RJM    PTWOD       OUTPUT TO FIRST DATA BUFFER
          AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          STML   PTWCP1
          LDN    1           USE BUFFER 1 NOW
          STML   PTWCPD
          RJM    PTWOD       OUTPUT TO SECOND DATA BUFFER
          UJK    PTW1        EXIT OK
          SPACE  5,20
*         -WRITE TO BUFFER-  COMMAND PACKET
 PTWCP    DATA   0#0014      PACKET LENGTH
 PTWCP1   DATA   0#FFFF      CMD REFERENCE NUMBER
          CON    OCWTB+CMCHN  OP-CODE AND CHAIN
 PTWCP5   DATA   0#00FF      ADDRESSEE
          CON    CPBCE       CMD EXTENT PARAM
          DATA   0#0000       COUNT
          DATA   0#1020       COUNT = 4128(DEC) BYTES
 PTWCPD   DATA   0#0000       DATA ADDRESS = BUFFER 0
          DATA   0#0000       DATA ADDRESS = 0
          CON    CPBA        BUFFER ADDRESS PARAM
          DATA   0#8020       GENERIC, SLAVE DATA BUFFER
          SPACE  5,20
** NAME-- PTR
*
** PURPOSE-- PATH TEST READING
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 PTR1     LDML   /TS/P.SPTR,CTST  RESTORE RETURN ADDRESS
          STML   PTR

 PTR      SUBR               ENTRY/EXIT
          LDML   PTR         SAVE RETURN ADDRESS
          STML   /TS/P.SPTR,CTST
          AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          STML   PTRCP1
          LDC    OCRFB+CMCHN  OP-CODE AND CHAIN
          STML   PTRCP3
          LDDL   SLVN        BUILD ADDRESSEE
          SHN    8
          ADDL   FF          NO FACILITY
          STML   PTRCP5
          LDN    0           USE BUFFER 0 FIRST
          STML   PTRCPD
          RJM    PTRID       INPUT FIRST BUFFER
          RJM    VDP         VERIFY DATA PATTERN
          NJN    PTR10       IF DATA ERROR
          AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          STML   PTRCP1
          LDC    OCRFB       OP-CODE AND END OF CHAIN
          STML   PTRCP3
          LDN    1           USE BUFFER 1
          STML   PTRCPD
          RJM    PTRID       INPUT SECOND BUFFER
          RJM    VDP         VERIFY DATA PATTERN
          ZJK    PTR1        IF OK, EXIT
 PTR10    LDK    E110        MASTER-SLAVE DATA INTEGRITY ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING  (NO RETURN)
          SPACE  5,12
*         -READ FROM BUFFER-  COMMAND PACKET
 PTRCP    DATA   0#0014      PACKET LENGTH
 PTRCP1   DATA   0#FFFF      CMD REFERENCE NUMBER
 PTRCP3   CON    OCRFB+CMCHN  OP-CODE AND CHAIN
 PTRCP5   DATA   0#00FF      ADDRESSEE
          CON    CPBCE       CMD EXTENT PARAM
          DATA   0#0000       COUNT
          DATA   0#1020       COUNT = 4128(DEC) BYTES
 PTRCPD   DATA   0#0000       DATA ADDRESS = BUFFER 0
          DATA   0#0000       DATA ADDRESS = 0
          CON    CPBA        BUFFER ADDRESS PARAM
          DATA   0#8020       GENERIC, SLAVE DATA BUFFER
          SPACE  5,20
** NAME-- GDP
*
** PURPOSE-- GENERATE DATA PATTERN IN CM PP COMMUNICATIONS BUFFER
*
** USES-- T1-T4 = DATA
*         T7 = INCREMENT VALUE
*         T8 = COUNTER
*         P5-P6 = CM RMA
          SPACE  2
 GDP      SUBR               ENTRY/EXIT
          LDDL   CM.COM+1    USE PP COMMUNICATIONS BUFFER
          ADN    /CB/C.PTD   OFFSET TO PATH TEST DATA AREA
          STDL   P6          SAVE IT IN WORKING CELL
          SHN    -16
          ADDL   CM.COM
          STDL   P5          SAVE REST OF RMA
          LDN    4           LOOP COUNT
          STDL   T8
          LDC    0#FFFF      DATA SEED
          UJN    GDP12

*         PATTERN = FFFF 7FFF 3FFF 1FFF
*                   0FFF 07FF 03FF 01FF
*                   00FF 007F 003F 001F
*                   000F 0007 0003 0001
 GDP10    LDDL   T4          CONTINUE FROM LAST VALUE
          SHN    -1
 GDP12    STDL   T1          FIRST PP WORD
          SHN    -1
          STDL   T2          SECOND PP WORD
          SHN    -1
          STDL   T3          THIRD PP WORD
          SHN    -1
          STDL   T4          FOURTH PP WORD
          RJM    GDP100      GO WRITE IT INTO CM
          SODL   T8          CHECK FOR DONE
          NJN    GDP10       IF NOT

          LDC    0#0202      INCREMENT VALUE
          STDL   T7
          LDN    32          LOOP COUNT
          STDL   T8
          LDN    1           SEED = 0001
          UJN    GDP22

*         PATTERN = 0001 0203 ETC. (INCREMENTING 8-BIT PATTERN)
 GDP20    LDDL   T4          CONTINUE FROM LAST VALUE
          ADDL   T7
 GDP22    STDL   T1          FIRST PP WORD
          ADDL   T7
          STDL   T2          SECOND PP WORD
          ADDL   T7
          STDL   T3          THIRD PP WORD
          ADDL   T7
          STDL   T4          FOURTH PP WORD
          RJM    GDP100      GO WRITE IT INTO CM
          SODL   T8          CHECK FOR DONE
          NJN    GDP20       IF NOT

          LDC    0#0101      INCREMENT VALUE
          STDL   T7
          LDC    64          LOOP COUNT
          STDL   T8
          LDN    0           SEED = 0000
          UJN    GDP32

*         PATTERN = 0000 0101 ETC. (DOUBLE BYTE INCREMENTING 8-BIT PATTERN)
 GDP30    LDDL   T4          CONTINUE FROM LAST VALUE
          ADDL   T7
 GDP32    STDL   T1          FIRST PP WORD
          ADDL   T7
          STDL   T2          SECOND PP WORD
          ADDL   T7
          STDL   T3          THIRD PP WORD
          ADDL   T7
          STDL   T4          FOURTH PP WORD
          RJM    GDP100      GO WRITE IT INTO CM
          SODL   T8          CHECK FOR DONE
          NJN    GDP30       IF NOT

          LDC    416         WORD COUNT
          STDL   T8

*         PATTERN = AAAA 5555 AAAA 5555
          LDC    0#AAAA      A = AAAA
          STDL   T1
          STDL   T3
          SHN    -1          A = 5555
          STDL   T2
          STDL   T4
 GDP40    RJM    GDP100      WRITE IT TO CM
          SODL   T8          CHECK FOR DONE
          NJN    GDP40       IF NOT

          UJK    GDPX        EXIT
          SPACE  2
 GDP100   SUBR               ENTRY/EXIT
          LOADC  P5          LOAD R+A
          CWDL   T1          WRITE PATTERN INTO CM
          AODL   P6          UPDATE RMA
          SHN    -16
          RADL   P5
          UJN    GDP100X     EXIT
          SPACE  5,20
** NAME-- VDP
*
** PURPOSE-- VERIFY DATA PATTERN
*
** EXIT-- A = 0  NO ERROR
*             NZ DATA MISCOMPARE ERROR
*
** USES-- T1-T4 = DATA
*         T6 = INCREMENT VALUE
*         T7 = EXPECTED VALUE
*         T8 = COUNTER
*         P5-P6 = CM RMA
          SPACE  2
 VDP      SUBR               ENTRY/EXIT
          LDDL   CM.COM+1    DATA IS IN PP COMMUNICATIONS BUFFER
          ADN    /CB/C.PTD   OFFSET TO PATH TEST DATA
          STDL   P6          SAVE IN WORKING CELL
          SHN    -16
          ADDL   CM.COM
          STDL   P5          REMAINING RMA

          LCN    0
          STDL   T7          SEED = FFFF
          LDN    4           WORD COUNT
          STDL   T8

*         PATTERN = FFFF 7FFF 3FFF 1FFF
*                   0FFF 07FF 03FF 01FF
*                   00FF 007F 003F 001F
*                   000F 0007 0003 0001
 VDP10    RJM    VDP100      GET DATA WORD
          LDDL   T7
          LMDL   T1          COMPARE FIRST PP WORD
          NJN    VDP15       IF ERROR
          LDDL   T7          BUILD NEXT EXPECTED PP WORD
          SHN    -1
          STDL   T7
          LMDL   T2          COMPARE SECOND PP WORD
          NJN    VDP15
          LDDL   T7
          SHN    -1
          STDL   T7
          LMDL   T3          COMPARE THIRD PP WORD
          NJN    VDP15
          LDDL   T7
          SHN    -1
          STDL   T7
          LMDL   T4          COMPARE FOURTH PP WORD
          NJN    VDP15
          LDDL   T7
          SHN    -1
          STDL   T7
          SODL   T8          CHECK FOR DONE
          NJK    VDP10       IF NOT
          UJN    VDP19       CONT.

 VDP15    LJM    VDPX        ERROR EXIT

 VDP19    BSS
          LDC    0#0202      INCREMENT VALUE
          STDL   T6
          LDN    1           SEED = 0001
          STDL   T7
          LDN    32          WORD COUNT
          STDL   T8

*         PATTERN = 0001 0203 ETC. (INCREMENTING 8-BIT PATTERN)
 VDP20    RJM    VDP100      GET DATA WORD
          LDDL   T7          EXPECTED VALUE
          LMDL   T1          COMPARE FIRST PP WORD
          NJN    VDP15       IF ERROR
          LDDL   T6          BUILD NEXT EXPECTED VALUE
          RADL   T7
          LMDL   T2          COMPARE SECOND PP WORD
          NJN    VDP15
          LDDL   T6
          RADL   T7
          LMDL   T3          COMPARE THIRD PP WORD
          NJN    VDP15
          LDDL   T6
          RADL   T7
          LMDL   T4          COMPARE FOURTH PP WORD
          NJN    VDP15
          LDDL   T6
          RADL   T7
          SODL   T8          CHECK FOR DONE
          NJK    VDP20       IF NOT

          LDC    0#0101      INCREMENT VALUE
          STDL   T6
          LDN    0           SEED = 0000
          STDL   T7
          LDC    64          WORD COUNT
          STDL   T8

*         PATTERN = 0000 0101 ETC. (DOUBLE BYTE INCREMENTING 8-BIT PATTERN)
 VDP30    RJM    VDP100      GET DATA WORD
          LDDL   T7          EXPECTED VALUE
          LMDL   T1          COMPARE FIRST PP WORD
          NJN    VDP35       IF ERROR
          LDDL   T6          BUILD NEXT EXPECTED VALUE
          RADL   T7
          LMDL   T2          COMPARE SECOND PP WORD
          NJN    VDP35
          LDDL   T6
          RADL   T7
          LMDL   T3          COMPARE THIRD PP WORD
          NJN    VDP35
          LDDL   T6
          RADL   T7
          LMDL   T4          COMPARE FOURTH PP WORD
          NJN    VDP35
          LDDL   T6
          RADL   T7
          SODL   T8          CHECK FOR DONE
          NJK    VDP30       IF NOT
          UJN    VDP39       CONT.

 VDP35    LJM    VDPX        ERROR EXIT

 VDP39    BSS
          LDC    0#AAAA      A = AAAA
          STDL   T6          T6 = FIRST AND THIRD EXPECTED PP WORDS
          SHN    -1          A = 5555
          STDL   T7          T7 = SECOND AND FOURTH EXPECTED PP WORDS
          LDC    416         WORD COUNT
          STDL   T8

*         PATTERN = AAAA 5555 AAAA 5555
 VDP40    RJM    VDP100      GET CM WORD
          LDDL   T6          GET EXPECTED
          LMDL   T1          COMPARE FIRST
          NJN    VDP35       IF ERROR
          LDDL   T7          GET EXPECTED
          LMDL   T2          COMPARE SECOND
          NJN    VDP35
          LDDL   T6          GET EXPECTED
          LMDL   T3          COMPARE THIRD
          NJN    VDP35
          LDDL   T7          GET EXPECTED
          LMDL   T4          COMPARE FOURTH
          NJN    VDP35
          SODL   T8          CHECK FOR DONE
          NJK    VDP40       IF NOT

          LJM    VDPX        EXIT OK, A=0
          SPACE  2
 VDP100   SUBR               ENTRY/EXIT
          LOADC  P5          LOAD R+A
          CRDL   T1          GET ONE CM WORD
          AODL   P6          UPDATE RMA
          SHN    -16
          RADL   P5
          UJN    VDP100X     EXIT
          SPACE  5,20
** NAME-- RERESP
*
** PURPOSE-- PROCESS RESUME RESPONSE
*
          SPACE  2
 RERESP   SUBR               ENTRY/EXIT
          LDN    0           NO IPI STATUS IN RESPONSE
          STML   RPB
          RJM    PNR         PREPARE NORMAL RESPONSE
          RJM    RESP        SEND RESPONSE
          UJN    RERESPX     EXIT
          SPACE  4,20
** NAME-- PNR
*
** PURPOSE-- PREPARE NORMAL RESPONSE
          SPACE  2
 PNR      SUBR               ENTRY/EXIT
          RJM    BBR         BUILD BASIC RESPONSE
          RJM    MVBID       MOVE BLOCK ID BUFFER TO RESPONSE
          LDK    R.NRM       NORMAL RESPONSE
          STML   RS+/RS/P.RC
          UJK    PNRX        EXIT
          SPACE  4,20
** NAME-- PAR
*
** PURPOSE-- PREPARE ABNORMAL RESPONSE
          SPACE  2
 PAR      SUBR               ENTRY/EXIT
          RJM    BBR         BUILD BASIC RESPONSE
          RJM    MVBID       MOVE BLOCK ID BUFFER TO RESPONSE
          LDK    R.ABN       ABNORMAL RESPONSE
          STML   RS+/RS/P.RC
          UJK    PARX        EXIT
          SPACE  4,10
** NAME-- PUR
*
** PURPOSE-- PREPARE UNSOLICITED RESPONSE
          SPACE  2
 PUR      SUBR               ENTRY/EXIT
          RJM    BBR         BUILD BASIC RESPONSE
          LDK    R.UNS       UNSOLICITED RESPONSE CODE
          STML   RS+/RS/P.RC
          UJK    PURX        EXIT
          SPACE  5,30
** NAME-- BBR
*
** PURPOSE-- BUILD BASIC RESPONSE

 BBR      SUBR               ENTRY/EXIT
          LDN    C.RS-/RS/C.ABALRT  ZERO OUT MOST OF RESPONSE BUFFER
          STDL   T5          NUMBER OF CM ZERO WORDS TO USE
          LOADC  CM.COM      USE PP COMMUNICIATIONS BUFFER
          ADN    /CB/C.ZEROES  START FORM CLEARED AREA
          CRML   RS+/RS/P.ABALRT,T5  CLEAR FROM C.ABALRT TO THE END

          LDML   /TS/P.CPVA,CTST   PVA OF REQUEST
          STML   RS+/RS/P.PVA
          LDML   /TS/P.CPVA+1,CTST
          STML   RS+/RS/P.PVA+1
          LDML   /TS/P.CPVA+2,CTST
          STML   RS+/RS/P.PVA+2

          LDML   /TS/P.CREQ,CTST  RMA OF REQUEST
          STML   RS+/RS/P.REQ
          LDML   /TS/P.CREQ+1,CTST
          STML   RS+/RS/P.REQ+1

          LDK    NRL         NORMAL RESPONSE LENGTH IN BYTES
          STML   RS+/RS/P.RESPL
          LDML   RPB         CHECK IF IPI RESPONSE IS TO BE INCLUDED
          LPC    377B        INSURE VALID LENGTH
          ZJN    BBR10       IF NOT
          ADN    9           INCREMENT FOR PACKET LENGTH BYTES AND
*                            TO ROUND UP TO CM WORD BOUNDARY
          LPK    -7
          RAML   RS+/RS/P.RESPL  INCREMENT RESPONSE LENGTH
 BBR10    LDML   /TS/P.RQB+/RQ/P.LU,CTST  LOGICIAL UNIT NUMBER
          STML   RS+/RS/P.LU

          LDML   /TS/P.RQB+/RQ/P.RECOV,CTST  R/I AND PRIORITY
          STML   RS+/RS/P.RECOV

          LDML   /TS/P.RQB+/RQ/P.LONGB,CTST   ALERT MASK
          STML   RS+/RS/P.LONGB

          LDML   /TS/P.XFER,CTST   BYTES TRANSFERRED
          STML   RS+/RS/P.XFER
          LDML   /TS/P.XFER+1,CTST
          STML   RS+/RS/P.XFER+1

          LDML   /TS/P.CREQ,CTST  CHECK IF A REQUEST IS LOADED
          ADML   /TS/P.CREQ+1,CTST
          ZJK    BBRX        IF NOT BYPASS LAST CMD RMA
          LDML   /TS/P.CREQ+1,CTST  BUILD RMA OF LAST COMMAND
          ADN    B.RQ        OFFSET TO FIRST COMMAND
          ADML   /TS/P.LASTC,CTST
          STML   RS+/RS/P.LASTC+1  2ND HALF RMA
          SHN    -16
          ADML   /TS/P.CREQ,CTST
          STML   RS+/RS/P.LASTC    1ST HALF RMA

          LDML   /TS/P.FACSTA,CTST  MOVE FACILITY STATUS ID52, IF ANY
          ZJK    BBRX        IF NONE, EXIT
          STML   RS+/RS/P.FACSTA
          LDML   /TS/P.FACSTA+1,CTST
          STML   RS+/RS/P.FACSTA+1

          UJK    BBRX        EXIT
* ENSURE THAT THE NUMBER OF ZERO BYTES IN THE PP COMMUNIAATION BUFFER
* IS ENOUGH TO CLEAR THE RESPONSE BUFFER.
          ERRNG  /CB/B.ZEROES-B.RS+/RS/P.ABALRT*2
          SPACE  5,30
** NAME-- MVBID
*
** PURPOSE-- MOVE BLOCK ID FROM TS TABLE TO RESPONSE BUFFER.
*
          SPACE  4
 MVBID    SUBR               ENTRY/EXIT
          LDML   /TS/P.BIDBP,CTST  GET THE POINTER
          ZJN    MVBIDX      IF NONE TO MOVE
          STML   RS+/RS/P.IOR+MBID+1  PUT POINTER IN RESPONSE
          STDL   T1          COUNT TO MOVE
          LDML   /TS/P.OTFC,CTST  GET ON-THE-FLY CORRECTION COUNT
          STML   RS+/RS/P.IOR+MBID  PUT IN RESPONSE
          LDK    /TS/P.BIDB  BUILD SOURCE ADDRESS
          ADDL   CTST
          STDL   T2          T2 HAS SOURCE ADDRESS
          LDK    RS+/RS/P.IOR
          STDL   T3          T3 IS DESTINATION ADDRESS

 MVBID10  LDIL   T2          GET BLOCK ID ENTRY
          STIL   T3          PUT IT INTO RESPONSE
          SODL   T1          DECREMENT COUNT
          ZJN    MVBIDX      IF DONE EXIT
          AODL   T2          INCREMENT SOURCE ADDRESS
          AODL   T3          INCREMENT DESTINATION ADDRESS
          UJN    MVBID10     LOOP
          SPACE  2
          ERRNZ  30-MBID     IF MAX NUMBER OF BLOCK ID CHANGE
          SPACE  5,30
** NAME-- RESP
*
** PURPOSE-- WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
*
** INPUT-- CM.PIT, CM.RS, LIM, /PIT/IN, /PIT/OUT, RS+/RS/P.RESPL
*
** OUTPUT-- /PIT/IN, RESPONSE BUFFER
          SPACE  2
 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  2
 RESP     SUBR               ENTRY/EXIT

* READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RESP10   LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADK    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ  OUT  POINTER INTO P5
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF  IN  POINTER
          CRDL   P1          READ  IN  POINTER INTO P4

* CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDDL   INP
          SBDL   OUTP
          MJN    RESP20      IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP

 RESP20   LDML   RS+/RS/P.RESPL  GET RESPONSE LENGTH
          STDL   T1
          LDN    0
          STDL   T2          FLAG TO DETERMINE IF 1 OR 2 BLOCK WRITES
          LDDL   INP
          RADL   T1          IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          PJK    RESP10      IN NOT ENOUGH ROOM IN BUFFER, LOOP
          LDDL   T1
          SBDL   LIM
          MJN    RESP40      IF IN + RESPONSE LENGTH .LT. LIMIT
          STDL   T1          IN + RESPONSE LENGTH - LIMIT = NEW  IN  POINTER
          AODL   T2          2 BLOCK WRITES REQUIRED

* WRITE RESPONSE TO CM.

 RESP40   BSS
          LDDL   INP
          SHN    -3
          STDL   T3           IN  POINTER IN WORDS
          LDML   RS+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          STDL   T5
          LDDL   T2
          ZJN    RESP50      IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADK    RS
          STML   RESPA       RESPONSE ADDRESS FOR 2ND BLOCK WRITE

 RESP50   LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD  IN  OFFSET
          CWML   RS,T4       WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          SBDL   T4
          ZJN    RESP70      IF ONLY 1 BLOCK WRITE REQUIRED
          STDL   T5          RESPONSE LENGTH - (LIMIT - IN)
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
 RESPA    EQU    *-1         (BEGINNING OF RESPONSE BUFFER)

 RESP70   LDDL   T1          NEW IN POINTER
          STDL   P4

* SET UP INTERRUPT PROCESSOR INSTRUCTION IF INTERRUPT IS SELECTED.

          LDML   RS+/RS/P.INT  CHECK IF INTERRUPT WAS SELECTED
          LPK    /RS/K.INT
          NJN    RESP80      IF INTERRUPT SELECTED
          LDK    PSNI        PSN INSTRUCTION
          UJN    RESP90

 RESP80   BSS
          LDML   RS+/RS/P.PORT  GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RS/L.PORT+/RS/N.PORT
          LPK    /RS/M.PORT
          ADK    INPNI       INPN INSTRUCTION

 RESP90   STML   INTPRC

*  WRITE UPDATED  IN  POINTER FOR CM RESPONSE BUFFER TO PIT.

          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADK    /PIT/C.IN   OFFSET OF  IN  POINTER
          CWDL   P1          WRITE NEW  IN  POINTER TO CM

*  INTERRUPT PROCESSOR.

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   PPNO-3      SET LAST BYTE NON-ZERO
          LDN    0           SET (A)=0 FOR S0 MAINFRAME

 INTPRC   INPN   1           INTERRUPT OR PSN
          LDN    0           CLEAR IPI RESPONSE LENGTH
          STML   RPB
          LJM    RESPX       EXIT
          SPACE  5,20
** NAME - CHGCH
*
** PURPOSE - CHANGE CHANNEL NUMBER IN CHANNEL INSTRUCTIONS
*
** INPUT - (CURCH) = CHANNEL NUMBER.
*          (A) = CHANNEL TABLE ADDRESS.
*
          SPACE  4
 CHGCH    SUBR               ENTRY/EXIT
          STDL   T1          SET ADDRESS MODIFICATION LIST ADDRESS

 CHG10    LDIL   T1          READ LIST WORD
          ZJN    CHGCHX      IF END OF LIST
          STDL   T2          SET INSTRUCTION ADDRESS
          LDIL   T2          READ INSTRUCTION WORD
          SCN    37B         CLEAR CHANNEL BITS
          LMDL   CURCH       REPLACE WITH NEW CHANNEL
          STIL   T2
          AODL   T1          INCREMENT TO NEXT INSTRUCTION
          UJN    CHG10       LOOP
          SPACE  5,20
** NAME-- SFP
*
** PURPOSE-- SEARCH FOR PARAMETER IDENTIFICATION IN RESPONSE PACKET
*
** INPUT
*         A = ID TO SEARCH FOR
** OUTPUT
*         A = POSITIVE IF ID FOUND
*         T3 = POINTER TO ID IF IT IS FOUND (RPB+5,T3)
          SPACE  2
 SFP      SUBR               ENTRY/EXIT
          STDL   T1          PARAMETER TO SEARCH FOR
          LDN    0
          STDL   T3          POINTER TO ID BEING SEARCHED FOR
          LDML   RPB
          ADN    1
          SHN    -1
          SBN    5           LENGTH OF MINIMUM RESPONSE PACKET
 SFP4     BSS
          STDL   T2          POINTER TO END OF PARAMETERS
          MJN    SFPX        EXIT, NO ID FOUND
          LDML   RPB+5,T3
          LMDL   T1
          LPDL   FF
          ZJN    SFPX        IF ID FOUND
          LDML   RPB+5,T3
          SHN    -9
          ADN    1           ADJUST FOR ODD BYTE
          STDL   T4          WORD LENGTH OF PARAMETER
          RADL   T3          UPDATE POINTER TO ID BEING SEARCHED FOR
          LDDL   T2
          SBDL   T4
          UJN    SFP4
          SPACE  5,20
** NAME-- PCER
*
** PURPOSE-- PREPARE COMMON ERROR RESPONSE
*
** INPUT  A = ERROR ID
          SPACE  2
 PCER     SUBR               ENTRY/EXIT
          STDL   P2
          SBN    E20
          ZJN    PCER10      IF ERROR CODE 20
          SBN    E22-E20
          MJN    PCER20      IF ERROR CODE 0-19, 21
          SBN    E23-E22
          MJN    PCER10      IF ERROR CODE 22
          SBN    E27-E23
          MJN    PCER20      IF ERROR CODE 23-26
          SBN    E29-E27
          MJN    PCER10      IF EC 27 OR 28
          ZJN    PCER20      IF EC 29
          SBN    E30-E29
          NJN    PCER20      IF ERROR CODE 31-XX
 PCER10   BSS
          LDK    H00E1       READ IPI STATUS REGISTER
          RJM    RDRG        READ REGISTER
          STDL   STATUS      SAVE CONTENTS OF STATUS REGISTER
 PCER20   BSS
          LDDL   INITFLG     CHECK IF FROM INITIALIZATION
          ZJN    PCER22      IF NOT
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          LDK    URC.IN      INITIALIZATION ERROR
          RAML   RS+/RS/P.URC
          UJN    PCER28      CONT.
 PCER22   LDDL   ASYNCP      CHECK IF ASYNCHRONUS PROCESSING
          ZJN    PCER24      IF NOT
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          UJN    PCER28      CONT.
 PCER24   BSS
          RJM    PAR         PREPARE ABNORMAL RESPONSE
 PCER28   BSS
          LDDL   P2
          NJN    PCER45      IF ERROR ALREADY ISOLATED
          LDK    ID14
          RJM    SFP         SEARCH FOR ID 14
          MJN    PCER30      IF NOT SLAVE INTERVENTION REQUIRED
          LDK    E71
          UJN    PCER45
 PCER30   BSS
          LDK    ID16
          RJM    SFP         SEARCH FOR ID 16
          MJN    PCER35      IF NOT SLAVE MACHINE EXCEPTION
          LDK    E72
          UJN    PCER45
 PCER35   BSS
          LDK    ID17
          RJM    SFP         SEARCH FOR ID 17
          MJN    PCER40      IF NOT SLAVE COMMAND EXCEPTION
          LDK    E73
          UJN    PCER70
 PCER40   BSS
          LDK    ID13
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    PCER50      IF NOT ID13
          LDK    E74         MICROCODE EXECUTION ERROR
 PCER45   BSS
          UJN    PCER70
 PCER50   BSS
          LDK    ID15
          RJM    SFP         SEARCH FOR ID 15
          MJN    PCER60      IF NOT ALTERNATE PORT EXCEPTION
          LDK    E75
          UJN    PCER70
 PCER60   BSS
          LDK    E00         CP MUST ISOLATE THE ERROR
 PCER70   BSS
          STML   RS+/RS/P.ERRID
          LDDL   LF
          STML   RS+/RS/P.FUNTO FAILING FUNCTION IF E01
          LDDL   STATUS      IPI STATUS REGISTER
          STML   RS+/RS/P.STREG
          LDK    H00F1
          RJM    RDRG        READ IPI ERROR REGISTER
          STML   RS+/RS/P.ERREG SAVE ERROR REGISTER
          LDK    H0022       CLEAR IPI ERROR REGISTER
          RJM    FAN
          UJK    PCERX       EXIT
          SPACE  5,20
** NAME-- EP / CMDTERM
*
** PURPOSE-- ERROR PROCESSING
*
** NOTE-- DOES NOT RETURN TO CALLER
          SPACE  2
 CMDTERM  EQU    *
 EP       BSSZ   1           ENTRY
          LDDL   INITFLG     CHECK IF FROM INITIALIZATION
          ADDL   ASYNCP      OR FROM ASYNCHRONUS PROCESSING
          NJN    EP10        IF YES
          RJM    CDUNIT      CHECK IF UNIT IS TO BE DISABLED
 EP10     RJM    RESP        SEND THE RESPONSE
          LDN    76B         SET ASYNCHRONUS PROCESSING FLAG
          STDL   ASYNCP
          AOML   /TS/P.RETRY,CTST  INCREMENT RETRY COUNTER
          SBN    1           CHECK IF FIRST RETRY EXECUTED
          NJN    EP200       IF YES

 EP100    RJM    MCC         MASTER CLEAR CHANNEL
          RJM    LIR         LOGICIAL INTERFACE RESET
          UJN    EP900       CONTINUE

 EP200    SBN    1           CHECK IF SECOND RETRY EXECUTED
          NJN    EP900       IF YES
          LDN    0           CLEAR IPI RESPONSE PACKET BUFFER
          STML   RPB
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          LDK    E50         EXECUTING CONTROLLER DIAGNOSTICS
          STML   RS+/RS/P.ERRID  SET ERROR ID FIELD
          RJM    RESP        SEND THE RESPONSE
          RJM    ISR         ISSUE SLAVE RESET
          LDN    0           CLEAR IPI RESPONSE PACKET BUFFER
          STML   RPB
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          LDK    E51         CONTROLLER DIAGNOSTICS PASSED
          STML   RS+/RS/P.ERRID  SET ERROR ID FIELD
          RJM    RESP        SEND THE RESPONSE

 EP900    SBN    1           CHECK IF CLREQ HAS FAILED
          NJN    EP920       IF YES

 EP910    RJM    CLREQ       CLEAR THE REQUEST FROM THE TS TABLE
          LJM    MAIN        GO TO MAIN LOOP

 EP920    LDN    0           CLEAR CHAIN FLAG SO CLREQ WONT FAIL AGAIN
          STML   /TS/P.CHAIN,CTST
          UJN    EP910       GO CLEAR THE REQUEST
          SPACE  5,20
** NAME - SLVTST
*
** PURPOSE - TO CHECK IF SLAVE TESTING IS REQUIRED
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 SLVTST   SUBR               ENTRY/EXIT
          LDML   SLB+/SL/P.SLVTST,SX  GET SLAVE TESTING REQUIRED FLAG
          LPN    1           MASK TESTING REQUIRED BIT
          ZJN    SLVTSTX     IF NOT, EXIT
          LDML   SLVTST      SAVE RETURN ADDRESS
          STML   /TS/P.SSLVT,CTST
          LDML   SRTAB,SLVN  CHECK IF SLAVE RESET EVER ISSUED
          ZJN    SLVTST2     IF NOT
          LDN    1           SET RETRY COUNTER
          STML   /TS/P.RETRY,CTST
          RJM    LIR         ISSUE LOGICIAL INTERFACE RESET
          UJN    SLVTST4
 SLVTST2  BSS
          LDN    2           SET RETRY COUNTER
          STML   /TS/P.RETRY,CTST
          RJM    ISR         ISSUE SLAVE RESET
 SLVTST4  BSS
          RJM    PTW         PATH TEST WRITE
          RJM    PTR         PATH TEST READ
          LDN    2           SET ATTRIBUTES REQUIRED FLAG
          STML   SLB+/SL/P.SLVTST,SX
          LDN    0           CLEAR RETRY COUNTER
          STML   /TS/P.RETRY,CTST
          LDML   /TS/P.SSLVT,CTST  RESTORE RETURN ADDRESS
          STML   SLVTST
          UJK    SLVTSTX     EXIT
          SPACE  5,20
** NAME - FACTST
*
** PURPOSE - TO CHECK IF FACILITY TESTING IS REQUIRED
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 FACTST0  LDML   UNITS+/UN/P.CTF,UX  CLEAR FACILITY TESTING REQUIRED FLAG
          LPK    -/UN/K.CTF  MASK OUT BIT
          STML   UNITS+/UN/P.CTF,UX
          LDML   /TS/P.SFACT,CTST  RESTORE RETURN ADDRESS
          STML   FACTST


 FACTST   SUBR               ENTRY/EXIT


          LDML   UNITS+/UN/P.CTF,UX  GET FACILITY TESTING REQUIRED FLAG
          LPK    /UN/K.CTF
          ZJN    FACTSTX     IF NOT SET, EXIT
          LDML   FACTST      SAVE RETURN ADDRESS
          STML   /TS/P.SFACT,CTST
          AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          STML   PFDCP1
          LDML   /TS/P.SN,CTST  GET SLAVE AND FACILITY ADDRESS
          STML   PFDCP5
          LDC    PFDCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER

 FACTST2  LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK IF SUCCESSFUL
          ZJK    FACTST0     IF YES
          LDML   RPB+MAJST   CHECK IF COMMAND COMPLETION RESPONSE
          SHN    -4
          LPN    0#F
          LMN    CC
          ZJN    FACTST4     IF YES, BUT WAS NOT SUCCESSFUL
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     PROCESS ASYNCHRONUS RESPONSE
          UJN    FACTST2     WAIT FOR COMMAND COMPLETE RESPONSE

 FACTST4  LDML   RPB+MAJST   CHECK IF DIAGNOSTIC FAILURE
          SHN    LSME          LOOK FOR MACHINE EXCEPTION
          MJN    FACTST6     IF YES
          LDN    0           DO NOT EXPECT BID OR TAPE MARKS
          RJM    CMDRESP     PROCESS RESPONSE (NO RETURN)

 FACTST6  LDK    E61         REPORT DRIVE FAILURE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE  (NO RETURN)
          SPACE  4
*         -PERFORM FACILITY DIAGNOSTICS-  COMMAND PACKET
 PFDCP    DATA   0#0010      PACKET LENGTH
 PFDCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCPFD+CMCHN  OP-CODE AND CHAIN
 PFDCP5   DATA   0#FFFF      ADDRESSEE
          DATA   0#0953      FACILITY DIAGNOSTIC PARAMETER
          DATA   0#8000        LOOP WRITE/READ SECTION
          DATA   0#0000        DIAG MODE
          DATA   0#0000        RETRY COUNT
          DATA   0#0001        EXECUTION LOOP COUNT
          SPACE  5,20
** NAME - CDUNIT
*
** PURPOSE - TO SET THE DISABLED UNIT BIT IN THE UIT IF THE MASK BIT IS SET.
*
*  INPUT - RESPONSE BUFFER HEADER ALERT MASK IS IMAGE OF REQUEST
*
** OUTPUT - THE DISABLE UNIT BIT IS SET IN THE STATUS FIELD OF THE UNIT
*           INTERFACE TABLE IF THE ALERT MASK DISABLE BIT WAS SET.
*
          SPACE  2
 CDUNIT   SUBR               ENTRY/EXIT
          LDML   RS+/RS/P.LONGB  CHECK ALERT MASK
          SHN    18-16+/RS/L.DUNIT  DISABLE UNIT BIT TO SIGN POSITION
          PJN    CDUNITX     IF NOT DISABLE UNIT BIT IN ALERT MASK
          LDK    /RS/K.DUNIT   SET UNIT DISABLED BIT IN RESPONSE
          RAML   RS+/RS/P.LNGBLK  SET RESPONSE ALERT CONDITIONS
          LOADR  UNITS+/UN/P.UIT,UX  LOAD R AND A OF UIT
          STDL   T5          SAVE CM ADDRESS
          CRDL   T1          READ UIT UNIT STATUS INTO T2
          LDK    /UIT/K.DSABLE  SET UNIT DISABLED IN UIT STATUS
          STDL   T2
          LDDL   T5          RESTORE CM ADDRESS
          CWDL   T1          UPDATE UIT UNIT STATUS
          UJK    CDUNITX     EXIT
          SPACE  5,20
** NAME-- MR
*
** PURPOSE-- MASTER RESET ALL SLAVES ON THE CHANNEL
          SPACE  2
 MR       SUBR               ENTRY/EXIT
          RJM    MCC         MASTER CLEAR CHANNEL
          LDK    H9213
          RJM    FUNC        BUS A, SET SYNC OUT
          PAUSE  10          MUST DELAY 10 MICROSECONDS MINIMUM
          LDK    H9211
          RJM    FUNC        DROP SYNC OUT
          UJK    MRX
          SPACE  5,20
** NAME--ISR
*
** PURPOSE-- ISSUE SLAVE RESET
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 ISR      SUBR               ENTRY/EXIT
          LDML   ISR         SAVE RETURN ADDRESS
          STML   /TS/P.SISR,CTST
          RJM    MCC         MASTER CLEAR CHANNEL
          LDK    H8415       SLAVE RESET
          RJM    IR          ISSUE RESET
          LDK    SRT         SLAVE RESET SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          SHN    -4
          LPN    0#F
          LMK    AR
          NJN    ISR20       IF NOT ASYNCHRONOUS RESPONSE
          LDK    ID16
          RJM    SFP         CHECK FOR MACHINE EXCEPTION
          MJN    ISR20       IF MACHINE EXCEPTION ID NOT FOUND
          LDML   RPB+6,T3
          LPK    0#FEE0
          LMK    0#6000
          NJN    ISR20       IF ERROR
          STML   /TS/P.CHAIN,CTST  CLEAR IPI CHAIN/ABORTED FLAG
          LDML   /TS/P.SISR,CTST  RESTORE RETURN ADDRESS
          STML   ISR
          STML   SRTAB,SLVN  SET SLAVE RESET ISSUED FLAG
          UJK    ISRX
 ISR20    BSS
          LDK    E60         CONTROLLER FAILURE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- LIR
*
** PURPOSE-- LOGICAL INTERFACE RESET.
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 LIR      SUBR               ENTRY/EXIT
          LDML   LIR         SAVE RETURN ADDRESS
          STML   /TS/P.SLIR,CTST
          LDK    H8215       LOGICAL INTERFACE RESET
          RJM    IR          ISSUE RESET
          LDN    3           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          SHN    -4
          LPN    0#F
          LMK    AR
          NJN    LIR20       IF NOT ASYNCHRONOUS RESPONSE
          LDK    ID16
          RJM    SFP         CHECK FOR MACHINE EXCEPTION
          MJN    LIR20       IF MACHINE EXCEPTION ID NOT FOUND
          LDML   RPB+6,T3
          LPK    0#FEE0
          LMK    0#6000
          NJN    LIR20       IF ERROR
          STML   /TS/P.CHAIN,CTST  CLEAR IPI CHAIN/ABORTED FLAG
          LDML   /TS/P.SLIR,CTST  RESTORE RETURN ADDRESS
          STML   LIR
          UJK    LIRX
 LIR20    BSS
          LDK    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- IR
*
** PURPOSE-- ISSUE INTERFACE RESET TO SLAVE
*
** ENTRY
*         A = 8115  FOR PHYSICAL INTERFACE RESET
*             8215  FOR LOGICAL INTERFACE RESET
*             8415  FOR SLAVE RESET
*         SLVN = SLAVE NUMBER
          SPACE  2
 IR       SUBR               ENTRY/EXIT
          STDL   P2
          RJM    SARF        SET ATTRIBUTES REQUIRED FLAG
          LDDL   SLVN        SLAVE NUMBER
          SHN    12
          ADDL   P2
          RJM    FUNC        SET MASTER OUT
          PAUSE  20
          LDDL   LF          LAST FUNCTION ISSUED
          LMN    2
          RJM    FUNC        SET SYNC OUT
          PAUSE  10
          LDDL   LF
          LMN    2
          RJM    FUNC        DROP SYNC OUT
          LDDL   LF
          LMN    4
          RJM    FUNC        DROP MASTER OUT
          UJK    IRX
          SPACE  5,20
** NAME-- IH
*
** PURPOSE-- INTERRUPT HANDLER.  INPUT THE RESPONSE PACKET.  THROW AWAY
*            ASYNCHRONOUS RESPONSES (UP TO 8) FROM THE FACILITIES.
*
** ENTRY--A = MAXIMUM SECONDS TO WAIT FOR THE INTERRUPT
*
** EXIT
*         A = MAJOR STATUS
*         THE SLAVE IS DESELECTED
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 IH       SUBR               ENTRY/EXIT
          ADN    1           ADJUST TIME LIMIT
          STML   /TS/P.SECLIM,CTST  SAVE THE SECONDS LIMIT
          RJM    UC          UPDATE THE CLOCK
          LDDL   CLSEC
          STML   /TS/P.CLK,CTST  SAVE CURRENT CLOCK IN TS TABLE
          LDML   IH          SAVE ROUTINE CALLER
          STML   /TS/P.SIH,CTST
 IH10     BSS
          RJM    SWITCH      SWITCH TO OTHER TS TABLE
          LDML   /TS/P.SIH,CTST  RESTORE RETURN ADDRESS
          STML   IH
          LDN    7           CLASS 1, 2 AND 3 INTERRUPTS
          RJM    RI          REQUEST INTERRUPTS
          LDML   SELT,SLVN   MASK VALUE
          LPDL   STATUS      INTERRUPT STATUS
          NJN    IH15        IF INTERRUPT PRESENT
          RJM    UC          UPDATE CLOCK
          LDDL   CLSEC
          SBML   /TS/P.CLK,CTST
          PJN    IH12        IF CLOCK HAS NOT WRAPPED
          ADK    0#10000
 IH12     BSS
          SBML   /TS/P.SECLIM,CTST
          MJN    IH10        IF TIMEOUT NOT EXPIRED
          LDK    E38         NO SLAVE INTERRUPT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 IH15     BSS
          RJM    DTM         DETERMINE TRANSFER MODE
          RJM    SEL         SELECT THE SLAVE
          STDL   CTM         CLEAR CHANGE TRANSFER MODE FLAG
          RJM    RPT         RESPONSE PACKET TRANSFER
          RJM    DCM         DESELECT THE SLAVE
          LDML   RPB+MAJST   MAJOR STATUS
          SHN    -4
          LPN    0#F
          LMK    AR
          NJN    IH20        IF NOT ASYNCHRONOUS RESPONSE
          LDML   RPB+SLAD
          LPDL   FF
          LMDL   FF
          ZJN    IH20        IF ASYNCHRONOUS RESPONSE FOR SLAVE
          LJM    IH10        GO LOOK FOR ANOTHER INTERRUPT
 IH20     BSS
          LDML   RPB+MAJST   MAJOR STATUS
          LJM    IHX
          SPACE  5,20
** NAME-- UC
*
** PURPOSE-- UPDATE CLOCK.  THE CLOCK IS USED TO TIMEOUT COMMANDS
*            ISSUED TO THE SLAVE.
          SPACE  2
 UC       SUBR               ENTRY/EXIT
          LDDL   CLCUR
          STDL   P6          SAVE CURRENT CLOCK
          IAN    14B
          STDL   CLCUR
          SBDL   P6
          PJN    UC5         IF CLOCK HASNT WRAPPED
          ADK    0#10000
 UC5      BSS
          RADL   CLMCS       UPDATE MICROSECOND PORTION OF CLOCK
          LDDL   CLMCS
          ADK    -30000
          MJN    UCX         IF LESS THAN 30 MILLISECONDS
          STDL   CLMCS
          LDN    30
          RADL   CLMLS       UPDATE MILLISECOND PORTION OF CLOCK
          ADK    -1000
          MJN    UCX         IF LESS THAN 1 SECOND
          STDL   CLMLS
          AODL   CLSEC       UPDATE SECOND PORTION OF CLOCK
          UJN    UCX         EXIT
          SPACE  5,20
** NAME-- EFP
*
** PURPOSE-- ERROR FLAG PROCESSING
          SPACE  2
 EFP      DATA   0
          LDK    H00F1       READ IPI ERROR REGISTER
          RJM    RDRG
          SHN    2           TEST BIT 48
          PJN    EFP5        IF NOT BUFFER COUNTER PARITY
          LDK    E31
          UJN    EFP35
 EFP5     BSS
          SHN    2           TEST BIT 50
          PJN    EFP10       IF NOT SYNC COUNTER PARITY
          LDK    E32
          UJN    EFP35
 EFP10    BSS
          SHN    1           TEST BIT 51
          PJN    EFP15       IF NOT PERIOD COUNTER PARITY
          LDK    E03
          UJN    EFP35
 EFP15    BSS
          SHN    1           TEST BIT 52
          MJN    EFP18       IF PARITY ERROR ON FUNCTION
          SHN    1           TEST BIT 53
          PJN    EFP20       IF NOT PARITY ERROR ON FUNCTION
 EFP18    BSS
          LDK    E01         FUNCTION TIMEOUT
          UJN    EFP35
 EFP20    BSS
          SHN    3           TEST BIT 56
          PJN    EFP25       IF NOT LOST DATA
          LDK    E33
          UJN    EFP110
 EFP25    BSS
          SHN    1           TEST BIT 57
          PJN    EFP30       IF NOT UPPER ICI PARITY
          LDK    E04
          UJN    EFP110
 EFP30    BSS
          SHN    1           TEST BIT 58
          PJN    EFP40       IF NOT LOWER ICI PARITY
          LDK    E05
 EFP35    BSS
          UJN    EFP110
 EFP40    BSS
          SHN    1           TEST BIT 59
          PJN    EFP45       IF NOT IPI SEQUENCE ERROR
          LDK    E24
          UJN    EFP110
 EFP45    BSS
          SHN    1           TEST BIT 60
          PJN    EFP50       IF NOT UPPER IPI CHANNEL PARITY
          LDK    E25
          UJN    EFP110
 EFP50    BSS
          SHN    1           TEST BIT 61
          PJN    EFP52       IF NOT LOWER IPI CHANNEL PARITY
          LDK    E26
          UJN    EFP110
 EFP52    SHN    1           TEST BIT 62
          PJN    EFP55       IF NOT ILLEGAL OPERATION
          LDK    E19
          UJN    EFP110
 EFP55    BSS
          LDK    E06         IOU ERROR
 EFP110   BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- INTERR
*
** PURPOSE-- REPORT AN INTERFACE ERROR
*
** ENTRY-- A REGISTER HAS INTERFACE ERROR CODE
*
** EXIT-- TO MAIN IDLE LOOP WITH IDLFLG FORCED SET.
*         PP WILL ONLY PROCESS IDLE/RESUME COMMANDS.
          SPACE  2
 INTERR   DATA   0
          STDL   T7          SAVE ERROR CODE
          LDN    0           NO IPI STATUS IN RESPONSE
          STML   RPB
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          LDDL   T7          GET INTERFACE ERROR CODE
          STML   RS+/RS/P.IEC INTERFACE ERROR CODE
          LDK    /RS/K.INTERR  INTERFACE ERROR
          STML   RS+/RS/P.INTERR  ABNORMAL STATUS CODE
          LDK    E120        SOFTWARE FAILURE
          STML   RS+/RS/P.ERRID
          LDK    /RS/K.PDN   PP IDLED
          STML   RS+/RS/P.DOWNST
          RJM    RESP        SEND THE RESPONSE
          LDN    77B         FORCE SET PP IDLE FLAG
          STDL   IDLFLG
          LJM    MAIN        EXIT TO MAIN IDLE LOOP
          SPACE  5,20
** NAME-- SARF
*
** PURPOSE-- SET ATTRIBUTES REQUIRED FLAG
          SPACE  2
 SARF     SUBR               ENTRY/EXIT
          LDML   SLB+/SL/P.SLVTST,SX  GET FLAG WORD
          LPN    1           MASK TESTING REQUIRED
          ADN    2           SET ATTRIBUTES REQUIRED BIT
          STML   SLB+/SL/P.SLVTST,SX  RESTORE FLAG WORD
          UJN    SARFX       EXIT
          TITLE  CHANNEL SUBROUTINES
** NAME-- MCC
*
** PURPOSE-- MASTER CLEAR CHANNEL
          SPACE  2
 MCC      SUBR               ENTRY/EXIT
          MCLR   DC          MASTER CLEAR CHANNEL
          PAUSE  100         ALLOW SLAVE TIME TO DROP LINES
          MCLR   DC          IN CASE SEQUENCE ERROR OCCURRED
          PAUSE  1
          DCN    DC+40B
          CFM    MCC10,DC    CLEAR CHANNEL ERROR FLAG
 MCC10    BSS
          LDK    H7C42       5.00 MB
          RJM    FUNC        SET IPI CHANNEL TRANSFER RATE
          UJN    MCCX
          SPACE  5,20
** NAME-- FUNC
*
** PURPOSE-- ISSUE FUNCTION TO IPI CHANNEL
*
** INPUT-- A REGISTER = FUNCTION CODE.
          SPACE  2
 FUNC     SUBR               ENTRY/EXIT
          DCN    DC+40B      ENSURE CHANNEL IS INACTIVE
                              THE CHANNEL MAY HAVE BEEN LEFT ACTIVE
                              BY A ROUTINE SUCH AS DCM,
                              OR AFTER A REPORTED ERROR.
          CFM    FUNC10,DC   IF CHANNEL ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 FUNC10   BSS
          FAN    DC          ISSUE THE FUNCTION
          STDL   LF          SAVE FUNCTION CODE
 FH1      IFEQ   FH,1        FUNCTION HISTORY TABLE
          STML   FBUF,FI     SAVE HISTORY OF FUNCTIONS ISSUED
          AODL   FI          INCREMENT FUNCTION BUFFER INDEX
          ADK    -FBUFL
          NJN    FUNC20      IF NOT END OF BUFFER
          STDL   FI          INITIALIZE INDEX
 FUNC20   BSS
 FH1      ENDIF
          CFM    FUNC30,DC   IF CHANNEL ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 FUNC30   BSS
          IJM    FUNCX,DC    EXIT IF CHANNEL INACTIVE
          LDK    E01         FUNCTION TIMEOUT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- FAN
*
** PURPOSE-- SEND A FUNCTION TO THE IPI CHANNEL, BUT DONT
*            PUT THE FUNCTION IN THE FUNCTION HISTORY TABLE
          SPACE  2
 FAN      SUBR               ENTRY/EXIT
          DCN    DC+40B      ENSURE THE CHANNEL IS INACTIVE
                              THE CHANNEL MAY HAVE BEEN LEFT ACTIVE
                              BY A MASTER CLEAR, A ROUTINE SUCH AS
                              DCM, OR AFTER A REPORTED ERROR.
          FAN    DC          SEND THE FUNCTION
          UJN    FANX
          SPACE  5,20
** NAME-- RDRG
*
** PURPOSE-- READ EITHER THE IPI STATUS OR IPI ERROR REGISTER
*
** ENTRY--  A = FUNCTION CODE
          SPACE  2
 RDRG10   BSS
          LDN    0

 RDRG     SUBR               ENTRY/EXIT
          RJM    FAN         SEND FUNCTION
          AJM    RDRG10,DC   IF NO FUNCTION REPLY
          ACN    DC+40B
          EJM    RDRG10,DC   IF WORD COULD NOT BE READ
          IAN    DC
          UJN    RDRGX
          SPACE  5,20
** NAME--RI
*
** PURPOSE-- REQUEST INTERRUPTS FROM ALL SLAVES ON THIS CHANNEL
*
** INPUT-- A = BIT 0 SET CLASS 1
*                  1 SET CLASS 2
*                  2 SET CLASS 3
*
** OUTPUT
*         STATUS - CONTAINS BIT SIGNIFICANT ADDRESS OF SLAVE WITH INTERRUPT
          SPACE  2
 RI       SUBR               ENTRY/EXIT
          LPN    7           MASK CALLER SELECTION
          SHN    8           POSITION THEM
          ADK    H0X15       REQUEST SELECTED INTERRUPTS
          RJM    FUNC        BUS A, MASTER OUT
          PAUSE  20          DELAY
          ACN    DC
          EJM    RI5,DC      IF ERROR
          IAN    DC
          STDL   STATUS      SAVE BIT SIGNIFICANT ADDRESS
          LDDL   LF
          LMN    4
          RJM    FUNC        DROP MASTER OUT
          UJN    RIX         EXIT
 RI5      BSS
          LDK    E02         CHANNEL EMPTY WHEN ACTIVATED
          RJM    PCER        PREPARE COMMAND ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,15
** NAME-- DTM
*
** PURPOSE-- DETERMINE TRANSFER MODE
*
** OUTPUT
*         STATUS - TRANSFER SETTINGS, BIT 4 = 1 IF DATA STREAMING
*         CTM - USED TO CHANGE TRANSFER MODE WHEN SELECTING
          SPACE  2
 DTM      SUBR               ENTRY/EXIT
          LDDL   SLVN        SLAVE NUMBER
          SHN    12
          ADK    H8025
          RJM    FUNC        REQUEST TRANSFER SETTINGS
          ACN    DC
          LDN    77B
 DTM4     FJM    DTM8,DC     IF SLAVE IN
          SBN    1
          NJN    DTM4        IF TIMEOUT NOT EXPIRED
          LDK    E27         NO SLAVE IN
          UJN    DTM16
 DTM8     IAN    DC
          STDL   STATUS      SAVE TRANSFER SETTING
          SFM    DTM20,DC    IF ERROR FLAG SET
          LPN    0#10
          LMN    0#10
          SHN    7
          STDL   CTM         CHANGE TRANSFER MODE BIT
          LDDL   LF          LAST FUNCTION ISSUED
          LMK    0#54        CODE 7, DROP MASTER OUT
          RJM    FUNC        DROP MASTER OUT
          ACN    DC
          LDN    77B
 DTM12    FJM    DTMX,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    DTM12       IF TIMEOUT NOT EXPIRED
          LDK    E28         SLAVE IN DID NOT DROP
 DTM16    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 DTM20    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- SEL
*
** PURPOSE-- SELECT THE SLAVE AND VERIFY THE BIT SIGNIFICANT RESPONSE
*
** INPUT
*         SLVN - SLAVE NUMBER
*         CTM - CHANGE TRANSFER MODE IF BIT 3 SET
*
** OUTPUT-- A = 0 IF NO ERROR
          SPACE  2
 SEL      SUBR               ENTRY/EXIT
          LDDL   SLVN
          SHN    12
          ADDL   CTM         CHANGE TRANSFR MODE MODIFIER
          ADK    H0029
          RJM    FUNC        SET SELECT OUT
          ACN    DC
          LDN    77B
 SEL4     FJM    SEL8,DC     IF SLAVE IN
          SBN    1
          NJN    SEL4        IF TIMEOUT NOT EXPIRED
          LDK    E20         CANT SELECT SLAVE
          UJN    SEL15
 SEL8     IAN    DC
          STDL   STATUS      SAVE BIT SIGNIFICANT RESPONSE
          CFM    SEL10,DC    IF ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 SEL10    BSS
          LPK    377B
          LMML   SELT,SLVN
          ZJK    SELX        IF BIT SIGNIFICANT RESPONSE CORRECT
          LDK    E21         BIT SIGNIFICANT RESPONSE WRONG
 SEL15    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- BCS
*
** PURPOSE-- PERFORM BUS CONTROL SEQUENCE
*
** INPUT
*         A = BUS A BITS 7,6 IN BITS 1,0 OF ACCUMULATOR
*             BIT 7 = 1 IF DATA ELSE RESPONSE OR COMMAND
*             BIT 6 = 1 IF INFORMATION IN
          SPACE  2
 BCS      SUBR               ENTRY/EXIT
          SHN    14
          ADK    H005B
          RJM    FUNC        SET SYNC OUT
          ACN    DC
          LDN    77B
 BCS4     FJM    BCS8,DC     IF SYNC IN
          SBN    1
          NJN    BCS4        IF TIMEOUT NOT EXPIRED
          LDK    E22         NO SYNC IN
          UJN    BCS20
 BCS8     IAN    DC
          STDL   STATUS      SAVE BUS ACKNOWLEDGE STATUS
          SFM    BCS25,DC    IF ERROR FLAG SET
          LPDL   FF
          NJN    BCS16       IF BUS ACKNOWLEDGE IS WRONG
          LDDL   LF          LAST FUNCTION
          LMN    0#32
          RJM    FUNC        DROP SYNC OUT
          ACN    DC
          LDN    77B
 BCS12    FJM    BCSX,DC     IF SYNC IN DROPPED
          SBN    1
          NJN    BCS12       IF TIMEOUT NOT EXPIRED
          LDK    E23         SYNC IN DID NOT DROP
          UJN    BCS20
 BCS16    BSS
          LDK    E37         BUS ACKNOWLEDGE WRONG
 BCS20    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 BCS25    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- CPT
*
** PURPOSE-- COMMAND PACKET TRANSFER
*
** INPUT-- A = COMMAND PACKET FWA
*              BIT 17 = BYPASS SEL AND DCM SUBROUTINES
          SPACE  2
 CPT30    LDN    EVENOT      USE EVEN OCTET TRANSFER ENCODED STATUS
          RJM    GES         GET ENDING STATUS
          LDDL   CPTBP       CHECK FOR BYPASS DCM
          LPN    1
          NJN    CPT35       IF YES
          RJM    DCM         DESELECT THE SLAVE
 CPT35    BSS
          LDDL   WC
          ZJN    CPT40       IF ALL WORDS TRANSFERRED
          LDK    E29         INCOMPLETE TRANSFER
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)

 CPT40    LDML   *           GET COMMAND CODE SENT
 CPTA     EQU    *-1
          LPN    CMCHN       CHECK FOR COMMAND CHAINING
          STML   /TS/P.CHAIN,CTST  SET CHAINING FLAG

 CPT      SUBR               ENTRY/EXIT

          SHN    1           SAVE BYPASS BIT AS BIT 0
          STDL   CPTBP       SAVE IT
          SHN    17          RESTORE ORIGINAL FWA
          STML   CPTC        INITIALIZE INSTRUCTIONS
          STML   CPTD
          ADN    OPCD        ADJUST TO OPCODE
          STML   CPTA        FOR CHAINING FLAG

 KH1      IFEQ   KH,1        COMMAND HISTORY
          SBN    OPCD        RESET ADDRESS
          STML   CPTB        INITIALIZE INSTRUCTION ADDRESS
          LCN    0           INDICATE COMMAND
          STML   HB,HBP
          AODL   HBP         INCREMENT DESTINATION INDEX
          ADN    7           COMPUTE LOOP LIMIT
          STML   CPTE        SET LOOP LIMIT

 CPT10    LDML   *           GET COMMAND WORD
 CPTB     EQU    *-1
          STML   HB,HBP      PUT INTO HISTORY LIST
          AOML   CPTB        INCREMENT SOURCE ADDRESS
          AODL   HBP         INCREMENT DESTINATION INDEX
          SBML   CPTE        CHECK FOR ENTRY LIMIT
          NJN    CPT10       IF NOT, LOOP
          LDDL   HBP         CHECK FOR BUFFER LIMIT
          ADK    -HBL
          MJN    CPT15       IF NOT
          LDN    0           RESET INDEX
          STDL   HBP
 CPT15    BSS
 KH1      ENDIF

          LDDL   CPTBP       CHECK FOR BYPASS SEL
          LPN    1
          NJN    CPT18       IF YES
          RJM    SEL         SELECT THE SLAVE
 CPT18    BSS
          LDK    CMDOUT      BUS A FOR COMMAND
          RJM    BCS         BUS CONTROL SEQUENCE
          LDK    H0381       STREAM, WRITE
          RJM    FUNC        RAISE MASTER OUT
          ACN    DC
          LDML   *           GET PACKET LENGTH
 CPTC     EQU    *-1
          ADN    3
          SHN    -1          CONVERT BYTE COUNT TO WORD COUNT
          OAM    *,DC        SEND COMMAND PACKET
 CPTD     EQU    *-1
          CFM    CPT20,DC    IF CHANNEL ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 CPT20    BSS
          STDL   WC          SAVE RESIDUAL WORD COUNT
          RJM    WSID        WAIT FOR SLAVE IN TO DROP
          UJK    CPT30
          SPACE  2
 KH1A     IFEQ   KH,1        COMMAND HISTORY
 CPTE     BSSZ   1           LIMIT ADDRESS
 KH1A     ENDIF
          SPACE  5,20
** NAME-- RPT
*
** PURPOSE-- RESPONSE PACKET TRANSFER
*
** OUTPUT
*         RPB - STARTING LOCATION OF RESPONSE PACKET
          SPACE  2
 RPT20    BSS
          STDL   WC          SAVE WORDS NOT TRANSFERRED
 RPT30    BSS
          LDN    EVENOT      USE EVEN OCTET TRANSFER ENCODED STATUS
          RJM    GES         GET ENDING STATUS

 KH2      IFEQ   KH,1        RESPONSE HISTORY
          LCN    77B         INDICATE RESPONSE
          STML   HB,HBP
          LDML   RPB         PACKET LENGTH
          STML   HB+1,HBP
          LDML   RPB+1       COMMAND REFERENCE NUMBER
          STML   HB+2,HBP
          LDML   RPB+2       COMMAND
          STML   HB+3,HBP
          LDML   RPB+3       SLAVE/FACILITY
          STML   HB+4,HBP
          LDML   RPB+4       MAJOR STATUS
          STML   HB+5,HBP
          LDML   RPB+5       PARAMETERS (IF ANY)
          STML   HB+6,HBP
          LDML   RPB+6
          STML   HB+7,HBP
          LDN    8
          RADL   HBP         UPDATE HISTORY BUFFER POINTER
          ADK    -HBL        CHECK IF FULL
          NJN    RPT35       IF NOT FULL YET
          STML   HBP         RESET POINTER
 RPT35    BSS
 KH2      ENDIF

          LDDL   WC
          ZJN    RPTX        IF ALL WORDS TRANSFERRED
          LDK    E29         INCOMPLETE TRANSFER
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)

 RPT      SUBR               ENTRY/EXIT

          LDK    RSPIN       BUS A FOR RESPONSE
          RJM    BCS         BUS CONTROL SEQUENCE
          LDK    H0281       STREAM, READ
          RJM    FUNC        SET MASTER OUT
          ACN    DC
          LDN    5
          IAM    RPB,DC      INPUT REQUIRED WORDS
          CFM    RPT2,DC     IF CHANNEL ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 RPT2     BSS
          NJK    RPT20       IF NOT ALL WORDS RECEIVED
          LDML   RPB         BYTE COUNT MINUS 2
          ADN    3
          SHN    -1
          SBN    5
          ZJN    RPT4        IF ALL WORDS TRANSFERRED
          LPK    377B        PROTECT AGAINST ILLEGAL LENGTH
          IAM    RPB+5,DC    INPUT REMAINING WORDS
          CFM    RPT3,DC     IF CHANNEL ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 RPT3     BSS
          NJN    RPT2        IF NOT ALL WORDS TRANSFERRED
 RPT4     BSS
          STDL   WC          WORDS NOT TRANSFERRED
          RJM    WSID        WAIT FOR SLAVE IN TO DROP
          UJK    RPT30
          SPACE  5,20
** NAME-- GES
*
** PURPOSE-- GET ENDING STATUS
*
** INPUT-- A = MASTER ENCODED ENDING STATUS IN LOWER 4 BITS
*
** OUTPUT--
*         RETURNS TO CALLING PROGRAM IF STATUS IS READ WITHOUT ERROR
*         AND SUCCESSFUL IS SET IN STATUS
          SPACE  2
 GES      SUBR               ENTRY/EXIT
          SHN    8           POSITION MASTER ENCODED ENDING STATUS
          ADK    H8039       INDICATE SUCCESSFUL IN BUS A
          RJM    FUNC        DROP MASTER OUT
          ACN    DC
          LDK    1470        ABOUT 1.1 MILLISECOND TIMELIMIT
 GES4     FJM    GES8,DC     IF SLAVE IN SET
          SBN    1
          NJN    GES4        IF TIMEOUT NOT EXPIRED
          LDK    E27         SLAVE IN NOT SET
          UJK    GES30
 GES8     IAN    DC
          STDL   STATUS      SAVE ENDING STATUS
          SFM    GES40,DC    IF ERROR FLAG SET
          LPK    0#80
          NJN    GESX        IF SUCCESSFUL
          LDDL   STATUS
          SHN    17-6
          PJN    GES15       IF NOT BUS PARITY
          LDK    E34
          UJN    GES30
 GES15    BSS
          LDDL   STATUS
          LPN    17B
          SBN    2
          MJN    GES25       IF REPORTING -ENDING STATUS WRONG-
          SBN    7
          NJN    GES20       IF NOT -SYNC OUTS NOT EQUAL SYNC INS-
          LDK    E36
          UJN    GES30
 GES20    BSS
          PJN    GES23       IF NOT COMMAND REJECT
 GES22    LDK    E35
          UJN    GES30
 GES23    BSS
          SBN    2
          NJN    GES25       IF NOT INTERNAL SLAVE ERROR
          LDK    E70
          UJN    GES30
 GES25    BSS
          SBN    1           CHECK FOR COMMAND REJECT
          ZJN    GES22       IF YES
          LDK    E39         ENDING STATUS WRONG
 GES30    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 GES40    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- DCM
*
** PURPOSE-- DESELECT THE SLAVE
          SPACE  2
 DCM1     DCN    DC+40B      DEACTIVATE CHANNEL
          SFM    DCM10,DC    IF CHANNEL ERROR FLAG IS SET

 DCM      SUBR               ENTRY/EXIT
          LDK    H0071
          RJM    FUNC        DROP SELECT OUT
          ACN    DC
          LDN    77B
 DCM4     FJM    DCM1,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    DCM4        IF TIMEOUT NOT EXPIRED
          SFM    DCM10,DC    IF CHANNEL ERROR FLAG IS SET
          LDK    E28         SLAVE IN DID NOT DROP
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 DCM10    RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- WSID
*
** PURPOSE-- WAIT FOR SLAVE IN TO DROP
*
** EXIT -- RETURN TO CALLER IF SLAVE IN DROPPED BEFORE TIMEOUT.
*          ELSE REPORT ERROR E30 AND DO NOT RETURN TO CALLER.
          SPACE  2
 WSID     SUBR               ENTRY/EXIT
          LDK    MS25        TIMEOUT VALUE (ABOUT 25 MS)
 WSID10   IJM    WSIDX,DC    IF SLAVE IN DROPPED, EXIT
          SBN    1
          NJN    WSID10      IF TIMEOUT NOT EXPIRED
          LDK    E30         CHANNEL STAYED ACTIVE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- INPUT
*
** PURPOSE-- INPUT TAPE DATA RECORD
*
** INPUT-- (/TS/P.ILSTP,CTST) HAS CURRENT INDIRECT LENGTH/ADDRESS PAIR
*          (WC) HAS CHANNEL WORD COUNT TO TRANSFER
*
** EXIT -- (/TS/P.RESBC,CTST) HAS RESIDUAL BYTE COUNT OF TRANSFER
*          A = 0  IF FULL TRANSFER
*          A = NZ IF PARTIAL TRANSFER
          SPACE  2
 INPUT    SUBR               ENTRY/EXIT
          LOADF  /TS/P.ILSTP+2,CTST  SET R+A FOR DATA
          CHCM   WC,DC       INPUT THE DATA
          LDDL   WC          SET RESIDUAL IF ANY
          SHN    1           ADJUST TO BYTES
          STML   /TS/P.RESBC,CTST  SAVE RESIDUAL BYTE COUNT
          UJN    INPUTX      EXIT
          SPACE  5,20
** NAME-- OUTPUT
*
** PURPOSE-- OUTPUT TAPE DATA RECORD
*
** INPUT-- (/TS/P.ILSTP,CTST) HAS CURRENT INDIRECT LENGTH/ADDRESS PAIR
*          (WC) HAS CHANNEL WORD COUNT TO TRANSFER
*
** EXIT -- (/TS/P.RESBC,CTST) HAS RESIDUAL BYTE COUNT OF TRANSFER
*          A = 0  IF FULL TRANSFER
*          A = NZ IF PARTIAL TRANSFER
          SPACE  2
 OUTPUT   SUBR               ENTRY/EXIT
          LOADF  /TS/P.ILSTP+2,CTST  SET R+A FOR DATA
          CMCH   WC,DC       OUTPUT THE DATA
          LDDL   WC          SET RESIDUAL IF ANY
          SHN    1           ADJUST TO BYTES
          STML   /TS/P.RESBC,CTST  SAVE RESIDUAL BYTE COUNT
          UJN    OUTPUTX     EXIT
          SPACE  5,20
** NAME-- PTWOD
*
** PURPOSE-- PATH TEST WRITE OUTPUT DATA
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 PTWO1    LDML   /TS/P.SPTWOD,CTST  RESTORE RETURN ADDRESS
          STML   PTWOD

 PTWOD    SUBR               ENTRY/EXIT
          LDML   PTWOD       SAVE RETURN ADDRESS
          STML   /TS/P.SPTWOD,CTST
          LDC    PTWCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PTWO10   LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16       CHECK FOR TRANSFER NOTIFICATION
          ZJN    PTWO20      IF YES
          LDML   RPB+MAJST   CHECK FOR ASYNC
          SHN    -4
          LPN    0#F
          LMK    AR
          ZJN    PTWO10      IF YES
          UJK    PTWO50      ELSE REPORT ERROR (E00)
 PTWO20   LDML   /TS/P.CRN,CTST  CHECK IF CMD REFERENCE NUMBERS AGREE
          LMML   RPB+CRN
          NJK    PTWO60      IF NOT, REPORT ERROR (E76)
          RJM    SEL         SELECT SLAVE
          LDN    DATAOUT     BUS A FOR DATA OUT
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0381       STREAM, WRITE
          RJM    FUNC
          ACN    DC
          LDC    4128/2      WORD COUNT
          STDL   WC
          LOADC  CM.COM      LOAD R+A
          ADN    /CB/C.PTD   OFFSET TO PATH TEST DATA
          CMCH   WC,DC       OUTPUT DATA
          RJM    WSID        WAIT FOR SLAVE IN TO DROP
          LDN    EVENOT      EVEN OCTET MASTER ENCODED ENDING STATUS
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT SLAVE
          LDDL   WC          CHECK RESIDUAL WORD COUNT
          ZJK    PTWO90      IF OK
          LDN    E29         INCOMPLETE TRANSFER
          UJN    PTWO80

 PTWO50   LDN    E00         CP MUST DETERMINE ERROR
          UJN    PTWO80

 PTWO60   LDK    E76         UNEXPECTED RESPONSE

 PTWO80   RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)

 PTWO90   LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR SUCCESSFUL
          ZJK    PTWO1       IF YES, EXIT OK
          LDML   RPB+MAJST   CHECK FOR ASYNC
          SHN    -4
          LPN    0#F
          LMK    AR
          ZJN    PTWO90      IF YES
          UJN    PTWO50      ELSE REPORT ERROR (E00)
          SPACE  5,20
** NAME-- PTRID
*
** PURPOSE-- PATH TEST READ INPUT DATA
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 PTRI1    LDML   /TS/P.SPTRID,CTST  RESTORE RETURN ADDRESS
          STML   PTRID

 PTRID    SUBR               ENTRY/EXIT
          LDML   PTRID       SAVE RETURN ADDRESS
          STML   /TS/P.SPTRID,CTST
          LDC    PTRCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PTRI10   LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16       CHECK FOR TRANSFER NOTIFICATION
          ZJN    PTRI20      IF YES
          LDML   RPB+MAJST   CHECK FOR ASYNC
          SHN    -4
          LPN    0#F
          LMK    AR
          ZJN    PTRI10      IF YES
          UJK    PTRI50      ELSE, REPORT ERROR (E00)
 PTRI20   LDML   /TS/P.CRN,CTST  COMPARE COMMAND REFERENCE NUMBERS
          LMML   RPB+CRN
          NJK    PTRI60      IF NOT THE SAME
          RJM    SEL         SELECT SLAVE
          LDN    DATAIN      BUS A FOR DATA IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0A81       STREAM, READ, DMA
          RJM    FUNC
          ACN    DC
          LDC    4128/2      WORD COUNT
          STDL   WC
          LOADC  CM.COM      LOAD R+A
          ADN    /CB/C.PTD   OFFSET TO PATH TEST DATA
          CHCM   WC,DC       INPUT THE DATA
          RJM    WSID        WAIT FOR SLAVE IN TO DROP
          LDN    EVENOT      USE EVEN OCTET MASTER ENCODED ENDING STATUS
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT SLAVE
          LDDL   STATUS      CHECK SLAVE ENCODED ENDING STATUS
          LPN    0#F
          NJN    PTRI80      IF NOT EVEN
          LDDL   WC          CHECK RESIDUAL WORD COUNT
          ZJK    PTRI100     IF OK
          LDN    E29         INCOMPLETE TRANSFER
          UJN    PTRI90
 PTRI50   LDN    E00         CP MUST DETERMINE ERROR
          UJN    PTRI90
 PTRI60   LDK    E76         UNEXPECTED STATUS
          UJN    PTRI90
 PTRI80   LDN    E40         SLAVE ENCODED ENDING STATUS ERROR
 PTRI90   RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING  (NO RETURN)

 PTRI100  LDN    1           SECONDS LIMIT
          RJM    IH          GET COMMAND COMPLETION
          LMN    CCS         CHECK FOR SUCCESSFUL
          ZJK    PTRI1       IF YES, EXIT
          LDML   RPB+MAJST   CHECK FOR ASYNC
          SHN    -4
          LPN    0#F
          LMK    AR
          ZJN    PTRI100     IF YES
          UJN    PTRI50      ELSE, REPORT ERROR (E00)
          SPACE  5,20
** NAME-- REL
*
** PURPOSE-- READ ERROR LOG
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 REL1     LDML   /TS/P.SREL,CTST  RESTORE RETURN ADDRESS
          STML   REL

 REL      SUBR               ENTRY/EXIT
          LDML   REL         SAVE RETURN ADDRESS
          STML   /TS/P.SREL,CTST
          AOML   /TS/P.CRN,CTST  INCREMENT COMMAND REFERENCE NUMBER
          STML   RELCP1
          LDC    RELCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 REL5     LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16       CHECK FOR TRANSFER NOTIFICATION
          ZJN    REL8        IF YES
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    REL5        IF ASYNC
 REL8     LDML   /TS/P.CRN,CTST  CHECK IF COMMAND REFERENCE NUMBERS AGREE
          LMML   RPB+CRN
          NJK    REL50       IF NOT
          RJM    SEL         SELECT SLAVE
          LDN    DATAIN      BUS A FOR DATA IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0281       STREAM AND READ
          RJM    FUNC
          ACN    DC
          LDML   RELCP5      CHECK IF SLAVE OR FACILITY IS SELECTED
          SHN    10
          PJN    REL10       IF FACILITY
          LDN    17          INPUT SLAVE ERROR LOG
          IAM    SLVEL,DC
          UJN    REL20       CONT.
 REL10    LDN    17          INPUT FACILITY ERROR LOG
          IAM    FACEL,DC
 REL20    STDL   WC          SAVE RESIDUAL WORD COUNT
          RJM    WSID        WAIT FOR SLAVE IN TO DROP
          LDN    EVENOT      USE EVEN OCTET MASTER ENCODED ENDING STATUS
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT SLAVE
          LDDL   WC          CHECK IF INCOMPLETE TRANSFER
          NJN    REL80       IF YES
 REL40    LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          ZJK    REL1        IF YES  EXIT
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    REL40       IF ASYNC

 REL50    LDK    E76         UNEXPECTED STATUS
          UJN    REL90
 REL80    LDN    E29         INCOMPLETE TRANSFER
 REL90    RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  4
*         -READ ERROR LOG-  COMMAND PACKET
 RELCP    DATA   0#0006      PACKET LENGTH
 RELCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
 RELCP3   CON    OCREL+CMCHN+OMRELC  OP-CODE, CLEAR LOG AND CHAIN
 RELCP5   DATA   0#FFFF      ADDRESSEE
          SPACE  2
 V1       IFEQ   VALID,1     VALIDATE CPU TABLES/BUFFERS
          TITLE  VALIDATE CPU TABLES/BUFFERS
** NAME-- CHKPIT
*
** PURPOSE-- CHECK FOR VALID PP INTERFACE TABLE
          SPACE  2
 CHKPIT   SUBR               ENTRY/EXIT
          LDN    0
          STDL   T8
          LDML   PITB+/PIT/P.CBUFL  COMMUNICATION BUFFER LENGTH
          LPN    7
          NJK    CHKP100     IF LENGTH NOT A MULTIPLE OF WORDS

          LDML   PITB+/PIT/P.CBUFL  COMMUNICATION BUFFER LENGTH
          ADK    -B.CB       CHECK IF LONG ENOUGH
          MJK    CHKP100     IF NOT

          AODL   T8
          LDML   PITB+/PIT/P.CBUFL-1  RESERVED WORD OF PP COMMUNICATION
                             BUFFER DESCRIPTOR
          NJK    CHKP100     IF RESERVED WORD NOT ZERO

          AODL   T8
          LDML   PITB+/PIT/P.CBUF+1  COMMUNICATION BUFFER (RMA)
          LPN    7
          NJK    CHKP100     IF PP COMMUNICATION BUFFER NOT A WORD BOUNDARY

          AODL   T8
          LDML   PITB+/PIT/P.PPQPVA-1  RESERVED FIELD OF PP REQUEST
                             QUEUE DESCRIPTOR
          ADML   PITB+/PIT/P.PPQ-1
          NJK    CHKP100     IF RESERVED FIELD NOT ZERO

          AODL   T8
          LDML   PITB+/PIT/P.INT+1  INTERRUPT WORD (RMA)
          LPN    7
          NJK    CHKP100     IF INTERRUPT WORD NOT A WORD BOUNDARY
          AODL   T8
          LDML   PITB+/PIT/P.CHAN+1  CHANNEL TABLE (RMA)
          LPN    7
          NJN    CHKP100     IF CHANNEL TABLE NOT ON A WORD BOUNDARY

          AODL   T8
          LDML   PITB+/PIT/P.IN-3  IN POINTER RESERVED FIELD
          ADML   PITB+/PIT/P.IN-2
          ADML   PITB+/PIT/P.IN-1
          NJN    CHKP100     IF NON ZERO

          AODL   T8
          LDML   PITB+/PIT/P.OUT-3  OUT POINTER RESERVED FIELD
          ADML   PITB+/PIT/P.OUT-2
          ADML   PITB+/PIT/P.OUT-1
          NJN    CHKP100     IF NON ZERO

          AODL   T8
          LDML   PITB+/PIT/P.LIMIT-3  LIMIT POINTER RESERVED FIELD
          ADML   PITB+/PIT/P.LIMIT-2
          ADML   PITB+/PIT/P.LIMIT-1
          ZJK    CHKPITX     IF OK, EXIT

 CHKP100  BSS
          LDML   CHKPA,T8    INTERFACE ERROR CODE
          RJM    INTERR      SEND ERROR TO CM (NO RETURN)

 CHKPA    BSS
          CON    E20B        COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS
          CON    E204        RESERVED WORD OF PP COMMUNICATION
                             BUFFER DESCRIPTOR NOT ZERO
          CON    E203        PP COMMUNICATION BUFFER NOT A WORD BOUNDARY
          CON    E205        RESERVED FIELD OF PP REQUEST QUEUE
                             DESCRIPTOR NOT ZERO
          CON    E211        RMA OF INTERRUPT WORD NOT A WORD BOUNDARY
          CON    E212        RMA OF CHANNEL TABLE NOT A WORD BOUNDARY
          CON    E20D        RESERVED FIELD OF IN POINTER IS NOT ZERO
          CON    E20E        RESERVED FIELD OF OUT POINTER IS NOT ZERO
          CON    E20F        RESERVED FIELD OF LIMIT POINTER IS NOT ZERO
          SPACE  5,20
** NAME-- CHKUD
*
** PUPOSE-- CHECK FOR VALID UNIT DESCRIPTOR
*
** ENTRY-- UX IS INDEX INTO UNITS TABLE
*          UNIT DESCRIPTOR IS IN UNITD BUFFER
          SPACE  2
 CHKUD    SUBR               ENTRY/EXIT
          LDML   UNITS+/UN/P.UIT,UX   CHECK IF DUPLICIATE UNIT
          ADML   UNITS+/UN/P.UIT+1,UX
          ZJN    CHKUD10     IF NOT DUPLICIATE UNIT
          LDK    E208
          UJN    CHKUD30     GO REPORT ERROR

 CHKUD10  LDML   UNITD+/UD/P.UQT+1   UNIT INTERFACE TABLE RMA
          LPN    7
          ZJN    CHKUD20     IF OK
          LDK    E209        UNIT INTERFACE TABLE NOT A WORD BOUNDARY
          UJN    CHKUD30     GO REPORT ERROR

 CHKUD20  LDML   UNITD+/UD/P.UNIT  CHECK PHYSICAL UNIT NUMBER
          SHN    -3
          ZJN    CHKUDX      IF OK, EXIT
          LDK    E210        INVALID PHYSICAL UNIT NUMBER

 CHKUD30  RJM    INTERR      SEND ERROR TO CM (NO RETURN)
          SPACE  5,20
** NAME-- CHKRS
*
** PURPOSE-- CHECK FOR VALID PP RESPONSE BUFFER
          SPACE  2
 CHKRS    SUBR               ENTRY/EXIT
          LDML   PITB+/PIT/P.RSBUF-2  RESERVED WORD OF RESPONSE
                             BUFFER DESCRIPTOR
          ADML   PITB+/PIT/P.RSBUF-1
          ADML   PITB+/PIT/P.RSPVA-1
          NJN    CHKR100     IF RESERVED FIELD NOT ZERO

          LDML   PITB+/PIT/P.IN-3  RESERVED FIELD OF IN POINTER
          ADML   PITB+/PIT/P.IN-2
          ADML   PITB+/PIT/P.IN-1
          NJN    CHKR100     IF RESERVED FIELD NOT ZERO

          LDML   PITB+/PIT/P.OUT-3  RESERVED FIELD OF OUT POINTER
          ADML   PITB+/PIT/P.OUT-2
          ADML   PITB+/PIT/P.OUT-1
          NJN    CHKR100     IF RESERVED FIELD NOT ZERO

          LDML   PITB+/PIT/P.LIMIT-3
          ADML   PITB+/PIT/P.LIMIT-2
          ADML   PITB+/PIT/P.LIMIT-1
          ZJK    CHKRSX      IF RESERVED FIELD NOT ZERO

 CHKR100  LDK    E207        RESERVED FIELD NOT ZERO
          RJM    INTERR      REPORT ERROR (NO RETURN)
          SPACE  5,20
** NAME-- CHKUIT
*
** PURPOSE-- CHECK FOR VALID UNIT INTERFACE TABLE
*
** ENTRY-- UIT IS IN THE TS TABLE FOR THE PP
          SPACE  2
 CHKUIT   SUBR               ENTRY/EXIT
          LDN    0
          STDL   T8
          LDML   UITB+/UIT/P.LU   UIT UNIT NUMBER
          LMML   UNITD+/UD/P.LU  UD UNIT NUMBER
          NJN    CUT100      LOGICAL UNIT NUMBER MISMATCH
          AODL   T8
          LDML   UITB+/UIT/P.UBUFL-1  RESERVED FIELD OF UNIT
                             COMMUNICATION BUFFER DESCRIPTOR
          NJN    CUT100      RESERVED FIELD IS NOT ZERO

          AODL   T8
          LDML   UITB+/UIT/P.UBUFL  UNIT COMMUNICATION BUFFER LENGTH
          LPN    7
          NJN    CUT100
          AODL   T8
          LDML   UITB+/UIT/P.UBUF+1  UNIT COMMUNICATION BUFFER
          LPN    7
          NJN    CUT100      NOT A WORD BOUNDARY
          AODL   T8
          LDML   UITB+/UIT/P.NEXTPV-1  RESERVED FIELD OF UNIT
                             REQUEST QUEUE DESCRIPTOR
          ADML   UITB+/UIT/P.NEXT-2
          ADML   UITB+/UIT/P.NEXT-1
          ZJK    CHKUITX     IF OK

 CUT100   LDML   CUTA,T8     INTERFACE ERROR CODE
          RJM    INTERR      SEND ERROR TO CM (NO RETURN)

 CUTA     BSS
          CON    E301        LOGICAL UNIT NUMBER MISMATCH
          CON    E303        RESERVED FIELD OF UNIT COMMUNICATION
                             BUFFER DESCRIPTOR IS NOT ZERO
          CON    E307        UNIT COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS
          CON    E302        UNIT COMMUNICATION BUFFER NOT A WORD BOUNDARY
          CON    E305        RESERVED FIELD OF UNIT REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 V1       ENDIF
          TITLE  INITIALIZATION
** NAME-- INIT
*
** PURPOSE-- INITIALIZE DRIVER
*
** INPUT-- DSRTP = CM BYTE-ADDRESS OF THE WORD CONTAINING A POINTER
*                  TO THE PP INTERFACE TABLE.
          SPACE  2
 INIT     BSS                ENTRY POINT

* CLEAR MOST OF PP DIRECT CELLS

          LDK    DCCEND      CLEAR DCCEND DOWN THRU P1
          STDL   T8          SET INDIRECT CELL

 INIT10   LDN    0
          STIL   T8          CLEAR DIRECT CELL
          SODL   T8          CHECK FOR DONE
          PJN    INIT10      IF NOT DONE

* CLEAR PP MEMORY LOCATIONS

*    ON DEADSTART, ALL PP LOCATIONS FROM ENDCODE THRU ENDMEM ARE CLEARED.
*    ON RESUME, ALL THE ABOVE EXCEPT THE PP TS TABLE IS CLEARED.

          LDDL   INITFLG     CHECK IF DEADSTART INITIALIZE
          SBN    2
          ZJN    INIT30      IF RESUME

*         PROCESS DEADSTART INITIALIZE
          LDK    ENDMEM-ENDCODE
          STDL   T1          SET INDEX

 INIT20   LDN    0
          STML   ENDCODE,T1  CLR PP WORD
          SODL   T1          DECREMENT INDEX
          PJN    INIT20      IF NOT DONE LOOP
          UJN    INIT60      CONT.

 INIT30   BSS
*         PROCESS RESUME INITIALIZE
          LDK    ENDMEM-TS-P.TS
          STDL   T1          SET INDEX

 INIT40   LDN    0
          STML   TS+P.TS,T1  CLR PP WORD
          SODL   T1          DECREMENT INDEX
          PJN    INIT40      IF NOT DONE LOOP

          LDK    TS-ENDCODE-1
          STDL   T1          SET INDEX

 INIT50   LDN    0
          STML   ENDCODE,T1  CLR PP WORD
          SODL   T1          DECREMENT INDEX
          PJN    INIT50      IF NOT DONE LOOP

*  READ PP-INTERFACE-TABLE AND UNIT DESCRIPTOR TABLES.  NOTE - THIS IS
*  THE ONLY PLACE THE STATIC FIELDS OF THE PIT AND THE UNIT DESCRIPTOR
*  TABLES ARE READ INTO THE PP.  IF THE UNIT DESCRIPTOR TABLES EVER
*  CONTAIN DYNAMIC FIELDS, THEY MUST BE READ IN WHEN LOOKING FOR UNIT
*  REQUESTS.  ONLY UNIT DESCRIPTORS THAT ARE NOT NULL ENTRIES ARE
*  CONVERETED TO *UN* ENTRIES IN THE PP UNITS TABLE.

 INIT60   LDK    C.PIT       LENGTH OF PIT
          STDL   WC
          REFAD  DSRTP,CM.PIT  REFORMAT CM ADDRESS OF PIT
          LOADC  CM.PIT      LOAD R+A OF PIT
          CRML   PITB,WC     READ PIT

*  REFORMAT ADDRESS OF THE INTERRUPT WORD.

          REFAD  PITB+/PIT/P.INT,CM.INT

*  REFORMAT ADDRESS OF CHANNEL TABLE.

          REFAD  PITB+/PIT/P.CHAN,CM.CHAN

*  REFORMAT ADDRESS OF PP COMMUNICATIONS BUFFER

          REFAD  PITB+/PIT/P.CBUF,CM.COM

*  REFORMAT ADDRESS OF RESPONSE BUFFER.
*  INITIALIZE LIM.

          REFAD  PITB+/PIT/P.RSBUF,CM.RS  REFORMAT ADDRESS OF RESP. BUFFER
          LDML   PITB+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STDL   LIM

          LDML   PITB+/PIT/P.PPNO   SET PP NUMBER
          STDL   PPNO

          LDML   TS1         USE PP TS TABLE
          STDL   CTST

          LDDL   INITFLG     CHECK IF INITIALIZATION IS FROM A RESUME
          SBN    2
          NJN    INIT70      IF NOT
          RJM    RERESP      SEND RESUME RESPONSE
 INIT70   BSS

 V2       IFEQ   VALID,1     VALIDATE CPU TABLES/BUFFERS
          RJM    CHKPIT      VALIDATE PIT
          RJM    CHKRS       VALIDATE RESPONSE BUFFER
 V2       ENDIF

          LDN    0           INITIALIZE LOOP CONTROL
          STDL   T2          NUMBER OF NON-NULL UNIT DESCRIPTORS
          STDL   T4          CM WORD OFFSET INTO UNIT DESCRIPTORS
          LDML   PITB+/PIT/P.UNITC  NUMBER OF UNIT DESCRIPTORS
          STDL   T1
          NJN    INIT80      IF UNITS DEFINED
          LDK    E213        NO DEFINED ACTIVE UNITS
          RJM    INTERR      INTERFACE ERROR (NO RETURN)

 INIT80   LOADC  CM.PIT      LOAD R REGISTER FOR PIT
          ADK    C.PIT       ADVANCE TO START OF UNIT DESCRIPTORS
          ADDL   T4          CM WORD OFFSET OF CURRENT UD
          CRML   UNITD,TWO   READ UD ENTRY INTO PP
          SODL   T1          DECREMENT TOTAL UNIT COUNT FROM PIT
          LDML   UNITD+/UD/P.UQT
          ADML   UNITD+/UD/P.UQT+1
          ZJK    INIT110     IF DUMMY ENTRY, DO NOT COUNT

*         BUILD UNITS AND SLAVE CONFIGURED TABLE INDEXES

          LDML   UNITD+/UD/P.CNTRLR  GET SLAVE NUMBER
          LPN    7B
          SHN    2
          STDL   SX          SET SLAVES CONFIGURED INDEX
          SHN    3
          STDL   UX          SAVE SLAVE OFFSET FOR UNITS TABLE INDEX
          LDML   UNITD+/UD/P.UNIT  GET FACILITY NUMBER
          LPN    7B
          SHN    2
          RADL   UX          SET UNITS TABLE INDEX

* CHECK FOR CHANGES IN SL AND UN
          ERRNZ  4-P.SL      IF SL HAS CHANGED
          ERRNZ  4-P.UN      IF UN HAS CHANGED
          ERRNZ  32-FACPSL*P.UN  IF FACILITIES PER SLAVE HAS CHANGED

 V3       IFEQ   VALID,1     VALIDATE CPU TABLES/BUFFERS
          RJM    CHKUD       VALIDATE UNIT DESCRIPTORS
          LDK    C.UIT       READ IN UIT AND VALIDATE
          STDL   WC          SAVE WORD COUNT
          LOADF  UNITD+/UD/P.UQT
          CRML   UITB,WC     READ UIT INTO PP TS TABLE
          RJM    CHKUIT      VALIDATE UIT
          LDML   UITB+/UIT/P.UTYPE   CHECK UNIT TYPE
          ADK    -T698.1
          ZJN    INIT85      IF OK
          LDK    E306        INVALID UNIT TYPE
          RJM    INTERR      REPORT ERROR  (NO RETURN)
 INIT85   BSS
 V3       ENDIF

* BUILD UNITS TABLE

          LDML   UNITD+/UD/P.LU  LOGICIAL UNIT NUMBER
          STML   UNITS+/UN/P.LU,UX

          LOADF  UNITD+/UD/P.UQT  REFORMAT AND SAVE UIT RMA
          STML   UNITS+/UN/P.UIT+1,UX  SAVE 2 HALF
          LDML   UNITD+/UD/P.UQT
          STML   UNITS+/UN/P.UIT,UX    SAVE 1 HALF

          LDML   UNITD+/UD/P.CHAN      GET CHANNEL NUMBER
          SHN    /UD/L.CHAN+/UD/N.CHAN+2  POSITION IT
          LPN    37B         MASK IT
          STDL   T3          SAVE IT
          LDDL   T2          CHECK IF FIRST ENTRY
          NJN    INIT90      IF NOT
          LDDL   T3          GET CHANNEL NUMBER
          STDL   CURCH       SET CURRENT CHANNEL

 INIT90   LDDL   T3          COMPARE CHANNEL NUMBERS
          LMDL   CURCH
          ZJN    INIT100     IF THE SAME
          LDK    E20A        INVALID CHANNEL NUMBER
          RJM    INTERR      REPORT ERROR (NO RETURN)

 INIT100  LDML   UNITD+/UD/P.UNIT   GET UNIT NUMBER
          LPN    7B
          STDL   T3          SAVE AS BIT SIGNIFICIANT INDEX
          LMK    /UN/K.CTF   SET CONFIDENCE TESTING REQUIRED FLAG
          STML   UNITS+/UN/P.FN,UX  SET FACILITY NUMBER

          LDML   SELT,T3     GET FACILITY BIT ADDRESS
          LMML   SLB+/SL/P.FBA,SX  MERGE WITH EXISTING FACILITIES
          STML   SLB+/SL/P.FBA,SX  SAVE THE UPDATE

          LDML   UNITD+/UD/P.CNTRLR  GET CONTROLER NUMBER
          LPN    7B
          SHN    /UN/N.FN  POSITION IT
          RAML   UNITS+/UN/P.SN,UX   SET SLAVE NUMBER

          AODL   T2          INCREMENT COUNT OF TOTAL ACTIVE UNITS
          ADK    -MAXUD
          ZJN    INIT120     IF REACHED MAX TABLE SPACE FOR UD-S

 INIT110  LDK    C.UD        INCREMENT TO NEXT CM UD
          RADL   T4
          LDDL   T1          CHECK TOTAL UNITS COUNT FROM PIT
          NJK    INIT80      IF NOT DONE SCANNING UD TABLES

 INIT120  LDDL   T1          CHECK IF MORE UD-S
          ZJN    INIT130     IF NONE LEFT
          LDK    E208        TO MANY CONFIGURED UNITS
          RJM    INTERR      REPORT ERROR  (NO RETURN)

 INIT130  LDDL   T2          RESET NUMBER OF ACTIVE UNITS
          STML   PITB+/PIT/P.UNITC
          NJN    INIT150     IF ANY ACTIVE UNITS DEFINED

          LDN    75B         NO ACTIVE UNITS
          STDL   IDLFLG      FORCE SET IDLE FLAG
*         DO NOT GENERATE ANY RESPONSE, WAIT FOR RESUME COMMAND
          LJM    MAIN        GO TO MAIN

*  INITIALIZE CONFIGURED SLAVES BY BIT ADDRESS (CSLVS)
*  AND TOTAL SLAVES CONFIGURED NUMBER (TSLVS) CELLS.

 INIT150  LDN    MAXSL       INITIALIZE LOOP COUNT
          STDL   T1
          LDN    0           INITIALIZE INDEX
          STDL   T2
          LDN    1           INITIALIZE SLIDING MASK
          STDL   T3
          LDN    0           INITIALIZE CSLVS AND TSLVS CELLS
          STDL   CSLVS
          STDL   TSLVS

 INIT160  LDML   SLB+/SL/P.FBA,T2  CHECK IF SLAVE IS CONFIGURED
          ZJN    INIT170     IF NOT
          LDDL   T3          SET CONFIGURED SLAVE BIT
          RADL   CSLVS
          AODL   TSLVS       INCREMENT TOTAL SLAVES CONFIGURED

 INIT170  LDDL   T3          SLIDE MASK
          SHN    1
          STDL   T3
          LDN    P.SL        INCREMENT INDEX
          RADL   T2
          SODL   T1          CHECK FOR DONE
          NJN    INIT160     IF NOT

* INITIALIZE SLAVE TS TABLES USABLE

          LDN    MCSLV       MAXIMUM CONCURRENT SLAVES TO SUPPORT
          SBDL   TSLVS       TOTAL CONFIGURED SLAVES
          MJN    INIT180     USE MAXIMUM VALUE
          LDDL   TSLVS       ELSE USE TOTAL SLAVES CONFIGURED
          UJN    INIT190

 INIT180  LDN    MCSLV       SET MAXIMUM VALUE

 INIT190  BSS
          STML   TNTAB       SAVE TOTAL NUMBER OF SLAVE TABLES TO SUPPORT

*  INITIALIZE CHANNEL INSTRUCTIONS.

          LDK    CONCH       MODIFY CHANNEL INSTRUCTIONS
          RJM    CHGCH

*  CLEAR PP COMMUNICATIONS BUFFER

          LDN    0           ZERO OUT *ZEROES* FIELD IN COMM. BUFFER
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDK    /CB/B.ZEROES  LENGTH OF ZERO AREA IN BYTES
          SHN    -3
          STDL   T5          LENGTH OF ZERO AREA IN CM WORDS

 INIT200  LOADC  CM.COM      LOAD R AND A OF COMMUNICATION BUFFER
          ADK    /CB/C.ZEROES-1
          ADDL   T5
          CWDL   T1          ZERO ONE CM WORD
          SODL   T5          DECREMENT INDEX
          NJN    INIT200     IF MORE CM WORDS TO CLEAR

* CLEAR REMAINING DIRECT CELLS

          LDN    T8          STARTING ADDRESS
          STDL   T1          SET INDIRECT CELL

 INIT210  LDN    0
          STIL   T1          CLEAR DIRECT CELL
          SODL   T1          CHECK FOR DONE
          PJN    INIT210     IF NOT
          LDN    0           CLEAR THE LAST CELL
          STDL   T1

*  EXIT TO MAIN IDLE LOOP

          LJM    MAIN        EXIT
          TITLE  PP TABLES AND BUFFERS
 CONCH    BSS                CHANNEL MODIFICATION LIST
 TDC+40B  HERE
 T40B+DC  HERE
 TDC      HERE
          CON    0           END OF TABLE
          SPACE  2
* BIT SIGNIFICANT SELECTION ADDRESS TABLE
 SELT     DATA   1,2,4,8
          DATA   16,32,64,128

          ERRNZ  8-SLVPCH    IF NUMBER OF SLAVES PER CHANNEL CHANGES
          SPACE  2
* SLAVE RESET EXECUTED TABLE,  INDEXED BY SLAVE ADDRESS
 SRTAB    BSSZ   MAXSL       NON ZERO ENTRY = SLAVE RESET EXECUTED
          SPACE  2
* TS TABLE ADDRESSES
 TS1      CON    TS          PP TS TABLE
 TS2      CON    TS+1*P.TS   FIRST SLAVE TS TABLE
 TS3      CON    TS+2*P.TS   NEXT TABLE

          ERRNZ  3-MAXTS     IF NUMBER OF TS TABLES CHANGE

 SCRATCH  BSSZ   100         SCRATCH AREA

 SLVEL    BSSZ   20          SLAVE ERROR LOG BUFFER
 FACEL    BSSZ   20          FACILITY ERROR LOG BUFFER
          SPACE  2
 ENDCODE  EQU    *           END OF PP CODE AREA
          SPACE  2
 FH2      IFEQ   FH,1        FUNCTION HISTORY TABLE
*
*         WORKING MEMORY
*
 FBUF     BSSZ   64          FUNCTION HISTORY BUFFER
 FBUFL    EQU    *-FBUF      FUNCTION HISTORY BUFFER LENGTH
          SPACE  2
 FH2      ENDIF
 KH3      IFEQ   KH,1        COMMAND/RESPONSE HISTORY
 HB       BSSZ   256         IPI COMMAND/RESPONSE HISTORY BUFFER
*         HB LENGTH MUST BE A MULTIPLE OF 8
 HBL      EQU    *-HB        HISTORY BUFFER LENGTH
 KH3      ENDIF
          SPACE  4
*
*         CHECK FOR BUFFER OVERLAP
*
          ERRNG  STRTBUF-*
          EJECT
          END
/EOR
*DECK DECK=IOM$TAPD EXPAND=TRUE
          IDENT  TAPD
          CIPPU
          MEMSEL 8
          TITLE  IOM$TAPD - 5698-1X TAPE DRIVER FOR I4.
          COMMENT  *SMD* LVL=04
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4
*         THIS IS THE PP DRIVER FOR THE IPI CHANNEL THAT SUPPORTS THE
*         5698-1X IPI TAPE SLAVE WITH 698-3X TAPE FACILITIES ON THE
*         CYBER I4 IOU SYSTEMS. THE PROGRAM NAME IS E9P5698 AND THE DECK
*         NAME IS IOM$TAPD.
*
*         WHEN THE PP DRIVER IS LOADED THE FOLLOWING LOCATIONS ARE REQUIRED.
*         72 AND 73 MUST CONTAIN THE RMA OF THE PP INTERFACE TABLE (PIT).
*         0 MUST CONTAIN THE ADDRESS-1 AT WHICH EXECUTION BEGINS.
          TITLE  IODMAC1 MACROS
*COPYC IODMAC1
          TITLE  IODMAC2 MACROS
*COPYC IODMAC2
          TITLE  IODMAC3 MACROS
*COPYC IODMAC3
          TITLE  IODMAC4 MACROS
*COPYC IODMAC4
          TITLE  SPECIAL MACROS
          SPACE  4
**        SUBR - DEFINE SUBROUTINE ENTRY/EXIT.
*
*NAME     SUBR
*         DECLARE *NAME* TO BE THE ENTRY POINT TO A PP SUBROUTINE
*         WHICH IS ENTERED VIA *RJM* TO *NAME*.
*
*         THE FOLLOWING CODE IS GENERATED.
*NAMEX    LJM    *
*NAME     EQU    *-1

          PURGMAC  SUBR

          MACRO  SUBR,A
 A_X      LJM    *
 A        EQU    *-1
          ENDM
          TITLE  CPU RECORD DEFINITIONS AND EQUATES
*
* PP INTERFACE TABLE
*

 PIT      RECORD PACKED

* WORD 1
 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
* WORD 2
          ALIGN  0,64
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
* WORD 3
 FILL1    PPWORD             UNUSED
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
* WORD 4
 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER
* WORD 5
          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)
* WORD 6
          ALIGN  32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)
* WORDS 7-8
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
* WORD 9
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
* WORD 10
          ALIGN  48,64
 IN       PPWORD             IN POINTER
* WORD 11
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
* WORD 12
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          EJECT
*
* UNIT DESCRIPTORS.
*

 UD       RECORD PACKED

* WORD 1
 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
* WORD 2
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 UD       RECEND
          SPACE  4
*
* UNIT INTERFACE TABLE
*

 UIT      RECORD PACKED

* WORD 1
 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
 QCNT     PPWORD             NOT USED
* WORD 2
          ALIGN  16,64
 UBUFL    PPWORD             UNIT COMMUNICATION BUFFER LENGTH
 UBUF     RMA                UNIT COMMUNICATION BUFFER (RMA)
* WORD 3
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
* WORD 4
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
* WORD 5
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
* WORD 6
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

          MASKP  DSABLE
 K.DSABLE EQU    MSK

 UIT      RECEND
          EJECT
*
* UNIT COMMUNICATION AREA
*

 UCA      RECORD PACKED

* WORD 1
 IN       PPWORD
 LIMIT    PPWORD
* WORDS 2-5
          ALIGN  0,64
 FILL1    STRUCT 32          RESERVRD

 UCA      RECEND
          SPACE  5
*
* REQUEST QUEUE
*

 RQ       RECORD PACKED

* WORD 1
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
* WORD 2
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
* WORD 3
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS
                               0 - ENABLE RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
 LONGB    BOOLEAN            LONG INPUT BLOCK
* WORD 4
          ALIGN  0,64
 SECADR   INTEGER            SECONDARY ADDRESS
* WORDS 5-64  COMMANDS

 RQ       RECEND
          EJECT
*
* COMMANDS
*

 CM       RECORD PACKED

* WORD 1
 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$

 CM       RECEND
          EJECT
*
* PP RESPONSE.
*

 RS       RECORD PACKED

* WORD 1
          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST
* WORD 2
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST
* WORD 3
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64       ALERT MASK
 LONGB    BOOLEAN            LONG INPUT BLOCK
* WORD 4
          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE INTERFACE
                             ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
 CHERR    BOOLEAN            CHANNEL PARITY ERROR ON INPUT
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION
                             OCCURRED ON INPUT OR INADEQUATE DATA RATE ON OUTPUT
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A
                             HARDWARE MALFUNCTION.  EXAMPLE- UNIT NOT READY.
 FTO      BOOLEAN            FUNCTION TIMEOUT
 CHERO    BOOLEAN            CHANNEL PARITY ERROR ON OUTPUT
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
                               1 - RECOVERED ERROR
                               2 - COMMAND HAD EXPLICIT RESPONSE FLAG SET
                               3 - BOTH CONDITIONS 1 AND 2
 K.REC    EQU    1           RECOVERED ERROR
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE
                               1 - UNIT CHANGED FROM READY TO NOT READY
                               2 - UNIT CHANGED FROM NOT READY TO READY
                               3 - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
                               4 - CONTROLLER RESERVED TO ANOTHER ACCESS
                               5 - UNIT RESERVED TO ANOTHER ACCESS
                               6 - RECOVERED ABNORMAL CONDITION
                               7 - DEADSTART RESPONSE
                               8 - INITIALIZATION ERROR
                                   (CHECK ERRID FOR CONDITION)
          ALIGN  48,64       ALERT CONDITIONS
 LNGBLK   BOOLEAN            LONG INPUT BLOCK
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
 PDLIM    BOOLEAN            PHYSICAL DELIMITER ENCOUNTERED (EOT OR BOT)
 LDLIM    BOOLEAN            LOGICAL DELIMITER ENCOUNTERED (TAPE MARK)
 CHARF    BOOLEAN            CHARACTER FILL PERFORMED
 DUNIT    BOOLEAN            UNIT WAS DISABLED BY PP
* WORD 5
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)
* WORD 6-13
 IOR      STRUCT 64          INDIVIDUAL OPERATION RESULTS
                             (BLOCK ID AND ON-THE-FLY CORRECTIONS)
* WORD 14
 ERRID    PPWORD             ERROR IDENTIFICATION
 FUNTO    PPWORD             FUNCTION WITH TIMEOUT
 STREG    PPWORD             STATUS REGISTER IPI CHANNEL
 ERREG    PPWORD             ERROR REGISTER IPI CHANNEL
* WORD 15
 DOWNST   PPWORD             DOWN STATUS
 K.PDN    EQU    8           PP IDLED ITSELF
 K.FDN    EQU    4           PP DOWNED THE FACILITY
 K.SDN    EQU    2           PP DOWNED THE SLAVE
 K.CDN    EQU    1           PP DOWNED THE CHANNEL
 K.NDN    EQU    0           PP DOWNED NOTHING

 CR       PPWORD             CONTROL REGISTER
 OSR      PPWORD             OPERATIONAL STATUS REGISTER
 DMAER    PPWORD             DMA ERROR REGISTER
* WORD 16
 FACSTA   STRUCT 4           FACILITY STATUS, IPI ID52
 WC       PPWORD             WORDS NOT TRANSFERED (PP USAGE ONLY)
 FILL1    PPWORD             RESERVED

* WORDS 17-48                IPI RESPONSE PACKET IF PRESENT
*                            VARIABLE LENGTH
          EJECT

          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$
          MASKP  ABALRT
 K.ABALRT EQU    MSK
          MASKP  INTERR
 K.INTERR EQU    MSK
          MASKP  HDWR
 K.HDWR   EQU    MSK
          MASKP  CHERR
 K.CHERR  EQU    MSK
          MASKP  DATOV
 K.DATOV  EQU    MSK
          MASKP  FTO
 K.FTO    EQU    MSK
          MASKP  LNGBLK
 K.LNGBLK EQU    MSK
          MASKP  PDLIM
 K.PDLIM  EQU    MSK
          MASKP  LDLIM
 K.LDLIM  EQU    MSK
          MASKP  CHARF
 K.CHARF  EQU    MSK
          MASKP  DUNIT
 K.DUNIT  EQU    MSK
          MASKP  CHERO
 K.CHERO  EQU    MSK

 RS       RECEND
          EJECT
*
* PP COMMUNICATION BUFFER.
*

 CB       RECORD PACKED

* WORD 1
          ALIGN  31,64
 SLAVE    BOOLEAN            NONZERO IF SLAVE PP
 PARTNR   RMA                PARTNERS PIT (RMA)
* WORD 2
 CONTRL   STRUCT 8           LOAD CONTROLWARE COMMAND
* WORD 3
 CMCMD    STRUCT 8           SLAVE COMMAND
* WORD 4
 OVRLAY   STRUCT 8           OVERLAY RMA
* WORDS 5-8
 FILL1    STRUCT 32          RESERVED
* WORDS 9-13
 SCRAT    STRUCT 40          SCRATCH AREA
* WORDS 14-28
 ZEROES   STRUCT 120         120 BYTES (15 CM WORDS) OF ZERO
* WORDS 29-544
 PTD      STRUCT 4128        PATH TEST DATA (516 CM WORDS)


          MASKP  SLAVE
K.SLAVE   EQU    MSK


 CB       RECEND
          TITLE  PP RECORD DEFINITIONS AND EQUATES
          SPACE  3
*
* CONFIGURED SLAVES.
*

 SL       RECORD PACKED

* PP WORD 1
 FBA      PPWORD             FACILITITES (BY ADDRESS BIT) ON THIS SLAVE

* PP WORD 2
 SIU      PPWORD             SLAVE IN USE FLAG

* PP WORD 3
 FACLCK   SUBRANGE 0,1777B   CURRENT FACILITY LOCKED FLAG
 CURFAC   SUBRANGE 0,77B     CURRENT FACILITY NUMBER (FOR USE IN SCANNING)

* PP WORD 4
 SLVTST   PPWORD             SLAVE TESTING REQUIRED  = 1
*                                ATTRIBUTES REQUIRED = 2

 SL       RECEND
          SPACE  4
*
* CONFIGURED UNITS.
*

 UN       RECORD PACKED

* PP WORD 1
 FILL1    SUBRANGE 0,37B     RESERVED
 PORT     SUBRANGE 0,3       IPI CHANNEL PORT, 0=PORT A, 1=PORT B
 FC       BOOLEAN            FACILITY CONFIGURED
 FD       BOOLEAN            FACILITY DISABLED
 CTF      BOOLEAN            CONFIDENCE TEST REQUIRED FLAG
 SN       SUBRANGE 0,7       SLAVE NUMBER
 FN       SUBRANGE 0,7       FACILITY NUMBER

* PP WORD 2
 LU       PPWORD             LOGICIAL UNIT NUMBER

* PP WORDS 3-5
 UIT      STRUCT 6           RMA OF UNIT INTERFACE TABLE (REFORMATTED)


          MASKP  PORT
 K.PORT   EQU    MSK
          MASKP  FC
 K.FC     EQU    MSK
          MASKP  FD
 K.FD     EQU    MSK
          MASKP  CTF
 K.CTF    EQU    MSK

 UN       RECEND
          EJECT
 MBID     EQU    30          MAX. NUMBER OF BLOCK ID-S TO SUPPORT (PP WORDS)
 MAXREQ   EQU    65          MAX. REQUEST LENGTH (CM WORDS)
 MAXSDC   EQU    10          MAX. NUMBER OF DIRECT CELLS TO SAVE IN TS TABLE
          SPACE  2
*
* TS TABLE DEFINITIONS.
*

 TS       RECORD PACKED

* PP WORD 1
 CRN      PPWORD             USED TO MAKE COMMAND REFERENCE NUMBER UNIQUE
*                            CRN MUST BE THE FIRST WORD OF THE TS TABLE

* PP WORD 2
 SN       SUBRANGE 0,377B    SLAVE NUMBER
 FN       SUBRANGE 0,377B    FACILITY NUMBER

* PP WORDS 3-6
 CPVACM   STRUCT 2           FILL FOR CM BOUNDARY
 CPVA     STRUCT 6           CURRENT REQUEST PVA (UNFORMATTED)

* PP WORDS 7-10
 CREQCM   STRUCT 4           FILL FOR CM BOUNDARY
 CREQ     STRUCT 4           CURRENT REQUEST RMA (UNFORMATTED)

* PP WORD 11
 LASTC    PPWORD             OFFSET OF COMMAND IN REQUEST

* PP WORD 12
 NUMCM    PPWORD             NUMBER OF COMMANDS LEFT TO PROCESS

* PP WORD 13
 ILSTL    PPWORD             NUMBER OF INDIRECT LIST ADDRESS-LENGTH PAIRS

* PP WORDS 14-15
 XFER     STRUCT 4           TRANSFER COUNT

* PP WORD 16
 CLK      PPWORD             STARTING OPERATION CLOCK VALUE

* PP WORD 17
 SECLIM   PPWORD             SECONDS LIMIT FOR CURRENT OPERATION

* PP WORDS 18-21
 CURCMD   STRUCT 8           CURRENT COMMAND

* PP WORD 22
 DENSEL   PPWORD             DENSITY SELECTION
                              1 = 1600 (PE)
                              2 = 6250 (GCR)
* PP WORD 23
 ECSEL    PPWORD             ERROR CORRECTION SELECTION
                              1 = EC ENABLED
                              2 = EC DISABLED
* PP WORD 24
 BIDEF    PPWORD             BLOCK ID EXPECTED FLAG
                              0 = NONE
                              1 = BID EXPECTED
                              2 = TAPE MARK EXPECTED
                              3 = EITHER TM OR BID EXPECTED
* PP WORD 25
 SCOND    PPWORD             STATUS CONDITIONS
                             100000 = LONG BLOCK
                              20000 = PHYSICAL DELIMITER (EOT)
                              10000 = LOGICIAL DELIMITER (TAPE MARK)
                               4000 = CHARACTER FILL
* PP WORD 26
 CHAIN    PPWORD             IPI COMMAND CHAINING FLAG
                             X0 = LAST COMMAND CHAIN WAS NOT ABORTED
                             X1 = LAST COMMAND CHAIN WAS ABORTED
                             0X = LAST COMMAND SENT WAS NOT CHAINED
                             2X = LAST COMMAND SENT WAS CHAINED
* PP WORDS 27-28
 FACSTA   STRUCT 4           FACILITY STATUS, IPI ID52

* PP WORDS 29-30
 ILSTA    STRUCT 4           INDIRECT LIST RMA (UNFORMATTED) ADDRESS

* PP WORDS 31-34
 ILSTP    STRUCT 8           INDIRECT LIST LENGTH/ADDRESS PAIR

* PP WORD 35
 CBURBC   PPWORD             CURRENT BURST BYTE COUNT

* PP WORD 36
 PARLAP   PPWORD             PARTIAL LENGTH/ADDRESS PAIR FLAG

* PP WORD 37
 RESBC    PPWORD             RESIDUAL BYTE COUNT FROM TRANSFER

* PP WORD 38
 SLVEES   PPWORD             SLAVE ENCODED ENDING STATUS

* PP WORD 39
 RETRY    PPWORD             RETRY COUNTER

* PP WORD 40
 NSCA     PPWORD             NON-STOP COMMAND ADDRESS (PP ADDRESS)

* PP WORD 41
 NSWC     PPWORD             NON-STOP WRITE COUNTER

* PP WORD 42
 NSRC     PPWORD             NON-STOP READ COUNTER

* PP WORD 43
 NSCRN    PPWORD             NON-STOP COMMAND REFERENCE NUMBER

* PP WORD 44
 WSTNF    PPWORD             WAIT SPECIAL TRANSFER NOTIFICATION FLAG

* PP WORD 45
 GNSCRN   PPWORD             GROUP NON-STOP COMMAND REFERENCE NUMBER

* PP WORD 46
 GNUMCM   PPWORD             GROUP NUMBER OF COMMANDS LEFT

* PP WORD 47
 GNSCA    PPWORD             GROUP NON-STOP PP COMMAND ADDRESS
          SPACE  4
* TS BUFFERS

*         BLOCK ID BUFFERS
 BIDB     STRUCT MBID*2      BLOCK ID BUFFER
 OTFC     PPWORD             ON-THE-FLY ERROR CORRECTION COUNTER
 BIDBP    PPWORD             BLOCK ID BUFFER POINTER

*         RECORD TRANSFER COUNT CIRCULAR BUFFER
 RTCIP    PPWORD             IN POINTER
 RTCOP    PPWORD             OUT POINTER
 RTCB     STRUCT 16          BUFFER FOR 4 32-BIT RECORD TRANSFER COUNTS


*         NOTE - ALL TS TABLE CELLS UP TO HERE ARE CLEARED DURING
*                NEW REQUEST INITIALIZATION PROCESSING.

*         SWITCH BUFFERS
 SAVEDC   STRUCT MAXSDC*2    SAVED DIRECT CELLS WHEN SWITCHING TS TABLES
 SATTR    PPWORD             SAVED SUBROUTINE ADDRESSES WHEN SWITCHING
 SOPMO    PPWORD
 SCFC     PPWORD
 SGFS     PPWORD
 SRSEL    PPWORD
 SRFEL    PPWORD
 SCLREQ   PPWORD
 SPTW     PPWORD
 SPTR     PPWORD
 SSLVT    PPWORD
 SISR     PPWORD
 SLIR     PPWORD
 SPTWOD   PPWORD
 SPTRID   PPWORD
 SREL     PPWORD
 SFACT    PPWORD
 SIH      PPWORD
 SWSTN    PPWORD

 RQB      STRUCT C.RQ*8      UNIT REQUEST HEADER BUFFER

 CQB      STRUCT C.CM*8*MAXREQ  UNIT COMMAND SEQUENCE BUFFER

 SPARE    STRUCT 14          SPARE BYTES

 TS       RECEND
          EJECT
* DEFINED RECORD EQUATES

* PP INTERFACE TABLE
 EBPIT    EQU    B.PIT       BYTE LENGTH
 EPPIT    EQU    P.PIT       PP WORD LENGTH
 ECPIT    EQU    C.PIT       CM WORD LENGTH

* UNIT DESCRIPTOR
 EBUD     EQU    B.UD        BYTE LENGTH
 EPUD     EQU    P.UD        PP WORD LENGTH
 ECUD     EQU    C.UD        CM WORD LENGTH

* UNIT INTERFACE TABLE
 EBUIT    EQU    B.UIT       BYTE LENGTH
 EPUIT    EQU    P.UIT       PP WORD LENGTH
 ECUIT    EQU    C.UIT       CM WORD LENGTH

* UNIT COMMUNICATIONS BUFFER
 EBUCA    EQU    B.UCA       BYTE LENGTH
 EPUCA    EQU    P.UCA       PP WORD LENGTH
 ECUCA    EQU    C.UCA       CM WORD LENGTH

* REQUEST QUEUE
 EBRQ     EQU    B.RQ        BYTE LENGTH
 EPRQ     EQU    P.RQ        PP WORD LENGTH
 ECRQ     EQU    C.RQ        CM WORD LENGTH

* COMMAND QUEUE
 EBCM     EQU    B.CM        BYTE LENGTH
 EPCM     EQU    P.CM        PP WORD LENGTH
 ECCM     EQU    C.CM        CM WORD LENGTH

* RESPONSE BUFFER (IPI RESPONSE BUFFER NOT INCLUDED)
 EBRS     EQU    B.RS        BYTE LENGTH
 EPRS     EQU    P.RS        PP WORD LENGTH
 ECRS     EQU    C.RS        CM WORD LENGTH

* PP COMMNUNICATIONS BUFFER
 EBCB     EQU    B.CB        BYTE LENGTH
 EPCB     EQU    P.CB        PP WORD LENGTH
 ECCB     EQU    C.CB        CM WORD LENGTH

* CONFIGURED SLAVES
 EBSL     EQU    B.SL        BYTE LENGTH
 EPSL     EQU    P.SL        PP WORD LENGTH
 ECSL     EQU    C.SL        CM WORD LENGTH

* CONFIGURED UNITS
 EBUN     EQU    B.UN        BYTE LENGTH
 EPUN     EQU    P.UN        PP WORD LENGTH
 ECUN     EQU    C.UN        CM WORD LENGTH

* TAPES SUPPORTED TABLE
 EBTS     EQU    B.TS        BYTE LENGTH
 EPTS     EQU    P.TS        PP WORD LENGTH
 ECTS     EQU    C.TS        CM WORD LENGTH
          TITLE  BUFFER EQUATES
*
* RESPONSE BUFFER EQUATES
*
 HRESPL   EQU    P.RS        NORMAL RESPONSE LENGTH (IN PP WORDS)
 NRL      EQU    HRESPL*2    NORMAL RESPONSE LENGTH (IN BYTES)

 SRESPL   EQU    128+1       MAX. IPI RESPONSE LENGTH +1 (IN PP WORDS)

 MRESPL   EQU    HRESPL+SRESPL  MAX. TOTAL RESPONSE BUFFER +1 (IN PP WORDS)
          SPACE  4
*
* CONFIGURATION EQUATES
*
 MAXCHP   EQU    2           MAX. NUMBER OF CHANNEL PORTS TO SUPPORT
 SLVPCH   EQU    8           MAX. NUMBER OF SLAVES PER CHANNEL PORT TO SUPPORT

 MAXSL    EQU    MAXCHP*SLVPCH  MAX. TOTAL SL TABLES TO SUPPORT

 FACPSL   EQU    8           MAX. NUMBER OF FACILITIES PER SLAVE TO SUPPORT
 MAXUD    EQU    MAXSL*FACPSL  MAX. TOTAL FACILITIES TO SUPPORT

 MCSLV    EQU    2           MAX. NUMBER OF CONCURRENT SLAVES TO SUPPORT
 MAXTS    EQU    1+MCSLV     MAX. NUMBER OF TS TABLES TO SUPPORT
          SPACE  4
*
* BUFFER EQUATES
*

 ENDMEM   EQU    17771B            LARGEST DRIVER ADDRESS

 RPB      EQU    ENDMEM-SRESPL     IPI RESPONSE PACKET BUFFER

 RS       EQU    RPB-P.RS          PP RESPONSE BUFFER

 PITB     EQU    RS-P.PIT          PP INTERFACE TABLE

 SLB      EQU    PITB-P.SL*MAXSL   SLAVES CONFIGURED TABLE

 UNITS    EQU    SLB-P.UN*MAXUD    FACILITIES CONFIGURED TABLE

 TS       EQU    UNITS-P.TS*MAXTS  TS TABLES
*         NOTE   THE FIRST TS TABLE IS FOR PP REQUESTS

 STRTBUF  EQU    TS                STARTING BUFFER ADDRESS


 UNITD    EQU    RPB+1       TRANSIENT UNIT DESCRIPTOR
 UITB     EQU    UNITD+P.UD  TRANSIENT UIT BUFFER
          TITLE  EQUATES
* CONDITIONAL ASSEMBLY EQUATES
 FH       EQU    0           1= KEEP FUNCTION HISTORY TABLE

 KH       EQU    0           1= KEEP HISTORY OF IPI COMMAND/RESPONSE PACKETS
 KHC      EQU    0           1= KEEP HISTORY OF IPI COMMAND PACKETS ONLY
 KHR      EQU    0           1= KEEP HISTORY OF IPI RESPONSE PACKETS ONLY

 VALID    EQU    0           1= VALIDATE CPU TABLES AND BUFFERS

* RESPONSE CODES (AA).
 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    40000B      INTERMEDIATE RESPONSE
 R.NRM    EQU    100000B     NORMAL REQUEST TERMINATION
 R.ABN    EQU    140000B     ABNORMAL REQUEST TERMINATION

* RESPONSE CODES (BB).
 R.RCV    EQU    10000B      RECOVERED ERROR CAUSED RESPONSE
 R.FLG    EQU    20000B      FLAG FIELD CAUSED RESPONSE
 R.RPF    EQU    R.RCV+R.FLG  BOTH CONDITIONS OCCURED

* UNSOLICITED RESPONSE CODES
 URC.RN   EQU    1           CHANGE FROM READY TO NOT READY
 URC.NR   EQU    2           CHANGE FROM NOT READY TO READY
 URC.IE   EQU    3           INTERNAL OR INTERFACE ERROR
 URC.CR   EQU    4           SLAVE RESERVED TO ANOTHER ACCESS
 URC.UR   EQU    5           FACILITY RESERVED TO ANOTHER ACCESS
 URC.RA   EQU    6           RECOVERED ABNORMAL CONDITION
 URC.DS   EQU    7           DEADSTART COMPLETED
 URC.IN   EQU    8           INITIALIZATION ERROR

* COMMAND EQUATES
 PSNI     EQU    2400B       PSN INSTRUCTION
 INPNI    EQU    102600B     INPN INSTRUCTION

 INDFLG   EQU    100B        INDIRECT ADDRESSING FLAG
 STRSP    EQU    200B        STORE RESPONSE FLAG

 IDLCMD   EQU    4           PP IDLE COMMAND
 RSUMCMD  EQU    5           PP RESUME COMMAND
 FUNCCMD  EQU    0#20        PHYSICAL COMMAND - FUNCTION (20 HEX)
 PWRTCMD  EQU    0#23        PHYSICAL COMMAND - OUTPUT 8-BIT DATA (23 HEX)
 LCREAD   EQU    0#41        LOCICAL READ RECORD OF 8-BIT DATA (41 HEX)
 LCWRITE  EQU    0#51        LOGICAL WRITE RECORD COMMAND (51 HEX)
 LCSTC    EQU    0#61        LOGICAL COMMAND STORE TRANSFER COUNT (61 HEX)

*         ATS PHYSICAL FUNCTION CODES
 F.FU     EQU    04B         FORMAT UNIT
 F.REW    EQU    10B         REWIND/UNLOAD UNIT
 F.SB     EQU    13B         FORESPACE/BACKSPACE BLOCK
 F.STM    EQU    15B         SEARCH TAPE MARK FWD/REV
 F.WTM    EQU    51B         WRITE TAPE MARK
 F.ERS    EQU    52B         ERASE TAPE
          EJECT
*
*         EQUATES FOR IPI ADAPTER
*
 H0000    EQU    0#0000      MASTER CLEAR ADAPTER
 H0004    EQU    0#0004      READ OPERAND GENERATOR
 H0009    EQU    0#0009      SET SELECT OUT
 H0014    EQU    0#0014      WRITE OPERAND GENERATOR
 H0X15    EQU    0#0015      REQUEST CLASS (X=PLUGGED) INTERRUPTS
 H0022    EQU    0#0022      CLEAR IPI ERROR
 H0029    EQU    0#0029      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H005B    EQU    0#005B      SET SYNC OUT
 H0071    EQU    0#0071      FULL WHEN SLAVE IN IS 0
 H00E1    EQU    0#00E1      READ STATUS REGISTER
 H00F1    EQU    0#00F1      READ ERROR REGISTER
 H0062    EQU    0#0062      PORT A SELECT (20 MHZ INT CLK)
 H0100    EQU    0#0100      CLEAR ERROR
 H0122    EQU    0#0122      IPI BUS A OUTPUT PARITY ERROR
 H0162    EQU    0#0162      PORT A SELECT (12 MHZ EXT CLK)
 H0200    EQU    0#0200      READ CONTROL REGISTER/READ ATTRIBUTES
 H0281    EQU    0#0281      STREAM, READ
 H0300    EQU    0#0300      WRITE CONTROL REGISTER
 H0322    EQU    0#0322      IPI BUS A INPUT PARITY ERROR
 H0381    EQU    0#0381      STREAM, WRITE
 H0600    EQU    0#0600      READ DMA ERROR REGISTER
 H0700    EQU    0#0700      READ OPERATIONAL STATUS
 H0711    EQU    0#0711      DROP MASTER OUT
 H0715    EQU    0#0715      REQUEST CLASS 1, 2, OR 3 INTERRUPT
 H0800    EQU    0#0800      DMA TERMINATE/ABORT COMMAND
 H0862    EQU    0#0862      PORT B SELECT (20 MHZ INT CLK)
 H0962    EQU    0#0962      PORT B SELECT (12 MHZ EXT CLK)
 H0A00    EQU    0#0A00      READ T REGISTER
 H0B00    EQU    0#0B00      WRITE T PRIME REGISTER
 H0C00    EQU    0#0C00      DMA READ
 H0C22    EQU    0#0C22      ICI OUTPUT PARITY ERROR
 H0D00    EQU    0#0D00      DMA WRITE
 H0E00    EQU    0#0E00      CLEAR T-REGISTERS
 H7C42    EQU    0#7C42      IPI CHANNEL TRANSFER RATE (5.00 MB)
 H8025    EQU    0#8025      MASTER OUT, FULL WHEN SLAVE IN IS 1
 H8039    EQU    0#8039      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H8115    EQU    0#8115      SET MASTER OUT, PHYSICAL INTERFACE RESET
 H8215    EQU    0#8215      SET MASTER OUT, LOGICAL INTERFACE RESET
 H8415    EQU    0#8415      SET MASTER OUT, SLAVE RESET
 H9211    EQU    0#9211      DROP SYNC OUT
 H9213    EQU    0#9213      SET SYNC OUT
 HFE42    EQU    0#FE42      IPI CHANNEL TRANSFER RATE (6.00 MB)
          SPACE  2
*
* BUS CONTROL EQUATES
*
 CMDOUT   EQU    0           COMMAND, INFORMATION OUT
 RSPIN    EQU    1           RESPONSE, INFORMATION IN
 DATAOUT  EQU    2           DATA OUT
 DATAIN   EQU    3           DATA IN
          SPACE  2
*
* ENDING STATUS EQUATES
*
 EVENOT   EQU    0#0         EVEN OCTET TRANSFER
 ODDOT    EQU    0#F         ODD OCTET TRANSFER
          EJECT
*
* IPI COMMAND EQUATES
*
 OCNOP    EQU    0#0000      NOP
 OCATT    EQU    0#0200      ATTRIBUTES
 OCRAS    EQU    0#0300      REPORT ADDRESSEE STATUS
 OCPA     EQU    0#0400      PORT ADDRESS
 OCPC     EQU    0#0500      PATH CONTROL
 OCAC     EQU    0#0600      ATTENTION CONTROL
 OCOM     EQU    0#0700      OPERATING MODE
 OCABT    EQU    0#0800      ABORT
 OCREAD   EQU    0#1000      READ
 OCWRITE  EQU    0#2000      WRITE
 OCSPACE  EQU    0#4000      SPACE BLOCK/FILE
 OCPOSC   EQU    0#4100      POSITION CONTROL
 OCREPP   EQU    0#4200      REPORT POSITION
 OCRECP   EQU    0#4300      RECORD POSITION
 OCREADV  EQU    0#5000      READ VERIFY
 OCRFB    EQU    0#5200      READ FROM BUFFER
 OCRFDTB  EQU    0#5300      READ FACILITY DATA TO BUFFER
 OCWTB    EQU    0#6200      WRITE TO BUFFER
 OCWBTF   EQU    0#6300      WRITE BUFFER TO FACILITY
 OCIML    EQU    0#6600      LOAD SLAVE IML
 OCERASE  EQU    0#6700      ERASE
 OCPSD    EQU    0#8000      PERFORM SLAVE DIAGNOSTICS
 OCPFD    EQU    0#8100      PERFORM FACILITY DIAGNOSTICS
 OCREL    EQU    0#8400      READ ERROR LOG
          SPACE  4
*
* IPI COMMON MODIFIER EQUATES
*
 CMPRI    EQU    0#40        PRIORITY
 CMCHN    EQU    0#10        CHAIN
          SPACE  4
*
* IPI OPCODE MODIFIER EQUATES
*
 OMRF     EQU    0#2         READ FORWARD
 OMRR     EQU    0#A         READ REVERSE
 OMRVF    EQU    0#0         READ VERIFY FORWARD
 OMRVR    EQU    0#8         READ VERIFY REVERSE
 OMSFF    EQU    0#1         SEARCH FILE FORWARD
 OMSFR    EQU    0#9         SEARCH FILE REVERSE
 OMDSE    EQU    0#0         ERASE - DSE
 OMGAP    EQU    0#6         ERASE - GAP
 OMOMS    EQU    0#4         OPERATION MODE - SET
 OMAL     EQU    0#9         ATTRIBUTE - LOAD
 OMRELC   EQU    0#0         READ ERROR LOG - CLEAR
 OMRASC   EQU    0#1         REPORT ADDRESSEE STATUS - CONDITION
          EJECT
*
* IPI COMMON PARAMETER EQUATES
*
 CPTP     EQU    0#0251      TAPE POSITION PARAM
 CPTM     EQU    0#0251      TAPE MARK PARAM
 CPSRB    EQU    0#026E      SLAVE RECONFIGURATION BIT PARAM
 CPSRF    EQU    0#176F      SLAVE RECONFIGURATION FIELD PARAM
 CPNOP    EQU    0#0301      NOP PARAM
 CPBA     EQU    0#0350      BUFFER ADDRESS PARAM
 CPPM     EQU    0#0450      PORT MASK PARAM
 CPCE     EQU    0#0531      COMMAND EXTENT PARAM
 CPSCE    EQU    0#05D2      MAXIMUM BLOCK LENGTH (READ) PARAM
 CPTMB    EQU    0#0552      TAPE MODE BIT PARAM
 CPBCE    EQU    0#0931      BUFFER COMMAND EXTENT PARAM
 CPTMF    EQU    0#0953      TAPE MODE FIELD PARAM
 CPBID    EQU    0#02D0      ENABLE/DISABLE BID PARAM
          SPACE  4
*
* IPI ID EQUATES
*
 ID13     EQU    0#13        MICROCODE EXCEPTION FOR SLAVE
 ID14     EQU    0#14        INTERVENTION REQUIRED FOR SLAVE
 ID15     EQU    0#15        ALTERNATE PORT EXCEPTION
 ID16     EQU    0#16        MACHINE EXCEPTION FOR SLAVE
 ID17     EQU    0#17        COMMAND EXCEPTION FOR SLAVE
 ID18     EQU    0#18        COMMAND ABORTED FOR SLAVE
 ID19     EQU    0#19        SLAVE CONDITIONAL SUCCESS
 ID24     EQU    0#24        INTERVENTION REQUIRED FOR FACILITY
 ID26     EQU    0#26        MACHINE EXCEPTION FOR FACILITY
 ID29     EQU    0#29        FACILITY CONDITIONAL SUCCESS
 ID2A     EQU    0#2A        INCOMPLETE STATUS FOR FACILITY
 ID32     EQU    0#32        RESPONSE EXTENT PARAMETER
 ID51     EQU    0#51        CONDITION PARAMETER
 ID52     EQU    0#52        MEDIA STATUS PARAMETER
 IDD0     EQU    0#D0        BLOCK ID PARAMETER
 IDD2     EQU    0#D2        MAXIMUM BLOCK LENGTH PARAMETER
          EJECT
*
* IPI COMMAND/RESPONSE PACKET EQUATES
*
 CRN      EQU    1           COMMAND REFERENCE NUMBER
 OPCD     EQU    2           OPERATION CODE FOR SLAVE
 SLAD     EQU    3           SLAVE ADDRESS, FACILITY ADDRESS
 MAJST    EQU    4           MAJOR STATUS
          SPACE  4
*
* IPI MAJOR STATUS EQUATES
*         RESPONSE TYPES
 CC       EQU    1           COMMAND COMPLETE RESPONSE
 AR       EQU    4           ASYNCHRONOUS RESPONSE
 TN       EQU    5           TRANSFER NOTIFICATION
 CCS      EQU    0#18        COMMAND COMPLETE, SUCCESSFUL
          SPACE  4
*
* IPI LEFT SHIFTS FOR MAJOR STATUS
*
 LSCE     EQU    2           COMMAND EXCEPTION
 LSME     EQU    3           MACHINE EXCEPTION
 LSAPE    EQU    4           ALTERNATE PORT EXCEPTION
 LSIR     EQU    5           INTERVENTION REQUIRED
 LSMME    EQU    6           MESSAGE/MICROCODE EXCEPTION
 LSS      EQU    14          SUCCESSFUL
 LSI      EQU    15          INCOMPLETE
 LSCS     EQU    16          CONDITIONAL SUCCESS
 LSCA     EQU    17          COMMAND ABORTED
          SPACE  4
*
* IPI MISCELLANEOUS EQUATES
*
 BURST    EQU    8192        IPI BURST SIZE (MUST BE MULTIPLE OF 8)
          SPACE  4
*
*         MISCELLANEOUS EQUATES
*
 DC       EQU    37B         DEVICE CHANNEL NUMBER
 T698.1   EQU    21B         5698 UIT UNIT TYPE FOR 698-3X TAPE FACILITY
 MALETVE  EQU    1           MALVET/VE CHANNEL REQUEST VALUE IN WORD (T2)
 MS25     EQU    26738*2     25 MILLISECOND TIMEOUT FOR CERTAIN LOOPS
 SRT      EQU    45          SLAVE RESET TIMEOUT (SECONDS)
 BYPSD    EQU    400000B     BYPASS SELECT/DESELECT IN ROUTINE CPT
          EJECT
*
* IOU/SLAVE/FACILITY ERROR CODES    *** DEC ***
*
 E00      EQU    0           CP MUST DECODE STATUS IN RESPONSE PACKET
 E01      EQU    1           FUNCTION TIMEOUT
 E02      EQU    2           CHANNEL EMPTY WHEN ACTIVATED
 E03      EQU    3           PERIOD COUNTER PARITY
 E04      EQU    4           UPPER ICI PARITY
 E05      EQU    5           LOWER ICI PARITY
 E06      EQU    6           IOU ERROR
 E07      EQU    7           INCOMPLETE I4 TRANSFER
 E08      EQU    8           CHANNEL NOT EMPTY
 E09      EQU    9           CENTRAL MEMORY ERROR
 E10      EQU    10          INVALID CM RESPONSE CODE
 E11      EQU    11          CM RESPONSE CODE PARITY ERROR
 E12      EQU    12          CMI READ DATA PARITY ERROR
 E13      EQU    13          JY DATA ERROR
 E14      EQU    14          BAS PARITY ERROR
 E15      EQU    15          LZ ERROR
 E16      EQU    16          JY ERROR
 E17      EQU    17          LX ERROR
 E18      EQU    18          DMA TEST MODE FAILURE
 E19      EQU    19          ILLEGAL OPERATION
 E20      EQU    20          CANT SELECT SLAVE
 E21      EQU    21          BIT SIGNIFICANT RESPONSE ERROR
 E22      EQU    22          NO SYNC IN
 E23      EQU    23          SYNC IN DID NOT DROP
 E24      EQU    24          IPI SEQUENCE ERROR
 E25      EQU    25          UPPER IPI CHANNEL PARITY
 E26      EQU    26          LOWER IPI CHANNEL PARITY
 E27      EQU    27          SLAVE IN NOT SET
 E28      EQU    28          SLAVE IN DID NOT DROP
 E29      EQU    29          INCOMPLETE TRANSFER
 E30      EQU    30          CHANNEL STAYED ACTIVE
 E31      EQU    31          BUFFER COUNTER PARITY
 E32      EQU    32          SYNC COUNTER PARITY
 E33      EQU    33          LOST DATA
 E34      EQU    34          BUS PARITY
 E35      EQU    35          COMMAND REJECT
 E36      EQU    36          SYNC OUT NOT EQUAL SYNC INS
 E37      EQU    37          BUS B ACKNOWLEDGE INCORRECT
 E38      EQU    38          NO SLAVE INTERRUPT
 E39      EQU    39          ENDING STATUS WRONG
 E40      EQU    40          SLAVE ENCODED ENDING STATUS WRONG
 E50      EQU    50          EXECUTING SLAVE DIAGNOSTICS
 E51      EQU    51          SLAVE DIAGNOSTICS PASSED
 E60      EQU    60          SLAVE FAILURE
 E61      EQU    61          FACILITY FAILURE
 E70      EQU    70          INTERNAL SLAVE ERROR
 E71      EQU    71          SLAVE INTERVENTION REQUIRED
 E72      EQU    72          SLAVE MACHINE EXCEPTION
 E73      EQU    73          COMMAND EXCEPTION
 E74      EQU    74          MICROCODE EXECUTION ERROR
 E75      EQU    75          ALTERNATE PORT EXCEPTION
 E76      EQU    76          UNEXPECTED RESPONSE
 E77      EQU    77          FACILITY RESERVED TO OTHER SLAVE
 E78      EQU    78          NO BLOCK ID PARAMETER RETURNED
 E79      EQU    79          UNEXPECTED CLASS 2 INTERRUPT
 E90      EQU    90          NO END OF EXTENT (TAPE MARK) DETECTED
 E110     EQU    110         PP-SLAVE DATA INTEGRITY
 E111     EQU    111         SLAVE-FACILITY DATA INTERGRITY
 E120     EQU    120         SOFTWARE FAILURE
          EJECT
*
* INTERFACE ERROR CODES.     *** HEX ***
*
 E201     EQU    1001B       RMA OF CHANNEL RESERVATION TABLE NOT
                              A WORD BOUNDARY
 E202     EQU    1002B       RMA OF UNIT ACTIVITY MASK NOT A
                              WORD BOUNDARY
 E203     EQU    1003B       RMA OF PP COMMUNICATION BUFFER NOT A
                              WORD BOUNDARY
 E204     EQU    1004B       RESERVED FIELD OF THE PP COMMUNICATION
                             BUFFER DESCRIPTOR IS NOT ZERO
 E205     EQU    1005B       RESERVED FIELD OF THE PP REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 E206     EQU    1006B       RMA OF NEXT PP NOT A WORD BOUNDARY
 E207     EQU    1007B       RESERVED FIELD OF THE PP RESPONSE
                             BUFFER DESCRIPTOR IS NOT ZERO
 E208     EQU    1010B       LOGICAL UNIT OF UNIT DESCRIPTOR NOT
                             IN SEQUENCE OR NOT IN RANGE
 E209     EQU    1011B       RMA OF UNIT INTERFACE TABLE NOT A
                             WORD BOUNDARY
 E20A     EQU    1012B       INVALID CHANNEL NUMBER SPECIFIED
                             IN UNIT DESCRIPTOR
 E20B     EQU    1013B       COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS OR NOT LONG ENOUGH
 E20D     EQU    1015B       RESERVED FIELD OF IN POINTER
                             IS NOT ZERO
 E20E     EQU    1016B       RESERVED FIELD OF OUT POINTER
                             IS NOT ZERO
 E20F     EQU    1017B       RESERVED FIELD OF LIMIT POINTER
                             IS NOT ZERO
 E210     EQU    1020B       INVALID PHYSICAL UNIT NUMBER
 E211     EQU    1021B       RMA OF INTERRUPT WORD NOT A WORD
                             BOUNDARY
 E212     EQU    1022B       RMA OF CHANNEL TABLE NOT A WORD
                             BOUNDARY
 E213     EQU    1023B       NO ACTIVE (NON NULL) UNIT DESCRIPTORS DEFINED
 E301     EQU    1401B       LOGICAL UNIT NUMBER NOT EQUAL TO LOGICAL
                             UNIT OF UNIT DESCRIPTOR
 E302     EQU    1402B       RMA OF UNIT COMMUNICATION BUFFER
                             NOT A WORD BOUNDARY
 E303     EQU    1403B       A RESERVED FIELD OF THE UNIT COMMUNICATION BUFFER
                             DESCRIPTOR IS NOT ZERO
 E304     EQU    1404B       RMA OF NEXT UNIT REQUEST
                             NOT A WORD BOUNDARY
 E305     EQU    1405B       RESERVED FIELD OF UNIT REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 E306     EQU    1406B       INVALID UNIT TYPE
 E307     EQU    1407B       UNIT COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF CM WORDS
 E308     EQU    1410B       UNIT COMMUNICATION BUFFER IS TOO SMALL
 E501     EQU    2401B       INVALID COMMAND CODE
 E505     EQU    2405B       INVALID LENGTH SPECIFICATION IN COMMAND
 E50A     EQU    2412B       INVALID SEQUENCE OF COMMANDS
          TITLE  DIRECT CELLS
 T0       CON    START-1     START OF DRIVER-1
 T1       BSSZ   1           SCRATCH CELLS
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1
 P1       BSSZ   1
 P2       BSSZ   1
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 P6       BSSZ   1
          SPACE  2
 CLCUR    BSSZ   1           CURRENT CHANNEL 14 CLOCK VALUE
 CLMCS    BSSZ   1           CLOCK, MICROSECOND
 CLMLS    BSSZ   1           CLOCK, MILLISECOND
 CLSEC    BSSZ   1           CLOCK, SECOND
 CPTBP    BSSZ   1           CPT BYPASS PARAMETER
 CTM      BSSZ   1           IPI CHANGE TRANSFER MODE FLAG
 CURCH    BSSZ   1           CURRENT CHANNEL NUMBER
 FI       BSSZ   1           FUNCTION HISTORY BUFFER INDEX
 HBP      BSSZ   1           HISTORY BUFFER POINTER
 LF       BSSZ   1           LAST FUNCTION TO IPI ADAPTER
 LIM      BSSZ   1           LIMIT OF CM RESPONSE BUFFER
 MALREQF  BSSZ   1           MALET CHANNEL REQUEST FLAG
 TIU      BSSZ   1           TS TABLES IN USE BY BIT ADDRESS
 TSLVS    BSSZ   1           TOTAL NUMBER OF SLAVES CONFIGURED
 WC       BSSZ   1           WORD COUNTER
          SPACE  4
*         THE FOLLOWING DIRECT CELLS ARE SAVED/LOADED WITH THE TS TABLE
 SAVEFWA  EQU    *
 ASYNCP   BSSZ   1           ASYNCHRONUS PROCESSING FLAG
 CTST     BSSZ   1           CURRENT TS TABLE INDEX
 FACN     BSSZ   1           CURRENT FACILITY NUMBER
 OS       BSSZ   1           OPERATIONAL STATUS
 SLVN     BSSZ   1           CURRENT SLAVE NUMBER
*                            0X = PORT A  SLAVE X
*                            1X = PORT B  SLAVE X
 STATUS   BSSZ   1           IPI CHANNEL STATUS
 SX       BSSZ   1           SLAVES TABLE INDEX
 UX       BSSZ   1           UNITS TABLE INDEX
 SAVELWA  EQU    *-1
          ERRPL  SAVELWA-SAVEFWA-MAXSDC  INSURE TS SAVE AREA IS ENOUGH
*         THIS IS THE END OF THE SAVED TS TABLE DIRECT CELLS
          EJECT
 CMADR    BSSZ   3           CM ADDRESS
 AT1      BSSZ   1           ALTERNATE T1 DIRECT CELL
 CM.PIT   BSSZ   3           CM ADDRESS OF PP INTERFACE TABLE (REFORMATTED)

* BC, RMA ARE T REGISTER PARAMETERS
 BC       BSSZ   1           BYTE COUNT TO READ/WRITE
 RMA      BSSZ   2           RMA FOR DMA TRANSFER

* NOTE   DIRECT CELLS T1 THRU DCCEND WILL BE CLEARED ON DEADSTART/RESUMES
 DCCEND   EQU    *-1
          BSSZ   4           UNUSED
          SPACE  2
 BURSTSZ  CON    BURST       IPI BURST SIZE
 INITFLG  DATA   1           INITIALIZATION FLAG 1=DS, 2=RESUME, 3=MALET
 PPREQF   DATA   0           PP REQUEST FLAG
 ONE      CON    1           CONSTANT ONE (DO NOT CHANGE THIS CELL)
 TWO      CON    2           CONSTANT TWO (DO NOT CHANGE THIS CELL)
 FF       CON    0#FF        CONSTANT HEX FF (DO NOT CHANGE THIS CELL)
 DSRTP    DATA   2,0         REAL MEMORY WORD-ADDRESS OF PIT (PLUGGED)

          ERRNZ  DSRTP-72B   MUST BE AT LOCATION 72

 IDLFLG   DATA   0           PP IDLE FLAG, IF NONZERO ONLY PP REQUESTS ARE DONE.
 CLF      DATA   1           CHANNEL LOCK FLAG  ** 0 = LOCKED **
 PPNO     DATA   5           LOGICAL PP NUMBER
          BSSZ   1           UNUSED

 ID       DATA   H*TAPD*     IDENTIFICATION
          ERRNZ  ID-100B     MUST BE AT LOCATION 100B
          SPACE  2
*
*         ENTRY POINT
*
          SPACE  2
 START    LJM    INIT        ENTRY POINT OF DRIVER

          ERRNZ  START-102B  MUST BE AT LOCATION 102B
          SPACE  2
* THE FOLLOWING CM.XXX ARE REFORMATTED CM ADDRESSES
*         THE BYTE ADDRESS IS
*          RIGHTMOST 10 BITS OF WORD 0 CONCATENATED WITH
*          RIGHTMOST 12 BITS OF WORD 1 CONCATENATED WITH
*          RIGHTMOST 6 BITS OF WORD 2 CONCATENATED WITH
*          3 BITS OF ZEROS

 CM.INT   BSSZ   3           CM ADDRESS OF INTERRUPT TABLE
 CM.CHAN  BSSZ   3           CM ADDRESS OF CHANNEL TABLE
 CM.COM   BSSZ   3           CM ADDRESS OF PP COMMUNICATION BUFFER
 CM.RS    BSSZ   3           CM ADDRESS OF RESPONSE BUFFER

* THE FOLLOWING CM ADDRESS IS REFORMATTED FOR DMA T REGISTER
 CM.CB.T  BSSZ   3           CM ADDRESS OF COM. BUFFER TEST MODE AREA
          TITLE  PP MONITOR

          SPACE  4
*
* PP MONITOR
*
          SPACE  2
 MAIN     BSS
          RJM    CKIT        CHECK FOR INITIALIZATION REQUIRED

          RJM    CKPPRQ      CHECK FOR ANY PP REQUESTS
          ZJN    MAIN10      IF NONE
          RJM    DOPPRQ      PROCESS PP REQUEST

 MAIN10   BSS
          LDDL   IDLFLG      CHECK IF PP IS IDLED
          NJN    MAIN        IF YES

 MAIN20   BSS
          RJM    CKCREQ      CHECK FOR MALET REQUESTING THE CHANNEL
          ZJN    MAIN30      IF NOT
          RJM    DOCREQ      PROCESS MALET CHANNEL REQUEST

 MAIN30   BSS
          RJM    CKUR        CHECK FOR UNIT REQUESTS
          ZJN    MAIN40      IF NONE
          LJM    DOUR        PROCESS UNIT REQUEST

 MAIN40   BSS
          RJM    CKINT       CHECK/PROCESS SLAVE ASYNCHRONUS INTERRUPTS

          LJM    MAIN        RELOOP
          TITLE  MONITOR SUBROUTINES
** NAME-- CKIT
*
** PURPOSE-- CHECK IF INITIALIZATION TESTING REQUIRED
*
** EXIT-- IMEDIATELY IF TESTING ALREADY COMPLETED.
*         AFTER TESTING ALL SLAVES WITH AT LEAST ONE
*         CONFIGURED NON-DISABLED FACILITY.
          SPACE  4
 CKIT     SUBR   ENTRY/EXIT
          LDDL   INITFLG     CHECK IF TESTING IS COMPLETE
          ZJN    CKITX       IF YES EXIT
          LDDL   IDLFLG      CHECK IF PP IS IDLE
          NJK    CKIT110     IF YES BYPASS TESTING
          LDDL   CTST        CHECK IF FIRST PASS THRU
          LMML   TS1
          NJN    CKIT10      IF NOT
          STDL   SLVN        START WITH PORT A  SLAVE 0
          RJM    SCLOCK      GET CHANNEL LOCKED
          LDML   TS2         USE FIRST SLAVE TS TABLE
          STDL   CTST
          RJM    MR          MASTER RESET
          UJN    CKIT20      CONT.
 CKIT10   BSS
          AODL   SLVN        INCREMENT SLAVE NUMBER
          SBN    MAXSL       CHECK FOR DONE
          PJK    CKIT100     IF YES
 CKIT20   BSS
          RJM    SETSX       SETUP SLAVE TABLE INDEX
          ZJN    CKIT10      IF NO CONFIGURED FACILITIES
          LDN    3           SET SLAVE TESTING/ATTRIBUTES REQUIRED FLAG
          STML   SLB+/SL/P.SLVTST,SX
          LDN    0
          STDL   FACN        START WITH FACILITY NUMBER 0
          UJN    CKIT40      CONT.
 CKIT30   BSS
          AODL   FACN        INCREMENT FACILITY NUMBER
          SBN    FACPSL      CHECK FOR LIMIT
          PJN    CKIT10      IF YES
 CKIT40   BSS
          RJM    SETUX       SETUP UNITS TABLE INDEX
          ZJN    CKIT30      IF UNIT NOT CONFIGURED
          LDML   UNITS+/UN/P.FD,UX
          SHN    /UN/L.FD+2  CHECK FOR DISABLED
          MJN    CKIT30      IF YES
          LOADR  UNITS+/UN/P.UIT,UX  ADDRESS OF UIT
          CRDL   T1          GET UIT DISABLE BIT
          LDDL   T1+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJN    CKIT30      IF DISABLED
          LDML   TS2         USE FIRST SLAVE TS TABLE
          STDL   CTST
          RJM    INTS        INITIALIZE TS TABLE
          LDML   UNITS+/UN/P.LU,UX  GET LOGICIAL UNIT NUMBER
          STML   /TS/P.RQB+/RQ/P.LU,CTST  PUT INTO TS TABLE
          RJM    PS          PORT SELECT
          RJM    TICP        TEST IPI CHANNEL PATH
          LDDL   INITFLG     CHECK IF DEADSTART INITIALIZATION
          SBN    1
          NJN    CKIT50      IF NOT
 CKIT45   BSS
          LDN    2           SET RETRY LEVEL
          STML   /TS/P.RETRY,CTST
          RJM    ISR         ISSUE SLAVE RESET
          UJN    CKIT60      CONT.
 CKIT50   BSS
          LDML   SRTAB,SLVN  CHECK IF SLAVE RESET EVER EXECUTED
          ZJN    CKIT45      IF NOT
          LDN    1           SET RETRY LEVEL
          STML   /TS/P.RETRY,CTST
          RJM    LIR         LOGICIAL INTERFACE RESET
 CKIT60   BSS
          LDN    0           SET RETRY LEVEL
          STML   /TS/P.RETRY,CTST
          LDN    1           ENABLE ERROR CORRECTION
          STML   /TS/P.ECSEL,CTST
          RJM    ATTRIB      SET ALL SLAVE ATTRIBUTES
          RJM    PTW         PATH TEST WRITE
          RJM    PTR         PATH TEST READ
          LDN    0           CLR SLAVE TESTING REQUIRED FLAG
          STML   SLB+/SL/P.SLVTST,SX
          UJK    CKIT10      GO DO NEXT SLAVE

*         INITIALIZATION TESTING COMPLETE
 CKIT100  BSS
          LDN    0           CLEAR SLAVE TS TABLE
          STDL   SLVN
          STDL   FACN
          RJM    CLRTS       CLEAR TS2 SLAVE TABLE
 CKIT110  BSS
          LDML   TS1         RESET TO TS1 IF PP RESUME
          STDL   CTST
          LDDL   INITFLG     DETERMINE WHAT CAUSED PP INITIALIZATION
          SBN    3
          ZJN    CKIT120     IF MALET
          RJM    CLRTS       CLEAR TS1 PP TABLE
          LDN    0
          STDL   TIU         CLEAR TS TABLES IN USE FLAG
          STDL   PPREQF      CLEAR IF FROM RESUME
          STML   RPB         CLEAR IPI RESPONSE LENGTH
          STDL   SX          CLEAR SLAVE INDEX
          STDL   UX          CLEAR UNIT INDEX
          UJN    CKIT130     CONT.
 CKIT120  BSS
          LDDL   IDLFLG      MALET PROCESSING
          NJN    CKIT140     IF PP IS IDLE (TESTING DONE BY RESUME)
 CKIT130  BSS
          LDN    0
          STDL   INITFLG     CLR INITIALIZATION FLAG
 CKIT140  BSS
          UJK    CKITX       EXIT
          EJECT
** NAME-- CKPPRQ
*
** PURPOSE-- CHECK IF THERE ARE ANY PP REQUESTS QUEUED.
*
** EXIT-- A = NZ IF NEW OR PENDING REQUEST ACTIVE (PPREQF = NZ).
*         A = 0  IF NO REQUEST ACTIVE (PPREQF = 0).
          SPACE  2
 CKPPRQ2  RJM    CPLOCK      UNLOCK PP REQUEST QUEUE IN PIT
 CKPPRQ4  LDN    0           NO NEW REQUESTS


 CKPPRQ   SUBR               ENTRY/EXIT


          LDDL   PPREQF      CHECK IF PENDING REQUEST
          NJN    CKPPRQX     IF YES EXIT
          LOADC  CM.PIT      LOAD A AND R FOR PIT
          ADK    /PIT/C.PPQ
          CRML   T1,ONE      READ REQUEST RMA FROM PIT
          LDDL   T3          HALF 1 OF REQUEST RMA
          ADDL   T4          HALF 2 OF REQUEST RMA
          ZJN    CKPPRQX     IF NO REQUEST QUEUED
          RJM    SPLOCK      LOCK PP REQUEST QUEUE IN PIT
          NJK    CKPPRQ4     RETURN IF PP REQUEST QUEUE ALREADY LOCKED
          LOADC  CM.PIT      CM ADDRESS TO A AND R FOR READ
          ADK    /PIT/C.PPQPVA
          CRML   PITB+/PIT/P.PPQPVA-1,TWO  READ IN REQUEST PVA/RMA FROM PIT
          LDML   PITB+/PIT/P.PPQ  GET HALF 1 OF RMA OF 1ST REQUEST
          ADML   PITB+/PIT/P.PPQ+1
          ZJK    CKPPRQ2     IF RMA = 0 NO PP REQUEST QUEUED
          LDN    1           SET PP REQUEST FLAG
          STDL   PPREQF
          UJK    CKPPRQX     EXIT
          EJECT
** NAME-- DOPPRQ
*
** PURPOSE-- PROCESS THE WAITING PP REQUEST IF POSSIBLE.
*
** NOTE-- THE ONLY PP COMMANDS SUPPORTED ARE IDLE AND RESUME.
*         THERE CAN BE ONLY ONE COMMAND PER PP REQUEST.
          SPACE  2
 DOPPRQ   SUBR               ENTRY/EXIT
          LDDL   TIU         CHECK IF ANY SLAVE USING TS TABLES
          LPN    76B         MASK OUT PP TS TABLE
          NJN    DOPPRQX     IF YES EXIT
          STDL   PPREQF      CLEAR THE PP REQUEST FLAG
          STDL   SLVN        CLEAR SLAVE NUMBER
          STDL   FACN        CLEAR FACILITY NUMBER
          LDN    1           SET PP TS TABLE IN USE
          STDL   TIU
          LDML   TS1         USE TS TABLE 1 FOR THE PP REQUEST
          STDL   CTST
          LDK    CM.PIT      SETUP SOURCE OF REQUEST
          STDL   T7
          RJM    LDTS        LOAD THE TS TABLE AND UNLOCK QUEUE
          LDML   /TS/P.NUMCM,CTST  CHECK NUMBER OF COMMANDS
          SBN    1           PP CAN ONLY HAVE 1 ACTIVE COMMAND
          ZJN    DOPPRQ5     IF OK
          LDK    E50A        INVALID SEQUENCE OF COMMANDS
          RJM    SWFAIL      REPORT SOFTWARE FAILURE (NO RETURN)
 DOPPRQ5  BSS
          LDML   /TS/P.CQB,CTST  GET THE PP COMMAND
          SHN    -8          POSITION IT
          SBN    IDLCMD      CHECK FOR IDLE COMMAND
          ZJK    IDLE        IF YES
          SBN    RSUMCMD-IDLCMD  CHECK FOR RESUME COMMAND
          ZJK    RESUME      IF YES
          LDK    E501        INVALID COMMAND CODE
          RJM    SWFAIL      REPORT SOFTWARE FAILURE (NO RETURN)
          EJECT
** NAME-- CKCREQ
*
** PURPOSE-- CHECK IF CHANNEL IS REQUESTED BY MALET.
*
** EXIT-- A = NZ IF NEW OR PENDING REQUEST ACTIVE (MALREQF = NZ).
*         A = 0  IF NO REQUEST ACTIVE (MALREQF = 0).
          SPACE  2
 CKCREQ1  LDN    0           EXIT A = 0
          STDL   MALREQF     CLEAR MALET REQUEST FLAG

 CKCREQ   SUBR               ENTRY/EXIT


          LDDL   MALREQF     CHECK IF REQUEST ALREADY ACTIVE
          NJK    CKCREQX     IF YES, EXIT
          LDDL   CLF         CHECK IF CHANNEL IS CURRENTLY LOCKED
          NJN    CKCREQ1     IF NOT, EXIT
          LOADC  CM.CHAN     ADDRESS OF CM CHANNEL TABLE
          ADDL   CURCH       CHANNEL NUMBER IS INDEX INTO TABLE
          CRML   T1,ONE      READ CM CHANNEL ENTRY
          LDDL   T2          GET MAINTENANCE BYTES OF CHANNEL WORD
          LMK    MALETVE     CHECK IF REQUESTED
          NJK    CKCREQ1     IF CHANNEL IS NOT REQUESTED
          LDDL   T2          SET MALREQF
          STDL   MALREQF
          UJK    CKCREQX     EXIT A = NZ
          EJECT
** NAME-- DOCREQ
*
** PURPOSE-- PROCESS MALET CHANNEL REQUEST IF POSSIBLE
*
          SPACE  2
 DOCREQ   SUBR               ENTRY/EXIT
          LDDL   TIU         CHECK IF ANY SLAVE TABLES STILL IN USE
          LPN    76B         EXCEPT PP TS TABLE
          NJN    DOCREQX     IF YES EXIT
          DCN    DC+40B      INSURE CHANNEL IS INACTIVE
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          LDN    0
          STDL   MALREQF     CLEAR MALET REQUEST FLAG
          PAUSE  25000       GIVE MAINTENANCE PP THE CHANNEL
          LDDL   IDLFLG      CHECK IF PP IS IDLE
          NJN    DOCREQX     IF YES EXIT
*                            RESUME WILL CAUSE INITIALIZATION TESTING
          LDDL   INITFLG     CHECK IF TESTING ALREADY ESTABLISHED
          NJN    DOCREQ5     IF YES
          LDN    3           SET MALET REQUIRED INIT TESTING
          STDL   INITFLG
 DOCREQ5  BSS
          LDML   TS1         ENABLE TESTING
          STDL   CTST
          LJM    MAIN        GO DO TESTING
          EJECT
** NAME-- CKUR
*
** PURPOSE-- CHECK FOR ANY NEW OR CURRENT UNIT REQUESTS
*
** EXIT-- A = 0 IF NO REQUESTS ARE ACTIVE.
*         A = 1 IF CURRENT REQUEST ACTIVE.
*         A = 2 IF NEW LOCKABLE REQUEST IS ACTIVE.
          SPACE  2
 CKUR     SUBR               ENTRY/EXIT
          LDDL   TIU         GET TABLES IN USE
          LPN    76B         MASK WITH SLAVE TABLES USABLE
          ZJN    CKUR20      IF NONE ACTIVE

 CKUR10   RJM    SCANT       SCAN TABLES FOR NEXT ACTIVE ONE
          ZJN    CKUR10      IF NOT THIS ONE
          LDN    1           SET A=1, ACTIVE CURRENT REQUEST
          UJN    CKURX       EXIT

 CKUR20   LDDL   PPREQF      CHECK FOR ACTIVE PP REQUEST
          ADDL   MALREQF     ALSO MALET CHANNEL REQUEST
          ZJN    CKUR30      IF NOT
          LDN    0           SET A=0, DO NOT START ANY NEW REQUESTS
          UJN    CKURX       EXIT

 CKUR30   RJM    SNXTAB      SELECT NEXT SLAVE TS TABLE TO USE
          RJM    SCANAS      SCAN ALL SLAVES FOR A LOCKABLE REQUEST
          ZJN    CKURX       IF NONE ACTIVE, EXIT A=0

          LDN    2           SET A=2, NEW REQUEST TO PROCESS
          UJN    CKURX       EXIT
          EJECT
** NAME-- DOUR
*
** PURPOSE-- PROCESS CURRENT OR NEW UNIT REQUESTS
*
** ENTRY--A = 1 IF CURRENT REQUEST TO BE PROCESSED
*         A = 2 IF NEW REQUEST TO BE PROCESSED
          SPACE  2
 DOUR     BSS                ENTRY
          SBN    1           CHECK FOR CURRENT ACTIVE REQUEST
          NJN    DOUR20      IF NOT

          RJM    RELDTAB     RELOAD CURRENT REQUEST TS TABLE
          LDML   SLB+/SL/P.SIU,SX  GET PROCESSING ADDRESS
          STML   DOURA       STORE JUMP ADDRESS
          LJM    *           GO PROCESS REQUEST
 DOURA    EQU    *-1

 DOUR20   RJM    INITNR      INITIALIZE NEW REQUEST
 DOUR30   SOML   /TS/P.NUMCM,CTST  DECREMENT COMMANDS REMAINING
          LDN    0           DO NOT INCREMENT COMMAND OFFSET
          RJM    NEXTCMD     GET NEXT (FIRST) COMMAND
          EJECT
*         DECODE AND EXECUTE THE NEXT COMMAND
 CMDEXEC  LDN    0
          STML   RPB         CLEAR IPI RESPONSE PACKET LENGTH
          STML   /TS/P.SCOND,CTST  CLEAR LAST STATUS CONDITIONS

          LDML   /TS/P.CURCMD,CTST  GET COMMAND CODE
          SHN    -8          POSITION IT

*         CHECK FOR PHYSICAL FUNCTION COMMAND (20 HEX)
 CMDEX20  SBN    FUNCCMD
          NJN    CMDEX23     IF NOT
          LJM    PFUNC

*         CHECK FOR OUTPUT 8-BIT DATA COMMAND (23 HEX)
 CMDEX23  SBN    PWRTCMD-FUNCCMD
          NJN    CMDEX41     IF NOT
          LJM    OUT8D

*         CHECK FOR LOGICIAL READ COMMAND (41 HEX)
 CMDEX41  SBN    LCREAD-PWRTCMD
          NJN    CMDEX51     IF NOT
          LJM    READ

*         CHECK FOR LOGICIAL WRITE COMMAND (51 HEX)
 CMDEX51  SBN    LCWRITE-LCREAD
          NJN    CMDEX61     IF NOT
          LJM    WRITE

*         CHECK FOR STORE TRANSFER COUNT COMMAND (61 HEX)
 CMDEX61  SBN    LCSTC-LCWRITE
          NJN    CMDEX99     IF NOT
          LJM    STRTC

*         INVLAID COMMAND
 CMDEX99  LDK    E501        INVALID COMMAND CODE
          RJM    SWFAIL      REPORT SOFTWARE FAILURE (NO RETURN)
          EJECT
*         CURRENT COMMAND HAS COMPLETED
 CMDCOMP  BSS
          RJM    ERRCHK      CHECK FOR ERRORS
          NJK    FAIL        IF ERRORS

 NOSTAT   LDML   /TS/P.CURCMD,CTST  CHECK FOR STORE RESPONSE REQUESTED
          SHN    17-7
          PJN    NOSTR       IF NOT REQUESTED
          LDML   /TS/P.NUMCM,CTST  CHECK IF THIS IS LAST COMMAND
          ZJN    REQCOMP     IF YES
          RJM    PNR         PREPARE NORMAL RESPONSE
          LDC    R.FLG       SET FLAG CAUSED RESPONSE BIT
          RAML   RS+/RS/P.RC
          RJM    RESP        SEND RESPONSE

 NOSTR    LDML   /TS/P.NUMCM,CTST  CHECK IF MORE COMMANDS
          ZJN    REQCOMP     IF NONE LEFT
          SOML   /TS/P.NUMCM,CTST  DECREMENT COMMANDS LEFT
          LDN    8           INCREMENT COMMAND OFFSET TO GET NEXT COMMAND
          RJM    NEXTCMD     GET NEXT COMMAND
          UJK    CMDEXEC     GO EXECUTE NEXT COMMAND

*         REQUEST HAS BEEN COMPLETED
 REQCOMP  BSS
          RJM    GFS         GET FACILITY ID52 STATUS
          RJM    PNR         PREPARE NORMAL RESPONSE

 FAIL     LJM    IODONE      PROCESS END OF REQUEST
          EJECT
** NAME-- CKINT
*
** PURPOSE-- CHECK FOR ANY ASYNCHRONUS SLAVE INTERRUPTS
*            AND PROCESS THEM
          SPACE  2
 CKINT1   LDML   CKINTA      RESTORE ORIGINAL SLVN AND FACN
          STDL   SLVN
          LDML   CKINTB
          STDL   FACN
          RJM    CLRTS       CLEAR TS TABLE
          LDN    0           CLEAR ASYNCHRONUS PROCESSING FLAG
          STDL   ASYNCP
          LDDL   TIU         CLEAR TS TABLE IN USE
          LPN    73B
          STDL   TIU

 CKINT    SUBR               ENTRY/EXIT

          LDDL   TIU         CHECK IF ANY TS TABLES ARE IN USE
          NJN    CKINTX      IF YES EXIT
          LDN    4           SET TS3 TABLE IN USE
          STDL   TIU
          LDML   TS3         SET CURRENT TS TABLE TO TS3
          STDL   CTST
          STDL   ASYNCP      SET ASYNCHRONUS PROCESSING FLAG
          LDDL   SLVN        SAVE ORIGINAL SLVN AND FACN
          STML   CKINTA
          LDDL   FACN
          STML   CKINTB
          LDN    0           INITIALIZE RPB AND SLAVE NUMBER
          STML   RPB
          STDL   SLVN
          RJM    INTS        INITIALIZE CURRENT TS TABLE
          RJM    MCC         MASTER CLEAR CHANNEL
          UJN    CKINT20     CONT.

 CKINT10  AODL   SLVN        INCREMENT SLAVE NUMBER
          SBN    MAXSL       CHECK FOR DONE
          ZJK    CKINT1      IF YES

 CKINT20  RJM    SETSX       CHECK IF SLAVE IS CONFIGURED
          ZJN    CKINT10     IF NOT
          LDN    0           INITIALIZE FACILITY NUMBER
          STDL   FACN

 CKINT30  RJM    SETUX       CHECK IF FACILITY IS CONFIGURED
          NJN    CKINT40     IF YES
          AODL   FACN        INCREMENT FACILITY NUMBER
          UJN    CKINT30     TRY NEXT ONE

 CKINT40  RJM    PS          PORT SELECT

*         CHECK FOR CLASS 2 INTERRUPTS
          LDN    2           CLASS 2 INTERRUPTS
          RJM    RI          REQUEST INTERRUPTS
          ZJN    CKINT50     IF NONE

*         PROCESS CLASS 2 INTERRUPTS
          RJM    SARF        SET ATTRIBUTES REQUIRED FLAG
          LDN    0           NO IPI STATUS IN RESPONSE
          STML   RPB
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          LDK    E79         UNEXPECTED CLASS 2 INTERRUPT
          STML   RS+/RS/P.ERRID
          LDDL   STATUS      SHOW SLAVE ADDRESSES WITH CLASS 2 INTERRUPTS
          STML   RS+/RS/P.STREG
          RJM    RESP        SEND RESPONSE
          RJM    LIR         LOGICIAL INTERFACE RESET TO CLEAR INTERRUPTS
          UJK    CKINT10     LOOP

*         CHECK FOR CLASS 1 OR 3 INTERRUPTS
 CKINT50  LDN    5           CLASS 1 AND 3 INTERRUPTS
          RJM    RI          REQUEST INTERRUPTS
          ZJK    CKINT10     IF NONE

*         PROCESS CLASS 1 OR 3 INTERRUPTS
          RJM    DTM         DETERMINE TRANSFER MODE
          RJM    SEL         SELECT SLAVE
          STDL   CTM         CLEAR CHANGE TRANSFER MODE FLAG
          RJM    RPT         RESPONSE PACKET TRANSFER
          RJM    DCM         DESELECT SLAVE
          LDML   RPB+MAJST   CHECK FOR ASYNC RESPONSE
          SHN    -4
          LPN    0#F
          LMK    AR
          NJN    CKINT60     IF NOT ASYNC RESPONSE
          LDML   RPB+SLAD    CHECK IF FACILITY ASYNC
          LPDL   FF
          LMDL   FF
          NJN    CKINT50     IF YES CHECK FOR OTHER INTERRUPTS
          RJM    SARF        SET ATTRIBUTES REQUIRED FLAG
 CKINT60  RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    RESP        SEND RESPONSE
          UJK    CKINT50     CHECK FOR OTHER INTERRUPTS THIS SLAVE
          SPACE  2
 CKINTA   BSSZ   1           ORIGINAL SLVN
 CKINTB   BSSZ   1           ORIGINAL FACN
          TITLE  COMMAND ROUTINES
** NAME-- IDLE
*
** PURPOSE-- PROCESS PP IDLE COMMAND
*            (LOGICIAL COMMAND 04)
          SPACE  2
 IDLE     BSS                ENTRY
          RJM    CCLOCK      CLEAR THE CHANNEL LOCK
          LDN    76B
          STDL   IDLFLG      SET THE PP IDLE FLAG
          LDN    0           NO IPI STATUS IN RESPONSE
          STML   RPB
          RJM    PNR         PREPARE NORMAL RESPONSE
          LDK    /RS/K.PDN   PP IDLED
          STML   RS+/RS/P.DOWNST
          RJM    RESP        SEND THE RESPONSE
          RJM    CLREQ       CLEAR THE REQUEST
          LJM    MAIN        GO TO MAIN AND WAIT FOR RESUME COMMAND
          EJECT
** NAME-- RESUME
*
** PURPOSE-- PROCESS PP RESUME COMMAND
*            (LOGICIAL COMMAND 05)
*
** NOTE-- RESPONSE TO RESUME COMMAND WILL BE SENT AFTER INITIALIZATION
*         TESTING HAS COMPLETED.
          SPACE  2
 RESUME   BSS                ENTRY
          LDN    0
          STDL   IDLFLG      CLEAR THE PP IDLE FLAG
          LDN    2
          STDL   INITFLG     SET INITIALIZATION FLAG TO RESUME
          LJM    INIT        REINITIALIZE THIS DRIVER
          EJECT
** NAME - PFUNC
*
** PURPOSE - TO PERFORM THE PHYSICAL COMMAND FUNCTION.
*            (LOGICIAL COMMAND 20)
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PFUNC    BSS                ENTRY
          LDML   /TS/P.CURCMD+3,CTST  GET FUNCTION CODE TO PROCESS
          LPN    77B         MASK MAJOR FUNCTION CODE BITS
* DECODE ATS FUNCTION CODE
          SBN    F.FU
          NJN    PFUNC10
          LJM    PFORM       IF FORMAT UNIT
 PFUNC10  BSS
          SBN    F.REW-F.FU
          NJN    PFUNC20
          LJM    PREW        IF REWIND/UNLOAD
 PFUNC20  BSS
          SBN    F.SB-F.REW
          NJN    PFUNC30
          LJM    PSPB        IF SPACE BLOCK FWD/REV
 PFUNC30  BSS
          SBN    F.STM-F.SB
          NJN    PFUNC40
          LJM    PSTM        IF SEARCH TAPE MARK FWD/REV
 PFUNC40  BSS
          SBN    F.WTM-F.STM
          NJN    PFUNC50
          LJM    PWTM        IF WRITE TAPE MARK
 PFUNC50  BSS
          SBN    F.ERS-F.WTM
          NJN    PFUNC90
          LJM    PERS        IF ERASE TAPE

*         NON-SUPPORTED COMMAND
 PFUNC90  BSS
          LDK    E501        NON-SUPPORTED COMMAND
          RJM    SWFAIL      REPORT SOFTWARE FAILURE (NO RETURN)
          EJECT
** NAME - OUT8D
*
** PURPOSE - PROCESS THE OUTPUT 8-BIT DATA COMMAND.
*            (LOGICIAL COMMAND 23)
*
** NOTE - THE WRITE COMMAND PACKET HAS ALREADY BEEN SENT BY THE
*         WRITE (LOGICIAL 51) COMMAND. THE TRANSFER NOTIFICATION
*         HAS NOT BEEN RECEIVED YET.
          SPACE  2
 OUT8D    BSS                ENTRY

 O8D05    LDML   /TS/P.WSTNF,CTST  CHECK WSTN FLAG
          NJK    O8D440      IF SET, CONTINUE CURRENT RECORD
          SPACE  2
*         PROCESS IPI INTERRUPTS
 O8D10    LDN    10          SECONDS LIMIT  (INCLUDES ID RETRY)
          RJM    IH          INTERRUPT HANDLER
          SHN    -4          POSITION RESPONSE TYPE
          LPN    0#F         MASK IT
          SBN    1           CHECK FOR COMMAND COMPLETION
          ZJK    O8D600      IF YES
          SBN    4           CHECK FOR TRANSFER NOTIFICATION
          ZJN    O8D20       IF YES
          LDN    0           ELSE MUST BE ASYNCHRONUS RESPONSE
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    O8D05       LOOP
          SPACE  2
*         INITIALIZE DATA TRANSFER
 O8D20    LDML   /TS/P.WSTNF,CTST CHECK WSTN FLAG
          ZJN    O8D25       IF NOT SET, START NEW RECORD
          LDN    0           CLEAR WSTN FLAG
          STML   /TS/P.WSTNF,CTST
          UJN    O8D30       CONTINUE CURRENT RECORD

 O8D25    RJM    NSI         NON-STOP INITIALIZATION
          LDML   /TS/P.NSCRN,CTST  COMPARE COMMAND REFERENCE NUMBERS
          LMML   RPB+CRN
          ZJN    O8D30       IF OK
          LDK    E76         REPORT UNEXPECTED STATUS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE (NO RETURN)
          SPACE  2
*         START DATA TRANSFER
 O8D30    RJM    SEL         SELECT SLAVE

 O8D40    LDN    DATAOUT     BUS A DATA OUT
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0381       STREAM AND WRITE
          RJM    FUNC
          LDN    0           CLEAR CURRENT BURST BYTE COUNT
          STML   /TS/P.CBURBC,CTST

*         DETERMINE BURST CHARACTERISTICS
 O8D50    LDML   /TS/P.ILSTP+1,CTST  GET REQUESTED BYTE COUNT THIS PAIR
          STDL   T1          SAVE IT
          ADML   /TS/P.CBURBC,CTST  ADD CURRENT BURST BYTE COUNT
          SBDL   BURSTSZ     SUBTRACT SLAVE BURST SIZE
          ZJN    O8D200      IF TRANSFER IS TO BURST BOUNDARY
          PJK    O8D300      IF TRANSFER IS GREATER THAN BURST BOUNDARY

*         PROCESS TRANSFER OF LESS THAN BURST BOUNDARY
          LDN    0           CLEAR PARTIAL L/A PAIR FLAG
          STML   /TS/P.PARLAP,CTST
          LDDL   T1          GET REQUESTED BYTE COUNT THIS PAIR
          ADN    1           ROUND UP (IF LAST PAIR HAS ODD BYTE COUNT)
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNEL WORD COUNT
          LDDL   T1          INCREMENT CURRENT BURST BYTE COUNT
          RAML   /TS/P.CBURBC,CTST
          RJM    DDO         DMA DATA OUTPUT OPERATION
          RJM    WFTE        WAIT FOR T PRIME REGISTER EMPTY
          NJN    O8D400      IF PARTIAL RECORD
          RJM    GETNP       GET NEXT L/A PAIR
          ZJN    O8D400      IF NO MORE L/A PAIRS
          UJN    O8D50       CONTINUE TO OUTPUT

*         PROCESS TRANSFER TO BURST BOUNDARY
 O8D200   LDN    0           CLEAR PARTIAL L/A PAIR FLAG
          STML   /TS/P.PARLAP,CTST
          LDDL   T1          GET REQUESTED BYTE COUNT THIS PAIR
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNNEL WORD COUNT
          LDDL   BURSTSZ     INCREMENT CURRENT BURST BYTE COUNT
          STML   /TS/P.CBURBC,CTST
          RJM    DDO         DMA DATA OUTPUT OPERATION
          UJN    O8D400      PROCESS END OF BURST

*         PROCESS TRANSFER OF GREATER THAN BURST BOUNDARY
 O8D300   LDDL   BURSTSZ     COMPUTE BYTE COUNT TO BURST BOUNDARY
          SBML   /TS/P.CBURBC,CTST  DECREMENT BY BYTES TRANSFERED ALREADY
          STML   /TS/P.PARLAP,CTST  SET PARTIAL L/A PAIR FLAG
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNEL WORD COUNT
          LDDL   BURSTSZ
          STML   /TS/P.CBURBC,CTST  SET CURRENT BURST BYTE COUNT
          RJM    DDO         DMA DATA OUTPUT OPERATION

*         PROCESS END OF BURST
 O8D400   RJM    WFTC        WAIT FOR TRANSFER COMPLETE
          LDML   /TS/P.CBURBC,CTST  CHECK FOR ODD/EVEN TRANSFER
          LPN    1
          ZJN    O8D420      IF EVEN, USE EVEN OCTET MASTER ENDING STATUS
          LDN    ODDOT       ELSE USE ODD OCTET STATUS
 O8D420   RJM    GES         GET ENDING STATUS
          LDDL   STATUS      SAVE SLAVE ENCODED ENDING STATUS
          STML   /TS/P.SLVEES,CTST
          RJM    URECTC      UPDATE RECORD TRANSFER COUNT
          NJN    O8D460      IF PARTIAL RECORD, REPORT ERROR
          LDML   /TS/P.SLVEES,CTST  CHECK FOR END OF RECORD
          LPN    60B         MASK PAUSE AND TDO BITS
          SBN    20B
          ZJN    O8D500      IF END OF RECORD
          RJM    GETNP       GET NEXT L/A PAIR
          ZJN    O8D460      IF NO PAIRS LEFT, REPORT ERROR
          LDML   /TS/P.SLVEES,CTST  CHECK FOR SLAVE PAUSE
          LPN    60B         MASK PAUSE AND TDO BITS
          ZJK    O8D40       IF NO PAUSE
          RJM    DCM         DESELECT SLAVE

 O8D440   RJM    WSTN        WAIT FOR SPECIAL TRANSFER NOTIFICATION
          ZJK    O8D30       IF NEXT BURST IS READY
          UJK    O8D10       ELSE PROCESS OTHER INTERRUPT

 O8D460   LDK    E505        INVALID LENGTH SPECIFICATION
          RJM    SWFAIL      REPORT ERROR (NO RETURN)
          SPACE  2
*         PROCESS END OF RECORD
 O8D500   RJM    DCM         DESELECT SLAVE
          LDML   /TS/P.RTCIP,CTST  INCREMENT RECORD XFER COUNT IN POINTER
          ADN    2
          LPN    7
          STML   /TS/P.RTCIP,CTST
          LDN    2           SEND 2 MORE WRITE COMMANDS IF ANY LEFT
          RJM    GWRT
          UJK    O8D10       WAIT FOR INTERRUPT
          SPACE  2
*         PROCESS COMMAND COMPLETION
 O8D600   AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          SOML   /TS/P.NSWC,CTST  DECREMENT NON-STOP WRITE COUNTER
          RJM    UREQTC      UPDATE REQUEST TRANSFER COUNTS
          LDML   RPB+MAJST   GET MAJOR STATUS
          LMN    CCS         CHECK FOR SUCCESSFUL
          NJN    O8D610      IF NOT
          LDML   /TS/P.CRN,CTST  CHECK THE CRN
          LMML   RPB+CRN
          NJN    O8D620      IF MISCOMPARE
          RJM    GBID        GET AND STORE BLOCK ID
          LJM    CMDCOMP     COMMAND COMPLETE

 O8D610   LDN    1           EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE (NO RETURN)

 O8D620   LDK    E76         REPORT UNEXPECTED RESPONSE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE (NO RETURN)
          EJECT
** NAME - READ
*
** PURPOSE - PROCESS LOGICAL READ RECORD COMMAND.
*            (LOGICIAL COMMAND 41)
*
** INPUT - THE SECONDARY ADDRESS FIELD OF THE REQUEST HEADER MUST HAVE A
*          MAXIMUM BYTE COUNT IN THE LEAST SIGNIFICANT 32 BITS. THIS
*          BYTE COUNT IS USED FOR THE IPI READ COMMAND EXTENT PARAMETER.
          SPACE  2
 READ     BSS                ENTRY

          LDML   /TS/P.NSRC,CTST  CHECK IF FIRST READ COMMAND
          NJK    READ40      IF NOT
          SPACE  2
*         SEND ALL READ COMMANDS TO SLAVE
          LDIL   CTST        GET COMMAND REFERENCE NUMBER
          STML   /TS/P.NSCRN,CTST  SET NON-STOP COMMAND REFERENCE NUMBER
          ADN    1           INCREMENT IT
          STML   READCP1     SAVE IT
          LDML   /TS/P.SN,CTST  GET ADDRESSEE
          STML   READCP5
          LDML   /TS/P.RQB+/RQ/P.SECADR+2,CTST  GET MAX. BYTE COUNT
          STML   READCP9     SET IN READ COMMAND PACKET
          LDML   /TS/P.RQB+/RQ/P.SECADR+3,CTST
          STML   READCPB
          ADML   READCP9     CHECK IF NON ZERO BYTE COUNT
          NJN    READ10      IF OK
          LDK    E505        INVALID LENGTH SPECIFICATION
          RJM    SWFAIL      REPORT SOFTWARE FAILURE (NO RETURN)

 READ10   LDML   /TS/P.NUMCM,CTST  GET NUMBER OF COMMANDS LEFT
          ADN    1           ADJUST FOR THIS COMMAND
          STDL   P5          SAVE IT
          LDML   /TS/P.LASTC,CTST  BUILD PP COMMAND ADDRESS
          SHN    -1
          ADDL   CTST
          ADK    /TS/P.CQB
          STDL   P6          SAVE IT
          STML   /TS/P.NSCA,CTST  SAVE FIRST NON-STOP COMMAND ADDRESS
          UJN    READ30

 READ20   LDN    8           INCREMENT PP ADDRESS TO NEXT COMMAND
          RADL   P6
          LDIL   P6          GET NEXT COMMAND
          SHN    -8          POSITION COMMAND CODE
          ADK    -LCREAD     CHECK FOR LOGICIAL READ
          NJN    READ40      IF NOT

 READ30   LDC    READCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
          AOML   /TS/P.NSRC,CTST  INCREMENT NON-STOP READ COUNTER
          LDDL   P5          DECREMENT COMMANDS LEFT COUNTER
          SBN    2
          STDL   P5
          ZJN    READ40      IF DONE
          AOML   READCP1     INCREMENT COMMAND REFERENCE NUMBER
          UJN    READ20      LOOP
          SPACE  4
*         PROCESS IPI INTERRUPTS
 READ40   LDML   /TS/P.WSTNF,CTST  CHECK WSTN FLAG
          NJK    READ440     IF SET, CONTINUE CURRENT RECORD

 READ50   LDK    100         SECS LIMIT (PARTIAL READ OF MAX 32K PE REC)
          RJM    IH          INTERRUPT HANDLER
          SHN    -4          POSITION RESPONSE TYPE
          LPN    0#F         MASK IT
          SBN    1           CHECK FOR COMMAND COMPLETION
          ZJK    READ600     IF YES
          SBN    4           CHECK FOR TRANSFER NOTIFICATION
          ZJN    READ60      IF YES
          LDN    0           ELSE MUST BE ASYNCHRONUS RESPONSE
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    READ40      LOOP
          SPACE  2
*         INITIALIZE DATA TRANSFER
 READ60   LDML   /TS/P.WSTNF,CTST  CHECK WSTN FLAG
          ZJN    READ65      IF NOT SET, START NEW RECORD
          LDN    0           CLEAR WSTN FLAG
          STML   /TS/P.WSTNF,CTST
          UJN    READ70      CONTINUE CURRENT RECORD

 READ65   RJM    NSI         NON-STOP INITIALIZATION
          LDML   /TS/P.NSCRN,CTST  COMPARE COMMAND REFERENCE NUMBERS
          LMML   RPB+CRN
          ZJN    READ70      IF OK
          LDK    E76         REPORT UNEXPECTED RESPONSE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE (NO RETURN)
          SPACE  2
*         START DATA TRANSFER
 READ70   RJM    SEL         SELECT SLAVE

 READ80   LDN    DATAIN      BUS A DATA IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0281       STREAM AND READ
          RJM    FUNC
          LDN    0           CLEAR CURRENT BURST BYTE COUNT
          STML   /TS/P.CBURBC,CTST
          STDL   BC          CLEAR PREVIOUS T PRIME REGISTERS
          STDL   RMA
          STDL   RMA+1

*         DETERMINE BURST CHARACTERISTICS
 READ90   LDML   /TS/P.ILSTP+1,CTST  GET REQUESTED BYTE COUNT THIS PAIR
          STDL   T1          SAVE IT
          ADML   /TS/P.CBURBC,CTST  ADD CURRENT BURST BYTE COUNT
          SBDL   BURSTSZ     SUBTRACT SLAVE BURST SIZE
          ZJN    READ200     IF TRANSFER IS TO BURST BOUNDARY
          PJK    READ300     IF TRANSFER IS GREATER THAN BURST BOUNDARY

*         PROCESS TRANSFER OF LESS THAN BURST BOUNDARY
 READ100  LDN    0           CLEAR PARTIAL L/A PAIR FLAG
          STML   /TS/P.PARLAP,CTST
          LDDL   T1          GET REQUESTED BYTE COUNT THIS PAIR
          ADN    1           ROUND UP (IF LAST PAIR HAS ODD BYTE COUNT)
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNEL WORD COUNT
          SHN    1           INCREMENT CURRENT BURST BYTE COUNT
          RAML   /TS/P.CBURBC,CTST
          RJM    DDI         DMA DATA INPUT
          RJM    WFTE        WAIT FOR T PRIME REGISTER EMPTY
          NJN    READ400     IF PARTIAL RECORD
          RJM    GETNP       GET NEXT L/A PAIR
          ZJN    READ400     IF NO MORE L/A PAIRS
          UJN    READ90      CONTINUE TO INPUT

*         PROCESS TRANSFER TO BURST BOUNDARY
 READ200  LDN    0           CLEAR PARTIAL L/A PAIR FLAG
          STML   /TS/P.PARLAP,CTST
          LDDL   T1          GET REQUESTED BYTE COUNT THIS PAIR
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNNEL WORD COUNT
          LDDL   BURSTSZ     INCREMENT CURRENT BURST BYTE COUNT
          STML   /TS/P.CBURBC,CTST
          RJM    DDI         DMA DATA INPUT
          UJN    READ400     PROCESS END OF BURST

*         PROCESS TRANSFER OF GREATER THAN BURST BOUNDARY
 READ300  LDDL   BURSTSZ     COMPUTE BYTE COUNT TO BURST BOUNDARY
          SBML   /TS/P.CBURBC,CTST  DECREMENT BY BYTES TRANSFERED ALREADY
          STML   /TS/P.PARLAP,CTST  SET PARTIAL L/A PAIR FLAG
          SHN    -1          ADJUST TO CHANNEL WORDS
          STDL   WC          SET CHANNEL WORD COUNT
          LDDL   BURSTSZ
          STML   /TS/P.CBURBC,CTST  SET CURRENT BURST BYTE COUNT
          RJM    DDI         DMA DATA INPUT

*         PROCESS END OF BURST
 READ400  RJM    WVTC        WAIT VARIABLE TRANSFER COMPLETE
          LDN    0           MASTER ENCODED ENDING STATUS
          RJM    GES         GET ENDING STATUS
          LDDL   STATUS      SAVE SLAVE ENCODED ENDING STATUS
          STML   /TS/P.SLVEES,CTST
          RJM    URECTC      UPDATE RECORD TRANSFER COUNT
          LDML   /TS/P.SLVEES,CTST  CHECK FOR END OF RECORD
          LPN    60B         MASK PAUSE AND TDO BITS
          SBN    20B
          ZJN    READ500     IF END OF RECORD
          RJM    GETNP       GET NEXT L/A PAIR
          ZJN    READ460     IF NO PAIRS LEFT, REPORT ERROR
          LDML   /TS/P.SLVEES,CTST  CHECK FOR SLAVE PAUSE
          LPN    60B         MASK PAUSE AND TDO BITS
          ZJK    READ80      IF NO PAUSE
          RJM    DCM         DESELECT SLAVE

 READ440  RJM    WSTN        WAIT FOR SPECIAL TRANSFER NOTIFICATION
          ZJK    READ70      IF NEXT BURST IS READY
          UJK    READ50      PROCESS OTHER INTERRUPT

 READ460  LDK    E505        INVALID LENGTH SPECIFICATION
          RJM    SWFAIL      REPORT ERROR (NO RETURN)
          SPACE  2
*         PROCESS END OF RECORD
 READ500  RJM    DCM         DESELECT SLAVE
          LDML   /TS/P.RTCIP,CTST  INCREMENT RECORD XFER COUNT IN POINTER
          ADN    2
          LPN    7
          STML   /TS/P.RTCIP,CTST
          UJK    READ50      WAIT FOR INTERRUPT
          SPACE  2
*         PROCESS COMMAND COMPLETION
 READ600  AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          SOML   /TS/P.NSRC,CTST  DECREMENT NON-STOP READ COUNTER
          RJM    UREQTC      UPDATE REQUEST TRANSFER COUNTS
          LDML   RPB+MAJST   GET MAJOR STATUS
          LMN    CCS         CHECK FOR SUCCESSFUL
          NJN    READ610     IF NOT
          LDML   /TS/P.CRN,CTST  CHECK THE CRN
          LMML   RPB+CRN
          NJN    READ620     IF MISCOMPARE
          RJM    GBID        GET AND STORE BLOCK ID
          LJM    CMDCOMP     COMMAND COMPLETE

 READ610  LDN    3           EXPECT BLOCK ID OR TAPE MARK
          RJM    CMDRESP     COMMAND RESPONSE DECODE (NO RETURN)

 READ620  LDK    E76         REPORT UNEXPECTED RESPONSE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE (NO RETURN)
          SPACE  4
*         -READ-  COMMAND PACKET
 READCP   DATA   0#000C      PACKET LENGTH
 READCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCREAD+CMCHN+OMRF  OP-CODE, CHAIN AND READ FORWARD
 READCP5  DATA   0#FFFF      ADDRESSEE
          CON    CPSCE       SPECIAL COMMAND EXTENT PARAMETER
 READCP9  DATA   0#FFFF        COUNT FIELD UPPER
 READCPB  DATA   0#FFFF        COUNT FIELD LOWER
          EJECT
** NAME - WRITE
*
** PURPOSE - TO PROCESS LOGICIAL WRITE COMMAND.
*            (LOGICIAL COMMAND 51 MODIFIED)
*
** NOTE-- THE ACTUAL DATA TRANSFER WILL BE DONE IN THE
*         OUTPUT 8-BIT DATA LOGICIAL COMMAND 23.
          SPACE  2
 WRITE    BSS                ENTRY

          LDML   /TS/P.NSWC,CTST  CHECK IF FIRST WRITE COMMAND
          NJN    WRITE10     IF NOT

*         INITIALIZE FIRST GROUP OF NON-STOP WRITE COMMANDS
          LDIL   CTST        GET COMMAND REFERENCE NUMBER
          STML   /TS/P.NSCRN,CTST  SET FIRST-1 NON-STOP CRN
          STML   /TS/P.GNSCRN,CTST  SET WORKING GROUP NON-STOP CRN
          LDML   /TS/P.NUMCM,CTST  GET NUMBER OF COMMANDS LEFT
          ADN    1           ADJUST FOR THIS COMMAND
          STML   /TS/P.GNUMCM,CTST  SAVE AS GROUP NUMBER OF CMDS LEFT
          LDML   /TS/P.LASTC,CTST  BUILD PP COMMAND ADDRESS
          SHN    -1
          ADDL   CTST
          ADK    /TS/P.CQB
          STML   /TS/P.GNSCA,CTST  SAVE AS GROUP NON-STOP PP ADDRESS
          ADN    4           SET FIRST NON-STOP COMMAND ADDRESS
          STML   /TS/P.NSCA,CTST
          LDN    4           SEND 4 WRITE COMMANDS IN FIRST GROUP
          RJM    GWRT        GO SEND A GROUP OF WRITE COMMANDS
 WRITE10  LJM    CMDCOMP     GOTO COMMAND COMPLETION
          SPACE  4
 GWRT     SUBR               ENTRY/EXIT
          STDL   P5          SET LOOP COUNTER FROM A
*         INITIALIZE THIS GROUP OF NON-STOP WRITE COMMANDS
 GWRT10   LDML   /TS/P.GNUMCM,CTST  CHECK IF ALL GROUPS DONE
          ZJN    GWRTX       IF YES
          LDML   /TS/P.GNSCA,CTST  GET PP CMD ADDRESS
          STDL   P6          SAVE IT
          LDIL   P6          GET THE COMMAND
          SHN    -8          POSITION COMMAND CODE
          ADC    -LCWRITE    CHECK FOR LOGICIAL WRITE COMMAND
          NJN    GWRTX       IF NOT
          LDML   /TS/P.SN,CTST  GET ADDRESSEE
          STML   WRTCP5      PUT INTO IPI COMMAND PACKAGE
          RJM    SEL         SELECT THE SLAVE

*         SEND THIS GROUP OF NON-STOP WRITE COMMANDS
 GWRT20   LDN    2           INCREMENT PP ADDRESS TO BYTE COUNT UPPER
          RADL   P6
          LDIL   P6          GET BYTE COUNT UPPER
          STML   WRTCP9      SET IT
          AODL   P6          INCREMENT PP ADDRESS TO BYTE COUNT LOWER
          LDIL   P6          GET BYTE COUNT LOWER
          STML   WRTCPB      SET IT
          AOML   /TS/P.GNSCRN,CTST  INCREMENT GROUP NON-STOP CRN
          STML   WRTCP1      SET IT
          LDC    WRTCP+BYPSD  COMMAND PACKET FWA AND BYPASS SEL/DCM
          RJM    CPT         COMMAND PACKET TRANSFER
          LDN    5           INCREMENT PP ADDRESS TO NEXT WRITE COMMAND
          RADL   P6
          AOML   /TS/P.NSWC,CTST  INCREMENT NON-STOP WRITE COUNTER
          LCN    2           DECREMENT GROUP NUMBER OF CMDS LEFT
          RAML   /TS/P.GNUMCM,CTST
          ZJN    GWRT30      IF DONE
          SODL   P5          DECREMENT LOOP COUNTER
          ZJN    GWRT30      IF DONE
          LDIL   P6          GET NEXT COMMAND
          SHN    -8          POSITION COMMAND CODE
          ADC    -LCWRITE    CHECK FOR LOGICIAL WRITE
          ZJN    GWRT20      IF YES

 GWRT30   RJM    DCM         DESELECT SLAVE
          LDDL   P6          SAVE WORKING PP CMD ADDRESS
          STML   /TS/P.GNSCA,CTST
          UJK    GWRTX       EXIT
          SPACE  4
*         -WRITE-  COMMAND PACKET
 WRTCP    DATA   0#000C      PACKET LENGTH
 WRTCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCWRITE+CMCHN  OP-CODE AND CHAIN
 WRTCP5   DATA   0#FFFF      ADDRESSEE
          CON    CPCE        COMMAND EXTENT PARAMETER
 WRTCP9   DATA   0#FFFF        COUNT (UPPER)
 WRTCPB   DATA   0#FFFF        COUNT (LOWER)
          EJECT
** NAME - STRTC
*
** PURPOSE - TO PERFORM THE LOGICAL COMMAND STORE TRANSFER COUNT.
*            (LOGICIAL COMMAND 61)
          SPACE  2
 STRTC    BSS                ENTRY
          LDN    0           INITIALIZE DIRECT CELLS
          STDL   T1
          STDL   T2
          LDML   /TS/P.XFER,CTST  GET TRANSFER COUNT
          STDL   T3          MOVE TO DIRECT CELLS
          LDML   /TS/P.XFER+1,CTST
          STDL   T4
          LOADF  /TS/P.CURCMD+2,CTST  LOAD R+A FROM COMMAND
          CWDL   T1          STORE TRANSFER COUNT
          LDN    0           CLEAR TRANSFER COUNTERS
          STML   /TS/P.XFER,CTST
          STML   /TS/P.XFER+1,CTST
          LJM    NOSTAT      COMMAND COMPLETE, NO STATUS TO CHECK
          TITLE  COMMAND SUBROUTINES
** NAME - PFORM
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF FORMAT UNIT
*            (FUNCTION CODE 004)
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
*
*          FORMAT FUNCTION PARAMETERS (LIKE ATS) ARE LOCATED IN THE
*          SECONDARY ADDRESS FIELD OF THE PERIPHERAL REQUEST.
          SPACE  2
 PFORM    BSS                ENTRY
          LDDL   CLF         CHECK IF CHANNEL IS ALREADY LOCKED
          ZJN    PFORM10     IF YES
          RJM    SCLOCK      LOCK CHANNEL LOCKWORD IN CHANNEL TABLE
 PFORM10  BSS
          RJM    SLVTST      CHECK FOR SLAVE TESTING REQUIRED
          LDML   SLB+/SL/P.SLVTST,SX  CHECK IF ATTRIBUTES REQUIRED
          ZJN    PFORM20     IF NOT
          LDN    1           ENABLE ERROR CORRECTION
          STML   /TS/P.ECSEL,CTST  SAVE SELECTION
          RJM    ATTRIB      SET ATTRIBUTES
          LDN    0
 PFORM20  BSS
          STML   /TS/P.FACSTA,CTST  CLEAR SPECIAL STATUS
          RJM    GFS         GET FACILITY STATUS TO CHECK FOR BUSY
          LDML   /TS/P.FACSTA+1,CTST  CHECK IF AT BOT
          SHN    17-15
          MJN    PFORM30     IF YES THEN DO DENSITY SELECTION
          LDML   SLB+/SL/P.SLVTST,SX  CHECK IF ATTRIBUTES WERE REQUIRED
          ZJN    PFORM60     IF NOT THEN BYPASS DENSITY SELECTION
 PFORM30  BSS
*         GET PARAMETER WORD 2 BIT 8  (DEFINE DENSITY SELECTION)
          LDML   /TS/P.RQB+/RQ/P.SECADR,CTST
          LPN    1           MASK DEFINE BIT
          ZJN    PFORM40     IF NOT SET USE DEFAULT DENSITY
*         GET PARAMETER WORD 2 BITS 7-6  (DENSITY SELECTION)
          LDML   /TS/P.RQB+/RQ/P.SECADR+1,CTST
          SHN    3           POSITION DENSITY SELECT BITS
          MJN    PFORM40     IF 6250 (GCR) SELECTED
          LDN    1           ELSE USE 1600 (PE) DENSITY
          UJN    PFORM50
 PFORM40  BSS
          LDN    2           USE 6250
 PFORM50  BSS
          STML   /TS/P.DENSEL,CTST  SAVE SELECTION
          RJM    OPMODE      SELECT DENSITY
 PFORM60  BSS
          LDN    0           CLEAR SPECIAL STATUS
          STML   /TS/P.FACSTA,CTST
          STML   SLB+/SL/P.SLVTST,SX  CLEAR TESTING/ATTRIBUTES REQUIRED
          RJM    FACTST      CHECK FOR FACILITY TESTING
          UJK    CMDCOMP     COMMAND COMPLETE
          EJECT
** NAME - PREW
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF REWIND/UNLOAD
*            (FUNCTION CODE X10)
*             X = 0 10 REWIND
*             X = 1 10 UNLOAD
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PREW     BSS                ENTRY
          RJM    RFEL        READ FACILITY ERROR LOG
          RJM    GFS         GET FACILITY STATUS ID52
          LDML   /TS/P.CURCMD+3,CTST  GET PHYSICAL FUNCTION CODE
          SHN    17-6
          MJK    PUNL        IF 110 UNLOAD
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PREWCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PREWCP5
          LDC    PREWCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PREW10   LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PREW20      IF NOT
          RJM    RSEL        READ SLAVE ERROR LOG
          LDN    0           CLEAR RESPONSE PACKET LENGTH
          STML   RPB
          LJM    CMDCOMP     COMMAND COMPLETE
 PREW20   LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PREW10      IF ASYNC RESPONSE
          SPACE  4
*         -POSITION CONTROL-  COMMAND PACKET
 PREWCP   DATA   0#0009      PACKET LENGTH
 PREWCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCPOSC      OP-CODE AND END OF CHAIN
 PREWCP5  DATA   0#FFFF      ADDRESSEE
          CON    CPTP        TAPE POSITION PARAMETER
          DATA   0#0800        REWIND
          EJECT
** NAME - PUNL
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF 110 UNLOAD
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PUNL     BSS                ENTRY
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PUNLCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PUNLCP5
          LDC    PUNLCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PUNL10   LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PUNL20      IF NOT
          RJM    RSEL        READ SLAVE ERROR LOG
          LDN    0           CLEAR RESPONSE PACKET LENGTH
          STML   RPB
          LJM    CMDCOMP     COMMAND COMPLETE
 PUNL20   LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PUNL10      IF ASYNC RESPONSE
          SPACE  4
*         -POSITION CONTROL-  COMMAND PACKET
 PUNLCP   DATA   0#0009      PACKET LENGTH
 PUNLCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCPOSC      OP-CODE AND END OF CHAIN
 PUNLCP5  DATA   0#FFFF      ADDRESSEE
          CON    CPTP        TAPE POSITION PARAMETER
          DATA   0#2000        UNLOAD
          EJECT
** NAME - PSPB
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF SPACE BLOCK FWD/REV
*            (FUNCTION CODE X13)
*             X = 0 13 SPACE BLOCK FORWARD
*             X = 1 13 SPACE BLOCK BACKWARD
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PSPB     BSS                ENTRY
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PSPBCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PSPBCP5
          LDML   /TS/P.CURCMD+3,CTST  GET PHYSICAL FUNCTION CODE
          SHN    17-6
          PJN    PSPB10      IF 013 (FORWARD) FUNCTION
          LDC    OCREADV+CMCHN+OMRVR  ELSE 113 (REVERSE)
          UJN    PSPB20      CONT.
 PSPB10   LDC    OCREADV+CMCHN+OMRVF
 PSPB20   STML   PSPBCP3     STORE OP-CODE
          LDC    PSPBCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PSPB30   LDK    150         SECONDS LIMIT (FULL LENGTH TAPE RECORD)
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PSPB40      IF NOT SUCCESSFUL
          RJM    GBID        GET BLOCK ID AND STORE INTO BID TABLE
          LJM    CMDCOMP     GOTO COMMAND COMPLETE
 PSPB40   LDN    3           EXPECT BLOCK ID OR END OF EXTENT (TAPE MARK)
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PSPB30      IF ASYNC RESPONSE
          SPACE  4
*         -READ VERIFY-  COMMAND PACKET
 PSPBCP   DATA   0#0006      PACKET LENGTH
 PSPBCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
 PSPBCP3  CON    OCREADV+CMCHN+OMRVF   OP-CODE AND CHAIN
 PSPBCP5  DATA   0#FFFF      ADDRESSEE
          EJECT
** NAME - PSTM
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF SEARCH TAPE MARK FWD/REV
*            (FUNCTION CODE X15)
*             X = 015 SEARCH TAPE MARK FORWARD
*             X = 115 SEARCH TAPE MARK BACKWARD
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PSTM     BSS                ENTRY
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PSTMCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PSTMCP5
          LDML   /TS/P.CURCMD+3,CTST  GET PHYSICAL FUNCTION CODE
          SHN    17-6
          PJN    PSTM10      IF 015 (FORWARD) FUNCTION
          LDC    OCSPACE+CMCHN+OMSFR  ELSE 115 (BACKWARD)
          UJN    PSTM20      CONT.
 PSTM10   LDC    OCSPACE+CMCHN+OMSFF  OP-CODE FWD AND CHAIN
 PSTM20   STML   PSTMCP3     STORE OP-CODE
          LDC    PSTMCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PSTM30   LDK    150         SECONDS LIMIT (FULL LENGTH TAPE)
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PSTM40      IF NOT
          RJM    TMBID       STORE TAPE MARK BLOCK ID
          LDK    /RS/K.LDLIM  SET LOGICIAL DELIMITER STATUS CONDITION
          STML   /TS/P.SCOND,CTST
          LJM    CMDCOMP     GOTO COMMAND COMPLETE
 PSTM40   LDN    2           EXPECT END OF EXTENT (TAPE MARK)
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PSTM30      IF ASYNC RESPONSE
          SPACE  4
*         -SPACE FILE MARK-  COMMAND PACKET
 PSTMCP   DATA   0#0006      PACKET LENGTH
 PSTMCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
 PSTMCP3  CON    OCSPACE+CMCHN+OMSFF  OP-CODE AND CHAIN
 PSTMCP5  DATA   0#FFFF      ADDRESSEE
          EJECT
** NAME - PWTM
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF WRITE TAPE MARK
*            (FUNCTION CODE 051)
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PWTM     BSS                ENTRY
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PWTMCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PWTMCP5
          LDC    PWTMCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PWTM10   LDN    10          SECONDS LIMIT (INCLUDES ID RECOVERY)
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PWTM20      IF NOT
          RJM    TMBID       STORE TAPE MARK BLOCK ID
          LDK    /RS/K.LDLIM  SET LOGICIAL DELIMITER STATUS CONDITION
          STML   /TS/P.SCOND,CTST
          LJM    CMDCOMP     GOTO COMMAND COMPLETE
 PWTM20   LDN    2           EXPECT END OF EXTENT (TAPE MARK)
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PWTM10      IF ASYNC RESPONSE
          SPACE  4
*         -RECORD POSITION-  COMMAND PACKET
 PWTMCP   DATA   0#0009      PACKET LENGTH
 PWTMCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCRECP      OP-CODE AND NO CHAIN
 PWTMCP5  DATA   0#FFFF      ADDRESSEE
          CON    CPTM        TAPE MARK PARAMETER
          DATA   0#8000        FILE MARK
          EJECT
** NAME - PERS
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF ERASE TAPE
*            (FUNCTION CODE X52)
*             X = 052 - ERASE GAP
*             X = 252 - DATA SECURITY ERASE
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PERS     BSS                ENTRY
          LDML   /TS/P.CURCMD+3,CTST  GET PHYSICAL FUNCTION CODE
          SHN    17-7
          MJK    PDSE        IF 252 DATA SECURITY ERASE FUNCTION
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PERSCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PERSCP5
          LDC    PERSCP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PERS10   LDN    10          SECONDS LIMIT (INCLUDES ID RECOVERY)
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          ZJK    CMDCOMP     IF YES, GOTO COMMAND COMPLETE
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PERS10      IF ASYNC RESPONSE
          SPACE  4
*         -ERASE-  COMMAND PACKET
 PERSCP   DATA   0#0006      PACKET LENGTH
 PERSCP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCERASE+OMGAP  OP-CODE, NO CHAIN AND GAP ERASE
 PERSCP5  DATA   0#FFFF      ADDRESSEE
          EJECT
** NAME - PDSE
*
** PURPOSE - PERFORM PHYSICAL FUNCTION OF DATA SECURITY ERASE
*            (FUNCTION CODE 252)
*
** INPUT - PHYSICAL FUNCTION CODE IN CURRENT TS TABLE
*          LOCATION CURCMD+3.
          SPACE  2
 PDSE     BSS                ENTRY
          RJM    GFS         GET FACILITY STATUS ID52
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PDSECP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   PDSECP5
          LDC    PDSECP      COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PDSE10   LDN    10          SECONDS LIMIT (INCLUDES ID RECOVERY)
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          NJN    PDSE20      IF NOT
          LDN    0           CLEAR IPI RESPONSE LENGTH
          STML   RPB
          LJM    CMDCOMP     COMMAND COMPLETE
 PDSE20   LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    PDSE10      IF ASYNC RESPONSE
          SPACE  4
*         -ERASE-  COMMAND PACKET
 PDSECP   DATA   0#0006      PACKET LENGTH
 PDSECP1  DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCERASE+OMDSE  OP-CODE, NO CHAIN AND DSE
 PDSECP5  DATA   0#FFFF      ADDRESSEE
          TITLE  SUPPORT SUBROUTINES
** NAME-- SCANT
*
** PURPOSE-- SCAN TS TABLES
*
** EXIT-- A =  0 NEXT TS TABLE NOT IN USE
*         A = NZ NEXT TS TABLE IN USE
          SPACE  2
 SCANT    SUBR               ENTRY/EXIT
          RJM    SNXTAB      SELECT NEXT SLAVE TS TABLE
          LPDL   TIU         MASK WITH TS TABLES IN USE
          UJN    SCANTX      EXIT
          SPACE  5,20
** NAME-- SNXTAB
*
** PURPOSE-- SELECT NEXT SLAVE TS TABLE
*
** ENTRY-- CTST = CURRENT TS TABLE IN USE
*
** EXIT-- A = NEXT TS TABLE BIT ADDRESS
*         CTST = NEXT TS TABLE INDEX
          SPACE  2
 SNXTAB   SUBR               ENTRY/EXIT
          LDDL   CTST        GET CURRENT TS TABLE IN USE
          SBML   TS1         CHECK IF TS1 IN USE
          ZJN    SNXTAB2     IF TS2 IS NEXT
          ADK    -P.TS       CHECK IF TS2 IN USE
          ZJN    SNXTAB3     IF TS3 IS NEXT
*                            ELSE TS2 IS NEXT

 SNXTAB2  LDN    1           USE TS2 NEXT
          UJN    SNXTAB9     CONT.

 SNXTAB3  LDN    2           USE TS3 NEXT

 SNXTAB9  STDL   T1          SAVE INDEX INTO NEXT TS TABLE TO USE
          LDML   TS1,T1      GET NEXT TS TABLE ADDRESS
          STDL   CTST
          LDML   SELT,T1     USE SLAVE BIT ADDRESS TABLE
          UJN    SNXTABX     EXIT
          SPACE  2
          ERRNZ  2-MCSLV     IF NUMBER OF SLAVE TS TABLES CHANGES
          SPACE  5,20
** NAME-- SCANAS
*
** PURPOSE-- SCAN ALL SLAVES FOR A NEW LOCKABLE REQUEST
*
** EXIT-- A =  0 NO NEW REQUESTS
*         A = NZ NEW REQUEST FOUND, UNIT AND UIT REQUEST QUEUE LOCKED
*
** NOTE-- NREQSN = SLAVE NUMBER THAT HAS REQUEST ACTIVE
*         NREQFN = FACILITY NUMBER THAT HAS REQUEST ACTIVE
          SPACE  2
 SCANAS   SUBR               ENTRY/EXIT
          LDDL   SLVN        START SEARCH FROM LAST SLAVE USED
          LPN    MAXSL-1     MASK IT
          STML   NREQSN
          LDDL   FACN        START SEARCH FROM LAST FACILITY+1
          ADN    1
          LPN    FACPSL-1    MASK IT
          STML   NREQFN
          LDN    MAXSL       LOOP COUNT
          STDL   P1

 SCANAS5  LDN    0           DISABLE SCANING SLAVE IF FACILITY LOCKED
          RJM    SCANS       SCAN ALL FACILITITES ON THE SLAVE
          NJN    SCANASX     FOUND ONE, EXIT A=NZ

          SODL   P1          CHECK FOR DONE
          ZJN    SCANASX     IF YES, EXIT A=0

          AOML   NREQSN      INCREMENT TO NEXT SLAVE
          LPN    MAXSL-1     MASK IT
          STML   NREQSN

          LDN    0           START FROM FIRST FACILITY THIS TIME
          STML   NREQFN

          UJN    SCANAS5     SCAN NEXT SLAVE
          SPACE  2
          ERRNZ  8-FACPSL    IF FACILITIES PER SLAVE CHANGES
          ERRNZ  8-SLVPCH    IF SLAVES PER CHANNEL CHANGES
          SPACE  5,20
** NAME-- SCANS
*
** PURPOSE-- SCAN ALL FACILITIES ON A SLAVE FOR A ACTIVE REQUEST
*
** ENTRY--A =  0 DO NOT SCAN A SLAVE THAT HAS A FACILITY LOCKED
*         A = NZ SCAN A SLAVE THAT HAS A FACILITY LOCKED
*
** EXIT-- A =  0 NO NEW REQUESTS
*         A = NZ NEW REQUEST FOUND, UNIT AND UIT REQUEST QUEUE LOCKED
*
** USES-- T1-T6, P2-P5
*
** NOTE-- NREQSN = SLAVE NUMBER THAT HAS REQUEST ACTIVE
*         NREQFN = FACILITY NUMBER THAT HAS REQUEST ACTIVE
          SPACE  2
 SCANS0   LDN    0           EXIT, NO NEW REQUEST

 SCANS    SUBR               ENTRY/EXIT
          STML   SCANSA      SAVE ENTRY PARAMETER
          LDML   NREQSN      GET SLAVE NUMBER TO SEARCH
          SHN    2           BUILD SLAVE TABLE INDEX
          STDL   P3          P3 = SX INDEX
          LDML   SLB+/SL/P.FBA,P3  CHECK FOR ANY FACILITIES CONFIGURED
          ZJN    SCANSX      IF NONE,  EXIT A=0
          LDML   SCANSA      CHECK IF SCAN IS ENABLED FOR LOCKED FACILITY
          NJN    SCANS5      IF YES, CONTINUE
          LDML   SLB+/SL/P.FACLCK,P3  CHECK IF A FACILITY IS LOCKED
          SHN    -6
          NJN    SCANS0      IF YES, DO NOT SCAN THIS SLAVE

 SCANS5   LDDL   UX          SAVE THE ORIGINAL UX
          STDL   P5          P5 = ORIGINAL UX
          LDN    FACPSL
          STDL   P2          P2 = LOOP COUNT

 SCANS10  LDDL   P3          BUILD UNITS TABLE INDEX
          SHN    -2
          ADDL   P3
          SHN    3
          STDL   P4
          LDML   NREQFN
          SHN    2
          RADL   P4
          LDML   NREQFN
          RADL   P4          P4 = UX INDEX
          LDML   UNITS+/UN/P.LU,P4  CHECK IF FACILITY IS CONFIGURED
          ZJK    SCANS60     IF NOT
          LOADR  UNITS+/UN/P.UIT,P4  LOAD REFORMATTED R+A OF UIT
          ERRNZ  /UIT/C.DSABLE
          CRDL   T1          READ UNIT STATUS INTO T2
          ADN    /UIT/C.NEXT  OFFSET TO NEXT REQUEST RMA
          CRDL   T3          READ NEXT REQUEST RMA WORD
          LDDL   T2          CHECK IF UNIT IS DISABLED
          ERRNZ  /UIT/P.DSABLE-1
          SHN    18-16+/UIT/L.DSABLE
          MJK    SCANS60     IF UNIT IS DISABLED
          LDDL   T5          CHECK HALF 1 OF REQUEST RMA
          ADDL   T6          AND HALF 2 OF REQUEST RMA
          ZJK    SCANS60     IF NO REQUEST
          LDML   SLB+/SL/P.FACLCK,P3  CHECK IF SLAVE HAS A FACILITY LOCKED
          SHN    -6
          ZJN    SCANS20     IF NONE
          LDML   SLB+/SL/P.CURFAC,P3  CHECK IF SAME FACILITY AS SCANED
          LPN    17B
          SBML   NREQFN
          ZJK    SCANS60     IF YES

*         TRY TO LOCK UNIT AND REQUEST QUEUE THEN VERIFY ACTIVE REQUEST
 SCANS20  LDDL   P4          SET UX = P4
          STDL   UX          LOCK ROUTINES USE UX
          RJM    SULOCK      TRY TO SET UNIT LOCKWORD
          NJK    SCANS60     IF COULD NOT GET THE LOCK
          RJM    SQLOCK      TRY TO SET REQUEST QUEUE LOCKWORD
          NJK    SCANS50     IF COULD NOT GET THE LOCK
          LOADR  UNITS+/UN/P.UIT,P4  LOAD REFORMATTED R+A OF UIT
          CRDL   T1          READ UNIT STATUS INTO T2
          ADN    /UIT/C.NEXT  OFFSET TO NEXT REQUEST RMA
          CRDL   T3          READ NEXT REQUEST RMA WORD
          LDDL   T2          VERIFY IF UNIT IS DISABLED
          SHN    18-16+/UIT/L.DSABLE
          MJN    SCANS40     IF UNIT IS DISABLED
          LDDL   T5          VERIFY HALF 1 OF REQUEST RMA
          ADDL   T6          AND HALF 2 OF REQUEST RMA
          ZJK    SCANS40     IF NOT VALID LOCKED REQUEST
          LDN    1           SET FACILITY LOCKED IN SL TABLE
          SHN    6
          STML   SLB+/SL/P.FACLCK,P3
          LDML   NREQFN      SET FACILITY NUMBER LOCKED
          LPN    17B
          RAML   SLB+/SL/P.CURFAC,P3
          LDDL   P5          RESTORE ORIGINAL UX
          STDL   UX
          LDN    1
          UJK    SCANSX      EXIT WITH REQUEST FOUND AND LOCKED, A=NZ

 SCANS40  RJM    CQLOCK      UNLOCK UNIT REQUEST QUEUE LOCKWORD

 SCANS50  RJM    CULOCK      UNLOCK UNIT LOCKWORD

 SCANS60  SODL   P2          CHECK FOR DONE SEARCHING
          ZJN    SCANS70     IF YES
          LDML   NREQFN      INCREMENT FACILITY NUMBER
          ADN    1
          LPN    FACPSL-1    MASK IT
          STML   NREQFN
          UJK    SCANS10     SEARCH AGAIN

 SCANS70  LDDL   P5          RESORE ORIGINAL UX
          STDL   UX
          LDN    0
          UJK    SCANSX      EXIT A=0, NONE FOUND

 SCANSA   BSSZ   1           SAVED ENTRY PARAMETER
          SPACE  2
          ERRNZ  4-P.SL      IF SL CHANGES
          ERRNZ  5-P.UN      IF UN CHANGES
          ERRNZ  40-FACPSL*P.UN  IF UNITS TABLE CHANGES
          ERRNZ  8-FACPSL    IF FACILITIES PER SLAVE CHANGES
          SPACE  4
 NREQSN   DATA   0           NEXT REQUEST SLAVE NUMBER
 NREQFN   DATA   0           NEXT REQUEST FACILITY NUMBER
          SPACE  5,20
** NAME-- NEXTCMD
*
** PURPOSE-- GET THE NEXT COMMAND TO PROCESS
*
** ENTRY-- A = BYTE INCREMENT VALUE FOR LASTC OFFSET
*              0=FIRST COMMAND
*              8=NEXT COMMAND
          SPACE  2
 NEXTCMD  SUBR               ENTRY/EXIT
          RAML   /TS/P.LASTC,CTST  INCREMENT COMMAND OFFSET
          SHN    -1          ADJUST TO PP WORD OFFSET
          ADDL   CTST        BUILD SOURCE ADDRESS
          ADK    /TS/P.CQB
          STML   NXTCA
          LDN    0           INITIALIZE LOOP COUNTER
          STDL   T1
          LDDL   CTST        INITIALIZE DESTINATION ADDRESS INDEX
          STDL   T2

 NXTC10   LDML   *,T1        GET THE NEXT COMMAND
 NXTCA    EQU    *-1
          STML   /TS/P.CURCMD,T2  PUT INTO TS TABLE CURRENT COMMAND
          AODL   T1          CHECK FOR DONE
          SBN    4
          ZJN    NEXTCMDX    IF YES, EXIT
          AODL   T2          INCREMENT DESTINATION ADDRESS INDEX
          UJN    NXTC10      LOOP
          SPACE  5,20
** NAME-- SWITCH
*
** PURPOSE-- SWITCH PROCESSING TO OTHER TS TABLES AS REQUIRED
*
** EXIT-- RETURN TO CALLER IF NO OTHER TS TABLES IN USE,
*         ELSE PROCESS OTHER TS TABLES.
          SPACE  2
 SWITCH   SUBR               ENTRY/EXIT

          LDDL   INITFLG     CHECK FOR INITIALIZATION
          NJN    SWITCHX     IF YES, EXIT

 SWI05    LDML   TNTAB       CHECK NUMBER OF SLAVE TS TABLES SUPPORTED
          SBN    1
          ZJN    SWITCHX     IF ONLY 1, RETURN TO CALLER
          LDML   SWITCH      GET CURRENT CALLERS RETURN ADDRESS
          STML   SLB+/SL/P.SIU,SX  SAVE ADDRESS IN SLAVE IN USE FLAG
          RJM    SAVETAB     SAVE CURRENT TS TABLE DIRECT CELLS

 SWI10    RJM    SCANT       SCAN NEXT SLAVE TS TABLE
          ZJN    SWI20       IF NOT IN USE
          RJM    RELDTAB     RELOAD THIS TS TABLE DIRECT CELLS
          RJM    PS          PORT SELECT
          LDML   SLB+/SL/P.SIU,SX  GET RETURN ADDRESS
          STML   SWITCH      STORE AS EXIT ADDRESS
          UJK    SWITCHX     GO PROCESS A TS TABLE

 SWI20    LDDL   ASYNCP      CHECK IF ASYNC PROCESSING
          ADDL   PPREQF       OR PP REQUEST WAITING
          ADDL   MALREQF      OR MALET CHANNEL REQUEST WAITING
          NJN    SWI10       IF YES, BYPASS LOOKING FOR NEW REQUESTS
          RJM    SCANAS      SCAN ALL SLAVES FOR NEW REQUESTS
          ZJN    SWI10       IF NONE
          RJM    INITNR      INITIALIZE THE NEW REQUEST
          LDC    DOUR30      STARTING ADDRESS FOR NEW REQUEST
          STML   SWITCH      SIMULATE A SWITCH CALL FROM NEW REQUEST
          UJK    SWI05       SWITCH TO NEXT TS TABLE

 TNTAB    DATA   0           TOTAL SLAVE TS TABLES SUPPORTED (PLUGGED)
          SPACE  5,20
** NAME-- ERRCHK
*
** PURPOSE-- CHECK FOR ALERT MASK STATUS CONDITIONS
*
** EXIT-- A = 0 IF NO MASKABLE ERRORS
*         A =NZ IF MASKABLE ERRORS
          SPACE  2
 ERRCHK   SUBR               ENTRY/EXIT
          LDML   /TS/P.SCOND,CTST  GET CURRENT STATUS CONDITIONS
          LPML   /TS/P.RQB+/RQ/P.LONGB,CTST  MASK WITH REQUEST ALERT MASK
          ZJN    ERRCHKX     IF NONE, EXIT A=0

          RJM    PAR         PREPARE ABNORMAL RESPONSE
          LDK    /RS/K.ABALRT  SET ABNORMAL ALERT
          STML   RS+/RS/P.ABALRT
          LDML   /TS/P.SCOND,CTST  GET CONDITIONS
          LPML   /TS/P.RQB+/RQ/P.LONGB,CTST  MASK THEM AGAIN
          STML   RS+/RS/P.LNGBLK  SET MASKED ALERT CONDITIONS
          RJM    CDUNIT      CHECK FOR DOWNING UNIT
          LDN    1
          UJN    ERRCHKX     ERROR EXIT, A=NZ
          SPACE  5,20
** NAME-- IODONE
*
** PURPOSE-- PROCESS IO REQUEST DONE
*
** ENTRY-- RESPONSE ALREADY GENERATED AND CDUNIT CALLED
*          IF NEEDED.
*
** EXIT-- *MAIN* IF NO OTHER NEW REQUESTS OR THIS REQUEST
*         IS NOT CHAINED.
*         *DOUR20* IF NEW OR CHAINED REQUEST IS PROCESSABLE.
          SPACE  2
 IODONE   BSS                ENTRY ONLY
          RJM    RESP        SEND THE PREPARED RESPONSE
          RJM    CKPPRQ      CHECK FOR EXISTING OR NEW PP REQUEST
          NJN    IODONE10    IF YES
          RJM    CKCREQ      CHECK FOR EXISTING OR NEW MALET CH REQUEST
          ZJN    IODONE20    IF NOT

 IODONE10 RJM    CLREQ       CLEAR UNIT REQUEST ACTIVE
          LJM    MAIN        GO TO MAIN IDLE LOOP

*         CHECK IF UNIT IS NOW DOWN OR CHAINED REQUEST
 IODONE20 LOADR  UNITS+/UN/P.UIT,UX  LOAD REFORMATTED R+A OF UIT
          ERRNZ  /UIT/C.DSABLE
          CRDL   T1          READ UNIT STATUS INTO T2
          ADN    /UIT/C.NEXT  OFFSET TO NEXT REQUEST RMA
          CRDL   T3          READ NEXT REQUEST RMA WORD
          LDDL   T2          CHECK IF UNIT IS DISABLED
          ERRNZ  /UIT/P.DSABLE-1
          SHN    18-16+/UIT/L.DSABLE
          MJN    IODONE10    IF UNIT IS DISABLED
          LDDL   T5          CHECK HALF 1 OF REQUEST RMA
          ADDL   T6          AND HALF 2 OF REQUEST RMA
          ZJN    IODONE10    IF NO CHAINED REQUEST
          RJM    CFC         CHECK IF FACILITY STILL CHAINED
          STDL   ASYNCP      CLEAR ASYNCHRONUS PROCESSING FLAG
          LDDL   TSLVS       CHECK IF MORE THAN 1 SLAVE CONFIGURED
          SBN    1
          NJK    IODONE60    IF YES

*         CHECK FOR ACTIVE REQUESTS ON OTHER UNITS OF THIS SLAVE
 IODONE30 LDDL   SLVN        PREPARE FOR SCAN
          STML   NREQSN      SLAVE NUMBER TO SCAN
          LDDL   FACN        START SCAN FROM NEXT UNIT NUMBER
          ADN    1
          LPN    FACPSL-1    MASK IT
          STML   NREQFN      FACILITY NUMBER TO SCAN FIRST
          LDN    1           ENABLE SCAN WITH LOCKED FACILITY
          RJM    SCANS       SCAN SLAVE FOR LOCKABLE REQUESTS
          NJK    IODONE40    IF ONE FOUND, PROCESS THE OTHER REQUEST
          RJM    CLRPTS      CLEAR PARTIAL TS TABLE
          RJM    SQLOCK      TRY TO SET UIT REQUEST QUEUE LOCK AGAIN
          NJK    IODONE10    IF COULD NOT SET LOCK
*         VERIFY CHAINED REQUEST WHILE QUEUE IS LOCKED
          LOADR  UNITS+/UN/P.UIT,UX  LOAD REFORMATTED R+A OF UIT
          ERRNZ  /UIT/C.DSABLE
          CRDL   T1          READ UNIT STATUS INTO T2
          ADN    /UIT/C.NEXT  OFFSET TO NEXT REQUEST RMA
          CRDL   T3          READ NEXT REQUEST RMA WORD
          LDDL   T2          CHECK IF UNIT IS DISABLED
          ERRNZ  /UIT/P.DSABLE-1
          SHN    18-16+/UIT/L.DSABLE
          MJK    IODONE10    IF UNIT IS DISABLED
          LDDL   T5          CHECK HALF 1 OF REQUEST RMA
          ADDL   T6          AND HALF 2 OF REQUEST RMA
          ZJK    IODONE10    IF NO CHAINED REQUEST
          RJM    LDTS        LOAD CHAINED REQUEST AND UNLOCK QUEUE
          LDN    70B         SET ASYNCHRONUS PROCESSING FLAG
          STDL   ASYNCP        SO SWITCH WILL NOT START A NEW REQUEST
          RJM    SWITCH      SWITCH, IF ANY CLASS 2 INTERRUPTS WAITING
          LDN    0           CLEAR ASYNCHRONUS PROCESSING FLAG
          STDL   ASYNCP
          LDML   /TS/P.NUMCM,CTST  DECREMENT NUMBER OF COMMANDS
          SBN    2
          STML   /TS/P.NUMCM,CTST
          LDN    8           BYPASS FORMAT COMMAND
          RJM    NEXTCMD     GET NEXT COMMAND
          LJM    CMDEXEC     GO EXECUTE THE COMMAND

*         PROCESS A DIFFERENT UNIT REQUEST
 IODONE40 RJM    CULOCK      UNLOCK OLD UNIT LOCKWORD
          RJM    CLRPTS      CLEAR PARTIAL TS TABLE
          UJK    DOUR20      GO PROCESS NEW REQUEST

*         CHECK FOR REQUESTS ON OTHER SLAVES
 IODONE60 LDDL   SLVN        START SCAN FROM NEXT SLAVE NUMBER
          ADN    1
          LPN    MAXSL-1     MASK IT
          STML   NREQSN      SLAVE NUMBER TO SCAN FIRST
          LDN    0           FACILITY NUMBER TO SCAN FIRST
          STML   NREQFN
          LDN    MAXSL-1     LOOP COUNT MINUS CURRENT SLAVE
          STDL   P1          P1 = LOOP COUNTER

 IODONE70 LDN    0           DISABLE SCAN IF A FACILITY IS LOCKED
          RJM    SCANS       SCAN SLAVE FOR NEW LOCKABLE REQUEST
          ZJN    IODONE80    IF NONE FOUND
          LDML   SLB+/SL/P.FACLCK,SX  CLEAR ORIGINAL FACILITY LOCK
          LPN    17B
          STML   SLB+/SL/P.FACLCK,SX
          UJK    IODONE40    GO PROCESS NEW REQUEST

 IODONE80 SODL   P1          DECRECMENT LOOP COUNT
          ZJK    IODONE30    IF ALL OTHER SLAVES SCANED
          AOML   NREQSN      INCREMENT SLAVE NUMBER
          LPN    MAXSL-1     MASK IT
          STML   NREQSN
          LDN    0
          STML   NREQFN      START SCAN FROM FACILITY 0
          UJN    IODONE70    LOOP
          ERRNZ  8-FACPSL    IF FACILITIES PER SLAVE CHANGES
          ERRNZ  8-SLVPCH    IF SLAVES PER CHANNEL CHANGES
          SPACE  5,20
** NAME-- CMDRESP
*
** PURPOSE-- COMMAND RESPONSE DECODE
*
** INPUT-- RPB HAS COMMAND RESPONSE PACKET
*          A = 0 DO NOT EXPECT BLOCK ID
*          A = 1 EXPECT BLOCK ID, IF NOT ERROR
*          A = 2 EXPECT END OF EXTENT (TAPE MARK), IF NOT ERROR
*          A = 3 EXPECT EITHER BLOCK ID OR END OF EXTENT, IF NOT ERROR
          SPACE  2
 CMDRESP  SUBR               ENTRY/EXIT
          STML   /TS/P.BIDEF,CTST  SAVE BLOCK ID EXPECTED FLAG
          LDN    0
          STDL   P1          CLEAR ERROR FLAG
          STML   /TS/P.SCOND,CTST  CLEAR ALERT CONDITIONS FLAG
          LDML   RPB+MAJST   DECODE RESPONSE TYPE
          SHN    -4
          LPN    0#F
          SBN    CC          CHECK FOR COMMAND COMPLETION
          ZJN    CMDR100     IF YES
          SBN    AR-CC       CHECK FOR ASYNCHRONUS
          ZJK    CMDR200     IF YES
          SBN    TN-AR       CHECK FOR TRANSFER NOTIFICATION
          ZJK    CMDR300     IF YES
          UJK    CMDR476     UNDEFINED RESPONSE TYPE (E76)
          SPACE  2
*         PROCESS COMMAND COMPLETION RESPONSE TYPE
 CMDR100  LDIL   CTST        COMPARE COMMAND REFERENCE NUMBERS
          LMML   RPB+CRN
          NJK    CMDR476     REPORT UNEXPECTED STATUS (E76)

          LDML   RPB+MAJST   DECODE MAJOR STATUS
          SHN    LSCS        CHECK FOR CONDITIONAL
          PJK    CMDR130     IF NOT
          LDK    ID29        SEARCH FOR FAC CONDITIONAL PARAMETER
          RJM    SFP
          PJN    CMDR110     IF FOUND
          LDK    ID19        ELSE SEARCH FOR SLAVE CONDITIONAL PARAMETER
          RJM    SFP
          PJN    CMDR110     IF FOUND
          UJK    CMDR476     REPORT UNEXPECTED STATUS (E76)

 CMDR110  LDML   RPB+6,T3    DECODE CONDITIONAL OCTETS 1 AND 2
          STDL   T1          SAVE IT
          LPC    0#7002      CHECK FOR ERRORS
          ZJN    CMDR115     IF NOT
          AODL   P1          SET ERROR FLAG

 CMDR115  LDDL   T1          CHECK FOR ON-THE-FLY CORRECTION
          LPN    0#8
          ZJN    CMDR120     IF NOT
          AOML   /TS/P.OTFC,CTST  REPORT ON-THE-FLY CORRECTION

 CMDR120  LDML   RPB+7,T3    DECODE CONDITIONAL OCTETS 3 AND 4
          SHN    -8          POSITION OCTET 3
          STDL   T1          SAVE OCTET 3
          LPN    1           CHECK FOR MASTER TERMINATED TRANSFER
          ZJN    CMDR125     IF NOT
          AODL   P1          SET ERROR FLAG

 CMDR125  LDDL   T1          GET OCTET 3
          LPN    0#10        CHECK FOR EOM WARNING (EOT)
          ZJN    CMDR130     IF NOT
          LDK    /RS/K.PDLIM  SET PHYSICAL DELIMITER IN STATUS CONDITIONS
          RAML   /TS/P.SCOND,CTST

 CMDR130  LDML   RPB+MAJST   CHECK FOR OTHER MAJOR STATUS BITS
          LPC    0#F805
          ZJK    CMDR165     IF NONE

          SHN    LSI         CHECK FOR INCOMPLETE
          PJK    CMDR160     IF NOT
          LDK    ID2A        SEARCH FOR INCOMPLETE PARAMETER
          RJM    SFP
          MJK    CMDR476     IF NOT FOUND REPORT ERROR (E76)

          LDML   RPB+7,T3    DECODE INCOMPLETE OCTETS 3 AND 4
          STDL   T1          SAVE IT
          SHN    -8          POSITION OCTET 3
          LPK    0#8C        CHECK FOR ERRORS
          ZJN    CMDR132     IF NOT
          AODL   P1          SET ERROR FLAG

 CMDR132  LDDL   T1          CHECK FOR BLOCK LENGTH DIFFERENCE
          SHN    -8          POSITION OCTET 3
          LPN    0#10        MASK IT
          ZJN    CMDR140     IF NOT SET
          LDML   RPB+OPCD    CHECK IF READ OPERATION
          SHN    -8          POSITION OP-CODE
          SBN    0#10
          ZJN    CMDR134     IF YES
          AODL   P1          SET ERROR FLAG
          UJN    CMDR140     CONT.

 CMDR134  LDK    ID32        SEARCH FOR RESPONSE EXTENT
          RJM    SFP
          MJK    CMDR476     IF PARAMETER NOT FOUND  (E76)
          LDML   RPB+6,T3    CHECK FOR SHORT OR LONG RECORD
          ADML   RPB+7,T3
          NJN    CMDR140     IF SHORT BLOCK, OK
          LDK    /RS/K.LNGBLK  SET LONG BLOCK IN STATUS CONDITIONS
          RAML   /TS/P.SCOND,CTST

 CMDR140  LDDL   T1          GET OCTET 3 AND 4
          SHN    17-14       CHECK FOR EOM WARNING (EOT)
          PJN    CMDR150     IF NOT
          LDK    /RS/K.PDLIM  SET PHYSICAL DELIMITER IN STATUS CONDITIONS
          RAML   /TS/P.SCOND,CTST

 CMDR150  LDDL   T1          GET OCTETS 3 AND 4
          SHN    17-13       CHECK FOR END OF EXTENT (TM) DETECTED
          PJN    CMDR160     IF NOT
          LDK    /RS/K.LDLIM  SET LOGICIAL DELIMITER IN STATUS CONDITIONS
          RAML   /TS/P.SCOND,CTST

 CMDR160  LDML   RPB+MAJST   CHECK FOR OTHER STATUS BITS
          LPC    0#F800
          ZJN    CMDR162     IF NOT
          AODL   P1          SET ERROR FLAG

 CMDR162  LDML   RPB+MAJST   CHECK FOR COMMAND ABORT
          LPN    1
          ZJN    CMDR165     IF NOT
          AOML   /TS/P.CHAIN,CTST  SET COMMAND CHAINING ABORT FLAG

 CMDR165  LDDL   P1          CHECK IF ERROR FLAG IS SET
          NJK    CMDR400     IF YES, BYPASS TM OR BID
          LDML   /TS/P.BIDEF,CTST  CHECK FOR BID OR TM EXPECTED
          ZJK    CMDR195     IF NOT GOTO COMMAND COMPLETE
          SBN    1           CHECK FOR BID EXPECTED
          ZJN    CMDR170     IF YES
          SBN    1           CHECK FOR END OF EXTENT (TM) EXPECTED
          ZJN    CMDR180     IF YES

          LDML   /TS/P.SCOND,CTST  ELSE EITHER
          SHN    17-12
          MJK    CMDR190     IF END OF EXTENT FOUND

 CMDR170  LDK    IDD0        SEARCH FOR BLOCK ID PARAMETER
          RJM    SFP
          MJK    CMDR478     IF NOT FOUND REPORT ERROR (E78)
          RJM    GBID        PUT BLOCK ID INTO TABLE
          UJN    CMDR195     GOTO COMMAND COMPLETE

 CMDR180  LDML   /TS/P.SCOND,CTST  CHECK FOR END OF EXTENT DETECTED
          SHN    17-12
          MJK    CMDR190     IF YES
*         CHECK FOR X15 OR 051 ATS PHYSICAL FUNCTIONS
          LDML   /TS/P.CURCMD+3,CTST
          LPN    77B         MASK MAJOR FUNCTION CODE BITS
          SBN    F.STM       CHECK FOR SEARCH TAPE MARK (X15)
          ZJN    CMDR185     IF YES
          SBN    F.WTM-F.STM  CHECK FOR WRITE TAPE MARK (X15)
          NJK    CMDR490     IF NOT, REPORT ERROR (E90)

 CMDR185  LDK    /RS/K.LDLIM  SET LOGICIAL DELIMITER IN STATUS CONDITIONS
          RAML   /TS/P.SCOND,CTST

 CMDR190  RJM    TMBID       SET END OF EXTENT IN BLOCK ID TABLE

 CMDR195  LDDL   P1          CHECK IF ERROR FLAG IS SET
          NJN    CMDR400     IF YES
          LJM    CMDCOMP     ELSE,  GOTO COMMAND COMPLETE
          SPACE  4
*         PROCESSING ASYNCHRONUS RESPONSE TYPE
 CMDR200  BSS
          LDML   RPB+SLAD    CHECK FOR FACILITY ASYNC RESPONSE
          LPDL   FF
          LMDL   FF
          NJK    CMDRESPX    IF YES, RETURN TO CALLER
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDK    R.UNS       CHANGE TO UNSOLICITED
          STML   RS+/RS/P.RC
          LDN    0           SET LOGICIAL UNIT NUMBER = 0
          STML   RS+/RS/P.LU
          RJM    RESP        SEND RESPONSE
          UJK    CMDRESPX    NOW RETURN TO CALLER
          SPACE  4
*         PROCESS TRANSFER NOTIFICATION RESPONSE TYPE
 CMDR300  UJN    CMDR476     REPORT UNEXPECTED STATUS (E76)
          SPACE  4
*         ERROR CODES
 CMDR400  LDN    E00         CPU MUST DETERMINE
          UJN    CMDR500

 CMDR476  LDK    E76         UNEXPECTED STATUS
          UJN    CMDR500

 CMDR478  LDDL   P1          CHECK IF ERROR FLAG IS SET
          NJN    CMDR400     IF YES
          LDK    E78         ELSE, NO BLOCK ID RETURNED
          UJN    CMDR500

 CMDR490  LDDL   P1          CHECK IF ERROR FLAG IS SET
          NJN    CMDR400     IF YES
          LDK    E90         ELSE, NO END OF EXTENT STATUS

 CMDR500  RJM    PCER        PREPARE COMMON ERROR RESPONSE
          LDML   /TS/P.SCOND,CTST  GET CURRENT STATUS CONDITIONS
          LPML   /TS/P.RQB+/RQ/P.LONGB,CTST  MASK WITH REQUEST ALERT MASK
          ZJN    CMDR510     IF NONE ACTIVE

          STML   RS+/RS/P.LNGBLK  SET MASKED CONDITIONS

          LDK    /RS/K.ABALRT  SET ABNORMAL ALERT BIT
          STML   RS+/RS/P.ABALRT

 CMDR510  LDDL   P1          CHECK IF ERROR FLAG IS SET
          ZJN    CMDR520     IF NOT
          LDML   RS+/RS/P.ERRID  CHECK IF ERROR ID IS NONZERO
          NJN    CMDR520     IF YES

          LDK    /RS/K.HDWR  SET HARDWARE MALFUNCTION BIT
          RAML   RS+/RS/P.ABALRT

 CMDR520  RJM    CMDTERM     COMMAND TERMINATE  (NO RETURN)
          SPACE  5,20
** NAME-- ATTRIB
*
** PURPOSE-- SEND ATTRIBUTE COMMAND TO SLAVE
*
** INPUT-- (/TS/P.ECSEL,CTST) =
*              0 DO NOTHING
*              1 ERROR CORRECTION ENABLED
*              2 ERROR CORRECTION DISABLED
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 ATT1     LDML   /TS/P.SATTR,CTST  RESTORE RETURN ADDRESS
          STML   ATTRIB

 ATTRIB   SUBR               ENTRY/EXIT
          LDML   ATTRIB      SAVE RETURN ADDRESS
          STML   /TS/P.SATTR,CTST
          LDML   /TS/P.ECSEL,CTST  CHECK FOR SELECTION
          ZJN    ATTRIBX     IF NOT DEFINED EXIT
          SBN    1
          ZJN    ATT10       IF ERROR CORRECTION ENABLED
          LDC    0#8000      DISABLE ERROR CORRECTION PARAM
          UJN    ATT20       CONT.
 ATT10    LDC    0#C000      ENABLE ERROR CORRECTION PARAM
 ATT20    STML   ATTCP9      STORE PARAMETER
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   ATTCP1
          LDML   /TS/P.SN,CTST  GET SLAVE ADDRESS
          SHN    -8
          SHN    8
          ADDL   FF          NO FACILITY ADDRESS
          STML   ATTCP5
          LDC    ATTCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 ATT30    LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          ZJK    ATT1        IF YES, EXIT
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    ATT30       IF ASYNC RESPONSE
          SPACE  4
*         -ATTRIBUTES-  COMMAND PACKET
 ATTCP    DATA   0#0025      PACKET LENGTH
 ATTCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCATT+OMAL  OP-CODE, LOAD AND NO CHAINING
 ATTCP5   DATA   0#FFFF      ADDRESSEE (NO FACILITY)
          CON    CPSRB       SLAVE RECONFIGURATION BIT PARAMETER
 ATTCP9   DATA   0#FF00        C000=EC ENABLED, 8000=EC DISABLED
          CON    CPSRF       SLAVE RECONFIGURATION FIELD PARAMETER
          DATA   0,0,0,0       OCTETS 01-08
          DATA   0,0,0,0              09-10
 ATTCP1D  CON    BURST                11-12 GENERATE CLASS 2 INTERRUPTS
          DATA   0                    13-14
 ATTCP21  CON    BURST                15-16 DATA BURST SIZE
          CON    CPBID       ENABLE/DISABLE BID PARAMETER
          DATA   0#8000        BID ENABLED
          SPACE  5,20
** NAME-- OPMODE
*
** PURPOSE-- SEND OPMODE COMMAND TO SLAVE/FACILITY
*
** INPUT-- (/TS/P.DENSEL,CTST) =
*              0 DO NOTHING
*              1 SELECT 1600 (PE) OPERATION
*              2 SELECT 6250 (GCR) OPERATION
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 OPM1     LDML   /TS/P.SOPMO,CTST  RESTORE RETURN ADDRESS
          STML   OPMODE

 OPMODE   SUBR               ENTRY/EXIT
          LDML   OPMODE      SAVE RETURN ADDRESS
          STML   /TS/P.SOPMO,CTST
          LDML   /TS/P.DENSEL,CTST  CHECK FOR SELECTION
          ZJN    OPMODEX     IF NOT DEFINED EXIT
          SBN    1
          ZJN    OPM10       IF 1600 (PE)
          LDC    0#030C      SET 6250 (GCR) PARAMETERS
          STML   OPMCP13
          LDC    0#186A
          STML   OPMCP15
          UJN    OPM20       CONT.
 OPM10    LDC    0#0607      SET 1600 (PE) PARAMETERS
          STML   OPMCP13
          LDC    0#0640
          STML   OPMCP15
 OPM20    AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   OPMCP1
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   OPMCP5
          LDC    OPMCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 OPM30    LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK IF COMMAND COMPLETE SUCCESSFUL
          ZJK    OPM1        IF YES, EXIT
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    OPM30       IF ASYNC RESPONSE
          SPACE  4
*         -OPERATING MODE-  COMMAND PACKET
 OPMCP    DATA   0#0016      PACKET LENGTH
 OPMCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCOM+CMCHN+OMOMS  OP-CODE, CHAIN AND SET
 OPMCP5   DATA   0#FFFF      ADDRESSEE
          CON    CPTMB       TAPE MODE BIT PARAMETER
          DATA   0#0000
          DATA   0#0100        DISABLE COMPRESSION
          CON    CPTMF       TAPE MODE FIELD PARAMETER
          DATA   0#0000
          DATA   0#0000
 OPMCP13  DATA   0#FFFF        PE=0607, GCR=030C
 OPMCP15  DATA   0#FFFF        PE=0640, GCR=186A
          SPACE  5,20
** NAME-- GBID
*
** PURPOSE-- GET BLOCK ID FROM RESPONSE PACKET
*            AND STORE INTO CURRENT TS BIDB BUFFER.
          SPACE  2
 GBID     SUBR               ENTRY/EXIT
          LDK    IDD0        FIND BLOCK ID PARAMETER IN RESPONSE PACKET
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    GBID10      IF NOT FOUND
          LDK    /TS/P.BIDB  BUILD DESTINATION ADDRESS
          ADDL   CTST        CURRENT TS TABLE BASE ADDRESS
          ADML   /TS/P.BIDBP,CTST  BLOCK ID BUFFER POINTER
          STML   GBIDA       SET DESTINATION ADDRESS
          LDML   RPB+6,T3    GET BLOCK ID VALUE
          SHN    3           POSITION IT LIKE ATS BID
          STML   *           PUT INTO BLOCK ID BUFFER
 GBIDA    EQU    *-1
          AOML   /TS/P.BIDBP,CTST  INCREMENT POINTER
          UJN    GBIDX       EXIT

 GBID10   RJM    PAR         PREPARE ABNORMAL RESPONSE
          LDK    E78         NO BLOCK ID PARAMETER RETURNED
          STML   RS+/RS/P.ERRID
          RJM    CMDTERM     TERMINATE COMMAND (NO RETURN)
          SPACE  5,10
** NAME-- CFC
*
** PURPOSE-- CHECK FOR CHAINING STILL ACTIVE
*
** EXIT-- A = 0
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 CFC      SUBR               ENTRY/EXIT
          LDML   /TS/P.CHAIN,CTST  GET CHAIN FLAG
          ZJN    CFCX        IF NOT ACTIVE EXIT
          STDL   ASYNCP      SET ASYNCHRONUS PROCESSING FLAG
          LDML   CFC         SAVE RETURN ADDRESS
          STML   /TS/P.SCFC,CTST
          RJM    LIR         LOGICIAL INTERFACE RESET TO CLEAR CHAINING
          LDML   /TS/P.SCFC,CTST  RESTORE RETURN ADDRESS
          STML   CFC
          LDN    0           CLEAR RESPONSE PACKET LENGTH
          STML   RPB
          UJN    CFCX        EXIT
          SPACE  5,20
** NAME-- TMBID
*
** PURPOSE-- SET TAPE MARK BLOCK ID INTO BLOACK ID BUFFER.
          SPACE  2
 TMBID    SUBR               ENTRY/EXIT
          LDK    /TS/P.BIDB  BUILD DESTINATION ADDRESS
          ADDL   CTST        CURRENT TS TABLE BASE ADDRESS
          ADML   /TS/P.BIDBP,CTST  BLOCK ID BUFFER POINTER
          STML   TMBIDA      SET DESTINATION ADDRESS
          LDN    0#01        TAPE MARK IDENTIFIER
          STML   *           PUT INTO BLOCK ID BUFFER
 TMBIDA   EQU    *-1
          AOML   /TS/P.BIDBP,CTST  INCREMENT POINTER
          UJN    TMBIDX      EXIT
          SPACE  5,20
** NAME-- GFS
*
** PURPOSE-- GET FACILITY STATUS ID52 FOR RESPONSE.
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 GFS1     LDML   /TS/P.SGFS,CTST  RESTORE RETURN ADDRESS
          STML   GFS

 GFS      SUBR               ENTRY/EXIT
          LDML   /TS/P.FACSTA,CTST  CHECK IF ALREADY SET
          NJN    GFSX        IF YES
          LDML   GFS         SAVE RETURN ADDRESS
          STML   /TS/P.SGFS,CTST
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   GFSCP1
          LDML   /TS/P.SN,CTST  ADDRESSEE
          STML   GFSCP5
          SHN    -8          BUILD SLAVE PARAMETER
          SHN    8
          ADDL   FF
          STML   GFSCP9
          LDC    GFSCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER

 GFS10    LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR SUCCESSFUL
          ZJN    GFS20       IF YES
          LDN    0           DO NOT EXPECT BID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    GFS10       IF ASYNC RESPONSE

 GFS20    LDK    ID52        LOCATE PARAM 52
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    GFS30       IF NOT FOUND
          LDML   RPB+5,T3    SAVE PARAMETERS IN TS TABLE
          STML   /TS/P.FACSTA,CTST
          LDML   RPB+6,T3
          STML   /TS/P.FACSTA+1,CTST
          LDN    0           CLEAR RESPONSE PACKET LENGTH
          STML   RPB
          UJK    GFS1        EXIT

 GFS30    LDK    E76         REPORT UNEXPECTED STATUS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE (NO RETURN)
          SPACE  2,10
*         -REPORT ADDRESSEE STATUS-  COMMAND PACKET
 GFSCP    DATA   0#000B      PACKET LENGTH
 GFSCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCRAS+OMRASC  OP-CODE AND CONDITION
 GFSCP5   DATA   0#FFFF      ADDRESSEE
          CON    CPPM        PORT MASK PARAMETER
 GFSCP9   DATA   0#00FF        SLAVE ADDRESS
          DATA   0#0100        PORT MASK
          SPACE  5,20
** NAME-- RSEL
*
** PURPOSE-- READ SLAVE ERROR LOG TO PREVENT IT
*            FROM OVERFLOWING.
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 RSEL1    LDML   /TS/P.SRSEL,CTST  RESTORE RETURN ADDRESS
          STML   RSEL

 RSEL     SUBR               ENTRY/EXIT
          LDML   RSEL        SAVE RETURN ADDRESS
          STML   /TS/P.SRSEL,CTST
          LDML   RELCP3      CLEAR CHAINING COMMON MODIFIER
          LPC    0#FF0F
          STML   RELCP3
          LDML   /TS/P.SN,CTST  GET SLAVE ADDRESS
          SHN    -8
          SHN    8
          ADDL   FF          NO FACILITY ADDRESS
          STML   RELCP5
          RJM    REL         READ THE SLAVE ERROR LOG
          UJN    RSEL1       EXIT
          SPACE  4,15
** NAME-- RFEL
*
** PURPOSE-- READ FACILITY ERROR LOG TO PREVENT IT
*            FROM OVERFLOWING.
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 RFEL1    LDML   /TS/P.SRFEL,CTST  RESTORE RETURN ADDRESS
          STML   RFEL

 RFEL     SUBR               ENTRY/EXIT
          LDML   RFEL        SAVE RETURN ADDRESS
          STML   /TS/P.SRFEL,CTST
          LDML   RELCP3      SET CHAINING COMMON MODIFIER
          LPC    0#FF0F
          ADN    CMCHN
          STML   RELCP3
          LDML   /TS/P.SN,CTST  GET SLAVE/FACILITY ADDRESS
          STML   RELCP5
          RJM    REL         READ THE FACILITY ERROR LOG
          UJN    RFEL1       EXIT
          SPACE  5,20
** NAME-- NSI
*
** PURPOSE-- NON-STOP INITIALIZATION FOR READ OR OUTPUT 8-BIT DATA COMMANDS.
*
** INPUT-- (/TS/P.NSCA,CTST) HAS CURRENT PP COMMAND ADDRESS TO SET UP.
*
** OUTPUT-- (/TS/P.ILSTL,CTST) HAS NUMBER OF INDIRECT LENGTH/ADDRESS PAIRS
*           (/TS/P.ILSTA,CTST) HAS RMA (UNFORMATTED) OF INDIRECT LEN/ADD PAIR
*           (/TS/P.ILSTP,CTST) HAS INDIRECT LENGTH/ADDRESS PAIR
*           (/TS/P.NSCRN,CTST) HAS UPDATED NON-STOP CMD REFERENCE NUMBER
*           ((/TS/P.RTCB,CTST)+(/TS/P.RTCIP,CTST)) REC XFER COUNT CLEARED
*
** NOTE-- IF THE COMMAND DOES NOT HAVE THE INDIRECT ADDRESS BIT SET, THE
*         COMMAND LENGTH/ADDRESS IS MOVED INTO (/TS/P.ILSTP,CTST) AND
*         (/TS/P.ILSTL,CTST) IS SET TO 1. (/TS/P.ILSTA,CTST) IS NOT SET.
          SPACE  2
 NSI10    AODL   P4          INCREMENT PP ADDRESS
          LDIL   P4          GET NUMBER OF PAIRS
          SHN    -3
          STML   /TS/P.ILSTL,CTST
          AODL   P4          INCREMENT PP ADDRESS
          LDIL   P4          SET RMA OF FIRST PAIR
          STML   /TS/P.ILSTA,CTST
          AODL   P4
          LDIL   P4
          STML   /TS/P.ILSTA+1,CTST
          LDK    /TS/P.ILSTP  BUILD CRML PP ADDRESS
          ADDL   CTST
          STML   NSIA
          LOADF  /TS/P.ILSTA,CTST  SET R+A OF FIRST PAIR
          CRML   *,ONE       READ THE FIRST INDIRECT LEN/ADD PAIR
 NSIA     EQU    *-1

 NSI20    LDN    8           INCREMENT TO NEXT NON-STOP COMMAND ADDRESS
          RAML   /TS/P.NSCA,CTST


 NSI      SUBR               ENTRY/EXIT


          LDK    /TS/P.RTCB  BUILD CURRENT REC XFER COUNT ADDRESS
          ADDL   CTST
          ADML   /TS/P.RTCIP,CTST  INCREMENT WITH IN POINTER
          STML   NSIB        SAVE IT (UPPER HALF)
          ADN    1           BUILD LOWER HALF ADDRESS
          STML   NSIC
          LDN    0           CLEAR CURRENT REC XFER COUNTER
          STML   *           UPPER HALF
 NSIB     EQU    *-1
          STML   *           LOWER HALF
 NSIC     EQU    *-1

          AOML   /TS/P.NSCRN,CTST  UPDATE NON-STOP COMMAND REFERENCE NUMBER
          LDML   /TS/P.NSCA,CTST  GET NON-STOP COMMAND PP ADDRESS
          STDL   P4          SAVE IT
          LDIL   P4          GET COMMAND
          SHN    17-6        CHECK FOR INDIRECT BIT
          MJK    NSI10       IF YES

*         ELSE PROCESS DIRECT
          LDN    1           SET NUMBER OF PAIRS
          STML   /TS/P.ILSTL,CTST
          AODL   P4          INCREMENT PP ADDRESS
          LDIL   P4          GET LENGTH/ADDRESS
          STML   /TS/P.ILSTP+1,CTST
          AODL   P4
          LDIL   P4
          STML   /TS/P.ILSTP+2,CTST
          AODL   P4
          LDIL   P4
          STML   /TS/P.ILSTP+3,CTST
          UJK    NSI20       EXIT
          SPACE  5,20
** NAME-- URECTC
*
** PURPOSE-- UPDATE RECORD TRANSFER COUNT
*
** INPUT-- (/TS/P.CBURBC,CTST) = CURRENT BURST BYTE COUNT
*          (/TS/P.RESBC,CTST)  = RESIDUAL BYTE COUNT
*          (/TS/P.SLVEES,CTST) = SLAVE ENCODED ENDING STATUS
*          (/TS/P.RTCIP,CTST)  = REC XFER COUNT BUFFER IN POINTER
*
** OUTPUT--(/TS/P.RTCB,CTST)+IN POINTER=UPDATED BY ACTUAL TRANSFER COUNT
*           A = 0  ALL DATA TRANSFERED
*               NZ RESIDUAL BYTE COUNT
          SPACE  2
 URECTC   SUBR               ENTRY/EXIT
          LDML   /TS/P.CBURBC,CTST  GET CURRENT BURST BYTE COUNT
          SBML   /TS/P.RESBC,CTST  DECREMENT BY RESIDUAL BYTE COUNT
          STDL   T1          SAVE IT
          LDML   /TS/P.SLVEES,CTST  CHECK FOR ODD OR EVEN TRANSFER
          LPN    0#F
          LMN    0#F
          NJN    URECTC2     IF EVEN TRANSFER
          SODL   T1          DECREMENT COUNT BY 1 ON ODD TRANSFERS

 URECTC2  LDK    /TS/P.RTCB  BUILD REC XFER COUNTER BUFFER ADDRESS
          ADDL   CTST
          ADML   /TS/P.RTCIP,CTST  ADJUST WITH IN POINTER
          STML   URECTCA     SAVE UPPER HALF ADDRESS
          ADN    1
          STML   URECTCB     SAVE LOWER HALF ADDRESS

          LDDL   T1          GET CURRENT TRANSFER COUNT
          RAML   *           UPDATE LOWER HALF
 URECTCB  EQU    *-1
          SHN    -16         ADJUST FOR CARRY BIT
          RAML   *           UPDATE UPPER HALF
 URECTCA  EQU    *-1

          LDML   /TS/P.RESBC,CTST  (A) = RESIDUAL BYTE COUNT
          UJN    URECTCX     EXIT
          SPACE  5,20
** NAME-- UREQTC
*
** PURPOSE-- UPDATE REQUEST TRANSFER COUNT
*
** INPUT-- (/TS/P.RTCB,CTST)+OUT POINTER = THIS RECORD XFER COUNT
*
** OUTPUT--(/TS/P.XFER,CTST) UPDATED BY RECORD TRANSFER COUNT
          SPACE  2
 UREQTC   SUBR               ENTRY/EXIT

          LDK    /TS/P.RTCB  BUILD RECORD XFER COUNT BUFFER ADDRESS
          ADDL   CTST
          ADML   /TS/P.RTCOP,CTST  ADJUST WITH OUT POINTER
          STML   UREQTCB     SAVE UPPER HALF ADDRESS
          ADN    1
          STML   UREQTCA     SAVE LOWER HALF ADDRESS

          LDML   *           GET RECORD XFER COUNT LOWER
 UREQTCA  EQU    *-1
          RAML   /TS/P.XFER+1,CTST  UPDATE REQUEST XFER COUNT LOWER
          SHN    -16         ADJUST FOR CARRY BIT
          ADML   *           ADD RECORD XFER COUNT UPPER
 UREQTCB  EQU    *-1
          RAML   /TS/P.XFER,CTST  UPDATE REQUEST XFER COUNT UPPER

          LDML   /TS/P.RTCOP,CTST  INCREMENT OUT POINTER
          ADN    2
          LPN    7
          STML   /TS/P.RTCOP,CTST

          UJN    UREQTCX     EXIT
          SPACE  5,30
** NAME-- GETNP
*
** PURPOSE-- GET NEXT LENGTH/ADDRESS PAIR
*
** INPUT-- (/TS/P.PARLAP,CTST) = PARTIAL L/A PAIR FLAG
*
** OUTPUT--(/TS/P.ILSTL,CTST) INDIRECT L/A PAIR LENGTH DECREMENTED
*          (/TS/P.ILSTA,CTST) INDIRECT L/A PAIR RMA UPDATED
*          (/TS/P.ILSTP,CTST) NEW INDIRECT L/A PAIR
*           A =  0 NO MORE L/A PAIRS
*               NZ VALID L/A PAIR
          SPACE  2
 GETNP    SUBR               ENTRY/EXIT
          LDML   /TS/P.PARLAP,CTST  CHECK FOR PARTIAL L/A PAIR
          NJN    GETNP10     IF YES
          SOML   /TS/P.ILSTL,CTST  DECREMENT NUMBER OF L/A PAIRS
          ZJN    GETNPX      EXIT IF NONE LEFT
          LDN    8           UPDATE L/A PAIR (UNFORMATTED) RMA
          RAML   /TS/P.ILSTA+1,CTST
          SHN    -16
          RAML   /TS/P.ILSTA,CTST
          LDK    /TS/P.ILSTP  BUILD CRML PP ADDRESS
          ADDL   CTST
          STML   GETNPA
          LOADF  /TS/P.ILSTA,CTST  SET R+A OF NEXT PAIR
          CRML   *,ONE       GET THE NEXT L/A PAIR
 GETNPA   EQU    *-1
          LDN    1           SET A = NZ
          UJN    GETNPX      EXIT

*         PROCESS PARTIAL L/A PAIR STILL ACTIVE
 GETNP10  STDL   T1          SAVE BYTES ALREADY USED FROM THIS PAIR
          LDML   /TS/P.ILSTP+1,CTST  DECREMENT L/A PAIR DATA LENGTH
          SBDL   T1
          STML   /TS/P.ILSTP+1,CTST
          LDDL   T1          INCREMENT L/A PAIR DATA (UNFORMATTED) RMA
          RAML   /TS/P.ILSTP+3,CTST
          SHN    -16
          RAML   /TS/P.ILSTP+2,CTST
          LDN    2           SET A = NZ
          UJK    GETNPX      EXIT
          SPACE  5,20
** NAME-- WSTN
*
** PURPOSE-- WAIT FOR SPECIAL TRANSFER NOTIFICATION
*
** NOTE -- THE SLAVE ONLY GENERATES A CLASS 2 RESPONSE
*          PACKET ON THE FIRST TRANSFER NOTIFICATION.
*
*          IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*          ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
*
** EXIT -- A =  0  SPECIAL CLASS 2 INTERRUPT ACTIVE
*            = NZ  CLASS 1 OR 3 INTERRUPT ACTIVE
*          WSTNF IS SET WITH (A) ON EXIT
          SPACE  2
 WSTN1    STML   /TS/P.WSTNF,CTST  SET WSTN FLAG WITH EXIT VALUE

 WSTN     SUBR               ENTRY/EXIT
          LDN    10          SECONDS LIMITS (INCLUDES ID RECOVERY)
          STML   /TS/P.SECLIM,CTST
          RJM    UC          UPDATE THE TIME CLOCK
          LDDL   CLSEC       SET CURRENT TIME IN SECONDS
          STML   /TS/P.CLK,CTST
          LDML   WSTN        SAVE RETURN ADDRESS
          STML   /TS/P.SWSTN,CTST

 WSTN10   RJM    SWITCH      SWITCH TO OTHER TS TABLES
          LDML   /TS/P.SWSTN,CTST  RESTORE RETURN ADDRESS
          STML   WSTN
          LDN    2           REQUEST CLASS 2 INTERRUPT
          RJM    RI          REQUEST INTERRUPTS
          ZJN    WSTN15      IF NOT
          LDN    0
          UJN    WSTN1       EXIT A = 0

 WSTN15   LDN    5           REQUEST CLASS 1 OR 3 INTERRUPTS
          RJM    RI          REQUEST INTERRUPTS
          ZJN    WSTN20      IF NONE ACTIVE
          LDN    1
          UJK    WSTN1       CLASS 1 OR 3 ACTIVE, EXIT A = NZ

 WSTN20   RJM    UC          UPDATE THE TIME CLOCK
          LDDL   CLSEC       GET CURRENT SECONDS
          SBML   /TS/P.CLK,CTST  ELAPSED SECONDS
          PJN    WSTN30      IF CLOCK HAS NOT WRAPPED
          ADK    0#10000

 WSTN30   SBML   /TS/P.SECLIM,CTST  CHECK IF TIME LIMIT EXPIRED
          MJK    WSTN10      IF NOT
          LDK    E38         NO SLAVE INTERRUPT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- SPLOCK
*
** PURPOSE-- SETS THE PP REQUEST QUEUE LOCK IN THE
*            PP INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                     NZ, IF LOCK WAS NOT SET.
          SPACE  2
 SPLOCK   SUBR               ENTRY/EXIT
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDK    /PIT/C.LOCK OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET THE LOCKWORD
          UJK    SPLOCKX
          SPACE  5,15
** NAME-- CPLOCK
*
** PURPOSE-- CLEARS THE PP REQUEST QUEUE LOCK IN THE
*            PP INTERFACE TABLE.
          SPACE  2
 CPLOCK   SUBR               ENTRY/EXIT
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDK    /PIT/C.LOCK OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CPLOCKX
          SPACE  5,15
** NAME-- SULOCK
*
** PURPOSE-- SETS UNIT LOCKWORD IN UNIT INTERFACE TABLE
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                     NZ, IF LOCK WAS NOT SET.
          SPACE  2
 SULOCK   SUBR               ENTRY/EXIT
          LDK    UNITS+/UN/P.UIT  BUILD ADDRESS OF UIT
          ADDL   UX          INCREMENT BY THE INDEX
          STDL   T7          CURRENT UNIT INTERFACE TABLE ADDRESS
          LDK    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          UJK    SULOCKX
          SPACE  5,15
** NAME-- CULOCK
*
** PURPOSE-- CLEARS UNIT LOCKWORD IN UNIT INTERFACE TABLE.
          SPACE  2
 CULOCK   SUBR               ENTRY/EXIT
          LDK    UNITS+/UN/P.UIT  BUILD ADDRESS OF UIT
          ADDL   UX          INCREMENT BY THE INDEX
          STDL   T7          CURRENT UNIT INTERFACE TABLE ADDRESS
          LDK    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CULOCKX
          SPACE  5,15
** NAME-- SQLOCK
*
** PURPOSE-- SETS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                     NZ, IF LOCK WAS NOT SET.
          SPACE  2
 SQLOCK   SUBR               ENTRY/EXIT
          LDK    UNITS+/UN/P.UIT  BUILD ADDRESS OF UIT
          ADDL   UX          INCREMENT BY THE INDEX
          STDL   T7          CURRENT UNIT INTERFACE TABLE ADDRESS
          LDK    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          UJK    SQLOCKX
          SPACE  5,15
** NAME-- CQLOCK
*
** PURPOSE-- CLEARS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
          SPACE  2
 CQLOCK   SUBR               ENTRY/EXIT
          LDK    UNITS+/UN/P.UIT  BUILD ADDRESS OF UIT
          ADDL   UX          INCREMENT BY THE INDEX
          STDL   T7          CURRENT UNIT INTERFACE TABLE ADDRESS
          LDK    /UIT/C.QLOCK OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CQLOCKX
          SPACE  5,15
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
*
** NOTE-- THIS ROUTINE WILL ONLY RETURN WHEN THE CHANNEL LOCK IS OBTAINED.
          SPACE  2
 SCLOCK   SUBR               ENTRY/EXIT

 SCL10    BSS
          LDK    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CURCH       CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    SCL10       IF LOCK WAS NOT SET
          STDL   CLF         CHANNEL LOCK FLAG = LOCKED NOW
          UJK    SCLOCKX     EXIT, LOCK WAS SET
          SPACE  5,15
** NAME-- CCLOCK
*
** PURPOSE-- CLEARS CHANNEL LOCK.
          SPACE  2
 CCLOCK   SUBR               ENTRY/EXIT
          LDDL   CLF         CHECK IF CHANNEL IS LOCKED
          NJN    CCLOCKX     IF NOT RETURN
          LDK    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          STDL   CLF         CHANNEL LOCK FLAG = NOT LOCKED
          LDDL   CURCH       CHANNEL NUMBER = OFFSET IN TABLE
          STDL   T5
          RJM    CLOCK       CLEAR CHANNEL LOCKWORD
          UJK    CCLOCKX     EXIT
          SPACE  5,30
** NAME-- LOCK
*
** PURPOSE-- SET A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS SET.
*         A REGISTER .NE. O, IF THE LOCK COULD NOT BE SET.
*
** USES-- T1-T7
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T1 = 0, WRITE THE PP LOCKWORD TO CENTRAL MEMORY,
*            AS DESCRIBED IN THIS STEP.  ELSE IF T1 .NE. 0, GO TO
*            STEP 4.
*            TO WRITE THE PP LOCKWORD ID:
*            SET T1 - T4 = 8000 0000 0000 PPNO, WHERE PPNO IS THE
*            LOGICAL PP NUMBER OF THIS PP.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
*
*         4. IF T1 = 8000 AND T4 = PPNO, THIS LOCKWORD WAS ALREADY
*            RESERVED TO THIS PP.
*            RESTORE THE CENTRAL MEMORY LOCATION  (CWDL   T1).
*            SET THE A REGISTER = 0, AND EXIT.
*
*         5. IF T4 .NE. PPNO, THEN THIS LOCKWORD IS RESERVED TO
*            A DIFFERENT PROCESSOR.
*            SET BIT 16 OF THE LOCKWORD THAT WAS READ WITH THE
*            RDSL INSTRUCTION, AND WRITE THE CONTENTS BACK TO
*            CENTRAL MEMORY.
*            THE PURPOSE OF SETTING BIT 16 IS TO REQUEST THE
*            OTHER PROCESSOR TO GIVE UP THE LOCKWORD.
*            LDDL   T2
*            LPC    77777B
*            ADC    100000B
*            STDL   T2
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
          SPACE  4
 LOCK     SUBR               ENTRY/EXIT

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 LOCK10   BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.

          LDDL   T1
          ADDL   T4
          ZJN    LOCK40      IF LOCK CAN BE SET

* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJK    LOCK10      IF THIS PP WAS NOT FIRST TO WRITE
*                            THE INTERMEDIATE VALUE, REPEAT RDSL INSTRUCTION

* SET BIT 16 IN THE ORIGINAL CONTENTS OF CENTRAL MEMORY AND
* WRITE IT BACK TO CENTRAL MEMORY.

          LDDL   T2          SET THE 'REQUEST LOCKWORD' FLAG
          LPC    77777B
          ADC    100000B
          STDL   T2
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE LOCKWORD

          LDDL   T4
          SBDL   PPNO        CHECK IF LOCK ALREADY SET
          NJN    LOCK30      IF LOCK COULD NOT BE SET, EXIT A .NE. 0
          LDDL   T1
          ADC    -100000B
 LOCK30   UJK    LOCKX       IF LOCK WAS ALREADY SET, EXIT A = 0
                             IF LOCK COULD NOT BE SET, EXIT A .NE. 0

* SET THE LOCKWORD.

 LOCK40   BSS
          LDC    100000B
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          LDDL   PPNO
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          SET THE LOCKWORD
          LDN    0
          UJK    LOCK30      EXIT, A REGISTER = 0
          SPACE  5,20
** NAME-- CLOCK
*
** PURPOSE-- CLEAR A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS CLEARED.
*         A REGISTER .NE. O, IF THE LOCK WAS NOT CLEARED.
*
** USES-- T1-T7
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T4 .NE. PPNO, THIS LOCKWORD IS RESERVED TO A
*            DIFFERENT PROCESSOR.
*            RESTORE THE CONTENTS OF THIS CENTRAL MEMORY LOCATION
*            AS IT EXISTED BEFORE THE VALUE FFFF FFFF XXXX XXXX
*            WAS WRITTEN.
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
*
*         4. IF T4 = PPNO, THEN CLEAR THE LOCKWORD IN CENTRAL MEMORY.
*            SET T1 - T4 = 0000 0000 0000 0000.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
          SPACE  4
 CLOCK    SUBR               ENTRY/EXIT

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 CLK10    BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.
* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJK    CLK10       IF THIS PP WAS NOT FIRST TO WRITE
*                            THE INTERMEDIATE VALUE, REPEAT RSDL INSTRUCTION

          LDDL   T4          CHECK PP NUMBER
          SBDL   PPNO
          ZJN    CLK30       IF THIS PP HAS THE LOCK SET

* RESTORE THE ORIGINAL CONTENTS.

          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE ORIGINAL CONTENTS
          LDN    1
 CLK20    UJK    CLOCKX      EXIT, A REGISTER NONZERO

* CLEAR THE LOCKWORD.

 CLK30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          CLEAR THE LOCKWORD
          LDN    0
          UJK    CLK20       EXIT, A REGISTER = 0
          SPACE  5,20
** NAME-- SWFAIL
*
** PURPOSE-- REPORT A SOFTWARE FAILURE AND TERMINATE A REQUEST.
*
** ENTRY-- A REGISTER HAS INTERFACE ERROR CODE
*
** EXIT-- TO MAIN IDLE LOOP.
          SPACE  2
 SWFAIL   BSSZ   1           ENTRY ONLY  NO RETURN
          STDL   T7          SAVE ERRID VALUE
          LDN    0           NO IPI STATUS IN RESPONSE
          STML   RPB
          RJM    PAR         PREPARE ABNORMAL RESPONSE
          LDDL   T7
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LDK    /RS/K.INTERR  INTERFACE ERROR
          STML   RS+/RS/P.INTERR
          LDK    E120        SOFTWARE FAILURE
          STML   RS+/RS/P.ERRID
          RJM    CMDTERM     COMMAND TERMINATE  (NO RETURN)
          SPACE  5,20
** NAME-- SETSX
*
** PURPOSE-- SET SLAVE TABLE INDEX
*
** INPUT--SLVN CONTAINS CURRENT SLAVE ADDRESS
*          0X = PORT A  SLAVE X
*          1X = PORT B  SLAVE X
*
** OUTPUT-- SX SET
*           A = FACILITIES CONFIGURED ON THIS SLAVE
          SPACE  3
 SETSX    SUBR               ENTRY/EXIT
          LDDL   SLVN        GET SLAVE NUMBER
          SHN    2           POSITION IT
          STDL   SX          SET IT
          LDML   SLB+/SL/P.FBA,SX  GET CONFIGURED FACILITIES ON THIS SLAVE
          UJK    SETSXX      EXIT
          SPACE  2
          ERRNZ  4-P.SL      IF SL CHANGES
          SPACE  5,20
** NAME-- SETUX
*
** PURPOSE-- SET UNITS TABLE INDEX
*
** INPUT--FACN CONTAINS CURRENT FACILITY ADDRESS
*         SX MUST ALREADY BE SET
*
** OUTPUT--UX SET
*          A = LOGICIAL UNIT NUMBER
          SPACE  2
 SETUX    SUBR               ENTRY/EXIT
          LDDL   SX          START WITH SLAVE OFFSET
          SHN    -2
          ADDL   SX
          SHN    3           REPOSITION IT
          STDL   UX
          LDDL   FACN        GET FACILITY NUMBER
          SHN    2           POSITION IT
          RADL   UX          SAVE IT
          LDDL   FACN
          RADL   UX          MERGE FINAL
          LDML   UNITS+/UN/P.LU,UX  GET LOGICIAL UNIT NUMBER
          UJK    SETUXX      EXIT
          SPACE  2
          ERRNZ  5-P.UN      IF UN CHANGES
          ERRNZ  40-FACPSL*P.UN  IF MAX FACILITIES PER SLAVE IS NOT 8
          SPACE  5,20
** NAME-- INITNR
*
** PURPOSE-- INITIALIZE NEW UNIT REQUEST
*
** INPUT--NREQSN = NEW SLAVE NUMBER
*         NREQFN = NEW FACILITY NUMBER
*         CTST   = NEW TS TABLE INDEX
          SPACE  2
 INITNR   SUBR               ENTRY/EXIT
          LDN    0           CLEAR ASYNCHRONUS PROCESSING FLAG
          STDL   ASYNCP
          STML   RPB         CLEAR IPI RESPONSE PACKET BUFFER
          LDML   NREQSN      INIT SLVN
          STDL   SLVN
          RJM    SETSX       INIT SX INDEX
          LDML   NREQFN      INIT FACN
          STDL   FACN
          RJM    SETUX       INIT UX INDEX
          LDC    UNITS+/UN/P.UIT  BUILD POINTER TO UIT REFORMATTED RMA
          ADDL   UX
          STDL   T7          T7 = POINTER TO UIT RMA
          RJM    LDTS        LOAD REQUEST AND UNLOCK IT
          LDDL   CTST        CHECK WHICH TS TO USE
          SBML   TS2
          NJN    INITNR1     IF NOT TS2
          LDDL   TIU         SET TS2 BIT IN TS TABLES IN USE
          LPN    75B
          ADN    2
          UJN    INITNR9     CONT.
 INITNR1  BSS
          LDDL   TIU         SET TS3 BIT IN TS TABLES IN USE
          LPN    73B
          ADN    4
 INITNR9  BSS
          STDL   TIU         SAVE UPDATED TS TABLES IN USE
          RJM    INTS        INIT TS TABLE
          RJM    PS          PORT SELECT
          UJK    INITNRX     EXIT
          SPACE  5,20
** NAME-- CLREQ
*
** PURPOSE-- CLEAR THE CURRENT REQUEST FROM THE ACTIVE TS TABLE
*            AND UNLOCK UNIT LOCKWORD.
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 CLREQ1   LDML   /TS/P.SCLREQ,CTST  RESTORE RETURN ADDRESS
          STML   CLREQ
          RJM    CLRTS       CLEAR TS TABLE

 CLREQ    SUBR               ENTRY/EXIT
          LDML   CLREQ       SAVE RETURN ADDRESS
          STML   /TS/P.SCLREQ,CTST
          LDDL   CTST        CLR TS TABLE IN USE BIT
          SBML   TS1
          ZJN    CLREQ10     IF PP TABLE IN USE
          ADK    -P.TS
          ZJN    CLREQ20     IF TS2 IN USE
          UJN    CLREQ30     IF TS3 IN USE
 CLREQ10  BSS
          LDN    0
          STDL   TIU         CLEAR ALL TS TABLES IN USE
          STDL   ASYNCP      CLEAR ASYNCHRONUS PROCESSING FLAG
          UJN    CLREQ1      EXIT
 CLREQ20  BSS
          RJM    CFC         CHECK FOR CHAINING STILL
          LDDL   TIU         CLEAR TS2 IN USE
          LPN    75B
          UJN    CLREQ90     CONT.
 CLREQ30  BSS
          RJM    CFC         CHECK FOR CHAINING STILL
          LDDL   TIU         CLEAR TS3 IN USE
          LPN    73B
 CLREQ90  BSS
          STDL   TIU         RESTORE TIU
          RJM    CULOCK      UNLOCK UNIT LOCKWORD IN UIT
          LDN    0
          STDL   ASYNCP      CLEAR ASYNCHRONUS PROCESSING FLAG
          STML   RPB         CLR ACTIVE IPI RESPONSE LENGTH
          STML   SLB+/SL/P.SIU,SX  CLR SLAVE IN USE FLAG
          LDML   SLB+/SL/P.FACLCK,SX  CLEAR FACILITY LOCKED FLAG
          LPN    77B
          STML   SLB+/SL/P.FACLCK,SX
          UJK    CLREQ1      EXIT
          SPACE  2
          ERRNZ  2-MCSLV     IF NUMBER OF CONCURRENT SLAVE TS TABLES CHANGE
          SPACE  5,20
** NAME-- SAVETAB
*
** PURPOSE-- SAVE THE CURRENT TS TABLE FOR USE LATER
*
** INPUT--CTST = CURRENT TS TABLE IN USE
          SPACE  2
 SAVETAB  SUBR               ENTRY/EXIT
          LDK    /TS/P.SAVEDC  BUILD DESTINATAION ADDRESS
          ADDL   CTST
          STML   SAVTA
          LDN    0           INIT LOOP COUNTER
          STDL   T1

 SAVT10   LDML   SAVEFWA,T1  GET DIRECT CELL TO SAVE
          STML   *,T1        SAVE IT
 SAVTA    EQU    *-1
          AODL   T1
          SBN    SAVELWA+1-SAVEFWA  CHECK FOR DONE
          NJN    SAVT10      IF NOT, LOOP
          UJN    SAVETABX    ELSE EXIT
          SPACE  5,20
** NAME-- RELDTAB
*
** PURPOSE-- RELOAD A SAVED TS TABLE FOR USE NOW
*
** INPUT--CTST = TS TABLE TO RELOAD
          SPACE  2
 RELDTAB  SUBR               ENTRY/EXIT
          LDK    /TS/P.SAVEDC  BUILD SOURCE ADDRESS
          ADDL   CTST
          STML   RELDTA
          LDN    0           INIT LOOP COUNTER
          STDL   T1

 RELDT10  LDML   *,T1        GET SAVED DIRECT CELL
 RELDTA   EQU    *-1
          STML   SAVEFWA,T1  PUT IT BACK IN DIRECT CELL
          AODL   T1          CHECK FOR DONE
          SBN    SAVELWA+1-SAVEFWA
          NJN    RELDT10     IF NOT, LOOP
          UJN    RELDTABX    ELSE, EXIT
          SPACE  5,20
** NAME-- INTS
*
** PURPOSE-- INITIALIZE TS TABLE
*
** INPUT-- CTST,SLVN AND FACN INITIALIZED
*
          SPACE  2
 INTS     SUBR               ENTRY/EXIT
          LDDL   SLVN        SET SLAVE NUMBER
          LPN    SLVPCH-1    MASK OFF PORT BIT
          SHN    8
          STML   /TS/P.SN,CTST
          LDDL   FACN        SET FACILITY NUMBER
          RAML   /TS/P.FN,CTST
          UJK    INTSX       EXIT
          SPACE  5,20
** NAME-- CLRTS
*
** PURPOSE-- CLEAR THE SELECTED TS TABLE
*
** INPUT-- CTST INITIALIZED
          SPACE  2
 CLRTS    SUBR               ENTRY/EXIT
          LDK    /TS/P.SAVEDC  NUMBER OF WORDS TO CLEAR
          STDL   T1
          LDDL   CTST        TS TABLE FWA
          STDL   T2

 CLRTS10  LDN    0           CLEAR TS TABLE ENTRY
          STIL   T2
          AODL   T2          INCREMENT ADDRESS
          SODL   T1          DECREMENT COUNTER
          NJN    CLRTS10     LOOP IF NOT DONE
          STML   /TS/P.RQB+/RQ/P.LU,CTST  CLEAR LOGICIAL UNIT NUMBER
          UJN    CLRTSX      EXIT
          SPACE  5,20
** NAME-- CLRPTS
*
** PURPOSE-- CLEAR PARTIAL TS TABLE
*
** INPUT-- CTST INITIALIZED
          SPACE  2
 CLRPTS   SUBR               ENTRY/EXIT
          LDN    0           CLEAR SELECTED TS TABLE ENTRIES
          STIL   CTST
          STML   /TS/P.LASTC,CTST
          STML   /TS/P.XFER,CTST
          STML   /TS/P.XFER+1,CTST
          STML   /TS/P.SCOND,CTST
          STML   /TS/P.FACSTA,CTST
          STML   /TS/P.NSWC,CTST
          STML   /TS/P.NSRC,CTST
          STML   /TS/P.OTFC,CTST
          STML   /TS/P.BIDBP,CTST
          STML   /TS/P.RTCIP,CTST
          STML   /TS/P.RTCOP,CTST
          UJN    CLRPTSX     EXIT
          SPACE  5,20
** NAME-- LDTS
*
** PURPOSE-- LOAD TS TABLE WITH CURRENT REQUEST, INITIALIZE TS TABLE
*            ENTRIES AND UPDATE PIT/UIT NEXT PVA-RMA AND UNLOCK QUEUE.
*
** INPUT--T7 = ADDRESS OF REFORMATTED CM ADDRESS OF EITHER PIT OR UIT.
*
          SPACE  2
 LDTS     SUBR               ENTRY/EXIT
*         GET THE PVA/RMA OF THE REQUEST
          LDDL   CTST        BUILD CRML ADDRESS
          ADK    /TS/P.CPVACM
          STML   LDTSA
          LOADR  0,T7        LOAD R AND A OF PIT OR UIT
          ADK    /PIT/C.PPQPVA  OFFSET TO REQUEST PVA/RMA
          CRML   *,TWO       READ THE PVA/RMA OF THE QUEUED REQUEST
                             INTO SELECTED TS TABLE LOCATION CPVACM
 LDTSA    EQU    *-1
*         GET THE REQUEST HEADER
          LDDL   CTST        BUILD CRML/CWML ADDRESSES
          ADK    /TS/P.RQB
          STML   LDTSB
          STML   LDTSC
          ADK    /TS/P.CQB-/TS/P.RQB  ANOTHER CRML ADDRESS
          STML   LDTSD
          LDK    /RQ/C.SECADR+1  LENGTH OF REQUEST HEADER
          STDL   WC
          LOADF  /TS/P.CREQ,CTST  LOAD R AND A OF REQUEST
          CRML   *,WC        READ THE REQUEST HEADER
                             INTO SELECTED TS TABLE LOCATIONS RQB
 LDTSB    EQU    *-1
*         UPDATE THE NEXT PVA/RMA
          LOADR  0,T7        LOAD R AND A OF PIT OR UIT
          ADK    /PIT/C.PPQPVA  OFFSET TO NEXT PVA/RMA
          CWML   *,TWO       RESET TO NEXT PVA/RMA IN PIT OR UIT
 LDTSC    EQU    *-1
*         CLEAR THE UIT/PIT QUEUE LOCKWORD
          LDK    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE PIT/UIT LOCKWORD
*         GET THE REQUEST COMMANDS
          LDML   /TS/P.RQB+/RQ/P.LEN,CTST  REQUEST LENGTH IN BYTES
          SHN    -3          TO CM WORDS
          SBN    /RQ/C.SECADR+1  DECREMENT BY HEADER LENGTH
          ZJN    *           IF NO COMMANDS
          STML   /TS/P.NUMCM,CTST  SAVE NUMBER OF COMMANDS
          STDL   WC
          LOADF  /TS/P.CREQ,CTST  LOAD R AND A OF REQUEST
          ADK    /RQ/C.SECADR+1  OFFSET TO COMMANDS
          CRML   *,WC        READ COMMANDS
                             INTO SELECTED TS TABLE LOCATIONS CQB
 LDTSD    EQU    *-1
          UJK    LDTSX       EXIT
          SPACE  5,20
** NAME-- PTW
*
** PURPOSE-- PATH TEST WRITING
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 PTW1     LDML   /TS/P.SPTW,CTST  RESTORE RETURN ADDRESS
          STML   PTW

 PTW      SUBR               ENTRY/EXIT
          LDML   PTW         SAVE RETURN ADDRESS
          STML   /TS/P.SPTW,CTST
          RJM    GDP         GENERATE DATA PATTERN
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PTWCP1
          LDDL   SLVN        BUILD ADDRESSEE
          LPN    SLVPCH-1    MASK OFF PORT BIT
          SHN    8
          ADDL   FF          NO FACILITY ADDRESS
          STML   PTWCP5
          LDN    0           USE BUFFER 0 FIRST
          STML   PTWCPD
          RJM    PTWOD       OUTPUT TO FIRST DATA BUFFER
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PTWCP1
          LDN    1           USE BUFFER 1 NOW
          STML   PTWCPD
          RJM    PTWOD       OUTPUT TO SECOND DATA BUFFER
          UJK    PTW1        EXIT OK
          SPACE  5,20
*         -WRITE TO BUFFER-  COMMAND PACKET
 PTWCP    DATA   0#0014      PACKET LENGTH
 PTWCP1   DATA   0#FFFF      CMD REFERENCE NUMBER
          CON    OCWTB+CMCHN  OP-CODE AND CHAIN
 PTWCP5   DATA   0#00FF      ADDRESSEE
          CON    CPBCE       CMD EXTENT PARAM
          DATA   0#0000       COUNT
          DATA   0#1020       COUNT = 4128(DEC) BYTES
 PTWCPD   DATA   0#0000       DATA ADDRESS = BUFFER 0
          DATA   0#0000       DATA ADDRESS = 0
          CON    CPBA        BUFFER ADDRESS PARAM
          DATA   0#8020       GENERIC, SLAVE DATA BUFFER
          SPACE  5,20
** NAME-- PTWOD
*
** PURPOSE-- PATH TEST WRITE OUTPUT DATA
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 PTWO1    LDML   /TS/P.SPTWOD,CTST  RESTORE RETURN ADDRESS
          STML   PTWOD

 PTWOD    SUBR               ENTRY/EXIT
          LDML   PTWOD       SAVE RETURN ADDRESS
          STML   /TS/P.SPTWOD,CTST
          LDC    PTWCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PTWO10   LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16       CHECK FOR TRANSFER NOTIFICATION
          ZJN    PTWO20      IF YES
          LDML   RPB+MAJST   CHECK FOR ASYNC
          SHN    -4
          LPN    0#F
          LMK    AR
          ZJN    PTWO10      IF YES
          UJK    PTWO50      ELSE REPORT ERROR (E00)
 PTWO20   LDIL   CTST        CHECK IF CMD REFERENCE NUMBERS AGREE
          LMML   RPB+CRN
          NJK    PTWO60      IF NOT, REPORT ERROR (E76)
          RJM    SEL         SELECT SLAVE
          LDN    DATAOUT     BUS A FOR DATA OUT
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0381       STREAM, WRITE
          RJM    FUNC
          LDC    4128/2      SET WORD COUNT
          STDL   WC
          LDML   CM.CB.T+1   BUILD SPECIAL INDIRECT LIST PAIR
          STML   /TS/P.ILSTP+2,CTST
          LDML   CM.CB.T+2
          STML   /TS/P.ILSTP+3,CTST
          RJM    DDO         DMA DATA OUTPUT
          RJM    WFTC        WAIT FOR TRANSFER COMPLETE
          LDN    EVENOT      EVEN OCTET MASTER ENCODED ENDING STATUS
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT SLAVE
          UJN    PTWO90      CONTINUE

 PTWO50   LDN    E00         CP MUST DETERMINE ERROR
          UJN    PTWO80

 PTWO60   LDK    E76         UNEXPECTED RESPONSE

 PTWO80   RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)

 PTWO90   LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR SUCCESSFUL
          ZJK    PTWO1       IF YES, EXIT OK
          LDML   RPB+MAJST   CHECK FOR ASYNC
          SHN    -4
          LPN    0#F
          LMK    AR
          ZJN    PTWO90      IF YES
          UJN    PTWO50      ELSE REPORT ERROR (E00)
          SPACE  5,20
** NAME-- PTR
*
** PURPOSE-- PATH TEST READING
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 PTR1     LDML   /TS/P.SPTR,CTST  RESTORE RETURN ADDRESS
          STML   PTR

 PTR      SUBR               ENTRY/EXIT
          LDML   PTR         SAVE RETURN ADDRESS
          STML   /TS/P.SPTR,CTST
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PTRCP1
          LDC    OCRFB+CMCHN  OP-CODE AND CHAIN
          STML   PTRCP3
          LDDL   SLVN        BUILD ADDRESSEE
          LPN    SLVPCH-1    MASK OFF PORT BIT
          SHN    8
          ADDL   FF          NO FACILITY
          STML   PTRCP5
          LDN    0           USE BUFFER 0 FIRST
          STML   PTRCPD
          RJM    PTRID       INPUT FIRST BUFFER
          RJM    VDP         VERIFY DATA PATTERN
          NJN    PTR10       IF DATA ERROR
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PTRCP1
          LDC    OCRFB       OP-CODE AND END OF CHAIN
          STML   PTRCP3
          LDN    1           USE BUFFER 1
          STML   PTRCPD
          RJM    PTRID       INPUT SECOND BUFFER
          RJM    VDP         VERIFY DATA PATTERN
          ZJK    PTR1        IF OK, EXIT
 PTR10    LDK    E110        MASTER-SLAVE DATA INTEGRITY ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING  (NO RETURN)
          SPACE  5,12
*         -READ FROM BUFFER-  COMMAND PACKET
 PTRCP    DATA   0#0014      PACKET LENGTH
 PTRCP1   DATA   0#FFFF      CMD REFERENCE NUMBER
 PTRCP3   CON    OCRFB+CMCHN  OP-CODE AND CHAIN
 PTRCP5   DATA   0#00FF      ADDRESSEE
          CON    CPBCE       CMD EXTENT PARAM
          DATA   0#0000       COUNT
          DATA   0#1020       COUNT = 4128(DEC) BYTES
 PTRCPD   DATA   0#0000       DATA ADDRESS = BUFFER 0
          DATA   0#0000       DATA ADDRESS = 0
          CON    CPBA        BUFFER ADDRESS PARAM
          DATA   0#8020       GENERIC, SLAVE DATA BUFFER
          SPACE  5,20
** NAME-- PTRID
*
** PURPOSE-- PATH TEST READ INPUT DATA
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 PTRI1    LDML   /TS/P.SPTRID,CTST  RESTORE RETURN ADDRESS
          STML   PTRID

 PTRID    SUBR               ENTRY/EXIT
          LDML   PTRID       SAVE RETURN ADDRESS
          STML   /TS/P.SPTRID,CTST
          LDC    PTRCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 PTRI10   LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16       CHECK FOR TRANSFER NOTIFICATION
          ZJN    PTRI20      IF YES
          LDML   RPB+MAJST   CHECK FOR ASYNC
          SHN    -4
          LPN    0#F
          LMK    AR
          ZJN    PTRI10      IF YES
          UJK    PTRI50      ELSE, REPORT ERROR (E00)
 PTRI20   LDIL   CTST        COMPARE COMMAND REFERENCE NUMBERS
          LMML   RPB+CRN
          NJK    PTRI60      IF NOT THE SAME
          RJM    SEL         SELECT SLAVE
          LDN    DATAIN      BUS A FOR DATA IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0281       STREAM AND READ
          RJM    FUNC
          LDC    4128/2      SET WORD COUNT
          STDL   WC
          LDML   CM.CB.T+1   BUILD SPECIAL INDIRECT LIST PAIR
          STML   /TS/P.ILSTP+2,CTST
          LDML   CM.CB.T+2
          STML   /TS/P.ILSTP+3,CTST
          RJM    DDI         DMA DATA INPUT
          RJM    WFTC        WAIT FOR TRANSFER COMPLETE
          LDN    EVENOT      USE EVEN OCTET MASTER ENCODED ENDING STATUS
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT SLAVE
          LDDL   STATUS      CHECK SLAVE ENCODED ENDING STATUS
          LPN    0#F
          NJN    PTRI80      IF NOT EVEN
          UJN    PTRI100     CONTINUE
 PTRI50   LDN    E00         CP MUST DETERMINE ERROR
          UJN    PTRI90
 PTRI60   LDK    E76         UNEXPECTED STATUS
          UJN    PTRI90
 PTRI80   LDN    E40         SLAVE ENCODED ENDING STATUS ERROR
 PTRI90   RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING  (NO RETURN)

 PTRI100  LDN    1           SECONDS LIMIT
          RJM    IH          GET COMMAND COMPLETION
          LMN    CCS         CHECK FOR SUCCESSFUL
          ZJK    PTRI1       IF YES, EXIT
          LDML   RPB+MAJST   CHECK FOR ASYNC
          SHN    -4
          LPN    0#F
          LMK    AR
          ZJN    PTRI100     IF YES
          UJN    PTRI50      ELSE, REPORT ERROR (E00)
          SPACE  5,20
** NAME-- GDP
*
** PURPOSE-- GENERATE DATA PATTERN IN CM PP COMMUNICATIONS BUFFER
*
** USES-- T1-T4 = DATA
*         T8 = COUNTER
*         P5 = RMA OFFSET
          SPACE  2
 GDP      SUBR               ENTRY/EXIT
          LDK    /CB/C.PTD   INITIALIZE OFFSET TO PATH TEST DATA AREA
          STDL   P5
          LDK    516         CM WORD COUNT = 4128 DEC. BYTES
          STDL   T8

* BUILD CM DATA PATTERN IN T1-T4 = FFFF 0000 AAAA 5555
          LCN    0           FFFF
          STDL   T1
          LDN    0           0000
          STDL   T2
          LDC    0#AAAA      AAAA
          STDL   T3
          SHN    -1          5555
          STDL   T4

* STORE DATA PATTERN IN CM
 GDP10    LOADC  CM.COM      LOAD R+A OF COMMUNICATIONS BUFFER
          ADDL   P5          INCLUDE OFFSET TO TEST DATA AREA
          CWDL   T1          WRITE THE PATTERN
          AODL   P5          INCREMENT THE OFFSET
          SODL   T8          CHECK FOR DONE
          NJN    GDP10       IF NOT LOOP

          UJK    GDPX        EXIT
          SPACE  5,20
** NAME-- VDP
*
** PURPOSE-- VERIFY DATA PATTERN
*
** EXIT-- A = 0  NO ERROR
*             NZ DATA MISCOMPARE ERROR
*
** USES-- T1-T4 = DATA
*         T5-T7 = EXPECTED VALUES
*         T8 = COUNTER
*         P5 = RMA OFFSET
          SPACE  2
 VDP      SUBR               ENTRY/EXIT
          LDK    /CB/C.PTD   INITIALIZE OFFSET TO PATH TEST DATA
          STDL   P5
          LDK    516         CM WORD COUNT = 4128 BYTES
          STDL   T8

* INITIALIZE EXPECTED VALUES
          LCN    0           FFFF
          STDL   T5
*                            0000 CHECKED DIRECTLY
          LDC    0#AAAA      AAAA
          STDL   T6
          SHN    -1          5555
          STDL   T7

* GET A CM WORD
 VDP10    LOADC  CM.COM      LOAD R+A OF COMMUNICATIONS BUFFER
          ADDL   P5          INCLUDE OFFSET
          CRDL   T1          READ THE CM WORD
          AODL   P5          INCREMENT RMA OFFSET

* CHECK THE DATA PATTERN
          LDDL   T1          FFFF
          LMDL   T5
          NJN    VDP20       IF ERROR
          LDDL   T2          0000
          NJN    VDP20       IF ERROR
          LDDL   T3          AAAA
          LMDL   T6
          NJN    VDP20       IF ERROR
          LDDL   T4          5555
          LMDL   T7
          NJN    VDP20

          SODL   T8          CHECK FOR DONE
          NJN    VDP10       IF NOT LOOP

 VDP20    UJK    VDPX        EXIT A=0 OK, NZ=ERROR
          SPACE  5,20
** NAME-- RERESP
*
** PURPOSE-- PROCESS RESUME RESPONSE
*
          SPACE  2
 RERESP   SUBR               ENTRY/EXIT
          LDN    0           NO IPI STATUS IN RESPONSE
          STML   RPB
          RJM    PNR         PREPARE NORMAL RESPONSE
          RJM    RESP        SEND RESPONSE
          UJN    RERESPX     EXIT
          SPACE  4,20
** NAME-- PNR
*
** PURPOSE-- PREPARE NORMAL RESPONSE
          SPACE  2
 PNR      SUBR               ENTRY/EXIT
          RJM    BBR         BUILD BASIC RESPONSE
          RJM    MVBID       MOVE BLOCK ID BUFFER TO RESPONSE
          LDK    R.NRM       NORMAL RESPONSE
          STML   RS+/RS/P.RC
          UJK    PNRX        EXIT
          SPACE  4,20
** NAME-- PAR
*
** PURPOSE-- PREPARE ABNORMAL RESPONSE
          SPACE  2
 PAR      SUBR               ENTRY/EXIT
          RJM    BBR         BUILD BASIC RESPONSE
          RJM    MVBID       MOVE BLOCK ID BUFFER TO RESPONSE
          LDK    R.ABN       ABNORMAL RESPONSE
          STML   RS+/RS/P.RC
          UJK    PARX        EXIT
          SPACE  4,10
** NAME-- PUR
*
** PURPOSE-- PREPARE UNSOLICITED RESPONSE
          SPACE  2
 PUR      SUBR               ENTRY/EXIT
          RJM    BBR         BUILD BASIC RESPONSE
          LDK    R.UNS       UNSOLICITED RESPONSE CODE
          STML   RS+/RS/P.RC
          UJK    PURX        EXIT
          SPACE  5,30
** NAME-- BBR
*
** PURPOSE-- BUILD BASIC RESPONSE

 BBR      SUBR               ENTRY/EXIT
          LDN    C.RS-/RS/C.ABALRT  ZERO OUT MOST OF RESPONSE BUFFER
          STDL   T5          NUMBER OF CM ZERO WORDS TO USE
          LOADC  CM.COM      USE PP COMMUNICIATIONS BUFFER
          ADN    /CB/C.ZEROES  START FORM CLEARED AREA
          CRML   RS+/RS/P.ABALRT,T5  CLEAR FROM C.ABALRT TO THE END

          LDML   /TS/P.CPVA,CTST   PVA OF REQUEST
          STML   RS+/RS/P.PVA
          LDML   /TS/P.CPVA+1,CTST
          STML   RS+/RS/P.PVA+1
          LDML   /TS/P.CPVA+2,CTST
          STML   RS+/RS/P.PVA+2

          LDML   /TS/P.CREQ,CTST  RMA OF REQUEST
          STML   RS+/RS/P.REQ
          LDML   /TS/P.CREQ+1,CTST
          STML   RS+/RS/P.REQ+1

          LDK    NRL         NORMAL RESPONSE LENGTH IN BYTES
          STML   RS+/RS/P.RESPL
          LDML   RPB         CHECK IF IPI RESPONSE IS TO BE INCLUDED
          LPC    377B        INSURE VALID LENGTH
          ZJN    BBR10       IF NOT
          ADN    9           INCREMENT FOR PACKET LENGTH BYTES AND
*                            TO ROUND UP TO CM WORD BOUNDARY
          LPK    -7
          RAML   RS+/RS/P.RESPL  INCREMENT RESPONSE LENGTH
 BBR10    LDML   /TS/P.RQB+/RQ/P.LU,CTST  LOGICIAL UNIT NUMBER
          STML   RS+/RS/P.LU

          LDML   /TS/P.RQB+/RQ/P.RECOV,CTST  R/I AND PRIORITY
          STML   RS+/RS/P.RECOV

          LDML   /TS/P.RQB+/RQ/P.LONGB,CTST   ALERT MASK
          STML   RS+/RS/P.LONGB

          LDML   /TS/P.XFER,CTST   BYTES TRANSFERRED
          STML   RS+/RS/P.XFER
          LDML   /TS/P.XFER+1,CTST
          STML   RS+/RS/P.XFER+1

          LDML   /TS/P.CREQ,CTST  CHECK IF A REQUEST IS LOADED
          ADML   /TS/P.CREQ+1,CTST
          ZJK    BBRX        IF NOT BYPASS LAST CMD RMA
          LDML   /TS/P.CREQ+1,CTST  BUILD RMA OF LAST COMMAND
          ADN    B.RQ        OFFSET TO FIRST COMMAND
          ADML   /TS/P.LASTC,CTST
          STML   RS+/RS/P.LASTC+1  2ND HALF RMA
          SHN    -16
          ADML   /TS/P.CREQ,CTST
          STML   RS+/RS/P.LASTC    1ST HALF RMA

          LDML   /TS/P.FACSTA,CTST  MOVE FACILITY STATUS ID52, IF ANY
          ZJK    BBRX        IF NONE, EXIT
          STML   RS+/RS/P.FACSTA
          LDML   /TS/P.FACSTA+1,CTST
          STML   RS+/RS/P.FACSTA+1

          UJK    BBRX        EXIT
* ENSURE THAT THE NUMBER OF ZERO BYTES IN THE PP COMMUNIAATION BUFFER
* IS ENOUGH TO CLEAR THE RESPONSE BUFFER.
          ERRNG  /CB/B.ZEROES-B.RS+/RS/P.ABALRT*2
          SPACE  5,30
** NAME-- MVBID
*
** PURPOSE-- MOVE BLOCK ID FROM TS TABLE TO RESPONSE BUFFER.
*
          SPACE  4
 MVBID    SUBR               ENTRY/EXIT
          LDML   /TS/P.BIDBP,CTST  GET THE POINTER
          ZJN    MVBIDX      IF NONE TO MOVE
          STML   RS+/RS/P.IOR+MBID+1  PUT POINTER IN RESPONSE
          STDL   T1          COUNT TO MOVE
          LDML   /TS/P.OTFC,CTST  GET ON-THE-FLY CORRECTION COUNT
          STML   RS+/RS/P.IOR+MBID  PUT IN RESPONSE
          LDK    /TS/P.BIDB  BUILD SOURCE ADDRESS
          ADDL   CTST
          STDL   T2          T2 HAS SOURCE ADDRESS
          LDK    RS+/RS/P.IOR
          STDL   T3          T3 IS DESTINATION ADDRESS

 MVBID10  LDIL   T2          GET BLOCK ID ENTRY
          STIL   T3          PUT IT INTO RESPONSE
          SODL   T1          DECREMENT COUNT
          ZJN    MVBIDX      IF DONE EXIT
          AODL   T2          INCREMENT SOURCE ADDRESS
          AODL   T3          INCREMENT DESTINATION ADDRESS
          UJN    MVBID10     LOOP
          SPACE  2
          ERRNZ  30-MBID     IF MAX NUMBER OF BLOCK ID CHANGE
          SPACE  5,30
** NAME-- RESP
*
** PURPOSE-- WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
*
** INPUT-- CM.PIT, CM.RS, LIM, /PIT/IN, /PIT/OUT, RS+/RS/P.RESPL
*
** OUTPUT-- /PIT/IN, RESPONSE BUFFER
          SPACE  2
 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  2
 RESP     SUBR               ENTRY/EXIT

* READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RESP10   LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADK    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ  OUT  POINTER INTO P5
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF  IN  POINTER
          CRDL   P1          READ  IN  POINTER INTO P4

* CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDDL   INP
          SBDL   OUTP
          MJN    RESP20      IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP

 RESP20   LDML   RS+/RS/P.RESPL  GET RESPONSE LENGTH
          STDL   T1
          LDN    0
          STDL   T2          FLAG TO DETERMINE IF 1 OR 2 BLOCK WRITES
          LDDL   INP
          RADL   T1          IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          PJK    RESP10      IN NOT ENOUGH ROOM IN BUFFER, LOOP
          LDDL   T1
          SBDL   LIM
          MJN    RESP40      IF IN + RESPONSE LENGTH .LT. LIMIT
          STDL   T1          IN + RESPONSE LENGTH - LIMIT = NEW  IN  POINTER
          AODL   T2          2 BLOCK WRITES REQUIRED

* WRITE RESPONSE TO CM.

 RESP40   BSS
          LDDL   INP
          SHN    -3
          STDL   T3           IN  POINTER IN WORDS
          LDML   RS+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          STDL   T5
          LDDL   T2
          ZJN    RESP50      IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADK    RS
          STML   RESPA       RESPONSE ADDRESS FOR 2ND BLOCK WRITE

 RESP50   LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD  IN  OFFSET
          CWML   RS,T4       WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          SBDL   T4
          ZJN    RESP70      IF ONLY 1 BLOCK WRITE REQUIRED
          STDL   T5          RESPONSE LENGTH - (LIMIT - IN)
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          LMC    400000B
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
 RESPA    EQU    *-1         (BEGINNING OF RESPONSE BUFFER)

 RESP70   LDDL   T1          NEW IN POINTER
          STDL   P4

* SET UP INTERRUPT PROCESSOR INSTRUCTION IF INTERRUPT IS SELECTED.

          LDML   RS+/RS/P.INT  CHECK IF INTERRUPT WAS SELECTED
          SHN    17-13
          MJN    RESP80      IF INTERRUPT SELECTED
          LDK    PSNI        PSN INSTRUCTION
          UJN    RESP90

 RESP80   BSS
          LDML   RS+/RS/P.PORT  GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RS/L.PORT+/RS/N.PORT
          LPK    /RS/M.PORT
          ADK    INPNI       INPN INSTRUCTION

 RESP90   STML   INTPRC

*  WRITE UPDATED  IN  POINTER FOR CM RESPONSE BUFFER TO PIT.

          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADK    /PIT/C.IN   OFFSET OF  IN  POINTER
          CWDL   P1          WRITE NEW  IN  POINTER TO CM

*  INTERRUPT PROCESSOR.

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   PPNO-3      SET LAST BYTE NON-ZERO

 INTPRC   INPN   1           INTERRUPT OR PSN
          LDN    0           CLEAR IPI RESPONSE LENGTH
          STML   RPB
          LJM    RESPX       EXIT
          SPACE  5,20
** NAME - CHGCH
*
** PURPOSE - CHANGE CHANNEL NUMBER IN CHANNEL INSTRUCTIONS
*
** INPUT - (CURCH) = CHANNEL NUMBER.
*          (A) = CHANNEL TABLE ADDRESS.
*
          SPACE  4
 CHGCH    SUBR               ENTRY/EXIT
          STDL   T1          SET ADDRESS MODIFICATION LIST ADDRESS

 CHG10    LDIL   T1          READ LIST WORD
          ZJN    CHGCHX      IF END OF LIST
          STDL   T2          SET INSTRUCTION ADDRESS
          LDIL   T2          READ INSTRUCTION WORD
          SCN    37B         CLEAR CHANNEL BITS
          LMDL   CURCH       REPLACE WITH NEW CHANNEL
          STIL   T2
          AODL   T1          INCREMENT TO NEXT INSTRUCTION
          UJN    CHG10       LOOP
          SPACE  5,20
** NAME-- SFP
*
** PURPOSE-- SEARCH FOR PARAMETER IDENTIFICATION IN RESPONSE PACKET
*
** INPUT
*         A = ID TO SEARCH FOR
** OUTPUT
*         A = POSITIVE IF ID FOUND
*         T3 = POINTER TO ID IF IT IS FOUND (RPB+5,T3)
          SPACE  2
 SFP      SUBR               ENTRY/EXIT
          STDL   T1          PARAMETER TO SEARCH FOR
          LDN    0
          STDL   T3          POINTER TO ID BEING SEARCHED FOR
          LDML   RPB
          ADN    1
          SHN    -1
          SBN    5           LENGTH OF MINIMUM RESPONSE PACKET
 SFP4     BSS
          STDL   T2          POINTER TO END OF PARAMETERS
          MJN    SFPX        EXIT, NO ID FOUND
          LDML   RPB+5,T3
          LMDL   T1
          LPDL   FF
          ZJN    SFPX        IF ID FOUND
          LDML   RPB+5,T3
          SHN    -9
          ADN    1           ADJUST FOR ODD BYTE
          STDL   T4          WORD LENGTH OF PARAMETER
          RADL   T3          UPDATE POINTER TO ID BEING SEARCHED FOR
          LDDL   T2
          SBDL   T4
          UJN    SFP4
          SPACE  5,20
** NAME-- PCER
*
** PURPOSE-- PREPARE COMMON ERROR RESPONSE
*
** INPUT  A = ERROR ID
          SPACE  2
 PCER     SUBR               ENTRY/EXIT
          STDL   P2
          SBN    E18
          MJN    PCER20      IF ERROR CODE 0-17
          SBN    E21-E18
          MJN    PCER10      IF ERROR CODE 18-20
          SBN    E22-E21
          MJN    PCER20      IF ERROR CODE 21
          SBN    E23-E22
          MJN    PCER10      IF ERROR CODE 22
          SBN    E27-E23
          MJN    PCER20      IF ERROR CODE 23-26
          SBN    E29-E27
          MJN    PCER10      IF ERROR CODE 27, 28
          ZJN    PCER20      IF ERROR CODE 29
          SBN    E30-E29
          NJN    PCER20      IF ERROR CODE 31-XX
 PCER10   BSS
          LDC    H00E1       READ STATUS REGISTER
          RJM    RDRG        READ REGISTER
          STDL   STATUS      SAVE CONTENTS OF STATUS REGISTER
 PCER20   BSS
          LDDL   INITFLG     CHECK IF FROM INITIALIZATION
          ZJN    PCER22      IF NOT
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          LDK    URC.IN      INITIALIZATION ERROR
          RAML   RS+/RS/P.URC
          UJN    PCER28      CONT.
 PCER22   LDDL   ASYNCP      CHECK IF ASYNCHRONUS PROCESSING
          ZJN    PCER24      IF NOT
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          UJN    PCER28      CONT.
 PCER24   BSS
          RJM    PAR         PREPARE ABNORMAL RESPONSE
 PCER28   BSS
          LDDL   P2
          NJN    PCER45      IF ERROR ALREADY ISOLATED
          LDK    ID14
          RJM    SFP         SEARCH FOR ID 14
          MJN    PCER30      IF NOT SLAVE INTERVENTION REQUIRED
          LDK    E71
          UJN    PCER45
 PCER30   BSS
          LDK    ID16
          RJM    SFP         SEARCH FOR ID 16
          MJN    PCER35      IF NOT SLAVE MACHINE EXCEPTION
          LDK    E72
          UJN    PCER45
 PCER35   BSS
          LDK    ID17
          RJM    SFP         SEARCH FOR ID 17
          MJN    PCER40      IF NOT SLAVE COMMAND EXCEPTION
          LDK    E73
          UJN    PCER70
 PCER40   BSS
          LDK    ID13
          RJM    SFP         SEARCH FOR PARAMETER
          MJN    PCER50      IF NOT ID13
          LDK    E74         MICROCODE EXECUTION ERROR
 PCER45   BSS
          UJN    PCER70
 PCER50   BSS
          LDK    ID15
          RJM    SFP         SEARCH FOR ID 15
          MJN    PCER60      IF NOT ALTERNATE PORT EXCEPTION
          LDK    E75
          UJN    PCER70
 PCER60   BSS
          LDK    E00         CP MUST ISOLATE THE ERROR
 PCER70   BSS
          STML   RS+/RS/P.ERRID
          LDDL   WC          WORDS NOT TRANSFERRED
          STML   RS+/RS/P.WC
          LDDL   LF
          STML   RS+/RS/P.FUNTO FAILING FUNCTION IF E01
          LDC    H0200       CONTROL REGISTER
          RJM    RDRG
          STML   RS+/RS/P.CR SAVE CONTROL REGISTER
          LDC    H00F1
          RJM    RDRG        READ IPI ERROR REGISTER
          STML   RS+/RS/P.ERREG SAVE ERROR REGISTER
          LDC    H0600       DMA ERROR REGISTER
          RJM    RDRG
          STML   RS+/RS/P.DMAER SAVE DMA ERROR REGISTER
          ZJN    PCER80      IF ERROR FLAG WAS NOT SET
          LDML   RS+/RS/P.CR CONTROL REGISTER
          SHN    17-12
          PJN    PCER80      IF TEST MODE NOT SET
          LDC    H00E1       READ STATUS REGISTER
          RJM    RDRG        READ REGISTER
          STDL   STATUS
 PCER80   BSS
          LDDL   STATUS      STATUS REGISTER
          STML   RS+/RS/P.STREG
          LDDL   OS
          STML   RS+/RS/P.OSR SAVE OPERATIONAL STATUS REGISTER
          UJK    PCERX
          SPACE  5,20
** NAME-- EP / CMDTERM
*
** PURPOSE-- ERROR PROCESSING
*
** NOTE-- DOES NOT RETURN TO CALLER
          SPACE  2
 CMDTERM  EQU    *
 EP       BSSZ   1           ENTRY
          LDDL   INITFLG     CHECK IF FROM INITIALIZATION
          ADDL   ASYNCP      OR FROM ASYNCHRONUS PROCESSING
          NJN    EP10        IF YES
          RJM    CDUNIT      CHECK IF UNIT IS TO BE DISABLED
 EP10     RJM    RESP        SEND THE RESPONSE
          LDN    76B         SET ASYNCHRONUS PROCESSING FLAG
          STDL   ASYNCP
          AOML   /TS/P.RETRY,CTST  INCREMENT RETRY COUNTER
          SBN    1           CHECK IF FIRST RETRY EXECUTED
          NJN    EP200       IF YES

 EP100    RJM    LIR         LOGICIAL INTERFACE RESET
          UJN    EP900       CONTINUE

 EP200    SBN    1           CHECK IF SECOND RETRY EXECUTED
          NJN    EP900       IF YES
          LDN    0           CLEAR IPI RESPONSE PACKET BUFFER
          STML   RPB
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          LDK    E50         EXECUTING CONTROLLER DIAGNOSTICS
          STML   RS+/RS/P.ERRID  SET ERROR ID FIELD
          RJM    RESP        SEND THE RESPONSE
          RJM    ISR         ISSUE SLAVE RESET
          LDN    0           CLEAR IPI RESPONSE PACKET BUFFER
          STML   RPB
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          LDK    E51         CONTROLLER DIAGNOSTICS PASSED
          STML   RS+/RS/P.ERRID  SET ERROR ID FIELD
          RJM    RESP        SEND THE RESPONSE

 EP900    SBN    1           CHECK IF CLREQ HAS FAILED
          NJN    EP920       IF YES

 EP910    RJM    CLREQ       CLEAR THE REQUEST FROM THE TS TABLE
          LJM    MAIN        GO TO MAIN LOOP

 EP920    LDN    0           CLEAR CHAIN FLAG SO CLREQ WONT FAIL AGAIN
          STML   /TS/P.CHAIN,CTST
          UJN    EP910       GO CLEAR REQUEST
          SPACE  5,20
** NAME - SLVTST
*
** PURPOSE - TO CHECK IF SLAVE TESTING IS REQUIRED
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 SLVTST   SUBR               ENTRY/EXIT
          LDML   SLB+/SL/P.SLVTST,SX  GET SLAVE TESTING REQUIRED FLAG
          LPN    1           MASK TESTING REQUIRED BIT
          ZJN    SLVTSTX     IF NOT, EXIT
          LDML   SLVTST      SAVE RETURN ADDRESS
          STML   /TS/P.SSLVT,CTST
          LDML   SRTAB,SLVN  CHECK IF SLAVE RESET EVER EXECUTED
          ZJN    SLVTST2     IF NOT
          LDN    1           SET RETRY COUNTER
          STML   /TS/P.RETRY,CTST
          RJM    LIR         LOGOICIAL INTERFACE RESET
          UJN    SLVTST4
 SLVTST2  BSS
          LDN    2           SET RETRY COUNTER
          STML   /TS/P.RETRY,CTST
          RJM    ISR         ISSUE SLAVE RESET
 SLVTST4  BSS
          RJM    PTW         PATH TEST WRITE
          RJM    PTR         PATH TEST READ
          LDN    2           SET ATTRIBUTES REQUIRED FLAG
          STML   SLB+/SL/P.SLVTST,SX
          LDN    0           CLEAR RETRY COUNTER
          STML   /TS/P.RETRY,CTST
          LDML   /TS/P.SSLVT,CTST  RESTORE RETURN ADDRESS
          STML   SLVTST
          UJK    SLVTSTX     EXIT
          SPACE  5,20
** NAME - FACTST
*
** PURPOSE - TO CHECK IF FACILITY TESTING IS REQUIRED
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 FACTST0  LDML   UNITS+/UN/P.CTF,UX  CLEAR FACILITY TESTING REQUIRED FLAG
          LPK    -/UN/K.CTF  MASK OUT BIT
          STML   UNITS+/UN/P.CTF,UX
          LDML   /TS/P.SFACT,CTST  RESTORE RETURN ADDRESS
          STML   FACTST


 FACTST   SUBR               ENTRY/EXIT


          LDML   UNITS+/UN/P.CTF,UX  GET FACILITY TESTING REQUIRED FLAG
          SHN    17-6
          PJN    FACTSTX     IF NOT SET, EXIT
          LDML   FACTST      SAVE RETURN ADDRESS
          STML   /TS/P.SFACT,CTST
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   PFDCP1
          LDML   /TS/P.SN,CTST  GET SLAVE AND FACILITY ADDRESS
          STML   PFDCP5
          LDC    PFDCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER

 FACTST2  LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK IF SUCCESSFUL
          ZJK    FACTST0     IF YES
          LDML   RPB+MAJST   CHECK IF COMMAND COMPLETION RESPONSE
          SHN    -4
          LPN    0#F
          LMN    CC
          ZJN    FACTST4     IF YES, BUT WAS NOT SUCCESSFUL
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     PROCESS ASYNCHRONUS RESPONSE
          UJN    FACTST2     WAIT FOR COMMAND COMPLETE RESPONSE

 FACTST4  LDML   RPB+MAJST   CHECK IF DIAGNOSTIC FAILURE
          SHN    LSME          LOOK FOR MACHINE EXCEPTION
          MJN    FACTST6     IF YES
          LDN    0           DO NOT EXPECT BID OR TAPE MARK
          RJM    CMDRESP     PROCESS RESPONSE (NO RETURN)

 FACTST6  LDK    E61         REPORT DRIVE FAILURE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    CMDTERM     COMMAND TERMINATE  (NO RETURN)
          SPACE  4
*         -PERFORM FACILITY DIAGNOSTICS-  COMMAND PACKET
 PFDCP    DATA   0#0010      PACKET LENGTH
 PFDCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
          CON    OCPFD+CMCHN  OP-CODE AND CHAIN
 PFDCP5   DATA   0#FFFF      ADDRESSEE
          DATA   0#0953      FACILITY DIAGNOSTIC PARAMETER
          DATA   0#8000        LOOP WRITE/READ SECTION
          DATA   0#0000        DIAG MODE
          DATA   0#0000        RETRY COUNT
          DATA   0#0001        EXECUTION LOOP COUNT
          SPACE  5,20
** NAME - CDUNIT
*
** PURPOSE - TO SET THE DISABLED UNIT BIT IN THE UIT IF THE MASK BIT IS SET.
*
*  INPUT - RESPONSE BUFFER HEADER ALERT MASK IS IMAGE OF REQUEST
*
** OUTPUT - THE DISABLE UNIT BIT IS SET IN THE STATUS FIELD OF THE UNIT
*           INTERFACE TABLE IF THE ALERT MASK DISABLE BIT WAS SET.
*
          SPACE  2
 CDUNIT   SUBR               ENTRY/EXIT
          LDML   RS+/RS/P.LONGB  CHECK ALERT MASK
          SHN    18-16+/RS/L.DUNIT  DISABLE UNIT BIT TO SIGN POSITION
          PJN    CDUNITX     IF NOT DISABLE UNIT BIT IN ALERT MASK
          LDK    /RS/K.DUNIT   SET UNIT DISABLED BIT IN RESPONSE
          RAML   RS+/RS/P.LNGBLK  SET RESPONSE ALERT CONDITIONS
          LOADR  UNITS+/UN/P.UIT,UX  LOAD R AND A OF UIT
          STDL   CMADR+2     SAVE CM ADDRESS
          CRDL   T1          READ UIT UNIT STATUS INTO T2
          LDK    /UIT/K.DSABLE  SET UNIT DISABLED IN UIT STATUS
          STDL   T2
          LDDL   CMADR+2     RESTORE CM ADDRESS
          LMC    400000B
          CWDL   T1          UPDATE UIT UNIT STATUS
          UJK    CDUNITX     EXIT
          SPACE  5,20
** NAME-- MR
*
** PURPOSE-- MASTER RESET ALL SLAVES ON THE CHANNEL
          SPACE  2
 MR       SUBR               ENTRY/EXIT
          RJM    MCC         MASTER CLEAR CHANNEL
          LDN    1
          STDL   T2
          LDC    H0062       SELECT PORT A (20 MHZ INT CLK)
*         LDC    H0162       SELECT PORT A (12 MHZ EXT CLK)
          RJM    FUNC
 MR10     BSS
          LDC    H9213
          RJM    FUNC        BUS A, SET SYNC OUT
          PAUSE  10          MUST DELAY 10 MICROSECONDS MINIMUM
          LDC    H9211
          RJM    FUNC        DROP SYNC OUT
          SODL   T2
          MJN    MRX         IF BOTH PORTS RESET
          LDC    H0862       SELECT PORT B (20 MHZ INT CLK)
*         LDC    H0962       SELECT PORT B (12 MHZ EXT CLK)
          RJM    FUNC
          UJN    MR10
          SPACE  5,20
** NAME--ISR
*
** PURPOSE-- ISSUE SLAVE RESET
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 ISR      SUBR               ENTRY/EXIT
          LDML   ISR         SAVE RETURN ADDRESS
          STML   /TS/P.SISR,CTST
          LDK    H8415       SLAVE RESET
          RJM    IR          ISSUE RESET
          LDK    SRT         SLAVE RESET SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          SHN    -4
          LPN    0#F
          LMK    AR
          NJN    ISR20       IF NOT ASYNCHRONOUS RESPONSE
          LDK    ID16
          RJM    SFP         CHECK FOR MACHINE EXCEPTION
          MJN    ISR20       IF MACHINE EXCEPTION ID NOT FOUND
          LDML   RPB+6,T3
          LPK    0#FEE0
          LMK    0#6000
          NJN    ISR20       IF ERROR
          STML   /TS/P.CHAIN,CTST  CLEAR IPI CHAIN/ABORTED FLAG
          LDML   /TS/P.SISR,CTST  RESTORE RETURN ADDRESS
          STML   ISR
          STML   SRTAB,SLVN  SET SLAVE RESET EXECUTED
          UJK    ISRX
 ISR20    BSS
          LDK    E60         CONTROLLER FAILURE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- LIR
*
** PURPOSE-- LOGICAL INTERFACE RESET.
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 LIR      SUBR               ENTRY/EXIT
          LDML   LIR         SAVE RETURN ADDRESS
          STML   /TS/P.SLIR,CTST
          LDK    H8215       LOGICAL INTERFACE RESET
          RJM    IR          ISSUE RESET
          LDN    3           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          SHN    -4
          LPN    0#F
          LMK    AR
          NJN    LIR20       IF NOT ASYNCHRONOUS RESPONSE
          LDK    ID16
          RJM    SFP         CHECK FOR MACHINE EXCEPTION
          MJN    LIR20       IF MACHINE EXCEPTION ID NOT FOUND
          LDML   RPB+6,T3
          LPK    0#FEE0
          LMK    0#6000
          NJN    LIR20       IF ERROR
          STML   /TS/P.CHAIN,CTST  CLEAR IPI CHAIN/ABORTED FLAG
          LDML   /TS/P.SLIR,CTST  RESTORE RETURN ADDRESS
          STML   LIR
          UJK    LIRX
 LIR20    BSS
          LDK    E00         CP MUST DETERMINE ERROR CODE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- IR
*
** PURPOSE-- ISSUE INTERFACE RESET TO SLAVE
*
** ENTRY
*         A = 8115  FOR PHYSICAL INTERFACE RESET
*             8215  FOR LOGICAL INTERFACE RESET
*             8415  FOR SLAVE RESET
*         SLVN = SLAVE NUMBER
          SPACE  2
 IR       SUBR               ENTRY/EXIT
          STDL   P2
          RJM    SARF        SET ATTRIBUTES REQUIRED FLAG
          RJM    MCC         MASTER CLEAR CHANNEL
          RJM    PS          PORT SELECT
          LDDL   SLVN        SLAVE NUMBER
          LPN    SLVPCH-1    MASK OFF PORT BIT
          SHN    12
          ADDL   P2
          RJM    FUNC        SET MASTER OUT
          PAUSE  20
          LDDL   LF          LAST FUNCTION ISSUED
          LMN    2
          RJM    FUNC        SET SYNC OUT
          PAUSE  10
          LDDL   LF
          LMN    2
          RJM    FUNC        DROP SYNC OUT
          LDDL   LF
          LMN    4
          RJM    FUNC        DROP MASTER OUT
          UJK    IRX
          SPACE  5,20
** NAME-- IH
*
** PURPOSE-- INTERRUPT HANDLER.  INPUT THE RESPONSE PACKET.  THROW AWAY
*            ASYNCHRONOUS RESPONSES (UP TO 8) FROM THE FACILITIES.
*
** ENTRY--A = MAXIMUM SECONDS TO WAIT FOR THE INTERRUPT
*
** EXIT
*         A = MAJOR STATUS
*         THE SLAVE IS DESELECTED
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 IH       SUBR               ENTRY/EXIT
          ADN    1           ADJUST TIME LIMIT
          STML   /TS/P.SECLIM,CTST  SAVE THE SECONDS LIMIT
          RJM    UC          UPDATE THE CLOCK
          LDDL   CLSEC
          STML   /TS/P.CLK,CTST  SAVE CURRENT CLOCK IN TS TABLE
          LDML   IH          SAVE ROUTINE CALLER
          STML   /TS/P.SIH,CTST
 IH10     BSS
          RJM    SWITCH      SWITCH TO OTHER TS TABLE
          LDML   /TS/P.SIH,CTST  RESTORE RETURN ADDRESS
          STML   IH
          LDN    7           CLASS 1, 2 AND 3 INTERRUPTS
          RJM    RI          REQUEST INTERRUPTS
          NJN    IH15        IF INTERRUPT PRESENT
          RJM    UC          UPDATE CLOCK
          LDDL   CLSEC
          SBML   /TS/P.CLK,CTST
          PJN    IH12        IF CLOCK HAS NOT WRAPPED
          ADK    0#10000
 IH12     BSS
          SBML   /TS/P.SECLIM,CTST
          MJN    IH10        IF TIMEOUT NOT EXPIRED
          LDK    E38         NO SLAVE INTERRUPT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 IH15     BSS
          RJM    DTM         DETERMINE TRANSFER MODE
          RJM    SEL         SELECT THE SLAVE
          STDL   CTM         CLEAR CHANGE TRANSFER MODE FLAG
          RJM    RPT         RESPONSE PACKET TRANSFER
          RJM    DCM         DESELECT THE SLAVE
          LDML   RPB+MAJST   MAJOR STATUS
          SHN    -4
          LPN    0#F
          LMK    AR
          NJN    IH20        IF NOT ASYNCHRONOUS RESPONSE
          LDML   RPB+SLAD
          LPDL   FF
          LMDL   FF
          ZJN    IH20        IF ASYNCHRONOUS RESPONSE FOR SLAVE
          LJM    IH10        GO LOOK FOR ANOTHER INTERRUPT
 IH20     BSS
          LDML   RPB+MAJST   MAJOR STATUS
          LJM    IHX
          SPACE  5,20
** NAME-- UC
*
** PURPOSE-- UPDATE CLOCK.  THE CLOCK IS USED TO TIMEOUT COMMANDS
*            ISSUED TO THE SLAVE.
          SPACE  2
 UC       SUBR               ENTRY/EXIT
          LDDL   CLCUR
          STDL   P6          SAVE CURRENT CLOCK
          IAN    14B
          STDL   CLCUR
          SBDL   P6
          PJN    UC5         IF CLOCK HASNT WRAPPED
          ADK    10000B
 UC5      BSS
          RADL   CLMCS       UPDATE MICROSECOND PORTION OF CLOCK
          LDDL   CLMCS
          ADK    -2000
          MJN    UCX         IF LESS THAN 2 MILLISECONDS
          STDL   CLMCS
          LDN    2
          RADL   CLMLS       UPDATE MILLISECOND PORTION OF CLOCK
          ADK    -1000
          MJN    UCX         IF LESS THAN 1 SECOND
          STDL   CLMLS
          AODL   CLSEC       UPDATE SECOND PORTION OF CLOCK
          UJN    UCX         EXIT
          SPACE  5,20
** NAME-- EFP
*
** PURPOSE-- ERROR FLAG PROCESSING
          SPACE  2
 EFP      DATA   0
          LDC    H0800       DMA TERMINATE
          RJM    FAN
          LDC    H0600       READ DMA ERROR REGISTER
          RJM    RDRG
          SHN    9
          MJK    EFP60       IF IPI ERROR
          SHN    12
          MJK    EFP85       IF ILLEGAL FUNCTION
          SHN    1
          MJN    EFP5        IF UNCORRECTED CM ERROR
          SHN    1
          PJN    EFP10       IF NOT CM REJECT
 EFP5     BSS
          LDN    E09         CENTRAL MEMORY ERROR
          UJN    EFP40
 EFP10    BSS
          SHN    1
          PJN    EFP15       IF NOT INVALID CM RESPONSE CODE
          LDN    E10
          UJN    EFP40
 EFP15    BSS
          SHN    1
          PJN    EFP20       IF NOT CM RESPONSE CODE PARITY ERROR
          LDN    E11
          UJN    EFP40
 EFP20    BSS
          SHN    1
          PJN    EFP25       IF NOT CMI READ DATA PARITY ERROR
          LDN    E12
          UJN    EFP40
 EFP25    BSS
          SHN    5
          PJN    EFP35       IF NOT JY DATA ERROR
          LDN    E13
          UJN    EFP40
 EFP35    BSS
          SHN    1
          PJN    EFP45       IF NOT BAS PARITY ERROR
          LDN    E14
 EFP40    BSS
          UJN    EFP75
 EFP45    BSS
          SHN    1
          PJN    EFP50       IF NOT LZ ERROR
          LDN    E15
          UJN    EFP75
 EFP50    BSS
          SHN    1
          PJN    EFP55       IF NOT JY ERROR
          LDN    E16
          UJN    EFP75
 EFP55    BSS
          SHN    1
          PJK    EFP130      IF NOT LX ERROR
          LDN    E17
          UJN    EFP75
 EFP60    BSS
          LDC    H00F1       READ IPI ERROR REGISTER
          RJM    RDRG
          SHN    2
          PJN    EFP65       IF NOT BUFFER COUNTER PARITY
          LDN    E31
          UJN    EFP75
 EFP65    BSS
          SHN    2
          PJN    EFP70       IF NOT SYNC COUNTER PARITY
          LDN    E32
          UJN    EFP75
 EFP70    BSS
          SHN    1
          PJN    EFP80       IF NOT PERIOD COUNTER PARITY
          LDN    E03
 EFP75    BSS
          UJN    EFP120
 EFP80    BSS
          SHN    1
          MJN    EFP85       IF PARITY ERROR ON FUNCTION
          SHN    1
          PJN    EFP95       IF NOT PARITY ERROR ON FUNCTION
 EFP85    BSS
          LDN    E01         FUNCTION TIMEOUT
          UJN    EFP120
 EFP95    BSS
          SHN    3
          PJN    EFP100      IF NOT LOST DATA
          LDN    E33
          UJN    EFP150
 EFP100   BSS
          SHN    1
          PJN    EFP105      IF NOT UPPER ICI PARITY
          LDN    E04
          UJN    EFP150
 EFP105   BSS
          SHN    1
          PJN    EFP110      IF NOT LOWER ICI PARITY
          LDN    E05
          UJN    EFP150
 EFP110   BSS
          SHN    1
          PJN    EFP115      IF NOT IPI SEQUENCE ERROR
          LDN    E24
          UJN    EFP150
 EFP115   BSS
          SHN    1
          PJN    EFP125      IF NOT UPPER IPI CHANNEL PARITY
          LDN    E25
 EFP120   BSS
          UJN    EFP150
 EFP125   BSS
          SHN    1
          PJN    EFP127      IF NOT LOWER IPI CHANNEL PARITY
          LDN    E26
          UJN    EFP150
 EFP127   SHN    1
          PJN    EFP130      IF NOT ILLEGAL OPERATION
          LDK    E19
          UJN    EFP150
 EFP130   BSS
          LDN    E06         IOU ERROR
 EFP150   BSS
          STML   RS+/RS/P.ERRID
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- INTERR
*
** PURPOSE-- REPORT AN INTERFACE ERROR
*
** ENTRY-- A REGISTER HAS INTERFACE ERROR CODE
*
** EXIT-- TO MAIN IDLE LOOP WITH IDLFLG FORCED SET.
*         PP WILL ONLY PROCESS IDLE/RESUME COMMANDS.
          SPACE  2
 INTERR   DATA   0
          STDL   T7          SAVE ERROR CODE
          LDN    0           NO IPI STATUS IN RESPONSE
          STML   RPB
          RJM    PUR         PREPARE UNSOLICITED RESPONSE
          LDDL   T7          GET INTERFACE ERROR CODE
          STML   RS+/RS/P.IEC INTERFACE ERROR CODE
          LDK    /RS/K.INTERR  INTERFACE ERROR
          STML   RS+/RS/P.INTERR  ABNORMAL STATUS CODE
          LDK    E120        SOFTWARE FAILURE
          STML   RS+/RS/P.ERRID
          LDK    /RS/K.PDN   PP IDLED
          STML   RS+/RS/P.DOWNST
          RJM    RESP        SEND THE RESPONSE
          LDN    77B         FORCE SET PP IDLE FLAG
          STDL   IDLFLG
          LJM    MAIN        EXIT TO MAIN IDLE LOOP
          SPACE  5,20
** NAME-- PAUS
*
** PURPOSE-- DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*            MICROSECONDS.
*
** INPUT-- A REGISTER SPECIFIES NUMBER OF MICROSECONDS
*          TO BE DELAYED.
          SPACE  2
 PAUS     SUBR               ENTRY/EXIT
 PAUS10   SBN    1           EACH ITERATION OF THIS LOOP
          STDL   AT1          IS ONE MICROSECOND (I4 ONLY)
          NJN    PAUS10
          UJK    PAUSX
          SPACE  5,20
** NAME-- FORMA
*
** PURPOSE-- FORMAT A CM REAL MEMORY ADDRESS.
*
** CALLING SEQUENCE-- LDC    ADDRESS
*                     RJM    FORMA
*
** INPUT-- - A REGISTER- IS THE ADDRESS OF A 2-WORD CM BYTE ADDRESS.
*
** OUTPUT-- -CMADR- IS THE ADDRESS OF THE RESULTING 3-WORD REFORMATED
*                CM ADDRESS.  THE FORMAT CAN BE USED BY THE LOADC MACRO.
*           -ADDRESS-, WORD 0, BITS 0-13 AND
*                      WORD 1, BITS 3-15, ARE REFORMATTED TO-
*           -CMADR-,   WORD 0, BITS 0-9,
*                      WORD 1, BITS 0-11,
*                      WORD 2, BITS 0-5.
*
** NOTE-- THIS SUBROUTINE USES DIRECT CELL AT1 INSTEAD OF T1
          SPACE  2
 FORMA    SUBR               ENTRY/EXIT
          STDL   AT1
          LDML   1,AT1
          LPN    7
          NJN    FORMA10     RMA ADDRESS ERROR
          LDIL   AT1
          LPN    37B
          SHN    16
          LMML   1,AT1
          SHN    9
          STD    CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   AT1
          SHN    -5
          STD    CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMC    400000B
          UJK    FORMAX      EXIT
 FORMA10  BSS
          LDC    E304        RMA NOT WORD BOUNDARY
          RJM    INTERR      REPORT ERROR (NO RETURN)
          SPACE  5,20
** NAME-- SAVAD
*
** PURPOSE-- SAVE A REFORMATTED CM ADDRESS.
*
** INPUT--  -A REGISTER- IS THE REFORMATTED A OF R+A
*           -T2- ADDRESS TO SAVE THE 3-WORD REFORMATTED CM ADDRESS
*           -CMADR-,   WORD 0, BITS 0-9,    SOURCE REFORMATTED CM ADDRESS
*                      WORD 1, BITS 0-11,
*                      WORD 2, BITS 0-5.
*
** NOTE-- THIS SUBROUTINE USES DIRECT CELL T2
          SPACE  2
 SAVAD    SUBR               ENTRY/EXIT
          STML   2,T2
          LDDL   CMADR
          STI    T2
          LDDL   CMADR+1
          STML   1,T2
          UJK    SAVADX
          SPACE  5,20
** NAME-- PS
*
** PURPOSE-- PORT SELECT.  SELECT PORT A OR B OF IPI CHANNEL
          SPACE  2
 PS       SUBR               ENTRY/EXIT
          LDML   UNITS+/UN/P.PORT,UX
          SHN    17-9
          PJN    PS5         IF PORT A
          LDC    H0862       PORT B SELECT (20 MHZ INT CLK)
*         LDC    H0962       PORT B SELECT (12 MHX EXT CLK)
          UJN    PS10
 PS5      BSS
          LDC    H0062       PORT A SELECT (20 MHZ INT CLK)
*         LDC    H0162       PORT A SELECT (12 MHX EXT CLK)
 PS10     BSS
          RJM    FUNC
          UJN    PSX
          SPACE  5,20
** NAME-- TICP
*
** PURPOSE-- TEST IPI CHANNEL PATH
*
** EXIT-- RETURN TO CALLER IF NO ERRORS DETECTED
          SPACE  2
 TICP     SUBR               ENTRY/EXIT
* TRANSFER FROM RECEIVERS TO CENTRAL MEMORY
          RJM    WOG         WRITE OPERAND GENERATOR, ENABLE TEST MODE
          LDN    H0009
          RJM    FUNC        SET SELECT OUT
          LDC    H0281
          RJM    FUNC        IPI TRANSFER FUNCTION (READ)
          LDC    H0C00       DMA READ
          RJM    TMT         TEST MODE TRANSFER
          LDC    0#ED1B      EXPECTED OPERAND GENERATOR
          RJM    COG         DROP MASTER OUT, DESELECT, DISABLE TEST
                              MODE, CHECK OPERAND GENERATOR
          RJM    VTMD        VERIFY TEST MODE DATA
* TRANSFER FROM CENTRAL MEMORY TO TRANSMITTERS
          RJM    WOG         WRITE OPERAND GENERATOR, ENABLE TEST MODE
          LDN    H0009
          RJM    FUNC        SET SELECT OUT
          LDC    H0381       IPI TRANSFER FUNCTION (WRITE)
          RJM    FUNC
          LDC    H0D00       DMA WRITE
          RJM    TMT         TEST MODE TRANSFER
          LDC    0#DC3E      EXPECTED OPERAND GENERATOR
          RJM    COG         DROP MASTER OUT, DESELECT, DISABLE TEST
                              MODE, CHECK OPERAND GENERATOR
          UJK    TICPX       EXIT
          SPACE  5,20
** NAME-- COG
*
** PURPOSE-- CHECK OPERAND GENERATOR.  THE CRC VALUE GENERATED
*            AFTER A TEST MODE OPERATION IS READ AND COMPARED
*            WITH THE CORRECT VALUE.
*
** ENTRY  A = EXPECTED OPERAND GENERATOR
          SPACE  2
 COG      SUBR               ENTRY/EXIT
          STDL   T2
          LDK    H0009
          RJM    FUNC        DROP MASTER OUT
          RJM    DCM         DROP SELECT OUT
          LDN    0           DISABLE TEST MODE
          RJM    WCR         WRITE CONTROL REGISTER
          LDN    H0004       READ OPERAND GENERATOR
          RJM    RDRG        READ REGISTER
          LMDL   T2
          ZJN    COGX        IF OPERAND GENERATOR IS CORRECT
          LDN    E18         DMA TEST MODE FAILURE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- VTMD
*
** PURPOSE-- VERIFY TEST MODE DATA.  DATA GENERATED FROM A
*            TEST MODE READ IS CHECKSUMMED AND COMPARED
*            AGAINST THE CORRECT VALUE.
          SPACE  2
 VTMD1    STML   RPB         CLEAR RPB LENGTH

 VTMD     SUBR               ENTRY/EXIT
          LDN    32
          STDL   P1          CM WORDS TO TRANSFER
          LOADC  CM.COM
          ADK    /CB/C.PTD   OFFSET TO TEST MODE AREA
          CRML   RPB,P1      READ TEST MODE PATTERN
          LDN    0
          STDL   P2
          STDL   P3
          LDC    128-1       PP WORD COUNT MINUS 1
          STDL   P1
 VTMD10   BSS
          LDML   RPB,P1
          RADL   P2
          SHN    -16
          RADL   P3
          SODL   P1
          PJN    VTMD10      IF MORE WORDS TO CHECKSUM
          LDDL   P2
          LMK    0#F415      CHECK THE LOWER CHECKSUM
          NJN    VTMD20      IF ERROR
          LDDL   P3
          LMK    0#003E      CHECK THE UPPER CHECKSUM
          ZJK    VTMD1       IF NO ERROR
 VTMD20   BSS
          LDN    E18         DMA TEST MODE FAILURE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- SARF
*
** PURPOSE-- SET ATTRIBUTES REQUIRED FLAG
          SPACE  2
 SARF     SUBR               ENTRY/EXIT
          LDML   SLB+/SL/P.SLVTST,SX  GET FLAG WORD
          LPN    1           MASK TESTING REQUIRED
          ADN    2           SET ATTRIBUTES REQUIRED BIT
          STML   SLB+/SL/P.SLVTST,SX  RESTORE FLAG WORD
          UJN    SARFX       EXIT
          TITLE  CHANNEL SUBROUTINES
** NAME-- MCC
*
** PURPOSE-- MASTER CLEAR CHANNEL
          SPACE  2
 MCC      SUBR               ENTRY/EXIT
          LDN    H0000       MASTER CLEAR CHANNEL
          RJM    FAN
          PAUSE  100         ALLOW CONTROLLER TIME TO DROP LINES
          LDN    H0000       MASTER CLEAR CHANNEL
          RJM    FAN          IN CASE SEQUENCE ERROR OCCURRED
          CFM    MCC10,DC    CLEAR CHANNEL ERROR FLAG
 MCC10    BSS
          LDC    H0062       SELECT 20 MHZ INT CLK
*         LDC    H0162       SELECT 12 MHZ EXT CLK
          RJM    FAN
          LDK    H7C42       SET TRANSFER RATE TO 5.00 MB
*         LDK    HFE42       SET TRANSFER RATE TO 6.00 MB
          RJM    FAN
          LDK    H0022       CLEAR IPI ERROR
          RJM    FAN          CLEAR PERIOD COUNTERS
          LDK    H0100       CLEAR ERROR
          RJM    FAN          CLEAR PERIOD COUNTER ERROR
          CFM    MCCX,DC     CLEAR CHANNEL ERROR FLAG
          UJN    MCCX
          SPACE  5,20
** NAME-- FUNC
*
** PURPOSE-- ISSUE FUNCTION TO IPI CHANNEL
*
** INPUT-- A REGISTER = FUNCTION CODE.
          SPACE  2
 FUNC     SUBR               ENTRY/EXIT
          DCN    DC+40B      ENSURE CHANNEL IS INACTIVE
                              THE CHANNEL MAY HAVE BEEN LEFT ACTIVE
                              BY A ROUTINE SUCH AS DCM,
                              OR AFTER A REPORTED ERROR.
          CFM    FUNC10,DC   IF CHANNEL ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 FUNC10   BSS
          FAN    DC          ISSUE THE FUNCTION
          STDL   LF          SAVE FUNCTION CODE
 FH1      IFEQ   FH,1        FUNCTION HISTORY TABLE
          STML   FBUF,FI     SAVE HISTORY OF FUNCTIONS ISSUED
          AODL   FI          INCREMENT FUNCTION BUFFER INDEX
          ADK    -FBUFL
          NJN    FUNC20      IF NOT END OF BUFFER
          STDL   FI          INITIALIZE INDEX
 FUNC20   BSS
 FH1      ENDIF
          CFM    FUNC30,DC   IF CHANNEL ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 FUNC30   BSS
          IJM    FUNCX,DC    EXIT IF CHANNEL INACTIVE
          LDK    E01         FUNCTION TIMEOUT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- FAN
*
** PURPOSE-- SEND A FUNCTION TO THE IPI CHANNEL, BUT DONT
*            PUT THE FUNCTION IN THE FUNCTION HISTORY TABLE
          SPACE  2
 FAN      SUBR               ENTRY/EXIT
          DCN    DC+40B      ENSURE THE CHANNEL IS INACTIVE
                              THE CHANNEL MAY HAVE BEEN LEFT ACTIVE
                              BY A MASTER CLEAR, A ROUTINE SUCH AS
                              DCM, OR AFTER A REPORTED ERROR.
          FAN    DC          SEND THE FUNCTION
          UJN    FANX
          SPACE  5,20
** NAME-- RDRG
*
** PURPOSE-- READ EITHER THE IPI STATUS OR IPI ERROR REGISTER
*
** ENTRY--  A = FUNCTION CODE
          SPACE  2
 RDRG10   BSS
          LDN    0

 RDRG     SUBR               ENTRY/EXIT
          RJM    FAN         SEND FUNCTION
          AJM    RDRG10,DC   IF NO FUNCTION REPLY
          ACN    DC+40B
          EJM    RDRG10,DC   IF WORD COULD NOT BE READ
          IAN    DC
          UJN    RDRGX
          SPACE  5,20
** NAME-- DCN
*
** PURPOSE-- DISCONNECT THE CHANNEL
          SPACE  2
 DCN05    DCN    DC+40B      DISCONNECT THE CHANNEL

 DCN      SUBR               ENTRY/EXIT

          SFM    DCN10,DC    IF ERROR FLAG SET
          ZJN    DCN20       IF ALL WORDS TRANSFERRED
          STDL   WC          WORDS NOT TRANSFERRED
          LDN    E07         INCOMPLETE I4 TRANSFER
          UJN    DCN40
 DCN10    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 DCN20    BSS
          EJM    DCN05,DC    IF CHANNEL EMPTY
          LDN    E08         CHANNEL NOT EMPTY
 DCN40    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME--RI
*
** PURPOSE-- REQUEST INTERRUPTS FROM ALL SLAVES ON THIS CHANNEL
*
** INPUT-- A = BIT 0 SET CLASS 1
*                  1 SET CLASS 2
*                  2 SET CLASS 3
*
** OUTPUT-- A = LOGICIAL PRODUCT OF CURRENT SLAVE AND SLAVE INTERRUPTS
*         STATUS =  BIT SIGNIFICANT ADDRESS OF SLAVES WITH INTERRUPTS
          SPACE  2
 RI       SUBR               ENTRY/EXIT
          LPN    7           MASK CALLER SELECTION
          SHN    8           POSITION THEM
          ADK    H0X15       REQUEST SELECTED INTERRUPTS
          RJM    FUNC        BUS A, MASTER OUT
          PAUSE  20          DELAY
          ACN    DC
          EJM    RI5,DC      IF ERROR
          IAN    DC
          STDL   STATUS      SAVE BIT SIGNIFICANT ADDRESS
          LDDL   LF
          LMN    4
          RJM    FUNC        DROP MASTER OUT
          LDML   SELT,SLVN   MASK VALUE
          LPDL   STATUS      LOGICIAL PRODUCT WITH INTERRUPT STATUS
          UJN    RIX         EXIT
 RI5      BSS
          LDK    E02         CHANNEL EMPTY WHEN ACTIVATED
          RJM    PCER        PREPARE COMMAND ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,15
** NAME-- DTM
*
** PURPOSE-- DETERMINE TRANSFER MODE
*
** OUTPUT
*         STATUS - TRANSFER SETTINGS, BIT 4 = 1 IF DATA STREAMING
*         CTM - USED TO CHANGE TRANSFER MODE WHEN SELECTING
          SPACE  2
 DTM      SUBR               ENTRY/EXIT
          RJM    PS          PORT SELECT
          LDDL   SLVN        SLAVE NUMBER
          LPN    SLVPCH-1    MASK OFF PORT BIT
          SHN    12
          ADK    H8025
          RJM    FUNC        REQUEST TRANSFER SETTINGS
          ACN    DC
          LDN    77B
 DTM4     FJM    DTM8,DC     IF SLAVE IN
          SBN    1
          NJN    DTM4        IF TIMEOUT NOT EXPIRED
          LDK    E27         NO SLAVE IN
          UJN    DTM16
 DTM8     IAN    DC
          STDL   STATUS      SAVE TRANSFER SETTING
          SFM    DTM20,DC    IF ERROR FLAG SET
          LPN    0#10
          LMN    0#10
          SHN    7
          STDL   CTM         CHANGE TRANSFER MODE BIT
          LDDL   LF          LAST FUNCTION ISSUED
          LMK    0#54        CODE 7, DROP MASTER OUT
          RJM    FUNC        DROP MASTER OUT
          ACN    DC
          LDN    77B
 DTM12    FJM    DTMX,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    DTM12       IF TIMEOUT NOT EXPIRED
          LDK    E28         SLAVE IN DID NOT DROP
 DTM16    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 DTM20    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- SEL
*
** PURPOSE-- SELECT THE SLAVE AND VERIFY THE BIT SIGNIFICANT RESPONSE
*
** INPUT
*         SLVN - SLAVE NUMBER
*         CTM - CHANGE TRANSFER MODE IF BIT 3 SET
*
** OUTPUT-- A = 0 IF NO ERROR
          SPACE  2
 SEL      SUBR               ENTRY/EXIT
          RJM    PS          PORT SELECT
          LDDL   SLVN
          LPN    SLVPCH-1    MASK OFF PORT BIT
          SHN    12
          ADDL   CTM         CHANGE TRANSFR MODE MODIFIER
          ADK    H0029
          RJM    FUNC        SET SELECT OUT
          ACN    DC
          LDN    77B
 SEL4     FJM    SEL8,DC     IF SLAVE IN
          SBN    1
          NJN    SEL4        IF TIMEOUT NOT EXPIRED
          LDK    E20         CANT SELECT SLAVE
          UJN    SEL15
 SEL8     IAN    DC
          STDL   STATUS      SAVE BIT SIGNIFICANT RESPONSE
          CFM    SEL10,DC    IF ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 SEL10    BSS
          LPK    377B
          LMML   SELT,SLVN
          ZJK    SELX        IF BIT SIGNIFICANT RESPONSE CORRECT
          LDK    E21         BIT SIGNIFICANT RESPONSE WRONG
 SEL15    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- BCS
*
** PURPOSE-- PERFORM BUS CONTROL SEQUENCE
*
** INPUT
*         A = BUS A BITS 7,6 IN BITS 1,0 OF ACCUMULATOR
*             BIT 7 = 1 IF DATA ELSE RESPONSE OR COMMAND
*             BIT 6 = 1 IF INFORMATION IN
          SPACE  2
 BCS      SUBR               ENTRY/EXIT
          SHN    14
          ADK    H005B
          RJM    FUNC        SET SYNC OUT
          ACN    DC
          LDN    77B
 BCS4     FJM    BCS8,DC     IF SYNC IN
          SBN    1
          NJN    BCS4        IF TIMEOUT NOT EXPIRED
          LDK    E22         NO SYNC IN
          UJN    BCS20
 BCS8     IAN    DC
          STDL   STATUS      SAVE BUS ACKNOWLEDGE STATUS
          SFM    BCS25,DC    IF ERROR FLAG SET
          LPDL   FF
          NJN    BCS16       IF BUS ACKNOWLEDGE IS WRONG
          LDDL   LF          LAST FUNCTION
          LMN    0#32
          RJM    FUNC        DROP SYNC OUT
          ACN    DC
          LDN    77B
 BCS12    FJM    BCSX,DC     IF SYNC IN DROPPED
          SBN    1
          NJN    BCS12       IF TIMEOUT NOT EXPIRED
          LDK    E23         SYNC IN DID NOT DROP
          UJN    BCS20
 BCS16    BSS
          LDK    E37         BUS ACKNOWLEDGE WRONG
 BCS20    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 BCS25    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- CPT
*
** PURPOSE-- COMMAND PACKET TRANSFER
*
** INPUT-- A = COMMAND PACKET FWA
*              BIT 17 - BYAPSS SEL AND DCM SUBROUTINES
          SPACE  2
 CPT30    LDN    EVENOT      USE EVEN OCTET TRANSFER ENCODED STATUS
          RJM    GES         GET ENDING STATUS
          LDDL   CPTBP       CHECK FOR BYPASS DCM
          LPN    1
          NJN    CPT35       IF YES
          RJM    DCM         DESELECT THE SLAVE

 CPT35    LDDL   WC
          ZJN    CPT40       IF ALL WORDS TRANSFERRED
          LDK    E29         INCOMPLETE TRANSFER
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)

 CPT40    LDML   *           GET COMMAND CODE SENT
 CPTA     EQU    *-1
          LPN    CMCHN       CHECK FOR COMMAND CHAINING
          STML   /TS/P.CHAIN,CTST  SET CHAINING FLAG

 CPT      SUBR               ENTRY/EXIT

          SHN    1           SAVE BYPASS BIT AS BIT 0
          STDL   CPTBP       SAVE IT
          SHN    17          RESTORE ORIGINAL FWA
          STML   CPTC        INITIALIZE INSTRUCTIONS
          STML   CPTD
          ADN    OPCD        ADJUST TO OPCODE
          STML   CPTA        FOR CHAINING FLAG

 KHCPT    EQU    KH+KHC
 KH1      IFNE   KHCPT,0     COMMAND HISTORY
          SBN    OPCD        RESET ADDRESS
          STML   CPTB        INITIALIZE INSTRUCTION ADDRESS
          LCN    0           INDICATE COMMAND
          STML   HB,HBP
          AODL   HBP         INCREMENT DESTINATION INDEX
          ADN    7           COMPUTE LOOP LIMIT
          STML   CPTE        SET LOOP LIMIT

 CPT10    LDML   *           GET COMMAND WORD
 CPTB     EQU    *-1
          STML   HB,HBP      PUT INTO HISTORY LIST
          AOML   CPTB        INCREMENT SOURCE ADDRESS
          AODL   HBP         INCREMENT DESTINATION INDEX
          SBML   CPTE        CHECK FOR ENTRY LIMIT
          NJN    CPT10       IF NOT, LOOP
          LDDL   HBP         CHECK FOR BUFFER LIMIT
          ADK    -HBL
          NJN    CPT15       IF NOT
          STDL   HBP
 CPT15    BSS
 KH1      ENDIF

          LDDL   CPTBP       CHECK FOR BYPASS SEL
          LPN    1
          NJN    CPT18       IF YES
          RJM    SEL         SELECT THE SLAVE

 CPT18    LDK    CMDOUT      BUS A FOR COMMAND
          RJM    BCS         BUS CONTROL SEQUENCE
          LDK    H0381       STREAM, WRITE
          RJM    FUNC        RAISE MASTER OUT
          ACN    DC
          LDML   *           GET PACKET LENGTH
 CPTC     EQU    *-1
          ADN    3
          SHN    -1          CONVERT BYTE COUNT TO WORD COUNT
          OAM    *,DC        SEND COMMAND PACKET
 CPTD     EQU    *-1
          CFM    CPT20,DC    IF CHANNEL ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 CPT20    BSS
          STDL   WC          SAVE RESIDUAL WORD COUNT
          RJM    WSID        WAIT FOR SLAVE IN TO DROP
          UJK    CPT30
          SPACE  2
 KHLIM    EQU    KH+KHC+KHR
 KH1A     IFNE   KHLIM,0     COMMAND HISTORY
 CPTE     BSSZ   1           LIMIT ADDRESS
 KH1A     ENDIF
          SPACE  5,20
** NAME-- RPT
*
** PURPOSE-- RESPONSE PACKET TRANSFER
*
** OUTPUT
*         RPB - STARTING LOCATION OF RESPONSE PACKET
          SPACE  2
 RPT20    BSS
          STDL   WC          SAVE WORDS NOT TRANSFERRED
 RPT30    BSS
          LDN    EVENOT      USE EVEN OCTET TRANSFER ENCODED STATUS
          RJM    GES         GET ENDING STATUS

 KHRPT    EQU    KH+KHR
 KH2      IFNE   KHRPT,0     RESPONSE HISTORY
          LCN    77B         INDICATE RESPONSE
          STML   HB,HBP
          LDML   RPB         PACKET LENGTH
          STML   HB+1,HBP
          LDML   RPB+1       COMMAND REFERENCE NUMBER
          STML   HB+2,HBP
          LDML   RPB+2       COMMAND
          STML   HB+3,HBP
          LDML   RPB+3       SLAVE/FACILITY
          STML   HB+4,HBP
          LDML   RPB+4       MAJOR STATUS
          STML   HB+5,HBP
          LDML   RPB+5       PARAMETERS (IF ANY)
          STML   HB+6,HBP
          LDML   RPB+6
          STML   HB+7,HBP
          LDN    8
          RADL   HBP         UPDATE HISTORY BUFFER POINTER
          ADK    -HBL        CHECK IF FULL
          NJN    RPT35       IF NOT FULL YET
          STDL   HBP         RESET POINTER
 RPT35    BSS
 KH2      ENDIF

          LDDL   WC
          ZJN    RPTX        IF ALL WORDS TRANSFERRED
          LDK    E29         INCOMPLETE TRANSFER
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)

 RPT      SUBR               ENTRY/EXIT

          LDK    RSPIN       BUS A FOR RESPONSE
          RJM    BCS         BUS CONTROL SEQUENCE
          LDK    H0281       STREAM, READ
          RJM    FUNC        SET MASTER OUT
          ACN    DC
          LDN    5
          IAM    RPB,DC      INPUT REQUIRED WORDS
          CFM    RPT2,DC     IF CHANNEL ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 RPT2     BSS
          NJK    RPT20       IF NOT ALL WORDS RECEIVED
          LDML   RPB         BYTE COUNT MINUS 2
          ADN    3
          SHN    -1
          SBN    5
          ZJN    RPT4        IF ALL WORDS TRANSFERRED
          LPK    377B        PROTECT AGAINST ILLEGAL LENGTH
          IAM    RPB+5,DC    INPUT REMAINING WORDS
          CFM    RPT3,DC     IF CHANNEL ERROR FLAG IS CLEAR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 RPT3     BSS
          NJN    RPT2        IF NOT ALL WORDS TRANSFERRED
 RPT4     BSS
          STDL   WC          WORDS NOT TRANSFERRED
          RJM    WSID        WAIT FOR SLAVE IN TO DROP
          UJK    RPT30
          SPACE  5,20
** NAME-- GES
*
** PURPOSE-- GET ENDING STATUS
*
** INPUT-- A = MASTER ENCODED ENDING STATUS IN LOWER 4 BITS
*
** OUTPUT--
*         RETURNS TO CALLING PROGRAM IF STATUS IS READ WITHOUT ERROR
*         AND SUCCESSFUL IS SET IN STATUS
          SPACE  2
 GES      SUBR               ENTRY/EXIT
          SHN    8           POSITION MASTER ENCODED ENDING STATUS
          ADK    H8039       INDICATE SUCCESSFUL IN BUS A
          RJM    FUNC        DROP MASTER OUT
          ACN    DC
          LDK    2000        ABOUT 2 MILLISECOND TIMELIMIT
 GES4     FJM    GES8,DC     IF SLAVE IN SET
          SBN    1
          NJN    GES4        IF TIMEOUT NOT EXPIRED
          LDK    E27         SLAVE IN NOT SET
          UJK    GES30
 GES8     IAN    DC
          STDL   STATUS      SAVE ENDING STATUS
          SFM    GES40,DC    IF ERROR FLAG SET
          SHN    17-7
          MJN    GESX        IF SUCCESSFUL
          LDDL   STATUS
          SHN    17-6
          PJN    GES15       IF NOT BUS PARITY
          LDK    E34
          UJN    GES30
 GES15    BSS
          LDDL   STATUS
          LPN    17B
          SBN    2
          MJN    GES25       IF REPORTING -ENDING STATUS WRONG-
          SBN    7
          NJN    GES20       IF NOT -SYNC OUTS NOT EQUAL SYNC INS-
          LDK    E36
          UJN    GES30
 GES20    BSS
          PJN    GES23       IF NOT COMMAND REJECT
 GES22    LDK    E35
          UJN    GES30
 GES23    BSS
          SBN    2
          NJN    GES25       IF NOT INTERNAL SLAVE ERROR
          LDK    E70
          UJN    GES30
 GES25    BSS
          SBN    1           CHECK FOR COMMAND REJECT
          ZJN    GES22       IF YES
          LDK    E39         ENDING STATUS WRONG
 GES30    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 GES40    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- DCM
*
** PURPOSE-- DESELECT THE SLAVE
          SPACE  2
 DCM1     DCN    DC+40B      DEACTIVATE CHANNEL
          SFM    DCM10,DC    IF CHANNEL ERROR FLAG IS SET

 DCM      SUBR               ENTRY/EXIT
          LDK    H0071
          RJM    FUNC        DROP SELECT OUT
          ACN    DC
          LDN    77B
 DCM4     FJM    DCM1,DC     IF SLAVE IN DROPPED
          SBN    1
          NJN    DCM4        IF TIMEOUT NOT EXPIRED
          SFM    DCM10,DC    IF CHANNEL ERROR FLAG IS SET
          LDK    E28         SLAVE IN DID NOT DROP
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 DCM10    RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- WOG
*
** PURPOSE-- WRITE OPERAND GENERATOR.  THIS DETERMINES THE NUMBER OF
*            WORDS TO TRANSFER.  FOR READS TO CM IT DETERMINES THE DATA
*            PATTERN AND FOR WRITES IT SETS THE STARTING VALUE FOR ITS
*            CRC CHECK OF THE DATA.
          SPACE  2
 WOG      SUBR               ENTRY/EXIT
          LDN    H0014       WRITE OPERAND GENERATOR FUNCTION
          RJM    FUNC
          ACN    DC
          LDN    2
          OAM    WOGP,DC     SEND THE PARAMETERS
          RJM    DCN         DISCONNECT THE CHANNEL
          LDC    0#1000      ENABLE TEST MODE
          RJM    WCR         WRITE CONTROL REGISTER
          UJN    WOGX
 WOGP     BSS
          DATA   0#1357      STARTING PATTERN
          DATA   0#8080      STREAM MODE, SYNC COUNT = 128
          SPACE  5,20
** NAME-- TMT
*
** PURPOSE-- TEST MODE TRANSFER
*
** ENTRY
*         A = 0C00 FOR DMA READ
*             0D00 FOR DMA WRITE
          SPACE  2
 TMT      SUBR               ENTRY/EXIT
          RJM    FUNC
          LDC    256
          STDL   T8          T8 CONTROLS THE TIMEOUT
          STML   CM.CB.T     BYTE COUNT
          ACN    DC
          LDN    3
          OAM    CM.CB.T,DC  BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
 TMT10    BSS
          LDC    H0700       READ OPERATIONAL STATUS
          RJM    FUNC
          ACN    DC
          EJM    TMT20,DC    IF ERROR
          IAN    DC
          STDL   OS          SAVE OPERATIONAL STATUS
          SFM    TMT40,DC    IF ERROR FLAG SET
          LPN    1
          ZJN    TMTX        IF TRANSFER COMPLETE
          SODL   T8
          NJN    TMT10       IF TIMEOUT NOT EXPIRED
          LDC    H0A00       READ T REGISTER
          RJM    RDRG        READ REGISTER
          STML   /TS/P.RESBC,CTST  SAVE RESIDUAL BYTE COUNT
          SHN    -1
          STDL   WC          SAVE RESIDUAL WORD COUNT
          LDC    H0800       DMA TERMINATE
          RJM    FAN
          LDC    H00E1       READ STATUS REGISTER
          RJM    RDRG        READ REGISTER
          STDL   STATUS      SAVE CONTENTS OF STATUS REGISTER
          LDN    E29         INCOMPLETE TRANSFER
          UJN    TMT30
 TMT20    BSS
          LDN    E02         CHANNEL EMPTY WHEN ACTIVATED
 TMT30    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
 TMT40    BSS
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- WCR
*
** PURPOSE-- WRITE CONTROL REGISTER
*
** ENTRY--  A = VALUE TO WRITE INTO CONTROL REGISTER
          SPACE  2
 WCR      SUBR               ENTRY/EXIT
          STDL   AT1
          LDC    H0300       WRITE CONTROL REGISTER
          RJM    FUNC
          ACN    DC
          LDDL   AT1
          OAN    DC
          LDN    0
          RJM    DCN         DISCONNECT THE CHANNEL
          UJN    WCRX
          SPACE  5,20
** NAME-- WSID
*
** PURPOSE-- WAIT FOR SLAVE IN TO DROP
*
** EXIT -- RETURN TO CALLER IF SLAVE IN DROPPED BEFORE TIMEOUT.
*          ELSE REPORT ERROR E30 AND DO NOT RETURN TO CALLER.
          SPACE  2
 WSID     SUBR               ENTRY/EXIT
          LDK    MS25        TIMEOUT VALUE (ABOUT 25 MS)
 WSID10   IJM    WSIDX,DC    IF SLAVE IN DROPPED, EXIT
          SBN    1
          NJN    WSID10      IF TIMEOUT NOT EXPIRED
          LDK    E30         CHANNEL STAYED ACTIVE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- DDI
*
** PURPOSE-- DMA DATA INPUT
*
** INPUT-- (/TS/P.ILSTP,CTST) HAS CURRENT INDIRECT LENGTH/ADDRESS PAIR
*          (WC) HAS CHANNEL WORD COUNT TO TRANSFER
*
** EXIT-- PREVIOUS T PRIME (BC THRU RMA) MOVED TO (TBC THRU TRMA+1).
*         RETURN WITH A=0.
          SPACE  2
 DDI      SUBR               ENTRY/EXIT
          LDN    2           MOVE PREVIOUS T PRIME REGESTER CONTENTS
          STDL   T8          LOOP COUNT MINUS 1
 DDI10    LDML   BC,T8       GET SOURCE WORD
          STML   TBC,T8      MOVE IT
          SODL   T8          CHECK IF DONE
          PJN    DDI10       IF NOT LOOP
          LDC    H0C00       DMA READ
          RJM    FUNC
          ACN    DC
          LDDL   WC          GET REQUESTED WORD COUNT
          SHN    1           CONVERT TO BYTE COUNT
          STDL   BC          SET T REGISTER BYTE COUNT PARAMETER
          LDML   /TS/P.ILSTP+2,CTST  INITIALIZE T REG. DATA RMA
          STDL   RMA
          LDML   /TS/P.ILSTP+3,CTST
          STDL   RMA+1
          LDN    3
          OAM    BC,DC       OUTPUT T REGISTER PARAMETERS
          RJM    DCN         DISCONNECT THE CHANNEL
          UJN    DDIX        EXIT
          SPACE  5,20
** NAME-- DDO
*
** PURPOSE-- DMA DATA OUTPUT
*
** INPUT-- (/TS/P.ILSTP,CTST) HAS CURRENT INDIRECT LENGTH/ADDRESS PAIR
*          (WC) HAS CHANNEL WORD COUNT TO TRANSFER
*
** EXIT-- A=0
          SPACE  2
 DDO      SUBR               ENTRY/EXIT
          LDC    H0D00       DMA WRITE
          RJM    FUNC
          ACN    DC
          LDDL   WC          GET REQUESTED WORD COUNT
          SHN    1           CONVERT TO BYTE COUNT
          STDL   BC          SET T REGISTER BYTE COUNT PARAMETER
          LDML   /TS/P.ILSTP+2,CTST  INITIALIZE T REG. DATA RMA
          STDL   RMA
          LDML   /TS/P.ILSTP+3,CTST
          STDL   RMA+1
          LDN    3
          OAM    BC,DC       OUTPUT T REGISTER PARAMETERS
          RJM    DCN         DISCONNECT THE CHANNEL
          UJN    DDOX        EXIT
          SPACE  5,20
** NAME-- WFTE
*
** PURPOSE-- WAIT FOR T PRIME REGISTER EMPTY
*
** EXIT -- A = 0 IF OK
*             NZ IF INCOMPLETE TRANSFER
          SPACE  2
 WFTE5    LDN    0           EXIT A=0

 WFTE     SUBR               ENTRY/EXIT

          LDC    2000        ABOUT 20 MILLISECONDS LIMIT
          STDL   T8          T8 CONTROLS THE TIMEOUT

 WFTE10   RJM    ROSR        READ OPERATIONAL STATUS REGISTER
          SHN    17-1        CHECK T PRIME REGISTER EMPTY
          MJN    WFTE5       IF YES
          SHN    17-6-17+1+18  CHECK IPI TRANSFER IN PROGRESS
          PJN    WFTE20      IF NOT
          SODL   T8
          NJN    WFTE10      IF TIMEOUT NOT EXPIRED

 WFTE20   LDN    1           INDICATE INCOMPLETE TRANSFER
          UJK    WFTEX       EXIT
          SPACE  5,20
** NAME-- ROSR
*
** PURPOSE-- READ OPERATIONAL STATUS REGISTER
*
** EXIT -- A AND (OS) = OPERATIONAL STATUS
          SPACE  2
 ROSR     SUBR               ENTRY/EXIT
          LDC    H0700
          RJM    FAN         READ OPERATIONAL STATUS
          AJM    ROSR30,DC   IF NO ADAPTER FUNCTION REPLY
          ACN    DC          ACTIVATE CHANNEL FOR INPUT
          EJM    ROSR10,DC   IF ADAPTER IS NOT RESPONDING
          IAN    DC
          STDL   OS          SAVE OPERATIONAL STATUS
          UJN    ROSRX       EXIT

 ROSR10   LDN    E02         CHANNEL EMPTY WHEN ACTIVATED

 ROSR20   RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)

 ROSR30   LDN    E01         FUNCTION TIMEOUT
          UJN    ROSR20      PROCESS THIS ERROR
          SPACE  5,20
** NAME-- WFTC
*
** PURPOSE-- WAIT FOR TRANSFER COMPLETE ON FIXED LENGTH RECORD.
*
** ENTRY-- A = 0 WAIT FOR COMPLETION,
*             NZ PROCESS INCOMPLETE TRANSFER.
*
** EXIT-- RETURN TO CALLING ROUTINE IF TRANSFER COMPLETED,
*         ELSE TO ERROR PROCESSING.
          SPACE  2
 WFTC10   STML   /TS/P.RESBC,CTST  CLEAR RESIDUAL BYTE COUNT

 WFTC     SUBR               ENTRY/EXIT
          NJN    WFTC30      IF PROCESS INCOMPLETE TRANSFER
          LDC    2106        ABOUT 20 MILLISECONDS LIMIT
          STDL   T8          T8 CONTROLS THE TIMEOUT

 WFTC20   RJM    ROSR        READ OPERATIONAL STATUS REGISTER
          LPN    1           CHECK TRANSFER IN PROGRESS
          ZJN    WFTC10      IF DONE
          SODL   T8
          NJN    WFTC20      IF TIMEOUT NOT EXPIRED

 WFTC30   UJN    ITVLR       PROCESS INCOMPLETE TRANSFER
          SPACE  5,20
** NAME-- ITVLR
*
** PURPOSE-- PROCESS INCOMPLETE TRANSFER VARIABLE LENGTH READ.
*
** NOTE-- THE DMA LOGIC WILL BE HARDWARE MASTER CLEARED WHEN ROUTINE *EP*
*         CALLS FOR A LOGICIAL INTERFACE RESET.
          SPACE  2
 ITVLR    LDC    H0800       DMA TERMINATE FUNCTION
          RJM    FAN
          LDC    H0E00       CLEAR T REGISTER FUNCTION
          RJM    FAN
          LDC    H00E1       READ IPI STATUS REGISTER FUNCTION
          RJM    RDRG        READ THE REGISTER
          STDL   STATUS      SAVE IT
          SHN    17-11       CHECK FOR SLAVE IN
          MJN    ITVLR10     IF SLAVE IN DID NOT DROP
          LDN    E29         REPORT INCOMPLETE TRANSFER
          UJN    ITVLR20

 ITVLR10  LDN    E30         REPORT SLAVE IN DID NOT DROP

 ITVLR20  RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING  (NO RETURN)
          SPACE  5,20
** NAME-- WVTC
*
** PURPOSE-- WAIT FOR VARIABLE LENGTH TRANSFER TO COMPLETE.
*
** EXIT-- RETURN TO CALLER WHEN TRANSFER COMPLETES WITH (/TS/P.RESBC,CTST)
*         SET TO RESIDUAL BYTE COUNT IF ANY.
*         ELSE GO TO ERROR PROCESSING.
          SPACE  2
**        MEMORY CELL EQUATES.
 OBC      EQU    T1          ORIGINAL BYTE COUNT THIS T REGISTER
 ORMAU    EQU    T2          ORIGINAL RMA UPPER THIS T REGISTER
 ORMAL    EQU    T3          ORIGINAL RMA LOWER THIS T REGISTER

 ARBC     EQU    T4          ACTUAL RESIDUAL BYTE COUNT
 ARRMAU   EQU    T5          ACTUAL RESIDUAL RMA UPPER
 ARRMAL   EQU    T6          ACTUAL RESIDUAL RMA LOWER
          SPACE  4
 WVTC     SUBR               ENTRY/EXIT

          LDC    2106        ABOUT 20 MILLISECOND TIMEOUT LIMIT
          STDL   T8

*         CHECK IF IPI TRANSFER IN PROGRESS HAS DROPPED.
 WVTC10   RJM    ROSR        READ OPERATIONAL STATUS REGISTER
          SHN    17-6        CHECK IPI TRANSFER IN PROGRESS
          PJN    WVTC20      IF IPI TIP HAS DROPPED
          SODL   T8
          NJN    WVTC10      IF TIMEOUT NOT EXPIRED
          UJK    ITVLR       PROCESS ERROR

*         PREPARE TO PROCESS VARIABLE LENGTH RECORD.
 WVTC20   LDK    37          MAXIMUM LOOP COUNT = ABOUT 1 MILLISECOND
          STDL   T8
          LDN    4           SET END CASE RECHECK COUNTER
          STDL   P6          MAXIMUM RECHECK = ABOUT 100 MICROSECONDS

*         CHECK IF VARIABLE LENGTH DMA READ HAS COMPLETED.
 WVTC30   LDC    H0A00       READ T REGISTER FUNCTION
          RJM    FAN
          AJM    ROSR30,DC   IF NO ADAPTER FUNCTION REPLY
          ACN    DC          ACTIVATE CHANNEL FOR INPUT
          EJM    ROSR10,DC   IF ADAPTER IS NOT RESPONDING
          LDN    3           INPUT WORD COUNT
          IAM    ARBC,DC     INPUT ACTUAL T REGISTER
          NJK    ITVLR       IF INPUT ERROR
          RJM    ROSR        READ OPERATIONAL STATUS REGISTER
          SHN    17-0        CHECK TRANSFER IN PROGRESS
          MJN    WVTC35      IF FIXED LENGTH RECORD IS NOT DONE
          LDN    0           CLEAR RESIDUAL BYTE COUNT
          STML   /TS/P.RESBC,CTST
          UJK    WVTCX       RETURN

 WVTC35   SHN    17-1-17+0+18  CHECK IF T PRIME IS EMPTY
          MJN    WVTC40      IF YES
          LDK    TBC         ELSE USE LAST LOADED T REGISTER FOR COMPARE
          UJN    WVTC50

 WVTC40   LDK    BC          USE LAST LOADED T PRIME REGISTER FOR COMPARE

*         BUILD ORIGINAL T REGISTER CONTENTS.
 WVTC50   STDL   T7          SET ADDRESS INDEX
          LDML   0,T7        GET LAST LOADED BYTE COUNT
          STDL   OBC         SET ORIGINAL BYTE COUNT
          LDML   1,T7        GET LAST LOADED RMA
          STDL   ORMAU       SET ORIGINAL RMA
          LDML   2,T7
          STDL   ORMAL

*         CALCULATE FINAL RMA OF DMA TRANSFER.
          LDDL   OBC         GET ORIGINAL BYTE COUNT
          SBDL   ARBC        DECREMENT BY ACTUAL BYTE COUNT RESIDUAL
*         CHECK IF LAST FULL CM WORD TRANSFER ENDED ON THE T REGISTER BOUNDARY.
          ZJN    WVTC60      IF YES
*         CHECK IF ONLY T PRIME REGISTER BC HAS TRANSFERED INTO T REGISTER.
          MJN    WVTC70      IF YES BYPASS COMPARE UNTIL RMA CATCHES UP
          ADN    7           ROUND UP TO NEXT CM WORD RMA
          SCN    7           INSURE CM WORD BOUNDARY
          RADL   ORMAL       COMPUTE FINAL DMA RMA
          SHN    -16
          RADL   ORMAU

*         CHECK IF DMA OPERATION HAS COMPLETED.
 WVTC60   LDDL   ORMAL       COMPARE ORIGINAL RMA TO ACTUAL RMA
          SBDL   ARRMAL      COMPARE LOWER HALF RMA
          NJN    WVTC70      IF NOT DONE YET
          LDDL   ORMAU
          SBDL   ARRMAU      COMPARE UPPER HALF RMA
          ZJN    WVTC80      IF THE DMA OPERATION HAS COMPLETED

*         CHECK IF TIMELIMIT HAS BEEN EXCEEDED.
 WVTC70   SODL   T8          DECREMENT LOOP COUNT
          NJK    WVTC30      IF NOT  LOOP
          UJK    ITVLR       PROCESS INCOMPLETE TRANSFER

*         PROCESS DMA OPERATION COMPLETION.
 WVTC80   LDDL   ARBC        SET RESIDUAL BYTE COUNT IF ANY
          STML   /TS/P.RESBC,CTST
          LDDL   OS          CHECK IF T PRIME IS EMPTY
          SHN    17-1
          MJN    WVTC90      IF IT IS EMPTY
*
*         CHECK FOR END CASE OF FALSE END OF OPERATION (EOP).
*         THIS CAN OCCUR IF T PRIME BC TRANSFERS INTO T BUT T PRIME STATUS
*         IS STILL NOT EMPTY AND THE CM DATA FIFO IS BACKED UP DURING THE
*         LAST 16 CM WORDS OF A PARTIAL RECORD.
*
*         CHECK OPERATION COMPLETE SEVERAL MORE TIMES, IF IT IS STILL
*         EOP AFTER THE RECHECKS THEN IT MUST BE A REAL EOP.
          SODL   P6          DECREMENT RECHECK COUNTER
          NJK    WVTC30      IF NOT DONE RECHECKING

*         CONTINUE PROCESSING END OF OPERATION.
          LDDL   WC          INCLUDE T PRIME IN RESIDUAL BYTE COUNT
          SHN    1           CONVERT TO BYTES
          RAML   /TS/P.RESBC,CTST

*         CLEAN UP DMA HARDWARE FROM THE PARTIAL READ OPERATION.
 WVTC90   LDC    H0800       DMA TERMINATE TO CLEAR DMA LOGIC
          RJM    FAN
          LDC    H0E00       CLEAR T REGISTER FUNCTION
          RJM    FAN
          UJK    WVTCX       EXIT
          SPACE  2
*         SAVED T REGISTER CONTENTS FROM SUBROUTINE *DDI*.
 TBC      BSSZ   1           T BYTE COUNT
 TRMA     BSSZ   2           T RMA
          SPACE  5,20
** NAME-- REL
*
** PURPOSE-- READ ERROR LOG
*
** NOTE-- IF A SUBROUTINE CALLS THIS SUBROUTINE IT MUST SAVE ITS RETURN
*         ADDRESS BECAUSE A TS TABLE SWITCH WILL OCCUR.
          SPACE  2
 REL1     LDML   /TS/P.SREL,CTST  RESTORE RETURN ADDRESS
          STML   REL

 REL      SUBR               ENTRY/EXIT
          LDML   REL         SAVE RETURN ADDRESS
          STML   /TS/P.SREL,CTST
          AOIL   CTST        INCREMENT COMMAND REFERENCE NUMBER
          STML   RELCP1
          LDC    RELCP       COMMAND PACKET FWA
          RJM    CPT         COMMAND PACKET TRANSFER
 REL5     LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMC    TN*16       CHECK FOR TRANSFER NOTIFICATION
          ZJN    REL20       IF YES
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    REL5        IF ASYNC
 REL20    LDIL   CTST        CHECK IF COMMAND REFERENCE NUMBERS AGREE
          LMML   RPB+CRN
          NJK    REL50       IF NOT
          RJM    SEL         SELECT SLAVE
          LDN    DATAIN      BUS A FOR DATA IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0281       STREAM AND READ
          RJM    FUNC
          ACN    DC
          LDN    17          WORD COUNT
          IAM    RPB+72,DC   INPUT TO THE RESPONSE PACKET BUFFER
          STDL   WC          SAVE RESIDUAL WORD COUNT
          RJM    WSID        WAIT FOR SLAVE IN TO DROP
          LDN    EVENOT      USE EVEN OCTET MASTER ENCODED ENDING STATUS
          RJM    GES         GET ENDING STATUS
          RJM    DCM         DESELECT SLAVE
          LDDL   WC          CHECK IF INCOMPLETE TRANSFER
          NJN    REL80       IF YES
 REL40    LDN    1           SECONDS LIMIT
          RJM    IH          INTERRUPT HANDLER
          LMN    CCS         CHECK FOR COMMAND COMPLETE SUCCESSFUL
          ZJK    REL1        IF YES  EXIT
          LDN    0           DO NOT EXPECT BLOCK ID
          RJM    CMDRESP     COMMAND RESPONSE DECODE
          UJN    REL40       IF ASYNC

 REL50    LDK    E76         UNEXPECTED STATUS
          UJN    REL90
 REL80    LDN    E29         INCOMPLETE TRANSFER
 REL90    RJM    PCER        PREPARE COMMON ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  4
*         -READ ERROR LOG-  COMMAND PACKET
 RELCP    DATA   0#0006      PACKET LENGTH
 RELCP1   DATA   0#FFFF      COMMAND REFERENCE NUMBER
 RELCP3   CON    OCREL+CMCHN+OMRELC  OP-CODE, CLEAR LOG AND CHAIN
 RELCP5   DATA   0#FFFF      ADDRESSEE
          SPACE  2
 V1       IFEQ   VALID,1     VALIDATE CPU TABLES/BUFFERS
          TITLE  VALIDATE CPU TABLES/BUFFERS
** NAME-- CHKPIT
*
** PURPOSE-- CHECK FOR VALID PP INTERFACE TABLE
          SPACE  2
 CHKPIT   SUBR               ENTRY/EXIT
          LDN    0
          STDL   T8
          LDML   PITB+/PIT/P.CBUFL  COMMUNICATION BUFFER LENGTH
          LPN    7
          NJK    CHKP100     IF LENGTH NOT A MULTIPLE OF WORDS

          AODL   T8
          LDML   PITB+/PIT/P.CBUFL-1  RESERVED WORD OF PP COMMUNICATION
                             BUFFER DESCRIPTOR
          NJK    CHKP100     IF RESERVED WORD NOT ZERO

          AODL   T8
          LDML   PITB+/PIT/P.CBUF+1  COMMUNICATION BUFFER (RMA)
          LPN    7
          NJK    CHKP100     IF PP COMMUNICATION BUFFER NOT A WORD BOUNDARY

          AODL   T8
          LDML   PITB+/PIT/P.PPQPVA-1  RESERVED FIELD OF PP REQUEST
                             QUEUE DESCRIPTOR
          ADML   PITB+/PIT/P.PPQ-1
          NJK    CHKP100     IF RESERVED FIELD NOT ZERO

          AODL   T8
          LDML   PITB+/PIT/P.INT+1  INTERRUPT WORD (RMA)
          LPN    7
          NJK    CHKP100     IF INTERRUPT WORD NOT A WORD BOUNDARY
          AODL   T8
          LDML   PITB+/PIT/P.CHAN+1  CHANNEL TABLE (RMA)
          LPN    7
          NJN    CHKP100     IF CHANNEL TABLE NOT ON A WORD BOUNDARY

          AODL   T8
          LDML   PITB+/PIT/P.IN-3  IN POINTER RESERVED FIELD
          ADML   PITB+/PIT/P.IN-2
          ADML   PITB+/PIT/P.IN-1
          NJN    CHKP100     IF NON ZERO

          AODL   T8
          LDML   PITB+/PIT/P.OUT-3  OUT POINTER RESERVED FIELD
          ADML   PITB+/PIT/P.OUT-2
          ADML   PITB+/PIT/P.OUT-1
          NJN    CHKP100     IF NON ZERO

          AODL   T8
          LDML   PITB+/PIT/P.LIMIT-3  LIMIT POINTER RESERVED FIELD
          ADML   PITB+/PIT/P.LIMIT-2
          ADML   PITB+/PIT/P.LIMIT-1
          ZJK    CHKPITX     IF OK, EXIT

 CHKP100  BSS
          LDML   CHKPA,T8    INTERFACE ERROR CODE
          RJM    INTERR      SEND ERROR TO CM (NO RETURN)

 CHKPA    BSS
          CON    E20B        COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS
          CON    E204        RESERVED WORD OF PP COMMUNICATION
                             BUFFER DESCRIPTOR NOT ZERO
          CON    E203        PP COMMUNICATION BUFFER NOT A WORD BOUNDARY
          CON    E205        RESERVED FIELD OF PP REQUEST QUEUE
                             DESCRIPTOR NOT ZERO
          CON    E211        RMA OF INTERRUPT WORD NOT A WORD BOUNDARY
          CON    E212        RMA OF CHANNEL TABLE NOT A WORD BOUNDARY
          CON    E20D        RESERVED FIELD OF IN POINTER IS NOT ZERO
          CON    E20E        RESERVED FIELD OF OUT POINTER IS NOT ZERO
          CON    E20F        RESERVED FIELD OF LIMIT POINTER IS NOT ZERO
          SPACE  5,20
** NAME-- CHKUD
*
** PUPOSE-- CHECK FOR VALID UNIT DESCRIPTOR
*
** ENTRY-- UX IS INDEX INTO UNITS TABLE
*          UNIT DESCRIPTOR IS IN UNITD BUFFER
          SPACE  2
 CHKUD    SUBR               ENTRY/EXIT
          LDML   UNITS+/UN/P.UIT,UX   CHECK IF DUPLICIATE UNIT
          ADML   UNITS+/UN/P.UIT+1,UX
          ADML   UNITS+/UN/P.UIT+2,UX
          ZJN    CHKUD10     IF NOT DUPLICIATE UNIT
          LDK    E208
          UJN    CHKUD30     GO REPORT ERROR

 CHKUD10  LDML   UNITD+/UD/P.UQT+1   UNIT INTERFACE TABLE RMA
          LPN    7
          ZJN    CHKUD20     IF OK
          LDK    E209        UNIT INTERFACE TABLE NOT A WORD BOUNDARY
          UJN    CHKUD30     GO REPORT ERROR

 CHKUD20  LDML   UNITD+/UD/P.UNIT  CHECK PHYSICAL UNIT NUMBER
          SHN    -3
          ZJN    CHKUDX      IF OK, EXIT
          LDK    E210        INVALID PHYSICAL UNIT NUMBER

 CHKUD30  RJM    INTERR      SEND ERROR TO CM (NO RETURN)
          SPACE  5,20
** NAME-- CHKRS
*
** PURPOSE-- CHECK FOR VALID PP RESPONSE BUFFER
          SPACE  2
 CHKRS    SUBR               ENTRY/EXIT
          LDML   PITB+/PIT/P.RSBUF-2  RESERVED WORD OF RESPONSE
                             BUFFER DESCRIPTOR
          ADML   PITB+/PIT/P.RSBUF-1
          ADML   PITB+/PIT/P.RSPVA-1
          NJN    CHKR100     IF RESERVED FIELD NOT ZERO

          LDML   PITB+/PIT/P.IN-3  RESERVED FIELD OF IN POINTER
          ADML   PITB+/PIT/P.IN-2
          ADML   PITB+/PIT/P.IN-1
          NJN    CHKR100     IF RESERVED FIELD NOT ZERO

          LDML   PITB+/PIT/P.OUT-3  RESERVED FIELD OF OUT POINTER
          ADML   PITB+/PIT/P.OUT-2
          ADML   PITB+/PIT/P.OUT-1
          NJN    CHKR100     IF RESERVED FIELD NOT ZERO

          LDML   PITB+/PIT/P.LIMIT-3
          ADML   PITB+/PIT/P.LIMIT-2
          ADML   PITB+/PIT/P.LIMIT-1
          ZJK    CHKRSX      IF RESERVED FIELD NOT ZERO

 CHKR100  LDK    E207        RESERVED FIELD NOT ZERO
          RJM    INTERR      REPORT ERROR (NO RETURN)
          SPACE  5,20
** NAME-- CHKUIT
*
** PURPOSE-- CHECK FOR VALID UNIT INTERFACE TABLE
*
** ENTRY-- UIT IS IN THE TS TABLE FOR THE PP
          SPACE  2
 CHKUIT   SUBR               ENTRY/EXIT
          LDN    0
          STDL   T8
          LDML   UITB+/UIT/P.LU  UIT UNIT NUMBER
          LMML   UNITD+/UD/P.LU  UD UNIT NUMBER
          NJN    CUT100      LOGICAL UNIT NUMBER MISMATCH
          AODL   T8
          LDML   UITB+/UIT/P.UBUFL-1  RESERVED FIELD OF UNIT
                             COMMUNICATION BUFFER DESCRIPTOR
          NJN    CUT100      RESERVED FIELD IS NOT ZERO

          AODL   T8
          LDML   UITB+/UIT/P.UBUFL  UNIT COMMUNICATION BUFFER LENGTH
          LPN    7
          NJN    CUT100
          AODL   T8
          LDML   UITB+/UIT/P.UBUF+1  UNIT COMMUNICATION BUFFER
          LPN    7
          NJN    CUT100      NOT A WORD BOUNDARY
          AODL   T8
          LDML   UITB+/UIT/P.NEXTPV-1  RESERVED FIELD OF UNIT
                             REQUEST QUEUE DESCRIPTOR
          ADML   UITB+/UIT/P.NEXT-2
          ADML   UITB+/UIT/P.NEXT-1
          ZJK    CHKUITX     IF OK

 CUT100   LDML   CUTA,T8     INTERFACE ERROR CODE
          RJM    INTERR      SEND ERROR TO CM (NO RETURN)

 CUTA     BSS
          CON    E301        LOGICAL UNIT NUMBER MISMATCH
          CON    E303        RESERVED FIELD OF UNIT COMMUNICATION
                             BUFFER DESCRIPTOR IS NOT ZERO
          CON    E307        UNIT COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS
          CON    E302        UNIT COMMUNICATION BUFFER NOT A WORD BOUNDARY
          CON    E305        RESERVED FIELD OF UNIT REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 V1       ENDIF
          TITLE  INITIALIZATION
** NAME-- INIT
*
** PURPOSE-- INITIALIZE DRIVER
*
** INPUT-- DSRTP = CM BYTE-ADDRESS OF THE WORD CONTAINING A POINTER
*                  TO THE PP INTERFACE TABLE.
          SPACE  2
 INIT     BSS                ENTRY POINT

* CLEAR MOST OF PP DIRECT CELLS

          LDK    DCCEND      CLEAR DCCEND DOWN THRU P1
          STDL   T8          SET INDIRECT CELL

 INIT10   LDN    0
          STIL   T8          CLEAR DIRECT CELL
          SODL   T8          CHECK FOR DONE
          PJN    INIT10      IF NOT DONE

* CLEAR PP MEMORY LOCATIONS

*    ON DEADSTART, ALL PP LOCATIONS FROM ENDCODE THRU ENDMEM ARE CLEARED.
*    ON RESUME, ALL THE ABOVE EXCEPT THE PP TS TABLE IS CLEARED.

          LDDL   INITFLG     CHECK IF DEADSTART INITIALIZE
          SBN    2
          ZJN    INIT30      IF RESUME

*         PROCESS DEADSTART INITIALIZE
          LDK    ENDMEM-ENDCODE
          STDL   T1          SET INDEX

 INIT20   LDN    0
          STML   ENDCODE,T1  CLR PP WORD
          SODL   T1          DECREMENT INDEX
          PJN    INIT20      IF NOT DONE LOOP
          UJN    INIT60      CONT.

 INIT30   BSS
*         PROCESS RESUME INITIALIZE
          LDK    ENDMEM-TS-P.TS
          STDL   T1          SET INDEX

 INIT40   LDN    0
          STML   TS+P.TS,T1  CLR PP WORD
          SODL   T1          DECREMENT INDEX
          PJN    INIT40      IF NOT DONE LOOP

          LDN    TS-ENDCODE-1
          STDL   T1          SET INDEX

 INIT50   LDN    0
          STML   ENDCODE,T1  CLR PP WORD
          SODL   T1          DECREMENT INDEX
          PJN    INIT50      IF NOT DONE LOOP

*  READ PP-INTERFACE-TABLE AND UNIT DESCRIPTOR TABLES.  NOTE - THIS IS
*  THE ONLY PLACE THE STATIC FIELDS OF THE PIT AND THE UNIT DESCRIPTOR
*  TABLES ARE READ INTO THE PP.  IF THE UNIT DESCRIPTOR TABLES EVER
*  CONTAIN DYNAMIC FIELDS, THEY MUST BE READ IN WHEN LOOKING FOR UNIT
*  REQUESTS.  ONLY UNIT DESCRIPTORS THAT ARE NOT NULL ENTRIES ARE
*  CONVERETED TO *UN* ENTRIES IN THE PP UNITS TABLE.

 INIT60   LDK    C.PIT       LENGTH OF PIT
          STDL   WC
          REFAD  DSRTP,CM.PIT  REFORMAT CM ADDRESS OF PIT
          LOADC  CM.PIT      LOAD R+A OF PIT
          CRML   PITB,WC     READ PIT

*  REFORMAT ADDRESS OF THE INTERRUPT WORD.

          REFAD  PITB+/PIT/P.INT,CM.INT

*  REFORMAT ADDRESS OF CHANNEL TABLE.

          REFAD  PITB+/PIT/P.CHAN,CM.CHAN

*  REFORMAT ADDRESS OF PP COMMUNICATIONS BUFFER

          REFAD  PITB+/PIT/P.CBUF,CM.COM

*  BUILD T REGISTER FORMAT OF COM BUFFER TEST MODE AREA RMA

          LDML   PITB+/PIT/P.CBUF+1  GET ORIGINAL RMA
          ADK    /CB/P.PTD*2  ADJUST WITH OFFSET TO PATH TEST AREA
          STML   CM.CB.T+2  SAVE IT
          SHN    -16
          ADML   PITB+/PIT/P.CBUF
          STML   CM.CB.T+1
          LDN    0           INITIALIZE BYTE COUNT
          STML   CM.CB.T

*  CHECK LENGTH OF COMMUNICATIONS BUFFER

          LDML   PITB+/PIT/P.CBUFL  GET THE LENGTH
          ADK    -B.CB
          PJN    INIT65      IF OK
          LDK    E20B        REPORT LENGTH ERROR
          RJM    INTERR      INTERFACE ERROR  (NO RETURN)
 INIT65   BSS

*  REFORMAT ADDRESS OF RESPONSE BUFFER.
*  INITIALIZE LIM.

          REFAD  PITB+/PIT/P.RSBUF,CM.RS  REFORMAT ADDRESS OF RESP. BUFFER
          LDML   PITB+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STDL   LIM

          LDML   PITB+/PIT/P.PPNO   SET PP NUMBER
          STDL   PPNO

          LDML   TS1         USE PP TS TABLE
          STDL   CTST

          LDDL   INITFLG     CHECK IF INITIALIZATION IS FROM A RESUME
          SBN    2
          NJN    INIT70      IF NOT
          RJM    RERESP      SEND RESUME RESPONSE
 INIT70   BSS

 V2       IFEQ   VALID,1     VALIDATE CPU TABLES/BUFFERS
          RJM    CHKPIT      VALIDATE PIT
          RJM    CHKRS       VALIDATE RESPONSE BUFFER
 V2       ENDIF

          LDN    0           INITIALIZE LOOP CONTROL
          STDL   T2          NUMBER OF NON-NULL UNIT DESCRIPTORS
          STDL   T4          CM WORD OFFSET INTO UNIT DESCRIPTORS
          LDML   PITB+/PIT/P.UNITC  NUMBER OF UNIT DESCRIPTORS
          STDL   T1
          NJN    INIT80      IF UNITS DEFINED
          LDK    E213        NO DEFINED ACTIVE UNITS
          RJM    INTERR      INTERFACE ERROR (NO RETURN)

 INIT80   LOADC  CM.PIT      LOAD R REGISTER FOR PIT
          ADK    C.PIT       ADVANCE TO START OF UNIT DESCRIPTORS
          ADDL   T4          CM WORD OFFSET OF CURRENT UD
          CRML   UNITD,TWO   READ UD ENTRY INTO PP
          SODL   T1          DECREMENT TOTAL UNIT COUNT FROM PIT
          LDML   UNITD+/UD/P.UQT
          ADML   UNITD+/UD/P.UQT+1
          ZJK    INIT110     IF DUMMY ENTRY, DO NOT COUNT

*         BUILD SLAVE AND UNITS TABLE INDEXES

          LDML   UNITD+/UD/P.CNTRLR  GET SLAVE NUMBER
          LPN    7B
          STDL   SX          SAVE IT
          LDML   UNITD+/UD/P.CNTRLR  GET PORT NUMBER
          SHN    -3          POSITION IT
          LPN    10B         MASK IT
          ADDL   SX          MERGE SLAVE NUMBER  0-0PSSS
          SHN    2
          STDL   SX          SET SLAVES CONFIGURED INDEX
          SHN    -2
          ADDL   SX
          SHN    3
          STDL   UX          SAVE SLAVE OFFSET FOR UNITS TABLE INDEX
          LDML   UNITD+/UD/P.UNIT  GET FACILITY NUMBER
          LPN    7B
          SHN    2
          RADL   UX
          LDML   UNITD+/UD/P.UNIT
          LPN    7B
          RADL   UX          SET UNITS TABLE INDEX

* CHECK FOR CHANGES IN SL AND UN
          ERRNZ  4-P.SL      IF SL HAS CHANGED
          ERRNZ  5-P.UN      IF UN HAS CHANGED
          ERRNZ  40-FACPSL*P.UN  IF FACILITIES PER SLAVE HAS CHANGED

 V3       IFEQ   VALID,1     VALIDATE CPU TABLES/BUFFERS
          RJM    CHKUD       VALIDATE UNIT DESCRIPTORS
          LDK    C.UIT       READ IN UIT AND VALIDATE
          STDL   WC          SAVE WORD COUNT
          LOADF  UNITD+/UD/P.UQT
          CRML   UITB,WC     READ UIT INTO TRANSIENT BUFFER
          RJM    CHKUIT      VALIDATE UIT
          LDML   UITB+/UIT/P.UTYPE   CHECK UNIT TYPE
          ADK    -T698.1
          ZJN    INIT85      IF OK
          LDK    E306        INVALID UNIT TYPE
          RJM    INTERR      REPORT ERROR  (NO RETURN)
 INIT85   BSS
 V3       ENDIF

* BUILD UNITS TABLE

          LDML   UNITD+/UD/P.LU  LOGICIAL UNIT NUMBER
          STML   UNITS+/UN/P.LU,UX

          LOADF  UNITD+/UD/P.UQT  REFORMAT UIT RMA
          LDDL   CMADR       SAVE REFORMATTED UIT RMA
          STML   UNITS+/UN/P.UIT,UX
          LDDL   CMADR+1
          STML   UNITS+/UN/P.UIT+1,UX
          LDDL   CMADR+2
          STML   UNITS+/UN/P.UIT+2,UX

          LDML   UNITD+/UD/P.CHAN      GET CHANNEL NUMBER
          SHN    /UD/L.CHAN+/UD/N.CHAN+2  POSITION IT
          LPN    37B         MASK IT
          STDL   T3          SAVE IT

          LDDL   T2          CHECK IF FIRST ENTRY
          NJN    INIT90      IF NOT
          LDDL   T3          GET CHANNEL NUMBER
          STDL   CURCH       SET CURRENT CHANNEL

 INIT90   LDDL   T3          COMPARE CHANNEL NUMBERS
          LMDL   CURCH
          ZJN    INIT100     IF THE SAME
          LDK    E20A        INVALID CHANNEL NUMBER
          RJM    INTERR      REPORT ERROR (NO RETURN)

 INIT100  LDML   UNITD+/UD/P.UNIT   GET UNIT NUMBER
          LPN    7B
          STDL   T3          SAVE AS BIT SIGNIFICIANT INDEX
          LMK    /UN/K.CTF   SET CONFIDENCE TESTING REQUIRED FLAG
          STML   UNITS+/UN/P.FN,UX  SET FACILITY NUMBER

          LDML   SELT,T3     GET FACILITY BIT ADDRESS
          LMML   SLB+/SL/P.FBA,SX  MERGE WITH EXISTING FACILITIES
          STML   SLB+/SL/P.FBA,SX  SAVE THE UPDATE

          LDML   UNITD+/UD/P.CNTRLR  GET CONTROLER NUMBER
          LPN    7B
          SHN    /UN/N.FN  POSITION IT
          RAML   UNITS+/UN/P.SN,UX   SET SLAVE NUMBER

          LDML   UNITD+/UD/P.CHAN  GET CHANNEL PORT NUMBER
          LPC    100B        MASK IT
          SHN    3           POSITION IT
          RAML   UNITS+/UN/P.PORT,UX  SAVE PORT NUMBER

          AODL   T2          INCREMENT COUNT OF TOTAL ACTIVE UNITS
          ADK    -MAXUD
          ZJN    INIT120     IF REACHED MAX TABLE SPACE FOR UD-S

 INIT110  LDK    C.UD        INCREMENT TO NEXT CM UD
          RADL   T4
          LDDL   T1          CHECK TOTAL UNITS COUNT FROM PIT
          NJK    INIT80      IF NOT DONE SCANNING UD TABLES

 INIT120  LDDL   T1          CHECK IF MORE UD-S
          ZJN    INIT130     IF NONE LEFT
          LDK    E208        TO MANY CONFIGURED UNITS
          RJM    INTERR      REPORT ERROR  (NO RETURN)

 INIT130  LDDL   T2          RESET NUMBER OF ACTIVE UNITS
          STML   PITB+/PIT/P.UNITC
          NJN    INIT150     IF ANY ACTIVE UNITS DEFINED

          LDN    75B         NO ACTIVE UNITS
          STDL   IDLFLG      FORCE SET IDLE FLAG
*         DO NOT GENERATE ANY RESPONSE, WAIT FOR RESUME COMMAND
          LJM    MAIN        GO TO MAIN

*  INITIALIZE CONFIGURED SLAVES BY BIT ADDRESS (CSLVS)
*  AND TOTAL SLAVES CONFIGURED NUMBER (TSLVS) CELLS.

 INIT150  LDN    MAXSL       INITIALIZE LOOP COUNT
          STDL   T1
          LDN    0           INITIALIZE INDEX
          STDL   T2
          STDL   TSLVS       INIT TOTAL SLAVES CONFIGURED

 INIT160  LDML   SLB+/SL/P.FBA,T2  CHECK IF SLAVE IS CONFIGURED
          ZJN    INIT170     IF NOT
          AODL   TSLVS       INCREMENT TOTAL SLAVES CONFIGURED

 INIT170  LDN    P.SL        INCREMENT INDEX
          RADL   T2
          SODL   T1          CHECK FOR DONE
          NJN    INIT160     IF NOT

* INITIALIZE SLAVE TS TABLES USABLE

          LDN    MCSLV       MAXIMUM CONCURRENT SLAVES TO SUPPORT
          SBDL   TSLVS       TOTAL CONFIGURED SLAVES
          MJN    INIT180     USE MAXIMUM VALUE
          LDDL   TSLVS       ELSE USE TOTAL SLAVES CONFIGURED
          UJN    INIT190

 INIT180  LDN    MCSLV       SET MAXIMUM VALUE

 INIT190  BSS
          STML   TNTAB       SAVE TOTAL NUMBER OF SLAVE TABLES TO SUPPORT

*  INITIALIZE CHANNEL INSTRUCTIONS.

          LDK    CONCH       MODIFY CHANNEL INSTRUCTIONS
          RJM    CHGCH

*  CLEAR PP COMMUNICATIONS BUFFER

          LDN    0           ZERO OUT *ZEROES* FIELD IN COMM. BUFFER
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDK    /CB/B.ZEROES  LENGTH OF ZERO AREA IN BYTES
          SHN    -3
          STDL   T5          LENGTH OF ZERO AREA IN CM WORDS

 INIT200  LOADC  CM.COM      LOAD R AND A OF COMMUNICATION BUFFER
          ADK    /CB/C.ZEROES-1
          ADDL   T5
          CWDL   T1          ZERO ONE CM WORD
          SODL   T5          DECREMENT INDEX
          NJN    INIT200     IF MORE CM WORDS TO CLEAR

* CLEAR REMAINING DIRECT CELLS

          LDN    T8          STARTING ADDRESS
          STDL   T1          SET INDIRECT CELL

 INIT210  LDN    0
          STIL   T1          CLEAR DIRECT CELL
          SODL   T1          CHECK FOR DONE
          PJN    INIT210     IF NOT
          LDN    0           CLEAR THE LAST CELL
          STDL   T1

*  EXIT TO MAIN IDLE LOOP

          LJM    MAIN        EXIT
          TITLE  PP TABLES AND BUFFERS
 CONCH    BSS                CHANNEL MODIFICATION LIST
 TDC+40B  HERE
 T40B+DC  HERE
 TDC      HERE
          CON    0           END OF TABLE
          SPACE  2
* BIT SIGNIFICANT SELECTION ADDRESS TABLE
 SELT     DATA   1,2,4,8     PORT A SLAVES
          DATA   16,32,64,128
          DATA   1,2,4,8     PORT B SLAVES
          DATA   16,32,64,128

          ERRNZ  8-SLVPCH    IF NUMBER OF SLAVES PER CHANNEL CHANGES
          SPACE  2
* SLAVE RESET EXECUTED TABLE, INDEXED BY SLAVE ADDRESS PLUS PORT (SLVN)
 SRTAB    BSSZ   MAXSL       NON ZERO ENTRY = SLAVE RESET EXECUTED
          SPACE  2
* TS TABLE ADDRESSES
 TS1      CON    TS          PP TS TABLE
 TS2      CON    TS+1*P.TS   FIRST SLAVE TS TABLE
 TS3      CON    TS+2*P.TS   NEXT TABLE

          ERRNZ  3-MAXTS     IF NUMBER OF TS TABLES CHANGE
          SPACE  2
 ENDCODE  EQU    *           END OF PP CODE AREA

 FH2      IFEQ   FH,1        FUNCTION HISTORY TABLE
          SPACE  2
*
*         WORKING MEMORY
*
 FBUF     BSSZ   64          FUNCTION HISTORY BUFFER
 FBUFL    EQU    *-FBUF      FUNCTION HISTORY BUFFER LENGTH
 FH2      ENDIF
 KHTAB    EQU    KH+KHC+KHR
 KH3      IFNE   KHTAB,0     COMMAND/RESPONSE HISTORY
          SPACE  2
 HB       BSSZ   80          IPI COMMAND/RESPONSE HISTORY BUFFER
*         HB LENGTH MUST BE A MULTIPLE OF 8
 HBL      EQU    *-HB        HISTORY BUFFER LENGTH
 KH3      ENDIF
          SPACE  2
*
*         CHECK FOR BUFFER OVERLAP
*
          ERRNG  STRTBUF-*
          EJECT
          END
/EOR

*DECK DECK=IOM$TAPE_BOOT_MANAGER EXPAND=TRUE
MODULE iom$tape_boot_manager;
? VAR system_version : boolean := FALSE?;
*copy ioi$tape_queue_manager

MODEND iom$tape_boot_manager;
*DECK DECK=IOM$TAPE_COMMAND_PROCEDURES EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Magnetic tape command management routines' ??
?? NEWTITLE := '  IOM$TAPE_COMMAND_PROCEDURES' ??
MODULE iom$tape_command_procedures;

{ Purpose: This module contains code that supports magnetic tape commands.
{

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    one_second = 1000 {milliseconds};

?? TITLE := '    Global Declarations Referenced by this Module', EJECT ??

*copyc cld$value
*copyc dme$tape_errors
*copyc jmt$system_supplied_name
*copyc ofe$error_codes
*copyc osd$integer_limits
*copyc ost$name
*copyc rme$avr_tape_errors
*copyc rmt$external_vsn

?? TITLE := '    Global Procedures Referenced by this Module', EJECT ??

*copyc avp$removable_media_operator
*copyc ifp$invoke_pause_utility
*copyc iop$access_tusl_entry
*copyc iop$determine_density_support
*copyc iop$get_tape_mount_information
*copyc iop$set_assignment_in_tusl
*copyc iop$tape_mount_count
*copyc iop$terminate_assignment
*copyc osp$establish_condition_handler
*copyc osp$disestablish_cond_handler
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pmp$continue_to_cause
*copyc pmp$long_term_wait
*copyc pmp$ready_task
*copyc rmp$log_debug_message

?? TITLE := '    Global Variables referenced this Module', EJECT ??

*copyc iov$tusl_p

?? OLDTITLE ??
?? NEWTITLE := 'iop$assign_device_command', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$assign_device_command
    (    job_name: jmt$system_supplied_name;
         element_name: ost$name;
         external_vsn: rmt$external_vsn;
     VAR status: ost$status);

?? NEWTITLE := '  assign_device_command_handler  ', EJECT ??

    PROCEDURE assign_device_command_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      CASE condition.selector OF
      = ifc$interactive_condition =
        CASE condition.interactive_condition OF
        = ifc$pause_break, ifc$job_reconnect =
          ifp$invoke_pause_utility (ignore_status);
        = ifc$terminate_break =
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
                ignore_status);
          EXIT iop$assign_device_command;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;

    PROCEND assign_device_command_handler;

?? OLDTITLE ??

    VAR
      all_tape_mounts_found: boolean,
      debug_message_logged: boolean,
      density_supported: boolean,
      info_array_index: ost$positive_integers,
      mount_ordinal: ost$positive_integers,
      mount_requests: integer,
      rvl_info_array_p: ^array [1 .. * ] of iot$rvl_entry_information,
      tape_mount_count: integer,
      tusl_ordinal: iot$tusl_ordinal;

    IF NOT avp$removable_media_operator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'removable_media_operator', status);
      RETURN;
    IFEND;

    debug_message_logged := FALSE;
    REPEAT
      IF NOT debug_message_logged THEN
        rmp$log_debug_message (' Calling iop$tape_mount_count');
      IFEND;
      iop$tape_mount_count (tape_mount_count, status);
      IF NOT status.normal THEN
        IF status.condition = dme$unable_to_lock_tape_table THEN
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Waiting for tape table lock');
            debug_message_logged := TRUE;
          IFEND;
          osp$establish_condition_handler (^assign_device_command_handler, {handle block exit} FALSE);
          pmp$long_term_wait (one_second, one_second);
          osp$disestablish_cond_handler;
        ELSE
          tape_mount_count := 0;
          status.normal := TRUE;
        IFEND;
      IFEND;
    UNTIL status.normal;

    IF tape_mount_count <= 0 THEN
      osp$set_status_abnormal (rmc$resource_management_id, rme$no_tape_mount_pending, external_vsn, status);
      RETURN;
    IFEND;

    PUSH rvl_info_array_p: [LOWERBOUND (rvl_info_array_p^) .. tape_mount_count];
    REPEAT
      REPEAT
        IF NOT debug_message_logged THEN
          rmp$log_debug_message (' Calling iop$get_tape_mount_information');
        IFEND;
        iop$get_tape_mount_information (rvl_info_array_p, all_tape_mounts_found, status);
        IF NOT status.normal THEN
          IF status.condition = dme$unable_to_lock_tape_table THEN
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Waiting for tape table lock');
              debug_message_logged := TRUE;
            IFEND;
            osp$establish_condition_handler (^assign_device_command_handler, {handle block exit} FALSE);
            pmp$long_term_wait (one_second, one_second);
            osp$disestablish_cond_handler;
          ELSE
            RETURN;
          IFEND;
        IFEND;
      UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF NOT all_tape_mounts_found THEN
        tape_mount_count := tape_mount_count + 1;
        PUSH rvl_info_array_p: [LOWERBOUND (rvl_info_array_p^) .. tape_mount_count];
      IFEND;
    UNTIL all_tape_mounts_found;

    mount_requests := 0;
  /find_mount_requests/
    FOR info_array_index := LOWERBOUND (rvl_info_array_p^) TO UPPERBOUND (rvl_info_array_p^) DO
      IF rvl_info_array_p^ [info_array_index].null_entry THEN
        EXIT /find_mount_requests/;
      IFEND;
      IF job_name = jmc$blank_system_supplied_name THEN
        IF rvl_info_array_p^ [info_array_index].current_vsn = external_vsn THEN
          mount_requests := mount_requests + 1;
          mount_ordinal := info_array_index;
        IFEND;
      ELSE
        IF (rvl_info_array_p^ [info_array_index].current_vsn = external_vsn) AND
              (rvl_info_array_p^ [info_array_index].ssn = job_name) THEN
          mount_requests := 1;
          mount_ordinal := info_array_index;
          EXIT /find_mount_requests/;
        IFEND;
      IFEND;
    FOREND;

    IF mount_requests = 0 THEN
      osp$set_status_abnormal (rmc$resource_management_id, rme$no_tape_mount_pending, external_vsn, status);
      RETURN;
    IFEND;

    IF mount_requests > 1 THEN
      osp$set_status_abnormal (rmc$resource_management_id, rme$system_name_required, external_vsn, status);
      RETURN;
    IFEND;

  /scan_tusl/
    BEGIN
      FOR tusl_ordinal := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
        IF iov$tusl_p^ [tusl_ordinal].element_name = element_name THEN
          EXIT /scan_tusl/;
        IFEND;
      FOREND;
      osp$set_status_abnormal (rmc$resource_management_id, rme$undefined_element_name, element_name, status);
      RETURN;
    END /scan_tusl/;

    iop$determine_density_support (iov$tusl_p^ [tusl_ordinal].unit_type,
          rvl_info_array_p^ [mount_ordinal].requested_tape_characteristics.density, density_supported);
    IF NOT density_supported THEN
      osp$set_status_abnormal (rmc$resource_management_id, rme$density_not_supported, element_name, status);
      RETURN;
    IFEND;

    debug_message_logged := FALSE;
    REPEAT
      IF NOT debug_message_logged THEN
        rmp$log_debug_message (' Calling iop$set_assignment_in_tusl');
      IFEND;
      iop$set_assignment_in_tusl (tusl_ordinal, rvl_info_array_p^ [mount_ordinal].sfid,
            rvl_info_array_p^ [mount_ordinal].ssn, external_vsn, status);
      IF NOT status.normal THEN
        IF status.condition = dme$unable_to_lock_tape_table THEN
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Waiting for tape table lock');
            debug_message_logged := TRUE;
          IFEND;
          osp$establish_condition_handler (^assign_device_command_handler, {handle block exit} FALSE);
          pmp$long_term_wait (one_second, one_second);
          osp$disestablish_cond_handler;
        ELSE
          RETURN;
        IFEND;
      IFEND;
    UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);

  PROCEND iop$assign_device_command;

?? TITLE := '    IOP$REASSIGN_DEVICE_COMMAND', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$reassign_device_command
    (    element_name: ost$name;
     VAR status: ost$status);

?? NEWTITLE := '  reassign_device_command_handler  ', EJECT ??

    PROCEDURE reassign_device_command_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      CASE condition.selector OF
      = ifc$interactive_condition =
        CASE condition.interactive_condition OF
        = ifc$pause_break, ifc$job_reconnect =
          ifp$invoke_pause_utility (ignore_status);
        = ifc$terminate_break =
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
                ignore_status);
          EXIT iop$reassign_device_command;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;

    PROCEND reassign_device_command_handler;

?? OLDTITLE ??

    VAR
      debug_message_logged: boolean,
      local_status: ost$status,
      tusl_entry_access: iot$tusl_entry_access,
      tusl_ordinal: iot$tusl_ordinal;

    status.normal := TRUE;

    IF NOT avp$removable_media_operator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'REMOVABLE_MEDIA_OPERATOR', status);
      RETURN;
    IFEND;

  /scan_tusl/
    BEGIN

      FOR tusl_ordinal := LOWERBOUND (iov$tusl_p^) TO UPPERBOUND (iov$tusl_p^) DO
        IF iov$tusl_p^ [tusl_ordinal].element_name = element_name THEN
          EXIT /scan_tusl/;
        IFEND;
      FOREND;

      osp$set_status_abnormal (rmc$resource_management_id, rme$undefined_element_name, element_name, status);
      RETURN;

    END /scan_tusl/;

    debug_message_logged := FALSE;
    REPEAT
      IF NOT debug_message_logged THEN
        rmp$log_debug_message (' Calling iop$access_tusl_entry');
      IFEND;
      tusl_entry_access.operation := ioc$set_operator_reassign;
      iop$access_tusl_entry (tusl_ordinal, tusl_entry_access, status);
      IF NOT status.normal THEN
        IF status.condition = dme$unable_to_lock_tape_table THEN
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Waiting for tape table lock');
            debug_message_logged := TRUE;
          IFEND;
          osp$establish_condition_handler (^reassign_device_command_handler, {handle block exit} FALSE);
          pmp$long_term_wait (one_second, one_second);
          osp$disestablish_cond_handler;
        IFEND;
      IFEND;
    UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);

  PROCEND iop$reassign_device_command;

?? TITLE := '    IOP$TERMINATE_TAPE_ASSIGNMENT', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$terminate_tape_assignment
    (    external_vsn: rmt$external_vsn;
         message: string (osc$max_string_size);
         ssn: jmt$system_supplied_name;
     VAR status: ost$status);

?? NEWTITLE := '  term_tape_assignment_handler  ', EJECT ??

    PROCEDURE term_tape_assignment_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      CASE condition.selector OF
      = ifc$interactive_condition =
        CASE condition.interactive_condition OF
        = ifc$pause_break, ifc$job_reconnect =
          ifp$invoke_pause_utility (ignore_status);
        = ifc$terminate_break =
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
                ignore_status);
          EXIT iop$terminate_tape_assignment;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;

    PROCEND term_tape_assignment_handler;

?? OLDTITLE ??

    VAR
      all_tape_mounts_found: boolean,
      debug_message_logged: boolean,
      info_array_index: ost$positive_integers,
      mount_requests: integer,
      mount_ordinal: ost$positive_integers,
      rvl_info_array_p: ^array [1 .. * ] of iot$rvl_entry_information,
      tape_mount_count: integer;

    IF NOT avp$removable_media_operator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'REMOVABLE_MEDIA_OPERATOR', status);
      RETURN;
    IFEND;

    debug_message_logged := FALSE;
    REPEAT
      IF NOT debug_message_logged THEN
        rmp$log_debug_message (' Calling iop$tape_mount_count');
      IFEND;
      iop$tape_mount_count (tape_mount_count, status);
      IF NOT status.normal THEN
        IF status.condition = dme$unable_to_lock_tape_table THEN
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Waiting for tape table lock');
            debug_message_logged := TRUE;
          IFEND;
          osp$establish_condition_handler (^term_tape_assignment_handler, {handle block exit} FALSE);
          pmp$long_term_wait (one_second, one_second);
          osp$disestablish_cond_handler;
        ELSE
          tape_mount_count := 0;
          status.normal := TRUE;
        IFEND;
      IFEND;
    UNTIL status.normal;

    IF tape_mount_count <= 0 THEN
      osp$set_status_abnormal (rmc$resource_management_id, rme$no_tape_mount_pending, external_vsn, status);
      RETURN;
    IFEND;

    PUSH rvl_info_array_p: [LOWERBOUND (rvl_info_array_p^) .. tape_mount_count];
    REPEAT
      REPEAT
        IF NOT debug_message_logged THEN
          rmp$log_debug_message (' Calling iop$get_tape_mount_information');
        IFEND;
        iop$get_tape_mount_information (rvl_info_array_p, all_tape_mounts_found, status);
        IF NOT status.normal THEN
          IF status.condition = dme$unable_to_lock_tape_table THEN
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Waiting for tape table lock');
              debug_message_logged := TRUE;
            IFEND;
            osp$establish_condition_handler (^term_tape_assignment_handler, {handle block exit} FALSE);
            pmp$long_term_wait (one_second, one_second);
            osp$disestablish_cond_handler;
          ELSE
            RETURN;
          IFEND;
        IFEND;
      UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF NOT all_tape_mounts_found THEN
        tape_mount_count := tape_mount_count + 1;
        PUSH rvl_info_array_p: [LOWERBOUND (rvl_info_array_p^) .. tape_mount_count];
      IFEND;
    UNTIL all_tape_mounts_found;

    mount_requests := 0;
  /search_mount_requests/
    BEGIN
      IF ssn = jmc$blank_system_supplied_name THEN
        FOR info_array_index := LOWERBOUND (rvl_info_array_p^) TO UPPERBOUND (rvl_info_array_p^) DO
          IF rvl_info_array_p^ [info_array_index].null_entry THEN
            EXIT /search_mount_requests/;
          IFEND;
          IF rvl_info_array_p^ [info_array_index].current_vsn = external_vsn THEN
            mount_requests := mount_requests + 1;
            mount_ordinal := info_array_index;
          IFEND;
        FOREND;
        EXIT /search_mount_requests/;

      ELSE { ssn <> jmc$blank_system_supplied_name
        FOR info_array_index := LOWERBOUND (rvl_info_array_p^) TO UPPERBOUND (rvl_info_array_p^) DO
          IF rvl_info_array_p^ [info_array_index].null_entry THEN
            EXIT /search_mount_requests/;
          IFEND;
          IF (rvl_info_array_p^ [info_array_index].current_vsn = external_vsn) AND
                (rvl_info_array_p^ [info_array_index].ssn = ssn) THEN
            mount_requests := 1;
            mount_ordinal := info_array_index;
            EXIT /search_mount_requests/;
          IFEND;
        FOREND;
      IFEND;

    END /search_mount_requests/;

    IF mount_requests < 1 THEN
      osp$set_status_abnormal (rmc$resource_management_id, rme$no_tape_mount_pending, external_vsn, status);
      RETURN;
    ELSEIF mount_requests > 1 THEN
      osp$set_status_abnormal (rmc$resource_management_id, rme$system_name_req_for_term, external_vsn,
            status);
      RETURN;
    IFEND;

    debug_message_logged := FALSE;
    REPEAT
      IF NOT debug_message_logged THEN
        rmp$log_debug_message (' Calling iop$terminate_assignment');
      IFEND;
      iop$terminate_assignment (rvl_info_array_p^ [mount_ordinal].sfid,
            rvl_info_array_p^ [mount_ordinal].ssn, message, status);
      IF NOT status.normal THEN
        IF status.condition = dme$unable_to_lock_tape_table THEN
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Waiting for tape table lock');
            debug_message_logged := TRUE;
          IFEND;
          osp$establish_condition_handler (^term_tape_assignment_handler, {handle block exit} FALSE);
          pmp$long_term_wait (one_second, one_second);
          osp$disestablish_cond_handler;
        ELSE
          RETURN;
        IFEND;
      IFEND;
    UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);

  PROCEND iop$terminate_tape_assignment;

MODEND iom$tape_command_procedures;
*DECK DECK=IOM$TAPE_QUEUE_MANAGER_MTR EXPAND=TRUE
MODULE iom$tape_queue_manager_mtr;

?? RIGHT := 110 ??

*copyc osd$default_pragmats

?? OLDTITLE ??
?? NEWTITLE := ' global definitions ' ??
?? EJECT ??

*copyc cml$system_informative_message
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc osv$boot
*copyc osv$boot_is_executing
*copyc osv$external_interrupt_selector
*copyc osv$mainframe_wired_heap
*copyc tmv$null_global_task_id
?? PUSH (LISTEXT := ON) ??
*copyc ioe$tape_io_conditions
*copyc iot$command
*copyc iot$io_function
*copyc iot$ipi_tape_log_data
*copyc iot$lockword
*copyc iot$pp_interface_table
*copyc iot$pp_number
*copyc iot$pp_response
*copyc iot$read_tape_description
*copyc iot$tape_block_count
*copyc iot$tape_collected_pp_response
*copyc iot$tape_command_heap
*copyc iot$tape_command_table_entry
*copyc iot$tape_completion_packet
*copyc iot$tape_device_status
*copyc iot$tape_request_block
*copyc iot$unit_interface_table
*copyc iot$write_tape_description
*copyc mme$condition_codes
*copyc mmt$buffer_descriptor
*copyc mmt$io_type
*copyc mmt$rma_list
*copyc osk$keypoints
*copyc osk$tape_keypoints
*copyc ost$informative_message_record
*copyc ost$page_size
*copyc ost$signature_lock
*copyc syt$monitor_request_code
?? POP ??

?? OLDTITLE ??
?? NEWTITLE := ' xref definitions ' ??
?? EJECT ??

*copyc i#move
*copyc i#real_memory_address
*copyc dsp$report_system_message
*copyc mmp$build_lock_rma_list_tape
*copyc mmp$unlock_rma_list
*copyc dpp$display_error
*copyc mtp$error_stop
*copyc tmp$check_taskid
*copyc tmp$set_task_ready

?? OLDTITLE ??
?? NEWTITLE := ' Global Variables ' ??
?? EJECT ??

  VAR
    iov$display_microcode_load: [XDCL, STATIC, #GATE] boolean := FALSE,

    iov$tape_process_pp_response: [XDCL, STATIC, #GATE, oss$mainframe_wired]
         iot$response_processor := ^iop$tape_process_pp_response,

    iov$tape_completion_q_table: [XDCL, #GATE] ^array [1 .. *] of
         iot$tape_completion_packet := NIL;

?? OLDTITLE ??
?? NEWTITLE := ' iop$ensure_tape_io_complete ' ??
?? EJECT ??

{ PURPOSE:
{ This routine will initiate a synchronize command on any unit that is
{ assigned to the input job_name.  This will ensure that all outstanding
{ write requests will complete in a timely manner.

  PROCEDURE [XDCL] iop$ensure_tape_io_complete (
        job_name: jmt$system_supplied_name);

    VAR
      ccc_cart_unit_comm_buffer_p: ^iot$ccc_cart_unit_comm_buffer,
      i: 0 .. 0ff(16),
      lun: iot$logical_unit;

    FOR i := LOWERBOUND (iov$tape_completion_q_table^) TO UPPERBOUND (iov$tape_completion_q_table^) DO
      lun := iov$tape_completion_q_table^ [i].lun;
      IF (iov$tape_completion_q_table^ [i].cart_writes_pending > 0) AND
            cmv$logical_unit_table^ [lun].status.assigned AND
            (cmv$logical_unit_table^ [lun].status.assigned_jsn = job_name) THEN
        RESET cmv$logical_unit_table^ [lun].unit_communication_buffer_pva;
        NEXT ccc_cart_unit_comm_buffer_p IN cmv$logical_unit_table^ [lun].
              unit_communication_buffer_pva;
        ccc_cart_unit_comm_buffer_p^.force_sync := 1;
        iov$tape_completion_q_table^ [i].sync_set := TRUE;
      IFEND;
    FOREND;

  PROCEND iop$ensure_tape_io_complete;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_process_pp_response ' ??
?? EJECT ??

  PROCEDURE [XDCL] iop$tape_process_pp_response (pp_response_header_p:
        ^iot$pp_response;
        detailed_status_p: ^iot$detailed_status;
        pp_number: 1 .. ioc$pp_count;
    VAR mon_status: syt$monitor_status);

    TYPE
      status_code = 0 .. 0ffff(16);

    VAR
      address_pair_count: 0 .. mmc$max_rma_list_length,
      block_id_status_area_p: ^iot$tape_bid_status_response,
      cart_tape_write: boolean,
      ccc_cart_dev_stat_p: ^iot$ccc_cart_device_status,
      ccc_cart_log_p: ^iot$ccc_cart_error_log,
      ccc_cart_sense_p: ^iot$ccc_cart_sense_bytes,
      ccc_cart_unit_comm_buffer_p: ^iot$ccc_cart_unit_comm_buffer,
      channel: cmt$physical_channel,
      channel_length: 1 .. 2,
      completion_q_table_p: ^iot$tape_completion_entry,
      error_status: status_code,
      first_logical_unit: iot$logical_unit,
      io_error: iot$io_error,
      io_type: iot$io_function,
      io_id: iot$io_id,
      ioid: mmt$io_identifier,
      iou: dst$iou_number,
      iov$good_cart_microcode_load: [XDCL] integer := 0,
      iov$bad_cart_microcode_load: [XDCL] integer := 0,
      iov$tape_task_id_check: [XDCL] integer := 0,
      iov$tape_task_id_not_found: [XDCL] integer := 0,
      ipi_status_p: ^iot$ipi_tape_status,
      ipi_source_p: ^cell,
      ipi_dest_p: ^cell,
      ipi_status_length: 0 .. (ioc$ipi_tape_status_size + ioc$ipi_max_status_size),
      j: 1 .. ioc$max_multiple_tape_requests,
      list_p: ^mmt$rma_list,
      logical_unit: iot$logical_unit,
      message_data: ^SEQ(*),
      message_record: ost$informative_message_record,
      msg_recorded: boolean,
      msg1: string(63),
      msg2: string(63),
      msg3: string(63),
      p_device_status: ^iot$tape_device_status,
      p_extended_status: ^iot$tape_extended_status,
      p_next_request: ^iot$io_request,
      p_unit_table: ^iot$unit_interface_table,
      seq_p: ^SEQ ( * ),
      status_code_p: ^status_code,
      tape_log_data: iot$ipi_tape_log_data,
      tape_log_seq_p: ^SEQ ( * ),
      tape_pp_response_p: ^iot$tape_collected_pp_response,
      tape_request_p: ^iot$wired_tape_request,
      temp_detailed_status_p: ^SEQ ( * ),
      temp_tape_request_p: ^iot$wired_tape_request,
      unit_type: iot$unit_type,
      unlock_io_type: iot$io_function;

    BEGIN
      mon_status.normal := TRUE;
      logical_unit := pp_response_header_p^.logical_unit;

      #INLINE ('keypoint', osk$entry, osk$m * pp_number,
            ioc$tape_entry_ioptptr);
      IF (pp_response_header_p^.response_code.primary_response =
            ioc$normal_response) OR (pp_response_header_p^.response_code.
            primary_response = ioc$abnormal_response) THEN

{ Verify task is still active if flag is set to check the task id.  This can occur
{ if a terminate task or job occurred with tape request(s) active.

        completion_q_table_p := pp_response_header_p^.request^.pp_request_p;

        IF completion_q_table_p^.check_task_id THEN
          tmp$check_taskid (completion_q_table_p^.task_id, tmc$opt_return, mon_status);
          iov$tape_task_id_check := iov$tape_task_id_check + 1;
          IF NOT mon_status.normal THEN  { task id gone, ignore response
            mon_status.normal := TRUE;
            completion_q_table_p^.waiting_response := FALSE;
            completion_q_table_p^.request_not_processed := FALSE;
            completion_q_table_p^.io_id := 0;
            completion_q_table_p^.io_request := NIL;
            completion_q_table_p^.task_id := tmv$null_global_task_id;
            completion_q_table_p^.check_task_id := FALSE;
            cmv$logical_unit_table^ [logical_unit].unit_interface_table^.unit_status.disabled := FALSE;
            iov$tape_task_id_not_found := iov$tape_task_id_not_found + 1;
            RETURN;
          IFEND;
        IFEND;
        tape_request_p := pp_response_header_p^.request^.device_request_p;
        tape_pp_response_p := tape_request_p^.pp_response_p;

        IF tape_pp_response_p = NIL THEN
{ There is no response to process so exit }
           RETURN;
        IFEND;

        tape_pp_response_p^.pp_no := pp_number;
        tape_pp_response_p^.pp_response := pp_response_header_p^;
        io_id := tape_request_p^.io_id;
        io_error := ioc$no_error;

{ Release process_io_completions CIO response area ASAP.
{ Must use redefined sequence pointer (temp_detailed_status_p) because the original pointer
{  is not passed in as a VAR and cannot be used to RESET the detailed status Sequence Structure.

        temp_detailed_status_p := detailed_status_p;
        RESET temp_detailed_status_p;

        IF NOT ((cmv$logical_pp_table_p^ [pp_number].controller_info.controller_type = cmc$mt5698_xx) OR
              (cmv$logical_pp_table_p^ [pp_number].controller_info.controller_type = cmc$mt5680_xx)) THEN

{ Move block_id status responses to wired request area.

          NEXT block_id_status_area_p IN temp_detailed_status_p;
          tape_pp_response_p^.block_id_status_area := block_id_status_area_p^;

{ Move device status to wired request area

          NEXT p_device_status IN temp_detailed_status_p;
          tape_pp_response_p^.device_status := p_device_status^;

{ Check pp response length and if extended status is included, handle extended device status.

          IF pp_response_header_p^.response_length > (ioc$min_response_length +
                 ioc$bid_area_size + ioc$device_status_size) THEN
            NEXT p_extended_status IN temp_detailed_status_p;
            tape_pp_response_p^.extended_device_status := p_extended_status^;
          IFEND;


        ELSEIF (cmv$logical_pp_table_p^ [pp_number].controller_info.controller_type = cmc$mt5698_xx) THEN

{ Move block_id status responses to wired request area.

          NEXT block_id_status_area_p IN temp_detailed_status_p;
          tape_pp_response_p^.ipi_block_id_status_area := block_id_status_area_p^;

{ Move ipi status to wired request area.

          ipi_status_length := pp_response_header_p^.response_length -
                (ioc$min_response_length + ioc$bid_area_size);

          IF ipi_status_length > 0 THEN
            NEXT ipi_status_p IN temp_detailed_status_p;
            ipi_source_p := ipi_status_p;
            ipi_dest_p := ^tape_pp_response_p^.ipi_tape_status;
            i#move (ipi_source_p, ipi_dest_p, ipi_status_length);
          IFEND;

        ELSEIF (cmv$logical_pp_table_p^ [pp_number].controller_info.controller_type = cmc$mt5680_xx) THEN

{ Clear flag (PVA) in unit communication buffer indicating task is waiting for write completion.
{ This is only done for cartridge tape write operations if the task is waiting for IO complete.

          IF (tape_request_p^.ready_task AND (tape_request_p^.io_type = ioc$explicit_write)) OR
                (iov$tape_completion_q_table^ [tape_request_p^.completion_q_index].sync_set) THEN
            RESET cmv$logical_unit_table^ [logical_unit].unit_communication_buffer_pva;
            NEXT ccc_cart_unit_comm_buffer_p IN cmv$logical_unit_table^ [logical_unit].
                  unit_communication_buffer_pva;
            ccc_cart_unit_comm_buffer_p^.request_pva := NIL;
            IF (ccc_cart_unit_comm_buffer_p^.force_sync <> 0) AND
                  (cmv$logical_unit_table^ [logical_unit].unit_interface_table^.next_request = NIL) THEN
              ccc_cart_unit_comm_buffer_p^.force_sync := 0;
              iov$tape_completion_q_table^ [tape_request_p^.completion_q_index].sync_set := FALSE;
            IFEND;
          IFEND;

{ Move general/detailed status to wired response area.

          NEXT ccc_cart_dev_stat_p IN temp_detailed_status_p;
          tape_pp_response_p^.ccc_cart_device_status := ccc_cart_dev_stat_p^;

{ Move sense bytes and error log data to wired response area if they are included in the response.

          IF pp_response_header_p^.response_length > ioc$min_ccc_cart_resp_size THEN
            NEXT ccc_cart_sense_p IN temp_detailed_status_p;
            tape_pp_response_p^.ccc_cart_sense_bytes := ccc_cart_sense_p^;
            IF pp_response_header_p^.response_length = ioc$max_ccc_cart_resp_size THEN
              NEXT ccc_cart_log_p IN temp_detailed_status_p;
              tape_pp_response_p^.ccc_cart_error_log := ccc_cart_log_p^;
            IFEND;
          IFEND;

        IFEND;

{ Unlock pages for data transfer request.

        io_type := tape_request_p^.io_type;
        cart_tape_write :=
              (cmv$logical_pp_table_p^ [pp_number].controller_info.controller_type = cmc$mt5680_xx) AND
                  (io_type = ioc$explicit_write);
        IF ((io_type = ioc$explicit_read) OR (io_type = ioc$explicit_write)) AND
              (tape_request_p^.data_pages_locked) THEN
          list_p := tape_request_p^.list_p;
          address_pair_count := tape_request_p^.address_pair_count;
          IF address_pair_count > 0 THEN
            IF (io_type = ioc$explicit_read) AND NOT tape_request_p^.cache_purge_required_data THEN
              unlock_io_type := ioc$explicit_read_no_purge;
            ELSE
              unlock_io_type := io_type;
            IFEND;
            IF io_type = ioc$explicit_read THEN
              address_pair_count := address_pair_count - 1;
            IFEND;
            mmp$unlock_rma_list (unlock_io_type, list_p, address_pair_count, ioid,
                  {MF_JOB_FILE} FALSE, io_error, mon_status);
            IF NOT mon_status.normal THEN
              mtp$error_stop ('IOT1 - abnormal unlock status');
            IFEND;
            IF io_type = ioc$explicit_read THEN { unlock transfer count buffer(s) page
              list_p := #LOC (tape_request_p^.wired_command_heap_p^.rma_list [address_pair_count + 1]);
              IF NOT tape_request_p^.cache_purge_required_length THEN
                unlock_io_type := ioc$explicit_read_no_purge;
              ELSE
                unlock_io_type := io_type;
              IFEND;
              mmp$unlock_rma_list (unlock_io_type, list_p, 1, ioid, {MF_JOB_FILE} FALSE,
                    io_error, mon_status);
              IF NOT mon_status.normal THEN
                mtp$error_stop ('IOT1 - abnormal unlock status');
              IFEND;
            ELSEIF cart_tape_write THEN
              iov$tape_completion_q_table^ [tape_request_p^.completion_q_index].cart_writes_pending :=
                    iov$tape_completion_q_table^ [tape_request_p^.completion_q_index].cart_writes_pending - 1;
              IF tape_request_p^.ijle_p^.active_cart_tape_write > 0 THEN
                tape_request_p^.ijle_p^.active_cart_tape_write :=
                      tape_request_p^.ijle_p^.active_cart_tape_write - 1;
              IFEND;
            IFEND;
          IFEND;
        IFEND;

{ Check for disable of unit by PP and unlock pages of any pending requests.

        IF tape_pp_response_p^.pp_response.alert_conditions.disabled_unit THEN
           p_unit_table := cmv$logical_unit_table^ [logical_unit].unit_interface_table;
           IF p_unit_table^.next_request <> NIL THEN
             p_next_request := p_unit_table^.next_request;
             temp_tape_request_p := p_next_request^.device_request_p;
            /pending_request_pages_unlocked/
             FOR j := 1 TO ioc$max_multiple_tape_requests DO
               io_type := temp_tape_request_p^.io_type;
               IF ((io_type = ioc$explicit_read) OR (io_type = ioc$explicit_write)) AND
                     (temp_tape_request_p^.data_pages_locked) THEN
                 list_p := temp_tape_request_p^.list_p;
                 address_pair_count := temp_tape_request_p^.address_pair_count;
                 IF address_pair_count > 0 THEN
                   IF io_type = ioc$explicit_read THEN
                     address_pair_count := address_pair_count - 1;
                   IFEND;
                   mmp$unlock_rma_list (ioc$no_io, list_p, address_pair_count, ioid,
                         {MF_JOB_FILE} FALSE, io_error, mon_status);
                   IF NOT mon_status.normal THEN
                     mtp$error_stop ('IOT1 - abnormal unlock status');
                   IFEND;
                   IF io_type = ioc$explicit_read THEN { unlock transfer count buffer(s) page
                     list_p := #LOC (temp_tape_request_p^.wired_command_heap_p^.rma_list
                           [address_pair_count + 1]);
                     mmp$unlock_rma_list (ioc$no_io, list_p, 1, ioid, {MF_JOB_FILE} FALSE,
                           io_error, mon_status);
                     IF NOT mon_status.normal THEN
                       mtp$error_stop ('IOT1 - abnormal unlock status');
                     IFEND;
                   ELSEIF cart_tape_write THEN
                     iov$tape_completion_q_table^ [temp_tape_request_p^.completion_q_index].
                           cart_writes_pending :=  iov$tape_completion_q_table^
                           [temp_tape_request_p^.completion_q_index].cart_writes_pending - 1;
                     IF (temp_tape_request_p^.ijle_p^.active_cart_tape_write > 0) THEN
                       temp_tape_request_p^.ijle_p^.active_cart_tape_write :=
                             temp_tape_request_p^.ijle_p^.active_cart_tape_write - 1;
                      IFEND;
                   IFEND;
                 IFEND;
               IFEND;
               p_next_request := temp_tape_request_p^.request.next_pp_request;
               IF p_next_request = NIL THEN
                  EXIT /pending_request_pages_unlocked/
               IFEND;
               temp_tape_request_p := p_next_request^.device_request_p;
             FOREND /pending_request_pages_unlocked/
           IFEND;
        IFEND;

{ Set waiting response in iov$tape_completion_q_table.

        IF completion_q_table_p^.io_id = io_id THEN
          completion_q_table_p^.waiting_response := TRUE;
          IF tape_request_p^.ready_task THEN
            tmp$set_task_ready (tape_request_p^.task_id, 0, tmc$rc_ready_conditional_wi);
          IFEND;
        ELSE
          msg_recorded := FALSE;
          message_record.message_type := cml$system_informative_message;
          message_record.message := 'Invalid tape io_id encountered';
          message_data := #SEQ(message_record);
          dsp$report_system_message (message_data, dsc$general_system_message,
                dsc$informative_message, msg_recorded);
          msg1 := 'Invalid io_id encountered';
          msg2 := ',lun = ';
                iop$ascii_decimal (^msg2 (8,*), 2, logical_unit);
          msg3 := ' pp# ';
                iop$ascii_decimal (^msg3 (8,*), 2, pp_number);
          dpp$display_error (msg1);
          dpp$display_error (msg2);
          dpp$display_error (msg3);
         RETURN;
        IFEND;

{ Check for unsolicited response.

      ELSEIF (pp_response_header_p^.response_code.primary_response =
          ioc$unsolicited_response) THEN
        IF cmv$logical_pp_table_p^ [pp_number].flags.configured = FALSE THEN
          RETURN;
        IFEND;

        first_logical_unit := cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p^.
              first_logical_unit;

        channel.number := cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p^.
             unit_descriptors [first_logical_unit].physical_path.channel_number;

        iou := cmv$logical_pp_table_p^ [pp_number].pp_info.channel.iou_number;

        unit_type := cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p^.
              unit_descriptors [first_logical_unit].unit_interface_table^.unit_type;

        IF channel.number > 9 THEN
          channel_length := 2;
        ELSE
          channel_length := 1;
        IFEND;

        IF cmv$logical_pp_table_p^ [pp_number].pp_info.channel_interlock_p^.
              channel_characteristics [channel.number].concurrent_channel THEN
          msg2 := 'IOU   CCH  ';
          iop$ascii_decimal (^msg2 (10, *), channel_length, channel.number);
          channel.concurrent := TRUE;
          IF (cmv$logical_pp_table_p^ [pp_number].controller_info.controller_type = cmc$mt5698_xx) THEN
            IF cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p^.
                  unit_descriptors [first_logical_unit].physical_path.port = 0 THEN
              channel.port := cmc$port_a;
            ELSE
              channel.port := cmc$port_b;
            IFEND;
          ELSE
            channel.port := cmc$unspecified_port;
          IFEND;
        ELSE
          msg2 := 'IOU   CH  ';
          iop$ascii_decimal (^msg2 (9, *), channel_length, channel.number);
          channel.concurrent := FALSE;
          channel.port := cmc$unspecified_port;
        IFEND;
        iop$ascii_decimal (^msg2 (4, *), 1, iou);

{ Must use redefined sequence pointer (temp_detailed_status_p) because the original pointer
{  is not passed in as a VAR and cannot be used to RESET the detailed status Sequence Structure.

        temp_detailed_status_p := detailed_status_p;
        RESET temp_detailed_status_p;

{ Move the sequence pointer by the block_id response area if necessary.

        IF NOT (cmv$logical_pp_table_p^ [pp_number].controller_info.controller_type = cmc$mt5680_xx) THEN
          NEXT block_id_status_area_p IN temp_detailed_status_p;
        IFEND;

{ Process IPI unsolicited response.

        IF (cmv$logical_pp_table_p^ [pp_number].controller_info.controller_type = cmc$mt5698_xx) THEN

          tape_log_data.unit_type := ioc$ipi_reel;
          NEXT ipi_status_p IN temp_detailed_status_p;

{ The following code that issues a message to the critical window is disabled.  It is
{ only to be used for debugging purposes.
{
{         msg1 := '5698_1X CONTROLLER ERROR';
{         msg3 := 'ERROR_ID =     (10)';
{         iop$ascii_decimal (^msg3 (12, *), 4, ipi_status_p^.error_id);
{         dpp$display_error (msg1);
{         dpp$display_error (msg2);
{         dpp$display_error (msg3);

          IF osv$boot THEN   { do not save logical unit number if in boot
            tape_log_data.logical_unit := 0;
          ELSE
            tape_log_data.logical_unit := pp_response_header_p^.logical_unit;
          IFEND;

          tape_log_data.iou_number := iou;
          tape_log_data.response_length := pp_response_header_p^.response_length;
          tape_log_data.channel := channel;
          tape_log_data.interface_error_code := pp_response_header_p^.interface_error_code;

          IF (tape_log_data.response_length <= ioc$min_ipi_total_resp_size) THEN
            IF tape_log_data.logical_unit = 0 THEN
              tape_log_data.controller_number := cmv$logical_pp_table_p^ [pp_number].
                  pp_info.pp_interface_table_p^.unit_descriptors [first_logical_unit].
                  physical_path.controller_number;
              tape_log_data.unit_number := 0;
            ELSE
              tape_log_data.controller_number := cmv$logical_pp_table_p^ [pp_number].pp_info.
                    pp_interface_table_p^.unit_descriptors [tape_log_data.logical_unit].
                    physical_path.controller_number;
              tape_log_data.unit_number := cmv$logical_pp_table_p^ [pp_number].pp_info.
                    pp_interface_table_p^.unit_descriptors [tape_log_data.logical_unit].
                    physical_path.physical_unit_number;
            IFEND;

          ELSE  {use slave,facility address from major status

            tape_log_data.controller_number := ipi_status_p^.major_status_header.slave_address;
            IF ipi_status_p^.major_status_header.facility_address = 0ff(16) THEN
              tape_log_data.unit_number := 0;
            ELSE
              tape_log_data.unit_number := ipi_status_p^.major_status_header.facility_address;
            IFEND;
          IFEND;

          ipi_status_length := pp_response_header_p^.response_length -
                (ioc$min_response_length + ioc$bid_area_size);
          IF ipi_status_length > 0 THEN
            ipi_source_p := ipi_status_p;
            ipi_dest_p := ^tape_log_data.ipi_status;
            i#move (ipi_source_p, ipi_dest_p, ipi_status_length);
          IFEND;

          tape_log_seq_p := #SEQ (tape_log_data);
          RESET tape_log_seq_p;
          NEXT seq_p: [[REP (ipi_status_length + ioc$length_to_ipi_status) of cell]] IN tape_log_seq_p;
          RESET seq_p;

          dsp$report_system_message (seq_p, dsc$tape_errors, dsc$unrecovered_error, msg_recorded);
          RETURN;

        ELSEIF (cmv$logical_pp_table_p^ [pp_number].controller_info.controller_type = cmc$mt5680_xx) THEN

          NEXT ccc_cart_dev_stat_p IN temp_detailed_status_p;

          IF (ccc_cart_dev_stat_p^.error_id = ioc$ccc_cart_no_pp_eid) OR
                osv$boot_is_executing THEN { do not log good load or error during boot
            RESET temp_detailed_status_p;
          ELSE
            tape_log_data.unit_type := ioc$ccc_cart;
            tape_log_data.logical_unit := 0;
            tape_log_data.iou_number := iou;
            tape_log_data.response_length := pp_response_header_p^.response_length;
            tape_log_data.channel := channel;
            tape_log_data.interface_error_code := pp_response_header_p^.interface_error_code;
            tape_log_data.unit_number := 0;
            tape_log_data.controller_number := cmv$logical_pp_table_p^ [pp_number].
                pp_info.pp_interface_table_p^.unit_descriptors [first_logical_unit].
                physical_path.controller_number;
            tape_log_data.ccc_cart_status := ccc_cart_dev_stat_p^;
            tape_log_seq_p := #SEQ (tape_log_data);
            RESET tape_log_seq_p;
            NEXT seq_p: [[REP (ioc$ccc_cart_device_status_size + ioc$length_to_ipi_status) of cell]]
                  IN tape_log_seq_p;
            RESET seq_p;

            dsp$report_system_message (seq_p, dsc$tape_errors, dsc$unrecovered_error, msg_recorded);
            IF (ccc_cart_dev_stat_p^.error_id = ioc$ccc_cart_microcode_load) THEN
              RESET temp_detailed_status_p;
            ELSE
              RETURN; { error is not microcode load error
            IFEND;
          IFEND;
        IFEND;

{ Pick up the first 16 bits of status.  For ISMT/698/5680 it is general status.

        NEXT status_code_p IN temp_detailed_status_p;
        error_status := status_code_p^;

{ Process microcode load response for ISMT, 698 and 5680.
{ Check the status returned by the hardware after the controlware/microcode is loaded.
{ For 5680, a critical window message is issued only if abnormal load status is
{ returned during deadstart. The variable iov$display_microcode_load is only for
{ internal use.

        IF (unit_type = ioc$dt_mt5682_1x) THEN
          IF error_status = 200(16) THEN
            iov$good_cart_microcode_load := iov$good_cart_microcode_load + 1;
          ELSE
            iov$bad_cart_microcode_load := iov$bad_cart_microcode_load + 1;
          IFEND;
          IF NOT iov$display_microcode_load AND NOT osv$boot THEN
            RETURN;  {do not issue any critical window message for 5680_11 if not during deadstart
          IFEND;
        IFEND;

        IF error_status = 0ffc(16) THEN
          msg1 := 'FUNCTION TIMEOUT ON CY170 DMA ADAPTER';
          dpp$display_error (msg1);
          dpp$display_error (msg2);
          RETURN;
        IFEND;

        IF unit_type = ioc$dt_mt639_1 THEN
          msg1 := 'ISMT MICROCODE LOAD ERROR';
        ELSEIF unit_type = ioc$dt_mt698_3x THEN
          msg1 := '698_XX MICROCODE LOAD ERROR';
        ELSE { 5680_11
          msg1 := '5680_11 MICROCODE LOAD ERROR';
        IFEND;

        IF error_status = 200(16) THEN
          IF unit_type = ioc$dt_mt639_1 THEN
            msg1 := 'ISMT MICROCODE LOADED';
          ELSEIF unit_type = ioc$dt_mt698_3x THEN
            msg1 := '698_XX MICROCODE LOADED';
          ELSE
            msg1 := '5680_11 MICROCODE LOADED';
            IF NOT iov$display_microcode_load THEN
              RETURN;  { do not issue good load message for 5680_11
            IFEND;
          IFEND;
          dpp$display_error (msg1);
          dpp$display_error (msg2);
        ELSEIF error_status = 0fff(16) THEN
          msg3 := 'FUNCTION TIMEOUT ON AUTOLOAD FUNCTION';
          dpp$display_error (msg1);
          dpp$display_error (msg2);
          dpp$display_error (msg3);
        ELSEIF error_status = 0ffe(16) THEN
          msg3 := 'CHANNEL PARITY ERROR ON AUTOLOAD FUNCTION';
          dpp$display_error (msg1);
          dpp$display_error (msg2);
          dpp$display_error (msg3);
        ELSE
          msg3 := 'GENERAL_STATUS=    ';
          iop$ascii_octal (^msg3 (16, *), 4, error_status);
          dpp$display_error (msg1);
          dpp$display_error (msg2);
          dpp$display_error (msg3);
        IFEND;
      IFEND;
    END
  PROCEND iop$tape_process_pp_response;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_queue_request ' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iop$tape_queue_request (VAR request_block:
    iot$tape_request_block);

    VAR
      actual_lock: iot$lockword,
      address_pair_count: 0 .. mmc$max_rma_list_length,
      completion_q_table_p: ^iot$tape_completion_entry,
      dmv$external_interrupt_selector: [XREF] 0 .. 0ff(16),
      initial_lock: [STATIC] iot$lockword := [FALSE, 0, [FALSE, 0, 0]],
      io_error: iot$io_error,
      io_type: iot$io_function,
      ioid: mmt$io_identifier,
      iov$tape_unit_q_lock_rejects: [XDCL] integer := 0,
      iov$max_tape_unit_q_lock_wait: [XDCL] integer := 0,
      iov$page_frame_not_assigned: [XDCL] integer := 0,
{     iov$tape_requests_p: [XDCL] ^iot$wired_tape_request,
{     iov$tape_requests: [XDCL] array [1 .. 11] of iot$wired_tape_request,
{     ii: [STATIC] integer := 1,
      n: iot$tape_command_index,
      new_lock: [STATIC] iot$lockword := [TRUE, 0, [TRUE, FALSE, 0, 0]],
      new_lock2: [STATIC] iot$lockword := [TRUE, 8000(16), [TRUE, FALSE, 0, 0]],
      new_time: integer,
      old_time: integer,
      p_unit_table: ^iot$unit_interface_table,
      p_next_request: ^iot$io_request,
      p_previous_request: ^iot$wired_tape_request,
      p_lockword: ^iot$lockword,
      rma: integer,
      request_header: ^iot$wired_tape_request,
      result: 0 .. 2,
      sen: iot$logical_unit,
      status: syt$monitor_status;

    BEGIN
      request_block.status.normal := TRUE;
      status.normal := TRUE;

      #INLINE ('keypoint', osk$entry, 0, ioc$tape_entry_ioptqrq);
      request_block.io_request_p^.response_processor_p :=
            ^iop$tape_process_pp_response;
      request_header := request_block.io_request_p^.device_request_p;
      io_type := request_header^.io_type;
      io_error := ioc$no_error;
      IF dmv$external_interrupt_selector = 1 THEN
        request_header^.request.interrupt.value := TRUE;
      ELSE
        request_header^.request.interrupt.value := FALSE;
      IFEND;
      request_header^.request.interrupt.port_number := osv$external_interrupt_selector;
      sen := request_header^.request.logical_unit;
      p_unit_table := cmv$logical_unit_table^ [sen].unit_interface_table;

{ Check for unit_disabled status to turn back request unless the request is being requeued
{ from recovery.  IF the requeue is from recovery and the unit is disabled, do not lock
{ the data pages for the read or write.

      IF p_unit_table^.unit_status.disabled THEN
        IF NOT request_header^.recovery_requeue THEN
          request_block.status.normal := FALSE;
          request_block.status.condition := ioe$tape_unit_disabled;
          RETURN;
        ELSE {request is from recovery requeue}
          IF (io_type = ioc$explicit_read) OR (io_type = ioc$explicit_write) THEN
            request_header^.data_pages_locked := FALSE;
          ELSE
            mtp$error_stop ('IO05 - Invalid tape requeue');
            RETURN;
          IFEND;
        IFEND;
      IFEND;

{Check for empty io_id slot in completion queue table.  If not empty, halt system.

      completion_q_table_p := request_block.io_request_p^.pp_request_p;

      IF completion_q_table_p^.io_id <> 0 THEN
        mtp$error_stop ('IO05 - No request slot found when queueing request.');
      IFEND;

{ Build RMA list and lock pages.

      IF ((io_type = ioc$explicit_read) OR (io_type = ioc$explicit_write)) AND
            (request_header^.data_pages_locked) THEN
        mmp$build_lock_rma_list_tape (request_header, status);
        IF NOT status.normal THEN
          request_block.status := status;
          IF status.condition = mme$page_frame_not_assigned THEN
            iov$page_frame_not_assigned := iov$page_frame_not_assigned + 1;
          IFEND;
          RETURN;
        IFEND;

{ Complete setting up request for reads of more than 1 block.  The remainder of the
{ transfer count buffers must be set up.  The transfer count buffers for read are always
{ in the same memory page.

        IF (io_type = ioc$explicit_read) AND (request_header^.no_of_data_commands > 1) THEN
          rma := request_header^.list_p^ [request_header^.address_pair_count].rma;
          FOR n := 2 TO request_header^.no_of_data_commands DO
            request_header^.request.tape_command [n * 2 + 1].address :=
                  rma + (#OFFSET (request_header^.wired_read_description_p^ [n].block_transfer_length) -
                  #OFFSET (request_header^.wired_read_description_p^ [1].block_transfer_length));
          FOREND;
        ELSEIF (request_header^.pp_response_p^.controller_type = cmc$mt5680_xx) AND
              (io_type = ioc$explicit_write) THEN
          iov$tape_completion_q_table^ [request_header^.completion_q_index].cart_writes_pending :=
                iov$tape_completion_q_table^ [request_header^.completion_q_index].cart_writes_pending + 1;
          request_header^.ijle_p^.active_cart_tape_write :=
                request_header^.ijle_p^.active_cart_tape_write + 1;
        IFEND;
      IFEND;

{ Set unit queue lockword. }

      p_lockword := ^cmv$logical_unit_table^ [sen].unit_interface_table^.unit_q_lockword;
      old_time := #free_running_clock (0);

   /set_lock/
      WHILE TRUE DO
        #compare_swap (p_lockword^, initial_lock, new_lock, actual_lock,
              result);
        IF result = 0 THEN
          EXIT /set_lock/;
        IFEND;
        new_time := #free_running_clock (0);
        IF new_time < old_time + 5000 THEN

{ Keep statistics on number of unit queue lock rejects and maximum wait in microseconds.

          IF iov$tape_unit_q_lock_rejects < 7fffffffffffffff(16) THEN
            iov$tape_unit_q_lock_rejects := iov$tape_unit_q_lock_rejects + 1;
            IF new_time - old_time > iov$max_tape_unit_q_lock_wait THEN
              iov$max_tape_unit_q_lock_wait := new_time - old_time;
            IFEND;
          IFEND;
        ELSE { timeout of 5 milliseconds occurred
          request_block.status.normal := FALSE;
          request_block.status.condition := ioe$tape_pp_q_locked;
          IF ((io_type = ioc$explicit_read) OR (io_type = ioc$explicit_write)) AND
                (request_header^.data_pages_locked) THEN  { unlock locked pages
            address_pair_count := request_header^.address_pair_count;
            IF io_type = ioc$explicit_read THEN
              address_pair_count := address_pair_count - 1;
            IFEND;
            mmp$unlock_rma_list (ioc$no_io, request_header^.list_p, address_pair_count,
                  ioid, {MF_JOB_FILE} FALSE, io_error, status);
            IF io_type = ioc$explicit_read THEN { unlock transfer count buffer(s) page
              mmp$unlock_rma_list (ioc$no_io, #LOC (request_header^.wired_command_heap_p^.rma_list
                    [address_pair_count + 1]), 1, ioid, {MF_JOB_FILE} FALSE, io_error, status);
            ELSEIF (request_header^.pp_response_p^.controller_type = cmc$mt5680_xx) AND
                  (io_type = ioc$explicit_write) THEN
              iov$tape_completion_q_table^ [request_header^.completion_q_index].cart_writes_pending :=
                    iov$tape_completion_q_table^ [request_header^.completion_q_index].cart_writes_pending - 1;
              request_header^.ijle_p^.active_cart_tape_write :=
                    request_header^.ijle_p^.active_cart_tape_write - 1;
            IFEND;
          IFEND;
          RETURN;
        IFEND;
      WHILEND /set_lock/;

{ Place request in queue. }

      i#real_memory_address (^request_header^.request, rma);
      IF p_unit_table^.next_request = NIL THEN
        p_unit_table^.next_request := request_block.io_request_p;
        p_unit_table^.next_request_rma := rma;
      ELSE
        p_next_request := p_unit_table^.next_request;
        REPEAT
          p_previous_request := p_next_request^.device_request_p;
          p_next_request := p_previous_request^.request.next_pp_request;
        UNTIL p_next_request = NIL;
        p_previous_request^.request.next_pp_request := request_block.io_request_p;
        p_previous_request^.request.next_pp_request_rma := rma;
      IFEND;

{ Clear unit queue lockword. }

      REPEAT
        #compare_swap (p_lockword^, new_lock, initial_lock,
              actual_lock, result);
      UNTIL result <> 2;
      IF result <> 0 THEN
        REPEAT
          #compare_swap (p_lockword^, new_lock2, initial_lock,
                actual_lock, result);
        UNTIL result <> 2;
        IF result <> 0 THEN
          mtp$error_stop ('IO05 - invalid unit queue lockword.');
        IFEND;
      IFEND;

{ Place io_id and pointer to iot$io_request in completion queue packet.

      completion_q_table_p^.check_task_id := FALSE;
      completion_q_table_p^.io_id := request_header^.io_id;
      completion_q_table_p^.io_request := request_block.io_request_p;

{ Temporary save of requests for debugging.
{     iov$tape_requests_p := ^iov$tape_requests [ii];
{     iov$tape_requests [ii] := request_header^;
{     IF ii < 11 THEN
{       ii := ii + 1;
{     ELSE
{       ii := 1;
{     IFEND;
{ End temporary code.
      #INLINE ('keypoint', osk$exit, 0,
             ioc$tape_exit_ioptqrq);
    END
  PROCEND iop$tape_queue_request;
?? EJECT ??

  PROCEDURE iop$ascii_octal (msg: ^string ( * );
        number_of_characters: 1 .. 6;
        word: 0 .. 0ffff(16));

    VAR
      i: integer,
      k: integer,
      divisor: [STATIC] array [1 .. 6] of integer := [1, 8, 64, 512, 4096,
        32768];


    k := 1;
    FOR i := number_of_characters DOWNTO 1 DO
      msg^ (i) := CHR (((word DIV divisor [k]) MOD 8) + ORD ('0'));
      k := k + 1;
    FOREND;

  PROCEND iop$ascii_octal;


  PROCEDURE iop$ascii_decimal (msg: ^string ( * );
        number_of_characters: 1 .. 4;
        word: 0 .. 0ffff(16));

    VAR
      i: integer,
      k: integer,
      divisor: [STATIC] array [1 .. 4] of integer := [1, 10, 100, 1000];


    k := 1;
    FOR i := number_of_characters DOWNTO 1 DO
      msg^ (i) := CHR (((word DIV divisor [k]) MOD 10) + ORD ('0'));
      k := k + 1;
    FOREND;
  PROCEND iop$ascii_decimal;

MODEND iom$tape_queue_manager_mtr;
*DECK DECK=IOM$TAPE_QUEUE_MANAGER_RING1 EXPAND=TRUE
MODULE iom$tape_queue_manager_ring1;

?? RIGHT := 110 ??

*copyc osd$default_pragmats

?? OLDTITLE ??
?? NEWTITLE := ' global definitions ' ??
?? EJECT ??

*copyc cmv$logical_pp_table_p
*copyc cmv$new_logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc iov$tape_completion_q_table
*copyc osv$job_pageable_heap
*copyc osv$mainframe_pageable_heap
*copyc osv$mainframe_wired_cb_heap
*copyc osv$mainframe_wired_heap
*copyc tmv$null_global_task_id

  VAR
    iov$establish_tape_statistics: [XDCL, #GATE, STATIC, oss$mainframe_pageable] boolean := TRUE,
    iov$number_of_tape_units: [XDCL, #GATE, STATIC, oss$mainframe_pageable] iot$no_of_tape_units := 0,
    iov$tape_scan_frequency: [XDCL, #GATE, oss$mainframe_pageable] integer := 5 {seconds},
    iov$tusl_lock: [XDCL, oss$mainframe_pageable] ost$signature_lock := [0],
    iov$tusl_p: [XDCL, #GATE, oss$mainframe_pageable] ^iot$tape_unit_status_list := NIL,
    iov$wired_tape_tables: [XDCL, oss$mainframe_pageable] ^ARRAY [ 1 .. *] OF iot$wired_tape_tables := NIL;

?? PUSH (LISTEXT := ON) ??

*copyc cmc$logical_unit_constants
*copyc cmt$element_state
*copyc ioe$tape_io_conditions
*copyc iot$tape_block_count
*copyc iot$tape_collected_pp_response
*copyc iot$tape_command_heap
*copyc iot$tape_command_table_entry
*copyc iot$tape_unit_status_list
*copyc iot$wired_tape_tables
*copyc mme$condition_codes
*copyc osd$virtual_address
*copyc osk$tape_keypoints
*copyc osk$keypoints
*copyc oss$mainframe_pageable
*copyc ost$page_size
*copyc syc$monitor_request_codes
*copyc syt$monitor_request_code
?? POP ??

?? OLDTITLE ??
?? NEWTITLE := ' xref definitions ' ??
?? EJECT ??

*copyc i#call_monitor
*copyc cmp$get_element_name_via_lun
*copyc cmp$get_logical_unit_state
*copyc mmp$test_for_cache_bypass
*copyc osp$initialize_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$unpack_status_identifier
*copyc pmp$find_executing_task_xcb

?? OLDTITLE ??
?? NEWTITLE := ' iop$allocate_wired_tape_tables ' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iop$allocate_wired_tape_tables (
    index: iot$no_of_tape_units;
    multiple_requests_possible: boolean);

    VAR
      i: 1 .. ioc$max_multiple_tape_requests,
      j: 1 .. ioc$max_multiple_tape_requests,
      wired_table_p: ^iot$wired_tape_tables;

    wired_table_p := ^iov$wired_tape_tables^ [index];

    IF multiple_requests_possible THEN
      j := ioc$max_multiple_tape_requests;
    ELSE { only need one set of tables
      j := 1;
      FOR i := 2 to ioc$max_multiple_tape_requests DO {ensure unallocated slots are not used
        wired_table_p^ [i].slot_in_use := TRUE;
      FOREND;
    IFEND;

    FOR i := 1 to j DO
      wired_table_p^ [i].slot_in_use := FALSE;
      ALLOCATE wired_table_p^ [i].io_request_p IN osv$mainframe_wired_cb_heap^;
      ALLOCATE wired_table_p^ [i].wired_tape_request_p IN osv$mainframe_wired_cb_heap^;
      ALLOCATE wired_table_p^ [i].wired_tape_request_p^.pp_response_p IN
            osv$mainframe_wired_cb_heap^;
      ALLOCATE wired_table_p^ [i].wired_tape_request_p^.wired_read_description_p IN
            osv$mainframe_wired_heap^;

{ The wired_write_description_p is only allocated if a write is performed on the tape.

      wired_table_p^ [i].wired_tape_request_p^.wired_write_description_p := NIL;

      ALLOCATE wired_table_p^ [i].request_block_p IN osv$mainframe_wired_cb_heap^;
      wired_table_p^ [i].io_request_p^.device_request_p := wired_table_p^ [i].wired_tape_request_p;

{ Use pp_request_p pointer in io_request_p (iot$io_request) to point to the completion_q_table_entry
{ for this request.

      wired_table_p^ [i].io_request_p^.pp_request_p := ^iov$tape_completion_q_table^ [index].req [i];

      wired_table_p^ [i].request_block_p^.request_code := syc$rc_tape_io;
      wired_table_p^ [i].request_block_p^.io_request_p := wired_table_p^ [i].io_request_p;
      iov$tape_completion_q_table^ [index].req [i].waiting_response := FALSE;
      iov$tape_completion_q_table^ [index].req [i].request_not_processed := FALSE;
      iov$tape_completion_q_table^ [index].req [i].io_id := 0;
      iov$tape_completion_q_table^ [index].req [i].io_request := NIL;
      iov$tape_completion_q_table^ [index].req [i].task_id := tmv$null_global_task_id;
      iov$tape_completion_q_table^ [index].req [i].check_task_id := FALSE;
    FOREND;

    iov$tape_completion_q_table^ [index].sync_set := FALSE;
    iov$tape_completion_q_table^ [index].cart_writes_pending := 0;

  PROCEND iop$allocate_wired_tape_tables;

?? OLDTITLE ??
?? NEWTITLE := ' iop$change_tape_scan_freq_113 ' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iop$change_tape_scan_freq_113
    (    scan_frequency: integer);

    IF scan_frequency > 0 THEN
      iov$tape_scan_frequency := scan_frequency;
    IFEND;

  PROCEND iop$change_tape_scan_freq_113;

?? OLDTITLE ??
?? NEWTITLE := ' iop$free_tape_tables ' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iop$free_tape_tables;

    VAR
      i: iot$no_of_tape_units;

    iov$number_of_tape_units := 0;
    iov$establish_tape_statistics := TRUE;

    IF iov$tape_completion_q_table <> NIL THEN
      FREE iov$tape_completion_q_table IN osv$mainframe_wired_heap^;
    IFEND;

    IF iov$wired_tape_tables <> NIL THEN
      FOR i := 1 TO UPPERBOUND(iov$wired_tape_tables^) DO
        iop$free_wired_tape_tables (i);
      FOREND;
      FREE iov$wired_tape_tables IN osv$mainframe_pageable_heap^;
    IFEND;

    IF iov$tusl_p <> NIL THEN
      FREE iov$tusl_p IN osv$mainframe_pageable_heap^;
    IFEND;

  PROCEND iop$free_tape_tables;

?? OLDTITLE ??
?? NEWTITLE := ' iop$free_wired_tape_tables ' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iop$free_wired_tape_tables (
    index: iot$no_of_tape_units);

    VAR
      i: 1 .. ioc$max_multiple_tape_requests,
      wired_table_p: ^iot$wired_tape_tables;

    wired_table_p := ^iov$wired_tape_tables^ [index];
    FOR i := 1 to ioc$max_multiple_tape_requests DO
      IF wired_table_p^ [i].io_request_p <> NIL THEN
        IF NOT wired_table_p^ [i].slot_in_use THEN
          FREE wired_table_p^ [i].io_request_p IN osv$mainframe_wired_cb_heap^;
        ELSE
          wired_table_p^ [i].io_request_p := NIL;   { Do not free memory
        IFEND;
        FREE wired_table_p^ [i].wired_tape_request_p^.pp_response_p IN
              osv$mainframe_wired_cb_heap^;
        FREE wired_table_p^ [i].wired_tape_request_p^.wired_read_description_p IN
              osv$mainframe_wired_heap^;
        IF wired_table_p^ [i].wired_tape_request_p^.wired_write_description_p <> NIL THEN
          FREE wired_table_p^ [i].wired_tape_request_p^.wired_write_description_p IN
                osv$mainframe_wired_heap^;
        IFEND;
        FREE wired_table_p^ [i].wired_tape_request_p IN osv$mainframe_wired_cb_heap^;
        FREE wired_table_p^ [i].request_block_p IN osv$mainframe_wired_cb_heap^;
      IFEND;
      wired_table_p^ [i].slot_in_use := FALSE;
    FOREND;

  PROCEND iop$free_wired_tape_tables;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_clear_activate_stats ' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iop$tape_clear_activate_stats (VAR status: ost$status);

    status.normal := TRUE;

{ Set the boolean flag to FALSE to indicate tape statistics do not need to be established.

   iov$establish_tape_statistics := FALSE;

  PROCEND iop$tape_clear_activate_stats;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_enable_ready_task ' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iop$tape_enable_ready_task (
        i: iot$no_of_tape_units;
        j: 1 .. ioc$max_multiple_tape_requests);

    VAR
      ccc_cart_unit_comm_buffer_p: ^iot$ccc_cart_unit_comm_buffer,
      wired_request_p: ^iot$wired_tape_request,
      xcb_p: ^ost$execution_control_block;

    wired_request_p := iov$tape_completion_q_table^ [i].req [j].io_request^.device_request_p;
    IF ((wired_request_p^.io_type = ioc$explicit_write) AND (wired_request_p^.pp_response_p^.
          controller_type = cmc$mt5680_xx)) THEN
      RESET cmv$logical_unit_table^ [wired_request_p^.request.logical_unit].unit_communication_buffer_pva;
      NEXT ccc_cart_unit_comm_buffer_p IN cmv$logical_unit_table^ [wired_request_p^.request.logical_unit].
            unit_communication_buffer_pva;
      ccc_cart_unit_comm_buffer_p^.request_pva := iov$tape_completion_q_table^ [i].req [j].io_request;
      ccc_cart_unit_comm_buffer_p^.force_sync := 0;
    IFEND;
    pmp$find_executing_task_xcb (xcb_p);
    wired_request_p^.task_id := xcb_p^.global_task_id;
    #SPOIL (wired_request_p^.task_id);
    wired_request_p^.ready_task := TRUE;

  PROCEND iop$tape_enable_ready_task;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_enable_taskid_check ' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iop$tape_enable_taskid_check (
        i: iot$no_of_tape_units;
        j: 1 .. ioc$max_multiple_tape_requests);

    VAR
      xcb_p: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb_p);
    iov$tape_completion_q_table^ [i].req [j].task_id := xcb_p^.global_task_id;
    #SPOIL (iov$tape_completion_q_table^ [i].req [j].task_id);
    iov$tape_completion_q_table^ [i].req [j].check_task_id := TRUE;

  PROCEND iop$tape_enable_taskid_check;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_initialization ' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iop$tape_initialization (logical_unit_table: ^cmt$logical_unit_table;
    VAR status: ost$status);

    VAR
      element_name: ost$name,
      i: iot$logical_unit,
      ignore_status: ost$status,
      j: integer,
      length: iot$logical_unit,
      lun: iot$logical_unit,
      state: cmt$element_state,
      unit_index: iot$no_of_tape_units;

    BEGIN
      status.normal := TRUE;

      length := UPPERBOUND (logical_unit_table^);

      iop$free_tape_tables;

{ Count number of tape units for ALLOCATE.

      FOR i := cmc$job_template_unit_ordinal TO length DO
        IF (logical_unit_table^ [i].unit_interface_table <> NIL) THEN
          IF (logical_unit_table^ [i].unit_interface_table^.unit_type <= ioc$highest_tape_unit) THEN
            iov$number_of_tape_units := iov$number_of_tape_units + 1;
          IFEND;
        IFEND;
      FOREND;

      IF iov$number_of_tape_units = 0 THEN
        RETURN;
      IFEND;

      IF iov$number_of_tape_units > ioc$max_number_tape_units THEN
        osp$set_status_abnormal ('IO', ioe$too_many_tapes_defined, ' ', status);
        RETURN;
      IFEND;

{ Allocate and initialize the tape completion queue table.

      ALLOCATE iov$tape_completion_q_table: [1 .. iov$number_of_tape_units] IN
            osv$mainframe_wired_heap^;

      unit_index := 0;

      FOR i := cmc$job_template_unit_ordinal TO length DO
        IF (logical_unit_table^ [i].unit_interface_table <> NIL) THEN
          IF (logical_unit_table^ [i].unit_interface_table^.unit_type <= ioc$highest_tape_unit) THEN
            unit_index := unit_index + 1;

{ Initialize the logical unit number field.

            iov$tape_completion_q_table^ [unit_index].lun := i;
          IFEND;
        IFEND;
      FOREND;

{ Initialize the tape completion queue table request entries.

      FOR i := 1 TO iov$number_of_tape_units DO
        iov$tape_completion_q_table^ [i].sync_set := FALSE;
        iov$tape_completion_q_table^ [i].cart_writes_pending := 0;
        FOR j := 1 to ioc$max_multiple_tape_requests DO
          iov$tape_completion_q_table^ [i].req [j].waiting_response := FALSE;
          iov$tape_completion_q_table^ [i].req [j].request_not_processed := FALSE;
          iov$tape_completion_q_table^ [i].req [j].io_id := 0;
          iov$tape_completion_q_table^ [i].req [j].io_request := NIL;
          iov$tape_completion_q_table^ [i].req [j].task_id := tmv$null_global_task_id;
          iov$tape_completion_q_table^ [i].req [j].check_task_id := FALSE;
        FOREND;
      FOREND;

{ Allocate and initialize wired request table.  Note - the completion_q_index
{ for a unit is also the index into this table.

      ALLOCATE iov$wired_tape_tables: [1 .. iov$number_of_tape_units] IN osv$mainframe_pageable_heap^;

      FOR i := 1 TO iov$number_of_tape_units DO
        FOR j := 1 to ioc$max_multiple_tape_requests DO
          iov$wired_tape_tables^ [i][j].slot_in_use := FALSE;
          iov$wired_tape_tables^ [i][j].io_request_p := NIL;
          iov$wired_tape_tables^ [i][j].wired_tape_request_p := NIL;
          iov$wired_tape_tables^ [i][j].request_block_p := NIL;
        FOREND;
      FOREND;

{ Allocate and initialize the Tape_Unit_Status_List (TUSL)

      ALLOCATE iov$tusl_p: [1 .. iov$number_of_tape_units] IN osv$mainframe_pageable_heap^;

      FOR i := LOWERBOUND(iov$tusl_p^) TO UPPERBOUND(iov$tusl_p^) DO
        lun := iov$tape_completion_q_table^ [i].lun;
        cmp$get_element_name_via_lun (lun, element_name, status);
        iov$tusl_p^[i].element_name := element_name;
        cmp$get_logical_unit_state (lun, logical_unit_table, state);
        iov$tusl_p^[i].tape_unit_state := state;
        find_logical_pps_for_unit (lun, iov$tusl_p^[i].logical_pp, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        iov$tusl_p^[i].unit_ready := FALSE;
        iov$tusl_p^[i].read_error := FALSE;
        iov$tusl_p^[i].evsn := rmc$unspecified_vsn;
        iov$tusl_p^[i].rvsn := rmc$unspecified_vsn;
        iov$tusl_p^[i].reassign_device_control.command_allowed := FALSE;
        iov$tusl_p^[i].ssn := jmc$blank_system_supplied_name;

{ Set sfid to the equivalent of dmv$null_sfid.  We cannot use dmv$null_sfid here
{ because it is not defined in the boot.

        iov$tusl_p^[i].sfid.file_entry_index := 0;
        iov$tusl_p^[i].sfid.residence := gfc$tr_null_residence;
        iov$tusl_p^[i].sfid.file_hash := 0;
        iov$tusl_p^[i].assignment_state := ioc$not_assigned;
        iov$tusl_p^[i].detected_tape_characteristics.label_type := amc$labelled;
        iov$tusl_p^[i].detected_tape_characteristics.character_set := amc$ascii;
        iov$tusl_p^[i].detected_tape_characteristics.write_ring := FALSE;
        iov$tusl_p^[i].detected_tape_characteristics.density := rmc$200;
        iov$tusl_p^[i].unit_type := logical_unit_table^ [lun].unit_interface_table^.unit_type;
        osp$initialize_signature_lock (iov$tusl_p^[i].lock, ignore_status);
      FOREND;

    END
  PROCEND iop$tape_initialization;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_queue_request_setup ' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iop$tape_queue_request_setup (tape_request_p: ^iot$tape_request;
    VAR status: ost$status);

    VAR
      buffer_length: iot$tape_block_length,
      cache_bypass: boolean,
      command_heap_p: ^iot$tape_command_heap,
      dummy_array_pointer: ^array [1 .. amc$maximum_block] of 0 .. 0ff(16),
      dump: 0 .. 0ff(16),
      dump1: 0 .. 0ff(16),
      dump2: iot$tape_transfer_count,
      found: boolean,
      i: 1 .. ioc$max_multiple_tape_requests,
      identifier: ost$status_identifier,
      l: iot$tape_block_count,
      m: 0 .. osc$max_segment_length DIV osc$min_page_size,
      no_of_pages: 0 .. osc$max_segment_length DIV osc$min_page_size,
      osv$page_size: [XREF] ost$page_size,
      page_size: ost$page_size,
      wired_tape_request_p: ^iot$wired_tape_request,
      wired_tape_tables: ^iot$wired_tape_tables;

    status.normal := TRUE;

    #INLINE ('keypoint', osk$entry, osk$m * ORD (tape_request_p^.io_type), ioc$tape_entry_ioptqsu);
    wired_tape_tables := ^iov$wired_tape_tables^ [tape_request_p^.ud^.completion_q_index];
    found := FALSE;

  /search_for_empty_entry/
    FOR i := 1 to ioc$max_multiple_tape_requests DO
      IF NOT wired_tape_tables^ [i].slot_in_use THEN
        wired_tape_tables^ [i].slot_in_use := TRUE;
        found := TRUE;
        EXIT /search_for_empty_entry/;
      IFEND;
    FOREND /search_for_empty_entry/;

    IF NOT found THEN
      osp$set_status_abnormal ('IO', ioc$os_failure,
            'unable to find wired request entry in tape_queue_manager_ring1.', status);
      RETURN;
    IFEND;

    wired_tape_request_p := wired_tape_tables^ [i].wired_tape_request_p;
    IF (tape_request_p^.request_type = ioc$tape_read) OR (tape_request_p^.request_type =
          ioc$tape_read_backwards) THEN
      wired_tape_request_p^.wired_read_description_p^ := tape_request_p^.read_block_description^;
    IFEND;
    IF tape_request_p^.request_type = ioc$tape_write THEN
      IF (wired_tape_request_p^.wired_write_description_p = NIL) THEN  { Allocate write description
        ALLOCATE wired_tape_request_p^.wired_write_description_p IN osv$mainframe_wired_heap^;
      IFEND;
      wired_tape_request_p^.wired_write_description_p^ := tape_request_p^.write_block_description^;
    IFEND;
    ALLOCATE command_heap_p: [1 .. tape_request_p^.estimated_address_pair_count] IN
          osv$mainframe_wired_cb_heap^;
    command_heap_p^.rma_list [1].length := 0;
    wired_tape_request_p^.completion_q_index := tape_request_p^.ud^.completion_q_index;
    wired_tape_request_p^.no_of_data_commands := tape_request_p^.no_of_data_commands;
    wired_tape_request_p^.max_input_count := tape_request_p^.max_input_count;
    wired_tape_request_p^.first_data_command := tape_request_p^.first_data_command;
    wired_tape_request_p^.io_id := tape_request_p^.io_id;
    wired_tape_request_p^.recovery_requeue := tape_request_p^.recovery_requeue;
    wired_tape_request_p^.request_type := tape_request_p^.request_type;
    wired_tape_request_p^.io_type := tape_request_p^.io_type;
    wired_tape_request_p^.allocated_address_pair_count :=
          tape_request_p^.estimated_address_pair_count;
    wired_tape_request_p^.wired_command_heap_p := command_heap_p;
    wired_tape_request_p^.pp_response_p^.controller_type := tape_request_p^.ud^.controller_type;
    wired_tape_request_p^.request := tape_request_p^.request;
    wired_tape_request_p^.tape_request_p := tape_request_p;
    wired_tape_request_p^.address_pair_count := 0;
    wired_tape_request_p^.list_p := NIL;
    wired_tape_request_p^.data_pages_locked := TRUE;
    wired_tape_request_p^.ready_task := FALSE;
    wired_tape_request_p^.wired_tape_table_index := i;
    IF tape_request_p^.io_type = ioc$explicit_read THEN
      mmp$test_for_cache_bypass(tape_request_p^.read_block_description^ [1].buffer_area,
            cache_bypass, status);   {Bad status will be detected later}
      wired_tape_request_p^.cache_purge_required_data := NOT cache_bypass;
      IF cache_bypass THEN
        mmp$test_for_cache_bypass(tape_request_p^.read_block_description^ [1].
              block_transfer_length, cache_bypass, status);   {Bad status will be detected later}
        wired_tape_request_p^.cache_purge_required_length := NOT cache_bypass;
      ELSE { do not repeat purge_cache if already did it on data pages
        wired_tape_request_p^.cache_purge_required_length := FALSE;
      IFEND;
    IFEND;

  /issue_monitor_req/
    WHILE TRUE DO

      i#call_monitor (#LOC (wired_tape_tables^ [i].request_block_p^),
            #SIZE (wired_tape_tables^ [i].request_block_p^));

      status.normal := wired_tape_tables^ [i].request_block_p^.status.normal;
      status.condition := wired_tape_tables^ [i].request_block_p^.status.condition;
      IF status.normal OR (NOT status.normal AND (status.condition <>
            mme$page_frame_not_assigned)) THEN
        EXIT /issue_monitor_req/;
      IFEND;

{ Reference each page to cause it to be loaded into memory.  This is only done
{ if a mme$page_frame_not_assigned status is returned from monitor after an
{ attempt to issue the request.  This error can only be returned if the operation
{ is ioc$explicit_read or ioc$explicit_write.

      page_size := osv$page_size;
      FOR l := 1 TO tape_request_p^.no_of_data_commands DO
        IF tape_request_p^.io_type = ioc$explicit_read THEN
          buffer_length := tape_request_p^.max_input_count;
          dummy_array_pointer := tape_request_p^.read_block_description^ [l].buffer_area;
        ELSE
          buffer_length := tape_request_p^.write_block_description^ [l].transfer_length;
          dummy_array_pointer := tape_request_p^.write_block_description^ [l].buffer_area;
        IFEND;
        no_of_pages := buffer_length DIV page_size;
        dump := dummy_array_pointer^ [1];
        dump1 := dummy_array_pointer^ [buffer_length];
        IF no_of_pages > 0 THEN
          FOR m := 1 TO no_of_pages DO
            dump := dummy_array_pointer^ [m * page_size];
          FOREND;
        IFEND;
        IF tape_request_p^.io_type = ioc$explicit_read THEN
          dump2 := tape_request_p^.read_block_description^ [l].block_transfer_length^;
        IFEND;
      FOREND;
    WHILEND /issue_monitor_req/;

    IF NOT status.normal THEN
      osp$unpack_status_identifier (wired_tape_tables^ [i].request_block_p^.status.condition, identifier);
      osp$set_status_abnormal (identifier, wired_tape_tables^ [i].request_block_p^.status.
            condition, 'Bad status from tape I/O monitor ', status);
      wired_tape_tables^ [i].slot_in_use := FALSE;
      FREE wired_tape_request_p^.wired_command_heap_p IN osv$mainframe_wired_cb_heap^;
    IFEND;

  PROCEND iop$tape_queue_request_setup;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_request_not_processed ' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iop$tape_request_not_processed (i: iot$io_id;
        j: iot$no_of_tape_units;
        q: 1 .. ioc$max_multiple_tape_requests;
    VAR status: ost$status);

    status.normal := TRUE;

{ Check if call to clear out waiting response on a request_not_processed completion_code (i = 0).

    IF i = 0 THEN
      iov$tape_completion_q_table^ [j].req [q].io_id := 0;
      iov$tape_completion_q_table^ [j].req [q].request_not_processed := FALSE;
      iov$tape_completion_q_table^ [j].req [q].waiting_response := FALSE;
      iov$tape_completion_q_table^ [j].req [q].io_request := NIL;
      iov$tape_completion_q_table^ [j].req [q].task_id := tmv$null_global_task_id;
      iov$tape_completion_q_table^ [j].req [q].check_task_id := FALSE;
    ELSE

{ Set request_not_processed status in iov$tape_completion_queue_table for the provided io_id.

      iov$tape_completion_q_table^ [j].req [q].io_id := i;
      iov$tape_completion_q_table^ [j].req [q].request_not_processed := TRUE;
      iov$tape_completion_q_table^ [j].req [q].waiting_response := TRUE;
    IFEND;

  PROCEND iop$tape_request_not_processed;

?? OLDTITLE ??
?? NEWTITLE := ' iop$tape_return_wired_request ' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iop$tape_return_wired_request (i: iot$no_of_tape_units;
        j: 1 .. ioc$max_multiple_tape_requests;
    VAR tape_request_p: ^iot$tape_request;
    VAR status: ost$status);

    VAR
      k: 1 .. ioc$max_multiple_tape_requests,
      m: iot$no_of_tape_units,
      n: 1 .. ioc$max_multiple_tape_requests,
      p_next_request: ^iot$io_request,
      p_ud: ^iot$tape_job_unit_descriptor,
      p_unit_table: ^iot$unit_interface_table,
      pending_wired_requests: array [1 .. ioc$max_multiple_tape_requests + 1] of ^iot$wired_tape_request,
      wired_request_p: ^iot$wired_tape_request;

    status.normal := TRUE;

    #INLINE ('keypoint', osk$entry, 0, ioc$tape_entry_ioptrwr);

{ Update pageable request and set wired_tape_tables slot to not is use.

    wired_request_p := iov$tape_completion_q_table^ [i].req [j].io_request^.device_request_p;
    tape_request_p := wired_request_p^.tape_request_p;
    tape_request_p^.pp_response_p^ := wired_request_p^.pp_response_p^;
    tape_request_p^.last_command_processed := wired_request_p^.pp_response_p^.pp_response.last_command -
          wired_request_p^.pp_response_p^.pp_response.request_rma;
    FREE wired_request_p^.wired_command_heap_p IN osv$mainframe_wired_cb_heap^;
    iov$wired_tape_tables^ [i][wired_request_p^.wired_tape_table_index].slot_in_use := FALSE;

{ Check for alert_condition where PP disabled the unit.

    IF tape_request_p^.pp_response_p^.pp_response.alert_conditions.disabled_unit THEN
      p_unit_table := cmv$logical_unit_table^ [tape_request_p^.request.logical_unit].unit_interface_table;

{ Check for pending_requests.

      IF p_unit_table^.next_request <> NIL THEN
        p_next_request := p_unit_table^.next_request;
        wired_request_p := p_next_request^.device_request_p;
        p_ud := wired_request_p^.tape_request_p^.ud;

{ Delink pending_requests from UIT.

        p_unit_table^.next_request := NIL;
        p_unit_table^.next_request_rma := 0;

{ Save wired_pending_request pointers in job_unit_descriptor_array.

      /pending_request_search/
        FOR k := 1 to ioc$max_multiple_tape_requests DO
          pending_wired_requests [k] := p_next_request^.device_request_p;
          p_next_request := pending_wired_requests [k]^.request.next_pp_request;
          IF p_next_request = NIL THEN
            pending_wired_requests [k + 1] := NIL;
            EXIT /pending_request_search/
          IFEND;
        FOREND /pending_request_search/;

{ Delink the wired_pending requests by clearing tape_completion_q_table, saving pointers
{ to pageable request in job_unit_descriptor, FREE wired_request structures, and finally
{ clear the disabled boolean in the UIT for this unit.

      /delink_pending_requests/
        FOR k := 1 to ioc$max_multiple_tape_requests DO
          wired_request_p := pending_wired_requests [k];
          p_ud^.pending_pageable_requests [k] := NIL;
          IF wired_request_p = NIL THEN
            EXIT /delink_pending_requests/
          IFEND;
          m := wired_request_p^.completion_q_index;
        /clear_completion_q_entry/
          FOR n := 1 to ioc$max_multiple_tape_requests DO
            IF iov$tape_completion_q_table^ [m].req [n].io_id = wired_request_p^.io_id THEN
              iov$tape_completion_q_table^ [m].req [n].io_id := 0;
              iov$tape_completion_q_table^ [m].req [n].io_request := NIL;
              iov$tape_completion_q_table^ [m].req [n].waiting_response := FALSE;
              iov$tape_completion_q_table^ [m].req [n].request_not_processed := FALSE;
              iov$tape_completion_q_table^ [m].req [n].task_id := tmv$null_global_task_id;
              iov$tape_completion_q_table^ [m].req [n].check_task_id := FALSE;
              EXIT /clear_completion_q_entry/
            IFEND;
          FOREND /clear_completion_q_entry/;

{ Save pointer to pending job_pageable_request in job_unit_descriptor.

          p_ud^.pending_pageable_requests [k] := wired_request_p^.tape_request_p;
          pending_wired_requests [k] := NIL;

{ Set wired_tape_tables slot to not in use and free RMA list.

          FREE wired_request_p^.wired_command_heap_p IN osv$mainframe_wired_cb_heap^;
          iov$wired_tape_tables^ [m][wired_request_p^.wired_tape_table_index].slot_in_use := FALSE;

        FOREND /delink_pending_requests/;
      IFEND;

{ Must clear unit_disabled status in UIT.

      p_unit_table^.unit_status.disabled := FALSE;

    IFEND;

{ Clear out the tape_completion_packet for this request/io_id.

    iov$tape_completion_q_table^ [i].req [j].waiting_response := FALSE;
    iov$tape_completion_q_table^ [i].req [j].request_not_processed := FALSE;
    iov$tape_completion_q_table^ [i].req [j].io_id := 0;
    iov$tape_completion_q_table^ [i].req [j].io_request := NIL;
    iov$tape_completion_q_table^ [i].req [j].task_id := tmv$null_global_task_id;
    iov$tape_completion_q_table^ [i].req [j].check_task_id := FALSE;

  PROCEND iop$tape_return_wired_request;

?? OLDTITLE ??
?? NEWTITLE := ' find_logical_pps_for_unit ' ??
?? EJECT ??

  PROCEDURE find_logical_pps_for_unit (lun: iot$logical_unit;
    VAR logical_pp: array [1 .. 4] of iot$pp_number;
    VAR status: ost$status);

    VAR
      index: 1 .. 4,
      logical_pp_table: ^cmt$logical_pp_table,
      lpp_index: iot$pp_number,
      ppit_p: ^iot$pp_interface_table,
      unit_descriptor_index: integer,
      unit_descriptors_p: ^iot$unit_descriptors;

    status.normal := TRUE;

    FOR index := 1 to 4 DO
      logical_pp [index] := 0;
    FOREND;
    index := 1;

    IF (cmv$new_logical_pp_table_p = NIL) OR (cmv$logical_pp_table_p = cmv$new_logical_pp_table_p) THEN
      logical_pp_table := cmv$logical_pp_table_p;
    ELSE
      logical_pp_table := cmv$new_logical_pp_table_p;
    IFEND;

    /lpp_search_loop/
    FOR lpp_index := LOWERBOUND (logical_pp_table^) TO UPPERBOUND (logical_pp_table^) DO
      IF logical_pp_table^ [lpp_index].flags.configured AND
            NOT logical_pp_table^ [lpp_index].pp_info.pp_communication_buffer_p^.slave THEN
        ppit_p := logical_pp_table^ [lpp_index].pp_info.pp_interface_table_p;
        IF (ppit_p^.first_logical_unit <= lun) AND (ppit_p^.first_logical_unit +
              ppit_p^.number_of_units > lun) THEN
          unit_descriptors_p := ^ppit_p^.unit_descriptors;
          FOR unit_descriptor_index := ppit_p^.first_logical_unit TO
                (ppit_p^.first_logical_unit + ppit_p^.number_of_units - 1) DO
            IF unit_descriptors_p^ [unit_descriptor_index].unit_interface_table <> NIL THEN
              IF unit_descriptors_p^ [unit_descriptor_index].logical_unit = lun THEN
                logical_pp [index] := lpp_index;
                IF index = 4 THEN
                  EXIT /lpp_search_loop/;  { found maximum number of logical pps
                ELSE
                  index := index + 1;
                  CYCLE /lpp_search_loop/;
                IFEND;
              IFEND;
            IFEND;
          FOREND;
        IFEND;
      IFEND;
    FOREND /lpp_search_loop/;

    IF index = 1 THEN {did not find any logical pp table containing input logical unit number
      osp$set_status_abnormal ('IO', ioc$os_failure,
            'unable to find logical pp table in tape_queue_manager_ring1.', status);
    IFEND;

  PROCEND find_logical_pps_for_unit;

?? OLDTITLE ??

MODEND iom$tape_queue_manager_ring1;

*DECK DECK=IOM$TAPE_QUEUE_MANAGER_RING2 EXPAND=TRUE
MODULE iom$tape_queue_manager_ring2;
? VAR system_version : boolean := TRUE?;
*copy ioi$tape_queue_manager

MODEND iom$tape_queue_manager_ring2;
*DECK DECK=IOM$TAPE_SCANNER EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Tape Scanner Management Routines' ??
MODULE iom$tape_scanner;

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$label_type
*copyc bat$block_header
*copyc cmt$element_capabilities
*copyc cyd$run_time_error_condition
*copyc dme$tape_errors
*copyc dmt$error_condition_codes
*copyc dmt$system_file_id
*copyc fst$ansi_vol1_label
*copyc fst$path_handle_name
*copyc ife$error_codes
*copyc ioc$tape_retry_limits
*copyc ioe$tape_io_conditions
*copyc ioe$tape_io_conditions
*copyc iot$no_of_tape_units
*copyc iot$io_id
*copyc iot$tape_io_status
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc ofd$type_definition
*copyc ofe$error_codes
*copyc ofp$report_status_error
*copyc oss$task_shared
*copyc oss$task_shared
*copyc ost$caller_identifier
*copyc ost$name
*copyc ost$status
*copyc ost$wait
*copyc pmd$system_log_interface
*copyc pmt$condition
*copyc pmt$established_handler
*copyc rmd$tape_declarations
*copyc rmd$volume_declarations
*copyc rme$condition_codes
*copyc tmt$system_task_id
?? POP ??

*copyc avp$configuration_administrator
*copyc avp$removable_media_operator
*copyc avp$system_displays
*copyc cmp$get_element_name_via_lun
*copyc cmp$lock_lun_entry
*copyc cmp$process_state_change
*copyc cmp$state_change_pending
*copyc cmp$unlock_lun_entry
*copyc iop$any_task_waiting_assignment
*copyc iop$change_tape_scan_freq_113
*copyc iop$initialize_tape_ud
*copyc iop$rdy_task_waiting_assignment
*copyc iop$read_lock_tusl_entry
*copyc iop$read_tape_scan
*copyc iop$rewind_tape_scan
*copyc iop$tape_initialize_unit_scan
*copyc iop$tape_internal_request_stat
*copyc iop$tape_terminate_io_scan
*copyc iop$write_unlock_tusl_entry
*copyc osp$establish_condition_handler
*copyc osp$format_message
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc osp$translate_bytes
*copyc osp$verify_system_privilege
*copyc pmp$continue_to_cause
*copyc pmp$delay
*copyc pmp$log
*copyc pmp$log_ascii
*copyc pmp$wait
*copyc tmp$save_system_task_id

*copyc osv$ebcdic_to_ascii
*copyc osv$task_private_heap
*copyc oss$task_private
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc iov$number_of_tape_units
*copyc iov$tape_completion_q_table
*copyc iov$tape_scan_frequency
*copyc iov$tusl_p

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    expected_io_completion_time = 2 * 1000000 {microseconds}, {expect tape I/O completion in < 2 seconds}
    expected_tape_scan_time = 2 {seconds}, {expect all tape units to be scanned in < 2 seconds}
    max_lock_attempts = 10,
    max_tusl_entry_lock_attempts = 30,
    one_second = 1000 {milliseconds},
    one_tenth_second = 100 {milliseconds},
    timeout_limit = 5 * 60 * 1000000 {microseconds}; {5 minute timeout for response to tape request}

?? PUSH (LIST := ON) ??

?? OLDTITLE ??
?? NEWTITLE := ' iop$change_tape_scan_freq_23d ' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iop$change_tape_scan_freq_23d
    (    scan_frequency: integer;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    IF caller_id.ring > osc$tsrv_ring THEN
      IF NOT avp$configuration_administrator () THEN
        osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
        RETURN;
      IFEND;
    IFEND;
    osp$verify_system_privilege;

    iop$change_tape_scan_freq_113 (scan_frequency);

  PROCEND iop$change_tape_scan_freq_23d;

?? OLDTITLE ??
?? NEWTITLE := ' iop$fetch_tape_scan_frequency ' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] iop$fetch_tape_scan_frequency
    (VAR scan_frequency: integer;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    IF caller_id.ring > osc$tsrv_ring THEN
      IF NOT (avp$configuration_administrator () OR avp$system_displays () OR
               avp$removable_media_operator ()) THEN
        osp$set_status_abnormal ('OF', ofe$sou_not_active,
             'configuration_administration, system_displays, removable_media_operation', status);
        RETURN;
      IFEND;
      osp$verify_system_privilege;
    IFEND;

    scan_frequency := iov$tape_scan_frequency;

  PROCEND iop$fetch_tape_scan_frequency;

?? OLDTITLE ??
?? NEWTITLE := 'iop$tape_scanner', EJECT ??

  PROCEDURE [XDCL, #GATE] iop$tape_scanner;

{ Purpose: This procedure contains one of the processes that provide Automatic Volume Recognition
{           of Labelled Tapes.
{
{ Flow:  The Tape Scanner is a System_Task that, once activated, will scan all unassigned/configured Tape
{        Units and then either go into a short_wait mode (periodically scan until all tape mount requests are
{        satisfied), or an indefinite_wait mode (scanner goes to sleep until another tape mount is
{        requested or an operator command activates the scanner for one scan).
{
{        The scanner is called when a tape file is opened, or by the refreshing of the Tape Status Display.
{
{        The procedure  'iop$tape_scanner' contains a CASE statement with a case_selector named
{          'next_scan_mode'. The CASE statement is the key to the flow of the scanner as indicated in the
{          following Structured English layout of the scanner.
{
{        PROCEDURE iop$tape_scanner;
{
{          TYPE
{          iot$tape_scanner_mode = (status_all_units, scan_rvl, short_wait, indefinite_wait);
{
{                 next_scan_mode: iot$tape_scanner_mode;
{                 Initialize scanner (Pass through here at deadstart or scanner restart).
{                 ALLOCATE necessary Task_Private containers (Read, Transfer_count, Array of rvsns_online.
{
{                 WHILE TRUE DO
{                   scanner_active := TRUE;
{                   next_scan_mode := status_all_units;
{
{                -->WHILE scanner_active DO
{                !
{                !
{                !    CASE next_scan_mode OF
{                !
{                !    = status_all_units =
{                !      FOR i := 1 TO max_units DO
{                !        status and read 1st record of an unassigned/ready unit.
{                !        update tape_status display entries.
{                !        set rvsn_online in array if labelled tape exits.
{                !      FOREND;
{                !
{                !      next_scan_mode := scan_rvl;
{                !      IF rvsns_online^[1] <> rmc$unspecified_vsn THEN
{                !       {Call procedure that determines if an assignment should be made,
{                !         {and that procedure will do a ready_task on the job that gets the tape assignment.
{                !      IFEND;
{                !
{                !    = scan_rvl =
{                !      tasks_are_waiting := FALSE; (task waiting for a tape mount)
{                !      call procedure to scan rvl and the procedure sets tasks_are_waiting accordingly.
{                !      IF NOT tasks_are_waiting THEN
{                !        next_scan_mode := indefinite_wait;
{                !      ELSE
{                !        next_scan_mode := short_wait;
{                !      IFEND;
{                !
{                !    = short_wait =
{                !      next_scan_mode := status_all_units;
{                !      pmp$ (10 seconds)
{                !
{                !    = indefinite_wait =
{                !      scanner_active := FALSE;
{                !
{                !    ELSE
{                !    CASEND;
{                -->WHILEND;
{                   pmp$wait(0ffffffffffff(16),0ffffffffffff(16)); sleep_mode
{                 WHILEND;

    TYPE
      iot$tape_scanner_mode = (status_all_units, scan_rvl, short_wait, indefinite_wait);

    VAR
      all_tape_mounts_found: boolean,
      current_time: integer,
      block: iot$read_tape_description,
      block_transfer_length: ^iot$tape_transfer_count,
      byte: 0 .. 0ff(16),
      byte_pointer: ^array [1 .. 4128] of 0 .. 0ff(16),
      element_capability: cmt$element_capabilities,
      element_descriptor: cmt$element_descriptor,
      error: ost$error,
      evsn: rmt$external_vsn,
      input_buffer: ^SEQ (REP 4128 of cell),
      i: iot$no_of_tape_units,
      j: iot$no_of_tape_units,
      ignore_status: ost$status,
      io_id: iot$io_id,
      io_status: iot$tape_io_status,
      last_scan_time: integer,
      local_status: ost$status,
      lock_attempts: integer,
      logset: pmt$ascii_logset,
      lpp: 1 .. 4,
      lpp_found: boolean,
      lun: iot$logical_unit,
      lun_lock_obtained: boolean,
      lun_lock_released: boolean,
      next_scan_mode: iot$tape_scanner_mode,
      previous_unit_ready_status_p: ^array [1 .. * ] of boolean,
      rewind_write_ring_status: boolean,
      rvsns_online_p: iot$new_vsns_online,
      scanner_active: boolean,
      status: ost$status,
      tape_init_record: dmt$tape_initialization_record,
      tasks_are_waiting: boolean,
      timeout_start: integer,
      tusl_entry_locked: boolean,
      tusl_template: iot$tape_unit_status_entry,
      vol1_p: ^fst$ansi_vol1_label,
      volume_id: rmt$recorded_vsn;

    PROCEDURE clean_up
      (    terminate_io_scan: boolean;
           issue_log_message: boolean);

    VAR
      local_status: ost$status;

      IF tusl_entry_locked THEN
        REPEAT
          iop$write_unlock_tusl_entry ({write_entry} FALSE, i, tusl_template, local_status);
          IF NOT local_status.normal AND (local_status.condition = dme$unable_to_lock_tape_table) THEN
            pmp$wait (one_second, one_second);
          IFEND;
        UNTIL local_status.normal OR (local_status.condition <> dme$unable_to_lock_tape_table);
        tusl_entry_locked := NOT local_status.normal;
        #SPOIL (tusl_entry_locked);
      IFEND;

      IF terminate_io_scan THEN
        iop$tape_terminate_io_scan (lun);
      IFEND;

      cmp$unlock_lun_entry (lun, lun_lock_released);
      lun_lock_obtained := FALSE;
      IF issue_log_message THEN
        osp$generate_log_message (logset, status, ignore_status);
      IFEND;
    PROCEND clean_up;

    PROCEDURE tape_scanner_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_stack: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      IF lun_lock_obtained THEN
        clean_up ({terminate_io_scan} TRUE, {issue_log_message} FALSE);
      IFEND;

    PROCEND tape_scanner_handler;

?? OLDTITLE ??
    element_capability := $cmt$element_capabilities [cmc$volume_assignment];
    element_descriptor.element_type := cmc$storage_device_element;
    last_scan_time := 0;
    logset := $pmt$ascii_logset [pmc$system_log];
    lun_lock_obtained := FALSE;
    tape_init_record.density := rmc$1600;
    tusl_entry_locked := FALSE;
    #SPOIL (tusl_entry_locked);
    status.normal := TRUE;

    osp$establish_condition_handler (^tape_scanner_handler, TRUE);

    tmp$save_system_task_id (tmc$stid_tape_scanner, {critical_task} FALSE, status);
    IF NOT status.normal THEN
      osp$generate_log_message (logset, status, ignore_status);
      RETURN;
    IFEND;

{Allocate boolean array to indicate last ready status of each scanned unit.
    PUSH previous_unit_ready_status_p: [1 .. UPPERBOUND (iov$tusl_p^)];

{Allocate array of possible rmt$recorded_vsn(s) that may come online.
    PUSH rvsns_online_p: [1 .. UPPERBOUND (iov$tusl_p^) + 1];

{Allocate buffer into which the label is read.

    ALLOCATE input_buffer IN osv$task_private_heap^;

{Allocate buffer into which the byte length of the record is placed.

    ALLOCATE block_transfer_length IN osv$task_private_heap^;
    block [1].buffer_area := input_buffer;
    block [1].block_transfer_length := block_transfer_length;
    byte_pointer := block [1].buffer_area;

    WHILE TRUE DO
      scanner_active := TRUE;
      next_scan_mode := status_all_units;

{ Initialize unit_ready_status array if scanner has not been called for IOV$TAPE_SCAN_FREQUENCY seconds.

      current_time := #FREE_RUNNING_CLOCK (0);
      IF current_time > last_scan_time + ((iov$tape_scan_frequency + expected_tape_scan_time) * 1000000) THEN
        FOR i := LOWERBOUND (previous_unit_ready_status_p^) TO UPPERBOUND (previous_unit_ready_status_p^) DO
          previous_unit_ready_status_p^ [i] := FALSE;
        FOREND;
      IFEND;

{ Main scanner loop.

      WHILE scanner_active DO

        status.normal := TRUE;

        CASE next_scan_mode OF
        = status_all_units =

          j := LOWERBOUND (rvsns_online_p^);

        /status_all_units_loop/
          FOR i := 1 TO iov$number_of_tape_units DO
            status.normal := TRUE;
            lun := iov$tape_completion_q_table^ [i].lun;

            IF NOT ((cmv$logical_unit_table^ [lun].configured) AND
                  (cmv$logical_unit_table^ [lun].element_capability >= element_capability) AND
                  NOT (cmv$logical_unit_table^ [lun].status.assigned)) THEN
              CYCLE /status_all_units_loop/;
            IFEND;

            element_descriptor.peripheral_descriptor.element_name := iov$tusl_p^ [i].element_name;
            IF cmp$state_change_pending (element_descriptor) THEN
              CYCLE /status_all_units_loop/;
            IFEND;

            tusl_entry_locked := FALSE;
            #SPOIL (tusl_entry_locked);

          /lock_unit_entries_to_initialize/
            FOR lock_attempts := 1 TO max_lock_attempts DO
              cmp$lock_lun_entry (lun, lun_lock_obtained);
              IF NOT lun_lock_obtained THEN
                pmp$wait (one_second, one_second);
                CYCLE /lock_unit_entries_to_initialize/
              IFEND;
              iop$read_lock_tusl_entry (i, tusl_template, local_status);
              tusl_entry_locked := local_status.normal;
              #SPOIL (tusl_entry_locked);
              IF NOT local_status.normal THEN
                cmp$unlock_lun_entry (lun, lun_lock_released);
                IF local_status.condition = dme$unable_to_lock_tape_table THEN
                  pmp$wait (one_second, one_second);
                  CYCLE /lock_unit_entries_to_initialize/
                ELSE
                  EXIT /lock_unit_entries_to_initialize/;
                IFEND;
              ELSE
                EXIT /lock_unit_entries_to_initialize/;
              IFEND;
            FOREND;
            IF NOT tusl_entry_locked THEN
              CYCLE /status_all_units_loop/;
            IFEND;

{ Make sure that there is at least one PP active for this unit.

            lpp_found := FALSE;

          /search_for_active_pp/
            FOR lpp := 1 TO 4 DO
              IF tusl_template.logical_pp [lpp] > 0 THEN
                IF cmv$logical_pp_table_p^ [tusl_template.logical_pp [lpp]].flags.pp_loaded THEN
                  lpp_found := TRUE;
                  EXIT /search_for_active_pp/;
                IFEND;
              IFEND;
            FOREND /search_for_active_pp/;

{Assure chosen unit still available after window time for lock_lun_entry

            IF ((cmv$logical_unit_table^ [lun].configured) AND
                  (cmv$logical_unit_table^ [lun].element_capability >= element_capability) AND
                  NOT (cmv$logical_unit_table^ [lun].status.assigned) AND
                  (tusl_template.assignment_state = ioc$not_assigned) AND (lpp_found)) THEN

{Set up structures for connecting to a tape unit

              tape_init_record.logical_unit_number := lun;
              iop$initialize_tape_ud (tape_init_record, {multiple_requests_possible} FALSE, status);
              IF NOT status.normal THEN
                clean_up ({terminate_io_scan} TRUE, {issue_log_message} TRUE);
                CYCLE /status_all_units_loop/;
              IFEND;

{Connect to the tape unit.

              iop$tape_initialize_unit_scan (lun, io_id, status);
              IF NOT status.normal THEN
                clean_up ({terminate_io_scan} TRUE, {issue_log_message} TRUE);
                CYCLE /status_all_units_loop/;
              IFEND;

{Obtain tape unit status from the format attempt.

              timeout_start := #FREE_RUNNING_CLOCK (0);
              io_status.normal_completion := FALSE;
              io_status.unit_ready := FALSE;
              pmp$wait (one_tenth_second, one_tenth_second);

            /unit_status_loop/
              WHILE (#FREE_RUNNING_CLOCK (0) - timeout_start) < timeout_limit DO
                iop$tape_internal_request_stat (lun, io_id, {buf_release =} TRUE, {bid_recovery =} FALSE,
                       {bid_update =} TRUE, osc$nowait, io_status, status);
                IF NOT status.normal THEN
                  clean_up ({terminate_io_scan} TRUE, {issue_log_message} TRUE);
                  CYCLE /status_all_units_loop/;
                IFEND;
                IF io_status.io_complete THEN
                  EXIT /unit_status_loop/;
                ELSE
                  IF (#FREE_RUNNING_CLOCK (0) - timeout_start) < expected_io_completion_time THEN
                    pmp$wait (one_tenth_second, one_tenth_second);
                    CYCLE /unit_status_loop/;
                  ELSE
                    pmp$wait (one_second, one_second);
                    CYCLE /unit_status_loop/;
                  IFEND;
                IFEND;
              WHILEND /unit_status_loop/;

              IF NOT io_status.io_complete THEN { unit is inoperable, so call CM to DOWN it }
                clean_up ({terminate_io_scan} FALSE, {issue_log_message} TRUE);
                down_tape_unit (lun);
                CYCLE /status_all_units_loop/;
              IFEND;

{Check if tape unit has ready status and capable of reading a tape record.

              IF NOT io_status.unit_ready THEN
                previous_unit_ready_status_p^ [i] := FALSE;
                IF io_status.normal_completion THEN
                  tusl_template.evsn := rmc$unspecified_vsn;
                  tusl_template.rvsn := rmc$unspecified_vsn;
                  tusl_template.unit_ready := FALSE;
                  tusl_template.read_error := FALSE;
                  REPEAT
                    iop$write_unlock_tusl_entry ({write_entry} TRUE, i, tusl_template, local_status);
                    IF NOT local_status.normal AND
                          (local_status.condition = dme$unable_to_lock_tape_table) THEN
                      pmp$wait (one_second, one_second);
                    IFEND;
                  UNTIL local_status.normal OR (local_status.condition <> dme$unable_to_lock_tape_table);
                  tusl_entry_locked := NOT local_status.normal;
                  #SPOIL (tusl_entry_locked);
                  clean_up ({terminate_io_scan} TRUE, {issue_log_message} FALSE);
                ELSE { unit is inoperable, so call CM to DOWN it }
                  clean_up ({terminate_io_scan} TRUE, {issue_log_message} FALSE);
                  down_tape_unit (lun);
                IFEND;
                CYCLE /status_all_units_loop/;
              ELSE {unit ready}
                IF NOT io_status.normal_completion THEN
                  clean_up ({terminate_io_scan} TRUE, {issue_log_message} FALSE);
                  down_tape_unit (lun);
                  CYCLE /status_all_units_loop/;
                IFEND;
              IFEND;

{ The following code is reached only if the unit is ready and no error occurred on rewind function.

              IF ((previous_unit_ready_status_p^ [i]) AND (tusl_template.unit_ready)) OR
                    (io_status.unit_busy) THEN
                IF NOT io_status.unit_busy AND (tusl_template.detected_tape_characteristics.label_type =
                      amc$labelled) THEN
                  rvsns_online_p^ [j].rvsn := tusl_template.rvsn;
                  rvsns_online_p^ [j].unit_type := cmv$logical_unit_table^ [lun].
                        unit_interface_table^.unit_type;
                  j := j + 1;
                IFEND;
                clean_up ({terminate_io_scan} TRUE, {issue_log_message} FALSE);
                CYCLE /status_all_units_loop/;
              IFEND;

              previous_unit_ready_status_p^ [i] := TRUE;
              rewind_write_ring_status := io_status.write_ring; { save ring status from rewind}

            /read_label/
              BEGIN
                byte := byte_pointer^ [1];      { Force buffer pages to memory
                byte := byte_pointer^ [4128];
                iop$read_tape_scan (lun, FALSE, 4128, ^block, 1, io_id, status);
                IF status.normal THEN
                  REPEAT
                    iop$write_unlock_tusl_entry ({write_entry} FALSE, i, tusl_template, local_status);
                    IF NOT local_status.normal AND
                          (local_status.condition = dme$unable_to_lock_tape_table) THEN
                      pmp$wait (one_second, one_second);
                    IFEND;
                  UNTIL local_status.normal OR (local_status.condition <> dme$unable_to_lock_tape_table);
                  tusl_entry_locked := NOT local_status.normal;
                  #SPOIL (tusl_entry_locked);
                  iop$tape_internal_request_stat (lun, io_id, {buf_release =} TRUE, {bid_recovery =} FALSE,
                        {bid_update =} TRUE,osc$wait, io_status, status);
                  IF NOT status.normal THEN
                    clean_up ({terminate_io_scan} TRUE, {issue_log_message} TRUE);
                    CYCLE /status_all_units_loop/;
                  IFEND;

{ Regain the TUSL lock and make sure the unit was not manually assigned during the read.

                /lock_tusl_entry_after_read/
                  FOR lock_attempts := 1 TO max_lock_attempts DO
                    iop$read_lock_tusl_entry (i, tusl_template, local_status);
                    IF NOT local_status.normal AND
                          (local_status.condition = dme$unable_to_lock_tape_table) THEN
                      pmp$wait (one_second, one_second);
                    ELSE
                      EXIT /lock_tusl_entry_after_read/;
                    IFEND;
                  FOREND;
                  tusl_entry_locked := local_status.normal;
                  #SPOIL (tusl_entry_locked);
                  IF NOT tusl_entry_locked THEN
                    clean_up ({terminate_io_scan} TRUE, {issue_log_message} TRUE);
                    CYCLE /status_all_units_loop/;
                  IFEND;
                  tusl_template.unit_ready := TRUE;
                  tusl_template.read_error := FALSE;
                  IF NOT (tusl_template.assignment_state = ioc$not_assigned) THEN
                    EXIT /read_label/;  { Release tape and exit, tape is assigned.
                  IFEND;
                  IF NOT (io_status.normal_completion) THEN
                    IF NOT ((io_status.completion_code = ioc$blank_tape) OR
                          (io_status.completion_code = ioc$indeterminate) OR
                          (io_status.completion_code = ioc$tape_medium_failure) OR
                          (io_status.completion_code = ioc$tapemark_read) OR
                          (io_status.completion_code = ioc$not_capable_of_density) OR
                          (io_status.completion_code = ioc$alert_condition_encountered) OR
                          (io_status.completion_code = ioc$unable_to_set_agc)) THEN
                      clean_up ({terminate_io_scan} TRUE, {issue_log_message} FALSE);
                      IF io_status.unit_ready THEN { down unit }
                        down_tape_unit (lun);
                      IFEND;
                      CYCLE /status_all_units_loop/;
                    ELSEIF NOT ((io_status.completion_code = ioc$blank_tape) OR
                          (io_status.completion_code = ioc$tapemark_read) OR
                          (io_status.completion_code = ioc$alert_condition_encountered)) THEN
                      tusl_template.read_error := TRUE;
                    IFEND;

                    {UPDATE TUSL ENTRY - INDICATE UNLABELLED
                    tusl_template.rvsn := rmc$unspecified_vsn;
                    tusl_template.detected_tape_characteristics.label_type := amc$unlabelled;
                    tusl_template.detected_tape_characteristics.character_set := amc$ascii;
                    tusl_template.detected_tape_characteristics.write_ring := rewind_write_ring_status;
                    EXIT /read_label/;
                  IFEND;
                ELSE
                  clean_up ({terminate_io_scan} TRUE, {issue_log_message} TRUE);
                  CYCLE /status_all_units_loop/;
                IFEND;

                IF (block_transfer_length^.length >= 80) THEN

{Check if this is a labelled tape.

                  RESET input_buffer;
                  NEXT vol1_p IN input_buffer;

                  IF (vol1_p^.label_identifier = 'VOL') AND (vol1_p^.label_number = '1') THEN
                    rvsns_online_p^ [j].rvsn := vol1_p^.volume_identifier;
                    rvsns_online_p^ [j].unit_type := cmv$logical_unit_table^ [lun].
                          unit_interface_table^.unit_type;
                    j := j + 1;
                    {UPDATE TSL TO INDICATE A LABELLED TAPE FOR THIS LUN
                    tusl_template.rvsn := vol1_p^.volume_identifier;
                    tusl_template.detected_tape_characteristics.label_type := amc$labelled;
                    tusl_template.detected_tape_characteristics.character_set := amc$ascii;
                    tusl_template.detected_tape_characteristics.write_ring := io_status.write_ring;

                  ELSE
                    osp$translate_bytes (vol1_p, 80, vol1_p, 80, ^osv$ebcdic_to_ascii, error);

                    IF (vol1_p^.label_identifier = 'VOL') AND (vol1_p^.label_number = '1') THEN
                      rvsns_online_p^ [j].rvsn := vol1_p^.volume_identifier;
                      rvsns_online_p^ [j].unit_type := cmv$logical_unit_table^ [lun].
                            unit_interface_table^.unit_type;
                      j := j + 1;

                      {UPDATE TSL TO INDICATE A LABELLED TAPE FOR THIS LUN
                      tusl_template.rvsn := vol1_p^.volume_identifier;
                      tusl_template.detected_tape_characteristics.label_type := amc$labelled;
                      tusl_template.detected_tape_characteristics.character_set := amc$ebcdic;
                      tusl_template.detected_tape_characteristics.write_ring := io_status.write_ring;

                    ELSE
                      {UPDATE TUSL ENTRY - INDICATE UNLABELLED

                      tusl_template.rvsn := rmc$unspecified_vsn;
                      tusl_template.detected_tape_characteristics.label_type := amc$unlabelled;
                      tusl_template.detected_tape_characteristics.character_set := amc$ascii;
                      tusl_template.detected_tape_characteristics.write_ring := io_status.write_ring;

                    IFEND;
                  IFEND;
                ELSE
                  {UPDATE TUSL ENTRY - INDICATE UNLABELLED

                  tusl_template.rvsn := rmc$unspecified_vsn;
                  tusl_template.detected_tape_characteristics.label_type := amc$unlabelled;
                  tusl_template.detected_tape_characteristics.character_set := amc$ascii;
                  tusl_template.detected_tape_characteristics.write_ring := io_status.write_ring;

                IFEND;
                EXIT /read_label/;
              END /read_label/;

              iop$rewind_tape_scan (lun, io_id, status);
              iop$tape_internal_request_stat (lun, io_id, {buf_release =} TRUE, {bid_recovery =} FALSE,
                    {bid_update =} TRUE, osc$wait, io_status, status);
              tusl_template.detected_tape_characteristics.density := io_status.unit_density;

              REPEAT
                iop$write_unlock_tusl_entry ({write_entry} TRUE, i, tusl_template, local_status);
                IF NOT local_status.normal AND
                      (local_status.condition = dme$unable_to_lock_tape_table) THEN
                  pmp$wait (one_second, one_second);
                IFEND;
              UNTIL local_status.normal OR (local_status.condition <> dme$unable_to_lock_tape_table);
              tusl_entry_locked := NOT local_status.normal;
              #SPOIL (tusl_entry_locked);
              clean_up ({terminate_io_scan} TRUE, {issue_log_message} TRUE);
            ELSE

              REPEAT
                iop$write_unlock_tusl_entry ({write_entry} FALSE, i, tusl_template, local_status);
                IF NOT local_status.normal AND
                      (local_status.condition = dme$unable_to_lock_tape_table) THEN
                  pmp$wait (one_second, one_second);
                IFEND;
              UNTIL local_status.normal OR (local_status.condition <> dme$unable_to_lock_tape_table);
              tusl_entry_locked := NOT local_status.normal;
              #SPOIL (tusl_entry_locked);
              cmp$unlock_lun_entry (lun, lun_lock_released);
              lun_lock_obtained := FALSE;
            IFEND;

          FOREND /status_all_units_loop/;

          rvsns_online_p^ [j].rvsn := rmc$unspecified_vsn;
          next_scan_mode := scan_rvl;
          IF rvsns_online_p^ [LOWERBOUND (rvsns_online_p^)].rvsn <> rmc$unspecified_vsn THEN
            REPEAT
              iop$rdy_task_waiting_assignment (rvsns_online_p, status);
              IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
                pmp$wait (one_second, one_second);
              IFEND;
            UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
            IF NOT status.normal THEN
              osp$generate_log_message (logset, status, ignore_status);
            IFEND;
          IFEND;

        = scan_rvl =

          pmp$wait (one_second, one_second);
          tasks_are_waiting := FALSE;
          REPEAT
            iop$any_task_waiting_assignment (tasks_are_waiting, status);
            IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
              pmp$wait (one_second, one_second);
            IFEND;
          UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
          IF NOT status.normal THEN
            osp$generate_log_message (logset, status, ignore_status);
          IFEND;
          IF tasks_are_waiting THEN
            next_scan_mode := short_wait;
          ELSE
            next_scan_mode := indefinite_wait;
          IFEND;

        = short_wait =
          next_scan_mode := status_all_units;
          pmp$wait (iov$tape_scan_frequency * 1000, iov$tape_scan_frequency * 1000);

        = indefinite_wait =
          scanner_active := FALSE;
        ELSE
        CASEND;
      WHILEND;

      last_scan_time := #FREE_RUNNING_CLOCK (0);
      pmp$wait (0ffffffffffff(16), 0ffffffffffff(16));

    WHILEND;

  PROCEND iop$tape_scanner;

?? TITLE := 'down_tape_unit', EJECT ??

  PROCEDURE down_tape_unit
    (    lun: iot$logical_unit);

    VAR
      element_descriptor: cmt$element_descriptor,
      element_name: cmt$element_name,
      ignore_status: ost$status,
      logset: pmt$ascii_logset,
      status: ost$status;

    status.normal := TRUE;
    logset := $pmt$ascii_logset [pmc$system_log];

  /main_program/
    BEGIN

      cmp$get_element_name_via_lun (lun, element_name, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      element_descriptor.element_type := cmc$storage_device_element;
      element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
      element_descriptor.peripheral_descriptor.element_name := element_name;
      cmp$process_state_change ({tape_element=} TRUE, {clear_lock_behind=} TRUE,
            TRUE, element_descriptor, {System critical element} FALSE,
            cmc$on, cmc$down, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    END /main_program/;

    IF NOT status.normal THEN
      osp$generate_log_message (logset, status, ignore_status);
    IFEND;

  PROCEND down_tape_unit;

MODEND iom$tape_scanner;
*DECK DECK=IOM$TAPF EXPAND=TRUE
*DECK DECK=IOM$TRANSLATE_BYTE_ADDRESS EXPAND=TRUE
MODULE iom$translate_byte_address;

*copyc OSD$DEFAULT_PRAGMATS
*copyc IOT$RB_TRANSLATE_BYTE_ADDRESS
*copyc IOT$IO_FUNCTION
*copyc JMT$IJL_ORDINAL
*copyc MTP$CST_P
*copyc OST$CPU_STATE_TABLE
*copyc DMT$SYSTEM_FILE_ID
*copyc OST$HARDWARE_SUBRANGES
*copyc DMT$MS_LOGICAL_DEVICE_ADDRESS
*copyc AMT$FILE_BYTE_ADDRESS
*copyc DMP$WRITE
*copyc gfp$mtr_get_locked_fde_p
*copyc gft$locked_file_desc_entry_p
*copyc syt$monitor_status


  PROCEDURE [XDCL] iop$translate_byte_address
    (VAR request_block: iot$rb_translate_byte_address;
         cst_p: ^ost$cpu_state_table);

    VAR
      m_request_block: iot$rb_translate_byte_address,
      fde_p: gft$locked_file_desc_entry_p,
      file_byte_address: amt$file_byte_address,
      length: ost$byte_count,
      device_address: dmt$ms_logical_device_address,
      status: syt$monitor_status;


    request_block.status.normal := TRUE;

    m_request_block := request_block;

    gfp$mtr_get_locked_fde_p (m_request_block.system_file_id, cst_p^.ijle_p, fde_p);
    file_byte_address := m_request_block.file_byte_address;
    length := m_request_block.length;

    iop$translate (fde_p, file_byte_address, length, device_address, status);

    request_block.device_address := device_address;
    request_block.status := status;

  PROCEND iop$translate_byte_address;





  PROCEDURE iop$translate
   (    fde_p: gft$locked_file_desc_entry_p;
        file_byte_address: amt$file_byte_address;
        length: ost$byte_count;
    VAR device_address: dmt$ms_logical_device_address;
    VAR status: syt$monitor_status);

    VAR
      io_function: iot$io_function,
      d_status: syt$monitor_status;


    status.normal := TRUE;


{Call device management to translate the byte_address to a device_address.}

    io_function := ioc$write_page;
    dmp$write (fde_p, file_byte_address, length, io_function, device_address, d_status);
    IF d_status.normal = FALSE THEN
      status := d_status;
      RETURN;
    IFEND;



  PROCEND iop$translate;
MODEND iom$translate_byte_address;
*DECK DECK=IOM55A EXPAND=TRUE
          IDENT  DSK55A
          CIPPU
          TITLE  IOM55A
          COMMENT *SMD* LVL=03
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 CHANTYP  EQU    0           CHANNEL TYPE
                               = 0, FOR NIO 170 CHANNEL
                               = 1, FOR CIO 170 CHANNEL
 CONTYP   EQU    3           CONTROLLER TYPE
                               = 2, FOR 7154 CONTROLLER
                               = 3, FOR 7155-1 CONTROLLER
                               = 4, FOR 7155-1X CONTROLLER
                               = 5, FOR 7155-4X CONTROLLER, 170 CHANNEL
                               = 7, FOR 7155-4X CONTROLLER, 180 CHANNEL
*copyc IODDSKP
          END    DSK55A
/EOR

*DECK DECK=IOM55C7 EXPAND=TRUE
          IDENT  DSK55C7
          CIPPU
          MEMSEL 8
          TITLE  IOM55C7
          COMMENT *SMD* LVL=03
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 CHANTYP  EQU    1           CHANNEL TYPE
                               = 0, FOR NIO 170 CHANNEL
                               = 1, FOR CIO 170 CHANNEL
 CONTYP   EQU    5           CONTROLLER TYPE
                               = 2, FOR 7154 CONTROLLER
                               = 3, FOR 7155-1 CONTROLLER
                               = 4, FOR 7155-1X CONTROLLER
                               = 5, FOR 7155-4X CONTROLLER, 170 CHANNEL
                               = 7, FOR 7155-4X CONTROLLER, 180 CHANNEL
*copyc IODDSKP
          END    DSK55C7
/EOR

*DECK DECK=IOM7154 EXPAND=TRUE
          IDENT  DSK7154
          CIPPU
          TITLE  IOM7154
          COMMENT *SMD* LVL=03
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 CHANTYP  EQU    0           CHANNEL TYPE
                               = 0, FOR NIO 170 CHANNEL
                               = 1, FOR CIO 170 CHANNEL
 CONTYP   EQU    2           CONTROLLER TYPE
                               = 2, FOR 7154 CONTROLLER
                               = 3, FOR 7155-1 CONTROLLER
                               = 4, FOR 7155-1X CONTROLLER
                               = 5, FOR 7155-4X CONTROLLER, 170 CHANNEL
                               = 7, FOR 7155-4X CONTROLLER, 180 CHANNEL
*copyc IODDSKP
          END    DSK7154
/EOR

*DECK DECK=IOP$ACCESS_TUSL_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] iop$access_tusl_entry
    (    tusl_ordinal: iot$tusl_ordinal;
     VAR tusl_entry_access {i/o} : iot$tusl_entry_access;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$tusl_entry_access
*copyc iot$tusl_ordinal
*copyc ost$status
?? POP ??

*DECK DECK=IOP$ALLOCATE_IMAGE_REQUESTS EXPAND=FALSE

  PROCEDURE [XREF] iop$allocate_image_requests (number_of_requests:
    iot$number_of_requests;
        commands_per_request: iot$commands_per_request;
    VAR image_request_area: ^SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$NUMBER_OF_REQUESTS
*copyc OST$STATUS
?? POP ??
*DECK DECK=IOP$ALLOCATE_USAGE_COUNTERS EXPAND=FALSE

  PROCEDURE [XREF] iop$allocate_usage_counters (
        VAR status: ost$status);
*DECK DECK=IOP$ALLOCATE_WIRED_TAPE_TABLES EXPAND=FALSE

  PROCEDURE [XREF] iop$allocate_wired_tape_tables (
        index: iot$no_of_tape_units;
        multiple_requests_possible: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc iot$no_of_tape_units
?? POP ??
*DECK DECK=IOP$ANY_TASK_WAITING_ASSIGNMENT EXPAND=FALSE
    PROCEDURE [XREF] iop$any_task_waiting_assignment (
      VAR tasks_are_waiting: boolean;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IOP$ASSIGN_DEVICE_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] iop$assign_device_command
    (    job_name: jmt$system_supplied_name,
         element_name: ost$name;
         external_vsn: rmt$external_vsn;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc rmt$external_vsn
*copyc ost$status
?? POP ??
*DECK DECK=IOP$ASSIGN_TAPE_UNIT EXPAND=FALSE

  PROCEDURE [XREF] iop$assign_tape_unit
    (    sfid: gft$system_file_identifier;
         element_name: cmt$element_name;
         acceptable_states: cmt$element_states;
         label_type: amt$label_type;
     VAR logical_unit: iot$logical_unit;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$label_type
*copyc cmt$element_name
*copyc cmt$element_states
*copyc gft$system_file_identifier
*copyc iot$logical_unit
*copyc ost$status
?? POP ??
*DECK DECK=IOP$BACKSPACE_TAPE EXPAND=FALSE

  PROCEDURE [XREF] iop$backspace_tape (
        system_file_id: dmt$system_file_id;
        block_count: iot$tape_block_count;
        use_locate_block: boolean;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc IOT$TAPE_IO_STATUS
*copyc IOT$TAPE_BLOCK_COUNT
*copyc OST$STATUS
?? POP ??


*DECK DECK=IOP$BACKSPACE_TAPE_TO_TAPEMARK EXPAND=FALSE
  PROCEDURE [XREF] iop$backspace_tape_to_tapemark (
    system_file_id: dmt$system_file_id;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc iot$tape_io_status
*copyc OST$STATUS
?? POP ??

*DECK DECK=IOP$BUILD_PP_QUEUE_REQ_R2 EXPAND=FALSE


*DECK DECK=IOP$BUILD_UNIT_QUEUE_REQ_R2 EXPAND=FALSE


*DECK DECK=IOP$CHANGE_DISK_CHANNEL EXPAND=FALSE

  PROCEDURE [XREF] iop$change_disk_channel
    (    new_state: cmt$element_state;
         pp: 1 .. ioc$pp_count;
         channel: ost$physical_channel_number;
     VAR status: syt$monitor_status);

*copyc cmt$element_state
*copyc syt$monitor_status
*copyc iot$pp_interface_table
*copyc ost$physical_channel_number
*DECK DECK=IOP$CHANGE_DISK_CONTROLLER EXPAND=FALSE

  PROCEDURE [XREF] iop$change_disk_controller
    (    new_state: cmt$element_state;
         pp: 1 .. ioc$pp_count;
         channel: ost$physical_channel_number;
         controller: cmt$physical_equipment_number;
     VAR status: syt$monitor_status);

*copyc cmt$element_state
*copyc syt$monitor_status
*copyc iot$pp_interface_table
*copyc ost$physical_channel_number
*copyc cmt$physical_equipment_number
*DECK DECK=IOP$CHANGE_DISK_UNIT EXPAND=FALSE

  PROCEDURE [XREF] iop$change_disk_unit
     (   new_state: cmt$element_state;
         logical_unit: iot$logical_unit;
     VAR status: syt$monitor_status);

*copyc cmt$element_state
*copyc iot$logical_unit
*copyc syt$monitor_status
*DECK DECK=IOP$CHANGE_TAPE_SCAN_FREQ_113 EXPAND=FALSE

  PROCEDURE [XREF] iop$change_tape_scan_freq_113
    (    scan_frequency: integer);
*DECK DECK=IOP$CHANGE_TAPE_SCAN_FREQ_23D EXPAND=FALSE

  PROCEDURE [XREF] iop$change_tape_scan_freq_23d
    (    scan_frequency: integer;
     VAR status: ost$status);

*copyc ost$status
*DECK DECK=IOP$CHECK_ACTIVE_PPS EXPAND=FALSE
*DECK DECK=IOP$CHECK_IDLE_PPS EXPAND=FALSE

  PROCEDURE [XREF] iop$check_idle_pps;
*DECK DECK=IOP$CLEAR_RESPONSE_PTR EXPAND=FALSE


  PROCEDURE [XREF] iop$clear_response_ptr (job_io_completion_queue_index:
    cmt$io_completion_queue_index;
    VAR status: ost$status);


*copyc ost$status
*copyc iot$io_completion_table
*DECK DECK=IOP$CLIENT_CANCEL_REQUEST EXPAND=FALSE
  PROCEDURE [XREF] iop$client_cancel_request
    (    server_name: ost$name;
         sfid: gft$system_file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc ost$name
*copyc ost$status
*copyc rme$robotic_interface_errors
?? POP ??
*DECK DECK=IOP$CLIENT_DELETE_REQUEST EXPAND=FALSE
  PROCEDURE [XREF] iop$client_delete_request
    (    server_name: ost$name;
         request_id: rmt$rbt_request_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc rme$robotic_interface_errors
*copyc rmt$rbt_request_id
?? POP ??
*DECK DECK=IOP$CLIENT_GET_RESPONSE EXPAND=FALSE

  PROCEDURE [XREF] iop$client_get_response
    (    server_name: ost$name;
         request_id: rmt$rbt_request_id;
     VAR server_response: iot$formatted_server_response;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc rme$robotic_interface_errors
*copyc iot$formatted_server_response
*copyc rmt$rbt_request_id
?? POP ??
*DECK DECK=IOP$CLIENT_PUT_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] iop$client_put_request
    (    server_name: ost$name;
         sfid: gft$system_file_identifier;
         client_request: rmt$rbt_request;
     VAR request_id: rmt$rbt_request_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc ost$name
*copyc ost$status
*copyc rme$robotic_interface_errors
*copyc rmt$rbt_request
*copyc rmt$rbt_request_id
?? POP ??
*DECK DECK=IOP$CREATE_APPLICATION_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] iop$create_application_queue(
    configured_element_list_p: ^ARRAY [1..*] OF cmt$element_name;
    queue_attributes: ARRAY [1..*] OF rmt$queue_attribute_item;
    VAR queue_id: rmt$queue_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc ost$status
*copyc rmt$queue_attribute_item
*copyc rmt$queue_id
?? POP ??
*DECK DECK=IOP$CREATE_RVL_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] iop$create_rvl_entry
    (    sfid: dmt$system_file_id;
         density: rmt$density;
         global_file_name: dmt$global_file_name;
         path_handle: fmt$path_handle;
         requested_volume_attributes: iot$requested_volume_attributes;
         volume_list: rmt$volume_list;
         write_ring: rmt$write_ring;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$global_file_name
*copyc dmt$system_file_id
*copyc fmt$path_handle
*copyc iot$requested_volume_attributes
*copyc ost$status
*copyc rmt$density
*copyc rmt$volume_list
*copyc rmt$write_ring
?? POP ??
*DECK DECK=IOP$DEFINE_ROBOTIC_SERVER EXPAND=FALSE

  PROCEDURE [XREF] iop$define_robotic_server
    (    server_name: ost$name;
         managed_elements: array [1 .. * ] of cmt$element_name;
         server_attributes: iot$robotic_server_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc iot$robotic_server_attributes
*copyc ost$name
*copyc ost$status
*copyc rme$robotic_interface_errors
?? POP ??
*DECK DECK=IOP$DELETE_APPLICATION_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] iop$delete_application_queue(
    queue_id: rmt$queue_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$queue_id
?? POP ??
*DECK DECK=IOP$DELETE_MEDIA_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] iop$delete_media_request(
    request: iot$general_request;
    gtid: ost$global_task_id;
    evsn: rmt$external_vsn;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$general_request
*copyc ost$global_task_id
*copyc ost$status
*copyc rmt$external_vsn
?? POP ??
*DECK DECK=IOP$DELETE_RVL_ENTRIES_VIA_SSN EXPAND=FALSE

  PROCEDURE [XREF] iop$delete_rvl_entries_via_ssn (
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IOP$DELETE_RVL_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] iop$delete_rvl_entry (
    sfid: dmt$system_file_id;
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??
*DECK DECK=IOP$DESTROY_PP_QUEUE_REQ_R2 EXPAND=FALSE


*DECK DECK=IOP$DESTROY_UNIT_QUEUE_REQ_R2 EXPAND=FALSE


*DECK DECK=IOP$DETERMINE_DENSITY_SUPPORT EXPAND=FALSE

  PROCEDURE [INLINE] iop$determine_density_support (
        unit_type: iot$unit_type;
        requested_density: rmt$density;
    VAR density_supported: boolean);

    density_supported := FALSE;

    CASE requested_density OF

    = rmc$800 =

      IF (unit_type = ioc$dt_mt679_2) OR (unit_type = ioc$dt_mt679_3) OR
            (unit_type = ioc$dt_mt679_4) THEN
        density_supported := TRUE;
      IFEND;

    = rmc$1600 =

      IF (unit_type <> ioc$dt_mt5682_1x) THEN
        density_supported := TRUE;
      IFEND;

    = rmc$6250 =

      IF NOT ((unit_type = ioc$dt_mt679_2) OR (unit_type = ioc$dt_mt679_3) OR
            (unit_type = ioc$dt_mt679_4) OR (unit_type = ioc$dt_mt5682_1x)) THEN
        density_supported := TRUE;
      IFEND;

      = rmc$38000 =

      IF (unit_type = ioc$dt_mt5682_1x) THEN
        density_supported := TRUE;
      IFEND;

    ELSE
    CASEND;

  PROCEND iop$determine_density_support;

?? PUSH (LISTEXT := ON) ??
*copyc iot$unit_type
*copyc rmt$density
?? POP ??
*DECK DECK=IOP$DETERMINE_VSN_QUEUE_STATUS EXPAND=FALSE
*DECK DECK=IOP$DEVICE_IO EXPAND=FALSE

  PROCEDURE [XREF] iop$device_io (VAR request_block: iot$rb_device_io);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$RB_DEVICE_IO
?? POP ??
*DECK DECK=IOP$DISK_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] iop$disk_request (request_info: iot$request_info;
    buffer_descriptor: mmt$buffer_descriptor;
    length: ost$byte_count;
    device_address: dmt$ms_logical_device_address;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$DISK_REQUEST
*copyc DMT$MS_LOGICAL_DEVICE_ADDRESS
*copyc OSD$VIRTUAL_ADDRESS
*copyc MMT$BUFFER_DESCRIPTOR
*copyc syt$monitor_status
?? POP ??
*DECK DECK=IOP$DOWN_DISK_CHANNEL EXPAND=FALSE

  PROCEDURE [XREF] iop$down_disk_channel
    (    pp: iot$pp_number;
         channel: cmt$physical_channel;
     VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$physical_channel
*copyc iot$pp_number
*copyc syt$monitor_status
?? POP ??
*DECK DECK=IOP$DOWN_DISK_CONTROLLER EXPAND=FALSE

  PROCEDURE [XREF] iop$down_disk_controller
    (    pp: iot$pp_number;
         channel: cmt$physical_channel;
         equipment: cmt$physical_equipment_number;
     VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$physical_channel
*copyc cmt$physical_equipment_number
*copyc iot$pp_number
*copyc syt$monitor_status
?? POP ??
*DECK DECK=IOP$DOWN_DISK_UNIT EXPAND=FALSE
  PROCEDURE [XREF] iop$down_disk_unit
    (    pp: iot$pp_number;
         channel: cmt$physical_channel;
         equipment: cmt$physical_equipment_number;
         unit: cmt$physical_unit_number;
         logical_unit: iot$logical_unit;
     VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$physical_channel
*copyc cmt$physical_equipment_number
*copyc cmt$physical_unit_number
*copyc iot$logical_unit
*copyc iot$pp_number
*copyc syt$monitor_status
?? POP ??
*DECK DECK=IOP$ENABLE_ALL_DISK_UNITS EXPAND=FALSE


  PROCEDURE [XREF] iop$enable_all_disk_units
    (VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc SYT$MONITOR_REQUEST_CODE
?? POP ??
*DECK DECK=IOP$ENSURE_TAPE_IO_COMPLETE EXPAND=FALSE

  PROCEDURE [XREF] iop$ensure_tape_io_complete (
        job_name: jmt$system_supplied_name);

*DECK DECK=IOP$ERASE_TAPE EXPAND=FALSE

  PROCEDURE [XREF] iop$erase_tape (system_file_id: dmt$system_file_id;
        block_length: amt$max_block_length;
        number_of_erases: integer;
        VAR io_status: iot$tape_io_status;
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc AMT$MAX_BLOCK_LENGTH
*copyc IOT$TAPE_IO_STATUS
*copyc OST$STATUS
?? POP ??


*DECK DECK=IOP$ESTABLISH_STATISTICS EXPAND=FALSE
 PROCEDURE [XREF] iop$establish_statistics (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IOP$EXTEND_VOLUME_LIST_IN_RVL EXPAND=FALSE

  PROCEDURE [XREF] iop$extend_volume_list_in_rvl (
    sfid: dmt$system_file_id;
    evsn: rmt$external_vsn;
    rvsn: rmt$recorded_vsn;
    requested_volume_attributes: iot$requested_volume_attributes,
    vsn_number: integer;
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc iot$requested_volume_attributes
*copyc ost$status
*copyc ost$name
*copyc rmt$external_vsn
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=IOP$FETCH_DEBUG_OPTION_VALUE EXPAND=FALSE
*DECK DECK=IOP$FETCH_TAPE_CAPABILITIES EXPAND=FALSE

  PROCEDURE [XREF] iop$fetch_tape_capabilities (system_file_id: dmt$system_file_id;
        VAR maximum_block_length: amt$max_block_length;
        VAR max_blocks_per_physical_call: iot$tape_block_count;
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc AMT$MAX_BLOCK_LENGTH
*copyc IOT$TAPE_BLOCK_COUNT
*copyc OST$STATUS
?? POP ??
*DECK DECK=IOP$FETCH_TAPE_SCAN_FREQUENCY EXPAND=FALSE

  PROCEDURE [XREF] iop$fetch_tape_scan_frequency
    (VAR scan_frequency: integer;
     VAR status: ost$status);

*copyc ost$status
*DECK DECK=IOP$FIND_EMPTY_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] iop$find_empty_request (VAR io_request_p: ^iot$io_request;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$IO_REQUEST
*copyc SYT$MONITOR_REQUEST_CODE
?? POP ??
*DECK DECK=IOP$FORSPACE_TAPE EXPAND=FALSE

  PROCEDURE [XREF] iop$forspace_tape ALIAS 'iomtsf' (
        system_file_id: dmt$system_file_id;
        block_count: iot$tape_block_count;
        VAR io_id: iot$io_id;
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc IOT$IO_ID
*copyc IOT$TAPE_BLOCK_COUNT
*copyc OST$STATUS
?? POP ??


*DECK DECK=IOP$FORSPACE_TAPE_TO_TAPEMARK EXPAND=FALSE
  PROCEDURE [XREF] iop$forspace_tape_to_tapemark (
    system_file_id: dmt$system_file_id;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc iot$tape_io_status
*copyc OST$STATUS
?? POP ??

*DECK DECK=IOP$FREE_BOOT_TAPE_TABLES EXPAND=FALSE

  PROCEDURE [XREF] iop$free_boot_tape_tables;
*DECK DECK=IOP$FREE_TAPE_TABLES EXPAND=FALSE

  PROCEDURE [XREF] iop$free_tape_tables;
*DECK DECK=IOP$FREE_WIRED_TAPE_TABLES EXPAND=FALSE

  PROCEDURE [XREF] iop$free_wired_tape_tables (
        index: iot$no_of_tape_units);

?? PUSH (LISTEXT := ON) ??
*copyc iot$no_of_tape_units
?? POP ??
*DECK DECK=IOP$GET_AQL_MRL_STRUCTURES EXPAND=FALSE

  PROCEDURE [XREF] iop$get_aql_mrl_structures(
    VAR aql_list_p: ^ARRAY [1..*] OF iot$application_queue_entry;
    VAR all_aql_entries_found: BOOLEAN;
    VAR aql_entries_returned: INTEGER;
    VAR mrl_list_p: ^ARRAY [1..*] OF iot$media_request_entry;
    VAR all_mrl_entries_found: BOOLEAN;
    VAR mrl_entries_returned: INTEGER);

?? PUSH (LISTEXT := ON) ??
*copyc iot$application_queue_entry
*copyc iot$media_request_entry
?? POP ??
*DECK DECK=IOP$GET_DENSITY_STATES EXPAND=FALSE

  PROCEDURE [XREF] iop$get_density_states
    (VAR density_states: array [rmc$800 .. rmc$38000] of iot$density_states;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$density_states
*copyc ost$status
*copyc rme$robotic_interface_errors
*copyc rmt$density
?? POP ??

*DECK DECK=IOP$GET_IN_OUT_PTRS EXPAND=TRUE
PROCEDURE [XREF] iop$get_in_out_ptrs  (pp: iot$pp_number;
         VAR inn: iot$response_buffer_offset;
         VAR out: iot$response_buffer_offset);


*copyc iot$pp_interface_table
*DECK DECK=IOP$GET_MEDIA_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] iop$get_media_request(
    queue_id: rmt$queue_id;
    wait: BOOLEAN;
    VAR found_request: BOOLEAN;
    VAR media_request: rmt$media_request_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$media_request_descriptor
*copyc rmt$queue_id
?? POP ??
*DECK DECK=IOP$GET_OPERATOR_QUEUE_MOUNTS EXPAND=FALSE

  PROCEDURE [XREF] iop$get_operator_queue_mounts(
    VAR mrl_list_p: ^ARRAY [1..*] OF iot$media_request_entry;
    VAR all_mrl_entries_found: BOOLEAN;
    VAR mrl_entries_returned: INTEGER);

?? PUSH (LISTEXT := ON) ??
*copyc iot$media_request_entry
?? POP ??
*DECK DECK=IOP$GET_POSITION_OF_TAPE_FILE EXPAND=FALSE

  PROCEDURE [XREF] iop$get_position_of_tape_file (
        lun: iot$logical_unit;
        VAR position: iot$tape_position;
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc iot$tape_position
*copyc ost$status
?? POP ??
*DECK DECK=IOP$GET_SELECTED_ELEMENT EXPAND=FALSE

  PROCEDURE [XREF] iop$get_selected_element
    (    sfid: gft$system_file_identifier;
         external_vsn: rmt$external_vsn;
         recorded_vsn: rmt$recorded_vsn;
         density: rmt$density;
     VAR element_name: cmt$element_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc gft$system_file_identifier
*copyc rmt$density
*copyc rmt$external_vsn
*copyc rmt$recorded_vsn
*copyc ost$status
?? POP ??
*DECK DECK=IOP$GET_SERVER_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] iop$get_server_entry
    (    server_index: iot$robotic_server_index;
     VAR server_entry: iot$robotic_server_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$robotic_server_entry
*copyc iot$robotic_server_index
*copyc ost$name
*copyc ost$status
*copyc rme$robotic_interface_errors
?? POP ??

*DECK DECK=IOP$GET_TAPE_MOUNT_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] iop$get_tape_mount_information (
    rvl_info_array_p: ^ARRAY [ 1..* ] OF iot$rvl_entry_information;
    VAR all_tape_mounts_found: boolean;
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc iot$rvl_entry_information
*copyc ost$status
?? POP ??
*DECK DECK=IOP$GET_TAPE_USAGE_DATA EXPAND=FALSE

  PROCEDURE [XREF] iop$get_tape_usage_data (
        system_file_id: dmt$system_file_id;
    VAR block_count: ost$non_negative_integers;
    VAR tapemark_count: ost$non_negative_integers;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc osd$integer_limits
*copyc ost$status
?? POP ??

*DECK DECK=IOP$IDLE EXPAND=FALSE
*DECK DECK=IOP$IDLE_ALL_PATHS EXPAND=FALSE

  PROCEDURE [XREF] iop$idle_all_paths
    (    wait: boolean;
     VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc syt$monitor_status
?? POP ??
*DECK DECK=IOP$IDLE_PATH EXPAND=FALSE

  PROCEDURE [XREF] iop$idle_path
    (    pp: iot$pp_number;
     VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
*copyc syt$monitor_status
?? POP ??
*DECK DECK=IOP$IDLE_RESUME EXPAND=FALSE

  PROCEDURE [XREF] iop$idle_resume
    (    pp: iot$pp_number;
         action: iot$idle_resume_action;
     VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$idle_resume_action
*copyc iot$pp_number
*copyc syt$monitor_status
?? POP ??
*DECK DECK=IOP$INITIALIZE_SECTORS EXPAND=FALSE

  PROCEDURE [XREF] iop$initialize_sectors (logical_unit: iot$logical_unit;
        cylinders: array [ * ] OF iot$cylinders_to_initialize;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc iot$logical_unit
*copyc iot$cylinders_to_initialize
?? POP ??
*DECK DECK=IOP$INITIALIZE_TAPE_UD EXPAND=FALSE

  PROCEDURE [XREF] iop$initialize_tape_ud (
        tape_initial: dmt$tape_initialization_record;
        multiple_requests_possible: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$tape_initialization_record
*copyc ost$status
?? POP ??
*DECK DECK=IOP$ISSUE_CCC_CART_LOG_ENTRY EXPAND=FALSE

 PROCEDURE [XREF] iop$issue_ccc_cart_log_entry (
        p_tape_failure_data: ^iot$ccc_cart_tape_failure_data;
        logical_unit: iot$logical_unit;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc ost$status
*copyc iot$tape_failure_statistic_data
?? POP ??

*DECK DECK=IOP$ISSUE_IPI_LOG_ENTRY EXPAND=FALSE

 PROCEDURE [XREF] iop$issue_ipi_log_entry (
        p_tape_failure_data: ^iot$ipi_tape_failure_data;
        logical_unit: iot$logical_unit;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc ost$status
*copyc iot$tape_failure_statistic_data
?? POP ??

*DECK DECK=IOP$JOB_TAPE_MOUNTS_ACTIVE EXPAND=FALSE

  PROCEDURE [XREF] iop$job_tape_mounts_active
    (    job_name: jmt$system_supplied_name;
     VAR job_tape_mounts_active: boolean;
     VAR status: ost$status);

*copyc jmt$system_supplied_name
*copyc ost$status
*DECK DECK=IOP$LOCATE_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] iop$locate_block (
        logical_unit: iot$logical_unit;
        block_id: iot$cartridge_tape_bid;
        bid_recovery: boolean;
        tape_mark_reset: integer;
        locate_block_option: iot$locate_block_option;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc iot$tape_io_status
*copyc iot$tape_block_id_area
*copyc ost$status
?? POP ??
*DECK DECK=IOP$LOG_DISK_DATA EXPAND=FALSE
 PROCEDURE [XREF] iop$log_disk_data (datap: ^SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IOP$LOG_TAPE_DATA EXPAND=FALSE

 PROCEDURE [XREF] iop$log_tape_data (datap: ^SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=IOP$LOG_USAGE_STATISTICS EXPAND=FALSE

  PROCEDURE [XREF] iop$log_usage_statistics;

*DECK DECK=IOP$MASS_STORAGE_IO EXPAND=FALSE

  PROCEDURE [XREF] iop$mass_storage_io (pva: ^cell;
    length: ost$byte_count;
    io_function: iot$io_function;
    device_address: dmt$ms_logical_device_address;
    wait_completion: boolean;
    VAR p_completion_status: ^iot$completion_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc OST$HARDWARE_SUBRANGES
*copyc IOT$IO_FUNCTION
*copyc IOT$COMPLETION_STATUS
*copyc DMT$MS_LOGICAL_DEVICE_ADDRESS
?? POP ??
*DECK DECK=IOP$MFH_SUBSYSTEM_IO_COMPLETION EXPAND=FALSE

      PROCEDURE [XREF] iop$mfh_subsystem_io_completion (flag_id: ost$system_flag);

??PUSH (LISTEXT := ON)??
*copyc ost$system_flag
??POP??
*DECK DECK=IOP$MTR_SET_STATUS_ABNORMAL EXPAND=FALSE

      PROCEDURE [XREF] iop$mtr_set_status_abnormal (
                 condition: ost$status_condition;
                 text: string (*);
             VAR status: syt$monitor_status);

??PUSH (LISTEXT:= ON)??
*copyc ost$status
*copyc syt$monitor_status
??POP??
*DECK DECK=IOP$PAGER_IO EXPAND=FALSE

  PROCEDURE [XREF] iop$pager_io (
    fde_p: gft$locked_file_desc_entry_p;
    chapter_offset: ost$segment_offset;
    buffer_descriptor: mmt$buffer_descriptor;
    length: ost$byte_count;
    io_function: iot$io_function;
    io_identifier: mmt$io_identifier;
    VAR status: syt$monitor_status);
?? PUSH (LISTEXT := ON) ??
*copyc gft$locked_file_desc_entry_p
*copyc IOT$IO_FUNCTION
*copyc OST$HARDWARE_SUBRANGES
*copyc IOT$IO_FUNCTION
*copyc SYT$MONITOR_REQUEST_CODE
*copyc OSD$VIRTUAL_ADDRESS
*copyc MMT$BUFFER_DESCRIPTOR
*copyc MMT$IO_IDENTIFIER
?? POP ??
*DECK DECK=IOP$PROCESS_DISK_RESPONSE EXPAND=FALSE

  PROCEDURE [XREF] iop$process_disk_response (pp_response_p: ^iot$pp_response;
        detailed_status_p: ^iot$detailed_status;
        pp: 1 .. ioc$pp_count;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$PP_RESPONSE
*copyc IOT$PP_INTERFACE_TABLE
*copyc syt$monitor_status
?? POP ??
*DECK DECK=IOP$PROCESS_IDLE_RESPONSE EXPAND=FALSE

  PROCEDURE [XREF] iop$process_idle_response (pp_response_p: ^iot$pp_response;
        detailed_status_p: ^iot$detailed_status;
        pp: 1 .. ioc$pp_count;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$PP_RESPONSE
*copyc IOT$PP_INTERFACE_TABLE
*copyc syt$monitor_status
?? POP ??
*DECK DECK=IOP$PROCESS_IO_COMPLETIONS EXPAND=FALSE

  PROCEDURE [XREF] iop$process_io_completions;
*DECK DECK=IOP$PUT_MEDIA_RESPONSE EXPAND=FALSE

  PROCEDURE [XREF] iop$put_media_response(
    queue_id: rmt$queue_id;
    response: rmt$media_response_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$media_response_descriptor
*copyc rmt$queue_id
?? POP ??
*DECK DECK=IOP$QUERY_MEDIA_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] iop$query_media_request(
    request: iot$general_request;
    gtid: ost$global_task_id;
    evsn: rmt$external_vsn;
    VAR request_results: iot$media_request_results;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$general_request
*copyc iot$media_request_results
*copyc ost$global_task_id
*copyc ost$status
*copyc rmt$external_vsn
?? POP ??
*DECK DECK=IOP$QUEUE_IMAGE_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] iop$queue_image_request (system_file_id: dmt$system_file_id;
        file_byte_address: amt$file_byte_address;
        length: ost$byte_count;
        image_request_area: ^SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc AMT$FILE_BYTE_ADDRESS
*copyc OST$HARDWARE_SUBRANGES
*copyc OST$STATUS
?? POP ??
*DECK DECK=IOP$QUEUE_PP_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] iop$queue_pp_request (ppit_p: ^iot$pp_interface_table;
        request_p: ^iot$io_request;
    VAR status: syt$monitor_status);
?? PUSH (LISTEXT := ON) ??
*copyc IOT$PP_INTERFACE_TABLE
*copyc IOT$IO_REQUEST
*copyc SYT$MONITOR_REQUEST_CODE
?? POP ??
*DECK DECK=IOP$QUEUE_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] iop$queue_request (request_info: iot$request_info;
    buffer_descriptor: mmt$buffer_descriptor;
    length: ost$byte_count;
    logical_unit: iot$logical_unit;
    cylinder: iot$cylinder;
    track: iot$track;
    sector: iot$sector;
    mau_count: 0 .. 03ff(16);
    device_address: dmt$ms_logical_device_address;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$DISK_REQUEST
*copyc IOT$LOGICAL_UNIT
*copyc IOT$CYLINDER
*copyc syt$monitor_status
*copyc OSD$VIRTUAL_ADDRESS
*copyc MMT$BUFFER_DESCRIPTOR
*copyc DMT$MS_LOGICAL_DEVICE_ADDRESS
?? POP ??
*DECK DECK=IOP$QUEUE_UNIT_REQUEST_R1 EXPAND=FALSE

     PROCEDURE [XREF] iop$queue_unit_request_r1 (
                request_id: cmt$subsystem_io_request_id;
                queue_control: cmt$unit_queuing_options;
                recovery_options: iot$request_recovery;
                ready_task_upon_io_completion: boolean;
            VAR status: ost$status);

??PUSH (LISTEXT:=ON)??
*copyc cmt$subsystem_io_request_id
*copyc cmt$unit_queuing_options
*copyc iot$request_recovery
*copyc ost$status
??POP??
*DECK DECK=IOP$QUEUE_VOLUME_ASSIGNMENT EXPAND=FALSE
  PROCEDURE [XREF] iop$queue_volume_assignment
    (    sfid: dmt$system_file_id;
         label_type: amt$label_type;
         requested_density: rmt$density;
         requested_evsn: rmt$external_vsn;
         requested_rvsn: rmt$recorded_vsn;
         requested_volume_attributes: iot$requested_volume_attributes;
     VAR first_in_queue: boolean;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc amt$label_type
*copyc dmt$system_file_id
*copyc iot$requested_volume_attributes
*copyc ost$name
*copyc ost$status
*copyc rmt$density
*copyc rmt$external_vsn
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=IOP$RDY_TASK_WAITING_ASSIGNMENT EXPAND=FALSE
    PROCEDURE [XREF] iop$rdy_task_waiting_assignment (
      VAR new_rvsns_online_p: iot$new_vsns_online;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$new_vsns_online
*copyc ost$status
?? POP ??
*DECK DECK=IOP$READY_WAITING_TAPE_TASKS EXPAND=FALSE

  PROCEDURE [XREF] iop$ready_waiting_tape_tasks
    (    unit_type: iot$unit_type);

?? PUSH (LISTEXT := ON) ??
*copyc iot$unit_type
?? POP ??
*DECK DECK=IOP$READ_LOCK_TUSL_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] iop$read_lock_tusl_entry
    (    tusl_ordinal: iot$tusl_ordinal;
     VAR tape_unit_status_entry: iot$tape_unit_status_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$tape_unit_status_entry
*copyc iot$tusl_ordinal
*copyc ost$status
?? POP ??

*DECK DECK=IOP$READ_TAPE EXPAND=FALSE

  PROCEDURE [XREF] iop$read_tape ALIAS 'iomtrd' (
        system_file_id: dmt$system_file_id;
        inhibit_error_recovery: boolean;
        max_byte_count: iot$tape_block_length;
        block_description: ^iot$read_tape_description;
        no_of_blocks_to_read: iot$tape_block_count;
        VAR io_id: iot$io_id;
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$TAPE_BLOCK_COUNT
*copyc IOT$READ_TAPE_DESCRIPTION
*copyc DMT$SYSTEM_FILE_ID
*copyc IOT$IO_ID
?? POP ??

*DECK DECK=IOP$READ_TAPE_SCAN EXPAND=FALSE


  PROCEDURE [XREF] iop$read_tape_scan (
        logical_unit_number: iot$logical_unit;
        inhibit_error_recovery: boolean;
        max_byte_count: iot$tape_block_length;
        block_description: ^iot$read_tape_description;
        no_of_blocks_to_read: iot$tape_block_count;
        VAR io_id: iot$io_id;
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$TAPE_BLOCK_COUNT
*copyc IOT$READ_TAPE_DESCRIPTION
*copyc IOT$LOGICAL_UNIT
*copyc IOT$IO_ID
?? POP ??

*DECK DECK=IOP$REASSIGN_DEVICE_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] iop$reassign_device_command (
    element_name: ost$name;
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=IOP$RECORD_ROBOTIC_ASSIGNMENT EXPAND=FALSE
  PROCEDURE [XREF] iop$record_robotic_assignment
    (    sfid: gft$system_file_identifier;
         assigned_element_name: cmt$element_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$label_type
*copyc amt$label_type
*copyc cmt$element_name
*copyc gft$system_file_identifier
*copyc ost$name
*copyc ost$status
*copyc rmt$external_vsn
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=IOP$RECOVERY_REL_ASSIGN_IN_RVL EXPAND=FALSE

  PROCEDURE [XREF] iop$recovery_rel_assign_in_rvl (
    sfid: dmt$system_file_id;
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??
*DECK DECK=IOP$RELEASE_ASSIGNMENT_IN_RVL EXPAND=FALSE

  PROCEDURE [XREF] iop$release_assignment_in_rvl (
    sfid: dmt$system_file_id;
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??
*DECK DECK=IOP$RELEASE_TAPE_UNIT EXPAND=FALSE

  PROCEDURE [XREF] iop$release_tape_unit
    (    sfid: gft$system_file_identifier;
         logical_unit: iot$logical_unit;
         delete_request_from_vsn_queue: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc gft$system_file_identifier
*copyc iot$logical_unit
*copyc ost$status
?? POP ??
*DECK DECK=IOP$RELOAD_HUNG_DISK_PP EXPAND=FALSE

  PROCEDURE [XREF] iop$reload_hung_disk_pp (
        hung_pp: iot$pp_number);

?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
?? POP ??
*DECK DECK=IOP$REMOVE_ROBOTIC_SERVER EXPAND=FALSE

  PROCEDURE [XREF] iop$remove_robotic_server
    (    server_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc rme$robotic_interface_errors
?? POP ??
*DECK DECK=IOP$REQUEST_ASSIGNMENT_IN_RVL EXPAND=FALSE

  PROCEDURE [XREF] iop$request_assignment_in_rvl
    (    sfid: dmt$system_file_id;
         requested_density: rmt$density;
         requested_evsn: rmt$external_vsn;
         requested_rvsn: rmt$recorded_vsn;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc rmt$density
*copyc rmt$external_vsn
*copyc rmt$recorded_vsn
*copyc ost$status
?? POP ??
*DECK DECK=IOP$RESUME EXPAND=FALSE
*DECK DECK=IOP$RESUME_ALL_PATHS EXPAND=FALSE

  PROCEDURE [XREF] iop$resume_all_paths
    (VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc syt$monitor_status
?? POP ??
*DECK DECK=IOP$RETURN_WIRED_REQUEST EXPAND=FALSE

 PROCEDURE [XREF] iop$return_wired_request (job_io_completion_queue_index:
  cmt$io_completion_queue_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$io_completion_queue_index
?? POP ??
*DECK DECK=IOP$REWIND_TAPE EXPAND=FALSE

  PROCEDURE [XREF] iop$rewind_tape ALIAS 'iomtrew' (
        system_file_id: dmt$system_file_id;
        VAR io_id: iot$io_id;
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc IOT$IO_ID
*copyc OST$STATUS
?? POP ??


*DECK DECK=IOP$REWIND_TAPE_SCAN EXPAND=FALSE


  PROCEDURE [XREF] iop$rewind_tape_scan (
        logical_unit_number: iot$logical_unit;
        VAR io_id: iot$io_id;
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
*copyc IOT$IO_ID
*copyc OST$STATUS
?? POP ??


*DECK DECK=IOP$SELECT_BEST_ELEMENT EXPAND=FALSE

  PROCEDURE [XREF] iop$select_best_element
    (    preferred_elements: ^array [1 .. * ] of cmt$element_name;
         remaining_elements: ^array [1 .. * ] of cmt$element_name;
     VAR selected_element: cmt$element_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc ost$status
*copyc rme$robotic_interface_errors
?? POP ??
*DECK DECK=IOP$SERVER_GET_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] iop$server_get_request
    (    server_name: ost$name;
         wait: boolean;
     VAR client_request: rmt$rbt_request;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc rme$robotic_interface_errors
*copyc rmt$rbt_request
?? POP ??
*DECK DECK=IOP$SERVER_PUT_RESPONSE EXPAND=FALSE

  PROCEDURE [XREF] iop$server_put_response
    (    server_name: ost$name;
         server_response: iot$formatted_server_response;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc rme$robotic_interface_errors
*copyc iot$formatted_server_response
?? POP ??
*DECK DECK=IOP$SET_ASSIGNMENT_IN_TUSL EXPAND=FALSE

  PROCEDURE [XREF] iop$set_assignment_in_tusl (
    tusl_entry_ord: iot$tusl_ordinal;
    sfid: dmt$system_file_id;
    ssn: jmt$system_supplied_name;
    external_vsn: rmt$external_vsn;
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc jmt$system_supplied_name
*copyc iot$tusl_ordinal
*copyc rmt$external_vsn
*copyc ost$status
?? POP ??

*DECK DECK=IOP$SET_AUTO_TAPE_ASSIGNMENT EXPAND=FALSE

  PROCEDURE [XREF] iop$set_auto_tape_assignment (
    sfid: dmt$system_file_id;
    VAR set_assignment_results: iot$set_assignment_results;
    VAR assigned_element_name: ost$name;
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc iot$set_assignment_results
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=IOP$SET_MANUAL_TAPE_ASSIGNMENT EXPAND=FALSE

  PROCEDURE [XREF] iop$set_manual_tape_assignment (
    sfid: dmt$system_file_id;
    VAR set_assignment_results: iot$set_assignment_results;
    VAR assigned_element_name: ost$name;
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc iot$set_assignment_results
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=IOP$SET_QUEUE_LOCKWORD EXPAND=TRUE

*copyc ioh$set_queue_lockword

 PROCEDURE [INLINE] iop$set_queue_lockword (VAR queue_lockword: iot$lockword;
        initial_value: iot$lockword;
        final_value: iot$lockword;
    VAR actual_value: iot$lockword;
    VAR lockword_set: boolean);

?? PUSH (LISTEXT := ON) ??

*copyc iot$lockword
*copyc ost$signature_lock

    VAR
      result: 0 .. 2;

    lockword_set := FALSE;

    REPEAT
      #compare_swap (queue_lockword, initial_value, final_value, actual_value,
            result);
    UNTIL result <> osc$cs_variable_locked;

    IF result = osc$cs_successful THEN
      actual_value := final_value;
      lockword_set := TRUE;
    IFEND;

  PROCEND iop$set_queue_lockword;
?? POP ??
*DECK DECK=IOP$SET_SFID_IN_RVL EXPAND=FALSE

  PROCEDURE [XREF] iop$set_sfid_in_rvl (
    sfid: dmt$system_file_id;
    path_handle_name: fst$path_handle_name;
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc fst$path_handle_name
*copyc ost$status
?? POP ??
*DECK DECK=IOP$SET_STATUS_ABNORMAL EXPAND=FALSE

      PROCEDURE [XREF] iop$set_status_abnormal (
             condition: ost$status_condition;
             text: string (* <= osc$max_string_size);
         VAR status: ost$status);

??PUSH (LISTEXT:=ON)??
*copyc ost$status
??POP??
*DECK DECK=IOP$SET_SUBSYSTEM_IO_STATUS EXPAND=FALSE

      PROCEDURE [XREF] cmp$set_subsystem_io_status (
             io_status_p: ^iot$subsystem_io_comp_status;
             new_subsystem_io_status: iot$subsys_io_response_status;
         VAR new_subsystem_io_status_set: boolean);

??PUSH (LISTEXT := ON)??
*copyc iot$os_subsystem_response
??POP??
*DECK DECK=IOP$SSIOT_RECOVERY_PROCESSING EXPAND=FALSE

         PROCEDURE [XREF] cmp$ssiot_recovery_processing (
                            VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=IOP$STORE_DEBUG_OPTION_VALUE EXPAND=FALSE
*DECK DECK=IOP$SUBMIT_MEDIA_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] iop$submit_media_request(
    request: iot$media_request;
    gtid: ost$global_task_id;
    evsn: rmt$external_vsn,
    ghosted_request: BOOLEAN;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$media_request
*copyc ost$global_task_id
*copyc ost$status
*copyc rmt$external_vsn
?? POP ??
*DECK DECK=IOP$SUBSYSTEM_QUEUE_REQUEST EXPAND=FALSE

      PROCEDURE [XREF] iop$subsystem_queue_request (
                      VAR request_block: iot$monitor_request_block);

??PUSH (LISTEXT:=ON) ??
*copyc iot$monitor_request_block
??POP??
*DECK DECK=IOP$SUBSYS_PROCESS_PP_RESPONSE EXPAND=FALSE

      PROCEDURE [XREF] iop$subsys_process_pp_response (
                          pp_response_header_p: ^iot$pp_response;
                          detailed_status_p: ^iot$detailed_status;
                          pp_number: 1 .. ioc$pp_count;
                      VAR monitor_status: syt$monitor_status);

?? PUSH (LISTEXT:= ON) ??
*copyc iot$pp_response
*copyc iot$pp_interface_table
*copyc syt$monitor_status
?? POP ??
*DECK DECK=IOP$TAPE_CLEAR_ACTIVATE_STATS EXPAND=FALSE
PROCEDURE [XREF] iop$tape_clear_activate_stats (
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=IOP$TAPE_ENABLE_READY_TASK EXPAND=FALSE

  PROCEDURE [XREF] iop$tape_enable_ready_task (
        i: iot$no_of_tape_units;
        j: 1 .. ioc$max_multiple_tape_requests);

?? PUSH (LISTEXT := ON) ??
*copyc iot$io_id
*copyc IOT$no_of_tape_units
?? POP ??
*DECK DECK=IOP$TAPE_ENABLE_TASKID_CHECK EXPAND=FALSE

  PROCEDURE [XREF] iop$tape_enable_taskid_check (
        i: iot$no_of_tape_units;
        j: 1 .. ioc$max_multiple_tape_requests);

?? PUSH (LISTEXT := ON) ??
*copyc iot$io_id
*copyc iot$no_of_tape_units
?? POP ??
*DECK DECK=IOP$TAPE_FILE_ATTACHED EXPAND=FALSE

  PROCEDURE [XREF] iop$tape_file_attached
    (    global_file_name: dmt$global_file_name;
     VAR attached: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$global_file_name
*copyc ost$status
?? POP ??
*DECK DECK=IOP$TAPE_INITIALIZATION EXPAND=FALSE

  PROCEDURE [XREF] iop$tape_initialization ALIAS 'iomtint' (
        logical_unit_table: ^cmt$logical_unit_table;
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc CMT$LOGICAL_UNIT_TABLE
*copyc OST$STATUS
?? POP ??
*DECK DECK=IOP$TAPE_INITIALIZE_UNIT EXPAND=FALSE

  PROCEDURE [XREF] iop$tape_initialize_unit ALIAS 'iomtgus' (
        system_file_id: dmt$system_file_id;
        VAR io_id: iot$io_id;
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc IOT$IO_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=IOP$TAPE_INITIALIZE_UNIT_SCAN EXPAND=FALSE


  PROCEDURE [XREF] iop$tape_initialize_unit_scan (
        logical_unit_number: iot$logical_unit;
        VAR io_id: iot$io_id;
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
*copyc IOT$IO_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=IOP$TAPE_INTERNAL_REQUEST_STAT EXPAND=FALSE

 PROCEDURE [XREF] iop$tape_internal_request_stat (
        logical_unit_number:iot$logical_unit;
        io_id: iot$io_id;
        buf_release: boolean;
        bid_recovery: boolean;
        bid_update: boolean;
        wait: ost$wait;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$tape_io_status
*copyc iot$logical_unit
*copyc iot$io_id
*copyc ost$status
*copyc ost$wait
?? POP ??
*DECK DECK=IOP$TAPE_MOUNTS_PENDING EXPAND=FALSE

  PROCEDURE [XREF] iop$tape_mounts_pending
    (VAR mounts_pending: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IOP$TAPE_MOUNT_COUNT EXPAND=FALSE

  PROCEDURE [XREF] iop$tape_mount_count
    (VAR tape_mount_count: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=IOP$TAPE_PROCESS_PP_RESPONSE EXPAND=FALSE

  PROCEDURE [XREF] iop$tape_process_pp_response ALIAS 'iomtptr' (
        pp_response: ^iot$pp_response;
        detailed_status_p: ^iot$detailed_status;
        pp_no: 1..ioc$pp_count;
        VAR mon_status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$PP_NUMBER
*copyc IOT$PP_RESPONSE
*copyc SYT$MONITOR_REQUEST_CODE
?? POP ??
*DECK DECK=IOP$TAPE_QUEUE_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] iop$tape_queue_request (
        VAR request_block: iot$tape_request_block);

*copyc IOT$TAPE_REQUEST_BLOCK
*DECK DECK=IOP$TAPE_QUEUE_REQUEST_SETUP EXPAND=FALSE

  PROCEDURE [XREF] iop$tape_queue_request_setup (
        pp_request: ^iot$tape_request;
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$TAPE_COLLECTED_PP_RESPONSE
*copyc OST$STATUS
?? POP ??
*DECK DECK=IOP$TAPE_REQUEST_NOT_PROCESSED EXPAND=FALSE

  PROCEDURE [XREF] iop$tape_request_not_processed (
         i: iot$io_id;
         j: iot$no_of_tape_units;
         q: 1 .. ioc$max_multiple_tape_requests;
         VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$NO_OF_TAPE_UNITS
*copyc OST$STATUS
?? POP ??

*DECK DECK=IOP$TAPE_REQUEST_STATUS EXPAND=FALSE
 PROCEDURE [XREF] iop$tape_request_status (
        file_id: dmt$system_file_id;
        io_id: iot$io_id;
        wait_for_completion: boolean;
    VAR io_status: iot$tape_io_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$tape_io_status
*copyc dmt$system_file_id
*copyc iot$io_id
*copyc ost$status
?? POP ??
*DECK DECK=IOP$TAPE_RETURN_WIRED_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] iop$tape_return_wired_request (
        i: iot$no_of_tape_units;
        j: 1 .. ioc$max_multiple_tape_requests;
        VAR tape_request_p: ^iot$tape_request;
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$TAPE_COLLECTED_PP_RESPONSE
*copyc IOT$NO_OF_TAPE_UNITS
*copyc OST$STATUS
?? POP ??
*DECK DECK=IOP$TAPE_SCANNER EXPAND=FALSE

 PROCEDURE [XREF] iop$tape_scanner;
*DECK DECK=IOP$TAPE_TERMINATE_IO_SCAN EXPAND=FALSE


  PROCEDURE [XREF] iop$tape_terminate_io_scan (
        logical_unit_number: iot$logical_unit);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$LOGICAL_UNIT
?? POP ??
*DECK DECK=IOP$TAPE_UPDATE_BYTE_COUNTS EXPAND=FALSE
  PROCEDURE [XREF] iop$tape_update_byte_counts (
    system_file_id: dmt$system_file_id;
    max_block_length: amt$max_block_length;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc AMT$MAX_BLOCK_LENGTH
*copyc OST$STATUS
?? POP ??

*DECK DECK=IOP$TERMINATE_ASSIGNMENT EXPAND=FALSE

  PROCEDURE [XREF] iop$terminate_assignment (
    sfid: dmt$system_file_id;
    ssn: jmt$system_supplied_name;
    message: string (osc$max_string_size);
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc jmt$system_supplied_name
*copyc ost$status
*copyc ost$string
?? POP ??


*DECK DECK=IOP$TERMINATE_TAPE_ASSIGNMENT EXPAND=FALSE

  PROCEDURE [XREF] iop$terminate_tape_assignment (
    external_vsn: rmt$external_vsn;
    message: string (osc$max_string_size);
    ssn: jmt$system_supplied_name;
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$string
*copyc rmt$external_vsn
*copyc ost$status
?? POP ??

*DECK DECK=IOP$TRANSLATE_BYTE_ADDRESS EXPAND=FALSE

  PROCEDURE [XREF] iop$translate_byte_address (VAR request_block:
    iot$rb_translate_byte_address);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$RB_TRANSLATE_BYTE_ADDRESS
?? POP ??
*DECK DECK=IOP$UNLOAD_TAPE EXPAND=FALSE

  PROCEDURE [XREF] iop$unload_tape
    (    system_file_id: dmt$system_file_id;
         detachment_options: fmt$detachment_options;
     VAR io_id: iot$io_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc fmt$detachment_options
*copyc iot$io_id
*copyc ost$status
?? POP ??
*DECK DECK=IOP$UNLOCK_THE_RMA_LIST EXPAND=FALSE


PROCEDURE [XREF] iop$unlock_the_rma_list (
   queue_index: cmt$io_completion_queue_index;
   VAR status: ost$status);


?? PUSH (LISTEXT :=ON) ??
*copyc iot$io_completion_table
*copyc ost$status
?? POP ??
*DECK DECK=IOP$UNSOLICITED_SUBSYSTEM_RESP EXPAND=FALSE

      PROCEDURE [XREF] iop$unsolicited_subsystem_resp (
                   pp_response_p: ^iot$pp_response;
                   detailed_status_p: ^iot$detailed_status;
                   pp_number: 1 .. ioc$pp_count;
              VAR status: syt$monitor_status);

?? PUSH (LISTEXT:= ON) ??
*copyc iot$pp_response
*copyc iot$pp_interface_table
*copyc syt$monitor_status
?? POP ??

*DECK DECK=IOP$UPDATE_BLOCK_COUNT EXPAND=FALSE

  PROCEDURE [XREF] iop$update_block_count (
        sfid: dmt$system_file_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??
*DECK DECK=IOP$VALIDATE_CANDIDATE_ELEMENT EXPAND=FALSE

  PROCEDURE [XREF] iop$validate_candidate_element
    (    element: cmt$element_name;
         acceptable_states: set of cmt$element_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$element_state
*copyc ost$name
*copyc ost$status
*copyc rme$robotic_interface_errors
?? POP ??
*DECK DECK=IOP$WRITE_TAPE EXPAND=FALSE

  PROCEDURE [XREF] iop$write_tape ALIAS 'iomtwr' (
        system_file_id: dmt$system_file_id;
        inhibit_error_recovery: boolean;
        block_description: ^iot$write_tape_description;
        no_of_blocks_to_write: iot$tape_block_count;
        VAR io_id: iot$io_id;
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$TAPE_BLOCK_COUNT
*copyc IOT$WRITE_TAPE_DESCRIPTION
*copyc DMT$SYSTEM_FILE_ID
*copyc IOT$IO_ID
?? POP ??
*DECK DECK=IOP$WRITE_TAPEMARK EXPAND=FALSE

  PROCEDURE [XREF] iop$write_tapemark ALIAS 'iomtwtm' (
        system_file_id: dmt$system_file_id;
        VAR io_id: iot$io_id;
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc IOT$IO_ID
*copyc OST$STATUS
?? POP ??

*DECK DECK=IOP$WRITE_UNLOCK_TUSL_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] iop$write_unlock_tusl_entry
    (    write_entry: boolean;
         tusl_ordinal: iot$tusl_ordinal;
         tape_unit_status_entry: iot$tape_unit_status_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$tape_unit_status_entry
*copyc iot$tusl_ordinal
*copyc ost$status
?? POP ??

*DECK DECK=IOPCCHI EXPAND=FALSE
          SPACE  4,10
          BASE   M
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 IOPCCHI  SPACE  4
***       IOPCCHI - REDEFINE I/O INSTRUCTIONS.
*         G. R. MANSFIELD.  70/10/04.
 IOPCCHI  SPACE  4
***              IOPCCHI REDEFINES THE I/O INSTRUCTIONS TO PRODUCE
*         A CHANNEL TABLE BY REMOTE CODE.
*
*         IF *RICHI$* IS UNDEFINED, THE CHANNEL INSTRUCTIONS WILL BE
*         REDEFINED AT THE TIME *IOPCCHI* IS ASSEMBLED AND THE MACRO
*         *RICHI* WILL NOT BE CREATED.  IF *RICHI$* IS DEFINED,
*         HOWEVER, THE MACRO *RICHI* WILL BE CREATED AND INSTRUCTION
*         REDEFINITION WILL NOT TAKE PLACE UNTIL *RICHI* IS CALLED.
*         THE MACROS *RICHI* AND *RSTC* CAN BE USED TO ENABLE OR
*         DESABLE INSTRUCTION REDEFINITION.
*
*         ORIGINAL FORM MAY BE USED BY APPENDING A *.* TO THE ORIGINAL
*         OPCODE.
*
*         INSTRUCTIONS REDEFINED -
*                AJM
*                IJM
*                FJM
*                EJM
*                IAM
*                OAM
*                FNC
*                IAN
*                OAN
*                ACN
*                DCN
*                FAN
 CHIM     SPACE  4
**        CHIM - REDEFINE M-TYPE CHANNEL INSTRUCTIONS.
*
*
*         CHIM   OPC,CODE
*         ENTRY  *OPC* = INSTRUCTION MNEMONIC.
*                *CODE* = OPERATION CODE.


          PURGMAC CHIM
 CHIM     MACRO  OPC,CODE
          PURGMAC OPC
 OPC.     PPOP   7,CODE
 OPC      MACRO  M,D
          LOCAL  A
 A        OPC.   M,D
          RMT
          CON    A
          RMT
 OPC      ENDM
 CHIM     ENDM
 CHIN     SPACE  4
**        CHIN - REDEFINE N-TYPE CHANNEL INSTRUCTIONS.
*
*
*         CHIN   OPC,CODE
*         ENTRY  *OPC* = INSTRUCTION MNEMONIC.
*                *CODE* = OPERATION CODE.


          PURGMAC CHIN
 CHIN     MACRO  OPC,CODE
          PURGMAC OPC
 OPC.     PPOP   4,CODE
 OPC      MACRO  D
          LOCAL  A
 A        OPC.   D
          RMT
          CON    A
          RMT
 OPC      ENDM
 CHIN     ENDM
 RICHI    SPACE  4
***       RICHI - REDEFINE CHANNEL INSTRUCTIONS.
*
*         RICHI
*         EACH TIME *RICHI* IS CALLED, INSTRUCTION REDEFINITION OCCURS.
*         *RICHI* IS CREATED ONLY IF *RICHI$* IS DEFINED.


          IF     DEF,RICHI$,2
          PURGMAC RICHI
 RICHI    MACRO
          BASE   O

          CHIM   AJM,6400
          CHIM   IJM,6500
          CHIM   FJM,6600
          CHIM   EJM,6700
          CHIM   IAM,7100
          CHIM   OAM,7300
          CHIM   FNC,7700

          CHIN   IAN,7000
          CHIN   OAN,7200
          CHIN   ACN,7400
          CHIN   DCN,7500
          CHIN   FAN,7600
          BASE   *

          ENDM
 CHTE     SPACE  4
***       CHTE - CREATE CHANNEL TABLE ENTRY.
*
*
*         CHTE   ADDRESS
*         ENTRY  (ADDRESS) = ADDRESS TO INSERT IN CHANNEL TABLE.


          PURGMAC CHTE
 CHTE     MACRO  A
          LOCAL  B
 B        EQU    A
          RMT
          CON    B
          RMT
          ENDM
 CHTL     SPACE  4
***       CHTL - CREATE LAST ENTRY IN CHANNEL TABLE.
*
*
*         CHTL   ADDRESS
*         ENTRY  (ADDRESS) = ADDRESS TO INSERT AS LAST ENTRY IN CHANNEL
*         TABLE.
*
*         NOTE-  WHEN THIS CALL IS USED CHANNEL TABLE WILL NOT
*         TERMINATE WITH A ZERO BYTE.


          PURGMAC CHTL
 CHTL     MACRO  A
          LOCAL  B
 B        EQU    A
 CHTL     RMT
          CON    B
 CHTL     RMT
          ENDM
 CHTB     SPACE  4
***       CHTB - DEFINE CHANNEL TABLE.
*         CHANNEL TABLE IS TERMINATED BY A ZERO WORD.
*
*
*LOC      CHTB
*         ENTRY  *LOC* = FWA OF CHANNEL TABLE.


          PURGMAC CHTB
          MACRO  CHTB,A
          LOCAL  B,C
 A        BSS    0
          HERE
 B        SET    *
 CHTL     HERE
 C        SET    *
          IFEQ   B,C,1       IF NO SPECIAL TERMINATOR
 A_E      DATA   0           TERMINATE TABLE
          ENDM
 RSTC     SPACE  4
***       RSTC - RESTORE CHANNEL INSTRUCTIONS.
*
*
*         RSTC


          PURGMAC RSTC
 RSTC     MACRO
          PURGMAC AJM
          PURGMAC IJM
          PURGMAC FJM
          PURGMAC EJM
          PURGMAC IAN
          PURGMAC IAM
          PURGMAC OAN
          PURGMAC OAM
          PURGMAC ACN
          PURGMAC DCN
          PURGMAC FAN
          PURGMAC FNC
 AJM      OPSYN  AJM.
 IJM      OPSYN  IJM.
 FJM      OPSYN  FJM.
 EJM      OPSYN  EJM.
 IAN      OPSYN  IAN.
 IAM      OPSYN  IAM.
 OAN      OPSYN  OAN.
 OAM      OPSYN  OAM.
 ACN      OPSYN  ACN.
 DCN      OPSYN  DCN.
 FAN      OPSYN  FAN.
 FNC      OPSYN  FNC.
          ENDM
          SPACE  4,10
          BASE   *
          ENDX
*DECK DECK=IOPDCMA EXPAND=FALSE
          SPACE  5,10
************************************************************************
*         SUBROUTINE NAME-   DCRCMA
*
*         PURPOSE-           DECREMENT A 28-BIT CM ADDRS
*
*         ENTRY-             A-REG CONTAINS THE ADDRS OF THE 1ST OF 3
*                             CONSECUTIVE WRDS WHICH CONTAIN A 28-BIT
*                             CM ADDRS; THE FORMAT OF THESE 3 WRDS IS AS
*                             FOLLOWS-
*
*                             1ST WRD- XXXXXXXXUUUU
*                             2ND WRD- MMMMMMMMMMMM
*                             3RD WRD- LLLLLLLLLLLL
*
*                             WHERE- X..X ARE IRRELEVANT TO THIS ROUTINE
*                                    U..U ARE CM ADDRS BITS 27-24
*                                    M..M ARE CM ADDRS BITS 23-12
*                                    L..L ARE CM ADDRS BITS 11-00
*
*                            DCT8 CONTAINS THE VALUE BY WHICH THE
*                             CM ADDRS IS TO BE DECREMENTED
*
*         EXIT-              THE 28-BIT CM ADDRS CONTAINED WITHIN THE
*                             3 SPECD PP WRDS HAS BEEN DECREMENTED
*
*         NOTES-             (1) THE DECREMENTING IS PERFORMED IN
*                             2'S COMPLEMENT; EG. 0000-1=7777 (NOT 7776)
*
*         USES-              DCT7,DCT8
************************************************************************
          SPACE  3
 DCRCMA   SUBR               ENTRY
          SPACE  1
*         MOVE 1ST, 2ND, AND 3RD WRDS TO LOCATIONS
*         DCR.TU, DCR.TM, AND DCR.TL, RESPECTIVELY
          SPACE  1
          STD    DCT7        SAVE ADDRS OF 1ST OF 3 WRDS
          LDM    0,DCT7
          LPN    17B         ONLY BITS 03-00 ARE RELEVANT
          STM    DCR.TU
          LDM    1,DCT7
          STM    DCR.TM
          LDM    2,DCT7
          STM    DCR.TL
          SPACE  1
*         PERFORM THE DECREMENTING OF THE 28-BIT
*         ADDRS WHICH NOW IS IN DCR.TU, DCR.TM, DCR.TL
          SPACE  1
          LDM    DCR.TL
          SBD    DCT8        SUBT SPECD VALUE FROM LOWER 12 BITS
          STM    DCR.TL       AND STORE RESULT
          SHN    -17         SHIFT SIGN OF RESULT TO BIT 0
          STM    DCR.SGN      AND SAVE IT (0/1 = POS/NEG)
          RAM    DCR.TL      ADD 0/1 TO RESULT
          LDM    DCR.SGN     0 OR 1
          LMC    -0          -0 OR -1
          RAM    DCR.TM      SUBR 0 OR 1 FROM MIDDLE 12 BITS
          SHN    -17         SHIFT SIGN OF RESULT TO BIT 0
          STM    DCR.SGN      AND SAVE IT (0/1 = POS/NEG)
          RAM    DCR.TM      ADD 0/1 TO RESULT
          LDM    DCR.SGN     0 OR 1
          LMC    -0          -0 OR -1
          RAM    DCR.TU      SUBT 0 OR 1 FROM UPPER BITS
          SHN    -17         SHIFT SIGN OF RESULT TO BIT 0
          RAM    DCR.TU      ADD 0/1 TO RESULT
          LPN    17B         ONLY 4 LOWER BITS ARE RELEVANT
          STM    DCR.TU
          SPACE  1
*         RETURN DECREMENTED CM ADDRS
*         TO THE ORIGINAL LOCATIONS
          SPACE  1
          LDM    0,DCT7      PICK ORIGINAL CONTENTS OF 1ST ADDRS SOURCE
          LPC    7760B        WRD AND RETAIN BITS 11-04
          ADM    DCR.TU      ADD CM ADDRS BITS 27-24
          STM    0,DCT7
          LDM    DCR.TM      CM ADDRS BITS 23-12
          STM    1,DCT7
          LDM    DCR.TL      CM ADDRS BITS 11-00
          STM    2,DCT7
          ENDSUB DCRCMA      EXIT
 DCR.TU   BSS    1
 DCR.TM   BSS    1
 DCR.TL   BSS    1
 DCR.SGN  BSS    1
*DECK DECK=IOPHDTD EXPAND=FALSE

*********************** IOPHDTD ****************************
*
*  DEFINE CTI HARDWARE DESCRIPTOR TABLE OFFSETS
*
************************************************************
HDT.PRT0 EQU    0           MAINT. CHANNEL PORT ZERO
HDT.PRT1 EQU    1           MAINT. CHANNEL PORT ONE
HDT.PRT2 EQU    2           MAINT. CHANNEL PORT TWO
HDT.PRT3 EQU    3           MAINT. CHANNEL PORT THREE
HDT.PRT4 EQU    4           MAINT. CHANNEL PORT FOUR
HDT.PRT5 EQU    5           MAINT. CHANNEL PORT FIVE
HDT.PRT6 EQU    6           MAINT. CHANNEL PORT SIX
HDT.PRT7 EQU    7           MAINT. CHANNEL PORT SEVEN
HDT.DEGR EQU    10B         DEGRADE STATUS
HDT.CMSZ EQU    11B         CM SIZE (UPPER)
HDT.OPTN EQU    13B         OPTIONS
HDT.PPP0 EQU    14B         PHYSICAL PPS 11B-0
HDT.PPP1 EQU    15B         PHYSICAL PPS 31B-20B
HDT.LPP0 EQU    16B         LOGICAL PPS 11B-0
HDT.LPP1 EQU    17B         LOGICAL PPS 31B-20B
HDT.PPPU EQU    20B         PHYSICAL PPUS 15B-0 (TWO WORDS)
HDT.LPPU EQU    22B         LOGICAL PPUS 15B-0 (TWO WORDS)
***************** END COMMON DECK IOPHDT *******************
*DECK DECK=IOT$ALERT_CONDITIONS EXPAND=FALSE

  TYPE
    iot$alert_conditions = packed record
      long_input_block: boolean,
      compare_not_satisfied: boolean,
      physical_delimiter: boolean,
      logical_delimiter: boolean,
      character_fill: boolean,
      disabled_unit: boolean,
      fill: 0 .. 3ff(16),
    recend;
*DECK DECK=IOT$APPLICATION_QUEUE_ENTRY EXPAND=FALSE
*DECK DECK=IOT$CCC_CARTRIDGE_TAPE_STATUS EXPAND=FALSE

{ DECK: IOT$CCC_CARTRIDGE_TAPE_STATUS

  CONST  { in bytes }
    ioc$ccc_cart_device_status_size = 2 * 8,  { 16 }
    ioc$ccc_cart_sense_bytes_size = 5 * 8,  { 40 }
    ioc$ccc_cart_error_log_size = 6 * 8,  { 48 }
    ioc$min_ccc_cart_resp_size = ioc$min_response_length + ioc$ccc_cart_device_status_size,   { 56 }
    ioc$max_ccc_cart_resp_size = ioc$min_ccc_cart_resp_size + ioc$ccc_cart_sense_bytes_size +
          ioc$ccc_cart_error_log_size;  { 144 }

  TYPE
    iot$ccc_cart_device_status = PACKED RECORD
      fill1: 0 .. 0f(16),
      alert: boolean,
      continue: boolean,
      fill2: 0 .. 1,
      eighteen_track: boolean,
      write_enabled: boolean,
      wait_continue_status: boolean,
      char_fill: boolean,
      tape_mark: boolean,
      end_of_tape: boolean,
      beginning_of_tape: boolean,
      busy: boolean,
      ready: boolean,
      fill3: 0 .. 0f(16),
      adapter_check: boolean,
      unit_check: boolean,
      equipment_check: boolean,
      data_check: boolean,
      deferred_unit_check: boolean,
      error_code: 0 .. 7f(16),
      last_good_bid: iot$cartridge_tape_bid,
      error_id: 0 .. 0ffff(16),
      last_function: 0 .. 0ffff(16),
      last_non_status_function: 0 .. 0ffff(16),
      channel_error_register: 0 .. 0ffff(16),
    RECEND,

    iot$ccc_cart_sense_bytes = PACKED RECORD
      command_reject: boolean,                { byte 0
      intervention_required: boolean,
      bus_out_check: boolean,
      equipment_check: boolean,
      data_check: boolean,
      overrun: boolean,
      unit_check_timing: boolean,
      assigned_elsewhere: boolean,
      locate_block_failed: boolean,           { byte 1
      drive_online: boolean,
      fill1: 0 .. 1,
      out_of_sequence_record: boolean,
      beginning_of_tape: boolean,
      write_status: boolean,
      file_protect: boolean,
      not_capable: boolean,
      channel_adaptor_code: 0 .. 7,           { byte 2
      channel_adaptor_location: 0 .. 1,
      detecting_control_unit: 0 .. 1,
      cart_avail_in_loader: boolean,
      drive_in_sync_mode: boolean,
      block_id_pos_indicator: boolean,
      erpa_code: 0 .. 0ff(16),                { byte 3
      logical_error_bid: 0 .. 0ffffff(16),    { bytes 4 - 6
      format_code: 0 .. 0ff(16),              { byte 7
      eight_thru_15: integer,                 { bytes 8 - 15
      sixteen_thru_23: integer,               { bytes 16 - 23
      twenty_four_thru_31: integer,           { bytes 24 - 31
      thirty_two_thru_35: 0 .. 0ffffffff(16), { bytes 32 - 35
      fips_di_status: 0 .. 0fff(16),
      thirty_seven_thru_39: 0 .. 0fffff(16),  { bytes 37 - 39
    RECEND,

    iot$ccc_cart_error_log = PACKED RECORD
      recovered_read_errors: 0 .. 0ffff(16),
      fill1: 0 .. 0ffff(16),
      recovered_write_errors: 0 .. 0ffff(16),
      on_the_fly_read_errors: 0 .. 0ffff(16),
      on_the_fly_write_errors: 0 .. 0ffff(16),
      temp_cu_errors: 0 .. 0ffff(16),
      fill2: 0 .. 0ffffffff(16),
      fill3: array [1 .. 32] of 0 .. 0ff(16),
    RECEND;

  TYPE
    iot$ccc_cart_unit_comm_buffer = PACKED RECORD
      force_sync: 0 .. 0ffff(16),    { unconditional synchronize if non-zero
      request_pva: ^iot$io_request,
    RECEND;

  TYPE
    iot$ccc_cart_error_id = 0 .. ioc$max_ccc_cart_error_id;

  CONST {ccc cartridge tape error id
    ioc$ccc_cart_no_pp_eid = 0,
    ioc$ccc_cart_indeterminate = 1,
    ioc$ccc_cart_input_chan_parity = 2,
    ioc$ccc_cart_output_chan_par = 3,
    ioc$ccc_cart_coupler_failure = 4,
    ioc$ccc_cart_cu_failure = 5,
    ioc$ccc_cart_unit_failure = 6,
    ioc$ccc_cart_unit_not_ready = 7,
    ioc$ccc_cart_function_timeout = 8,
    ioc$ccc_cart_tape_medium = 9,
    ioc$ccc_cart_iou_parity = 10,
    ioc$ccc_cart_indeterminate_par = 11,
    ioc$ccc_cart_write_id_mark = 12,
    ioc$ccc_cart_read_id_mark = 13,
    ioc$ccc_cart_hardware_corr = 14,
    ioc$ccc_cart_microcode_load = 15,
    ioc$ccc_cart_invalid_bid = 16,
    ioc$ccc_cart_inc_trans_in = 17,
    ioc$ccc_cart_inc_trans_out = 18,
    ioc$ccc_cart_pp_chan_flag = 19,

{ The following are software errors that are returned by the PP.  The I/F Error
{ bit is set in the response.

    ioc$ccc_cart_single_pp = 20,
    ioc$ccc_cart_unit_type = 21,
    ioc$ccc_cart_ill_command = 22,
    ioc$ccc_cart_ill_comm_buf_lng = 23,
    ioc$ccc_cart_ill_write_sequence = 24,
    ioc$ccc_cart_reserved_1 = 25,  { reserved for software error

{ The following are software errors that are detected by CPU code
{ in iop$tape_status_check_ccc_cart.

    ioc$ccc_cart_ill_abn_status = 26,
    ioc$ccc_cart_no_alert = 27,
    ioc$ccc_cart_no_abn_status = 28,

    ioc$max_ccc_cart_error_id = 28;

?? PUSH (LISTEXT := ON) ??
*copyc iot$tape_block_id_area
*copyc iot$tape_collected_pp_response
?? POP ??

*DECK DECK=IOT$CHANNEL_INTERLOCK_TABLE EXPAND=FALSE
 CONST
    ioc$max_channel_number = 31;

  TYPE
    iot$channel_interlock_table = RECORD
      channel_table: ALIGNED [0 MOD 512]  ARRAY [0 .. ioc$max_channel_number] OF
             iot$table_lock_entry,
      channel_characteristics: ARRAY [0 .. ioc$max_channel_number] OF
             iot$channel_characteristics,
    recend,

    iot$table_lock_entry = PACKED RECORD
        channel_locked : BOOLEAN,
        fill_1 : 0 .. 7fff(16),       { 15 bits }
        ve_need_channel : BOOLEAN,
        fill_2 : 0 .. 3fff(16),       { 14 bits }
        maintenance_need_channel : BOOLEAN,
        fill_3 : 0 .. 0ffff(16),      { 16 bits }
        locking_pp : 0 .. 0ffff(16),
      recend,

{ The following type could be expanded in the future to include information
{ contained in the Mainframe_Reconfiguration_Table (MRT) that a PP might
{ be interested in.

    iot$channel_characteristics = PACKED RECORD
        concurrent_channel : BOOLEAN,
        fill : 0 .. 7fffffff(16),     { 31 bits }
        fill1 : 0 .. 0ffffffff(16),   { 32 bits }
      recend;
*DECK DECK=IOT$CHANNEL_NUMBER EXPAND=FALSE

  TYPE
    iot$channel_number = 0 .. 0ff(16),
    iot$controller_number = 0 .. 0ff(16),
    iot$physical_unit_number = 0 .. 0ffff(16);
*DECK DECK=IOT$CIO_CHANNEL_INTERLOCK_TABLE EXPAND=FALSE

   TYPE
     iot$cio_channel_interlock_table = RECORD
       channel_table : ALIGNED [0 MOD 512] ARRAY [0 .. 9] of
            iot$table_lock_entry,
       recend;

?? PUSH(LISTEXT := ON) ??
*copyc iot$channel_interlock_table
?? POP ??

*DECK DECK=IOT$COMMAND EXPAND=FALSE
{}
{ Command codes 00 .. 1f are allowed only in requests in ppu queue.
{}

  CONST
    ioc$cc_acknowledge = 0,
    ioc$cc_stop_unit = 1,
    ioc$cc_select_unit = 2,
    ioc$cc_select_controller = 3,
    ioc$cc_idle = 4,
    ioc$cc_resume = 5,
    ioc$cc_execute_overlay = 6,
    ioc$cc_start_ready_scan = 7,
    ioc$cc_stop_ready_scan = 8,
    ioc$cc_select_pp_address = 9(16),
    ioc$cc_copy_pp_memory = 0a(16),
    ioc$cc_load_controlware = 0c(16),
    ioc$cc_load_control_module = 0d(16),
    ioc$cc_enable_unit = 10(16),
    ioc$cc_disable_unit = 11(16),
    ioc$cc_master_clear_channel = 16(16),
    ioc$cc_master_clear_controller = 17(16),
{}
{ Command codes 20 .. 3f identify device_dependent (physical) commands.
{}
    ioc$cc_function = 20(16),
    ioc$cc_output_8_bit_parameters = 21(16),
    ioc$cc_output_6_bit_parameters = 22(16),
    ioc$cc_output_8_bit_data = 23(16),
    ioc$cc_output_6_bit_data = 24(16),
    ioc$cc_input_8_bit_data = 25(16),
    ioc$cc_input_6_bit_data = 26(16),
{}
{ Command codes 40 .. ff identify logical commands.
{}
    ioc$cc_read_bytes = 40(16),
    ioc$cc_read_record = 41(16),
    ioc$cc_read_6_bit_record = 42(16),
    ioc$cc_write_bytes = 50(16),
    ioc$cc_write_record = 51(16),
    ioc$cc_network_output = 51(16),
    ioc$cc_write_6_bit_record = 52(16),
    ioc$cc_read_status = 60(16),
    ioc$cc_store_transfer_count = 61(16),
    ioc$cc_compare_swap = 70(16),
    ioc$cc_pool_read = 71(16),
    ioc$cc_write_initialize = 72(16),
    ioc$cc_read_flaws = 73(16),
    ioc$cc_initialize_sectors = 74(16),
    ioc$cc_synchronize_pp = 75(16),
    ioc$cc_normal_flow_control = 77(16),
    ioc$cc_debug_mode = 78(16),
    ioc$cc_reset_device = 79(16),
    ioc$cc_define_ethernet_address = 7A(16),
    ioc$cc_write_verify = 80(16),
    ioc$cc_rewind = 90(16),
    ioc$cc_unload = 91(16),
    ioc$cc_forward_space_record = 92(16),
    ioc$cc_backspace_record = 93(16),
    ioc$cc_forward_space_filemark = 94(16),
    ioc$cc_backspace_filemark = 95(16),
    ioc$cc_write_filemark = 96(16),
    ioc$cc_security_erase = 97(16),
    ioc$cc_select_density = 98(16),
    ioc$cc_locate_block = 99(16);

  TYPE
    iot$command = packed record
      command_code: iot$command_code,
      flags: iot$flags,
      length: iot$command_length,
      address: ost$real_memory_address,
    recend,

    iot$command_code = 0 .. 0ff(16),

    iot$flags = packed record
      store_response: boolean,
      indirect_address: boolean,
      fill: 0 .. 3f(16),
    recend,

    iot$command_length = 0 .. 0ffff(16);

*copyc ost$hardware_subranges
*DECK DECK=IOT$COMPLETION_STATUS EXPAND=FALSE

  TYPE
    iot$completion_status = 0 .. 2;
*DECK DECK=IOT$CONDITIONAL_SERVER_MESSAGE EXPAND=FALSE
  TYPE
    iot$conditional_server_message = record
      issue_prior_to_retry_attempt: ost$positive_integers,
      message: ost$status_message,
    recend;

*copyc osd$integer_limits
*copyc ost$status_message
*DECK DECK=IOT$CONFIGURED_ELEMENT_ENTRY EXPAND=FALSE

 TYPE
   iot$configured_element_entry = iot$tusl_ordinal;

*copyc iot$tusl_ordinal
*DECK DECK=IOT$CONTROLLER_CONNECTION EXPAND=FALSE

  TYPE
    iot$controller_connection = record
      mainframe_id: iot$mainframe_id,
      channel_number: iot$channel_number,
      equipment_number: iot$controller_number,
      physical_unit_number: iot$physical_unit_number,
      pp_usage: array [1 .. 2] of iot$pp_number,
    recend;

*copyc IOT$MAINFRAME_ID
*copyc IOT$CHANNEL_NUMBER
*copyc IOT$PP_NUMBER
*DECK DECK=IOT$CYLINDER EXPAND=FALSE

  TYPE
    iot$cylinder = 0 .. 0ffff(16),
    iot$track = 0 .. 0ffff(16),
    iot$sector = 0 .. 0ffff(16);
*DECK DECK=IOT$CYLINDERS_TO_INITIALIZE EXPAND=FALSE
 TYPE
    iot$cylinders_to_initialize = packed record
      start_cylinder: 0 .. 0ffff(16),
      end_cylinder: 0 .. 0ffff(16),
    recend,

    iot$initialize_sectors = packed record
      fill1: ALIGNED [0 MOD 8] 0 .. 0ffffffff(16),
      cylinders: iot$cylinders_to_initialize,
    recend,

    iot$initialize_sector_list = packed record
      list: ALIGNED [0 MOD 4096] array [ * ] of iot$initialize_sectors,
    recend;
*DECK DECK=IOT$DEBUG_ACTIONS EXPAND=FALSE
 TYPE
    iot$debug_actions = set of iot$debug_codes,
    iot$debug_codes = (ioc$validate_subsys_io_comp_tbl,
      ioc$halt_on_fatal_status, ioc$enable_subsystem_timing, ioc$validate_io_queue,
      ioc$validate_parameters, ioc$debug_6, ioc$debug_7, ioc$debug_8);
*DECK DECK=IOT$DENSITY_STATES EXPAND=FALSE

  TYPE
    iot$density_states = record
      down_count: ost$non_negative_integers,
      off_count: ost$non_negative_integers,
      on_count: ost$non_negative_integers,
    recend;

*copyc osd$integer_limits
*DECK DECK=IOT$DEVICE_STATUS EXPAND=FALSE

  TYPE
    iot$device_status = record
      element_status: iot$element_status,
      element_mode: iot$element_mode,
    recend;

*copyc IOT$ELEMENT_STATUS
*copyc IOT$ELEMENT_MODE
*DECK DECK=IOT$DEVICE_TABLE EXPAND=FALSE

  TYPE
    iot$device_table = record
      sen: iot$sen,
      unit_type: iot$unit_type,
      device_usage_type: iot$device_usage_type,
      controller_connection: array [1 .. 4] of iot$controller_connection,
      element_state: iot$element_state,
    recend;

*copyc IOT$SEN
*copyc IOT$UNIT_TYPE
*copyc IOT$DEVICE_USAGE_TYPE
*copyc IOT$CONTROLLER_CONNECTION
*copyc IOT$HARDWARE_IDENTIFIER
*copyc IOT$DEVICE_STATUS
*DECK DECK=IOT$DEVICE_USAGE_TYPE EXPAND=FALSE

  TYPE
    iot$device_usage_type = (ioc$removable_device, ioc$system_device);
*DECK DECK=IOT$DISK_DETAILED_STATUS_844 EXPAND=FALSE

{ DECK: IOT$DISK_DETAILED_STATUS_844 }

 CONST
   ioc$unique_status = ioc$disk_detailed_status_length - 4;


 TYPE
    iot$common_disk_status = packed record
      general_status: ALIGNED [0 MOD 8] iot$general_status,
      detailed_status: array [1 .. ioc$unique_status] of ost$word,
    recend,



    iot$disk_detailed_status_844 = packed record
      general_status: ALIGNED [0 MOD 8] iot$general_status,
      part1: ALIGNED [0 MOD 8] iot$disk_detailed_status1,
      status_844: ALIGNED [0 MOD 8] iot$status_844,
      part3: ALIGNED [0 MOD 8] iot$disk_detailed_status3,
      part4: ALIGNED [0 MOD 8] iot$disk_detailed_status1,
      status_844_b: ALIGNED [0 MOD 8] iot$status_844,
      part6: ALIGNED [0 MOD 8] iot$disk_detailed_status3,
    recend,



    iot$disk_detailed_status_885 = packed record
      general_status: ALIGNED [0 MOD 8] iot$general_status,
      part1: ALIGNED [0 MOD 8] iot$disk_detailed_status1,
      status_885: ALIGNED [0 MOD 8] iot$status_885,
      part3: ALIGNED [0 MOD 8] iot$disk_detailed_status3,
      part4: ALIGNED [0 MOD 8] iot$disk_detailed_status1,
      status_885_b: ALIGNED [0 MOD 8] iot$status_885,
      part6: ALIGNED [0 MOD 8] iot$disk_detailed_status3,
    recend,


    iot$general_status = packed record
      port: boolean,
      channel: 0 .. 07fff(16),
      starting_cylinder: 0 .. 0ffff(16),
      starting_track: 0 .. 0ffff(16),
      starting_sector: 0 .. 0ffff(16),

      control_module: 0 .. 1fff(16),
      unit: 0 .. 7,
      request_retry: 0 .. 0ffff(16),
      failing_track: 0 .. 0ffff(16),
      failing_sector: 0 .. 0ffff(16),

      sector_size_not_4096: boolean,
      not_same_host_id: boolean,
      confidence_cylinder_is_flawed: boolean,
      running_the_confidence_test: boolean,
      master_clear_did_not_work: boolean,
      drive_if_integrity_error: boolean,
      host_if_integrity_error: boolean,
      channel_initialization_error: boolean,
      timeout_pause: boolean,
      timeout_tip: boolean,
      cannot_select_controller: boolean,
      incorrect_controller_selected: boolean,
      error_log_present: boolean,
      error_register_image_present: boolean,
      device_status_present: boolean,
      detailed_status_present: boolean,

      channel_down: boolean,
      control_module_down: boolean,
      unit_down: boolean,
      level_1_diagnostics_passed: boolean,
      level_1_diagnostics_started: boolean,
      selective_reset_successful: boolean,
      selective_reset_attempted: boolean,
      soft_sectoring_complete: boolean,
      soft_sectoring_started: boolean,
      pp_timed_out_a_command: boolean,
      spindle_powered_up: boolean,
      power_up_spindle_started: boolean,
      level_2_diagnostics_passed: boolean,
      level_2_diagnostics_started: boolean,
      control_module_reload_completed: boolean,
      control_module_reload_started: boolean,

      fill4: 0 .. 1,
      timeout_t_register_byte_count: boolean,
      timeout_tip_or_t_reg_not_empty: boolean,
      data_transfer_error: boolean,
      invalid_execution_status: boolean,
      select_active_dropped_data: boolean,
      select_active_dropped_error_log: boolean,
      incomplete_error_log_transfer: boolean,
      sa_dropped_error_register_image: boolean,
      incomplete_error_reg_image_xfer: boolean,
      sa_dropped_device_status: boolean,
      incomplete_device_status_xfer: boolean,
      sa_dropped_hydra_status: boolean,
      incomplete_status_transfer: boolean,
      fill6: boolean,
      incomplete_command_block_xfer: boolean,

      sector_retry_count: 0 .. 0ffff(16),

      first_general_status: ALIGNED [0 MOD 8]   0 .. 0ffff(16),
      last_general_status: 0 .. 0ffff(16),
      function_timeout: 0 .. 0ffff(16),

      adapter_controlware_error: boolean,
      controller_reserved: boolean,
      unit_reserved: boolean,
      not_ready: boolean,
      load_attention_delay_error: boolean,
      bad_status_loading_controlware: boolean,
      read_error: boolean,
      unrecovered_media_error: boolean,
      media_failure: boolean,
      input_channel_active: boolean,
      output_channel_full: boolean,
      autoload_function_timeout: boolean,
      controlware_load_attempted: boolean,
      ram_parity_error: boolean,
      clear_unit_reserve: boolean,
      incomplete_sector_transfer: boolean,
    recend,



    iot$disk_detailed_status1 = packed record
{Word 1.}
      fill1: 0 .. 0f(16),
      strobe_offset_retry_count: 0 .. 0ff(16),
      address_error: boolean,
      cylinder_number_error: boolean,
      track_number_error: boolean,
      sector_number_error: boolean,

{Word 2.}
      fill2: 0 .. 0f(16),
      address_checkword_error: boolean,
      non_correct_address_checkword: boolean,
      data_checkword_error: boolean,
      non_correct_data_checkword: boolean,
      status_word_4: 0 .. 0ff(16),

{Word 3.}
      fill3: 0 .. 0f(16),
      pp_command: 0 .. 0ff(16),
      parameters_illegal: boolean,
      illegal_parameter_count: boolean,
      fill4: boolean,
      no_reply_esm: boolean,

{Word 4.}
      fill5: 0 .. 0f(16),
      ma401_controlware: boolean,
      subsystem_7155: boolean,
      controlware_revision_number: 0 .. 0f(16),
      unit_number: 0 .. 3f(16),
    recend,



    iot$status_844 = packed record
{Word 5.}
      fill6: 0 .. 0f(16),
      cylinder2: 0 .. 1ff(16),
      track1: 0 .. 7,

{Word 6.}
      fill7: 0 .. 0f(16),
      track2: 0 .. 3,
      sector: 0 .. 1f(16),
      sector_flaw_bit: boolean,
      track_flaw_bit: boolean,
      factory_flaw_map: boolean,
      utility_flaw_map: boolean,
      cylinder1: 0 .. 1,

{Word 7.}
      fill8: 0 .. 0ffff(16),

{Word 8.}
      fill9: 0 .. 0ffff(16),

{Word 9.}
      fill10: 0 .. 0f(16),
      sector_alert: boolean,
      seek_error: boolean,
      unit_busy: boolean,
      unit_selected: boolean,
      unit_ready: boolean,
      unit_on_line: boolean,
      dsu_844_4x: boolean,
      fill11: 0 .. 3,
      end_of_cylinder: boolean,
      end_of_travel: boolean,
      index_mark: boolean,

{Word 10.}
      fill12: 0 .. 0f(16),
      on_cylinder: boolean,
      seek_error_noc: boolean,
      pack_unsafe: boolean,
      sector_mark: boolean,
      seek: boolean,
      volt_current: 0 .. 0f(16),
      w_r_not_on_cylinder: boolean,
      ac_write_fault: boolean,
      interlock_status1: boolean,

{Word 11.}
      fill13: 0 .. 0f(16),
      interlock_status2: 0 .. 0fff(16),

{Word 12.}
      fill14: 0 .. 0ffff(16),
    recend,



    iot$status_885 = packed record
{Word 5.}
      fill6: 0 .. 0f(16),
      track_flaw_bit: boolean,
      flag_factory_flaw_bit: boolean,
      fill7: 0 .. 0f(16),
      cylinder1: 0 .. 3f(16),

{Word 6.}
      fill8: 0 .. 0f(16),
      cylinder2: 0 .. 0f(16),
      track: 0 .. 0ff(16),

{Word 7.}
      fill9: 0 .. 0f(16),
      sector: 0 .. 0ff(16),
      unit_ready_and_safe: boolean,
      system_maintenance_switch: boolean,
      drive_id: 0 .. 3,

{Word 8.}
      fill10: 0 .. 0f(16),
      drive_id2: 0 .. 3f(16),
      fixed_heads_installed: boolean,
      write_enable: boolean,
      on_line: boolean,
      air_switch: boolean,
      start_switch_on: boolean,
      motor_at_speed: boolean,

{Word 9.}
      fill11: 0 .. 0f(16),
      index: boolean,
      sector_mark: boolean,
      on_cylinder: boolean,
      selected_and_reserved: boolean,
      ready_and_safe: boolean,
      on_sector: boolean,
      status_valid: boolean,
      status_parity_error: boolean,
      seek_timeout_error: boolean,
      seek_overshoot_error: boolean,
      servo_off_track: boolean,
      rezero_mode_latch: boolean,

{Word 10.}
      fill12: 0 .. 0f(16),
      status_word_2: 0 .. 0f(16),
      status_word3: 0 .. 0ff(16),

{Word 11.}
      fill13: 0 .. 0f(16),
      capable_enable_error: boolean,
      write_overrun: boolean,
      multi_head_error: boolean,
      write_current_error: boolean,
      write_transition_error: boolean,
      control_error: boolean,
      index_check: boolean,
      head_short: boolean,
      no_control_select_active: boolean,
      write_while_in_offset: boolean,
      fill14: 0 .. 3,

{Word 12.}
      fill15: 0 .. 0f(16),
      early_strobe: boolean,
      late_strobe: boolean,
      forward_offset: boolean,
      reverse_offset: boolean,
      fill16: boolean,
      sector_compare_error: boolean,
      drive_check_error: boolean,
      fill17: boolean,
      read_write_error: boolean,
      fill18: 0 .. 3,
      access_check: boolean,
    recend,



    iot$disk_detailed_status3 = packed record
{Word 13.}
      fill19: 0 .. 0f(16),
      write_buffer_to_disk_error: boolean,
      coupler_connected_before_gs: boolean,
      dsu_reserved_before_seek: boolean,
      word_address: 0 .. 1ff(16),

{Word 14.}
      fill20: 0 .. 0f(16),
      status_word: 0 .. 0fff(16),

{Word 15.}
      fill21: 0 .. 0f(16),
      status_word_2: 0 .. 0fff(16),

{Word 16.}
      fill22: 0 .. 0f(16),
      lost_dsu_clock: boolean,
      checkword_error_head3: boolean,
      checkword_error_head_2: boolean,
      checkword_error_head1: boolean,
      checkword_error_head_0: boolean,
      data_parity_error: boolean,
      processor_instruction_timeout: boolean,
      lost_control_word: boolean,
      up_down_count_non_zero: boolean,
      pack_unsafe_not_ready: boolean,
      bm_register_parity_error: boolean,
      write_verify_error: boolean,

{Word 17.}
      fill23: 0 .. 0f(16),
      sync_byte_search: boolean,
      sector_length_violation: boolean,
      lost_data: boolean,
      sync_byte_miscompare: boolean,
      checkword_error_correction: boolean,
      bm_output_register_full: boolean,
      bm_input_register_full: boolean,
      channel_reserved: boolean,
      channel_deadman_timeout: boolean,
      channel_active: boolean,
      data_field_error: boolean,
      address_field_error: boolean,

{Word 18.}
      fill24: 0 .. 0f(16),
      access_d_connected: boolean,
      access_c_connected: boolean,
      access_b_connected: boolean,
      access_a_connected: boolean,
      controlware: 0 .. 7,
      status_not_valid: boolean,
      large_sector_mode: boolean,
      fill25: 0 .. 7,

{Word 19.}
      fill26: 0 .. 0f(16),
      extended_addressing: boolean,
      high_speed_data: boolean,
      upper_half_of_buffer_memory: boolean,
      fill27: 0 .. 3,
      status_word_valid: boolean,
      fill28: boolean,
      channel_parity_error: boolean,
      write_function: boolean,
      double_error: boolean,
      accept: boolean,
      abort: boolean,

{Word 20.}
      fill29: 0 .. 0f(16),
      error_head3: boolean,
      error_head_2: boolean,
      error_head1: boolean,
      error_head_0: boolean,
      controller_number: 0 .. 0ff(16),
    recend,



    iot$isd_status = packed record
      general_status: ALIGNED [0 MOD 8] iot$general_status,
      detailed_status1: ALIGNED [0 MOD 8] iot$isd_detailed_status,
      detailed_status2: ALIGNED [0 MOD 8] iot$isd_detailed_status,
    recend,


    iot$isd_detailed_status = packed record
{Word 1.}
      fill1: 0 .. 0ffff(16),

{Word 2.}
      fill2: 0 .. 0ffff(16),

{Word 3.}
      fill3: 0 .. 0f(16),
      pp_command: 0 .. 0ff(16),
      parameters_illegal: boolean,
      fill4: boolean,
      multiple_select: boolean,
      fill5: boolean,

{Word 4.}
      fill6: 0 .. 1f(16),
      isd_subsystem: boolean,
      controlware_revision_number: 0 .. 0f(16),
      cm_number: 0 .. 7,
      unit_number: 0 .. 7,

{Word 5.}
      fill7: 0 .. 0ffff(16),

{Word 6.}
      fill8: 0 .. 0ffff(16),

{Word 7.}
      fill9: 0 .. 0f(16),
      normal_end: boolean,
      check_end: boolean,
      execution_status: 0 .. 7,
      system_intervention_code_valid: boolean,
      manual_intervention_code_valid: boolean,
      delay_status_valid: boolean,
      drive_number: 0 .. 0f(16),

{Word 8.}
      fill10: 0 .. 0f(16),
      command_block_number: 0 .. 0f(16),
      level_i_diagnostic_code: 0 .. 0ff(16),

{Word 9.}
      fill11: 0 .. 0f(16),
      system_intervention_code: 0 .. 0ff(16),
      level_ii_diagnostic_code_1: 0 .. 0f(16),

{Word 10.}
      fill12: 0 .. 0f(16),
      level_ii_diagnostic_code_2: 0 .. 0f(16),
      manual_intervention_code: 0 .. 0ff(16),

{Word 11.}
      fill13: 0 .. 0f(16),
      delay_code: 0 .. 0ff(16),
      drive_ready: boolean,
      drive_present: boolean,
      fill14: 0 .. 3,

{Word 12.}
      fill29: 0 .. 0f(16),
      cylinder: 0 .. 0fff(16),

{Word 13.}

      fill15: 0 .. 0f(16),
      track: 0 .. 0ff(16),
      sector1: 0 .. 0f(16),

{Word 14.}
      fill16: 0 .. 0f(16),
      sector2: 0 .. 07,
      sector3: 0 .. 1,
      device_id: 0 .. 0ff(16),

{Word 15.}
      fill17: 0 .. 0f(16),
      device_capacity: 0 .. 0f(16),
      device_model: 0 .. 0f(16),
      no_head_select: boolean,
      write_fault: boolean,
      off_cylinder: boolean,
      read_and_write_fault: boolean,

{Word 16.}
      fill18: 0 .. 0f(16),
      voltage_fault: boolean,
      head_select_fault: boolean,
      seek_error: boolean,
      write_protect: boolean,
      address_mark_found: boolean,
      write_protect2: boolean,
      on_cylinder: boolean,
      unit_ready: boolean,
      fill19: 0 .. 3,
      offset_action: boolean,
      check_diagnostic: boolean,

{Word 17.}
      fill20: 0 .. 0f(16),
      cm_model_number: 0 .. 0f(16),
      adapter_failure: boolean,
      cm_failure: boolean,
      drive_failure: boolean,
      failure_code: 0 .. 1f(16),

{WOrd 18.}
      fill21: 0 .. 0f(16),
      fill22: 0 .. 0f(16),
      controlware: 0 .. 7,
      cos_revision_number: 0 .. 1f(16),

{Word 19.}
      fill23: 0 .. 0f(16),
      fill24: boolean,
      no_attention_bit: boolean,
      cm_busy: boolean,
      fill25: boolean,
      isi_select_active: boolean,
      isi_pause: boolean,
      disable_isi_parity_error: boolean,
      force_sync_in: boolean,
      isi_parity_error: boolean,
      isi_select_hold: boolean,
      isi_command_sequence: boolean,
      isi_deadman_time_out: boolean,

{Word 20.}
      fill26: 0 .. 0f(16),
      fill27: 0 .. 3,
      memory_parity_error: boolean,
      buffer_memory_parity_error: boolean,
      word_transfer_in_progress: boolean,
      read_not_equal_write_address: boolean,
      ici_parity_error: boolean,
      fill28: boolean,
      ici_full: boolean,
      channel_reserved: boolean,
      channel_deadman_time_out: boolean,
      channel_active: boolean,
    recend,

{Hydra status.

    iot$hydra_status = packed record
      general_status: ALIGNED [0 MOD 8] iot$general_status,
      operational_status: 0 .. 0ffff(16),
      t_register: 0 .. 0ffffffffffff(16),
      control_register: 0 .. 0ffff(16),
      flag_mask_register: 0 .. 0ffff(16),
      idle_status: 0 .. 0ffff(16),
      bit_significant_response: 0 .. 0ffff(16),
      cm_status1: iot$hydra_cm_status,
      device_status1: iot$hydra_device_status,
      cm_status2: iot$hydra_cm_status,
      device_status2: iot$hydra_device_status,
      error_register_image: array [1 .. 12] of ost$word,
      error_log: array [1 .. 12] of ost$word,
    recend,


    iot$hydra_cm_status = packed record
{Word 0.}
      normal_end: boolean,
      check_end: boolean,
      execution_status: 0 .. 7,
      system_intervention_code_valid: boolean,
      manual_intervention_code_valid: boolean,
      delay_status_valid: boolean,
      device_number: 0 .. 0f(16),
      command_block_number: 0 .. 0f(16),

{Word 1.}
      fru1: 0 .. 0f(16),
      fru2: 0 .. 0f(16),
      system_intervention_code: 0 .. 0ff(16),

{Word 2.}
      fru3: 0 .. 0f(16),
      fru4: 0 .. 0f(16),
      manual_intervention_code: 0 .. 0ff(16),

{Word 3.}
      model_number: 0 .. 0f(16),
      type_number: 0 .. 0f(16),
      delay_code: 0 ..0ff(16),

{Word 4.}
      transfer_count_residue: 0 .. 0ffff(16),

{Word 5.}
      device_ready: 0 .. 0ff(16),
      device_present: 0 .. 0ff(16),
    recend,


    iot$hydra_device_status = packed record
{Word 0.}
      device_id: 0 .. 0ff(16),
      device_capacity: 0 .. 0f(16),
      device_model: 0 .. 0f(16),

{Word 1.}
      cylinder: 0 .. 0ffff(16),

{Word 2.}
      track: 0 ..0ff(16),
      sector: 0 .. 0ff(16),

{Word 3.}
      no_head_select: boolean,
      write_fault: boolean,
      write_and_off_cylinder: boolean,
      read_and_write_fault: boolean,
      voltage_fault: boolean,
      head_select_fault: boolean,
      seek_rps_error: boolean,
      write_offset: boolean,
      volt_warning: boolean,
      mpu_fault: boolean,
      on_cylinder: boolean,
      disk_ready: boolean,
      rps_sector: boolean,
      diagnostic_mode: boolean,
      offset_active: boolean,
      check_diagnostic: boolean,
    recend,

    iot$channel_error_status = packed record
      fill: 0 .. 3,
      uncorrected_cm_error: boolean,
      cm_reject: boolean,
      invalid_cm_response: boolean,
      response_code_parity_error: boolean,
      cmi_read_data_parity_error: boolean,
      test_mode_compare_error: boolean,
      overflow_error: boolean,
      isi_input_error: boolean,
      isi_timeout: boolean,
      jp_jy_data_error: boolean,
      bas_parity_error: boolean,
      jz_error: boolean,
      jp_jy_error: boolean,
      jn_jx_error: boolean,
    recend,



{895 Status.}

    iot$895_detailed_status = packed record
      general_status: ALIGNED [0 MOD 8] iot$general_status,
      first_error_register: 0 .. 0ffff(16),
      last_error_register: 0 .. 0ffff(16),
      op_status: 0 .. 0ffff(16),
      error_code: 0 .. 0ffff(16),
      detailed_status_1: ALIGNED [0 MOD 8] iot$895_sense_status,
      controller_status_1: ALIGNED [0 MOD 8] iot$controller_status,
      detailed_status_2: ALIGNED [0 MOD 8] iot$895_sense_status,
      controller_status_2: ALIGNED [0 MOD 8] iot$controller_status,
    recend,


    iot$895_sense_status = packed record

{Sense Byte 0}
      fill1: 0..0f(16),
      command_reject: boolean,
      intervention_required: boolean,
      bus_out_parity: boolean,
      equipment_check: boolean,
      data_check: boolean,
      overrun: boolean,
      not_used1: 0..3,

{Sense Byte 1}
      permanent_device_error: boolean,
      invalid_track_format: boolean,
      end_of_cylinder: boolean,
      message_to_operator: boolean,
      fill2: 0..0f(16),
      no_record_found: boolean,
      file_protected: boolean,
      not_used2: 0..3,

 {Sense Byte 2}
      not_used3: 0..1,
      correctable: boolean,
      first_logged_error: boolean,
      environmental_data_present: boolean,
      not_used4: 0..0f(16),

{Sense Byte 3}
      fill3: 0..0f(16),
      controller_id: 0..0ff(16),
{        Sense Byte 4}
      dynamic_path_select: boolean,
      not_used5: 0..1,
      path_error: boolean,
      not_used6: 0..1,

{Sense Byte 4}
      fill4: 0..0f(16),
      device_address: 0..0f(16),

{        Sense Byte 5}
      cylinder_address_1: 0..0ff(16),

{Sense Byte 6}
      fill5: 0..0f(16),
      not_used7: 0..3,
      cylinder_address_2: 0..3,
      head_address: 0..0f(16),

{Sense Byte 7}
      format_code: 0..0f(16),
      fill6: 0..0f(16),
      message_code: 0..0f(16),

      sense_byte_8: 0..0ff(16),
      fill7: 0..0f(16),
      sense_byte_9: 0..0ff(16),
      sense_byte_10a: 0..0f(16),
      fill8: 0..0f(16),
      sense_byte_10b: 0..0f(16),
      sense_byte_11: 0..0ff(16),
      fill9: 0..0f(16),
      sense_byte_12: 0..0ff(16),
      sense_byte_13a: 0..0f(16),
      fill10: 0..0f(16),
      sense_byte_13b: 0..0f(16),
      sense_byte_14: 0..0ff(16),
      fill11: 0..0f(16),
      sense_byte_15: 0..0ff(16),
      sense_byte_16a: 0..0f(16),
      fill12: 0..0f(16),
      sense_byte_16b: 0..0f(16),
      sense_byte_17: 0..0ff(16),
      fill13: 0..0f(16),
      sense_byte_18: 0..0ff(16),
      sense_byte_19a: 0..0f(16),
      fill14: 0..0f(16),
      sense_byte_19b: 0..0f(16),
      sense_byte_20: 0..0ff(16),
      fill15: 0..0f(16),
      sense_byte_21: 0..0ff(16),
      sense_byte_22a: 0..0f(16),
      fill16: 0..0f(16),
      sense_byte_22b: 0..0f(16),
      sense_byte_23: 0..0ff(16),

    recend,


    iot$controller_status = packed record

{Word 17}
      fill1: 0..0f(16),
      controlware_type: 0..3,
      controlware_revision: 0..0f(16),
      current_record: 0..3f(16),

{Word 18}
      fill2: 0..0f(16),
      not_used1: 0..0f(16),
      normal_end: boolean,
      channel_parity: boolean,
      memory_parity: boolean,
      deadman_timeout: boolean,
      coupler_memory_parity: boolean,
      transfer_indicator: boolean,
      character_fill: boolean,
      not_used2: 0..1,

{Word 19}
      fill3: 0..0f(16),
      controlware_detected_error: boolean,
      ccc_status_byte_error: boolean,
      fsc_sequence_error: boolean,
      parity_error: boolean,
      bit_7: boolean,
      bit_6: boolean,
      bit_5: boolean,
      bit_4: boolean,
      bit_3: boolean,
      bit_2: boolean,
      bit_1: boolean,
      bit_0: boolean,

{Word 20}
      fill4: 0..0f(16),
      capacity: 0..3,
      always_ones: 0..3,
      ccc_serial_number: 0..0ff(16),
    recend,

    iot$detailed_status_9836_1 = packed record
        { CM word 1 }
      port: boolean,
      channel: 0 .. 07fff(16),
      starting_cylinder: 0 .. 0ffff(16),
      starting_track: 0 .. 0ffff(16),
      starting_sector: 0 .. 0ffff(16),
        { CM word 2 }
      unit: 0 .. 0ffff(16),
      request_retry: 0 .. 0ffff(16),
      failing_track: 0 .. 0ffff(16),
      failing_sector: 0 .. 0ffff(16),
        { CM word 3 }
      residual_word_count: 0 .. 0ffff(16),
      failing_function: 0 .. 0ffff(16),
      id: 0 .. 0ffff(16),
      error_id: 0 .. 0ffff(16),
        { CM word 4 }
      microcode_revision: 0 .. 0ffff(16),                  {upper code part number for 5831}
      ipi_channel_status_register: 0 .. 0ffff(16),
      ipi_channel_error_register: 0 .. 0ffff(16),
      lower_code_part_number: 0 .. 0ffff(16),              {5831 only}
        { CM word 5 }
      ipi_dma_error_register: 0 .. 0ffff(16),
      operational_status_register: 0 .. 0ffff(16),
      control_register: 0 .. 0ffff(16),
      actual_drive_type: 0 .. 0ffff(16),
      response_packets: ALIGNED [0 MOD 8] packed array [1 .. 128] OF 0 .. 0ff(16),
    recend,

    iot$9836_analyzed_response_pkt = record
      id23_present: boolean,
      id23_error_code: integer,
      id23_facility_status: integer,
      id24_present: boolean,
      id24_byte1_bit7: boolean,
      id24_byte1_bit6: boolean,
      id24_byte1_bit1: boolean,
      id24_byte1_not_bit7_or_6: boolean,
      id26_present: boolean,
      id26_byte1_bit4: boolean,
      id26_byte1_bit3: boolean,
      id26_byte2_bit6: boolean,
      id26_byte2_bit5: boolean,
      id26_byte2_bit4: boolean,
      id26_byte4_bit4: boolean,
      id26_byte10: 0 .. 0ff(16),       {byte 10(16) for 5831}
      id26_error_code: integer,        {from byte 0b(16), 21(16) for 5831}
      id29_present: boolean,
      id29_byte2_bit6: boolean,
      id29_byte2_bit5: boolean,
      id29_byte2_bit4: boolean,
      id29_byte2_bit3: boolean,
      id29_byte2_bit2: boolean,
      id29_byte6_bit7: boolean,
      id29_error_code: integer,        {from byte 0f(16), 21(16) for 5831}
    recend;

*DECK DECK=IOT$DISK_REQUEST EXPAND=FALSE
 CONST
    ioc$min_request_length = 5 * 8,
    ioc$command_count = 3;

  TYPE

    iot$disk_request = record
      request_index: ALIGNED [0 MOD 8] 0 .. ioc$request_heap_count,
      link: ALIGNED [2 MOD 8] ^iot$io_request,
      request_info: ALIGNED [0 MOD 8] iot$request_info,
      request: ALIGNED [0 MOD 8] iot$disk_pp_request,
    recend,

    iot$request_info = record
      preset_value: ALIGNED [0 MOD 8] amt$preset_value,
      command_index: 0 .. ioc$command_heap_count,
      command_group_count: 0 .. ioc$command_map_count,
      list_length: 0 .. mmc$max_rma_list_length,
      io_function: iot$io_function,
      request_type: iot$io_request_type,
      job_id: jmt$ijl_ordinal,
      system_file_id: dmt$system_file_id,
      byte_address: amt$file_byte_address,
      au_was_previously_written: boolean,
      list_p: ^mmt$rma_list,
      completion: ^iot$completion_status,
      next_track: iot$track,
      next_sector: iot$sector,
      data_maus: 0 .. dmc$max_maus_per_transfer,
      time: integer,
      io_identifier: mmt$io_identifier,
    recend,


    iot$disk_pp_request = packed record
      fill1: ALIGNED [0 MOD 8] 0 .. 0ffff(16),
      next_pp_request: ALIGNED [2 MOD 8] ^iot$io_request,
      fill2: 0 .. 0ffffffff(16),
      next_pp_request_rma: ost$real_memory_address,
      request_length: iot$request_length,
      logical_unit: iot$logical_unit,
      recovery: iot$request_recovery,
      interrupt: iot$interrupt,
      priority: iot$priority,
      alert_mask: iot$alert_conditions,
      pp_switch: boolean,
      fill5: 0 .. 1f(16),
      mau_count: 0 .. 3ff(16),
      cylinder: iot$cylinder,
      track: iot$track,
      sector: iot$sector,
      command: array [1 .. ioc$command_count] of iot$command,
    recend,


    iot$request_length = 0 .. 0ffff(16);

*copyc iot$io_function
*copyc ost$hardware_subranges
*copyc iot$logical_unit
*copyc iot$request_recovery
*copyc iot$alert_conditions
*copyc rmt$device_class
*copyc iot$cylinder
*copyc iot$command
*copyc mmt$rma_list
*copyc iot$request_heap_map
*copyc jmt$ijl_ordinal
*copyc amt$file_byte_address
*copyc dmt$system_file_id
*copyc amt$preset_value
*copyc iot$io_request_type
*copyc dmt$minimum_allocation_unit
*copyc iot$completion_status
*copyc iot$io_request
*copyc mmt$io_identifier
*DECK DECK=IOT$DISK_STATISTICS EXPAND=FALSE
{COMMON DECK IOT$DISK_STATISTICS}

?? PUSH (LISTEXT := ON) ??
{ Disk statistics codes.

*copyc cml$10395_11_failure_data
*copyc cml$fa7b4_d_failure_data
*copyc cml$7154_failure_data
*copyc cml$7155_1x_failure_data
*copyc cml$7165_2x_failure_data
*copyc cml$887_failure_data
*copyc cml$9836_1_failure_data
?? POP ??
*copyc iot$disk_request
{
{ DECK - IOT$DISK_STATISTICS
{

  CONST

{Symptom codes for 7154 and 7155:
    ioc$indeterminate = 1,
    ioc$input_channel_parity = 2,
    ioc$output_channel_parity = 3,
    ioc$controller_failure = 4,
    ioc$unit_failure = 5,
    ioc$function_timeout = 6,
    ioc$unit_is_reserved = 7,
    ioc$controller_is_reserved = 8,
    ioc$seek_failure = 9,
    ioc$checkword_error = 10,
    ioc$ram_parity = 11,
    ioc$incomplete_sector_transfer = 12,
    ioc$unit_not_ready = 15,
    ioc$unit_off_line_or_not_cabled = 16,
    ioc$read_only_switch_on = 17,
    ioc$ch_enable_off_or_not_cabled = 18,
    ioc$flawed_track = 19,
    ioc$flawed_sector = 20,
    ioc$sector_address_miscompare = 21,
    ioc$cylinder_address_miscompare = 22,
    ioc$lost_control_word = 23,
    ioc$iou_output_parity = 24,
    ioc$indeterminate_output_parity = 25,
    ioc$7155_software_failure = 26,
    ioc$address_error = 27,
    ioc$track_address_miscompare = 28,
    ioc$drive_not_selected = 29,
    ioc$controller_drive_interface = 30,
    ioc$host_if_integrity_error = 31,
    ioc$drive_if_integrity_error = 32,
    ioc$write_buffer_to_disk_error = 33,
    ioc$processor_instruction_timeo = 34,
    ioc$bm_register_parity_error = 35,
    ioc$write_verify_error = 36,
    ioc$7155_media_error = 37,
    ioc$conf_cylinder_is_flawed = 38,
    ioc$loading_controlware = 39,


{Symptom codes for System Action:
    ioc$controlware_reloaded = 1,
    ioc$controller_downed = 2,
    ioc$unit_downed = 3,


{Symptom codes for 10395_1 and isd_2:
    ioc$isd_indeterminate = 0,
    ioc$pp_timed_out_a_command = 1,
    ioc$control_module_reserved = 2,
    ioc$isd_software_failure = 3,
    ioc$drive_not_ready = 4,
    ioc$reloading_control_module = 5,
    ioc$control_module_reloaded = 6,
    ioc$executing_level_ii = 7,
    ioc$level_ii_passed = 8,
    ioc$drive_not_present = 9,
    ioc$media_failure = 10,
    ioc$function_failure_class_2 = 11,
    ioc$function_failure_class_3 = 12,
    ioc$input_ici_parity = 13,
    ioc$output_ici_parity_class_1 = 14,
    ioc$output_ici_parity_class_2 = 15,
    ioc$output_ici_parity_class_3 = 16,
    ioc$adapter_ram_parity = 17,
    ioc$adapter_buffer_parity = 18,
    ioc$adapter_rom_parity = 19,
    ioc$start_switch_not_depressed = 20,
    ioc$isi_parity = 21,
    ioc$output_isi_parity_class_1 = 22,
    ioc$output_isi_parity_class_3 = 23,
    ioc$seek_error = 24,
    ioc$unable_to_read_header = 25,
    ioc$unable_to_read_data = 26,
    ioc$isi_deadman_time_out = 27,
    ioc$cm_scheduler_parity = 28,
    ioc$cm_mpu_parity = 29,
    ioc$cm_rw_hardware_fault = 30,
    ioc$drive_voltage_fault = 31,
    ioc$over_temperature_fault = 32,
    ioc$invalid_bootstrap_error = 33,
    ioc$drive_write_protected = 34,
    ioc$incomplete_ici_transfer = 35,
    ioc$loopback_compare_error = 36,
    ioc$loopback_select_active = 37,
    ioc$loopback_attention = 38,
    ioc$loopback_check_failure = 39,
    ioc$isd_controller_failure = 40,
    ioc$adapter_failure = 41,
    ioc$drive_failure = 42,
    ioc$adapter_controlware_error = 43,
    ioc$i_host_if_integrity_error = 44,
    ioc$i_drive_if_integrity_error = 45,


{Symptom codes for 895:

{        Retry / Recoverered errors.
{        Valid for: (General Status = 900) AND (EDS word 19 =44A)

    ioc$895_storage_director_retry = 1,

{        Storage Director detected errors.
{        Valid for: (General Status = A10) OR
{                   (General Status = 900) AND (EDS word 19 =402))

    ioc$895_undocumented_format_msg = 10,
    ioc$895_invalid_command = 11,
    ioc$895_invalid_command_to_7165 = 12,
    ioc$895_ccw_count_too_small = 13,
    ioc$895_invalid_data_argument = 14,
    ioc$895_chaining_not_indicated = 16,
    ioc$895_command_mismatch = 17,
    ioc$895_defective_track_pointer = 18,
    ioc$895_device_status_1_not_exp = 19,
    ioc$895_index_missing = 20,
    ioc$895_unresettable_interrupt = 21,
    ioc$895_device_does_not_respond = 22,
    ioc$895_incomplete_set_sector = 23,
    ioc$895_head_address_miscompare = 24,
    ioc$895_invalid_device_status_1 = 25,
    ioc$895_device_not_ready = 26,
    ioc$895_track_addr_miscompare = 27,
    ioc$895_drive_motor_off = 28,
    ioc$895_seek_incomplete = 29,
    ioc$895_cyl_addr_miscompare = 30,
    ioc$895_unresettable_offset = 31,
    ioc$895_selective_reset = 32,
    ioc$895_sync_latch_failure = 33,
    ioc$895_micro_detected_check = 34,
    ioc$895_clock_stopped_check_1 = 35,
    ioc$895_alternate_sd_failure = 36,
    ioc$895_error_uncorr_by_ecc = 37,
    ioc$895_data_sync_unsuccessful = 38,
    ioc$895_error_corrected_by_ecc = 39,
    ioc$895_rcc_initiated_by_cca = 41,
    ioc$895_rcc1_not_successful = 42,
    ioc$895_rcc1_rcc2_unsuccessful = 43,
    ioc$895_invalid_ddc_tag_seq = 44,
    ioc$895_extra_rcc_required = 45,
    ioc$895_invalid_ddc_selection = 46,
    ioc$895_missing_end_op = 47,
    ioc$895_invalid_tag = 48,
    ioc$895_deselection = 49,
    ioc$895_no_controller_response = 50,
    ioc$895_controller_unavailable = 51,
    ioc$895_ecc_hardware_failure = 52,
    ioc$895_unexpected_end_op = 53,
    ioc$895_end_op_active = 54,
    ioc$895_command_reject = 55,
    ioc$895_intervention_req = 56,
    ioc$895_bus_out_parity = 57,
    ioc$895_equipment_check = 58,
    ioc$895_data_check = 59,
    ioc$895_overrun = 60,
    ioc$895_permanent_device_error = 61,
    ioc$895_end_of_cylinder = 62,
    ioc$895_message_to_operator = 63,
    ioc$895_no_record_found = 64,
    ioc$895_file_protected = 65,
    ioc$895_first_logged_error = 67,
    ioc$895_environmental_data = 68,
    ioc$895_path_error = 69,
    ioc$895_invalid_track_format = 70,
    ioc$895_undocumented_sd_resp = 79,

{          CYBER Channel Coupler detected errors.
{          Valid only for General Status = A00(16)

    ioc$895_no_request_in_cmd = 80,
    ioc$895_illegal_write = 81,
    ioc$895_fips_error = 82,
    ioc$895_full_empty_count = 83,
    ioc$895_address_miscompare = 92,
    ioc$895_no_request_in_poll = 93,
    ioc$895_select_in_received = 94,
    ioc$895_bus_in_parity = 95,
    ioc$895_read_path_parity = 96,
    ioc$895_write_path_parity = 97,
    ioc$895_incomplete_transfer = 98,
    ioc$895_output_chan_parity = 99,
    ioc$895_parity_err_on_input = 100,
    ioc$895_deadman_timeout = 101,
    ioc$895_memory_parity = 102,
    ioc$895_excess_data_xfered = 103,
    ioc$895_data_packing_wrong = 104,
    ioc$895_normal_end_not_set = 105,

{        PP detected errors.
{        Checked / reported only if above cases are not present.

    ioc$895_function_timeout = 121,
    ioc$895_soft_sectoring = 122,
    ioc$895_unit_soft_sectored = 123,
    ioc$895_interface_error = 126,
    ioc$895_kz_board_error = 127,
    ioc$895_kx_board_error = 128,
    ioc$895_channel_error = 129,
    ioc$895_media_failure = 131,
    ioc$895_incomplete_chan_xfer = 132,
    ioc$895_ccc_failure = 133,
    ioc$895_pp_ccc_data_integrity = 134,
    ioc$895_pp_drive_data_integrity = 135,
    ioc$895_seek_command_timeout = 136,
    ioc$895_indeterminate = 140,
    ioc$895_uncorrected_cm_error = 141,
    ioc$895_cm_reject = 142,
    ioc$895_invalid_cm_response = 143,
    ioc$895_cm_response_pe = 144,
    ioc$895_cmi_read_pe = 145,
    ioc$895_overflow_error = 146,
    ioc$895_jy_board_error = 147,
    ioc$895_iou_failure_st_err = 148,
    ioc$895_iou_failure_data_err = 149,
    ioc$895_tip_not_clear = 150,
    ioc$895_t_reg_not_empty = 151,

{Symptom codes for Hydra:

    ioc$hydra_indeterminate = 0,
    ioc$h_exec_level_i_diagnostics = 1,
    ioc$h_lev_i_diagnostics_passed = 2,
    ioc$h_exec_level_ii_diagnostics = 3,
    ioc$h_lev_ii_diagnostics_passed = 4,
    ioc$h_spindle_powered_up = 5,
    ioc$h_function_timeout = 6,
    ioc$h_channel_doesnt_go_empty = 7,
    ioc$h_incomplete_i4_transfer = 8,
    ioc$h_channel_init_error = 9,
    ioc$h_cannot_select_controller = 10,
    ioc$h_incorrect_controller = 11,
    ioc$h_pp_timed_out_a_command = 12,
    ioc$h_controller_reserved = 13,
    ioc$h_software_failure = 14,
    ioc$h_drive_not_ready = 15,
    ioc$h_uncorrected_cm_error = 16,
    ioc$h_cm_reject = 17,
    ioc$h_invalid_response_code = 18,
    ioc$h_cm_response_code_pe = 19,
    ioc$h_cmi_read_data_pe = 20,
    ioc$h_input_buffer_overflow = 21,
    ioc$h_jp_jy_data_parity_error = 22,
    ioc$h_bas_parity_error = 23,
    ioc$h_output_isi_parity = 24,
    ioc$h_jz_error = 25,
    ioc$h_jp_jy_error = 26,
    ioc$h_jn_jx_error = 27,
    ioc$h_incomplete_dma_transfer = 28,
    ioc$h_t_register_byte_count = 29,
    ioc$h_invalid_controller_status = 30,
    ioc$h_controller_interface_err = 31,
    ioc$h_seek_error = 32,
    ioc$h_unable_to_read_header = 33,
    ioc$h_header_miscompare = 34,
    ioc$h_unable_to_read_data = 35,
    ioc$h_disk_not_formatted = 36,
    ioc$h_diagnostic_fault_detected = 37,
    ioc$h_command_block_negated = 38,
    ioc$h_command_block_overwrite = 39,
    ioc$h_illegal_command_byte = 40,
    ioc$h_illegal_sec_seek_address = 41,
    ioc$h_illegal_pri_seek_address = 42,
    ioc$h_illegal_command_parameter = 43,
    ioc$h_io_illegal_write_error = 44,
    ioc$h_end_of_disk_reached = 45,
    ioc$h_illegal_device_number = 46,
    ioc$h_illegal_control_field = 47,
    ioc$h_io_illegal_disconnect = 48,
    ioc$h_isi_io_parity_error = 49,
    ioc$h_rw_sequencer_ram_parity = 50,
    ioc$h_mpu_parity_error = 51,
    ioc$h_ecc_fault = 52,
    ioc$h_voltage_fault = 53,
    ioc$h_write_transfer_count = 54,
    ioc$h_over_temperature_fault = 55,
    ioc$h_no_rw_sequencer_response = 56,
    ioc$h_invalid_rw_sequencer_rsp = 57,
    ioc$h_rw_sequencer_status_overw = 58,
    ioc$h_hydra_hardware_fault = 59,
    ioc$h_rw_sequencer_fault = 60,
    ioc$h_zerofill_timeout = 61,
    ioc$h_function_buffer_pe = 62,
    ioc$h_partial_sector_error = 63,
    ioc$h_disk_fault = 64,
    ioc$h_no_sector_pulse = 65,
    ioc$h_no_index_pulse = 66,
    ioc$h_cyl_head_sec_wrap_error = 67,
    ioc$h_no_disk_response = 68,
    ioc$h_pause_timeout = 69,
    ioc$h_tip_didnt_clear = 70,
    ioc$h_incomplete_cb_xfer = 71,
    ioc$h_incomplete_status_xfer = 72,
    ioc$h_sa_dropped_hydra_status = 73,
    ioc$h_incomplete_device_st_xfer = 74,
    ioc$h_sa_dropped_device_status = 75,
    ioc$h_incomplete_eri_xfer = 76,
    ioc$h_sa_dropped_err_reg_image = 77,
    ioc$h_incomplete_error_log_xfer = 78,
    ioc$h_sa_dropped_error_log = 79,
    ioc$h_sa_dropped_data = 80,
    ioc$h_host_if_integrity_error = 81,
    ioc$h_drive_if_integrity_error = 82,
    ioc$h_isi_input_error = 83,
    ioc$h_isi_timeout = 84,
    ioc$h_media_failure = 85,
    ioc$h_seek_error_retried = 86,
    ioc$h_power_up_complete = 87,
    ioc$h_reset_complete = 88,
    ioc$h_priority_override = 89,
    ioc$h_hydra_on_line = 90,
    ioc$h_sector_size_not_4096 = 91,
    ioc$h_not_same_host_id = 92,
    ioc$h_transfer_count_error = 93,

{Symptom codes for $9836_1:

    ioc$9836_1_indeterminate = 0,
    ioc$9836_1_function_timeout = 1,
    ioc$9836_1_ch_empty_when_act = 2,
    ioc$9836_1_period_c_error = 3,
    ioc$9836_1_upper_ici_parity = 4,
    ioc$9836_1_lower_ici_parity = 5,
    ioc$9836_1_iou_error = 6,
    ioc$9836_1_incomplete_i4_xfer = 7,
    ioc$9836_1_channel_not_empty = 8,
    ioc$9836_1_central_memory_error = 9,
    ioc$9836_1_invalid_cm_response = 10,
    ioc$9836_1_cm_response_error = 11,
    ioc$9836_1_cmi_read_parity = 12,
    ioc$9836_1_jy_data_error = 13,
    ioc$9836_1_bas_parity_error = 14,
    ioc$9836_1_lz_error = 15,
    ioc$9836_1_jy_error = 16,
    ioc$9836_1_lx_error = 17,
    ioc$9836_1_dma_test_failure = 18,
    ioc$9836_1_count_overflow = 19,
    ioc$9836_1_cant_select_cont = 20,
    ioc$9836_1_bit_sig_response_err = 21,
    ioc$9836_1_no_sync_in = 22,
    ioc$9836_1_sync_in_did_not_drop = 23,
    ioc$9836_1_ipi_sequence_error = 24,
    ioc$9836_1_upper_ipi_ch_parity = 25,
    ioc$9836_1_lower_ipi_ch_parity = 26,
    ioc$9836_1_slave_in_not_set = 27,
    ioc$9836_1_slave_in_not_drop= 28,
    ioc$9836_1_incomplete_transfer = 29,
    ioc$9836_1_ch_stayed_active = 30,
    ioc$9836_1_buffer_counter_e = 31,
    ioc$9836_1_sync_counter_error = 32,
    ioc$9836_1_lost_data = 33,
    ioc$9836_1_bus_parity = 34,
    ioc$9836_1_command_reject = 35,
    ioc$9836_1_sync_out_not_sync_in = 36,
    ioc$9836_1_bus_b_ack_incorrect = 37,
    ioc$9836_1_no_cont_response = 38,
    ioc$9836_1_ending_status_wrong = 39,
    ioc$9836_1_executing_cont_diag = 50,
    ioc$9836_1_cont_diag_passed = 51,
    ioc$9836_1_cont_diag_passed_2 = 52,
    ioc$9836_1_cont_alt_port_event = 53,
    ioc$9836_1_dr_alt_port_event = 54,
    ioc$9836_1_restoring_drive =55,
    ioc$9836_1_restore_complete = 56,
    ioc$9836_1_formatting_drive = 57,
    ioc$9836_1_format_complete = 58,
    ioc$9836_1_par_prot_disabled = 59,
    ioc$9836_1_controller_failure = 60,
    ioc$9836_1_drive_failure = 61,
    ioc$9836_1_media_failure = 62,
    ioc$9836_1_lrc_error = 70,
    ioc$9836_1_cont_intervention = 71,
    ioc$9836_1_cont_machine_exc = 72,
    ioc$9836_1_command_exception = 73,
    ioc$9836_1_microcode_exec_error = 74,
    ioc$9836_1_unexpected_response = 76,
    ioc$9836_1_drive_rsvd_other_p = 77,
    ioc$9836_1_controller_over_temp = 78,
    ioc$9836_1_drive_not_operable = 80,
    ioc$9836_1_drive_not_ready = 81,
    ioc$9836_1_drive_intervention = 82,
    ioc$9836_1_uncorr_data_ck = 85,
    ioc$9836_1_drive_fatal_error = 86,
    ioc$9836_1_hw_write_protect = 87,
    ioc$9836_1_drive_rsvd_other_c = 89,
    ioc$9836_1_drive_ecc_error = 91,
    ioc$9836_1_missing_sync = 92,
    ioc$9836_1_sector_not_found = 93,
    ioc$9836_1_drive_exception = 94,
    ioc$9836_1_no_unit_oper_resp = 95,
    ioc$9836_1_das_head_shift = 96,
    ioc$9836_1_ssd_battery_to_low = 97,
    ioc$9836_1_ssd_battery_test = 98,
    ioc$9836_1_ssd_battery_old = 99,
    ioc$9836_1_error_retry = 100,
    ioc$9836_1_data_retry = 101,
    ioc$9836_1_motion_retry = 102,
    ioc$9836_1_data_correction = 103,
    ioc$9836_1_soft_error = 104,
    ioc$9836_1_parity_dr_corr = 106,
    ioc$9836_1_pp_cont_data_integ = 110,
    ioc$9836_1_cm_drive_data_integ = 111,
    ioc$9836_1_software_failure = 120,
    ioc$9836_1_wrong_drive_config = 121,
    ioc$9836_1_defect_mgmt_failure = 130,
    ioc$9836_1_wrong_drive_type = 140,
    ioc$9836_1_drive_init_required = 141,
    ioc$9836_1_no_parallel_support = 142,


{Disk function codes:
    ioc$seek_function = 1,


{Logical_operation codes:
    ioc$log_read = 1,
    ioc$log_write = 2,
    ioc$log_write_initialize = 3,
    ioc$log_read_flaw_map = 4,
    ioc$log_initialize_sectors = 5,


    ioc$no_value = - 1;




  CONST
      { The '+10' is determined by the size of all fields in}
      { IOT$DISK_LOG_DATA excluding detailed_status.}
    ioc$disk_log_data_length = ioc$disk_detailed_status_length + 10;

  TYPE
    iot$disk_log_data = record
      pp_response: iot$pp_response,
      detailed_status: iot$common_disk_status,
      channel: cmt$physical_channel,
      equipment: 0 .. 0ff(16),
      logical_unit: iot$logical_unit,
      symptom_code: 0 .. 0ffff(16),
      disk_type: iot$unit_type,
      logical_operation: integer,
      controller_type: 0 .. 0ff(16),
      display_message: boolean,
      physical_unit: iot$physical_unit_number,
      failure_severity: 0 .. 0ff(16),
      diagnostic_code: 0 .. 0ffffffffff(16),
      isolation_code: 0 .. 0ff(16),
      actual_drive_type: 0 ..0ff(16),
      iou_number: dst$iou_number,
    recend;

  TYPE
    iot$disk_log_data_full = record
      request: iot$disk_request,
      resp: iot$disk_log_data,
      msg: string (63),
    recend;


*copyc iot$pp_response
*copyc iot$channel_number
*copyc iot$disk_detailed_status_844
*copyc iot$unit_type
*copyc iot$logical_unit
*copyc cmc$condition_limits
*copyc cmt$physical_channel
*copyc dst$iou_number

*DECK DECK=IOT$DISK_TYPE_TABLE EXPAND=FALSE
 CONST
    ioc$disk_type_count = 26;

  TYPE
    iot$disk_type_table = packed record
      unit_type: iot$unit_type,
      sectors_per_mau: iot$sectors_per_mau,
      sectors_per_track: iot$sectors_per_track,
      tracks_per_cylinder: iot$tracks_per_cylinder,
      cylinders_per_unit: iot$cylinders_per_unit,
      bytes_per_mau: iot$bytes_per_mau,
      mau_time: integer,
    recend,

    iot$sectors_per_mau = 1 .. 10,
    iot$sectors_per_track = 4 .. 80,
    iot$tracks_per_cylinder = 4 .. 80,
    iot$cylinders_per_unit = 500 .. 2620,
    iot$bytes_per_mau = 512 .. 8192;

*copyc iot$unit_type
*DECK DECK=IOT$DISK_USAGE EXPAND=FALSE

  TYPE
    iot$disk_pp_array = array [1 .. *] of ^ iot$disk_pp_usage,

    iot$disk_pp_usage = record
      last_response_time: integer,
      computed_data_transfer_time: integer,
      seek_and_latency_time: integer,
      streamed_req_count_read: integer,
      streamed_req_failed_count_read: integer,
      streamed_req_count_write: integer,
      streamed_req_failed_count_write: integer,
      iou_number: dst$iou_number,
      channel: cmt$physical_channel,
      path_usage: array [0 .. 1] of array [0 .. 7] of iot$path_usage
    recend,

    iot$disk_unit_array = array [1 .. *] of ^ iot$disk_unit_usage,

    iot$disk_unit_usage = record
      read_requests: integer,
      read_qtime: integer,
      read_mau_count: integer,
      write_requests: integer,
      write_qtime: integer,
      write_data_mau_count: integer,
      write_data_and_preset_maus: integer,
      swap_in_requests: integer,
      swap_in_qtime: integer,
      swap_in_mau_count: integer,
      swap_out_requests: integer,
      swap_out_qtime: integer,
      swap_out_data_mau_count: integer,
      swap_out_data_and_preset_maus: integer,
      streamed_request_possible: boolean,
      streamed_req_count_read: integer,
      streamed_req_failed_count_read: integer,
      streamed_req_count_write: integer,
      streamed_req_failed_count_write: integer,
      requests_causing_skipped_cyl: integer,
      total_cylinders_skipped: integer,
      current_cylinder: iot$cylinder,
      intermediate_errors: integer,
      recovered_errors: integer,
      unrecovered_errors: integer,
      iou_number: dst$iou_number,
      channel: cmt$physical_channel,
      equipment: cmt$physical_equipment_number,
      recorded_vsn: rmt$recorded_vsn,
      bytes_per_mau: iot$bytes_per_mau,
      unit_type: iot$unit_type,
      element_name: cmt$element_name,
      last_request_good: boolean,
      unit_configured: boolean,
      unit_used: boolean,
    recend,

    iot$path_usage = record
      read_requests: integer,
      read_maus: integer,
      write_requests: integer,
      written_and_preset_maus: integer,
      total_request_qtime: integer,
      intermediate_errors: integer,
      recovered_errors: integer,
      unrecovered_errors: integer,
      logical_unit: iot$logical_unit,
      bytes_per_mau: iot$bytes_per_mau,
      path_type: cmt$controller_type,
      path_configured: boolean,
      path_used: boolean,
    recend;

*copyc cmt$controller_type
*copyc cmt$element_name
*copyc cmt$physical_channel
*copyc cmt$physical_equipment_number
*copyc dst$iou_number
*copyc iot$cylinder
*copyc iot$disk_type_table
*copyc iot$logical_unit
*copyc iot$unit_type
*copyc rmt$recorded_vsn
*DECK DECK=IOT$DOWN_STATUS EXPAND=FALSE
TYPE
  iot$down_status = (ioc$no_change, ioc$channel_down, ioc$controller_down,
    ioc$unit_down, ioc$executing_diagnostics, ioc$diagnostics_completed);
*DECK DECK=IOT$ELEMENT_MODE EXPAND=FALSE

  TYPE
    iot$element_mode = record
      inhibit_allocation: iot$inhibit_allocation,
      read_write_mode: iot$read_write_mode,
    recend,

    iot$inhibit_allocation = boolean,
    iot$read_write_mode = (ioc$normal, ioc$read_only, ioc$write_only,
      ioc$idle);
*DECK DECK=IOT$ELEMENT_STATE EXPAND=FALSE

  TYPE
    iot$element_state = (ioc$on, ioc$off, ioc$maintenance);
*DECK DECK=IOT$ELEMENT_STATUS EXPAND=FALSE

  CONST
    ioc$max_maint_jobs = 4;

  TYPE
    iot$element_status = record
      element_state: iot$element_state,
      maintenance_count: iot$maintenance_count,
      fault_history: iot$fault_history,
    recend,

    iot$maintenance_count = 0 .. ioc$max_maint_jobs,

    iot$fault_history = record
      date_time_stamp: integer,
      maint_req_data: integer,
      io_status: integer,
    recend;

*copyc IOT$ELEMENT_STATE
*DECK DECK=IOT$FORMATTED_SERVER_RESPONSE EXPAND=FALSE

  TYPE
    iot$formatted_server_response = record
      request_id: rmt$rbt_request_id,
      case request_processed: boolean of
      = TRUE =
        case processed_request: rmt$rbt_request_type of
        = rmc$rbt_query =
          query: rmt$rbt_query_response,
        = rmc$rbt_mount =
          mount: rmt$rbt_mount_response,
        = rmc$rbt_dismount =
          dismount: rmt$rbt_dismount_response,
        = rmc$rbt_force_dismount =
          force_dismount: rmt$rbt_force_dismount_response,
        casend
      = FALSE = {retry request}
        server_event_code: ost$non_negative_integers,
        current_request: rmt$rbt_request_type,
        retry_delay_interval: ost$non_negative_integers,
        retry_limit: ost$positive_integers,
        server_messages: ^iot$robotic_server_messages,
        next_request {after limit exceeded} : rmt$rbt_request_type,
      casend,
    recend;

*copyc osd$integer_limits
*copyc iot$robotic_server_messages
*copyc rmt$rbt_dismount_response
*copyc rmt$rbt_force_dismount_response
*copyc rmt$rbt_mount_response
*copyc rmt$rbt_query_response
*copyc rmt$rbt_request_id
*copyc rmt$rbt_request_type
*DECK DECK=IOT$GENERAL_REQUEST EXPAND=FALSE

 TYPE
   iot$general_request = (ioc$mount_volume,
                          ioc$dismount_volume,
                          ioc$forced_volume_dismount);

*DECK DECK=IOT$GENERAL_REQUEST_RESULTS EXPAND=FALSE
*DECK DECK=IOT$HARDWARE_IDENTIFIER EXPAND=FALSE

  TYPE
    iot$hardware_identifier = integer;
*DECK DECK=IOT$IDLE_RESUME_ACTION EXPAND=FALSE

  TYPE
    iot$idle_resume_action = (ioc$ira_idle, ioc$ira_resume);
*DECK DECK=IOT$IMAGE_REQUEST EXPAND=FALSE

  TYPE

    iot$image_request = record
      io_request: iot$io_request,
      image_disk_request: iot$image_disk_request,
    recend,

    iot$image_disk_request = packed record
      fill1: ALIGNED [0 MOD 8] 0 .. 0ffff(16),
      next_pp_request: ^iot$io_request,
      fill2: 0 .. 0ffffffff(16),
      next_pp_request_rma: ost$real_memory_address,
      request_length: iot$request_length,
      logical_unit: iot$logical_unit,
      recovery: iot$request_recovery,
      interrupt: iot$interrupt,
      priority: iot$priority,
      alert_mask: iot$alert_conditions,
      pp_switch: boolean,
      fill5: 0 .. 7fff(16),
      cylinder: iot$cylinder,
      track: iot$track,
      sector: iot$sector,
    recend;


*copyc IOT$DISK_REQUEST
*copyc IOT$IO_REQUEST
*copyc OST$HARDWARE_SUBRANGES
*copyc IOT$LOGICAL_UNIT
*copyc IOT$REQUEST_RECOVERY
*copyc IOT$ALERT_CONDITIONS
*copyc RMT$DEVICE_CLASS
*copyc IOT$CYLINDER
*DECK DECK=IOT$IO_COMPLETION_TABLE EXPAND=FALSE
 TYPE
    cmt$io_completion_table_entry = record
      available: boolean,
      request_identification: cmt$subsystem_io_request_id,
      global_task_id: ost$global_task_id,
      io_status: cmt$subsystem_io_completion_sta,
      io_request_type: cmt$io_request,
      subsystem_response_p: ^cmt$os_subsystem_io_response,
      data_command_descriptors_p: ^cmt$data_command_descriptors,
      wired_unit_queue_request_p: ^cmt$wired_unit_queue_request,
      next_entry: ^cmt$io_completion_table_entry,
      entry_index: cmt$io_completion_queue_index,
      time_request_created: ost$time,
      job_name: jmt$system_supplied_name,
    recend,
    cmt$available_entries = string(cmc$max_subsystem_io_requests),
    cmt$io_completion_table_header = record
      available_entries: cmt$io_completion_queue_index,
      entries_in_use: cmt$io_completion_queue_index,
      recovery_action_required: cmt$io_completion_queue_index,
      table_lock: ost$signature_lock,
      entries_available: cmt$available_entries,
      responses_available: ^cmt$subsys_io_response_area,
    recend;

  TYPE
    cmt$io_completion_table = record
      header: cmt$io_completion_table_header,
      entries: array [1 .. cmc$max_subsystem_io_requests] of
        cmt$io_completion_table_entry,
    recend;

  TYPE
    cmt$ssiot_entry_information = array [1 .. * ] of cmt$ssiot_information,
    cmt$ssiot_information = record
      case keyword: cmt$ssiot_entry_field of
      = cmc$ssiote_io_status =
        io_status: cmt$subsystem_io_completion_sta,
      = cmc$ssiote_null_entry =
        ,
      = cmc$ssiote_request =
        io_type: cmt$io_request_type,
        element_name: cmt$element_name,
      = cmc$ssiote_request_created =
        time_request_created: ost$time,
      = cmc$ssiote_request_id =
        request_id: cmt$subsystem_io_request_id,
        subsystem_response_p: ^cmt$os_subsystem_io_response,
        data_command_descriptors_p: ^cmt$data_command_descriptors,
      = cmc$ssiote_wait_for_io_complete =
        wait_for_io_completion: cmt$wait_for_io_completion,
      = cmc$ssiote_wired_request =
        wired_request_p: ^cmt$wired_unit_queue_request,
      casend,
    recend,
    cmt$ssiot_entry_field = (cmc$ssiote_io_status, cmc$ssiote_request,
      cmc$ssiote_request_id, cmc$ssiote_dummy_3, cmc$ssiote_wired_request,
      cmc$ssiote_request_created,
      cmc$ssiote_dummy_14,
      cmc$ssiote_wait_for_io_complete, cmc$ssiote_null_entry);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$io_completion_queue_index
*copyc cmt$subsystem_io_request_id
*copyc cmt$subsystem_io_status
*copyc jmt$system_supplied_name
*copyc ost$global_task_id
*copyc iot$wired_unit_queue_request
*copyc cmt$io_request_type
*copyc cmt$element_name
*copyc ost$signature_lock
*copyc ost$time
*copyc ost$name
?? POP ??
*DECK DECK=IOT$IO_DISK_REQUEST EXPAND=FALSE

  TYPE
    iot$io_disk_request = record
      io_request: ALIGNED [0 MOD 8] iot$io_request,
      disk_request: ALIGNED [0 MOD 8] iot$disk_request,
    recend;

*copyc IOT$IO_REQUEST
*copyc IOT$DISK_REQUEST
*DECK DECK=IOT$IO_ERROR EXPAND=FALSE
  TYPE
    iot$io_error = (ioc$no_error, ioc$allocate_file_space, ioc$media_error, ioc$unrecovered_error,
      ioc$unrecovered_error_unit_down, ioc$server_allocation_error, ioc$server_has_terminated,
      ioc$error_on_init, ioc$unit_down_on_init);
*DECK DECK=IOT$IO_FUNCTION EXPAND=FALSE

{ DECK: IOT$IO_FUNCTION (Definitions for interface to physical IO requests)

  TYPE
    iot$io_function = (ioc$read_page, ioc$write_page, ioc$explicit_read,
      ioc$explicit_write, ioc$swap_in, ioc$swap_out, ioc$compare_swap,
      ioc$write_verify, ioc$read_uft, ioc$read_mass_storage,
      ioc$write_mass_storage, ioc$no_io, ioc$write_locked_page,
      ioc$keypoint_io, ioc$initialize_sectors, ioc$explicit_read_no_purge,
      ioc$read_for_server, ioc$read_from_client,
      ioc$write_for_server, ioc$write_to_client, ioc$allocate, ioc$read_ahead_on_server);
*DECK DECK=IOT$IO_ID EXPAND=FALSE

{ DECK: IOT$IO_ID


  CONST
*IF $true(osv$unix)
    ioc$max_tape_io_id = 7fffffff(16),
*ELSE
    ioc$max_tape_io_id = 0ffffffffffff(16),
*IFEND
    ioc$max_multiple_tape_requests =  3;

  TYPE
    iot$io_id = 0..ioc$max_tape_io_id;
*DECK DECK=IOT$IO_REQUEST EXPAND=FALSE

{ DECK: IOT$IO_REQUEST

  TYPE
    iot$io_request = record
      response_processor_p: ALIGNED [0 MOD 8] iot$response_processor,
      device_request_p: ^cell,
      pp_request_p: ^cell,
    recend,

    iot$response_processor = ^procedure (pp_response_p: ^iot$pp_response;
          detailed_status_p: ^iot$detailed_status;
          pp: 1 .. ioc$pp_count;
      VAR status: syt$monitor_status),

    iot$link = packed record
      fill1: ALIGNED [0 MOD 8] 0 .. 0ffff(16),
      next_pp_request: ^iot$io_request,
      fill2: 0 .. 0ffffffff(16),
      next_pp_request_rma: ost$real_memory_address,
    recend;

*copyc IOT$PP_RESPONSE
*copyc IOT$PP_INTERFACE_TABLE
*copyc syt$monitor_status
*DECK DECK=IOT$IO_REQUEST_TYPE EXPAND=FALSE

  TYPE
    iot$io_request_type = (ioc$pager_io, ioc$device_io);
*DECK DECK=IOT$IPI_TAPE_LOG_DATA EXPAND=FALSE

{ DECK: IOP$IPI_TAPE_LOG_DATA

{ Type definition for sequence passed by iop$tape_process_pp_response
{ to dsp$report_system_message. The procedure iop$log_tape_data converts
{ this sequence into one of type iot$ipi_statistic_data (IPI) or
{ iot$ccc_cart_statistic_data (Cartridge/CCC) which is passed
{ to procedure sfp$emit_statistic.

{ The following constant is the length of iot$ipi_tape_log_data excluding the
{ ipi_status or ccc_cart_status field. There are 3 spare bytes.

  CONST
    ioc$length_to_ipi_status = 16;

  TYPE
    iot$log_unit_type = (ioc$ipi_reel, ioc$ccc_cart);

  TYPE
    iot$ipi_tape_log_data = record
      logical_unit: iot$logical_unit,                        {2 bytes}
      iou_number: dst$iou_number,                            {1 byte}
      response_length: iot$response_length,                  {2 bytes}
      channel: cmt$physical_channel,                         {3 bytes}
      interface_error_code: iot$interface_error_code,        {2 bytes}
      controller_number: 0 .. 0ff(16),                       {1 byte}
      unit_number: 0 .. 0ff(16),                             {1 byte}
      spare: 0 .. 0ffffff(16),                               {3 bytes spare}
      case unit_type: iot$log_unit_type of                   {1 byte}
      = ioc$ipi_reel =
        ipi_status: ALIGNED [0 MOD 8] iot$ipi_tape_status,
      = ioc$ccc_cart =
        ccc_cart_status: ALIGNED [0 MOD 8] iot$ccc_cart_device_status,
      casend
    recend;

*copyc cmt$physical_channel
*copyc dst$iou_number
*copyc iot$ccc_cartridge_tape_status
*copyc iot$ipi_tape_status
*copyc iot$logical_unit
*copyc iot$pp_response
*DECK DECK=IOT$IPI_TAPE_STATUS EXPAND=FALSE

{ DECK: IOT$IPI_TAPE_STATUS

  CONST  { in bytes }
    ioc$ipi_tape_status_size = 3 * 8,  { length up to major status header }
    ioc$ipi_max_status_size = 256,  { includes major status }
    ioc$major_status_size = 10,
    ioc$min_ipi_total_resp_size = ioc$min_response_length + ioc$bid_area_size + ioc$ipi_tape_status_size;

  TYPE
    iot$ipi_tape_status = PACKED RECORD
      error_id: 0 .. 0ffff(16),               { see CONST below
      function_with_timeout: 0 .. 0ffff(16),
      ipi_status_register: 0 .. 0ffff(16),
      ipi_error_register: 0 .. 0ffff(16),
      down_status: 0 .. 0ffff(16),
      i4_dma_control_register: 0 .. 0ffff(16),
      i4_dma_operational_status_reg: 0 .. 0ffff(16),
      i4_dma_error_register: 0 .. 0ffff(16),
      special_status: iot$special_ipi_status,
      major_status_header: ALIGNED iot$ipi_major_status_header,
      major_status: iot$ipi_major_status,
      ipi_status: ARRAY [ioc$major_status_size + 1 .. ioc$ipi_max_status_size] OF 0 .. 0ff(16),
    RECEND;

  TYPE
    iot$special_ipi_status = PACKED RECORD
      length: 0 .. 0ff(16),   {02}
      parm: 0 .. 0ff(16),     {52(16)}
      beginning_of_media: boolean,
      end_of_media: boolean,
      media_present: boolean,
      logical_end_of_media: boolean,
      fill: 0 .. 3,
      density: boolean,        { F = 1600, T = 6250 }
      write_protect: boolean,  { F = ring in, T = ring out }
      fill1: 0 .. 0ffffffffff(16),
    RECEND,

    iot$ipi_major_status_header = PACKED RECORD
      length: 0 .. 0ffff(16),
      fill: 0 .. 0ffff(16),
      ipi_command: 0 .. 0ffff(16),
      slave_address: 0 .. 0ff(16),
      facility_address: 0 .. 0ff(16),
    RECEND,

    iot$ipi_major_status = PACKED RECORD
      command_exception: boolean,
      machine_exception: boolean,
      alternate_port_exception: boolean,
      intervention_required: boolean,
      microcode_exception: boolean,
      fill1: 0 .. 7,
      response_type: 0 .. 0f(16),    { see CONST below
      successful: boolean,
      incomplete: boolean,
      conditional_success: boolean,
      command_aborted: boolean,
    RECEND;

  CONST  {define constants for response_type in iot$ipi_major_status

    ioc$standard_command_completion = 1,
    ioc$asynchronous_response = 4,
    ioc$transfer_notification = 5;

  CONST  { define constants for error_id in iot$ipi_major_status

    ioc$ipi_indeterminate_error = 0,
    ioc$ipi_function_timeout = 1,
    ioc$chan_empty_when_act = 2,
    ioc$period_counter_error = 3,
    ioc$upper_ici_parity = 4,
    ioc$lower_ici_parity = 5,
    ioc$iou_error = 6,
    ioc$incomplete_i4_transfer = 7,
    ioc$channel_not_empty = 8,
    ioc$central_memory_error = 9,
    ioc$invalid_cm_resp_code = 10,
    ioc$cm_resp_code_parity = 11,
    ioc$cmi_read_data_parity = 12,
    ioc$jy_data_error = 13,
    ioc$bas_parity_error = 14,
    ioc$lz_error = 15,
    ioc$yj_error = 16,
    ioc$lx_error = 17,
    ioc$dma_test_mode_failure = 18,
    ioc$illegal_operation = 19,
    ioc$can_not_select_controller = 20,
    ioc$bit_sign_response_error = 21,
    ioc$no_sync_in = 22,
    ioc$sync_in_did_not_drop = 23,
    ioc$ipi_sequence_error = 24,
    ioc$upper_ipi_chan_parity = 25,
    ioc$lower_ipi_chan_parity = 26,
    ioc$slave_in_not_set = 27,
    ioc$slave_in_did_not_drop = 28,
    ioc$incomplete_transfer = 29,
    ioc$channel_stayed_active = 30,
    ioc$buffer_counter_error = 31,
    ioc$sync_counter_error = 32,
    ioc$lost_data = 33,
    ioc$bus_parity = 34,
    ioc$command_reject = 35,
    ioc$sync_outs_ne_sync_ins = 36,
    ioc$bus_b_ack_incorrect = 37,
    ioc$no_controller_interrupt = 38,
    ioc$ending_status_wrong = 39,
    ioc$slave_encoded_end_status = 40,
    ioc$executing_controller_diag = 50,
    ioc$controller_diag_passed = 51,
    ioc$hdw_corrected_errors = 52,
    ioc$ipi_controller_failure = 60,
    ioc$drive_failure = 61,
    ioc$internal_controller_error = 70,
    ioc$controller_intervention_req = 71,
    ioc$controller_mach_excep = 72,
    ioc$command_exception = 73,
    ioc$microcode_execution_error = 74,
    ioc$alternate_port_exception = 75,
    ioc$unexpected_response = 76,
    ioc$drive_reserved = 77,
    ioc$no_block_id_returned = 78,
    ioc$unexpected_class_2 = 79,
    ioc$drive_not_operational = 80,
    ioc$drive_not_ready = 81,
    ioc$drive_intervention_req = 82,
    ioc$physical_interface_check = 83,
    ioc$operation_timeout = 84,
    ioc$drive_machine_exception = 85,
    ioc$fatal_error = 86,
    ioc$drive_conditional_success = 87,
    ioc$position_lost = 88,
    ioc$drive_res_to_other_cont = 89,
    ioc$no_end_of_extent = 90,
    ioc$data_length_difference = 91,
    ioc$ipi_tape_medium_failure = 100,
    ioc$ipi_id_burst_error = 101,
    ioc$ipi_unable_to_set_agc = 102,
    ioc$master_slave_data_integrity = 110,
    ioc$slave_fac_data_integrity = 111,
    ioc$pp_detect_software_failure = 120,
    ioc$illegal_abnormal_status = 121,
    ioc$interface_error_wo_eid = 122,
    ioc$invalid_response_type = 123,
    ioc$no_alert_cond_set = 124,
    ioc$no_bits_in_abnormal_status = 125,
    ioc$max_ipi_error_id = 130;

  TYPE
    iot$analyzed_ipi_tape_response = PACKED RECORD
      id24_present: boolean,
      id26_present: boolean,
      id19_present: boolean,
      id29_present: boolean,
      id2a_present: boolean,
      sense_bytes_present: boolean,
      id24_byte1: ALIGNED iot$id24_byte1,
      id26_byte1: ALIGNED iot$id26_byte1,
      id26_byte2: ALIGNED iot$id26_byte2,
      id26_byte4: ALIGNED iot$id26_byte4,
      id2a_byte3: ALIGNED iot$id2a_byte3,
      sense_bytes: ALIGNED iot$mtc_sense_bytes,
    recend;

  TYPE
    iot$id24_byte1 = PACKED RECORD
      not_p_available: boolean,
      not_ready: boolean,
      not_p_avail_transition: boolean,
      not_ready_transition: boolean,
      fill1: 0 .. 1,
      corrupted_attr_table: boolean,
      addressee_busy: boolean,
      fill2: 0 .. 1,
    recend,

    iot$id26_byte1 = PACKED RECORD
      no_longer_busy: boolean,
      p_avail_transition: boolean,
      ready_transition: boolean,
      operation_timeout: boolean,
      physical_interface_check: boolean,
      fill1: 0 .. 7,
    recend,

    iot$id26_byte2 = PACKED RECORD
      fill1: 0 .. 1,
      data_check: boolean,
      fatal_error: boolean,
      hardware_write_protected: boolean,
      queue_full_check: boolean,
      fill2: 0 .. 7,
    recend,

    iot$id26_byte4 = PACKED RECORD
      error_log_full: boolean,
      fill1: 0 .. 3,
      position_lost: boolean,
      fill2: 0 .. 0f(16),
    recend,

    iot$id2a_byte3 = PACKED RECORD
      beginning_of_media: boolean,
      end_of_media: boolean,
      end_of_extent: boolean,
      block_length_difference: boolean,
      blank_tape: boolean,
      data_length_difference: boolean,
      fill1: 0 .. 3,
    recend,

    iot$mtc_sense_bytes = PACKED RECORD
      command_reject: boolean,             { byte 0
      intervention_required: boolean,
      bus_out_check: boolean,
      equip_check: boolean,
      data_check: boolean,
      overrun: boolean,
      wordcount_zero: boolean,
      fill1: 0 .. 1,
      noise: boolean,                      { byte 1
      mt_status_a: boolean,
      mt_status_b: boolean,
      fill2: 0 .. 1,
      beginning_of_tape: boolean,
      write_status: boolean,
      file_protect: boolean,    { true = ring out
      not_capable_of_density: boolean,
      track_in_error: 0 .. 0ff(16),        { byte 2
      r_w_vrc: boolean,                    { byte 3
      mte_lrc: boolean,
      skew_error: boolean,
      edc_crc: boolean,
      env_ecc: boolean,
      tu_set_1600_bpi: boolean,
      backward: boolean,
      c_p_compare: boolean,
      mp_hdw_error: boolean,               { byte 4
      reject_tu: boolean,
      end_of_tape: boolean,
      write_vrc: boolean,
      valid_tape_mark: boolean,
      lwr: boolean,
      tu_check: boolean,
      dead_par_track: boolean,
      fill3: 0 .. 3,                       { byte 5
      tm_check: boolean,
      id_burst_check: boolean,
      start_rd_check: boolean,
      partial_record: boolean,
      postamble_error: boolean,
      fill4: 0 .. 1,
      fill5: 0 .. 3,                       { byte 6
      dual_density: boolean,
      not_1600_bpi: boolean,
      model: 0 .. 0f(16),
      lamp_failure: boolean,               { byte 7
      tape_bottom: boolean,
      dsp_error: boolean,
      reset_key: boolean,
      dse: boolean,
      head_failure: boolean,
      micro_p_check: boolean,
      load_failure: boolean,
      ibg_detect: boolean,                 { byte 8
      compress_bytcnt_err: boolean,
      fill6: 0 .. 1,
      early_rd_back_check: boolean,
      control_burst_check: boolean,
      slow_rd_back_check: boolean,
      slow_end_read_check: boolean,
      velocity_retry: boolean,
      den_6250_correct: boolean,           { byte 9
      velocity_change: boolean,
      ch_buffer_check: boolean,
      crc_iii: boolean,
      den_6250_capable: boolean,
      fill7: 0 .. 3,
      tcu_reserved: boolean,
    recend;

?? PUSH(LISTEXT := ON) ??
*copyc iot$pp_response
*copyc iot$tape_device_status
?? POP ??
*DECK DECK=IOT$LIBRARY_DRIVE EXPAND=FALSE
*DECK DECK=IOT$LOCKWORD EXPAND=FALSE

  TYPE
    iot$lockword = packed record
      lock: boolean,
      fill: 0 .. 7fffffff(16),
      lock_owner: iot$lock_owner,
    recend,

    iot$lock_owner = packed record
      case cpu_lock: boolean of
      = TRUE =
        processor_id: boolean,
        module_id: 0 .. 7fff(16),
        condition_handler: 0 .. 7fff(16),
      = FALSE =
        fill: 0 .. 07fff(16),
        pp_number: iot$pp_number,
      casend
    recend;

*copyc IOT$PP_NUMBER
*DECK DECK=IOT$LOGICAL_UNIT EXPAND=FALSE

{ DECK: IOT$LOGICAL_UNIT

  CONST
    ioc$max_unit_number = 0ffff(16);

  TYPE
    iot$logical_unit = 0 .. ioc$max_unit_number;
*DECK DECK=IOT$MAINFRAME_ID EXPAND=FALSE

  TYPE
    iot$mainframe_id = integer;
*DECK DECK=IOT$MANAGED_DENSITIES EXPAND=FALSE
  TYPE
    iot$managed_densities = set of rmt$density;

*copyc rmt$density
*DECK DECK=IOT$MEDIA_REQUEST EXPAND=FALSE

 TYPE
   iot$media_request = RECORD
     CASE key: iot$general_request OF
     = ioc$mount_volume =
       ,
     = ioc$dismount_volume =
       dismount_element: cmt$element_name,
     = ioc$forced_volume_dismount =
       force_dismount_element: cmt$element_name,
     CASEND
   RECEND;

*copyc iot$general_request
*copyc cmt$element_name
*DECK DECK=IOT$MEDIA_REQUEST_ENTRY EXPAND=FALSE
*DECK DECK=IOT$MEDIA_REQUEST_RESULTS EXPAND=FALSE

 TYPE
   iot$media_request_results = RECORD
     CASE key: iot$general_request_results OF
     = ioc$mount_volume_complete =
       mount_element: cmt$element_name,
     = ioc$dismount_volume_complete =
       ,
     = ioc$force_vol_dismount_complete =
       ,
     = ioc$request_not_complete =
       present_queue_type: rmt$queue_type,
     CASEND
   RECEND;

*copyc cmt$element_name
*copyc iot$general_request_results
*copyc rmt$queue_type
*DECK DECK=IOT$MONITOR_REQUEST_BLOCK EXPAND=FALSE
     TYPE
        iot$monitor_request_block = RECORD
                 request_code: ALIGNED [0 MOD 8] syt$monitor_request_code,
                 status: syt$monitor_status,
                 CASE subsystem_request_code: iot$request_code OF
                    =ioc$queue_io_request=
                         io_request_p: ^iot$io_request,
                    =ioc$unlock_rma_list=
                         wired_request: ^cmt$max_wired_unit_queue_req,
                 CASEND,
                                        RECEND;

      TYPE
         iot$request_code = (ioc$queue_io_request,
              ioc$request_d2, ioc$request_d3,
              ioc$request_d4, ioc$request_d5,
              ioc$request_d6, ioc$request_d7,
              ioc$unlock_rma_list);

??PUSH (LISTEXT := ON)??
*copyc iot$io_request
*copyc syc$monitor_request_codes
*copyc syt$monitor_status
*copyc iot$wired_unit_queue_request
*copyc ost$global_task_id
??POP??
*DECK DECK=IOT$MOVED_RESPONSE_BUFFER EXPAND=FALSE

  TYPE

    iot$moved_response_buffer = record
      case word_move: boolean of
      = TRUE =
        bytes: ALIGNED [0 MOD 8] array [0 .. ioc$min_response_length - 1] of
          ost$byte,
      = FALSE =
        response: ALIGNED [0 MOD 8] iot$pp_response,
      casend,
    recend;

*copyc OST$HARDWARE_SUBRANGES
*copyc IOT$PP_RESPONSE
*DECK DECK=IOT$NEW_VSNS_ONLINE EXPAND=FALSE

 TYPE
  iot$new_vsns_online = ^ARRAY [1 .. *] of iot$new_vsns_online_entry,

  iot$new_vsns_online_entry = RECORD
    rvsn: rmt$recorded_vsn,
    unit_type: iot$unit_type,
  RECEND;

*copyc iot$unit_type
*copyc rmt$recorded_vsn
*DECK DECK=IOT$NO_OF_TAPE_UNITS EXPAND=FALSE

  TYPE
    iot$no_of_tape_units = 0..ioc$max_number_tape_units;

*copyc IOC$MAX_NUM_TAPE_UNITS
*DECK DECK=IOT$NUMBER_OF_REQUESTS EXPAND=FALSE

  TYPE

    iot$number_of_requests = 1 .. 500,
    iot$commands_per_request = 1 .. 65535;
*DECK DECK=IOT$OPERATOR_ASSIGNMENT_TYPE EXPAND=FALSE

  TYPE
    iot$operator_assignment_type = (ioc$unknown_assignment_type,
                                    ioc$expecting_manual_assignment,
                                    ioc$expecting_auto_assignment);

*DECK DECK=IOT$PAGEABLE_TAPE_REQUESTS EXPAND=FALSE

{ DECK: IOT$PAGEABLE_TAPE_REQUESTS


  TYPE
    iot$pageable_tape_requests = ARRAY [1 .. ioc$max_multiple_tape_requests + 1] OF
          iot$pageable_tape_request_entry;

  TYPE
    iot$pageable_tape_request_entry = RECORD
      slot_in_use: boolean,
      tape_request_p: ^iot$tape_request,
      pp_response_p: ^iot$tape_collected_pp_response,
    RECEND;

?? PUSH(LISTEXT := ON) ??
*copyc iot$tape_collected_pp_response
?? POP ??

*DECK DECK=IOT$PP_INTERFACE_TABLE EXPAND=FALSE

{ DECK: IOT$PP_INTERFACE_TABLE

  CONST
    ioc$extra_logical_pp = 10,
    ioc$pp_count = (cmc$max_pp_per_iou * dsc$max_number_of_ious) +
          ioc$extra_logical_pp,
    ioc$communication_buffer_length = 768,
    ioc$pp_interface_table_lock_bit = 63,
    ioc$response_buffer_length = 200,
    ioc$response_buffer_length_b = ioc$response_buffer_length * 8;

  TYPE
    iot$pp_interface_table = packed record
      pp_number: ALIGNED [0 MOD 512] iot$pp_number,
      first_logical_unit: iot$logical_unit,
      number_of_units: iot$logical_unit,
      active_check: boolean,
      idle_request: boolean,
      resume_request: boolean,
      idle_status: boolean,
      fill1: 0 .. 0f(16),
      fill12: 0 .. 7f(16),
      lock: boolean,
      interrupt_register_rma: ALIGNED [0 MOD 8] ost$real_memory_address,
      channel_interlock_rma: ost$real_memory_address,
      fill2: 0 .. 0ffff(16),
      communication_buffer_length: iot$communication_buffer_length,
      communication_buffer_rma: ost$real_memory_address,
      lockword: ALIGNED [0 MOD 8] iot$lockword,
      fill3: 0 .. 0ffff(16),
      pp_request_queue: ALIGNED [2 MOD 8] ^iot$io_request,
      fill4: 0 .. 0ffffffff(16),
      pp_request_queue_rma: ALIGNED [4 MOD 8] ost$real_memory_address,
      fill5: 0 .. 0ffff(16),
      response_buffer: ^iot$response_buffer,
      fill10: 0 .. 0ffffffff(16),
      fill11: 0 .. 0ffffffff(16),
      fill6: ALIGNED [0 MOD 8] 0 .. 0ffffffff(16),
      response_buffer_rma: ost$real_memory_address,
      fill7: 0 .. 0ffffffffffff(16),
      inn: iot$response_buffer_offset,
      fill8: 0 .. 0ffffffffffff(16),
      out: iot$response_buffer_offset,
      fill9: 0 .. 0ffffffffffff(16),
      limit: iot$response_buffer_offset,
      unit_descriptors: ALIGNED [0 MOD 8] iot$unit_descriptors,
    recend,

    iot$unit_descriptors = array [ * ] of iot$unit_descriptor_entry,

    iot$unit_descriptor_entry = packed record
      logical_unit: ALIGNED [0 MOD 8] iot$logical_unit,
      unit_interface_table: ^iot$unit_interface_table,
      physical_path: ALIGNED [0 MOD 8] iot$physical_path,
      unit_interface_table_rma: ost$real_memory_address,
    recend,

    iot$communication_buffer = packed record
      fill1: 0 .. 7fffffff(16),
      slave: boolean,
      partner_pp: ost$real_memory_address,
      controlware_command: iot$command,
      control_module_command: iot$command,
      fill2: 0 .. 0ffffffff(16),
      overlay_rma: ost$real_memory_address,
      fill3: integer,
      fill4: integer,
      fill5: integer,
      fill6: integer,
      pp_usage: ALIGNED [0 MOD 8] array [1 .. ioc$communication_buffer_length]
            of ost$word,
    recend,
    iot$commun_buffer_template = record
      cb: ALIGNED [0 MOD 65000] iot$communication_buffer,
    recend,

    iot$communication_buffer_length = 0 .. 0ffff(16),
    iot$response_buffer = array [0 .. (ioc$response_buffer_length_b - 1)]
          of ost$byte,

{ 800 = 8 * ioc$response_buffer_length.

    iot$response_buffer_offset = 0 .. 0ffff(16),
    iot$response_buffer_template = record
      response_buffer: ALIGNED [0 MOD 65000] iot$response_buffer,
    recend,

    iot$physical_path = packed record
      channel_number: 0 .. 0ff(16), { 8 bits }
      port: 0 .. 3, { 2 bit  }
      controller_number: 0 .. 3f(16), { 6 bits }
      storage_directory_address: 0 .. 7, { 3 bits }
      physical_unit_number: 0 .. 1fff(16), { 13 bits}
    recend;

*copyc cmc$max_pp_per_iou
*copyc iot$pp_number
*copyc iot$logical_unit
*copyc dsc$max_number_of_ious
*copyc ost$hardware_subranges
*copyc iot$lockword
*copyc iot$io_request
*copyc iot$unit_interface_table
*copyc iot$command
*copyc mmt$rma_list
*DECK DECK=IOT$PP_NUMBER EXPAND=FALSE

{ DECK: IOT$PP_NUMBER

  TYPE
    iot$pp_number = 0 .. 0ffff(16);
*DECK DECK=IOT$PP_RESPONSE EXPAND=FALSE

{ DECK: IOT$PP_RESPONSE

  CONST
    ioc$min_response_length = 5 * 8,
    ioc$max_response_length = 49 * 8,
    ioc$detailed_status_length_b = (ioc$max_response_length -
      ioc$min_response_length),
    ioc$detailed_status_length = ioc$detailed_status_length_b DIV 8,
    ioc$disk_detailed_status_length = 44,
    ioc$disk_detailed_status_words = ioc$disk_detailed_status_length * 4,
    ioc$unsolicited_response = 0,
    ioc$intermediate_response = 1,
    ioc$normal_response = 2,
    ioc$abnormal_response = 3,
    ioc$recovered_error = 1;

  TYPE
    iot$short_response = packed record
      flags: ALIGNED [0 MOD 8] iot$short_response_flags,
      request: ^iot$io_request,
    recend,

    iot$short_response_flags = packed record
      fill1: 0 .. 1,
      one_word_response: boolean,
      fill2: 0 .. 3fff(16),
    recend,


    iot$pp_response = packed record
      fill1: ALIGNED [0 MOD 8] 0 .. 0ffff(16),
      request: ^iot$io_request,
      fill2: 0 .. 0ffffffff(16),
      request_rma: ost$real_memory_address,
      response_length: iot$response_length,
      logical_unit: iot$logical_unit,
      recovery: iot$request_recovery,
      interrupt: iot$interrupt,
      priority: iot$priority,
      alert_mask: iot$alert_conditions,
      abnormal_status: iot$abnormal_status,
      interface_error_code: iot$interface_error_code,
      response_code: iot$response_code,
      unsolicited_response_code: iot$unsolicited_response_code,
      alert_conditions: iot$alert_conditions,
      transfer_count: iot$transfer_count,
      last_command: ost$real_memory_address,
    recend,

    iot$detailed_status = SEQ (REP ioc$detailed_status_length of ost$word),

    iot$detailed = record
      CASE word_move: boolean OF
      = TRUE =
        bytes: ALIGNED [0 MOD 8]  ARRAY [0 .. ioc$detailed_status_length_b - 1]
              OF ost$byte,
      = FALSE =
        detailed_status: ALIGNED [0 MOD 8]  iot$detailed_status,
      CASEND,
    recend,

    iot$detailed_seq = record
      detailed_status: ALIGNED [0 MOD 8]  iot$detailed_status,
    recend,


    iot$response_length = 0 .. 0ffff(16),

    iot$abnormal_status = packed record
      abnormal_alert: boolean,
      interface_error: boolean,
      forced_termination: boolean,
      channel_error: boolean,
      data_overrun: boolean,
      recording_medium_error: boolean,
      hardware_malfunction: boolean,
      intervention_required: boolean,
      function_timeout: boolean,
      output_channel_parity: boolean,
      fill: 0 .. 03f(16),
    recend,

    iot$interface_error_code = 0 .. 0ffff(16),

    iot$response_code = packed record
      primary_response: 0 .. 3,
      secondary_response: 0 .. 3,
      future: 0 .. 0f(16),
    recend,

    iot$unsolicited_response_code = 0 .. 0ff(16);

*copyc iot$io_request
*copyc ost$hardware_subranges
*copyc iot$logical_unit
*copyc iot$request_recovery
*copyc iot$alert_conditions
*copyc iot$transfer_count
*DECK DECK=IOT$PP_TABLE EXPAND=FALSE
*DECK DECK=IOT$PVA_LIST EXPAND=FALSE
 TYPE
    iot$pva_list = array [1 .. * ] of iot$pva_list_information,
    iot$pva_list_information = record
      address: ^cell,
      length: ost$segment_length,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
?? POP ??
*DECK DECK=IOT$QUEUE_INFO EXPAND=FALSE
*DECK DECK=IOT$RB_DEVICE_IO EXPAND=FALSE

  TYPE
    iot$rb_device_io = packed record
      request_code: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      pva: ^cell,
      length: ost$byte_count,
      io_function: iot$io_function,
      device_address: dmt$ms_logical_device_address,
      completion: ^iot$completion_status,
    recend;

*copyc SYC$MONITOR_REQUEST_CODES
*copyc OST$HARDWARE_SUBRANGES
*copyc IOT$IO_FUNCTION
*copyc SYT$MONITOR_REQUEST_CODE
*copyc DMT$MS_LOGICAL_DEVICE_ADDRESS
*copyc IOT$COMPLETION_STATUS
*DECK DECK=IOT$RB_TRANSLATE_BYTE_ADDRESS EXPAND=FALSE

  TYPE
    iot$rb_translate_byte_address = packed record
      request_code: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      system_file_id: dmt$system_file_id,
      file_byte_address: amt$file_byte_address,
      length: ost$byte_count,
      device_address: dmt$ms_logical_device_address,
    recend;

*copyc SYC$MONITOR_REQUEST_CODES
*copyc OST$HARDWARE_SUBRANGES
*copyc DMT$SYSTEM_FILE_ID
*copyc SYT$MONITOR_REQUEST_CODE
*copyc DMT$MS_LOGICAL_DEVICE_ADDRESS
*copyc AMT$FILE_BYTE_ADDRESS
*DECK DECK=IOT$READ_TAPE_DESCRIPTION EXPAND=FALSE
  TYPE
     iot$read_tape_description = array[iot$tape_block_count] of
        iot$read_block_descriptor;

  TYPE
     iot$read_block_descriptor = PACKED RECORD
        block_transfer_length: ALIGNED [0 MOD 8] ^iot$tape_transfer_count,
      fill: 0..0ffff(16),
        buffer_area: ^cell,
        fill2: 0..0ffff(16),
     RECEND,

{ NOTE - The store transfer count buffers must all be contained in the same
{ memory page if a read request is issued with multiple blocks.
{ See procedure mmp$build_lock_rma_list_tape.

      iot$tape_transfer_count = PACKED RECORD
        character_fill: BOOLEAN,
        fill: 0..7fffffff(16),
        length: ost$segment_offset,
      RECEND;

*copyc IOT$TAPE_BLOCK_COUNT
*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=IOT$REASSIGN_DEVICE_CONTROL EXPAND=FALSE

  TYPE
    iot$reassign_device_control = RECORD
      CASE command_allowed: boolean OF

        = TRUE =
          command_entered: boolean,
          global_task_id: ost$global_task_id,

        = FALSE =
           ,

      CASEND,
    RECEND;

*copyc ost$global_task_id
*DECK DECK=IOT$REQUESTED_SERVER_MESSAGES EXPAND=FALSE
  TYPE
    iot$requested_server_messages = set of iot$server_message_type;

*copyc iot$server_message_type
*DECK DECK=IOT$REQUESTED_VOLUME_ATTRIBUTES EXPAND=FALSE
  TYPE

    iot$requested_volume_attributes = record
      account: avt$account_name,
      family: ost$family_name,
      project: avt$project_name,
      removable_media_group: ost$name,
      removable_media_location: ost$name,
      slot: ost$name,
      user: ost$user_name,
    recend;

*copyc ost$name
*copyc avt$account_name
*copyc avt$project_name
*copyc ost$name
*copyc ost$user_identification
*DECK DECK=IOT$REQUESTED_VSN_LIST_ENTRY EXPAND=FALSE

  TYPE
    iot$requested_vsn_list_entry = record
      ssn: jmt$system_supplied_name,
      sfid: dmt$system_file_id,
      path_handle_name: fst$path_handle_name,
      global_file_name: dmt$global_file_name,
      forward_link: ^iot$requested_vsn_list_entry,
      backward_link: ^iot$requested_vsn_list_entry,
      vsn_state: iot$vsn_assignment_state,
      gtid: ost$global_task_id,
      assigned_element_name: ost$name,
      assignment_terminated: boolean,
      recovery_assignment: boolean,
      message: string (osc$max_string_size),
      time_of_mount_request: ost$hms_time,
      operator_assignment_type: iot$operator_assignment_type,
      next_in_vsn_queue: ^iot$requested_vsn_list_entry,
      previous_in_vsn_queue: ^iot$requested_vsn_list_entry,
      current_vsn_p: ^iot$vsn_entry,
      first_vsn_entry_p: ^iot$vsn_entry,
      last_vsn_entry_p: ^iot$vsn_entry,
      requested_tape_characteristics: iot$tape_characteristics,
      requested_volume_attributes: iot$requested_volume_attributes,
      robotic_communication: ^iot$robotic_communication,
    recend;


  TYPE
    iot$vsn_entry = record
      rvsn: rmt$recorded_vsn,
      evsn: rmt$external_vsn,
      next_vsn_p: ^iot$vsn_entry,
      previous_vsn_p: ^iot$vsn_entry,
    recend;


*copyc amt$internal_code
*copyc amt$label_type
*copyc amt$local_file_name
*copyc dmt$global_file_name
*copyc dmt$system_file_id
*copyc fst$path_handle_name
*copyc iot$operator_assignment_type
*copyc iot$requested_volume_attributes
*copyc iot$robotic_communication
*copyc iot$tape_characteristics
*copyc iot$vsn_assignment_state
*copyc jmt$system_supplied_name
*copyc ost$global_task_id
*copyc ost$name
*copyc ost$string
*copyc ost$time
*copyc rmt$density
*copyc rmt$external_vsn
*copyc rmt$recorded_vsn

*DECK DECK=IOT$REQUEST_HEAP_MAP EXPAND=FALSE
 CONST
    ioc$request_heap_count = 255,
    ioc$command_heap_count = 4000,
    ioc$command_group = 1,
    ioc$command_map_count = (ioc$command_heap_count DIV ioc$command_group);

  TYPE
    iot$request_heap_map = packed array [1 .. ioc$request_heap_count] of
      boolean,
    iot$request_heap = array [1 .. ioc$request_heap_count] of
      iot$io_disk_request,
    iot$command_heap_map = packed array [1 .. ioc$command_map_count] of
      boolean,
    iot$command_heap = array [1 .. ioc$command_heap_count] of
      mmt$rma_list_entry;

*copyc iot$io_disk_request
*copyc mmt$rma_list
*DECK DECK=IOT$REQUEST_INFO EXPAND=FALSE

  TYPE
    iot$request_info = record
      case request_type: iot$io_request_type of
      = ioc$pager_io =
        job_id: jmt$ajl_ordinal,
        system_file_id: dmt$system_file_id,
      = ioc$device_io =
        completion: ^iot$completion_status,
      casend
    recend;

*copyc IOT$IO_REQUEST_TYPE
*copyc JMT$AJL_ORDINAL
*copyc DMT$SYSTEM_FILE_ID
*copyc IOT$COMPLETION_STATUS
*DECK DECK=IOT$REQUEST_LENGTHS EXPAND=FALSE
 TYPE
    iot$unit_request_length = 0 .. 0ffff(16),
    iot$pp_request_length = 0 .. 0ffff(16);
*DECK DECK=IOT$REQUEST_RECOVERY EXPAND=FALSE

  TYPE
    iot$request_recovery = (ioc$attempt_recovery, ioc$terminate_at_error,
      ioc$rec_reserved, ioc$continue_at_error),
    iot$interrupt = packed record
      value: boolean,
      port_number: iot$port_number,
    recend,
    iot$priority = 0 .. 0ff(16),
    iot$port_number = 0 .. 1f(16);
*DECK DECK=IOT$ROBOTIC_COMMUNICATION EXPAND=FALSE

  TYPE
    iot$robotic_communication = record
      client_request: rmt$rbt_request,
      requesting_task: ost$global_task_id,
      server_name: ost$name,
      case server_received_request: boolean of
      = TRUE =
        case server_response_received: boolean of
        = TRUE =
          server_response: iot$formatted_server_response,
        = FALSE =
        casend,
      = FALSE =
      casend,
    recend;

*copyc ost$name
*copyc ost$global_task_id
*copyc rmt$rbt_request
*copyc iot$formatted_server_response

*DECK DECK=IOT$ROBOTIC_SERVER_ATTRIBUTES EXPAND=FALSE
  TYPE
    iot$robotic_server_attributes = record
      supported_requests: rmt$rbt_supported_requests,
      timeout {in milliseconds} : ost$positive_integers,
    recend;

*copyc osd$integer_limits
*copyc rmt$rbt_supported_requests
*DECK DECK=IOT$ROBOTIC_SERVER_ENTRY EXPAND=FALSE

  TYPE
    iot$robotic_server_entry = record
      server_name: ost$name,
      managed_elements_p: ^array [1 .. * ] of cmt$element_name,
      managed_densities: iot$managed_densities,
      server_attributes: iot$robotic_server_attributes,
      server_job_name: jmt$system_supplied_name,
      waiting_tasks: array [1 .. ioc$max_tasks_per_server] of
            ost$global_task_id,
    recend;

*copyc cmt$element_name
*copyc ioc$max_tasks_per_server
*copyc iot$managed_densities
*copyc iot$robotic_server_attributes
*copyc jmt$system_supplied_name
*copyc ost$global_task_id
*copyc ost$name

*DECK DECK=IOT$ROBOTIC_SERVER_INDEX EXPAND=FALSE
  TYPE
    iot$robotic_server_index = 1 .. ioc$max_server_index;

*copyc ioc$max_server_index
*DECK DECK=IOT$ROBOTIC_SERVER_MESSAGES EXPAND=FALSE
  TYPE
    iot$robotic_server_messages = record
      requested_messages: iot$requested_server_messages,
      job_log: iot$conditional_server_message,
      job_status_display: iot$conditional_server_message,
      operator_action: iot$conditional_server_message,
      system_log: iot$conditional_server_message,
    recend;

*copyc iot$conditional_server_message
*copyc iot$requested_server_messages
*DECK DECK=IOT$RVL_ENTRY_INFORMATION EXPAND=FALSE

TYPE
  iot$rvl_entry_information = RECORD
    null_entry: boolean,
    ssn: jmt$system_supplied_name,
    sfid: dmt$system_file_id,
    path_handle_name: fst$path_handle_name,
    vsn_state: iot$vsn_assignment_state,
    gtid: ost$global_task_id,
    assigned_element_name: ost$name,
    time_of_mount_request : ost$hms_time,
    operator_assignment_type: iot$operator_assignment_type,
    current_vsn: rmt$external_vsn,
    previous_vsn: rmt$external_vsn,
    next_vsn: rmt$external_vsn,
    requested_tape_characteristics: iot$tape_characteristics,
    requested_volume_attributes: iot$requested_volume_attributes,
  RECEND;


*copyc dmt$system_file_id
*copyc fst$path_handle_name
*copyc iot$operator_assignment_type
*copyc iot$requested_volume_attributes
*copyc iot$tape_characteristics
*copyc iot$vsn_assignment_state
*copyc jmt$system_supplied_name
*copyc ost$global_task_id
*copyc ost$name
*copyc ost$time
*copyc rmt$external_vsn

*DECK DECK=IOT$SEN EXPAND=FALSE

  TYPE
    iot$sen = 0 .. 999;
*DECK DECK=IOT$SERVER_MESSAGE_TYPE EXPAND=FALSE
  TYPE
    iot$server_message_type = (ioc$job_log_message, ioc$job_status_message,
          ioc$operator_action_message, ioc$system_log_message);

*DECK DECK=IOT$SET_ASSIGNMENT_RESULTS EXPAND=FALSE

  TYPE
    iot$set_assignment_results = (ioc$volume_assigned,
                                  ioc$volume_not_online,
                                  ioc$manual_assignment_required);

*DECK DECK=IOT$SUBSYSTEM_IO_REQUEST EXPAND=FALSE
      TYPE
         iot$subsystem_io_request = RECORD
                  device_type: iot$unit_type,
                  request_p: ^cell,
                                       RECEND;

??PUSH (LISTEXT:= ON)??
*copyc iot$unit_type
??POP??
*DECK DECK=IOT$SUBSYSTEM_IO_STATISTICS EXPAND=FALSE
      CONST
        ioc$number_of_io_statistics = 2,
        ioc$subsystem_io_identifier = 'IO';
*DECK DECK=IOT$TAPE_BLOCK_COUNT EXPAND=FALSE

  TYPE
     iot$tape_block_count = 0..ioc$max_tape_blocks_to_process,
     iot$min_block_length = 1..ioc$min_tape_block_length,
     iot$tape_block_length = 0..ioc$max_tape_block_length;

*copyc IOC$MAX_NUM_TAPE_UNITS
*DECK DECK=IOT$TAPE_BLOCK_ID_AREA EXPAND=FALSE

{ DECK IOT$TAPE_BLOCK_ID_AREA

  CONST
     ioc$bid_window_length = 32,
     ioc$empty_bid = 0,
     ioc$error_block_bid = 2000(16),
     ioc$loadpoint_bid = 1000(16),
     ioc$min_bksp_count = 3,
     ioc$tapemark_bid = 1,
     ioc$unavail_bid = 4;

  TYPE
     iot$bid_index = 1 .. ioc$bid_window_length,
     iot$bid_window = ARRAY [1 .. ioc$bid_window_length] OF 0 .. 0ffff(16);

  TYPE
    iot$cartridge_tape_bid = PACKED RECORD
      physical_position: 0 .. 0ff(16),
      logical_position: 0 .. 0ffffff(16),
    RECEND;

{ The following type is used as a parameter on the iop$locate_block procedure call to
{ position to either:
{ ioc$lbg = Last good block (lbg).
{ ioc$lbg_plus_count = Last good block + forespace the count in error_block_forespace_count.
{ ioc$lbg_plus_count_minus_1 = ioc$lbg_plus_count - 1.

  TYPE
    iot$locate_block_option = (ioc$lbg, ioc$lbg_plus_count, ioc$lbg_plus_count_minus_1);
*DECK DECK=IOT$TAPE_CHARACTERISTICS EXPAND=FALSE
TYPE
  iot$tape_characteristics = RECORD
    label_type: amt$label_type,
    character_set: amt$internal_code,
    write_ring: boolean,
    density: rmt$density,
  RECEND;

*copyc amt$internal_code
*copyc amt$label_type
*copyc rmt$density

*DECK DECK=IOT$TAPE_COLLECTED_PP_RESPONSE EXPAND=FALSE

{ DECK: IOT$TAPE_COLLECTED_PP_RESPONSE

  CONST
    ioc$tape_mode_command_index = 1,
    ioc$request_header_length = 4 * 8,
    ioc$min_request_length = 5 * 8;

  TYPE
    iot$tape_collected_pp_response = packed record
      pp_no: ALIGNED [0 MOD 8] 1 .. ioc$pp_count,
      pp_response: ALIGNED [0 MOD 8] iot$pp_response,
      case controller_type: cmt$controller_type of
      = cmc$mt7021_3x, cmc$mt7021_4x, cmc$mt7221_2_s0, cmc$mt7221_1, cmc$mt698_xx =
        block_id_status_area: ALIGNED [0 MOD 8] iot$tape_bid_status_response,
        device_status: ALIGNED [0 MOD 8] iot$tape_device_status,
        extended_device_status: ALIGNED [0 MOD 8] iot$tape_extended_status,
      = cmc$mt5698_xx =
        ipi_block_id_status_area: ALIGNED [0 MOD 8] iot$tape_bid_status_response,
        ipi_tape_status: ALIGNED [0 MOD 8] iot$ipi_tape_status,
      = cmc$mt5680_xx =
        ccc_cart_device_status: ALIGNED [0 MOD 8] iot$ccc_cart_device_status,
        ccc_cart_sense_bytes: ALIGNED [0 MOD 8] iot$ccc_cart_sense_bytes,
        ccc_cart_error_log: ALIGNED [0 MOD 8] iot$ccc_cart_error_log,
      casend,
    recend,

    iot$tape_request = packed record
      write_block_description: ^iot$write_tape_description,
      read_block_description: ^iot$read_tape_description,
      no_of_data_commands: iot$tape_command_index,
      no_of_non_data_commands: iot$tape_command_index,
      max_input_count: iot$transfer_count,
      first_data_command: iot$tape_command_index,
      io_id: iot$io_id,
      recovery_requeue: boolean,
      request_type: iot$tape_request_types,
      transfer_count: 0 .. ioc$tape_max_data_transfer,
      ud: ^iot$tape_job_unit_descriptor,
      error: boolean,
      inhibit_error_recovery: boolean,
      last_command_processed: iot$request_length,
      estimated_address_pair_count: 0 .. mmc$max_rma_list_length,
      tcu_parity_retry_count: iot$max_retry_count,
      parity_retry_count: iot$max_retry_count,
      lost_data_retry_count: iot$max_retry_count,
      busy_retry_count: iot$max_retry_count,
      lateack_retry_count: iot$max_retry_count,
      misc_retry_count: iot$max_retry_count,
      ipi_retry_count: iot$max_retry_count,
      initial_block_count: 0 .. ioc$max_tape_blocks_to_process,
      blocks_accessed: 0 .. ioc$max_tape_blocks_to_process,
      io_status: iot$tape_io_status,
      io_type: iot$io_function,
      pp_response_p: ^iot$tape_collected_pp_response,
      pageable_tape_request_index: 1 .. ioc$max_multiple_tape_requests + 1,
      must_free_pageable_request: boolean,
      ccc_cart_buf_underrun_recovery: boolean,
      request: ALIGNED [0 MOD 8] iot$tape_pp_request,
    recend,

    iot$wired_tape_request = packed record
      address_pair_count: ALIGNED [0 MOD 600] 0 .. mmc$max_rma_list_length,
      allocated_address_pair_count: 0 .. mmc$max_rma_list_length,
      data_pages_locked: boolean,
      list_p: ^mmt$rma_list,
      ijle_p: ^jmt$initiated_job_list_entry,
      no_of_data_commands: iot$tape_command_index,
      max_input_count: iot$transfer_count,
      first_data_command: iot$tape_command_index,
      io_id: iot$io_id,
      recovery_requeue: boolean,
      cache_purge_required_data : boolean,
      cache_purge_required_length: boolean,
      request_type: iot$tape_request_types,
      wired_write_description_p: ^iot$write_tape_description,
      wired_read_description_p: ^iot$read_tape_description,
      wired_command_heap_p: ^iot$tape_command_heap,
      io_type: iot$io_function,
      pp_response_p: ^iot$tape_collected_pp_response,
      tape_request_p: ^iot$tape_request,
      completion_q_index: iot$no_of_tape_units,
      wired_tape_table_index: 1 .. ioc$max_multiple_tape_requests,
      ready_task: boolean,
      task_id: ost$global_task_id,
      request: ALIGNED [0 MOD 8] iot$tape_pp_request,
    recend,

    iot$tape_pp_request = packed record
      fill1: ALIGNED [0 MOD 8] 0 .. 0ffff(16),
      next_pp_request: ^iot$io_request,
      fill2: 0 .. 0ffffffff(16),
      next_pp_request_rma: ost$real_memory_address,
      request_length: iot$request_length,
      logical_unit: iot$logical_unit,
      recovery: iot$request_recovery,
      interrupt: iot$interrupt,
      priority: iot$priority,
      alert_mask: iot$alert_conditions,
      mode: ALIGNED [0 MOD 8] iot$tape_format_parameters,
      tape_command: ALIGNED [0 MOD 8] array [1 .. 61] of iot$command,
    recend,

    iot$request_length = 0 .. 0ffff(16);

*copyc IOT$ALERT_CONDITIONS
*copyc IOT$CCC_CARTRIDGE_TAPE_STATUS
*copyc IOT$COMMAND
*copyc IOT$IO_FUNCTION
*copyc IOT$IO_ID
*copyc IOT$IO_REQUEST
*copyc IOT$IPI_TAPE_STATUS
*copyc IOT$LOGICAL_UNIT
*copyc IOT$NO_OF_TAPE_UNITS
*copyc IOT$READ_TAPE_DESCRIPTION
*copyc IOT$REQUEST_RECOVERY
*copyc IOT$TAPE_BLOCK_COUNT
*copyc IOT$TAPE_COMMAND_HEAP
*copyc iot$tape_device_status
*copyc IOT$TAPE_IO_STATUS
*copyc iot$tape_job_unit_descriptor
*copyc IOT$TAPE_REQUEST_TYPES
*copyc IOC$TAPE_RETRY_LIMITS
*copyc IOT$UNIT_TYPE
*copyc IOT$WRITE_TAPE_DESCRIPTION
*copyc jmt$initiated_job_list_entry
*copyc MMT$IO_TYPE
*copyc MMT$RMA_LIST
*copyc OST$GLOBAL_TASK_ID
*copyc OST$HARDWARE_SUBRANGES
*copyc RMT$DEVICE_CLASS
*DECK DECK=IOT$TAPE_COMMAND_HEAP EXPAND=FALSE

{ DECK: IOT$TAPE_COMMAND_HEAP

  TYPE
    iot$tape_command_heap = record
      rma_list: ALIGNED [0 MOD 16384] array [1 .. *] of
        mmt$rma_list_entry,
    recend;

*copyc MMT$RMA_LIST
*DECK DECK=IOT$TAPE_COMMAND_TABLE_ENTRY EXPAND=FALSE

{ DECK: IOT$TAPE_COMMAND_TABLE_ENTRY

  CONST
    ioc$no_of_67x_commands = 19,

{   Below are the tape hardware function codes used by the tape handler.

    ioc$67x_func_clear = 0,
    ioc$67x_func_format = 4,
    ioc$67x_func_normal_clip = 6,
    ioc$67x_func_high_clip = 46(16),
    ioc$67x_func_low_clip = 86(16),
    ioc$67x_func_hyper_clip = 0c6(16),
    ioc$67x_func_rewind = 8(16),
    ioc$67x_func_unload = 48(16),
    ioc$67x_func_forspace = 0b(16),
    ioc$67x_func_backspace = 4b(16),
    ioc$67x_func_cont_backspace = 4c(16),
    ioc$67x_func_read = 20(16),
    ioc$67x_func_read_backwards = 60(16),
    ioc$67x_func_write = 28(16),
    ioc$67x_func_short_write = 0a8(16),
    ioc$67x_func_write_tapemark = 29(16),
    ioc$67x_func_erase = 2a(16),
    ioc$67x_func_security_erase = 0aa(16),
    ioc$67x_func_loop1 = 3d(16),
    ioc$67x_func_loop2 = 7d(16),
    ioc$67x_func_loop3 = 0fd(16),
    ioc$67x_func_master_clear = 10c(16),
    ioc$67x_func_get_status = 8,
    ioc$67x_func_skip_tm_f = 0d(16),
    ioc$67x_func_skip_tm_b = 4d(16),

    ioc$tape_function_code_length = 8,

{   Below are the PP-request I/O packet lengths in bytes for various functions.
{   For data transfer functions the number is a minimum length. NOTE, the length
{   must be at least 40 and a multiple of 8 to be legal.

    ioc$tape_pkt_lng_clear = 48,
{     ioc$tape_pkt_lng_format - never a main command
{     ioc$tape_pkt_lng_normal_clip - never a main command
{     ioc$tape_pkt_lng_high_clip - never a main command
{     ioc$tape_pkt_lng_low_clip - never a main command
{     ioc$tape_pkt_lng_hyper_clip - never a main command
    ioc$tape_pkt_lng_rewind = 48,
    ioc$tape_pkt_lng_unload = 48,
    ioc$tape_pkt_lng_forspace = 48,
    ioc$tape_pkt_lng_backspace = 48,
    ioc$tape_pkt_lng_cont_backspace = 48,
    ioc$tape_pkt_lng_read = 40,
    ioc$tape_pkt_lng_read_backwards = 40,
    ioc$tape_pkt_lng_write = 40,
    ioc$tape_pkt_lng_short_write = 40,
    ioc$tape_pkt_lng_write_tapemark = 48,
    ioc$tape_pkt_lng_erase = 48,
    ioc$tape_pkt_lng_security_erase = 48,
    ioc$tape_pkt_lng_loop1 = 48,
    ioc$tape_pkt_lng_loop2 = 48,
    ioc$tape_pkt_lng_loop3 = 48,
    ioc$tape_pkt_lng_master_clear = 40,
    ioc$tape_pkt_lng_get_status = 48,
    ioc$tape_pkt_lng_skip_tm_f = 48,
    ioc$tape_pkt_lng_skip_tm_b = 48,

    ioc$length_of_67x_parameters = 5,

    ioc$format_cmd_length = 1,
    ioc$non_data_cmd_length = 1,
    ioc$write_cmd_per_block = 2,
    ioc$read_cmd_per_block = 2,

{   Below are the positions in the command chain where various hardware
{   commands go.

    ioc$67x_cmd_pos_clear = 2,
    ioc$67x_cmd_pos_format = 1,
    ioc$67x_cmd_pos_normal_clip = 2,
    ioc$67x_cmd_pos_high_clip = 2,
    ioc$67x_cmd_pos_low_clip = 2,
    ioc$67x_cmd_pos_hyper_clip = 2,
    ioc$67x_cmd_pos_rewind = 2,
    ioc$67x_cmd_pos_unload = 2,
    ioc$67x_cmd_pos_forspace = 2,
    ioc$67x_cmd_pos_backspace = 2,
    ioc$67x_cmd_pos_cont_backspace = 2,
    ioc$67x_cmd_pos_read = 2,
    ioc$67x_cmd_pos_read_backwards = 2,
    ioc$67x_cmd_pos_write = 2,
    ioc$67x_cmd_pos_short_write = 2,
    ioc$67x_cmd_pos_write_tapemark = 2,
    ioc$67x_cmd_pos_erase = 2,
    ioc$67x_cmd_pos_security_erase = 2,
    ioc$67x_cmd_pos_loop1 = 2,
    ioc$67x_cmd_pos_loop2 = 2,
    ioc$67x_cmd_pos_loop3 = 2,
    ioc$67x_cmd_pos_master_clear = 1,
    ioc$67x_cmd_pos_get_status = 2,
    ioc$67x_cmd_pos_skip_tm_f = 2,
    ioc$67x_cmd_pos_skip_tm_b = 2;

  TYPE
    iot$tape_command_index = 0..0ff(16),
    iot$tape_hardware_command = 0..01ff(16),
    iot$tape_request_length =
      0..ioc$max_tape_blocks_to_process*8*ioc$read_cmd_per_block+ioc$tape_pkt_lng_read;

{ Note that the following table must be ordered in the same manner as
{ the table iot$tape_request_types in module iom$tape_queue_manager_c.

  TYPE
    tape_command_table_entry = packed record
      index: iot$tape_command_index,
      length: iot$tape_request_length,
      hardware_command: iot$tape_hardware_command,
    recend;

*copyc IOC$MAX_NUM_TAPE_UNITS
*DECK DECK=IOT$TAPE_COMPLETION_PACKET EXPAND=FALSE

{ DECK: IOT$TAPE_COMPLETION_PACKET

  TYPE
    iot$tape_completion_packet = record
      lun: iot$logical_unit,
      cart_writes_pending: 0 .. ioc$max_multiple_tape_requests,
      sync_set: boolean,
      req: array [1 .. ioc$max_multiple_tape_requests] of iot$tape_completion_entry,
    recend;

  TYPE
    iot$tape_completion_entry = record
      waiting_response: boolean,
      request_not_processed: boolean,
      io_id: iot$io_id,
      io_request: ^iot$io_request,
      task_id: ost$global_task_id,
      check_task_id: boolean,
    recend;

*copyc iot$io_id
*copyc iot$io_request
*copyc iot$logical_unit
*copyc ost$global_task_id
*DECK DECK=IOT$TAPE_DEVICE_STATUS EXPAND=FALSE

{ DECK: IOT$TAPE_DEVICE_STATUS

  CONST   { length in PP 16 bit words }
    ioc$bid_status_response_length = 32,
    ioc$device_status_length = 16,
    ioc$extended_status_length = 20;

  CONST   { length in bytes }
    ioc$bid_area_size = ioc$bid_status_response_length * 2,   { 64 }
    ioc$device_status_size = ioc$device_status_length * 2;    { 32 }

  TYPE
    iot$tape_bid_status_response = ARRAY [1 .. ioc$bid_status_response_length] OF 0 .. 0ffff(16);

  TYPE
    iot$tape_device_status = packed record
      fillw1: 0 .. 0f(16),
      alert: boolean,
      fill: 0 .. 1,
      tu_connect: boolean,
      fill2: 0 .. 1,
      write_ring: boolean,
      nine_track: boolean,
      character_fill: boolean,
      tape_mark: boolean,
      end_of_tape: boolean,
      beginning_of_tape: boolean,
      unit_busy: boolean,
      unit_ready: boolean,

      fillw2: 0 .. 0f(16),
      block_id: 0 .. 1ff(16),
      fill3: 0 .. 1,
      odd_parity: boolean,
      fill4: 0 .. 1,

      fillw3: 0 .. 0f(16),
      lost_data: boolean,
      unit_check: boolean,
      tape_parity_error: boolean,
      channel_parity_error: boolean,
      tcu_parity_error: boolean,
      error_code: 0 .. 7f(16),

      fillw4: 0 .. 0f(16),
      pointer_error: boolean,
      dual_track_correction: boolean,
      single_track_correction: boolean,
      dead_tracks: 0 .. 1ff(16),

      fill5aa: 0 .. 3ff(16),
      false_eop: boolean,
      fill5b: 0 .. 1f(16),

      word6: 0 .. 0ffff(16),

      word7: 0 .. 0ffff(16),

      word8: 0 .. 0ffff(16),

      fill9a: 0 .. 0f(16),
      false_gap_bypassed: boolean,
      noise_bypassed: boolean,
      fill9b: 0 .. 3ff(16),

      word10: 0 .. 0ffff(16),

      fillw11a: 0 .. 7ff(16),
      density: 0 .. 3,
      fillw11b: 0 .. 7,

      fill12a: 0 .. 1fff(16),
      erase_current_failure: boolean,
      fill12b: 0 .. 3(16),

      word13: 0 .. 0ffff(16),

      fill14a: 0 .. 7ff(16),
      tape_present: boolean,
      fill14b: 0 .. 0f(16),

      word15: 0 .. 0ffff(16),

      word16: 0 .. 0ffff(16),
    recend;

  TYPE
    iot$tape_extended_status = ARRAY [1 .. ioc$extended_status_length] of 0 .. 0ffff(16);
*DECK DECK=IOT$TAPE_FAILURE_STATISTIC_DATA EXPAND=FALSE

{ DECK: IOT$TAPE_FAILURE_STATISTIC_DATA

  CONST
    ioc$undetermined = 1,
    ioc$recovered = 2,
    ioc$unrecovered = 3,
    ioc$intermediate = 4,
    ioc$informative = 5;

  TYPE
    iot$tape_failure_type = 1 .. ioc$informative;

  CONST
    ioc$max_failure_counters = 62,
    ioc$max_ccc_cart_counters = 36,
    ioc$min_ipi_counters = 31,
    ioc$max_ipi_error_text = 39,
    ioc$max_ccc_cart_error_text = 30,
    ioc$tape_failure_counters = 1,
    ioc$tape_failure_statistic_data = 2,
    ioc$tape_failure_array = 3;

  TYPE
    iot$tape_failure_data_selector = ioc$tape_failure_counters ..
          ioc$tape_failure_array;

  TYPE
    iot$tape_failure_data = record
      case iot$tape_failure_data_selector of

      = ioc$tape_failure_counters =
        counters: seq (rep ioc$max_failure_counters of integer),
      = ioc$tape_failure_statistic_data =
        package: iot$tape_failure_statistic_data,
      = ioc$tape_failure_array =
        counters_array: array [1 .. ioc$max_failure_counters] of integer,

      casend
    recend;

  TYPE
    iot$tape_failure_statistic_data = record
      pp_number: iot$iou_resource_counter,
      channel_number: iot$iou_resource_counter,
      equipment_number: integer,
      physical_unit_number: integer,
      unit_type: integer,
      operation_code: integer,
      failure_severity: integer,
      failure_symptom_code: integer,
      blocks_written: integer,
      blocks_read: integer,
      single_double_track_corrections: integer,
      unused_fill1: integer,
      block_count: integer,
      tapemark_count: integer,
      tape_format_parameters: integer,
      density: integer,
      recovery_type: integer,
      recovery_retry_count: integer,
      last_requested_function: integer,
      initial_hardware_status: array [1 .. 16] of 0 .. 0ffff(16),
      initial_extended_status: array [1 .. 20] of 0 .. 0ffff(16),
      final_hardware_status: array [1 .. 16] of 0 .. 0ffff(16),
      final_extended_status: array [1 .. 20] of 0 .. 0ffff(16),
      historical_bid_index: 0 .. 0ffff(16),
      historical_limit:  0 .. 0ffff(16),
      historical_reserved_area: 0 .. 0ffffffff(16),
      historical_bid_window: iot$bid_window,
      current_bid_index: 0 .. 0ffff(16),
      current_limit:  0 .. 0ffff(16),
      current_reserved_area: 0 .. 0ffffffff(16),
      current_bid_window: iot$bid_window,
    recend;

  TYPE
    iot$iou_resource_counter = packed record
      initial_error_status_register: 0 .. 0ffff(16),
      final_error_status_register: 0 .. 0ffff(16),
      fill1: 0 .. 3fff(16),
      iou: 0 .. 3f(16),
      fill2: 0 .. 7,
      i4_port_a: 0 .. 1,
      i4_port_b: 0 .. 1,
      concurrent: 0 .. 1,
      resource_number: 0 .. 3f(16),
    recend;

  TYPE
    iot$ipi_failure_data_selector = ioc$tape_failure_counters ..
          ioc$tape_failure_statistic_data;

  TYPE
    iot$ipi_tape_failure_data = record
      case iot$ipi_failure_data_selector of

      = ioc$tape_failure_counters =
        counters: seq (rep ioc$max_failure_counters of integer),
      = ioc$tape_failure_statistic_data =
        package: iot$ipi_statistic_data,

      casend
    recend;

  TYPE
    iot$ipi_statistic_data = record
{1}   pp_number: iot$iou_resource_counter,
{2}   channel_number: iot$iou_resource_counter,
{3}   equipment_number: integer,
{4}   physical_unit_number: integer,
{5}   unit_type: integer,
{6}   operation_code: integer,
{7}   failure_severity: integer,
{8}   failure_symptom_code: integer,
{9}   blocks_written: integer,
{10}  blocks_read: integer,
{11}  single_double_track_corrections: integer,
{12}  unused_fill1: integer,
{13}  block_count: integer,
{14}  tapemark_count: integer,
{15}  tape_format_parameters: integer,
{16}  density: integer,
{17}  unused_fill2: integer,
{18}  recovery_retry_count: integer,
{19}  last_requested_function: integer,
{20}  ipi_status_register: integer,
{21}  ipi_error_register: integer,
{22}  i4_error_register: integer,
{23}  i4_operation_register: integer,
{24}  i4_control_register: integer,
{25}  interface_error_code: integer,
{26}  unused_fill3: integer,
{27}  unused_fill4: integer,
{28}  unused_fill5: integer,
{29}  unused_fill6: integer,
{30}  unused_fill7: integer,
{31}  ipi_status: array [1 .. ioc$ipi_max_status_size] of 0 .. 0ff(16),
    recend;

  TYPE
    iot$ccc_cart_failure_selector = ioc$tape_failure_counters ..
          ioc$tape_failure_statistic_data;

  TYPE
    iot$ccc_cart_tape_failure_data = RECORD
      CASE iot$ccc_cart_failure_selector OF

      = ioc$tape_failure_counters =
        counters: seq (rep ioc$max_ccc_cart_counters of integer),
      = ioc$tape_failure_statistic_data =
        package: iot$ccc_cart_statistic_data,

      CASEND
    RECEND;

  TYPE
    iot$ccc_cart_statistic_data = RECORD
{1}   pp_number: iot$iou_resource_counter,
{2}   channel_number: iot$iou_resource_counter,
{3}   equipment_number: integer,
{4}   physical_unit_number: integer,
{5}   unit_type: integer,
{6}   operation_code: integer,
{7}   failure_severity: integer,
{8}   failure_symptom_code: integer,
{9}   blocks_written: integer,
{10}  blocks_read: integer,
{11}  on_the_fly_read_corrections: integer,
{12}  on_the_fly_write_corrections: integer,
{13}  block_count: integer,
{14}  tapemark_count: integer,
{15}  read_recovery_count: integer,
{16}  write_recovery_count: integer,
{17}  last_function: iot$last_ccc_cart_function,
{18}  recovery_retry_count: integer,
{19}  first_error_status_register: integer,
{20}  final_error_status_register: integer,
{21}  initial_status: array [1 .. 8] of 0 .. 0ff(16),
{22}  initial_sense_bytes: array [1 .. 40] of 0 .. 0ff(16),
{27}  final_status: array [1 .. 8] of 0 .. 0ff(16),
{28}  final_sense_bytes: array [1 .. 40] of 0 .. 0ff(16),
{33}  density: integer,
{34}  buffer_underruns: integer,
{35}  res2: integer,
{36}  last_failure_info: iot$ccc_cart_last_failure_info,
    RECEND,

    iot$last_ccc_cart_function = PACKED RECORD
      fill: 0 .. 0ffffffff(16),
      last_not_status: 0 .. 0ffff(16),
      last: 0 .. 0ffff(16),
    RECEND,

    iot$ccc_cart_last_failure_info = PACKED RECORD
      fill: 0 .. 0ffff(16),
      error_id: 0 .. 0ffff(16),
      last_non_status_function: 0 .. 0ffff(16),
      last_function: 0 .. 0ffff(16),
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc iot$tape_block_id_area
?? POP ??
*DECK DECK=IOT$TAPE_IO_STATUS EXPAND=FALSE

{ DECK: IOT$TAPE_IO_STATUS

  CONST
    ioc$tape_completion_code_max = 120;

  CONST

{   Completions codes returned that indicate hardware or media failure.

    ioc$indeterminate = 1,
    ioc$input_channel_parity = 2,
    ioc$output_channel_parity =  3,
    ioc$controller_failure = 4,
    ioc$unit_failure = 5,
    ioc$function_timeout = 6,
    ioc$tape_medium_failure = 7,
    ioc$erase_limit_exceeded = 8,
    ioc$unit_reserved = 9,
    ioc$iou_output_parity = 10,
    ioc$indeterminate_output_parity = 11,
    ioc$unable_to_write_id_burst = 12,
    ioc$unable_to_set_agc = 13,
    ioc$hardware_correction_logging = 14,

{   Completion codes that are used to communicate between tape_queue_manager
{   and tape_block_manager.

    ioc$blank_tape = 60,
    ioc$read_past_phys_eot = 61,  { cartridge tape only
    ioc$write_past_phys_eot = 62, { cartridge tape only

    ioc$load_point = 100,
    ioc$load_point_block_count_ne_0 = 101,
    ioc$no_write_ring = 102,
    ioc$not_capable_of_density = 103,
    ioc$system_software_failure = 104,
    ioc$tapemark_read = 105,
    ioc$user_own_recovery = 106,
    ioc$alert_condition_encountered = 107,
    ioc$request_not_processed = 108;

  TYPE
    iot$tape_completion_codes = 1 .. ioc$tape_completion_code_max;

  TYPE
    iot$tape_io_status = RECORD
      case io_complete: boolean of
      = TRUE =
        write_ring,
        end_of_tape,
        beginning_of_tape,
        unit_busy,
        unit_ready,
        wait_selected: boolean,
        unit_density: rmt$density,  {Density not valid on status after write/read, or if not off load point.
                                    {Used in tape_scanner on rewind status after label read.
        residual_block_count: iot$tape_block_count,
        case normal_completion: boolean of
        = TRUE =
          ,
        = FALSE =
          long_input_block,
          position_uncertain: boolean,
          completion_code: iot$tape_completion_codes,
        casend,
      = FALSE =
        ,
      casend,
    RECEND;

*copyc IOT$TAPE_BLOCK_COUNT
*copyc IOT$TAPE_COMMAND_TABLE_ENTRY
*copyc IOT$TAPE_REQUEST_TYPES
*copyc RMT$DENSITY
*DECK DECK=IOT$TAPE_JOB_STATISTIC_DATA EXPAND=FALSE

{ DECK: IOT$TAPE_JOB_STATISTIC_DATA

  TYPE
    iot$statistic_data_p_array = array [ * ] of iot$statistic_data_pointers;

  TYPE
    iot$unit_type_case_selector = (ioc$non_ipi_reel, ioc$ipi_reel, ioc$ccc_cart);

  TYPE
    iot$statistic_data_pointers = record
      slot_in_use: boolean,
      logical_unit: iot$logical_unit,
      p_tape_job_unit_descriptor: ^iot$tape_job_unit_descriptor,
      case unit_type: iot$unit_type_case_selector of
      = ioc$non_ipi_reel =
        p_failure_data: ^iot$tape_failure_data,
      = ioc$ipi_reel =
        p_ipi_failure_data: ^iot$ipi_tape_failure_data,
      = ioc$ccc_cart =
        p_ccc_cart_failure_data: ^iot$ccc_cart_tape_failure_data,
      casend
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc iot$pp_interface_table
*copyc iot$tape_failure_statistic_data
*copyc iot$tape_job_unit_descriptor
?? POP ??
*DECK DECK=IOT$TAPE_JOB_UNIT_DESCRIPTOR EXPAND=FALSE

{ DECK: IOT$TAPE_JOB_UNIT_DESCRIPTOR

  TYPE
    iot$tape_job_unit_descriptor = record
      io_id: iot$io_id,

{ completion_q_index is the index into iov$tape_completion_q_table and iov$wired_tape_tables
{ for this logical_unit.

      completion_q_index: iot$no_of_tape_units,
      pageable_tape_requests: iot$pageable_tape_requests,
      pending_pageable_requests: array [1 .. ioc$max_multiple_tape_requests] of ^iot$tape_request,

{ Blocks_read/written includes recovery operations. The blocks_read counter also includes all
{ forspaces/backspaces executed on the tape unit.

      blocks_read: integer,
      blocks_written: integer,

{ Blocks_read/written_for_accounting does not include recovery operations. This is a total
{ accumulation count from the time the tape was assigned until unload time. The read counter
{ does not include any forspaces or backspaces as they are in the blocks_skipped counter.

      blocks_read_for_accounting,
      blocks_written_for_accounting,

{ Blocks_read/written_for_byte_count is the counts for that particular instance of open. At the time
{ a close is issued, the byte counts are incremented by taking these block_counts and multiplying
{ by the max_block_length for the instance of open. On multi-file labelled tapes, the max_block_length
{ can vary from file to file. These counts are cleared at close of file.

      blocks_read_for_byte_count: integer,
      blocks_written_for_byte_count: integer,

{ Bytes_read/written is a total accumulation of bytes processed from the time the tape was assigned
{ until the tape was unloaded.

      bytes_read: integer,
      bytes_written: integer,

{ Blocks_skipped is the total number of forespaces/backspaces (does not include recovery operations)
{ that were executed from the time the tape was asigned until the tape was unloaded.  With Release
{ 1.4.1, the tape block manager will not use the hardware function of SKIP_TAPEMARK, but will
{ forespace/backspace until the tapemark is encountered.  This mechanism of searching for a tapemark
{ allows channel sharing and functionally does what is involved for the hardware in a SKIP_TAPEMARK.

      blocks_skipped: integer,

{ Block_count is the number of IRG's (Inter_Record_Gaps) from loadpoint (includes tapemarks) at the
{ present physical position of the tape file.

      block_count: integer,

{ Tapemark count is the number of Tapemarks that can be counted from loadpoint at the present physical
{ position of the tape file.

      tapemark_count: integer,

      tape_unit_density: integer,
      io_requests_count: integer,
      tape_error_log_entry: boolean,
      task_terminated_during_recovery: boolean,
      block_in_error: -1 .. ioc$max_tape_blocks_to_process,
      last_request: iot$tape_request_types,
      controller_type: cmt$controller_type,
      min_block_length: amt$min_block_length,
      max_block_length: amt$max_block_length,
      position_uncertain: boolean,
      format_parameters: iot$tape_format_parameters,
      single_double_track_corrections: integer,
      free_running_clock: integer,
      consecutive_erases: 0 .. 0ffff(16),
      positioning_to_tapemark: boolean,
      cartridge_tape_last_good_bid: iot$cartridge_tape_bid,
      ccc_cart_buffer_underruns: 0 .. 0ffff(16),
      error_block_forespace_count: 0 .. 0ffff(16),
      bid_index: iot$bid_index,
      bid_window: iot$bid_window,
      historical_bid_index: iot$bid_index,
      historical_bid_window: iot$bid_window,
    recend;

  TYPE
    iot$tape_format_parameters = packed record
      define_code_translation: 0 .. 1,
      code_translation: 0 .. 7,
      define_ad: 0 .. 1,
      ad_mode: 0 .. 3,
      define_unit_no: boolean,
      hardware_unit_number: 0 .. 0f(16),
      fill: 0 .. 1,
      define_vertical_parity: 0 .. 1,
      vertical_parity: 0 .. 1,
      define_density: 0 .. 1,
      density: 0 .. 3,
      define_min_block_length: 0 .. 1,
      min_block_length: 0 .. 1f(16),
      define_disable_error_correction: 0 .. 1,
      disable_hardware_correction: 0 .. 1,
      fill1: 0 .. 3ff(16),
      read_max_byte_count: 0 .. 0fffffff(16),
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
*copyc amt$max_block_length
*copyc cmt$controller_type
*copyc iot$io_id
*copyc iot$no_of_tape_units
*copyc iot$pageable_tape_requests
*copyc iot$tape_block_id_area
*copyc iot$tape_request_types
?? POP ??
*DECK DECK=IOT$TAPE_POSITION EXPAND=FALSE
{ DECK: IOT$TAPE_POSITION

 TYPE
   tape_position = (ioc$tape_at_loadpoint_position, ioc$tape_not_loadpoint_position,
                    ioc$tape_position_unknown),

   unit_type_selector = (ioc$reel_to_reel, ioc$cartridge),

   iot$tape_position = RECORD
      tape_position: tape_position,
      blocks_from_loadpoint: INTEGER,
      tapemarks_from_loadpoint: INTEGER,
      CASE unit_type: unit_type_selector OF
      = ioc$reel_to_reel =
        historical_bid_index: iot$bid_index,
        historical_bid_window: iot$bid_window,
      = ioc$cartridge =
        last_good_bid: iot$cartridge_tape_bid,
      CASEND
   RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc iot$tape_block_id_area
?? POP ??

*DECK DECK=IOT$TAPE_REQUEST_BLOCK EXPAND=FALSE

  TYPE
    iot$tape_request_block = packed record
      request_code: ALIGNED [0 MOD 8] syt$monitor_request_code,
      io_request_p: ^iot$io_request,
      status: syt$monitor_status,
    recend;

*copyc IOT$IO_REQUEST
*copyc SYC$MONITOR_REQUEST_CODES
*copyc SYT$MONITOR_REQUEST_CODE
*DECK DECK=IOT$TAPE_REQUEST_TYPES EXPAND=FALSE

{
{     Common deck iodtrt
{

  TYPE
    iot$tape_request_types = 1..20;

  CONST
    ioc$tape_clear = 1,
    ioc$tape_rewind = 2,
    ioc$tape_unload = 3,
    ioc$tape_forspace = 4,
    ioc$tape_backspace = 5,
    ioc$tape_cont_backspace = 6,
    ioc$tape_read = 7,
    ioc$tape_read_backwards = 8,
    ioc$tape_write = 9,
    ioc$tape_loop1 = 10,
    ioc$tape_loop2 = 11,
    ioc$tape_loop3 = 12,
    ioc$tape_write_tapemark = 13,
    ioc$tape_erase = 14,
    ioc$tape_data_security_erase = 15,
    ioc$tape_master_clear = 16,
    ioc$tape_get_status = 17,
    ioc$skip_tapemark_forward = 18,
    ioc$skip_tapemark_backward = 19,
    ioc$locate_block = 20;
*DECK DECK=IOT$TAPE_STATISTICS EXPAND=FALSE

{ Common deck IOT$TAPE_STATISTICS

{ This deck calls all of the tape statistics definition decks.

*copyc cml$7021_3x_failure_data
*copyc cml$7221_1_failure_data
*copyc cml$698_1x_failure_data
*copyc cml$5698_1x_failure_data
*copyc cml$5680_11_failure_data
*copyc cml$tape_subsystem_usage_data


*DECK DECK=IOT$TAPE_TRACK EXPAND=FALSE
TYPE

 iot$tape_track = record
                  id: iot$io_id,
                  time: integer,
                  recend;

*copyc iot$io_id
*DECK DECK=IOT$TAPE_UNIT_STATUS_ENTRY EXPAND=FALSE

  TYPE
    iot$tape_unit_status_entry = record
      element_name: ost$name,
      evsn: rmt$external_vsn,
      rvsn: rmt$recorded_vsn,
      logical_pp: array [1 .. 4] of iot$pp_number,
      reassign_device_control: iot$reassign_device_control,
      sfid: dmt$system_file_id,
      ssn: jmt$system_supplied_name,
      assignment_state: iot$unit_assignment_state,
      tape_unit_state: cmt$element_state,
      unit_ready: boolean,
      read_error: boolean,
      detected_tape_characteristics: iot$tape_characteristics,
      path_handle_name: fst$path_handle_name,
      unit_type: iot$unit_type,
      lock: ost$signature_lock,
    recend;


  TYPE
    iot$unit_assignment_state = (ioc$not_assigned,
                                 ioc$man_assignment_in_progress,
                                 ioc$manually_assigned,
                                 ioc$automatically_assigned );


*copyc cmt$element_state
*copyc iot$pp_number
*copyc dmt$system_file_id
*copyc iot$reassign_device_control
*copyc iot$tape_characteristics
*copyc iot$unit_type
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$signature_lock
*copyc rmt$external_vsn
*copyc rmt$recorded_vsn
*copyc fst$path_handle_name
*DECK DECK=IOT$TAPE_UNIT_STATUS_LIST EXPAND=FALSE
  TYPE
    iot$tape_unit_status_list = ARRAY [1 .. *] OF iot$tape_unit_status_entry;


*copyc iot$tape_unit_status_entry
*DECK DECK=IOT$TAPE_USAGE_STATISTIC_DATA EXPAND=FALSE

{ DECK: IOT$TAPE_USAGE_STATISTIC_DATA

  CONST
    ioc$max_usage_counters = 10,
    ioc$tape_usage_counters = 1,
    ioc$tape_usage_statistic_data = 2,
    ioc$tape_usage_array = 3;

  TYPE
    iot$tape_usage_data_selector = ioc$tape_usage_counters ..
          ioc$tape_usage_array;

  TYPE
    iot$tape_usage_data = record
      case iot$tape_usage_data_selector of

      = ioc$tape_usage_counters =
        counters: seq (rep ioc$max_usage_counters of integer),
      = ioc$tape_usage_statistic_data =
        package: iot$tape_usage_statistic_data,
      = ioc$tape_usage_array =
        counters_array: array [1 .. ioc$max_usage_counters] of integer,

      casend
    recend;

  TYPE
    iot$tape_usage_statistic_data = record
      last_density: integer,
      total_blocks_written: integer,
      total_blocks_read: integer,
      total_io_requests: integer,
      accounting_blocks_skipped: integer,
      accounting_blocks_written: integer,
      accounting_blocks_read: integer,
      accounting_bytes_written: integer,
      accounting_bytes_read: integer,
      seconds_tape_mounted: integer,
    recend;
*DECK DECK=IOT$TAPE_USER_MESG_INDEX EXPAND=FALSE

  CONST
    ioc$tape_num_user_messages = 4,
    ioc$tape_user_mesg_length = 80,
    ioc$tape_marginal_mesg = 1,

    ioc$tape_num_op_messages = 2,
    ioc$tape_op_mesg_length = 80,
    ioc$tape_offline_message = 1,

    ioc$tape_offline_mesg = 1,
    ioc$tape_not_ready_mesg = 2;

  TYPE
    iot$tape_user_mesg_index = 1..ioc$tape_num_user_messages,
    iot$tape_user_message = string (ioc$tape_user_mesg_length),

    iot$tape_op_mesg_index = 1..ioc$tape_num_op_messages,
    iot$tape_op_message_entry = packed record
      response_required: boolean,
      text: string(ioc$tape_op_mesg_length),
    RECEND;
*DECK DECK=IOT$TRANSFER_COUNT EXPAND=FALSE

*IF $true(osv$unix)

  TYPE
    iot$transfer_count = 0 .. 7fffffff(16);

*ELSE

  TYPE
    iot$transfer_count = 0 .. 0ffffffff(16);

*IFEND
*DECK DECK=IOT$TUSL_ENTRY_ACCESS EXPAND=FALSE

  TYPE
    iot$tusl_entry_access = record
      case operation: iot$tusl_entry_operation of
      = ioc$disable_operator_reassign =
        ,
      = ioc$enable_operator_reassign =
        ,
      = ioc$fetch_operator_reassign =
        fetch_operator_reassign {output} : boolean,
      = ioc$set_operator_reassign =
        ,
      = ioc$store_tape_characteristics =
        store_density {input} : rmt$density,
        store_write_ring {input} : boolean,
      = ioc$store_unit_ready =
        store_unit_ready {input} : boolean,
      casend
    recend;

*copyc iot$tusl_entry_operation
*copyc rmt$density
*DECK DECK=IOT$TUSL_ENTRY_OPERATION EXPAND=FALSE

  TYPE
    iot$tusl_entry_operation = (ioc$disable_operator_reassign, ioc$enable_operator_reassign,
          ioc$fetch_operator_reassign, ioc$set_operator_reassign, ioc$store_tape_characteristics,
          ioc$store_unit_ready);


*DECK DECK=IOT$TUSL_ORDINAL EXPAND=FALSE

    TYPE
      iot$tusl_ordinal = 1 .. ioc$maximum_tusl_entries;

    CONST
      ioc$maximum_tusl_entries = ioc$max_number_tape_units;

*copyc ioc$max_num_tape_units
*DECK DECK=IOT$UNIT_INTERFACE_TABLE EXPAND=FALSE
 CONST
    ioc$unit_commun_buffer_length = 64;

  TYPE
    iot$unit_interface_table = packed record
      logical_unit: ALIGNED [0 MOD 64] iot$logical_unit,
      unit_status: iot$unit_status,
      unit_type: iot$unit_type,
      queue_count: 0 .. 0ffff(16),
      unit_shared : boolean,
      fill1: 0 .. 7fff(16),
      unit_commun_buffer_length: iot$unit_commun_buffer_length,
      unit_communication_buffer_rma: ost$real_memory_address,
      unit_lockword: iot$lockword,
      unit_q_lockword: ALIGNED [0 MOD 8] iot$lockword,
      fill2: 0 .. 0ffff(16),
      next_request: ALIGNED [2 MOD 8] ^iot$io_request,
      last_word: ALIGNED [0 MOD 8] 0 .. 0ffffffff(16),
      next_request_rma: ALIGNED [4 MOD 8] ost$real_memory_address,
    recend,

    iot$unit_status = packed record
      disabled: boolean,
      force_format: boolean,
      parity_protection_enabled: boolean,
      restoring_drive: boolean,
      fill4: 0 .. 0f(16),
      off_line_drive_number: 0 .. 0ff(16),
    recend,

    iot$unit_communication_buffer = SEQ (REP ioc$unit_commun_buffer_length of
      ost$word),
    iot$unit_commun_buffer_template = record
      unit_communication_buffer: ALIGNED [0 MOD 512]
        iot$unit_communication_buffer,
    recend,
    iot$unit_commun_buffer_length = 0 .. 0ffff(16);

*copyc iot$logical_unit
*copyc ost$hardware_subranges
*copyc iot$lockword
*copyc iot$io_request
*copyc iot$unit_type
*DECK DECK=IOT$UNIT_TYPE EXPAND=FALSE

  CONST
    ioc$dt_mt679_5 = 1,
    ioc$dt_mt679_6 = 2,
    ioc$dt_mt679_7 = 3,
    ioc$dt_mt679_2 = 4,
    ioc$dt_mt679_3 = 5,
    ioc$dt_mt679_4 = 6,
    ioc$dt_mt677_2 = 7,
    ioc$dt_mt677_3 = 8(16),
    ioc$dt_mt677_4 = 9(16),
    ioc$dt_mt667_2 = 0a(16),
    ioc$dt_mt667_3 = 0b(16),
    ioc$dt_mt667_4 = 0c(16),
    ioc$dt_mt669_2 = 0d(16),
    ioc$dt_mt669_3 = 0e(16),
    ioc$dt_mt669_4 = 0f(16),
    ioc$dt_mt639_1 = 10(16),
    ioc$dt_mt698_3x = 11(16),
    ioc$dt_mt5682_1x = 12(16),
    ioc$highest_tape_unit = 99(16),

    ioc$lowest_disk_unit = 100(16),
    ioc$highest_disk_unit = 1ff(16),

    ioc$dt_ms844_4x = 100(16),
    ioc$dt_ms885_1x = 101(16),
    ioc$dt_ms885_42 = 102(16),
    ioc$dt_ms834_2 = 103(16),
    ioc$dt_msfsd_2 = 104(16),
    ioc$dt_ms895_2 = 105(16),
    ioc$dt_mshydra = 106(16),
    ioc$dt_ms9836_1 = 107(16),
    ioc$dt_msxmd_3 = 108(16),
    ioc$dt_ms5832_1 = 109(16),
    ioc$dt_ms5832_2 = 10a(16),
    ioc$dt_ms5833_1 = 10b(16),
    ioc$dt_ms5833_1p = 10c(16),
    ioc$dt_ms5833_2 = 10d(16),
    ioc$dt_ms5833_3p = 10e(16),
    ioc$dt_ms5833_4 = 10f(16),
    ioc$dt_ms5838_1 = 110(16),
    ioc$dt_ms5838_1p = 111(16),
    ioc$dt_ms5838_2 = 112(16),
    ioc$dt_ms5838_3p = 113(16),
    ioc$dt_ms5838_4 = 114(16),
    ioc$dt_ms47444_1 = 115(16),
    ioc$dt_ms47444_1p = 116(16),
    ioc$dt_ms47444_2 = 117(16),
    ioc$dt_ms47444_3p = 118(16),
    ioc$dt_ms47444_4 = 119(16),
    ioc$dt_mdi_1 = 200(16),
    ioc$dt_map_1 = 201(16),
    ioc$dt_map_cmi_1 = 202(16),
    ioc$dt_lcn_1 = 204(16),
    ioc$dt_file_server = 205(16),
    ioc$dt_ica_2 = 206(16),
    ioc$dt_expresslink = 207(16);

{  Foreign device unit type:

 CONST
   ioc$dt_foreign_device = 300(16);

{  Control Module Definitions:

  CONST
    ioc$cm_10395_1 = 1,
    ioc$cm_isd_2 = 2;

  TYPE
    iot$unit_type = 0 .. 0ffff(16);
*DECK DECK=IOT$VSN EXPAND=FALSE
TYPE

  iot$vsn = ARRAY [1 .. ioc$request_heap_count] OF rmt$recorded_vsn;


*copyc rmt$recorded_vsn
*copyc iot$request_heap_map
*DECK DECK=IOT$VSN_ASSIGNMENT_STATE EXPAND=FALSE

TYPE
  iot$vsn_assignment_state = (ioc$unassigned,
                              ioc$queued_for_assignment,
                              ioc$ready_for_assignment,
                              ioc$assigned );

  { !Examine all code references if iot$assignment_state is modified.
  { Relational operations are performed on this type.
*DECK DECK=IOT$WAITING_TASK_ENTRY EXPAND=FALSE
*DECK DECK=IOT$WIRED_TAPE_TABLES EXPAND=FALSE

{ DECK: IOT$WIRED_TAPE_TABLES


  TYPE
    iot$wired_tape_tables = ARRAY [1 .. ioc$max_multiple_tape_requests] OF
          iot$wired_tape_table_entry;

  TYPE
    iot$wired_tape_table_entry = RECORD
      slot_in_use: boolean,
      io_request_p: ^iot$io_request,
      wired_tape_request_p: ^iot$wired_tape_request,
      request_block_p: ^iot$tape_request_block,
    RECEND;

?? PUSH(LISTEXT := ON) ??
*copyc iot$io_request
*copyc iot$tape_collected_pp_response
*copyc iot$tape_request_block
?? POP ??

*DECK DECK=IOT$WIRED_UNIT_QUEUE_REQUEST EXPAND=FALSE
 TYPE
    cmt$wired_unit_queue_request = record
      address_word_pair_count: ALIGNED [0 MOD 512] 0 ..
        mmc$max_rma_list_length,
      io_identification: cmt$subsystem_io_request_id,
      task_id: ost$global_task_id,
      number_of_commands: cmt$command_index,
      unit_queuing_control: cmt$unit_queuing_options,
      number_of_data_descriptors: cmt$command_index,
      task_is_to_be_readied: boolean,
      response_area_p: ^cmt$subsys_io_response_area,
      wired_command_heap_p: ^cmt$subsystem_command_heap,
      wired_pp_response_p: ^cmt$collected_pp_response,
      wired_data_command_descript_p: ^cmt$wired_data_descriptors,
      monitor_request_block_p: ^iot$monitor_request_block,
      wired_io_request_p: ^iot$io_request,
      request: ALIGNED [0 MOD 8] cmt$pp_request,
    recend;

  TYPE
    cmt$max_wired_unit_queue_req = record
      address_word_pair_count: ALIGNED [0 MOD 512] 0 ..
        mmc$max_rma_list_length,
      io_identification: cmt$subsystem_io_request_id,
      task_id: ost$global_task_id,
      number_of_commands: cmt$command_index,
      unit_queuing_control: cmt$unit_queuing_options,
      number_of_data_descriptors: cmt$command_index,
      task_is_to_be_readied: boolean,
      response_area_p: ^cmt$subsys_io_response_area,
      wired_command_heap_p: ^cmt$subsystem_command_heap,
      wired_pp_response_p: ^cmt$collected_pp_response,
      wired_data_command_descript_p: ^cmt$wired_data_descriptors,
      monitor_request_block_p: ^iot$monitor_request_block,
      wired_io_request_p: ^iot$io_request,
      request: ALIGNED [0 MOD 8] cmt$max_pp_request,
    recend;

   TYPE
      cmt$wired_data_descriptor = RECORD
                  command_index: cmt$command_index,
                  rma_list_index: 0 .. mmc$max_rma_list_length,
                  data_descriptor_index: cmt$command_index,
                  io_direction: cmt$io_direction,
                  lock_data_pages: boolean,
                  length: cmt$data_descriptor_length,
                  address: ^cell,
                                  RECEND,
      cmt$wired_data_descriptors = array [1 .. *] of cmt$wired_data_descriptor,
      cmt$wired_descriptor_area = RECORD
                        data_area: ALIGNED [0 MOD 1024] SEQ (*),
                                  RECEND;

 TYPE
    cmt$pp_request = packed record
      fill1: ALIGNED [0 MOD 8] 0 .. 0ffff(16),
      next_pp_request: ^iot$io_request,
      fill2: 0 .. 0ffffffff(16),
      next_pp_request_rma: ost$real_memory_address,
      request_length: iot$pp_request_length,
      logical_unit: iot$logical_unit,
      recovery: iot$request_recovery,
      interrupt: iot$interrupt,
      priority: iot$priority,
      alert_mask: iot$alert_conditions,
      current_command_index: ALIGNED [0 MOD 8] 0 .. cmc$max_command_index,
      fill3: 0 .. 0FFFFFFFFFFFFFF(16),
      commands: ALIGNED [0 MOD 8] array [1 .. * ] of iot$command,
    recend;

  TYPE
    cmt$max_pp_request = packed record
      fill1: ALIGNED [0 MOD 8] 0 .. 0ffff(16),
      next_pp_request: ^iot$io_request,
      fill2: 0 .. 0ffffffff(16),
      next_pp_request_rma: ost$real_memory_address,
      request_length: iot$pp_request_length,
      logical_unit: iot$logical_unit,
      recovery: iot$request_recovery,
      interrupt: iot$interrupt,
      priority: iot$priority,
      alert_mask: iot$alert_conditions,
      current_command_index: ALIGNED [0 MOD 8] 0 .. cmc$max_command_index,
      fill3: 0 .. 0FFFFFFFFFFFFFF(16),
      commands: ALIGNED [0 MOD 8] array [1 .. cmc$max_command_index] of
        iot$command,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc iot$request_lengths
*copyc cmt$subsystem_io_request_id
*copyc mmt$rma_list
*copyc cmt$subsys_io_response_area
*copyc iot$monitor_request_block
*copyc cmt$os_subsystem_response
*copyc cmt$data_command_descriptors
*copyc cmt$subsystem_command_heap
*copyc cmt$unit_queuing_options
?? POP ??
*DECK DECK=IOT$WRITE_TAPE_DESCRIPTION EXPAND=FALSE

{ IODTWTD }

  TYPE
     iot$write_tape_description = array[iot$tape_block_count] of
        iot$write_block_descriptor;

  TYPE
     iot$write_block_descriptor = PACKED RECORD
*IF $true(osv$unix)
       fill : ALIGNED [0 MOD 8] integer,
*ELSE
       fill : ALIGNED [0 MOD 8] 0..0ffffffff(16),
*IFEND
       transfer_length: iot$transfer_count,
       fill2: 0..0ffff(16),
       buffer_area: ^cell,
     RECEND;

*copyc IOT$TAPE_BLOCK_COUNT
*copyc IOT$TRANSFER_COUNT
*DECK DECK=IOV$DEBUG_OPTIONS EXPAND=FALSE
*DECK DECK=IOV$DISK_PP_USAGE_P EXPAND=FALSE

  VAR
    iov$disk_pp_usage_p: [XREF] ^iot$disk_pp_array;

?? PUSH (LISTEXT := ON) ??
*copyc iot$disk_usage
?? POP ??
*DECK DECK=IOV$DISK_TYPE_TABLE EXPAND=FALSE

  VAR
    iov$disk_type_table: [XREF] array [1 .. ioc$disk_type_count] of iot$disk_type_table;

?? PUSH (LISTEXT := ON) ??
*copyc iot$disk_type_table
?? POP ??
*DECK DECK=IOV$DISK_TYPE_TABLE_XDCL EXPAND=FALSE
  VAR

    iov$disk_type_table: [XDCL, STATIC, #GATE] array [1 ..
      ioc$disk_type_count] of iot$disk_type_table := [
      [ioc$dt_ms844_4x, 5, 24, 19, 823, 2048, 3472],
      [ioc$dt_ms885_1x, 4, 32, 40, 843, 2048, 2083],
      [ioc$dt_ms885_42, 1, 32, 10, 843, 2048, 521],
      [ioc$dt_ms834_2, 4, 32, 10, 817, 2048, 2083],
      [ioc$dt_msfsd_2, 4, 47, 24, 700, 2048, 1418],
      [ioc$dt_ms895_2, 1, 10, 15, 886, 4096, 1666],
      [ioc$dt_mshydra, 1, 38, 4, 884, 4096, 439],
      [ioc$dt_ms9836_1, 1, 12, 24, 703, 2048, 1389],
      [ioc$dt_msxmd_3, 1, 21, 19, 1412, 2048, 794],
      [ioc$dt_ms5832_1, 1, 12, 4, 844, 4096, 410],
      [ioc$dt_ms5832_2, 1, 24, 4, 835, 4096, 819],
      [ioc$dt_ms5833_1, 1, 22, 7, 1629, 4096, 757],
      [ioc$dt_ms5833_1p, 1, 22, 7, 1629, 4096, 757],
      [ioc$dt_ms5833_2, 1, 42, 7, 1629, 4096, 397],
      [ioc$dt_ms5833_3p, 1, 33, 7, 1629, 8192, 505],
      [ioc$dt_ms5833_4, 1, 42, 7, 1629, 8192, 397],
      [ioc$dt_ms5838_1, 1, 18, 9, 2620, 4096, 622],
      [ioc$dt_ms5838_1p, 1, 18, 9, 2620, 4096, 622],
      [ioc$dt_ms5838_2, 1, 35, 9, 2620, 4096, 319],
      [ioc$dt_ms5838_3p, 1, 27, 9, 2620, 8192, 414],
      [ioc$dt_ms5838_4, 1, 35, 9, 2620, 8192, 319],
      [ioc$dt_ms47444_1, 1, 13, 15, 2290, 4096, 861],
      [ioc$dt_ms47444_1p, 1, 13, 15, 2290, 4096, 861],
      [ioc$dt_ms47444_2, 1, 25, 15, 2290, 4096, 448],
      [ioc$dt_ms47444_3p, 1, 19, 15, 2290, 8192, 589],
      [ioc$dt_ms47444_4, 1, 25, 15, 2290, 8192, 448]];
*DECK DECK=IOV$DISK_UNIT_USAGE_P EXPAND=FALSE

  VAR
    iov$disk_unit_usage_p: [XREF] ^iot$disk_unit_array;

?? PUSH (LISTEXT := ON) ??
*copyc iot$disk_usage
?? POP ??
*DECK DECK=IOV$ENFORCE_READ_PRIORITY EXPAND=FALSE
{ iov$enforce_read_priority}

   VAR
     iov$enforce_read_priority: [XREF] boolean;
*DECK DECK=IOV$ESTABLISH_TAPE_STATISTICS EXPAND=FALSE

{ DECK: IOV$ESTABLISH_TAPE_STATISTICS

  VAR
    iov$establish_tape_statistics : [XREF] boolean;

*DECK DECK=IOV$NUMBER_OF_TAPE_UNITS EXPAND=FALSE

{ DECK: IOV$NUMBER_OF_TAPE_UNITS

  VAR
    iov$number_of_tape_units: [XREF] iot$no_of_tape_units;

?? PUSH (LISTEXT := ON) ??
*copyc iot$no_of_tape_units
?? POP ??
*DECK DECK=IOV$PROCESS_DISK_RESPONSE EXPAND=FALSE
 VAR
    iov$process_disk_response: [XREF] iot$response_processor;

?? PUSH (LISTEXT := ON) ??
*copyc iot$io_request
?? POP ??
*DECK DECK=IOV$PROCESS_SUBSYSTEM_RESPONSE EXPAND=FALSE

      VAR
        iov$process_subsystem_response: [XREF] iot$response_processor;

?? PUSH (LISTEXT:=ON) ??
*copyc iot$io_request
?? POP ??
*DECK DECK=IOV$QUEUE_LOCKWORD_VALUES EXPAND=FALSE

      VAR
        iov$initial_queue_lock: [XREF] iot$lockword,
        iov$new_queue_lock: [XREF] iot$lockword;

??PUSH(LISTEXT:= ON)??
*copyc iot$lockword
??POP??
*DECK DECK=IOV$SUBSYS_PROCESS_PP_RESPONSE EXPAND=FALSE

     VAR
       iov$subsys_process_pp_response: [XREF] iot$response_processor;

?? PUSH (LISTEXT:= ON) ??
*copyc iot$io_request
?? POP ??
*DECK DECK=IOV$TAPE_COMPLETION_Q_TABLE EXPAND=FALSE

{ DECK: IOV$TAPE_COMPLETION_Q_TABLE

  VAR
    iov$tape_completion_q_table : [XREF] ^array [1 .. *] of iot$tape_completion_packet;

?? PUSH (LISTEXT := ON) ??
*copyc iot$tape_completion_packet
?? POP ??
*DECK DECK=IOV$TAPE_PROCESS_PP_RESPONSE EXPAND=FALSE
VAR
  iov$tape_process_pp_response: [XREF] iot$response_processor;

?? PUSH (LISTEXT := ON) ??
*copyc iot$io_request
?? POP ??
*DECK DECK=IOV$TAPE_SCAN_FREQUENCY EXPAND=FALSE

  VAR
    iov$tape_scan_frequency: [XREF] integer;
*DECK DECK=IOV$TIME_TO_LOG_USAGE_STATS EXPAND=FALSE

  VAR
    iov$time_to_log_usage_stats: [XREF] integer;
*DECK DECK=IOV$TUSL_LOCK EXPAND=FALSE

  VAR
    iov$tusl_lock: [XREF, oss$mainframe_pageable] ost$signature_lock;

*DECK DECK=IOV$TUSL_P EXPAND=FALSE
  VAR
    iov$tusl_p: [XREF] ^iot$tape_unit_status_list;

?? PUSH (LISTEXT := ON) ??
*copyc iot$tape_unit_status_list
?? POP ??
*DECK DECK=IPAUSE EXPAND=FALSE
          SPACE  3
 PAUSE    MACRO  X           DELAY X (1..127D) MSECS
          LOCAL  PAUSE1
          IFGT   X,127
          ERR                VALUE EXCEEDS 127D
          ENDIF
          LDC    X
          LPC    177B        ASSURE VALUE LE 127
          ZJN    PAUSE1      NO DELAY
          RJM    PAUS        PROCESS THE DELAY
 PAUSE1   BSS    0
          ENDM
*DECK DECK=IPM$SENCPR_PROGRAM_DESCRIPTION EXPAND=TRUE
create_program_description names=(send_cso_ph_request, sencpr) ..
      library=($system.tcp_ip.ipf$library) ..
      starting_procedure=ipp$cso_ph_client ..
      load_map=:$local.$null  load_map_options=none ..
      termination_error_level=warning  preset_value=zero  debug_mode=off
*DECK DECK=ISD EXPAND=TRUE
          IDENT  ISD
          CIPPU
          TITLE  ISD
          COMMENT *SMD* LVL=03
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 CONTYP   EQU    10           CONTROLLER TYPE
                               = 2, FOR 7154 CONTROLLER
                               = 3, FOR 7155-1 CONTROLLER
                               = 4, FOR 7155-1X CONTROLLER
                               = 5, FOR 7155-4X CONTROLLER, 170 CHANNEL
                               = 7, FOR 7155-4X CONTROLLER, 180 CHANNEL
                               = 10, FOR ISD SUBSYSTEM
*copyc IODISD
          END    ISD
/EOR
*DECK DECK=JMC$AJL_CALLER EXPAND=FALSE

  CONST
    jmc$swapping_ajl = 1,
    jmc$lock_ajl = 10(16);
*DECK DECK=JMC$ATTRIBUTE_KEYWORD_OFFSETS EXPAND=FALSE

{ Define the numerical offsets which represent the keywords, UNLIMITED,
{ UNSPECIFIED, REQUIRED, and SYSTEM_DEFAULT, used on SCL command parameter
{ values for scheduling attributes.  These offsets are used by the
{ Manage_Active_Scheduling Utility to facilitate the coding required to
{ translate the command parameter values to their internal format.


  CONST
    jmc$unlimited_offset = 1,
    jmc$unspecified_offset = 2,
    jmc$required_offset = 3,
    jmc$system_default_offset = 4,
    jmc$keyword_offset_maximum = jmc$system_default_offset;

*DECK DECK=JMC$CHANGE_ATTRIBUTE_DEFAULTS EXPAND=FALSE

  CONST
    jmc$change_attribute_defaults = 'JMP$CHANGE_ATTRIBUTE_DEFAULTS';
*DECK DECK=JMC$CHANGE_INPUT_ATTRIBUTES EXPAND=FALSE

  CONST
    jmc$change_input_attributes = 'JMP$CHANGE_INPUT_ATTRIBUTES';
*DECK DECK=JMC$CHANGE_JOB_ATTRIBUTES EXPAND=FALSE

  CONST
    jmc$change_job_attributes = 'JMC$CHANGE_JOB_ATTRIBUTES';
*DECK DECK=JMC$CHANGE_OUTPUT_ATTRIBUTES EXPAND=FALSE

  CONST
    jmc$change_output_attributes = 'JMC$CHANGE_OUTPUT_ATTRIBUTES';
*DECK DECK=JMC$CLASS_NAMES EXPAND=FALSE

  CONST
    jmc$all_class_name = 'ALL                            ',
    jmc$automatic_class_name = 'AUTOMATIC                      ',
    jmc$none_class_name = 'NONE                           ',
    jmc$null_class_name = '                               ',
    jmc$system_class_name = 'SYSTEM                         ',
    jmc$maintenance_class_name = 'MAINTENANCE                    ',
    jmc$interactive_class_name = 'INTERACTIVE                    ',
    jmc$batch_class_name = 'BATCH                          ',
    jmc$normal_class_name = 'NORMAL                         ',
    jmc$system_default_class_name = 'SYSTEM_DEFAULT                 ',
    jmc$unassigned_class_name = 'UNASSIGNED                     ',
    jmc$unknown_class_name = 'UNKNOWN                        ';
*DECK DECK=JMC$COMPILING_JOB_HISTORY_CLSP EXPAND=FALSE
*DECK DECK=JMC$CONDITION_LIMITS EXPAND=FALSE
*copyc jmc$condition_limits2

  CONST
    jmc$min_scc = jmc$min_ecc,
    jmc$max_scc = jmc$max_ecc;
*DECK DECK=JMC$CONDITION_LIMITS2 EXPAND=FALSE
  CONST
    jmc$max_ecc = jmc$min_ecc + 9999;

*copyc jmc$min_ecc
*DECK DECK=JMC$DEFAULT_FORMS_CODE EXPAND=FALSE

  CONST
    jmc$default_forms_code = 'NORMAL';

*DECK DECK=JMC$GENERIC_QUEUE_FULL_MESSAGE EXPAND=FALSE

  CONST
    jmc$generic_queue_full_message = 'WARNING - The NOS/VE generic queue is full.';
*DECK DECK=JMC$GET_ATTRIBUTE_DEFAULTS EXPAND=FALSE

  CONST
    jmc$get_attribute_defaults = 'JMP$GET_ATTRIBUTE_DEFAULTS';
*DECK DECK=JMC$GET_INPUT_ATTRIBUTES EXPAND=FALSE

  CONST
    jmc$get_input_attributes = 'JMP$GET_INPUT_ATTRIBUTES';
*DECK DECK=JMC$GET_JOB_ATTRIBUTES EXPAND=FALSE

  CONST
    jmc$get_job_attributes = 'JMP$GET_JOB_ATTRIBUTES';
*DECK DECK=JMC$GET_JOB_STATUS EXPAND=FALSE

  CONST
    jmc$get_job_status = 'JMP$GET_JOB_STATUS';
*DECK DECK=JMC$GET_OUTPUT_ATTRIBUTES EXPAND=FALSE

  CONST
    jmc$get_output_attributes = 'JMP$GET_OUTPUT_ATTRIBUTES';
*DECK DECK=JMC$GET_OUTPUT_STATUS EXPAND=FALSE

  CONST
    jmc$get_output_status = 'JMP$GET_OUTPUT_STATUS';
*DECK DECK=JMC$INPUT_QUEUE_FULL_MESSAGE EXPAND=FALSE

  CONST
    jmc$input_queue_full_message = 'WARNING - The NOS/VE input queue is full.';
*DECK DECK=JMC$JOB_MANAGEMENT_ID EXPAND=FALSE

{ This is the two character Job Management identifier for status conditions.

  CONST
    jmc$job_management_id = 'JM';
*DECK DECK=JMC$JOB_TIME_LIMIT_FLAG_ID EXPAND=FALSE
*DECK DECK=JMC$KJL_MAXIMUM_CLIENTS EXPAND=FALSE

  CONST
    jmc$kjl_maximum_clients = jmc$maximum_mainframes;

*copyc jmc$maximum_mainframes
*DECK DECK=JMC$KJL_MAXIMUM_ENTRIES EXPAND=FALSE

  CONST
    jmc$kjl_maximum_entries = jmc$maximum_job_count;

*copyc jmc$maximum_job_count
*DECK DECK=JMC$KJL_MAXIMUM_SERVERS EXPAND=FALSE

  CONST
    jmc$kjl_maximum_servers = jmc$maximum_mainframes;

*copyc jmc$maximum_mainframes
*DECK DECK=JMC$KOL_MAXIMUM_ENTRIES EXPAND=FALSE

  CONST
    jmc$kol_maximum_entries = jmc$maximum_output_count;

*copyc jmc$maximum_output_count
*DECK DECK=JMC$LOGOUT_FLAG_ID EXPAND=FALSE
*DECK DECK=JMC$MAXIMUM_CONSTANTS EXPAND=FALSE

  CONST
    jmc$max_active_jobs = jmc$max_ajl_ord - jmc$reserved_ajls,
    jmc$max_ajl_ord = 255,
    jmc$max_ijl_ord = jmc$kjl_maximum_entries,
    jmc$max_kjl_ord = jmc$kjl_maximum_entries,
    jmc$max_kol_ord = jmc$kol_maximum_entries,
    jmc$reserved_ajls = 5;

*copyc jmc$kjl_maximum_entries
*copyc jmc$kol_maximum_entries
*DECK DECK=JMC$MAXIMUM_INPUT_APPLICATIONS EXPAND=FALSE

{ This is the maximum number of applications to manipulate files from the
{ queue that can be active simultaneously.

  CONST
    jmc$maximum_input_applications = 10;

*DECK DECK=JMC$MAXIMUM_JOB_COUNT EXPAND=FALSE

{ This constant represents the maximum number of jobs that can be known
{   by the NOS/VE operating system.

  CONST
    jmc$maximum_job_count = 65535;
*DECK DECK=JMC$MAXIMUM_MAINFRAMES EXPAND=FALSE

{ The value of this variable must be less than or equal to the value of the
{ file server constant dfc$maximum_partner_mainframes.

  CONST
    jmc$maximum_mainframes = 32;

*copyc dft$partner_mainframe_list
*DECK DECK=JMC$MAXIMUM_OBJECTS_ON_PROFILE EXPAND=FALSE

  CONST
    jmc$maximum_objects_on_profile = 4095;

*DECK DECK=JMC$MAXIMUM_OUTPUT_APPLICATIONS EXPAND=FALSE

{ This is the maximum number of applications to manipulate files from the
{ queue that can be active simultaneously.

  CONST
    jmc$maximum_output_applications = 15;

*DECK DECK=JMC$MAXIMUM_OUTPUT_COUNT EXPAND=FALSE

{ This constant represents the maximum number of output files
{   that NOS/VE is capable of knowing at one time.

  CONST
    jmc$maximum_output_count = 65535;

*DECK DECK=JMC$MAXIMUM_QFILE_APPLICATIONS EXPAND=FALSE

{ This is the maximum number of applications to manipulate files from the
{ queue that can be active simultaneously.

  CONST
    jmc$maximum_qfile_applications = 100;

*DECK DECK=JMC$MAXIMUM_QFILE_COUNT EXPAND=FALSE
  CONST
    jmc$maximum_qfile_count = 65535;

*DECK DECK=JMC$MAXIMUM_SYSTEM_LABEL_LENGTH EXPAND=FALSE
{ This value represents the largest area that can be reserved for the label
{ for a job or output file in the file attribute area of a file.  The size
{ of this value cannot exceed two bytes in length.
{
{ WARNING!!!   If this value exceeds two bytes in length, a breakage will occur
{ in NOS/VE permanent files.  Do not exceed 0ffff(16), i.e. 65535.

  CONST
    jmc$maximum_system_label_length = 2fff(16);
*DECK DECK=JMC$MAX_COMPLETED_JOB_COUNT EXPAND=FALSE

{ This constant represents the maximum count of completed jobs that can
{ be accumulated since deadstart

  CONST
    jmc$max_completed_job_count = 0FFFFFF(16);
*DECK DECK=JMC$MIN_ECC EXPAND=FALSE

  CONST
*IF $true(osv$unix)
    jmc$min_ecc = (($INTEGER ('J') * 100(16)) + $INTEGER ('M')) * 10000(16);
*ELSE
    jmc$min_ecc = (($INTEGER ('J') * 100(16)) + $INTEGER ('M')) * 1000000(16);
*IFEND

*DECK DECK=JMC$NULL_AJL_ORDINAL EXPAND=FALSE

  CONST
    jmc$null_ajl_ordinal = jmc$max_ajl_ord;

*copyc jmc$maximum_constants
*DECK DECK=JMC$OUTPUT_QUEUE_FULL_MESSAGE EXPAND=FALSE

  CONST
    jmc$output_queue_full_message = 'WARNING - The NOS/VE output queue is full.';
*DECK DECK=JMC$PRINT_FILE EXPAND=FALSE

  CONST
    jmc$print_file = 'JMP$PRINT_FILE';
*DECK DECK=JMC$PROFILE_CONSTANTS EXPAND=FALSE

  CONST
    jmc$object_abbreviation = 1;


{ Constants for Job Category attributes

  CONST
    jmc$c_cpu_time_limit = 2,
    jmc$c_sru_limit = 3,
    jmc$c_magnetic_tape_limit = 4,
    jmc$c_maximum_working_set = 5,
    jmc$c_job_mode = 6,
    jmc$c_job_priority = 7,
    jmc$c_job_qualifier = 8,
    jmc$c_login_family = 9,
    jmc$c_login_user = 10,
    jmc$c_login_account = 11,
    jmc$c_login_project = 12,
    jmc$c_user_job_name = 13,
    jmc$c_origin_application_name = 14,
    jmc$c_data_display = 15,
    jmc$c_set_display = 16,
    jmc$c_maximum_attribute = 16;

{ Constants for Job Priority attributes

  CONST
    jmc$jp_initiation_bias = 2,
    jmc$jp_scheduling_bias = 3,
    jmc$jp_dispatching_bias = 4,
    jmc$jp_timeslice_bias = 5,
    jmc$jp_output_bias = 6,
    jmc$jp_maximum_attribute = 6;

{ Constants for Scheduler Controls attributes

  CONST

{  Definition Group

    jmc$ct_abbreviation = jmc$object_abbreviation,
    jmc$ct_cpu_quantum_time = 2,
    jmc$ct_service_calc_interval = 3,
    jmc$ct_idle_disp_queue_time = 4,
    jmc$ct_stat_reset_interval = 5,

{  Control Group

    jmc$ct_dual_state_prio_control = 9,
    jmc$ct_scheduling_memory_levels = 10,
    jmc$ct_enable_job_leveling = 11,
    jmc$ct_maximum_initiated_jobs = 12,
    jmc$ct_job_leveling_interval = 13,
    jmc$ct_ini_required_categories = 16,
    jmc$ct_ini_excluded_categories = 17,
    jmc$ct_dispatching_allocation = 18,
    jmc$ct_cpu_dispatching_interval = 19,

{  Membership Group

    jmc$ct_val_required_categories = 20,
    jmc$ct_val_excluded_categories = 21,

{  Priority Group

    jmc$ct_job_leveling_prio_bias = 22,

{  Statistics Group

    jmc$ct_profile_identification = 23,
    jmc$ct_maximum_attribute = 23;

{ Constants for Job Class attributes

  CONST

{  Definition Group

    jmc$jc_abbreviation = jmc$object_abbreviation,
    jmc$jc_prolog = 2,
    jmc$jc_epilog = 3,
    jmc$jc_enable_class_membership = 4,
    jmc$jc_enable_class_execution = 5,
    jmc$jc_enable_class_initiation = 6,
    jmc$jc_enable_immediate_aging = 7,
    jmc$jc_immediate_initiation_can = 8,
    jmc$jc_enable_latch_mode = 9,
    jmc$jc_initial_working_set = 10,
    jmc$jc_initial_service_class = 11,
    jmc$jc_valid_service_classes = 12,
    jmc$jc_default_output_class = 14,
    jmc$jc_valid_output_classes = 15,

{  Control Group

    jmc$jc_initiation_level = 20,
    jmc$jc_use_initiation_class = 21,
    jmc$jc_over_commitment_criteria = 22,
    jmc$jc_minimum_working_set = 23,
    jmc$jc_maximum_working_set = 24,
    jmc$jc_page_aging_interval = 25,
    jmc$jc_cyclic_aging_interval = 26,
    jmc$jc_class_capabilities = 27,
    jmc$jc_defer_on_submit = 28,

{  Limit Group

    jmc$jc_detached_job_wait_time = 30,
    jmc$jc_cpu_time_limit = 31,
    jmc$jc_sru_limit = 32,
    jmc$jc_magnetic_tape_limit = 33,

{  Membership Group

    jmc$jc_auto_class_selection = 35,
    jmc$jc_required_categories = 36,
    jmc$jc_excluded_categories = 37,

{  Priority Group

    jmc$jc_initiation_age_interval = 40,
    jmc$jc_selection_priority = 41,
    jmc$jc_class_priority_bias = 42,
    jmc$jc_job_leveling_prio_bias = 43,
    jmc$jc_multiple_job_bias = 44,

{  Statistic Group

    jmc$jc_queued_jobs = 45,
    jmc$jc_initiated_jobs = 46,
    jmc$jc_initiation_wait_time = 47,
    jmc$jc_processing_wait_time = 48,

    jmc$jc_definition_name = 49, { For debug only
    jmc$jc_index = 50, { For debug only
    jmc$jc_profile_index = 51, { For debug only
    jmc$jc_maximum_attribute = 51;

{ Constants for Service Class attributes

  CONST

{  Definition Group

    jmc$sc_abbreviation = jmc$object_abbreviation,
    jmc$sc_enable_class_execution = 2,

{  Control Group

    jmc$sc_maximum_active_jobs = 5,
    jmc$sc_service_factors = 6,
    jmc$sc_guaranteed_service_quan = 7,
    jmc$sc_class_resource_threshold = 8,
    jmc$sc_next_service_class = 9,
    jmc$sc_long_wait_think_time = 10,
    jmc$sc_aio_limit = 11,

{  Priority Group

    jmc$sc_dispatching_control = 15,
    jmc$sc_swap_age_interval = 16,
    jmc$sc_scheduling_priority = 17,

{  Statistic Group

    jmc$sc_active_jobs = 20,
    jmc$sc_queued_jobs = 21,
    jmc$sc_swapped_jobs = 22,
    jmc$sc_service_achieved_percent = 23,

    jmc$sc_definition_name = 24, { For debug only
    jmc$sc_index = 25, { For debug only
    jmc$sc_maximum_attribute = 25;

{ Constants for Output Class attributes

  CONST

{  Definition Group

    jmc$oc_abbreviation = jmc$object_abbreviation,
    jmc$oc_enable_class_scheduling = 2,

{  Control Group

    jmc$oc_class_capabilities = 3,

{  Membership Group

    jmc$oc_required_categories = 10,
    jmc$oc_excluded_categories = 11,
    jmc$oc_automatic_class_sel = 12,

{  Priority Group

    jmc$oc_output_age_interval = 15,
    jmc$oc_delivery_priority = 16,

{  Statistic Group

    jmc$oc_delivery_wait_time = 20,

    jmc$oc_definition_name = 21, { For debug only
    jmc$oc_index = 22, { For debug only
    jmc$oc_maximum_attribute = 22;

{ Constants for Application attributes

  CONST

{  Definition Group

    jmc$ap_enable_application_sched = 2,
    jmc$ap_enable_accounting_stats = 5,

{  Control Group

    jmc$ap_service_class = 10,
    jmc$ap_minimum_working_set = 11,
    jmc$ap_maximum_working_set = 12,
    jmc$ap_page_aging_interval = 13,
    jmc$ap_cyclic_aging_interval = 14,

{  Statistics group

    jmc$ap_active_application = 20,
    jmc$ap_definition_name = 21, { For debug only
    jmc$ap_maximum_attribute = 21;

*DECK DECK=JMC$SCHED_PROFILE_DEADSTART_ID EXPAND=FALSE
  CONST
    jmc$sched_profile_deadstart_id = 'DEADSTART                      ';

*DECK DECK=JMC$SPECIAL_DISPATCH_PRIORITIES EXPAND=FALSE
{
{ Define priorities for special system tasks and tasks in special states.
{

  CONST
    jmc$priority_system_job         = jmc$priority_p10,
    jmc$priority_job_scheduler      = jmc$priority_p11,
    jmc$priority_split_alloc        = jmc$priority_p12,
    jmc$priority_administer_log     = jmc$priority_p11,
    jmc$priority_volume_space_mgr   = jmc$priority_p10,
    jmc$priority_mli_helper         = jmc$priority_p13,

    jmc$prior_system_tbls_locked    = jmc$priority_p10,
    jmc$prior_subsystem_tbls_locked = jmc$priority_p9;

*copyc jmt$dispatching_priority
*DECK DECK=JMC$STATUS_MESSAGE_TEXT EXPAND=FALSE

  CONST
    jmc$smt_application = 'Application',
    jmc$smt_applications = 'Applications',
    jmc$smt_job_class = 'Job Class',
    jmc$smt_job_classes = 'Job Classes',
    jmc$smt_service_class = 'Service Class',
    jmc$smt_service_classes = 'Service Classes';

*DECK DECK=JMC$SUBMIT_DETACHED_JOBS EXPAND=FALSE
  CONST
    jmc$submit_detached_jobs = avc$submit_detached_jobs;

*copyc avc$validation_field_names

*DECK DECK=JMC$SUBMIT_JOB EXPAND=FALSE

  CONST
    jmc$submit_job = 'JMP$SUBMIT_JOB';
*DECK DECK=JMC$SYSTEM_FAMILY EXPAND=FALSE

  CONST
    jmc$system_family         = '$SYSTEM                        ',
    jmc$system_user           = '$SYSTEM                        ',
    jmc$nve_family            = '$NVE                           ',
    jmc$job_input_catalog     = '$JOB_INPUT_QUEUE               ',
    jmc$job_output_catalog    = '$JOB_OUTPUT_QUEUE              ',
    jmc$generic_queue_catalog = '$APPLICATION_QUEUE             ',
    jmc$job_swap_catalog      = '$JOB_SWAP_FILES                ',
    jmc$sf_job_input_catalog  = '$SF_JOB_INPUT_QUEUE            ',
    jmc$sf_job_output_catalog = '$SF_JOB_OUTPUT_QUEUE           ';

*DECK DECK=JMC$SYSTEM_SCHEDULING_PROFILE EXPAND=FALSE

  CONST
    jmc$scheduling_profile_family = '$SYSTEM                        ',
    jmc$scheduling_profile_user = '$SYSTEM                        ',
    jmc$scheduling_profile_catalog = 'SCHEDULING                     ',
    jmc$scheduling_profile_filename = 'OSF$SYSTEM_PROFILE             ',
    jmc$scheduling_profile_cycle = 2,
    jmc$scheduling_profile_pathname =
          ':$SYSTEM.$SYSTEM.SCHEDULING.OSF$SYSTEM_PROFILE',
    jmc$scheduling_profile_path_siz = 46,
    jmc$scheduling_profile_password = osc$null_name;

*copyc ost$name
*DECK DECK=JMC$TERMINATE_JOB EXPAND=FALSE

  CONST
    jmc$terminate_job = 'JMP$TERMINATE_JOB';
*DECK DECK=JMC$TERMINATE_OUTPUT EXPAND=FALSE

  CONST
    jmc$terminate_output = 'JMC$TERMINATE_OUTPUT';
*DECK DECK=JMD$JOB_RESOURCE_CONDITION EXPAND=FALSE

  CONST
    jmc$time_limit_condition = 1;

  TYPE
    jmt$job_resource_condition = pmt$condition_identifier;
*copyc PMT$CONDITION_IDENTIFIER
*DECK DECK=JMD$SRU_COUNT EXPAND=FALSE

  CONST
    jmc$sru_count_max = 0ffffffffffff(16);

  TYPE
    jmt$sru_count = 0 .. jmc$sru_count_max;
*DECK DECK=JME$ABBREVIATION_CHANGE_ILLEGAL EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$abbreviation_change_illegal = jmc$min_ecc + 7087;
    {E The abbreviation may be changed for only one object at a time.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$ABORT_BY_OPERATOR EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$abort_by_operator           = jmc$min_ecc + 4100;
    {F Terminated via the +P command.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$ACCESS_ID_MISMATCH EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$access_id_mismatch          = jmc$min_ecc + 1065;
    {E The access identification given does not match the one using the..
    { utility. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$ACTIVATE_PROFILE_ERRORS EXPAND=FALSE
?? NEWTITLE := '        :Profile Management: ''JM'' 7000 .. 7019', EJECT ??

{ This deck is maintained for compatibility only.  Do NOT change it.
{ When adding status conditions, create a new discrete error deck for the
{ condition then add a *copyc to the deck JME$EXCEPTION_CONDITION_CODES.

*copyc jmc$min_ecc
*copyc jme$unable_to_recover_profile
*copyc jme$major_profile_change
*copyc jme$system_profile_mismatch
*copyc jme$profile_is_too_large
*copyc jme$cannot_change_bad_profile
*copyc jme$no_controls_for_mainframe
*copyc jme$updated_only_tables
*copyc jme$job_resubmit_failed
?? OLDTITLE ??
*DECK DECK=JME$ANOTHER_UTILITY_IS_ACTIVE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$another_utility_is_active   = jmc$min_ecc + 1066;
    {E Another scheduling utility is currently active. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$APPLICATIONS_NOT_SORTED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$applications_not_sorted     = jmc$min_ecc + 1067;
    {E The application names are not sorted in ascending order. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$APPLICATION_NAME_INCORRECT EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$application_name_incorrect               = jmc$min_ecc + 4566;
    {E The application name +P is incorrect. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$APPLICATION_NAME_IN_USE EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$application_name_in_use                  = jmc$min_ecc + 4567;
    {E The application name +P is already in use by another application. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$APPLICATION_NOT_PERMITTED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$application_not_permitted   = jmc$min_ecc + 4510;
    {E The requesting application is not permitted access to output files
{ with a destination usage of +P. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$APPLICATION_TABLE_IS_FULL EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$application_table_is_full   = jmc$min_ecc + 4520;
    {E The maximum number of applications have already registered. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$BAD_SWAP_FILE_DESCRIPTOR EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$bad_swap_file_descriptor    = jmc$min_ecc + 1049;
    {E Corrupted data found in the swap file descriptor. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$BATCH_ACCESS_DENIED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$batch_access_denied         = jmc$min_ecc + 4545;
    {E User not valid for access to batch services. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CANNOT_ASSIGN_TO_JOB_CLASS EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$cannot_assign_to_job_class  = jmc$min_ecc + 7101;
    {E The attributes of this job prevent it from being assigned to the Job }
    {Class +P1.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CANNOT_CHANGE_BAD_PROFILE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$cannot_change_bad_profile   = jmc$min_ecc + 7005;
    {E The current profile can only be changed with activate_profile.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CANNOT_CHANGE_INTERACTIVE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$cannot_change_interactive   = jmc$min_ecc + 4322;
    {E The input attributes of an interactive mode job cannot be changed. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CANNOT_DETACH_XTERM_JOB EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$cannot_detach_xterm_job = jmc$min_ecc + 4387;
    {E An xterm job cannot be detached.}

?? FMT (FORMAT := ON) ??

*DECK DECK=JME$CANNOT_MOVE_UNASSIGNED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$cannot_move_unassigned      = jmc$min_ecc + 7084;
    {E The +P1 UNASSIGNED cannot be moved.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CANNOT_READ_PROFILE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$cannot_read_profile         = jmc$min_ecc + 7061;
    {E Cannot read profile +F.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CANT_IDLE_JOB_TASKS EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$cant_idle_job_tasks         = jmc$min_ecc + 1044;
    {E Ready tasks prevent job from being swapped.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CANT_RECOVER_JOB EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$cant_recover_job            = jmc$min_ecc + 4310;
    {E Can't recover +P job.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CANT_SPECIFY_BOTH_DO_AND_GO EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$cant_specify_both_do_and_go = jmc$min_ecc + 7046;
    {E The DISPLAY_OPTION and GROUP_OPTION parameters may not be used }
    {at the same time.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CANT_USE_$NULL EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$cant_use_$null              = jmc$min_ecc + 4350;
    {E $NULL cannot be used as input to this command. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CLASS_ABBREV_NOT_UNIQUE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$class_abbrev_not_unique     = jmc$min_ecc + 1068;
    {E The +P1 abbreviation +P2 is not unique. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CLASS_INDEX_ALREADY_IN_USE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$class_index_already_in_use  = jmc$min_ecc + 1069;
    {E The +P1 +P2 is already defined with class index +P. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CLASS_INDEX_CONFLICT EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$class_index_conflict        = jmc$min_ecc + 1070;
    {E The +P1 +P2 to be updated has an incorrect class index. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CLASS_INDEX_NOT_DEFINED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$class_index_not_defined     = jmc$min_ecc + 1071;
    {E The +P1 index +P2 is not defined. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CLASS_OR_APPL_NOT_DEFINED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$class_or_appl_not_defined   = jmc$min_ecc + 1072;
    {E The +P1 +P2 is not defined.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CLASS_OR_APPL_NOT_UNIQUE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$class_or_appl_not_unique    = jmc$min_ecc + 1073;
    {E The +P1 name +P2 is not unique. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CONDITION_ENCOUNTERED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$condition_encountered       = jmc$min_ecc + 1048;
    {E Condition handler invoked during swapfile update. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CURRENT_ACCUMULATOR_IS EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$current_accumulator_is      = jmc$min_ecc + 2020;
    {I Accumulator value is +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$CURRENT_OBJECT_UNDEFINED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$current_object_undefined    = jmc$min_ecc + 7045;
    {E +P is undefined.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$DATA_LENGTH_ZERO EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$data_length_zero            = jmc$min_ecc + 5060;
    {E A data transfer request has been given with amount to move equal zero.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$DELETE_CLASS_STILL_ACTIVE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$delete_class_still_active   = jmc$min_ecc + 1074;
    {E The scheduling profile cannot be activated because the +P1 +P2 being..
    { deleted has active jobs.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$DESTINATION_USAGE_INCORRECT EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$destination_usage_incorrect = jmc$min_ecc + 4505;
    {E The destination usage +P is incorrect. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$DESTINATION_USAGE_IN_USE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$destination_usage_in_use    = jmc$min_ecc + 4515;
    {E The destination_usage +P is already in use by another application. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$DUPLICATE_ABBREVIATION EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$duplicate_abbreviation      = jmc$min_ecc + 7086;
    {E The abbreviation +P1 is already being used.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$DUPLICATE_ATTRIBUTE_KEY EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$duplicate_attribute_key     = jmc$min_ecc + 4290;
    {E The key +P was specified more than once for the +P parameter on the
{ +P request. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$DUPLICATE_CATEGORIES EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$duplicate_categories        = jmc$min_ecc + 7085;
    {E Duplicate categories in the excluded and required lists for +P2 +P1.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$DUPLICATE_NAME EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$duplicate_name              = jmc$min_ecc + 4120;
    {E Multiple names of +P were found. Use system supplied name to be unique.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$END_OF_LOG_REACHED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$end_of_log_reached          = jmc$min_ecc + 6005;
    {E End of HISTORY log reached.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$ENTRY_NOT_FOUND EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$entry_not_found             = jmc$min_ecc + 4030;
    {E The entry +P was not found.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$ERROR_IN_JOB_CLASS_RANKING EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$error_in_job_class_ranking  = jmc$min_ecc + 1075;
    {E The ranking of the job classes is incorrect.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$EXCEPTION_CONDITION_CODES EXPAND=FALSE
?? NEWTITLE := 'JMDECC  : JOB MANAGEMENT       : ''JM'' 0 .. 9999', EJECT ??
*copyc jmc$min_ecc
*copyc jme$illegal_system_job_command  "JM       5
*copyc jme$job_terminating_normally    "JM      10
*copyc jme$job_end_called_unexpectedly "JM      15
*copyc jme$self_terminating_job        "JM      20
*copyc jme$job_initiated_too_late      "JM      25
*copyc jme$job_terminated_via_command  "JM      30
*copyc jme$login_error_in_prolog       "JM      40
*copyc jme$login_abort_in_prolog       "JM      45
*copyc jme$non_existent_job            "JM    1010
*copyc jme$job_not_in_swap_list        "JM    1020
*copyc jme$job_cant_be_swapped         "JM    1030
*copyc jme$swap_buffer_full            "JM    1031
*copyc jme$job_in_memory_or_swapin     "JM    1032
*copyc jme$job_status_non_swappable    "JM    1033
*copyc jme$wrong_display               "JM    1040
*copyc jme$no_swapped_jobs             "JM    1041
*copyc jme$unknown_class               "JM    1042
*copyc jme$swapping_not_allowed        "JM    1043
*copyc jme$cant_idle_job_tasks         "JM    1044
*copyc jme$job_dead_cannot_swap        "JM    1045
*copyc jme$no_free_ajl_ordinals        "JM    1046
*copyc jme$system_not_idle             "JM    1047
*copyc jme$condition_encountered       "JM    1048
*copyc jme$bad_swap_file_descriptor    "JM    1049
*copyc jme$invalid_dispatch_priority   "JM    1056
*copyc jme$swapin_with_maxaj_zero      "JM    1058
*copyc jme$access_id_mismatch          "JM    1065
*copyc jme$another_utility_is_active   "JM    1066
*copyc jme$applications_not_sorted     "JM    1067
*copyc jme$class_abbrev_not_unique     "JM    1068
*copyc jme$class_index_already_in_use  "JM    1069
*copyc jme$class_index_conflict        "JM    1070
*copyc jme$class_index_not_defined     "JM    1071
*copyc jme$class_or_appl_not_defined   "JM    1072
*copyc jme$class_or_appl_not_unique    "JM    1073
*copyc jme$delete_class_still_active   "JM    1074
*copyc jme$error_in_job_class_ranking  "JM    1075
*copyc jme$excess_class_in_sched_table "JM    1076
*copyc jme$job_class_not_defined       "JM    1077
*copyc jme$must_be_scheduling_admin    "JM    1078
*copyc jme$no_delete_of_default_class  "JM    1080
*copyc jme$no_element_in_sequence      "JM    1081
*copyc jme$no_ranking_of_default_class "JM    1082
*copyc jme$no_space_in_runtime_stack   "JM    1083
*copyc jme$no_utility_is_active        "JM    1084
*copyc jme$profile_cannot_be_read      "JM    1085
*copyc jme$profile_cycle2_lost         "JM    1086
*copyc jme$profile_id_mismatch         "JM    1087
*copyc jme$profile_not_installed       "JM    1088
*copyc jme$profile_too_large           "JM    1089
*copyc jme$service_class_not_defined   "JM    1092
*copyc jme$table_lengths_from_profile  "JM    1093
*copyc jme$unknown_class_kind          "JM    1094
*copyc jme$use_adms_or_manas_utility   "JM    1095
*copyc jme$use_adms_utility            "JM    1096
*copyc jme$invalid_scheduler_request   "JM    1097
*copyc jme$job_in_ready_task_state     "JM    1098
*copyc jme$job_has_no_ready_tasks      "JM    1099
*copyc jme$job_message_error           "JM    2001
*copyc jme$resource_condition          "JM    2005
*copyc jme$time_limit_condition        "JM    2010
*copyc jme$maximum_limit_is            "JM    2015
*copyc jme$current_accumulator_is      "JM    2020
*copyc jme$increment_prompt            "JM    2040
*copyc jme$increment_range             "JM    2045
*copyc jme$job_reconnected             "JM    2050
*copyc jme$not_integer_or_logout       "JM    2055
*copyc jme$pause_break_ignored         "JM    2060
*copyc jme$terminate_break_ignored     "JM    2065
*copyc jme$served_family_unavailable   "JM    2066
*copyc jme$job_not_found               "JM    4010
*copyc jme$file_not_found              "JM    4020
*copyc jme$entry_not_found             "JM    4030
*copyc jme$tried_to_self_destruct      "JM    4040
*copyc jme$job_cannot_be_terminated    "JM    4041
*copyc jme$missing_parameter           "JM    4050
*copyc jme$invalid_parameter           "JM    4060
*copyc jme$invalid_parameter_value     "JM    4061
*copyc jme$invalid_keyword             "JM    4070
*copyc jme$special_privilege_required  "JM    4080
*copyc jme$job_owner_only              "JM    4090
*copyc jme$abort_by_operator           "JM    4100
*copyc jme$name_not_found              "JM    4110
*copyc jme$duplicate_name              "JM    4120
*copyc jme$multiple_detached_jobs      "JM    4121
*copyc jme$must_be_operator            "JM    4130
*copyc jme$requires_operator_privilege "JM    4131
*copyc jme$maximum_jobs                "JM    4140
*copyc jme$no_space_for_file           "JM    4145
*copyc jme$maximum_output              "JM    4150
*copyc jme$output_queue_is_empty       "JM    4160
*copyc jme$input_queue_is_empty        "JM    4161
*copyc jme$temp_err1                   "JM    4170
*copyc jme$write_job_system_label      "JM    4180
*copyc jme$write_output_system_label   "JM    4185
*copyc jme$read_job_system_label       "JM    4190
*copyc jme$read_output_system_label    "JM    4195
*copyc jme$job_already_terminated      "JM    4200
*copyc jme$job_forced_out_of_memory    "JM    4201
*copyc jme$job_has_a_hung_task         "JM    4202
*copyc jme$job_damaged_during_recovery "JM    4203
*copyc jme$output_already_terminated   "JM    4210
*copyc jme$no_user_name_specified      "JM    4215
*copyc jme$job_state_is_null           "JM    4220
*copyc jme$no_jobs_were_found          "JM    4230
*copyc jme$no_outputs_were_found       "JM    4240
*copyc jme$result_array_too_small      "JM    4250
*copyc jme$output_state_is_null        "JM    4260
*copyc jme$sl_version_mismatch         "JM    4270
*copyc jme$illegal_ssn                 "JM    4280
*copyc jme$illegal_usn                 "JM    4285
*copyc jme$duplicate_attribute_key     "JM    4290
*copyc jme$input_was_recovered         "JM    4297
*copyc jme$input_was_not_recovered     "JM    4298
*copyc jme$job_recovery_or_abort_set   "JM    4299
*copyc jme$unable_to_recover_catalog   "JM    4300
*copyc jme$job_was_recovered           "JM    4301
*copyc jme$job_was_not_recovered       "JM    4302
*copyc jme$output_was_recovered        "JM    4303
*copyc jme$output_was_not_recovered    "JM    4304
*copyc jme$must_be_system_job          "JM    4305
*copyc jme$cant_recover_job            "JM    4310
*copyc jme$invalid_job_class           "JM    4315
*copyc jme$output_is_initiated         "JM    4320
*copyc jme$input_is_initiated          "JM    4321
*copyc jme$cannot_change_interactive   "JM    4322
*copyc jme$output_is_terminated        "JM    4325
*copyc jme$output_cannot_initiate      "JM    4330
*copyc jme$input_cannot_initiate       "JM    4331
*copyc jme$permanent_file_required     "JM    4340
*copyc jme$cant_use_$null              "JM    4350
*copyc jme$value_out_of_range          "JM    4360
*copyc jme$invalid_working_set_size    "JM    4365
*copyc jme$invalid_data_mode           "JM    4370
*copyc jme$invalid_paired_connection   "JM    4375
*copyc jme$job_is_in_termination       "JM    4380
*copyc jme$user_requested_exit         "JM    4381
*copyc jme$incompatible_network_origin "JM    4382
*copyc jme$terminal_timeout_message    "JM    4383
*copyc jme$task_is_in_termination      "JM    4384
*copyc jme$transaction_job_disconnect  "JM    4385
*copyc jme$unlimited_timeout_message   "JM    4386
*copyc jme$cannot_detach_xterm_job     "JM    4387
*copyc jme$recompilation_required      "JM    4400
*copyc jme$latest_print_time_expired   "JM    4405
*copyc jme$invalid_output_state        "JM    4500
*copyc jme$invalid_job_state           "JM    4501
*copyc jme$destination_usage_incorrect "JM    4505
*copyc jme$application_not_permitted   "JM    4510
*copyc jme$destination_usage_in_use    "JM    4515
*copyc jme$application_table_is_full   "JM    4520
*copyc jme$vsn_or_vsnp_or_bf_required  "JM    4521
*copyc jme$vsn_vsnp_vsns_bf_required   "JM    4522
*copyc jme$parameter_required_when     "JM    4525
*copyc jme$interactive_job_discarded   "JM    4530
*copyc jme$not_all_jobs_were_moved     "JM    4535
*copyc jme$scheduling_profile_changed  "JM    4540
*copyc jme$batch_access_denied         "JM    4545
*copyc jme$interactive_access_denied   "JM    4550
*copyc jme$unknown_requestor           "JM    4554
*copyc jme$leveler_not_responding      "JM    4555
*copyc jme$not_validated_for_copof     "JM    4556
*copyc jme$operator_queue_backup       "JM    4557
*copyc jme$operator_queue_restore      "JM    4558
*copyc jme$incompatible_vsn_params     "JM    4559
*copyc jme$internal_work_area_overflow "JM    4560
*copyc jme$vsn_or_vsnp_required        "JM    4561
*copyc jme$vsn_vsnp_vsns_required      "JM    4562
*copyc jme$job_deleted_via_command     "JM    4563
*copyc jme$output_deleted_via_command  "JM    4564
*copyc jme$work_area_too_small         "JM    4565
*copyc jme$application_name_incorrect  "JM    4566
*copyc jme$application_name_in_use     "JM    4567
*copyc jme$generic_queue_is_empty      "JM    4568
*copyc jme$invalid_destination         "JM    4569
*copyc jme$invalid_rhd                 "JM    4570
*copyc jme$latest_run_time_expired     "JM    4571
*copyc jme$maximum_generic_qfiles      "JM    4572
*copyc jme$no_qfiles_were_found        "JM    4573
*copyc jme$qfile_already_terminated    "JM    4574
*copyc jme$qfile_appl_not_permitted    "JM    4575
*copyc jme$qfile_cannot_initiate       "JM    4576
*copyc jme$qfile_is_initiated          "JM    4577
*copyc jme$qfile_is_terminated         "JM    4578
*copyc jme$qfile_state_is_null         "JM    4579
*copyc jme$qfile_was_not_recovered     "JM    4580
*copyc jme$qfile_was_recovered         "JM    4581
*copyc jme$read_qfile_system_label     "JM    4582
*copyc jme$write_qfile_system_label    "JM    4583
*copyc jme$system_label_internal_error "JM    4584
*copyc jme$job_template_not_found      "JM    5010
*copyc jme$no_binding_segment          "JM    5020
*copyc jme$template_corrupted          "JM    5030
*copyc jme$tasking_segs_mismatch       "JM    5040
*copyc jme$template_pointer_nil        "JM    5050
*copyc jme$data_length_zero            "JM    5060
*copyc jme$unknown_command             "JM    5070
*copyc jme$job_temp_sys_core_mismatch  "JM    5080
*copyc jme$end_of_log_reached          "JM    6005
*copyc jme$no_space_for_allocate       "JM    6010
*copyc jme$jh_internal_error           "JM    6015
*copyc jme$jh_no_jobs_to_display       "JM    6020
*copyc jme$jh_job_history_not_active   "JM    6025
*copyc jme$unable_to_recover_profile   "JM    7001
*copyc jme$major_profile_change        "JM    7002
*copyc jme$system_profile_mismatch     "JM    7003
*copyc jme$profile_is_too_large        "JM    7004
*copyc jme$cannot_change_bad_profile   "JM    7005
*copyc jme$no_controls_for_mainframe   "JM    7006
*copyc jme$updated_only_tables         "JM    7007
*copyc jme$job_resubmit_failed         "JM    7008
*copyc jme$invalid_attribute_keyword   "JM    7021
*copyc jme$invalid_attribute_value     "JM    7022
*copyc jme$wrong_kind_of_value         "JM    7023
*copyc jme$invalid_subattr_keyword     "JM    7024
*copyc jme$invalid_subattribute_value  "JM    7025
*copyc jme$wrong_kind_of_subvalue      "JM    7026
*copyc jme$subvalue_out_of_range       "JM    7027
*copyc jme$unknown_attribute           "JM    7041
*copyc jme$unknown_group_name          "JM    7042
*copyc jme$parameter_has_no_value      "JM    7043
*copyc jme$parameter_too_complex       "JM    7044
*copyc jme$current_object_undefined    "JM    7045
*copyc jme$cant_specify_both_do_and_go "JM    7046
*copyc jme$cannot_read_profile         "JM    7061
*copyc jme$object_not_known            "JM    7081
*copyc jme$object_already_known        "JM    7082
*copyc jme$too_many_objects            "JM    7083
*copyc jme$cannot_move_unassigned      "JM    7084
*copyc jme$duplicate_categories        "JM    7085
*copyc jme$duplicate_abbreviation      "JM    7086
*copyc jme$abbreviation_change_illegal "JM    7087
*copyc jme$profile_object_referenced   "JM    7088
*copyc jme$permanent_object            "JM    7089
*copyc jme$item_to_delete_is_missing   "JM    7090
*copyc jme$item_to_add_is_present      "JM    7091
*copyc jme$percent_sums_over_100       "JM    7092
*copyc jme$cannot_assign_to_job_class  "JM    7101
*copyc jme$no_mainframe_found_for_job  "JM    7102
*copyc jme$no_job_class_found_for_job  "JM    7103
*copyc jme$job_class_does_not_exist    "JM    7104
*copyc jme$job_qualifier_not_valid     "JM    7105
*copyc jme$profile_internal_error      "JM    7120
*copyc jme$function_has_no_value       "JM    7121
*copyc jme$unable_to_alloc_all_space   "JM    7122
?? OLDTITLE ??

*DECK DECK=JME$EXCESS_CLASS_IN_SCHED_TABLE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$excess_class_in_sched_table = jmc$min_ecc + 1076;
    {E The +P1 +P2 in the scheduler table is not in the profile being..
    { installed.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$FILE_NOT_FOUND EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$file_not_found              = jmc$min_ecc + 4020;
    {E The file +P was not found.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$FUNCTION_HAS_NO_VALUE EXPAND=FALSE
*copyc jmc$condition_limits2
?? NEWTITLE := 'jme$function_has_no_value      : ''JM'' 7121', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    jme$function_has_no_value       = jmc$min_ecc + 7121;
    {E No default currently exists for +p.

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=JME$GENERIC_QUEUE_IS_EMPTY EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$generic_queue_is_empty                   = jmc$min_ecc + 4568;
    {E There are no files in the queue. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$ILLEGAL_SSN EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$illegal_ssn                 = jmc$min_ecc + 4280;
    {E The name +P is an illegal SYSTEM SUPPLIED NAME.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$ILLEGAL_SYSTEM_JOB_COMMAND EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$illegal_system_job_command  = jmc$min_ecc + 5;
    {E +P command is illegal for System Job.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$ILLEGAL_USN EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$illegal_usn                 = jmc$min_ecc + 4285;
    {E It is improper to use +P as a user supplied name.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INCOMPATIBLE_NETWORK_ORIGIN EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$incompatible_network_origin = jmc$min_ecc + 4382;
    {E The job +P cannot be attached because it originated from a
{ non-compatible network. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INCOMPATIBLE_VSN_PARAMS EXPAND=FALSE
*copyc JMC$CONDITION_LIMITS2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$incompatible_vsn_params   = jmc$min_ecc + 4559;
    {E The combination of VSN list parameters is incompatible. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INCREMENT_PROMPT EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$increment_prompt            = jmc$min_ecc + 2040;
    {I Please enter an integer increment or TERMINATE_COMMAND or LOGOUT.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INCREMENT_RANGE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$increment_range             = jmc$min_ecc + 2045;
    {I The integer increment must be in the range +P to +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INPUT_CANNOT_INITIATE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$input_cannot_initiate       = jmc$min_ecc + 4331;
    {E The input file requested cannot be initiated and must be reacquired. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INPUT_IS_INITIATED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$input_is_initiated          = jmc$min_ecc + 4321;
    {E The input file +P has been initiated and cannot be changed. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INPUT_QUEUE_IS_EMPTY EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$input_queue_is_empty        = jmc$min_ecc + 4161;
    {E There are no jobs in the input queue.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INPUT_WAS_NOT_RECOVERED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$input_was_not_recovered     = jmc$min_ecc + 4298;
    {I The input file +P was not recovered.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INPUT_WAS_RECOVERED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$input_was_recovered         = jmc$min_ecc + 4297;
    {I The input file +P was recovered.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INTERACTIVE_ACCESS_DENIED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$interactive_access_denied   = jmc$min_ecc + 4550;
    {E User not valid for access to interactive services. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INTERACTIVE_JOB_DISCARDED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$interactive_job_discarded   = jmc$min_ecc + 4530;
    {E Interactive job discarded because it could not be reassigned to a..
    { Job Class. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INTERNAL_WORK_AREA_OVERFLOW EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$internal_work_area_overflow              = jmc$min_ecc + 4560;
    {E NIL pointer occurred accessing an internal job management work area. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INVALID_ATTRIBUTE_KEYWORD EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$invalid_attribute_keyword   = jmc$min_ecc + 7021;
    {E Specifying the key +P for parameter +P is not meaningful.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INVALID_ATTRIBUTE_VALUE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$invalid_attribute_value     = jmc$min_ecc + 7022;
    {E The value specified for the parameter +P request is invalid.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INVALID_DATA_MODE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$invalid_data_mode           = jmc$min_ecc + 4370;
    {E A data_mode of transparent is not valid with a destination_usage of
{ dual_state. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INVALID_DESTINATION EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$invalid_destination                      = jmc$min_ecc + 4569;
    {E A null destination is invalid with the application_name QTF. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INVALID_DISPATCH_PRIORITY EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$invalid_dispatch_priority   = jmc$min_ecc + 1056;
    {E The specified dispatching priority is invalid. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INVALID_JOB_CLASS EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$invalid_job_class           = jmc$min_ecc + 4315;
    {E +P is not a valid job class. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INVALID_JOB_STATE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$invalid_job_state           = jmc$min_ecc + 4501;
    {E The specified job state is invalid. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INVALID_KEYWORD EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$invalid_keyword             = jmc$min_ecc + 4070;
    {E Invalid keyword for +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INVALID_OUTPUT_STATE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$invalid_output_state        = jmc$min_ecc + 4500;
    {E The specified output state is invalid. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INVALID_PAIRED_CONNECTION EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$invalid_paired_connection   = jmc$min_ecc + 4375;
    {F The paired connection data is invalid.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INVALID_PARAMETER EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$invalid_parameter           = jmc$min_ecc + 4060;
    {E Specifying the key +P for the +P parameter on the +P request is not
{ meaningful or it is not supported at this time. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INVALID_PARAMETER_VALUE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$invalid_parameter_value     = jmc$min_ecc + 4061;
    {E The value specified for the key +P for the +P parameter on the +P
{ request is not meaningful or it is not supported at this time. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INVALID_RHD EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$invalid_rhd                              = jmc$min_ecc + 4570;
    {E A null remote_host_directive is invalid with the application_name QTF. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INVALID_SCHEDULER_REQUEST EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$invalid_scheduler_request   = jmc$min_ecc + 1097;
    {E An invalid scheduler monitor sub_request was specified.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INVALID_SUBATTRIBUTE_VALUE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$invalid_subattribute_value  = jmc$min_ecc + 7025;
    {E The value specified for +P3 of parameter +P1 request is invalid.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INVALID_SUBATTR_KEYWORD EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$invalid_subattr_keyword     = jmc$min_ecc + 7024;
    {E Specifying the key +P1 for +P2 of parameter +P3 is not meaningful.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$INVALID_WORKING_SET_SIZE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$invalid_working_set_size    = jmc$min_ecc + 4365;
    {E It is not valid to have a minimum_working_set value greater than the
{ maximum_working_set value. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$ITEM_TO_ADD_IS_PRESENT EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$item_to_add_is_present      = jmc$min_ecc + 7091;
    {E The +P2 +P1 already is present in the list.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$ITEM_TO_DELETE_IS_MISSING EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$item_to_delete_is_missing   = jmc$min_ecc + 7090;
    {E The +P2 +P1 is missing from the list.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JH_INTERNAL_ERROR EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$jh_internal_error           = jmc$min_ecc + 6015;
    {E Internal error processing HISTORY.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JH_JOB_HISTORY_NOT_ACTIVE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$jh_job_history_not_active   = jmc$min_ecc + 6025;
    {E Job History is not activated in the system.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JH_NO_JOBS_TO_DISPLAY EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$jh_no_jobs_to_display       = jmc$min_ecc + 6020;
    {E Requested job not found in HISTORY log.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_ALREADY_TERMINATED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_already_terminated      = jmc$min_ecc + 4200;
    {E Job +P has already been terminated via command.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_CANNOT_BE_TERMINATED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_cannot_be_terminated    = jmc$min_ecc + 4041;
    {E The job +P cannot be terminated.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_CANT_BE_SWAPPED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_cant_be_swapped         = jmc$min_ecc + 1030;
    {E The job cannot be swapped out now.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_CATEGORIZATION_ERRORS EXPAND=FALSE
?? NEWTITLE := 'Job categorization errors  : ''JM'' 7100 .. 7119', EJECT ??

{ This deck is maintained for compatibility only.  Do NOT change it.
{ When adding status conditions, create a new discrete error deck for the
{ condition then add a *copyc to the deck JME$EXCEPTION_CONDITION_CODES.

*copyc jmc$min_ecc
*copyc jme$cannot_assign_to_job_class
*copyc jme$no_mainframe_found_for_job
*copyc jme$no_job_class_found_for_job
*copyc jme$job_class_does_not_exist
*copyc jme$job_qualifier_not_valid
?? OLDTITLE ??
*DECK DECK=JME$JOB_CLASS_DOES_NOT_EXIST EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_class_does_not_exist    = jmc$min_ecc + 7104;
    {E The Job Class +P1 does not exist.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_CLASS_NOT_DEFINED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_class_not_defined       = jmc$min_ecc + 1077;
    {E The job class specified is not defined.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_DAMAGED_DURING_RECOVERY EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_damaged_during_recovery = jmc$min_ecc + 4203;
    {W The job +p was damaged during job recovery and cannot be swapped in
    { or terminated.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_DEAD_CANNOT_SWAP EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_dead_cannot_swap        = jmc$min_ecc + 1045;
    {E Job is dead because of io or recovery errors, and cannot be swapped.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_DELETED_VIA_COMMAND EXPAND=FALSE
*copyc JMC$CONDITION_LIMITS2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_deleted_via_command  = jmc$min_ecc + 4563;
    {E Job file deleted via a TERMINATE_JOB command.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_END_CALLED_UNEXPECTEDLY EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_end_called_unexpectedly = jmc$min_ecc + 15;
    {I JOB_END called unexpectedly.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_FORCED_OUT_OF_MEMORY EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_forced_out_of_memory    = jmc$min_ecc + 4201;
    {W The job +P has been forced out of memory and cannot be terminated.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_HAS_A_HUNG_TASK EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_has_a_hung_task         = jmc$min_ecc + 4202;
    {W The job +P has a task that cannot be terminated therefore the job
    { cannot be terminated.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_HAS_NO_READY_TASKS EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_has_no_ready_tasks      = jmc$min_ecc + 1099;
    {W Job has no ready tasks so will not be swapped in.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_HISTORY_CONDITIONS EXPAND=FALSE
?? NEWTITLE := 'JMDEJH  :          Job History: ''JM'' 6000 .. 6999', EJECT ??

{ This deck is maintained for compatibility only.  Do NOT change it.
{ When adding status conditions, create a new discrete error deck for the
{ condition then add a *copyc to the deck JME$EXCEPTION_CONDITION_CODES.

*copyc jmc$min_ecc
*copyc jme$end_of_log_reached
*copyc jme$no_space_for_allocate
*copyc jme$jh_internal_error
*copyc jme$jh_no_jobs_to_display
*copyc jme$jh_job_history_not_active
?? OLDTITLE ??
*DECK DECK=JME$JOB_INITIATED_TOO_LATE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_initiated_too_late      = jmc$min_ecc + 25;
    {I The job was not initiated before its latest time.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_IN_MEMORY_OR_SWAPIN EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_in_memory_or_swapin     = jmc$min_ecc + 1032;
    {E Job is in memory or is being swapped in.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_IN_READY_TASK_STATE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_in_ready_task_state     = jmc$min_ecc + 1098;
    {E Job is in a ready task state now but swapout will continue later.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_IS_IN_TERMINATION EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_is_in_termination       = jmc$min_ecc + 4380;
    {E The requested operation cannot be performed when the job is in
{ termination. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_MANAGEMENT_CONDITIONS EXPAND=FALSE
?? NEWTITLE := 'JME$JOB_MANAGEMENT_CONDITIONS :  ''JM'' 2000 .. 2065' ??

{ This deck is maintained for compatibility only.  Do NOT change it.
{ When adding status conditions, create a new discrete error deck for the
{ condition then add a *copyc to the deck JME$EXCEPTION_CONDITION_CODES.

*copyc jmc$min_ecc
*copyc jme$resource_condition
*copyc jme$time_limit_condition
*copyc jme$maximum_limit_is
*copyc jme$current_accumulator_is
*copyc jme$increment_prompt
*copyc jme$increment_range
*copyc jme$job_reconnected
*copyc jme$not_integer_or_logout
*copyc jme$pause_break_ignored
*copyc jme$terminate_break_ignored
?? OLDTITLE ??
*DECK DECK=JME$JOB_MESSAGE_ERROR EXPAND=FALSE
*copyc jmc$condition_limits2

?? FMT (FORMAT := OFF) ??

    CONST
      jme$job_message_error         = jmc$min_ecc + 2001;
      {E The job message could not be delivered to the target mainframe.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_MONITOR_CONDITIONS EXPAND=FALSE
?? NEWTITLE := 'JMDEMTR :          Job Monitor : ''JM'' 0 .. 10999', EJECT ??

{ This deck is maintained for compatibility only.  Do NOT change it.
{ When adding status conditions, create a new discrete error deck for the
{ condition then add a *copyc to the deck JME$EXCEPTION_CONDITION_CODES.

*copyc jmc$min_ecc
*copyc jme$illegal_system_job_command
*copyc jme$job_terminating_normally
*copyc jme$job_end_called_unexpectedly
*copyc jme$self_terminating_job
*copyc jme$job_initiated_too_late
*copyc jme$job_terminated_via_command
*copyc jme$login_error_in_prolog
*copyc jme$login_abort_in_prolog
?? OLDTITLE ??
*DECK DECK=JME$JOB_NOT_FOUND EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_not_found               = jmc$min_ecc + 4010;
    {E The job +P was not found.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_NOT_IN_SWAP_LIST EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_not_in_swap_list        = jmc$min_ecc + 1020;
    {E The job being swapped in is not in swap list.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_ON_ANOTHER_MAINFRAME EXPAND=FALSE
*DECK DECK=JME$JOB_OWNER_ONLY EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_owner_only              = jmc$min_ecc + 4090;
    {E Only the owner can say +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_QUALIFIER_NOT_VALID EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_qualifier_not_valid     = jmc$min_ecc + 7105;
    {E The Job Qualifier +P1 is not valid.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_RECONNECTED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_reconnected             = jmc$min_ecc + 2050;
    {I Job has been reconnected to this terminal.'}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_RECOVERY_OR_ABORT_SET EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_recovery_or_abort_set   = jmc$min_ecc + 4299;
    {I The job_recovery_disposition or the job_abort_disposition indicated that
{ the job should be +P. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_RESUBMIT_FAILED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_resubmit_failed         = jmc$min_ecc + 7008;
    {W The job +P1 had the following error when resubmitted.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_SCHEDULER_CONDITIONS EXPAND=FALSE
?? NEWTITLE := 'Job Scheduler : ''JM'' 1000 .. 1999', EJECT ??

{ This deck is maintained for compatibility only.  Do NOT change it.
{ When adding status conditions, create a new discrete error deck for the
{ condition then add a *copyc to the deck JME$EXCEPTION_CONDITION_CODES.

*copyc jmc$min_ecc
*copyc jme$non_existent_job
*copyc jme$job_not_in_swap_list
*copyc jme$job_cant_be_swapped
*copyc jme$swap_buffer_full
*copyc jme$job_in_memory_or_swapin
*copyc jme$job_status_non_swappable
*copyc jme$wrong_display
*copyc jme$no_swapped_jobs
*copyc jme$unknown_class
*copyc jme$swapping_not_allowed
*copyc jme$cant_idle_job_tasks
*copyc jme$job_dead_cannot_swap
*copyc jme$no_free_ajl_ordinals
*copyc jme$system_not_idle
*copyc jme$condition_encountered
*copyc jme$bad_swap_file_descriptor
*copyc jme$invalid_dispatch_priority
*copyc jme$swapin_with_maxaj_zero
*copyc jme$access_id_mismatch
*copyc jme$another_utility_is_active
*copyc jme$applications_not_sorted
*copyc jme$class_abbrev_not_unique
*copyc jme$class_index_already_in_use
*copyc jme$class_index_conflict
*copyc jme$class_index_not_defined
*copyc jme$class_or_appl_not_defined
*copyc jme$class_or_appl_not_unique
*copyc jme$delete_class_still_active
*copyc jme$error_in_job_class_ranking
*copyc jme$excess_class_in_sched_table
*copyc jme$job_class_not_defined
*copyc jme$must_be_scheduling_admin
*copyc jme$no_delete_of_default_class
*copyc jme$no_element_in_sequence
*copyc jme$no_ranking_of_default_class
*copyc jme$no_space_in_runtime_stack
*copyc jme$no_utility_is_active
*copyc jme$profile_cannot_be_read
*copyc jme$profile_cycle2_lost
*copyc jme$profile_id_mismatch
*copyc jme$profile_not_installed
*copyc jme$profile_too_large
*copyc jme$service_class_not_defined
*copyc jme$table_lengths_from_profile
*copyc jme$unknown_class_kind
*copyc jme$use_adms_or_manas_utility
*copyc jme$use_adms_utility
*copyc jme$invalid_scheduler_request
*copyc jme$job_in_ready_task_state
*copyc jme$job_has_no_ready_tasks
?? OLDTITLE ??

*DECK DECK=JME$JOB_STATE_IS_NULL EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_state_is_null           = jmc$min_ecc + 4220;
    {E The job state cannot be null.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_STATUS_NON_SWAPPABLE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_status_non_swappable    = jmc$min_ecc + 1033;
    {E Job has ijl status of non-swappable.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_TEMPLATE_CONDITIONS EXPAND=FALSE
?? NEWTITLE := 'JMDETEM :   Job Template Loading : ''JM'' 5000 .. 5999', EJECT ??

{ This deck is maintained for compatibility only.  Do NOT change it.
{ When adding status conditions, create a new discrete error deck for the
{ condition then add a *copyc to the deck JME$EXCEPTION_CONDITION_CODES.

*copyc jmc$min_ecc
*copyc jme$job_template_not_found
*copyc jme$no_binding_segment
*copyc jme$template_corrupted
*copyc jme$tasking_segs_mismatch
*copyc jme$template_pointer_nil
*copyc jme$data_length_zero
*copyc jme$unknown_command
*copyc jme$job_temp_sys_core_mismatch
?? OLDTITLE ??
*DECK DECK=JME$JOB_TEMPLATE_NOT_FOUND EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_template_not_found      = jmc$min_ecc + 5010;
    {E The template name specified does not exist.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_TEMP_SYS_CORE_MISMATCH EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_temp_sys_core_mismatch  = jmc$min_ecc + 5080;
    {E The job template is not compatable with the system core.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_TERMINATED_VIA_COMMAND EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_terminated_via_command  = jmc$min_ecc + 30;
    {E Job terminated via a TERMINATE_JOB command.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_TERMINATING_NORMALLY EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_terminating_normally    = jmc$min_ecc + 10;
    {I Job terminating normally.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_WAS_NOT_RECOVERED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_was_not_recovered       = jmc$min_ecc + 4302;
    {I The job +P was not recovered.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$JOB_WAS_RECOVERED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$job_was_recovered           = jmc$min_ecc + 4301;
    {I The job +P was recovered.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$LATEST_PRINT_TIME_EXPIRED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$latest_print_time_expired   = jmc$min_ecc + 4405;
    {E The file's LATEST_PRINT_TIME has expired.  }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$LATEST_RUN_TIME_EXPIRED EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$latest_run_time_expired                  = jmc$min_ecc + 4571;
    {E The file's LATEST_RUN_TIME has expired. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$LEVELER_NOT_RESPONDING EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$leveler_not_responding      = jmc$min_ecc + 4555;
    {E There are jobs in the queues that cannot be resubmitted because one
{ or more job levelers are not responding.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$LOGIN_ABORT_IN_PROLOG EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$login_abort_in_prolog       = jmc$min_ecc + 45;
    {I Login aborted because of following error in +P prolog: }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$LOGIN_ERROR_IN_PROLOG EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$login_error_in_prolog       = jmc$min_ecc + 40;
    {I Following error in +P prolog: }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$MAJOR_PROFILE_CHANGE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$major_profile_change        = jmc$min_ecc + 7002;
    {E Activating profile will cause jobs to be resubmitted.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$MAXIMUM_GENERIC_QFILES EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$maximum_generic_qfiles                   = jmc$min_ecc + 4572;
    {E The queue resources are temporarily unavailable. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$MAXIMUM_JOBS EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$maximum_jobs                = jmc$min_ecc + 4140;
    {E The job resources are temporarily unavailable.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$MAXIMUM_LIMIT_IS EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$maximum_limit_is            = jmc$min_ecc + 2015;
    {I Maximum limit value is +p.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$MAXIMUM_OUTPUT EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$maximum_output              = jmc$min_ecc + 4150;
    {E The output resources are temporarily unavailable.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$MISSING_PARAMETER EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$missing_parameter           = jmc$min_ecc + 4050;
    {E Required parameter +P omitted.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$MULTIPLE_DETACHED_JOBS EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$multiple_detached_jobs      = jmc$min_ecc + 4121;
    {E There is more than one detached job.  Use system supplied name to be
    { unique.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$MUST_BE_OPERATOR EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$must_be_operator            = jmc$min_ecc + 4130;
    {E You must be an operator to use this command.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$MUST_BE_SCHEDULING_ADMIN EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$must_be_scheduling_admin    = jmc$min_ecc + 1078;
    {E Scheduling administration privilege is required to use this request. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$MUST_BE_SYSTEM_JOB EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$must_be_system_job          = jmc$min_ecc + 4305;
    {E Must be the system job to use +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NAME_NOT_FOUND EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$name_not_found              = jmc$min_ecc + 4110;
    {E The name +P was not found.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NON_EXISTENT_JOB EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$non_existent_job            = jmc$min_ecc + 1010;
    {E The job does not exist.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NOT_ALL_JOBS_WERE_MOVED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$not_all_jobs_were_moved     = jmc$min_ecc + 4535;
    {E Not all jobs in Job Class +P were moved to the UNASSIGNED Job Class. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NOT_INTEGER_OR_LOGOUT EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$not_integer_or_logout       = jmc$min_ecc + 2055;
    {I +P is not a valid integer increment or TERMINATE_COMMAND or LOGOUT.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NOT_VALIDATED_FOR_COPOF EXPAND=TRUE
*copyc JMC$CONDITION_LIMITS2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$not_validated_for_copof   = jmc$min_ecc + 4556;
    {E You have insufficient authority to copy an output file. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NO_BINDING_SEGMENT EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$no_binding_segment          = jmc$min_ecc + 5020;
    {E There is no binding segment associated with this template.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NO_CONTROLS_FOR_MAINFRAME EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$no_controls_for_mainframe   = jmc$min_ecc + 7006;
    {E The profile on +F2 does not contain controls for mainframe +p1.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NO_DELETE_OF_DEFAULT_CLASS EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$no_delete_of_default_class  = jmc$min_ecc + 1080;
    {E The predefined +P1 +P2 cannot be deleted. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NO_ELEMENT_IN_SEQUENCE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$no_element_in_sequence      = jmc$min_ecc + 1081;
    {E Unable to access an element in a sequence. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NO_FREE_AJL_ORDINALS EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$no_free_ajl_ordinals        = jmc$min_ecc + 1046;
    {E No free ajl ordinals exist. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NO_JOBS_WERE_FOUND EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$no_jobs_were_found          = jmc$min_ecc + 4230;
    {E No jobs were found.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NO_JOB_CLASS_FOUND_FOR_JOB EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$no_job_class_found_for_job  = jmc$min_ecc + 7103;
    {E The attributes of this job prevent it from being a member of any Job }
    {Class.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NO_MAINFRAME_FOUND_FOR_JOB EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$no_mainframe_found_for_job  = jmc$min_ecc + 7102;
    {E The required combination of resources needed to run this job is }
    {unavailable.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NO_OUTPUTS_WERE_FOUND EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$no_outputs_were_found       = jmc$min_ecc + 4240;
    {E No outputs were found.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NO_QFILES_WERE_FOUND EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$no_qfiles_were_found                     = jmc$min_ecc + 4573;
    {E No queue files were found. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NO_RANKING_OF_DEFAULT_CLASS EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$no_ranking_of_default_class = jmc$min_ecc + 1082;
    {E The predefined +P1 +P2 cannot be used for automatic class selection. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NO_SPACE_FOR_ALLOCATE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$no_space_for_allocate       = jmc$min_ecc + 6010;
    {E No space for ALLOCATE.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NO_SPACE_FOR_FILE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$no_space_for_file           = jmc$min_ecc + 4145;
    {E There is insufficient space to write queue files.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NO_SPACE_IN_RUNTIME_STACK EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$no_space_in_runtime_stack   = jmc$min_ecc + 1083;
    {E Unable to allocate a variable in the run-time stack. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NO_SWAPPED_JOBS EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$no_swapped_jobs             = jmc$min_ecc + 1041;
    {E There are no swapped jobs present.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NO_USER_NAME_SPECIFIED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$no_user_name_specified      = jmc$min_ecc + 4215;
    {E The user supplied name cannot be null.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$NO_UTILITY_IS_ACTIVE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$no_utility_is_active        = jmc$min_ecc + 1084;
    {E The utility active flag must be set in order to change the scheduler..
    { tables. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$OBJECT_ALREADY_KNOWN EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$object_already_known        = jmc$min_ecc + 7082;
    {E The +P2 +P1 already exists.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$OBJECT_ATTRIBUTE_ERRORS EXPAND=FALSE
?? NEWTITLE := '        :Profile Management: ''JM'' 7020 .. 7039', EJECT ??

{ This deck is maintained for compatibility only.  Do NOT change it.
{ When adding status conditions, create a new discrete error deck for the
{ condition then add a *copyc to the deck JME$EXCEPTION_CONDITION_CODES.

*copyc jmc$min_ecc
*copyc jme$invalid_attribute_keyword
*copyc jme$invalid_attribute_value
*copyc jme$wrong_kind_of_value
*copyc jme$invalid_subattr_keyword
*copyc jme$invalid_subattribute_value
*copyc jme$wrong_kind_of_subvalue
*copyc jme$subvalue_out_of_range
?? OLDTITLE ??
*DECK DECK=JME$OBJECT_DISPLAY_ERRORS EXPAND=FALSE
?? NEWTITLE := '        :Profile Management: ''JM'' 7040 .. 7059', EJECT ??

{ This deck is maintained for compatibility only.  Do NOT change it.
{ When adding status conditions, create a new discrete error deck for the
{ condition then add a *copyc to the deck JME$EXCEPTION_CONDITION_CODES.

*copyc jmc$min_ecc
*copyc jme$unknown_attribute
*copyc jme$unknown_group_name
*copyc jme$parameter_has_no_value
*copyc jme$parameter_too_complex
*copyc jme$current_object_undefined
*copyc jme$cant_specify_both_do_and_go
?? OLDTITLE ??
*DECK DECK=JME$OBJECT_NOT_KNOWN EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$object_not_known            = jmc$min_ecc + 7081;
    {E The +P2 +P1 is not known.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$OPERATOR_QUEUE_BACKUP EXPAND=FALSE
*copyc JMC$CONDITION_LIMITS2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$operator_queue_backup     = jmc$min_ecc + 4557;
    {I The system operator backed up and deleted the job or output file. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$OPERATOR_QUEUE_RESTORE EXPAND=FALSE
*copyc JMC$CONDITION_LIMITS2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$operator_queue_restore    = jmc$min_ecc + 4558;
    {I The system operator restored the job or output file. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$OUTPUT_ALREADY_TERMINATED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$output_already_terminated   = jmc$min_ecc + 4210;
    {E Output file +P has already been terminated via command.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$OUTPUT_CANNOT_INITIATE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$output_cannot_initiate      = jmc$min_ecc + 4330;
    {E The output file requested cannot be initiated and must be reacquired. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$OUTPUT_DELETED_VIA_COMMAND EXPAND=FALSE
*copyc JMC$CONDITION_LIMITS2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$output_deleted_via_command  = jmc$min_ecc + 4564;
    {E Output file deleted via a TERMINATE_OUTPUT command.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$OUTPUT_IS_INITIATED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$output_is_initiated         = jmc$min_ecc + 4320;
    {E The output +P is printing and cannot be changed. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$OUTPUT_IS_TERMINATED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$output_is_terminated        = jmc$min_ecc + 4325;
    {E The output +P is terminated and cannot be changed. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$OUTPUT_QUEUE_IS_EMPTY EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$output_queue_is_empty       = jmc$min_ecc + 4160;
    {E There are no files in the output queue.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$OUTPUT_STATE_IS_NULL EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$output_state_is_null        = jmc$min_ecc + 4260;
    {E The output state cannot be null.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$OUTPUT_WAS_NOT_RECOVERED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$output_was_not_recovered    = jmc$min_ecc + 4304;
    {I The output file +P was not recovered.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$OUTPUT_WAS_RECOVERED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$output_was_recovered        = jmc$min_ecc + 4303;
    {I The output file +P was recovered.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$PARAMETER_HAS_NO_VALUE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$parameter_has_no_value      = jmc$min_ecc + 7043;
    {E Parameter +P1 has no value.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$PARAMETER_REQUIRED_WHEN EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$parameter_required_when     = jmc$min_ecc + 4525;
    {E The parameter +P is required when the parameter +P is specified. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$PARAMETER_TOO_COMPLEX EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$parameter_too_complex       = jmc$min_ecc + 7044;
    {E The parameter +P1 is too complex to return in a function.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$PAUSE_BREAK_IGNORED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$pause_break_ignored         = jmc$min_ecc + 2060;
    {I Pause break ignored.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$PERCENT_SUMS_OVER_100 EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$percent_sums_over_100       = jmc$min_ecc + 7092;
    {E The minimum percentages cannot total more then 100 percent for the
    { CPU_Dispatching_Allocation attribute.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$PERMANENT_FILE_REQUIRED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$permanent_file_required     = jmc$min_ecc + 4340;
    {E A permanent file is required for the OUTPUT_DISPOSITION parameter. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$PERMANENT_OBJECT EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$permanent_object            = jmc$min_ecc + 7089;
    {E Cannot delete +P2 +P1.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$PROFILE_CANNOT_BE_READ EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$profile_cannot_be_read      = jmc$min_ecc + 1085;
    {E The scheduling profile cannot be read. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$PROFILE_CYCLE2_LOST EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$profile_cycle2_lost         = jmc$min_ecc + 1086;
    {E The scheduling profile was not installed and cycle 2 of the system..
    { profile has already been deleted.  Retry the operation. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$PROFILE_ERRORS EXPAND=FALSE
?? NEWTITLE := '        :Profile Management: ''JM'' 7060 .. 7079', EJECT ??

{ This deck is maintained for compatibility only.  Do NOT change it.
{ When adding status conditions, create a new discrete error deck for the
{ condition then add a *copyc to the deck JME$EXCEPTION_CONDITION_CODES.

*copyc jmc$min_ecc
*copyc jme$cannot_read_profile
?? OLDTITLE ??
*DECK DECK=JME$PROFILE_ID_MISMATCH EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$profile_id_mismatch         = jmc$min_ecc + 1087;
    {E The profile changes to be made require activation of the profile. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$PROFILE_INTERNAL_ERROR EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$profile_internal_error      = jmc$min_ecc + 7120;
    {E Internal profile error +p.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$PROFILE_IS_TOO_LARGE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$profile_is_too_large        = jmc$min_ecc + 7004;
    {E The profile contains too many +P1 to be activated.  Present selections
    { allow a maximum of +P3 and there are +P2 on the profile.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$PROFILE_NOT_INSTALLED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$profile_not_installed       = jmc$min_ecc + 1088;
    {E The scheduling profile was not installed.  Retry the operation. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$PROFILE_OBJECT_ERRORS EXPAND=FALSE
?? NEWTITLE := '        :Profile Management: ''JM'' 7080 .. 7099', EJECT ??

{ This deck is maintained for compatibility only.  Do NOT change it.
{ When adding status conditions, create a new discrete error deck for the
{ condition then add a *copyc to the deck JME$EXCEPTION_CONDITION_CODES.

*copyc jmc$min_ecc
*copyc jme$object_not_known
*copyc jme$object_already_known
*copyc jme$too_many_objects
*copyc jme$cannot_move_unassigned
*copyc jme$duplicate_categories
*copyc jme$duplicate_abbreviation
*copyc jme$abbreviation_change_illegal
*copyc jme$profile_object_referenced
*copyc jme$permanent_object
*copyc jme$item_to_delete_is_missing
*copyc jme$item_to_add_is_present
*copyc jme$percent_sums_over_100
?? OLDTITLE ??
*DECK DECK=JME$PROFILE_OBJECT_REFERENCED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$profile_object_referenced   = jmc$min_ecc + 7088;
    {E Cannot delete +P1 since a class or category references it.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$PROFILE_TOO_LARGE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$profile_too_large           = jmc$min_ecc + 1089;
    {E Maximum +P1 +P2 required at deadstart to install the scheduling..
    { profile. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$QFILE_ALREADY_TERMINATED EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$qfile_already_terminated                 = jmc$min_ecc + 4574;
    {E Queue file +P has already been terminated via command. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$QFILE_APPL_NOT_PERMITTED EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$qfile_appl_not_permitted                 = jmc$min_ecc + 4575;
    {E The requesting application is not permitted access to queue files
{ with an application name of +P. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$QFILE_CANNOT_INITIATE EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$qfile_cannot_initiate                    = jmc$min_ecc + 4576;
    {E The queue file requested cannot be initiated and must be reacquired. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$QFILE_IS_INITIATED EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$qfile_is_initiated                       = jmc$min_ecc + 4577;
    {E The queue file +P is being processed and cannot be changed. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$QFILE_IS_TERMINATED EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$qfile_is_terminated                      = jmc$min_ecc + 4578;
    {E The queue file +P is terminated and cannot be changed. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$QFILE_STATE_IS_NULL EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$qfile_state_is_null                      = jmc$min_ecc + 4579;
    {E The queue file state cannot be null. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$QFILE_WAS_NOT_RECOVERED EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$qfile_was_not_recovered                  = jmc$min_ecc + 4580;
    {I The queue file +P was not recovered. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$QFILE_WAS_RECOVERED EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$qfile_was_recovered                      = jmc$min_ecc + 4581;
    {I The queue file +P was recovered. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$QUEUED_FILE_CONDITIONS EXPAND=FALSE
?? NEWTITLE := 'JME$QUEUED_FILE_CONDITIONS : ''JM'' 4000 .. 4555', EJECT ??

{ This deck is maintained for compatibility only.  Do NOT change it.
{ When adding status conditions, create a new discrete error deck for the
{ condition then add a *copyc to the deck JME$EXCEPTION_CONDITION_CODES.

*copyc jmc$min_ecc
*copyc jme$job_not_found
*copyc jme$file_not_found
*copyc jme$entry_not_found
*copyc jme$tried_to_self_destruct
*copyc jme$job_cannot_be_terminated
*copyc jme$missing_parameter
*copyc jme$invalid_parameter
*copyc jme$invalid_parameter_value
*copyc jme$invalid_keyword
*copyc jme$special_privilege_required
*copyc jme$job_owner_only
*copyc jme$abort_by_operator
*copyc jme$name_not_found
*copyc jme$duplicate_name
*copyc jme$must_be_operator
*copyc jme$requires_operator_privilege
*copyc jme$maximum_jobs
*copyc jme$maximum_output
*copyc jme$output_queue_is_empty
*copyc jme$input_queue_is_empty
*copyc jme$temp_err1
*copyc jme$write_job_system_label
*copyc jme$write_output_system_label
*copyc jme$read_job_system_label
*copyc jme$read_output_system_label
*copyc jme$job_already_terminated
*copyc jme$job_forced_out_of_memory
*copyc jme$job_has_a_hung_task
*copyc jme$job_damaged_during_recovery
*copyc jme$output_already_terminated
*copyc jme$no_user_name_specified
*copyc jme$job_state_is_null
*copyc jme$no_jobs_were_found
*copyc jme$no_outputs_were_found
*copyc jme$result_array_too_small
*copyc jme$output_state_is_null
*copyc jme$sl_version_mismatch
*copyc jme$illegal_ssn
*copyc jme$illegal_usn
*copyc jme$duplicate_attribute_key
*copyc jme$input_was_recovered
*copyc jme$input_was_not_recovered
*copyc jme$job_recovery_or_abort_set
*copyc jme$unable_to_recover_catalog
*copyc jme$job_was_recovered
*copyc jme$job_was_not_recovered
*copyc jme$output_was_recovered
*copyc jme$output_was_not_recovered
*copyc jme$must_be_system_job
*copyc jme$cant_recover_job
*copyc jme$invalid_job_class
*copyc jme$output_is_initiated
*copyc jme$input_is_initiated
*copyc jme$cannot_change_interactive
*copyc jme$output_is_terminated
*copyc jme$output_cannot_initiate
*copyc jme$input_cannot_initiate
*copyc jme$permanent_file_required
*copyc jme$cant_use_$null
*copyc jme$value_out_of_range
*copyc jme$invalid_working_set_size
*copyc jme$invalid_data_mode
*copyc jme$job_is_in_termination
*copyc jme$user_requested_exit
*copyc jme$incompatible_network_origin
*copyc jme$terminal_timeout_message
*copyc jme$task_is_in_termination
*copyc jme$recompilation_required
*copyc jme$latest_print_time_expired
*copyc jme$invalid_output_state
*copyc jme$invalid_job_state
*copyc jme$destination_usage_incorrect
*copyc jme$application_not_permitted
*copyc jme$destination_usage_in_use
*copyc jme$application_table_is_full
*copyc jme$parameter_required_when
*copyc jme$interactive_job_discarded
*copyc jme$not_all_jobs_were_moved
*copyc jme$scheduling_profile_changed
*copyc jme$batch_access_denied
*copyc jme$interactive_access_denied
*copyc jme$leveler_not_responding
?? OLDTITLE ??

*DECK DECK=JME$READ_JOB_SYSTEM_LABEL EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$read_job_system_label       = jmc$min_ecc + 4190;
    {E Error attempting to read job system label.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$READ_OUTPUT_SYSTEM_LABEL EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$read_output_system_label    = jmc$min_ecc + 4195;
    {E Error attempting to read output system label.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$READ_QFILE_SYSTEM_LABEL EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$read_qfile_system_label                  = jmc$min_ecc + 4582;
    {E Error attempting to read queue file system label. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$RECOMPILATION_REQUIRED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$recompilation_required      = jmc$min_ecc + 4400;
    {F The interface +P has changed in a manner which requires the caller
{ of the request to be recompiled. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$REQUIRES_OPERATOR_PRIVILEGE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$requires_operator_privilege = jmc$min_ecc + 4131;
    {E You must be an operator to use +P on this request.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$RESOURCE_CONDITION EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$resource_condition          = jmc$min_ecc + 2005;
    {I +P warning limit has been reached.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$RESULT_ARRAY_TOO_SMALL EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$result_array_too_small      = jmc$min_ecc + 4250;
    {E The status result array was too small.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$SCHEDULING_PROFILE_CHANGED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$scheduling_profile_changed  = jmc$min_ecc + 4540;
    {E The scheduling profile changed while a job was being submitted. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$SELF_TERMINATING_JOB EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$self_terminating_job        = jmc$min_ecc + 20;
    {I Self terminating job.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$SERVED_FAMILY_UNAVAILABLE EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$served_family_unavailable   = jmc$min_ecc + 2066;
    {E The served family +p1 is temporarily unavailable.}

?? FMT (FORMAT := ON) ??

*DECK DECK=JME$SERVICE_CLASS_NOT_DEFINED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$service_class_not_defined   = jmc$min_ecc + 1092;
    {E The service class specified is not defined. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$SL_VERSION_MISMATCH EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$sl_version_mismatch         = jmc$min_ecc + 4270;
    {E VERSION in System Label does not match running system.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$SPECIAL_PRIVILEGE_REQUIRED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$special_privilege_required  = jmc$min_ecc + 4080;
    {E Special privilege is required.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$SUBVALUE_OUT_OF_RANGE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$subvalue_out_of_range       = jmc$min_ecc + 7027;
    {E The value specified for +P2 of parameter +P1 is out of range. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$SWAPIN_WITH_MAXAJ_ZERO EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$swapin_with_maxaj_zero      = jmc$min_ecc + 1058;
    {W ATTENTION OPERATOR:  The number of maximum active jobs for the }
    { service class +P for the job +P is currently set to zero.  It must }
    { be changed before the swapin can proceed. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$SWAPPING_NOT_ALLOWED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$swapping_not_allowed        = jmc$min_ecc + 1043;
    {E Swapping has been disabled.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$SWAP_BUFFER_FULL EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$swap_buffer_full            = jmc$min_ecc + 1031;
    {E The swap buffer is full. Try again.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$SYSTEM_LABEL_INTERNAL_ERROR EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$system_label_internal_error              = jmc$min_ecc + 4584;
    {E NIL pointer occurred attempting to update queue file system label. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$SYSTEM_NOT_IDLE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$system_not_idle             = jmc$min_ecc + 1047;
    {E System did not idle within requested time.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$SYSTEM_PROFILE_MISMATCH EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$system_profile_mismatch     = jmc$min_ecc + 7003;
    {E The system tables do not match the current profile.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$TABLE_LENGTHS_FROM_PROFILE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$table_lengths_from_profile  = jmc$min_ecc + 1093;
    {I In the system scheduling profile, the maximum Job Class index is +P1..
    { and the maximum Service Class index is +P2. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$TASKING_SEGS_MISMATCH EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$tasking_segs_mismatch       = jmc$min_ecc + 5040;
    {E The number of tasking segments in template has exceeded a constant value.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$TASK_IS_IN_TERMINATION EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$task_is_in_termination      = jmc$min_ecc + 4384;
    {E The requested operation cannot be performed when a task is in
{ termination and communication with the terminal is disabled because
{ of another task.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$TEMPLATE_CORRUPTED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$template_corrupted          = jmc$min_ecc + 5030;
    {E The data intrgrity of the template is suspect.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$TEMPLATE_POINTER_NIL EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$template_pointer_nil        = jmc$min_ecc + 5050;
    {E The template pointer variable has not been initialized.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$TEMP_ERR1 EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$temp_err1                   = jmc$min_ecc + 4170;
    {E Error in temporary code.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$TERMINAL_TIMEOUT_MESSAGE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$terminal_timeout_message    = jmc$min_ecc + 4383;
    {I Disconnect timeout completes at +P1.+P2.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$TERMINATE_BREAK_IGNORED EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$terminate_break_ignored     = jmc$min_ecc + 2065;
    {I Terminate break ignored.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$TIME_LIMIT_CONDITION EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$time_limit_condition        = jmc$min_ecc + 2010;
    {I Job Time Limit reached.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$TOO_MANY_OBJECTS EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$too_many_objects            = jmc$min_ecc + 7083;
    {E Adding +P1 exceeds the limit for +P2.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$TRANSACTION_JOB_DISCONNECT EXPAND=FALSE
*copyc jmc$condition_limits2

?? FMT (FORMAT := OFF) ??

    CONST
      jme$transaction_job_disconnect    = jmc$min_ecc + 4385;
      {E The requested operation cannot be performed in a disconnected
      {transaction job.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$TRIED_TO_SELF_DESTRUCT EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$tried_to_self_destruct      = jmc$min_ecc + 4040;
    {W Terminating the current job (+P) is not permitted.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$UNABLE_TO_ALLOC_ALL_SPACE EXPAND=FALSE

?? NEWTITLE := 'jme$unable_to_alloc_all_space      : ''JM'' 7122', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    jme$unable_to_alloc_all_space       = jmc$min_ecc + 7122;
    {E System unable to allocate space, job terminated.

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=JME$UNABLE_TO_RECOVER_CATALOG EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$unable_to_recover_catalog   = jmc$min_ecc + 4300;
    {E The catalog +P for the family +P could not be found.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$UNABLE_TO_RECOVER_PROFILE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$unable_to_recover_profile   = jmc$min_ecc + 7001;
    {W No valid profile was found, standard profile activated. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$UNKNOWN_ATTRIBUTE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$unknown_attribute           = jmc$min_ecc + 7041;
    {E +P1 is not a valid attribute.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$UNKNOWN_CLASS EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$unknown_class               = jmc$min_ecc + 1042;
    {E An unknown class name was used.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$UNKNOWN_CLASS_KIND EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$unknown_class_kind          = jmc$min_ecc + 1094;
    {E An unknown class kind was specified when requesting the defined class..
    { list. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$UNKNOWN_COMMAND EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$unknown_command             = jmc$min_ecc + 5070;
    {E The job template command given is not legal.

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$UNKNOWN_GROUP_NAME EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$unknown_group_name          = jmc$min_ecc + 7042;
    {E +P1 is not a valid group name.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$UNKNOWN_REQUESTOR EXPAND=FALSE

*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$unknown_requestor           = jmc$min_ecc + 4554;
    {E The value specified for the +P parameter on the +P
{ request is not meaningful or it is not supported at this time. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$UNLIMITED_TIMEOUT_MESSAGE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$unlimited_timeout_message   = jmc$min_ecc + 4386;
    {I Disconnect timeout is UNLIMITED.}

?? FMT (FORMAT := ON) ??

*DECK DECK=JME$UPDATED_ONLY_TABLES EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$updated_only_tables         = jmc$min_ecc + 7007;
    {W The scheduler tables were updated but the system scheduler profile
    { file was not.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$USER_REQUESTED_EXIT EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$user_requested_exit         = jmc$min_ecc + 4381;
    {E Exit due to user request <NCC>-X for logout. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$USE_ADMS_OR_MANAS_UTILITY EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$use_adms_or_manas_utility   = jmc$min_ecc + 1095;
    {W No operation was performed.  This command has been replaced by the..
    { ADMINISTER_SCHEDULING and MANAGE_ACTIVE_SCHEDULING Utilities. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$USE_ADMS_UTILITY EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$use_adms_utility            = jmc$min_ecc + 1096;
    {W No operation was performed.  This command has been replaced by the..
    { ADMINISTER_SCHEDULING Utility. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$VALUE_OUT_OF_RANGE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$value_out_of_range          = jmc$min_ecc + 4360;
    {E The value specified for +P is out of range for the job class. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$VSN_OR_VSNP_OR_BF_REQUIRED EXPAND=TRUE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$vsn_or_vsnp_or_bf_required = jmc$min_ecc + 4521;
    {E Either the VSN or VSN_PREFIX or BACKUP_FILE parameter is required. }

?? FMT (FORMAT := OFF) ??
*DECK DECK=JME$VSN_OR_VSNP_REQUIRED EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$vsn_or_vsnp_required      = jmc$min_ecc + 4561;
    {E Either the VSN or VSN_PREFIX parameter is required. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$VSN_VSNP_VSNS_BF_REQUIRED EXPAND=TRUE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
 jme$vsn_vsnp_vsns_bf_required = jmc$min_ecc + 4522;
 {E One of the VSN, VSN_PREFIX, VSN_SUFFIX, or BACKUP_FILE parameters is required. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$VSN_VSNP_VSNS_REQUIRED EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$vsn_vsnp_vsns_required = jmc$min_ecc + 4562;
    {E One of the VSN, VSN_PREFIX, or VSN_SUFFIX parameters is required. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$WORK_AREA_TOO_SMALL EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$work_area_too_small       = jmc$min_ecc + 4565;
    {E The work area provided was too small. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$WRITE_JOB_SYSTEM_LABEL EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$write_job_system_label      = jmc$min_ecc + 4180;
    {E Error attempting to write job system label.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$WRITE_OUTPUT_SYSTEM_LABEL EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$write_output_system_label   = jmc$min_ecc + 4185;
    {E Error attempting to write output system label.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$WRITE_QFILE_SYSTEM_LABEL EXPAND=FALSE
*copyc jmc$condition_limits2
?? FMT (FORMAT := OFF) ??

  CONST
    jme$write_qfile_system_label                 = jmc$min_ecc + 4583;
    {E Error attempting to write queue file system label. }

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$WRONG_DISPLAY EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$wrong_display               = jmc$min_ecc + 1040;
    {E The wrong display code was presented.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$WRONG_KIND_OF_SUBVALUE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$wrong_kind_of_subvalue      = jmc$min_ecc + 7026;
    {E Expecting +P1 value for +P2 of parameter +P3.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JME$WRONG_KIND_OF_VALUE EXPAND=FALSE
*copyc jmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    jme$wrong_kind_of_value         = jmc$min_ecc + 7023;
    {E Expecting +P1 value for parameter +P2.}

?? FMT (FORMAT := ON) ??
*DECK DECK=JMH$ABORT_DEADSTART EXPAND=FALSE
{
{   The purpose of this request is to abort NOS/VE Deadstart and display
{ informative messages in the Main Operator Window as follows:
{
{ A fatal NOS/VE initialization error has occurred.
{ ' the text of DISPLAY_MESSAGE '
{ ' the text of DISPLAY_STATUS '
{ A NOS/VE Deadstart is required.
{
{ The caller must be the system job.
{
{       JMP$ABORT_DEADSTART (DISPLAY_MESSAGE, DISPLAY_STATUS, STATUS)
{
{ DISPLAY_MESSAGE: (input)  This parameter specifies the text of the first
{       message to be displayed.
{
{ DISPLAY_STATUS: (input)  This parameter specifies an error status variable.
{       The text of the status variable is the second message displayed.
{
{ STATUS: (output) This parameter specifies the request status.  No return
{       is made to the caller when the request is completed normally and
{       deadstart is aborted.
{       CONDITIONS:
{             jme$must_be_system_job
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$ACQUIRE_CONNECTION EXPAND=FALSE
{
{    The purpose of this request is to acquire a connection for a job submitted
{ by jmp$submit_detached_job.  The effect of this request is similar to an
{ attach_job command in that the acquired connection is the job's nominal
{ connection and all terminal files are connected to the new connection.
{
{    The parameters to this request are defined to allow the request to be
{ issued from a COBOL or FORTRAN program.
{
{       JMP$ACQUIRE_CONNECTION (SERVER_NAME, SERVICE_DATA, SERVICE_DATA_LENGTH,
{             STATUS);
{
{ SERVER_NAME: (input)  This parameter specifies the network server name for
{       which a connection will be acquired.
{
{ SERVICE_DATA: (output)  This parameter returns the value that was specified
{       on the CDCNET create connection command service data parameter, if any.
{
{ SERVICE_DATA_LENGTH: (output)  This parameter returns the length of the
{       service_data parameter.  Zero will returned if there is no service
{       data.
{
{ STATUS: (output) This parameter specifies the completion status of
{         the request.
*DECK DECK=JMH$ACQUIRE_MODIFIED_INPUT EXPAND=FALSE
{
{    The purpose of this request is to allow restricted programs to acquire
{ their respective "modified" jobs in the input queue.  "Modified" input is a
{ job that has been previously acquired and has since had its attributes
{ changed.
{
{       JMP$ACQUIRE_MODIFIED_INPUT (JOB_DESTINATION_USAGE, INPUT_DESCRIPTOR,
{             STATUS);
{
{ JOB_DESTINATION_USAGE: (input)  This parameter indicates what the
{       job_destination_usage of the job must be.
{
{ INPUT_DESCRIPTOR: (output)  This record contains the information that is
{       necessary for applications to dispose of jobs correctly.
{
{ STATUS: (output) This is a record which specifies the status of the request.
{       CONDITIONS:
{             jme$application_not_permitted
{             jme$destination_usage_incorrect
{             jme$input_queue_is_empty
*DECK DECK=JMH$ACQUIRE_MODIFIED_OUTPUT EXPAND=FALSE
{
{    The purpose of this request is to allow restricted programs to acquire
{ their respective "modified" files in the output queue.  "Modified" output is
{ an output file that has been previously acquired and has since had its
{ attributes changed.
{
{       JMP$ACQUIRE_MODIFIED_OUTPUT (OUTPUT_DESTINATION_USAGE,
{             OUTPUT_DESCRIPTOR, STATUS);
{
{ OUTPUT_DESTINATION_USAGE: (input)  This parameter indicates what the
{       output_destination_usage of the output file must be.
{
{ OUTPUT_DESCRIPTOR: (output)  This record contains the information that is
{       necessary for an application to dispose of the output file.
{
{ STATUS: (output) This is a record which specifies the status of the request.
{       CONDITIONS:
{             jme$application_not_permitted
{             jme$destination_usage_incorrect
{             jme$output_queue_is_empty
{
*DECK DECK=JMH$ACQUIRE_MODIFIED_QFILE EXPAND=FALSE
{
{    The purpose of this request is to allow registered applications to acquire
{ their respective "modified" files in the generic queue.  A "modified" file is
{ a queue file that has been previously acquired and has since had its
{ attributes changed.
{
{       JMP$ACQUIRE_MODIFIED_QFILE (APPLICATION_NAME, ATTRIBUTE_KEYS_P,
{             ATTRIBUTE_WORK_AREA_P, ATTRIBUTE_RESULTS_P, SYSTEM_FILE_NAME,
{             STATUS);
{
{ APPLICATION_NAME: (input)  This parameter indicates what the application_name
{       of the queue file must be.
{
{ ATTRIBUTE_KEYS_P: (input)  This parameter lists the attributes the application
{       wants to obtain from the acquired file.
{
{ ATTRIBUTE_WORK_AREA_P: (input, output)  This is the work area in which the
{       attribute results are returned.
{
{ ATTRIBUTE_RESULTS_P: (input, output)  This array of records contains the
{       information that is necessary for applications to dispose of queue
{       files correctly.
{
{ SYSTEM_FILE_NAME: (output)  This is the name of the acquired queue file.
{
{ STATUS: (output) This is a record which specifies the status of the request.
{       CONDITIONS:
{             jme$invalid_parameter
{             jme$qfile_appl_not_permitted
{             jme$generic_queue_is_empty
{             jme$work_area_too_small
*DECK DECK=JMH$ACQUIRE_NEW_INPUT EXPAND=FALSE
{
{    The purpose of this request is to allow restricted programs to acquire
{ their respective "new" files in the input queue.  "New" input is a job that
{ has not been acquired by the application.
{
{       JMP$ACQUIRE_NEW_INPUT (JOB_DESTINATION_USAGE, INPUT_DESCRIPTOR,
{             STATUS);
{
{ JOB_DESTINATION_USAGE: (input)  This parameter indicates what the
{       job_destination_usage of the job must be.
{
{ INPUT_DESCRIPTOR: (output)  This record contains the information that is
{       necessary for applications to dispose of jobs correctly.
{
{ STATUS: (output) This is a record which specifies the status of the request.
{       CONDITIONS:
{             jme$application_not_permitted
{             jme$destination_usage_incorrect
{             jme$input_queue_is_empty
*DECK DECK=JMH$ACQUIRE_NEW_OUTPUT EXPAND=FALSE
{
{    The purpose of this request is to allow restricted programs to acquire
{ their respective "new" files in the output queue.  "New" output is an output
{ file that has not been acquired by the application.
{
{       JMP$ACQUIRE_NEW_OUTPUT (OUTPUT_DESTINATION_USAGE, OUTPUT_DESCRIPTOR,
{             STATUS);
{
{ OUTPUT_DESTINATION_USAGE: (input)  This parameter indicates what the
{       output_destination_usage of the output file must be.
{
{ OUTPUT_DESCRIPTOR: (output)  This record contains the information that is
{       necessary for applications to dispose of output files correctly.
{
{ STATUS: (output) This is a record which specifies the status of the request.
{       CONDITIONS:
{             jme$application_not_permitted
{             jme$destination_usage_incorrect
{             jme$output_queue_is_empty
{
*DECK DECK=JMH$ACQUIRE_NEW_QFILE EXPAND=FALSE
{
{    The purpose of this request is to allow registered applications to acquire
{ their respective "new" files in the generic queue.  A "new" file is a generic
{ queue file that has not been acquired by the application.
{
{       JMP$ACQUIRE_NEW_QFILE (APPLICATION_NAME, ATTRIBUTE_KEYS_P,
{             ATTRIBUTE_WORK_AREA_P, ATTRIBUTE_RESULTS_P, SYSTEM_FILE_NAME,
{             STATUS);
{
{ APPLICATION_NAME: (input)  This parameter indicates what the application_name
{       of the queue file must be.
{
{ ATTRIBUTE_KEYS_P: (input)  This lists the attributes the application wants
{       to obtain from the acquired file.
{
{ ATTRIBUTE_WORK_AREA_P: (input, output)  This is the work area in which the
{       attribute results are returned.
{
{ ATTRIBUTE_RESULTS_P: (input, output)  This array of records contains the
{       information that is necessary for applications to dispose of queue
{       files correctly.
{
{ SYSTEM_FILE_NAME: (output)  This is the name of the acquired queue file.
{
{ STATUS: (output) This is a record which specifies the status of the request.
{       CONDITIONS:
{             jme$invalid_parameter
{             jme$qfile_appl_not_permitted
{             jme$generic_queue_is_empty
{             jme$work_area_too_small
{
*DECK DECK=JMH$ACTIVATE_DEFERRED_FAMILY EXPAND=FALSE
{    The purpose of this request is to remove jobs that are in a deferred
{ state because their login family (served family) is unavailable.  This
{ request is called on the client by the file server during activation.
{
{       JMP$ACTIVATE_DEFERRED_FAMILY (ACTIVATED_FAMILY_LIST);
{
{ ACTIVATED_FAMILY_LIST: (input)  This is the list of families that is being
{       activated.
{
*DECK DECK=JMH$ACTIVATE_JOB EXPAND=FALSE
{
{    The purpose of this request is to reactivate a job which is inactive due
{  to being reloaded from a backup or belonging to a disk set which was added
{  to a configuration by Alternate Set Recovery.
{
{        JMP$ACTIVATE_JOB (SYSTEM_JOB_NAME, FAMILY_NAME, SUBCATALOG_NAME,
{              RECOVER_USING_ABORT_DISPOSITION, IGNORE_CLIENT_INITIATED_JOBS,
{              STATUS);
{
{ SYSTEM_JOB_NAME: (input) This is the system-supplied job name for the job
{        that is to be reactivated.
{
{ FAMILY_NAME: (input)  This is the NOS/VE family name in which the input file
{       resides.
{
{ SUBCATALOG_NAME: (input)  This is the subcatalog in the $SYSTEM username of
{       the specified family that contains the file.
{
{ RECOVER_USING_ABORT_DISPOSITION: (input)  This indicates if the job abort
{       disposition originally specified with the input file should be used to
{       determine the restartability of the job.
{
{ IGNORE_CLIENT_INITIATED_JOBS: (input)  This indicates that if the job is
{       initiated on a client, the job's initiation location should be ignored
{       and the job should be requeued as queued and not initiated.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        ofe$sou_not_active
{
*DECK DECK=JMH$ACTIVATE_OUTPUT EXPAND=FALSE
{
{    The purpose of this request is to reactivate an output file which is
{  inactive due to being reloaded from a backup or belonging to a disk set
{  which was added to a configuration by Alternate Set Recovery.
{
{        JMP$ACTIVATE_OUTPUT (SYSTEM_FILE_NAME, SUBCATALOG_NAME, STATUS);
{
{ SYSTEM_FILE_NAME: (input) This is the system-supplied file name for the
{        output that is to be reactivated.
{
{ SUBCATALOG_NAME: (input) This is the subcatalog in $SYSTEM where the
{        inactive output file has been placed.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        ofe$sou_not_active
*DECK DECK=JMH$ACTIVATE_SYS_JOB_TEMPLATE EXPAND=FALSE
{
{     This request will activate a named system job template.
{
{  JMP$ACTIVATE_SYS_JOB_TEMPLATE(TEMPLATE_NAME, CODE_BASE_PTR, STATUS)
{
{  TEMPLATE_NAME: (input) The 31 character job template name.
{
{  CODE_BASE_PTR: (output) The external code base pointer of the starting
{                          procedure in the job template.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$ADJUST_AGE_INTERVAL EXPAND=FALSE
{
{     This procedure allows the scheduler to adjust the age interval used
{  by memory management for paging.
{
{  ADJUST_AGE_INTERVAL
{
*DECK DECK=JMH$ADJUST_JOB_PRIORITY EXPAND=FALSE
{
{     This procedure will adjust both active and swapped jobs priority
{  according to values in the respective class attribute table.
{
{  JMP$ADJUST_JOB_PRIORITY( AGE, PRIORITY_ADJ)
{
{  AGE: (input) A boolean directing whether or not input queued jobs should
{               be aged.
{
{  PRIORITY_ADJ: (input) A boolean directing whether or not active jobs should
{               be aged.
{
*DECK DECK=JMH$ADJUST_PRIORITY_OF_NEW_JOB EXPAND=FALSE
{
{     This procedure will calculate the priority of a new job in the system.
{  Priority is determined by job class.
{
{  JMP$ADJUST_PRIORITY_OF_NEW_JOB (INDEX)
{
{  INDEX: (input) This is the KJL index of the job getting the priority.
{
*DECK DECK=JMH$AGE_SWAPPED_JOBS EXPAND=FALSE
{
{     This procedure applies aging criteria spelled out in the appropriate
{  class attribute record to jobs swapped out.
{
{  JMP$AGE_SWAPPED_JOBS
{
*DECK DECK=JMH$ALLOCATE_MORE_IJL_SPACE EXPAND=FALSE
{
{    This procedure allocates a new ijl block.
{
{       JMP$ALLOCATE_MORE_IJL_SPACE (IJL_BLOCK_NUMBER)
{
{  IJL_BLOCK_NUMBER: (input) This parameter specifies the block number of the
{       ijl block to be allocated.
{
*DECK DECK=JMH$ALTER_JOB_PRIORITY EXPAND=FALSE
{
{     This procedure will allow the operator to change a jobs priority.
{
{  JMP$ALTER_JOB_PRIORITY (NAME, PRIORITY, STATUS)
{
{  NAME: (input) The jobs job sequence number.
{
{  PRIORITY: (input) The new priority for the job.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$ASSIGN_SERVER_JOBS EXPAND=FALSE
{
{    The purpose of this request is to place the jobs assigned by the server
{ mainframe into the client mainframe's known job list (KJL).
{
{       JMP$ASSIGN_SERVER_JOBS (SERVER_MAINFRAME_ID, ASSIGNED_JOB_LIST_P,
{             NUMBER_OF_JOBS_ASSIGNED, STATUS);
{
{ SERVER_MAINFRAME_ID: (input)  This is the binary mainframe identifier of the
{       server mainframe that assigned the jobs to the client.
{
{ ASSIGNED_JOB_LIST_P: (output)  This is the list of jobs that the server
{       mainframe assigned.  The list contains all the information required to
{       construct the KJL entry for each assigned job.
{
{ NUMBER_OF_JOBS_ASSIGNED: (output)  This is the number of jobs in the assigned
{       job list that were successfully placed in the client's KJL.  This
{       parameter if valid if abnormal status is returned by this request.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$maximum_jobs
*DECK DECK=JMH$ATTACH_TIMESHARING_JOB EXPAND=FALSE
{
{    The purpose of this request is to attach (reconnect) to a disconnected job.
{
{        JMP$ATTACH_TIMESHARING_JOB (JOB_NAME, STATUS);
{
{ JOB_NAME: (input) This is the name of the job to attach.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{         jme$duplicate_name
{         jme$name_not_found
{         cle$invalid_name
{
*DECK DECK=JMH$BEGIN_TIMESHARING_HANDLER EXPAND=FALSE
{
{    The purpose of this request is to indicate that another timesharing, i.e.
{  interactive, condition handler is going to become active or that a ring-
{  crossing condition is being posted.
{
{        JMP$BEGIN_TIMESHARING_HANDLER (CONDITION);
{
{ CONDITION: (input) This is the interactive condition that is being propogated.
{
*DECK DECK=JMH$BRING_UP_JOB_TASKS EXPAND=FALSE
{
{     This request will be the final phase of swapin processing. The tasks
{  of the newly swapped in job will be allowed to execute.
{
{  BRING_UP_JOB_TASKS( AJL )
{
{  AJL: (input) The active job list ordinal of the job whose tasks are to
{               be readied.
{
*DECK DECK=JMH$CALLED_BY_JOB_LEVELER EXPAND=FALSE
{
{    The purpose of this request is to determine if the requestor is the job
{ leveler task.
{
{       JMP$CALLED_BY_JOB_LEVELER () :  BOOLEAN;
{
*DECK DECK=JMH$CALL_JOB_LEVELER_SERVER EXPAND=FALSE
{
{    The purpose of this request is to make the remote procedure call (RPC)
{ from the Job Leveler Task on the client mainframe to the server mainframe.
{
{       JMP$CALL_JOB_LEVELER_SERVER (SERVER_MAINFRAME_ID,
{             LEVELER_SERVER_REQUEST, STATUS);
{
{ SERVER_MAINFRAME_ID: (input)  This is the binary mainframe identifier of the
{       server mainframe that is the target of the remote procedure call
{       request.
{
{ LEVELER_SERVER_REQUEST: (input, output)  This is an Input/Output request
{       block that defines the type of request being made by the job leveler
{       task.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             none.
*DECK DECK=JMH$CALL_SERVER_GET_JOB_STATUS EXPAND=FALSE
*DECK DECK=JMH$CALL_SERVER_SUBMIT_JOB EXPAND=FALSE
*DECK DECK=JMH$CALL_SERVER_TERMINATE_JOB EXPAND=FALSE
{
{    The purpose of this request is to terminate a job on a server mainframe
{ from a client mainframe.  If the job's command file needs to be deleted it
{ will be done from the server mainframe.
{
{       JMP$CALL_SERVER_TERMINATE_JOB (SYSTEM_JOB_NAME, SERVER_MAINFRAME_ID,
{             JOB_STATE_SET, OUTPUT_DISPOSITION_KEY_KNOWN,
{             OUTPUT_DISPOSITION_KEY, OPERATOR_JOB, STATUS);
{
{ SYSTEM_JOB_NAME: (input)  This is the system job name of the job to
{       terminate.
{
{ SERVER_MAINFRAME_ID: (input)  The mainframe identifier of the mainframe on
{       which the job's command file resides.
{
{ JOB_STATE_SET: (input)  This is a list of job states the job must be in to be
{       terminated.
{
{ OUTPUT_DISPOSITION_KEY_KNOWN: (input)  This indicates if the
{       output_disposition_key is known (i.e., has a value).
{
{ OUTPUT_DISPOSITION_KEY: (input)  This is the output disposition to be used by
{       the job being terminated.
{
{ OPERATOR_JOB: (input) Indicates whether or not the terminate job request
{       originated from an operator job (versus a user job).
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             none.
*DECK DECK=JMH$CHANGES_SCH_TBL EXPAND=FALSE
{
{     This request will change selected parts of the job scheduler table.
{
{  JMP$CHANGE_SCH_TBL( SCH_SET, CHANGED_SCH, STATUS)
{
{  SCH_SET: (input) The set of fields to change.
{
{  CHANGED_SCH: (input) The template of new values to change to.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$CHANGE_ATTRIBUTE_DEFAULTS EXPAND=FALSE
{
{    The purpose of this request is to change the system's default job
{ attribute values.
{
{       JMP$CHANGE_ATTRIBUTE_DEFAULTS (JOB_MODE, DEFAULT_ATTRIBUTE_CHANGES,
{             STATUS);
{
{ JOB_MODE: (input)  This indicates which mode's default job attributes are to
{       be changed.
{
{ DEFAULT_ATTRIBUTE_CHANGES: (input)  This represents the attributes to be
{       changed and the values to which they will be changed.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             cle$improper_name
{             jme$invalid_parameter
{             ofe$val_req_for sou
{
*DECK DECK=JMH$CHANGE_CLASS_ATTR EXPAND=FALSE
{
{     This procedure will change all or selected parts of a specified
{  job class. It will also change multiple job classes.
{
{  JMP$CHANGE_CLASS_ATTR( CLASS_SET, ATTR_SET, CHANGED_CAT, STATUS)
{
{  CLASS_SET: (input) The list of classes to affect change.
{
{  ATTR_SET: (input) The set of attributes to change.
{
{  CHANGED_CAT: (output) The template of the new class attribute values.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$CHANGE_CLASS_ATTR_CMND EXPAND=FALSE
{
{     This request will change all or parts of the class attribute table
{  for all or a subset of job classes.
{
{  JMP$CHANGE_CLASS_ATTR_CMND( PARAMS, STATUS)
{
{  PARAMS: (input) Is a command language parameter list.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$CHANGE_INPUT_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to change the attributes of an input file
{ and resubmit the job.
{
{       JMP$CHANGE_INPUT_ATTRIBUTES (INPUT_NAME, INPUT_ATTRIBUTE_CHANGES,
{             STATUS);
{
{ INPUT_NAME: (input)  This is the name of the input file to be changed.
{
{ INPUT_ATTRIBUTE_CHANGES: (input)  This specifies the attributes that are to
{       be changed.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             cle$improper_name
{             jme$cannot_assign_to_job_class
{             jme$duplicate_name
{             jme$input_is_initiated
{             jme$interactive_job_discarded
{             jme$invalid_parameter
{             jme$invalid_parameter_value
{             jme$job_class_does_not_exist
{             jme$no_job_class_found_for_job
{             ofe$sou_not_active
{
*DECK DECK=JMH$CHANGE_JOB_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to change the job attributes of the calling
{  job.
{
{        JMP$CHANGE_JOB_ATTRIBUTES (JOB_ATTRIBUTE_CHANGES, STATUS);
{
{ JOB_ATTRIBUTE_CHANGES: (input) This parameter indicates which job attributes
{        the requestor wants to change.
{
{ STATUS: (output) This specifies the status of the request.
{       CONDITIONS:
{         ave$insufficient_authority
{         cle$improper_name
{         jme$illegal_system_job_command
{         jme$invalid_parameter
{         jme$invalid_working_set_size
{         jme$permanent_file_required
{         jme$value_out_of_range
*DECK DECK=JMH$CHANGE_OUTPUT_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to change the attributes of an output file.
{
{        JMP$CHANGE_OUTPUT_ATTRIBUTES (OUTPUT_NAME, OUTPUT_ATTRIBUTE_CHANGES,
{          STATUS);
{
{ OUTPUT_NAME: (input) This is the name of the output file to be changed.
{
{ OUTPUT_ATTRIBUTE_CHANGES: (input) This specifies the attributes that are to
{        be changed.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{         cle$improper_name
{         jme$duplicate_name
{         jme$illegal_ssn
{         jme$invalid_parameter
{         jme$output_is_initiated,
{         ofe$sou_not_active
{
*DECK DECK=JMH$CHANGE_PROFILE_CYCLE EXPAND=FALSE
{
{   The purpose of this request is to change the cycle number of cycle one of
{ the file $system.scheduling.osf$system_profile to cycle two.  This is the
{ final step in activating a new profile.
{
{       JMP$CHANGE_PROFILE_CYCLE (ACCESS_ID, STATUS)
{
{ ACCESS_ID: (input)  This parameter specifies the access id assigned to the
{       caller when the utility active condition was set.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             jme$access_id_mismatch
{             jme$no_utility_is_active
{             pfe$name_not_permanent_file
{             pfe$pf_system_error
{             pfe$unknown_permanent_file
{             pfe$usage_not_permitted
*DECK DECK=JMH$CHANGE_QFILE_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to change the attributes of a file in the
{ generic queue.
{
{       JMP$CHANGE_QFILE_ATTRIBUTES (SYSTEM_FILE_NAME, ATTRIBUTE_CHANGES_P,
{             STATUS);
{
{ SYSTEM_FILE_NAME: (input)  This is the name of the queue file to be changed.
{
{ ATTRIBUTE_CHANGES_P: (input)  This specifies the attributes that are to be
{       changed.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{         cle$improper_name
{         jme$illegal_ssn
{         jme$invalid_parameter
{         jme$latest_run_time_expired
{         jme$name_not_found
{         jme$qfile_is_initiated
{         ofe$sou_not_active
{
*DECK DECK=JMH$CHANGE_SCHEDULER_TABLE_CMND EXPAND=FALSE
{
{     This request will change all or some fields in the job scheduler table.
{
{  JMP$CHANGE_SCHEDULER_TABLE_CMND (PARAMS, STATUS)
{
{  PARAMS: (input) Is a command language parameter list.
{
{  STATUS: (output) Is the request status.
{
*DECK DECK=JMH$CHANGE_SWAP_JOB EXPAND=FALSE
{
{     This procedure allows the operator to change the priority
{  of a swapped out job.
{
{  JMP$CHANGE_SWAP_JOB (JOB_NAME, PRIORITY_VALUE, STATUS)
{
{  JOB_NAME: (input) The system supplied name of the job swapped out.
{
{  PRIORITY_VALUE: (input) The new priority value of the job.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$CHANGE_TERMINATE_JOB_ACTION EXPAND=FALSE
{    The purpose of this request is to change the action that a terminate job
{ request will take when a job is terminated for the second and subsequent
{ times.
{
{       JMP$CHANGE_TERMINATE_JOB_ACTION (TERMINATE_JOB_ACTION_SET, STATUS);
{
{ TERMINATE_JOB_ACTION_SET: (input)  This is the set of terminate job actions
{       being requested.
{
{ STATUS: (output) This is the status of the request.
{     CONDITIONS:
{         ofe$sou_not_active
*DECK DECK=JMH$CHNG_SWAPPED_JOB_ATTR_CMND EXPAND=FALSE
{
{     This request will change a swapped jobs attributes. It is for
{  use by the system operator.
{
{  JMP$CHNG_SWAPPED_JOB_ATTR_CMND (PARAMS, STATUS)
{
{  PARAMS: (input) Command language parameter list.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$CLEAR_LEVELER_PROFILE_FLAG EXPAND=FALSE
{
{    The purpose of this request is to clear the flag used by the job leveler
{ task to indicate that a scheduling profile is being loaded.
{
{       JMP$CLEAR_LEVELER_PROFILE_FLAG (ACCESS_ID, STATUS);
{
{ ACCESS_ID: (input)  This identifier is used to verify that the request is
{       coming from the scheduling administrator.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{            none.
*DECK DECK=JMH$CLEAR_SERVER_JOB_CLASSES EXPAND=FALSE
{
{    The purpose of this request is to "clear-up" any residue that may have
{ been left over by the job leveler task with respect to any server mainframe.
{ For example, the job classes are all "unblocked" by this request.
{
{    JMP$CLEAR_SERVER_JOB_CLASSES;
*DECK DECK=JMH$CLEAR_UTILITY_ACTIVE EXPAND=FALSE
{
{   The purpose of this request is to clear the utility active flag which was
{ set previously by the caller.  The caller must have scheduling administration
{ privilege.
{
{       JMP$CLEAR_UTILITY_ACTIVE (ACCESS_ID, STATUS)
{
{ ACCESS_ID: (input)  This parameter specifies the access id assigned to the
{       caller when the utility active flag was set.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{            jme$access_id_mismatch
{            jme$must_be_scheduling_admin
{            jme$no_utility_is_active
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$CLEAR_UTILITY_ACTIVE_FLAG EXPAND=FALSE
{
{   The purpose of this request is to clear the utility active flag which was
{ set previously by the caller.
{
{       JMP$CLEAR_UTILITY_ACTIVE_FLAG (ACCESS_ID, STATUS)
{
{ ACCESS_ID: (input)  This parameter specifies the access id assigned to the
{       caller when the utility active flag was set.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{            jme$access_id_mismatch
{            jme$no_utility_is_active
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$CLOSE_FILES_FOR_COPOF EXPAND=FALSE
{
{    The purpose of this request is to close the output queue file and target
{  file on behalf of the copy_output_file command processor.  The files must
{  be closed at the same ring as where they were opened, ring 3.
{
{        JMP$CLOSE_FILES_FOR_COPOF (OUTPUT_FID, OUTPUT_LFN, TARGET_FID,
{          STATUS);
{
{ OUTPUT_FID: (input) This is the file_identifier record for the output queue
{        file.
{
{ OUTPUT_LFN: (input) This is the local file name of the output queue file
{        after it was attached.
{
{ TARGET_FID: (input) This is the file_identifier record for the copy target
{        file.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        None.

*DECK DECK=JMH$CLOSE_FILES_FOR_COPQF EXPAND=FALSE
{
{    The purpose of this request is to close the queue file and target file on
{ behalf of the copy_queue_file command processor and the copy_mail_file
{ command processor.  The files must be closed from the same ring as they were
{ opened, ring 3.
{
{       JMP$CLOSE_FILES_FOR_COPQF (QFILE_FID, QFILE_LFN, TARGET_FID, STATUS);
{
{ QFILE_FID: (input)  This is the file_identifier record for the queue file.
{
{ QFILE_LFN: (input)  This is the local file name of the queue file after it
{       was attached.
{
{ TARGET_FID: (input)  This is the file_identifier record for the copy target
{       file.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        None.
*DECK DECK=JMH$CLOSE_INPUT_FILE EXPAND=FALSE
{
{    The purpose of this request is to close a file in the NOS/VE input queue
{ that was opened with the JMP$OPEN_INPUT_FILE request.
{
{       JMP$CLOSE_INPUT_FILE (FILE_IDENTIFIER, STATUS);
{
{ FILE_IDENTIFIER: (input)  This is the file identifier that was assigned to
{       the file when it was opened.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{        none.
*DECK DECK=JMH$CLOSE_OUTPUT_FILE EXPAND=FALSE
{
{    The purpose of this request is to close a file in the NOS/VE output queue
{ that was opened with the JMP$OPEN_OUTPUT_FILE request.
{
{       JMP$CLOSE_OUTPUT_FILE (FILE_IDENTIFIER, STATUS);
{
{ FILE_IDENTIFIER: (input)  This is the file identifier that was assigned to
{       the file when it was opened.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{        none.
*DECK DECK=JMH$CLOSE_QFILE EXPAND=FALSE
{
{    The purpose of this request is to close a file in the NOS/VE generic queue
{ that was opened with the JMP$OPEN_QFILE request.
{
{       JMP$CLOSE_QFILE (FILE_IDENTIFIER, STATUS);
{
{ FILE_IDENTIFIER: (input)  This is the file identifier that was assigned to
{       the file when it was opened.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{        none
*DECK DECK=JMH$CLOSE_SYSTEM_PROFILE EXPAND=FALSE
{
{   The purpose of this request is to close the system profile.  Since the file
{ was opened in ring 3 by JMP$OPEN_SYSTEM_PROFILE, it must also be closed at
{ ring 3.
{
{       JMP$CLOSE_SYSTEM_PROFILE (ACCESS_ID, DETACH_FILE, FILE_IDENTIFIER,
{            STATUS)
{
{ ACCESS_ID: (input)  This parameter specifies the access id assigned to the
{       caller when the utility active condition was set.
{
{ DETACH_FILE: (input) This specifies that the file should be detached after
{       it is closed.  This is only done after writing the file $system.
{       scheduling.osf$system_profile.1.
{
{ FILE_IDENTIFIER: (input) This specifies the file identifier of the opened
{       file.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             jme$access_id_mismatch
{             jme$no_utility_is_active
*DECK DECK=JMH$CLUSTER_GET_LEVELING_DATA EXPAND=FALSE
{    The purpose of this request is to call the specified mainframe(s) in a
{ cluster to retrieve leveling data.  Leveling data may be any information a
{ site determines to be necessary in order to level interactive jobs.  This
{ routine functions as a co-routine with the jmp$get_leveling_data request.
{
{       JMP$CLUSTER_GET_LEVELING_DATA (TARGET_MAINFRAME_ID, TARGET_OPTIONS_P,
{             DATA_PACKET_SIZE, DATA_AREA_P, MAINFRAMES_PROCESSED,
{             NUMBER_OF_DATA_PACKETS, STATUS);
{
{ TARGET_MAINFRAME_ID: (input)  This is the mainframe to be called.  If the
{       identifier pmc$null_mainframe_id is specified, the function will be
{       performed on all mainframes in the cluster.
{
{ TARGET_OPTIONS_P: (input)  A pointer to a sequence that contains the caller
{       information and options about what data to be returned.
{
{ DATA_PACKET_SIZE: (input)  This indicates the size of data packets that the
{       called function will return.
{
{ DATA_AREA_P: (input, output)  The area where the leveling data is written.
{
{ MAINFRAMES_PROCESSED: (output)  This indicates what mainframes were processed
{       by this request.
{
{ NUMBER_OF_DATA_PACKETS: (output)  This indicates the number of data packets
{       in the data_area_p sequence.  Each mainframe called returns data as one
{       data packet.
{
{ STATUS: (output) This is the status of the request.
{      CONDITION:
{            none
*DECK DECK=JMH$COMBINE_OFFLINE_OUTPUT EXPAND=FALSE
{    The purpose of this request is to write all output files with an
{ output_destination_usage of OFFLINE that are destined for the specified
{ device to the specified tape file.
{
{       JMP$COMBINE_OFFLINE_OUTPUT (TAPE_FILE_PATH, DEVICE_NAME,
{             NUMBER_OF_FILES_TO_COMBINE, COMBINED_FILE_COUNT,
{             COMBINED_FILE_LIST, ERROR_FILE_COUNT, ERROR_FILE_LIST, STATUS);
{
{ TAPE_FILE_PATH: (input)  This is the file path of the tape file.  This must
{       be a magnetic tape device.
{
{ DEVICE_NAME: (input)  This is the name of the output device.  This value is
{       selected by the site.
{
{ NUMBER_OF_FILES_TO_COMBINE: (input)  This is the number of output files to
{       combine to the tape file.  If jmc$maximum_output_files is specified,
{       then all output files for the specified device_name will be written to
{       the tape file.
{
{ COMBINED_FILE_COUNT: (output)  The number of output descriptors (files) in
{       the combined_file_list.
{
{ COMBINED_FILE_LIST: (output)  An array of output descriptors (files) that
{       describes the files that were written to the tape file.
{
{ ERROR_FILE_COUNT: (output)  The number of output descriptors (files) in the
{       error_file_list.
{
{ ERROR_FILE_LIST: (output)  An array of output descriptors (files) that
{       describes the files that could not be written to the tape file.
{
{ STATUS: (output)  The status of the request.
{      CONDITION:
{            ofe$sou_not_active
*DECK DECK=JMH$COMPRE_QUEUES_VIA_PRIORITY EXPAND=TRUE
{
{    The purpose of this request is to compare the input and swap job queues
{  against the active queue. If a job in the active queue is of lower
{  priority than a job in the input or swap queue it is returned for swapout.
{
{  JMP$COMPARE_QUEUES_VIA_PRIORITY(NODE, CLASS, DONE)
{
{  NODE: (output) The id of the returned job.
{
{  CLASS: (output) The job class of the returned job.
{
{  DONE: (output) A boolean specifying whether or not the search has terminated.
{
COMMON
*DECK DECK=JMH$CONSTRUCT_AJL_ENTRY EXPAND=FALSE
{
{     This procedure will rebuild an AJL entry as part of swapin processing.
{
{  CONSTRUCT_AJL_ENTRY (AJL, AJL_ENTRY, KJL_ENTRY_O, SWAP_LIST_ENTRY_P)
{
{  AJL: (input) Active job list index.
{
{  AJL_ENTRY: (input) Contents of the index.
{
{  KJL_ENTRY_O: (input) Ordinal of the associated KJL entry.
{
{  SWAP_LIST_ENTRY_P: (input) A pointer to the swapout list entry for the job.
{
*DECK DECK=JMH$CONVERT_DATE_TIME_DIF_TO_US EXPAND=FALSE
{
{    The purpose of this request is to calculate the difference between two
{ date times, convert the result to microseconds (us) and add in a base
{ free-running clock value.
{
{       JMP$CONVERT_DATE_TIME_DIF_TO_US (BASE_DATE_TIME, DATE_TIME,
{             CURRENT_CLOCK_TIME, FREE_RUNNING_CLOCK_VALUE);
{
{ BASE_DATE_TIME: (input)  This is the base date-time value used for
{       calculation of the date-time difference.
{
{ DATE_TIME: (input)  This is the date-time value used for calculation of the
{       date-time difference.
{
{ CURRENT_CLOCK_TIME: (input)  This is the relative clock time to be added to
{       date-time difference.
{
{ FREE_RUNNING_CLOCK_VALUE: (output)  This is the microsecond (us) value that
{       represents the difference in the date-times (in us) and the current
{       clock time that was specified.
*DECK DECK=JMH$CONVERT_DATE_TIME_TO_CLOCK EXPAND=FALSE
{
{    The purpose of this request is to take a date-time record and convert
{  it to its equivalent microsecond clock time.
{
{        JMP$CONVERT_DATE_TIME_TO_CLOCK (DATE_TIME, MICROSECOND_CLOCK_VALUE);
{
{ DATE_TIME: (input) This is the date-time record to convert into microseconds.
{
{ MICROSECOND_CLOCK_VALUE: (output) This is the microsecond clock value.
{
*DECK DECK=JMH$CONVERT_JOB_TEMPLATE EXPAND=FALSE
{
{     This request will convert a system job template from 60 to 64 bits per
{  word format.
{
{  JMP$CONVERT_JOB_TEMPLATE (PARAMS, STATUS)
{
{  PARAMS: (input) Command language parameter list.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$CONVERT_JOB_TEMPLATE_FILE EXPAND=FALSE
{
{     This procedure will given a local job template file convert it
{  to a 64 bits/ word file from 60 bits/word.
{
{  JMP$CONVERT_JOB_TEMPLATE_FILE (LFN, STATUS)
{
{  LFN: (input) The local file name of the template to be converted.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$CONVERT_NAME_TO_SSN EXPAND=FALSE
{
{    The purpose of this request is to search for a job with the given name and
{  return the system-supplied name of the job if it exists.
{
{        JMP$CONVERT_NAME_TO_SSN (NAME, PRIVILEGED_JOB, SYSTEM_SUPPLIED_NAME,
{          STATUS);
{
{ NAME: (input) This string is the name of the job's whose system-supplied name
{        is being searched for.
{
{ PRIVILEGED_JOB: (input) This indicates whether the request may return the
{        system-supplied name of any job or only jobs for which the login user
{        of the executing job is the owner or originator.
{
{ SYSTEM_SUPPLIED_NAME: (output) This is the system-supplied name of the job
{        being searched for.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS: jme$name_not_found, jme$duplicate_name, cle$improper_name
{       IDENTIFIERS: 'JM', 'CL'
{
*DECK DECK=JMH$COPY_QFILE EXPAND=FALSE
{
{    The purpose of this request is to copy a file from the generic queue to
{ the target file.
{
{       JMP$COPY_QFILE (SYSTEM_FILE_NAME, TARGET_FILE, TARGET_RING, STATUS);
{
{ SYSTEM_FILE_NAME: (input)  This is the name of the queue file to be
{       copied.
{
{ TARGET_FILE: (input) This is the file to which the queue file will be copied.
{
{ TARGET_RING: (input) This specifies the ring at which the target_file is to
{       be created if it does not exist. Target_ring must be >= ring of the
{       caller.
{
{ STATUS: (output) This is the record that contains the status of the request.
{       CONDITIONS:
{             jme$name_not_found
{
{ Remarks: When building object modules that contain calls to
{          JMP$COPY_QFILE, externals must be satisfied from
{          $SYSTEM.OSF$SYSTEM_LIBRARY_46D.
{
{          The user program calling JMP$COPY_QFILE must have ring 6
{          privileges.
*DECK DECK=JMH$CREATE_JOB_TEMPLATE_CMND EXPAND=FALSE
{
{     This request will create a new job template for use in a subsequent
{  deadstart of the system.
{
{  JMP$CREATE_JOB_TEMPLATE_CMND (PARAMS, STATUS)
{
{  PARAMS: (input) Comand language parameter list
{
{  STATUS: (output) Request status.
{
*DECK DECK=JMH$DEACTIVATE_JOB_LEVELING EXPAND=FALSE
{
{    The purpose of this request is to force all known job levelers to return
{ jobs assigned by or to this mainframe to their respective server mainframes.
{ If the levelers on other mainframes do not respond in sufficient time an
{ error will be returned.
{
{       JMP$DEACTIVATE_JOB_LEVELING (STATUS);
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$leveler_not_responding
*DECK DECK=JMH$DEFER_DEACTIVATED_FAMILY EXPAND=FALSE
{    The purpose of this request is to move jobs that are in a queued state to
{ a deferred state because their login family (served family) is unavailable.
{ This request is called on the client by the file server during deactivation
{ and when the server mainframe times out.  This request should be called after
{ the job leveler task has been notified of deactivation or timeout.
{
{       JMP$DEFER_DEACTIVATED_FAMILY (DEACTIVATED_FAMILY_LIST);
{
{ DEACTIVATED_FAMILY_LIST: (input)  This is the list of families that is being
{       deactivated.
{
*DECK DECK=JMH$DEFINE_ANDM_PERMIT_CATALOGS EXPAND=FALSE
{
{   The purpose of this procedure is to  define and permit the Permanent File
{  Catalogs needed by Job Management. An example is the catalog which is used
{  to represent the Swap Files needed by all jobs. This procedure is called
{  only when an Installation Deadstart occures.
{
{     JMP$DEFINE_AND_PERMIT_CATALOGS ( STATUS )
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=JMH$DELETE_IJL_ENTRY EXPAND=FALSE
{
{    This procedure deletes an ijl_entry and the ijl block that contains
{  the entry if it is the last entry in the block.
{
{       JMP$DELETE_IJL_ENTRY (IJL_ORDINAL, IJLE_P)
{
{  IJL_ORDINAL: (input) This parameter specifies the ijl ordinal to the
{       entry to be deleted.
{
{  IJLE_P: (input) This parameter specifies a pointer to the entry to be
{       deleted.
{
*DECK DECK=JMH$DELETE_PROFILE_CYCLE EXPAND=FALSE
{
{   The purpose of this request is to delete a cycle of the system scheduling
{ profile - $system.scheduling.osf$system_profile.  This request can only be
{ made from the utility manage_active_scheduling.  The scheduling profile
{ normally is on cycle 2 of the file.  When installing a new profile, cycle 1
{ is written first, then the profile is installed into the system tables.  If
{ the install is successful, cycle 2 is deleted and cycle 1 is changed to cycle
{ 2.  If the install fails, cycle 1 is deleted.
{
{       JMP$DELETE_PROFILE_CYCLE (ACCESS_ID, CYCLE_NUMBER, STATUS)
{
{ ACCESS_ID: (input)  This parameter specifies the access id assigned to the
{       caller when the utility active condition was set.
{
{ CYCLE_NUMBER: (input) This parameter specifies the specific cycle number of
{       the system scheduling profile to delete.  It can only be 1 or 2.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             jme$access_id_mismatch
{             jme$no_utility_is_active
{             pfe$name_not_permanent_file
{             pfe$pf_system_error
{             pfe$unknown_permanent_file
{             pfe$usage_not_permitted
*DECK DECK=JMH$DETACH_TIMESHARING_JOB EXPAND=FALSE
{
{    The purpose of this request is to detach (disconnect) the current job.
{
{        JMP$DETACH_TIMESHARING_JOB (STATUS);
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{        none
*DECK DECK=JMH$DETERMINE_JOB_CLASS EXPAND=FALSE
{
{    The purpose of this request is to accept a name and return the ordinal
{  value of the job-class represented by that name.
{
{        JMP$DETERMINE_JOB_CLASS (CLASS_NAME, JOB_CLASS, STATUS);
{
{ CLASS_NAME: (input) This is the string representation of the job-class.
{
{ JOB_CLASS: (output) This is the ordinal value of the job-class.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS: jme$invalid_job_class
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$DETERMINE_JOB_CLASS_NAME EXPAND=FALSE
{
{    The purpose of this request is to accept a name and return the ordinal
{  value of the job-class represented by that name.
{
{        JMP$DETERMINE_JOB_CLASS_NAME (JOB_CLASS, JOB_CLASS_NAME, STATUS);
{
{ JOB_CLASS: (input) This is the ordinal value of the job-class.
{
{ JOB_CLASS_NAME: (output) This is the string representation of the job-class.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS: none
{
*DECK DECK=JMH$DETERMINE_NAME_KIND EXPAND=FALSE
{
{    The purpose of this request is to accept a string representation of a name
{  and determine if it is a user or system-supplied name and return a complete
{  representation of the name.
{
{        JMP$DETERMINE_NAME_KIND (CANDIDATE_NAME, NAME, STATUS);
{
{ CANDIDATE_NAME: (input) This string is the name to be parsed.
{
{ NAME: (output) This is the parsed and validated version of the candidate name.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS: cle$improper_name
{
*DECK DECK=JMH$DETERMINE_NEEDED_PRIORITIES EXPAND=FALSE
{
{    The purpose of this request is to retrieve the job priorities that are
{ necessary for assignment to a job class for a job from a server mainframe.
{ Given a job class position (N) for each job class, this request will return
{ the priority of that job.  In order for a server to assign a job to a client,
{ that job's priority must exceed this priority.
{
{       JMP$DETERMINE_NEEDED_PRIORITIES (LEVELER_JOB_CLASS_DATA,
{             JOB_CLASS_PRIORITIES);
{
{ LEVELER_JOB_CLASS_DATA: (input)  This indicates the "number" of jobs the job
{       leveler task is requesting.
{
{ JOB_CLASS_PRIORITIES: (output)  This is the list of job class priorities.
*DECK DECK=JMH$DETERMINE_NEED_FOR_JOBS EXPAND=FALSE
{
{    The purpose of this request is to determine how many jobs of each job
{ class a client mainframe should ask a server mainframe for.
{
{       JMP$DETERMINE_NEED_FOR_JOBS (LEVELER_JOB_CLASS_DATA);
{
{ LEVELER_JOB_CLASS_DATA: (output)  This is the "need" of jobs for each job
{       class.
*DECK DECK=JMH$DISABLE_USER_BREAKS EXPAND=FALSE
{
{    The purpose of this request is to disable user breaks.
{
{       JMP$DISABLE_USER_BREAKS;
*DECK DECK=JMH$DISCARD_SERVER_JOBS EXPAND=FALSE
{
{    The purpose of this request is to discard all uninitiated jobs assigned to
{ the client by the specified server mainframe.
{
{    JMP$DISCARD_SERVER_JOBS (SERVER_MAINFRAME_ID);
{
{ SERVER_MAINFRAME_ID: (input)  This is the binary mainframe id of the server
{       mainframe.
*DECK DECK=JMH$DISPLAY_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to display the attributes requested.
{
{       JMP$DISPLAY_ATTRIBUTES (ATTRIBUTE_VALUES_SEQ, NUMBER_TO_DISPLAY,
{             HEADER_DISPLAY_LIST_P, NOT_FOUND_NAME_LIST,
{             NOT_FOUND_NAME_LIST_COUNT, FILE, COMMAND_TITLE, STATUS);
{
{ ATTRIBUTE_VALUES_SEQ: (input)  This is the set of attributes to display.
{
{ NUMBER_TO_DISPLAY: (input)  This is how many objects in the sequence are to
{       be displayed.
{
{ HEADER_DISPLAY_LIST_P: (input)  This is a list of headers to be displayed
{       with each of the corresponding elements in the ATTRIBUTE_VALUE_SEQ.
{
{ NOT_FOUND_NAME_LIST: (input)  This is a list of objects searched for but were
{       not found.
{
{ NOT_FOUND_NAME_LIST_COUNT: (input)  This is the number of objects in the
{       not_found_name_list.
{
{ FILE: (input)  This is the file to which the display is to be written.
{
{ COMMAND_TITLE: (input)  This is the name of the command.
{
{ STATUS: (output) This is the status of the request.
*DECK DECK=JMH$DISPLAY_CLASS_ATTRIBUTES EXPAND=FALSE
{
{     This request will allow the operator to display either all some
{  or one job class set of attributes.
{
{  JMP$DISPLAY_CLASS_ATTRIBUTES( PARAMS, STATUS)
{
{  PARAMS: (input) Consists of a list of class names which defaults to all.
{          Also the output may be directed to a file so named.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$DISPLAY_JOB_ATTRIBUTES EXPAND=FALSE
{
{ The purpose of this request is to display the job attributes to a file.
{
{        JMP$DISPLAY_JOB_ATTRIBUTES (ATTRIBUTE_P, DISPLAY_KEYS, FILE, STATUS);
{
{ ATTRIBUTE_P: (input) This contains the attribute values that may be displayed.
{
{ DISPLAY_KEYS: (input) This specifies exactly which elements of the ATTRIBUTE_P
{        are to be displayed.
{
{ FILE: (input) This is the file that will receive the display.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS: none
{
*DECK DECK=JMH$DISPLAY_JOB_STATUS EXPAND=FALSE
{
{   The purpose of this request is to display the status of the selected jobs
{ to the specified file using the desired display options.
{
{       JMP$DISPLAY_JOB_STATUS (FILE, DISPLAY_OPTIONS, JOB_NAMES, STATUS);
{
{ FILE: (input) This is the name of the file to write the job status display.
{
{ DISPLAY_OPTIONS: (input) This is the set of desired attributes to display
{       for each job.
{
{ JOB_NAMES: (input) This defines list of jobs for which status is desired.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{        cle$improper_name
{        jme$no_jobs_were_found
*DECK DECK=JMH$DISPLAY_OUTPUT_ATTRIBUTES EXPAND=FALSE
{
{ The purpose of this request is to display output file attributes to a file.
{
{        JMP$DISPLAY_OUTPUT_ATTRIBUTES (ATTRIBUTE_P, NUMBER_OF_OUTPUTS_FOUND,
{          DISPLAY_KEYS, FILE, STATUS);
{
{ ATTRIBUTE_P: (input) This contains the attribute values that may be displayed.
{
{ NUMBER_OF_OUTPUTS_FOUND: (input) This is the number of output files whose
{        attributes are in ATTRIBUTE_P.
{
{ DISPLAY_KEYS: (input) This specifies exactly which elements of the ATTRIBUTE_P
{        are to be displayed.
{
{ FILE: (input) This is the file that will receive the display.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS: none
{

*DECK DECK=JMH$DISPLAY_PRINT_STATUS EXPAND=FALSE
{
{    The purpose of this request is to output a print-status result to a file
{  in a somewhat standard form.
{
{        JMP$DISPLAY_PRINT_STATUS (STATUS_P, NUMBER_RETURNED, PRINT_NAME_LIST_P,
{          FILE, STATUS);
{
{ STATUS_P: (input) This is a pointer to an array of variants which contain
{        the description of statuses to be output.
{
{ NUMBER_RETURNED: (input) This contains the number of elements in STATUS_P
{        to be output.
{
{ PRINT_NAME_LIST_P: (input) This is a pointer to an array that contains names
{        of prints.
{
{ FILE: (input) This is the file to which the output of the request is sent.
{
{ STATUS: (output) This is the record which contains the status of the request.
{
*DECK DECK=JMH$DISPLAY_SCH_TABLE EXPAND=FALSE
{
{     This request will display the job scheduler table to the operator.
{
{  JMP$DISPLAY_SCH_TABLE (PARAMS, STATUS)
{
{  PARAMS: (input) The name of the file to receive output. Default is OUTPUT.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$DISPLAY_SWAP_LIST EXPAND=FALSE
{
{     This request will display the swapped out jobs to the operator.
{
{  JMP$DISPLAY_SWAP_LIST( PARAMS, STATUS)
{
{  PARAMS: (input) The name of a file to receive output. Default is OUTPUT.
{
{  STATUS: The request status.
{
*DECK DECK=JMH$EMIT_COMMUNICATION_STAT EXPAND=FALSE
{
{    The purpose of this request is to build a communication accounting
{ statistic and emit it.
{
{       JMP$EMIT_COMMUNICATION_STAT (STATISTIC_DATA)
{
{ STATISTIC_DATA: (input)  This is a variant record that contains the
{       information needed for the statistic to be emitted.
{
*DECK DECK=JMH$EMIT_JOB_BEGIN_STATISTICS EXPAND=FALSE
{
{   The purpose of this procedure is to emit Job Management statistics at the
{  Job_Begin timeframe for the requesting job.
{
{     JMP$EMIT_JOB_BEGIN_STATISTICS ( STATUS )
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=JMH$EMIT_JOB_END_STATISTICS EXPAND=FALSE
{
{   The purpose of this procedure is to emit Job Management statistics at the
{  Job_End timeframe for the requesting job.
{
{     JMP$EMIT_JOB_END_STATISTICS ( STATUS )
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=JMH$EMIT_JOB_HISTORY_STATISTICS EXPAND=FALSE
{
{    The purpose of this request is to emit a statistic to the history log.
{
{       JMP$EMIT_JOB_HISTORY_STATISTICS (STATISTIC_CODE, DISPOSITION,
{             SYSTEM_JOB_NAME, SYSTEM_FILE_NAME, SYSTEM_LABEL_P,
{             OUTPUT_SYSTEM_LABEL_P, REASON, PARENT_JOB_NAME, STATUS);
{
{ STATISTIC_CODE: (input)  This is the statistic to be emitted.
{
{ DISPOSITION: (input)  This is name describing how a job's output is to be
{       disposed.  It is inserted in the descriptive data for the statistic.
{
{ SYSTEM_JOB_NAME: (input)  This is the name of the job to be inserted in the
{       descriptive data for the statistic.
{
{ SYSTEM_FILE_NAME: (input)  This is the name of the output file to be inserted
{       in the descriptive data for the statistic.
{
{ SYSTEM_LABEL_P: (input)  This is a pointer to the job system label where
{       descriptive data for the statistic is obtained.
{
{ OUTPUT_SYSTEM_LABEL_P: (input)  This is a pointer to the output system label
{       where descriptive data for the statistic is obtained.
{
{ REASON: (input)  This is the condition identifier to be inserted in the
{       descriptive data for the statistic.
{
{ PARENT_JOB_NAME: (input)  This is the name of the parent (submitting) job
{        to be inserted in the descriptive data for the job_queuing_started
{        statistic.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             sfe$descriptive_data_size
{
*DECK DECK=JMH$ENABLE_USER_BREAKS EXPAND=FALSE
{
{    The purpose of this request is to enable user breaks.
{
{       JMP$ENABLE_USER_BREAKS;
*DECK DECK=JMH$END_APPLICATION_SCHEDULING EXPAND=FALSE
{
{    This request resets all the scheduling parameters of the job changed by
{ special application scheduling to the normal job values.
{
{       JMP$END_APPLICATION_SCHEDULING (STATUS)
{
{  STATUS: (output) The normal status parameter.
{       CONDITIONS:
{             NONE
{
*DECK DECK=JMH$END_TIMESHARING_HANDLER EXPAND=FALSE
{
{    The purpose of this request is to indicate that a condition handler dealing
{  with a timesharing (interactive) condition has completed or that a ring-
{  crossing condition has been propogated.
{
{        JMP$END_TIMESHARING_HANDLER (CONDITION);
{
{ CONDITION: (input) This is the interactive condition that has ended.
{
*DECK DECK=JMH$EXECUTE_JOB_TEMPL_TASKS EXPAND=FALSE
{
{     This procedure will call PMP$EXECUTE TASK to create a task to
{  load a given system job template. The entry point of the task is
{  JMP$LOAD_JOB_TEMPLATE.
{
{  JMP$EXECUTE_JOB_TEMPL_TASK (TEMPL_FUNCTION, TEMPL_NAME, FILE_NAME, STATUS)
{
{  TEMPL_FUNCTION: (input) Either the string LOAD or PURGE depending on
{                          the function required.
{
{  TEMPL_NAME: (input) The name associated with the new job template.
{
{  FILE_NAME: (input) The local file containing the job template to be loaded.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$EXIT_JOB EXPAND=FALSE

{
{   The purpose of this procedure is to begin the final stages of job
{ termination in ring 2.  Deletes all segments and their backing store
{ files unique to the job except for the ring 1 and ring 2 stack and the job
{ fixed segment.  The ring 1 stack is wired down for the remainder of the
{ job's life.  The remaining job environment is returned in the ring 1
{ interface including the ring 1 stack backing store file.  The ring 2
{ stack segment should be the only segment to be deleted with a backing store
{ file when this procedure calls the ring 1 interface (last procedure call).
{
{        JMP$EXIT_JOB;
{
{ NOTE:  Control is not returned to the caller when completed.
{

*DECK DECK=JMH$FORCE_CANDIDATE_REFRESH EXPAND=FALSE
{
{    The purpose of this request is to force the job scheduler to release all
{ jobs from the job candidate queue.  When this request completes, the job
{ candidate queue will be refreshed.
{
{    The Known Job List (KJL) must be locked when this request is issued.
{
{       JMP$FORCE_CANDIDATE_REFRESH (FLUSH_CANDIDATE_QUEUE);
{
{ FLUSH_CANDIDATE_QUEUE: (input)  Indicates if the job candidate queue should
{       be flushed of all jobs and be empty when this request completes.
*DECK DECK=JMH$GENERAL_PURPOSE_CLUSTER_RPC EXPAND=FALSE
{    The purpose of this request is to make a request to the specified
{ mainframe.  The function to perform on the target mainframe is supplied as a
{ parameter to this request.  A fixed set of data is passed to the target
{ mainframe.  A set of data is returned by the target mainframe.  A required
{ characteristic of the returned data is that the called process must place
{ fixed size data packets for each "object" for which data are being returned.
{
{       JMP$GENERAL_PURPOSE_CLUSTER_RPC (TARGET_MAINFRAME_ID,
{             PROCEDURE_ORDINAL, DATA_PACKET_SIZE, MAINFRAMES_PROCESSED_SO_FAR,
{             TARGET_OPTIONS_P, DATA_AREA_P, TARGET_MAINFRAME_REACHED,
{             MAINFRAMES_PROCESSED, NUMBER_OF_DATA_PACKETS, STATUS);
{
{ TARGET_MAINFRAME_ID: (input)  This is the mainframe on which the supplied
{       function is to be performed.  If the identifier pmc$null_mainframe_id
{       is specified, the function will be performed on all mainframes in the
{       cluster.
{
{ PROCEDURE_ORDINAL: (input)  This indicates the function to perform (i.e., the
{       procedure to call) on the target mainframe.
{
{ DATA_PACKET_SIZE: (input)  This indicates the size of data packets that the
{       called function will return.
{
{ MAINFRAMES_PROCESSED_SO_FAR: (input)  This is the list of mainframes that
{       have been processed up until this request has been issued.
{
{ TARGET_OPTIONS_P: (input)  This sequence contains the list of options to be
{       supplied to the function on the target mainframe.  The entire sequence
{       is copied to the target.  The #SEQ intrinsic can be most useful for
{       this parameter.
{
{ DATA_AREA_P: (input, output)  This is the address space to which the data returned
{       by the function on the target mainframe should be placed.
{
{ TARGET_MAINFRAME_REACHED: (output)  This indicates whether or not the
{       supplied target mainframe has been reached.  If all mainframes are
{       being processed, this will always have the value FALSE.
{
{ MAINFRAMES_PROCESSED: (output)  This indicates what mainframes were processed
{       by this request plus the mainframes that were supplied in the
{       MAINFRAMES_PROCESSED_SO_FAR parameter.
{
{ NUMBER_OF_DATA_PACKETS: (output)  This is the number of data packets in the
{       address space pointed to by the DATA_AREA_P parameter.  The total size
{       of the data area is NUMBER_OF_DATA_PACKETS * DATA_PACKET_SIZE (in
{       bytes).
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$work_area_too_small
*DECK DECK=JMH$GENERATE_SWAP_REQUEST EXPAND=FALSE
{
{     This request will be the first step in a swapout procedure. It will
{  idle all tasks of the specified job.
{
{  GENERATE_SWAP_REQUEST (NODE, REASON, CONTINUE, STATUS)
{
{  NODE: (input) This parameter identifies the job to be acted upon.
{
{  REASON: (input) This specifies the reason for the swapout request.
{
{  CONTINUE: (output) This indicates whether or not subsequent swapout steps
{                     can proceed immediately.
{  STATUS: (output) This is the request status.
{
*DECK DECK=JMH$GENERATE_TIMESHARING_TITLE EXPAND=FALSE
{    The purpose of this request is to translate a binary mainframe identifier
{ to a universally unique timesharing title used to represent a given
{ mainframe.  The value returned is a string and not a valid SCL name, which
{ makes the title a non-configurable value.  This prohibits users from doing a
{ CREATE_CONNECTION using this title.
{
{       JMP$GENERATE_TIMESHARING_TITLE (BINARY_MAINFRAME_ID,
{             TIMESHARING_TITLE);
{
{ BINARY_MAINFRAME_ID: (input)  This is the binary mainframe identifier of the
{       mainframe whose timesharing title is of interest.
{
{ TIMESHARING_TITLE: (output)  This is the timesharing title for the requested
{       mainframe.
*DECK DECK=JMH$GET_ACTIVE_SCHEDULING_ATTR EXPAND=FALSE
{
{    The purpose of this request is to get the active scheduling attributes and
{ statistics for the current mainframe and specified job class.
{
{       JMP$GET_ACTIVE_SCHEDULING_ATTR (JOB_CLASS_NAME,
{             SCHEDULING_RESULTS_KEYS_P, WORK_AREA_P,
{             SCHEDULING_ATTRIBUTE_RESULTS_P, STATUS)
{
{ JOB_CLASS_NAME: (input)  This parameter specifies the assigned job class of a
{       job.
{
{ SCHEDULING_RESULTS_KEYS_P: (input)  This parameter specifies which attributes
{       to return.
{
{ WORK_AREA_P: (input, output)  This parameter specifies a work area that will
{       contain the data returned.  The sequence is not RESET by this request.
{
{ SCHEDULING_ATTRIBUTE_RESULTS_P: (output)  This parameter specifies the
{       requested data.  It points into the work area provided on the
{       WORK_AREA_P parameter.
{
{ STATUS: (output) This parameter returns the status of the request.
{    CONDITIONS:
{       jme$work_area_too_small
{       jme$job_class_not_defined
*DECK DECK=JMH$GET_AJL_STATISTICS EXPAND=FALSE
{
{     This procedure gathers pertinent information concerning the AJL.
{  This is a stack of free + reserved AJL entries, the sum of all
{  jobs working sets, the page fault rate of all jobs and the total
{  available pages.
{
{  GET_AJL_STATISTICS (AJL_STACK, AJL_RES_STACK, MAX_AJL_INDEX, TOP_OF_AJL_STACK,
{         TOP_OF_AJL_RES_STACK, WS_SUM, PF_RATE, TOTAL_AVAIL_PAGES)
{
{  AJL_STACK: (input) A list to be filled in of free ajl entries.
{
{  AJL_RES_STACK: (input) A list to be filled in of free reserved ajl entries.
{
{  MAX_AJL_INDEX: (input) The delineation of reserved - free ajl entries.
{
{  TOP_OF_AJL_STACK: (output) The number of free ajl_entries.
{
{  TOP_OF_AJL_RES_STACK: (output) The top of reserved ajl entries.
{
{  WS_SUM: (output) The summation of all jobs working sets.
{
{  PF_RATE: (output) The summation of all jobs page fault rates.
{
{  TOTAL_AVAIL_PAGES: (output) The total number of free pages in memory.
{
*DECK DECK=JMH$GET_APPLICATION_RECORD EXPAND=FALSE
{
{   The purpose of this request is to return the attributes for a given
{ application from the application table used for scheduling applications.
{ The application must be defined in the application table.  The caller
{ must have scheduling administration privilege.
{
{       JMP$GET_APPLICATION_RECORD (APPLICATION_NAME, APPLICATION_RECORD,
{         STATUS)
{
{ APPLICATION_NAME: (input)  This parameter specifies the name of the
{       application for the request.
{
{ APPLICATION_RECORD: (output)  This parameter specifies the result record for
{       the application attributes.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{            cle$improper_name
{            jme$class_or_appl_not_defined
{            jme$must_be_scheduling_admin
{       IDENTIFIER: 'CL', 'JM'
{
*DECK DECK=JMH$GET_ATTRIBUTE_DEFAULTS EXPAND=FALSE
{
{    The purpose of this request is to retrieve the system's default job
{ attribute values.
{
{       JMP$GET_ATTRIBUTE_DEFAULTS (JOB_MODE, DEFAULT_ATTRIBUTE_RESULTS,
{             STATUS);
{
{ JOB_MODE: (input)  This is the job mode for which the default values are
{       being requested.
{
{ DEFAULT_ATTRIBUTE_RESULTS: (input, output)  This indicates which attributes
{       to retrieve and is a place to store the attribute data.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$invalid_parameter
*DECK DECK=JMH$GET_ATTRIBUTE_INDEX EXPAND=FALSE
{
{    The purpose of this request is to determine the attribute key (index) of
{  an attribute based on its name or abbreviation.  If the name of the
{  attribute is unknown the attribute key jmc$unknown_attribute is returned.
{
{        JMP$GET_ATTRIBUTE_INDEX (ATTRIBUTE_NAME, ATTRIBUTE_INDEX);
{
{ ATTRIBUTE_NAME: (input) This is the name or the abbreviation of the
{        attribute being queried.
{
{ ATTRIBUTE_INDEX: (output) This is the matching key (index) of the attribute
{        that was requested.
*DECK DECK=JMH$GET_ATTRIBUTE_NAME EXPAND=FALSE
{
{    The purpose of this request is to determine the attribute name of an
{  attribute based on its key (index).  If the key of the attribute is
{  unknown the name 'UNKNOWN' is returned.
{
{        JMP$GET_ATTRIBUTE_NAME (ATTRIBUTE_INDEX, ATTRIBUTE_NAME);
{
{ ATTRIBUTE_INDEX: (input) This is the key (index) of the attribute being
{        queried.
{
{ ATTRIBUTE_NAME: (output) This is the name of the requested attribute.
*DECK DECK=JMH$GET_CATEGORY_DATA EXPAND=FALSE
{
{   The purpose of this request is to return the category data used for
{ categorizing input jobs.  The caller must have scheduling administration
{ privilege.
{
{       JMP$GET_CATEGORY_DATA (CATEGORY_DATA, DATA_P, STATUS)
{
{ CATEGORY_DATA: (output)  This parameter specifies the result record for the
{       category data.
{
{ DATA_P: (output)  This parameter specifies a pointer to an adaptable
{       sequence.  Category data which has variable length is returned in this
{       sequence.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             jme$must_be_scheduling_admin
{             jme$mo_element_in_sequence
{             jme$no_space_in_runtime_stack
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$GET_CLASS_ATTRIBUTES EXPAND=FALSE
{
{     This request gets a copy of 1 or all job class attribute table entries.
{  The copy is used for display to operator.
{
{  JMP$GET_CLASS_ATTR( DISPLAY_CLASSES, DISP, STATUS)
{
{  DISPLAY_CLASSES: (input) A set of the classes whose attributes to display.
{
{  DISP: (output) An array of displays corresponding to the classes specified.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$GET_CLIENT_SCHEDULING_DATA EXPAND=FALSE
{
{    The purpose of this request is to get the job scheduling information
{ needed by the job leveler task on a client mainframe.
{
{       JMP$GET_CLIENT_SCHEDULING_DATA (SCHEDULING_DATA);
{
{ SCHEDULING_DATA: (output)  This record contains the information necessary for
{       the job leveler task.
*DECK DECK=JMH$GET_DEFAULT_CLASS_VALUES EXPAND=FALSE
{
{   The purpose of this request is to return the default attribute values for a
{ job class, service class, and application which are used as the base when
{ initializing the scheduler tables during system deadstart.  The caller must
{ have scheduling administration privilege.
{
{       JMP$GET_DEFAULT_CLASS_VALUES ( JOB_CLASS_DEFAULTS,
{         SERVICE_CLASS_DEFAULTS, APPLICATION_DEFAULTS, STATUS)
{
{ JOB_CLASS_DEFAULTS: (output)  This parameter specifies the result record for
{       the default attribute values for a job class.
{
{ SERVICE_CLASS_DEFAULTS: (output)  This parameter specifies the result record
{       for the default attribute values for a service class.
{
{ APPLICATION_DEFAULTS: (output)  This parameter specifies the result record
{       for the default attribute values for an application.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             jme$must_be_scheduling_admin
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$GET_DEFINED_CLASSES EXPAND=FALSE
{
{   The purpose of this request is to return a list of the job classes, service
{ classes, or applications defined in the scheduler tables.  The caller must
{ have scheduling administration privilege.
{
{       JMP$GET_DEFINED_CLASSES (CLASS_KIND, DEFINED_CLASSES,
{         NUMBER_OF_CLASSES, STATUS)
{
{ CLASS_KIND: (input)  This parameter specifies whether information is being
{       requested for job classes, service classes, or applications.
{
{ DEFINED_CLASSES: (output)  This parameter specifies an array in which the
{       names and indices of the defined classes or applications are returned.
{       Job classes are returned in ranked order of highest to lowest.
{
{ NUMBER_OF_CLASSES: (output)  This parameter specifies the number of defined
{       classes or applications for which information is returned.
{
{ STATUS: (output) This parameter specifies the request status.  When the
{       condition, jme$error_in_job_class_ranking, is returned, all of the
{       defined job classes are returned but the ranking is unknown.
{       CONDITIONS:
{             jme$error_in_job_class_ranking
{             jme$must_be_scheduling_admin
{             jme$result_array_is_too_small
{             jme$unknown_class_kind
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$GET_ENCRYPTED_PASSWORD EXPAND=FALSE
{
{    The purpose of this request is to retrieve the requesting user's login
{ password in an encrypted form.
{
{       JMP$GET_ENCRYPTED_PASSWORD (ENCRYPTED_PASSWORD, STATUS);
{
{ ENCRYPTED_PASSWORD: (output)  This is the requestor's encrypted password.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{            none.
*DECK DECK=JMH$GET_INPUT_ATTRIBUTES EXPAND=FALSE
{    The purpose of this request is to retrieve the attributes of a file in a
{ NOS/VE input queue.
{
{       JMP$GET_INPUT_ATTRIBUTES (INPUT_ATTRIBUTE_OPTIONS_P,
{             INPUT_ATTRIBUTE_RESULTS_KEYS_P, WORK_AREA_P,
{             INPUT_ATTRIBUTE_RESULTS_P, NUMBER_OF_JOBS_FOUND, STATUS);
{
{ INPUT_ATTRIBUTE_OPTIONS_P: (input)  This is a set of criteria that selects
{       which input file(s) to retrieve the attributes for.
{
{ INPUT_ATTRIBUTE_RESULTS_KEYS_P: (input)  This is a pointer to an array of
{       keys that selects the data to retrieve about the input file(s).  Keys
{       that can be specified are the same as those returned in the
{       INPUT_ATTRIBUTE_RESULTS_P parameter.
{
{ WORK_AREA_P: (input, output)  This is a pointer to a sequence that is defined
{       by the caller.  The size required for a specific number of files can be
{       obtained by calling jmp$get_result_size.  See jmh$get_result_size for
{       further information.  Jmp$get_input_attributes will not RESET this
{       sequence before using it and will leave it positioned at the end of the
{       area used.
{
{ INPUT_ATTRIBUTE_RESULTS_P: (input, output)  This is a pointer (into the work
{       area) to an array of variants that contains the data retrieved about
{       the file(s).
{
{ NUMBER_OF_JOBS_FOUND: (output)  This contains the number of input files that
{       met the INPUT_ATTRIBUTE_OPTIONS_P criteria.  If the status condition
{       jme$work_area_too_small is returned this value indicates the total
{       number of input files that were found.
{
{ STATUS: This is the status of the request.
{      CONDITIONS:
{        cle$improper_name
{        jme$duplicate_attribute_key
{        jme$invalid_parameter
{        jme$no_jobs_were_found
{        jme$work_area_too_small
*DECK DECK=JMH$GET_INPUT_Q_FROM_UNASSIGNED EXPAND=FALSE
{
{   The purpose of this request is obtain a list of the input jobs in the
{ UNASSIGNED job class which have a job destination of VE.  The caller must
{ have scheduling administration privilege.
{
{       JMP$GET_INPUT_Q_FROM_UNASSIGNED (SYSTEM_SUPPLIED_NAMES,
{         NUMBER_OF_JOBS_FOUND, STATUS)
{
{ SYSTEM_SUPPLIED_NAMES: (output)  This parameter specifies a result array in
{       which the system supplied names of the input jobs in the UNASSIGNED job
{       class are returned.  These jobs have a job destination of VE.
{
{ NUMBER_OF_JOBS_FOUND: (output)  This parameter specifies the number of input
{       jobs for which information is returned.  If status condition,
{       jme$result_array_is_too_small, is returned, this value indicates the
{       total number of input jobs which met the criteria.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             jme$must_be_scheduling_admin
{             jme$result_array_too_small
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$GET_JM_WORK_AREA EXPAND=FALSE
{
{    The purpose of this request is to get a pointer to the job management work
{ area.  If the work area does not exist it will be created.
{
{       JMP$GET_JM_WORK_AREA (JM_WORK_AREA_P, STATUS)
{
{ JM_WORK_AREA_P: (output)  This parameter is a pointer to a sequence that is
{       the job management work area.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             none
{
*DECK DECK=JMH$GET_JOB_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to retrieve the job attributes of the
{  requesting job.
{
{        JMP$GET_JOB_ATTRIBUTES (JOB_ATTRIBUTE_RESULTS, STATUS);
{
{ JOB_ATTRIBUTE_RESULTS: (input,output) This contains the attributes to be
{        retrieved.
{
{ STATUS: This is the status of the request.
{       CONDITIONS: jme$invalid_parameter
{
*DECK DECK=JMH$GET_JOB_CLASS EXPAND=FALSE
{     This procedure will return the job classification of a specified job.
{
{  GET_JOB_CLASS( KJL, CLASS)
{
{  KJL: (input) The Known Job List (KJL) ordinal of the job.
{
{  CLASS: (output) The associated job class.
{
*DECK DECK=JMH$GET_JOB_CLASS_EPILOG EXPAND=FALSE
{
{   The purpose of this request is to obtain the file pathname of the job class
{ epilog for the caller job.
{
{       JMP$GET_JOB_CLASS_EPILOG (JOB_CLASS_EPILOG, STATUS);
{
{ JOB_CLASS_EPILOG: (outut)  This parameter specifies the file pathname of the
{       job class epilog for the caller job.  No job class epilog is
{       represented by the empty string, ''.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             jme$job_class_not_defined
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$GET_JOB_CLASS_PROLOG EXPAND=FALSE
{
{   The purpose of this request is to obtain the file pathname of the job class
{ prolog for the caller job.
{
{       JMP$GET_JOB_CLASS_PROLOG (JOB_CLASS_PROLOG, STATUS);
{
{ JOB_CLASS_PROLOG: (outut)  This parameter specifies the file pathname of the
{       job class prolog for the caller job.  No job class prolog is
{       represented by the empty string, ''.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             jme$job_class_not_defined
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$GET_JOB_CLASS_RECORD EXPAND=FALSE
{
{   The purpose of this request is to return the attributes for a given job
{ class from the job class table used for job scheduling.  The job class must
{ be defined in the job class table.  The caller must have scheduling
{ administration privilege.
{
{       JMP$GET_JOB_CLASS_RECORD ( JOB_CLASS_INDEX, JOB_CLASS_RECORD, DATA_P,
{         STATUS)
{
{ JOB_CLASS_INDEX: (input)  This parameter specifies the index of the job class
{       for the request.
{
{ JOB_CLASS_RECORD: (output)  This parameter specifies the result record for
{       the job class attributes.
{
{ DATA_P: (output)  This parameter specifies a pointer to an adaptable
{       sequence.  Job class attributes which have variable length are returned
{       in this sequence.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             jme$class_index_not_defined
{             jme$must_be_scheduling_admin
{             jme$no_element_in_sequence
{             jme$no_space_in_runtime_stack
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$GET_JOB_CLASS_STATISTICS EXPAND=FALSE
{
{   The purpose of this request is to return the statistics for the given job
{ class.  The job class must be defined in the job class table.  The caller
{ must have scheduling administration privilege.
{
{       JMP$GET_JOB_CLASS_STATISTICS (JOB_CLASS_INDEX, JOB_CLASS_STATISTICS,
{         STATUS)
{
{ JOB_CLASS_INDEX: (input)  This parameter specifies the index of the job class
{       for the request.
{
{ JOB_CLASS_STATISTICS: (output)  This parameter specifies the result record
{       for the job class statistics.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             jme$class_index_not_defined
{             jme$must_be_scheduling_admin
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$GET_JOB_COMMAND_INPUT_LFN EXPAND=FALSE
{
{   The purpose of this procedure is to obtain the Local_File_name (LFN) of
{  the $COMMAND file belonging to the requesting job.
{
{     JMP$GET_JOB_COMMAND_INPUT_LFN ( LOCAL_FILE_NAME, STATUS )
{
{  LOCAL_FILE_NAME: (output) This parameter specifies the Local_File_Name of
{                            the requesting jobs $COMMAND file.
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=JMH$GET_JOB_COUNTS EXPAND=FALSE
{
{   The purpose of this request is to retrieve some count information
{ kept about jobs.  The count information includes items such a the
{ number of queued and initiated jobs and job class counts.
{
{        JMP$GET_JOB_COUNTS (JOB_COUNTS, STATUS);
{
{ JOB_COUNTS: (output) This is a record that contains various counts of
{        general interest.
{
{ STATUS: (output) This is a record that contains the status of the request.
{
*DECK DECK=JMH$GET_JOB_IJL_ORDINAL EXPAND=FALSE
{
{    The purpose of this request is to retreive the Initiated_Job_List (IJL)
{ ordinal of a job.
{
{       JMP$GET_JOB_IJL_ORDINAL (NAME, PRIVILEGED_JOB, IJL_ORDINAL,
{         SYSTEM_SUPPLIED_NAME, STATUS);
{
{ NAME: (input)  This string is the name of the job whose IJL ordinal we want.
{
{ PRIVILEGED_JOB: (input) This indicates whether the request may return the
{        ijl ordinal of any job or only jobs for which the login user
{        of the executing job is the owner or originator.
{
{ IJL_ORDINAL: (output)  This is the IJL ordinal of the job.
{
{ SYSTEM_SUPPLIED_NAME: (output)  This is the system supplied name of the job.
{
{ STATUS: This is the status of the request.
{       CONDITIONS:
{             jme$name_not_found
{             jme$duplicate_name
{             cle$improper_name
{
*DECK DECK=JMH$GET_JOB_INTERNAL_INFO EXPAND=FALSE
{
{    The purpose of this request is to retrieve various internal data of an
{  executing job via the system supplied name of the job.
{
{        JMP$GET_JOB_INTERNAL_INFO (SYSTEM_SUPPLIED_NAME,
{          JOB_INTERNAL_INFO, STATUS)
{
{ SYSTEM_SUPPLIED_NAME: (input) This parameter specifies the system supplied
{                       name of the job.
{
{ JOB_INTERNAL_INFO: (output) This parameter specifies the job's internal
{                     information.
{
{ STATUS: (output) This is a record that contains the status of the request.
{

*DECK DECK=JMH$GET_JOB_NAMES_BY_USER EXPAND=FALSE
{    The purpose of this request is to translate a user and family name into a
{ list of system job names and mainframe identifiers on which those job's are
{ executing.
{
{       JMP$GET_JOB_NAMES_BY_USER (USER, FAMILY, JOB_NAME_LIST_P,
{             NUMBER_OF_JOBS_FOUND, STATUS);
{
{ USER: (input)  This is the name of the user.
{
{ FAMILY: (input)  This is the name of the family.
{
{ JOB_NAME_LIST_P: (output)  This is a pointer to an array that will contain
{       the resulting system job names and mainframe identifiers.  The status
{       condition jme$result_array_too_small will be returned if this array is
{       not large enough.
{
{ NUMBER_OF_JOBS_FOUND: (output)  This is the number of jobs that were
{       executing for the user/family supplied.  If the status condition
{       jme$result_array_too_small is returned, this number represents the
{       actual number of jobs that were found.
{
{ STATUS: (output)  This is the result of the request.
{      CONDITIONS:
{            jme$no_jobs_were_found
{            jme$result_array_too_small
*DECK DECK=JMH$GET_JOB_NAME_VIA_GTID EXPAND=FALSE

{
{   The purpose of this request is to return the system_supplied_name of a
{ job that contains the specified global_task_id.
{
{       JMP$GET_JOB_NAME_VIA_GTID (GLOBAL_TASK_ID, SYSTEM_SUPPLIED_NAME,
{             JOB_EXISTS)
{
{ GLOBAL_TASK_ID: (input) This parameter specifies the global_task_id of
{       the specified task.
{
{ SYSTEM_SUPPLIED_NAME: (output) This parameter specifies the
{       system_supplied_name of the job that the specified task belongs to.
{
{ JOB_EXISTS: (output) This parameter specifies whether the job of the
{       specified task exists at the instant the taskid was verified.
{       NOTE:  The task may have exited by the time the system_supplied_
{       name is returned to the caller.
{
*DECK DECK=JMH$GET_JOB_PARAMETERS EXPAND=FALSE
{
{    The purpose of this request is to retrieve a copy of the system parameters
{  given to a job upon submission.
{
{        JMP$GET_JOB_PARAMETERS (JOB_PARAMETERS, STATUS)
{
{
{ JOB_PARAMETERS: (output) This is the job_management representation of system
{        parameters given to a job.
{
{ STATUS: (output) This is a record that contains the status of the request.
{

*DECK DECK=JMH$GET_JOB_PATH_ELEMENTS EXPAND=FALSE
{
{    The purpose of this request is to obtain the permanent file path for the
{  command file of a batch job.
{
{        JMP$GET_JOB_PATH_ELEMENTS (SYSTEM_JOB_NAME, PATH, STATUS);
{
{ SYSTEM_JOB_NAME: (input) This is the system-supplied job name for the job
{        in question.
{
{ PATH: (output) This is an array which will contain the elements of the
{        permanent file path.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        jme$name_not_found
{        ofe$sou_not_active
*DECK DECK=JMH$GET_JOB_STATUS EXPAND=FALSE
{
{    The purpose of this request is to obtain various data about a job or set
{ of jobs based on specified criteria.
{
{       JMP$GET_JOB_STATUS (JOB_STATUS_OPTIONS_P, JOB_STATUS_RESULTS_KEYS_P,
{             WORK_AREA_P, JOB_STATUS_RESULTS_P, NUMBER_OF_JOBS_FOUND, STATUS);
{
{ JOB_STATUS_OPTIONS_P: (input)  This is a pointer to an array of variants that
{       determine which job or jobs to status.
{
{ JOB_STATUS_RESULTS_KEYS_P: (input)  This is a pointer to an array of keys
{       that selects the data to retrieve about the job(s).  Keys that can be
{       specified are the same as those that can be returned in the
{       JOB_STATUS_RESULTS_P parameter.
{
{ WORK_AREA_P: (input, output)  This is a pointer to a sequence that is defined
{       by the caller.  The size required for a specified number of jobs can be
{       obtained by calling jmp$get_result_size.  See jmh$get_result_size for
{       further information.  Jmp$get_job_status will not RESET this sequence
{       before using it and will leave it positioned at the end of the area
{       used.
{
{ JOB_STATUS_RESULTS_P: (output)  This is a pointer (into the work area) to an
{       array of variants that contains the data retrieved about the job(s).
{
{ NUMBER_OF_JOBS_FOUND: (output)  This indicates the number of jobs that fit
{       the criteria given by JOB_STATUS_OPTIONS_P.  If the status condition
{       jme$work_area_too_small is returned this value indicates the total
{       number of jobs that were found.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        cle$improper_name
{        jme$duplicate_attribute_key
{        jme$invalid_parameter
{        jme$no_jobs_were_found
{        jme$work_area_too_small
*DECK DECK=JMH$GET_JOB_STATUS_SIZE EXPAND=FALSE
*DECK DECK=JMH$GET_LENGTH_OF_SCHED_TABLES EXPAND=FALSE
{
{   The purpose of this request is to return the maximum lengths of the tables
{ used for job scheduling.  The caller must have scheduling administration
{ privilege.
{
{       JMP$GET_LENGTH_OF_SCHED_TABLES (MAXIMUM_JOB_CLASSES,
{         MAXIMUM_JOB_CLASS_INDEX, MAXIMUM_SERVICE_CLASSES,
{         MAXIMUM_SERVICE_CLASS_INDEX, MAXIMUM_APPLICATIONS,
{         MAXIMUM_CATEGORIES, STATUS)
{
{ MAXIMUM_JOB_CLASSES: (output)  This parameter specifies the maximum number of
{       of job classes that may be defined.  This maximum is the system
{       attribute set by the site at system deadstart.
{
{ MAXIMUM_JOB_CLASS_INDEX: (output)  This parameter specifies the current size
{       of the job class table.  This value can be greater than or equal to
{       maximum_job_classes.
{
{ MAXIMUM_SERVICE_CLASSES: (output)  This parameter specifies the maximum
{       number of service classes that may be defined.  This maximum is the
{       system attribute set by the site at system deadstart.
{
{ MAXIMUM_SERVICE_CLASS_INDEX: (output)  This parameter specifies the current
{       size of the service class table.  This value can be greater than or
{       equal to maximum_service_classes.
{
{ MAXIMUM_APPLICATIONS: (output)  This parameter specifies the maximum number
{       of applications that may be defined.
{
{ MAXIMUM_CATEGORIES: (output)  This parameter specifies the maximum number of
{       job categories that may be defined.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             jme$must_be_scheduling_admin
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$GET_LEVELING_DATA EXPAND=FALSE
{    The purpose of this request is to get leveling data on the requesting
{ mainframe.  The procedure jmp$mainframe_get_leveling_data, which may be
{ modified by the site, is called to collect the information.  This routine
{ functions as a co-routine with the jmp$cluster_get_leveling_data request.
{ This request is called by the jmp$general_purpose_cluster_rpc request.
{
{       JMP$GET_LEVELING_DATA (TARGET_OPTIONS_P, DATA_AREA_P,
{             NUMBER_OF_DATA_PACKETS, STATUS);
{
{ TARGET_OPTIONS_P: (input)  A pointer to a sequence that contains the caller
{       information and options about what data is to be returned.
{
{ DATA_AREA_P: (input, output)  The area where the leveling data is written.
{
{ NUMBER_OF_DATA_PACKETS: (output)  This indicates the number of data packets
{       in the data_area_p sequence.  This request returns all data from one
{       mainframe in one data packet.  Therefore, this value will always be 1.
{
{ STATUS: (output) This is the status of the request.
{      CONDITION:
{            none
*DECK DECK=JMH$GET_MAX_SWAPPED_JOBS EXPAND=FALSE
{
{     This procedure will return the maximum amount of swapped jobs allowed
{  in the system.
{
{  JMP$GET_MAX_SWAPPED_JOBS( MAX_SW_JBS, STATUS)
{
{  MAX_SW_JBS: (output) The number of swapped jobs allowed
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$GET_NEXT_ENTRY EXPAND=FALSE
{
{     This procedure will chain through any given KJL thread and return
{  individual KJL entries, until the thread is exhausted.
{
{  JMP$GET_NEXT_ENTRY (DONE, KJL_THD, NEXT_ENTRY)
{
{  DONE: (output) Indicates whether or not thread is exhausted.
{
{  KJL_THD: (input) The thread to search.
{
{  NEXT_ENTRY: (output) The individual kjl entry ordinal.
{
*DECK DECK=JMH$GET_OUTPUT_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to retrieve the output attributes of output
{ files.
{
{       JMP$GET_OUTPUT_ATTRIBUTES (OUTPUT_ATTRIBUTE_OPTIONS_P,
{             OUTPUT_ATTRIBUTE_RESULTS_KEYS_P, WORK_AREA_P,
{             OUTPUT_ATTRIBUTE_RESULTS_P, NUMBER_OF_OUTPUTS_FOUND, STATUS);
{
{ OUTPUT_ATTRIBUTE_OPTIONS_P: (input)  This is the criteria that selects which
{       output file(s) to retrieve the attributes for.
{
{ OUTPUT_ATTRIBUTE_RESULTS_KEYS_P: (input)  This is a pointer to an array of
{       keys that selects the data to retrieve about the file(s).  Keys that
{       can be specified are the same as those returned in the
{       OUTPUT_ATTRIBUTE_RESULTS_P parameter.
{
{ WORK_AREA_P: (input, output)  This is a pointer to a sequence that is defined
{       by the caller.  The size required for a specific number of files can be
{       obtained by calling jmp$get_result_size.  See jmh$get_result_size for
{       further information.  Jmp$get_output_attributes will not RESET this
{       sequence before using it and will leave it positioned at the end of the
{       area used.
{
{ OUTPUT_ATTRIBUTE_RESULTS_P: (output)  This is a pointer (into the work area)
{       to an array of variants that contains the data retrieved about the
{       file(s).
{
{ NUMBER_OF_OUTPUTS_FOUND: (output)  This is the number of output files that
{       met the OUTPUT_ATTRIBUTE_OPTIONS_P criteria.  If the status condition
{       jme$work_area_too_small is returned this value indicates the total
{       number of output files that were found.
{
{ STATUS: This is the status of the request.
{       CONDITIONS:
{         cle$improper_name
{         jme$duplicate_output_attr_key
{         jme$invalid_parameter
{         jme$no_outputs_were_found
{         jme$work_area_too_small
*DECK DECK=JMH$GET_OUTPUT_COUNTS EXPAND=FALSE
{
{    The purpose of this request is to determine the number of files that are
{  in the NOS/VE output queue.
{
{        JMP$GET_OUTPUT_COUNTS (OUTPUT_COUNTS, STATUS);
{
{ OUTPUT_COUNTS: (output) This is the set of counts of how many output files
{        there are in the output queue.
{
{ STATUS: (output) This is the status of the request.
{      IDENTIFIER:
{        'JM'
{      CONDITIONS:
{        none.
*DECK DECK=JMH$GET_OUTPUT_PATH_ELEMENTS EXPAND=FALSE
{
{    The purpose of this request is to obtain the permanent file path for the
{  file which contains an output queue file's data and label.
{
{        JMP$GET_OUTPUT_PATH_ELEMENTS (SYSTEM_FILE_NAME, PATH, STATUS);
{
{ SYSTEM_FILE_NAME: (input) This is the system-supplied file name for the
{        output queue file in question.
{
{ PATH: (output) This is an array which will contain the elements of the
{        permanent file path.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        jme$name_not_found
{        ofe$sou_not_active
*DECK DECK=JMH$GET_OUTPUT_STATUS EXPAND=FALSE
{
{    The purpose of this request is to obtain various data about the status of
{ output files based on specified criteria.
{
{       JMP$GET_OUTPUT_STATUS (OUTPUT_STATUS_OPTIONS_P,
{             OUTPUT_STATUS_RESULTS_KEYS_P, WORK_AREA_P,
{             OUTPUT_STATUS_RESULTS_P, NUMBER_OF_OUTPUTS_FOUND, STATUS);
{
{ OUTPUT_STATUS_OPTIONS_P: (input)  This is pointer to an array of variants
{       which determine which file(s) to status.
{
{ OUTPUT_STATUS_RESULTS_KEYS_P: (input)  This is a pointer to an array of keys
{       that selects the data to retrieve about the file(s).  Keys that can be
{       specified are the same as those that can be returned in the
{       OUTPUT_STATUS_RESULTS_P parameter.
{
{ WORK_AREA_P: (input, output)  This is a pointer to a sequence that is defined
{       by the caller.  The size required for a specific number of files can
{       be obtained by calling jmp$get_result_size.  See jmh$get_result_size
{       for further information.  Jmp$get_output_status will not RESET this
{       sequence before using it and will leave it positioned at the end of the
{       area used.
{
{ OUTPUT_STATUS_RESULTS_P: (output)  This is a pointer (into the work area) to
{       an array of variants that contains the data retrieved about the
{       file(s).
{
{ NUMBER_OF_OUTPUTS_FOUND: (output)  This indicates the number of files that
{       fit the criteria given by OUTPUT_STATUS_OPTIONS_P.  If the status
{       condition jme$work_area_too_small is returned this number indicates the
{       total number of output files that were found.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        cle$improper_name
{        jme$duplicate_attribute_key
{        jme$invalid_parameter
{        jme$no_outputs_were_found
{        jme$work_area_too_small
*DECK DECK=JMH$GET_PRINT_COUNTS EXPAND=FALSE
{
{    The purpose of this request is to retrieve the some count information
{  kept about prints.
{
{        JMP$GET_PRINT_COUNTS (PRINT_COUNTS, STATUS);
{
{ PRINT_COUNTS: (output) This is a record that contains various counts of
{        general interest.
{
{ STATUS: (output) This is a record that contains the status of the request.
{

*DECK DECK=JMH$GET_QFILE_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to retrieve the attributes of generic queue
{ files.
{
{       JMP$GET_QFILE_ATTRIBUTES (ATTRIBUTE_OPTIONS_P,
{             ATTRIBUTE_RESULTS_KEYS_P, ATTRIBUTE_WORK_AREA_P,
{             ATTRIBUTE_RESULTS_P, NUMBER_OF_QFILES_FOUND, STATUS);
{
{ ATTRIBUTE_OPTIONS_P: (input)  This is the criteria that select which queue
{       file(s) to retrieve the attributes for.
{
{ ATTRIBUTE_RESULTS_KEYS_P: (input)  This is an array of keys which determine
{       what information to return about the files.  Keys that can be specified
{       are the same as those that can be returned in the ATTRIBUTE_RESULTS_P
{       parameter.
{
{ ATTRUBUTE_WORK_AREA_P: (output)  This is the work area in which the attribute
{       results are returned.  The size required for a specified number of files
{       can be obtained by calling jmp$get_result_size.  See jmh$get_result_size
{       for further information.  Jmp$get_qfile_attributes will not RESET this
{       sequence before using it and will leave it positioned at the end of the
{       area used.
{
{ ATTRIBUTE_RESULTS_P: (output)  This contains the values of the requested
{       attributes.
{
{ NUMBER_OF_QFILES_FOUND: (output)  This is the number of queue files that met
{       the ATTRIBUTE_OPTIONS_P criteria.  If the status condition
{       jme$work_area_too_small is returned this value indicates the total
{       number of queue files that were found.
{
{ STATUS: This is the status of the request.
{       CONDITIONS:
{         cle$improper_name
{         jme$duplicate_attribute_key
{         jme$invalid_parameter
{         jme$no_qfiles_were_found
{         jme$work_area_too_small
{
*DECK DECK=JMH$GET_QFILE_ATTRIBUTES_SIZE EXPAND=FALSE
*DECK DECK=JMH$GET_QFILE_STATUS EXPAND=FALSE
{
{    The purpose of this request is to obtain various data about the status of
{ generic queue files based on specified criteria.
{
{       JMP$GET_QFILE_STATUS (STATUS_OPTIONS_P, STATUS_RESULTS_KEYS_P,
{             STATUS_WORK_AREA_P, STATUS_RESULTS_P, NUMBER_OF_QFILES_FOUND,
{             STATUS);
{
{ STATUS_OPTIONS_P: (input)  This is an array of variants which determine which
{       file(s) to status.
{
{ STATUS_RESULTS_KEYS_P: (input)  This is an array of keys which determine what
{       information to return about the files being statused.  Keys that can be
{       specified are the same as those that can be returned in the
{       STATUS_RESULTS_P parameter.
{
{ STATUS_WORK_AREA_P: (output)  This is the work area in which the status
{       results are returned.  The size required for a specified number of files
{       can be obtained by calling jmp$get_result_size.  See jmh$get_result_size
{       further information.  Jmp$get_qfile_status will not RESET this sequence
{       before using it and will leave it positioned at the end of the area used.
{
{ STATUS_RESULTS_P: (output)  This is an array of variants which contains the
{       data retrieved about the file(s).
{
{ NUMBER_OF_QFILES_FOUND: (output)  This indicates the number of files that fit
{       the criteria given by STATUS_OPTIONS_P.  If the status condition
{       jme$work_area_too_small is returned this number indicates the total
{       number of queue files that were found.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        cle$improper_name
{        jme$duplicate_attribute_key
{        jme$invalid_parameter
{        jme$no_qfiles_were_found
{        jme$work_area_too_small
*DECK DECK=JMH$GET_QFILE_STATUS_SIZE EXPAND=FALSE
*DECK DECK=JMH$GET_RECOVERY_RESTART_FILE EXPAND=FALSE
{    The purpose of this request is to determine the file name of the recovery
{ restart file used for queue file and leveled job recovery.
{
{       JMP$GET_RECOVERY_RESTART_FILE (SERVER_MAINFRAME_ID, RESTART_FILE_NAME);
{
{ SERVER_MAINFRAME_ID: (input)  This is the mainframe identifier of the server
{       on which the job resides.
{
{ RESTART_FILE_NAME: (output)  This is the name of the restart file.
*DECK DECK=JMH$GET_RESULT_SIZE EXPAND=FALSE
{    The purpose of this request is to determine the amount of space required
{ to contain the types JMT$JOB_STATUS_RESULTS, JMT$INPUT_ATTRIBUTE_RESULTS,
{ JMT$OUTPUT_ATTRIBUTE_RESULTS, JMT$OUTPUT_STATUS_RESULTS,
{ JMT$QFILE_STATUS_RESULTS, and JMT$QFILE_ATTRIBUTE_RESULTS for a specified
{ number of items and set of result keys.  This procedure can be used to
{ determine the size required for the work area to be passed to
{ JMP$GET_JOB_STATUS, JMP$GET_INPUT_ATTRIBUTES, JMP$GET_OUTPUT_ATTRIBUTES,
{ JMP$GET_OUTPUT_STATUS, JMP$GET_QFILE_STATUS, and JMP$GET_QFILE_ATTRIBUTES
{if the number of items are known.
{
{       JMP$GET_RESULT_SIZE (NUMBER_OF_ITEMS, RESULTS_KEYS_SEQ_P, SIZE)
{
{ NUMBER_OF_ITEMS: (input)  This parameter specifies the number of jobs or
{       output files.
{
{ RESULT_KEYS_SEQ_P: (input)  This parameter specifies a sequence that contains
{       a list of result keys.  To supply this parameter, it is easiest to use
{       the "#SEQ" CYBIL intrinsic.  To do this, suppose that you have a
{       variable result_keys:  array [1 ..  5] of jmt$result_keys.  To supply
{       this parameter, simply initialize the variable result_keys to the
{       desired values for each of the elements, and call this request as
{       jmp$get_result_size (item_count, #SEQ(result_keys), required_size).
{
{ SIZE: (output)  This parameter specifies the amount of space required to
{       contain results of the request.  The work area passed into the request
{       must be at least this large.
*DECK DECK=JMH$GET_SCHEDULER_TABLE EXPAND=FALSE
{
{   The purpose of this request is to return the job scheduler table used for
{ global control of job scheduling.  The caller must have scheduling
{ administration privilege.
{
{       JMP$GET_SCHEDULER_TABLE (SCHEDULER_TABLE, DATA_P, STATUS)
{
{ SCHEDULER_TABLE: (output)  This parameter specifies the result record for the
{       job scheduler table.
{
{ DATA_P: (output)  This parameter specifies a pointer to an adaptable
{       sequence.  Scheduler table data which has variable length is returned
{       in this sequence.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             jme$must_be_scheduling_admin
{             jme$no_element_in_sequence
{             jme$no_space_in_runtime_stack
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$GET_SCHEDULING_ADMIN_STATUS EXPAND=FALSE
{
{    The purpose of this request is to determine if the caller has scheduling
{ administration privilege.  This privilege is granted if the caller is the
{ system job, is a job processing within a system or job class prolog or
{ epilog, or has a user validation capability of scheduling administration.
{
{       JMP$GET_SCHEDULING_ADMIN_STATUS (STATUS)
{
{ STATUS: (output)  This parameter specifies the request status.  An error
{       condition is returned if the caller does not have scheduling
{       administration privilege.
{       CONDITIONS:
{             jme$must_be_scheduling_admin
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$GET_SCH_ATTR EXPAND=FALSE
{
{     This request will return the job scheduler table values.
{
{  JMP$GET_SCH_ATTR( DISP, STATUS)
{
{  DISP: (output) This is the display of the table.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$GET_SELE_TER_CANDIDATE EXPAND=FALSE
{
{     This procedure checks to see if there are any jobs queued that are
{  self terminating types. This type is an attribute of a job class.
{
{  GET_SELF_TERMINATING_CANDIDATE(NODE, CLASS, NONE_LEFT)
{
{  NODE: (output) This is the id of a self terminating job.
{
{  CLASS: (output) This is the job class of the self terminating job.
{
{  NONE_LEFT: (output) This is a boolean signalling end of search.
{
*DECK DECK=JMH$GET_SERVER_JOB_END_INFO EXPAND=FALSE
{
{    The purpose of this request is to retrieve the necessary information (from
{ the client mainframe) to complete job end cleanup on the server mainframe.
{
{       JMP$GET_SERVER_JOB_END_INFO (JOB_END_INFORMATION);
{
{ JOB_END_INFORMATION: (output)  This is the information from the client that
{       the server mainframe requires to cleanup at job end.
*DECK DECK=JMH$GET_SERVICE_CLASS_RECORD EXPAND=FALSE
{
{   The purpose of this request is to return the attributes for a given service
{ class from the service class table used for job scheduling.  The service
{ class must be defined in the service class table.  The caller must have
{ scheduling administration privilege.
{
{       JMP$GET_SERVICE_CLASS_RECORD ( SERVICE_CLASS_INDEX,
{         SERVICE_CLASS_RECORD, STATUS)
{
{ SERVICE_CLASS_INDEX: (input)  This parameter specifies the index of the
{       service class for the request.
{
{ SERVICE_CLASS_RECORD: (output)  This parameter specifies the result record
{       for the service class attributes.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             jme$class_index_not_defined
{             jme$must_be_scheduling_admin
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$GET_SERVICE_CLASS_STATS EXPAND=FALSE
{
{   The purpose of this request is to return the statistics for the given
{ service class.  The service class must be defined in the service class table.
{ The caller must have scheduling administration privilege.
{
{       JMP$GET_SERVICE_CLASS_STATS (SERVICE_CLASS_INDEX,
{         SERVICE_CLASS_STATISTICS, STATUS)
{
{ SERVICE_CLASS_INDEX: (input)  This parameter specifies the index of the
{       service class for the request.
{
{ SERVICE_CLASS_STATISTICS: (output)  This parameter specifies the result
{       record for the service class statistics.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             jme$class_index_not_defined
{             jme$must_be_scheduling_admin
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$GET_SWAPPED_JOBS_ATTR EXPAND=FALSE
{
{     This request will display all swapped jobs attributes.
{
{  JMP$GET_SWAPPED_JOBS_ATTR (DISP, STATUS)
{
{  DISP: (output) An array of attributes of each swapped job found.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$GET_TERMINATE_JOB_ACTION EXPAND=FALSE
{    The purpose of this request is to retrieve the action that a terminate job
{ request will take when a job is terminated for the second and subsequent
{ times.
{
{       JMP$GET_TERMINATE_JOB_ACTION (TERMINATE_JOB_ACTION_SET, STATUS);
{
{ TERMINATE_JOB_ACTION_SET: (input)  This is the set of terminate job actions
{       being requested.
{
{ STATUS: (output) This is the status of the request.
{     CONDITIONS:
{         ofe$sou_not_active
*DECK DECK=JMH$HANDLE_JOB_RESOURCE_SIGNAL EXPAND=FALSE

{     The purpose of this procedure is to field all Job Resource signals and
{  process or transfer control to the appropriate area to process Job Resource
{  conditions.
{
{     JMP$HANDLE_JOB_RESOURCE_SIGNAL ( ORIGINATOR, SIGNAL)
{
{  ORIGINATOR: (input) This parameter specifies the Global Task Identifier
{                      of the task of which the signal originated from.
{
{  SIGNAL: (input) This parameter specifies the signal recieved.
{

*DECK DECK=JMH$HANDLE_LOGOUT_FLAG EXPAND=FALSE
{
{     The purpose of this procedure is to process the notification of logout.
{
{     JMP$HANDLE_LOGOUT_FLAG ( FLAG_ID )
{
{  FLAG_ID: (input) This parameter specifies the system flag that was set.
{
{
*DECK DECK=JMH$HANDLE_QFM_IA_SIGNAL EXPAND=FALSE
{
{  The purpose of this procedure is to allow the scheduler
{  to recognize that an interactive job has been routed.
{
{     jmp$handle_qfm_ia_signal(originator: ost$global_task_id,
{                    signal: pmt$signal);
*DECK DECK=JMH$HANDLE_SIGNAL_SENSE_SWITCH EXPAND=FALSE

{
{    The purpose of this procedure is to change the job local
{  'sense switches' as requested from another job via the SWITCH command.
{
{    JMP$HANDLE_SIGNAL_SENSE_SWITCH( ORIGINATOR, SIGNAL)
{
{  ORIGINATOR: (input) This parameter specifies the sender of the signal.
{
{  SIGNAL: (input) This parameter specifies the recieved signal.
{
*DECK DECK=JMH$HANDLE_TS_IO_REQ_FAILURE EXPAND=FALSE
{
{    The purpose of this request is to handle deal with the situation of a task
{  realizing that it cannot do IO on the timesharing connection.
{
{        JMP$HANDLE_TS_IO_REQ_FAILURE (STATUS);
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{        ife$pause_break_received
{        ife$terminate_break_received
{        ife$connection_break_disconnect
{        ife$terminate_reconnected_to_job
{
*DECK DECK=JMH$INITIALAL_JOB_BEGIN EXPAND=FALSE

{   The purpose of this procedure is to provide an initial entry point at the
{  Nominal Ring for the Job Monitor. JMP$JOB_BEGIN and CLP$INTERPRET_COMMANDS
{  is called by this process.
{
{     JMP$INITIAL_JOB_BEGIN
{

*DECK DECK=JMH$INITIALIZE_AJL_IJL EXPAND=FALSE
{
{   The purpose of this request is to initialize the Active Job List (AJL),
{ Initiated Job List (IJL) and other structures during deadstart.  The
{ other structures include a Mini - Known Job List (just the system job) and
{ the system's job attribute defaults.
{
{        JMP$INITIALIZE_AJL_IJL;
{

*DECK DECK=JMH$INITIALIZE_JOB_ATTRIBUTES EXPAND=FALSE
{
{   The purpose of this request is to initialize the ring 2 job attribute
{ structure.  The job attributes of a job are contained in the job system
{ label that was created by when the job was submitted.  The system job
{ does not have a system job label.  For the system job a specific set
{ of values is assigned.
{
{        JMP$INITIALIZE_JOB_ATTRIBUTES (SYSTEM_LABEL_P, STATUS);
{
{ SYSTEM_LABEL_P: (input) This is the job system label that contains the job
{        attributes of the job.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{        none.
*DECK DECK=JMH$INITIALIZE_JOB_FILES EXPAND=FALSE
{
{   The purpose of this procedure is to initialize the standard job files
{  ( $COMMAND, $INPUT, and $OUTPUT ) based on the type of environment that the
{  job is executing within ( BATCH, INTERACTIVE, ect.).
{
{     JMP_INITIALIZE_JOB_FILES ( STATUS )
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=JMH$INITIALIZE_JOB_TABLES EXPAND=FALSE
{
{    The purpose of this procedure is to define/initialize Job Management
{  tables and variables within the Deadstart timeframe of events. Tables
{  such as the Known Job List, Known Output List, and Known Qfile List
{  are defined and initialized in this process.
{
{        JMP$INITIALIZE_JOB_TABLES (STATUS);
{
{ STATUS: (output)  This parameter specifies the request status.
{    CONDITIONS:
{        none.
{
*DECK DECK=JMH$INITIALIZE_SCHEDULER_TABLES EXPAND=FALSE
{
{   The purpose of this request is to initialize the job scheduler tables
{ during system deadstart before the job scheduler task is initiated.
{
{       JMP$INITIALIZE_SCHEDULER_TABLES (STATUS)
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             pme$invalid_mainframe_id
{       IDENTIFIER: 'PM'
{
*DECK DECK=JMH$INITIALIZE_SCHED_RING_2 EXPAND=FALSE
{
{     This procedure initializes ring 2 scheduler structures. There are
{  no parameters.
{
{  JMP$INITIALIZE_SCHED_RING_2
{
*DECK DECK=JMH$INITIALIZE_SSN EXPAND=FALSE
{
{    The purpose of this request is to initialize the last used system supplied
{  name during NOS/VE deadstart.  A value is retrieved from an area in the
{  Recovery Deadstart File (RDF) and is used to initialize the last value
{  assigned.  On an installation deadstart, the value is simply assigned.
{
{        JMP$INITIALIZE_SSN (DEADSTART_PHASE, STATUS);
{
{ DEADSTART_PHASE: (input) This indicates what kind of deadstart this is.
{
{ STATUS: (output) This is the status of the request.
{
*DECK DECK=JMH$INITIALIZE_SWAP_ENTRY EXPAND=FALSE
{
{     This procedure will initialize a swapout list entry with information
{  about a recently swapped job.
{
{  INITIALIZE_SWAP_ENTRY (SWAP_P, AJL_SLOT, SWAPPED_JOB_INFO)
{
{  SWAP_P: (input) The pointer to the swap list entry to initialize.
{
{  AJL_SLOT: (input) The active job list ordinal that is being swapped out.
{
{  SWAPPED_JOB_INFO: (input) The pertinent information necessary for future
{                            swapin.
{
*DECK DECK=JMH$INITIALIZE_TIMESHARING EXPAND=FALSE
{
{    The purpose of this request is to initialize the timesharing environment
{  within a job.
{
{        JMP$INITIALIZE_TIMESHARING (STATUS);
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{        none
{
*DECK DECK=JMH$INIT_CPU_DEPENDENT_NAMES EXPAND=FALSE
{
{    The purpose of this request is to initialize the system names dependent
{  on CPU0 of the machine being deadstarted.
{
{        JMP$INIT_CPU_DEPENDENT_NAMES (STATUS);
{
{ STATUS: (output) This is the status of request.
{        CONDITIONS: none
{
*DECK DECK=JMH$INIT_JOB_FROM_SCHEDULER EXPAND=FALSE
{
{     This procedure will create a new job in the system. It will direct
{  creation of the new jobs JOB FIXED segment and will call monitor
{  to make the new job known in monitors address space.
{
{  INITIATE_JOB_FROM_SCHEDULER (NODE, SELF_TERM_JOB, AJL_ORD, CLASS, STATUS)
{
{  NODE: (input) Identifies the job to be initiated.
{
{  SELF_TERM_JOB: (input) Tells whether the job will bring itself down upon
{                           initiation.
{
{  AJL_ORD: (input) tells the location in the active job list AJL for the new job.
{  CLASS: (output) Tells the class of the newly created job.
{
{  STATUS: (output) Tells the status of this request.
{
*DECK DECK=JMH$INSTALL_PROFILE EXPAND=FALSE
{
{   The purpose of this request is to install a scheduling profile in the
{ scheduler tables.  The tables are completely replaced with the given
{ definitions for job classes, service classes, applications, job scheduler
{ controls, and job categories.  The caller must have scheduling administration
{ privilege and must have set the utility active condition prior to this call.
{
{       JMP$INSTALL_PROFILE (ACCESS_ID, JOB_CLASS_ENTRIES_P,
{         SERVICE_CLASS_ENTRIES_P, APPLICATION_ENTRIES_P, CONTROLS_ENTRY,
{         CATEGORY_DATA, MOVE_JOB_CLASSES, DELETED_JOB_CLASSES,
{         DELETED_SERVICE_CLASSES, DELETED_APPLICATIONS, DELETE_PROFILE_CYCLE2,
{         STATUS)
{
{ ACCESS_ID: (input)  This parameter specifies the access id assigned to the
{       caller when the utility active condition was set.
{
{ JOB_CLASS_ENTRIES_P: (input)  This parameter specifies a pointer to an array
{       of job class entries which are to be installed in the job class table.
{       The order in which the job classes are given defines the rank, highest
{       to lowest, of the classes for automatic class selection.  The job class
{       indices cannot exceed the maximum value for which space was reserved
{       during deadstart.  The job classes must have a unique name,
{       abbreviation, and index.  Job classes currently defined in the job
{       class table must retain the same job class index.
{
{ SERVICE_CLASS_ENTRIES_P: (input)  This parameter specifies a pointer to an
{       array of service class entries which are to be installed in the service
{       class table.  The service class indices cannot exceed the maximum value
{       for which space was reserved during deadstart.  The service classes
{       must have a unique name, abbreviation, and index.  Service classes
{       currently defined in the service class table must retain the same
{       service class index.
{
{ APPLICATION_ENTRIES_P: (input)  This parameter specifies a pointer to an
{       array of application entries which are to be installed in the
{       application table.  If this pointer is NIL, there are no applications
{       to be installed.  The number of applications which can be installed is
{       limited by a system constant.  The applications are given in ascending
{       order by application name.  All applications must have a unique name.
{
{ CONTROLS_ENTRY: (input)  This parameter specifies a record which is to be
{       installed in the job scheduler table.
{
{ CATEGORY_DATA: (input)  This parameter specifies a record which is to be
{       installed in the job category data.
{
{ MOVE_JOB_CLASSES: (input)  This parameter specifies a set of job classes
{       whose queued input jobs are to be moved to the UNASSIGNED job class.  A
{       given job class must be defined in the job class table.  Job classes
{       which are to be deleted must be included in this set.
{
{ DELETED_JOB_CLASSES: (input)  This parameter specifies a set of job classes
{       that are to be deleted from the job class table.  A job class to be
{       deleted must be defined in the job class table and cannot have any
{       queued or executing jobs.  The predefined job classes, SYSTEM,
{       MAINTENANCE, and UNASSIGNED cannot be deleted.
{
{ DELETED_SERVICE_CLASSES: (input)  This parameter specifies a set of service
{       classes that are to be deleted from the service class table.  A service
{       class to be deleted must be defined in the service class table and
{       cannot have any executing jobs.  The predefined service classes,
{       SYSTEM, MAINTENANCE, and UNASSIGNED cannot be deleted.
{
{ DELETED_APPLICATIONS: (input)  This parameter specifies a set of applications
{       that are to be deleted from the application table.  An application to
{       be deleted must be defined in the application table.
{
{ DELETE_PROFILE_CYCLE2: (input)  This parameter specifies a TRUE value if
{       cycle 2 of the system scheduling profile permanent file is to be
{       deleted.  No status condition is returned if cycle 2 of this file does
{       not exist.
{
{ STATUS: (output)  This parameter specifies the request status.
{       All of the conditions listed are detected before the scheduler tables
{       are changed.
{       CONDITIONS:
{             jme$access_id_mismatch
{             jme$applications_not_sorted
{             jme$class_abbrev_not_unique
{             jme$class_index_already_in_use
{             jme$class_or_appl_not_defined
{             jme$class_or_appl_not_unique
{             jme$delete_class_still_active
{             jme$excess_class_in_sched_table
{             jme$must_be_scheduling_admin
{             jme$not_all_jobs_were_moved
{             jme$no_delete_of_default_class
{             jme$no_ranking_of_default_class
{             jme$no_utility_is_active
{             jme$profile_cycle2_lost
{             jme$profile_not_installed
{             jme$profile_too_large
{             pfe$bad_cycle_number
{             pfe$bad_cycle_option
{             pfe$bad_family_name
{             pfe$bad_master_catalog_name
{             pfe$bad_nth_subcatalog_name
{             pfe$bad_password
{             pfe$bad_permanent_file_name
{             pfe$incorrect_password
{             pfe$invalid_ring_access
{             pfe$name_not_permanent_file
{             pfe$nth_name_not_subcatalog
{             pfe$path_too_short
{             pfe$pf_system_error
{             pfe$unknown_family
{             pfe$unknown_master_catalog
{             pfe$unknown_nth_subcatalog
{             pfe$unknown_permanent_file
{             pfe$usage_not_permitted
{       IDENTIFIER: 'JM', 'PF'
{
*DECK DECK=JMH$INSTALL_PROFILE_IN_TABLES EXPAND=FALSE
{
{   The purpose of this request is to install a scheduling profile in the
{ scheduler tables.  The tables are completely replaced with the given
{ definitions for job classes, service classes, applications, job scheduler
{ controls, and job categories.
{
{       JMP$INSTALL_PROFILE_IN_TABLES (ACCESS_ID, JOB_CLASS_ENTRIES_P,
{         SERVICE_CLASS_ENTRIES_P, APPLICATION_ENTRIES_P, CONTROLS_ENTRY,
{         CATEGORY_DATA, DELETED_JOB_CLASSES, DELETED_SERVICE_CLASSES,
{         DELETED_APPLICATIONS, STATUS)
{
{ ACCESS_ID: (input)  This parameter specifies the access id assigned to the
{       caller when the utility active condition was set.
{
{ JOB_CLASS_ENTRIES_P: (input)  This parameter specifies a pointer to an array
{       of job class entries which are to be installed in the job class table.
{       The order in which the job classes are given defines the rank, highest
{       to lowest, of the classes for automatic class selection.
{
{ SERVICE_CLASS_ENTRIES_P: (input)  This parameter specifies a pointer to an
{       array of service class entries which are to be installed in the service
{       class table.
{
{ APPLICATION_ENTRIES_P: (input)  This parameter specifies a pointer to an
{       array of application entries which are to be installed in the
{       application table.  If this pointer is NIL, there are no applications
{       to be installed.
{
{ CONTROLS_ENTRY: (input)  This parameter specifies a record which is to be
{       installed in the job scheduler table.
{
{ CATEGORY_DATA: (input)  This parameter specifies a record which is to be
{       installed in the job category data.
{
{ DELETED_JOB_CLASSES: (input)  This parameter specifies a set of job classes
{       that are to be deleted from the job class table.
{
{ DELETED_SERVICE_CLASSES: (input)  This parameter specifies a set of service
{       classes that are to be deleted from the service class table.
{
{ DELETED_APPLICATIONS: (input)  This parameter specifies a set of applications
{       that are to be deleted from the application table.
{
{ STATUS: (output)  This parameter specifies the request status.
{       All of the conditions listed are detected before the scheduler tables
{       are changed.
{       CONDITIONS:
{             jme$access_id_mismatch
{             jme$no_utility_is_active
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$INSTALL_SYS_JOB_TEMPLATE EXPAND=FALSE
{
{     This procedure will install a system job template to a device
{  file via specified name.
{
{  JMP$INSTALL_SYS_JOB_TEMPLATE( NAME, STATUS)
{
{  NAME: (input) The name of the job template that is being installed. Used
{                on future activates.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$INVOKE_EPILOG_PROCESSING EXPAND=FALSE

{
{     The purpose of this procedure is to invoke the epilog processing
{  of the requesting job.
{
{     JMP$INVOKE_EPILOG_PROCESSING
{
*DECK DECK=JMH$JMH_GET_AJL_ORD EXPAND=FALSE
{
{     Given a KJL ordinal derive the associated AJL ordinal.
{
{  GET_AJL_ORD (KJL, AJL)
{
{  KJL: (input) The jobs KJL ordinal.
{
{  AJL: (output) The associated AJL ordinal
{
*DECK DECK=JMH$JOB_BEGIN EXPAND=FALSE

{   The purpose of this procedure is to call the various system areas to
{  initialize their environments needed by a new job. This procedure is
{  called once for a new job within the Job Monitor.
{
{     JMP$JOB_BEGIN
{
*DECK DECK=JMH$JOB_END EXPAND=FALSE

{   The purpose of this procedure is to collapse a jobs environment when a
{  job has completed via LOGOUT command or some other like event. Control is
{  given to this procedure by tasking when all Child Tasks of the job have
{  returned to the jobs Job Monitor. If an error occures while attempting to
{  collapse the jobs environment, the error is logged to the System Log and
{  the next logical process of collapsing the jobs environment is attempted.
{  When all of the processes have completed and the job contains the minimum
{  environment it can, a request is made to Monitor to collapse the remainder
{  and return any remaining job resources and working set residue. This
{  process executes within the jobs Job Monitor.
{
{     JMP$JOB_END
{
*DECK DECK=JMH$JOB_EXISTS EXPAND=FALSE
{
{    The purpose of this request is to determine if a job with the given name
{ exists anywhere on the local system.
{
{       JMP$JOB_EXISTS (NAME, JOB_STATE_SET, JOB_EXISTS, STATUS);
{
{ NAME: (input)  This string is the name of the job whose existence is in
{       question.
{
{ JOB_STATE_SET: (input)  This indicates what state the job should exist in.
{
{ JOB_EXISTS: (output)  A boolean value indicating the existence of the job.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             cle$improper_name
{             jme$duplicate_name
{
*DECK DECK=JMH$JOB_FILE_FAP EXPAND=FALSE
{
{   This function provides the requestor with a pointer to the File Access
{  Procedure (FAP) assigned (if any) to the specified job file. The recognized
{  job file names that can be specified are as follows:
{
{     COMMAND
{     INPUT
{     OUTPUT
{
{  If the specified job file is not recognized or if there is no FAP
{  assigned, a value of NIL is returned for the function.
{
{     JMP$JOB_FILE_FAP ( LOCAL_FILE_NAME )
{
{  LOCAL_FILE_NAME: (input) This parameter specifies the the requested job
{                           file name.
{
*DECK DECK=JMH$JOB_IS_BEING_LEVELED EXPAND=FALSE
{
{    The purpose of this request is to determine if the requesting job is a
{    batch job being leveled or not.
{
{       JMP$JOB_IS_BEING_LEVELED () :  BOOLEAN;
{
*DECK DECK=JMH$JOB_LEVELER_SERVER EXPAND=FALSE
{
{    The purpose of this request is to process the job leveler's request from a
{ client mainframe.  The parameters and calling sequence are determined by the
{ NOS/VE remote procedure call (RPC).
{
{       JMP$JOB_LEVELER_SERVER (RECEIVED_FROM_CLIENT_PARAMS_P,
{             RECEIVED_FROM_CLIENT_DATA_P, SEND_TO_CLIENT_PARAMS_P,
{             SEND_TO_CLIENT_DATA_P, PARAMETER_SIZE, DATA_SIZE, STATUS);
{
{ RECEIVED_FROM_CLIENT_PARAMS_P: (input)  This is a sequence containing the
{       parameters sent by the client mainframe.  This sequence should be
{       considered read only and is passed as an actual parameter only as a
{       convenience to the procedure.  NIL will be passed if no parameters were
{       passed.  This sequence is reset before the procedure is called.
{
{ RECEIVED_FROM_CLIENT_DATA_P: (input)  This is a sequence containing the data
{       sent by the client mainframe.  This sequence should be considered read
{       only and is passed as an actual parameter only as a convenience to the
{       procedure.  NIL will be passed if no data were passed.  This sequence
{       is reset before the procedure is called.
{
{ SEND_TO_CLIENT_PARAMS_P: (output)  This is a sequence that can be used to
{       send parameters back to the client mainframe.  This sequence is reset
{       before the procedure is called.
{
{ SEND_TO_CLIENT_DATA_P: (output)  This is a sequence that can be used to send
{       data back to the client mainframe.  This sequence is reset before the
{       procedure is called.
{
{ PARAMETER_SIZE: (output)  This is the amount of data in the parameter
{       sequence that should be passed to the client.  Zero should be used if
{       no parameters (other than status) are to be passed to the client.
{
{ DATA_SIZE: (output)  This is the amount of data in the data sequence that
{       should be passed to the client mainframe.  Zero should be used if no
{       data is to be passed to the client.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             none.
*DECK DECK=JMH$JOB_MONITOR_XCB EXPAND=FALSE
{
{   This function provides a pointer to the Execution Control Block (XCB)
{  belonging to the Job Monitor of the requesting job.
{
{
{     JMP$JOB_MONITOR_XCB ( )
{
*DECK DECK=JMH$JOB_SCHEDULER_ENTRY_POINT EXPAND=FALSE
{
{    The purpose of this procedure is to make the job scheduler entry point
{  available to a task execution request.
{  There are no parameters.
{
{  JMP$JOB_SCHEDULER_ENTRY_POINT
{
*DECK DECK=JMH$JOB_SCHEDULER_MONITOR EXPAND=FALSE
{
{     This procedure is the main job scheduler task entry point. There
{  are no parameters to this procedure call.
{
{  JMP$JOB_SCHEDULER_MONITOR
{
*DECK DECK=JMH$JOB_SCHED_ASYNC_ENTRY_PT EXPAND=FALSE
{
{     The purpose of this procedure is to make the job scheduler helper task
{  available to a task execution request. There are no parameters.
{
{  JMP$JOB_SCHED_ASYNC_ENTRY_PT
{
*DECK DECK=JMH$JOB_SELECTION_PRIORITY EXPAND=FALSE
{
{    The purpose of this function is to compute the selection priority of a job
{ in the input queue.
{
{       JMP$JOB_SELECTION_PRIORITY ( CURRENT_TIME, KJL_INDEX, JOB_CLASS);
{
{ CURRENT_TIME: (input)  This is the time in microseconds at which the priority
{       is to be computed.
{
{ KJL_INDEX: (input)  This is the kjl index of the job in the input queue whose
{       priority is to be computed.
{
{ JOB_CLASS: (input)  This is the job class of the job in the input queue.
{
*DECK DECK=JMH$JOB_SWAPPING_CONTROL_COMND EXPAND=FALSE
{
{     This request will allow the system operator to enable or disable
{     swapping.
{
{  JMP$JOB_SWAPPING_CONTROL_COMND (PARAMS, STATUS)
{
{  PARAMS: (input) The keywords ENABLE or DISABLE.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$JOB_SWAP_FUNCTION_PROCESSOR EXPAND=FALSE
{
{     This procedure is the basis for the job scheduler helper task. Its
{  function is to provide asynchronous swapout / swapin of jobs picked
{  by the main scheduler task.
{
{  JMP$JOB_SWAP_FUNCTION_PROCESSOR
{
*DECK DECK=JMH$LEVELER_WAIT EXPAND=FALSE
{
{    The purpose of this request is for the the job leveler task to wait for
{ its job leveling interval to expire or the first ready task of the job
{ leveler.
{
{       JMP$LEVELER_WAIT (JOB_LEVELING_INTERVAL);
{
{ JOB_LEVELING_INTERVAL: (input)  This is the job leveling interval to wait
{       for.
{
*DECK DECK=JMH$LIST_JOBS_VIA_MODE EXPAND=FALSE

{
{   The purpose of this request is to obtain a list of system supplied names
{  for each executing job in the system via specified JOB_MODE.
{
{     JMP$LIST_JOBS_VIA_MODE ( MODE, JOB_LIST, COUNT, STATUS)
{
{  MODE: (input) This parameter specifies the job_mode of jobs for which
{        system supplied names are to be returned.
{
{  JOB_LIST: (output) This parameter specifies the array into which the
{            list of system supplied names is to be placed.
{
{  COUNT: (output) This parameter specifies the number of system supplied
{         names returned in the array.
{
{  STATUS: (output) This parameter specifies the request status.
{

*DECK DECK=JMH$LOGOUT EXPAND=FALSE
{
{    The purpose of this procedure is to invoke the termination of the
{ requesting job.
{
{       JMP$LOGOUT ( STATUS )
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             jme$illegal_system_job_command
*DECK DECK=JMH$LOG_EDITED_LOGIN_COMMAND EXPAND=FALSE
{    The purpose of this request is to log a job's login command to the job and
{ system logs.  The entire login command (except password) is logged using the
{ actual login values used by the job, not the requested values.
{
{       JMP$LOG_EDITED_LOGIN_COMMAND (STATUS);
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{            none.
*DECK DECK=JMH$LOG_RESTORED_JOB EXPAND=FALSE
{
{    The purpose of this request is to issue a job history log statistic about
{  a batch job command file that has been restored from a backup and
{  reactivated.
{
{        JMP$LOG_RESTORED_JOB (SYSTEM_JOB_NAME, STATUS);
{
{ SYSTEM_JOB_NAME: (input) This is the system-supplied job name for the job
{        that has been restored.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        jme$cant_recover_job
{        jme$jh_job_history_not_active
{        jme$name_not_found
{        jme$sl_version_mismatch
{        ofe$sou_not_active
{        sye$job_damaged
*DECK DECK=JMH$LOG_RESTORED_OUTPUT EXPAND=TRUE
{
{    The purpose of this request is to issue a job history log statistic about
{  an output queue file that has been restored from a backup and reactivated.
{
{        JMP$LOG_RESTORED_OUTPUT (SYSTEM_FILE_NAME, STATUS);
{
{ SYSTEM_FILE_NAME: (input) This is the system-supplied file name for the
{        output queue file that has been restored.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        jme$jh_job_history_not_active
{        jme$name_not_found
{        jme$sl_version_mismatch
{        ofe$sou_not_active
*DECK DECK=JMH$LOG_STATUS_ERROR EXPAND=FALSE
{
{   The purpose of this request is to format the specified status and send
{  the formatted status to the specified log.
{
{     JMP$LOG_STATUS_ERROR ( STATUS_TO_DISPLAY, LOGSET, STATUS )
{
{  STATUS_TO_DISPLAY: (input) This parameter specifies the status record to
{                             be formatted and sent to the specified log.
{
{  LOGSET: (input) This parameter specifies the set of logs that the formatted
{                  status is to be sent to.
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=JMH$MAINFRAME_CHANGE_INPUT_ATTR EXPAND=FALSE
{    The purpose of this request is to change the input attributes of the
{ specified file.  This routine functions as a co-routine with the
{ jmp$change_input_attributes request.  This request is called by the
{ jmp$general_purpose_cluster_rpc request.
{
{       JMP$MAINFRAME_CHANGE_INPUT_ATTR (TARGET_OPTIONS_P,
{             DATA_AREA_P, NUMBER_OF_DATA_PACKETS, STATUS);
{
{ TARGET_OPTIONS_P: (input)  A pointer to a sequence that contains the caller
{       information and options about what file and attributes are to be
{       changed.
{
{ DATA_AREA_P: (input, output)  NO data is returned.
{
{ NUMBER_OF_DATA_PACKETS: (output)  This indicates the number of data packets
{       in the data_area_p sequence.  This value will be zero since no data
{       packets are returned by this request.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$job_class_does_not_exist
{             jme$scheduling_profile_changed
*DECK DECK=JMH$MAINFRAME_CHANGE_OUTPUT_ATT EXPAND=FALSE
{    The purpose of this request is to change the output attributes of the
{ specified file.  This routine functions as a co-routine with the
{ jmp$change_output_attributes request.  This request is called by the
{ jmp$general_purpose_cluster_rpc request.
{
{       JMP$MAINFRAME_CHANGE_OUTPUT_ATT (TARGET_OPTIONS_P,
{             DATA_AREA_P, NUMBER_OF_DATA_PACKETS, STATUS);
{
{ TARGET_OPTIONS_P: (input)  A pointer to a sequence that contains the caller
{       information and options about what file and attributes are to be
{       changed.
{
{ DATA_AREA_P: (input, output)  NO data is returned.
{
{ NUMBER_OF_DATA_PACKETS: (output)  This indicates the number of data packets
{       in the data_area_p sequence.  This value will be zero since no data
{       packets are returned by this request.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{           jme$invalid_parameter
{           jme$latest_print_time_expired
*DECK DECK=JMH$MAINFRAME_GET_INPUT_ATTRIBU EXPAND=FALSE
{    The purpose of this request is to get the output attributes of all files
{ that fit the options supplied in the target_options_p sequence on the
{ requesting mainframe.  This routine functions as a co-routine with the
{ jmp$get_input_attributes request.  This request is called by the
{ jmp$general_purpose_cluster_rpc request.
{
{       JMP$MAINFRAME_GET_INPUT_ATTRIB (TARGET_OPTIONS_P,
{             DATA_AREA_P, NUMBER_OF_DATA_PACKETS, STATUS);
{
{ TARGET_OPTIONS_P: (input)  A pointer to a sequence that contains the caller
{       information and options about what files are to be selected.
{
{ DATA_AREA_P: (input, output)  The area where the input attribute information is
{       written.
{
{ NUMBER_OF_DATA_PACKETS: (output)  This indicates the number of data packets
{       in the data_area_p sequence.  Each file is returned as a data packet.
{       Therefore, this represents the number of input files returned by this
{       request.
{
{ STATUS: (output) This is the status of the request.
{      CONDITION:
{            jme$work_area_too_small
*DECK DECK=JMH$MAINFRAME_GET_JOB_STATUS EXPAND=FALSE
{    The purpose of this request is to get the job status of all jobs that fit
{ the options supplied in the target_options_p sequence on the requesting
{ mainframe.  This routine functions as a co-routine with the
{ jmp$get_job_status request.  This request is called by the
{ jmp$general_purpose_cluster_rpc request.
{
{       JMP$MAINFRAME_GET_JOB_STATUS (TARGET_OPTIONS_P, DATA_AREA_P,
{             NUMBER_OF_DATA_PACKETS, STATUS);
{
{ TARGET_OPTIONS_P: (input)  A pointer to a sequence that contains the caller
{       information and options about what jobs are to be selected.
{
{ DATA_AREA_P: (input, output)  The area where the job status information is
{       written.
{
{ NUMBER_OF_DATA_PACKETS: (output)  This indicates the number of data packets
{       in the data_area_p sequence.  Each job is returned as a data packet.
{       Therefore, this represents the number of jobs returned by this request.
{
{ STATUS: (output) This is the status of the request.
{      CONDITION:
{            none
*DECK DECK=JMH$MAINFRAME_GET_LEVELING_DATA EXPAND=FALSE
{    The purpose of this procedure is to gather data on one mainframe.  The
{ data will be returned via remote procedure call to the caller of the
{ JMP$CLUSTER_GET_LEVELING_DATA request on another mainframe.  This procedure
{ is available as a site hook.
{
{       JMP$MAINFRAME_GET_LEVELING_DATA (SEND_DATA_P, WORK_AREA_P, STATUS);
{
{ SEND_DATA_P: (input)  This parameter is a pointer to a sequence containing
{       data that has been sent from the originating mainframe.  A value of NIL
{       for this parameter indicates that no data was sent.
{
{ WORK_AREA_P: (input, output)  This parameter specifies a pointer to a
{       sequence containing the data to be returned to the originating
{       mainframe.
{
{ STATUS: (output) This is the status of the request.
{    CONDITIONS:
{        None
*DECK DECK=JMH$MAINFRAME_GET_OUTPUT_ATTRIB EXPAND=FALSE
{    The purpose of this request is to get the output attributes of all files
{ that fit the options supplied in the target_options_p sequence on the
{ requesting mainframe.  This routine functions as a co-routine with the
{ jmp$get_output_attributes request.  This request is called by the
{ jmp$general_purpose_cluster_rpc request.
{
{       JMP$MAINFRAME_GET_OUTPUT_ATTRIB (TARGET_OPTIONS_P,
{             DATA_AREA_P, NUMBER_OF_DATA_PACKETS, STATUS);
{
{ TARGET_OPTIONS_P: (input)  A pointer to a sequence that contains the caller
{       information and options about what outputs are to be selected.
{
{ DATA_AREA_P: (input, output)  The area where the output attribute information is
{       written.
{
{ NUMBER_OF_DATA_PACKETS: (output)  This indicates the number of data packets
{       in the data_area_p sequence.  Each file is returned as a data packet.
{       Therefore, this represents the number of outputs returned by this
{       request.
{
{ STATUS: (output) This is the status of the request.
{      CONDITION:
{            jme$work_area_too_small
*DECK DECK=JMH$MAINFRAME_GET_OUTPUT_STATUS EXPAND=FALSE
{    The purpose of this request is to get the output status of all files that
{ fit the options supplied in the target_options_p sequence on the requesting
{ mainframe.  This routine functions as a co-routine with the
{ jmp$get_output_status request.  This request is called by the
{ jmp$general_purpose_cluster_rpc request.
{
{       JMP$MAINFRAME_GET_OUTPUT_STATUS (TARGET_OPTIONS_P,
{             DATA_AREA_P, NUMBER_OF_DATA_PACKETS, STATUS);
{
{ TARGET_OPTIONS_P: (input)  A pointer to a sequence that contains the caller
{       information and options about what outputs are to be selected.
{
{ DATA_AREA_P: (input, output)  The area where the output status information is
{       written.
{
{ NUMBER_OF_DATA_PACKETS: (output)  This indicates the number of data packets
{       in the data_area_p sequence.  Each file is returned as a data packet.
{       Therefore, this represents the number of outputs returned by this
{       request.
{
{ STATUS: (output) This is the status of the request.
{      CONDITION:
{            none
*DECK DECK=JMH$MAINFRAME_SET_SENSE_SWITCH EXPAND=FALSE
{    The purpose of this request is to set the sense switches of the specified
{ job.  This routine functions as a co-routine with the jmp$switch_command_r3.
{ This request is called by the jmp$general_purpose_cluster_rpc request.
{
{       JMP$MAINFRAME_SET_SENSE_SWITCH (TARGET_OPTIONS_P,
{             DATA_AREA_P, NUMBER_OF_DATA_PACKETS, STATUS);
{
{ TARGET_OPTIONS_P: (input)  A pointer to a sequence that contains the caller
{       information and options about what job's sense switches are to be
{       changed.
{
{ DATA_AREA_P: (input, output)  NO data is returned.
{
{ NUMBER_OF_DATA_PACKETS: (output)  This indicates the number of data packets
{       in the data_area_p sequence.  This value will be zero since no data
{       packets are returned for this request.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{           none.
*DECK DECK=JMH$MAINFRAME_TERMINATE_OUTPUT EXPAND=FALSE
{    The purpose of this request is to remove an output file from the output
{ queue.  This routine functions as a co-routine with the jmp$terminate_output
{ request.  This request is called by the jmp$general_purpose_cluster_rpc
{ request.
{
{       JMP$MAINFRAME_TERMINATE_OUTPUT (TARGET_OPTIONS_P,
{             DATA_AREA_P, NUMBER_OF_DATA_PACKETS, STATUS);
{
{ TARGET_OPTIONS_P: (input)  A pointer to a sequence that contains the caller
{       information and options about what file to terminate.
{
{ DATA_AREA_P: (input, output)  NO data is returned.
{
{ NUMBER_OF_DATA_PACKETS: (output)  This indicates the number of data packets
{       in the data_area_p sequence.  This value will be zero since no data
{       packets are returned are returned.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{           none.
{
*DECK DECK=JMH$MANAGE_AJL_KJL_LOCKS EXPAND=FALSE
{
{     This procedure will lock/unlock the AJL or KJL system tables.
{
{  JMP$MANAGE_AJL_KJL_LOCKS(LOCK_AND_FUNCTION)
{
{  LOCK_AND_FUNCTION: (input) Describes whick lock and whether to lock/unlock.
{
*DECK DECK=JMH$MANAGE_SENSE_SWITCHES EXPAND=FALSE
{
{     The purpose of this procedure is to set or clear the job local
{  'sense switches'.
{
{       JMP$MANAGE_SENSE_SWITCHES ( ON, OFF )
{
{  ON:  (input) This parameter specifies the 'sense switches' to be set.
{
{  OFF: (input) This parameter specifies the 'sense switches' to be cleared.
{
*DECK DECK=JMH$MANAGE_SWAP_LIST_LOCK EXPAND=FALSE
{
{     This procedure will lock or unlock the scheduler job swap list.
{
{  JMP$MANAGE_SWAP_LIST_LOCK (LOCK)
{
{  LOCK: (input) What function lock or unlock. This is a boolean. True=lock.
{
*DECK DECK=JMH$MODIFIED_INPUT_EXISTS EXPAND=FALSE
{
{    The purpose of this request is to determine if there are jobs for the
{ specified job_destination_usage that have been changed since being acquired.
{
{       JMP$MODIFIED_INPUT_EXISTS (JOB_DESTINATION_USAGE) :  BOOLEAN;
{
{ JOB_DESTINATION_USAGE: (input)  This is the job_destination_usage of the job.
{
*DECK DECK=JMH$MODIFIED_OUTPUT_EXISTS EXPAND=FALSE
{
{    The purpose of this request is to determine if there are files for the
{ specified output_destination_usage that have changed since being acquired.
{
{       JMP$MODIFIED_OUTPUT_EXISTS (OUTPUT_DESTINATION_USAGE) :  BOOLEAN;
{
{ OUTPUT_DESTINATION_USAGE: (input)  This is the output_destination_usage of
{       the file.
{
*DECK DECK=JMH$MODIFIED_QFILE_EXISTS EXPAND=FALSE
{
{    The purpose of this request is to determine if there are files for the
{ specified application_name that have changed since being acquired.
{
{       JMP$MODIFIED_QFILE_EXISTS (APPLICATION_NAME) :  BOOLEAN;
{
{ APPLICATION_NAME: (input)  This is the application_name of the file.
{
*DECK DECK=JMH$NEW_INPUT_EXISTS EXPAND=FALSE
{
{    The purpose of this request is to determine if there are jobs for the
{ specified job_destination_usage that have not been acquired.
{
{       JMP$NEW_INPUT_EXISTS (JOB_DESTINATION_USAGE) :  BOOLEAN;
{
{ JOB_DESTINATION_USAGE: (input)  This is the job_destination_usage of the job.
{
*DECK DECK=JMH$NEW_OUTPUT_EXISTS EXPAND=FALSE
{
{    The purpose of this request is to determine if there are files for the
{ specified output_destination_usage that have not been acquired.
{
{       JMP$NEW_OUTPUT_EXISTS (OUTPUT_DESTINATION_USAGE) :  BOOLEAN;
{
{ OUTPUT_DESTINATION_USAGE: (input)  This is the output_destination_usage of
{       the file.
{
*DECK DECK=JMH$NEW_QFILE_EXISTS EXPAND=FALSE
{
{    The purpose of this request is to determine if there are files for the
{ specified application_name that have not been acquired.
{
{       JMP$NEW_QFILE_EXISTS (APPLICATION_NAME) :  BOOLEAN;
{
{ APPLICATION_NAME: (input)  This is the application_name of the file.
{
*DECK DECK=JMH$NOTIFY_JOB_SCHEDULER_OF_JOB EXPAND=FALSE
{
{    The purpose of this request is to notify the job scheduler of a job in the
{ input queue that is a candidate for initiation.  It is also used to notify
{ the job scheduler that a job has terminated and the input queue should be
{ examined for a candidate.
{
{       JMP$NOTIFY_JOB_SCHEDULER_OF_JOB (JOB_CLASS, NEW_KJL_INDEX);
{
{ JOB_CLASS: (input)  This is the class of the candidate job.
{
{ NEW_KJL_INDEX: (input)  This is the kjl index of the candidate job that was
{       just placed in the input queue.  It is the null index if the input
{       queue is to be examined for a candidate.
{
*DECK DECK=JMH$NOTIFY_QUEUED_FILES_JOB_END EXPAND=FALSE
{
{    The purpose of this request is to notify the queued files that
{  a previously initiated job is terminated (normally or abnormally).
{
{        JMH$NOTIFY_QUEUED_FILES_JOB_END (KJL_INDEX);
{
{ KJL_INDEX: This is the Known Job List (KJL) index of the job that has
{        terminated.
{
*DECK DECK=JMH$OPEN_FILES_FOR_COPOF EXPAND=FALSE
{
{    The purpose of this request is to open the output queue file and target
{  file on behalf of the copy_output_file command processor.  The ring 3 queue
{  file must be copied at the caller's ring, but it must be attached and
{  opened at ring 3.
{
{        JMP$OPEN_FILES_FOR_COPOF (OUTPUT_FILE_NAME, TARGET_FILE, CONTROL_INFO,
{          OUTPUT_FID, OUTPUT_LFN, TARGET_FID, STATUS);
{
{ OUTPUT_FILE_NAME: (input) This is the user file name or system file name of
{        the output queue file to copy.
{
{ TARGET_FILE: (input) This is a file reference for the file where the
{        contents of the output queue file are copied.
{
{ CONTROL_INFO: (output) This is the record of data required by the
{        fsp$copy_data_and_close_files request.  That request must be done
{        at the user ring.
{
{ OUTPUT_FID: (output) This is the file_identifier record for the output
{        queue file.
{
{ OUTPUT_LFN: (output) This is the local file name of the output queue file
{        after it is attached.
{
{ TARGET_FID: (output) This is the file_identifier record for the copy target
{        file.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        jme$duplicate_name
{        jme$name_not_found
{        jme$not_validated_for_copof
*DECK DECK=JMH$OPEN_INPUT_FILE EXPAND=FALSE
{
{    The purpose of this request is to open an input file in a NOS/VE input
{ queue.  The job_destination_usage and queue_file_password are used to
{ validate the caller's privilege to access the file.
{
{       JMP$OPEN_INPUT_FILE (SYSTEM_JOB_NAME, ACCESS_LEVEL,
{             JOB_DESTINATION_USAGE, QUEUE_FILE_PASSWORD, FILE_IDENTIFIER,
{             STATUS);
{
{ SYSTEM_JOB_NAME: (input)  This is the system supplied name assigned to the
{       job when it is entered into the NOS/VE input queue.
{
{ ACCESS_LEVEL: (input)  This is the level of access required for the job.
{
{ JOB_DESTINATION_USAGE: (input)  This is the job destination usage of the job.
{
{ QUEUE_FILE_PASSWORD: (input)  This password validates the request to open the
{       file.
{
{ FILE_IDENTIFIER: (output)  This is the file identifier assigned to the file
{       that was opened.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$application_not_permitted
{             jme$destination_usage_incorrect
{             jme$name_not_found
*DECK DECK=JMH$OPEN_OUTPUT_FILE EXPAND=FALSE
{
{    The purpose of this request is to open an output file in the NOS/VE output
{ queue.  The output_destination_usage and queue_file_password are used to
{ validate the caller's privilege to access the file.
{
{       JMP$OPEN_OUTPUT_FILE (SYSTEM_FILE_NAME, ACCESS_LEVEL,
{             OUTPUT_DESTINATION_USAGE, QUEUE_FILE_PASSWORD, FILE_IDENTIFIER,
{             STATUS);
{
{ SYSTEM_FILE_NAME: (input)  This is the system supplied name assigned to the
{       file when it is entered into the NOS/VE output queue.
{
{ ACCESS_LEVEL: (input)  This is the level of access required for the output
{       file.
{
{ OUTPUT_DESTINATION_USAGE: (input)  This is the output destination usage of
{       the file.
{
{ QUEUE_FILE_PASSWORD: (input)  This password validates the request to open the
{       file.
{
{ FILE_IDENTIFIER: (output)  This is the file identifier assigned to the file
{       that was opened.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$application_not_permitted
{             jme$destination_usage_incorrect
{             jme$name_not_found
*DECK DECK=JMH$OPEN_QFILE EXPAND=FALSE
{
{    The purpose of this request is to open a file in the NOS/VE generic queue.
{ The application_name and qfile_password are used to validate the caller's
{ privilege to access the file.
{
{       JMP$OPEN_QFILE (SYSTEM_FILE_NAME, ACCESS_LEVEL, APPLICATION_NAME,
{             QFILE_PASSWORD, FILE_IDENTIFIER, STATUS);
{
{ SYSTEM_FILE_NAME: (input)  This is the system supplied name assigned to the
{       file when it is entered into the NOS/VE generic queue.
{
{ ACCESS_LEVEL: (input)  This is the level of access required for the queue
{       file.
{
{ APPLICATION_NAME: (input)  This is the application_name of the file.
{
{ QFILE_PASSWORD: (input)  This password validates the request to open the
{       file.
{
{ FILE_IDENTIFIER: (output)  This is the file identifier assigned to the file
{       that was opened.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$qfile_appl_not_permitted
{             jme$application_name_incorrect
{             jme$name_not_found
*DECK DECK=JMH$OPEN_SYSTEM_PROFILE EXPAND=FALSE
{
{   The purpose of this request is to open the system profile.  Since the file
{ is in the $system catalog, it is not normally readable or writable by the
{ user of manage_active_scheduling.  To provide access, the open must be done
{ at ring 3 with pf system authority enabled.
{
{       JMP$OPEN_SYSTEM_PROFILE (ACCESS_ID, CYCLE_NUMBER, OPEN_FOR_WRITE,
{            VALIDATION_ATTRIBUTES_P, FILE_IDENTIFIER, STATUS)
{
{ ACCESS_ID: (input)  This parameter specifies the access id assigned to the
{       caller when the utility active condition was set.
{
{ CYCLE_NUMBER: (input) This specifies the cycle number of the profile to open.
{
{ OPEN_FOR_WRITE: (input) This specifies if the profile is to be opened for
{       read or write.  When opened for write, a request is made to assign
{       the file to a critical device.  A side effect is that the file will
{       need to be explicitly detached after closing.
{
{ VALIDATION_ATTRIBUTES_P: (input) This specifies the attributes expected
{       if the file is valid.  If the file is created, these attributes are
{       assigned.
{
{ FILE_IDENTIFIER: (output) This returns the file identifier of the opened
{       file.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             ame$attribute_validation_error
{             ame$new_file_requires_append
{             jme$access_id_mismatch
{             jme$no_utility_is_active
{             pfe$duplicate_cycle
*DECK DECK=JMH$OPERATOR_JOB EXPAND=FALSE
{
{   This function indicates whether the requesting job is an operator job.
{
{     JMP$OPERATOR_JOB ( )
{
*DECK DECK=JMH$OPER_SWAPIN_OF_JOB EXPAND=FALSE
{
{     This request will allow the operator to swapin a selected job.
{
{  JMP$OPER_SWAPIN_OF_JOB( PARAMS, STATUS)
{
{  PARAMS: (input) The JSN job sequesnce number of the job to be swapped in.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$OPER_SWAPOUT_OF_JOB EXPAND=FALSE
{
{     This request will allow the system operator to swapout a selected job.
{
{  JMP$OPER_SWAPOUT_OF_JOB (PARAMS, STATUS)
{
{  PARAMS: (input) The JSN job sequence number of the job to be swapped.
{
{  STATUS: (output) The request status
{
*DECK DECK=JMH$PERFORM_PHYSICAL_SWAPOUT EXPAND=FALSE
{
{     This request will generate a swap job signal to the job scheduler
{  helper task.
{
{  PERFORM_PHYSICAL_SWAPOUT (NODE, SWAPOUT_REASON, CLASS, STATUS);
{
{  NODE: (input) The input job node.
{
{  SWAPOUT_REASON: (input) The reason for the swapout.
{
{  CLASS: (input) The service class index.
{
{  STATUS (output) This is the status of the request.
{
*DECK DECK=JMH$PRINT_COMPLETED EXPAND=FALSE
{
{    The purpose of this request is for restricted programs to inform Queued
{  File Management that as to the disposition status of a previously "acquired"
{  file.
{
{        JMP$PRINT_COMPLETED (PRINT_SYSTEM_ID, COMPLETED_SUCCESSFULLY, STATUS);
{
{ PRINT_SYSTEM_ID: (input) This is queued file's identifier for determining
{        which print file is being reported on.
{
{ COMPLETED_SUCCESSFULLY: (input) A boolean indicator as to whether or not the
{        file was disposed of successfully.
{
{ STATUS: (output) This  is a record containing the status of the request.
{
*DECK DECK=JMH$PRINT_FILE EXPAND=FALSE
{
{    The purpose of this request is to submit an output file as a candidate for
{ disposition on NOS/VE.
{
{       JMP$PRINT_FILE (FILE_REFERENCE, OUTPUT_SUBMISSION_OPTIONS,
{             SYSTEM_FILE_NAME, STATUS);
{
{ FILE_REFERENCE: (input)  This is the file to be printed.
{
{ OUTPUT_SUBMISSION_OPTIONS: (input)  This is an array of variants which can
{       provide several of the characteristics about the file (e.g.  the number
{       of copies to print).
{
{ SYSTEM_FILE_NAME: (output)  This is the system supplied name that has been
{       assigned to the file.
{
{ STATUS: (output) This is the record that contains the status of the request.
{       CONDITIONS:
{             ame$ring_validation_error
{             cle$improper_name
{             jme$invalid_parameter
{             jme$maximum_output
{             jme$no_space_for_file
{             jme$sl_version_mismatch
*DECK DECK=JMH$PRIORITY EXPAND=FALSE
{
{    This procedure will select initiation candidates strictly on a
{  priority basis across all classes.
{
{  JMP$PRIORITY(NODE, CLASS, NONE_LEFT)
{
{  NODE: (output) Specifies the job id.
{
{  CLASS: (output) gives the job class found.
{
{  NONE_LEFT: (output) A boolean telling if any more jobs available to examine.
{
*DECK DECK=JMH$PRIVILEGED_JOB EXPAND=FALSE
{
{   This function indicates whether the requesting job has special privilege.
{
{     JMP$PRIVILEGED_JOB ( )
{
*DECK DECK=JMH$PROCESS_JOB_REQUESTED_SWAP EXPAND=FALSE
{
{     This procedure allows a job to request itself to be swapped out.
{
{  JMP$PROCESS_JOB_REQUESTED_SWAP(WAIT_ESTIMATE, STATUS)
{
{  WAIT_ESTIMATE: (input) time duration of swapout.
{  STATUS: (output) disposition of the request.
{
*DECK DECK=JMH$PROCESS_TERMINAL_WAIT EXPAND=FALSE
{
{     This procedure will allow the job scheduler to record the fact
{  that a wait for terminal input situation has occured within this job.
{
{  JMP$PROCESS_TERMINAL_WAIT (WAIT_ESTIMATE)
{
{  WAIT_ESTIMATE: (input) The estimated amount of time in microseconds the
{                         job will be in a terminal wait.
{
*DECK DECK=JMH$PURGE_EXPIRED_FILE EXPAND=FALSE
{
{    The purpose of this request is to notify the appropriate processes that a
{ file has exceeded its expiration time in the output queue.  This request also
{ sets the time at which the next file will expire.
{
{    JMP$PURGE_EXPIRED_FILE;
*DECK DECK=JMH$PURGE_EXPIRED_QUEUE_FILE EXPAND=FALSE
{
{    The purpose of this request is to notify the appropriate processes that a
{ file has exceeded its purge_delay in the generic queue.  This request also
{ sets the time at which the next file will exceed its purge_delay.
{
{    JMP$PURGE_EXPIRED_QUEUE_FILE;
*DECK DECK=JMH$PURGE_JOB_TEMPLATE_FILE EXPAND=FALSE
{
{     This procedure will purge a system job template that has been
{   previously installed.
{
{  JMP$PURGE_JOB_TEMPLATE_FILE (NAME, STATUS)
{
{  NAME: (input) The name of the installed job template
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$PURGE_PRINTED_FILE EXPAND=FALSE
{
{    The purpose of this request is to notify the appropriate processes that an
{ output file that has been previously disposed has exceeded its purge delay in
{ the output queue.  This request also sets the time at which the next file
{ will exceed its purge delay.
{
{    JMP$PURGE_PRINTED_FILE;
*DECK DECK=JMH$PURGE_PROCESSED_QUEUE_FILE EXPAND=FALSE
{
{    The purpose of this request is to notify the appropriate processes that a
{ file that has been previously disposed has exceeded its purge_delay in the
{ generic queue.  This request also sets the time at which the next file will
{ exceed its purge_delay.
{
{    JMP$PURGE_PROCESSED_QUEUE_FILE;
*DECK DECK=JMH$QUICK_LOAD_OF_JOB_TEMPALATE EXPAND=FALSE
{
{     This procedure will perform a quick load of a job template. A quick
{  load is not saved across deadstarts.
{
{  JMP$QUICK_LOAD_OF_JOB_TEMPLATE( NAME, CODE_BASE_P, STATUS)
{
{  NAME: (input) The name of the template.
{
{  CODE_BASE_P: (output) The code base pointer of the starting procedure in
{                        the template.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$REACTIVATE_JOB_LEVELING EXPAND=FALSE
{
{    The purpose of this request is to reactivate the ability to load level
{ jobs from this mainframe.
{
{       JMP$REACTIVATE_JOB_LEVELING (ACCESS_ID, STATUS);
{
{ ACCESS_ID: (input)  This identifier is used to verify that the request is
{       coming from the scheduling administrator.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{            none.
*DECK DECK=JMH$READY_JOB_LEVELER_TASK EXPAND=FALSE
{
{    The purpose of this request is to ready the job leveler task if it exists.
{
{       JMP$READY_JOB_LEVELER_TASK (TASK_EXECUTING);
{
{ TASK_EXECUTING: (output)  This indicates if the job leveler task is executing
{       or not.
*DECK DECK=JMH$READ_APPLICATION_RECORD EXPAND=FALSE
{
{    The purpose of this request is to return the attributes for a given
{ application from the application table used for scheduling applications.  The
{ application must be defined in the application table.
{
{       JMP$READ_APPLICATION_RECORD (APPLICATION_NAME, APPLICATION_INDEX,
{             APPLICATION_RECORD, STATUS)
{
{ APPLICATION_NAME: (input)  This parameter specifies the name of the
{       application for the request.
{
{ APPLICATION_INDEX: (input, output)  This parameter specifies the index of the
{       application if known.  Provide zero (0) if not known.  On exit it will
{       contain the actual index.
{
{ APPLICATION_RECORD: (output)  This parameter specifies the result record for
{       the application attributes.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             jme$class_or_appl_not_defined
{
*DECK DECK=JMH$READ_CATEGORY_DATA EXPAND=FALSE
{
{   The purpose of this request is to return the category data used for
{ categorizing an input job.
{
{       JMP$READ_CATEGORY_DATA (CATEGORY_DATA, DATA_P, STATUS)
{
{ CATEGORY_DATA: (output)  This parameter specifies the result record for the
{       category data.
{
{ DATA_P: (output)  This parameter specifies a pointer to an adaptable
{       sequence.  Category data which has variable length is returned in this
{       sequence.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             jme$no_element_in_sequence
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$READ_DEFINED_APPLICATIONS EXPAND=FALSE
{
{   The purpose of this request is to return a list of applications defined in
{ the application table.
{
{       JMP$READ_DEFINED_APPLICATIONS (DEFINED_APPLICATIONS,
{         NUMBER_OF_APPLICATIONS, STATUS)
{
{ DEFINED_APPLICATIONS: (output)  This parameter specifies an adaptable array
{       in which the names and table position index of the defined applications
{       are returned.
{
{ NUMBER_OF_APPLICATIONS: (output)  This parameter specifies the number of
{       defined applications for which information is returned.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             none
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$READ_DEFINED_CLASSES EXPAND=FALSE
{
{   The purpose of this request is to return a list of the job classes, service
{ classes, or applications defined in the scheduler tables.
{
{       JMP$READ_DEFINED_CLASSES (CLASS_KIND, DEFINED_CLASSES,
{         NUMBER_OF_CLASSES, STATUS)
{
{ CLASS_KIND: (input)  This parameter specifies whether information is being
{       requested for job classes, service classes, or applications.
{
{ DEFINED_CLASSES: (output)  This parameter specifies an array in which the
{       names and indices of the defined classes or applications are returned.
{       Job classes are returned in ranked order of highest to lowest.
{
{ NUMBER_OF_CLASSES: (output)  This parameter specifies the number of defined
{       classes or applications for which information is returned.
{
{ STATUS: (output) This parameter specifies the request status.  When the
{       condition, jme$error_in_job_class_ranking, is returned, all of the
{       defined job classes are returned but the ranking is unknown.
{       CONDITIONS:
{             jme$error_in_job_class_ranking
{             jme$result_array_too_small
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$READ_JOB_CLASS_RECORD EXPAND=FALSE
{
{   The purpose of this request is to return the attributes for a given job
{ class from the job class table used for job scheduling.  The job class must
{ be defined in the job class table.
{
{       JMP$READ_JOB_CLASS_RECORD (JOB_CLASS_INDEX, JOB_CLASS_RECORD, DATA_P,
{         STATUS)
{
{ JOB_CLASS_INDEX: (input)  This parameter specifies the index of the job class
{       for the request.
{
{ JOB_CLASS_RECORD: (output)  This parameter specifies the result record for
{       the job class attributes.
{
{ DATA_P: (output)  This parameter specifies a pointer to an adaptable
{       sequence.  Job class attributes which have variable length are returned
{       in this sequence.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             jme$class_index_not_defined
{             jme$no_element_in_sequence
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$READ_SCHEDULER_TABLE EXPAND=FALSE
{
{   The purpose of this request is to return the job scheduler table used for
{ global control of job scheduling.
{
{       JMP$READ_SCHEDULER_TABLE (SCHEDULER_TABLE, DATA_P, STATUS)
{
{ SCHEDULER_TABLE: (output)  This parameter specifies the result record for the
{       job scheduler table.
{
{ DATA_P: (output)  This parameter specifies a pointer to an adaptable
{       sequence.  Scheduler table data which has variable length is returned
{       in this sequence.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             jme$no_element_in_sequence
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$REBUILD_EXECUTING_JOB EXPAND=FALSE
{
{   The purpose of this request is to rebuild the Known Job List entry of a
{ job that was executing and is being recovered (a.k.a., active job recovery).
{
{        JMP$REBUILD_EXECUTING_JOB (SYSTEM_JOB_NAME, JCB_P);
{
{ SYSTEM_JOB_NAME: (input) This is the system job name of the job being
{        recovered.
{
{ JCB_P: (input) This is a pointer to the job's job control block.
{
*DECK DECK=JMH$REBUILD_GENERIC_QUEUE EXPAND=FALSE
{
{    The purpose of this request is to reconstruct the Known Qfile List (KQL)
{  entry representing the specified queue file.
{
{        JMP$REBUILD_GENERIC_QUEUE (SYSTEM_FILE_NAME, STATUS);
{
{ SYSTEM_FILE_NAME: (input) This is the system file name of file being
{        recovered.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        cle$improper_name
*DECK DECK=JMH$REBUILD_INPUT_QUEUE EXPAND=FALSE
{
{    The purpose of this request is to reconstruct the Known Job LIST (KJL)
{ entry representing the specified job.
{
{       JMP$REBUILD_INPUT_QUEUE (SYSTEM_JOB_NAME, FAMILY_NAME, SUBCATALOG_NAME,
{             RECOVER_USING_ABORT_DISPOSITION, IGNORE_CLIENT_INITIATED_JOBS,
{             STATUS);
{
{ SYSTEM_JOB_NAME: (input)  This is the system job name of the input file being
{       recovered.
{
{ FAMILY_NAME: (input)  This is the NOS/VE family name in which the input file
{       resides.
{
{ SUBCATALOG_NAME: (input)  This is the subcatalog that contains the file.
{
{ RECOVER_USING_ABORT_DISPOSITION: (input)  This indicates if the job abort
{       disposition originally specified with the input file should be used to
{       determine the restartability of the job.
{
{ IGNORE_CLIENT_INITIATED_JOBS: (input)  This indicates that if the job is
{       initiated on a client, the job's initiation location should be ignored
{       and the job should be requeued as queued and not initiated.
{
{ JOB_DEFERRED_BY_OPERATOR: (input)  This indicates whether the job attribute
{       JOB_DEFERRED_BY_OPERATOR should be set to true when the input file is
{       recovered.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$cant_recovery_job
{             jme$job_recovery_or_abort_set
{             jme$sl_version_mismatch
*DECK DECK=JMH$REBUILD_OUTPUT_QUEUE EXPAND=FALSE
{
{    The purpose of this request is to reconstruct the Known Output List (KOL)
{  entry representing the specified output file.
{
{        JMP$REBUILD_OUTPUT_QUEUE (SYSTEM_FILE_NAME, SUBCATALOG_NAME, STATUS);
{
{ SYSTEM_FILE_NAME: (input) This is the system file name of file being
{        recovered.
{
{ SUBCATALOG_NAME: (input) This is the subcatalog that contains the file.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        cle$improper_name
{        jme$sl_version_mismatch
*DECK DECK=JMH$RECONCILE_LEVELED_JOBS EXPAND=FALSE
{    The purpose of this request is to reconcile the known jobs between the
{ client and the server mainframe during file server activation.  This
{ procedure is called by the client for every file server activation.
{
{       JMP$RECONCILE_LEVELED_JOBS (SERVER_MAINFRAME_ID, STATUS);
{
{ SERVER_MAINFRAME_ID: (input)  This is the binary mainframe identifier of the
{       server mainframe being activated.
{
{ STATUS: (output) This is the status of the request.
{
*DECK DECK=JMH$RECORD_JOB_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to restore the values contained in the job
{ local attribute structure in the Known Job List (KJL) at the time of active
{ job recovery.
{
{       JMP$RECORD_JOB_ATTRIBUTES (JOB_ATTRIBUTES_P,
{             JOB_RECOVERY_INFORMATION_P, STATUS);
{
{ JOB_ATTRIBUTES_P: (input)  This is a pointer to the job local attribute
{       structure.
{
{ JOB_RECOVERY_INFORMATION_P: (input)  This is a pointer to the job recovery
{       information for the job that was saved during job begin.
{
{ STATUS: (output)  This is the record that contains the status of the request.
{       CONDITIONS:
{           Abnormal status can only occur if the condition handler is invoked.
*DECK DECK=JMH$RECORD_TERMINAL_WAIT EXPAND=FALSE
  { The purpose of this procedure (JMXTEWT) is to
  { inform the job scheduler of a job with a terminal wait
  { condition. Parameters are:
  {
  {      JMP$RECORD_TERMINAL_WAIT( WAIT_ESTIMATE: INTEGER )
  {
  {   Where wait estimate is the approximate duration in
  {   seconds of the wait.
*DECK DECK=JMH$RECOVER_QUEUES EXPAND=FALSE
{
{    The purpose of this request is to recover the jobs, output files and
{  generic queue files from the NOS/VE input, output and generic queues.
{
{        JMP$RECOVER_QUEUES (SWAP_FILE_RECOVERY_LIST, STATUS);
{
{ SWAP_FILE_RECOVERY_LIST: (input, output) This is a list of swap files that
{        existed when the system was deadstarted along with the "disposition"
{        of those files.
{
{ STATUS: (output) This is the status of the request.
{
*DECK DECK=JMH$REFRESH_JOB_CANDIDATES EXPAND=FALSE
{
{    The purpose of this request is to refresh the information the job
{  scheduler uses for initiation of jobs from the input queue.
{
{        JMP$REFRESH_JOB_CANDIDATES;
{
*DECK DECK=JMH$REFRESH_JOB_CANDIDATE_CLASS EXPAND=FALSE
{
{    The purpose of this request is to refresh the information the job
{  scheduler uses for initiation of jobs from the input queue.  This
{  request refreshes the information for a particular class only.
{
{        JMP$REFRESH_JOB_CANDIDATE_CLASS (JOB_CLASS, INITIATION_SUCCEEDED);
{
{ JOB_CLASS: (input) This parameter indicates which class to refresh.
{
{ INITIATION_SUCCEEDED: (input) This parameter indicates whether or not the
{        last acquired job of this class was successfully initiated.
{
*DECK DECK=JMH$REGISTER_INPUT_APPLICATION EXPAND=FALSE
{
{    The purpose of this request is for an application to gain access to
{ certain jobs in the input queue.  Jobs are grouped by their
{ job_destination_usage.  An application has the exclusive right to all jobs of
{ a particular job_destination_usage once it has registered.
{
{       JMP$REGISTER_INPUT_APPLICATION (APPLICATION_NAME,
{             JOB_DESTINATION_USAGE, QUEUE_FILE_PASSWORD, STATUS);
{
{ APPLICATION_NAME: (input)  This is the name by which the application is
{       known.
{
{ JOB_DESTINATION_USAGE: (input)  This indicates which set of jobs the
{       application is requesting access to.
{
{ QUEUE_FILE_PASSWORD: (output)  This is a password that is returned by this
{       request.  It is necessary to specify this value on certain requests in
{       order to gain access to the queues.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             cle$improper_name
{             jme$application_table_is_full
{             jme$destination_usage_in_use
{
*DECK DECK=JMH$REGISTER_JOB_LEVELER EXPAND=FALSE
{
{    The purpose of this request is to register a client's job leveler task
{ with NOS/VE queue file management.
{
{    JMP$REGISTER_JOB_LEVELER;
*DECK DECK=JMH$REGISTER_OUTPUT_APPLICATION EXPAND=FALSE
{
{    The purpose of this request is for an application to gain access to
{ certain files in the output queue.  Files are grouped by their
{ output_destination_usage.  An application has the exclusive right to all
{ files of that output_destination_usage once it has registered.
{
{       JMP$REGISTER_OUTPUT_APPLICATION (APPLICATION_NAME,
{             OUTPUT_DESTINATION_USAGE, QUEUE_FILE_PASSWORD, STATUS);
{
{ APPLICATION_NAME: (input)  This is the name by which the application is
{       known.
{
{ OUTPUT_DESTINATION_USAGE: (input)  This indicates which set of output files
{       the application is requesting access to.
{
{ QUEUE_FILE_PASSWORD: (output)  This is a password that is returned by this
{       request.  It is necessary to specify this value on certain requests in
{       order to gain access to the queues.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             cle$improper_name
{             jme$application_table_is_full
{             jme$destination_usage_in_use
{
*DECK DECK=JMH$REGISTER_QFILE_APPLICATION EXPAND=FALSE
{
{    The purpose of this request is for an application to gain access to
{ certain files in the generic queue.  Files are grouped by their
{ application_name.  An application has the exclusive right to all files with
{ the matching application_name once it has registered.
{
{       JMP$REGISTER_QFILE_APPLICATION (APPLICATION_NAME,
{             REGISTRATION_OPTIONS_P, QUEUE_FILE_PASSWORD, STATUS);
{
{ APPLICATION_NAME: (input)  This is the name by which the application is
{       known.
{
{ REGISTRATION_OPTIONS_P: (input)  These options specify how the application
{       and the generic queue file manager work together.
{
{ QUEUE_FILE_PASSWORD: (output)  This is a password that is returned by this
{       request.  It is necessary to specify this value on certain requests in
{       order to gain access to the queues.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             cle$improper_name
{             jme$application_table_is_full
{
*DECK DECK=JMH$RELEASE_GENERIC_QUEUE_FILES EXPAND=FALSE
{
{    The purpose of this request is to release all generic queue files for a
{ particular application at task exit.
{
{    JMP$RELEASE_GENERIC_QUEUE_FILES;
{
*DECK DECK=JMH$RELEASE_INPUT_FILES EXPAND=FALSE
{
{   The purpose of this request is to release all input files for a particular
{ input application at task exit.
{
{        JMH$RELEASE_INPUT_FILES;
*DECK DECK=JMH$RELEASE_OUTPUT_FILES EXPAND=FALSE
{
{    The purpose of this request is to release all output files for a particular
{  output application at task exit.
{
{        JMP$RELEASE_OUTPUT_FILES (STATUS);
{
{ STATUS: (output) This is the status of the request.
{      IDENTIFIER:
{        'JM'
{      CONDITIONS:
{        none.
*DECK DECK=JMH$REMOTE_JOB_TEMPLATE_CMND EXPAND=FALSE
{
{     This request will remove a system job template from the system.
{
{  JMP$REMOVE_JOB_TEMPLATE_CMND (PARAMS, STATUS)
{
{  PARAMS: (input) The command language parameter list.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$RESTORE_JOB_ENVIRONMENT EXPAND=FALSE
{
{     This procedure is the first phase of swapin processing. It is
{  responsible for signalling the scheduler helper task that a swapin
{  function is needed.
{
{  RESTORE_JOB_ENVIRONMENT (NODE, AJL_ORD, WORKING_SET_SIZE, STATUS)
{
{  NODE: (input) Identifies the job to acted upon
{
{  AJL_ORD: (input) Is the AJL slot the job will be swapped into.
{
{  WORKING_SET_SIZE: (output) Is the number of pages the job will require
{                             when it is swapped in.
{
{  STATUS: (output) This is the status of the request.
{
*DECK DECK=JMH$RESUBMIT_QUEUED_INPUT_JOB EXPAND=FALSE
{
{   The purpose of this request is to resubmit a queued input job using its
{ original input attributes.  The caller must have scheduling administration
{ privilege.
{
{       JMP$RESUBMIT_QUEUED_INPUT_JOB (SYSTEM_SUPPLIED_NAME, STATUS)
{
{ SYSTEM_SUPPLIED_NAME: (input)  This parameter specifies the name of the job
{       in the input queue which is to be resubmitted.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             cle$improper_name
{             jme$cannot_assign_to_job_class
{             jme$duplicate_name
{             jme$input_is_initiated
{             jme$interactive_job_discarded
{             jme$invalid_parameter
{             jme$invalid_parameter_value
{             jme$job_class_does_not_exist
{             jme$no_job_class_found_for_job
{       IDENTIFIER: 'CL', 'JM'
{
*DECK DECK=JMH$RETURN_CONNECTION EXPAND=FALSE
{
{    The purpose of this request is to return a network connection that had
{ been acquired by jmp$acquire_connection.
{
{       JMP$RETURN_CONNECTION (STATUS);
{
{ STATUS: (output) This parameter returns the completion status of
{         the request.
*DECK DECK=JMH$SAVE_JOB_TEMPLATES EXPAND=FALSE
{
{     The purpose of this request is to save the job fixed base template
{  and set a flag denoting execution in the system job.
{
{  JMP$SAVE_JOB_TEMPLATES( STATUS)
{
{  STATUS: (output) The outcome of the request status.
{
*DECK DECK=JMH$SAVE_RECOVERY_INFORMATION EXPAND=FALSE
{    The purpose of this request is to save information needed by job
{ management that is used only to complete job recovery.
{
{       JMP$SAVE_RECOVERY_INFORMATION (JOB_SYSTEM_LABEL_P);
{
{ JOB_SYSTEM_LABEL_P: (input)  This is a pointer to the job system label to be
{       saved.
*DECK DECK=JMH$SAVE_SFID_OF_SWAP_FILE EXPAND=FALSE
{
{     This request saves the SFID (system file id) of the jobs swap out
{  file in the AJL entry for the job.
{
{  JMP$SAVE_SFID_OF_SWAP_FILE (SFID, STATUS)
{
{  SFID: (input) The system file id of the job swap file.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$SAVE_SYSTEM_CORE_TEMPLATE EXPAND=FALSE
{
{     This procedure saves the JOB FIXED segment static data portion
{  in mainframe pageable segment for use in initiating future jobs.
{
{  JMP$SAVE_SYSTEM_CORE_TEMPLATE( STATUS)
{
{  STATUS: (output) Gives disposition of request.
{
*DECK DECK=JMH$SCAN_AJL_FOR_SWAP_CONDTION EXPAND=FALSE
{
{     This procedure scans the AJL (active job list) looking for jobs
{  in various states of being 1) swapped out or 2) terminated. Appropriate
{  action is then taken.
{
{  SCAN_AJL_FOR_SWAP_CONDITIONS
{
*DECK DECK=JMH$SCHEDULER_TABLE_INITIALIZE EXPAND=FALSE
{
{     This procedure initializes the job scheduler system wide table and
{  each individual job class table.
{
{  JMP$SCHEDULER_TABLE_INITIALIZE
{
*DECK DECK=JMH$SCHED_SWAPIN_JOB EXPAND=FALSE
{
{     The purpose of this request is to affect actual swapin of a job
{  via operator command.
{
{  JMP$SCHED_SWAPIN_JOB (IJL_ORDINAL, SYSTEM_SUPPLIED_NAME, STATUS)
{
{  IJL_ORDINAL: (input) The ijl ordinal of the job.
{
{  SYSTEM_SUPPLIED_NAME: (input) The system_supplied name of the job.
{
{  STATUS: (output) The disposition of the request.
{
*DECK DECK=JMH$SCHED_SWAPOUT_JOB EXPAND=FALSE
{
{     The purpose of this request is to affect swapout of a job via
{  operator action.
{
{  JMP$SCHED_SWAPOUT_JOB (IJL_ORDINAL, SYSTEM_SUPPLIED_NAME, STATUS)
{
{  IJL_ORDINAL: (input) The ijl ordinal of the job.
{
{  JOB_NAME: (input) The system supplied name of the job to be swapped.
{
{  STATUS: The request status.
{
*DECK DECK=JMH$SCH_CHANGE_CAT EXPAND=FALSE
{
{     This request will change all or some job class attributes.
{
{  JMP$SCH_CHANGE_CAT (CCL, AS, CHANGED_CAT, STATUS)
{
{  CCL: (input) The job class set depicting which class(es) to change.
{
{  AS: (input) Which class attributes to change.
{
{  CHANGED_CAT: (input) The template of the changed class attribute record.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$SCH_CHANGE_JST EXPAND=FALSE
{
{     The purpose of this procedure is to invoke change on the
{  Job Scheduler Table. This proc will change all or part of the table.
{
{  JMP$SCH_CHANGE_JST (SCH_SET, CHANGED_SCH, STATUS)
{
{  SCH_SET: (input) This parameter specifies which fields to change.
{
{  CHANGED_SCH: (input) This parameter is the template holding changed values.
{
{  STATUS: (output) This is the request status.
{
*DECK DECK=JMH$SCH_CHANGE_SWAP_JOB EXPAND=FALSE
{
{     This request will increase the priority of a swapped out job up to
{  the jobs maximum allowed value.
{
{  JMP$SCH_CHANGE_SWAP_JOB( JOB_NAME, PRIORITY_VALUE, STATUS)
{
{  JOB_NAME: (input) The system_supplied name of the job.
{
{  PRIORITY_VALUE: (input) The new priority value for the job.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$SELECT_INTERACTIVE_JOB_DEST EXPAND=FALSE
{
{ The purpose of this request is to determine which mainframe an
{ interactive job should be submitted to.  This procedure is available
{ as a site hook.
{
{       JMP$SELECT_INTERACTIVE_JOB_DEST (VALID_MAINFRAME_LIST,
{             INTERACTIVE_JOB_INFO, SELECTED_MAINFRAME, STATUS);
{
{ VALID_MAINFRAME_LIST: (input) This parameter provides an array of
{     mainframe identifiers whose validation categories in the
{     scheduling profile fit the job.
{
{ INTERACTIVE_JOB_INFO: (input) This parameter contains information
{     about the job such as job attributes, limit information, login
{     identification, etc.
{
{ SELECTED_MAINFRAME: (output) This parameter specifies the chosen
{     mainframe identifier.  The leveled job will be sent to this
{     mainframe for execution.
{
{ STATUS: (output) This is the status of the request.  Abnormal status
{     will abort the users login.
{    CONDITIONS:
{         none
*DECK DECK=JMH$SELECT_RESET_DISP_PR EXPAND=FALSE

{ PURPOSE:
{   This procedure is executed during the process of a job receiving input from the
{   terminal. It is to set the global taskid of the interactive task in the IJL indicating
{   that the next time this task runs, the dispatching priority should be reset.
{
{  JMP$SELECT_RESET_DISP_PR;
*DECK DECK=JMH$SELECT_RESET_DISP_PR_R2 EXPAND=FALSE

{ PURPOSE:
{   This procedure calls a ring one procedure which stores the global task id of the
{   interactive task in the IJL field-INTERACTIVE_TASK_GTID. A non-null gtid in this field
{   indicates that the task has not been readied since the last command. This situation
{   would occur if the user was using type-ahead. In this case, the priority of the job
{   is reset, and the INTERACTIVE_TASK_GTID field is cleared.
{
{   JMP$SELECT_RESET_DISP_PR_R2;
*DECK DECK=JMH$SELECT_RESET_DISP_PR_R3 EXPAND=FALSE

{ PURPOSE:
{   The purpose of this procedure is to cause the priority of this job to be reset.
{ The taskid of the main or interactive task is stored in the IJL of the job. When this task
{ is next readied, the priority of the job is reset. Priorities of interactive jobs are
{ reset only if DYNAMIC DISPATCHING is active.
{
{ JMP$SELECT_RESET_DISP_PR_R3;
*DECK DECK=JMH$SEND_JOB_MESSAGE EXPAND=FALSE
{    The purpose of this request is to send a message to the specified
{ mainframe.
{
{       JMP$SEND_JOB_MESSAGE (TARGET_MAINFRAME_ID, JOB_MESSAGE, STATUS);
{
{ TARGET_MAINFRAME_ID: (input)  This is the mainframe to which the message is
{       to be delivered.  If the identifier pmc$null_mainframe_id is specified,
{       the message will be delivered to all mainframes in the cluster.
{
{ JOB_MESSAGE: (input)  This is the message to be sent.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{            jme$job_message_error
*DECK DECK=JMH$SERVER_GENERAL_PURPOSE_RPC EXPAND=FALSE
{
{    The purpose of this request is to process the general purpose remote
{ procedure call from a client mainframe.  The parameters and calling sequence
{ are determined by the NOS/VE remote procedure call (RPC).
{
{       JMP$SERVER_GENERAL_PURPOSE_RPC (RECEIVED_FROM_CLIENT_PARAMS_P,
{             RECEIVED_FROM_CLIENT_DATA_P, SEND_TO_CLIENT_PARAMS_P,
{             SEND_TO_CLIENT_DATA_P, PARAMETER_SIZE, DATA_SIZE, STATUS);
{
{ RECEIVED_FROM_CLIENT_PARAMS_P: (input)  This is a sequence containing the
{       parameters sent by the client mainframe.  This sequence should be
{       considered read only and is passed as an actual parameter only as a
{       convenience to the procedure.  NIL will be passed if no parameters were
{       passed.  This sequence is reset before the procedure is called.
{
{ RECEIVED_FROM_CLIENT_DATA_P: (input)  This is a sequence containing the data
{       sent by the client mainframe.  This sequence should be considered read
{       only and is passed as an actual parameter only as a convenience to the
{       procedure.  NIL will be passed if no data is passed.  This sequence
{       is reset before the procedure is called.
{
{ SEND_TO_CLIENT_PARAMS_P: (output)  This is a sequence that can be used to
{       send parameters back to the client mainframe.  This sequence is reset
{       before the procedure is called.
{
{ SEND_TO_CLIENT_DATA_P: (output)  This is a sequence that can be used to send
{       data back to the client mainframe.  This sequence is reset before the
{       procedure is called.
{
{ PARAMETER_SIZE: (output)  This is the amount of data in the parameter
{       sequence that should be passed to the client.  Zero should be used if
{       no parameters (other than status) are to be passed to the client.
{
{ DATA_SIZE: (output)  This is the amount of data in the data sequence that
{       should be passed to the client mainframe.  Zero should be used if no
{       data is to be passed to the client.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             none.
*DECK DECK=JMH$SERVER_GET_JOB_STATUS EXPAND=FALSE
*DECK DECK=JMH$SERVER_JOB_BEGIN EXPAND=FALSE
{
{    The purpose of this request is to process the job begin request for a job
{ that has a Known Job List (KJL) entry on the server mainframe.  The
{ parameters and calling sequence are determined by the NOS/VE remote procedure
{ call (RPC).
{
{       JMP$SERVER_JOB_BEGIN (RECEIVED_FROM_CLIENT_PARAMS_P,
{             RECEIVED_FROM_CLIENT_DATA_P, SEND_TO_CLIENT_PARAMS_P,
{             SEND_TO_CLIENT_DATA_P, PARAMETER_SIZE, DATA_SIZE, STATUS);
{
{ RECEIVED_FROM_CLIENT_PARAMS_P: (input)  This is a sequence containing the
{       parameters sent by the client mainframe.  This sequence should be
{       considered read only and is passed as an actual parameter only as a
{       convenience to the procedure.  NIL will be passed if no parameters were
{       passed.  This sequence is reset before the procedure is called.
{
{ RECEIVED_FROM_CLIENT_DATA_P: (input)  This is a sequence containing the data
{       sent by the client mainframe.  This sequence should be considered read
{       only and is passed as an actual parameter only as a convenience to the
{       procedure.  NIL will be passed if no data were passed.  This sequence
{       is reset before the procedure is called.
{
{ SEND_TO_CLIENT_PARAMS_P: (output)  This is a sequence that can be used to
{       send parameters back to the client mainframe.  This sequence is reset
{       before the procedure is called.
{
{ SEND_TO_CLIENT_DATA_P: (output)  This is a sequence that can be used to send
{       data back to the client mainframe.  This sequence is reset before the
{       procedure is called.
{
{ PARAMETER_SIZE: (output)  This is the amount of data in the parameter
{       sequence that should be passed to the client.  Zero should be used if
{       no parameters (other than status) are to be passed to the client.
{
{ DATA_SIZE: (output)  This is the amount of data in the data sequence that
{       should be passed to the client mainframe.  Zero should be used if no
{       data is to be passed to the client.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             none.
*DECK DECK=JMH$SERVER_SEND_JOB_MESSAGE EXPAND=FALSE
{
{    The purpose of this request is to process the send job message request
{ from a client mainframe.  The parameters and calling sequence are determined
{ by the NOS/VE remote procedure call (RPC).
{
{       JMP$SERVER_SEND_JOB_MESSAGE (RECEIVED_FROM_CLIENT_PARAMS_P,
{             RECEIVED_FROM_CLIENT_DATA_P, SEND_TO_CLIENT_PARAMS_P,
{             SEND_TO_CLIENT_DATA_P, PARAMETER_SIZE, DATA_SIZE, STATUS);
{
{ RECEIVED_FROM_CLIENT_PARAMS_P: (input)  This is a sequence containing the
{       parameters sent by the client mainframe.  This sequence should be
{       considered read only and is passed as an actual parameter only as a
{       convenience to the procedure.  NIL will be passed if no parameters were
{       passed.  This sequence is reset before the procedure is called.
{
{ RECEIVED_FROM_CLIENT_DATA_P: (input)  This is a sequence containing the data
{       sent by the client mainframe.  This sequence should be considered read
{       only and is passed as an actual parameter only as a convenience to the
{       procedure.  NIL will be passed if no data were passed.  This sequence
{       is reset before the procedure is called.
{
{ SEND_TO_CLIENT_PARAMS_P: (output)  This is a sequence that can be used to
{       send parameters back to the client mainframe.  This sequence is reset
{       before the procedure is called.
{
{ SEND_TO_CLIENT_DATA_P: (output)  This is a sequence that can be used to send
{       data back to the client mainframe.  This sequence is reset before the
{       procedure is called.
{
{ PARAMETER_SIZE: (output)  This is the amount of data in the parameter
{       sequence that should be passed to the client.  Zero should be used if
{       no parameters (other than status) are to be passed to the client.
{
{ DATA_SIZE: (output)  This is the amount of data in the data sequence that
{       should be passed to the client mainframe.  Zero should be used if no
{       data is to be passed to the client.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             none.
*DECK DECK=JMH$SERVER_SUBMIT_JOB EXPAND=FALSE
{
{    The purpose of this request is to process the submit job request from a
{ client mainframe.  The parameters and calling sequence are determined by the
{ NOS/VE remote procedure call (RPC).
{
{       JMP$SERVER_SUBMIT_JOB (RECEIVED_FROM_CLIENT_PARAMS_P,
{             RECEIVED_FROM_CLIENT_DATA_P, SEND_TO_CLIENT_PARAMS_P,
{             SEND_TO_CLIENT_DATA_P, PARAMETER_SIZE, DATA_SIZE, STATUS);
{
{ RECEIVED_FROM_CLIENT_PARAMS_P: (input)  This is a sequence containing the
{       parameters sent by the client mainframe.  This sequence should be
{       considered read only and is passed as an actual parameter only as a
{       convenience to the procedure.  NIL will be passed if no parameters were
{       passed.  This sequence is reset before the procedure is called.
{
{ RECEIVED_FROM_CLIENT_DATA_P: (input)  This is a sequence containing the data
{       sent by the client mainframe.  This sequence should be considered read
{       only and is passed as an actual parameter only as a convenience to the
{       procedure.  NIL will be passed if no data were passed.  This sequence
{       is reset before the procedure is called.
{
{ SEND_TO_CLIENT_PARAMS_P: (output)  This is a sequence that can be used to
{       send parameters back to the client mainframe.  This sequence is reset
{       before the procedure is called.
{
{ SEND_TO_CLIENT_DATA_P: (output)  This is a sequence that can be used to send
{       data back to the client mainframe.  This sequence is reset before the
{       procedure is called.
{
{ PARAMETER_SIZE: (output)  This is the amount of data in the parameter
{       sequence that should be passed to the client.  Zero should be used if
{       no parameters (other than status) are to be passed to the client.
{
{ DATA_SIZE: (output)  This is the amount of data in the data sequence that
{       should be passed to the client mainframe.  Zero should be used if no
{       data is to be passed to the client.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             none.
*DECK DECK=JMH$SERVER_TERMINATE_JOB EXPAND=FALSE
{
{    The purpose of this request is to process the terminate job request from a
{ client mainframe.  The parameters and calling sequence are determined by the
{ NOS/VE remote procedure call (RPC).
{
{       JMP$SERVER_TERMINATE_JOB (RECEIVED_FROM_CLIENT_PARAMS_P,
{             RECEIVED_FROM_CLIENT_DATA_P, SEND_TO_CLIENT_PARAMS_P,
{             SEND_TO_CLIENT_DATA_P, PARAMETER_SIZE, DATA_SIZE, STATUS);
{
{ RECEIVED_FROM_CLIENT_PARAMS_P: (input)  This is a sequence containing the
{       parameters sent by the client mainframe.  This sequence should be
{       considered read only and is passed as an actual parameter only as a
{       convenience to the procedure.  NIL will be passed if no parameters were
{       passed.  This sequence is reset before the procedure is called.
{
{ RECEIVED_FROM_CLIENT_DATA_P: (input)  This is a sequence containing the data
{       sent by the client mainframe.  This sequence should be considered read
{       only and is passed as an actual parameter only as a convenience to the
{       procedure.  NIL will be passed if no data were passed.  This sequence
{       is reset before the procedure is called.
{
{ SEND_TO_CLIENT_PARAMS_P: (output)  This is a sequence that can be used to
{       send parameters back to the client mainframe.  This sequence is reset
{       before the procedure is called.
{
{ SEND_TO_CLIENT_DATA_P: (output)  This is a sequence that can be used to send
{       data back to the client mainframe.  This sequence is reset before the
{       procedure is called.
{
{ PARAMETER_SIZE: (output)  This is the amount of data in the parameter
{       sequence that should be passed to the client.  Zero should be used if
{       no parameters (other than status) are to be passed to the client.
{
{ DATA_SIZE: (output)  This is the amount of data in the data sequence that
{       should be passed to the client mainframe.  Zero should be used if no
{       data is to be passed to the client.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             none.
*DECK DECK=JMH$SET_ACCOUNT_PROJECT EXPAND=FALSE

{
{   The purpose of this request is to set the ACCOUNT and PROJECT
{  fields in the Job Control Block (JCB) of the requesting job.
{
{     JMP$SET_ACCOUNT_PROJECT (ACCOUNT, PROJECT, STATUS)
{
{  ACCOUNT: (input) This parameter specifies the account to be set.
{
{  PROJECT: (input) This parameter specifies the project to be set.
{
{  STATUS: (output) This parameter specifies the request status.
{

*DECK DECK=JMH$SET_AJL_SWAP_STATUS EXPAND=FALSE
{
{     This procedure will set a swapout/swapin status in a particular
{  AJL entry.
{
{  SET_AJL_SWAP_STATUS (AJL, SWAP_STATUS)
{
{  AJL: (input) The Active Job List ordinal.
{
{  SWAP_STATUS: (input) The associated swapout/swapin status.
{
*DECK DECK=JMH$SET_APPLICATION_SCHEDULING EXPAND=FALSE
{
{    The purpose of this request is to set scheduling parameters for an
{ application.  The request updates the desired attributes in the jmv$jcb and
{ sets flags to prevent changes from being made to the changed attributes.
{
{    While application scheduling is in effect, any changes made by the job to
{ the affected attributes are postponed until the attribute is no longer under
{ control of application scheduling.  Requests to display the affected
{ attributes will get the values as they were before being changed for
{ application scheduling.
{
{       JMP$SET_APPLICATION_SCHEDULING (APPLICATION_ATTRIBUTES,
{             NEW_SERVICE_ACCUMULATOR, OLD_SERVICE_ACCUMULATOR, STATUS);
{
{  APPLICATION_ATTRIBUTES: (input)  The application's scheduling attributes.
{
{  NEW_SERVICE_ACCUMULATOR: (input)  The value to give to the service
{        accumulator if the service class is changed.  When an application is
{        initially scheduled this should be zero but when application
{        scheduling is restarted after running a nested application then this
{        should be the saved value from when the nested application took over.
{
{  OLD_SERVICE_ACCUMULATOR: (output)  Returns the service accumulator value
{        from before the service class was changed.  If the service class was
{        not changed then the value zero is returned.
{
{  STATUS: (output) The standard status parameter.
{       CONDITIONS:
{             NONE
*DECK DECK=JMH$SET_DISPLAY_MESSAGE_POINTER EXPAND=FALSE
{
{    This request sets the pointer to the display message descriptor
{  in the Known Job List (KJL) entry of the requesting job.
{
{        JMP$SET_DISPLAY_MESSAGE_POINTER (STATUS_MESSAGE)
{
{ STATUS_MESSAGE: (input) This parameter specifies the pointer to the ALLOCATEd
{       space for the display message.
*DECK DECK=JMH$SET_INPUT_COMPLETED EXPAND=FALSE
{
{    The purpose of this request is to indicate to queue files that the
{ disposition of a job has completed.  After this request is made the
{ application must discard any knowledge it may have about this job.  The job
{ no longer belongs to the application and is the sole property of NOS/VE queue
{ file management.
{
{       JMP$SET_INPUT_COMPLETED (JOB_DESTINATION_USAGE, SYSTEM_JOB_NAME,
{             COMPLETED_SUCCESSFULLY, STATUS);
{
{ JOB_DESTINATION_USAGE: (input)  This is the job_destination_usage of the job.
{
{ SYSTEM_JOB_NAME: (input)  This is the name that NOS/VE assigned to the job
{       when it was submitted.
{
{ COMPLETED_SUCCESSFULLY: (input)  This indicates whether or not the job was
{       disposed of successfully.  If the job was not disposed of successfully
{       it may be made available to the application again.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$application_not_permitted
{             jme$destination_usage_incorrect
{             jme$name_not_found
*DECK DECK=JMH$SET_INPUT_INITIATED EXPAND=FALSE
{
{    The purpose of this request is to notify queued files that the disposition
{ of a job has commenced (or is about to).  This request prevents any attribute
{ changes from taking place in the job until disposition has completed.
{
{       JMP$SET_INPUT_INITIATED (JOB_DESTINATION_USAGE, SYSTEM_JOB_NAME,
{             STATUS);
{
{ JOB_DESTINATION_USAGE: (input)  This is the job_destination_usage of the job
{       that is being disposed of.
{
{ SYSTEM_JOB_NAME: (input)  This is the name that NOS/VE assigned to the job
{       when it was submitted.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$application_not_permitted
{             jme$destination_usage_incorrect
{             jme$input_cannot_initiate
{             jme$name_not_found
*DECK DECK=JMH$SET_INTERACTIVE_COND_STATE EXPAND=FALSE
{    The purpose of this request is to enable or disable interactive conditions
{ within a transaction job created by the jmp$submit_detached_job request.
{ This request is ignored in any other type of job.
{
{    When a transaction job begins, it functions identically to any other
{ NOS/VE interactive job with regards to interactive conditions, user breaks,
{ and user interrupts.  This is the state of the job when interactive
{ conditions are enabled.
{
{    If this request is used to disable interactive conditions, the following
{ behavior changes occur in the job:
{
{ o User breaks (%1, %2) are ignored and no pause-break or terminate break
{   interactive condition is created.
{ o User interrupts (%S, %L, %A, %D, etc) are disabled.
{ o Should a job become disconnected, no disconnect condition is raised.  In
{   addition, IO requests on a terminal file will result in the error
{   JME$TRANSACTION_JOB_DISCONNECT being returned as the status of the request.
{ o No reconnect conditions will occur should a disconnected transaction job
{   be reconnected.
{
{ NOTE:
{   If the transaction job sees the error JME$TRANSACTION_JOB_DISCONNECT on an
{ IO request, the JMP$RETURN_CONNECTION request should still be issued.
{
{       JMP$SET_INTERACTIVE_COND_STATE (INTERACTIVE_CONDITIONS_ENABLED);
{
{ INTERACTIVE_CONDITIONS_ENABLED: (input)  A boolean indicator used to enable
{       or disable interactive conditions within the transaction job.
*DECK DECK=JMH$SET_JOB_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to set the values of the job local
{  attribute structure to various values.
{
{        JMP$SET_JOB_ATTRIBUTES (JOB_ATTRIBUTE_CHANGES, STATUS);
{
{ JOB_ATTRIBUTE_CHANGES: (input) This is an array of variants that contains the
{        job attribute values to be set.
{
{ STATUS: (output) This is a record that contains the status of the request.
{
*DECK DECK=JMH$SET_JOB_CLASS_LIMITS EXPAND=FALSE
{
{    The purpose of this request is to select the limit of the maximum number
{ of initiated jobs in a particular set of job classes.
{
{       JMP$SET_JOB_CLASS_LIMITS (JOB_CLASS_SET, CLASS_LIMIT_VALUE, STATUS);
{
{ JOB_CLASS_SET: (input)  This is the set of job class whose values are to be
{       altered.
{
{ CLASS_LIMIT_VALUE: (input)  This is the limit imposed on the classes in
{       JOB_CLASS_SET.
{
{ STATUS: (output) This returns the status of the request.
{   CONDITION:
{     jme$special_privilege_required
{
{
*DECK DECK=JMH$SET_JOB_HISTORY_STATE EXPAND=FALSE
{
{    The purpose of this request is to set indicator of whether job history
{  is active or not.
{
{        JMP$SET_JOB_HISTORY_STATE (STATE);
{
{ STATE: (input) Indicates whether job history is active or not.
*DECK DECK=JMH$SET_JOB_MODE EXPAND=FALSE
{
{    The purpose of this request is to set the job mode of the requesting
{  job to the specified job mode.
{
{        JMP$SET_JOB_MODE (MODE, STATUS)
{
{ MODE: (input) This parameter specifies the new job mode to be assigned
{        to the requesting job.
{
{ STATUS: (output) This parameter specifies the request status.
{      CONDITIONS:
{        none.
*DECK DECK=JMH$SET_JOB_SWAP_STATUS EXPAND=FALSE
{
{     This request will set a particular swapout swapin status in the
{  associated jobs AJL entry.
{
{  JMP$SET_JOB_SWAP_STATUS (AJL_ORDINAL, SWAP_STATUS, ABORT_SWAP)
{
{  AJL_ORDINAL: (input) The AJL ordinal of the job whose status to set.
{
{  SWAP_STATUS: (input) The status to set to.
{
{  ABORT_SWAP: (output) A boolean telling whether or not to continue with the swap.
{
*DECK DECK=JMH$SET_JOB_UNSWAPPABLE EXPAND=FALSE
{
{     This request will set the job invoking it in an unswappable state.
{
{  JMP$SET_JOB_UNSWAPPABLE (STATUS)
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$SET_OPERATOR_INFO_POINTER EXPAND=FALSE
{
{    This request sets the pointer to the OFT$OPERATOR_INFO_DESCRIPTOR
{  in the Known Job List (KJL) entry of the requesting job.
{
{        JMP$SET_OPERATOR_INFO_POINTER (OPERATOR_INFO_P)
{
{ OPERATOR_INFO_P: (input) This parameter specifies the pointer value.
*DECK DECK=JMH$SET_OUTPUT_COMPLETED EXPAND=FALSE
{
{    The purpose of this request is to indicate to queue file manager that the
{ disposition of an output file has completed.  After this request is made the
{ application must discard any knowledge it may have about this file.  The file
{ no longer belongs to the application and is the sole property of NOS/VE queue
{ file manager.
{
{       JMP$SET_OUTPUT_COMPLETED (OUTPUT_DESTINATION_USAGE, SYSTEM_FILE_NAME,
{             COMPLETED_SUCCESSFULLY, STATUS);
{
{ OUTPUT_DESTINATION_USAGE: (input)  This is the output_destination_usage of
{       the output file.
{
{ SYSTEM_FILE_NAME: (input)  This is the name that NOS/VE assigned to the file
{       when it was printed.
{
{ COMPLETED_SUCCESSFULLY: (input)  This indicates whether or not the file was
{       disposed of successfully.  If the file was not disposed of successfully
{       it may be made available to the application again.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$application_not_permitted
{             jme$destination_usage_incorrect
{             jme$name_not_found
*DECK DECK=JMH$SET_OUTPUT_INITIATED EXPAND=FALSE
{
{    The purpose of this request is to notify queue file manager that the
{ disposition of an output file has commenced (or is about to).  This request
{ prevents any attribute changes from taking place in the output file until
{ disposition has completed.
{
{       JMP$SET_OUTPUT_INITIATED (OUTPUT_DESTINATION_USAGE, SYSTEM_FILE_NAME,
{             STATUS);
{
{ OUTPUT_DESTINATION_USAGE: (input)  This is the output_destination_usage of
{       the output file that is being disposed of.
{
{ SYSTEM_FILE_NAME: (input)  This is the name that NOS/VE assigned to the file
{       when it was printed.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$application_not_permitted
{             jme$destination_usage_incorrect
{             jme$name_not_found
{             jme$output_cannot_initiate
{
*DECK DECK=JMH$SET_PROFILE_LOADING_FLAG EXPAND=FALSE
{
{   The purpose of this request is to set or clear the system restrictions
{ required for the installation of a scheduling profile in the scheduler
{ tables.
{
{       JMP$SET_PROFILE_LOADING_FLAG (PROFILE_IS_LOADING, NEW_PROFILE_ID,
{         STATUS)
{
{ PROFILE_IS_LOADING: (input)  This parameter specifies whether or not a
{       scheduling profile is being installed.  A TRUE value indicates that a
{       profile is being installed.
{
{ NEW_PROFILE_ID: (input)  This parameter specifies the identification of the
{       profile which is being installed.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             none
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$SET_QFILE_COMPLETED EXPAND=FALSE
{
{    The purpose of this request is to indicate to the generic queue file
{ manager that the processing of a queue file has completed.  After this
{ request is made the application must discard any knowledge it may have about
{ this file.  The file no longer belongs to the application and is the sole
{ property of NOS/VE queue file manager.
{
{       JMP$SET_QFILE_COMPLETED (APPLICATION_NAME, SYSTEM_FILE_NAME,
{             COMPLETED_SUCCESSFULLY, STATUS)
{
{ APPLICATION_NAME: (input)  This is the application_name of the queue file.
{
{ SYSTEM_FILE_NAME: (input)  This is the name that NOS/VE assigned to the file
{       when it was queued.
{
{ COMPLETED_SUCCESSFULLY: (input)  This indicates whether or not the file was
{       disposed of successfully.  If the file was not disposed of successfully
{       it may be made available to the application again.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$qfile_appl_not_permitted
{             jme$application_name_incorrect
{             jme$name_not_found
*DECK DECK=JMH$SET_QFILE_INITIATED EXPAND=FALSE
{
{    The purpose of this request is to notify the generic queue file manager
{ that the processing of a queue file has commenced (or is about to).  This
{ request prevents any attribute changes from taking place in the queue file
{ until processing has completed.
{
{       JMP$SET_QFILE_INITIATED (APPLICATION_NAME, SYSTEM_FILE_NAME, STATUS);
{
{ APPLICATION_NAME: (input)  This is the application_name of the queue file
{       that is being disposed of.
{
{ SYSTEM_FILE_NAME: (input)  This is the name that NOS/VE assigned to the file
{       when it was queued.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$application_name_incorrect
{             jme$name_not_found
{             jme$qfile_appl_not_permitted
{             jme$qfile_cannot_initiate
{
*DECK DECK=JMH$SET_SWAPPING_CONTROL EXPAND=FALSE
{
{     This request will toggle the boolean which controls whether
{  job swapping is allowed on a system wide basis or not.
{
{  JMP$SET_SWAPPING_CONTROL (TOGGLE, STATUS)
{
{  TOGGLE: (input) What value to ascribe the boolean.
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$SET_SWAP_CONTROL_VARIABLE EXPAND=FALSE
{
{     This procedure enables or disables swapping by setting a control
{  variable.
{
{  JMP$SET_SWAP_CONTROL_VARIABLE( TOGGLE )
{
{  TOGGLE: (input) A boolean true=enable.
{
*DECK DECK=JMH$SET_SYSTEM_SEQUENCE_NUMBER EXPAND=FALSE
{
{    The purpose of this request is to validate and reset the sequence and
{ counter portion (a.k.a. sequence number) of the system supplied names
{ assigned to jobs and output files.
{
{       JMP$SET_SYSTEM_SEQUENCE_NUMBER (SYSTEM_SEQUENCE_NUMBER, STATUS);
{
{ SYSTEM_SEQUENCE_NUMBER: (input)  This is the system supplied name sequence
{       and counter values to be set.
{
{ STATUS: (output) This is the status of the request.
*DECK DECK=JMH$SET_UTILITY_ACTIVE EXPAND=FALSE
{
{   The purpose of this request is to set the utility active flag which allows
{ the caller to subsequently install a scheduling profile and update the
{ scheduler tables.  The caller must have scheduling administration privilege.
{
{       JMP$SET_UTILITY_ACTIVE (ACCESS_ID, STATUS)
{
{ ACCESS_ID: (output)  This parameter specifies tha access id assigned to the
{       caller which allows the caller to modify the scheduler tables.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             jme$another_utility_is_active
{             jme$must_be_scheduling_admin
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$SET_UTILITY_ACTIVE_FLAG EXPAND=FALSE
{
{   The purpose of this request is to set the utility active flag which allows
{ the caller to subsequently install a scheduling profile and update the
{ scheduler tables.
{
{       JMP$SET_UTILITY_ACTIVE_FLAG (ACCESS_ID, STATUS)
{
{ ACCESS_ID: (output)  This parameter specifies tha access id assigned to the
{       caller which allows the caller to modify the scheduler tables.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             jme$another_utility_is_active
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$SIGNAL_PAIR_CONNECT_TARGET EXPAND=FALSE
{    The purpose of this request is to notify the target job of a paired
{ connection attach job request.  This function is used in a cluster
{ environment when the job doing the attach job is on one mainframe and the
{ target job of the attach is on a different mainframe.
{
{       JMP$SIGNAL_PAIR_CONNECT_TARGET (SYSTEM_JOB_NAME, STATUS);
{
{ SYSTEM_JOB_NAME: (input)  This is the system job name of the job that is the
{       target of the attach job request.  The connection destined for the
{       target job must have been offered for connection switch before this
{       request is issued.
{
{ STATUS: (output)  This is the status of the request.
{      CONDITIONS:
{            none
*DECK DECK=JMH$STATUS_ALL_FULL EXPAND=FALSE
{
{   The purpose of this request is to obtain the full status of all jobs and
{  queue files that currently exist in the system. Special privileges are
{  required for this request.
{
{     JMP$QSTATUS_ALL_FULL ( QUEUE_TYPE, PRIORITY, START, STATUS_ARRAY,
{       NRETURNED, STATUS)
{
{  QUEUE_TYPE: (input) This parameter specifies the type of jobs and/or
{                      files for which status information is desired.
{
{  PRIORITY: (input) This parameter is not currently used.
{
{  START: (input) This parameter is not currently used.
{
{  STATUS_ARRAY: (output) This parameter specifies the array of status records
{                         that the status is placed into.
{
{  NRETURNED: (output) This parameter specifies the number of status records
{                      returned in STATUS_ARRAY.
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=JMH$SUBMIT_DETACHED_JOB EXPAND=FALSE
{
{    The purpose of this request is to initiate a detached interactive job.
{ Terminal output from this job will be discarded until a network connection
{ has been acquired by jmp$acquire_connection.  Terminal input will cause the
{ job to wait for a terminal reconnect.
{
{    The submitted job has the same login family, login user and job class as
{ the requesting job.  The user must be validated for the submit_detached_jobs
{ capability to use this request.
{
{       JMP$SUBMIT_DETACHED_JOB (USER_INFORMATION, STATUS);
{
{ USER_INFORMATION: (input)  This parameter specifies a value for the
{       user_information job attribute of the submitted job.
{
{ STATUS: (output) This parameter returns the completion status of this
{         request.
*DECK DECK=JMH$SUBMIT_JOB EXPAND=FALSE
{
{    The purpose of this request is to submit a job to become a candidate for
{  initiation on NOS/VE.
{
{        JMP$SUBMIT_JOB (FILE_REFERENCE, JOB_SUBMISSION_OPTIONS,
{              SYSTEM_JOB_NAME, STATUS);
{
{ FILE_REFERENCE: (input) This is a file that contains the commands of the job
{        to be submitted.
{
{ JOB_SUBMISSION_OPTIONS: (input) This is an array of variants that can impress
{        various characteristics on the job (e.g. job_class).
{
{ SYSTEM_JOB_NAME: (output) This is the system supplied name that NOS/VE
{        has assigned to the job.
{
{ STATUS: (output) This is a record that contains the status of the request.
{       CONDITIONS:
{        ave$illegal_ring
{        cle$improper_name
{        jme$invalid_parameter
{        jme$maximum_jobs
{        jme$must_be_system_job
{        jme$no_space_for_file
*DECK DECK=JMH$SUBMIT_QFILE EXPAND=FALSE
{
{    The purpose of this request is to submit a file to the generic queue.
{
{       JMP$SUBMIT_QFILE (FILE_REFERENCE, APPLICATION_NAME,
{             SUBMISSION_OPTIONS_P, SYSTEM_FILE_NAME, STATUS);
{
{ FILE_REFERENCE: (input)  This is the file to be put in the queue.
{
{ APPLICATION_NAME: (input)  This is the name of the application that is
{       expected to process the file in the queue.
{
{ SUBMISSION_OPTIONS_P: (input)  This is an array of variants which can provide
{       several of the characteristics about the file.
{
{ SYSTEM_FILE_NAME: (output)  This is the system supplied name that has been
{       assigned to the file.
{
{ STATUS: (output) This is the record that contains the status of the request.
{       CONDITIONS:
{             ame$ring_validation_error
{             cle$improper_name
{             jme$invalid_destination
{             jme$invalid_parameter
{             jme$invalid_rhd
{             jme$maximum_generic_qfiles
{             jme$sl_version_mismatch
{
*DECK DECK=JMH$SWAPIN_BY_PRIORITY EXPAND=FALSE
{
{     The purpose of this request is to select a swapin candidate
{  considering all queues solely on a priority basis.
{
{  JMP$SWAPIN_BY_PRIORITY(BEST_NODE, NONE_LEFT)
{
{  BEST_NODE: (output) The job id of the swapin candidate.
{
{  NONE_LEFT: (output) A boolean specifying termination of search.
{
*DECK DECK=JMH$SWAPIN_JOB EXPAND=FALSE
{
{     This request starts the swapin process.
{
{  JMP$SWAPIN_JOB (IJL_ORDINAL, SYSTEM_SUPPLIED_NAME, STATUS)
{
{  IJL_ORDINAL: (input) The ijl ordinal of the job.
{
{  JOB_NAME: (input) The system supplied job name(JSN).
{
{  STATUS: (output) The request status.
{
*DECK DECK=JMH$SWAPIN_JOB_SIGNAL_HANDLER EXPAND=FALSE
{
{     The purpose of this request is to handle a signal from monitor
{  to increase a swapped jobs priority in order that it may be swapped in
{  sooner.
{
{  JMP$SWAPIN_JOB_SIGNAL_HANDLER (ORIGINATOR, SIGNAL)
{
{  ORIGINATOR: (input) global taskid of task who originated the signal.
{
{  SIGNAL: (input) Here the KJL ordinal of the job to be upped in priority.
{
*DECK DECK=JMH$SWAPOUT_JOB EXPAND=FALSE
{    This request will start the job swapout process and if requested will
{ disable recovery of the job.
{
{       JMP$SWAPOUT_JOB (JOB_NAME, DISABLE_RECOVERY, STATUS);
{
{ JOB_NAME: (input)  This is the name of the job to be swapped out.
{
{ DISABLE_RECOVERY: (input)  Indicates if recovery of the job should be
{       inhibited.
{
{ STATUS: (output) This is the status of the request.
{      CONDITION:
{          ofe$sou_not_active
*DECK DECK=JMH$SWAP_SIGNAL_HANDLER EXPAND=FALSE
{ This deck externalizes the signal handler procedure of the job scheduler.
{ The signal handler procedure of the scheduler is responsible for actually
{ invoking the physical swapout/swapin process.
{
{  jmp$swap_signal_handler(recipient: ost$global_task_id,
{     signal: pmt$signal);
{
{  recipient: (input)  Will be the scheduler asynchronous swapper.
{  signal: (input) the message sent will describe which job to swap via its AJL ordinal.
{  Also provided is the swap function, either swapout or swapin.
*DECK DECK=JMH$SWITCH_COMMAND_R3 EXPAND=FALSE
{
{    The purpose of this request is to change the sense switches of
{  a specified job. The specified job may be the requesting job or
{  a job other than the requesting job.
{
{     JMP$SWITCH_COMMAND_R3( NAME, ON, OFF, STATUS)
{
{  NAME:  (input)  The name of the job whose sense switches are to be
{         changed.
{
{  ON: (input) This parameter specifies the sense switches to be set.
{      The results of setting and clearing the same switch on a single
{      command are undefined.
{
{  OFF: (input) This parameter specifies the sense switches to be cleared.
{       The results of setting and clearing the same switch on a single
{       command are undefined.
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=JMH$SYSTEM_ERROR EXPAND=FALSE

{
{   The purpose of this procedure is to provide a mechanism to field
{  OSP$SYSTEM_ERROR type of errors at Ring Level 2 and pass them on to the
{  OSP$SYSTEM_ERROR interface.
{
{     JMP$SYSTEM_ERROR ( ERROR_MESSAGE, STATUS )
{
{  ERROR_MESSAGE: (input) This parameter specifies the error message
{      to be displayed.  This parameter has been provided to indicate
{      the system area that failed without changing the status variable.
{
{  STATUS: (input) This parameter specifies the status of the caller.
{      It is assumed to be abnormal and is not changed by this procedure.
{
*DECK DECK=JMH$SYSTEM_JOB EXPAND=FALSE
{
{     This function indicates whether the requesting job is the System Job.
{
{     JMP$SYSTEM_JOB ( )
{
*DECK DECK=JMH$TERMINATED_INPUT_EXISTS EXPAND=FALSE
{
{    The purpose of this request is to determine if there are jobs for the
{ specified job_destination_usage that have been terminated since being
{ acquired.
{
{       JMP$TERMINATED_INPUT_EXISTS (JOB_DESTINATION_USAGE) :  BOOLEAN;
{
{ JOB_DESTINATION_USAGE: (input)  This is the job_destination_usage of the job.
{
*DECK DECK=JMH$TERMINATED_OUTPUT_EXISTS EXPAND=FALSE
{
{    The purpose of this request is to determine if there are files for the
{ specified output_destination_usage that have been terminated since being
{ acquired.
{
{       JMP$TERMINATED_OUTPUT_EXISTS (OUTPUT_DESTINATION_USAGE) :  BOOLEAN;
{
{ OUTPUT_DESTINATION_USAGE: (input)  This is the output_destination_usage of
{       the file.
{
*DECK DECK=JMH$TERMINATED_QFILE_EXISTS EXPAND=FALSE
{
{    The purpose of this request is to determine if there are files for the
{ specified application_name that have been terminated since being acquired.
{
{       JMP$TERMINATED_QFILE_EXISTS (APPLICATION_NAME) :  BOOLEAN;
{
{ APPLICATION_NAME: (input)  This is the application_name of the file.
{
*DECK DECK=JMH$TERMINATE_ACQUIRED_INPUT EXPAND=FALSE
{
{    The purpose of this request is to notify queued files that it is okay to
{ terminate a job that has been terminated by request of a user.
{
{       JMP$TERMINATE_ACQUIRED_INPUT (JOB_DESTINATION_USAGE, SYSTEM_JOB_NAME,
{             STATUS);
{
{ JOB_DESTINATION_USAGE: (input)  This parameter indicates what the
{       job_destination_usage of the job must be.
{
{ SYSTEM_JOB_NAME: (output)  This parameter is the name of the job that has
{       been terminated.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$application_not_permitted
{             jme$destination_usage_incorrect
{             jme$input_queue_is_empty
*DECK DECK=JMH$TERMINATE_ACQUIRED_OUTPUT EXPAND=FALSE
{
{    The purpose of this request is to notify queued files that it is okay to
{ terminate an output file that has been terminated by request of a user.
{
{       JMP$TERMINATE_ACQUIRED_OUTPUT (OUTPUT_DESTINATION_USAGE,
{             SYSTEM_FILE_NAME, STATUS);
{
{ OUTPUT_DESTINATION_USAGE: (input)  This parameter indicates what the
{       output_destination_usage of the output file must be.
{
{ SYSTEM_FILE_NAME: (output)  This parameter is the name of the output file
{       that has been terminated.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$application_not_permitted
{             jme$destination_usage_incorrect
{             jme$output_queue_is_empty
{
{
*DECK DECK=JMH$TERMINATE_ACQUIRED_QFILE EXPAND=FALSE
{
{    The purpose of this request is to notify a queue file application to
{ terminate a queue file.
{
{       JMP$TERMINATE_ACQUIRED_QFILE (APPLICATION_NAME, SYSTEM_FILE_NAME,
{             STATUS);
{
{ APPLICATION_NAME: (input)  This parameter indicates what the application_name
{       of the queue file must be.
{
{ SYSTEM_FILE_NAME: (output)  This parameter is the name of the queue file that
{       has been terminated.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$qfile_appl_not_permitted
{             jme$generic_queue_is_empty
{
*DECK DECK=JMH$TERMINATE_JOB EXPAND=FALSE
{
{    The purpose of this request is to discard a job on NOS/VE.
{
{        JMP$TERMINATE_JOB (JOB_NAME, JOB_TERMINATION_OPTIONS, STATUS);
{
{ JOB_NAME: (input) This is the name of the job to be terminated.
{
{ JOB_TERMINATION_OPTIONS: (input) This can require the job to satisfy certain
{        conditions if it is to be terminated and/or it can impress termination
{        characteristics on job (e.g., job_state or discard_job_output).
{
{ STATUS: (output) This is the record that contains the status of the request.
{
*DECK DECK=JMH$TERMINATE_JOB_FLAG_HANDLER EXPAND=FALSE
{
{    The purpose of this procedure is to terminate the entire job environment
{ from a JMP$TERMINATE_JOB request.
{
{       JMP$TERMINATE_JOB_FLAG_HANDLER (FLAG_ID);
{
{  FLAG_ID: (input)  This parameter specifies which system flag was set.
*DECK DECK=JMH$TERMINATE_OUTPUT EXPAND=FALSE
{
{    The purpose of this request is to discard an output file on NOS/VE.
{
{       JMP$TERMINATE_OUTPUT (OUTPUT_NAME, OUTPUT_TERMINATION_OPTIONS, STATUS);
{
{ OUTPUT_NAME: (input)  This is the name of the output file to be terminated.
{
{ OUTPUT_TERMINATION_OPTIONS: (input)  This can require the output file to
{       satisfy conditions if it is to be terminated.
{
{ STATUS: (output) This is the record that contains the status of the request.
{       CONDITIONS:
{             jme$duplicate_name
{             jme$invalid_parameter
{             jme$name_not_found
{             jme$output_already_terminated
{             jme$output_state_is_null
*DECK DECK=JMH$TERMINATE_QFILE EXPAND=FALSE
{
{    The purpose of this request is to discard a file from the generic queue.
{
{       JMP$TERMINATE_QFILE (SYSTEM_FILE_NAME, TERMINATION_OPTIONS_P, STATUS);
{
{ SYSTEM_FILE_NAME: (input)  This is the name of the queue file to be
{       terminated.
{
{ TERMINATION_OPTIONS_P: (input)  This can require the queue file to satisfy
{       conditions if it is to be terminated.
{
{ STATUS: (output) This is the record that contains the status of the request.
{       CONDITIONS:
{             jme$invalid_parameter
{             jme$name_not_found
{             jme$qfile_already_terminated
{             jme$qfile_state_is_null
*DECK DECK=JMH$TIMESHARING_SIGNAL_HANDLER EXPAND=FALSE
{
{    The purpose of this request is to indicate that a timesharing signal has
{  arrived and requires attention.
{
{        JMP$TIMESHARING_SIGNAL_HANDLER (ORIGINATOR, SIGNAL);
{
{ ORIGINATOR: (input) This indicates the task that send the signal.
{
{ SIGNAL: (input) This is the information sent with the signal.
{
*DECK DECK=JMH$UNASSIGN_SERVER_JOBS EXPAND=FALSE
{
{    The purpose of this request is to remove uninitiated jobs from the
{ client's Known Job List (KJL).
{
{       JMP$UNASSIGN_SERVER_JOBS (SERVER_MAINFRAME_ID, UNASSIGN_ALL_JOBS,
{             JOB_CLASS_PRIORITIES, UNASSIGNED_JOB_LIST,
{             NUMBER_OF_UNASSIGNED_JOBS);
{
{ SERVER_MAINFRAME_ID: (input)  This is the binary mainframe identifier of the
{       server mainframe.
{
{ UNASSIGN_ALL_JOBS: (input)  This indicates if all jobs should be unassigned
{       regardless of their priority.
{
{ JOB_CLASS_PRIORITIES: (input)  This is the priority of the jobs being
{       requested from the clients.
{
{ UNASSIGNED_JOB_LIST: (output)  This is the list of jobs removed from the KJL.
{
{ NUMBER_OF_UNASSIGNED_JOBS: (output)  This is the number of jobs in the
{       unassigned_job_list.
*DECK DECK=JMH$UPDATE_DISPLAY_MESSAGE EXPAND=FALSE
{    The purpose of this request is to convert a status value to a string and
{ write the string value to the display message field for job status.
{
{       JMP$UPDATE_DISPLAY_MESSAGE (MESSAGE_STATUS);
{
{ MESSAGE_STATUS: (input)  This is the status to be displayed.

*DECK DECK=JMH$UPDATE_JOB_TEMPLATE_SDT EXPAND=FALSE
{
{     This request will place a copy of a specified job template
{  SDT, SDTX entry in the saved template SDT, SDTX entry.
{
{  JMP$UPDATE_JOB_TEMPLATE_SDT( PVA, STATUS)
{
{  PVA: (input) This is a process virtual address of the segment whose
{               SDT and SDTX entries should be saved.
{
{  STATUS: (output) The disposition of the request.
{
*DECK DECK=JMH$UPDATE_LAST_USED_SSN EXPAND=FALSE
{
{    The purpose of this request is to update the last system_supplied_name
{  that was assigned by NOS/VE.  The value is written to a recovery area in
{  the Recovery Deadstart File (RDF).
{
{        JMP$UPDATE_LAST_USED_SSN (STATUS);
{
{ STATUS: (output) This is the status of the request.
{
*DECK DECK=JMH$UPDATE_OUTPUT_STATUS EXPAND=FALSE
{
{    The purpose of this request is to update the status of a file that is
{ currently being printed (transferred).  The output_destination_usage and the
{ queue_file_password are used to validate the caller's privilege to access the
{ file.  The file must be CLOSED when this request is made.
{
{       JMP$UPDATE_OUTPUT_STATUS (SYSTEM_FILE_NAME, OUTPUT_DESTINATION_USAGE,
{             QUEUE_FILE_PASSWORD, OUTPUT_STATUS_UPDATES, STATUS);
{
{ SYSTEM_FILE_NAME: (input)  This is the system supplied name for the file.
{
{ OUTPUT_DESTINATION_USAGE: (input)  This is the output destination usage of
{       the file.
{
{ QUEUE_FILE_PASSWORD: (input)  This password validates the request to update
{       the status of the file.
{
{ OUTPUT_STATUS_UPDATES: (input)  This indicates what information about the
{       file is being updated.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$application_not_permitted
{             jme$destination_usage_incorrect
{             jme$invalid_parameter
{             jme$name_not_found
*DECK DECK=JMH$UPDATE_PROFILE EXPAND=FALSE
{
{   The purpose of this request is to update the scheduling profile in the
{ scheduler tables.  The existing tables are updated with the given definitions
{ for job classes, service classes, applications, and job scheduler controls.
{ The structure of the profile cannot be changed with this request.  The caller
{ must have scheduling administration privilege and must have set the utility
{ active condition prior to this call.
{
{       JMP$UPDATE_PROFILE (ACCESS_ID, CHANGED_JOB_CLASSES_P,
{         CHANGED_SERVICE_CLASSES_P, CHANGED_APPLICATIONS_P, CONTROLS_P,
{         STATUS)
{
{ ACCESS_ID: (input)  This parameter specifies the access id assigned to the
{       caller when the utility active condition was set.
{
{ CHANGED_JOB_CLASSES_P: (input)  This parameter specifies a pointer to an
{       array of job classes and their attributes which are to be updated in
{       the job class table.  The job classes must be defined in the current
{       job class table and have the sane index.  If this pointer is NIL, there
{       are no job classes to be updated.
{
{ CHANGED_SERVICE_CLASSES_P: (input)  This parameter specifies a pointer to an
{       array of service classes and their attributes which are to be updated
{       in the service class table.  The service classes must be defined in the
{       current service class table and have the same index.  If this pointer
{       is NIL, there are no service classes to be updated.
{
{ CHANGED_APPLICATIONS_P: (input)  This parameter specifies a pointer to an
{       array of applications and their attributes which are to be updated in
{       the application table.  The applications must be defined in the current
{       application table.  If this pointer is NIL, there are no applications
{       to be updated.
{
{ CONTROLS_P: (input)  This parameter specifies a pointer to a record which
{       updates the job scheduler table.  If this pointer is NIL, there are no
{       updates to the job scheduler table.
{
{ STATUS: (output)  This parameter specifies the request status.
{       All of the conditions listed are detected before the scheduler tables
{       are changed.
{       CONDITIONS:
{             jme$access_id_mismatch
{             jme$class_index_conflict
{             jme$class_or_appl_not_defined
{             jme$must_be_scheduling_admin
{             jme$no_utility_is_active
{             jme$profile_id_mismatch
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$UPDATE_PROFILE_IN_TABLES EXPAND=FALSE
{
{   The purpose of this request is to update the scheduling profile in the
{ scheduler tables.  The existing tables are updated with the given definitions
{ for job classes, service classes, applications, and job scheduler controls.
{
{       JMP$UPDATE_PROFILE_IN_TABLES (ACCESS_ID, CHANGED_JOB_CLASSES_P,
{         CHANGED_SERVICE_CLASSES_P, CHANGED_APPLICATIONS_P, CONTROLS_P,
{         STATUS)
{
{ ACCESS_ID: (input)  This parameter specifies the access id assigned to the
{       caller when the utility active condition was set.
{
{ CHANGED_JOB_CLASSES_P: (input)  This parameter specifies a pointer to an
{       array of job classes and their attributes which are to be updated in
{       the job class table.  If this pointer is NIL, there are no job classes
{       to be updated.
{
{ CHANGED_SERVICE_CLASSES_P: (input)  This parameter specifies a pointer to an
{       array of service classes and their attributes which are to be updated
{       in the service class table.  If this pointer is NIL, there are no
{       service classes to be updated.
{
{ CHANGED_APPLICATIONS_P: (input)  This parameter specifies a pointer to an
{       array of applications and their attributes which are to be updated in
{       the application table.  If this pointer is NIL, there are no
{       applications to be updated.
{
{ CONTROLS_P: (input)  This parameter specifies a pointer to a record which
{       updates the job scheduler table.  If this pointer is NIL, there are no
{       updates to the job scheduler table.
{
{ STATUS: (output)  This parameter specifies the request status.
{       All of the conditions listed are detected before the scheduler tables
{       are changed.
{       CONDITIONS:
{             jme$access_id_mismatch
{             jme$no_utility_is_active
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$UPDATE_QFILE_STATUS EXPAND=FALSE
{
{    The purpose of this request is to update the status of a file that is
{ currently being processed by an application.  The application_name and the
{ qfile_password are used to validate the caller's privilege to access the
{ file.  The file must be CLOSED when this request is made.
{
{       JMP$UPDATE_QFILE_STATUS (SYSTEM_FILE_NAME, APPLICATION_NAME,
{             QFILE_PASSWORD, QFILE_STATUS_UPDATES_P, STATUS);
{
{ SYSTEM_FILE_NAME: (input)  This is the system supplied name for the file.
{
{ APPLICATION_NAME: (input)  This is the application name of the file.
{
{ QFILE_PASSWORD: (input)  This password validates the request to update the
{       status of the file.
{
{ QFILE_STATUS_UPDATES_P: (input)  This indicates what information about the
{       file is being updated.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$qfile_appl_not_permitted
{             jme$application_name_incorrect
{             jme$invalid_parameter
{             jme$name_not_found
*DECK DECK=JMH$UPDATE_SERVER_PRIORITIES EXPAND=FALSE
{
{    The purpose of this request is to record the priority of the highest
{ priority job for each job class that is available on a server mainframe.
{
{       JMP$UPDATE_SERVER_PRIORITIES (HIGHEST_SERVER_PRIORITIES);
{
{ HIGHEST_SERVER_PRIORITIES: (input)  This is the highest priority job for each
{       job class that is available on a server mainframe.
*DECK DECK=JMH$UPDATE_SSN_SEQUENCE EXPAND=FALSE
{
{    The purpose of this request is to change the sequence and counter of the
{ system supplied names generated for jobs and output files.  This request is
{ intended to be used after the system device has been lost and the Recovery
{ Deadstart File (RDF) is unavailable.  This request permits the re-initialized
{ value to be changed to a more appropriate value.
{
{       JMP$UPDATE_SSN_SEQUENCE (SYSTEM_SUPPLIED_NAME);
{
{ SYSTEM_SUPPLIED_NAME: (input)  This is a system supplied name that contains
{       the new form of the name with the correct sequence.
{
*DECK DECK=JMH$UTIL_GET_QFILE_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to retrieve the attributes of generic queue
{ files for the manage_queue_file utility.  Either system_display or system_
{ operation capability must be active to call this interface.
{
{       JMP$UTIL_GET_QFILE_ATTRIBUTES (ATTRIBUTE_OPTIONS_P,
{             ATTRIBUTE_RESULTS_KEYS_P, ATTRIBUTE_WORK_AREA_P,
{             ATTRIBUTE_RESULTS_P, NUMBER_OF_QFILES_FOUND, STATUS);
{
{ ATTRIBUTE_OPTIONS_P: (input)  This is the criteria that select which queue
{       file(s) to retrieve the attributes for.
{
{ ATTRIBUTE_RESULTS_KEYS_P: (input)  This is an array of keys which determine
{       what information to return about the files.  Keys that can be specified
{       are the same as those that can be returned in the ATTRIBUTE_RESULTS_P
{       parameter.
{
{ ATTRUBUTE_WORK_AREA_P: (output)  This is the work area in which the attribute
{       results are returned.  The size required for a specified number of files
{       can be obtained by calling jmp$get_result_size.  See jmh$get_result_size
{       for further information.  Jmp$get_qfile_attributes will not RESET this
{       sequence before using it and will leave it positioned at the end of the
{       area used.
{
{ ATTRIBUTE_RESULTS_P: (output)  This contains the values of the requested
{       attributes.
{
{ NUMBER_OF_QFILES_FOUND: (output)  This is the number of queue files that met
{       the ATTRIBUTE_OPTIONS_P criteria.  If the status condition
{       jme$work_area_too_small is returned this value indicates the total
{       number of queue files that were found.
{
{ STATUS: This is the status of the request.
{       CONDITIONS:
{         cle$improper_name
{         jme$duplicate_attribute_key
{         jme$invalid_parameter
{         jme$no_qfiles_were_found
{         jme$work_area_too_small
{         ofe$sou_not_active

*DECK DECK=JMH$UTIL_TERMINATE_QFILE EXPAND=FALSE
{
{    The purpose of this request is to discard a file from the generic queue.
{ This request is intended to be called from manage_queue_files utility and the
{ system_operation capability must be active.
{
{       JMP$UTIL_TERMINATE_QFILE (SYSTEM_FILE_NAME, TERMINATION_OPTIONS_P,
{             STATUS);
{
{ SYSTEM_FILE_NAME: (input)  This is the name of the queue file to be
{       terminated.
{
{ TERMINATION_OPTIONS_P: (input)  This can require the queue file to satisfy
{       conditions if it is to be terminated.
{
{ STATUS: (output) This is the record that contains the status of the request.
{       CONDITIONS:
{             jme$invalid_parameter
{             jme$name_not_found
{             jme$qfile_already_terminated
{             jme$qfile_state_is_null
{             ofe$sou_not_active

*DECK DECK=JMH$VALIDATE_NAME EXPAND=FALSE
{
{    The purpose of this request is to verify that a name is valid as it has
{  been classified.
{
{        JMP$VALIDATE_NAME (CANDIATE_NAME, NAME, STATUS);
{
{ CANDIDATE_NAME: (input) This is the name to be verified.
{
{ NAME: (output) This is the verified (valid) name.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS: jme$illegal_ssn, cle$improper_name
{       IDENTIFIERS: 'JM', 'CL'
{
*DECK DECK=JMH$VALIDATE_PAIRED_CONNECTION EXPAND=FALSE
{    The purpose of this request is to verify that a paired connection request
{ is valid.  This request is used in a cluster environment when a job executing
{ on one mainframe does an attach job of a job that is executing on a different
{ mainframe in the cluster.
{
{       JMP$VALIDATE_PAIRED_CONNECTION (UNVALIDATED_CONNECTION_DATA_P,
{             LOGIN_FAMILY, LOGIN_USER, SYSTEM_JOB_NAME, STATUS);
{
{ UNVALIDATED_CONNECTION_DATA_P: (input)  This is the data that defines the
{       target and validation information for the paired connection.
{
{ LOGIN_FAMILY: (output)  This is the login family of the target job of the
{       paired connection request.
{
{ LOGIN_USER: (output)  This is the login user of the target job of the paired
{       connection request.
{
{ SYSTEM_JOB_NAME: (output)  This is the system job name of the target job of
{       the paired connection request.
{
{ STATUS: (output)  This is the status of the request.  If this request returns
{        abnormal status, the caller must NOT offer the connection to the target
{        job.
{      CONDITIONS:
{            jme$invalid_paired_connection
*DECK DECK=JMH$VALIDATE_USER EXPAND=FALSE
{    The purpose of this request is to validate particular attributes about the
{ given user.  In order to use this request, you must be executing in a job
{ with the login family of $SYSTEM and the login user of $SYSTEM.
{
{       JMP$VALIDATE_USER (LOGIN_FAMILY, LOGIN_USER, USER_VALIDATION_OPTIONS_P,
{             STATUS);
{
{ LOGIN_FAMILY: (input)  This is the family name of the user to be validated.
{
{ LOGIN_USER: (input)  This is the user name of the user to be validated.
{
{ USER_VALIDATION_OPTIONS_P: (input)  This is an array of variants that
{       contains the specific items to be validated for the supplied user.
{
{ STATUS: (output)  This is the status of the request.
{      CONDITIONS:
{            ave$bad_user_validation_info
{            cle$improper_name
{            jme$invalid_parameter
*DECK DECK=JMH$VERIFY_INACTIVE_SERVER EXPAND=FALSE
{
{    The purpose of this request is to verify that the indicated server
{ mainframe does not have any uninitiated jobs in the client's Known Job List.
{ In order for a server mainframe to go inactive, all jobs must be returned to
{ the server in an orderly manner.
{
{       JMP$VERIFY_INACTIVE_SERVER (SERVER_MAINFRAME_ID, SERVER_INACTIVE);
{
{ SERVER_MAINFRAME_ID: (input)  This is the binary mainframe id of the server
{       mainframe.
{
{ SERVER_INACTIVE: (output)  This indicates whether the server is legitimately
{       inactive.
*DECK DECK=JMH$VERIFY_JOB_LEVELER EXPAND=FALSE
{
{    The purpose of this request is to verify that the requesting task is the
{ job leveler task.  If the requesting task is NOT the job leveler task the
{ task is aborted.
{
{        JMP$VERIFY_JOB_LEVELER;
*DECK DECK=JMH$VERIFY_UTILITY_ACCESS_ID EXPAND=FALSE
{
{   The purpose of this request is to verify that the given access id belongs
{ to a scheduling utility that is currently in progress.
{
{       JMP$VERIFY_UTILITY_ACCESS_ID (ACCESS_ID, STATUS)
{
{ ACCESS_ID: (input)  This parameter specifies the access id for the request.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{            jme$access_id_mismatch
{            jme$no_utility_is_active
{       IDENTIFIER: 'JM'
{
*DECK DECK=JMH$WORKING_SET_LOCALITY_SEARCH EXPAND=FALSE

{
{     The purpose of this request is to find the job with the largest
{  working set to swap.
{
{  JMP$WORKING_SET_LOCALITY_SEARCH(NODE, CLASS, WORKING_SET_SIZE, NONE_LEFT)
{
{  NODE: (output) This specifies the job id to be swapped.
{
{  CLASS: (output) This is the class of the job.
{
{  WORKING_SET_SIZE: (output) The current working set of the job.
{
{  NONE_LEFT: (output) A boolean to indicate no jobs left to examine.
{
*DECK DECK=JMH$WRITE_RECOVERY_INFO_TO_DISK EXPAND=FALSE
{    The purpose of this request is to force the job recovery information that
{ has been saved to disk to remove the pages from the job's working set.
{
{       JMP$WRITE_RECOVERY_INFO_TO_DISK;
*DECK DECK=JMHIJE EXPAND=FALSE

{
{   The purpose of this procedure is to initialize a newly started jobs
{  environment. The procedure is called by tasking only for a new job and only
{  once for the new job. The procedure will perform functions such as moving
{  Job Templates into the various job segments, initialize respective heaps,
{  and other similar functions. Upon returning to tasking, the jobs initial
{  execution ring, a Program Descriptor, and Program Parameters for the
{  Job Monitor of the requesting job are formed and passed back to tasking
{  as return parameters of the initial call.
{
{     JMP$INITIALIZE_JOB_ENVIRONMENT ( JMTR_INITIAL_RING,
{       JMTR_PROGRAM_DESCRIPTION_P, JMTR_PROGRAM_PARAMETERS_P, STATUS)
{
{  JMTR_INITIAL_RING: (output) This parameter specifies the initial execution
{                              of the Job Monitor for the requesting job.
{
{  JMTR_PROGRAM_DESCRIPTION_P: (output) This parameter specifies the pointer
{                                       to the Program Description for the Job
{                                       Monitor of the requesting job.
{
{  JMTR_PROGRAM_PARAMETERS_P: (output) This parameter specifies the pointer
{                                      to the Program Parameters for the Job
{                                      Monitor of the requesting job.
{
{  STATUS: (output) This parameter specifies the request status.
{

*DECK DECK=JMK$KEYPOINTS EXPAND=FALSE

?? FMT (FORMAT := OFF) ??
  CONST

    jmk$submit_job                  = jmk$base +  0,
    {E  'jmp$submit_job' }
    {X  'jmp$submit_job' }

    jmk$terminate_job               = jmk$base +  1,
     {E 'jmp$terminate_job' }
     {X 'jmp$terminate_job' }

    jmk$get_job_status                = jmk$base +  2,
     {E 'jmp$get_job_status' }
     {X 'jmp$get_job_status' }

    jmk$print_file                = jmk$base +  3,
     {E 'jmp$print_file' }
     {X 'jmp$print_file' }

    jmk$terminate_output               = jmk$base +  4,
     {E 'jmp$terminate_output' }
     {X 'jmp$terminate_output' }

    jmk$acquire_new_input               = jmk$base +  5,
     {E 'jmp$acquire_new_input' }
     {X 'jmp$acquire_new_input' }

    jmk$acquire_new_output            = jmk$base +  6,
     {E 'jmp$acquire_new_output' }
     {X 'jmp$acquire_new_output' }

    jmk$output_completed          = jmk$base +  7,
     {E 'jmp$output_completed' }
     {X 'jmp$output_completed' }

    jmk$insert_swapin_candidate         = jmk$base +  8,
     {E 'jmp$insert_swapin_candidate' }
     {X 'jmp$insert_swapin_candidate' }

    jmk$restore_job_environment         = jmk$base +  9,
     {E 'jmp$restore_job_environment' }
     {X 'jmp$restore_job_environment' }

    jmk$close_input_file           = jmk$base + 10,
     {E 'jmp$close_input_file' }
     {X 'jmp$close_input_file' }

    jmk$logout                      = jmk$base + 11,
      {E 'jmp$logout' }
      {X 'jmp$logout' }

    jmk$set_swapout_candidate          = jmk$base + 12,
      {E 'jmp$set_swapout_candidate' }
      {X 'jmp$set_swapout_candidate' }

    jmk$calculate_service           = jmk$base + 13,
      {E 'jmp$calculate_service' }
      {X 'jmp$calculate_service' }

    jmk$emit_communication_stat            = jmk$base + 14,
      {E 'jmp$emit_communication_stat' }
      {X 'jmp$emit_communication_stat' }

    jmk$idle_system                 = jmk$base + 15,
      {E 'jmp$idle_system' }
      {X 'jmp$idle_system' }

    jmk$resume_system               = jmk$base + 16,
      {E 'jmp$resume_system' }
      {X 'jmp$resume_system' }

    jmk$recover_queues              = jmk$base + 17,
      {E 'jmp$recover_queues' }
      {X 'jmp$recover_queues' }

    jmk$get_job_class_limits        = jmk$base + 18,
      {E 'jmp$get_job_class_limits' }
      {X 'jmp$get_job_class_limits' }

    jmk$process_activate_job        = jmk$base + 19,
      {E 'jmp$process_activate_job' }
      {X 'jmp$process_activate_job' }

    jmk$acquire_modified_input       = jmk$base + 20,
      {E 'jmp$acquire_modified_input' }
      {X 'jmp$acquire_modified_input' }

    jmk$set_output_initiated        = jmk$base + 21,
      {E 'jmp$set_output_initiated' }
      {X 'jmp$set_output_initiated' }

    jmk$job_begin                   = jmk$base + 22,
      {E 'jmp$job_begin' }
      {X 'jmp$job_begin' }

    jmk$initialize_swap_file        = jmk$base + 23,
      {E 'jmp$initialize_swap_file' }
      {X 'jmp$initialize_swap_file' }

    jmk$ready_task_in_swapped_job       = jmk$base + 24,
      {E 'jmp$ready_task_in_swapped_job' }
      {X 'jmp$ready_task_in_swapped_job' }

    jmk$switch_command_r3           = jmk$base + 25,
      {E 'jmp$switch_command_r3' }
      {X 'jmp$switch_command_r3' }

    jmk$determine_name_kind          = jmk$base + 26,
      {E 'jmp$determine_name_kind' }
      {X 'jmp$determine_name_kind' }

    jmk$job_exists                   = jmk$base + 27,
      {E 'jmp$job_exists' }
      {X 'jmp$job_exists' }

    jmk$get_attribute_defaults   = jmk$base + 28,
      {E 'jmp$get_attribute_defaults' }
      {X 'jmp$get_attribute_defaults' }

    jmk$change_attribute_defaults   = jmk$base + 29,
      {E 'jmp$change_attribute_defaults' }
      {X 'jmp$change_attribute_defaults' }

    jmk$acquire_modified_output      = jmk$base + 30,
      {E 'jmp$acquire_modified_output' }
      {X 'jmp$acquire_modified_output' }

    jmk$change_output_attributes     = jmk$base + 31,
      {E 'jmp$change_output_attributes' }
      {X 'jmp$change_output_attributes' }

    jmk$terminate_acquired_output    = jmk$base + 32,
      {E 'jmp$terminate_acquired_output' }
      {X 'jmp$terminate_acquired_output' }

    jmk$change_job_attributes        = jmk$base + 33,
      {E 'jmp$change_job_attributes' }
      {X 'jmp$change_job_attributes' }

    jmk$get_job_attributes        = jmk$base + 34,
      {E 'jmp$get_job_attributes' }
      {X 'jmp$get_job_attributes' }

    jmk$modified_input_exists        = jmk$base + 35,
      {E 'jmp$modified_input_exists' }
      {X 'jmp$modified_input_exists' }

    jmk$set_job_attributes        = jmk$base + 36,
      {E 'jmp$set_job_attributes' }
      {X 'jmp$set_job_attributes' }

    jmk$get_job_parameters        = jmk$base + 37,
      {E 'jmp$get_job_parameters' }
      {X 'jmp$get_job_parameters' }

    jmk$categorize_job              = jmk$base + 38,
     {E  'qfp$categorize_job' }
     {X  'qfp$categorize_job' }

    jmk$new_input_exists        = jmk$base + 39,
      {E 'jmp$new_input_exists' }
      {X 'jmp$new_input_exists' }

    jmk$open_input_file        = jmk$base + 40,
      {E 'jmp$open_input_file' }
      {X 'jmp$open_input_file' }

    jmk$register_input_application        = jmk$base + 41,
      {E 'jmp$register_input_application' }
      {X 'jmp$register_input_application' }

    jmk$set_input_completed        = jmk$base + 42,
      {E 'jmp$set_input_completed' }
      {X 'jmp$set_input_completed' }

    jmk$set_input_initiated        = jmk$base + 43,
      {E 'jmp$set_input_initiated' }
      {X 'jmp$set_input_initiated' }

    jmk$terminated_input_exists        = jmk$base + 44,
      {E 'jmp$terminated_input_exists' }
      {X 'jmp$terminated_input_exists' }

    jmk$terminate_acquired_input        = jmk$base + 45,
      {E 'jmp$terminate_acquired_input' }
      {X 'jmp$terminate_acquired_input' }

    jmk$close_output_file        = jmk$base + 46,
      {E 'jmp$close_output_file' }
      {X 'jmp$close_output_file' }

    jmk$modified_output_exists        = jmk$base + 47,
      {E 'jmp$modified_output_exists' }
      {X 'jmp$modified_output_exists' }

    jmk$new_output_exists        = jmk$base + 48,
      {E 'jmp$new_output_exists' }
      {X 'jmp$new_output_exists' }

    jmk$open_output_file        = jmk$base + 49,
      {E 'jmp$open_output_file' }
      {X 'jmp$open_output_file' }

    jmk$register_output_application        = jmk$base + 50,
      {E 'jmp$register_output_application' }
      {X 'jmp$register_output_application' }

    jmk$terminated_output_exists        = jmk$base + 51,
      {E 'jmp$terminated_output_exists' }
      {X 'jmp$terminated_output_exists' }

    jmk$update_output_status        = jmk$base + 52,
      {E 'jmp$update_output_status' }
      {X 'jmp$update_output_status' }

    jmk$administer_scheduling        = jmk$base + 53,
      {E 'jmp$administer_scheduling' }
      {X 'jmp$administer_scheduling' }

    jmk$manage_active_scheduling        = jmk$base + 54,
      {E 'jmp$manage_active_scheduling' }
      {X 'jmp$manage_active_scheduling' }

    jmk$change_job_name_counter        = jmk$base + 55,
      {E 'jmp$change_job_name_counter' }
      {X 'jmp$change_job_name_counter' }

    jmk$wait_system_idle_comnd        = jmk$base + 56,
      {E 'jmp$wait_system_idle_comnd' }
      {X 'jmp$wait_system_idle_comnd' }

   jmk$limit                        = jmk$base + 100;
?? FMT (FORMAT := ON) ??

*copyc osk$keypoints
*DECK DECK=JML$USER_ID EXPAND=FALSE

*copyc JMC$CONDITION_LIMITS

  CONST
    jml$user_id = jmc$min_scc,
    jml$user_job_name = jmc$min_scc + 1,
    jml$job_mode = jmc$min_scc + 2,
    jml$job_end_statistics = jmc$min_scc + 3,
    jml$job_queuing_started = jmc$min_scc + 4,
    jml$job_queuing_aborted = jmc$min_scc + 5,
    jml$output_queuing_started = jmc$min_scc + 6,
    jml$output_queuing_aborted = jmc$min_scc + 7,
    jml$job_forwarding_started = jmc$min_scc + 8,
    jml$output_forwarding_started = jmc$min_scc + 9,
    jml$job_initiated = jmc$min_scc + 10,
    jml$job_terminated = jmc$min_scc + 11,
    jml$print_plot_initiated = jmc$min_scc + 12,
    jml$print_plot_terminated = jmc$min_scc + 13,
    jml$submit_job_executed = jmc$min_scc + 14,
    jml$print_plot_file_executed = jmc$min_scc + 15,
    jml$job_history_message = jmc$min_scc + 16,
    jml$non_recovery_of_job = jmc$min_scc + 17,
    jml$change_output_attributes = jmc$min_scc + 18,
    jml$job_file_deleted = jmc$min_scc + 19,
    jml$output_file_deleted = jmc$min_scc + 20,
    jml$open_file_statistics = jmc$min_scc + 21,

{ These constants must be used when referring to the entire range of history statistics, for example, when
{ activating or deactivating them via the statistics facility.

    jml$first_history_statistic = jml$job_queuing_started,
    jml$last_history_statistic = jml$output_file_deleted;
*DECK DECK=JMM$ADMINISTER_APPLICATION EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Scheduling : Application Administration' ??
MODULE jmm$administer_application;

{ PURPOSE:
{   This module defines the commands that make up the sub utility of
{   ADMINISTER_SCHEDULING called ADMINISTER_APPLICATION.  The procedures
{   in this module create, change, delete, and display application objects
{   from the scheduling profile.
{
{ DESIGN:
{   This module mainly provides the framework for the utility.  It
{   contains the PDTs and code for the subutility and it's subcommands.
{
{ NOTES:
{   Most of the work of creating, deleting, changing, and displaying is
{   done in routines which are generalized to handle all types of objects.
{   These routines can be found in the modules JMM$ADMINISTER_DISPLAY and
{   JMM$ADMINISTER_OBJECTS.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$maximum_job_count
*copyc jmt$application_attributes
?? POP ??
*copyc clp$begin_utility
*copyc clp$get_value
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$include_file
*copyc clp$evaluate_parameters
*copyc jmp$add_object
*copyc jmp$change_object
*copyc jmp$delete_object
*copyc jmp$get_attributes
*copyc jmp$get_object_list
*copyc jmp$set_default_attributes

*copyc jmv$current_profile_level
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    command_file: amt$local_file_name := clc$current_command_input,
    utility_name: string (31) := 'ADMINISTER_APPLICATION         ',
    utility_attributes: array [1 .. 2] of clt$utility_attribute :=
          [[clc$utility_command_table, * ], [clc$utility_prompt, [2, 'AA']]];

{ table command_table
{ command (create_application, crea), jmp$_create_application
{ command (change_attribute, change_attributes, chaa), jmp$_change_attribute
{ command (display_attribute, display_attributes, disa), ..
{   jmp$_display_application cm=xref
{ command (delete_application, dela), jmp$_delete_application
{ command (quit, qui), jmp$_quit
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    command_table: [STATIC, READ] ^clt$command_table := ^command_table_entries,

    command_table_entries: [STATIC, READ] array [1 .. 12] of
          clt$command_table_entry := [
          {} ['CHAA                           ', clc$abbreviation_entry,
          clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_change_attribute],
          {} ['CHANGE_ATTRIBUTE               ', clc$nominal_entry,
          clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_change_attribute],
          {} ['CHANGE_ATTRIBUTES              ', clc$alias_entry,
          clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_change_attribute],
          {} ['CREA                           ', clc$abbreviation_entry,
          clc$advertised_entry, 1, clc$automatically_log, clc$linked_call,
          ^jmp$_create_application],
          {} ['CREATE_APPLICATION             ', clc$nominal_entry,
          clc$advertised_entry, 1, clc$automatically_log, clc$linked_call,
          ^jmp$_create_application],
          {} ['DELA                           ', clc$abbreviation_entry,
          clc$advertised_entry, 4, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_application],
          {} ['DELETE_APPLICATION             ', clc$nominal_entry,
          clc$advertised_entry, 4, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_application],
          {} ['DISA                           ', clc$abbreviation_entry,
          clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_display_application],
          {} ['DISPLAY_ATTRIBUTE              ', clc$nominal_entry,
          clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_display_application],
          {} ['DISPLAY_ATTRIBUTES             ', clc$alias_entry,
          clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_display_application],
          {} ['QUI                            ', clc$abbreviation_entry,
          clc$advertised_entry, 5, clc$automatically_log, clc$linked_call,
          ^jmp$_quit],
          {} ['QUIT                           ', clc$nominal_entry,
          clc$advertised_entry, 5, clc$automatically_log, clc$linked_call,
          ^jmp$_quit]];

  PROCEDURE [XREF] jmp$_display_application
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??
?? TITLE := 'jmp$_change_attribute ', EJECT ??

{ PURPOSE:
{   Processes the CHANGE_ATTRIBUTE command.
{
{ DESIGN:
{   Determines the applications to update, fetches the attributes that are
{   changing and updates them.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS.

  PROCEDURE jmp$_change_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adma_chaa) change_attribute (
{   application_name, application_names, an: any of
{       key all keyend
{       list of name
{     anyend = $current_application
{   cyclic_aging_interval, cai: (by_name) any of
{       key default, unspecified keyend
{       integer jmc$lowest_aging_interval..jmc$highest_aging_interval
{     anyend = $optional
{   enable_application_scheduling, eas: (by_name) any of
{       key default keyend
{       boolean
{     anyend = $optional
{   maximum_working_set, maxws: (by_name) any of
{       key default, unlimited, unspecified keyend
{       integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{     anyend = $optional
{   minimum_working_set, minws: (by_name) any of
{       key default, unspecified keyend
{       integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{     anyend = $optional
{   page_aging_interval, pai: (by_name) any of
{       key default, unspecified keyend
{       integer jmc$lowest_aging_interval..jmc$highest_aging_interval
{     anyend = $optional
{   service_class, sc: (by_name) any of
{       key default, unspecified keyend
{       name
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 16] of clt$pdt_parameter_name,
        parameters: array [1 .. 8] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (20),
        recend,
        type2: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type3: 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,
          recend,
        recend,
        type4: 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 .. 3] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type5: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type6: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type7: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type8: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 31, 26, 721], clc$command, 16, 8, 0, 0, 0,
            0, 8, 'OSM$ADMA_CHAA'], [['AN                             ',
            clc$abbreviation_entry, 1], ['APPLICATION_NAME               ',
            clc$nominal_entry, 1], ['APPLICATION_NAMES              ',
            clc$alias_entry, 1], ['CAI                            ',
            clc$abbreviation_entry, 2], ['CYCLIC_AGING_INTERVAL          ',
            clc$nominal_entry, 2], ['EAS                            ',
            clc$abbreviation_entry, 3], ['ENABLE_APPLICATION_SCHEDULING  ',
            clc$nominal_entry, 3], ['MAXIMUM_WORKING_SET            ',
            clc$nominal_entry, 4], ['MAXWS                          ',
            clc$abbreviation_entry, 4], ['MINIMUM_WORKING_SET            ',
            clc$nominal_entry, 5], ['MINWS                          ',
            clc$abbreviation_entry, 5], ['PAGE_AGING_INTERVAL            ',
            clc$nominal_entry, 6], ['PAI                            ',
            clc$abbreviation_entry, 6], ['SC                             ',
            clc$abbreviation_entry, 7], ['SERVICE_CLASS                  ',
            clc$nominal_entry, 7], ['STATUS                         ',
            clc$nominal_entry, 8]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 20],

{ PARAMETER 2

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 121, clc$optional_parameter, 0,
            0],

{ PARAMETER 3

      [7, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [8, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 158, clc$optional_parameter, 0,
            0],

{ PARAMETER 5

      [10, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 121, clc$optional_parameter, 0,
            0],

{ PARAMETER 6

      [12, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 121, clc$optional_parameter, 0,
            0],

{ PARAMETER 7

      [15, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 106, clc$optional_parameter, 0,
            0],

{ PARAMETER 8

      [16, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            '$current_application'],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 81, [[1, 0, clc$keyword_type],
            [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNSPECIFIED                    ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
            jmc$highest_aging_interval, 10]]],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type], FALSE,
            2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 3, [[1, 0, clc$boolean_type]]],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 118, [[1, 0, clc$keyword_type],
            [3], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNLIMITED                      ',
            clc$nominal_entry, clc$normal_usage_entry, 2],
            ['UNSPECIFIED                    ', clc$nominal_entry,
            clc$normal_usage_entry, 3]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
            jmc$highest_working_set_size, 10]]],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 81, [[1, 0, clc$keyword_type],
            [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNSPECIFIED                    ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
            jmc$highest_working_set_size, 10]]],

{ PARAMETER 6

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 81, [[1, 0, clc$keyword_type],
            [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNSPECIFIED                    ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
            jmc$highest_aging_interval, 10]]],

{ PARAMETER 7

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2],
            81, [[1, 0, clc$keyword_type], [2],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNSPECIFIED                    ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 5,
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 8

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$application_name = 1,
      p$cyclic_aging_interval = 2,
      p$enable_application_scheduling = 3,
      p$maximum_working_set = 4,
      p$minimum_working_set = 5,
      p$page_aging_interval = 6,
      p$service_class = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    VAR
      the_attributes: jmt$object_attribute;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_application;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$get_attributes (jmc$profile_application, #SEQ (pdt), ^pvt,
          the_attributes, status);
    IF status.normal THEN
      jmp$change_object (jmc$profile_application,
            pvt [p$application_name].value^, the_attributes, jmc$update,
            status);
    IFEND;

  PROCEND jmp$_change_attribute;
?? TITLE := 'jmp$_create_application ', EJECT ??

{ PURPOSE:
{   Processes the CREATE_APPLICATION command.
{
{ DESIGN:
{   Fetches the default values and adds the specified application to the
{   profile.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS.

  PROCEDURE jmp$_create_application
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adma_crea) create_application (
{   application_name, an: name = $required
{   default_values, dv: (by_name) name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 31, 53, 242], clc$command, 5, 3, 1, 0, 0,
            0, 3, 'OSM$ADMA_CREA'], [['AN                             ',
            clc$abbreviation_entry, 1], ['APPLICATION_NAME               ',
            clc$nominal_entry, 1], ['DEFAULT_VALUES                 ',
            clc$nominal_entry, 2], ['DV                             ',
            clc$abbreviation_entry, 2], ['STATUS                         ',
            clc$nominal_entry, 3]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 5,
            clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$application_name = 1,
      p$default_values = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      the_application: jmt$profile_object_reference,
      the_attributes: jmt$object_attribute;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_application;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$set_default_attributes (jmc$profile_application,
          pvt [p$default_values], the_attributes, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$add_object (jmc$profile_application,
          pvt [p$application_name].value^.name_value, the_attributes,
          the_application, status);

  PROCEND jmp$_create_application;
?? TITLE := 'jmp$_delete_application ', EJECT ??

{ PURPOSE:
{   Processes the DELETE_APPLICATION command.
{
{ DESIGN:
{   Determine the applications to delete and delete them.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS

  PROCEDURE jmp$_delete_application
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adma_dela) delete_application (
{   application_name, application_names, an: list of name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 4] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 32, 29, 487], clc$command, 4, 2, 1, 0, 0,
            0, 2, 'OSM$ADMA_DELA'], [['AN                             ',
            clc$abbreviation_entry, 1], ['APPLICATION_NAME               ',
            clc$nominal_entry, 1], ['APPLICATION_NAMES              ',
            clc$alias_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 2]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 21,
            clc$required_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$application_name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_application;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$delete_object (jmc$profile_application, pvt [p$application_name].
          value^, status);

  PROCEND jmp$_delete_application;
?? TITLE := 'jmp$_quit', EJECT ??

{ PURPOSE:
{   Exits the subutility.
{
{ DESIGN:
{   Terminates the subutility.

  PROCEDURE jmp$_quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adma_qui) quit, qui (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 9, 26, 10, 32, 57, 896], clc$command, 1, 1, 0, 0, 0,
            0, 1, 'OSM$ADMA_QUI'], [['STATUS                         ',
            clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$end_include (utility_name, status);

  PROCEND jmp$_quit;
?? TITLE := '[XDCL, #GATE] jmp$_administer_application', EJECT ??

{ PURPOSE:
{   Starts the ADMINISTER_APPLICATION sub utility.
{
{ DESIGN:
{   Pass the command table to command_language.

  PROCEDURE [XDCL, #GATE] jmp$_administer_application
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adms_adma) administer_application (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 9, 26, 10, 33, 43, 988], clc$command, 1, 1, 0, 0, 0,
            0, 1, 'OSM$ADMS_ADMA'], [['STATUS                         ',
            clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    utility_attributes [1].command_table := command_table;
    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmv$current_profile_level := jmc$profile_application;

    clp$include_file (command_file, '', utility_name, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$end_utility (utility_name, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

  PROCEND jmp$_administer_application;
MODEND jmm$administer_application;
*DECK DECK=JMM$ADMINISTER_ATTRIBUTES EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Scheduling : administer_attributes' ??
MODULE jmm$administer_attributes;

{ PURPOSE:
{   This module contains the routines that manipulate object attributes.
{
{ DESIGN:
{   Attributes of objects are kept in linked n-tuple tree structures.
{   This provides for a way to handle expressions like 'f=((1 3 7) (8 9))'.
{   Routines are provided here to build these attribute lists from the
{   SCL commands, copy and destroy these lists, and to merge them with
{   the defaults in preparation for display.
{
{ NOTES:
{   JMM$ADMINISTER_DISPLAY displays the attribute list.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc jmt$object_attribute
*copyc jmt$profile_data
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_value_table
*copyc jmc$job_management_id
*copyc jmt$object_attribute_index
*copyc jme$object_attribute_errors
*copyc jme$queued_file_conditions
*copyc osd$integer_limits
*copyc oss$job_paged_literal
?? POP ??
*copyc clp$convert_value_to_string
*copyc clp$get_parameter_number
*copyc jmp$get_object
*copyc jmp$internal_error
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc jmv$object_definition
*copyc jmv$object_heap
*copyc jmv$working_storage
*copyc osv$lower_to_upper
?? RIGHT := 79 ??
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    jmv$dispatching_priority_names: [XDCL, READ,
          oss$job_paged_literal] array [1 .. 10] of string (3) :=
          ['P1 ', 'P2 ', 'P3 ', 'P4 ', 'P5 ', 'P6 ', 'P7 ', 'P8 ', 'P9 ',
          'P10'];

?? TITLE := '[XDCL] jmv$modify_display_attributes', EJECT ??

{ PURPOSE:
{   This variable references a utility specifiable procedure which
{   should be called when the display attributes are built.  The
{   procedure has the possibility to update the attributes prior
{   to display.

  VAR
    jmv$modify_display_attributes: [XDCL] ^jmt$modify_display_attributes :=
          NIL;

*copyc jmt$modify_display_attributes
?? TITLE := 'get_item ', EJECT ??

{ PURPOSE:
{   This routine builds an attribute list from an SCL parameter list.
{
{ DESIGN:
{   The routine uses the attribute's definition to determine how to interpret
{   the scl parameter list.  The first level of the attribute definition maps
{   to the parameter level of the command.  The second level of the attribute
{   definition maps to the value set level of a parameter.  The third level of
{   the attribute definition maps to the value element level.  Though the
{   attribute types allow for more levels, since SCL does not support any
{   further nesting, they cannot be used.
{
{ NOTES:
{   See JMM$ADMINISTER_DISPLAY for the routines to display attributes.

  PROCEDURE get_item
    (    data_value: ^clt$data_value;
         attribute_definition: jmt$profile_declaration;
         parameter_name: ost$name;
     VAR attribute: jmt$object_attribute;
     VAR status: ost$status);

?? NEWTITLE := 'wrong_kind_of_value', EJECT ??

    PROCEDURE wrong_kind_of_value;

      VAR
        attribute_name: ost$name,
        kind: string (10);

      CASE attribute_definition.kind OF
      = jmc$number =
        kind := 'INTEGER';
      = jmc$dispatching_priority =
        kind := 'P1 to P10';
      = jmc$name =
        kind := 'NAME';
      = jmc$object =
        kind := jmv$object_definition [attribute_definition.object_kind].
              declaration.name;
      = jmc$file =
        kind := 'FILE';
      = jmc$boolean =
        kind := 'BOOLEAN';
      ELSE
        kind := 'KEYWORD';
      CASEND;

      attribute_name := attribute_definition.name;
      IF parameter_name = attribute_name THEN
        osp$set_status_abnormal (jmc$job_management_id,
              jme$wrong_kind_of_value, kind, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              attribute_name, status);
      ELSE
        osp$set_status_abnormal (jmc$job_management_id,
              jme$wrong_kind_of_subvalue, kind, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              attribute_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              parameter_name, status);
      IFEND;
      EXIT get_item;
    PROCEND wrong_kind_of_value;
?? NEWTITLE := 'check_value_in_range', EJECT ??

    PROCEDURE check_value_in_range;

      IF (attribute.number > attribute_definition.maximum) OR
            (attribute.number < attribute_definition.minimum) THEN
        IF parameter_name = attribute_definition.name THEN
          osp$set_status_abnormal (jmc$job_management_id,
                jme$value_out_of_range, attribute_definition.name, status);
        ELSE
          osp$set_status_abnormal (jmc$job_management_id,
                jme$subvalue_out_of_range, parameter_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                attribute_definition.name, status);
        IFEND;
        EXIT get_item;
      IFEND;
    PROCEND check_value_in_range;

?? OLDTITLE, EJECT ??

    VAR
      count: ost$non_negative_integers,
      empty: boolean,
      i: jmt$object_attribute_index,
      priority_index: ost$positive_integers,
      the_value: ^clt$data_value;

    status.normal := TRUE;
    attribute.kind := jmc$empty;

    IF data_value = NIL THEN
      RETURN;
    IFEND;

    CASE data_value^.kind OF
    = clc$list =
      IF (attribute_definition.kind <> jmc$editable_list) AND
            (attribute_definition.kind <> jmc$list) THEN
        wrong_kind_of_value;
      IFEND;

{ Count the values in the list.

      count := 0;
      the_value := data_value;
      WHILE the_value <> NIL DO
        count := count + 1;
        the_value := the_value^.link;
      WHILEND;

{ Build the attribute list and call get_item to get each attribute in the list.

      attribute.kind := attribute_definition.kind;
      NEXT attribute.attribute_list: [1 .. count] IN jmv$working_storage;
      IF attribute.attribute_list = NIL THEN
        jmp$internal_error (20);
      IFEND;
      empty := TRUE;
      the_value := data_value;
      FOR i := 1 TO count DO
        attribute.attribute_list^ [i].kind := jmc$empty;
        get_item (the_value^.element_value,
              attribute_definition.declarations^ [1]^, parameter_name,
              attribute.attribute_list^ [i], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        the_value := the_value^.link;
        empty := empty AND (attribute.attribute_list^ [i].kind = jmc$empty);
      FOREND;

{ If each attribute in the list is empty then change the list to empty.

      IF empty THEN
        attribute.kind := jmc$empty;
      IFEND;

    = clc$record =
      IF attribute_definition.kind <> jmc$type THEN
        wrong_kind_of_value;
      IFEND;

{ Count the values in the list.

      count := attribute_definition.count;

{ Build the attribute list and call get_item to get each attribute in the type.

      attribute.kind := attribute_definition.kind;
      NEXT attribute.attribute_list: [1 .. count] IN jmv$working_storage;
      IF attribute.attribute_list = NIL THEN
        jmp$internal_error (20);
      IFEND;
      empty := TRUE;
      FOR i := 1 TO count DO
        attribute.attribute_list^ [i].kind := jmc$empty;
        get_item (data_value^.field_values^ [i].value,
              attribute_definition.declarations^ [i]^, parameter_name,
              attribute.attribute_list^ [i], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        empty := empty AND (attribute.attribute_list^ [i].kind = jmc$empty);
      FOREND;

{ If each attribute in the list is empty then change the list to empty.

      IF empty THEN
        attribute.kind := jmc$empty;
      IFEND;

    = clc$range =
      IF attribute_definition.kind <> jmc$range THEN
        wrong_kind_of_value;
      IFEND;

{ Process values like a..b.

      attribute.kind := attribute_definition.kind;
      NEXT attribute.attribute_list: [1 .. 2] IN jmv$working_storage;
      IF attribute.attribute_list = NIL THEN
        jmp$internal_error (21);
      IFEND;
      attribute.attribute_list^ [1].kind := jmc$empty;
      attribute.attribute_list^ [2].kind := jmc$empty;
      get_item (data_value^.low_value, attribute_definition.declarations^ [1]^,
            parameter_name, attribute.attribute_list^ [1], status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Get the second item only if it really exists.

      IF data_value^.low_value <> data_value^.high_value THEN
        get_item (data_value^.high_value, attribute_definition.
              declarations^ [1]^, parameter_name, attribute.
              attribute_list^ [2], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

{ If no values were given then make the attribute empty.

      IF (attribute.attribute_list^ [1].kind = jmc$empty) AND
            (attribute.attribute_list^ [2].kind = jmc$empty) THEN
        attribute.kind := jmc$empty;
      IFEND;

{ Verify that the scl value is consistant with the attribute being processed.

    = clc$unspecified =
      attribute.kind := jmc$empty;

    = clc$keyword =

      IF data_value^.keyword_value = 'DEFAULT' THEN
        attribute.kind := jmc$default;

      ELSEIF data_value^.keyword_value = 'UNLIMITED' THEN
        attribute.kind := jmc$unlimited;

      ELSEIF data_value^.keyword_value = 'UNSPECIFIED' THEN
        attribute.kind := jmc$unspecified;

      ELSEIF data_value^.keyword_value = 'SYSTEM_DEFAULT' THEN
        attribute.kind := jmc$system_default;

      ELSEIF data_value^.keyword_value = 'ALL' THEN
        attribute.kind := jmc$all;

      ELSEIF data_value^.keyword_value = 'NONE' THEN
        attribute.kind := jmc$none;

      ELSEIF attribute_definition.kind = jmc$name THEN
        attribute.kind := jmc$name;
        NEXT attribute.name IN jmv$working_storage;
        IF attribute.name = NIL THEN
          jmp$internal_error (23);
        IFEND;
        attribute.name^ := data_value^.keyword_value;

      ELSEIF attribute_definition.kind = jmc$dispatching_priority THEN
        attribute.kind := jmc$empty;

      /get_dispatching_priority_index/
        FOR priority_index := LOWERBOUND (jmv$dispatching_priority_names)
              TO UPPERBOUND (jmv$dispatching_priority_names) DO
          IF jmv$dispatching_priority_names [priority_index] =
                data_value^.name_value THEN
            attribute.kind := jmc$dispatching_priority;
            attribute.number := priority_index;
            EXIT /get_dispatching_priority_index/;
          IFEND;
        FOREND /get_dispatching_priority_index/;

        IF attribute.kind = jmc$empty THEN
          wrong_kind_of_value;
        IFEND;
        check_value_in_range;

      ELSE
        wrong_kind_of_value;

      IFEND;

    = clc$name =
      CASE attribute_definition.kind OF

      = jmc$name =
        attribute.kind := jmc$name;
        NEXT attribute.name IN jmv$working_storage;
        IF attribute.name = NIL THEN
          jmp$internal_error (23);
        IFEND;
        attribute.name^ := data_value^.name_value;

      = jmc$object =
        get_object (data_value^, attribute_definition, attribute, status);

      = jmc$boolean =
        attribute.kind := jmc$empty;

        IF (data_value^.name_value = 'TRUE') OR
              (data_value^.name_value = 'YES') OR (data_value^.name_value =
              'ON') THEN
          attribute.kind := jmc$boolean;
          attribute.bool := TRUE;
        ELSEIF (data_value^.name_value = 'FALSE') OR (data_value^.name_value =
              'NO') OR (data_value^.name_value = 'OFF') THEN
          attribute.kind := jmc$boolean;
          attribute.bool := FALSE;
        ELSE
          wrong_kind_of_value;
        IFEND;

      ELSE
        wrong_kind_of_value;
      CASEND;

    = clc$file =
      IF attribute_definition.kind <> jmc$file THEN
        wrong_kind_of_value;
      IFEND;
      attribute.kind := jmc$file;
      NEXT attribute.file: [STRLENGTH (data_value^.file_value^)] IN
            jmv$working_storage;
      IF attribute.file = NIL THEN
        jmp$internal_error (22);
      IFEND;
      attribute.file^ := data_value^.file_value^;

    = clc$integer =
      IF (attribute_definition.kind <> jmc$number) AND
            (attribute_definition.kind <> jmc$dispatching_priority) THEN
        wrong_kind_of_value;
      IFEND;
      attribute.kind := attribute_definition.kind;
      attribute.number := data_value^.integer_value.value;
      check_value_in_range;

    = clc$boolean =
      IF attribute_definition.kind <> jmc$boolean THEN
        wrong_kind_of_value;
      IFEND;
      attribute.kind := jmc$boolean;
      attribute.bool := data_value^.boolean_value.value;

    ELSE
      wrong_kind_of_value;
    CASEND;
  PROCEND get_item;
?? TITLE := 'get_object', EJECT ??

{ PURPOSE:
{   convert the scl parameter into an object reference.
{
{ DESIGN:
{   Search for an object of the appropriate type with the specified
{   name.  If it is found, build an object reference to it.

  PROCEDURE get_object
    (    object_name: clt$data_value;
         attribute_definition: jmt$profile_declaration;
     VAR attribute: jmt$object_attribute;
     VAR status: ost$status);

    VAR
      ignore: jmt$profile_object_reference;

    status.normal := TRUE;
    attribute.kind := jmc$object;
    jmp$get_object (object_name.name_value, attribute_definition.object_kind,
          attribute.object_p, ignore, status);
    IF NOT status.normal THEN
      attribute.kind := jmc$empty;
    IFEND;

  PROCEND get_object;
?? TITLE := '[XDCL] jmp$copy_attributes', EJECT ??

{ PURPOSE:
{   This routine copies an attribute structure.
{
{ DESIGN:
{   This routine makes a copy of the current level of the attribute structure
{   and calls itself recursively to copy lower levels.
{
{ NOTES:
{   When object references are copied, the referenced object's reference
{   counts are incremented.  New allocations are made for file and
{   name references.

  PROCEDURE [XDCL] jmp$copy_attributes
    (    old_attributes: jmt$object_attribute;
     VAR new_attributes: jmt$object_attribute);

    VAR
      i: jmt$object_attribute_index;

    new_attributes := old_attributes;
    CASE old_attributes.kind OF
    = jmc$list, jmc$type, jmc$range, jmc$editable_list =
      ALLOCATE new_attributes.attribute_list:
            [1 .. UPPERBOUND (old_attributes.attribute_list^)] IN
            jmv$object_heap^;
      IF new_attributes.attribute_list = NIL THEN
        jmp$internal_error (25);
      IFEND;
      FOR i := 1 TO UPPERBOUND (old_attributes.attribute_list^) DO
        jmp$copy_attributes (old_attributes.attribute_list^ [i],
              new_attributes.attribute_list^ [i]);
      FOREND;
    = jmc$object =
      new_attributes.object_p^.references :=
            new_attributes.object_p^.references + 1;
    = jmc$file =
      ALLOCATE new_attributes.file: [STRLENGTH (old_attributes.file^)] IN
            jmv$object_heap^;
      IF new_attributes.file = NIL THEN
        jmp$internal_error (26);
      IFEND;
      new_attributes.file^ := old_attributes.file^;
    = jmc$name =
      ALLOCATE new_attributes.name IN jmv$object_heap^;
      IF new_attributes.name = NIL THEN
        jmp$internal_error (27);
      IFEND;
      new_attributes.name^ := old_attributes.name^;
    ELSE

{ Do nothing.

    CASEND;

  PROCEND jmp$copy_attributes;
?? TITLE := '[XDCL] jmp$delete_attributes', EJECT ??

{ PURPOSE:
{   This routine deletes an attribute structure.
{
{ DESIGN:
{   This routine first deletes the lower levels of the attribute structure
{   by calling itself recursively and then deletes the current level.
{
{ NOTES:
{   When object references are deleted, the referenced object's reference
{   counts are decremented.  File and name structures are freed.

  PROCEDURE [XDCL] jmp$delete_attributes
    (VAR object_attributes: jmt$object_attribute);

    VAR
      i: jmt$object_attribute_index;

    CASE object_attributes.kind OF
    = jmc$list, jmc$type, jmc$range, jmc$editable_list =
      FOR i := 1 TO UPPERBOUND (object_attributes.attribute_list^) DO
        jmp$delete_attributes (object_attributes.attribute_list^ [i]);
      FOREND;
      FREE object_attributes.attribute_list IN jmv$object_heap^;
    = jmc$object =
      object_attributes.object_p^.references :=
            object_attributes.object_p^.references - 1;
      object_attributes.object_p := NIL;
    = jmc$file =
      FREE object_attributes.file IN jmv$object_heap^;
    = jmc$name =
      FREE object_attributes.name IN jmv$object_heap^;
    ELSE
    CASEND;
    object_attributes.kind := jmc$empty;

  PROCEND jmp$delete_attributes;
?? TITLE := '[XDCL, #GATE] jmp$get_attributes', EJECT ??

{ PURPOSE:
{   This interface gets the attributes for an object from an SCL command
{   list of a command.
{
{ DESIGN:
{   The routine locates the definition of the attributes and calls a lower
{   level routine to actually build the attribute list.
{
{ NOTES:
{   JMV$WORKING_STORAGE is reset since this marks the beginning of a command
{   and it may be used by get_item.

  PROCEDURE [XDCL, #GATE] jmp$get_attributes
    (    the_kind: jmt$profile_object_kinds;
         parameter_description_table: ^clt$parameter_description_table;
         parameter_value_table: ^clt$parameter_value_table;
     VAR the_attributes: jmt$object_attribute;
     VAR status: ost$status);

    VAR
      attribute: jmt$object_attribute,
      attribute_definition: jmt$profile_declaration,
      empty: boolean,
      i: jmt$object_attribute_index,
      parameter_name: ost$name,
      parameter_number: clt$parameter_number;

    status.normal := TRUE;
    RESET jmv$working_storage;
    the_attributes.kind := jmc$empty;

    attribute_definition := jmv$object_definition [the_kind].declaration;
    attribute.kind := attribute_definition.kind;
    NEXT attribute.attribute_list: [1 .. attribute_definition.count] IN
          jmv$working_storage;
    IF attribute.attribute_list = NIL THEN
      jmp$internal_error (20);
    IFEND;

    empty := TRUE;
    FOR i := 1 TO attribute_definition.count DO
      attribute.attribute_list^ [i].kind := jmc$empty;
      #TRANSLATE (osv$lower_to_upper, attribute_definition.declarations^ [i]^.
            name, parameter_name);
      clp$get_parameter_number (parameter_description_table, parameter_name,
            parameter_number, status);
      IF status.normal THEN
        get_item (parameter_value_table^ [parameter_number].value,
              attribute_definition.declarations^ [i]^,
              attribute_definition.declarations^ [i]^.name,
              attribute.attribute_list^ [i], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      status.normal := TRUE;
      empty := empty AND (attribute.attribute_list^ [i].kind = jmc$empty);
    FOREND;

    IF NOT empty THEN
      the_attributes := attribute;
    IFEND;

  PROCEND jmp$get_attributes;
?? TITLE := '[XDCL, #GATE] jmp$get_attributes_for_display', EJECT ??

{ PURPOSE:
{   This interface builds an attribute list that is displayable from the
{   attribute list of the specified object.
{
{   The displayable attribute list includes
{   o the attributes given by in the object's attribute list;
{   o the attributes from the default attribute list for this object kind
{     for those attributes not specified in the object's attribute list.
{
{ DESIGN:
{   The routine scans the attribute list building a copy which uses the
{   information from the original attribute list when provided and
{   information from the default attribute list when not provided.
{
{   If a routine has been provided to do additional processing of the
{   attributes, it is called.

  PROCEDURE [XDCL, #GATE] jmp$get_attributes_for_display
    (    profile: jmt$profile_data;
         the_object: jmt$profile_object;
     VAR displayable_attributes: jmt$object_attribute;
     VAR status: ost$status);

?? NEWTITLE := 'form_merged_list', EJECT ??

{ PURPOSE:
{   This routine edits the default list with the editing directions in
{   the attribute.  This editing list is a list of type where the first
{   element in the type is a range.  This range specifies the range of
{   values for which the remaining elements of the type apply.
{
{ DESIGN:
{   The editing list is applied to the default list though, rather than
{   replacing sections of the default list with the editing list, they
{   are merged to satisfy defaults.  Adjoining ranges which result in the
{   same results are combined into a larger range.

    PROCEDURE form_merged_list
      (    original: jmt$object_attribute;
           default: jmt$object_attribute;
       VAR result: jmt$object_attribute);

      TYPE
        item = record
          upper: integer,
          lower: integer,
          attribute: jmt$object_attribute,
          next_item: ^item,
        recend;

      VAR
        an_item: ^item,
        attribute_a: jmt$object_attribute,
        attribute_b: jmt$object_attribute,
        i: integer,
        items: integer,
        matches: boolean,
        new_item: ^item,
        pair: ^jmt$object_attribute_list,
        previous_item: ^item,
        result_list: ^jmt$object_attribute_list,
        top_item: ^item;

{ setup

      top_item := NIL;
      items := 0;

{ unpack default attribute list

      FOR i := UPPERBOUND (default.attribute_list^) DOWNTO 1 DO
        PUSH new_item;
        merge_with_defaults (default.attribute_list^ [i],
              default.attribute_list^ [i], new_item^.attribute);
        pair := new_item^.attribute.attribute_list^ [1].attribute_list;
        new_item^.lower := pair^ [1].number;
        new_item^.upper := new_item^.lower;
        IF pair^ [2].kind <> jmc$empty THEN
          new_item^.upper := pair^ [2].number;
        IFEND;
        new_item^.next_item := top_item;
        top_item := new_item;
        items := items + 1;
      FOREND;

{ unpack editing attribute list

      an_item := top_item;
      previous_item := NIL;
      FOR i := 1 TO UPPERBOUND (original.attribute_list^) DO
        PUSH new_item;
        new_item^.attribute := original.attribute_list^ [i];
        pair := new_item^.attribute.attribute_list^ [1].attribute_list;
        new_item^.lower := pair^ [1].number;
        new_item^.upper := new_item^.lower;
        IF pair^ [2].kind <> jmc$empty THEN
          new_item^.upper := pair^ [2].number;
        IFEND;
        WHILE an_item^.upper < new_item^.lower DO
          previous_item := an_item;
          an_item := an_item^.next_item;
        WHILEND;
        IF an_item^.lower < new_item^.lower THEN
          previous_item := an_item;
          PUSH an_item;
          an_item^ := previous_item^;
          previous_item^.next_item := an_item;
          previous_item^.upper := new_item^.lower - 1;
          an_item^.lower := new_item^.lower;
          merge_with_defaults (previous_item^.attribute,
                previous_item^.attribute, an_item^.attribute);
          items := items + 1;
        IFEND;
        WHILE (an_item <> NIL) AND (an_item^.upper <= new_item^.upper) DO
          merge_with_defaults (new_item^.attribute, an_item^.attribute,
                an_item^.attribute);
          previous_item := an_item;
          an_item := an_item^.next_item;
        WHILEND;
        IF (an_item <> NIL) AND (an_item^.lower <= new_item^.upper) THEN
          an_item^.lower := new_item^.upper + 1;
          new_item^.next_item := an_item;
          merge_with_defaults (new_item^.attribute, an_item^.attribute,
                new_item^.attribute);
          IF previous_item = NIL THEN
            top_item := new_item;
          ELSE
            previous_item^.next_item := new_item;
          IFEND;
          previous_item := new_item;
          items := items + 1;
        IFEND;
      FOREND;

{ Remove duplicate items from list

      previous_item := top_item;
      an_item := previous_item^.next_item;

    /remove_duplicates/
      WHILE an_item <> NIL DO
        FOR i := 2 TO UPPERBOUND (previous_item^.attribute.attribute_list^) DO
          attribute_a := previous_item^.attribute.attribute_list^ [i];
          attribute_b := an_item^.attribute.attribute_list^ [i];
          CASE attribute_a.kind OF
          = jmc$number, jmc$dispatching_priority =
            matches := attribute_a.number = attribute_b.number;
          = jmc$boolean =
            matches := attribute_a.bool = attribute_b.bool;
          = jmc$file =
            matches := attribute_a.file^ = attribute_b.file^;
          = jmc$name =
            matches := attribute_a.name^ = attribute_b.name^;
          = jmc$object =
            matches := attribute_a.object_p = attribute_b.object_p;
          ELSE
            matches := FALSE
          CASEND;
          IF NOT matches THEN
            previous_item := an_item;
            an_item := an_item^.next_item;
            CYCLE /remove_duplicates/;
          IFEND;
        FOREND;
        previous_item^.next_item := an_item^.next_item;
        previous_item^.upper := an_item^.upper;
        items := items - 1;
        an_item := an_item^.next_item;
      WHILEND /remove_duplicates/;

{ Build result

      result.kind := jmc$editable_list;
      NEXT result.attribute_list: [1 .. items] IN jmv$working_storage;
      FOR i := 1 TO items DO
        result.attribute_list^ [i] := top_item^.attribute;
        pair := top_item^.attribute.attribute_list^ [1].attribute_list;
        pair^ [1].number := top_item^.lower;
        IF top_item^.lower = top_item^.upper THEN
          pair^ [2].kind := jmc$empty;
        ELSE
          pair^ [2].kind := pair^ [1].kind;
          pair^ [2].number := top_item^.upper;
        IFEND;
        top_item := top_item^.next_item;
      FOREND;
    PROCEND form_merged_list;
?? OLDTITLE ??
?? NEWTITLE := 'merge_with_defaults', EJECT ??

    PROCEDURE merge_with_defaults
      (    original: jmt$object_attribute;
           default: jmt$object_attribute;
       VAR result: jmt$object_attribute);

      VAR
        smaller_array_size: jmt$object_attribute_index,
        desired_array_size: jmt$object_attribute_index,
        i: jmt$object_attribute_index;

      result := original;
      CASE original.kind OF
      = jmc$empty, jmc$default =
        IF original.kind <> default.kind THEN
          merge_with_defaults (default, default, result);
        IFEND;
      = jmc$editable_list =
        form_merged_list (original, default, result);
      = jmc$list, jmc$type =
        desired_array_size := UPPERBOUND (original.attribute_list^);
        NEXT result.attribute_list: [1 .. desired_array_size] IN
              jmv$working_storage;
        IF result.attribute_list = NIL THEN
          jmp$internal_error (28);
        IFEND;
        smaller_array_size := UPPERBOUND (default.attribute_list^);
        IF smaller_array_size > desired_array_size THEN
          smaller_array_size := desired_array_size;
        IFEND;
        FOR i := 1 TO smaller_array_size DO
          merge_with_defaults (original.attribute_list^ [i],
                default.attribute_list^ [i], result.attribute_list^ [i]);
        FOREND;
        FOR i := smaller_array_size + 1 TO desired_array_size DO
          merge_with_defaults (original.attribute_list^ [i],
                default.attribute_list^ [1], result.attribute_list^ [i]);
        FOREND;
      = jmc$range =
        NEXT result.attribute_list: [1 .. 2] IN jmv$working_storage;
        IF result.attribute_list = NIL THEN
          jmp$internal_error (28);
        IFEND;
        merge_with_defaults (original.attribute_list^ [1],
              default.attribute_list^ [1], result.attribute_list^ [1]);
        result.attribute_list^ [2] := original.attribute_list^ [2];
      ELSE
      CASEND;
    PROCEND merge_with_defaults;
?? OLDTITLE, EJECT ??

    VAR
      default_attributes: jmt$object_attribute;

    status.normal := TRUE;

    jmv$object_definition [the_object.kind].
          fetch_attribute_defaults^ (profile, the_object, default_attributes);
    merge_with_defaults (the_object.attributes, default_attributes,
          displayable_attributes);

    IF jmv$modify_display_attributes <> NIL THEN
      jmv$modify_display_attributes^ (the_object, displayable_attributes,
            status);
    IFEND;

  PROCEND jmp$get_attributes_for_display;
?? TITLE := '[XDCL, #GATE] jmp$set_default_attributes', EJECT ??

{ PURPOSE:
{   This interface sets the default values of an object when first created.
{
{ DESIGN:
{   The routine checks for the 'DEFAULT_VALUES' parameter and if specified
{   it searches for an object with the specified name.

  PROCEDURE [XDCL, #GATE] jmp$set_default_attributes
    (    the_kind: jmt$profile_object_kinds;
         default_value: clt$parameter_value;
     VAR the_attributes: jmt$object_attribute;
     VAR status: ost$status);

    VAR
      ignore: jmt$profile_object_reference,
      the_object: jmt$profile_object_reference;

    status.normal := TRUE;
    the_attributes.kind := jmc$empty;

    IF NOT default_value.specified THEN
      RETURN;
    IFEND;

    jmp$get_object (default_value.value^.name_value, the_kind, the_object,
          ignore, status);
    IF status.normal THEN
      the_attributes := the_object^.attributes;
    IFEND;

  PROCEND jmp$set_default_attributes;
MODEND jmm$administer_attributes;

*DECK DECK=JMM$ADMINISTER_CONTROLS EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Scheduling : Controls Administration' ??
MODULE jmm$administer_controls;

{ PURPOSE:
{   This module defines the commands that make up the subutility of
{   ADMINISTER_SCHEDULING called ADMINISTER_CONTROLS.  This utility
{   manages the global controls for one or more mainframes on the
{   scheduling profile.  The procedures in this module allow the
{   administrator to create, change, delete or display a set of
{   controls for a mainframe on/from the scheduling profile.
{
{ DESIGN:
{   This module mainly provides the framework for the utility.  It
{   contains the PDTs and code for the subutility and it's subcommands.
{
{ NOTES:
{   Most of the work of creating, deleting, changing, and displaying is
{   done in routines which are generalized to handle all types of objects.
{   These routines can be found in the modules JMM$ADMINISTER_DISPLAY and
{   JMM$ADMINISTER_OBJECTS.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_scheduler_table
?? POP ??
*copyc clp$begin_utility
*copyc clp$end_utility
*copyc clp$end_scan_command_file
*copyc clp$include_file
*copyc clp$evaluate_parameters
*copyc jmp$add_object
*copyc jmp$change_object
*copyc jmp$delete_object
*copyc jmp$get_attributes
*copyc jmp$set_default_attributes

*copyc jmv$current_profile_level

  CONST
    milliseconds_per_second = 1000,
    microseconds_per_second = milliseconds_per_second * 1000;

  CONST
    lowest_idle_disp_q_time = jmc$lowest_idle_disp_q_time DIV
          microseconds_per_second,
    highest_idle_disp_q_time = jmc$highest_idle_disp_q_time DIV
          microseconds_per_second;

  VAR
    command_file: amt$local_file_name := clc$current_command_input,
    utility_name: string (31) := 'ADMINISTER_CONTROLS            ',
    utility_attributes: array [1 .. 2] of clt$utility_attribute :=
          [[clc$utility_command_table, * ], [clc$utility_prompt, [2, 'AC']]];

{ table command_table
{ command (add_job_category_entry add_job_category_entries addjce) ..
{   jmp$_add_job_category_entry
{ command (create_controls crec) jmp$_create_controls
{ command (change_attribute change_attributes chaa) jmp$_change_attribute
{ command (display_attribute display_attributes disa) jmp$_display_controls ..
{   cm=xref
{ command (delete_controls delc) jmp$_delete_controls
{ command (quit qui) jmp$_quit
{ command (delete_job_category_entry delete_job_category_entries deljce) ..
{   jmp$_delete_job_category_entry
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    command_table: [STATIC, READ] ^clt$command_table := ^command_table_entries,

    command_table_entries: [STATIC, READ] array [1 .. 18] of
          clt$command_table_entry := [
          {} ['ADDJCE                         ', clc$abbreviation_entry,
          clc$advertised_entry, 1, clc$automatically_log, clc$linked_call,
          ^jmp$_add_job_category_entry],
          {} ['ADD_JOB_CATEGORY_ENTRIES       ', clc$alias_entry,
          clc$advertised_entry, 1, clc$automatically_log, clc$linked_call,
          ^jmp$_add_job_category_entry],
          {} ['ADD_JOB_CATEGORY_ENTRY         ', clc$nominal_entry,
          clc$advertised_entry, 1, clc$automatically_log, clc$linked_call,
          ^jmp$_add_job_category_entry],
          {} ['CHAA                           ', clc$abbreviation_entry,
          clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_change_attribute],
          {} ['CHANGE_ATTRIBUTE               ', clc$nominal_entry,
          clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_change_attribute],
          {} ['CHANGE_ATTRIBUTES              ', clc$alias_entry,
          clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_change_attribute],
          {} ['CREATE_CONTROLS                ', clc$nominal_entry,
          clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_create_controls],
          {} ['CREC                           ', clc$abbreviation_entry,
          clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_create_controls],
          {} ['DELC                           ', clc$abbreviation_entry,
          clc$advertised_entry, 5, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_controls],
          {} ['DELETE_CONTROLS                ', clc$nominal_entry,
          clc$advertised_entry, 5, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_controls],
          {} ['DELETE_JOB_CATEGORY_ENTRIES    ', clc$alias_entry,
          clc$advertised_entry, 7, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_job_category_entry],
          {} ['DELETE_JOB_CATEGORY_ENTRY      ', clc$nominal_entry,
          clc$advertised_entry, 7, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_job_category_entry],
          {} ['DELJCE                         ', clc$abbreviation_entry,
          clc$advertised_entry, 7, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_job_category_entry],
          {} ['DISA                           ', clc$abbreviation_entry,
          clc$advertised_entry, 4, clc$automatically_log, clc$linked_call,
          ^jmp$_display_controls],
          {} ['DISPLAY_ATTRIBUTE              ', clc$nominal_entry,
          clc$advertised_entry, 4, clc$automatically_log, clc$linked_call,
          ^jmp$_display_controls],
          {} ['DISPLAY_ATTRIBUTES             ', clc$alias_entry,
          clc$advertised_entry, 4, clc$automatically_log, clc$linked_call,
          ^jmp$_display_controls],
          {} ['QUI                            ', clc$abbreviation_entry,
          clc$advertised_entry, 6, clc$automatically_log, clc$linked_call,
          ^jmp$_quit],
          {} ['QUIT                           ', clc$nominal_entry,
          clc$advertised_entry, 6, clc$automatically_log, clc$linked_call,
          ^jmp$_quit]];

  PROCEDURE [XREF] jmp$_display_controls
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??
?? TITLE := 'jmp$_add_job_category_entry ', EJECT ??

{ PURPOSE:
{   Processes the ADD_JOB_CATEGORY_ENTRY command.
{
{ DESIGN:
{   Determines the controls to update, fetches the job categories to add
{   as an attribute list and updates the controls.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS.

  PROCEDURE jmp$_add_job_category_entry
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admc_addjce) add_job_category_entry (
{   mainframe_name, mainframe_names, mn, ..
{     controls_name, controls_names, cn: any of
{       key all keyend
{       list of name
{     anyend = $current_mainframe
{   initiation_excluded_categories, iec: (by_name) any of
{       key all keyend
{       list of name
{     anyend = $optional
{   initiation_required_categories, irc: (by_name) any of
{       key all keyend
{       list of name
{     anyend = $optional
{   validation_excluded_categories, vec: (by_name) any of
{       key all keyend
{       list of name
{     anyend = $optional
{   validation_required_categories, vrc: (by_name) any of
{       key all keyend
{       list of name
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 15] of clt$pdt_parameter_name,
        parameters: array [1 .. 6] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (18),
        recend,
        type2: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type3: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type4: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type5: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type6: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 27, 11, 554], clc$command, 15, 6, 0, 0, 0,
            0, 6, 'OSM$ADMC_ADDJCE'], [['CN                             ',
            clc$abbreviation_entry, 1], ['CONTROLS_NAME                  ',
            clc$alias_entry, 1], ['CONTROLS_NAMES                 ',
            clc$alias_entry, 1], ['IEC                            ',
            clc$abbreviation_entry, 2], ['INITIATION_EXCLUDED_CATEGORIES ',
            clc$nominal_entry, 2], ['INITIATION_REQUIRED_CATEGORIES ',
            clc$nominal_entry, 3], ['IRC                            ',
            clc$abbreviation_entry, 3], ['MAINFRAME_NAME                 ',
            clc$nominal_entry, 1], ['MAINFRAME_NAMES                ',
            clc$alias_entry, 1], ['MN                             ',
            clc$alias_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 6], ['VALIDATION_EXCLUDED_CATEGORIES ',
            clc$nominal_entry, 4], ['VALIDATION_REQUIRED_CATEGORIES ',
            clc$nominal_entry, 5], ['VEC                            ',
            clc$abbreviation_entry, 4], ['VRC                            ',
            clc$abbreviation_entry, 5]], [

{ PARAMETER 1

      [8, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 18],

{ PARAMETER 2

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [6, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [12, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [13, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [11, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            '$current_mainframe'],

{ PARAMETER 2

      [[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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 3

      [[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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 4

      [[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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 5

      [[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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 6

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$mainframe_name = 1,
      p$initiation_excluded_categorie = 2 {INITIATION_EXCLUDED_CATEGORIES} ,
      p$initiation_required_categorie = 3 {INITIATION_REQUIRED_CATEGORIES} ,
      p$validation_excluded_categorie = 4 {VALIDATION_EXCLUDED_CATEGORIES} ,
      p$validation_required_categorie = 5 {VALIDATION_REQUIRED_CATEGORIES} ,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      the_attributes: jmt$object_attribute;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$get_attributes (jmc$profile_controls, #SEQ (pdt), ^pvt, the_attributes,
          status);
    IF status.normal THEN
      jmp$change_object (jmc$profile_controls, pvt [p$mainframe_name].value^,
            the_attributes, jmc$add_list_items, status);
    IFEND;

  PROCEND jmp$_add_job_category_entry;
?? TITLE := 'jmp$_change_attribute ', EJECT ??

{ PURPOSE:
{   Processes the CHANGE_ATTRIBUTE command.
{
{ DESIGN:
{   Determines the controls to update, fetches the attributes that are
{   changing and updates them.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS.

  PROCEDURE jmp$_change_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admc_chaa) change_attribute (
{   mainframe_name, mainframe_names, mn, ..
{     controls_name, controls_names, cn: any of
{       key all keyend
{       list of name
{     anyend = $current_mainframe
{   abbreviation, a: (by_name) any of
{       key default none keyend
{       name
{     anyend = $optional
{   cpu_dispatching_allocation, cda: (by_name) any of
{       key default keyend
{       list 1..8 of record
{         dispatching_priority: range of any of
{           integer 1..8
{           key p1 p2 p3 p4 p5 p6 p7 p8 keyend
{         anyend
{         minimum_percent: any of
{           key default keyend
{           integer 0..100
{         anyend = $optional
{         maximum_percent: any of
{           key default keyend
{           integer 0..100
{         anyend = $optional
{         enforce_maximum: any of
{           key default keyend
{           boolean
{         anyend = $optional
{       recend
{     anyend = $optional
{   cpu_dispatching_interval, cdi: (by_name) any of
{       key default keyend
{       integer 1..600
{     anyend = $optional
{   cpu_quantum_time, cqt: (by_name) any of
{       key default keyend
{       integer 1000..100000
{     anyend = $optional
{   dual_state_priority_control, dspc: (by_name) any of
{       key default keyend
{       list 1..10 of record
{         dispatching_priority: range of any of
{           integer 1..10
{           key p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 keyend
{         anyend
{         dual_state_priority: any of
{           key default keyend
{           integer 1..10
{         anyend = $optional
{         subpriority: any of
{           key default keyend
{           integer 1..15
{         anyend = $optional
{       recend
{     anyend = $optional
{   enable_job_leveling, ejl: (by_name) any of
{       key default keyend
{       boolean
{     anyend = $optional
{   idle_dispatching_queue_time, idqt: (by_name) any of
{       key default, unlimited keyend
{       integer lowest_idle_disp_q_time..highest_idle_disp_q_time
{     anyend = $optional
{   initiation_excluded_categories, iec: (by_name) any of
{       key default, all, none keyend
{       list of name
{     anyend = $optional
{   initiation_required_categories, irc: (by_name) any of
{       key default, all, none keyend
{       list of name
{     anyend = $optional
{   job_leveling_interval, jli: (by_name) any of
{       key default keyend
{       integer jmc$lowest_service_interval..jmc$highest_service_interval
{     anyend = $optional
{   job_leveling_priority_bias, jlpb: (by_name) any of
{       key default keyend
{       integer jmc$lowest_priority_bias..jmc$highest_priority_bias
{     anyend = $optional
{   scheduling_memory_levels, sml: (by_name) any of
{       key default keyend
{       record
{         target: any of
{           key default keyend
{         integer jmc$lowest_sched_memory_level..jmc$highest_sched_memory_level
{         anyend = $optional
{         thrashing: any of
{           key default keyend
{         integer jmc$lowest_sched_memory_level..jmc$highest_sched_memory_level
{         anyend = $optional
{       recend
{     anyend = $optional
{   service_calculation_interval, sci: (by_name) any of
{       key default keyend
{       integer jmc$lowest_service_interval..jmc$highest_service_interval
{     anyend = $optional
{   validation_excluded_categories, vec: (by_name) any of
{       key default, all, none keyend
{       list of name
{     anyend = $optional
{   validation_required_categories, vrc: (by_name) any of
{       key default, all, none keyend
{       list of name
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 37] of clt$pdt_parameter_name,
      parameters: array [1 .. 17] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (18),
      recend,
      type2: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type3: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: record
              header: clt$type_specification_header,
              qualifier: clt$range_type_qualifier,
              element_type_spec: 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$integer_type_qualifier,
                recend,
                type_size_2: clt$type_specification_size,
                element_type_spec_2: record
                  header: clt$type_specification_header,
                  qualifier: clt$keyword_type_qualifier,
                  keyword_specs: array [1 .. 8] of clt$keyword_specification,
                recend,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_3: clt$field_specification,
            element_type_spec_3: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_4: clt$field_specification,
            element_type_spec_4: 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,
              recend,
            recend,
          recend,
        recend,
      recend,
      type4: 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$integer_type_qualifier,
        recend,
      recend,
      type5: 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$integer_type_qualifier,
        recend,
      recend,
      type6: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: record
              header: clt$type_specification_header,
              qualifier: clt$range_type_qualifier,
              element_type_spec: 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$integer_type_qualifier,
                recend,
                type_size_2: clt$type_specification_size,
                element_type_spec_2: record
                  header: clt$type_specification_header,
                  qualifier: clt$keyword_type_qualifier,
                  keyword_specs: array [1 .. 10] of clt$keyword_specification,
                recend,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_3: clt$field_specification,
            element_type_spec_3: 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$integer_type_qualifier,
              recend,
            recend,
          recend,
        recend,
      recend,
      type7: 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,
        recend,
      recend,
      type8: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type9: 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 .. 3] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type10: 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 .. 3] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type11: 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$integer_type_qualifier,
        recend,
      recend,
      type12: 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$integer_type_qualifier,
        recend,
      recend,
      type13: 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$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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$integer_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type14: 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$integer_type_qualifier,
        recend,
      recend,
      type15: 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 .. 3] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type16: 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 .. 3] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type17: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 2, 15, 15, 35, 26, 603],
    clc$command, 37, 17, 0, 0, 0, 0, 17, 'OSM$ADMC_CHAA'], [
    ['A                              ',clc$abbreviation_entry, 2],
    ['ABBREVIATION                   ',clc$nominal_entry, 2],
    ['CDA                            ',clc$abbreviation_entry, 3],
    ['CDI                            ',clc$abbreviation_entry, 4],
    ['CN                             ',clc$abbreviation_entry, 1],
    ['CONTROLS_NAME                  ',clc$alias_entry, 1],
    ['CONTROLS_NAMES                 ',clc$alias_entry, 1],
    ['CPU_DISPATCHING_ALLOCATION     ',clc$nominal_entry, 3],
    ['CPU_DISPATCHING_INTERVAL       ',clc$nominal_entry, 4],
    ['CPU_QUANTUM_TIME               ',clc$nominal_entry, 5],
    ['CQT                            ',clc$abbreviation_entry, 5],
    ['DSPC                           ',clc$abbreviation_entry, 6],
    ['DUAL_STATE_PRIORITY_CONTROL    ',clc$nominal_entry, 6],
    ['EJL                            ',clc$abbreviation_entry, 7],
    ['ENABLE_JOB_LEVELING            ',clc$nominal_entry, 7],
    ['IDLE_DISPATCHING_QUEUE_TIME    ',clc$nominal_entry, 8],
    ['IDQT                           ',clc$abbreviation_entry, 8],
    ['IEC                            ',clc$abbreviation_entry, 9],
    ['INITIATION_EXCLUDED_CATEGORIES ',clc$nominal_entry, 9],
    ['INITIATION_REQUIRED_CATEGORIES ',clc$nominal_entry, 10],
    ['IRC                            ',clc$abbreviation_entry, 10],
    ['JLI                            ',clc$abbreviation_entry, 11],
    ['JLPB                           ',clc$abbreviation_entry, 12],
    ['JOB_LEVELING_INTERVAL          ',clc$nominal_entry, 11],
    ['JOB_LEVELING_PRIORITY_BIAS     ',clc$nominal_entry, 12],
    ['MAINFRAME_NAME                 ',clc$nominal_entry, 1],
    ['MAINFRAME_NAMES                ',clc$alias_entry, 1],
    ['MN                             ',clc$alias_entry, 1],
    ['SCHEDULING_MEMORY_LEVELS       ',clc$nominal_entry, 13],
    ['SCI                            ',clc$abbreviation_entry, 14],
    ['SERVICE_CALCULATION_INTERVAL   ',clc$nominal_entry, 14],
    ['SML                            ',clc$abbreviation_entry, 13],
    ['STATUS                         ',clc$nominal_entry, 17],
    ['VALIDATION_EXCLUDED_CATEGORIES ',clc$nominal_entry, 15],
    ['VALIDATION_REQUIRED_CATEGORIES ',clc$nominal_entry, 16],
    ['VEC                            ',clc$abbreviation_entry, 15],
    ['VRC                            ',clc$abbreviation_entry, 16]],
    [
{ PARAMETER 1
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 18],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 106, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 816, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 787, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 121, clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 159, clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 159, clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],
{ PARAMETER 13
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 311, clc$optional_parameter, 0, 0],
{ PARAMETER 14
    [31, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],
{ PARAMETER 15
    [34, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 159, clc$optional_parameter, 0, 0],
{ PARAMETER 16
    [35, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 159, clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [33, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    '$current_mainframe'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    752, [[1, 0, clc$list_type], [736, 1, 8, FALSE],
        [[1, 0, clc$record_type], [4],
        ['DISPATCHING_PRIORITY           ', clc$required_field, 350], [[1, 0,
  clc$range_type], [343],
            [[1, 0, clc$union_type], [[clc$integer_type,
            clc$keyword_type],
            FALSE, 2],
            20, [[1, 0, clc$integer_type], [1, 8, 10]],
            303, [[1, 0, clc$keyword_type], [8], [
              ['P1                             ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
              ['P2                             ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
              ['P3                             ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
              ['P4                             ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
              ['P5                             ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
              ['P6                             ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
              ['P7                             ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
              ['P8                             ', clc$nominal_entry,
  clc$normal_usage_entry, 8]]
              ]
            ]
          ],
        ['MINIMUM_PERCENT                ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
          FALSE, 2],
          44, [[1, 0, clc$keyword_type], [1], [
            ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
            ],
          20, [[1, 0, clc$integer_type], [0, 100, 10]]
          ],
        ['MAXIMUM_PERCENT                ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
          FALSE, 2],
          44, [[1, 0, clc$keyword_type], [1], [
            ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
            ],
          20, [[1, 0, clc$integer_type], [0, 100, 10]]
          ],
        ['ENFORCE_MAXIMUM                ', clc$optional_field, 67], [[1, 0,
  clc$union_type], [[clc$boolean_type, clc$keyword_type],
          FALSE, 2],
          44, [[1, 0, clc$keyword_type], [1], [
            ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
            ],
          3, [[1, 0, clc$boolean_type]]
          ]
        ]
      ]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, 600, 10]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1000, 100000, 10]]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    723, [[1, 0, clc$list_type], [707, 1, 10, FALSE],
        [[1, 0, clc$record_type], [3],
        ['DISPATCHING_PRIORITY           ', clc$required_field, 424], [[1, 0,
  clc$range_type], [417],
            [[1, 0, clc$union_type], [[clc$integer_type,
            clc$keyword_type],
            FALSE, 2],
            20, [[1, 0, clc$integer_type], [1, 10, 10]],
            377, [[1, 0, clc$keyword_type], [10], [
              ['P1                             ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
              ['P10                            ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
              ['P2                             ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
              ['P3                             ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
              ['P4                             ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
              ['P5                             ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
              ['P6                             ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
              ['P7                             ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
              ['P8                             ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
              ['P9                             ', clc$nominal_entry,
  clc$normal_usage_entry, 9]]
              ]
            ]
          ],
        ['DUAL_STATE_PRIORITY            ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
          FALSE, 2],
          44, [[1, 0, clc$keyword_type], [1], [
            ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
            ],
          20, [[1, 0, clc$integer_type], [1, 10, 10]]
          ],
        ['SUBPRIORITY                    ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
          FALSE, 2],
          44, [[1, 0, clc$keyword_type], [1], [
            ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
            ],
          20, [[1, 0, clc$integer_type], [1, 15, 10]]
          ]
        ]
      ]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$boolean_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [lowest_idle_disp_q_time,
  highest_idle_disp_q_time, 10]]
    ],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 11
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_service_interval,
  jmc$highest_service_interval, 10]]
    ],
{ PARAMETER 12
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_priority_bias,
  jmc$highest_priority_bias, 10]]
    ],
{ PARAMETER 13
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$record_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    247, [[1, 0, clc$record_type], [2],
      ['TARGET                         ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_sched_memory_level,
  jmc$highest_sched_memory_level, 10]]
        ],
      ['THRASHING                      ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_sched_memory_level,
  jmc$highest_sched_memory_level, 10]]
        ]
      ]
    ],
{ PARAMETER 14
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_service_interval,
  jmc$highest_service_interval, 10]]
    ],
{ PARAMETER 15
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 16
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 17
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$mainframe_name = 1,
      p$abbreviation = 2,
      p$cpu_dispatching_allocation = 3,
      p$cpu_dispatching_interval = 4,
      p$cpu_quantum_time = 5,
      p$dual_state_priority_control = 6,
      p$enable_job_leveling = 7,
      p$idle_dispatching_queue_time = 8,
      p$initiation_excluded_categorie = 9 {INITIATION_EXCLUDED_CATEGORIES} ,
      p$initiation_required_categorie = 10 {INITIATION_REQUIRED_CATEGORIES} ,
      p$job_leveling_interval = 11,
      p$job_leveling_priority_bias = 12,
      p$scheduling_memory_levels = 13,
      p$service_calculation_interval = 14,
      p$validation_excluded_categorie = 15 {VALIDATION_EXCLUDED_CATEGORIES} ,
      p$validation_required_categorie = 16 {VALIDATION_REQUIRED_CATEGORIES} ,
      p$status = 17;

    VAR
      pvt: array [1 .. 17] of clt$parameter_value;

    VAR
      the_attributes: jmt$object_attribute;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_controls;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$get_attributes (jmc$profile_controls, #SEQ (pdt), ^pvt, the_attributes,
          status);
    IF status.normal THEN
      jmp$change_object (jmc$profile_controls, pvt [p$mainframe_name].value^,
            the_attributes, jmc$update, status);
    IFEND;

  PROCEND jmp$_change_attribute;
?? TITLE := 'jmp$_create_controls', EJECT ??

{ PURPOSE:
{   Processes the CREATE_CONTROLS command.
{
{ DESIGN:
{   Fetches the default values and adds the specified controls to the profile.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS.

  PROCEDURE jmp$_create_controls
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admc_crec) create_controls (
{   mainframe_name, controls_name, mn, cn: name 17..17 = $required
{   default_values, dv: (by_name) name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 30, 51, 254], clc$command, 7, 3, 1, 0, 0,
            0, 3, 'OSM$ADMC_CREC'], [['CN                             ',
            clc$abbreviation_entry, 1], ['CONTROLS_NAME                  ',
            clc$alias_entry, 1], ['DEFAULT_VALUES                 ',
            clc$nominal_entry, 2], ['DV                             ',
            clc$abbreviation_entry, 2], ['MAINFRAME_NAME                 ',
            clc$nominal_entry, 1], ['MN                             ',
            clc$alias_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 3]], [

{ PARAMETER 1

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 5,
            clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [7, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [17, 17]],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$mainframe_name = 1,
      p$default_values = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      the_controls: jmt$profile_object_reference,
      the_attributes: jmt$object_attribute;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$set_default_attributes (jmc$profile_controls, pvt [p$default_values],
          the_attributes, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$add_object (jmc$profile_controls,
          pvt [p$mainframe_name].value^.name_value, the_attributes,
          the_controls, status);

  PROCEND jmp$_create_controls;
?? TITLE := 'jmp$_delete_controls ', EJECT ??

{ PURPOSE:
{   Processes the DELETE_CONTROLS command.
{
{ DESIGN:
{   Determine the controls to delete and delete them.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS

  PROCEDURE jmp$_delete_controls
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admc_delc) delete_controls (
{   mainframe_name, mainframe_names, mn, ..
{     controls_name, controls_names, cn: list of name
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 31, 22, 741], clc$command, 7, 2, 0, 0, 0,
            0, 2, 'OSM$ADMC_DELC'], [['CN                             ',
            clc$abbreviation_entry, 1], ['CONTROLS_NAME                  ',
            clc$alias_entry, 1], ['CONTROLS_NAMES                 ',
            clc$alias_entry, 1], ['MAINFRAME_NAME                 ',
            clc$nominal_entry, 1], ['MAINFRAME_NAMES                ',
            clc$alias_entry, 1], ['MN                             ',
            clc$alias_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 2]], [

{ PARAMETER 1

      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 21,
            clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [7, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$mainframe_name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_controls;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$delete_object (jmc$profile_controls, pvt [p$mainframe_name].value^,
          status);

  PROCEND jmp$_delete_controls;
?? TITLE := 'jmp$_delete_job_category_entry ', EJECT ??

{ PURPOSE:
{   Processes the DELETE_JOB_CATEGORY_ENTRY command.
{
{ DESIGN:
{   Determines the controls to update, fetches the job categories to delete
{   as an attribute list and updates the controls.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS.

  PROCEDURE jmp$_delete_job_category_entry
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admc_deljce) delete_job_category_entry (
{   mainframe_name, mainframe_names, mn, ..
{     controls_name, controls_names, cn: any of
{       key all keyend
{       list of name
{     anyend = $current_mainframe
{   initiation_excluded_categories, iec: (by_name) any of
{       key all keyend
{       list of name
{     anyend = $optional
{   initiation_required_categories, irc: (by_name) any of
{       key all keyend
{       list of name
{     anyend = $optional
{   validation_excluded_categories, vec: (by_name) any of
{       key all keyend
{       list of name
{     anyend = $optional
{   validation_required_categories, vrc: (by_name) any of
{       key all keyend
{       list of name
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 15] of clt$pdt_parameter_name,
        parameters: array [1 .. 6] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (18),
        recend,
        type2: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type3: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type4: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type5: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type6: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 32, 11, 319], clc$command, 15, 6, 0, 0, 0,
            0, 6, 'OSM$ADMC_DELJCE'], [['CN                             ',
            clc$abbreviation_entry, 1], ['CONTROLS_NAME                  ',
            clc$alias_entry, 1], ['CONTROLS_NAMES                 ',
            clc$alias_entry, 1], ['IEC                            ',
            clc$abbreviation_entry, 2], ['INITIATION_EXCLUDED_CATEGORIES ',
            clc$nominal_entry, 2], ['INITIATION_REQUIRED_CATEGORIES ',
            clc$nominal_entry, 3], ['IRC                            ',
            clc$abbreviation_entry, 3], ['MAINFRAME_NAME                 ',
            clc$nominal_entry, 1], ['MAINFRAME_NAMES                ',
            clc$alias_entry, 1], ['MN                             ',
            clc$alias_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 6], ['VALIDATION_EXCLUDED_CATEGORIES ',
            clc$nominal_entry, 4], ['VALIDATION_REQUIRED_CATEGORIES ',
            clc$nominal_entry, 5], ['VEC                            ',
            clc$abbreviation_entry, 4], ['VRC                            ',
            clc$abbreviation_entry, 5]], [

{ PARAMETER 1

      [8, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 18],

{ PARAMETER 2

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [6, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [12, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [13, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [11, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            '$current_mainframe'],

{ PARAMETER 2

      [[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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 3

      [[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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 4

      [[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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 5

      [[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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 6

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$mainframe_name = 1,
      p$initiation_excluded_categorie = 2 {INITIATION_EXCLUDED_CATEGORIES} ,
      p$initiation_required_categorie = 3 {INITIATION_REQUIRED_CATEGORIES} ,
      p$validation_excluded_categorie = 4 {VALIDATION_EXCLUDED_CATEGORIES} ,
      p$validation_required_categorie = 5 {VALIDATION_REQUIRED_CATEGORIES} ,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      the_attributes: jmt$object_attribute;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$get_attributes (jmc$profile_controls, #SEQ (pdt), ^pvt, the_attributes,
          status);
    IF status.normal THEN
      jmp$change_object (jmc$profile_controls, pvt [p$mainframe_name].value^,
            the_attributes, jmc$delete_list_items, status);
    IFEND;

  PROCEND jmp$_delete_job_category_entry;
?? TITLE := 'jmp$_quit', EJECT ??

{ PURPOSE:
{   Exits the subutility.
{ DESIGN:
{   Terminates the subutility.

  PROCEDURE jmp$_quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admc_qui) quit (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 9, 26, 11, 32, 50, 891], clc$command, 1, 1, 0, 0, 0,
            0, 1, 'OSM$ADMC_QUI'], [['STATUS                         ',
            clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$end_scan_command_file (utility_name, status);

  PROCEND jmp$_quit;
?? TITLE := '[XDCL, #GATE] jmp$_administer_controls', EJECT ??

{ PURPOSE:
{   Starts the ADMINISTER_CONTROLS sub utility.
{ DESIGN:
{   Pass the command table to command_language.

  PROCEDURE [XDCL, #GATE] jmp$_administer_controls
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adms_admc) administer_controls (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 9, 26, 11, 33, 18, 81], clc$command, 1, 1, 0, 0, 0,
            0, 1, 'OSM$ADMS_ADMC'], [['STATUS                         ',
            clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    utility_attributes [1].command_table := command_table;
    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmv$current_profile_level := jmc$profile_controls;

    clp$include_file (command_file, '', utility_name, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$end_utility (utility_name, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

  PROCEND jmp$_administer_controls;
MODEND jmm$administer_controls;
*DECK DECK=JMM$ADMINISTER_DEFINITIONS EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Scheduling : administer definitions' ??
MODULE jmm$administer_definitions;

{ PURPOSE:
{   This module contains the data declarations and routines that
{   are used to build the data structures that define the objects and
{   attributes of these objects for the scheduling profile.  These
{   data structures are used by the modules when displaying, building,
{   and merging of attribute lists and objects.
{
{ DESIGN:
{   The attribute structure for each object is a tree structure.  The
{   definitions here express this tree structure in a flat form.  The
{   routines in this module convert this flat form into the actual tree
{   structure.  The preset routine also builds the default profile.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS
{       JMM$ADMINISTER_ATTRIBUTES

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc jmt$profile_data
*copyc jmt$object_definition
?? PUSH (LISTEXT := ON) ??
*copyc jme$job_scheduler_conditions
*copyc jme$profile_internal_error
*copyc jmc$class_names
*copyc jmc$job_management_id
*copyc jmc$maximum_mainframes
*copyc jmc$profile_constants
*copyc jmt$application_index
*copyc jmt$job_category
*copyc jmt$job_class
*copyc jmt$job_class_attributes
*copyc jmt$job_scheduler_table
*copyc jmt$output_class_attributes
*copyc jmt$output_class_index
*copyc jmt$profile_header
*copyc jmt$service_class_attributes
*copyc jmt$service_class_index
?? POP ??
*copyc jmp$copy_attributes
*copyc jmp$delete_attributes
*copyc jmp$add_object
*copyc jmp$get_default_class_values
*copyc jmp$set_object_default
*copyc mmp$create_scratch_segment
*copyc osp$get_cpu_model_definition
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
*copyc pmp$abort
*copyc pmp$convert_mainframe_to_binary
*copyc pmp$get_mainframe_id

*copyc jmv$current_class_name
*copyc jmv$current_profile_level
*copyc osv$lower_to_upper
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] JMV$THE_PROFILE', EJECT ??

{ PURPOSE:
{   Defines the working profile.
{
{ DESIGN:
{   The variable contains the profile identifier, counts of the number of
{   objects of each type, and a pointer to the head object for each type.
{   The procedures in JMM$ADMINISTER_ATTRIBUTES, and JMM$ADMINISTER_OBJECTS
{   manipulate the data referenced by this variable.

  VAR
    jmv$the_profile: [XDCL, #GATE] jmt$profile_data :=
          ['EMPTY', [REP object_kind_count of NIL],
          [REP object_kind_count of 0]];

?? TITLE := '[XDCL] JMV$NEW_PROFILE', EJECT ??

{ Global variable JMV$NEW_PROFILE
{ PURPOSE:
{   This variable is used to hold the definition of a profile read from
{   a profile file until it is made the working profile.
{
{ DESIGN:
{   The variable contains the profile identifier, counts of the number of
{   objects of each type, and a pointer to the head object for each type.

  VAR
    jmv$new_profile: [XDCL] jmt$profile_data :=
          ['EMPTY', [REP object_kind_count of NIL],
          [REP object_kind_count of 0]];

?? TITLE := '[XDCL, #GATE] JMV$OBJECT_DEFINITION', EJECT ??

{ PURPOSE:
{   This definition is used when reading a profile to verify the data on the
{   file; when displaying the attributes to determine the attribute class_name,
{   attribute groups and set the defaults for unspecified attributes of an
{   object; when building the system tables to set the defaults for unspecified
{   attributes of an object; when processing an scl command list to determine
{   the parameter class_name and to impose a structure on the parameter data.
{
{ DESIGN:
{   This variable is the starting point in a tree structure that defines the
{   structure of a scheduling profile - the structure of the attributes for
{   each of the object types, and the default values for each node in the
{   attribute tree structure for an object type.

?? FMT (FORMAT := OFF) ??

  VAR
    jmv$object_definition: [XDCL, #GATE] jmt$object_definition := [
      [['JOB_CATEGORY   ', 'JCA', *, jmc$none], ^fetch_standard_defaults,
          jmc$maximum_job_categories, NIL, NIL],
      [['JOB_PRIORITY   ', 'JP', *, jmc$none], ^fetch_standard_defaults,
          0, NIL, NIL],
      [['OUTPUT_CATEGORY', 'OC', *, jmc$none], ^fetch_standard_defaults,
          0, NIL, NIL],
      [['RESERVED       ', '--', *, jmc$none], ^fetch_standard_defaults,
          0, NIL, NIL],
      [['CONTROLS       ', 'C ', *, jmc$none], ^fetch_controls_defaults,
          jmc$maximum_mainframes, ^check_controls_attributes, NIL],
      [['JOB_CLASS      ', 'JCL', *, jmc$none], ^fetch_job_class_defaults,
          jmc$maximum_job_classes, ^check_job_class_attributes, NIL],
      [['SERVICE_CLASS  ', 'SC', *, jmc$none], ^fetch_standard_defaults,
          jmc$maximum_service_classes, NIL, NIL],
      [['OUTPUT_CLASS   ', 'OC', *, jmc$none], ^fetch_standard_defaults,
          jmc$maximum_output_classes, NIL, NIL],
      [['APPLICATION    ', 'A ', *, jmc$none], ^fetch_standard_defaults,
          jmc$maximum_application_index, NIL, NIL]];

?? FMT (FORMAT := ON) ??

?? TITLE := '[XDCL, #GATE] JMV$OBJECT_HEAP', EJECT ??

{ PURPOSE:
{   This variable references a heap that is used for allocating object and
{   attribute structures to be included in the JMV$THE_PROFILE and
{   JMV$NEW_PROFILE profile definitions.
{
{ NOTES:
{   The heap is created at utility initiation by requesting a segment as a
{   heap.

  VAR
    jmv$object_heap: [XDCL, #GATE] ^HEAP ( * );

?? TITLE := '[XDCL, #GATE] JMV$WORKING_STORAGE', EJECT ??

{ PURPOSE:
{   Provides temporary memory for building structures that have a limited
{   lifetime (a subcommand or less) but never the less must survive across
{   procedure calls.  For instance, when creating the system tables, the
{   tables are allocated from here, and the attributes for each object are
{   expanded to full depth assigning a value to each node in the list by
{   building the expanded list out of this storage area.
{
{ DESIGN:
{   Structures are allocated using NEXTs.  When the structures are no longer
{   needed then the sequence can be reset.

  VAR
    jmv$working_storage: [XDCL, #GATE] ^SEQ ( * );

?? TITLE := 'Declarations for This Module', EJECT ??

  CONST
    object_kind_count = 9;

  CONST
    lowest_idle_disp_q_time = jmc$lowest_idle_disp_q_time DIV 1000000,
    highest_idle_disp_q_time = jmc$highest_idle_disp_q_time DIV 1000000;

  CONST
    lowest_prio_age_interval = jmc$lowest_prio_age_interval DIV 1000000,
    highest_prio_age_interval = jmc$highest_prio_age_interval DIV 1000000;

  VAR
    mainframe_id: pmt$mainframe_id,
    abbreviation: ost$name := osc$null_name,
    empty_declaration: jmt$profile_declaration :=
          ['EMPTY', 'E', * , jmc$empty];

  CONST
    maximum_list_size = 4095;

  TYPE
    structure_list = array [1 .. * ] of attribute_structure,

    attribute_structure = record
      list_index: 1 .. maximum_list_size,
      definition: jmt$profile_declaration,
      default: jmt$object_attribute,
    recend;

  VAR
    object_structure: array [jmt$profile_object_kinds] of ^structure_list :=
          [^category_structure, ^priority_structure, ^empty_structure,
          ^empty_structure, ^controls_structure, ^job_class_structure,
          ^service_class_structure, ^output_class_structure,
          ^application_structure];

  VAR
    empty_structure: array [1 .. 1] of attribute_structure :=
          [[1, ['--', '--', * , jmc$empty], [jmc$empty]]];

  TYPE
    attribute_preset_list = array [1 .. * ] of attribute_preset,
    attribute_preset = record
      list_index: 0 .. maximum_list_size,
      attribute: jmt$object_attribute,
    recend;

  VAR
    object_attribute_defaults: array [jmt$profile_object_kinds] of
          jmt$object_attribute := [REP object_kind_count of [jmc$none]];

  TYPE
    job_and_service_classes = (interactive, batch, system, maintenance,
          unassigned);

?? TITLE := 'Job Category Definitions', EJECT ??

?? FMT (FORMAT := OFF) ??

  CONST
    category_descriptor_count = 39;

  VAR
    category_structure: array [1 .. category_descriptor_count] of
        attribute_structure := [

  [1, ['JOB_CATEGORY', 'JCA', * , jmc$type, jmc$c_maximum_attribute, * ],
          [jmc$type, * ]],

{ CPU_TIME_LIMIT                 = range of integer

    [jmc$c_cpu_time_limit, ['Cpu_Time_Limit', 'CTL', jmc$membership_group,
          jmc$range, 1, * ], [jmc$empty]],
      [1, ['Cpu_Time_Limit', '--', * , jmc$number, jmc$lowest_cpu_time_limit,
          jmc$highest_cpu_time_limit], [jmc$empty]],

{ JOB_MODE                       = list of name

    [jmc$c_job_mode, ['Job_Mode', 'JM', jmc$membership_group, jmc$list, 1, * ],
          [jmc$empty]],
      [1, ['Job_Mode', '--', * , jmc$name], [jmc$empty]],

{ JOB_PRIORITY

{   [jmc$c_job_priority, ['Job_Priority', 'JP', jmc$membership_group, jmc$list,
{         1, * ], [jmc$empty]],
{     [1, ['--', '--', * , jmc$object, jmc$profile_priority], [jmc$empty]],

{ JOB_QUALIFIER                  = list of name

    [jmc$c_job_qualifier, ['Job_Qualifier', 'JQ', jmc$membership_group,
          jmc$list, 1, * ], [jmc$empty]],
      [1, ['Job_Qualifier', '--', * , jmc$name], [jmc$empty]],

{ LOGIN_FAMILY                   = list of name

    [jmc$c_login_family, ['Login_Family', 'LF', jmc$membership_group, jmc$list,
          1, * ], [jmc$empty]],
      [1, ['Login_Family', '--', * , jmc$name], [jmc$empty]],

{ LOGIN_USER                     = list of name

    [jmc$c_login_user, ['Login_User', 'LU', jmc$membership_group, jmc$list,
          1, *], [jmc$empty]],
      [1, ['Login_User', '--', * , jmc$name], [jmc$empty]],

{ LOGIN_PROJECT                  = list of name

    [jmc$c_login_project, ['Login_Project', 'LP', jmc$membership_group,
          jmc$list, 1, * ], [jmc$empty]],
      [1, ['Login_Project', '--', * , jmc$name], [jmc$empty]],

{ LOGIN_ACCOUNT                  = list of name

    [jmc$c_login_account, ['Login_Account', 'LA', jmc$membership_group,
          jmc$list, 1, * ], [jmc$empty]],
      [1, ['Login_Account', '--', * , jmc$name], [jmc$empty]],

{ MAGNETIC_TAPE_LIMIT            = range of integer

    [jmc$c_magnetic_tape_limit, ['Magnetic_Tape_Limit', 'MTL',
          jmc$membership_group, jmc$range, 1, * ], [jmc$empty]],
      [1, ['Magnetic_Tape_Limit', '--', * , jmc$number,
            jmc$lowest_magnetic_tape_limit, jmc$highest_magnetic_tape_limit],
        [jmc$empty]],

{ ORIGINATING_APPLICATION_NAME   = list of name

    [jmc$c_origin_application_name, ['Originating_Application_Name', 'OAN',
          jmc$membership_group, jmc$list, 1, * ], [jmc$empty]],
      [1, ['Originating_Application_Name', '--', * , jmc$name], [jmc$empty]],

{ SRU_LIMIT                      = range of integer

    [jmc$c_sru_limit, ['Sru_Limit', 'SL', jmc$membership_group, jmc$range,
          1, * ], [jmc$empty]],
      [1, ['Sru_Limit', '--', * , jmc$number, jmc$lowest_sru_limit,
            jmc$highest_sru_limit], [jmc$empty]],

{ USER_JOB_NAME                  = list of name

    [jmc$c_user_job_name, ['User_Job_Name', 'UJN', jmc$membership_group,
          jmc$list, 1, * ], [jmc$empty]],
      [1, ['User_Job_Name', '--', * , jmc$name], [jmc$empty]],

{ MAXIMUM_WORKING_SET            = range of integer

    [jmc$c_maximum_working_set, ['Maximum_Working_Set', 'MAXWS',
          jmc$membership_group, jmc$range, 1, * ], [jmc$empty]],
      [1, ['Maximum_Working_Set', '--', * , jmc$number,
            jmc$lowest_working_set_size, jmc$highest_working_set_size],
        [jmc$empty]],

{ CATEGORY_DEFINITION            = list of record
{     SKIP_ITEM                  = integer
{     NEXT_ITEM                  = integer
{     CATEGORIES                 = list of jmc$profile_category
{     TYPE                       = name
{     MEMBERS                    = list of jmc$profile_category OR
{                                    name OR integer

    [jmc$c_data_display, ['Category_Data_Display', 'CDD', jmc$statistic_group,
          jmc$list, 1, * ], [jmc$empty]],
      [1, ['--', '--', * , jmc$type, 5, * ], [jmc$type, * ]],
        [1, ['Skip_Item', 'SI', * , jmc$number, 0, 0], [jmc$empty]],
        [2, ['Next_Item', 'NI', * , jmc$number, 0, 0], [jmc$empty]],
        [3, ['Categories', 'C', * , jmc$list, 1, * ], [jmc$empty]],
          [1, ['--', '--', * , jmc$object, jmc$profile_category], [jmc$empty]],
        [4, ['Type', 'T', * , jmc$name], [jmc$empty]],
        [5, ['Members', 'M', * , jmc$list, 1, * ], [jmc$empty]],
          [1, ['--', '--', * , jmc$object, jmc$profile_category], [jmc$empty]],

{ CATEGORY_SET_DISPLAY           = list of record
{    NAME                        = name
{    MEMBERS                     = list of jmc$profile_category

    [jmc$c_set_display, ['Category_Set_Display', 'CSD', jmc$statistic_group,
          jmc$list, 1, * ], [jmc$empty]],
      [1, ['--', '--', * , jmc$type, 2, * ], [jmc$empty]],
        [1, ['Name', 'N', * , jmc$name], [jmc$empty]],
        [2, ['Members', 'M', * , jmc$list, 1, * ], [jmc$empty]],
          [1, ['--', '--', * , jmc$object, jmc$profile_category],
            [jmc$empty]]];

?? FMT (FORMAT := ON) ??

  VAR
    category_default: array [1 .. 2] of attribute_preset :=
          [[jmc$c_job_mode, [jmc$list, * ]], [1, [jmc$name, * ]]];

?? TITLE := 'Job Priority Definitions', EJECT ??

?? FMT (FORMAT := OFF) ??

  CONST
    priority_descriptor_count = 6;

  VAR
    priority_structure: array [1 .. priority_descriptor_count] of
        attribute_structure := [

  [1, ['JOB_PRIORITY', 'JP', * , jmc$type, jmc$jp_maximum_attribute, * ],
          [jmc$type, * ]],

{ INITIATION_BIAS                = integer

    [jmc$jp_initiation_bias, ['Initiation_Bias', 'IB', jmc$priority_group,
          jmc$number, -jmc$highest_job_priority, jmc$highest_job_priority],
          [jmc$number, 0]],

{ SCHEDULING_BIAS                = integer

    [jmc$jp_scheduling_bias, ['Scheduling_Bias', 'SB', jmc$priority_group,
          jmc$number, -jmc$highest_job_priority, jmc$highest_job_priority],
          [jmc$number, 0]],

{ DISPATCHING_BIAS               = integer

    [jmc$jp_dispatching_bias, ['Dispatching_Bias', 'DB', jmc$priority_group,
          jmc$number, -10000000, 10000000], [jmc$number, 0]],

{ TIMESLICE_BIAS                 = integer

    [jmc$jp_timeslice_bias, ['Timeslice_Bias', 'TB', jmc$priority_group,
          jmc$number, -10000000, 10000000], [jmc$number, 0]],

{ OUTPUT_BIAS                    = integer

    [jmc$jp_output_bias, ['Output_Bias', 'OB', jmc$priority_group, jmc$number,
          -jmc$highest_job_priority, jmc$highest_job_priority],
          [jmc$number, 0]]];

?? FMT (FORMAT := ON) ??
?? TITLE := 'Scheduler Control Definitions', EJECT ??

?? FMT (FORMAT := OFF) ??

  CONST
    controls_descriptor_count = 35;

  VAR
    controls_structure: array [1 .. controls_descriptor_count] of
        attribute_structure := [

  [1, ['CONTROLS', 'C', * , jmc$type, jmc$ct_maximum_attribute, * ],
          [jmc$type, * ]],

{ ABBREVIATION                   = name

    [jmc$ct_abbreviation, ['Abbreviation', 'A', jmc$definition_group,
          jmc$name], [jmc$none]],

{ CPU_QUANTUM_TIME   = integer

    [jmc$ct_cpu_quantum_time, ['CPU_Quantum_Time', 'CQT',
          jmc$definition_group, jmc$number, 1000,
          100000], [jmc$number, 10000]],

{ ENABLE_JOB_LEVELING            = boolean

    [jmc$ct_enable_job_leveling, ['Enable_Job_Leveling', 'EJL',
          jmc$definition_group, jmc$boolean], [jmc$boolean, FALSE]],

{ JOB_LEVELING_INTERVAL          = integer

    [jmc$ct_job_leveling_interval, ['Job_Leveling_Interval', 'JLI',
          jmc$definition_group, jmc$number, jmc$lowest_service_interval,
          jmc$highest_service_interval], [jmc$number, 60]],

{ JOB_LEVELING_PRIORITY_BIAS     = integer

    [jmc$ct_job_leveling_prio_bias, ['Job_Leveling_Priority_Bias', 'JLPB',
          jmc$priority_group, jmc$number, jmc$lowest_priority_bias,
          jmc$highest_priority_bias], [jmc$number, 0]],

{ SERVICE_CALCULATION_INTERVAL   = integer

    [jmc$ct_service_calc_interval, ['Service_Calculation_Interval', 'SCI',
          jmc$definition_group, jmc$number, jmc$lowest_service_interval,
          jmc$highest_service_interval], [jmc$number, 10]],

{ STATISTICS_RESET_INTERVAL      = integer

{   [jmc$ct_stat_reset_interval, ['Statistics_Reset_Interval', 'SRI',
{         jmc$control_group, jmc$number, 1800, 36000], [jmc$number, 100]],

{ CPU_DISPATCHING_ALLOCATION     = list of
{   PRIORITY_INFORMATION
{    PRIORITY                        = dispatching priority 1..8
{    MINIMUM_PERCENT                 = integer 0..100
{    MAXIMUM_PERCENT                 = integer 0..100
{    ENFORCE_MAXIMUM                 = boolean

    [jmc$ct_dispatching_allocation, ['CPU_Dispatching_Allocation', 'CDA',
          jmc$control_group, jmc$editable_list, 1, * ],
          [jmc$editable_list, * ]],
      [1, ['Priority_Triplet', 'PT', *, jmc$type, 4, * ], [jmc$type, * ]],
        [1, ['Priority', 'P', * , jmc$range, 2, *], [jmc$range, *]],
          [1, ['Priority', 'P', * , jmc$dispatching_priority, 1, 8],
              [jmc$dispatching_priority, 1]],
          [2, ['Priority', 'P', * , jmc$dispatching_priority, 1, 8],
              [jmc$dispatching_priority, 8]],
        [2, ['Minimum_Percent', 'MINA', * , jmc$number, 0, 100],
            [jmc$number, 0]],
        [3, ['Maximum_Percent', 'MAXA', * , jmc$number, 0, 100],
            [jmc$number, 100]],
        [4, ['Enforce_Maximum', 'EM', * , jmc$boolean],
            [jmc$boolean, FALSE]],

{ CPU_DISPATCHING_INTERVAL       = integer

    [jmc$ct_cpu_dispatching_interval, ['CPU_Dispatching_Interval', 'CDI',
          jmc$control_group, jmc$number, 1, 600], [jmc$number, 1]],

{ DUAL_STATE_PRIORITY_CONTROL    = editable list
{   PRIORITY_CONTROL               = type
{     PRIORITY                       = dispatching priority 1..10
{     MAINFRAME_PRIORITY             = integer 0..7
{     SUBPRIORITY                    = integer 1..15

    [jmc$ct_dual_state_prio_control, ['Dual_State_Priority_Control', 'DSPC',
          jmc$control_group, jmc$editable_list, 1, * ],
          [jmc$empty]],
      [1, ['Priority_Control', 'PT', *, jmc$type, 3, * ], [jmc$empty]],
        [1, ['Dispatching_Priority', 'DP', * , jmc$range, 1, *],
            [jmc$range, *]],
          [1, ['Priority', 'P', * , jmc$dispatching_priority, 1, 10],
              [jmc$dispatching_priority, 1]],
        [2, ['Dual_State_Priority', 'DSP', * , jmc$number, 1, 7],
            [jmc$number, 1]],
        [3, ['Subpriority', 'S', * , jmc$number, 1, 15],
            [jmc$number, 8]],

{ IDLE_DISPATCHING_QUEUE_TIME    = integer

    [jmc$ct_idle_disp_queue_time, ['Idle_Dispatching_Queue_Time', 'IDQT',
          jmc$control_group, jmc$number, lowest_idle_disp_q_time,
          highest_idle_disp_q_time], [jmc$number, 360]],

{ SCHEDULING_MEMORY_LEVELS       = record
{    TARGET                          = integer
{    THRASHING                       = integer

    [jmc$ct_scheduling_memory_levels, ['Scheduling_Memory_Levels', 'SML',
          jmc$control_group, jmc$type, 2, * ], [jmc$type, * ]],
      [1, ['Target', 'TA', * , jmc$number, jmc$lowest_sched_memory_level,
          jmc$highest_sched_memory_level], [jmc$number, 60]],
      [2, ['Thrashing', 'TH', * , jmc$number, jmc$lowest_sched_memory_level,
          jmc$highest_sched_memory_level], [jmc$number, 20]],

{ MAXIMUM_INITIATED_JOBS         = integer

{   [jmc$ct_maximum_initiated_jobs, ['Maximum_Initiated_Jobs', 'MAXIJ',
{         jmc$control_group, jmc$number, 0, 1000], [jmc$number, 100]],

{ INITIATION_REQUIRED_CATEGORIES = list of jmc$profile_category

    [jmc$ct_ini_required_categories, ['Initiation_Required_Categories', 'IRC',
          jmc$control_group, jmc$list, 1, * ], [jmc$none]],
      [1, ['Initiation_Required_Categories', '--', * , jmc$object,
            jmc$profile_category], [jmc$empty]],

{ INITIATION_EXCLUDED_CATEGORIES = list of jmc$profile_category

    [jmc$ct_ini_excluded_categories, ['Initiation_Excluded_Categories', 'IEC',
          jmc$control_group, jmc$list, 1, * ], [jmc$none]],
      [1, ['Initiation_Excluded_Categories', '--', * , jmc$object,
            jmc$profile_category], [jmc$empty]],

{ VALIDATION_REQUIRED_CATEGORIES = list of jmc$profile_category

    [jmc$ct_val_required_categories, ['Validation_Required_Categories', 'VRC',
          jmc$membership_group, jmc$list, 1, * ], [jmc$none]],
      [1, ['Validation_Required_Categories', '--', * , jmc$object,
            jmc$profile_category], [jmc$empty]],

{ VALIDATION_EXCLUDED_CATEGORIES = list of jmc$profile_category

    [jmc$ct_val_excluded_categories, ['Validation_Excluded_Categories', 'VEC',
          jmc$membership_group, jmc$list, 1, * ], [jmc$none]],
      [1, ['Validation_Excluded_Categories', '--', * , jmc$object,
            jmc$profile_category], [jmc$empty]],

{ PROFILE_IDENTIFICATION         = name - for debugging purposes

    [jmc$ct_profile_identification, ['Profile_Identification', 'PI',
          jmc$statistic_group, jmc$name], [jmc$empty]]];

?? FMT (FORMAT := ON) ??
?? FMT (FORMAT := OFF) ??

{ Controls defaults
{   Dual_State_Priority_Control = ((p1..p2 1 8) (p3..p4 2 8)
{         (p5..p6 3 8) (p7..p8 4 8) (p9..p10 5 8))

  VAR
    ds_priority_control_default: array [1 .. 30] of attribute_preset := [
        [5, [jmc$type, * ]],
          [1, [jmc$range, *]],
            [2, [jmc$dispatching_priority, 10]],
            [1, [jmc$dispatching_priority, 9]],
          [2, [jmc$number, 5]],
          [3, [jmc$number, 8]],
        [1, [jmc$type, * ]],
          [1, [jmc$range, *]],
            [2, [jmc$dispatching_priority, 2]],
            [1, [jmc$dispatching_priority, 1]],
          [2, [jmc$number, 1]],
          [3, [jmc$number, 8]],
        [2, [jmc$type, * ]],
          [1, [jmc$range, *]],
            [2, [jmc$dispatching_priority, 4]],
            [1, [jmc$dispatching_priority, 3]],
          [2, [jmc$number, 2]],
          [3, [jmc$number, 8]],
        [3, [jmc$type, * ]],
          [1, [jmc$range, *]],
            [2, [jmc$dispatching_priority, 6]],
            [1, [jmc$dispatching_priority, 5]],
          [2, [jmc$number, 3]],
          [3, [jmc$number, 8]],
        [4, [jmc$type, * ]],
          [1, [jmc$range, *]],
            [2, [jmc$dispatching_priority, 8]],
            [1, [jmc$dispatching_priority, 7]],
          [2, [jmc$number, 4]],
          [3, [jmc$number, 8]]];
?? FMT (FORMAT := ON) ??
?? TITLE := 'Job Class Definitions', EJECT ??

?? FMT (FORMAT := OFF) ??

  CONST
    job_class_descriptor_count = 52;

  VAR
    job_class_structure: array [1 .. job_class_descriptor_count] of
        attribute_structure := [

  [1, ['JOB_CLASS', 'JCL', * , jmc$type, jmc$jc_maximum_attribute, * ],
          [jmc$type, * ]],

{ ABBREVIATION                   = name

    [jmc$jc_abbreviation, ['Abbreviation', 'A', jmc$definition_group,
          jmc$name], [jmc$none]],

{ PROLOG                         = name

    [jmc$jc_prolog, ['Prolog', 'P', jmc$definition_group, jmc$file],
          [jmc$none]],

{ EPILOG                         = name

    [jmc$jc_epilog, ['Epilog', 'E', jmc$definition_group, jmc$file],
          [jmc$none]],

{ ENABLE_CLASS_MEMBERSHIP        = boolean

{   [jmc$jc_enable_class_membership, ['Enable_Class_Membership', 'ECM',
{         jmc$definition_group, jmc$boolean], [jmc$boolean, TRUE]],

{ ENABLE_CLASS_EXECUTION         = boolean

{   [jmc$jc_enable_class_execution, ['Enable_Class_Execution', 'ECE',
{         jmc$definition_group, jmc$boolean], [jmc$boolean, TRUE]],

{ ENABLE_CLASS_INITIATION        = boolean

    [jmc$jc_enable_class_initiation, ['Enable_Class_Initiation', 'ECI',
          jmc$definition_group, jmc$boolean], [jmc$boolean, TRUE]],

{ ENABLE_IMMEDIATE_AGING         = boolean

{   [jmc$jc_enable_immediate_aging, ['Enable_Immediate_Aging', 'EIA',
{         jmc$definition_group, jmc$boolean], [jmc$boolean, TRUE]],

{ IMMEDIATE_INITIATION_CANDIDATES= boolean

    [jmc$jc_immediate_initiation_can, ['Immediate_Initiation_Candidate', 'IIC',
          jmc$definition_group, jmc$boolean], [jmc$boolean, FALSE]],

{ ENABLE_LATCH_MODE              = boolean

{   [jmc$jc_enable_latch_mode, ['Enable_Latch_Mode', 'ELM',
{         jmc$definition_group, jmc$boolean], [jmc$boolean, FALSE]],

{ INITIAL_WORKING_SET            = integer

    [jmc$jc_initial_working_set, ['Initial_Working_Set', 'IWS',
          jmc$definition_group, jmc$number, jmc$lowest_working_set_size,
          jmc$highest_working_set_size], [jmc$number, 65]],

{ INITIAL_SERVICE_CLASS          = jmc$profile_service_class

    [jmc$jc_initial_service_class, ['Initial_Service_Class', 'ISC',
          jmc$definition_group, jmc$object, jmc$profile_service_class],
          [jmc$object, * , * ]],

{ VALID_SERVICE_CLASSES          = list of jmc$profile_service_class

{   [jmc$jc_valid_service_classes, ['Valid_Service_Classes', 'VSC',
{         jmc$definition_group, jmc$empty], [jmc$none]],

{ DEFAULT_OUTPUT_CLASS           = jmc$profile_output_class

{   [jmc$jc_default_output_class, ['Default_Output_Class', 'DOC',
{         jmc$definition_group, jmc$empty], [jmc$system_default]],

{ VALID_OUTPUT_CLASSES           = list of jmc$profile_output_class

{   [jmc$jc_valid_output_classes, ['Valid_Output_Classes', 'VOC',
{         jmc$definition_group, jmc$empty], [jmc$none]],

{ DEFER_ON_SUBMIT                = boolean

    [jmc$jc_defer_on_submit, ['Defer_On_Submit', 'DOS',
          jmc$control_group, jmc$boolean], [jmc$boolean, FALSE]],

{ INITIATION_LEVEL               = record
{    PREFERRED                       = integer
{ *  MAXIMUM_INCREMENT               = integer

    [jmc$jc_initiation_level, ['Initiation_Level', 'IL', jmc$control_group,
          jmc$type, 1, * ], [jmc$type, * ]],
      [1, ['Preferred', 'P', * , jmc$number, jmc$lowest_max_initiated_jobs,
          jmc$highest_max_initiated_jobs], [jmc$number, 20]],
{     [2, ['Maximum_Increment', 'MAXI', * , jmc$number,
{         jmc$lowest_max_initiated_jobs, jmc$highest_max_initiated_jobs],
{         [jmc$number, 0]],

{ USE_INITIATION_GROUP           = jmc$profile_job_group

{   [jmc$jc_use_initiation_group, ['Use_Initiation_Group', 'UIG',
{         jmc$control_group, jmc$empty], [jmc$none]],

{ OVER_COMMITMENT_CRITERIA       = record
{    WAIT_TIME                       = integer
{    WAIT_COUNT                      = integer
{    MAXIMUM                         = integer

{   [jmc$jc_over_commitment_criteria, ['Over_Commitment_Criteria', 'OCC',
{         jmc$control_group, jmc$type, 3, * ], [jmc$empty]],
{     [1, ['Wait_Time', 'WT', *, jmc$number, jmc$lowest_lsi, jmc$highest_lsi],
{           [jmc$number, 600]],
{     [2, ['Wait_Count', 'WC', *, jmc$number, 1, 100], [jmc$number, 3]],
{     [3, ['Maximum', 'MAX', *, jmc$number, 0, 100], [jmc$number, 0]],

{ MINIMUM_WORKING_SET            = record
{    DEFAULT                         = integer
{    Minimum                         = integer
{    Maximum                         = integer

    [jmc$jc_minimum_working_set, ['Minimum_Working_Set', 'MINWS',
          jmc$control_group, jmc$type, 3, * ], [jmc$type, * ]],
      [1, ['Default', 'D', * , jmc$number, jmc$lowest_working_set_size,
            jmc$highest_working_set_size], [jmc$number, 20]],
      [2, ['Minimum', 'MIN', * , jmc$number, jmc$lowest_working_set_size,
            jmc$highest_working_set_size], [jmc$number, 20]],
      [3, ['Maximum', 'MAX', * , jmc$number, jmc$lowest_working_set_size,
            jmc$highest_working_set_size], [jmc$number, 1000]],

{ Maximum_Working_Set            = integer
{    Default                         = integer
{    Minimum                         = integer
{    Maximum                         = integer

    [jmc$jc_maximum_working_set, ['Maximum_Working_Set', 'MAXWS',
          jmc$control_group, jmc$type, 3, * ], [jmc$type, * ]],
      [1, ['Default', 'D', * , jmc$number, jmc$lowest_working_set_size,
            jmc$highest_working_set_size], [jmc$number, 1000]],
      [2, ['Minimum', 'MIN', * , jmc$number, jmc$lowest_working_set_size,
            jmc$highest_working_set_size], [jmc$number, 20]],
      [3, ['Maximum', 'MAX', * , jmc$number, jmc$lowest_working_set_size,
            jmc$highest_working_set_size], [jmc$number, 1000]],

{ PAGE_AGING_INTERVAL            = record
{    Default                         = integer
{    Minimum                         = integer
{    Maximum                         = integer

    [jmc$jc_page_aging_interval, ['Page_Aging_Interval', 'PAI',
          jmc$control_group, jmc$type, 3, * ], [jmc$type, * ]],
      [1, ['Default', 'D', * , jmc$number, jmc$lowest_aging_interval,
            jmc$highest_aging_interval], [jmc$number, 50000]],
      [2, ['Minimum', 'MIN', * , jmc$number, jmc$lowest_aging_interval,
            jmc$highest_aging_interval], [jmc$number, 10000]],
      [3, ['Maximum', 'MAX', * , jmc$number, jmc$lowest_aging_interval,
            jmc$highest_aging_interval], [jmc$number, 1000000000]],

{ CYCLIC_AGING_INTERVAL          = record
{    Default                         = integer
{    Minimum                         = integer
{    Maximum                         = integer

    [jmc$jc_cyclic_aging_interval, ['Cyclic_Aging_Interval', 'CAI',
          jmc$control_group, jmc$type, 3, * ], [jmc$type, * ]],
      [1, ['Default', 'D', * , jmc$number, jmc$lowest_aging_interval,
          jmc$highest_aging_interval], [jmc$number, 1000000000]],
      [2, ['Minimum', 'MIN', * , jmc$number, jmc$lowest_aging_interval,
          jmc$highest_aging_interval], [jmc$number, 10000]],
      [3, ['Maximum', 'MAX', * , jmc$number, jmc$lowest_aging_interval,
          jmc$highest_aging_interval], [jmc$number, 1000000000]],

{ CLASS_CAPABILITIES             = list of name

{   [jmc$jc_class_capabilities, ['Class_Capabilities', 'CC', jmc$control_group,
{         jmc$empty], [jmc$none]],

{ DETACHED_JOB_WAIT_TIME         = record
{    DEFAULT                         = integer
{    MINIMUM                         = integer
{    MAXIMUM                         = integer

    [jmc$jc_detached_job_wait_time, ['Detached_Job_Wait_Time', 'DJWT',
          jmc$limit_group, jmc$type, 3, * ], [jmc$type, * ]],
      [1, ['Default', 'D', * , jmc$number, jmc$lowest_det_job_wait_time,
          jmc$highest_det_job_wait_time], [jmc$number, 3600]],
      [2, ['Minimum', 'MIN', * , jmc$number, jmc$lowest_det_job_wait_time,
          jmc$highest_det_job_wait_time], [jmc$number, 0]],
      [3, ['Maximum', 'MAX', * , jmc$number, jmc$lowest_det_job_wait_time,
          jmc$highest_det_job_wait_time], [jmc$number, 18000]],

{ CPU_TIME_LIMIT                 = integer

    [jmc$jc_cpu_time_limit, ['CPU_Time_Limit', 'CTL', jmc$limit_group,
          jmc$number, jmc$lowest_cpu_time_limit, jmc$highest_cpu_time_limit],
          [jmc$unlimited]],

{ SRU_LIMIT                      = integer

    [jmc$jc_sru_limit, ['SRU_Limit', 'SL', jmc$limit_group, jmc$number,
          jmc$lowest_sru_limit, jmc$highest_sru_limit], [jmc$unlimited]],

{ MAGNETIC_TAPE_LIMIT            = integer

    [jmc$jc_magnetic_tape_limit, ['Magnetic_Tape_Limit', 'MTL', jmc$limit_group
,
          jmc$number, jmc$lowest_magnetic_tape_limit,
          jmc$highest_magnetic_tape_limit], [jmc$unlimited]],

{ AUTOMATIC_CLASS_SELECTION      = boolean

    [jmc$jc_auto_class_selection, ['Automatic_Class_Selection', 'ACS',
          jmc$membership_group, jmc$boolean], [jmc$boolean, FALSE]],

{ REQUIRED_CATEGORIES            = list of jmc$profile_category

    [jmc$jc_required_categories, ['Required_Categories', 'RC',
          jmc$membership_group, jmc$list, 1, * ], [jmc$none]],
      [1, ['Required_Categories', '--', * , jmc$object, jmc$profile_category],
            [jmc$empty]],

{ EXCLUDED_CATEGORIES            = list of jmc$profile_category

    [jmc$jc_excluded_categories, ['Excluded_Categories', 'EC',
          jmc$membership_group, jmc$list, 1, * ], [jmc$none]],
      [1, ['Excluded_Categories', '--', * , jmc$object, jmc$profile_category],
            [jmc$empty]],

{ MULTIPLE_JOB_BIAS              = integer
    [jmc$jc_multiple_job_bias, ['Multiple_Job_Bias', 'MJB',
          jmc$priority_group, jmc$number, jmc$lowest_job_priority,
          jmc$highest_job_priority], [jmc$number, 0]],

{ INITIATION_AGE_INTERVAL        = integer

    [jmc$jc_initiation_age_interval, ['Initiation_Age_Interval', 'IAI',
          jmc$priority_group, jmc$number, lowest_prio_age_interval,
          highest_prio_age_interval], [jmc$number, 1]],

{ SELECTION_PRIORITY             = record
{    INITIAL                         = integer
{    MAXIMUM                         = integer
{    INCREMENT                       = integer
{    THRESHOLD                       = integer

    [jmc$jc_selection_priority, ['Selection_Priority', 'SP',
          jmc$priority_group, jmc$type, 4, * ], [jmc$type, * ]],
      [1, ['Initial', 'I', * , jmc$number, jmc$lowest_job_priority,
            jmc$highest_job_priority], [jmc$number, 5000]],
      [2, ['Maximum', 'MAX', * , jmc$number, jmc$lowest_job_priority,
            jmc$highest_job_priority], [jmc$number, 10000]],
      [3, ['Increment', 'I', * , jmc$number, jmc$lowest_job_priority,
            jmc$highest_job_priority], [jmc$number, 10]],
      [4, ['Threshold', 'T', * , jmc$number, jmc$lowest_job_priority,
            jmc$highest_job_priority], [jmc$number, 0]],

{ CLASS_PRIORITY_BIAS            = record
{    SCHEDULING                      = integer
{    DISPATCHING                     = integer
{    TIMESLICE                       = integer
{ *  OUTPUT                          = integer

{   [jmc$jc_class_priority_bias, ['Class_Priority_Bias', 'CPB',
{         jmc$priority_group, jmc$type, 3, * ], [jmc$none]],
{     [1, ['Scheduling', 'S', *, jmc$number, -8000000, 8000000],
{           [jmc$number, 0]],
{     [2, ['Dispatching', 'D', *, jmc$number, -9, 9], [jmc$number, 0]],
{     [3, ['Timeslice', 'T', *, jmc$number, -1000000, 1000000],
{           [jmc$number, 0]],
{     [3, ['Output', 'O', *, jmc$number, -8000000, 8000000], [jmc$number, 0]],

{ JOB_LEVELING_PRIORITY_BIAS     = integer

    [jmc$jc_job_leveling_prio_bias, ['Job_Leveling_Priority_Bias', 'JLPB',
          jmc$priority_group, jmc$number, jmc$lowest_priority_bias,
          jmc$highest_priority_bias], [jmc$number, 0]],

{ QUEUED_JOBS                    = integer (display only)

    [jmc$jc_queued_jobs, ['Queued_Jobs', 'QJ', jmc$statistic_group, jmc$number,
          0, 0], [jmc$empty]],

{ INITIATED_JOBS                 = integer (display only)

    [jmc$jc_initiated_jobs, ['Initiated_Jobs', 'IJ', jmc$statistic_group,
          jmc$number, 0, 0], [jmc$empty]],

{ INITIATION_WAIT_TIME           = record (display only)
{    MINIMUM                         = integer
{    MAXIMUM                         = integer
{    AVERAGE                         = integer
{    NUMBER_OF_JOBS                  = integer

{   [jmc$jc_initiation_wait_time, ['Initiation_Wait_Time', 'IWT',
{         jmc$statistic_group, jmc$type, 4, * ], [jmc$empty]],
{     [1, ['Minimum', 'MIN', *, jmc$number, 0, 0], [jmc$number, 0]],
{     [2, ['Maximum', 'MAX', *, jmc$number, 0, 0], [jmc$number, 0]],
{     [3, ['Average', 'A', *, jmc$number, 0, 0], [jmc$number, 0]],
{     [4, ['Number_Of_Jobs', 'NOJ', *, jmc$number, 0, 0], [jmc$number, 0]],

{ PROCESSING_WAIT_TIME           = record (display only)
{    MINIMUM                         = integer
{    MAXIMUM                         = integer
{    AVERAGE                         = integer
{    NUMBER_OF_JOBS                  = integer

{   [jmc$jc_processing_wait_time, ['Processing_Wait_Time', 'PWT',
{         jmc$statistic_group, jmc$type, 4, * ], [jmc$empty]],
{     [1, ['Minimum', 'MIN', *, jmc$number, 0, 0], [jmc$number, 0]],
{     [2, ['Maximum', 'MAX', *, jmc$number, 0, 0], [jmc$number, 0]],
{     [3, ['Average', 'A', *, jmc$number, 0, 0], [jmc$number, 0]],
{     [4, ['Number_Of_Jobs', 'NOJ', *, jmc$number, 0, 0], [jmc$number, 0]],

{ DEFINITION_NAME                = name (for debug display only)

    [jmc$jc_definition_name, ['Definition_Name', 'DN', jmc$statistic_group,
          jmc$name], [jmc$empty]],

{ PROFILE_INDEX                  = integer (for debug display only)

    [jmc$jc_profile_index, ['Profile_Index', 'PI', jmc$statistic_group,
          jmc$number, 0, 0], [jmc$empty]],

{ JOB_CLASS_INDEX                = integer (for debug display only)

    [jmc$jc_index, ['Job_Class_Index', 'JCI', jmc$statistic_group, jmc$number,
          0, 0], [jmc$empty]]];

?? FMT (FORMAT := ON) ??

  VAR
    job_class_defaults: array [job_and_service_classes] of
          ^attribute_preset_list := [^job_class_interactive, ^job_class_batch,
          ^job_class_system, ^job_class_maintenance, ^job_class_unassigned];

?? FMT (FORMAT := OFF) ??

  VAR
    job_class_interactive: array [1 .. 11] of attribute_preset := [
      [jmc$jc_excluded_categories, [jmc$list, * ]],
        [1, [jmc$object, * , * ]],
      [jmc$jc_abbreviation, [jmc$name, ^abbreviation]],
      [jmc$jc_immediate_initiation_can, [jmc$boolean, TRUE]],
      [jmc$jc_selection_priority, [jmc$type, * ]],
        [1, [jmc$number, 14000]],
        [2, [jmc$number, 17000]],
        [3, [jmc$number, 1000]],
        [4, [jmc$number, 0]],
      [jmc$jc_initiation_level, [jmc$type, * ]],
        [1, [jmc$unlimited]]];

  VAR
    job_class_batch: array [1 .. 7] of attribute_preset :=
     [[jmc$jc_excluded_categories, [jmc$list, * ]],
        [1, [jmc$object, * , * ]],
      [jmc$jc_abbreviation, [jmc$name, ^abbreviation]],
      [jmc$jc_initial_working_set, [jmc$number, 200]],
      [jmc$jc_initiation_age_interval, [jmc$number, 60]],
      [jmc$jc_initiation_level, [jmc$type, * ]],
        [1, [jmc$number, 10]]];

  VAR
    job_class_system: array [1 .. 11] of attribute_preset :=
     [[jmc$jc_excluded_categories, [jmc$list, * ]],
        [1, [jmc$object, * , * ]],
      [jmc$jc_abbreviation, [jmc$name, ^abbreviation]],
      [jmc$jc_initial_working_set, [jmc$number, 80]],
      [jmc$jc_selection_priority, [jmc$type, * ]],
        [1, [jmc$number, 19000]],
        [2, [jmc$number, 22000]],
        [3, [jmc$number, 100]],
        [4, [jmc$number, 0]],
      [jmc$jc_initiation_level, [jmc$type, * ]],
        [1, [jmc$unlimited]]];

  VAR
    job_class_maintenance: array [1 .. 10] of attribute_preset :=
     [[jmc$jc_abbreviation, [jmc$name, ^abbreviation]],
      [jmc$jc_immediate_initiation_can, [jmc$boolean, TRUE]],
      [jmc$jc_initiation_age_interval, [jmc$number, 60]],
      [jmc$jc_selection_priority, [jmc$type, * ]],
        [1, [jmc$number, 14000]],
        [2, [jmc$number, 17000]],
        [3, [jmc$number, 1000]],
        [4, [jmc$number, 0]],
      [jmc$jc_initiation_level, [jmc$type, * ]],
        [1, [jmc$number, 10]]];

  VAR
    job_class_unassigned: array [1 .. 7] of attribute_preset :=
     [[jmc$jc_abbreviation, [jmc$name, ^abbreviation]],
      [jmc$jc_enable_class_initiation, [jmc$boolean, FALSE]],
      [jmc$jc_initial_working_set, [jmc$number, 200]],
      [jmc$jc_initiation_age_interval, [jmc$number, 60]],
      [jmc$jc_initiation_level, [jmc$type, * ]],
        [1, [jmc$number, 10]],
        [2, [jmc$default]]];

?? FMT (FORMAT := ON) ??
?? TITLE := 'Service Class Definitions', EJECT ??

?? FMT (FORMAT := OFF) ??

  CONST
    service_class_descriptor_count = 30;

  VAR
    service_class_structure: array [1 .. service_class_descriptor_count] of
        attribute_structure := [

  [1, ['SERVICE_CLASS', 'SC', * , jmc$type, jmc$sc_maximum_attribute, * ],
          [jmc$type, * ]],

{   ABBREVIATION                 = name

    [jmc$sc_abbreviation, ['Abbreviation', 'A', jmc$definition_group,
          jmc$name], [jmc$none]],

{   ENABLE_CLASS_EXECUTION       = boolean

    [jmc$sc_enable_class_execution, ['Enable_Class_Execution', 'ECE',
          jmc$definition_group, jmc$boolean], [jmc$boolean, TRUE]],

{   MAXIMUM_ACTIVE_JOBS          = integer

    [jmc$sc_maximum_active_jobs, ['Maximum_Active_Jobs', 'MAXAJ',
          jmc$control_group, jmc$number, jmc$lowest_maximum_active_jobs,
          jmc$highest_maximum_active_jobs], [jmc$number, 20]],

{   SERVICE_FACTORS              = record
{    CPU                             = integer
{    MEMORY                          = integer
{    RESIDENCE                       = integer
{    IO                              = integer

    [jmc$sc_service_factors, ['Service_Factors', 'SF', jmc$control_group,
          jmc$type, 4, * ], [jmc$type, * ]],
      [1, ['CPU', 'C', * , jmc$number, jmc$lowest_service_factor_value,
            jmc$highest_service_factor_valu], [jmc$number, 1]],
      [2, ['Memory', 'M', * , jmc$number, jmc$lowest_service_factor_value,
            jmc$highest_service_factor_valu], [jmc$number, 1]],
      [3, ['Residence', 'R', * , jmc$number, jmc$lowest_service_factor_value,
            jmc$highest_service_factor_valu], [jmc$number, 1]],
      [4, ['IO', 'IO', *, jmc$number, jmc$lowest_service_factor_value,
            jmc$highest_service_factor_valu], [jmc$number, 1]],

{   DISPATCHING_CONTROL          = list of record
{    DISPATCHING_PRIORITY            = integer
{    SERVICE_TIME                    = integer
{    MINOR_TIMESLICE                 = integer
{    MAJOR_TIMESLICE                 = integer

    [jmc$sc_dispatching_control, ['Dispatching_Control', 'DC',
          jmc$priority_group, jmc$list, 1, * ], [jmc$list, * ]],
      [1, ['Dispatching_Control', '--', jmc$control_group, jmc$type, 4, * ],
          [jmc$type, * ]],
        [1, ['Dispatching_Priority', 'DP', * , jmc$dispatching_priority,
            1, 10], [jmc$dispatching_priority, 5]],
        [2, ['Service_Time', 'ST', * , jmc$number,
            jmc$lowest_service_limit DIV 1000, jmc$highest_service_limit DIV
            1000], [jmc$unlimited]],
        [3, ['Minor_Timeslice', 'MINT', * , jmc$number,
            jmc$lowest_task_time_slice, jmc$highest_task_time_slice],
            [jmc$number, 1]],
        [4, ['Major_Timeslice', 'MAJT', * , jmc$number,
            jmc$lowest_task_time_slice, jmc$highest_task_time_slice],
            [jmc$number, 1]],

{   GUARANTEED_SERVICE_QUANTUM   = integer

    [jmc$sc_guaranteed_service_quan, ['Guaranteed_Service_Quantum', 'GSQ',
          jmc$control_group, jmc$number, jmc$lowest_service_accumulator,
          jmc$highest_service_accumulator], [jmc$number, 100]],

{   CLASS_SERVICE_THRESHOLD      = integer

    [jmc$sc_class_resource_threshold, ['Class_Service_Threshold', 'CST',
          jmc$control_group, jmc$number, jmc$lowest_service_accumulator,
          jmc$highest_service_accumulator], [jmc$unlimited]],

{   NEXT_SERVICE_CLASS           = jmc$profile_service_class

    [jmc$sc_next_service_class, ['Next_Service_Class', 'NSC',
          jmc$control_group, jmc$object, jmc$profile_service_class],
          [jmc$none]],

{   LONG_WAIT_THINK_TIME         = integer

    [jmc$sc_long_wait_think_time, ['Long_Wait_Think_Time', 'LWTT',
          jmc$control_group, jmc$number, jmc$low_long_wait_think_time,
          jmc$high_long_wait_think_time], [jmc$number, 0]],

{   AIO_LIMIT                    = integer

    [jmc$sc_aio_limit, ['AIO_Limit', 'AIOL', jmc$control_group, jmc$number,
          jmc$lowest_aio_limit, jmc$highest_aio_limit], [jmc$number, 60000]],

{   SWAP_AGE_INTERVAL            = integer

    [jmc$sc_swap_age_interval, ['Swap_Age_Interval', 'SAI', jmc$priority_group,
          jmc$number, lowest_prio_age_interval, highest_prio_age_interval],
          [jmc$number, 1]],

{   SCHEDULING_PRIORITY          = record
{    MINIMUM                         = integer
{    MAXIMUM                         = integer
{    SWAP_AGE_INCREMENT              = integer
{    READY_TASK_INCREMENT            = integer

    [jmc$sc_scheduling_priority, ['Scheduling_Priority', 'SP',
          jmc$priority_group, jmc$type, 4, * ], [jmc$type, * ]],
      [1, ['Minimum', 'MIN', * , jmc$number, jmc$lowest_job_priority,
            jmc$highest_job_priority], [jmc$number, 1000]],
      [2, ['Maximum', 'MAX', * , jmc$number, jmc$lowest_job_priority,
            jmc$highest_job_priority], [jmc$number, 10000]],
      [3, ['Swap_Age_Increment', 'SAI', * , jmc$number,
            jmc$lowest_job_priority, jmc$highest_job_priority],
            [jmc$number, 1000]],
      [4, ['Ready_Task_Increment', 'RTI', * , jmc$number,
            jmc$lowest_job_priority, jmc$highest_job_priority],
            [jmc$number, 0]],

{   ACTIVE_JOBS                  = integer (display only)

    [jmc$sc_active_jobs, ['Active_Jobs', 'AJ', jmc$statistic_group, jmc$number,
          0, 0], [jmc$empty]],

{   QUEUED_JOBS                  = integer (display only)

    [jmc$sc_queued_jobs, ['Queued_Jobs', 'QJ', jmc$statistic_group, jmc$number,
          0, 0], [jmc$empty]],

{   SWAPPED_JOBS                 = integer (display only)

    [jmc$sc_swapped_jobs, ['Swapped_Jobs', 'SJ', jmc$statistic_group,
          jmc$number, 0, 0], [jmc$empty]],

{   SERVICE_ACHIEVED_PERCENT     = integer (display only)

{   [jmc$sc_service_achieved_percent, ['Service_Achieved_Percent', 'SAP',
{         jmc$statistic_group, jmc$number, 0, 0], [jmc$empty]]];

{ DEFINITION_NAME                = name (for debug display only)

    [jmc$sc_definition_name, ['Definition_Name', 'DN', jmc$statistic_group,
          jmc$name], [jmc$empty]],

{ SERVICE_CLASS_INDEX            = integer (for debug display only)

    [jmc$sc_index, ['Service_Class_Index', 'SCI', jmc$statistic_group,
          jmc$number, 0, 0], [jmc$empty]]];

?? FMT (FORMAT := ON) ??

  VAR
    service_class_defaults: array [job_and_service_classes] of
          ^attribute_preset_list := [^service_class_interactive,
          ^service_class_batch, ^service_class_system,
          ^service_class_maintenance, ^service_class_unassigned];

?? FMT (FORMAT := OFF) ??

  VAR
    service_class_interactive: array [1 .. 8] of attribute_preset :=
     [[jmc$sc_abbreviation, [jmc$name, ^abbreviation]],
      [jmc$sc_maximum_active_jobs, [jmc$number, 100]],
      [jmc$sc_guaranteed_service_quan, [jmc$number, 9000]],
      [jmc$sc_scheduling_priority, [jmc$type, * ]],
        [1, [jmc$number, 8000]],
        [2, [jmc$number, 17000]],
        [3, [jmc$number, 1000]],
        [4, [jmc$number, 1000]]];

  VAR
    service_class_batch: array [1 .. 3] of attribute_preset :=
     [[jmc$sc_abbreviation, [jmc$name, ^abbreviation]],
      [jmc$sc_maximum_active_jobs, [jmc$number, 50]],
      [jmc$sc_guaranteed_service_quan, [jmc$number, 20000]]];

  VAR
    service_class_system: array [1 .. 13] of attribute_preset :=
     [[jmc$sc_abbreviation, [jmc$name, ^abbreviation]],
      [jmc$sc_guaranteed_service_quan, [jmc$number, 2000]],
      [jmc$sc_scheduling_priority, [jmc$type, * ]],
        [1, [jmc$number, 19000]],
        [2, [jmc$number, 22000]],
        [3, [jmc$number, 1000]],
        [4, [jmc$number, 0]],
      [jmc$sc_dispatching_control, [jmc$list, * ]],
        [1, [jmc$type, * ]],
          [1, [jmc$dispatching_priority, 6]],
          [2, [jmc$unlimited]],
          [3, [jmc$number, 1]],
          [4, [jmc$number, 1]]];

  VAR
    service_class_maintenance: array [1 .. 14] of attribute_preset :=
     [[jmc$sc_abbreviation, [jmc$name, ^abbreviation]],
      [jmc$sc_maximum_active_jobs, [jmc$number, 100]],
      [jmc$sc_guaranteed_service_quan, [jmc$number, 9400]],
      [jmc$sc_scheduling_priority, [jmc$type, * ]],
        [1, [jmc$number, 8000]],
        [2, [jmc$number, 17000]],
        [3, [jmc$number, 1000]],
        [4, [jmc$number, 1000]],
      [jmc$sc_dispatching_control, [jmc$list, * ]],
        [1, [jmc$type, * ]],
          [1, [jmc$dispatching_priority, 6]],
          [2, [jmc$unlimited]],
          [3, [jmc$number, 1]],
          [4, [jmc$number, 1]]];

  VAR
    service_class_unassigned: array [1 .. 3] of attribute_preset :=
     [[jmc$sc_abbreviation, [jmc$name, ^abbreviation]],
      [jmc$sc_maximum_active_jobs, [jmc$number, 0]],
      [jmc$sc_guaranteed_service_quan, [jmc$number, 20000]]];

?? FMT (FORMAT := ON) ??
?? TITLE := 'Output Class Definitions', EJECT ??

?? FMT (FORMAT := OFF) ??

  CONST
    output_class_descriptor_count = 10;

  VAR
    output_class_structure: array [1 .. output_class_descriptor_count] of
        attribute_structure := [

  [1, ['OUTPUT_CLASS', 'OC', * , jmc$type, jmc$oc_maximum_attribute, * ],
          [jmc$type, * ]],

{   ABBREVIATION                 = name

    [jmc$oc_abbreviation, ['Abbreviation', 'A', jmc$definition_group, jmc$name]
,
          [jmc$none]],

{   ENABLE_CLASS_SCHEDULING      = boolean

    [jmc$oc_enable_class_scheduling, ['Enable_Class_Scheduling', 'ECS',
          jmc$definition_group, jmc$boolean], [jmc$boolean, TRUE]],

{   CLASS_CAPABILITIES           = list of name

{   [jmc$oc_class_capabilities, ['Class_Capabilities', 'CC',
{         jmc$control_group, jmc$empty], [jmc$none]],

{   OUTPUT_AGE_INTERVAL          = integer

    [jmc$oc_output_age_interval, ['Output_Age_Interval', 'OAI',
          jmc$priority_group, jmc$number, lowest_prio_age_interval,
          highest_prio_age_interval], [jmc$number, 1]],

{   DELIVERY_PRIORITY            = record
{    MINIMUM                         = integer
{    MAXIMUM                         = integer
{    OUTPUT_AGE_INCREMENT            = integer

    [jmc$oc_delivery_priority, ['Delivery_Priority', 'DP', jmc$priority_group,
          jmc$type, 3, * ], [jmc$type, * ]],
      [1, ['Minimum', 'MIN', * , jmc$number, jmc$lowest_job_priority,
            jmc$highest_job_priority], [jmc$number, 100]],
      [2, ['Maximum', 'MAX', * , jmc$number, jmc$lowest_job_priority,
            jmc$highest_job_priority], [jmc$number, 200]],
      [3, ['Output_Age_Increment', 'OAI', * , jmc$number,
            jmc$lowest_job_priority, jmc$highest_job_priority],
            [jmc$number, 1]],

{ DELIVERY_WAIT_TIME             = record (display only)
{    MINIMUM                         = integer
{    MAXIMUM                         = integer
{    AVERAGE                         = integer
{    NUMBER_OF_FILES                 = integer

{   [jmc$oc_delivery_wait_time, ['Delivery_Wait_Time', 'DWT',
{         jmc$statistic_group, jmc$type, 4, * ], [jmc$empty]],
{     [1, ['Minimum', 'MIN', *, jmc$number, 0, 0], [jmc$number, 0]],
{     [2, ['Maximum', 'MAX', *, jmc$number, 0, 0], [jmc$number, 0]],
{     [3, ['Average', 'A', *, jmc$number, 0, 0], [jmc$number, 0]],
{     [4, ['Number_Of_Files', 'NOF', *, jmc$number, 0, 0], [jmc$number, 0]],

{ DEFINITION_NAME                = name (debug display only)

    [jmc$oc_definition_name, ['Definition_Name', 'DN', jmc$statistic_group,
          jmc$name], [jmc$empty]],

{ OUTPUT_CLASS_INDEX             = integer (debug display only)

    [jmc$oc_index, ['Output_Class_Index', 'OCI', jmc$statistic_group,
          jmc$number, 0, 0], [jmc$empty]]];

?? FMT (FORMAT := ON) ??
?? TITLE := 'Application Definitions', EJECT ??

?? FMT (FORMAT := OFF) ??

  CONST
    application_descriptor_count = 8;

  VAR
    application_structure: array [1 .. application_descriptor_count] of
        attribute_structure := [

  [1, ['APPLICATION', 'A', * , jmc$type, jmc$ap_maximum_attribute, * ],
          [jmc$type, * ]],

{   ENABLE_APPLICATION_SCHEDULING= boolean

    [jmc$ap_enable_application_sched, ['Enable_Application_Scheduling', 'EAS',
          jmc$definition_group, jmc$boolean], [jmc$boolean, TRUE]],

{   ENABLE_ACCOUNTING_STATISTICS = boolean

{   [jmc$ap_enable_accounting_stats, ['Enable_Accounting_Stats', 'EAS',
{         jmc$definition_group, jmc$boolean], [jmc$boolean, FALSE]],

{   SERVICE_CLASS                = jmc$profile_service_class

    [jmc$ap_service_class, ['Service_Class', 'SC', jmc$control_group,
          jmc$object, jmc$profile_service_class], [jmc$unspecified]],

{   MINIMUM_WORKING_SET          = integer

    [jmc$ap_minimum_working_set, ['Minimum_Working_Set', 'MINWS',
          jmc$control_group, jmc$number, jmc$lowest_working_set_size,
          jmc$highest_working_set_size], [jmc$unspecified]],

{   MAXIMUM_WORKING_SET          = integer

    [jmc$ap_maximum_working_set, ['Maximum_Working_Set', 'MAXWS',
          jmc$control_group, jmc$number, jmc$lowest_working_set_size,
          jmc$highest_working_set_size], [jmc$unspecified]],

{   PAGE_AGING_INTERVAL          = integer

    [jmc$ap_page_aging_interval, ['Page_Aging_Interval', 'PAI',
          jmc$control_group, jmc$number, jmc$lowest_aging_interval,
          jmc$highest_aging_interval], [jmc$unspecified]],

{   CYCLIC_AGING_INTERVAL        = integer

    [jmc$ap_cyclic_aging_interval, ['Cyclic_Aging_Interval', 'CAI',
          jmc$control_group, jmc$number, jmc$lowest_aging_interval,
          jmc$highest_aging_interval], [jmc$unspecified]],

{ DEFINITION_NAME                = name (debug display only)

    [jmc$ap_definition_name, ['Definition_Name', 'DN', jmc$statistic_group,
          jmc$name], [jmc$empty]]];

?? FMT (FORMAT := ON) ??
?? TITLE := 'check_categories', EJECT ??

{ PURPOSE:
{   Compare the excluded category and required_category lists to ensure that
{   no element is in both lists.

  PROCEDURE check_categories
    (    the_object: jmt$profile_object;
         excluded_category_index: jmt$object_attribute_index;
         required_category_index: jmt$object_attribute_index;
     VAR status: ost$status);

    VAR
      job_category: jmt$profile_object_reference,
      all_categories: boolean,
      any_categories: boolean,
      duplicate_categories: boolean,
      attribute: jmt$object_attribute,
      i: jmt$object_attribute_index;

    status.normal := TRUE;

    IF the_object.attributes.kind <> jmc$type THEN
      RETURN;
    IFEND;

    job_category := jmv$the_profile.objects [jmc$profile_category];
    WHILE job_category <> NIL DO
      job_category^.profile_index := 0;
      job_category := job_category^.next_object;
    WHILEND;

    any_categories := FALSE;
    all_categories := FALSE;

    attribute := the_object.attributes.attribute_list^
          [excluded_category_index];
    IF attribute.kind = jmc$list THEN
      FOR i := 1 TO UPPERBOUND (attribute.attribute_list^) DO
        IF attribute.attribute_list^ [i].kind = jmc$object THEN
          attribute.attribute_list^ [i].object_p^.profile_index := 1;
          any_categories := TRUE;
        IFEND;
      FOREND;
    ELSEIF attribute.kind = jmc$all THEN
      any_categories := TRUE;
      all_categories := TRUE;
    IFEND;

    duplicate_categories := FALSE;
    attribute := the_object.attributes.attribute_list^
          [required_category_index];
    IF attribute.kind = jmc$list THEN
      IF NOT all_categories THEN

      /scan_categories/
        FOR i := 1 TO UPPERBOUND (attribute.attribute_list^) DO
          IF attribute.attribute_list^ [i].kind = jmc$object THEN
            IF attribute.attribute_list^ [i].object_p^.profile_index = 1 THEN
              duplicate_categories := TRUE;
              EXIT /scan_categories/;
            IFEND;
          IFEND;
        FOREND /scan_categories/;
      ELSE
        duplicate_categories := TRUE;
      IFEND;
    ELSEIF (attribute.kind = jmc$all) AND any_categories THEN
      duplicate_categories := TRUE;
    IFEND;

    IF duplicate_categories THEN
      set_object_error (jme$duplicate_categories, the_object, status);
    IFEND;
  PROCEND check_categories;
?? TITLE := 'check_controls_attributes', EJECT ??

{ PURPOSE:
{   This routine verifies that the controls attribute list is valid.
{
{ DESIGN:
{   This routine checks:
{   o that the object name is a valid mainframe name and
{   o that the excluded_categories and required_categories do not intersect.
{   o that the dispatching allocation is correct.

  PROCEDURE check_controls_attributes
    (    the_object: jmt$profile_object;
     VAR status: ost$status);

?? NEWTITLE := 'check_dispatching_allocation', EJECT ??

{ PURPOSE:
{   This routine verifies that the dispatchin allocation list is valid.
{
{ DESIGN:
{   This routine checks:
{   o that no dispatching priority is given twice and
{   o that the sum of the minimum percentage does not exceed 100 percent.

    PROCEDURE check_dispatching_allocation
      (    dispatching_allocation: jmt$object_attribute;
       VAR status: ost$status);

      TYPE
        priority_set = set of 1 .. 8;

      VAR
        index: 1 .. 8,
        dispatching_entity: ^jmt$object_attribute_list,
        percentage_total: integer,
        priorities: priority_set,
        priority_range: 1 .. 8;

      status.normal := TRUE;
      IF dispatching_allocation.kind <> jmc$editable_list THEN
        RETURN;
      IFEND;

      priorities := $priority_set [];
      percentage_total := 0;
      FOR index := 1 TO UPPERBOUND (dispatching_allocation.attribute_list^) DO
        IF dispatching_allocation.attribute_list^ [index].kind = jmc$type THEN
          dispatching_entity := dispatching_allocation.attribute_list^ [index].
                attribute_list;
          IF dispatching_entity^ [2].kind = jmc$number THEN
            priority_range := 1;
            IF dispatching_entity^ [1].attribute_list^ [2].kind <>
                  jmc$empty THEN
              priority_range := dispatching_entity^ [1].attribute_list^ [2].
                    number - dispatching_entity^ [1].attribute_list^ [1].
                    number + 1;
            IFEND;
            percentage_total := percentage_total + priority_range *
                  dispatching_entity^ [2].number;
            IF percentage_total > 100 THEN
              set_object_error (jme$percent_sums_over_100, the_object, status);
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      FOREND;
    PROCEND check_dispatching_allocation;
?? OLDTITLE, EJECT ??

    VAR
      mainframe_name: pmt$mainframe_id,
      binary_name: pmt$binary_mainframe_id;

    status.normal := TRUE;
    mainframe_name := the_object.name;
    pmp$convert_mainframe_to_binary (mainframe_name, binary_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF the_object.attributes.kind <> jmc$type THEN
      RETURN;
    IFEND;

    check_categories (the_object, jmc$ct_ini_required_categories,
          jmc$ct_ini_excluded_categories, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    check_categories (the_object, jmc$ct_val_required_categories,
          jmc$ct_val_excluded_categories, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    check_dispatching_allocation (the_object.attributes.
          attribute_list^ [jmc$ct_dispatching_allocation], status);
  PROCEND check_controls_attributes;
?? TITLE := 'check_job_class_attributes', EJECT ??

{ PURPOSE:
{   This routine verifies that the job class attribute list is valid.
{
{ DESIGN:
{   This routine checks:
{   o that the excluded_categories and required_categories do not intersect.
{   o that the auto_class_selection is not true for permanent job classes.

  PROCEDURE check_job_class_attributes
    (    the_object: jmt$profile_object;
     VAR status: ost$status);

    status.normal := TRUE;
    IF the_object.attributes.kind <> jmc$type THEN
      RETURN;
    IFEND;

    check_categories (the_object, jmc$jc_required_categories,
          jmc$jc_excluded_categories, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF the_object.permanent AND (the_object.attributes.
          attribute_list^ [jmc$jc_auto_class_selection].kind = jmc$boolean) AND
          the_object.attributes.attribute_list^ [jmc$jc_auto_class_selection].
          bool THEN
      osp$set_status_abnormal (jmc$job_management_id,
            jme$no_ranking_of_default_class, 'Job Class', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            the_object.name, status);
    IFEND;
  PROCEND check_job_class_attributes;
?? TITLE := 'fetch_controls_defaults', EJECT ??

{ PURPOSE
{   Returns the default attributes the specified controls.
{
{ NOTE
{   The defaults must be modified based on mainframe type.  The value for
{   cpu_quantum type varies based on mainframe type.

  PROCEDURE fetch_controls_defaults
    (    profile: jmt$profile_data;
         the_object: jmt$profile_object;
     VAR defaults: jmt$object_attribute);

    VAR
      binary_name: pmt$binary_mainframe_id,
      definition_found: boolean,
      ignored: ost$status,
      mainframe_name: pmt$mainframe_id,
      processor_model_definition: ost$processor_model_definition,
      search_data: ost$processor_search_data;

    mainframe_name := the_object.name;
    pmp$convert_mainframe_to_binary (mainframe_name, binary_name, ignored);

    defaults := object_attribute_defaults [the_object.kind];

    search_data.search_mode := osc$psm_by_pseudo_model_number;
    search_data.pseudo_model_number := binary_name.model_number;
    osp$get_cpu_model_definition (search_data, definition_found,
          processor_model_definition);
    IF definition_found THEN
      defaults.attribute_list^ [jmc$ct_cpu_quantum_time].number :=
            processor_model_definition.quantum;
    ELSE
      defaults.attribute_list^ [jmc$ct_cpu_quantum_time].number := 30000;
    IFEND;

  PROCEND fetch_controls_defaults;
?? TITLE := 'fetch_job_class_defaults', EJECT ??

{ PURPOSE
{   Returns the default attributes for job class objects.
{
{ NOTE
{   The default for service class is set here.

  PROCEDURE fetch_job_class_defaults
    (    profile: jmt$profile_data;
         the_object: jmt$profile_object;
     VAR defaults: jmt$object_attribute);

    VAR
      target_class: jmt$profile_object_reference,
      service_class: jmt$profile_object_reference;

    defaults := object_attribute_defaults [the_object.kind];

    target_class := NIL;
    service_class := profile.objects [jmc$profile_service_class];

  /find_service_class/
    WHILE service_class <> NIL DO
      IF service_class^.name = jmc$unassigned_class_name THEN
        target_class := service_class;
      ELSEIF service_class^.name = the_object.name THEN
        target_class := service_class;
        EXIT /find_service_class/;
      IFEND;
      service_class := service_class^.next_object;
    WHILEND /find_service_class/;
    defaults.attribute_list^ [jmc$jc_initial_service_class].object_p :=
          target_class;

  PROCEND fetch_job_class_defaults;
?? TITLE := 'fetch_standard_defaults', EJECT ??

{ PURPOSE
{   Returns the default attributes for objects of the type of the specified
{   object.
{
{ NOTE
{   This routine is used to only if the defaults can be used as is.

  PROCEDURE fetch_standard_defaults
    (    profile: jmt$profile_data;
         the_object: jmt$profile_object;
     VAR defaults: jmt$object_attribute);

    defaults := object_attribute_defaults [the_object.kind];

  PROCEND fetch_standard_defaults;

?? TITLE := '[XDCL] jmp$build_default_profile', EJECT ??

{ PURPOSE:
{   Initializes the tables defining what the attributes of each object type
{   are and then builds the standard profile.
{
{ NOTES:
{   The standard profile consists of
{      Job categories  INTERACTIVE, BATCH
{      Job classes     INTERACTIVE, BATCH, MAINTENANCE, SYSTEM, UNASSIGNED
{      Service classes INTERACTIVE, BATCH, MAINTENANCE, SYSTEM, UNASSIGNED

  PROCEDURE [XDCL] jmp$build_default_profile
    (VAR status: ost$status);

    VAR
      no_attributes: [STATIC] jmt$object_attribute := [jmc$empty];

?? NEWTITLE := 'build_object_attributes', EJECT ??

{ PURPOSE:
{   Builds the default attributes for the specified object.
{
{ DESIGN:
{   The default attributes are built from a flat static list which gives
{   values for the desired attributes.  The attribute declarations are used
{   to determine the shape of the attribute lists.

    PROCEDURE build_object_attributes
      (    attribute_values: attribute_preset_list;
       VAR object_attribute_definitions: jmt$profile_declaration;
       VAR object_attributes: jmt$object_attribute);

      VAR
        index: jmt$object_attribute_index,
        last_index: jmt$object_attribute_index;

?? NEWTITLE := 'build_attribute', EJECT ??

{ PURPOSE
{   Builds the data structure for an attribute based on the attribute value
{   list.
{
{ DESIGN
{   Since the attribute data is defined recursively, this routine calls
{   itself to build the lower levels of the attribute definition.

      PROCEDURE build_attribute
        (    attribute_definition: jmt$profile_declaration;
         VAR attribute: jmt$object_attribute);

        VAR
          local_attribute: jmt$object_attribute,
          list_size: jmt$object_attribute_index,
          i: jmt$object_attribute_index,
          j: jmt$object_attribute_index;

        IF attribute_definition.kind <= jmc$range THEN
          list_size := attribute_definition.count;
          IF attribute_values [index].list_index > list_size THEN
            list_size := attribute_values [index].list_index;
          IFEND;
          ALLOCATE attribute.attribute_list: [1 .. list_size] IN
                jmv$object_heap^;
          IF attribute.attribute_list = NIL THEN
            jmp$internal_error (10);
          IFEND;
          FOR i := 1 TO list_size DO
            attribute.attribute_list^ [i].kind := jmc$empty;
          FOREND;
          FOR i := 1 TO list_size DO
            j := attribute_values [index].list_index;
            attribute.attribute_list^ [j] := attribute_values [index].
                  attribute;
            index := index + 1;
            IF attribute_definition.kind = jmc$type THEN
              build_attribute (attribute_definition.declarations^ [j]^,
                    attribute.attribute_list^ [j]);
            ELSE
              build_attribute (attribute_definition.declarations^ [1]^,
                    attribute.attribute_list^ [j]);
            IFEND;
            IF index > last_index THEN
              RETURN;
            IFEND;
          FOREND;
        ELSE
          local_attribute := attribute;
          jmp$copy_attributes (local_attribute, attribute);
        IFEND;
      PROCEND build_attribute;
?? OLDTITLE, EJECT ??

      index := 1;
      last_index := UPPERBOUND (attribute_values);
      object_attributes.kind := object_attribute_definitions.kind;
      build_attribute (object_attribute_definitions, object_attributes);
    PROCEND build_object_attributes;
?? TITLE := 'build_object_descriptions', EJECT ??

{ PURPOSE:
{   This routine builds the declaration structure and default attributes
{   for each object type from the flat static declarations lists.
{
{ DESIGN:
{   Builds the declaration and default attribute trees from a static
{   description in flat form.
{
{   A flat list has the form
{     [index  declaration  attribute_value]
{
{   A flat list of the form
{     [1 a*1 aa] [1 b*2 ba] [1 c*0 ca] [2 d*2 da] [1 e*0 ea] [1 f*0 fa] ..
{     [3 g*0 ga]
{
{   builds the following two lists.
{              c                         ca
{      a - b - |   e           aa - ba - |    ea
{              d - |                     da - |
{              |   f                     |    fa
{              g                         ga
{
{ NOTE:
{   Index starts at 2 because the values at index = 1 are used in the call
{   to build_lists.

    PROCEDURE build_object_descriptions
      (VAR object_declarations: structure_list;
       VAR object_definition: jmt$profile_declaration;
       VAR object_attribute_default: jmt$object_attribute);

      VAR
        index: jmt$object_attribute_index,
        last_index: jmt$object_attribute_index;

?? NEWTITLE := 'build_lists', EJECT ??

{ PURPOSE
{   Builds the lists for the attribute definition and for the default
{   values of the attribute.
{
{ DESIGN
{   Since the definition and default value lists for attributes are
{   defined recursively the routine calls itself to define the definitions
{   and default values of the attributes of the attributes.

      PROCEDURE build_lists
        (VAR definition: jmt$profile_declaration;
         VAR default: jmt$object_attribute);

        VAR
          list_size: jmt$object_attribute_index,
          i: jmt$object_attribute_index,
          j: jmt$object_attribute_index;

        IF definition.kind <= jmc$range THEN
          list_size := definition.count;
          ALLOCATE definition.declarations: [1 .. list_size] IN
                jmv$object_heap^;
          ALLOCATE default.attribute_list: [1 .. list_size] IN
                jmv$object_heap^;
          IF (default.attribute_list = NIL) OR
                (definition.declarations = NIL) THEN
            jmp$internal_error (11);
          IFEND;
          FOR i := 1 TO list_size DO
            definition.declarations^ [i] := ^empty_declaration;
            default.attribute_list^ [i].kind := jmc$empty;
          FOREND;
          FOR i := 1 TO list_size DO
            j := object_declarations [index].list_index;
            definition.declarations^ [j] := ^object_declarations [index].
                  definition;
            default.attribute_list^ [j] := object_declarations [index].default;
            index := index + 1;
            build_lists (definition.declarations^ [j]^,
                  default.attribute_list^ [j]);
            IF index > last_index THEN
              RETURN;
            IFEND;
          FOREND;
        IFEND;
      PROCEND build_lists;
?? OLDTITLE, EJECT ??

      index := 2;
      last_index := UPPERBOUND (object_declarations);
      object_definition := object_declarations [1].definition;
      object_attribute_default := object_declarations [1].default;
      build_lists (object_definition, object_attribute_default);
    PROCEND build_object_descriptions;
?? TITLE := 'build_job_and_service_classes', EJECT ??

{ PURPOSE
{   Build the standard job and service classes for the default profile.
{
{ NOTE
{   The initial service class for each job class is the service class
{   with the same name.

    PROCEDURE build_job_and_service_classes
      (VAR status: ost$status);

      VAR
        class_name: [STATIC, READ] array [job_and_service_classes] of
              string (12) := [jmc$interactive_class_name, jmc$batch_class_name,
              jmc$system_class_name, jmc$maintenance_class_name,
              jmc$unassigned_class_name],
        class_index: [STATIC, READ] array [job_and_service_classes] of
              jmt$object_attribute_index := [jmc$lowest_site_job_class,
              jmc$lowest_site_job_class + 1, jmc$system_job_class,
              jmc$maintenance_job_class, jmc$unassigned_job_class];

      VAR
        class: job_and_service_classes,
        job_class: jmt$profile_object_reference,
        service_class: jmt$profile_object_reference;

      status.normal := TRUE;

      FOR class := interactive TO unassigned DO
        abbreviation := class_name [class] (1);

        jmp$add_object (jmc$profile_service_class, class_name [class],
              no_attributes, service_class, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        jmp$add_object (jmc$profile_job_class, class_name [class],
              no_attributes, job_class, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF class > batch THEN
          service_class^.permanent := TRUE;
          job_class^.permanent := TRUE;
        IFEND;

        service_class^.index := class_index [class];
        job_class^.index := class_index [class];

        build_object_attributes (service_class_defaults [class]^,
              jmv$object_definition [jmc$profile_service_class].declaration,
              service_class^.attributes);
        build_object_attributes (job_class_defaults [class]^,
              jmv$object_definition [jmc$profile_job_class].declaration,
              job_class^.attributes);

        service_class^.definition_id := class_name [class];
        service_class^.behaviour_id := jmc$standard_behaviour;
        job_class^.definition_id := class_name [class];
        job_class^.behaviour_id := jmc$standard_behaviour;
      FOREND;
    PROCEND build_job_and_service_classes;
?? TITLE := 'build_job_categories', EJECT ??

{  PURPOSE
{    This procedure builds the default job categories of INTERACTIVE and
{    BATCH for the standard profile.

    PROCEDURE build_job_categories
      (VAR status: ost$status);

      CONST
        interactive_category_index = 1,
        batch_category_index = 2;

      TYPE
        category_indicies = interactive_category_index .. batch_category_index;

      CONST
        interactive_category_name = 'INTERACTIVE',
        batch_category_name = 'BATCH';

      VAR
        category_name: [STATIC, READ] array [category_indicies] of
              ost$name := [interactive_category_name, batch_category_name];

      VAR
        category_index: category_indicies,
        job_category: jmt$profile_object_reference;

      status.normal := TRUE;

      FOR category_index := LOWERVALUE (category_indicies)
            TO UPPERVALUE (category_indicies) DO
        jmp$add_object (jmc$profile_category, category_name [category_index],
              no_attributes, job_category, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        job_category^.index := category_index;

        category_default [2].attribute.name := ^category_name [category_index];

        build_object_attributes (category_default,
              jmv$object_definition [jmc$profile_category].declaration,
              job_category^.attributes);

{ Store references to the job categories in the job class attributes.
{ Batch and System have excluded_categories = interactive.
{ Interactive has excluded_categories = batch.

        IF category_index = interactive_category_index THEN
          job_class_batch [2].attribute.object_p := job_category;
          job_class_system [2].attribute.object_p := job_category;
        ELSE
          job_class_interactive [2].attribute.object_p := job_category;
        IFEND;

        job_category^.definition_id := category_name [category_index];
        job_category^.behaviour_id := jmc$standard_behaviour;
      FOREND;
    PROCEND build_job_categories;
?? TITLE := 'build_sorted_parameter_list', EJECT ??

{ PURPOSE:
{   This procedure builds a sorted parameter list from the declaration
{   for the object's attributes.

    PROCEDURE build_sorted_parameter_list
      (    declaration_list: jmt$profile_declaration_list;
       VAR parameter_list: ^jmt$object_parameter_list);

?? NEWTITLE := 'sort_parameters', EJECT ??

{ PURPOSE
{   This procedure sorts a parameter list by name.
{
{ DESIGN:
{   The sort used is a shell sort.

      PROCEDURE sort_parameters
        (VAR parameter_list: jmt$object_parameter_list);

        VAR
          gap: integer,
          starting_index: integer,
          current_index: integer,
          current_element: jmt$object_parameter_element;

{ Use shell sort technique.

        gap := 1;
        REPEAT
          gap := gap * 3 + 1;
        UNTIL gap > UPPERBOUND (parameter_list);

        WHILE gap > 1 DO
          gap := gap DIV 3;
          FOR starting_index := gap + 1 TO UPPERBOUND (parameter_list) DO
            current_index := starting_index;
            current_element := parameter_list [current_index];
            WHILE (current_index > gap) AND (current_element.name <
                  parameter_list [current_index - gap].name) DO
              parameter_list [current_index] :=
                    parameter_list [current_index - gap];
              current_index := current_index - gap;
            WHILEND;
            parameter_list [current_index] := current_element;
          FOREND;
        WHILEND;

      PROCEND sort_parameters;
?? OLDTITLE, EJECT ??

      VAR
        declaration_index: jmt$object_attribute_index,
        list_length: integer,
        unsorted_parameters: ^jmt$object_parameter_list,
        parameter_element: ^jmt$object_parameter_element;

      RESET jmv$working_storage;
      list_length := 0;
      FOR declaration_index := LOWERBOUND (declaration_list)
            TO UPPERBOUND (declaration_list) DO
        IF declaration_list [declaration_index] <> ^empty_declaration THEN
          NEXT parameter_element IN jmv$working_storage;
          #TRANSLATE (osv$lower_to_upper, declaration_list
                [declaration_index]^.name, parameter_element^.name);
          parameter_element^.attribute_index := declaration_index;
          parameter_element^.abbreviation := FALSE;
          NEXT parameter_element IN jmv$working_storage;
          parameter_element^.name := declaration_list [declaration_index]^.
                abbreviation;
          parameter_element^.attribute_index := declaration_index;
          parameter_element^.abbreviation := TRUE;
          list_length := list_length + 2;
        IFEND;
      FOREND;

      RESET jmv$working_storage;
      NEXT unsorted_parameters: [1 .. list_length] IN jmv$working_storage;
      ALLOCATE parameter_list: [1 .. list_length] IN jmv$object_heap^;
      parameter_list^ := unsorted_parameters^;

      sort_parameters (parameter_list^);

    PROCEND build_sorted_parameter_list;

?? TITLE := 'build_standard_controls', EJECT ??

{ PURPOSE
{   This procedure builds the controls for the standard profile.  The controls
{   are built for the mainframe on which the utility is run.

    PROCEDURE build_standard_controls
      (VAR status: ost$status);

      VAR
        controls: jmt$profile_object_reference;

      status.normal := TRUE;

      jmp$add_object (jmc$profile_controls, mainframe_id, no_attributes,
            controls, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      controls^.definition_id := mainframe_id;
      controls^.behaviour_id := jmc$standard_behaviour;
      controls^.index := 1;
    PROCEND build_standard_controls;
?? TITLE := 'update_dynamic_defaults', EJECT ??

{ PURPOSE
{   Update the job class and service class default attributes
{   with those values that depend on the deadstart.

    PROCEDURE update_dynamic_defaults
      (VAR status: ost$status);

      VAR
        job_class_defaults: jmt$job_class_attributes,
        service_class_defaults: jmt$service_class_attributes,
        application_defaults: jmt$application_attributes;

      status.normal := TRUE;

      jmp$get_default_class_values (job_class_defaults, service_class_defaults,
            application_defaults, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      object_attribute_defaults [jmc$profile_job_class].
            attribute_list^ [jmc$jc_page_aging_interval].attribute_list^ [1].
            number := job_class_defaults.page_aging_interval.default;

    PROCEND update_dynamic_defaults;
?? OLDTITLE, EJECT ??

    VAR
      control_default: clt$data_value,
      initial_call: [STATIC] boolean := TRUE,
      object_kind: jmt$profile_object_kinds,
      segment_pointer: amt$segment_pointer;

    status.normal := TRUE;

    IF initial_call THEN

      pmp$get_mainframe_id (mainframe_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Create heap for allocating objects and their attributes.

      mmp$create_scratch_segment (amc$heap_pointer, mmc$as_random,
            segment_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      jmv$object_heap := segment_pointer.heap_pointer;

{ Create sequence for temporary storage of data.

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random,
            segment_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      jmv$working_storage := segment_pointer.sequence_pointer;
      initial_call := FALSE;
    IFEND;

    RESET jmv$object_heap^;
    RESET jmv$working_storage;

    FOR object_kind := LOWERVALUE (object_kind) TO UPPERVALUE (object_kind) DO
      jmv$current_class_name [object_kind] := NIL;
    FOREND;

{ Build internal tables.

    FOR object_kind := LOWERVALUE (object_kind) TO UPPERVALUE (object_kind) DO
      build_object_descriptions (object_structure [object_kind]^,
            jmv$object_definition [object_kind].declaration,
            object_attribute_defaults [object_kind]);
      IF jmv$object_definition [object_kind].declaration.kind = jmc$type THEN
        build_sorted_parameter_list (jmv$object_definition [object_kind].
              declaration.declarations^, jmv$object_definition [object_kind].
              sorted_parameters);
      IFEND;
      jmv$new_profile.objects [object_kind] := NIL;
      jmv$new_profile.count [object_kind] := 0;
    FOREND;
    jmv$the_profile := jmv$new_profile;

    build_object_attributes (ds_priority_control_default,
          jmv$object_definition [jmc$profile_controls].declaration.
          declarations^ [jmc$ct_dual_state_prio_control]^,
          object_attribute_defaults [jmc$profile_controls].
          attribute_list^ [jmc$ct_dual_state_prio_control]);

    update_dynamic_defaults (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Create controls for this mainframe.

    build_standard_controls (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Create standard job categories.

    build_job_categories (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Create the standard output classes.

{ Create the standard job and service classes.

    build_job_and_service_classes (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmv$the_profile.definition_id := jmv$the_profile.
          objects [jmc$profile_controls]^.definition_id;

    jmp$set_object_default (jmc$profile_category, NIL);
    jmp$set_object_default (jmc$profile_service_class, NIL);
    jmp$set_object_default (jmc$profile_job_class, NIL);

  PROCEND jmp$build_default_profile;
?? TITLE := '[XDCL, #GATE] jmp$internal_error', EJECT ??

{ PURPOSE:
{   Issues the message 'Internal profile error #n.'

  PROCEDURE [XDCL, #GATE] jmp$internal_error
    (    location: integer);

    VAR
      number: string (10),
      string_size: integer,
      status: ost$status;

    STRINGREP (number, string_size, location);
    osp$set_status_abnormal (jmc$job_management_id, jme$profile_internal_error,
          number, status);
    pmp$abort (status);
  PROCEND jmp$internal_error;
?? TITLE := '[XDCL] jmp$set_profile', EJECT ??

{ PURPOSE:
{   Makes the specified profile the working profile.
{
{ DESIGN:
{   It moves the provided profile to jmv$the_profile.
{   It finds the UNASSIGNED service class in the profile and stores a reference
{   to it in the default for the 'INITIAL_SERVICE_CLASS' attribute for
{   job classes.
{
{ FUTURE:
{   When output classes are implemented - Find the NORMAL output class in the
{   profile and store a reference to it in the default for the attribute
{   'INITIAL_OUTPUT_CLASS' for job classes.

  PROCEDURE [XDCL] jmp$set_profile
    (VAR profile: jmt$profile_data);

    VAR
      control_default: clt$data_value,
      deleted_object: jmt$profile_object_reference,
      next_object: jmt$profile_object_reference,
      object_kind: jmt$profile_object_kinds,
      service_class: jmt$profile_object_reference;

    FOR object_kind := LOWERVALUE (object_kind) TO UPPERVALUE (object_kind) DO
      deleted_object := jmv$the_profile.objects [object_kind];
      WHILE deleted_object <> NIL DO
        jmp$delete_attributes (deleted_object^.attributes);
        deleted_object := deleted_object^.next_object;
      WHILEND;
    FOREND;

    FOR object_kind := LOWERVALUE (object_kind) TO UPPERVALUE (object_kind) DO
      deleted_object := jmv$the_profile.objects [object_kind];
      WHILE deleted_object <> NIL DO
        next_object := deleted_object^.next_object;
        FREE deleted_object IN jmv$object_heap^;
        deleted_object := next_object;
      WHILEND;
      jmv$the_profile.objects [object_kind] := profile.objects [object_kind];
      profile.objects [object_kind] := NIL;
      jmp$set_object_default (jmc$profile_controls, NIL);
    FOREND;

    control_default.kind := clc$name;
    control_default.name_value := mainframe_id;
    jmp$set_object_default (jmc$profile_controls, ^control_default);
    jmv$the_profile.definition_id := profile.definition_id;
    jmv$the_profile.count := profile.count;

    jmv$current_profile_level := jmc$profile_job_class;

  PROCEND jmp$set_profile;
?? TITLE := 'set_object_error', EJECT ??

{ PURPOSE:
{   This routine builds an error message including both the object name
{   and object kind.

  PROCEDURE set_object_error
    (    the_error: ost$status_condition_code;
         the_object: jmt$profile_object;
     VAR status: ost$status);

    osp$set_status_abnormal (jmc$job_management_id, the_error, the_object.name,
          status);
    osp$append_status_parameter (osc$status_parameter_delimiter,
          jmv$object_definition [the_object.kind].declaration.name, status);
  PROCEND set_object_error;
MODEND jmm$administer_definitions;
*DECK DECK=JMM$ADMINISTER_DISPLAY EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Scheduling : administer_display' ??
MODULE jmm$administer_display;

{ PURPOSE:
{   This modules contains the generic routines used to display objects
{   and attributes of objects from the scheduling profile.  All knowledge of
{   how to display an object and its attributes is kept here.
{
{ DESIGN:
{   Each entry point into this routine obtains the display file name,
{   opens the display file, obtains the objects to be displayed and
{   calls (if necessary) procedures to display the attributes of the object.
{
{ NOTES:
{   Objects are Job classes, service classes, etc.  Attributes are the
{   attributes of the job class, service class, etc.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cyd$run_time_error_condition
*copyc jmc$class_names
*copyc jmc$job_management_id
*copyc jme$object_display_errors
*copyc jmt$profile_changes
*copyc jmt$profile_object_list
*copyc jmt$profile_set
?? POP ??
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$trimmed_string_size
*copyc jmp$get_object
*copyc jmp$get_attributes_for_display
*copyc jmp$internal_error
*copyc jmp$set_object_default
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc pmp$continue_to_cause

*copyc jmv$dispatching_priority_names
*copyc jmv$object_definition
*copyc jmv$the_profile
*copyc jmv$working_storage
*copyc osv$upper_to_lower
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??

  VAR
    object_name: [READ] array [jmt$profile_object_kinds] of string (20) :=
          ['Job Categories', 'Priorities', 'Output Categories', 'Reserved',
          'Controls', 'Job Classes', 'Service Classes', 'Output Classes',
          'Applications'],

    group_names: [READ] array [jmt$profile_group] of string (10) :=
          ['DEFINITION', 'CONTROL', 'LIMIT', 'MEMBERSHIP', 'PRIORITY',
          'STATISTIC', '-'];

  TYPE
    group_sets = array [jmt$profile_group] of jmt$profile_set;

?? NEWTITLE := 'display variables', EJECT ??

  VAR
    default_output_file: ^fst$file_reference := ^standard_output,
    display_control: clt$display_control,
    output_file_name: ^fst$file_reference,
    ring_attributes: [STATIC] amt$ring_attributes :=
          [osc$user_ring, osc$user_ring, osc$user_ring],
    standard_output: string (7) := '$OUTPUT';

*copy clv$display_variables
*copyc clp$new_page_procedure
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle', EJECT ??

{ PURPOSE:
{   Dummy routine for the display procedures to call when they wish to
{   display a subtitle.

  PROCEDURE put_subtitle
    (VAR display_control: clt$display_control;
     VAR status: ost$status);

  PROCEND put_subtitle;
?? TITLE := 'display_object_attribute', EJECT ??

{ PURPOSE:
{   Displays the attributes from a single object to the display file.
{
{ DESIGN:
{   The value must be a type to be displayed.  Each sub value of this type
{   is an attribute of the object so this routine displays the name of the
{   attribute, a ':' or '=', and then the value.  Each attribute is displayed
{   on a seperate line.  It calls a nested routine to display the value of
{   the object attribute since it is best done in a recursive manner.
{
{ NOTES:
{   The display file must be previously opened and the information on the
{   file kept in the variable 'display_control'.

  PROCEDURE display_object_attribute
    (    object_attributes: jmt$object_attribute;
         attributes_to_display: jmt$profile_set;
         attribute_structure: jmt$profile_declaration;
         sorted_parameters: jmt$object_parameter_list;
         suppress_empty_attributes: boolean;
         building_command_file: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'display_item', EJECT ??

{ PURPOSE:
{   Used by the enclosing procedure to display the attributes for an attribute
{   of an object.
{
{ DESIGN:
{   A value is displayed according to its contained type.  Structured types
{   like lists, types, and ranges are displayed by recursively calling this
{   routine to display the sub attributes.  Before an atomic value is written
{   to the display the routine ensures that it will fit on the line and starts
{   a new line if necessary.  A new line is started for a list or type if
{   the current position is too close to the end of the line in order to
{   keep most structures together in the display.  If a new line is started
{   and the building_command_file flag is true it writes an elipsis at the
{   end of the previous line (for command language compatible input).

    PROCEDURE display_item
      (    object_attributes: jmt$object_attribute;
       VAR status: ost$status);

      VAR
        dispatching_priority_name: ost$name,
        display_line: ost$string,
        i: integer;

      CASE object_attributes.kind OF

      = jmc$list, jmc$type, jmc$editable_list =
        IF UPPERBOUND (object_attributes.attribute_list^) = 1 THEN
          IF object_attributes.attribute_list^ [1].kind > jmc$range THEN
            display_item (object_attributes.attribute_list^ [1], status);
            RETURN;
          IFEND;
        IFEND;

        IF display_control.column_number > 40 THEN
          clp$put_partial_display (display_control, '..', clc$no_trim,
                amc$terminate, status);
          clp$horizontal_tab_display (display_control, 10, status);
        IFEND;

        display_line.value (1) := '(';
        display_line.size := 1;
        FOR i := 1 TO UPPERBOUND (object_attributes.attribute_list^) DO
          clp$put_partial_display (display_control, display_line.value (1, 1),
                clc$no_trim, amc$continue, status);
          display_item (object_attributes.attribute_list^ [i], status);
          display_line.value (1) := ' ';
        FOREND;
        display_line.value (1) := ')';

      = jmc$range =
        display_item (object_attributes.attribute_list^ [1], status);
        IF object_attributes.attribute_list^ [2].kind <> jmc$empty THEN
          clp$put_partial_display (display_control, '..', clc$no_trim,
                amc$continue, status);
          display_item (object_attributes.attribute_list^ [2], status);
        IFEND;
        RETURN;

      = jmc$object =
        display_line.size := clp$trimmed_string_size
              (object_attributes.object_p^.name);
        #TRANSLATE (osv$upper_to_lower, object_attributes.object_p^.name,
              display_line.value (1, display_line.size));

      = jmc$number =
        clp$convert_integer_to_string (object_attributes.number, 10, FALSE,
              display_line, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = jmc$boolean =
        display_line.size := 5;
        display_line.value (1, 5) := 'false';
        IF object_attributes.bool THEN
          display_line.size := 4;
          display_line.value (1, 4) := 'true';
        IFEND;

      = jmc$file =
        #TRANSLATE (osv$upper_to_lower, object_attributes.file^,
              display_line.value);
        display_line.size := clp$trimmed_string_size (display_line.value);

      = jmc$name =
        display_line.size := clp$trimmed_string_size (object_attributes.name^);
        #TRANSLATE (osv$upper_to_lower, object_attributes.name^,
              display_line.value (1, display_line.size));

      = jmc$dispatching_priority =
        dispatching_priority_name := 'UNKNOWN';
        IF ((LOWERBOUND (jmv$dispatching_priority_names) <=
              object_attributes.number) AND (object_attributes.
              number <= UPPERBOUND (jmv$dispatching_priority_names))) THEN
          dispatching_priority_name := jmv$dispatching_priority_names [
                object_attributes.number];
        IFEND;
        display_line.size := clp$trimmed_string_size
              (dispatching_priority_name);
        #TRANSLATE (osv$upper_to_lower, dispatching_priority_name,
              display_line.value);

      = jmc$unspecified =
        display_line.size := 11;
        display_line.value := 'unspecified';

      = jmc$default =
        display_line.size := 7;
        display_line.value := 'default';

      = jmc$all =
        display_line.size := 3;
        display_line.value := 'all';

      = jmc$none =
        display_line.size := 4;
        display_line.value := 'none';

      = jmc$system_default =
        display_line.size := 14;
        display_line.value := 'system_default';

      = jmc$unlimited =
        display_line.size := 9;
        display_line.value := 'unlimited';

      = jmc$empty =
        display_line.size := 7;
        display_line.value := 'default';
      CASEND;
      IF (display_control.column_number + display_line.size) >
            (display_control.page_width - 3) THEN
        clp$put_partial_display (display_control, '..', clc$no_trim,
              amc$terminate, status);
        clp$horizontal_tab_display (display_control, 10, status);
      IFEND;
      clp$put_partial_display (display_control, display_line.
            value (1, display_line.size), clc$no_trim, amc$continue, status);
    PROCEND display_item;
?? OLDTITLE ??
?? NEWTITLE := 'display_complex_item', EJECT ??

    PROCEDURE display_complex_item
      (    object_attributes: jmt$object_attribute;
           attribute_structure: jmt$profile_declaration;
           depth: integer;
       VAR status: ost$status);

      VAR
        display_line: string (40),
        j: integer,
        i: integer;

      CASE object_attributes.kind OF

      = jmc$list =
        IF attribute_structure.declarations^ [1]^.kind > jmc$range THEN
          clp$horizontal_tab_display (display_control, 43, status);
          clp$put_partial_display (display_control, ': ', clc$no_trim,
                amc$continue, status);
          display_item (object_attributes, status);
          RETURN;
        IFEND;

        FOR i := 1 TO UPPERBOUND (object_attributes.attribute_list^) DO
          clp$put_partial_display (display_control, ' ', clc$no_trim,
                amc$terminate, status);
          clp$horizontal_tab_display (display_control, 2 * depth, status);
          STRINGREP (display_line, j, '[', i, ']');
          clp$put_partial_display (display_control, display_line (1, j),
                clc$no_trim, amc$continue, status);
          display_complex_item (object_attributes.attribute_list^ [i],
                attribute_structure.declarations^ [1]^, depth + 1, status);
        FOREND;

      = jmc$editable_list =
        IF attribute_structure.declarations^ [1]^.kind > jmc$range THEN
          clp$horizontal_tab_display (display_control, 43, status);
          clp$put_partial_display (display_control, ': ', clc$no_trim,
                amc$continue, status);
          display_item (object_attributes, status);
          RETURN;
        IFEND;

        FOR i := 1 TO UPPERBOUND (object_attributes.attribute_list^) DO
          IF i > 1 THEN
            clp$put_partial_display (display_control, ' ', clc$no_trim,
                  amc$terminate, status);
            clp$horizontal_tab_display (display_control, 2 * depth + 2,
                  status);
            clp$put_partial_display (display_control, '-', clc$no_trim,
                  amc$continue, status);
          IFEND;
          display_complex_item (object_attributes.attribute_list^ [i],
                attribute_structure.declarations^ [1]^, depth, status);
        FOREND;

      = jmc$type =
        FOR i := 1 TO UPPERBOUND (object_attributes.attribute_list^) DO
          clp$put_partial_display (display_control, ' ', clc$no_trim,
                amc$terminate, status);
          clp$horizontal_tab_display (display_control, 2 * depth, status);
          display_line := attribute_structure.declarations^ [i]^.name;
          clp$put_partial_display (display_control, display_line, clc$trim,
                amc$continue, status);
          display_complex_item (object_attributes.attribute_list^ [i],
                attribute_structure.declarations^ [i]^, depth + 1, status);
        FOREND;

      ELSE
        clp$horizontal_tab_display (display_control, 43, status);
        clp$put_partial_display (display_control, ': ', clc$no_trim,
              amc$continue, status);
        display_item (object_attributes, status);
      CASEND;
    PROCEND display_complex_item;
?? OLDTITLE, EJECT ??

    VAR
      display_line: string (50),
      something_displayed: boolean,
      j: integer,
      i: integer;

    status.normal := TRUE;
    IF object_attributes.kind <> jmc$type THEN
      RETURN;
    IFEND;

    IF attributes_to_display = $jmt$profile_set [] THEN
      RETURN;
    IFEND;

    something_displayed := FALSE;

  /display_attributes/
    FOR j := 1 TO UPPERBOUND (sorted_parameters) DO
      IF sorted_parameters [j].abbreviation THEN
        CYCLE /display_attributes/;
      IFEND;
      i := sorted_parameters [j].attribute_index;

      IF NOT (i IN attributes_to_display) OR
            (attribute_structure.declarations^ [i]^.kind = jmc$empty) THEN
        CYCLE /display_attributes/;
      IFEND;

      IF (object_attributes.attribute_list^ [i].kind = jmc$empty) OR
            (object_attributes.attribute_list^ [i].kind = jmc$default) THEN
        IF (attribute_structure.declarations^ [i]^.group =
              jmc$statistic_group) OR suppress_empty_attributes THEN
          CYCLE /display_attributes/;
        IFEND;
      IFEND;
      something_displayed := TRUE;
      IF building_command_file THEN
        display_line := ' ';
        display_line (2, * ) := '..';
        clp$put_partial_display (display_control, display_line (1, 3),
              clc$no_trim, amc$continue, status);
      IFEND;
      display_line := ' ';
      display_line (4, * ) := attribute_structure.declarations^ [i]^.name;
      IF building_command_file THEN
        display_line (35, 1) := '=';
        clp$put_partial_display (display_control, display_line (1, 36),
              clc$no_trim, amc$start, status);
        display_item (object_attributes.attribute_list^ [i], status);
      ELSE
        clp$put_partial_display (display_control, display_line (1, 36),
              clc$trim, amc$start, status);
        display_complex_item (object_attributes.attribute_list^ [i],
              attribute_structure.declarations^ [i]^, 3, status);
      IFEND;
    FOREND /display_attributes/;
    IF something_displayed THEN
      clp$put_partial_display (display_control, ' ', clc$trim, amc$terminate,
            status);
    IFEND;

  PROCEND display_object_attribute;
?? TITLE := 'get_attributes', EJECT ??

{ PURPOSE:
{   Determine which attributes were specified on the DISPLAY_OPTIONS parameter
{   of the display command.
{
{ DESIGN:
{   For each name specified on the DISPLAY_OPTIONS parameter compare it
{   against the parameter names and abbreviations in the provided declaration.
{   The result is returned as a set.  The option 'ALL' is treated as a
{   special case.

  PROCEDURE get_attributes
    (    attribute_list: ^clt$data_value;
         sorted_parameters: jmt$object_parameter_list;
     VAR attributes_to_display: jmt$profile_set;
     VAR status: ost$status);

    VAR
      temp: integer,
      high_index: jmt$object_attribute_index,
      list_item: ^clt$data_value,
      low_index: jmt$object_attribute_index,
      middle_index: jmt$object_attribute_index,
      i: integer;

    attributes_to_display := $jmt$profile_set [];

{ Check if the keyword ALL was given (or no default and not specified).

    IF (attribute_list = NIL) OR (attribute_list^.kind = clc$keyword) THEN
      attributes_to_display := -$jmt$profile_set [];
      RETURN;
    IFEND;

    list_item := attribute_list;

  /found/
    WHILE list_item <> NIL DO
      high_index := UPPERBOUND (sorted_parameters);
      low_index := 1;
      REPEAT
        temp := high_index + low_index;
        middle_index := temp DIV 2;
        IF sorted_parameters [middle_index].name <
              list_item^.element_value^.name_value THEN
          low_index := middle_index + 1;
        ELSEIF sorted_parameters [middle_index].name >
              list_item^.element_value^.name_value THEN
          high_index := middle_index - 1;
        ELSE
          attributes_to_display := attributes_to_display +
                $jmt$profile_set [sorted_parameters [middle_index].
                attribute_index];
          list_item := list_item^.link;
          CYCLE /found/;
        IFEND;
      UNTIL low_index > high_index;
      osp$set_status_abnormal (jmc$job_management_id, jme$unknown_attribute,
            list_item^.element_value^.name_value, status);
      RETURN;
    WHILEND /found/;

  PROCEND get_attributes;
?? TITLE := 'get_group', EJECT ??

{ PURPOSE:
{   Determine which groups were specified on the GROUP_OPTION parameter of a
{   display command.
{
{ DESIGN:
{   Each name specified on the GROUP_OPTION parameter is searched for in the
{   list of group names.  Finding a name sets the appropriate bit in a set.
{   ALL causes all bits to be set.  Then the attributes are scanned and
{   a bit is set for the attribute in the set it belongs to.  The sets for
{   the selected groups are returned.

  PROCEDURE get_group
    (    group_list: ^clt$data_value;
         attribute_structure: jmt$profile_declaration;
     VAR groups_to_display: group_sets;
     VAR status: ost$status);

    VAR
      group: jmt$profile_group,
      i: integer,
      list_item: ^clt$data_value,
      selected_groups: jmt$group_set;

    selected_groups := $jmt$group_set [];

    FOR group := LOWERVALUE (group) TO UPPERVALUE (group) DO
      groups_to_display [group] := $jmt$profile_set [];
    FOREND;

    FOR i := 1 TO UPPERBOUND (attribute_structure.declarations^) DO
      group := attribute_structure.declarations^ [i]^.group;
      groups_to_display [group] := groups_to_display [group] +
            $jmt$profile_set [i];
    FOREND;

    IF group_list^.kind = clc$keyword {ALL} THEN
      RETURN;
    IFEND;

    list_item := group_list;

  /found/
    WHILE list_item <> NIL DO

      FOR group := LOWERVALUE (group) TO UPPERVALUE (group) DO
        IF (group_names [group] = list_item^.element_value^.name_value) THEN
          selected_groups := selected_groups + $jmt$group_set [group];
          list_item := list_item^.link;
          CYCLE /found/;
        IFEND;
      FOREND;
      osp$set_status_abnormal (jmc$job_management_id, jme$unknown_group_name,
            list_item^.element_value^.name_value, status);
      RETURN;
    WHILEND /found/;

    FOR group := LOWERVALUE (group) TO UPPERVALUE (group) DO
      IF NOT (group IN selected_groups) THEN
        groups_to_display [group] := $jmt$profile_set [];
      IFEND;
    FOREND;

  PROCEND get_group;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$_change_list_option', EJECT ??

{ PURPOSE:
{   This interface processes the CHANGE_LIST_OPTION command for the utility.
{   This command causes all the utility sub commands to redirect their output
{   to an alternate list file.
{
{ DESIGN:
{   If the OUTPUT parameter is specified then save that file as the new
{   default output file.

  PROCEDURE [XDCL] jmp$_change_list_option
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adms_chalo) change_list_option (
{   output, o: file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 34, 51, 457], clc$command, 3, 2, 0, 0, 0,
            0, 2, 'OSM$ADMS_CHALO'], [['O                              ',
            clc$abbreviation_entry, 1], ['OUTPUT                         ',
            clc$nominal_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 2]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$output].specified THEN
      IF default_output_file <> ^standard_output THEN
        FREE default_output_file;
      IFEND;
      ALLOCATE default_output_file: [STRLENGTH (pvt [p$output].value^.
            file_value^)];
      default_output_file^ := pvt [p$output].value^.file_value^;
    IFEND;

  PROCEND jmp$_change_list_option;
?? TITLE := '[XDCL, #GATE] jmp$display_objects', EJECT ??

{ PURPOSE:
{   This routine is called to display a list of objects.
{
{ DESIGN:
{   It obtains the set of attributes to display, opens the display file,
{   and then displays each selected object using the nested routine.
{
{ NOTES:
{   The attributes are selected by the SCL parameter DISPLAY_OPTIONS
{   which is interpreted by this command.  The file used for the display
{   is obtained from the 'OUTPUT' parameter.
{
{   Attributes are displayed in the order of the attributes as stored
{   in the object attributes and not the order that the user specified on the
{   DISPLAY_OPTIONS parameter.

  PROCEDURE [XDCL, #GATE] jmp$display_objects
    (    object_kind: jmt$profile_object_kinds;
         suppress_empty_attributes: boolean;
         object_names: clt$parameter_value;
         attribute_parameter: clt$parameter_value;
         group_parameter: clt$parameter_value;
         output_parameter: clt$parameter_value;
     VAR status: ost$status);

    VAR
      attributes_to_display: jmt$profile_set,
      first_display_line: boolean,
      groups_to_display: group_sets;

?? NEWTITLE := 'abort_handler', EJECT ??

{   PURPOSE:
{     This procedure traps conditions which should abort the display being
{     generated.  In the event the display processor unexpectedly exits, it
{     cleans up by closing the display file.
{     Conditions to abort for are: system, segment access, cybil run time,
{     and interactive terminate break.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF (condition.selector = pmc$system_conditions) OR
            (condition.selector = mmc$segment_access_condition) OR
            ((condition.selector = pmc$user_defined_condition) AND
            (condition.user_condition_name = cye$run_time_condition)) OR
            ((condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break)) THEN
        osp$set_status_from_condition (jmc$job_management_id, condition,
              save_area, handler_status, status);
        EXIT jmp$display_objects;
      ELSEIF (condition.selector = pmc$block_exit_processing) THEN
        clp$close_display (display_control, ignore_status);
        RETURN;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE ??
?? NEWTITLE := 'display_object_by_attribute', EJECT ??

{ PURPOSE:
{   Displays the attributes for a specific object.
{
{ DESIGN:
{   This routine requests the object's displayable_attributes for this kind
{   of object and then displays this fully specified attribute structure
{   Any objects immediatly following the specified object in the list with
{   the same name are also displayed since they are part of this object's
{   definition on the profile.

    PROCEDURE display_object_by_attribute
      (VAR the_object: jmt$profile_object_reference;
       VAR status: ost$status);

      VAR
        display_line: string (256),
        displayable_attributes: jmt$object_attribute,
        i: integer,
        name: ost$name;

      RESET jmv$working_storage;
      name := the_object^.name;
      IF NOT first_display_line THEN
        clp$new_display_line (display_control, 1, status);
      IFEND;
      first_display_line := FALSE;
      display_line := ' ';
      #TRANSLATE (osv$upper_to_lower, the_object^.name, display_line (2, 31));
      REPEAT
        clp$put_display (display_control, display_line, clc$trim, status);
        IF suppress_empty_attributes THEN
          displayable_attributes := the_object^.attributes;
        ELSE
          jmp$get_attributes_for_display (jmv$the_profile, the_object^,
                displayable_attributes, status);
        IFEND;
        display_object_attribute (displayable_attributes,
              attributes_to_display, attribute_structure, sorted_parameters^,
              suppress_empty_attributes, FALSE, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        the_object := the_object^.next_object;
      UNTIL (the_object = NIL) OR (the_object^.name <> name);
    PROCEND display_object_by_attribute;
?? TITLE := 'display_object_by_group', EJECT ??

{ PURPOSE:
{   Displays the attributes for a specific object by groups.
{
{ DESIGN:
{   This routine merges the object's attributes with the default attributes for
{   this kind of object and calls a routine to display this fully specified
{   value structure.  Any objects immediatly following the specified object
{   in the list with the same name are also displayed since they are
{   part of this object's definition on the profile.

    PROCEDURE display_object_by_group
      (VAR the_object: jmt$profile_object_reference;
       VAR status: ost$status);

      VAR
        group_names: [STATIC, READ] array [jmt$profile_group] of string (16) :=
              ['Definition Group', 'Control Group', 'Limit Group',
              'Membership Group', 'Priority Group', 'Statistic Group', '-'];

      VAR
        attributes: jmt$object_attribute,
        display_group: jmt$profile_group,
        display_line: string (34),
        group_display_line: string (20),
        i: integer,
        name: ost$name;

      RESET jmv$working_storage;
      IF NOT first_display_line THEN
        clp$new_display_line (display_control, 1, status);
      IFEND;
      first_display_line := FALSE;
      name := the_object^.name;
      display_line := ' ';
      #TRANSLATE (osv$upper_to_lower, the_object^.name, display_line (2, 31));
      REPEAT
        clp$put_display (display_control, display_line, clc$trim, status);
        IF suppress_empty_attributes THEN
          attributes := the_object^.attributes;
        ELSE
          jmp$get_attributes_for_display (jmv$the_profile, the_object^,
                attributes, status);
        IFEND;
        group_display_line := ' ';
        FOR display_group := LOWERVALUE (display_group)
              TO UPPERVALUE (display_group) DO
          IF groups_to_display [display_group] <> $jmt$profile_set [] THEN
            group_display_line (3, * ) := group_names [display_group];
            clp$put_display (display_control, group_display_line, clc$trim,
                  status);
            display_object_attribute (attributes,
                  groups_to_display [display_group], attribute_structure,
                  sorted_parameters^, suppress_empty_attributes, FALSE,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        FOREND;
        the_object := the_object^.next_object;
      UNTIL (the_object = NIL) OR (the_object^.name <> name);
    PROCEND display_object_by_group;
?? OLDTITLE, EJECT ??

    VAR
      attribute_list: clt$parameter_value,
      attribute_structure: jmt$profile_declaration,
      do_not_care: jmt$profile_object_reference,
      group_list: clt$parameter_value,
      object_list: ^clt$data_value,
      output_file: clt$parameter_value,
      sorted_parameters: ^jmt$object_parameter_list,
      the_object: jmt$profile_object_reference;

    VAR
      display_routine: ^procedure (VAR the_object: jmt$profile_object_reference
                                       ;
                                   VAR status: ost$status);

    attribute_structure := jmv$object_definition [object_kind].declaration;
    sorted_parameters := jmv$object_definition [object_kind].sorted_parameters;

    IF NOT group_parameter.specified THEN
      get_attributes (attribute_parameter.value, sorted_parameters^,
            attributes_to_display, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      display_routine := ^display_object_by_attribute;
      clv$command_name := 'Display of ';
      clv$command_name (12, * ) := object_name [object_kind];
    ELSEIF NOT attribute_parameter.specified THEN
      get_group (group_parameter.value, attribute_structure, groups_to_display,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      display_routine := ^display_object_by_group;
      clv$command_name := 'Display by group of ';
      clv$command_name (21, * ) := object_name [object_kind];
    ELSE
      osp$set_status_condition (jme$cant_specify_both_do_and_go, status);
      RETURN;
    IFEND;

    output_file_name := default_output_file;
    IF output_parameter.specified THEN
      output_file_name := output_parameter.value^.file_value;
    IFEND;

    clp$open_display_reference (output_file_name^, ^clp$new_page_procedure,
          fsc$list, ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^abort_handler, TRUE);
    first_display_line := TRUE;
    clv$titles_built := FALSE;

    object_list := object_names.value;
    IF object_list^.kind = clc$name THEN
      jmp$get_object (object_list^.name_value, object_kind, the_object,
            do_not_care, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      display_routine^ (the_object, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    ELSEIF object_list^.kind = clc$list THEN
      WHILE object_list <> NIL DO
        IF object_list^.element_value <> NIL THEN
          jmp$get_object (object_list^.element_value^.name_value, object_kind,
                the_object, do_not_care, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          display_routine^ (the_object, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          object_list := object_list^.link;
        IFEND;
      WHILEND;

    ELSEIF object_list^.kind = clc$keyword {ALL} THEN
      the_object := jmv$the_profile.objects [object_kind];
      WHILE the_object <> NIL DO
        display_routine^ (the_object, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      WHILEND;
    IFEND;
    jmp$set_object_default (object_kind, object_names.value);

    clp$close_display (display_control, status);
    osp$disestablish_cond_handler;

  PROCEND jmp$display_objects;
?? TITLE := '[XDCL] jmp$display_profile_changes', EJECT ??

{ PURPOSE:
{   Displays the changes in when a profile is activated.

  PROCEDURE [XDCL] jmp$display_profile_changes
    (    the_changes: jmt$profile_changes;
         output_file: clt$parameter_value;
     VAR status: ost$status);

    VAR
      first_display_line: boolean;

?? NEWTITLE := 'abort_handler', EJECT ??

{   PURPOSE:
{     This procedure traps conditions which should abort the display being
{     generated.  In the event the display processor unexpectedly exits, it
{     cleans up by closing the display file.
{     Conditions to abort for are: system, segment access, cybil run time,
{     and interactive terminate break.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF (condition.selector = pmc$system_conditions) OR
            (condition.selector = mmc$segment_access_condition) OR
            ((condition.selector = pmc$user_defined_condition) AND
            (condition.user_condition_name = cye$run_time_condition)) OR
            ((condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break)) THEN
        osp$set_status_from_condition (jmc$job_management_id, condition,
              save_area, handler_status, status);
        EXIT jmp$display_profile_changes;
      ELSEIF (condition.selector = pmc$block_exit_processing) THEN
        clp$close_display (display_control, ignore_status);
        RETURN;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE ??
?? NEWTITLE := 'display_job_list', EJECT ??

{ PURPOSE:
{   Displays a list of jobs with the specified title if the list is not
{   empty.  If the list is empty then nothing is displayed.
{
{ DESIGN:
{   If status of the resubmit of a job was normal then just the name
{   is displayed.  If the status was abnormal then the message
{      'resubmit fail with status'
{   is displayed on the same line as the job name and the status
{   from the resubmit is displayed in the following lines.

    PROCEDURE display_job_list
      (    job_list: jmt$resubmitted_job_list;
           title: string ( * );
       VAR status: ost$status);

      VAR
        display_line: string (clc$wide_page_width),
        message_data: ^ost$status_message,
        message_line_size: ^ost$status_message_line_size,
        message_line_count: ^ost$status_message_line_count,
        message_line_text: ^ost$status_message_line,
        line_index: 1 .. osc$max_status_message_lines,
        i: integer;

      IF job_list = NIL THEN
        RETURN;
      IFEND;

      display_line := ' ';
      PUSH message_data;
      IF NOT first_display_line THEN
        clp$new_display_line (display_control, 1, status);
      IFEND;
      first_display_line := FALSE;

      clp$put_display (display_control, title, clc$trim, status);
      FOR i := 1 TO UPPERBOUND (job_list^) DO
        display_line (4, * ) := job_list^ [i].job_name;
        IF job_list^ [i].status.normal THEN
          clp$put_display (display_control, display_line, clc$trim, status);
        ELSE
          display_line (25, * ) := 'Resubmit failed with status';
          clp$put_display (display_control, display_line, clc$trim, status);
          display_line := ' ';
          osp$format_message (job_list^ [i].status, osc$full_message_level,
                display_control.page_width - 4, message_data^, status);
          RESET message_data;
          NEXT message_line_count IN message_data;
          IF message_line_count = NIL THEN
            jmp$internal_error (30);
          IFEND;
          FOR line_index := 1 TO message_line_count^ DO
            NEXT message_line_size IN message_data;
            IF message_line_size = NIL THEN
              jmp$internal_error (31);
            IFEND;
            NEXT message_line_text: [message_line_size^] IN message_data;
            IF message_line_text = NIL THEN
              jmp$internal_error (32);
            IFEND;
            display_line (4, * ) := message_line_text^;
            clp$put_display (display_control, display_line, clc$trim, status);
          FOREND;
        IFEND;
      FOREND;
    PROCEND display_job_list;
?? TITLE := 'display_name_list', EJECT ??

{ PURPOSE:
{   Displays a list of names with the specified title if the list is not
{   empty.  If the list is empty then nothing at all is displayed.
{
{ NOTE:
{   Duplicate names are suppressed.

    PROCEDURE display_name_list
      (    name_list: jmt$object_name_list;
           title: string ( * );
       VAR status: ost$status);

      VAR
        display_line: string (40),
        previous_name: ost$name,
        i: integer;

      IF name_list = NIL THEN
        RETURN;
      IFEND;

      previous_name := osc$null_name;

      display_line := ' ';
      IF NOT first_display_line THEN
        clp$new_display_line (display_control, 1, status);
      IFEND;
      first_display_line := FALSE;

      clp$put_display (display_control, title, clc$trim, status);
      FOR i := 1 TO UPPERBOUND (name_list^) DO
        IF name_list^ [i] <> previous_name THEN
          previous_name := name_list^ [i];
          #TRANSLATE (osv$upper_to_lower, name_list^ [i], display_line (4,
                31));
          clp$put_display (display_control, display_line, clc$trim, status);
        IFEND;
      FOREND;
    PROCEND display_name_list;
?? OLDTITLE, EJECT ??

    VAR
      title_line: string (80),
      i: integer,
      j: integer;

    VAR
      object_kind_list: [STATIC] array [1 .. 6] of
            jmt$profile_object_kinds := [jmc$profile_category,
            jmc$profile_controls, jmc$profile_job_class,
            jmc$profile_service_class, jmc$profile_output_class,
            jmc$profile_application];

    output_file_name := default_output_file;
    IF output_file.specified THEN
      output_file_name := output_file.value^.file_value;
    IFEND;

    first_display_line := TRUE;

    clp$open_display_reference (output_file_name^, ^clp$new_page_procedure,
          fsc$list, ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^abort_handler, TRUE);
    clv$titles_built := FALSE;
    clv$command_name := 'Activate Profile';

    FOR i := 1 TO UPPERBOUND (object_kind_list) DO
      STRINGREP (title_line, j, ' New ', object_name [object_kind_list [i]]);
      display_name_list (the_changes.objects_changed [object_kind_list [i]].
            new_objects, title_line (1, j), status);
      STRINGREP (title_line, j, ' Changed ',
            object_name [object_kind_list [i]]);
      display_name_list (the_changes.objects_changed [object_kind_list [i]].
            changed_objects, title_line (1, j), status);
      STRINGREP (title_line, j, ' Deleted ',
            object_name [object_kind_list [i]]);
      display_name_list (the_changes.objects_changed [object_kind_list [i]].
            deleted_objects, title_line (1, j), status);
    FOREND;
    title_line := ' All jobs in the following Job Classes were resubmitted.';
    display_name_list (the_changes.move_classes, title_line, status);
    title_line := ' The following jobs were resubmitted.';
    display_job_list (the_changes.resubmitted_jobs, title_line, status);
    IF NOT first_display_line THEN
      clp$new_display_line (display_control, 1, status);
    IFEND;
    clp$put_display (display_control, ' Profile activation complete.',
          clc$trim, status);
    clp$close_display (display_control, status);
    osp$disestablish_cond_handler;

  PROCEND jmp$display_profile_changes;
?? TITLE := '[XDCL] jmp$_display_profile_summary', EJECT ??

{ PURPOSE:
{   Displays the names of all objects on the profile by object type.
{
{ DESIGN:
{   For each object type display the name of this type of object and
{   then the name of each object of that type.  The names are displayed
{   in the order they are on the profile.

  PROCEDURE [XDCL] jmp$_display_profile_summary
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adms_disps) display_profile_summary (
{   display_options, do: any of
{     key all keyend
{     list of key
{       (job_category, jca)
{       (controls, c)
{       (job_class, jcl)
{       (service_class, sc)
{       (application, a)
{     keyend
{    anyend = all
{   output, o: (by_name) file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$keyword_type_qualifier,
              keyword_specs: array [1 .. 10] of clt$keyword_specification,
            recend,
          recend,
          default_value: string (3),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 17, 39, 296], clc$command, 5, 3, 0, 0, 0,
            0, 3, 'OSM$ADMS_DISPS'], [['DISPLAY_OPTIONS                ',
            clc$nominal_entry, 1], ['DO                             ',
            clc$abbreviation_entry, 1], ['O                              ',
            clc$abbreviation_entry, 2], ['OUTPUT                         ',
            clc$nominal_entry, 2], ['STATUS                         ',
            clc$nominal_entry, 3]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 457,
            clc$optional_default_parameter, 0, 3],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 393,
            [[1, 0, clc$list_type], [377, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [10], [[
            'A                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['APPLICATION                    ',
            clc$nominal_entry, clc$normal_usage_entry, 5],
            ['C                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['CONTROLS                       ',
            clc$nominal_entry, clc$normal_usage_entry, 2],
            ['JCA                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['JCL                            ',
            clc$abbreviation_entry, clc$normal_usage_entry, 3],
            ['JOB_CATEGORY                   ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['JOB_CLASS                      ',
            clc$nominal_entry, clc$normal_usage_entry, 3],
            ['SC                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['SERVICE_CLASS                  ',
            clc$nominal_entry, clc$normal_usage_entry, 4]]]], 'all'],

{ PARAMETER 2

      [[1, 0, clc$file_type]],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$display_options = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

?? NEWTITLE := 'abort_handler', EJECT ??

{   PURPOSE:
{     This procedure traps conditions which should abort the display being
{     generated.  In the event the display processor unexpectedly exits, it
{     cleans up by closing the display file.
{     Conditions to abort for are: system, segment access, cybil run time,
{     and interactive terminate break.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF (condition.selector = pmc$system_conditions) OR
            (condition.selector = mmc$segment_access_condition) OR
            ((condition.selector = pmc$user_defined_condition) AND
            (condition.user_condition_name = cye$run_time_condition)) OR
            ((condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break)) THEN
        osp$set_status_from_condition (jmc$job_management_id, condition,
              save_area, handler_status, status);
        EXIT jmp$_display_profile_summary;
      ELSEIF (condition.selector = pmc$block_exit_processing) THEN
        clp$close_display (display_control, ignore_status);
        RETURN;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    TYPE
      object_kind_set = set of jmt$profile_object_kinds;

    VAR
      an_object: jmt$profile_object_reference,
      display_line: string (80),
      display_options: ^clt$data_value,
      first_display_line: boolean,
      i: integer,
      j: integer,
      object_kind: jmt$profile_object_kinds,
      which_object_kinds: object_kind_set;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    which_object_kinds := $object_kind_set [];

    display_options := pvt [p$display_options].value;
    IF display_options^.kind = clc$keyword {ALL} THEN
      which_object_kinds := -$object_kind_set [];
    ELSE
      WHILE display_options <> NIL DO
        IF display_options^.element_value <> NIL THEN
          FOR object_kind := LOWERVALUE (object_kind)
                TO UPPERVALUE (object_kind) DO
            IF jmv$object_definition [object_kind].declaration.name =
                  display_options^.element_value^.name_value THEN
              which_object_kinds := which_object_kinds +
                    $object_kind_set [object_kind];
            IFEND;
          FOREND;
        IFEND;
        display_options := display_options^.link;
      WHILEND;
    IFEND;

    output_file_name := default_output_file;
    IF pvt [p$output].specified THEN
      output_file_name := pvt [p$output].value^.file_value;
    IFEND;

    clp$open_display_reference (output_file_name^, ^clp$new_page_procedure,
          fsc$list, ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^abort_handler, TRUE);
    first_display_line := TRUE;
    clv$titles_built := FALSE;
    clv$command_name := 'Display Profile Summary';

    display_line := ' ';
    FOR object_kind := LOWERVALUE (object_kind) TO UPPERVALUE (object_kind) DO
      IF (object_kind IN which_object_kinds) AND
            (jmv$the_profile.objects [object_kind] <> NIL) THEN
        IF NOT first_display_line THEN
          clp$new_display_line (display_control, 1, status);
        IFEND;
        first_display_line := FALSE;
        display_line := ' Summary of ';
        display_line (13, * ) := object_name [object_kind];
        clp$put_display (display_control, display_line, clc$trim, status);

        display_line := '     ';
        an_object := jmv$the_profile.objects [object_kind];
        REPEAT
          #TRANSLATE (osv$upper_to_lower, an_object^.name,
                display_line (5, 31));
          STRINGREP (display_line (36, 20), i, an_object^.references);
          clp$put_display (display_control, display_line (1, 36 + i - 1),
                clc$no_trim, status);
          an_object := an_object^.next_object;
        UNTIL an_object = NIL;
      IFEND;
    FOREND;

    clp$close_display (display_control, status);
    osp$disestablish_cond_handler;

  PROCEND jmp$_display_profile_summary;
?? TITLE := '[XDCL] jmp$_generate_profile_definitio', EJECT ??

{ PURPOSE:
{   This interface generates a file of ADMINISTER_SCHEDULING commands
{   that will build a profile with the same structure as the current
{   profile - it converts the profile to source.
{
{ DESIGN:
{   The routine writes the 'ADMS' command to enter the utility.  It then
{   writes commands to delete the categories.  Each object type is
{   processed with commands output to delete the deleteable standard
{   objects and then create the objects on the profile of that type.

  PROCEDURE [XDCL] jmp$_generate_profile_definitio
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adms_genpd) generate_profile_definition (
{   generate_option, go: key
{       (full, f), (brief, b)
{     keyend = brief
{   output, o: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
          default_value: string (5),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 36, 19, 426], clc$command, 5, 3, 1, 0, 0,
            0, 3, 'OSM$ADMS_GENPD'], [['GENERATE_OPTION                ',
            clc$nominal_entry, 1], ['GO                             ',
            clc$abbreviation_entry, 1], ['O                              ',
            clc$abbreviation_entry, 2], ['OUTPUT                         ',
            clc$nominal_entry, 2], ['STATUS                         ',
            clc$nominal_entry, 3]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 155,
            clc$optional_default_parameter, 0, 5],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$required_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$keyword_type], [4], [['B                              ',
            clc$abbreviation_entry, clc$normal_usage_entry, 2],
            ['BRIEF                          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['F                              ',
            clc$abbreviation_entry, clc$normal_usage_entry, 1],
            ['FULL                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]], 'brief'],

{ PARAMETER 2

      [[1, 0, clc$file_type]],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$generate_option = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

?? NEWTITLE := 'abort_handler', EJECT ??

{   PURPOSE:
{     This procedure traps conditions which should abort the display being
{     generated.  In the event the display processor unexpectedly exits, it
{     cleans up by closing the display file.
{     Conditions to abort for are: system, segment access, cybil run time,
{     and interactive terminate break.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF (condition.selector = pmc$system_conditions) OR
            (condition.selector = mmc$segment_access_condition) OR
            ((condition.selector = pmc$user_defined_condition) AND
            (condition.user_condition_name = cye$run_time_condition)) OR
            ((condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break)) THEN
        osp$set_status_from_condition (jmc$job_management_id, condition,
              save_area, handler_status, status);
        EXIT jmp$_generate_profile_definitio;
      ELSEIF (condition.selector = pmc$block_exit_processing) THEN
        clp$close_display (display_control, ignore_status);
        RETURN;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

?? FMT (FORMAT := OFF) ??

    VAR
      utility_name: [STATIC] array [jmt$profile_object_kinds] of string (24) :=
       ['                        ', {Job category }
        '                        ', {Job priority }
        '                        ', {Output Category}
        '                        ', {Reserved     }
        'administer_controls     ', {Controls     }
        'administer_job_class    ', {Job Class    }
        'administer_service_class', {Service Class}
        'administer_output_class ', {Output Class }
        'administer_Application  '],{Application  }

      create_name: [STATIC] array [jmt$profile_object_kinds] of string (24) :=
       ['create_job_category     ', {Job category }
        'create_job_priority     ', {Job Priority }
        'create_output_category  ', {Output Category}
        '                        ', {Reserved     }
        'create_controls         ', {Controls     }
        'create_class            ', {Job Class    }
        'create_class            ', {Service Class}
        'create_class            ', {Output Class }
        'create_application      '],{Application  }

      cleanup_commands: [STATIC] array [1 .. 5] of string (40) := [
         ' create_default_profile                ',
         ' administer_job_class                  ',
         '  change_attributes all ec=none rc=none',
         ' quit                                  ',
         ' delete_job_category all               '];

?? FMT (FORMAT := ON) ??

    VAR
      order_of_objects_on_display: [STATIC] array [1 .. 7] of
            jmt$profile_object_kinds := [jmc$profile_priority,
            jmc$profile_category, jmc$profile_controls,
            jmc$profile_output_class, jmc$profile_service_class,
            jmc$profile_job_class, jmc$profile_application];

    VAR
      open_position: [STATIC] clt$open_position := [FALSE];

    VAR
      an_object: jmt$profile_object_reference,
      attribute_structure: jmt$profile_declaration,
      attributes: jmt$object_attribute,
      batch_class: boolean,
      display_line: string (40),
      full_display: boolean,
      i: integer,
      interactive_class: boolean,
      j: integer,
      job_or_service_class: boolean,
      lower_case_name: string (40),
      object_kind: jmt$profile_object_kinds,
      sorted_parameters: ^jmt$object_parameter_list;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$open_display_reference (pvt [p$output].value^.file_value^,
          ^clp$new_page_procedure, fsc$legible_data, ring_attributes,
          display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^abort_handler, TRUE);
    clv$titles_built := FALSE;
    clv$command_name := 'Generate Profile Definition';

    full_display := FALSE;
    IF pvt [p$generate_option].value^.name_value = 'FULL' THEN
      full_display := TRUE;
    IFEND;

    clp$put_display (display_control, 'administer_scheduling', clc$trim,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_line := ' ';
    lower_case_name := ' ';

    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    FOR i := 1 TO UPPERBOUND (cleanup_commands) DO
      clp$put_display (display_control, cleanup_commands [i], clc$trim,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;
    FOR j := LOWERBOUND (order_of_objects_on_display)
          TO UPPERBOUND (order_of_objects_on_display) DO
      object_kind := order_of_objects_on_display [j];
      IF jmv$the_profile.objects [object_kind] <> NIL THEN
        IF object_kind >= jmc$profile_controls THEN
          clp$new_display_line (display_control, 1, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          display_line (2, * ) := utility_name [object_kind];
          clp$put_display (display_control, display_line, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$new_display_line (display_control, 1, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF object_kind = jmc$profile_controls THEN
            clp$put_display (display_control,
                  '  delete_controls $name($mainframe(identifier))', clc$trim,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
          display_line (2) := ' ';
          display_line (3, * ) := create_name [object_kind];
          job_or_service_class := (object_kind = jmc$profile_job_class) OR
                (object_kind = jmc$profile_service_class);
          interactive_class := NOT job_or_service_class;
          batch_class := NOT job_or_service_class;
          an_object := jmv$the_profile.objects [object_kind];
          REPEAT
            IF job_or_service_class AND (an_object^.name =
                  jmc$interactive_class_name) THEN
              interactive_class := TRUE;
            ELSEIF job_or_service_class AND (an_object^.name =
                  jmc$batch_class_name) THEN
              batch_class := TRUE;
            ELSEIF NOT an_object^.permanent THEN
              clp$put_partial_display (display_control, display_line, clc$trim,
                    amc$start, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              #TRANSLATE (osv$upper_to_lower, an_object^.name,
                    lower_case_name (2, 31));
              clp$put_partial_display (display_control, lower_case_name,
                    clc$trim, amc$terminate, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
            an_object := an_object^.next_object;
          UNTIL an_object = NIL;
          IF NOT interactive_class THEN
            clp$put_display (display_control, '  delete_class interactive',
                  clc$trim, status);
          IFEND;
          IF NOT batch_class THEN
            clp$put_display (display_control, '  delete_class batch', clc$trim,
                  status);
          IFEND;
          display_line (2, * ) := ' change_attribute';
        ELSE
          display_line (2, * ) := create_name [object_kind];
        IFEND;

        sorted_parameters := jmv$object_definition [object_kind].
              sorted_parameters;
        attribute_structure := jmv$object_definition [object_kind].declaration;
        an_object := jmv$the_profile.objects [object_kind];
        REPEAT
          clp$new_display_line (display_control, 1, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_partial_display (display_control, display_line, clc$trim,
                amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          #TRANSLATE (osv$upper_to_lower, an_object^.name,
                lower_case_name (2, 31));
          clp$put_partial_display (display_control, lower_case_name, clc$trim,
                amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          attributes := an_object^.attributes;
          IF full_display THEN
            RESET jmv$working_storage;
            jmp$get_attributes_for_display (jmv$the_profile, an_object^,
                  attributes, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
          display_object_attribute (attributes, -$jmt$profile_set [],
                attribute_structure, sorted_parameters^, TRUE, TRUE, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          an_object := an_object^.next_object;
        UNTIL an_object = NIL;
        IF object_kind >= jmc$profile_controls THEN
          clp$put_display (display_control, ' quit', clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    FOREND;
    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$put_display (display_control, 'quit yes', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$close_display (display_control, status);
    osp$disestablish_cond_handler;

  PROCEND jmp$_generate_profile_definitio;
MODEND jmm$administer_display;
*DECK DECK=JMM$ADMINISTER_FUNCTIONS EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Scheduling : administer_functions' ??
MODULE jmm$administer_functions;

{ PURPOSE:
{   Provide the routines to process the functions used in the job
{   scheduling utilities ADMINISTER_SCHEDULING, and MANAGE_ACTIVE_SCHEDULING.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$function_processor_table
*copyc jmc$job_management_id
*copyc jme$object_display_errors
*copyc jme$function_has_no_value
?? POP ??
*copyc clp$evaluate_parameters
*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_name_value
*copyc clp$make_range_value
*copyc clp$make_record_value
*copyc clp$make_unspecified_value
*copyc jmp$get_attributes_for_display
*copyc jmp$get_object
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc pmp$generate_unique_name

*copyc jmv$current_class_name
*copyc jmv$current_profile_level
*copyc jmv$dispatching_priority_names
*copyc jmv$object_definition
*copyc jmv$the_profile
*copyc osv$lower_to_upper
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

{ table jmv$utility_functions function scope=xdcl
{ function $application             p=jmp$$application ..
{   availability=hidden
{ function $controls                p=jmp$$controls ..
{   availability=hidden
{ function $job_class               p=jmp$$job_class ..
{   availability=hidden
{ function $service_class           p=jmp$$service_class ..
{   availability=hidden
{ function $output_class            p=jmp$$output_class ..
{   availability=hidden
{ function $current_application     p=jmp$$current_application
{ function ($current_mainframe $current_controls) p=jmp$$current_controls
{ function $current_job_category    p=jmp$$current_job_category
{ function $current_job_class       p=jmp$$current_job_class
{ function $current_service_class   p=jmp$$current_service_class
{ function $current_output_class    p=jmp$$current_output_class ..
{   availability=hidden
{ function $current_profile_level   p=jmp$$current_profile_level
{ function $profile_identification  p=jmp$$profile_identification ..
{   availability=hidden
{ function $profile_summary         p=jmp$$profile_summary ..
{   availability=hidden
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    jmv$utility_functions: [XDCL, READ] ^clt$function_processor_table :=
          ^jmv$utility_functions_entries,

    jmv$utility_functions_entries: [STATIC,
          READ] array [1 .. 15] of clt$function_proc_table_entry := [
          {} ['$APPLICATION                   ', clc$nominal_entry,
          clc$hidden_entry, 1, clc$linked_call, ^jmp$$application],
          {} ['$CONTROLS                      ', clc$nominal_entry,
          clc$hidden_entry, 2, clc$linked_call, ^jmp$$controls],
          {} ['$CURRENT_APPLICATION           ', clc$nominal_entry,
          clc$normal_usage_entry, 6, clc$linked_call,
          ^jmp$$current_application],
          {} ['$CURRENT_CONTROLS              ', clc$abbreviation_entry,
          clc$normal_usage_entry, 7, clc$linked_call, ^jmp$$current_controls],
          {} ['$CURRENT_JOB_CATEGORY          ', clc$nominal_entry,
          clc$normal_usage_entry, 8, clc$linked_call,
          ^jmp$$current_job_category],
          {} ['$CURRENT_JOB_CLASS             ', clc$nominal_entry,
          clc$normal_usage_entry, 9, clc$linked_call, ^jmp$$current_job_class],
          {} ['$CURRENT_MAINFRAME             ', clc$nominal_entry,
          clc$normal_usage_entry, 7, clc$linked_call, ^jmp$$current_controls],
          {} ['$CURRENT_OUTPUT_CLASS          ', clc$nominal_entry,
          clc$hidden_entry, 11, clc$linked_call, ^jmp$$current_output_class],
          {} ['$CURRENT_PROFILE_LEVEL         ', clc$nominal_entry,
          clc$normal_usage_entry, 12, clc$linked_call,
          ^jmp$$current_profile_level],
          {} ['$CURRENT_SERVICE_CLASS         ', clc$nominal_entry,
          clc$normal_usage_entry, 10, clc$linked_call,
          ^jmp$$current_service_class],
          {} ['$JOB_CLASS                     ', clc$nominal_entry,
          clc$hidden_entry, 3, clc$linked_call, ^jmp$$job_class],
          {} ['$OUTPUT_CLASS                  ', clc$nominal_entry,
          clc$hidden_entry, 5, clc$linked_call, ^jmp$$output_class],
          {} ['$PROFILE_IDENTIFICATION        ', clc$nominal_entry,
          clc$hidden_entry, 13, clc$linked_call, ^jmp$$profile_identification],
          {} ['$PROFILE_SUMMARY               ', clc$nominal_entry,
          clc$hidden_entry, 14, clc$linked_call, ^jmp$$profile_summary],
          {} ['$SERVICE_CLASS                 ', clc$nominal_entry,
          clc$hidden_entry, 4, clc$linked_call, ^jmp$$service_class]];

?? POP ??
?? OLDTITLE ??
?? NEWTITLE := 'attribute', EJECT ??

{ PURPOSE:
{   Processes the $xxx functions which returns the value for the
{   attributes of an xxx object on the profile.  'xxx' may be an
{   application, controls, job_class, service_class, or output_class.
{
{ DESIGN:
{   Locate the desired object, merge the objects attributes with the defaults,
{   determine the attribute to be returned, and return that value.
{

  PROCEDURE build_attributes
    (    profile_level: jmt$profile_object_kinds;
         pvt: array [1 .. 2] of clt$parameter_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    VAR
      temp: integer,
      attribute: jmt$object_attribute,
      attribute_definition: jmt$profile_declaration,
      attribute_index: jmt$object_attribute_index,
      attribute_name: ost$name,
      field_index: jmt$object_attribute_index,
      high_index: jmt$object_attribute_index,
      i: jmt$object_attribute_index,
      ignored: jmt$profile_object_reference,
      low_index: jmt$object_attribute_index,
      middle_index: jmt$object_attribute_index,
      object_parameters: ^jmt$object_parameter_list,
      the_object: jmt$profile_object_reference;

    the_object := jmv$the_profile.objects [profile_level];
    jmp$get_object (pvt [1].value^.name_value, profile_level, the_object,
          ignored, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    attribute_definition := jmv$object_definition [profile_level].declaration;
    object_parameters := jmv$object_definition [profile_level].
          sorted_parameters;

    jmp$get_attributes_for_display (jmv$the_profile, the_object^, attribute,
          status);

    attribute_name := pvt [2].value^.keyword_value;
    IF attribute_name = 'ALL' THEN
      high_index := UPPERBOUND (attribute.attribute_list^);
      FOR i := 1 TO high_index DO
        IF attribute.attribute_list^ [i].kind = jmc$empty THEN
          high_index := high_index - 1;
        IFEND;
      FOREND;

      field_index := 1;
      clp$make_record_value (high_index, work_area, result);
      FOR i := 1 TO UPPERBOUND (object_parameters^) DO
        IF NOT object_parameters^ [i].abbreviation THEN
          attribute_index := object_parameters^ [i].attribute_index;
          IF attribute.attribute_list^ [attribute_index].kind <> jmc$empty THEN
            result^.field_values^ [field_index].name :=
                  object_parameters^ [i].name;
            build_scl_value_from_attribute (attribute.
                  attribute_list^ [attribute_index],
                  attribute_definition.declarations^ [attribute_index]^,
                  work_area, result^.field_values^ [field_index].value,
                  status);
            field_index := field_index + 1;
          IFEND;
        IFEND;
      FOREND;

    ELSE { attribute name specified }
      high_index := UPPERBOUND (object_parameters^);
      low_index := 1;

    /find_attribute/
      REPEAT
        temp := high_index + low_index;
        middle_index := temp DIV 2;
        IF object_parameters^ [middle_index].name < attribute_name THEN
          low_index := middle_index + 1;
        ELSEIF object_parameters^ [middle_index].name > attribute_name THEN
          high_index := middle_index - 1;
        ELSE
          attribute_index := object_parameters^ [middle_index].attribute_index;
          EXIT /find_attribute/;
        IFEND;
      UNTIL low_index > high_index;
      IF low_index > high_index THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$unknown_attribute,
              attribute_name, status);
        RETURN;
      IFEND;

      build_scl_value_from_attribute (attribute.
            attribute_list^ [attribute_index],
            attribute_definition.declarations^ [attribute_index]^, work_area,
            result, status);
    IFEND;

  PROCEND build_attributes;
?? TITLE := 'build_scl_value_from_attribute', EJECT ??

{ PURPOSE:
{   This routine converts the attribute value to an scl value.
{
{ DESIGN:
{   Builds the appropriate scl variable equivalent for the various attribute
{   values.  The keyword attribute values are converted into strings.
{   Attributes that have more then one value are not converted since there
{   are no scl structures that they could map into reliably.

  PROCEDURE build_scl_value_from_attribute
    (    attribute: jmt$object_attribute;
         attribute_definition: jmt$profile_declaration;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    VAR
      variable_dimension: integer,
      element: ^clt$data_value,
      name: ost$name,
      i: integer;

    CASE attribute.kind OF

    = jmc$all =
      clp$make_keyword_value ('ALL', work_area, result);

    = jmc$unspecified =
      clp$make_keyword_value ('UNSPECIFIED', work_area, result);

    = jmc$unlimited =
      clp$make_keyword_value ('UNLIMITED', work_area, result);

    = jmc$system_default =
      clp$make_keyword_value ('SYSTEM_DEFAULT', work_area, result);

    = jmc$none =
      clp$make_keyword_value ('NONE', work_area, result);

    = jmc$object =
      clp$make_name_value (attribute.object_p^.name, work_area, result);

    = jmc$number =
      clp$make_integer_value (attribute.number, 10, FALSE, work_area, result);

    = jmc$dispatching_priority =
      clp$make_name_value (jmv$dispatching_priority_names [attribute.number],
            work_area, result);

    = jmc$boolean =
      clp$make_boolean_value (attribute.bool, clc$true_false_boolean,
            work_area, result);

    = jmc$file =
      clp$make_file_value (attribute.file^, work_area, result);

    = jmc$name =
      clp$make_name_value (attribute.name^, work_area, result);

    = jmc$empty, jmc$default =
      osp$set_status_abnormal (jmc$job_management_id,
            jme$parameter_has_no_value, attribute_definition.name, status);

    = jmc$range =
      clp$make_range_value (work_area, result);
      build_scl_value_from_attribute (attribute.attribute_list^ [1],
            attribute_definition.declarations^ [1]^, work_area,
            result^.low_value, status);
      IF attribute.attribute_list^ [2].kind = jmc$empty THEN
        clp$make_unspecified_value (work_area, result^.high_value);
      ELSE
        build_scl_value_from_attribute (attribute.attribute_list^ [2],
              attribute_definition.declarations^ [1]^, work_area,
              result^.high_value, status);
      IFEND;

    = jmc$list, jmc$editable_list =
      variable_dimension := UPPERBOUND (attribute.attribute_list^);

      result := NIL;
      FOR i := variable_dimension DOWNTO 1 DO
        clp$make_list_value (work_area, element);
        build_scl_value_from_attribute (attribute.attribute_list^ [i],
              attribute_definition.declarations^ [1]^, work_area,
              element^.element_value, status);
        element^.link := result;
        element^.generated_via_list_rest := FALSE;
        result := element;
      FOREND;

    = jmc$type =
      variable_dimension := UPPERBOUND (attribute.attribute_list^);

      clp$make_record_value (variable_dimension, work_area, result);
      FOR i := 1 TO variable_dimension DO
        #TRANSLATE (osv$lower_to_upper, attribute_definition.
              declarations^ [i]^.name, result^.field_values^ [i].name);
        build_scl_value_from_attribute (attribute.attribute_list^ [i],
              attribute_definition.declarations^ [i]^, work_area,
              result^.field_values^ [i].value, status);
      FOREND;
    CASEND;
  PROCEND build_scl_value_from_attribute;
?? TITLE := 'current_object', EJECT ??

{ PURPOSE:
{    Processes functions of the form $CURRENT_object_kind.
{
{ DESIGN:
{    All commands which manipulate an object store the name of that object
{    in jmv$current_class_name.  This function returns that as a name value.

  PROCEDURE current_object
    (    profile_level: jmt$profile_object_kinds;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    VAR
      i: integer,
      entry: ^^clt$data_value,
      name_list: ^array [1 .. * ] of ost$name;

    name_list := jmv$current_class_name [profile_level];
    IF name_list = NIL THEN
      osp$set_status_abnormal (jmc$job_management_id,
            jme$function_has_no_value, jmv$object_definition [profile_level].
            declaration.name, status);
      clp$make_unspecified_value (work_area, result);

    ELSEIF UPPERBOUND (name_list^) = 1 THEN
      clp$make_name_value (name_list^ [1], work_area, result);

    ELSE
      entry := ^result;
      FOR i := 1 TO UPPERBOUND (name_list^) DO
        clp$make_list_value (work_area, entry^);
        clp$make_name_value (name_list^ [i], work_area, entry^^.element_value);
        entry := ^entry^^.link;
      FOREND;
      entry^ := NIL;
    IFEND;

  PROCEND current_object;
?? TITLE := 'jmp$$application', EJECT ??

{ PURPOSE:
{   Processes the $application function which returns the attributes of the
{   specific application.
{

  PROCEDURE jmp$$application
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $application (
{   application_name: name = $required
{   attribute: key
{       all
{       (cyclic_aging_interval, cai)
{       (enable_application_scheduling, eas)
{       (maximum_working_set, maxws)
{       (minimum_working_set, minws)
{       (page_aging_interval, pai)
{       (service_class, sc)
{     hidden_key
{       (definition_name, dn)
{     keyend = all
{  )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 15] of clt$keyword_specification,
          default_value: string (3),
        recend,
      recend := [[1, [88, 10, 13, 18, 26, 50, 487], clc$function, 2, 2, 1, 0,
            0, 0, 0, '$APPLICATION'], [['APPLICATION_NAME               ',
            clc$nominal_entry, 1], ['ATTRIBUTE                      ',
            clc$nominal_entry, 2]], [

{ 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, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [2, 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, 562,
            clc$optional_default_parameter, 0, 3]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [15], [['ALL                            ',
            clc$nominal_entry, clc$normal_usage_entry, 1],
            ['CAI                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['CYCLIC_AGING_INTERVAL          ',
            clc$nominal_entry, clc$normal_usage_entry, 2],
            ['DEFINITION_NAME                ', clc$nominal_entry,
            clc$hidden_entry, 8], ['DN                             ',
            clc$abbreviation_entry, clc$hidden_entry, 8],
            ['EAS                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['ENABLE_APPLICATION_SCHEDULING  ',
            clc$nominal_entry, clc$normal_usage_entry, 3],
            ['MAXIMUM_WORKING_SET            ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['MAXWS                          ',
            clc$abbreviation_entry, clc$normal_usage_entry, 4],
            ['MINIMUM_WORKING_SET            ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['MINWS                          ',
            clc$abbreviation_entry, clc$normal_usage_entry, 5],
            ['PAGE_AGING_INTERVAL            ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['PAI                            ',
            clc$abbreviation_entry, clc$normal_usage_entry, 6],
            ['SC                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['SERVICE_CLASS                  ',
            clc$nominal_entry, clc$normal_usage_entry, 7]], 'all']];

?? POP ??

    CONST
      p$application_name = 1,
      p$attribute = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    build_attributes (jmc$profile_application, pvt, work_area, result, status);

  PROCEND jmp$$application;
?? TITLE := 'jmp$$controls', EJECT ??

{ PURPOSE:
{   Processes the $controls function which returns the attributes for the
{   specified controls.
{

  PROCEDURE jmp$$controls
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $controls (
{   controls_name: name = $required
{   attribute: key
{       all
{       (abbreviation, a)
{       (cpu_dispatching_allocation, cda)
{       (cpu_dispatching_interval, cdi)
{       (cpu_quantum_time, cqt)
{       (dual_state_priority_control, dspc)
{       (enable_job_leveling, ejl)
{       (idle_dispatching_queue_time, idqt)
{       (initiation_excluded_categories, iec)
{       (initiation_required_categories, irc)
{       (job_leveling_interval, jli)
{       (job_leveling_priority_bias, jlpb)
{       (scheduling_memory_levels, sml)
{       (service_calculation_interval, sci)
{       (validation_excluded_categories, vec)
{       (validation_required_categories, vrc)
{     hidden_key
{       (profile_identification, pi)
{     keyend = all
{  )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 33] of clt$keyword_specification,
          default_value: string (3),
        recend,
      recend := [[1, [88, 10, 13, 18, 27, 6, 794], clc$function, 2, 2, 1, 0, 0,
            0, 0, '$CONTROLS'], [['ATTRIBUTE                      ',
            clc$nominal_entry, 2], ['CONTROLS_NAME                  ',
            clc$nominal_entry, 1]], [

{ PARAMETER 1

      [2, 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, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [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, 1228,
            clc$optional_default_parameter, 0, 3]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [33], [['A                              ',
            clc$abbreviation_entry, clc$normal_usage_entry, 2],
            ['ABBREVIATION                   ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['ALL                            ',
            clc$nominal_entry, clc$normal_usage_entry, 1],
            ['CDA                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['CDI                            ',
            clc$abbreviation_entry, clc$normal_usage_entry, 4],
            ['CPU_DISPATCHING_ALLOCATION     ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['CPU_DISPATCHING_INTERVAL       ',
            clc$nominal_entry, clc$normal_usage_entry, 4],
            ['CPU_QUANTUM_TIME               ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['CQT                            ',
            clc$abbreviation_entry, clc$normal_usage_entry, 5],
            ['DSPC                           ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['DUAL_STATE_PRIORITY_CONTROL    ',
            clc$nominal_entry, clc$normal_usage_entry, 6],
            ['EJL                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['ENABLE_JOB_LEVELING            ',
            clc$nominal_entry, clc$normal_usage_entry, 7],
            ['IDLE_DISPATCHING_QUEUE_TIME    ', clc$nominal_entry,
            clc$normal_usage_entry, 8], ['IDQT                           ',
            clc$abbreviation_entry, clc$normal_usage_entry, 8],
            ['IEC                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 9], ['INITIATION_EXCLUDED_CATEGORIES ',
            clc$nominal_entry, clc$normal_usage_entry, 9],
            ['INITIATION_REQUIRED_CATEGORIES ', clc$nominal_entry,
            clc$normal_usage_entry, 10], ['IRC                            ',
            clc$abbreviation_entry, clc$normal_usage_entry, 10],
            ['JLI                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 11], ['JLPB                           ',
            clc$abbreviation_entry, clc$normal_usage_entry, 12],
            ['JOB_LEVELING_INTERVAL          ', clc$nominal_entry,
            clc$normal_usage_entry, 11], ['JOB_LEVELING_PRIORITY_BIAS     ',
            clc$nominal_entry, clc$normal_usage_entry, 12],
            ['PI                             ', clc$abbreviation_entry,
            clc$hidden_entry, 17], ['PROFILE_IDENTIFICATION         ',
            clc$nominal_entry, clc$hidden_entry, 17],
            ['SCHEDULING_MEMORY_LEVELS       ', clc$nominal_entry,
            clc$normal_usage_entry, 13], ['SCI                            ',
            clc$abbreviation_entry, clc$normal_usage_entry, 14],
            ['SERVICE_CALCULATION_INTERVAL   ', clc$nominal_entry,
            clc$normal_usage_entry, 14], ['SML                            ',
            clc$abbreviation_entry, clc$normal_usage_entry, 13],
            ['VALIDATION_EXCLUDED_CATEGORIES ', clc$nominal_entry,
            clc$normal_usage_entry, 15], ['VALIDATION_REQUIRED_CATEGORIES ',
            clc$nominal_entry, clc$normal_usage_entry, 16],
            ['VEC                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 15], ['VRC                            ',
            clc$abbreviation_entry, clc$normal_usage_entry, 16]], 'all']];

?? POP ??

    CONST
      p$controls_name = 1,
      p$attribute = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    build_attributes (jmc$profile_controls, pvt, work_area, result, status);

  PROCEND jmp$$controls;
?? TITLE := 'jmp$$current_application', EJECT ??

{ PURPOSE:
{    Processes the $CURRENT_APPLICATION function which returns the name
{    of the last application specified in a command.
{
{ DESIGN:
{    Calls current_object.

  PROCEDURE jmp$$current_application
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $current_application

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [88, 5, 3, 10, 11, 37, 598], clc$function, 0, 0, 0, 0, 0,
            0, 0, '$CURRENT_APPLICATION']];

?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_object (jmc$profile_application, work_area, result, status);
  PROCEND jmp$$current_application;
?? TITLE := 'jmp$$current_controls', EJECT ??

{ PURPOSE:
{    Processes the $CURRENT_MAINFRAME function which returns the name
{    of the last controls specified in a command.
{
{ DESIGN:
{    Calls current_object.

  PROCEDURE jmp$$current_controls
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{  FUNCTION $current_controls

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [88, 5, 3, 10, 12, 26, 987], clc$function, 0, 0, 0, 0, 0,
            0, 0, '$CURRENT_CONTROLS']];

?? POP ??
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_object (jmc$profile_controls, work_area, result, status);
  PROCEND jmp$$current_controls;
?? TITLE := 'jmp$$current_job_category', EJECT ??

{ PURPOSE:
{    Processes the $CURRENT_JOB_CATEGORY function which returns the name
{    of the last job_category specified in a command.
{
{ DESIGN:
{    Calls current_object.

  PROCEDURE jmp$$current_job_category
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{  FUNCTION $current_job_category

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [88, 5, 3, 10, 12, 58, 369], clc$function, 0, 0, 0, 0, 0,
            0, 0, '$CURRENT_JOB_CATEGORY']];

?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_object (jmc$profile_category, work_area, result, status);
  PROCEND jmp$$current_job_category;
?? TITLE := 'jmp$$current_job_class', EJECT ??

{ PURPOSE:
{    Processes the $CURRENT_JOB_CLASS function which returns the name
{    of the last job_class specified in a command.
{
{ DESIGN:
{    Calls current_object.

  PROCEDURE jmp$$current_job_class
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{  FUNCTION $current_job_class

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [88, 5, 3, 10, 13, 29, 695], clc$function, 0, 0, 0, 0, 0,
            0, 0, '$CURRENT_JOB_CLASS']];

?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_object (jmc$profile_job_class, work_area, result, status);
  PROCEND jmp$$current_job_class;
?? TITLE := 'jmp$$current_output_class', EJECT ??

{ PURPOSE:
{    Processes the $CURRENT_OUTPUT_CLASS function which returns the name
{    of the last output_class specified in a command.
{
{ DESIGN:
{    Calls current_object.

  PROCEDURE jmp$$current_output_class
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{  FUNCTION $current_output_class

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [88, 5, 3, 10, 13, 54, 831], clc$function, 0, 0, 0, 0, 0,
            0, 0, '$CURRENT_OUTPUT_CLASS']];

?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_object (jmc$profile_output_class, work_area, result, status);
  PROCEND jmp$$current_output_class;
?? TITLE := 'jmp$$current_profile_level', EJECT ??

{ PURPOSE:
{   Processes the $current_profile_level function which returns the level
{   of the profile last used.  Level refers here to the type of object
{   that was last manipulated (changed, displayed, etc.) like Job_class,
{   Service_class, Application, Controls, Job_category, Output_class, or
{   Job_priority.
{
{ DESIGN:
{   Each command that manipulates a profile object and each utility stores
{   the profile level in jmv$current_profile_level which this function
{   returns as a name value.

  PROCEDURE jmp$$current_profile_level
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{  FUNCTION $current_profile_level

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [88, 5, 3, 10, 14, 34, 205], clc$function, 0, 0, 0, 0, 0,
            0, 0, '$CURRENT_PROFILE_LEVEL']];

?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_name_value (jmv$object_definition [jmv$current_profile_level].
          declaration.name, work_area, result);

  PROCEND jmp$$current_profile_level;
?? TITLE := 'jmp$$current_service_class', EJECT ??

{ PURPOSE:
{    Processes the $CURRENT_SERVICE_CLASS function which returns the name
{    of the last service_class specified in a command.
{
{ DESIGN:
{    Calls current_object.

  PROCEDURE jmp$$current_service_class
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{  FUNCTION $current_service_class

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
      recend := [[1, [88, 5, 3, 10, 15, 12, 860], clc$function, 0, 0, 0, 0, 0,
            0, 0, '$CURRENT_SERVICE_CLASS']];

?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_object (jmc$profile_service_class, work_area, result, status);
  PROCEND jmp$$current_service_class;
?? TITLE := 'jmp$$profile_identification', EJECT ??

{ PURPOSE:
{   Processes the $profile_identification function which returns the value for
{   the specified profile_identification of an object on the profile.
{
{ DESIGN:
{   Locate the desired object, merge the objects profile_identifications with
{   the defaults, determine the profile_identification to be returned,
{   and return that value.
{
{ NOTES:
{   Until there is a way to return mixed data only single values will be
{   returned.

  PROCEDURE jmp$$profile_identification
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $profile_identification (
{  object: any of
{    key header keyend
{    record object_name: name = $required
{      profile_level: key
{        (job_class, jcl) (service_class, sc) (application, a)
{        (job_category, jc) (controls, c)
{      keyend = $required
{    recend
{  anyend
{  )

?? PUSH (LISTEXT := ON) ??

    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$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$keyword_type_qualifier,
              keyword_specs: array [1 .. 10] of clt$keyword_specification,
            recend,
          recend,
        recend,
      recend := [[1, [88, 5, 3, 10, 23, 21, 577], clc$function, 1, 1, 0, 0, 0,
            0, 0, '$PROFILE_IDENTIFICATION'],
            [['OBJECT                         ', 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, 525, clc$optional_parameter, 0,
            0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$record_type], FALSE, 2],
            44, [[1, 0, clc$keyword_type], [1],
            [['HEADER                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 461,
            [[1, 0, clc$record_type], [2], ['OBJECT_NAME                    ',
            clc$required_field, 5], [[1, 0, clc$name_type],
            [1, osc$max_name_size]], ['PROFILE_LEVEL                  ',
            clc$required_field, 377], [[1, 0, clc$keyword_type],
            [10], [['A                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['APPLICATION                    ',
            clc$nominal_entry, clc$normal_usage_entry, 3],
            ['C                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['CONTROLS                       ',
            clc$nominal_entry, clc$normal_usage_entry, 5],
            ['JC                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['JCL                            ',
            clc$abbreviation_entry, clc$normal_usage_entry, 1],
            ['JOB_CATEGORY                   ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['JOB_CLASS                      ',
            clc$nominal_entry, clc$normal_usage_entry, 1],
            ['SC                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SERVICE_CLASS                  ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]]]]];

?? POP ??

    CONST
      p$object = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      profile_level: jmt$profile_object_kinds,
      ignored: jmt$profile_object_reference,
      the_object: jmt$profile_object_reference,
      name_size: integer,
      name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$object].value^.kind = clc$keyword THEN
      clp$make_name_value (jmv$the_profile.definition_id, work_area, result);
    ELSE
      profile_level := jmv$current_profile_level;
      IF pvt [p$object].value^.field_values^ [2].value^.kind = clc$name THEN
        name := pvt [p$object].value^.field_values^ [2].value^.name_value;
        profile_level := LOWERVALUE (profile_level);
        WHILE name <> jmv$object_definition [profile_level].declaration.name DO
          profile_level := SUCC (profile_level);
        WHILEND;
      IFEND;
      name := pvt [p$object].value^.field_values^ [1].value^.name_value;

      jmp$get_object (name, profile_level, the_object, ignored, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$make_name_value (the_object^.definition_id, work_area, result);
    IFEND;

  PROCEND jmp$$profile_identification;
?? TITLE := 'jmp$$profile_summary', EJECT ??

{ PURPOSE:
{   Processes the $profile_summary function which returns the value for
{   the specified profile_summary of an object on the profile.
{
{ DESIGN:
{   Locate the desired object, merge the objects profile_summarys with
{   the defaults, determine the profile_summary to be returned,
{   and return that value.
{
{ NOTES:
{   Until there is a way to return mixed data only single values will be
{   returned.

  PROCEDURE jmp$$profile_summary
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $profile_summary (
{   profile_level: key
{     (job_class, jcl) (service_class, sc) (application, a)
{     (job_category, jc) (controls, c)
{    keyend = $required
{  )

?? PUSH (LISTEXT := ON) ??

    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$keyword_type_qualifier,
          keyword_specs: array [1 .. 10] of clt$keyword_specification,
        recend,
      recend := [[1, [88, 10, 13, 18, 27, 36, 578], clc$function, 1, 1, 1, 0,
            0, 0, 0, '$PROFILE_SUMMARY'], [['PROFILE_LEVEL                  ',
            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, 377, clc$required_parameter, 0,
            0]],

{ PARAMETER 1

      [[1, 0, clc$keyword_type], [10], [['A                              ',
            clc$abbreviation_entry, clc$normal_usage_entry, 3],
            ['APPLICATION                    ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['C                              ',
            clc$abbreviation_entry, clc$normal_usage_entry, 5],
            ['CONTROLS                       ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['JC                             ',
            clc$abbreviation_entry, clc$normal_usage_entry, 4],
            ['JCL                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['JOB_CATEGORY                   ',
            clc$nominal_entry, clc$normal_usage_entry, 4],
            ['JOB_CLASS                      ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SC                             ',
            clc$abbreviation_entry, clc$normal_usage_entry, 2],
            ['SERVICE_CLASS                  ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]]];

?? POP ??

    CONST
      p$profile_level = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      name: ost$name,
      node: ^clt$data_value,
      previous: ^^clt$data_value,
      profile_level: jmt$profile_object_kinds,
      the_object: jmt$profile_object_reference;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    name := pvt [p$profile_level].value^.name_value;
    profile_level := LOWERVALUE (profile_level);
    WHILE name <> jmv$object_definition [profile_level].declaration.name DO
      profile_level := SUCC (profile_level);
    WHILEND;

    the_object := jmv$the_profile.objects [profile_level];
    IF the_object = NIL THEN
      clp$make_list_value (work_area, node);
      result^.link := NIL;
      result^.element_value := NIL;
    ELSE
      previous := ^result;
      WHILE the_object <> NIL DO
        clp$make_list_value (work_area, node);
        node^.link := NIL;
        node^.generated_via_list_rest := FALSE;
        clp$make_name_value (the_object^.name, work_area, node^.element_value);
        previous^ := node;
        the_object := the_object^.next_object;
        previous := ^node^.link;
      WHILEND;
    IFEND;

  PROCEND jmp$$profile_summary;
?? TITLE := 'jmp$$job_class', EJECT ??

{ PURPOSE:
{   Processes the $job_class function which returns the attributes of the
{   specified job_class.
{

  PROCEDURE jmp$$job_class
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $job_class (
{   class_name: name = $required
{   attribute: key
{       all
{       (abbreviation, a)
{       (automatic_class_selection, acs)
{       (cpu_time_limit, ctl)
{       (cyclic_aging_interval, cai)
{       (defer_on_submit, dos)
{       (detached_job_wait_time, djwt)
{       (enable_class_initiation, eci)
{       (epilog, e)
{       (excluded_categories, ec)
{       (immediate_initiation_candidate, iic)
{       (initial_service_class, isc)
{       (initial_working_set, iws)
{       (initiated_jobs, ij)
{       (initiation_age_interval, iai)
{       (initiation_level, il)
{       (job_leveling_priority_bias, jlpb)
{       (magnetic_tape_limit, mtl)
{       (maximum_working_set, maxws)
{       (minimum_working_set, minws)
{       (multiple_job_bias, mjb)
{       (page_aging_interval, pai)
{       (prolog, p)
{       (queued_jobs, qj)
{       (required_categories, rc)
{       (selection_priority, sp)
{       (sru_limit, sl)
{     hidden_key
{       (definition_name, dn)
{       (profile_index, pi)
{       (job_class_index, jci)
{     keyend = all
{  )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 59] of clt$keyword_specification,
        default_value: string (3),
      recend,
    recend := [
    [1,
    [90, 1, 26, 11, 40, 2, 676],
    clc$function, 2, 2, 1, 0, 0, 0, 0, ''], [
    ['ATTRIBUTE                      ',clc$nominal_entry, 2],
    ['CLASS_NAME                     ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [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, 2190, clc$optional_default_parameter, 0, 3
  ]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [59], [
    ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['ABBREVIATION                   ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['ACS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['AUTOMATIC_CLASS_SELECTION      ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['CAI                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
    ['CPU_TIME_LIMIT                 ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['CTL                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
    ['CYCLIC_AGING_INTERVAL          ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
    ['DEFER_ON_SUBMIT                ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
    ['DEFINITION_NAME                ', clc$nominal_entry, clc$hidden_entry, 28
  ],
    ['DETACHED_JOB_WAIT_TIME         ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
    ['DJWT                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
    ['DN                             ', clc$abbreviation_entry,
  clc$hidden_entry, 28],
    ['DOS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
    ['E                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
    ['EC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
    ['ECI                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
    ['ENABLE_CLASS_INITIATION        ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
    ['EPILOG                         ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
    ['EXCLUDED_CATEGORIES            ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
    ['IAI                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 15],
    ['IIC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 11],
    ['IJ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 14],
    ['IL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 16],
    ['IMMEDIATE_INITIATION_CANDIDATE ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
    ['INITIAL_SERVICE_CLASS          ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
    ['INITIAL_WORKING_SET            ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
    ['INITIATED_JOBS                 ', clc$nominal_entry,
  clc$normal_usage_entry, 14],
    ['INITIATION_AGE_INTERVAL        ', clc$nominal_entry,
  clc$normal_usage_entry, 15],
    ['INITIATION_LEVEL               ', clc$nominal_entry,
  clc$normal_usage_entry, 16],
    ['ISC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 12],
    ['IWS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 13],
    ['JCI                            ', clc$abbreviation_entry,
  clc$hidden_entry, 30],
    ['JLPB                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 17],
    ['JOB_CLASS_INDEX                ', clc$nominal_entry, clc$hidden_entry, 30
  ],
    ['JOB_LEVELING_PRIORITY_BIAS     ', clc$nominal_entry,
  clc$normal_usage_entry, 17],
    ['MAGNETIC_TAPE_LIMIT            ', clc$nominal_entry,
  clc$normal_usage_entry, 18],
    ['MAXIMUM_WORKING_SET            ', clc$nominal_entry,
  clc$normal_usage_entry, 19],
    ['MAXWS                          ', clc$abbreviation_entry,
  clc$normal_usage_entry, 19],
    ['MINIMUM_WORKING_SET            ', clc$nominal_entry,
  clc$normal_usage_entry, 20],
    ['MINWS                          ', clc$abbreviation_entry,
  clc$normal_usage_entry, 20],
    ['MJB                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 21],
    ['MTL                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 18],
    ['MULTIPLE_JOB_BIAS              ', clc$nominal_entry,
  clc$normal_usage_entry, 21],
    ['P                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 23],
    ['PAGE_AGING_INTERVAL            ', clc$nominal_entry,
  clc$normal_usage_entry, 22],
    ['PAI                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 22],
    ['PI                             ', clc$abbreviation_entry,
  clc$hidden_entry, 29],
    ['PROFILE_INDEX                  ', clc$nominal_entry, clc$hidden_entry, 29
  ],
    ['PROLOG                         ', clc$nominal_entry,
  clc$normal_usage_entry, 23],
    ['QJ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 24],
    ['QUEUED_JOBS                    ', clc$nominal_entry,
  clc$normal_usage_entry, 24],
    ['RC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 25],
    ['REQUIRED_CATEGORIES            ', clc$nominal_entry,
  clc$normal_usage_entry, 25],
    ['SELECTION_PRIORITY             ', clc$nominal_entry,
  clc$normal_usage_entry, 26],
    ['SL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 27],
    ['SP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 26],
    ['SRU_LIMIT                      ', clc$nominal_entry,
  clc$normal_usage_entry, 27]]
    ,
    'all']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$class_name = 1,
      p$attribute = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    build_attributes (jmc$profile_job_class, pvt, work_area, result, status);

  PROCEND jmp$$job_class;
?? TITLE := 'jmp$$output_class', EJECT ??

{ PURPOSE:
{   Processes the $output_class function which returns the attributes of the
{   specified output_class.
{

  PROCEDURE jmp$$output_class
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $output_class (
{   class_name: name = $required
{   attribute: key
{       all
{       (abbreviation, a)
{       (delivery_priority, dp)
{       (enable_class_scheduling, ecs)
{       (output_age_interval, oai)
{     hidden_key
{       (definition_name, dn)
{       (output_class_index, oci)
{     keyend = all
{  )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 13] of clt$keyword_specification,
          default_value: string (3),
        recend,
      recend := [[1, [88, 10, 13, 18, 28, 8, 480], clc$function, 2, 2, 1, 0, 0,
            0, 0, '$OUTPUT_CLASS'], [['ATTRIBUTE                      ',
            clc$nominal_entry, 2], ['CLASS_NAME                     ',
            clc$nominal_entry, 1]], [

{ PARAMETER 1

      [2, 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, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [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, 488,
            clc$optional_default_parameter, 0, 3]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [13], [['A                              ',
            clc$abbreviation_entry, clc$normal_usage_entry, 2],
            ['ABBREVIATION                   ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['ALL                            ',
            clc$nominal_entry, clc$normal_usage_entry, 1],
            ['DEFINITION_NAME                ', clc$nominal_entry,
            clc$hidden_entry, 6], ['DELIVERY_PRIORITY              ',
            clc$nominal_entry, clc$normal_usage_entry, 3],
            ['DN                             ', clc$abbreviation_entry,
            clc$hidden_entry, 6], ['DP                             ',
            clc$abbreviation_entry, clc$normal_usage_entry, 3],
            ['ECS                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['ENABLE_CLASS_SCHEDULING        ',
            clc$nominal_entry, clc$normal_usage_entry, 4],
            ['OAI                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['OCI                            ',
            clc$abbreviation_entry, clc$hidden_entry, 7],
            ['OUTPUT_AGE_INTERVAL            ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['OUTPUT_CLASS_INDEX             ',
            clc$nominal_entry, clc$hidden_entry, 7]], 'all']];

?? POP ??

    CONST
      p$class_name = 1,
      p$attribute = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    build_attributes (jmc$profile_output_class, pvt, work_area, result,
          status);

  PROCEND jmp$$output_class;
?? TITLE := 'jmp$$service_class', EJECT ??

{ PURPOSE:
{   Processes the $service_class function which returns the attributes of the
{   specified service_class.
{

  PROCEDURE jmp$$service_class
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $service_class (
{   class_name: name = $required
{   attribute: key
{       all
{       (abbreviation, a)
{       (active_jobs, aj)
{       (aio_limit, aiol)
{       (class_service_threshold, cst)
{       (dispatching_control, dc)
{       (enable_class_execution, ece)
{       (guaranteed_service_quantum, gsq)
{       (long_wait_think_time, lwtt)
{       (maximum_active_jobs, maxaj)
{       (next_service_class, nsc)
{       (queued_jobs, qj)
{       (scheduling_priority, sp)
{       (service_factors, sf)
{       (swap_age_interval, sai)
{       (swapped_jobs, sj)
{     hidden_key
{       (definition_name, dn)
{       (service_class_index, sci)
{     keyend = all
{  )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 35] of clt$keyword_specification,
        default_value: string (3),
      recend,
    recend := [
    [1,
    [91, 8, 15, 13, 22, 31, 449],
    clc$function, 2, 2, 1, 0, 0, 0, 0, ''], [
    ['ATTRIBUTE                      ',clc$nominal_entry, 2],
    ['CLASS_NAME                     ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [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, 1302, clc$optional_default_parameter, 0, 3
  ]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [35], [
    ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['ABBREVIATION                   ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['ACTIVE_JOBS                    ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['AIOL                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
    ['AIO_LIMIT                      ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['AJ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['CLASS_SERVICE_THRESHOLD        ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
    ['CST                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
    ['DC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
    ['DEFINITION_NAME                ', clc$nominal_entry, clc$hidden_entry, 17
  ],
    ['DISPATCHING_CONTROL            ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
    ['DN                             ', clc$abbreviation_entry,
  clc$hidden_entry, 17],
    ['ECE                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
    ['ENABLE_CLASS_EXECUTION         ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
    ['GSQ                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
    ['GUARANTEED_SERVICE_QUANTUM     ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
    ['LONG_WAIT_THINK_TIME           ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
    ['LWTT                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
    ['MAXAJ                          ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
    ['MAXIMUM_ACTIVE_JOBS            ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
    ['NEXT_SERVICE_CLASS             ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
    ['NSC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 11],
    ['QJ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 12],
    ['QUEUED_JOBS                    ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
    ['SAI                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 15],
    ['SCHEDULING_PRIORITY            ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
    ['SCI                            ', clc$abbreviation_entry,
  clc$hidden_entry, 18],
    ['SERVICE_CLASS_INDEX            ', clc$nominal_entry, clc$hidden_entry, 18
  ],
    ['SERVICE_FACTORS                ', clc$nominal_entry,
  clc$normal_usage_entry, 14],
    ['SF                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 14],
    ['SJ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 16],
    ['SP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 13],
    ['SWAPPED_JOBS                   ', clc$nominal_entry,
  clc$normal_usage_entry, 16],
    ['SWAP_AGE_INTERVAL              ', clc$nominal_entry,
  clc$normal_usage_entry, 15]]
    ,
    'all']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$class_name = 1,
      p$attribute = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    build_attributes (jmc$profile_service_class, pvt, work_area, result,
          status);

  PROCEND jmp$$service_class;

MODEND jmm$administer_functions;
*DECK DECK=JMM$ADMINISTER_JOB_CLASS EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Scheduling : administer_job_class' ??
MODULE jmm$administer_job_class;

{ PURPOSE:
{   This module defines the commands that make up the subutility of
{   ADMINISTER_SCHEDULING called ADMINISTER_JOB_CLASS.  This utility
{   manages the job classes on the scheduling profile.  The procedures
{   in this module allow the administrator to create, change, delete
{   and display job classes on/from the scheduling profile.
{
{ DESIGN:
{   This module mainly provides the framework for the utility.  It
{   contains the PDTs and code for the subutility and it's subcommands.
{
{ NOTES:
{   Most of the work of creating, deleting, changing, and displaying is
{   done in routines which are generalized to handle all types of objects.
{   These routines can be found in the modules JMM$ADMINISTER_DISPLAY and
{   JMM$ADMINISTER_OBJECTS.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$class_names
*copyc jmt$job_class_attributes
?? POP ??
*copyc clp$begin_utility
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$include_file
*copyc clp$evaluate_parameters
*copyc jmp$add_object
*copyc jmp$change_object
*copyc jmp$delete_object
*copyc jmp$get_attributes
*copyc jmp$move_object
*copyc jmp$set_default_attributes

*copyc jmv$current_profile_level
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    milliseconds_per_second = 1000,
    microseconds_per_second = milliseconds_per_second * 1000;

  CONST
    lowest_prio_age_interval = jmc$lowest_prio_age_interval DIV
          microseconds_per_second,
    highest_prio_age_interval = jmc$highest_prio_age_interval DIV
          microseconds_per_second;

  VAR
    command_file: amt$local_file_name := clc$current_command_input,
    utility_name: string (31) := 'ADMINISTER_JOB_CLASS           ',
    utility_attributes: array [1 .. 2] of clt$utility_attribute :=
          [[clc$utility_command_table, * ], [clc$utility_prompt, [3, 'AJC']]];

{ table command_table
{ command (add_job_category_entry add_job_category_entries, addjce)   ..
{   jmp$_add_job_category_entry
{ command (delete_job_category_entry delete_job_category_entries, deljce)   ..
{   jmp$_delete_job_category_entry
{ command (create_class, crec), jmp$_create_class
{ command (change_attribute, change_attributes, chaa),   ..
{   jmp$_change_attribute
{ command (display_attribute, display_attributes, disa),   ..
{   jmp$_display_job_class cm=xref
{ command (delete_class, delc), jmp$_delete_class
{ command (quit, qui), jmp$_quit
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    command_table: [STATIC, READ] ^clt$command_table := ^command_table_entries,

    command_table_entries: [STATIC, READ] array [1 .. 18] of
          clt$command_table_entry := [
          {} ['ADDJCE                         ', clc$abbreviation_entry,
          clc$advertised_entry, 1, clc$automatically_log, clc$linked_call,
          ^jmp$_add_job_category_entry],
          {} ['ADD_JOB_CATEGORY_ENTRIES       ', clc$alias_entry,
          clc$advertised_entry, 1, clc$automatically_log, clc$linked_call,
          ^jmp$_add_job_category_entry],
          {} ['ADD_JOB_CATEGORY_ENTRY         ', clc$nominal_entry,
          clc$advertised_entry, 1, clc$automatically_log, clc$linked_call,
          ^jmp$_add_job_category_entry],
          {} ['CHAA                           ', clc$abbreviation_entry,
          clc$advertised_entry, 4, clc$automatically_log, clc$linked_call,
          ^jmp$_change_attribute],
          {} ['CHANGE_ATTRIBUTE               ', clc$nominal_entry,
          clc$advertised_entry, 4, clc$automatically_log, clc$linked_call,
          ^jmp$_change_attribute],
          {} ['CHANGE_ATTRIBUTES              ', clc$alias_entry,
          clc$advertised_entry, 4, clc$automatically_log, clc$linked_call,
          ^jmp$_change_attribute],
          {} ['CREATE_CLASS                   ', clc$nominal_entry,
          clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_create_class],
          {} ['CREC                           ', clc$abbreviation_entry,
          clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_create_class],
          {} ['DELC                           ', clc$abbreviation_entry,
          clc$advertised_entry, 6, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_class],
          {} ['DELETE_CLASS                   ', clc$nominal_entry,
          clc$advertised_entry, 6, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_class],
          {} ['DELETE_JOB_CATEGORY_ENTRIES    ', clc$alias_entry,
          clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_job_category_entry],
          {} ['DELETE_JOB_CATEGORY_ENTRY      ', clc$nominal_entry,
          clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_job_category_entry],
          {} ['DELJCE                         ', clc$abbreviation_entry,
          clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_job_category_entry],
          {} ['DISA                           ', clc$abbreviation_entry,
          clc$advertised_entry, 5, clc$automatically_log, clc$linked_call,
          ^jmp$_display_job_class],
          {} ['DISPLAY_ATTRIBUTE              ', clc$nominal_entry,
          clc$advertised_entry, 5, clc$automatically_log, clc$linked_call,
          ^jmp$_display_job_class],
          {} ['DISPLAY_ATTRIBUTES             ', clc$alias_entry,
          clc$advertised_entry, 5, clc$automatically_log, clc$linked_call,
          ^jmp$_display_job_class],
          {} ['QUI                            ', clc$abbreviation_entry,
          clc$advertised_entry, 7, clc$automatically_log, clc$linked_call,
          ^jmp$_quit],
          {} ['QUIT                           ', clc$nominal_entry,
          clc$advertised_entry, 7, clc$automatically_log, clc$linked_call,
          ^jmp$_quit]];

  PROCEDURE [XREF] jmp$_display_job_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??
?? OLDTITLE ??
?? NEWTITLE := 'jmp$_add_job_category_entry ', EJECT ??

{ PURPOSE:
{   Processes the ADD_JOB_CATEGORY_ENTRY command.
{
{ DESIGN:
{   Obtains the job categories to add, determines the job classes to change,
{   and applies the change to each job class.
{
{ NOTES:
{  See JMM$ADMINISTER_OBJECTS,
{      JMM$ADMINISTER_ATTRIBUTES,
{      JMM$ADMINISTER_DEFINITIONS.

  PROCEDURE jmp$_add_job_category_entry
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admjc_addjce) add_job_category_entry (
{   class_name, class_names, cn: any of
{       key all keyend
{       list of name
{     anyend = $current_job_class
{   excluded_categories, ec: (by_name) any of
{       key all keyend
{       list of name
{     anyend = $optional
{   required_categories, rc: (by_name) any of
{       key all keyend
{       list of name
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 8] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (18),
        recend,
        type2: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type3: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 37, 42, 537], clc$command, 8, 4, 0, 0, 0,
            0, 4, 'OSM$ADMJC_ADDJCE'], [['CLASS_NAME                     ',
            clc$nominal_entry, 1], ['CLASS_NAMES                    ',
            clc$alias_entry, 1], ['CN                             ',
            clc$abbreviation_entry, 1], ['EC                             ',
            clc$abbreviation_entry, 2], ['EXCLUDED_CATEGORIES            ',
            clc$nominal_entry, 2], ['RC                             ',
            clc$abbreviation_entry, 3], ['REQUIRED_CATEGORIES            ',
            clc$nominal_entry, 3], ['STATUS                         ',
            clc$nominal_entry, 4]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 18],

{ PARAMETER 2

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [7, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [8, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            '$current_job_class'],

{ PARAMETER 2

      [[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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 3

      [[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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$class_name = 1,
      p$excluded_categories = 2,
      p$required_categories = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      attributes: jmt$object_attribute;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$get_attributes (jmc$profile_job_class, #SEQ (pdt), ^pvt, attributes,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$change_object (jmc$profile_job_class, pvt [p$class_name].value^,
          attributes, jmc$add_list_items, status);

  PROCEND jmp$_add_job_category_entry;
?? TITLE := 'jmp$_change_attribute ', EJECT ??

{ PURPOSE:
{   Processes the CHANGE_ATTRIBUTE command.
{
{ DESIGN:
{   Determines the job class objects to update, fetches the attributes that
{   are changing and updates them.
{
{ NOTES:
{  See JMM$ADMINISTER_OBJECTS,
{      JMM$ADMINISTER_ATTRIBUTES,
{      JMM$ADMINISTER_DEFINITIONS.

  PROCEDURE jmp$_change_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admjc_chaa) change_attribute (
{   class_name, class_names, cn: any of
{       key all keyend
{       list of name
{     anyend = $current_job_class
{   abbreviation, a: (by_name) any of
{       key default, none, unspecified keyend
{       name
{     anyend = $optional
{   automatic_class_selection, acs: (by_name) any of
{       key default keyend
{       boolean
{     anyend = $optional
{   cpu_time_limit, ctl: (by_name) any of
{       key default, unlimited, system_default keyend
{       integer jmc$lowest_cpu_time_limit..jmc$highest_cpu_time_limit
{     anyend = $optional
{   cyclic_aging_interval, cai: (by_name) any of
{       key default keyend
{       record
{         default: any of
{           key default keyend
{           integer jmc$lowest_aging_interval..jmc$highest_aging_interval
{         anyend = $optional
{         minimum: any of
{           key default keyend
{           integer jmc$lowest_aging_interval..jmc$highest_aging_interval
{         anyend = $optional
{         maximum: any of
{           key default keyend
{           integer jmc$lowest_aging_interval..jmc$highest_aging_interval
{         anyend = $optional
{       recend
{     anyend = $optional
{   defer_on_submit, dos: (by_name) any of
{       key default keyend
{       boolean
{     anyend = $optional
{   detached_job_wait_time, djwt: (by_name) any of
{       key default keyend
{       record
{         default: any of
{           key default, unlimited keyend
{         integer jmc$lowest_det_job_wait_time..jmc$highest_det_job_wait_time
{         anyend = $optional
{         minimum: any of
{           key default, unlimited keyend
{         integer jmc$lowest_det_job_wait_time..jmc$highest_det_job_wait_time
{         anyend = $optional
{         maximum: any of
{           key default, unlimited keyend
{         integer jmc$lowest_det_job_wait_time..jmc$highest_det_job_wait_time
{         anyend = $optional
{       recend
{     anyend = $optional
{   enable_class_initiation, eci: (by_name) any of
{       key default keyend
{       boolean
{     anyend = $optional
{   epilog, e: (by_name) any of
{       key default, none, unspecified keyend
{       file
{     anyend = $optional
{   excluded_categories, ec: (by_name) any of
{       key default, none, all keyend
{       list of name
{     anyend = $optional
{   immediate_initiation_candidate, iic: (by_name) any of
{       key default keyend
{       boolean
{     anyend = $optional
{   initial_service_class, isc: (by_name) any of
{       key default, none keyend
{        name
{     anyend = $optional
{   initial_working_set, iws: (by_name) any of
{       key default keyend
{       integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{     anyend = $optional
{   initiation_age_interval, iai: (by_name) any of
{       key default, unlimited keyend
{       integer lowest_prio_age_interval..highest_prio_age_interval
{     anyend = $optional
{   initiation_level, il: (by_name) any of
{       key default keyend
{       record
{         preferred: any of
{           key default, unlimited keyend
{         integer jmc$lowest_max_initiated_jobs..jmc$highest_max_initiated_jobs
{         anyend
{       recend
{     anyend = $optional
{   job_leveling_priority_bias, jlpb: (by_name) any of
{       key default keyend
{       integer jmc$lowest_priority_bias..jmc$highest_priority_bias
{     anyend = $optional
{   magnetic_tape_limit, mtl: (by_name) any of
{       key default, unlimited keyend
{       integer jmc$lowest_magnetic_tape_limit..jmc$highest_magnetic_tape_limit
{     anyend = $optional
{   maximum_working_set, maxws: (by_name) any of
{       key default keyend
{       record
{         default: any of
{           key default, unlimited keyend
{           integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{         anyend = $optional
{         minimum: any of
{           key default, unlimited keyend
{           integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{         anyend = $optional
{         maximum: any of
{           key default, unlimited keyend
{           integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{         anyend = $optional
{       recend
{     anyend = $optional
{   minimum_working_set, minws: (by_name) any of
{       key default keyend
{       record
{         default: any of
{           key default keyend
{           integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{         anyend = $optional
{         minimum: any of
{           key default keyend
{           integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{         anyend = $optional
{         maximum: any of
{           key default keyend
{           integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{         anyend = $optional
{       recend
{     anyend = $optional
{   multiple_job_bias, mjb: (by_name) any of
{       key default keyend
{       integer jmc$lowest_job_priority..jmc$highest_job_priority
{     anyend = $optional
{   page_aging_interval, pai: (by_name) any of
{       key default keyend
{       record
{         default: any of
{           key default keyend
{           integer jmc$lowest_aging_interval..jmc$highest_aging_interval
{         anyend = $optional
{         minimum: any of
{           key default keyend
{           integer jmc$lowest_aging_interval..jmc$highest_aging_interval
{         anyend = $optional
{         maximum: any of
{           key default keyend
{           integer jmc$lowest_aging_interval..jmc$highest_aging_interval
{         anyend = $optional
{       recend
{     anyend = $optional
{   prolog, p: (by_name) any of
{       key default, none, unspecified keyend
{       file
{     anyend = $optional
{   required_categories, rc: (by_name) any of
{       key default, none, all keyend
{       list of name
{     anyend = $optional
{   selection_priority, sp: (by_name) any of
{       key default keyend
{       record
{         initial: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{         maximum: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{         increment: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{         threshold: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{       recend
{     anyend = $optional
{   selection_rank, sr: (by_name) name = $optional
{   sru_limit, sl: (by_name) any of
{       key default, unlimited, system_default keyend
{       integer jmc$lowest_sru_limit..jmc$highest_sru_limit
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 54] of clt$pdt_parameter_name,
      parameters: array [1 .. 27] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (18),
      recend,
      type2: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type3: 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,
        recend,
      recend,
      type4: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type5: 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$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: 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$integer_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type6: 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,
        recend,
      recend,
      type7: 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$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: 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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: 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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type8: 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,
        recend,
      recend,
      type9: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type10: 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 .. 3] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type11: 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,
        recend,
      recend,
      type12: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type13: 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$integer_type_qualifier,
        recend,
      recend,
      type14: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type15: 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$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: 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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type16: 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$integer_type_qualifier,
        recend,
      recend,
      type17: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type18: 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$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: 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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: 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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type19: 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$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: 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$integer_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type20: 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$integer_type_qualifier,
        recend,
      recend,
      type21: 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$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: 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$integer_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type22: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type23: 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 .. 3] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type24: 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$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: 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$integer_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type25: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type26: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type27: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 1, 26, 11, 45, 37, 231],
    clc$command, 54, 27, 0, 0, 0, 0, 27, 'OSM$ADMJC_CHAA'], [
    ['A                              ',clc$abbreviation_entry, 2],
    ['ABBREVIATION                   ',clc$nominal_entry, 2],
    ['ACS                            ',clc$abbreviation_entry, 3],
    ['AUTOMATIC_CLASS_SELECTION      ',clc$nominal_entry, 3],
    ['CAI                            ',clc$abbreviation_entry, 5],
    ['CLASS_NAME                     ',clc$nominal_entry, 1],
    ['CLASS_NAMES                    ',clc$alias_entry, 1],
    ['CN                             ',clc$abbreviation_entry, 1],
    ['CPU_TIME_LIMIT                 ',clc$nominal_entry, 4],
    ['CTL                            ',clc$abbreviation_entry, 4],
    ['CYCLIC_AGING_INTERVAL          ',clc$nominal_entry, 5],
    ['DEFER_ON_SUBMIT                ',clc$nominal_entry, 6],
    ['DETACHED_JOB_WAIT_TIME         ',clc$nominal_entry, 7],
    ['DJWT                           ',clc$abbreviation_entry, 7],
    ['DOS                            ',clc$abbreviation_entry, 6],
    ['E                              ',clc$abbreviation_entry, 9],
    ['EC                             ',clc$abbreviation_entry, 10],
    ['ECI                            ',clc$abbreviation_entry, 8],
    ['ENABLE_CLASS_INITIATION        ',clc$nominal_entry, 8],
    ['EPILOG                         ',clc$nominal_entry, 9],
    ['EXCLUDED_CATEGORIES            ',clc$nominal_entry, 10],
    ['IAI                            ',clc$abbreviation_entry, 14],
    ['IIC                            ',clc$abbreviation_entry, 11],
    ['IL                             ',clc$abbreviation_entry, 15],
    ['IMMEDIATE_INITIATION_CANDIDATE ',clc$nominal_entry, 11],
    ['INITIAL_SERVICE_CLASS          ',clc$nominal_entry, 12],
    ['INITIAL_WORKING_SET            ',clc$nominal_entry, 13],
    ['INITIATION_AGE_INTERVAL        ',clc$nominal_entry, 14],
    ['INITIATION_LEVEL               ',clc$nominal_entry, 15],
    ['ISC                            ',clc$abbreviation_entry, 12],
    ['IWS                            ',clc$abbreviation_entry, 13],
    ['JLPB                           ',clc$abbreviation_entry, 16],
    ['JOB_LEVELING_PRIORITY_BIAS     ',clc$nominal_entry, 16],
    ['MAGNETIC_TAPE_LIMIT            ',clc$nominal_entry, 17],
    ['MAXIMUM_WORKING_SET            ',clc$nominal_entry, 18],
    ['MAXWS                          ',clc$abbreviation_entry, 18],
    ['MINIMUM_WORKING_SET            ',clc$nominal_entry, 19],
    ['MINWS                          ',clc$abbreviation_entry, 19],
    ['MJB                            ',clc$abbreviation_entry, 20],
    ['MTL                            ',clc$abbreviation_entry, 17],
    ['MULTIPLE_JOB_BIAS              ',clc$nominal_entry, 20],
    ['P                              ',clc$abbreviation_entry, 22],
    ['PAGE_AGING_INTERVAL            ',clc$nominal_entry, 21],
    ['PAI                            ',clc$abbreviation_entry, 21],
    ['PROLOG                         ',clc$nominal_entry, 22],
    ['RC                             ',clc$abbreviation_entry, 23],
    ['REQUIRED_CATEGORIES            ',clc$nominal_entry, 23],
    ['SELECTION_PRIORITY             ',clc$nominal_entry, 24],
    ['SELECTION_RANK                 ',clc$nominal_entry, 25],
    ['SL                             ',clc$abbreviation_entry, 26],
    ['SP                             ',clc$abbreviation_entry, 24],
    ['SR                             ',clc$abbreviation_entry, 25],
    ['SRU_LIMIT                      ',clc$nominal_entry, 26],
    ['STATUS                         ',clc$nominal_entry, 27]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 18],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 143, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 158, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 431, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 542, clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 141, clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 159, clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 106, clc$optional_parameter, 0, 0],
{ PARAMETER 13
    [27, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],
{ PARAMETER 14
    [28, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 121, clc$optional_parameter, 0, 0],
{ PARAMETER 15
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 228, clc$optional_parameter, 0, 0],
{ PARAMETER 16
    [33, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [34, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 121, clc$optional_parameter, 0, 0],
{ PARAMETER 18
    [35, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 542, clc$optional_parameter, 0, 0],
{ PARAMETER 19
    [37, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 431, clc$optional_parameter, 0, 0],
{ PARAMETER 20
    [41, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],
{ PARAMETER 21
    [43, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 431, clc$optional_parameter, 0, 0],
{ PARAMETER 22
    [45, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 141, clc$optional_parameter, 0, 0],
{ PARAMETER 23
    [47, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 159, clc$optional_parameter, 0, 0],
{ PARAMETER 24
    [48, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 551, clc$optional_parameter, 0, 0],
{ PARAMETER 25
    [49, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 26
    [53, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 158, clc$optional_parameter, 0, 0],
{ PARAMETER 27
    [54, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    '$current_job_class'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$boolean_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_cpu_time_limit,
  jmc$highest_cpu_time_limit, 10]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$record_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    367, [[1, 0, clc$record_type], [3],
      ['DEFAULT                        ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
  jmc$highest_aging_interval, 10]]
        ],
      ['MINIMUM                        ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
  jmc$highest_aging_interval, 10]]
        ],
      ['MAXIMUM                        ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
  jmc$highest_aging_interval, 10]]
        ]
      ]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$boolean_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$record_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    478, [[1, 0, clc$record_type], [3],
      ['DEFAULT                        ', clc$optional_field, 121], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        81, [[1, 0, clc$keyword_type], [2], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
          ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_det_job_wait_time,
  jmc$highest_det_job_wait_time, 10]]
        ],
      ['MINIMUM                        ', clc$optional_field, 121], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        81, [[1, 0, clc$keyword_type], [2], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
          ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_det_job_wait_time,
  jmc$highest_det_job_wait_time, 10]]
        ],
      ['MAXIMUM                        ', clc$optional_field, 121], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        81, [[1, 0, clc$keyword_type], [2], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
          ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_det_job_wait_time,
  jmc$highest_det_job_wait_time, 10]]
        ]
      ]
    ],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$boolean_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
      ],
    3, [[1, 0, clc$file_type]]
    ],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 11
    [[1, 0, clc$union_type], [[clc$boolean_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 12
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 13
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
  jmc$highest_working_set_size, 10]]
    ],
{ PARAMETER 14
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [lowest_prio_age_interval,
  highest_prio_age_interval, 10]]
    ],
{ PARAMETER 15
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$record_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    164, [[1, 0, clc$record_type], [1],
      ['PREFERRED                      ', clc$required_field, 121], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        81, [[1, 0, clc$keyword_type], [2], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
          ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_max_initiated_jobs,
  jmc$highest_max_initiated_jobs, 10]]
        ]
      ]
    ],
{ PARAMETER 16
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_priority_bias,
  jmc$highest_priority_bias, 10]]
    ],
{ PARAMETER 17
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_magnetic_tape_limit,
  jmc$highest_magnetic_tape_limit, 10]]
    ],
{ PARAMETER 18
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$record_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    478, [[1, 0, clc$record_type], [3],
      ['DEFAULT                        ', clc$optional_field, 121], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        81, [[1, 0, clc$keyword_type], [2], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
          ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
  jmc$highest_working_set_size, 10]]
        ],
      ['MINIMUM                        ', clc$optional_field, 121], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        81, [[1, 0, clc$keyword_type], [2], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
          ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
  jmc$highest_working_set_size, 10]]
        ],
      ['MAXIMUM                        ', clc$optional_field, 121], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        81, [[1, 0, clc$keyword_type], [2], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
          ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
  jmc$highest_working_set_size, 10]]
        ]
      ]
    ],
{ PARAMETER 19
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$record_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    367, [[1, 0, clc$record_type], [3],
      ['DEFAULT                        ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
  jmc$highest_working_set_size, 10]]
        ],
      ['MINIMUM                        ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
  jmc$highest_working_set_size, 10]]
        ],
      ['MAXIMUM                        ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
  jmc$highest_working_set_size, 10]]
        ]
      ]
    ],
{ PARAMETER 20
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
  jmc$highest_job_priority, 10]]
    ],
{ PARAMETER 21
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$record_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    367, [[1, 0, clc$record_type], [3],
      ['DEFAULT                        ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
  jmc$highest_aging_interval, 10]]
        ],
      ['MINIMUM                        ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
  jmc$highest_aging_interval, 10]]
        ],
      ['MAXIMUM                        ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
  jmc$highest_aging_interval, 10]]
        ]
      ]
    ],
{ PARAMETER 22
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
      ],
    3, [[1, 0, clc$file_type]]
    ],
{ PARAMETER 23
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 24
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$record_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    487, [[1, 0, clc$record_type], [4],
      ['INITIAL                        ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
  jmc$highest_job_priority, 10]]
        ],
      ['MAXIMUM                        ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
  jmc$highest_job_priority, 10]]
        ],
      ['INCREMENT                      ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
  jmc$highest_job_priority, 10]]
        ],
      ['THRESHOLD                      ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
  jmc$highest_job_priority, 10]]
        ]
      ]
    ],
{ PARAMETER 25
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 26
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_sru_limit, jmc$highest_sru_limit
  , 10]]
    ],
{ PARAMETER 27
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$class_name = 1,
      p$abbreviation = 2,
      p$automatic_class_selection = 3,
      p$cpu_time_limit = 4,
      p$cyclic_aging_interval = 5,
      p$defer_on_submit = 6,
      p$detached_job_wait_time = 7,
      p$enable_class_initiation = 8,
      p$epilog = 9,
      p$excluded_categories = 10,
      p$immediate_initiation_candidat = 11 {IMMEDIATE_INITIATION_CANDIDATE} ,
      p$initial_service_class = 12,
      p$initial_working_set = 13,
      p$initiation_age_interval = 14,
      p$initiation_level = 15,
      p$job_leveling_priority_bias = 16,
      p$magnetic_tape_limit = 17,
      p$maximum_working_set = 18,
      p$minimum_working_set = 19,
      p$multiple_job_bias = 20,
      p$page_aging_interval = 21,
      p$prolog = 22,
      p$required_categories = 23,
      p$selection_priority = 24,
      p$selection_rank = 25,
      p$sru_limit = 26,
      p$status = 27;

    VAR
      pvt: array [1 .. 27] of clt$parameter_value;

    VAR
      new_attributes: jmt$object_attribute;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_job_class;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$get_attributes (jmc$profile_job_class, #SEQ (pdt), ^pvt,
          new_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$selection_rank].specified THEN
      jmp$move_object (jmc$profile_job_class, pvt [p$class_name].
            value^, pvt [p$selection_rank].value^.name_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    jmp$change_object (jmc$profile_job_class, pvt [p$class_name].value^,
          new_attributes, jmc$update, status);

  PROCEND jmp$_change_attribute;
?? TITLE := 'jmp$_create_class ', EJECT ??

{ PURPOSE:
{   Processes the CREATE_CLASS command.
{
{ DESIGN:
{   Fetches the default values and adds the specified job class to the
{   profile.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS.

  PROCEDURE jmp$_create_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admjc_crec) create_class (
{   class_name, cn: name = $required
{   default_values, dv: (by_name) name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 43, 18, 175], clc$command, 5, 3, 1, 0, 0,
            0, 3, 'OSM$ADMJC_CREC'], [['CLASS_NAME                     ',
            clc$nominal_entry, 1], ['CN                             ',
            clc$abbreviation_entry, 1], ['DEFAULT_VALUES                 ',
            clc$nominal_entry, 2], ['DV                             ',
            clc$abbreviation_entry, 2], ['STATUS                         ',
            clc$nominal_entry, 3]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 5,
            clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$class_name = 1,
      p$default_values = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      the_attributes: jmt$object_attribute,
      the_object: jmt$profile_object_reference;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$set_default_attributes (jmc$profile_job_class, pvt [p$default_values],
          the_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$add_object (jmc$profile_job_class, pvt [p$class_name].value^.
          name_value, the_attributes, the_object, status);
    IF status.normal THEN
      jmp$move_object (jmc$profile_job_class, pvt [p$class_name].value^,
            jmc$system_class_name, status);
    IFEND;

  PROCEND jmp$_create_class;
?? TITLE := 'jmp$_delete_class ', EJECT ??

{ PURPOSE:
{   Processes the DELETE_CLASS command.
{
{ DESIGN:
{   Determine the job classes to delete and delete them.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS.

  PROCEDURE jmp$_delete_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admjc_delc) delete_class (
{   class_name, class_names, cn: list of name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 4] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 43, 47, 883], clc$command, 4, 2, 1, 0, 0,
            0, 2, 'OSM$ADMJC_DELC'], [['CLASS_NAME                     ',
            clc$nominal_entry, 1], ['CLASS_NAMES                    ',
            clc$alias_entry, 1], ['CN                             ',
            clc$abbreviation_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 2]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 21,
            clc$required_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$class_name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_job_class;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$delete_object (jmc$profile_job_class, pvt [p$class_name].value^,
          status);

  PROCEND jmp$_delete_class;
?? TITLE := 'jmp$_delete_job_category_entry ', EJECT ??

{ PURPOSE:
{   Processes the DELETE_JOB_CATEGORY_ENTRY command.
{
{ DESIGN:
{   Obtains the job categories to delete, determines the job classes to change,
{   and applies the change to each job class.
{
{ NOTES:
{  See JMM$ADMINISTER_OBJECTS,
{      JMM$ADMINISTER_ATTRIBUTES,
{      JMM$ADMINISTER_DEFINITIONS.

  PROCEDURE jmp$_delete_job_category_entry
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admjc_deljce) delete_job_category_entry (
{   class_name, class_names, cn: any of
{       key all keyend
{       list of name
{     anyend = $current_job_class
{   excluded_categories, ec: (by_name) any of
{       key all keyend
{       list of name
{     anyend = $optional
{   required_categories, rc: (by_name) any of
{       key all keyend
{       list of name
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 8] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (18),
        recend,
        type2: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type3: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 44, 17, 995], clc$command, 8, 4, 0, 0, 0,
            0, 4, 'OSM$ADMJC_DELJCE'], [['CLASS_NAME                     ',
            clc$nominal_entry, 1], ['CLASS_NAMES                    ',
            clc$alias_entry, 1], ['CN                             ',
            clc$abbreviation_entry, 1], ['EC                             ',
            clc$abbreviation_entry, 2], ['EXCLUDED_CATEGORIES            ',
            clc$nominal_entry, 2], ['RC                             ',
            clc$abbreviation_entry, 3], ['REQUIRED_CATEGORIES            ',
            clc$nominal_entry, 3], ['STATUS                         ',
            clc$nominal_entry, 4]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 18],

{ PARAMETER 2

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [7, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [8, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            '$current_job_class'],

{ PARAMETER 2

      [[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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 3

      [[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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$class_name = 1,
      p$excluded_categories = 2,
      p$required_categories = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      attributes: jmt$object_attribute;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$get_attributes (jmc$profile_job_class, #SEQ (pdt), ^pvt, attributes,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$change_object (jmc$profile_job_class, pvt [p$class_name].value^,
          attributes, jmc$delete_list_items, status);

  PROCEND jmp$_delete_job_category_entry;
?? TITLE := 'jmp$_quit', EJECT ??

{ PURPOSE:
{   Exits the subutility.
{
{ DESIGN:
{   Terminates the subutility.

  PROCEDURE jmp$_quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admjc_qui) quit, qui (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 9, 26, 10, 44, 46, 770], clc$command, 1, 1, 0, 0, 0,
            0, 1, 'OSM$ADMJC_QUI'], [['STATUS                         ',
            clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_include (utility_name, status);

  PROCEND jmp$_quit;
?? TITLE := '[XDCL, #GATE] jmp$_administer_job_class', EJECT ??

{ PURPOSE:
{   Starts the ADMINISTER_JOB_CLASS subutility.
{
{ DESIGN:
{   Pass the command table to command_language.

  PROCEDURE [XDCL, #GATE] jmp$_administer_job_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adms_admjc) administer_job_class (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 9, 26, 10, 45, 33, 790], clc$command, 1, 1, 0, 0, 0,
            0, 1, 'OSM$ADMS_ADMJC'], [['STATUS                         ',
            clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    utility_attributes [1].command_table := command_table;
    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmv$current_profile_level := jmc$profile_job_class;

    clp$include_file (command_file, '', utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (utility_name, status);

  PROCEND jmp$_administer_job_class;
MODEND jmm$administer_job_class;
*DECK DECK=JMM$ADMINISTER_OBJECTS EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Scheduling : administer objects' ??
MODULE jmm$administer_objects;

{ PURPOSE:
{   This module contains the routines that manage the creating, changing
{   deleting, and rearranging of profile objects.
{
{ DESIGN:
{   Objects are kept as linked lists with a separate list for each object
{   type.  The objects are kept in the users order which means that they
{   are not sorted by the object name and cannot be kept as a binary tree.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc jmt$profile_object
*copyc jmt$profile_object_list
?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc jmc$job_management_id
*copyc jme$profile_object_errors
*copyc jmt$ways_to_change_object
?? POP ??
*copyc clp$count_list_elements
*copyc jmp$copy_attributes
*copyc jmp$delete_attributes
*copyc jmp$internal_error
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc pmp$generate_unique_name
*copyc pmp$get_mainframe_id

*copyc jmv$object_definition
*copyc jmv$object_heap
*copyc jmv$the_profile
*copyc jmv$working_storage
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? NEWTITLE := '[XDCL, #GATE] jmv$current_class_name', EJECT ??

{ PURPOSE:
{   JMV$CURRENT_CLASS_NAME contains the name of the last referenced
{   profile object for each profile object kind.  If ALL was last
{   referenced then it will contain ALL for that object kind.

  VAR
    jmv$current_class_name: [XDCL, #GATE] array [jmt$profile_object_kinds] of
          ^array [1 .. * ] of ost$name := [REP 9 of NIL];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmv$current_profile_level', EJECT ??

{ PURPOSE:
{   JMV$CURRENT_PROFILE_LEVEL contains the object kind of the last referenced
{   profile object.

  VAR
    jmv$current_profile_level: [XDCL, #GATE] jmt$profile_object_kinds :=
          jmc$profile_job_class;

?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$add_object', EJECT ??

{ PURPOSE:
{   This interface adds an object to the profile.
{
{ DESIGN:
{   The routine adds the objects to the end of the list of objects of the
{   specified type.
{
{ NOTES:
{   Check for duplicate named objects.  This is valid for job_categories
{   and if it occurs the objects must be added after the last category
{   object with the same name.

  PROCEDURE [XDCL, #GATE] jmp$add_object
    (    the_kind: jmt$profile_object_kinds;
         the_name: string ( * );
         the_attributes: jmt$object_attribute;
     VAR the_object: jmt$profile_object_reference;
     VAR status: ost$status);

    VAR
      attribute_constraints: jmt$attribute_check_routine,
      count: integer,
      i: integer,
      local_status: ost$status,
      new_object: jmt$profile_object_reference,
      object: jmt$profile_object,
      object_default: clt$data_value,
      previous_object: jmt$profile_object_reference,
      size: integer,
      unique_name: ost$unique_name;

    status.normal := TRUE;

    pmp$generate_unique_name (unique_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    object.name := the_name;
    object.kind := the_kind;
    object.behaviour_id := unique_name.value;
    object.definition_id := unique_name.value;
    object.references := 0;
    object.index := 0;
    object.changed := TRUE;
    object.permanent := FALSE;
    object.next_object := NIL;
    object.attributes := the_attributes;

    attribute_constraints := jmv$object_definition [the_kind].check_attributes;
    IF attribute_constraints <> NIL THEN
      attribute_constraints^ (object, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    jmp$get_object (the_name, the_kind, new_object, previous_object,
          local_status);
    IF local_status.normal THEN
      IF the_kind <> jmc$profile_category THEN
        the_object := new_object;
        set_object_error (jme$object_already_known, object, status);
        RETURN;
      IFEND;
      REPEAT
        previous_object := new_object;
        new_object := new_object^.next_object;
      UNTIL (new_object = NIL) OR (new_object^.name <> the_name);
    IFEND;

    IF jmv$the_profile.count [the_kind] =
          jmv$object_definition [the_kind].maximum_number_of_objects THEN
      set_object_error (jme$too_many_objects, object, status);
      RETURN;
    IFEND;

    ALLOCATE new_object IN jmv$object_heap^;
    IF new_object = NIL THEN
      jmp$internal_error (51);
    IFEND;

    new_object^ := object;
    jmp$copy_attributes (object.attributes, new_object^.attributes);
    IF the_attributes.kind = jmc$type THEN
      jmp$delete_attributes (new_object^.attributes.
            attribute_list^ [jmc$object_abbreviation]);
    IFEND;

    object_default.kind := clc$name;
    object_default.name_value := the_name;
    jmp$set_object_default (the_kind, ^object_default);
    jmv$the_profile.definition_id := object.definition_id;

    jmv$the_profile.count [the_kind] := jmv$the_profile.count [the_kind] + 1;

    IF previous_object = NIL THEN
      new_object^.next_object := jmv$the_profile.objects [the_kind];
      jmv$the_profile.objects [the_kind] := new_object;
    ELSE
      new_object^.next_object := previous_object^.next_object;
      previous_object^.next_object := new_object;
    IFEND;
    the_object := new_object;

  PROCEND jmp$add_object;
?? TITLE := '[XDCL, #GATE] jmp$change_object', EJECT ??

{ PURPOSE:
{   This interface updates the attribute list for one or more objects.
{
{ DESIGN:
{   The objects are found and the attribute list changed.  If the request is
{   to replace then the list is replaced as a whole.  Otherwise the list is
{   merged with the old list replacing only those parts of the list that
{   have been newly specified.

  PROCEDURE [XDCL, #GATE] jmp$change_object
    (    object_kind: jmt$profile_object_kinds;
         objects: clt$data_value;
         new_attributes: jmt$object_attribute;
         how: jmt$ways_to_change_object;
     VAR status: ost$status);

    VAR
      attribute_definition: jmt$profile_declaration,
      attribute_constraints: jmt$attribute_check_routine;

?? NEWTITLE := 'change_object', EJECT ??

{ PURPOSE:
{   This interface updates the attribute list for an object.
{
{ DESIGN:
{   The attribute list is changed for the specified object.  If the request is
{   to replace then the list is replaced as a whole.  Otherwise the list is
{   merged with the old list replacing only those parts of the list that
{   have been newly specified.
{
{ NOTES:
{   Objects following with the same name are deleted.
{   If any attribute changed in the membership group then the definition id
{     of both the object and the profile are changed.

    PROCEDURE change_object
      (VAR the_object: jmt$profile_object_reference;
       VAR status: ost$status);

?? NEWTITLE := 'build_merged_list', EJECT ??

{ PURPOSE:
{   Replace the parts of the old attribute list that are changed in the
{   new attribute list.

      PROCEDURE build_merged_list
        (    new_attribute: jmt$object_attribute;
             old_attribute: jmt$object_attribute;
         VAR updated_attribute: jmt$object_attribute);

        TYPE
          item = record
            upper,
            lower: integer,
            attribute: jmt$object_attribute,
            next_item: ^item,
          recend;

        VAR
          new_item: ^item,
          an_item: ^item,
          top_item: ^item,
          another_item: ^item,
          previous_item: ^item,
          items: integer,
          i: integer,
          pair: ^jmt$object_attribute_list,
          result_list: ^jmt$object_attribute_list;

        top_item := NIL;
        items := 0;

{ unpack old_attribute

        IF old_attribute.kind = jmc$editable_list THEN
          FOR i := UPPERBOUND (old_attribute.attribute_list^) DOWNTO 1 DO
            PUSH new_item;
            new_item^.attribute := old_attribute.attribute_list^ [i];
            pair := new_item^.attribute.attribute_list^ [1].attribute_list;
            new_item^.lower := pair^ [1].number;
            new_item^.upper := new_item^.lower;
            IF pair^ [2].kind <> jmc$empty THEN
              new_item^.upper := pair^ [2].number;
            IFEND;
            new_item^.next_item := top_item;
            top_item := new_item;
            items := items + 1;
          FOREND;
        IFEND;

{ unpack new_attribute

        FOR i := 1 TO UPPERBOUND (new_attribute.attribute_list^) DO
          PUSH new_item;
          items := items + 1;
          new_item^.attribute := new_attribute.attribute_list^ [i];
          pair := new_item^.attribute.attribute_list^ [1].attribute_list;
          new_item^.lower := pair^ [1].number;
          new_item^.upper := new_item^.lower;
          IF pair^ [2].kind <> jmc$empty THEN
            new_item^.upper := pair^ [2].number;
            IF new_item^.upper < new_item^.lower THEN
              new_item^.upper := pair^ [1].number;
              new_item^.lower := pair^ [2].number;
            IFEND;
          IFEND;
          an_item := top_item;
          previous_item := NIL;
          WHILE (an_item <> NIL) AND (an_item^.upper < new_item^.lower) DO
            previous_item := an_item;
            an_item := an_item^.next_item;
          WHILEND;
          IF (an_item <> NIL) AND (an_item^.lower < new_item^.lower) THEN
            PUSH another_item;
            another_item^ := an_item^;
            an_item^.next_item := new_item;
            an_item^.upper := new_item^.lower - 1;
            an_item := another_item;
            items := items + 1;
          ELSEIF previous_item = NIL THEN
            top_item := new_item;
          ELSE
            previous_item^.next_item := new_item;
          IFEND;
          WHILE (an_item <> NIL) AND (an_item^.upper <= new_item^.upper) DO
            an_item := an_item^.next_item;
            items := items - 1;
          WHILEND;
          IF (an_item <> NIL) AND (an_item^.lower <= new_item^.upper) THEN
            an_item^.lower := new_item^.upper + 1;
          IFEND;
          new_item^.next_item := an_item;
        FOREND;

{ Build updated_attribute

        updated_attribute.kind := jmc$editable_list;
        ALLOCATE updated_attribute.attribute_list: [1 .. items] IN
              jmv$object_heap^;
        FOR i := 1 TO items DO
          jmp$copy_attributes (top_item^.attribute,
                updated_attribute.attribute_list^ [i]);
          pair := updated_attribute.attribute_list^ [i].attribute_list^ [1].
                attribute_list;
          pair^ [1].number := top_item^.lower;
          IF top_item^.lower = top_item^.upper THEN
            pair^ [2].kind := jmc$empty;
          ELSE
            pair^ [2].kind := pair^ [1].kind;
            pair^ [2].number := top_item^.upper;
          IFEND;
          top_item := top_item^.next_item;
        FOREND;
      PROCEND build_merged_list;

?? NEWTITLE := 'merge_new_attributes', EJECT ??

{ PURPOSE:
{   Replace the parts of the old attribute list that are changed in the
{   new attribute list.

      PROCEDURE merge_new_attributes
        (    new_attribute: jmt$object_attribute;
             old_attribute: jmt$object_attribute;
         VAR updated_attribute: jmt$object_attribute);

        VAR
          default_attribute: [STATIC] jmt$object_attribute := [jmc$default],
          smaller_list_size: jmt$object_attribute_index,
          desired_list_size: jmt$object_attribute_index,
          index: jmt$object_attribute_index;

        CASE new_attribute.kind OF
        = jmc$empty =
          jmp$copy_attributes (old_attribute, updated_attribute);
        = jmc$range =
          jmp$copy_attributes (new_attribute, updated_attribute);
        = jmc$editable_list =
          build_merged_list (new_attribute, old_attribute, updated_attribute);
        = jmc$list, jmc$type =
          updated_attribute := new_attribute;
          desired_list_size := UPPERBOUND (new_attribute.attribute_list^);
          ALLOCATE updated_attribute.attribute_list:
                [1 .. desired_list_size] IN jmv$object_heap^;
          IF updated_attribute.attribute_list = NIL THEN
            jmp$internal_error (52);
          IFEND;
          smaller_list_size := 0;
          IF old_attribute.kind = new_attribute.kind THEN
            smaller_list_size := UPPERBOUND (old_attribute.attribute_list^);
            IF smaller_list_size > desired_list_size THEN
              smaller_list_size := desired_list_size;
            IFEND;
            FOR index := 1 TO smaller_list_size DO
              merge_new_attributes (new_attribute.attribute_list^ [index],
                    old_attribute.attribute_list^ [index],
                    updated_attribute.attribute_list^ [index]);
            FOREND;
          IFEND;
          FOR index := smaller_list_size + 1 TO desired_list_size DO
            merge_new_attributes (new_attribute.attribute_list^ [index],
                  default_attribute, updated_attribute.
                  attribute_list^ [index]);
          FOREND;
        = jmc$name, jmc$object, jmc$file =
          jmp$copy_attributes (new_attribute, updated_attribute);
        ELSE
          updated_attribute := new_attribute;
        CASEND;
      PROCEND merge_new_attributes;
?? TITLE := 'modify_attributes', EJECT ??

{ PURPOSE:
{   Build an updated attribute by adding/removing the elements in lists in
{   attribute_update to/from the lists in old_attribute.

      PROCEDURE modify_attributes
        (    attribute_update: jmt$object_attribute;
             old_attribute: jmt$object_attribute;
         VAR new_attribute: jmt$object_attribute);

        VAR
          default_attribute: [STATIC] jmt$object_attribute := [jmc$default],
          smaller_list_size: jmt$object_attribute_index,
          desired_list_size: jmt$object_attribute_index,
          index: jmt$object_attribute_index;

        CASE attribute_update.kind OF
        = jmc$all =
          new_attribute.kind := jmc$all;
          IF how = jmc$delete_list_items THEN
            new_attribute.kind := jmc$none;
          IFEND;
        = jmc$type =
          new_attribute.kind := attribute_update.kind;
          desired_list_size := UPPERBOUND (attribute_update.attribute_list^);
          NEXT new_attribute.attribute_list: [1 .. desired_list_size] IN
                jmv$working_storage;
          IF new_attribute.attribute_list = NIL THEN
            jmp$internal_error (52);
          IFEND;
          smaller_list_size := 0;
          IF old_attribute.kind = attribute_update.kind THEN
            smaller_list_size := UPPERBOUND (old_attribute.attribute_list^);
            IF smaller_list_size > desired_list_size THEN
              smaller_list_size := desired_list_size;
            IFEND;
            FOR index := 1 TO smaller_list_size DO
              modify_attributes (attribute_update.attribute_list^ [index],
                    old_attribute.attribute_list^ [index],
                    new_attribute.attribute_list^ [index]);
            FOREND;
          IFEND;
          FOR index := smaller_list_size + 1 TO desired_list_size DO
            modify_attributes (attribute_update.attribute_list^ [index],
                  default_attribute, new_attribute.attribute_list^ [index]);
          FOREND;
        = jmc$list =
          update_attribute_list (attribute_update, old_attribute,
                new_attribute);
        ELSE
          new_attribute := attribute_update;
        CASEND;
      PROCEND modify_attributes;
?? TITLE := 'update_attribute_list', EJECT ??

{ PURPOSE:
{   Add to/Remove from the list in old attribute the items in the list in
{   new attribute producing a new updated list in updated attribute.

      PROCEDURE update_attribute_list
        (    attribute_update: jmt$object_attribute;
             old_attribute: jmt$object_attribute;
         VAR new_attribute: jmt$object_attribute);

        VAR
          old_list_size: jmt$object_attribute_index,
          desired_list_size: jmt$object_attribute_index,
          first_object: jmt$profile_object_reference,
          attribute: jmt$object_attribute,
          object: jmt$profile_object_reference,
          object_count: 0 .. jmc$maximum_objects_on_profile,
          last_name: ost$name,
          toggle: 0 .. 1,
          index: jmt$object_attribute_index;

        new_attribute := attribute_update;
        IF attribute_update.attribute_list^ [1].kind <> jmc$object THEN
          RETURN;
        IFEND;
        object := attribute_update.attribute_list^ [1].object_p;
        first_object := jmv$the_profile.objects [object^.kind];
        CASE old_attribute.kind OF
        = jmc$list =
          toggle := 0;
          old_list_size := UPPERBOUND (old_attribute.attribute_list^);
        = jmc$all =
          toggle := 1;
          old_list_size := 0;
        ELSE
          IF how = jmc$delete_list_items THEN
            set_object_error (jme$item_to_delete_is_missing, object^, status);
            EXIT change_object;
          IFEND;
          RETURN;
        CASEND;

{ Represent the old list as 'profile_index=1' in the actual profile
{ objects for those objects in the list.

        object := first_object;
        object_count := 0;
        last_name := '';
        WHILE object <> NIL DO
          object^.profile_index := 0;
          IF object^.name <> last_name THEN
            object_count := object_count + 1;
            object^.profile_index := toggle;
          IFEND;
          last_name := object^.name;
          object := object^.next_object;
        WHILEND;
        desired_list_size := object_count * toggle;
        FOR index := 1 TO old_list_size DO
          attribute := old_attribute.attribute_list^ [index];
          IF attribute.kind = jmc$object THEN
            desired_list_size := desired_list_size -
                  attribute.object_p^.profile_index + 1;
            attribute.object_p^.profile_index := 1;
          IFEND;
        FOREND;

{ Add or Delete items from the list by changing the 'Profile_index' to
{ 1 or 0 respectively in the profile objects to be added or removed.

        toggle := 1;
        IF how = jmc$delete_list_items THEN
          toggle := 0;
        IFEND;
        FOR index := 1 TO UPPERBOUND (attribute_update.attribute_list^) DO
          attribute := attribute_update.attribute_list^ [index];
          IF attribute.kind = jmc$object THEN
            IF attribute.object_p^.profile_index = toggle THEN
              IF toggle = 0 THEN
                set_object_error (jme$item_to_delete_is_missing,
                      attribute.object_p^, status);
              ELSE
                set_object_error (jme$item_to_add_is_present,
                      attribute.object_p^, status);
              IFEND;
              EXIT change_object;
            IFEND;
            desired_list_size := desired_list_size + 2 * toggle - 1;
            attribute.object_p^.profile_index := toggle;
          IFEND;
        FOREND;

{ Build new list with all profile objects with 'profile_index=1'.

        IF desired_list_size = object_count THEN
          new_attribute.kind := jmc$all;
        ELSEIF desired_list_size = 0 THEN
          new_attribute.kind := jmc$none;
        ELSE
          NEXT new_attribute.attribute_list: [1 .. desired_list_size] IN
                jmv$working_storage;
          IF new_attribute.attribute_list = NIL THEN
            jmp$internal_error (52);
          IFEND;

          object := first_object;
          index := 0;
          WHILE object <> NIL DO
            IF object^.profile_index = 1 THEN
              index := index + 1;
              new_attribute.attribute_list^ [index].kind := jmc$object;
              new_attribute.attribute_list^ [index].object_p := object;
            IFEND;
            object := object^.next_object;
          WHILEND;
        IFEND;
      PROCEND update_attribute_list;
?? OLDTITLE, EJECT ??

      VAR
        following_object: jmt$profile_object_reference,
        new_object: jmt$profile_object,
        old_attributes: jmt$object_attribute,
        unique_name: ost$unique_name,
        update_attributes: jmt$object_attribute;

      new_object := the_object^;

      pmp$generate_unique_name (unique_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      new_object.behaviour_id := unique_name.value;
      new_object.changed := TRUE;

      old_attributes := new_object.attributes;
      IF how = jmc$replace THEN
        jmv$the_profile.definition_id := unique_name.value;
        new_object.definition_id := unique_name.value;
        new_object.attributes.kind := jmc$default;
      ELSE
        IF new_attributes.kind = jmc$type THEN
          FOR i := 1 TO UPPERBOUND (new_attributes.attribute_list^) DO
            IF new_attributes.attribute_list^ [i].kind <> jmc$empty THEN
              IF attribute_definition.declarations^ [i]^.group =
                    jmc$membership_group THEN
                new_object.definition_id := unique_name.value;
                jmv$the_profile.definition_id := unique_name.value;
              IFEND;
            IFEND;
          FOREND;
        IFEND;
      IFEND;

      IF how = jmc$replace THEN
        jmp$copy_attributes (new_attributes, new_object.attributes);
      ELSE
        IF how = jmc$update THEN
          update_attributes := new_attributes;
        ELSE
          modify_attributes (new_attributes, old_attributes,
                update_attributes);
        IFEND;

        merge_new_attributes (update_attributes, new_object.attributes,
              new_object.attributes);
      IFEND;

      IF attribute_constraints <> NIL THEN
        attribute_constraints^ (new_object, status);
        IF NOT status.normal THEN
          jmp$delete_attributes (new_object.attributes);
          RETURN;
        IFEND;
      IFEND;
      jmp$delete_attributes (old_attributes);

{ Delete all additional definitions with this same name.

      following_object := new_object.next_object;
      WHILE (following_object <> NIL) AND (following_object^.name =
            new_object.name) DO
        new_object.next_object := following_object^.next_object;
        jmp$delete_attributes (following_object^.attributes);
        FREE following_object IN jmv$object_heap^;
        following_object := new_object.next_object;
      WHILEND;

      the_object^ := new_object;
    PROCEND change_object;
?? OLDTITLE, EJECT ??

    VAR
      abbreviation: ost$name,
      i: integer,
      ignored: jmt$profile_object_reference,
      list_entry: ^clt$data_value,
      object_with_abbreviation: jmt$profile_object_reference,
      the_object: jmt$profile_object_reference;

    status.normal := TRUE;

    attribute_definition := jmv$object_definition [object_kind].declaration;
    attribute_constraints := jmv$object_definition [object_kind].
          check_attributes;

  /change/
    BEGIN
      abbreviation := osc$null_name;
      object_with_abbreviation := NIL;
      IF new_attributes.kind = jmc$type THEN
        IF new_attributes.attribute_list^ [jmc$object_abbreviation].kind =
              jmc$name THEN
          abbreviation := new_attributes.attribute_list^ [
                jmc$object_abbreviation].name^;
          jmp$get_object (abbreviation, object_kind, object_with_abbreviation,
                ignored, status);
          status.normal := TRUE;
        IFEND;
      IFEND;

      IF objects.kind = clc$name THEN
        jmp$get_object (objects.name_value, object_kind, the_object, ignored,
              status);
        IF NOT status.normal THEN
          EXIT /change/;
        IFEND;
        IF (object_with_abbreviation <> NIL) AND
              (object_with_abbreviation <> the_object) THEN
          osp$set_status_abnormal (jmc$job_management_id,
                jme$duplicate_abbreviation, abbreviation, status);
          EXIT /change/;
        IFEND;
        change_object (the_object, status);

      ELSEIF objects.kind = clc$list THEN
        list_entry := ^objects;
        IF (abbreviation <> osc$null_name) AND
              (clp$count_list_elements (list_entry) > 1) THEN
          osp$set_status_abnormal (jmc$job_management_id,
                jme$abbreviation_change_illegal, '', status);
          EXIT /change/;
        IFEND;
        WHILE list_entry <> NIL DO
          IF list_entry^.element_value <> NIL THEN
            jmp$get_object (list_entry^.element_value^.name_value, object_kind,
                  the_object, ignored, status);
            IF NOT status.normal THEN
              EXIT /change/;
            IFEND;
            IF (object_with_abbreviation <> NIL) AND
                  (object_with_abbreviation <> the_object) THEN
              osp$set_status_abnormal (jmc$job_management_id,
                    jme$duplicate_abbreviation, abbreviation, status);
              EXIT /change/;
            IFEND;
            change_object (the_object, status);
            IF NOT status.normal THEN
              EXIT /change/;
            IFEND;
          IFEND;
          list_entry := list_entry^.link;
        WHILEND;

      ELSEIF objects.kind = clc$keyword {ALL} THEN
        the_object := jmv$the_profile.objects [object_kind];
        WHILE the_object <> NIL DO
          change_object (the_object, status);
          IF NOT status.normal THEN
            EXIT /change/;
          IFEND;
          the_object := the_object^.next_object;
        WHILEND;
      IFEND;
      jmp$set_object_default (object_kind, ^objects);
    END /change/;
  PROCEND jmp$change_object;
?? TITLE := '[XDCL, #GATE] jmp$delete_object', EJECT ??

{ PURPOSE:
{   This interface deletes the specified objects from the profile.
{
{ DESIGN:
{   The routine determines the objects to be deleted and calls a subordinate
{   routine to actually delete them.

  PROCEDURE [XDCL, #GATE] jmp$delete_object
    (    object_kind: jmt$profile_object_kinds;
         objects: clt$data_value;
     VAR status: ost$status);

?? NEWTITLE := 'delete_object', EJECT ??

{ PURPOSE:
{   This interface deletes the specified object from the profile.
{
{ DESIGN:
{   The routine locates the object and removes it and any objects following
{   it that have the same name.
{
{ NOTES:
{   Deleting an object causes the profile definition_id to be changed.

    PROCEDURE delete_object
      (    previous_object: jmt$profile_object_reference;
       VAR the_object: jmt$profile_object_reference;
       VAR status: ost$status);

?? NEWTITLE := 'count_self_references', EJECT ??

      FUNCTION count_self_references
        (    attribute: jmt$object_attribute): integer;

        VAR
          i: integer,
          references: integer;

        references := 0;
        IF attribute.kind = jmc$object THEN
          references := $INTEGER (attribute.object_p = the_object);
        ELSEIF attribute.kind <= jmc$range THEN
          FOR i := 1 TO UPPERBOUND (attribute.attribute_list^) DO
            references := references + count_self_references
                  (attribute.attribute_list^ [i]);
          FOREND;
        IFEND;
        count_self_references := references;
      FUNCEND count_self_references;
?? OLDTITLE, EJECT ??

      VAR
        name: ost$name,
        next_object: jmt$profile_object_reference;

      IF the_object^.permanent THEN
        set_object_error (jme$permanent_object, the_object^, status);
        RETURN;
      IFEND;

      IF count_self_references (the_object^.attributes) <
            the_object^.references THEN
        osp$set_status_abnormal (jmc$job_management_id,
              jme$profile_object_referenced, the_object^.name, status);
        RETURN;
      IFEND;

      name := the_object^.name;
      REPEAT
        next_object := the_object^.next_object;
        jmv$the_profile.count [object_kind] :=
              jmv$the_profile.count [object_kind] - 1;
        jmp$delete_attributes (the_object^.attributes);
        FREE the_object IN jmv$object_heap^;
        the_object := next_object;
      UNTIL (next_object = NIL) OR (next_object^.name <> name);

      IF previous_object = NIL THEN
        jmv$the_profile.objects [object_kind] := next_object;
      ELSE
        previous_object^.next_object := next_object;
      IFEND;
      jmv$the_profile.definition_id := unique_name.value;
    PROCEND delete_object;
?? OLDTITLE, EJECT ??

    VAR
      i: integer,
      unique_name: ost$unique_name,
      an_object: ^clt$data_value,
      the_object: jmt$profile_object_reference,
      previous_object: jmt$profile_object_reference;

    pmp$generate_unique_name (unique_name, status);

    IF objects.kind = clc$name THEN
      jmp$get_object (objects.name_value, object_kind, the_object,
            previous_object, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      delete_object (previous_object, the_object, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    ELSEIF objects.kind = clc$list THEN
      an_object := ^objects;
      WHILE an_object <> NIL DO
        jmp$delete_object (object_kind, an_object^.element_value^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        an_object := an_object^.link;
      WHILEND;

    ELSEIF objects.kind = clc$keyword {ALL} THEN
      WHILE jmv$the_profile.objects [object_kind] <> NIL DO
        the_object := jmv$the_profile.objects [object_kind];
        delete_object (NIL, the_object, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      WHILEND;
    IFEND;
    jmp$set_object_default (object_kind, NIL);

  PROCEND jmp$delete_object;
?? TITLE := '[XDCL] jmp$get_object', EJECT ??

{ PURPOSE:
{   This interface finds the requested object.
{
{ DESIGN:
{   The request makes a sequencial search for the name in the list of objects
{   of the specified type.  Both the name and abbreviation are checked.
{
{ NOTES:
{   The pointer to the first of a list of same-named types is returned.

  PROCEDURE [XDCL] jmp$get_object
    (    the_name: string ( * );
         the_kind: jmt$profile_object_kinds;
     VAR the_object: jmt$profile_object_reference;
     VAR previous_object: jmt$profile_object_reference;
     VAR status: ost$status);

    VAR
      object: jmt$profile_object,
      current_object: jmt$profile_object_reference;

{ Search for object with a matching name of the desired type.

    status.normal := TRUE;

    previous_object := NIL;
    current_object := jmv$the_profile.objects [the_kind];
    WHILE (current_object <> NIL) AND (current_object^.name <> the_name) DO
      previous_object := current_object;
      current_object := current_object^.next_object;
    WHILEND;

    IF current_object <> NIL THEN
      the_object := current_object;
      RETURN;
    IFEND;

{ Search for object with an abbrievation that matches.

    previous_object := NIL;
    current_object := jmv$the_profile.objects [the_kind];
    WHILE (current_object <> NIL) DO
      IF current_object^.attributes.kind = jmc$type THEN
        IF current_object^.attributes.attribute_list^
              [jmc$object_abbreviation].kind = jmc$name THEN
          IF current_object^.attributes.attribute_list^ [
                jmc$object_abbreviation].name^ = the_name THEN
            the_object := current_object;
            RETURN;
          IFEND;
        IFEND;
      IFEND;
      previous_object := current_object;
      current_object := current_object^.next_object;
    WHILEND;
    the_object := NIL;
    object.name := the_name;
    object.kind := the_kind;
    set_object_error (jme$object_not_known, object, status);

  PROCEND jmp$get_object;
?? TITLE := '[XDCL] jmp$move_object', EJECT ??

{ PURPOSE:
{   This interface moves one or more objects to follow the specified object.
{
{ DESIGN:
{   The destination object is found and all objects are found and moved in
{   front of the destination object.

  PROCEDURE [XDCL] jmp$move_object
    (    object_kind: jmt$profile_object_kinds;
         objects: clt$data_value;
         destination_name: string ( * );
     VAR status: ost$status);

    VAR
      destination_object: jmt$profile_object_reference,
      previous_to_destination: jmt$profile_object_reference;

?? NEWTITLE := 'move_object', EJECT ??

{ PURPOSE:
{   This interface moves an object to in front of the destination object.
{
{ DESIGN:
{   Delete the object from the list and then reinsert it in front of the
{   destination object.
{
{ NOTES:
{   Moving an object changes the DEFINITION_ID of the profile.

    PROCEDURE move_object
      (    previous_object: jmt$profile_object_reference;
       VAR object_to_move: jmt$profile_object_reference;
       VAR status: ost$status);

      IF (previous_to_destination = object_to_move) OR
            (destination_object = object_to_move) THEN
        RETURN;
      IFEND;

      IF object_to_move^.name = 'UNASSIGNED' THEN
        set_object_error (jme$cannot_move_unassigned, object_to_move^, status);
        RETURN;
      IFEND;

      IF previous_object = NIL THEN
        jmv$the_profile.objects [object_to_move^.kind] :=
              object_to_move^.next_object;
      ELSE
        previous_object^.next_object := object_to_move^.next_object;
      IFEND;

      object_to_move^.next_object := destination_object;
      IF previous_to_destination = NIL THEN
        jmv$the_profile.objects [object_to_move^.kind] := object_to_move;
      ELSE
        previous_to_destination^.next_object := object_to_move;
      IFEND;
      previous_to_destination := object_to_move;

      jmv$the_profile.definition_id := unique_name.value;
    PROCEND move_object;
?? OLDTITLE, EJECT ??

    VAR
      list_entry: ^clt$data_value,
      previous_object: jmt$profile_object_reference,

      the_object: jmt$profile_object_reference,
      unique_name: ost$unique_name;

    pmp$generate_unique_name (unique_name, status);

    jmp$get_object (destination_name, object_kind, destination_object,
          previous_to_destination, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF objects.kind = clc$name THEN
      jmp$get_object (objects.name_value, object_kind, the_object,
            previous_object, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      move_object (previous_object, the_object, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    ELSEIF objects.kind = clc$list THEN
      list_entry := ^objects;
      WHILE list_entry <> NIL DO
        IF list_entry^.element_value <> NIL THEN
          jmp$get_object (list_entry^.element_value^.name_value, object_kind,
                the_object, previous_object, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          move_object (previous_object, the_object, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        list_entry := list_entry^.link;
      WHILEND;

    ELSEIF objects.kind = clc$keyword {ALL} THEN
      the_object := destination_object^.next_object;
      WHILE the_object <> NIL DO
        move_object (destination_object, the_object, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        the_object := destination_object^.next_object;
      WHILEND;
    IFEND;
    jmp$set_object_default (object_kind, ^objects);

  PROCEND jmp$move_object;
?? OLDTITLE ??
?? NEWTITLE := '[XREF, #GATE] jmp$set_object_default', EJECT ??

{ PURPOSE:
{   Defines the new default for that object type in commands.

  PROCEDURE [XDCL, #GATE] jmp$set_object_default
    (    object_kind: jmt$profile_object_kinds;
         objects: ^clt$data_value);

    VAR
      i: clt$list_size,
      list_size: clt$list_size,
      node: ^clt$data_value;

    IF jmv$current_class_name [object_kind] <> NIL THEN
      FREE jmv$current_class_name [object_kind] IN jmv$object_heap^;
    IFEND;
    jmv$current_class_name [object_kind] := NIL;
    IF (objects <> NIL) THEN
      IF objects^.kind = clc$list THEN
        list_size := clp$count_list_elements (objects);
        IF list_size > 0 THEN
          ALLOCATE jmv$current_class_name [object_kind]: [1 .. list_size] IN
                jmv$object_heap^;
        IFEND;
        node := objects;
        FOR i := 1 TO clp$count_list_elements (objects) DO
          jmv$current_class_name [object_kind]^ [i] :=
                node^.element_value^.name_value;
          node := node^.link;
        FOREND
      ELSE
        ALLOCATE jmv$current_class_name [object_kind]: [1 .. 1] IN
              jmv$object_heap^;
        IF (objects^.kind = clc$keyword) THEN
          jmv$current_class_name [object_kind]^ [1] := objects^.keyword_value;
        ELSE
          jmv$current_class_name [object_kind]^ [1] := objects^.name_value;
        IFEND;
      IFEND;
    IFEND;
    jmv$current_profile_level := object_kind;
  PROCEND jmp$set_object_default;
?? OLDTITLE ??
?? NEWTITLE := 'set_object_error', EJECT ??

{ PURPOSE:
{   This routine builds an error message including both the object name
{   and object kind.

  PROCEDURE set_object_error
    (    the_error: ost$status_condition_code;
         the_object: jmt$profile_object;
     VAR status: ost$status);

    osp$set_status_abnormal (jmc$job_management_id, the_error, the_object.name,
          status);
    osp$append_status_parameter (osc$status_parameter_delimiter,
          jmv$object_definition [the_object.kind].declaration.name, status);
  PROCEND set_object_error;
MODEND jmm$administer_objects;

*DECK DECK=JMM$ADMINISTER_OUTPUT_CLASS EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Scheduling : administer_output_class' ??
MODULE jmm$administer_output_class;

{ PURPOSE:
{   This module defines the commands that make up the subutility of
{   ADMINISTER_SCHEDULING called ADMINISTER_OUTPUT_CLASS.  This utility
{   manages the output classes on the scheduling profile.  The procedures
{   in this module allow the administrator to create, change, delete
{   and display output classes on/from the scheduling profile.
{
{ DESIGN:
{   This module mainly provides the framework for the utility.  It
{   contains the PDTs and code for the subutility and it's subcommands.
{
{ NOTES:
{   Most of the work of creating, deleting, changing, and displaying is
{   done in routines which are generalized to handle all types of objects.
{   These routines can be found in the modules JMM$ADMINISTER_DISPLAY and
{   JMM$ADMINISTER_OBJECTS.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$maximum_job_count
*copyc jmc$profile_constants
*copyc jmt$default_and_range_parameter
*copyc jmt$job_priority
*copyc jmt$output_class_attributes
?? POP ??
*copyc clp$begin_utility
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$include_file
*copyc clp$evaluate_parameters
*copyc jmp$add_object
*copyc jmp$change_object
*copyc jmp$delete_object
*copyc jmp$get_attributes
*copyc jmp$get_object_list
*copyc jmp$move_object
*copyc jmp$set_default_attributes

*copyc jmv$current_profile_level
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    command_file: amt$local_file_name := clc$current_command_input,
    utility_name: string (31) := 'ADMINISTER_OUTPUT_CLASS        ',
    utility_attributes: array [1 .. 2] of clt$utility_attribute :=
          [[clc$utility_command_table, * ], [clc$utility_prompt, [3, 'AOC']]];

{ table command_table
{ command (jmp$_create_class, crec), jmp$_create_class
{ command (jmp$_change_attribute, jmp$_change_attributes, chaa),
{ jmp$_change_attribute
{ command (display_attribute, display_attributes, disa), ..
{   jmp$_display_output_class cm=xref
{ command (jmp$_delete_class, delc), jmp$_delete_class
{ command (quit, qui), jmp$_quit
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    command_table: [STATIC, READ] ^clt$command_table := ^command_table_entries,

    command_table_entries: [STATIC, READ] array [1 .. 12] of
          clt$command_table_entry := [
          {} ['CHAA                           ', clc$abbreviation_entry,
          clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_change_attribute],
          {} ['CHANGE_ATTRIBUTE               ', clc$nominal_entry,
          clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_change_attribute],
          {} ['CHANGE_ATTRIBUTES              ', clc$alias_entry,
          clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_change_attribute],
          {} ['CREATE_CLASS                   ', clc$nominal_entry,
          clc$advertised_entry, 1, clc$automatically_log, clc$linked_call,
          ^jmp$_create_class],
          {} ['CREC                           ', clc$abbreviation_entry,
          clc$advertised_entry, 1, clc$automatically_log, clc$linked_call,
          ^jmp$_create_class],
          {} ['DELC                           ', clc$abbreviation_entry,
          clc$advertised_entry, 4, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_class],
          {} ['DELETE_CLASS                   ', clc$nominal_entry,
          clc$advertised_entry, 4, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_class],
          {} ['DISA                           ', clc$abbreviation_entry,
          clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_display_output_class],
          {} ['DISPLAY_ATTRIBUTE              ', clc$nominal_entry,
          clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_display_output_class],
          {} ['DISPLAY_ATTRIBUTES             ', clc$alias_entry,
          clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_display_output_class],
          {} ['QUI                            ', clc$abbreviation_entry,
          clc$advertised_entry, 5, clc$automatically_log, clc$linked_call,
          ^jmp$_quit],
          {} ['QUIT                           ', clc$nominal_entry,
          clc$advertised_entry, 5, clc$automatically_log, clc$linked_call,
          ^jmp$_quit]];

  PROCEDURE [XREF] jmp$_display_output_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??
?? OLDTITLE ??
?? NEWTITLE := 'jmp$_change_attribute ', EJECT ??

{ PURPOSE:
{   Processes the CHANGE_ATTRIBUTE command.
{
{ DESIGN:
{   Determines the output class objects to update, fetches the attributes that
{   are changing and updates them.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS.

  PROCEDURE jmp$_change_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admo_chaa) change_attribute (
{   class_name, class_names, cn: any of
{       key all keyend
{       list of name
{     anyend = $current_output_class
{   abbreviation, a: (by_name) any of
{       key default, unspecified, none keyend
{       name
{     anyend = $optional
{   delivery_priority, dp: (by_name) any of
{       key default keyend
{       record
{         minimum: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend
{         maximum: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend
{         output_age_increment: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend
{       recend
{     anyend = $optional
{   enable_class_scheduling, ecs: (by_name) any of
{       key default keyend
{       boolean
{     anyend = $optional
{   output_age_interval, oai: (by_name) any of
{       key default, unlimited keyend
{       integer jmc$lowest_prio_age_interval..jmc$highest_prio_age_interval
{     anyend = $optional
{   selection_rank, sr: (by_name) name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 14] of clt$pdt_parameter_name,
        parameters: array [1 .. 7] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (21),
        recend,
        type2: 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 .. 3] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type3: 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$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_3: clt$field_specification,
            element_type_spec_3: 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$integer_type_qualifier,
              recend,
            recend,
          recend,
        recend,
        type4: 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,
          recend,
        recend,
        type5: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type7: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 34, 48, 634], clc$command, 14, 7, 0, 0, 0,
            0, 7, 'OSM$ADMO_CHAA'], [['A                              ',
            clc$abbreviation_entry, 2], ['ABBREVIATION                   ',
            clc$nominal_entry, 2], ['CLASS_NAME                     ',
            clc$nominal_entry, 1], ['CLASS_NAMES                    ',
            clc$alias_entry, 1], ['CN                             ',
            clc$abbreviation_entry, 1], ['DELIVERY_PRIORITY              ',
            clc$nominal_entry, 3], ['DP                             ',
            clc$abbreviation_entry, 3], ['ECS                            ',
            clc$abbreviation_entry, 4], ['ENABLE_CLASS_SCHEDULING        ',
            clc$nominal_entry, 4], ['OAI                            ',
            clc$abbreviation_entry, 5], ['OUTPUT_AGE_INTERVAL            ',
            clc$nominal_entry, 5], ['SELECTION_RANK                 ',
            clc$nominal_entry, 6], ['SR                             ',
            clc$abbreviation_entry, 6], ['STATUS                         ',
            clc$nominal_entry, 7]], [

{ PARAMETER 1

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 21],

{ PARAMETER 2

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 143, clc$optional_parameter, 0,
            0],

{ PARAMETER 3

      [6, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 431, clc$optional_parameter, 0,
            0],

{ PARAMETER 4

      [9, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [11, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 121, clc$optional_parameter, 0,
            0],

{ PARAMETER 6

      [12, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [14, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            '$current_output_class'],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2],
            118, [[1, 0, clc$keyword_type], [3],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ',
            clc$nominal_entry, clc$normal_usage_entry, 3],
            ['UNSPECIFIED                    ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 5, [[1, 0, clc$name_type],
            [1, osc$max_name_size]]],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$record_type], FALSE, 2],
            44, [[1, 0, clc$keyword_type], [1],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 367,
            [[1, 0, clc$record_type], [3], ['MINIMUM                        ',
            clc$required_field, 84], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        '
            , clc$nominal_entry, clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
            jmc$highest_job_priority, 10]]], ['MAXIMUM                        '
            , clc$required_field, 84], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        '
            , clc$nominal_entry, clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
            jmc$highest_job_priority, 10]]], ['OUTPUT_AGE_INCREMENT           '
            , clc$required_field, 84], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        '
            , clc$nominal_entry, clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
            jmc$highest_job_priority, 10]]]]],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type], FALSE,
            2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 3, [[1, 0, clc$boolean_type]]],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 81, [[1, 0, clc$keyword_type],
            [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNLIMITED                      ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_prio_age_interval,
            jmc$highest_prio_age_interval, 10]]],

{ PARAMETER 6

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 7

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$class_name = 1,
      p$abbreviation = 2,
      p$delivery_priority = 3,
      p$enable_class_scheduling = 4,
      p$output_age_interval = 5,
      p$selection_rank = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

    VAR
      the_attributes: jmt$object_attribute;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_output_class;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$get_attributes (jmc$profile_output_class, #SEQ (pdt), ^pvt,
          the_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$selection_rank].specified THEN
      jmp$move_object (jmc$profile_output_class, pvt [p$class_name].value^,
            pvt [p$selection_rank].value^.name_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    jmp$change_object (jmc$profile_output_class, pvt [p$class_name].value^,
          the_attributes, jmc$update, status);

  PROCEND jmp$_change_attribute;
?? TITLE := 'jmp$_create_class ', EJECT ??

{ PURPOSE:
{   Processes the CREATE_CLASS command.
{
{ DESIGN:
{   Fetches the default values and adds the specified output class to the
{   profile.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS.

  PROCEDURE jmp$_create_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admoc_crec) create_class (
{   class_name, cn: name = $required
{   default_values, dv: (by_name) name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 35, 41, 541], clc$command, 5, 3, 1, 0, 0,
            0, 3, 'OSM$ADMOC_CREC'], [['CLASS_NAME                     ',
            clc$nominal_entry, 1], ['CN                             ',
            clc$abbreviation_entry, 1], ['DEFAULT_VALUES                 ',
            clc$nominal_entry, 2], ['DV                             ',
            clc$abbreviation_entry, 2], ['STATUS                         ',
            clc$nominal_entry, 3]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 5,
            clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$class_name = 1,
      p$default_values = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      the_attributes: jmt$object_attribute,
      the_object: jmt$profile_object_reference;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_output_class;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$set_default_attributes (jmc$profile_output_class,
          pvt [p$default_values], the_attributes, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$add_object (jmc$profile_output_class,
          pvt [p$class_name].value^.name_value, the_attributes, the_object,
          status);
    IF status.normal THEN
      jmp$move_object (jmc$profile_output_class, pvt [p$class_name].value^,
            'SYSTEM', status);
    IFEND;

  PROCEND jmp$_create_class;
?? TITLE := 'jmp$_delete_class ', EJECT ??

{ PURPOSE:
{   Processes the DELETE_CLASS command.
{
{ DESIGN:
{   Determine the output classes to delete and delete them.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS

  PROCEDURE jmp$_delete_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admoc_delc) delete_class (
{   class_name, class_names, cn: list of name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 4] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 36, 6, 451], clc$command, 4, 2, 1, 0, 0,
            0, 2, 'OSM$ADMOC_DELC'], [['CLASS_NAME                     ',
            clc$nominal_entry, 1], ['CLASS_NAMES                    ',
            clc$alias_entry, 1], ['CN                             ',
            clc$abbreviation_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 2]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 21,
            clc$required_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$class_name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_output_class;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$delete_object (jmc$profile_output_class, pvt [p$class_name].value^,
          status);

  PROCEND jmp$_delete_class;
?? TITLE := 'jmp$_quit', EJECT ??

{ PURPOSE:
{   Exits the subutility.
{
{ DESIGN:
{   Terminates the subutility.

  PROCEDURE jmp$_quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admoc_qui) quit (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 9, 26, 11, 36, 25, 569], clc$command, 1, 1, 0, 0, 0,
            0, 1, 'OSM$ADMOC_QUI'], [['STATUS                         ',
            clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$end_include (utility_name, status);

  PROCEND jmp$_quit;
?? TITLE := 'jmp$_administer_output_class', EJECT ??

{ PURPOSE:
{   Starts the ADMINISTER_OUTPUT_CLASS sub utility.
{
{ DESIGN:
{   Pass the command table to command_language.

  PROCEDURE [XDCL, #GATE] jmp$_administer_output_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adms_admoc) administer_output_class (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 9, 26, 11, 36, 57, 805], clc$command, 1, 1, 0, 0, 0,
            0, 1, 'OSM$ADMS_ADMOC'], [['STATUS                         ',
            clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    utility_attributes [1].command_table := command_table;
    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmv$current_profile_level := jmc$profile_output_class;

    clp$include_file (command_file, '', utility_name, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$end_utility (utility_name, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

  PROCEND jmp$_administer_output_class;
MODEND jmm$administer_output_class;
*DECK DECK=JMM$ADMINISTER_PROFILE EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Scheduling : administer_profile' ??
MODULE jmm$administer_profile;

{ PURPOSE:
{   This module provides the routines to read and write a scheduling
{   profile.
{
{ DESIGN:
{   The scheduling profile is kept as a segment access file.  The file
{   is read and written as a sequence.  The file starts with a header
{   followed by all the objects then all the values for each object.
{   To provide for reasonable error detection, each item written to the
{   profile is preceeded by a string identifying its nature.  This string
{   is verified when reading the profile to ensure that the item is what
{   is expected.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$job_management_id
*copyc jme$profile_errors
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc fsp$close_file
*copyc fsp$open_file
*copyc jmp$close_system_profile
*copyc jmp$delete_attributes
*copyc jmp$delete_profile_cycle
*copyc jmp$open_system_profile
*copyc jmt$profile_header
*copyc jmt$profile_data
*copyc osp$append_status_file
*copyc osp$set_status_condition

*copyc clv$standard_files
*copyc jmv$object_definition
*copyc jmv$object_heap
*copyc jmv$the_profile
?? TITLE := 'Declarations for This Module', EJECT ??

  CONST
    bad_item_id = 'BADV',
    keyword_item_id = 'KEYW',
    value_item_id = 'VALU';

  TYPE
    item_header = record
      name: string (4),
      size: 0 .. 0ffffffff(16),
    recend;

  VAR
    required_attributes: [STATIC] array [1 .. 3] of
          fst$file_cycle_attribute := [[fsc$file_contents_and_processor,
          'SCHEDULING_PROFILE', 'ADMINISTER_SCHEDULING'],
          [fsc$file_organization, amc$byte_addressable],
          [fsc$record_type, amc$undefined]];

  VAR
    attribute_kind_id: [STATIC] array [jmt$object_attribute_kinds] of string
          (4) := ['TYPE', 'LIST', 'ELST', 'RNGE', 'NUMB', 'BOOL', 'NAME',
          'FILE', 'OBJR', 'DISP', '---C', '---D', 'EMPT', 'NONE', 'ALL ',
          'UNLM', 'UNSP', 'DFLT', 'SDFT'],
    old_keyword_to_new_keyword: [STATIC] array [12 .. 18] of
          jmt$object_attribute_kinds := [jmc$empty, jmc$none, jmc$all,
          jmc$unlimited, jmc$unspecified, jmc$default, jmc$system_default];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$read_profile', EJECT ??

{ PURPOSE:
{   This interface reads the profile from the specified file.

  PROCEDURE [XDCL] jmp$read_profile
    (    base_file: fst$file_reference;
     VAR the_profile: jmt$profile_data;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      profile_file_identifier: amt$file_identifier,
      read_attachment: [STATIC] array [1 .. 2] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes,
            [fsc$read]], [fsc$specific_share_modes, []]],
            [fsc$open_position, amc$open_at_boi]];

    fsp$open_file (base_file, amc$segment, ^read_attachment, NIL, NIL,
          ^required_attributes, NIL, profile_file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    read_profile (profile_file_identifier, the_profile, status);
    IF NOT status.normal THEN
      osp$append_status_file (osc$status_parameter_delimiter, base_file,
            status);
    IFEND;

    fsp$close_file (profile_file_identifier, local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND jmp$read_profile;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$read_system_profile', EJECT ??

{ PURPOSE:
{   This interface reads the profile from the specified file.

  PROCEDURE [XDCL] jmp$read_system_profile
    (    profile_access_id: ost$binary_unique_name;
         cycle_number: jmt$system_profile_cycle_number;
     VAR the_profile: jmt$profile_data;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      profile_file_identifier: amt$file_identifier;

    jmp$open_system_profile (profile_access_id, cycle_number,
          {open_for_write = } FALSE, ^required_attributes,
          profile_file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    read_profile (profile_file_identifier, the_profile, status);

    jmp$close_system_profile (profile_access_id, {detach_file} FALSE,
          profile_file_identifier, local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND jmp$read_system_profile;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$write_profile', EJECT ??

{ PURPOSE:
{   This interface opens and writes the profile to the specified file.

  PROCEDURE [XDCL] jmp$write_profile
    (    base_file: fst$file_reference;
     VAR the_profile: jmt$profile_data;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      profile_file_identifier: amt$file_identifier,
      write_attachment: [STATIC] array [1 .. 3] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes,
            [fsc$read, fsc$append, fsc$modify, fsc$shorten]],
            [fsc$specific_share_modes, []]], [fsc$create_file, TRUE],
            [fsc$open_position, amc$open_at_boi]];

    status.normal := TRUE;
    IF base_file = clv$standard_files [clc$sf_null_file].path_handle_name THEN
      RETURN;
    IFEND;

    fsp$open_file (base_file, amc$segment, ^write_attachment, NIL,
          ^required_attributes, ^required_attributes, NIL,
          profile_file_identifier, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    write_profile (profile_file_identifier, the_profile, status);

    fsp$close_file (profile_file_identifier, local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND jmp$write_profile;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$write_system_profile', EJECT ??

{ PURPOSE:
{   This interface opens and writes the profile to the specified cycle of the
{   system profile.

  PROCEDURE [XDCL] jmp$write_system_profile
    (    profile_access_id: ost$binary_unique_name;
     VAR the_profile: jmt$profile_data;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      profile_file_identifier: amt$file_identifier;

    jmp$open_system_profile (profile_access_id, { cycle_number =} 1,
          { open_for_write = } TRUE, ^required_attributes,
          profile_file_identifier, status);
    IF NOT status.normal THEN
      IF status.condition <> pfe$duplicate_cycle THEN
        RETURN;
      IFEND;
      jmp$delete_profile_cycle (profile_access_id, { cycle_number =} 1,
            local_status);
      IF NOT local_status.normal THEN
        RETURN;
      IFEND;
      jmp$open_system_profile (profile_access_id, { cycle_number =} 1,
            { open_for_write = } TRUE, ^required_attributes,
            profile_file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    write_profile (profile_file_identifier, the_profile, status);

    jmp$close_system_profile (profile_access_id, { Detach_file =} TRUE,
          profile_file_identifier, local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND jmp$write_system_profile;
?? OLDTITLE ??
?? NEWTITLE := 'read_profile', EJECT ??

{ PURPOSE:
{   This interface reads the profile from the opened file.
{
{ DESIGN:
{   This routine reads the profile from the file in the same manner that
{   it was written.  The header is read first.  The all the object headers
{   are read.  Finally all the attributes for all the objects are read.
{
{ NOTES:
{   Consistancy checks are made for each item read that the item we expect
{   to read is in fact the next item.

  PROCEDURE read_profile
    (    profile_file_identifier: amt$file_identifier;
     VAR the_profile: jmt$profile_data;
     VAR status: ost$status);

    VAR
      profile_file: ^SEQ ( * ),
      profile_object_list: ^array [1 .. * ] of jmt$profile_object_reference;

?? NEWTITLE := 'read_attributes', EJECT ??

{ PURPOSE:
{   This routine reads attributes from the file.
{
{ DESIGN:
{   The routine reads the item header from the file and compares it with
{   what was expected.  As it reads the attributes from the file it also
{   compares them with the current attribute definition.  If the definition
{   is empty then the data is skipped.  The length of type attributes can
{   be different.  In any case the current definition length is used but
{   extra attributes in the file are skipped or extra attributes in the
{   current definition are set to empty so they will default properly.

    PROCEDURE read_attributes
      (    attribute_definition: jmt$profile_declaration;
       VAR attribute: jmt$object_attribute;
       VAR status: ost$status);

      VAR
        attribute_from_profile: ^jmt$object_attribute,
        file: ^fst$file_reference,
        i: integer,
        item: ^item_header,
        kind: jmt$object_attribute_kinds,
        name: ^ost$name,
        upper_bound: integer;

      status.normal := FALSE;

      IF attribute_definition.kind = jmc$empty THEN
        skip_attributes (status);
        RETURN;
      IFEND;

      NEXT item IN profile_file;
      IF item = NIL THEN
        RETURN;
      IFEND;

      NEXT attribute_from_profile IN profile_file;
      IF attribute_from_profile = NIL THEN
        RETURN;
      IFEND;

      IF item^.name = value_item_id THEN
        attribute := attribute_from_profile^;
        attribute.kind := attribute_definition.kind;

      ELSEIF item^.name = keyword_item_id THEN
        attribute.kind := old_keyword_to_new_keyword
              [$INTEGER (attribute_from_profile^.kind)];

      ELSE
        kind := jmc$type;
        WHILE (kind < jmc$system_default) AND
              (attribute_kind_id [kind] <> item^.name) DO
          kind := SUCC (kind);
        WHILEND;

        IF attribute_kind_id [kind] <> item^.name THEN
          RETURN;
        IFEND;

        CASE kind OF
        = jmc$type =
          IF kind <> attribute_definition.kind THEN
            RETURN;
          IFEND;

          upper_bound := UPPERBOUND (attribute_definition.declarations^);
          ALLOCATE attribute.attribute_list: [1 .. upper_bound] IN
                jmv$object_heap^;
          FOR i := 1 TO upper_bound DO
            attribute.attribute_list^ [i].kind := jmc$empty;
          FOREND;
          attribute.kind := kind;

          FOR i := 1 TO item^.size DO
            IF i > upper_bound THEN
              skip_attributes (status);
            ELSE
              read_attributes (attribute_definition.declarations^ [i]^,
                    attribute.attribute_list^ [i], status);
            IFEND;
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND;

        = jmc$list, jmc$range, jmc$editable_list =
          IF kind <> attribute_definition.kind THEN
            RETURN;
          IFEND;

          upper_bound := item^.size;
          ALLOCATE attribute.attribute_list: [1 .. upper_bound] IN
                jmv$object_heap^;
          FOR i := 1 TO upper_bound DO
            attribute.attribute_list^ [i].kind := jmc$empty;
          FOREND;
          attribute.kind := kind;

          FOR i := 1 TO upper_bound DO
            read_attributes (attribute_definition.declarations^ [1]^,
                  attribute.attribute_list^ [i], status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND;

        = jmc$name =
          IF attribute_definition.kind <> kind THEN
            RETURN;
          IFEND;

          NEXT name IN profile_file;
          IF name = NIL THEN
            RETURN;
          IFEND;

          ALLOCATE attribute.name IN jmv$object_heap^;
          attribute.kind := kind;
          attribute.name^ := name^;

        = jmc$file =
          IF kind <> attribute_definition.kind THEN
            RETURN;
          IFEND;

          NEXT file: [item^.size] IN profile_file;
          IF file = NIL THEN
            RETURN;
          IFEND;

          ALLOCATE attribute.file: [STRLENGTH (file^)] IN jmv$object_heap^;
          attribute.kind := kind;
          attribute.file^ := file^;

        = jmc$object =
          IF kind <> attribute_definition.kind THEN
            RETURN;
          IFEND;

          attribute.object_p := profile_object_list^
                [attribute_from_profile^.profile_object_index];
          attribute.object_p^.references := attribute.object_p^.references + 1;
          attribute.kind := kind;

        = jmc$number, jmc$boolean, jmc$dispatching_priority =
          attribute := attribute_from_profile^;
          attribute.kind := kind;

        = jmc$empty, jmc$none, jmc$all, jmc$unlimited, jmc$unspecified,
              jmc$default, jmc$system_default =
          attribute.kind := kind;
        CASEND;
      IFEND;
      status.normal := TRUE;
    PROCEND read_attributes;
?? TITLE := 'skip_attributes', EJECT ??

{ PURPOSE:
{   This routine skips attributes that no longer have meaning.
{
{ DESIGN:
{   If the definition of the profile has changed between now and the last
{   time the profile was written, then some attributes may no longer be used
{   This routine is used to skip this data when the file is read.

    PROCEDURE skip_attributes
      (VAR status: ost$status);

      VAR
        attribute_from_profile: ^jmt$object_attribute,
        file: ^fst$file_reference,
        i: integer,
        item: ^item_header,
        kind: jmt$object_attribute_kinds,
        name: ^ost$name;

      status.normal := FALSE;
      NEXT item IN profile_file;
      IF item = NIL THEN
        RETURN;
      IFEND;

      NEXT attribute_from_profile IN profile_file;
      IF attribute_from_profile = NIL THEN
        RETURN;
      IFEND;

      IF (item^.name = value_item_id) OR (item^.name = keyword_item_id) THEN

      ELSE
        kind := jmc$type;
        WHILE (kind < jmc$system_default) AND
              (attribute_kind_id [kind] <> item^.name) DO
          kind := SUCC (kind);
        WHILEND;

        IF attribute_kind_id [kind] <> item^.name THEN
          RETURN;
        IFEND;

        CASE kind OF
        = jmc$type, jmc$list, jmc$range, jmc$editable_list =
          FOR i := 1 TO item^.size DO
            skip_attributes (status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND;

        = jmc$name =
          NEXT name IN profile_file;
          IF name = NIL THEN
            RETURN;
          IFEND;

        = jmc$file =
          NEXT file: [item^.size] IN profile_file;
          IF file = NIL THEN
            RETURN;
          IFEND;

        ELSE
        CASEND;
      IFEND;
      status.normal := TRUE;
    PROCEND skip_attributes;
?? OLDTITLE, EJECT ??

    VAR
      local_status: ost$status,
      segment_pointer: amt$segment_pointer;

    VAR
      i: integer,
      objects_on_profile: integer,
      object_kind: jmt$profile_object_kinds,
      header: ^jmt$profile_header,
      item: ^item_header,
      previous_object: jmt$profile_object_reference,
      the_object: jmt$profile_object_reference;

    objects_on_profile := 0;

    amp$get_segment_pointer (profile_file_identifier, amc$sequence_pointer,
          segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET segment_pointer.sequence_pointer;
    profile_file := segment_pointer.sequence_pointer;

  /read_file/
    BEGIN

      NEXT header IN profile_file;
      IF header = NIL THEN
        EXIT /read_file/;
      IFEND;

      IF header^.version <> jmc$profile_version THEN
        EXIT /read_file/;
      IFEND;

      objects_on_profile := header^.object_count;

      PUSH profile_object_list: [1 .. objects_on_profile];
      FOR i := 1 TO objects_on_profile DO
        profile_object_list^ [i] := NIL;
      FOREND;

      FOR i := 1 TO objects_on_profile DO
        NEXT item IN profile_file;
        IF item = NIL THEN
          EXIT /read_file/;
        IFEND;

        IF item^.name <> 'OBJI' THEN
          EXIT /read_file/;
        IFEND;

        NEXT the_object IN profile_file;
        IF the_object = NIL THEN
          EXIT /read_file/;
        IFEND;
        ALLOCATE profile_object_list^ [i] IN jmv$object_heap^;
        profile_object_list^ [i]^ := the_object^;
        profile_object_list^ [i]^.attributes.kind := jmc$empty;
        profile_object_list^ [i]^.references := 0;
        profile_object_list^ [i]^.changed := FALSE;
      FOREND;

      FOR i := 1 TO objects_on_profile DO
        the_object := profile_object_list^ [i];
        read_attributes (jmv$object_definition [the_object^.kind].declaration,
              the_object^.attributes, status);
        IF NOT status.normal THEN
          EXIT /read_file/;
        IFEND;
      FOREND;

      FOR object_kind := LOWERVALUE (object_kind)
            TO UPPERVALUE (object_kind) DO
        previous_object := the_profile.objects [object_kind];
        WHILE previous_object <> NIL DO
          jmp$delete_attributes (previous_object^.attributes);
          the_object := previous_object;
          previous_object := previous_object^.next_object;
          FREE the_object IN jmv$object_heap^;
        WHILEND;
        the_profile.count [object_kind] := 0;
        the_profile.objects [object_kind] := NIL;
      FOREND;
      the_profile.definition_id := header^.definition_id;

      object_kind := UPPERVALUE (object_kind);
      FOR i := 1 TO objects_on_profile DO
        the_object := profile_object_list^ [i];
        the_object^.next_object := NIL;
        IF the_object^.kind = object_kind THEN
          previous_object^.next_object := the_object;
          the_profile.count [object_kind] :=
                the_profile.count [object_kind] + 1;
        ELSE
          object_kind := the_object^.kind;
          the_profile.objects [object_kind] := the_object;
          the_profile.count [object_kind] := 1;
        IFEND;
        previous_object := the_object;
      FOREND;

      RETURN;
    END /read_file/;

    osp$set_status_condition (jme$cannot_read_profile, status);

    FOR i := 1 TO objects_on_profile DO
      the_object := profile_object_list^ [i];
      IF the_object <> NIL THEN
        jmp$delete_attributes (the_object^.attributes);
        FREE the_object IN jmv$object_heap^;
      IFEND;
    FOREND;
  PROCEND read_profile;
?? TITLE := 'write_profile', EJECT ??

{ PURPOSE:
{   This interface writes the profile to the specified file.
{
{ DESIGN:
{   The header is written first.
{   All the objects are written second.
{   The attributes for each object are written in the order of the objects.

  PROCEDURE write_profile
    (    profile_file_identifier: amt$file_identifier;
     VAR the_profile: jmt$profile_data;
     VAR status: ost$status);

    VAR
      profile_file: ^SEQ ( * );

?? NEWTITLE := 'write_attributes', EJECT ??

{ PURPOSE:
{   This routine writes attributes onto the profile file.
{
{ DESIGN:
{   The routine puts a header on the file first which contains a description
{   of the attribute type in a string.  Then a copy of the attribute is put
{   on the file.  If the attribute is of type list, range, or type then the
{   routine is called recursively for each item in the list.  Names and
{   strings are stored immediatly following the attribute.  Object references
{   are kept as an index into the object headers written in the front of the
{   file.
{
{ NOTES:
{   The string stored in the header provides a safety check when reading the
{   file back in.

    PROCEDURE write_attributes
      (VAR attribute: jmt$object_attribute;
       VAR status: ost$status);

      VAR
        i: integer,
        file: ^fst$file_reference,
        name: ^ost$name,
        attribute_on_profile: ^jmt$object_attribute,
        item: ^item_header;

      status.normal := FALSE;
      NEXT item IN profile_file;
      IF item = NIL THEN
        RETURN;
      IFEND;
      item^.name := bad_item_id;

      NEXT attribute_on_profile IN profile_file;
      IF attribute_on_profile = NIL THEN
        RETURN;
      IFEND;

      attribute_on_profile^ := attribute;

      CASE attribute.kind OF
      = jmc$list, jmc$range, jmc$type, jmc$editable_list =
        item^.size := UPPERBOUND (attribute.attribute_list^);

        FOR i := 1 TO UPPERBOUND (attribute.attribute_list^) DO
          write_attributes (attribute.attribute_list^ [i], status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;

      = jmc$name =
        NEXT name IN profile_file;
        IF name = NIL THEN
          RETURN;
        IFEND;
        name^ := attribute.name^;

      = jmc$file =
        item^.size := STRLENGTH (attribute.file^);
        NEXT file: [STRLENGTH (attribute.file^)] IN profile_file;
        IF file = NIL THEN
          RETURN;
        IFEND;
        file^ := attribute.file^;

      = jmc$object =
        item^.size := attribute.object_p^.profile_index;
        attribute_on_profile^.profile_object_index :=
              attribute.object_p^.profile_index;

      ELSE
        item^.size := 0;
      CASEND;

      item^.name := attribute_kind_id [attribute.kind];

      status.normal := TRUE;
    PROCEND write_attributes;
?? OLDTITLE, EJECT ??

    VAR
      local_status: ost$status,
      item: ^item_header,
      segment_pointer: amt$segment_pointer;

    VAR
      the_object: jmt$profile_object_reference,
      object_on_profile: jmt$profile_object_reference,
      object_kind: jmt$profile_object_kinds,
      header: ^jmt$profile_header,
      max_index: integer,
      i: integer,
      j: integer;

    status.normal := TRUE;

    amp$get_segment_pointer (profile_file_identifier, amc$sequence_pointer,
          segment_pointer, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    RESET segment_pointer.sequence_pointer;
    profile_file := segment_pointer.sequence_pointer;

    NEXT header IN profile_file;
    header^.version := 'GARBAGE';

    j := 0;
    FOR object_kind := LOWERVALUE (object_kind) TO UPPERVALUE (object_kind) DO

      the_object := the_profile.objects [object_kind];
      max_index := 0;
      WHILE the_object <> NIL DO
        j := j + 1;
        the_object^.profile_index := j;
        NEXT item IN profile_file;
        item^.name := 'OBJI';
        item^.size := j;
        NEXT object_on_profile IN profile_file;
        object_on_profile^ := the_object^;
        IF the_object^.index > max_index THEN
          max_index := the_object^.index;
        IFEND;
        the_object := the_object^.next_object;
      WHILEND;

      IF object_kind = jmc$profile_job_class THEN
        header^.maximum_job_class_index := max_index;
      ELSEIF object_kind = jmc$profile_service_class THEN
        header^.maximum_service_class_index := max_index;
      ELSEIF object_kind = jmc$profile_application THEN
        header^.application_count := max_index;
      IFEND;

    FOREND;

    FOR object_kind := LOWERVALUE (object_kind) TO UPPERVALUE (object_kind) DO
      the_object := the_profile.objects [object_kind];
      WHILE the_object <> NIL DO
        write_attributes (the_object^.attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        the_object := the_object^.next_object;
      WHILEND;
    FOREND;

    header^.definition_id := the_profile.definition_id;
    header^.object_count := j;
    header^.version := jmc$profile_version;

    segment_pointer.sequence_pointer := profile_file;
    amp$set_segment_eoi (profile_file_identifier, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND write_profile;
MODEND jmm$administer_profile;
*DECK DECK=JMM$ADMINISTER_SCHEDULING EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Scheduling : administer_scheduling' ??
MODULE jmm$administer_scheduling;

{ PURPOSE:
{   This module contains the code for the ADMINISTER_SCHEDULING utility.
{   The subcommands of this utility are defined here with the exception
{   of the DISPLAY_PROFILE_SUMMARY and GENERATE_PROFILE commands.  The
{   sub utilities are also defined separately.  The ADMINISTER_SCHEDULING
{   utility is used to create and modify a description of a sites
{   scheduling called a scheduling profile.  This profile can then be
{   activated in a utility called MANAGE_ACTIVE_SCHEDULING.
{
{ DESIGN:
{   This module only contains the framework for the utility - basically just
{   the PDTs and Command Tables.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmk$keypoints
*copyc jmt$cpu_time_limit
*copyc jmt$job_priority
*copyc jmt$magnetic_tape_limit
*copyc jmt$sru_limit
*copyc jmt$working_set_size
?? POP ??
*copyc clp$begin_utility
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc jmp$add_object
*copyc jmp$build_default_profile
*copyc jmp$change_object
*copyc jmp$delete_object
*copyc jmp$get_attributes
*copyc jmp$get_object_list
*copyc jmp$read_profile
*copyc jmp$set_profile
*copyc jmp$write_profile

*copyc jmv$current_profile_level
*copyc jmv$new_profile
*copyc jmv$the_profile
*copyc jmv$utility_functions
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    default_profile_file_name = '$USER.SCHEDULING_PROFILE';

  VAR
    result_file: ^fst$file_reference := NIL,
    command_file: amt$local_file_name := clc$current_command_input,
    utility_name: string (31) := 'ADMINISTER_SCHEDULING          ',
    utility_attributes: array [1 .. 3] of clt$utility_attribute :=
          [[clc$utility_command_table, * ], [clc$utility_function_proc_table, *
          ], [clc$utility_prompt, [2, 'AS']]];

{ table command_table
{ command (use_profile usep) jmp$_use_profile
{ command (change_list_option, change_list_options, chalo) ..
{   jmp$_change_list_option cm=xref
{ command (create_default_profile credp) jmp$_create_default_profile
{ command (write_profile wrip) jmp$_write_profile
{ command (create_job_category crejc crejca) jmp$_create_job_category
{ command (change_job_category chajc chajca) jmp$_change_job_category
{ command (delete_job_category deljc deljca) jmp$_delete_job_category
{ command (display_job_category display_job_categories disjc disjca) ..
{   jmp$_display_job_category cm=xref
{ command (create_job_priority crejp) jmp$_create_job_priority a=hidden
{ command (change_job_priority chajp) jmp$_change_job_priority a=hidden
{ command (delete_job_priority deljp) jmp$_delete_job_priority a=hidden
{ command (display_job_priority display_job_priorities disjp) ..
{   jmp$_display_job_priority cm=xref a=hidden
{ command (display_profile_summary disps) jmp$_display_profile_summary ..
{   cm=xref
{ command (generate_profile_definition genpd) ..
{   jmp$_generate_profile_definitio cm=xref
{ command (administer_controls admc) jmp$_administer_controls cm=xref
{ command (administer_application adma) jmp$_administer_application cm=xref
{ command (administer_job_class admjc) jmp$_administer_job_class  cm=xref
{ command (administer_service_class admsc) jmp$_administer_service_class ..
{   cm=xref
{ command (administer_output_class admoc) jmp$_administer_output_class ..
{   cm=xref a=hidden
{ command (quit qui) jmp$_quit
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    command_table: [STATIC, READ] ^clt$command_table := ^command_table_entries,

    command_table_entries: [STATIC, READ] array [1 .. 47] of
          clt$command_table_entry := [
          {} ['ADMA                           ', clc$abbreviation_entry,
          clc$normal_usage_entry, 16, clc$automatically_log, clc$linked_call,
          ^jmp$_administer_application],
          {} ['ADMC                           ', clc$abbreviation_entry,
          clc$normal_usage_entry, 15, clc$automatically_log, clc$linked_call,
          ^jmp$_administer_controls],
          {} ['ADMINISTER_APPLICATION         ', clc$nominal_entry,
          clc$normal_usage_entry, 16, clc$automatically_log, clc$linked_call,
          ^jmp$_administer_application],
          {} ['ADMINISTER_CONTROLS            ', clc$nominal_entry,
          clc$normal_usage_entry, 15, clc$automatically_log, clc$linked_call,
          ^jmp$_administer_controls],
          {} ['ADMINISTER_JOB_CLASS           ', clc$nominal_entry,
          clc$normal_usage_entry, 17, clc$automatically_log, clc$linked_call,
          ^jmp$_administer_job_class],
          {} ['ADMINISTER_OUTPUT_CLASS        ', clc$nominal_entry,
          clc$hidden_entry, 19, clc$automatically_log, clc$linked_call,
          ^jmp$_administer_output_class],
          {} ['ADMINISTER_SERVICE_CLASS       ', clc$nominal_entry,
          clc$normal_usage_entry, 18, clc$automatically_log, clc$linked_call,
          ^jmp$_administer_service_class],
          {} ['ADMJC                          ', clc$abbreviation_entry,
          clc$normal_usage_entry, 17, clc$automatically_log, clc$linked_call,
          ^jmp$_administer_job_class],
          {} ['ADMOC                          ', clc$abbreviation_entry,
          clc$hidden_entry, 19, clc$automatically_log, clc$linked_call,
          ^jmp$_administer_output_class],
          {} ['ADMSC                          ', clc$abbreviation_entry,
          clc$normal_usage_entry, 18, clc$automatically_log, clc$linked_call,
          ^jmp$_administer_service_class],
          {} ['CHAJC                          ', clc$alias_entry,
          clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
          ^jmp$_change_job_category],
          {} ['CHAJCA                         ', clc$abbreviation_entry,
          clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
          ^jmp$_change_job_category],
          {} ['CHAJP                          ', clc$abbreviation_entry,
          clc$hidden_entry, 10, clc$automatically_log, clc$linked_call,
          ^jmp$_change_job_priority],
          {} ['CHALO                          ', clc$abbreviation_entry,
          clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_change_list_option],
          {} ['CHANGE_JOB_CATEGORY            ', clc$nominal_entry,
          clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
          ^jmp$_change_job_category],
          {} ['CHANGE_JOB_PRIORITY            ', clc$nominal_entry,
          clc$hidden_entry, 10, clc$automatically_log, clc$linked_call,
          ^jmp$_change_job_priority],
          {} ['CHANGE_LIST_OPTION             ', clc$nominal_entry,
          clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_change_list_option],
          {} ['CHANGE_LIST_OPTIONS            ', clc$alias_entry,
          clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_change_list_option],
          {} ['CREATE_DEFAULT_PROFILE         ', clc$nominal_entry,
          clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_create_default_profile],
          {} ['CREATE_JOB_CATEGORY            ', clc$nominal_entry,
          clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
          ^jmp$_create_job_category],
          {} ['CREATE_JOB_PRIORITY            ', clc$nominal_entry,
          clc$hidden_entry, 9, clc$automatically_log, clc$linked_call,
          ^jmp$_create_job_priority],
          {} ['CREDP                          ', clc$abbreviation_entry,
          clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_create_default_profile],
          {} ['CREJC                          ', clc$alias_entry,
          clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
          ^jmp$_create_job_category],
          {} ['CREJCA                         ', clc$abbreviation_entry,
          clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
          ^jmp$_create_job_category],
          {} ['CREJP                          ', clc$abbreviation_entry,
          clc$hidden_entry, 9, clc$automatically_log, clc$linked_call,
          ^jmp$_create_job_priority],
          {} ['DELETE_JOB_CATEGORY            ', clc$nominal_entry,
          clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_job_category],
          {} ['DELETE_JOB_PRIORITY            ', clc$nominal_entry,
          clc$hidden_entry, 11, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_job_priority],
          {} ['DELJC                          ', clc$alias_entry,
          clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_job_category],
          {} ['DELJCA                         ', clc$abbreviation_entry,
          clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_job_category],
          {} ['DELJP                          ', clc$abbreviation_entry,
          clc$hidden_entry, 11, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_job_priority],
          {} ['DISJC                          ', clc$alias_entry,
          clc$normal_usage_entry, 8, clc$automatically_log, clc$linked_call,
          ^jmp$_display_job_category],
          {} ['DISJCA                         ', clc$abbreviation_entry,
          clc$normal_usage_entry, 8, clc$automatically_log, clc$linked_call,
          ^jmp$_display_job_category],
          {} ['DISJP                          ', clc$abbreviation_entry,
          clc$hidden_entry, 12, clc$automatically_log, clc$linked_call,
          ^jmp$_display_job_priority],
          {} ['DISPLAY_JOB_CATEGORIES         ', clc$alias_entry,
          clc$normal_usage_entry, 8, clc$automatically_log, clc$linked_call,
          ^jmp$_display_job_category],
          {} ['DISPLAY_JOB_CATEGORY           ', clc$nominal_entry,
          clc$normal_usage_entry, 8, clc$automatically_log, clc$linked_call,
          ^jmp$_display_job_category],
          {} ['DISPLAY_JOB_PRIORITIES         ', clc$alias_entry,
          clc$hidden_entry, 12, clc$automatically_log, clc$linked_call,
          ^jmp$_display_job_priority],
          {} ['DISPLAY_JOB_PRIORITY           ', clc$nominal_entry,
          clc$hidden_entry, 12, clc$automatically_log, clc$linked_call,
          ^jmp$_display_job_priority],
          {} ['DISPLAY_PROFILE_SUMMARY        ', clc$nominal_entry,
          clc$normal_usage_entry, 13, clc$automatically_log, clc$linked_call,
          ^jmp$_display_profile_summary],
          {} ['DISPS                          ', clc$abbreviation_entry,
          clc$normal_usage_entry, 13, clc$automatically_log, clc$linked_call,
          ^jmp$_display_profile_summary],
          {} ['GENERATE_PROFILE_DEFINITION    ', clc$nominal_entry,
          clc$normal_usage_entry, 14, clc$automatically_log, clc$linked_call,
          ^jmp$_generate_profile_definitio],
          {} ['GENPD                          ', clc$abbreviation_entry,
          clc$normal_usage_entry, 14, clc$automatically_log, clc$linked_call,
          ^jmp$_generate_profile_definitio],
          {} ['QUI                            ', clc$abbreviation_entry,
          clc$normal_usage_entry, 20, clc$automatically_log, clc$linked_call,
          ^jmp$_quit],
          {} ['QUIT                           ', clc$nominal_entry,
          clc$normal_usage_entry, 20, clc$automatically_log, clc$linked_call,
          ^jmp$_quit],
          {} ['USEP                           ', clc$abbreviation_entry,
          clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
          ^jmp$_use_profile],
          {} ['USE_PROFILE                    ', clc$nominal_entry,
          clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
          ^jmp$_use_profile],
          {} ['WRIP                           ', clc$abbreviation_entry,
          clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
          ^jmp$_write_profile],
          {} ['WRITE_PROFILE                  ', clc$nominal_entry,
          clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
          ^jmp$_write_profile]];

  PROCEDURE [XREF] jmp$_administer_application
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] jmp$_administer_controls
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] jmp$_administer_job_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] jmp$_administer_output_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] jmp$_administer_service_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] jmp$_change_list_option
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] jmp$_display_job_category
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] jmp$_display_job_priority
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] jmp$_display_profile_summary
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] jmp$_generate_profile_definitio
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??
?? OLDTITLE ??
?? NEWTITLE := 'job_category commands', EJECT ??
?? NEWTITLE := 'get_category_attributes', EJECT ??

{ PURPOSE:
{   Common routine to get extract the name and attributes for a job category
{   from the command.  A common routine is used since the form of the command
{   between the create and change commands are identical.

  PROCEDURE get_category_attributes
    (    parameter_list: clt$parameter_list;
     VAR category_name: ^clt$data_value;
     VAR attributes: jmt$object_attribute;
     VAR status: ost$status);

{ PROCEDURE (osm$admjc_crejc) get_category_attributes (
{   category_name, cn: name = $required
{   cpu_time_limit, ctl: (by_name) range of any of
{       key unlimited keyend
{       integer jmc$lowest_cpu_time_limit..jmc$highest_cpu_time_limit
{     anyend = $optional
{   job_mode, jm: (by_name) list 1..1 of key
{       interactive, batch
{     keyend = $optional
{   job_qualifier, job_qualifiers, jq: (by_name) list of name = $optional
{   login_account, login_accounts, la: (by_name) list of name = $optional
{   login_family, login_families, lf: (by_name) list of name = $optional
{   login_project, login_projects, lp: (by_name) list of name = $optional
{   login_user, login_users, lu: (by_name) list of name = $optional
{   magnetic_tape_limit, mtl: (by_name) range of any of
{       key unlimited, unspecified keyend
{       integer jmc$lowest_magnetic_tape_limit..jmc$highest_magnetic_tape_limit
{     anyend = $optional
{   maximum_working_set, maxws: (by_name) range of any of
{       key unlimited keyend
{       integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{     anyend = $optional
{   originating_application_name, originating_application_names, oan: ..
{       (by_name) list of name = $optional
{   sru_limit, sl: (by_name) range of any of
{       key unlimited keyend
{       integer jmc$lowest_sru_limit..jmc$highest_sru_limit
{     anyend = $optional
{   user_job_name, user_job_names, ujn: (by_name) list of name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 34] of clt$pdt_parameter_name,
        parameters: array [1 .. 14] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$range_type_qualifier,
          element_type_spec: 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$integer_type_qualifier,
            recend,
          recend,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 2] of clt$keyword_specification,
          recend,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type5: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type7: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type9: record
          header: clt$type_specification_header,
          qualifier: clt$range_type_qualifier,
          element_type_spec: 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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
        recend,
        type10: record
          header: clt$type_specification_header,
          qualifier: clt$range_type_qualifier,
          element_type_spec: 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$integer_type_qualifier,
            recend,
          recend,
        recend,
        type11: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type12: record
          header: clt$type_specification_header,
          qualifier: clt$range_type_qualifier,
          element_type_spec: 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$integer_type_qualifier,
            recend,
          recend,
        recend,
        type13: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type14: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 47, 46, 358], clc$command, 34, 14, 1, 0,
            0, 0, 14, 'OSM$ADMJC_CREJC'], [['CATEGORY_NAME                  ',
            clc$nominal_entry, 1], ['CN                             ',
            clc$abbreviation_entry, 1], ['CPU_TIME_LIMIT                 ',
            clc$nominal_entry, 2], ['CTL                            ',
            clc$abbreviation_entry, 2], ['JM                             ',
            clc$abbreviation_entry, 3], ['JOB_MODE                       ',
            clc$nominal_entry, 3], ['JOB_QUALIFIER                  ',
            clc$nominal_entry, 4], ['JOB_QUALIFIERS                 ',
            clc$alias_entry, 4], ['JQ                             ',
            clc$abbreviation_entry, 4], ['LA                             ',
            clc$abbreviation_entry, 5], ['LF                             ',
            clc$abbreviation_entry, 6], ['LOGIN_ACCOUNT                  ',
            clc$nominal_entry, 5], ['LOGIN_ACCOUNTS                 ',
            clc$alias_entry, 5], ['LOGIN_FAMILIES                 ',
            clc$alias_entry, 6], ['LOGIN_FAMILY                   ',
            clc$nominal_entry, 6], ['LOGIN_PROJECT                  ',
            clc$nominal_entry, 7], ['LOGIN_PROJECTS                 ',
            clc$alias_entry, 7], ['LOGIN_USER                     ',
            clc$nominal_entry, 8], ['LOGIN_USERS                    ',
            clc$alias_entry, 8], ['LP                             ',
            clc$abbreviation_entry, 7], ['LU                             ',
            clc$abbreviation_entry, 8], ['MAGNETIC_TAPE_LIMIT            ',
            clc$nominal_entry, 9], ['MAXIMUM_WORKING_SET            ',
            clc$nominal_entry, 10], ['MAXWS                          ',
            clc$abbreviation_entry, 10], ['MTL                            ',
            clc$abbreviation_entry, 9], ['OAN                            ',
            clc$abbreviation_entry, 11], ['ORIGINATING_APPLICATION_NAME   ',
            clc$nominal_entry, 11], ['ORIGINATING_APPLICATION_NAMES  ',
            clc$alias_entry, 11], ['SL                             ',
            clc$abbreviation_entry, 12], ['SRU_LIMIT                      ',
            clc$nominal_entry, 12], ['STATUS                         ',
            clc$nominal_entry, 14], ['UJN                            ',
            clc$abbreviation_entry, 13], ['USER_JOB_NAME                  ',
            clc$nominal_entry, 13], ['USER_JOB_NAMES                 ',
            clc$alias_entry, 13]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 5,
            clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 91, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [6, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 97, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [7, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 21, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [12, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 21, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [15, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 21, clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [16, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 21, clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [18, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 21, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [22, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 128, clc$optional_parameter, 0,
            0],

{ PARAMETER 10

      [23, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 91, clc$optional_parameter, 0, 0],

{ PARAMETER 11

      [27, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 21, clc$optional_parameter, 0, 0],

{ PARAMETER 12

      [30, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 91, clc$optional_parameter, 0, 0],

{ PARAMETER 13

      [33, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 21, clc$optional_parameter, 0, 0],

{ PARAMETER 14

      [31, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$range_type], [84], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      '
            , clc$nominal_entry, clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_cpu_time_limit,
            jmc$highest_cpu_time_limit, 10]]]],

{ PARAMETER 3

      [[1, 0, clc$list_type], [81, 1, 1, FALSE],
            [[1, 0, clc$keyword_type], [2], [['BATCH                          '
            , clc$nominal_entry, clc$normal_usage_entry, 2],
            ['INTERACTIVE                    ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]]],

{ PARAMETER 4

      [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 5

      [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 6

      [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 7

      [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 8

      [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 9

      [[1, 0, clc$range_type], [121], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['UNLIMITED                      '
            , clc$nominal_entry, clc$normal_usage_entry, 1],
            ['UNSPECIFIED                    ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_magnetic_tape_limit,
            jmc$highest_magnetic_tape_limit, 10]]]],

{ PARAMETER 10

      [[1, 0, clc$range_type], [84], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      '
            , clc$nominal_entry, clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
            jmc$highest_working_set_size, 10]]]],

{ PARAMETER 11

      [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 12

      [[1, 0, clc$range_type], [84], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      '
            , clc$nominal_entry, clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_sru_limit,
            jmc$highest_sru_limit, 10]]]],

{ PARAMETER 13

      [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 14

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$category_name = 1,
      p$cpu_time_limit = 2,
      p$job_mode = 3,
      p$job_qualifier = 4,
      p$login_account = 5,
      p$login_family = 6,
      p$login_project = 7,
      p$login_user = 8,
      p$magnetic_tape_limit = 9,
      p$maximum_working_set = 10,
      p$originating_application_name = 11,
      p$sru_limit = 12,
      p$user_job_name = 13,
      p$status = 14;

    VAR
      pvt: array [1 .. 14] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF status.normal THEN
      jmp$get_attributes (jmc$profile_category, #SEQ (pdt), ^pvt, attributes,
            status);
      category_name := pvt [p$category_name].value;
    IFEND;

  PROCEND get_category_attributes;

?? TITLE := 'jmp$_change_job_category', EJECT ??

{ PURPOSE:
{   Process the CHANGE_JOB_CATEGORY command.
{
{ DESIGN:
{   Determines the job categories to update, fetches the attribute values
{   and updates the job categories by replacing their existing attribute
{   values with these new ones.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS.

  PROCEDURE jmp$_change_job_category
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      the_category: ^clt$data_value,
      the_attributes: jmt$object_attribute;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_category;

    get_category_attributes (parameter_list, the_category, the_attributes,
          status);
    IF status.normal THEN
      jmp$change_object (jmc$profile_category, the_category^, the_attributes,
            jmc$replace, status);
    IFEND;

  PROCEND jmp$_change_job_category;
?? TITLE := 'jmp$_create_job_category', EJECT ??

{ PURPOSE:
{   Process the CREATE_JOB_CATEGORY command.
{
{ DESIGN:
{   Fetches the parameter values from the command and adds the specified
{   job category to the profile.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS.
{   Unlike the other create commands, this command can create a job category
{   with the same name as one that already exists.

  PROCEDURE jmp$_create_job_category
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      new_category: jmt$profile_object_reference,
      the_category: ^clt$data_value,
      the_attributes: jmt$object_attribute;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_category;

    get_category_attributes (parameter_list, the_category, the_attributes,
          status);
    IF status.normal THEN
      jmp$add_object (jmc$profile_category, the_category^.name_value,
            the_attributes, new_category, status);
    IFEND;

  PROCEND jmp$_create_job_category;
?? TITLE := 'jmp$_delete_job_category', EJECT ??

{ PURPOSE:
{   Processes the DELETE_JOB_CATEGORY command.
{
{ DESIGN:
{   Determine the job categories to delete and delete them.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS

  PROCEDURE jmp$_delete_job_category
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adms_deljc) delete_job_category (
{   category_name, cn: any of
{       key all keyend
{       list of name
{     anyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 5, 16, 39, 47, 987], clc$command, 3, 2, 1, 0, 0,
            0, 2, 'OSM$ADMS_DELJC'], [['CATEGORY_NAME                  ',
            clc$nominal_entry, 1], ['CN                             ',
            clc$abbreviation_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 2]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$category_name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$delete_object (jmc$profile_category, pvt [p$category_name].value^,
          status);

  PROCEND jmp$_delete_job_category;
?? OLDTITLE ??
?? TITLE := 'job_priority commands', EJECT ??
?? NEWTITLE := 'get_priority_attributes', EJECT ??

{ PURPOSE:
{   Common routine to get extract the name and attributes for a job priority
{   from the command.  A common routine is used since the form of the command
{   between the create and change commands are identical.

  PROCEDURE get_priority_attributes
    (    parameter_list: clt$parameter_list;
     VAR priority_name: ^clt$data_value;
     VAR attributes: jmt$object_attribute;
     VAR status: ost$status);

{ PROCEDURE (osm$adms_crejp) get_priority_attributes (
{   priority_name, pn: name = $required
{   dispatching_bias, db: (by_name) integer -9..9 = 0
{   initiation_bias, ib: (by_name) integer ..
{       -jmc$highest_job_priority..jmc$highest_job_priority = 0
{   output_bias, ob: (by_name) integer ..
{       -jmc$highest_job_priority..jmc$highest_job_priority = 0
{   scheduling_bias, sb: (by_name) integer ..
{       -jmc$highest_job_priority..jmc$highest_job_priority = 0
{   timeslice_bias, tb: (by_name) integer -10000000..10000000 = 0
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 13] of clt$pdt_parameter_name,
        parameters: array [1 .. 7] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (1),
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (1),
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (1),
        recend,
        type5: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (1),
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (1),
        recend,
        type7: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 22, 13, 518], clc$command, 13, 7, 1, 0, 0,
            0, 7, 'OSM$ADMS_CREJP'], [['DB                             ',
            clc$abbreviation_entry, 2], ['DISPATCHING_BIAS               ',
            clc$nominal_entry, 2], ['IB                             ',
            clc$abbreviation_entry, 3], ['INITIATION_BIAS                ',
            clc$nominal_entry, 3], ['OB                             ',
            clc$abbreviation_entry, 4], ['OUTPUT_BIAS                    ',
            clc$nominal_entry, 4], ['PN                             ',
            clc$abbreviation_entry, 1], ['PRIORITY_NAME                  ',
            clc$nominal_entry, 1], ['SB                             ',
            clc$abbreviation_entry, 5], ['SCHEDULING_BIAS                ',
            clc$nominal_entry, 5], ['STATUS                         ',
            clc$nominal_entry, 7], ['TB                             ',
            clc$abbreviation_entry, 6], ['TIMESLICE_BIAS                 ',
            clc$nominal_entry, 6]], [

{ PARAMETER 1

      [8, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 5,
            clc$required_parameter, 0, 0],

{ PARAMETER 2

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20,
            clc$optional_default_parameter, 0, 1],

{ PARAMETER 3

      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20,
            clc$optional_default_parameter, 0, 1],

{ PARAMETER 4

      [6, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20,
            clc$optional_default_parameter, 0, 1],

{ PARAMETER 5

      [10, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20,
            clc$optional_default_parameter, 0, 1],

{ PARAMETER 6

      [13, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20,
            clc$optional_default_parameter, 0, 1],

{ PARAMETER 7

      [11, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$integer_type], [-9, 9, 10], '0'],

{ PARAMETER 3

      [[1, 0, clc$integer_type], [-jmc$highest_job_priority,
            jmc$highest_job_priority, 10], '0'],

{ PARAMETER 4

      [[1, 0, clc$integer_type], [-jmc$highest_job_priority,
            jmc$highest_job_priority, 10], '0'],

{ PARAMETER 5

      [[1, 0, clc$integer_type], [-jmc$highest_job_priority,
            jmc$highest_job_priority, 10], '0'],

{ PARAMETER 6

      [[1, 0, clc$integer_type], [-10000000, 10000000, 10], '0'],

{ PARAMETER 7

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$priority_name = 1,
      p$dispatching_bias = 2,
      p$initiation_bias = 3,
      p$output_bias = 4,
      p$scheduling_bias = 5,
      p$timeslice_bias = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF status.normal THEN
      jmp$get_attributes (jmc$profile_priority, #SEQ (pdt), ^pvt, attributes,
            status);
      priority_name := pvt [p$priority_name].value;
    IFEND;

  PROCEND get_priority_attributes;
?? NEWTITLE := 'jmp$_change_job_priority', EJECT ??

{ PURPOSE:
{   Process the CHANGE_JOB_PRIORITY command.
{
{ DESIGN:
{   Determines the job priorities to update, fetches the attribute values
{   and updates the job priorities by replacing their existing attribute
{   values with these new ones.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS.

  PROCEDURE jmp$_change_job_priority
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      the_attributes: jmt$object_attribute,
      the_priority: ^clt$data_value;

    status.normal := TRUE;

    get_priority_attributes (parameter_list, the_priority, the_attributes,
          status);
    IF status.normal THEN
      jmp$change_object (jmc$profile_priority, the_priority^, the_attributes,
            jmc$replace, status);
    IFEND;

  PROCEND jmp$_change_job_priority;
?? TITLE := 'jmp$_create_job_priority', EJECT ??

{ PURPOSE:
{   Process the CREATE_JOB_PRIORITY command.
{
{ DESIGN:
{   Fetches the parameter values from the command and adds the specified
{   job priority to the profile.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS.

  PROCEDURE jmp$_create_job_priority
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      new_priority: jmt$profile_object_reference,
      the_attributes: jmt$object_attribute,
      the_priority: ^clt$data_value;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_priority;

    get_priority_attributes (parameter_list, the_priority, the_attributes,
          status);
    IF status.normal THEN
      jmp$add_object (jmc$profile_priority, the_priority^.name_value,
            the_attributes, new_priority, status);
    IFEND;

  PROCEND jmp$_create_job_priority;
?? TITLE := 'jmp$_delete_job_priority', EJECT ??

{ PURPOSE:
{   Processes the DELETE_JOB_PRIORITY command.
{
{ DESIGN:
{   Determine the job priorities to delete and delete them.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS

  PROCEDURE jmp$_delete_job_priority
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adms_deljp) delete_job_priority (
{   priority_name, pn: name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 49, 58, 199], clc$command, 3, 2, 1, 0, 0,
            0, 2, 'OSM$ADMS_DELJP'], [['PN                             ',
            clc$abbreviation_entry, 1], ['PRIORITY_NAME                  ',
            clc$nominal_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 2]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 5,
            clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$priority_name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_priority;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$delete_object (jmc$profile_priority, pvt [p$priority_name].value^,
          status);

  PROCEND jmp$_delete_job_priority;
?? OLDTITLE ??
?? TITLE := 'jmp$_create_default_profile', EJECT ??

{ PURPOSE:
{   Process the CREATE_DEFAULT_PROFILE command which creates the standard
{   scheduling profile.
{
{ DESIGN:
{   Set the result file based on the RESULT parameter and re-create the
{   default profile.
{
{ NOTES:
{   See JMM$ADMINISTER_DEFINITIONS.

  PROCEDURE jmp$_create_default_profile
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adms_credp) create_default_profile (
{   result, r: file = $user.scheduling_profile.$next
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          default_value: string (30),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 50, 20, 771], clc$command, 3, 2, 0, 0, 0,
            0, 2, 'OSM$ADMS_CREDP'], [['R                              ',
            clc$abbreviation_entry, 1], ['RESULT                         ',
            clc$nominal_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 2]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_default_parameter, 0, 30],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type], '$user.scheduling_profile.$next'],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$result = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$build_default_profile (status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    set_result_file (pvt [p$result].value^.file_value^);

  PROCEND jmp$_create_default_profile;
?? TITLE := 'jmp$_quit ', EJECT ??

{ PURPOSE:
{   Exits the command utility.
{
{ DESIGN:
{   Terminates the commmand utility.

  PROCEDURE jmp$_quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adms_qui) quit (
{   save_change, sc: boolean = true
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          default_value: string (4),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 50, 43, 416], clc$command, 3, 2, 0, 0, 0,
            0, 2, 'OSM$ADMS_QUI'], [['SAVE_CHANGE                    ',
            clc$nominal_entry, 1], ['SC                             ',
            clc$abbreviation_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 2]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_default_parameter, 0, 4],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$boolean_type], 'true'],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$save_change = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    IF pvt [p$save_change].value^.boolean_value.value THEN
      jmp$write_profile (result_file^, jmv$the_profile, status);
      IF NOT status.normal THEN
        RETURN
      IFEND;
    IFEND;

    clp$end_include (utility_name, status);

  PROCEND jmp$_quit;
?? TITLE := 'set_result_file', EJECT ??

{ PURPOSE:
{   Saves the result file name for later use by the utility.
{
{ DESIGN:
{   Allocate space for the file name and save it.

  PROCEDURE set_result_file
    (    file_name: fst$file_reference);

    IF result_file <> NIL THEN
      FREE result_file;
    IFEND;
    ALLOCATE result_file: [STRLENGTH (file_name)];
    result_file^ := file_name;

  PROCEND set_result_file;

?? TITLE := 'jmp$_use_profile', EJECT ??

{ PURPOSE:
{   Process the USE_PROFILE command which defines the profile file to
{   be used within the utility.
{
{ DESIGN:
{   Get the file name.  Attempt to read the file.  If successful then
{   make it the working profile and define the result file name to
{   the input file name + '.$next' if otherwise not specified.
{
{ NOTES:
{   See JMM$ADMINISTER_PROFILE.

  PROCEDURE jmp$_use_profile
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adms_usep) use_profile (
{   base, b: file = $user.scheduling_profile
{   result, r: file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          default_value: string (24),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 51, 2, 904], clc$command, 5, 3, 0, 0, 0,
            0, 3, 'OSM$ADMS_USEP'], [['B                              ',
            clc$abbreviation_entry, 1], ['BASE                           ',
            clc$nominal_entry, 1], ['R                              ',
            clc$abbreviation_entry, 2], ['RESULT                         ',
            clc$nominal_entry, 2], ['STATUS                         ',
            clc$nominal_entry, 3]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_default_parameter, 0, 24],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type], '$user.scheduling_profile'],

{ PARAMETER 2

      [[1, 0, clc$file_type]],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$base = 1,
      p$result = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      base_file: ^fst$file_reference,
      size: integer;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    base_file := pvt [p$base].value^.file_value;

    IF pvt [p$result].specified THEN
      set_result_file (pvt [p$result].value^.file_value^);
      result_file^ := pvt [p$result].value^.file_value^;
    ELSE
      FREE result_file;
      size := STRLENGTH (base_file^);
      ALLOCATE result_file: [size + 6];
      result_file^ := base_file^;
      result_file^ (size + 1, 6) := '.$next';
    IFEND;

    IF base_file^ <> '$NULL' THEN
      jmp$read_profile (base_file^, jmv$new_profile, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      jmp$set_profile (jmv$new_profile);
    IFEND;

  PROCEND jmp$_use_profile;
?? TITLE := 'jmp$_write_profile', EJECT ??

{ PURPOSE:
{   Process the WRITE_PROFILE command.
{
{ DESIGN:
{   Write the working profile data to the specified file.
{
{ NOTES:
{   See JMM$ADMINISTER_PROFILE.

  PROCEDURE jmp$_write_profile
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adms_wrip) write_profile (
{   result, r: file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 51, 28, 909], clc$command, 3, 2, 0, 0, 0,
            0, 2, 'OSM$ADMS_WRIP'], [['R                              ',
            clc$abbreviation_entry, 1], ['RESULT                         ',
            clc$nominal_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 2]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$result = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    IF pvt [p$result].specified THEN
      jmp$write_profile (pvt [p$result].value^.file_value^, jmv$the_profile,
            status);
    ELSE
      jmp$write_profile (result_file^, jmv$the_profile, status);
    IFEND;

  PROCEND jmp$_write_profile;
?? TITLE := '[XDCL] jmp$_administer_scheduling', EJECT ??

{ PURPOSE:
{   Starts the ADMINISTER_SCHEDULING command utility.
{
{ DESIGN:
{   Pass the command table to command_language.

  PROCEDURE [XDCL] jmp$_administer_scheduling
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adms) administer_scheduling (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 9, 23, 11, 45, 58, 617], clc$command, 1, 1, 0, 0, 0,
            0, 1, 'OSM$ADMS'], [['STATUS                         ',
            clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    CONST
      result_file_name = default_profile_file_name CAT '.$next';

    VAR
      profile_status: ost$status;

    #keypoint (osk$entry, 0, jmk$administer_scheduling);

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, 0, jmk$administer_scheduling);
      RETURN
    IFEND;

    jmp$build_default_profile (status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, 0, jmk$administer_scheduling);
      RETURN
    IFEND;

    set_result_file (default_profile_file_name CAT '.$next');

    jmp$read_profile (default_profile_file_name, jmv$new_profile,
          profile_status);
    IF profile_status.normal THEN
      jmp$set_profile (jmv$new_profile);
    IFEND;

    utility_attributes [1].command_table := command_table;
    utility_attributes [2].function_processor_table := jmv$utility_functions;
    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, 0, jmk$administer_scheduling);
      RETURN
    IFEND;

    clp$include_file (command_file, '', utility_name, status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, 0, jmk$administer_scheduling);
      RETURN
    IFEND;

    clp$end_utility (utility_name, status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, 0, jmk$administer_scheduling);
      RETURN
    IFEND;

    #keypoint (osk$exit, 0, jmk$administer_scheduling);

  PROCEND jmp$_administer_scheduling;
MODEND jmm$administer_scheduling;
*DECK DECK=JMM$ADMINISTER_SCHEDULING_PD EXPAND=TRUE
 create_program_description (administer_scheduling adms) ..
    l=('$system.osf$builtin_library') sp=jmp$_administer_scheduling ..
    dm=off
*DECK DECK=JMM$ADMINISTER_SERVICE_CLASS EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Scheduling : administer_service_class' ??
MODULE jmm$administer_service_class;

{ PURPOSE:
{   This module defines the commands that make up the subutility of
{   ADMINISTER_SCHEDULING called ADMINISTER_SERVICE_CLASS.  This utility
{   manages the service classes on the scheduling profile.  The procedures
{   in this module allow the administrator to create, change, delete
{   and display service classes on/from the scheduling profile.
{
{ DESIGN:
{   This module mainly provides the framework for the utility.  It
{   contains the PDTs and code for the subutility and its subcommands.
{
{ NOTES:
{   Most of the work of creating, deleting, changing, and displaying is
{   done in routines which are generalized to handle all types of objects.
{   These routines can be found in the modules JMM$ADMINISTER_DISPLAY and
{   JMM$ADMINISTER_OBJECTS.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$maximum_job_count
*copyc jmt$default_and_range_parameter
*copyc jmt$job_priority
*copyc jmt$service_class_attributes
?? POP ??
*copyc clp$begin_utility
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$include_file
*copyc clp$evaluate_parameters
*copyc jmp$add_object
*copyc jmp$change_object
*copyc jmp$delete_object
*copyc jmp$get_attributes
*copyc jmp$get_object_list
*copyc jmp$set_default_attributes

*copyc jmv$current_profile_level
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    milliseconds_per_second = 1000,
    microseconds_per_millisecond = 1000,
    microseconds_per_second = milliseconds_per_second *
          microseconds_per_millisecond;

  CONST
    lowest_service_limit = jmc$lowest_service_limit DIV
          microseconds_per_millisecond,
    highest_service_limit = jmc$highest_service_limit DIV
          microseconds_per_millisecond,
    lowest_prio_age_interval = jmc$lowest_prio_age_interval DIV
          microseconds_per_second,
    highest_prio_age_interval = jmc$highest_prio_age_interval DIV
          microseconds_per_second;

  VAR
    command_file: amt$local_file_name := clc$current_command_input,
    utility_name: string (31) := 'ADMINISTER_SERVICE_CLASS       ',
    utility_attributes: array [1 .. 2] of clt$utility_attribute :=
          [[clc$utility_command_table, * ], [clc$utility_prompt, [3, 'ASC']]];

{ table command_table
{ command (create_class, crec), jmp$_create_class
{ command (change_attribute, change_attributes, chaa), jmp$_change_attribute
{ command (display_attribute, display_attributes, disa), ..
{   jmp$_display_service_class cm=xref
{ command (delete_class, delc), jmp$_delete_class
{ command (quit, qui), jmp$_quit
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    command_table: [STATIC, READ] ^clt$command_table := ^command_table_entries,

    command_table_entries: [STATIC, READ] array [1 .. 12] of
          clt$command_table_entry := [
          {} ['CHAA                           ', clc$abbreviation_entry,
          clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_change_attribute],
          {} ['CHANGE_ATTRIBUTE               ', clc$nominal_entry,
          clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_change_attribute],
          {} ['CHANGE_ATTRIBUTES              ', clc$alias_entry,
          clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_change_attribute],
          {} ['CREATE_CLASS                   ', clc$nominal_entry,
          clc$advertised_entry, 1, clc$automatically_log, clc$linked_call,
          ^jmp$_create_class],
          {} ['CREC                           ', clc$abbreviation_entry,
          clc$advertised_entry, 1, clc$automatically_log, clc$linked_call,
          ^jmp$_create_class],
          {} ['DELC                           ', clc$abbreviation_entry,
          clc$advertised_entry, 4, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_class],
          {} ['DELETE_CLASS                   ', clc$nominal_entry,
          clc$advertised_entry, 4, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_class],
          {} ['DISA                           ', clc$abbreviation_entry,
          clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_display_service_class],
          {} ['DISPLAY_ATTRIBUTE              ', clc$nominal_entry,
          clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_display_service_class],
          {} ['DISPLAY_ATTRIBUTES             ', clc$alias_entry,
          clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_display_service_class],
          {} ['QUI                            ', clc$abbreviation_entry,
          clc$advertised_entry, 5, clc$automatically_log, clc$linked_call,
          ^jmp$_quit],
          {} ['QUIT                           ', clc$nominal_entry,
          clc$advertised_entry, 5, clc$automatically_log, clc$linked_call,
          ^jmp$_quit]];

  PROCEDURE [XREF] jmp$_display_service_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??
?? OLDTITLE ??
?? NEWTITLE := 'jmp$_change_attribute ', EJECT ??

{ PURPOSE:
{   Processes the CHANGE_ATTRIBUTE command.
{
{ DESIGN:
{   Determines the service class objects to update, fetches the attributes that
{   are changing and updates them.
{
{ NOTES:
{  See JMM$ADMINISTER_OBJECTS.

  PROCEDURE jmp$_change_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admsc_chaa) change_attribute (
{   class_name, class_names, cn: any of
{       key all keyend
{       list of name
{     anyend = $current_service_class
{   abbreviation, a: (by_name) any of
{       key default, unspecified, none keyend
{       name
{     anyend = $optional
{   aio_limit, aiol: (by_name) any of
{       key default keyend
{       integer jmc$lowest_aio_limit..jmc$highest_aio_limit
{     anyend = $optional
{   class_service_threshold, cst: (by_name) any of
{       key default, unlimited keyend
{       integer jmc$lowest_service_accumulator..jmc$highest_service_accumulator
{     anyend = $optional
{   dispatching_control, dc: (by_name) any of
{       key default keyend
{       list 1..5 of record
{         dispatching_priority: any of
{           key default p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 keyend
{           integer 1..10
{          anyend
{         service_time: any of
{           key unlimited keyend
{           integer lowest_service_limit..highest_service_limit
{          anyend = $optional
{         minor_timeslice: any of
{           key default keyend
{           integer jmc$lowest_task_time_slice..jmc$highest_task_time_slice
{          anyend = $optional
{         major_timeslice: any of
{           key default keyend
{           integer jmc$lowest_task_time_slice..jmc$highest_task_time_slice
{          anyend = $optional
{        recend
{     anyend = $optional
{   guaranteed_service_quantum, gsq: (by_name) any of
{       key default, unlimited keyend
{       integer jmc$lowest_service_accumulator..jmc$highest_service_accumulator
{     anyend = $optional
{   long_wait_think_time, lwtt: (by_name) any of
{       key default keyend
{       integer jmc$low_long_wait_think_time..jmc$high_long_wait_think_time
{     anyend = $optional
{   maximum_active_jobs, maxaj: (by_name) any of
{       key default, unlimited keyend
{       integer jmc$lowest_maximum_active_jobs..jmc$highest_maximum_active_jobs
{     anyend = $optional
{   next_service_class, nsc: (by_name) any of
{       key default, none keyend
{       name
{     anyend = $optional
{   scheduling_priority, sp: (by_name) any of
{       key default keyend
{       record
{         minimum: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{         maximum: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{         swap_age_increment: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{         ready_task_increment: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{       recend
{     anyend = $optional
{   service_factors, sf: (by_name) any of
{       key default keyend
{       record
{         CPU: any of
{           key default keyend
{           integer ..
{             jmc$lowest_service_factor_value..jmc$highest_service_factor_valu
{         anyend = $optional
{         memory: any of
{           key default keyend
{           integer ..
{             jmc$lowest_service_factor_value..jmc$highest_service_factor_valu
{         anyend = $optional
{         residence: any of
{           key default keyend
{           integer ..
{             jmc$lowest_service_factor_value..jmc$highest_service_factor_valu
{         anyend = $optional
{         IO: any of
{           key default keyend
{           integer ..
{             jmc$lowest_service_factor_value..jmc$highest_service_factor_valu
{         anyend = $optional
{       recend
{     anyend = $optional
{   swap_age_interval, sai: (by_name) any of
{       key default, unlimited keyend
{       integer lowest_prio_age_interval..highest_prio_age_interval
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 26] of clt$pdt_parameter_name,
      parameters: array [1 .. 13] 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (22),
      recend,
      type2: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type3: 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$integer_type_qualifier,
        recend,
      recend,
      type4: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type5: 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$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: 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 .. 11] of clt$keyword_specification,
              recend,
              type_size_2: clt$type_specification_size,
              element_type_spec_2: record
                header: clt$type_specification_header,
                qualifier: clt$integer_type_qualifier,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_3: clt$field_specification,
            element_type_spec_3: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_4: clt$field_specification,
            element_type_spec_4: 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$integer_type_qualifier,
              recend,
            recend,
          recend,
        recend,
      recend,
      type6: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type7: 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$integer_type_qualifier,
        recend,
      recend,
      type8: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type9: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type10: 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$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: 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$integer_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type11: 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$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: 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$integer_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type12: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type13: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 8, 12, 15, 1, 2, 230],
    clc$command, 26, 13, 0, 0, 0, 0, 13, 'OSM$ADMSC_CHAA'], [
    ['A                              ',clc$abbreviation_entry, 2],
    ['ABBREVIATION                   ',clc$nominal_entry, 2],
    ['AIOL                           ',clc$abbreviation_entry, 3],
    ['AIO_LIMIT                      ',clc$nominal_entry, 3],
    ['CLASS_NAME                     ',clc$nominal_entry, 1],
    ['CLASS_NAMES                    ',clc$alias_entry, 1],
    ['CLASS_SERVICE_THRESHOLD        ',clc$nominal_entry, 4],
    ['CN                             ',clc$abbreviation_entry, 1],
    ['CST                            ',clc$abbreviation_entry, 4],
    ['DC                             ',clc$abbreviation_entry, 5],
    ['DISPATCHING_CONTROL            ',clc$nominal_entry, 5],
    ['GSQ                            ',clc$abbreviation_entry, 6],
    ['GUARANTEED_SERVICE_QUANTUM     ',clc$nominal_entry, 6],
    ['LONG_WAIT_THINK_TIME           ',clc$nominal_entry, 7],
    ['LWTT                           ',clc$abbreviation_entry, 7],
    ['MAXAJ                          ',clc$abbreviation_entry, 8],
    ['MAXIMUM_ACTIVE_JOBS            ',clc$nominal_entry, 8],
    ['NEXT_SERVICE_CLASS             ',clc$nominal_entry, 9],
    ['NSC                            ',clc$abbreviation_entry, 9],
    ['SAI                            ',clc$abbreviation_entry, 12],
    ['SCHEDULING_PRIORITY            ',clc$nominal_entry, 10],
    ['SERVICE_FACTORS                ',clc$nominal_entry, 11],
    ['SF                             ',clc$abbreviation_entry, 11],
    ['SP                             ',clc$abbreviation_entry, 10],
    ['STATUS                         ',clc$nominal_entry, 13],
    ['SWAP_AGE_INTERVAL              ',clc$nominal_entry, 12]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 22],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 143, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 121, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 937, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 121, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 121, clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 106, clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 551, clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 551, clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 121, clc$optional_parameter, 0, 0],
{ PARAMETER 13
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    '$current_service_class'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['UNSPECIFIED                    ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_aio_limit, jmc$highest_aio_limit
  , 10]]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_service_accumulator,
  jmc$highest_service_accumulator, 10]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    873, [[1, 0, clc$list_type], [857, 1, 5, 0, FALSE, FALSE],
        [[1, 0, clc$record_type], [4],
        ['DISPATCHING_PRIORITY           ', clc$required_field, 454], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
          FALSE, 2],
          414, [[1, 0, clc$keyword_type], [11], [
            ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
            ['P1                             ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
            ['P10                            ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
            ['P2                             ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
            ['P3                             ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
            ['P4                             ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
            ['P5                             ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
            ['P6                             ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
            ['P7                             ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
            ['P8                             ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
            ['P9                             ', clc$nominal_entry,
  clc$normal_usage_entry, 10]]
            ],
          20, [[1, 0, clc$integer_type], [1, 10, 10]]
          ],
        ['SERVICE_TIME                   ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
          FALSE, 2],
          44, [[1, 0, clc$keyword_type], [1], [
            ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
            ],
          20, [[1, 0, clc$integer_type], [lowest_service_limit,
  highest_service_limit, 10]]
          ],
        ['MINOR_TIMESLICE                ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
          FALSE, 2],
          44, [[1, 0, clc$keyword_type], [1], [
            ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
            ],
          20, [[1, 0, clc$integer_type], [jmc$lowest_task_time_slice,
  jmc$highest_task_time_slice, 10]]
          ],
        ['MAJOR_TIMESLICE                ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
          FALSE, 2],
          44, [[1, 0, clc$keyword_type], [1], [
            ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
            ],
          20, [[1, 0, clc$integer_type], [jmc$lowest_task_time_slice,
  jmc$highest_task_time_slice, 10]]
          ]
        ]
      ]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_service_accumulator,
  jmc$highest_service_accumulator, 10]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$low_long_wait_think_time,
  jmc$high_long_wait_think_time, 10]]
    ],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_maximum_active_jobs,
  jmc$highest_maximum_active_jobs, 10]]
    ],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$record_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    487, [[1, 0, clc$record_type], [4],
      ['MINIMUM                        ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
  jmc$highest_job_priority, 10]]
        ],
      ['MAXIMUM                        ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
  jmc$highest_job_priority, 10]]
        ],
      ['SWAP_AGE_INCREMENT             ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
  jmc$highest_job_priority, 10]]
        ],
      ['READY_TASK_INCREMENT           ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
  jmc$highest_job_priority, 10]]
        ]
      ]
    ],
{ PARAMETER 11
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$record_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    487, [[1, 0, clc$record_type], [4],
      ['CPU                            ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_service_factor_value,
  jmc$highest_service_factor_valu, 10]]
        ],
      ['MEMORY                         ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_service_factor_value,
  jmc$highest_service_factor_valu, 10]]
        ],
      ['RESIDENCE                      ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_service_factor_value,
  jmc$highest_service_factor_valu, 10]]
        ],
      ['IO                             ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_service_factor_value,
  jmc$highest_service_factor_valu, 10]]
        ]
      ]
    ],
{ PARAMETER 12
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [lowest_prio_age_interval,
  highest_prio_age_interval, 10]]
    ],
{ PARAMETER 13
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$class_name = 1,
      p$abbreviation = 2,
      p$aio_limit = 3,
      p$class_service_threshold = 4,
      p$dispatching_control = 5,
      p$guaranteed_service_quantum = 6,
      p$long_wait_think_time = 7,
      p$maximum_active_jobs = 8,
      p$next_service_class = 9,
      p$scheduling_priority = 10,
      p$service_factors = 11,
      p$swap_age_interval = 12,
      p$status = 13;

    VAR
      pvt: array [1 .. 13] of clt$parameter_value;

    VAR
      the_attributes: jmt$object_attribute;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_service_class;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$get_attributes (jmc$profile_service_class, #SEQ (pdt), ^pvt,
          the_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$change_object (jmc$profile_service_class, pvt [p$class_name].value^,
          the_attributes, jmc$update, status);

  PROCEND jmp$_change_attribute;
?? TITLE := 'jmp$_create_class ', EJECT ??

{ PURPOSE:
{   Processes the CREATE_CLASS command.
{
{ DESIGN:
{   Fetches the default values and adds the specified service class to the
{   profile.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS.

  PROCEDURE jmp$_create_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admsc_crec) create_class (
{   class_name, cn: name = $required
{   default_values, dv: (by_name) name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 54, 2, 85], clc$command, 5, 3, 1, 0, 0, 0,
            3, 'OSM$ADMSC_CREC'], [['CLASS_NAME                     ',
            clc$nominal_entry, 1], ['CN                             ',
            clc$abbreviation_entry, 1], ['DEFAULT_VALUES                 ',
            clc$nominal_entry, 2], ['DV                             ',
            clc$abbreviation_entry, 2], ['STATUS                         ',
            clc$nominal_entry, 3]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 5,
            clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$class_name = 1,
      p$default_values = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      the_attributes: jmt$object_attribute,
      the_class: jmt$profile_object_reference;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_service_class;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$set_default_attributes (jmc$profile_service_class,
          pvt [p$default_values], the_attributes, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$add_object (jmc$profile_service_class,
          pvt [p$class_name].value^.name_value, the_attributes, the_class,
          status);

  PROCEND jmp$_create_class;
?? TITLE := 'jmp$_delete_class ', EJECT ??

{ PURPOSE:
{   Processes the DELETE_CLASS command.
{
{ DESIGN:
{   Determine the service classes to delete and delete them.
{
{ NOTES:
{   See JMM$ADMINISTER_OBJECTS

  PROCEDURE jmp$_delete_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admsc_delc) delete_class (
{   class_name, class_names, cn: list of name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 4] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 54, 21, 856], clc$command, 4, 2, 1, 0, 0,
            0, 2, 'OSM$ADMSC_DELC'], [['CLASS_NAME                     ',
            clc$nominal_entry, 1], ['CLASS_NAMES                    ',
            clc$alias_entry, 1], ['CN                             ',
            clc$abbreviation_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 2]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 21,
            clc$required_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$class_name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_service_class;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$delete_object (jmc$profile_service_class, pvt [p$class_name].value^,
          status);

  PROCEND jmp$_delete_class;
?? TITLE := 'jmp$_quit', EJECT ??

{ PURPOSE:
{   Exits the subutility.
{
{ DESIGN:
{   Terminates the subutility.

  PROCEDURE jmp$_quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admsc_qui) quit (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 9, 26, 10, 54, 39, 306], clc$command, 1, 1, 0, 0, 0,
            0, 1, 'OSM$ADMSC_QUI'], [['STATUS                         ',
            clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$end_include (utility_name, status);

  PROCEND jmp$_quit;
?? TITLE := '[XDCL] jmp$_administer_service_class', EJECT ??

{ PURPOSE:
{   Starts the ADMINISTER_SERVICE_CLASS sub utility.
{
{ DESIGN:
{   Pass the command table to command_language.

  PROCEDURE [XDCL, #GATE] jmp$_administer_service_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$adms_admsc) administer_service_class (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 9, 26, 10, 55, 0, 434], clc$command, 1, 1, 0, 0, 0,
            0, 1, 'OSM$ADMS_ADMSC'], [['STATUS                         ',
            clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    utility_attributes [1].command_table := command_table;
    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmv$current_profile_level := jmc$profile_service_class;

    clp$include_file (command_file, '', utility_name, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$end_utility (utility_name, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

  PROCEND jmp$_administer_service_class;
MODEND jmm$administer_service_class;
*DECK DECK=JMM$AJL_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOSVE AJL MANAGER MODULE' ??
MODULE jmm$ajl_manager;

{
{ This module governs the allocation and freeing of the ajl ordinals. It also
{ modifies the monitor segment table.
{
{ JMP$ASSIGN_AJL_ENTRY: This procedure is called by tmm$dispatcher (tmp$create_job)
{    when a job is created, jsm$monitor_mode_job_swapper when a job is being swapped
{    in, or when access to a job's job fixed is needed.  An entry is assigned if
{    needed, otherwise just the in_use count is incremented.  An error status condition
{    is returned if an entry is needed but not available.  When an entry is assigned,
{    several fields are initialized, and an entry is made into the monitor segment
{    table.  The variables jmv$max_ajl_ordinal_in_use and jmv$number_free_ajl_entries
{    are updated appropriately.  Jmv$number_free_ajl_entries may go negative down to the
{    number of cpus defined (must_assign is set and called for swapping io, for io
{    completion or for job fixed access).
{
{
{ JMP$ASSIGN_AJL_WITH_LOCK: Same as above but caller already has tmv$ptl_lock set.
{
{
{ JMP$FREE_AJL_ENTRY: This procedure decrements the in_use count.  When the count goes
{    to zero the ajl entry is freed and the monitor segment table entry is marked invalid.
{    The variables jmv$max_ajl_ordinal_in_use and jmv$number_of_free_ajl_entries are
{    updated appropriately.  This procedure is called by tmm$dispatcher (tmp$exit_job)
{    when a job is exited, by jsm$monitor_mode_job_swapper when a job is swapped out, or
{    when access to a job's job fixed is no longer needed.
{
{
{ JMP$FREE_AJL_WITH_LOCK: Same as above but caller already has tmv$ptl_lock set.
{
{
{ NOTE: The following are inline procedures.  They are used instead of the above
{    procedures when access to a job's job fixed is needed and there is reason to
{    believe there is already an ajl entry for the job.
{
{
{ JMP$LOCK_AJL: This procedure increments the in_use count. Jmp$assign_ajl_with_lock
{    is called if necessary with the MUST_ASSIGN parameter set to TRUE.
{
{
{ JMP$LOCK_AJL_WITH_LOCK: This procedure increments the in_use count but caller
{    already has tmv$ptl_lock_set.  Jmp$assign_ajl_with_lock is called if
{    necessary with the MUST_ASSIGN parameter set to TRUE.
{
{
{ JMP$UNLOCK_AJL: This procedure decrements the in_use count.  Jmp$free_ajl_with_lock
{    is called if necessary.
{
{
{ JMP$UNLOCK_AJL_WITH_LOCK: Same as above but caller already has tmv$ptl_lock set.
{
{
?? PUSH (LISTEXT := ON) ??
*copyc jmc$ajl_caller
*copyc jmc$null_ajl_ordinal
*copyc jmt$active_job_list
*copyc jmt$ajl_ordinal
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc mtc$job_fixed_segment
*copyc osc$multiprocessor_constants
*copyc syt$monitor_status



?? POP ??
*copyc jme$job_scheduler_conditions
*copyc jmp$get_ijle_p
*copyc mtp$error_stop
*copyc mtp$set_status_abnormal
*copyc mmp$conditional_purge_all_s_map
*copyc jmp$set_scheduler_event
*copyc tmp$set_lock
*copyc tmp$clear_lock

*copyc jmv$job_sched_events_selected
*copyc jmv$job_scheduler_event
*copyc jmv$ijl_p
*copyc jmv$ajl_p
*copyc mmv$multiple_page_maps
*copyc mtv$monitor_segment_table
*copyc osv$cpus_physically_configured
*copyc tmv$ptl_lock

  VAR
    jmv$number_free_ajl_entries: [XDCL, #GATE] integer,
    null_ajl: [STATIC] jmt$active_job_list_entry := [0, [0, 0], NIL, FALSE, 0],
    jmv$max_ajl_ordinal_in_use: [XDCL, #GATE] jmt$ajl_ordinal := 0,
    jmv$start_ajl_search_ordinal: [STATIC] jmt$ajl_ordinal := 0;


?? TITLE := ' JMP$ASSIGN_AJL_ENTRY ', EJECT ??

{  This procedure is called by tmm$dispatcher (tmp$create_job)
{  when a job is created, jsm$monitor_mode_job_swapper when a job is being swapped
{  in, or when access to a job's job fixed is needed.  An entry is assigned if
{  needed, otherwise just the in_use count is incremented.  An error status condition
{  is returned if an entry is needed but not available.  When an entry is assigned,
{  several fields are initialized, and an entry is made into the monitor segment
{  table.  The variables jmv$max_ajl_ordinal_in_use and jmv$number_free_ajl_entries
{  are updated appropriately.  Jmv$number_free_ajl_entries may go negative down to the
{  number of cpus defined (must_assign is set and called for swapping io, for io
{  completion or for job fixed access).

  PROCEDURE [XDCL] jmp$assign_ajl_entry
    (    asid: ost$asid,
         ijl_o: jmt$ijl_ordinal;
         caller: 0 .. 10(16);
         must_assign: boolean;
     VAR ajl_o: jmt$ajl_ordinal;
     VAR status: syt$monitor_status);

    VAR
      ajl_p: ^jmt$active_job_list_entry,
      ajlo: jmt$ajl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      job_fixed_ste: ost$segment_descriptor,
      none_found: boolean;

    status.normal := TRUE;
    tmp$set_lock (tmv$ptl_lock);

    jmp$get_ijle_p (ijl_o, ijle_p);
    IF ijle_p^.ajl_ordinal = jmc$null_ajl_ordinal THEN
      IF (jmv$number_free_ajl_entries > 0) OR (must_assign) THEN
        none_found := TRUE;

      /scan_ajl_for_free_entry/
        FOR ajlo := jmv$start_ajl_search_ordinal TO UPPERBOUND (jmv$ajl_p^) DO
          IF jmv$ajl_p^ [ajlo].in_use = 0 THEN
            ajl_o := ajlo;
            none_found := FALSE;
            EXIT /scan_ajl_for_free_entry/;
          IFEND;
        FOREND /scan_ajl_for_free_entry/;

        IF none_found THEN
          mtp$error_stop ('JM - No free ajl ordinal');
        IFEND;

      ELSE
        mtp$set_status_abnormal ('JM', jme$no_free_ajl_ordinals, status);
        tmp$clear_lock (tmv$ptl_lock);
        RETURN;
      IFEND;

      ajl_p := ^jmv$ajl_p^ [ajl_o];
      ajl_p^.ijl_ordinal := ijl_o;
      ajl_p^.ijle_p := ijle_p;
      ijle_p^.ajl_ordinal := ajl_o;

{ Purge the page-segment map if it has not been purged since the AJL entry was last used.

      mmp$conditional_purge_all_s_map (ajl_p^.time_freed);


{ Entry made into the monitor segment table for the job fixed segment of the job.

      job_fixed_ste := mtv$monitor_segment_table.st [mtc$job_fixed_segment].ste;
      job_fixed_ste.asid := asid;
      mtv$monitor_segment_table.st [ajl_o + mtc$job_fixed_segment].ste := job_fixed_ste;

      jmv$start_ajl_search_ordinal := ajl_o;

      IF jmv$max_ajl_ordinal_in_use < ajl_o THEN
        jmv$max_ajl_ordinal_in_use := ajl_o;
      IFEND;

      jmv$number_free_ajl_entries := jmv$number_free_ajl_entries - 1;

    ELSE
      ajl_p := ^jmv$ajl_p^ [ijle_p^.ajl_ordinal];
      ajl_o := ijle_p^.ajl_ordinal;
    IFEND;

    ajl_p^.in_use := ajl_p^.in_use + caller;
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND jmp$assign_ajl_entry;

?? TITLE := ' JMP$ASSIGN_AJL_WITH_LOCK ', EJECT ??

{  This procedure is identical to jmp$assign_ajl_entry except the caller
{  already has tmv$ptl_lock set.

  PROCEDURE [XDCL] jmp$assign_ajl_with_lock
    (    asid: ost$asid,
         ijl_o: jmt$ijl_ordinal;
         caller: 0 .. 10(16);
         must_assign: boolean;
     VAR ajl_o: jmt$ajl_ordinal;
     VAR status: syt$monitor_status);

    VAR
      ajl_p: ^jmt$active_job_list_entry,
      ajlo: jmt$ajl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      job_fixed_ste: ost$segment_descriptor,
      none_found: boolean;

    status.normal := TRUE;

    jmp$get_ijle_p (ijl_o, ijle_p);
    IF ijle_p^.ajl_ordinal = jmc$null_ajl_ordinal THEN
      IF (jmv$number_free_ajl_entries > 0) OR (must_assign) THEN
        none_found := TRUE;

      /scan_ajl_for_free_entry/
        FOR ajlo := jmv$start_ajl_search_ordinal TO UPPERBOUND (jmv$ajl_p^) DO
          IF jmv$ajl_p^ [ajlo].in_use = 0 THEN
            ajl_o := ajlo;
            none_found := FALSE;
            EXIT /scan_ajl_for_free_entry/;
          IFEND;
        FOREND /scan_ajl_for_free_entry/;

        IF none_found THEN
          mtp$error_stop ('JM - No free ajl ordinal');
        IFEND;

      ELSE
        mtp$set_status_abnormal ('JM', jme$no_free_ajl_ordinals, status);
        RETURN;
      IFEND;

      ajl_p := ^jmv$ajl_p^ [ajl_o];
      ajl_p^.ijl_ordinal := ijl_o;
      ajl_p^.ijle_p := ijle_p;
      ijle_p^.ajl_ordinal := ajl_o;

{ Purge the page-segment map if it has not been purged since the AJL entry was last used.

      mmp$conditional_purge_all_s_map (ajl_p^.time_freed);


{ Entry made into the monitor segment table for the job fixed segment of the job.

      job_fixed_ste := mtv$monitor_segment_table.st [mtc$job_fixed_segment].ste;
      job_fixed_ste.asid := asid;
      mtv$monitor_segment_table.st [ajl_o + mtc$job_fixed_segment].ste := job_fixed_ste;

      jmv$start_ajl_search_ordinal := ajl_o;

      IF jmv$max_ajl_ordinal_in_use < ajl_o THEN
        jmv$max_ajl_ordinal_in_use := ajl_o;
      IFEND;

      jmv$number_free_ajl_entries := jmv$number_free_ajl_entries - 1;

    ELSE
      ajl_p := ^jmv$ajl_p^ [ijle_p^.ajl_ordinal];
      ajl_o := ijle_p^.ajl_ordinal;
    IFEND;

    ajl_p^.in_use := ajl_p^.in_use + caller;

  PROCEND jmp$assign_ajl_with_lock;

?? TITLE := ' JMP$FREE_AJL_ENTRY ', EJECT ??

{  This procedure decrements the in_use count.  When the count goes
{  to zero the ajl entry is freed and the monitor segment table entry is marked invalid.
{  The variables jmv$max_ajl_ordinal_in_use and jmv$number_of_free_ajl_entries are
{  updated appropriately.  This procedure is called by tmm$dispatcher (tmp$exit_job)
{  when a job is exited, by jsm$monitor_mode_job_swapper when a job is swapped out, or
{  when access to a job's job fixed is no longer needed.

  PROCEDURE [XDCL] jmp$free_ajl_entry
    (    ijle_p: ^jmt$initiated_job_list_entry;
         caller: 0 .. 10(16));

    VAR
      ajl_ordinal: jmt$ajl_ordinal,
      in_use: integer,
      new_ajlo: jmt$ajl_ordinal;

    tmp$set_lock (tmv$ptl_lock);
    ajl_ordinal := ijle_p^.ajl_ordinal;
    in_use := jmv$ajl_p^ [ajl_ordinal].in_use;
    in_use := in_use - caller;
    IF in_use < 0 THEN
      mtp$error_stop ('JM - AJL.in_use has gone negative.');
    ELSEIF in_use > 0 THEN
      jmv$ajl_p^ [ajl_ordinal].in_use := in_use;
    ELSE   { in_use = 0 }
      IF (ajl_ordinal = 0) THEN
        mtp$error_stop ('JM - trying to free system job ajl');
      IFEND;
      ijle_p^.ajl_ordinal := jmc$null_ajl_ordinal;
      mtv$monitor_segment_table.st [ajl_ordinal + mtc$job_fixed_segment].ste.vl := osc$vl_invalid_entry;
      jmv$ajl_p^ [ajl_ordinal] := null_ajl;
      jmv$ajl_p^ [ajl_ordinal].time_freed := #FREE_RUNNING_CLOCK (0);

{ increment number of free ajl ordinals

      jmv$number_free_ajl_entries := jmv$number_free_ajl_entries + 1;

{ if scheduler is waiting for an ajlo to be freed, then notify scheduler

      IF (jmv$number_free_ajl_entries > 0) AND
            (jmv$job_sched_events_selected [jmc$needed_ajlo_available]) AND
            (NOT jmv$job_scheduler_event [jmc$needed_ajlo_available]) THEN
        jmp$set_scheduler_event (jmc$needed_ajlo_available);
      IFEND;

{ update jmv$start_ajl_search_ordinal if necessary

      IF ajl_ordinal < jmv$start_ajl_search_ordinal THEN
        jmv$start_ajl_search_ordinal := ajl_ordinal;
      IFEND;

{ update jmv$max_ajl_ordinal_in_use if necessary

      IF ajl_ordinal = jmv$max_ajl_ordinal_in_use THEN
        new_ajlo := ajl_ordinal;
        WHILE (jmv$ajl_p^ [new_ajlo].in_use = 0) DO
          new_ajlo := new_ajlo - 1;
        WHILEND;
        jmv$max_ajl_ordinal_in_use := new_ajlo;
      IFEND;
    IFEND;

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND jmp$free_ajl_entry;
?? TITLE := ' JMP$FREE_AJL_WITH_LOCK ', EJECT ??

{  This procedure is identical to jmp$free_ajl_entry except the caller
{  already has tmv$ptl_lock set.

  PROCEDURE [XDCL] jmp$free_ajl_with_lock
    (    ijle_p: ^jmt$initiated_job_list_entry;
         caller: 0 .. 10(16));

    VAR
      ajl_ordinal: jmt$ajl_ordinal,
      in_use: integer,
      new_ajlo: jmt$ajl_ordinal;

    ajl_ordinal := ijle_p^.ajl_ordinal;
    in_use := jmv$ajl_p^ [ajl_ordinal].in_use;
    in_use := in_use - caller;
    IF in_use < 0 THEN
      mtp$error_stop ('JM - AJL.in_use has gone negative.');
    ELSEIF in_use > 0 THEN
      jmv$ajl_p^ [ajl_ordinal].in_use := in_use;
    ELSE   { in_use = 0 }
      IF (ajl_ordinal = 0) THEN
        mtp$error_stop ('JM - trying to free system job ajl');
      IFEND;
      ijle_p^.ajl_ordinal := jmc$null_ajl_ordinal;
      mtv$monitor_segment_table.st [ajl_ordinal + mtc$job_fixed_segment].ste.vl := osc$vl_invalid_entry;
      jmv$ajl_p^ [ajl_ordinal] := null_ajl;
      jmv$ajl_p^ [ajl_ordinal].time_freed := #FREE_RUNNING_CLOCK (0);

{ increment number of free ajl ordinals

      jmv$number_free_ajl_entries := jmv$number_free_ajl_entries + 1;

{ if scheduler is waiting for an ajlo to be freed, then notify scheduler

      IF (jmv$number_free_ajl_entries > 0) AND
            (jmv$job_sched_events_selected [jmc$needed_ajlo_available]) AND
            (NOT jmv$job_scheduler_event [jmc$needed_ajlo_available]) THEN
        jmp$set_scheduler_event (jmc$needed_ajlo_available);
      IFEND;

{ update jmv$start_ajl_search_ordinal if necessary

      IF ajl_ordinal < jmv$start_ajl_search_ordinal THEN
        jmv$start_ajl_search_ordinal := ajl_ordinal;
      IFEND;

{ update jmv$max_ajl_ordinal_in_use if necessary

      IF ajl_ordinal = jmv$max_ajl_ordinal_in_use THEN
        new_ajlo := ajl_ordinal;
        WHILE (jmv$ajl_p^ [new_ajlo].in_use = 0) DO
          new_ajlo := new_ajlo - 1;
        WHILEND;
        jmv$max_ajl_ordinal_in_use := new_ajlo;
      IFEND;
    IFEND;

  PROCEND jmp$free_ajl_with_lock;

MODEND jmm$ajl_manager;
*DECK DECK=JMM$ATTRIBUTE_DISPLAY_FUNCTIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : Attribute Displays and Functions' ??
MODULE jmm$attribute_display_functions;

{ PURPOSE:
{   This module contains the procedures for managing the display and translation of job-associated
{ attributes.  The display interfaces are structured as the weakly typed program interface.  This
{ allows a significant amount of commonality and flexibility for the introduction of new attributes.
{ This allows a single display procedure to perform all of the display operations.
{
{ DESIGN:
{   The display procedure in this module is modeled after the "standard" display procedures generated
{ by the NOS/VE System Command Language (SCL) Project.
{
{   The display procedure will accept a sequence that contains a pointer to an adaptable array of
{ pointers to adaptable arrays of variant records.  Given this, it will display the contents of these
{ arrays in the order in which they are specified.  The display procedure also allows a list of names
{ to be displayed as "Name not found".

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$term_option
*copyc cle$ecc_miscellaneous
*copyc clt$display_control
*copyc clt$file
*copyc clt$file_reference
*copyc clt$path_display_chunks
*copyc clt$processing_phase
*copyc jme$queued_file_conditions
*copyc jme$work_area_too_small
*copyc jmt$attribute_keys
*copyc jmt$attribute_values
*copyc jmt$full_job_category_list
*copyc jmt$header_display_information
*copyc jmt$job_class_set
*copyc jmt$name_list
*copyc jmt$output_device
*copyc jmt$qfile_application_attrs
*copyc jmt$results_keys
*copyc jmt$work_area
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc ost$date
*copyc ost$name
*copyc ost$status
*copyc ost$string
*copyc ost$time
*copyc ost$user_identification
*copyc pmt$os_name
?? POP ??
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_data_to_string
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$get_work_area
*copyc clp$horizontal_tab_display
*copyc clp$make_boolean_value
*copyc clp$make_date_time_value
*copyc clp$make_file_value
*copyc clp$make_integer_value
*copyc clp$make_list_value
*copyc clp$make_name_value
*copyc clp$make_string_value
*copyc clp$make_time_increment_value
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$open_display
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$scan_argument_list
*copyc clp$trimmed_string_size
*copyc jmp$determine_job_class
*copyc jmp$determine_name_kind
*copyc jmp$get_attribute_defaults
*copyc jmp$get_input_attributes
*copyc jmp$get_job_attributes
*copyc jmp$get_job_counts
*copyc jmp$get_job_status
*copyc jmp$get_output_attributes
*copyc jmp$get_output_status
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$compute_date_time_increment
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pmp$get_compact_date_time
*copyc pmp$get_job_mode
*copyc clv$value_descriptors
*copyc jmv$null_date_time
*copyc osv$upper_to_lower
?? OLDTITLE ??
?? NEWTITLE := 'Global Variables and Constants Declared in this Module', EJECT ??

  CONST
    lowercase_required = 'required',
    lowercase_system_default = 'system_default',
    lowercase_unlimited = 'unlimited',
    lowercase_unspecified = 'unspecified',
    none = 'NONE',
    unknown_attribute_name = 'UNKNOWN',
    max_os_type_size = 6, {nos/be
    max_data_mode_size = 13, {rhf_structure
    max_device_type_size = 7, {printer
    max_job_abort_disposition_size = 9, {terminate
    max_job_recovery_disp_size = 9, {terminate
    max_job_state_size = 23, {waiting to be initiated
    max_terminate_job_action_size = 21, {operator kill enabled
    max_job_mode_size = 30, {interactive command disconnect
    max_output_disposition_size = 23, {discard_standard_output
    max_output_state_size = 21, {waiting to be printed
    max_processing_phase_size = 20, {member prolog phase
    max_qfile_state_size = 23, {waiting to be processed
    max_boolean_string_size = 3; {yes

  VAR
    boolean_string: [STATIC, READ, oss$job_paged_literal] array [boolean] of record
      size: 1 .. max_boolean_string_size,
      value: string (max_boolean_string_size),
    recend := [[2, 'no'], [3, 'yes']],
    c170_os_type: [STATIC, READ, oss$job_paged_literal] array [ost$170_os_type] of record
      size: 1 .. max_os_type_size,
      value: string (max_os_type_size),
    recend := [[4, 'none'], [3, 'NOS'], [6, 'NOS/BE']],
    data_mode: [STATIC, READ, oss$job_paged_literal] array [jmt$data_mode] of record
      size: 1 .. max_data_mode_size,
      value: string (max_data_mode_size),
    recend := [[5, 'coded'], [13, 'rhf_structure'], [11, 'transparent']],
    device_type: [STATIC, READ, oss$job_paged_literal] array [jmt$output_device_type] of record
      size: 1 .. max_device_type_size,
      value: string (max_device_type_size),
    recend := [[7, 'printer'], [7, 'plotter'], [5, 'punch']],
    input_file_location: [STATIC, READ, oss$job_paged_literal] array
          [jmc$ifl_no_input_file_exists .. jmc$ifl_login_family_queue] of record
      size: 1 .. 23,
      value: string (23),
    recend := [[20, 'no_input_file_exists'], [18, 'system_input_queue'], [23, 'store_and_forward_queue'], [18,
          'login_family_queue']],
    job_abort_disposition: [STATIC, READ, oss$job_paged_literal] array [jmt$job_abort_disposition] of record
      size: 1 .. max_job_abort_disposition_size,
      value: string (max_job_abort_disposition_size),
    recend := [[7, 'restart'], [9, 'terminate']],
    job_mode: [STATIC, READ, oss$job_paged_literal] array [jmt$job_mode] of record
      size: 1 .. max_job_mode_size,
      value: string (max_job_mode_size),
    recend := [[5, 'batch'], [22, 'interactive connected'], [30, 'interactive command disconnect'], [27,
          'interactive line disconnect'], [29, 'interactive system disconnect']],
    job_recovery_disposition: [STATIC, READ, oss$job_paged_literal] array [jmt$job_recovery_disposition] of
          record
      size: 1 .. max_job_recovery_disp_size,
      value: string (max_job_recovery_disp_size),
    recend := [[8, 'continue'], [7, 'restart'], [9, 'terminate']],
    job_state: [STATIC, READ, oss$job_paged_literal] array [jmt$job_state] of record
      size: 1 .. max_job_state_size,
      value: string (max_job_state_size),
    recend := [[8, 'deferred'], [23, 'waiting to be initiated'], [9, 'initiated'], [11, 'terminating'], [9,
          'completed']],
    output_disposition: [STATIC, READ, oss$job_paged_literal] array [jmt$output_disposition_keys] of record
      size: 1 .. max_output_disposition_size,
      value: string (max_output_disposition_size),
    recend := [[18, 'discard_all_output'], [23, 'discard_standard_output'], [5, 'local'], [7, 'printer'], [15,
          'standard_output'], [10, 'wait_queue']],
    output_state: [STATIC, READ, oss$job_paged_literal] array [jmt$output_state] of record
      size: 1 .. max_output_state_size,
      value: string (max_output_state_size),
    recend := [[8, 'deferred'], [21, 'waiting to be printed'], [8, 'printing'], [10, 'terminated'], [9,
          'completed']],
    processing_phase: [STATIC, READ, oss$job_paged_literal] array [clt$processing_phase] of record
      size: 1 .. max_processing_phase_size,
      value: string (max_processing_phase_size),
    recend := [[15, 'job begin phase'], [19, 'system prolog phase'], [18, 'class prolog phase'], [20,
          'account prolog phase'], [20, 'project prolog phase'], [20, 'member prolog phase'], [17,
          'user prolog phase'], [13, 'command phase'], [17, 'user epilog phase'], [20, 'member epilog phase'],
          [20, 'project epilog phase'], [20, 'account epilog phase'], [18, 'class epilog phase'], [19,
          'system epilog phase'], [13, 'job end phase']],
    terminate_job_action: [STATIC, READ, oss$job_paged_literal] array [jmt$terminate_job_action] of record
      size: 1 .. max_terminate_job_action_size,
      value: string (max_terminate_job_action_size),
    recend := [[13, 'kill_disabled'], [21, 'operator_kill_enabled'], [17, 'user_kill_enabled']],
    qfile_state: [STATIC, READ, oss$job_paged_literal] array [jmt$qfile_state] of record
      size: 1 .. max_qfile_state_size,
      value: string (max_qfile_state_size),
    recend := [[8, 'deferred'], [23, 'waiting to be processed'], [10, 'processing'], [10, 'terminated'], [9,
          'completed']];

?? EJECT ??

{ PURPOSE:
{   The alphabetical_attribute_list is used for searching for attributes based on name.  Not all
{ attributes are placed in this table.  Only the attributes that need to be searched by name for some
{ process are located in this table.  Attributes are searched by name by SCL function processors and
{ as display_options on various display commands.
{
{ NOTES:
{   Remember: In the ASCII collating sequence the underscore comes after and alpha/numeric characters.
{ Therefore, if a='ABC_XYZ' and b='ABCDXYZ', a > b.
{
{   Some attributes are not present in this table because of name or abbreviation conflicts.  For example,
{ the attributes job_state and job_size have the same abbreviation so only on abbreviation can appear in
{ the table.
{
{   This table MUST be in alphabetical order.

  CONST
    alphabetical_attribute_count = 117;

?? FMT (FORMAT := OFF) ??
  VAR
    alphabetical_attribute_list: [STATIC, READ, oss$job_paged_literal] array [1 ..
          alphabetical_attribute_count] of record
      attribute_name: ost$name,
      attribute_index: jmt$attribute_keys,
    recend := [
      ['ACCOUNT                        ', jmc$login_account],
      ['APPLICATION_NAME               ', jmc$application_name],
      ['C170_OS_TYPE                   ', jmc$c170_os_type],
      ['CLIENT_MAINFRAME_IDENTIFIER    ', jmc$client_mainframe_id],
      ['COMMENT_BANNER                 ', jmc$comment_banner],
      ['CONTROL_FAMILY                 ', jmc$control_family],
      ['CONTROL_USER                   ', jmc$control_user],
      ['COPIES                         ', jmc$copies],
      ['COPIES_PRINTED                 ', jmc$copies_printed],
      ['CPU_TIME_LIMIT                 ', jmc$cpu_time_limit],
      ['CPU_TIME_USED                  ', jmc$cpu_time_used],
      ['CYCLIC_AGING_INTERVAL          ', jmc$cyclic_aging_interval],
      ['DATA_DECLARATION               ', jmc$data_declaration],
      ['DATA_MODE                      ', jmc$data_mode],
      ['DEFERRED_BY_APPLICATION        ', jmc$deferred_by_application],
      ['DESTINATION                    ', jmc$destination],
      ['DESTINATION_FAMILY             ', jmc$output_destination_family],
      ['DESTINATION_USAGE              ', jmc$output_destination_usage],
      ['DETACHED_JOB_WAIT_TIME         ', jmc$detached_job_wait_time],
      ['DEVICE                         ', jmc$device],
      ['DEVICE_TYPE                    ', jmc$device_type],
      ['DISPATCHING_PRIORITY           ', jmc$dispatching_priority],
      ['DISPLAY_MESSAGE                ', jmc$display_message],
      ['DUAL_STATE_ROUTE_PARAMETERS    ', jmc$remote_host_directive],
      ['EARLIEST_PRINT_TIME            ', jmc$earliest_print_time],
      ['EARLIEST_RUN_TIME              ', jmc$earliest_run_time],
      ['EXTERNAL_CHARACTERISTICS       ', jmc$external_characteristics],
      ['FAMILY_NAME                    ', jmc$login_family],
      ['FILE_POSITION                  ', jmc$file_position],
      ['FILE_SIZE                      ', jmc$file_size],
      ['FORMS_CODE                     ', jmc$forms_code],
      ['INPUT_FILE_LOCATION            ', jmc$input_file_location],
      ['JOB_ABORT_DISPOSITION          ', jmc$job_abort_disposition],
      ['JOB_CLASS                      ', jmc$job_class],
      ['JOB_CLASS_POSITION             ', jmc$job_class_position],
      ['JOB_DEFERRED_BY_OPERATOR       ', jmc$job_deferred_by_operator],
      ['JOB_DEFERRED_BY_USER           ', jmc$job_deferred_by_user],
      ['JOB_DESTINATION                ', jmc$job_destination_family],
      ['JOB_DESTINATION_USAGE          ', jmc$job_destination_usage],
      ['JOB_EXECUTION_RING             ', jmc$job_execution_ring],
      ['JOB_INITIATION_TIME            ', jmc$job_initiation_time],
      ['JOB_MODE                       ', jmc$job_mode],
      ['JOB_MODE_CPU_TIME              ', jmc$cpu_time_used],
      ['JOB_NAME                       ', jmc$user_job_name],
      ['JOB_PRIORITY                   ', jmc$job_priority],
      ['JOB_PROCESSING_PHASE           ', jmc$processing_phase],
      ['JOB_QUALIFIER                  ', jmc$job_qualifier_list],
      ['JOB_QUALIFIERS                 ', jmc$job_qualifier_list],
      ['JOB_RECOVERY_DISPOSITION       ', jmc$job_recovery_disposition],
      ['JOB_SIZE                       ', jmc$job_size],
      ['JOB_STATE                      ', jmc$job_state],
      ['JOB_SUBMISSION_TIME            ', jmc$job_submission_time],
      ['LATEST_PRINT_TIME              ', jmc$latest_print_time],
      ['LATEST_RUN_TIME                ', jmc$latest_run_time],
      ['LOGIN_ACCOUNT                  ', jmc$login_account],
      ['LOGIN_FAMILY                   ', jmc$login_family],
      ['LOGIN_PROJECT                  ', jmc$login_project],
      ['LOGIN_USER                     ', jmc$login_user],
      ['MAGNETIC_TAPE_LIMIT            ', jmc$magnetic_tape_limit],
      ['MAXIMUM_WORKING_SET            ', jmc$maximum_working_set],
      ['MINIMUM_WORKING_SET            ', jmc$minimum_working_set],
      ['MODE                           ', jmc$job_mode],
      ['MONITOR_MODE_CPU_TIME          ', jmc$cpu_time_used],
      ['NAME                           ', jmc$system_file_name],
      ['OPERATOR                       ', jmc$operator_job],
      ['OPERATOR_ACTION_POSTED         ', jmc$operator_action_posted],
      ['OPERATOR_FAMILY                ', jmc$output_destination_family],
      ['OPERATOR_JOB                   ', jmc$operator_job],
      ['OPERATOR_USER                  ', jmc$station_operator],
      ['ORIGINATING_APPLICATION_NAME   ', jmc$origin_application_name],
      ['OS_VERSION                     ', jmc$os_version],
      ['OUTPUT_CLASS                   ', jmc$output_class],
      ['OUTPUT_DEFERRED_BY_OPERATOR    ', jmc$output_deferred_by_operator],
      ['OUTPUT_DEFERRED_BY_USER        ', jmc$output_deferred_by_user],
      ['OUTPUT_DESTINATION             ', jmc$output_destination],
      ['OUTPUT_DESTINATION_USAGE       ', jmc$output_destination_usage],
      ['OUTPUT_DISPOSITION             ', jmc$output_disposition],
      ['OUTPUT_PRIORITY                ', jmc$output_priority],
      ['OUTPUT_STATE                   ', jmc$output_state],
      ['OUTPUT_SUBMISSION_TIME         ', jmc$output_submission_time],
      ['PAGES_ASSIGNED                 ', jmc$page_faults],
      ['PAGES_FROM_DISK                ', jmc$page_faults],
      ['PAGES_RECLAIMED                ', jmc$page_faults],
      ['PAGE_AGING_INTERVAL            ', jmc$page_aging_interval],
      ['PAGE_FAULTS                    ', jmc$page_faults],
      ['PROCESSING_PHASE               ', jmc$processing_phase],
      ['PROJECT                        ', jmc$login_project],
      ['PURGE_DELAY                    ', jmc$purge_delay],
      ['REMOTE_HOST_DIRECTIVE          ', jmc$remote_host_directive],
      ['ROUTING_BANNER                 ', jmc$routing_banner],
      ['SENSE_SWITCHES                 ', jmc$sense_switches],
      ['SERVER_MAINFRAME_IDENTIFIER    ', jmc$server_mainframe_id],
      ['SERVICE_CLASS                  ', jmc$service_class],
      ['SITE_INFORMATION               ', jmc$site_information],
      ['SOURCE_LOGICAL_ID              ', jmc$source_logical_id],
      ['SRU_LIMIT                      ', jmc$sru_limit],
      ['STATE                          ', jmc$qfile_state],
      ['STATION                        ', jmc$station],
      ['STATION_OPERATOR               ', jmc$station_operator],
      ['SWITCH1                        ', jmc$sense_switches],
      ['SWITCH2                        ', jmc$sense_switches],
      ['SWITCH3                        ', jmc$sense_switches],
      ['SWITCH4                        ', jmc$sense_switches],
      ['SWITCH5                        ', jmc$sense_switches],
      ['SWITCH6                        ', jmc$sense_switches],
      ['SWITCH7                        ', jmc$sense_switches],
      ['SWITCH8                        ', jmc$sense_switches],
      ['SYSTEM                         ', jmc$system_job],
      ['SYSTEM_FILE_NAME               ', jmc$system_file_name],
      ['SYSTEM_JOB                     ', jmc$system_job],
      ['SYSTEM_JOB_NAME                ', jmc$system_job_name],
      ['USER                           ', jmc$login_user],
      ['USER_FILE_NAME                 ', jmc$user_file_name ],
      ['USER_INFORMATION               ', jmc$user_information],
      ['USER_JOB_NAME                  ', jmc$user_job_name],
      ['VERTICAL_PRINT_DENSITY         ', jmc$vertical_print_density],
      ['VFU_LOAD_PROCEDURE             ', jmc$vfu_load_procedure]];
?? FMT (FORMAT := ON) ??
?? EJECT ??

{ PURPOSE:
{   The indexed_attribute_list is used for searching for attributes based on their attribute index.
{ All attributes are placed in this table.
{
{ NOTES:
{   This table MUST be in numerical order.

  CONST
    indexed_attribute_count = 137;

?? FMT (FORMAT := OFF) ??
  VAR
    indexed_attribute_list: [STATIC, READ, oss$job_paged_literal] array [1 ..
          indexed_attribute_count] of record
      attribute_index: jmt$attribute_keys,
      attribute_name: ost$name,
    recend := [
      [jmc$unknown_attribute          , unknown_attribute_name],
      [jmc$application_attributes_1   , 'APPLICATION_ATTRIBUTES_1'],
      [jmc$application_attributes_2   , 'APPLICATION_ATTRIBUTES_2'],
      [jmc$application_attributes_3   , 'APPLICATION_ATTRIBUTES_3'],
      [jmc$application_attributes_4   , 'APPLICATION_ATTRIBUTES_4'],
      [jmc$application_attributes_5   , 'APPLICATION_ATTRIBUTES_5'],
      [jmc$application_attributes_6   , 'APPLICATION_ATTRIBUTES_6'],
      [jmc$application_attributes_7   , 'APPLICATION_ATTRIBUTES_7'],
      [jmc$application_attributes_8   , 'APPLICATION_ATTRIBUTES_8'],
      [jmc$application_attributes_9   , 'APPLICATION_ATTRIBUTES_9'],
      [jmc$application_attributes_10  , 'APPLICATION_ATTRIBUTES_10'],
      [jmc$application_name           , 'APPLICATION_NAME'],
      [jmc$c170_os_type               , 'C170_OS_TYPE'],
      [jmc$client_mainframe_id        , 'CLIENT_MAINFRAME_IDENTIFIER'],
      [jmc$comment_banner             , 'COMMENT_BANNER'],
      [jmc$continue_request_to_servers, 'CONTINUE_REQUEST_TO_SERVERS'],
      [jmc$control_family             , 'CONTROL_FAMILY'],
      [jmc$control_user               , 'CONTROL_USER'],
      [jmc$copies                     , 'COPIES'],
      [jmc$copies_printed             , 'COPIES_PRINTED'],
      [jmc$cpu_time_limit             , 'CPU_TIME_LIMIT'],
      [jmc$cpu_time_used              , 'CPU_TIME_USED'],
      [jmc$cyclic_aging_interval      , 'CYCLIC_AGING_INTERVAL'],
      [jmc$data_declaration           , 'DATA_DECLARATION'],
      [jmc$data_mode                  , 'DATA_MODE'],
      [jmc$default_login_account      , 'DEFAULT_LOGIN_ACCOUNT'],
      [jmc$default_login_family       , 'DEFAULT_LOGIN_FAMILY'],
      [jmc$default_login_password     , 'DEFAULT_LOGIN_PASSWORD'],
      [jmc$default_login_project      , 'DEFAULT_LOGIN_PROJECT'],
      [jmc$default_login_user         , 'DEFAULT_LOGIN_USER'],
      [jmc$deferred_by_application    , 'DEFERRED_BY_APPLICATION'],
      [jmc$destination                , 'DESTINATION'],
      [jmc$detached_job_wait_time     , 'DETACHED_JOB_WAIT_TIME'],
      [jmc$device                     , 'DEVICE'],
      [jmc$device_type                , 'DEVICE_TYPE'],
      [jmc$dispatching_priority       , 'DISPATCHING_PRIORITY'],
      [jmc$display_message            , 'DISPLAY_MESSAGE'],
      [jmc$disposition_code           , 'DISPOSITION_CODE'],
      [jmc$earliest_print_time        , 'EARLIEST_PRINT_TIME'],
      [jmc$earliest_run_time          , 'EARLIEST_RUN_TIME'],
      [jmc$encrypted_password         , 'ENCRYPTED_PASSWORD'],
      [jmc$external_characteristics   , 'EXTERNAL_CHARACTERISTICS'],
      [jmc$file_position              , 'FILE_POSITION'],
      [jmc$file_size                  , 'FILE_SIZE'],
      [jmc$forms_code                 , 'FORMS_CODE'],
      [jmc$immediate_init_candidate   , 'IMMEDIATE_INITIATION_CANDIDATE'],
      [jmc$implicit_routing_text      , 'IMPLICIT_ROUTING_TEXT'],
      [jmc$input_file_location        , 'INPUT_FILE_LOCATION'],
      [jmc$internal_index             , 'INTERNAL_INDEX'],
      [jmc$job_abort_disposition      , 'JOB_ABORT_DISPOSITION'],
      [jmc$job_category_list          , 'JOB_CATEGORY_LIST'],
      [jmc$job_class                  , 'JOB_CLASS'],
      [jmc$job_class_list             , 'JOB_CLASS_LIST'],
      [jmc$job_class_position         , 'JOB_CLASS_POSITION'],
      [jmc$job_deferred_by_operator   , 'JOB_DEFERRED_BY_OPERATOR'],
      [jmc$job_deferred_by_user       , 'JOB_DEFERRED_BY_USER'],
      [jmc$job_destination_family     , 'JOB_DESTINATION_FAMILY'],
      [jmc$job_destination_usage      , 'JOB_DESTINATION_USAGE'],
      [jmc$job_execution_ring         , 'JOB_EXECUTION_RING'],
      [jmc$job_initiation_time        , 'JOB_INITIATION_TIME'],
      [jmc$job_input_device           , 'JOB_INPUT_DEVICE'],
      [jmc$job_mode                   , 'JOB_MODE'],
      [jmc$job_mode_set               , 'JOB_MODE_SET'],
      [jmc$job_priority               , 'JOB_PRIORITY'],
      [jmc$job_qualifier_list         , 'JOB_QUALIFIER_LIST'],
      [jmc$job_recovery_disposition   , 'JOB_RECOVERY_DISPOSITION'],
      [jmc$job_size                   , 'JOB_SIZE'],
      [jmc$job_state                  , 'JOB_STATE'],
      [jmc$job_state_set              , 'JOB_STATE_SET'],
      [jmc$job_submission_time        , 'JOB_SUBMISSION_TIME'],
      [jmc$latest_print_time          , 'LATEST_PRINT_TIME'],
      [jmc$latest_run_time            , 'LATEST_RUN_TIME'],
      [jmc$login_account              , 'LOGIN_ACCOUNT'],
      [jmc$login_command              , 'LOGIN_COMMAND'],
      [jmc$login_command_supplied     , 'LOGIN_COMMAND_SUPPLIED'],
      [jmc$login_family               , 'LOGIN_FAMILY'],
      [jmc$login_password             , 'LOGIN_PASSWORD'],
      [jmc$login_project              , 'LOGIN_PROJECT'],
      [jmc$login_user                 , 'LOGIN_USER'],
      [jmc$magnetic_tape_limit        , 'MAGNETIC_TAPE_LIMIT'],
      [jmc$maximum_working_set        , 'MAXIMUM_WORKING_SET'],
      [jmc$minimum_working_set        , 'MINIMUM_WORKING_SET'],
      [jmc$name_list                  , 'NAME_LIST'],
      [jmc$notify_on_terminate        , 'NOTIFY_ON_TERMINATE'],
      [jmc$null_attribute             , 'NULL_ATTRIBUTE'],
      [jmc$omit_class_validation      , 'OMIT_CLASS_VALIDATION'],
      [jmc$omit_user_prolog_and_epilog, 'OMIT_USER_PROLOG_AND_EPILOG'],
      [jmc$operator_action_posted     , 'OPERATOR_ACTION_POSTED'],
      [jmc$operator_job               , 'OPERATOR_JOB'],
      [jmc$optional_user_capability   , 'OPTIONAL_USER_CAPABILITY'],
      [jmc$origin_application_name    , 'ORIGINATING_APPLICATION_NAME'],
      [jmc$os_version                 , 'OS_VERSION'],
      [jmc$output_class               , 'OUTPUT_CLASS'],
      [jmc$output_deferred_by_operator, 'OUTPUT_DEFERRED_BY_OPERATOR'],
      [jmc$output_deferred_by_user    , 'OUTPUT_DEFERRED_BY_USER'],
      [jmc$output_destination         , 'OUTPUT_DESTINATION'],
      [jmc$output_destination_family  , 'OUTPUT_DESTINATION_FAMILY'],
      [jmc$output_destination_usage   , 'OUTPUT_DESTINATION_USAGE'],
      [jmc$output_disposition         , 'OUTPUT_DISPOSITION'],
      [jmc$output_priority            , 'OUTPUT_PRIORITY'],
      [jmc$output_state               , 'OUTPUT_STATE'],
      [jmc$output_state_set           , 'OUTPUT_STATE_SET'],
      [jmc$output_submission_time     , 'OUTPUT_SUBMISSION_TIME'],
      [jmc$page_aging_interval        , 'PAGE_AGING_INTERVAL'],
      [jmc$page_faults                , 'PAGE_FAULTS'],
      [jmc$processing_phase           , 'PROCESSING_PHASE'],
      [jmc$purge_delay                , 'PURGE_DELAY'],
      [jmc$qfile_state                , 'STATE'],
      [jmc$qfile_state_set            , 'QFILE_STATE_SET'],
      [jmc$recovery_disposition       , 'RECOVERY_DISPOSITION'],
      [jmc$remote_host_directive      , 'REMOTE_HOST_DIRECTIVE'],
      [jmc$reprint_disposition        , 'REPRINT_DISPOSITION'],
      [jmc$required_user_capability   , 'REQUIRED_USER_CAPABILITY'],
      [jmc$rerun_disposition          , 'RERUN_DISPOSITION'],
      [jmc$routing_banner             , 'ROUTING_BANNER'],
      [jmc$sense_switches             , 'SENSE_SWITCHES'],
      [jmc$server_mainframe_id        , 'SERVER_MAINFRAME_IDENTIFIER'],
      [jmc$service_class              , 'SERVICE_CLASS'],
      [jmc$site_information           , 'SITE_INFORMATION'],
      [jmc$source_logical_id          , 'SOURCE_LOGICAL_ID'],
      [jmc$sru_limit                  , 'SRU_LIMIT'],
      [jmc$station                    , 'STATION'],
      [jmc$station_operator           , 'STATION_OPERATOR'],
      [jmc$system_job                 , 'SYSTEM_JOB'],
      [jmc$system_job_parameters      , 'SYSTEM_JOB_PARAMETERS'],
      [jmc$system_file_name           , 'SYSTEM_FILE_NAME'],
      [jmc$system_job_name            , 'SYSTEM_JOB_NAME'],
      [jmc$system_routing_text        , 'SYSTEM_ROUTING_TEXT'],
      [jmc$system_supplied_name_list  , 'SYSTEM_SUPPLIED_NAME_LIST'],
      [jmc$terminate_job_action_set   , 'TERMINATE_JOB_ACTION_SET'],
      [jmc$termination_reason         , 'TERMINATION_REASON'],
      [jmc$user_file_name             , 'USER_FILE_NAME'],
      [jmc$user_information           , 'USER_INFORMATION'],
      [jmc$user_job_name              , 'USER_JOB_NAME'],
      [jmc$validation_ring            , 'VALIDATION_RING'],
      [jmc$vertical_print_density     , 'VERTICAL_PRINT_DENSITY'],
      [jmc$vfu_load_procedure         , 'VFU_LOAD_PROCEDURE']];
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
?? NEWTITLE := 'assign_function_value', EJECT ??

{ PURPOSE:
{   The purpose of this request is to assign a function value to a job management
{ SCL function.
{
{ DESIGN:
{   The interface accepts a pointer to one of the job management attribute types and
{ uses the jmt$attribute_value type (which is a superset of all of the job management
{ attribute types) to convert the value into the SCL function value.  This allows
{ a single procedure to assign all function values and only one copy of the value
{ assignment for each job management attribute is therefore required.

  PROCEDURE assign_function_value
    (    generic_attribute_value_p: ^cell;
         attribute_name: string ( * <= osc$max_name_size);
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    VAR
      attribute_value_p: ^jmt$attribute_value,
      index: ost$non_negative_integers,
      job_qualifier_exists: boolean,
      node: ^clt$data_value,
      scl_name: ost$name,
      string_size: ost$string_size;

    VAR
      c170_os_types: [STATIC, READ, oss$job_paged_literal] array [ost$170_os_type] of string (6) := ['NONE',
            'NOS', 'NOS/BE'],
      data_mode: [STATIC, READ, oss$job_paged_literal] array [jmt$data_mode] of string (13) := ['CODED',
            'RHF_STRUCTURE', 'TRANSPARENT'],
      device_type: [STATIC, READ, oss$job_paged_literal] array [jmt$output_device_type] of string (7) :=
            ['PRINTER', 'PLOTTER', 'PUNCH'],
      input_file_location: [STATIC, READ, oss$job_paged_literal] array
            [jmc$ifl_no_input_file_exists .. jmc$ifl_login_family_queue] of string (23) :=
            ['NO_INPUT_FILE_EXISTS', 'SYSTEM_INPUT_QUEUE', 'STORE_AND_FORWARD_QUEUE', 'LOGIN_FAMILY_QUEUE'],
      job_abort_disposition: [STATIC, READ, oss$job_paged_literal] array [jmt$job_abort_disposition] of
            string (9) := ['RESTART', 'TERMINATE'],
      job_modes: [STATIC, READ, oss$job_paged_literal] array [jmt$job_mode] of string (30) := ['BATCH',
            'INTERACTIVE', 'INTERACTIVE_COMMAND_DISCONNECT', 'INTERACTIVE_LINE_DISCONNECT',
            'INTERACTIVE_SYSTEM_DISCONNECT'],
      job_recovery_disposition: [STATIC, READ, oss$job_paged_literal] array [jmt$job_recovery_disposition] of
            string (9) := ['CONTINUE', 'RESTART', 'TERMINATE'],
      job_state: [STATIC, READ, oss$job_paged_literal] array [jmt$job_state] of string (10) := ['DEFERRED',
            'QUEUED', 'INITIATED', 'TERMINATED', 'COMPLETED'],
      output_disposition: [STATIC, READ, oss$job_paged_literal] array [jmt$output_disposition_keys] of
            string (23) := ['DISCARD_ALL_OUTPUT', 'DISCARD_STANDARD_OUTPUT', 'LOCAL', 'PRINTER',
            'STANDARD_OUTPUT', 'WAIT_QUEUE'],
      output_state: [STATIC, READ, oss$job_paged_literal] array [jmt$output_state] of string (10) :=
            ['DEFERRED', 'QUEUED', 'INITIATED', 'TERMINATED', 'COMPLETED'],
      phases: [STATIC, READ, oss$job_paged_literal] array [clt$processing_phase] of string (20) :=
            ['JOB_BEGIN_PHASE', 'SYSTEM_PROLOG_PHASE', 'CLASS_PROLOG_PHASE', 'ACCOUNT_PROLOG_PHASE',
            'PROJECT_PROLOG_PHASE', 'MEMBER_PROLOG_PHASE', 'USER_PROLOG_PHASE', 'COMMAND_PHASE',
            'USER_EPILOG_PHASE', 'MEMBER_EPILOG_PHASE', 'PROJECT_EPILOG_PHASE', 'ACCOUNT_EPILOG_PHASE',
            'CLASS_EPILOG_PHASE', 'SYSTEM_EPILOG_PHASE', 'JOB_END_PHASE'],
      qfile_state: [STATIC, READ, oss$job_paged_literal] array [jmt$qfile_state] of string (10) :=
            ['DEFERRED', 'QUEUED', 'INITIATED', 'TERMINATED', 'COMPLETED'],
      vertical_print_density: [STATIC, READ, oss$job_paged_literal] array [jmt$vertical_print_density] of
            string (6) := ['FILE', 'NONE', 'SIX', 'SEVEN', 'EIGHT', 'NINE', 'TEN', 'ELEVEN', 'TWELVE'];

?? NEWTITLE := 'make_date_time_value', EJECT ??

    PROCEDURE [INLINE] make_date_time_value
      (    date_time: ost$date_time;
       VAR work_area { input, output } : ^clt$work_area;
       VAR result: ^clt$data_value);

      VAR
        scl_date_time: clt$date_time;

      scl_date_time.value := date_time;
      scl_date_time.date_specified := TRUE;
      scl_date_time.time_specified := TRUE;
      clp$make_date_time_value (scl_date_time, work_area, result);
    PROCEND make_date_time_value;
?? OLDTITLE ??
?? NEWTITLE := 'make_trimmed_string_value', EJECT ??

    PROCEDURE [INLINE] make_trimmed_string_value
      (    string_value: string ( * );
       VAR work_area { input, output } : ^clt$work_area;
       VAR result: ^clt$data_value);

      clp$make_string_value (string_value (1, clp$trimmed_string_size (string_value)), work_area, result);
    PROCEND make_trimmed_string_value;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    attribute_value_p := generic_attribute_value_p;
    CASE attribute_value_p^.key OF
    = jmc$c170_os_type =
      make_trimmed_string_value (c170_os_types [attribute_value_p^.c170_os_type], work_area, result);

    = jmc$client_mainframe_id =
      IF attribute_value_p^.client_mainframe_id = '' THEN
        clp$make_name_value (none, work_area, result);
      ELSE
        clp$make_name_value (attribute_value_p^.client_mainframe_id, work_area, result);
      IFEND;

    = jmc$comment_banner =
      make_trimmed_string_value (attribute_value_p^.comment_banner, work_area, result);

    = jmc$control_family =
      clp$make_name_value (attribute_value_p^.control_family, work_area, result);

    = jmc$control_user =
      clp$make_name_value (attribute_value_p^.control_user, work_area, result);

    = jmc$copies =
      clp$make_integer_value (attribute_value_p^.copies, { radix } 10, { radix_specified } FALSE, work_area,
            result);

    = jmc$copies_printed =
      clp$make_integer_value (attribute_value_p^.copies_printed, { radix } 10, { radix_specified } FALSE,
            work_area, result);

    = jmc$cpu_time_limit =
      IF attribute_value_p^.cpu_time_limit <= jmc$highest_cpu_time_limit THEN
        clp$make_integer_value (attribute_value_p^.cpu_time_limit, { radix } 10, { radix_specified } FALSE,
              work_area, result);
      ELSE
        IF attribute_value_p^.cpu_time_limit = jmc$unlimited_cpu_time_limit THEN
          scl_name := 'UNLIMITED';
        ELSE { IF attribute_value_p^.cpu_time_limit = jmc$required_cpu_time_limit THEN
          scl_name := 'REQUIRED';
        IFEND;
        clp$make_name_value (scl_name, work_area, result);
      IFEND;

    = jmc$cpu_time_used =
      IF attribute_name = 'JOB_MODE_CPU_TIME' THEN
        clp$make_integer_value (attribute_value_p^.cpu_time_used.job_mode_time, { radix } 10,
              { radix_specified } FALSE, work_area, result);
      ELSE { IF attribute_name = 'MONITOR_MODE_CPU_TIME' THEN
        clp$make_integer_value (attribute_value_p^.cpu_time_used.monitor_mode_time, { radix } 10,
              { radix_specified } FALSE, work_area, result);
      IFEND;

    = jmc$cyclic_aging_interval =
      clp$make_integer_value (attribute_value_p^.cyclic_aging_interval, { radix } 10,
            { radix_specified } FALSE, work_area, result);

    = jmc$data_declaration =
      make_trimmed_string_value (attribute_value_p^.data_declaration, work_area, result);

    = jmc$data_mode =
      clp$make_name_value (data_mode [attribute_value_p^.data_mode], work_area, result);

    = jmc$detached_job_wait_time =
      IF attribute_value_p^.detached_job_wait_time <= jmc$highest_det_job_wait_time THEN
        clp$make_integer_value (attribute_value_p^.detached_job_wait_time, { radix } 10,
              { radix_specified } FALSE, work_area, result);
      ELSE
        clp$make_name_value ('UNLIMITED', work_area, result);
      IFEND;

    = jmc$device =
      clp$make_name_value (attribute_value_p^.device, work_area, result);

    = jmc$device_type =
      clp$make_name_value (device_type [attribute_value_p^.device_type], work_area, result);

    = jmc$display_message =
      clp$make_string_value (attribute_value_p^.display_message^.
            value (1, attribute_value_p^.display_message^.size), work_area, result);

    = jmc$dispatching_priority =
      clp$make_name_value (attribute_value_p^.dispatching_priority, work_area, result);

    = jmc$earliest_print_time =
      IF attribute_value_p^.earliest_print_time.specified THEN
        make_date_time_value (attribute_value_p^.earliest_print_time.date_time, work_area, result);
      ELSE
        clp$make_name_value (none, work_area, result);
      IFEND;

    = jmc$earliest_run_time =
      IF attribute_value_p^.earliest_run_time.specified THEN
        make_date_time_value (attribute_value_p^.earliest_run_time.date_time, work_area, result);
      ELSE
        clp$make_name_value (none, work_area, result);
      IFEND;

    = jmc$external_characteristics =
      make_trimmed_string_value (attribute_value_p^.external_characteristics, work_area, result);

    = jmc$file_position =
      clp$make_integer_value (attribute_value_p^.file_position, { radix } 10, { radix_specified } FALSE,
            work_area, result);

    = jmc$file_size =
      clp$make_integer_value (attribute_value_p^.file_size, { radix } 10, { radix_specified } FALSE,
            work_area, result);

    = jmc$forms_code =
      make_trimmed_string_value (attribute_value_p^.forms_code, work_area, result);

    = jmc$input_file_location =
      clp$make_name_value (input_file_location [attribute_value_p^.input_file_location], work_area, result);

    = jmc$job_abort_disposition =
      clp$make_name_value (job_abort_disposition [attribute_value_p^.job_abort_disposition], work_area,
            result);

    = jmc$job_class =
      IF attribute_value_p^.job_class = osc$null_name THEN
        clp$make_name_value ('NONE', work_area, result);
      ELSE
        clp$make_name_value (attribute_value_p^.job_class, work_area, result);
      IFEND;

    = jmc$job_class_position =
      IF attribute_value_p^.job_class_position = 0 THEN
        clp$make_name_value (none, work_area, result);
      ELSE
        clp$make_integer_value (attribute_value_p^.job_class_position, { radix } 10,
              { radix_specified } FALSE, work_area, result);
      IFEND;

    = jmc$job_deferred_by_operator =
      clp$make_boolean_value (attribute_value_p^.job_deferred_by_operator, clc$yes_no_boolean, work_area,
            result);

    = jmc$job_deferred_by_user =
      clp$make_boolean_value (attribute_value_p^.job_deferred_by_user, clc$yes_no_boolean, work_area, result);

    = jmc$job_destination_family =
      make_trimmed_string_value (attribute_value_p^.job_destination_family, work_area, result);

    = jmc$job_destination_usage =
      clp$make_name_value (attribute_value_p^.job_destination_usage, work_area, result);

    = jmc$job_execution_ring =
      IF attribute_value_p^.job_execution_ring = osc$invalid_ring THEN
        clp$make_name_value ('NOMINAL', work_area, result);
      ELSE
        clp$make_integer_value (attribute_value_p^.job_execution_ring, { radix } 10,
              { radix_specified } FALSE, work_area, result);
      IFEND;

    = jmc$job_initiation_time =
      IF attribute_value_p^.job_initiation_time.specified THEN
        make_date_time_value (attribute_value_p^.job_initiation_time.date_time, work_area, result);
      ELSE
        clp$make_name_value (none, work_area, result);
      IFEND;

    = jmc$job_mode =
      IF attribute_name = 'MODE' THEN
        make_trimmed_string_value (job_modes [attribute_value_p^.job_mode], work_area, result);
      ELSE
        clp$make_name_value (job_modes [attribute_value_p^.job_mode], work_area, result);
      IFEND;

    = jmc$job_qualifier_list =

    /generate_job_qualifier_list/
      BEGIN
        clp$make_list_value (work_area, result);
        IF result = NIL THEN
          EXIT /generate_job_qualifier_list/;
        IFEND;
        job_qualifier_exists := FALSE;
        node := result;
        FOR index := 1 TO UPPERBOUND (attribute_value_p^.job_qualifier_list^) DO
          IF attribute_value_p^.job_qualifier_list^ [index] <> osc$null_name THEN
            IF job_qualifier_exists THEN
              clp$make_list_value (work_area, node^.link);
              IF node^.link = NIL THEN
                result := NIL;
                EXIT /generate_job_qualifier_list/;
              ELSE
                node := node^.link;
              IFEND;
            ELSE
              job_qualifier_exists := TRUE;
            IFEND;
            clp$make_name_value (attribute_value_p^.job_qualifier_list^ [index], work_area,
                  node^.element_value);
            IF node^.element_value = NIL THEN
              result := NIL;
              EXIT /generate_job_qualifier_list/;
            IFEND;
          IFEND;
        FOREND;
        IF NOT job_qualifier_exists THEN
          clp$make_name_value (none, work_area, result^.element_value);
          IF result^.element_value = NIL THEN
            result := NIL;
          IFEND;
        IFEND;
      END /generate_job_qualifier_list/;

    = jmc$job_recovery_disposition =
      clp$make_name_value (job_recovery_disposition [attribute_value_p^.job_recovery_disposition], work_area,
            result);

    = jmc$job_size =
      clp$make_integer_value (attribute_value_p^.job_size, { radix } 10, { radix_specified } FALSE, work_area,
            result);

    = jmc$job_state =
      clp$make_name_value (job_state [attribute_value_p^.job_state], work_area, result);

    = jmc$job_submission_time =
      make_date_time_value (attribute_value_p^.job_submission_time, work_area, result);

    = jmc$latest_print_time =
      IF attribute_value_p^.latest_print_time.specified THEN
        make_date_time_value (attribute_value_p^.latest_print_time.date_time, work_area, result);
      ELSE
        clp$make_name_value (none, work_area, result);
      IFEND;

    = jmc$latest_run_time =
      IF attribute_value_p^.latest_run_time.specified THEN
        make_date_time_value (attribute_value_p^.latest_run_time.date_time, work_area, result);
      ELSE
        clp$make_name_value (none, work_area, result);
      IFEND;

    = jmc$login_account =
      IF attribute_name = 'ACCOUNT' THEN
        make_trimmed_string_value (attribute_value_p^.login_account, work_area, result);
      ELSE
        IF attribute_value_p^.login_account = osc$null_name THEN
          clp$make_name_value ('NONE', work_area, result);
        ELSE
          clp$make_name_value (attribute_value_p^.login_account, work_area, result);
        IFEND;
      IFEND;

    = jmc$login_family =
      IF attribute_name = 'FAMILY_NAME' THEN
        make_trimmed_string_value (attribute_value_p^.login_family, work_area, result);
      ELSE
        IF attribute_value_p^.login_family = osc$null_name THEN
          clp$make_name_value ('NONE', work_area, result);
        ELSE
          clp$make_name_value (attribute_value_p^.login_family, work_area, result);
        IFEND;
      IFEND;

    = jmc$login_project =
      IF attribute_name = 'PROJECT' THEN
        make_trimmed_string_value (attribute_value_p^.login_project, work_area, result);
      ELSE
        IF attribute_value_p^.login_project = osc$null_name THEN
          clp$make_name_value ('NONE', work_area, result);
        ELSE
          clp$make_name_value (attribute_value_p^.login_project, work_area, result);
        IFEND;
      IFEND;

    = jmc$login_user =
      IF attribute_name = 'USER' THEN
        make_trimmed_string_value (attribute_value_p^.login_user, work_area, result);
      ELSE
        IF attribute_value_p^.login_user = osc$null_name THEN
          clp$make_name_value ('NONE', work_area, result);
        ELSE
          clp$make_name_value (attribute_value_p^.login_user, work_area, result);
        IFEND;
      IFEND;

    = jmc$magnetic_tape_limit =
      IF attribute_value_p^.magnetic_tape_limit <= jmc$highest_magnetic_tape_limit THEN
        clp$make_integer_value (attribute_value_p^.magnetic_tape_limit, { radix } 10,
              { radix_specified } FALSE, work_area, result);
      ELSE
        IF attribute_value_p^.magnetic_tape_limit = jmc$unlimited_mag_tape_limit THEN
          scl_name := 'UNLIMITED';
        ELSEIF attribute_value_p^.magnetic_tape_limit = jmc$unspecified_mag_tape_limit THEN
          scl_name := 'UNSPECIFIED';
        ELSE { IF attribute_value_p^ .magnetic_tape_limit = jmc$required_mag_tape_limit THEN
          scl_name := 'REQUIRED';
        IFEND;
        clp$make_name_value (scl_name, work_area, result);
      IFEND;

    = jmc$maximum_working_set =
      IF attribute_value_p^.maximum_working_set <= jmc$highest_working_set_size THEN
        clp$make_integer_value (attribute_value_p^.maximum_working_set, { radix } 10,
              { radix_specified } FALSE, work_area, result);
      ELSE
        IF attribute_value_p^.maximum_working_set = jmc$unlimited_working_set_size THEN
          scl_name := 'UNLIMITED';
        ELSE { IF attribute_value_p^ .maximum_working_set = jmc$required_working_set_size THEN
          scl_name := 'REQUIRED';
        IFEND;
        clp$make_name_value (scl_name, work_area, result);
      IFEND;

    = jmc$minimum_working_set =
      clp$make_integer_value (attribute_value_p^.minimum_working_set, { radix } 10, { radix_specified } FALSE,
            work_area, result);

    = jmc$operator_action_posted =
      clp$make_boolean_value (attribute_value_p^.operator_action_posted, clc$yes_no_boolean, work_area,
            result);

    = jmc$operator_job =
      clp$make_boolean_value (attribute_value_p^.operator_job, clc$yes_no_boolean, work_area, result);

    = jmc$origin_application_name =
      clp$make_name_value (attribute_value_p^.origin_application_name, work_area, result);

    = jmc$os_version =
      make_trimmed_string_value (attribute_value_p^.os_version, work_area, result);

    = jmc$output_class =
      string_size := clp$trimmed_string_size (attribute_value_p^.output_class);
      IF string_size > 0 THEN
        scl_name := attribute_value_p^.output_class;
      ELSE
        scl_name := none;
      IFEND;
      clp$make_name_value (scl_name, work_area, result);

    = jmc$output_deferred_by_operator =
      clp$make_boolean_value (attribute_value_p^.output_deferred_by_operator, clc$yes_no_boolean, work_area,
            result);

    = jmc$output_deferred_by_user =
      clp$make_boolean_value (attribute_value_p^.output_deferred_by_user, clc$yes_no_boolean, work_area,
            result);

    = jmc$output_destination =
      make_trimmed_string_value (attribute_value_p^.output_destination, work_area, result);

    = jmc$output_destination_family =
      clp$make_name_value (attribute_value_p^.output_destination_family, work_area, result);

    = jmc$output_destination_usage =
      clp$make_name_value (attribute_value_p^.output_destination_usage, work_area, result);

    = jmc$output_disposition =
      IF attribute_value_p^.output_disposition.key = jmc$standard_output_path THEN

        clp$make_file_value (attribute_value_p^.output_disposition.standard_output_path^, work_area, result);
      ELSE
        clp$make_name_value (output_disposition [attribute_value_p^.output_disposition.key], work_area,
              result);
      IFEND;

    = jmc$output_priority =
      string_size := clp$trimmed_string_size (attribute_value_p^.output_priority);
      IF string_size > 0 THEN
        scl_name := attribute_value_p^.output_priority;
      ELSE
        scl_name := none;
      IFEND;
      clp$make_name_value (scl_name, work_area, result);

    = jmc$output_state =
      clp$make_name_value (output_state [attribute_value_p^.output_state], work_area, result);

    = jmc$output_submission_time =
      make_date_time_value (attribute_value_p^.output_submission_time, work_area, result);

    = jmc$page_aging_interval =
      clp$make_integer_value (attribute_value_p^.page_aging_interval, { radix } 10, { radix_specified } FALSE,
            work_area, result);

    = jmc$page_faults =
      IF attribute_name = 'PAGES_ASSIGNED' THEN
        clp$make_integer_value (attribute_value_p^.page_faults.new_pages_assigned, { radix } 10,
              { radix_specified } FALSE, work_area, result);
      ELSEIF attribute_name = 'PAGES_FROM_DISK' THEN
        clp$make_integer_value (attribute_value_p^.page_faults.pages_read_from_disk, { radix } 10,
              { radix_specified } FALSE, work_area, result);
      ELSE { IF attribute_name = 'PAGES_RECLAIMED' THEN
        clp$make_integer_value (attribute_value_p^.page_faults.pages_reclaimed_from_memory, { radix } 10,
              { radix_specified } FALSE, work_area, result);
      IFEND;

    = jmc$processing_phase =
      IF attribute_name = 'PROCESSING_PHASE' THEN
        make_trimmed_string_value (phases [translated_processing_phase (attribute_value_p^.processing_phase)],
              work_area, result);
      ELSE
        clp$make_name_value (phases [translated_processing_phase (attribute_value_p^.processing_phase)],
              work_area, result);
      IFEND;

    = jmc$purge_delay =
      IF attribute_value_p^.purge_delay^.specified THEN
        clp$make_time_increment_value (^attribute_value_p^.purge_delay^.time_increment, work_area, result);
      ELSE
        clp$make_name_value (none, work_area, result);
      IFEND;

    = jmc$remote_host_directive =
      clp$make_string_value (attribute_value_p^.remote_host_directive^.
            parameters (1, attribute_value_p^.remote_host_directive^.size), work_area, result);

    = jmc$routing_banner =
      make_trimmed_string_value (attribute_value_p^.routing_banner, work_area, result);

    = jmc$sense_switches =
      clp$make_boolean_value (($INTEGER (attribute_name (7)) - $INTEGER ('0')) IN
            attribute_value_p^.sense_switches, clc$on_off_boolean, work_area, result);

    = jmc$server_mainframe_id =
      IF attribute_value_p^.server_mainframe_id = '' THEN
        clp$make_name_value (none, work_area, result);
      ELSE
        clp$make_name_value (attribute_value_p^.server_mainframe_id, work_area, result);
      IFEND;

    = jmc$service_class =
      clp$make_name_value (attribute_value_p^.service_class, work_area, result);

    = jmc$site_information =
      make_trimmed_string_value (attribute_value_p^.site_information^, work_area, result);

    = jmc$source_logical_id =
      make_trimmed_string_value (attribute_value_p^.source_logical_id, work_area, result);

    = jmc$sru_limit =
      IF attribute_value_p^.sru_limit <= jmc$highest_sru_limit THEN
        clp$make_integer_value (attribute_value_p^.sru_limit, { radix } 10, { radix_specified } FALSE,
              work_area, result);
      ELSE
        IF attribute_value_p^.sru_limit = jmc$unlimited_sru_limit THEN
          scl_name := 'UNLIMITED';
        ELSE { IF attribute_value_p^ .sru_limit = jmc$required_sru_limit THEN
          scl_name := 'REQUIRED';
        IFEND;
        clp$make_name_value (scl_name, work_area, result);
      IFEND;

    = jmc$station =
      clp$make_name_value (attribute_value_p^.station, work_area, result);

    = jmc$station_operator =
      clp$make_name_value (attribute_value_p^.station_operator, work_area, result);

    = jmc$system_file_name =
      clp$make_name_value (attribute_value_p^.system_file_name, work_area, result);

    = jmc$system_job =
      clp$make_boolean_value (attribute_value_p^.system_job, clc$yes_no_boolean, work_area, result);

    = jmc$system_job_name =
      clp$make_name_value (attribute_value_p^.system_job_name, work_area, result);

    = jmc$user_file_name =
      clp$make_name_value (attribute_value_p^.user_file_name, work_area, result);

    = jmc$user_information =
      make_trimmed_string_value (attribute_value_p^.user_information^, work_area, result);

    = jmc$user_job_name =
      IF attribute_name = 'JOB_NAME' THEN
        make_trimmed_string_value (attribute_value_p^.user_job_name, work_area, result);
      ELSE { USER_JOB_NAME
        IF attribute_value_p^.user_job_name = osc$null_name THEN
          clp$make_name_value (none, work_area, result);
        ELSE
          clp$make_name_value (attribute_value_p^.user_job_name, work_area, result);
        IFEND;
      IFEND;

    = jmc$vertical_print_density =
      clp$make_name_value (vertical_print_density [attribute_value_p^.vertical_print_density], work_area,
            result);

    = jmc$vfu_load_procedure =
      string_size := clp$trimmed_string_size (attribute_value_p^.vfu_load_procedure);
      IF string_size > 0 THEN
        scl_name := attribute_value_p^.vfu_load_procedure;
      ELSE
        scl_name := none;
      IFEND;
      clp$make_name_value (scl_name, work_area, result);

    ELSE
      ;
    CASEND;

    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;
  PROCEND assign_function_value;
?? OLDTITLE ??
?? NEWTITLE := 'translated_processing_phase', EJECT ??

  FUNCTION translated_processing_phase
    (    job_processing_phase: jmt$job_processing_phase): clt$processing_phase;

    VAR
      processing_phase: [STATIC, READ, oss$job_paged_literal] array [clt$processing_phase] of
            jmt$job_processing_phase := [jmc$jpp_job_begin_phase, jmc$jpp_system_prolog_phase,
            jmc$jpp_class_prolog_phase, jmc$jpp_account_prolog_phase, jmc$jpp_project_prolog_phase,
            jmc$jpp_member_prolog_phase, jmc$jpp_user_prolog_phase, jmc$jpp_command_phase,
            jmc$jpp_user_epilog_phase, jmc$jpp_member_epilog_phase, jmc$jpp_project_epilog_phase,
            jmc$jpp_account_epilog_phase, jmc$jpp_class_epilog_phase, jmc$jpp_system_epilog_phase,
            jmc$jpp_job_end_phase];

    VAR
      processing_phase_index: clt$processing_phase;

    FOR processing_phase_index := LOWERVALUE (processing_phase_index)
          TO UPPERVALUE (processing_phase_index) DO
      IF processing_phase [processing_phase_index] = job_processing_phase THEN
        translated_processing_phase := processing_phase_index;
        RETURN;
      IFEND;
    FOREND;
  FUNCEND translated_processing_phase;
?? OLDTITLE ??
?? NEWTITLE := 'jmp$$job', EJECT ??

  PROCEDURE [XDCL] jmp$$job
    (    parameter_list: clt$parameter_list;
     VAR work_area { input, output } : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);


{ FUNCTION (osm$$job) $job (
{   attribute: key
{       (comment_banner, cb)
{       (control_family, cf)
{       (control_user, cu)
{       (copies, c)
{       (cyclic_aging_interval, cai)
{       (detached_job_wait_time, djwt)
{       (device, d)
{       (dispatching_priority, dp)
{       (earliest_print_time, ept)
{       (earliest_run_time, ert)
{       (external_characteristics, ec)
{       (forms_code, fc)
{       (job_abort_disposition, jad)
{       (job_class, jc)
{       (job_mode, jm)
{       (job_processing_phase, jpp)
{       (job_qualifier, job_qualifiers, jq)
{       (job_recovery_disposition, jrd)
{       (job_size, js)
{       (job_submission_time, jst)
{       (latest_print_time, lpt)
{       (latest_run_time, lrt)
{       (login_account, la)
{       (login_family, lf)
{       (login_project, lp)
{       (login_user, lu)
{       (maximum_working_set, maxws)
{       (minimum_working_set, minws)
{       (operator_family, of)
{       (operator_user, ou)
{       (originating_application_name, oan)
{       (output_class, oc)
{       (output_deferred_by_user, odbu)
{       (output_destination, ode)
{       (output_destination_usage, odu)
{       (output_disposition, odi)
{       (output_priority, op)
{       (page_aging_interval, pai)
{       (purge_delay, pd)
{       (remote_host_directive, rhd)
{       (routing_banner, rb)
{       (service_class, sc)
{       (site_information, si)
{       (station, s)
{       switch1, switch2, switch3, switch4, switch5, switch6, switch7, switch8, system
{       (system_job_name, sjn)
{       (user_information, ui)
{       (user_job_name, ujn)
{       (vertical_print_density, vpd)
{       (vfu_load_procedure, vlp)
{     hidden_key
{       c170_os_type
{       (mode, m)
{       job_name, account, family_name, project, user
{       (destination_family, df)
{       (station_operator, so)
{       os_version
{       (destination_usage, du)
{       (operator, o)
{       processing_phase
{       (dual_state_route_parameters, dsrp)
{     keyend = $required
{   )

?? PUSH (LISTEXT := ON) ??

    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$keyword_type_qualifier,
          keyword_specs: array [1 .. 128] of clt$keyword_specification,
        recend,
      recend := [[1, [88, 6, 20, 21, 56, 3, 425], clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$JOB'],
            [['ATTRIBUTE                      ', 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, 4743, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$keyword_type], [128], [['ACCOUNT                        ', clc$nominal_entry,
            clc$hidden_entry, 62], ['C                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['C170_OS_TYPE                   ', clc$nominal_entry,
            clc$hidden_entry, 59], ['CAI                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['CB                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['CF                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['COMMENT_BANNER                 ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['CONTROL_FAMILY                 ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['CONTROL_USER                   ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['COPIES                         ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['CU                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['CYCLIC_AGING_INTERVAL          ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['D                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['DESTINATION_FAMILY             ', clc$nominal_entry,
            clc$hidden_entry, 66], ['DESTINATION_USAGE              ', clc$nominal_entry, clc$hidden_entry,
            69], ['DETACHED_JOB_WAIT_TIME         ', clc$nominal_entry, clc$normal_usage_entry, 6],
            ['DEVICE                         ', clc$nominal_entry, clc$normal_usage_entry, 7],
            ['DF                             ', clc$abbreviation_entry, clc$hidden_entry, 66],
            ['DISPATCHING_PRIORITY           ', clc$nominal_entry, clc$normal_usage_entry, 8],
            ['DJWT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
            ['DP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
            ['DSRP                           ', clc$abbreviation_entry, clc$hidden_entry, 72],
            ['DU                             ', clc$abbreviation_entry, clc$hidden_entry, 69],
            ['DUAL_STATE_ROUTE_PARAMETERS    ', clc$nominal_entry, clc$hidden_entry, 72],
            ['EARLIEST_PRINT_TIME            ', clc$nominal_entry, clc$normal_usage_entry, 9],
            ['EARLIEST_RUN_TIME              ', clc$nominal_entry, clc$normal_usage_entry, 10],
            ['EC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
            ['EPT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
            ['ERT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
            ['EXTERNAL_CHARACTERISTICS       ', clc$nominal_entry, clc$normal_usage_entry, 11],
            ['FAMILY_NAME                    ', clc$nominal_entry, clc$hidden_entry, 63],
            ['FC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
            ['FORMS_CODE                     ', clc$nominal_entry, clc$normal_usage_entry, 12],
            ['JAD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
            ['JC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
            ['JM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
            ['JOB_ABORT_DISPOSITION          ', clc$nominal_entry, clc$normal_usage_entry, 13],
            ['JOB_CLASS                      ', clc$nominal_entry, clc$normal_usage_entry, 14],
            ['JOB_MODE                       ', clc$nominal_entry, clc$normal_usage_entry, 15],
            ['JOB_NAME                       ', clc$nominal_entry, clc$hidden_entry, 61],
            ['JOB_PROCESSING_PHASE           ', clc$nominal_entry, clc$normal_usage_entry, 16],
            ['JOB_QUALIFIER                  ', clc$nominal_entry, clc$normal_usage_entry, 17],
            ['JOB_QUALIFIERS                 ', clc$alias_entry, clc$normal_usage_entry, 17],
            ['JOB_RECOVERY_DISPOSITION       ', clc$nominal_entry, clc$normal_usage_entry, 18],
            ['JOB_SIZE                       ', clc$nominal_entry, clc$normal_usage_entry, 19],
            ['JOB_SUBMISSION_TIME            ', clc$nominal_entry, clc$normal_usage_entry, 20],
            ['JPP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
            ['JQ                             ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
            ['JRD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
            ['JS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
            ['JST                            ', clc$abbreviation_entry, clc$normal_usage_entry, 20],
            ['LA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 23],
            ['LATEST_PRINT_TIME              ', clc$nominal_entry, clc$normal_usage_entry, 21],
            ['LATEST_RUN_TIME                ', clc$nominal_entry, clc$normal_usage_entry, 22],
            ['LF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 24],
            ['LOGIN_ACCOUNT                  ', clc$nominal_entry, clc$normal_usage_entry, 23],
            ['LOGIN_FAMILY                   ', clc$nominal_entry, clc$normal_usage_entry, 24],
            ['LOGIN_PROJECT                  ', clc$nominal_entry, clc$normal_usage_entry, 25],
            ['LOGIN_USER                     ', clc$nominal_entry, clc$normal_usage_entry, 26],
            ['LP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 25],
            ['LPT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 21],
            ['LRT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 22],
            ['LU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 26],
            ['M                              ', clc$abbreviation_entry, clc$hidden_entry, 60],
            ['MAXIMUM_WORKING_SET            ', clc$nominal_entry, clc$normal_usage_entry, 27],
            ['MAXWS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 27],
            ['MINIMUM_WORKING_SET            ', clc$nominal_entry, clc$normal_usage_entry, 28],
            ['MINWS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 28],
            ['MODE                           ', clc$nominal_entry, clc$hidden_entry, 60],
            ['O                              ', clc$abbreviation_entry, clc$hidden_entry, 70],
            ['OAN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 31],
            ['OC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 32],
            ['ODBU                           ', clc$abbreviation_entry, clc$normal_usage_entry, 33],
            ['ODE                            ', clc$abbreviation_entry, clc$normal_usage_entry, 34],
            ['ODI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 36],
            ['ODU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 35],
            ['OF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 29],
            ['OP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 37],
            ['OPERATOR                       ', clc$nominal_entry, clc$hidden_entry, 70],
            ['OPERATOR_FAMILY                ', clc$nominal_entry, clc$normal_usage_entry, 29],
            ['OPERATOR_USER                  ', clc$nominal_entry, clc$normal_usage_entry, 30],
            ['ORIGINATING_APPLICATION_NAME   ', clc$nominal_entry, clc$normal_usage_entry, 31],
            ['OS_VERSION                     ', clc$nominal_entry, clc$hidden_entry, 68],
            ['OU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 30],
            ['OUTPUT_CLASS                   ', clc$nominal_entry, clc$normal_usage_entry, 32],
            ['OUTPUT_DEFERRED_BY_USER        ', clc$nominal_entry, clc$normal_usage_entry, 33],
            ['OUTPUT_DESTINATION             ', clc$nominal_entry, clc$normal_usage_entry, 34],
            ['OUTPUT_DESTINATION_USAGE       ', clc$nominal_entry, clc$normal_usage_entry, 35],
            ['OUTPUT_DISPOSITION             ', clc$nominal_entry, clc$normal_usage_entry, 36],
            ['OUTPUT_PRIORITY                ', clc$nominal_entry, clc$normal_usage_entry, 37],
            ['PAGE_AGING_INTERVAL            ', clc$nominal_entry, clc$normal_usage_entry, 38],
            ['PAI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 38],
            ['PD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 39],
            ['PROCESSING_PHASE               ', clc$nominal_entry, clc$hidden_entry, 71],
            ['PROJECT                        ', clc$nominal_entry, clc$hidden_entry, 64],
            ['PURGE_DELAY                    ', clc$nominal_entry, clc$normal_usage_entry, 39],
            ['RB                             ', clc$abbreviation_entry, clc$normal_usage_entry, 41],
            ['REMOTE_HOST_DIRECTIVE          ', clc$nominal_entry, clc$normal_usage_entry, 40],
            ['RHD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 40],
            ['ROUTING_BANNER                 ', clc$nominal_entry, clc$normal_usage_entry, 41],
            ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 44],
            ['SC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 42],
            ['SERVICE_CLASS                  ', clc$nominal_entry, clc$normal_usage_entry, 42],
            ['SI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 43],
            ['SITE_INFORMATION               ', clc$nominal_entry, clc$normal_usage_entry, 43],
            ['SJN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 54],
            ['SO                             ', clc$abbreviation_entry, clc$hidden_entry, 67],
            ['STATION                        ', clc$nominal_entry, clc$normal_usage_entry, 44],
            ['STATION_OPERATOR               ', clc$nominal_entry, clc$hidden_entry, 67],
            ['SWITCH1                        ', clc$nominal_entry, clc$normal_usage_entry, 45],
            ['SWITCH2                        ', clc$nominal_entry, clc$normal_usage_entry, 46],
            ['SWITCH3                        ', clc$nominal_entry, clc$normal_usage_entry, 47],
            ['SWITCH4                        ', clc$nominal_entry, clc$normal_usage_entry, 48],
            ['SWITCH5                        ', clc$nominal_entry, clc$normal_usage_entry, 49],
            ['SWITCH6                        ', clc$nominal_entry, clc$normal_usage_entry, 50],
            ['SWITCH7                        ', clc$nominal_entry, clc$normal_usage_entry, 51],
            ['SWITCH8                        ', clc$nominal_entry, clc$normal_usage_entry, 52],
            ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 53],
            ['SYSTEM_JOB_NAME                ', clc$nominal_entry, clc$normal_usage_entry, 54],
            ['UI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 55],
            ['UJN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 56],
            ['USER                           ', clc$nominal_entry, clc$hidden_entry, 65],
            ['USER_INFORMATION               ', clc$nominal_entry, clc$normal_usage_entry, 55],
            ['USER_JOB_NAME                  ', clc$nominal_entry, clc$normal_usage_entry, 56],
            ['VERTICAL_PRINT_DENSITY         ', clc$nominal_entry, clc$normal_usage_entry, 57],
            ['VFU_LOAD_PROCEDURE             ', clc$nominal_entry, clc$normal_usage_entry, 58],
            ['VLP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 58],
            ['VPD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 57]]]];

?? POP ??

    CONST
      p$attribute = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      get_attribute_p: ^jmt$job_attribute_results;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH get_attribute_p: [1 .. 1];
    jmp$get_attribute_index (pvt [p$attribute].value^.keyword_value, get_attribute_p^ [1].key);

    CASE get_attribute_p^ [1].key OF
    = jmc$job_qualifier_list =
      PUSH get_attribute_p^ [1].job_qualifier_list: [1 .. jmc$maximum_job_qualifiers];

    = jmc$output_disposition =
      PUSH get_attribute_p^ [1].output_disposition.standard_output_path;

    = jmc$purge_delay =
      PUSH get_attribute_p^ [1].purge_delay;

    = jmc$remote_host_directive =
      PUSH get_attribute_p^ [1].remote_host_directive;

    = jmc$site_information =
      PUSH get_attribute_p^ [1].site_information;

    = jmc$user_information =
      PUSH get_attribute_p^ [1].user_information;
    ELSE
    CASEND;

    jmp$get_job_attributes (get_attribute_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    assign_function_value (get_attribute_p, pvt [p$attribute].value^.keyword_value, work_area, result,
          status);
  PROCEND jmp$$job;
?? OLDTITLE ??
?? NEWTITLE := 'jmp$$job_counts', EJECT ??

  PROCEDURE [XDCL] jmp$$job_counts
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      job_counts_adt: [STATIC, READ, cls$adt] array [1 .. 2] of clt$argument_descriptor := [
            {1} [[clc$optional_with_default, ^state_default], [^valid_states, clc$keyword_value]],
            {2} [[clc$optional_with_default, ^class_default], [NIL, clc$name_value, 1, osc$max_name_size]]],
      state_default: [STATIC, READ, cls$adt_names_and_defaults] string (9) := 'INITIATED',
      valid_states: [STATIC, READ, cls$adt_names_and_defaults] array [1 .. 3] of ost$name := ['ALL', 'QUEUED',
            'INITIATED'],
      class_default: [STATIC, READ, cls$adt_names_and_defaults] string (3) := 'ALL';

    VAR
      avt: array [1 .. 2] of clt$value,
      selected_states: jmt$job_state_set,
      selected_classes: jmt$job_class_set,
      job_class: jmt$job_class,
      job_state: jmt$job_state,
      job_counts: jmt$job_counts,
      total_jobs: integer;

    status.normal := TRUE;

    clp$scan_argument_list (function_name, argument_list, ^job_counts_adt, ^avt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF avt [1].name.value = 'ALL' THEN
      selected_states := -$jmt$job_state_set [];
    ELSEIF avt [1].name.value = 'INITIATED' THEN
      selected_states := $jmt$job_state_set [jmc$initiated_job];
    ELSE
      selected_states := $jmt$job_state_set [jmc$queued_job];
    IFEND;

    IF avt [2].name.value = 'ALL' THEN
      selected_classes := -$jmt$job_class_set [];
    ELSE
      jmp$determine_job_class (avt [2].name.value, job_class, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      selected_classes := $jmt$job_class_set [job_class];
    IFEND;

    jmp$get_job_counts (job_counts, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    total_jobs := 0;
    FOR job_state := LOWERVALUE (jmt$job_state) TO UPPERVALUE (jmt$job_state) DO
      IF job_state IN selected_states THEN

        FOR job_class := LOWERVALUE (jmt$job_class) TO UPPERVALUE (jmt$job_class) DO
          IF job_class IN selected_classes THEN

            CASE job_state OF
            = jmc$queued_job =
              total_jobs := total_jobs + job_counts.job_class_counts [job_class].queued_jobs;

            = jmc$initiated_job =
              total_jobs := total_jobs + job_counts.job_class_counts [job_class].initiated_jobs;

            ELSE
            CASEND;
          IFEND;
        FOREND;
      IFEND;
    FOREND;

    value.descriptor := clv$value_descriptors [clc$integer_value];
    value.kind := clc$integer_value;
    value.int.radix := 10;
    value.int.radix_specified := FALSE;
    value.int.value := total_jobs;

  PROCEND jmp$$job_counts;
?? OLDTITLE ??
?? NEWTITLE := 'jmp$$job_default', EJECT ??

  PROCEDURE [XDCL] jmp$$job_default
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$job_default) $job_default (
{   attribute: key
{       (cpu_time_limit, ctl)
{       (job_abort_disposition, jad)
{       (job_class, jc)
{       (job_deferred_by_operator, jdbo)
{       (job_destination_usage, jdu)
{       (job_qualifier, job_qualifiers, jq)
{       (job_recovery_disposition, jrd)
{       (login_family, lf)
{       (magnetic_tape_limit, mtl)
{       (maximum_working_set, maxws)
{       (output_class, oc)
{       (output_deferred_by_operator, odbo)
{       (output_destination_usage, odu)
{       (purge_delay, pd)
{       (site_information, si)
{       (sru_limit, sl)
{       (station, s)
{       (vertical_print_density, vpd)
{     keyend = $required
{   job_mode: key
{       (batch, b)
{       (interactive, i)
{     keyend = $optional
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 37] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
    recend := [
    [1,
    [91, 7, 8, 14, 13, 25, 695],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$$JOB_DEFAULT'], [
    ['ATTRIBUTE                      ',clc$nominal_entry, 1],
    ['JOB_MODE                       ',clc$nominal_entry, 2]],
    [
{ 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, 1376,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, 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, 155,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [37], [
    ['CPU_TIME_LIMIT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['CTL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['JAD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['JC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['JDBO                           ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['JDU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['JOB_ABORT_DISPOSITION          ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['JOB_CLASS                      ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['JOB_DEFERRED_BY_OPERATOR       ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['JOB_DESTINATION_USAGE          ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['JOB_QUALIFIER                  ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['JOB_QUALIFIERS                 ', clc$alias_entry, clc$normal_usage_entry, 6],
    ['JOB_RECOVERY_DISPOSITION       ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['JQ                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['JRD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
    ['LF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
    ['LOGIN_FAMILY                   ', clc$nominal_entry, clc$normal_usage_entry, 8],
    ['MAGNETIC_TAPE_LIMIT            ', clc$nominal_entry, clc$normal_usage_entry, 9],
    ['MAXIMUM_WORKING_SET            ', clc$nominal_entry, clc$normal_usage_entry, 10],
    ['MAXWS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
    ['MTL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
    ['OC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
    ['ODBO                           ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
    ['ODU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
    ['OUTPUT_CLASS                   ', clc$nominal_entry, clc$normal_usage_entry, 11],
    ['OUTPUT_DEFERRED_BY_OPERATOR    ', clc$nominal_entry, clc$normal_usage_entry, 12],
    ['OUTPUT_DESTINATION_USAGE       ', clc$nominal_entry, clc$normal_usage_entry, 13],
    ['PD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
    ['PURGE_DELAY                    ', clc$nominal_entry, clc$normal_usage_entry, 14],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
    ['SI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
    ['SITE_INFORMATION               ', clc$nominal_entry, clc$normal_usage_entry, 15],
    ['SL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
    ['SRU_LIMIT                      ', clc$nominal_entry, clc$normal_usage_entry, 16],
    ['STATION                        ', clc$nominal_entry, clc$normal_usage_entry, 17],
    ['VERTICAL_PRINT_DENSITY         ', clc$nominal_entry, clc$normal_usage_entry, 18],
    ['VPD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 18]]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BATCH                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['INTERACTIVE                    ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$attribute = 1,
      p$job_mode = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      default_attribute_p: ^jmt$default_attribute_results,
      job_mode: jmt$job_mode;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH default_attribute_p: [1 .. 1];
    jmp$get_attribute_index (pvt [p$attribute].value^.keyword_value, default_attribute_p^ [1].key);

    CASE default_attribute_p^ [1].key OF
    = jmc$job_qualifier_list =
      PUSH default_attribute_p^ [1].job_qualifier_list: [1 .. jmc$maximum_job_qualifiers];

    = jmc$purge_delay =
      PUSH default_attribute_p^ [1].purge_delay;

    = jmc$site_information =
      PUSH default_attribute_p^ [1].site_information;

    ELSE
    CASEND;

    IF pvt [p$job_mode].specified THEN
      IF pvt [p$job_mode].value^.keyword_value = 'BATCH' THEN
        job_mode := jmc$batch;
      ELSE
        job_mode := jmc$interactive_connected;
      IFEND;
    ELSE
      pmp$get_job_mode (job_mode, { ignore} status);
    IFEND;
    jmp$get_attribute_defaults (job_mode, default_attribute_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    assign_function_value (default_attribute_p, pvt [p$attribute].value^.keyword_value, work_area, result,
          status);
  PROCEND jmp$$job_default;
?? OLDTITLE ??
?? NEWTITLE := 'jmp$$job_status', EJECT ??

  PROCEDURE [XDCL] jmp$$job_status
    (    parameter_list: clt$parameter_list;
     VAR work_area { input, output } : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$job_status) $job_status (
{   name: name = $required
{   attribute: key
{       (control_family, cf)
{       (control_user, cu)
{       (display_message, dm)
{       (job_class, jc)
{       (job_class_position, jcp)
{       (job_destination_usage, jdu)
{       (job_initiation_time, jit)
{       (job_mode, jm)
{       (job_mode_cpu_time, jmct)
{       (job_state, js)
{       (login_family, lf)
{       (login_user, lu)
{       (monitor_mode_cpu_time, mmct)
{       (operator_action_posted, oap)
{       (pages_assigned, pa)
{       (pages_from_disk, pfd)
{       (pages_reclaimed, pr)
{       (system_job_name, sjn)
{       (user_job_name, ujn)
{     hidden_key
{       (client_mainframe_identifier, cmi)
{       (input_file_location, ifl)
{       (server_mainframe_identifier, smi)
{       (state, s)
{     keyend = $required
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 46] of clt$keyword_specification,
        recend,
      recend := [[1, [88, 5, 5, 11, 9, 8, 976], clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$JOB_STATUS'],
            [['ATTRIBUTE                      ', clc$nominal_entry, 2],
            ['NAME                           ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [2, 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, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [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, 1709, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [46], [['CF                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['CLIENT_MAINFRAME_IDENTIFIER    ', clc$nominal_entry,
            clc$hidden_entry, 20], ['CMI                            ', clc$abbreviation_entry,
            clc$hidden_entry, 20], ['CONTROL_FAMILY                 ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['CONTROL_USER                   ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['CU                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['DISPLAY_MESSAGE                ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['DM                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['IFL                            ', clc$abbreviation_entry,
            clc$hidden_entry, 21], ['INPUT_FILE_LOCATION            ', clc$nominal_entry, clc$hidden_entry,
            21], ['JC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
            ['JCP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
            ['JDU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
            ['JIT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
            ['JM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
            ['JMCT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
            ['JOB_CLASS                      ', clc$nominal_entry, clc$normal_usage_entry, 4],
            ['JOB_CLASS_POSITION             ', clc$nominal_entry, clc$normal_usage_entry, 5],
            ['JOB_DESTINATION_USAGE          ', clc$nominal_entry, clc$normal_usage_entry, 6],
            ['JOB_INITIATION_TIME            ', clc$nominal_entry, clc$normal_usage_entry, 7],
            ['JOB_MODE                       ', clc$nominal_entry, clc$normal_usage_entry, 8],
            ['JOB_MODE_CPU_TIME              ', clc$nominal_entry, clc$normal_usage_entry, 9],
            ['JOB_STATE                      ', clc$nominal_entry, clc$normal_usage_entry, 10],
            ['JS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
            ['LF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
            ['LOGIN_FAMILY                   ', clc$nominal_entry, clc$normal_usage_entry, 11],
            ['LOGIN_USER                     ', clc$nominal_entry, clc$normal_usage_entry, 12],
            ['LU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
            ['MMCT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
            ['MONITOR_MODE_CPU_TIME          ', clc$nominal_entry, clc$normal_usage_entry, 13],
            ['OAP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
            ['OPERATOR_ACTION_POSTED         ', clc$nominal_entry, clc$normal_usage_entry, 14],
            ['PA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
            ['PAGES_ASSIGNED                 ', clc$nominal_entry, clc$normal_usage_entry, 15],
            ['PAGES_FROM_DISK                ', clc$nominal_entry, clc$normal_usage_entry, 16],
            ['PAGES_RECLAIMED                ', clc$nominal_entry, clc$normal_usage_entry, 17],
            ['PFD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
            ['PR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
            ['S                              ', clc$abbreviation_entry, clc$hidden_entry, 23],
            ['SERVER_MAINFRAME_IDENTIFIER    ', clc$nominal_entry, clc$hidden_entry, 22],
            ['SJN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
            ['SMI                            ', clc$abbreviation_entry, clc$hidden_entry, 22],
            ['STATE                          ', clc$nominal_entry, clc$hidden_entry, 23],
            ['SYSTEM_JOB_NAME                ', clc$nominal_entry, clc$normal_usage_entry, 18],
            ['UJN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
            ['USER_JOB_NAME                  ', clc$nominal_entry, clc$normal_usage_entry, 19]]]];

?? POP ??

    CONST
      p$name = 1,
      p$attribute = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      job_name: jmt$name,
      job_status_options_p: ^jmt$job_status_options,
      job_status_results_keys_p: ^jmt$results_keys,
      job_status_results_p: ^jmt$job_status_results,
      job_status_results_seq_p: ^jmt$work_area,
      number_of_jobs_found: jmt$job_status_count,
      size_of_sequence: ost$segment_length;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$determine_name_kind (pvt [p$name].value^.name_value, job_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH job_status_options_p: [1 .. 2];
    job_status_options_p^ [1].key := jmc$name_list;
    PUSH job_status_options_p^ [1].name_list: [1 .. 1];
    job_status_options_p^ [1].name_list^ [1] := job_name;
    job_status_options_p^ [2].key := jmc$continue_request_to_servers;
    job_status_options_p^ [2].continue_request_to_servers := TRUE;
    PUSH job_status_results_keys_p: [1 .. 1];
    IF pvt [p$attribute].value^.keyword_value = 'STATE' THEN
      job_status_results_keys_p^ [1] := jmc$job_state;
    ELSE
      jmp$get_attribute_index (pvt [p$attribute].value^.keyword_value, job_status_results_keys_p^ [1]);
    IFEND;

    jmp$get_result_size ({number_of_jobs} 1, #SEQ (job_status_results_keys_p^), size_of_sequence);
    PUSH job_status_results_seq_p: [[REP size_of_sequence OF cell]];

    jmp$get_job_status (job_status_options_p, job_status_results_keys_p, job_status_results_seq_p,
          job_status_results_p, number_of_jobs_found, status);
    IF NOT status.normal THEN
      IF status.condition = jme$no_jobs_were_found THEN
        IF (job_status_results_keys_p^ [1] <> jmc$job_state) THEN
          osp$set_status_abnormal ('JM', jme$name_not_found, pvt [p$name].value^.name_value, status);
        ELSE
          clp$make_name_value ('UNKNOWN', work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
          ELSE
            status.normal := TRUE;
          IFEND;
        IFEND;
      ELSE
        IF status.condition = jme$work_area_too_small THEN
          osp$set_status_abnormal ('JM', jme$duplicate_name, pvt [p$name].value^.name_value, status);
        IFEND;
      IFEND;
    ELSE
      assign_function_value (job_status_results_p^ [1], pvt [p$attribute].value^.keyword_value, work_area,
            result, status);
    IFEND;
  PROCEND jmp$$job_status;
?? OLDTITLE ??
?? NEWTITLE := 'jmp$$input', EJECT ??

  PROCEDURE [XDCL] jmp$$input
    (    parameter_list: clt$parameter_list;
     VAR work_area { input, input } : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$job_input) $job_input (
{   name: name = $required
{   attribute: key
{       (comment_banner, cb)
{       (control_family, cf)
{       (control_user, cu)
{       (copies, c)
{       (cpu_time_limit, ctl)
{       (data_mode, dm)
{       (device, d)
{       (earliest_print_time, ept)
{       (earliest_run_time, ert)
{       (external_characteristics, ec)
{       (forms_code, fc)
{       (job_abort_disposition, jad)
{       (job_class, jc)
{       (job_deferred_by_operator, jdbo)
{       (job_deferred_by_user, jdbu)
{       (job_destination, jd)
{       (job_destination_usage, jdu)
{       (job_execution_ring, jer)
{       (job_mode, jm)
{       (job_qualifier, job_qualifiers, jq)
{       (job_recovery_disposition, jrd)
{       (job_size, js)
{       (job_submission_time, jst)
{       (latest_print_time, lpt)
{       (latest_run_time, lrt)
{       (login_account, la)
{       (login_family, lf)
{       (login_project, lp)
{       (login_user, lu)
{       (magnetic_tape_limit, mtl)
{       (maximum_working_set, maxws)
{       (operator_family, of)
{       (operator_user, ou)
{       (originating_application_name, oan)
{       (output_class, oc)
{       (output_deferred_by_user, odbu)
{       (output_destination, ode)
{       (output_destination_usage, odu)
{       (output_disposition, odi)
{       (output_priority, op)
{       (purge_delay, pd)
{       (remote_host_directive, rhd)
{       (routing_banner, rb)
{       (site_information, si)
{       (sru_limit, sl)
{       (station, s)
{       (system_job_name, sjn)
{       (user_information, ui)
{       (user_job_name, ujn)
{       (vertical_print_density, vpd)
{       (vfu_load_procedure, vlp)
{     keyend = $required
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 103] of clt$keyword_specification,
        recend,
      recend := [[1, [88, 2, 22, 13, 1, 26, 776], clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$JOB_INPUT'],
            [['ATTRIBUTE                      ', clc$nominal_entry, 2],
            ['NAME                           ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [2, 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, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [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, 3818, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [103], [['C                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['CB                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['CF                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['COMMENT_BANNER                 ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['CONTROL_FAMILY                 ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['CONTROL_USER                   ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['COPIES                         ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['CPU_TIME_LIMIT                 ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['CTL                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['CU                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['D                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['DATA_MODE                      ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['DEVICE                         ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['DM                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['EARLIEST_PRINT_TIME            ', clc$nominal_entry,
            clc$normal_usage_entry, 8], ['EARLIEST_RUN_TIME              ', clc$nominal_entry,
            clc$normal_usage_entry, 9], ['EC                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 10], ['EPT                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 8], ['ERT                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 9], ['EXTERNAL_CHARACTERISTICS       ', clc$nominal_entry,
            clc$normal_usage_entry, 10], ['FC                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 11], ['FORMS_CODE                     ', clc$nominal_entry,
            clc$normal_usage_entry, 11], ['JAD                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 12], ['JC                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 13], ['JD                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 16], ['JDBO                           ', clc$abbreviation_entry,
            clc$normal_usage_entry, 14], ['JDBU                           ', clc$abbreviation_entry,
            clc$normal_usage_entry, 15], ['JDU                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 17], ['JER                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 18], ['JM                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 19], ['JOB_ABORT_DISPOSITION          ', clc$nominal_entry,
            clc$normal_usage_entry, 12], ['JOB_CLASS                      ', clc$nominal_entry,
            clc$normal_usage_entry, 13], ['JOB_DEFERRED_BY_OPERATOR       ', clc$nominal_entry,
            clc$normal_usage_entry, 14], ['JOB_DEFERRED_BY_USER           ', clc$nominal_entry,
            clc$normal_usage_entry, 15], ['JOB_DESTINATION                ', clc$nominal_entry,
            clc$normal_usage_entry, 16], ['JOB_DESTINATION_USAGE          ', clc$nominal_entry,
            clc$normal_usage_entry, 17], ['JOB_EXECUTION_RING             ', clc$nominal_entry,
            clc$normal_usage_entry, 18], ['JOB_MODE                       ', clc$nominal_entry,
            clc$normal_usage_entry, 19], ['JOB_QUALIFIER                  ', clc$nominal_entry,
            clc$normal_usage_entry, 20], ['JOB_QUALIFIERS                 ', clc$alias_entry,
            clc$normal_usage_entry, 20], ['JOB_RECOVERY_DISPOSITION       ', clc$nominal_entry,
            clc$normal_usage_entry, 21], ['JOB_SIZE                       ', clc$nominal_entry,
            clc$normal_usage_entry, 22], ['JOB_SUBMISSION_TIME            ', clc$nominal_entry,
            clc$normal_usage_entry, 23], ['JQ                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 20], ['JRD                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 21], ['JS                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 22], ['JST                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 23], ['LA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 26], ['LATEST_PRINT_TIME              ', clc$nominal_entry,
            clc$normal_usage_entry, 24], ['LATEST_RUN_TIME                ', clc$nominal_entry,
            clc$normal_usage_entry, 25], ['LF                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 27], ['LOGIN_ACCOUNT                  ', clc$nominal_entry,
            clc$normal_usage_entry, 26], ['LOGIN_FAMILY                   ', clc$nominal_entry,
            clc$normal_usage_entry, 27], ['LOGIN_PROJECT                  ', clc$nominal_entry,
            clc$normal_usage_entry, 28], ['LOGIN_USER                     ', clc$nominal_entry,
            clc$normal_usage_entry, 29], ['LP                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 28], ['LPT                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 24], ['LRT                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 25], ['LU                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 29], ['MAGNETIC_TAPE_LIMIT            ', clc$nominal_entry,
            clc$normal_usage_entry, 30], ['MAXIMUM_WORKING_SET            ', clc$nominal_entry,
            clc$normal_usage_entry, 31], ['MAXWS                          ', clc$abbreviation_entry,
            clc$normal_usage_entry, 31], ['MTL                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 30], ['OAN                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 34], ['OC                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 35], ['ODBU                           ', clc$abbreviation_entry,
            clc$normal_usage_entry, 36], ['ODE                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 37], ['ODI                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 39], ['ODU                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 38], ['OF                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 32], ['OP                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 40], ['OPERATOR_FAMILY                ', clc$nominal_entry,
            clc$normal_usage_entry, 32], ['OPERATOR_USER                  ', clc$nominal_entry,
            clc$normal_usage_entry, 33], ['ORIGINATING_APPLICATION_NAME   ', clc$nominal_entry,
            clc$normal_usage_entry, 34], ['OU                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 33], ['OUTPUT_CLASS                   ', clc$nominal_entry,
            clc$normal_usage_entry, 35], ['OUTPUT_DEFERRED_BY_USER        ', clc$nominal_entry,
            clc$normal_usage_entry, 36], ['OUTPUT_DESTINATION             ', clc$nominal_entry,
            clc$normal_usage_entry, 37], ['OUTPUT_DESTINATION_USAGE       ', clc$nominal_entry,
            clc$normal_usage_entry, 38], ['OUTPUT_DISPOSITION             ', clc$nominal_entry,
            clc$normal_usage_entry, 39], ['OUTPUT_PRIORITY                ', clc$nominal_entry,
            clc$normal_usage_entry, 40], ['PD                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 41], ['PURGE_DELAY                    ', clc$nominal_entry,
            clc$normal_usage_entry, 41], ['RB                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 43], ['REMOTE_HOST_DIRECTIVE          ', clc$nominal_entry,
            clc$normal_usage_entry, 42], ['RHD                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 42], ['ROUTING_BANNER                 ', clc$nominal_entry,
            clc$normal_usage_entry, 43], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 46], ['SI                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 44], ['SITE_INFORMATION               ', clc$nominal_entry,
            clc$normal_usage_entry, 44], ['SJN                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 47], ['SL                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 45], ['SRU_LIMIT                      ', clc$nominal_entry,
            clc$normal_usage_entry, 45], ['STATION                        ', clc$nominal_entry,
            clc$normal_usage_entry, 46], ['SYSTEM_JOB_NAME                ', clc$nominal_entry,
            clc$normal_usage_entry, 47], ['UI                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 48], ['UJN                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 49], ['USER_INFORMATION               ', clc$nominal_entry,
            clc$normal_usage_entry, 48], ['USER_JOB_NAME                  ', clc$nominal_entry,
            clc$normal_usage_entry, 49], ['VERTICAL_PRINT_DENSITY         ', clc$nominal_entry,
            clc$normal_usage_entry, 50], ['VFU_LOAD_PROCEDURE             ', clc$nominal_entry,
            clc$normal_usage_entry, 51], ['VLP                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 51], ['VPD                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 50]]]];

?? POP ??

    CONST
      p$name = 1,
      p$attribute = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      number_of_inputs_found: jmt$job_status_count,
      input_name: jmt$name,
      input_options_p: ^jmt$input_attribute_options,
      input_results_keys_p: ^jmt$results_keys,
      input_results_p: ^jmt$input_attribute_results,
      result_size: ost$segment_length,
      work_area_p: ^jmt$work_area;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$determine_name_kind (pvt [p$name].value^.name_value, input_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH input_options_p: [1 .. 2];
    input_options_p^ [1].key := jmc$name_list;
    PUSH input_options_p^ [1].name_list: [1 .. 1];
    input_options_p^ [1].name_list^ [1] := input_name;
    input_options_p^ [2].key := jmc$continue_request_to_servers;
    input_options_p^ [2].continue_request_to_servers := TRUE;

    PUSH input_results_keys_p: [1 .. 1];
    jmp$get_attribute_index (pvt [p$attribute].value^.keyword_value, input_results_keys_p^ [1]);
    jmp$get_result_size ({number_of_items} 1, #SEQ (input_results_keys_p^), result_size);
    PUSH work_area_p: [[REP result_size OF cell]];
    RESET work_area_p;

    jmp$get_input_attributes (input_options_p, input_results_keys_p, work_area_p, input_results_p,
          number_of_inputs_found, status);
    IF NOT status.normal THEN
      IF status.condition = jme$no_jobs_were_found THEN
        IF (input_results_keys_p^ [1] <> jmc$job_state) THEN
          osp$set_status_abnormal ('JM', jme$name_not_found, pvt [p$name].value^.name_value, status);
        ELSE
          clp$make_name_value ('UNKNOWN', work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
          ELSE
            status.normal := TRUE;
          IFEND;
        IFEND;
      ELSE
        IF status.condition = jme$work_area_too_small THEN
          osp$set_status_abnormal ('JM', jme$duplicate_name, pvt [p$name].value^.name_value, status);
        IFEND;
      IFEND;
    ELSE
      assign_function_value (input_results_p^ [1], pvt [p$attribute].value^.keyword_value, work_area, result,
            status);
    IFEND;
  PROCEND jmp$$input;
?? OLDTITLE ??
?? NEWTITLE := 'jmp$$output', EJECT ??

  PROCEDURE [XDCL] jmp$$output
    (    parameter_list: clt$parameter_list;
     VAR work_area { input, output } : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$job_output) $job_output (
{   name: name = $required
{   attribute: key
{       (comment_banner, cb)
{       (control_family, cf)
{       (control_user, cu)
{       (copies, c)
{       (copies_printed, cp)
{       (data_mode, dm)
{       (device, d)
{       (device_type, dt)
{       (earliest_print_time, ept)
{       (external_characteristics, ec)
{       (file_position, fp)
{       (file_size, fs)
{       (forms_code, fc)
{       (latest_print_time, lpt)
{       (login_account, la)
{       (login_family, lf)
{       (login_project, lp)
{       (login_user, lu)
{       (operator_family, of)
{       (operator_user, ou)
{       (originating_application_name, oan)
{       (output_class, oc)
{       (output_deferred_by_operator, odbo)
{       (output_deferred_by_user, odbu)
{       (output_destination, ode)
{       (output_destination_usage, odu)
{       (output_priority, op)
{       (output_submission_time, ost)
{       (purge_delay, pd)
{       (remote_host_directive, rhd)
{       (routing_banner, rb)
{       (site_information, si)
{       (station, s)
{       (system_file_name, sfn)
{       (system_job_name, sjn)
{       (user_file_name, ufn)
{       (user_information, ui)
{       (user_job_name, ujn)
{       (vertical_print_density, vpd)
{       (vfu_load_procedure, vlp)
{     hidden_key
{       (destination_family, df)
{       (station_operator, so)
{       (destination_usage, du)
{       (dual_state_route_parameters, dsrp)
{     keyend = $required
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 88] of clt$keyword_specification,
        recend,
      recend := [[1, [88, 2, 18, 14, 59, 18, 957], clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$JOB_OUTPUT'],
            [['ATTRIBUTE                      ', clc$nominal_entry, 2],
            ['NAME                           ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [2, 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, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [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, 3263, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [88], [['C                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['CB                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['CF                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['COMMENT_BANNER                 ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['CONTROL_FAMILY                 ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['CONTROL_USER                   ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['COPIES                         ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['COPIES_PRINTED                 ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['CP                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['CU                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['D                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['DATA_MODE                      ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['DESTINATION_FAMILY             ', clc$nominal_entry,
            clc$hidden_entry, 41], ['DESTINATION_USAGE              ', clc$nominal_entry, clc$hidden_entry,
            43], ['DEVICE                         ', clc$nominal_entry, clc$normal_usage_entry, 7],
            ['DEVICE_TYPE                    ', clc$nominal_entry, clc$normal_usage_entry, 8],
            ['DF                             ', clc$abbreviation_entry, clc$hidden_entry, 41],
            ['DM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
            ['DSRP                           ', clc$abbreviation_entry, clc$hidden_entry, 44],
            ['DT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
            ['DU                             ', clc$abbreviation_entry, clc$hidden_entry, 43],
            ['DUAL_STATE_ROUTE_PARAMETERS    ', clc$nominal_entry, clc$hidden_entry, 44],
            ['EARLIEST_PRINT_TIME            ', clc$nominal_entry, clc$normal_usage_entry, 9],
            ['EC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
            ['EPT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
            ['EXTERNAL_CHARACTERISTICS       ', clc$nominal_entry, clc$normal_usage_entry, 10],
            ['FC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
            ['FILE_POSITION                  ', clc$nominal_entry, clc$normal_usage_entry, 11],
            ['FILE_SIZE                      ', clc$nominal_entry, clc$normal_usage_entry, 12],
            ['FORMS_CODE                     ', clc$nominal_entry, clc$normal_usage_entry, 13],
            ['FP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
            ['FS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
            ['LA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
            ['LATEST_PRINT_TIME              ', clc$nominal_entry, clc$normal_usage_entry, 14],
            ['LF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
            ['LOGIN_ACCOUNT                  ', clc$nominal_entry, clc$normal_usage_entry, 15],
            ['LOGIN_FAMILY                   ', clc$nominal_entry, clc$normal_usage_entry, 16],
            ['LOGIN_PROJECT                  ', clc$nominal_entry, clc$normal_usage_entry, 17],
            ['LOGIN_USER                     ', clc$nominal_entry, clc$normal_usage_entry, 18],
            ['LP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
            ['LPT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
            ['LU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
            ['OAN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 21],
            ['OC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 22],
            ['ODBO                           ', clc$abbreviation_entry, clc$normal_usage_entry, 23],
            ['ODBU                           ', clc$abbreviation_entry, clc$normal_usage_entry, 24],
            ['ODE                            ', clc$abbreviation_entry, clc$normal_usage_entry, 25],
            ['ODU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 26],
            ['OF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
            ['OP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 27],
            ['OPERATOR_FAMILY                ', clc$nominal_entry, clc$normal_usage_entry, 19],
            ['OPERATOR_USER                  ', clc$nominal_entry, clc$normal_usage_entry, 20],
            ['ORIGINATING_APPLICATION_NAME   ', clc$nominal_entry, clc$normal_usage_entry, 21],
            ['OST                            ', clc$abbreviation_entry, clc$normal_usage_entry, 28],
            ['OU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 20],
            ['OUTPUT_CLASS                   ', clc$nominal_entry, clc$normal_usage_entry, 22],
            ['OUTPUT_DEFERRED_BY_OPERATOR    ', clc$nominal_entry, clc$normal_usage_entry, 23],
            ['OUTPUT_DEFERRED_BY_USER        ', clc$nominal_entry, clc$normal_usage_entry, 24],
            ['OUTPUT_DESTINATION             ', clc$nominal_entry, clc$normal_usage_entry, 25],
            ['OUTPUT_DESTINATION_USAGE       ', clc$nominal_entry, clc$normal_usage_entry, 26],
            ['OUTPUT_PRIORITY                ', clc$nominal_entry, clc$normal_usage_entry, 27],
            ['OUTPUT_SUBMISSION_TIME         ', clc$nominal_entry, clc$normal_usage_entry, 28],
            ['PD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 29],
            ['PURGE_DELAY                    ', clc$nominal_entry, clc$normal_usage_entry, 29],
            ['RB                             ', clc$abbreviation_entry, clc$normal_usage_entry, 31],
            ['REMOTE_HOST_DIRECTIVE          ', clc$nominal_entry, clc$normal_usage_entry, 30],
            ['RHD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 30],
            ['ROUTING_BANNER                 ', clc$nominal_entry, clc$normal_usage_entry, 31],
            ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 33],
            ['SFN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 34],
            ['SI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 32],
            ['SITE_INFORMATION               ', clc$nominal_entry, clc$normal_usage_entry, 32],
            ['SJN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 35],
            ['SO                             ', clc$abbreviation_entry, clc$hidden_entry, 42],
            ['STATION                        ', clc$nominal_entry, clc$normal_usage_entry, 33],
            ['STATION_OPERATOR               ', clc$nominal_entry, clc$hidden_entry, 42],
            ['SYSTEM_FILE_NAME               ', clc$nominal_entry, clc$normal_usage_entry, 34],
            ['SYSTEM_JOB_NAME                ', clc$nominal_entry, clc$normal_usage_entry, 35],
            ['UFN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 36],
            ['UI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 37],
            ['UJN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 38],
            ['USER_FILE_NAME                 ', clc$nominal_entry, clc$normal_usage_entry, 36],
            ['USER_INFORMATION               ', clc$nominal_entry, clc$normal_usage_entry, 37],
            ['USER_JOB_NAME                  ', clc$nominal_entry, clc$normal_usage_entry, 38],
            ['VERTICAL_PRINT_DENSITY         ', clc$nominal_entry, clc$normal_usage_entry, 39],
            ['VFU_LOAD_PROCEDURE             ', clc$nominal_entry, clc$normal_usage_entry, 40],
            ['VLP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 40],
            ['VPD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 39]]]];

?? POP ??

    CONST
      p$name = 1,
      p$attribute = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    VAR
      number_of_outputs_found: jmt$output_status_count,
      output_name: jmt$name,
      output_options_p: ^jmt$output_attribute_options,
      output_results_keys_p: ^jmt$results_keys,
      output_results_p: ^jmt$output_attribute_results,
      result_size: ost$segment_length,
      work_area_p: ^jmt$work_area;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$determine_name_kind (pvt [p$name].value^.name_value, output_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH output_options_p: [1 .. 2];
    output_options_p^ [1].key := jmc$name_list;
    PUSH output_options_p^ [1].name_list: [1 .. 1];
    output_options_p^ [1].name_list^ [1] := output_name;
    output_options_p^ [2].key := jmc$continue_request_to_servers;
    output_options_p^ [2].continue_request_to_servers := TRUE;

    PUSH output_results_keys_p: [1 .. 1];
    jmp$get_attribute_index (pvt [p$attribute].value^.keyword_value, output_results_keys_p^ [1]);
    jmp$get_result_size ({number_of_items} 1, #SEQ (output_results_keys_p^), result_size);
    PUSH work_area_p: [[REP result_size OF cell]];
    RESET work_area_p;

    jmp$get_output_attributes (output_options_p, output_results_keys_p, work_area_p, output_results_p,
          number_of_outputs_found, status);
    IF NOT status.normal THEN
      IF status.condition = jme$no_outputs_were_found THEN
        IF (output_results_keys_p^ [1] <> jmc$output_state) THEN
          osp$set_status_abnormal ('JM', jme$name_not_found, pvt [p$name].value^.name_value, status);
        ELSE
          clp$make_name_value ('UNKNOWN', work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
          ELSE
            status.normal := TRUE;
          IFEND;
        IFEND;
      ELSE
        IF status.condition = jme$work_area_too_small THEN
          osp$set_status_abnormal ('JM', jme$duplicate_name, pvt [p$name].value^.name_value, status);
        IFEND;
      IFEND;
    ELSE
      assign_function_value (output_results_p^ [1], pvt [p$attribute].value^.keyword_value, work_area, result,
            status);
    IFEND;
  PROCEND jmp$$output;
?? OLDTITLE ??
?? NEWTITLE := 'jmp$$output_status', EJECT ??

  PROCEDURE [XDCL] jmp$$output_status
    (    parameter_list: clt$parameter_list;
     VAR work_area { input, output } : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$output_status) $output_status (
{   name: name = $required
{   attribute: key
{       (control_family, cf)
{       (control_user, cu)
{       (login_family, lf)
{       (login_user, lu)
{       (output_destination_usage, odu)
{       (output_state, os)
{       (system_file_name, sfn)
{       (system_job_name, sjn)
{       (user_file_name, ufn)
{     hidden_key
{       (state, s)
{     keyend = $required
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 20] of clt$keyword_specification,
        recend,
      recend := [[1, [88, 2, 18, 16, 50, 28, 515], clc$function, 2, 2, 2, 0, 0, 0, 0, 'OSM$$OUTPUT_STATUS'],
            [['ATTRIBUTE                      ', clc$nominal_entry, 2],
            ['NAME                           ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [2, 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, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [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, 747, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [20], [['CF                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['CONTROL_FAMILY                 ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['CONTROL_USER                   ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['CU                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['LF                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['LOGIN_FAMILY                   ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['LOGIN_USER                     ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['LU                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['ODU                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['OS                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['OUTPUT_DESTINATION_USAGE       ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['OUTPUT_STATE                   ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['S                              ', clc$abbreviation_entry,
            clc$hidden_entry, 10], ['SFN                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['SJN                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 8], ['STATE                          ', clc$nominal_entry,
            clc$hidden_entry, 10], ['SYSTEM_FILE_NAME               ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['SYSTEM_JOB_NAME                ', clc$nominal_entry,
            clc$normal_usage_entry, 8], ['UFN                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 9], ['USER_FILE_NAME                 ', clc$nominal_entry,
            clc$normal_usage_entry, 9]]]];

?? POP ??

    CONST
      p$name = 1,
      p$attribute = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      number_of_outputs_found: jmt$output_status_count,
      output_name: jmt$name,
      output_status_options: ^jmt$output_status_options,
      output_status_results: ^jmt$output_status_results,
      result_size: ost$segment_length,
      status_results_keys_p: ^jmt$results_keys,
      status_work_area_p: ^jmt$work_area;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$determine_name_kind (pvt [p$name].value^.name_value, output_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH output_status_options: [1 .. 2];
    output_status_options^ [1].key := jmc$name_list;
    PUSH output_status_options^ [1].name_list: [1 .. 1];
    output_status_options^ [1].name_list^ [1] := output_name;
    output_status_options^ [2].key := jmc$continue_request_to_servers;
    output_status_options^ [2].continue_request_to_servers := TRUE;
    PUSH status_results_keys_p: [1 .. 1];
    IF pvt [p$attribute].value^.keyword_value = 'STATE' THEN
      status_results_keys_p^ [1] := jmc$output_state;
    ELSE
      jmp$get_attribute_index (pvt [p$attribute].value^.keyword_value, status_results_keys_p^ [1]);
    IFEND;
    jmp$get_result_size ({number_of_items} 1, #SEQ (status_results_keys_p^), result_size);
    PUSH status_work_area_p: [[REP result_size OF cell]];
    RESET status_work_area_p;
    jmp$get_output_status (output_status_options, status_results_keys_p, status_work_area_p,
          output_status_results, number_of_outputs_found, status);
    IF NOT status.normal THEN
      IF status.condition = jme$no_outputs_were_found THEN
        IF (status_results_keys_p^ [1] <> jmc$output_state) THEN
          osp$set_status_abnormal ('JM', jme$name_not_found, pvt [p$name].value^.name_value, status);
        ELSE
          clp$make_name_value ('UNKNOWN', work_area, result);
          IF result = NIL THEN
            osp$set_status_condition (cle$work_area_overflow, status);
          ELSE
            status.normal := TRUE;
          IFEND;
        IFEND;
      ELSE
        IF status.condition = jme$work_area_too_small THEN
          osp$set_status_abnormal ('JM', jme$duplicate_name, pvt [p$name].value^.name_value, status);
        IFEND;
      IFEND;
    ELSE
      assign_function_value (output_status_results^ [1], pvt [p$name].value^.keyword_value, work_area, result,
            status);
    IFEND;
  PROCEND jmp$$output_status;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$display_attributes', EJECT ??
*copy jmh$display_attributes

  PROCEDURE [XDCL, #GATE] jmp$display_attributes
    (VAR attribute_values_seq: ^SEQ ( * );
         number_to_display: integer;
         header_display_list_p: ^jmt$header_display_information,
         not_found_name_list_p: ^jmt$name_list;
         not_found_name_list_count: integer;
         file: clt$file;
         command_title: string ( * );
     VAR status: ost$status);

    CONST
      clc$maximum_display_string_size = osc$max_string_size + 2,
      clc$max_display_string_chunk = clc$maximum_display_string_size DIV 2,
      maximum_attribute_name_size = 28, { Originating_Application_Name
      tab_over = maximum_attribute_name_size + 4;

    VAR
      current_date_time: ost$date_time;

*copy clv$display_variables
?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   Attempt to cleanup on block exit if something doesn't work.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF output_open THEN
        clp$close_display (display_control, ignore_status);
        output_open := FALSE;
        #SPOIL (output_open);
      IFEND;

    PROCEND abort_handler;
*copy clp$new_page_procedure
?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

{ These displays do not have subtitles.  This is merely a dummy routine to keep the module consistant
{ with those that do produce subtitles.

    PROCEND put_subtitle;
?? OLDTITLE ??
?? NEWTITLE := 'put_attribute', EJECT ??

{ PURPOSE:
{   This procedure will display a header and a value that are passed as strings.  These values will be
{ displayed to the file requested on the call to jmp$display_attributes.

    PROCEDURE put_attribute
      (    header: string ( * );
           value: string ( * ));

      VAR
        start_option: amt$term_option,
        edited_header: string (tab_over);

      status.normal := TRUE;
      start_option := amc$start;
      edited_header := header;

      IF value <> ' ' THEN
        edited_header (tab_over - 2) := ':';
      IFEND;
      clp$put_partial_display (display_control, edited_header, clc$no_trim, start_option, status);
      IF NOT status.normal THEN
        EXIT jmp$display_attributes;
      IFEND;
      clp$put_partial_display (display_control, value, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        EXIT jmp$display_attributes;
      IFEND;

    PROCEND put_attribute;
?? OLDTITLE ??
?? NEWTITLE := 'put_header', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display a line containing a header that
{ describes a set of attributes to be displayed.

    PROCEDURE put_header
      (    header: string ( * ));

      VAR
        start_option: amt$term_option,
        edited_header: string (tab_over);

      status.normal := TRUE;

      clp$put_partial_display (display_control, header, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        EXIT jmp$display_attributes;
      IFEND;
      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        EXIT jmp$display_attributes;
      IFEND;
    PROCEND put_header;
?? OLDTITLE ??
?? NEWTITLE := 'display_attribute', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to display a single attribute value.

    PROCEDURE display_attribute
      (    attribute: jmt$attribute_value;
       VAR status: ost$status);

      VAR
        temp_string: string (osc$max_string_size),
        result_length: integer,
        os_string: ost$string;

?? NEWTITLE := 'put_cpu_time_limit', EJECT ??

{ PURPOSE:
{   This procedure will display the CPU_TIME_LIMIT attribute.

      PROCEDURE put_cpu_time_limit
        (    title: string ( * );
             cpu_time_limit: jmt$cpu_time_limit);

        IF cpu_time_limit = jmc$required_cpu_time_limit THEN
          put_name (title, lowercase_required);
        ELSEIF cpu_time_limit = jmc$system_default_cpu_time_lim THEN
          put_name (title, lowercase_system_default);
        ELSEIF cpu_time_limit = jmc$unlimited_cpu_time_limit THEN
          put_name (title, lowercase_unlimited);
        ELSEIF cpu_time_limit = jmc$unspecified_cpu_time_limit THEN
          put_name (title, lowercase_unspecified);
        ELSE
          put_integer (title, cpu_time_limit);
        IFEND;
      PROCEND put_cpu_time_limit;
?? OLDTITLE ??
?? NEWTITLE := 'put_cpu_time_used', EJECT ??

{ PURPOSE:
{   This procedure will display the CPU_TIME_USED attribute.

      PROCEDURE put_cpu_time_used
        (    title: string ( * );
             cpu_time_used: jmt$cpu_time_used);

        CONST
          maximum_cpu_time_string_size = 100;

        VAR
          ignore_status: ost$status,
          millisecond_string: string (3),
          cpu_time_string: string (maximum_cpu_time_string_size),
          second_string: ost$string,
          string_index: 0 .. maximum_cpu_time_string_size;

        string_index := 1;
        cpu_time_string := 'Job Mode- ';
        string_index := string_index + 10;
        clp$convert_integer_to_string (cpu_time_used.job_mode_time DIV 1000, 10, FALSE, second_string,
              ignore_status);
        cpu_time_string (string_index, second_string.size) := second_string.value (1, second_string.size);
        string_index := string_index + second_string.size;
        cpu_time_string (string_index) := '.';
        string_index := string_index + 1;
        clp$convert_integer_to_rjstring (cpu_time_used.job_mode_time MOD 1000, 10, FALSE, '0',
              millisecond_string, ignore_status);
        cpu_time_string (string_index, 3) := millisecond_string;
        string_index := string_index + 5;
        cpu_time_string (string_index, 14) := 'Monitor Mode- ';
        string_index := string_index + 14;
        clp$convert_integer_to_string (cpu_time_used.monitor_mode_time DIV 1000, 10, FALSE, second_string,
              ignore_status);
        cpu_time_string (string_index, second_string.size) := second_string.value (1, second_string.size);
        string_index := string_index + second_string.size;
        cpu_time_string (string_index) := '.';
        string_index := string_index + 1;
        clp$convert_integer_to_rjstring (cpu_time_used.monitor_mode_time MOD 1000, 10, FALSE, '0',
              millisecond_string, ignore_status);
        cpu_time_string (string_index, 3) := millisecond_string;
        string_index := string_index + 3;

        put_large_string (title, cpu_time_string (1, string_index));
      PROCEND put_cpu_time_used;
?? OLDTITLE ??
?? NEWTITLE := 'put_date_time', EJECT ??

{ PURPOSE:
{   The purpose of this request is to format and display a date/time value.

      PROCEDURE put_date_time
        (    title: string ( * );
             date_time: ost$date_time);

        VAR
          date: ost$date,
          representation_p: ^clt$data_representation,
          scl_time_increment_value_p: ^clt$data_value,
          string_count_p: ^clt$data_representation_count,
          string_p: ^clt$string_value,
          string_size_p: ^clt$string_size,
          time: ost$time,
          work_area_pp: ^^clt$work_area;


        IF date_time = jmv$null_date_time THEN
          put_attribute (title, 'none');
        ELSE
          pmp$format_compact_date (date_time, osc$iso_date, date, status);
          IF NOT status.normal THEN
            EXIT jmp$display_attributes;
          IFEND;

          pmp$format_compact_time (date_time, osc$hms_time, time, status);
          IF NOT status.normal THEN
            EXIT jmp$display_attributes;
          IFEND;

          PUSH scl_time_increment_value_p;
          scl_time_increment_value_p^.kind := clc$time_increment;
          PUSH scl_time_increment_value_p^.time_increment_value;
          pmp$compute_date_time_increment (date_time, current_date_time,
                scl_time_increment_value_p^.time_increment_value^, status);
          IF NOT status.normal THEN
            EXIT jmp$display_attributes;
          IFEND;
          clp$get_work_area (#RING (^work_area_pp), work_area_pp, status);
          IF NOT status.normal THEN
            EXIT jmp$display_attributes;
          IFEND;
          clp$convert_data_to_string (scl_time_increment_value_p, clc$data_source_representation,
                clc$max_string_size, work_area_pp^, representation_p, status);
          IF NOT status.normal THEN
            EXIT jmp$display_attributes;
          IFEND;
          NEXT string_count_p IN representation_p;
          NEXT string_size_p IN representation_p;
          NEXT string_p: [string_size_p^] IN representation_p;
          STRINGREP (temp_string, result_length, date.iso, '.', time.hms, '   (', string_p^, ')');
          put_large_string (title, temp_string (1, result_length));
        IFEND;
      PROCEND put_date_time;
?? OLDTITLE ??
?? NEWTITLE := 'put_date_time_conditional', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display a date time value if one is specified or "none" if the
{ date time value is unspecified.

      PROCEDURE put_date_time_conditional
        (    title: string ( * );
             date_time: jmt$date_time);

        IF date_time.specified THEN
          put_date_time (title, date_time.date_time);
        ELSE
          put_attribute (title, 'none');
        IFEND;
      PROCEND put_date_time_conditional;
?? OLDTITLE ??
?? NEWTITLE := 'put_detached_job_wait_time', EJECT ??

{ PURPOSE:
{   This procedure will display the detached_job_wait_time attribute.

      PROCEDURE put_detached_job_wait_time
        (    title: string ( * );
             detached_job_wait_time: jmt$detached_job_wait_time);

        IF detached_job_wait_time = jmc$unlimited_det_job_wait_time THEN
          put_name (title, lowercase_unlimited);
        ELSE
          put_integer (title, detached_job_wait_time);
        IFEND;
      PROCEND put_detached_job_wait_time;
?? OLDTITLE ??
?? NEWTITLE := 'put_integer', EJECT ??

{ PURPOSE:
{   The purpose of this request is to convert and display an integer value.
{
{ NOTES:
{   All values are displayed in base 10 (ten) notation.

      PROCEDURE put_integer
        (    title: string ( * );
             integer_value: integer);

        VAR
          number_string: ost$string;

        clp$convert_integer_to_string (integer_value, 10, FALSE, number_string, ignore_status);
        put_attribute (title, number_string.value (1, number_string.size));
      PROCEND put_integer;
?? OLDTITLE ??
?? NEWTITLE := 'put_job_qualifiers', EJECT ??

{ PURPOSE:
{   This procedure displays the names that represent the job qualifiers of a job.

      PROCEDURE put_job_qualifiers
        (    header: string ( * );
             job_qualifier_list: jmt$job_qualifier_list);

{ The "33" originates from a 31 character name plus a comma plus a space.

        CONST
          max_job_qualifier_string_size = 33 * jmc$maximum_job_qualifiers;

        VAR
          qualifier_index: 1 .. jmc$maximum_job_qualifiers,
          qualifier_string: string (max_job_qualifier_string_size),
          string_index: 1 .. max_job_qualifier_string_size + 2,
          string_size: 0 .. osc$max_name_size;

        qualifier_string (1) := '[';
        string_index := 2;

        FOR qualifier_index := 1 TO UPPERBOUND (job_qualifier_list) DO
          string_size := clp$trimmed_string_size (job_qualifier_list [qualifier_index]);
          IF string_size > 0 THEN
            qualifier_string (string_index, string_size) := job_qualifier_list [qualifier_index] (1,
                  string_size);
            string_index := string_index + string_size;
            qualifier_string (string_index, 2) := ', ';
            string_index := string_index + 2;
          IFEND;
        FOREND;
        IF string_index > 2 THEN
          string_index := string_index - 2;
        IFEND;
        qualifier_string (string_index) := ']';

        put_large_string (header, qualifier_string (1, string_index));
      PROCEND put_job_qualifiers;
?? OLDTITLE ??
?? NEWTITLE := 'put_large_string', EJECT ??

{ PURPOSE:
{   This procedure will display a large string value (> 31 characters).  This is done in such a fashion
{ that if the display requires it, the line will be split into continuation lines so as not to overflow
{ the lines on the display file.

      PROCEDURE put_large_string
        (    header: string ( * );
             large_string: string ( * <= clc$maximum_display_string_size));

        TYPE
          display_string_chunk = record
            position: integer,
            length: integer,
          recend;

        VAR
          start_option: amt$term_option,
          edited_header: string (tab_over),
          terminate_string: string (2),
          display_string_length: 0 .. clc$maximum_display_string_size,
          display_string: string (clc$maximum_display_string_size),
          display_string_chunk_count: 0 .. clc$max_display_string_chunk,
          display_string_chunk_array: array [1 .. clc$max_display_string_chunk] of display_string_chunk,
          index: integer;

?? NEWTITLE := 'build_display_string', EJECT ??

{ PURPOSE:
{   This procedure takes the string to be displayed and breaks it into "chunks" that will correspond to the
{ values to be displayed for each partial line.

        PROCEDURE build_display_string
          (    display_string: string ( * );
               length: 0 .. clc$maximum_display_string_size;
               width: amt$page_width;
           VAR count: 0 .. clc$max_display_string_chunk;
           VAR display_string_array: array [1 .. clc$max_display_string_chunk] of display_string_chunk);

          VAR
            current_character_position: 0 .. clc$maximum_display_string_size,
            break_position: 0 .. clc$maximum_display_string_size,
            current_length: 0 .. clc$maximum_display_string_size,
            remaining_text: 0 .. clc$maximum_display_string_size,
            starting_position: 1 .. clc$maximum_display_string_size;

          current_character_position := 0;
          remaining_text := length;
          count := 0;
          starting_position := 1;

          WHILE remaining_text > 0 DO
            count := count + 1;
            IF remaining_text <= width THEN
              display_string_array [count].position := starting_position;
              display_string_array [count].length := remaining_text;
              RETURN;
            IFEND;

            break_position := 0;
            REPEAT
              current_character_position := current_character_position + 1;
              IF (display_string (current_character_position) = ',') OR
                    (display_string (current_character_position) = ' ') THEN
                break_position := current_character_position;
              IFEND;
            UNTIL (current_character_position - starting_position) >= (width - 2);

            IF break_position > 0 THEN
              current_character_position := break_position;
            IFEND;

            current_length := current_character_position - starting_position;
            display_string_array [count].position := starting_position;
            display_string_array [count].length := current_length;
            starting_position := current_character_position;
            remaining_text := length - starting_position + 1;
          WHILEND;

        PROCEND build_display_string;
?? OLDTITLE ??
?? EJECT ??
        status.normal := TRUE;
        start_option := amc$start;
        edited_header := header;
        edited_header (tab_over - 2) := ':';
        terminate_string := '..';
        display_string_length := STRLENGTH (large_string);
        display_string := large_string (1, display_string_length);

        IF display_control.page_width < clc$narrow_page_width THEN
          clv$page_width := clc$narrow_page_width;
        ELSEIF display_control.page_width > clc$wide_page_width THEN
          clv$page_width := clc$wide_page_width;
        ELSE
          clv$page_width := display_control.page_width;
        IFEND;

        clp$put_partial_display (display_control, edited_header, clc$no_trim, start_option, status);
        IF NOT status.normal THEN
          EXIT jmp$display_attributes;
        IFEND;

        build_display_string (display_string, display_string_length, clv$page_width - tab_over,
              display_string_chunk_count, display_string_chunk_array);

        FOR index := 1 TO display_string_chunk_count DO
          IF index = display_string_chunk_count THEN
            terminate_string := ' ';
          IFEND;
          clp$put_partial_display (display_control, display_string
                (display_string_chunk_array [index].position, display_string_chunk_array [index].length),
                clc$no_trim, amc$continue, status);
          IF NOT status.normal THEN
            EXIT jmp$display_attributes;
          IFEND;
          clp$put_partial_display (display_control, terminate_string, clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            EXIT jmp$display_attributes;
          IFEND;
          IF index <> display_string_chunk_count THEN
            clp$new_display_line (display_control, clc$next_display_line, status);
            IF NOT status.normal THEN
              EXIT jmp$display_attributes;
            IFEND;
            clp$horizontal_tab_display (display_control, (tab_over + 1), status);
            IF NOT status.normal THEN
              EXIT jmp$display_attributes;
            IFEND;
          IFEND;
        FOREND;

      PROCEND put_large_string;
?? OLDTITLE ??
?? NEWTITLE := 'put_magnetic_tape_limit', EJECT ??

{ PURPOSE:
{   This procedure will display the magnetic_tape_limit attribute.

      PROCEDURE put_magnetic_tape_limit
        (    title: string ( * );
             magnetic_tape_limit: jmt$magnetic_tape_limit);

        IF magnetic_tape_limit = jmc$required_mag_tape_limit THEN
          put_name (title, lowercase_required);
        ELSEIF magnetic_tape_limit = jmc$system_default_mag_tape_lim THEN
          put_name (title, lowercase_system_default);
        ELSEIF magnetic_tape_limit = jmc$unlimited_mag_tape_limit THEN
          put_name (title, lowercase_unlimited);
        ELSEIF magnetic_tape_limit = jmc$unspecified_mag_tape_limit THEN
          put_name (title, lowercase_unspecified);
        ELSE
          put_integer (title, magnetic_tape_limit);
        IFEND;
      PROCEND put_magnetic_tape_limit;
?? OLDTITLE ??
?? NEWTITLE := 'put_maximum_working_set', EJECT ??

{ PURPOSE:
{   This procedure will display the maximum_working_set attribute.

      PROCEDURE put_maximum_working_set
        (    title: string ( * );
             maximum_working_set: jmt$working_set_size);

        IF maximum_working_set = jmc$required_working_set_size THEN
          put_name (title, lowercase_required);
        ELSEIF maximum_working_set = jmc$system_default_work_set_siz THEN
          put_name (title, lowercase_system_default);
        ELSEIF maximum_working_set = jmc$unlimited_working_set_size THEN
          put_name (title, lowercase_unlimited);
        ELSEIF maximum_working_set = jmc$unspecified_work_set_size THEN
          put_name (title, lowercase_unspecified);
        ELSE
          put_integer (title, maximum_working_set);
        IFEND;
      PROCEND put_maximum_working_set;
?? OLDTITLE ??
?? NEWTITLE := 'put_name', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to display a name value.  If the name value is the empty string
{ then the value "none" is displayed.

      PROCEDURE put_name
        (    title: string ( * );
             name: string ( * <= osc$max_name_size));

        VAR
          string_size: 0 .. osc$max_name_size,
          translated_name: ost$name;

        string_size := clp$trimmed_string_size (name);
        IF string_size = 0 THEN
          translated_name := 'none';
          string_size := 4;
        ELSE
          #TRANSLATE (osv$upper_to_lower, name (1, string_size), translated_name);
        IFEND;
        put_attribute (title, translated_name (1, string_size));
      PROCEND put_name;
?? OLDTITLE ??
?? NEWTITLE := 'put_sense_switches', EJECT ??

{ PURPOSE:
{   This procedure will display the sense switches given.

      PROCEDURE put_sense_switches
        (    header: string ( * );
             sense_switches: pmt$sense_switches);

{ The "3" originates from a 1 character numeral plus a comma plus a space.
{ There are eight sense switches.

        CONST
          max_sense_switch_string_size = 3 * 8;

        VAR
          switch_index: 1 .. 8,
          switch_string: string (max_sense_switch_string_size),
          string_index: 1 .. max_sense_switch_string_size + 1;

        switch_string (1) := '[';
        string_index := 2;

        FOR switch_index := 1 TO 8 DO
          IF switch_index IN sense_switches THEN
            switch_string (string_index) := $CHAR (switch_index + $INTEGER ('0'));
            string_index := string_index + 1;
            switch_string (string_index, 2) := ', ';
            string_index := string_index + 2;
          IFEND;
        FOREND;
        IF string_index > 2 THEN
          string_index := string_index - 2;
        IFEND;
        switch_string (string_index) := ']';

        put_attribute (header, switch_string (1, string_index));
      PROCEND put_sense_switches;
?? OLDTITLE ??
?? NEWTITLE := 'put_sru_limit', EJECT ??

{ PURPOSE:
{   This request will display the sru_limit attribute.

      PROCEDURE put_sru_limit
        (    title: string ( * );
             sru_limit: jmt$sru_limit);

        IF sru_limit = jmc$required_sru_limit THEN
          put_name (title, lowercase_required);
        ELSEIF sru_limit = jmc$system_default_sru_limit THEN
          put_name (title, lowercase_system_default);
        ELSEIF sru_limit = jmc$unlimited_sru_limit THEN
          put_name (title, lowercase_unlimited);
        ELSEIF sru_limit = jmc$unspecified_sru_limit THEN
          put_name (title, lowercase_unspecified);
        ELSE
          put_integer (title, sru_limit);
        IFEND;
      PROCEND put_sru_limit;
?? OLDTITLE ??
?? NEWTITLE := 'put_string', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display a string value surrounded by single quotes (apostrophes).

      PROCEDURE put_string
        (    title: string ( * );
             string_value: string ( * ));

        VAR
          string_size: ost$string_size,
          temp_string: string (osc$max_string_size),
          result_length: integer;

        string_size := clp$trimmed_string_size (string_value);
        IF string_size = 0 THEN
          temp_string := ''' ''';
          result_length := 3;
        ELSE
          STRINGREP (temp_string, result_length, '''', string_value (1, string_size), '''');
        IFEND;
        IF result_length > osc$max_name_size THEN
          put_large_string (title, temp_string (1, result_length));
        ELSE
          put_attribute (title, temp_string (1, result_length));
        IFEND;
      PROCEND put_string;
?? OLDTITLE ??
?? NEWTITLE := 'put_terminate_job_action_set', EJECT ??

      PROCEDURE put_terminate_job_action_set
        (    title: string ( * );
             terminate_job_action_set: jmt$terminate_job_action_set);

        CONST
          max_terj_action_string_size = ($INTEGER (jmc$tja_user_kill_enabled) + 1) *
                max_terminate_job_action_size;

        VAR
          action_index: jmt$terminate_job_action,
          action_string: string (max_terj_action_string_size),
          string_index: 1 .. max_terj_action_string_size + 1;

        action_string (1) := '(';
        string_index := 2;

        FOR action_index := LOWERVALUE (jmt$terminate_job_action) TO UPPERVALUE (jmt$terminate_job_action) DO
          IF action_index IN terminate_job_action_set THEN
            action_string (string_index, max_terminate_job_action_size) :=
                  terminate_job_action [action_index].value (1, terminate_job_action [action_index].size);
            string_index := string_index + terminate_job_action [action_index].size;
            action_string (string_index, 2) := ', ';
            string_index := string_index + 2;
          IFEND;
        FOREND;
        IF string_index > 2 THEN
          string_index := string_index - 2;
        IFEND;
        action_string (string_index) := ')';

        put_attribute (title, action_string (1, string_index));
      PROCEND put_terminate_job_action_set;
?? OLDTITLE ??
?? NEWTITLE := 'put_time_increment', EJECT ??

      PROCEDURE put_time_increment
        (    title: string ( * );
             time_increment: jmt$time_increment);

        VAR
          representation_p: ^clt$data_representation,
          scl_time_increment_value_p: ^clt$data_value,
          string_count_p: ^clt$data_representation_count,
          string_p: ^clt$string_value,
          string_size_p: ^clt$string_size,
          work_area_pp: ^^clt$work_area;

        IF time_increment.specified THEN
          PUSH scl_time_increment_value_p;
          scl_time_increment_value_p^.kind := clc$time_increment;
          PUSH scl_time_increment_value_p^.time_increment_value;
          scl_time_increment_value_p^.time_increment_value^ := time_increment.time_increment;
          clp$get_work_area (#RING (^work_area_pp), work_area_pp, status);
          IF NOT status.normal THEN
            EXIT jmp$display_attributes;
          IFEND;
          clp$convert_data_to_string (scl_time_increment_value_p, clc$data_source_representation,
                clc$max_string_size, work_area_pp^, representation_p, status);
          IF NOT status.normal THEN
            EXIT jmp$display_attributes;
          IFEND;
          NEXT string_count_p IN representation_p;
          NEXT string_size_p IN representation_p;
          NEXT string_p: [string_size_p^] IN representation_p;
          put_large_string (title, string_p^);
        ELSE
          put_name (title, '');
        IFEND;
      PROCEND put_time_increment;
?? OLDTITLE ??
?? EJECT ??
      status.normal := TRUE;

      CASE attribute.key OF
      = jmc$application_name =
        put_name ('Application_Name', attribute.application_name);

      = jmc$c170_os_type =
        put_name ('C170_OS_Type', c170_os_type [attribute.c170_os_type].
              value (1, c170_os_type [attribute.c170_os_type].size));

      = jmc$client_mainframe_id =
        put_name ('Client_Mainframe_Identifier', attribute.client_mainframe_id);

      = jmc$comment_banner =
        put_string ('Comment_Banner', attribute.comment_banner);

      = jmc$control_family =
        put_name ('Control_Family', attribute.control_family);

      = jmc$control_user =
        put_name ('Control_User', attribute.control_user);

      = jmc$copies =
        put_integer ('Copies', attribute.copies);

      = jmc$copies_printed =
        put_integer ('Copies_Printed', attribute.copies_printed);

      = jmc$cpu_time_limit =
        put_cpu_time_limit ('CPU_Time_Limit', attribute.cpu_time_limit);

      = jmc$cpu_time_used =
        put_cpu_time_used ('CPU_Time_Used', attribute.cpu_time_used);

      = jmc$cyclic_aging_interval =
        put_integer ('Cyclic_Aging_Interval', attribute.cyclic_aging_interval);

      = jmc$data_declaration =
        put_string ('Data_Declaration', attribute.data_declaration);

      = jmc$data_mode =
        put_name ('Data_Mode', data_mode [attribute.data_mode].value (1, data_mode [attribute.data_mode].
              size));

      = jmc$deferred_by_application =
        put_name ('Deferred_By_Application', boolean_string [attribute.deferred_by_application].
              value (1, boolean_string [attribute.deferred_by_application].size));

      = jmc$destination =
        put_string ('Destination', attribute.destination);

      = jmc$detached_job_wait_time =
        put_detached_job_wait_time ('Detached_Job_Wait_Time', attribute.detached_job_wait_time);

      = jmc$device =
        put_name ('Device', attribute.device);

      = jmc$device_type =
        put_name ('Device_Type', device_type [attribute.device_type].
              value (1, device_type [attribute.device_type].size));

      = jmc$dispatching_priority =
        put_name ('Dispatching_Priority', attribute.dispatching_priority);

      = jmc$display_message =
        IF attribute.display_message^.size > 0 THEN
          put_large_string ('Display_Message', attribute.display_message^.
                value (1, clp$trimmed_string_size (attribute.display_message^.value)));
        ELSE
          put_name ('Display_Message', '');
        IFEND;

      = jmc$earliest_print_time =
        put_date_time_conditional ('Earliest_Print_Time', attribute.earliest_print_time);

      = jmc$earliest_run_time =
        put_date_time_conditional ('Earliest_Run_Time', attribute.earliest_run_time);

      = jmc$external_characteristics =
        put_string ('External_Characteristics', attribute.external_characteristics);

      = jmc$file_position =
        put_integer ('File_Position', attribute.file_position);

      = jmc$file_size =
        put_integer ('File_Size', attribute.file_size);

      = jmc$forms_code =
        put_string ('Forms_Code', attribute.forms_code);

      = jmc$input_file_location =
        put_name ('Input_File_Location', input_file_location [attribute.input_file_location].
              value (1, input_file_location [attribute.input_file_location].size));

      = jmc$job_abort_disposition =
        put_name ('Job_Abort_Disposition', job_abort_disposition [attribute.job_abort_disposition].
              value (1, job_abort_disposition [attribute.job_abort_disposition].size));

      = jmc$job_class =
        put_name ('Job_Class', attribute.job_class);

      = jmc$job_class_position =
        IF attribute.job_class_position = 0 THEN
          put_name ('Job_Class_Position', '');
        ELSE
          put_integer ('Job_Class_Position', attribute.job_class_position);
        IFEND;

      = jmc$job_deferred_by_operator =
        put_name ('Job_Deferred_By_Operator', boolean_string [attribute.job_deferred_by_operator].
              value (1, boolean_string [attribute.job_deferred_by_operator].size));

      = jmc$job_deferred_by_user =
        put_name ('Job_Deferred_By_User', boolean_string [attribute.job_deferred_by_user].
              value (1, boolean_string [attribute.job_deferred_by_user].size));

      = jmc$job_destination_family =
        put_string ('Job_Destination', attribute.job_destination_family);

      = jmc$job_destination_usage =
        put_name ('Job_Destination_Usage', attribute.job_destination_usage);

      = jmc$job_execution_ring =
        IF attribute.job_execution_ring = osc$invalid_ring THEN
          put_name ('Job_Execution_Ring', 'nominal');
        ELSE
          put_integer ('Job_Execution_Ring', attribute.job_execution_ring);
        IFEND;

      = jmc$job_initiation_time =
        put_date_time_conditional ('Job_Initiation_Time', attribute.job_initiation_time);

      = jmc$job_mode =
        put_name ('Job_Mode', job_mode [attribute.job_mode].value (1, job_mode [attribute.job_mode].size));

      = jmc$job_priority =
        put_name ('Job_Priority', attribute.job_priority);

      = jmc$job_qualifier_list =
        put_job_qualifiers ('Job_Qualifier', attribute.job_qualifier_list^);

      = jmc$job_recovery_disposition =
        put_name ('Job_Recovery_Disposition', job_recovery_disposition [attribute.job_recovery_disposition].
              value (1, job_recovery_disposition [attribute.job_recovery_disposition].size));

      = jmc$job_size =
        put_integer ('Job_Size', attribute.job_size);

      = jmc$job_state =
        put_name ('Job_State', job_state [attribute.job_state].value (1, job_state [attribute.job_state].
              size));

      = jmc$job_submission_time =
        put_date_time ('Job_Submission_Time', attribute.job_submission_time);

      = jmc$latest_print_time =
        put_date_time_conditional ('Latest_Print_Time', attribute.latest_print_time);

      = jmc$latest_run_time =
        put_date_time_conditional ('Latest_Run_Time', attribute.latest_run_time);

      = jmc$login_account =
        put_name ('Login_Account', attribute.login_account);

      = jmc$login_family =
        put_name ('Login_Family', attribute.login_family);

      = jmc$login_project =
        put_name ('Login_Project', attribute.login_project);

      = jmc$login_user =
        put_name ('Login_User', attribute.login_user);

      = jmc$magnetic_tape_limit =
        put_magnetic_tape_limit ('Magnetic_Tape_Limit', attribute.magnetic_tape_limit);

      = jmc$maximum_working_set =
        put_maximum_working_set ('Maximum_Working_Set', attribute.maximum_working_set);

      = jmc$minimum_working_set =
        put_integer ('Minimum_Working_Set', attribute.minimum_working_set);

      = jmc$null_attribute =
        ;

      = jmc$operator_action_posted =
        put_name ('Operator_Action_Posted', boolean_string [attribute.operator_action_posted].
              value (1, boolean_string [attribute.operator_action_posted].size));

      = jmc$origin_application_name =
        put_name ('Originating_Application_Name', attribute.origin_application_name);

      = jmc$os_version =
        put_name ('OS_Version', attribute.os_version);

      = jmc$output_class =
        put_name ('Output_Class', attribute.output_class);

      = jmc$output_deferred_by_operator =
        put_name ('Output_Deferred_By_Operator', boolean_string [attribute.output_deferred_by_operator].
              value (1, boolean_string [attribute.output_deferred_by_operator].size));

      = jmc$output_deferred_by_user =
        put_name ('Output_Deferred_By_User', boolean_string [attribute.output_deferred_by_user].
              value (1, boolean_string [attribute.output_deferred_by_user].size));

      = jmc$output_destination =
        put_string ('Output_Destination', attribute.output_destination);

      = jmc$output_destination_family =
        put_name ('Operator_Family', attribute.output_destination_family);

      = jmc$output_destination_usage =
        put_name ('Output_Destination_Usage', attribute.output_destination_usage);

      = jmc$output_disposition =
        IF attribute.output_disposition.key = jmc$standard_output_path THEN
          put_large_string ('Output_Disposition', attribute.output_disposition.
                standard_output_path^ (1, clp$trimmed_string_size
                (attribute.output_disposition.standard_output_path^)));
        ELSE
          put_name ('Output_Disposition', output_disposition [attribute.output_disposition.key].
                value (1, output_disposition [attribute.output_disposition.key].size));
        IFEND;

      = jmc$output_priority =
        put_name ('Output_Priority', attribute.output_priority);

      = jmc$output_state =
        put_name ('Output_State', output_state [attribute.output_state].
              value (1, output_state [attribute.output_state].size));

      = jmc$output_submission_time =
        put_date_time ('Output_Submission_Time', attribute.output_submission_time);

      = jmc$page_aging_interval =
        put_integer ('Page_Aging_Interval', attribute.page_aging_interval);

      = jmc$page_faults =
        STRINGREP (temp_string, result_length, 'Assigned-', attribute.page_faults.new_pages_assigned,
              '  From Disk-', attribute.page_faults.pages_read_from_disk, '  Reclaimed-',
              attribute.page_faults.pages_reclaimed_from_memory);
        put_large_string ('Page_Faults', temp_string (1, result_length));

      = jmc$processing_phase =
        put_attribute ('Processing_Phase', processing_phase
              [translated_processing_phase (attribute.processing_phase)].
              value (1, processing_phase [translated_processing_phase (attribute.processing_phase)].size));

      = jmc$purge_delay =
        put_time_increment ('Purge_Delay', attribute.purge_delay^);

      = jmc$qfile_state =
        put_name ('State', qfile_state [attribute.qfile_state].value (1,
              qfile_state [attribute.qfile_state].size));

      = jmc$remote_host_directive =
        IF attribute.remote_host_directive^.size = 0 THEN
          put_string ('Remote_Host_Directive', '');
        ELSE
          put_string ('Remote_Host_Directive', attribute.remote_host_directive^.
                parameters (1, attribute.remote_host_directive^.size));
        IFEND;

      = jmc$routing_banner =
        put_string ('Routing_Banner', attribute.routing_banner);

      = jmc$sense_switches =
        put_sense_switches ('Sense_Switches', attribute.sense_switches);

      = jmc$server_mainframe_id =
        put_name ('Server_Mainframe_Identifier', attribute.server_mainframe_id);

      = jmc$service_class =
        put_name ('Service_Class', attribute.service_class);

      = jmc$site_information =
        put_string ('Site_Information', attribute.site_information^);

      = jmc$source_logical_id =
        put_name ('Source_Logical_ID', attribute.source_logical_id);

      = jmc$sru_limit =
        put_sru_limit ('SRU_limit', attribute.sru_limit);

      = jmc$station =
        put_name ('Station', attribute.station);

      = jmc$station_operator =
        put_name ('Operator_User', attribute.station_operator);

      = jmc$system_file_name =
        put_name ('System_File_Name', attribute.system_file_name);

      = jmc$system_job_name =
        put_name ('System_Job_Name', attribute.system_job_name);

      = jmc$terminate_job_action_set =
        put_terminate_job_action_set ('Terminate_Job_Action', attribute.terminate_job_action_set);

      = jmc$user_file_name =
        put_name ('User_File_Name', attribute.user_file_name);

      = jmc$user_information =
        put_string ('User_Information', attribute.user_information^);

      = jmc$user_job_name =
        put_name ('User_Job_Name', attribute.user_job_name);

      = jmc$vertical_print_density =
        CASE attribute.vertical_print_density OF
        = jmc$vertical_print_density_file =
          put_name ('Vertical_Print_Density', 'file');
        = jmc$vertical_print_density_none =
          put_name ('Vertical_Print_Density', '');
        = jmc$vertical_print_density_6 =
          put_name ('Vertical_Print_Density', 'six');
        ELSE
          put_name ('Vertical_Print_Density', 'eight');
        CASEND;

      = jmc$vfu_load_procedure =
        put_name ('VFU_Load_Procedure', attribute.vfu_load_procedure);

      ELSE
        put_name ('Undefined_Attribute', '');

      CASEND;
    PROCEND display_attribute;
?? OLDTITLE ??
?? EJECT ??

    VAR
      attribute_values_pp: ^^array [1 .. * ] of ^jmt$attribute_values,
      display_control: clt$display_control,
      ignore_status: ost$status,
      output_open: boolean,
      data_written: boolean,
      display_index: 0 .. jmc$maximum_attribute_index,
      object_index: integer,
      name_index: integer,
      string_size: ost$string_size,
      temp_string: string (osc$max_string_size);

    status.normal := TRUE;

    pmp$get_compact_date_time (current_date_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Set-up access to the array by converting it from a sequence to the expected pointer object.

    RESET attribute_values_seq;
    NEXT attribute_values_pp IN attribute_values_seq;

    output_open := FALSE;
    #SPOIL (output_open);
    osp$establish_block_exit_hndlr (^abort_handler);

    clp$open_display (file, ^clp$new_page_procedure, display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN
    IFEND;
    output_open := TRUE;
    #SPOIL (output_open);

    clv$titles_built := FALSE;
    clv$command_name := command_title;

  /display/
    BEGIN

    /display_all_objects/
      FOR object_index := 1 TO number_to_display DO
        data_written := FALSE;
        IF object_index > 1 THEN
          clp$new_display_line (display_control, 1, status);
          IF NOT status.normal THEN
            EXIT /display/;
          IFEND;
        ELSEIF NOT (display_control.page_format = amc$continuous_form) AND
              NOT (display_control.page_format = amc$untitled_form) THEN
          clp$new_display_page (display_control, status);
          IF NOT status.normal THEN
            EXIT /display/;
          IFEND;
        IFEND;

{ Display the header to augment each list of attributes.  If there are more lists
{ of attributes to be displayed, use the last header available.

        IF header_display_list_p <> NIL THEN
          IF object_index <= UPPERBOUND (header_display_list_p^) THEN
            put_header (header_display_list_p^ [object_index].value (1,
                  header_display_list_p^ [object_index].size));
          ELSE
            put_header (header_display_list_p^ [UPPERBOUND (header_display_list_p^)].
                  value (1, header_display_list_p^ [UPPERBOUND (header_display_list_p^)].size));
          IFEND;
        IFEND;

      /display_all_attributes/
        FOR display_index := 1 TO UPPERBOUND (attribute_values_pp^^ [object_index]^) DO
          display_attribute (attribute_values_pp^^ [object_index]^ [display_index], status);
          IF NOT status.normal THEN
            EXIT /display_all_objects/;
          IFEND;
        FOREND /display_all_attributes/;
      FOREND /display_all_objects/;

      IF (not_found_name_list_p <> NIL) AND (not_found_name_list_count > 0) THEN
        FOR name_index := 1 TO not_found_name_list_count DO
          IF not_found_name_list_p^ [name_index].kind = jmc$system_supplied_name THEN
            #TRANSLATE (osv$upper_to_lower, not_found_name_list_p^ [name_index].system_supplied_name,
                  temp_string);
          ELSE
            string_size := clp$trimmed_string_size (not_found_name_list_p^ [name_index].user_supplied_name);
            #TRANSLATE (osv$upper_to_lower, not_found_name_list_p^ [name_index].
                  user_supplied_name (1, string_size), temp_string);
          IFEND;

{ If anything has been displayed, a blank line must be added otherwise a new page may be necessary.

          IF (number_to_display > 0) OR (name_index > 1) THEN
            clp$new_display_line (display_control, 1, status);
            IF NOT status.normal THEN
              EXIT /display/;
            IFEND;
          ELSEIF NOT (display_control.page_format = amc$continuous_form) AND
                NOT (display_control.page_format = amc$untitled_form) THEN
            clp$new_display_page (display_control, status);
            IF NOT status.normal THEN
              EXIT /display/;
            IFEND;
          IFEND;
          put_attribute ('Name Not Found', temp_string);
        FOREND;
      ELSE
        IF number_to_display = 0 THEN
          IF (display_control.page_format <> amc$continuous_form) AND
                (display_control.page_format <> amc$untitled_form) THEN
            clp$new_display_page (display_control, status);
            IF NOT status.normal THEN
              EXIT /display/;
            IFEND;
          IFEND;
          put_attribute ('None Were Found.', '');
        IFEND;
      IFEND;
    END /display/;

    clp$close_display (display_control, ignore_status);
    output_open := FALSE;
    #SPOIL (output_open);
    osp$disestablish_cond_handler;

  PROCEND jmp$display_attributes;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$get_attribute_index', EJECT ??
*copy jmh$get_attribute_index

  PROCEDURE [XDCL, #GATE] jmp$get_attribute_index
    (    attribute_name: string ( * <= osc$max_name_size);
     VAR attribute_index: jmt$attribute_keys);

    VAR
      low_index: 1 .. alphabetical_attribute_count + 1,
      high_index: 0 .. alphabetical_attribute_count,
      temp: integer,
      current_index: 1 .. alphabetical_attribute_count;

    low_index := 1;
    high_index := alphabetical_attribute_count;
    REPEAT
      temp := low_index + high_index;
      current_index := temp DIV 2;
      IF attribute_name = alphabetical_attribute_list [current_index].attribute_name THEN
        attribute_index := alphabetical_attribute_list [current_index].attribute_index;
        RETURN;
      ELSEIF attribute_name > alphabetical_attribute_list [current_index].attribute_name THEN
        low_index := current_index + 1;
      ELSE
        high_index := current_index - 1;
      IFEND;
    UNTIL low_index > high_index;
    attribute_index := jmc$unknown_attribute;
  PROCEND jmp$get_attribute_index;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$get_attribute_name', EJECT ??
*copy jmh$get_attribute_name

  PROCEDURE [XDCL, #GATE] jmp$get_attribute_name
    (    attribute_index: jmt$attribute_keys;
     VAR attribute_name: ost$name);

    VAR
      low_index: 1 .. indexed_attribute_count + 1,
      high_index: 0 .. indexed_attribute_count,
      temp: integer,
      current_index: 1 .. indexed_attribute_count;

    low_index := 1;
    high_index := indexed_attribute_count;
    REPEAT
      temp := low_index + high_index;
      current_index := temp DIV 2;
      IF attribute_index = indexed_attribute_list [current_index].attribute_index THEN
        attribute_name := indexed_attribute_list [current_index].attribute_name;
        RETURN;
      ELSEIF attribute_index > indexed_attribute_list [current_index].attribute_index THEN
        low_index := current_index + 1;
      ELSE
        high_index := current_index - 1;
      IFEND;
    UNTIL low_index > high_index;
    attribute_name := unknown_attribute_name;
  PROCEND jmp$get_attribute_name;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$get_result_size', EJECT ??
*copy jmh$get_result_size

  PROCEDURE [XDCL, #GATE] jmp$get_result_size
    (    number_of_items: ost$non_negative_integers;
         results_keys_seq_p: ^SEQ ( * );
     VAR size: ost$segment_length);

    VAR
      application_attr_size_added: boolean,
      seq_p: ^SEQ ( * ),
      result_keys_p: ^jmt$results_keys,
      result_index: ost$positive_integers,
      number_of_keys: ost$positive_integers;


    application_attr_size_added := FALSE;
    size := 0;
    IF results_keys_seq_p <> NIL THEN
      seq_p := results_keys_seq_p;
      number_of_keys := #SIZE (seq_p^) DIV #SIZE (jmt$attribute_keys);
      IF number_of_keys > 0 THEN
        NEXT result_keys_p: [1 .. number_of_keys] IN seq_p;

        size := #SIZE (jmt$attribute_values: [1 .. 1]) + (number_of_keys * #SIZE (jmt$attribute_value));
        FOR result_index := 1 TO number_of_keys DO
          CASE result_keys_p^ [result_index] OF
          = jmc$application_attributes_1, jmc$application_attributes_2, jmc$application_attributes_3,
                jmc$application_attributes_4, jmc$application_attributes_5, jmc$application_attributes_6,
                jmc$application_attributes_7, jmc$application_attributes_8, jmc$application_attributes_9,
                jmc$application_attributes_10 =
            IF NOT application_attr_size_added THEN
              application_attr_size_added := TRUE;
              size := size + jmc$max_qfile_appl_attr_size;
            IFEND;
          = jmc$display_message =
            size := size + #SIZE (jmt$display_message);
          = jmc$job_qualifier_list =
            size := size + #SIZE (jmt$job_qualifier_list: [1 .. jmc$maximum_job_qualifiers]);
          = jmc$output_disposition =
            size := size + #SIZE (fst$path);
          = jmc$purge_delay =
            size := size + #SIZE (jmt$time_increment);
          = jmc$remote_host_directive =
            size := size + #SIZE (jmt$remote_host_directive);
          = jmc$site_information =
            size := size + #SIZE (jmt$site_information);
          = jmc$user_information =
            size := size + #SIZE (jmt$user_information);
          ELSE
          CASEND;
        FOREND;
        size := size * number_of_items;
      IFEND;
    IFEND;
  PROCEND jmp$get_result_size;
?? OLDTITLE ??
MODEND jmm$attribute_display_functions;
*DECK DECK=JMM$CONVERT_TO_SCHEDULER_TYPES EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Scheduling : convert_to_scheduler_types' ??
MODULE jmm$convert_to_scheduler_types;

{ PURPOSE:
{   This module provides the logic to translate scheduler tables to
{   profile objects and profile objects to scheduler tables.  This
{   is the only module that specifically manipulates scheduler tables
{   within the modules that make up MANAGE_ACTIVE_SCHEDULING and
{   ADMINISTER_SCHEDULING.
{
{ DESIGN:
{   Contains one routine to translate profile objects to scheduler tables
{   and one routine to translate scheduler tables to objects.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc jmc$attribute_keyword_offsets
*copyc jmc$profile_constants
*copyc jmt$application_index
*copyc jmt$application_attributes
*copyc jmt$application_table
*copyc jmt$dispatching_control
*copyc jmt$job_category_data
*copyc jmt$job_class_attributes
*copyc jmt$job_class_table
*copyc jmt$job_scheduler_table
*copyc jmt$output_class_attributes
*copyc jmt$profile_data
*copyc jmt$service_class_attributes
*copyc jmt$service_class_table
*copyc jmp$delete_attributes
*copyc jmp$get_application_record
*copyc jmp$get_attributes_for_display
*copyc jmp$get_category_data
*copyc jmp$get_defined_classes
*copyc jmp$get_job_class_record
*copyc jmp$get_scheduler_table
*copyc jmp$get_service_class_record
*copyc jmp$internal_error
*copyc pmp$convert_mainframe_to_binary
*copyc jmv$object_definition
*copyc jmv$object_heap
*copyc jmv$working_storage
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    microseconds_per_millisecond = 1000,
    milliseconds_per_second = 1000,
    microseconds_per_second = milliseconds_per_second * 1000;

  CONST
    dispatching_priority_offset = 1;

?? TITLE := ' build_shell', EJECT ??

{ PURPOSE:
{   Build an attribute shell so that the class attributes can be just stored
{   with appropriate assignment statements.
{
{ DESIGN:
{   Use the attribute description to create and empty shell of attributes of
{   the desired object type.
{
{ NOTES:
{   List attributes must be handled by the caller seperately or by calling
{   this routine to build just that part of the attribute structure when
{   the size of the list is known.

  PROCEDURE build_shell
    (    attribute_definition: jmt$profile_declaration;
         list_length: integer;
     VAR new_attribute: jmt$object_attribute);

    VAR
      i: integer;

    new_attribute.kind := attribute_definition.kind;
    CASE attribute_definition.kind OF
    = jmc$list, jmc$editable_list =
      IF list_length > 0 THEN
        ALLOCATE new_attribute.attribute_list: [1 .. list_length] IN
              jmv$object_heap^;
        IF new_attribute.attribute_list = NIL THEN
          jmp$internal_error (87);
        IFEND;
        FOR i := 1 TO list_length DO
          build_shell (attribute_definition.declarations^ [1]^, 0,
                new_attribute.attribute_list^ [i]);
        FOREND;
      ELSE
        new_attribute.kind := jmc$empty;
      IFEND;
    = jmc$type =
      ALLOCATE new_attribute.attribute_list:
            [1 .. attribute_definition.count] IN jmv$object_heap^;
      IF new_attribute.attribute_list = NIL THEN
        jmp$internal_error (88);
      IFEND;
      FOR i := 1 TO attribute_definition.count DO
        build_shell (attribute_definition.declarations^ [i]^, 0,
              new_attribute.attribute_list^ [i]);
      FOREND;
    = jmc$range =
      ALLOCATE new_attribute.attribute_list: [1 .. 2] IN jmv$object_heap^;
      IF new_attribute.attribute_list = NIL THEN
        jmp$internal_error (89);
      IFEND;
      FOR i := 1 TO 2 DO
        build_shell (attribute_definition.declarations^ [1]^, 0,
              new_attribute.attribute_list^ [i]);
      FOREND;
    = jmc$name =
      ALLOCATE new_attribute.name IN jmv$object_heap^;
      IF new_attribute.name = NIL THEN
        jmp$internal_error (90);
      IFEND;
    = jmc$file =
      new_attribute.kind := jmc$empty;
    ELSE
    CASEND;
  PROCEND build_shell;
?? TITLE := '[XDCL] jmp$build_category_object', EJECT ??

{ PURPOSE:
{   Builds an object containing the system category information.
{
{ DESIGN:
{   Fetch the job category data.  Create a dummy job category object and
{   into one statistic field place the data from the category sequence.
{   Into the other statistic place the data from the set array.

  PROCEDURE [XDCL] jmp$build_category_object
    (VAR profile: jmt$profile_data;
     VAR status: ost$status);

?? NEWTITLE := ' build_category_list', EJECT ??

{ PURPOSE:
{   Builds an attribute list of categories from a category set.
{
{ DESIGN:
{   Define a category object for each bit set in the category set.  If the
{   category name already exists then use the existing object in the list.
{   Build a list to pass back the list of category object references.

    PROCEDURE build_category_list
      (    categories: jmt$job_category_set;
       VAR attribute: jmt$object_attribute);

      VAR
        job_category: jmt$profile_object_reference,
        list_size: integer,
        list_index: integer;

      IF categories = $jmt$job_category_set [] THEN
        attribute.kind := jmc$none;
        RETURN;
      IFEND;

      list_size := 0;
      job_category := profile.objects [jmc$profile_category];
      WHILE job_category <> NIL DO
        IF (job_category^.index - 1) IN categories THEN
          list_size := list_size + 1;
        IFEND;
        job_category := job_category^.next_object;
      WHILEND;

      attribute.kind := jmc$list;
      ALLOCATE attribute.attribute_list: [1 .. list_size] IN jmv$object_heap^;
      IF attribute.attribute_list = NIL THEN
        jmp$internal_error (91);
      IFEND;

      list_index := 0;
      job_category := profile.objects [jmc$profile_category];
      WHILE job_category <> NIL DO
        IF (job_category^.index - 1) IN categories THEN
          list_index := list_index + 1;
          attribute.attribute_list^ [list_index].kind := jmc$object;
          attribute.attribute_list^ [list_index].object_p := job_category;
          job_category^.references := job_category^.references + 1;
        IFEND;
        job_category := job_category^.next_object;
      WHILEND;
    PROCEND build_category_list;

?? OLDTITLE, EJECT ??

    VAR
      i: integer,
      s: ost$name,
      job_category: jmt$profile_object_reference,
      category_data: jmt$job_category_data,
      list_size: integer,
      list_index: integer,
      cik: jmt$job_category_item_kind,
      category_item: ^jmt$job_category_item,
      item_display: ^jmt$object_attribute_list,
      set_value_display: ^jmt$object_attribute_list,
      category_attributes: ^jmt$object_attribute_list,
      category_definition: jmt$profile_declaration,
      attribute: jmt$object_attribute;

    VAR
      convert: record
        case boolean of
        = TRUE =
          offset: 0 .. 0ffffffff(16),
        = FALSE =
          category_reference: jmt$job_category_reference,
        casend,
      recend;

    VAR
      item_name: [STATIC] array [jmt$job_category_item_kind] of ost$name :=
            ['cpu_time_limit', 'sru_time_limit', 'magnetic_tape_limit',
            'working_set', 'login_account', 'login_project', 'login_family',
            'login_user', 'user_job_name', 'original_application_name',
            'job_mode', 'job_priority', 'job_qualifier', 'or_conditions'];

    jmp$get_category_data (category_data, jmv$working_storage, status);

    ALLOCATE job_category IN jmv$object_heap^;
    IF job_category = NIL THEN
      jmp$internal_error (92);
    IFEND;
    job_category^.name := 'Category_structure';
    job_category^.kind := jmc$profile_category;
    job_category^.index := 1;
    job_category^.definition_id := 'Category_structure';
    job_category^.references := 0;
    category_definition := jmv$object_definition [jmc$profile_category].
          declaration;
    build_shell (category_definition, 0, attribute);
    category_attributes := attribute.attribute_list;

    IF category_data.item_list <> NIL THEN
      list_size := #SIZE (category_data.item_list^) DIV
            #SIZE (jmt$job_category_item);
      RESET category_data.item_list;

      build_shell (category_definition.declarations^ [jmc$c_data_display]^,
            list_size, category_attributes^ [jmc$c_data_display]);

      FOR list_index := 1 TO list_size DO
        NEXT category_item IN category_data.item_list;
        item_display := category_attributes^ [jmc$c_data_display].
              attribute_list^ [list_index].attribute_list;

        convert.category_reference := category_item^.skip_item;
        item_display^ [1].number := convert.offset DIV
              #SIZE (jmt$job_category_item);

        convert.category_reference := category_item^.next_item;
        item_display^ [2].number := convert.offset DIV
              #SIZE (jmt$job_category_item);

        build_category_list (category_item^.categories, item_display^ [3]);
        item_display^ [4].name^ := item_name [category_item^.kind];
        CASE category_item^.kind OF
        = jmc$ca_cpu_time_limit, jmc$ca_sru_time_limit, jmc$ca_mag_tape_limit,
              jmc$ca_working_set =
          item_display^ [5].kind := jmc$number;
          item_display^ [5].number := category_item^.number;
        = jmc$ca_or_conditions =
          build_category_list (category_item^.members, item_display^ [5]);
        ELSE
          item_display^ [5].kind := jmc$name;
          ALLOCATE item_display^ [5].name IN jmv$object_heap^;
          IF item_display = NIL THEN
            jmp$internal_error (93);
          IFEND;
          item_display^ [5].name^ := category_item^.name;
        CASEND;
      FOREND;
    IFEND;

    list_size := $INTEGER (UPPERVALUE (cik)) + 1;
    build_shell (category_definition.declarations^ [jmc$c_set_display]^,
          list_size, category_attributes^ [jmc$c_set_display]);
    set_value_display := category_attributes^ [jmc$c_set_display].
          attribute_list;

    FOR cik := LOWERBOUND (category_data.initial_set_values)
          TO UPPERBOUND (category_data.initial_set_values) DO
      list_index := $INTEGER (cik) + 1;
      set_value_display^ [list_index].attribute_list^ [1].
            name^ := item_name [cik];
      build_category_list (category_data.initial_set_values [cik],
            set_value_display^ [list_index].attribute_list^ [2]);
    FOREND;

    job_category^.attributes := attribute;
    job_category^.next_object := profile.objects [jmc$profile_category];
    profile.objects [jmc$profile_category] := job_category;

    job_category := job_category^.next_object;
    WHILE job_category <> NIL DO
      s := job_category^.name;
      i := 31;
      WHILE s (i) = ' ' DO
        i := i - 1;
      WHILEND;
      STRINGREP (job_category^.name, i, s (1, i), job_category^.index);
      job_category := job_category^.next_object;
    WHILEND;

  PROCEND jmp$build_category_object;

?? TITLE := '[XDCL] jmp$build_profile_from_system', EJECT ??

{ PURPOSE:
{   Builds the objects and attributes necessary to describe the current
{   system profile.
{
{ DESIGN:
{   Obtain the list of job, service, application class names from the
{   system.  Build an object of the appropriate type for each name
{   obtained and then build the attributes for that class.
{
{ NOTES:
{   This routine should only be used to build a profile either to
{   verify the system tables or to construct something good enough to
{   be able to activate another profile.

  PROCEDURE [XDCL] jmp$build_profile_from_system
    (VAR profile: jmt$profile_data;
     VAR status: ost$status);

    VAR
      job_class_list: array [1 .. jmc$maximum_job_classes] of
            jmt$profile_object_reference,
      service_class_list: array [1 .. jmc$maximum_service_classes] of
            jmt$profile_object_reference,
      application_list: array [1 .. jmc$maximum_application_index] of
            jmt$profile_object_reference,
      job_category_list: array [1 .. jmc$maximum_job_categories + 1] of
            jmt$profile_object_reference;

    VAR
      cpu_quantum_time: ost$task_time_slice;

?? NEWTITLE := ' build_application_object', EJECT ??

{ PURPOSE:
{   Builds an application object with the specified name.
{
{ DESIGN:
{   Fetch the application record for the specified application name.  Set
{   the name, kind, and definition_id of the object.  Store the attributes
{   from the application record into the application attribute shell.

    PROCEDURE build_application_object
      (    application_name: jmt$application_name;
           application_index: integer;
       VAR application: jmt$profile_object;
       VAR status: ost$status);

      VAR
        application_table: jmt$application_attributes,
        application_attributes: ^jmt$object_attribute_list,
        service_class: jmt$profile_object_reference,
        attributes: jmt$object_attribute;

      jmp$get_application_record (application_name, application_table, status);

      application.kind := jmc$profile_application;
      application.name := application_table.name;
      application.changed := FALSE;
      application.definition_id := application_table.profile_identification;
      application.index := application_index;
      application.references := 0;
      build_shell (jmv$object_definition [application.kind].declaration, 0,
            attributes);
      application_attributes := attributes.attribute_list;

      application_attributes^ [jmc$ap_definition_name].name^ :=
            application_table.profile_identification;

{   Group definition attributes

      application_attributes^ [jmc$ap_enable_application_sched].bool :=
            application_table.enable_application_scheduling;

      IF application_table.service_class_index = 0 THEN
        application_attributes^ [jmc$ap_service_class].kind := jmc$empty;
      ELSE
        service_class := service_class_list
              [application_table.service_class_index];
        application_attributes^ [jmc$ap_service_class].object_p :=
              service_class;
        service_class^.references := service_class^.references + 1;
      IFEND;

{   Group control attributes

      application_attributes^ [jmc$ap_cyclic_aging_interval].number :=
            application_table.cyclic_aging_interval;
      application_attributes^ [jmc$ap_maximum_working_set].number :=
            application_table.maximum_working_set;
      application_attributes^ [jmc$ap_minimum_working_set].number :=
            application_table.minimum_working_set;
      application_attributes^ [jmc$ap_page_aging_interval].number :=
            application_table.page_aging_interval;

      application.attributes := attributes;
    PROCEND build_application_object;
?? TITLE := ' build_category_list', EJECT ??

{ PURPOSE:
{   Builds a list of categories from a category set.
{
{ DESIGN:
{   Define a category object for each bit set in the category set.  If the
{   category name already exists then use the existing category object.
{   Build a list to pass back the category object references.

    PROCEDURE build_category_list
      (    categories: jmt$job_category_set;
       VAR attribute: jmt$object_attribute);

      VAR
        job_category_name: string (31),
        job_category: jmt$profile_object_reference,
        name_length: integer,
        list_size: integer,
        list_index: integer,
        category_index: integer;

      IF categories = $jmt$job_category_set [] THEN
        attribute.kind := jmc$none;
        RETURN;
      IFEND;

      list_size := 0;
      FOR category_index := 1 TO UPPERBOUND (job_category_list) DO
        IF (category_index - 1) IN categories THEN
          list_size := list_size + 1;
          IF job_category_list [category_index] = NIL THEN
            ALLOCATE job_category IN jmv$object_heap^;
            IF job_category = NIL THEN
              jmp$internal_error (94);
            IFEND;
            STRINGREP (job_category_name, name_length, 'CATEGORY',
                  category_index);
            job_category_name (9) := '_';
            job_category^.name := job_category_name (1, name_length);
            job_category^.kind := jmc$profile_category;
            job_category^.index := category_index;
            job_category^.changed := FALSE;
            job_category^.definition_id := 'Category_structure';
            job_category^.attributes.kind := jmc$empty;
            job_category^.references := 0;
            job_category^.next_object := NIL;
            job_category_list [category_index] := job_category;
          IFEND;
        IFEND;
      FOREND;

      attribute.kind := jmc$list;
      ALLOCATE attribute.attribute_list: [1 .. list_size] IN jmv$object_heap^;
      IF attribute.attribute_list = NIL THEN
        jmp$internal_error (95);
      IFEND;
      list_index := 0;
      FOR category_index := 1 TO UPPERBOUND (job_category_list) DO
        IF (category_index - 1) IN categories THEN
          list_index := list_index + 1;
          attribute.attribute_list^ [list_index].kind := jmc$object;
          job_category := job_category_list [category_index];
          attribute.attribute_list^ [list_index].object_p := job_category;
          job_category^.references := job_category^.references + 1;
        IFEND;
      FOREND;
    PROCEND build_category_list;
?? TITLE := 'build_category_objects', EJECT ??

{ PURPOSE:
{   builds the category objects for the profile.
{
{ DESIGN:
{   Fetch the job category data.  Or all elements of the category set
{   array together and build a category object for each element in the
{   category set.

    PROCEDURE build_category_objects
      (VAR status: ost$status);

      VAR
        job_category: jmt$profile_object_reference,
        category_data: jmt$job_category_data,
        categories: jmt$job_category_set,
        cik: jmt$job_category_item_kind,
        category_name: ost$name,
        category_index: integer,
        name_length: integer;

      jmp$get_category_data (category_data, jmv$working_storage, status);

      categories := $jmt$job_category_set [];
      FOR cik := LOWERBOUND (category_data.initial_set_values)
            TO UPPERBOUND (category_data.initial_set_values) DO
        categories := categories + category_data.initial_set_values [cik];
      FOREND;

      FOR category_index := 1 TO UPPERBOUND (job_category_list) DO
        IF (category_index - 1) IN categories THEN
          ALLOCATE job_category IN jmv$object_heap^;
          IF job_category = NIL THEN
            jmp$internal_error (96);
          IFEND;
          job_category^.name := category_data.
                category_names^ [category_index - 1].name;
          job_category^.kind := jmc$profile_category;
          job_category^.index := category_index;
          job_category^.definition_id := category_data.
                category_names^ [category_index - 1].definition_name;
          job_category^.attributes.kind := jmc$empty;
          job_category^.references := 0;
          job_category^.changed := FALSE;
          job_category^.next_object := NIL;
          job_category_list [category_index] := job_category;
        ELSE
          job_category_list [category_index] := NIL;
        IFEND;
      FOREND;

    PROCEND build_category_objects;

?? TITLE := ' build_controls_object', EJECT ??

{ PURPOSE:
{   Builds a controls object for the running mainframe.
{
{ DESIGN:
{   Set the name, kind, and definition_id of the object.  Store the attributes
{   from the job_scheduler_table into the controls attribute shell.
{
{ NOTES:
{   The following attribute must be converted back to external units:
{     idle_dispatching_queue_time.

    PROCEDURE build_controls_object
      (VAR controls: jmt$profile_object;
       VAR cpu_quantum_time: ost$task_time_slice;
       VAR status: ost$status);

      VAR
        attributes: jmt$object_attribute,
        controls_attributes: ^jmt$object_attribute_list,
        controls_definition: jmt$profile_declaration,
        dispatching_allocation: ^jmt$object_attribute_list,
        dispatching_priority: jmt$dispatching_priority,
        i: integer,
        job_scheduler_table: jmt$job_scheduler_table,
        mainframe_count: integer,
        other_controls: jmt$profile_object_reference,
        priority_control: ^jmt$object_attribute_list;

      jmp$get_scheduler_table (job_scheduler_table, jmv$working_storage,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      controls.kind := jmc$profile_controls;
      controls.name := job_scheduler_table.validation_categories_p^ [1].
            mainframe_id;
      controls.changed := FALSE;
      controls.next_object := NIL;
      controls.references := 0;
      controls.index := 1;
      controls_definition := jmv$object_definition [controls.kind].declaration;
      cpu_quantum_time := job_scheduler_table.cpu_quantum_time;
      build_shell (controls_definition, 0, attributes);
      controls_attributes := attributes.attribute_list;

      controls_attributes^ [jmc$ct_profile_identification].name^ :=
            job_scheduler_table.profile_identification;

{   Group definition attributes

      controls_attributes^ [jmc$ct_abbreviation].name^ := 'UNKNOWN';
      controls_attributes^ [jmc$ct_cpu_quantum_time].number :=
            job_scheduler_table.cpu_quantum_time;
      controls_attributes^ [jmc$ct_enable_job_leveling].bool :=
            job_scheduler_table.enable_job_leveling;
      controls_attributes^ [jmc$ct_job_leveling_interval].number :=
            job_scheduler_table.job_leveling_interval;
      controls_attributes^ [jmc$ct_service_calc_interval].number :=
            job_scheduler_table.service_calculation_interval;

{   Group control attributes

      controls_attributes^ [jmc$ct_idle_disp_queue_time].number :=
            job_scheduler_table.idle_dispatching_queue_time DIV
            microseconds_per_second;
      controls_attributes^ [jmc$ct_scheduling_memory_levels].
            attribute_list^ [1].number := job_scheduler_table.
            scheduling_memory_levels.target;
      controls_attributes^ [jmc$ct_scheduling_memory_levels].
            attribute_list^ [2].number := job_scheduler_table.
            scheduling_memory_levels.thrashing;
      controls_attributes^ [jmc$ct_cpu_dispatching_interval].number :=
            job_scheduler_table.dispatching_allocation_interval;

      build_shell (controls_definition.declarations^ [
            jmc$ct_dispatching_allocation]^, 8,
            controls_attributes^ [jmc$ct_dispatching_allocation]);
      FOR dispatching_priority := jmc$priority_p1 TO jmc$priority_p8 DO
        dispatching_allocation := controls_attributes^ [
              jmc$ct_dispatching_allocation].attribute_list^ [
              dispatching_priority - dispatching_priority_offset].
              attribute_list;
        dispatching_allocation^ [1].attribute_list^ [1].number :=
              dispatching_priority - dispatching_priority_offset;
        dispatching_allocation^ [1].attribute_list^ [2].kind := jmc$empty;
        dispatching_allocation^ [2].number :=
              job_scheduler_table.cpu_dispatching_allocation [
              dispatching_priority].minimum;
        dispatching_allocation^ [3].number :=
              job_scheduler_table.cpu_dispatching_allocation [
              dispatching_priority].maximum;
        dispatching_allocation^ [4].bool :=
              job_scheduler_table.cpu_dispatching_allocation [
              dispatching_priority].enforce_maximum;
      FOREND;

      build_shell (controls_definition.declarations^ [
            jmc$ct_dual_state_prio_control]^,
            10, controls_attributes^ [jmc$ct_dual_state_prio_control]);
      FOR dispatching_priority := jmc$priority_p1 TO jmc$priority_p10 DO
        priority_control := controls_attributes^ [
              jmc$ct_dual_state_prio_control].attribute_list^ [
              dispatching_priority - dispatching_priority_offset].
              attribute_list;
        priority_control^ [1].attribute_list^ [1].number :=
              dispatching_priority - dispatching_priority_offset;
        priority_control^ [1].attribute_list^ [2].kind := jmc$empty;
        priority_control^ [2].number := job_scheduler_table.
              dual_state_priority_control [dispatching_priority].priority;
        priority_control^ [3].number := job_scheduler_table.
              dual_state_priority_control [dispatching_priority].subpriority;
      FOREND;

      build_category_list (job_scheduler_table.initiation_required_categories,
            controls_attributes^ [jmc$ct_ini_required_categories]);
      build_category_list (job_scheduler_table.initiation_excluded_categories,
            controls_attributes^ [jmc$ct_ini_excluded_categories]);

{ Priority Group.

      controls_attributes^ [jmc$ct_job_leveling_prio_bias].number :=
            job_scheduler_table.job_leveling_priority_bias;

{ Membership Group.

      build_category_list (job_scheduler_table.validation_categories_p^ [1].
            required, controls_attributes^ [jmc$ct_val_required_categories]);
      build_category_list (job_scheduler_table.validation_categories_p^ [1].
            excluded, controls_attributes^ [jmc$ct_val_excluded_categories]);

      controls.attributes := attributes;
      mainframe_count := UPPERBOUND (job_scheduler_table.
            validation_categories_p^);
      FOR i := mainframe_count DOWNTO 2 DO
        ALLOCATE other_controls IN jmv$object_heap^;
        IF other_controls = NIL THEN
          jmp$internal_error (97);
        IFEND;
        other_controls^.kind := jmc$profile_controls;
        other_controls^.name := job_scheduler_table.
              validation_categories_p^ [i].mainframe_id;
        other_controls^.changed := FALSE;
        other_controls^.index := mainframe_count;
        build_shell (controls_definition, 0, attributes);

        controls_attributes := attributes.attribute_list;

        build_category_list (job_scheduler_table.validation_categories_p^ [i].
              required, controls_attributes^ [jmc$ct_val_required_categories]);
        build_category_list (job_scheduler_table.validation_categories_p^ [i].
              excluded, controls_attributes^ [jmc$ct_val_excluded_categories]);

        controls_attributes^ [jmc$ct_abbreviation].name^ := 'UNKNOWN';
        controls_attributes^ [jmc$ct_profile_identification].name^ :=
              'NO_PROFILE_IDENTIFICATION';

        other_controls^.attributes := attributes;
        other_controls^.next_object := controls.next_object;
        controls.next_object := other_controls;
      FOREND;
      profile.count [jmc$profile_controls] := mainframe_count;
    PROCEND build_controls_object;
?? TITLE := ' build_job_class_object', EJECT ??

{ PURPOSE:
{   Builds an job class object for the specified index.
{
{ DESIGN:
{   Fetch the job class record for the specified index.  Set the name, kind,
{   and definition_id of the object.  Store the attributes from the job
{   class record into the job class attribute shell.
{
{ NOTES:
{   The service classes must be created first since the job classes reference
{   service classes.
{
{   The following attribute must be converted back to external units:
{     initiation_age_interval.

    PROCEDURE build_job_class_object
      (    job_class_index: jmt$job_class;
       VAR job_class: jmt$profile_object;
       VAR status: ost$status);

      VAR
        job_class_table: jmt$job_class_attributes;

      VAR
        job_class_definition: jmt$profile_declaration,
        job_class_attributes: ^jmt$object_attribute_list,
        delivery_priority: ^jmt$object_attribute_list,
        selection_priority: ^jmt$object_attribute_list,
        detached_job_wait_time: ^jmt$object_attribute_list,
        page_aging_interval: ^jmt$object_attribute_list,
        minimum_working_set: ^jmt$object_attribute_list,
        maximum_working_set: ^jmt$object_attribute_list,
        cyclic_aging_interval: ^jmt$object_attribute_list,
        service_class: jmt$profile_object_reference,
        attribute: jmt$object_attribute;

      jmp$get_job_class_record (job_class_index, job_class_table,
            jmv$working_storage, status);

      job_class.name := job_class_table.name;
      job_class.definition_id := job_class_table.profile_identification;
      job_class.index := job_class_table.index;
      job_class.kind := jmc$profile_job_class;
      job_class.references := 0;
      job_class.changed := FALSE;
      job_class_definition := jmv$object_definition [job_class.kind].
            declaration;
      build_shell (job_class_definition, 0, attribute);
      job_class_attributes := attribute.attribute_list;

      job_class_attributes^ [jmc$jc_definition_name].name^ :=
            job_class_table.profile_identification;
      job_class_attributes^ [jmc$jc_index].number := job_class_table.index;
      job_class_attributes^ [jmc$jc_profile_index].number :=
            job_class_table.profile_index;

{   Group definition attributes

      job_class_attributes^ [jmc$jc_abbreviation].name^ :=
            job_class_table.abbreviation;

      IF job_class_table.prolog_p <> NIL THEN
        job_class_attributes^ [jmc$jc_prolog].kind := jmc$file;
        ALLOCATE job_class_attributes^ [jmc$jc_prolog].file:
              [STRLENGTH (job_class_table.prolog_p^)] IN jmv$object_heap^;
        IF job_class_attributes^ [jmc$jc_prolog].file = NIL THEN
          jmp$internal_error (99);
        IFEND;
        job_class_attributes^ [jmc$jc_prolog].file^ :=
              job_class_table.prolog_p^;
      IFEND;
      IF job_class_table.epilog_p <> NIL THEN
        job_class_attributes^ [jmc$jc_epilog].kind := jmc$file;
        ALLOCATE job_class_attributes^ [jmc$jc_epilog].file:
              [STRLENGTH (job_class_table.epilog_p^)] IN jmv$object_heap^;
        IF job_class_attributes^ [jmc$jc_epilog].file = NIL THEN
          jmp$internal_error (99);
        IFEND;
        job_class_attributes^ [jmc$jc_epilog].file^ :=
              job_class_table.epilog_p^;
      IFEND;

      job_class_attributes^ [jmc$jc_enable_class_initiation].bool :=
            job_class_table.enable_class_initiation;
      job_class_attributes^ [jmc$jc_immediate_initiation_can].bool :=
            job_class_table.immediate_initiation_candidate;
      service_class := service_class_list [job_class_table.
            initial_service_class_index];
      job_class_attributes^ [jmc$jc_initial_service_class].object_p :=
            service_class;
      service_class^.references := service_class^.references + 1;
      job_class_attributes^ [jmc$jc_initial_working_set].number :=
            job_class_table.initial_working_set;

{   Group control attributes

      cyclic_aging_interval := job_class_attributes^ [
            jmc$jc_cyclic_aging_interval].attribute_list;
      cyclic_aging_interval^ [1].number :=
            job_class_table.cyclic_aging_interval.default;
      cyclic_aging_interval^ [2].number :=
            job_class_table.cyclic_aging_interval.minimum;
      cyclic_aging_interval^ [3].number :=
            job_class_table.cyclic_aging_interval.maximum;

      job_class_attributes^ [jmc$jc_defer_on_submit].bool :=
            job_class_table.defer_on_submit;

      job_class_attributes^ [jmc$jc_initiation_level].attribute_list^ [1].
            number := job_class_table.initiation_level.preferred;

{     job_class_attributes^ [jmc$jc_initiation_level].attribute_list^ [2].
{           number := job_class_table.initiation_level.maximum_increment;

      maximum_working_set := job_class_attributes^
            [jmc$jc_maximum_working_set].attribute_list;
      maximum_working_set^ [1].number := job_class_table.maximum_working_set.
            default;
      maximum_working_set^ [2].number := job_class_table.maximum_working_set.
            minimum;
      maximum_working_set^ [3].number := job_class_table.maximum_working_set.
            maximum;

      minimum_working_set := job_class_attributes^
            [jmc$jc_minimum_working_set].attribute_list;
      minimum_working_set^ [1].number := job_class_table.minimum_working_set.
            default;
      minimum_working_set^ [2].number := job_class_table.minimum_working_set.
            minimum;
      minimum_working_set^ [3].number := job_class_table.minimum_working_set.
            maximum;

      page_aging_interval := job_class_attributes^
            [jmc$jc_page_aging_interval].attribute_list;
      page_aging_interval^ [1].number := job_class_table.page_aging_interval.
            default;
      page_aging_interval^ [2].number := job_class_table.page_aging_interval.
            minimum;
      page_aging_interval^ [3].number := job_class_table.page_aging_interval.
            maximum;

{   Group limit attributes

      job_class_attributes^ [jmc$jc_cpu_time_limit].number :=
            job_class_table.cpu_time_limit;

      detached_job_wait_time := job_class_attributes^ [
            jmc$jc_detached_job_wait_time].attribute_list;
      detached_job_wait_time^ [1].number :=
            job_class_table.detached_job_wait_time.default;
      detached_job_wait_time^ [2].number :=
            job_class_table.detached_job_wait_time.minimum;
      detached_job_wait_time^ [3].number :=
            job_class_table.detached_job_wait_time.maximum;
      job_class_attributes^ [jmc$jc_magnetic_tape_limit].number :=
            job_class_table.magnetic_tape_limit;
      job_class_attributes^ [jmc$jc_sru_limit].number :=
            job_class_table.sru_limit;

{   Group membership attributes

      job_class_attributes^ [jmc$jc_auto_class_selection].bool :=
            job_class_table.automatic_class_selection;
      build_category_list (job_class_table.required_categories,
            job_class_attributes^ [jmc$jc_required_categories]);
      build_category_list (job_class_table.excluded_categories,
            job_class_attributes^ [jmc$jc_excluded_categories]);

{   Group priority attributes

      job_class_attributes^ [jmc$jc_initiation_age_interval].number :=
            job_class_table.initiation_age_interval DIV
            microseconds_per_second;

      job_class_attributes^ [jmc$jc_job_leveling_prio_bias].number :=
            job_class_table.job_leveling_priority_bias;

      job_class_attributes^ [jmc$jc_multiple_job_bias].number :=
            job_class_table.multiple_job_bias;

      selection_priority := job_class_attributes^ [jmc$jc_selection_priority].
            attribute_list;
      selection_priority^ [1].number := job_class_table.selection_priority.
            initial;
      selection_priority^ [2].number := job_class_table.selection_priority.
            maximum;
      selection_priority^ [3].number := job_class_table.selection_priority.
            increment;
      selection_priority^ [4].number := job_class_table.selection_priority.
            threshold;

      job_class.attributes := attribute;
    PROCEND build_job_class_object;
?? TITLE := ' build_output_class_object', EJECT ??

{ PURPOSE:
{   Builds an output class object for the specified index.
{
{ DESIGN:
{   Fetch the output class record for the specified index.  Set the name, kind,
{   and definition_id of the object.  Store the attributes from the output
{   class record into the output class attribute shell.

    PROCEDURE build_output_class_object
      (VAR output_class: jmt$profile_object;
       VAR output_class_table: jmt$output_class_attributes);

      VAR
        delivery_priority: ^jmt$object_attribute_list,
        output_class_attributes: ^jmt$object_attribute_list,
        attribute: jmt$object_attribute;

      output_class.name := output_class_table.name;
      output_class.kind := jmc$profile_output_class;
      output_class.definition_id := output_class_table.profile_identification;
      output_class.index := output_class_table.index;
      output_class.references := 0;
      output_class.changed := FALSE;
      build_shell (jmv$object_definition [output_class.kind].declaration, 0,
            attribute);
      output_class_attributes := attribute.attribute_list;

      output_class_attributes^ [jmc$oc_definition_name].name^ :=
            output_class_table.profile_identification;
      output_class_attributes^ [jmc$oc_index].number :=
            output_class_table.index;

{ Definition Group attributes

      output_class_attributes^ [jmc$oc_enable_class_scheduling].bool :=
            output_class_table.enable_class_scheduling;

{ Priority group attributes

      delivery_priority := output_class_attributes^ [jmc$oc_delivery_priority].
            attribute_list;
      delivery_priority^ [1].number := output_class_table.delivery_priority.
            initial;
      delivery_priority^ [2].number := output_class_table.delivery_priority.
            maximum;
      delivery_priority^ [3].number := output_class_table.delivery_priority.
            increment;
      output_class_attributes^ [jmc$oc_output_age_interval].number :=
            output_class_table.output_age_interval;

      output_class.attributes := attribute;
    PROCEND build_output_class_object;
?? TITLE := ' build_service_class_object', EJECT ??

{ PURPOSE:
{   Builds an service class object for the specified index.
{
{ DESIGN:
{   Fetch the service class record for the specified index.  Set the name,
{ kind,
{   and definition_id of the object.  Store the attributes from the service
{   class record into the service class attribute shell.
{
{ NOTES:
{   The following attributes must be converted back to external units:
{     swap_age_interval,
{     dispatching_control.service_time,
{     dispatching_control.dispatching_priority,
{     long_wait_think_time.

    PROCEDURE build_service_class_object
      (    service_class_index: jmt$service_class_index;
       VAR service_class: jmt$profile_object;
       VAR status: ost$status);

      VAR
        service_class_table: jmt$service_class_attributes,
        service_class_attributes: ^jmt$object_attribute_list,
        scheduling_priority: ^jmt$object_attribute_list,
        service_factors: ^jmt$object_attribute_list,
        dispatching_control: ^jmt$object_attribute_list,
        dispatching_control_count: jmt$dispatching_control_index,
        dispatching_control_index: jmt$dispatching_control_index,
        next_service_class: jmt$profile_object_reference,
        service_class_definition: jmt$profile_declaration,
        attribute: jmt$object_attribute;

      jmp$get_service_class_record (service_class_index, service_class_table,
            status);

      service_class.name := service_class_table.name;
      service_class.kind := jmc$profile_service_class;
      service_class.index := service_class_table.index;
      service_class.definition_id := service_class_table.
            profile_identification;
      service_class.changed := FALSE;
      service_class_definition := jmv$object_definition [service_class.kind].
            declaration;
      build_shell (service_class_definition, 0, attribute);
      service_class_attributes := attribute.attribute_list;

      service_class_attributes^ [jmc$sc_definition_name].name^ :=
            service_class_table.profile_identification;
      service_class_attributes^ [jmc$sc_index].number :=
            service_class_table.index;

{   Group definition attributes

      service_class_attributes^ [jmc$sc_abbreviation].name^ :=
            service_class_table.abbreviation;
      service_class_attributes^ [jmc$sc_enable_class_execution].bool := TRUE;

{   Group control attributes

      service_class_attributes^ [jmc$sc_aio_limit].number :=
            service_class_table.aio_limit;
      service_class_attributes^ [jmc$sc_class_resource_threshold].number :=
            service_class_table.class_service_threshold;
      service_class_attributes^ [jmc$sc_guaranteed_service_quan].number :=
            service_class_table.guaranteed_service_quantum;
      service_class_attributes^ [jmc$sc_long_wait_think_time].number :=
            service_class_table.long_wait_think_time DIV
            microseconds_per_millisecond;
      service_class_attributes^ [jmc$sc_maximum_active_jobs].number :=
            service_class_table.maximum_active_jobs;

      IF service_class_table.next_service_class_index > 0 THEN
        next_service_class := service_class_list
              [service_class_table.next_service_class_index];
        service_class_attributes^ [jmc$sc_next_service_class].object_p :=
              next_service_class;
        next_service_class^.references := next_service_class^.references + 1;
      ELSE
        service_class_attributes^ [jmc$sc_next_service_class].kind :=
              jmc$unspecified;
      IFEND;

      service_factors := service_class_attributes^ [jmc$sc_service_factors].
            attribute_list;
      service_factors^ [1].number := service_class_table.
            service_factors [jmc$sf_cpu];
      service_factors^ [2].number := service_class_table.
            service_factors [jmc$sf_memory];
      service_factors^ [3].number := service_class_table.
            service_factors [jmc$sf_residence];
      service_factors^ [4].number := service_class_table.
            service_factors [jmc$sf_io];

{   Group priority attributes

      dispatching_control_count := jmc$max_dispatching_control;
      WHILE NOT service_class_table.dispatching_control [
            dispatching_control_count].set_defined DO
        dispatching_control_count := dispatching_control_count - 1;
      WHILEND;

      build_shell (service_class_definition.
            declarations^ [jmc$sc_dispatching_control]^,
            dispatching_control_count, attribute.
            attribute_list^ [jmc$sc_dispatching_control]);

      FOR dispatching_control_index := 1 TO dispatching_control_count DO
        dispatching_control := service_class_attributes^ [
              jmc$sc_dispatching_control].attribute_list^ [
              dispatching_control_index].attribute_list;
        dispatching_control^ [1].number := service_class_table.
              dispatching_control [dispatching_control_index].
              dispatching_priority - dispatching_priority_offset;
        dispatching_control^ [2].number := service_class_table.
              dispatching_control [dispatching_control_index].service_limit DIV
              milliseconds_per_second;
        dispatching_control^ [3].number := service_class_table.
              dispatching_control [dispatching_control_index].
              dispatching_timeslice.minor DIV cpu_quantum_time;
        dispatching_control^ [4].number := service_class_table.
              dispatching_control [dispatching_control_index].
              dispatching_timeslice.major DIV cpu_quantum_time;
      FOREND;

      scheduling_priority := service_class_attributes^ [
            jmc$sc_scheduling_priority].attribute_list;
      scheduling_priority^ [1].number := service_class_table.
            scheduling_priority.minimum;
      scheduling_priority^ [2].number := service_class_table.
            scheduling_priority.maximum;
      scheduling_priority^ [3].number := service_class_table.
            scheduling_priority.swap_age_increment;
      scheduling_priority^ [4].number := service_class_table.
            scheduling_priority.ready_task_increment;

      service_class_attributes^ [jmc$sc_swap_age_interval].number :=
            service_class_table.swap_age_interval DIV microseconds_per_second;

      service_class.attributes := attribute;
    PROCEND build_service_class_object;
?? OLDTITLE, EJECT ??

    VAR
      category_index: integer,
      class_index: integer,
      list_index: integer,
      class_count: ost$non_negative_integers,
      application: jmt$profile_object_reference,
      job_class: jmt$profile_object_reference,
      service_class: jmt$profile_object_reference,
      job_category: jmt$profile_object_reference,
      object_list_head: jmt$profile_object_reference,
      defined_classes: array [1 .. jmc$maximum_job_classes] of
            jmt$defined_class;

    FOR class_index := 1 TO UPPERBOUND (job_class_list) DO
      job_class_list [class_index] := NIL;
    FOREND;

    FOR class_index := 1 TO UPPERBOUND (service_class_list) DO
      service_class_list [class_index] := NIL;
    FOREND;

    FOR class_index := 1 TO UPPERBOUND (application_list) DO
      application_list [class_index] := NIL;
    FOREND;

    build_category_objects (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE object_list_head IN jmv$object_heap^;
    IF object_list_head = NIL THEN
      jmp$internal_error (100);
    IFEND;
    build_controls_object (object_list_head^, cpu_quantum_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    profile.objects [jmc$profile_controls] := object_list_head;

{ Build service class objects.

    jmp$get_defined_classes (jmc$service_class, defined_classes, class_count,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    object_list_head := NIL;
    FOR list_index := class_count DOWNTO 1 DO
      class_index := defined_classes [list_index].index;
      ALLOCATE service_class IN jmv$object_heap^;
      IF service_class = NIL THEN
        jmp$internal_error (101);
      IFEND;
      service_class_list [class_index] := service_class;
      service_class^.next_object := object_list_head;
      service_class^.references := 0;
      object_list_head := service_class;
    FOREND;

    FOR list_index := class_count DOWNTO 1 DO
      class_index := defined_classes [list_index].index;
      build_service_class_object (class_index,
            service_class_list [class_index]^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;
    profile.objects [jmc$profile_service_class] := service_class;
    profile.count [jmc$profile_service_class] := class_count;

{ Build job class objects.

    jmp$get_defined_classes (jmc$job_class, defined_classes, class_count,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    object_list_head := NIL;
    FOR list_index := class_count DOWNTO 1 DO
      class_index := defined_classes [list_index].index;
      ALLOCATE job_class IN jmv$object_heap^;
      IF job_class = NIL THEN
        jmp$internal_error (102);
      IFEND;
      job_class_list [class_index] := job_class;
      build_job_class_object (class_index, job_class^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      job_class^.next_object := object_list_head;
      object_list_head := job_class;
    FOREND;
    profile.objects [jmc$profile_job_class] := job_class;
    profile.count [jmc$profile_job_class] := class_count;

{ Build application objects.

    jmp$get_defined_classes (jmc$application, defined_classes, class_count,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    object_list_head := NIL;
    FOR list_index := class_count DOWNTO 1 DO
      class_index := defined_classes [list_index].index;
      ALLOCATE application IN jmv$object_heap^;
      IF application = NIL THEN
        jmp$internal_error (103);
      IFEND;
      application_list [class_index] := application;
      build_application_object (defined_classes [list_index].name, class_index,
            application^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      application^.next_object := object_list_head;
      object_list_head := application;
    FOREND;
    profile.objects [jmc$profile_application] := object_list_head;
    profile.count [jmc$profile_application] := class_count;

{ Link job category objects into list for profile.

    job_category := NIL;
    class_count := 0;
    FOR class_index := UPPERBOUND (job_category_list) DOWNTO 1 DO
      IF job_category_list [class_index] <> NIL THEN
        job_category_list [class_index]^.next_object := job_category;
        job_category := job_category_list [class_index];
        class_count := class_count + 1;
      IFEND;
    FOREND;
    profile.objects [jmc$profile_category] := job_category;
    profile.count [jmc$profile_category] := class_count;

  PROCEND jmp$build_profile_from_system;
?? TITLE := '[XDCL] jmp$build_tables_from_profile', EJECT ??

{ PURPOSE:
{   This interface builds the scheduling tables from the objects in the
{   scheduling profile.
{
{ DESIGN:
{   Build a scheduling table of the appropriate kind for each object in
{   the scheduling profile.  Tables are build only for those objects which
{   are marked as having changed.
{
{ NOTES:
{   To build the full set of tables, all objects must be marked as changed.

  PROCEDURE [XDCL] jmp$build_tables_from_profile
    (    profile: jmt$profile_data;
         compress: boolean;
     VAR job_class_table: ^jmt$job_class_table;
     VAR service_class_table: ^jmt$service_class_table;
     VAR application_table: ^jmt$application_table;
     VAR job_scheduler_table: jmt$job_scheduler_table;
     VAR job_category_table: jmt$job_category_data;
     VAR status: ost$status);

    VAR
      all_job_categories: jmt$job_category_set;

?? NEWTITLE := ' analyse_job_categories', EJECT ??

{ PURPOSE:
{   This routine builds a set containing all the job categories.
{
{ DESIGN:
{   This category set is build by building a set using the index stored in
{   the object itself as the category bit number.  This index is computed
{   when the profile is installed.

    PROCEDURE analyse_job_categories
      (VAR all_job_categories: jmt$job_category_set);

      VAR
        job_category: jmt$profile_object_reference,
        previous_category_name: ost$name;

      all_job_categories := $jmt$job_category_set [];
      previous_category_name := osc$null_name;

      job_category := profile.objects [jmc$profile_category];
      WHILE job_category <> NIL DO
        IF job_category^.name <> previous_category_name THEN
          all_job_categories := all_job_categories +
                $jmt$job_category_set [job_category^.index - 1];
          previous_category_name := job_category^.name;
        IFEND;
        job_category := job_category^.next_object;
      WHILEND;

    PROCEND analyse_job_categories;
?? TITLE := ' build_application_table', EJECT ??

{ PURPOSE:
{   This routine builds an application table from the application objects
{   attributes.
{
{ DESIGN:
{   The application attributes are first merged with the defaults and
{   all keyword attributes are converted into constants.  From the resulting
{   attributes the application table is build.

    PROCEDURE build_application_table
      (    application: jmt$profile_object;
       VAR application_table: jmt$application_attributes);

      VAR
        application_attributes: ^jmt$object_attribute_list;

      get_object_attributes (application, application_attributes);

{   Group definition attributes

      application_table.defined := TRUE;
      application_table.profile_identification := application.definition_id;
      application_table.name := application.name;

      application_table.enable_application_scheduling :=
            application_attributes^ [jmc$ap_enable_application_sched].bool;

      application_table.service_class_index := 0;
      IF application_attributes^ [jmc$ap_service_class].kind = jmc$object THEN
        application_table.service_class_index :=
              application_attributes^ [jmc$ap_service_class].object_p^.index;
      IFEND;

{   Group control attributes

      application_table.cyclic_aging_interval :=
            application_attributes^ [jmc$ap_cyclic_aging_interval].number;
      application_table.maximum_working_set :=
            application_attributes^ [jmc$ap_maximum_working_set].number;
      application_table.minimum_working_set :=
            application_attributes^ [jmc$ap_minimum_working_set].number;
      application_table.page_aging_interval :=
            application_attributes^ [jmc$ap_page_aging_interval].number;

    PROCEND build_application_table;
?? TITLE := 'build_category_table', EJECT ??

{ PURPOSE:
{   This routine builds a job category table from the job category object
{   list.

    PROCEDURE build_category_table
      (VAR job_category_table: jmt$job_category_data);

?? NEWTITLE := 'build_item_list', EJECT ??

{ PURPOSE:
{   Builds a sequence of category items from job category attributes.
{
{ DESIGN:
{   Each numeric attribute adds two items to the sequence - one for the
{   lower value and the other for the upper value+1.  Each name attribute
{   adds one item to the sequence.

      PROCEDURE build_item_list
        (VAR item_count: integer;
         VAR maximum_index: integer;
         VAR top_item: ^jmt$job_category_item);

        VAR
          i: integer,
          categories: jmt$job_category_set,
          category_attributes: ^jmt$object_attribute_list,
          attribute: jmt$object_attribute,
          item: ^jmt$job_category_item,
          low_value: integer,
          or_item: jmt$job_category_item,
          last_category_name: ost$name,
          job_category: jmt$profile_object_reference,
          definition: jmt$profile_declaration,
          cik: jmt$job_category_item_kind;

        VAR
          index: [STATIC] array [jmc$ca_cpu_time_limit .. jmc$ca_job_qualifier]
                of integer := [jmc$c_cpu_time_limit, jmc$c_sru_limit,
                jmc$c_magnetic_tape_limit, jmc$c_maximum_working_set,
                jmc$c_login_account, jmc$c_login_project, jmc$c_login_family,
                jmc$c_login_user, jmc$c_user_job_name,
                jmc$c_origin_application_name, jmc$c_job_mode,
                jmc$c_job_priority, jmc$c_job_qualifier];

        job_category := profile.objects [jmc$profile_category];
        last_category_name := ' ';
        maximum_index := 0;

        or_item.kind := jmc$ca_or_conditions;
        or_item.categories := $jmt$job_category_set [];
        or_item.members := or_item.categories;

        item_count := 0;
        NEXT top_item IN jmv$working_storage;
        IF top_item = NIL THEN
          jmp$internal_error (70);
        IFEND;
        top_item^ := or_item;
        top_item^.next_item := #REL (top_item, jmv$working_storage^);
        top_item^.skip_item := #REL (top_item, jmv$working_storage^);

      /for_all_objects/
        WHILE job_category <> NIL DO
          IF maximum_index < (job_category^.index - 1) THEN
            maximum_index := job_category^.index - 1;
          IFEND;

          categories := $jmt$job_category_set [job_category^.index - 1];
          top_item^.members := top_item^.members + categories;

          IF job_category^.attributes.kind <> jmc$type THEN
            job_category := job_category^.next_object;
            CYCLE /for_all_objects/;
          IFEND;

          category_attributes := job_category^.attributes.attribute_list;
          get_object_attributes (job_category^, category_attributes);

{ Create or_item for the previous category if necessary.

          IF last_category_name <> job_category^.name THEN
            IF or_item.categories <> or_item.members THEN
              NEXT item IN jmv$working_storage;
              IF item = NIL THEN
                jmp$internal_error (71);
              IFEND;
              item^ := or_item;
              item^.next_item := top_item^.next_item;
              item^.skip_item := #REL (item, jmv$working_storage^);
              top_item^.next_item := #REL (item, jmv$working_storage^);
              item_count := item_count + 1;
            IFEND;
            last_category_name := job_category^.name;
            or_item.categories := categories;
            or_item.members := categories;
          IFEND;
          or_item.members := or_item.members + categories;

        /for_all_names/
          FOR cik := jmc$ca_login_account TO jmc$ca_job_qualifier DO
            attribute := category_attributes^ [index [cik]];
            IF attribute.kind <> jmc$list THEN
              CYCLE /for_all_names/;
            IFEND;

{ Create category item for each name in the list.

            FOR i := 1 TO UPPERBOUND (attribute.attribute_list^) DO
              NEXT item IN jmv$working_storage;
              IF item = NIL THEN
                jmp$internal_error (72);
              IFEND;
              item^.kind := cik;
              item^.categories := categories;
              item^.name := attribute.attribute_list^ [i].object_p^.name;
              item^.next_item := top_item^.next_item;
              item^.skip_item := #REL (item, jmv$working_storage^);
              top_item^.next_item := #REL (item, jmv$working_storage^);
              item_count := item_count + 1;
            FOREND;
          FOREND /for_all_names/;

        /for_all_numbers/
          FOR cik := LOWERVALUE (cik) TO jmc$ca_working_set DO
            attribute := category_attributes^ [index [cik]];
            IF attribute.kind <> jmc$range THEN
              CYCLE /for_all_numbers/;
            IFEND;

            definition := jmv$object_definition [jmc$profile_category].
                  declaration.declarations^ [index [cik]]^.declarations^ [1]^;

{ Create category item for lower value in range.

            NEXT item IN jmv$working_storage;
            IF item = NIL THEN
              jmp$internal_error (73);
            IFEND;
            item^.kind := cik;
            item^.categories := categories;
            CASE attribute.attribute_list^ [1].kind OF
            = jmc$number =
              item^.number := attribute.attribute_list^ [1].number - 1;
            = jmc$unlimited =
              item^.number := definition.maximum + jmc$unlimited_offset - 1;
            = jmc$unspecified =
              item^.number := definition.maximum + jmc$unspecified_offset - 1;
            CASEND;
            item^.next_item := top_item^.next_item;
            item^.skip_item := #REL (item, jmv$working_storage^);
            top_item^.next_item := #REL (item, jmv$working_storage^);
            low_value := item^.number;

{ Create category item for upper value in range.

            NEXT item IN jmv$working_storage;
            IF item = NIL THEN
              jmp$internal_error (74);
            IFEND;
            item^.kind := cik;
            item^.categories := categories;
            CASE attribute.attribute_list^ [2].kind OF
            = jmc$number =
              item^.number := attribute.attribute_list^ [2].number;
            = jmc$unlimited =
              item^.number := definition.maximum + jmc$unlimited_offset;
            = jmc$unspecified =
              item^.number := definition.maximum + jmc$unspecified_offset;
            = jmc$empty =
              item^.number := low_value + 1;
            CASEND;
            item^.next_item := top_item^.next_item;
            item^.skip_item := #REL (item, jmv$working_storage^);
            top_item^.next_item := #REL (item, jmv$working_storage^);
            item_count := item_count + 2;
          FOREND /for_all_numbers/;
          job_category := job_category^.next_object;
        WHILEND /for_all_objects/;

{ Create or_item for the last category if necessary.

        IF or_item.categories <> or_item.members THEN
          NEXT item IN jmv$working_storage;
          IF item = NIL THEN
            jmp$internal_error (75);
          IFEND;
          item^ := or_item;
          item^.next_item := top_item^.next_item;
          item^.skip_item := #REL (item, jmv$working_storage^);
          top_item^.next_item := #REL (item, jmv$working_storage^);
          item_count := item_count + 1;
        IFEND;

      PROCEND build_item_list;
?? TITLE := 'build_name_list', EJECT ??

{ PURPOSE:
{   Build the list of category names and the corresponding definition names.

      PROCEDURE build_name_list
        (    maximum_index: integer;
         VAR name_list: ^jmt$job_category_name_list);

        VAR
          i: integer,
          job_category: jmt$profile_object_reference;

        job_category := profile.objects [jmc$profile_category];

        IF job_category = NIL THEN
          name_list := NIL;
          RETURN;
        IFEND;

        NEXT name_list: [0 .. maximum_index] IN jmv$working_storage;
        IF name_list = NIL THEN
          jmp$internal_error (76);
        IFEND;
        FOR i := 0 TO maximum_index DO
          name_list^ [i].name := osc$null_name;
          name_list^ [i].definition_name := osc$null_name;
        FOREND;

        WHILE job_category <> NIL DO
          i := job_category^.index - 1;
          name_list^ [i].name := job_category^.name;
          name_list^ [i].definition_name := job_category^.definition_id;
          job_category := job_category^.next_object;
        WHILEND;
      PROCEND build_name_list;

?? TITLE := 'compress_item_list', EJECT ??

{ PURPOSE:
{   Compress the category items and propogate the sets for numeric items.
{
{ DESIGN:
{   This routine removes the duplicate category items combining the set
{   values of the duplicate items into one set.  It also propagates category
{   bits for numeric items.  A category bit will be propagated until it
{   is encountered again in the list at which point it the category bit is
{   removed from the set.

      PROCEDURE compress_item_list
        (VAR total_items: integer;
         VAR top_item: ^jmt$job_category_item);

        VAR
          item: ^jmt$job_category_item,
          item_categories: jmt$job_category_set,
          last_good_item: ^jmt$job_category_item,
          next_item_categories: jmt$job_category_set;

        IF #PTR (top_item^.next_item, jmv$working_storage^) = top_item THEN
          RETURN;
        IFEND;

        last_good_item := top_item;
        item := #PTR (last_good_item^.next_item, jmv$working_storage^);
        WHILE (item <> top_item) AND (item^.kind <= jmc$ca_working_set) DO
          item_categories := next_item_categories;
          IF item^.kind <> last_good_item^.kind THEN
            item_categories := $jmt$job_category_set [];
            last_good_item := item;
          ELSE
            IF item^.number = last_good_item^.number THEN
              total_items := total_items - 1;
              last_good_item^.next_item := item^.next_item;
            ELSE
              last_good_item := item;
            IFEND;
          IFEND;
          next_item_categories := item_categories + item^.categories -
                (item_categories * item^.categories);
          item^.categories := item_categories;
          item := #PTR (last_good_item^.next_item, jmv$working_storage^);
        WHILEND;

        WHILE (item <> top_item) AND (item^.kind < jmc$ca_or_conditions) DO
          IF (item^.kind = last_good_item^.kind) AND
                (item^.name = last_good_item^.name) THEN
            total_items := total_items - 1;
            last_good_item^.next_item := item^.next_item;
            last_good_item^.categories := last_good_item^.categories +
                  item^.categories;
          ELSE
            last_good_item := item;
          IFEND;
          item := #PTR (last_good_item^.next_item, jmv$working_storage^);
        WHILEND;
      PROCEND compress_item_list;
?? TITLE := 'copy_item_list', EJECT ??

{ PURPOSE:
{   Builds the final category list from the compressed data.
{
{ DESIGN:
{   This routine copies the data from the compressed list into the final
{   list and links the entries together.

      PROCEDURE copy_item_list
        (    total_items: integer;
             top_item: ^jmt$job_category_item;
         VAR category_data: jmt$job_category_data);

        VAR
          cik: jmt$job_category_item_kind,
          skip_item: ^jmt$job_category_item,
          last_item: ^jmt$job_category_item,
          this_item: ^jmt$job_category_item,
          old_item: ^jmt$job_category_item,
          item_number: integer,
          item_list: ^array [1 .. * ] of jmt$job_category_item;

        FOR cik := LOWERVALUE (cik) TO UPPERVALUE (cik) DO
          category_data.initial_set_values [cik] := top_item^.members;
        FOREND;

        old_item := #PTR (top_item^.next_item, jmv$working_storage^);
        IF old_item = top_item THEN
          job_category_table.item_list := NIL;
          RETURN;
        IFEND;

        NEXT item_list: [1 .. total_items] IN jmv$working_storage;
        IF item_list = NIL THEN
          jmp$internal_error (77);
        IFEND;
        job_category_table.item_list := #SEQ (item_list^);
        RESET job_category_table.item_list;

        item_number := 0;
        WHILE old_item <> top_item DO
          item_number := item_number + 1;
          category_data.initial_set_values [old_item^.kind] :=
                category_data.initial_set_values [old_item^.kind] -
                old_item^.categories;
          item_list^ [item_number] := old_item^;
          old_item := #PTR (old_item^.next_item, jmv$working_storage^);
        WHILEND;

{ Relink the list in reverse order setting skip_item appropriately.

        skip_item := ^item_list^ [1];
        last_item := skip_item;
        FOR item_number := total_items DOWNTO 1 DO
          this_item := ^item_list^ [item_number];
          IF last_item^.kind <> this_item^.kind THEN
            skip_item := last_item;
          IFEND;
          this_item^.next_item := #REL (last_item, category_data.item_list^);
          this_item^.skip_item := #REL (skip_item, category_data.item_list^);
          last_item := this_item;
        FOREND;

      PROCEND copy_item_list;
?? TITLE := ' sort_item_list', EJECT ??

{ PURPOSE:
{   Put the category records in the sequence into order by kind and value.
{
{ DESIGN:
{   Sort using a merge sort with linked lists.

      PROCEDURE sort_item_list
        (VAR top: ^jmt$job_category_item);

        VAR
          i: integer,
          sublist_size: integer,
          nil_pointer: ^jmt$job_category_item,
          is_less: boolean,
          old_list: ^jmt$job_category_item,
          sublist_1: ^jmt$job_category_item,
          sublist_2: ^jmt$job_category_item,
          newlist_tail: ^jmt$job_category_item,
          sublist_tail: ^jmt$job_category_item;

        old_list := #PTR (top^.next_item, jmv$working_storage^);
        IF old_list = top THEN
          RETURN;
        IFEND;

        nil_pointer := top;

        sublist_size := 1;
        WHILE TRUE DO
          old_list := #PTR (top^.next_item, jmv$working_storage^);
          newlist_tail := top;

          WHILE old_list <> nil_pointer DO

            sublist_1 := old_list;

          /peel1/
            FOR i := 1 TO sublist_size DO
              IF old_list = nil_pointer THEN
                IF newlist_tail = top THEN
                  RETURN;
                IFEND;
                EXIT /peel1/;
              IFEND;
              sublist_tail := old_list;
              old_list := #PTR (old_list^.next_item, jmv$working_storage^);
            FOREND /peel1/;
            sublist_tail^.next_item := #REL (nil_pointer,
                  jmv$working_storage^);

            sublist_2 := old_list;

          /peel2/
            FOR i := 1 TO sublist_size DO
              IF old_list = nil_pointer THEN
                EXIT /peel2/;
              IFEND;
              sublist_tail := old_list;
              old_list := #PTR (old_list^.next_item, jmv$working_storage^);
            FOREND /peel2/;
            sublist_tail^.next_item := #REL (nil_pointer,
                  jmv$working_storage^);

          /merge/
            WHILE (sublist_1 <> nil_pointer) AND (sublist_2 <> nil_pointer) DO
              is_less := FALSE;
              IF sublist_1^.kind < sublist_2^.kind THEN
                is_less := TRUE;
              ELSEIF sublist_1^.kind = sublist_2^.kind THEN
                IF sublist_1^.kind <= jmc$ca_mag_tape_limit THEN
                  is_less := sublist_1^.number < sublist_2^.number;
                ELSE
                  is_less := sublist_1^.name < sublist_2^.name;
                IFEND;
              IFEND;
              IF is_less THEN
                newlist_tail^.next_item := #REL (sublist_1,
                      jmv$working_storage^);
                newlist_tail := sublist_1;
                sublist_1 := #PTR (newlist_tail^.next_item,
                      jmv$working_storage^);
              ELSE
                newlist_tail^.next_item := #REL (sublist_2,
                      jmv$working_storage^);
                newlist_tail := sublist_2;
                sublist_2 := #PTR (newlist_tail^.next_item,
                      jmv$working_storage^);
              IFEND;
            WHILEND /merge/;

            newlist_tail^.next_item := #REL (sublist_1, jmv$working_storage^);
            WHILE sublist_1 <> nil_pointer DO
              newlist_tail := sublist_1;
              sublist_1 := #PTR (newlist_tail^.next_item,
                    jmv$working_storage^);
            WHILEND;

            newlist_tail^.next_item := #REL (sublist_2, jmv$working_storage^);
            WHILE sublist_2 <> nil_pointer DO
              newlist_tail := sublist_2;
              sublist_2 := #PTR (newlist_tail^.next_item,
                    jmv$working_storage^);
            WHILEND;

          WHILEND;
          sublist_size := sublist_size * 2;
        WHILEND;
      PROCEND sort_item_list;
?? OLDTITLE, EJECT ??

      VAR
        top_item: ^jmt$job_category_item,
        maximum_index: integer,
        item_count: integer;

      build_item_list (item_count, maximum_index, top_item);
      sort_item_list (top_item);
      compress_item_list (item_count, top_item);
      copy_item_list (item_count, top_item, job_category_table);
      build_name_list (maximum_index, job_category_table.category_names);
    PROCEND build_category_table;
?? TITLE := ' build_job_category_set', EJECT ??

{ PURPOSE:
{   This routine converts a list of category object references to a category
{   set.
{
{ DESIGN:
{   A category set is build by building a set using the index stored in the
{   object itself as the category bit number.  This index is computed
{   when the profile is installed.

    PROCEDURE build_job_category_set
      (VAR attribute: jmt$object_attribute;
       VAR categories: jmt$job_category_set);

      VAR
        job_category: jmt$profile_object_reference,
        category_list: ^jmt$object_attribute_list,
        i: integer;

      categories := $jmt$job_category_set [];

      IF attribute.kind = jmc$all THEN
        categories := all_job_categories;
        RETURN;
      IFEND;

      IF attribute.kind = jmc$list THEN
        category_list := attribute.attribute_list;
        FOR i := 1 TO UPPERBOUND (category_list^) DO
          IF category_list^ [i].kind = jmc$object THEN
            categories := categories + $jmt$job_category_set
                  [category_list^ [i].object_p^.index - 1];
          IFEND;
        FOREND;
        categories := categories * all_job_categories;
      IFEND;

    PROCEND build_job_category_set;
?? TITLE := ' build_job_class_table', EJECT ??

{ PURPOSE:
{   This routine builds a job class table from the job class object's
{   attributes.
{
{ DESIGN:
{   The job class attributes are first merged with the defaults and
{   all keyword attributes are converted into constants.  From the resulting
{   attributes the job class table is build.
{
{ NOTES:
{   Special processing is done for
{     initiation_level .preferred and .maximum;
{     cpu_time_limit and sru_limit;
{     initiation_age_interval.

    PROCEDURE build_job_class_table
      (    job_class: jmt$profile_object;
       VAR job_class_table: jmt$job_class_attributes);

      VAR
        job_class_attributes: ^jmt$object_attribute_list,
        delivery_priority: ^jmt$object_attribute_list,
        selection_priority: ^jmt$object_attribute_list,
        detached_job_wait_time: ^jmt$object_attribute_list,
        page_aging_interval: ^jmt$object_attribute_list,
        minimum_working_set: ^jmt$object_attribute_list,
        maximum_working_set: ^jmt$object_attribute_list,
        cyclic_aging_interval: ^jmt$object_attribute_list,
        sru_limit: integer,
        cpu_time_limit: integer,
        initiation_level: integer;

      get_object_attributes (job_class, job_class_attributes);

{   Group definition attributes

      job_class_table.defined := TRUE;
      job_class_table.index := job_class.index;
      job_class_table.profile_identification := job_class.definition_id;
      job_class_table.name := job_class.name;

      job_class_table.abbreviation := job_class_attributes^ [
            jmc$jc_abbreviation].name^;

      job_class_table.prolog_p := NIL;
      job_class_table.epilog_p := NIL;
      IF job_class_attributes^ [jmc$jc_prolog].kind = jmc$file THEN
        NEXT job_class_table.prolog_p: [STRLENGTH (job_class_attributes^
              [jmc$jc_prolog].file^)] IN jmv$working_storage;
        IF job_class_table.prolog_p = NIL THEN
          jmp$internal_error (78);
        IFEND;
        job_class_table.prolog_p^ := job_class_attributes^ [jmc$jc_prolog].
              file^;
      IFEND;
      IF job_class_attributes^ [jmc$jc_epilog].kind = jmc$file THEN
        NEXT job_class_table.epilog_p: [STRLENGTH (job_class_attributes^
              [jmc$jc_epilog].file^)] IN jmv$working_storage;
        IF job_class_table.epilog_p = NIL THEN
          jmp$internal_error (79);
        IFEND;
        job_class_table.epilog_p^ := job_class_attributes^ [jmc$jc_epilog].
              file^;
      IFEND;

      job_class_table.enable_class_initiation :=
            job_class_attributes^ [jmc$jc_enable_class_initiation].bool;
      job_class_table.immediate_initiation_candidate :=
            job_class_attributes^ [jmc$jc_immediate_initiation_can].bool;
      job_class_table.default_output_class := 'OUTPUT';
      job_class_table.initial_service_class_index :=
            job_class_attributes^ [jmc$jc_initial_service_class].object_p^.
            index;
      job_class_table.initial_working_set :=
            job_class_attributes^ [jmc$jc_initial_working_set].number;

{   Group control attributes

      job_class_table.defer_on_submit := job_class_attributes^ [
            jmc$jc_defer_on_submit].bool;

      cyclic_aging_interval := job_class_attributes^ [
            jmc$jc_cyclic_aging_interval].attribute_list;
      job_class_table.cyclic_aging_interval.default :=
            cyclic_aging_interval^ [1].number;
      job_class_table.cyclic_aging_interval.minimum :=
            cyclic_aging_interval^ [2].number;
      job_class_table.cyclic_aging_interval.maximum :=
            cyclic_aging_interval^ [3].number;

      initiation_level := job_class_attributes^ [jmc$jc_initiation_level].
            attribute_list^ [1].number;
      IF initiation_level > jmc$unlimited_max_init_jobs THEN
        initiation_level := jmc$unlimited_max_init_jobs;
      IFEND;
      job_class_table.initiation_level.preferred := initiation_level;

{     initiation_level := job_class_attributes^ [jmc$jc_initiation_level].
{           attribute_list^ [2].number;
{     IF initiation_level > jmc$unlimited_max_init_jobs THEN
{       initiation_level := jmc$unlimited_max_init_jobs;
{     IFEND;
{     job_class_table.initiation_level.maximum_increment := initiation_level;

      maximum_working_set := job_class_attributes^
            [jmc$jc_maximum_working_set].attribute_list;
      job_class_table.maximum_working_set.default :=
            maximum_working_set^ [1].number;
      job_class_table.maximum_working_set.minimum :=
            maximum_working_set^ [2].number;
      job_class_table.maximum_working_set.maximum :=
            maximum_working_set^ [3].number;

      minimum_working_set := job_class_attributes^
            [jmc$jc_minimum_working_set].attribute_list;
      job_class_table.minimum_working_set.default :=
            minimum_working_set^ [1].number;
      job_class_table.minimum_working_set.minimum :=
            minimum_working_set^ [2].number;
      job_class_table.minimum_working_set.maximum :=
            minimum_working_set^ [3].number;

      page_aging_interval := job_class_attributes^
            [jmc$jc_page_aging_interval].attribute_list;
      job_class_table.page_aging_interval.default :=
            page_aging_interval^ [1].number;
      job_class_table.page_aging_interval.minimum :=
            page_aging_interval^ [2].number;
      job_class_table.page_aging_interval.maximum :=
            page_aging_interval^ [3].number;

{   Group limit attributes

      cpu_time_limit := job_class_attributes^ [jmc$jc_cpu_time_limit].number;
      IF cpu_time_limit = jmc$highest_cpu_time_limit +
            jmc$unlimited_offset THEN
        cpu_time_limit := jmc$unlimited_cpu_time_limit;
      IFEND;
      job_class_table.cpu_time_limit := cpu_time_limit;

      detached_job_wait_time := job_class_attributes^ [
            jmc$jc_detached_job_wait_time].attribute_list;
      job_class_table.detached_job_wait_time.default :=
            detached_job_wait_time^ [1].number;
      job_class_table.detached_job_wait_time.minimum :=
            detached_job_wait_time^ [2].number;
      job_class_table.detached_job_wait_time.maximum :=
            detached_job_wait_time^ [3].number;

      job_class_table.magnetic_tape_limit :=
            job_class_attributes^ [jmc$jc_magnetic_tape_limit].number;

      sru_limit := job_class_attributes^ [jmc$jc_sru_limit].number;
      IF sru_limit = jmc$highest_sru_limit + jmc$unlimited_offset THEN
        sru_limit := jmc$unlimited_sru_limit;
      IFEND;
      job_class_table.sru_limit := sru_limit;

{   Group membership attributes

      job_class_table.next_rank_class := 0;
      job_class_table.automatic_class_selection :=
            job_class_attributes^ [jmc$jc_auto_class_selection].bool;
      build_job_category_set (job_class_attributes^
            [jmc$jc_required_categories], job_class_table.required_categories);
      build_job_category_set (job_class_attributes^
            [jmc$jc_excluded_categories], job_class_table.excluded_categories);

{   Group priority attributes

      job_class_table.initiation_age_interval :=
            job_class_attributes^ [jmc$jc_initiation_age_interval].number *
            microseconds_per_second;

      job_class_table.job_leveling_priority_bias :=
            job_class_attributes^ [jmc$jc_job_leveling_prio_bias].number;

      job_class_table.multiple_job_bias :=
            job_class_attributes^ [jmc$jc_multiple_job_bias].number;

      selection_priority := job_class_attributes^ [jmc$jc_selection_priority].
            attribute_list;
      job_class_table.selection_priority.initial :=
            selection_priority^ [1].number;
      job_class_table.selection_priority.maximum :=
            selection_priority^ [2].number;
      job_class_table.selection_priority.increment :=
            selection_priority^ [3].number;
      job_class_table.selection_priority.threshold :=
            selection_priority^ [4].number;

    PROCEND build_job_class_table;
?? TITLE := ' build_output_class_table', EJECT ??

{ PURPOSE:
{   This routine builds an output class table from the output class object's
{   attributes.
{
{ DESIGN:
{   The output class attributes are first merged with the defaults and
{   all keyword attributes are converted into constants.  From the resulting
{   attributes the output class table is build.

    PROCEDURE build_output_class_table
      (    output_class: jmt$profile_object;
       VAR output_class_table: jmt$output_class_attributes);

      VAR
        output_class_attributes: ^jmt$object_attribute_list,
        delivery_priority: ^jmt$object_attribute_list;

      get_object_attributes (output_class, output_class_attributes);

{ Definition Group attributes

      output_class_table.defined := TRUE;
      output_class_table.index := output_class.index;
      output_class_table.profile_identification := output_class.definition_id;
      output_class_table.name := output_class.name;
      output_class_table.enable_class_scheduling :=
            output_class_attributes^ [jmc$oc_enable_class_scheduling].bool;

{ Priority group attributes

      delivery_priority := output_class_attributes^ [jmc$oc_delivery_priority].
            attribute_list;
      output_class_table.delivery_priority.initial :=
            delivery_priority^ [1].number;
      output_class_table.delivery_priority.maximum :=
            delivery_priority^ [2].number;
      output_class_table.delivery_priority.increment :=
            delivery_priority^ [3].number;

      output_class_table.output_age_interval :=
            output_class_attributes^ [jmc$oc_output_age_interval].number;

    PROCEND build_output_class_table;
?? TITLE := ' build_scheduler_table', EJECT ??

{ PURPOSE:
{   This routine builds a scheduler table from the controls object's
{   attribute_list.
{
{ DESIGN:
{   The controls attributes are first merged with the defaults and
{   all keyword attributes are converted into constants.  From the resulting
{   attributes the controls table is build.
{
{ NOTES:
{   Special processing is done for
{     idle_dispatching_queue_time.

    PROCEDURE build_scheduler_table
      (VAR job_scheduler_table: jmt$job_scheduler_table;
       VAR status: ost$status);

      VAR
        controls: jmt$profile_object_reference,
        controls_attributes: ^jmt$object_attribute_list,
        dispatching_allocation: ^jmt$object_attribute_list,
        dispatching_priority: jmt$dispatching_priority,
        i: integer,
        idle_dispatching_queue_time: integer,
        lower_priority: jmt$dispatching_priority,
        mainframe_count: integer,
        priority_control: ^jmt$object_attribute_list,
        upper_priority: jmt$dispatching_priority,
        validation_categories: ^jmt$mainframe_categories;

      status.normal := TRUE;

      controls := profile.objects [jmc$profile_controls];
      get_object_attributes (controls^, controls_attributes);

{ Definition Group

      job_scheduler_table.profile_identification := profile.definition_id;
      job_scheduler_table.cpu_quantum_time :=
            controls_attributes^ [jmc$ct_cpu_quantum_time].number;
      job_scheduler_table.enable_job_leveling :=
            controls_attributes^ [jmc$ct_enable_job_leveling].bool;
      job_scheduler_table.job_leveling_interval :=
            controls_attributes^ [jmc$ct_job_leveling_interval].number;
      job_scheduler_table.service_calculation_interval :=
            controls_attributes^ [jmc$ct_service_calc_interval].number;

{ Control group

      idle_dispatching_queue_time := controls_attributes^ [
            jmc$ct_idle_disp_queue_time].number * microseconds_per_second;
      IF idle_dispatching_queue_time = (jmc$highest_idle_disp_q_time +
            jmc$unlimited_offset * microseconds_per_second) THEN
        idle_dispatching_queue_time := jmc$unlimited_idle_disp_q_time;
      IFEND;
      job_scheduler_table.idle_dispatching_queue_time :=
            idle_dispatching_queue_time;
      job_scheduler_table.scheduling_memory_levels.target :=
            controls_attributes^ [jmc$ct_scheduling_memory_levels].
            attribute_list^ [1].number;
      job_scheduler_table.scheduling_memory_levels.thrashing :=
            controls_attributes^ [jmc$ct_scheduling_memory_levels].
            attribute_list^ [2].number;
      job_scheduler_table.dispatching_allocation_interval :=
            controls_attributes^ [jmc$ct_cpu_dispatching_interval].number;

      FOR i := 1 TO UPPERBOUND (controls_attributes^
            [jmc$ct_dispatching_allocation].attribute_list^) DO
        dispatching_allocation := controls_attributes^ [
              jmc$ct_dispatching_allocation].attribute_list^ [i].
              attribute_list;
        lower_priority := dispatching_allocation^ [1].attribute_list^ [1].
              number + dispatching_priority_offset;
        upper_priority := lower_priority;
        IF dispatching_allocation^ [1].attribute_list^ [2].kind <>
              jmc$empty THEN
          upper_priority := dispatching_allocation^ [1].attribute_list^ [2].
                number + dispatching_priority_offset;
        IFEND;
        FOR dispatching_priority := lower_priority TO upper_priority DO
          job_scheduler_table.cpu_dispatching_allocation
                [dispatching_priority].minimum :=
                dispatching_allocation^ [2].number;
          job_scheduler_table.cpu_dispatching_allocation
                [dispatching_priority].maximum :=
                dispatching_allocation^ [3].number;
          job_scheduler_table.cpu_dispatching_allocation
                [dispatching_priority].enforce_maximum :=
                dispatching_allocation^ [4].bool;
        FOREND;
      FOREND;

      FOR i := 1 TO UPPERBOUND (controls_attributes^
            [jmc$ct_dual_state_prio_control].attribute_list^) DO
        priority_control := controls_attributes^ [
              jmc$ct_dual_state_prio_control].attribute_list^ [i].
              attribute_list;
        lower_priority := priority_control^ [1].attribute_list^ [1].number +
              dispatching_priority_offset;
        upper_priority := lower_priority;
        IF priority_control^ [1].attribute_list^ [2].kind <> jmc$empty THEN
          upper_priority := priority_control^ [1].attribute_list^ [2].number +
                dispatching_priority_offset;
        IFEND;
        FOR dispatching_priority := lower_priority TO upper_priority DO
          job_scheduler_table.dual_state_priority_control
                [dispatching_priority].priority := priority_control^ [2].
                number;
          job_scheduler_table.dual_state_priority_control
                [dispatching_priority].subpriority :=
                priority_control^ [3].number;
        FOREND;
      FOREND;

      build_job_category_set (controls_attributes^
            [jmc$ct_ini_required_categories],
            job_scheduler_table.initiation_required_categories);
      build_job_category_set (controls_attributes^
            [jmc$ct_ini_excluded_categories],
            job_scheduler_table.initiation_excluded_categories);

{ Priority group

      job_scheduler_table.job_leveling_priority_bias :=
            controls_attributes^ [jmc$ct_job_leveling_prio_bias].number;

{ Membership group

      NEXT validation_categories: [1 .. profile.
            count [jmc$profile_controls]] IN jmv$working_storage;
      IF validation_categories = NIL THEN
        jmp$internal_error (80);
      IFEND;

      validation_categories^ [1].mainframe_id := controls^.name;
      build_job_category_set (controls_attributes^
            [jmc$ct_val_required_categories],
            validation_categories^ [1].required);
      build_job_category_set (controls_attributes^
            [jmc$ct_val_excluded_categories],
            validation_categories^ [1].excluded);

      mainframe_count := 1;

      controls := controls^.next_object;
      WHILE controls <> NIL DO
        get_object_attributes (controls^, controls_attributes);
        mainframe_count := mainframe_count + 1;
        validation_categories^ [mainframe_count].mainframe_id :=
              controls^.name;
        build_job_category_set (controls_attributes^
              [jmc$ct_val_required_categories],
              validation_categories^ [mainframe_count].required);
        build_job_category_set (controls_attributes^
              [jmc$ct_val_excluded_categories],
              validation_categories^ [mainframe_count].excluded);
        controls := controls^.next_object;
      WHILEND;

      NEXT job_scheduler_table.validation_categories_p:
            [1 .. mainframe_count] IN jmv$working_storage;
      IF job_scheduler_table.validation_categories_p = NIL THEN
        jmp$internal_error (80);
      IFEND;

      FOR i := 1 TO mainframe_count DO
        pmp$convert_mainframe_to_binary (validation_categories^ [i].
              mainframe_id, validation_categories^ [i].binary_mainframe_id,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        job_scheduler_table.validation_categories_p^ [i] :=
              validation_categories^ [i];
      FOREND;

    PROCEND build_scheduler_table;
?? TITLE := ' build_service_class_table', EJECT ??

{ PURPOSE:
{   This routine builds a service class table from the service class object's
{   attributes.
{
{ DESIGN:
{   The service class attributes are first merged with the defaults and
{   all keyword attributes are converted into constants.  From the resulting
{   attributes the service class table is build.
{
{ NOTES:
{   Special processing is done for
{     long_wait_think_time,
{     maximum_active_jobs;
{     dispatching_control .service_limit and .dispatching_priority;
{     swap_age_interval.

    PROCEDURE build_service_class_table
      (    service_class: jmt$profile_object;
       VAR service_class_table: jmt$service_class_attributes);

      VAR
        i: integer,
        service_limit: integer,
        maximum_active_jobs: integer,
        service_class_attributes: ^jmt$object_attribute_list,
        dispatching_control_list: ^jmt$object_attribute_list,
        dispatching_control: ^jmt$object_attribute_list,
        scheduling_priority: ^jmt$object_attribute_list,
        service_factors: ^jmt$object_attribute_list;

      get_object_attributes (service_class, service_class_attributes);

{   Group definition attributes

      service_class_table.defined := TRUE;
      service_class_table.index := service_class.index;
      service_class_table.profile_identification :=
            service_class.definition_id;
      service_class_table.name := service_class.name;

      service_class_table.abbreviation := service_class_attributes^ [
            jmc$sc_abbreviation].name^;

{   Group control attributes

      service_class_table.aio_limit :=
            service_class_attributes^ [jmc$sc_aio_limit].number;
      service_class_table.class_service_threshold :=
            service_class_attributes^ [jmc$sc_class_resource_threshold].number;
      service_class_table.guaranteed_service_quantum :=
            service_class_attributes^ [jmc$sc_guaranteed_service_quan].number;
      service_class_table.long_wait_think_time :=
            service_class_attributes^ [jmc$sc_long_wait_think_time].number *
            microseconds_per_millisecond;

      IF service_class_attributes^ [jmc$sc_enable_class_execution].bool THEN
        maximum_active_jobs := service_class_attributes^ [
              jmc$sc_maximum_active_jobs].number;
        IF maximum_active_jobs > jmc$unlimited_max_active_jobs THEN
          maximum_active_jobs := jmc$unlimited_max_active_jobs;
        IFEND;
      ELSE
        maximum_active_jobs := 0;
      IFEND;
      service_class_table.maximum_active_jobs := maximum_active_jobs;

      service_class_table.next_service_class_index := 0;
      IF service_class_attributes^ [jmc$sc_next_service_class].kind =
            jmc$object THEN
        service_class_table.next_service_class_index :=
              service_class_attributes^ [jmc$sc_next_service_class].object_p^.
              index;
      IFEND;

      service_factors := service_class_attributes^ [jmc$sc_service_factors].
            attribute_list;
      service_class_table.service_factors [jmc$sf_cpu] :=
            service_factors^ [1].number;
      service_class_table.service_factors [jmc$sf_memory] :=
            service_factors^ [2].number;
      service_class_table.service_factors [jmc$sf_residence] :=
            service_factors^ [3].number;
      service_class_table.service_factors [jmc$sf_io] :=
            service_factors^ [4].number;

{   Group priority attributes

      FOR i := 1 TO UPPERBOUND (service_class_table.dispatching_control) DO
        service_class_table.dispatching_control [i].set_defined := FALSE;
      FOREND;

      dispatching_control_list := service_class_attributes^ [
            jmc$sc_dispatching_control].attribute_list;
      FOR i := 1 TO UPPERBOUND (dispatching_control_list^) DO
        dispatching_control := dispatching_control_list^ [i].attribute_list;
        service_class_table.dispatching_control [i].set_defined := TRUE;
        service_class_table.dispatching_control [i].dispatching_priority :=
              dispatching_control^ [1].number + dispatching_priority_offset;
        service_limit := dispatching_control^ [2].number *
              milliseconds_per_second;
        IF service_limit = (jmc$highest_service_limit + jmc$unlimited_offset *
              milliseconds_per_second) THEN
          service_limit := jmc$dc_maximum_service_limit;
        IFEND;
        service_class_table.dispatching_control [i].service_limit :=
              service_limit;
        service_class_table.dispatching_control [i].dispatching_timeslice.
              minor := job_scheduler_table.cpu_quantum_time *
              dispatching_control^ [3].number;
        service_class_table.dispatching_control [i].dispatching_timeslice.
              major := job_scheduler_table.cpu_quantum_time *
              dispatching_control^ [4].number;
      FOREND;

      scheduling_priority := service_class_attributes^ [
            jmc$sc_scheduling_priority].attribute_list;
      service_class_table.scheduling_priority.minimum :=
            scheduling_priority^ [1].number;
      service_class_table.scheduling_priority.maximum :=
            scheduling_priority^ [2].number;
      service_class_table.scheduling_priority.swap_age_increment :=
            scheduling_priority^ [3].number;
      service_class_table.scheduling_priority.ready_task_increment :=
            scheduling_priority^ [4].number;

      service_class_table.swap_age_interval :=
            service_class_attributes^ [jmc$sc_swap_age_interval].number *
            microseconds_per_second;

    PROCEND build_service_class_table;
?? TITLE := ' get_object_attributes', EJECT ??

{ PURPOSE:
{   This routine converts the key attributes into the appropriate constants.
{
{ DESIGN:
{   All key attributes are located and converted into appropriate constants
{   for the calling routines convenience.

    PROCEDURE get_object_attributes
      (    object: jmt$profile_object;
       VAR attributes: ^jmt$object_attribute_list);

?? NEWTITLE := 'replace_keywords_with_values', EJECT ??

      PROCEDURE replace_keywords_with_values
        (    definition: jmt$profile_declaration;
         VAR result: jmt$object_attribute);

        TYPE
          attribute_kind_set = set of jmt$object_attribute_kinds;

        VAR
          desired_list_size: integer,
          i: integer,
          keyword_kinds: [STATIC, READ] attribute_kind_set :=
                [jmc$unlimited, jmc$unspecified, jmc$system_default, jmc$none],
          list_kinds: [STATIC, READ] attribute_kind_set :=
                [jmc$list, jmc$range, jmc$editable_list, jmc$type];

        IF result.kind IN list_kinds THEN
          desired_list_size := UPPERBOUND (result.attribute_list^);
          IF result.kind = jmc$type THEN
            FOR i := 1 TO desired_list_size DO
              replace_keywords_with_values (definition.declarations^ [i]^,
                    result.attribute_list^ [i]);
            FOREND;
          ELSE
            FOR i := 1 TO desired_list_size DO
              replace_keywords_with_values (definition.declarations^ [1]^,
                    result.attribute_list^ [i]);
            FOREND;
          IFEND;

        ELSEIF result.kind IN keyword_kinds THEN
          IF (definition.kind = jmc$number) OR
                (definition.kind = jmc$dispatching_priority) THEN
            CASE result.kind OF
            = jmc$unspecified, jmc$none =
              result.number := definition.maximum + jmc$unspecified_offset;
            = jmc$unlimited =
              result.number := definition.maximum + jmc$unlimited_offset;
            = jmc$system_default =
              result.number := definition.maximum + jmc$system_default_offset;
            CASEND;
            result.kind := definition.kind;

          ELSEIF definition.kind = jmc$name THEN
            NEXT result.name IN jmv$working_storage;
            IF result.name = NIL THEN
              jmp$internal_error (83);
            IFEND;
            CASE result.kind OF
            = jmc$unspecified =
              result.name^ := 'UNSPECIFIED';
            = jmc$unlimited =
              result.name^ := 'UNLIMITED';
            = jmc$none =
              result.name^ := osc$null_name;
            = jmc$system_default =
              result.name^ := 'SYSTEM_DEFAULT';
            CASEND;
            result.kind := definition.kind;
          IFEND;
        IFEND;
      PROCEND replace_keywords_with_values;
?? OLDTITLE, EJECT ??

      VAR
        attribute: jmt$object_attribute,
        ignored_status: ost$status;

      jmp$get_attributes_for_display (profile, object, attribute,
            ignored_status);
      replace_keywords_with_values (jmv$object_definition [object.kind].
            declaration, attribute);
      attributes := attribute.attribute_list;

    PROCEND get_object_attributes;
?? OLDTITLE, EJECT ??

    VAR
      application: jmt$profile_object_reference,
      job_class: jmt$profile_object_reference,
      profile_index: jmt$job_class,
      service_class: jmt$profile_object_reference,
      table_size: integer,
      table_index: integer;

    analyse_job_categories (all_job_categories);

    build_scheduler_table (job_scheduler_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Build job class scheduling table.

    table_size := 0;
    job_class := profile.objects [jmc$profile_job_class];
    WHILE job_class <> NIL DO
      IF job_class^.changed OR NOT compress THEN
        table_size := table_size + 1;
      IFEND;
      job_class := job_class^.next_object;
    WHILEND;

    job_class_table := NIL;
    IF table_size > 0 THEN
      NEXT job_class_table: [1 .. table_size] IN jmv$working_storage;
      IF job_class_table = NIL THEN
        jmp$internal_error (84);
      IFEND;
      table_index := 0;
      profile_index := 0;
      job_class := profile.objects [jmc$profile_job_class];
      WHILE job_class <> NIL DO
        profile_index := profile_index + 1;
        IF job_class^.changed OR NOT compress THEN
          table_index := table_index + 1;
          build_job_class_table (job_class^, job_class_table^ [table_index]);
          job_class_table^ [table_index].profile_index := profile_index;
        IFEND;
        job_class := job_class^.next_object;
      WHILEND;
    IFEND;

{ Build service class scheduling table.

    table_size := 0;
    service_class := profile.objects [jmc$profile_service_class];
    WHILE service_class <> NIL DO
      IF service_class^.changed OR NOT compress THEN
        table_size := table_size + 1;
      IFEND;
      service_class := service_class^.next_object;
    WHILEND;

    service_class_table := NIL;
    IF table_size <> 0 THEN
      NEXT service_class_table: [1 .. table_size] IN jmv$working_storage;
      IF service_class_table = NIL THEN
        jmp$internal_error (85);
      IFEND;
      table_index := 0;
      service_class := profile.objects [jmc$profile_service_class];
      WHILE service_class <> NIL DO
        IF service_class^.changed OR NOT compress THEN
          table_index := table_index + 1;
          build_service_class_table (service_class^,
                service_class_table^ [table_index]);
        IFEND;
        service_class := service_class^.next_object;
      WHILEND;
    IFEND;

{ Build application scheduling table.

    table_size := 0;
    application := profile.objects [jmc$profile_application];
    WHILE application <> NIL DO
      IF application^.changed OR NOT compress THEN
        table_size := table_size + 1;
      IFEND;
      application := application^.next_object;
    WHILEND;

    application_table := NIL;
    IF table_size <> 0 THEN
      NEXT application_table: [1 .. table_size] IN jmv$working_storage;
      IF application_table = NIL THEN
        jmp$internal_error (86);
      IFEND;
      table_index := 0;
      application := profile.objects [jmc$profile_application];
      WHILE application <> NIL DO
        IF application^.changed OR NOT compress THEN
          table_index := table_index + 1;
          build_application_table (application^,
                application_table^ [table_index]);
        IFEND;
        application := application^.next_object;
      WHILEND;
    IFEND;

{ Build job category table.

    IF NOT compress THEN
      build_category_table (job_category_table);
    IFEND;

  PROCEND jmp$build_tables_from_profile;
MODEND jmm$convert_to_scheduler_types;
*DECK DECK=JMM$FORWARD_OFFLINE_OUTPUT EXPAND=TRUE
PROCEDURE (jmm$mano_foroo, hidden) jmm$forward_offline_output (
  output_destination, ode: any of
      string 0..31
      name
    anyend = $required
  status)

  "$FORMAT=OFF"
  VAR
    selected_output: list 0..$max_list of name = ()
    ignore_status: status
  VAREND
  "$FORMAT=ON"

  $system.MANAGE_OUTPUT
    select_output output_destination_usage=offline osl=selected_output
    FOR EACH output_file IN selected_output DO
      $system.change_output_attributes name=output_file output_destination_usage=qtf ..
            output_destination=output_destination status=ignore_status
    FOREND
  QUIT

PROCEND jmm$forward_offline_output
*DECK DECK=JMM$GENERAL_PURPOSE_CLUSTER_RPC EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Job Management - general purpose cluster interfaces' ??
MODULE jmm$general_purpose_cluster_rpc;

{ PURPOSE:
{   This module contains routines that are used for processing general purpose
{ remote procedure calls.

{ NOTES:
{   To add an additional target procedure for this request do the following:
{   o  Change the type jmt$general_purpose_rpc_ordinal to define an ordinal for
{      the new procedure.
{   o  Create an XREF deck for the new procedure as follows:
{         PROCEDURE [XREF] jmp$new_procedure (
{           (    target_options_p: ^SEQ ( * );
{            VAR data_area_p: (input, output) ^SEQ ( * );
{            VAR number_of_data_packets: ost$non_negative_integers;
{            VAR status: ost$status)
{   o  Place a *copyc of the above mentioned XREF deck in this module.
{   o  Change the variable v$gpcr_procedures to include a pointer to the new procedure
{      at the newly defined ordinal location.
{   o  Make the controlling function call the procedure jmp$general_purpose_cluster_rpc and
{      complete the code in the new procedure according to the purpose of the function.
{   o  Test the request first using one mainframe.  Once verified, test the request using
{      two mainframes in a cluster.  It should work without any changes.  There is no
{      need to test with more than two mainframes (i.e., indirectly coupled mainframes).

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_parameters
*copyc jmc$job_management_id
*copyc jme$work_area_too_small
*copyc jmt$general_purpose_rpc_ordinal
*copyc jmt$rpc_mainframes_processed
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc dfp$get_partner_mainframes
*copyc dfp$receive_server_rpc_segment
*copyc dfp$reserve_server_rpc_segment
*copyc dfp$send_remote_procedure_call
*copyc i#current_sequence_position
*copyc jmp$get_leveling_data
*copyc jmp$mainframe_change_input_attr
*copyc jmp$mainframe_change_output_att
*copyc jmp$mainframe_get_input_attribu
*copyc jmp$mainframe_get_job_status
*copyc jmp$mainframe_get_output_attrib
*copyc jmp$mainframe_get_output_status
*copyc jmp$mainframe_set_sense_switch
*copyc jmp$mainframe_terminate_output
*copyc osp$generate_log_message
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc pmp$convert_binary_mainframe_id
*copyc pmp$convert_mainframe_to_binary
*copyc pmp$get_mainframe_id
*copyc pmp$get_pseudo_mainframe_id
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by this Module', EJECT ??

  TYPE
    t$gpcr_procedure_p = ^procedure (    target_options_p: ^SEQ ( * );
                                     VAR data_area_p: ^SEQ ( * );
                                     VAR number_of_data_packets: ost$non_negative_integers;
                                     VAR status: ost$status);

  VAR
    v$gpcr_procedures: [STATIC, READ, oss$job_paged_literal] array [jmt$general_purpose_rpc_ordinal] of
          t$gpcr_procedure_p := [
?? FMT (FORMAT := OFF) ??
{ jmc$gpro_get_job_status         } ^jmp$mainframe_get_job_status,
{ jmc$gpro_get_output_status      } ^jmp$mainframe_get_output_status,
{ jmc$gpro_get_output_attributes  } ^jmp$mainframe_get_output_attrib,
{ jmc$gpro_get_input_attributes   } ^jmp$mainframe_get_input_attribu,
{ jmc$gpro_change_output_attribut } ^jmp$mainframe_change_output_att,
{ jmc$gpro_change_input_attribute } ^jmp$mainframe_change_input_attr,
{ jmc$gpro_terminate_output       } ^jmp$mainframe_terminate_output,
{ jmc$gpro_set_sense_switches     } ^jmp$mainframe_set_sense_switch,
{ jmc$gpro_get_leveling_data      } ^jmp$get_leveling_data,
{ jmc$gpro_unused_ordinal         } NIL
?? FMT (FORMAT := ON) ??
    ];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$general_purpose_cluster_rpc', EJECT ??
*copy jmh$general_purpose_cluster_rpc

  PROCEDURE [XDCL] jmp$general_purpose_cluster_rpc
    (    target_mainframe_id: pmt$mainframe_id;
         procedure_ordinal: jmt$general_purpose_rpc_ordinal;
         data_packet_size: ost$segment_length;
         mainframes_processed_so_far: jmt$rpc_mainframes_processed;
         target_options_p: ^SEQ ( * );
     VAR data_area_p: {input, output} ^SEQ ( * );
     VAR target_mainframe_reached: boolean;
     VAR mainframes_processed: jmt$rpc_mainframes_processed;
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      binary_target_mainframe_id: pmt$binary_mainframe_id,
      current_mainframe_id: pmt$mainframe_id,
      local_status: ost$status,
      mainframe_id: pmt$mainframe_id,
      mainframes_searched_index: jmt$maximum_mainframes,
      server_mainframe_count: dft$partner_mainframe_count,
      server_mainframe_index: dft$partner_mainframe_count,
      server_mainframe_list: array [1 .. dfc$maximum_partner_mainframes] of dft$partner_mainframe_entry;

?? NEWTITLE := 'call_server_general_purpose_rpc', EJECT ??

{ NOTES:
{   This request will not return abnormal status if there is a remote procedure call failure.
{ If a problem occurs during communication with the server, this request treats it as though
{ the server could not be reached (from the current client).
{
{   This request will return the abnormal status JME$WORK_AREA_TOO_SMALL if the data area passed
{ in is not large enough to hold the data.  The number of data-packets returned by this request
{ still indicates the number of data elements that were available.
{
{ ASSUMPTION:
{   It is assumed that no more than a segment's worth of data can be returned by this request,
{ collectively by all servers in the cluster.  In short, it is not expected that the error
{ jme$work_area_too_small will be returned by this request except on the originating mainframe.

    PROCEDURE call_server_general_purpose_rpc
      (    mainframe_to_call: pmt$mainframe_id;
           target_mainframe_id: pmt$mainframe_id;
           procedure_ordinal: jmt$general_purpose_rpc_ordinal;
           data_packet_size: ost$segment_length;
           mainframes_processed_so_far: jmt$rpc_mainframes_processed;
           target_options_p: ^SEQ ( * );
       VAR number_of_data_packets {input, output} : ost$non_negative_integers;
       VAR data_area_p {input, output} : ^SEQ ( * );
       VAR target_mainframe_reached: boolean;
       VAR mainframes_processed: jmt$rpc_mainframes_processed;
       VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

      PROCEDURE dfp$remote_procedure_call_ch
        (    condition: pmt$condition;
             cond_desc: ^pmt$condition_information;
             save: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);

        dfp$ch_cleanup;
        osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
        EXIT call_server_general_purpose_rpc;

      PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
      VAR
        data_p: ^SEQ ( * ),
        data_packet_size_p: ^ost$segment_length,
        data_size: dft$send_data_size,
        ignore_status: ost$status,
        local_status: ost$status,
        mainframes_processed_p: ^jmt$rpc_mainframes_processed,
        number_of_data_packets_p: ^ost$non_negative_integers,
        number_of_packets: ost$non_negative_integers,
        options_p: ^SEQ ( * ),
        options_size_p: ^ost$non_negative_integers,
        queue_entry_location: dft$rpc_queue_entry_location,
        parameter_size: dft$send_parameter_size,
        procedure_ordinal_p: ^jmt$general_purpose_rpc_ordinal,
        received_from_server_data_p: dft$p_receive_data,
        received_from_server_params_p: dft$p_receive_parameters,
        send_to_server_data_p: dft$p_send_data,
        send_to_server_params_p: dft$p_send_parameters,
        server_location: dft$server_location,
        target_mainframe_id_p: ^pmt$mainframe_id,
        target_mainframe_reached_p: ^boolean;


      status.normal := TRUE;
      local_status.normal := TRUE;

      target_mainframe_reached := FALSE;
      mainframes_processed := mainframes_processed_so_far;
      server_location.server_location_selector := dfc$mainframe_id;
      server_location.server_mainframe := mainframe_to_call;

      dfp$begin_ch_remote_proc_call (server_location, {allowed_when_server_deactivated} FALSE,
            queue_entry_location, send_to_server_params_p, send_to_server_data_p, local_status);
      IF NOT local_status.normal THEN
        RETURN;
      IFEND;

{ The sequences for the remote procedure call have already been reset.

      NEXT procedure_ordinal_p IN send_to_server_params_p;
      procedure_ordinal_p^ := procedure_ordinal;
      NEXT target_mainframe_id_p IN send_to_server_params_p;
      target_mainframe_id_p^ := target_mainframe_id;
      NEXT data_packet_size_p IN send_to_server_params_p;
      data_packet_size_p^ := data_packet_size;
      NEXT mainframes_processed_p IN send_to_server_params_p;
      mainframes_processed_p^ := mainframes_processed_so_far;
      NEXT options_size_p IN send_to_server_params_p;
      options_size_p^ := #SIZE (target_options_p^);

      NEXT options_p: [[REP options_size_p^ OF cell]] IN send_to_server_data_p;
      options_p^ := target_options_p^;

      parameter_size := i#current_sequence_position (send_to_server_params_p);
      data_size := i#current_sequence_position (send_to_server_data_p);

      dfp$send_remote_procedure_call (queue_entry_location, dfc$rpc_jl_general_purpose, parameter_size,
            data_size, received_from_server_params_p, received_from_server_data_p, local_status);
      IF local_status.normal THEN
        NEXT target_mainframe_reached_p IN received_from_server_params_p;
        target_mainframe_reached := target_mainframe_reached_p^;
        NEXT mainframes_processed_p IN received_from_server_params_p;
        mainframes_processed := mainframes_processed_p^;
        NEXT number_of_data_packets_p IN received_from_server_params_p;
        IF number_of_data_packets_p^ > 0 THEN

{ Need to copy this value as it gets overwritten by the dfp$receive_server_rpc_segment
{ The spoil is used to keep the number_of_packets variable from being optimized out of
{ existence.  This will force the compiler to distinguish between the two values.

          number_of_packets := number_of_data_packets_p^;
          #SPOIL (number_of_packets);

          IF (number_of_packets * data_packet_size) > (#SIZE (data_area_p^) -
                i#current_sequence_position (data_area_p)) THEN
            number_of_data_packets := number_of_data_packets + number_of_packets;
            osp$set_status_condition (jme$work_area_too_small, status);
          ELSE

{ The data area sequence is positioned to the point where data should be added.

            NEXT data_p: [[REP (number_of_packets * data_packet_size) OF cell]] IN data_area_p;

            dfp$receive_server_rpc_segment (queue_entry_location, {server_segment_offset} 0,
                  number_of_packets * data_packet_size, data_p, local_status);
            IF local_status.normal THEN
              number_of_data_packets := number_of_data_packets + number_of_packets;
            ELSE
              RESET data_area_p TO data_p;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
      IF NOT local_status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
      IFEND;
      dfp$end_ch_remote_proc_call (queue_entry_location, ignore_status);
    PROCEND call_server_general_purpose_rpc;
?? OLDTITLE ??
?? EJECT ??

{ BEGIN: jmp$general_purpose_cluster_rpc

    status.normal := TRUE;

    mainframes_processed := mainframes_processed_so_far;
    target_mainframe_reached := FALSE;
    number_of_data_packets := 0;

    IF mainframes_processed.count < jmc$maximum_mainframes THEN

{ Add the current mainframe to the mainframes processed list.

      mainframes_processed.count := mainframes_processed.count + 1;
      pmp$get_pseudo_mainframe_id (mainframes_processed.mainframes [mainframes_processed.count]);

      pmp$get_mainframe_id (current_mainframe_id, {ignore} status);

{ If we are at the target mainframe, then call the procedure requested....

      IF current_mainframe_id = target_mainframe_id THEN
        target_mainframe_reached := TRUE;
        v$gpcr_procedures [procedure_ordinal]^ (target_options_p, data_area_p, number_of_data_packets,
              status);
      ELSE
        IF target_mainframe_id = pmc$null_mainframe_id THEN
          v$gpcr_procedures [procedure_ordinal]^ (target_options_p, data_area_p, number_of_data_packets,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        dfp$get_partner_mainframes ({partners_are_servers} TRUE, ^server_mainframe_list,
              server_mainframe_count);

        IF target_mainframe_id <> pmc$null_mainframe_id THEN
          pmp$convert_mainframe_to_binary (target_mainframe_id, binary_target_mainframe_id, local_status);
          IF local_status.normal THEN

{ Determine if the target mainframe is directly connected and available.

          /search_for_direct_mainframe/
            FOR server_mainframe_index := 1 TO server_mainframe_count DO
              IF (server_mainframe_list [server_mainframe_index].mainframe_id =
                    binary_target_mainframe_id) AND (server_mainframe_list [server_mainframe_index].
                    partner_state = dfc$active) THEN
                call_server_general_purpose_rpc ({mainframe_to_call} target_mainframe_id, target_mainframe_id,
                      procedure_ordinal, data_packet_size, mainframes_processed, target_options_p,
                      number_of_data_packets, data_area_p, target_mainframe_reached, mainframes_processed,
                      status);
                IF target_mainframe_reached OR (NOT status.normal) THEN
                  RETURN;
                ELSE
                  EXIT /search_for_direct_mainframe/;
                IFEND;
              IFEND;
            FOREND /search_for_direct_mainframe/;
          IFEND;
        IFEND;

{ The target is not directly connected or all mainframes are targeted.

      /call_each_server_mainframe/
        FOR server_mainframe_index := 1 TO server_mainframe_count DO
          IF mainframes_processed.count < jmc$maximum_mainframes THEN
            FOR mainframes_searched_index := 1 TO mainframes_processed.count DO
              IF mainframes_processed.mainframes [mainframes_searched_index] =
                    server_mainframe_list [server_mainframe_index].mainframe_id THEN
                CYCLE /call_each_server_mainframe/;
              IFEND;
            FOREND;

            IF server_mainframe_list [server_mainframe_index].partner_state = dfc$active THEN
              pmp$convert_binary_mainframe_id (server_mainframe_list [server_mainframe_index].mainframe_id,
                    mainframe_id, {ignore} status);
              call_server_general_purpose_rpc ({mainframe_to_call} mainframe_id, target_mainframe_id,
                    procedure_ordinal, data_packet_size, mainframes_processed, target_options_p,
                    number_of_data_packets, data_area_p, target_mainframe_reached, mainframes_processed,
                    status);
              IF target_mainframe_reached OR (NOT status.normal) THEN
                EXIT /call_each_server_mainframe/;
              IFEND;
            IFEND;
          IFEND;
        FOREND /call_each_server_mainframe/;
      IFEND
    IFEND;
  PROCEND jmp$general_purpose_cluster_rpc;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$server_general_purpose_rpc', EJECT ??
*copy jmh$server_general_purpose_rpc

  PROCEDURE [XDCL] jmp$server_general_purpose_rpc
    (VAR received_from_client_params_p { Input } : dft$p_receive_parameters;
     VAR received_from_client_data_p { Input } : dft$p_receive_data;
     VAR send_to_client_params_p { Output } : dft$p_send_parameters;
     VAR send_to_client_data_p { Output } : dft$p_send_data;
     VAR parameter_size: dft$send_parameter_size;
     VAR data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      data_packet_size_p: ^ost$segment_length,
      local_status: ost$status,
      mainframes_processed_p: ^jmt$rpc_mainframes_processed,
      mainframes_processed_so_far_p: ^jmt$rpc_mainframes_processed,
      number_of_data_packets_p: ^ost$non_negative_integers,
      options_p: ^SEQ ( * ),
      options_size_p: ^ost$non_negative_integers,
      procedure_ordinal_p: ^jmt$general_purpose_rpc_ordinal,
      send_to_client_segment_p: ^SEQ ( * ),
      target_mainframe_id_p: ^pmt$mainframe_id,
      target_mainframe_reached_p: ^boolean;

    status.normal := TRUE;

  /process_remote_procedure_call/
    BEGIN

{ The sequences for the remote procedure call have already been reset.

      NEXT procedure_ordinal_p IN received_from_client_params_p;
      NEXT target_mainframe_id_p IN received_from_client_params_p;
      NEXT data_packet_size_p IN received_from_client_params_p;
      NEXT mainframes_processed_so_far_p IN received_from_client_params_p;
      NEXT options_size_p IN received_from_client_params_p;

      NEXT options_p: [[REP options_size_p^ OF cell]] IN received_from_client_data_p;

      NEXT target_mainframe_reached_p IN send_to_client_params_p;
      NEXT mainframes_processed_p IN send_to_client_params_p;
      NEXT number_of_data_packets_p IN send_to_client_params_p;

      dfp$reserve_server_rpc_segment (send_to_client_segment_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET send_to_client_segment_p;
      jmp$general_purpose_cluster_rpc (target_mainframe_id_p^, procedure_ordinal_p^, data_packet_size_p^,
            mainframes_processed_so_far_p^, options_p, send_to_client_segment_p, target_mainframe_reached_p^,
            mainframes_processed_p^, number_of_data_packets_p^, status);
    END /process_remote_procedure_call/;
    parameter_size := i#current_sequence_position (send_to_client_params_p);
    data_size := i#current_sequence_position (send_to_client_data_p);

  PROCEND jmp$server_general_purpose_rpc;
?? OLDTITLE ??
MODEND jmm$general_purpose_cluster_rpc;

*DECK DECK=JMM$GENERIC_QUEUE_FILE_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE: Job Management Generic Queue File Interfaces' ??                                      
MODULE jmm$generic_queue_file_manager;                                                                        
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains the generic queue file management interfaces.  These interfaces control the          
{ access to, submission of, and manipulation of files in the generic queue.                                   
{                                                                                                             
{ DESIGN:                                                                                                     
{   The program interfaces contained in this module are designed in such a fashion that binary                
{ compatibility can be maintained.  Any change to the size of a record element in a variant record            
{ will result in an interface breakage.  These procedures operate in rings 2 and 3 with a call bracket        
{ of ring 6.                                                                                                  
{                                                                                                             
{ NOTE:                                                                                                       
{   The jmp$ procedures in this module are in alphabetical order, preceded by all the non-jmp$                
{ procedures also in alphabetical order.                                                                      
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc amt$access_level                                                                                       
*copyc amt$file_attributes                                                                                    
*copyc amt$get_attributes                                                                                     
*copyc amt$local_file_name                                                                                    
*copyc cle$ecc_lexical                                                                                        
*copyc fme$file_management_errors                                                                             
*copyc fst$evaluated_file_reference                                                                           
*copyc fst$file_reference                                                                                     
*copyc jmc$job_management_id                                                                                  
*copyc jmc$system_family                                                                                      
*copyc jme$duplicate_attribute_key                                                                            
*copyc jme$duplicate_name                                                                                     
*copyc jme$invalid_destination                                                                                
*copyc jme$invalid_parameter                                                                                  
*copyc jme$invalid_rhd                                                                                        
*copyc jme$latest_run_time_expired                                                                            
*copyc jme$no_qfiles_were_found                                                                               
*copyc jme$qfile_is_initiated                                                                                 
*copyc jme$qfile_state_is_null                                                                                
*copyc jme$system_label_internal_error                                                                        
*copyc jme$work_area_too_small                                                                                
*copyc jmt$attribute_keys_set                                                                                 
*copyc jmt$name                                                                                               
*copyc jmt$name_list                                                                                          
*copyc jmt$qfile_application_attrs                                                                            
*copyc jmt$qfile_attribute_changes                                                                            
*copyc jmt$qfile_attribute_options                                                                            
*copyc jmt$qfile_attribute_results                                                                            
*copyc jmt$qfile_registration_options                                                                         
*copyc jmt$qfile_status_count                                                                                 
*copyc jmt$qfile_status_options                                                                               
*copyc jmt$qfile_status_results                                                                               
*copyc jmt$qfile_status_updates                                                                               
*copyc jmt$qfile_submission_options                                                                           
*copyc jmt$qfile_termination_options                                                                          
*copyc jmt$queue_file_password                                                                                
*copyc jmt$queue_file_path                                                                                    
*copyc jmt$results_keys                                                                                       
*copyc jmt$system_supplied_name                                                                               
*copyc ofe$error_codes                                                                                        
*copyc oss$task_private                                                                                       
*copyc ost$caller_identifier                                                                                  
*copyc ost$date_time                                                                                          
*copyc ost$status                                                                                             
*copyc pmt$entry_point_reference                                                                              
?? POP ??                                                                                                     
*copyc amp$return                                                                                             
*copyc bap$validate_file_identifier                                                                           
*copyc clp$trimmed_string_size                                                                                
*copyc clp$validate_name                                                                                      
*copyc fsp$close_file                                                                                         
*copyc fsp$open_and_get_type_of_copy                                                                          
*copyc fsp$open_file                                                                                          
*copyc fsp$subsystem_copy_file                                                                                
*copyc i#current_sequence_position                                                                            
*copyc i#move                                                                                                 
*copyc ifp$invoke_pause_utility                                                                               
*copyc jmp$convert_date_time_dif_to_us                                                                        
*copyc jmp$get_attribute_name                                                                                 
*copyc jmp$get_jm_work_area                                                                                   
*copyc jmp$get_result_size                                                                                    
*copyc jmp$validate_name                                                                                      
*copyc mmp$create_scratch_segment                                                                             
*copyc mmp$delete_scratch_segment                                                                             
*copyc osp$append_status_parameter                                                                            
*copyc osp$disestablish_cond_handler                                                                          
*copyc osp$establish_block_exit_hndlr                                                                         
*copyc osp$establish_condition_handler                                                                        
*copyc osp$set_status_abnormal                                                                                
*copyc osp$set_status_condition                                                                               
*copyc osp$set_status_from_condition                                                                          
*copyc osp$verify_system_privilege                                                                            
*copyc pfp$attach                                                                                             
*copyc pfp$begin_system_authority                                                                             
*copyc pfp$define                                                                                             
*copyc pfp$define_catalog                                                                                     
*copyc pfp$end_system_authority                                                                               
*copyc pfp$purge                                                                                              
*copyc pmp$compute_date_time                                                                                  
*copyc pmp$compute_date_time_increment                                                                        
*copyc pmp$continue_to_cause                                                                                  
*copyc pmp$get_compact_date_time                                                                              
*copyc pmp$get_microsecond_clock                                                                              
*copyc pmp$get_unique_name                                                                                    
*copyc qfp$acquire_modified_qfile                                                                             
*copyc qfp$acquire_new_qfile                                                                                  
*copyc qfp$assign_system_supplied_name                                                                        
*copyc qfp$change_qfile_attributes                                                                            
*copyc qfp$get_qfile_status                                                                                   
*copyc qfp$purge_expired_queue_file                                                                           
*copyc qfp$purge_processed_queue_file                                                                         
*copyc qfp$read_qfile_system_label                                                                            
*copyc qfp$rebuild_generic_queue                                                                              
*copyc qfp$register_qfile_application                                                                         
*copyc qfp$release_generic_queue_files                                                                        
*copyc qfp$set_qfile_completed                                                                                
*copyc qfp$set_qfile_initiated                                                                                
*copyc qfp$submit_qfile                                                                                       
*copyc qfp$terminate_acquired_qfile                                                                           
*copyc qfp$terminate_qfile                                                                                    
*copyc qfp$validate_qfile_access                                                                              
*copyc qfp$write_qfile_system_label                                                                           
*copyc syp$system_is_idling                                                                                   
*copyc amv$nil_file_identifier                                                                                
*copyc jmv$job_management_work_area_p                                                                         
*copyc jmv$known_qfile_list                                                                                   
*copyc jmv$last_used_application_index                                                                        
*copyc osv$lower_to_upper                                                                                     
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'Global Declarations Declared by this Module', EJECT ??                                        
                                                                                                              
  VAR                                                                                                         
    task_has_registered_application: [STATIC, oss$task_private] boolean := FALSE;                             
                                                                                                              
{ These constants are used as parameters in error messages.                                                   
                                                                                                              
  CONST                                                                                                       
    jmc$change_qfile_attributes = 'JMP$CHANGE_QFILE_ATTRIBUTES',                                              
    jmc$get_qfile_attributes = 'JMP$GET_QFILE_ATTRIBUTES',                                                    
    jmc$get_qfile_status = 'JMP$GET_QFILE_STATUS',                                                            
    jmc$submit_qfile = 'JMP$SUBMIT_QFILE',                                                                    
    jmc$terminate_qfile = 'JMP$TERMINATE_QFILE',                                                              
    jmc$update_qfile_status = 'JMP$UPDATE_QFILE_STATUS';                                                      
                                                                                                              
  TYPE                                                                                                        
    qfile_appl_attribute_choices = array [jmc$application_attributes_1 .. jmc$application_attributes_10] of   
          record                                                                                              
      key: jmt$attribute_keys,                                                                                
      application_attributes: jmt$qfile_application_attrs,                                                    
    recend;                                                                                                   
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'acquire_qfile', EJECT ??                                                                      
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this request is to acquire a file from the generic queue.  What this means is to attach    
{ the file and read its system label information.  A subset of this information is then placed in             
{ the attribute_results array.                                                                                
{ DESIGN:                                                                                                     
{ IF new_qfile THEN                                                                                           
{   Validate the application and update the KQL (qfp$acquire_new_qfile)                                       
{ ELSE                                                                                                        
{   Validate the application and update the KQL (qfp$acquire_modified_qfile)                                  
{ IFEND                                                                                                       
{ IF queue is empty THEN                                                                                      
{   RETURN                                                                                                    
{ IFEND                                                                                                       
{ IF the caller has supplied a work area for queue file attributes THEN                                       
{   Call jmp$get_qfile_attributes to:                                                                         
{     Attach the file                                                                                         
{     Read the label                                                                                          
{     Release the file in case somebody needs it for write access                                             
{     Set up the attribute_results array                                                                      
{ IFEND                                                                                                       
                                                                                                              
  PROCEDURE acquire_qfile                                                                                     
    (    application_name: ost$name;                                                                          
         new_qfile: boolean;                                                                                  
         attribute_keys_p: ^jmt$results_keys;                                                                 
     VAR attribute_work_area_p: ^jmt$work_area;                                                               
     VAR attribute_results_p: ^jmt$qfile_attribute_results;                                                   
     VAR system_file_name: jmt$system_supplied_name;                                                          
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      attribute_options_p: ^jmt$qfile_attribute_options,                                                      
      number_of_qfiles_found: jmt$qfile_status_count;                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    IF syp$system_is_idling () THEN                                                                           
      osp$set_status_condition (jme$generic_queue_is_empty, status);                                          
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Acquire the file                                                                                            
                                                                                                              
    IF new_qfile THEN                                                                                         
      qfp$acquire_new_qfile (application_name, system_file_name, status);                                     
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
    ELSE                                                                                                      
      qfp$acquire_modified_qfile (application_name, system_file_name, status);                                
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    IF attribute_work_area_p <> NIL THEN                                                                      
                                                                                                              
{ Set up parameters for call to jmp$get_qfile_attributes.                                                     
                                                                                                              
      PUSH attribute_options_p: [1 .. 1];                                                                     
      attribute_options_p^ [1].key := jmc$system_supplied_name_list;                                          
      PUSH attribute_options_p^ [1].system_supplied_name_list: [1 .. 1];                                      
      attribute_options_p^ [1].system_supplied_name_list^ [1] := system_file_name;                            
                                                                                                              
      jmp$get_qfile_attributes (attribute_options_p, attribute_keys_p, attribute_work_area_p,                 
            attribute_results_p, number_of_qfiles_found, status);                                             
    IFEND;                                                                                                    
                                                                                                              
  PROCEND acquire_qfile;                                                                                      
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[INLINE] determine_file_path', EJECT ??                                                       
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this request is to PUSH the correct path name for a queue file on the requester's          
{ stack.                                                                                                      
{                                                                                                             
{ NOTES:                                                                                                      
{   This procedure MUST be INLINE.                                                                            
                                                                                                              
  PROCEDURE [INLINE] determine_file_path                                                                      
    (    system_file_name: jmt$system_supplied_name;                                                          
     VAR path_p: ^pft$path);                                                                                  
                                                                                                              
    PUSH path_p: [1 .. 4];                                                                                    
    path_p^ [1] := jmc$system_family;                                                                         
    path_p^ [2] := jmc$system_user;                                                                           
    path_p^ [3] := jmc$generic_queue_catalog;                                                                 
    path_p^ [4] := system_file_name;                                                                          
  PROCEND determine_file_path;                                                                                
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'pack_application_attributes', EJECT ??                                                        
                                                                                                              
{ PURPOSE:                                                                                                    
{     The purpose of this procedure is to take an array of application attributes                             
{ and pack it into the form expected in the queue file system label. It also                                  
{ calculates the total amount of space needed for the application attributes field                            
{ in the system label.                                                                                        
{ DESIGN:                                                                                                     
{ The application attribute choices passed in must be in ascending numerical order.                           
{ FOR each attribute choice                                                                                   
{   Put the key and size in the sequence                                                                      
{   IF size of attribute > 0 THEN                                                                             
{     Put the attribute contents in the sequence                                                              
{   IFEND                                                                                                     
{   Add the size of the key field, size field and attributes field to the total size.                         
{ FOREND                                                                                                      
                                                                                                              
  PROCEDURE pack_application_attributes                                                                       
    (    qfile_appl_attribute_choices_p: ^qfile_appl_attribute_choices;                                       
         system_label_p {input, output} : ^jmt$qfile_system_label;                                            
     VAR total_size: jmt$qsl_appl_attr_contents_size;                                                         
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      attribute_index: integer,                                                                               
      attributes_p: ^SEQ ( * ),                                                                               
      key_p: ^jmt$attribute_keys,                                                                             
      qsl_appl_attr_contents_p: ^jmt$qsl_appl_attr_contents,                                                  
      size_p: ^jmt$qfile_appl_attr_size;                                                                      
                                                                                                              
    status.normal := TRUE;                                                                                    
    total_size := 0;                                                                                          
    qsl_appl_attr_contents_p := ^system_label_p^.application_attributes;                                      
    RESET qsl_appl_attr_contents_p;                                                                           
    FOR attribute_index := jmc$application_attributes_1 TO jmc$application_attributes_10 DO                   
      NEXT key_p IN qsl_appl_attr_contents_p;                                                                 
      IF key_p = NIL THEN                                                                                     
        osp$set_status_condition (jme$system_label_internal_error, status);                                   
        RETURN;                                                                                               
      IFEND;                                                                                                  
      key_p^ := qfile_appl_attribute_choices_p^ [attribute_index].key;                                        
      NEXT size_p IN qsl_appl_attr_contents_p;                                                                
      IF size_p = NIL THEN                                                                                    
        osp$set_status_condition (jme$system_label_internal_error, status);                                   
        RETURN;                                                                                               
      IFEND;                                                                                                  
      size_p^ := qfile_appl_attribute_choices_p^ [attribute_index].application_attributes.size;               
      IF qfile_appl_attribute_choices_p^ [attribute_index].application_attributes.size > 0 THEN               
        NEXT attributes_p: [[REP size_p^ OF cell]] IN qsl_appl_attr_contents_p;                               
        IF attributes_p = NIL THEN                                                                            
          osp$set_status_condition (jme$system_label_internal_error, status);                                 
          RETURN;                                                                                             
        IFEND;                                                                                                
        i#move (qfile_appl_attribute_choices_p^ [attribute_index].application_attributes.attributes_p,        
              attributes_p, size_p^);                                                                         
      IFEND;                                                                                                  
    FOREND;                                                                                                   
    total_size := i#current_sequence_position (qsl_appl_attr_contents_p);                                     
  PROCEND pack_application_attributes;                                                                        
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'unpack_application_attributes', EJECT ??                                                      
                                                                                                              
{ PURPOSE:                                                                                                    
{     The purpose of this procedure is to unpack the application attributes from the system label             
{ into an array.                                                                                              
{                                                                                                             
{ DESIGN:                                                                                                     
{ Initialize the array to be returned with size 0, attributes_p NIL.                                          
{ FOR EACH key in the application attributes in the system label                                              
{  Get the size key                                                                                           
{  IF size > 0 THEN get the application attributes from the system label                                      
{ FOREND                                                                                                      
                                                                                                              
  PROCEDURE unpack_application_attributes                                                                     
    (    system_label_p: ^jmt$qfile_system_label;                                                             
         attribute_choices_p {input, output} : ^qfile_appl_attribute_choices;                                 
     VAR attribute_work_area_p: ^jmt$work_area;                                                               
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      application_attributes_p: ^SEQ ( * ),                                                                   
      appl_attr_work_area_p: ^jmt$work_area,                                                                  
      attribute_index: integer,                                                                               
      key_p: ^jmt$attribute_keys,                                                                             
      qsl_appl_attr_contents_p: ^jmt$qsl_appl_attr_contents,                                                  
      size_p: ^jmt$qfile_appl_attr_size;                                                                      
                                                                                                              
    status.normal := TRUE;                                                                                    
    IF attribute_choices_p <> NIL THEN                                                                        
      FOR attribute_index := jmc$application_attributes_1 TO jmc$application_attributes_10 DO                 
        attribute_choices_p^ [attribute_index].key := attribute_index;                                        
        attribute_choices_p^ [attribute_index].application_attributes.size := 0;                              
        attribute_choices_p^ [attribute_index].application_attributes.attributes_p := NIL;                    
      FOREND;                                                                                                 
      RESET attribute_work_area_p;                                                                            
                                                                                                              
      qsl_appl_attr_contents_p := ^system_label_p^.application_attributes;                                    
      RESET qsl_appl_attr_contents_p;                                                                         
      FOR attribute_index := jmc$application_attributes_1 TO jmc$application_attributes_10 DO                 
        NEXT key_p IN qsl_appl_attr_contents_p;                                                               
        IF key_p <> NIL THEN                                                                                  
          NEXT size_p IN qsl_appl_attr_contents_p;                                                            
          IF size_p <> NIL THEN                                                                               
            IF size_p^ > 0 THEN                                                                               
              NEXT application_attributes_p: [[REP size_p^ OF cell]] IN qsl_appl_attr_contents_p;             
              NEXT appl_attr_work_area_p: [[REP size_p^ OF cell]] IN attribute_work_area_p;                   
              IF application_attributes_p <> NIL THEN                                                         
                attribute_choices_p^ [key_p^].application_attributes.size := size_p^;                         
                i#move (application_attributes_p, appl_attr_work_area_p, size_p^);                            
                attribute_choices_p^ [key_p^].application_attributes.attributes_p := appl_attr_work_area_p;   
              ELSE                                                                                            
                osp$set_status_condition (jme$system_label_internal_error, status);                           
                RETURN;                                                                                       
              IFEND;                                                                                          
            IFEND;                                                                                            
          ELSE                                                                                                
            osp$set_status_condition (jme$system_label_internal_error, status);                               
            RETURN;                                                                                           
          IFEND;                                                                                              
        ELSE                                                                                                  
          osp$set_status_condition (jme$system_label_internal_error, status);                                 
          RETURN;                                                                                             
        IFEND;                                                                                                
      FOREND;                                                                                                 
    IFEND;                                                                                                    
  PROCEND unpack_application_attributes;                                                                      
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$acquire_modified_qfile', EJECT ??                                           
*copy jmh$acquire_modified_qfile                                                                              
                                                                                                              
{ DESIGN:                                                                                                     
{ Call acquire_qfile with new_qfile=false                                                                     
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$acquire_modified_qfile                                                          
    (    application_name: ost$name;                                                                          
         attribute_keys_p: ^jmt$results_keys;                                                                 
     VAR attribute_work_area_p: ^jmt$work_area;                                                               
     VAR attribute_results_p: ^jmt$qfile_attribute_results;                                                   
     VAR system_file_name: jmt$system_supplied_name;                                                          
     VAR status: ost$status);                                                                                 
                                                                                                              
                                                                                                              
    status.normal := TRUE;                                                                                    
    acquire_qfile (application_name, { new_qfile } FALSE, attribute_keys_p, attribute_work_area_p,            
          attribute_results_p, system_file_name, status);                                                     
  PROCEND jmp$acquire_modified_qfile;                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$acquire_new_qfile', EJECT ??                                                
*copy jmh$acquire_new_qfile                                                                                   
                                                                                                              
{ DESIGN:                                                                                                     
{ Call acquire_qfile with new_qfile=true                                                                      
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$acquire_new_qfile                                                               
    (    application_name: ost$name;                                                                          
         attribute_keys_p: ^jmt$results_keys;                                                                 
     VAR attribute_work_area_p: ^jmt$work_area;                                                               
     VAR attribute_results_p: ^jmt$qfile_attribute_results;                                                   
     VAR system_file_name: jmt$system_supplied_name;                                                          
     VAR status: ost$status);                                                                                 
                                                                                                              
                                                                                                              
    status.normal := TRUE;                                                                                    
    acquire_qfile (application_name, { new_qfile } TRUE, attribute_keys_p, attribute_work_area_p,             
          attribute_results_p, system_file_name, status);                                                     
  PROCEND jmp$acquire_new_qfile;                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$change_qfile_attributes', EJECT ??                                          
*copy jmh$change_qfile_attributes                                                                             
                                                                                                              
{ DESIGN:                                                                                                     
{ Set up block exit and interactive condition handler                                                         
                                                                                                              
{ Call status procedure to determine the file to change                                                       
{ Determine the path of the file                                                                              
{ Attach the queue file and read the system label                                                             
{ FOR each attribute change DO                                                                                
{   validate as necessary and update the value in the system label                                            
{ FOREND                                                                                                      
{ IF earliest_run_time specified THEN                                                                         
{   earliest_run_time_clock := (earliest_run_time - current time) + current_clock_value                       
{ ELSE                                                                                                        
{   earliest_run_time_clock := earliest_clock_time                                                            
{ IFEND                                                                                                       
{ IF latest_run_time specified THEN                                                                           
{   latest_run_time_clock := (latest_run_time - current time) + current_clock_value                           
{ ELSE                                                                                                        
{   latest_run_time_clock := latest_clock_time                                                                
{ IFEND                                                                                                       
{ IF file_processed AND purge_delay specified THEN                                                            
{   IF purge_delay_changed THEN                                                                               
{     disposition_time := current_time                                                                        
{     purge_delay_clock := purge_delay_in_microseconds + current_clock_value                                  
{   ELSE                                                                                                      
{     purge_delay_clock := (disposition_time - current_time) +                                                
{           purge_delay_in_microseconds + current_clock_value                                                 
{   IFEND                                                                                                     
{ ELSE                                                                                                        
{   purge_delay_clock := earliest_clock_time                                                                  
{ IFEND                                                                                                       
{ IF file_processed AND rerun THEN                                                                            
{   IF latest_run_time_clock < current_clock THEN                                                             
{     detach the file                                                                                         
{     RETURN abnormal status jme$latest_run_time_expired                                                      
{   ELSE                                                                                                      
{     file_processed := false                                                                                 
{   IFEND                                                                                                     
{ IFEND                                                                                                       
{ Update the KQL with the new information (qfp$change_qfile_attributes)                                       
{ IF delete_qfile THEN                                                                                        
{   delete the file from the queue                                                                            
{ ELSE                                                                                                        
{   write the updated system label                                                                            
{   detach the file                                                                                           
{ IFEND                                                                                                       
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$change_qfile_attributes                                                         
    (    system_file_name: jmt$system_supplied_name;                                                          
         attribute_changes_p: ^jmt$qfile_attribute_changes;                                                   
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      attributes_size: jmt$qsl_appl_attr_contents_size,                                                       
      attribute_work_area_p: ^jmt$work_area,                                                                  
      change_index: integer,                                                                                  
      cycle_selector: pft$cycle_selector,                                                                     
      current_date_time: ost$date_time,                                                                       
      current_microsecond_clock: jmt$clock_time,                                                              
      date_time: ost$date_time,                                                                               
      delete_qfile: boolean,                                                                                  
      earliest_clock_time_to_process: jmt$clock_time,                                                         
      ignore_status: ost$status,                                                                              
      latest_clock_time_to_process: jmt$clock_time,                                                           
      local_file_name: amt$local_file_name,                                                                   
      new_appl_attributes_p: ^qfile_appl_attribute_choices,                                                   
      number_of_qfiles_found: jmt$qfile_status_count,                                                         
      old_appl_attributes_p: ^qfile_appl_attribute_choices,                                                   
      qfile_status_options_p: ^jmt$qfile_status_options,                                                      
      qfile_status_results_keys_p: ^jmt$results_keys,                                                         
      qfile_status_results_p: ^jmt$qfile_status_results,                                                      
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      purge_delay_clock_time: jmt$clock_time,                                                                 
      rerun_disposition: jmt$rerun_disposition,                                                               
      scl_name: ost$name,                                                                                     
      share_selections: pft$share_selections,                                                                 
      size_of_sequence: ost$segment_length,                                                                   
      system_label: jmt$qfile_system_label,                                                                   
      usage_selections: pft$usage_selections,                                                                 
      valid_name: boolean,                                                                                    
      work_area_p: ^jmt$work_area;                                                                            
                                                                                                              
?? NEWTITLE := 'condition_handler', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit and interactive                                  
{   conditions that arise from the attempt to attach a file in the generic queue.                             
{   If the file is busy, the attach processor goes into long term wait without                                
{   establishing a condition handler for interactive conditions - so it does                                  
{   not exit.  When pfp$attach gets changed to work correctly, this handler                                   
{   will no longer need to handle interactive conditions.                                                     
                                                                                                              
    PROCEDURE condition_handler                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      CASE condition.selector OF                                                                              
      = pmc$block_exit_processing =                                                                           
        pfp$end_system_authority;                                                                             
        amp$return (local_file_name, ignore_status);                                                          
        IF status.normal THEN                                                                                 
          osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);    
        IFEND;                                                                                                
                                                                                                              
      = ifc$interactive_condition =                                                                           
        IF condition.interactive_condition = ifc$pause_break THEN                                             
          ifp$invoke_pause_utility (handler_status);                                                          
        ELSE                                                                                                  
          osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);    
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);                             
          EXIT jmp$change_qfile_attributes;                                                                   
        IFEND;                                                                                                
                                                                                                              
      ELSE                                                                                                    
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);                               
      CASEND;                                                                                                 
    PROCEND condition_handler;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
    ignore_status.normal := TRUE;                                                                             
    status.normal := TRUE;                                                                                    
    pmp$get_compact_date_time (current_date_time, ignore_status);                                             
                                                                                                              
    PUSH qfile_status_options_p: [1 .. 1];                                                                    
    qfile_status_options_p^ [1].key := jmc$system_supplied_name_list;                                         
    PUSH qfile_status_options_p^ [1].system_supplied_name_list: [1 .. 1];                                     
    qfile_status_options_p^ [1].system_supplied_name_list^ [1] := system_file_name;                           
                                                                                                              
    PUSH qfile_status_results_keys_p: [1 .. 3];                                                               
    qfile_status_results_keys_p^ [1] := jmc$system_file_name;                                                 
    qfile_status_results_keys_p^ [2] := jmc$qfile_state;                                                      
    qfile_status_results_keys_p^ [3] := jmc$application_name;                                                 
                                                                                                              
    jmp$get_result_size ({number of files} 1, #SEQ (qfile_status_results_keys_p^), size_of_sequence);         
    PUSH work_area_p: [[REP size_of_sequence OF cell]];                                                       
                                                                                                              
    jmp$get_qfile_status (qfile_status_options_p, qfile_status_results_keys_p, work_area_p,                   
          qfile_status_results_p, number_of_qfiles_found, status);                                            
    IF NOT status.normal THEN                                                                                 
      IF status.condition = jme$no_qfiles_were_found THEN                                                     
        osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_file_name, status);        
      IFEND;                                                                                                  
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF number_of_qfiles_found > 1 THEN                                                                        
      osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_name, system_file_name, status);          
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF qfile_status_results_p^ [1]^ [2].qfile_state IN $jmt$qfile_state_set                                   
          [jmc$initiated_qfile, jmc$terminated_qfile] THEN                                                    
                                                                                                              
{ In order for the queue file state to be terminated, the file is either being processed or the application   
{ responsible for the file will momentarily return the file to queue file management.  In any case,           
{ the same error (jme$qfile_is_initiated) is reported since the later is not likely to occur.                 
                                                                                                              
      osp$set_status_abnormal (jmc$job_management_id, jme$qfile_is_initiated, system_file_name, status);      
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Attach the file so we can read the system label and get the attributes                                      
                                                                                                              
    pmp$get_unique_name (local_file_name, status);                                                            
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    determine_file_path (qfile_status_results_p^ [1]^ [1].system_file_name, path_p);                          
    cycle_selector.cycle_option := pfc$specific_cycle;                                                        
    cycle_selector.cycle_number := 1;                                                                         
    password := osc$null_name;                                                                                
    usage_selections := $pft$usage_selections [pfc$read, pfc$modify];                                         
    share_selections := $pft$share_selections [pfc$read];                                                     
                                                                                                              
{ Prepare in case the file is busy and the attach goes into long-term-wait.                                   
                                                                                                              
    osp$establish_condition_handler (^condition_handler, {block_exit} TRUE);                                  
                                                                                                              
    pfp$begin_system_authority;                                                                               
    pfp$attach (local_file_name, path_p^, cycle_selector, password, usage_selections, share_selections,       
          pfc$wait, status);                                                                                  
    pfp$end_system_authority;                                                                                 
    osp$disestablish_cond_handler;                                                                            
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Read the queue file's system label                                                                          
                                                                                                              
    qfp$read_qfile_system_label (local_file_name, system_label, status);                                      
    IF NOT status.normal THEN                                                                                 
      amp$return (local_file_name, ignore_status);                                                            
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    rerun_disposition := jmc$rr_no_change;                                                                    
                                                                                                              
{ Check attribute changes and change the local copy of the system label                                       
                                                                                                              
    IF attribute_changes_p <> NIL THEN                                                                        
      PUSH old_appl_attributes_p;                                                                             
      PUSH attribute_work_area_p: [[REP jmc$max_qfile_appl_attr_size OF cell]];                               
      unpack_application_attributes (^system_label, old_appl_attributes_p, attribute_work_area_p, status);    
      IF NOT status.normal THEN                                                                               
        amp$return (local_file_name, ignore_status);                                                          
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
    /process_changes/                                                                                         
      FOR change_index := 1 TO UPPERBOUND (attribute_changes_p^) DO                                           
        CASE attribute_changes_p^ [change_index].key OF                                                       
        = jmc$application_attributes_1, jmc$application_attributes_2, jmc$application_attributes_3,           
              jmc$application_attributes_4, jmc$application_attributes_5, jmc$application_attributes_6,       
              jmc$application_attributes_7, jmc$application_attributes_8, jmc$application_attributes_9,       
              jmc$application_attributes_10 =                                                                 
          old_appl_attributes_p^ [attribute_changes_p^ [change_index].key].application_attributes :=          
                attribute_changes_p^ [change_index].application_attributes;                                   
                                                                                                              
        = jmc$deferred_by_application =                                                                       
          system_label.deferred_by_application := attribute_changes_p^ [change_index].deferred_by_application;
                                                                                                              
        = jmc$destination =                                                                                   
          clp$validate_name (attribute_changes_p^ [change_index].destination, scl_name, valid_name);          
          IF valid_name THEN                                                                                  
            system_label.destination := scl_name;                                                             
          ELSE                                                                                                
            #TRANSLATE (osv$lower_to_upper, attribute_changes_p^ [change_index].destination,                  
                  system_label.destination);                                                                  
          IFEND;                                                                                              
                                                                                                              
        = jmc$earliest_run_time =                                                                             
          system_label.earliest_run_time := attribute_changes_p^ [change_index].earliest_run_time;            
                                                                                                              
        = jmc$latest_run_time =                                                                               
          system_label.latest_run_time := attribute_changes_p^ [change_index].latest_run_time;                
                                                                                                              
        = jmc$null_attribute =                                                                                
          ;                                                                                                   
                                                                                                              
        = jmc$purge_delay =                                                                                   
                                                                                                              
{ If the purge delay has changed, the disposition time has changed.                                           
                                                                                                              
          system_label.disposition_time.date_time := current_date_time;                                       
          system_label.purge_delay := attribute_changes_p^ [change_index].purge_delay^;                       
                                                                                                              
        = jmc$remote_host_directive =                                                                         
          system_label.remote_host_directive := attribute_changes_p^ [change_index].remote_host_directive^;   
                                                                                                              
        = jmc$rerun_disposition =                                                                             
          rerun_disposition := attribute_changes_p^ [change_index].rerun_disposition;                         
                                                                                                              
        ELSE                                                                                                  
          jmp$get_attribute_name (attribute_changes_p^ [change_index].key, scl_name);                         
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'QFILE_ATTRIBUTE_CHANGES', status);    
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$change_qfile_attributes, status);  
          EXIT /process_changes/;                                                                             
        CASEND;                                                                                               
      FOREND /process_changes/;                                                                               
      IF NOT status.normal THEN                                                                               
        amp$return (local_file_name, ignore_status);                                                          
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
{ Update the application attributes.                                                                          
                                                                                                              
      pack_application_attributes (old_appl_attributes_p, ^system_label, attributes_size, status);            
      IF NOT status.normal THEN                                                                               
        amp$return (local_file_name, ignore_status);                                                          
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
{ Calculate the earliest_run_time, latest_run_time and purge_delay if necessary.                              
                                                                                                              
      pmp$get_microsecond_clock (current_microsecond_clock, ignore_status);                                   
                                                                                                              
      IF system_label.earliest_run_time.specified THEN                                                        
        jmp$convert_date_time_dif_to_us (current_date_time, system_label.earliest_run_time.date_time,         
              current_microsecond_clock, earliest_clock_time_to_process);                                     
      ELSE                                                                                                    
        earliest_clock_time_to_process := jmc$earliest_clock_time;                                            
      IFEND;                                                                                                  
                                                                                                              
      IF system_label.latest_run_time.specified THEN                                                          
        jmp$convert_date_time_dif_to_us (current_date_time, system_label.latest_run_time.date_time,           
              current_microsecond_clock, latest_clock_time_to_process);                                       
      ELSE                                                                                                    
        latest_clock_time_to_process := jmc$latest_clock_time;                                                
      IFEND;                                                                                                  
                                                                                                              
{ If the file has been processed (i.e. disposition time is available) and a purge delay has been supplied then
{ calculate the free-running clock value at which the file can be purged.                                     
{ At this point the disposition time is the current time .. so the net result                                 
{ is that no matter what time the file was processed, it will be purged according to the purge delay          
{ supplied.  If the purge_delay has not changed, the disposition time will be the previous                    
{ disposition time.  This value is typically the time at which the file was processed.                        
                                                                                                              
      IF system_label.purge_delay.specified AND system_label.disposition_time.specified THEN                  
        pmp$compute_date_time (system_label.disposition_time.date_time,                                       
              system_label.purge_delay.time_increment, date_time, status);                                    
        IF NOT status.normal THEN                                                                             
          amp$return (local_file_name, ignore_status);                                                        
          RETURN;                                                                                             
        IFEND;                                                                                                
        jmp$convert_date_time_dif_to_us (current_date_time, date_time, current_microsecond_clock,             
              purge_delay_clock_time);                                                                        
      ELSE                                                                                                    
        purge_delay_clock_time := jmc$earliest_clock_time;                                                    
      IFEND;                                                                                                  
                                                                                                              
      IF system_label.disposition_time.specified AND (rerun_disposition = jmc$rr_rerun_file) THEN             
        IF latest_clock_time_to_process <= current_microsecond_clock THEN                                     
          osp$set_status_condition (jme$latest_run_time_expired, status);                                     
          amp$return (local_file_name, ignore_status);                                                        
          RETURN;                                                                                             
        ELSE                                                                                                  
          system_label.disposition_time.specified := FALSE;                                                   
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
{ Update the Known Qfile List                                                                                 
                                                                                                              
      qfp$change_qfile_attributes (system_label, earliest_clock_time_to_process, latest_clock_time_to_process,
            purge_delay_clock_time, current_microsecond_clock, rerun_disposition, delete_qfile, status);      
      IF NOT status.normal THEN                                                                               
        amp$return (local_file_name, ignore_status);                                                          
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      IF delete_qfile THEN                                                                                    
                                                                                                              
{ We only want control on block exit - not for interactive so only establish the                              
{ condition handler for block exit.                                                                           
                                                                                                              
        osp$establish_block_exit_hndlr (^condition_handler);                                                  
        pfp$begin_system_authority;                                                                           
        pfp$purge (path_p^, cycle_selector, password, status);                                                
        pfp$end_system_authority;                                                                             
        osp$disestablish_cond_handler;                                                                        
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
{ Write the result system label to the queue file                                                             
                                                                                                              
      qfp$write_qfile_system_label (local_file_name, { write_label } TRUE, system_label, attributes_size,     
            status);                                                                                          
      IF NOT status.normal THEN                                                                               
        amp$return (local_file_name, ignore_status);                                                          
        RETURN;                                                                                               
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Release the file in case somebody needs it                                                                  
                                                                                                              
    amp$return (local_file_name, status);                                                                     
  PROCEND jmp$change_qfile_attributes;                                                                        
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$close_qfile', EJECT ??                                                      
*copy jmh$close_qfile                                                                                         
                                                                                                              
{ DESIGN:                                                                                                     
{   This procedure will close a file with the specified file identifier.                                      
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$close_qfile                                                                     
    (    file_identifier: amt$file_identifier;                                                                
     VAR status: ost$status);                                                                                 
                                                                                                              
    status.normal := TRUE;                                                                                    
    fsp$close_file (file_identifier, status);                                                                 
                                                                                                              
  PROCEND jmp$close_qfile;                                                                                    
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$get_qfile_attributes', EJECT ??                                             
*copy jmh$get_qfile_attributes                                                                                
                                                                                                              
{ DESIGN:                                                                                                     
{ Set up block exit condition handler                                                                         
                                                                                                              
{ Initialize number_of_qfiles_found to 0                                                                      
{ FOR each attribute option specified DO                                                                      
{   IF attribute option IN specified_keys THEN                                                                
{     Return abnormal status jme$duplicate_attribute_key                                                      
{   IFEND                                                                                                     
{   Add to specified_keys                                                                                     
{   Validate as necessary                                                                                     
{ FOREND                                                                                                      
{ FOR each attribute results key specified DO                                                                 
{   IF caller is not asking for valid fields THEN                                                             
{     Return abnormal status jme$invalid_parameter                                                            
{   IFEND                                                                                                     
{ FOREND                                                                                                      
{ Call jmp$get_qfile_status                                                                                   
{ IF no files found THEN                                                                                      
{   RETURN abnormal status jme$no_qfiles_were_found                                                           
{ IFEND                                                                                                       
{ IF  work_area too small THEN                                                                                
{   RETURN abnormal status jme$work_area_too_small                                                            
{ IFEND                                                                                                       
{ FOR each file whose status was returned DO                                                                  
{   IF we can't get all the attributes from jmp$get_qfile_status THEN                                         
{     Attach the file                                                                                         
{     Read the system label                                                                                   
{     Detach the file                                                                                         
{   IFEND                                                                                                     
{   Increment number_of_qfiles_found                                                                          
{   FOR each result_key DO                                                                                    
{     Get the attribute from the system label or status results                                               
{     and put it in attribute_results                                                                         
{   FOREND                                                                                                    
{ FOREND                                                                                                      
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$get_qfile_attributes                                                            
    (    attribute_options_p: ^jmt$qfile_attribute_options;                                                   
         attribute_results_keys_p: ^jmt$results_keys;                                                         
     VAR attribute_work_area_p: ^jmt$work_area;                                                               
     VAR attribute_results_p: ^jmt$qfile_attribute_results;                                                   
     VAR number_of_qfiles_found: jmt$qfile_status_count;                                                      
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      appl_attribute_temp_p: ^SEQ ( * ),                                                                      
      appl_attribute_work_area_p: ^jmt$work_area,                                                             
      attribute_choices: qfile_appl_attribute_choices,                                                        
      current_date_time: ost$date_time,                                                                       
      cycle_selector: pft$cycle_selector,                                                                     
      date_time: ost$date_time,                                                                               
      get_application_attributes: boolean,                                                                    
      good_name: jmt$name,                                                                                    
      ignore_status: ost$status,                                                                              
      local_file_name: amt$local_file_name,                                                                   
      name_index: integer,                                                                                    
      need_to_attach_file: boolean,                                                                           
      number_of_attribute_result_keys: integer,                                                               
      number_of_qfiles_statused: jmt$qfile_count_range,                                                       
      option_index: integer,                                                                                  
      potential_name: jmt$name,                                                                               
      qfile_index: integer,                                                                                   
      qfile_status_options_p: ^jmt$qfile_status_options,                                                      
      qfile_status_results_keys_p: ^jmt$results_keys,                                                         
      qfile_status_results_p: ^jmt$qfile_status_results,                                                      
      qfile_status_work_area: amt$segment_pointer,                                                            
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      result_index: integer,                                                                                  
      scl_name: ost$name,                                                                                     
      share_selections: pft$share_selections,                                                                 
      specified_keys: jmt$attribute_keys_set,                                                                 
      system_authority_in_effect: boolean,                                                                    
      system_label: jmt$qfile_system_label,                                                                   
      usage_selections: pft$usage_selections,                                                                 
      valid_name: boolean;                                                                                    
                                                                                                              
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      mmp$delete_scratch_segment (qfile_status_work_area, status);                                            
      IF system_authority_in_effect THEN                                                                      
        pfp$end_system_authority;                                                                             
        system_authority_in_effect := FALSE;                                                                  
        #SPOIL (system_authority_in_effect);                                                                  
      IFEND;                                                                                                  
      IF status.normal THEN                                                                                   
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);      
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
    ignore_status.normal := TRUE;                                                                             
    system_authority_in_effect := FALSE;                                                                      
    #SPOIL (system_authority_in_effect);                                                                      
    number_of_qfiles_found := 0;                                                                              
    get_application_attributes := FALSE;                                                                      
    need_to_attach_file := FALSE;                                                                             
                                                                                                              
    IF attribute_options_p = NIL THEN                                                                         
      qfile_status_options_p := NIL;                                                                          
    ELSE                                                                                                      
      specified_keys := $jmt$attribute_keys_set [];                                                           
                                                                                                              
      PUSH qfile_status_options_p: [1 .. UPPERBOUND (attribute_options_p^)];                                  
                                                                                                              
{ Verify status option fields for validity                                                                    
                                                                                                              
    /validate_attribute_options/                                                                              
      FOR option_index := 1 TO UPPERBOUND (attribute_options_p^) DO                                           
        IF attribute_options_p^ [option_index].key IN specified_keys THEN                                     
          jmp$get_attribute_name (attribute_options_p^ [option_index].key, scl_name);                         
          osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_attribute_key, scl_name, status);     
          osp$append_status_parameter (osc$status_parameter_delimiter, 'QFILE_ATTRIBUTE_OPTIONS', status);    
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$get_qfile_attributes, status);     
          EXIT /validate_attribute_options/;                                                                  
        IFEND;                                                                                                
        qfile_status_options_p^ [option_index].key := attribute_options_p^ [option_index].key;                
        IF qfile_status_options_p^ [option_index].key <> jmc$null_attribute THEN                              
          specified_keys := specified_keys + $jmt$attribute_keys_set [attribute_options_p^ [option_index].    
                key];                                                                                         
        IFEND;                                                                                                
                                                                                                              
        CASE attribute_options_p^ [option_index].key OF                                                       
        = jmc$application_name =                                                                              
          clp$validate_name (attribute_options_p^ [option_index].application_name, scl_name, valid_name);     
          IF NOT valid_name THEN                                                                              
            osp$set_status_abnormal ('CL', cle$improper_name,                                                 
                  attribute_options_p^ [option_index].application_name, status);                              
            EXIT /validate_attribute_options/;                                                                
          IFEND;                                                                                              
          qfile_status_options_p^ [option_index].application_name := scl_name;                                
                                                                                                              
        = jmc$null_attribute =                                                                                
          ;                                                                                                   
        = jmc$qfile_state_set =                                                                               
          IF attribute_options_p^ [option_index].qfile_state_set = $jmt$qfile_state_set [] THEN               
            osp$set_status_condition (jme$qfile_state_is_null, status);                                       
            EXIT /validate_attribute_options/;                                                                
          IFEND;                                                                                              
          qfile_status_options_p^ [option_index].qfile_state_set :=                                           
                attribute_options_p^ [option_index].qfile_state_set;                                          
                                                                                                              
        = jmc$system_supplied_name_list =                                                                     
          IF attribute_options_p^ [option_index].system_supplied_name_list <> NIL THEN                        
            PUSH qfile_status_options_p^ [option_index].system_supplied_name_list:                            
                  [1 .. UPPERBOUND (attribute_options_p^ [option_index].system_supplied_name_list^)];         
            qfile_status_options_p^ [option_index].system_supplied_name_list^ :=                              
                  attribute_options_p^ [option_index].system_supplied_name_list^;                             
                                                                                                              
            potential_name.kind := jmc$system_supplied_name;                                                  
            FOR name_index := 1 TO UPPERBOUND (qfile_status_options_p^ [option_index].                        
                  system_supplied_name_list^) DO                                                              
              potential_name.system_supplied_name := qfile_status_options_p^ [option_index].                  
                    system_supplied_name_list^ [name_index];                                                  
              jmp$validate_name (potential_name, good_name, status);                                          
              IF NOT status.normal THEN                                                                       
                EXIT /validate_attribute_options/;                                                            
              IFEND;                                                                                          
                                                                                                              
              qfile_status_options_p^ [option_index].system_supplied_name_list^ [name_index] :=               
                    good_name.system_supplied_name;                                                           
            FOREND;                                                                                           
          IFEND;                                                                                              
                                                                                                              
        ELSE                                                                                                  
          jmp$get_attribute_name (attribute_options_p^ [option_index].key, scl_name);                         
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'ATTRIBUTE_OPTIONS_P', status);        
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$get_qfile_attributes, status);     
          EXIT /validate_attribute_options/;                                                                  
        CASEND;                                                                                               
      FOREND /validate_attribute_options/;                                                                    
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Verify that result is only asking for valid fields                                                          
                                                                                                              
    IF attribute_results_keys_p = NIL THEN                                                                    
      qfile_status_results_keys_p := NIL;                                                                     
      number_of_attribute_result_keys := 0;                                                                   
    ELSE                                                                                                      
      number_of_attribute_result_keys := UPPERBOUND (attribute_results_keys_p^);                              
      PUSH qfile_status_results_keys_p: [1 .. (number_of_attribute_result_keys + 1)];                         
      FOR result_index := 1 TO (number_of_attribute_result_keys) DO                                           
        qfile_status_results_keys_p^ [result_index] := attribute_results_keys_p^ [result_index];              
      FOREND;                                                                                                 
      qfile_status_results_keys_p^ [number_of_attribute_result_keys + 1] := jmc$system_file_name;             
                                                                                                              
      FOR result_index := 1 TO number_of_attribute_result_keys DO                                             
        IF NOT (attribute_results_keys_p^ [result_index] IN                                                   
              $jmt$attribute_keys_set [jmc$application_attributes_1, jmc$application_attributes_2,            
              jmc$application_attributes_3, jmc$application_attributes_4, jmc$application_attributes_5,       
              jmc$application_attributes_6, jmc$application_attributes_7, jmc$application_attributes_8,       
              jmc$application_attributes_9, jmc$application_attributes_10, jmc$application_name,              
              jmc$data_mode, jmc$deferred_by_application, jmc$destination, jmc$earliest_run_time,             
              jmc$latest_run_time, jmc$null_attribute, jmc$purge_delay, jmc$qfile_state,                      
              jmc$remote_host_directive, jmc$system_file_name]) THEN                                          
                                                                                                              
          jmp$get_attribute_name (attribute_results_keys_p^ [result_index], scl_name);                        
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'ATTRIBUTE_RESULTS_KEYS_P', status);   
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$get_qfile_attributes, status);     
          RETURN;                                                                                             
        IFEND;                                                                                                
        CASE attribute_results_keys_p^ [result_index] OF                                                      
        = jmc$application_attributes_1, jmc$application_attributes_2, jmc$application_attributes_3,           
              jmc$application_attributes_4, jmc$application_attributes_5, jmc$application_attributes_6,       
              jmc$application_attributes_7, jmc$application_attributes_8, jmc$application_attributes_9,       
              jmc$application_attributes_10 =                                                                 
          get_application_attributes := TRUE;                                                                 
          need_to_attach_file := TRUE;                                                                        
          qfile_status_results_keys_p^ [result_index] := jmc$null_attribute;                                  
                                                                                                              
        = jmc$data_mode, jmc$deferred_by_application, jmc$destination, jmc$earliest_run_time,                 
              jmc$latest_run_time, jmc$purge_delay, jmc$remote_host_directive =                               
          need_to_attach_file := TRUE;                                                                        
          qfile_status_results_keys_p^ [result_index] := jmc$null_attribute;                                  
                                                                                                              
        = jmc$application_name, jmc$qfile_state, jmc$system_file_name =                                       
                                                                                                              
{ These attributes can be obtained from jmp$get_qfile_status.                                                 
                                                                                                              
          ;                                                                                                   
                                                                                                              
        = jmc$null_attribute =                                                                                
          ;                                                                                                   
        ELSE                                                                                                  
          ;                                                                                                   
        CASEND;                                                                                               
      FOREND; { result index                                                                                  
    IFEND;                                                                                                    
                                                                                                              
  /get_attributes/                                                                                            
    BEGIN                                                                                                     
      osp$establish_block_exit_hndlr (^handle_block_exit);                                                    
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, qfile_status_work_area, status);   
      IF NOT status.normal THEN                                                                               
        EXIT /get_attributes/;                                                                                
      IFEND;                                                                                                  
      RESET qfile_status_work_area.sequence_pointer;                                                          
                                                                                                              
      jmp$get_qfile_status (qfile_status_options_p, qfile_status_results_keys_p,                              
            qfile_status_work_area.sequence_pointer, qfile_status_results_p, number_of_qfiles_found, status); 
      IF NOT status.normal THEN                                                                               
        EXIT /get_attributes/;                                                                                
      IFEND;                                                                                                  
                                                                                                              
      IF attribute_results_keys_p <> NIL THEN                                                                 
        NEXT attribute_results_p: [1 .. number_of_qfiles_found] IN attribute_work_area_p;                     
        IF attribute_results_p = NIL THEN                                                                     
          osp$set_status_condition (jme$work_area_too_small, status);                                         
          EXIT /get_attributes/;                                                                              
        IFEND;                                                                                                
        number_of_qfiles_statused := number_of_qfiles_found;                                                  
        number_of_qfiles_found := 0;                                                                          
                                                                                                              
        PUSH appl_attribute_work_area_p: [[REP jmc$max_qfile_appl_attr_size OF cell]];                        
                                                                                                              
      /attach_all_queue_files/                                                                                
        FOR qfile_index := 1 TO number_of_qfiles_statused DO                                                  
          NEXT attribute_results_p^ [qfile_index]: [1 .. number_of_attribute_result_keys] IN                  
                attribute_work_area_p;                                                                        
          IF attribute_results_p^ [qfile_index] = NIL THEN                                                    
            osp$set_status_condition (jme$work_area_too_small, status);                                       
            EXIT /get_attributes/;                                                                            
          IFEND;                                                                                              
                                                                                                              
          IF need_to_attach_file THEN                                                                         
                                                                                                              
{ Attach the file so we can read the system label and get the attributes                                      
                                                                                                              
            pmp$get_unique_name (local_file_name, { ignore } status);                                         
                                                                                                              
            determine_file_path (qfile_status_results_p^ [qfile_index]^ [number_of_attribute_result_keys +    
                  1].system_file_name, path_p);                                                               
            cycle_selector.cycle_option := pfc$specific_cycle;                                                
            cycle_selector.cycle_number := 1;                                                                 
            password := osc$null_name;                                                                        
            usage_selections := $pft$usage_selections [pfc$read];                                             
            share_selections := $pft$share_selections [pfc$read, pfc$modify];                                 
                                                                                                              
            #SPOIL (system_authority_in_effect);                                                              
            system_authority_in_effect := TRUE;                                                               
            #SPOIL (system_authority_in_effect);                                                              
            pfp$begin_system_authority;                                                                       
            pfp$attach (local_file_name, path_p^, cycle_selector, password, usage_selections,                 
                  share_selections, pfc$wait, status);                                                        
            pfp$end_system_authority;                                                                         
            #SPOIL (system_authority_in_effect);                                                              
            system_authority_in_effect := FALSE;                                                              
            #SPOIL (system_authority_in_effect);                                                              
            IF NOT status.normal THEN                                                                         
              status.normal := TRUE;                                                                          
              CYCLE /attach_all_queue_files/;                                                                 
            IFEND;                                                                                            
                                                                                                              
{ Read the queue file's system label                                                                          
                                                                                                              
            qfp$read_qfile_system_label (local_file_name, system_label, status);                              
            IF NOT status.normal THEN                                                                         
              amp$return (local_file_name, ignore_status);                                                    
              EXIT /get_attributes/;                                                                          
            IFEND;                                                                                            
                                                                                                              
{ Release the file in case somebody needs it for write access                                                 
                                                                                                              
            amp$return (local_file_name, status);                                                             
                                                                                                              
{ Get the application attributes from the system label, if necessary.                                         
                                                                                                              
            IF get_application_attributes THEN                                                                
              unpack_application_attributes (^system_label, ^attribute_choices, appl_attribute_work_area_p,   
                    status);                                                                                  
              IF NOT status.normal THEN                                                                       
                EXIT /get_attributes/;                                                                        
              IFEND;                                                                                          
            IFEND;                                                                                            
          IFEND;                                                                                              
                                                                                                              
          number_of_qfiles_found := number_of_qfiles_found + 1;                                               
                                                                                                              
          FOR result_index := 1 TO number_of_attribute_result_keys DO                                         
            attribute_results_p^ [number_of_qfiles_found]^ [result_index].                                    
                  key := attribute_results_keys_p^ [result_index];                                            
            CASE attribute_results_keys_p^ [result_index] OF                                                  
            = jmc$application_attributes_1, jmc$application_attributes_2, jmc$application_attributes_3,       
                  jmc$application_attributes_4, jmc$application_attributes_5, jmc$application_attributes_6,   
                  jmc$application_attributes_7, jmc$application_attributes_8, jmc$application_attributes_9,   
                  jmc$application_attributes_10 =                                                             
              IF (attribute_choices [attribute_results_keys_p^ [result_index]].application_attributes.size >  
                    0) THEN                                                                                   
                NEXT appl_attribute_temp_p: [[REP attribute_choices                                           
                      [attribute_results_keys_p^ [result_index]].application_attributes.size OF cell]] IN     
                      attribute_work_area_p;                                                                  
                IF (appl_attribute_temp_p = NIL) THEN                                                         
                  osp$set_status_condition (jme$work_area_too_small, status);                                 
                  EXIT /get_attributes/;                                                                      
                IFEND;                                                                                        
                attribute_results_p^ [number_of_qfiles_found]^ [result_index].application_attributes.         
                      attributes_p := appl_attribute_temp_p;                                                  
                attribute_results_p^ [number_of_qfiles_found]^ [result_index].application_attributes.size :=  
                      attribute_choices [attribute_results_keys_p^ [result_index]].application_attributes.    
                      size;                                                                                   
                i#move (attribute_choices [attribute_results_keys_p^ [result_index]].application_attributes.  
                      attributes_p, attribute_results_p^ [number_of_qfiles_found]^ [result_index].            
                      application_attributes.attributes_p, attribute_choices                                  
                      [attribute_results_keys_p^ [result_index]].application_attributes.size);                
                                                                                                              
              ELSE                                                                                            
                attribute_results_p^ [number_of_qfiles_found]^ [result_index].application_attributes.size :=  
                      0;                                                                                      
                attribute_results_p^ [number_of_qfiles_found]^ [result_index].application_attributes.         
                      attributes_p := NIL;                                                                    
              IFEND;                                                                                          
                                                                                                              
            = jmc$application_name =                                                                          
              attribute_results_p^ [number_of_qfiles_found]^ [result_index].application_name :=               
                    qfile_status_results_p^ [qfile_index]^ [result_index].application_name;                   
                                                                                                              
            = jmc$data_mode =                                                                                 
              attribute_results_p^ [number_of_qfiles_found]^ [result_index].data_mode :=                      
                    system_label.data_mode;                                                                   
                                                                                                              
            = jmc$deferred_by_application =                                                                   
              attribute_results_p^ [number_of_qfiles_found]^ [result_index].deferred_by_application :=        
                    system_label.deferred_by_application;                                                     
                                                                                                              
            = jmc$destination =                                                                               
              attribute_results_p^ [number_of_qfiles_found]^ [result_index].destination :=                    
                    system_label.destination;                                                                 
                                                                                                              
            = jmc$earliest_run_time =                                                                         
              attribute_results_p^ [number_of_qfiles_found]^ [result_index].earliest_run_time :=              
                    system_label.earliest_run_time;                                                           
                                                                                                              
            = jmc$latest_run_time =                                                                           
              attribute_results_p^ [number_of_qfiles_found]^ [result_index].latest_run_time :=                
                    system_label.latest_run_time;                                                             
                                                                                                              
            = jmc$null_attribute =                                                                            
              ;                                                                                               
                                                                                                              
            = jmc$purge_delay =                                                                               
              NEXT attribute_results_p^ [number_of_qfiles_found]^ [result_index].purge_delay IN               
                    attribute_work_area_p;                                                                    
              IF attribute_results_p^ [number_of_qfiles_found]^ [result_index].purge_delay = NIL THEN         
                osp$set_status_condition (jme$work_area_too_small, status);                                   
                EXIT /get_attributes/;                                                                        
              IFEND;                                                                                          
              IF system_label.disposition_time.specified THEN                                                 
                pmp$compute_date_time (system_label.disposition_time.date_time,                               
                      system_label.purge_delay.time_increment, date_time, ignore_status);                     
                pmp$get_compact_date_time (current_date_time, ignore_status);                                 
                pmp$compute_date_time_increment (current_date_time, date_time,                                
                      attribute_results_p^ [number_of_qfiles_found]^ [result_index].purge_delay^.             
                      time_increment, ignore_status);                                                         
                attribute_results_p^ [number_of_qfiles_found]^ [result_index].purge_delay^.specified := TRUE; 
              ELSE                                                                                            
                attribute_results_p^ [number_of_qfiles_found]^ [result_index].purge_delay^ :=                 
                      system_label.purge_delay;                                                               
              IFEND;                                                                                          
                                                                                                              
            = jmc$qfile_state =                                                                               
              attribute_results_p^ [number_of_qfiles_found]^ [result_index].qfile_state :=                    
                    qfile_status_results_p^ [qfile_index]^ [result_index].qfile_state;                        
                                                                                                              
            = jmc$remote_host_directive =                                                                     
              NEXT attribute_results_p^ [number_of_qfiles_found]^ [result_index].remote_host_directive IN     
                    attribute_work_area_p;                                                                    
              IF attribute_results_p^ [number_of_qfiles_found]^ [result_index].remote_host_directive =        
                    NIL THEN                                                                                  
                osp$set_status_condition (jme$work_area_too_small, status);                                   
                EXIT /get_attributes/;                                                                        
              IFEND;                                                                                          
              attribute_results_p^ [number_of_qfiles_found]^ [result_index].remote_host_directive^ :=         
                    system_label.remote_host_directive;                                                       
                                                                                                              
            = jmc$system_file_name =                                                                          
              attribute_results_p^ [number_of_qfiles_found]^ [result_index].system_file_name :=               
                    qfile_status_results_p^ [qfile_index]^ [result_index].system_file_name;                   
                                                                                                              
            ELSE                                                                                              
              ;                                                                                               
            CASEND;                                                                                           
          FOREND;                                                                                             
        FOREND /attach_all_queue_files/;                                                                      
      IFEND;                                                                                                  
    END /get_attributes/;                                                                                     
    mmp$delete_scratch_segment (qfile_status_work_area, ignore_status);                                       
    osp$disestablish_cond_handler;                                                                            
  PROCEND jmp$get_qfile_attributes;                                                                           
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$get_qfile_status', EJECT ??                                                 
*copy jmh$get_qfile_status                                                                                    
                                                                                                              
{ DESIGN:                                                                                                     
{ Initialize number_of_qfiles_found to 0                                                                      
{ IF some status options were specified THEN                                                                  
{   FOR each status option DO                                                                                 
{     IF status option IN specified keys THEN                                                                 
{       Return abnormal status jme$duplicate_attribute_key                                                    
{     ELSE                                                                                                    
{       validate the status option                                                                            
{       add it to specified keys                                                                              
{     IFEND                                                                                                   
{   FOREND                                                                                                    
{ IFEND                                                                                                       
{ IF some status results keys were specified THEN                                                             
{   FOR each status results key DO                                                                            
{     verify that user may see the status result                                                              
{   FOREND                                                                                                    
{ IFEND                                                                                                       
{ Call qfp$get_qfile_status to get the information from the KQL                                               
{ Unpack information into caller's work area.                                                                 
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$get_qfile_status                                                                
    (    status_options_p: ^jmt$qfile_status_options;                                                         
         status_results_keys_p: ^jmt$results_keys;                                                            
     VAR status_work_area_p: ^jmt$work_area;                                                                  
     VAR status_results_p: ^jmt$qfile_status_results;                                                         
     VAR number_of_qfiles_found: jmt$qfile_status_count;                                                      
     VAR status: ost$status);                                                                                 
                                                                                                              
    CONST                                                                                                     
      bytes_that_can_be_pushed = 32767;                                                                       
                                                                                                              
    VAR                                                                                                       
      good_name: jmt$name,                                                                                    
      jm_work_area_p: ^jmt$work_area,                                                                         
      name_index: integer,                                                                                    
      name_value_p: ^ost$name,                                                                                
      option_index: integer,                                                                                  
      potential_name: jmt$name,                                                                               
      qfile_index: integer,                                                                                   
      qfile_state_p: ^jmt$qfile_state,                                                                        
      result_index: integer,                                                                                  
      scl_name: ost$name,                                                                                     
      specified_keys: jmt$attribute_keys_set,                                                                 
      system_file_name_p: ^jmt$system_supplied_name,                                                          
      valid_status_options_p: ^jmt$qfile_status_options,                                                      
      valid_name: boolean;                                                                                    
                                                                                                              
    status.normal := TRUE;                                                                                    
    number_of_qfiles_found := 0;                                                                              
    jm_work_area_p := NIL;                                                                                    
                                                                                                              
    IF status_work_area_p <> NIL THEN                                                                         
      IF (jmv$job_management_work_area_p = NIL) AND (#SIZE (status_work_area_p^) <=                           
            bytes_that_can_be_pushed) THEN                                                                    
        PUSH jm_work_area_p: [[REP #SIZE (status_work_area_p^) OF cell]];                                     
      ELSE                                                                                                    
        jmp$get_jm_work_area (jm_work_area_p, status);                                                        
        IF NOT status.normal THEN                                                                             
          RETURN;                                                                                             
        IFEND;                                                                                                
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    IF status_options_p = NIL THEN                                                                            
      valid_status_options_p := NIL;                                                                          
    ELSE                                                                                                      
      specified_keys := $jmt$attribute_keys_set [];                                                           
                                                                                                              
      PUSH valid_status_options_p: [1 .. UPPERBOUND (status_options_p^)];                                     
      valid_status_options_p^ := status_options_p^;                                                           
                                                                                                              
{ Verify status option fields for validity                                                                    
                                                                                                              
    /validate_status_options/                                                                                 
      FOR option_index := 1 TO UPPERBOUND (valid_status_options_p^) DO                                        
        IF valid_status_options_p^ [option_index].key IN specified_keys THEN                                  
          jmp$get_attribute_name (valid_status_options_p^ [option_index].key, scl_name);                      
          osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_attribute_key, scl_name, status);     
          osp$append_status_parameter (osc$status_parameter_delimiter, 'STATUS_OPTIONS_P', status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$get_qfile_status, status);         
          EXIT /validate_status_options/;                                                                     
        IFEND;                                                                                                
        IF valid_status_options_p^ [option_index].key <> jmc$null_attribute THEN                              
          specified_keys := specified_keys + $jmt$attribute_keys_set                                          
                [valid_status_options_p^ [option_index].key];                                                 
        IFEND;                                                                                                
                                                                                                              
        CASE valid_status_options_p^ [option_index].key OF                                                    
        = jmc$application_name =                                                                              
          clp$validate_name (valid_status_options_p^ [option_index].application_name, scl_name, valid_name);  
          IF NOT valid_name THEN                                                                              
            osp$set_status_abnormal ('CL', cle$improper_name,                                                 
                  valid_status_options_p^ [option_index].application_name, status);                           
            EXIT /validate_status_options/;                                                                   
          IFEND;                                                                                              
          valid_status_options_p^ [option_index].application_name := scl_name;                                
                                                                                                              
        = jmc$null_attribute =                                                                                
          ;                                                                                                   
                                                                                                              
        = jmc$qfile_state_set =                                                                               
          ;                                                                                                   
                                                                                                              
        = jmc$system_supplied_name_list =                                                                     
          IF status_options_p^ [option_index].system_supplied_name_list <> NIL THEN                           
            PUSH valid_status_options_p^ [option_index].system_supplied_name_list:                            
                  [1 .. UPPERBOUND (status_options_p^ [option_index].system_supplied_name_list^)];            
            valid_status_options_p^ [option_index].system_supplied_name_list^ :=                              
                  status_options_p^ [option_index].system_supplied_name_list^;                                
            potential_name.kind := jmc$system_supplied_name;                                                  
            FOR name_index := 1 TO UPPERBOUND (valid_status_options_p^ [option_index].                        
                  system_supplied_name_list^) DO                                                              
              potential_name.system_supplied_name := valid_status_options_p^ [option_index].                  
                    system_supplied_name_list^ [name_index];                                                  
              jmp$validate_name (potential_name, good_name, status);                                          
              IF NOT status.normal THEN                                                                       
                EXIT /validate_status_options/;                                                               
              IFEND;                                                                                          
                                                                                                              
              valid_status_options_p^ [option_index].system_supplied_name_list^ [name_index] :=               
                    good_name.system_supplied_name;                                                           
            FOREND;                                                                                           
          IFEND;                                                                                              
                                                                                                              
        ELSE                                                                                                  
          jmp$get_attribute_name (valid_status_options_p^ [option_index].key, scl_name);                      
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'STATUS_OPTIONS_P', status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$get_qfile_status, status);         
          EXIT /validate_status_options/;                                                                     
        CASEND;                                                                                               
      FOREND /validate_status_options/;                                                                       
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
    IFEND;                                                                                                    
                                                                                                              
{ Verify that result is only asking for valid fields                                                          
                                                                                                              
    IF status_results_keys_p <> NIL THEN                                                                      
      FOR result_index := 1 TO UPPERBOUND (status_results_keys_p^) DO                                         
        IF NOT (status_results_keys_p^ [result_index] IN $jmt$attribute_keys_set                              
              [jmc$application_name, jmc$null_attribute, jmc$qfile_state, jmc$system_file_name]) THEN         
                                                                                                              
          jmp$get_attribute_name (status_results_keys_p^ [result_index], scl_name);                           
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'STATUS_RESULTS_KEYS_P', status);      
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$get_qfile_status, status);         
          RETURN;                                                                                             
        IFEND;                                                                                                
      FOREND;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    qfp$get_qfile_status (valid_status_options_p, status_results_keys_p, jm_work_area_p, status_results_p,    
          number_of_qfiles_found);                                                                            
                                                                                                              
    IF number_of_qfiles_found = 0 THEN                                                                        
      osp$set_status_condition (jme$no_qfiles_were_found, status);                                            
    ELSEIF status_results_keys_p <> NIL THEN                                                                  
      RESET jm_work_area_p;                                                                                   
      NEXT status_results_p: [1 .. number_of_qfiles_found] IN status_work_area_p;                             
      IF status_results_p = NIL THEN                                                                          
        osp$set_status_condition (jme$work_area_too_small, status);                                           
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      FOR qfile_index := 1 TO number_of_qfiles_found DO                                                       
        NEXT status_results_p^ [qfile_index]: [1 .. UPPERBOUND (status_results_keys_p^)] IN                   
              status_work_area_p;                                                                             
        IF status_results_p^ [qfile_index] = NIL THEN                                                         
          osp$set_status_condition (jme$work_area_too_small, status);                                         
          RETURN;                                                                                             
        IFEND;                                                                                                
                                                                                                              
        FOR result_index := 1 TO UPPERBOUND (status_results_keys_p^) DO                                       
          status_results_p^ [qfile_index]^ [result_index].key := status_results_keys_p^ [result_index];       
          CASE status_results_keys_p^ [result_index] OF                                                       
          = jmc$application_name =                                                                            
            NEXT name_value_p IN jm_work_area_p;                                                              
            IF name_value_p = NIL THEN                                                                        
              osp$set_status_condition (jme$work_area_too_small, status);                                     
              RETURN;                                                                                         
            IFEND;                                                                                            
            status_results_p^ [qfile_index]^ [result_index].application_name := name_value_p^;                
                                                                                                              
          = jmc$null_attribute =                                                                              
            ;                                                                                                 
                                                                                                              
          = jmc$qfile_state =                                                                                 
            NEXT qfile_state_p IN jm_work_area_p;                                                             
            IF qfile_state_p = NIL THEN                                                                       
              osp$set_status_condition (jme$work_area_too_small, status);                                     
              RETURN;                                                                                         
            IFEND;                                                                                            
            status_results_p^ [qfile_index]^ [result_index].qfile_state := qfile_state_p^;                    
                                                                                                              
          = jmc$system_file_name =                                                                            
            NEXT system_file_name_p IN jm_work_area_p;                                                        
            IF system_file_name_p = NIL THEN                                                                  
              osp$set_status_condition (jme$work_area_too_small, status);                                     
              RETURN;                                                                                         
            IFEND;                                                                                            
            status_results_p^ [qfile_index]^ [result_index].system_file_name := system_file_name_p^;          
                                                                                                              
          ELSE                                                                                                
          CASEND;                                                                                             
        FOREND;                                                                                               
      FOREND;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
  PROCEND jmp$get_qfile_status;                                                                               
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$modified_qfile_exists', EJECT ??                                            
*copy jmh$modified_qfile_exists                                                                               
                                                                                                              
{ DESIGN:                                                                                                     
{ Find index of application_name in the KQL application table                                                 
{ IF (index is NOT unassigned) AND (KQL application table's state data                                        
{     has modified files for this index) AND (NOT system idling) THEN                                         
{   modified_qfile_exists := true                                                                             
{ IFEND                                                                                                       
                                                                                                              
  FUNCTION [XDCL, #GATE] jmp$modified_qfile_exists                                                            
    (    application_name: ost$name): boolean;                                                                
                                                                                                              
    VAR                                                                                                       
      application_index: jmt$qfile_application_index,                                                         
      qfile_exists: boolean;                                                                                  
                                                                                                              
    application_index := jmv$last_used_application_index;                                                     
    WHILE (jmv$known_qfile_list.application_table [application_index].application_name <>                     
          application_name) AND (application_index <> jmc$unassigned_qfile_index) DO                          
      application_index := application_index - 1;                                                             
    WHILEND;                                                                                                  
    qfile_exists := (application_index <> jmc$unassigned_qfile_index) AND                                     
          (jmv$known_qfile_list.application_table [application_index].                                        
          state_data [jmc$kql_application_modified].number_of_entries > 0);                                   
    jmp$modified_qfile_exists := qfile_exists AND (NOT syp$system_is_idling ());                              
                                                                                                              
  FUNCEND jmp$modified_qfile_exists;                                                                          
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$new_qfile_exists', EJECT ??                                                 
*copy jmh$new_qfile_exists                                                                                    
                                                                                                              
{ DESIGN:                                                                                                     
{ Find index of application_name in the KQL application table                                                 
{ IF (index is NOT unassigned) AND (KQL application table's state data                                        
{     has new files for this index) AND (NOT system idling) THEN                                              
{   new_qfile_exists := true                                                                                  
{ IFEND                                                                                                       
                                                                                                              
  FUNCTION [XDCL, #GATE] jmp$new_qfile_exists                                                                 
    (    application_name: ost$name): boolean;                                                                
                                                                                                              
    VAR                                                                                                       
      application_index: jmt$qfile_application_index,                                                         
      qfile_exists: boolean;                                                                                  
                                                                                                              
    application_index := jmv$last_used_application_index;                                                     
    WHILE (jmv$known_qfile_list.application_table [application_index].application_name <>                     
          application_name) AND (application_index <> jmc$unassigned_qfile_index) DO                          
      application_index := application_index - 1;                                                             
    WHILEND;                                                                                                  
    qfile_exists := (application_index <> jmc$unassigned_qfile_index) AND                                     
          (jmv$known_qfile_list.application_table [application_index].state_data [jmc$kql_application_new].   
          number_of_entries > 0);                                                                             
    jmp$new_qfile_exists := qfile_exists AND (NOT syp$system_is_idling ());                                   
                                                                                                              
  FUNCEND jmp$new_qfile_exists;                                                                               
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$open_files_for_copqf', EJECT ??                                             
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to open queue files at the correct ring for                              
{ jmp$copy_qfile.                                                                                             
                                                                                                              
{ DESIGN:                                                                                                     
                                                                                                              
{ IF the specified queue file does not exist  (verify through jmp$get_qfile_status) THEN                      
{   RETURN with abnormal status jme$name_not_found                                                            
{ IFEND                                                                                                       
{ Build the file path for the open request                                                                    
{ Establish block exit and interactive condition handler                                                      
{ Attach the file                                                                                             
{ Disestablish condition handler                                                                              
{ Set up options to open the queue file for read access.                                                      
{ Set up options to open the target file for write access and to create it (if it doesn't                     
{       exist) at max(caller ring, target ring)                                                               
{ Open the files and obtain the copy control information                                                      
{ Reopen the queue file for read access at the caller's ring                                                  
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$open_files_for_copqf                                                            
    (    system_file_name: jmt$system_supplied_name;                                                          
         target_file: fst$file_reference;                                                                     
         target_ring: ost$valid_ring;                                                                         
     VAR control_info: fst$copy_control_information;                                                          
     VAR qfile_fid: amt$file_identifier;                                                                      
     VAR qfile_lfn: amt$local_file_name;                                                                      
     VAR target_fid: amt$file_identifier;                                                                     
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      attribute_override_p: ^fst$file_cycle_attributes,                                                       
      caller_id: ost$caller_identifier,                                                                       
      cycle_selector: pft$cycle_selector,                                                                     
      ignore_status: ost$status,                                                                              
      number_of_qfiles_found: jmt$qfile_status_count,                                                         
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      qfile_attachment_options_p: ^fst$attachment_options,                                                    
      selected_ring: ost$valid_ring,                                                                          
      share_selections: pft$share_selections,                                                                 
      status_options_p: ^jmt$qfile_status_options,                                                            
      status_results_p: ^jmt$qfile_status_results,                                                            
      status_work_area_p: ^jmt$work_area,                                                                     
      target_attachment_options_p: ^fst$attachment_options,                                                   
      target_creation_attributes_p: ^fst$file_cycle_attributes,                                               
      usage_selections: pft$usage_selections;                                                                 
                                                                                                              
?? NEWTITLE := 'condition_handler', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit and interactive                                  
{   conditions that arise from the attempt to attach a file in the generic queue.                             
{   If the file is busy, the attach processor goes into long term wait without                                
{   establishing a condition handler for interactive conditions - so it does                                  
{   not exit.  When pfp$attach gets changed to work correctly, this handler                                   
{   will no longer need to handle interactive conditions.                                                     
                                                                                                              
    PROCEDURE condition_handler                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      CASE condition.selector OF                                                                              
      = pmc$block_exit_processing =                                                                           
        pfp$end_system_authority;                                                                             
        IF status.normal THEN                                                                                 
          osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);    
        IFEND;                                                                                                
                                                                                                              
      = ifc$interactive_condition =                                                                           
        IF condition.interactive_condition = ifc$pause_break THEN                                             
          ifp$invoke_pause_utility (handler_status);                                                          
        ELSE                                                                                                  
          osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);    
          pmp$continue_to_cause (pmc$execute_standard_procedure, ignore_status);                              
          EXIT jmp$open_files_for_copqf;                                                                      
        IFEND;                                                                                                
                                                                                                              
      ELSE                                                                                                    
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);                               
      CASEND;                                                                                                 
    PROCEND condition_handler;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
    qfile_fid := amv$nil_file_identifier;                                                                     
    target_fid := amv$nil_file_identifier;                                                                    
                                                                                                              
    pmp$get_unique_name (qfile_lfn, ignore_status);                                                           
                                                                                                              
    #CALLER_ID (caller_id);                                                                                   
                                                                                                              
{ IF the specified queue file does not exist  (verify through jmp$get_qfile_status) THEN                      
{   RETURN with abnormal status jme$name_not_found                                                            
{ IFEND                                                                                                       
                                                                                                              
    PUSH status_options_p: [1 .. 1];                                                                          
    status_options_p^ [1].key := jmc$system_supplied_name_list;                                               
    PUSH status_options_p^ [1].system_supplied_name_list: [1 .. 1];                                           
    status_options_p^ [1].system_supplied_name_list^ [1] := system_file_name;                                 
                                                                                                              
    PUSH status_work_area_p: [[REP #SIZE (jmt$qfile_status_results: [1 .. 1]) OF cell]];                      
    RESET status_work_area_p;                                                                                 
    jmp$get_qfile_status (status_options_p, { status_results_keys_p } NIL, status_work_area_p,                
          status_results_p, number_of_qfiles_found, status);                                                  
                                                                                                              
    IF NOT status.normal THEN                                                                                 
      IF status.condition = jme$no_qfiles_were_found THEN                                                     
        osp$set_status_abnormal ('JM', jme$name_not_found, system_file_name, status);                         
      IFEND;                                                                                                  
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Build the file path for the open request                                                                    
                                                                                                              
    determine_file_path (system_file_name, path_p);                                                           
    cycle_selector.cycle_option := pfc$specific_cycle;                                                        
    cycle_selector.cycle_number := 1;                                                                         
    password := osc$null_name;                                                                                
    usage_selections := $pft$usage_selections [pfc$read];                                                     
    share_selections := $pft$share_selections [pfc$read, pfc$modify];                                         
                                                                                                              
{ Establish block exit and interactive condition handler                                                      
{ Attach the file                                                                                             
{ Disestablish condition handler                                                                              
                                                                                                              
    osp$establish_condition_handler (^condition_handler, { block_exit } TRUE);                                
    pfp$begin_system_authority;                                                                               
    pfp$attach (qfile_lfn, path_p^, cycle_selector, password, usage_selections,                               
          share_selections, pfc$wait, status);                                                                
    pfp$end_system_authority;                                                                                 
    osp$disestablish_cond_handler;                                                                            
                                                                                                              
    IF NOT status.normal THEN                                                                                 
      amp$return (qfile_lfn, ignore_status);                                                                  
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Set up options to open the queue file for read access.                                                      
                                                                                                              
    PUSH qfile_attachment_options_p: [1 .. 2];                                                                
    qfile_attachment_options_p^ [1].selector := fsc$access_and_share_modes;                                   
    qfile_attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;                       
    qfile_attachment_options_p^ [1].access_modes.value := $fst$file_access_options [fsc$read];                
    qfile_attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;                         
    qfile_attachment_options_p^ [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$modify];     
    qfile_attachment_options_p^ [2].selector := fsc$open_share_modes;                                         
    qfile_attachment_options_p^ [2].open_share_modes := $fst$file_access_options [fsc$read, fsc$modify];      
                                                                                                              
{ Set up options to open the target file for write access and to create it (if it doesn't                     
{       exist) at max(caller ring, target ring)                                                               
                                                                                                              
    PUSH target_attachment_options_p: [1 .. 3];                                                               
    target_attachment_options_p^ [1].selector := fsc$access_and_share_modes;                                  
    target_attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;                      
    target_attachment_options_p^ [1].access_modes.value := $fst$file_access_options                           
          [fsc$append, fsc$modify, fsc$shorten];                                                              
    target_attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;                        
    target_attachment_options_p^ [1].share_modes.value := $fst$file_access_options [];                        
    target_attachment_options_p^ [2].selector := fsc$open_share_modes;                                        
    target_attachment_options_p^ [2].open_share_modes := -$fst$file_access_options [];                        
    target_attachment_options_p^ [3].selector := fsc$validation_ring;                                         
    IF caller_id.ring > target_ring THEN                                                                      
      selected_ring := caller_id.ring;                                                                        
    ELSE                                                                                                      
      selected_ring := target_ring;                                                                           
    IFEND;                                                                                                    
    target_attachment_options_p^ [3].validation_ring := selected_ring;                                        
                                                                                                              
    PUSH target_creation_attributes_p: [1 .. 1];                                                              
    target_creation_attributes_p^ [1].selector := fsc$ring_attributes;                                        
    target_creation_attributes_p^ [1].ring_attributes.r1 := selected_ring;                                    
    target_creation_attributes_p^ [1].ring_attributes.r2 := selected_ring;                                    
    target_creation_attributes_p^ [1].ring_attributes.r3 := selected_ring;                                    
                                                                                                              
{ Open the files and obtain the copy control information                                                      
                                                                                                              
    fsp$open_and_get_type_of_copy (qfile_lfn, target_file, qfile_attachment_options_p,                        
          target_attachment_options_p, { input_attribute_validation } NIL,                                    
          { output_attribute_validation } NIL, target_creation_attributes_p, qfile_fid, target_fid,           
          control_info, status);                                                                              
    IF NOT status.normal THEN                                                                                 
      IF (qfile_fid <> amv$nil_file_identifier) THEN                                                          
        fsp$close_file (qfile_fid, ignore_status);                                                            
        qfile_fid := amv$nil_file_identifier;                                                                 
        #SPOIL (qfile_fid);                                                                                   
      IFEND;                                                                                                  
                                                                                                              
      amp$return (qfile_lfn, ignore_status);                                                                  
                                                                                                              
      IF (target_fid <> amv$nil_file_identifier) THEN                                                         
        fsp$close_file (target_fid, ignore_status);                                                           
        target_fid := amv$nil_file_identifier;                                                                
        #SPOIL (target_fid);                                                                                  
      IFEND;                                                                                                  
                                                                                                              
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    fsp$close_file (qfile_fid, ignore_status);                                                                
    qfile_fid := amv$nil_file_identifier;                                                                     
    #SPOIL (qfile_fid);                                                                                       
                                                                                                              
{ Reopen the queue file for read access at the caller's ring                                                  
                                                                                                              
    PUSH attribute_override_p: [1 .. 1];                                                                      
    attribute_override_p^ [1].selector := fsc$ring_attributes;                                                
    attribute_override_p^ [1].ring_attributes.r1 := osc$tsrv_ring;                                            
    attribute_override_p^ [1].ring_attributes.r2 := selected_ring;                                            
    attribute_override_p^ [1].ring_attributes.r3 := selected_ring;                                            
                                                                                                              
    fsp$open_file (qfile_lfn, amc$record, qfile_attachment_options_p,                                         
          { default_creation_attributes } NIL, { mandated_creation_attributes } NIL,                          
          { attribute_validation } NIL, attribute_override_p, qfile_fid, status);                             
                                                                                                              
    IF NOT status.normal THEN                                                                                 
      amp$return (qfile_lfn, ignore_status);                                                                  
      IF (target_fid <> amv$nil_file_identifier) THEN                                                         
        fsp$close_file (target_fid, ignore_status);                                                           
        target_fid := amv$nil_file_identifier;                                                                
        #SPOIL (target_fid);                                                                                  
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
  PROCEND jmp$open_files_for_copqf;                                                                           
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$close_files_for_copqf', EJECT ??                                            
*copy jmh$close_files_for_copqf                                                                               
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$close_files_for_copqf                                                           
    (    qfile_fid: amt$file_identifier;                                                                      
         qfile_lfn: amt$local_file_name;                                                                      
         target_fid: amt$file_identifier;                                                                     
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      file_id_is_valid: boolean,                                                                              
      file_instance: ^bat$task_file_entry,                                                                    
      local_status: ost$status;                                                                               
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
{ Close the files and detach the output queue file.                                                           
                                                                                                              
    IF qfile_fid <> amv$nil_file_identifier THEN                                                              
      bap$validate_file_identifier (qfile_fid, file_instance, file_id_is_valid);                              
      IF file_id_is_valid THEN                                                                                
        fsp$close_file (qfile_fid, status);                                                                   
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    amp$return (qfile_lfn, local_status);                                                                     
    IF status.normal AND (NOT local_status.normal) THEN                                                       
      status := local_status;                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF target_fid <> amv$nil_file_identifier THEN                                                             
      bap$validate_file_identifier (target_fid, file_instance, file_id_is_valid);                             
      IF file_id_is_valid THEN                                                                                
        fsp$close_file (target_fid, local_status);                                                            
        IF status.normal AND (NOT local_status.normal) THEN                                                   
          status := local_status;                                                                             
        IFEND;                                                                                                
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
  PROCEND jmp$close_files_for_copqf;                                                                          
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL #GATE] jmp$open_qfile', EJECT ??                                                        
*copy jmh$open_qfile                                                                                          
                                                                                                              
{ DESIGN:                                                                                                     
{ Set up block exit condition handler                                                                         
                                                                                                              
{ IF caller is not validated to access the file THEN                                                          
{   RETURN abnormal status jme$qfile_appl_not_permitted                                                       
{ IFEND                                                                                                       
{ Build the file path for the open request                                                                    
{ Attach the file for read access and open the file with the rings of the caller                              
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$open_qfile                                                                      
    (    system_file_name: jmt$system_supplied_name;                                                          
         access_level: amt$access_level;                                                                      
         application_name: ost$name;                                                                          
         queue_file_password: jmt$queue_file_password;                                                        
     VAR file_identifier: amt$file_identifier;                                                                
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      attachment_options_p: ^fst$attachment_options,                                                          
      attribute_override_p: ^fst$file_cycle_attributes,                                                       
      caller_id: ost$caller_identifier,                                                                       
      file_path: fst$path,                                                                                    
      file_path_size: 0 .. fsc$max_path_size,                                                                 
      ignore_status: ost$status;                                                                              
                                                                                                              
?? NEWTITLE := '[INLINE] add_to_file_path', EJECT ??                                                          
                                                                                                              
    PROCEDURE [INLINE] add_to_file_path                                                                       
      (    path_string: string ( * <= osc$max_name_size));                                                    
                                                                                                              
      VAR                                                                                                     
        string_length: 1 .. osc$max_name_size;                                                                
                                                                                                              
      string_length := clp$trimmed_string_size (path_string);                                                 
      file_path (file_path_size + 1, string_length) := path_string;                                           
      file_path_size := file_path_size + string_length;                                                       
    PROCEND add_to_file_path;                                                                                 
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      pfp$end_system_authority;                                                                               
      IF status.normal THEN                                                                                   
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);      
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
    ignore_status.normal := TRUE;                                                                             
    #CALLER_ID (caller_id);                                                                                   
                                                                                                              
{ Validate that the caller deserves access to the file.                                                       
                                                                                                              
    qfp$validate_qfile_access (system_file_name, application_name, queue_file_password, status);              
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Build the file path for the open request.                                                                   
                                                                                                              
    file_path_size := 0;                                                                                      
    add_to_file_path (':');                                                                                   
    add_to_file_path (jmc$system_family);                                                                     
    add_to_file_path ('.');                                                                                   
    add_to_file_path (jmc$system_user);                                                                       
    add_to_file_path ('.');                                                                                   
    add_to_file_path (jmc$generic_queue_catalog);                                                             
    add_to_file_path ('.');                                                                                   
    add_to_file_path (system_file_name);                                                                      
                                                                                                              
{ Attach the file for read access and open the file with the rings of the caller                              
                                                                                                              
    PUSH attribute_override_p: [1 .. 1];                                                                      
    attribute_override_p^ [1].selector := fsc$ring_attributes;                                                
    attribute_override_p^ [1].ring_attributes.r1 := osc$tsrv_ring;                                            
    attribute_override_p^ [1].ring_attributes.r2 := caller_id.ring;                                           
    attribute_override_p^ [1].ring_attributes.r3 := caller_id.ring;                                           
                                                                                                              
    PUSH attachment_options_p: [1 .. 2];                                                                      
    attachment_options_p^ [1].selector := fsc$access_and_share_modes;                                         
    attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;                             
    attachment_options_p^ [1].access_modes.value := $fst$file_access_options [fsc$read];                      
    attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;                               
    attachment_options_p^ [1].share_modes.value := $fst$file_access_options [fsc$read];                       
    attachment_options_p^ [2].selector := fsc$open_share_modes;                                               
    attachment_options_p^ [2].open_share_modes := $fst$file_access_options [fsc$read];                        
                                                                                                              
    osp$establish_block_exit_hndlr (^handle_block_exit);                                                      
    pfp$begin_system_authority;                                                                               
    fsp$open_file (file_path (1, file_path_size), access_level, attachment_options_p, NIL, NIL, NIL,          
          attribute_override_p, file_identifier, status);                                                     
    pfp$end_system_authority;                                                                                 
    osp$disestablish_cond_handler;                                                                            
  PROCEND jmp$open_qfile;                                                                                     
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$purge_expired_queue_file', EJECT ??                                         
*copy jmh$purge_expired_queue_file                                                                            
                                                                                                              
{ DESIGN:                                                                                                     
{ Set up block exit condition handler                                                                         
                                                                                                              
{ Call qfp$purge_expired_queue_file to update the KQL and                                                     
{   update the time to purge the next expired file.                                                           
{ Purge it                                                                                                    
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$purge_expired_queue_file;                                                       
                                                                                                              
    VAR                                                                                                       
      cycle_selector: pft$cycle_selector,                                                                     
      ignore_status: ost$status,                                                                              
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      system_file_name: jmt$system_supplied_name;                                                             
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      pfp$end_system_authority;                                                                               
    PROCEND handle_block_exit;                                                                                
?? OLDTITLE ??                                                                                                
?? EJECT ??                                                                                                   
                                                                                                              
    qfp$purge_expired_queue_file (system_file_name);                                                          
    IF system_file_name <> jmc$blank_system_supplied_name THEN                                                
      determine_file_path (system_file_name, path_p);                                                         
                                                                                                              
      cycle_selector.cycle_option := pfc$specific_cycle;                                                      
      cycle_selector.cycle_number := 1;                                                                       
      password := osc$null_name;                                                                              
      osp$establish_block_exit_hndlr (^handle_block_exit);                                                    
      pfp$begin_system_authority;                                                                             
      pfp$purge (path_p^, cycle_selector, password, ignore_status);                                           
      pfp$end_system_authority;                                                                               
      osp$disestablish_cond_handler;                                                                          
    IFEND;                                                                                                    
                                                                                                              
  PROCEND jmp$purge_expired_queue_file;                                                                       
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$purge_processed_queue_file', EJECT ??                                       
*copy jmh$purge_processed_queue_file                                                                          
                                                                                                              
{ DESIGN:                                                                                                     
{ Set up block exit condition handler                                                                         
                                                                                                              
{ Call qfp$purge_processed_queue_file to update the KQL                                                       
{   and update the time to purge the next processed file.                                                     
{ Purge it                                                                                                    
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$purge_processed_queue_file;                                                     
                                                                                                              
    VAR                                                                                                       
      cycle_selector: pft$cycle_selector,                                                                     
      ignore_status: ost$status,                                                                              
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      system_file_name: jmt$system_supplied_name;                                                             
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      pfp$end_system_authority;                                                                               
    PROCEND handle_block_exit;                                                                                
?? OLDTITLE ??                                                                                                
?? EJECT ??                                                                                                   
                                                                                                              
    qfp$purge_processed_queue_file (system_file_name);                                                        
    IF system_file_name <> jmc$blank_system_supplied_name THEN                                                
      determine_file_path (system_file_name, path_p);                                                         
                                                                                                              
      cycle_selector.cycle_option := pfc$specific_cycle;                                                      
      cycle_selector.cycle_number := 1;                                                                       
      password := osc$null_name;                                                                              
      osp$establish_block_exit_hndlr (^handle_block_exit);                                                    
      pfp$begin_system_authority;                                                                             
      pfp$purge (path_p^, cycle_selector, password, ignore_status);                                           
      pfp$end_system_authority;                                                                               
      osp$disestablish_cond_handler;                                                                          
    IFEND;                                                                                                    
                                                                                                              
  PROCEND jmp$purge_processed_queue_file;                                                                     
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$rebuild_generic_queue', EJECT ??                                            
*copy jmh$rebuild_generic_queue                                                                               
                                                                                                              
{ DESIGN:                                                                                                     
{ Set up block exit handler                                                                                   
{                                                                                                             
{ Validate the system_file_name                                                                               
{ IF NOT valid THEN                                                                                           
{   Return abnormal status cle$improper_name                                                                  
{ IFEND                                                                                                       
{ Attach the file.                                                                                            
{ IF we can't read the system label,                                                                          
{   Purge the file                                                                                            
{ IFEND                                                                                                       
{ IF the file has been processed already (disposition_time.specified) THEN                                    
{   IF purge_delay was specified THEN                                                                         
{     Calculate the purge_delay.                                                                              
{     Desired algorithm:                                                                                      
{       disposition_time = disposition_time + down_time                                                       
{       purge_delay_clock_time = disposition_time + purge_delay - current time + microsecond clock            
{     Currently the down_time is unknown so a file may get purged                                             
{     due to the system being down when its purge delay expires.                                              
{   ELSE                                                                                                      
{     purge_delay := earliest clock time                                                                      
{   IFEND                                                                                                     
{ ELSE                                                                                                        
{   IF earliest_run_time was specified THEN                                                                   
{     Calculate earliest_run_time                                                                             
{   ELSE                                                                                                      
{     earliest_run_time := earliest clock time                                                                
{   IFEND                                                                                                     
{   IF latest_run_time was specified THEN                                                                     
{     Calculate latest_run_time                                                                               
{   ELSE                                                                                                      
{     latest_run_time := latest clock time                                                                    
{   IFEND                                                                                                     
{   purge_delay = earliest clock time                                                                         
{ IFEND                                                                                                       
{ Call qfp$rebuild_generic_queue to update the KQL                                                            
{   and update the time to purge the next processed file, the next expired file,                              
{   and ready the next deferred file.                                                                         
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$rebuild_generic_queue                                                           
    (    system_file_name: jmt$system_supplied_name;                                                          
     VAR status: ost$status);                                                                                 
                                                                                                              
                                                                                                              
    VAR                                                                                                       
      current_date_time: ost$date_time,                                                                       
      current_microsecond_clock: jmt$clock_time,                                                              
      cycle_selector: pft$cycle_selector,                                                                     
      date_time: ost$date_time,                                                                               
      earliest_clock_time_to_process: jmt$clock_time,                                                         
      ignore_status: ost$status,                                                                              
      latest_clock_time_to_process: jmt$clock_time,                                                           
      local_file_name: amt$local_file_name,                                                                   
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      purge_delay_clock_time: jmt$clock_time,                                                                 
      scl_name: ost$name,                                                                                     
      system_label: jmt$qfile_system_label,                                                                   
      system_supplied_name: jmt$system_supplied_name,                                                         
      usage_selections: pft$usage_selections,                                                                 
      valid_name: boolean;                                                                                    
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while the queue file is attached.                                                                   
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      amp$return (local_file_name, ignore_status);                                                            
    PROCEND handle_block_exit;                                                                                
?? OLDTITLE ??                                                                                                
?? EJECT ??                                                                                                   
    status.normal := TRUE;                                                                                    
    ignore_status.normal := TRUE;                                                                             
                                                                                                              
    clp$validate_name (system_file_name, scl_name, valid_name);                                               
    IF NOT valid_name THEN                                                                                    
      osp$set_status_abnormal ('CL', cle$improper_name, system_file_name, status);                            
      RETURN;                                                                                                 
    IFEND;                                                                                                    
    system_supplied_name := scl_name;                                                                         
                                                                                                              
    pmp$get_unique_name (local_file_name, status);                                                            
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    determine_file_path (system_supplied_name, path_p);                                                       
    cycle_selector.cycle_option := pfc$specific_cycle;                                                        
    cycle_selector.cycle_number := 1;                                                                         
    password := osc$null_name;                                                                                
    usage_selections := $pft$usage_selections [pfc$read];                                                     
                                                                                                              
    osp$establish_block_exit_hndlr (^handle_block_exit);                                                      
                                                                                                              
  /process_file/                                                                                              
    BEGIN                                                                                                     
      pfp$attach (local_file_name, path_p^, cycle_selector, password, usage_selections, usage_selections,     
            pfc$wait, status);                                                                                
      IF NOT status.normal THEN                                                                               
        pfp$purge (path_p^, cycle_selector, password, ignore_status);                                         
        EXIT /process_file/;                                                                                  
      IFEND;                                                                                                  
                                                                                                              
{ If we can't read the system label - don't recover it                                                        
{ In fact, delete the queue file                                                                              
                                                                                                              
      qfp$read_qfile_system_label (local_file_name, system_label, status);                                    
      IF NOT status.normal THEN                                                                               
        amp$return (local_file_name, ignore_status);                                                          
        pfp$purge (path_p^, cycle_selector, password, ignore_status);                                         
        EXIT /process_file/;                                                                                  
      IFEND;                                                                                                  
                                                                                                              
{ Calculate the earliest_process_time, latest_process_time and purge_delay if necessary.                      
                                                                                                              
      pmp$get_microsecond_clock (current_microsecond_clock, ignore_status);                                   
      pmp$get_compact_date_time (current_date_time, ignore_status);                                           
                                                                                                              
                                                                                                              
{ If the file has been processed (i.e. disposition time is available) and a purge delay has been supplied then
{ calculate the free-running clock value at which the file can be purged.                                     
{ The desired algorithm for a file that has been processed is:                                                
{                                                                                                             
{   disposition_time = disposition_time + down_time;                                                          
{   purge_delay_clock_time = disposition_time + purge_delay - current_time + microsecond_clock;               
{                                                                                                             
{ Currently the quantity (DOWN_TIME) is unknown so a file may get purged                                      
{ due to the system being down when its purge delay expires.                                                  
                                                                                                              
      IF system_label.disposition_time.specified THEN                                                         
        earliest_clock_time_to_process := jmc$earliest_clock_time;                                            
        latest_clock_time_to_process := jmc$latest_clock_time;                                                
        IF system_label.purge_delay.specified THEN                                                            
          pmp$compute_date_time (system_label.disposition_time.date_time,                                     
                system_label.purge_delay.time_increment, date_time, status);                                  
          IF NOT status.normal THEN                                                                           
            amp$return (local_file_name, ignore_status);                                                      
            EXIT /process_file/;                                                                              
          IFEND;                                                                                              
          jmp$convert_date_time_dif_to_us (current_date_time, date_time, current_microsecond_clock,           
                purge_delay_clock_time);                                                                      
        ELSE                                                                                                  
          purge_delay_clock_time := jmc$earliest_clock_time;                                                  
        IFEND;                                                                                                
      ELSE                                                                                                    
        IF system_label.earliest_run_time.specified THEN                                                      
          jmp$convert_date_time_dif_to_us (current_date_time, system_label.earliest_run_time.date_time,       
                current_microsecond_clock, earliest_clock_time_to_process);                                   
        ELSE                                                                                                  
          earliest_clock_time_to_process := jmc$earliest_clock_time;                                          
        IFEND;                                                                                                
                                                                                                              
        IF system_label.latest_run_time.specified THEN                                                        
          jmp$convert_date_time_dif_to_us (current_date_time, system_label.latest_run_time.date_time,         
                current_microsecond_clock, latest_clock_time_to_process);                                     
        ELSE                                                                                                  
          latest_clock_time_to_process := jmc$latest_clock_time;                                              
        IFEND;                                                                                                
        purge_delay_clock_time := jmc$earliest_clock_time;                                                    
      IFEND;                                                                                                  
                                                                                                              
      qfp$rebuild_generic_queue (system_label, earliest_clock_time_to_process, latest_clock_time_to_process,  
            purge_delay_clock_time, current_microsecond_clock, status);                                       
      IF NOT status.normal THEN                                                                               
        amp$return (local_file_name, ignore_status);                                                          
      ELSE                                                                                                    
        amp$return (local_file_name, status);                                                                 
      IFEND;                                                                                                  
    END /process_file/;                                                                                       
    osp$disestablish_cond_handler;                                                                            
                                                                                                              
  PROCEND jmp$rebuild_generic_queue;                                                                          
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$register_qfile_application', EJECT ??                                       
*copy jmh$register_qfile_application                                                                          
                                                                                                              
{ DESIGN:                                                                                                     
{ Validate application name                                                                                   
{ IF NOT valid name THEN                                                                                      
{   RETURN abnormal status cle$improper_name                                                                  
{ IFEND                                                                                                       
{ Get unique name for password                                                                                
{ Call qfp$register_qfile_application to update information in KQL                                            
{ IF status.normal THEN                                                                                       
{   task_has_registered_application := true                                                                   
{ IFEND                                                                                                       
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$register_qfile_application                                                      
    (    application_name: ost$name;                                                                          
         registration_options_p: ^jmt$qfile_registration_options;                                             
     VAR queue_file_password: jmt$queue_file_password;                                                        
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      valid_name: boolean,                                                                                    
      valid_application_name: ost$name;                                                                       
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    clp$validate_name (application_name, valid_application_name, valid_name);                                 
    IF NOT valid_name THEN                                                                                    
      osp$set_status_abnormal ('CL', cle$improper_name, application_name, status);                            
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    pmp$get_unique_name (queue_file_password, status);                                                        
    IF status.normal THEN                                                                                     
      qfp$register_qfile_application (valid_application_name, registration_options_p, queue_file_password,    
            status);                                                                                          
      IF status.normal THEN                                                                                   
        task_has_registered_application := TRUE;                                                              
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
  PROCEND jmp$register_qfile_application;                                                                     
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$release_generic_queue_files', EJECT ??                                      
*copy jmh$release_generic_queue_files                                                                         
                                                                                                              
{ DESIGN:                                                                                                     
{ Set up block exit condition handler                                                                         
                                                                                                              
{ IF NOT task_has_registered_application THEN                                                                 
{   RETURN                                                                                                    
{ IFEND                                                                                                       
{ Call qfp$release_generic_queue_files to get the list of files to be deleted                                 
{ FOR each file to be deleted DO                                                                              
{   purge it                                                                                                  
{ FOREND                                                                                                      
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$release_generic_queue_files;                                                    
                                                                                                              
    VAR                                                                                                       
      release_file_list: ^jmt$system_supplied_name_list,                                                      
      release_file_count: jmt$qfile_count_range,                                                              
      release_file_index: jmt$qfile_count_range,                                                              
      ignore_status: ost$status,                                                                              
      path_p: ^pft$path,                                                                                      
      cycle_selector: pft$cycle_selector,                                                                     
      password: pft$password;                                                                                 
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        local_status: ost$status;                                                                             
                                                                                                              
      pfp$end_system_authority;                                                                               
      IF ignore_status.normal THEN                                                                            
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, ignore_status, local_status);
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    IF NOT task_has_registered_application THEN                                                               
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    ignore_status.normal := TRUE;                                                                             
                                                                                                              
    PUSH release_file_list: [1 .. jmc$maximum_qfile_count];                                                   
    release_file_count := 0;                                                                                  
                                                                                                              
{ Since the release_file_list is at the maximum, no test will be necessary to verify that                     
{ the release_file_count does not exceed the upperbound of the list.                                          
                                                                                                              
    qfp$release_generic_queue_files (release_file_list, release_file_count);                                  
                                                                                                              
    cycle_selector.cycle_option := pfc$specific_cycle;                                                        
    cycle_selector.cycle_number := 1;                                                                         
    password := osc$null_name;                                                                                
    PUSH path_p: [1 .. 4];                                                                                    
    path_p^ [1] := jmc$system_family;                                                                         
    path_p^ [2] := jmc$system_user;                                                                           
    path_p^ [3] := jmc$generic_queue_catalog;                                                                 
                                                                                                              
    osp$establish_block_exit_hndlr (^handle_block_exit);                                                      
    pfp$begin_system_authority;                                                                               
                                                                                                              
  /purge_all_released_files/                                                                                  
    FOR release_file_index := 1 TO release_file_count DO                                                      
      path_p^ [4] := release_file_list^ [release_file_index];                                                 
      pfp$purge (path_p^, cycle_selector, password, ignore_status);                                           
    FOREND /purge_all_released_files/;                                                                        
                                                                                                              
    pfp$end_system_authority;                                                                                 
    osp$disestablish_cond_handler;                                                                            
                                                                                                              
  PROCEND jmp$release_generic_queue_files;                                                                    
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$set_qfile_completed', EJECT ??                                              
*copy jmh$set_qfile_completed                                                                                 
                                                                                                              
{ DESIGN:                                                                                                     
{ Set up block exit condition handler                                                                         
                                                                                                              
{ IF completed_successfully THEN                                                                              
{   Attach the queue file and read the system label                                                           
{   disposition_time := current_time                                                                          
{   IF purge_delay_specified THEN                                                                             
{     purge_delay_clock := purge_delay_in_microseconds + current_clock_value                                  
{   ELSE                                                                                                      
{     purge_delay_clock := earliest_clock_time                                                                
{   IFEND                                                                                                     
{ ELSE                                                                                                        
{   purge_delay_clock := earliest_clock_time                                                                  
{ IFEND                                                                                                       
{ Mark the KQL as completed (qfp$set_qfile_completed)                                                         
{ IF delete_qfile is returned by qfp$set_qfile_completed THEN                                                 
{   Purge it                                                                                                  
{ ELSEIF completed_successfully THEN                                                                          
{   Write the system label                                                                                    
{ IFEND                                                                                                       
{ Return the file                                                                                             
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$set_qfile_completed                                                             
    (    application_name: ost$name;                                                                          
         system_file_name: jmt$system_supplied_name;                                                          
         completed_successfully: boolean;                                                                     
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      application_attributes_p: ^qfile_appl_attribute_choices,                                                
      attributes_size: jmt$qsl_appl_attr_contents_size,                                                       
      attribute_work_area_p: ^jmt$work_area,                                                                  
      cycle_selector: pft$cycle_selector,                                                                     
      current_clock_time: jmt$clock_time,                                                                     
      date_time: ost$date_time,                                                                               
      delete_qfile: boolean,                                                                                  
      ignore_status: ost$status,                                                                              
      local_file_name: amt$local_file_name,                                                                   
      local_status: ost$status,                                                                               
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      purge_delay_clock_time: jmt$clock_time,                                                                 
      share_selections: pft$usage_selections,                                                                 
      system_label: jmt$qfile_system_label,                                                                   
      usage_selections: pft$usage_selections;                                                                 
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      pfp$end_system_authority;                                                                               
      amp$return (local_file_name, ignore_status);                                                            
      IF status.normal THEN                                                                                   
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);      
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
    determine_file_path (system_file_name, path_p);                                                           
    cycle_selector.cycle_option := pfc$specific_cycle;                                                        
    cycle_selector.cycle_number := 1;                                                                         
    password := osc$null_name;                                                                                
                                                                                                              
    IF completed_successfully THEN                                                                            
      pmp$get_unique_name (local_file_name, ignore_status);                                                   
      usage_selections := $pft$usage_selections [pfc$read, pfc$modify];                                       
      share_selections := $pft$share_selections [pfc$read];                                                   
      osp$establish_block_exit_hndlr (^handle_block_exit);                                                    
      pfp$begin_system_authority;                                                                             
      pfp$attach (local_file_name, path_p^, cycle_selector, password, usage_selections, usage_selections,     
            pfc$wait, status);                                                                                
      pfp$end_system_authority;                                                                               
                                                                                                              
{ The attach has completed - dump the handler                                                                 
                                                                                                              
      osp$disestablish_cond_handler;                                                                          
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
      qfp$read_qfile_system_label (local_file_name, system_label, status);                                    
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
      pmp$get_microsecond_clock (current_clock_time, ignore_status);                                          
      pmp$get_compact_date_time (system_label.disposition_time.date_time, ignore_status);                     
      system_label.disposition_time.specified := TRUE;                                                        
      IF system_label.purge_delay.specified THEN                                                              
        pmp$compute_date_time (system_label.disposition_time.date_time,                                       
              system_label.purge_delay.time_increment, date_time, ignore_status);                             
        jmp$convert_date_time_dif_to_us (system_label.disposition_time.date_time, date_time,                  
              current_clock_time, purge_delay_clock_time);                                                    
      ELSE                                                                                                    
        purge_delay_clock_time := jmc$earliest_clock_time;                                                    
      IFEND;                                                                                                  
    ELSE                                                                                                      
      purge_delay_clock_time := jmc$earliest_clock_time;                                                      
    IFEND;                                                                                                    
                                                                                                              
    qfp$set_qfile_completed (application_name, system_file_name, completed_successfully,                      
          purge_delay_clock_time, current_clock_time, delete_qfile, status);                                  
    IF status.normal THEN                                                                                     
      IF delete_qfile THEN                                                                                    
        amp$return (local_file_name, ignore_status);                                                          
        osp$establish_block_exit_hndlr (^handle_block_exit);                                                  
        pfp$begin_system_authority;                                                                           
        pfp$purge (path_p^, cycle_selector, password, status);                                                
        pfp$end_system_authority;                                                                             
        osp$disestablish_cond_handler;                                                                        
      ELSEIF completed_successfully THEN                                                                      
                                                                                                              
{ The application attributes must be unpacked and then packed again in order to find their size.              
                                                                                                              
        PUSH application_attributes_p;                                                                        
        PUSH attribute_work_area_p: [[REP jmc$max_qfile_appl_attr_size OF cell]];                             
        unpack_application_attributes (^system_label, application_attributes_p, attribute_work_area_p,        
              status);                                                                                        
        IF NOT status.normal THEN                                                                             
          amp$return (local_file_name, ignore_status);                                                        
          RETURN;                                                                                             
        IFEND;                                                                                                
                                                                                                              
        pack_application_attributes (application_attributes_p, ^system_label, attributes_size, status);       
        IF NOT status.normal THEN                                                                             
          amp$return (local_file_name, ignore_status);                                                        
          RETURN;                                                                                             
        IFEND;                                                                                                
                                                                                                              
{ Write the updated queue file's system label                                                                 
                                                                                                              
        qfp$write_qfile_system_label (local_file_name, { write_label } TRUE, system_label, attributes_size,   
              status);                                                                                        
        IF status.normal THEN                                                                                 
          amp$return (local_file_name, status);                                                               
        ELSE                                                                                                  
          amp$return (local_file_name, ignore_status);                                                        
        IFEND;                                                                                                
      IFEND;                                                                                                  
    ELSE                                                                                                      
      amp$return (local_file_name, ignore_status);                                                            
    IFEND;                                                                                                    
                                                                                                              
  PROCEND jmp$set_qfile_completed;                                                                            
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$set_qfile_initiated', EJECT ??                                              
*copy jmh$set_qfile_initiated                                                                                 
                                                                                                              
{ DESIGN:                                                                                                     
{ Call qfp$set_qfile_initiated to validate the application and                                                
{   update the KQL                                                                                            
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$set_qfile_initiated                                                             
    (    application_name: ost$name;                                                                          
         system_file_name: jmt$system_supplied_name;                                                          
     VAR status: ost$status);                                                                                 
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    qfp$set_qfile_initiated (application_name, system_file_name, status);                                     
                                                                                                              
  PROCEND jmp$set_qfile_initiated;                                                                            
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$submit_qfile', EJECT ??                                                     
*copy jmh$submit_qfile                                                                                        
                                                                                                              
{ DESIGN:                                                                                                     
{ Set up block exit condition handler                                                                         
                                                                                                              
{ Determine if a system label exists in the submitted file                                                    
{ IF NOT system label exists THEN                                                                             
{   Initialize the qfile attributes in the label                                                              
{ IFEND                                                                                                       
{ FOR each submission option DO                                                                               
{   validate as necessary and override the value in the system label                                          
{ FOREND                                                                                                      
{ IF earliest_run_time specified THEN                                                                         
{   earliest_run_time_clock := (earliest_run_time - current_time) + current_clock_value                       
{ ELSE                                                                                                        
{   earliest_run_time_clock := earliest_clock_time                                                            
{ IFEND                                                                                                       
{ IF latest_run_time specified THEN                                                                           
{   latest_run_time_clock := (latest_run_time - current_time) + current_clock_value                           
{ ELSE                                                                                                        
{   latest_run_time_clock := latest_clock_time                                                                
{ IFEND                                                                                                       
{ Set up file attributes: Creation_attributes ring = 3                                                        
{                         IF data_mode = coded, T-record file ELSE raw copy IFEND                             
{ Assign a system supplied name to the file if it doesn't have one                                            
{ Try to define the file in the queue                                                                         
{ IF queue catalog doesn't exist                                                                              
{   Create queue catalog                                                                                      
{   Define the file in the queue                                                                              
{ IFEND                                                                                                       
{ Copy the file to the queue                                                                                  
{ Write the system label                                                                                      
{ Return the queue file                                                                                       
{ Add the file to the KQL (qfp$submit_qfile)                                                                  
{ IF error THEN                                                                                               
{   purge it                                                                                                  
{ IFEND                                                                                                       
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$submit_qfile                                                                    
    (    file_reference: fst$file_reference;                                                                  
         application_name: ost$name;                                                                          
         submission_options_p: ^jmt$qfile_submission_options;                                                 
     VAR system_file_name: jmt$system_supplied_name;                                                          
     VAR status: ost$status);                                                                                 
                                                                                                              
    CONST                                                                                                     
      unit_separator = $CHAR (1f(16));                                                                        
                                                                                                              
    VAR                                                                                                       
      attributes_size: jmt$qsl_appl_attr_contents_size,                                                       
      attribute_work_area_p: ^jmt$work_area,                                                                  
      caller_identifier: ost$caller_identifier,                                                               
      catalog_path_p: ^pft$path,                                                                              
      contains_data: boolean,                                                                                 
      current_date_time: ost$date_time,                                                                       
      current_microsecond_clock: jmt$clock_time,                                                              
      cycle_selector: pft$cycle_selector,                                                                     
      date_time: ost$date_time,                                                                               
      earliest_clock_time_to_process: jmt$clock_time,                                                         
      file_attributes: ^amt$get_attributes,                                                                   
      good_application_name: ost$name,                                                                        
      ignore_status: ost$status,                                                                              
      input_attachment_options_p: ^fst$attachment_options,                                                    
      input_validation_attributes_p: ^fst$file_cycle_attributes,                                              
      latest_clock_time_to_process: jmt$clock_time,                                                           
      local_file: boolean,                                                                                    
      null_file_access_procedure: pmt$entry_point_reference,                                                  
      old_file: boolean,                                                                                      
      qfile_attachment_options_p: ^fst$attachment_options,                                                    
      qfile_attribute_choices: qfile_appl_attribute_choices,                                                  
      qfile_creation_attributes_p: ^fst$file_cycle_attributes,                                                
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      permanent_file_name: amt$local_file_name,                                                               
      system_file_name_assigned: boolean,                                                                     
      system_label: jmt$qfile_system_label,                                                                   
      system_label_already_existed: boolean,                                                                  
      valid_name: boolean,                                                                                    
      validation_ring: ost$valid_ring;                                                                        
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      pfp$end_system_authority;                                                                               
      IF status.normal THEN                                                                                   
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);      
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'build_standard_label', EJECT ??                                                               
                                                                                                              
{ PURPOSE:                                                                                                    
{   Build the label for the queued file.                                                                      
                                                                                                              
    PROCEDURE build_standard_label                                                                            
      (    application_name: ost$name;                                                                        
       VAR appl_attribute_choices: qfile_appl_attribute_choices;                                              
       VAR system_label: jmt$qfile_system_label);                                                             
                                                                                                              
      VAR                                                                                                     
        attribute_index: integer;                                                                             
                                                                                                              
{ Initialize the application attributes. These will be put in the system label later.                         
                                                                                                              
      FOR attribute_index := jmc$application_attributes_1 TO jmc$application_attributes_10 DO                 
        appl_attribute_choices [attribute_index].key := attribute_index;                                      
        appl_attribute_choices [attribute_index].application_attributes.size := 0;                            
        appl_attribute_choices [attribute_index].application_attributes.attributes_p := NIL;                  
      FOREND;                                                                                                 
                                                                                                              
      system_label.data_mode := jmc$coded_data;                                                               
      system_label.deferred_by_application := FALSE;                                                          
      system_label.destination := '';                                                                         
      system_label.disposition_time.specified := FALSE;                                                       
      system_label.earliest_run_time.specified := FALSE;                                                      
      system_label.latest_run_time.specified := FALSE;                                                        
      system_label.application_name := application_name;                                                      
      system_label.purge_delay.specified := FALSE;                                                            
      system_label.remote_host_directive.size := 0;                                                           
      system_label.remote_host_directive.parameters := '';                                                    
      system_label.system_file_name := '';                                                                    
                                                                                                              
    PROCEND build_standard_label;                                                                             
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'update_label_with_user_options', EJECT ??                                                     
                                                                                                              
{ PURPOSE:                                                                                                    
{   Validates the submission options and updates the system label.                                            
                                                                                                              
    PROCEDURE update_label_with_user_options                                                                  
      (    submission_options_p: ^jmt$qfile_submission_options;                                               
       VAR appl_attribute_choices: qfile_appl_attribute_choices;                                              
       VAR system_label: jmt$qfile_system_label;                                                              
       VAR validation_ring: ost$valid_ring;                                                                   
       VAR status: ost$status);                                                                               
                                                                                                              
      VAR                                                                                                     
        candidate_system_file_name: jmt$name,                                                                 
        option_index: integer,                                                                                
        scl_name: ost$name,                                                                                   
        valid_name: boolean,                                                                                  
        valid_system_file_name: jmt$name;                                                                     
                                                                                                              
      status.normal := TRUE;                                                                                  
      IF submission_options_p = NIL THEN                                                                      
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      FOR option_index := 1 TO UPPERBOUND (submission_options_p^) DO                                          
        CASE submission_options_p^ [option_index].key OF                                                      
        = jmc$application_attributes_1, jmc$application_attributes_2, jmc$application_attributes_3,           
              jmc$application_attributes_4, jmc$application_attributes_5, jmc$application_attributes_6,       
              jmc$application_attributes_7, jmc$application_attributes_8, jmc$application_attributes_9,       
              jmc$application_attributes_10 =                                                                 
          appl_attribute_choices [submission_options_p^ [option_index].key].application_attributes :=         
                submission_options_p^ [option_index].application_attributes;                                  
                                                                                                              
        = jmc$data_mode =                                                                                     
          system_label.data_mode := submission_options_p^ [option_index].data_mode;                           
                                                                                                              
        = jmc$deferred_by_application =                                                                       
          system_label.deferred_by_application := submission_options_p^ [option_index].                       
                deferred_by_application;                                                                      
                                                                                                              
        = jmc$destination =                                                                                   
          clp$validate_name (submission_options_p^ [option_index].destination, scl_name, valid_name);         
          IF valid_name THEN                                                                                  
            system_label.destination := scl_name;                                                             
          ELSE                                                                                                
            #TRANSLATE (osv$lower_to_upper, submission_options_p^ [option_index].destination,                 
                  system_label.destination);                                                                  
          IFEND;                                                                                              
                                                                                                              
        = jmc$earliest_run_time =                                                                             
          system_label.earliest_run_time := submission_options_p^ [option_index].earliest_run_time;           
                                                                                                              
        = jmc$latest_run_time =                                                                               
          system_label.latest_run_time := submission_options_p^ [option_index].latest_run_time;               
                                                                                                              
        = jmc$null_attribute =                                                                                
          ;                                                                                                   
                                                                                                              
        = jmc$purge_delay =                                                                                   
          system_label.purge_delay := submission_options_p^ [option_index].purge_delay^;                      
                                                                                                              
        = jmc$remote_host_directive =                                                                         
          system_label.remote_host_directive := submission_options_p^ [option_index].remote_host_directive^;  
                                                                                                              
        = jmc$system_file_name =                                                                              
                                                                                                              
{ A blank system supplied name indicates that a "new" system file name should be assigned.                    
                                                                                                              
          IF submission_options_p^ [option_index].system_file_name <> jmc$blank_system_supplied_name THEN     
            candidate_system_file_name.kind := jmc$system_supplied_name;                                      
            candidate_system_file_name.system_supplied_name :=                                                
                  submission_options_p^ [option_index].system_file_name;                                      
            jmp$validate_name (candidate_system_file_name, valid_system_file_name, status);                   
            IF NOT status.normal THEN                                                                         
              RETURN;                                                                                         
            IFEND;                                                                                            
            system_label.system_file_name := valid_system_file_name.system_supplied_name;                     
          ELSE                                                                                                
            system_label.system_file_name := jmc$blank_system_supplied_name;                                  
          IFEND;                                                                                              
                                                                                                              
        = jmc$validation_ring =                                                                               
                                                                                                              
{ Validation_ring doesn't go in the system label.  It is used to validate attaching the file.                 
                                                                                                              
          validation_ring := submission_options_p^ [option_index].validation_ring;                            
                                                                                                              
        ELSE                                                                                                  
          jmp$get_attribute_name (submission_options_p^ [option_index].key, scl_name);                        
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'SUBMISSION_OPTIONS_P', status);       
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$submit_qfile, status);             
          RETURN;                                                                                             
        CASEND;                                                                                               
      FOREND;                                                                                                 
      IF system_label.application_name = jmc$qtf_usage THEN                                                   
        IF system_label.destination = '' THEN                                                                 
          osp$set_status_condition (jme$invalid_destination, status);                                         
        ELSEIF system_label.remote_host_directive.size = 0 THEN                                               
          osp$set_status_condition (jme$invalid_rhd, status);                                                 
        IFEND;                                                                                                
      IFEND;                                                                                                  
    PROCEND update_label_with_user_options;                                                                   
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
    ignore_status.normal := TRUE;                                                                             
                                                                                                              
{ Set up static and default values                                                                            
                                                                                                              
    #CALLER_ID (caller_identifier);                                                                           
    validation_ring := caller_identifier.ring;                                                                
    pmp$get_compact_date_time (current_date_time, { ignore } status);                                         
                                                                                                              
{ Validate the application name.                                                                              
                                                                                                              
    clp$validate_name (application_name, good_application_name, valid_name);                                  
    IF NOT valid_name THEN                                                                                    
      osp$set_status_abnormal ('CL', cle$improper_name, application_name, status);                            
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Test to see if the queue file already has a system label.  If it does then the                              
{ defaulting does not take place.                                                                             
                                                                                                              
    qfp$read_qfile_system_label (file_reference, system_label, status);                                       
    IF status.normal THEN                                                                                     
      system_label_already_existed := TRUE;                                                                   
      PUSH attribute_work_area_p: [[REP jmc$max_qfile_appl_attr_size OF cell]];                               
      unpack_application_attributes (^system_label, ^qfile_attribute_choices, attribute_work_area_p, status); 
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      system_label.application_name := good_application_name;                                                 
    ELSE {NOT status.normal ==> The file did not have a system label                                          
                                                                                                              
      status.normal := TRUE;                                                                                  
                                                                                                              
      system_label_already_existed := FALSE;                                                                  
      build_standard_label (good_application_name, qfile_attribute_choices, system_label);                    
    IFEND; {NOT status.normal ==> The file did not have a system label                                        
                                                                                                              
{ Override default values for the system label - if necessary                                                 
                                                                                                              
    update_label_with_user_options (submission_options_p, qfile_attribute_choices, system_label,              
          validation_ring, status);                                                                           
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    pack_application_attributes (^qfile_attribute_choices, ^system_label, attributes_size, status);           
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Calculate the earliest_run_time, latest_run_time and purge_delay if necessary.                              
                                                                                                              
    pmp$get_microsecond_clock (current_microsecond_clock, ignore_status);                                     
                                                                                                              
    IF system_label.earliest_run_time.specified THEN                                                          
      jmp$convert_date_time_dif_to_us (current_date_time, system_label.earliest_run_time.date_time,           
            current_microsecond_clock, earliest_clock_time_to_process);                                       
    ELSE                                                                                                      
      earliest_clock_time_to_process := jmc$earliest_clock_time;                                              
    IFEND;                                                                                                    
                                                                                                              
    IF system_label.latest_run_time.specified THEN                                                            
      jmp$convert_date_time_dif_to_us (current_date_time, system_label.latest_run_time.date_time,             
            current_microsecond_clock, latest_clock_time_to_process);                                         
    ELSE                                                                                                      
      latest_clock_time_to_process := jmc$latest_clock_time;                                                  
    IFEND;                                                                                                    
                                                                                                              
{ The system label is now completely built                                                                    
                                                                                                              
    password := osc$null_name;                                                                                
                                                                                                              
{ Make the appropriate copy - to t-record if the file is coded - raw copy if the file is transparent.         
                                                                                                              
    null_file_access_procedure.entry_point := osc$null_name;                                                  
    null_file_access_procedure.object_library := '';                                                          
    PUSH input_validation_attributes_p: [1 .. 2];                                                             
    input_validation_attributes_p^ [1].selector := fsc$file_access_procedure_name;                            
    input_validation_attributes_p^ [1].file_access_procedure_name := ^null_file_access_procedure;             
    input_validation_attributes_p^ [2].selector := fsc$ring_attributes;                                       
    input_validation_attributes_p^ [2].ring_attributes.r1 := validation_ring;                                 
    input_validation_attributes_p^ [2].ring_attributes.r2 := validation_ring;                                 
    input_validation_attributes_p^ [2].ring_attributes.r3 := validation_ring;                                 
                                                                                                              
    PUSH input_attachment_options_p: [1 .. 8];                                                                
    input_attachment_options_p^ [1].selector := fsc$access_and_share_modes;                                   
    input_attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;                       
    input_attachment_options_p^ [1].access_modes.value := $fst$file_access_options [fsc$read];                
    input_attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;                         
    input_attachment_options_p^ [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];    
    input_attachment_options_p^ [2].selector := fsc$allowed_device_classes;                                   
    input_attachment_options_p^ [2].allowed_device_classes := $fst$device_classes [fsc$mass_storage_device];  
    input_attachment_options_p^ [3].selector := fsc$create_file;                                              
    input_attachment_options_p^ [3].create_file := FALSE;                                                     
    input_attachment_options_p^ [4].selector := fsc$free_behind;                                              
    input_attachment_options_p^ [4].free_behind := TRUE;                                                      
    input_attachment_options_p^ [5].selector := fsc$open_position;                                            
    input_attachment_options_p^ [5].open_position := amc$open_at_boi;                                         
    input_attachment_options_p^ [6].selector := fsc$private_read;                                             
    input_attachment_options_p^ [6].private_read := TRUE;                                                     
    input_attachment_options_p^ [7].selector := fsc$sequential_access;                                        
    input_attachment_options_p^ [7].sequential_access := TRUE;                                                
    input_attachment_options_p^ [8].selector := fsc$validation_ring;                                          
    input_attachment_options_p^ [8].validation_ring := caller_identifier.ring;                                
                                                                                                              
    PUSH qfile_attachment_options_p: [1 .. 2];                                                                
    qfile_attachment_options_p^ [1].selector := fsc$free_behind;                                              
    qfile_attachment_options_p^ [1].free_behind := TRUE;                                                      
    qfile_attachment_options_p^ [2].selector := fsc$sequential_access;                                        
    qfile_attachment_options_p^ [2].sequential_access := TRUE;                                                
                                                                                                              
    IF system_label.data_mode = jmc$coded_data THEN                                                           
      PUSH qfile_creation_attributes_p: [1 .. 6];                                                             
      qfile_creation_attributes_p^ [1].selector := fsc$ring_attributes;                                       
                                                                                                              
{ Ring attributes are set below.                                                                              
                                                                                                              
      qfile_creation_attributes_p^ [2].selector := fsc$file_contents_and_processor;                           
      qfile_creation_attributes_p^ [2].file_contents := fsc$list;                                             
      qfile_creation_attributes_p^ [2].file_processor := fsc$unknown_processor;                               
      qfile_creation_attributes_p^ [3].selector := fsc$block_type;                                            
      qfile_creation_attributes_p^ [3].block_type := amc$system_specified;                                    
      qfile_creation_attributes_p^ [4].selector := fsc$record_delimiting_character;                           
      qfile_creation_attributes_p^ [4].record_delimiting_character := unit_separator;                         
      qfile_creation_attributes_p^ [5].selector := fsc$record_type;                                           
      qfile_creation_attributes_p^ [5].record_type := amc$trailing_char_delimited;                            
      qfile_creation_attributes_p^ [6].selector := fsc$file_organization;                                     
      qfile_creation_attributes_p^ [6].file_organization := amc$sequential;                                   
                                                                                                              
    ELSE { transparent data }                                                                                 
      PUSH qfile_creation_attributes_p: [1 .. 1];                                                             
      qfile_creation_attributes_p^ [1].selector := fsc$ring_attributes;                                       
                                                                                                              
{ Ring attributes are set below.                                                                              
                                                                                                              
    IFEND;                                                                                                    
                                                                                                              
    system_file_name_assigned := system_label.system_file_name <> '';                                         
                                                                                                              
  /submit_qfile/                                                                                              
    WHILE TRUE DO                                                                                             
      IF NOT system_file_name_assigned THEN                                                                   
        qfp$assign_system_supplied_name (system_label.system_file_name);                                      
      IFEND;                                                                                                  
                                                                                                              
      permanent_file_name := system_label.system_file_name;                                                   
      system_file_name := system_label.system_file_name;                                                      
                                                                                                              
      determine_file_path (system_file_name, path_p);                                                         
      cycle_selector.cycle_option := pfc$specific_cycle;                                                      
      cycle_selector.cycle_number := 1;                                                                       
      osp$establish_block_exit_hndlr (^handle_block_exit);                                                    
      pfp$begin_system_authority;                                                                             
      pfp$define (permanent_file_name, path_p^, cycle_selector, password, pfc$maximum_retention, pfc$log,     
            status);                                                                                          
      IF NOT status.normal THEN                                                                               
        IF (status.condition = pfe$unknown_last_subcatalog) OR                                                
              (status.condition = pfe$unknown_nth_subcatalog) THEN                                            
          PUSH catalog_path_p: [1 .. 3];                                                                      
          catalog_path_p^ [1] := path_p^ [1];                                                                 
          catalog_path_p^ [2] := path_p^ [2];                                                                 
          catalog_path_p^ [3] := path_p^ [3];                                                                 
          pfp$define_catalog (catalog_path_p^, status);                                                       
          IF status.normal THEN                                                                               
            osp$set_status_condition (pfe$duplicate_cycle, status);                                           
          IFEND;                                                                                              
        ELSEIF (status.condition = pfe$duplicate_cycle) THEN                                                  
          system_file_name_assigned := FALSE;                                                                 
        IFEND;                                                                                                
      IFEND;                                                                                                  
      pfp$end_system_authority;                                                                               
      osp$disestablish_cond_handler;                                                                          
      IF NOT status.normal THEN                                                                               
        IF (status.condition = pfe$duplicate_cycle) THEN                                                      
          status.normal := TRUE;                                                                              
          CYCLE /submit_qfile/;                                                                               
        IFEND;                                                                                                
        EXIT /submit_qfile/;                                                                                  
      IFEND;                                                                                                  
                                                                                                              
      qfile_creation_attributes_p^ [1].ring_attributes.r1 := osc$tsrv_ring;                                   
      qfile_creation_attributes_p^ [1].ring_attributes.r2 := osc$tsrv_ring;                                   
      qfile_creation_attributes_p^ [1].ring_attributes.r3 := osc$tsrv_ring;                                   
                                                                                                              
      fsp$subsystem_copy_file (file_reference, permanent_file_name, input_attachment_options_p,               
            qfile_attachment_options_p, input_validation_attributes_p, {qfile_attribute_validation} NIL,      
            qfile_creation_attributes_p, status);                                                             
      IF NOT status.normal THEN                                                                               
        amp$return (permanent_file_name, ignore_status);                                                      
        osp$establish_block_exit_hndlr (^handle_block_exit);                                                  
        pfp$begin_system_authority;                                                                           
        pfp$purge (path_p^, cycle_selector, password, ignore_status);                                         
        pfp$end_system_authority;                                                                             
        osp$disestablish_cond_handler;                                                                        
        EXIT /submit_qfile/;                                                                                  
      IFEND;                                                                                                  
                                                                                                              
      qfp$write_qfile_system_label (permanent_file_name, { write_label } TRUE, system_label, attributes_size, 
            status);                                                                                          
      IF NOT status.normal THEN                                                                               
        amp$return (permanent_file_name, ignore_status);                                                      
        osp$establish_block_exit_hndlr (^handle_block_exit);                                                  
        pfp$begin_system_authority;                                                                           
        pfp$purge (path_p^, cycle_selector, password, ignore_status);                                         
        pfp$end_system_authority;                                                                             
        osp$disestablish_cond_handler;                                                                        
        EXIT /submit_qfile/;                                                                                  
      IFEND;                                                                                                  
                                                                                                              
      amp$return (permanent_file_name, status);                                                               
      IF NOT status.normal THEN                                                                               
        osp$establish_block_exit_hndlr (^handle_block_exit);                                                  
        pfp$begin_system_authority;                                                                           
        pfp$purge (path_p^, cycle_selector, password, ignore_status);                                         
        pfp$end_system_authority;                                                                             
        osp$disestablish_cond_handler;                                                                        
        EXIT /submit_qfile/;                                                                                  
      IFEND;                                                                                                  
                                                                                                              
{ Enter the file in the Known Qfile List.                                                                     
                                                                                                              
      qfp$submit_qfile (system_label, earliest_clock_time_to_process, latest_clock_time_to_process,           
            current_microsecond_clock, status);                                                               
      IF NOT status.normal THEN                                                                               
        osp$establish_block_exit_hndlr (^handle_block_exit);                                                  
        pfp$begin_system_authority;                                                                           
        pfp$purge (path_p^, cycle_selector, password, ignore_status);                                         
        pfp$end_system_authority;                                                                             
        osp$disestablish_cond_handler;                                                                        
        IF status.condition = jme$duplicate_name THEN                                                         
          status.normal := TRUE;                                                                              
          system_file_name_assigned := FALSE;                                                                 
          CYCLE /submit_qfile/;                                                                               
        IFEND;                                                                                                
                                                                                                              
      IFEND;                                                                                                  
      EXIT /submit_qfile/;                                                                                    
    WHILEND /submit_qfile/;                                                                                   
                                                                                                              
  PROCEND jmp$submit_qfile;                                                                                   
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$terminate_acquired_qfile', EJECT ??                                         
*copy jmh$terminate_acquired_qfile                                                                            
                                                                                                              
{ DESIGN:                                                                                                     
{ Set up block exit condition handler                                                                         
                                                                                                              
{ Call qfp$terminate_acquired_qfile to get the name of the file terminated.                                   
{ IF delete_qfile is returned by qfp$terminate_acquired_qfile THEN                                            
{   purge it                                                                                                  
{ IFEND                                                                                                       
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$terminate_acquired_qfile                                                        
    (    application_name: ost$name;                                                                          
     VAR system_file_name: jmt$system_supplied_name;                                                          
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      delete_qfile: boolean,                                                                                  
      cycle_selector: pft$cycle_selector,                                                                     
      ignore_status: ost$status,                                                                              
      path_p: ^pft$path,                                                                                      
      password: pft$password,                                                                                 
      system_job_name: jmt$system_supplied_name;                                                              
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      pfp$end_system_authority;                                                                               
      IF status.normal THEN                                                                                   
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);      
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    qfp$terminate_acquired_qfile (application_name, system_file_name, delete_qfile, status);                  
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF delete_qfile THEN                                                                                      
      determine_file_path (system_file_name, path_p);                                                         
                                                                                                              
      cycle_selector.cycle_option := pfc$specific_cycle;                                                      
      cycle_selector.cycle_number := 1;                                                                       
      password := osc$null_name;                                                                              
      osp$establish_block_exit_hndlr (^handle_block_exit);                                                    
      pfp$begin_system_authority;                                                                             
      pfp$purge (path_p^, cycle_selector, password, status);                                                  
      pfp$end_system_authority;                                                                               
      osp$disestablish_cond_handler;                                                                          
    IFEND;                                                                                                    
                                                                                                              
  PROCEND jmp$terminate_acquired_qfile;                                                                       
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$terminate_qfile', EJECT ??                                                  
*copy jmh$terminate_qfile                                                                                     
                                                                                                              
{ DESIGN:                                                                                                     
{ Set up block exit condition handler                                                                         
                                                                                                              
{ qfile_state_set := all states                                                                               
{ FOR each termination option DO                                                                              
{   Record the options                                                                                        
{ FOREND                                                                                                      
{ Remove the file from the KQL (qfp$terminate_qfile)                                                          
{ IF delete_qfile is returned from qfp$terminate_qfile THEN                                                   
{   Purge it                                                                                                  
{ IFEND                                                                                                       
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$terminate_qfile                                                                 
    (    system_file_name: jmt$system_supplied_name;                                                          
         termination_options_p: ^jmt$qfile_termination_options;                                               
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      cycle_selector: pft$cycle_selector,                                                                     
      delete_qfile: boolean,                                                                                  
      number_of_qfiles_found: jmt$qfile_status_count,                                                         
      option_index: integer,                                                                                  
      qfile_state_set: jmt$qfile_state_set,                                                                   
      qfile_to_terminate: jmt$name,                                                                           
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      potential_name: jmt$name,                                                                               
      scl_name: ost$name,                                                                                     
      status_options_p: ^jmt$qfile_status_options,                                                            
      status_results_p: ^jmt$qfile_status_results,                                                            
      status_work_area_p: ^jmt$work_area;                                                                     
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      pfp$end_system_authority;                                                                               
      IF status.normal THEN                                                                                   
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);      
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
    status.normal := TRUE;                                                                                    
                                                                                                              
{ Set defaults                                                                                                
                                                                                                              
    qfile_state_set := -$jmt$qfile_state_set [];                                                              
                                                                                                              
{ Override defaults if necessary                                                                              
                                                                                                              
    IF termination_options_p <> NIL THEN                                                                      
      FOR option_index := 1 TO UPPERBOUND (termination_options_p^) DO                                         
        CASE termination_options_p^ [option_index].key OF                                                     
        = jmc$null_attribute =                                                                                
          ;                                                                                                   
                                                                                                              
        = jmc$qfile_state_set =                                                                               
          IF termination_options_p^ [option_index].qfile_state_set = $jmt$qfile_state_set [] THEN             
            osp$set_status_condition (jme$qfile_state_is_null, status);                                       
            RETURN;                                                                                           
          IFEND;                                                                                              
          qfile_state_set := termination_options_p^ [option_index].qfile_state_set;                           
                                                                                                              
        ELSE                                                                                                  
          jmp$get_attribute_name (termination_options_p^ [option_index].key, scl_name);                       
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'QFILE_TERMINATION_OPTIONS', status);  
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$terminate_qfile, status);          
          RETURN;                                                                                             
        CASEND;                                                                                               
      FOREND;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    potential_name.kind := jmc$system_supplied_name;                                                          
    potential_name.system_supplied_name := system_file_name;                                                  
    jmp$validate_name (potential_name, qfile_to_terminate, status);                                           
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    PUSH status_options_p: [1 .. 2];                                                                          
    status_options_p^ [1].key := jmc$system_supplied_name_list;                                               
    PUSH status_options_p^ [1].system_supplied_name_list: [1 .. 1];                                           
    status_options_p^ [1].system_supplied_name_list^ [1] := qfile_to_terminate.system_supplied_name;          
    status_options_p^ [2].key := jmc$qfile_state_set;                                                         
    status_options_p^ [2].qfile_state_set := qfile_state_set;                                                 
                                                                                                              
    PUSH status_work_area_p: [[REP #SIZE (jmt$qfile_status_results: [1 .. 1]) OF cell]];                      
                                                                                                              
    jmp$get_qfile_status (status_options_p, { status_results_keys_p } NIL, status_work_area_p,                
          status_results_p, number_of_qfiles_found, status);                                                  
    IF NOT status.normal THEN                                                                                 
      IF status.condition = jme$no_qfiles_were_found THEN                                                     
        osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_file_name, status);        
      IFEND;                                                                                                  
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    qfp$terminate_qfile (qfile_to_terminate.system_supplied_name, qfile_state_set, delete_qfile, status);     
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF delete_qfile THEN                                                                                      
                                                                                                              
      determine_file_path (qfile_to_terminate.system_supplied_name, path_p);                                  
      cycle_selector.cycle_option := pfc$specific_cycle;                                                      
      cycle_selector.cycle_number := 1;                                                                       
      password := osc$null_name;                                                                              
      osp$establish_block_exit_hndlr (^handle_block_exit);                                                    
      pfp$begin_system_authority;                                                                             
      pfp$purge (path_p^, cycle_selector, password, status);                                                  
      pfp$end_system_authority;                                                                               
      osp$disestablish_cond_handler;                                                                          
    IFEND;                                                                                                    
                                                                                                              
  PROCEND jmp$terminate_qfile;                                                                                
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$terminated_qfile_exists', EJECT ??                                          
*copy jmh$terminated_qfile_exists                                                                             
                                                                                                              
{ DESIGN:                                                                                                     
{ Find index of application_name in the KQL application table                                                 
{ IF (index is NOT unassigned) AND (KQL application table's state data                                        
{     has terminated files for this index) AND (NOT system idling) THEN                                       
{   terminated_qfile_exists := true                                                                           
{ IFEND                                                                                                       
                                                                                                              
  FUNCTION [XDCL, #GATE] jmp$terminated_qfile_exists                                                          
    (    application_name: ost$name): boolean;                                                                
                                                                                                              
    VAR                                                                                                       
      application_index: jmt$qfile_application_index,                                                         
      qfile_exists: boolean;                                                                                  
                                                                                                              
    application_index := jmv$last_used_application_index;                                                     
    WHILE (jmv$known_qfile_list.application_table [application_index].application_name <>                     
          application_name) AND (application_index <> jmc$unassigned_qfile_index) DO                          
      application_index := application_index - 1;                                                             
    WHILEND;                                                                                                  
                                                                                                              
    qfile_exists := (application_index <> jmc$unassigned_qfile_index) AND                                     
          (jmv$known_qfile_list.application_table [application_index].                                        
          state_data [jmc$kql_application_terminated].number_of_entries > 0);                                 
    jmp$terminated_qfile_exists := qfile_exists AND (NOT syp$system_is_idling ());                            
                                                                                                              
  FUNCEND jmp$terminated_qfile_exists;                                                                        
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$update_qfile_status', EJECT ??                                              
*copy jmh$update_qfile_status                                                                                 
                                                                                                              
{ DESIGN:                                                                                                     
{ Set up block exit condition handler                                                                         
                                                                                                              
{ Validate that the application has permission to access the file                                             
{ IF any status updates were specified THEN                                                                   
{   Attach the file for read, modify access                                                                   
{   Read the system label                                                                                     
{   Update the system label                                                                                   
{   Write the system label                                                                                    
{ IFEND                                                                                                       
{ Return the file                                                                                             
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$update_qfile_status                                                             
    (    system_file_name: jmt$system_supplied_name;                                                          
         application_name: ost$name;                                                                          
         qfile_password: jmt$queue_file_password;                                                             
         qfile_status_updates_p: ^jmt$qfile_status_updates;                                                   
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      attribute_choices_p: ^qfile_appl_attribute_choices,                                                     
      attribute_work_area_p: ^jmt$work_area,                                                                  
      attributes_size: jmt$qsl_appl_attr_contents_size,                                                       
      cycle_selector: pft$cycle_selector,                                                                     
      ignore_status: ost$status,                                                                              
      local_file_name: amt$local_file_name,                                                                   
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      scl_name: ost$name,                                                                                     
      share_selections: pft$share_selections,                                                                 
      system_label: jmt$qfile_system_label,                                                                   
      update_index: integer,                                                                                  
      usage_selections: pft$usage_selections;                                                                 
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      pfp$end_system_authority;                                                                               
      IF status.normal THEN                                                                                   
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);      
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    ignore_status.normal := TRUE;                                                                             
    status.normal := TRUE;                                                                                    
                                                                                                              
{ Validate that the application has permission to access the file.                                            
                                                                                                              
    qfp$validate_qfile_access (system_file_name, application_name, qfile_password, status);                   
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    pmp$get_unique_name (local_file_name, status);                                                            
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    determine_file_path (system_file_name, path_p);                                                           
    cycle_selector.cycle_option := pfc$specific_cycle;                                                        
    cycle_selector.cycle_number := 1;                                                                         
    password := osc$null_name;                                                                                
    usage_selections := $pft$usage_selections [pfc$read, pfc$modify];                                         
    share_selections := $pft$share_selections [pfc$read];                                                     
    osp$establish_block_exit_hndlr (^handle_block_exit);                                                      
    pfp$begin_system_authority;                                                                               
    pfp$attach (local_file_name, path_p^, cycle_selector, password, usage_selections, share_selections,       
          pfc$wait, status);                                                                                  
    pfp$end_system_authority;                                                                                 
    osp$disestablish_cond_handler;                                                                            
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Read the queue file's system label                                                                          
                                                                                                              
    qfp$read_qfile_system_label (local_file_name, system_label, status);                                      
    IF NOT status.normal THEN                                                                                 
      amp$return (local_file_name, ignore_status);                                                            
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Check update changes and change the local copy of the system label                                          
                                                                                                              
    IF qfile_status_updates_p <> NIL THEN                                                                     
                                                                                                              
{ Get the application attributes from the label.                                                              
                                                                                                              
      PUSH attribute_choices_p;                                                                               
      PUSH attribute_work_area_p: [[REP jmc$max_qfile_appl_attr_size OF cell]];                               
      unpack_application_attributes (^system_label, attribute_choices_p, attribute_work_area_p, status);      
      IF NOT status.normal THEN                                                                               
        amp$return (local_file_name, ignore_status);                                                          
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
    /process_changes/                                                                                         
      FOR update_index := 1 TO UPPERBOUND (qfile_status_updates_p^) DO                                        
        CASE qfile_status_updates_p^ [update_index].key OF                                                    
        = jmc$application_attributes_1, jmc$application_attributes_2, jmc$application_attributes_3,           
              jmc$application_attributes_4, jmc$application_attributes_5, jmc$application_attributes_6,       
              jmc$application_attributes_7, jmc$application_attributes_8, jmc$application_attributes_9,       
              jmc$application_attributes_10 =                                                                 
          attribute_choices_p^ [qfile_status_updates_p^ [update_index].key].application_attributes :=         
                qfile_status_updates_p^ [update_index].application_attributes;                                
        = jmc$null_attribute =                                                                                
          ;                                                                                                   
                                                                                                              
        ELSE                                                                                                  
          jmp$get_attribute_name (qfile_status_updates_p^ [update_index].key, scl_name);                      
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'QFILE_STATUS_UPDATES_P', status);     
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$update_qfile_status, status);      
          EXIT /process_changes/;                                                                             
        CASEND;                                                                                               
      FOREND /process_changes/;                                                                               
      IF NOT status.normal THEN                                                                               
        amp$return (local_file_name, ignore_status);                                                          
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
{ Put the application attributes in the system label.                                                         
                                                                                                              
      pack_application_attributes (attribute_choices_p, ^system_label, attributes_size, status);              
      IF NOT status.normal THEN                                                                               
        amp$return (local_file_name, ignore_status);                                                          
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
{ Write the result system label to the queue file                                                             
                                                                                                              
      qfp$write_qfile_system_label (local_file_name, { write_label } TRUE, system_label, attributes_size,     
            status);                                                                                          
      IF NOT status.normal THEN                                                                               
        amp$return (local_file_name, ignore_status);                                                          
        RETURN;                                                                                               
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Release the file in case somebody needs it                                                                  
                                                                                                              
    amp$return (local_file_name, status);                                                                     
  PROCEND jmp$update_qfile_status;                                                                            
?? OLDTITLE ??                                                                                                
MODEND jmm$generic_queue_file_manager;                                                                        
*DECK DECK=JMM$GET_ENCRYPTED_PASSWORD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : Get Encrypted Password' ??
MODULE jmm$get_encrypted_password;

{ PURPOSE:
{   This module contains the routine to retrieve a users encrypted password.
{
{ DESIGN:
{   This module will access the user's validation file and retrieve the user's
{ encrypted password.  This module resides in a 236 library.

?? NEWTITLE := 'Global Declarations Referenced By This Module' ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc avp$prevalidate_job
*copyc pmp$get_user_identification
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$get_encrypted_password', EJECT ??
*copy jmh$get_encrypted_password

  PROCEDURE [XDCL, #GATE] jmp$get_encrypted_password
    (VAR encrypted_password: ost$name;
     VAR status: ost$status);

    VAR
      user_identification: ost$user_identification,
      validation_default: array [1 .. 1] of avt$validation_item;

    status.normal := TRUE;
    pmp$get_user_identification (user_identification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    validation_default [1].key := avc$password_key;
    avp$prevalidate_job (user_identification.user, user_identification.family,
          { validation_attributes } NIL, ^validation_default, status);
    IF status.normal THEN
      encrypted_password := validation_default [1].password;
    IFEND;

  PROCEND jmp$get_encrypted_password;
?? OLDTITLE ??
MODEND jmm$get_encrypted_password;
*DECK DECK=JMM$HANDLE_CONDITIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management: Handle Conditions' ??
MODULE jmm$handle_conditions;

?? NEWTITLE := '  Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??

*copyc jme$job_management_conditions
*copyc jmd$job_resource_condition
*copyc ost$status
*copyc oss$job_paged_literal
*copyc pmt$condition

?? POP ??

*copyc amp$get_next
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_integer
*copyc clp$put_job_output
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc jmp$logout
*copyc jmp$set_job_resource_condition
*copyc jmv$job_resource_condition
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$generate_log_message
*copyc osp$generate_output_message
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$dispose_interactive_cond
*copyc pmp$establish_condition_handler
*copyc pmp$exit
*copyc pmp$get_job_mode
*copyc sfp$change_job_warning_limit
*copyc sfp$get_job_limit
*copyc sfp$get_job_limit_name

?? TITLE := '  [XDCL] jmp$default_job_resource_hndlr', EJECT ??

  PROCEDURE [XDCL] jmp$default_job_resource_hndlr
    (    complete_condition: pmt$condition;
     VAR status: ost$status);

{ PURPOSE:
{
{   This is the default job resource condition handler.
{
{ DESIGN:
{
{   If this is a batch job, JMP$LOGOUT is called to terminate the job.
{
{
{   If this is an interactive job, the condition handler displays information
{ about the limit that has been hit to the user and then prompts the user to
{ enter an integer increment that will be added to the current accumulator value
{ to arrive at a new job warning limit value for the limit.  If the user does
{ not want the job to continue, LOGOUT may be entered in response to the prompt,
{ and the JMP$LOGOUT is called to terminate the job.
{
{   The job will not be allowed to continue unless the user enters an increment
{ that will increase the job warning limit value for the limit that has been
{ hit.


    VAR
      condition: jmt$job_resource_condition,
      condition_status: ost$status,
      error_conditions: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
            [pmc$condition_combination, $pmt$condition_combination
            [jmc$job_resource_condition, ifc$interactive_condition, pmc$pit_condition]],
      established_descriptor: pmt$established_handler,
      ignored_status: ost$status,
      job_mode: jmt$job_mode,
      limit_name: ost$name;

?? NEWTITLE := '    condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_description: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignored_status: ost$status,
        message_status: ost$status;

      IF condition.selector = ifc$interactive_condition THEN
        CASE condition.interactive_condition OF
        = ifc$pause_break =
          osp$set_status_abnormal ('JM', jme$pause_break_ignored, '', message_status);
          osp$generate_output_message (message_status, ignored_status);

        = ifc$terminate_break =
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_abnormal ('JM', jme$terminate_break_ignored, '', message_status);
          osp$generate_output_message (message_status, ignored_status);

        = ifc$job_reconnect =
          osp$set_status_abnormal ('JM', jme$job_reconnected, '', message_status);
          osp$generate_output_message (message_status, ignored_status);

        ELSE

{do nothing

        CASEND;
      IFEND;

    PROCEND condition_handler;

?? TITLE := '    default_interactive_handler', EJECT ??

    PROCEDURE default_interactive_handler
      (    condition: jmt$job_resource_condition;
       VAR status: ost$status);

      VAR
        overlimit_handled: boolean,
        condition_handled: boolean,
        file_id: amt$file_identifier,
        ignored_status: ost$status,
        input_line: ost$string,
        limit_name: ost$name;

?? TITLE := '      display_limit_information', EJECT ??

      PROCEDURE display_limit_information
        (    limit_name: ost$name;
         VAR status: ost$status);

        VAR
          limit_information: sft$limit,
          message_status: ost$status;

        status.normal := TRUE;
        overlimit_handled := FALSE;

        sfp$get_job_limit (limit_name, limit_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        osp$set_status_abnormal ('JM', jme$resource_condition, limit_name, message_status);
        osp$generate_output_message (message_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        osp$set_status_abnormal ('JM', jme$current_accumulator_is, '', message_status);
        osp$append_status_integer (osc$status_parameter_delimiter, limit_information.accumulator, 10, FALSE,
              message_status);
        osp$generate_output_message (message_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF limit_information.job_abort_limit <> sfc$unlimited THEN
          osp$set_status_abnormal ('JM', jme$maximum_limit_is, '', message_status);
          osp$append_status_integer (osc$status_parameter_delimiter, limit_information.job_abort_limit, 10,
                FALSE, message_status);

          IF limit_information.job_abort_limit < limit_information.accumulator THEN
            overlimit_handled := TRUE;
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal ('JM', jme$maximum_limit_is, 'UNLIMITED', message_status);
        IFEND;
        osp$generate_output_message (message_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      PROCEND display_limit_information;

?? TITLE := '      display_range_message', EJECT ??

      PROCEDURE display_range_message
        (    limit_name: ost$name;
         VAR status: ost$status);

        VAR
          limit_information: sft$limit,
          message_status: ost$status;

        status.normal := TRUE;

        sfp$get_job_limit (limit_name, limit_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        osp$set_status_abnormal ('JM', jme$increment_range, '', message_status);
        osp$append_status_integer (osc$status_parameter_delimiter, 1, 10, FALSE, message_status);
        IF limit_information.job_abort_limit = sfc$unlimited THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'UNLIMITED', message_status);
        ELSE
          osp$append_status_integer (osc$status_parameter_delimiter,
                limit_information.job_abort_limit - limit_information.accumulator, 10, FALSE, message_status);
        IFEND;
        osp$generate_output_message (message_status, status);

      PROCEND display_range_message;

?? TITLE := '      get_user_input', EJECT ??

      PROCEDURE get_user_input
        (    file_id: amt$file_identifier;
         VAR input_line: ost$string;
         VAR status: ost$status);

        VAR
          byte_address: amt$file_byte_address,
          file_position: amt$file_position,
          message_status: ost$status,
          transfer_count: amt$transfer_count,
          working_storage_area: string (osc$max_string_size);

        osp$set_status_abnormal ('JM', jme$increment_prompt, '', message_status);
        osp$generate_output_message (message_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        working_storage_area := ' ';
        amp$get_next (file_id, ^working_storage_area, osc$max_string_size, transfer_count, byte_address,
              file_position, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF transfer_count <> 0 THEN
          #TRANSLATE (osv$lower_to_upper, working_storage_area, input_line.value);
          input_line.size := clp$trimmed_string_size (input_line.value (1, transfer_count));
        ELSE
          input_line.value := ' ';
          input_line.size := 1;
        IFEND;

      PROCEND get_user_input;

?? TITLE := '      open_input_file', EJECT ??

      PROCEDURE open_input_file
        (VAR file_id: amt$file_identifier;
         VAR status: ost$status);

        VAR
          attribute_override: array [1 .. 3] of fst$file_cycle_attribute,
          file_attachment: array [1 .. 3] of fst$attachment_option;

        file_attachment [1].selector := fsc$access_and_share_modes;
        file_attachment [1].access_modes.selector := fsc$specific_access_modes;
        file_attachment [1].access_modes.value := $fst$file_access_options [fsc$read];
        file_attachment [1].share_modes.selector := fsc$specific_share_modes;
        file_attachment [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
        file_attachment [2].selector := fsc$open_share_modes;
        file_attachment [2].open_share_modes := $fst$file_access_options [fsc$read, fsc$execute];
        file_attachment [3].selector := fsc$create_file;
        file_attachment [3].create_file := FALSE;

        attribute_override [1].selector := fsc$block_type;
        attribute_override [1].block_type := amc$system_specified;
        attribute_override [2].selector := fsc$record_type;
        attribute_override [2].record_type := amc$undefined;
        attribute_override [3].selector := fsc$file_organization;
        attribute_override [3].file_organization := amc$sequential;

        fsp$open_file (':$LOCAL.INPUT.1', amc$record, ^file_attachment, NIL, NIL, NIL, ^attribute_override,
              file_id, status);

      PROCEND open_input_file;

?? TITLE := '      update_warning_limit', EJECT ??

      PROCEDURE update_warning_limit
        (    limit_name: ost$name;
             input_line: string ( * );
         VAR status: ost$status);

        VAR
          ignored_status: ost$status,
          increment: clt$integer,
          limit_information: sft$limit,
          new_warning_limit: sft$counter;

        status.normal := TRUE;

        sfp$get_job_limit (limit_name, limit_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF input_line = 'UNLIMITED' THEN
          new_warning_limit := sfc$unlimited;
        ELSE
          clp$convert_string_to_integer (input_line, increment, status);
          IF NOT status.normal THEN
            osp$set_status_abnormal ('JM', jme$not_integer_or_logout, input_line, status);
            osp$generate_output_message (status, ignored_status);
            RETURN;
          IFEND;
          new_warning_limit := limit_information.accumulator + increment.value;
        IFEND;

        sfp$change_job_warning_limit (limit_name, new_warning_limit, status);

      PROCEND update_warning_limit;

?? OLDTITLE, EJECT ??

      jmp$set_job_resource_condition (condition, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      sfp$get_job_limit_name (jmv$job_resource_condition, limit_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_limit_information (limit_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF NOT overlimit_handled THEN
        open_input_file (file_id, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        condition_handled := FALSE;

        REPEAT

          get_user_input (file_id, input_line, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF input_line.value = 'LOGOUT' THEN
            jmp$logout (status);
          ELSEIF (input_line.value = 'TERMINATE_COMMAND') OR (input_line.value = 'TERC') THEN
            pmp$dispose_interactive_cond (ifc$terminate_break);
            condition_handled := TRUE;
          ELSEIF (input_line.value = '?') OR (input_line.value = ' ') THEN
            display_range_message (limit_name, status);
          ELSE
            update_warning_limit (limit_name, input_line.value (1, input_line.size), status);
            IF NOT status.normal THEN
              status.normal := TRUE;
              display_range_message (limit_name, status);
            ELSE
              condition_handled := TRUE;
            IFEND;
          IFEND;
        UNTIL condition_handled OR NOT status.normal;

        fsp$close_file (file_id, ignored_status);
      IFEND;
    PROCEND default_interactive_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    ignored_status.normal := TRUE;
    condition := complete_condition.job_resource_condition;

    pmp$establish_condition_handler (error_conditions, ^condition_handler, ^established_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_job_mode (job_mode, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF condition = jmc$time_limit_condition THEN
      osp$set_status_abnormal ('JM', jme$time_limit_condition, '', condition_status);
    ELSE
      sfp$get_job_limit_name (condition, limit_name, ignored_status);
      osp$set_status_abnormal ('JM', jme$resource_condition, limit_name, condition_status);
    IFEND;

    osp$generate_log_message ($pmt$ascii_logset [pmc$system_log, pmc$job_log], condition_status,
          ignored_status);

    IF condition = jmc$time_limit_condition THEN
      clp$put_job_output (' JOB TIME LIMIT REACHED.', ignored_status);
    IFEND;

    IF job_mode = jmc$batch THEN
      jmp$logout (ignored_status);
    ELSE
      default_interactive_handler (condition, status);
      IF NOT status.normal THEN
        jmp$logout (ignored_status);
      IFEND;
    IFEND;

    pmp$disestablish_cond_handler (error_conditions, status);

  PROCEND jmp$default_job_resource_hndlr;

MODEND jmm$handle_conditions;
*DECK DECK=JMM$INITIALIZE_JOB_ENVIRONMENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE job_management initialize job environment' ??
?? NEWTITLE := '  JMM$INITIALIZE_JOB_ENVIRONMENT', EJECT ??
MODULE jmm$initialize_job_environment;

{ Purpose: This module contains the code necessary to initialize the
{          initial job environment.

?? NEWTITLE := '    Global Declarations Referenced by this Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc i#call_monitor
*copyc i#disable_traps
*copyc i#move
*copyc i#program_error
*copyc jmk$keypoints
*copyc osd$virtual_address
*copyc oss$job_pageable
*copyc oss$task_private
*copyc ost$heap
*copyc ost$status
*copyc pmc$default_user_stack_size
*copyc pmt$program_parameters
*copyc pmt$program_description
*copyc syv$nosve_job_template
*copyc syp$initialize_job_template
?? POP ??

*copyc osp$reset_heap
*copyc jmp$initialize_jcb
*copyc mmp$delete_non_inherited_segs
*copyc mmp$init_system_privilege_map
*copyc mmp$job_delete_inherited_sdt
*copyc pmp$delay
*copyc osp$system_error
*copyc osp$initialize_sc_debugger

*copyc jmv$executing_within_system_job
*copyc jmv$jcb
*copyc jmv$job_attributes
*copyc jmv$kjl_p
*copyc jmv$system_job_template_p
*copyc osv$system_privilege_map

?? TITLE := '    JMP$DELETE_NON_INHERITED_SEGS', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$delete_non_inherited_segs (VAR status: ost$status);

    mmp$delete_non_inherited_segs (status);
  PROCEND jmp$delete_non_inherited_segs;


?? TITLE := '    JMP$EXIT_JOB', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$exit_job;

    VAR
      old_trap_enable: 0 .. 3,
      status: ost$status;

{  Disable traps for the remainder of job termination.  Do not want to be interrupted by monitor flags.

    i#disable_traps (old_trap_enable);

{  Delete all inherited segments in the job environment except for those needed to exit the job.
{  Call ring 1 interface to delete remainder of the job environment.  This
{  procedure call is not expected to return.

    mmp$job_delete_inherited_sdt;

  PROCEND jmp$exit_job;


?? TITLE := '    JMP$INITIALIZE_JOB_ENVIRONMENT', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$initialize_job_environment (VAR jmtr_initial_ring: ost$ring;
    VAR jmtr_program_description_p: ^pmt$program_description;
    VAR jmtr_program_parameters_p: ^pmt$program_parameters;
    VAR status: ost$status);

    VAR
      osv$job_pageable_heap: [XDCL, oss$job_pageable] ^ost$heap,

      osv$task_private_heap: [XDCL, #GATE, oss$job_pageable] ^ost$heap,

      osv$task_shared_heap: [XDCL, #GATE, oss$job_pageable] ^ost$heap;

    VAR
      jp_seg_p: ^cell,
      ts_seg_p: ^cell,
      te: 0 .. 3,
      lfn: ost$name,
      zero_length_sequence: [oss$job_pageable] SEQ (REP 0 of cell),
      dest_pva: ^cell,
      templ_entry_p: ^jmt$job_templ_segment,
      max_segs: ost$segment,
      scan: ost$segment,
      p: ^ost$pva;

    status.normal := TRUE;

    IF NOT jmv$executing_within_system_job THEN
      { Move job templates into their respective segments.

      IF syv$nosve_job_template THEN
      max_segs := UPPERBOUND (jmv$system_job_template_p^.job_template);
      FOR scan := 1 TO max_segs DO
        templ_entry_p := ^jmv$system_job_template_p^.job_template [scan];
        IF templ_entry_p^.writeable_segment AND NOT templ_entry_p^.tasking_segment THEN
          dest_pva := #address (1, templ_entry_p^.seg_no, 0);
          i#move (templ_entry_p^.static_data_p, dest_pva, #SIZE (templ_entry_p^.static_data_p^));
        IFEND;
      FOREND;
      ELSE
        syp$initialize_job_template (FALSE, NIL);
        osp$initialize_sc_debugger;
      IFEND;
    ELSE

      { This code is entered once per deadstart.  Make the call to initialize
      { the system privilege bit map. This call goes to ring 1.

      mmp$init_system_privilege_map (#offset(#loc(osv$system_privilege_map)));

    IFEND;

{ CAUTION: The following check is to assure that the job scheduler has
{          notified queued files that this job has been initiated.
{          Presumably, this should never loop!?  Do NOT remove unless
{          timing window has been removed.  See also the note in
{          JMM$QUEUE_FILE_SCHED_INTERFACES dealing with the relink.

    WHILE jmv$kjl_p^ [jmv$jcb.job_id].entry_kind <> jmc$kjl_initiated_entry DO
      pmp$delay (100, status);
      IF NOT status.normal THEN
        i#program_error;
      IFEND;
    WHILEND;

{ Initialize the Job Control Block

    jmp$initialize_jcb;

{ Set up job Pageable and task shared heaps.

    osp$reset_heap (osv$job_pageable_heap, 100000000, TRUE, 1);
    osp$reset_heap (osv$task_shared_heap, 100000000, TRUE, 1);

{ Build packet of job monitor information needed for task manager.

    jmtr_program_description_p := ^zero_length_sequence;
    jmtr_program_parameters_p := ^zero_length_sequence;
    jmtr_initial_ring := osc$user_ring;

  PROCEND jmp$initialize_job_environment;


?? TITLE := '    JMP$SYSTEM_ERROR', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$system_error (error_message: string ( * );
        status: ^ost$status);

    osp$system_error (error_message, status);
  PROCEND jmp$system_error;
MODEND jmm$initialize_job_environment;
*DECK DECK=JMM$INITIALIZE_JOB_TABLES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management initialize job tables' ??
MODULE jmm$initialize_job_tables;

{ PURPOSE:
{   This module contains the code to initialize the tables
{   that are local to ring 1 of the job structure.
{
{ DESIGN:
{   The procedures in this module execute in ring one and are
{   callable from ring 3.  The primary data object that is modified is
{   the job control block.

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_attributes
*copyc jmt$job_system_label
*copyc ost$status
*copyc pmt$sense_switches
?? POP ??
*copyc jmp$get_ijle_p
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_pseudo_mainframe_id

*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc jmv$job_class_table_p
*copyc jmv$kjl_p
*copyc jmv$kjlx_p
*copyc jmv$known_job_list
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$initialize_jcb', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$initialize_jcb;

    VAR
      global_task_id: ost$global_task_id,
      kjl_index: jmt$kjl_index;

    kjl_index := jmv$jcb.job_id;

{ Initialize fields in the Job Control Block (JCB).

    pmp$get_executing_task_gtid (global_task_id);
    jmv$jcb.system_name := jmv$kjl_p^ [kjl_index].system_job_name;
    jmv$jcb.jobname := jmv$kjl_p^ [kjl_index].user_job_name;
    jmv$jcb.user_id := jmv$kjlx_p^ [kjl_index].login_user_identification;
    jmv$jcb.job_monitor_id := global_task_id;
    jmv$jcb.ijle_p^.job_mode := jmv$kjlx_p^ [kjl_index].job_mode;
    IF jmv$kjl_p^ [kjl_index].server_index = jmc$kjl_server_undefined THEN
      pmp$get_pseudo_mainframe_id (jmv$jcb.server_mainframe_id);
    ELSE
      jmv$jcb.server_mainframe_id := jmv$known_job_list.server_data.
            state_data [jmv$kjl_p^ [kjl_index].server_index].mainframe_id;
    IFEND;
    jmv$jcb.sense_switches := $pmt$sense_switches [];
    jmv$jcb.perm_file_job_warning_limit := sfc$unlimited;
    jmv$jcb.perm_file_job_warning_checking := FALSE;
    jmv$jcb.perm_file_job_maximum_limit := sfc$unlimited;
    jmv$jcb.temp_file_job_warning_limit := sfc$unlimited;
    jmv$jcb.temp_file_job_warning_checking := FALSE;
    jmv$jcb.temp_file_job_maximum_limit := sfc$unlimited;

    jmv$jcb.account_project_specified := FALSE;
  PROCEND jmp$initialize_jcb;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$initialize_job_local_tables', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$initialize_job_local_tables
    (    system_label_p: ^jmt$job_system_label;
     VAR status: ost$status);

    VAR
      job_class: jmt$job_class,
      maximum_working_set: jmt$working_set_size;

    status.normal := TRUE;

{ A NIL system label pointer implies the system job.

    IF system_label_p = NIL THEN
      jmv$jcb.ijle_p^.queue_file_information.job_abort_disposition := jmc$terminate_on_abort;
      jmv$jcb.ijle_p^.queue_file_information.job_recovery_disposition := jmc$terminate_on_recovery;
      jmv$jcb.ijle_p^.queue_file_information.input_file_location := jmc$ifl_no_input_file_exists;
    ELSE

{ Set interactive jobs to unrecoverable.  They are set to the requested JAD and JRD
{ in the procedure qfp$set_interactive_jrd_jad.

      IF system_label_p^.job_mode <> jmc$batch THEN
        jmv$jcb.ijle_p^.queue_file_information.job_abort_disposition := jmc$terminate_on_abort;
        jmv$jcb.ijle_p^.queue_file_information.job_recovery_disposition := jmc$terminate_on_recovery;
      ELSE
        jmv$jcb.ijle_p^.queue_file_information.job_abort_disposition := system_label_p^.job_abort_disposition;
        jmv$jcb.ijle_p^.queue_file_information.job_recovery_disposition :=
              system_label_p^.job_recovery_disposition;
      IFEND;
      jmv$jcb.ijle_p^.queue_file_information.input_file_location :=
            jmv$kjlx_p^ [jmv$jcb.job_id].input_file_location;

{ Assign the maximum working set to the job that was requested at job submission.
{ Restrict the value assigned to the maximum working set range defined for the job class.

      job_class := jmv$kjl_p^ [jmv$jcb.job_id].job_class;
      maximum_working_set := system_label_p^.limit_information.maximum_working_set_assigned;
      IF maximum_working_set < jmv$job_class_table_p^ [job_class].maximum_working_set.minimum THEN
        maximum_working_set := jmv$job_class_table_p^ [job_class].maximum_working_set.minimum;
      ELSEIF maximum_working_set > jmv$job_class_table_p^ [job_class].maximum_working_set.maximum THEN
        maximum_working_set := jmv$job_class_table_p^ [job_class].maximum_working_set.maximum;
      IFEND;
      jmv$jcb.max_working_set_size := maximum_working_set;
    IFEND;
  PROCEND jmp$initialize_job_local_tables;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$manage_sense_switches', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$manage_sense_switches
    (    ON: pmt$sense_switches;
         OFF: pmt$sense_switches);

    jmv$jcb.sense_switches := jmv$jcb.sense_switches + ON;
    jmv$jcb.sense_switches := jmv$jcb.sense_switches - OFF;
  PROCEND jmp$manage_sense_switches;
?? OLDTITLE ??
MODEND jmm$initialize_job_tables;
*DECK DECK=JMM$INITIAL_ENTRY_POINTS EXPAND=TRUE
?? RIGHT := 110 ??
*copy OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE JOB MANAGEMENT INITIAL ENTRY POINTS' ??
MODULE jmm$initial_entry_points;
?? EJECT ??
?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??

*copyc OST$STATUS
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$CALLER_IDENTIFIER
?? EJECT ??
?? TITLE := 'PROCEDURES REFERENCED BY THIS MODULE' ??

*copyc JMP$JOB_SCHEDULER_MONITOR
?? EJECT ??
?? TITLE := 'VARIABLES REFERENCED BY THIS MODULE' ??
?? EJECT ??
?? TITLE := 'JMP$JOB_SCHEDULER_ENTRY_POINT' ??

  PROCEDURE [XDCL, #GATE] jmp$job_scheduler_entry_point;

    VAR
      id: ost$caller_identifier;


    #caller_id ( id);
    IF id.ring > osc$tsrv_ring THEN
      RETURN;
    ELSE

      jmp$job_scheduler_monitor;

    IFEND;

  PROCEND jmp$job_scheduler_entry_point;
?? EJECT ??
?? OLDTITLE ??
MODEND jmm$initial_entry_points;
*DECK DECK=JMM$JOB_ATTRIBUTE_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Job Management Job Attribute Interfaces' ??
MODULE jmm$job_attribute_manager;

{ PURPOSE:
{   This module contains the job attribute management interfaces.  These interfaces control job attributes
{ as well as the system's job attribute defaults.
{
{ DESIGN:
{   The program interfaces contained in this module are designed in such a fashion that binary
{ compatability can be maintained.  Any change to the size of a record element in a variant record
{ will result in an interface breakage.  These procedures operate in rings 2 and 3 with a call bracket
{ of ring 13.
{
{   This module contains procedures to change and retrieve job attributes.  The change interfaces make
{ a local copy of their caller supplied inputs, validate them for accuracy and call a lower ring interface
{ to change the attributes.  The attribute retrieval interface uses its ring 3 privilege to gain access to
{ the values that it needs.  Since it executes in rings 2 or 3, it has access to all system variables - this
{ allows this interface to directly reference the attribute requested, irrespective of its residency.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ave$validation_interface_errors
*copyc clc$standard_file_names
*copyc cld$value
*copyc cle$ecc_lexical
*copyc jmc$change_attribute_defaults
*copyc jmc$change_job_attributes
*copyc jmc$get_attribute_defaults
*copyc jmc$get_job_attributes
*copyc jmc$job_management_id
*copyc jme$job_monitor_conditions
*copyc jme$queued_file_conditions
*copyc jmk$keypoints
*copyc jmt$default_attribute_changes
*copyc jmt$default_attribute_results
*copyc jmt$dispatching_control
*copyc jmt$job_attribute_changes
*copyc jmt$job_attribute_results
*copyc jmt$job_processing_phase
*copyc jmt$sense_switch_signal
*copyc ofe$error_codes
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc ost$name
*copyc ost$status
*copyc tmc$signal_identifiers
*copyc tmt$change_priority_origin
?? POP ??

*copyc avp$configuration_administrator
*copyc avp$system_operator
*copyc clp$convert_string_to_file_ref
*copyc clp$get_processing_phase
*copyc clp$validate_name
*copyc jmp$convert_string_to_disp_pr
*copyc jmp$determine_dis_priority_name
*copyc jmp$determine_job_class_name
*copyc jmp$determine_name_kind
*copyc jmp$general_purpose_cluster_rpc
*copyc jmp$get_attribute_name
*copyc jmp$get_ijle_p
*copyc jmp$get_job_ijl_ordinal
*copyc jmp$get_job_internal_info
*copyc jmp$get_job_status
*copyc jmp$get_result_size
*copyc jmp$queue_operator_request
*copyc jmp$set_job_attributes
*copyc jmp$system_job
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$get_job_names
*copyc pmp$get_os_version
*copyc pmp$get_170_os_type
*copyc pmp$manage_sense_switches
*copyc pmp$send_signal
*copyc qfp$change_attribute_defaults
*copyc avv$account_name
*copyc avv$project_name
*copyc jmv$default_job_attributes
*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc jmv$job_attributes
*copyc jmv$job_class_table_p
*copyc jmv$job_execution_attributes
*copyc jmv$kjl_p
*copyc jmv$kjlx_p
*copyc jmv$service_classes
*copyc jmv$system_ijl_ordinal
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    job_processing_phase_mask: [STATIC, READ, oss$job_paged_literal] array [clt$processing_phase] of
          jmt$job_processing_phase := [jmc$jpp_job_begin_phase, jmc$jpp_system_prolog_phase,
          jmc$jpp_class_prolog_phase, jmc$jpp_account_prolog_phase, jmc$jpp_project_prolog_phase,
          jmc$jpp_member_prolog_phase, jmc$jpp_user_prolog_phase, jmc$jpp_command_phase,
          jmc$jpp_user_epilog_phase, jmc$jpp_member_epilog_phase, jmc$jpp_project_epilog_phase,
          jmc$jpp_account_epilog_phase, jmc$jpp_class_epilog_phase, jmc$jpp_system_epilog_phase,
          jmc$jpp_job_end_phase];

?? TITLE := 'jmp$change_attribute_defaults', EJECT ??
*copy jmh$change_attribute_defaults

  PROCEDURE [XDCL, #GATE] jmp$change_attribute_defaults
    (    job_mode: jmt$job_mode;
         default_attribute_changes: ^jmt$default_attribute_changes;
     VAR status: ost$status);

    VAR
      job_qualifier_index: 1 .. jmc$maximum_job_qualifiers,
      local_status: ost$status,
      option_index: integer,
      scl_name: ost$name,
      valid_attribute_changes_p: ^jmt$default_attribute_changes,
      valid_job_mode: jmt$job_mode,
      valid_name: boolean;

    #KEYPOINT (osk$entry, 0, jmk$change_attribute_defaults);
    status.normal := TRUE;
    local_status.normal := TRUE;

    IF NOT avp$configuration_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      #KEYPOINT (osk$exit, 0, jmk$change_attribute_defaults);
      RETURN;
    IFEND;

    IF job_mode = jmc$batch THEN
      valid_job_mode := jmc$batch;
    ELSE
      valid_job_mode := jmc$interactive_connected;
    IFEND;

    IF default_attribute_changes <> NIL THEN
      PUSH valid_attribute_changes_p: [1 .. UPPERBOUND (default_attribute_changes^)];

    /validate_attribute_changes/
      FOR option_index := 1 TO UPPERBOUND (valid_attribute_changes_p^) DO
        valid_attribute_changes_p^ [option_index].key := default_attribute_changes^ [option_index].key;
        CASE default_attribute_changes^ [option_index].key OF
        = jmc$cpu_time_limit =
          valid_attribute_changes_p^ [option_index].cpu_time_limit :=
                default_attribute_changes^ [option_index].cpu_time_limit;

        = jmc$job_abort_disposition =
          valid_attribute_changes_p^ [option_index].job_abort_disposition :=
                default_attribute_changes^ [option_index].job_abort_disposition;

        = jmc$job_class =
          clp$validate_name (default_attribute_changes^ [option_index].job_class, scl_name, valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name,
                  default_attribute_changes^ [option_index].job_class, local_status);
            EXIT /validate_attribute_changes/;
          IFEND;
          valid_attribute_changes_p^ [option_index].job_class := scl_name;

        = jmc$job_deferred_by_operator =
          valid_attribute_changes_p^ [option_index].job_deferred_by_operator :=
                default_attribute_changes^ [option_index].job_deferred_by_operator;

        = jmc$job_destination_usage =
          clp$validate_name (default_attribute_changes^ [option_index].job_destination_usage, scl_name,
                valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name,
                  default_attribute_changes^ [option_index].job_destination_usage, local_status);
            EXIT /validate_attribute_changes/;
          IFEND;
          valid_attribute_changes_p^ [option_index].job_destination_usage := scl_name;

        = jmc$job_qualifier_list =
          PUSH valid_attribute_changes_p^ [option_index].job_qualifier_list:
                [1 .. jmc$maximum_job_qualifiers];
          FOR job_qualifier_index := 1 TO jmc$maximum_job_qualifiers DO
            IF (default_attribute_changes^ [option_index].job_qualifier_list <> NIL) AND
                  (UPPERBOUND (default_attribute_changes^ [option_index].job_qualifier_list^) >=
                  job_qualifier_index) THEN
              IF default_attribute_changes^ [option_index].job_qualifier_list^ [job_qualifier_index] =
                    osc$null_name THEN
                scl_name := osc$null_name;
              ELSE
                clp$validate_name (default_attribute_changes^ [option_index].
                      job_qualifier_list^ [job_qualifier_index], scl_name, valid_name);
                IF NOT valid_name THEN
                  osp$set_status_abnormal ('CL', cle$improper_name,
                        default_attribute_changes^ [option_index].job_qualifier_list^ [job_qualifier_index],
                        local_status);
                  EXIT /validate_attribute_changes/;
                IFEND;
              IFEND;
              valid_attribute_changes_p^ [option_index].job_qualifier_list^ [job_qualifier_index] := scl_name;
            ELSE
              valid_attribute_changes_p^ [option_index].job_qualifier_list^ [job_qualifier_index] :=
                    osc$null_name;
            IFEND;
          FOREND;

        = jmc$job_recovery_disposition =
          valid_attribute_changes_p^ [option_index].job_recovery_disposition :=
                default_attribute_changes^ [option_index].job_recovery_disposition;

        = jmc$login_family =
          clp$validate_name (default_attribute_changes^ [option_index].login_family, scl_name, valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name,
                  default_attribute_changes^ [option_index].login_family, local_status);
            EXIT /validate_attribute_changes/;
          IFEND;
          valid_attribute_changes_p^ [option_index].login_family := scl_name;

        = jmc$magnetic_tape_limit =
          valid_attribute_changes_p^ [option_index].magnetic_tape_limit :=
                default_attribute_changes^ [option_index].magnetic_tape_limit;

        = jmc$maximum_working_set =
          valid_attribute_changes_p^ [option_index].maximum_working_set :=
                default_attribute_changes^ [option_index].maximum_working_set;

        = jmc$null_attribute =
          ;

        = jmc$output_class =
          clp$validate_name (default_attribute_changes^ [option_index].output_class, scl_name, valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name,
                  default_attribute_changes^ [option_index].output_class, local_status);
            EXIT /validate_attribute_changes/;
          IFEND;
          valid_attribute_changes_p^ [option_index].output_class := scl_name;

        = jmc$output_deferred_by_operator =
          valid_attribute_changes_p^ [option_index].output_deferred_by_operator :=
                default_attribute_changes^ [option_index].output_deferred_by_operator;

        = jmc$output_destination_usage =
          clp$validate_name (default_attribute_changes^ [option_index].output_destination_usage, scl_name,
                valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name,
                  default_attribute_changes^ [option_index].output_destination_usage, local_status);
            EXIT /validate_attribute_changes/;
          IFEND;
          valid_attribute_changes_p^ [option_index].output_destination_usage := scl_name;

        = jmc$purge_delay =
          PUSH valid_attribute_changes_p^ [option_index].purge_delay;
          valid_attribute_changes_p^ [option_index].purge_delay^ :=
                default_attribute_changes^ [option_index].purge_delay^;

        = jmc$site_information =
          PUSH valid_attribute_changes_p^ [option_index].site_information;
          valid_attribute_changes_p^ [option_index].site_information^ :=
                default_attribute_changes^ [option_index].site_information^;

        = jmc$sru_limit =
          valid_attribute_changes_p^ [option_index].sru_limit :=
                default_attribute_changes^ [option_index].sru_limit;

        = jmc$station =
          clp$validate_name (default_attribute_changes^ [option_index].station, scl_name, valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name,
                  default_attribute_changes^ [option_index].station, local_status);
            EXIT /validate_attribute_changes/;
          IFEND;
          valid_attribute_changes_p^ [option_index].station := scl_name;

        = jmc$vertical_print_density =
          valid_attribute_changes_p^ [option_index].vertical_print_density :=
                default_attribute_changes^ [option_index].vertical_print_density;
        ELSE
          jmp$get_attribute_name (default_attribute_changes^ [option_index].key, scl_name);
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, local_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'DEFAULT_ATTRIBUTE_CHANGES',
                local_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$change_attribute_defaults,
                local_status);
          EXIT /validate_attribute_changes/;
        CASEND;
      FOREND /validate_attribute_changes/;
    ELSE

      valid_attribute_changes_p := NIL;
    IFEND;

    IF local_status.normal AND (valid_attribute_changes_p <> NIL) THEN
      qfp$change_attribute_defaults (valid_job_mode, valid_attribute_changes_p, local_status);
    IFEND;
    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, jmk$change_attribute_defaults);
  PROCEND jmp$change_attribute_defaults;
?? TITLE := 'jmp$change_job_attributes', EJECT ??
*copyc jmh$change_job_attributes

{
{ NOTES:
{   The use of DISPATCHING_PRIORITY for the system job has been disabled.
{   For the System Job the follow attributes are not bound to the range specified by the minimum and maximum
{   of the system_job_class attributes:      CYCLIC_AGING_INTERVAL
{                                            MAXIMUM_WORKING_SET
{                                            MINIMUM_WORKING_SET
{                                            PAGE_AGING_INTERVAL
{

  PROCEDURE [XDCL, #GATE] jmp$change_job_attributes
    (    job_attribute_changes: ^jmt$job_attribute_changes;
     VAR status: ost$status);

    TYPE
      processing_phase_set = set of clt$processing_phase;

    VAR
      attribute_index: integer,
      attribute_value: integer,
      dummy_priority: jmt$dispatching_priority,
      local_status: ost$status,
      job_class: jmt$job_class,
      maximum_working_set: jmt$working_set_size,
      minimum_working_set: jmt$working_set_size,
      parsed_file_reference: fst$parsed_file_reference,
      processing_phase: clt$processing_phase,
      scl_name: ost$name,
      service_class: jmt$service_class_index,
      valid_attribute_changes_p: ^jmt$job_attribute_changes,
      valid_name: boolean;

    #KEYPOINT (osk$entry, 0, jmk$change_job_attributes);
    status.normal := TRUE;
    local_status.normal := TRUE;

    job_class := jmv$kjl_p^ [jmv$jcb.job_id].job_class;
    maximum_working_set := jmv$job_execution_attributes.maximum_working_set;
    minimum_working_set := jmv$job_execution_attributes.minimum_working_set;
    service_class := jmv$job_class_table_p^ [job_class].initial_service_class_index;

    IF job_attribute_changes <> NIL THEN
      PUSH valid_attribute_changes_p: [1 .. UPPERBOUND (job_attribute_changes^)];

    /validate_attribute_changes/
      FOR attribute_index := 1 TO UPPERBOUND (valid_attribute_changes_p^) DO
        valid_attribute_changes_p^ [attribute_index].key := job_attribute_changes^ [attribute_index].key;
        CASE job_attribute_changes^ [attribute_index].key OF
        = jmc$comment_banner =
          valid_attribute_changes_p^ [attribute_index].comment_banner :=
                job_attribute_changes^ [attribute_index].comment_banner;

        = jmc$copies =
          valid_attribute_changes_p^ [attribute_index].copies :=
                job_attribute_changes^ [attribute_index].copies;

        = jmc$cyclic_aging_interval =
          attribute_value := job_attribute_changes^ [attribute_index].cyclic_aging_interval;

{JSE: This will need to change when job scheduling enhancements are done.

          IF NOT (jmp$system_job ()) THEN {The SYSTEM JOB is not bound by the "system" job class attributes
            IF (jmv$job_class_table_p^ [job_class].cyclic_aging_interval.minimum > attribute_value) OR
                  (jmv$job_class_table_p^ [job_class].cyclic_aging_interval.maximum < attribute_value) THEN
              osp$set_status_abnormal (jmc$job_management_id, jme$value_out_of_range, 'CYCLIC_AGING_INTERVAL',
                    local_status);
              EXIT /validate_attribute_changes/;
            IFEND;
          IFEND;
          valid_attribute_changes_p^ [attribute_index].cyclic_aging_interval := attribute_value;

        = jmc$detached_job_wait_time =
          attribute_value := job_attribute_changes^ [attribute_index].detached_job_wait_time;

{JSE: This will need to change when job scheduling enhancements are done.

          IF (jmv$job_class_table_p^ [job_class].detached_job_wait_time.minimum > attribute_value) OR
                (jmv$job_class_table_p^ [job_class].detached_job_wait_time.maximum < attribute_value) THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$value_out_of_range, 'DETACHED_JOB_WAIT_TIME',
                  local_status);
            EXIT /validate_attribute_changes/;
          IFEND;
          valid_attribute_changes_p^ [attribute_index].detached_job_wait_time := attribute_value;

        = jmc$device =
          IF job_attribute_changes^ [attribute_index].device <> osc$null_name THEN
            clp$validate_name (job_attribute_changes^ [attribute_index].device, scl_name, valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_attribute_changes^ [attribute_index].device, local_status);
              EXIT /validate_attribute_changes/;
            IFEND;
          ELSE
            scl_name := osc$null_name;
          IFEND;
          valid_attribute_changes_p^ [attribute_index].device := scl_name;

        = jmc$dispatching_priority =
          IF jmp$system_job () THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$illegal_system_job_command,
                  'Specifying DISPATCHING_PRIORITY for the CHANGE_JOB_ATTRIBUTES', local_status);
            EXIT /validate_attribute_changes/;
          ELSE
            jmp$convert_string_to_disp_pr (job_attribute_changes^ [attribute_index].dispatching_priority,
                  dummy_priority, local_status); {Check for valid priority values.
            IF NOT local_status.normal THEN
              EXIT /validate_attribute_changes/;
            IFEND;
            clp$validate_name (job_attribute_changes^ [attribute_index].dispatching_priority, scl_name,
                  valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_attribute_changes^ [attribute_index].dispatching_priority, local_status);
              EXIT /validate_attribute_changes/;
            IFEND;
            valid_attribute_changes_p^ [attribute_index].dispatching_priority := scl_name;
          IFEND;

        = jmc$earliest_print_time =
          valid_attribute_changes_p^ [attribute_index].earliest_print_time :=
                job_attribute_changes^ [attribute_index].earliest_print_time;

        = jmc$external_characteristics =
          #TRANSLATE (osv$lower_to_upper, job_attribute_changes^ [attribute_index].external_characteristics,
                valid_attribute_changes_p^ [attribute_index].external_characteristics);

        = jmc$forms_code =
          #TRANSLATE (osv$lower_to_upper, job_attribute_changes^ [attribute_index].forms_code,
                valid_attribute_changes_p^ [attribute_index].forms_code);

        = jmc$job_abort_disposition =
          valid_attribute_changes_p^ [attribute_index].job_abort_disposition :=
                job_attribute_changes^ [attribute_index].job_abort_disposition;

        = jmc$job_recovery_disposition =
          valid_attribute_changes_p^ [attribute_index].job_recovery_disposition :=
                job_attribute_changes^ [attribute_index].job_recovery_disposition;

        = jmc$latest_print_time =
          valid_attribute_changes_p^ [attribute_index].latest_print_time :=
                job_attribute_changes^ [attribute_index].latest_print_time;

        = jmc$maximum_working_set =
          maximum_working_set := job_attribute_changes^ [attribute_index].maximum_working_set;

{JSE: This will need to change when job scheduling enhancements are done.

          IF NOT (jmp$system_job ()) THEN {The SYSTEM JOB is not bound by the "system" job class attributes
            IF (jmv$job_class_table_p^ [job_class].maximum_working_set.minimum > maximum_working_set) OR
                  (jmv$job_class_table_p^ [job_class].maximum_working_set.maximum < maximum_working_set) THEN
              osp$set_status_abnormal (jmc$job_management_id, jme$value_out_of_range, 'MAXIMUM_WORKING_SET',
                    local_status);
              EXIT /validate_attribute_changes/;
            IFEND;
          IFEND;
          valid_attribute_changes_p^ [attribute_index].maximum_working_set := maximum_working_set;

        = jmc$minimum_working_set =
          minimum_working_set := job_attribute_changes^ [attribute_index].minimum_working_set;

{JSE: This will need to change when job scheduling enhancements are done.

          IF NOT (jmp$system_job ()) THEN {The SYSTEM JOB is not bound by the "system" job class attributes
            IF (jmv$job_class_table_p^ [job_class].minimum_working_set.minimum > minimum_working_set) OR
                  (jmv$job_class_table_p^ [job_class].minimum_working_set.maximum < minimum_working_set) THEN
              osp$set_status_abnormal (jmc$job_management_id, jme$value_out_of_range, 'MINIMUM_WORKING_SET',
                    local_status);
              EXIT /validate_attribute_changes/;
            IFEND;
          IFEND;
          valid_attribute_changes_p^ [attribute_index].minimum_working_set := minimum_working_set;

        = jmc$null_attribute =
          ;

        = jmc$output_class =
          IF job_attribute_changes^ [attribute_index].output_class <> osc$null_name THEN
            clp$validate_name (job_attribute_changes^ [attribute_index].output_class, scl_name, valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_attribute_changes^ [attribute_index].output_class, local_status);
              EXIT /validate_attribute_changes/;
            IFEND;
          ELSE
            scl_name := osc$null_name;
          IFEND;
          valid_attribute_changes_p^ [attribute_index].output_class := scl_name;

        = jmc$output_deferred_by_user =
          valid_attribute_changes_p^ [attribute_index].output_deferred_by_user :=
                job_attribute_changes^ [attribute_index].output_deferred_by_user;

        = jmc$output_destination =
          #TRANSLATE (osv$lower_to_upper, job_attribute_changes^ [attribute_index].output_destination,
                valid_attribute_changes_p^ [attribute_index].output_destination);

        = jmc$output_destination_family =
          clp$validate_name (job_attribute_changes^ [attribute_index].output_destination_family, scl_name,
                valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name,
                  job_attribute_changes^ [attribute_index].output_destination_family, local_status);
            EXIT /validate_attribute_changes/;
          IFEND;
          valid_attribute_changes_p^ [attribute_index].output_destination_family := scl_name;

        = jmc$output_destination_usage =
          clp$validate_name (job_attribute_changes^ [attribute_index].output_destination_usage, scl_name,
                valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name,
                  job_attribute_changes^ [attribute_index].output_destination_usage, local_status);
            EXIT /validate_attribute_changes/;
          IFEND;
          valid_attribute_changes_p^ [attribute_index].output_destination_usage := scl_name;

        = jmc$output_disposition =
          valid_attribute_changes_p^ [attribute_index].output_disposition :=
                job_attribute_changes^ [attribute_index].output_disposition;
          IF (valid_attribute_changes_p^ [attribute_index].output_disposition.key = jmc$standard_output_path)
                THEN
            clp$convert_string_to_file_ref (job_attribute_changes^ [attribute_index].output_disposition.
                  standard_output_path^, parsed_file_reference, local_status);
            IF NOT local_status.normal THEN
              EXIT /validate_attribute_changes/;
            IFEND;

            IF parsed_file_reference.path (parsed_file_reference.first_name.index,
                  parsed_file_reference.first_name.size) = '$LOCAL' THEN
              osp$set_status_condition (jme$permanent_file_required, local_status);
              EXIT /validate_attribute_changes/;
            IFEND;

            PUSH valid_attribute_changes_p^ [attribute_index].output_disposition.standard_output_path;
            valid_attribute_changes_p^ [attribute_index].output_disposition.standard_output_path^ :=
                  parsed_file_reference.path (1, parsed_file_reference.complete_path_size);
          IFEND;

        = jmc$output_priority =
          IF job_attribute_changes^ [attribute_index].output_priority <> osc$null_name THEN
            clp$validate_name (job_attribute_changes^ [attribute_index].output_priority, scl_name,
                  valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_attribute_changes^ [attribute_index].output_priority, local_status);
              EXIT /validate_attribute_changes/;
            IFEND;
          ELSE
            scl_name := osc$null_name;
          IFEND;
          valid_attribute_changes_p^ [attribute_index].output_priority := scl_name;

        = jmc$page_aging_interval =
          attribute_value := job_attribute_changes^ [attribute_index].page_aging_interval;

{JSE: This will need to change when job scheduling enhancements are done.

          IF NOT (jmp$system_job ()) THEN {The SYSTEM JOB is not bound by the "system" job class attributes
            IF (jmv$job_class_table_p^ [job_class].page_aging_interval.minimum > attribute_value) OR
                  (jmv$job_class_table_p^ [job_class].page_aging_interval.maximum < attribute_value) THEN
              osp$set_status_abnormal (jmc$job_management_id, jme$value_out_of_range, 'PAGE_AGING_INTERVAL',
                    local_status);
              EXIT /validate_attribute_changes/;
            IFEND;
          IFEND;
          valid_attribute_changes_p^ [attribute_index].page_aging_interval := attribute_value;

        = jmc$purge_delay =
          PUSH valid_attribute_changes_p^ [attribute_index].purge_delay;
          valid_attribute_changes_p^ [attribute_index].purge_delay^ :=
                job_attribute_changes^ [attribute_index].purge_delay^;

        = jmc$remote_host_directive =
          PUSH valid_attribute_changes_p^ [attribute_index].remote_host_directive;
          valid_attribute_changes_p^ [attribute_index].remote_host_directive^ :=
                job_attribute_changes^ [attribute_index].remote_host_directive^;

        = jmc$routing_banner =
          valid_attribute_changes_p^ [attribute_index].routing_banner :=
                job_attribute_changes^ [attribute_index].routing_banner;

        = jmc$site_information =
          clp$get_processing_phase (processing_phase, {ignore} local_status);
          IF processing_phase IN $processing_phase_set [clc$system_prolog_phase, clc$class_prolog_phase,
                clc$account_prolog_phase, clc$project_prolog_phase, clc$project_epilog_phase,
                clc$account_epilog_phase, clc$class_epilog_phase, clc$system_epilog_phase] THEN
            PUSH valid_attribute_changes_p^ [attribute_index].site_information;
            valid_attribute_changes_p^ [attribute_index].site_information^ :=
                  job_attribute_changes^ [attribute_index].site_information^;
          ELSE
            osp$set_status_condition (ave$insufficient_authority, local_status);
            EXIT /validate_attribute_changes/;
          IFEND;

        = jmc$station =
          IF job_attribute_changes^ [attribute_index].station <> osc$null_name THEN
            clp$validate_name (job_attribute_changes^ [attribute_index].station, scl_name, valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_attribute_changes^ [attribute_index].station, local_status);
              EXIT /validate_attribute_changes/;
            IFEND;
          ELSE
            scl_name := osc$null_name;
          IFEND;
          valid_attribute_changes_p^ [attribute_index].station := scl_name;

        = jmc$station_operator =
          clp$validate_name (job_attribute_changes^ [attribute_index].station_operator, scl_name, valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name,
                  job_attribute_changes^ [attribute_index].station_operator, local_status);
            EXIT /validate_attribute_changes/;
          IFEND;
          valid_attribute_changes_p^ [attribute_index].station_operator := scl_name;

        = jmc$user_information =
          PUSH valid_attribute_changes_p^ [attribute_index].user_information;
          valid_attribute_changes_p^ [attribute_index].user_information^ :=
                job_attribute_changes^ [attribute_index].user_information^;

        = jmc$vertical_print_density =
          valid_attribute_changes_p^ [attribute_index].vertical_print_density :=
                job_attribute_changes^ [attribute_index].vertical_print_density;

        = jmc$vfu_load_procedure =
          IF job_attribute_changes^ [attribute_index].vfu_load_procedure <> osc$null_name THEN
            clp$validate_name (job_attribute_changes^ [attribute_index].vfu_load_procedure, scl_name,
                  valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_attribute_changes^ [attribute_index].vfu_load_procedure, local_status);
              EXIT /validate_attribute_changes/;
            IFEND;
          ELSE
            scl_name := osc$null_name;
          IFEND;
          valid_attribute_changes_p^ [attribute_index].vfu_load_procedure := scl_name;

        ELSE
          jmp$get_attribute_name (job_attribute_changes^ [attribute_index].key, scl_name);
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, local_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'JOB_ATTRIBUTE_CHANGES', local_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$change_job_attributes,
                local_status);
          EXIT /validate_attribute_changes/;

        CASEND;
      FOREND /validate_attribute_changes/;

{ Check to make sure that the working set sizes are compatible

      IF local_status.normal AND (minimum_working_set > maximum_working_set) THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$invalid_working_set_size, '', local_status);
      IFEND;

      IF local_status.normal THEN
        jmp$set_job_attributes (valid_attribute_changes_p, local_status);
      IFEND;
    IFEND;
    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, jmk$change_job_attributes);
  PROCEND jmp$change_job_attributes;

?? TITLE := 'JMP$CHANGE_DISPATCHING_PRIORITY', EJECT ??

{
{ NOTE:
{   This command is illegal for the system_job.
{

  PROCEDURE [XDCL, #GATE] jmp$change_dispatching_priority
    (    job_name: clt$value;
         dispatching_priority: jmt$dispatching_priority;
     VAR status: ost$status);

    VAR
      ijl_ordinal: jmt$ijl_ordinal,
      privileged_job: boolean,
      system_supplied_name: jmt$system_supplied_name;

    status.normal := TRUE;
    privileged_job := avp$system_operator ();

    IF NOT privileged_job THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_operation', status);
      RETURN;
    IFEND;

    jmp$get_job_ijl_ordinal (job_name.name.value, privileged_job, ijl_ordinal, system_supplied_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (ijl_ordinal = jmv$system_ijl_ordinal) THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$illegal_system_job_command,
            'CHANGE_PRIORITY job_name = $AAA_0000', status);
    ELSE
      jmp$queue_operator_request (jmc$or_change_dispatching_prio, ijl_ordinal, system_supplied_name,
            dispatching_priority, {disable_recovery} FALSE, status);
    IFEND;
  PROCEND jmp$change_dispatching_priority;
?? TITLE := 'jmp$get_attribute_defaults', EJECT ??
*copyc jmh$get_attribute_defaults

  PROCEDURE [XDCL, #GATE] jmp$get_attribute_defaults
    (    job_mode: jmt$job_mode;
         default_attribute_results: ^jmt$default_attribute_results;
     VAR status: ost$status);

    VAR
      attribute_index: integer,
      job_qualifier_index: integer,
      scl_name: ost$name,
      valid_job_mode: jmt$job_mode;

    #KEYPOINT (osk$entry, 0, jmk$get_attribute_defaults);
    status.normal := TRUE;

    IF job_mode = jmc$batch THEN
      valid_job_mode := jmc$batch;
    ELSE
      valid_job_mode := jmc$interactive_connected;
    IFEND;
    IF default_attribute_results <> NIL THEN

    /assign_requested_attributes/
      FOR attribute_index := 1 TO UPPERBOUND (default_attribute_results^) DO
        CASE default_attribute_results^ [attribute_index].key OF
        = jmc$cpu_time_limit =
          default_attribute_results^ [attribute_index].cpu_time_limit :=
                jmv$default_job_attributes [valid_job_mode].cpu_time_limit;

        = jmc$job_abort_disposition =
          default_attribute_results^ [attribute_index].job_abort_disposition :=
                jmv$default_job_attributes [valid_job_mode].job_abort_disposition;

        = jmc$job_deferred_by_operator =
          default_attribute_results^ [attribute_index].job_deferred_by_operator :=
                jmv$default_job_attributes [valid_job_mode].job_deferred_by_operator;

        = jmc$job_class =
          default_attribute_results^ [attribute_index].job_class :=
                jmv$default_job_attributes [valid_job_mode].job_class;

        = jmc$job_destination_usage =
          default_attribute_results^ [attribute_index].job_destination_usage :=
                jmv$default_job_attributes [valid_job_mode].job_destination_usage;

        = jmc$job_qualifier_list =
          IF default_attribute_results^ [attribute_index].job_qualifier_list <> NIL THEN
            FOR job_qualifier_index := 1 TO UPPERBOUND (default_attribute_results^ [attribute_index].
                  job_qualifier_list^) DO
              IF job_qualifier_index <= jmc$maximum_job_qualifiers THEN
                default_attribute_results^ [attribute_index].job_qualifier_list^ [job_qualifier_index] :=
                      jmv$default_job_attributes [valid_job_mode].job_qualifier_list [job_qualifier_index];
              ELSE
                default_attribute_results^ [attribute_index].job_qualifier_list^ [job_qualifier_index] :=
                      osc$null_name;
              IFEND;
            FOREND;
          IFEND;

        = jmc$job_recovery_disposition =
          default_attribute_results^ [attribute_index].job_recovery_disposition :=
                jmv$default_job_attributes [valid_job_mode].job_recovery_disposition;

        = jmc$login_family =
          default_attribute_results^ [attribute_index].login_family :=
                jmv$default_job_attributes [valid_job_mode].login_family;

        = jmc$magnetic_tape_limit =
          default_attribute_results^ [attribute_index].magnetic_tape_limit :=
                jmv$default_job_attributes [valid_job_mode].magnetic_tape_limit;

        = jmc$maximum_working_set =
          default_attribute_results^ [attribute_index].maximum_working_set :=
                jmv$default_job_attributes [valid_job_mode].maximum_working_set;

        = jmc$null_attribute =
          ;

        = jmc$output_class =
          default_attribute_results^ [attribute_index].output_class :=
                jmv$default_job_attributes [valid_job_mode].output_class;

        = jmc$output_deferred_by_operator =
          default_attribute_results^ [attribute_index].output_deferred_by_operator :=
                jmv$default_job_attributes [valid_job_mode].output_deferred_by_operator;

        = jmc$output_destination_usage =
          default_attribute_results^ [attribute_index].output_destination_usage :=
                jmv$default_job_attributes [valid_job_mode].output_destination_usage;

        = jmc$purge_delay =
          default_attribute_results^ [attribute_index].purge_delay^ :=
                jmv$default_job_attributes [valid_job_mode].purge_delay;

        = jmc$site_information =
          default_attribute_results^ [attribute_index].site_information^ :=
                jmv$default_job_attributes [valid_job_mode].site_information;

        = jmc$sru_limit =
          default_attribute_results^ [attribute_index].sru_limit :=
                jmv$default_job_attributes [valid_job_mode].sru_limit;

        = jmc$station =
          default_attribute_results^ [attribute_index].station :=
                jmv$default_job_attributes [valid_job_mode].station;

        = jmc$vertical_print_density =
          default_attribute_results^ [attribute_index].vertical_print_density :=
                jmv$default_job_attributes [valid_job_mode].vertical_print_density;
        ELSE
          jmp$get_attribute_name (default_attribute_results^ [attribute_index].key, scl_name);
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'DEFAULT_ATTRIBUTE_RESULTS', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$get_attribute_defaults, status);
          EXIT /assign_requested_attributes/;
        CASEND;
      FOREND /assign_requested_attributes/;
    IFEND;
    #KEYPOINT (osk$exit, 0, jmk$get_attribute_defaults);
  PROCEND jmp$get_attribute_defaults;
?? TITLE := 'jmp$get_job_attributes', EJECT ??
*copyc jmh$get_job_attributes

  PROCEDURE [XDCL, #GATE] jmp$get_job_attributes
    (    job_attribute_results: ^jmt$job_attribute_results;
     VAR status: ost$status);

    VAR
      attribute_index: integer,
      ignore_status: ost$status,
      ijl_entry_p: ^jmt$initiated_job_list_entry,
      job_qualifier_index: integer,
      processing_phase: clt$processing_phase,
      scl_name: ost$name;

    #KEYPOINT (osk$entry, 0, jmk$get_job_attributes);
    status.normal := TRUE;
    ignore_status.normal := TRUE;

    IF job_attribute_results <> NIL THEN

    /assign_requested_attributes/
      FOR attribute_index := 1 TO UPPERBOUND (job_attribute_results^) DO
        CASE job_attribute_results^ [attribute_index].key OF
        = jmc$c170_os_type =
          pmp$get_170_os_type (job_attribute_results^ [attribute_index].c170_os_type, ignore_status);

        = jmc$comment_banner =
          job_attribute_results^ [attribute_index].comment_banner := jmv$job_attributes.comment_banner;

        = jmc$control_family =
          job_attribute_results^ [attribute_index].control_family := jmv$job_attributes.job_controller.family;

        = jmc$control_user =
          job_attribute_results^ [attribute_index].control_user := jmv$job_attributes.job_controller.user;

        = jmc$copies =
          job_attribute_results^ [attribute_index].copies := jmv$job_attributes.copy_count;

        = jmc$cyclic_aging_interval =
          job_attribute_results^ [attribute_index].cyclic_aging_interval :=
                jmv$job_execution_attributes.cyclic_aging_interval;

        = jmc$detached_job_wait_time =
          job_attribute_results^ [attribute_index].detached_job_wait_time := jmv$jcb.detached_job_wait_time;

        = jmc$device =
          job_attribute_results^ [attribute_index].device := jmv$job_attributes.device;

        = jmc$dispatching_priority =
          jmp$determine_dis_priority_name (jmv$jcb.ijle_p^.dispatching_control.dispatching_priority,
                job_attribute_results^ [attribute_index].dispatching_priority, ignore_status);

        = jmc$earliest_print_time =
          job_attribute_results^ [attribute_index].earliest_print_time :=
                jmv$job_attributes.earliest_print_time;

        = jmc$earliest_run_time =
          job_attribute_results^ [attribute_index].earliest_run_time := jmv$job_attributes.earliest_run_time;

        = jmc$external_characteristics =
          job_attribute_results^ [attribute_index].external_characteristics :=
                jmv$job_attributes.external_characteristics;

        = jmc$forms_code =
          job_attribute_results^ [attribute_index].forms_code := jmv$job_attributes.forms_code;

        = jmc$job_abort_disposition =
          jmp$get_ijle_p (jmv$kjl_p^ [jmv$jcb.job_id].initiated_job_list_ordinal, ijl_entry_p);
          job_attribute_results^ [attribute_index].job_abort_disposition :=
                ijl_entry_p^.queue_file_information.job_abort_disposition;

        = jmc$job_class =
          jmp$determine_job_class_name (jmv$kjl_p^ [jmv$jcb.job_id].
                job_class, job_attribute_results^ [attribute_index].job_class, ignore_status);

        = jmc$job_input_device =
          job_attribute_results^ [attribute_index].job_input_device^ := jmv$job_attributes.job_input_device;

        = jmc$job_mode =
          job_attribute_results^ [attribute_index].job_mode := jmv$jcb.ijle_p^.job_mode;

        = jmc$job_qualifier_list =
          IF job_attribute_results^ [attribute_index].job_qualifier_list <> NIL THEN
            FOR job_qualifier_index := 1 TO UPPERBOUND (job_attribute_results^ [attribute_index].
                  job_qualifier_list^) DO
              IF job_qualifier_index <= jmc$maximum_job_qualifiers THEN
                job_attribute_results^ [attribute_index].job_qualifier_list^ [job_qualifier_index] :=
                      jmv$job_attributes.job_qualifier_list [job_qualifier_index];
              ELSE
                job_attribute_results^ [attribute_index].job_qualifier_list^ [job_qualifier_index] :=
                      osc$null_name;
              IFEND;
            FOREND;
          IFEND;

        = jmc$job_recovery_disposition =
          jmp$get_ijle_p (jmv$kjl_p^ [jmv$jcb.job_id].initiated_job_list_ordinal, ijl_entry_p);
          job_attribute_results^ [attribute_index].job_recovery_disposition :=
                ijl_entry_p^.queue_file_information.job_recovery_disposition;

        = jmc$job_size =
          job_attribute_results^ [attribute_index].job_size := jmv$job_attributes.job_size;

        = jmc$job_submission_time =
          job_attribute_results^ [attribute_index].job_submission_time :=
                jmv$job_attributes.job_submission_time;

        = jmc$latest_print_time =
          job_attribute_results^ [attribute_index].latest_print_time := jmv$job_attributes.latest_print_time;

        = jmc$latest_run_time =
          job_attribute_results^ [attribute_index].latest_run_time := jmv$job_attributes.latest_run_time;

        = jmc$login_account =
          job_attribute_results^ [attribute_index].login_account := avv$account_name;

        = jmc$login_family =
          job_attribute_results^ [attribute_index].login_family := jmv$jcb.user_id.family;

        = jmc$login_project =
          job_attribute_results^ [attribute_index].login_project := avv$project_name;

        = jmc$login_user =
          job_attribute_results^ [attribute_index].login_user := jmv$jcb.user_id.user;

        = jmc$maximum_working_set =
          job_attribute_results^ [attribute_index].maximum_working_set :=
                jmv$job_execution_attributes.maximum_working_set;

        = jmc$minimum_working_set =
          job_attribute_results^ [attribute_index].minimum_working_set :=
                jmv$job_execution_attributes.minimum_working_set;

        = jmc$null_attribute =
          ;

        = jmc$operator_job =
          job_attribute_results^ [attribute_index].operator_job := jmp$system_job ();

        = jmc$origin_application_name =
          job_attribute_results^ [attribute_index].origin_application_name :=
                jmv$job_attributes.originating_application_name;

        = jmc$os_version =
          pmp$get_os_version (job_attribute_results^ [attribute_index].os_version, ignore_status);

        = jmc$output_class =
          job_attribute_results^ [attribute_index].output_class := jmv$job_attributes.output_class;

        = jmc$output_deferred_by_user =
          job_attribute_results^ [attribute_index].output_deferred_by_user :=
                jmv$job_attributes.output_deferred_by_user;

        = jmc$output_destination =
          job_attribute_results^ [attribute_index].output_destination :=
                jmv$job_attributes.output_destination;

        = jmc$output_destination_family =
          job_attribute_results^ [attribute_index].output_destination_family :=
                jmv$job_attributes.output_destination_family;

        = jmc$output_destination_usage =
          job_attribute_results^ [attribute_index].output_destination_usage :=
                jmv$job_attributes.output_destination_usage;

        = jmc$output_disposition =
          job_attribute_results^ [attribute_index].output_disposition.key :=
                jmv$kjlx_p^ [jmv$jcb.job_id].output_disposition_key;
          IF jmv$kjlx_p^ [jmv$jcb.job_id].output_disposition_key = jmc$standard_output_path THEN
            job_attribute_results^ [attribute_index].output_disposition.standard_output_path^ :=
                  jmv$job_attributes.output_disposition_path;
          IFEND;

        = jmc$output_priority =
          job_attribute_results^ [attribute_index].output_priority := jmv$job_attributes.output_priority;

        = jmc$page_aging_interval =
          job_attribute_results^ [attribute_index].page_aging_interval :=
                jmv$job_execution_attributes.page_aging_interval;

        = jmc$processing_phase =
          clp$get_processing_phase (processing_phase, ignore_status);
          job_attribute_results^ [attribute_index].processing_phase :=
                job_processing_phase_mask [processing_phase];

        = jmc$purge_delay =
          job_attribute_results^ [attribute_index].purge_delay^ := jmv$job_attributes.purge_delay;

        = jmc$remote_host_directive =
          job_attribute_results^ [attribute_index].remote_host_directive^ :=
                jmv$job_attributes.remote_host_directive;

        = jmc$routing_banner =
          job_attribute_results^ [attribute_index].routing_banner := jmv$job_attributes.routing_banner;

        = jmc$sense_switches =
          job_attribute_results^ [attribute_index].sense_switches := jmv$jcb.sense_switches;

        = jmc$service_class =
          jmp$get_ijle_p (jmv$kjl_p^ [jmv$jcb.job_id].initiated_job_list_ordinal, ijl_entry_p);
          job_attribute_results^ [attribute_index].service_class :=
                jmv$service_classes [ijl_entry_p^.job_scheduler_data.service_class]^.attributes.name;

        = jmc$site_information =
          job_attribute_results^ [attribute_index].site_information^ := jmv$job_attributes.site_information;

        = jmc$station =
          job_attribute_results^ [attribute_index].station := jmv$job_attributes.station;

        = jmc$station_operator =
          job_attribute_results^ [attribute_index].station_operator := jmv$job_attributes.station_operator;

        = jmc$system_job =
          job_attribute_results^ [attribute_index].system_job := jmp$system_job ();

        = jmc$system_job_name =
          job_attribute_results^ [attribute_index].system_job_name := jmv$jcb.system_name;

        = jmc$user_information =
          job_attribute_results^ [attribute_index].user_information^ := jmv$job_attributes.user_information;

        = jmc$user_job_name =
          job_attribute_results^ [attribute_index].user_job_name := jmv$jcb.jobname;

        = jmc$vertical_print_density =
          job_attribute_results^ [attribute_index].vertical_print_density :=
                jmv$job_attributes.vertical_print_density;

        = jmc$vfu_load_procedure =
          job_attribute_results^ [attribute_index].vfu_load_procedure :=
                jmv$job_attributes.vfu_load_procedure;

        ELSE
          jmp$get_attribute_name (job_attribute_results^ [attribute_index].key, scl_name);
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'JOB_ATTRIBUTES_RESULTS', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$get_job_attributes, status);
          EXIT /assign_requested_attributes/;

        CASEND;
      FOREND /assign_requested_attributes/;
    IFEND;
    #KEYPOINT (osk$exit, 0, jmk$get_job_attributes);
  PROCEND jmp$get_job_attributes;


?? TITLE := '    JMP$GET_JOB_PARAMETERS', EJECT ??

  PROCEDURE [XDCL] jmp$get_job_parameters
    (VAR job_parameters: jmt$system_job_parameters;
     VAR status: ost$status);

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, jmk$get_job_parameters);

    job_parameters := jmv$job_attributes.system_job_parameters;
    #KEYPOINT (osk$exit, 0, jmk$get_job_parameters);
  PROCEND jmp$get_job_parameters;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$switch_command_r3', EJECT ??
*copyc jmh$switch_command_r3

  PROCEDURE [XDCL, #GATE] jmp$switch_command_r3
    (    name: string ( * <= osc$max_name_size);
         ON: pmt$sense_switches;
         OFF: pmt$sense_switches;
     VAR status: ost$status);

    VAR
      caller_ssn: jmt$system_supplied_name,
      caller_ujn: jmt$user_supplied_name,
      converted_name: jmt$name,
      jm_work_area_p: ^jmt$work_area,
      job_info: jmt$job_internal_information,
      job_status_results_keys_p: ^jmt$results_keys,
      job_status_results_seq_p: ^jmt$work_area,
      job_status_options_p: ^jmt$job_status_options,
      job_status_results_p: ^jmt$job_status_results,
      local_off_switches_p: ^pmt$sense_switches,
      local_on_switches_p: ^pmt$sense_switches,
      local_system_job_name_p: ^jmt$system_supplied_name,
      mainframes_processed: jmt$rpc_mainframes_processed,
      number_of_data_packets: ost$non_negative_integers,
      number_of_jobs_found: jmt$job_count_range,
      privileged_job: boolean,
      results: pmt$sense_switches,
      size_of_sequence: ost$segment_length,
      target_mainframe_reached: boolean,
      target_options_p: ^SEQ ( * );

    status.normal := TRUE;

    #KEYPOINT (osk$entry, 0, jmk$switch_command_r3);

    privileged_job := avp$system_operator ();
    jmp$determine_name_kind (name, converted_name, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$switch_command_r3);
      RETURN;
    IFEND;

    PUSH job_status_options_p: [1 .. 3];
    job_status_options_p^ [1].key := jmc$name_list;
    PUSH job_status_options_p^ [1].name_list: [1 .. 1];
    job_status_options_p^ [1].name_list^ [1] := converted_name;
    job_status_options_p^ [2].key := jmc$privilege;
    IF privileged_job THEN
      job_status_options_p^ [2].privilege := jmc$privileged;
    ELSE
      job_status_options_p^ [2].privilege := jmc$not_privileged;
    IFEND;
    job_status_options_p^ [3].key := jmc$continue_request_to_servers;
    job_status_options_p^ [3].continue_request_to_servers := TRUE;

    PUSH job_status_results_keys_p: [1 .. 2];
    job_status_results_keys_p^ [1] := jmc$system_job_name;
    job_status_results_keys_p^ [2] := jmc$client_mainframe_id;

    jmp$get_result_size ({number_of_jobs} 1, #SEQ (job_status_results_keys_p^), size_of_sequence);
    PUSH job_status_results_seq_p: [[REP size_of_sequence OF cell]];

{ If we are able to status the input file, we have control over the file
{ so we can change the attributes of the file

    jmp$get_job_status (job_status_options_p, job_status_results_keys_p, job_status_results_seq_p,
          job_status_results_p, number_of_jobs_found, status);
    IF number_of_jobs_found = 0 THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, name, status);
    ELSEIF number_of_jobs_found > 1 THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_name, name, status);
    IFEND;
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$switch_command_r3);
      RETURN;
    IFEND;

    pmp$get_job_names (caller_ujn, caller_ssn, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$switch_command_r3);
      RETURN;
    IFEND;

    IF job_status_results_p^ [1]^ [1].system_job_name = caller_ssn THEN
      pmp$manage_sense_switches (ON, OFF, results, status);
    ELSE

{ Set the sense switches in the job by using the general purpose cluster RPC request.

      PUSH target_options_p: [[REP (#SIZE (jmt$system_supplied_name) + #SIZE (pmt$sense_switches) +
            #SIZE (pmt$sense_switches)) OF cell]];
      RESET target_options_p;
      NEXT local_system_job_name_p IN target_options_p;
      local_system_job_name_p^ := job_status_results_p^ [1]^ [1].system_job_name;
      NEXT local_on_switches_p IN target_options_p;
      local_on_switches_p^ := ON;
      NEXT local_off_switches_p IN target_options_p;
      local_off_switches_p^ := OFF;
      mainframes_processed.count := 0;
      jm_work_area_p := NIL;

      jmp$general_purpose_cluster_rpc (job_status_results_p^ [1]^ [2].client_mainframe_id,
            jmc$gpro_set_sense_switches, {data_packet_size} 0, mainframes_processed, target_options_p,
            jm_work_area_p, target_mainframe_reached, mainframes_processed, number_of_data_packets, status);
    IFEND;

    #KEYPOINT (osk$exit, 0, jmk$switch_command_r3);
  PROCEND jmp$switch_command_r3;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$mainframe_set_sense_switch', EJECT ??
*copy jmh$mainframe_set_sense_switch

  PROCEDURE [XDCL] jmp$mainframe_set_sense_switch
    (    target_options_p: ^SEQ ( * );
     VAR data_area_p: {input, output} ^SEQ ( * );
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      job_info: jmt$job_internal_information,
      local_off_switches_p: ^pmt$sense_switches,
      local_on_switches_p: ^pmt$sense_switches,
      local_system_job_name_p: ^jmt$system_supplied_name,
      options_p: ^SEQ ( * ),
      signal: pmt$signal,
      signal_contents_p: ^jmt$sense_switch_signal;

    status.normal := TRUE;
    number_of_data_packets := 0;
    options_p := target_options_p;
    RESET options_p;
    NEXT local_system_job_name_p IN options_p;
    NEXT local_on_switches_p IN options_p;
    NEXT local_off_switches_p IN options_p;
    jmp$get_job_internal_info (local_system_job_name_p^, job_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    signal.identifier := jmc$sense_switch_signal_id;
    signal_contents_p := #LOC (signal.contents);
    signal_contents_p^. ON := local_on_switches_p^;
    signal_contents_p^. OFF := local_off_switches_p^;
    pmp$send_signal (job_info.jmtr_global_taskid, signal, status);
  PROCEND jmp$mainframe_set_sense_switch;
?? OLDTITLE ??
MODEND jmm$job_attribute_manager;
*DECK DECK=JMM$JOB_CLASS_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : Job Class Commands' ??
MODULE jmm$job_class_commands;

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$file
*copyc CLD$VALUE
*copyc CLE$ECC_MISCELLANEOUS
*copyc oss$job_paged_literal
*copyc jmc$job_management_id
*copyc JME$JOB_SCHEDULER_CONDITIONS
*copyc CLE$ECC_PARAMETER_LIST
*copyc jmt$dispatching_priority
*copyc jmt$job_class
*copyc jmt$job_class_set
*copyc jmt$job_counts
*copyc JMC$MAXIMUM_CONSTANTS
*copyc OST$STATUS
?? POP ??

*copyc CLP$SCAN_PARAMETER_LIST
*copyc CLP$GET_VALUE
*copyc CLP$SCAN_PARAMETER_LIST
*copyc jmp$determine_job_class
*copyc jmp$set_job_class_limits
*copyc osp$set_status_abnormal
*copyc osp$verify_system_privilege
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    priority_table: [STATIC, READ, oss$job_paged_literal] array [1 .. 15] of record
      dispatching_priority: jmt$dispatching_priority,
      name: string (7),
    recend := [[jmc$null_dispatching_priority, 'DEFAULT'], [jmc$priority_p1, 'P1     '],
          [jmc$priority_p2, 'P2     '], [jmc$priority_p3, 'P3     '], [jmc$priority_p4, 'P4     '],
          [jmc$priority_p5, 'P5     '], [jmc$priority_p6, 'P6     '], [jmc$priority_p7, 'P7     '],
          [jmc$priority_p8, 'P8     '], [jmc$priority_p9, 'P9     '], [jmc$priority_p10, 'P10    '],
          [jmc$priority_p11, 'P11    '], [jmc$priority_p12, 'P12    '], [jmc$priority_p13, 'P13    '],
          [jmc$priority_p14, 'P14    ']];


?? TITLE := '    CLP$SET_JOB_CLASS_LIMIT_COMMAND', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$set_job_class_limit_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PDT set_job_class_limits_pdt (
{        job_class, jc : LIST OF NAME = all
{        number, n : INTEGER 0 .. jmc$maximum_job_count = 0
{        status)

?? PUSH (LISTEXT := ON) ??

    VAR
      set_job_class_limits_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^set_job_class_limits_pdt_names, ^set_job_class_limits_pdt_params];

    VAR
      set_job_class_limits_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
            clt$parameter_name_descriptor := [['JOB_CLASS', 1], ['JC', 1], ['NUMBER', 2], ['N', 2],
            ['STATUS', 3]];

    VAR
      set_job_class_limits_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
            clt$parameter_descriptor := [

{ JOB_CLASS JC }
      [[clc$optional_with_default, ^set_job_class_limits_pdt_dv1], 1, clc$max_value_sets, 1, 1,
            clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ NUMBER N }
      [[clc$optional_with_default, ^set_job_class_limits_pdt_dv2], 1, 1, 1, 1,
            clc$value_range_not_allowed, [NIL, clc$integer_value, 0, jmc$maximum_job_count]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      set_job_class_limits_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

    VAR
      set_job_class_limits_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

?? POP ??

    VAR
      selected_job_class: jmt$job_class_set,
      job_class: jmt$job_class,
      max_jobs: 0 .. jmc$max_ijl_ord,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, set_job_class_limits_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_value ('JOB_CLASS', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.name.value = 'ALL' THEN
      selected_job_class := (-$jmt$job_class_set []) - $jmt$job_class_set [jmc$system_job_class];
    ELSE
      jmp$determine_job_class (value.name.value, job_class, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      selected_job_class := $jmt$job_class_set [job_class];
    IFEND;

    clp$get_value ('NUMBER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    max_jobs := value.int.value;
    jmp$set_job_class_limits (selected_job_class, max_jobs, status);

  PROCEND clp$set_job_class_limit_command;
?? TITLE := '[XDCL] jmp$change_class_attr_cmnd', EJECT ??

{ PURPOSE:
{   The purpose of this request is to change the attributes of the job and
{   serrvice class tables.
{ NOTES:
{   This request is retained for compatibility.  It is replaced functionally by
{   commands under the ADMINISTER_SCHEDULING and MANAGE_ACTIVE_SCHEDULING utilities.

  PROCEDURE [XDCL] jmp$change_class_attr_cmnd
    (    param_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT chaca_pdt (
{ class_name, cn: LIST OF NAME = all
{ name, n: NAME
{ abbreviation, a: NAME
{ prolog, p: STRING
{ epilog, e: STRING
{ mode, m: KEY all, batch, b, interactive, i
{ immediate_initiation_candidate, iic: BOOLEAN
{ page_aging_interval, pai: LIST 1..2 RANGE OF INTEGER 1000..3600000000
{ cyclic_aging_interval, cai: LIST 1..2 RANGE OF INTEGER 1000..3600000000
{ min_working_set, minws: LIST 1..2 RANGE OF INTEGER 20..65535
{ max_working_set, maxws: LIST 1..2 RANGE OF INTEGER 20..65535
{ dispatching_control, dc: LIST 1..5, 4 OF ANY
{ dispatching_priority, dp : LIST 1..2 RANGE OF NAME
{ dispatching_timeslice, dt, dispatching_timeslice_time, dtt: LIST 2 OF INTEGER 1000..10000000
{ detached_job_wait_time, djwt: LIST 1..2 RANGE OF INTEGER 0..65535
{ cpu_time_limit, ctl: INTEGER 1000000..0ffffffffff(16)
{ low_priority,lp: INTEGER 0..16000000
{ high_priority,hp: INTEGER 0..16000000
{ initial_priority,ip: INTEGER 0..16000000
{ max_initiated_jobs,maxij: INTEGER 0..jmc$max_ijl_ord
{ max_active_jobs,maxaj: INTEGER 0..100
{ initial_working_set,iws: INTEGER 0..65535
{ memory_resource_bias,mrb: INTEGER 0..100
{ cpu_resource_bias,crb: INTEGER 0..100
{ io_resource_bias,irb: INTEGER 0..100
{ residence_resource_bias,rrb: INTEGER 0..100
{ initial_slope,is: INTEGER -10000..10000
{ initial_b,ib: INTEGER 0..10000
{ mid_slope,ms: INTEGER -10000..10000
{ mid_b,mb: INTEGER 0..10000
{ final_slope,fs: INTEGER -10000..10000
{ final_b,fb: INTEGER 0..10000
{ initial_job_phase,ijp: INTEGER 0..0ffffffffffff(16)
{ mid_job_phase,mjp: INTEGER 0..0ffffffffffff(16)
{ final_job_phase,fjp: INTEGER 0..0ffffffffffff(16)
{ class_switch_threshold,cst: INTEGER 0..0ffffffffffff(16)
{ next_class,nc: NAME
{ priority_bias,pb: INTEGER 0..10000
{ guaranteed_service,gs: INTEGER 0..0ffffffffffff(16)
{ input_age_factor,iaf: INTEGER 0..16000000
{ swap_age_factor,saf: INTEGER 0..16000000
{ swapped_priority_increment,spi: INTEGER 0..16000000
{ swapin_increment,si: INTEGER 0..16000000
{ STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    chaca_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^chaca_pdt_names, ^chaca_pdt_params
      ];

  VAR
    chaca_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 89] of
      clt$parameter_name_descriptor := [['CLASS_NAME', 1], ['CN', 1], ['NAME', 2], ['N', 2], ['ABBREVIATION',
      3], ['A', 3], ['PROLOG', 4], ['P', 4], ['EPILOG', 5], ['E', 5], ['MODE', 6], ['M', 6], [
      'IMMEDIATE_INITIATION_CANDIDATE', 7], ['IIC', 7], ['PAGE_AGING_INTERVAL', 8], ['PAI', 8], [
      'CYCLIC_AGING_INTERVAL', 9], ['CAI', 9], ['MIN_WORKING_SET', 10], ['MINWS', 10], ['MAX_WORKING_SET', 11]
      , ['MAXWS', 11], ['DISPATCHING_CONTROL', 12], ['DC', 12], ['DISPATCHING_PRIORITY', 13], ['DP', 13], [
      'DISPATCHING_TIMESLICE', 14], ['DT', 14], ['DISPATCHING_TIMESLICE_TIME', 14], ['DTT', 14], [
      'DETACHED_JOB_WAIT_TIME', 15], ['DJWT', 15], ['CPU_TIME_LIMIT', 16], ['CTL', 16], ['LOW_PRIORITY', 17],
      ['LP', 17], ['HIGH_PRIORITY', 18], ['HP', 18], ['INITIAL_PRIORITY', 19], ['IP', 19], [
      'MAX_INITIATED_JOBS', 20], ['MAXIJ', 20], ['MAX_ACTIVE_JOBS', 21], ['MAXAJ', 21], ['INITIAL_WORKING_SET'
      , 22], ['IWS', 22], ['MEMORY_RESOURCE_BIAS', 23], ['MRB', 23], ['CPU_RESOURCE_BIAS', 24], ['CRB', 24], [
      'IO_RESOURCE_BIAS', 25], ['IRB', 25], ['RESIDENCE_RESOURCE_BIAS', 26], ['RRB', 26], ['INITIAL_SLOPE', 27
      ], ['IS', 27], ['INITIAL_B', 28], ['IB', 28], ['MID_SLOPE', 29], ['MS', 29], ['MID_B', 30], ['MB', 30],
      ['FINAL_SLOPE', 31], ['FS', 31], ['FINAL_B', 32], ['FB', 32], ['INITIAL_JOB_PHASE', 33], ['IJP', 33], [
      'MID_JOB_PHASE', 34], ['MJP', 34], ['FINAL_JOB_PHASE', 35], ['FJP', 35], ['CLASS_SWITCH_THRESHOLD', 36]
      , ['CST', 36], ['NEXT_CLASS', 37], ['NC', 37], ['PRIORITY_BIAS', 38], ['PB', 38], ['GUARANTEED_SERVICE'
      , 39], ['GS', 39], ['INPUT_AGE_FACTOR', 40], ['IAF', 40], ['SWAP_AGE_FACTOR', 41], ['SAF', 41], [
      'SWAPPED_PRIORITY_INCREMENT', 42], ['SPI', 42], ['SWAPIN_INCREMENT', 43], ['SI', 43], ['STATUS', 44]];

  VAR
    chaca_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 44] of clt$parameter_descriptor := [

{ CLASS_NAME CN }
    [[clc$optional_with_default, ^chaca_pdt_dv1], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed,
      [NIL, clc$name_value, 1, osc$max_name_size]],

{ NAME N }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ ABBREVIATION A }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ PROLOG P }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, osc$max_string_size
      ]],

{ EPILOG E }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, osc$max_string_size
      ]],

{ MODE M }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [^chaca_pdt_kv6, clc$keyword_value]],

{ IMMEDIATE_INITIATION_CANDIDATE IIC }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ PAGE_AGING_INTERVAL PAI }
    [[clc$optional], 1, 2, 1, 1, clc$value_range_allowed, [NIL, clc$integer_value, 1000, 3600000000]],

{ CYCLIC_AGING_INTERVAL CAI }
    [[clc$optional], 1, 2, 1, 1, clc$value_range_allowed, [NIL, clc$integer_value, 1000, 3600000000]],

{ MIN_WORKING_SET MINWS }
    [[clc$optional], 1, 2, 1, 1, clc$value_range_allowed, [NIL, clc$integer_value, 20, 65535]],

{ MAX_WORKING_SET MAXWS }
    [[clc$optional], 1, 2, 1, 1, clc$value_range_allowed, [NIL, clc$integer_value, 20, 65535]],

{ DISPATCHING_CONTROL DC }
    [[clc$optional], 1, 5, 4, 4, clc$value_range_not_allowed, [NIL, clc$any_value]],

{ DISPATCHING_PRIORITY DP }
    [[clc$optional], 1, 2, 1, 1, clc$value_range_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ DISPATCHING_TIMESLICE DT DISPATCHING_TIMESLICE_TIME DTT }
    [[clc$optional], 2, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 1000, 10000000]],

{ DETACHED_JOB_WAIT_TIME DJWT }
    [[clc$optional], 1, 2, 1, 1, clc$value_range_allowed, [NIL, clc$integer_value, 0, 65535]],

{ CPU_TIME_LIMIT CTL }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 1000000,
      0ffffffffff(16)]],

{ LOW_PRIORITY LP }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 16000000]],

{ HIGH_PRIORITY HP }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 16000000]],

{ INITIAL_PRIORITY IP }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 16000000]],

{ MAX_INITIATED_JOBS MAXIJ }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, jmc$max_ijl_ord]],

{ MAX_ACTIVE_JOBS MAXAJ }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 100]],

{ INITIAL_WORKING_SET IWS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 65535]],

{ MEMORY_RESOURCE_BIAS MRB }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 100]],

{ CPU_RESOURCE_BIAS CRB }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 100]],

{ IO_RESOURCE_BIAS IRB }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 100]],

{ RESIDENCE_RESOURCE_BIAS RRB }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 100]],

{ INITIAL_SLOPE IS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, -10000, 10000]],

{ INITIAL_B IB }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 10000]],

{ MID_SLOPE MS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, -10000, 10000]],

{ MID_B MB }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 10000]],

{ FINAL_SLOPE FS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, -10000, 10000]],

{ FINAL_B FB }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 10000]],

{ INITIAL_JOB_PHASE IJP }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffffffffff(16)]],

{ MID_JOB_PHASE MJP }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffffffffff(16)]],

{ FINAL_JOB_PHASE FJP }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffffffffff(16)]],

{ CLASS_SWITCH_THRESHOLD CST }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffffffffff(16)]],

{ NEXT_CLASS NC }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ PRIORITY_BIAS PB }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 10000]],

{ GUARANTEED_SERVICE GS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffffffffff(16)]],

{ INPUT_AGE_FACTOR IAF }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 16000000]],

{ SWAP_AGE_FACTOR SAF }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 16000000]],

{ SWAPPED_PRIORITY_INCREMENT SPI }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 16000000]],

{ SWAPIN_INCREMENT SI }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 16000000]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    chaca_pdt_kv6: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of ost$name := ['ALL','BATCH','B'
      ,'INTERACTIVE','I'];

  VAR
    chaca_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

?? POP ??

    clp$scan_parameter_list (param_list, chaca_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Issue a warning message stating that this command has been replaced by
{ the ADMINISTER_SCHEDULING and MANAGE_ACTIVE_SCHEDULING utilities.

    osp$set_status_abnormal (jmc$job_management_id, jme$use_adms_or_manas_utility, '', status);

  PROCEND jmp$change_class_attr_cmnd;
?? TITLE := 'JMP$CONVERT_DISP_PR_TO_STRING', EJECT ??

  PROCEDURE [XDCL] jmp$convert_disp_pr_to_string
    (    dispatching_priority: jmt$dispatching_priority;
     VAR str: ost$string;
     VAR status: ost$status);

    VAR
      i: integer;

    osp$verify_system_privilege;
    status.normal := TRUE;
    FOR i := LOWERBOUND (priority_table) TO UPPERBOUND (priority_table) DO
      IF priority_table [i].dispatching_priority = dispatching_priority THEN
        str.value := priority_table [i].name;
        str.size := 3;
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal ('JM', jme$invalid_dispatch_priority, ' ', status);

  PROCEND jmp$convert_disp_pr_to_string;

?? TITLE := 'JMP$CONVERT_STRING_TO_DISP_PR', EJECT ??

  PROCEDURE [XDCL] jmp$convert_string_to_disp_pr
    (    name: ost$name;
     VAR dispatching_priority: jmt$dispatching_priority;
     VAR status: ost$status);

    VAR
      i: integer;

    status.normal := TRUE;

    FOR i := LOWERBOUND (priority_table) TO UPPERBOUND (priority_table) DO
      IF priority_table [i].name = name THEN
        dispatching_priority := priority_table [i].dispatching_priority;
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal ('JM', jme$invalid_dispatch_priority, ' ', status);

  PROCEND jmp$convert_string_to_disp_pr;
?? TITLE := '[XDCL] jmp$create_job_class_command', EJECT ??

{ PURPOSE:
{   The purpose of this request is to add a new job class to the job class table
{   and a corresponding service class to the service class table.
{ NOTES:
{   This request is retained for compatibility.  It is replaced functionally by
{   commands under the ADMINISTER_SCHEDULING utility.

  PROCEDURE [XDCL] jmp$create_job_class_command
    (    param_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT crejc_pdt (
{ default_values, dv: NAME
{ index, i: INTEGER 3..255 = $REQUIRED
{ name, n: NAME = $REQUIRED
{ abbreviation, a: NAME
{ prolog, p: STRING
{ epilog, e: STRING
{ mode, m: KEY all, batch, b interactive, i = batch
{ immediate_initiation_candidate, iic: BOOLEAN
{ page_aging_interval, pai: LIST 1..2 RANGE OF INTEGER 1000..3600000000
{ cyclic_aging_interval, cai: LIST 1..2 RANGE OF INTEGER 1000..3600000000
{ min_working_set, minws: LIST 1..2 RANGE OF INTEGER 20..65535
{ max_working_set, maxws: LIST 1..2 RANGE OF INTEGER 20..65535
{ dispatching_control, dc: LIST 1..5, 4 OF ANY
{ dispatching_priority, dp: LIST 1..2 RANGE OF NAME
{ dispatching_timeslice, dt, dispatching_timeslice_time, dtt: LIST 2 OF INTEGER 1000..10000000
{ detached_job_wait_time, djwt: LIST 1..2 RANGE OF INTEGER 0..65535
{ cpu_time_limit, ctl: INTEGER 1000000..0ffffffffff(16)
{ low_priority, lp: INTEGER 0..16000000
{ high_priority, hp: INTEGER 0..16000000
{ initial_priority, ip: INTEGER 0..16000000
{ max_initiated_jobs, maxij: INTEGER 0..jmc$max_ijl_ord
{ max_active_jobs, maxaj: INTEGER 0..100
{ initial_working_set, iws: INTEGER 0..65535
{ memory_resource_bias, mrb: INTEGER 0..100
{ cpu_resource_bias, crb: INTEGER 0..100
{ io_resource_bias, irb: INTEGER 0..100
{ residence_resource_bias, rrb: INTEGER 0..100
{ initial_slope, is: INTEGER -10000..10000
{ initial_b, ib: INTEGER 0..10000
{ mid_slope, ms: INTEGER -10000..10000
{ mid_b, mb: INTEGER 0..10000
{ final_slope, fs: INTEGER -10000..10000
{ final_b, fb: INTEGER 0..10000
{ initial_job_phase, ijp: INTEGER 0..0ffffffffffff(16)
{ mid_job_phase, mjp: INTEGER 0..0ffffffffffff(16)
{ final_job_phase, fjp: INTEGER 0..0ffffffffffff(16)
{ class_switch_threshold,cst: INTEGER 0..0ffffffffffff(16)
{ next_class,nc: NAME
{ priority_bias,pb: INTEGER 0..10000
{ guaranteed_service, gs: INTEGER 0..0ffffffffffff(16)
{ input_age_factor, iaf: INTEGER 0..16000000
{ swap_age_factor, saf: INTEGER 0..16000000
{ swapped_priority_increment, spi: INTEGER 0..16000000
{ swapin_increment, si: INTEGER 0..16000000
{ STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    crejc_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^crejc_pdt_names, ^crejc_pdt_params
      ];

  VAR
    crejc_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 91] of
      clt$parameter_name_descriptor := [['DEFAULT_VALUES', 1], ['DV', 1], ['INDEX', 2], ['I', 2], ['NAME', 3]
      , ['N', 3], ['ABBREVIATION', 4], ['A', 4], ['PROLOG', 5], ['P', 5], ['EPILOG', 6], ['E', 6], ['MODE', 7]
      , ['M', 7], ['IMMEDIATE_INITIATION_CANDIDATE', 8], ['IIC', 8], ['PAGE_AGING_INTERVAL', 9], ['PAI', 9], [
      'CYCLIC_AGING_INTERVAL', 10], ['CAI', 10], ['MIN_WORKING_SET', 11], ['MINWS', 11], ['MAX_WORKING_SET',
      12], ['MAXWS', 12], ['DISPATCHING_CONTROL', 13], ['DC', 13], ['DISPATCHING_PRIORITY', 14], ['DP', 14], [
      'DISPATCHING_TIMESLICE', 15], ['DT', 15], ['DISPATCHING_TIMESLICE_TIME', 15], ['DTT', 15], [
      'DETACHED_JOB_WAIT_TIME', 16], ['DJWT', 16], ['CPU_TIME_LIMIT', 17], ['CTL', 17], ['LOW_PRIORITY', 18],
      ['LP', 18], ['HIGH_PRIORITY', 19], ['HP', 19], ['INITIAL_PRIORITY', 20], ['IP', 20], [
      'MAX_INITIATED_JOBS', 21], ['MAXIJ', 21], ['MAX_ACTIVE_JOBS', 22], ['MAXAJ', 22], ['INITIAL_WORKING_SET'
      , 23], ['IWS', 23], ['MEMORY_RESOURCE_BIAS', 24], ['MRB', 24], ['CPU_RESOURCE_BIAS', 25], ['CRB', 25], [
      'IO_RESOURCE_BIAS', 26], ['IRB', 26], ['RESIDENCE_RESOURCE_BIAS', 27], ['RRB', 27], ['INITIAL_SLOPE', 28
      ], ['IS', 28], ['INITIAL_B', 29], ['IB', 29], ['MID_SLOPE', 30], ['MS', 30], ['MID_B', 31], ['MB', 31],
      ['FINAL_SLOPE', 32], ['FS', 32], ['FINAL_B', 33], ['FB', 33], ['INITIAL_JOB_PHASE', 34], ['IJP', 34], [
      'MID_JOB_PHASE', 35], ['MJP', 35], ['FINAL_JOB_PHASE', 36], ['FJP', 36], ['CLASS_SWITCH_THRESHOLD', 37]
      , ['CST', 37], ['NEXT_CLASS', 38], ['NC', 38], ['PRIORITY_BIAS', 39], ['PB', 39], ['GUARANTEED_SERVICE'
      , 40], ['GS', 40], ['INPUT_AGE_FACTOR', 41], ['IAF', 41], ['SWAP_AGE_FACTOR', 42], ['SAF', 42], [
      'SWAPPED_PRIORITY_INCREMENT', 43], ['SPI', 43], ['SWAPIN_INCREMENT', 44], ['SI', 44], ['STATUS', 45]];

  VAR
    crejc_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 45] of clt$parameter_descriptor := [

{ DEFAULT_VALUES DV }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ INDEX I }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 3, 255]],

{ NAME N }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ ABBREVIATION A }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ PROLOG P }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, osc$max_string_size
      ]],

{ EPILOG E }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, osc$max_string_size
      ]],

{ MODE M }
    [[clc$optional_with_default, ^crejc_pdt_dv7], 1, 1, 1, 1, clc$value_range_not_allowed, [^crejc_pdt_kv7,
      clc$keyword_value]],

{ IMMEDIATE_INITIATION_CANDIDATE IIC }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ PAGE_AGING_INTERVAL PAI }
    [[clc$optional], 1, 2, 1, 1, clc$value_range_allowed, [NIL, clc$integer_value, 1000, 3600000000]],

{ CYCLIC_AGING_INTERVAL CAI }
    [[clc$optional], 1, 2, 1, 1, clc$value_range_allowed, [NIL, clc$integer_value, 1000, 3600000000]],

{ MIN_WORKING_SET MINWS }
    [[clc$optional], 1, 2, 1, 1, clc$value_range_allowed, [NIL, clc$integer_value, 20, 65535]],

{ MAX_WORKING_SET MAXWS }
    [[clc$optional], 1, 2, 1, 1, clc$value_range_allowed, [NIL, clc$integer_value, 20, 65535]],

{ DISPATCHING_CONTROL DC }
    [[clc$optional], 1, 5, 4, 4, clc$value_range_not_allowed, [NIL, clc$any_value]],

{ DISPATCHING_PRIORITY DP }
    [[clc$optional], 1, 2, 1, 1, clc$value_range_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ DISPATCHING_TIMESLICE DT DISPATCHING_TIMESLICE_TIME DTT }
    [[clc$optional], 2, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 1000, 10000000]],

{ DETACHED_JOB_WAIT_TIME DJWT }
    [[clc$optional], 1, 2, 1, 1, clc$value_range_allowed, [NIL, clc$integer_value, 0, 65535]],

{ CPU_TIME_LIMIT CTL }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 1000000,
      0ffffffffff(16)]],

{ LOW_PRIORITY LP }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 16000000]],

{ HIGH_PRIORITY HP }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 16000000]],

{ INITIAL_PRIORITY IP }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 16000000]],

{ MAX_INITIATED_JOBS MAXIJ }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, jmc$max_ijl_ord]],

{ MAX_ACTIVE_JOBS MAXAJ }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 100]],

{ INITIAL_WORKING_SET IWS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 65535]],

{ MEMORY_RESOURCE_BIAS MRB }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 100]],

{ CPU_RESOURCE_BIAS CRB }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 100]],

{ IO_RESOURCE_BIAS IRB }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 100]],

{ RESIDENCE_RESOURCE_BIAS RRB }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 100]],

{ INITIAL_SLOPE IS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, -10000, 10000]],

{ INITIAL_B IB }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 10000]],

{ MID_SLOPE MS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, -10000, 10000]],

{ MID_B MB }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 10000]],

{ FINAL_SLOPE FS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, -10000, 10000]],

{ FINAL_B FB }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 10000]],

{ INITIAL_JOB_PHASE IJP }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffffffffff(16)]],

{ MID_JOB_PHASE MJP }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffffffffff(16)]],

{ FINAL_JOB_PHASE FJP }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffffffffff(16)]],

{ CLASS_SWITCH_THRESHOLD CST }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffffffffff(16)]],

{ NEXT_CLASS NC }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ PRIORITY_BIAS PB }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 10000]],

{ GUARANTEED_SERVICE GS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffffffffff(16)]],

{ INPUT_AGE_FACTOR IAF }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 16000000]],

{ SWAP_AGE_FACTOR SAF }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 16000000]],

{ SWAPPED_PRIORITY_INCREMENT SPI }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 16000000]],

{ SWAPIN_INCREMENT SI }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 16000000]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    crejc_pdt_kv7: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of ost$name := ['ALL','BATCH','B'
      ,'INTERACTIVE','I'];

  VAR
    crejc_pdt_dv7: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'batch';

?? POP ??

    clp$scan_parameter_list (param_list, crejc_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Issue a warning message stating that this command has been replaced by
{ the ADMINISTER_SCHEDULING utility.

    osp$set_status_abnormal (jmc$job_management_id, jme$use_adms_utility, '', status);

  PROCEND jmp$create_job_class_command;
?? TITLE := '[XDCL] jmp$delete_job_class_command', EJECT ??

{ PURPOSE:
{   The purpose of this request is to delete an existing job class from the job
{   class table and its corresponding service class from the service class table.
{ NOTES:
{   This request is retained for compatibility.  It is replaced functionally by
{   commands under the ADMINISTER_SCHEDULING utility.

  PROCEDURE [XDCL] jmp$delete_job_class_command
    (    param_list: clt$parameter_list;
     VAR status: ost$status);

{
{   PDT deljc_pdt (
{   name, n: LIST OF NAME = $REQUIRED
{   STATUS)

?? PUSH (LISTEXT := ON) ??

    VAR
      deljc_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^deljc_pdt_names, ^deljc_pdt_params];

    VAR
      deljc_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['NAME', 1], ['N', 1], ['STATUS', 2]];

    VAR
      deljc_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ NAME N }
      [[clc$required], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    clp$scan_parameter_list (param_list, deljc_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Issue a warning message stating that this command has been replaced by
{ the ADMINISTER_SCHEDULING utility.

    osp$set_status_abnormal (jmc$job_management_id, jme$use_adms_utility, '', status);

  PROCEND jmp$delete_job_class_command;
?? TITLE := '[XDCL] jmp$display_class_attribute_cmd', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display the attributes of the job and
{   service class tables.
{ NOTES:
{   This request is retained for compatibility.  It is replaced functionally by
{   commands under the ADMINISTER_SCHEDULING and MANAGE_ACTIVE_SCHEDULING utilities.

  PROCEDURE [XDCL] jmp$display_class_attribute_cmd
    (    param_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT dca_pdt (
{ class,c: LIST OF NAME = all
{ output,o: FILE = $OUTPUT
{ STATUS);


    VAR
      dca_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^dca_pdt_names, ^dca_pdt_params];

    VAR
      dca_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
            clt$parameter_name_descriptor := [['CLASS', 1], ['C', 1], ['OUTPUT', 2], ['O', 2], ['STATUS', 3]];

    VAR
      dca_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ CLASS C }
      [[clc$optional_with_default, ^dca_pdt_dv1], 1, clc$max_value_sets, 1, 1,
            clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ OUTPUT O }
      [[clc$optional_with_default, ^dca_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      dca_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

    VAR
      dca_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';


    clp$scan_parameter_list (param_list, dca_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Issue a warning message stating that this command has been replaced by
{ the ADMINISTER_SCHEDULING and MANAGE_ACTIVE_SCHEDULING utilities.

    osp$set_status_abnormal (jmc$job_management_id, jme$use_adms_or_manas_utility, '', status);

  PROCEND jmp$display_class_attribute_cmd;

MODEND jmm$job_class_commands;

*DECK DECK=JMM$JOB_DEADSTART EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management: Deadstart Initialization' ??
MODULE jmm$job_deadstart;

{ PURPOSE:
{   This module contains the code to initialize the Job Management mainframe global tables
{ at system deadstart.

{ DESIGN:
{   The procedures contained in this module are used to create the ring one tables that are used by
{ the Job Management area of NOS/VE.  The tables include the Active Job List (AJL), the Initiated
{ Job List (IJL), the Known Job List (KJL), the Known Output List (KOL), the Known Qfile List (KQL),
{ and the job attribute defaults.  These tables are allocated
{ and initialized during NOS/VE deadstart.
{
{   The procedures used to initialize the NOS/VE CPU dependent names are resident in this module.  The
{ names that are CPU dependent are the mainframe id and the system supplied names assigned to NOS/VE queue
{ files.  These names are assigned as early in NOS/VE deadstart as is possible.
{
{   The procedures to save the essence of the system job as it is deadstarting reside in this module.
{ As NOS/VE deadstart progresses the Job Fixed, Job Pageable, Task Shared and Task Private segments are
{ saved at various states.  This allows other job and task initiations to initialize these segments by
{ moving the contents of the saved system segments to the their own environment.

?? NEWTITLE := '    Global Declarations Referenced by this Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc jmc$ajl_caller
*copyc jmc$class_names
*copyc jmc$default_forms_code
*copyc jmc$kjl_maximum_entries
*copyc jmc$kol_maximum_entries
*copyc jmc$maximum_qfile_count
*copyc jmc$special_dispatch_priorities
*copyc jmc$system_family
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc jmt$job_class
*copyc jmt$job_control_block
*copyc jmt$kjl_index
*copyc jmt$service_class_index
*copyc jmt$system_core_template
*copyc mmt$segment_descriptor_table
*copyc mmt$segment_descriptor_table_ex
*copyc osc$nosve_job_scheduler
*copyc osc$processor_defined_registers
*copyc osd$virtual_address
*copyc ost$execution_control_block
*copyc ost$global_task_id
*copyc ost$signature_lock
*copyc ost$status
*copyc sfc$unlimited
*copyc tmt$primary_task_list
?? POP ??
*copyc i#move
*copyc jmp$get_ijle_p
*copyc jmp$job_monitor_xcb
*copyc mmp$get_sdt_for_job_template
*copyc osp$initialize_sig_lock
*copyc osp$system_error
*copyc pmp$get_170_os_type
*copyc pmp$get_compact_date_time
*copyc pmp$get_cpu_attributes
*copyc pmp$get_pseudo_mainframe_id
*copyc pmp$initialize_cpu_attributes
*copyc pmp$zero_out_table
*copyc qfp$relink_kjl_application
*copyc qfp$relink_kjl_client
*copyc qfp$relink_kjl_entry
*copyc qfp$relink_kjl_server
*copyc jmv$ajl_p
*copyc jmv$candidate_queued_jobs
*copyc jmv$default_job_attributes
*copyc jmv$executing_within_system_job
*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc jmv$job_counts
*copyc jmv$job_counts_lock
*copyc jmv$kjl_p
*copyc jmv$kjlx_p
*copyc jmv$known_job_list
*copyc jmv$known_output_list
*copyc jmv$known_qfile_list
*copyc jmv$kol_p
*copyc jmv$kql_p
*copyc jmv$number_free_ajl_entries
*copyc jmv$system_ajl_ordinal
*copyc jmv$system_ijl_ordinal
*copyc jmv$system_job_ssn
*copyc jmv$system_supplied_name
*copyc mtv$cst0
*copyc mtv$mx_ajl_entries
*copyc mtv$xp_initial_value
*copyc osv$cpus_physically_configured
*copyc osv$job_fixed_heap
*copyc osv$mainframe_pageable_heap
*copyc osv$mainframe_wired_heap
*copyc qfv$current_kjl_limit
*copyc qfv$current_kol_limit
*copyc qfv$current_kql_limit
*copyc qfv$kjl_lock
*copyc qfv$kol_lock
*copyc qfv$kql_lock
*copyc syv$all_jobs_selected_for_debug
?? OLDTITLE ??
?? NEWTITLE := 'Global Variables Declared by this Module', EJECT ??

  VAR
    jmv$ajl_lock: [XDCL, STATIC, oss$mainframe_pageable] ost$signature_lock := [0],
    jmv$system_job_kjl_entry: [STATIC, oss$mainframe_pageable] array [1 .. 1] of jmt$known_job_list_entry,
    jmv$system_job_kjlx_entry: [STATIC, oss$mainframe_pageable] array [1 .. 1] of jmt$known_job_list_extended,
    jmv$system_core_template: [XDCL, #GATE] jmt$system_core_template;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$init_cpu_dependent_names', EJECT ??

  PROCEDURE [XDCL] jmp$init_cpu_dependent_names
    (VAR status: ost$status);

    VAR
      cpu_attributes: pmt$cpu_attributes,
      length: integer;

?? NEWTITLE := '      change_space_to_zero', EJECT ??

{ This procedure converts trailing space into leading zeros and shifts
{ the contents of the string accordingly.

    PROCEDURE change_space_to_zero
      (VAR stng: string ( * ));

      VAR
        index: integer,
        length: integer;

      length := STRLENGTH (stng);
      IF length > 0 THEN
        WHILE stng (length) = ' ' DO
          FOR index := length DOWNTO 2 DO
            stng (index) := stng (index - 1);
          FOREND;
          stng (1) := '0';
        WHILEND;
      IFEND;
    PROCEND change_space_to_zero;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    pmp$initialize_cpu_attributes;

    pmp$get_cpu_attributes (cpu_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    change_space_to_zero (cpu_attributes.cpu [0].model_number);
    change_space_to_zero (cpu_attributes.cpu [0].serial_number);

    STRINGREP (jmv$system_job_ssn, length, '$', cpu_attributes.cpu [0].
          model_number, '_', cpu_attributes.cpu [0].serial_number, '_AAA_0000');
    jmv$system_supplied_name.system_supplied_name := jmv$system_job_ssn;

  PROCEND jmp$init_cpu_dependent_names;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$initialize_job_tables', EJECT ??
*copy jmh$initialize_job_tables

  PROCEDURE [XDCL, #GATE] jmp$initialize_job_tables
    (VAR status: ost$status);

{ Choose values that give the KJL, KOL, and KQL some predefined size but do not
{ use too much at a time since the more disk space that is used here the less
{ that will be available during recovery.

    CONST
      initial_kjl_limit = 100,
      initial_kol_limit = 100,
      initial_kql_limit = 100;

    VAR
      xcb_p: ^ost$execution_control_block,
      i: integer,
      input_application_index: jmt$input_application_index,
      output_application_index: jmt$output_application_index,
      qfile_application_index: jmt$qfile_application_index,
      system_job_kjl_index: jmt$kjl_index;

{ Initialize system parameters.

    status.normal := TRUE;

{ Initialize signature locks

    osp$initialize_sig_lock (jmv$job_counts_lock);
    osp$initialize_sig_lock (qfv$kjl_lock);
    osp$initialize_sig_lock (qfv$kol_lock);
    osp$initialize_sig_lock (qfv$kql_lock);

{ Zero out table for queued job candidates for initiation

    pmp$zero_out_table (^jmv$candidate_queued_jobs, #SIZE (jmv$candidate_queued_jobs));

{ Allocate the known job list (KJL) and the known job list extended (KJLX).

    ALLOCATE jmv$kjl_p: [1 .. jmc$kjl_maximum_entries] IN osv$mainframe_pageable_heap^;
    ALLOCATE jmv$kjlx_p: [1 .. jmc$kjl_maximum_entries] IN osv$mainframe_pageable_heap^;

{  Initialize KJL.

    pmp$zero_out_table (^jmv$known_job_list, #SIZE (jmv$known_job_list));
    jmv$known_job_list.state_data [jmc$kjl_unused_entry].first_entry := 1;
    jmv$known_job_list.state_data [jmc$kjl_unused_entry].last_entry := initial_kjl_limit;
    jmv$known_job_list.state_data [jmc$kjl_unused_entry].number_of_entries := initial_kjl_limit;
    jmv$known_job_list.kjl_p := jmv$kjl_p;
    jmv$known_job_list.kjlx_p := jmv$kjlx_p;

    FOR i := 1 TO (initial_kjl_limit - 1) DO
      jmv$kjl_p^ [i].forward_link := i + 1;
      jmv$kjl_p^ [i].reverse_link := i - 1;
      jmv$kjl_p^ [i].entry_kind := jmc$kjl_unused_entry;
    FOREND;

    jmv$kjl_p^ [initial_kjl_limit].forward_link := jmc$kjl_undefined_index;
    jmv$kjl_p^ [initial_kjl_limit].reverse_link := initial_kjl_limit - 1;
    jmv$kjl_p^ [initial_kjl_limit].entry_kind := jmc$kjl_unused_entry;
    qfv$current_kjl_limit := initial_kjl_limit;

    FOR input_application_index := LOWERBOUND (jmv$known_job_list.application_table)
          TO UPPERBOUND (jmv$known_job_list.application_table) DO
      jmv$known_job_list.application_table [input_application_index].application_name := osc$null_name;
      jmv$known_job_list.application_table [input_application_index].destination_usage := osc$null_name;
      jmv$known_job_list.application_table [input_application_index].global_task_id.index := 0;
      jmv$known_job_list.application_table [input_application_index].global_task_id.seqno := 0;
      jmv$known_job_list.application_table [input_application_index].queue_file_password := osc$null_name;
    FOREND;

{ Initialize an entry for the job scheduler application in the KJL's input application table.
{ The global task id in this entry is used for the NOS/VE Job Leveler.

    jmv$known_job_list.application_table [jmc$ve_input_application_index].application_name :=
          osc$nosve_job_scheduler;
    jmv$known_job_list.application_table [jmc$ve_input_application_index].destination_usage := jmc$ve_usage;
    jmv$known_job_list.application_table [jmc$ve_input_application_index].global_task_id.index := 0;
    jmv$known_job_list.application_table [jmc$ve_input_application_index].global_task_id.seqno := 0;
    jmv$known_job_list.application_table [jmc$ve_input_application_index].queue_file_password :=
          osc$null_name;

{ Initialize the client mainframe entry in the KJL for this mainframe.  All fields except the mainframe id
{ should be initialized to zeroes (this was done above).

    pmp$get_pseudo_mainframe_id (
          jmv$known_job_list.client_data.state_data [jmc$kjl_client_this_mainframe].mainframe_id);

{ Initialize the server mainframe entry in the KJL for this mainframe.  All fields except the mainframe id
{ should be initialized to zeroes (this was done above).

    jmv$known_job_list.server_data.state_data [jmc$kjl_server_this_mainframe].mainframe_id :=
          jmv$known_job_list.client_data.state_data [jmc$kjl_client_this_mainframe].mainframe_id;

{ Initialize the job counts table.

    pmp$zero_out_table (^jmv$job_counts, #SIZE (jmv$job_counts));
    jmv$job_counts.initiated_jobs := jmv$job_counts.initiated_jobs + 1;
    jmv$job_counts.job_class_counts [jmc$system_job_class].
          initiated_jobs := jmv$job_counts.job_class_counts [jmc$system_job_class].initiated_jobs + 1;

{  Activate an entry for the system job.

    xcb_p := jmp$job_monitor_xcb ();

    system_job_kjl_index := jmv$known_job_list.state_data [jmc$kjl_unused_entry].first_entry;
    jmv$system_job_kjl_entry [1].forward_link := jmv$kjl_p^ [system_job_kjl_index].forward_link;
    jmv$system_job_kjl_entry [1].reverse_link := jmv$kjl_p^ [system_job_kjl_index].reverse_link;

    jmv$kjl_p^ [system_job_kjl_index] := jmv$system_job_kjl_entry [1];
    jmv$kjlx_p^ [system_job_kjl_index] := jmv$system_job_kjlx_entry [1];

    jmv$kjl_p^ [system_job_kjl_index].entry_kind := jmc$kjl_unused_entry;
    qfp$relink_kjl_entry (system_job_kjl_index, jmv$kjl_p^ [system_job_kjl_index].job_class,
          jmc$kjl_initiated_entry);
    jmv$kjl_p^ [system_job_kjl_index].application_state := jmc$kjl_application_unused;
    qfp$relink_kjl_application (system_job_kjl_index, jmc$ve_input_application_index,
          jmc$kjl_application_initiated);
    qfp$relink_kjl_server (system_job_kjl_index, jmc$kjl_server_this_mainframe);
    qfp$relink_kjl_client (system_job_kjl_index, jmc$kjl_client_this_mainframe);

{ Initialize the system jobs job_id in the JCB.

    jmv$jcb.job_id := system_job_kjl_index;

{  Allocate known output list (KOL).

    ALLOCATE jmv$kol_p: [1 .. jmc$kol_maximum_entries] IN osv$mainframe_pageable_heap^;

{  Initialize KOL.

    pmp$zero_out_table (^jmv$known_output_list, #SIZE (jmv$known_output_list));
    jmv$known_output_list.state_data [jmc$kol_unused_entry].first_entry := 1;
    jmv$known_output_list.state_data [jmc$kol_unused_entry].last_entry := initial_kol_limit;
    jmv$known_output_list.state_data [jmc$kol_unused_entry].number_of_entries := initial_kol_limit;
    jmv$known_output_list.kol_p := jmv$kol_p;

    FOR i := 1 TO (initial_kol_limit - 1) DO
      jmv$kol_p^ [i].forward_link := i + 1;
      jmv$kol_p^ [i].reverse_link := i - 1;
      jmv$kol_p^ [i].entry_kind := jmc$kol_unused_entry;
    FOREND;
    jmv$kol_p^ [initial_kol_limit].forward_link := jmc$kol_undefined_index;
    jmv$kol_p^ [initial_kol_limit].reverse_link := initial_kol_limit - 1;
    jmv$kol_p^ [initial_kol_limit].entry_kind := jmc$kol_unused_entry;
    qfv$current_kol_limit := initial_kol_limit;

    FOR output_application_index := LOWERBOUND (jmv$known_output_list.application_table)
          TO UPPERBOUND (jmv$known_output_list.application_table) DO
      jmv$known_output_list.application_table [output_application_index].application_name := osc$null_name;
      jmv$known_output_list.application_table [output_application_index].destination_usage := osc$null_name;
      jmv$known_output_list.application_table [output_application_index].global_task_id.index := 0;
      jmv$known_output_list.application_table [output_application_index].global_task_id.seqno := 0;
      jmv$known_output_list.application_table [output_application_index].queue_file_password := osc$null_name;
    FOREND;

{  Allocate known qfile list (KQL).

    ALLOCATE jmv$kql_p: [1 .. jmc$maximum_qfile_count] IN osv$mainframe_pageable_heap^;

{  Initialize KQL.

    pmp$zero_out_table (^jmv$known_qfile_list, #SIZE (jmv$known_qfile_list));
    jmv$known_qfile_list.state_data [jmc$kql_unused_entry].first_entry := 1;
    jmv$known_qfile_list.state_data [jmc$kql_unused_entry].last_entry := initial_kql_limit;
    jmv$known_qfile_list.state_data [jmc$kql_unused_entry].number_of_entries := initial_kql_limit;
    jmv$known_qfile_list.kql_p := jmv$kql_p;

    FOR i := 1 TO (initial_kql_limit - 1) DO
      jmv$kql_p^ [i].forward_link := i + 1;
      jmv$kql_p^ [i].reverse_link := i - 1;
      jmv$kql_p^ [i].entry_kind := jmc$kql_unused_entry;
    FOREND;
    jmv$kql_p^ [initial_kql_limit].forward_link := jmc$kql_undefined_index;
    jmv$kql_p^ [initial_kql_limit].reverse_link := initial_kql_limit - 1;
    jmv$kql_p^ [initial_kql_limit].entry_kind := jmc$kql_unused_entry;
    qfv$current_kql_limit := initial_kql_limit;

    FOR qfile_application_index := LOWERBOUND (jmv$known_qfile_list.application_table)
          TO UPPERBOUND (jmv$known_qfile_list.application_table) DO
      jmv$known_qfile_list.application_table [qfile_application_index].application_name := osc$null_name;
      jmv$known_qfile_list.application_table [qfile_application_index].global_task_id.index := 0;
      jmv$known_qfile_list.application_table [qfile_application_index].global_task_id.seqno := 0;
      jmv$known_qfile_list.application_table [qfile_application_index].registration_options.
            notify_on_terminate := FALSE;
      jmv$known_qfile_list.application_table [qfile_application_index].queue_file_password := osc$null_name;
    FOREND;
  PROCEND jmp$initialize_job_tables;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$initialize_ajl_ijl', EJECT ??
*copy jmh$initialize_ajl_ijl

  PROCEDURE [XDCL] jmp$initialize_ajl_ijl;

    VAR
      ignore_status: ost$status,
      ijle_p: ^jmt$initiated_job_list_entry,
      job_mode: jmt$job_mode,
      job_qualifier_index: 1 .. jmc$maximum_job_qualifiers,
      os_type: ost$170_os_type,
      system_job_kjl_index: jmt$kjl_index,
      xcb_p: ^ost$execution_control_block,
      i: integer;

    pmp$get_170_os_type (os_type, ignore_status);

{ Initialize the default job attributes

    FOR job_mode := jmc$batch TO jmc$interactive_connected DO
      jmv$default_job_attributes [job_mode].cpu_time_limit := sfc$unlimited;
      jmv$default_job_attributes [job_mode].device := 'AUTOMATIC';
      jmv$default_job_attributes [job_mode].external_characteristics := 'NORMAL';
      jmv$default_job_attributes [job_mode].forms_code := jmc$default_forms_code;
      jmv$default_job_attributes [job_mode].job_abort_disposition := jmc$terminate_on_abort;
      IF job_mode = jmc$batch THEN
        jmv$default_job_attributes [job_mode].job_class := jmc$batch_class_name;
        jmv$default_job_attributes [job_mode].job_destination_usage := jmc$ve_qtf_usage;
      ELSE
        jmv$default_job_attributes [job_mode].job_class := jmc$interactive_class_name;
        jmv$default_job_attributes [job_mode].job_destination_usage := jmc$ve_local_usage;
      IFEND;
      jmv$default_job_attributes [job_mode].job_deferred_by_operator := FALSE;
      FOR job_qualifier_index := 1 TO jmc$maximum_job_qualifiers DO
        jmv$default_job_attributes [job_mode].job_qualifier_list [job_qualifier_index] := osc$null_name;
      FOREND;
      jmv$default_job_attributes [job_mode].job_recovery_disposition := jmc$continue_on_recovery;
      jmv$default_job_attributes [job_mode].login_family := jmc$system_family;
      jmv$default_job_attributes [job_mode].magnetic_tape_limit := jmc$unspecified_mag_tape_limit;
      jmv$default_job_attributes [job_mode].maximum_working_set := 1000;
      jmv$default_job_attributes [job_mode].output_class := jmc$normal_class_name;
      jmv$default_job_attributes [job_mode].output_deferred_by_operator := FALSE;
      IF os_type = osc$ot7_none THEN
        jmv$default_job_attributes [job_mode].output_destination_usage := jmc$public_usage;
      ELSE
        jmv$default_job_attributes [job_mode].output_destination_usage := jmc$dual_state_usage;
      IFEND;
      jmv$default_job_attributes [job_mode].output_priority := 'LOW';
      jmv$default_job_attributes [job_mode].purge_delay.specified := FALSE;
      jmv$default_job_attributes [job_mode].site_information := '';
      jmv$default_job_attributes [job_mode].station := 'AUTOMATIC';
      jmv$default_job_attributes [job_mode].sru_limit := sfc$unlimited;
      jmv$default_job_attributes [job_mode].vertical_print_density := jmc$vertical_print_density_file;
      jmv$default_job_attributes [job_mode].vfu_load_procedure := '';
    FOREND;

{ Build a mini-KJL for the system job to use until we can allocate the full KJL.

    jmv$kjl_p := ^jmv$system_job_kjl_entry;
    jmv$kjlx_p := ^jmv$system_job_kjlx_entry;
    pmp$zero_out_table (jmv$kjl_p, #SIZE (jmv$kjl_p^));

    pmp$zero_out_table (^jmv$known_job_list, #SIZE (jmv$known_job_list));
    jmv$known_job_list.state_data [jmc$kjl_initiated_entry].first_entry := 1;
    jmv$known_job_list.state_data [jmc$kjl_initiated_entry].last_entry := 1;
    jmv$known_job_list.state_data [jmc$kjl_initiated_entry].number_of_entries := 1;
    jmv$known_job_list.kjl_p := jmv$kjl_p;
    jmv$known_job_list.kjlx_p := jmv$kjlx_p;

{ Activate an entry for the system job.

    xcb_p := jmp$job_monitor_xcb ();

    system_job_kjl_index := 1;
    jmv$kjl_p^ [system_job_kjl_index].system_job_name := jmv$system_job_ssn;
    jmv$kjl_p^ [system_job_kjl_index].user_job_name := jmc$system_user;
    jmv$kjl_p^ [system_job_kjl_index].initiated_job_list_ordinal := jmv$system_ijl_ordinal;
    jmv$kjl_p^ [system_job_kjl_index].job_submission_time := jmc$earliest_clock_time;
    jmv$kjl_p^ [system_job_kjl_index].earliest_clock_time_to_initiate := jmc$earliest_clock_time;
    jmv$kjl_p^ [system_job_kjl_index].job_class := jmc$system_job_class;
    jmv$kjl_p^ [system_job_kjl_index].job_category_set := $jmt$job_category_set [];
    jmv$kjl_p^ [system_job_kjl_index].job_priority := 0;
    jmv$kjl_p^ [system_job_kjl_index].job_deferred_by_operator := FALSE;
    jmv$kjl_p^ [system_job_kjl_index].job_deferred_by_user := FALSE;
    jmv$kjl_p^ [system_job_kjl_index].login_family_available := TRUE;
    jmv$kjl_p^ [system_job_kjl_index].destination_usage := jmc$ve_usage;
    jmv$kjl_p^ [system_job_kjl_index].next_destination_usage := jmc$ve_usage;
    jmv$kjl_p^ [system_job_kjl_index].application_state := jmc$kjl_application_initiated;
    jmv$kjl_p^ [system_job_kjl_index].application_forward_link := jmc$kjl_undefined_index;
    jmv$kjl_p^ [system_job_kjl_index].application_reverse_link := jmc$kjl_undefined_index;
    jmv$kjl_p^ [system_job_kjl_index].entry_kind := jmc$kjl_initiated_entry;
    jmv$kjl_p^ [system_job_kjl_index].forward_link := jmc$kjl_undefined_index;
    jmv$kjl_p^ [system_job_kjl_index].reverse_link := jmc$kjl_undefined_index;
    jmv$kjl_p^ [system_job_kjl_index].class_forward_link := jmc$kjl_undefined_index;
    jmv$kjl_p^ [system_job_kjl_index].class_reverse_link := jmc$kjl_undefined_index;
    jmv$kjl_p^ [system_job_kjl_index].client_index := jmc$kjl_client_undefined;
    jmv$kjl_p^ [system_job_kjl_index].client_forward_link := jmc$kjl_undefined_index;
    jmv$kjl_p^ [system_job_kjl_index].client_reverse_link := jmc$kjl_undefined_index;
    jmv$kjl_p^ [system_job_kjl_index].server_index := jmc$kjl_server_undefined;
    jmv$kjl_p^ [system_job_kjl_index].server_forward_link := jmc$kjl_undefined_index;
    jmv$kjl_p^ [system_job_kjl_index].server_reverse_link := jmc$kjl_undefined_index;
    jmv$kjl_p^ [system_job_kjl_index].server_kjl_index := system_job_kjl_index;

    jmv$kjlx_p^ [system_job_kjl_index].login_user_identification.family := jmc$system_family;
    jmv$kjlx_p^ [system_job_kjl_index].login_user_identification.user := jmc$system_user;
    jmv$kjlx_p^ [system_job_kjl_index].job_controller.family := jmc$system_family;
    jmv$kjlx_p^ [system_job_kjl_index].job_controller.user := jmc$system_user;
    jmv$kjlx_p^ [system_job_kjl_index].originating_ssn := jmv$kjl_p^ [system_job_kjl_index].system_job_name;
    jmv$kjlx_p^ [system_job_kjl_index].latest_clock_time_to_initiate := jmc$latest_clock_time;
    jmv$kjlx_p^ [system_job_kjl_index].job_mode := jmc$batch;
    jmv$kjlx_p^ [system_job_kjl_index].job_monitor_global_task_id := xcb_p^.global_task_id;
    jmv$kjlx_p^ [system_job_kjl_index].output_disposition_key := jmc$normal_output_disposition;
    jmv$kjlx_p^ [system_job_kjl_index].input_file_location := jmc$ifl_no_input_file_exists;
    jmv$kjlx_p^ [system_job_kjl_index].valid_mainframe_set := $jmt$valid_mainframe_set [];
    jmv$kjlx_p^ [system_job_kjl_index].timesharing_job := FALSE;
    jmv$kjlx_p^ [system_job_kjl_index].restart_job := FALSE;
    jmv$kjlx_p^ [system_job_kjl_index].system_label_p := NIL;
    jmv$kjlx_p^ [system_job_kjl_index].terminal_name := osc$null_name;
    pmp$get_compact_date_time (jmv$kjlx_p^ [system_job_kjl_index].job_initiation_time, ignore_status);

    jmv$jcb.job_id := system_job_kjl_index;

{ Allocate active job list (AJL).

    ALLOCATE jmv$ajl_p: [jmv$system_ajl_ordinal .. mtv$mx_ajl_entries + osv$cpus_physically_configured] IN
          osv$mainframe_wired_heap^;
    pmp$zero_out_table (#LOC (jmv$ajl_p^), #SIZE (jmv$ajl_p^));

    FOR i := jmv$system_ajl_ordinal TO mtv$mx_ajl_entries + osv$cpus_physically_configured DO
      jmv$ajl_p^ [i].ijle_p := NIL;
    FOREND;

{ Mark the system job ajl entry as active and connect to the kjl.

    jmv$ajl_p^ [jmv$system_ajl_ordinal].in_use := jmc$swapping_ajl;
    jmv$ajl_p^ [jmv$system_ajl_ordinal].ijl_ordinal := jmv$system_ijl_ordinal;

{
{  Set number of free AJL entries, the system job takes the first AJL ordinal.
{

    jmv$number_free_ajl_entries := mtv$mx_ajl_entries - jmv$system_ajl_ordinal;

{
{  Allocate initiated job list (IJL)
{
{ The size of the initiated job list (IJL) is controlled by the maximum number of tasks that
{ there can be.  Since each job consists of at least one task, the number of IJL entries
{ required is less than or equal to the number of tasks that can exist.
{
{ Please note: there is no precaution taken to prevent the system from running out of IJL
{ entries.  It can't happen.  The above constraint is why.

    ALLOCATE jmv$ijl_p.block_p: [0 .. tmc$maximum_ptl DIV (UPPERVALUE (jmt$ijl_block_index) + 1)] IN
          osv$mainframe_wired_heap^;
    ALLOCATE jmv$ijl_p.block_p^ [0].index_p IN osv$mainframe_wired_heap^;
    pmp$zero_out_table (#LOC (jmv$ijl_p.block_p^ [0].index_p^), #SIZE (jmv$ijl_p.block_p^ [0].index_p^));
    jmv$ijl_p.block_p^ [0].in_use_count := 1;
    jmp$get_ijle_p (jmv$system_ijl_ordinal, ijle_p);

    i := #READ_REGISTER (osc$pr_maintenance_id);
    mtv$cst0 [i].ijl_ordinal := jmv$system_ijl_ordinal;
    mtv$cst0 [i].ajlo := jmv$system_ajl_ordinal;
    mtv$cst0 [i].ijle_p := ijle_p;
    jmv$ajl_p^ [jmv$system_ajl_ordinal].ijle_p := ijle_p;
    ijle_p^.job_name := jmv$kjl_p^ [system_job_kjl_index].user_job_name;
    ijle_p^.system_supplied_name := jmv$kjl_p^ [system_job_kjl_index].system_job_name;
    ijle_p^.entry_status := jmc$ies_job_in_memory_non_swap;
    ijle_p^.ajl_ordinal := jmv$system_ajl_ordinal;
    ijle_p^.kjl_ordinal := system_job_kjl_index;
    ijle_p^.executing_task_count := 1;
    ijle_p^.job_scheduler_data.swapout_reason := jmc$sr_null;
    ijle_p^.job_scheduler_data.job_class := jmc$system_job_class;
    ijle_p^.job_scheduler_data.service_class := jmc$system_service_class;
    ijle_p^.job_monitor_taskid := mtv$cst0 [i].taskid;
    ijle_p^.swap_status := jmc$iss_executing;
    ijle_p^.dispatching_control.dispatching_control_index := jmc$min_dispatching_control;
    ijle_p^.dispatching_control.dispatching_priority := jmc$priority_system_job;
    ijle_p^.scheduling_dispatching_priority := jmc$priority_system_job;
    ijle_p^.dispatching_control.service_remaining := jmc$dc_maximum_service_limit;
    ijle_p^.sfd_p := NIL;
    ijle_p^.job_fixed_contiguous_pages := 0;
    IF syv$all_jobs_selected_for_debug THEN
      ijle_p^.system_breakpoint_selected := TRUE;
    IFEND;
    jmv$jcb.ijle_p := ijle_p;

  PROCEND jmp$initialize_ajl_ijl;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$save_system_core_template', EJECT ??

  PROCEDURE [XDCL] jmp$save_system_core_template
    (VAR status: ost$status);

    VAR
      i: integer,
      j: integer,
      k: integer,
      l: integer,
      rn: ost$ring,
      len: ost$byte_count,
      segment_number: ost$segment,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;

{ Save current System Core environment.

    jmv$executing_within_system_job := FALSE;
    len := #OFFSET (^osv$job_fixed_heap^);
    len := len + 100;
    ALLOCATE jmv$system_core_template.job_fixed_template_p: [1 .. len] IN osv$mainframe_pageable_heap^;
    i#move (#ADDRESS (1, osc$segnum_job_fixed_heap, 0), #LOC (jmv$system_core_template.job_fixed_template_p^),
          #SIZE (jmv$system_core_template.job_fixed_template_p^));

{ Set system job flag for system job.

    jmv$executing_within_system_job := TRUE;

{ Form XCB offset.

    xcb_p := jmp$job_monitor_xcb ();
    i := #OFFSET (xcb_p);

{ Check for JCB overflow.

    IF #SIZE (jmv$jcb) > i THEN
      status.normal := FALSE;
      osp$system_error ('JOB CONTROL BLOCK OVERFLOW', ^status);
    IFEND;

{ Save JMTR xcb offset.

    jmv$system_core_template.jmtr_xcb_offset := i;

{ Form template offset in heap.

    j := #OFFSET (#LOC (jmv$system_core_template.job_fixed_template_p^));

{ Form pointer to JCB in system core template.

    jmv$system_core_template.jcb_p := #ADDRESS (1, #SEGMENT (^osv$mainframe_pageable_heap^), j);

{ Form pointer to XCB in system core template.

    jmv$system_core_template.xcb_p := #ADDRESS (1, #SEGMENT (^osv$mainframe_pageable_heap^), j + i);

{ Form pointer to SDT in system core template.

    k := xcb_p^.sdt_offset;
    jmv$system_core_template.sdt_p := #ADDRESS (1, #SEGMENT (^osv$mainframe_pageable_heap^), j + k);

{ Form pointer to SDTX in system core template.

    l := xcb_p^.sdtx_offset;
    jmv$system_core_template.sdtx_p := #ADDRESS (1, #SEGMENT (^osv$mainframe_pageable_heap^), j + l);

{ Zero out JCB in system core template.

    pmp$zero_out_table (#LOC (jmv$system_core_template.jcb_p^), #SIZE (jmv$system_core_template.jcb_p^));

{ Initialize the XP portion of the XCB in the system core template.

    jmv$system_core_template.xcb_p^.xp := mtv$xp_initial_value;

{ Initialize the accounting fields in the XCB.

    jmv$system_core_template.xcb_p^.dispatching_priority_bias_id := jmc$dpb_positive;
    jmv$system_core_template.xcb_p^.cp_time.time_spent_in_job_mode := 0;
    jmv$system_core_template.xcb_p^.cp_time.time_spent_in_mtr_mode := 0;
    jmv$system_core_template.xcb_p^.proc_malf_count := 0;
    jmv$system_core_template.xcb_p^.paging_statistics.page_fault_count := 0;
    jmv$system_core_template.xcb_p^.paging_statistics.pages_from_server := 0;
    jmv$system_core_template.xcb_p^.paging_statistics.page_in_count := 0;
    jmv$system_core_template.xcb_p^.paging_statistics.pages_reclaimed_from_queue := 0;
    jmv$system_core_template.xcb_p^.paging_statistics.new_pages_assigned := 0;

{ Clear stack segments of SDT in the system core template.

    FOR rn := 1 TO 3 DO
      jmv$system_core_template.sdt_p^ [jmv$system_core_template.xcb_p^.xp.tos_registers [rn].pva.seg].
            ste.asid := 0;
    FOREND;
    jmv$system_core_template.sdt_p^ [osc$segnum_job_fixed_heap].ste.asid := 0;
    jmv$system_core_template.sdt_p^ [osc$segnum_job_pageable_heap].ste.asid := 0;
    jmv$system_core_template.sdt_p^ [osc$segnum_task_shared_heap].ste.asid := 0;
    jmv$system_core_template.sdt_p^ [osc$segnum_task_private_heap].ste.asid := 0;
    jmv$system_core_template.sdt_p^ [osc$segnum_task_private_ring_11].ste.asid := 0;

{  Scan the SDTX for non-template segments and delete these segments from the SDT.

    FOR segment_number := 0 TO jmv$system_core_template.xcb_p^.xp.segment_table_length DO
      IF jmv$system_core_template.sdtx_p^ [segment_number].inheritance = mmc$si_none THEN
        jmv$system_core_template.sdt_p^ [segment_number].ste.vl := osc$vl_invalid_entry;
      IFEND;
      jmv$system_core_template.sdtx_p^ [segment_number].assign_active := osc$max_segment_length;
    FOREND;
  PROCEND jmp$save_system_core_template;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$update_job_template_sdt', EJECT ??

  PROCEDURE [XDCL] jmp$update_job_template_sdt
    (    pva: ^cell;
     VAR status: ost$status);

    VAR
      segment_number: 0 .. 4095,
      sdt_entry: mmt$segment_descriptor,
      sdtx_entry: mmt$segment_descriptor_extended;

    status.normal := TRUE;

    IF jmv$executing_within_system_job = FALSE THEN
      status.normal := FALSE;
      RETURN;
    IFEND;

    segment_number := #SEGMENT (pva);

    mmp$get_sdt_for_job_template (pva, sdt_entry, sdtx_entry, status);
    IF status.normal = FALSE THEN
      RETURN;
    IFEND;

    jmv$system_core_template.sdt_p^ [segment_number] := sdt_entry;
    jmv$system_core_template.sdtx_p^ [segment_number] := sdtx_entry;
  PROCEND jmp$update_job_template_sdt;
?? OLDTITLE ??
MODEND jmm$job_deadstart;
*DECK DECK=JMM$JOB_HISTORY_LOG_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE - Job Management: History Log Interfaces' ??
MODULE jmm$job_history_log_interfaces;

{ PURPOSE:
{   This module accesses the global log $HISTORY_LOG and positions the log at the
{   requested starting position. It retrieves an event and passes this information
{   back to the processor of job_history.
{
{ DESIGN:
{   This module has ring brackets of (2,3,D) such that it can access the global logs.
{   As little processing as possible is in this module so as to let users interrupt
{   the display command as they return from ring 3.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jme$job_history_conditions
*copyc jml$user_id
*copyc jmt$beginning_log_position
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc ost$user_identification
*copyc sfd$type_declarations
*copyc sft$statistic_buffer
*copyc sft$global_log_statistic_header
?? POP ??
*copyc amp$get_next
*copyc fsp$open_file
*copyc osp$set_status_abnormal
*copyc osp$verify_system_privilege
*copyc pmp$get_compact_date_time
*copyc pmp$get_job_names
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$ready_log_file', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to open and position the $HISTORY_LOG
{   at the requested position to start collection of job events.

  PROCEDURE [XDCL, #GATE] jmp$ready_log_file
    (    start_log_search: jmt$beginning_log_position;
         current_login_user: ost$user_identification;
         file: ^fst$file_reference;
     VAR buffer: sft$statistic_buffer;
     VAR file_position: amt$file_position;
     VAR p_header: ^sft$global_log_statistic_header;
     VAR p_descriptor: ^sft$descriptive_data;
     VAR input_file: amt$file_identifier;
     VAR status: ost$status);

    VAR
      attachment_options_p: ^fst$attachment_options,
      date_time: ost$date_time,
      ssn: jmt$system_supplied_name,
      temp_ssn: jmt$system_supplied_name,
      ujn: jmt$user_supplied_name;

    osp$verify_system_privilege;
    status.normal := TRUE;

    PUSH attachment_options_p: [1 .. 2];
    attachment_options_p^ [1].selector := fsc$access_and_share_modes;
    attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options_p^ [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_options_p^ [1].share_modes.selector := fsc$determine_from_access_modes;
    attachment_options_p^ [2].selector := fsc$open_position;
    attachment_options_p^ [2].open_position := amc$open_at_boi;

    IF (file <> NIL) THEN

      fsp$open_file (file^, amc$record, attachment_options_p, NIL, NIL, NIL, NIL, input_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      fsp$open_file ('$HISTORY_LOG                   ', amc$record, attachment_options_p, NIL, NIL, NIL, NIL,
            input_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    CASE start_log_search OF
    = jmc$today =
      pmp$get_compact_date_time (date_time, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      jmp$get_log_entry (input_file, buffer, file_position, p_header, p_descriptor, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    /search_log/
      WHILE file_position <> amc$eoi DO

        IF p_header^.date_time.year >= date_time.year THEN
          IF p_header^.date_time.month >= date_time.month THEN
            IF p_header^.date_time.day = date_time.day THEN
              EXIT /search_log/;
            IFEND;
          IFEND;
        IFEND;
        jmp$get_log_entry (input_file, buffer, file_position, p_header, p_descriptor, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      WHILEND /search_log/;

      IF file_position = amc$eoi THEN
        osp$set_status_abnormal ('JM', jme$end_of_log_reached, '', status);
        RETURN;
      IFEND;

    = jmc$session =
      pmp$get_job_names (ujn, ssn, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      jmp$get_log_entry (input_file, buffer, file_position, p_header, p_descriptor, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    /find_starting_event/
      WHILE file_position <> amc$eoi DO

        IF p_header^.statistic_code = jml$job_queuing_started THEN
          temp_ssn := p_descriptor^ (1, jmc$system_supplied_name_size);
          IF temp_ssn = ssn THEN
            EXIT /find_starting_event/;
          IFEND;
        IFEND;
        jmp$get_log_entry (input_file, buffer, file_position, p_header, p_descriptor, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      WHILEND /find_starting_event/;

      IF file_position = amc$eoi THEN
        osp$set_status_abnormal ('JM', jme$end_of_log_reached, '', status);
        RETURN;
      IFEND;

    = jmc$boi =
      jmp$get_log_entry (input_file, buffer, file_position, p_header, p_descriptor, status);
    ELSE
    CASEND;

  PROCEND jmp$ready_log_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$get_log_entry', EJECT ??

{ PURPOSE:
{   The purpose of this request is to retrieve on job event and pass this on
{   for further processing.
{
{ NOTE:
{   If there are counters associated with a statistic they are ignored.  Job
{   history statistics should not contain counters.  This will be captured
{   in the processing module by the statistic_identifier in the statistic
{   header.

  PROCEDURE [XDCL, #GATE] jmp$get_log_entry
    (    file: amt$file_identifier;
     VAR buffer: sft$statistic_buffer;
     VAR file_position: amt$file_position;
     VAR p_header: ^sft$global_log_statistic_header;
     VAR p_descriptor: ^sft$descriptive_data;
     VAR status: ost$status);


    VAR
      byte_address: amt$file_byte_address,
      p_buffer: ^sft$statistic_buffer,
      p_counters: sft$counters,
      transfer_count: amt$transfer_count;

    osp$verify_system_privilege;
    amp$get_next (file, #LOC (buffer), #SIZE (buffer), transfer_count, byte_address, file_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF file_position <> amc$eoi THEN
      p_buffer := ^buffer;
      RESET p_buffer;
      NEXT p_header IN p_buffer;
      IF p_header^.number_of_counters <> 0 THEN
        NEXT p_counters: [1 .. p_header^.number_of_counters] IN p_buffer;
      IFEND;
      IF p_header^.descriptive_data_size > 0 THEN
        NEXT p_descriptor: [p_header^.descriptive_data_size] IN p_buffer;
      ELSE
        p_descriptor := NIL;
      IFEND;
    IFEND;
  PROCEND jmp$get_log_entry;
?? OLDTITLE ??
MODEND jmm$job_history_log_interfaces;
*DECK DECK=JMM$JOB_LEVELER_TASK EXPAND=TRUE
?? NEWTITLE := 'NOS/VE : Job Leveler Task' ??
MODULE jmm$job_leveler_task;

{ PURPOSE:
{   This module contains the code for the NOS/VE Job Leveler Task.  The Job
{   Leveler Task is responsible for controlling the load of jobs on a mainframe
{   in relation to other mainframes in a set of systems connected by the NOS/VE
{   File Server.  The job leveler is responsible for the assignment of jobs
{   from one mainframe to another (this includes the ability to "unassign"
{   a job that has not been initiated).
{
{ DESIGN:
{   The job leveler task executes in ring 6.
{
{   The job leveler will assign and unassign jobs every job leveler cycle.  It
{   will determine how many jobs the mainframe requires for each job class and
{   perform requests to all server mainframes to request jobs for assignment.
{   At the same time, it will return jobs to the server mainframes that it
{   believes will not be initiated before the job leveler executes again.  When
{   the server assigns jobs to the client mainframe on which the job leveler is
{   executing, the jobs are added to the Known Job List (KJL) on the client.
{   Once in the KJL, the jobs are initiated in the same fashion that
{   non-leveled jobs are.
{
{   A sequence is used to contain data - this allows the requests to always
{   pass a container large enough to contain all data that could be returned.
{   After returning from the request, the containers are reset to occupy only
{   the space actually required (i.e., the data returned by the request)
{   instead of the maximum.  This should allow the task's working set to
{   remain as small as possible.  This is particularly important since the task
{   executes in the system job.
{
{ NOTES:
{   The Job Management Project has a detail design document that describes the
{   operations of the job leveler in detail, "NOS/VE Queue File Management
{   Detail Design."
{
{   In a future release of NOS/VE this module is intended to be made available
{   in source form as a site hook.  At that time, additional documentation will
{   be added to document in much more detail the functions of the job leveler
{   at a high level.  With this in mind, the module will have a module width
{   of the CYBIL default (i.e., 79).

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc ost$status
?? POP ??
*copyc dfp$get_partner_mainframes
*copyc dfp$store_leveler_status
*copyc jmp$assign_server_jobs
*copyc jmp$call_job_leveler_server
*copyc jmp$clear_server_job_classes
*copyc jmp$determine_needed_priorities
*copyc jmp$determine_need_for_jobs
*copyc jmp$discard_server_jobs
*copyc jmp$get_client_scheduling_data
*copyc jmp$leveler_wait
*copyc jmp$register_job_leveler
*copyc jmp$unassign_server_jobs
*copyc jmp$update_server_priorities
*copyc jmp$verify_inactive_server
*copyc mmp$create_scratch_segment
*copyc osp$establish_block_exit_hndlr
*copyc pmp$long_term_wait
?? OLDTITLE ??
?? NEWTITLE := 'update_leveler_status', EJECT ??

{ This procedure updates the leveler status for the file server display.

  PROCEDURE update_leveler_status
    (    server_mainframe_id: pmt$binary_mainframe_id;
         leveler_state: jmt$jl_job_leveler_state;
         cleanup_completed: boolean);

    VAR
      ignore_status: ost$status,
      leveler_status: jmt$jl_job_leveler_status;

    leveler_status.leveler_state := leveler_state;
    leveler_status.cleanup_completed := cleanup_completed;
    dfp$store_leveler_status (server_mainframe_id, leveler_status,
          ignore_status);
  PROCEND update_leveler_status;
?? OLDTITLE ??
?? NEWTITLE := 'jmp$job_leveler_task', EJECT ??

{ PURPOSE:
{   This procedure is the NOS/VE Job Leveler Task.

  PROGRAM jmp$job_leveler_task
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      highest_server_class_priorities: jmt$jl_server_job_priorities,
      job_class: jmt$job_class,
      leveler_job_class_data: jmt$jl_job_class_data,
      scheduling_data: jmt$jl_scheduling_data,
      scratch_segment_pointer: amt$segment_pointer,
      scratch_sequence_p: ^SEQ ( * ),
      server_inactive: boolean,
      server_mainframe_count: dft$partner_mainframe_count,
      server_mainframe_id: pmt$binary_mainframe_id,
      server_mainframe_index: dft$partner_mainframe_count,
      server_mainframe_list_p: ^dft$partner_mainframe_list;

?? NEWTITLE := 'handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this request is to cleanup when the job leveler task
{ is terminated.
{
{ DESIGN:
{   Unassign the jobs from all server mainframes that are still active
{ or are deactivated.  The server mainframe is then signed off.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      NEXT server_mainframe_list_p: [1 .. dfc$maximum_partner_mainframes] IN
            scratch_sequence_p;
      dfp$get_partner_mainframes ({ partners_are_servers } TRUE,
            server_mainframe_list_p, server_mainframe_count);
      RESET scratch_sequence_p TO server_mainframe_list_p;
      IF server_mainframe_count > 0 THEN
        NEXT server_mainframe_list_p: [1 .. server_mainframe_count] IN
              scratch_sequence_p;
      ELSE
        server_mainframe_list_p := NIL;
      IFEND;

      FOR server_mainframe_index := 1 TO server_mainframe_count DO
        server_mainframe_id := server_mainframe_list_p^
              [server_mainframe_index].mainframe_id;
        CASE server_mainframe_list_p^ [server_mainframe_index].partner_state OF
        = dfc$active =
          signoff_request (server_mainframe_id);

        = dfc$deactivated =
          signoff_request (server_mainframe_id);

        = dfc$inactive =
          ; { do nothing

        = dfc$terminated, dfc$awaiting_recovery =
          jmp$discard_server_jobs (server_mainframe_id);

        = dfc$recovering =
          ; { do nothing

        ELSE
        CASEND;

        update_leveler_status (server_mainframe_id, jmc$jl_leveler_disabled,
              { cleanup_completed } TRUE);
      FOREND;

      jmp$clear_server_job_classes;
    PROCEND handle_block_exit;
?? OLDTITLE ??
?? NEWTITLE := 'normal_request', EJECT ??

{ PURPOSE:
{   The purpose of this request is to send the "normal" leveler request to
{   the server mainframe.  This request includes unassigning jobs and
{   requesting assignment of additional jobs.

    PROCEDURE normal_request
      (    server_mainframe_id: pmt$binary_mainframe_id;
           leveler_job_class_data: jmt$jl_job_class_data;
           scheduling_data: jmt$jl_scheduling_data;
       VAR highest_server_class_priorities: jmt$jl_server_job_priorities);

      VAR
        assigned_job_index: jmt$job_count_range,
        job_class: jmt$job_class,
        leveler_server_request: jmt$jl_leveler_server_request,
        local_status: ost$status,
        successful_assigned_job_count: jmt$job_count_range,
        unassigned_job_count: jmt$job_count_range,
        unassigned_job_list_p: ^jmt$jl_unassigned_job_list;

      leveler_server_request.request_kind := jmc$jl_normal_request;
      leveler_server_request.normal_request.leveler_job_class_data :=
            leveler_job_class_data;
      leveler_server_request.normal_request.initiation_required_categories :=
            scheduling_data.initiation_required_categories;
      leveler_server_request.normal_request.initiation_excluded_categories :=
            scheduling_data.initiation_excluded_categories;
      leveler_server_request.normal_request.active_profile_id :=
            scheduling_data.profile_identification;

      jmp$determine_needed_priorities (leveler_server_request.normal_request.
            leveler_job_class_data, leveler_server_request.normal_request.
            job_class_priorities);
      NEXT leveler_server_request.normal_request.unassigned_job_list_p:
            [1 .. jmc$maximum_job_count] IN scratch_sequence_p;
      jmp$unassign_server_jobs (server_mainframe_id,
            { unassign_all_jobs } FALSE, leveler_server_request.normal_request.
            job_class_priorities, leveler_server_request.normal_request.
            unassigned_job_list_p, unassigned_job_count);
      RESET scratch_sequence_p TO leveler_server_request.normal_request.
            unassigned_job_list_p;
      IF unassigned_job_count = 0 THEN
        leveler_server_request.normal_request.unassigned_job_list_p := NIL;
      ELSE
        NEXT leveler_server_request.normal_request.unassigned_job_list_p:
              [1 .. unassigned_job_count] IN scratch_sequence_p;
      IFEND;

{ Call the server and request jobs via the Remote Procedure Call (RPC)
{ mechanism.

      NEXT leveler_server_request.normal_request.assigned_job_list_p:
            [1 .. jmc$maximum_job_count] IN scratch_sequence_p;
      jmp$call_job_leveler_server (server_mainframe_id, leveler_server_request,
            status);
      IF status.normal THEN
        FOR job_class := LOWERVALUE (job_class) TO UPPERVALUE (job_class) DO
          IF leveler_server_request.normal_request.
                server_job_priorities [job_class] >
                highest_server_class_priorities [job_class] THEN
            highest_server_class_priorities [job_class] :=
                  leveler_server_request.normal_request.
                  server_job_priorities [job_class];
          IFEND;
        FOREND;
        RESET scratch_sequence_p TO leveler_server_request.normal_request.
              assigned_job_list_p;
        IF (leveler_server_request.normal_request.profile_mismatch) OR
              (NOT leveler_server_request.normal_request.job_leveling_enabled)
              THEN

{ Return all jobs to the server.

          unassign_jobs_request (server_mainframe_id);
          IF leveler_server_request.normal_request.profile_mismatch THEN
            update_leveler_status (server_mainframe_id,
                  jmc$jl_server_profile_mismatch, { cleanup_completed } TRUE);
          ELSE
            update_leveler_status (server_mainframe_id,
                  jmc$jl_leveler_disabled, { cleanup_completed } TRUE);
          IFEND;

        ELSE

          IF leveler_server_request.normal_request.assigned_job_count > 0 THEN

{ Put the jobs assigned by the server into the Known Job List (KJL).

            NEXT leveler_server_request.normal_request.assigned_job_list_p:
                  [1 .. leveler_server_request.normal_request.
                  assigned_job_count] IN scratch_sequence_p;
            jmp$assign_server_jobs (server_mainframe_id,
                  leveler_server_request.normal_request.assigned_job_list_p,
                  successful_assigned_job_count, status);
            IF NOT status.normal THEN
              IF leveler_server_request.normal_request.assigned_job_count >
                    successful_assigned_job_count THEN
                NEXT unassigned_job_list_p: [1 .. leveler_server_request.
                      normal_request.assigned_job_count -
                      successful_assigned_job_count] IN scratch_sequence_p;
                FOR assigned_job_index := successful_assigned_job_count +
                      1 TO leveler_server_request.normal_request.
                      assigned_job_count DO
                  unassigned_job_list_p^ [assigned_job_index -
                        successful_assigned_job_count].system_job_name :=
                        leveler_server_request.normal_request.
                        assigned_job_list_p^ [assigned_job_index].
                        system_job_name;
                  unassigned_job_list_p^ [assigned_job_index -
                        successful_assigned_job_count].server_kjl_index :=
                        leveler_server_request.normal_request.
                        assigned_job_list_p^ [assigned_job_index].
                        server_kjl_index;
                FOREND;
                leveler_server_request.request_kind :=
                      jmc$jl_unassign_jobs_request;
                leveler_server_request.unassign_jobs_request.
                      unassigned_job_list_p := unassigned_job_list_p;
                jmp$call_job_leveler_server (server_mainframe_id,
                      leveler_server_request, { ignore } local_status);
              IFEND;
            IFEND;
          IFEND;
          update_leveler_status (server_mainframe_id, jmc$jl_leveler_enabled,
                { cleanup_completed } FALSE);
        IFEND;

      ELSE

{ The server has terminated - throw away all jobs assigned by the server.

        jmp$discard_server_jobs (server_mainframe_id);
        update_leveler_status (server_mainframe_id, jmc$jl_leveler_disabled,
              { cleanup_completed } TRUE);
      IFEND;
    PROCEND normal_request;
?? OLDTITLE ??
?? NEWTITLE := 'signoff_request', EJECT ??

{ PURPOSE:
{   The purpose of this request is signoff to the server mainframe.  This
{ request
{   is performed only when the job leveler task is being deactivated.

    PROCEDURE signoff_request
      (    server_mainframe_id: pmt$binary_mainframe_id);

      VAR
        ignore_status: ost$status,
        job_class: jmt$job_class,
        job_class_priorities: jmt$jl_job_class_priorities,
        leveler_server_request: jmt$jl_leveler_server_request,
        unassigned_job_count: jmt$job_count_range;

      leveler_server_request.request_kind := jmc$jl_signoff_request;
      FOR job_class := LOWERVALUE (job_class) TO UPPERVALUE (job_class) DO
        job_class_priorities [job_class].job_priority := 0;
        job_class_priorities [job_class].based_on_selection_priority := FALSE;
      FOREND;

      NEXT leveler_server_request.signoff_request.unassigned_job_list_p:
            [1 .. jmc$maximum_job_count] IN scratch_sequence_p;
      jmp$unassign_server_jobs (server_mainframe_id,
            { unassign_all_jobs } TRUE, job_class_priorities,
            leveler_server_request.signoff_request.unassigned_job_list_p,
            unassigned_job_count);
      RESET scratch_sequence_p TO leveler_server_request.signoff_request.
            unassigned_job_list_p;
      IF unassigned_job_count = 0 THEN
        leveler_server_request.signoff_request.unassigned_job_list_p := NIL;
      ELSE
        NEXT leveler_server_request.signoff_request.unassigned_job_list_p:
              [1 .. unassigned_job_count] IN scratch_sequence_p;
      IFEND;
      jmp$call_job_leveler_server (server_mainframe_id, leveler_server_request,
            ignore_status);
      update_leveler_status (server_mainframe_id, jmc$jl_leveler_disabled,
            { cleanup_completed } TRUE);
    PROCEND signoff_request;
?? OLDTITLE ??
?? NEWTITLE := 'unassign_jobs_request', EJECT ??

{ PURPOSE:
{   The purpose of this request is to unconditionally unassign all jobs for
{ the indicated server mainframe.

    PROCEDURE unassign_jobs_request
      (    server_mainframe_id: pmt$binary_mainframe_id);

      VAR
        ignore_status: ost$status,
        job_class: jmt$job_class,
        job_class_priorities: jmt$jl_job_class_priorities,
        leveler_server_request: jmt$jl_leveler_server_request,
        unassigned_job_count: jmt$job_count_range;

      leveler_server_request.request_kind := jmc$jl_unassign_jobs_request;
      FOR job_class := LOWERVALUE (job_class) TO UPPERVALUE (job_class) DO
        job_class_priorities [job_class].job_priority := 0;
        job_class_priorities [job_class].based_on_selection_priority := FALSE;
      FOREND;

      NEXT leveler_server_request.unassign_jobs_request.
            unassigned_job_list_p: [1 .. jmc$maximum_job_count] IN
            scratch_sequence_p;
      jmp$unassign_server_jobs (server_mainframe_id,
            { unassign_all_jobs } TRUE, job_class_priorities,
            leveler_server_request.unassign_jobs_request.unassigned_job_list_p,
            unassigned_job_count);
      RESET scratch_sequence_p TO leveler_server_request.unassign_jobs_request.
            unassigned_job_list_p;
      IF unassigned_job_count = 0 THEN
        leveler_server_request.unassign_jobs_request.unassigned_job_list_p :=
              NIL;
      ELSE
        NEXT leveler_server_request.unassign_jobs_request.
              unassigned_job_list_p: [1 .. unassigned_job_count] IN
              scratch_sequence_p;
      IFEND;
      jmp$call_job_leveler_server (server_mainframe_id, leveler_server_request,
            ignore_status);
    PROCEND unassign_jobs_request;
?? OLDTITLE ??
?? EJECT ??

{ Register the job leveler task with Queue File Management.  This will identify
{ the executing task as the one and only job leveler task.

    jmp$register_job_leveler;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random,
          scratch_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    scratch_sequence_p := scratch_segment_pointer.sequence_pointer;
    #SPOIL (scratch_sequence_p);

    osp$establish_block_exit_hndlr (^handle_block_exit);

    WHILE TRUE DO
      RESET scratch_sequence_p;
      jmp$get_client_scheduling_data (scheduling_data);

      FOR job_class := LOWERVALUE (job_class) TO UPPERVALUE (job_class) DO
        highest_server_class_priorities [job_class] := 0;
      FOREND;

{ If there are servers to communicate with, determine the number of jobs that
{ are needed by this mainframe.

      NEXT server_mainframe_list_p: [1 .. dfc$maximum_partner_mainframes] IN
            scratch_sequence_p;
      dfp$get_partner_mainframes ({ partners_are_servers } TRUE,
            server_mainframe_list_p, server_mainframe_count);
      RESET scratch_sequence_p TO server_mainframe_list_p;
      IF server_mainframe_count > 0 THEN
        NEXT server_mainframe_list_p: [1 .. server_mainframe_count] IN
              scratch_sequence_p;
      ELSE
        server_mainframe_list_p := NIL;
      IFEND;

      jmp$determine_need_for_jobs (leveler_job_class_data);

      FOR server_mainframe_index := 1 TO server_mainframe_count DO
        server_mainframe_id := server_mainframe_list_p^
              [server_mainframe_index].mainframe_id;

        CASE server_mainframe_list_p^ [server_mainframe_index].partner_state OF
        = dfc$active =

{ For each ACTIVE server determine the priority required for jobs to be
{ assigned, and unassign any jobs unlikely to be initiated.  Retrieve the
{ mainframe's required and excluded categories and the active scheduling
{ profile id.

          IF scheduling_data.profile_loading_in_progress OR
                (NOT scheduling_data.job_leveling_enabled) THEN
            unassign_jobs_request (server_mainframe_id);
            update_leveler_status (server_mainframe_id,
                  jmc$jl_leveler_disabled, { cleanup_complete } TRUE);
          ELSE
            normal_request (server_mainframe_id, leveler_job_class_data,
                  scheduling_data, highest_server_class_priorities);
          IFEND;

        = dfc$deactivated =

{ For each DEACTIVATED server unassign any non-initiated jobs assigned by
{ the server mainframe.

          unassign_jobs_request (server_mainframe_id);
          update_leveler_status (server_mainframe_id, jmc$jl_leveler_disabled,
                { cleanup_complete } TRUE);

        = dfc$inactive =

{ For each server that is INACTIVE verify that there are no unassigned jobs on
{ this mainframe.  It is not possible to communicate with the server if it
{ is in the INACTIVE state.

          jmp$verify_inactive_server (server_mainframe_id, server_inactive);
          update_leveler_status (server_mainframe_id, jmc$jl_leveler_disabled,
                { cleanup_complete } TRUE);

        = dfc$terminated, dfc$awaiting_recovery =

{ For each TERMINATED server remove any non-initiated jobs assigned by the
{ server mainframe from the KJL.  It is not possible to communicate with the
{ server if it is in the TERMINATED state.
{ For each server that is AWAITING_RECOVERY remove any non-initiated jobs
{ assigned by the server mainframe from the KJL.  It is not possible to
{ communicate with the server in the AWAITING_RECOVERY state.  It is possible
{ for jobs to be in the KJL when the server crashes and the leveler must
{ remove them.


          jmp$discard_server_jobs (server_mainframe_id);
          update_leveler_status (server_mainframe_id, jmc$jl_leveler_disabled,
                { cleanup_complete } TRUE);

        = dfc$recovering =
          ; { Do nothing

        ELSE
        CASEND;

      FOREND;

{ Update the highest priority unassigned server job that is available for each
{ job class.

      IF server_mainframe_count > 0 THEN
        jmp$update_server_priorities (highest_server_class_priorities);
      ELSE
        jmp$clear_server_job_classes;
      IFEND;

{ Wait for the job leveling interval.

      jmp$leveler_wait (scheduling_data.job_leveling_interval);
    WHILEND;
  PROCEND jmp$job_leveler_task;
?? OLDTITLE ??
MODEND jmm$job_leveler_task;
*DECK DECK=JMM$JOB_MESSAGE_MANAGEMENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Job Management - message handling interfaces' ??
MODULE jmm$job_message_management;

{ PURPOSE:
{   This module contains routines that are used to handle job messages.

{ NOTES:
{   To add an additional job message do the following:
{   o  Change the types jmt$job_message_kind and jmt$job_message to reflect the
{      new message.
{   o  Add a procedure (or a call) to the procedure send_job_message to process
{      the message once the target mainframe is reached.
{   o  Change the procedure pack_job_message to move the contents of the message
{      into the parameters and data to send to the server.  The total size of
{      of the parameters should be less than 3000 bytes.  If the amount of data
{      to be sent, exceeds this, use the data sequence to send information to
{      the server.
{   o  Change the unpack_job_message procedure to remove the data from the
{      sequences from the client.
{   o  Test the request using two mainframes (client & server).  There should
{      be no need to test the indirect case since any new message that is added
{      will be passed the same way using a previously validated path.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_parameters
*copyc jmc$job_management_id
*copyc jme$job_message_error
*copyc jmt$job_message
*copyc jmt$mainframes_searched_list
*copyc jmt$maximum_mainframes
*copyc ost$status
?? POP ??
*copyc dfp$get_partner_mainframes
*copyc dfp$send_remote_procedure_call
*copyc i#current_sequence_position
*copyc jmp$get_job_internal_info
*copyc jmp$get_job_status
*copyc jmp$get_result_size
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc pmp$convert_binary_mainframe_id
*copyc pmp$convert_mainframe_to_binary
*copyc pmp$get_mainframe_id
*copyc pmp$get_pseudo_mainframe_id
*copyc pmp$set_system_flag
?? OLDTITLE ??
?? NEWTITLE := 'send_indirect_job_message', EJECT ??

{ PURPOSE:
{   The purpose of this request is to send a job message via the file server's
{   remote procedure call mechanism to another mainframe.  If the target mainframe
{   is directly connected, send the message to the target immediately.  If the
{   target is not directly connected, or all mainframes are the target, then
{   send the message to all connected mainframes.

  PROCEDURE send_indirect_job_message
    (    target_mainframe_id: pmt$mainframe_id;
         job_message: jmt$job_message;
     VAR mainframes_searched_count {input, output} : jmt$maximum_mainframes;
     VAR mainframes_searched_list {input, output} : jmt$mainframes_searched_list;
     VAR target_mainframe_reached: boolean;
     VAR status: ost$status);

    VAR
      binary_target_mainframe_id: pmt$binary_mainframe_id,
      data_size: dft$send_data_size,
      local_status: ost$status,
      mainframe_id: pmt$mainframe_id,
      mainframes_searched_count_p: ^jmt$maximum_mainframes,
      mainframes_searched_index: jmt$maximum_mainframes,
      mainframes_searched_list_p: ^jmt$mainframes_searched_list,
      queue_entry_location: dft$rpc_queue_entry_location,
      parameter_size: dft$send_parameter_size,
      received_from_server_data_p: dft$p_receive_data,
      received_from_server_params_p: dft$p_receive_parameters,
      send_to_server_data_p: dft$p_send_data,
      send_to_server_params_p: dft$p_send_parameters,
      server_directly_connected: boolean,
      server_location: dft$server_location,
      server_mainframe_count: dft$partner_mainframe_count,
      server_mainframe_index: dft$partner_mainframe_count,
      server_mainframe_list: array [1 .. dfc$maximum_partner_mainframes] of dft$partner_mainframe_entry,
      target_mainframe_id_p: ^pmt$mainframe_id,
      target_mainframe_reached_p: ^boolean;

?? NEWTITLE := 'pack_job_message', EJECT ??

{ PURPOSE:
{   The purpose of this request is to pack the parameters and data passed to
{   the server and initialize pointers within the job_message to point to the
{   passed data.
{
{ NOTE:
{   For now, no packing is necessary since all data is currently passed in
{   the job message header.  When that changes, delete this note.

    PROCEDURE pack_job_message
      (    job_message: jmt$job_message;
       VAR send_to_server_params_p: dft$p_send_parameters;
       VAR send_to_server_data_p: dft$p_send_data;
       VAR status: ost$status);

      VAR
        local_job_message_p: ^jmt$job_message;

      status.normal := TRUE;
      NEXT local_job_message_p IN send_to_server_params_p;
      local_job_message_p^ := job_message;

      CASE job_message.message_kind OF
      = jmc$jmk_null_message =
        ;

      = jmc$jmk_unseen_mail_message =
        ;

      ELSE
        osp$set_status_condition (jme$job_message_error, status);
      CASEND;
    PROCEND pack_job_message;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT send_indirect_job_message;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE ??
?? EJECT ??
    status.normal := TRUE;
    target_mainframe_reached := FALSE;

    dfp$get_partner_mainframes ({partners_are_servers} TRUE, ^server_mainframe_list, server_mainframe_count);

    IF target_mainframe_id <> pmc$null_mainframe_id THEN
      pmp$convert_mainframe_to_binary (target_mainframe_id, binary_target_mainframe_id, local_status);
      IF local_status.normal THEN

{ Determine if the target mainframe is directly connected and available.

      /search_for_direct_mainframe/
        FOR server_mainframe_index := 1 TO server_mainframe_count DO
          IF (server_mainframe_list [server_mainframe_index].mainframe_id = binary_target_mainframe_id) AND
                (server_mainframe_list [server_mainframe_index].partner_state = dfc$active) THEN

            server_location.server_location_selector := dfc$mainframe_id;
            server_location.server_mainframe := target_mainframe_id;

            dfp$begin_ch_remote_proc_call (server_location, {allowed_when_server_deactivated} FALSE,
                  queue_entry_location, send_to_server_params_p, send_to_server_data_p, local_status);
            IF NOT local_status.normal THEN
              EXIT /search_for_direct_mainframe/;
            IFEND;

{ The sequences for the remote procedure call have already been reset.

            NEXT target_mainframe_id_p IN send_to_server_params_p;
            target_mainframe_id_p^ := target_mainframe_id;
            NEXT mainframes_searched_count_p IN send_to_server_params_p;
            mainframes_searched_count_p^ := mainframes_searched_count;
            NEXT mainframes_searched_list_p IN send_to_server_params_p;
            mainframes_searched_list_p^ := mainframes_searched_list;
            pack_job_message (job_message, send_to_server_params_p, send_to_server_data_p, status);

            parameter_size := i#current_sequence_position (send_to_server_params_p);
            data_size := i#current_sequence_position (send_to_server_data_p);

            dfp$send_remote_procedure_call (queue_entry_location, dfc$rpc_jl_send_job_message, parameter_size,
                  data_size, received_from_server_params_p, received_from_server_data_p, local_status);
            IF local_status.normal THEN
              NEXT target_mainframe_reached_p IN received_from_server_params_p;
              target_mainframe_reached := target_mainframe_reached_p^;
              IF NOT target_mainframe_reached THEN
                NEXT mainframes_searched_count_p IN received_from_server_params_p;
                NEXT mainframes_searched_list_p IN received_from_server_params_p;
                mainframes_searched_count := mainframes_searched_count_p^;
                mainframes_searched_list := mainframes_searched_list_p^;
              IFEND;
            IFEND;
            dfp$end_ch_remote_proc_call (queue_entry_location, {ignore} local_status);

            IF target_mainframe_reached THEN
              RETURN;
            ELSE
              EXIT /search_for_direct_mainframe/;
            IFEND;
          IFEND;
        FOREND /search_for_direct_mainframe/;
      IFEND;
    IFEND;

{ The target is not directly connected or all mainframes are targeted.

  /call_each_server_mainframe/
    FOR server_mainframe_index := 1 TO server_mainframe_count DO
      IF mainframes_searched_count < jmc$maximum_mainframes THEN
        FOR mainframes_searched_index := 1 TO mainframes_searched_count DO
          IF mainframes_searched_list [mainframes_searched_index] =
                server_mainframe_list [server_mainframe_index].mainframe_id THEN
            CYCLE /call_each_server_mainframe/;
          IFEND;
        FOREND;

        IF server_mainframe_list [server_mainframe_index].partner_state = dfc$active THEN
          pmp$convert_binary_mainframe_id (server_mainframe_list [server_mainframe_index].mainframe_id,
                mainframe_id, {ignore} status);
          server_location.server_location_selector := dfc$mainframe_id;
          server_location.server_mainframe := mainframe_id;

          dfp$begin_ch_remote_proc_call (server_location, {allowed_when_server_deactivated} FALSE,
                queue_entry_location, send_to_server_params_p, send_to_server_data_p, local_status);
          IF NOT local_status.normal THEN
            CYCLE /call_each_server_mainframe/;
          IFEND;

{ The sequences for the remote procedure call have already been reset.

          NEXT target_mainframe_id_p IN send_to_server_params_p;
          target_mainframe_id_p^ := target_mainframe_id;
          NEXT mainframes_searched_count_p IN send_to_server_params_p;
          mainframes_searched_count_p^ := mainframes_searched_count;
          NEXT mainframes_searched_list_p IN send_to_server_params_p;
          mainframes_searched_list_p^ := mainframes_searched_list;
          pack_job_message (job_message, send_to_server_params_p, send_to_server_data_p, status);

          parameter_size := i#current_sequence_position (send_to_server_params_p);
          data_size := i#current_sequence_position (send_to_server_data_p);

          dfp$send_remote_procedure_call (queue_entry_location, dfc$rpc_jl_send_job_message, parameter_size,
                data_size, received_from_server_params_p, received_from_server_data_p, local_status);
          IF local_status.normal THEN
            NEXT target_mainframe_reached_p IN received_from_server_params_p;
            target_mainframe_reached := target_mainframe_reached_p^;
            IF NOT target_mainframe_reached THEN
              NEXT mainframes_searched_count_p IN received_from_server_params_p;
              NEXT mainframes_searched_list_p IN received_from_server_params_p;
              mainframes_searched_count := mainframes_searched_count_p^;
              mainframes_searched_list := mainframes_searched_list_p^;
            IFEND;
          IFEND;
          dfp$end_ch_remote_proc_call (queue_entry_location, {ignore} local_status);

          IF target_mainframe_reached THEN
            EXIT /call_each_server_mainframe/;
          IFEND;
        IFEND;
      IFEND;
    FOREND /call_each_server_mainframe/;
  PROCEND send_indirect_job_message;
?? OLDTITLE ??
?? NEWTITLE := 'send_job_message', EJECT ??

{ PURPOSE:
{   The purpose of this request is to send a job message to the message target
{   once the target mainframe is reached.
{
{ NOTE:
{   This request is only called on the target mainframe.

  PROCEDURE send_job_message
    (    job_message: jmt$job_message;
     VAR status: ost$status);

?? NEWTITLE := 'broadcast_unseen_mail', EJECT ??

{ PURPOSE:
{   The purpose of this request is to deliver the unseen mail message to the
{   appropriate jobs on the mainframe.

    PROCEDURE broadcast_unseen_mail
      (    job_message: jmt$job_message;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status,
        index: jmt$job_status_count,
        job_count: ost$non_negative_integers,
        job_info: jmt$job_internal_information,
        number_of_jobs_found: jmt$job_status_count,
        size_of_sequence: ost$segment_length,
        status_options: array [1 .. 4] of jmt$job_status_option,
        status_results_keys_p: ^jmt$results_keys,
        status_results_seq_p: ^jmt$work_area,
        status_results_p: ^jmt$job_status_results;

      status.normal := TRUE;

      status_options [1].key := jmc$job_state_set;
      status_options [1].job_state_set := $jmt$job_state_set [jmc$initiated_job];
      status_options [2].key := jmc$login_family;
      status_options [2].login_family := job_message.unseen_mail_message.user_id.family;
      status_options [3].key := jmc$login_user;
      status_options [3].login_user := job_message.unseen_mail_message.user_id.user;
      status_options [4].key := jmc$privilege;
      status_options [4].privilege := jmc$privileged;

      number_of_jobs_found := 0;

      PUSH status_results_keys_p: [1 .. 1];
      status_results_keys_p^ [1] := jmc$system_job_name;

      REPEAT
        job_count := number_of_jobs_found + 1;
        jmp$get_result_size (job_count, #SEQ (status_results_keys_p^), size_of_sequence);
        PUSH status_results_seq_p: [[REP size_of_sequence OF cell]];

        jmp$get_job_status (^status_options, status_results_keys_p, status_results_seq_p, status_results_p,
              number_of_jobs_found, ignore_status);
      UNTIL number_of_jobs_found <= job_count;
      IF number_of_jobs_found <> 0 THEN
        FOR index := 1 TO number_of_jobs_found DO
          jmp$get_job_internal_info (status_results_p^ [index]^ [1].system_job_name, job_info, status);
          IF status.normal THEN
            pmp$set_system_flag (jmc$message_waiting_flag_id, job_info.jmtr_global_taskid, ignore_status);
          IFEND;
        FOREND;
        status.normal := TRUE;
      IFEND;
    PROCEND broadcast_unseen_mail;
?? OLDTITLE ??
?? EJECT ??


    status.normal := TRUE;

    CASE job_message.message_kind OF
    = jmc$jmk_null_message =
      ;

    = jmc$jmk_unseen_mail_message =
      broadcast_unseen_mail (job_message, status);

    ELSE
      osp$set_status_condition (jme$job_message_error, status);
    CASEND;

  PROCEND send_job_message;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$send_job_message', EJECT ??
*copy jmh$send_job_message

  PROCEDURE [XDCL] jmp$send_job_message
    (    target_mainframe_id: pmt$mainframe_id;
         job_message: jmt$job_message;
     VAR status: ost$status);

    VAR
      current_mainframe_id: pmt$mainframe_id,
      mainframes_searched_count: jmt$maximum_mainframes,
      mainframes_searched_list: jmt$mainframes_searched_list,
      target_mainframe_reached: boolean;

    status.normal := TRUE;

    pmp$get_mainframe_id (current_mainframe_id, {ignore} status);

{ If we are at the target mainframe, then process the message....

    IF current_mainframe_id = target_mainframe_id THEN
      send_job_message (job_message, status);
    ELSE
      IF target_mainframe_id = pmc$null_mainframe_id THEN
        send_job_message (job_message, status);
      IFEND;

      mainframes_searched_count := 1;
      pmp$get_pseudo_mainframe_id (mainframes_searched_list [1]);
      send_indirect_job_message (target_mainframe_id, job_message, mainframes_searched_count,
            mainframes_searched_list, target_mainframe_reached, status);

      IF NOT target_mainframe_reached THEN
        osp$set_status_condition (jme$job_message_error, status);
      IFEND;
    IFEND;

  PROCEND jmp$send_job_message;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$server_send_job_message', EJECT ??
*copy jmh$server_send_job_message

  PROCEDURE [XDCL] jmp$server_send_job_message
    (VAR received_from_client_params_p { Input } : dft$p_receive_parameters;
     VAR received_from_client_data_p { Input } : dft$p_receive_data;
     VAR send_to_client_params_p { Output } : dft$p_send_parameters;
     VAR send_to_client_data_p { Output } : dft$p_send_data;
     VAR parameter_size: dft$send_parameter_size;
     VAR data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      current_mainframe_id: pmt$mainframe_id,
      job_message: jmt$job_message,
      local_job_message_p: ^jmt$job_message,
      mainframes_searched_count: jmt$maximum_mainframes,
      mainframes_searched_count_p: ^jmt$maximum_mainframes,
      mainframes_searched_list: jmt$mainframes_searched_list,
      mainframes_searched_list_p: ^jmt$mainframes_searched_list,
      target_mainframe_id_p: ^pmt$mainframe_id,
      target_mainframe_reached: boolean,
      target_mainframe_reached_p: ^boolean;

?? NEWTITLE := 'unpack_job_message', EJECT ??

{ PURPOSE:
{   The purpose of this request is to unpack the parameters and data passed from
{ the client and initialize pointers within the job_message to point to the
{ passed data.
{
{ NOTE:
{   For now, no unpacking is necessary since all data is currently passed in
{ the job message header.  When that changes, delete this note.

    PROCEDURE unpack_job_message
      (VAR received_from_client_params_p {input} : dft$p_receive_parameters;
       VAR received_from_client_data_p {input} : dft$p_receive_data;
       VAR job_message {input,output} : jmt$job_message;
       VAR status: ost$status);

      VAR
        local_job_message_p: ^jmt$job_message;

      status.normal := TRUE;
      NEXT local_job_message_p IN received_from_client_params_p;
      job_message := local_job_message_p^;
      CASE job_message.message_kind OF
      = jmc$jmk_null_message =
        ;

      = jmc$jmk_unseen_mail_message =
        ;

      ELSE
        osp$set_status_condition (jme$job_message_error, status);
      CASEND;
    PROCEND unpack_job_message;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;

  /process_remote_procedure_call/
    BEGIN
      NEXT target_mainframe_id_p IN received_from_client_params_p;
      NEXT mainframes_searched_count_p IN received_from_client_params_p;
      mainframes_searched_count := mainframes_searched_count_p^;
      NEXT mainframes_searched_list_p IN received_from_client_params_p;
      mainframes_searched_list := mainframes_searched_list_p^;

      unpack_job_message (received_from_client_params_p, received_from_client_data_p, job_message, status);

      IF status.normal THEN
        pmp$get_mainframe_id (current_mainframe_id, {ignore} status);
        IF current_mainframe_id = target_mainframe_id_p^ THEN
          send_job_message (job_message, status);
          NEXT target_mainframe_reached_p IN send_to_client_params_p;
          target_mainframe_reached_p^ := TRUE;
        ELSE
          IF target_mainframe_id_p^ = pmc$null_mainframe_id THEN
            send_job_message (job_message, status);
          IFEND;
          mainframes_searched_count := mainframes_searched_count + 1;
          pmp$get_pseudo_mainframe_id (mainframes_searched_list [mainframes_searched_count]);
          send_indirect_job_message (target_mainframe_id_p^, job_message, mainframes_searched_count,
                mainframes_searched_list, target_mainframe_reached, status);

          NEXT target_mainframe_reached_p IN send_to_client_params_p;
          target_mainframe_reached_p^ := target_mainframe_reached;
          IF NOT target_mainframe_reached THEN
            NEXT mainframes_searched_count_p IN send_to_client_params_p;
            NEXT mainframes_searched_list_p IN send_to_client_params_p;
            mainframes_searched_count_p^ := mainframes_searched_count;
            mainframes_searched_list_p^ := mainframes_searched_list;
          IFEND;
        IFEND;
      IFEND; { unpack - status.normal
    END /process_remote_procedure_call/;
    parameter_size := i#current_sequence_position (send_to_client_params_p);
    data_size := i#current_sequence_position (send_to_client_data_p);

  PROCEND jmp$server_send_job_message;
?? OLDTITLE ??
MODEND jmm$job_message_management;

*DECK DECK=JMM$JOB_MGMT_MISC_SERVICES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Job Management Miscellaineous Services' ??
MODULE jmm$job_mgmt_misc_services;

{ PURPOSE:
{   This module contains routines that are of a specific nature, unrelated to
{   other routines in a specific part of job management.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc jmc$get_input_attributes
*copyc jmc$get_job_status
*copyc jmc$get_output_attributes
*copyc jmc$get_output_status
*copyc jmc$job_management_id
*copyc jmd$job_resource_condition
*copyc jme$duplicate_attribute_key
*copyc jme$invalid_parameter
*copyc jme$unknown_requestor
*copyc jme$work_area_too_small
*copyc jmt$attribute_keys_set
*copyc jmt$attribute_values
*copyc jmt$full_job_category_list
*copyc jmt$job_status_count
*copyc jmt$results
*copyc jmt$results_keys
*copyc jmt$work_area
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc oss$task_shared
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*copyc clp$validate_name
*copyc jmp$get_attribute_name
*copyc jmp$validate_name
*copyc mmp$create_user_segment
*copyc osp$append_status_parameter
*copyc osp$force_access_violation
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    jmv$job_management_work_area_p: [XDCL, STATIC, oss$task_private] ^jmt$work_area := NIL,
    jmv$job_resource_condition: [XDCL, #GATE, oss$task_shared] jmt$job_resource_condition;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$copy_seq_to_result_array', EJECT ??

{ PURPOSE:
{   The purpose of this request is to copy the data in the results sequence
{   to the results array.

  PROCEDURE [XDCL] jmp$copy_seq_to_result_array
    (    number_of_keys: ost$positive_integers;
         number_of_packets_in_sequence: ost$non_negative_integers,
         results_keys_p: ^jmt$results_keys;
     VAR jm_work_area_p: ^jmt$work_area;
     VAR user_work_area_p: ^jmt$work_area;
     VAR status: ost$status);

    VAR
      boolean_p: ^boolean,
      copies_p: ^jmt$output_copy_count,
      cpu_time_limit_p: ^jmt$cpu_time_limit,
      cpu_time_used_p: ^jmt$cpu_time_used,
      data_mode_p: ^jmt$data_mode,
      date_time_p: ^jmt$date_time,
      device_type_p: ^jmt$output_device_type,
      display_message_p: ^jmt$display_message,
      external_characteristics_p: ^jmt$external_characteristics,
      file_position_p: ^jmt$output_file_position,
      file_size_p: ^jmt$output_file_size,
      forms_code_p: ^jmt$forms_code,
      input_file_location_p: ^jmt$input_file_location,
      internal_index_p: ^integer,
      job_abort_disposition_p: ^jmt$job_abort_disposition,
      job_category_count_p: ^jmt$job_category_count,
      job_category_index: jmt$job_category_count,
      job_category_list_p: ^jmt$full_job_category_list,
      job_class_position_p: ^jmt$job_status_count,
      job_initiation_time_p: ^jmt$date_time,
      job_mode_p: ^jmt$job_mode,
      job_qualifier_list_p: ^jmt$job_qualifier_list,
      job_recovery_disposition_p: ^jmt$job_recovery_disposition,
      job_size_p: ^jmt$job_size,
      job_state_p: ^jmt$job_state,
      magnetic_tape_limit_p: ^jmt$magnetic_tape_limit,
      mainframe_id_p: ^pmt$mainframe_id,
      maximum_working_set_p: ^jmt$working_set_size,
      message_column: integer,
      name_value_p: ^ost$name,
      operator_action_posted_p: ^boolean,
      os_date_time_p: ^ost$date_time,
      output_disposition_key_p: ^jmt$output_disposition_keys,
      output_disposition_path_p: ^fst$path,
      output_state_p: ^jmt$output_state,
      packet_number: ost$positive_integers,
      page_faults_p: ^jmt$page_faults,
      remote_host_directive_p: ^jmt$remote_host_directive,
      result_index: ost$positive_integers,
      results_p: ^jmt$results,
      ring_p: ^ost$ring,
      site_information_p: ^jmt$site_information,
      sru_limit_p: ^jmt$sru_limit,
      system_file_name_p: ^jmt$system_supplied_name,
      system_job_name_p: ^jmt$system_supplied_name,
      time_increment_p: ^jmt$time_increment,
      user_information_p: ^jmt$user_information,
      vertical_print_density_p: ^jmt$vertical_print_density;


    status.normal := TRUE;

    NEXT results_p: [1 .. number_of_packets_in_sequence] IN user_work_area_p;
    IF results_p = NIL THEN
      osp$set_status_condition (jme$work_area_too_small, status);
      RETURN;
    IFEND;

  /copy_the_data_for_each_packet/
    FOR packet_number := 1 TO number_of_packets_in_sequence DO
      NEXT results_p^ [packet_number]: [1 .. number_of_keys] IN user_work_area_p;
      IF results_p^ [packet_number] = NIL THEN
        osp$set_status_condition (jme$work_area_too_small, status);
        RETURN;
      IFEND;

    /fill_in_each_result_field/
      FOR result_index := 1 TO number_of_keys DO
        results_p^ [packet_number]^ [result_index].key := results_keys_p^ [result_index];
        CASE results_keys_p^ [result_index] OF

        = jmc$client_mainframe_id =
          NEXT mainframe_id_p IN jm_work_area_p;
          IF mainframe_id_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].client_mainframe_id := mainframe_id_p^;

        = jmc$comment_banner =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].comment_banner := name_value_p^;

        = jmc$control_family =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].control_family := name_value_p^;

        = jmc$control_user =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].control_user := name_value_p^;

        = jmc$copies =
          NEXT copies_p IN jm_work_area_p;
          IF copies_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].copies := copies_p^;

        = jmc$copies_printed =
          NEXT copies_p IN jm_work_area_p;
          IF copies_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].copies_printed := copies_p^;

        = jmc$cpu_time_limit =
          NEXT cpu_time_limit_p IN jm_work_area_p;
          IF cpu_time_limit_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].cpu_time_limit := cpu_time_limit_p^;

        = jmc$cpu_time_used =
          NEXT cpu_time_used_p IN jm_work_area_p;
          IF cpu_time_used_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].cpu_time_used := cpu_time_used_p^;

        = jmc$data_mode =
          NEXT data_mode_p IN jm_work_area_p;
          IF data_mode_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].data_mode := data_mode_p^;

        = jmc$device =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].device := name_value_p^;

        = jmc$device_type =
          NEXT device_type_p IN jm_work_area_p;
          IF device_type_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].device_type := device_type_p^;

        = jmc$display_message =
          NEXT display_message_p IN jm_work_area_p;
          IF display_message_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          FOR message_column := 1 TO display_message_p^.size DO
            CASE display_message_p^.value(message_column) OF
            = $CHAR (0) .. $CHAR (31), $CHAR (127) =
              display_message_p^.value(message_column) := '?';
            ELSE
              ;
            CASEND;
          FOREND;
          NEXT results_p^ [packet_number]^ [result_index].display_message IN user_work_area_p;
          IF results_p^ [packet_number]^ [result_index].display_message = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].display_message^ := display_message_p^;

        = jmc$earliest_print_time =
          NEXT date_time_p IN jm_work_area_p;
          IF date_time_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].earliest_print_time := date_time_p^;

        = jmc$earliest_run_time =
          NEXT date_time_p IN jm_work_area_p;
          IF date_time_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].earliest_run_time := date_time_p^;

        = jmc$external_characteristics =
          NEXT external_characteristics_p IN jm_work_area_p;
          IF external_characteristics_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].external_characteristics := external_characteristics_p^;

        = jmc$file_position =
          NEXT file_position_p IN jm_work_area_p;
          IF file_position_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].file_position := file_position_p^;

        = jmc$file_size =
          NEXT file_size_p IN jm_work_area_p;
          IF file_size_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].file_size := file_size_p^;

        = jmc$forms_code =
          NEXT forms_code_p IN jm_work_area_p;
          IF forms_code_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].forms_code := forms_code_p^;

        = jmc$input_file_location =
          NEXT input_file_location_p IN jm_work_area_p;
          IF input_file_location_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].input_file_location := input_file_location_p^;

        = jmc$internal_index =
          NEXT internal_index_p IN jm_work_area_p;
          IF internal_index_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].internal_index := internal_index_p^;

        = jmc$job_abort_disposition =
          NEXT job_abort_disposition_p IN jm_work_area_p;
          IF job_abort_disposition_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].job_abort_disposition := job_abort_disposition_p^;

        = jmc$job_category_list =
          NEXT job_category_count_p IN jm_work_area_p;
          IF job_category_count_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          NEXT job_category_list_p IN jm_work_area_p;
          IF job_category_list_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].job_category_list.category_count :=
                job_category_count_p^;
          IF job_category_count_p^ > 0 THEN
            NEXT results_p^ [packet_number]^ [result_index].job_category_list.category_list:
                  [1 .. job_category_count_p^] IN user_work_area_p;
            IF results_p^ [packet_number]^ [result_index].job_category_list.category_list = NIL THEN
              osp$set_status_condition (jme$work_area_too_small, status);
              RETURN;
            IFEND;
            FOR job_category_index := 1 TO job_category_count_p^ DO
              results_p^ [packet_number]^ [result_index].job_category_list.
                    category_list^ [job_category_index] := job_category_list_p^ [job_category_index];
            FOREND;
          IFEND;

        = jmc$job_class =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].job_class := name_value_p^;

        = jmc$job_class_position =
          NEXT job_class_position_p IN jm_work_area_p;
          IF job_class_position_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].job_class_position := job_class_position_p^;

        = jmc$job_deferred_by_operator =
          NEXT boolean_p IN jm_work_area_p;
          IF boolean_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].job_deferred_by_operator := boolean_p^;

        = jmc$job_deferred_by_user =
          NEXT boolean_p IN jm_work_area_p;
          IF boolean_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].job_deferred_by_user := boolean_p^;

        = jmc$job_destination_family =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].job_destination_family := name_value_p^;

        = jmc$job_destination_usage =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].job_destination_usage := name_value_p^;

        = jmc$job_execution_ring =
          NEXT ring_p IN jm_work_area_p;
          IF ring_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].job_execution_ring := ring_p^;

        = jmc$job_initiation_time =
          NEXT job_initiation_time_p IN jm_work_area_p;
          IF job_initiation_time_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].job_initiation_time := job_initiation_time_p^;

        = jmc$job_mode =
          NEXT job_mode_p IN jm_work_area_p;
          IF job_mode_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].job_mode := job_mode_p^;

        = jmc$job_qualifier_list =
          NEXT job_qualifier_list_p: [1 .. jmc$maximum_job_qualifiers] IN jm_work_area_p;
          IF job_qualifier_list_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          NEXT results_p^ [packet_number]^ [result_index].job_qualifier_list:
                [1 .. jmc$maximum_job_qualifiers] IN user_work_area_p;
          IF results_p^ [packet_number]^ [result_index].job_qualifier_list = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].job_qualifier_list^ := job_qualifier_list_p^;

        = jmc$job_recovery_disposition =
          NEXT job_recovery_disposition_p IN jm_work_area_p;
          IF job_recovery_disposition_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].job_recovery_disposition := job_recovery_disposition_p^;

        = jmc$job_state =
          NEXT job_state_p IN jm_work_area_p;
          IF job_state_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].job_state := job_state_p^;

        = jmc$job_size =
          NEXT job_size_p IN jm_work_area_p;
          IF job_size_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].job_size := job_size_p^;

        = jmc$job_submission_time =
          NEXT os_date_time_p IN jm_work_area_p;
          IF os_date_time_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].job_submission_time := os_date_time_p^;

        = jmc$latest_print_time =
          NEXT date_time_p IN jm_work_area_p;
          IF date_time_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].latest_print_time := date_time_p^;

        = jmc$latest_run_time =
          NEXT date_time_p IN jm_work_area_p;
          IF date_time_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].latest_run_time := date_time_p^;

        = jmc$login_account =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].login_account := name_value_p^;

        = jmc$login_family =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].login_family := name_value_p^;

        = jmc$login_project =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].login_project := name_value_p^;

        = jmc$login_user =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].login_user := name_value_p^;

        = jmc$magnetic_tape_limit =
          NEXT magnetic_tape_limit_p IN jm_work_area_p;
          IF magnetic_tape_limit_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].magnetic_tape_limit := magnetic_tape_limit_p^;

        = jmc$maximum_working_set =
          NEXT maximum_working_set_p IN jm_work_area_p;
          IF maximum_working_set_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].maximum_working_set := maximum_working_set_p^;

        = jmc$null_attribute =
          ;

        = jmc$operator_action_posted =
          NEXT operator_action_posted_p IN jm_work_area_p;
          IF operator_action_posted_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].operator_action_posted := operator_action_posted_p^;

        = jmc$origin_application_name =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].origin_application_name := name_value_p^;

        = jmc$output_class =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].output_class := name_value_p^;

        = jmc$output_deferred_by_operator =
          NEXT boolean_p IN jm_work_area_p;
          IF boolean_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].output_deferred_by_operator := boolean_p^;

        = jmc$output_deferred_by_user =
          NEXT boolean_p IN jm_work_area_p;
          IF boolean_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].output_deferred_by_user := boolean_p^;

        = jmc$output_destination =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].output_destination := name_value_p^;

        = jmc$output_destination_family = { operator_family
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].output_destination_family := name_value_p^;

        = jmc$output_destination_usage =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].output_destination_usage := name_value_p^;

        = jmc$output_disposition =
          NEXT output_disposition_key_p IN jm_work_area_p;
          IF output_disposition_key_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          NEXT output_disposition_path_p IN jm_work_area_p;
          IF output_disposition_path_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].output_disposition.key := output_disposition_key_p^;
          IF output_disposition_key_p^ = jmc$standard_output_path THEN
            NEXT results_p^ [packet_number]^ [result_index].output_disposition.standard_output_path IN
                  user_work_area_p;
            IF results_p^ [packet_number]^ [result_index].output_disposition.standard_output_path = NIL THEN
              osp$set_status_condition (jme$work_area_too_small, status);
              RETURN;
            IFEND;
            results_p^ [packet_number]^ [result_index].output_disposition.standard_output_path^ :=
                  output_disposition_path_p^;
          ELSEIF output_disposition_key_p^ = jmc$wait_queue_path THEN
            results_p^ [packet_number]^ [result_index].output_disposition.wait_queue_path := NIL;
          IFEND;

        = jmc$output_priority =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].output_priority := name_value_p^;

        = jmc$output_state =
          NEXT output_state_p IN jm_work_area_p;
          IF output_state_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].output_state := output_state_p^;

        = jmc$output_submission_time =
          NEXT os_date_time_p IN jm_work_area_p;
          IF os_date_time_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].output_submission_time := os_date_time_p^;

        = jmc$page_faults =
          NEXT page_faults_p IN jm_work_area_p;
          IF page_faults_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].page_faults := page_faults_p^;

        = jmc$purge_delay =
          NEXT time_increment_p IN jm_work_area_p;
          IF time_increment_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          NEXT results_p^ [packet_number]^ [result_index].purge_delay IN user_work_area_p;
          IF results_p^ [packet_number]^ [result_index].purge_delay = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].purge_delay^ := time_increment_p^;

        = jmc$remote_host_directive =
          NEXT remote_host_directive_p IN jm_work_area_p;
          IF remote_host_directive_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          NEXT results_p^ [packet_number]^ [result_index].remote_host_directive IN user_work_area_p;
          IF results_p^ [packet_number]^ [result_index].remote_host_directive = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].remote_host_directive^ := remote_host_directive_p^;

        = jmc$routing_banner =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].routing_banner := name_value_p^;

        = jmc$server_mainframe_id =
          NEXT mainframe_id_p IN jm_work_area_p;
          IF mainframe_id_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].server_mainframe_id := mainframe_id_p^;

        = jmc$site_information =
          NEXT site_information_p IN jm_work_area_p;
          IF site_information_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          NEXT results_p^ [packet_number]^ [result_index].site_information IN user_work_area_p;
          IF results_p^ [packet_number]^ [result_index].site_information = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].site_information^ := site_information_p^;

        = jmc$sru_limit =
          NEXT sru_limit_p IN jm_work_area_p;
          IF sru_limit_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].sru_limit := sru_limit_p^;

        = jmc$station =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].station := name_value_p^;

        = jmc$station_operator = { operator_user
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].station_operator := name_value_p^;

        = jmc$system_file_name =
          NEXT system_file_name_p IN jm_work_area_p;
          IF system_file_name_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].system_file_name := system_file_name_p^;

        = jmc$system_job_name =
          NEXT system_job_name_p IN jm_work_area_p;
          IF system_job_name_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].system_job_name := system_job_name_p^;

        = jmc$user_file_name =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].user_file_name := name_value_p^;

        = jmc$user_information =
          NEXT user_information_p IN jm_work_area_p;
          IF user_information_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          NEXT results_p^ [packet_number]^ [result_index].user_information IN user_work_area_p;
          IF results_p^ [packet_number]^ [result_index].user_information = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].user_information^ := user_information_p^;

        = jmc$user_job_name =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].user_job_name := name_value_p^;

        = jmc$vertical_print_density =
          NEXT vertical_print_density_p IN jm_work_area_p;
          IF vertical_print_density_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].vertical_print_density := vertical_print_density_p^;

        = jmc$vfu_load_procedure =
          NEXT name_value_p IN jm_work_area_p;
          IF name_value_p = NIL THEN
            osp$set_status_condition (jme$work_area_too_small, status);
            RETURN;
          IFEND;
          results_p^ [packet_number]^ [result_index].vfu_load_procedure := name_value_p^;

        ELSE
        CASEND;
      FOREND /fill_in_each_result_field/;
    FOREND /copy_the_data_for_each_packet/;

  PROCEND jmp$copy_seq_to_result_array;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$get_data_packet_size', EJECT ??

{ PURPOSE:
{   The purpose of this request is to get the size of a group of result keys.
{   The result keys are input or output queue file attributes.

  PROCEDURE [XDCL] jmp$get_data_packet_size
    (    results_keys_p: ^jmt$results_keys;
     VAR data_packet_size: ost$segment_length;
     VAR status: ost$status);

{ Cybil is not allowing #SIZE of ost$name and some other types.  PSR CILB533 has
{ been written (8/1/90).  The first set of variable declarations below have
{ been made as a work-around.

    VAR
      name: ost$name,
      output_device: jmt$output_device,
      job_class_name: jmt$job_class_name,
      destination_usage: jmt$destination_usage,
      output_class_name: jmt$output_class_name,
      output_priority: jmt$output_priority,
      station: jmt$station,
      station_operator: jmt$station_operator,
      user_supplied_name: jmt$user_supplied_name,
      vfu_load_procedure: jmt$vfu_load_procedure;

    VAR
      result_index: ost$non_negative_integers,
      scl_name: ost$name;


    status.normal := TRUE;
    data_packet_size := 0;

    FOR result_index := 1 TO UPPERBOUND (results_keys_p^) DO
      CASE results_keys_p^ [result_index] OF
      = jmc$client_mainframe_id, jmc$server_mainframe_id =
        data_packet_size := data_packet_size + #SIZE (pmt$mainframe_id);
      = jmc$comment_banner =
        data_packet_size := data_packet_size + #SIZE (jmt$output_comment_banner);
      = jmc$control_family, jmc$control_user, jmc$job_destination_family, jmc$login_account, jmc$login_family,
            jmc$login_project, jmc$login_user, jmc$origin_application_name, jmc$output_destination,
            jmc$output_destination_family { operator_family } =
        data_packet_size := data_packet_size + #SIZE (name);
      = jmc$copies, jmc$copies_printed =
        data_packet_size := data_packet_size + #SIZE (jmt$output_copy_count);
      = jmc$cpu_time_limit =
        data_packet_size := data_packet_size + #SIZE (jmt$cpu_time_limit);
      = jmc$cpu_time_used =
        data_packet_size := data_packet_size + #SIZE (jmt$cpu_time_used);
      = jmc$data_mode =
        data_packet_size := data_packet_size + #SIZE (jmt$data_mode);
      = jmc$device =
        data_packet_size := data_packet_size + #SIZE (output_device);
      = jmc$device_type =
        data_packet_size := data_packet_size + #SIZE (jmt$output_device_type);
      = jmc$display_message =
        data_packet_size := data_packet_size + #SIZE (jmt$display_message);
      = jmc$earliest_print_time, jmc$earliest_run_time, jmc$job_initiation_time, jmc$latest_print_time,
            jmc$latest_run_time =
        data_packet_size := data_packet_size + #SIZE (jmt$date_time);
      = jmc$external_characteristics =
        data_packet_size := data_packet_size + #SIZE (jmt$external_characteristics);
      = jmc$file_position =
        data_packet_size := data_packet_size + #SIZE (jmt$output_file_position);
      = jmc$file_size =
        data_packet_size := data_packet_size + #SIZE (jmt$output_file_size);
      = jmc$forms_code =
        data_packet_size := data_packet_size + #SIZE (jmt$forms_code);
      = jmc$input_file_location =
        data_packet_size := data_packet_size + #SIZE (jmt$input_file_location);
      = jmc$internal_index =
        data_packet_size := data_packet_size + #SIZE (integer);
      = jmc$job_abort_disposition =
        data_packet_size := data_packet_size + #SIZE (jmt$job_abort_disposition);
      = jmc$job_category_list =
        data_packet_size := data_packet_size + #SIZE (jmt$job_category_count) +
              #SIZE (jmt$full_job_category_list);
      = jmc$job_class =
        data_packet_size := data_packet_size + #SIZE (job_class_name);
      = jmc$job_class_position =
        data_packet_size := data_packet_size + #SIZE (jmt$job_count_range);
      = jmc$job_deferred_by_operator, jmc$job_deferred_by_user, jmc$operator_action_posted,
            jmc$output_deferred_by_operator, jmc$output_deferred_by_user =
        data_packet_size := data_packet_size + #SIZE (boolean);
      = jmc$job_destination_usage, jmc$output_destination_usage =
        data_packet_size := data_packet_size + #SIZE (destination_usage);
      = jmc$job_execution_ring =
        data_packet_size := data_packet_size + #SIZE (ost$ring);
      = jmc$job_mode =
        data_packet_size := data_packet_size + #SIZE (jmt$job_mode);
      = jmc$job_qualifier_list =
        data_packet_size := data_packet_size + #SIZE (jmt$job_qualifier_list:
              [1 .. jmc$maximum_job_qualifiers]);
      = jmc$job_recovery_disposition =
        data_packet_size := data_packet_size + #SIZE (jmt$job_recovery_disposition);
      = jmc$job_state =
        data_packet_size := data_packet_size + #SIZE (jmt$job_state);
      = jmc$job_size =
        data_packet_size := data_packet_size + #SIZE (jmt$job_size);
      = jmc$job_submission_time, jmc$output_submission_time =
        data_packet_size := data_packet_size + #SIZE (ost$date_time);
      = jmc$magnetic_tape_limit =
        data_packet_size := data_packet_size + #SIZE (jmt$magnetic_tape_limit);
      = jmc$maximum_working_set =
        data_packet_size := data_packet_size + #SIZE (jmt$working_set_size);
      = jmc$null_attribute =
        ;
      = jmc$output_class =
        data_packet_size := data_packet_size + #SIZE (output_class_name);
      = jmc$output_disposition =
        data_packet_size := data_packet_size + #SIZE (jmt$output_disposition_keys) + #SIZE (fst$path);
      = jmc$output_priority =
        data_packet_size := data_packet_size + #SIZE (output_priority);
      = jmc$output_state =
        data_packet_size := data_packet_size + #SIZE (jmt$output_state);
      = jmc$page_faults =
        data_packet_size := data_packet_size + #SIZE (jmt$page_faults);
      = jmc$purge_delay =
        data_packet_size := data_packet_size + #SIZE (jmt$time_increment);
      = jmc$remote_host_directive =
        data_packet_size := data_packet_size + #SIZE (jmt$remote_host_directive);
      = jmc$routing_banner =
        data_packet_size := data_packet_size + #SIZE (jmt$output_routing_banner);
      = jmc$site_information =
        data_packet_size := data_packet_size + #SIZE (jmt$site_information);
      = jmc$sru_limit =
        data_packet_size := data_packet_size + #SIZE (jmt$sru_limit);
      = jmc$station =
        data_packet_size := data_packet_size + #SIZE (station);
      = jmc$station_operator = { operator_user
        data_packet_size := data_packet_size + #SIZE (station_operator);
      = jmc$system_file_name, jmc$system_job_name =
        data_packet_size := data_packet_size + #SIZE (jmt$system_supplied_name);
      = jmc$user_file_name, jmc$user_job_name =
        data_packet_size := data_packet_size + #SIZE (user_supplied_name);
      = jmc$user_information =
        data_packet_size := data_packet_size + #SIZE (jmt$user_information);
      = jmc$vertical_print_density =
        data_packet_size := data_packet_size + #SIZE (jmt$vertical_print_density);
      = jmc$vfu_load_procedure =
        data_packet_size := data_packet_size + #SIZE (vfu_load_procedure);
      ELSE

{ Should never get here since the caller validates the result keys.

        jmp$get_attribute_name (results_keys_p^ [result_index], scl_name);
        osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'RESULTS_KEYS_P', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'JMP$GET_DATA_PACKET_SIZE', status);
        RETURN;
      CASEND;

    FOREND;

  PROCEND jmp$get_data_packet_size;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$get_jm_work_area', EJECT ??
*copyc jmh$get_jm_work_area

  PROCEDURE [XDCL] jmp$get_jm_work_area
    (VAR jm_work_area_p: ^jmt$work_area;
     VAR status: ost$status);

    VAR
      segment_pointer: amt$segment_pointer,
      user_segment_attributes: array [1 .. 1] of mmt$user_attribute_descriptor;

    status.normal := TRUE;

    IF jmv$job_management_work_area_p = NIL THEN
      user_segment_attributes [1].keyword := mmc$ua_ring_numbers;
      user_segment_attributes [1].r1 := osc$tsrv_ring;
      user_segment_attributes [1].r2 := osc$tsrv_ring;
      mmp$create_user_segment (^user_segment_attributes, amc$sequence_pointer, mmc$as_sequential,
            segment_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      jmv$job_management_work_area_p := segment_pointer.sequence_pointer;
    IFEND;
    jm_work_area_p := jmv$job_management_work_area_p;

  PROCEND jmp$get_jm_work_area;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$set_job_resource_condition', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$set_job_resource_condition
    (    condition: jmt$job_resource_condition;
     VAR status: ost$status);

    status.normal := TRUE;
    jmv$job_resource_condition := condition;
  PROCEND jmp$set_job_resource_condition;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$validate_status_options' ??
?? EJECT ??

{ PURPOSE:
{   The purpose of this request is to validate input or output queue file
{   status options and their values and to reduce the set of options to only
{   those that are necesary.

  PROCEDURE [XDCL] jmp$validate_status_options
    (    request_name: string ( * );
         parameter_name: string ( * );
         options_seq_p: ^SEQ ( * );
         caller_privileged: boolean;
     VAR privileged_job: boolean;
     VAR user_identification: ost$user_identification;
     VAR continue_request_to_servers: boolean;
     VAR number_of_valid_options: ost$non_negative_integers;
     VAR target_options_seq_p: ^jmt$work_area;
     VAR status: ost$status);

    TYPE
      valid_requests = (jmp$get_job_status, jmp$get_output_status);

    VAR
      option_valid_for_request: [STATIC, READ, oss$job_paged_literal] array [valid_requests] of
            jmt$attribute_keys_set := [$jmt$attribute_keys_set
            [jmc$continue_request_to_servers, jmc$control_family, jmc$control_user,
            jmc$job_deferred_by_operator, jmc$job_deferred_by_user, jmc$include_the_system_job,
            jmc$job_mode_set, jmc$job_state_set, jmc$login_family, jmc$login_user, jmc$name_list,
            jmc$null_attribute, jmc$privilege, jmc$user_identification],
            $jmt$attribute_keys_set [jmc$continue_request_to_servers, jmc$control_family, jmc$control_user,
            jmc$login_family, jmc$login_user, jmc$name_list, jmc$null_attribute,
            jmc$output_deferred_by_operator, jmc$output_deferred_by_user, jmc$output_destination_usage,
            jmc$output_state_set, jmc$privilege, jmc$system_job_name, jmc$user_identification,
            jmc$user_job_name]];


    VAR
      good_name: jmt$name,
      name_count_p: ^ost$non_negative_integers,
      name_index: ost$positive_integers,
      number_of_options: ost$non_negative_integers,
      option_index: ost$positive_integers,
      options_p: ^jmt$attribute_values,
      request: valid_requests,
      scl_name: ost$name,
      seq_p: ^SEQ ( * ),
      specified_keys: jmt$attribute_keys_set,
      valid_name: boolean,
      valid_option_index: ost$non_negative_integers,
      valid_options_p: ^jmt$attribute_values;


    status.normal := TRUE;
    continue_request_to_servers := FALSE;
    number_of_valid_options := 0;

    IF options_seq_p <> NIL THEN
      seq_p := options_seq_p;
      number_of_options := #SIZE (seq_p^) DIV #SIZE (jmt$attribute_values: [1 .. 1]);
      IF number_of_options > 0 THEN
        NEXT options_p: [1 .. number_of_options] IN seq_p;

        IF request_name = jmc$get_job_status THEN
          request := jmp$get_job_status;
        ELSEIF request_name = jmc$get_output_status THEN
          request := jmp$get_output_status;
        ELSE

          osp$set_status_abnormal (jmc$job_management_id, jme$unknown_requestor, request_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'JMP$VALIDATE_STATUS_OPTIONS', status);
          RETURN;
        IFEND;

        specified_keys := $jmt$attribute_keys_set [];

        FOR option_index := 1 TO UPPERBOUND (options_p^) DO
          IF options_p^ [option_index].key IN specified_keys THEN
            jmp$get_attribute_name (options_p^ [option_index].key, scl_name);
            osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_attribute_key, scl_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, parameter_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, request_name, status);
            RETURN;
          IFEND;

          IF options_p^ [option_index].key <> jmc$null_attribute THEN
            IF NOT (options_p^ [option_index].key IN option_valid_for_request [request]) THEN
              jmp$get_attribute_name (options_p^ [option_index].key, scl_name);
              osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, parameter_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, request_name, status);
              RETURN;
            IFEND;

            specified_keys := specified_keys + $jmt$attribute_keys_set [options_p^ [option_index].key];
            IF (options_p^ [option_index].key = jmc$continue_request_to_servers) THEN
              continue_request_to_servers := options_p^ [option_index].continue_request_to_servers;
            ELSEIF (options_p^ [option_index].key = jmc$privilege) THEN
              IF caller_privileged THEN
                IF options_p^ [option_index].privilege = jmc$privileged THEN
                  privileged_job := TRUE;
                ELSEIF options_p^ [option_index].privilege = jmc$not_privileged THEN
                  privileged_job := FALSE;
                IFEND;
              IFEND;
            ELSEIF (options_p^ [option_index].key = jmc$user_identification) THEN
              IF caller_privileged THEN
                user_identification := options_p^ [option_index].user_identification^;
              ELSE
                osp$force_access_violation;
              IFEND;
            ELSE
              number_of_valid_options := number_of_valid_options + 1;
            IFEND;
          IFEND;
        FOREND;

        IF number_of_valid_options > 0 THEN
          NEXT valid_options_p: [1 .. number_of_valid_options] IN target_options_seq_p;
          valid_option_index := 0;
          FOR option_index := 1 TO UPPERBOUND (options_p^) DO
            CASE options_p^ [option_index].key OF
            = jmc$continue_request_to_servers, jmc$null_attribute, jmc$privilege, jmc$user_identification =
              ;

            = jmc$control_family =
              clp$validate_name (options_p^ [option_index].control_family, scl_name, valid_name);
              IF NOT valid_name THEN
                osp$set_status_abnormal ('CL', cle$improper_name, options_p^ [option_index].control_family,
                      status);
                RETURN;
              IFEND;

              valid_option_index := valid_option_index + 1;
              valid_options_p^ [valid_option_index].key := options_p^ [option_index].key;
              valid_options_p^ [valid_option_index].control_family := scl_name;

            = jmc$control_user =
              clp$validate_name (options_p^ [option_index].control_user, scl_name, valid_name);
              IF NOT valid_name THEN
                osp$set_status_abnormal ('CL', cle$improper_name, options_p^ [option_index].control_user,
                      status);
                RETURN;
              IFEND;

              valid_option_index := valid_option_index + 1;
              valid_options_p^ [valid_option_index].key := options_p^ [option_index].key;
              valid_options_p^ [valid_option_index].control_user := scl_name;

            = jmc$job_deferred_by_operator, jmc$job_deferred_by_user, jmc$include_the_system_job,
                  jmc$job_mode_set, jmc$job_state_set, jmc$output_deferred_by_operator,
                  jmc$output_deferred_by_user, jmc$output_state_set =
              valid_option_index := valid_option_index + 1;
              valid_options_p^ [valid_option_index] := options_p^ [option_index];

            = jmc$login_family =
              clp$validate_name (options_p^ [option_index].login_family, scl_name, valid_name);
              IF NOT valid_name THEN
                osp$set_status_abnormal ('CL', cle$improper_name, options_p^ [option_index].login_family,
                      status);
                RETURN;
              IFEND;

              valid_option_index := valid_option_index + 1;
              valid_options_p^ [valid_option_index].key := options_p^ [option_index].key;
              valid_options_p^ [valid_option_index].login_family := scl_name;

            = jmc$login_user =
              clp$validate_name (options_p^ [option_index].login_user, scl_name, valid_name);
              IF NOT valid_name THEN
                osp$set_status_abnormal ('CL', cle$improper_name, options_p^ [option_index].login_user,
                      status);
                RETURN;
              IFEND;

              valid_option_index := valid_option_index + 1;
              valid_options_p^ [valid_option_index].key := options_p^ [option_index].key;
              valid_options_p^ [valid_option_index].login_user := scl_name;

            = jmc$name_list =
              valid_option_index := valid_option_index + 1;
              valid_options_p^ [valid_option_index].key := jmc$name_list;
              NEXT name_count_p IN target_options_seq_p;

              IF options_p^ [option_index].name_list <> NIL THEN
                name_count_p^ := UPPERBOUND (options_p^ [option_index].name_list^);
                NEXT valid_options_p^ [valid_option_index].name_list: [1 .. name_count_p^] IN
                      target_options_seq_p;
                FOR name_index := 1 TO name_count_p^ DO
                  jmp$validate_name (options_p^ [option_index].name_list^ [name_index], good_name, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;

                  valid_options_p^ [valid_option_index].name_list^ [name_index] := good_name;
                FOREND;
              ELSE
                name_count_p^ := 0;
              IFEND;

            = jmc$output_destination_usage =
              clp$validate_name (options_p^ [option_index].output_destination_usage, scl_name, valid_name);
              IF NOT valid_name THEN
                osp$set_status_abnormal ('CL', cle$improper_name,
                      options_p^ [option_index].output_destination_usage, status);
                RETURN;
              IFEND;

              valid_option_index := valid_option_index + 1;
              valid_options_p^ [valid_option_index].key := options_p^ [option_index].key;
              valid_options_p^ [valid_option_index].output_destination_usage := scl_name;

            = jmc$system_job_name =
              good_name.kind := jmc$system_supplied_name;
              good_name.system_supplied_name := options_p^ [option_index].system_job_name;
              jmp$validate_name (good_name, good_name, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              valid_option_index := valid_option_index + 1;
              valid_options_p^ [valid_option_index].key := options_p^ [option_index].key;
              valid_options_p^ [valid_option_index].system_job_name := good_name.system_supplied_name;

            = jmc$user_job_name =
              clp$validate_name (options_p^ [option_index].user_job_name, scl_name, valid_name);
              IF NOT valid_name THEN
                osp$set_status_abnormal ('CL', cle$improper_name, options_p^ [option_index].user_job_name,
                      status);
                RETURN;
              IFEND;

              valid_option_index := valid_option_index + 1;
              valid_options_p^ [valid_option_index].key := options_p^ [option_index].key;
              valid_options_p^ [valid_option_index].user_job_name := scl_name;

            ELSE
            CASEND
          FOREND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND jmp$validate_status_options;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$validate_attribute_options' ??
?? EJECT ??

{ PURPOSE:
{   The purpose of this request is to validate input or output queue file
{   attribute options and to reduce the set of options to only those that are
{   necessary.

  PROCEDURE [XDCL] jmp$validate_attribute_options
    (    request_name: string ( * );
         parameter_name: string ( * );
         options_seq_p: ^SEQ ( * );
         number_of_options_to_add: ost$non_negative_integers;
     VAR continue_request_to_servers: boolean;
     VAR number_of_valid_options: ost$non_negative_integers;
     VAR target_options_seq_p: ^jmt$work_area;
     VAR status: ost$status);

    TYPE
      valid_requests = (jmp$get_input_attributes, jmp$get_output_attributes);

    VAR
      option_valid_for_request: [STATIC, READ, oss$job_paged_literal] array [valid_requests] of
            jmt$attribute_keys_set := [$jmt$attribute_keys_set
            [jmc$continue_request_to_servers, jmc$control_family, jmc$control_user,
            jmc$job_deferred_by_operator, jmc$job_deferred_by_user, jmc$job_state_set, jmc$login_family,
            jmc$login_user, jmc$name_list, jmc$null_attribute],
            $jmt$attribute_keys_set [jmc$continue_request_to_servers, jmc$control_family, jmc$control_user,
            jmc$login_family, jmc$login_user, jmc$name_list, jmc$null_attribute,
            jmc$output_deferred_by_operator, jmc$output_deferred_by_user, jmc$output_destination_usage,
            jmc$output_state_set, jmc$system_job_name, jmc$user_job_name]];


    VAR
      name_count_p: ^ost$non_negative_integers,
      number_of_options: ost$non_negative_integers,
      option_index: ost$positive_integers,
      options_p: ^jmt$attribute_values,
      request: valid_requests,
      scl_name: ost$name,
      seq_p: ^SEQ ( * ),
      specified_keys: jmt$attribute_keys_set,
      status_options_p: ^jmt$attribute_values,
      valid_option_index: ost$non_negative_integers,
      valid_options_p: ^jmt$attribute_values;


    status.normal := TRUE;
    continue_request_to_servers := FALSE;
    number_of_valid_options := 0;

    IF options_seq_p <> NIL THEN
      seq_p := options_seq_p;
      number_of_options := #SIZE (seq_p^) DIV #SIZE (jmt$attribute_values: [1 .. 1]);
      IF number_of_options > 0 THEN
        NEXT options_p: [1 .. number_of_options] IN seq_p;

        IF request_name = jmc$get_input_attributes THEN
          request := jmp$get_input_attributes;
        ELSEIF request_name = jmc$get_output_attributes THEN
          request := jmp$get_output_attributes;
        ELSE

          osp$set_status_abnormal (jmc$job_management_id, jme$unknown_requestor, request_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'JMP$VALIDATE_ATTRIBUTE_OPTIONS',
                status);
          RETURN;
        IFEND;

        specified_keys := $jmt$attribute_keys_set [];

        FOR option_index := 1 TO UPPERBOUND (options_p^) DO
          IF options_p^ [option_index].key IN specified_keys THEN
            jmp$get_attribute_name (options_p^ [option_index].key, scl_name);
            osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_attribute_key, scl_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, parameter_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, request_name, status);
            RETURN;
          IFEND;

          IF options_p^ [option_index].key <> jmc$null_attribute THEN
            IF NOT (options_p^ [option_index].key IN option_valid_for_request [request]) THEN
              jmp$get_attribute_name (options_p^ [option_index].key, scl_name);
              osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, parameter_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, request_name, status);
              RETURN;
            IFEND;

            specified_keys := specified_keys + $jmt$attribute_keys_set [options_p^ [option_index].key];
            IF (options_p^ [option_index].key = jmc$continue_request_to_servers) THEN
              continue_request_to_servers := options_p^ [option_index].continue_request_to_servers;
            ELSE
              number_of_valid_options := number_of_valid_options + 1;
            IFEND;
          IFEND;
        FOREND;
      IFEND;
    IFEND;

    IF number_of_valid_options + number_of_options_to_add > 0 THEN
      NEXT valid_options_p: [1 .. number_of_valid_options + number_of_options_to_add] IN
            target_options_seq_p;
      valid_option_index := 0;
      IF number_of_valid_options > 0 THEN
        FOR option_index := 1 TO UPPERBOUND (options_p^) DO
          CASE options_p^ [option_index].key OF
          = jmc$continue_request_to_servers, jmc$null_attribute =
            ;

          = jmc$name_list =
            valid_option_index := valid_option_index + 1;
            valid_options_p^ [valid_option_index].key := jmc$name_list;
            NEXT name_count_p IN target_options_seq_p;
            IF options_p^ [option_index].name_list <> NIL THEN
              name_count_p^ := UPPERBOUND (options_p^ [option_index].name_list^);
              NEXT valid_options_p^ [valid_option_index].name_list: [1 .. name_count_p^] IN
                    target_options_seq_p;
              valid_options_p^ [valid_option_index].name_list^ := options_p^ [option_index].name_list^;
            ELSE
              name_count_p^ := 0;
            IFEND;

          ELSE
            valid_option_index := valid_option_index + 1;
            valid_options_p^ [valid_option_index] := options_p^ [option_index];
          CASEND;
        FOREND;
      IFEND;

      number_of_valid_options := number_of_valid_options + number_of_options_to_add;
    IFEND;
  PROCEND jmp$validate_attribute_options;
?? OLDTITLE ??
MODEND jmm$job_mgmt_misc_services;
*DECK DECK=JMM$JOB_MONITOR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management job monitor routines' ??
MODULE jmm$job_monitor;

{ PURPOSE:
{   This module contains the code for a job to begin and end from within its environment.
{ This module also contains some monitoring routines for the job.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_pointer
*copyc amt$file_attributes
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc avc$system_defined_limit_names
*copyc clc$standard_file_names
*copyc cle$ecc_file_reference
*copyc dfe$error_condition_codes
*copyc dmt$system_file_id
*copyc dmt$class
*copyc jmc$job_management_id
*copyc jmc$system_family
*copyc jme$job_monitor_conditions
*copyc jme$user_requested_exit
*copyc jmk$keypoints
*copyc jml$user_id
*copyc jmt$clock_time
*copyc jmt$display_message
*copyc jmt$job_mode
*copyc jmt$job_resource_signal
*copyc jmt$job_statistics
*copyc jmt$sense_switch_signal
*copyc jmt$swap_file_user_info
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc jmv$xterm_job
*copyc mme$condition_codes
*copyc nat$wait_time
*copyc osc$dual_state_interactive
*copyc osc$timesharing
*copyc osc$timesharing_terminal_file
*copyc osc$batch_transfer_server
*copyc osc$queue_transfer_server
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc ost$date
*copyc ost$global_task_id
*copyc ost$status
*copyc ost$system_flag
*copyc ost$user_identification
*copyc ost$caller_identifier
*copyc pmt$os_name
*copyc pmt$sense_switches
?? POP ??
*copyc amp$return
*copyc avp$begin_account
*copyc avp$dual_state_prompt
*copyc avp$get_limit_value
*copyc avp$get_string_value
*copyc avp$ring_nominal
*copyc avp$security_option_active
*copyc avp$validate_job
*copyc bap$file_command
*copyc bap$inhibit_implicit_detach
*copyc clp$convert_integer_to_string
*copyc clp$get_processing_phase
*copyc clp$store_std_path_handle_names
*copyc clp$update_connected_files
*copyc clp$validate_local_file_name
*copyc cmp$subsystem_io_job_exit
*copyc dfp$check_job_recovery
*copyc dfp$process_job_end
*copyc dfp$send_remote_procedure_call
*copyc dpp$put_critical_message
*copyc fmp$get_system_file_id
*copyc fmp$initialize_path_table
*copyc fmp$job_exit
*copyc fsp$build_file_ref_from_elems
*copyc fsp$close_file
*copyc fsp$copy_file
*copyc fsp$open_file
*copyc i#current_sequence_position
*copyc i#move
*copyc ifp$job_initialize
*copyc ifp$purge_connection_io
*copyc iip$terminate_disconnected_job
*copyc jmp$add_to_server_restart_file
*copyc jmp$clone_login
*copyc jmp$delete_non_inherited_segs
*copyc jmp$determine_job_class_name
*copyc jmp$emit_communication_stat
*copyc jmp$emit_job_history_statistics
*copyc jmp$exit_job
*copyc jmp$get_ijle_p
*copyc jmp$get_server_job_end_info
*copyc jmp$initialize_job_attributes
*copyc jmp$initialize_job_local_tables
*copyc jmp$initialize_timesharing
*copyc jmp$job_is_being_leveled
*copyc jmp$print_file
*copyc jmp$save_recovery_information
*copyc jmp$save_sfid_of_swap_file
*copyc jmp$system_job
*copyc jmp$set_job_unswappable
*copyc jmp$write_recovery_info_to_disk
*copyc lgp$append_job_log_to_output
*copyc lgp$setup_access_to_local_logs
*copyc nap$parse_accounting_data
*copyc nap$process_job_termination
*copyc nap$se_synchronize
*copyc ofp$display_status_message
*copyc ofp$job_begin
*copyc ofp$job_end
*copyc ofp$screen_input_fap
*copyc ofp$screen_output_fap
*copyc osp$called_by_system_code
*copyc osp$disestablish_cond_handler
*copyc osp$enforce_exception_policies
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$force_access_violation
*copyc osp$format_message
*copyc osp$get_status_condition_name
*copyc osp$generate_log_message
*copyc osp$generate_output_message
*copyc osp$get_job_template_name
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$system_error
*copyc osp$verify_system_privilege
*copyc pfp$attach
*copyc pfp$begin_system_authority
*copyc pfp$define
*copyc pfp$define_catalog
*copyc pfp$delete_catalog_permit
*copyc pfp$end_system_authority
*copyc pfp$process_job_end
*copyc pfp$purge
*copyc pmp$continue_to_cause
*copyc pmp$convert_binary_mainframe_id
*copyc pmp$dispose_job_resource_cond
*copyc pmp$emit_job_end_statistics
*copyc pmp$exit
*copyc pmp$find_executing_task_tcb
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pmp$get_date
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_job_mode
*copyc pmp$get_job_names
*copyc pmp$get_mainframe_id
*copyc pmp$get_pseudo_mainframe_id
*copyc pmp$get_termination_status
*copyc pmp$get_user_identification
*copyc pmp$get_unique_name
*copyc pmp$get_microsecond_clock
*copyc pmp$get_os_version
*copyc pmp$log
*copyc pmp$log_ascii
*copyc pmp$long_term_wait
*copyc pmp$manage_sense_switches
*copyc pmp$update_jmtr_tcb_target_ring
*copyc pmp$set_system_flag
*copyc qfp$discard_job
*copyc qfp$job_requests_restart
*copyc qfp$read_job_system_label
*copyc qfp$server_job_begin
*copyc qfp$set_family_unavailable
*copyc qfp$set_interactive_jrd_jad
*copyc qfp$set_job_restart
*copyc qfp$write_job_system_label
*copyc rfp$job_termination
*copyc rhp$save_link_user_description
*copyc rmp$request_mass_storage
*copyc rmp$request_null_device
*copyc rmp$request_terminal
*copyc sfp$emit_audit_statistic
*copyc sfp$emit_statistic
*copyc sfp$get_job_limit
*copyc sfp$init_job_routing_control
*copyc stp$set_end_job
*copyc syp$initialize_job_mode
*copyc tmp$disable_preemptive_commo
*copyc tmp$fetch_job_statistics

*copyc avv$account_name
*copyc avv$project_name
*copyc clv$standard_files
*copyc iiv$interactive_terminated
*copyc iiv$xt_xterm_control_block
*copyc jmv$executing_within_system_job
*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc jmv$job_attributes
*copyc jmv$job_history_active
*copyc jmv$job_recovery_information_p
*copyc jmv$kjl_p
*copyc jmv$kjlx_p
*copyc jmv$known_job_list
*copyc jmv$swap_file_allocation_size
*copyc jmv$ts_job_disconnected
*copyc osv$control_codes_to_quest_mark
*copyc osv$initial_exception_context
*copyc osv$task_shared_heap
*copyc pfv$p_attached_pf_table
*copyc pfv$p_queued_catalog_table
*copyc syv$job_initialization_complete
*copyc syv$clone_enabled
*copyc syv$job_recovery_step
*copyc syv$nosve_job_template
?? OLDTITLE ??
?? NEWTITLE := 'Global Variables Declared by this Module', EJECT ??

  VAR
    jmv$job_swap_file_id: [STATIC, oss$task_shared] amt$file_identifier,
    jmv$job_command_input_lfn: [STATIC, oss$task_shared] amt$local_file_name := osc$null_name,
    jmv$job_termination_status: [XDCL, #GATE, STATIC, oss$task_shared] ^ost$status := NIL,
    jmv$leveled_job_committed: [XDCL, #GATE, STATIC, oss$task_shared] boolean := FALSE,
    jmv$terminal_io_disabled: [XDCL, #GATE, STATIC, oss$task_shared] boolean := FALSE,
    jmv$exit_processing_inhibited: [STATIC, oss$task_shared] boolean := FALSE;

?? TITLE := '    JMP$JOB_BEGIN', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$job_begin
    (VAR users_nominal_ring: ost$ring);

    VAR
      account_name: avt$account_name,
      cloned_job: boolean,
      date: ost$date,
      get_accounting_data_p: ^nat$accounting_data_fields,
      id: ost$caller_identifier,
      ignore_status: ost$status,
      job_template_name: ost$name,
      local_status: ost$status,
      logset: pmt$ascii_logset,
      microsecond_clock_value: jmt$clock_time,
      operation_information_p: ^sft$audit_information,
      operation_status_p: ^ost$status,
      peer_accounting_information_p: ^string ( * ),
      project_name: avt$project_name,
      statistic_data: jmt$comm_acct_statistic_data,
      status: ost$status,
      system_identification_line: string (54),
      system_label_p: ^jmt$job_system_label,
      version: pmt$os_name;

    CONST
      avc$none = 'NONE                           ';

    #KEYPOINT (osk$entry, 0, jmk$job_begin);

    #CALLER_ID (id);
    IF NOT osp$called_by_system_code (id) THEN
      osp$force_access_violation;
    IFEND;
    IF id.ring > osc$tsrv_ring THEN
      osp$force_access_violation;
    IFEND;

    logset := $pmt$ascii_logset [pmc$system_log, pmc$job_log];

    cloned_job := syv$job_initialization_complete;
    IF NOT cloned_job THEN

{ The job initialization capture point
{ All user specific job initialization must come AFTER this point

      jmp$initialize_job_mode;
    IFEND;

    pmp$get_date (osc$mdy_date, date, status);
    IF NOT status.normal THEN
      osp$generate_log_message (logset, status, ignore_status);
      system_identification_line (1, 8) := '        ';
    ELSE
      system_identification_line (1, 8) := date.mdy;
    IFEND;
    system_identification_line (9) := ' ';
    pmp$get_os_version (version, status);
    IF NOT status.normal THEN
      osp$generate_log_message (logset, status, ignore_status);
      system_identification_line (10, * ) := ' ';
    ELSE
      system_identification_line (10, * ) := version;
    IFEND;
    system_identification_line (34, * ) := jmv$kjl_p^ [jmv$jcb.job_id].system_job_name;

    pmp$log (system_identification_line, status);

    osp$get_job_template_name (job_template_name);
    IF job_template_name <> '' THEN
      pmp$log (job_template_name, status);
    IFEND;

    jmp_initialize_swap_file (status);
    IF NOT status.normal THEN
      osp$generate_log_message (logset, status, ignore_status);
      pmp$exit (status);
    IFEND;

    IF jmp$job_is_being_leveled () THEN
      call_server_job_begin (status);
      IF NOT status.normal THEN
        osp$generate_log_message (logset, status, ignore_status);
        pmp$exit (status);
      IFEND;
    IFEND;

    IF syv$clone_enabled AND syv$nosve_job_template THEN
      PUSH system_label_p;
      initialize_job_tables (system_label_p, status);
      IF NOT status.normal THEN
        osp$generate_log_message (logset, status, ignore_status);
        pmp$exit (status);
      IFEND;
    ELSE
      system_label_p := ^jmv$job_recovery_information_p^.job_system_label;
    IFEND;

{ NOTE: The following call "should" take place before the call to pmp$init_default_prog_options,
{       but must be done here because of a previous pfp$attach done with COMMAND as the alias.

    IF NOT jmv$kjlx_p^ [jmv$jcb.job_id].timesharing_job THEN
      clp$store_std_path_handle_names (jmv$executing_within_system_job, {first_time=} FALSE, status);
      IF NOT status.normal THEN
        osp$generate_log_message (logset, status, ignore_status);
        pmp$exit (status);
      IFEND;
    IFEND;

{ NOTE: At this point, a job is now capable of referencing itself for job
{       attributes.

    jmp$emit_job_begin_statistics (status);
    IF NOT status.normal THEN
      osp$generate_log_message (logset, status, ignore_status);
    IFEND;

    IF jmv$job_history_active THEN
      jmp$emit_job_history_statistics (jml$job_initiated, osc$null_name, system_label_p^.system_job_name,
            jmc$blank_system_supplied_name, NIL, NIL, osc$null_name, jmc$blank_system_supplied_name,
            ignore_status);
    IFEND;

    IF system_label_p = NIL THEN
      account_name := avc$none;
      project_name := avc$none;
    ELSE
      account_name := system_label_p^.login_account;
      project_name := system_label_p^.login_project;
    IFEND;

    IF jmp$is_dual_state_job () THEN
      ifp$job_initialize (status);
      IF NOT status.normal THEN
        osp$generate_log_message (logset, status, ignore_status);
        pmp$exit (status);
      IFEND;

      jmp_initialize_job_files (status);
      IF NOT status.normal THEN
        osp$generate_log_message (logset, status, ignore_status);
        pmp$exit (status);
      IFEND;

      IF system_label_p^.optional_user_capability = avc$dual_state_prompt THEN
        avp$dual_state_prompt (system_label_p^.login_user_identification.user,
              system_label_p^.login_user_identification.family, status);
        IF NOT status.normal THEN
          osp$generate_log_message (logset, status, ignore_status);
          pmp$exit (status);
        IFEND;

        account_name := avv$account_name;
        project_name := avv$project_name;

      IFEND;

    IFEND;

    IF cloned_job THEN
      IF jmv$kjlx_p^ [jmv$jcb.job_id].timesharing_job THEN
        jmp$clone_login (status);
        IF NOT status.normal THEN
          osp$generate_log_message (logset, status, ignore_status);
          pmp$exit (status);
        IFEND;
      IFEND;
    IFEND;

    validate_job (system_label_p, account_name, project_name, users_nominal_ring, status);
    IF NOT status.normal THEN
      osp$generate_log_message (logset, status, ignore_status);
      IF system_label_p^.job_mode = jmc$interactive_connected THEN
        osp$generate_output_message (status, ignore_status);
      IFEND;
      pmp$exit (status);
    IFEND;

    clp$update_connected_files (users_nominal_ring);
    pmp$update_jmtr_tcb_target_ring (users_nominal_ring);

{ The following statistics are emitted after the call to validate_job so that
{ the account and project names will be valid.

    IF (jmv$job_attributes.originating_application_name = osc$batch_transfer_server) THEN
      statistic_data.statistic_id := jmc$ca_input_file;
      PUSH statistic_data.input_file;
      statistic_data.input_file^.job_input_device := jmv$job_attributes.job_input_device;
      statistic_data.input_file^.job_system_label_p := system_label_p;
      jmp$emit_communication_stat (statistic_data);
    ELSEIF (jmv$job_attributes.originating_application_name = osc$queue_transfer_server) THEN
      statistic_data.statistic_id := jmc$ca_dest_qf_transfer;
      PUSH statistic_data.dest_queue_file_transfer;
      statistic_data.dest_queue_file_transfer^.kind := jmc$input_file;
      statistic_data.dest_queue_file_transfer^.job_input_device := jmv$job_attributes.job_input_device;
      statistic_data.dest_queue_file_transfer^.job_system_label_p := system_label_p;
      jmp$emit_communication_stat (statistic_data);
    IFEND;

    IF (avp$security_option_active (avc$vso_security_audit) AND (system_label_p <> NIL)) THEN
      PUSH operation_information_p;
      operation_information_p^.audited_operation := sfc$ao_job_user_identification;
      operation_information_p^.user_identification.family_name_p :=
            ^system_label_p^.login_user_identification.family;
      operation_information_p^.user_identification.user_name_p :=
            ^system_label_p^.login_user_identification.user;
      operation_information_p^.user_identification.account_name_p := ^avv$account_name;
      operation_information_p^.user_identification.project_name_p := ^avv$project_name;
      IF jmv$kjlx_p^ [jmv$jcb.job_id].timesharing_job THEN

{ Get the terminal name.

        PUSH get_accounting_data_p: [1 .. 1];
        get_accounting_data_p^ [1].kind := nac$ca_device_name;
        PUSH peer_accounting_information_p: [jmv$job_attributes.job_input_device.size];
        peer_accounting_information_p^ := jmv$job_attributes.job_input_device.text;
        nap$parse_accounting_data (peer_accounting_information_p, NIL, get_accounting_data_p, local_status);
        IF local_status.normal THEN
          operation_information_p^.user_identification.terminal_name_p :=
                ^get_accounting_data_p^ [1].device_name;
        ELSE
          operation_information_p^.user_identification.terminal_name_p := NIL;
        IFEND;
      ELSE
        operation_information_p^.user_identification.terminal_name_p := NIL;
      IFEND;
      PUSH operation_status_p;
      operation_status_p^.normal := TRUE;
      sfp$emit_audit_statistic (operation_information_p^, operation_status_p^);
    IFEND;

    ofp$job_begin;

{ This request must take place after an interactive job has connected to its terminal.

    IF NOT jmp$is_xterm_job () THEN
      qfp$set_interactive_jrd_jad;
    IFEND;

{ This request should take place before returning to force the recovery information
{ out of the working set.

    jmp$write_recovery_info_to_disk;

    pmp$get_microsecond_clock (microsecond_clock_value, ignore_status);
    IF (jmv$kjlx_p^ [jmv$jcb.job_id].latest_clock_time_to_initiate < microsecond_clock_value) THEN
      osp$set_status_abnormal ('JM', jme$job_initiated_too_late, '', status);
      osp$generate_log_message (logset, status, ignore_status);
      pmp$exit (status);
    IFEND;

    #KEYPOINT (osk$exit, 0, jmk$job_begin);

  PROCEND jmp$job_begin;

?? TITLE := '   JMP$JOB_BOOT', EJECT ??

  PROCEDURE [XDCL] jmp$job_boot;

    VAR
      job_mode: jmt$job_mode,
      ignore_status: ost$status,
      system_label_p: ^jmt$job_system_label,
      status: ost$status;

    fmp$initialize_path_table;

    lgp$setup_access_to_local_logs (status);
    IF NOT status.normal THEN
      pmp$exit (status);
    IFEND;

    sfp$init_job_routing_control (status);
    IF NOT status.normal THEN
      pmp$exit (status);
    IFEND;

    clp$store_std_path_handle_names (jmv$executing_within_system_job, TRUE, status);
    IF NOT status.normal THEN
      pmp$exit (status);
    IFEND;

    pmp$get_job_mode (job_mode, status);
    IF job_mode = jmc$batch THEN
      jmp_initialize_job_files (status);
      IF NOT status.normal THEN
        pmp$exit (status);
      IFEND;
    IFEND;

    IF (NOT syv$clone_enabled) OR (NOT syv$nosve_job_template) THEN

{Job will never save a login template
{system label must be available during login for a detached job submit

      PUSH system_label_p;
      initialize_job_tables (system_label_p, status);
      IF NOT status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$system_log, pmc$job_log], status, ignore_status);
        pmp$exit (status);
      IFEND;
    IFEND;

    IF jmv$kjlx_p^ [jmv$jcb.job_id].timesharing_job THEN
      jmp$initialize_timesharing (status);
      IF NOT status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$system_log, pmc$job_log], status, ignore_status);
        pmp$exit (status);
      IFEND;
      jmp_initialize_job_files (status);
      IF NOT status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$system_log, pmc$job_log], status, ignore_status);
        pmp$exit (status);
      IFEND;
      clp$store_std_path_handle_names (jmv$executing_within_system_job, FALSE, status);
      IF NOT status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$system_log, pmc$job_log], status, ignore_status);
        pmp$exit (status);
      IFEND;
    IFEND;

  PROCEND jmp$job_boot;


?? TITLE := '    JMP$JOB_END', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$job_end;

    TYPE
      jmt$job_end_phase = (null_phase, rethread_job, append_job_log, route_output, set_job_unswappable,
            purge_command_file, purge_swap_file, disable_preemptive_commo, operator_facility_cleanup,
            cm_job_exit, delete_non_inherited_segs, ln_job_exit, rhfam_job_exit, nam_job_exit, pf_job_exit,
            set_management_cleanup, file_server_job_exit, emit_job_statistics, exit_job_request);


    VAR
      job_end_phase: [STATIC, oss$task_shared] jmt$job_end_phase := LOWERVALUE (jmt$job_end_phase),
      logset: pmt$ascii_logset,
      command_path_p: ^pft$path,
      restart_job: boolean,
      swap_path_p: ^pft$path,
      pf_cycle: pft$cycle_selector,
      password: pft$password,
      expected_status: boolean,
      files_binary_mainframe_id: pmt$binary_mainframe_id,
      file_attributes_p: ^amt$file_attributes,
      job_output_fap_p: amt$fap_pointer,
      job_mode: jmt$job_mode,
      executing_taskid: ost$global_task_id,
      ignore_status: ost$status,
      output_disposition: [STATIC, READ, oss$job_paged_literal] array [jmt$output_disposition_keys] of
            string (osc$max_name_size) := ['DISCARD_ALL_OUTPUT             ',
            'DISCARD_STANDARD_OUTPUT        ', 'LOCAL                          ',
            'PRINTER                        ', 'STANDARD_OUTPUT                ',
            'WAIT_QUEUE                     '],
      output_disposition_key: jmt$output_disposition_keys,
      reason: ost$name,
      return_files_option: pft$return_files_option,
      system_label_p: ^jmt$job_system_label,
      system_job_name: jmt$system_supplied_name,
      system_supplied_name: jmt$system_supplied_name,
      status: ost$status,
      termination_status: ost$status;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      IF NOT status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??

    logset := $pmt$ascii_logset [pmc$system_log];

{! Stop the music if the System Job is terminating.

    IF jmv$executing_within_system_job = TRUE THEN
      osp$system_error ('JOB_END CALLED IN SYSTEM JOB', ^status);
    IFEND;

    pmp$get_executing_task_gtid (executing_taskid);
    IF executing_taskid <> jmv$jcb.job_monitor_id THEN
      osp$set_status_abnormal ('JM', jme$job_end_called_unexpectedly, '', status);
      osp$generate_log_message (logset, status, ignore_status);
      RETURN;
    IFEND;
    output_disposition_key := jmv$kjlx_p^ [jmv$jcb.job_id].output_disposition_key;
    system_job_name := jmv$kjl_p^ [jmv$jcb.job_id].system_job_name;

    WHILE TRUE DO
      job_end_phase := SUCC (job_end_phase);
      CASE job_end_phase OF

      = rethread_job =
        jmp$set_job_term_disposition;

      = append_job_log =
        pmp$get_job_mode (job_mode, status);
        IF NOT status.normal THEN
          osp$system_error ('ERROR ON PMP$GET_JOB_MODE', ^status);
        IFEND;
        job_output_fap_p := jmp$job_file_fap (clv$standard_files [clc$sf_job_output_file].path_handle_name);
        IF (job_output_fap_p = NIL) AND (job_mode = jmc$batch) AND
              (output_disposition_key <> jmc$discard_standard_output) AND
              (output_disposition_key <> jmc$discard_all_output) THEN
          lgp$append_job_log_to_output (status);
          IF NOT status.normal THEN
            osp$generate_log_message (logset, status, ignore_status);
          IFEND;
        IFEND;

      = route_output =
        pmp$get_job_mode (job_mode, status);
        IF NOT status.normal THEN
          osp$system_error ('ERROR ON PMP$GET_JOB_MODE', ^status);
        IFEND;
        job_output_fap_p := jmp$job_file_fap (clv$standard_files [clc$sf_job_output_file].path_handle_name);
        system_supplied_name := jmc$blank_system_supplied_name;
        IF (job_output_fap_p = NIL) AND (job_mode = jmc$batch) AND
              (output_disposition_key <> jmc$discard_standard_output) AND
              (output_disposition_key <> jmc$discard_all_output) THEN
          dispose_of_standard_output (output_disposition_key, system_supplied_name, status);
          IF NOT status.normal THEN
            osp$generate_log_message (logset, status, ignore_status);
          IFEND;
        IFEND;

        IF jmv$job_history_active THEN
          pmp$get_termination_status (termination_status);
          reason := '';
          osp$get_status_condition_name (termination_status.condition, reason, ignore_status);

          IF (job_mode = jmc$batch) THEN
            IF (output_disposition_key <> jmc$standard_output_path) OR (NOT status.normal) THEN

{ If the status is not normal the the copy_file has failed to dispose of standard output;  The output
{ file is then on $local.output.

              jmp$emit_job_history_statistics (jml$job_terminated,
                    output_disposition [output_disposition_key], system_job_name, system_supplied_name, NIL,
                    NIL, reason, jmc$blank_system_supplied_name, status);
            ELSE
              jmp$emit_job_history_statistics (jml$job_terminated,
                    output_disposition [output_disposition_key], system_job_name,
                    jmc$blank_system_supplied_name, NIL, NIL, reason, jmc$blank_system_supplied_name, status);
            IFEND;
          ELSE
            jmp$emit_job_history_statistics (jml$job_terminated, osc$null_name, system_job_name,
                  'TSJOB              ', NIL, NIL, reason, jmc$blank_system_supplied_name, status);
          IFEND;
          IF NOT status.normal THEN
            osp$generate_log_message (logset, status, ignore_status);
          IFEND;
        IFEND;

      = set_job_unswappable =
        jmp$set_job_unswappable (ignore_status);

      = purge_command_file =
        pmp$get_job_mode (job_mode, ignore_status);

{ Interactive jobs don't have command files and cannot be restarted.

        IF job_mode = jmc$batch THEN
          restart_job := FALSE;

{ If the job is a batch job and the job claims that it wants to restart if it aborted we may not want to
{ delete the command file.  In order to consider this further, the job must have completed the system
{ prolog.  The job recovery step must indicate that the job has been through a recovery otherwise the
{ job abort disposition is ignored.

          IF (qfp$job_requests_restart () AND (syv$job_recovery_step <> syc$jrs_initial_step)) THEN
            pmp$get_termination_status (termination_status);

{ If the termination status of the job is not one of the expected termination statuses it is okay to
{ restart the job.  This means that the job monitor task aborted with an unexpected status and NOS/VE
{ was responsible for bringing down the user's job.

            expected_status := (termination_status.condition = jme$job_terminating_normally) OR
                  (termination_status.condition = jme$job_terminated_via_command) OR
                  (termination_status.condition = ave$bad_user_validation_info) OR
                  (termination_status.condition = jme$user_requested_exit) OR
                  (termination_status.condition = jme$login_abort_in_prolog) OR
                  (termination_status.condition = mme$job_file_tables_full) OR
                  (termination_status.condition = ife$disconnected_job_timeout);

            IF NOT expected_status THEN
              restart_job := TRUE;
              osp$generate_log_message (logset, termination_status, ignore_status);
            ELSE
              restart_job := FALSE;
            IFEND;
          IFEND;

          IF (NOT restart_job) AND jmv$kjl_p^ [jmv$jcb.job_id].login_family_available AND
                (NOT jmp$job_is_being_leveled () OR jmv$leveled_job_committed) THEN
            PUSH command_path_p: [1 .. 4];
            IF jmv$kjlx_p^ [jmv$jcb.job_id].input_file_location = jmc$ifl_login_family_queue THEN
              command_path_p^ [1] := jmv$jcb.user_id.family;
            ELSE
              command_path_p^ [1] := jmc$system_family;
            IFEND;
            command_path_p^ [2] := jmc$system_user;
            command_path_p^ [3] := jmc$job_input_catalog;
            command_path_p^ [4] (1, * ) := jmv$jcb.system_name;
            pf_cycle.cycle_option := pfc$specific_cycle;
            pf_cycle.cycle_number := 1;
            password := osc$null_name;
            osp$establish_block_exit_hndlr (^handle_block_exit);
            pfp$begin_system_authority;
            pfp$purge (command_path_p^, pf_cycle, password, status);
            pfp$end_system_authority;
            osp$disestablish_cond_handler;
            IF NOT status.normal THEN
              osp$generate_log_message (logset, status, ignore_status);
            IFEND;
          ELSEIF (NOT jmp$job_is_being_leveled () OR jmv$leveled_job_committed) THEN

{ Write an updated job label to the command file. Make it appear as though the job
{ did not initiate.  If we cannot write the updated label, the job will initiate
{ on the next deadstart or the file will be purged by recovery.  It is likely that
{ an attempt to re-start the job from this deadstart would fail since the file
{ could not be updated.

            PUSH system_label_p;
            qfp$read_job_system_label (clc$job_command_input, system_label_p^, status);
            IF status.normal THEN
              system_label_p^.job_initiation_location := '';
              qfp$write_job_system_label (clc$job_command_input, { write_label } TRUE, system_label_p^,
                    status);
              IF status.normal AND jmv$kjl_p^ [jmv$jcb.job_id].login_family_available THEN
                qfp$set_job_restart;
              ELSE
                osp$generate_log_message (logset, status, ignore_status);
              IFEND;
            ELSE
              osp$generate_log_message (logset, status, ignore_status);
            IFEND;

          ELSE { The job was leveled and failed before updating the server
            PUSH swap_path_p: [1 .. 4];
            swap_path_p^ [1] := jmc$system_family;
            swap_path_p^ [2] := jmc$system_user;
            swap_path_p^ [3] := jmc$job_swap_catalog;
            swap_path_p^ [4] (1, * ) := jmv$jcb.system_name;
            jmp$add_to_server_restart_file (swap_path_p, {recover_using_abort_disposition} FALSE);
          IFEND;
        IFEND; { job_mode = jmc$batch

      = purge_swap_file =

{ Don't need to close the swap file - bam has already done this in cleanup - whoops!

        PUSH swap_path_p: [1 .. 4];
        swap_path_p^ [1] := jmc$system_family;
        swap_path_p^ [2] := jmc$system_user;
        swap_path_p^ [3] := jmc$job_swap_catalog;
        swap_path_p^ [4] (1, * ) := jmv$jcb.system_name;
        pf_cycle.cycle_option := pfc$specific_cycle;
        pf_cycle.cycle_number := 1;
        password := osc$null_name;
        osp$establish_block_exit_hndlr (^handle_block_exit);
        pfp$begin_system_authority;
        pfp$purge (swap_path_p^, pf_cycle, password, status);
        pfp$end_system_authority;
        osp$disestablish_cond_handler;
        IF NOT status.normal THEN
          osp$generate_log_message (logset, status, ignore_status);
        IFEND;

      = disable_preemptive_commo =
        job_end_phase := PRED (disable_preemptive_commo); { inhibit phase advancement
        tmp$disable_preemptive_commo;
        job_end_phase := disable_preemptive_commo; { enable phase advancement

      = operator_facility_cleanup =
        ofp$job_end;

      = cm_job_exit =
        cmp$subsystem_io_job_exit (status);
        IF NOT status.normal THEN
          osp$generate_log_message (logset, status, ignore_status);
        IFEND;

      = delete_non_inherited_segs =

{###    jmp$delete_non_inherited_segs (status);
{###    IF NOT status.normal THEN
{###      osp$generate_log_message (logset, status, ignore_status);
{###    IFEND;

      = ln_job_exit =
        fmp$job_exit;

      = rhfam_job_exit =
        rfp$job_termination;

      = nam_job_exit =
        nap$process_job_termination;

      = pf_job_exit =
        return_files_option.return_files := FALSE;
        pmp$get_pseudo_mainframe_id (files_binary_mainframe_id);
        pfp$process_job_end (files_binary_mainframe_id, return_files_option);

      = set_management_cleanup =
        stp$set_end_job (status);
        IF NOT status.normal THEN
          osp$generate_log_message (logset, status, ignore_status);
        IFEND;

      = file_server_job_exit =

{ If the job was leveled and did not reach the commit point then don't tell the server
{ the job is completed.

        IF (NOT jmp$job_is_being_leveled () OR jmv$leveled_job_committed) THEN
          dfp$process_job_end;
        IFEND;

      = emit_job_statistics =
        pmp$emit_job_end_statistics (status);
        IF NOT status.normal THEN
          osp$generate_log_message (logset, status, ignore_status);
        IFEND;

      = exit_job_request =
        job_end_phase := PRED (exit_job_request);

{! Control is not returned to this procedure after the call to JMP$EXIT_JOB.

        jmp$exit_job;

      CASEND;
    WHILEND;

  PROCEND jmp$job_end;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$define_and_permit_catalogs', EJECT ??

  PROCEDURE [XDCL] jmp$define_and_permit_catalogs
    (VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      path_p: ^pft$path;

    status.normal := TRUE;

    PUSH path_p: [1 .. 3];
    path_p^ [1] := jmc$system_family;
    path_p^ [2] := jmc$system_user;

    path_p^ [3] := jmc$job_input_catalog;
    pfp$define_catalog (path_p^, ignore_status);

    path_p^ [3] := jmc$sf_job_input_catalog;
    pfp$define_catalog (path_p^, ignore_status);

    path_p^ [3] := jmc$job_output_catalog;
    pfp$define_catalog (path_p^, ignore_status);

    path_p^ [3] := jmc$sf_job_output_catalog;
    pfp$define_catalog (path_p^, ignore_status);

    path_p^ [3] := jmc$job_swap_catalog;
    pfp$define_catalog (path_p^, ignore_status);
  PROCEND jmp$define_and_permit_catalogs;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_job_tables', EJECT ??

  PROCEDURE initialize_job_tables
    (VAR system_label_p: ^jmt$job_system_label;
     VAR status: ost$status);

    VAR
      command_lfn: amt$local_file_name,
      path_p: ^pft$path,
      pf_cycle: pft$cycle_selector,
      password: pft$password,
      usage: pft$usage_selections,
      share: pft$share_selections;

?? NEWTITLE := 'handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      IF NOT status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    IF jmv$executing_within_system_job THEN
      system_label_p := NIL;
    ELSE

      IF jmv$kjlx_p^ [jmv$jcb.job_id].job_mode = jmc$batch THEN

{ Attach the command file for the job so we can read the system label

        PUSH path_p: [1 .. 4];
        IF jmv$kjlx_p^ [jmv$jcb.job_id].input_file_location = jmc$ifl_login_family_queue THEN
          path_p^ [1] := jmv$jcb.user_id.family;
        ELSE
          path_p^ [1] := jmc$system_family;
        IFEND;
        path_p^ [2] := jmc$system_user;
        path_p^ [3] := jmc$job_input_catalog;
        path_p^ [4] := jmv$jcb.system_name;
        pf_cycle.cycle_option := pfc$specific_cycle;
        pf_cycle.cycle_number := 1;
        password := osc$null_name;
        usage := $pft$usage_selections [pfc$read];
        share := $pft$share_selections [pfc$read];
        command_lfn := clc$job_command_input;
        osp$establish_block_exit_hndlr (^handle_block_exit);
        pfp$begin_system_authority;
        pfp$attach (command_lfn, path_p^, pf_cycle, password, usage, share, pfc$wait, status);
        pfp$end_system_authority;
        osp$disestablish_cond_handler;
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Read the system label for the job

        qfp$read_job_system_label (command_lfn, system_label_p^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        system_label_p^ := jmv$kjlx_p^ [jmv$jcb.job_id].system_label_p^;
      IFEND;

{ Place the mainframe ID and the job initiation time in the job's system label.
{ This serves two purposes.  The first is to indicate when the job was initiated.  The second
{ is to indicate which mainframe the job initiated on.  This is necessary for
{ load-leveling.  Once the job's system label is updated on the server, the leveled
{ job is committed to execution.  Any server failure before this point must result in a
{ restart of the job.  Any server failure after this point must result in the job
{ waiting for the server.

      pmp$get_mainframe_id (system_label_p^.job_initiation_location, { ignore } status);
      system_label_p^.job_attributes.job_initiation_time := jmv$kjlx_p^ [jmv$jcb.job_id].job_initiation_time;

      IF jmv$kjlx_p^ [jmv$jcb.job_id].job_mode = jmc$batch THEN
        qfp$write_job_system_label (command_lfn, { write_label } TRUE, system_label_p^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      jmp$save_recovery_information (system_label_p);
    IFEND; { NOT jmv$executing_in_system_job

{ Initialize the tables that are local to the job's execution environment

    jmp$initialize_job_local_tables (system_label_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$initialize_job_attributes (system_label_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND initialize_job_tables;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] validate_job', EJECT ??

  PROCEDURE [INLINE] validate_job
    (    system_label_p: ^jmt$job_system_label;
         account_name: avt$account_name;
         project_name: avt$project_name;
     VAR users_nominal_ring: ost$ring;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context,
      job_class: jmt$job_class,
      ignore_display_format: avt$numeric_display_format,
      link_attribute_family: ost$string,
      link_attribute_user: ost$string,
      link_attribute_password: ost$string,
      link_attribute_account: ost$string,
      link_attribute_project: ost$string,
      validation_attributes: ^avt$validation_items,
      week_timeout_period: integer;

    status.normal := TRUE;
    context := NIL;


    IF jmv$executing_within_system_job THEN
      users_nominal_ring := osc$user_ring;
      iiv$terminal_timeout_limit := nac$max_wait_time;
      iiv$terminal_timeout_limit_left := nac$max_wait_time;

    ELSE

{ Validate the job

      PUSH validation_attributes: [1 .. 7];
      validation_attributes^ [1].key := avc$password_key;
      validation_attributes^ [1].password := system_label_p^.login_password;

      job_class := jmv$kjl_p^ [jmv$jcb.job_id].job_class;
      IF system_label_p^.perform_class_validation AND (system_label_p^.assigned_job_class <>
            osc$null_name) AND (job_class <> jmc$unassigned_job_class) THEN
        validation_attributes^ [2].key := avc$job_class_name_key;
        validation_attributes^ [2].job_class_name := system_label_p^.assigned_job_class;
      ELSE
        validation_attributes^ [2].key := avc$null_validation_key;
      IFEND;

{ Did the user specify a ring ?

      IF system_label_p^.job_execution_ring <> osc$invalid_ring THEN
        users_nominal_ring := system_label_p^.job_execution_ring;
        validation_attributes^ [3].key := avc$job_execution_ring_key;
        validation_attributes^ [3].job_execution_ring := system_label_p^.job_execution_ring;
      ELSE
        validation_attributes^ [3].key := avc$null_validation_key;
      IFEND;

      IF system_label_p^.required_user_capability <> osc$null_name THEN
        validation_attributes^ [4].key := avc$required_capability_key;
        validation_attributes^ [4].required_capability := system_label_p^.required_user_capability;
      ELSE
        validation_attributes^ [4].key := avc$null_validation_key;
      IFEND;

      validation_attributes^ [5].key := avc$job_limit_key;
      validation_attributes^ [5].limit_name := avc$cpu_time_limit_name;
      validation_attributes^ [5].user_specified := (system_label_p^.limit_information.
            cpu_time_limit_specified AND (system_label_p^.limit_information.cpu_time_limit_requested <>
            jmc$unspecified_cpu_time_limit));
      validation_attributes^ [5].job_maximum := system_label_p^.limit_information.cpu_time_limit_assigned;

      validation_attributes^ [6].key := avc$job_limit_key;
      validation_attributes^ [6].limit_name := avc$sru_limit_name;
      validation_attributes^ [6].user_specified := (system_label_p^.limit_information.
            sru_limit_specified AND (system_label_p^.limit_information.sru_limit_requested <>
            jmc$unspecified_sru_limit));
      validation_attributes^ [6].job_maximum := system_label_p^.limit_information.sru_limit_assigned;

      validation_attributes^ [7].key := avc$job_limit_key;
      validation_attributes^ [7].limit_name := avc$magnetic_tape_limit_name;
      validation_attributes^ [7].user_specified := (system_label_p^.limit_information.
            magnetic_tape_limit_specified AND (system_label_p^.limit_information.
            magnetic_tape_limit_requested <> jmc$unspecified_mag_tape_limit));
      validation_attributes^ [7].job_maximum := system_label_p^.limit_information.
            magnetic_tape_limit_assigned;

{ Validate the job.  If the validation file is on a server mainframe and the server
{ is not active, then one of two things must happen.  If the job is a leveled job,
{ the job should wait for the server mainframe to activate.  Otherwise (the job
{ is logging in thru the server) the job should abort, noting that the login
{ family is unavailable.  This will result in the job being deferred.

      REPEAT
        avp$validate_job (system_label_p^.login_user_identification.user,
              system_label_p^.login_user_identification.family, account_name, project_name,
              validation_attributes, status);
        IF (NOT status.normal) AND (status.condition = dfe$server_not_active) THEN
          IF jmp$job_is_being_leveled () THEN
            IF context = NIL THEN
              PUSH context;
              context^ := osv$initial_exception_context;
            IFEND;
            context^.condition_status := status;
            osp$enforce_exception_policies (context^);
            status := context^.condition_status;
          ELSE
            qfp$set_family_unavailable;
            RETURN;
          IFEND;
        IFEND;
      UNTIL status.normal OR (status.condition <> dfe$server_not_active) OR ((context <> NIL) AND
            (NOT context^.wait));
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT jmp$is_xterm_job () THEN
        avp$get_limit_value (avc$terminal_timeout_limit, avc$user, iiv$terminal_timeout_limit,
              ignore_display_format, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF iiv$terminal_timeout_limit < (nac$max_wait_time DIV 60000) THEN
          iiv$terminal_timeout_limit := iiv$terminal_timeout_limit * 60000 - 30000;
        ELSE
          iiv$terminal_timeout_limit := nac$max_wait_time;
        IFEND;
      ELSE
{ Because an xterm job does not yet support attach_job, the job
{ cannot be disconnected for terminal timeout.

        iiv$terminal_timeout_limit := nac$max_wait_time;
      IFEND;
      iiv$terminal_timeout_limit_left := iiv$terminal_timeout_limit;

{ Save info for the memory link.  This will be modified latter with the valid account and project names if
{ system accounting is active and the users validation is project required.


      avp$get_string_value (avc$link_attribute_family, avc$user, link_attribute_family, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      avp$get_string_value (avc$link_attribute_user, avc$user, link_attribute_user, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      avp$get_string_value (avc$link_attribute_password, avc$user, link_attribute_password, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      avp$get_string_value (avc$link_attribute_charge, avc$user, link_attribute_account, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      avp$get_string_value (avc$link_attribute_project, avc$user, link_attribute_project, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      rhp$save_link_user_description (link_attribute_user.value (1, 31), link_attribute_family.value (1, 31),
            link_attribute_password.value (1, 31), link_attribute_account.value (1, 31),
            link_attribute_project.value (1, 31), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF system_label_p^.job_execution_ring = osc$invalid_ring THEN
        users_nominal_ring := avp$ring_nominal ();
      IFEND;
    IFEND;

  PROCEND validate_job;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_of_standard_output', EJECT ??

  PROCEDURE dispose_of_standard_output
    (VAR output_disposition_key: jmt$output_disposition_keys;
     VAR system_supplied_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      boi_attributes_p: ^amt$file_attributes,
      ignore_status: ost$status,
      logset: pmt$ascii_logset,
      mandated_creation_attributes_p: ^fst$file_cycle_attributes,
      nominal_ring: ost$ring,
      print_output: boolean;

?? NEWTITLE := 'handle_out_of_space', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with the out of space condition.

    PROCEDURE handle_out_of_space
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF (condition.selector = pmc$user_defined_condition) AND
            (condition.user_condition_name = osc$space_unavailable_condition) THEN
        osp$set_status_condition (jme$no_space_for_file, status);
        jmp$update_display_message (status);

{ This is called twice to fish out any signals and flags that are waiting to be processed.
{ This forces the job to wait for 5 minutes unless another event triggers the task to come ready.

        pmp$long_term_wait (100, 100);
        pmp$long_term_wait (300000, 300000);
        ofp$display_status_message (' ', ignore_status);
        status.normal := TRUE;
        RETURN;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND handle_out_of_space;
?? OLDTITLE ??
?? EJECT ??
    logset := $pmt$ascii_logset [pmc$system_log];

    PUSH boi_attributes_p: [1 .. 1];
    boi_attributes_p^ [1].key := amc$open_position;
    boi_attributes_p^ [1].open_position := amc$open_at_boi;
    IF status.normal THEN
      bap$file_command (clc$job_output, boi_attributes_p, status);
    IFEND;
    IF NOT status.normal THEN
      osp$generate_log_message (logset, status, ignore_status);
      RETURN;
    IFEND;

{ Did the user specify a file for standard output?

    print_output := (output_disposition_key <> jmc$standard_output_path);
    IF NOT print_output THEN

    /copy_standard_output/
      BEGIN
        nominal_ring := avp$ring_nominal ();
        PUSH mandated_creation_attributes_p: [1 .. 1];
        mandated_creation_attributes_p^ [1].selector := fsc$ring_attributes;
        mandated_creation_attributes_p^ [1].ring_attributes.r1 := nominal_ring;
        mandated_creation_attributes_p^ [1].ring_attributes.r2 := nominal_ring;
        mandated_creation_attributes_p^ [1].ring_attributes.r3 := nominal_ring;


        osp$establish_condition_handler (^handle_out_of_space, {block_exit} FALSE);
        fsp$copy_file (clc$job_output, jmv$job_attributes.output_disposition_path, NIL, NIL,
              mandated_creation_attributes_p, status);
        IF NOT status.normal THEN
          osp$disestablish_cond_handler;
          amp$return (jmv$job_attributes.output_disposition_path, ignore_status);
          osp$generate_log_message (logset, status, ignore_status);
          EXIT /copy_standard_output/;
        IFEND;
        osp$disestablish_cond_handler;

      END /copy_standard_output/;
    IFEND;

    IF NOT status.normal THEN

{ The copy did not work for some reason.  So print the file.

      status.normal := TRUE;
      print_output := TRUE;
    IFEND;

    IF print_output THEN
      jmp$print_file (':$LOCAL.OUTPUT.$BOI', NIL, system_supplied_name, status);

    /wait_for_resources/
      WHILE NOT status.normal DO
        IF (status.condition = jme$maximum_output) OR (status.condition = jme$no_space_for_file) THEN
          jmp$update_display_message (status);

{ This is called twice to fish out any signals and flags that are waiting to
{ be processed.  This forces the job to wait for 5 minutes unless another
{ event triggers the task to come ready.

          pmp$long_term_wait (100, 100);
          pmp$long_term_wait (300000, 300000);
          ofp$display_status_message (' ', ignore_status);
          output_disposition_key := jmv$kjlx_p^ [jmv$jcb.job_id].output_disposition_key;
          IF (output_disposition_key = jmc$discard_standard_output) OR
                (output_disposition_key = jmc$discard_all_output) THEN
            RETURN;
          IFEND;
          jmp$print_file (':$LOCAL.OUTPUT.$BOI', NIL, system_supplied_name, status);
        ELSE
          osp$generate_log_message (logset, status, ignore_status);
          EXIT /wait_for_resources/;
        IFEND;
      WHILEND /wait_for_resources/;
    IFEND;

  PROCEND dispose_of_standard_output;


?? TITLE := '    INITIALIZE_JOB_FILES', EJECT ??

  PROCEDURE jmp_initialize_job_files
    (VAR status: ost$status);

    VAR
      null_attribute: [STATIC, READ, oss$job_paged_literal] array
            [1 .. 1] of ift$connection_attribute := [[ifc$null_connection_attribute]],
      job_mode: jmt$job_mode;


    status.normal := TRUE;

    pmp$get_job_mode (job_mode, status);
    IF NOT status.normal THEN
      osp$system_error ('ERROR ON PMP$GET_JOB_MODE', ^status);
    IFEND;

    IF (job_mode <> jmc$batch) THEN

      rmp$request_terminal (clc$job_command_input, NIL, null_attribute, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      rmp$request_terminal (clc$job_input, NIL, null_attribute, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      rmp$request_terminal (clc$job_output, NIL, null_attribute, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    ELSE
      IF jmv$executing_within_system_job THEN
        rmp$request_null_device (clc$job_command_input, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        rmp$request_null_device (clc$job_input, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        rmp$request_null_device (clc$job_output, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSE

{ For batch jobs, the command file is already attached at this point

        jmv$job_command_input_lfn := clc$job_command_input;
        rmp$request_null_device (clc$job_input, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      IFEND;
    IFEND;

  PROCEND jmp_initialize_job_files;


?? TITLE := '    INITIALIZE_SWAP_FILE', EJECT ??

  PROCEDURE jmp_initialize_swap_file
    (VAR status: ost$status);

    VAR
      path_p: ^pft$path,
      sfid: dmt$system_file_id,
      retention: pft$retention,
      swap_file_path: string (fsc$max_path_size),
      path_length: integer,
      attachment_options_p: ^fst$attachment_options,
      mandated_creation_options_p: ^fst$file_cycle_attributes,
      swap_file_fid: amt$file_identifier,
      swap_file_user_information: jmt$swap_file_user_info,
      allocation_size: rmt$allocation_size,
      estimated_file_size: amt$file_byte_address,
      file_class: rmt$mass_storage_class,
      initial_volume: rmt$recorded_vsn,
      volume_overflow_allowed: boolean;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      IF NOT status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??

    #KEYPOINT (osk$entry, 0, jmk$initialize_swap_file);

    PUSH path_p: [1 .. 4];

    IF NOT jmv$executing_within_system_job THEN
      allocation_size := jmv$swap_file_allocation_size;
      estimated_file_size := rmc$unspecified_file_size;
      file_class := dmc$swap_file_class;
      initial_volume := rmc$unspecified_vsn;
      volume_overflow_allowed := TRUE;

{ Currently, the swap file version isn't used for anything but just in case it
{ is necessary to distinguish swap files in the future it might come in handy.

      swap_file_user_information.version := jmc$swap_file_version_1;
      swap_file_user_information.server_mainframe_id := jmv$known_job_list.server_data.
            state_data [jmv$kjl_p^ [jmv$jcb.job_id].server_index].mainframe_id;
      path_p^ [1] := jmc$system_family;
      path_p^ [2] := jmc$system_user;
      path_p^ [3] := jmc$job_swap_catalog;
      path_p^ [4] (1, * ) := jmv$jcb.system_name;
      fsp$build_file_ref_from_elems (path_p, swap_file_path, status);
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, jmk$initialize_swap_file);
        RETURN;
      IFEND;

      osp$establish_block_exit_hndlr (^handle_block_exit);
      pfp$begin_system_authority;
      rmp$request_mass_storage (swap_file_path, allocation_size, estimated_file_size, file_class,
            initial_volume, volume_overflow_allowed, status);
      IF NOT status.normal THEN
        pfp$end_system_authority;
        osp$disestablish_cond_handler;
        #KEYPOINT (osk$exit, 0, jmk$initialize_swap_file);
        RETURN;
      IFEND;

      pfp$end_system_authority;
      osp$disestablish_cond_handler;
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, jmk$initialize_swap_file);
        RETURN;
      IFEND;

      PUSH attachment_options_p: [1 .. 2];
      attachment_options_p^ [1].selector := fsc$access_and_share_modes;
      attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options_p^ [1].access_modes.value := $fst$file_access_options
            [fsc$read, fsc$shorten, fsc$append, fsc$modify];
      attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;
      attachment_options_p^ [1].share_modes.value := $fst$file_access_options [];
      attachment_options_p^ [2].selector := fsc$open_share_modes;
      attachment_options_p^ [2].open_share_modes := $fst$file_access_options [];

      PUSH mandated_creation_options_p: [1 .. 2];
      mandated_creation_options_p^ [1].selector := fsc$ring_attributes;
      mandated_creation_options_p^ [1].ring_attributes.r1 := osc$tsrv_ring;
      mandated_creation_options_p^ [1].ring_attributes.r2 := osc$tsrv_ring;
      mandated_creation_options_p^ [1].ring_attributes.r3 := osc$tsrv_ring;
      mandated_creation_options_p^ [2].selector := fsc$user_information;
      i#move (^swap_file_user_information, ^mandated_creation_options_p^ [2].
            user_information, #SIZE (jmt$swap_file_user_info));

      fsp$open_file (swap_file_path, amc$record, attachment_options_p, NIL, mandated_creation_options_p, NIL,
            NIL, swap_file_fid, status);
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, jmk$initialize_swap_file);
        RETURN;
      IFEND;

{ Call bap$inhibit_implicit_detach so that the swap file is not detached by bap$loaded_ring_cleanup.

      bap$inhibit_implicit_detach (swap_file_fid);

      fmp$get_system_file_id (swap_file_path, sfid, status);
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, jmk$initialize_swap_file);
        RETURN;
      IFEND;
      jmp$save_sfid_of_swap_file (sfid, status);
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, jmk$initialize_swap_file);
        RETURN;
      IFEND;
    IFEND;

    #KEYPOINT (osk$exit, 0, jmk$initialize_swap_file);

  PROCEND jmp_initialize_swap_file;


?? TITLE := '[XDCL] jmp$set_job_term_disposition', EJECT ??

  PROCEDURE [XDCL] jmp$set_job_term_disposition;

    qfp$discard_job;
  PROCEND jmp$set_job_term_disposition;


?? TITLE := '    JMP$GET_JOB_COMMAND_INPUT_LFN', EJECT ??

  PROCEDURE [XDCL] jmp$get_job_command_input_lfn
    (VAR local_file_name: amt$local_file_name);

    local_file_name := jmv$job_command_input_lfn;

  PROCEND jmp$get_job_command_input_lfn;


?? TITLE := '   JMP$OPERATOR_JOB', EJECT ??

  FUNCTION [XDCL, #GATE] jmp$operator_job: boolean;

{--------------------------------------------------------------------
{                       WARNING!!!
{ This function will be eliminated in the near future.
{   Use jmp$system_job or a capability-based validation instead.
{---------------------------------------------------------------------

    jmp$operator_job := jmv$executing_within_system_job;
  FUNCEND jmp$operator_job;

?? TITLE := '    JMP$JOB_FILE_FAP', EJECT ??

  FUNCTION [XDCL, #GATE] jmp$job_file_fap
    (    local_file_name: amt$local_file_name): amt$fap_pointer;

    IF jmp$system_job () THEN
      IF (local_file_name = clv$standard_files [clc$sf_command_file].path_handle_name) OR
            (local_file_name = clv$standard_files [clc$sf_job_input_file].path_handle_name) THEN
        jmp$job_file_fap := ^ofp$screen_input_fap;
      ELSEIF (local_file_name = clv$standard_files [clc$sf_job_output_file].path_handle_name) OR
            (local_file_name = clv$standard_files [clc$sf_display_a_file].path_handle_name) OR
            (local_file_name = clv$standard_files [clc$sf_display_b_file].path_handle_name) THEN
        jmp$job_file_fap := ^ofp$screen_output_fap;
      ELSE
        jmp$job_file_fap := NIL;
      IFEND;
    ELSE
      jmp$job_file_fap := NIL;
    IFEND;
  FUNCEND jmp$job_file_fap;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$terminate_job_flag_handler', EJECT ??
*copy jmh$terminate_job_flag_handler

  PROCEDURE [XDCL] jmp$terminate_job_flag_handler
    (    flag_id: ost$system_flag);

    VAR
      executing_taskid: ost$global_task_id,
      ignore_status: ost$status,
      job_mode: jmt$job_mode,
      termination_status: ost$status;

    IF jmv$executing_within_system_job = TRUE THEN
      RETURN;
    IFEND;

    pmp$get_executing_task_gtid (executing_taskid);
    IF executing_taskid <> jmv$jcb.job_monitor_id THEN
      RETURN;
    IFEND;
    pmp$get_job_mode (job_mode, ignore_status);


{ The messages logged by this routine are not message templates because the job's environment
{ may be so messed up that translating a message template is not possible.  This is particularly
{ possible for jobs that need to be killed.

    IF NOT jmv$exit_processing_inhibited THEN
      IF jmp$is_dual_state_job () THEN
        iip$terminate_disconnected_job;
      IFEND;

      jmv$exit_processing_inhibited := TRUE;
      pmp$log ('Job terminated via a TERMINATE_JOB command (exit).', ignore_status);
      osp$set_status_abnormal ('JM', jme$job_terminated_via_command, '', termination_status);
      jmp$set_job_termination_status (termination_status);
      pmp$exit (termination_status);

    ELSEIF (NOT jmv$terminal_io_disabled) AND (job_mode <> jmc$batch) THEN
      pmp$log ('Job terminated via a TERMINATE_JOB command (disable).', ignore_status);
      IF (jmp$is_dual_state_job () OR jmp$is_xterm_job () OR
            (jmv$job_attributes.originating_application_name = osc$timesharing)) THEN
        disable_terminal_io;
      IFEND;
    ELSE
      IF flag_id = jmc$kill_job_flag THEN
        pmp$log_ascii ('Job terminated via a TERMINATE_JOB command (kill).', $pmt$ascii_logset
              [pmc$system_log, pmc$job_log], pmc$msg_origin_system, ignore_status);
        pmp$set_system_flag (pmc$kill_task_flag, executing_taskid, ignore_status);
      ELSE
        pmp$log ('Job terminated via a TERMINATE_JOB command (ignore).', ignore_status);
      IFEND;
    IFEND;

  PROCEND jmp$terminate_job_flag_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$handle_logout_flag', EJECT ??

  PROCEDURE [XDCL] jmp$handle_logout_flag
    (    flag_id: ost$system_flag);

    VAR
      termination_status: ost$status;

    IF NOT jmv$exit_processing_inhibited THEN
      jmv$exit_processing_inhibited := TRUE;
      osp$set_status_abnormal ('JM', jme$job_terminating_normally, '', termination_status);
      jmp$set_job_termination_status (termination_status);
      pmp$exit (termination_status);
    IFEND;

  PROCEND jmp$handle_logout_flag;


?? TITLE := '    JMP$HANDLE_JOB_RESOURCE_SIGNAL', EJECT ??

  PROCEDURE [XDCL] jmp$handle_job_resource_signal
    (    originator: ost$global_task_id;
         signal: pmt$signal);

    VAR
      job_resource_signal: jmt$job_resource_signal;

    job_resource_signal.signal := signal;

    pmp$dispose_job_resource_cond (job_resource_signal.signal_contents);

  PROCEND jmp$handle_job_resource_signal;


?? TITLE := '    JMP$HANDLE_SIGNAL_SENSE_SWITCH', EJECT ??

  PROCEDURE [XDCL] jmp$handle_signal_sense_switch
    (    originator: ost$global_task_id;
         signal: pmt$signal);

    VAR
      signal_contents_p: ^jmt$sense_switch_signal,
      results: pmt$sense_switches,
      status: ost$status;

    status.normal := TRUE;

    signal_contents_p := #LOC (signal.contents);
    pmp$manage_sense_switches (signal_contents_p^. ON, signal_contents_p^. OFF, results, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND jmp$handle_signal_sense_switch;


?? TITLE := '    DISABLE_TERMINAL_IO', EJECT ??

  PROCEDURE disable_terminal_io;

    VAR
      data1: ^char,
      data: ^SEQ ( * ),
      ignore_status: ost$status,
      local_status: ost$status,
      logset: pmt$ascii_logset,
      terminal_file_id: amt$file_identifier;

    logset := $pmt$ascii_logset [pmc$system_log, pmc$job_log];
    local_status.normal := TRUE;

    jmv$terminal_io_disabled := TRUE;

    IF jmp$is_dual_state_job () THEN
      ifp$purge_connection_io (local_status);
      IF NOT local_status.normal THEN
        osp$generate_log_message (logset, local_status, ignore_status);
      IFEND;

    ELSEIF (jmv$job_attributes.originating_application_name = osc$timesharing) THEN
      fsp$open_file (osc$timesharing_terminal_file, amc$record, NIL, NIL, NIL, NIL, NIL, terminal_file_id,
            local_status);
      IF local_status.normal THEN
        PUSH data: [[REP 1 OF char]];
        RESET data;
        NEXT data1 IN data;
        data1^ := ' ';
        nap$se_synchronize (terminal_file_id, nac$se_synchronize_all_data, data^, local_status);
        IF local_status.normal THEN
          fsp$close_file (terminal_file_id, local_status);
        ELSE
          fsp$close_file (terminal_file_id, ignore_status);
        IFEND;
      IFEND;
      IF NOT local_status.normal THEN
        osp$generate_log_message (logset, local_status, ignore_status);
      IFEND;
    IFEND;
  PROCEND disable_terminal_io;
?? OLDTITLE ??
?? NEWTITLE := 'call_server_job_begin', EJECT ??

{ PURPOSE:
{   The purpose of this request is to notify a job's server mainframe that the
{ job has been initiated on a client mainframe.  This request will result in
{ the state of the job changing from queued to initiated in the server's KJL.
{ The job's job system label on the server is updated to reflect that the
{ job has been initiated on the client.
{ This procedure is called by the job on the client mainframe.

  PROCEDURE call_server_job_begin
    (VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT call_server_job_begin;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      data_size: dft$send_data_size,
      ignore_recovery_occured: boolean,
      ignore_status: ost$status,
      job_begin_information: jmt$jl_server_job_end_info,
      local_job_begin_information_p: ^jmt$jl_server_job_end_info,
      local_job_terminated_p: ^boolean,
      queue_entry_location: dft$rpc_queue_entry_location,
      parameter_size: dft$send_parameter_size,
      receive_from_server_data_p: dft$p_receive_data,
      receive_from_server_params_p: dft$p_receive_parameters,
      send_to_server_data_p: dft$p_send_data,
      send_to_server_parameters_p: dft$p_send_parameters,
      server_location: dft$server_location;

    status.normal := TRUE;

{ Need to convert the server's mainframe id to a queue entry location.

    jmp$get_server_job_end_info (job_begin_information);
    server_location.server_location_selector := dfc$mainframe_id;
    pmp$convert_binary_mainframe_id (job_begin_information.server_mainframe_id,
          server_location.server_mainframe, { ignore } status);

    dfp$begin_ch_remote_proc_call (server_location, { allowed_when_server_deactivated } FALSE,
          queue_entry_location, send_to_server_parameters_p, send_to_server_data_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Build the send to server parameters and data to send to the server mainframe.
{ RPC sequences are already reset.

    NEXT local_job_begin_information_p IN send_to_server_parameters_p;
    local_job_begin_information_p^ := job_begin_information;

    parameter_size := i#current_sequence_position (send_to_server_parameters_p);
    data_size := i#current_sequence_position (send_to_server_data_p);

    dfp$send_remote_procedure_call (queue_entry_location, dfc$rpc_jl_job_begin, parameter_size, data_size,
          receive_from_server_params_p, receive_from_server_data_p, status);
    IF status.normal THEN

{ Once the job's system label is updated on the server, the leveled
{ job is committed to execution.  Any server failure before this point must result in a
{ restart of the job.  Any server failure after this point must result in the job
{ waiting for the server.

      jmv$leveled_job_committed := TRUE;
      NEXT local_job_terminated_p IN receive_from_server_params_p;
      IF local_job_terminated_p^ THEN
        pmp$set_system_flag (jmc$terminate_job_flag, jmv$jcb.job_monitor_id, ignore_status);
      IFEND;
      dfp$end_ch_remote_proc_call (queue_entry_location, status);
    ELSE
      dfp$end_ch_remote_proc_call (queue_entry_location, ignore_status);
    IFEND;
  PROCEND call_server_job_begin;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$server_job_begin', EJECT ??
*copy jmh$server_job_begin

  PROCEDURE [XDCL] jmp$server_job_begin
    (VAR received_from_client_params_p { Input } : dft$p_receive_parameters;
     VAR received_from_client_data_p { Input } : dft$p_receive_data;
     VAR send_to_client_params_p { Output } : dft$p_send_parameters;
     VAR send_to_client_data_p { Output } : dft$p_send_data;
     VAR parameter_size: dft$send_parameter_size;
     VAR data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      command_lfn: amt$local_file_name,
      ignore_status: ost$status,
      job_begin_information_p: ^jmt$jl_server_job_end_info,
      job_terminated_p: ^boolean,
      path_p: ^pft$path,
      pf_cycle: pft$cycle_selector,
      password: pft$password,
      share: pft$share_selections,
      system_label_p: ^jmt$job_system_label,
      usage: pft$usage_selections;

?? NEWTITLE := 'handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      IF NOT status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

{ RPC sequences are already reset.

    NEXT job_begin_information_p IN received_from_client_params_p;
    NEXT job_terminated_p IN send_to_client_params_p;
    PUSH system_label_p;
    PUSH path_p: [1 .. 4];
    path_p^ [2] := jmc$system_user;
    path_p^ [3] := jmc$job_input_catalog;
    path_p^ [4] := job_begin_information_p^.system_job_name;
    qfp$server_job_begin (job_begin_information_p^, job_terminated_p^, path_p^ [1]);

    parameter_size := i#current_sequence_position (send_to_client_params_p);
    data_size := i#current_sequence_position (send_to_client_data_p);

    pf_cycle.cycle_option := pfc$specific_cycle;
    pf_cycle.cycle_number := 1;
    password := osc$null_name;
    usage := $pft$usage_selections [pfc$read];
    share := $pft$share_selections [pfc$read];
    pmp$get_unique_name (command_lfn, ignore_status);
    osp$establish_block_exit_hndlr (^handle_block_exit);
    pfp$begin_system_authority;
    pfp$attach (command_lfn, path_p^, pf_cycle, password, usage, share, pfc$no_wait, status);
    pfp$end_system_authority;
    osp$disestablish_cond_handler;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Read the system label for the job

    qfp$read_job_system_label (command_lfn, system_label_p^, status);
    IF NOT status.normal THEN
      amp$return (command_lfn, ignore_status);
      RETURN;
    IFEND;

{ Place the mainframe ID of the client mainframe in the job's system label.
{ This serves two purposes.  The first is to indicate when the job was initiated.  The second
{ is to indicate which mainframe the job initiated on.  This is necessary for
{ load-leveling.

    pmp$convert_binary_mainframe_id (job_begin_information_p^.client_mainframe_id,
          system_label_p^.job_initiation_location, { ignore } status);
    qfp$write_job_system_label (command_lfn, { write_label } TRUE, system_label_p^, status);
    IF NOT status.normal THEN
      amp$return (command_lfn, ignore_status);
      RETURN;
    IFEND;

    amp$return (command_lfn, status);
  PROCEND jmp$server_job_begin;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$enable_terminal_io', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$enable_terminal_io;

    jmv$terminal_io_disabled := FALSE;

  PROCEND jmp$enable_terminal_io;

?? TITLE := '    [XDCL, #GATE] JMP$ENABLE_EXIT_PROCESSING', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$enable_exit_processing;

    jmv$exit_processing_inhibited := FALSE;

  PROCEND jmp$enable_exit_processing;

?? TITLE := '    [XDCL, #GATE] JMP$INHIBIT_EXIT_PROCESSING', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$inhibit_exit_processing;

    jmv$exit_processing_inhibited := TRUE;

  PROCEND jmp$inhibit_exit_processing;

?? TITLE := '    JMP$LOGOUT', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$logout
    (VAR status: ost$status);

    VAR
      termination_status: ost$status,
      executing_taskid: ost$global_task_id;

    #KEYPOINT (osk$entry, 0, jmk$logout);
    status.normal := TRUE;

    IF jmv$executing_within_system_job THEN
      osp$set_status_abnormal ('JM', jme$illegal_system_job_command, '"LOGOUT"', status);
      #KEYPOINT (osk$exit, 0, jmk$logout);
      RETURN;
    IFEND;

    pmp$get_executing_task_gtid (executing_taskid);

    IF executing_taskid <> jmv$jcb.job_monitor_id THEN
      pmp$set_system_flag (jmc$logout_flag_id, jmv$jcb.job_monitor_id, status);
      IF NOT status.normal THEN
        osp$system_error ('SEND LOGOUT FLAG FAILURE', ^status);
      IFEND;
      pmp$exit (status);

{ exit keypoint for logout is task end keypoint in syp$return_jobs_r1_resources

    ELSE
      IF NOT jmv$exit_processing_inhibited THEN
        jmv$exit_processing_inhibited := TRUE;
        osp$set_status_abnormal ('JM', jme$job_terminating_normally, '', termination_status);
        jmp$set_job_termination_status (termination_status);
        pmp$exit (termination_status);

{ exit keypoint for logout is task end keypoint in syp$return_jobs_r1_resources

      IFEND;
    IFEND;
    #KEYPOINT (osk$exit, 0, jmk$logout);
  PROCEND jmp$logout;

?? TITLE := '    JMP$SET_JOB_TERMINATION_STATUS', EJECT ??

{
{ PURPOSE:
{   Sets the status to be returned by the SCL function $JOB_TERMINATION_STATUS.
{

  PROCEDURE [XDCL, #GATE, INLINE] jmp$set_job_termination_status
    (    status: ost$status);

    IF jmv$job_termination_status = NIL THEN
      ALLOCATE jmv$job_termination_status IN osv$task_shared_heap^;
      jmv$job_termination_status^ := status;
    IFEND;

  PROCEND jmp$set_job_termination_status;

?? TITLE := '    JMP$EMIT_JOB_BEGIN_STATISTICS', EJECT ??

  PROCEDURE jmp$emit_job_begin_statistics
    (VAR status: ost$status);

    VAR
      user_id: ost$user_identification,
      user_job_name: jmt$user_supplied_name,
      system_job_name: jmt$system_supplied_name,
      job_mode: jmt$job_mode,
      mode_data: string (11);

    status.normal := TRUE;

    pmp$get_user_identification (user_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    sfp$emit_statistic (jml$user_id, user_id.user, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_job_names (user_job_name, system_job_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    sfp$emit_statistic (jml$user_job_name, user_job_name, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_job_mode (job_mode, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF job_mode = jmc$batch THEN
      mode_data (1, 11) := 'BATCH      ';
    ELSEIF (job_mode = jmc$interactive_connected) OR (job_mode = jmc$interactive_cmnd_disconnect) OR
          (job_mode = jmc$interactive_line_disconnect) OR (job_mode = jmc$interactive_sys_disconnect) THEN
      mode_data (1, 11) := 'INTERACTIVE';
    ELSE
      mode_data (1, 11) := '           ';
    IFEND;
    sfp$emit_statistic (jml$job_mode, mode_data, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND jmp$emit_job_begin_statistics;

?? TITLE := 'JMP$LOG_STATUS_ERROR', EJECT ??

  PROCEDURE [XDCL] jmp$log_status_error
    (    status_to_display: ost$status;
         logset: pmt$ascii_logset;
     VAR status: ost$status);

    VAR
      line_count: 1 .. osc$max_status_message_lines,
      status_message_p: ^ost$status_message,
      status_message_line_count_p: ^ost$status_message_line_count,
      status_message_line_size_p: ^ost$status_message_line_size,
      status_message_line_p: ^ost$status_message_line,
      status_message: ost$status_message;

    status.normal := TRUE;
    osp$format_message (status_to_display, osc$full_message_level, osc$max_status_message_line,
          status_message, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    status_message_p := ^status_message;
    RESET status_message_p;
    NEXT status_message_line_count_p IN status_message_p;
    FOR line_count := 1 TO status_message_line_count_p^ DO
      NEXT status_message_line_size_p IN status_message_p;
      NEXT status_message_line_p: [status_message_line_size_p^] IN status_message_p;
      pmp$log_ascii (status_message_line_p^, logset, pmc$msg_origin_system, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND jmp$log_status_error;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$update_display_message', EJECT ??
*copy jmh$update_display_message

{ DESIGN:
{   If the status condition is jme$no_space_for_file, notify the operator.

  PROCEDURE [XDCL, #GATE] jmp$update_display_message
    (    message_status: ost$status);

    VAR
      formatted_message: ost$status_message,
      formatted_message_line_count_p: ^ost$status_message_line_count,
      formatted_message_line_p: ^ost$status_message_line,
      formatted_message_line_size_p: ^ost$status_message_line_size,
      formatted_message_p: ^ost$status_message,
      local_status: ost$status;

    osp$verify_system_privilege;

    formatted_message_p := ^formatted_message;
    osp$format_message (message_status, osc$brief_message_level, jmc$display_message_size, formatted_message,
          local_status);
    IF local_status.normal THEN

{ The line count should always be one.  The message template cannot exceed a
{ total of jmc$display_message_size characters in length.  If this length is
{ exceeded, the message is truncated.

      NEXT formatted_message_line_count_p IN formatted_message_p;
      NEXT formatted_message_line_size_p IN formatted_message_p;
      NEXT formatted_message_line_p: [formatted_message_line_size_p^] IN formatted_message_p;
      ofp$display_status_message (formatted_message_line_p^, { ignore } local_status);

{ If necessary, notify the operator.

      IF message_status.condition = jme$no_space_for_file THEN
        dpp$put_critical_message (formatted_message_line_p^, {ignore} local_status);
      IFEND;
    IFEND;
  PROCEND jmp$update_display_message;
?? OLDTITLE ??
?? NEWTITLE := 'jmp$initialize_job_mode', EJECT ??

  PROCEDURE jmp$initialize_job_mode;

    IF (NOT syv$clone_enabled) OR jmv$executing_within_system_job OR (NOT syv$nosve_job_template) THEN
      syp$initialize_job_mode; {Just sets syv$job_initialization_complete}
      RETURN;
    IFEND;

    IF (pfv$p_attached_pf_table <> NIL) OR (pfv$p_queued_catalog_table <> NIL) THEN
      osp$system_error (' Cannot initialize job mode', NIL);
      RETURN;
    IFEND;

    syp$initialize_job_mode;

  PROCEND jmp$initialize_job_mode;

  FUNCTION [XDCL, #GATE] jmp$job_initialized: boolean;

    jmp$job_initialized := syv$job_initialization_complete;

  FUNCEND jmp$job_initialized;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$is_dual_state_job', EJECT ??

  FUNCTION [XDCL, #GATE] jmp$is_dual_state_job: boolean;

    jmp$is_dual_state_job := (jmv$job_attributes.originating_application_name = osc$dual_state_interactive);

  FUNCEND jmp$is_dual_state_job;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$is_xterm_job', EJECT ??
 FUNCTION [XDCL, #GATE] jmp$is_xterm_job: boolean;

    jmp$is_xterm_job := jmv$xterm_job;

  FUNCEND jmp$is_xterm_job;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$is_xterm_task', EJECT ??
 FUNCTION [XDCL, #GATE] jmp$is_xterm_task
   (task_id: pmt$task_id): boolean;

    IF iiv$xt_xterm_control_block.task.exists THEN
      jmp$is_xterm_task := (iiv$xt_xterm_control_block.task.id = task_id);
    ELSE
      jmp$is_xterm_task := FALSE;
    IFEND;

  FUNCEND jmp$is_xterm_task;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$timesharing', EJECT ??

  FUNCTION [XDCL, #GATE] jmp$timesharing: boolean;

    jmp$timesharing := jmv$kjlx_p^ [jmv$jcb.job_id].timesharing_job;

  FUNCEND jmp$timesharing;


?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$log_edited_login_command', EJECT ??
*copy jmh$log_edited_login_command

  PROCEDURE [XDCL] jmp$log_edited_login_command
    (VAR status: ost$status);

    CONST
      line_size_maximum = 2000;

    VAR
      ascii_logset: pmt$ascii_logset,
      ijl_entry_p: ^jmt$initiated_job_list_entry,
      line: string (line_size_maximum),
      line_size: 0 .. line_size_maximum,
      job_abort_dispositions: [STATIC, READ, oss$job_paged_literal] array [jmt$job_abort_disposition] of
            string (9) := ['RESTART', 'TERMINATE'],
      job_recovery_dispositions: [STATIC, READ, oss$job_paged_literal] array [jmt$job_recovery_disposition] of
            string (9) := ['CONTINUE', 'RESTART', 'TERMINATE'],
      job_class_name: jmt$job_class_name,
      job_qualifier_exists: boolean,
      job_qualifier_index: 1 .. jmc$maximum_job_qualifiers,
      tcb_p: ^pmt$task_control_block,
      user_information: jmt$user_information;

?? NEWTITLE := 'add_date_time_value', EJECT ??

    PROCEDURE add_date_time_value
      (    date_time_value: jmt$date_time);

      VAR
        date: ost$date,
        ignore_status: ost$status,
        time: ost$time;

      IF date_time_value.specified THEN
        pmp$format_compact_date (date_time_value.date_time, osc$iso_date, date, ignore_status);
        pmp$format_compact_time (date_time_value.date_time, osc$hms_time, time, ignore_status);
        add_to_line (date.iso);
        add_to_line ('.');
        add_to_line (time.hms);
      ELSE
        add_to_line ('NONE');
      IFEND;
    PROCEND add_date_time_value;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] add_integer_value', EJECT ??

    PROCEDURE [INLINE] add_integer_value
      (    integer_value: integer);

      VAR
        ignore_status: ost$status,
        integer_string_value: ost$string;

      clp$convert_integer_to_string (integer_value, 10, FALSE, integer_string_value, ignore_status);
      add_to_line (integer_string_value.value (1, integer_string_value.size));
    PROCEND add_integer_value;
?? OLDTITLE ??
?? NEWTITLE := 'add_limit_value', EJECT ??

    PROCEDURE add_limit_value
      (    limit_name: ost$name);

      VAR
        ignore_status: ost$status,
        limit_value: sft$limit;

      sfp$get_job_limit (limit_name, limit_value, ignore_status);

      IF limit_value.job_abort_limit = sfc$unlimited THEN
        add_to_line ('UNLIMITED');
      ELSE
        add_integer_value (limit_value.job_abort_limit);
      IFEND;
    PROCEND add_limit_value;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] add_to_line', EJECT ??

    PROCEDURE [INLINE] add_to_line
      (    text: string ( * ));

      line (line_size + 1, STRLENGTH (text)) := text;
      line_size := line_size + STRLENGTH (text);
      WHILE (line_size > 0) AND (line (line_size) = ' ') DO
        line_size := line_size - 1;
      WHILEND;

    PROCEND add_to_line;
?? OLDTITLE ??

    status.normal := TRUE;
    jmp$determine_job_class_name (jmv$kjl_p^ [jmv$jcb.job_id].job_class, job_class_name, { ignore } status);

    avp$begin_account (jmv$jcb.user_id.family, jmv$jcb.user_id.user, avv$account_name, avv$project_name,
          jmv$jcb.jobname, jmv$kjl_p^ [jmv$jcb.job_id].job_class, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$get_ijle_p (jmv$kjl_p^ [jmv$jcb.job_id].initiated_job_list_ordinal, ijl_entry_p);
    line_size := 0;
    add_to_line ('LOGIN, LOGIN_USER=');
    add_to_line (jmv$jcb.user_id.user);
    add_to_line (', LOGIN_FAMILY=');
    add_to_line (jmv$jcb.user_id.family);
    add_to_line (', LOGIN_ACCOUNT=');
    IF avv$account_name = osc$null_name THEN
      add_to_line ('NONE');
    ELSE
      add_to_line (avv$account_name);
    IFEND;
    add_to_line (', LOGIN_PROJECT=');
    IF avv$project_name = osc$null_name THEN
      add_to_line ('NONE');
    ELSE
      add_to_line (avv$project_name);
    IFEND;
    add_to_line (', CPU_TIME_LIMIT=');
    add_limit_value (avc$cpu_time_limit_name);
    add_to_line (', EARLIEST_RUN_TIME=');
    add_date_time_value (jmv$job_attributes.earliest_run_time);
    add_to_line (', JOB_ABORT_DISPOSITION=');
    add_to_line (job_abort_dispositions [ijl_entry_p^.queue_file_information.job_abort_disposition]);
    add_to_line (', JOB_CLASS=');
    add_to_line (job_class_name);
    add_to_line (', JOB_DEFERRED_BY_USER=NO, JOB_EXECUTION_RING=');
    pmp$find_executing_task_tcb (tcb_p);
    add_integer_value (tcb_p^.target_ring);
    add_to_line (', JOB_QUALIFIER=(');
    job_qualifier_exists := FALSE;
    FOR job_qualifier_index := 1 TO jmc$maximum_job_qualifiers DO
      IF jmv$job_attributes.job_qualifier_list [job_qualifier_index] <> osc$null_name THEN
        job_qualifier_exists := TRUE;
        add_to_line (jmv$job_attributes.job_qualifier_list [job_qualifier_index]);
        add_to_line (',');
      IFEND;
    FOREND;
    IF job_qualifier_exists THEN
      line (line_size) := ')';
    ELSE
      add_to_line ('NONE)');
    IFEND;
    add_to_line (', JOB_RECOVERY_DISPOSITION=');
    add_to_line (job_recovery_dispositions [ijl_entry_p^.queue_file_information.job_recovery_disposition]);
    add_to_line (', LATEST_RUN_TIME=');
    add_date_time_value (jmv$job_attributes.latest_run_time);
    add_to_line (', MAGNETIC_TAPE_LIMIT=');
    add_limit_value (avc$magnetic_tape_limit_name);
    add_to_line (', MAXIMUM_WORKING_SET=');
    IF jmv$jcb.max_working_set_size = jmc$unlimited_working_set_size THEN
      add_to_line ('UNLIMITED');
    ELSE
      add_integer_value (jmv$jcb.max_working_set_size);
    IFEND;
    add_to_line (', SRU_LIMIT=');
    add_limit_value (avc$sru_limit_name);
    add_to_line (', USER_INFORMATION=''');
    #TRANSLATE (osv$control_codes_to_quest_mark, jmv$job_attributes.user_information, user_information);
    add_to_line (user_information);
    add_to_line (''', USER_JOB_NAME=');
    add_to_line (jmv$jcb.jobname);

    ?IF clc$compiling_for_test_harness THEN
      ascii_logset := $pmt$ascii_logset [pmc$job_log];
    ?ELSE
      ascii_logset := $pmt$ascii_logset [pmc$job_log, pmc$system_log];
    ?IFEND;

    pmp$log_ascii (line (1, line_size), ascii_logset, pmc$msg_origin_command, status);
    ?IF clc$compiling_for_test_harness THEN
      RETURN;
    ?ELSE
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ?IFEND;

    ofp$display_status_message (line (1, ofc$max_display_message), status);
  PROCEND jmp$log_edited_login_command;
?? OLDTITLE ??
MODEND jmm$job_monitor;
*DECK DECK=JMM$JOB_RECOVERY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE job management job recovery interfaces' ??
MODULE jmm$job_recovery;

{ Purpose: This module contains the job-management job-recovery
{          interfaces.  The interfaces contain routines used for idling the system,
{          resuming the system, and recovery of queues and jobs from and idled state.

{ Design: The process of queue file and job recovery during deadstart is as follows:
{         1.  Construct the Known_Job_List (KJL), Known_Output_List (KOL) and Known_Qfile_List (KQL).
{         2.  Recover Active Jobs.
{         3.  PF reconciliation and System Commit
{         4.  Recover the queues - place each job/output/queue file into the KJL/KOL/KQL.
{
{         The messages that are logged to the system log and job log are message
{         templates.  There is some code that is primarily for debugging that
{         will log non-message template messages to these logs.  This code
{         should never be executed on a customer system.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc dfc$server_mainframes_catalog
*copyc jmc$job_management_id
*copyc jmc$system_family
*copyc jme$qfile_was_not_recovered
*copyc jme$qfile_was_recovered
*copyc jme$queued_file_conditions
*copyc jmk$keypoints
*copyc jmt$jl_restart_file_version
*copyc jmt$jl_restart_job_list
*copyc jmt$job_count_range
*copyc jmt$output_count_range
*copyc jmt$output_counts
*copyc jmt$swap_file_recovery_list
*copyc jmt$swap_file_user_info
*copyc jmt$system_supplied_name
*copyc ost$status
*copyc pmt$family_name_count
*copyc pmt$family_name_list
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc amp$return
*copyc amp$set_segment_eoi
*copyc dpp$put_critical_message
*copyc fsp$build_file_ref_from_elems
*copyc fsp$close_file
*copyc fsp$open_file
*copyc i#move
*copyc jmp$all_jobs_swapped_for_idling
*copyc jmp$get_recovery_restart_file
*copyc jmp$rebuild_generic_queue
*copyc jmp$rebuild_input_queue
*copyc jmp$rebuild_output_queue
*copyc jmp$resume_activation_of_jobs
*copyc jmp$set_idle_system_event
*copyc jmp$system_job
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pfp$define
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_multi_item_info
*copyc pfp$purge
*copyc pmp$convert_binary_mainframe_id
*copyc pmp$get_family_names
*copyc pmp$get_pseudo_mainframe_id
*copyc pmp$get_unique_name
*copyc pmp$log_ascii
*copyc pmp$wait
*copyc qfp$update_last_used_ssn
*copyc syp$set_system_idling
*copyc syp$system_is_idling
*copyc tmp$ready_system_task1
*copyc jmv$input_file_recovery_option
*copyc jmv$output_file_recovery_option
*copyc jmv$qfile_recovery_option

  CONST
    restarted = 'RESTARTED',
    terminated = 'TERMINATED';

?? OLDTITLE ??
?? NEWTITLE := 'delete_swap_file', EJECT ??

  PROCEDURE delete_swap_file
    (    swap_file_path: pft$path;
     VAR status: ost$status);

    VAR
      i: integer,
      cycle_selector: pft$cycle_selector;

    cycle_selector.cycle_option := pfc$lowest_cycle;
    i := 0;

    REPEAT
      i := i + 1;
      pfp$purge (swap_file_path, cycle_selector, osc$null_name, status);
    UNTIL NOT status.normal;

    IF (status.condition = pfe$unknown_permanent_file) AND (i > 1) THEN
      status.normal := TRUE;
    IFEND;
  PROCEND delete_swap_file;
?? OLDTITLE ??
?? NEWTITLE := 'log_recovery_message', EJECT ??

  PROCEDURE log_recovery_message
    (    error_message: string ( * );
         bad_status: ost$status);

    VAR
      logset: pmt$ascii_logset,
      log_origin: pmt$log_msg_origin,
      ignore_status: ost$status;

    ignore_status.normal := TRUE;
    log_origin := pmc$msg_origin_system;
    logset := $pmt$ascii_logset [pmc$system_log, pmc$job_log];

    IF error_message <> '' THEN
      pmp$log_ascii (error_message, logset, log_origin, ignore_status);
    IFEND;

    IF NOT bad_status.normal THEN
      osp$generate_log_message (logset, bad_status, ignore_status);
    IFEND;
  PROCEND log_recovery_message;


?? TITLE := 'sort_directory', EJECT ??

  PROCEDURE sort_directory
    (    directory: pft$p_directory_array);

    VAR
      gap: integer,
      start: integer,
      current: integer,
      swap: pft$directory_array_entry;

{ Use shell sort technique.

    gap := UPPERBOUND (directory^);
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := 1 TO UPPERBOUND (directory^) - gap DO
        current := start;
        WHILE (current > 0) AND (directory^ [current].name > directory^ [current + gap].name) DO
          swap := directory^ [current];
          directory^ [current] := directory^ [current + gap];
          directory^ [current + gap] := swap;
          current := current - gap;
        WHILEND;
      FOREND;
    WHILEND;
  PROCEND sort_directory;



?? TITLE := 'read_directory', EJECT ??

{
{    The purpose of this request is to read the directory of the catalog
{  specified on the request.  A sequence (file) is used as a placeholder for
{  the directory.  The directory is returned as a pointer to an adaptable
{  array of names.
{
{        READ_DIRECTORY (CATALOG_PATH, SEQUENCE_P, DIRECTORY_ARRAY_P, STATUS);
{
{ CATALOG_PATH: (input) This is the catalog that the directory is being
{        requested for.
{
{ SEQUENCE_P: (input/output) This is a sequence (file) that is used to place
{        the requested information on.
{
{ DIRECTORY_ARRAY_P: (output) This is a pointer to an adaptable array of the
{        names in the catalog's directory.
{
{ STATUS: (output) This is the status of the request.
{

  PROCEDURE read_directory
    (    catalog_path: pft$path;
     VAR sequence_p: ^SEQ ( * );
     VAR directory_array_p: pft$p_directory_array;
     VAR status: ost$status);

    VAR
      group: pft$group,
      info_record_p: pft$p_info_record;

    RESET sequence_p;
    group.group_type := pfc$public;

{ This request places all of the desired information into the sequence

    pfp$get_multi_item_info (catalog_path, group, $pft$catalog_info_selections [],
          $pft$file_info_selections [pfc$file_description], sequence_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ This request validates what has been placed in the sequence

    RESET sequence_p;
    pfp$find_next_info_record (sequence_p, info_record_p, status);
    IF status.normal AND (info_record_p = NIL) THEN
      osp$set_status_abnormal ('JM', jme$unable_to_recover_catalog, catalog_path [1], status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ This request converts the information in the sequence to something useful
{ i.e., an array that the caller can recognize.

    pfp$find_directory_array (info_record_p, directory_array_p, status);
    IF directory_array_p <> NIL THEN
      sort_directory (directory_array_p);
    IFEND;
  PROCEND read_directory;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$add_to_server_restart_file', EJECT ??

{ PURPOSE:
{   The purpose of this request is to add a job to a file containing a list of
{   jobs that a server needs to restart or recover using the job's job abort
{   disposition.
{
{ DESIGN:
{   This request opens and closes the recovery restart file every time a job
{ needs to be added.  Generally, it is expected that this request will never
{ be called.  But, even if it is, the number of times it is called is limited
{ by the number of active jobs that have been leveled from the particular
{ server that have a job recovery disposition of restart.  Therefore,
{ performance is not a constraint for this procedure.

  PROCEDURE [XDCL] jmp$add_to_server_restart_file
    (    swap_file_path_p: ^pft$path;
         recover_using_abort_disposition: boolean);

    VAR
      attachment_options_p: ^fst$attachment_options,
      created_server_file: boolean,
      cycle_selector: pft$cycle_selector,
      ignore_contains_data: boolean,
      ignore_file_exists: boolean,
      ignore_previously_opened: boolean,
      ignore_status: ost$status,
      local_status: ost$status,
      recovering_mainframe_id: pmt$binary_mainframe_id,
      restart_file_version_p: ^jmt$jl_restart_file_version,
      restart_job_count_p: ^jmt$job_count_range,
      restart_job_list_p: ^jmt$jl_restart_job_list,
      restart_job_p: ^jmt$jl_restart_job,
      restart_job_sequence_p: ^SEQ ( * ),
      segment_pointer: amt$segment_pointer,
      server_file_identifier: amt$file_identifier,
      server_file_lfn: ost$name,
      server_file_path: fst$path,
      server_file_path_p: ^pft$path,
      server_mainframe_id: pmt$mainframe_id,
      swap_file_attributes_p: ^amt$get_attributes,
      swap_file_path: fst$path,
      swap_file_user_information: jmt$swap_file_user_info;

    PUSH swap_file_attributes_p: [1 .. 1];
    swap_file_attributes_p^ [1].key := amc$user_info;
    fsp$build_file_ref_from_elems (swap_file_path_p, swap_file_path, ignore_status);
    amp$get_file_attributes (swap_file_path, swap_file_attributes_p^, ignore_file_exists,
          ignore_previously_opened, ignore_contains_data, local_status);
    IF NOT local_status.normal THEN
      log_recovery_message (swap_file_path, local_status);
      RETURN;
    IFEND;

    i#move (^swap_file_attributes_p^ [1].user_info, ^swap_file_user_information,
          #SIZE (swap_file_user_information));
    IF swap_file_user_information.version <> jmc$swap_file_version_1 THEN
      local_status.normal := TRUE;
      log_recovery_message ('Invalid swap file version', local_status);
      RETURN;
    IFEND;

{ If this is the job's server mainframe the job has been lost.
{ When deadstart is changed to log sufficient job history information for
{ recovery this should be noted.

    pmp$get_pseudo_mainframe_id (recovering_mainframe_id);
    IF swap_file_user_information.server_mainframe_id = recovering_mainframe_id THEN
      RETURN;
    IFEND;

    pmp$convert_binary_mainframe_id (swap_file_user_information.server_mainframe_id, server_mainframe_id,
          local_status);
    IF NOT local_status.normal THEN
      log_recovery_message ('Swap file has invalid server mainframe id.', local_status);
      RETURN;
    IFEND;

    pmp$get_unique_name (server_file_lfn, ignore_status);
    PUSH server_file_path_p: [1 .. 4];
    server_file_path_p^ [1] := jmc$system_family;
    server_file_path_p^ [2] := jmc$system_user;
    server_file_path_p^ [3] := dfc$server_mainframes_catalog;
    jmp$get_recovery_restart_file (server_mainframe_id, server_file_path_p^ [4]);

{ Create the file to place the swap file restart list in.  If an error is returned
{ assume that the file already exists.

    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := 1;
    pfp$define (server_file_lfn, server_file_path_p^, cycle_selector, { password } osc$null_name,
          { retention } pfc$maximum_retention, pfc$log, local_status);
    IF local_status.normal THEN
      created_server_file := TRUE;
      amp$return (server_file_lfn, ignore_status);
    ELSE
      created_server_file := FALSE;
      IF local_status.condition = pfe$duplicate_cycle THEN
        local_status.normal := TRUE;
      ELSE
        log_recovery_message ('Got unexpected error attempting to create the restart file.', local_status);
        RETURN;
      IFEND;
    IFEND;

{ Open the server file as a sequence.

    fsp$build_file_ref_from_elems (server_file_path_p, server_file_path, ignore_status);
    PUSH attachment_options_p: [1 .. 3];
    attachment_options_p^ [1].selector := fsc$access_and_share_modes;
    attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options_p^ [1].access_modes.value := $fst$file_access_options
          [fsc$read, fsc$shorten, fsc$append, fsc$modify];
    attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options_p^ [1].share_modes.value := $fst$file_access_options [];
    attachment_options_p^ [2].selector := fsc$open_share_modes;
    attachment_options_p^ [2].open_share_modes := $fst$file_access_options [];
    attachment_options_p^ [3].selector := fsc$wait_for_attachment;
    attachment_options_p^ [3].wait_for_attachment.wait := osc$wait;
    attachment_options_p^ [3].wait_for_attachment.wait_time := 300000; { five minutes
    fsp$open_file (server_file_path, amc$segment, attachment_options_p, NIL, NIL, NIL, NIL,
          server_file_identifier, local_status);
    IF NOT local_status.normal THEN
      log_recovery_message (server_file_path, local_status);
      RETURN;
    IFEND;
    amp$get_segment_pointer (server_file_identifier, amc$sequence_pointer, segment_pointer, local_status);
    IF NOT local_status.normal THEN
      log_recovery_message (server_file_path, local_status);
      fsp$close_file (server_file_identifier, ignore_status);
      RETURN;
    IFEND;

{ Add the job to the restart list in the file.

    restart_job_sequence_p := segment_pointer.sequence_pointer;
    RESET restart_job_sequence_p;
    NEXT restart_file_version_p IN restart_job_sequence_p;
    NEXT restart_job_count_p IN restart_job_sequence_p;
    IF created_server_file THEN
      restart_file_version_p^ := jmc$jl_rfv_version_1;
      restart_job_count_p^ := 0;
    ELSE

{ If the restart file version matches, add to the file.  If the restart file
{ version does not match, discard the contents of the file and reformat the
{ file to the new contents.

      IF restart_file_version_p^ = jmc$jl_rfv_version_1 THEN
        NEXT restart_job_list_p: [1 .. restart_job_count_p^] IN restart_job_sequence_p;
      ELSE
        restart_file_version_p^ := jmc$jl_rfv_version_1;
        restart_job_count_p^ := 0;
      IFEND;
    IFEND;
    NEXT restart_job_p IN restart_job_sequence_p;
    restart_job_p^.system_job_name := swap_file_path_p^ [4];
    restart_job_p^.recover_using_abort_disposition := recover_using_abort_disposition;
    restart_job_count_p^ := restart_job_count_p^ +1;

{ Close the file with the correct EOI.

    segment_pointer.sequence_pointer := restart_job_sequence_p;
    amp$set_segment_eoi (server_file_identifier, segment_pointer, local_status);
    IF NOT local_status.normal THEN
      log_recovery_message (server_file_path, local_status);
      fsp$close_file (server_file_identifier, ignore_status);
      RETURN;
    IFEND;

    fsp$close_file (server_file_identifier, local_status);
    IF NOT local_status.normal THEN
      log_recovery_message (server_file_path, local_status);
    IFEND;
  PROCEND jmp$add_to_server_restart_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$idle_system', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$idle_system
    (VAR status: ost$status);

    VAR
      wait_on_jobs: integer,
      i: integer,
      ignore_status: ost$status;

    status.normal := TRUE;
    ignore_status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, jmk$idle_system);

    IF NOT jmp$system_job () THEN
      osp$set_status_abnormal ('JM', jme$must_be_system_job, 'jmp$idle_system', status);
      #KEYPOINT (osk$exit, 0, jmk$idle_system);
      RETURN;
    IFEND;

{ See if the system is idling - if so - return

    IF syp$system_is_idling () THEN
      #KEYPOINT (osk$exit, 0, jmk$idle_system);
      RETURN;
    IFEND;

{ the following requests:
{  1.  suspend initiation of jobs
{  2.  prohibit jobs from swapping in
{  3.  swap out all active jobs

    jmp$set_idle_system_event;
    i := 0;
    wait_on_jobs := 0;

  /time_check/

    WHILE NOT jmp$all_jobs_swapped_for_idling () DO

{ Put out a message every 5 seconds showing why the system is waiting.

      IF i = 0 THEN
        dpp$put_critical_message ('Wait 2 minutes max for all jobs to swap...', ignore_status);
        wait_on_jobs := wait_on_jobs + 1;
        IF wait_on_jobs > 20 THEN

{ Wait for 2 minutes for all jobs to swap - if not complete by then,
{ somthing is wrong. Force the system to terminate and so that we at the
{ least are able to recover all other jobs.

          dpp$put_critical_message ('Unable to swap all jobs...', ignore_status);
          dpp$put_critical_message ('  some jobs will not be recovered.', ignore_status);
          EXIT /time_check/
        IFEND;
      IFEND;
      pmp$wait (1000, 1000);
      i := (i + 1) MOD 5;
    WHILEND /time_check/;

{ Set the flag to allow interested parties to determine
{ that the system is being idled

    syp$set_system_idling (TRUE);

    #KEYPOINT (osk$exit, 0, jmk$idle_system);
  PROCEND jmp$idle_system;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$recover_input_queue', EJECT ??

{ PURPOSE:
{   The purpose of this request is to recover a standard input queue catalog.
{

  PROCEDURE [XDCL] jmp$recover_input_queue
    (    family_name: ost$name;
         defer_input_queue: boolean;
     VAR status: ost$status);

    VAR
      directory_array_p: pft$p_directory_array,
      ignore_status: ost$status,
      local_status: ost$status,
      name_index: integer,
      path_p: ^pft$path,
      segment_pointer: amt$segment_pointer,
      system_job_name: jmt$system_supplied_name;

    status.normal := TRUE;
    PUSH path_p: [1 .. 3];
    path_p^ [1] := family_name;
    path_p^ [2] := jmc$system_user;
    path_p^ [3] := jmc$job_input_catalog;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
    IF NOT status.normal THEN
      log_recovery_message ('Could not create a scratch segment for queue recovery.', status);
      #KEYPOINT (osk$exit, 0, jmk$recover_queues);
      RETURN;
    IFEND;

{ Read the job input catalog

    read_directory (path_p^, segment_pointer.sequence_pointer, directory_array_p, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$unable_to_recover_catalog, jmc$job_input_catalog,
            local_status);
      osp$append_status_parameter (osc$status_parameter_delimiter, family_name, local_status);
      log_recovery_message ('', local_status);
      log_recovery_message ('', status);
      RETURN;
    IFEND;

    IF directory_array_p <> NIL THEN

    /recover_all_files/
      FOR name_index := LOWERBOUND (directory_array_p^) TO UPPERBOUND (directory_array_p^) DO

        system_job_name := directory_array_p^ [name_index].name;

        jmp$rebuild_input_queue (directory_array_p^ [name_index].name (1, jmc$system_supplied_name_size),
              path_p^ [1], path_p^ [3], {recover_using_abort_disposition} FALSE,
              {ignore_client_initiated_jobs} FALSE, defer_input_queue, local_status);

        IF local_status.normal THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$input_was_recovered, system_job_name,
                ignore_status);
          log_recovery_message ('', ignore_status);
        ELSE
          osp$set_status_abnormal (jmc$job_management_id, jme$input_was_not_recovered, system_job_name,
                ignore_status);
          log_recovery_message ('', ignore_status);
          log_recovery_message ('', local_status);
        IFEND;
      FOREND /recover_all_files/;
    IFEND;

  PROCEND jmp$recover_input_queue;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$recover_queues', EJECT ??
*copyc jmh$recover_queues

  PROCEDURE [XDCL] jmp$recover_queues
    (    swap_file_recovery_list: ^jmt$swap_file_recovery_list;
         swap_file_recovery_list_count: jmt$job_count_range;
     VAR status: ost$status);

    VAR
      directory_array_p: pft$p_directory_array,
      sequence_p: ^SEQ ( * ),
      path_p: ^pft$path,
      family_index: pmt$family_name_count,
      family_name_list: ^pmt$family_name_list,
      family_name_count: pmt$family_name_count,
      segment_pointer: amt$segment_pointer,
      swap_file_path_p: ^pft$path,
      swap_index: integer,
      name_index: integer,
      recovery_message: string (80),
      recover_using_abort_disposition: boolean,
      length: integer,
      local_status: ost$status,
      ignore_status: ost$status;

?? NEWTITLE := 'recover_generic_queue', EJECT ??

    PROCEDURE recover_generic_queue;

{ Read the generic queue directory

      path_p^ [3] := jmc$generic_queue_catalog;
      read_directory (path_p^, sequence_p, directory_array_p, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$unable_to_recover_catalog,
              jmc$generic_queue_catalog, local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, jmc$system_family, local_status);
        log_recovery_message ('', local_status);
        log_recovery_message ('', status);
        #KEYPOINT (osk$exit, 0, jmk$recover_queues);
        RETURN;
      IFEND;

{ Recover the generic queue

      IF directory_array_p <> NIL THEN
        FOR name_index := LOWERBOUND (directory_array_p^) TO UPPERBOUND (directory_array_p^) DO
          jmp$rebuild_generic_queue (directory_array_p^ [name_index].name (1, jmc$system_supplied_name_size),
                local_status);
          IF local_status.normal THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$qfile_was_recovered,
                  directory_array_p^ [name_index].name (1, jmc$system_supplied_name_size), local_status);
            log_recovery_message ('', local_status);

          ELSE
            osp$set_status_abnormal (jmc$job_management_id, jme$qfile_was_not_recovered,
                  directory_array_p^ [name_index].name (1, jmc$system_supplied_name_size), ignore_status);
            log_recovery_message ('', ignore_status);
            log_recovery_message ('', local_status);
          IFEND;
        FOREND;
      IFEND;
    PROCEND recover_generic_queue;
?? OLDTITLE ??
?? NEWTITLE := 'recover_input_queue', EJECT ??

{ PURPOSE:
{   The purpose of this request is to recover a standard input queue catalog.
{
{ DESIGN:
{   Read the names of the files in the input queue.  Compare this list of names with the list of names in
{ swap catalog.  If there is no entry in the swap catalog, then the job is has not been initiated so attempt
{ to recover it.  If there is an entry in the swap catalog there are four possible cases that need to be
{ managed.  If the recovery disposition of the job is not known the job should be recovered under the
{ job_abort_disposition specified when the job was submitted.  If the recovery disposition is CONTINUE then
{ the job has been recovered.  If the recovery disposition is RESTART then delete the swap file and
{ requeue the job.  Otherwise (the recovery disposition is TERMINATE) delete the swap file and the input
{ file.

    PROCEDURE recover_input_queue
      (    family_name: ost$name;
           swap_file_recovery_list_p: ^jmt$swap_file_recovery_list;
           swap_file_recovery_list_count: jmt$job_count_range;
       VAR sequence_p: ^SEQ ( * );
       VAR status: ost$status);

      VAR
        cycle_selector: pft$cycle_selector,
        directory_array_p: pft$p_directory_array,
        ignore_status: ost$status,
        input_file_path_p: ^pft$path,
        length: integer,
        local_status: ost$status,
        name_index: integer,
        path_p: ^pft$path,
        recovery_message: string (80),
        recover_using_abort_disposition: boolean,
        swap_file_path_p: ^pft$path,
        swap_index: integer,
        system_job_name: jmt$system_supplied_name;

      status.normal := TRUE;
      PUSH path_p: [1 .. 3];
      path_p^ [1] := family_name;
      path_p^ [2] := jmc$system_user;
      path_p^ [3] := jmc$job_input_catalog;

      cycle_selector.cycle_option := pfc$specific_cycle;
      cycle_selector.cycle_number := 1;
      PUSH input_file_path_p: [1 .. 4];
      input_file_path_p^ [1] := path_p^ [1];
      input_file_path_p^ [2] := path_p^ [2];
      input_file_path_p^ [3] := path_p^ [3];

      PUSH swap_file_path_p: [1 .. 4];
      swap_file_path_p^ [1] := jmc$system_family;
      swap_file_path_p^ [2] := jmc$system_user;
      swap_file_path_p^ [3] := jmc$job_swap_catalog;

{ Read the job input catalog

      read_directory (path_p^, sequence_p, directory_array_p, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$unable_to_recover_catalog, jmc$job_input_catalog,
              local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, family_name, local_status);
        log_recovery_message ('', local_status);
        log_recovery_message ('', status);
        RETURN;
      IFEND;

      IF directory_array_p <> NIL THEN

      /recover_all_files/
        FOR name_index := LOWERBOUND (directory_array_p^) TO UPPERBOUND (directory_array_p^) DO

          system_job_name := directory_array_p^ [name_index].name;
          recover_using_abort_disposition := FALSE;

{ Check to see if the job has a swap file

        /search_swap_file_list/
          FOR swap_index := 1 TO swap_file_recovery_list_count DO
            IF system_job_name = swap_file_recovery_list^ [swap_index].system_job_name THEN

{ The job's command file exists.  This means that the queue recovery knows what to to with
{ the job's swap file.

              swap_file_recovery_list^ [swap_index].command_file_exists := TRUE;
              IF swap_file_recovery_list^ [swap_index].recovery_disposition_available THEN
                CASE swap_file_recovery_list^ [swap_index].job_recovery_disposition OF
                = jmc$continue_on_recovery =
                  osp$set_status_abnormal (jmc$job_management_id, jme$job_was_recovered, system_job_name,
                        local_status);
                  log_recovery_message ('', local_status);
                  CYCLE /recover_all_files/;

                = jmc$restart_on_recovery =
                  osp$set_status_abnormal (jmc$job_management_id, jme$job_was_not_recovered, system_job_name,
                        local_status);
                  log_recovery_message ('', local_status);
                  osp$set_status_abnormal (jmc$job_management_id, jme$job_recovery_or_abort_set, restarted,
                        local_status);
                  log_recovery_message ('', local_status);
                  swap_file_path_p^ [4] := system_job_name;
                  delete_swap_file (swap_file_path_p^, local_status);
                  log_recovery_message ('', local_status);
                  EXIT /search_swap_file_list/;

                = jmc$terminate_on_recovery =
                  osp$set_status_abnormal (jmc$job_management_id, jme$job_was_not_recovered, system_job_name,
                        local_status);
                  log_recovery_message ('', local_status);
                  osp$set_status_abnormal (jmc$job_management_id, jme$job_recovery_or_abort_set, terminated,
                        local_status);
                  log_recovery_message ('', local_status);
                  swap_file_path_p^ [4] := system_job_name;
                  delete_swap_file (swap_file_path_p^, local_status);
                  log_recovery_message ('', local_status);
                  input_file_path_p^ [4] := system_job_name;
                  pfp$purge (input_file_path_p^, cycle_selector, osc$null_name, local_status);
                  log_recovery_message ('', local_status);
                  CYCLE /recover_all_files/;
                ELSE
                CASEND;
              ELSE
                recover_using_abort_disposition := TRUE;
                osp$set_status_abnormal (jmc$job_management_id, jme$job_was_not_recovered, system_job_name,
                      local_status);
                log_recovery_message ('', local_status);
                swap_file_path_p^ [4] := system_job_name;
                delete_swap_file (swap_file_path_p^, local_status);
                log_recovery_message ('', local_status);
                EXIT /search_swap_file_list/;
              IFEND;
            IFEND;
          FOREND /search_swap_file_list/;

{ The job either didn't have a swap file or it wasn't recovered - try to recover the command file.

          jmp$rebuild_input_queue (directory_array_p^ [name_index].name (1, jmc$system_supplied_name_size),
                path_p^ [1], path_p^ [3], recover_using_abort_disposition,
                {ignore_client_initiated_jobs} FALSE, {job_deferred_by_operator} FALSE, local_status);

          IF local_status.normal THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$input_was_recovered, system_job_name,
                  ignore_status);
            log_recovery_message ('', ignore_status);
          ELSE
            osp$set_status_abnormal (jmc$job_management_id, jme$input_was_not_recovered, system_job_name,
                  ignore_status);
            log_recovery_message ('', ignore_status);
            log_recovery_message ('', local_status);
          IFEND;
        FOREND /recover_all_files/;
      IFEND;

    PROCEND recover_input_queue;
?? OLDTITLE ??
?? NEWTITLE := 'recover_output_queue', EJECT ??

    PROCEDURE recover_output_queue;

{ Read the output queue directory

      path_p^ [3] := jmc$job_output_catalog;
      read_directory (path_p^, sequence_p, directory_array_p, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$unable_to_recover_catalog, jmc$job_output_catalog,
              local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, jmc$system_family, local_status);
        log_recovery_message ('', local_status);
        log_recovery_message ('', status);
        #KEYPOINT (osk$exit, 0, jmk$recover_queues);
        RETURN;
      IFEND;

{ Recover the output queue

      IF directory_array_p <> NIL THEN
        FOR name_index := LOWERBOUND (directory_array_p^) TO UPPERBOUND (directory_array_p^) DO
          jmp$rebuild_output_queue (directory_array_p^ [name_index].name (1, jmc$system_supplied_name_size),
                path_p^ [3], local_status);
          IF local_status.normal THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$output_was_recovered,
                  directory_array_p^ [name_index].name (1, jmc$system_supplied_name_size), local_status);
            log_recovery_message ('', local_status);

          ELSE
            osp$set_status_abnormal (jmc$job_management_id, jme$output_was_not_recovered,
                  directory_array_p^ [name_index].name (1, jmc$system_supplied_name_size), ignore_status);
            log_recovery_message ('', ignore_status);
            log_recovery_message ('', local_status);
          IFEND;
        FOREND;
      IFEND;
    PROCEND recover_output_queue;
?? OLDTITLE ??
?? NEWTITLE := 'recover_sf_input_queue', EJECT ??

    PROCEDURE recover_sf_input_queue;

{ Read the store-and-forward job input catalog

      path_p^ [1] := jmc$system_family;
      path_p^ [2] := jmc$system_user;
      path_p^ [3] := jmc$sf_job_input_catalog;

      read_directory (path_p^, sequence_p, directory_array_p, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$unable_to_recover_catalog,
              jmc$sf_job_input_catalog, local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, jmc$system_family, local_status);
        log_recovery_message ('', local_status);
        log_recovery_message ('', status);
        status.normal := TRUE;
      IFEND;

      IF directory_array_p <> NIL THEN
        FOR name_index := LOWERBOUND (directory_array_p^) TO UPPERBOUND (directory_array_p^) DO

{ Recover the input file.

          jmp$rebuild_input_queue (directory_array_p^ [name_index].name (1, jmc$system_supplied_name_size),
                path_p^ [1], path_p^ [3], {recover_using_abort_disposition} FALSE,
                {ignore_client_initiated_jobs} TRUE, {job_deferred_by_operator} FALSE, local_status);
          IF local_status.normal THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$input_was_recovered,
                  directory_array_p^ [name_index].name (1, jmc$system_supplied_name_size), ignore_status);
            log_recovery_message ('', ignore_status);
          ELSE
            osp$set_status_abnormal (jmc$job_management_id, jme$input_was_not_recovered,
                  directory_array_p^ [name_index].name (1, jmc$system_supplied_name_size), ignore_status);
            log_recovery_message ('', ignore_status);
            log_recovery_message ('', local_status);
          IFEND;
        FOREND;
      IFEND;
    PROCEND recover_sf_input_queue;
?? OLDTITLE ??
?? NEWTITLE := 'recover_sf_output_queue', EJECT ??

    PROCEDURE recover_sf_output_queue;

{ Read the store and forward output queue directory

      path_p^ [3] := jmc$sf_job_output_catalog;
      read_directory (path_p^, sequence_p, directory_array_p, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$unable_to_recover_catalog,
              jmc$sf_job_output_catalog, local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, jmc$system_family, local_status);
        log_recovery_message ('', local_status);
        log_recovery_message ('', status);
        #KEYPOINT (osk$exit, 0, jmk$recover_queues);
        RETURN;
      IFEND;

{ Recover the store and forward output queue.

      IF directory_array_p <> NIL THEN
        FOR name_index := LOWERBOUND (directory_array_p^) TO UPPERBOUND (directory_array_p^) DO
          jmp$rebuild_output_queue (directory_array_p^ [name_index].name (1, jmc$system_supplied_name_size),
                path_p^ [3], local_status);
          IF local_status.normal THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$output_was_recovered,
                  directory_array_p^ [name_index].name (1, jmc$system_supplied_name_size), ignore_status);
            log_recovery_message ('', ignore_status);

          ELSE
            osp$set_status_abnormal (jmc$job_management_id, jme$output_was_not_recovered,
                  directory_array_p^ [name_index].name (1, jmc$system_supplied_name_size), ignore_status);
            log_recovery_message ('', ignore_status);
            log_recovery_message ('', local_status);
          IFEND;
        FOREND;
      IFEND;
    PROCEND recover_sf_output_queue;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    local_status.normal := TRUE;
    ignore_status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, jmk$recover_queues);

{ Create a scratch sequence to use for the perm file interfaces

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
    IF NOT status.normal THEN
      log_recovery_message ('Could not create a scratch segment for queue recovery.', status);
      #KEYPOINT (osk$exit, 0, jmk$recover_queues);
      RETURN;
    IFEND;

    sequence_p := segment_pointer.sequence_pointer;

{ Do some initial setup before reading any catalogs

    PUSH path_p: [1 .. 3];
    path_p^ [1] := jmc$system_family;
    path_p^ [2] := jmc$system_user;

    IF jmv$output_file_recovery_option = jmc$ofro_recover_all_files THEN
      recover_output_queue;
      recover_sf_output_queue;
    IFEND;

    IF jmv$qfile_recovery_option = jmc$qro_recover_all_files THEN
      recover_generic_queue;
    IFEND;

{ Recover the input queues - only recover those jobs that are not executing
{ or executing job's that indicate they should be restarted.

{ Find the family names on the system.
{ Each family has its own input queue.  Its form is as follows:
{   :<family_name>.$SYSTEM.$JOB_INPUT_QUEUE.

{ Make a guess at the number of family names defined.  The pmp$get_family_names request
{ only returns abnormal status if the result array is too full.

    PUSH family_name_list: [1 .. 10];
    pmp$get_family_names (family_name_list^, family_name_count, local_status);
    IF NOT local_status.normal THEN
      PUSH family_name_list: [1 .. family_name_count];
      pmp$get_family_names (family_name_list^, family_name_count, { ignore } local_status);
    IFEND;

    IF jmv$input_file_recovery_option = jmc$ifro_recover_all_files THEN
      FOR family_index := 1 TO family_name_count DO
        local_status.normal := TRUE;
        recover_input_queue (family_name_list^ [family_index], swap_file_recovery_list,
              swap_file_recovery_list_count, sequence_p, { ignore } local_status);
      FOREND;
    IFEND;

{ Delete the swap files on any non-recovered jobs that do not have command files.

    PUSH swap_file_path_p: [1 .. 4];
    swap_file_path_p^ [1] := jmc$system_family;
    swap_file_path_p^ [2] := jmc$system_user;
    swap_file_path_p^ [3] := jmc$job_swap_catalog;

    FOR swap_index := 1 TO swap_file_recovery_list_count DO
      IF (NOT swap_file_recovery_list^ [swap_index].command_file_exists) THEN
        IF (swap_file_recovery_list^ [swap_index].recovery_disposition_available AND
              (swap_file_recovery_list^ [swap_index].job_recovery_disposition <> jmc$continue_on_recovery)) OR
              (NOT swap_file_recovery_list^ [swap_index].recovery_disposition_available) THEN
          swap_file_path_p^ [4] := swap_file_recovery_list^ [swap_index].system_job_name;
          osp$set_status_abnormal (jmc$job_management_id, jme$job_was_not_recovered, swap_file_path_p^ [4],
                local_status);
          log_recovery_message ('', local_status);
          IF (NOT swap_file_recovery_list^ [swap_index].recovery_disposition_available) OR
                (swap_file_recovery_list^ [swap_index].job_recovery_disposition = jmc$restart_on_recovery)
                THEN
            jmp$add_to_server_restart_file (swap_file_path_p, { recover_using_abort_disposition } NOT
                  swap_file_recovery_list^ [swap_index].recovery_disposition_available);
            osp$set_status_abnormal (jmc$job_management_id, jme$job_recovery_or_abort_set, restarted,
                  local_status);
            log_recovery_message ('', local_status);
          ELSE
            osp$set_status_abnormal (jmc$job_management_id, jme$job_recovery_or_abort_set, terminated,
                  local_status);
            log_recovery_message ('', local_status);
          IFEND;

          delete_swap_file (swap_file_path_p^, local_status);
          log_recovery_message ('', local_status);
        ELSE
          osp$set_status_abnormal (jmc$job_management_id, jme$job_was_recovered,
                swap_file_recovery_list^ [swap_index].system_job_name, local_status);
          log_recovery_message ('', local_status);
        IFEND;
      IFEND;
    FOREND;

    IF jmv$input_file_recovery_option = jmc$ifro_recover_all_files THEN
      recover_sf_input_queue;
    IFEND;
    mmp$delete_scratch_segment (segment_pointer, status);
    #KEYPOINT (osk$exit, 0, jmk$recover_queues);
  PROCEND jmp$recover_queues;
?? TITLE := '[XDCL, #GATE] jmp$resume_system', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$resume_system
    (VAR status: ost$status);

    VAR
      output_counts: jmt$output_counts,
      ignore_status: ost$status;

    status.normal := TRUE;
    ignore_status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, jmk$resume_system);

    IF NOT jmp$system_job () THEN
      osp$set_status_abnormal ('JM', jme$must_be_system_job, 'jmp$resume_system', status);
      #KEYPOINT (osk$exit, 0, jmk$resume_system);
      RETURN;
    IFEND;

{ See if the system is idling - if not - return

    IF NOT syp$system_is_idling () THEN
      #KEYPOINT (osk$exit, 0, jmk$resume_system);
      RETURN;
    IFEND;

{ Set a flag to allow interested parties to determine
{ that the system is no longer idling

    syp$set_system_idling (FALSE);

{   swap the jobs back in

    jmp$resume_activation_of_jobs;

    #KEYPOINT (osk$exit, 0, jmk$resume_system);
  PROCEND jmp$resume_system;
?? TITLE := '[XDCL, #GATE] jmp$update_last_used_ssn', EJECT ??
*copyc jmh$update_last_used_ssn

  PROCEDURE [XDCL, #GATE] jmp$update_last_used_ssn
    (VAR status: ost$status);

    status.normal := TRUE;
    IF NOT jmp$system_job () THEN
      osp$set_status_abnormal ('JM', jme$must_be_system_job, 'jmp$update_last_used_ssn', status);
      RETURN;
    IFEND;

    qfp$update_last_used_ssn;
  PROCEND jmp$update_last_used_ssn;
MODEND jmm$job_recovery;
*DECK DECK=JMM$JOB_SCHEDULER_MONITOR_MODE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : job scheduler monitor mode' ??
MODULE jmm$job_scheduler_monitor_mode;

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc jmv$ajl_p
*copyc jmv$ijl_p
*copyc jmv$max_ajl_ordinal_in_use
*copyc jmv$number_free_ajl_entries
*copyc jmv$swap_jobs_in_long_wait
*copyc jmv$system_ajl_ordinal
*copyc jmv$system_ijl_ordinal
*copyc jsv$ijl_swap_queue_list
*copyc mmv$reduce_jws_for_thrashing
*copyc tmv$cpu_execution_statistics
*copyc tmv$dispatch_priority_integer
*copyc tmv$dispatching_controls
*copyc tmv$dispatching_control_sets
*copyc tmv$dispatching_control_time
*copyc tmv$ptl_lock

*copyc jmp$get_ijle_p
*copyc jmp$calculate_service
*copyc jmp$change_ijl_entry_status
*copyc jmp$find_jsn
*copyc jsp$monitor_advance_swap
*copyc jsp$monitor_swap_in
*copyc jsp$monitor_swap_out
*copyc jsp$relink_swap_queue
*copyc mmp$nudge_periodic_call
*copyc mtp$error_stop
*copyc mtp$set_status_abnormal
*copyc osp$fetch_locked_variable
*copyc osp$set_locked_variable
*copyc tmp$calculate_dct_priority_int
*copyc tmp$clear_lock
*copyc tmp$free_unrecovered_tasks
*copyc tmp$monitor_ready_system_task
*copyc tmp$reset_dispatching_control
*copyc tmp$set_lock
*copyc tmp$update_job_task_environment

?? PUSH (LISTEXT := ON) ??
*copyc jmc$sched_profile_deadstart_id
*copyc jme$job_scheduler_conditions
*copyc jmt$ajl_ordinal
*copyc jmt$change_dispatching_list
*copyc jmt$dispatching_control
*copyc jmt$dispatching_control_index
*copyc jmt$dual_state_priority_control
*copyc jmt$idle_dispatching_controls
*copyc jmt$ijl_entry_status_statistics
*copyc jmt$ijl_swap_status
*copyc jmt$initiated_job_list_entry
*copyc jmt$job_category_set
*copyc jmt$job_counts
*copyc jmt$job_scheduler_event
*copyc jmt$job_scheduler_table
*copyc jmt$long_wait_swap_threshold
*copyc jmt$rb_scheduler_requests
*copyc jmt$rb_service_class_statistics
*copyc jmt$service_class_entry
*copyc jmt$service_class_index
*copyc jmt$service_class_set
*copyc jmt$ssn_sequence_number
*copyc jmt$swapin_candidate_q_header
*copyc jmt$swapout_reasons
*copyc jmt$system_supplied_name
*copyc jmt$system_supplied_name_mask
*copyc jmt$trick_ijlo_variant_record
*copyc jmt$working_set_size
*copyc jst$ijl_swap_queue_link
*copyc mmt$page_frame_index
*copyc oss$mainframe_wired
*copyc ost$free_running_clock
*copyc ost$hardware_subranges
*copyc syt$monitor_status
*copyc tmt$dispatching_controls
*copyc tmt$dispatching_control_sets
*copyc tmt$dispatching_prio_controls
*copyc tmt$fnx_search_type
*copyc jmk$keypoints
*copyc tmt$ptl_lock
?? POP ??

  VAR

    jmv$classes_in_maxaj_limit_wait: [XDCL, #GATE] jmt$service_class_set := $jmt$service_class_set [],

    jmv$classes_in_resource_wait: [XDCL, #GATE] jmt$service_class_set := $jmt$service_class_set [],

    jmv$change_dispatching_list: [XDCL, #GATE, oss$mainframe_wired] jmt$change_dispatching_list := [[0], NIL],

    jmv$idle_dispatching_controls: [XDCL, #GATE, oss$mainframe_wired] jmt$idle_dispatching_controls,

    jmv$ijl_entry_status_statistics: [XDCL, #GATE, oss$mainframe_wired] jmt$ijl_entry_status_statistics,

{ NOTE:  Because jmv$ijl_ready_task_list is read/written by both job mode and monitor mode scheduler,
{ it is a locked variable and can be referenced only via the compare_swap procedures.

    jmv$ijl_ready_task_list: [XDCL, #GATE, oss$mainframe_wired] integer,

    jmv$job_counts: [XDCL, #GATE] jmt$job_counts,

    jmv$job_scheduler_event: [XDCL, #GATE, oss$mainframe_wired] jmt$job_scheduler_event := [REP 19 of FALSE],

    jmv$job_sched_events_selected: [XDCL, #GATE, oss$mainframe_wired] jmt$job_sched_event_selections :=
          [TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE,
          FALSE, FALSE, FALSE],

    jmv$job_scheduler_table: [XDCL, #GATE, oss$mainframe_wired] jmt$job_scheduler_table :=
          [40000, FALSE, 60, jmc$sched_profile_deadstart_id, 10, [REP 8 of [0, 100, FALSE]], 1, [[1, 8],
          [1, 8], [2, 8], [2, 8], [3, 8], [3, 8], [4, 8], [4, 8], [5, 8], [5, 8]], 360000000, [], [],
          [20, 60], NIL, 0],

    jmv$last_service_calc_time: [XDCL, #GATE, oss$mainframe_wired] ost$free_running_clock := 0,

    jmv$long_wait_swap_threshold: [XDCL, #GATE] jmt$long_wait_swap_threshold,

    jmv$max_class_working_set: [XDCL, #GATE] jmt$working_set_size := 3000,

    jmv$max_service_class_in_use: [XDCL, #GATE] jmt$service_class_index,

    jmv$min_think_time: [XDCL, #GATE] integer := 500000, {Dont update THINK TIME if estimated think

{time is less than this value.

    jmv$max_think_time: [XDCL, #GATE] integer := 60000000, {THINK TIMEs > this value are rounded to this

{value.

    jmv$memory_needed_by_scheduler: [XDCL, #GATE] mmt$page_frame_index,

    jmv$null_ijl_ordinal: [XDCL, #GATE] jmt$ijl_ordinal := [0, 0],

    jmv$prevent_activation_of_jobs: [XDCL, #GATE] boolean := TRUE,

    jmv$scan_idle_dispatch_interval: [XDCL, #GATE] integer := 15000000,

    jmv$sched_profile_is_loading: [XDCL, #GATE, oss$mainframe_wired] boolean := FALSE,

    jmv$sched_service_calc_time: [XDCL, #GATE] ost$free_running_clock,

    jmv$service_class_stats_lock: [XDCL] tmt$ptl_lock := [FALSE, 0],

    jmv$service_classes: [XDCL, #GATE, oss$mainframe_wired] array [jmt$service_class_index] of
          ^jmt$service_class_entry := [REP jmc$maximum_service_classes + 1 of NIL],

    jmv$ssn_previous_sequence: [XDCL, #GATE] jmt$ssn_sequence_number,

    jmv$subsystem_priority_changes: [XDCL, #GATE] packed array [jmt$service_class_index] of boolean,

    jmv$swapin_candidate_queue: [XDCL, #GATE] array [jmt$service_class_index] of
          jmt$swapin_candidate_q_header,

    jmv$swapped_idle_disp_count: [XDCL] integer := 0,

    jmv$system_supplied_name: [XDCL, #GATE] jmt$system_supplied_name_mask,

    jmv$time_to_wake_scheduler: [XDCL, #GATE] ost$free_running_clock;

?? TITLE := 'check_for_class_switch', EJECT ??

  PROCEDURE check_for_class_switch
    (    ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      new_class: jmt$service_class_index,
      rb: jmt$rb_scheduler_requests,
      service_class_p: ^jmt$service_class_attributes;

{ Change the job's service class if the job has reached the class service threshold.
{ Only switch classes if the new class to switch to is currently defined.

    service_class_p := ^jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.attributes;
    IF (ijle_p^.job_scheduler_data.service_accumulator > service_class_p^.class_service_threshold) AND
          (service_class_p^.class_service_threshold <> jmc$unlimited_service_accum) AND
          (NOT jmv$sched_profile_is_loading) THEN
      IF ijle_p^.job_scheduler_data.service_class <> service_class_p^.next_service_class_index THEN
        new_class := service_class_p^.next_service_class_index;
        IF (jmv$service_classes [new_class] <> NIL) AND jmv$service_classes [new_class]^.attributes.
              defined THEN
          rb.reqcode := syc$rc_job_scheduler_request;
          rb.sub_reqcode := jmc$src_class_switch;
          rb.system_supplied_name := ijle_p^.system_supplied_name;
          rb.new_service_class := new_class;
          rb.new_service_accumulator := 0;
          rb.old_service_class := ijle_p^.job_scheduler_data.service_class;
          rb.old_service_accumulator := ijle_p^.job_scheduler_data.service_accumulator;

          jmp$process_class_switch (rb);

        IFEND;
      IFEND;
    IFEND;
  PROCEND check_for_class_switch;

?? TITLE := 'insert_job_in_ready_task_list', EJECT ??

{ PURPOSE:
{   This procedure inserts a job with a ready task into the list for job mode
{   scheduler to process.
{ DESIGN:
{   The head of the list is a global variable which must be changed by both
{   monitor mode and job mode scheduler.  To synchronize the monitor/job mode
{   references, the head of the list is a locked variable which can be referenced
{   only via the #compare_swap procedures.

  PROCEDURE insert_job_in_ready_task_list
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      ijlo: jmt$trick_ijlo_variant_record,
      list_head: jmt$trick_ijlo_variant_record,
      old_list_head: integer,
      succeeded: boolean;

    ijlo.ijl_ordinal := ijl_ordinal;

    REPEAT
      osp$fetch_locked_variable (jmv$ijl_ready_task_list, list_head.ijl_integer);
      ijle_p^.job_scheduler_data.ready_task_link := list_head.ijl_ordinal;
      old_list_head := list_head.ijl_integer;
      osp$set_locked_variable (jmv$ijl_ready_task_list, old_list_head, ijlo.ijl_integer,
            list_head.ijl_integer, succeeded);
    UNTIL succeeded;

  PROCEND insert_job_in_ready_task_list;

?? TITLE := 'remove_class_from_maxaj_limit', EJECT ??

  PROCEDURE remove_class_from_maxaj_limit
    (    service_class: jmt$service_class_index);

    VAR
      ignore_status: syt$monitor_status;

    jmv$classes_in_maxaj_limit_wait := jmv$classes_in_maxaj_limit_wait - $jmt$service_class_set
          [service_class];
    jmv$job_scheduler_event [jmc$scheduler_wake_time] := TRUE;
    jmv$job_scheduler_event [jmc$examine_input_queue] := TRUE;
    jmv$job_scheduler_event [jmc$examine_swapin_queue] := TRUE;
    tmp$monitor_ready_system_task (tmc$stid_job_scheduler, ignore_status);

  PROCEND remove_class_from_maxaj_limit;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE, UNSAFE] swapin_queue_empty', EJECT ??

{ PURPOSE:
{   This function is called when determining if a monitor swapin should be allowed to take place.
{   If the input dispatching priority is blocked, or if there are queued jobs with an equal or higher
{   dispatching priority, FALSE will be returned.

  FUNCTION [INLINE, UNSAFE] swapin_queue_empty
    (    dispatching_priority: jmt$dispatching_priority): boolean;

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      service_class: jmt$service_class_index;

    swapin_queue_empty := TRUE;

    IF jmv$idle_dispatching_controls.controls [dispatching_priority].blocked THEN
      swapin_queue_empty := FALSE;
      RETURN;
    IFEND;

  /check_swapin_queue/
    FOR service_class := jmc$system_service_class TO jmv$max_service_class_in_use DO
      IF (jmv$swapin_candidate_queue [service_class].swapin_candidate_queue <> jmv$null_ijl_ordinal) AND
            (NOT too_many_active_jobs_for_class (service_class)) THEN
        jmp$get_ijle_p (jmv$swapin_candidate_queue [service_class].swapin_candidate_queue, ijle_p);
        IF ijle_p^.scheduling_dispatching_priority >= dispatching_priority THEN
          swapin_queue_empty := FALSE;
          EXIT /check_swapin_queue/;
        IFEND;
      IFEND;
    FOREND /check_swapin_queue/;

  FUNCEND swapin_queue_empty;

?? TITLE := '[INLINE] too_many_active_jobs_for_class', EJECT ??

  FUNCTION [INLINE] too_many_active_jobs_for_class
    (    service_class: jmt$service_class_index): boolean;

    too_many_active_jobs_for_class := (jmv$job_counts.service_class_counts [service_class].
          scheduler_initiated_jobs - jmv$job_counts.service_class_counts [service_class].swapped_jobs) >=
          jmv$service_classes [service_class]^.attributes.maximum_active_jobs;

  FUNCEND too_many_active_jobs_for_class;

?? TITLE := '[XDCL] jmp$activate_job_mode_swapper', EJECT ??

  PROCEDURE [XDCL] jmp$activate_job_mode_swapper;

    VAR
      status: syt$monitor_status;

    jmp$set_scheduler_event (jmc$call_job_swapper);

  PROCEND jmp$activate_job_mode_swapper;

?? TITLE := 'jmp$change_dispatching_alloc', EJECT ??

{ PURPOSE:
{   This procedure changes the dispatching allocation controls in dispatcher's
{   tables.
{ DESIGN:
{   The scheduler table has been changed in job mode.  Dispatcher's tables must
{   be changed in mtr mode with the PTL lock set so that task switch cannot be
{   referencing the tables.  The scheduler table is kept in units of seconds for
{   the time interval and percentages for the minimum and maximum values; those
{   values must all be converted to microseconds for the dispatching table.
{   This procedure is called infrequently (only when a site is changing its
{   dispatching allocation controls).

  PROCEDURE jmp$change_dispatching_alloc;

    CONST
      u_second = 1000000;

    VAR
      controls_defined: boolean,
      dp: jmt$user_dispatching_priority,
      dp_unblocked: boolean,
      local_set: tmt$dispatching_control_sets,
      normalized_interval: integer,
      unblock_higher_dp: boolean;

{ Decide if controls are being defined; the site may be setting controls back to defaults
{ (0% minimum and 100% maximum).

    controls_defined := FALSE;
    dp_unblocked := FALSE;

  /check_controls/
    FOR dp := jmc$priority_p1 TO jmc$priority_p8 DO
      IF (jmv$job_scheduler_table.cpu_dispatching_allocation [dp].minimum <> 0) OR
            (jmv$job_scheduler_table.cpu_dispatching_allocation [dp].maximum <> 100) THEN
        controls_defined := TRUE;
        EXIT /check_controls/;
      IFEND;
    FOREND /check_controls/;

{ Set the PTL lock while changing the dispatching tables.

    tmp$set_lock (tmv$ptl_lock);

{ Reset the dispatching control sets.  Reset the minimums_to_satisfy field in the dispatching table
{ (it is used in mmp$periodic to determine if a dispatching priority is blocked).
{ NOTE:  'System' priorities always have minimums_to_satisfy.  This guarantees that they will always be
{ in the first set considered by task selection in task switch.
{ If controls are not defined, clear the controls_defined field in the dispatching table.  Other fields
{ in the dispatching table can be left with 'garbage' in them; nothing references them when
{ controls_defined is FALSE.
{ If controls are defined, reset the values in the dispatching table.
{ NOTE:  Elements in dispatching priority sets are converted so that the highest priority in the set
{ is the leftmost bit in the set.  Setting bit 1 in a dispatching priority set is adding priority 15
{ to the set.  (See jmt$dispatching_priority.)

    tmv$dispatching_control_sets.minimums_to_satisfy := $jmt$dispatching_priority_set [1, 2, 3, 4, 5, 6];
    tmv$dispatching_control_sets.maximums_exceeded := $jmt$dispatching_priority_set [];
    tmv$dispatching_control_sets.enforce_maximums := $jmt$dispatching_priority_set [];
    tmv$dispatching_controls.minimums_to_satisfy := $jmt$dispatching_priority_set [1, 2, 3, 4, 5, 6];

    IF NOT controls_defined THEN
      tmv$dispatching_controls.controls_defined := FALSE;
    ELSE
      tmv$dispatching_controls.controls_defined := TRUE;
      tmv$dispatching_controls.maximums_defined := $jmt$dispatching_priority_set [];
      tmv$dispatching_controls.enforce_maximums := $jmt$dispatching_priority_set [];
      tmv$dispatching_controls.controls.time_left_in_interval :=
            jmv$job_scheduler_table.dispatching_allocation_interval * u_second;
      normalized_interval := tmv$dispatching_controls.controls.time_left_in_interval DIV 100;
      unblock_higher_dp := FALSE;
      FOR dp := jmc$priority_p1 TO jmc$priority_p8 DO

{ Set the minimums.

        IF jmv$job_scheduler_table.cpu_dispatching_allocation [dp].minimum <> 0 THEN
          unblock_higher_dp := TRUE;
          tmv$dispatching_controls.controls.dispatching_priority_time [dp].
                minimum_time := (normalized_interval) * jmv$job_scheduler_table.
                cpu_dispatching_allocation [dp].minimum;
          tmv$dispatching_controls.minimums_to_satisfy := tmv$dispatching_controls.minimums_to_satisfy +
                $jmt$dispatching_priority_set [jmc$dp_conversion - dp];
        ELSE
          tmv$dispatching_controls.controls.dispatching_priority_time [dp].minimum_time := 0;
        IFEND;

{ If this dispatching priority is blocked and this or a lower dispatching priority has a minimum allocated,
{ this priority must be unblocked.

        IF unblock_higher_dp AND (jmv$idle_dispatching_controls.controls [dp].blocked OR
              jmv$idle_dispatching_controls.controls [dp].idle_noticed_once) THEN
          jmv$idle_dispatching_controls.controls [dp].blocked := FALSE;
          jmv$idle_dispatching_controls.controls [dp].idle_noticed_once := FALSE;
          jmv$idle_dispatching_controls.controls [dp].timestamp := #FREE_RUNNING_CLOCK (0);
          jmv$idle_dispatching_controls.controls [dp].last_cp_time :=
                tmv$cpu_execution_statistics [dp].time_spent_in_job_mode +
                tmv$cpu_execution_statistics [dp].time_spent_in_mtr_mode;
          jmv$idle_dispatching_controls.unblocked_priorities :=
                jmv$idle_dispatching_controls.unblocked_priorities +
                $jmt$dispatching_priority_set [jmc$dp_conversion - dp];
          dp_unblocked := TRUE;
        IFEND;

{ Set the maximums.

        IF jmv$job_scheduler_table.cpu_dispatching_allocation [dp].maximum <> 100 THEN
          tmv$dispatching_controls.controls.dispatching_priority_time [dp].
                maximum_time := (normalized_interval) * jmv$job_scheduler_table.
                cpu_dispatching_allocation [dp].maximum;
          tmv$dispatching_controls.maximums_defined := tmv$dispatching_controls.maximums_defined +
                $jmt$dispatching_priority_set [jmc$dp_conversion - dp];
        ELSE
          tmv$dispatching_controls.controls.dispatching_priority_time [dp].maximum_time :=
                tmv$dispatching_controls.controls.time_left_in_interval;
        IFEND;
        IF jmv$job_scheduler_table.cpu_dispatching_allocation [dp].enforce_maximum THEN
          tmv$dispatching_controls.enforce_maximums := tmv$dispatching_controls.enforce_maximums +
                $jmt$dispatching_priority_set [jmc$dp_conversion - dp];
        IFEND;
      FOREND;
      tmv$dispatching_control_sets.minimums_to_satisfy := tmv$dispatching_controls.minimums_to_satisfy;
      tmv$dispatching_control_time := tmv$dispatching_controls.controls;
    IFEND;

{ Calculate the dispatching priority integers used by task switch and ready task to determine
{ which dispatching priority is the highest.

    tmp$calculate_dct_priority_int;

    local_set := tmv$dispatching_control_sets;

    FOR dp := jmc$priority_p1 TO jmc$priority_p8 DO
      local_set.ready_tasks := $jmt$dispatching_priority_set [jmc$dp_conversion - dp];
      local_set.minimums_to_satisfy := local_set.minimums_to_satisfy * local_set.ready_tasks;
      local_set.ready_tasks := local_set.ready_tasks XOR local_set.minimums_to_satisfy;
      #UNCHECKED_CONVERSION (local_set, tmv$dispatch_priority_integer [dp]);
    FOREND;

    tmp$clear_lock (tmv$ptl_lock);

    IF dp_unblocked THEN
      jmp$set_scheduler_event (jmc$examine_swapin_queue);
      jmp$set_scheduler_event (jmc$examine_input_queue);
    IFEND;

  PROCEND jmp$change_dispatching_alloc;

?? TITLE := 'jmp$change_dispatching_mtr_req', EJECT ??

{ PURPOSE:
{   This procedure changes the dispatching control information in the service class table
{   and resets the dispatching control information for all jobs in classes being changed.
{ DESIGN:
{   The PTL lock must be set while the table is being changed and affected job updated to
{   prevent task switch from using obsolete/uninitialized dispatching control information.

  PROCEDURE jmp$change_dispatching_mtr_req;

    VAR
      changes_pointer: ^jmt$dispatching_control_changes,
      circular_service: array [jmt$service_class_index] of integer,
      class: jmt$service_class_index,
      classes_changed: jmt$service_class_set,
      dispatching_control_index: jmt$dispatching_control_index,
      dispatching_control_p: ^jmt$dispatching_control,
      ijl_bn: jmt$ijl_block_number,
      ijl_bi: jmt$ijl_block_index,
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      service_used: integer;

    classes_changed := $jmt$service_class_set [];

{ Set the ptl lock so that task switch cannot be accessing the service class attribute table

    tmp$set_lock (tmv$ptl_lock);

{ Change the service class attribute table

    changes_pointer := jmv$change_dispatching_list.dispatching_control_changes_p;

    WHILE changes_pointer <> NIL DO
      class := changes_pointer^.change_service_class;
      classes_changed := classes_changed + $jmt$service_class_set [class];
      dispatching_control_p := ^changes_pointer^.dispatching_control_info;
      jmv$service_classes [class]^.attributes.dispatching_control := dispatching_control_p^;

      circular_service [class] := 0;

    /calculate_circular_service/
      FOR dispatching_control_index := jmc$max_dispatching_control DOWNTO jmc$min_dispatching_control DO
        IF dispatching_control_p^ [dispatching_control_index].set_defined THEN
          IF dispatching_control_p^ [dispatching_control_index].service_limit <>
                jmc$dc_maximum_service_limit THEN
            circular_service [class] := circular_service [class] +
                  dispatching_control_p^ [dispatching_control_index].service_limit;
          ELSE
            EXIT /calculate_circular_service/;
          IFEND;
        IFEND;
      FOREND /calculate_circular_service/;
      changes_pointer := changes_pointer^.dispatching_control_changes_p;
    WHILEND;

{ Scan the ijl to find all jobs belonging to classes that have been changed--those jobs may need to have
{ their dispatching priority reset.  If the dispatching control sets are circular, MOD the service used
{ before calling tmp$reset_dispatching_control.  For batch jobs, total job service is used; for interactive
{ jobs, use zero for the service.  Interactive jobs should be reset to the first dispatching control set.

    ijle_p := NIL;

  /scan_ijl/
    FOR ijl_bn := LOWERBOUND (jmv$ijl_p.block_p^) TO jmv$ijl_p.max_block_in_use DO
      IF (jmv$ijl_p.block_p^ [ijl_bn].index_p <> NIL) THEN
        ijl_ordinal.block_number := ijl_bn;
        FOR ijl_bi := LOWERVALUE (jmt$ijl_block_index) TO UPPERVALUE (jmt$ijl_block_index) DO
          ijl_ordinal.block_index := ijl_bi;
          IF ijl_ordinal <> jmv$system_ijl_ordinal THEN
            jmp$get_ijle_p (ijl_ordinal, ijle_p);
            IF ijle_p^.job_scheduler_data.service_class IN classes_changed THEN
              IF ijle_p^.job_mode = jmc$batch THEN
                service_used := ijle_p^.statistics.cp_time.time_spent_in_job_mode +
                      ijle_p^.statistics.cp_time.time_spent_in_mtr_mode -
                      ijle_p^.dispatching_control.cp_service_at_class_switch;
                IF circular_service [ijle_p^.job_scheduler_data.service_class] <> 0 THEN
                  service_used := service_used MOD circular_service
                        [ijle_p^.job_scheduler_data.service_class];
                IFEND;
              ELSE
                service_used := 0;
              IFEND;
              tmp$reset_dispatching_control (ijle_p, ijl_ordinal, service_used, FALSE);
            IFEND;
          IFEND;
        FOREND;
      IFEND;
    FOREND /scan_ijl/;

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND jmp$change_dispatching_mtr_req;

?? TITLE := '[XDCL, INLINE] jmp$decrement_swapped_job_count', EJECT ??

  PROCEDURE [XDCL, INLINE] jmp$decrement_swapped_job_count
    (    ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      job_class: jmt$job_class,
      service_class: jmt$service_class_index;

    job_class := ijle_p^.job_scheduler_data.job_class;
    service_class := ijle_p^.job_scheduler_data.service_class;
    jmv$job_counts.job_class_counts [job_class].swapped_jobs :=
          jmv$job_counts.job_class_counts [job_class].swapped_jobs - 1;
    jmv$job_counts.service_class_counts [service_class].swapped_jobs := jmv$job_counts.
          service_class_counts [service_class].swapped_jobs - 1;

  PROCEND jmp$decrement_swapped_job_count;

?? TITLE := '[XDCL, INLINE] jmp$increment_swapped_job_count', EJECT ??

  PROCEDURE [XDCL, INLINE] jmp$increment_swapped_job_count
    (    ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      job_class: jmt$job_class,
      service_class: jmt$service_class_index;

    job_class := ijle_p^.job_scheduler_data.job_class;
    service_class := ijle_p^.job_scheduler_data.service_class;
    jmv$job_counts.job_class_counts [job_class].swapped_jobs :=
          jmv$job_counts.job_class_counts [job_class].swapped_jobs + 1;
    jmv$job_counts.service_class_counts [service_class].swapped_jobs := jmv$job_counts.
          service_class_counts [service_class].swapped_jobs + 1;

  PROCEND jmp$increment_swapped_job_count;

?? TITLE := '[XDCL] jmp$mtr_job_scheduler_requests', EJECT ??

  PROCEDURE [XDCL] jmp$mtr_job_scheduler_requests
    (VAR request_block: jmt$rb_scheduler_requests);

    request_block.status.normal := TRUE;

{ Process the job scheduler sub requests.

    CASE request_block.sub_reqcode OF
    = jmc$src_operator_swap_in =
      jmp$process_oper_swapin_mtr_req (request_block.ijl_ordinal, request_block.status);

    = jmc$src_idling_advance_swaps =
      jmp$process_idling_adv_swaps;

    = jmc$src_class_switch =
      jmp$process_class_switch (request_block);

    = jmc$src_change_dispatching_ctrl =
      jmp$change_dispatching_mtr_req;

    = jmc$src_cleanup_unrecovered_job =
      jmp$process_unrecovered_job (request_block);

    = jmc$src_sched_profile_loading =
      jmp$set_sched_profile_loading;

    = jmc$src_dispatching_allocation =
      jmp$change_dispatching_alloc;

    = jmc$src_swapin_recovered_jobs =
      jmp$mtr_swapin_recovered_jobs;

    ELSE
      mtp$set_status_abnormal ('JM', jme$invalid_scheduler_request, request_block.status);
    CASEND;

  PROCEND jmp$mtr_job_scheduler_requests;

?? TITLE := 'jmp$mtr_swapin_recovered_jobs', EJECT ??

{ PURPOSE:
{   This procedure scans the IJL and readies all jobs so that they can swapin for job recovery.
{ DESIGN:
{   The PTL lock is set to prevent any kind of ready task being processed asynchronously.
{   The job_fixed_asid in the ijl is zeroed out.  The old asid cannot be referenced because the
{   recovered system has a new AST.  A new asid will be assigned when the job swaps in.

  PROCEDURE jmp$mtr_swapin_recovered_jobs;

    VAR
      ijl_bn: jmt$ijl_block_number,
      ijl_bi: jmt$ijl_block_index,
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry;

    tmp$set_lock (tmv$ptl_lock);

    FOR ijl_bn := LOWERBOUND (jmv$ijl_p.block_p^) TO jmv$ijl_p.max_block_in_use DO
      IF jmv$ijl_p.block_p^ [ijl_bn].index_p <> NIL THEN
        FOR ijl_bi := LOWERVALUE (jmt$ijl_block_index) TO UPPERVALUE (jmt$ijl_block_index) DO
          ijl_ordinal.block_number := ijl_bn;
          ijl_ordinal.block_index := ijl_bi;
          jmp$get_ijle_p (ijl_ordinal, ijle_p);
          IF ijle_p^.entry_status <> jmc$ies_entry_free THEN
            IF jmc$dsw_job_recovery IN ijle_p^.delayed_swapin_work THEN
              ijle_p^.job_fixed_asid := 0;
              jmp$change_ijl_entry_status (ijle_p, jmc$ies_job_swapped);
              jmp$ready_task_in_swapped_job (ijl_ordinal, ijle_p);
            IFEND;
          IFEND;
        FOREND;
      IFEND;
    FOREND;

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND jmp$mtr_swapin_recovered_jobs;

?? TITLE := 'jmp$process_class_switch', EJECT ??

{ PURPOSE:
{   This procedure updates dispatching control information when a job switches
{   service classes.  The PTL lock must be set while the dispatching control
{   information is changed to prevent task switch from referencing obsolete/
{   uninitialized information.

  PROCEDURE jmp$process_class_switch
    (VAR rb: jmt$rb_scheduler_requests);

    VAR
      old_class: jmt$service_class_index,
      service_class_p: ^jmt$service_class_attributes,
      ijle_p: ^jmt$initiated_job_list_entry,
      ijlo: jmt$ijl_ordinal;

    jmp$find_jsn (rb.system_supplied_name, ijle_p, ijlo);

    tmp$set_lock (tmv$ptl_lock);

    IF (ijle_p <> NIL) AND (ijle_p^.entry_status > jmc$ies_job_in_memory_non_swap) AND
          (NOT jmv$sched_profile_is_loading) THEN
      old_class := ijle_p^.job_scheduler_data.service_class;

      IF rb.old_service_class = jmc$null_service_class THEN
        rb.old_service_class := old_class;
        rb.old_service_accumulator := ijle_p^.job_scheduler_data.service_accumulator;
      ELSEIF (rb.old_service_class <> old_class) OR (rb.old_service_accumulator >
            ijle_p^.job_scheduler_data.service_accumulator) THEN
        tmp$clear_lock (tmv$ptl_lock);
        RETURN;
      IFEND;

      jmp$update_service_class_stats (ijle_p);

      IF (ijle_p^.entry_status > jmc$ies_swapped_in) THEN
        jmp$decrement_swapped_job_count (ijle_p);
        ijle_p^.job_scheduler_data.service_class := rb.new_service_class;
        jmp$increment_swapped_job_count (ijle_p);
      ELSE
        ijle_p^.job_scheduler_data.service_class := rb.new_service_class;
      IFEND;

      jmv$job_counts.service_class_counts [old_class].scheduler_initiated_jobs :=
            jmv$job_counts.service_class_counts [old_class].scheduler_initiated_jobs - 1;

      jmv$job_counts.service_class_counts [rb.new_service_class].scheduler_initiated_jobs :=
            jmv$job_counts.service_class_counts [rb.new_service_class].scheduler_initiated_jobs + 1;

      service_class_p := ^jmv$service_classes [rb.new_service_class]^.attributes;

      ijle_p^.job_scheduler_data.service_accumulator := 0;
      ijle_p^.dispatching_control.dispatching_control_index := jmc$min_dispatching_control;
      IF ijle_p^.dispatching_control.dispatching_priority = ijle_p^.scheduling_dispatching_priority THEN
        ijle_p^.scheduling_dispatching_priority := service_class_p^.
              dispatching_control [jmc$min_dispatching_control].dispatching_priority;
      IFEND;
      ijle_p^.dispatching_control.dispatching_priority := service_class_p^.
            dispatching_control [jmc$min_dispatching_control].dispatching_priority;
      ijle_p^.dispatching_control.service_remaining := service_class_p^.
            dispatching_control [jmc$min_dispatching_control].service_limit;
      ijle_p^.dispatching_control.cp_service_at_class_switch :=
            ijle_p^.statistics.cp_time.time_spent_in_job_mode +
            ijle_p^.statistics.cp_time.time_spent_in_mtr_mode;
      tmp$update_job_task_environment (ijle_p, ijlo, tmc$fnx_job);

{ Check active job limits for the new class; cause a job to swapout if necessary.

      IF (jmv$job_counts.service_class_counts [rb.new_service_class].scheduler_initiated_jobs -
            jmv$job_counts.service_class_counts [rb.new_service_class].swapped_jobs) >
            service_class_p^.maximum_active_jobs THEN
        jmp$set_scheduler_event (jmc$swap_jobs_for_lower_maxaj);
      IFEND;
    IFEND;

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND jmp$process_class_switch;

?? TITLE := 'jmp$process_idling_adv_swaps', EJECT ??

  PROCEDURE jmp$process_idling_adv_swaps;

    VAR
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      next_ijl_ordinal: jmt$ijl_ordinal;

    ijl_ordinal := jsv$ijl_swap_queue_list [jsc$isqi_swapped_io_completed].forward_link;

    WHILE ijl_ordinal <> jmv$null_ijl_ordinal DO
      jmp$get_ijle_p (ijl_ordinal, ijle_p);
      next_ijl_ordinal := ijle_p^.swap_queue_link.forward_link;
      jsp$monitor_advance_swap (ijl_ordinal);
      ijl_ordinal := next_ijl_ordinal;
    WHILEND;

  PROCEND jmp$process_idling_adv_swaps;

?? TITLE := 'jmp$process_oper_swapin_mtr_req', EJECT ??

{ PURPOSE:
{   Process an operator swapin job request.
{ DESIGN:
{   Re-check entry status.  Entry status was operator force out when the monitor request was issued.
{   The following (very unlikely) timing sequence could occur though:
{     The job was swapping in (swapin I/O was active) when the operator swapout occurred.  Entry status
{     was changed to operator force out.  The operator swapped the job in right away (I/O was still
{     active); the job mode operator swapin code found entry status still set to operator force out.
{     Before exchanging to monitor for the swapin request, process I/O completions executed.  Swapin I/O
{     errors would cause the entry status to be changed to system force out.
{   If entry status is still operator force out, then change entry_status to swapped.  Call
{   jmp$ready_task_in_swapped_job if the job has any ready tasks.


  PROCEDURE jmp$process_oper_swapin_mtr_req
    (    ijl_ordinal: jmt$ijl_ordinal;
     VAR status: syt$monitor_status);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry;

    jmp$get_ijle_p (ijl_ordinal, ijle_p);

    IF ijle_p^.entry_status = jmc$ies_operator_force_out THEN

{ Set the PTL lock to synchronize with the dispatcher/ready task path.

      status.normal := TRUE;
      tmp$set_lock (tmv$ptl_lock);
      jmp$change_ijl_entry_status (ijle_p, jmc$ies_job_swapped);
      IF ijle_p^.statistics.ready_task_count > 0 THEN
        ijle_p^.job_scheduler_data.swapin_q_priority_timestamp := 0;
        jmp$ready_task_in_swapped_job (ijl_ordinal, ijle_p);
      IFEND;
      tmp$clear_lock (tmv$ptl_lock);

    ELSE
      IF ijle_p^.entry_status <> jmc$ies_system_force_out THEN
        mtp$error_stop ('OPER SWAPIN REQUEST ERROR');
      IFEND;
      mtp$set_status_abnormal ('JM', jme$job_dead_cannot_swap, status);
    IFEND;

  PROCEND jmp$process_oper_swapin_mtr_req;

?? TITLE := 'jmp$process_unrecovered_job', EJECT ??

{ PURPOSE:
{   This procedure relinks a job to the null swapping queue and changes job class counts
{   when a job must be terminated during job recovery.  The PTL entries for the tasks of
{   the job are freed.  The two reasons for the termination are that a job class is not
{   defined for a job or a job could not be swapped in for recovery due to an io error.

  PROCEDURE jmp$process_unrecovered_job
    (    rb: jmt$rb_scheduler_requests);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry;

    jmp$get_ijle_p (rb.ijl_ordinal, ijle_p);

    tmp$set_lock (tmv$ptl_lock);

    jmv$job_counts.service_class_counts [ijle_p^.job_scheduler_data.service_class].scheduler_initiated_jobs :=
          jmv$job_counts.service_class_counts [ijle_p^.job_scheduler_data.service_class].
          scheduler_initiated_jobs - 1;
    jmv$job_counts.service_class_counts [ijle_p^.job_scheduler_data.service_class].swapped_jobs :=
          jmv$job_counts.service_class_counts [ijle_p^.job_scheduler_data.service_class].swapped_jobs - 1;
    jmv$job_counts.job_class_counts [ijle_p^.job_scheduler_data.job_class].swapped_jobs :=
          jmv$job_counts.job_class_counts [ijle_p^.job_scheduler_data.job_class].swapped_jobs - 1;

    jsp$relink_swap_queue (rb.ijl_ordinal, ijle_p, jsc$isqi_null);

    tmp$free_unrecovered_tasks (ijle_p);

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND jmp$process_unrecovered_job;

?? TITLE := '[XDCL] jmp$ready_task_in_swapped_job', EJECT ??

  PROCEDURE [XDCL] jmp$ready_task_in_swapped_job
    (    ijl_ord: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      current_time: integer,
      service_class: jmt$service_class_index,
      status: syt$monitor_status,
      swap_stats_p: ^jmt$service_class_swap_stats,
      think_time: integer;

    #KEYPOINT (osk$entry, 0, jmk$ready_task_in_swapped_job);

{ If a job with a memory reserve request posted has a task go ready, cancel the request.
{ The ready task may be because of a user interrupt; do not wait for the requested memory
{ to become available.

    IF ijle_p^.memory_reserve_request.requested_page_count > 0 THEN
      ijle_p^.memory_reserve_request.requested_page_count := 0;
      jmv$job_sched_events_selected [jmc$examine_swapin_queue] := TRUE;
      jmp$set_scheduler_event (jmc$examine_swapin_queue);
    IFEND;

    current_time := #FREE_RUNNING_CLOCK (0);
    IF ijle_p^.entry_status = jmc$ies_job_swapped THEN

      think_time := current_time - (ijle_p^.estimated_ready_time - ijle_p^.last_think_time);
      IF (think_time > jmv$max_think_time) THEN
        ijle_p^.last_think_time := jmv$max_think_time;
      ELSEIF (think_time > jmv$min_think_time) THEN
        ijle_p^.last_think_time := think_time;
      IFEND;

      ijle_p^.swap_data.timestamp := current_time;

      service_class := ijle_p^.job_scheduler_data.service_class;

      tmp$set_lock (jmv$service_class_stats_lock);
      swap_stats_p := ^jmv$service_classes [service_class]^.statistics.swap_stats;
      swap_stats_p^.swap_to_ready_time := swap_stats_p^.swap_to_ready_time +
            (current_time - ijle_p^.swap_data.swapout_timestamp);
      swap_stats_p^.swap_to_ready_count := swap_stats_p^.swap_to_ready_count + 1;
      tmp$clear_lock (jmv$service_class_stats_lock);

{ If possible, swap the job in immediately through the monitor interface; otherwise notify job mode
{ scheduler to swap the job in.  If the dispatching priority of the job is blocked, the swapin must
{ be handled by job mode scheduler.

      IF (NOT jmv$prevent_activation_of_jobs) AND (NOT jmv$job_scheduler_event [jmc$examine_input_queue]) AND
            (ijle_p^.job_scheduler_data.swapout_reason <> jmc$sr_thrashing) AND
            (swapin_queue_empty (ijle_p^.scheduling_dispatching_priority)) AND
            (ijle_p^.swap_status <= jmc$iss_swapped_io_complete) AND (jmv$number_free_ajl_entries > 0) AND
            (NOT too_many_active_jobs_for_class (service_class)) THEN

        jsp$monitor_swap_in (ijl_ord);

{ Reset fields for scheduler data -- only reset service accumulator since swap if the job used
{ its whole guaranteed service allotment the last time it was swapped in.

        IF ijle_p^.job_scheduler_data.guaranteed_service_remaining = 0 THEN
          ijle_p^.job_scheduler_data.service_accumulator_since_swap := 0;
        IFEND;
        ijle_p^.job_scheduler_data.guaranteed_service_remaining := 0;
        ijle_p^.job_scheduler_data.priority := jmv$service_classes [service_class]^.attributes.
              scheduling_priority.maximum;

      ELSE {The swapin could not take place in monitor so notify job mode scheduler to handle the swapin.}
        jmp$change_ijl_entry_status (ijle_p, jmc$ies_ready_task);
        insert_job_in_ready_task_list (ijl_ord, ijle_p);
        jmv$job_scheduler_event [jmc$ready_task_in_job] := TRUE;
        IF (NOT (service_class IN jmv$classes_in_maxaj_limit_wait)) THEN
          jmv$job_scheduler_event [jmc$examine_swapin_queue] := TRUE;
          IF (NOT (service_class IN jmv$classes_in_resource_wait)) THEN
            jmv$job_sched_events_selected [jmc$examine_swapin_queue] := TRUE;
            tmp$monitor_ready_system_task (tmc$stid_job_scheduler, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    #KEYPOINT (osk$exit, 0, jmk$ready_task_in_swapped_job);

  PROCEND jmp$ready_task_in_swapped_job;

?? TITLE := '[XDCL] jmp$recognize_job_dead', EJECT ??

{ PURPOSE:
{   This procedure is called when a swapin I/O error occurs to change a job's status to reflect that the
{   job cannot swapin.
{ DESIGN:
{   The current status is checked before changing it to system_force_out.  The various statuses
{   are handled as follows:
{     Free, Terminating, In memory non swap, In memory, System force out -- CANNOT possibly be these statuses.
{     Swapin in progress, Swapped, Operator force out -- Change the entry status to system force out.
{          Swapin in progress is the usual case; swapped requires an IDLE_SYSTEM swapout while the swapin
{          I/O was active; operator force out would be set if the operator swapped out the job while swapin
{          I/O was active.
{     Job damaged -- do not change the entry status; job damaged is more important to know.
{     Ready task, Swapin candidate -- do not change the entry status; only JOB SCHEDULER can change
{          these statuses.  The job will be swapped in again and the I/O error will be processed then.
{          The possible timing for a job to be in one of these states is very remote:  An IDLE_SYSTEM
{          swapout would have to be processed while swapin I/O was active (a swap cannot be aborted
{          while swapin I/O is active).  Then RESUME_SYSTEM would have to queue the job to swap in again
{          while the original swapin I/O was still active.
{
{   The PTL must be locked while changing the entry status because the swapped job count will be changed
{   in the swapin in progress ---> system force out transition.

  PROCEDURE [XDCL] jmp$recognize_job_dead
    (    ijl_o: jmt$ijl_ordinal);

    VAR
      ijl_p: ^jmt$initiated_job_list_entry;

    jmp$get_ijle_p (ijl_o, ijl_p);

    IF (ijl_p^.entry_status = jmc$ies_swapin_in_progress) OR (ijl_p^.entry_status = jmc$ies_job_swapped) OR
          (ijl_p^.entry_status = jmc$ies_operator_force_out) THEN

      tmp$set_lock (tmv$ptl_lock);
      jmp$change_ijl_entry_status (ijl_p, jmc$ies_system_force_out);
      tmp$clear_lock (tmv$ptl_lock);

      IF jmc$dsw_job_recovery IN ijl_p^.delayed_swapin_work THEN
        ijl_p^.delayed_swapin_work := ijl_p^.delayed_swapin_work +
              $jmt$delayed_swapin_work [jmc$dsw_recovery_swap_io_error];
        jmp$set_scheduler_event (jmc$recovery_swap_io_error);
      IFEND;
    IFEND;

  PROCEND jmp$recognize_job_dead;

?? TITLE := '[XDCL] jmp$recognize_thrashing', EJECT ??

  PROCEDURE [XDCL] jmp$recognize_thrashing;

    VAR
      ajlo: jmt$ajl_ordinal,
      count: jmt$ajl_ordinal;

    count := 0;

{ Determine if there is more than one user job active.

  /count_active_jobs/
    FOR ajlo := jmv$system_ajl_ordinal + 1 TO jmv$max_ajl_ordinal_in_use DO
      IF jmv$ajl_p^ [ajlo].in_use <> 0 THEN
        count := count + 1;
        IF count = 2 THEN
          EXIT /count_active_jobs/;
        IFEND;
      IFEND;
    FOREND /count_active_jobs/;

{ If there is more than one user job active, cause scheduler to swap for thrashing.  If there is only
{ one user job active, cause mmp$periodic_call to run so the jobs working set can be shrunk to fit in memory.

    IF count = 2 THEN
      jmp$set_scheduler_event (jmc$system_is_thrashing);
    ELSE
      mmv$reduce_jws_for_thrashing := TRUE;
      mmp$nudge_periodic_call;
    IFEND;

  PROCEND jmp$recognize_thrashing;

?? TITLE := '[XDCL] jmp$reset_job_to_swapped_out', EJECT ??

{ PURPOSE:
{   This procedure is called from swapper when a swapin could not be completed because there
{   was not enough memory or there was not a free AJL ordinal.  The entry status has
{   to be swapin in progress when this procedure is called.

  PROCEDURE [XDCL] jmp$reset_job_to_swapped_out
    (    ijl_o: jmt$ijl_ordinal);

    VAR
      ijl_p: ^jmt$initiated_job_list_entry,
      status: syt$monitor_status;

    jmp$get_ijle_p (ijl_o, ijl_p);
    IF ijl_p^.entry_status <> jmc$ies_swapin_in_progress THEN
      mtp$error_stop ('RESET TO SWAPPED OUT ERROR');
    IFEND;

    tmp$set_lock (tmv$ptl_lock);
    jmp$change_ijl_entry_status (ijl_p, jmc$ies_ready_task);
    insert_job_in_ready_task_list (ijl_o, ijl_p);
    tmp$clear_lock (tmv$ptl_lock);

    jmv$job_scheduler_event [jmc$ready_task_in_job] := TRUE;
    IF (NOT (ijl_p^.job_scheduler_data.service_class IN jmv$classes_in_maxaj_limit_wait)) THEN
      jmv$job_scheduler_event [jmc$examine_swapin_queue] := TRUE;
      IF (NOT (ijl_p^.job_scheduler_data.service_class IN jmv$classes_in_resource_wait)) THEN
        tmp$monitor_ready_system_task (tmc$stid_job_scheduler, status);
      IFEND;
    IFEND;

  PROCEND jmp$reset_job_to_swapped_out;

?? TITLE := '[XDCL] jmp$resurrect_dead_jobs', EJECT ??

  PROCEDURE [XDCL] jmp$resurrect_dead_jobs;

{ The purpose of this procedure is to find all jobs that have been marked as system_force_out
{ because a disk unit was down, and find all jobs that could not be swapped completely because
{ a disk unit was down.  This procedure is called whenenver a disk unit comes back up.
{ Swapper will try to procede swapping the jobs normally.

    VAR
      call_job_swapper: boolean,
      ijle_p: ^jmt$initiated_job_list_entry,
      ijl_bn: jmt$ijl_block_number,
      ijl_bi: jmt$ijl_block_index,
      ijl_ordinal: jmt$ijl_ordinal,
      status: syt$monitor_status;

    call_job_swapper := FALSE;

  /search_ijl/
    FOR ijl_bn := LOWERBOUND (jmv$ijl_p.block_p^) TO jmv$ijl_p.max_block_in_use DO
      IF jmv$ijl_p.block_p^ [ijl_bn].index_p <> NIL THEN
        FOR ijl_bi := LOWERVALUE (jmt$ijl_block_index) TO UPPERVALUE (jmt$ijl_block_index) DO
          ijle_p := ^jmv$ijl_p.block_p^ [ijl_bn].index_p^ [ijl_bi];
          ijl_ordinal.block_number := ijl_bn;
          ijl_ordinal.block_index := ijl_bi;

          IF (ijle_p^.entry_status = jmc$ies_system_force_out) AND
                (ijle_p^.swap_data.swapping_io_error <> ioc$no_error) THEN

{ The job was swapped out, swapping in when the io error occurred.  Try to swap the job in now.

            tmp$set_lock (tmv$ptl_lock);
            jmp$change_ijl_entry_status (ijle_p, jmc$ies_ready_task);
            insert_job_in_ready_task_list (ijl_ordinal, ijle_p);
            tmp$clear_lock (tmv$ptl_lock);

            jmv$job_scheduler_event [jmc$ready_task_in_job] := TRUE;
            jmv$job_scheduler_event [jmc$examine_swapin_queue] := TRUE;
            tmp$monitor_ready_system_task (tmc$stid_job_scheduler, status);

          ELSEIF (ijle_p^.swap_status = jmc$iss_swapped_io_cannot_init) OR
                (ijle_p^.swap_status = jmc$iss_job_allocate_swap_file) THEN

{ The job was swapping out when the condition occurred.  Call job mode swapper to check on
{ the state of the swap file and allocate it if necessary, then advance the swapout.

            call_job_swapper := TRUE;

          IFEND;
        FOREND;
      IFEND;
    FOREND /search_ijl/;

    IF call_job_swapper THEN
      jmp$activate_job_mode_swapper;
    IFEND;

  PROCEND jmp$resurrect_dead_jobs;

?? TITLE := '[XDCL] jmp$set_entry_status_to_rt', EJECT ??

{ PURPOSE:
{   This procedure is called from swapper (job_mode_swapout) to set the entry status of the
{   job being swapped out to jmc$ies_ready_task and insert the job in the ready task list.
{   The caller has the PTL lock set.

  PROCEDURE [XDCL] jmp$set_entry_status_to_rt
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      status: syt$monitor_status;

    jmp$change_ijl_entry_status (ijle_p, jmc$ies_ready_task);
    insert_job_in_ready_task_list (ijl_ordinal, ijle_p);

    jmv$job_scheduler_event [jmc$ready_task_in_job] := TRUE;
    IF (NOT (ijle_p^.job_scheduler_data.service_class IN jmv$classes_in_maxaj_limit_wait)) THEN
      jmv$job_scheduler_event [jmc$examine_swapin_queue] := TRUE;
      IF (NOT (ijle_p^.job_scheduler_data.service_class IN jmv$classes_in_resource_wait)) THEN
        tmp$monitor_ready_system_task (tmc$stid_job_scheduler, status);
      IFEND;
    IFEND;

  PROCEND jmp$set_entry_status_to_rt;

?? TITLE := 'jmp$set_job_terminated', EJECT ??

{ PURPOSE:
{   This procedure sets a job's entry status to terminating, and JOB SCHEDULER event to
{   process the terminating job.

  PROCEDURE [XDCL] jmp$set_job_terminated
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry);

    jmp$change_ijl_entry_status (ijle_p, jmc$ies_job_terminating);
    jmv$ijl_p.block_p^ [ijl_ordinal.block_number].terminated_job := TRUE;
    jmp$set_scheduler_event (jmc$job_terminated);

  PROCEND jmp$set_job_terminated;

?? TITLE := 'jmp$set_sched_profile_loading', EJECT ??

{ PURPOSE:
{   The purpose of this request is to set the flag which indicates that a
{   scheduling profile is being installed in the scheduler tables.

  PROCEDURE jmp$set_sched_profile_loading;

    jmv$sched_profile_is_loading := TRUE;

  PROCEND jmp$set_sched_profile_loading;

?? TITLE := '[XDCL, INLINE] jmp$set_scheduler_event', EJECT ??

  PROCEDURE [XDCL, INLINE] jmp$set_scheduler_event
    (    event: jmt$job_scheduler_events);

    VAR
      status: syt$monitor_status;

    IF NOT jmv$job_scheduler_event [event] THEN
      jmv$job_scheduler_event [event] := TRUE;
      IF jmv$job_sched_events_selected [event] THEN
        tmp$monitor_ready_system_task (tmc$stid_job_scheduler, status);
      IFEND;
    IFEND;
  PROCEND jmp$set_scheduler_event;

?? TITLE := '[XDCL] jmp$set_scheduler_memory_event', EJECT ??

  PROCEDURE [XDCL] jmp$set_scheduler_memory_event;

    VAR
      status: syt$monitor_status;

    jmv$job_scheduler_event [jmc$needed_memory_available] := TRUE;
    tmp$monitor_ready_system_task (tmc$stid_job_scheduler, status);

  PROCEND jmp$set_scheduler_memory_event;

?? TITLE := '[XDCL] jmp$set_swapout_candidate', EJECT ??

  PROCEDURE [XDCL] jmp$set_swapout_candidate
    (    ajl_o: jmt$ajl_ordinal;
         swapout_reason: jmt$swapout_reasons);

    VAR
      ajle_p: ^jmt$active_job_list_entry,
      ijle_p: ^jmt$initiated_job_list_entry,
      ijl_ord: jmt$ijl_ordinal,
      service_used: integer;

    #KEYPOINT (osk$entry, 0, jmk$set_swapout_candidate);

    ajle_p := ^jmv$ajl_p^ [ajl_o];
    ijle_p := ajle_p^.ijle_p;
    IF ijle_p^.entry_status = jmc$ies_job_in_memory THEN
      IF jmv$swap_jobs_in_long_wait THEN
        ijl_ord := ajle_p^.ijl_ordinal;
        ijle_p^.estimated_ready_time := #FREE_RUNNING_CLOCK (0) + ijle_p^.last_think_time;
        jmp$calculate_service (ijle_p, service_used);
        check_for_class_switch (ijle_p);
        ijle_p^.job_scheduler_data.swapout_reason := swapout_reason;
        IF (swapout_reason = jmc$sr_idle_dispatching) AND (jmv$service_classes
              [ijle_p^.job_scheduler_data.service_class]^.attributes.guaranteed_service_quantum =
              jmc$unlimited_service_accum) THEN
          ijle_p^.job_scheduler_data.guaranteed_service_remaining := jmc$unlimited_service_accum;
        ELSEIF (swapout_reason = jmc$sr_idle_dispatching) AND
              (ijle_p^.job_scheduler_data.service_accumulator_since_swap <
              jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.attributes.
              guaranteed_service_quantum) THEN
          ijle_p^.job_scheduler_data.guaranteed_service_remaining := jmv$service_classes
                [ijle_p^.job_scheduler_data.service_class]^.attributes.guaranteed_service_quantum -
                ijle_p^.job_scheduler_data.service_accumulator_since_swap;
        IFEND;
        ijle_p^.job_scheduler_data.job_swap_counts.long_wait :=
              ijle_p^.job_scheduler_data.job_swap_counts.long_wait + 1;
        jsp$monitor_swap_out (ijl_ord);

{ If the service class is at the maxaj limit, remove the class so a job
{ with this service class can be activated.

        IF (ijle_p^.job_scheduler_data.service_class IN jmv$classes_in_maxaj_limit_wait) THEN
          remove_class_from_maxaj_limit (ijle_p^.job_scheduler_data.service_class);
        IFEND;
      ELSE
        ajle_p^.job_is_good_swap_candidate := TRUE;
      IFEND;
    IFEND;

    #KEYPOINT (osk$exit, 0, jmk$set_swapout_candidate);

  PROCEND jmp$set_swapout_candidate;

?? TITLE := '[XDCL] jmp$subsystem_priority_change', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to set a scheduler event if a swapin candidate
{   job has had its scheduling dispatching priority changed because of subsystem locks.
{ DESIGN:
{   The caller of this procedure must set the PTL lock.

  PROCEDURE [XDCL] jmp$subsystem_priority_change
    (    ijle_p: ^jmt$initiated_job_list_entry);

    IF (ijle_p^.entry_status = jmc$ies_swapin_candidate) AND
          (ijle_p^.scheduling_dispatching_priority > ijle_p^.dispatching_control.dispatching_priority) THEN
      jmv$subsystem_priority_changes [ijle_p^.job_scheduler_data.service_class] := TRUE;
      jmp$set_scheduler_event (jmc$subsystem_priority_change);
    IFEND;

  PROCEND jmp$subsystem_priority_change;

?? TITLE := '[XDCL] jmp$swap_non_dispatchable_job', EJECT ??

  PROCEDURE [XDCL] jmp$swap_non_dispatchable_job
    (    ajl_ordinal: jmt$ajl_ordinal);

    VAR
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry;

    ijle_p := jmv$ajl_p^ [ajl_ordinal].ijle_p;
    ijl_ordinal := jmv$ajl_p^ [ajl_ordinal].ijl_ordinal;
    jmp$set_swapout_candidate (ajl_ordinal, jmc$sr_idle_dispatching);

{ Jmp$set_swapout_candidate swapped the job and caused entry status to be changed to job_swapped.
{ The job was artificially idled, so it must be put in the ready task list to swap back in.

    jmv$swapped_idle_disp_count := jmv$swapped_idle_disp_count + 1;
    jmp$change_ijl_entry_status (ijle_p, jmc$ies_ready_task);
    insert_job_in_ready_task_list (ijl_ordinal, ijle_p);
    jmv$job_scheduler_event [jmc$ready_task_in_job] := TRUE;

  PROCEND jmp$swap_non_dispatchable_job;

?? TITLE := '[XDCL] jmp$update_serv_class_stats_req', EJECT ??

{ PURPOSE:
{   This procedure processes the monitor request to update service class statistics.
{ DESIGN:
{   The service class statistics updated by this procedure must be updated in monitor mode
{   in order to synchronize writing the statistics variable.  This procedure is called via
{   a monitor request at statistics emission time.  All initiated jobs are scanned for
{   statistics information.

  PROCEDURE [XDCL] jmp$update_serv_class_stats_req
    (VAR request_block: jmt$rb_service_class_statistics);

    VAR
      ijl_bn: jmt$ijl_block_number,
      ijl_bi: jmt$ijl_block_index,
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry;

    request_block.status.normal := TRUE;

    FOR ijl_bn := LOWERBOUND (jmv$ijl_p.block_p^) TO jmv$ijl_p.max_block_in_use DO
      IF (jmv$ijl_p.block_p^ [ijl_bn].index_p <> NIL) THEN
        ijl_ordinal.block_number := ijl_bn;
        FOR ijl_bi := LOWERVALUE (jmt$ijl_block_index) TO UPPERVALUE (jmt$ijl_block_index) DO
          ijl_ordinal.block_index := ijl_bi;
          jmp$get_ijle_p (ijl_ordinal, ijle_p);
          IF ijle_p^.entry_status <> jmc$ies_entry_free THEN
            jmp$update_service_class_stats (ijle_p);
          IFEND;
        FOREND;
      IFEND;
    FOREND;

  PROCEND jmp$update_serv_class_stats_req;

?? TITLE := '[XDCL] jmp$update_service_class_stats', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to update the service class statistics for a
{   service class with the information of a specific job.  The service class statistics
{   accumulators for the job are updated.

  PROCEDURE [XDCL] jmp$update_service_class_stats
    (    ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      statistics_p: ^jmt$mtr_serv_class_stat_entry;

{ Update cp statistics.

    tmp$set_lock (jmv$service_class_stats_lock);

    statistics_p := ^jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.statistics;
    statistics_p^.cp_time.job_mode := statistics_p^.cp_time.job_mode +
          (ijle_p^.statistics.cp_time.time_spent_in_job_mode -
          ijle_p^.service_class_statistics.cp_time.time_spent_in_job_mode);
    ijle_p^.service_class_statistics.cp_time.time_spent_in_job_mode :=
          ijle_p^.statistics.cp_time.time_spent_in_job_mode;

    statistics_p^.cp_time.monitor_mode := statistics_p^.cp_time.monitor_mode +
          (ijle_p^.statistics.cp_time.time_spent_in_mtr_mode -
          ijle_p^.service_class_statistics.cp_time.time_spent_in_mtr_mode);

    ijle_p^.service_class_statistics.cp_time.time_spent_in_mtr_mode :=
          ijle_p^.statistics.cp_time.time_spent_in_mtr_mode;

{ Update page fault statistics.

    statistics_p^.page_faults.disk := statistics_p^.page_faults.disk +
          (ijle_p^.statistics.paging_statistics.page_in_count -
          ijle_p^.service_class_statistics.page_faults.disk);
    ijle_p^.service_class_statistics.page_faults.disk := ijle_p^.statistics.paging_statistics.page_in_count;

    statistics_p^.page_faults.reclaimed := statistics_p^.page_faults.reclaimed +
          (ijle_p^.statistics.paging_statistics.pages_reclaimed_from_queue -
          ijle_p^.service_class_statistics.page_faults.reclaimed);
    ijle_p^.service_class_statistics.page_faults.reclaimed :=
          ijle_p^.statistics.paging_statistics.pages_reclaimed_from_queue;

    statistics_p^.page_faults.assigned := statistics_p^.page_faults.assigned +
          (ijle_p^.statistics.paging_statistics.new_pages_assigned -
          ijle_p^.service_class_statistics.page_faults.assigned);
    ijle_p^.service_class_statistics.page_faults.assigned :=
          ijle_p^.statistics.paging_statistics.new_pages_assigned;

{ Update swapping statistics.

    statistics_p^.swap_stats.long_wait_swaps := statistics_p^.swap_stats.long_wait_swaps +
          (ijle_p^.job_scheduler_data.job_swap_counts.long_wait -
          ijle_p^.service_class_statistics.swapouts.long_wait);
    ijle_p^.service_class_statistics.swapouts.long_wait :=
          ijle_p^.job_scheduler_data.job_swap_counts.long_wait;

    statistics_p^.swap_stats.job_mode_swaps := statistics_p^.swap_stats.job_mode_swaps +
          (ijle_p^.job_scheduler_data.job_swap_counts.job_mode -
          ijle_p^.service_class_statistics.swapouts.job_mode);
    ijle_p^.service_class_statistics.swapouts.job_mode := ijle_p^.job_scheduler_data.job_swap_counts.job_mode;

    tmp$clear_lock (jmv$service_class_stats_lock);

  PROCEND jmp$update_service_class_stats;

MODEND jmm$job_scheduler_monitor_mode;
*DECK DECK=JMM$JOB_SCHEDULER_MONITOR_OR_R1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : job scheduler monitor or r1' ??
MODULE jmm$job_scheduler_monitor_or_r1;

{ Purpose:
{   This module contains scheduler procedures which can be called from either monitor or
{   ring 1.
{
{ Index of procedures:
{   jmp$calculate_service
{   jmp$find_jsn
{
{ Externals referenced by this module:

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc jmp$compute_total_memory_used
*copyc jmv$ijl_p
*copyc jmv$last_service_calc_time
*copyc jmv$service_classes
*copyc jmv$ssn_previous_sequence
*copyc jmv$system_supplied_name

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc jmt$service_factors
*copyc jmt$system_supplied_name
*copyc jmt$system_supplied_name_mask
*copyc jmk$keypoints
?? POP ??

?? TITLE := '[XDCL] jmp$calculate_service', EJECT ??

{ PURPOSE:
{   This procedure calculates the amount of service a job has used.
{ DESIGN:
{   This procedure is called periodically (based on the job scheduler table attribute,
{   service_adjustment_interval) to calculate the service all active jobs have used.  It
{   is also called to calculate service for jobs that swap out for long wait.
{   The value for each service component is determined and multiplied by the service
{   factor.  Some components (io and cptime) must be determined even if the service factor
{   for that component is zero; otherwise there is no "history" for the component.  If the
{   service factor is changed to a non-zero value, the first service calculation would
{   be skewed.

  PROCEDURE [XDCL] jmp$calculate_service
    (    ijl_p: ^jmt$initiated_job_list_entry;
     VAR service_used: integer);

    VAR
      cptime_used: integer,
      current_cptime: integer,
      current_page_fault_count: integer,
      memory_used: 0 .. osc$max_page_frames,
      service_class_list_p: ^jmt$service_class_attributes,
      time_swapped_in: integer;

{ Compute the service the job has received.

    #KEYPOINT (osk$entry, 0, jmk$calculate_service);

    service_used := 0;
    service_class_list_p := ^jmv$service_classes [ijl_p^.job_scheduler_data.service_class]^.attributes;

    current_cptime := ijl_p^.statistics.cp_time.time_spent_in_job_mode;
    cptime_used := (current_cptime - ijl_p^.job_scheduler_data.last_cptime) DIV 1000;
    IF cptime_used < 1 THEN
      cptime_used := 1;
    IFEND;
    service_used := service_used + (service_class_list_p^.service_factors [jmc$sf_cpu] * cptime_used);
    ijl_p^.job_scheduler_data.last_cptime := current_cptime;

    IF service_class_list_p^.service_factors [jmc$sf_memory] <> 0 THEN
      jmp$compute_total_memory_used (ijl_p, memory_used);
      service_used := service_used + (service_class_list_p^.service_factors [jmc$sf_memory] * memory_used);
    IFEND;

    IF service_class_list_p^.service_factors [jmc$sf_residence] <> 0 THEN
      IF jmv$last_service_calc_time < ijl_p^.swap_data.timestamp THEN
        time_swapped_in := (#FREE_RUNNING_CLOCK (0) - ijl_p^.swap_data.timestamp) DIV 1000000;
      ELSE
        time_swapped_in := (#FREE_RUNNING_CLOCK (0) - jmv$last_service_calc_time) DIV 1000000;
      IFEND;
      service_used := service_used + (service_class_list_p^.service_factors [jmc$sf_residence] *
            time_swapped_in);
    IFEND;

    current_page_fault_count := ijl_p^.statistics.paging_statistics.page_fault_count;
    service_used := service_used + (service_class_list_p^.service_factors [jmc$sf_io] *
          (current_page_fault_count - ijl_p^.job_scheduler_data.last_page_fault_count));
    ijl_p^.job_scheduler_data.last_page_fault_count := current_page_fault_count;

{ Increment the job's service accumulators by the amount of service the job has used.

    ijl_p^.job_scheduler_data.service_accumulator := ijl_p^.job_scheduler_data.service_accumulator +
          service_used;
    ijl_p^.job_scheduler_data.service_accumulator_since_swap :=
          ijl_p^.job_scheduler_data.service_accumulator_since_swap + service_used;

    #KEYPOINT (osk$exit, 0, jmk$calculate_service);

  PROCEND jmp$calculate_service;

?? TITLE := '[XDCL] jmp$find_jsn', EJECT ??

  PROCEDURE [XDCL] jmp$find_jsn
    (    jsn: string ( * <= jmc$system_supplied_name_size);
     VAR ijle_p: ^jmt$initiated_job_list_entry;
     VAR ijlo: jmt$ijl_ordinal);

    VAR
      ijl_bn: jmt$ijl_block_number,
      ijl_bi: jmt$ijl_block_index,
      ijl_p: ^jmt$initiated_job_list_entry,
      jsn_length: 0 .. jmc$system_supplied_name_size,
      system_supplied_name: jmt$system_supplied_name_mask;

    ijle_p := NIL;

{ Expand jsn to full system supplied name.

    jsn_length := STRLENGTH (jsn);
    IF jsn_length = jmc$system_supplied_name_size THEN
      system_supplied_name.system_supplied_name := jsn;
    ELSEIF jsn_length = jmc$long_ssn_size THEN
      system_supplied_name := jmv$system_supplied_name;
      system_supplied_name.sequence := jsn (2, jmc$ssn_sequence_number_size);
      system_supplied_name.counter := jsn (6, jmc$ssn_counter_size);
    ELSEIF jsn_length = jmc$short_ssn_size THEN
      system_supplied_name := jmv$system_supplied_name;
      IF system_supplied_name.counter < jsn (2, jmc$ssn_counter_size) THEN
        system_supplied_name.sequence := jmv$ssn_previous_sequence;
      IFEND;
      system_supplied_name.counter := jsn (2, jmc$ssn_counter_size);
    ELSE
      RETURN;
    IFEND;

  /scan_ijl_for_jsn/

    FOR ijl_bn := LOWERBOUND (jmv$ijl_p.block_p^) TO jmv$ijl_p.max_block_in_use DO
      IF (jmv$ijl_p.block_p^ [ijl_bn].index_p <> NIL) THEN
        FOR ijl_bi := LOWERVALUE (jmt$ijl_block_index) TO UPPERVALUE (jmt$ijl_block_index) DO
          ijl_p := ^jmv$ijl_p.block_p^ [ijl_bn].index_p^ [ijl_bi];
          IF ijl_p^.system_supplied_name = system_supplied_name.system_supplied_name THEN
            ijle_p := ijl_p;
            ijlo.block_number := ijl_bn;
            ijlo.block_index := ijl_bi;
            RETURN;
          IFEND;

        FOREND;
      IFEND;
    FOREND /scan_ijl_for_jsn/;
  PROCEND jmp$find_jsn;

MODEND jmm$job_scheduler_monitor_or_r1;





*DECK DECK=JMM$JOB_SCHEDULER_RING_1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : job scheduler ring 1' ??
MODULE jmm$job_scheduler_ring_1;

{ Purpose
{     This module contains procedures to adjust a jobs priority
{      and to perform functions necessary to  accomplish swapout,
{      swapin, and job initiation.
{

{  EXTERNALS REFERENCED BY THIS MODULE:

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc gfp$assign_fde
*copyc gfp$get_fde_p
*copyc gfp$free_fde
*copyc jmp$calculate_service
*copyc jmp$change_dispatching_prior_r1
*copyc jmp$jm_change_ijl_entry_status
*copyc jmp$compute_total_memory_used
*copyc jmp$determine_serv_class_name
*copyc jmp$get_ijle_p
*copyc jmp$incr_scheduler_statistics
*copyc jmp$notify_queued_files_job_end
*copyc jmp$refresh_job_candidate_class
*copyc jmp$reset_max_class_working_set
*copyc jsp$advance_long_wait_jobs
*copyc jsp$help_monitor_mode_swapper
*copyc jsp$special_job_swapout
*copyc jsp$swap_job_out
*copyc jsp$swap_job_in
*copyc i#build_adaptable_array_ptr
*copyc i#call_monitor
*copyc i#move
*copyc i#program_error
*copyc i$real_memory_address
*copyc mmp$build_segment
*copyc mmp$close_device_file
*copyc mmp$free_pages
*copyc mmp$get_max_sdt_sdtx_pointer
*copyc mmp$get_sdtx_entry_p
*copyc mmp$invalidate_segment
*copyc mmp$open_file_by_sfid
*copyc mmp$write_modified_pages
*copyc osp$append_status_parameter
*copyc osp$clear_signature_lock
*copyc osp$expand_ptl
*copyc osp$set_locked_variable
*copyc osp$set_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$find_executing_task_xcb
*copyc pmp$get_executing_task_gtid
*copyc pmp$ready_task
*copyc pmp$zero_out_table
*copyc syp$create_job_template
*copyc syp$establish_condition_handler
*copyc syp$order_job_fixed_pages
*copyc syp$set_status_from_mtr_status
*copyc syp$update_flags
*copyc syp$write_job_fixed_pages
*copyc tmp$find_mainframe_signal
*copyc tmp$ready_system_task1
*copyc jmv$ajl_p
*copyc jmv$candidate_queued_jobs
*copyc jmv$classes_in_maxaj_limit_wait
*copyc jmv$classes_in_resource_wait
*copyc jmv$idle_dispatching_controls
*copyc jmv$ijl_entry_status_statistics
*copyc jmv$ijl_p
*copyc jmv$ijl_ready_task_list
*copyc jmv$job_class_table_p
*copyc jmv$job_counts
*copyc jmv$job_scheduler_event
*copyc jmv$job_scheduler_table
*copyc jmv$job_sched_events_selected
*copyc jmv$last_service_calc_time
*copyc jmv$long_wait_swap_threshold
*copyc jmv$max_ajl_ordinal_in_use
*copyc jmv$max_class_working_set
*copyc jmv$max_service_class_in_use
*copyc jmv$maximum_service_classes
*copyc jmv$maximum_job_class_in_use
*copyc jmv$memory_needed_by_scheduler
*copyc jmv$memory_queue_update_by_swap
*copyc jmv$null_ijl_ordinal
*copyc jmv$prevent_activation_of_jobs
*copyc jmv$refresh_job_candidates
*copyc jmv$sched_profile_is_loading
*copyc jmv$sched_service_calc_time
*copyc jmv$sdtx
*copyc jmv$service_classes
*copyc jmv$subsystem_priority_changes
*copyc jmv$swapin_candidate_queue
*copyc jmv$system_ajl_ordinal
*copyc jmv$system_core_template
*copyc jmv$system_ijl_ordinal
*copyc jmv$system_job_template_p
*copyc jmv$time_to_wake_scheduler
*copyc mmv$default_sdtx_entry
*copyc mmv$max_template_segment_number
*copyc mmv$min_avail_pages
*copyc mmv$reassignable_page_frames
*copyc mmv$resident_job_target
*copyc osv$mainframe_pageable_heap
*copyc osv$mainframe_wired_heap
*copyc osv$page_size
*copyc tmv$ptl_p

?? PUSH (LISTEXT := ON) ??
*copyc jmc$maximum_job_count
*copyc jmc$null_ajl_ordinal
*copyc jme$job_scheduler_conditions
*copyc jmt$dispatching_control
*copyc jmt$dispatching_control_index
*copyc jmt$job_class_attributes
*copyc jmt$job_sched_serv_class_stats
*copyc jmt$job_scheduler_event
*copyc jmt$job_scheduler_statistics
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc jmt$job_template_entry
*copyc jmt$operator_request_list
*copyc jmt$rb_scheduler_requests
*copyc jmt$service_class_attributes
*copyc jmt$service_class_set
*copyc jmt$system_supplied_name
*copyc jmt$trick_ijlo_variant_record
*copyc jse$condition_codes
*copyc mmc$segment_manager_defaults
*copyc mme$condition_codes
*copyc mmt$page_frame_queue_id
*copyc mmt$page_frame_index
*copyc syt$monitor_request_code
*copyc syt$system_core_condition
*copyc jmt$lock_functions
*copyc jmt$node
*copyc jmc$special_dispatch_priorities
*copyc syc$monitor_request_codes
*copyc jmk$keypoints
*copyc ost$hardware_subranges
*copyc ost$status
*copyc ost$heap
*copyc tme$monitor_mode_exceptions
*copyc tmt$rb_initiate_job
*copyc jmt$job_control_block
*copyc ost$execution_control_block
*copyc oss$job_fixed
*copyc oss$mainframe_paged_literal
*copyc oss$mainframe_pageable
?? POP ??
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    gtid_of_task_waiting_for_idle: ost$global_task_id := [0, 0],
    jmv$job_sched_serv_class_stats: [XDCL, #GATE] jmt$job_sched_serv_class_stats :=
          [REP jmc$maximum_service_classes of [0, 0]],
    jmv$operator_request_list: [STATIC, oss$mainframe_pageable] jmt$operator_request_list := [[0], * ],
    jmv$all_jobs_swapped_for_idling: [STATIC, oss$mainframe_pageable] boolean := FALSE,
    jmv$sched_memory_wait_factor: [XDCL] integer := 5,
    jmv$scheduler_wait_time: [XDCL] integer := 500000;


?? TITLE := 'adjust_active_job_priority', EJECT ??

  PROCEDURE adjust_active_job_priority
    (    ijle_p: ^jmt$initiated_job_list_entry;
         service_used: integer);

    VAR
      current_class: jmt$service_class_index,
      new_class: jmt$service_class_index,
      priority: integer,
      rb: jmt$rb_scheduler_requests,
      service_class_p: ^jmt$service_class_attributes;

    service_class_p := ^jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.attributes;

{ Decrement the job's priority by the amount of service used.

    priority := ijle_p^.job_scheduler_data.priority - service_used;
    IF priority < service_class_p^.scheduling_priority.minimum THEN
      ijle_p^.job_scheduler_data.priority := service_class_p^.scheduling_priority.minimum;
    ELSE
      ijle_p^.job_scheduler_data.priority := priority;
    IFEND;

{ Change the job's service class if the job has reached the class service threshold.
{ Only switch classes if the new class to switch to is currently defined.

    IF (ijle_p^.job_scheduler_data.service_accumulator > service_class_p^.class_service_threshold) AND
          (service_class_p^.class_service_threshold <> jmc$unlimited_service_accum) AND
          (NOT jmv$sched_profile_is_loading) THEN
      IF ijle_p^.job_scheduler_data.service_class <> service_class_p^.next_service_class_index THEN
        current_class := ijle_p^.job_scheduler_data.service_class;
        new_class := service_class_p^.next_service_class_index;
        IF jmv$service_classes [new_class]^.attributes.defined THEN
          rb.reqcode := syc$rc_job_scheduler_request;
          rb.sub_reqcode := jmc$src_class_switch;
          rb.system_supplied_name := ijle_p^.system_supplied_name;
          rb.new_service_class := new_class;
          rb.new_service_accumulator := 0;
          rb.old_service_class := current_class;
          rb.old_service_accumulator := ijle_p^.job_scheduler_data.service_accumulator;

          i#call_monitor (#LOC (rb), #SIZE (rb));

        IFEND;
      IFEND;
    IFEND;

  PROCEND adjust_active_job_priority;

?? TITLE := '[INLINE] adjust_swapin_cand_prio', EJECT ??

{ PURPOSE:
{   Adjust the scheduling priority of a swapin candidate.

  PROCEDURE [INLINE] adjust_swapin_cand_prio
    (    ijle_p: ^jmt$initiated_job_list_entry;
         current_time: jmt$clock_time);

    VAR
      age_interval: integer,
      priority: integer,
      service_class_list_p: ^jmt$service_class_attributes,
      swap_age_interval: integer;

      service_class_list_p := ^jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.attributes;
      swap_age_interval := service_class_list_p^.swap_age_interval;
      IF swap_age_interval <> jmc$unlimited_prio_age_interval THEN
        age_interval := ((current_time - ijle_p^.job_scheduler_data.swapin_q_priority_timestamp)
              DIV swap_age_interval);
      ELSE
        age_interval := 0;  { no aging
      IFEND;
      priority := age_interval * service_class_list_p^.scheduling_priority.swap_age_increment + ijle_p^.
            job_scheduler_data.unaged_swap_queue_priority;
      IF priority > service_class_list_p^.scheduling_priority.maximum THEN
        ijle_p^.job_scheduler_data.priority := service_class_list_p^.scheduling_priority.maximum;
      ELSE
        ijle_p^.job_scheduler_data.priority := priority;
      IFEND;

  PROCEND adjust_swapin_cand_prio;

?? TITLE := 'create_and_initialize_job_fixed', EJECT ??

  PROCEDURE create_and_initialize_job_fixed
    (    job_class: jmt$job_class,
         service_class: jmt$service_class_index,
         ijl_ord: jmt$ijl_ordinal;
     VAR xcb_p: ^ost$execution_control_block;
     VAR create_status: ost$status);

    VAR
      jcb_p: ^jmt$job_control_block,
      jf_seg_no: ost$segment,
      jf_seg_p: ^cell,
      max_segs: ost$segment,
      max_seg_len: ost$segment_length,
      scan: ost$segment,
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      seg_no: ost$segment,
      seg_templ_p: ^jmt$job_templ_segment,
      segment_attributes: [READ, oss$mainframe_paged_literal] mmt$segment_attrib_descriptor :=
         [1, sfc$no_limit, mmc$cell_pointer, [0, gfc$tr_null_residence, gfc$null_file_hash],
         ^software_attributes],
      segment_pointer: mmt$segment_pointer,
      software_attributes: [READ, oss$mainframe_paged_literal] array [1 .. 1] of mmt$attribute_descriptor :=
            [[mmc$kw_software_attributes, $mmt$software_attribute_set [mmc$sa_fixed]]],
      status: ost$status,
      template_created: boolean,
      st_rma: integer;

    create_status.normal := TRUE;
    mmp$build_segment (segment_attributes, NIL {shared_taskid_array}, segment_pointer, status);
    IF NOT status.normal THEN
      create_status.normal := FALSE;
      i#program_error;
      RETURN;
    IFEND;

{ move the job fixed base template into the job fixed segment.

    jf_seg_p := segment_pointer.cell_pointer;
    i#move (#LOC (jmv$system_core_template.job_fixed_template_p^),
          jf_seg_p, #SIZE (jmv$system_core_template.job_fixed_template_p^));


{ Create JCB descriptor for new segment.

    jcb_p := jf_seg_p;
    jcb_p^.cptime_next_age_working_set := 200000;
    jcb_p^.signal_interval := 0ffffffff(16);

{ Initialize job identity.

    jcb_p^.job_id := jmv$candidate_queued_jobs [job_class].kjl_index;
    jcb_p^.page_aging_interval := jmv$job_class_table_p^ [job_class].page_aging_interval.default;
    jcb_p^.cyclic_aging_interval := jmv$job_class_table_p^ [job_class].cyclic_aging_interval.default;
    jcb_p^.min_working_set_size := jmv$job_class_table_p^ [job_class].minimum_working_set.default;
    jcb_p^.max_working_set_size := jmv$job_class_table_p^ [job_class].maximum_working_set.default;
    jcb_p^.detached_job_wait_time := jmv$job_class_table_p^ [job_class].detached_job_wait_time.default;
    jcb_p^.next_cyclic_aging_time := 0ffffffffffff(16);
    jmp$get_ijle_p (ijl_ord, jcb_p^.ijle_p);
    jcb_p^.jobname := jmv$candidate_queued_jobs [job_class].user_supplied_name;
    jcb_p^.system_name := jmv$candidate_queued_jobs [job_class].system_supplied_name;

{ create XCB descriptor for new segment.

    jf_seg_no := #SEGMENT (segment_pointer.cell_pointer);

    xcb_p := #ADDRESS (#RING (jf_seg_p), jf_seg_no, jmv$system_core_template.jmtr_xcb_offset);

    xcb_p^.timeslice := jmv$service_classes [service_class]^.
          attributes.dispatching_control [jmc$min_dispatching_control].dispatching_timeslice;

{ Create SDT descriptor for new segment.

    sdt_p := #ADDRESS (1, jf_seg_no, xcb_p^.sdt_offset);
    sdtx_p := #ADDRESS (1, jf_seg_no, xcb_p^.sdtx_offset);
    sdt_p^.st [osc$segnum_job_fixed_heap].ste.vl := osc$vl_cache_bypass;
    sdt_p^.st [osc$segnum_job_fixed_heap].ste.r2 := 3;
    sdtx_p^.sdtx_table [osc$segnum_job_fixed_heap].inheritance := mmc$si_share_segment;

{ Set rma pointer of SDT in XP.

    i#real_memory_address (sdt_p, st_rma);
    xcb_p^.xp.segment_table_address_1 := st_rma DIV 10000(16);
    xcb_p^.xp.segment_table_address_2 := st_rma MOD 10000(16);

    xcb_p^.dispatching_priority := jmc$priority_system_job;


{Search for alternate template to match the job class.
{If none found, then initiate NOS/VE template

    syp$create_job_template (ijl_ord, job_class, sdt_p, sdtx_p, template_created);
    IF NOT template_created THEN

{ Load job template segment descriptors in SDT.

{ remember to re init the adaptable pointers in the xcb when
{ multiple job templates become a reality.

      max_segs := UPPERBOUND (jmv$system_job_template_p^.job_template);

    /load_new_jobs_sdt/

      FOR scan := 1 TO max_segs DO
        seg_templ_p := ^jmv$system_job_template_p^.job_template [scan];
        seg_no := seg_templ_p^.seg_no;
        sdt_p^.st [seg_no] := seg_templ_p^.sdt;
        sdtx_p^.sdtx_table [seg_no] := seg_templ_p^.sdtx;
      FOREND /load_new_jobs_sdt/;
    IFEND;

  PROCEND create_and_initialize_job_fixed;

?? TITLE := 'decrement_swapin_cand_counts', EJECT ??

  PROCEDURE [INLINE] decrement_swapin_cand_counts
    (    class: jmt$service_class_index);

{ Decrement the number of jobs in the queue.

    jmv$swapin_candidate_queue [class].number_of_jobs_in_queue :=
          jmv$swapin_candidate_queue [class].number_of_jobs_in_queue - 1;

  PROCEND decrement_swapin_cand_counts;

?? TITLE := '[INLINE] find_end_of_higher_dp_q', EJECT ??

{ PURPOSE:
{   This procedure finds the end of the next higher dispatching priority sub_queue in the
{   swapin candidate queue, if there is one.

  PROCEDURE [INLINE] find_end_of_higher_dp_q
    (    swapin_cand_dp: jmt$dispatching_priority;
         class: jmt$service_class_index;
     VAR end_of_higher_dp_q: jmt$ijl_ordinal;
     VAR head_of_current_q: jmt$ijl_ordinal);

    VAR
      dp: jmt$dispatching_priority,
      ijle_p: ^jmt$initiated_job_list_entry;

    FOR dp := swapin_cand_dp + 1 TO jmc$priority_p10 DO
      IF jmv$swapin_candidate_queue [class].end_of_dp_q [dp] <> jmv$null_ijl_ordinal THEN
        end_of_higher_dp_q := jmv$swapin_candidate_queue [class].end_of_dp_q [dp];
        jmp$get_ijle_p (end_of_higher_dp_q, ijle_p);
        head_of_current_q := ijle_p^. swapin_candidate_queue;
        RETURN;
      IFEND;
    FOREND;

    end_of_higher_dp_q := jmv$null_ijl_ordinal;
    head_of_current_q := jmv$swapin_candidate_queue [class].swapin_candidate_queue;

  PROCEND find_end_of_higher_dp_q;

?? TITLE := 'get_ready_task_list', EJECT ??

{ PURPOSE:
{   This procedure gets the head of the ready task list, which monitor mode
{   scheduler builds.
{ DESIGN:
{   The head of the list is a global variable which must be changed by both
{   monitor mode and job mode scheduler.  To synchronize the monitor/job mode
{   references, the head of the list is a locked variable which can be referenced
{   only via the #compare_swap procedures.

  PROCEDURE get_ready_task_list
    (VAR head_of_list: jmt$ijl_ordinal);

    VAR
      list_head: jmt$trick_ijlo_variant_record,
      old_list_head: jmt$trick_ijlo_variant_record,
      succeeded: boolean;

    old_list_head.ijl_integer := 0;

    REPEAT
      osp$set_locked_variable (jmv$ijl_ready_task_list, old_list_head.ijl_integer, 0, list_head.ijl_integer,
            succeeded);
      IF NOT succeeded THEN
        old_list_head.ijl_integer := list_head.ijl_integer;
      IFEND;
    UNTIL succeeded;
    head_of_list := old_list_head.ijl_ordinal;

  PROCEND get_ready_task_list;

?? TITLE := '[XDCL, #GATE] jmp$add_to_maxaj_limit_set', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$add_to_maxaj_limit_set
    (    class: jmt$service_class_index);

    jmv$classes_in_maxaj_limit_wait := jmv$classes_in_maxaj_limit_wait + $jmt$service_class_set [class];

  PROCEND jmp$add_to_maxaj_limit_set;

?? TITLE := '[XDCL, #GATE] jmp$adjust_swapin_cand_prio', EJECT ??

{ PURPOSE:
{   Process the calls from ring 2 to adjust the scheduling priority for a swapin candidate.

  PROCEDURE [XDCL, #GATE] jmp$adjust_swapin_cand_prio
    (    ijl_ordinal: jmt$ijl_ordinal;
         current_time: jmt$clock_time);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry;

      jmp$get_ijle_p (ijl_ordinal, ijle_p);
      adjust_swapin_cand_prio (ijle_p, current_time);

  PROCEND jmp$adjust_swapin_cand_prio;

?? TITLE := '[XDCL, #GATE] jmp$all_jobs_swapped_for_idling', EJECT ??

  FUNCTION [XDCL, #GATE] jmp$all_jobs_swapped_for_idling: boolean;

    jmp$all_jobs_swapped_for_idling := jmv$all_jobs_swapped_for_idling;

  FUNCEND jmp$all_jobs_swapped_for_idling;

?? TITLE := '[XDCL, #GATE] jmp$allocate_more_ijl_space', EJECT ??

*copy jmh$allocate_more_ijl_space

  PROCEDURE [XDCL, #GATE] jmp$allocate_more_ijl_space
    (    ijl_block_number: jmt$ijl_block_number);

    jmv$ijl_p.block_p^ [ijl_block_number].in_use_count := 0;
    ALLOCATE jmv$ijl_p.block_p^ [ijl_block_number].index_p IN osv$mainframe_wired_heap^;

    pmp$zero_out_table (#LOC (jmv$ijl_p.block_p^ [ijl_block_number].index_p^),
          #SIZE (jmv$ijl_p.block_p^ [ijl_block_number].index_p^));

    IF ijl_block_number > jmv$ijl_p.max_block_in_use THEN
      jmv$ijl_p.max_block_in_use := jmv$ijl_p.max_block_in_use + 1;

{  This loop is necessary because when this procedure is called from job recovery,
{  the IJL in not constructed sequentially.

      WHILE jmv$ijl_p.max_block_in_use <> ijl_block_number DO
        jmv$ijl_p.block_p^ [jmv$ijl_p.max_block_in_use].index_p := NIL;
        jmv$ijl_p.block_p^ [jmv$ijl_p.max_block_in_use].in_use_count := 0;
        jmv$ijl_p.max_block_in_use := jmv$ijl_p.max_block_in_use + 1;
      WHILEND;
    IFEND;

  PROCEND jmp$allocate_more_ijl_space;

?? TITLE := '[XDCL, #GATE] jmp$call_job_swapper', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$call_job_swapper;

{
{     The purpose of this procedure is to call the job swapper to perform some activity that
{  is neeeded by monitor mode job swapper.
{

    jmp$clear_scheduler_event (jmc$call_job_swapper);
    jsp$help_monitor_mode_swapper;

  PROCEND jmp$call_job_swapper;

?? TITLE := '[XDCL] jmp$check_active_job_limits', EJECT ??

  PROCEDURE [XDCL] jmp$check_active_job_limits
    (    service_class_set: jmt$service_class_set);

    VAR
      class: jmt$service_class_index,
      ignore_status: ost$status;

  /check_maxaj/
    FOR class := jmc$system_service_class TO jmv$max_service_class_in_use DO
      IF class IN service_class_set THEN
        IF ((jmv$job_counts.service_class_counts [class].scheduler_initiated_jobs -
              jmv$job_counts.service_class_counts [class].swapped_jobs) >
              jmv$service_classes [class]^.attributes.maximum_active_jobs) THEN
          jmp$set_event_and_ready_sched (jmc$swap_jobs_for_lower_maxaj);
          EXIT /check_maxaj/;
        IFEND;
      IFEND;
    FOREND /check_maxaj/;
  PROCEND jmp$check_active_job_limits;

?? TITLE := '[XDCL, #GATE] jmp$clear_memory_res_swap_field', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$clear_memory_res_swap_field
    (    ijl_ord: jmt$ijl_ordinal);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry;

    jmp$get_ijle_p (ijl_ord, ijle_p);
    ijle_p^.memory_reserve_request.swapout_job := FALSE;

  PROCEND jmp$clear_memory_res_swap_field;

?? TITLE := '[XDCL, #GATE] jmp$clear_scheduler_event', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$clear_scheduler_event
    (    event: jmt$job_scheduler_events);

    jmv$job_scheduler_event [event] := FALSE;

  PROCEND jmp$clear_scheduler_event;

?? TITLE := '[XDCL, #GATE] jmp$clear_sched_event_selection', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$clear_sched_event_selection
    (    event: jmt$job_scheduler_events);

    jmv$job_sched_events_selected [event] := FALSE;

  PROCEND jmp$clear_sched_event_selection;

?? TITLE := '[XDCL, #GATE] jmp$decrement_lw_threshold', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$decrement_lw_threshold
    (    node: jmt$node);

    VAR
      dp: jmt$dispatching_priority;

    FOR dp := node.dispatching_priority DOWNTO jmc$lowest_dispatching_priority DO
      jmv$long_wait_swap_threshold [dp] := jmv$long_wait_swap_threshold [dp] - node.ws;
      IF jmv$long_wait_swap_threshold [dp] < mmv$min_avail_pages THEN
        jmv$long_wait_swap_threshold [dp] := mmv$min_avail_pages;
      IFEND;
    FOREND;

  PROCEND jmp$decrement_lw_threshold;

?? TITLE := '[XDCL, #GATE] jmp$delete_swapin_candidate', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$delete_swapin_candidate
    (    delete_ijl_ordinal: jmt$ijl_ordinal;
         class: jmt$service_class_index);

    VAR
      class_scan: jmt$service_class_index,
      current_ijle_p: ^jmt$initiated_job_list_entry,
      current_ijlo: jmt$ijl_ordinal,
      delete_ijle_p: ^jmt$initiated_job_list_entry,
      dispatch_prio: jmt$dispatching_priority,
      found: boolean,
      status: ost$status;

    found := FALSE;
    jmp$get_ijle_p (delete_ijl_ordinal, delete_ijle_p);
    dispatch_prio := delete_ijle_p^.swapin_candidate_queue_dp;

    IF delete_ijl_ordinal = jmv$swapin_candidate_queue [class].swapin_candidate_queue THEN


{ Delete from the head of the queue.

      jmv$swapin_candidate_queue [class].swapin_candidate_queue := delete_ijle_p^.swapin_candidate_queue;
      found := TRUE;
      decrement_swapin_cand_counts (class);
      IF delete_ijl_ordinal = jmv$swapin_candidate_queue [class].end_of_dp_q [dispatch_prio] THEN
        jmv$swapin_candidate_queue [class].end_of_dp_q [dispatch_prio] := jmv$null_ijl_ordinal;
      IFEND;

    ELSE


{ Delete from the middle or end of the queue.

      current_ijlo := jmv$swapin_candidate_queue [class].swapin_candidate_queue;

    /find_delete_candidate/
      WHILE (current_ijlo <> delete_ijl_ordinal) AND (current_ijlo <> jmv$null_ijl_ordinal) DO
        jmp$get_ijle_p (current_ijlo, current_ijle_p);
        IF current_ijle_p^.swapin_candidate_queue = delete_ijl_ordinal THEN
          found := TRUE;
          current_ijle_p^.swapin_candidate_queue := delete_ijle_p^.swapin_candidate_queue;


          decrement_swapin_cand_counts (class);
          IF delete_ijl_ordinal = jmv$swapin_candidate_queue [class].end_of_dp_q [dispatch_prio] THEN
            IF current_ijle_p^.swapin_candidate_queue_dp = dispatch_prio THEN
              jmv$swapin_candidate_queue [class].end_of_dp_q [dispatch_prio] := current_ijlo;
            ELSE
              jmv$swapin_candidate_queue [class].end_of_dp_q [dispatch_prio] := jmv$null_ijl_ordinal;
            IFEND;
          IFEND;
          EXIT /find_delete_candidate/;
        IFEND;
        current_ijlo := current_ijle_p^.swapin_candidate_queue;
      WHILEND /find_delete_candidate/;

    IFEND;

    IF NOT found THEN


{ The job was not in the queue we expected it to be in.  Check the queues for
{ each class (in case of a service class switch).

    /scan_all_service_class_queues/
      FOR class_scan := jmc$system_service_class TO jmv$max_service_class_in_use DO
        IF delete_ijl_ordinal = jmv$swapin_candidate_queue [class_scan].swapin_candidate_queue THEN


{ Delete from the head of the queue.

          jmv$swapin_candidate_queue [class_scan].swapin_candidate_queue := delete_ijle_p^.
                swapin_candidate_queue;
          found := TRUE;
          decrement_swapin_cand_counts (class_scan);
          IF delete_ijl_ordinal = jmv$swapin_candidate_queue [class].end_of_dp_q [dispatch_prio] THEN
            jmv$swapin_candidate_queue [class].end_of_dp_q [dispatch_prio] := jmv$null_ijl_ordinal;
          IFEND;
          EXIT /scan_all_service_class_queues/;
        ELSE


{ Delete from the middle or end of the queue.

          current_ijlo := jmv$swapin_candidate_queue [class_scan].swapin_candidate_queue;

        /find_delete_candidate_2/
          WHILE (current_ijlo <> delete_ijl_ordinal) AND (current_ijlo <> jmv$null_ijl_ordinal) DO
            jmp$get_ijle_p (current_ijlo, current_ijle_p);
            IF current_ijle_p^.swapin_candidate_queue = delete_ijl_ordinal THEN
              found := TRUE;
              current_ijle_p^.swapin_candidate_queue := delete_ijle_p^.swapin_candidate_queue;

{ Change the deleted candidate's swapin_candidate field.

              decrement_swapin_cand_counts (class_scan);
              IF delete_ijl_ordinal = jmv$swapin_candidate_queue [class].end_of_dp_q [dispatch_prio] THEN
                IF current_ijle_p^.swapin_candidate_queue_dp = dispatch_prio THEN
                  jmv$swapin_candidate_queue [class].end_of_dp_q [dispatch_prio] := current_ijlo;
                ELSE
                  jmv$swapin_candidate_queue [class].end_of_dp_q [dispatch_prio] := jmv$null_ijl_ordinal;
                IFEND;
              IFEND;
              EXIT /scan_all_service_class_queues/;
            IFEND;
            current_ijlo := current_ijle_p^.swapin_candidate_queue;
          WHILEND /find_delete_candidate_2/;

        IFEND;
      FOREND /scan_all_service_class_queues/;

      IF {still} NOT found THEN
        osp$system_error ('COULD NOT FIND DELETE CANDIDATE', ^status);
      IFEND;
    IFEND;
    delete_ijle_p^.swapin_candidate_queue := jmv$null_ijl_ordinal;

  PROCEND jmp$delete_swapin_candidate;

?? TITLE := '[XDCL, #GATE] jmp$delete_ijl_entry', EJECT ??

*copy jmh$delete_ijl_entry

  PROCEDURE [XDCL, #GATE] jmp$delete_ijl_entry
    (    ijl_ordinal: jmt$ijl_ordinal);

    VAR
      ijl_bn: jmt$ijl_block_number,
      ijle_p: ^jmt$initiated_job_list_entry;

    jmp$get_ijle_p (ijl_ordinal, ijle_p);
    ijl_bn := ijl_ordinal.block_number;

    IF jmv$ijl_p.block_p^ [ijl_bn].in_use_count = 1 THEN
      IF ijl_bn = jmv$ijl_p.max_block_in_use THEN
        ijl_bn := ijl_bn - 1;
        WHILE (jmv$ijl_p.block_p^ [ijl_bn].index_p = NIL) DO
          ijl_bn := ijl_bn - 1;
        WHILEND;
        jmv$ijl_p.max_block_in_use := ijl_bn;
      IFEND;

      FREE jmv$ijl_p.block_p^ [ijl_ordinal.block_number].index_p IN osv$mainframe_wired_heap^;
    ELSE
      pmp$zero_out_table (ijle_p, #SIZE (ijle_p^));
    IFEND;

    jmv$ijl_p.block_p^ [ijl_ordinal.block_number].in_use_count := jmv$ijl_p.
          block_p^ [ijl_ordinal.block_number].in_use_count - 1;

{  Update jmv$ijl_p.start_search_block if necessary.

    IF jmv$ijl_p.start_search_block > ijl_bn THEN
      jmv$ijl_p.start_search_block := ijl_bn;
    IFEND;

  PROCEND jmp$delete_ijl_entry;

?? TITLE := '[XDCL, #GATE] jmp$get_page_count_of_lw_queue', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$get_page_count_of_lw_queue
    (VAR pages_in_lw_queue: mmt$page_frame_index);

    pages_in_lw_queue := mmv$reassignable_page_frames.swapout_io_not_initiated;

  PROCEND jmp$get_page_count_of_lw_queue;

?? TITLE := '[XDCL, #GATE] jmp$find_and_insert_swapin_cand', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to move all jobs that are in the ready task list to the swapin
{   candidate queues.  A job is prioritized based on its service class attributes and the time that
{   it went ready.  A swapin_candidate_q_timestamp of 0 indicates that the job has been swapped in
{   via an operator command; it should be given high priority.

  PROCEDURE [XDCL, #GATE] jmp$find_and_insert_swapin_cand
    (    current_time: jmt$clock_time);

    PROCEDURE prioritize_swapin_candidate
      (    ijl_p: ^jmt$initiated_job_list_entry;
           current_time: jmt$clock_time);

      VAR
        age_interval: integer,
        new_priority: integer,
        service_class_p: ^jmt$service_class_attributes,
        swap_age_interval: integer;

      IF ijl_p^.job_scheduler_data.swapin_q_priority_timestamp = 0 THEN
        ijl_p^.job_scheduler_data.unaged_swap_queue_priority := UPPERVALUE (jmt$job_priority);
        ijl_p^.job_scheduler_data.priority := UPPERVALUE (jmt$job_priority);
      ELSE
        service_class_p := ^jmv$service_classes [ijl_p^.job_scheduler_data.service_class]^.attributes;
        swap_age_interval := service_class_p^.swap_age_interval;
        IF swap_age_interval <> jmc$unlimited_prio_age_interval THEN
          age_interval := ((current_time - ijl_p^.swap_data.timestamp) DIV swap_age_interval);
        ELSE
          age_interval := 0; { no aging
        IFEND;
        new_priority := service_class_p^.scheduling_priority.minimum +
              service_class_p^.scheduling_priority.ready_task_increment +
              (age_interval * service_class_p^.scheduling_priority.swap_age_increment);
        IF new_priority > service_class_p^.scheduling_priority.maximum THEN
          ijl_p^.job_scheduler_data.unaged_swap_queue_priority :=
                service_class_p^.scheduling_priority.maximum;
          ijl_p^.job_scheduler_data.priority := service_class_p^.scheduling_priority.maximum;
        ELSE
          ijl_p^.job_scheduler_data.unaged_swap_queue_priority := new_priority;
          ijl_p^.job_scheduler_data.priority := new_priority;
        IFEND;
      IFEND;

      ijl_p^.job_scheduler_data.swapin_q_priority_timestamp := current_time;

    PROCEND prioritize_swapin_candidate;

?? TITLE := '[XDCL, #GATE] jmp$find_and_insert_swapin_cand', EJECT ??

    VAR
      current_job: jmt$ijl_ordinal,
      ijl_p: ^jmt$initiated_job_list_entry,
      next_job_with_ready_task: jmt$ijl_ordinal,
      status: ost$status;

    jmp$clear_scheduler_event (jmc$ready_task_in_job);
    get_ready_task_list (next_job_with_ready_task);

    WHILE next_job_with_ready_task <> jmv$null_ijl_ordinal DO
      current_job := next_job_with_ready_task;
      jmp$get_ijle_p (current_job, ijl_p);
      next_job_with_ready_task := ijl_p^.job_scheduler_data.ready_task_link;
      ijl_p^.job_scheduler_data.ready_task_link := jmv$null_ijl_ordinal;
      IF ijl_p^.entry_status <> jmc$ies_ready_task THEN
        osp$system_error ('BAD IJL STAT ON RDY TSK IN JOB', ^status);
      IFEND;
      prioritize_swapin_candidate (ijl_p, current_time);
      jmp$jm_change_ijl_entry_status (ijl_p, jmc$ies_swapin_candidate);
      jmp$insert_swapin_candidate (current_job, current_time);
    WHILEND;

  PROCEND jmp$find_and_insert_swapin_cand;

?? TITLE := '[XDCL, #GATE] jmp$idle_advance_lw_jobs', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$idle_advance_lw_jobs;

    VAR
      dp: jmc$lowest_dispatching_priority .. jmc$highest_dispatch_priority,
      dummy_pages_flushed: mmt$page_frame_index;

    FOR dp := jmc$lowest_dispatching_priority TO jmc$highest_dispatch_priority DO
      jmv$long_wait_swap_threshold [dp] := UPPERVALUE (mmt$page_frame_index);
    FOREND;
    jsp$advance_long_wait_jobs (TRUE {flush_all_pages}, dummy_pages_flushed);

  PROCEND jmp$idle_advance_lw_jobs;

?? TITLE := '[XDCL, #GATE] jmp$idling_swapfile_update', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$idling_swapfile_update
    (    ijlo: jmt$ijl_ordinal;
     VAR status: ost$status);

{  This procedure is called for each job in the swapped out queue when the
{  system is idling.  If the swapfile is on an unavailable device the
{  condition handler will be invoked.

    TYPE
      jxcbl = record
        head: ^ost$execution_control_block,
        lock: ost$signature_lock,
      recend;

    VAR
      buffer_index: tmt$signal_buffers,
      fde_entry_p: gft$file_desc_entry_p,
      flags_updated: boolean,
      highest_page_number: mmt$page_frame_index,
      ignore_status: ost$status,
      ijl_p: ^jmt$initiated_job_list_entry,
      job_fixed: ^array [0 .. 7fffffff(16)] of cell,
      job_fixed_offset_list: ^array [0 .. * ] of integer,
      job_fixed_page_count: mmt$page_frame_index,
      job_page_count: mmt$page_frame_index,
      job_xcb_list: [XREF, oss$job_fixed] record
        head: ^ost$execution_control_block,
        lock: ost$signature_lock,
      recend,
      jxcbl_p: ^jxcbl,
      page_index: mmt$page_frame_index,
      page_number: mmt$page_frame_index,
      queue_id: mmt$job_page_queue_index,
      job_fixed_segn: ost$segment,
      sfd_p: ^jst$swap_file_descriptor,
      signal_found: boolean,
      swap_file_p: ^cell,
      swap_file_segn: ost$segment,
      system_flags: ^PACKED ARRAY [tmc$first_system_flag .. tmc$last_system_flag] OF boolean,
      write_job_fixed: boolean,
      xcb_p: ^ost$execution_control_block;


    PROCEDURE scch
      (    mf: ost$monitor_fault;
           ctc: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$set_status_abnormal ('JM', jme$condition_encountered, '', status);
      EXIT jmp$idling_swapfile_update;
    PROCEND scch;


    syp$establish_condition_handler (^scch);
    job_fixed_segn := 0;

  /file_open/
    BEGIN
      jmp$get_ijle_p (ijlo, ijl_p);
      mmp$open_file_by_sfid (ijl_p^.swap_data.swap_file_sfid, 3, 3, mmc$as_random, mmc$sar_write_extend,
            swap_file_segn, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      swap_file_p := #ADDRESS (1, swap_file_segn, 0);

{  Calculate job page count.  Swapped job page count from the IJL could be wrong if shared
{  pages were removed while the job was in the swapped io complete state (S2).  The job page
{  count was updated to the lower value to keep mmv$reassignable_page_frames.now correct.
{  However all pages were written out and need to be accounted for.

      job_page_count := 0;
      FOR queue_id := LOWERVALUE (mmt$job_page_queue_index) TO UPPERVALUE (mmt$job_page_queue_index) DO
        job_page_count := job_page_count + ijl_p^.swap_data.swapped_job_entry.job_page_queue_count [queue_id];
      FOREND;
      ijl_p^.swap_data.swapped_job_page_count := job_page_count;

      i#build_adaptable_array_ptr (1, swap_file_segn, job_page_count * osv$page_size,
            #SIZE (jst$swapped_page_descriptor) * (ijl_p^.swap_data.swapped_job_entry.
            swap_file_descriptor_page_count + job_page_count), 0, #SIZE (jst$swapped_page_descriptor),
            #LOC (sfd_p));

      IF sfd_p^.ijl_entry.system_supplied_name <> ijl_p^.system_supplied_name THEN
        osp$set_status_abnormal ('JM', jme$bad_swap_file_descriptor, '', status);
        EXIT /file_open/;
      IFEND;

      sfd_p^.ijl_entry := ijl_p^;
      mmp$write_modified_pages (^sfd_p^.ijl_entry, #SIZE (jmt$initiated_job_list_entry), osc$wait, status);
      IF NOT status.normal THEN
        EXIT /file_open/;
      IFEND;

{ There may be gaps in the job fixed pages.  Find the largest page number.
{ Pages of job fixed segment that are not JOB FIXED cannot be counted.

      job_fixed_page_count := ijl_p^.swap_data.swapped_job_entry.job_page_queue_count [mmc$pq_job_fixed];
      highest_page_number := 0;
      FOR page_index := 0 TO job_fixed_page_count - 1 DO
        IF (sfd_p^.swapped_page_descriptors [page_index].pft_entry.queue_id = mmc$pq_job_fixed) AND
             (sfd_p^.swapped_page_descriptors [page_index].pft_entry.sva.asid =
              sfd_p^.ijl_entry.job_fixed_asid) THEN
          page_number := sfd_p^.swapped_page_descriptors [page_index].pft_entry.sva.offset DIV osv$page_size;
          IF page_number > highest_page_number THEN
            highest_page_number := page_number;
          IFEND;
        IFEND;
      FOREND;

{ Copy job fixed from the swap file to a segment so that we have a sequence of bytes that is
{ in pva order.

      PUSH job_fixed_offset_list: [0 .. highest_page_number];
      syp$order_job_fixed_pages (job_fixed_page_count, sfd_p, job_fixed_offset_list, job_fixed,
            job_fixed_segn, status);
      IF NOT status.normal THEN
        EXIT /file_open/;
      IFEND;

      jxcbl_p := ^job_fixed^ [#OFFSET (^job_xcb_list)];
      xcb_p := jxcbl_p^.head;
      write_job_fixed := FALSE;

    /follow_xcb_chain/
      WHILE xcb_p <> NIL DO
        xcb_p := ^job_fixed^ [#OFFSET (xcb_p)];
        syp$update_flags (xcb_p, tmv$ptl_p, flags_updated);
        IF flags_updated THEN
          write_job_fixed := TRUE;
          IF tmc$mainframe_linked_signals IN xcb_p^.system_flags THEN

          /find_buffer/
            FOR buffer_index := LOWERVALUE (tmt$signal_buffers) TO UPPERVALUE (tmt$signal_buffers) DO
              IF xcb_p^.signals.reserved [buffer_index] = FALSE THEN
                tmp$find_mainframe_signal (xcb_p^.global_task_id, signal_found, xcb_p^.signals.
                      buffer [buffer_index]);
                IF signal_found THEN
                  xcb_p^.signals.reserved [buffer_index] := TRUE;
                  xcb_p^.signals.present [buffer_index] := TRUE;
                ELSE
                  system_flags := #LOC (xcb_p^.system_flags);
                  system_flags^ [tmc$mainframe_linked_signals] := FALSE;
                  EXIT /find_buffer/;
                IFEND;
              IFEND;
            FOREND /find_buffer/;

          IFEND;
        IFEND;

        xcb_p := xcb_p^.link;
      WHILEND /follow_xcb_chain/;

      IF write_job_fixed THEN
        syp$write_job_fixed_pages (job_fixed_page_count, job_fixed, sfd_p, status);
      IFEND;

    END /file_open/;

    mmp$free_pages (swap_file_p, 7fffffff(16), osc$wait, ignore_status);
    mmp$close_device_file (swap_file_segn, ignore_status);
    IF job_fixed_segn <> 0 THEN
      mmp$invalidate_segment (job_fixed_segn, 1, NIL, ignore_status);
    IFEND;

  PROCEND jmp$idling_swapfile_update;

?? TITLE := '[XDCL, #GATE] jmp$increment_in_use_count', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$increment_ijl_in_use_count
    (    ijl_block_number: jmt$ijl_block_number);

{  This procedure is called by a ring 2 procedure to modify a ring 1 variable.

    jmv$ijl_p.block_p^ [ijl_block_number].in_use_count :=
          jmv$ijl_p.block_p^ [ijl_block_number].in_use_count + 1;

  PROCEND jmp$increment_ijl_in_use_count;

?? TITLE := '[XDCL, #GATE] jmp$initialize_sched_variables', EJECT ??

{  PURPOSE:
{  This procedure initializes variables used by the job scheduler.
{  This procedure is called by jmp$job_scheduler_ring_3.
{

  PROCEDURE [XDCL, #GATE] jmp$initialize_sched_variables;

    VAR
      dp: jmc$lowest_dispatching_priority .. jmc$highest_dispatch_priority,
      i: integer,
      status: ost$status;

    FOR dp := jmc$lowest_dispatching_priority TO jmc$highest_dispatch_priority DO
      jmv$long_wait_swap_threshold [dp] := mmv$min_avail_pages;
    FOREND;
    jmv$prevent_activation_of_jobs := FALSE;

    FOR i := LOWERBOUND (jmv$operator_request_list.request_list)
          TO UPPERBOUND (jmv$operator_request_list.request_list) DO
      jmv$operator_request_list.request_list [i].in_use := FALSE;
    FOREND;

  PROCEND jmp$initialize_sched_variables;

?? TITLE := '[XDCL, #GATE] jmp$initiate_job_from_scheduler', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$initiate_job_from_scheduler
    (    node: jmt$node;
         ijl_ord: jmt$ijl_ordinal;
         service_class: jmt$service_class_index;
     VAR status: ost$status);

    VAR
      create_status: ost$status,
      time: integer,
      fde_entry_p: gft$file_desc_entry_p,
      ignore_status: ost$status,
      ijl_p: ^jmt$initiated_job_list_entry,
      job_class: jmt$job_class,
      kjl_ord: jmt$kjl_index,
      local_status: ost$status,
      lock_status: ost$status,
      original_ijl_entry: jmt$initiated_job_list_entry,
      parent_fde_p: gft$file_desc_entry_p,
      parent_xcb_p: ^ost$execution_control_block,
      rb: tmt$rb_initiate_job,
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      seg: ost$segment,
      segn: ost$segment,
      sfid: gft$system_file_identifier,
      xcb_ptr: ^ost$execution_control_block;

    status.normal := TRUE;


    jmp$get_ijle_p (ijl_ord, ijl_p);

    job_class := node.job_class;
    kjl_ord := jmv$candidate_queued_jobs [job_class].kjl_index;
    create_and_initialize_job_fixed (job_class, service_class, ijl_ord, xcb_ptr, create_status);
    IF NOT create_status.normal THEN
      status.normal := FALSE;
      RETURN;
    ELSE
      jmv$candidate_queued_jobs [job_class].initiated_job_list_ordinal := ijl_ord;

      IF ijl_p^.entry_status <> jmc$ies_entry_free THEN
        osp$system_error ('INIT ERR', ^ignore_status);
      IFEND;

      pmp$zero_out_table (#LOC (ijl_p^), #SIZE (ijl_p^));

      time := #FREE_RUNNING_CLOCK (0);

      ijl_p^.ajl_ordinal := jmc$null_ajl_ordinal;
      ijl_p^.job_scheduler_data.swapout_reason := jmc$sr_null;
      ijl_p^.executing_task_count := 0;
      ijl_p^.job_scheduler_data.job_class := job_class;
      ijl_p^.job_scheduler_data.service_class := service_class;
      ijl_p^.job_scheduler_data.priority := jmv$service_classes [service_class]^.attributes.
            scheduling_priority.maximum;
      ijl_p^.job_scheduler_data.swapin_q_priority_timestamp := time;
      ijl_p^.swap_data.timestamp := time;
      ijl_p^.dispatching_control.dispatching_control_index := jmc$min_dispatching_control;
      ijl_p^.dispatching_control.dispatching_priority := jmc$priority_system_job;
      ijl_p^.scheduling_dispatching_priority := jmc$priority_system_job;
      ijl_p^.dispatching_control.service_remaining := jmc$dc_maximum_service_limit;
      ijl_p^.job_name := jmv$candidate_queued_jobs [job_class].user_supplied_name;
      ijl_p^.kjl_ordinal := jmv$candidate_queued_jobs [job_class].kjl_index;
      ijl_p^.system_supplied_name := jmv$candidate_queued_jobs [job_class].system_supplied_name;
      ijl_p^.queue_file_information.job_abort_disposition := jmc$terminate_on_abort;
      ijl_p^.queue_file_information.job_recovery_disposition := jmc$restart_on_recovery;

{ create a new job in the system.

      rb.reqcode := syc$rc_initiate_job;
      rb.xcb_p := xcb_ptr;
      rb.ijlo := ijl_ord;
      rb.ajo := jmc$null_ajl_ordinal;
      seg := #SEGMENT (xcb_ptr);

{ FDE entries must be assigned for all of the job template segments. The FDE entries will exist
{ in the new job's job fixed segment. This segment currently on exists in the system job scheduler
{ task. The FDE's must be created prior to the monitor request to initiate the job, because the job
{ could execute any time after the monitor request completes.

        mmp$get_max_sdt_sdtx_pointer (xcb_ptr, sdt_p, sdtx_p);
        FOR segn := 1 TO mmv$max_template_segment_number DO
          IF sdtx_p^.sdtx_table [segn].open_validating_ring_number <> 0 THEN
            gfp$assign_fde (gfc$tr_null_residence, seg, sfid, fde_entry_p);
            fde_entry_p^.open_count := 1;
            sdtx_p^.sdtx_table [segn].sfid := sfid;
            IF mmc$sa_stack IN sdtx_p^.sdtx_table [segn].software_attribute_set THEN
              fde_entry_p^.stack_for_ring := sdt_p^.st [segn].ste.r1;
              fde_entry_p^.last_segment_number := segn;
            IFEND;
          IFEND;
        FOREND;

    /issue_system_call/
      WHILE TRUE DO

        i#call_monitor (#LOC (rb), #SIZE (rb));
        IF rb.status.normal THEN

{ The linkage between the FDE created in the parent or the scheduler task, and
{ the AST entry for the job-fixed segment must be broken. The segment should only
{ by associated with the new job.

          pmp$find_executing_task_xcb (parent_xcb_p);
          sdtx_entry_p := mmp$get_sdtx_entry_p (parent_xcb_p, seg);
          gfp$get_fde_p (sdtx_entry_p^.sfid, parent_fde_p);
          parent_fde_p^.asti := 0;
          parent_fde_p^.open_count := 0;
          gfp$free_fde (parent_fde_p, sdtx_entry_p^.sfid);
          EXIT /issue_system_call/
        ELSEIF rb.status.condition = tme$ptl_full THEN
          osp$expand_ptl ({ unconditionally_expand } FALSE, local_status);
          IF local_status.normal THEN
            rb.status.normal := TRUE;
          IFEND;
        IFEND;

        IF NOT (rb.status.normal) THEN
          jmp$refresh_job_candidate_class (job_class, FALSE);
          pmp$zero_out_table (#LOC (ijl_p^), #SIZE (ijl_p^));

{ It is not necessary to delete all of the FDE entries associated with this
{ job, as they only existed in the job fixed segment which is being invalidated.
{ The FDE entry in the job scheduler task must be deleted.

          mmp$invalidate_segment (seg, 1, NIL, local_status);
          IF NOT local_status.normal THEN
            osp$system_error ('SCH CANT DELETE SEG', ^local_status);
          IFEND;
          RETURN;
        IFEND;
      WHILEND /issue_system_call/;

{ set the job monitor task_id into its jobs kjl entry.

      jmv$candidate_queued_jobs [job_class].job_monitor_global_task_id := rb.jmtr_taskid;
      jmp$refresh_job_candidate_class (job_class, TRUE);

{ If the working set maximum for this class is larger than
{ jmv$max_class_working_set then update it.  This job is the only job of this
{ class initiated or it is the 2nd job of the system_job_class.  The System Job
{ is not considered in the value of jmv$max_class_working_set.

      IF (jmv$job_class_table_p^ [job_class].maximum_working_set.maximum > jmv$max_class_working_set) THEN
        jmv$max_class_working_set := jmv$job_class_table_p^ [job_class].maximum_working_set.maximum;
      IFEND;

    IFEND;
  PROCEND jmp$initiate_job_from_scheduler;

?? TITLE := 'jmp$insert_swapin_candidate', EJECT ??

{ PURPOSE:
{   Insert a swapin candidate into the swapin candidate queue.
{ DESIGN:
{   The swapin candidate queue is ordered highest dispatching priority first.  Within equal dispatching
{   priorities, the queue is ordered highest guaranteed service remaining first.
{   If guaranteed service remaining is equal, the queue is ordered highest scheduling priority first.
{   The following example represents a queue with multiple dispatching priorities:
{   Key = (dispatching priority, guaranteed service remaining, scheduling priority)
{
{     (P9,0,900) --> (P6,0,700) --> (P6,0,300) --> (P4,300,500) --> (P4,200,300) --> (P4,0,700)
{
{   Linkage of the swapin queue is the swapin_candidate_queue field in an initiated_job_list (IJL)
{   entry.  The variable, JMV$SWAPIN_CANDIDATE_QUEUE, contains the ijl ordinal of the head of the queue.
{   To facilitate inserting a job into the queue, the end of each dispatching priority sub-queue is kept.
{   Before comparing scheduling priorities, the job in the queue is aged.

  PROCEDURE [XDCL] jmp$insert_swapin_candidate
    (    swap_cand_ijlo: jmt$ijl_ordinal;
           current_time: jmt$clock_time);

    VAR
      class: jmt$service_class_index,
      end_ijlo: jmt$ijl_ordinal,
      end_ijle_p: ^jmt$initiated_job_list_entry,
      next_ijle_p: ^jmt$initiated_job_list_entry,
      next_ijlo: jmt$ijl_ordinal,
      null_ijlo: jmt$ijl_ordinal,
      prev_ijle_p: ^jmt$initiated_job_list_entry,
      prev_ijlo: jmt$ijl_ordinal,
      status: ost$status,
      swap_cand_dp : jmt$dispatching_priority,
      swap_cand_ijle_p: ^jmt$initiated_job_list_entry;

    #KEYPOINT (osk$entry, 0, jmk$insert_swapin_candidate);

    jmp$get_ijle_p (swap_cand_ijlo, swap_cand_ijle_p);
    swap_cand_dp := swap_cand_ijle_p^.scheduling_dispatching_priority;
    swap_cand_ijle_p^.swapin_candidate_queue_dp := swap_cand_dp;
    class := swap_cand_ijle_p^.job_scheduler_data.service_class;

  /insert/
    BEGIN
      IF jmv$swapin_candidate_queue [class].swapin_candidate_queue = jmv$null_ijl_ordinal THEN
        swap_cand_ijle_p^.swapin_candidate_queue := jmv$null_ijl_ordinal;
        jmv$swapin_candidate_queue [class].swapin_candidate_queue := swap_cand_ijlo;
        jmv$swapin_candidate_queue [class].end_of_dp_q [swap_cand_dp] := swap_cand_ijlo;
        EXIT /insert/;
      IFEND;

      end_ijlo := jmv$swapin_candidate_queue [class].end_of_dp_q [swap_cand_dp];
      IF end_ijlo = jmv$null_ijl_ordinal THEN
        find_end_of_higher_dp_q (swap_cand_dp, class, prev_ijlo, null_ijlo);
        IF prev_ijlo <> jmv$null_ijl_ordinal THEN
          jmp$get_ijle_p (prev_ijlo, prev_ijle_p);
          swap_cand_ijle_p^.swapin_candidate_queue := prev_ijle_p^.swapin_candidate_queue;
          prev_ijle_p^.swapin_candidate_queue := swap_cand_ijlo;
          jmv$swapin_candidate_queue [class].end_of_dp_q [swap_cand_dp] := swap_cand_ijlo;
        ELSE
          swap_cand_ijle_p^.swapin_candidate_queue := jmv$swapin_candidate_queue [class].
                swapin_candidate_queue;
          jmv$swapin_candidate_queue [class].swapin_candidate_queue := swap_cand_ijlo;
          jmv$swapin_candidate_queue [class].end_of_dp_q [swap_cand_dp] := swap_cand_ijlo;
        IFEND;
      ELSE
        jmp$get_ijle_p (end_ijlo, end_ijle_p);
        adjust_swapin_cand_prio (end_ijle_p, current_time);
        IF (end_ijle_p^.job_scheduler_data.guaranteed_service_remaining > swap_cand_ijle_p^.
              job_scheduler_data.guaranteed_service_remaining) OR
              ((end_ijle_p^.job_scheduler_data.guaranteed_service_remaining = swap_cand_ijle_p^.
              job_scheduler_data.guaranteed_service_remaining) AND (end_ijle_p^.
              job_scheduler_data.priority >= swap_cand_ijle_p^.job_scheduler_data.priority)) THEN
          swap_cand_ijle_p^.swapin_candidate_queue := end_ijle_p^.swapin_candidate_queue;
          end_ijle_p^.swapin_candidate_queue := swap_cand_ijlo;
          jmv$swapin_candidate_queue [class].end_of_dp_q [swap_cand_dp] := swap_cand_ijlo;
        ELSE
          find_end_of_higher_dp_q (swap_cand_dp, class, prev_ijlo, next_ijlo);

        /find_place_in_queue/
          WHILE next_ijlo <> end_ijlo DO
            jmp$get_ijle_p (next_ijlo, next_ijle_p);
            adjust_swapin_cand_prio (next_ijle_p, current_time);
            IF (swap_cand_ijle_p^.job_scheduler_data.guaranteed_service_remaining > next_ijle_p^.
                  job_scheduler_data.guaranteed_service_remaining) OR
                  ((swap_cand_ijle_p^.job_scheduler_data.guaranteed_service_remaining = next_ijle_p^.
                  job_scheduler_data.guaranteed_service_remaining) AND (swap_cand_ijle_p^.job_scheduler_data.
                  priority > next_ijle_p^.job_scheduler_data.priority)) THEN
              EXIT /find_place_in_queue/;
            IFEND;

            prev_ijlo := next_ijlo;
            next_ijlo := next_ijle_p^.swapin_candidate_queue;

          WHILEND /find_place_in_queue/;

{ Link the swapin candidate into the queue.

          IF prev_ijlo = jmv$null_ijl_ordinal THEN
            swap_cand_ijle_p^.swapin_candidate_queue := jmv$swapin_candidate_queue [class].
                  swapin_candidate_queue;
            jmv$swapin_candidate_queue [class].swapin_candidate_queue := swap_cand_ijlo;
          ELSE
            jmp$get_ijle_p (prev_ijlo, prev_ijle_p);
            prev_ijle_p^.swapin_candidate_queue := swap_cand_ijlo;
            swap_cand_ijle_p^.swapin_candidate_queue := next_ijlo;
          IFEND;
        IFEND;
      IFEND;
    END /insert/;

{ Increment the number of jobs in the queue.

    jmv$swapin_candidate_queue [class].number_of_jobs_in_queue :=
          jmv$swapin_candidate_queue [class].number_of_jobs_in_queue + 1;

    #KEYPOINT (osk$exit, 0, jmk$insert_swapin_candidate);

  PROCEND jmp$insert_swapin_candidate;

?? TITLE := '[XDCL, #GATE] jmp$perform_physical_swapout', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$perform_physical_swapout
    (    node: jmt$node,
         swapout_reason: jmt$swapout_reasons,
         class: jmt$service_class_index;
         memory_needed: mmt$page_frame_index;
     VAR status: ost$status);

    VAR
      ajl_ord: jmt$ajl_ordinal,
      count: jmt$ajl_ordinal,
      ijl_ord: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      new_total_swapped_jobs: integer,
      service_table_p: ^jmt$service_class_attributes;

    status.normal := TRUE;

    ijl_ord := node.ijl_ord;
    jmp$get_ijle_p (ijl_ord, ijle_p);
    ajl_ord := ijle_p^.ajl_ordinal;

    IF (jmv$ajl_p^ [ajl_ord].in_use = 0) OR (ajl_ord = jmv$system_ajl_ordinal) THEN
      osp$set_status_abnormal ('JM', jme$swapping_not_allowed, 'Swapping non existent or system job', status);
      RETURN;
    IFEND;

    CASE ijle_p^.entry_status OF
    = jmc$ies_entry_free, jmc$ies_job_swapped =
      osp$set_status_abnormal ('JM', jme$job_cant_be_swapped, 'ijl entry status prevents swapout', status);
      RETURN;
    = jmc$ies_job_in_memory_non_swap =
      osp$set_status_abnormal ('JM', jme$job_status_non_swappable, 'ijl status non swappable', status);
      RETURN;
    ELSE
    CASEND;

    jsp$swap_job_out (ijl_ord, swapout_reason, memory_needed, status);
    IF NOT status.normal THEN
      IF status.condition = jse$unimplemented_subfunction THEN
        osp$system_error ('Unimplemented swapout subfunction', ^status);
      IFEND;
      RETURN;
    IFEND;

    service_table_p := ^jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.attributes;
    ijle_p^.job_scheduler_data.unaged_swap_queue_priority := service_table_p^.scheduling_priority.minimum;
    ijle_p^.job_scheduler_data.priority := service_table_p^.scheduling_priority.minimum;
    IF service_table_p^.guaranteed_service_quantum = jmc$unlimited_service_accum THEN
      ijle_p^.job_scheduler_data.guaranteed_service_remaining := jmc$unlimited_service_accum;
    ELSEIF ijle_p^.job_scheduler_data.service_accumulator_since_swap <
          service_table_p^.guaranteed_service_quantum THEN
      ijle_p^.job_scheduler_data.guaranteed_service_remaining := service_table_p^.guaranteed_service_quantum -
            ijle_p^.job_scheduler_data.service_accumulator_since_swap;
    IFEND;

    IF swapout_reason = jmc$sr_lower_priority THEN
      jmp$incr_scheduler_statistics (jmc$lower_prio_swap_count);
    IFEND;

  PROCEND jmp$perform_physical_swapout;

?? TITLE := 'jmp$process_damaged_jobs', EJECT ??

{ PURPOSE:
{   This procedure scans the IJL to find jobs with the job_damaged_during_recovery field set, and
{   change their entry status so they can never swap in.
{ DESIGN:
{   If the swapout request gets back a status that the job is in a ready task state, the event is reset.
{   Scheduler's event processing loop (in ring 3) will process the ready task list, and the next time
{   through this procedure the job will no longer be in the ready task entry status.

  PROCEDURE [XDCL, #GATE] jmp$process_damaged_jobs;

    VAR
      ijl_bn: jmt$ijl_block_number,
      ijl_bi: jmt$ijl_block_index,
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      status: ost$status;

    jmp$clear_scheduler_event (jmc$recovery_job_damaged);

    FOR ijl_bn := LOWERBOUND (jmv$ijl_p.block_p^) TO jmv$ijl_p.max_block_in_use DO
      IF jmv$ijl_p.block_p^ [ijl_bn].index_p <> NIL THEN
        FOR ijl_bi := LOWERVALUE (jmt$ijl_block_index) TO UPPERVALUE (jmt$ijl_block_index) DO
          ijl_ordinal.block_number := ijl_bn;
          ijl_ordinal.block_index := ijl_bi;
          jmp$get_ijle_p (ijl_ordinal, ijle_p);
          IF ijle_p^.entry_status <> jmc$ies_entry_free THEN
            IF (ijle_p^.job_damaged_during_recovery) AND (ijle_p^.entry_status <> jmc$ies_job_damaged) THEN
              jmp$special_job_swapout (ijl_ordinal, ijle_p, jmc$sr_job_damaged, status);
              IF NOT status.normal THEN
                IF status.condition = jme$job_in_ready_task_state THEN
                  jmv$job_scheduler_event [jmc$recovery_job_damaged] := TRUE;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        FOREND;
      IFEND;
    FOREND;

  PROCEND jmp$process_damaged_jobs;

?? TITLE := '[XDCL, #GATE] jmp$process_operator_requests', EJECT ??

{ PURPOSE:
{   This procedure is called by the job scheduler to process operator request events
{     in the service class table:
{       swapin_job,
{       swapout_job,
{       change_dispatching_priority.
{   If the swapout_job request gets back a status that the job is in a ready task state,
{   the job is left in the operator request list and the event is reset.  Scheduler's event
{   processing loop (in ring 3) will process the ready task list, and the next time through
{   this procedure the job will no longer be in the ready task entry status.
{   Note:  There is no need for an interlock of the jmv$operator_request_list table since
{         the 'in_use' field is cleared at the end of the processing.

  PROCEDURE [XDCL, #GATE] jmp$process_operator_requests
    (VAR status: ost$status);

    VAR
      dispatching_control_info: jmt$dispatching_control_info,
      ijle_p: ^jmt$initiated_job_list_entry,
      i: jmt$request_list_index,
      time: jmt$clock_time;

    status.normal := TRUE;

  /process_operator_requests/
    FOR i := LOWERBOUND (jmv$operator_request_list.request_list)
          TO UPPERBOUND (jmv$operator_request_list.request_list) DO
      IF jmv$operator_request_list.request_list [i].in_use THEN
        CASE jmv$operator_request_list.request_list [i].operator_request OF

        = jmc$or_swapout =
          jmp$sched_swapout_job (jmv$operator_request_list.request_list [i].ijl_ordinal,
                jmv$operator_request_list.request_list [i].system_supplied_name, status);
          IF NOT status.normal THEN
            IF status.condition = jme$job_in_ready_task_state THEN
              jmv$job_scheduler_event [jmc$process_operator_request] := TRUE;
              status.normal := TRUE;
              CYCLE /process_operator_requests/;
            IFEND;
          IFEND;

        = jmc$or_swapin =
          jmp$sched_swapin_job (jmv$operator_request_list.request_list [i].ijl_ordinal,
                jmv$operator_request_list.request_list [i].system_supplied_name, status);

        = jmc$or_change_dispatching_prio =
          dispatching_control_info.dispatching_priority := jmv$operator_request_list.request_list [i].
                dispatching_priority;
          jmp$change_dispatching_prior_r1 (tmc$cpo_operator,
                jmv$operator_request_list.request_list [i].ijl_ordinal,
                jmv$operator_request_list.request_list [i].system_supplied_name, dispatching_control_info,
                status);
          jmp$get_ijle_p (jmv$operator_request_list.request_list [i].ijl_ordinal, ijle_p);
          IF ijle_p^.entry_status = jmc$ies_swapin_candidate THEN
            jmp$delete_swapin_candidate (jmv$operator_request_list.request_list [i].ijl_ordinal,
                  ijle_p^.job_scheduler_data.service_class);
            time := #FREE_RUNNING_CLOCK (0);
            jmp$insert_swapin_candidate (jmv$operator_request_list.request_list [i].ijl_ordinal, time);
          IFEND;
        ELSE

        CASEND;

        jmv$operator_request_list.request_list [i].in_use := FALSE;

        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND /process_operator_requests/;

  PROCEND jmp$process_operator_requests;
?? TITLE := '[XDCL, #GATE] jmp$process_subsyst_prio_change', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to scan the swapin candidate queues to
{   find jobs that have had their scheduling dispatching priority changed
{   because of subsystem locks.
{ DESIGN:
{   Clear the event, copy the set of queues to consider, then process the queues.

  PROCEDURE [XDCL, #GATE] jmp$process_subsyst_prio_change;

    VAR
      head: jmt$ijl_ordinal,
      ijlo: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      last_ijle_p: ^jmt$initiated_job_list_entry,
      next_ijlo: jmt$ijl_ordinal,
      service_class: jmt$service_class_index,
      time: jmt$clock_time;

    jmp$clear_scheduler_event (jmc$subsystem_priority_change);

    FOR service_class := jmc$system_service_class TO jmv$max_service_class_in_use DO
      IF jmv$subsystem_priority_changes [service_class] THEN
        jmv$subsystem_priority_changes [service_class] := FALSE;
        head := jmv$swapin_candidate_queue [service_class].swapin_candidate_queue;
        IF head <> jmv$null_ijl_ordinal THEN
          jmp$get_ijle_p (head, last_ijle_p);
          ijlo := last_ijle_p^.swapin_candidate_queue;
          WHILE ijlo <> jmv$null_ijl_ordinal DO
            jmp$get_ijle_p (ijlo, ijle_p);
            next_ijlo := ijle_p^.swapin_candidate_queue;
            IF ijle_p^.scheduling_dispatching_priority > last_ijle_p^.scheduling_dispatching_priority THEN
              jmp$delete_swapin_candidate (ijlo, service_class);
              time := #FREE_RUNNING_CLOCK (0);
              jmp$insert_swapin_candidate (ijlo, time);
            ELSE
              last_ijle_p := ijle_p;
            IFEND;
            ijlo := next_ijlo;
          WHILEND;
        IFEND;
      IFEND;
    FOREND;
  PROCEND jmp$process_subsyst_prio_change;

?? TITLE := '[XDCL, #GATE] jmp$process_terminated_job', EJECT ??

{ PURPOSE:
{   This procedure scans all IJL blocks with the terminated_jobs field set.  All jobs with entry status
{   of job terminating are removed from the IJL and queued files is called to cleanup the KJL entry.

  PROCEDURE [XDCL, #GATE] jmp$process_terminated_job;

    VAR
      class: jmt$service_class_index,
      job_class: jmt$job_class,
      ijl_p: ^jmt$initiated_job_list_entry,
      kjl_ord: jmt$kjl_index,
      ijl_bn: jmt$ijl_block_number,
      status: ost$status,
      ijl_bi: jmt$ijl_block_index,
      ijl_ord: jmt$ijl_ordinal;

    jmp$clear_scheduler_event (jmc$job_terminated);

    FOR ijl_bn := LOWERBOUND (jmv$ijl_p.block_p^) TO jmv$ijl_p.max_block_in_use DO
      IF (jmv$ijl_p.block_p^ [ijl_bn].index_p <> NIL) AND (jmv$ijl_p.block_p^ [ijl_bn].terminated_job) THEN

{ Clear the terminated job indicator, and then find all terminated jobs in the block.

        jmv$ijl_p.block_p^ [ijl_bn].terminated_job := FALSE;

      /index_loop/
        FOR ijl_bi := LOWERVALUE (jmt$ijl_block_index) TO UPPERVALUE (jmt$ijl_block_index) DO

{  Check if last time through this block was deleted by jmp$delete_ijl_entry.

          IF jmv$ijl_p.block_p^ [ijl_bn].index_p <> NIL THEN
            ijl_p := ^jmv$ijl_p.block_p^ [ijl_bn].index_p^ [ijl_bi];
            IF ijl_p^.entry_status = jmc$ies_job_terminating THEN
              kjl_ord := ijl_p^.kjl_ordinal;
              class := ijl_p^.job_scheduler_data.service_class;
              job_class := ijl_p^.job_scheduler_data.job_class;

              ijl_ord.block_number := ijl_bn;
              ijl_ord.block_index := ijl_bi;
              IF (class IN jmv$classes_in_maxaj_limit_wait) THEN
                jmp$set_class_below_maxaj_limit ($jmt$service_class_set [class]);
              IFEND;

              jmp$jm_change_ijl_entry_status (ijl_p, jmc$ies_entry_free);

              IF (ijl_p^.swap_queue_link.queue_id <> jsc$isqi_null) THEN
                osp$system_error ('JOB END WITH JOB IN SWAP QUEUE', ^status);
              IFEND;

              jmp$delete_ijl_entry (ijl_ord);

              jmp$notify_queued_files_job_end (kjl_ord);

{ If there are no longer any jobs in this class and the maximum working set for
{ this class was the working set ceiling, the global maximum needs to be reset.
{ Note that since the System Job is not considered in the value of
{ jmv$max_class_working_set, the check is for an initiated_jobs count of zero
{ if the job class is NOT the system_job_class and a count of 1 if the job
{ class is the system_job_class.

              IF (jmv$job_counts.job_class_counts [job_class].initiated_jobs =
                    $INTEGER (jmc$system_job_class = job_class)) AND
                    (jmv$job_class_table_p^ [job_class].maximum_working_set.maximum =
                    jmv$max_class_working_set) THEN
                jmp$reset_max_class_working_set;
              IFEND;

              IF (jmv$job_counts.initiated_jobs = 1) AND (gtid_of_task_waiting_for_idle.index > 0) THEN
                pmp$ready_task (gtid_of_task_waiting_for_idle, status);
                gtid_of_task_waiting_for_idle.index := 0;
              IFEND;
            IFEND;
          ELSE
            EXIT /index_loop/;
          IFEND;
        FOREND /index_loop/;
      IFEND;
    FOREND;

  PROCEND jmp$process_terminated_job;

?? TITLE := '[XDCL, #GATE] jmp$recover_swapin_jobs', EJECT ??

{ PURPOSE:
{   This procedure issues a monitor request to ready recovered jobs so that they get queued to swapin.

  PROCEDURE [XDCL, #GATE] jmp$recover_swapin_jobs;

    VAR
      request_block: jmt$rb_scheduler_requests;

    jmp$clear_scheduler_event (jmc$recovery_swapin);

    request_block.reqcode := syc$rc_job_scheduler_request;
    request_block.sub_reqcode := jmc$src_swapin_recovered_jobs;
    i#call_monitor (#LOC (request_block), #SIZE (request_block));

  PROCEND jmp$recover_swapin_jobs;

?? TITLE := '[XDCL, #GATE] jmp$queue_operator_request', EJECT ??

{ PURPOSE:
{   This procedure queues operator requests (swapin job, swapout job, change
{   dispatching control in the service class table) and sets a scheduler event.
{   Processing these requests must be synchronized by the scheduler.
{   The swapout job request can indicate that a job is not to be recovered
{   during a subsequent deadstart.

  PROCEDURE [XDCL, #GATE] jmp$queue_operator_request
    (    operator_request: jmt$operator_request;
         ijl_ordinal: jmt$ijl_ordinal;
         system_supplied_name: jmt$system_supplied_name;
         dispatching_priority: jmt$dispatching_priority;
         disable_recovery: boolean;
     VAR status: ost$status);

    VAR
      i: jmt$request_list_index,
      ijle_p: ^jmt$initiated_job_list_entry,
      service_class_name: jmt$service_class_name;

    status.normal := TRUE;

    osp$set_signature_lock (jmv$operator_request_list.lock, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /search_for_free_entry/

    FOR i := LOWERBOUND (jmv$operator_request_list.request_list)
          TO UPPERBOUND (jmv$operator_request_list.request_list) DO
      IF NOT jmv$operator_request_list.request_list [i].in_use THEN
        jmv$operator_request_list.request_list [i].ijl_ordinal := ijl_ordinal;
        jmv$operator_request_list.request_list [i].system_supplied_name := system_supplied_name;
        jmv$operator_request_list.request_list [i].operator_request := operator_request;
        jmv$operator_request_list.request_list [i].dispatching_priority := dispatching_priority;
        jmv$operator_request_list.request_list [i].in_use := TRUE;

{  Notify the scheduler that an operator request event has occurred.

        jmp$set_event_and_ready_sched (jmc$process_operator_request);

        jmp$get_ijle_p (ijl_ordinal, ijle_p);
        IF disable_recovery THEN
          ijle_p^.queue_file_information.job_abort_disposition := jmc$terminate_on_abort;
          ijle_p^.queue_file_information.job_recovery_disposition := jmc$terminate_on_recovery;
        IFEND;
        IF (operator_request = jmc$or_swapin) AND (jmv$service_classes
              [ijle_p^.job_scheduler_data.service_class]^.attributes.maximum_active_jobs = 0) THEN
          jmp$determine_serv_class_name (ijle_p^.job_scheduler_data.service_class, service_class_name,
                status);
          osp$set_status_abnormal ('JM', jme$swapin_with_maxaj_zero, service_class_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, system_supplied_name, status);
        IFEND;
        osp$clear_signature_lock (jmv$operator_request_list.lock, status);
        RETURN;
      IFEND;
    FOREND /search_for_free_entry/;

    osp$clear_signature_lock (jmv$operator_request_list.lock, status);
    osp$set_status_abnormal ('JM', jme$swap_buffer_full, 'Request cannot be processed now', status);

  PROCEND jmp$queue_operator_request;
?? TITLE := '[XDCL, #GATE] jmp$relink_to_end_of_swapin_q', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$relink_to_end_of_swapin_q
    (    ijl_ordinal: jmt$ijl_ordinal);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      status: ost$status,
      time: jmt$clock_time;

    jmp$get_ijle_p (ijl_ordinal, ijle_p);

    IF ijle_p^.entry_status = jmc$ies_swapin_candidate THEN
      jmp$delete_swapin_candidate (ijl_ordinal, ijle_p^.job_scheduler_data.service_class);
      ijle_p^.job_scheduler_data.unaged_swap_queue_priority := LOWERVALUE (jmt$job_priority);
      ijle_p^.job_scheduler_data.priority := LOWERVALUE (jmt$job_priority);
      time := #FREE_RUNNING_CLOCK (0);
      jmp$insert_swapin_candidate (ijl_ordinal, time);
    ELSE
      osp$system_error ('RELINK SWAPIN CANDIDATE NOT IN QUEUE', ^status);
    IFEND;

  PROCEND jmp$relink_to_end_of_swapin_q;

?? TITLE := '[XDCL] jmp$reorder_swapin_queues', EJECT ??

{ PURPOSE:
{   This procedure reorders the swapin candidate queue for job classes which have had dispatching
{   controls (dispatching priority) changed by operator command.
{ DESIGN:
{   All swapin candidates for changed classes are removed from the swapin candidate queue and
{   then re-inserted.  The insert procedure places jobs in the queue in order of priority.

  PROCEDURE [XDCL] jmp$reorder_swapin_queues
    (    class_set: jmt$service_class_set);

    VAR
      class: jmt$service_class_index,
      count: integer,
      index: integer,
      swapin_candidate_ijlos_p: ^array [1 .. * ] of jmt$ijl_ordinal,
      time: jmt$clock_time;

    PUSH swapin_candidate_ijlos_p: [1 .. jmv$job_counts.initiated_jobs];

    FOR class := jmc$system_service_class TO jmv$max_service_class_in_use DO
      IF class IN class_set THEN
        count := 0;
        WHILE jmv$swapin_candidate_queue [class].swapin_candidate_queue <> jmv$null_ijl_ordinal DO
          count := count + 1;
          swapin_candidate_ijlos_p^ [count] := jmv$swapin_candidate_queue [class].swapin_candidate_queue;
          jmp$delete_swapin_candidate (jmv$swapin_candidate_queue [class].swapin_candidate_queue, class);
        WHILEND;

        time := #FREE_RUNNING_CLOCK (0);
        FOR index := 1 TO count DO
          jmp$insert_swapin_candidate (swapin_candidate_ijlos_p^ [index], time);
        FOREND;
      IFEND;
    FOREND;

  PROCEND jmp$reorder_swapin_queues;

?? TITLE := '[XDCL, #GATE] jmp$reset_activate_event', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$reset_activate_event;

    VAR
      any_swapped: boolean,
      any_queued: boolean,
      job_class: jmt$job_class,
      sc_ijle_p: ^jmt$initiated_job_list_entry,
      service_class: jmt$service_class_index;

    any_queued := FALSE;
    any_swapped := FALSE;

  /queued_job_count/

    FOR job_class := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
      IF (jmv$candidate_queued_jobs [job_class].candidate_available) AND
            NOT (jmv$job_class_table_p^ [job_class].initial_service_class_index IN
            jmv$classes_in_maxaj_limit_wait) AND (NOT jmv$idle_dispatching_controls.
            controls [jmv$service_classes [jmv$job_class_table_p^ [job_class].initial_service_class_index]^.
            attributes.dispatching_control [jmc$min_dispatching_control].dispatching_priority].blocked) THEN
        any_queued := TRUE;
      IFEND;
    FOREND /queued_job_count/;

  /swapped_job_count/

    FOR service_class := jmc$system_service_class TO jmv$max_service_class_in_use DO
      IF (jmv$swapin_candidate_queue [service_class].swapin_candidate_queue <> jmv$null_ijl_ordinal) AND
            NOT (service_class IN jmv$classes_in_maxaj_limit_wait) THEN
        jmp$get_ijle_p (jmv$swapin_candidate_queue [service_class].swapin_candidate_queue, sc_ijle_p);
        IF NOT jmv$idle_dispatching_controls.controls [sc_ijle_p^.scheduling_dispatching_priority].
              blocked THEN
          any_swapped := TRUE;
        IFEND;
      IFEND;
    FOREND /swapped_job_count/;

    IF any_queued THEN
      jmv$job_scheduler_event [jmc$examine_input_queue] := TRUE;
    IFEND;

    IF any_swapped THEN
      jmv$job_scheduler_event [jmc$examine_swapin_queue] := TRUE;
    IFEND;

  PROCEND jmp$reset_activate_event;

?? TITLE := '[XDCL, #GATE] jmp$reset_activate_events_sels', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$reset_activate_events_sels;

    jmv$job_scheduler_event [jmc$scheduler_wake_time] := FALSE;
    jmv$job_scheduler_event [jmc$needed_memory_available] := FALSE;
    jmv$job_scheduler_event [jmc$needed_ajlo_available] := FALSE;

    jmv$job_sched_events_selected [jmc$scheduler_wake_time] := FALSE;
    jmv$job_sched_events_selected [jmc$needed_memory_available] := FALSE;
    jmv$job_sched_events_selected [jmc$needed_ajlo_available] := FALSE;

    jmv$job_scheduler_event [jmc$examine_input_queue] := FALSE;
    jmv$job_scheduler_event [jmc$examine_swapin_queue] := FALSE;
    jmv$job_sched_events_selected [jmc$examine_input_queue] := TRUE;
    jmv$job_sched_events_selected [jmc$examine_swapin_queue] := TRUE;

    jmv$classes_in_resource_wait := $jmt$service_class_set [];
    jmv$memory_needed_by_scheduler := 0;
    jmv$time_to_wake_scheduler := jmv$sched_service_calc_time;

  PROCEND jmp$reset_activate_events_sels;

?? TITLE := '[XDCL, #GATE] jmp$reset_advance_lw_swaps', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$reset_advance_lw_swaps
    (VAR memory_flushed_from_lw_queue: mmt$page_frame_index);

    VAR
      dp: jmc$lowest_dispatching_priority .. jmc$highest_dispatch_priority,
      job_class: jmt$job_class,
      next_ijle_p: ^jmt$initiated_job_list_entry,
      next_ijlo: jmt$ijl_ordinal,
      number_to_maxaj_p: ^array [1 .. * ] of integer,
      pages_needed: jmt$long_wait_swap_threshold,
      service_class: jmt$service_class_index,
      status: ost$status;

    FOR dp := jmc$lowest_dispatching_priority TO jmc$highest_dispatch_priority DO
      pages_needed [dp] := 0;
    FOREND;

    PUSH number_to_maxaj_p: [jmc$system_service_class .. jmv$max_service_class_in_use];

{ Determine the total number of pages that job mode scheduler needs to swapin or initiate all
{ swapin or initiation candidates (exclude the working sets of jobs belonging to a class that
{ has reached the maximum active job limit).

    FOR service_class := jmc$system_service_class TO jmv$max_service_class_in_use DO
      IF jmv$service_classes [service_class] <> NIL THEN
        number_to_maxaj_p^ [service_class] := jmv$service_classes [service_class]^.attributes.
              maximum_active_jobs - (jmv$job_counts.service_class_counts [service_class].
              scheduler_initiated_jobs - jmv$job_counts.service_class_counts [service_class].swapped_jobs);
        IF (jmv$swapin_candidate_queue [service_class].swapin_candidate_queue <> jmv$null_ijl_ordinal) THEN
          next_ijlo := jmv$swapin_candidate_queue [service_class].swapin_candidate_queue;
          WHILE (number_to_maxaj_p^ [service_class] > 0) AND (next_ijlo <> jmv$null_ijl_ordinal) DO
            jmp$get_ijle_p (next_ijlo, next_ijle_p);
            IF next_ijle_p^.scheduling_dispatching_priority > jmc$highest_dispatch_priority THEN
              dp := jmc$highest_dispatch_priority;
            ELSE
              dp := next_ijle_p^.scheduling_dispatching_priority;
            IFEND;
            pages_needed [dp] := pages_needed [dp] + next_ijle_p^.swap_data.swapped_job_page_count +
                  next_ijle_p^.memory_reserve_request.requested_page_count;
            number_to_maxaj_p^ [service_class] := number_to_maxaj_p^ [service_class] - 1;
            next_ijlo := next_ijle_p^.swapin_candidate_queue;
          WHILEND;
        IFEND;
      IFEND;
    FOREND;

    FOR job_class := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
      IF (jmv$candidate_queued_jobs [job_class].candidate_available) THEN
        service_class := jmv$job_class_table_p^ [job_class].initial_service_class_index;
        dp := jmv$service_classes [service_class]^.attributes.dispatching_control
              [jmc$min_dispatching_control].dispatching_priority;
        IF number_to_maxaj_p^ [service_class] > 0 THEN
          pages_needed [dp] := pages_needed [dp] + jmv$job_class_table_p^ [job_class].initial_working_set;
          number_to_maxaj_p^ [service_class] := number_to_maxaj_p^ [service_class] - 1;
        IFEND;
      IFEND;
    FOREND;

{ Accumulate downward through the array.  The threshold is the number of pages needed to swapin jobs of equal
{ or higher priority.  If the actual number of pages needed is less than mmv$min_avail_pages, then the
{ threshold is mmv$min_avail_pages.

    FOR dp := jmc$highest_dispatch_priority - 1 DOWNTO jmc$lowest_dispatching_priority DO
      pages_needed [dp] := pages_needed [dp + 1] + pages_needed [dp];
      IF ((pages_needed [dp + 1]) + mmv$resident_job_target) > mmv$min_avail_pages THEN
        jmv$long_wait_swap_threshold [dp +1] := pages_needed [dp + 1] + mmv$resident_job_target;
      ELSE
        jmv$long_wait_swap_threshold [dp + 1] := mmv$min_avail_pages;
      IFEND;
    FOREND;
    IF (pages_needed [jmc$lowest_dispatching_priority] + mmv$resident_job_target) > mmv$min_avail_pages THEN
      jmv$long_wait_swap_threshold [jmc$lowest_dispatching_priority] :=
            pages_needed [jmc$lowest_dispatching_priority] + mmv$resident_job_target;
    ELSE
      jmv$long_wait_swap_threshold [jmc$lowest_dispatching_priority] := mmv$min_avail_pages;
    IFEND;

    IF ((mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon) <
          pages_needed [jmc$lowest_dispatching_priority]) AND
          (mmv$reassignable_page_frames.swapout_io_not_initiated > 0) THEN
      jsp$advance_long_wait_jobs (FALSE {flush_all_pages}, memory_flushed_from_lw_queue);
      jmp$incr_scheduler_statistics (jmc$called_advance_lw_job);
    IFEND;

  PROCEND jmp$reset_advance_lw_swaps;

?? TITLE := '[XDCL, #GATE] jmp$reset_ijl_search_block', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$reset_ijl_search_block
    (    ijl_block_number: jmt$ijl_block_number);

{  This procedure is called by a ring 2 procedure to modify a ring 1 variable.

    jmv$ijl_p.start_search_block := ijl_block_number;

  PROCEND jmp$reset_ijl_search_block;

?? TITLE := '[XDCL, #GATE] jmp$reset_time_to_wake_sched', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$reset_time_to_wake_sched;

    jmv$time_to_wake_scheduler := #FREE_RUNNING_CLOCK (0) + 10000000;

  PROCEND jmp$reset_time_to_wake_sched;

?? TITLE := '[XDCL, #GATE] jmp$restore_job_environment', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$restore_job_environment
    (    node: jmt$node;
     VAR status: ost$status);

    VAR
      class: jmt$service_class_index,
      ijl_p: ^jmt$initiated_job_list_entry;

    #KEYPOINT (osk$entry, 0, jmk$restore_job_environment);

    status.normal := TRUE;
    jmp$get_ijle_p (node.ijl_ord, ijl_p);
    class := ijl_p^.job_scheduler_data.service_class;

    IF (ijl_p^.entry_status <> jmc$ies_swapin_candidate) THEN
      osp$system_error ('SWAPIN FREE IJL ENTRY', ^status);
    IFEND;

    jsp$swap_job_in (node.ijl_ord, status);

    jmp$delete_swapin_candidate (node.ijl_ord, class);

{ If the job was swapped out with service remaining (ie, it was preempted before reaching guaranteed
{ service), it was swapped back in ahead of other jobs.  Do not zero out service_accumulator_since_swap--
{ the job must become a preemption candidate again when it uses its guaranteed service allotment.

    IF ijl_p^.job_scheduler_data.guaranteed_service_remaining = 0 THEN
      ijl_p^.job_scheduler_data.service_accumulator_since_swap := 0;
    IFEND;
    ijl_p^.job_scheduler_data.guaranteed_service_remaining := 0;
    ijl_p^.job_scheduler_data.priority := jmv$service_classes [class]^.attributes.scheduling_priority.maximum;

    #KEYPOINT (osk$exit, 0, jmk$restore_job_environment);

  PROCEND jmp$restore_job_environment;

?? TITLE := '[XDCL, #GATE] jmp$resume_activation_of_jobs', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$resume_activation_of_jobs;

    VAR
      dp: jmc$lowest_dispatching_priority .. jmc$highest_dispatch_priority,
      status: ost$status;

    FOR dp := jmc$lowest_dispatching_priority TO jmc$highest_dispatch_priority DO
      jmv$long_wait_swap_threshold [dp] := mmv$min_avail_pages;
    FOREND;
    jmv$prevent_activation_of_jobs := FALSE;
    jmv$all_jobs_swapped_for_idling := FALSE;
    jmv$refresh_job_candidates := TRUE;
    jmv$job_scheduler_event [jmc$examine_swapin_queue] := TRUE;
    jmv$job_scheduler_event [jmc$examine_input_queue] := TRUE;
    jmv$job_sched_events_selected [jmc$examine_input_queue] := TRUE;
    jmv$job_sched_events_selected [jmc$examine_swapin_queue] := TRUE;
    jmv$refresh_job_candidates := TRUE;

    tmp$ready_system_task (tmc$stid_job_scheduler, status);

  PROCEND jmp$resume_activation_of_jobs;

?? TITLE := '[XDCL, #GATE] jmp$scan_ajl_for_service', EJECT ??

{ PURPOSE:
{   This procedure scans the ajl and calls the procedure which calculates service for all active jobs.

  PROCEDURE [XDCL, #GATE] jmp$scan_ajl_for_service;

    VAR
      ajlo: jmt$ajl_ordinal,
      class: jmt$service_class_index,
      ijle_p: ^jmt$initiated_job_list_entry,
      ijlo: jmt$ijl_ordinal,
      service_used: integer;

  /search_for_job/
    FOR ajlo := LOWERBOUND (jmv$ajl_p^) TO jmv$max_ajl_ordinal_in_use DO
      IF (jmv$ajl_p^ [ajlo].in_use <> 0) AND (ajlo <> jmv$system_ajl_ordinal) THEN
        ijlo := jmv$ajl_p^ [ajlo].ijl_ordinal;
        jmp$get_ijle_p (ijlo, ijle_p);
        IF (ijle_p^.ajl_ordinal = ajlo) AND (ijle_p^.swap_status = jmc$iss_executing) THEN
          jmp$calculate_service (ijle_p, service_used);
          adjust_active_job_priority (ijle_p, service_used);
        IFEND;
      IFEND;
    FOREND /search_for_job/;

    jmv$last_service_calc_time := #FREE_RUNNING_CLOCK (0);

{ Clear out the set of service classes which are not being considered for activation because
{ the service class has reached the maximum active job limit; now that service accumulations
{ and priorities have changed for the active jobs, one of them may be preemptable.

    IF jmv$classes_in_maxaj_limit_wait <> $jmt$service_class_set [] THEN
      jmv$classes_in_maxaj_limit_wait := $jmt$service_class_set [];
      jmv$job_scheduler_event [jmc$examine_input_queue] := TRUE;
      jmv$job_scheduler_event [jmc$examine_swapin_queue] := TRUE;
    IFEND;

  PROCEND jmp$scan_ajl_for_service;

?? TITLE := '[XDCL, #GATE] jmp$sched_swapin_job', EJECT ??

{ PURPOSE:
{   This procedure processes swapin requests from the operator request list.
{ DESIGN:
{   Issue a monitor request to swapin the job ONLY if the entry status is operator force out.
{  *** This could be made more tolerant, so that 'lost' jobs (which would represent
{   a bug) could be swapped in with an operator request.

  PROCEDURE [XDCL, #GATE] jmp$sched_swapin_job
    (    ijl_ordinal: jmt$ijl_ordinal;
         system_supplied_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      ijl_p: ^jmt$initiated_job_list_entry,
      request_block: jmt$rb_scheduler_requests,
      time: jmt$clock_time;

    status.normal := TRUE;

    IF (ijl_ordinal = jmv$system_ijl_ordinal) THEN
      osp$set_status_abnormal ('JM', jme$swapping_not_allowed, 'SWAPPING THE SYSTEM JOB NOT ALLOWED', status);
      RETURN;
    IFEND;

    jmp$get_ijle_p (ijl_ordinal, ijl_p);

    IF ijl_p^.system_supplied_name = system_supplied_name THEN
      CASE ijl_p^.entry_status OF
      = jmc$ies_operator_force_out =

{ Issue a monitor request to change the entry status of the job and swap the job in if it has
{ ready tasks.  This must be done in monitor to prevent timing problems checking the ready task count.

        request_block.reqcode := syc$rc_job_scheduler_request;
        request_block.sub_reqcode := jmc$src_operator_swap_in;
        request_block.ijl_ordinal := ijl_ordinal;
        i#call_monitor (#LOC (request_block), #SIZE (request_block));
      = jmc$ies_swapin_candidate =

{ If the job is already a swapin candidate then take the job out of the swapin queue, give
{ it the highest priority, and put it back in the swapin queue (highest priority will ensure
{ that it is placed at the head of the queue).  Because the job is already marked as a swapin
{ candidate, monitor mode will not try to swap the job in if a task goes ready.

        jmp$delete_swapin_candidate (ijl_ordinal, ijl_p^.job_scheduler_data.service_class);
        ijl_p^.job_scheduler_data.unaged_swap_queue_priority := UPPERVALUE (jmt$job_priority);
        ijl_p^.job_scheduler_data.priority := UPPERVALUE (jmt$job_priority);
        time := #FREE_RUNNING_CLOCK (0);
        jmp$insert_swapin_candidate (ijl_ordinal, time);

      = jmc$ies_system_force_out, jmc$ies_job_damaged =
        osp$set_status_abnormal ('JM', jme$job_dead_cannot_swap, 'JOB IS DEAD--CANNOT SWAPIN', status);

      = jmc$ies_job_swapped =
        osp$set_status_abnormal ('JM', jme$job_has_no_ready_tasks, 'JOB HAS NO READY TASKS--WILL NOT SWAPIN',
              status);

      = jmc$ies_entry_free =
        osp$system_error ('SWAPIN FREE IJL ENTRY', ^status);

      ELSE
        osp$set_status_abnormal ('JM', jme$job_in_memory_or_swapin, 'JOB IN MEMORY OR SWAPPING IN', status);
      CASEND;

    ELSE
      osp$set_status_abnormal ('JM', jme$job_not_in_swap_list, 'CANT FIND SWAPPED JOB', status);
    IFEND;

  PROCEND jmp$sched_swapin_job;

?? TITLE := 'jmp$sched_swapout_job ', EJECT ??

{ PURPOSE:
{   This procedure is executed by the JOB SCHEDULER task to process an operator swapout of a job.
{ DESIGN:
{   If the job is currently a swapin candidate, then the job scheduler task can change the job's
{   entry status here in job mode because only job mode scheduler does anything with swapin candidates.
{   If a job is non-swappable or terminating, an error status is returned.
{   All other statuses must be processed (checked and changed) in monitor with the PTL lock set to prevent
{   timing problems.

  PROCEDURE jmp$sched_swapout_job
    (    ijl_ordinal: jmt$ijl_ordinal;
         system_supplied_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      class: jmt$service_class_index,
      ijl_p: ^jmt$initiated_job_list_entry;

    status.normal := TRUE;

    IF ijl_ordinal = jmv$system_ijl_ordinal THEN
      osp$set_status_abnormal ('JM', jme$swapping_not_allowed, 'SWAPPING THE SYSTEM JOB NOT ALLOWED', status);
      RETURN;
    IFEND;

    jmp$get_ijle_p (ijl_ordinal, ijl_p);

    IF ijl_p^.system_supplied_name = system_supplied_name THEN
      jmp$special_job_swapout (ijl_ordinal, ijl_p, jmc$sr_operator_request, status);
    ELSE
      osp$set_status_abnormal ('JM', jme$non_existent_job, 'NO MATCH FOR JOB NAME GIVEN', status);
    IFEND;

  PROCEND jmp$sched_swapout_job;

?? TITLE := 'jmp$select_job_for_thrashing', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$select_job_for_thrashing
    (VAR node: jmt$node;
     VAR class: jmt$service_class_index;
     VAR ws: integer;
     VAR done: boolean);

{
{ PURPOSE:
{ To select a candidate to swap because thrashing is occurring.

{ NOTE:
{ start ajl search at one to avoid considering system job.
{ dont consider possibility of zero ws in ajls.
{

    VAR
      ajl_index: jmt$ajl_ordinal,
      first_max_prio: jmt$job_priority,
      first_pick,
      second_pick,
      third_pick: boolean,
      max_delta_serv: integer,
      delta_serv: integer,
      max_delta_ws: integer,
      delta_cand: jmt$ijl_ordinal,
      serv_cand: jmt$ijl_ordinal,
      first_cand: jmt$ijl_ordinal,
      first_ws: integer,
      local_class: jmt$service_class_index,
      guaranteed_service: integer,
      max_serv_ws: integer,
      max_ws: integer,
      ajl_p: ^jmt$active_job_list_entry,
      cp_time: integer,
      ijl_ord: jmt$ijl_ordinal,
      ijl_p: ^jmt$initiated_job_list_entry,
      cp_time_used_this_period: integer,
      candidate: jmt$ijl_ordinal,
      job_priority: jmt$job_priority,
      i: mmt$job_page_queue_index,
      working_set_size: 0 .. osc$max_page_frames,
      max_job_priority: jmt$job_priority;

    done := FALSE;
    first_pick := FALSE;
    second_pick := FALSE;
    third_pick := FALSE;
    max_delta_serv := UPPERVALUE (integer);
    max_delta_ws := 0;
    max_job_priority := UPPERVALUE (jmt$job_priority);
    max_ws := 0;
    first_max_prio := UPPERVALUE (jmt$job_priority);

  /scan_for_swapout_candidate/

    FOR ajl_index := LOWERBOUND (jmv$ajl_p^) TO jmv$max_ajl_ordinal_in_use DO

      ajl_p := ^jmv$ajl_p^ [ajl_index];
      IF (ajl_p^.in_use <> 0) AND (ajl_index <> jmv$system_ajl_ordinal) THEN

        ijl_ord := ajl_p^.ijl_ordinal;
        jmp$get_ijle_p (ijl_ord, ijl_p);
        IF (ijl_p^.ajl_ordinal = ajl_index) AND (ijl_p^.entry_status = jmc$ies_job_in_memory) THEN

          jmp$compute_total_memory_used (ijl_p, working_set_size);
          cp_time := (ijl_p^.statistics.cp_time.time_spent_in_job_mode +
                ijl_p^.statistics.cp_time.time_spent_in_mtr_mode);
          cp_time_used_this_period := cp_time - ijl_p^.job_scheduler_data.last_cptime;
          IF ajl_p^.job_is_good_swap_candidate OR (cp_time_used_this_period = 0) THEN
            IF ijl_p^.job_scheduler_data.priority < first_max_prio THEN
              first_cand := ijl_ord;
              first_ws := working_set_size;
              first_max_prio := ijl_p^.job_scheduler_data.priority;
              first_pick := TRUE;
            IFEND;
          ELSE
            local_class := ijl_p^.job_scheduler_data.service_class;
            guaranteed_service := jmv$service_classes [local_class]^.attributes.guaranteed_service_quantum;
            IF ijl_p^.job_scheduler_data.service_accumulator_since_swap > guaranteed_service THEN
              job_priority := ijl_p^.job_scheduler_data.priority;
              IF job_priority < max_job_priority THEN
                serv_cand := ijl_ord;
                max_job_priority := job_priority;
                max_serv_ws := working_set_size;
                second_pick := TRUE;
              IFEND;
            ELSE
              delta_serv := guaranteed_service - ijl_p^.job_scheduler_data.service_accumulator_since_swap;
              IF delta_serv <= max_delta_serv THEN
                IF working_set_size > max_delta_ws THEN
                  delta_cand := ijl_ord;
                  max_delta_serv := delta_serv;
                  max_delta_ws := working_set_size;
                  third_pick := TRUE;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    FOREND /scan_for_swapout_candidate/;

    IF first_pick THEN
      candidate := first_cand;
      max_ws := first_ws;
    ELSEIF second_pick THEN
      candidate := serv_cand;
      max_ws := max_serv_ws;
    ELSEIF third_pick THEN
      candidate := delta_cand;
      max_ws := max_delta_ws;
    ELSE
      done := TRUE;
      RETURN;
    IFEND;

    jmp$get_ijle_p (candidate, ijl_p);
    node.qtype := active;
    node.priority := ijl_p^.job_scheduler_data.priority;
    node.ijl_ord := candidate;
    node.ws := max_ws;
    class := ijl_p^.job_scheduler_data.service_class;
    ws := max_ws;

  PROCEND jmp$select_job_for_thrashing;

?? TITLE := '[XDCL, #GATE] jmp$select_sched_memory_event', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$select_sched_memory_event
    (    ws: mmt$page_frame_index;
         class: jmt$service_class_index);

    VAR
      needed_memory: integer;

    needed_memory := ws + mmv$resident_job_target + jmv$sched_memory_wait_factor;

    IF (jmv$memory_needed_by_scheduler = 0) OR (jmv$memory_needed_by_scheduler > needed_memory) THEN
      jmv$memory_needed_by_scheduler := needed_memory;
    IFEND;
    jmv$job_sched_events_selected [jmc$needed_memory_available] := TRUE;
    jmv$job_sched_events_selected [jmc$examine_input_queue] := FALSE;
    jmv$job_sched_events_selected [jmc$examine_swapin_queue] := FALSE;
    jmv$classes_in_resource_wait := jmv$classes_in_resource_wait + $jmt$service_class_set [class];

  PROCEND jmp$select_sched_memory_event;

?? TITLE := '[XDCL, #GATE] jmp$select_sched_service_wait', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$select_sched_service_wait;

    jmv$time_to_wake_scheduler := jmv$sched_service_calc_time;
    jmv$job_sched_events_selected [jmc$scheduler_wake_time] := TRUE;

  PROCEND jmp$select_sched_service_wait;

?? TITLE := '[XDCL, #GATE] jmp$select_scheduler_short_wait', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$select_scheduler_short_wait;

    jmv$time_to_wake_scheduler := #FREE_RUNNING_CLOCK (0) + 500000;
    jmv$job_sched_events_selected [jmc$scheduler_wake_time] := TRUE;
    jmv$job_sched_events_selected [jmc$examine_input_queue] := FALSE;
    jmv$job_sched_events_selected [jmc$examine_swapin_queue] := FALSE;

  PROCEND jmp$select_scheduler_short_wait;

?? TITLE := '[XDCL, #GATE] jmp$select_scheduler_ajlo_event', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$select_scheduler_ajlo_event
    (    class: jmt$service_class_index);

    jmv$job_sched_events_selected [jmc$needed_ajlo_available] := TRUE;
    jmv$job_sched_events_selected [jmc$examine_input_queue] := FALSE;
    jmv$job_sched_events_selected [jmc$examine_swapin_queue] := FALSE;
    jmv$classes_in_resource_wait := jmv$classes_in_resource_wait + $jmt$service_class_set [class];

  PROCEND jmp$select_scheduler_ajlo_event;

?? TITLE := '[XDCL, #GATE] jmp$set_all_jobs_swapped_var', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$set_all_jobs_swapped_var;

    jmv$all_jobs_swapped_for_idling := TRUE;

  PROCEND jmp$set_all_jobs_swapped_var;

?? TITLE := '[XDCL] jmp$set_class_below_maxaj_limit', EJECT ??

  PROCEDURE [XDCL] jmp$set_class_below_maxaj_limit
    (    service_class_set: jmt$service_class_set);

    VAR
      status: ost$status;

    jmv$classes_in_maxaj_limit_wait := jmv$classes_in_maxaj_limit_wait - service_class_set;
    jmv$job_scheduler_event [jmc$scheduler_wake_time] := TRUE;
    jmv$job_scheduler_event [jmc$examine_input_queue] := TRUE;
    jmv$job_scheduler_event [jmc$examine_swapin_queue] := TRUE;
    tmp$ready_system_task (tmc$stid_job_scheduler, status);

  PROCEND jmp$set_class_below_maxaj_limit;

?? TITLE := '[XDCL, #GATE] jmp$set_event_and_ready_sched', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$set_event_and_ready_sched
    (    event: jmt$job_scheduler_events);

    VAR
      status: ost$status;

    IF NOT jmv$job_scheduler_event [event] THEN
      jmv$job_scheduler_event [event] := TRUE;
      IF jmv$job_sched_events_selected [event] THEN
        tmp$ready_system_task (tmc$stid_job_scheduler, status);
      IFEND;
    IFEND;

  PROCEND jmp$set_event_and_ready_sched;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$set_examine_input_event', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$set_examine_input_event;
    jmv$job_scheduler_event [jmc$examine_input_queue] := TRUE;
    jmv$job_sched_events_selected [jmc$examine_input_queue] := TRUE;
    jmv$refresh_job_candidates := TRUE;
  PROCEND jmp$set_examine_input_event;

?? OLDTITLE ??
?? TITLE := '[XDCL] jmp$set_examine_queue_event', EJECT ??

  PROCEDURE [XDCL] jmp$set_examine_queue_event
    (    event: jmt$job_scheduler_events;
         job_class: jmt$job_class;
         unconditional: boolean);

    VAR
      service_class: jmt$service_class_index,
      status: ost$status;

    IF unconditional THEN
      jmv$job_scheduler_event [event] := TRUE;
      jmv$job_sched_events_selected [event] := TRUE;
      tmp$ready_system_task (tmc$stid_job_scheduler, status);
    ELSE
      service_class := jmv$job_class_table_p^ [job_class].initial_service_class_index;
      IF (NOT (service_class IN jmv$classes_in_maxaj_limit_wait)) THEN
        jmv$job_scheduler_event [event] := TRUE;
        IF (NOT (service_class IN jmv$classes_in_resource_wait)) THEN
          jmv$job_sched_events_selected [event] := TRUE;
          tmp$ready_system_task (tmc$stid_job_scheduler, status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND jmp$set_examine_queue_event;

?? TITLE := '[XDCL, #GATE] jmp$set_high_swapin_priority', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$set_high_swapin_priority
    (    ijl_ordinal: jmt$ijl_ordinal);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      status: ost$status;

    jmp$get_ijle_p (ijl_ordinal, ijle_p);

    IF ijle_p^.entry_status = jmc$ies_swapin_candidate THEN
      ijle_p^.job_scheduler_data.unaged_swap_queue_priority := UPPERVALUE (jmt$job_priority);
      ijle_p^.job_scheduler_data.priority := UPPERVALUE (jmt$job_priority);
    ELSE
      osp$system_error ('SET HIGH SWAPIN PRIORITY -- CANDIDATE NOT IN QUEUE', ^status);
    IFEND;

  PROCEND jmp$set_high_swapin_priority;

?? TITLE := '[XDCL, #GATE] jmp$set_idle_system_event', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$set_idle_system_event;

    VAR
      status: ost$status;

    jmv$prevent_activation_of_jobs := TRUE;
    jmp$idle_advance_lw_jobs;
    jmv$job_scheduler_event [jmc$system_is_idling] := TRUE;
    tmp$ready_system_task (tmc$stid_job_scheduler, status);

  PROCEND jmp$set_idle_system_event;

?? TITLE := '[XDCL, #GATE] jmp$set_sched_service_calc_time', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$set_sched_service_calc_time;

    jmv$sched_service_calc_time := #FREE_RUNNING_CLOCK (0) +
          (jmv$job_scheduler_table.service_calculation_interval * 1000000);

  PROCEND jmp$set_sched_service_calc_time;

?? TITLE := '[XDCL, #GATE] jmp$set_sched_thrashing_event', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$set_sched_thrashing_event;

    jmv$job_scheduler_event [jmc$system_is_thrashing] := TRUE;

  PROCEND jmp$set_sched_thrashing_event;

?? TITLE := '[XDCL, #GATE] jmp$set_scheduler_time_event', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$set_scheduler_time_event;

    jmv$job_scheduler_event [jmc$scheduler_wake_time] := TRUE;

  PROCEND jmp$set_scheduler_time_event;

?? TITLE := '[XDCL, #GATE] jmp$set_unable_to_swap_flag', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$set_unable_to_swap_flag
    (    ijlo: jmt$ijl_ordinal);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry;

    jmp$get_ijle_p (ijlo, ijle_p);
    ijle_p^.unable_to_swap_idle_flag := TRUE;

  PROCEND jmp$set_unable_to_swap_flag;

?? TITLE := 'jmp$special_job_swapout', EJECT ??

{ PURPOSE:
{   This procedure processes operator and job damaged swapouts.
{ DESIGN:
{   Determine which status the job is currently in and swap it if necessary.  It is OK for job mode
{   scheduler to process entry statuses of swapin candidate and job damaged.  Job scheduler controls
{   setting those statuses and nothing asynchronous in monitor will change them once they are set.
{   Entry status of job damaged is checked so that an operator swapout does not change it.

  PROCEDURE jmp$special_job_swapout
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry;
         reason: jmt$swapout_reasons;
     VAR status: ost$status);

    IF ijle_p^.entry_status = jmc$ies_swapin_candidate THEN
      IF reason = jmc$sr_operator_request THEN
        jmp$jm_change_ijl_entry_status (ijle_p, jmc$ies_operator_force_out);
      ELSE {reason = jmc$sr_job_damaged}
        jmp$jm_change_ijl_entry_status (ijle_p, jmc$ies_job_damaged);
      IFEND;
      jmp$delete_swapin_candidate (ijl_ordinal, ijle_p^.job_scheduler_data.service_class);

    ELSEIF (ijle_p^.entry_status < jmc$ies_job_in_memory) OR (ijle_p^.entry_status = jmc$ies_job_damaged) THEN
      osp$set_status_abnormal ('JM', jme$job_cant_be_swapped, 'JOB CANT BE SWAPPED', status);

    ELSE
      jsp$special_job_swapout (ijl_ordinal, reason, status);
    IFEND;

  PROCEND jmp$special_job_swapout;

?? TITLE := '[XDCL, #GATE] jmp$test_for_system_idle_r1', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$test_for_system_idle_r1
    (VAR status: ost$status);

    status.normal := TRUE;
    pmp$get_executing_task_gtid (gtid_of_task_waiting_for_idle);
    IF jmv$job_counts.initiated_jobs > 1 THEN
      osp$set_status_abnormal ('JM', jme$system_not_idle, '', status);
    IFEND;

  PROCEND jmp$test_for_system_idle_r1;

MODEND jmm$job_scheduler_ring_1;
*DECK DECK=JMM$JOB_SCHEDULER_RING_2 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : job scheduler ring 2' ??
MODULE jmm$job_scheduler_ring_2;

{ PURPOSE:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc jse$condition_codes
*copyc jmc$kjl_maximum_entries
*copyc jmc$null_ajl_ordinal
*copyc jmc$system_family
*copyc jme$job_scheduler_conditions
*copyc jmk$keypoints
*copyc jmt$active_job_queue
*copyc jmt$ajl_ordinal
*copyc jmt$clock_time
*copyc jmt$dispatching_control_info
*copyc jmt$dispatching_priority
*copyc jmt$job_scheduler_statistics
*copyc jmt$job_scheduler_table
*copyc jmt$lock_functions
*copyc jmt$operator_request_list
*copyc jmt$node
*copyc jmt$rb_scheduler_requests
*copyc jmt$service_class_set
*copyc jmt$service_class_name
*copyc jmt$system_supplied_name
*copyc ost$global_task_id
*copyc ost$status
*copyc pmd$log_entries
*copyc pmt$signal
?? POP ??
*copyc dmp$set_eoi
*copyc dpp$put_critical_message
*copyc i#call_monitor
*copyc jmp$adjust_swapin_cand_prio
*copyc jmp$add_to_maxaj_limit_set
*copyc jmp$allocate_more_ijl_space
*copyc jmp$change_dispatching_prior_r1
*copyc jmp$clear_memory_res_swap_field
*copyc jmp$clear_scheduler_event
*copyc jmp$compute_total_memory_used
*copyc jmp$decrement_lw_threshold
*copyc jmp$delete_ijl_entry
*copyc jmp$find_and_insert_swapin_cand
*copyc jmp$get_ijle_p
*copyc jmp$idle_advance_lw_jobs
*copyc jmp$idling_swapfile_update
*copyc jmp$incr_sched_serv_statistics
*copyc jmp$incr_scheduler_statistics
*copyc jmp$increment_ijl_in_use_count
*copyc jmp$initiate_job_from_scheduler
*copyc jmp$perform_physical_swapout
*copyc jmp$refresh_job_candidates
*copyc jmp$relink_to_end_of_swapin_q
*copyc jmp$reset_advance_lw_swaps
*copyc jmp$reset_activate_event
*copyc jmp$reset_activate_events_sels
*copyc jmp$reset_ijl_search_block
*copyc jmp$restore_job_environment
*copyc jmp$select_job_for_thrashing
*copyc jmp$select_reset_disp_pr
*copyc jmp$select_sched_memory_event
*copyc jmp$select_scheduler_ajlo_event
*copyc jmp$select_sched_service_wait
*copyc jmp$select_scheduler_short_wait
*copyc jmp$set_all_jobs_swapped_var
*copyc jmp$set_class_below_maxaj_limit
*copyc jmp$set_event_and_ready_sched
*copyc jmp$set_high_swapin_priority
*copyc jmp$set_sched_thrashing_event
*copyc jmp$set_unable_to_swap_flag
*copyc lgp$add_entry_to_system_log
*copyc osp$append_status_parameter
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pfp$purge
*copy  syp$disable_job_recovery
?? EJECT ??
*copyc jmv$ajl_p
*copyc jmv$candidate_queued_jobs
*copyc jmv$classes_in_maxaj_limit_wait
*copyc jmv$idle_dispatching_controls
*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc jmv$job_class_table_p
*copyc jmv$job_counts
*copyc jmv$job_scheduler_event
*copyc jmv$job_scheduler_table
*copyc jmv$max_ajl_ordinal_in_use
*copyc jmv$max_service_class_in_use
*copyc jmv$maximum_job_class_in_use
*copyc jmv$null_ijl_ordinal
*copyc jmv$number_free_ajl_entries
*copyc jmv$prevent_activation_of_jobs
*copyc jmv$refresh_job_candidates
*copyc jmv$service_classes
*copyc jmv$swapin_candidate_queue
*copyc jmv$system_ajl_ordinal
*copyc jmv$system_ijl_ordinal
*copyc jmv$system_job_ssn
*copyc jsv$ijl_swap_queue_list
*copyc mmv$aggressive_aging_level
*copyc mmv$max_working_set_size
*copyc mmv$gpql
*copyc mmv$reassignable_page_frames
*copyc mmv$reserved_page_count
*copyc mmv$resident_job_target
*copyc mmv$last_active_shared_queue
*copyc mtv$mx_ajl_entries
*copyc osv$job_pageable_heap
*copyc tmv$null_global_task_id
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    jmv$total_pageable_pages: [XDCL] integer := 0,

    v$active_job_queue_free_index: jmt$active_job_queue_range,
    v$active_job_queue_header: jmt$active_job_queue_header,
    v$active_job_queue_p: ^jmt$active_job_queue,
    v$preemptable_memory: integer;

?? OLDTITLE ??
?? NEWTITLE := 'activate_jobs', EJECT ??

{ PURPOSE:
{   This procedure will swapin and initiate all jobs possible.  If any jobs cannot be activated,
{   jobs that are currently active will be preempted, if possible, to free resources for the
{   jobs waiting to be activated.

  PROCEDURE activate_jobs
    (    examine_input_queue: boolean;
         current_time: jmt$clock_time);

?? NEWTITLE := 'get_free_ijl_entry', EJECT ??

    PROCEDURE get_free_ijl_entry
      (VAR free_ijl: jmt$ijl_ordinal);

      VAR
        found: boolean,
        ijl_bi: jmt$ijl_block_index,
        ijl_bn: jmt$ijl_block_number,
        ijl_p: ^jmt$initiated_job_list_entry,
        new_starting_block_index: jmt$ijl_block_index,
        new_starting_block_number: jmt$ijl_block_number;

      found := FALSE;

    /get_ijl_entry/
      FOR ijl_bn := starting_block_number TO jmv$ijl_p.max_block_in_use DO
        IF jmv$ijl_p.block_p^ [ijl_bn].index_p <> NIL THEN
          FOR ijl_bi := starting_block_index TO UPPERVALUE (jmt$ijl_block_index) DO
            ijl_p := ^jmv$ijl_p.block_p^ [ijl_bn].index_p^ [ijl_bi];
            IF ijl_p^.entry_status = jmc$ies_entry_free THEN
              free_ijl.block_number := ijl_bn;
              free_ijl.block_index := ijl_bi;
              found := TRUE;
              IF ijl_bi = UPPERVALUE (jmt$ijl_block_index) THEN

                IF ijl_bn = jmv$ijl_p.max_block_in_use THEN

                  { A new ijl must be allocated before the new_starting_block_number can be incremented.
                  { We may not need it if this is the last time through the /activation_loop/ in activate
                  { jobs.  Leave the new_starting_block_index at UPPERVALUE so we will exit the loop quickly
                  { if this is not the last time through.

                  new_starting_block_index := ijl_bi;
                  new_starting_block_number := ijl_bn;
                ELSE
                  new_starting_block_index := LOWERVALUE (jmt$ijl_block_index);
                  new_starting_block_number := ijl_bn + 1;
                IFEND;

              ELSE
                new_starting_block_index := ijl_bi + 1;
                new_starting_block_number := ijl_bn;
              IFEND;
              EXIT /get_ijl_entry/;
            IFEND;
          FOREND;
        ELSE
          EXIT /get_ijl_entry/;
        IFEND;
      FOREND /get_ijl_entry/;

      IF NOT found THEN
        IF ijl_bn = jmv$ijl_p.max_block_in_use THEN
          ijl_bn := ijl_bn + 1;
        IFEND;
        jmp$allocate_more_ijl_space (ijl_bn);
        free_ijl.block_number := ijl_bn;
        free_ijl.block_index := LOWERVALUE (jmt$ijl_block_index);
        new_starting_block_number := ijl_bn;
        new_starting_block_index := LOWERVALUE (jmt$ijl_block_index) + 1;
      IFEND;

      starting_block_number := new_starting_block_number;
      starting_block_index := new_starting_block_index;
      jmp$increment_ijl_in_use_count (ijl_bn);

    PROCEND get_free_ijl_entry;
?? OLDTITLE ??
?? NEWTITLE := 'activate', EJECT ??

    PROCEDURE activate
      (VAR pages_used_to_init_jobs: integer;
       VAR available_memory: integer;
       VAR status: ost$status);

      VAR
        ijlo: jmt$ijl_ordinal;

      status.normal := TRUE;

      CASE node.qtype OF
      = queued_thd =
        get_free_ijl_entry (ijlo);
        jmp$initiate_job_from_scheduler (node, ijlo, class, status);
        IF NOT status.normal THEN
          jmp$delete_ijl_entry (ijlo);
          RETURN;
        IFEND;
      = swapped =
        jmp$restore_job_environment (node, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
      CASEND;

      IF node.qtype <> swapped THEN
        pages_used_to_init_jobs := pages_used_to_init_jobs + required_memory;
      IFEND;
      available_memory := mmv$reassignable_page_frames.now - mmv$resident_job_target -
            pages_used_to_init_jobs - mmv$reserved_page_count;

      { Reset the memory needed by scheduler, if the counts have already been set up.

      IF active_queues_built THEN
        jmp$decrement_lw_threshold (node);
      IFEND;

    PROCEND activate;
?? OLDTITLE, EJECT ??

    VAR
      activation_violation: boolean,
      activation_violation_classes: jmt$service_class_set,
      active_queues_built: boolean,
      available_memory: integer,
      can_preempt: boolean,
      class: jmt$service_class_index,
      ijl_p: ^jmt$initiated_job_list_entry,
      memory_flushed_from_lw_queue: mmt$page_frame_index,
      need_ajl: boolean,
      needed_memory: integer,
      next_sc_ijl_p: ^jmt$initiated_job_list_entry,
      node: jmt$node,
      none_left: boolean,
      pages_used_to_init_jobs: integer,
      queue: mmt$global_page_queue_index,
      relink_count: integer,
      required_memory: integer,
      starting_block_number: jmt$ijl_block_number,
      starting_block_index: jmt$ijl_block_index,
      status: ost$status,
      sum_shared: integer,
      ws_greater_than_system_max: boolean;

    active_queues_built := FALSE;
    activation_violation_classes := jmv$classes_in_maxaj_limit_wait;
    available_memory := mmv$reassignable_page_frames.now - mmv$resident_job_target - mmv$reserved_page_count;
    memory_flushed_from_lw_queue := 0;
    relink_count := 0;
    pages_used_to_init_jobs := 0;
    none_left := FALSE;
    starting_block_number := jmv$ijl_p.start_search_block;
    starting_block_index := LOWERVALUE (jmt$ijl_block_index);

  /activation_loop/
    WHILE TRUE DO
      select_highest_priority (examine_input_queue, current_time, activation_violation_classes, node, class,
            none_left);
      IF none_left THEN
        IF activation_violation_classes = $jmt$service_class_set [] THEN
          jmp$incr_scheduler_statistics (jmc$queues_emptied_count);
        ELSE
          jmp$incr_scheduler_statistics (jmc$none_left_activation_viol);
        IFEND;
        EXIT /activation_loop/;
      IFEND;

      activation_violation := (jmv$job_counts.service_class_counts [class].scheduler_initiated_jobs -
            jmv$job_counts.service_class_counts [class].swapped_jobs) >=
            jmv$service_classes [class]^.attributes.maximum_active_jobs;

      required_memory := node.ws;
      ws_greater_than_system_max := ((node.qtype = swapped) AND (node.ws > mmv$max_working_set_size));
      need_ajl := TRUE;
      IF node.qtype = swapped THEN
        jmp$get_ijle_p (node.ijl_ord, ijl_p);
        IF ijl_p^.swap_status < jmc$iss_initiate_swapout_io THEN
          required_memory := ijl_p^.memory_reserve_request.requested_page_count;
        ELSE
          required_memory := required_memory + ijl_p^.memory_reserve_request.requested_page_count;
        IFEND;
        need_ajl := (ijl_p^.ajl_ordinal = jmc$null_ajl_ordinal);
      IFEND;

      IF ws_greater_than_system_max OR activation_violation OR (available_memory < required_memory) OR
            ((jmv$number_free_ajl_entries <= 0) AND need_ajl) THEN

        IF NOT active_queues_built THEN

          { It is necessary to try to preempt, so a list of swappable jobs is built.  Also the threshold of
          { pages needed by scheduler to activate all swapin candidates is set (this controls whether jobs
          { stay in the long wait queue or not).  Start the IO on jobs in the long wait queue if necessary
          { or possible.

          build_active_job_queues (node);
          jmp$reset_advance_lw_swaps (memory_flushed_from_lw_queue);
          active_queues_built := TRUE;
        IFEND;

        IF ws_greater_than_system_max THEN

          IF ijl_p^.swapin_candidate_queue <> jmv$null_ijl_ordinal THEN
            jmp$get_ijle_p (ijl_p^.swapin_candidate_queue, next_sc_ijl_p);
          IFEND;

          { If swapping the job in will drive memory below target, but still be above thrashing, swap it in.
          { Memory manager algorithms will cause the jobs working set to decrease.

          IF node.ws < (available_memory + mmv$resident_job_target - mmv$aggressive_aging_level) THEN
            activate (pages_used_to_init_jobs, available_memory, status);
            IF NOT status.normal THEN
              jmp$incr_scheduler_statistics (jmc$large_ws_bad_status_on_act);
            ELSE
              jmp$incr_scheduler_statistics (jmc$large_ws_job_activated);
            IFEND;
            jmp$select_scheduler_short_wait;
            EXIT /activation_loop/;

          ELSEIF ((ijl_p^.swapin_candidate_queue = jmv$null_ijl_ordinal) OR
                (ijl_p^.scheduling_dispatching_priority > next_sc_ijl_p^.scheduling_dispatching_priority)) AND
                (jmv$max_ajl_ordinal_in_use = jmv$system_ajl_ordinal) THEN

            { If there are no other jobs contending for memory, swap the job in if there is enough memory in
            { the shared queue that can be freed up.  Swapper algorithms will cause the shared queue to be
            { raided.

            sum_shared := 0;
            FOR queue := mmc$pq_shared_first TO mmv$last_active_shared_queue DO
              sum_shared := sum_shared + mmv$gpql [queue].pqle.count;
            FOREND;
            IF (sum_shared - 10 + available_memory + mmv$resident_job_target - mmv$aggressive_aging_level) >
                  required_memory THEN
              activate (pages_used_to_init_jobs, available_memory, status);
              IF NOT status.normal THEN
                jmp$incr_scheduler_statistics (jmc$age_shared_q_bad_status);
              ELSE
                jmp$incr_scheduler_statistics (jmc$age_shared_q_activated);
              IFEND;
              jmp$select_scheduler_short_wait;
              EXIT /activation_loop/;
            ELSE
              activation_violation_classes := activation_violation_classes + $jmt$service_class_set [class];
            IFEND;

          ELSEIF (node.ws <
                mmv$max_working_set_size + mmv$resident_job_target - mmv$aggressive_aging_level) AND
                (node.ws < available_memory + v$preemptable_memory + mmv$resident_job_target) THEN

            { If there are jobs that can be preempted to get memory, preempt them.

            needed_memory := required_memory - available_memory;
            IF memory_flushed_from_lw_queue > needed_memory THEN
              memory_flushed_from_lw_queue := memory_flushed_from_lw_queue - needed_memory;
              available_memory := 0;
              needed_memory := 0;
              jmp$incr_scheduler_statistics (jmc$large_ws_mem_avail_in_lw_q);
            ELSE
              needed_memory := needed_memory - memory_flushed_from_lw_queue;
            IFEND;
            determine_if_can_preempt (FALSE, activation_violation, node, class, needed_memory, can_preempt);
            IF can_preempt THEN
              preempt (FALSE, activation_violation, node, class, needed_memory, status);
              jmp$incr_scheduler_statistics (jmc$large_ws_preempt_for_memory);
              jmp$select_sched_memory_event (required_memory, class);
              jmp$set_high_swapin_priority (node.ijl_ord);
              EXIT /activation_loop/;
            ELSE
              IF (ijl_p^.swapin_candidate_queue <> jmv$null_ijl_ordinal) AND
                    (relink_count < jmv$swapin_candidate_queue [class].number_of_jobs_in_queue) THEN
                jmp$relink_to_end_of_swapin_q (node.ijl_ord);
                jmp$incr_scheduler_statistics (jmc$large_ws_relink_no_preempt);
                relink_count := relink_count + 1;
              ELSE
                activation_violation_classes := activation_violation_classes + $jmt$service_class_set [class];
              IFEND;
            IFEND;

          ELSEIF (ijl_p^.swapin_candidate_queue <> jmv$null_ijl_ordinal) AND
                (ijl_p^.scheduling_dispatching_priority = next_sc_ijl_p^.scheduling_dispatching_priority) AND
                (relink_count < jmv$swapin_candidate_queue [class].number_of_jobs_in_queue) THEN

            { If this class has other jobs in the swapin queue, relink so they can be considered.

            jmp$relink_to_end_of_swapin_q (node.ijl_ord);
            jmp$incr_scheduler_statistics (jmc$large_ws_relink_job_too_big);
            relink_count := relink_count + 1;

          ELSE

            { Turn off considering candidates of this job class; this job cannot swap in now.

            activation_violation_classes := activation_violation_classes + $jmt$service_class_set [class];
          IFEND;
          jmp$select_sched_service_wait;
          jmp$select_sched_memory_event (required_memory, class);

        ELSEIF activation_violation THEN
          IF available_memory > required_memory THEN
            determine_if_can_preempt (TRUE, activation_violation, node, class, 0, can_preempt);
            IF can_preempt THEN

              { Only one job needs to be preempted so that the number of active jobs allowed for this class
              { is not exceeded.  The count of active jobs for the class will be decremented before preempt
              { returns, so the job scheduler is trying to activate will not be an activation_violation on
              { the next pass through the loop.

              preempt (TRUE, activation_violation, node, class, 0, status);
            ELSE
              activation_violation_classes := activation_violation_classes + $jmt$service_class_set [class];
              jmp$add_to_maxaj_limit_set (class);
              jmp$select_sched_service_wait;
              jmp$incr_scheduler_statistics (jmc$ajlo_wait_act_viol);
            IFEND;
          ELSE
            needed_memory := required_memory - available_memory;
            IF memory_flushed_from_lw_queue > needed_memory THEN
              memory_flushed_from_lw_queue := memory_flushed_from_lw_queue - needed_memory;
              determine_if_can_preempt (TRUE, activation_violation, node, class, 0, can_preempt);
              needed_memory := 0;
            ELSE
              needed_memory := needed_memory - memory_flushed_from_lw_queue;
              IF (available_memory + v$preemptable_memory) > required_memory THEN
                determine_if_can_preempt (FALSE, activation_violation, node, class, needed_memory,
                      can_preempt);
              ELSE
                can_preempt := FALSE;
              IFEND;
            IFEND;

            IF can_preempt THEN

              { Swapout (preempt) as many active jobs as necessay to get enough memory.  The job cannot be
              { activated until the memory is freed, so mark the class as an activation violation class to
              { prevent selecting the job again.  The job will be selected for activation when scheduler runs
              { again.

              preempt ((needed_memory = 0), activation_violation, node, class, needed_memory, status);
              available_memory := 0;
              IF needed_memory > 0 THEN
                memory_flushed_from_lw_queue := 0;
              IFEND;
              jmp$select_sched_memory_event (required_memory, class);
              jmp$incr_scheduler_statistics (jmc$wait_for_memory);
            ELSE
              jmp$add_to_maxaj_limit_set (class);
              jmp$incr_scheduler_statistics (jmc$memory_wait_act_viol);
            IFEND;
            jmp$select_sched_service_wait;
            activation_violation_classes := activation_violation_classes + $jmt$service_class_set [class];
          IFEND;

        ELSEIF available_memory < required_memory THEN

         /try_to_age_not_swap/
          BEGIN
            needed_memory := required_memory - available_memory;
            IF memory_flushed_from_lw_queue > needed_memory THEN
              memory_flushed_from_lw_queue := memory_flushed_from_lw_queue - needed_memory;
              available_memory := 0;
              jmp$incr_scheduler_statistics (jmc$memory_available_in_lw_q);
            ELSE
              needed_memory := needed_memory - memory_flushed_from_lw_queue;
              IF (available_memory + v$preemptable_memory) > required_memory THEN
                determine_if_can_preempt (FALSE, activation_violation, node, class, needed_memory,
                      can_preempt);
                IF can_preempt THEN

                  { Swapout (preempt) as many active jobs as necessay to get enough memory.  The job cannot be
                  { activated until the memory is freed, so mark the class as an activation violation class to
                  { prevent selecting the job again.  The job will be selected for activation when scheduler
                  { runs again.

                  preempt (FALSE, activation_violation, node, class, needed_memory, status);
                  IF NOT status.normal AND (status.condition = jse$job_aged_not_swapped) THEN
                    activate (pages_used_to_init_jobs, available_memory, status);
                    IF NOT status.normal THEN
                      jmp$incr_scheduler_statistics (jmc$bad_status_after_age_job);
                      jmp$select_scheduler_short_wait;
                      EXIT /activation_loop/;
                    ELSE
                      jmp$incr_scheduler_statistics (jmc$activate_after_age_job);
                      EXIT /try_to_age_not_swap/;
                    IFEND;
                  IFEND;
                  available_memory := 0;
                  memory_flushed_from_lw_queue := 0;
                  jmp$incr_scheduler_statistics (jmc$wait_for_memory);
                ELSE
                  jmp$incr_sched_serv_statistics (jmc$memory_wait_no_preempt, class);
                IFEND;
              ELSE
                jmp$incr_sched_serv_statistics (jmc$memory_wait_no_preempt, class);
              IFEND;
            IFEND;
            jmp$select_sched_service_wait;
            jmp$select_sched_memory_event (required_memory, class);
            activation_violation_classes := activation_violation_classes + $jmt$service_class_set [class];
          END /try_to_age_not_swap/;

        ELSE { jmv$number_free_ajl_entries = 0 AND need_ajl }
          determine_if_can_preempt (TRUE, activation_violation, node, class, 0, can_preempt);
          IF can_preempt THEN

            { Swapout (preempt) one active job to free an ajl ordinal.  EXIT the activation loop.
            { The job will be selected for activation when scheduler runs again.

            preempt (TRUE, activation_violation, node, class, 0, status);
            jmp$select_scheduler_ajlo_event (class);
            jmp$incr_scheduler_statistics (jmc$wait_for_ajlo);
          ELSE
            jmp$select_sched_service_wait;
            jmp$select_scheduler_ajlo_event (class);
            jmp$incr_sched_serv_statistics (jmc$ajlo_wait_no_preempt, class);
          IFEND;
          EXIT /activation_loop/;
        IFEND;

      ELSE
        activate (pages_used_to_init_jobs, available_memory, status);
        IF NOT status.normal THEN
          jmp$incr_scheduler_statistics (jmc$bad_status_on_activate);
          jmp$select_scheduler_short_wait;
          EXIT /activation_loop/;
        IFEND;
      IFEND;
    WHILEND /activation_loop/;

    jmp$reset_ijl_search_block (starting_block_number);

    { Active_queues_built = False means scheduler never had to try to preempt.  Reset the long_wait_
    { swap_threshold.  It may be higher from the previous time scheduler ran.

    IF NOT active_queues_built THEN
      jmp$reset_advance_lw_swaps (memory_flushed_from_lw_queue);
    IFEND;

  PROCEND activate_jobs;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] priority_allows_preemption', EJECT ??

  FUNCTION [INLINE] priority_allows_preemption
    (    dispatching_priority: jmt$dispatching_priority;
         priority: jmt$job_priority;
         queue_index: jmt$active_job_queue_range): boolean;

    priority_allows_preemption := (dispatching_priority >
          v$active_job_queue_p^ [queue_index].node.dispatching_priority) OR
          ((dispatching_priority = v$active_job_queue_p^ [queue_index].node.dispatching_priority) AND
          (priority >= v$active_job_queue_p^ [queue_index].node.priority));

  FUNCEND priority_allows_preemption;
?? OLDTITLE ??
?? NEWTITLE := 'determine_if_can_preempt', EJECT ??

  PROCEDURE determine_if_can_preempt
    (    singleton: boolean;
         activation_violation: boolean;
         node: jmt$node;
         class: jmt$service_class_index;
         needed_memory: integer;
     VAR can_preempt: boolean);

    VAR
      can_preempt_for_act_viol: boolean,
      class_index: jmt$service_class_index,
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      in_memory: boolean,
      next_index: jmt$active_job_queue_range,
      queue_index: jmt$active_job_queue_range,
      within_queue_index: integer,
      ws_obtained: integer;

    can_preempt := FALSE;
    IF singleton THEN

      { Need to be able to preempt only one job, either because there are too many active jobs for a
      { certain class, or an ajl ordinal is needed.

      IF activation_violation THEN

        { Find a job in memory in order to preempt it.

        in_memory := FALSE;

        WHILE NOT in_memory AND (v$active_job_queue_header [class] <> 0) DO
          ijl_ordinal := v$active_job_queue_p^ [v$active_job_queue_header [class]].node.ijl_ord;
          jmp$get_ijle_p (ijl_ordinal, ijle_p);
          IF ijle_p^.entry_status = jmc$ies_job_in_memory THEN
            in_memory := TRUE;
            queue_index := v$active_job_queue_header [class];
            can_preempt := priority_allows_preemption (node.dispatching_priority, node.priority, queue_index);
          ELSE
            delete_active_job_from_q (v$active_job_queue_header [class], class);
          IFEND;
        WHILEND;
        RETURN;
      IFEND;

      { Else, determine if any job can be preempted to get a free ajl_ord.

      FOR class_index := jmc$system_service_class TO jmv$max_service_class_in_use DO
        in_memory := FALSE;
        WHILE NOT in_memory AND (v$active_job_queue_header [class_index] <> 0) DO
          queue_index := v$active_job_queue_header [class_index];
          ijl_ordinal := v$active_job_queue_p^ [queue_index].node.ijl_ord;
          jmp$get_ijle_p (ijl_ordinal, ijle_p);
          IF ijle_p^.entry_status = jmc$ies_job_in_memory THEN
            in_memory := TRUE;
            IF priority_allows_preemption (node.dispatching_priority, node.priority, queue_index) THEN
              can_preempt := TRUE;
              RETURN;
            IFEND;
          ELSE
            delete_active_job_from_q (queue_index, class_index);
          IFEND;
        WHILEND;
      FOREND;
      RETURN;

    ELSE

      { Jobs need to be preempted before others can be activated because memory is getting low.

      can_preempt_for_act_viol := FALSE;
      ws_obtained := 0;

      IF activation_violation THEN

        { Need to be able to preempt at least one job of the specified class.  Find a job in memory in order
        { to preempt it.

        in_memory := FALSE;
        WHILE NOT in_memory AND (v$active_job_queue_header [class] <> 0) DO
          queue_index := v$active_job_queue_header [class];
          ijl_ordinal := v$active_job_queue_p^ [queue_index].node.ijl_ord;
          jmp$get_ijle_p (ijl_ordinal, ijle_p);
          IF ijle_p^.entry_status = jmc$ies_job_in_memory THEN
            in_memory := TRUE;
            can_preempt_for_act_viol :=
                  priority_allows_preemption (node.dispatching_priority, node.priority, queue_index);
          ELSE
            delete_active_job_from_q (queue_index, class);
          IFEND;
        WHILEND;

        IF can_preempt_for_act_viol THEN
          ws_obtained := ws_obtained + v$active_job_queue_p^ [queue_index].node.ws;
          IF ws_obtained >= needed_memory THEN
            can_preempt := TRUE;
            RETURN;
          IFEND;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      { Now look for jobs of lower priority in any service class that can be swapped to get enough memory.
      { Here the queues are searched by class, because it only needs to be determined that there are jobs that
      { can be swapped that will provide enough memory.  The procedure preempt however, will search across
      { service classes and swap out jobs according to priority.

      { Reset ws_obtained--if we went through activation_violation, the ws_obtained there will be re_added in
      { the following FOR loops.

      ws_obtained := 0;

      FOR class_index := jmc$system_service_class TO jmv$max_service_class_in_use DO
        queue_index := v$active_job_queue_header [class_index];

      /search_each_class/
        WHILE queue_index <> jmc$null_active_job_queue_link DO
          ijl_ordinal := v$active_job_queue_p^ [queue_index].node.ijl_ord;
          jmp$get_ijle_p (ijl_ordinal, ijle_p);
          IF ijle_p^.entry_status = jmc$ies_job_in_memory THEN
            IF priority_allows_preemption (node.dispatching_priority, node.priority, queue_index) THEN
              ws_obtained := ws_obtained + v$active_job_queue_p^ [queue_index].node.ws;
              IF ws_obtained >= needed_memory THEN
                can_preempt := TRUE;
                RETURN;
              IFEND;
              next_index := v$active_job_queue_p^ [queue_index].link;
            ELSE
              EXIT /search_each_class/;
            IFEND;
          ELSE
            next_index := v$active_job_queue_p^ [queue_index].link;
            delete_active_job_from_q (queue_index, class);
          IFEND;
          queue_index := next_index;
        WHILEND /search_each_class/;
      FOREND;
    IFEND;

  PROCEND determine_if_can_preempt;
?? OLDTITLE ??
?? NEWTITLE := 'preempt', EJECT ??

  PROCEDURE preempt
    (    singleton: boolean;
         activation_violation: boolean;
         node: jmt$node;
         class: jmt$service_class_index;
         needed_memory: integer;
     VAR status: ost$status);

    VAR
      best_class: jmt$service_class_index,
      best_dispatching_priority: jmt$dispatching_priority,
      best_priority: jmt$job_priority,
      class_index: jmt$service_class_index,
      queue_index: jmt$active_job_queue_range,
      required_memory: integer,
      swap_candidate_found: boolean,
      swap_node: jmt$node;

    status.normal := TRUE;

    IF singleton THEN
      IF activation_violation THEN

        { Swap the lowest priority job of the service class.

        swap_node := v$active_job_queue_p^ [v$active_job_queue_header [class]].node;
        jmp$perform_physical_swapout (swap_node, jmc$sr_lower_priority, class, 0, status);
        delete_active_job_from_q (v$active_job_queue_header [class], class);
        v$preemptable_memory := v$preemptable_memory - swap_node.ws;
        RETURN;
      IFEND;

      { Preempt a job of any class in order to get an ajl_ord.

      swap_candidate_found := FALSE;
      best_dispatching_priority := node.dispatching_priority;
      best_priority := node.priority;

      FOR class_index := jmc$system_service_class TO jmv$max_service_class_in_use DO
        queue_index := v$active_job_queue_header [class_index];
        IF queue_index <> 0 THEN
          IF priority_allows_preemption (best_dispatching_priority, best_priority, queue_index) THEN
            best_class := class_index;
            best_priority := v$active_job_queue_p^ [queue_index].node.priority;
            best_dispatching_priority := v$active_job_queue_p^ [queue_index].node.dispatching_priority;
            swap_candidate_found := TRUE;
          IFEND;
        IFEND;
      FOREND;

      IF swap_candidate_found THEN
        swap_node := v$active_job_queue_p^ [v$active_job_queue_header [best_class]].node;
        jmp$perform_physical_swapout (swap_node, jmc$sr_lower_priority, best_class, 0, status);
        delete_active_job_from_q (v$active_job_queue_header [best_class], best_class);
        v$preemptable_memory := v$preemptable_memory - swap_node.ws;
        RETURN;
      IFEND;

    ELSE

      { Swap out as many lower priority jobs as necessary to get enough memory to activate a job.

      required_memory := needed_memory;
      IF activation_violation THEN

        { Swap out the lowest priority job of the service class to resolve the activation violation.

        swap_node := v$active_job_queue_p^ [v$active_job_queue_header [class]].node;
        jmp$perform_physical_swapout (swap_node, jmc$sr_lower_priority, class, 0, status);
        delete_active_job_from_q (v$active_job_queue_header [class], class);
        v$preemptable_memory := v$preemptable_memory - swap_node.ws;
        required_memory := required_memory - swap_node.ws;
      IFEND;

      { Now swap the lowest priority job of all the service classes; repeat until enough memory is acquired.

      WHILE required_memory > 0 DO
        swap_candidate_found := FALSE;
        best_dispatching_priority := node.dispatching_priority;
        best_priority := node.priority;

        FOR class_index := jmc$system_service_class TO jmv$max_service_class_in_use DO
          queue_index := v$active_job_queue_header [class_index];
          IF queue_index <> 0 THEN
            IF priority_allows_preemption (best_dispatching_priority, best_priority, queue_index) THEN
              best_class := class_index;
              best_priority := v$active_job_queue_p^ [queue_index].node.priority;
              best_dispatching_priority := v$active_job_queue_p^ [queue_index].node.dispatching_priority;
              swap_candidate_found := TRUE;
            IFEND;
          IFEND;
        FOREND;

        IF NOT swap_candidate_found THEN
          RETURN;
        IFEND;

        swap_node := v$active_job_queue_p^ [v$active_job_queue_header [best_class]].node;
        jmp$perform_physical_swapout (swap_node, jmc$sr_lower_priority, best_class, required_memory,
              status);
        IF NOT status.normal AND (status.condition = jse$job_aged_not_swapped) THEN

          { Desired memory was retrieved from aging, no more swapping is needed.

          RETURN;
        IFEND;
        delete_active_job_from_q (v$active_job_queue_header [best_class], best_class);
        required_memory := required_memory - swap_node.ws;
        v$preemptable_memory := v$preemptable_memory - swap_node.ws;
      WHILEND;
    IFEND;

  PROCEND preempt;
?? OLDTITLE ??
?? NEWTITLE := 'select_highest_priority', EJECT ??

{ PURPOSE:
{   This procedure selects the highest priority initiation candidate from across all queues.

  PROCEDURE select_highest_priority
    (    examine_input_queue: boolean;
         current_time: jmt$clock_time;
         activation_violation_classes: jmt$service_class_set;
     VAR best_node: jmt$node;
     VAR best_class: jmt$service_class_index;
     VAR none_left: boolean);

    VAR
      age_interval: integer,
      best_queued_class: jmt$service_class_index,
      best_queued_node: jmt$node,
      best_swapped_class: jmt$service_class_index,
      best_swapped_node: jmt$node,
      dispatching_priority: jmt$dispatching_priority,
      initiation_age_interval: integer,
      job_class: jmt$job_class,
      job_priority: jmt$job_priority,
      max_queued_dispatching_prio: jmt$dispatching_priority,
      max_swapped_dispatching_prio: jmt$dispatching_priority,
      maximum_queued_job_priority: jmt$job_priority,
      maximum_swapped_job_priority: jmt$job_priority,
      queue_type: jmt$phases,
      sc_ijle_p: ^jmt$initiated_job_list_entry,
      sc_ijlo: jmt$ijl_ordinal,
      service_class: jmt$service_class_index;

    max_queued_dispatching_prio := jmc$null_dispatching_priority;
    max_swapped_dispatching_prio := jmc$null_dispatching_priority;
    maximum_swapped_job_priority := 0;
    maximum_queued_job_priority := 0;
    none_left := FALSE;

    IF examine_input_queue AND jmv$refresh_job_candidates THEN
      jmp$refresh_job_candidates;
    IFEND;

    { Retrieve the highest priority candidate among the queued jobs.

    FOR job_class := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
      IF jmv$candidate_queued_jobs [job_class].candidate_available AND
            NOT (jmv$job_class_table_p^ [job_class].initial_service_class_index IN
            activation_violation_classes) THEN
        dispatching_priority := jmv$service_classes [jmv$job_class_table_p^ [job_class].
              initial_service_class_index]^.attributes.dispatching_control [jmc$min_dispatching_control].
              dispatching_priority;
        IF NOT jmv$idle_dispatching_controls.controls [dispatching_priority].blocked THEN
          initiation_age_interval := jmv$job_class_table_p^ [job_class].initiation_age_interval;
          IF initiation_age_interval <> jmc$unlimited_prio_age_interval THEN
            age_interval := (current_time - jmv$candidate_queued_jobs [job_class].job_submission_time) DIV
                  initiation_age_interval;
          ELSE
            age_interval := 0; { no aging
          IFEND;
          job_priority := age_interval * jmv$job_class_table_p^ [job_class].selection_priority.increment +
                jmv$job_class_table_p^ [job_class].selection_priority.initial;
          IF job_priority > jmv$job_class_table_p^ [job_class].selection_priority.maximum THEN
            job_priority := jmv$job_class_table_p^ [job_class].selection_priority.maximum;
          IFEND;
          IF (dispatching_priority > max_queued_dispatching_prio) OR
                ((dispatching_priority = max_queued_dispatching_prio) AND
                (job_priority > maximum_queued_job_priority)) THEN
            best_queued_node.dispatching_priority := dispatching_priority;
            best_queued_node.priority := job_priority;
            best_queued_node.ws := jmv$job_class_table_p^ [job_class].initial_working_set;
            best_queued_node.qtype := queued_thd;
            best_queued_node.job_class := job_class;
            max_queued_dispatching_prio := dispatching_priority;
            maximum_queued_job_priority := job_priority;
            best_queued_class := jmv$job_class_table_p^ [job_class].initial_service_class_index;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

    { Retrieve the highest priority candidate among the swapped jobs.

    FOR service_class := jmc$system_service_class TO jmv$max_service_class_in_use DO
      sc_ijlo := jmv$swapin_candidate_queue [service_class].swapin_candidate_queue;
      IF (sc_ijlo <> jmv$system_ijl_ordinal) AND
            NOT (service_class IN activation_violation_classes) THEN
        jmp$get_ijle_p (sc_ijlo, sc_ijle_p);
        dispatching_priority := sc_ijle_p^.scheduling_dispatching_priority;
        IF NOT jmv$idle_dispatching_controls.controls [dispatching_priority].blocked THEN
          jmp$adjust_swapin_cand_prio (sc_ijlo, current_time);
          IF (dispatching_priority > max_swapped_dispatching_prio) OR
                ((dispatching_priority = max_swapped_dispatching_prio) AND
                (sc_ijle_p^.job_scheduler_data.priority > maximum_swapped_job_priority)) THEN
            best_swapped_node.qtype := swapped;
            best_swapped_node.dispatching_priority := dispatching_priority;
            best_swapped_node.priority := sc_ijle_p^.job_scheduler_data.priority;
            best_swapped_node.ws := sc_ijle_p^.swap_data.swapped_job_page_count;
            best_swapped_node.ijl_ord := jmv$swapin_candidate_queue [service_class].swapin_candidate_queue;
            max_swapped_dispatching_prio := dispatching_priority;
            maximum_swapped_job_priority := sc_ijle_p^.job_scheduler_data.priority;
            best_swapped_class := service_class;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

    { Pick the highest priority candidate among the highest queued job and the highest swapped job.

    IF (maximum_queued_job_priority = 0) AND (maximum_swapped_job_priority = 0) THEN
      none_left := TRUE;
      RETURN;
    ELSEIF (max_queued_dispatching_prio > max_swapped_dispatching_prio) OR
          ((max_queued_dispatching_prio = max_swapped_dispatching_prio) AND
          (maximum_queued_job_priority >= maximum_swapped_job_priority)) THEN
      best_node := best_queued_node;
      best_class := best_queued_class;
    ELSE
      best_node := best_swapped_node;
      best_class := best_swapped_class;
    IFEND;

  PROCEND select_highest_priority;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$process_activate_job', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$process_activate_job;

    VAR
      approaching_thrashing: boolean,
      current_time: jmt$clock_time,
      examine_input_queue: boolean;

    #KEYPOINT (osk$entry, 0, jmk$process_activate_job);

    jmv$total_pageable_pages := mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon;

    approaching_thrashing := (jmv$total_pageable_pages < jmv$job_scheduler_table.scheduling_memory_levels.
          thrashing);

    IF approaching_thrashing THEN
      jmp$incr_scheduler_statistics (jmc$thrashing_in_activate_jobs);
      jmp$set_sched_thrashing_event;
    ELSE

      examine_input_queue := jmv$job_scheduler_event [jmc$examine_input_queue];
      jmp$reset_activate_events_sels;
      current_time := #FREE_RUNNING_CLOCK (0);

      IF NOT jmv$prevent_activation_of_jobs THEN

        IF jmv$job_scheduler_event [jmc$ready_task_in_job] THEN
          jmp$incr_scheduler_statistics (jmc$ready_task_event_count);
          jmp$find_and_insert_swapin_cand (current_time);
        IFEND;

        activate_jobs (examine_input_queue, current_time);

        jmp$reset_activate_event;
      IFEND;
    IFEND;

    #KEYPOINT (osk$exit, 0, jmk$process_activate_job);

  PROCEND jmp$process_activate_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$process_thrashing', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$process_thrashing;

    VAR
      class_index: jmt$service_class_index,
      current_memory: integer,
      node: jmt$node,
      none_left: boolean,
      reason: jmt$swapout_reasons,
      swap_status: ost$status,
      working_set_size: integer;

    jmp$clear_scheduler_event (jmc$system_is_thrashing);

    current_memory := mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon;

  /pick_thrashing_candidate/
    WHILE (current_memory < mmv$resident_job_target) DO

      { Select a candidate to swap.

      jmp$select_job_for_thrashing (node, class_index, working_set_size, none_left);
      IF none_left THEN
        jmp$incr_scheduler_statistics (jmc$exit_thrashing_none_to_swap);
        EXIT /pick_thrashing_candidate/;
      IFEND;

      reason := jmc$sr_thrashing;
      jmp$perform_physical_swapout (node, reason, class_index, 0, swap_status);
      IF swap_status.normal THEN
        current_memory := current_memory + node.ws;
      IFEND;
    WHILEND /pick_thrashing_candidate/;

    jmp$select_scheduler_short_wait;

  PROCEND jmp$process_thrashing;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$swap_job_for_memory_reserve', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$swap_job_for_memory_reserve;

    VAR
      class: jmt$service_class_index,
      ijl_bi: jmt$ijl_block_index,
      ijl_bn: jmt$ijl_block_number,
      ijle_p: ^jmt$initiated_job_list_entry,
      ijlo: jmt$ijl_ordinal,
      node: jmt$node,
      reason: jmt$swapout_reasons,
      status: ost$status;

    jmp$clear_scheduler_event (jmc$swap_job_for_memory_reserve);

  /search_for_job/
    FOR ijl_bn := LOWERBOUND (jmv$ijl_p.block_p^) TO jmv$ijl_p.max_block_in_use DO
      IF jmv$ijl_p.block_p^ [ijl_bn].index_p <> NIL THEN
        FOR ijl_bi := LOWERVALUE (jmt$ijl_block_index) TO UPPERVALUE (jmt$ijl_block_index) DO
          ijle_p := ^jmv$ijl_p.block_p^ [ijl_bn].index_p^ [ijl_bi];
          IF ijle_p^.memory_reserve_request.swapout_job THEN
            ijlo.block_number := ijl_bn;
            ijlo.block_index := ijl_bi;
            jmp$clear_memory_res_swap_field (ijlo);
            IF (ijle_p^.entry_status = jmc$ies_job_in_memory) THEN
              node.qtype := active;
              node.ijl_ord := ijlo;
              class := ijle_p^.job_scheduler_data.service_class;
              reason := jmc$sr_memory_reserve_request;
              jmp$perform_physical_swapout (node, reason, class, 0, status);
            IFEND;
          IFEND;
        FOREND;
      IFEND;
    FOREND /search_for_job/;

  PROCEND jmp$swap_job_for_memory_reserve;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$swap_jobs_for_lower_maxaj', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$swap_jobs_for_lower_maxaj;

    VAR
      class: jmt$service_class_index,
      class_still_over_limit: boolean,
      excess_active_jobs: integer,
      status: ost$status,
      swap_node: jmt$node;

    build_lower_maxaj_swap_queue;

    class_still_over_limit := FALSE;

    FOR class := jmc$system_service_class TO jmv$max_service_class_in_use DO

      IF jmv$service_classes [class] <> NIL THEN

        excess_active_jobs := jmv$job_counts.service_class_counts [class].scheduler_initiated_jobs -
              jmv$job_counts.service_class_counts [class].swapped_jobs;

      /swapout_jobs/
        WHILE (excess_active_jobs > jmv$service_classes [class]^.attributes.maximum_active_jobs) DO

          { The system job (ajl and ijl = 0) is not initiated by scheduler; therefore it is not counted in the
          { scheduler_initiated_jobs count.  While scheduler_initiatied_jobs is used, the above while loop
          { is okay; if initiated jobs is ever used the following if condition must be checked because the
          { system job cannot be  swapped out. (ie, there will always be 1 system class job active)

          {  IF (class = jmc$system_service_class) AND (excess_active_jobs = 1) THEN
          {    EXIT /swapout_jobs/;
          {  IFEND;

          IF v$active_job_queue_header [class] > 0 THEN
            swap_node := v$active_job_queue_p^ [v$active_job_queue_header [class]].node;
            jmp$perform_physical_swapout (swap_node, jmc$sr_lower_priority, class, 0, status);
            excess_active_jobs := excess_active_jobs - 1;
            delete_active_job_from_q (v$active_job_queue_header [class], class);
          ELSE
            class_still_over_limit := TRUE;
            EXIT /swapout_jobs/;
          IFEND;
        WHILEND /swapout_jobs/;
      IFEND;
    FOREND;

    IF NOT class_still_over_limit THEN
      jmp$clear_scheduler_event (jmc$swap_jobs_for_lower_maxaj);
    IFEND; { Else the event stays set to be processed when scheduler runs again. }

  PROCEND jmp$swap_jobs_for_lower_maxaj;
?? OLDTITLE ??
?? NEWTITLE := 'build_lower_maxaj_swap_queue', EJECT ??

  PROCEDURE build_lower_maxaj_swap_queue;

    VAR
      ajl_index: jmt$ajl_ordinal,
      class: jmt$service_class_index,
      ijl_ord: jmt$ijl_ordinal,
      ijl_p: ^jmt$initiated_job_list_entry,
      index: jmt$active_job_queue_range,
      job_memory: 0 .. osc$max_page_frames,
      temp_node: jmt$node;

    FOR class := jmc$system_service_class TO jmv$max_service_class_in_use DO
      v$active_job_queue_header [class] := 0;
    FOREND;

    v$active_job_queue_free_index := LOWERBOUND (v$active_job_queue_p^);
    v$preemptable_memory := 0;

  /build_active_job_queue/
    FOR ajl_index := LOWERBOUND (jmv$ajl_p^) TO jmv$max_ajl_ordinal_in_use DO
      IF (jmv$ajl_p^ [ajl_index].in_use <> 0) AND (ajl_index <> jmv$system_ajl_ordinal) THEN
        ijl_ord := jmv$ajl_p^ [ajl_index].ijl_ordinal;
        jmp$get_ijle_p (ijl_ord, ijl_p);
        IF ijl_p^.ajl_ordinal = ajl_index THEN
          IF ijl_p^.entry_status = jmc$ies_job_in_memory THEN
            class := ijl_p^.job_scheduler_data.service_class;
            temp_node.qtype := active;
            temp_node.ijl_ord := ijl_ord;
            temp_node.dispatching_priority := ijl_p^.scheduling_dispatching_priority;
            temp_node.priority := ijl_p^.job_scheduler_data.priority;
            temp_node.service_since_swap := ijl_p^.job_scheduler_data.service_accumulator_since_swap;
            jmp$compute_total_memory_used (ijl_p, job_memory);
            temp_node.ws := job_memory;
            insert_active_job_in_queue (temp_node, class);
            v$preemptable_memory := v$preemptable_memory + job_memory;
          IFEND;
        IFEND;
      IFEND;
    FOREND /build_active_job_queue/;

  PROCEND build_lower_maxaj_swap_queue;
?? OLDTITLE ??
?? NEWTITLE := 'build_active_job_queues', EJECT ??

{ PURPOSE:
{   This procedure is used to build a queue of possible preemption (swapout) candidates.
{ DESIGN:
{   All jobs that have a lower dispatching priority than the highest priority swapin candidate
{   or that have an equal dispatching priority and have exceeded guaranteed service and have a
{   lower or equal scheduling priority than the highest priority swapin candidate are queued.

  PROCEDURE build_active_job_queues
    (    highest_priority_swapin_node: jmt$node);

    VAR
      ajl_index: jmt$ajl_ordinal,
      class: jmt$service_class_index,
      class_gsq: jmt$service_accumulator,
      ijl_ord: jmt$ijl_ordinal,
      ijl_p: ^jmt$initiated_job_list_entry,
      index: jmt$active_job_queue_range,
      job_memory: 0 .. osc$max_page_frames,
      temp_node: jmt$node;

    FOR class := jmc$system_service_class TO jmv$max_service_class_in_use DO
      v$active_job_queue_header [class] := 0;
    FOREND;

    v$active_job_queue_free_index := LOWERBOUND (v$active_job_queue_p^);
    v$preemptable_memory := 0;

  /build_active_job_queue/
    FOR ajl_index := LOWERBOUND (jmv$ajl_p^) TO jmv$max_ajl_ordinal_in_use DO
      IF (jmv$ajl_p^ [ajl_index].in_use <> 0) AND (ajl_index <> jmv$system_ajl_ordinal) THEN
        ijl_ord := jmv$ajl_p^ [ajl_index].ijl_ordinal;
        jmp$get_ijle_p (ijl_ord, ijl_p);
        IF ijl_p^.ajl_ordinal = ajl_index THEN
          IF ijl_p^.entry_status = jmc$ies_job_in_memory THEN
            class := ijl_p^.job_scheduler_data.service_class;
            IF ijl_p^.scheduling_dispatching_priority > highest_priority_swapin_node.dispatching_priority THEN
              CYCLE /build_active_job_queue/;
            ELSEIF ijl_p^.scheduling_dispatching_priority = highest_priority_swapin_node.
                  dispatching_priority THEN
              class_gsq := jmv$service_classes [class]^.attributes.guaranteed_service_quantum;
              IF (ijl_p^.job_scheduler_data.service_accumulator_since_swap < class_gsq) OR
                    (ijl_p^.job_scheduler_data.priority > highest_priority_swapin_node.priority) OR
                    (class_gsq = jmc$unlimited_service_accum) THEN
                CYCLE /build_active_job_queue/;
              IFEND;
            IFEND;
            temp_node.qtype := active;
            temp_node.ijl_ord := ijl_ord;
            temp_node.dispatching_priority := ijl_p^.scheduling_dispatching_priority;
            temp_node.priority := ijl_p^.job_scheduler_data.priority;
            temp_node.service_since_swap := ijl_p^.job_scheduler_data.service_accumulator_since_swap;
            jmp$compute_total_memory_used (ijl_p, job_memory);
            temp_node.ws := job_memory;
            insert_active_job_in_queue (temp_node, class);
            v$preemptable_memory := v$preemptable_memory + job_memory;
          IFEND;
        IFEND;
      IFEND;
    FOREND /build_active_job_queue/;

  PROCEND build_active_job_queues;
?? OLDTITLE ??
?? NEWTITLE := 'insert_active_job_in_queue', EJECT ??

{ PURPOSE:
{   This procedure is used to insert jobs into the active job queue.
{ DESIGN:
{   Determine where the new node belongs in the queue.  Lowest dispatching priority jobs are queued
{   first.  If jobs have equal dispatching priority, the one with the lower scheduling priority is
{   queued first. If jobs have equal scheduling priority as well as equal dispatching priority, the
{   one that has used the most service is queued first.

  PROCEDURE insert_active_job_in_queue
    (    new_node: jmt$node;
         class: jmt$service_class_index);

    VAR
      current_index: jmt$active_job_queue_range,
      next_index: jmt$active_job_queue_range,
      new_node_index: jmt$active_job_queue_range,
      status: ost$status;

    new_node_index := v$active_job_queue_free_index;
    v$active_job_queue_free_index := v$active_job_queue_free_index + 1;
    v$active_job_queue_p^ [new_node_index].node := new_node;

    current_index := jmc$null_active_job_queue_link;
    next_index := v$active_job_queue_header [class];

  /find_place_in_queue/
    WHILE next_index <> jmc$null_active_job_queue_link DO
      IF new_node.dispatching_priority > v$active_job_queue_p^ [next_index].node.dispatching_priority THEN
        current_index := next_index;
        next_index := v$active_job_queue_p^ [next_index].link;

      ELSEIF new_node.dispatching_priority = v$active_job_queue_p^ [next_index].node.dispatching_priority THEN
        IF new_node.priority > v$active_job_queue_p^ [next_index].node.priority THEN
          current_index := next_index;
          next_index := v$active_job_queue_p^ [next_index].link;

        ELSEIF new_node.priority < v$active_job_queue_p^ [next_index].node.priority THEN
          EXIT /find_place_in_queue/;

        ELSE { new_node.priority = active queue node.priority }
          IF new_node.service_since_swap < v$active_job_queue_p^ [next_index].node.service_since_swap THEN
            current_index := next_index;
            next_index := v$active_job_queue_p^ [next_index].link;
          ELSE
            EXIT /find_place_in_queue/;
          IFEND;
        IFEND;
      ELSE { new_node.dispatching_priority < active queue node.dispatching_priority }
        EXIT /find_place_in_queue/;
      IFEND;

    WHILEND /find_place_in_queue/;

    IF current_index = jmc$null_active_job_queue_link THEN

      { Insertion is at the head of the queue

      v$active_job_queue_p^ [new_node_index].link := next_index;
      v$active_job_queue_header [class] := new_node_index;
    ELSE

      { Insertion is in the middle or end of the queue

      v$active_job_queue_p^ [current_index].link := new_node_index;
      v$active_job_queue_p^ [new_node_index].link := next_index;
    IFEND;

  PROCEND insert_active_job_in_queue;
?? OLDTITLE ??
?? NEWTITLE := 'delete_active_job_from_q', EJECT ??

  PROCEDURE delete_active_job_from_q
    (    delete_node_index: jmt$active_job_queue_range;
         class: jmt$service_class_index);

    VAR
      current_index: jmt$active_job_queue_range;

    IF (delete_node_index = v$active_job_queue_header [class]) THEN

      { Delete from the head of the queue

      v$active_job_queue_header [class] := v$active_job_queue_p^ [delete_node_index].link;
    ELSE

      { Delete from the middle or end of queue

      current_index := v$active_job_queue_header [class];

    /find_delete_node/
      WHILE (current_index <> delete_node_index) AND (current_index <> jmc$null_active_job_queue_link) DO
        IF v$active_job_queue_p^ [current_index].link = delete_node_index THEN
          v$active_job_queue_p^ [current_index].link := v$active_job_queue_p^ [delete_node_index].link;
          EXIT /find_delete_node/;
        IFEND;
        current_index := v$active_job_queue_p^ [current_index].link;
      WHILEND /find_delete_node/;
    IFEND;

  PROCEND delete_active_job_from_q;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$idling_swap_all_jobs', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$idling_swap_all_jobs;

    VAR
      ajl_index: jmt$ajl_ordinal,
      class: jmt$service_class_index,
      ignore_status: ost$status,
      ijl_ord: jmt$ijl_ordinal,
      ijl_p: ^jmt$initiated_job_list_entry,
      jobs_still_active: boolean,
      log_time: ost$time,
      msg: string (80),
      msg_len: integer,
      next_ijlo: jmt$ijl_ordinal,
      node: jmt$node,
      reason: jmt$swapout_reasons,
      request_block: jmt$rb_scheduler_requests,
      status: ost$status;

    { Clean out the job candidate queue.

    jmp$refresh_job_candidates;

    { Flush jobs in the long wait queue to disk.

    jmp$idle_advance_lw_jobs;

    { Initiate swapping out all jobs.

    jobs_still_active := FALSE;

    { Scan the ajl to find and swap all active jobs.

  /swap_active_jobs_loop/
    FOR ajl_index := LOWERBOUND (jmv$ajl_p^) TO jmv$max_ajl_ordinal_in_use DO
      IF (jmv$ajl_p^ [ajl_index].in_use <> 0) AND (ajl_index <> jmv$system_ajl_ordinal) THEN
        ijl_ord := jmv$ajl_p^ [ajl_index].ijl_ordinal;
        jmp$get_ijle_p (ijl_ord, ijl_p);
        IF ijl_p^.ajl_ordinal = ajl_index THEN
          IF ((ijl_p^.entry_status = jmc$ies_job_in_memory) OR
                (ijl_p^.entry_status = jmc$ies_swapin_in_progress)) AND NOT (ijl_p^.hung_task_in_job) THEN
            node.qtype := active;
            node.ijl_ord := ijl_ord;
            node.priority := ijl_p^.job_scheduler_data.priority;
            class := ijl_p^.job_scheduler_data.service_class;
            reason := jmc$sr_idling_system_swapout;
            jmp$perform_physical_swapout (node, reason, class, 0, status);
            jobs_still_active := TRUE;
          IFEND;
        IFEND;
      IFEND;
    FOREND /swap_active_jobs_loop/;

    { Check the swapping queues to be sure all jobs have been written to disk.

    IF (jsv$ijl_swap_queue_list [jsc$isqi_swapped_io_not_init].forward_link <> jmv$null_ijl_ordinal) OR
          (jsv$ijl_swap_queue_list [jsc$isqi_swapped_io_completed].forward_link <> jmv$null_ijl_ordinal) THEN

      IF (jsv$ijl_swap_queue_list [jsc$isqi_swapped_io_completed].forward_link <> jmv$null_ijl_ordinal) THEN
        request_block.reqcode := syc$rc_job_scheduler_request;
        request_block.sub_reqcode := jmc$src_idling_advance_swaps;
        i#call_monitor (#LOC (request_block), #SIZE (request_block));
      IFEND;
      jobs_still_active := TRUE;
      jmp$select_scheduler_short_wait;
    IFEND;

    next_ijlo := jsv$ijl_swap_queue_list [jsc$isqi_swapping].forward_link;

  /swap_queue_loop/
    WHILE next_ijlo <> jmv$null_ijl_ordinal DO
      jmp$get_ijle_p (next_ijlo, ijl_p);
      IF (ijl_p^.swap_status = jmc$iss_job_allocate_swap_file) AND
            ((#FREE_RUNNING_CLOCK (0) - ijl_p^.swap_data.timestamp) > 30000000) THEN
        IF NOT ijl_p^.unable_to_swap_idle_flag THEN
          STRINGREP (msg, msg_len, 'Job recovery disabled; unable to swap job: ',
                ijl_p^.system_supplied_name);
          lgp$add_entry_to_system_log (pmc$msg_origin_system, msg, log_time, status);
          dmp$set_eoi (ijl_p^.swap_data.swap_file_sfid, 0, status);
          jmp$set_unable_to_swap_flag (ijl_ord);
          dpp$put_critical_message (msg (1, msg_len), status);
          syp$disable_job_recovery;
          next_ijlo := ijl_p^.swap_queue_link.forward_link;
        ELSE
          next_ijlo := ijl_p^.swap_queue_link.forward_link;
        IFEND;
      ELSEIF NOT (ijl_p^.hung_task_in_job) THEN
        jobs_still_active := TRUE;
        jmp$select_scheduler_short_wait;
        EXIT /swap_queue_loop/;
      ELSE
        next_ijlo := ijl_p^.swap_queue_link.forward_link;
      IFEND;
    WHILEND /swap_queue_loop/;

    IF NOT jobs_still_active THEN

      { Update swapfiles in the swapped out queue with lastest IJL information, monitor and system flags from
      { the PTL, and mainframe linked signals in case we need to do a job recovery deadstart after the idle.

      next_ijlo := jsv$ijl_swap_queue_list [jsc$isqi_swapped_out].forward_link;
      WHILE next_ijlo <> jmv$null_ijl_ordinal DO
        jmp$get_ijle_p (next_ijlo, ijl_p);
        jmp$idling_swapfile_update (next_ijlo, status);
        IF NOT status.normal THEN
          osp$generate_log_message ($pmt$ascii_logset [pmc$system_log], status, ignore_status);
          STRINGREP (msg, msg_len, 'Job recovery disabled; swapfile not updated: ',
                ijl_p^.system_supplied_name);
          lgp$add_entry_to_system_log (pmc$msg_origin_system, msg, log_time, ignore_status);
          dpp$put_critical_message (msg (1, msg_len), ignore_status);
          syp$disable_job_recovery;
        IFEND;
        next_ijlo := ijl_p^.swap_queue_link.forward_link;
      WHILEND;
      jmp$set_all_jobs_swapped_var;
      jmp$clear_scheduler_event (jmc$system_is_idling);
    IFEND;

  PROCEND jmp$idling_swap_all_jobs;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$initialize_sched_ring_2', EJECT ??

{ PURPOSE:
{   This procedure allocates space for the active job queue.

  PROCEDURE [XDCL, #GATE] jmp$initialize_sched_ring_2;

    ALLOCATE v$active_job_queue_p: [1 .. mtv$mx_ajl_entries] IN osv$job_pageable_heap^;

  PROCEND jmp$initialize_sched_ring_2;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$select_reset_disp_pr_r2', EJECT ??

*copy jmh$select_reset_disp_pr_r2

  PROCEDURE [XDCL, #GATE] jmp$select_reset_disp_pr_r2;

    VAR
      ignore_status: ost$status,
      null_dispatching_info: jmt$dispatching_control_info;

    IF jmv$jcb.system_name = jmv$system_job_ssn THEN
      RETURN;
    IFEND;
    IF jmv$jcb.ijle_p^.interactive_task_gtid <> tmv$null_global_task_id THEN
      jmp$change_dispatching_prior_r1 (tmc$cpo_interactive_command, jmv$jcb.ijl_ordinal, jmv$jcb.system_name,
        null_dispatching_info, ignore_status);
    ELSE
      jmp$select_reset_disp_pr;
    IFEND;

  PROCEND jmp$select_reset_disp_pr_r2;
?? OLDTITLE ??
MODEND jmm$job_scheduler_ring_2;
*DECK DECK=JMM$JOB_SCHEDULER_RING_3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : Job Scheduler Monitor and Ring 3 Procedures' ??
MODULE jmm$job_scheduler_ring_3;


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc jmv$job_class_table_p
*copyc jmv$job_counts
*copyc jmv$job_sched_events_selected
*copyc jmv$job_scheduler_event
*copyc jmv$job_scheduler_table
*copyc jmv$next_job_cand_refresh_time
*copyc jmv$sched_service_calc_time
*copyc jmv$system_job_ssn
*copyc jmv$time_to_wake_scheduler
*copyc mmv$resident_job_target

*copyc avp$system_operator
*copyc jmp$call_job_swapper
*copyc jmp$change_dispatching_prior_r1
*copyc jmp$clear_scheduler_event
*copyc jmp$get_job_ijl_ordinal
*copyc jmp$get_ijle_p
*copyc jmp$idling_swap_all_jobs
*copyc jmp$initialize_sched_ring_2
*copyc jmp$initialize_sched_variables
*copyc jmp$incr_scheduler_statistics
*copyc jmp$process_activate_job
*copyc jmp$process_change_dispatching
*copyc jmp$process_damaged_jobs
*copyc jmp$process_operator_requests
*copyc jmp$process_subsyst_prio_change
*copyc jmp$process_terminated_job
*copyc jmp$process_thrashing
*copyc jmp$queue_operator_request
*copyc jmp$recover_swapin_jobs
*copyc jmp$reset_time_to_wake_sched
*copyc jmp$scan_ajl_for_service
*copyc jmp$select_reset_disp_pr
*copyc jmp$set_examine_input_event
*copyc jmp$set_sched_service_calc_time
*copyc jmp$set_scheduler_time_event
*copyc jmp$swap_job_for_memory_reserve
*copyc jmp$swap_jobs_for_lower_maxaj
*copyc jmp$test_for_system_idle_r1
*copyc osp$generate_log_message
*copyc osp$recovery_swap_io_error
*copyc osp$set_status_abnormal
*copyc osp$verify_system_privilege
*copyc pmp$get_executing_task_gtid
*copyc pmp$wait
*copyc tmp$save_system_task_id
*copyc tmp$clear_wait_inhibited
*copyc tmp$set_task_priority

{?? PUSH(LISTEXT := ON) ??

*copyc cld$value
*copyc fst$path
*copyc jmc$class_names
*copyc jmc$special_dispatch_priorities
*copyc jme$job_scheduler_conditions
*copyc jme$queued_file_conditions
*copyc jmt$ajl_ordinal
*copyc jmt$dispatching_control_info
*copyc jmt$dispatching_priority
*copyc jmt$job_class_set
*copyc jmt$job_priority
*copyc jmt$job_scheduler_statistics
*copyc jmt$job_scheduler_table
*copyc jmt$service_class_set
*copyc jmt$system_supplied_name
*copyc ofe$error_codes
*copyc oss$task_shared
*copyc ost$global_task_id
*copyc ost$status
*copyc tmc$wait_times

{?? POP ??

?? TITLE := 'JMP$JOB_SCHEDULER_MONITOR', EJECT ??


  PROCEDURE [XDCL] jmp$job_scheduler_monitor;

{
{ PURPOSE:
{   To process job scheduler events.
{ DESIGN:
{   Scheduler processes all events that are set and selected.  When event processing is
{   completed, scheduler goes into a wait.  The next time an event is set, scheduler will
{   be readied.

    VAR
      wait_time: integer,
      was_set: boolean,
      local_status: ost$status,
      global_task_id: ost$global_task_id,
      processed_event_this_pass: boolean,
      processed_thrashing_this_pass: boolean;

    tmp$set_task_priority (jmc$priority_job_scheduler, 0, local_status);
    tmp$save_system_task_id (tmc$stid_job_scheduler, TRUE, local_status);

    jmp$initialize_sched_variables;
    jmp$initialize_sched_ring_2;
    jmp$reset_time_to_wake_sched;

{  we are now  done with initialization

    jmp$set_sched_service_calc_time;

    WHILE TRUE DO
      processed_thrashing_this_pass := FALSE;

      REPEAT

        processed_event_this_pass := FALSE;
        tmp$clear_wait_inhibited (was_set);

        IF jmv$job_scheduler_event [jmc$call_job_swapper] AND
              jmv$job_sched_events_selected [jmc$call_job_swapper] THEN
          jmp$incr_scheduler_statistics (jmc$advance_swap_event_count);
          processed_event_this_pass := TRUE;
          jmp$call_job_swapper;
        IFEND;

        IF jmv$job_scheduler_event [jmc$job_terminated] AND
              jmv$job_sched_events_selected [jmc$job_terminated] THEN
          jmp$incr_scheduler_statistics (jmc$job_terminated_event_count);
          processed_event_this_pass := TRUE;
          jmp$process_terminated_job;
        IFEND;

        IF jmv$job_scheduler_event [jmc$recovery_swap_io_error] AND
              jmv$job_sched_events_selected [jmc$recovery_swap_io_error] THEN
          jmp$incr_scheduler_statistics (jmc$recovery_swap_error);
          processed_event_this_pass := TRUE;
          jmp$process_recovery_swap_error;
        IFEND;

        IF jmv$job_scheduler_event [jmc$recovery_job_damaged] AND
              jmv$job_sched_events_selected [jmc$recovery_job_damaged] THEN
          processed_event_this_pass := TRUE;
          jmp$process_damaged_jobs;
        IFEND;

        IF (#FREE_RUNNING_CLOCK (0)) >= jmv$sched_service_calc_time THEN
          jmp$scan_ajl_for_service;
          jmp$set_sched_service_calc_time;
        IFEND;

        IF jmv$job_scheduler_event [jmc$system_is_idling] AND
              jmv$job_sched_events_selected [jmc$system_is_idling] THEN
          jmp$incr_scheduler_statistics (jmc$idle_system_event_count);
          jmp$idling_swap_all_jobs;
        IFEND;

        IF jmv$job_scheduler_event [jmc$recovery_swapin] AND
              jmv$job_sched_events_selected [jmc$recovery_swapin] THEN
          jmp$incr_scheduler_statistics (jmc$recovery_swapin_event_count);
          jmp$recover_swapin_jobs;
        IFEND;

        IF jmv$job_scheduler_event [jmc$swap_jobs_for_lower_maxaj] AND
              jmv$job_sched_events_selected [jmc$swap_jobs_for_lower_maxaj] THEN
          jmp$incr_scheduler_statistics (jmc$lower_maxaj_event_count);
          jmp$swap_jobs_for_lower_maxaj;
        IFEND;

        IF jmv$job_scheduler_event [jmc$change_dispatching_controls] AND
              jmv$job_sched_events_selected [jmc$change_dispatching_controls] THEN
          jmp$incr_scheduler_statistics (jmc$change_dispatching);
          jmp$process_change_dispatching;
        IFEND;

        IF jmv$job_scheduler_event [jmc$subsystem_priority_change] AND
              jmv$job_sched_events_selected [jmc$subsystem_priority_change] THEN
          jmp$incr_scheduler_statistics (jmc$change_subsystem_priority);
          jmp$process_subsyst_prio_change;
        IFEND;

        IF jmv$job_scheduler_event [jmc$swap_job_for_memory_reserve] AND
              jmv$job_sched_events_selected [jmc$swap_job_for_memory_reserve] THEN
          jmp$incr_scheduler_statistics (jmc$memory_reserve_event_count);
          jmp$swap_job_for_memory_reserve;
        IFEND;

        IF jmv$job_scheduler_event [jmc$system_is_thrashing] AND
              jmv$job_sched_events_selected [jmc$system_is_thrashing] THEN
          jmp$incr_scheduler_statistics (jmc$system_thrashing_event_cnt);
          processed_event_this_pass := TRUE;
          jmp$process_thrashing;
          processed_thrashing_this_pass := TRUE;
        IFEND;

        IF jmv$job_scheduler_event [jmc$process_operator_request] AND
              jmv$job_sched_events_selected [jmc$process_operator_request] THEN
          jmp$incr_scheduler_statistics (jmc$operator_request_event_cnt);
          processed_event_this_pass := TRUE;

          jmp$clear_scheduler_event (jmc$process_operator_request);

          REPEAT
            jmp$process_operator_requests (local_status);

            IF NOT local_status.normal THEN
              osp$generate_log_message ($pmt$ascii_logset [pmc$system_log], local_status, local_status);
              local_status.normal := FALSE;
            IFEND;

          UNTIL local_status.normal


        IFEND;

        IF #FREE_RUNNING_CLOCK (0) >= jmv$next_job_cand_refresh_time THEN
          jmp$set_examine_input_event;
        IFEND;

        IF (NOT processed_thrashing_this_pass) AND ((jmv$job_scheduler_event [jmc$examine_input_queue] AND
              jmv$job_sched_events_selected [jmc$examine_input_queue]) OR
              (jmv$job_scheduler_event [jmc$examine_swapin_queue] AND
              jmv$job_sched_events_selected [jmc$examine_swapin_queue]) OR
              (jmv$job_scheduler_event [jmc$scheduler_wake_time] AND
              jmv$job_sched_events_selected [jmc$scheduler_wake_time]) OR
              (jmv$job_scheduler_event [jmc$needed_memory_available] AND
              jmv$job_sched_events_selected [jmc$needed_memory_available]) OR
              (jmv$job_scheduler_event [jmc$needed_ajlo_available] AND
              jmv$job_sched_events_selected [jmc$needed_ajlo_available])) THEN
          jmp$incr_scheduler_statistics (jmc$activate_event_count);
          processed_event_this_pass := TRUE;
          jmp$process_activate_job;
        IFEND;

      UNTIL NOT processed_event_this_pass;

      IF jmv$next_job_cand_refresh_time < jmv$time_to_wake_scheduler THEN
        wait_time := (jmv$next_job_cand_refresh_time - #FREE_RUNNING_CLOCK (0)) DIV 1000;
      ELSE
        wait_time := (jmv$time_to_wake_scheduler - #FREE_RUNNING_CLOCK (0)) DIV 1000;
      IFEND;
      IF wait_time > 500 THEN
        jmp$incr_scheduler_statistics (jmc$long_wait);
      ELSE
        jmp$incr_scheduler_statistics (jmc$short_wait);
      IFEND;

      IF wait_time > 0 THEN
        pmp$wait (wait_time, wait_time);
        IF jmv$time_to_wake_scheduler < #FREE_RUNNING_CLOCK (0) THEN
          jmp$set_scheduler_time_event;
        IFEND;
      ELSE
        IF jmv$job_sched_events_selected [jmc$scheduler_wake_time] THEN
          jmp$set_scheduler_time_event;
        ELSE {system is idle--reset wake time to wake scheduler in the future
          jmp$reset_time_to_wake_sched;
        IFEND;
      IFEND;

    WHILEND;
  PROCEND jmp$job_scheduler_monitor;

?? TITLE := 'jmp$process_recovery_swap_error', EJECT ??

  PROCEDURE jmp$process_recovery_swap_error;

    jmp$clear_scheduler_event (jmc$recovery_swap_io_error);
    osp$recovery_swap_io_error;

  PROCEND jmp$process_recovery_swap_error;

?? TITLE := '[XDCL, #GATE] jmp$reset_dispatching_priority', EJECT ??

{ PURPOSE:
{   To reset the dispatching control information for interactive jobs.
{ DESIGN:
{   This procedure is called when command processing gets input from an interactive terminal.

  PROCEDURE [XDCL, #GATE] jmp$reset_dispatching_priority;

    VAR
      null_dispatching_info: jmt$dispatching_control_info,
      status: ost$status;

    status.normal := TRUE;
    IF jmv$jcb.system_name = jmv$system_job_ssn THEN
      RETURN;
    IFEND;
    jmp$change_dispatching_prior_r1 (tmc$cpo_interactive_command, jmv$jcb.ijl_ordinal, jmv$jcb.system_name,
          null_dispatching_info, status);

  PROCEND jmp$reset_dispatching_priority;
?? TITLE := '[XDCL] jmp$restore_dispatching_control', EJECT ??

{ PURPOSE:
{   To restore a job's dispatching control information.
{ DESIGN:
{   This procedure is called after a user interrupt to restore the dispatching control
{   information a job was exeuting with at the time the interrupt occurred.

  PROCEDURE [XDCL] jmp$restore_dispatching_control
    (    dispatching_control_info: jmt$dispatching_control_info);

    VAR
      status: ost$status;

    status.normal := TRUE;
    IF jmv$jcb.system_name = jmv$system_job_ssn THEN
      RETURN;
    IFEND;
    jmp$change_dispatching_prior_r1 (tmc$cpo_interrupt_restore, jmv$jcb.ijl_ordinal, jmv$jcb.system_name,
          dispatching_control_info, status);

  PROCEND jmp$restore_dispatching_control;

?? OLDTITLE, NEWTITLE := '[XDCL, #GATE]  JMP$SELECT_RESET_DISP_PR_R3', EJECT ??
*copy jmh$select_reset_disp_pr_r3

  PROCEDURE [XDCL, #GATE] jmp$select_reset_disp_pr_r3;

    jmp$select_reset_disp_pr;
  PROCEND jmp$select_reset_disp_pr_r3;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$swapout_job', EJECT ??
*copy jmh$swapout_job

{ PURPOSE:
{   This procedure is the ring 3 code for the operator SWAPOUT command.
{ DESIGN:
{   The swapout request must be queued for the job scheduler to process (the swapout
{   must be synchronized by scheduler).

  PROCEDURE [XDCL, #GATE] jmp$swapout_job
    (    job_name: ost$name;
         disable_recovery: boolean;
     VAR status: ost$status);

    VAR
      ijl_ordinal: jmt$ijl_ordinal,
      privileged_job: boolean,
      system_supplied_name: jmt$system_supplied_name;

    privileged_job := avp$system_operator ();
    IF NOT privileged_job THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_operator', status);
      RETURN;
    IFEND;

    jmp$get_job_ijl_ordinal (job_name, privileged_job, ijl_ordinal, system_supplied_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$queue_operator_request (jmc$or_swapout, ijl_ordinal, system_supplied_name,
          jmc$null_dispatching_priority, disable_recovery, status);

  PROCEND jmp$swapout_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$swapin_job', EJECT ??
*copy jmh$swapin_job

{ PURPOSE:
{   This procedure is the ring 3 code for the operator SWAPIN command.
{ DESIGN:
{   The swapin request must be queued for the job scheduler to process (the swapin
{   must be synchronized by scheduler).

  PROCEDURE [XDCL, #GATE] jmp$swapin_job
    (    job_name: clt$value;
     VAR status: ost$status);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      ijl_ordinal: jmt$ijl_ordinal,
      privileged_job: boolean,
      system_supplied_name: jmt$system_supplied_name;

    privileged_job := avp$system_operator ();
    IF NOT privileged_job THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_operator', status);
      RETURN;
    IFEND;

    jmp$get_job_ijl_ordinal (job_name.name.value, privileged_job, ijl_ordinal, system_supplied_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$get_ijle_p (ijl_ordinal, ijle_p);
    IF ijle_p^.entry_status = jmc$ies_job_damaged THEN
      osp$set_status_abnormal ('JM', jme$job_damaged_during_recovery, job_name.name.value, status);
      RETURN;
    IFEND;

    jmp$queue_operator_request (jmc$or_swapin, ijl_ordinal, system_supplied_name,
          jmc$null_dispatching_priority, {disable_recovery} FALSE, status);

  PROCEND jmp$swapin_job;
?? TITLE := 'JMP$TEST_FOR_SYSTEM_IDLE', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$test_for_system_idle
    (VAR status: ost$status);

    status.normal := TRUE;
    jmp$test_for_system_idle_r1 (status);

  PROCEND jmp$test_for_system_idle;
MODEND jmm$job_scheduler_ring_3;
*DECK DECK=JMM$JOB_SCHEDULER_UTILITY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : Job Scheduler Ring 1 Utilities' ??
MODULE jmm$job_scheduler_utility;

{ PURPOSE:
{   This module contains the ring 1 interfaces for the MANAGE_ACTIVE_SCHEDULING
{   utility, job priority control, and job swapping control.
{ DESIGN:
{   This module contains interfaces which install a new scheduling profile in
{   the scheduler tables, update an existing profile in the tables, and return
{   the contents of these tables.  It also contains interfaces which manage
{   the priority of a job and prevent a job from swapping when it is terminating.
{ NOTES:
{   Applicable documents for the MANAGE_ACTIVE_SCHEDULING utility include:
{   NOS/VE Job Schedulung Phase II ERS, DCS# A7594
{   NOS/VE Job Scheduling Phase IIA Increment Plan, DCS# ARH7808

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??


?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc jmc$job_management_id
*copyc jmc$sched_profile_deadstart_id
*copyc jmc$special_dispatch_priorities
*copyc jmc$status_message_text
*copyc jme$job_scheduler_conditions
*copyc jme$queued_file_conditions
*copyc jmt$application_attributes
*copyc jmt$application_name
*copyc jmt$application_set
*copyc jmt$application_table
*copyc jmt$change_dispatching_list
*copyc jmt$class_kind
*copyc jmt$defined_classes
*copyc jmt$dispatching_control
*copyc jmt$dispatching_control_info
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc jmt$job_category_data
*copyc jmt$job_class_set
*copyc jmt$job_priority
*copyc jmt$job_scheduler_statistics
*copyc jmt$maximum_active_jobs
*copyc jmt$node
*copyc jmt$rb_scheduler_requests
*copyc jmt$service_class_table
*copyc jmt$system_supplied_name
*copyc jmt$working_set_size
*copyc mmt$rb_ring1_segment_request
*copyc osd$integer_limits
*copyc ost$binary_unique_name
*copyc ost$global_task_id
*copyc ost$status
*copyc sft$file_space_limit_kind
*copyc tmt$change_priority_origin
*copyc tmt$rb_update_job_task_enviro
?? POP ??
*copyc dmp$allocate_file_space_r1
*copyc dmp$set_eoi
*copyc jmp$jm_change_ijl_entry_status
*copyc jmp$check_active_job_limits
*copyc jmp$clear_scheduler_event
*copyc jmp$delete_swapin_candidate
*copyc jmp$get_ijle_p
*copyc jmp$reorder_swapin_queues
*copyc jmp$reset_max_class_working_set
*copyc jmp$set_class_below_maxaj_limit
*copyc jmp$set_event_and_ready_sched
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$clear_mainframe_sig_lock
*copyc osp$generate_unique_binary_name
*copyc osp$get_locked_variable_value
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$system_error
*copyc pmp$delay
*copyc pmp$get_executing_task_gtid
*copyc pmp$zero_out_table
*copyc syp$set_status_from_mtr_status
*copyc tmp$ready_system_task1
*copyc i#call_monitor
*copyc jmv$application_table_p
*copyc jmv$candidate_queued_jobs
*copyc jmv$change_dispatching_list
*copyc jmv$classes_in_maxaj_limit_wait
*copyc jmv$default_job_class_attr
*copyc jmv$default_service_class_attr
*copyc jmv$highest_rank_job_class
*copyc jmv$ijl_entry_status_statistics
*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc jmv$job_category_data
*copyc jmv$job_class_table_p
*copyc jmv$job_counts
*copyc jmv$job_sched_serv_class_stats
*copyc jmv$job_scheduler_event
*copyc jmv$job_scheduler_table
*copyc jmv$maximum_job_class_in_use
*copyc jmv$max_class_working_set
*copyc jmv$max_service_class_in_use
*copyc jmv$maximum_profile_index
*copyc jmv$profile_index_to_job_class
*copyc jmv$refresh_job_candidates
*copyc jmv$sched_profile_is_loading
*copyc jmv$scheduler_tables_access
*copyc jmv$scheduling_utility_usage
*copyc jmv$service_classes
*copyc osv$mainframe_pageable_heap
*copyc osv$mainframe_wired_heap
*copyc pmv$quantum
*copyc tmv$dual_state_dispatch_prior
*copyc tmv$null_global_task_id
*copyc tmv$ptl_p

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    jmv$leveler_profile_loading: [XDCL, #GATE, oss$mainframe_pageable] boolean := FALSE,
    jmv$job_scheduler_statistics: [XDCL, #GATE, oss$mainframe_pageable] jmt$job_scheduler_statistics :=
          [REP 41 of 0];

?? TITLE := 'delete_classes_from_tables', EJECT ??

{ PURPOSE:
{   The purpose of this request is to delete job classes, service classes, and
{   applications from the scheduler tables used by the job scheduler.
{ DESIGN:
{   Job classes and applications are deleted first since they may reference
{   service classes.  Then service classes are deleted.  Job classes being
{   deleted are first removed from the thread of ranked job classes.  For
{   coding convenience, the index of the highest rank job class is stored in
{   the next_rank_class field of the UNASSIGNED job class since this is never
{   a ranked job class.  IF a service class being deleted is still referenced
{   by a job class, another service class, or application , these references
{   are replaced by the UNASSIGNED service class, the parent service class,
{   and the null service class, respectively.  These references will be
{   resolved when the new profile is installed in the tables.
{ NOTES:
{   Data validity checks are made and access to the scheduler tables is
{   interlocked prior to calling this procedure.

  PROCEDURE delete_classes_from_tables
    (    deleted_job_classes: jmt$job_class_set;
         deleted_service_classes: jmt$service_class_set;
         deleted_applications: jmt$application_set);

    VAR
      application_index: jmt$application_index,
      current_rank_class: jmt$job_class,
      job_class_index: jmt$job_class,
      next_rank_class: jmt$job_class,
      service_class_index: jmt$service_class_index;

{ Delete the job classes.

    IF deleted_job_classes <> $jmt$job_class_set [] THEN

{ Remove job classes which are to be deleted from the thread of ranked job classes.

      current_rank_class := jmc$unassigned_job_class;
      WHILE current_rank_class <> jmc$null_job_class DO
        next_rank_class := jmv$job_class_table_p^ [current_rank_class].next_rank_class;
        WHILE (next_rank_class <> jmc$null_job_class) AND (next_rank_class IN deleted_job_classes) DO
          next_rank_class := jmv$job_class_table_p^ [next_rank_class].next_rank_class;
          jmv$job_class_table_p^ [current_rank_class].next_rank_class := next_rank_class;
        WHILEND;
        current_rank_class := next_rank_class;
      WHILEND;
      jmv$highest_rank_job_class := jmv$job_class_table_p^ [jmc$unassigned_job_class].next_rank_class;

{ Now delete the job classes.

      FOR job_class_index := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
        IF job_class_index IN deleted_job_classes THEN
          jmv$job_class_table_p^ [job_class_index].defined := FALSE;
          IF jmv$job_class_table_p^ [job_class_index].prolog_p <> NIL THEN
            FREE jmv$job_class_table_p^ [job_class_index].prolog_p IN osv$mainframe_pageable_heap^;
          IFEND;
          IF jmv$job_class_table_p^ [job_class_index].epilog_p <> NIL THEN
            FREE jmv$job_class_table_p^ [job_class_index].epilog_p IN osv$mainframe_pageable_heap^;
          IFEND;

          jmv$job_counts.job_class_counts [job_class_index].completed_jobs := 0;

{         pmp$zero_out_table (^jmv$job_class_table_p^ [job_class_index],
{               #SIZE (jmv$job_class_table_p^ [job_class_index]));

          IF job_class_index = jmv$maximum_job_class_in_use THEN
            WHILE NOT jmv$job_class_table_p^ [jmv$maximum_job_class_in_use].defined DO
              jmv$maximum_job_class_in_use := jmv$maximum_job_class_in_use - 1;
            WHILEND;
          IFEND;
        IFEND;
      FOREND;

    IFEND;

{ Delete the applications.

    IF deleted_applications <> $jmt$application_set [] THEN
      IF jmv$application_table_p <> NIL THEN
        FOR application_index := 1 TO UPPERBOUND (jmv$application_table_p^) DO
          IF application_index IN deleted_applications THEN
            jmv$application_table_p^ [application_index].defined := FALSE;
          IFEND;
        FOREND;
      IFEND;
    IFEND;

{ Delete the service classes.

    IF deleted_service_classes <> $jmt$service_class_set [] THEN

{ Remove references by job classes to service classes which are to be deleted.

      FOR job_class_index := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
        IF jmv$job_class_table_p^ [job_class_index].defined THEN
          IF jmv$job_class_table_p^ [job_class_index].initial_service_class_index IN
                deleted_service_classes THEN
            jmv$job_class_table_p^ [job_class_index].initial_service_class_index :=
                  jmc$unassigned_service_class;
          IFEND;
        IFEND;
      FOREND;

{ Remove references by service classes to service classes which are to be deleted.

      FOR service_class_index := jmc$system_service_class TO jmv$max_service_class_in_use DO
        IF (jmv$service_classes [service_class_index] <> NIL) AND
              jmv$service_classes [service_class_index]^.attributes.defined THEN
          IF jmv$service_classes [service_class_index]^.attributes.next_service_class_index IN
                deleted_service_classes THEN
            jmv$service_classes [service_class_index]^.attributes.next_service_class_index :=
                  service_class_index;
          IFEND;
        IFEND;
      FOREND;

{ Remove references by applications to service classes which are to be deleted.

      IF jmv$application_table_p <> NIL THEN
        FOR application_index := 1 TO UPPERBOUND (jmv$application_table_p^) DO
          IF jmv$application_table_p^ [application_index].defined THEN
            IF jmv$application_table_p^ [application_index].service_class_index IN
                  deleted_service_classes THEN
              jmv$application_table_p^ [application_index].service_class_index :=
                    jmc$unspecified_service_class;
            IFEND;
          IFEND;
        FOREND;
      IFEND;

{ Now delete the service classes.

      FOR service_class_index := jmc$system_service_class TO jmv$max_service_class_in_use DO
        IF service_class_index IN deleted_service_classes THEN
          jmv$service_classes [service_class_index]^.attributes.defined := FALSE;

          pmp$zero_out_table (^jmv$job_sched_serv_class_stats [service_class_index],
                #SIZE (jmv$job_sched_serv_class_stats [service_class_index]));
          pmp$zero_out_table (^jmv$service_classes [service_class_index]^.
                statistics, #SIZE (jmv$service_classes [service_class_index]^.statistics));

        IFEND;
      FOREND;
      WHILE (jmv$service_classes [jmv$max_service_class_in_use] = NIL) OR
            NOT jmv$service_classes [jmv$max_service_class_in_use]^.attributes.defined DO
        jmv$max_service_class_in_use := jmv$max_service_class_in_use - 1;
      WHILEND;

    IFEND;

  PROCEND delete_classes_from_tables;
?? TITLE := 'install_application_table', EJECT ??

{ PURPOSE:
{   The purpose of this request is to install a given list of applications
{   in the application table for application scheduling.
{ DESIGN:
{   The current application table is completely replaced with the given list of
{   applications.
{ NOTES:
{   Data validity checks are made and access to the scheduler tables is
{   interlocked prior to calling this procedure.

  PROCEDURE install_application_table
    (    application_entries_p: ^jmt$application_table);

    VAR
      application_index: jmt$application_index;

    IF jmv$application_table_p <> NIL THEN
      FREE jmv$application_table_p IN osv$mainframe_pageable_heap^;
    IFEND;
    IF application_entries_p <> NIL THEN
      ALLOCATE jmv$application_table_p: [1 .. UPPERBOUND (application_entries_p^)] IN
            osv$mainframe_pageable_heap^;
      jmv$application_table_p^ := application_entries_p^;
      FOR application_index := 1 TO UPPERBOUND (application_entries_p^) DO
        jmv$application_table_p^ [application_index].defined := TRUE;
      FOREND;
    IFEND;

  PROCEND install_application_table;
?? TITLE := 'install_job_category_data', EJECT ??

{ PURPOSE:
{   The purpose of this request is to install a given list of job category
{   data for job submission and scheduling.
{ DESIGN:
{   The current job category data is completely replaced with the given list of
{   data.
{ NOTES:
{   Data validity checks are made and access to the scheduler tables is
{   interlocked prior to calling this procedure.

  PROCEDURE install_job_category_data
    (    category_data: jmt$job_category_data);

    IF jmv$job_category_data.item_list <> NIL THEN
      FREE jmv$job_category_data.item_list IN osv$mainframe_pageable_heap^;
    IFEND;

    jmv$job_category_data := category_data;
    IF category_data.item_list <> NIL THEN
      ALLOCATE jmv$job_category_data.item_list: [[REP #SIZE (category_data.item_list^) OF cell]] IN
            osv$mainframe_pageable_heap^;
      jmv$job_category_data.item_list^ := category_data.item_list^;
    IFEND;
    IF category_data.category_names <> NIL THEN
      ALLOCATE jmv$job_category_data.category_names: [0 .. UPPERBOUND (category_data.category_names^)] IN
            osv$mainframe_pageable_heap^;
      jmv$job_category_data.category_names^ := category_data.category_names^;
    IFEND;

  PROCEND install_job_category_data;
?? TITLE := 'install_job_class_table', EJECT ??

{ PURPOSE:
{   The purpose of this request is to install a given list of job classes
{   in the job class table.  The order in which the job classes are given
{   defines the rank, highest to lowest, of the classes which are to be used
{   for automatic class selection.
{ DESIGN:
{   The current job class table is completely replaced with the given list of
{   job class entries.  Job classes which are to be used for automatic class
{   selection are threaded by rank from highest to lowest.  The predefined
{   job classes, SYSTEM, MAINTENANCE, AND UNASSIGNED are never used for
{   automatic class selection.  For coding convenience, the index of the
{   highest rank job class is stored in the next_rank_class field of the
{   UNASSIGNED job class.
{   If this is the first profile installed since the system was deadstarted,
{   initiation of jobs for all job classes except SYSTEM and MAINTENANCE is
{   prevented by setting the initiation_level counts to zero.
{ NOTES:
{   Data validity checks are made and access to the scheduler tables is
{   interlocked prior to calling this procedure.
{   Job candidates for initiation are not refreshed here as a result of new
{   job class table information since this is done unconditionally when
{   the installation of a profile is complete.

  PROCEDURE install_job_class_table
    (    job_class_entries_p: ^jmt$job_class_table;
         current_profile_id: ost$name);

    VAR
      entry: ost$non_negative_integers,
      job_class_index: jmt$job_class,
      ignore_refresh_job_candidates: boolean,
      profile_index: jmt$job_class;

    jmv$highest_rank_job_class := jmc$null_job_class;
    jmv$job_class_table_p^ [jmc$unassigned_job_class].next_rank_class := jmc$null_job_class;

    jmv$maximum_profile_index := 0;
    FOR entry := UPPERBOUND (job_class_entries_p^) DOWNTO 1 DO
      job_class_index := job_class_entries_p^ [entry].index;
      WHILE job_class_index > jmv$maximum_job_class_in_use DO
        jmv$maximum_job_class_in_use := jmv$maximum_job_class_in_use + 1;
        jmv$job_class_table_p^ [jmv$maximum_job_class_in_use] := jmv$default_job_class_attr;
      WHILEND;
      IF NOT jmv$job_class_table_p^ [job_class_index].defined THEN
        jmv$job_class_table_p^ [job_class_index] := job_class_entries_p^ [entry];
        IF (current_profile_id = jmc$sched_profile_deadstart_id) AND
              (job_class_index > jmc$maintenance_job_class) THEN
          jmv$job_class_table_p^ [job_class_index].initiation_level.preferred := 0;
          jmv$job_class_table_p^ [job_class_index].initiation_level.maximum_increment := 0;
        IFEND;
        IF job_class_entries_p^ [entry].prolog_p <> NIL THEN
          ALLOCATE jmv$job_class_table_p^ [job_class_index].prolog_p:
                [STRLENGTH (job_class_entries_p^ [entry].prolog_p^)] IN osv$mainframe_pageable_heap^;
          jmv$job_class_table_p^ [job_class_index].prolog_p^ := job_class_entries_p^ [entry].prolog_p^;
        IFEND;
        IF job_class_entries_p^ [entry].epilog_p <> NIL THEN
          ALLOCATE jmv$job_class_table_p^ [job_class_index].epilog_p:
                [STRLENGTH (job_class_entries_p^ [entry].epilog_p^)] IN osv$mainframe_pageable_heap^;
          jmv$job_class_table_p^ [job_class_index].epilog_p^ := job_class_entries_p^ [entry].epilog_p^;
        IFEND;
        jmv$job_class_table_p^ [job_class_index].defined := TRUE;
      ELSE
        update_job_class_table (job_class_entries_p^ [entry], {install_profile} TRUE, current_profile_id,
              ignore_refresh_job_candidates);
      IFEND;
      IF job_class_entries_p^ [entry].automatic_class_selection THEN
        jmv$job_class_table_p^ [job_class_index].next_rank_class := jmv$highest_rank_job_class;
        jmv$highest_rank_job_class := job_class_index;
      IFEND;
      profile_index := jmv$job_class_table_p^ [job_class_index].profile_index;
      jmv$profile_index_to_job_class [profile_index] := job_class_index;
      IF profile_index > jmv$maximum_profile_index THEN
        jmv$maximum_profile_index := profile_index;
      IFEND;
    FOREND;

    jmv$job_class_table_p^ [jmc$unassigned_job_class].next_rank_class := jmv$highest_rank_job_class;

  PROCEND install_job_class_table;
?? TITLE := 'install_job_scheduler_table', EJECT ??

{ PURPOSE:
{   The purpose of this request is to install a given list of job scheduler
{   controls in the job scheduler table.
{ DESIGN:
{   The current job scheduler table is completely replaced with the given list of
{   job scheduler controls.
{   If there are different dispatching allocation values, a monitor request must be
{   issued to change tables used by dispatcher.  The scheduler table must be updated
{   before the monitor request is issued.
{ NOTES:
{   Data validity checks are made and access to the scheduler tables is
{   interlocked prior to calling this procedure.

  PROCEDURE install_job_scheduler_table
    (    controls_entry: jmt$job_scheduler_table);

    VAR
      dp: 1 .. 15,
      local_controls: jmt$job_scheduler_table,
      rb: jmt$rb_scheduler_requests;

    IF jmv$job_scheduler_table.validation_categories_p <> NIL THEN
      FREE jmv$job_scheduler_table.validation_categories_p IN osv$mainframe_pageable_heap^;
    IFEND;

    jmv$job_scheduler_table := controls_entry;

    IF controls_entry.validation_categories_p <> NIL THEN
      ALLOCATE jmv$job_scheduler_table.validation_categories_p:
            [1 .. UPPERBOUND (controls_entry.validation_categories_p^)] IN osv$mainframe_pageable_heap^;
      jmv$job_scheduler_table.validation_categories_p^ := controls_entry.validation_categories_p^;
    IFEND;

{ Issue a monitor request to check and change dispatching allocation controls.

    rb.reqcode := syc$rc_job_scheduler_request;
    rb.sub_reqcode := jmc$src_dispatching_allocation;
    i#call_monitor (#LOC (rb), #SIZE (rb));

{ Update the dual-state dispatching priority table. This is the table that
{ the dispatcher reads during task selection. It does not have to be updated in
{ monitor mode. The table will be wrong (because not updated in MM) for a maximum
{ a one timeslice. The table has the priorities and subpriorities for NOS/VE priorities
{ P1 through P14. Only the values P1 through P10 can be modified by the scheduling utilities.
{ Priorities P11 through P14 are hard-coded.

    FOR dp := jmc$priority_p1 TO jmc$priority_p10 DO
      tmv$dual_state_dispatch_prior [dp].dual_state_priority :=
            jmv$job_scheduler_table.dual_state_priority_control [dp].priority;
      tmv$dual_state_dispatch_prior [dp].subpriority := jmv$job_scheduler_table.
            dual_state_priority_control [dp].subpriority;
    FOREND;

  PROCEND install_job_scheduler_table;
?? TITLE := 'install_service_class_table', EJECT ??

{ PURPOSE:
{   The purpose of this request is to install a given list of service classes
{   in the service class table.
{ DESIGN:
{   The current service class table is completely replaced with the given list of
{   service class entries.  New classes are defined first and then existing
{   classes are updated since existing classes may reference new classes.
{   Job scheduler events are issued once after the entire table has been installed to
{   process changes due to new service class table information.
{ NOTES:
{   Data validity checks are made and access to the scheduler tables is
{   interlocked prior to calling this procedure.

  PROCEDURE install_service_class_table
    (    service_class_entries_p: ^jmt$service_class_table);

    VAR
      decreased_maxaj: boolean,
      decreased_maxaj_classes: jmt$service_class_set,
      dispatching_control_change: boolean,
      dispatching_control_changes: boolean,
      entry: ost$non_negative_integers,
      existing_classes: jmt$service_class_set,
      increased_maxaj: boolean,
      increased_maxaj_classes: jmt$service_class_set,
      service_class_index: jmt$service_class_index;

    dispatching_control_changes := FALSE;
    existing_classes := $jmt$service_class_set [];
    decreased_maxaj_classes := $jmt$service_class_set [];
    increased_maxaj_classes := $jmt$service_class_set [];

{ Define new service classes.

    FOR entry := 1 TO UPPERBOUND (service_class_entries_p^) DO
      service_class_index := service_class_entries_p^ [entry].index;
      IF jmv$service_classes [service_class_index] = NIL THEN
        ALLOCATE jmv$service_classes [service_class_index] IN osv$mainframe_wired_heap^;
        pmp$zero_out_table (^jmv$service_classes [service_class_index]^.
              statistics, #SIZE (jmv$service_classes [service_class_index]^.statistics));
        jmv$service_classes [service_class_index]^.attributes := jmv$default_service_class_attr;
      IFEND;
      IF NOT jmv$service_classes [service_class_index]^.attributes.defined THEN
        jmv$service_classes [service_class_index]^.attributes := service_class_entries_p^ [entry];
        IF service_class_entries_p^ [entry].next_service_class_index = jmc$null_service_class THEN
          jmv$service_classes [service_class_index]^.attributes.next_service_class_index :=
                service_class_index;
        IFEND;
        jmv$service_classes [service_class_index]^.attributes.defined := TRUE;
        IF service_class_index > jmv$max_service_class_in_use THEN
          jmv$max_service_class_in_use := service_class_index;
        IFEND;
      ELSE
        existing_classes := existing_classes + $jmt$service_class_set [service_class_index];
      IFEND;
    FOREND;

{ Update existing service classes.

    IF existing_classes <> $jmt$service_class_set [] THEN
      FOR entry := 1 TO UPPERBOUND (service_class_entries_p^) DO
        service_class_index := service_class_entries_p^ [entry].index;
        IF service_class_index IN existing_classes THEN
          update_service_class_table (service_class_entries_p^ [entry], dispatching_control_change,
                decreased_maxaj, increased_maxaj);
          dispatching_control_changes := dispatching_control_changes OR dispatching_control_change;
          IF decreased_maxaj THEN
            decreased_maxaj_classes := decreased_maxaj_classes + $jmt$service_class_set [service_class_index];
          IFEND;
          IF increased_maxaj THEN
            increased_maxaj_classes := increased_maxaj_classes + $jmt$service_class_set [service_class_index];
          IFEND;
        IFEND;
      FOREND;
    IFEND;

{ Issue the job scheduler events to process the service class table changes.

    IF decreased_maxaj_classes <> $jmt$service_class_set [] THEN
      jmp$check_active_job_limits (decreased_maxaj_classes);
    IFEND;

    IF increased_maxaj_classes <> $jmt$service_class_set [] THEN
      jmp$set_class_below_maxaj_limit (increased_maxaj_classes);
    IFEND;

    IF dispatching_control_changes THEN
      jmp$set_event_and_ready_sched (jmc$change_dispatching_controls);
    IFEND;

  PROCEND install_service_class_table;
?? TITLE := '[XDCL] jmp$cleanup_unrecovered_job', EJECT ??

  PROCEDURE [XDCL] jmp$cleanup_unrecovered_job
    (    ijl_ordinal: jmt$ijl_ordinal);

    VAR
      rb: jmt$rb_scheduler_requests;

    rb.reqcode := syc$rc_job_scheduler_request;
    rb.sub_reqcode := jmc$src_cleanup_unrecovered_job;
    rb.ijl_ordinal := ijl_ordinal;
    i#call_monitor (#LOC (rb), #SIZE (rb));

  PROCEND jmp$cleanup_unrecovered_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$clear_leveler_profile_flag', EJECT ??
*copy jmh$clear_leveler_profile_flag

  PROCEDURE [XDCL, #GATE] jmp$clear_leveler_profile_flag
    (    access_id: ost$binary_unique_name;
     VAR status: ost$status);

    status.normal := TRUE;

    jmp$verify_utility_access_id (access_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmv$leveler_profile_loading := FALSE;
  PROCEND jmp$clear_leveler_profile_flag;
?? TITLE := '[XDCL, #GATE] jmp$clear_utility_active_flag', EJECT ??
*copy jmh$clear_utility_active_flag

  PROCEDURE [XDCL, #GATE] jmp$clear_utility_active_flag
    (    access_id: ost$binary_unique_name;
     VAR status: ost$status);

    VAR
      global_task_id: ost$global_task_id;

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (jmv$scheduling_utility_usage.lock);

    IF NOT jmv$scheduling_utility_usage.active THEN
      osp$clear_mainframe_sig_lock (jmv$scheduling_utility_usage.lock);
      osp$set_status_condition (jme$no_utility_is_active, status);
      RETURN;
    IFEND;
    pmp$get_executing_task_gtid (global_task_id);
    IF (access_id <> jmv$scheduling_utility_usage.access_id) OR
          (global_task_id <> jmv$scheduling_utility_usage.global_task_id) THEN
      osp$clear_mainframe_sig_lock (jmv$scheduling_utility_usage.lock);
      osp$set_status_condition (jme$access_id_mismatch, status);
      RETURN;
    IFEND;
    jmv$scheduling_utility_usage.active := FALSE;
    jmv$leveler_profile_loading := FALSE;

    osp$clear_mainframe_sig_lock (jmv$scheduling_utility_usage.lock);

  PROCEND jmp$clear_utility_active_flag;

?? TITLE := '[XDCL] jmp$get_job_name_via_gtid', EJECT ??

*copyc jmh$get_job_name_via_gtid

  PROCEDURE [XDCL] jmp$get_job_name_via_gtid
    (    global_task_id: ost$global_task_id;
     VAR system_supplied_name: jmt$system_supplied_name;
     VAR job_exists: boolean);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry;

    job_exists := TRUE;

    IF (global_task_id = tmv$null_global_task_id) OR (global_task_id.index > UPPERBOUND (tmv$ptl_p^)) OR
          (tmv$ptl_p^ [global_task_id.index].sequence_number <> global_task_id.seqno) OR
          (tmv$ptl_p^ [global_task_id.index].status = tmc$ts_null) THEN
      job_exists := FALSE;
    ELSE
      jmp$get_ijle_p (tmv$ptl_p^ [global_task_id.index].ijl_ordinal, ijle_p);
      system_supplied_name := ijle_p^.system_supplied_name;
      IF (tmv$ptl_p^ [global_task_id.index].status = tmc$ts_null) OR
            (tmv$ptl_p^ [global_task_id.index].sequence_number <> global_task_id.seqno) THEN
        job_exists := FALSE;
      IFEND;
    IFEND;

  PROCEND jmp$get_job_name_via_gtid;

?? TITLE := '[XDCL, #GATE] jmp$incr_scheduler_statistics', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$incr_scheduler_statistics
    (    scheduler_statistic: jmt$sched_statistic_elements);

    jmv$job_scheduler_statistics [scheduler_statistic] :=
          jmv$job_scheduler_statistics [scheduler_statistic] + 1;

  PROCEND jmp$incr_scheduler_statistics;
?? TITLE := '[XDCL, #GATE] jmp$incr_sched_serv_statistics', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to increment the scheduler statistics and the service class
{   statistics.  Service class statistics are a subset of scheduler statistics.

  PROCEDURE [XDCL, #GATE] jmp$incr_sched_serv_statistics
    (    scheduler_statistic: jmt$sched_statistic_elements;
         class: jmt$service_class_index);

    jmv$job_scheduler_statistics [scheduler_statistic] :=
          jmv$job_scheduler_statistics [scheduler_statistic] + 1;

    IF scheduler_statistic = jmc$memory_wait_no_preempt THEN
      jmv$job_sched_serv_class_stats [class].memory_wait := jmv$job_sched_serv_class_stats [class].
            memory_wait + 1;
    ELSEIF scheduler_statistic = jmc$ajlo_wait_no_preempt THEN
      jmv$job_sched_serv_class_stats [class].ajl_wait := jmv$job_sched_serv_class_stats [class].ajl_wait + 1;
    IFEND;

  PROCEND jmp$incr_sched_serv_statistics;
?? TITLE := '[XDCL, #GATE] jmp$install_profile_in_tables', EJECT ??
*copy jmh$install_profile_in_tables

{ DESIGN:
{   Access to the scheduler tables is interlocked while a profile is installed.
{   Job classes, service classes, and applications to be deleted are deleted
{   first.  Then the new scheduler tables are installed in the order of
{   service classes, applications, job scheduler controls, job classes, and
{   job category data.  Service classes are installed first since job classes
{   and applications reference them.
{   If this is the first profile installed since the system was deadstarted,
{   initiation of jobs is prevented for all job classes except SYSTEM and
{   MAINTENANCE.
{ NOTES:
{   Data validity checks are made prior to calling this procedure.

  PROCEDURE [XDCL, #GATE] jmp$install_profile_in_tables
    (    access_id: ost$binary_unique_name;
         job_class_entries_p: ^jmt$job_class_table;
         service_class_entries_p: ^jmt$service_class_table;
         application_entries_p: ^jmt$application_table;
         controls_entry: jmt$job_scheduler_table;
         category_data: jmt$job_category_data;
         deleted_job_classes: jmt$job_class_set;
         deleted_service_classes: jmt$service_class_set;
         deleted_applications: jmt$application_set;
     VAR status: ost$status);

    VAR
      actual_value: integer,
      current_profile_id: ost$name,
      ignore_status: ost$status;

    status.normal := TRUE;

    jmp$verify_utility_access_id (access_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (jmv$scheduler_tables_access.lock);
    osp$get_locked_variable_value (jmv$scheduler_tables_access.count, {expected_value} 0, actual_value);
    WHILE actual_value <> 0 DO
      pmp$delay (500, ignore_status);
      osp$get_locked_variable_value (jmv$scheduler_tables_access.count, {expected_value} 0, actual_value);
    WHILEND;

    current_profile_id := jmv$job_scheduler_table.profile_identification;
    delete_classes_from_tables (deleted_job_classes, deleted_service_classes, deleted_applications);
    install_service_class_table (service_class_entries_p);
    install_application_table (application_entries_p);
    install_job_scheduler_table (controls_entry);
    install_job_class_table (job_class_entries_p, current_profile_id);
    install_job_category_data (category_data);

    osp$clear_mainframe_sig_lock (jmv$scheduler_tables_access.lock);

  PROCEND jmp$install_profile_in_tables;
?? TITLE := '[XDCL, #GATE] jmp$read_application_record', EJECT ??
*copy jmh$read_application_record

  PROCEDURE [XDCL, #GATE] jmp$read_application_record
    (    application_name: jmt$application_name;
     VAR application_index: {input, output} jmt$application_index;
     VAR application_record: jmt$application_attributes;
     VAR status: ost$status);

    VAR
      temp: integer,
      high_index: jmt$application_index,
      low_index: jmt$application_index,
      middle_index: jmt$application_index;

    status.normal := TRUE;
    low_index := 1;
    high_index := 0;

    osp$set_mainframe_sig_lock (jmv$scheduler_tables_access.lock);

    IF jmv$application_table_p <> NIL THEN
      high_index := UPPERBOUND (jmv$application_table_p^);
      IF (application_index > 0) AND (application_index <= high_index) THEN
        middle_index := application_index;
      ELSE
        temp := low_index + high_index;
        middle_index := temp DIV 2;
      IFEND;

    /binary_search_for_application/
      REPEAT
        IF application_name < jmv$application_table_p^ [middle_index].name THEN
          high_index := middle_index - 1;
        ELSEIF application_name > jmv$application_table_p^ [middle_index].name THEN
          low_index := middle_index + 1;
        ELSEIF jmv$application_table_p^ [middle_index].defined THEN
          application_record := jmv$application_table_p^ [middle_index];
          application_index := middle_index;
          EXIT /binary_search_for_application/;
        ELSE
          low_index := high_index + 1;
        IFEND;
        temp := low_index + high_index;
        middle_index := temp DIV 2;
      UNTIL low_index > high_index;
    IFEND;

    osp$clear_mainframe_sig_lock (jmv$scheduler_tables_access.lock);

    IF low_index > high_index THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$class_or_appl_not_defined, jmc$smt_application,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, application_name, status);
    IFEND;

  PROCEND jmp$read_application_record;
?? TITLE := '[XDCL, #GATE] jmp$read_category_data', EJECT ??
*copy jmh$read_category_data

  PROCEDURE [XDCL, #GATE] jmp$read_category_data
    (VAR category_data: jmt$job_category_data;
     VAR data_p: ^SEQ ( * );
     VAR status: ost$status);

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (jmv$scheduler_tables_access.lock);

    category_data := jmv$job_category_data;
    RESET data_p;
    IF jmv$job_category_data.item_list <> NIL THEN
      NEXT category_data.item_list: [[REP #SIZE (jmv$job_category_data.item_list^) OF cell]] IN data_p;
      IF category_data.item_list = NIL THEN
        osp$set_status_condition (jme$no_element_in_sequence, status);
      ELSE
        category_data.item_list^ := jmv$job_category_data.item_list^;
      IFEND;
    IFEND;
    IF jmv$job_category_data.category_names <> NIL THEN
      NEXT category_data.category_names: [0 .. UPPERBOUND (jmv$job_category_data.category_names^)] IN data_p;
      IF category_data.category_names = NIL THEN
        osp$set_status_condition (jme$no_element_in_sequence, status);
      ELSE
        category_data.category_names^ := jmv$job_category_data.category_names^;
      IFEND;
    IFEND;

    osp$clear_mainframe_sig_lock (jmv$scheduler_tables_access.lock);

  PROCEND jmp$read_category_data;
?? TITLE := '[XDCL, #GATE] jmp$read_defined_classes', EJECT ??
*copy jmh$read_defined_classes

  PROCEDURE [XDCL, #GATE] jmp$read_defined_classes
    (    class_kind: jmt$class_kind;
     VAR defined_classes: jmt$defined_classes;
     VAR number_of_classes: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      application_index: jmt$application_index,
      job_class_index: jmt$job_class,
      ranking_error: boolean,
      ranked_class_set: jmt$job_class_set,
      result_size: ost$non_negative_integers,
      service_class_index: jmt$service_class_index,
      size_error: boolean;

    status.normal := TRUE;
    number_of_classes := 0;
    result_size := UPPERBOUND (defined_classes);
    ranking_error := FALSE;
    size_error := FALSE;

    osp$set_mainframe_sig_lock (jmv$scheduler_tables_access.lock);

    CASE class_kind OF

    = jmc$job_class =
      job_class_index := jmv$highest_rank_job_class;
      ranked_class_set := $jmt$job_class_set [];

    /get_ranked_job_classes/
      WHILE job_class_index <> jmc$null_job_class DO
        IF (jmv$job_class_table_p^ [job_class_index].defined) AND
              (jmv$job_class_table_p^ [job_class_index].automatic_class_selection) THEN
          IF number_of_classes < result_size THEN
            number_of_classes := number_of_classes + 1;
          ELSE
            size_error := TRUE;
            EXIT /get_ranked_job_classes/;
          IFEND;
          defined_classes [number_of_classes].name := jmv$job_class_table_p^ [job_class_index].name;
          defined_classes [number_of_classes].index := jmv$job_class_table_p^ [job_class_index].index;
          ranked_class_set := ranked_class_set + $jmt$job_class_set [job_class_index];
          job_class_index := jmv$job_class_table_p^ [job_class_index].next_rank_class;
        ELSE
          ranking_error := TRUE;
          EXIT /get_ranked_job_classes/;
        IFEND;
      WHILEND /get_ranked_job_classes/;

      IF ranking_error THEN
        number_of_classes := 0;
      IFEND;

    /get_non_ranked_job_classes/
      FOR job_class_index := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
        IF jmv$job_class_table_p^ [job_class_index].defined THEN
          IF (NOT jmv$job_class_table_p^ [job_class_index].automatic_class_selection) OR (ranking_error) THEN
            IF number_of_classes < result_size THEN
              number_of_classes := number_of_classes + 1;
            ELSE
              size_error := TRUE;
              EXIT /get_non_ranked_job_classes/;
            IFEND;
            defined_classes [number_of_classes].name := jmv$job_class_table_p^ [job_class_index].name;
            defined_classes [number_of_classes].index := jmv$job_class_table_p^ [job_class_index].index;
          ELSE
            IF NOT (job_class_index IN ranked_class_set) THEN
              IF NOT size_error THEN
                ranking_error := TRUE;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND /get_non_ranked_job_classes/;

    = jmc$service_class =

    /get_service_classes/
      FOR service_class_index := jmc$system_service_class TO jmv$max_service_class_in_use DO
        IF (jmv$service_classes [service_class_index] <> NIL) AND
              jmv$service_classes [service_class_index]^.attributes.defined THEN
          IF number_of_classes < result_size THEN
            number_of_classes := number_of_classes + 1;
          ELSE
            size_error := TRUE;
            EXIT /get_service_classes/;
          IFEND;
          defined_classes [number_of_classes].name := jmv$service_classes [service_class_index]^.attributes.
                name;
          defined_classes [number_of_classes].index := jmv$service_classes [service_class_index]^.attributes.
                index;
        IFEND;
      FOREND /get_service_classes/;

    = jmc$application =
      IF jmv$application_table_p <> NIL THEN

      /get_applications/
        FOR application_index := 1 TO UPPERBOUND (jmv$application_table_p^) DO
          IF jmv$application_table_p^ [application_index].defined THEN
            IF number_of_classes < result_size THEN
              number_of_classes := number_of_classes + 1;
            ELSE
              size_error := TRUE;
              EXIT /get_applications/;
            IFEND;
            defined_classes [number_of_classes].name := jmv$application_table_p^ [application_index].name;
            defined_classes [number_of_classes].index := application_index;
          IFEND;
        FOREND /get_applications/;
      IFEND;

    ELSE
    CASEND;

    osp$clear_mainframe_sig_lock (jmv$scheduler_tables_access.lock);

    IF ranking_error THEN
      osp$set_status_condition (jme$error_in_job_class_ranking, status);
    ELSEIF size_error THEN
      osp$set_status_condition (jme$result_array_too_small, status);
    IFEND;

  PROCEND jmp$read_defined_classes;
?? TITLE := '[XDCL, #GATE] jmp$read_job_class_record', EJECT ??
*copy jmh$read_job_class_record

  PROCEDURE [XDCL, #GATE] jmp$read_job_class_record
    (    job_class_index: jmt$job_class;
     VAR job_class_record: jmt$job_class_attributes;
     VAR data_p: ^SEQ ( * );
     VAR status: ost$status);

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (jmv$scheduler_tables_access.lock);

    IF (job_class_index = 0) OR (NOT jmv$job_class_table_p^ [job_class_index].defined) THEN
      osp$clear_mainframe_sig_lock (jmv$scheduler_tables_access.lock);
      osp$set_status_abnormal (jmc$job_management_id, jme$class_index_not_defined, jmc$smt_job_class, status);
      osp$append_status_integer (osc$status_parameter_delimiter, job_class_index, 10, FALSE, status);
      RETURN;
    IFEND;

    job_class_record := jmv$job_class_table_p^ [job_class_index];
    RESET data_p;
    IF job_class_record.prolog_p <> NIL THEN
      NEXT job_class_record.prolog_p: [STRLENGTH (jmv$job_class_table_p^ [job_class_index].prolog_p^)] IN
            data_p;
      IF job_class_record.prolog_p = NIL THEN
        osp$set_status_condition (jme$no_element_in_sequence, status);
      ELSE
        job_class_record.prolog_p^ := jmv$job_class_table_p^ [job_class_index].prolog_p^;
      IFEND;
    IFEND;
    IF job_class_record.epilog_p <> NIL THEN
      NEXT job_class_record.epilog_p: [STRLENGTH (jmv$job_class_table_p^ [job_class_index].epilog_p^)] IN
            data_p;
      IF job_class_record.epilog_p = NIL THEN
        osp$set_status_condition (jme$no_element_in_sequence, status);
      ELSE
        job_class_record.epilog_p^ := jmv$job_class_table_p^ [job_class_index].epilog_p^;
      IFEND;
    IFEND;

    osp$clear_mainframe_sig_lock (jmv$scheduler_tables_access.lock);

  PROCEND jmp$read_job_class_record;
?? TITLE := '[XDCL, #GATE] jmp$read_scheduler_table', EJECT ??
*copy jmh$read_scheduler_table

  PROCEDURE [XDCL, #GATE] jmp$read_scheduler_table
    (VAR scheduler_table: jmt$job_scheduler_table;
     VAR data_p: ^SEQ ( * );
     VAR status: ost$status);

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (jmv$scheduler_tables_access.lock);

    scheduler_table := jmv$job_scheduler_table;
    RESET data_p;
    IF jmv$job_scheduler_table.validation_categories_p <> NIL THEN
      NEXT scheduler_table.validation_categories_p: [1 .. UPPERBOUND (jmv$job_scheduler_table.
            validation_categories_p^)] IN data_p;
      IF scheduler_table.validation_categories_p = NIL THEN
        osp$set_status_condition (jme$no_element_in_sequence, status);
      ELSE
        scheduler_table.validation_categories_p^ := jmv$job_scheduler_table.validation_categories_p^;
      IFEND;
    IFEND;

    osp$clear_mainframe_sig_lock (jmv$scheduler_tables_access.lock);

  PROCEND jmp$read_scheduler_table;
?? TITLE := '[XDCL, #GATE] jmp$save_sfid_of_swap_file', EJECT ??

{ PURPOSE:
{   This procedure is executed during job initiation to do the following:
{   --store the sfid of the job's swap file
{   --allocate the swap file for interactive jobs
{   --issue a monitor request to change the DM and MM tables for the swap file to indicate
{     that the swap file is a shared file.  The job has the swap file attached exclusively,
{     but the tables need to indicate shared because the system will open and reference the
{     swap file during IDLE_SYSTEM and TERMINATE_SYSTEM.
{   --change the entry status of the job so that it is now swappable
{   --change the dispatching priority of the job from system priority to the value for the service class

  PROCEDURE [XDCL, #GATE] jmp$save_sfid_of_swap_file
    (    sfid: dmt$system_file_id;
     VAR status: ost$status);

    CONST
      initial_swap_file_size = 393216;

    VAR
      dispatching_control_info: jmt$dispatching_control_info,
      rb: mmt$rb_ring1_segment_request;

    status.normal := TRUE;
    jmv$jcb.ijle_p^.swap_data.swap_file_sfid := sfid;
    IF jmv$jcb.ijle_p^.job_mode <> jmc$batch THEN
      dmp$allocate_file_space_r1 (sfid, initial_swap_file_size, 0, 0, osc$wait, sfc$no_limit, status);
    IFEND;

    rb.reqcode := syc$rc_ring1_segment_request;
    rb.request := mmc$sr1_change_swap_file_queue;
    rb.sfid := sfid;
    i#call_monitor (#LOC (rb), #SIZE (rb));

    jmp$jm_change_ijl_entry_status (jmv$jcb.ijle_p, jmc$ies_job_in_memory);

    dispatching_control_info.dispatching_priority := jmv$service_classes
          [jmv$jcb.ijle_p^.job_scheduler_data.service_class]^.
          attributes.dispatching_control [jmc$min_dispatching_control].dispatching_priority;
    jmp$change_dispatching_prior_r1 (tmc$cpo_save_swap_file_sfid, jmv$jcb.ijl_ordinal, jmv$jcb.system_name,
          dispatching_control_info, status);

  PROCEND jmp$save_sfid_of_swap_file;
?? OLDTITLE, NEWTITLE := '[XDCL, #GATE] jmp$select_reset_disp_pr', EJECT ??
*copy jmh$select_reset_disp_pr

  PROCEDURE [XDCL, #GATE] jmp$select_reset_disp_pr;

    VAR
      ignore_status: ost$status,
      interactive_gtid: ost$global_task_id,
      null_dispatching_info:  jmt$dispatching_control_info;

    pmp$get_executing_task_gtid (interactive_gtid);

{ The following code is a duplicate of the ring 2 code. It is required here also to
{ satisfy DESKTOP's use of the interface. DESKTOP bypasses ring 2.

    IF jmv$jcb.ijle_p^.interactive_task_gtid <> tmv$null_global_task_id THEN
      jmp$change_dispatching_prior_r1 (tmc$cpo_interactive_command, jmv$jcb.ijl_ordinal, jmv$jcb.system_name,
        null_dispatching_info, ignore_status);
    ELSE
      jmv$jcb.ijle_p^.interactive_task_gtid := interactive_gtid;
    IFEND;

  PROCEND jmp$select_reset_disp_pr;
?? TITLE := '[XDCL, #GATE] jmp$set_job_unswappable', EJECT ??

{ PURPOSE:
{   This procedure is executed during job termination to set a job non-swappable.
{   This MUST happen to insure that a job is not swapping when it terminates.

  PROCEDURE [XDCL, #GATE] jmp$set_job_unswappable
    (VAR status: ost$status);

    VAR
      dispatching_control_info: jmt$dispatching_control_info,
      rb: tmt$rb_update_job_task_enviro;

    status.normal := TRUE;
    dispatching_control_info.dispatching_priority := jmc$priority_system_job;
    jmp$change_dispatching_prior_r1 (tmc$cpo_set_job_unswappable, jmv$jcb.ijl_ordinal, jmv$jcb.system_name,
          dispatching_control_info, status);

    rb.reqcode := syc$rc_update_job_task_enviro;
    rb.subcode := tmc$ujte_set_non_swappable;
    i#call_monitor (#LOC (rb), #SIZE (rb));

{ Set swapfile eoi to 0 in case the system terminates before the swapfile gets purged.

    dmp$set_eoi (jmv$jcb.ijle_p^.swap_data.swap_file_sfid, 0, status);

  PROCEND jmp$set_job_unswappable;
?? TITLE := '[XDCL, #GATE] jmp$set_profile_loading_flag', EJECT ??
*copy jmh$set_profile_loading_flag

  PROCEDURE [XDCL, #GATE] jmp$set_profile_loading_flag
    (    profile_is_loading: boolean;
         new_profile_id: ost$name;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      job_class: jmt$job_class,
      rb: jmt$rb_scheduler_requests;

    status.normal := TRUE;

{ If a profile is being installed, issue a monitor request to set the
{ profile loading flag.  Wait for scheduler to refresh the job candidates
{ for initiation before returning.

    IF profile_is_loading THEN
      jmv$leveler_profile_loading := TRUE;

      rb.reqcode := syc$rc_job_scheduler_request;
      rb.sub_reqcode := jmc$src_sched_profile_loading;

      i#call_monitor (#LOC (rb), #SIZE (rb));

      jmv$job_class_table_p^ [jmc$unassigned_job_class].enable_class_initiation := FALSE;
      jmv$refresh_job_candidates := TRUE;
      jmp$set_event_and_ready_sched (jmc$examine_input_queue);
      WHILE jmv$refresh_job_candidates DO
        pmp$delay (500, ignore_status);
      WHILEND;
      FOR job_class := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
        WHILE jmv$candidate_queued_jobs [job_class].candidate_available DO
          pmp$delay (100, ignore_status);
        WHILEND;
      FOREND;
    ELSE
      jmv$sched_profile_is_loading := FALSE;
      jmv$refresh_job_candidates := TRUE;
      jmp$set_event_and_ready_sched (jmc$examine_input_queue);
    IFEND;

  PROCEND jmp$set_profile_loading_flag;
?? TITLE := '[XDCL, #GATE] jmp$set_utility_active_flag', EJECT ??
*copy jmh$set_utility_active_flag

  PROCEDURE [XDCL, #GATE] jmp$set_utility_active_flag
    (VAR access_id: ost$binary_unique_name;
     VAR status: ost$status);

    status.normal := TRUE;
    IF jmv$scheduling_utility_usage.active THEN
      osp$set_status_condition (jme$another_utility_is_active, status);
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (jmv$scheduling_utility_usage.lock);

    IF jmv$scheduling_utility_usage.active THEN
      osp$clear_mainframe_sig_lock (jmv$scheduling_utility_usage.lock);
      osp$set_status_condition (jme$another_utility_is_active, status);
      RETURN;
    IFEND;
    pmp$get_executing_task_gtid (jmv$scheduling_utility_usage.global_task_id);
    osp$generate_unique_binary_name (jmv$scheduling_utility_usage.access_id, status);
    IF NOT status.normal THEN
      osp$clear_mainframe_sig_lock (jmv$scheduling_utility_usage.lock);
      RETURN;
    IFEND;
    jmv$scheduling_utility_usage.active := TRUE;

    osp$clear_mainframe_sig_lock (jmv$scheduling_utility_usage.lock);

    access_id := jmv$scheduling_utility_usage.access_id;

  PROCEND jmp$set_utility_active_flag;
?? TITLE := '[XDCL, #GATE] jmp$update_profile_in_tables', EJECT ??
*copy jmh$update_profile_in_tables

{ DESIGN:
{   Access to the scheduler tables is interlocked while a profile is updated.
{   Job category data is never updated since this type of change would
{   constitute a structure change in the scheduling profile.  Job scheduler
{   events are issued once after all the tables are updated to process changes
{   due to new information in the tables.
{ NOTES:
{   Data validity checks are made prior to calling this procedure.

  PROCEDURE [XDCL, #GATE] jmp$update_profile_in_tables
    (    access_id: ost$binary_unique_name;
         changed_job_classes_p: ^jmt$job_class_table;
         changed_service_classes_p: ^jmt$service_class_table;
         changed_applications_p: ^jmt$application_table;
         controls_p: ^jmt$job_scheduler_table;
     VAR status: ost$status);

    VAR
      actual_value: integer,
      current_profile_id: ost$name,
      decreased_maxaj: boolean,
      decreased_maxaj_classes: jmt$service_class_set,
      dispatching_control_change: boolean,
      dispatching_control_changes: boolean,
      entry: ost$non_negative_integers,
      ignore_status: ost$status,
      increased_maxaj: boolean,
      increased_maxaj_classes: jmt$service_class_set,
      refresh_candidates: boolean,
      refresh_job_candidates: boolean;

    status.normal := TRUE;
    dispatching_control_changes := FALSE;
    decreased_maxaj_classes := $jmt$service_class_set [];
    increased_maxaj_classes := $jmt$service_class_set [];
    refresh_candidates := FALSE;

    jmp$verify_utility_access_id (access_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (jmv$scheduler_tables_access.lock);
    osp$get_locked_variable_value (jmv$scheduler_tables_access.count, {expected_value} 0, actual_value);
    WHILE actual_value <> 0 DO
      pmp$delay (500, ignore_status);
      osp$get_locked_variable_value (jmv$scheduler_tables_access.count, {expected_value} 0, actual_value);
    WHILEND;

    IF changed_job_classes_p <> NIL THEN
      current_profile_id := jmv$job_scheduler_table.profile_identification;
      FOR entry := 1 TO UPPERBOUND (changed_job_classes_p^) DO
        update_job_class_table (changed_job_classes_p^ [entry], {install_profile} FALSE, current_profile_id,
              refresh_job_candidates);
        refresh_candidates := refresh_candidates OR refresh_job_candidates;
      FOREND;
    IFEND;

    IF changed_service_classes_p <> NIL THEN
      FOR entry := 1 TO UPPERBOUND (changed_service_classes_p^) DO
        update_service_class_table (changed_service_classes_p^ [entry], dispatching_control_change,
              decreased_maxaj, increased_maxaj);
        dispatching_control_changes := dispatching_control_changes OR dispatching_control_change;
        IF decreased_maxaj THEN
          decreased_maxaj_classes := decreased_maxaj_classes +
                $jmt$service_class_set [changed_service_classes_p^ [entry].index];
        IFEND;
        IF increased_maxaj THEN
          increased_maxaj_classes := increased_maxaj_classes +
                $jmt$service_class_set [changed_service_classes_p^ [entry].index];
        IFEND;
      FOREND;
    IFEND;

    update_application_table (changed_applications_p);

    update_job_scheduler_table (controls_p, refresh_job_candidates);
    refresh_candidates := refresh_candidates OR refresh_job_candidates;

    osp$clear_mainframe_sig_lock (jmv$scheduler_tables_access.lock);

{ Issue the job scheduler events to process the service class table changes.

    IF decreased_maxaj_classes <> $jmt$service_class_set [] THEN
      jmp$check_active_job_limits (decreased_maxaj_classes);
    IFEND;

    IF increased_maxaj_classes <> $jmt$service_class_set [] THEN
      jmp$set_class_below_maxaj_limit (increased_maxaj_classes);
    IFEND;

    IF dispatching_control_changes THEN
      jmp$set_event_and_ready_sched (jmc$change_dispatching_controls);
    IFEND;

{ Issue the job scheduler event to refresh the job candidates for initiation.

    IF refresh_candidates THEN
      jmv$refresh_job_candidates := TRUE;
      jmp$set_event_and_ready_sched (jmc$examine_input_queue);
    IFEND;

  PROCEND jmp$update_profile_in_tables;
?? TITLE := '[XDCL, #GATE] jmp$verify_utility_access_id', EJECT ??
*copy jmh$verify_utility_access_id

  PROCEDURE [XDCL, #GATE] jmp$verify_utility_access_id
    (    access_id: ost$binary_unique_name;
     VAR status: ost$status);

    VAR
      global_task_id: ost$global_task_id;

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (jmv$scheduling_utility_usage.lock);

    IF NOT jmv$scheduling_utility_usage.active THEN
      osp$clear_mainframe_sig_lock (jmv$scheduling_utility_usage.lock);
      osp$set_status_condition (jme$no_utility_is_active, status);
      RETURN;
    IFEND;
    pmp$get_executing_task_gtid (global_task_id);
    IF (access_id <> jmv$scheduling_utility_usage.access_id) OR
          (global_task_id <> jmv$scheduling_utility_usage.global_task_id) THEN
      osp$set_status_condition (jme$access_id_mismatch, status);
    IFEND;

    osp$clear_mainframe_sig_lock (jmv$scheduling_utility_usage.lock);

  PROCEND jmp$verify_utility_access_id;

?? TITLE := '[XDCL, #GATE] jmp$process_change_dispatching', EJECT ??

{ PURPOSE:
{   This procedure processes the scheduler event to change the dispatching control
{   information in the service class table.
{ DESIGN:
{   The list of changes to be made must be locked so that another change service table
{   command cannot add to the list during processing.  A monitor request must be made
{   to change the dispatching control field in the service class table.
{   After the dispatching controls have been changed, the swapin candidate queues (which
{   are ordered by dispatching priority) must be re-ordered.

  PROCEDURE [XDCL, #GATE] jmp$process_change_dispatching;

    VAR
      changed_classes: jmt$service_class_set,
      dispatching_ctrl_p_to_free: ^jmt$dispatching_control_changes,
      rb: jmt$rb_scheduler_requests;

    osp$set_mainframe_sig_lock (jmv$change_dispatching_list.lock);

    rb.reqcode := syc$rc_job_scheduler_request;
    rb.sub_reqcode := jmc$src_change_dispatching_ctrl;
    i#call_monitor (#LOC (rb), #SIZE (rb));

{ Free the space used by the change dispatching control list and determine the set of classes
{ that have been changed.

    changed_classes := $jmt$service_class_set [];
    WHILE jmv$change_dispatching_list.dispatching_control_changes_p <> NIL DO
      dispatching_ctrl_p_to_free := jmv$change_dispatching_list.dispatching_control_changes_p;
      changed_classes := changed_classes + $jmt$service_class_set
            [jmv$change_dispatching_list.dispatching_control_changes_p^.change_service_class];
      jmv$change_dispatching_list.dispatching_control_changes_p :=
            jmv$change_dispatching_list.dispatching_control_changes_p^.dispatching_control_changes_p;
      FREE dispatching_ctrl_p_to_free IN osv$mainframe_wired_heap^;
    WHILEND;

    jmp$clear_scheduler_event (jmc$change_dispatching_controls);

    osp$clear_mainframe_sig_lock (jmv$change_dispatching_list.lock);

    jmp$reorder_swapin_queues (changed_classes);
    jmp$set_event_and_ready_sched (jmc$examine_swapin_queue);
    jmp$set_event_and_ready_sched (jmc$examine_input_queue);

  PROCEND jmp$process_change_dispatching;

?? TITLE := '[XDCL, #GATE] jmp$change_dispatching_prior_r1', EJECT ??

{ PURPOSE:
{   This procedure processes requests to change a job's dispatching priority.
{ DESIGN:
{   A monitor request must be issued to change the job's dispatching priority, because
{   the change must be synchronized with dispatcher and swapper in monitor.

  PROCEDURE [XDCL, #GATE] jmp$change_dispatching_prior_r1
    (    request_origin: tmt$change_priority_origin;
         ijl_ordinal: jmt$ijl_ordinal;
         system_supplied_name: jmt$system_supplied_name;
         dispatching_control_info: jmt$dispatching_control_info;
     VAR status: ost$status);

    VAR
      rb: tmt$rb_update_job_task_enviro;

    rb.reqcode := syc$rc_update_job_task_enviro;
    rb.subcode := tmc$ujte_dispatching_priority;
    rb.request_origin := request_origin;
    rb.ijl_ordinal := ijl_ordinal;
    rb.system_supplied_name := system_supplied_name;
    rb.dispatching_control_info := dispatching_control_info;
    i#call_monitor (#LOC (rb), #SIZE (rb));
    syp$set_status_from_mtr_status (rb.status, status);

  PROCEND jmp$change_dispatching_prior_r1;
?? TITLE := 'update_application_table', EJECT ??

{ PURPOSE:
{   The purpose of this request is to update the current application table with
{   the given list of existing applications whose attributes have changed.
{ DESIGN:
{   The application name and profile identification are never updated since
{   changing them would constitute a change in the structure of the scheduling profile.
{ NOTES:
{   Data validity checks are made and access to the scheduler tables is
{   interlocked prior to calling this procedure.

  PROCEDURE update_application_table
    (    changed_applications_p: ^jmt$application_table);

    VAR
      temp: integer,
      application_name: jmt$application_name,
      high_index: jmt$application_index,
      i: integer,
      low_index: jmt$application_index,
      middle_index: jmt$application_index;

    IF (changed_applications_p = NIL) OR (jmv$application_table_p = NIL) THEN
      RETURN;
    IFEND;

    FOR i := 1 TO UPPERBOUND (changed_applications_p^) DO
      low_index := 1;
      high_index := UPPERBOUND (jmv$application_table_p^);
      application_name := changed_applications_p^ [i].name;

    /binary_search_for_application/
      REPEAT
        temp := low_index + high_index;
        middle_index := temp DIV 2;
        IF application_name < jmv$application_table_p^ [middle_index].name THEN
          high_index := middle_index - 1;
        ELSEIF application_name > jmv$application_table_p^ [middle_index].name THEN
          low_index := middle_index + 1;
        ELSE { Application name matches }

{ Update the Definition group attributes.

          jmv$application_table_p^ [middle_index].enable_application_scheduling :=
                changed_applications_p^ [i].enable_application_scheduling;

{ Update the Control group attributes.

          jmv$application_table_p^ [middle_index].cyclic_aging_interval :=
                changed_applications_p^ [i].cyclic_aging_interval;
          jmv$application_table_p^ [middle_index].maximum_working_set :=
                changed_applications_p^ [i].maximum_working_set;
          jmv$application_table_p^ [middle_index].minimum_working_set :=
                changed_applications_p^ [i].minimum_working_set;
          jmv$application_table_p^ [middle_index].page_aging_interval :=
                changed_applications_p^ [i].page_aging_interval;
          jmv$application_table_p^ [middle_index].service_class_index :=
                changed_applications_p^ [i].service_class_index;
          EXIT /binary_search_for_application/;
        IFEND;
      UNTIL low_index > high_index;
    FOREND;

  PROCEND update_application_table;
?? TITLE := 'update_job_class_table', EJECT ??

{ PURPOSE:
{   The purpose of this request is to update the current job class table with
{   the given existing job class whose attributes have changed.
{ DESIGN:
{   The job class name and index are never updated.  The profile identification,
{   abbreviation, and all Membership group attributes are only updated when
{   a profile is being installed since these changes constitute a structure
{   change in the scheduling profile.  The enable class initiation attribute is
{   not updated for the UNASSIGNED job class when a profile is installed.
{   If this is the first profile installed since the system was deadstarted,
{   initiation of jobs is prevented for all classes except SYSTEM and
{   MAINTENANCE by setting the initiation_level to zero.
{ NOTES:
{   Data validity checks are made and access to the scheduler tables is
{   interlocked prior to calling this procedure.

  PROCEDURE update_job_class_table
    (    changed_job_class: jmt$job_class_attributes;
         install_profile: boolean;
         current_profile_id: ost$name;
     VAR refresh_job_candidates: boolean);

    VAR
      job_class_index: jmt$job_class,
      local_job_class: jmt$job_class_attributes,
      previous_maxws_maximum: jmt$working_set_size;

    refresh_job_candidates := FALSE;

    job_class_index := changed_job_class.index;
    local_job_class := changed_job_class;

{ Retain the elements of the job class table which must not be updated.

    local_job_class.defined := jmv$job_class_table_p^ [job_class_index].defined;
    local_job_class.next_rank_class := jmv$job_class_table_p^ [job_class_index].next_rank_class;
    IF install_profile AND (job_class_index = jmc$unassigned_job_class) THEN
      local_job_class.enable_class_initiation := jmv$job_class_table_p^ [job_class_index].
            enable_class_initiation;
    IFEND;
    IF install_profile AND (current_profile_id = jmc$sched_profile_deadstart_id) AND
          (job_class_index > jmc$maintenance_job_class) THEN
      local_job_class.initiation_level.preferred := 0;
      local_job_class.initiation_level.maximum_increment := 0;
    IFEND;

{ Retain the elements of the job class table which need special processing to
{ be updated.

    local_job_class.prolog_p := jmv$job_class_table_p^ [job_class_index].prolog_p;
    local_job_class.epilog_p := jmv$job_class_table_p^ [job_class_index].epilog_p;
    previous_maxws_maximum := jmv$job_class_table_p^ [job_class_index].maximum_working_set.maximum;

{ Check for attribute changes which require the job candidates for execution to
{ be refreshed.

    IF (jmv$job_class_table_p^ [job_class_index].enable_class_initiation <>
          local_job_class.enable_class_initiation) OR (jmv$job_class_table_p^ [job_class_index].
          initial_service_class_index <> local_job_class.initial_service_class_index) OR
          (jmv$job_class_table_p^ [job_class_index].initiation_level <> local_job_class.initiation_level) THEN
      refresh_job_candidates := TRUE;
    IFEND;

    jmv$job_class_table_p^ [job_class_index] := local_job_class;

{ Process any changes in maximum working set, prolog, and epilog after the job
{ class table has been updated.  jmv$max_class_working_set only needs to be examined if there are jobs
{ of this class initiated.  Note that since the System Job is not considered in the value of
{ jmv$max_class_working_set, the check is for an initiated_jobs count greater than zero if the job class is
{ NOT the system_job_class and a count greater than 1 if the job class is the system_job_class.

    IF (jmv$job_counts.job_class_counts [job_class_index].
          initiated_jobs > $INTEGER (jmc$system_job_class = job_class_index)) THEN
      IF jmv$job_class_table_p^ [job_class_index].maximum_working_set.maximum > jmv$max_class_working_set THEN
        jmv$max_class_working_set := jmv$job_class_table_p^ [job_class_index].maximum_working_set.maximum;
      ELSEIF (previous_maxws_maximum = jmv$max_class_working_set) THEN
        jmp$reset_max_class_working_set;
      IFEND;
    IFEND;


    IF jmv$job_class_table_p^ [job_class_index].prolog_p <> NIL THEN
      IF changed_job_class.prolog_p <> NIL THEN
        IF jmv$job_class_table_p^ [job_class_index].prolog_p^ <> changed_job_class.prolog_p^ THEN
          FREE jmv$job_class_table_p^ [job_class_index].prolog_p IN osv$mainframe_pageable_heap^;
          ALLOCATE jmv$job_class_table_p^ [job_class_index].prolog_p:
                [STRLENGTH (changed_job_class.prolog_p^)] IN osv$mainframe_pageable_heap^;
          jmv$job_class_table_p^ [job_class_index].prolog_p^ := changed_job_class.prolog_p^;
        IFEND;
      ELSE
        FREE jmv$job_class_table_p^ [job_class_index].prolog_p IN osv$mainframe_pageable_heap^;
      IFEND;
    ELSEIF changed_job_class.prolog_p <> NIL THEN
      ALLOCATE jmv$job_class_table_p^ [job_class_index].prolog_p: [STRLENGTH (changed_job_class.prolog_p^)] IN
            osv$mainframe_pageable_heap^;
      jmv$job_class_table_p^ [job_class_index].prolog_p^ := changed_job_class.prolog_p^;
    IFEND;

    IF jmv$job_class_table_p^ [job_class_index].epilog_p <> NIL THEN
      IF changed_job_class.epilog_p <> NIL THEN
        IF jmv$job_class_table_p^ [job_class_index].epilog_p^ <> changed_job_class.epilog_p^ THEN
          FREE jmv$job_class_table_p^ [job_class_index].epilog_p IN osv$mainframe_pageable_heap^;
          ALLOCATE jmv$job_class_table_p^ [job_class_index].epilog_p:
                [STRLENGTH (changed_job_class.epilog_p^)] IN osv$mainframe_pageable_heap^;
          jmv$job_class_table_p^ [job_class_index].epilog_p^ := changed_job_class.epilog_p^;
        IFEND;
      ELSE
        FREE jmv$job_class_table_p^ [job_class_index].epilog_p IN osv$mainframe_pageable_heap^;
      IFEND;
    ELSEIF changed_job_class.epilog_p <> NIL THEN
      ALLOCATE jmv$job_class_table_p^ [job_class_index].epilog_p: [STRLENGTH (changed_job_class.epilog_p^)] IN
            osv$mainframe_pageable_heap^;
      jmv$job_class_table_p^ [job_class_index].epilog_p^ := changed_job_class.epilog_p^;
    IFEND;

  PROCEND update_job_class_table;
?? TITLE := 'update_job_scheduler_table', EJECT ??

{ PURPOSE:
{   The purpose of this request is to update the current job scheduler table with
{   the given job scheduler controls which have changed.
{ DESIGN:
{   The profile identification and all Membership group attributes are never
{   updated since changing these would constitute a change in the structure of
{   the scheduling profile.
{   If dispatching allocation is being changed, monitor request must be issued to
{   change tables used by dispatcher.  The scheduler table must be updated before
{   the monitor request is issued.
{ NOTES:
{   Data validity checks are made and access to the scheduler tables is
{   interlocked prior to calling this procedure.

  PROCEDURE update_job_scheduler_table
    (    controls_p: ^jmt$job_scheduler_table;
     VAR refresh_job_candidates: boolean);

    VAR
      dp: 1 .. 15,
      local_controls: jmt$job_scheduler_table,
      rb: jmt$rb_scheduler_requests;

    refresh_job_candidates := FALSE;

    IF controls_p = NIL THEN
      RETURN;
    IFEND;

    local_controls := controls_p^;

{ Retain the current Membership group attributes.

    local_controls.validation_categories_p := jmv$job_scheduler_table.validation_categories_p;

{ Check for attribute changes which require the job candidates for execution to be refreshed.

    IF (jmv$job_scheduler_table.initiation_excluded_categories <>
          local_controls.initiation_excluded_categories) OR (jmv$job_scheduler_table.
          initiation_required_categories <> local_controls.initiation_required_categories) THEN
      refresh_job_candidates := TRUE;
    IFEND;

    jmv$job_scheduler_table := local_controls;

{ Issue a monitor request to check and change the dispatching allocation controls.

    rb.reqcode := syc$rc_job_scheduler_request;
    rb.sub_reqcode := jmc$src_dispatching_allocation;
    i#call_monitor (#LOC (rb), #SIZE (rb));

{ Update the dual-state dispatching priority table. This is the table that
{ the dispatcher reads during task selection. It does not have to be updated in
{ monitor mode. The table will be wrong (because not updated in MM) for a maximum
{ a one timeslice. The table has the priorities and subpriorities for NOS/VE priorities
{ P1 through P14. Only the values P1 through P10 can be modified by the scheduling utilities.
{ Priorities P11 through P14 are hard-coded.

    FOR dp := jmc$priority_p1 TO jmc$priority_p10 DO
      tmv$dual_state_dispatch_prior [dp].dual_state_priority :=
            jmv$job_scheduler_table.dual_state_priority_control [dp].priority;
      tmv$dual_state_dispatch_prior [dp].subpriority := jmv$job_scheduler_table.
            dual_state_priority_control [dp].subpriority;
    FOREND;

  PROCEND update_job_scheduler_table;
?? TITLE := 'update_service_class_table', EJECT ??

{ PURPOSE:
{   The purpose of this request is to update the current service class table with
{   the given existing service class whose attributes have changed.
{ DESIGN:
{   The service class name and index are never updated.  The profile
{   identification and abbreviation are only updated when a profile is being
{   installed since these changes constitute a structure change in the
{   scheduling profile.
{   Because dispatcher is using the dispatching control field in monitor mode
{   during task switch, the dispatching control field of the service class
{   table cannot be changed in job mode.  Dispatching control changes must be
{   synchronized by setting a scheduler event to have scheduler issue a monitor
{   request to change the dispatching control field.
{ NOTES:
{   Data validity checks are made and access to the scheduler tables is
{   interlocked prior to calling this procedure.

  PROCEDURE update_service_class_table
    (    changed_service_class: jmt$service_class_attributes;
     VAR dispatching_control_change: boolean;
     VAR decreased_maxaj: boolean;
     VAR increased_maxaj: boolean);

    VAR
      dispatching_control_p: ^jmt$dispatching_control_changes,
      entry: jmt$dispatching_control_index,
      local_service_class: jmt$service_class_attributes,
      new_dispatching_control_p: ^jmt$dispatching_control_changes,
      next_dispatching_control_p: ^jmt$dispatching_control_changes,
      old_value_maxaj: jmt$maximum_active_jobs,
      service_class_index: jmt$service_class_index,
      service_class_p: ^jmt$service_class_attributes;

    dispatching_control_change := FALSE;
    decreased_maxaj := FALSE;
    increased_maxaj := FALSE;

    service_class_index := changed_service_class.index;
    local_service_class := changed_service_class;
    service_class_p := ^jmv$service_classes [service_class_index]^.attributes;

{ Retain the elements of the service class table which must not be updated.

    local_service_class.defined := service_class_p^.defined;
    local_service_class.dispatching_control := service_class_p^.dispatching_control;

{ Check for changes in attributes that require special processing.

    old_value_maxaj := service_class_p^.maximum_active_jobs;
    IF old_value_maxaj > changed_service_class.maximum_active_jobs THEN
      decreased_maxaj := TRUE;
    ELSEIF old_value_maxaj < changed_service_class.maximum_active_jobs THEN
      IF (service_class_index IN jmv$classes_in_maxaj_limit_wait) THEN
        increased_maxaj := TRUE;
      IFEND;
    IFEND;

    IF changed_service_class.next_service_class_index = jmc$null_service_class THEN
      local_service_class.next_service_class_index := service_class_index;
    IFEND;

    service_class_p^ := local_service_class;

{ Process any changes in dispatching control after the service class table has been updated.

    FOR entry := jmc$min_dispatching_control TO jmc$max_dispatching_control DO
      IF local_service_class.dispatching_control [entry] <>
            changed_service_class.dispatching_control [entry] THEN
        dispatching_control_change := TRUE;
      IFEND;
    FOREND;

    IF dispatching_control_change THEN

      osp$set_mainframe_sig_lock (jmv$change_dispatching_list.lock);

      ALLOCATE new_dispatching_control_p IN osv$mainframe_wired_heap^;
      new_dispatching_control_p^.change_service_class := service_class_index;
      new_dispatching_control_p^.dispatching_control_info := changed_service_class.dispatching_control;
      new_dispatching_control_p^.dispatching_control_changes_p := NIL;

{ Link the new set of dispatching control changes into the list for monitor.

      IF jmv$change_dispatching_list.dispatching_control_changes_p = NIL THEN
        jmv$change_dispatching_list.dispatching_control_changes_p := new_dispatching_control_p;
      ELSE
        next_dispatching_control_p := jmv$change_dispatching_list.dispatching_control_changes_p;
        WHILE next_dispatching_control_p <> NIL DO
          dispatching_control_p := next_dispatching_control_p;
          next_dispatching_control_p := dispatching_control_p^.dispatching_control_changes_p;
        WHILEND;
        dispatching_control_p^.dispatching_control_changes_p := new_dispatching_control_p;
      IFEND;

      osp$clear_mainframe_sig_lock (jmv$change_dispatching_list.lock);

    IFEND;

  PROCEND update_service_class_table;

MODEND jmm$job_scheduler_utility;
*DECK DECK=JMM$JOB_SCHEDULER_UTILITY_R3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : Scheduling Utility Interfaces' ??
MODULE jmm$job_scheduler_utility_r3;

{ PURPOSE:
{   This module contains the ring 3 interfaces for the MANAGE_ACTIVE_SCHEDULING
{   utility.  These interfaces manage the active scheduler tables and provide
{   miscellaneous support functions for the scheduling utility and the
{   scheduling profile.
{ DESIGN:
{   This module contains the system interfaces which enable the MANAGE_ACTIVE_
{   SCHEDULING utility to activate and install a new scheduling profile in the
{   scheduler tables, update an existing profile in the tables, and obtain the
{   contents of these tables.  It also contains an interface for system deadstart
{   which obtains the size of the scheduler tables associated with the system
{   scheduling profile.
{ NOTES:
{   Applicable documents for the MANAGE_ACTIVE_SCHEDULING utility include:
{   NOS/VE Job Scheduling Phase II ERS, DCS# A7594
{   NOS/VE Job Scheduling Phase IIA Increment Plan DCS# ARH7808

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc cle$ecc_lexical
*copyc clt$string_size
*copyc fst$goi_object_information
*copyc jmc$class_names
*copyc jmc$job_management_id
*copyc jmc$status_message_text
*copyc jmc$system_scheduling_profile
*copyc jme$job_scheduler_conditions
*copyc jme$queued_file_conditions
*copyc jme$work_area_too_small
*copyc jmt$application_attributes
*copyc jmt$application_index
*copyc jmt$application_name
*copyc jmt$application_set
*copyc jmt$application_table
*copyc jmt$class_kind
*copyc jmt$defined_classes
*copyc jmt$job_category
*copyc jmt$job_category_data
*copyc jmt$job_class
*copyc jmt$job_class_attributes
*copyc jmt$job_class_set
*copyc jmt$job_class_statistics
*copyc jmt$job_class_table
*copyc jmt$job_scheduler_table
*copyc jmt$profile_header
*copyc jmt$scheduling_attr_results
*copyc jmt$scheduling_results_keys
*copyc jmt$service_class_attributes
*copyc jmt$service_class_index
*copyc jmt$service_class_set
*copyc jmt$service_class_statistics
*copyc jmt$service_class_table
*copyc jmt$system_profile_cycle_number
*copyc jmt$work_area
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc ost$binary_unique_name
*copyc ost$caller_identifier
*copyc ost$status
?? POP ??
*copyc amp$return
*copyc avp$get_capability
*copyc clp$get_processing_phase
*copyc clp$get_source
*copyc clp$validate_name
*copyc fsp$close_file
*copyc fsp$expand_file_label
*copyc fsp$open_file
*copyc jmp$clear_leveler_profile_flag
*copyc jmp$clear_utility_active_flag
*copyc jmp$deactivate_job_leveling
*copyc jmp$determine_job_class
*copyc jmp$determine_service_class
*copyc jmp$install_profile_in_tables
*copyc jmp$read_application_record
*copyc jmp$read_category_data
*copyc jmp$read_defined_classes
*copyc jmp$read_job_class_record
*copyc jmp$read_scheduler_table
*copyc jmp$ready_job_leveler_task
*copyc jmp$set_profile_loading_flag
*copyc jmp$set_utility_active_flag
*copyc jmp$system_job
*copyc jmp$update_profile_in_tables
*copyc jmp$verify_utility_access_id
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$begin_system_activity
*copyc osp$check_for_desired_mf_class
*copyc osp$disestablish_cond_handler
*copyc osp$end_system_activity
*copyc osp$establish_block_exit_hndlr
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$verify_system_privilege
*copyc pfp$begin_system_authority
*copyc pfp$change
*copyc pfp$end_system_authority
*copyc pfp$get_object_information
*copyc pfp$purge
*copyc qfp$move_input_q_to_unassigned
*copyc rmp$request_mass_storage
*copyc syp$process_deadstart_status
*copyc osv$deadstart_phase
*copyc jmv$application_table_p
*copyc jmv$default_job_class_attr
*copyc jmv$default_service_class_attr
*copyc jmv$default_application_attr
*copyc jmv$jcb
*copyc jmv$job_category_data
*copyc jmv$job_class_table_p
*copyc jmv$job_counts
*copyc jmv$job_scheduler_table
*copyc jmv$kjl_p
*copyc jmv$max_service_class_in_use
*copyc jmv$maximum_job_class_in_use
*copyc jmv$maximum_job_classes
*copyc jmv$maximum_service_classes
*copyc jmv$scheduling_utility_usage
*copyc jmv$service_classes
?? TITLE := 'check_active_jobs', EJECT ??

{ PURPOSE:
{   The purpose of this request is to determine if there are jobs active in
{   the job and service classes which are to be deleted from the active
{   scheduler tables.
{ NOTES:
{   Verification that the job and service classes are defined in the scheduler
{   tables has been made prior to calling this procedure.

  PROCEDURE check_active_jobs
    (    deleted_job_classes: jmt$job_class_set;
         deleted_service_classes: jmt$service_class_set;
     VAR status: ost$status);

    VAR
      job_class_index: jmt$job_class,
      service_class_index: jmt$service_class_index;

    status.normal := TRUE;

    IF deleted_job_classes <> $jmt$job_class_set [] THEN
      FOR job_class_index := jmc$lowest_site_job_class TO jmv$maximum_job_class_in_use DO
        IF job_class_index IN deleted_job_classes THEN
          IF jmv$job_counts.job_class_counts [job_class_index].initiated_jobs > 0 THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$delete_class_still_active, jmc$smt_job_class,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  jmv$job_class_table_p^ [job_class_index].name, status);
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;

    IF deleted_service_classes <> $jmt$service_class_set [] THEN
      FOR service_class_index := jmc$lowest_site_service_class TO jmv$max_service_class_in_use DO
        IF service_class_index IN deleted_service_classes THEN
          IF jmv$job_counts.service_class_counts [service_class_index].scheduler_initiated_jobs > 0 THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$delete_class_still_active,
                  jmc$smt_service_class, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  jmv$service_classes [service_class_index]^.attributes.name, status);
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;

  PROCEND check_active_jobs;
?? TITLE := 'delete_profile_cycle', EJECT ??

{ PURPOSE:
{   The purpose of this request is to delete the specified cycle of the
{   system scheduling profile permanent file if it exists.

  PROCEDURE delete_profile_cycle
    (    cycle_number: pft$cycle_number;
     VAR status: ost$status);

?? NEWTITLE := 'handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      IF status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;
?? OLDTITLE, EJECT ??

    VAR
      file_cycle: pft$cycle_selector,
      local_status: ost$status,
      path: array [1 .. 4] of pft$name;

    status.normal := TRUE;

    path [1] := jmc$scheduling_profile_family;
    path [2] := jmc$scheduling_profile_user;
    path [3] := jmc$scheduling_profile_catalog;
    path [4] := jmc$scheduling_profile_filename;
    file_cycle.cycle_option := pfc$specific_cycle;
    file_cycle.cycle_number := cycle_number;

    osp$establish_block_exit_hndlr (^handle_block_exit);
    pfp$begin_system_authority;
    pfp$purge (path, file_cycle, jmc$scheduling_profile_password, local_status);
    pfp$end_system_authority;
    osp$disestablish_cond_handler;
    IF NOT local_status.normal THEN
      IF local_status.condition <> pfe$unknown_cycle THEN
        status := local_status;
      IFEND;
    IFEND;

  PROCEND delete_profile_cycle;
?? TITLE := '[XDCL, #GATE] jmp$abort_deadstart', EJECT ??
*copy jmh$abort_deadstart

  PROCEDURE [XDCL, #GATE] jmp$abort_deadstart
    (    display_message: string ( * );
         display_status: ost$status;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      message: ost$status_message,
      msg_line_count: ^ost$status_message_line_count,
      msg_line_size: ^ost$status_message_line_size,
      msg_line_text: ^ost$status_message_line,
      pointer: ^ost$status_message;

    status.normal := TRUE;

    IF NOT jmp$system_job () THEN
      osp$set_status_condition (jme$must_be_system_job, status);
      RETURN;
    IFEND;

    IF (osv$deadstart_phase <> osc$normal_deadstart) THEN
      RETURN;
    IFEND;

{ Format the error message since the deadstart message proceesor cannot process
{ templates.

  /format_error_message/
    BEGIN
      osp$format_message (display_status, osc$full_message_level, 256, message, local_status);
      IF NOT local_status.normal THEN
        EXIT /format_error_message/;
      IFEND;

      pointer := ^message;
      RESET pointer;
      NEXT msg_line_count IN pointer;
      IF msg_line_count = NIL THEN
        EXIT /format_error_message/;
      IFEND;
      NEXT msg_line_size IN pointer;
      IF msg_line_size = NIL THEN
        EXIT /format_error_message/;
      IFEND;
      NEXT msg_line_text: [msg_line_size^] IN pointer;
      IF msg_line_text = NIL THEN
        EXIT /format_error_message/;
      IFEND;

{ No return is expected from this call.

      syp$process_deadstart_status (msg_line_text^, {fatal_status} TRUE, status);
    END /format_error_message/;

{ Issue a general text message if the template message cannot be generated.

{ No return is expected from this call.

    syp$process_deadstart_status ('The system scheduling profile contains more Job and/or Service ' CAT
          'Classes than were declared at deadstart.', {fatal_status} TRUE, display_status);

  PROCEND jmp$abort_deadstart;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$change_profile_cycle', EJECT ??
*copy jmh$change_profile_cycle

  PROCEDURE [XDCL, #GATE] jmp$change_profile_cycle
    (    access_id: ost$binary_unique_name;
     VAR status: ost$status);

?? NEWTITLE := 'handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      IF status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;
?? OLDTITLE, EJECT ??

    VAR
      change_list: array [1 .. 1] of pft$change_descriptor,
      file_cycle: pft$cycle_selector,
      local_access_id: ost$binary_unique_name,
      local_status: ost$status,
      path: array [1 .. 4] of pft$name;

    status.normal := TRUE;
    local_access_id := access_id;
    jmp$verify_utility_access_id (local_access_id, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    path [1] := jmc$scheduling_profile_family;
    path [2] := jmc$scheduling_profile_user;
    path [3] := jmc$scheduling_profile_catalog;
    path [4] := jmc$scheduling_profile_filename;
    file_cycle.cycle_option := pfc$specific_cycle;
    file_cycle.cycle_number := 1;

    change_list [1].change_type := pfc$cycle_number_change;
    change_list [1].cycle_number := 2;

    osp$establish_block_exit_hndlr (^handle_block_exit);
    pfp$begin_system_authority;
    pfp$change (path, file_cycle, jmc$scheduling_profile_password, change_list, status);
    pfp$end_system_authority;
    osp$disestablish_cond_handler;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND jmp$change_profile_cycle;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$clear_utility_active', EJECT ??
*copy jmh$clear_utility_active

  PROCEDURE [XDCL, #GATE] jmp$clear_utility_active
    (    access_id: ost$binary_unique_name;
     VAR status: ost$status);

    VAR
      local_access_id: ost$binary_unique_name,
      local_status: ost$status;

    status.normal := TRUE;

    jmp$get_scheduling_admin_status (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    local_access_id := access_id;
    jmp$clear_utility_active_flag (local_access_id, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND jmp$clear_utility_active;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$close_system_profile', EJECT ??
*copy jmh$close_system_profile

  PROCEDURE [XDCL, #GATE] jmp$close_system_profile
    (    access_id: ost$binary_unique_name;
         detach_file: boolean;
         file_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      local_access_id: ost$binary_unique_name,
      local_status: ost$status;

    local_access_id := access_id;
    jmp$verify_utility_access_id (local_access_id, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    fsp$close_file (file_identifier, status);

    IF status.normal AND detach_file THEN
      amp$return (jmc$scheduling_profile_pathname CAT '.1', status);
    IFEND;

  PROCEND jmp$close_system_profile;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$delete_profile_cycle', EJECT ??
*copy jmh$delete_profile_cycle

  PROCEDURE [XDCL, #GATE] jmp$delete_profile_cycle
    (    access_id: ost$binary_unique_name;
         cycle_number: jmt$system_profile_cycle_number;
     VAR status: ost$status);

    VAR
      local_access_id: ost$binary_unique_name,
      local_status: ost$status;

    status.normal := TRUE;
    local_access_id := access_id;
    jmp$verify_utility_access_id (local_access_id, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    delete_profile_cycle (cycle_number, status);

  PROCEND jmp$delete_profile_cycle;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$get_active_scheduling_attr', EJECT ??
*copy jmh$get_active_scheduling_attr

  PROCEDURE [XDCL] jmp$get_active_scheduling_attr
    (    job_class_name: ost$name;
         scheduling_results_keys_p: ^jmt$scheduling_results_keys;
     VAR work_area_p: {input, output} ^jmt$work_area;
     VAR scheduling_attribute_results_p: ^jmt$scheduling_attr_results;
     VAR status: ost$status);


    VAR
      caller_id: ost$caller_identifier,
      job_class_found: boolean,
      job_class_index: jmt$job_class,
      key_index: ost$non_negative_integers,
      local_status: ost$status,
      number_of_keys: ost$non_negative_integers,
      queued_jobs: jmt$job_count_range,
      queued_job_class_index: jmt$job_class,
      service_class_index: jmt$service_class_index,
      service_class_status: ost$status;


    status.normal := TRUE;
    local_status.normal := TRUE;
    service_class_status.normal := TRUE;

    #CALLER_ID (caller_id);
    IF caller_id.ring > osc$tsrv_ring THEN
      jmp$get_scheduling_admin_status (local_status);
      IF NOT local_status.normal THEN
        status := local_status;
        RETURN;
      IFEND;
    IFEND;

    scheduling_attribute_results_p := NIL;

    IF scheduling_results_keys_p <> NIL THEN
      number_of_keys := UPPERBOUND (scheduling_results_keys_p^);
      IF number_of_keys > 0 THEN
        NEXT scheduling_attribute_results_p: [1 .. number_of_keys] IN work_area_p;
        IF scheduling_attribute_results_p = NIL THEN
          osp$set_status_condition (jme$work_area_too_small, status);
          RETURN;
        IFEND;

        job_class_found := FALSE;

      /find_job_class_index/
        FOR job_class_index := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
          IF jmv$job_class_table_p^ [job_class_index].defined AND
                (jmv$job_class_table_p^ [job_class_index].name = job_class_name) THEN
            job_class_found := TRUE;
            service_class_index := jmv$job_class_table_p^ [job_class_index].initial_service_class_index;
            IF (service_class_index = 0) OR (jmv$service_classes [service_class_index] = NIL) OR
                  (NOT jmv$service_classes [service_class_index]^.attributes.defined) THEN

{ This status will only be returned if a service class attribute has been requested.

              osp$set_status_abnormal (jmc$job_management_id, jme$class_index_not_defined,
                    jmc$smt_service_class, service_class_status);
              osp$append_status_integer (osc$status_parameter_delimiter, service_class_index, 10, FALSE,
                    service_class_status);
            IFEND;
            EXIT /find_job_class_index/;
          IFEND;
        FOREND /find_job_class_index/;

        FOR key_index := 1 TO number_of_keys DO
          scheduling_attribute_results_p^ [key_index].key := scheduling_results_keys_p^ [key_index];
          CASE scheduling_results_keys_p^ [key_index] OF
          = jmc$sak_active_jobs =
            IF job_class_found THEN
              IF service_class_status.normal THEN
                scheduling_attribute_results_p^ [key_index].active_jobs :=
                      jmv$job_counts.service_class_counts [service_class_index].scheduler_initiated_jobs -
                      jmv$job_counts.service_class_counts [service_class_index].swapped_jobs;
              ELSE
                status := service_class_status;
                RETURN;
              IFEND;
            ELSE
              osp$set_status_condition (jme$job_class_not_defined, status);
              RETURN;
            IFEND;

          = jmc$sak_enable_class_initiation =
            IF job_class_found THEN
              scheduling_attribute_results_p^ [key_index].enable_class_initiation :=
                    jmv$job_class_table_p^ [job_class_index].enable_class_initiation;
            ELSE
              osp$set_status_condition (jme$job_class_not_defined, status);
              RETURN;
            IFEND;

          = jmc$sak_enable_job_leveling =
            scheduling_attribute_results_p^ [key_index].enable_job_leveling :=
                  jmv$job_scheduler_table.enable_job_leveling;

          = jmc$sak_initiation_age_interval =
            IF job_class_found THEN
              scheduling_attribute_results_p^ [key_index].initiation_age_interval :=
                    jmv$job_class_table_p^ [job_class_index].initiation_age_interval;
            ELSE
              osp$set_status_condition (jme$job_class_not_defined, status);
              RETURN;
            IFEND;

          = jmc$sak_initiation_level =
            IF job_class_found THEN
              scheduling_attribute_results_p^ [key_index].initiation_level :=
                    jmv$job_class_table_p^ [job_class_index].initiation_level;
            ELSE
              osp$set_status_condition (jme$job_class_not_defined, status);
              RETURN;
            IFEND;

          = jmc$sak_job_leveling_prior_bias =
            scheduling_attribute_results_p^ [key_index].job_leveling_priority_bias :=
                  jmv$job_scheduler_table.job_leveling_priority_bias;

          = jmc$sak_maximum_active_jobs =
            IF job_class_found THEN
              scheduling_attribute_results_p^ [key_index].maximum_active_jobs :=
                    jmv$service_classes [service_class_index]^.attributes.maximum_active_jobs;
            ELSE
              osp$set_status_condition (jme$job_class_not_defined, status);
              RETURN;
            IFEND;

          = jmc$sak_null_attribute =
            ;

          = jmc$sak_queued_jobs =
            IF job_class_found THEN
              IF service_class_status.normal THEN
                queued_jobs := 0;

              /compute_queued_job_counts/
                FOR queued_job_class_index := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
                  IF jmv$job_class_table_p^ [queued_job_class_index].defined THEN
                    IF jmv$job_class_table_p^ [queued_job_class_index].initial_service_class_index =
                          service_class_index THEN
                      queued_jobs := queued_jobs + jmv$job_counts.job_class_counts [queued_job_class_index].
                            queued_jobs;
                    IFEND;
                  IFEND;
                FOREND /compute_queued_job_counts/;
                scheduling_attribute_results_p^ [key_index].queued_jobs := queued_jobs;
              ELSE
                status := service_class_status;
                RETURN;
              IFEND;
            ELSE
              osp$set_status_condition (jme$job_class_not_defined, status);
              RETURN;
            IFEND;

          = jmc$sak_selection_priority =
            IF job_class_found THEN
              scheduling_attribute_results_p^ [key_index].selection_priority :=
                    jmv$job_class_table_p^ [job_class_index].selection_priority;
            ELSE
              osp$set_status_condition (jme$job_class_not_defined, status);
              RETURN;
            IFEND;

          = jmc$sak_swapped_jobs =
            IF job_class_found THEN
              IF service_class_status.normal THEN
                scheduling_attribute_results_p^ [key_index].swapped_jobs :=
                      jmv$job_counts.service_class_counts [service_class_index].swapped_jobs;
              ELSE
                status := service_class_status;
                RETURN;
              IFEND;
            ELSE
              osp$set_status_condition (jme$job_class_not_defined, status);
              RETURN;
            IFEND;

          ELSE
            ;
          CASEND;
        FOREND;
      IFEND;
    IFEND;

  PROCEND jmp$get_active_scheduling_attr;
?? TITLE := '[XDCL, #GATE] jmp$get_application_record', EJECT ??
*copy jmh$get_application_record

  PROCEDURE [XDCL, #GATE] jmp$get_application_record
    (    application_name: jmt$application_name;
     VAR application_record: jmt$application_attributes;
     VAR status: ost$status);

    VAR
      application_index: jmt$application_index,
      caller_id: ost$caller_identifier,
      local_application_name: jmt$application_name,
      local_application_record: jmt$application_attributes,
      local_status: ost$status,
      scl_name: ost$name,
      valid_name: boolean;

    status.normal := TRUE;

    #CALLER_ID (caller_id);
    IF caller_id.ring > osc$tsrv_ring THEN
      jmp$get_scheduling_admin_status (local_status);
      IF NOT local_status.normal THEN
        status := local_status;
        RETURN;
      IFEND;
    IFEND;

    local_application_name := application_name;
    clp$validate_name (local_application_name, scl_name, valid_name);
    IF NOT valid_name THEN
      osp$set_status_abnormal ('CL', cle$improper_name, local_application_name, status);
      RETURN;
    IFEND;

    application_index := 0;
    jmp$read_application_record (application_name, application_index, local_application_record, local_status);
    IF local_status.normal THEN
      application_record := local_application_record;
    ELSE
      status := local_status;
    IFEND;

  PROCEND jmp$get_application_record;
?? TITLE := '[XDCL, #GATE] jmp$get_category_data', EJECT ??
*copy jmh$get_category_data

  PROCEDURE [XDCL, #GATE] jmp$get_category_data
    (VAR category_data: jmt$job_category_data;
     VAR data_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      local_category_data: jmt$job_category_data,
      local_data_length: integer,
      local_data_p: ^SEQ ( * ),
      local_status: ost$status;

    status.normal := TRUE;

    jmp$get_scheduling_admin_status (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    REPEAT
      local_data_length := 1;
      IF jmv$job_category_data.item_list <> NIL THEN
        local_data_length := local_data_length + #SIZE (jmv$job_category_data.item_list^);
      IFEND;
      IF jmv$job_category_data.category_names <> NIL THEN
        local_data_length := local_data_length + #SIZE (jmv$job_category_data.category_names^);
      IFEND;
      PUSH local_data_p: [[REP local_data_length OF cell]];
      IF local_data_p = NIL THEN
        osp$set_status_condition (jme$no_space_in_runtime_stack, status);
        RETURN;
      IFEND;
      jmp$read_category_data (local_category_data, local_data_p, local_status);
      IF NOT local_status.normal AND (local_status.condition <> jme$no_element_in_sequence) THEN
        status := local_status;
        RETURN;
      IFEND;
    UNTIL local_status.normal;

    category_data := local_category_data;
    RESET data_p;
    IF local_category_data.item_list <> NIL THEN
      NEXT category_data.item_list: [[REP #SIZE (local_category_data.item_list^) OF cell]] IN data_p;
      IF category_data.item_list = NIL THEN
        osp$set_status_condition (jme$no_element_in_sequence, status);
        RETURN;
      IFEND;
      category_data.item_list^ := local_category_data.item_list^;
    IFEND;
    IF local_category_data.category_names <> NIL THEN
      NEXT category_data.category_names: [0 .. UPPERBOUND (local_category_data.category_names^)] IN data_p;
      IF category_data.category_names = NIL THEN
        osp$set_status_condition (jme$no_element_in_sequence, status);
        RETURN;
      IFEND;
      category_data.category_names^ := local_category_data.category_names^;
    IFEND;

  PROCEND jmp$get_category_data;
?? TITLE := '[XDCL, #GATE] jmp$get_default_class_values', EJECT ??
*copy jmh$get_default_class_values

  PROCEDURE [XDCL, #GATE] jmp$get_default_class_values
    (VAR job_class_defaults: jmt$job_class_attributes;
     VAR service_class_defaults: jmt$service_class_attributes;
     VAR application_defaults: jmt$application_attributes;
     VAR status: ost$status);

    VAR
      local_status: ost$status;

    status.normal := TRUE;

    jmp$get_scheduling_admin_status (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
    ELSE
      job_class_defaults := jmv$default_job_class_attr;
      service_class_defaults := jmv$default_service_class_attr;
      application_defaults := jmv$default_application_attr;
    IFEND;

  PROCEND jmp$get_default_class_values;
?? TITLE := '[XDCL, #GATE] jmp$get_defined_classes', EJECT ??
*copy jmh$get_defined_classes

  PROCEDURE [XDCL, #GATE] jmp$get_defined_classes
    (    class_kind: jmt$class_kind;
     VAR defined_classes: jmt$defined_classes;
     VAR number_of_classes: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      local_class_kind: jmt$class_kind,
      local_defined_classes_p: ^jmt$defined_classes,
      local_status: ost$status;

    status.normal := TRUE;
    number_of_classes := 0;

    jmp$get_scheduling_admin_status (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    local_class_kind := class_kind;
    IF (local_class_kind < LOWERVALUE (jmt$class_kind)) OR (local_class_kind > UPPERVALUE (jmt$class_kind))
          THEN
      osp$set_status_condition (jme$unknown_class_kind, status);
    ELSE
      PUSH local_defined_classes_p: [1 .. UPPERBOUND (defined_classes)];
      jmp$read_defined_classes (local_class_kind, local_defined_classes_p^, number_of_classes, local_status);
      IF local_status.normal THEN
        defined_classes := local_defined_classes_p^;
      ELSE
        status := local_status;
        IF local_status.condition = jme$error_in_job_class_ranking THEN
          defined_classes := local_defined_classes_p^;
        IFEND;
      IFEND;
    IFEND;

  PROCEND jmp$get_defined_classes;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$get_job_class_epilog', EJECT ??
*copy jmh$get_job_class_epilog

  PROCEDURE [XDCL] jmp$get_job_class_epilog
    (VAR job_class_epilog: fst$file_reference;
     VAR status: ost$status);

    VAR
      job_class_index: jmt$job_class;

    status.normal := TRUE;

    job_class_index := jmv$kjl_p^ [jmv$jcb.job_id].job_class;
    IF jmv$job_class_table_p^ [job_class_index].defined THEN
      IF jmv$job_class_table_p^ [job_class_index].epilog_p <> NIL THEN
        job_class_epilog := jmv$job_class_table_p^ [job_class_index].epilog_p^;
      ELSE
        job_class_epilog := '';
      IFEND;
    ELSE
      osp$set_status_condition (jme$job_class_not_defined, status);
    IFEND;

  PROCEND jmp$get_job_class_epilog;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$get_job_class_prolog', EJECT ??
*copy jmh$get_job_class_prolog

  PROCEDURE [XDCL, #GATE] jmp$get_job_class_prolog
    (VAR job_class_prolog: fst$file_reference;
     VAR status: ost$status);

    VAR
      job_class_index: jmt$job_class;

    osp$verify_system_privilege;
    status.normal := TRUE;

    job_class_index := jmv$kjl_p^ [jmv$jcb.job_id].job_class;
    IF jmv$job_class_table_p^ [job_class_index].defined THEN
      IF jmv$job_class_table_p^ [job_class_index].prolog_p <> NIL THEN
        job_class_prolog := jmv$job_class_table_p^ [job_class_index].prolog_p^;
      ELSE
        job_class_prolog := '';
      IFEND;
    ELSE
      osp$set_status_condition (jme$job_class_not_defined, status);
    IFEND;

  PROCEND jmp$get_job_class_prolog;
?? TITLE := '[XDCL, #GATE] jmp$get_job_class_record', EJECT ??
*copy jmh$get_job_class_record

  PROCEDURE [XDCL, #GATE] jmp$get_job_class_record
    (    job_class_index: jmt$job_class;
     VAR job_class_record: jmt$job_class_attributes;
     VAR data_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      local_data_length: integer,
      local_data_p: ^SEQ ( * ),
      local_job_class_index: jmt$job_class,
      local_job_class_record: jmt$job_class_attributes,
      local_status: ost$status;

    status.normal := TRUE;

    jmp$get_scheduling_admin_status (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    local_job_class_index := job_class_index;
    IF (local_job_class_index = 0) OR (local_job_class_index > jmv$maximum_job_class_in_use) OR
          (NOT jmv$job_class_table_p^ [local_job_class_index].defined) THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$class_index_not_defined, jmc$smt_job_class, status);
      osp$append_status_integer (osc$status_parameter_delimiter, local_job_class_index, 10, FALSE, status);
      RETURN;
    IFEND;

    REPEAT
      local_data_length := 1;
      IF jmv$job_class_table_p^ [local_job_class_index].prolog_p <> NIL THEN
        local_data_length := local_data_length + #SIZE (jmv$job_class_table_p^ [local_job_class_index].
              prolog_p^);
      IFEND;
      IF jmv$job_class_table_p^ [local_job_class_index].epilog_p <> NIL THEN
        local_data_length := local_data_length + #SIZE (jmv$job_class_table_p^ [local_job_class_index].
              epilog_p^);
      IFEND;
      PUSH local_data_p: [[REP local_data_length OF cell]];
      IF local_data_p = NIL THEN
        osp$set_status_condition (jme$no_space_in_runtime_stack, status);
        RETURN;
      IFEND;
      jmp$read_job_class_record (local_job_class_index, local_job_class_record, local_data_p, local_status);
      IF NOT local_status.normal AND (local_status.condition <> jme$no_element_in_sequence) THEN
        status := local_status;
        RETURN;
      IFEND;
    UNTIL local_status.normal;

    job_class_record := local_job_class_record;
    RESET data_p;
    IF local_job_class_record.prolog_p <> NIL THEN
      NEXT job_class_record.prolog_p: [STRLENGTH (local_job_class_record.prolog_p^)] IN data_p;
      IF job_class_record.prolog_p = NIL THEN
        osp$set_status_condition (jme$no_element_in_sequence, status);
        RETURN;
      IFEND;
      job_class_record.prolog_p^ := local_job_class_record.prolog_p^;
    IFEND;
    IF local_job_class_record.epilog_p <> NIL THEN
      NEXT job_class_record.epilog_p: [STRLENGTH (local_job_class_record.epilog_p^)] IN data_p;
      IF job_class_record.epilog_p = NIL THEN
        osp$set_status_condition (jme$no_element_in_sequence, status);
        RETURN;
      IFEND;
      job_class_record.epilog_p^ := local_job_class_record.epilog_p^;
    IFEND;

  PROCEND jmp$get_job_class_record;
?? TITLE := '[XDCL, #GATE] jmp$get_job_class_statistics', EJECT ??
*copy jmh$get_job_class_statistics

  PROCEDURE [XDCL, #GATE] jmp$get_job_class_statistics
    (    job_class_index: jmt$job_class;
     VAR job_class_statistics: jmt$job_class_statistics;
     VAR status: ost$status);

    VAR
      local_status: ost$status;

    status.normal := TRUE;

    jmp$get_scheduling_admin_status (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    IF (job_class_index = 0) OR (job_class_index > jmv$maximum_job_class_in_use) OR
          (NOT jmv$job_class_table_p^ [job_class_index].defined) THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$class_index_not_defined, jmc$smt_job_class, status);
      osp$append_status_integer (osc$status_parameter_delimiter, job_class_index, 10, FALSE, status);
      RETURN;
    IFEND;

    job_class_statistics.queued_jobs := jmv$job_counts.job_class_counts [job_class_index].queued_jobs;
    job_class_statistics.initiated_jobs := jmv$job_counts.job_class_counts [job_class_index].initiated_jobs;

  PROCEND jmp$get_job_class_statistics;
?? TITLE := '[XDCL, #GATE] jmp$get_length_of_sched_tables', EJECT ??
*copy jmh$get_length_of_sched_tables

  PROCEDURE [XDCL, #GATE] jmp$get_length_of_sched_tables
    (VAR maximum_job_classes: jmt$job_class;
     VAR maximum_job_class_index: jmt$job_class;
     VAR maximum_service_classes: jmt$service_class_index;
     VAR maximum_service_class_index: jmt$service_class_index;
     VAR maximum_applications: jmt$application_index;
     VAR maximum_categories: integer;
     VAR status: ost$status);

    VAR
      local_status: ost$status;

    status.normal := TRUE;

    jmp$get_scheduling_admin_status (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    maximum_job_classes := jmv$maximum_job_classes;
    maximum_job_class_index := jmc$maximum_job_classes;
    maximum_service_classes := jmv$maximum_service_classes;
    maximum_service_class_index := jmc$maximum_service_classes;
    maximum_applications := jmc$maximum_application_index;
    maximum_categories := jmc$number_of_job_categories;

  PROCEND jmp$get_length_of_sched_tables;
?? TITLE := '[XDCL, #GATE] jmp$get_scheduler_table', EJECT ??
*copy jmh$get_scheduler_table

  PROCEDURE [XDCL, #GATE] jmp$get_scheduler_table
    (VAR scheduler_table: jmt$job_scheduler_table;
     VAR data_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      local_data_length: integer,
      local_data_p: ^SEQ ( * ),
      local_scheduler_table: jmt$job_scheduler_table,
      local_status: ost$status;

    status.normal := TRUE;

    jmp$get_scheduling_admin_status (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    REPEAT
      local_data_length := 1;
      IF jmv$job_scheduler_table.validation_categories_p <> NIL THEN
        local_data_length := local_data_length + #SIZE (jmv$job_scheduler_table.validation_categories_p^);
      IFEND;
      PUSH local_data_p: [[REP local_data_length OF cell]];
      IF local_data_p = NIL THEN
        osp$set_status_condition (jme$no_space_in_runtime_stack, status);
        RETURN;
      IFEND;
      jmp$read_scheduler_table (local_scheduler_table, local_data_p, local_status);
      IF NOT local_status.normal AND (local_status.condition <> jme$no_element_in_sequence) THEN
        status := local_status;
        RETURN;
      IFEND;
    UNTIL local_status.normal;

    scheduler_table := local_scheduler_table;
    RESET data_p;
    IF local_scheduler_table.validation_categories_p <> NIL THEN
      NEXT scheduler_table.validation_categories_p: [1 .. UPPERBOUND (local_scheduler_table.
            validation_categories_p^)] IN data_p;
      IF scheduler_table.validation_categories_p = NIL THEN
        osp$set_status_condition (jme$no_element_in_sequence, status);
        RETURN;
      IFEND;
      scheduler_table.validation_categories_p^ := local_scheduler_table.validation_categories_p^;
    IFEND;

  PROCEND jmp$get_scheduler_table;
?? TITLE := '[XDCL] jmp$get_scheduling_admin_status', EJECT ??
*copy jmh$get_scheduling_admin_status

  PROCEDURE [XDCL] jmp$get_scheduling_admin_status
    (VAR status: ost$status);

    VAR
      administrator_status: boolean,
      override_validation: boolean,
      processing_phase: clt$processing_phase,
      restricted_mainframe: boolean;


?? NEWTITLE := 'check_for_establish_job_classes', EJECT ??

{ This procedure checks to see if the command that initiated this request is on
{ $SYSTEM.OSF$BUILTIN_LIBRARY, its R1 ring attribute is 3, and that the program
{ called (MANAS) is also on $SYSTEM.OSF$BUILTIN_LIBRARY.  This will allow the
{ Soviet 962 systems to deadstart even though the $system user does not have the
{ Scheduling_Administration capability.

    PROCEDURE check_for_establish_job_classes
      (VAR override_validation: boolean;
       VAR status: ost$status);

      CONST
        expected_library_path = ':$SYSTEM.$SYSTEM.OSF$BUILTIN_LIBRARY',
        expected_library_path_size = 36;

      VAR
        file_previously_opened: boolean,
        information_request: fst$goi_information_request,
        object_info_p: ^fst$goi_object_information,
        resolved_path_size: clt$string_size,
        source: clt$source,
        static_label_attributes: bat$static_label_attributes,
        work_area_p: ^SEQ ( * ),
        work_area_size: [STATIC] ost$segment_length := #SIZE (fst$goi_object_information) +
              #SIZE (fst$goi_object) + fsc$max_path_size + #SIZE (bat$static_label_attributes);


      status.normal := TRUE;
      override_validation := FALSE;

      information_request.catalog_depth.depth_specification := fsc$specific_depth;
      information_request.catalog_depth.depth := 1;
      information_request.object_information_requests := $fst$goi_object_info_requests [fsc$goi_file_label];

      PUSH work_area_p: [[REP work_area_size OF cell]];
      RESET work_area_p;

{ Verify that the commands are coming from the expected library.

      pfp$get_object_information (clc$current_command_input, information_request, NIL, work_area_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      RESET work_area_p;
      NEXT object_info_p IN work_area_p;

      resolved_path_size := STRLENGTH (object_info_p^.resolved_path^);
      IF expected_library_path_size <= resolved_path_size THEN
        IF (object_info_p^.resolved_path^ (1, expected_library_path_size) = expected_library_path) THEN

          fsp$expand_file_label (object_info_p^.object^.file_label, static_label_attributes,
                file_previously_opened, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Verify the R1 ring attribute of the file.

          IF static_label_attributes.ring_attributes.r1 <> osc$tsrv_ring THEN
            RETURN;
          IFEND;

{ Verify that the program called is from the expected library.

          clp$get_source (source, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF (source.kind = clc$library_source) AND (source.path_name (1, resolved_path_size) =
                object_info_p^.resolved_path^) THEN
            override_validation := TRUE;
          IFEND;
        IFEND;
      IFEND;
    PROCEND check_for_establish_job_classes;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;

{ If this task already has the utility active there is no need to verify the
{ scheduling_administration capability.

    jmp$verify_utility_access_id (jmv$scheduling_utility_usage.access_id, status);
    IF status.normal THEN
      RETURN;
    IFEND;

    IF NOT jmp$system_job () THEN
      avp$get_capability (avc$scheduling_administration, avc$user, administrator_status, status);
      IF NOT status.normal THEN
        osp$set_status_condition (jme$must_be_scheduling_admin, status);
        RETURN;
      IFEND;
      IF administrator_status THEN
        RETURN;
      IFEND;

      clp$get_processing_phase (processing_phase, status);
      IF status.normal THEN
        IF (processing_phase = clc$class_prolog_phase) OR (processing_phase = clc$class_epilog_phase) THEN
          RETURN;
        IFEND;
      IFEND;
      osp$set_status_condition (jme$must_be_scheduling_admin, status);
    ELSE
      status.normal := TRUE;
      osp$check_for_desired_mf_class (osc$mc_china_or_soviet_class, restricted_mainframe);
      IF restricted_mainframe THEN
        avp$get_capability (avc$scheduling_administration, avc$user, administrator_status, status);
        IF NOT status.normal THEN
          osp$set_status_condition (jme$must_be_scheduling_admin, status);
        ELSEIF NOT administrator_status THEN

{ Check to see if the call was made from the rap$establish_job_classes procedure
{ on OSF$BUILTIN_LIBRARY, and that the program called is also on this library.
{ This will allow Soviet 962 systems to recover the scheduling profile in
{ deadstart even though the system job does not have the Scheduling Administration
{ capability.

          check_for_establish_job_classes (override_validation, status);
          IF (NOT status.normal) OR (NOT override_validation) THEN
            osp$set_status_condition (jme$must_be_scheduling_admin, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND jmp$get_scheduling_admin_status;
?? TITLE := '[XDCL, #GATE] jmp$get_service_class_record', EJECT ??
*copy jmh$get_service_class_record

  PROCEDURE [XDCL, #GATE] jmp$get_service_class_record
    (    service_class_index: jmt$service_class_index;
     VAR service_class_record: jmt$service_class_attributes;
     VAR status: ost$status);

    VAR
      local_status: ost$status;

    status.normal := TRUE;

    jmp$get_scheduling_admin_status (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    IF (service_class_index = 0) OR (jmv$service_classes [service_class_index] = NIL) OR
          (NOT jmv$service_classes [service_class_index]^.attributes.defined) THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$class_index_not_defined, jmc$smt_service_class,
            status);
      osp$append_status_integer (osc$status_parameter_delimiter, service_class_index, 10, FALSE, status);
      RETURN;
    IFEND;

    service_class_record := jmv$service_classes [service_class_index]^.attributes;

  PROCEND jmp$get_service_class_record;
?? TITLE := '[XDCL, #GATE] jmp$get_service_class_stats', EJECT ??
*copy jmh$get_service_class_stats

  PROCEDURE [XDCL, #GATE] jmp$get_service_class_stats
    (    service_class_index: jmt$service_class_index;
     VAR service_class_statistics: jmt$service_class_statistics;
     VAR status: ost$status);

    VAR
      active_jobs: jmt$job_count_range,
      job_class_index: jmt$job_class,
      local_status: ost$status,
      queued_jobs: jmt$job_count_range;

    status.normal := TRUE;

    jmp$get_scheduling_admin_status (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    IF (service_class_index = 0) OR (jmv$service_classes [service_class_index] = NIL) OR
          (NOT jmv$service_classes [service_class_index]^.attributes.defined) THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$class_index_not_defined, jmc$smt_service_class,
            status);
      osp$append_status_integer (osc$status_parameter_delimiter, service_class_index, 10, FALSE, status);
      RETURN;
    IFEND;

    queued_jobs := 0;

  /compute_queued_job_counts/
    FOR job_class_index := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
      IF jmv$job_class_table_p^ [job_class_index].defined THEN
        IF jmv$job_class_table_p^ [job_class_index].initial_service_class_index = service_class_index THEN
          queued_jobs := queued_jobs + jmv$job_counts.job_class_counts [job_class_index].queued_jobs;
        IFEND;
      IFEND;
    FOREND /compute_queued_job_counts/;

    active_jobs := jmv$job_counts.service_class_counts [service_class_index].scheduler_initiated_jobs -
          jmv$job_counts.service_class_counts [service_class_index].swapped_jobs;

    service_class_statistics.queued_jobs := queued_jobs;
    service_class_statistics.active_jobs := active_jobs;
    service_class_statistics.swapped_jobs := jmv$job_counts.service_class_counts [service_class_index].
          swapped_jobs;

  PROCEND jmp$get_service_class_stats;
?? TITLE := '[XDCL, #GATE] jmp$install_profile', EJECT ??
*copy jmh$install_profile

{ DESIGN:
{   Verify that the caller has the proper access and that the profile to be
{   installed contains scheduling definitions that are consistent with the
{   active scheduler tables.  Make the calling job unswappable.  Prevent job
{   submission, job initiation, and service class switching by executing jobs.
{   Check that no jobs are still active in any job or service classes that are
{   going to be deleted.  Move the input queues of job classes that are changing
{   structure or being deleted to the UNASSIGNED job class.  Delete the current
{   scheduling profile, if requested, and then install the new profile in the
{   scheduler tables.  Allow job submission, job initiation, and service class
{   switching to proceed and allow the calling job to be swapped.
{ NOTES:
{   All data verification is performed before the job is made unswappable.
{   While the job is unswappable, the only mass storage I/O performed is the
{   delete of the scheduling profile permanent file.

  PROCEDURE [XDCL, #GATE] jmp$install_profile
    (    access_id: ost$binary_unique_name;
         job_class_entries_p: ^jmt$job_class_table;
         service_class_entries_p: ^jmt$service_class_table;
         application_entries_p: ^jmt$application_table;
         controls_entry: jmt$job_scheduler_table;
         category_data: jmt$job_category_data;
         move_job_classes: jmt$job_class_set;
         deleted_job_classes: jmt$job_class_set;
         deleted_service_classes: jmt$service_class_set;
         deleted_applications: jmt$application_set;
         delete_profile_cycle2: boolean;
     VAR status: ost$status);

    VAR
      cycle_number: pft$cycle_number,
      ignore_status: ost$status,
      local_access_id: ost$binary_unique_name,
      local_number_of_jobs_moved: jmt$job_count_range,
      local_status: ost$status,
      profile_deleted: boolean,
      profile_installed: boolean,
      system_activity_begun: boolean;

?? NEWTITLE := 'install_profile_abort_handler', EJECT ??

{ PURPOSE:
{   The purpose of this request is to clear any restraints on system activity
{   which were set to install a scheduling profile if the install process
{   aborts.

    PROCEDURE install_profile_abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

{ Allow job submission and initiation and service class switching to proceed.

      jmp$set_profile_loading_flag ({profile_is_loading} FALSE, controls_entry.profile_identification,
            ignore_status);

{ Clear special processing for this task.

      IF system_activity_begun THEN
        system_activity_begun := FALSE;
        #SPOIL (system_activity_begun);
        osp$end_system_activity;
      IFEND;

      IF local_status.normal THEN
        IF NOT profile_installed THEN
          IF profile_deleted THEN
            osp$set_status_condition (jme$profile_cycle2_lost, status);
          ELSE
            osp$set_status_condition (jme$profile_not_installed, status);
          IFEND;
        IFEND;
      ELSE
        status := local_status;
      IFEND;

    PROCEND install_profile_abort_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    local_status.normal := TRUE;
    profile_deleted := FALSE;
    profile_installed := FALSE;
    system_activity_begun := FALSE;
    #SPOIL (profile_deleted);
    #SPOIL (profile_installed);
    #SPOIL (system_activity_begun);

    jmp$get_scheduling_admin_status (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    local_access_id := access_id;
    jmp$verify_utility_access_id (local_access_id, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    verify_profile_to_be_installed (job_class_entries_p, service_class_entries_p, application_entries_p,
          move_job_classes, deleted_job_classes, deleted_service_classes, deleted_applications, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^install_profile_abort_handler);

{ Set special processing for this task.

    osp$begin_system_activity;
    system_activity_begun := TRUE;
    #SPOIL (system_activity_begun);

  /install_profile/
    BEGIN

{ Prevent job submission and initiation and service class switching.

      jmp$set_profile_loading_flag ({profile_is_loading} TRUE, controls_entry.profile_identification,
            local_status);
      IF NOT local_status.normal THEN
        EXIT /install_profile/;
      IFEND;

{ Ready all the job levelers that are directly connected and wait for them
{ to unassign jobs from this mainframe (a.k.a., the client).

      jmp$deactivate_job_leveling (local_status);
      IF NOT local_status.normal THEN
        EXIT /install_profile/;
      IFEND;

{ Check that no jobs are active in the job and service classes to be deleted.

      check_active_jobs (deleted_job_classes, deleted_service_classes, local_status);
      IF NOT local_status.normal THEN
        EXIT /install_profile/;
      IFEND;

{ Move the input queues of job classes that are changing structure or being
{ deleted to the UNASSIGNED job class.

      move_jobs_to_unassigned (move_job_classes, local_number_of_jobs_moved, local_status);
      IF NOT local_status.normal THEN
        EXIT /install_profile/;
      IFEND;

{ Delete the current scheduling profile.

      IF delete_profile_cycle2 THEN
        cycle_number := jmc$scheduling_profile_cycle;
        delete_profile_cycle (cycle_number, local_status);
        IF NOT local_status.normal THEN
          EXIT /install_profile/;
        IFEND;
        profile_deleted := TRUE;
        #SPOIL (profile_deleted);
      IFEND;

{ Install the new scheduling profile in the scheduling tables.

      jmp$install_profile_in_tables (local_access_id, job_class_entries_p, service_class_entries_p,
            application_entries_p, controls_entry, category_data, deleted_job_classes,
            deleted_service_classes, deleted_applications, local_status);
      IF NOT local_status.normal THEN
        IF profile_deleted THEN
          osp$set_status_condition (jme$profile_cycle2_lost, local_status);
        ELSE
          osp$set_status_condition (jme$profile_not_installed, local_status);
        IFEND;
        EXIT /install_profile/;
      IFEND;
      profile_installed := TRUE;
      #SPOIL (profile_installed);

    END /install_profile/;

{ Allow job submission and initiation and service class switching to proceed.

    jmp$set_profile_loading_flag ({profile_is_loading} FALSE, controls_entry.profile_identification,
          ignore_status);

{ Clear special processing for this task.

    osp$end_system_activity;
    system_activity_begun := FALSE;
    #SPOIL (system_activity_begun);

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND jmp$install_profile;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$open_system_profile', EJECT ??
*copy jmh$open_system_profile

  PROCEDURE [XDCL, #GATE] jmp$open_system_profile
    (    access_id: ost$binary_unique_name;
         cycle_number: jmt$system_profile_cycle_number;
         open_for_write: boolean;
         validation_attributes_p: ^fst$file_cycle_attributes;
     VAR file_identifier: amt$file_identifier;
     VAR status: ost$status);

?? NEWTITLE := 'handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      IF status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;
?? OLDTITLE, EJECT ??

    CONST
      path_size = jmc$scheduling_profile_path_siz + 2;

    VAR
      access_ring_p: ^fst$file_cycle_attributes,
      attachment_options_p: ^fst$attachment_options,
      creation_ring_p: ^fst$file_cycle_attributes,
      caller_id: ost$caller_identifier,
      file_path: string (path_size),
      local_access_id: ost$binary_unique_name,
      local_status: ost$status;

    status.normal := TRUE;
    local_access_id := access_id;
    jmp$verify_utility_access_id (local_access_id, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    #CALLER_ID (caller_id);

    file_path := jmc$scheduling_profile_pathname CAT '.1';
    IF cycle_number = 2 THEN
      file_path (path_size) := '2';
    IFEND;

{ Attach the file for read access and open the file with the rings of the caller
{
{ Note:
{   For compatibility with MANAS at previous levels of NOS/VE (< 1.5.2), the
{   file is created with ring attributes of osc$user_ring and opened at the
{   larger of of osc$user_ring and the caller ring.  Eventually this should be
{   changed to create the file with rings of (3, 3, 3) and open the file with
{   the rings of the caller.  This must be done in two more phases.  1) Create
{   the file with rings of (3, 3, 3) but open it at the caller ring or
{   osc$user_ring which ever is larger.  2) Override the open ring to the
{   caller ring.

    PUSH creation_ring_p: [1 .. 1];
    creation_ring_p^ [1].selector := fsc$ring_attributes;
    creation_ring_p^ [1].ring_attributes.r1 := osc$user_ring;
    creation_ring_p^ [1].ring_attributes.r2 := osc$user_ring;
    creation_ring_p^ [1].ring_attributes.r3 := osc$user_ring;

    access_ring_p := creation_ring_p;
    IF caller_id.ring > osc$user_ring THEN
      PUSH access_ring_p: [1 .. 1];
      access_ring_p^ [1].ring_attributes.r1 := caller_id.ring;
      access_ring_p^ [1].ring_attributes.r2 := caller_id.ring;
      access_ring_p^ [1].ring_attributes.r3 := caller_id.ring;
    IFEND;

    PUSH attachment_options_p: [1 .. 3];
    attachment_options_p^ [1].selector := fsc$access_and_share_modes;
    attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options_p^ [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options_p^ [1].share_modes.value := $fst$file_access_options [fsc$read];
    attachment_options_p^ [2].selector := fsc$open_position;
    attachment_options_p^ [2].open_position := amc$open_at_boi;
    attachment_options_p^ [3].selector := fsc$create_file;
    attachment_options_p^ [3].create_file := FALSE;

    osp$establish_block_exit_hndlr (^handle_block_exit);
    pfp$begin_system_authority;
    IF open_for_write THEN
      attachment_options_p^ [1].access_modes.value := $fst$file_access_options
            [fsc$read, fsc$append, fsc$modify, fsc$shorten];
      attachment_options_p^ [3].create_file := TRUE;
      rmp$request_mass_storage (file_path, rmc$unspecified_allocation_size, rmc$unspecified_file_size,
            rmc$msc_system_critical_files, rmc$unspecified_vsn, {volume_overflow_allowed =} TRUE, status);
    IFEND;
    IF status.normal THEN
      fsp$open_file (file_path, amc$segment, attachment_options_p, creation_ring_p, validation_attributes_p,
            validation_attributes_p, access_ring_p, file_identifier, status);
    IFEND;
    pfp$end_system_authority;
    osp$disestablish_cond_handler;

  PROCEND jmp$open_system_profile;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$reactivate_job_leveling', EJECT ??
*copy jmh$reactivate_job_leveling

  PROCEDURE [XDCL, #GATE] jmp$reactivate_job_leveling
    (    access_id: ost$binary_unique_name;
     VAR status: ost$status);

    VAR
      ignore_leveler_exists: boolean,
      local_status: ost$status;

    status.normal := TRUE;
    jmp$clear_leveler_profile_flag (access_id, local_status);
    IF local_status.normal THEN
      jmp$ready_job_leveler_task (ignore_leveler_exists);
    ELSE
      status := local_status;
    IFEND;
  PROCEND jmp$reactivate_job_leveling;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$set_utility_active', EJECT ??
*copy jmh$set_utility_active

  PROCEDURE [XDCL, #GATE] jmp$set_utility_active
    (VAR access_id: ost$binary_unique_name;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      local_access_id: ost$binary_unique_name;

    status.normal := TRUE;

    jmp$get_scheduling_admin_status (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    jmp$set_utility_active_flag (local_access_id, local_status);
    IF local_status.normal THEN
      access_id := local_access_id;
    ELSE
      status := local_status;
    IFEND;

  PROCEND jmp$set_utility_active;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$update_profile', EJECT ??
*copy jmh$update_profile

{ DESIGN:
{   Verify that the caller has the proper access and that the structure
{   of the scheduling profile is not being changed.  Verify that all of the
{   job classes, service classes, and applications to be updated are defined
{   in the scheduler tables and that the job and service classes have the
{   same indices.  Update the profile in the scheduler tables.
{ NOTES:
{   A change in structure is indicated by a change in the profile identification
{   field of the job scheduler controls, a class, or an application.
{   The following types of changes are not made by an update request.  They
{   require an install request.
{   . change in category data
{   . addition of a class or application
{   . deletion of a class or application
{   . change in the  Membership attributes of the job scheduler controls or
{           job classes
{   . change in the name, abbreviation, or index of a class
{   . change in the name of an application

  PROCEDURE [XDCL, #GATE] jmp$update_profile
    (    access_id: ost$binary_unique_name;
         changed_job_classes_p: ^jmt$job_class_table;
         changed_service_classes_p: ^jmt$service_class_table;
         changed_applications_p: ^jmt$application_table;
         controls_p: ^jmt$job_scheduler_table;
     VAR status: ost$status);

    VAR
      application_record: jmt$application_attributes,
      application_index: jmt$application_index,
      i: integer,
      job_class_index: jmt$job_class,
      job_class_name: jmt$job_class_name,
      local_access_id: ost$binary_unique_name,
      local_status: ost$status,
      service_class_index: jmt$service_class_index,
      service_class_name: jmt$service_class_name;


    status.normal := TRUE;

    jmp$get_scheduling_admin_status (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    local_access_id := access_id;
    jmp$verify_utility_access_id (local_access_id, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

{ Verify that the structure of the scheduling profile is not being changed.

    IF controls_p <> NIL THEN
      IF controls_p^.profile_identification <> jmv$job_scheduler_table.profile_identification THEN
        osp$set_status_condition (jme$profile_id_mismatch, status);
        RETURN;
      IFEND;
    IFEND;

{ Verify that the job classes to be updated are defined with the same name
{ and class index in the job class table and that their structure is not being
{ changed.

    IF changed_job_classes_p <> NIL THEN
      FOR i := 1 TO UPPERBOUND (changed_job_classes_p^) DO
        job_class_index := changed_job_classes_p^ [i].index;
        job_class_name := changed_job_classes_p^ [i].name;
        IF jmv$job_class_table_p^ [job_class_index].defined THEN
          IF jmv$job_class_table_p^ [job_class_index].name <> job_class_name THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$class_index_conflict, jmc$smt_job_class,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, job_class_name, status);
            RETURN;
          ELSEIF jmv$job_class_table_p^ [job_class_index].profile_identification <>
                changed_job_classes_p^ [i].profile_identification THEN
            osp$set_status_condition (jme$profile_id_mismatch, status);
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal (jmc$job_management_id, jme$class_or_appl_not_defined, jmc$smt_job_class,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, job_class_name, status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;

{ Verify that the service classes to be updated are defined with the same name
{ and class index in the service class table and that their structure is not
{ being changed.

    IF changed_service_classes_p <> NIL THEN
      FOR i := 1 TO UPPERBOUND (changed_service_classes_p^) DO
        service_class_index := changed_service_classes_p^ [i].index;
        service_class_name := changed_service_classes_p^ [i].name;
        IF (jmv$service_classes [service_class_index] <> NIL) AND
              jmv$service_classes [service_class_index]^.attributes.defined THEN
          IF jmv$service_classes [service_class_index]^.attributes.name <> service_class_name THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$class_index_conflict, jmc$smt_service_class,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, service_class_name, status);
            RETURN;
          ELSEIF jmv$service_classes [service_class_index]^.attributes.profile_identification <>
                changed_service_classes_p^ [i].profile_identification THEN
            osp$set_status_condition (jme$profile_id_mismatch, status);
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal (jmc$job_management_id, jme$class_or_appl_not_defined,
                jmc$smt_service_class, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, service_class_name, status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;

{ Verify that the applications to be updated are defined in the application
{ table.

    IF changed_applications_p <> NIL THEN
      FOR i := 1 TO UPPERBOUND (changed_applications_p^) DO
        application_index := 0;
        jmp$read_application_record (changed_applications_p^ [i].name, application_index, application_record,
              local_status);
        IF NOT local_status.normal THEN
          status := local_status;
          RETURN;
        IFEND;
        IF application_record.profile_identification <> changed_applications_p^ [i].
              profile_identification THEN
          osp$set_status_condition (jme$profile_id_mismatch, status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    jmp$update_profile_in_tables (local_access_id, changed_job_classes_p, changed_service_classes_p,
          changed_applications_p, controls_p, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND jmp$update_profile;
?? OLDTITLE ??
?? NEWTITLE := 'move_jobs_to_unassigned', EJECT ??

{ PURPOSE:
{   The purpose of this request is to move the input queues for the given job
{   classes to the UNASSIGNED job class.
{ NOTES:
{   Verification that the job classes are defined in the job class table has
{   been made prior to calling this procedure.

  PROCEDURE move_jobs_to_unassigned
    (    move_job_classes: jmt$job_class_set;
     VAR number_of_jobs_moved: jmt$job_count_range;
     VAR status: ost$status);

    VAR
      job_class_index: jmt$job_class,
      jobs_moved: jmt$job_count_range;

    status.normal := TRUE;
    number_of_jobs_moved := 0;

    FOR job_class_index := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
      IF job_class_index IN move_job_classes THEN
        qfp$move_input_q_to_unassigned (job_class_index, jobs_moved, status);
        number_of_jobs_moved := number_of_jobs_moved + jobs_moved;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND move_jobs_to_unassigned;
?? TITLE := 'verify_applications_in_profile', EJECT ??

{ PURPOSE:
{   The purpose of this request is to verify that applications in the profile
{   to be installed contain valid application definitions.
{ DESIGN:
{   Verify that the applications to be installed do not exceed the maximum
{   number supported by the system.  Verify that they have a unique name and
{   are sorted in ascending sequence by name.

  PROCEDURE verify_applications_in_profile
    (    application_entries_p: ^jmt$application_table;
     VAR status: ost$status);

    VAR
      application_name: jmt$application_name,
      entry: ost$non_negative_integers,
      next_entry: ost$non_negative_integers,
      number_of_entries: ost$non_negative_integers;

    status.normal := TRUE;

    IF application_entries_p <> NIL THEN
      number_of_entries := UPPERBOUND (application_entries_p^);
      IF number_of_entries > jmc$maximum_application_index THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$profile_too_large, jmc$smt_applications, status);
        osp$append_status_integer (osc$status_parameter_delimiter, jmc$maximum_application_index, 10, FALSE,
              status);
        RETURN;
      IFEND;
      FOR entry := 1 TO number_of_entries DO
        application_name := application_entries_p^ [entry].name;
        next_entry := entry + 1;
        IF next_entry < number_of_entries THEN
          IF application_name > application_entries_p^ [next_entry].name THEN
            osp$set_status_condition (jme$applications_not_sorted, status);
            RETURN;
          IFEND;
        IFEND;

      /verify_unique_names/
        WHILE next_entry < number_of_entries DO
          IF application_name = application_entries_p^ [next_entry].name THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$class_or_appl_not_unique, jmc$smt_application,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, application_name, status);
            RETURN;
          IFEND;
          next_entry := next_entry + 1;
        WHILEND /verify_unique_names/;
      FOREND;
    IFEND;

  PROCEND verify_applications_in_profile;
?? TITLE := 'verify_classes_to_be_deleted', EJECT ??

{ PURPOSE:
{   The purpose of this request is to verify that the classes and applications
{   to be deleted are valid for deletion.
{ DESIGN:
{   Verify that the job and service classes to be deleted are defined in the
{   scheduler tables and are not any of the predefined classes, SYSTEM,
{   MAINTENANCE, or UNASSIGNED.  Verify that the applications to be deleted
{   are defined in the application table for application scheduling.

  PROCEDURE verify_classes_to_be_deleted
    (    deleted_job_classes: jmt$job_class_set;
         deleted_service_classes: jmt$service_class_set;
         deleted_applications: jmt$application_set;
     VAR status: ost$status);

    VAR
      application_index: jmt$application_index,
      job_class_index: jmt$job_class,
      service_class_index: jmt$service_class_index;

    status.normal := TRUE;

{ Verify job classes to be deleted.

    IF deleted_job_classes <> $jmt$job_class_set [] THEN
      FOR job_class_index := jmc$system_job_class TO jmc$maximum_job_classes DO
        IF job_class_index IN deleted_job_classes THEN
          IF (job_class_index > jmv$maximum_job_class_in_use) OR
                (NOT jmv$job_class_table_p^ [job_class_index].defined) THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$class_index_not_defined, jmc$smt_job_class,
                  status);
            osp$append_status_integer (osc$status_parameter_delimiter, job_class_index, 10, FALSE, status);
            RETURN;
          ELSEIF job_class_index < jmc$lowest_site_job_class THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$no_delete_of_default_class, jmc$smt_job_class,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  jmv$job_class_table_p^ [job_class_index].name, status);
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;

{ Verify service classes to be deleted.

    IF deleted_service_classes <> $jmt$service_class_set [] THEN
      FOR service_class_index := jmc$system_service_class TO jmc$maximum_service_classes DO
        IF service_class_index IN deleted_service_classes THEN
          IF (service_class_index > jmv$max_service_class_in_use) OR
                (jmv$service_classes [service_class_index] = NIL) OR
                (NOT jmv$service_classes [service_class_index]^.attributes.defined) THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$class_index_not_defined,
                  jmc$smt_service_class, status);
            osp$append_status_integer (osc$status_parameter_delimiter, service_class_index, 10, FALSE,
                  status);
            RETURN;
          ELSEIF service_class_index < jmc$lowest_site_service_class THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$no_delete_of_default_class,
                  jmc$smt_service_class, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  jmv$service_classes [service_class_index]^.attributes.name, status);
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;

{ Verify applications to be deleted.

    IF deleted_applications <> $jmt$application_set [] THEN
      FOR application_index := 1 TO jmc$maximum_application_index DO
        IF application_index IN deleted_applications THEN
          IF jmv$application_table_p = NIL THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$class_index_not_defined, jmc$smt_application,
                  status);
            osp$append_status_integer (osc$status_parameter_delimiter, application_index, 10, FALSE, status);
            RETURN;
          ELSEIF (application_index > UPPERBOUND (jmv$application_table_p^)) OR
                (NOT jmv$application_table_p^ [application_index].defined) THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$class_index_not_defined, jmc$smt_application,
                  status);
            osp$append_status_integer (osc$status_parameter_delimiter, application_index, 10, FALSE, status);
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;

  PROCEND verify_classes_to_be_deleted;
?? TITLE := 'verify_classes_to_be_moved', EJECT ??

{ PURPOSE:
{   The purpose of this request is to verify that the job classes whose input
{   queues are to be moved to the UNASSIGNED job class are defined in the
{   job class table.

  PROCEDURE verify_classes_to_be_moved
    (    move_job_classes: jmt$job_class_set;
     VAR status: ost$status);

    VAR
      job_class_index: jmt$job_class;

    status.normal := TRUE;

    FOR job_class_index := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
      IF job_class_index IN move_job_classes THEN
        IF NOT jmv$job_class_table_p^ [job_class_index].defined THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$class_index_not_defined, jmc$smt_job_class,
                status);
          osp$append_status_integer (osc$status_parameter_delimiter, job_class_index, 10, FALSE, status);
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND verify_classes_to_be_moved;
?? TITLE := 'verify_job_classes_in_profile', EJECT ??

{ PURPOSE:
{   The purpose of this request is to verify that job classes in the profile
{   to be installed contain valid job class definitions that are consistent
{   with the active job class table.
{ DESIGN:
{   Verify that the job classes to be installed have a unique name,
{   abbreviation, and class index and that existing classes defined in
{   the job class table retain the same index.

  PROCEDURE verify_job_classes_in_profile
    (    job_class_entries_p: ^jmt$job_class_table;
         deleted_job_classes: jmt$job_class_set;
     VAR status: ost$status);

    VAR
      current_job_class_index: jmt$job_class,
      entry: ost$non_negative_integers,
      existing_job_classes: jmt$job_class_set,
      job_class_abbreviation: jmt$job_class_name,
      job_class_index: jmt$job_class,
      job_class_name: jmt$job_class_name,
      local_status: ost$status,
      next_entry: ost$non_negative_integers;

    status.normal := TRUE;
    existing_job_classes := $jmt$job_class_set [];

    IF job_class_entries_p <> NIL THEN

      FOR entry := 1 TO UPPERBOUND (job_class_entries_p^) DO
        job_class_index := job_class_entries_p^ [entry].index;
        job_class_name := job_class_entries_p^ [entry].name;
        job_class_abbreviation := job_class_entries_p^ [entry].abbreviation;
        IF job_class_index = jmc$null_job_class THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$class_index_not_defined, jmc$smt_job_class,
                status);
          osp$append_status_integer (osc$status_parameter_delimiter, job_class_index, 10, FALSE, status);
          RETURN;
        IFEND;
        IF job_class_index < jmc$lowest_site_job_class THEN
          IF job_class_entries_p^ [entry].automatic_class_selection THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$no_ranking_of_default_class,
                  jmc$smt_job_class, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, job_class_name, status);
            RETURN;
          IFEND;
        IFEND;

{ Verify that an existing job class has the same index and a new job class
{ has a valid index.

        jmp$determine_job_class (job_class_name, current_job_class_index, local_status);
        IF local_status.normal AND (job_class_name = jmv$job_class_table_p^ [current_job_class_index].name)
              THEN
          IF job_class_index = current_job_class_index THEN
            existing_job_classes := existing_job_classes + $jmt$job_class_set [job_class_index];
          ELSE
            osp$set_status_abnormal (jmc$job_management_id, jme$class_index_conflict, jmc$smt_job_class,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, job_class_name, status);
            RETURN;
          IFEND;
        ELSEIF jmv$job_class_table_p^ [job_class_index].defined THEN
          IF NOT (job_class_index IN deleted_job_classes) THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$class_index_already_in_use, jmc$smt_job_class,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  jmv$job_class_table_p^ [job_class_index].name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, job_class_index, 10, FALSE, status);
            RETURN;
          IFEND;
        IFEND;

{ Verify the uniqueness of the job class name, abbreviation, and index.

        next_entry := entry + 1;

      /verify_uniqueness/
        WHILE next_entry < UPPERBOUND (job_class_entries_p^) DO
          IF (job_class_name = job_class_entries_p^ [next_entry].name) OR
                (job_class_name = job_class_entries_p^ [next_entry].abbreviation) THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$class_or_appl_not_unique, jmc$smt_job_class,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, job_class_name, status);
            RETURN;
          ELSEIF (job_class_abbreviation <> jmc$null_class_name) AND
                ((job_class_abbreviation = job_class_entries_p^ [next_entry].name) OR
                (job_class_abbreviation = job_class_entries_p^ [next_entry].abbreviation)) THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$class_abbrev_not_unique, jmc$smt_job_class,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, job_class_abbreviation, status);
            RETURN;
          ELSEIF job_class_index = job_class_entries_p^ [next_entry].index THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$class_index_already_in_use, jmc$smt_job_class,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, job_class_name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, job_class_index, 10, FALSE, status);
            RETURN;
          IFEND;
          next_entry := next_entry + 1;
        WHILEND /verify_uniqueness/;

      FOREND;
    IFEND;

{ Check for any classes in the job class table which are not accounted for in the
{ profile being installed.

    FOR job_class_index := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
      IF jmv$job_class_table_p^ [job_class_index].defined THEN
        IF NOT ((job_class_index IN deleted_job_classes) OR (job_class_index IN existing_job_classes)) THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$excess_class_in_sched_table, jmc$smt_job_class,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                jmv$job_class_table_p^ [job_class_index].name, status);
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND verify_job_classes_in_profile;
?? TITLE := 'verify_profile_to_be_installed', EJECT ??

{ PURPOSE:
{   The purpose of this request is to verify that the profile to be installed
{   contains valid scheduler table definitions and is consistent with the
{   active scheduler tables.
{ DESIGN:
{   Verify that the classes and applications to be deleted are valid for
{   deletion.  Verify that job classes whose input queues are to be moved
{   are defined in the job class table.  Verify that the job and service
{   classes to be installed contain valid class definitions that are
{   consistent with the active job and service class tables.  Verify that
{   the applications to be installed contain valid application definitions.

  PROCEDURE verify_profile_to_be_installed
    (    job_class_entries_p: ^jmt$job_class_table;
         service_class_entries_p: ^jmt$service_class_table;
         application_entries_p: ^jmt$application_table;
         move_job_classes: jmt$job_class_set;
         deleted_job_classes: jmt$job_class_set;
         deleted_service_classes: jmt$service_class_set;
         deleted_applications: jmt$application_set;
     VAR status: ost$status);

    status.normal := TRUE;

    verify_classes_to_be_deleted (deleted_job_classes, deleted_service_classes, deleted_applications, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    verify_classes_to_be_moved (move_job_classes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    verify_job_classes_in_profile (job_class_entries_p, deleted_job_classes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    verify_serv_classes_in_profile (service_class_entries_p, deleted_service_classes, job_class_entries_p,
          application_entries_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    verify_applications_in_profile (application_entries_p, status);

  PROCEND verify_profile_to_be_installed;
?? TITLE := 'verify_serv_classes_in_profile', EJECT ??

{ PURPOSE:
{   The purpose of this request is to verify that service classes in the profile
{   to be installed contain valid service class definitions that are consistent
{   with the active service class table.
{ DESIGN:
{   Verify that the service classes to be installed will fit in the service class
{   table space allocated during deadstart.  Verify that they have a unique
{   name, abbreviation, and class index and that existing classes defined in
{   the service class table retain the same index.  Verify that all service
{   classes referenced by job classes, other service classes, and applications
{   are defined in the profile.

  PROCEDURE verify_serv_classes_in_profile
    (    service_class_entries_p: ^jmt$service_class_table;
         deleted_service_classes: jmt$service_class_set;
         job_class_entries_p: ^jmt$job_class_table;
         application_entries_p: ^jmt$application_table;
     VAR status: ost$status);

    VAR
      all_service_classes: jmt$service_class_set,
      current_service_class_index: jmt$service_class_index,
      entry: ost$non_negative_integers,
      existing_service_classes: jmt$service_class_set,
      local_status: ost$status,
      next_entry: ost$non_negative_integers,
      service_class_abbreviation: jmt$service_class_name,
      service_class_index: jmt$service_class_index,
      service_class_name: jmt$service_class_name,
      unknown_service_class_index: jmt$service_class_index;

    status.normal := TRUE;
    all_service_classes := $jmt$service_class_set [];
    existing_service_classes := $jmt$service_class_set [];

    IF service_class_entries_p <> NIL THEN
      service_class_index := 0;
      FOR entry := 1 TO UPPERBOUND (service_class_entries_p^) DO
        IF (service_class_entries_p^ [entry].index > service_class_index) THEN
          service_class_index := service_class_entries_p^ [entry].index;
        IFEND;
      FOREND;

      FOR entry := 1 TO UPPERBOUND (service_class_entries_p^) DO
        service_class_index := service_class_entries_p^ [entry].index;
        service_class_name := service_class_entries_p^ [entry].name;
        service_class_abbreviation := service_class_entries_p^ [entry].abbreviation;
        all_service_classes := all_service_classes + $jmt$service_class_set [service_class_index];
        IF service_class_index = jmc$null_service_class THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$class_index_not_defined, jmc$smt_service_class,
                status);
          osp$append_status_integer (osc$status_parameter_delimiter, service_class_index, 10, FALSE, status);
          RETURN;
        IFEND;

{ Verify that an existing service class has the same index and a new service
{ class has a valid index.

        jmp$determine_service_class (service_class_name, current_service_class_index, local_status);
        IF (local_status.normal) AND (service_class_name = jmv$service_classes [current_service_class_index]^.
              attributes.name) THEN
          IF service_class_index = current_service_class_index THEN
            existing_service_classes := existing_service_classes + $jmt$service_class_set
                  [service_class_index];
          ELSE
            osp$set_status_abnormal (jmc$job_management_id, jme$class_index_conflict, jmc$smt_service_class,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, service_class_name, status);
            RETURN;
          IFEND;
        ELSEIF (jmv$service_classes [service_class_index] <> NIL) AND
              jmv$service_classes [service_class_index]^.attributes.defined THEN
          IF NOT (service_class_index IN deleted_service_classes) THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$class_index_already_in_use,
                  jmc$smt_service_class, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  jmv$service_classes [service_class_index]^.attributes.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, service_class_index, 10, FALSE,
                  status);
            RETURN;
          IFEND;
        IFEND;

{ Verify the uniqueness of the service class name, abbreviation, and index.

        next_entry := entry + 1;

      /verify_uniqueness/
        WHILE next_entry < UPPERBOUND (service_class_entries_p^) DO
          IF (service_class_name = service_class_entries_p^ [next_entry].name) OR
                (service_class_name = service_class_entries_p^ [next_entry].abbreviation) THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$class_or_appl_not_unique,
                  jmc$smt_service_class, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, service_class_name, status);
            RETURN;
          ELSEIF (service_class_abbreviation <> jmc$null_class_name) AND
                ((service_class_abbreviation = service_class_entries_p^ [next_entry].name) OR
                (service_class_abbreviation = service_class_entries_p^ [next_entry].abbreviation)) THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$class_abbrev_not_unique,
                  jmc$smt_service_class, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, service_class_abbreviation, status);
            RETURN;
          ELSEIF service_class_index = service_class_entries_p^ [next_entry].index THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$class_index_already_in_use,
                  jmc$smt_service_class, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, service_class_name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, service_class_index, 10, FALSE,
                  status);
            RETURN;
          IFEND;
          next_entry := next_entry + 1;
        WHILEND /verify_uniqueness/;

      FOREND;
    IFEND;

{ Check for any classes in the service class table which are not accounted for in the
{ profile being installed.

    FOR service_class_index := jmc$system_service_class TO jmv$max_service_class_in_use DO
      IF (jmv$service_classes [service_class_index] <> NIL) AND
            jmv$service_classes [service_class_index]^.attributes.defined THEN
        IF NOT ((service_class_index IN deleted_service_classes) OR
              (service_class_index IN existing_service_classes)) THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$excess_class_in_sched_table,
                jmc$smt_service_class, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                jmv$service_classes [service_class_index]^.attributes.name, status);
          RETURN;
        IFEND;
      IFEND;
    FOREND;

{ Check that service classes referenced by job classes, other service classes,
{ and applications are defined in the profile.

    unknown_service_class_index := jmc$null_service_class;

    IF job_class_entries_p <> NIL THEN

    /check_job_class_references/
      FOR entry := 1 TO UPPERBOUND (job_class_entries_p^) DO
        IF NOT (job_class_entries_p^ [entry].initial_service_class_index IN all_service_classes) THEN
          unknown_service_class_index := job_class_entries_p^ [entry].initial_service_class_index;
        IFEND;
      FOREND /check_job_class_references/;
    IFEND;

    IF service_class_entries_p <> NIL THEN

    /check_service_class_references/
      FOR entry := 1 TO UPPERBOUND (service_class_entries_p^) DO
        IF service_class_entries_p^ [entry].next_service_class_index <> jmc$null_service_class THEN
          IF NOT (service_class_entries_p^ [entry].next_service_class_index IN all_service_classes) THEN
            unknown_service_class_index := service_class_entries_p^ [entry].next_service_class_index;
          IFEND;
        IFEND;
      FOREND /check_service_class_references/;
    IFEND;

    IF application_entries_p <> NIL THEN

    /check_application_references/
      FOR entry := 1 TO UPPERBOUND (application_entries_p^) DO
        IF application_entries_p^ [entry].service_class_index <> jmc$null_service_class THEN
          IF NOT (application_entries_p^ [entry].service_class_index IN all_service_classes) THEN
            unknown_service_class_index := application_entries_p^ [entry].service_class_index;
          IFEND;
        IFEND;
      FOREND /check_application_references/;
    IFEND;

    IF unknown_service_class_index <> jmc$null_service_class THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$class_index_not_defined, jmc$smt_service_class,
            status);
      osp$append_status_integer (osc$status_parameter_delimiter, unknown_service_class_index, 10, FALSE,
            status);
    IFEND;

  PROCEND verify_serv_classes_in_profile;

MODEND jmm$job_scheduler_utility_r3;
*DECK DECK=JMM$JOB_SCHED_TABLE_INIT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : Scheduler Tables Initialization' ??
MODULE jmm$job_sched_table_init;

{ PURPOSE:
{   This module initializes the job scheduler tables.
{ DESIGN:
{   The scheduler tables are initialized during system deadstart before the
{   job scheduler task is initiated.  Initialization is performed for the
{   job scheduler, job category data, job class, service class, output class,
{   and application tables.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$class_names
*copyc jmc$sched_profile_deadstart_id
*copyc jmt$application_table
*copyc jmt$dispatching_control
*copyc jmt$dispatching_control_index
*copyc jmt$job_category_data
*copyc jmt$job_class
*copyc jmt$job_class_table
*copyc jmt$output_class_table
*copyc jmt$profile_index_to_job_class
*copyc jmt$scheduler_tables_access
*copyc jmt$scheduling_utility_usage
*copyc ost$status
?? POP ??

*copyc osp$generate_unique_binary_name
*copyc osp$initialize_sig_lock
*copyc pmp$convert_mainframe_to_binary
*copyc pmp$cycle
*copyc pmp$zero_out_table
*copyc jmv$jcb
*copyc jmv$job_scheduler_table
*copyc jmv$last_service_calc_time
*copyc jmv$max_class_working_set
*copyc jmv$max_service_class_in_use
*copyc jmv$service_classes
*copyc mmv$tick_time
*copyc osv$mainframe_pageable_heap
*copyc osv$mainframe_wired_heap
*copyc pmv$mainframe_id
*copyc pmv$quantum
*copyc tmv$null_global_task_id
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    jmv$application_table_p: [XDCL, #GATE, oss$mainframe_pageable] ^jmt$application_table,
    jmv$job_category_data: [XDCL, #GATE, oss$mainframe_pageable] jmt$job_category_data,
    jmv$highest_rank_job_class: [XDCL, #GATE, oss$mainframe_pageable] jmt$job_class,
    jmv$job_class_table_p: [XDCL, #GATE, oss$mainframe_pageable] ^jmt$job_class_table,
    jmv$maximum_job_class_in_use: [XDCL, #GATE, oss$mainframe_pageable] jmt$job_class,
    jmv$maximum_job_classes: [XDCL, #GATE, oss$mainframe_pageable] 0 .. 0ffffffff(16) := 15,
    jmv$maximum_output_classes: [XDCL, #GATE, oss$mainframe_pageable] 0 .. 0ffffffff(16) := 1,
    jmv$maximum_output_class_in_use: [XDCL, #GATE, oss$mainframe_pageable] jmt$output_class_index,
    jmv$maximum_profile_index: [XDCL, #GATE, oss$mainframe_pageable] jmt$job_class,
    jmv$maximum_service_classes: [XDCL, #GATE, oss$mainframe_pageable] 0 .. 0ffffffff(16) := 15,
    jmv$output_class_table_p: [XDCL, #GATE, oss$mainframe_pageable] ^jmt$output_class_table,
    jmv$profile_index_to_job_class: [XDCL, #GATE, oss$mainframe_pageable] jmt$profile_index_to_job_class,
    jmv$scheduler_tables_access: [XDCL, #GATE, oss$mainframe_pageable] jmt$scheduler_tables_access,
    jmv$scheduling_utility_usage: [XDCL, #GATE, oss$mainframe_pageable] jmt$scheduling_utility_usage;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE, OSS$MAINFRAME_PAGEABLE] jmv$default_application_attr', EJECT ??

  VAR
    jmv$default_application_attr: [XDCL, #GATE, oss$mainframe_pageable] jmt$application_attributes := [

?? FMT (FORMAT = OFF) ??

{ Definition group attributes.

{     defined                        #} FALSE,
{     profile_identification         #} jmc$sched_profile_deadstart_id,
{     name                           #} osc$null_name,
{     enable_application_scheduling  #} TRUE,

{ Control group attributes.

{     cyclic_aging_interval          #} jmc$unspecified_aging_interval,
{     maximum_working_set            #} jmc$unspecified_work_set_size,
{     minimum_working_set            #} jmc$unspecified_work_set_size,
{     page_aging_interval            #} jmc$unspecified_aging_interval,
{     service_class_index            #} jmc$unspecified_service_class];

?? FMT (FORMAT = ON) ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE, OSS$MAINFRAME_PAGEABLE] jmv$default_job_class_attr', EJECT ??

  VAR
    jmv$default_job_class_attr: [XDCL, #GATE, oss$mainframe_pageable] jmt$job_class_attributes := [

?? FMT (FORMAT = OFF) ??

{ Definition group attributes.

{    defined                        #} FALSE,
{    index                          #} jmc$null_job_class,
{    profile_index                  #} 0,
{    profile_identification         #} jmc$sched_profile_deadstart_id,
{    name                           #} jmc$null_class_name,
{    abbreviation                   #} jmc$null_class_name,
{    prolog_p                       #} NIL,
{    epilog_p                       #} NIL,
{    enable_class_initiation        #} TRUE,
{    immediate_initiation_candidate #} FALSE,
{    default_output_class           #} jmc$normal_class_name,
{    initial_service_class_index    #} jmc$null_service_class,
{    initial_working_set            #} 65,

{ Control attributes.

{    cyclic_aging_interval          #} [50000, 10000, 1000000000],
{    defer_on_submit                #} FALSE,
{    initiation_level               #} [20, 0],
{    maximum_working_set            #} [1000, 20, 1000],
{    minimum_working_set            #} [20, 20, 1000],
{    page_aging_interval            #} [0, 10000, 1000000000],

{ Limit attributes.

{    cpu_time_limit                 #} jmc$unlimited_cpu_time_limit,
{    detached_job_wait_time         #} [3600, 0, 18000],
{    magnetic_tape_limit            #} jmc$unlimited_mag_tape_limit,
{    sru_limit                      #} jmc$unlimited_sru_limit,

{ Membership attributes.

{    automatic_class_selection      #} FALSE,
{    excluded_categories            #} $jmt$job_category_set [],
{    next_rank_class                #} jmc$null_job_class,
{    required_categories            #} $jmt$job_category_set [],

{ Priority group attributes.

{    initiation_age_interval        #} 1000000,
{    job_leveling_priority_bias     #} 0,
{    multiple_job_bias              #} 0,
{    selection_priority             #} [100, 10000, 1, 0]];

?? FMT (FORMAT = ON) ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE, OSS$MAINFRAME_PAGEABLE] jmv$default_output_class_attr', EJECT ??

  VAR
    jmv$default_output_class_attr: [XDCL, #GATE, oss$mainframe_pageable] jmt$output_class_attributes := [

?? FMT (FORMAT = OFF) ??

{ Definition group attributes.

{    defined                        #} FALSE,
{    index                          #} jmc$null_output_class,
{    profile_identification         #} jmc$sched_profile_deadstart_id,
{    name                           #} jmc$null_class_name,
{    abbreviation                   #} jmc$null_class_name,
{    enable_class_scheduling        #} TRUE,

{ Priority group attributes.

{    delivery_priority              #} [100, 2000, 1],
{    output_age_interval            #} 1000000];

?? FMT (FORMAT = ON) ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE, OSS$MAINFRAME_PAGEABLE] jmv$default_service_class_attr', EJECT ??

  VAR
    jmv$default_service_class_attr: [XDCL, #GATE, oss$mainframe_pageable] jmt$service_class_attributes := [

?? FMT (FORMAT = OFF) ??

{ Definition group attributes.

{    defined                        #} FALSE,
{    index                          #} jmc$null_service_class,
{    profile_identification         #} jmc$sched_profile_deadstart_id,
{    name                           #} jmc$null_class_name,
{    abbreviation                   #} jmc$null_class_name,

{ Control group attributes.

{    aio_limit                      #} 60000,
{    class_service_threshold        #} jmc$unlimited_service_accum,
{    guaranteed_service_quantum     #} 100,
{    long_wait_think_time           #} 0,
{    maximum_active_jobs            #} 20,
{    next_service_class_index       #} jmc$null_service_class,
{    service_factors                #} [1, 0, 0, 0],

{ Priority group attributes.

{    dispatching_control [1]        #} [[TRUE, jmc$priority_p4, jmc$dc_maximum_service_limit, [0, 0]],
{    dispatching_control [2]        #} [FALSE, 0, 0, [0, 0]],
{    dispatching_control [3]        #} [FALSE, 0, 0, [0, 0]],
{    dispatching_control [4]        #} [FALSE, 0, 0, [0, 0]],
{    dispatching_control [5]        #} [FALSE, 0, 0, [0, 0]]],
{    scheduling_priority            #} [100, 1000, 1, 500],
{    swap_age_interval              #} 1000000];

?? FMT (FORMAT = ON) ??
?? TITLE := 'initialize_application_table', EJECT ??

{ PURPOSE:
{   The purpose of this request is to initialize the application table for
{   application scheduling.

  PROCEDURE initialize_application_table;

{ Initialize                                           the application table to contain no applications.

    jmv$application_table_p := NIL;

  PROCEND initialize_application_table;
?? TITLE := 'initialize_default_job_attr', EJECT ??

{ PURPOSE:
{   The purpose of this request is to initialize the default attributes for
{   a job class which are used when creating a new job class.
{ NOTES:
{   Creation of a new job class is performed by the ADMINISTER_SCHEDULING
{   utility.  These default attributes are accessed by MANAGE_ACTIVE_SCHEDULING
{   utility when a scheduling profile is installed.

  PROCEDURE initialize_default_job_attr;

{ Initialize the Definition attributes.

{ Initialize the Control attributes.

    jmv$default_job_class_attr.page_aging_interval.default := mmv$tick_time;

{ Initialize the Limit attributes.

{ Initialize the Membership group attributes.

{ Initialize the Priority group attributes.

  PROCEND initialize_default_job_attr;
?? TITLE := 'initialize_default_service_attr', EJECT ??

{ PURPOSE:
{   The purpose of this request is to initialize the default attributes for
{   a service class which are used when creating a new service class.
{ NOTES:
{   Creation of a new service class is performed by the ADMINISTER_SCHEDULING
{   utility.  These default attributes are accessed by MANAGE_ACTIVE_SCHEDULING
{   utility when a scheduling profile is installed.

  PROCEDURE initialize_default_service_attr;

{ Initialize the Definition group attributes.

{ Initialize the Control group attributes.

{ Initialize the Priority group attributes.

    jmv$default_service_class_attr.dispatching_control [jmc$min_dispatching_control].set_defined := TRUE;
    jmv$default_service_class_attr.dispatching_control [jmc$min_dispatching_control].dispatching_priority :=
          jmc$priority_p4;
    jmv$default_service_class_attr.dispatching_control [jmc$min_dispatching_control].service_limit :=
          jmc$dc_maximum_service_limit;
    jmv$default_service_class_attr.dispatching_control [jmc$min_dispatching_control].dispatching_timeslice.
          minor := pmv$quantum;
    jmv$default_service_class_attr.dispatching_control [jmc$min_dispatching_control].dispatching_timeslice.
          major := pmv$quantum;

  PROCEND initialize_default_service_attr;
?? TITLE := 'initialize_job_category_data', EJECT ??

{ PURPOSE:
{   The purpose of this request in to initialize the job category data.

  PROCEDURE initialize_job_category_data;

{ Initialize the job category data to contain no categories.

    VAR
      entry: jmt$job_category_item_kind;

    jmv$job_category_data.item_list := NIL;
    FOR entry := LOWERVALUE (jmt$job_category_item_kind) TO UPPERVALUE (jmt$job_category_item_kind) DO
      jmv$job_category_data.initial_set_values [entry] := $jmt$job_category_set [];
    FOREND;
    jmv$job_category_data.category_names := NIL;

  PROCEND initialize_job_category_data;
?? TITLE := 'initialize_job_class_table', EJECT ??

{ PURPOSE:
{   The purpose of this request is to initialize the job class table.
{ DESIGN:
{   The job class table is allocated and the job classes, SYSTEM, MAINTENANCE,
{   and UNASSIGNED are defined.

  PROCEDURE initialize_job_class_table;

    VAR
      job_class: ^jmt$job_class_attributes;

{ Allocate the maximum sized job class table but only initialize part of it.

    ALLOCATE jmv$job_class_table_p: [1 .. jmc$maximum_job_classes] IN osv$mainframe_pageable_heap^;

    pmp$zero_out_table (^jmv$profile_index_to_job_class, #SIZE (jmv$profile_index_to_job_class));

{ Initialize the SYSTEM job class.

    job_class := ^jmv$job_class_table_p^ [jmc$system_job_class];
    job_class^ := jmv$default_job_class_attr;

{ Initialize the Definition group attributes.

    job_class^.defined := TRUE;
    job_class^.index := jmc$system_job_class;
    job_class^.profile_index := 1;
    job_class^.profile_identification := jmc$system_class_name;
    job_class^.name := jmc$system_class_name;
    job_class^.abbreviation := 'S';
    job_class^.initial_service_class_index := jmc$system_service_class;
    job_class^.initial_working_set := 80;

{ Initialize the Control group attributes.

    job_class^.cyclic_aging_interval.default := 1000000000;
    job_class^.initiation_level.preferred := 20;
    job_class^.initiation_level.maximum_increment := 0;

{ Initialize the Limit group attributes.

    job_class^.detached_job_wait_time.default := 18000;
    job_class^.detached_job_wait_time.minimum := 18000;

{ Initialize the Membership attributes.

{ Initialize the Priority group attributes.

    job_class^.selection_priority.initial := 19000;
    job_class^.selection_priority.maximum := 22000;
    job_class^.selection_priority.increment := 100;
    job_class^.selection_priority.threshold := 19000;

{ Initialize the MAINTENANCE job class.

    job_class := ^jmv$job_class_table_p^ [jmc$maintenance_job_class];
    job_class^ := jmv$default_job_class_attr;

{ Initialize the Definition group attributes.

    job_class^.defined := TRUE;
    job_class^.index := jmc$maintenance_job_class;
    job_class^.profile_index := 2;
    job_class^.profile_identification := jmc$maintenance_class_name;
    job_class^.name := jmc$maintenance_class_name;
    job_class^.abbreviation := 'M';
    job_class^.immediate_initiation_candidate := TRUE;
    job_class^.initial_service_class_index := jmc$maintenance_service_class;

{ Initialize the Control group attributes.

    job_class^.cyclic_aging_interval.default := 1000000000;
    job_class^.initiation_level.preferred := 100;
    job_class^.initiation_level.maximum_increment := 0;

{ Initialize the Limit group attributes.

    job_class^.detached_job_wait_time.default := 18000;
    job_class^.detached_job_wait_time.minimum := 18000;
    job_class^.detached_job_wait_time.maximum := 18000;

{ Initialize the Membership group attributes.

{ Initialize the Priority group attributes.

    job_class^.selection_priority.initial := 14000;
    job_class^.selection_priority.maximum := 17000;
    job_class^.selection_priority.increment := 1000;
    job_class^.selection_priority.threshold := 14000;


{ Initialize the UNASSIGNED job class.

    job_class := ^jmv$job_class_table_p^ [jmc$unassigned_job_class];
    job_class^ := jmv$default_job_class_attr;

{ Initialize the Definition group attributes.

    job_class^.defined := TRUE;
    job_class^.index := jmc$unassigned_job_class;
    job_class^.profile_index := 3;
    job_class^.profile_identification := jmc$unassigned_class_name;
    job_class^.name := jmc$unassigned_class_name;
    job_class^.abbreviation := 'U';
    job_class^.enable_class_initiation := FALSE;
    job_class^.initial_service_class_index := jmc$unassigned_service_class;

{ Initialize the Control group attributes.

    job_class^.cyclic_aging_interval.default := 1000000000;
    job_class^.initiation_level.preferred := 20;
    job_class^.initiation_level.maximum_increment := 0;

{ Initialize the Limit group attributes.

    job_class^.detached_job_wait_time.default := 18000;
    job_class^.detached_job_wait_time.minimum := 18000;
    job_class^.detached_job_wait_time.maximum := 18000;

{ Initialize the Membership group attributes.

{ Initialize the Priority group attributes.

    job_class^.selection_priority.initial := 14000;
    job_class^.selection_priority.maximum := 17000;
    job_class^.selection_priority.increment := 1000;
    job_class^.selection_priority.threshold := 14000;

{ The default values of the system job class attributes are NOT to be moved into the JCB of the System Job.
{ The JCB of the System Job was initialized in sym$deadstart_initialization and is NOT to be affected by
{ the attributes of the "system" job class.  Now initialize the maximum class working set to zero.  It
{ is not to include the System Job MAXWS and the System Job is all that is executing at deadstart.

    jmv$max_class_working_set := 0;

{ Initialize the highest rank job class for automatic class selection.

    jmv$highest_rank_job_class := jmc$null_job_class;

{ Set the highest job class index currently used.

    jmv$maximum_job_class_in_use := jmc$minimum_job_classes;

{ Set the job leveling translation table.

    jmv$profile_index_to_job_class [1] := jmc$system_job_class;
    jmv$profile_index_to_job_class [2] := jmc$maintenance_job_class;
    jmv$profile_index_to_job_class [3] := jmc$unassigned_job_class;
    jmv$maximum_profile_index := 3;

  PROCEND initialize_job_class_table;
?? TITLE := 'initialize_job_scheduler_table', EJECT ??

{ PURPOSE:
{   The purpose of this request is to initialize the job scheduler table.
{ NOTES:
{   The job scheduler table is preset when it is defined in monitor.
{   Those attributes which cannot be preset are initialized here.

  PROCEDURE initialize_job_scheduler_table
    (VAR status: ost$status);

    VAR
      binary_id: pmt$binary_mainframe_id;

{ Initialize the Definition group attributes.

    jmv$job_scheduler_table.cpu_quantum_time := pmv$quantum;

{ Initialize the Membership group attributes for one mainframe with no
{ job categories.

    ALLOCATE jmv$job_scheduler_table.validation_categories_p: [1 .. 1] IN osv$mainframe_pageable_heap^;
    jmv$job_scheduler_table.validation_categories_p^ [1].mainframe_id := pmv$mainframe_id;
    jmv$job_scheduler_table.validation_categories_p^ [1].excluded := $jmt$job_category_set [];
    jmv$job_scheduler_table.validation_categories_p^ [1].required := $jmt$job_category_set [];
    pmp$convert_mainframe_to_binary (pmv$mainframe_id, binary_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    jmv$job_scheduler_table.validation_categories_p^ [1].binary_mainframe_id := binary_id;

  PROCEND initialize_job_scheduler_table;
?? TITLE := 'initialize_output_class_table', EJECT ??

{ PURPOSE:
{   The purpose of this request is to initialize the output class table.
{ DESIGN:
{   The output class table is allocated and the output class NORMAL is
{   defined.

  PROCEDURE initialize_output_class_table;

    VAR
      output_class: jmt$output_class_index;

    ALLOCATE jmv$output_class_table_p: [1 .. jmv$maximum_output_classes] IN osv$mainframe_pageable_heap^;
    FOR output_class := jmc$system_output_class TO jmv$maximum_output_classes DO
      jmv$output_class_table_p^ [output_class] := jmv$default_output_class_attr;
    FOREND;


{ Initialize the NORMAL output class.

{ Initialize the Definition group attributes.

    jmv$output_class_table_p^ [jmc$system_output_class].defined := TRUE;
    jmv$output_class_table_p^ [jmc$system_output_class].index := jmc$system_output_class;
    jmv$output_class_table_p^ [jmc$system_output_class].profile_identification := jmc$unassigned_class_name;
    jmv$output_class_table_p^ [jmc$system_output_class].name := jmc$normal_class_name;
    jmv$output_class_table_p^ [jmc$system_output_class].abbreviation := 'N';
    jmv$output_class_table_p^ [jmc$system_output_class].enable_class_scheduling := TRUE;

{ Initialize the Priority group attributes.

    jmv$output_class_table_p^ [jmc$system_output_class].delivery_priority.initial := 100;
    jmv$output_class_table_p^ [jmc$system_output_class].delivery_priority.maximum := 2000;
    jmv$output_class_table_p^ [jmc$system_output_class].delivery_priority.increment := 1;
    jmv$output_class_table_p^ [jmc$system_output_class].output_age_interval := 1000000;

{ Set the highest output class index currently used.

    jmv$maximum_output_class_in_use := jmc$minimum_output_classes;

  PROCEND initialize_output_class_table;
?? TITLE := 'initialize_sched_table_locks', EJECT ??

{ PURPOSE:
{   The purpose of this request is to initialize the variables which
{   control access to the scheduler tables and use of the scheduling
{   utilities.

  PROCEDURE initialize_sched_tables_locks
    (VAR status: ost$status);

{ Initialize the variable for scheduler tables access.

    osp$initialize_sig_lock (jmv$scheduler_tables_access.lock);
    jmv$scheduler_tables_access.count := 0;

{ Initialize the variable for scheduling utility usage.

    osp$initialize_sig_lock (jmv$scheduling_utility_usage.lock);
    jmv$scheduling_utility_usage.active := FALSE;
    jmv$scheduling_utility_usage.global_task_id := tmv$null_global_task_id;
    osp$generate_unique_binary_name (jmv$scheduling_utility_usage.access_id, status);

  PROCEND initialize_sched_tables_locks;
?? TITLE := 'initialize_service_class_table', EJECT ??

{ PURPOSE:
{   The purpose of this request is to initialize the service class table.
{ DESIGN:
{   The service class table is allocated and the service classes, SYSTEM,
{   MAINTENANCE, and UNASSIGNED are defined.

  PROCEDURE initialize_service_class_table
    (VAR status: ost$status);

    VAR
      service_class: jmt$service_class_index,
      service_class_p: ^jmt$service_class_attributes;

{ Initialize the SYSTEM service class.

    IF jmv$service_classes [jmc$system_service_class] = NIL THEN
      ALLOCATE jmv$service_classes [jmc$system_service_class] IN osv$mainframe_wired_heap^;
      pmp$zero_out_table (jmv$service_classes [jmc$system_service_class],
            #SIZE (jmv$service_classes [jmc$system_service_class]^));
    IFEND;
    service_class_p := ^jmv$service_classes [jmc$system_service_class]^.attributes;
    service_class_p^ := jmv$default_service_class_attr;

{ Initialize the Definition group attributes.

    service_class_p^.defined := TRUE;
    service_class_p^.index := jmc$system_service_class;
    service_class_p^.profile_identification := jmc$system_class_name;
    service_class_p^.name := jmc$system_class_name;
    service_class_p^.abbreviation := 'S';

{ Initialize the Control group attributes.

    service_class_p^.class_service_threshold := 10000000;
    service_class_p^.guaranteed_service_quantum := 2000;
    service_class_p^.maximum_active_jobs := 20;
    service_class_p^.next_service_class_index := jmc$system_service_class;
    service_class_p^.service_factors [jmc$sf_cpu] := 1;
    service_class_p^.service_factors [jmc$sf_memory] := 1;
    service_class_p^.service_factors [jmc$sf_residence] := 1;
    service_class_p^.service_factors [jmc$sf_io] := 1;

{ Initialize the Priority attributes.

    service_class_p^.dispatching_control [jmc$min_dispatching_control].dispatching_priority :=
          jmc$priority_p6;

    service_class_p^.scheduling_priority.minimum := 19000;
    service_class_p^.scheduling_priority.maximum := 22000;
    service_class_p^.scheduling_priority.swap_age_increment := 1000;
    service_class_p^.scheduling_priority.ready_task_increment := 0;
    service_class_p^.swap_age_interval := 1000000;


{ Initialize the MAINTENANCE service class.

    IF jmv$service_classes [jmc$maintenance_service_class] = NIL THEN
      ALLOCATE jmv$service_classes [jmc$maintenance_service_class] IN osv$mainframe_wired_heap^;
      pmp$zero_out_table (jmv$service_classes [jmc$maintenance_service_class],
            #SIZE (jmv$service_classes [jmc$maintenance_service_class]^));
    IFEND;
    service_class_p := ^jmv$service_classes [jmc$maintenance_service_class]^.attributes;
    service_class_p^ := jmv$default_service_class_attr;

{ Initialize the Definition group attributes.

    service_class_p^.defined := TRUE;
    service_class_p^.index := jmc$maintenance_service_class;
    service_class_p^.profile_identification := jmc$maintenance_class_name;
    service_class_p^.name := jmc$maintenance_class_name;
    service_class_p^.abbreviation := 'M';

{ Initialize the Control group attributes.

    service_class_p^.class_service_threshold := 10000000;
    service_class_p^.guaranteed_service_quantum := 9000;
    service_class_p^.maximum_active_jobs := 100;
    service_class_p^.next_service_class_index := jmc$maintenance_service_class;
    service_class_p^.service_factors [jmc$sf_cpu] := 1;
    service_class_p^.service_factors [jmc$sf_memory] := 1;
    service_class_p^.service_factors [jmc$sf_residence] := 1;
    service_class_p^.service_factors [jmc$sf_io] := 1;

{ Initialize the Prioirty group attributes.

    service_class_p^.dispatching_control [jmc$min_dispatching_control].dispatching_priority :=
          jmc$priority_p5;

    service_class_p^.scheduling_priority.minimum := 8000;
    service_class_p^.scheduling_priority.maximum := 17000;
    service_class_p^.scheduling_priority.swap_age_increment := 1000;
    service_class_p^.scheduling_priority.ready_task_increment := 1000;
    service_class_p^.swap_age_interval := 1000000;


{ Initialize the UNASSIGNED service class.

    IF jmv$service_classes [jmc$unassigned_service_class] = NIL THEN
      ALLOCATE jmv$service_classes [jmc$unassigned_service_class] IN osv$mainframe_wired_heap^;
      pmp$zero_out_table (jmv$service_classes [jmc$unassigned_service_class],
            #SIZE (jmv$service_classes [jmc$unassigned_service_class]^));
    IFEND;
    service_class_p := ^jmv$service_classes [jmc$unassigned_service_class]^.attributes;
    service_class_p^ := jmv$default_service_class_attr;

{ Initialize the Definition group attributes.

    service_class_p^.defined := TRUE;
    service_class_p^.index := jmc$unassigned_service_class;
    service_class_p^.profile_identification := jmc$unassigned_class_name;
    service_class_p^.name := jmc$unassigned_class_name;
    service_class_p^.abbreviation := 'U';

{ Initialize the Control group attributes.

    service_class_p^.class_service_threshold := 10000000;
    service_class_p^.guaranteed_service_quantum := 9000;
    service_class_p^.maximum_active_jobs := 20;
    service_class_p^.next_service_class_index := jmc$unassigned_service_class;
    service_class_p^.service_factors [jmc$sf_cpu] := 1;
    service_class_p^.service_factors [jmc$sf_memory] := 1;
    service_class_p^.service_factors [jmc$sf_residence] := 1;
    service_class_p^.service_factors [jmc$sf_io] := 1;

{ Initialize the Prioirty group attributes.

    service_class_p^.dispatching_control [jmc$min_dispatching_control].dispatching_priority :=
          jmc$priority_p5;

    service_class_p^.scheduling_priority.minimum := 8000;
    service_class_p^.scheduling_priority.maximum := 17000;
    service_class_p^.scheduling_priority.swap_age_increment := 1000;
    service_class_p^.scheduling_priority.ready_task_increment := 1000;
    service_class_p^.swap_age_interval := 1000000;

{ Set the highest service class index currently used.

    jmv$max_service_class_in_use := jmc$minimum_service_classes;
    jmv$last_service_calc_time := #FREE_RUNNING_CLOCK (0);

  PROCEND initialize_service_class_table;
?? TITLE := '[XDCL, #GATE] jmp$initialize_scheduler_tables', EJECT ??
*copy jmh$initialize_scheduler_tables

  PROCEDURE [XDCL, #GATE] jmp$initialize_scheduler_tables
    (VAR status: ost$status);

    status.normal := TRUE;

    initialize_sched_tables_locks (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Update the default attribute record for the job and service classes.

    initialize_default_job_attr;

    initialize_default_service_attr;

{ Initialize the scheduler tables for job scheduler controls, job category data,
{ scheduling classes and applications.

    initialize_job_scheduler_table (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    initialize_job_category_data;

    initialize_job_class_table;

    initialize_service_class_table (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    initialize_output_class_table;

    initialize_application_table;

  PROCEND jmp$initialize_scheduler_tables;

MODEND jmm$job_sched_table_init;
*DECK DECK=JMM$JOB_TO_JOB_COMMUNICATION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management: Job to Job Communication Procedures' ??
MODULE jmm$job_to_job_communication;
{
{ PURPOSE:
{   This module contains procedures supporting job to job communication.
{
?? NEWTITLE := 'Global Declarations Referenced in this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osc$unseen_mail_condition
*copyc ost$status
*copyc ost$system_flag
?? POP ??
*copyc clp$find_current_job_synch_task
*copyc clp$find_unseen_mail_action
*copyc pmp$cause_intra_job_condition
*copyc pmp$get_task_id
*copyc pmp$post_unseen_mail
*copyc pmp$propagate_unseen_mail
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$message_waiting_flag_hndlr', EJECT ??
{
{ PURPOSE:
{   This procedure processes the message waiting system flag.
{
{ NOTES:
{   Currently, the only job to job message implemented is unseen_mail. When additional messages are
{   implemented, this procedure must process messages by identifying ordinal.
{

  PROCEDURE [XDCL] jmp$message_waiting_flag_hndlr
    (    flag_id: ost$system_flag);

    VAR
      current_task: pmt$task_id,
      ignore_status: ost$status,
      job_synch_task: pmt$task_id,
      unseen_mail_action: ^clt$unseen_mail_action;


    clp$find_current_job_synch_task (job_synch_task, ignore_status);
    pmp$get_task_id (current_task, ignore_status);
    IF current_task <> job_synch_task THEN
      pmp$cause_intra_job_condition (osc$unseen_mail_condition, job_synch_task, ignore_status);
    ELSE
      clp$find_unseen_mail_action (unseen_mail_action);
      IF unseen_mail_action^ = clc$post_unseen_mail THEN
        pmp$post_unseen_mail;
      ELSE
        pmp$propagate_unseen_mail (ignore_status);
      IFEND;
    IFEND;

  PROCEND jmp$message_waiting_flag_hndlr;
?? OLDTITLE ??
MODEND jmm$job_to_job_communication;
*DECK DECK=JMM$LOAD_JOB_TEMPLATES_RING_3 EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE jmm$load_job_templates_ring_3;
MODEND jmm$load_job_templates_ring_3;
*DECK DECK=JMM$LOAD_SYSTEM_JOB_TEMPLATES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : Load System Job Templates' ??
MODULE jmm$load_system_job_templates;

{ PURPOSE:
{   This module contains the procedures which load the job templates from the deadstart
{   device to the correct device files and activates them.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$segment_pointer
*copyc jme$job_template_conditions
*copyc jmt$job_template_entry
*copyc jmt$seg_attr
*copyc mtv$xp_initial_value
*copyc osd$code_base_pointer
*copyc ost$hardware_subranges
*copyc ost$name
*copyc pmt$task_template
*copyc pmt$virtual_memory_image_header
?? POP ??
*copyc dmp$attach_device_file
*copyc dmp$close_file
*copyc dmp$create_device_file
*copyc dmp$destroy_device_file
*copyc dmp$detach_device_file
*copyc dmp$open_file
*copyc dmp$fetch_eoi
*copyc dmp$set_eoi
*copyc dsp$read_deadstart_device
*copyc dsp$read_header_labels
*copyc i#move
*copyc mmp$add_global_template_segment
*copyc mmp$assign_mass_storage
*copyc mmp$close_device_file
*copyc mmp$open_file_by_sfid
*copyc mmp$write_modified_pages
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$zero_out_table
*copyc syp$display_deadstart_message
*copyc syp$process_deadstart_status
*copyc syp$trace_deadstart_message
?? EJECT ??
*copyc dmv$system_device_information
*copyc jmv$delete_old_templates
*copyc gfv$null_sfid
*copyc jmv$system_core_id
*copyc mmv$default_sdtx_entry
*copyc osv$mainframe_pageable_heap
*copyc osv$page_size
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    file_name_seed: ost$name := 'jt_file_',
    jmv$system_job_template_p: [XDCL, #GATE] ^jmt$job_template_entry,
    jmv$task_private_templ_p: [XDCL, #GATE] ^pmt$task_template;
?? TITLE := 'create_and_load_segment', EJECT ??

{ PURPOSE:
{   This procedure creates and loads the job template segments.

  PROCEDURE create_and_load_segment
    (    directory_header_p: ^pmt$virtual_memory_image_header;
     VAR directory_file_p: ^SEQ ( * );
     VAR cbp_present: boolean;
     VAR code_base_pointer: ost$external_code_base_pointer;
     VAR template_segments_array_p: ^ARRAY [ * ] OF jmt$seg_attr;
     VAR status: ost$status);

    VAR
      device_file_segment_number: ost$segment,
      file_name: ost$name,
      pva_destination_p: ^cell,
      sdt_entry: mmt$segment_descriptor,
      sdtx_entry: mmt$segment_descriptor_extended,
      segment_description_p: ^pmt$linked_segment_description,
      segment_index: integer,
      segment_number: ost$segment,
      sfid: dmt$system_file_id,
      source_pva_p: ^cell,
      vsn: rmt$recorded_vsn;

    syp$trace_deadstart_message ('assign device shared segments');
    FOR segment_index := 1 TO directory_header_p^.number_of_segments DO
      NEXT segment_description_p IN directory_file_p;
      file_name := file_name_seed;
      file_name (9, 1) := $CHAR (segment_index DIV 10 + ORD ('0'));
      file_name (10, 1) := $CHAR (segment_index MOD 10 + ORD ('0'));
      vsn := dmv$system_device_recorded_vsn;
      dmp$attach_device_file (vsn, file_name, sfid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      segment_number := segment_description_p^.segment_number;
      sdt_entry.ste := segment_description_p^.segment_descriptor;
      sdt_entry.ste.asid := 0; {for insurance
      sdtx_entry := mmv$default_sdtx_entry;
      CASE segment_number OF
      = osc$segnum_job_pageable_heap, osc$segnum_task_shared_heap =
        sdtx_entry.inheritance := mmc$si_share_segment;
        sdtx_entry.open_validating_ring_number := 1;
      = osc$segnum_task_private_heap =
        sdtx_entry.inheritance := mmc$si_new_segment;
        sdtx_entry.open_validating_ring_number := 1;
      ELSE
        sdtx_entry.inheritance := mmc$si_share_segment;
        sdtx_entry.open_validating_ring_number := 0;
      CASEND;

      IF segment_description_p^.segment_descriptor.wp = osc$non_writable THEN
        sdtx_entry.sfid := sfid;
        sdtx_entry.access_state := mmc$sas_allow_access;
        { Since this is a non-writable segment, change from the default access
        { rights (write_extend) to read (only).

        sdtx_entry.access_rights := mmc$sar_read;
        IF segment_description_p^.segment_descriptor.rp = osc$binding_segment THEN
          cbp_present := TRUE;
          code_base_pointer := directory_header_p^.starting_procedure;
        IFEND;

        mmp$add_global_template_segment (sdt_entry, sdtx_entry, segment_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSE   { segment is writeable therefore must be unique.
        mmp$open_file_by_sfid (sfid, 1, 1, mmc$as_sequential, mmc$sar_read,
              device_file_segment_number, status);
        source_pva_p := #ADDRESS (1, device_file_segment_number, 0);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        mmp$add_global_template_segment (sdt_entry, sdtx_entry, segment_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        mmp$assign_mass_storage (segment_number, gfv$null_sfid, segment_description_p^.length,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        pva_destination_p := #ADDRESS (1, segment_number, 0);
        i#move (source_pva_p, pva_destination_p, segment_description_p^.length);
        mmp$close_device_file (device_file_segment_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      { Save the segment attributes.

      template_segments_array_p^ [segment_index].sfid_needed :=
            segment_description_p^.segment_descriptor.wp = osc$non_writable;
      template_segments_array_p^ [segment_index].seg_len := segment_description_p^.length;
      template_segments_array_p^ [segment_index].segnumber := segment_number;
      template_segments_array_p^ [segment_index].sdt := sdt_entry;
      template_segments_array_p^ [segment_index].sdtx := sdtx_entry;
    FOREND;

  PROCEND create_and_load_segment;
?? TITLE := 'create_segment_file', EJECT ??

{ PURPOSE:
{   This procedure creates the job template segment device file and moves the segment
{   from the deadstart device into this file.

  PROCEDURE create_segment_file
    (    segment_index: integer;
         segment_length: ost$segment_length);

    VAR
      data_size_read: integer,
      file_attributes_p: ^ARRAY [1 .. * ] OF dmt$new_device_file_attribute,
      file_eoi: amt$file_byte_address,
      file_modified: boolean,
      file_name: ost$name,
      file_segment_pointer: mmt$segment_pointer,
      file_size: amt$file_byte_address,
      fmd_modified: boolean,
      segment_file_p: ^SEQ ( * ),
      segment_p: ^SEQ ( * ),
      sfid: dmt$system_file_id,
      status: ost$status,
      vsn: rmt$recorded_vsn;

    file_name := file_name_seed;
    file_name (9, 1) := $CHAR (segment_index DIV 10 + ORD ('0'));
    file_name (10, 1) := $CHAR (segment_index MOD 10 + ORD ('0'));
    vsn := dmv$system_device_recorded_vsn;
    dmp$attach_device_file (vsn, file_name, sfid, status);
    IF NOT status.normal THEN
      IF (status.condition = dme$unknown_device_file) THEN
        PUSH file_attributes_p: [1 .. 1];
        file_attributes_p^ [1].keyword := dmc$file_limit;
        file_attributes_p^ [1].limit := UPPERVALUE (amt$file_limit);
        dmp$create_device_file (file_name, vsn, file_attributes_p, (segment_length * 2), sfid, status);
        IF NOT status.normal THEN
          IF (status.condition = dme$unable_to_alloc_all_space) THEN
            syp$display_deadstart_message ('Not enough space on disk to upgrade.');
            syp$display_deadstart_message ('Use old system to delete files.');
            syp$process_deadstart_status ('Disk too full for template.', TRUE, status);
          ELSE
            osp$system_error ('Cant create template file.', ^status);
          IFEND;
        IFEND;
      ELSE
        osp$system_error ('Cant attach template file.', ^status);
      IFEND;
    IFEND;

    file_segment_pointer.kind := mmc$sequence_pointer;
    dmp$open_file (sfid, osc$os_ring_1, osc$os_ring_1, mmc$sar_write_extend, mmc$as_sequential,
          file_segment_pointer, status);
    IF NOT status.normal THEN
      osp$system_error ('Cant open template file.', ^status);
    IFEND;

    dmp$fetch_eoi (sfid, file_eoi, status);
    IF NOT status.normal THEN
      osp$system_error ('Bad status on dmp$fetch_eoi.', ^status);
    IFEND;

    IF segment_length > file_eoi THEN
      dmp$close_file (file_segment_pointer.cell_pointer, status);
      IF NOT status.normal THEN
        osp$system_error ('Bad status on dmp$close.', ^status);
      IFEND;
      dmp$detach_device_file (sfid, file_modified, fmd_modified, status);
      IF NOT status.normal THEN
        osp$system_error ('Bad status on dmp$detach.', ^status);
      IFEND;
      dmp$destroy_device_file (vsn, file_name, status);
      IF NOT status.normal THEN
        osp$system_error ('Bad status on dmp$destroy.', ^status);
      IFEND;

      file_size := segment_length * 2;
      PUSH file_attributes_p: [1 .. 1];
      file_attributes_p^ [1].keyword := dmc$file_limit;
      file_attributes_p^ [1].limit := UPPERVALUE (amt$file_limit);
      dmp$create_device_file (file_name, vsn, file_attributes_p, file_size, sfid, status);
      IF NOT status.normal THEN
        IF (status.condition = dme$unable_to_alloc_all_space) THEN
          syp$display_deadstart_message ('Not enough space on disk to upgrade.');
          syp$display_deadstart_message ('Use old system to delete files.');
          syp$process_deadstart_status ('Disk too full for template.', TRUE, status);
        ELSE
          osp$system_error ('Cant create template file.', ^status);
        IFEND;
      IFEND;
      dmp$open_file (sfid, osc$os_ring_1, osc$os_ring_1, mmc$sar_write_extend, mmc$as_sequential,
            file_segment_pointer, status);
      IF NOT status.normal THEN
        osp$system_error ('Bad status on dmp$open.', ^status);
      IFEND;
    IFEND;

    { Move the segment from the deadstart device to the device file.

    segment_file_p := file_segment_pointer.seq_pointer;
    RESET segment_file_p;
    NEXT segment_p: [[REP segment_length OF cell]] IN segment_file_p;
    dmp$set_eoi (sfid, 0, status);
    IF NOT status.normal THEN
      osp$system_error ('Cant set EOI for template file.', ^status);
    IFEND;

    dsp$read_deadstart_device (segment_length, segment_p, data_size_read);
    IF data_size_read < segment_length THEN
      osp$system_error ('Invalid deadstart file: Bad segment.', NIL);
    IFEND;

    mmp$write_modified_pages (segment_file_p, segment_length, osc$nowait, status);
    IF NOT status.normal THEN
      osp$system_error ('Cant write template file.', ^status);
    IFEND;

    dmp$close_file (segment_file_p, status);
    IF NOT status.normal THEN
      osp$system_error ('Cant close template file.', ^status);
    IFEND;

    dmp$detach_device_file (sfid, file_modified, fmd_modified, status);
    IF NOT status.normal THEN
      osp$system_error ('Cant detach template file.', ^status);
    IFEND;
  PROCEND create_segment_file;
?? TITLE := 'save_system_job_template', EJECT ??

{ PURPOSE:
{   The following procedure initializes the task private template(s). These are used by tasking
{   to initialize the task private segments of newly created tasks.

  PROCEDURE save_system_job_template
    (    seg_attr_array_p: ^ARRAY [ * ] OF jmt$seg_attr,
         max_segments: integer;
     VAR status: ost$status);

    CONST
      max_task_private_segs = 1;

    TYPE
      task_private_segments = SET OF ost$segment;

    VAR
      incoming_segment_entry_p: ^jmt$seg_attr,
      length_of_static_data: integer,
      pva_p: ^cell,
      scan: ost$segment,
      segment_number: ost$segment,
      task_private_segment_index: ost$segment,
      task_private_segment_set: task_private_segments,
      template_segment_entry_p: ^jmt$job_templ_segment;

    task_private_segment_index := 1;
    task_private_segment_set := $task_private_segments [osc$segnum_task_private_heap];

    ALLOCATE jmv$task_private_templ_p: [1 .. max_task_private_segs] IN osv$mainframe_pageable_heap^;
    FOR scan := 1 TO max_task_private_segs DO
      jmv$task_private_templ_p^.segment [scan].content := NIL;
    FOREND;

    { Set up the initial execution control block for all spawned tasks.

    pmp$zero_out_table (#LOC (jmv$task_private_templ_p^.xcb), #SIZE (jmv$task_private_templ_p^.xcb));
    jmv$task_private_templ_p^.xcb.xp := mtv$xp_initial_value;
    jmv$task_private_templ_p^.xcb.dispatching_priority := 0;
    jmv$task_private_templ_p^.xcb.pit_count := 7fffffff(16);
    jmv$task_private_templ_p^.xcb.iocb_p := NIL;
    jmv$task_private_templ_p^.xcb.assign_active_sfid := gfv$null_sfid;

    ALLOCATE jmv$system_job_template_p: [1 .. max_segments] IN osv$mainframe_pageable_heap^;

    { Build the template segment by segment.

    FOR scan := 1 TO max_segments DO
      incoming_segment_entry_p := ^seg_attr_array_p^ [scan];
      template_segment_entry_p := ^jmv$system_job_template_p^.job_template [scan];
      segment_number := incoming_segment_entry_p^.segnumber;
      pva_p := #ADDRESS (1, segment_number, 0);
      template_segment_entry_p^.tasking_segment := FALSE;
      template_segment_entry_p^.writeable_segment := TRUE;
      template_segment_entry_p^.seg_no := segment_number;
      template_segment_entry_p^.sdt := incoming_segment_entry_p^.sdt;
      template_segment_entry_p^.sdtx := incoming_segment_entry_p^.sdtx;
      IF incoming_segment_entry_p^.sfid_needed THEN
        template_segment_entry_p^.writeable_segment := FALSE;
      ELSE
        length_of_static_data := incoming_segment_entry_p^.seg_len;
        ALLOCATE template_segment_entry_p^.static_data_p: [1 .. length_of_static_data] IN
              osv$mainframe_pageable_heap^;
        i#move (pva_p, template_segment_entry_p^.static_data_p, length_of_static_data);
        IF segment_number IN task_private_segment_set THEN
          template_segment_entry_p^.tasking_segment := TRUE;
          IF task_private_segment_index <= max_task_private_segs THEN
            jmv$task_private_templ_p^.segment [task_private_segment_index].number := segment_number;
            jmv$task_private_templ_p^.segment [task_private_segment_index].content :=
                  template_segment_entry_p^.static_data_p;
            task_private_segment_index := task_private_segment_index + 1;
          ELSE
            osp$set_status_abnormal ('JM', jme$tasking_segs_mismatch, 'MAX TASK PRIVATE SEGS EXCEEDED',
                  status);
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND save_system_job_template;
?? TITLE := 'jmp$activate_sys_job_template', EJECT ??

{ PURPOSE:
{   This procedure is called to load the job templates (consisting of a series of
{   segments) into virtual memory.

  PROCEDURE [XDCL] jmp$activate_sys_job_template
    (    template_name: ost$name;
     VAR code_base_pointer: ost$external_code_base_pointer;
     VAR status: ost$status);

    VAR
      cbp_present: boolean,
      directory_file_p: ^SEQ ( * ),
      directory_header_p: ^pmt$virtual_memory_image_header,
      file_modified: boolean,
      file_segment_pointer: mmt$segment_pointer,
      fmd_modified: boolean,
      max_segments: integer,
      sfid: dmt$system_file_id,
      template_segments_array_p: ^ARRAY [ * ] OF jmt$seg_attr,
      vsn: rmt$recorded_vsn;

    status.normal := TRUE;

    vsn := dmv$system_device_recorded_vsn;
    dmp$attach_device_file (vsn, template_name, sfid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_segment_pointer.kind := mmc$sequence_pointer;
    dmp$open_file (sfid, osc$os_ring_1, osc$os_ring_1, mmc$sar_read, mmc$as_random,
          file_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    directory_file_p := file_segment_pointer.seq_pointer;
    RESET directory_file_p;
    NEXT directory_header_p IN directory_file_p;
    IF directory_header_p^.system_core_id <> jmv$system_core_id THEN
      osp$set_status_abnormal ('JM', jme$job_temp_sys_core_mismatch, 'JOB TEMPL - SYS CORE MISMATCH', status);
      RETURN;
    IFEND;

    { Save space for the segment list.

    max_segments := directory_header_p^.number_of_segments;
    PUSH template_segments_array_p: [1 .. directory_header_p^.number_of_segments];
    cbp_present := FALSE;

    { Create and load the job segments.

    create_and_load_segment (directory_header_p, directory_file_p, cbp_present, code_base_pointer,
          template_segments_array_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$close_file (directory_file_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    dmp$detach_device_file (sfid, file_modified, fmd_modified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT cbp_present THEN
      osp$set_status_abnormal ('JM', jme$no_binding_segment, 'NO BINDING SEGMENT', status);
      RETURN;
    IFEND;

    { Save the job templates.

    save_system_job_template (template_segments_array_p, max_segments, status);

  PROCEND jmp$activate_sys_job_template;
?? TITLE := 'jmp$load_sys_job_template', EJECT ??

{ PURPOSE:
{   This procedure loads the job templates from the deadstart device to the device file.

  PROCEDURE [XDCL] jmp$load_sys_job_template
    (    template_name: ost$name;
     VAR status: ost$status);

    VAR
      data_size_read: integer,
      directory_file_p: ^SEQ ( * ),
      directory_header_p: ^pmt$virtual_memory_image_header,
      file_attributes_p: ^ARRAY [1 .. * ] OF dmt$new_device_file_attribute,
      file_identifier: dst$deadstart_file_identifier,
      file_modified: boolean,
      file_name: ost$name,
      file_segment_pointer: mmt$segment_pointer,
      file_size: amt$file_byte_address,
      fmd_modified: boolean,
      header_sfid: dmt$system_file_id,
      local_status: ost$status,
      segment_description_p: ^pmt$linked_segment_description,
      segment_description_seq_p: ^SEQ ( * ),
      segment_index: integer,
      virtual_memory_header: pmt$virtual_memory_image_header,
      virtual_memory_header_seq_p: ^SEQ ( * ),
      vsn: rmt$recorded_vsn;

    status.normal := TRUE;
    vsn := dmv$system_device_recorded_vsn;
    dsp$read_header_labels (file_identifier);
    IF file_identifier <> 'JOB_IMAGE' THEN
      osp$system_error ('Invalid deadstart file: Cannot find JOB_IMAGE.', NIL);
    IFEND;

    virtual_memory_header_seq_p := #SEQ (virtual_memory_header);
    dsp$read_deadstart_device (#SIZE (pmt$virtual_memory_image_header), virtual_memory_header_seq_p,
          data_size_read);
    IF data_size_read < #SIZE (pmt$virtual_memory_image_header) THEN
      osp$system_error ('Invalid deadstart file: Bad JOB_IMAGE.', NIL);
    IFEND;

    IF virtual_memory_header.version <> pmc$image_version THEN
      osp$system_error ('Template header-system linker mismatch.', NIL);
    IFEND;

    { Delete old template files if requested.

    IF jmv$delete_old_templates THEN
      dmp$destroy_device_file (vsn, template_name, local_status);
      FOR segment_index := 1 TO 99 DO
        file_name := file_name_seed;
        file_name (9, 1) := $CHAR (segment_index DIV 10 + ORD ('0'));
        file_name (10, 1) := $CHAR (segment_index MOD 10 + ORD ('0'));
        dmp$destroy_device_file (vsn, file_name, local_status);
      FOREND;
    IFEND;

    { Open or create the job template directory file.

    dmp$attach_device_file (vsn, template_name, header_sfid, status);
    IF NOT status.normal THEN
      IF status.condition <> dme$unknown_device_file THEN
        RETURN;
      ELSE
        file_size := 2 * (#SIZE (pmt$virtual_memory_image_header) + #SIZE (pmt$linked_segment_description)
              * virtual_memory_header.number_of_segments);
        PUSH file_attributes_p: [1 .. 1];
        file_attributes_p^ [1].keyword := dmc$file_limit;
        file_attributes_p^ [1].limit := UPPERVALUE (amt$file_limit);
        dmp$create_device_file (template_name, vsn, file_attributes_p, file_size, header_sfid, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    file_segment_pointer.kind := mmc$sequence_pointer;
    dmp$open_file (header_sfid, osc$os_ring_1, osc$os_ring_1, mmc$sar_write_extend, mmc$as_random,
          file_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    directory_file_p := file_segment_pointer.seq_pointer;
    RESET directory_file_p;
    NEXT directory_header_p IN directory_file_p;

    directory_header_p^ := virtual_memory_header;

    { Load the job template segments from the deadstart device.

    FOR segment_index := 1 TO virtual_memory_header.number_of_segments DO
      NEXT segment_description_p IN directory_file_p;
      segment_description_seq_p := #SEQ (segment_description_p^);
      dsp$read_deadstart_device (#SIZE (segment_description_p^), segment_description_seq_p,
            data_size_read);
      IF data_size_read < #SIZE (segment_description_p^) THEN
        osp$system_error ('Invalid deadstart file: Bad segment description.', NIL);
      IFEND;
      create_segment_file (segment_index, segment_description_p^.length);
    FOREND;

    { Force the directory to its device file, close and detach the directory file.

    mmp$write_modified_pages (directory_file_p, #SIZE (directory_file_p^), osc$wait, status);
    IF NOT status.normal THEN
      osp$system_error ('Cant write template file.', ^status);
    IFEND;

    dmp$close_file (directory_file_p, status);
    IF NOT status.normal THEN
      osp$system_error ('Cant close template file.', ^status);
    IFEND;

    dmp$detach_device_file (header_sfid, file_modified, fmd_modified, status);
    IF NOT status.normal THEN
       osp$system_error ('Cant detach template file.', ^status);
    IFEND;

  PROCEND jmp$load_sys_job_template;
MODEND jmm$load_system_job_templates;
*DECK DECK=JMM$LOAD_SYSTEM_PROFILE EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Scheduling : load system profile' ??
MODULE jmm$load_system_profile;

{ PURPOSE:
{   This module contains the logic to load a new scheduling profile
{   into the system tables (activate) and to reload a previously activated
{   profile at system startup.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$class_names
*copyc jmc$job_management_id
*copyc jmc$sched_profile_deadstart_id
*copyc jmc$status_message_text
*copyc jme$activate_profile_errors
*copyc jme$job_scheduler_conditions
*copyc jme$queued_file_conditions
*copyc jmt$application_index
*copyc jmt$job_class
*copyc jmt$profile_changes
?? POP ??
*copyc amp$return
*copyc jmp$abort_deadstart
*copyc jmp$build_profile_from_system
*copyc jmp$build_tables_from_profile
*copyc jmp$clear_utility_active
*copyc jmp$change_profile_cycle
*copyc jmp$delete_profile_cycle
*copyc jmp$get_defined_classes
*copyc jmp$get_input_q_from_unassigned
*copyc jmp$get_length_of_sched_tables
*copyc jmp$get_object
*copyc jmp$get_scheduler_table
*copyc jmp$install_profile
*copyc jmp$internal_error
*copyc jmp$reactivate_job_leveling
*copyc jmp$read_profile
*copyc jmp$read_system_profile
*copyc jmp$resubmit_queued_input_job
*copyc jmp$set_profile
*copyc jmp$set_utility_active
*copyc jmp$update_profile
*copyc jmp$write_system_profile
*copyc osp$generate_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc pmp$get_mainframe_id

*copyc jmv$new_profile
*copyc jmv$object_definition
*copyc jmv$object_heap
*copyc jmv$the_profile
*copyc jmv$working_storage
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    cycle_1 = 1,
    cycle_2 = 2;

  VAR
    utility_active: boolean := FALSE,
    profile_access_id: ost$binary_unique_name;

  TYPE
    object_set = jmt$job_class_set,
    comparison_summary = record
      any_changes: boolean,
      maximum_index: integer,
      deleted_objects: object_set,
      modified_objects: object_set,
      all_old_objects: object_set,
      all_new_objects: object_set,
    recend;

  VAR
    recovery_case: (system_failed_while_moving_jobs, everything_was_ok,
          system_failed_during_update, no_valid_profile);

  VAR
    the_changes: jmt$profile_changes,
    categories_modified: boolean;

?? TITLE := 'compare_objects', EJECT ??

{ PURPOSE:
{   This routine compares the objects (classes, categories) from the new
{   profile of the specified type with the objects from the installed
{   profile.  From this comparison it
{     o determines which objects have been deleted - an object with that
{       name cannot be found.
{     o determines which objects have been modified - an object with that
{       name was found but the definition_id is different.
{     o Determines which objects are new.
{     o assigns indicies to the new objects.

  PROCEDURE compare_objects
    (    kind: jmt$profile_object_kinds;
         assign_new_indicies: boolean;
     VAR summary: comparison_summary);

    VAR
      j: integer,
      index: integer,
      this_object: object_set,
      maximum_index: integer,
      display_name: ^ost$name,
      display_sequence: ^SEQ ( * ),
      new_object: jmt$profile_object_reference,
      old_object: jmt$profile_object_reference;

    summary.any_changes := FALSE;
    summary.modified_objects := $object_set [];
    summary.deleted_objects := $object_set [];
    summary.all_old_objects := $object_set [];
    summary.all_new_objects := $object_set [];

    display_sequence := jmv$working_storage;
    the_changes.objects_changed [kind].new_objects := NIL;
    the_changes.objects_changed [kind].deleted_objects := NIL;
    the_changes.objects_changed [kind].changed_objects := NIL;
    j := 0;

    new_object := jmv$new_profile.objects [kind];
    WHILE new_object <> NIL DO
      old_object := jmv$the_profile.objects [kind];
      new_object^.index := 0;

    /find_matching_old_object/
      WHILE (old_object <> NIL) DO
        IF old_object^.name = new_object^.name THEN
          IF NOT (old_object^.index IN summary.all_new_objects) THEN
            new_object^.index := old_object^.index;
            this_object := $object_set [new_object^.index];
            summary.all_new_objects := summary.all_new_objects + this_object;
            IF old_object^.definition_id <> new_object^.definition_id THEN
              summary.any_changes := TRUE;
              summary.modified_objects := summary.modified_objects +
                    this_object;
              NEXT display_name IN display_sequence;
              IF display_name = NIL THEN
                jmp$internal_error (120);
              IFEND;
              display_name^ := old_object^.name;
              j := j + 1;
            IFEND;
            EXIT /find_matching_old_object/;
          IFEND;
        IFEND;
        old_object := old_object^.next_object;
      WHILEND /find_matching_old_object/;
      new_object := new_object^.next_object;
    WHILEND;

    IF j > 0 THEN
      NEXT the_changes.objects_changed [kind].changed_objects: [1 .. j] IN
            jmv$working_storage;
      j := 0;
    IFEND;

    old_object := jmv$the_profile.objects [kind];
    WHILE old_object <> NIL DO
      this_object := $object_set [old_object^.index];
      summary.all_old_objects := summary.all_old_objects + this_object;
      IF NOT (old_object^.index IN summary.all_new_objects) THEN
        summary.deleted_objects := summary.deleted_objects + this_object;
        summary.any_changes := TRUE;
        NEXT display_name IN display_sequence;
        IF display_name = NIL THEN
          jmp$internal_error (121);
        IFEND;
        display_name^ := old_object^.name;
        j := j + 1;
      IFEND;
      old_object := old_object^.next_object;
    WHILEND;

    IF j > 0 THEN
      NEXT the_changes.objects_changed [kind].deleted_objects: [1 .. j] IN
            jmv$working_storage;
      j := 0;
    IFEND;

    IF assign_new_indicies THEN
      summary.all_new_objects := $object_set [];
    IFEND;

    index := 1;
    maximum_index := 1;
    new_object := jmv$new_profile.objects [kind];
    WHILE new_object <> NIL DO
      new_object^.changed := TRUE;
      IF new_object^.index = 0 THEN
        summary.any_changes := TRUE;
        WHILE index IN summary.all_new_objects DO
          index := index + 1;
        WHILEND;
        new_object^.index := index;
        index := index + 1;

        NEXT display_name IN display_sequence;
        IF display_name = NIL THEN
          jmp$internal_error (122);
        IFEND;
        display_name^ := new_object^.name;
        j := j + 1;
      ELSEIF assign_new_indicies THEN
        summary.any_changes := summary.any_changes OR
              (new_object^.index <> index);
        new_object^.index := index;
        index := index + 1;
      ELSEIF new_object^.index > maximum_index THEN
        maximum_index := new_object^.index;
      IFEND;
      summary.all_new_objects := summary.all_new_objects +
            $object_set [new_object^.index];
      new_object := new_object^.next_object;
    WHILEND;

    IF j > 0 THEN
      NEXT the_changes.objects_changed [kind].new_objects: [1 .. j] IN
            jmv$working_storage;
    IFEND;

    IF index > maximum_index THEN
      maximum_index := index - 1;
    IFEND;
    summary.maximum_index := maximum_index;

  PROCEND compare_objects;
?? TITLE := 'determine_extent_of_change', EJECT ??

{ PURPOSE:
{   This routine determines exactly how much the new profile is different from
{   the installed profile. This routine also assigns the indicies for the
{   job and service classes, applications, and categories.
{
{ DESIGN:
{   The routine compares the job classes, service classes, and categories
{   between the installed and new profile to determine the changes and
{   to assign the indicies.  The applications on the new profile are
{   sorted and assigned sequential indicies.  All applications on the old
{   profile are assumed to be deleted since it is easier to delete all
{   applications and install the new list fresh.
{
{ NOTES:
{   The assignment of indicies for applications is done after the compare
{   since they are always kept in alphabetical order in the system tables.

  PROCEDURE determine_extent_of_change
    (VAR job_class_summary: comparison_summary;
     VAR deleted_service_classes: jmt$service_class_set;
     VAR deleted_applications: jmt$application_set;
     VAR category_changes: boolean;
     VAR status: ost$status);

    VAR
      assign_new_indicies: boolean,
      new_object: jmt$profile_object_reference,
      object_kind: jmt$profile_object_kinds,
      object_summary: comparison_summary,
      old_object: jmt$profile_object_reference;

    VAR
      maximum_job_classes: jmt$job_class,
      maximum_job_class_index: jmt$job_class,
      maximum_service_classes: jmt$service_class_index,
      maximum_service_class_index: jmt$service_class_index,
      maximum_applications: jmt$application_index,
      maximum_categories: integer;

    jmp$get_length_of_sched_tables (maximum_job_classes,
          maximum_job_class_index, maximum_service_classes,
          maximum_service_class_index, maximum_applications,
          maximum_categories, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF jmv$new_profile.count [jmc$profile_job_class] > maximum_job_classes THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$profile_is_too_large,
            jmc$smt_job_classes, status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            jmv$new_profile.count [jmc$profile_job_class], 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            maximum_job_classes, 10, FALSE, status);
      RETURN;
    ELSEIF jmv$new_profile.count [jmc$profile_service_class] >
          maximum_service_classes THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$profile_is_too_large,
            jmc$smt_service_classes, status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            jmv$new_profile.count [jmc$profile_service_class], 10, FALSE,
            status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            maximum_service_classes, 10, FALSE, status);
      RETURN;
    ELSEIF jmv$new_profile.count [jmc$profile_application] >
          maximum_applications THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$profile_is_too_large,
            jmc$smt_applications, status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            jmv$new_profile.count [jmc$profile_application], 10, FALSE,
            status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            maximum_applications, 10, FALSE, status);
      RETURN;
    IFEND;

    sort_objects (jmv$new_profile.objects [jmc$profile_application]);

    FOR object_kind := LOWERVALUE (object_kind) TO UPPERVALUE (object_kind) DO
      assign_new_indicies := (object_kind = jmc$profile_category) OR
            (object_kind = jmc$profile_application);
      compare_objects (object_kind, assign_new_indicies, object_summary);
      CASE object_kind OF
      = jmc$profile_service_class =
        deleted_service_classes := object_summary.deleted_objects;

      = jmc$profile_job_class =
        job_class_summary := object_summary;

      = jmc$profile_category =
        category_changes := object_summary.any_changes;

      = jmc$profile_application =
        deleted_applications := object_summary.all_old_objects;

      ELSE
      CASEND;
    FOREND
  PROCEND determine_extent_of_change;
?? TITLE := 'disable_unassigned_job_class', EJECT ??

  PROCEDURE disable_unassigned_job_class;

    VAR
      job_class: jmt$profile_object_reference;

    job_class := jmv$new_profile.objects [jmc$profile_job_class];
    WHILE job_class^.name <> jmc$unassigned_class_name DO
      job_class := job_class^.next_object;
    WHILEND;

    IF job_class^.attributes.kind = jmc$type THEN
      job_class^.attributes.attribute_list^ [jmc$jc_enable_class_initiation].
            kind := jmc$boolean;
      job_class^.attributes.attribute_list^ [jmc$jc_enable_class_initiation].
            bool := FALSE;
    IFEND;
  PROCEND disable_unassigned_job_class;
?? TITLE := 'find_classes_to_move_jobs_from', EJECT ??

{ PURPOSE:
{   Determine which classes contain jobs which potentially will end up in
{   a different class after the profile is installed.
{
{ DESIGN:
{   A job may end up in a different class if the job class it is queued in
{     o no longer exists on the new profile.
{     o has a new definition id signifying that the membership attributes
{       have been modified.
{     o is an automatic membership candidate and the class is further down
{       in the list of classes - a class with automatic membership has been
{       inserted in front of this class so this job may end up in the
{       inserted class when resubmitted.

  PROCEDURE find_classes_to_move_jobs_from
    (    category_changes: boolean;
     VAR classes_to_move_jobs: jmt$job_class_set;
     VAR job_class_summary: comparison_summary);

    VAR
      j: integer,
      display_name: ^ost$name,
      display_sequence: ^SEQ ( * ),
      index: jmt$job_class,
      auto_class_selection: jmt$object_attribute,
      target: object_set,
      order: array [jmt$job_class] of jmt$job_class,
      new_object: jmt$profile_object_reference,
      the_object: jmt$profile_object_reference;

    IF category_changes THEN
      classes_to_move_jobs := job_class_summary.all_old_objects;
    ELSE

      new_object := jmv$new_profile.objects [jmc$profile_job_class];
      WHILE new_object <> NIL DO
        new_object^.profile_index := UPPERVALUE (jmt$job_class);
        new_object := new_object^.next_object;
      WHILEND;

{ Select all classes whos definition has been modified or deleted

      classes_to_move_jobs := job_class_summary.modified_objects +
            job_class_summary.deleted_objects;

      FOR index := 1 TO job_class_summary.maximum_index DO
        order [index] := UPPERVALUE (jmt$job_class);
      FOREND;

      index := 1;
      target := job_class_summary.all_old_objects - classes_to_move_jobs;
      the_object := jmv$the_profile.objects [jmc$profile_job_class];
      WHILE the_object <> NIL DO
        IF the_object^.index IN target THEN
          order [the_object^.index] := index;
          index := index + 1;
        IFEND;
        the_object := the_object^.next_object;
      WHILEND;

{ Add in the classes which are automatically selectable and have moved
{ down in the in the list of selectable classes.

      index := 1;
      new_object := jmv$new_profile.objects [jmc$profile_job_class];
      WHILE new_object <> NIL DO
        IF new_object^.attributes.kind = jmc$type THEN
          auto_class_selection := new_object^.attributes.
                attribute_list^ [jmc$jc_auto_class_selection];
          IF (auto_class_selection.kind = jmc$boolean) AND
                auto_class_selection.bool THEN
            IF order [new_object^.index] < index THEN
              classes_to_move_jobs := classes_to_move_jobs +
                    $jmt$job_class_set [new_object^.index];
            ELSE
              index := order [new_object^.index];
            IFEND;
          IFEND;
        IFEND;
        new_object := new_object^.next_object;
      WHILEND;
    IFEND;

    the_changes.move_classes := NIL;

    IF classes_to_move_jobs <> $jmt$job_class_set [] THEN
      j := 0;
      display_sequence := jmv$working_storage;
      the_object := jmv$the_profile.objects [jmc$profile_job_class];
      WHILE the_object <> NIL DO
        IF the_object^.index IN classes_to_move_jobs THEN
          NEXT display_name IN display_sequence;
          IF display_name = NIL THEN
            jmp$internal_error (123);
          IFEND;
          display_name^ := the_object^.name;
          j := j + 1;
        IFEND;
        the_object := the_object^.next_object;
      WHILEND;
      NEXT the_changes.move_classes: [1 .. j] IN jmv$working_storage;
    IFEND;
  PROCEND find_classes_to_move_jobs_from;
?? TITLE := 'install_system_profile', EJECT ??

{ PURPOSE:
{   This request installs the specified profile into the system.
{
{ DESIGN:
{   The routine builds the scheduler tables from the specified profile
{   and calls the ring 3 interface to install the tables.

  PROCEDURE install_system_profile
    (    the_profile: jmt$profile_data;
         move_job_classes: jmt$job_class_set;
         deleted_job_classes: jmt$job_class_set;
         deleted_service_classes: jmt$service_class_set;
         deleted_applications: jmt$application_set;
         delete_profile_cycle2: boolean;
     VAR status: ost$status);

    VAR
      job_category_data: jmt$job_category_data,
      job_class_table: ^jmt$job_class_table,
      service_class_table: ^jmt$service_class_table,
      application_table: ^jmt$application_table,
      controls_table: jmt$job_scheduler_table;

    jmp$build_tables_from_profile (the_profile, FALSE, job_class_table,
          service_class_table, application_table, controls_table,
          job_category_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$install_profile (profile_access_id, job_class_table,
          service_class_table, application_table, controls_table,
          job_category_data, move_job_classes, deleted_job_classes,
          deleted_service_classes, deleted_applications, delete_profile_cycle2,
          status);

  PROCEND install_system_profile;
?? TITLE := 'find_mainframe_controls', EJECT ??

{ PURPOSE:
{   This interface finds the controls for this mainframe.
{
{ DESIGN:
{   The request makes a sequencial search for the name in the list of objects
{   of the specified type.

  PROCEDURE find_mainframe_controls
    (VAR the_profile: jmt$profile_data;
     VAR status: ost$status);

    VAR
      mainframe_id: pmt$mainframe_id,
      previous_object: jmt$profile_object_reference,
      current_object: jmt$profile_object_reference;

    status.normal := TRUE;

    pmp$get_mainframe_id (mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Look for a controls object whose name matches the current mainframe name.

    previous_object := NIL;
    current_object := the_profile.objects [jmc$profile_controls];
    WHILE (current_object <> NIL) AND (current_object^.name <> mainframe_id) DO
      previous_object := current_object;
      current_object := current_object^.next_object;
    WHILEND;

    IF current_object = NIL THEN
      osp$set_status_abnormal (jmc$job_management_id,
            jme$no_controls_for_mainframe, mainframe_id, status);
      RETURN;
    IFEND;

    IF previous_object <> NIL THEN
      previous_object^.next_object := current_object^.next_object;
      current_object^.next_object := the_profile.
            objects [jmc$profile_controls];
      the_profile.objects [jmc$profile_controls] := current_object;
    IFEND;

  PROCEND find_mainframe_controls;
?? TITLE := 'resubmit_jobs_in_unassigned', EJECT ??

{ PURPOSE
{   This request resubmits all jobs in the UNASSIGNED job class.
{
{ DESIGN:
{   Fetch list of jobs in UNASSIGNED and resubmit them one by one.

  PROCEDURE resubmit_jobs_in_unassigned
    (VAR status: ost$status);

    VAR
      job_names: ^array [1 .. * ] of jmt$system_supplied_name,
      job_count: integer,
      job_data: ^jmt$resubmitted_job_data,
      display_sequence: ^SEQ ( * ),
      i: integer;

    status.normal := TRUE;

    the_changes.resubmitted_jobs := NIL;

    job_count := 1;
    REPEAT
      PUSH job_names: [1 .. job_count];
      jmp$get_input_q_from_unassigned (job_names^, job_count, status);
      IF NOT status.normal AND (status.condition <> jme$result_array_too_small)
            THEN
        RETURN;
      IFEND;
    UNTIL status.normal;

    display_sequence := jmv$working_storage;

    FOR i := 1 TO job_count DO
      NEXT job_data IN display_sequence;
      IF job_data = NIL THEN
        jmp$internal_error (123);
      IFEND;
      job_data^.job_name := job_names^ [i];
      jmp$resubmit_queued_input_job (job_names^ [i], job_data^.status);
    FOREND;

    IF job_count > 0 THEN
      NEXT the_changes.resubmitted_jobs: [1 .. job_count] IN
            jmv$working_storage;
    IFEND;

  PROCEND resubmit_jobs_in_unassigned;

?? TITLE := 'sort_objects', EJECT ??

{ PURPOSE:
{   This request sorts the objects of the specified type by name.
{
{ DESIGN:
{   Uses merge sort with linked lists.

  PROCEDURE sort_objects
    (VAR the_list: jmt$profile_object_reference);

    VAR
      i: integer,
      merge_list_size: integer,
      old_list: jmt$profile_object_reference,
      sublist_1: jmt$profile_object_reference,
      sublist_2: jmt$profile_object_reference,
      newlist_tail: jmt$profile_object_reference,
      sublist_tail: jmt$profile_object_reference,
      top: jmt$profile_object_reference;

    IF the_list = NIL THEN
      RETURN;
    IFEND;

    PUSH top;
    top^.next_object := the_list;
    merge_list_size := 1;
    WHILE TRUE DO
      old_list := top^.next_object;
      newlist_tail := top;

      WHILE old_list <> NIL DO

        sublist_1 := old_list;

      /peel1/
        FOR i := 1 TO merge_list_size DO
          IF old_list = NIL THEN
            IF newlist_tail = top THEN
              the_list := top^.next_object;
              RETURN;
            IFEND;
            EXIT /peel1/;
          IFEND;
          sublist_tail := old_list;
          old_list := old_list^.next_object;
        FOREND /peel1/;
        sublist_tail^.next_object := NIL;

        sublist_2 := old_list;

      /peel2/
        FOR i := 1 TO merge_list_size DO
          IF old_list = NIL THEN
            EXIT /peel2/;
          IFEND;
          sublist_tail := old_list;
          old_list := old_list^.next_object;
        FOREND /peel2/;
        sublist_tail^.next_object := NIL;

      /merge/
        WHILE (sublist_1 <> NIL) AND (sublist_2 <> NIL) DO
          IF sublist_1^.name < sublist_2^.name THEN
            newlist_tail^.next_object := sublist_1;
            newlist_tail := sublist_1;
            sublist_1 := newlist_tail^.next_object;
          ELSE
            newlist_tail^.next_object := sublist_2;
            newlist_tail := sublist_2;
            sublist_2 := newlist_tail^.next_object;
          IFEND;
        WHILEND /merge/;

        newlist_tail^.next_object := sublist_1;
        WHILE sublist_1 <> NIL DO
          newlist_tail := sublist_1;
          sublist_1 := newlist_tail^.next_object;
        WHILEND;

        newlist_tail^.next_object := sublist_2;
        WHILE sublist_2 <> NIL DO
          newlist_tail := sublist_2;
          sublist_2 := newlist_tail^.next_object;
        WHILEND;

      WHILEND;
      merge_list_size := merge_list_size * 2;
    WHILEND;
  PROCEND sort_objects;
?? TITLE := 'validate_profile', EJECT ??

{ PURPOSE:
{   This request verifies that the internal profile matches the scheduler
{   tables.
{
{ DESIGN:
{   Compare the profile identification, the job class names, and the service
{   class names from the system tables with same data from the profile.

  PROCEDURE validate_profile
    (    profile_identification: ost$name;
     VAR status: ost$status);

    VAR
      i: integer,
      number_of_classes: ost$non_negative_integers,
      call_status: ost$status,
      object_p: jmt$profile_object_reference,
      defined_classes: array [1 .. jmc$maximum_job_classes] of
            jmt$defined_class;

    osp$set_status_abnormal (jmc$job_management_id,
          jme$system_profile_mismatch, ' ', status);

    IF profile_identification <> jmv$the_profile.definition_id THEN
      RETURN;
    IFEND;

    jmp$get_defined_classes (jmc$job_class, defined_classes, number_of_classes,
          call_status);
    IF NOT call_status.normal THEN
      status := call_status;
      RETURN;
    IFEND;

  /job_classes/
    FOR i := 1 TO number_of_classes DO
      object_p := jmv$the_profile.objects [jmc$profile_job_class];
      WHILE object_p <> NIL DO
        IF defined_classes [i].name = object_p^.name THEN
          IF defined_classes [i].index = object_p^.index THEN
            CYCLE /job_classes/;
          IFEND;
          RETURN;
        IFEND;
        object_p := object_p^.next_object;
      WHILEND;
      RETURN;
    FOREND /job_classes/;

    jmp$get_defined_classes (jmc$service_class, defined_classes,
          number_of_classes, call_status);
    IF NOT call_status.normal THEN
      status := call_status;
      RETURN;
    IFEND;

  /service_classes/
    FOR i := 1 TO number_of_classes DO
      object_p := jmv$the_profile.objects [jmc$profile_service_class];
      WHILE object_p <> NIL DO
        IF defined_classes [i].name = object_p^.name THEN
          IF defined_classes [i].index = object_p^.index THEN
            CYCLE /service_classes/;
          IFEND;
          RETURN;
        IFEND;
        object_p := object_p^.next_object;
      WHILEND;
      RETURN;
    FOREND /service_classes/;

    status.normal := TRUE;
  PROCEND validate_profile;
?? TITLE := '[XDCL, #GATE] jmp$activate_system_profile', EJECT ??

{ PURPOSE:
{   This interface attempts to activate the profile on the specified file.
{
{ NOTES:
{   If activating the profile could potentially cause jobs to be resubmitted
{   then the ALLOW_JOB_RECLASSIFICATION flag must be set to allow the profile
{   activation to complete.

  PROCEDURE [XDCL, #GATE] jmp$activate_system_profile
    (    access_id: ost$binary_unique_name;
         new_profile: fst$file_reference;
         allow_job_reclassification: boolean;
     VAR profile_changes: jmt$profile_changes;
     VAR status: ost$status);

    VAR
      deleted_service_classes: jmt$service_class_set,
      deleted_applications: jmt$application_set,
      category_changes: boolean,
      job_class_summary: comparison_summary,
      classes_to_move_jobs: jmt$job_class_set,
      old_object: jmt$profile_object_reference,
      j: integer,
      display_name: ^ost$name,
      local_status: ost$status;

    RESET jmv$working_storage;

    IF NOT utility_active THEN
      osp$set_status_condition (jme$no_utility_is_active, status);
      RETURN;
    IFEND;

    IF access_id <> profile_access_id THEN
      osp$set_status_condition (jme$access_id_mismatch, status);
      RETURN;
    IFEND;

    jmp$read_profile (new_profile, jmv$new_profile, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    find_mainframe_controls (jmv$new_profile, status);
    IF NOT status.normal THEN
      osp$append_status_file (osc$status_parameter_delimiter, new_profile,
            status);
      RETURN;
    IFEND;

    determine_extent_of_change (job_class_summary, deleted_service_classes,
          deleted_applications, category_changes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    find_classes_to_move_jobs_from (category_changes, classes_to_move_jobs,
          job_class_summary);

    IF classes_to_move_jobs <> $jmt$job_class_set [] THEN
      IF NOT allow_job_reclassification THEN
        osp$set_status_condition (jme$major_profile_change, status);
        RETURN;
      IFEND;
    IFEND;

    profile_changes := the_changes;

    disable_unassigned_job_class;

    jmp$write_system_profile (access_id, jmv$new_profile, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    install_system_profile (jmv$new_profile, classes_to_move_jobs,
          job_class_summary.deleted_objects, deleted_service_classes,
          deleted_applications, TRUE, status);
    IF NOT status.normal THEN
      jmp$delete_profile_cycle (access_id, cycle_1, local_status);
      RETURN;
    IFEND;

    jmp$set_profile (jmv$new_profile);

    jmp$change_profile_cycle (access_id, local_status);
    IF NOT local_status.normal THEN
      osp$generate_message (local_status, status);
    IFEND;

    resubmit_jobs_in_unassigned ({ ignore } local_status);
    profile_changes := the_changes;

    jmp$reactivate_job_leveling (access_id, status);
  PROCEND jmp$activate_system_profile;
?? TITLE := '[XDCL, #GATE] jmp$recover_profile', EJECT ??

{ PURPOSE:
{   This interface attempts to recover a valid profile from the system
{   scheduling profile file.  If the system tables still have the deadstart
{   profile then it installs the profile it recovered otherwise it makes
{   sure that the profile it recovered is the same as the system tables.
{   If there is a mismatch the system tables are used to form a temporary
{   profile and the flag PREVENT_UPDATE_OF_PROFILE_FILE is set to TRUE.

  PROCEDURE [XDCL, #GATE] jmp$recover_profile
    (VAR access_id: ost$binary_unique_name;
     VAR prevent_update_of_profile_file: boolean;
     VAR status: ost$status);

    VAR
      profile1_is_valid: boolean,
      profile2_is_valid: boolean,
      scheduler_table: jmt$job_scheduler_table,
      local_status: ost$status,
      ignore: ost$status;

    RESET jmv$working_storage;

    prevent_update_of_profile_file := FALSE;

    jmp$set_utility_active (profile_access_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    access_id := profile_access_id;
    utility_active := TRUE;

    profile2_is_valid := FALSE;
    profile1_is_valid := FALSE;
    jmp$read_system_profile (access_id, cycle_2, jmv$new_profile,
          local_status);
    IF local_status.normal THEN
      find_mainframe_controls (jmv$new_profile, local_status);
      IF local_status.normal THEN
        jmp$set_profile (jmv$new_profile);
        profile2_is_valid := TRUE;
      IFEND;
    IFEND;

    jmp$read_system_profile (access_id, cycle_1, jmv$new_profile,
          local_status);
    IF local_status.normal THEN
      find_mainframe_controls (jmv$new_profile, local_status);
      profile1_is_valid := local_status.normal;
    IFEND;

    IF profile2_is_valid THEN
      IF profile1_is_valid THEN
        recovery_case := system_failed_while_moving_jobs;
        jmp$delete_profile_cycle (access_id, cycle_1, local_status);
      ELSE
        recovery_case := everything_was_ok;
      IFEND;
    ELSE
      IF profile1_is_valid THEN
        recovery_case := system_failed_during_update;
        jmp$delete_profile_cycle (access_id, cycle_2, ignore);
        jmp$change_profile_cycle (access_id, local_status);
        jmp$set_profile (jmv$new_profile);
      ELSE
        recovery_case := no_valid_profile;
      IFEND;
    IFEND;

    jmp$get_scheduler_table (scheduler_table, jmv$working_storage, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF scheduler_table.profile_identification =
          jmc$sched_profile_deadstart_id THEN

      IF recovery_case = no_valid_profile THEN
        jmp$write_system_profile (access_id, jmv$the_profile, status);
        IF NOT status.normal THEN
          jmp$clear_utility_active (profile_access_id, ignore);
          RETURN;
        IFEND;

        install_system_profile (jmv$the_profile, $jmt$job_class_set [],
              $jmt$job_class_set [], $jmt$service_class_set [],
              $jmt$application_set [], FALSE, status);
        IF NOT status.normal THEN
          jmp$clear_utility_active (profile_access_id, ignore);
          IF status.condition = jme$profile_too_large THEN
            jmp$abort_deadstart ('', status, local_status);
          IFEND;
          RETURN;
        IFEND;

        jmp$delete_profile_cycle (access_id, cycle_2, ignore);
        jmp$change_profile_cycle (access_id, status);
        IF NOT status.normal THEN
          jmp$clear_utility_active (profile_access_id, ignore);
          RETURN;
        IFEND;

        osp$set_status_condition (jme$unable_to_recover_profile, local_status);
        osp$generate_message (local_status, ignore);

      ELSE
        install_system_profile (jmv$the_profile, $jmt$job_class_set [],
              $jmt$job_class_set [], $jmt$service_class_set [],
              $jmt$application_set [], FALSE, status);
        IF NOT status.normal THEN
          jmp$clear_utility_active (profile_access_id, ignore);
          IF status.condition = jme$profile_too_large THEN
            jmp$abort_deadstart ('', status, local_status);
          IFEND;
          RETURN;
        IFEND;
      IFEND;
      resubmit_jobs_in_unassigned (status);

    ELSE
      validate_profile (scheduler_table.profile_identification, local_status);
      IF NOT local_status.normal THEN
        IF local_status.condition <> jme$system_profile_mismatch THEN
          jmp$clear_utility_active (profile_access_id, ignore);
          status := local_status;
          RETURN;
        IFEND;

        osp$generate_message (local_status, ignore);
        jmp$build_profile_from_system (jmv$new_profile, status);
        IF NOT status.normal THEN
          jmp$clear_utility_active (profile_access_id, ignore);
          RETURN;
        IFEND;

        jmp$set_profile (jmv$new_profile);
        prevent_update_of_profile_file := TRUE;
      IFEND;

    IFEND;

  PROCEND jmp$recover_profile;
?? TITLE := '[XDCL, #GATE] jmp$update_system_profile', EJECT ??

{ PURPOSE:
{   This request is used to make changes to the system tables that
{   do not involve structural changes.
{
{ NOTE
{   If the flag PREVENT_UPDATE_OF_PROFILE_FILE is TRUE then the tables
{   are updated but no new profile file cycle is written.

  PROCEDURE [XDCL, #GATE] jmp$update_system_profile
    (    access_id: ost$binary_unique_name;
         prevent_update_of_profile_file: boolean;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      job_category_data: jmt$job_category_data,
      job_class_table: ^jmt$job_class_table,
      service_class_table: ^jmt$service_class_table,
      application_table: ^jmt$application_table,
      controls_table: jmt$job_scheduler_table;

    IF NOT utility_active THEN
      osp$set_status_condition (jme$no_utility_is_active, status);
      RETURN;
    IFEND;

    IF access_id <> profile_access_id THEN
      osp$set_status_condition (jme$access_id_mismatch, status);
      RETURN;
    IFEND;

    RESET jmv$working_storage;

    jmp$build_tables_from_profile (jmv$the_profile, TRUE, job_class_table,
          service_class_table, application_table, controls_table,
          job_category_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF prevent_update_of_profile_file THEN
      jmp$update_profile (access_id, job_class_table, service_class_table,
            application_table, ^controls_table, status);
      IF status.normal THEN
        osp$set_status_condition (jme$updated_only_tables, local_status);
        osp$generate_message (local_status, status);
      IFEND;
    ELSE
      jmp$write_system_profile (access_id, jmv$the_profile, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      jmp$update_profile (access_id, job_class_table, service_class_table,
            application_table, ^controls_table, status);
      IF status.normal THEN
        jmp$delete_profile_cycle (access_id, cycle_2, local_status);
        jmp$change_profile_cycle (access_id, status);
      ELSE
        jmp$delete_profile_cycle (access_id, cycle_1, local_status);
      IFEND;
    IFEND;

  PROCEND jmp$update_system_profile;

MODEND jmm$load_system_profile;
*DECK DECK=JMM$LOGGING_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : Logging Interfaces' ??
MODULE jmm$logging_interfaces;

{ PURPOSE:
{   This module contains interfaces used to format and emit
{   statistics.
{
{ DESIGN:
{   Procedures in this module will run in rings 2 and 3 with a call bracket of ring 13.
{   In order to emit a statistic the following must be done:
{      1. Obtain the data necessary for the statistic to be emitted.
{      2. Format the statistics' counters if there are any.
{      3. Format the statistics' descriptive data if there is any.
{      4. Call SF interface to emit the statistic.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avc$accounting_statistics
*copyc jmc$job_management_id
*copyc jme$queued_file_conditions
*copyc jmk$keypoints
*copyc jml$user_id
*copyc jmt$comm_acct_statistic_data
*copyc jmt$job_system_label
*copyc nft$batch_input_accounting_data
*copyc nft$qtf_input_accounting_data
*copyc osc$timesharing
*copyc osc$timesharing_terminal_file
*copyc osd$integer_limits
*copyc oss$job_paged_literal
*copyc ost$string
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$return
*copyc clp$convert_integer_to_string
*copyc clp$trimmed_string_size
*copyc clv$standard_files
*copyc iip$st_get_input_output_counts
*copyc jmv$job_attributes
*copyc nap$get_attributes
*copyc nap$get_connect_time_interval
*copyc nap$parse_accounting_data
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pfp$attach
*copyc pfp$begin_system_authority
*copyc pfp$end_system_authority
*copyc pmp$compute_time_dif_in_seconds
*copyc pmp$get_account_project
*copyc pmp$get_compact_date_time
*copyc pmp$get_unique_name
*copyc qfp$read_output_system_label
*copyc sfp$emit_statistic
*copyc sfp$get_routing_controls
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    max_descriptive_data_items = sfc$max_descriptive_data_size;

  TYPE
    descriptive_data_item = string (sfc$max_descriptive_data_size);

?? OLDTITLE ??
?? NEWTITLE := 'build_descriptive_data', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to trim trailing blanks from each item
{   and concatenate the string to the end of the descriptive data.

  PROCEDURE build_descriptive_data
    (    descriptive_data_items: array [1 .. * ] of descriptive_data_item;
     VAR descriptive_data: string (sfc$max_descriptive_data_size);
     VAR descriptive_data_size: 0 .. sfc$max_descriptive_data_size);

    VAR
      item: 1 .. max_descriptive_data_items,
      string_to_add_size: 0 .. sfc$max_descriptive_data_size;

    FOR item := 1 TO UPPERBOUND (descriptive_data_items) DO

{ If size of descriptive data is already at max, return.

      IF descriptive_data_size = sfc$max_descriptive_data_size THEN
        RETURN;
      IFEND;

{ Get the size of string_to_add minus trailing blanks.

      string_to_add_size := clp$trimmed_string_size (descriptive_data_items [item]);

{ Shorten string_to_add_size if it will overflow the descriptive data.

      IF descriptive_data_size + string_to_add_size > sfc$max_descriptive_data_size THEN
        string_to_add_size := sfc$max_descriptive_data_size - descriptive_data_size;
      IFEND;

{ Add item to descriptive_data.

      descriptive_data (descriptive_data_size + 1, string_to_add_size) := descriptive_data_items [item]
            (1, string_to_add_size);
      descriptive_data_size := descriptive_data_size + string_to_add_size;

{ If this is not the last item, add a comma.

      IF item <> UPPERBOUND (descriptive_data_items) THEN
        descriptive_data (descriptive_data_size + 1, 1) := ',';
        descriptive_data_size := descriptive_data_size + 1;
      IFEND;

    FOREND;
  PROCEND build_descriptive_data;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$emit_communication_stat', EJECT ??
*copyc jmh$emit_communication_stat

  PROCEDURE [XDCL, #GATE] jmp$emit_communication_stat
    (    statistic_data: jmt$comm_acct_statistic_data);


{ The following constant represents the size of the work area set up to contain the
{ peer_accounting_information attribute from the NAM/VE connection.

    CONST
      max_data_area_size = 1000;

    TYPE
      batch_input_device_converter = record
        case boolean of
        = TRUE =
          data: nft$batch_input_accounting_data,
        = FALSE =
          string_value: string (jmc$job_input_device_size),
        casend,
      recend;

    TYPE
      qtf_input_device_converter = record
        case boolean of
        = TRUE =
          data: nft$qtf_input_accounting_data,
        = FALSE =
          string_value: string (jmc$job_input_device_size),
        casend,
      recend;

    VAR
      account: avt$account_name,
      activated_logs: sft$binary_logset,
      batch_input_device: batch_input_device_converter,
      bytes_transferred_in: ost$non_negative_integers,
      bytes_transferred_out: ost$non_negative_integers,
      connect_time: ost$non_negative_integers,
      contains_data: boolean,
      counters: sft$counters,
      current_date_time: ost$date_time,
      cycle_selector: pft$cycle_selector,
      descriptive_data: string (sfc$max_descriptive_data_size),
      descriptive_data_items: ^array [1 .. * ] of descriptive_data_item,
      descriptive_data_size: 0 .. sfc$max_descriptive_data_size,
      file_attributes: ^amt$get_attributes,
      get_accounting_data: ^nat$accounting_data_fields,
      get_attributes: ^nat$get_attributes,
      ignore_name: ost$name,
      ignore_status: ost$status,
      index: nat$accounting_data_kind,
      job_system_label_p: ^jmt$job_system_label,
      line_speed_string: ost$string,
      local_file: boolean,
      local_status: ost$status,
      logset: pmt$ascii_logset,
      old_file: boolean,
      output_system_label_p: ^jmt$output_system_label,
      password: pft$password,
      peer_accounting_information: ^string ( * ),
      project: avt$project_name,
      qtf_input_device: qtf_input_device_converter,
      seconds: integer,
      statistic_identifier_map: [STATIC, READ, oss$job_paged_literal] array
            [jmc$ca_input_file .. jmc$ca_last_statistic] of ost$non_negative_integers :=
            [avc$ca_input_file, avc$ca_output_file, avc$ca_output_queue_residency, avc$ca_print_file,
            avc$ca_submit_job, avc$ca_standard_output_file, avc$ca_request_pf_transfer,
            avc$ca_target_pf_transfer, avc$ca_origin_qf_transfer, avc$ca_dest_qf_transfer,
            avc$ca_interactive_interval, avc$ca_ftp_client_ctrl_connect, avc$ca_ftp_client_data_connect,
            avc$ca_ftp_server_ctrl_connect, avc$ca_ftp_server_data_connect],
      unique_lfn: amt$local_file_name,
      usage_selections: pft$usage_selections;

?? NEWTITLE := 'handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, local_status, ignore_status);
    PROCEND handle_block_exit;
?? OLDTITLE, EJECT ??

    #KEYPOINT (osk$entry, 0, jmk$emit_communication_stat);

    local_status.normal := TRUE;

{ The procedure "osp$verify_system_privilege" should be called here when the capability for
{ NOS/VE applications to run in system privileged segments is available.

    logset := $pmt$ascii_logset [pmc$system_log];

{ Determine if the statistic to be emitted is activated to any log.

    REPEAT
      sfp$get_routing_controls (statistic_identifier_map [statistic_data.statistic_id], activated_logs,
            ignore_name, local_status);
    UNTIL (local_status.normal) OR (local_status.condition <> sfe$call_again_job_recovered);
    IF NOT local_status.normal THEN
      osp$generate_log_message (logset, local_status, ignore_status);
      #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
      RETURN;
    IFEND;

{ If the set of logs in activated_logs is empty, return.

    IF activated_logs = $sft$binary_logset [] THEN
      #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
      RETURN;
    IFEND;

{ Initialize the descriptive_data and descriptive_data_size.

    descriptive_data := ' ';
    descriptive_data_size := 0;

    PUSH file_attributes: [1 .. 1];
    file_attributes^ [1].key := amc$file_length;

    CASE statistic_data.statistic_id OF
    = jmc$ca_input_file =

{ Build the avc$ca_input_file statistic.

      batch_input_device.string_value := statistic_data.input_file^.job_input_device.
            text (1, statistic_data.input_file^.job_input_device.size);
      job_system_label_p := statistic_data.input_file^.job_system_label_p;

{ Set up counters for the statistic.

      PUSH counters: [1 .. 3];
      counters^ [1] := job_system_label_p^.job_attributes.job_size;
      counters^ [2] := batch_input_device.data.connect_time;
      counters^ [3] := batch_input_device.data.number_of_cards;

      pmp$get_account_project (account, project, ignore_status);

{ Build the descriptive_data for the statistic.

      PUSH descriptive_data_items: [1 .. 12];

      descriptive_data_items^ [1] := job_system_label_p^.login_user_identification.family;
      descriptive_data_items^ [2] := job_system_label_p^.login_user_identification.user;
      descriptive_data_items^ [3] := account;
      descriptive_data_items^ [4] := project;
      descriptive_data_items^ [5] := job_system_label_p^.system_job_name;
      descriptive_data_items^ [6] := job_system_label_p^.user_job_name;
      descriptive_data_items^ [7] := batch_input_device.data.di_system_name;
      descriptive_data_items^ [8] := batch_input_device.data.line_name;
      descriptive_data_items^ [9] := batch_input_device.data.line_subtype;
      clp$convert_integer_to_string (batch_input_device.data.line_speed, 10, FALSE, line_speed_string,
            ignore_status);
      descriptive_data_items^ [10] := line_speed_string.value (1, line_speed_string.size);
      descriptive_data_items^ [11] := batch_input_device.data.i_o_station_name;
      descriptive_data_items^ [12] := batch_input_device.data.device_name;

      build_descriptive_data (descriptive_data_items^, descriptive_data, descriptive_data_size);

    = jmc$ca_output_file =

{ Build the avc$ca_output_file statistic.

{ Set up counters for statistic.

      PUSH counters: [1 .. 3];
      counters^ [1] := statistic_data.output_file^.output_descriptor.file_size;
      counters^ [2] := statistic_data.output_file^.connect_time;
      counters^ [3] := statistic_data.output_file^.number_of_lines;

{ Retrieve the peer_accounting_information attribute.

      PUSH get_attributes: [1 .. 1];
      get_attributes^ [1].kind := nac$peer_accounting_information;
      PUSH get_attributes^ [1].peer_accounting_information: [[REP max_data_area_size OF cell]];

      nap$get_attributes (statistic_data.output_file^.network_file_name, get_attributes^, local_status);
      IF NOT local_status.normal THEN
        osp$generate_log_message (logset, local_status, ignore_status);
        #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
        RETURN;
      IFEND;

      IF get_attributes^ [1].peer_accounting_info_length = 0 THEN
        peer_accounting_information := NIL;
      ELSE
        RESET get_attributes^ [1].peer_accounting_information;
        NEXT peer_accounting_information: [get_attributes^ [1].peer_accounting_info_length] IN
              get_attributes^ [1].peer_accounting_information;
      IFEND;

{ Get accounting_data.

      PUSH get_accounting_data: [1 .. 4];
      get_accounting_data^ [1].kind := nac$ca_di_system_name;
      get_accounting_data^ [2].kind := nac$ca_line_name;
      get_accounting_data^ [3].kind := nac$ca_line_subtype;
      get_accounting_data^ [4].kind := nac$ca_line_speed;

      nap$parse_accounting_data (peer_accounting_information, NIL, get_accounting_data, local_status);
      IF NOT local_status.normal THEN
        osp$generate_log_message (logset, local_status, ignore_status);
        #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
        RETURN;
      IFEND;

{ Set up descriptive_data for statistic.

      PUSH descriptive_data_items: [1 .. UPPERBOUND (get_accounting_data^) + 11];

      descriptive_data_items^ [1] := statistic_data.output_file^.output_descriptor.login_family;
      descriptive_data_items^ [2] := statistic_data.output_file^.output_descriptor.login_user;
      descriptive_data_items^ [3] := statistic_data.output_file^.output_descriptor.login_account;
      descriptive_data_items^ [4] := statistic_data.output_file^.output_descriptor.login_project;
      descriptive_data_items^ [5] := statistic_data.output_file^.output_descriptor.system_job_name;
      descriptive_data_items^ [6] := statistic_data.output_file^.output_descriptor.user_file_name;

{ Add each element of get_accounting_data array to the descriptive_data.

      FOR index := 1 TO UPPERBOUND (get_accounting_data^) DO
        CASE get_accounting_data^ [index].kind OF
        = nac$ca_di_system_name =
          descriptive_data_items^ [index + 6] := get_accounting_data^ [index].di_system_name;
        = nac$ca_line_name =
          descriptive_data_items^ [index + 6] := get_accounting_data^ [index].line_name;
        = nac$ca_line_subtype =
          descriptive_data_items^ [index + 6] := get_accounting_data^ [index].line_subtype;
        = nac$ca_line_speed =
          clp$convert_integer_to_string (get_accounting_data^ [index].line_speed, 10, FALSE,
                line_speed_string, ignore_status);
          descriptive_data_items^ [index + 6] := line_speed_string.value (1, line_speed_string.size);
        = nac$ca_unavailable_information =
          descriptive_data_items^ [index + 6] := ' ';
        ELSE
          ;
        CASEND;
      FOREND;

      descriptive_data_items^ [11] := statistic_data.output_file^.output_descriptor.station;
      descriptive_data_items^ [12] := statistic_data.output_file^.output_descriptor.device;
      descriptive_data_items^ [13] := statistic_data.output_file^.output_descriptor.output_class;
      descriptive_data_items^ [14] := statistic_data.output_file^.output_descriptor.forms_code;
      descriptive_data_items^ [15] := statistic_data.output_file^.output_descriptor.system_file_name;

      build_descriptive_data (descriptive_data_items^, descriptive_data, descriptive_data_size);

    = jmc$ca_output_queue_residency =

{ Build the avc$ca_output_queue_residency statistic.

{ Get a unique name.

      pmp$get_unique_name (unique_lfn, local_status);
      IF NOT local_status.normal THEN
        osp$generate_log_message (logset, local_status, ignore_status);
        #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
        RETURN;
      IFEND;

{ Attach the output file.

      cycle_selector.cycle_option := pfc$specific_cycle;
      cycle_selector.cycle_number := 1;
      password := osc$null_name;
      usage_selections := $pft$usage_selections [pfc$read];

      osp$establish_block_exit_hndlr (^handle_block_exit);
      pfp$begin_system_authority;

      pfp$attach (unique_lfn, statistic_data.output_queue_residency^.output_file_path^, cycle_selector,
            password, usage_selections, usage_selections, pfc$wait, local_status);
      IF NOT local_status.normal THEN
        osp$generate_log_message (logset, local_status, ignore_status);
        #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
        RETURN;
      IFEND;

      pfp$end_system_authority;
      osp$disestablish_cond_handler;

{ Read the output system label.

      PUSH output_system_label_p;
      qfp$read_output_system_label (unique_lfn, output_system_label_p^, local_status);
      IF NOT local_status.normal THEN
        amp$return (unique_lfn, ignore_status);
        osp$generate_log_message (logset, local_status, ignore_status);
        #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
        RETURN;
      IFEND;

{ Return the output queue file.

      amp$return (unique_lfn, local_status);
      IF NOT local_status.normal THEN
        osp$generate_log_message (logset, local_status, ignore_status);
        #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
        RETURN;
      IFEND;

{ Get the current date and time.

      pmp$get_compact_date_time (current_date_time, local_status);
      IF NOT local_status.normal THEN
        osp$generate_log_message (logset, local_status, ignore_status);
        #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
        RETURN;
      IFEND;

      pmp$compute_time_dif_in_seconds (output_system_label_p^.output_submission_time, current_date_time,
            seconds, local_status);
      IF NOT local_status.normal THEN
        osp$generate_log_message (logset, local_status, ignore_status);
        #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
        RETURN;
      IFEND;

{ Set the values of the counters.

      PUSH counters: [1 .. 2];
      counters^ [1] := output_system_label_p^.file_size;
      counters^ [2] := seconds;

{ Build the descriptive_data.

      PUSH descriptive_data_items: [1 .. 7];

      descriptive_data_items^ [1] := output_system_label_p^.login_user_identification.family;
      descriptive_data_items^ [2] := output_system_label_p^.login_user_identification.user;
      descriptive_data_items^ [3] := output_system_label_p^.login_account;
      descriptive_data_items^ [4] := output_system_label_p^.login_project;
      descriptive_data_items^ [5] := output_system_label_p^.system_job_name;
      descriptive_data_items^ [6] := output_system_label_p^.user_file_name;
      descriptive_data_items^ [7] := output_system_label_p^.system_file_name;

      build_descriptive_data (descriptive_data_items^, descriptive_data, descriptive_data_size);

    = jmc$ca_print_file =

{ Build the avc$ca_print_file statistic.

{ Set the values of the counter.

      PUSH counters: [1 .. 1];
      counters^ [1] := statistic_data.print_file^.file_size;

{ Build the descriptive_data.

      PUSH descriptive_data_items: [1 .. 2];

      descriptive_data_items^ [1] := statistic_data.print_file^.user_file_name;
      descriptive_data_items^ [2] := statistic_data.print_file^.system_file_name;

      build_descriptive_data (descriptive_data_items^, descriptive_data, descriptive_data_size);

    = jmc$ca_submit_job =

{ Build the avc$ca_submit_job statistic.

{ Set the values of the counter.

      PUSH counters: [1 .. 1];
      counters^ [1] := statistic_data.submit_job^.job_size;

{ Build the descriptive_data.

      descriptive_data := statistic_data.submit_job^.system_job_name;
      descriptive_data_size := clp$trimmed_string_size (descriptive_data);

    = jmc$ca_standard_output_file =

{ Build the avc$ca_standard_output_file statistic.

      IF (jmv$job_attributes.output_disposition_key = jmc$normal_output_disposition) THEN

{ Get the file_length file attribute of $OUTPUT.

        amp$get_file_attributes (clv$standard_files [clc$sf_job_output_file].path_handle_name,
              file_attributes^, local_file, old_file, contains_data, local_status);
        IF NOT local_status.normal THEN
          osp$generate_log_message (logset, local_status, ignore_status);
          #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
          RETURN;
        IFEND;

        PUSH counters: [1 .. 1];
        counters^ [1] := file_attributes^ [1].file_length;

{ Get the file_length file attribute of $JOB_LOG.

        amp$get_file_attributes (clv$standard_files [clc$sf_job_log_file].path_handle_name, file_attributes^,
              local_file, old_file, contains_data, local_status);
        IF NOT local_status.normal THEN
          osp$generate_log_message (logset, local_status, ignore_status);
          #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
          RETURN;
        IFEND;

{ Set value of counter to size of $OUTPUT + size of $JOB_LOG.

        counters^ [1] := counters^ [1] + file_attributes^ [1].file_length;

{ Build the descriptive_data.

        descriptive_data := 'OUTPUT';
        descriptive_data_size := 6;

      ELSE
        #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
        RETURN;

      IFEND;

    = jmc$ca_request_pf_transfer =

{ Build the avc$ca_request_pf_transfer statistic.

{ Set values of counters.

      PUSH counters: [1 .. 3];
      counters^ [1] := statistic_data.request_perm_file_transfer^.file_size;
      counters^ [2] := statistic_data.request_perm_file_transfer^.bytes_transferred;
      counters^ [3] := statistic_data.request_perm_file_transfer^.connect_time;

{ Build the descriptive_data.

      PUSH descriptive_data_items: [1 .. 3];

      descriptive_data_items^ [1] := statistic_data.request_perm_file_transfer^.requesting_mainframe_name;
      descriptive_data_items^ [2] := statistic_data.request_perm_file_transfer^.target_mainframe_name;
      descriptive_data_items^ [3] := statistic_data.request_perm_file_transfer^.command_string.
            value (1, statistic_data.request_perm_file_transfer^.command_string.size);

      build_descriptive_data (descriptive_data_items^, descriptive_data, descriptive_data_size);

    = jmc$ca_target_pf_transfer =

{ Build the avc$ca_target_pf_transfer statistic.

{ Set values of counters.

      PUSH counters: [1 .. 3];
      counters^ [1] := statistic_data.target_perm_file_transfer^.file_size;
      counters^ [2] := statistic_data.target_perm_file_transfer^.bytes_transferred;
      counters^ [3] := statistic_data.target_perm_file_transfer^.connect_time;

{ Build the descriptive_data.

      PUSH descriptive_data_items: [1 .. 3];

      descriptive_data_items^ [1] := statistic_data.target_perm_file_transfer^.requesting_mainframe_name;
      descriptive_data_items^ [2] := statistic_data.target_perm_file_transfer^.target_mainframe_name;
      descriptive_data_items^ [3] := statistic_data.target_perm_file_transfer^.command_string.
            value (1, statistic_data.target_perm_file_transfer^.command_string.size);

      build_descriptive_data (descriptive_data_items^, descriptive_data, descriptive_data_size);

    = jmc$ca_origin_qf_transfer =

{ Build the avc$ca_origin_qf_transfer statistic.

{ Set value of counter.

      PUSH counters: [1 .. 1];
      counters^ [1] := statistic_data.origin_queue_file_transfer^.file_size;

{ Build the descriptive_data.

      PUSH descriptive_data_items: [1 .. 8];

      descriptive_data_items^ [1] := statistic_data.origin_queue_file_transfer^.user_identification.family;
      descriptive_data_items^ [2] := statistic_data.origin_queue_file_transfer^.user_identification.user;
      descriptive_data_items^ [3] := statistic_data.origin_queue_file_transfer^.account_name;
      descriptive_data_items^ [4] := statistic_data.origin_queue_file_transfer^.project_name;
      descriptive_data_items^ [5] := statistic_data.origin_queue_file_transfer^.system_job_name;
      descriptive_data_items^ [6] := statistic_data.origin_queue_file_transfer^.user_job_name;
      descriptive_data_items^ [7] := statistic_data.origin_queue_file_transfer^.origin_mainframe_name;
      descriptive_data_items^ [8] := statistic_data.origin_queue_file_transfer^.dest_mainframe_name;

      build_descriptive_data (descriptive_data_items^, descriptive_data, descriptive_data_size);

    = jmc$ca_dest_qf_transfer =

{ Build the avc$ca_dest_qf_transfer statistic.


      PUSH counters: [1 .. 1];
      PUSH descriptive_data_items: [1 .. 8];

      CASE statistic_data.dest_queue_file_transfer^.kind OF
      = jmc$input_file =
        qtf_input_device.string_value := statistic_data.dest_queue_file_transfer^.job_input_device.
              text (1, statistic_data.dest_queue_file_transfer^.job_input_device.size);
        job_system_label_p := statistic_data.dest_queue_file_transfer^.job_system_label_p;

        counters^ [1] := qtf_input_device.data.file_size;

        pmp$get_account_project (account, project, ignore_status);

        descriptive_data_items^ [1] := job_system_label_p^.login_user_identification.family;
        descriptive_data_items^ [2] := job_system_label_p^.login_user_identification.user;
        descriptive_data_items^ [3] := account;
        descriptive_data_items^ [4] := project;
        descriptive_data_items^ [5] := job_system_label_p^.system_job_name;
        descriptive_data_items^ [6] := job_system_label_p^.user_job_name;
        descriptive_data_items^ [7] := qtf_input_device.data.origin_mainframe_name;
        descriptive_data_items^ [8] := qtf_input_device.data.dest_mainframe_name;

      ELSE {jmc$output_file

        PUSH output_system_label_p;
        qfp$read_output_system_label (statistic_data.dest_queue_file_transfer^.output_file_name,
              output_system_label_p^, local_status);
        IF local_status.normal THEN
          counters^ [1] := output_system_label_p^.file_size;

          descriptive_data_items^ [1] := output_system_label_p^.login_user_identification.family;
          descriptive_data_items^ [2] := output_system_label_p^.login_user_identification.user;
          descriptive_data_items^ [3] := output_system_label_p^.login_account;
          descriptive_data_items^ [4] := output_system_label_p^.login_project;
          descriptive_data_items^ [5] := output_system_label_p^.system_job_name;
          descriptive_data_items^ [6] := output_system_label_p^.user_file_name;
          descriptive_data_items^ [7] := statistic_data.dest_queue_file_transfer^.data.origin_mainframe_name;
          descriptive_data_items^ [8] := statistic_data.dest_queue_file_transfer^.data.dest_mainframe_name;

        ELSE {NOT status.normal.  This implies that the output file is from a non-NOS/VE system.

          counters^ [1] := statistic_data.dest_queue_file_transfer^.data.file_size;

          descriptive_data_items^ [1] := statistic_data.dest_queue_file_transfer^.data.user_identification.
                family;
          descriptive_data_items^ [2] := statistic_data.dest_queue_file_transfer^.data.user_identification.
                user;
          descriptive_data_items^ [3] := statistic_data.dest_queue_file_transfer^.data.account_name;
          descriptive_data_items^ [4] := statistic_data.dest_queue_file_transfer^.data.project_name;
          descriptive_data_items^ [5] := statistic_data.dest_queue_file_transfer^.data.system_job_name;
          descriptive_data_items^ [6] := statistic_data.dest_queue_file_transfer^.data.user_job_name;
          descriptive_data_items^ [7] := statistic_data.dest_queue_file_transfer^.data.origin_mainframe_name;
          descriptive_data_items^ [8] := statistic_data.dest_queue_file_transfer^.data.dest_mainframe_name;
        IFEND;

      CASEND;

      build_descriptive_data (descriptive_data_items^, descriptive_data, descriptive_data_size);

    = jmc$ca_interactive_interval =

      IF jmv$job_attributes.originating_application_name <> osc$timesharing THEN
        #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
        RETURN;
      IFEND;

{ Build the avc$ca_interactive_interval statistic.

{ Set up the counters for statistic.

      PUSH counters: [1 .. 3];

      iip$st_get_input_output_counts (bytes_transferred_in, bytes_transferred_out, local_status);
      IF NOT local_status.normal THEN
        osp$generate_log_message (logset, local_status, ignore_status);
        #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
        RETURN;
      IFEND;

      nap$get_connect_time_interval (osc$timesharing_terminal_file, connect_time, local_status);
      IF NOT local_status.normal THEN
        osp$generate_log_message (logset, local_status, ignore_status);
        #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
        RETURN;
      IFEND;

      counters^ [1] := bytes_transferred_in;
      counters^ [2] := bytes_transferred_out;

{ Connect time is in microseconds.  Round it to seconds.

      counters^ [3] := connect_time DIV 1000000;
      IF (connect_time MOD 1000000) > 500000 THEN
        counters^ [3] := counters^ [3] + 1;
      IFEND;

{ Get the accounting data.  If the connection is an X.25 connection nap$parse_accounting_data will
{ return the trunk name and trunk subtype.  Otherwise the line name and line subtype will be returned.

      PUSH get_accounting_data: [1 .. 7];
      get_accounting_data^ [1].kind := nac$ca_di_system_name;
      get_accounting_data^ [2].kind := nac$ca_line_name;
      get_accounting_data^ [3].kind := nac$ca_trunk_name;
      get_accounting_data^ [4].kind := nac$ca_line_subtype;
      get_accounting_data^ [5].kind := nac$ca_trunk_subtype;
      get_accounting_data^ [6].kind := nac$ca_line_speed;
      get_accounting_data^ [7].kind := nac$ca_device_name;

      PUSH peer_accounting_information: [jmv$job_attributes.job_input_device.size];
      peer_accounting_information^ := jmv$job_attributes.job_input_device.text;
      nap$parse_accounting_data (peer_accounting_information, NIL, get_accounting_data, local_status);
      IF NOT local_status.normal THEN
        osp$generate_log_message (logset, local_status, ignore_status);
        #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
        RETURN;
      IFEND;

{ Set up the descriptive_data for the statistic using the elements of the get_accounting_data array.

      PUSH descriptive_data_items: [1 .. 5];

      IF get_accounting_data^ [1].kind = nac$ca_di_system_name THEN
        descriptive_data_items^ [1] := get_accounting_data^ [1].di_system_name;
      ELSE
        descriptive_data_items^ [1] := ' ';
      IFEND;

      IF get_accounting_data^ [2].kind = nac$ca_line_name THEN
        descriptive_data_items^ [2] := get_accounting_data^ [2].line_name;
      ELSEIF get_accounting_data^ [3].kind = nac$ca_trunk_name THEN
        descriptive_data_items^ [2] := get_accounting_data^ [3].trunk_name;
      ELSE
        descriptive_data_items^ [2] := ' ';
      IFEND;

      IF get_accounting_data^ [4].kind = nac$ca_line_subtype THEN
        descriptive_data_items^ [3] := get_accounting_data^ [4].line_subtype;
      ELSEIF get_accounting_data^ [5].kind = nac$ca_trunk_subtype THEN
        descriptive_data_items^ [3] := get_accounting_data^ [5].trunk_subtype;
      ELSE
        descriptive_data_items^ [3] := ' ';
      IFEND;

      IF get_accounting_data^ [6].kind = nac$ca_line_speed THEN
        clp$convert_integer_to_string (get_accounting_data^ [6].line_speed, 10, FALSE, line_speed_string,
              ignore_status);
        descriptive_data_items^ [4] := line_speed_string.value (1, line_speed_string.size);
      ELSE
        descriptive_data_items^ [4] := ' ';
      IFEND;

      IF get_accounting_data^ [7].kind = nac$ca_device_name THEN
        descriptive_data_items^ [5] := get_accounting_data^ [7].device_name;
      ELSE
        descriptive_data_items^ [5] := ' ';
      IFEND;

      build_descriptive_data (descriptive_data_items^, descriptive_data, descriptive_data_size);

    = jmc$ca_ftp_client_ctrl_connect, jmc$ca_ftp_server_ctrl_connect =

{ Build the avc$ca_ftp_client_ctrl_connect or avc$ca_ftp_server_ctrl_connect statistic.

{ Set up the counters for statistic.

      PUSH counters: [1 .. 3];

      counters^ [1] := statistic_data.ftp_statistics^.bytes_sent;
      counters^ [2] := statistic_data.ftp_statistics^.bytes_received;
      counters^ [3] := statistic_data.ftp_statistics^.connect_time;

{ Set up the descriptive_data for the statistic.

      PUSH descriptive_data_items: [1 .. 4];
      descriptive_data_items^ [1] := statistic_data.ftp_statistics^.requesting_mainframe_address;
      descriptive_data_items^ [2] := statistic_data.ftp_statistics^.requesting_port_number;
      descriptive_data_items^ [3] := statistic_data.ftp_statistics^.target_mainframe_address;
      descriptive_data_items^ [4] := statistic_data.ftp_statistics^.target_port_number;

      build_descriptive_data (descriptive_data_items^, descriptive_data, descriptive_data_size);

    = jmc$ca_ftp_client_data_connect, jmc$ca_ftp_server_data_connect =

{ Build the avc$ca_ftp_client_data_connect or avc$ca_ftp_server_data_connect statistic.

{ Set up the counters for statistic.

      PUSH counters: [1 .. 2];

      counters^ [1] := statistic_data.ftp_statistics^.file_size;
      counters^ [2] := statistic_data.ftp_statistics^.connect_time;

{ Set up the descriptive_data for the statistic.

      PUSH descriptive_data_items: [1 .. 6];
      descriptive_data_items^ [1] := statistic_data.ftp_statistics^.requesting_mainframe_address;
      descriptive_data_items^ [2] := statistic_data.ftp_statistics^.requesting_port_number;
      descriptive_data_items^ [3] := statistic_data.ftp_statistics^.target_mainframe_address;
      descriptive_data_items^ [4] := statistic_data.ftp_statistics^.target_port_number;
      descriptive_data_items^ [5] := statistic_data.ftp_statistics^.command;
      descriptive_data_items^ [6] := statistic_data.ftp_statistics^.successful;

      build_descriptive_data (descriptive_data_items^, descriptive_data, descriptive_data_size);

    ELSE

      #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);
      RETURN;
    CASEND;

    sfp$emit_statistic (statistic_identifier_map [statistic_data.statistic_id],
          descriptive_data (1, descriptive_data_size), counters, local_status);
    IF NOT local_status.normal THEN
      osp$generate_log_message (logset, local_status, ignore_status);
    IFEND;

    #KEYPOINT (osk$exit, 0, jmk$emit_communication_stat);

  PROCEND jmp$emit_communication_stat;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$emit_job_history_statistics', EJECT ??
*copy jmh$emit_job_history_statistics

  PROCEDURE [XDCL] jmp$emit_job_history_statistics
    (    statistic_code: sft$statistic_code;
         disposition: ost$name;
         system_job_name: jmt$system_supplied_name;
         system_file_name: jmt$system_supplied_name;
         system_label_p: ^jmt$job_system_label;
         output_system_label_p: ^jmt$output_system_label;
         reason: ost$name;
         parent_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      data_size: 1 .. osc$max_string_size,
      ignore_status: ost$status,
      logset: pmt$ascii_logset,
      statistic_data: string (osc$max_string_size);

    status.normal := TRUE;
    logset := $pmt$ascii_logset [pmc$system_log, pmc$job_log];
    data_size := 1;

    CASE statistic_code OF
    = jml$job_queuing_started =

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_job_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, osc$max_name_size) := system_label_p^.user_job_name (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := system_label_p^.login_user_identification.
            family (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := system_label_p^.login_user_identification.
            user (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := system_label_p^.job_attributes.job_controller.
            family (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := system_label_p^.job_attributes.job_controller.
            user (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := system_label_p^.job_attributes.
            station (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := reason (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            parent_job_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size - 1;

    = jml$job_queuing_aborted =

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_job_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, osc$max_name_size) := reason (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size - 1;

    = jml$job_file_deleted =

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_job_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, osc$max_name_size) := reason (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size - 1;

    = jml$output_queuing_started =

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_job_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, osc$max_name_size) := output_system_label_p^.login_user_identification.
            family (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := output_system_label_p^.login_user_identification.
            user (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_file_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, osc$max_name_size) := output_system_label_p^.output_controller.
            family (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := output_system_label_p^.output_controller.
            user (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := output_system_label_p^.station (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := reason (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size - 1;

    = jml$output_queuing_aborted =

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_job_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_file_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, osc$max_name_size) := reason (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size - 1;

    = jml$output_file_deleted =

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_job_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_file_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, osc$max_name_size) := reason (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size - 1;

    = jml$job_forwarding_started =

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_job_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size - 1;

    = jml$output_forwarding_started =

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_job_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_file_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

{ The application_name has been passed in as the parameter "reason", in order
{ to avoid adding yet another parameter to this request.

      statistic_data (data_size, osc$max_name_size) := reason;
      data_size := data_size + osc$max_name_size - 1;

    = jml$job_initiated =

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_job_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size - 1;

    = jml$job_terminated =

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_job_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_file_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, osc$max_name_size) := disposition (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := reason (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size - 1;

    = jml$print_plot_initiated =

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_job_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_file_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

{ The application_name has been passed in as the parameter "reason", in order
{ to avoid adding yet another parameter to this request.

      statistic_data (data_size, osc$max_name_size) := reason;
      data_size := data_size + osc$max_name_size - 1;

    = jml$print_plot_terminated =

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_job_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_file_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size - 1;

{ Early versions of ERS ARH6850 stated that the print_plot_terminated
{ statistic should have a reason field. Keep this in mind for future rework.

    = jml$submit_job_executed =

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_job_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, osc$max_name_size) := system_label_p^.
            job_destination_family (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := system_label_p^.
            job_destination_usage (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := system_label_p^.user_job_name (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size - 1;

    = jml$print_plot_file_executed =

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_job_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_file_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, osc$max_name_size) := output_system_label_p^.
            output_destination (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := output_system_label_p^.
            output_destination_usage (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := output_system_label_p^.
            user_file_name (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size - 1;

    = jml$non_recovery_of_job =

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_job_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, osc$max_name_size) := reason (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size - 1;

    = jml$change_output_attributes =

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_job_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, jmc$system_supplied_name_size) :=
            system_file_name (1, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      statistic_data (data_size, osc$max_name_size) := output_system_label_p^.output_controller.
            family (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := output_system_label_p^.output_controller.
            user (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := output_system_label_p^.
            output_destination (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := output_system_label_p^.
            output_destination_usage (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      statistic_data (data_size, osc$max_name_size) := output_system_label_p^.station (1, osc$max_name_size);
      data_size := data_size + osc$max_name_size - 1;

    ELSE
      ;
    CASEND;

    sfp$emit_statistic (statistic_code, statistic_data (1, data_size), NIL, status);
    IF NOT status.normal THEN
      osp$generate_log_message (logset, status, ignore_status);
    IFEND;
  PROCEND jmp$emit_job_history_statistics;
?? OLDTITLE ??

MODEND jmm$logging_interfaces;
*DECK DECK=JMM$MAINFRAME_GET_LEVELING_DATA EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Management : Interactive Load Leveling' ??
MODULE jmm$mainframe_get_leveling_data;

{ PURPOSE:
{   This module contains a procedure that is called on each mainframe in a
{   cluster via remote procedure call.  The procedure collects data and
{   returns it to the caller.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
?? POP ??
*copyc jmp$get_active_scheduling_attr
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$mainframe_get_leveling_data', EJECT ??
*copy jmh$mainframe_get_leveling_data

  PROCEDURE [XDCL] jmp$mainframe_get_leveling_data
    (    send_data_p: ^SEQ ( * );
     VAR work_area_p: ^jmt$work_area;
     VAR status: ost$status);

    VAR
      copy_send_data_p: ^SEQ ( * ),
      job_class_name_p: ^ost$name,
      number_of_keys_p: ^ost$non_negative_integers,
      scheduling_attr_results_p: ^jmt$scheduling_attr_results,
      scheduling_results_keys_p: ^jmt$scheduling_results_keys;


    status.normal := TRUE;

    copy_send_data_p := send_data_p;
    RESET copy_send_data_p;
    NEXT job_class_name_p IN copy_send_data_p;
    NEXT number_of_keys_p IN copy_send_data_p;
    NEXT scheduling_results_keys_p: [1 .. number_of_keys_p^] IN
          copy_send_data_p;

    jmp$get_active_scheduling_attr (job_class_name_p^,
          scheduling_results_keys_p, work_area_p, scheduling_attr_results_p,
          status);

  PROCEND jmp$mainframe_get_leveling_data;
?? OLDTITLE ??

MODEND jmm$mainframe_get_leveling_data;
*DECK DECK=JMM$MANAGE_ACTIVE_SCHEDULING EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Scheduling : manage_active_scheduling' ??
MODULE jmm$manage_active_scheduling;

{ PURPOSE:
{   This module contains the routines forming the MANAGE_ACTIVE_SCHEDULING
{   utility.  This utility allows the site scheduling administrator to
{   make various changes to the behaviour of the scheduling.  In general
{   they are allowed to change anything that does not change the structure
{   of scheduling (add or delete classes, change membership of jobs to
{   classes).  Structural changes can only be done through the activate
{   profile command by activating a previously created profile built by
{   the ADMINISTER_SCHEDULING utility.
{
{ DESIGN:
{   Provides basically a framework for the utility and its subcommands.
{   The PDTs and command tables are defined here.  When the utility
{   is called, it sets a utility flag and recovers the active profile.
{   All changes made in the utility are kept local until the utility is
{   exited when the administrator decides via a parameter on the quit
{   command if the changes should be made permanent.  If so, the
{   system tables are updated and the file rewritten.
{
{ NOTES:
{   See JMM$LOAD_SYSTEM_PROFILE, JMM$ADMINISTER_OBJECTS, JMM$ADMINISTER_DISPLAY

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$job_management_id
*copyc jme$activate_profile_errors
*copyc jmk$keypoints
*copyc jmt$application_attributes
*copyc jmt$job_class_attributes
*copyc jmt$job_scheduler_table
*copyc jmt$output_class_attributes
*copyc jmt$service_class_attributes
?? POP ??
*copyc clp$begin_utility
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$include_file
*copyc clp$evaluate_parameters
*copyc jmp$activate_system_profile
*copyc jmp$build_category_object
*copyc jmp$build_default_profile
*copyc jmp$build_profile_from_system
*copyc jmp$change_object
*copyc jmp$clear_utility_active
*copyc jmp$display_profile_changes
*copyc jmp$get_attributes
*copyc jmp$get_object_list
*copyc jmp$recover_profile
*copyc jmp$set_profile
*copyc jmp$update_system_profile
*copyc jmp$update_object_statistics
*copyc jmp$write_profile
*copyc osp$generate_message
*copyc osp$get_status_severity
*copyc osp$set_status_abnormal
*copyc pmp$disestablish_end_handler
*copyc pmp$get_mainframe_id
*copyc pmp$establish_end_handler

*copyc jmv$current_profile_level
*copyc jmv$modify_display_attributes
*copyc jmv$new_profile
*copyc jmv$object_definition
*copyc jmv$the_profile
*copyc jmv$utility_functions
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    milliseconds_per_second = 1000,
    microseconds_per_millisecond = 1000,
    microseconds_per_second = milliseconds_per_second *
          microseconds_per_millisecond;

  CONST
    lowest_idle_disp_q_time = jmc$lowest_idle_disp_q_time DIV
          microseconds_per_second,
    highest_idle_disp_q_time = jmc$highest_idle_disp_q_time DIV
          microseconds_per_second,
    lowest_service_limit = jmc$lowest_service_limit DIV
          microseconds_per_millisecond,
    highest_service_limit = jmc$highest_service_limit DIV
          microseconds_per_millisecond,
    lowest_prio_age_interval = jmc$lowest_prio_age_interval DIV
          microseconds_per_second,
    highest_prio_age_interval = jmc$highest_prio_age_interval DIV
          microseconds_per_second;

  VAR
    result_file: amt$local_file_name := 'SCHEDULING_PROFILE',
    command_file: amt$local_file_name := clc$current_command_input,
    utility_name: string (31) := 'MANAGE_ACTIVE_SCHEDULING       ',
    utility_attributes: array [1 .. 3] of clt$utility_attribute :=
          [[clc$utility_command_table, * ], [clc$utility_function_proc_table, *
          ], [clc$utility_prompt, [3, 'MAS']]];

{ table command_table
{ command (add_job_category_entry add_job_category_entries addjce) ..
{   jmp$_add_job_category_entry
{ command (delete_job_category_entry delete_job_category_entries deljce) ..
{   jmp$_delete_job_category_entry
{ command (activate_profile, actp) jmp$_activate_profile
{ command (write_profile, wrip) jmp$_write_profile
{ command (change_list_option, change_list_options, chalo) ..
{   jmp$_change_list_option cm=xref
{ command (display_job_category, display_job_categories, disjc, disjca) ..
{   jmp$_display_job_category cm=xref
{ command (display_application, display_applications, disa) ..
{   jmp$_display_application cm=xref
{ command (display_controls, disc) jmp$_display_controls cm=xref
{ command (display_job_class, display_job_classes, disjcl) ..
{   jmp$_display_job_class cm=xref
{ command (display_service_class, display_service_classes, dissc) ..
{   jmp$_display_service_class cm=xref
{ command (display_output_class, display_output_classes, disoc) ..
{   jmp$_display_output_class cm=xref a=hidden
{ command (display_profile_summary, disps) jmp$_display_profile_summary ..
{   a=hidden cm=xref
{ command (change_controls, chac) jmp$_change_controls
{ command (change_application, chaa) jmp$_change_application
{ command (change_job_class, chajc, chajcl) jmp$_change_job_class
{ command (change_service_class, chasc) jmp$_change_service_class
{ command (change_output_class, chaoc) jmp$_change_output_class a=hidden
{ command (read_system_tables, reast) jmp$_read_system_tables a=hidden
{ command (quit, qui), jmp$_quit
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    command_table: [STATIC, READ] ^clt$command_table := ^command_table_entries,

    command_table_entries: [STATIC, READ] array [1 .. 48] of
          clt$command_table_entry := [
          {} ['ACTIVATE_PROFILE               ', clc$nominal_entry,
          clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_activate_profile],
          {} ['ACTP                           ', clc$abbreviation_entry,
          clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
          ^jmp$_activate_profile],
          {} ['ADDJCE                         ', clc$abbreviation_entry,
          clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
          ^jmp$_add_job_category_entry],
          {} ['ADD_JOB_CATEGORY_ENTRIES       ', clc$alias_entry,
          clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
          ^jmp$_add_job_category_entry],
          {} ['ADD_JOB_CATEGORY_ENTRY         ', clc$nominal_entry,
          clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
          ^jmp$_add_job_category_entry],
          {} ['CHAA                           ', clc$abbreviation_entry,
          clc$normal_usage_entry, 14, clc$automatically_log, clc$linked_call,
          ^jmp$_change_application],
          {} ['CHAC                           ', clc$abbreviation_entry,
          clc$normal_usage_entry, 13, clc$automatically_log, clc$linked_call,
          ^jmp$_change_controls],
          {} ['CHAJC                          ', clc$alias_entry,
          clc$normal_usage_entry, 15, clc$automatically_log, clc$linked_call,
          ^jmp$_change_job_class],
          {} ['CHAJCL                         ', clc$abbreviation_entry,
          clc$normal_usage_entry, 15, clc$automatically_log, clc$linked_call,
          ^jmp$_change_job_class],
          {} ['CHALO                          ', clc$abbreviation_entry,
          clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
          ^jmp$_change_list_option],
          {} ['CHANGE_APPLICATION             ', clc$nominal_entry,
          clc$normal_usage_entry, 14, clc$automatically_log, clc$linked_call,
          ^jmp$_change_application],
          {} ['CHANGE_CONTROLS                ', clc$nominal_entry,
          clc$normal_usage_entry, 13, clc$automatically_log, clc$linked_call,
          ^jmp$_change_controls],
          {} ['CHANGE_JOB_CLASS               ', clc$nominal_entry,
          clc$normal_usage_entry, 15, clc$automatically_log, clc$linked_call,
          ^jmp$_change_job_class],
          {} ['CHANGE_LIST_OPTION             ', clc$nominal_entry,
          clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
          ^jmp$_change_list_option],
          {} ['CHANGE_LIST_OPTIONS            ', clc$alias_entry,
          clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
          ^jmp$_change_list_option],
          {} ['CHANGE_OUTPUT_CLASS            ', clc$nominal_entry,
          clc$hidden_entry, 17, clc$automatically_log, clc$linked_call,
          ^jmp$_change_output_class],
          {} ['CHANGE_SERVICE_CLASS           ', clc$nominal_entry,
          clc$normal_usage_entry, 16, clc$automatically_log, clc$linked_call,
          ^jmp$_change_service_class],
          {} ['CHAOC                          ', clc$abbreviation_entry,
          clc$hidden_entry, 17, clc$automatically_log, clc$linked_call,
          ^jmp$_change_output_class],
          {} ['CHASC                          ', clc$abbreviation_entry,
          clc$normal_usage_entry, 16, clc$automatically_log, clc$linked_call,
          ^jmp$_change_service_class],
          {} ['DELETE_JOB_CATEGORY_ENTRIES    ', clc$alias_entry,
          clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_job_category_entry],
          {} ['DELETE_JOB_CATEGORY_ENTRY      ', clc$nominal_entry,
          clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_job_category_entry],
          {} ['DELJCE                         ', clc$abbreviation_entry,
          clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
          ^jmp$_delete_job_category_entry],
          {} ['DISA                           ', clc$abbreviation_entry,
          clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
          ^jmp$_display_application],
          {} ['DISC                           ', clc$abbreviation_entry,
          clc$normal_usage_entry, 8, clc$automatically_log, clc$linked_call,
          ^jmp$_display_controls],
          {} ['DISJC                          ', clc$alias_entry,
          clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
          ^jmp$_display_job_category],
          {} ['DISJCA                         ', clc$abbreviation_entry,
          clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
          ^jmp$_display_job_category],
          {} ['DISJCL                         ', clc$abbreviation_entry,
          clc$normal_usage_entry, 9, clc$automatically_log, clc$linked_call,
          ^jmp$_display_job_class],
          {} ['DISOC                          ', clc$abbreviation_entry,
          clc$hidden_entry, 11, clc$automatically_log, clc$linked_call,
          ^jmp$_display_output_class],
          {} ['DISPLAY_APPLICATION            ', clc$nominal_entry,
          clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
          ^jmp$_display_application],
          {} ['DISPLAY_APPLICATIONS           ', clc$alias_entry,
          clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
          ^jmp$_display_application],
          {} ['DISPLAY_CONTROLS               ', clc$nominal_entry,
          clc$normal_usage_entry, 8, clc$automatically_log, clc$linked_call,
          ^jmp$_display_controls],
          {} ['DISPLAY_JOB_CATEGORIES         ', clc$alias_entry,
          clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
          ^jmp$_display_job_category],
          {} ['DISPLAY_JOB_CATEGORY           ', clc$nominal_entry,
          clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
          ^jmp$_display_job_category],
          {} ['DISPLAY_JOB_CLASS              ', clc$nominal_entry,
          clc$normal_usage_entry, 9, clc$automatically_log, clc$linked_call,
          ^jmp$_display_job_class],
          {} ['DISPLAY_JOB_CLASSES            ', clc$alias_entry,
          clc$normal_usage_entry, 9, clc$automatically_log, clc$linked_call,
          ^jmp$_display_job_class],
          {} ['DISPLAY_OUTPUT_CLASS           ', clc$nominal_entry,
          clc$hidden_entry, 11, clc$automatically_log, clc$linked_call,
          ^jmp$_display_output_class],
          {} ['DISPLAY_OUTPUT_CLASSES         ', clc$alias_entry,
          clc$hidden_entry, 11, clc$automatically_log, clc$linked_call,
          ^jmp$_display_output_class],
          {} ['DISPLAY_PROFILE_SUMMARY        ', clc$nominal_entry,
          clc$hidden_entry, 12, clc$automatically_log, clc$linked_call,
          ^jmp$_display_profile_summary],
          {} ['DISPLAY_SERVICE_CLASS          ', clc$nominal_entry,
          clc$normal_usage_entry, 10, clc$automatically_log, clc$linked_call,
          ^jmp$_display_service_class],
          {} ['DISPLAY_SERVICE_CLASSES        ', clc$alias_entry,
          clc$normal_usage_entry, 10, clc$automatically_log, clc$linked_call,
          ^jmp$_display_service_class],
          {} ['DISPS                          ', clc$abbreviation_entry,
          clc$hidden_entry, 12, clc$automatically_log, clc$linked_call,
          ^jmp$_display_profile_summary],
          {} ['DISSC                          ', clc$abbreviation_entry,
          clc$normal_usage_entry, 10, clc$automatically_log, clc$linked_call,
          ^jmp$_display_service_class],
          {} ['QUI                            ', clc$abbreviation_entry,
          clc$normal_usage_entry, 19, clc$automatically_log, clc$linked_call,
          ^jmp$_quit],
          {} ['QUIT                           ', clc$nominal_entry,
          clc$normal_usage_entry, 19, clc$automatically_log, clc$linked_call,
          ^jmp$_quit],
          {} ['READ_SYSTEM_TABLES             ', clc$nominal_entry,
          clc$hidden_entry, 18, clc$automatically_log, clc$linked_call,
          ^jmp$_read_system_tables],
          {} ['REAST                          ', clc$abbreviation_entry,
          clc$hidden_entry, 18, clc$automatically_log, clc$linked_call,
          ^jmp$_read_system_tables],
          {} ['WRIP                           ', clc$abbreviation_entry,
          clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
          ^jmp$_write_profile],
          {} ['WRITE_PROFILE                  ', clc$nominal_entry,
          clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
          ^jmp$_write_profile]];

  PROCEDURE [XREF] jmp$_change_list_option
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] jmp$_display_application
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] jmp$_display_controls
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] jmp$_display_job_category
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] jmp$_display_job_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] jmp$_display_output_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] jmp$_display_profile_summary
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] jmp$_display_service_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??

  VAR
    profile_access_id: ost$binary_unique_name;

  VAR
    prevent_profile_file_update: boolean := FALSE;

  VAR
    current_controls: clt$data_value;

?? OLDTITLE ??
?? NEWTITLE := 'jmp$_add_job_category_entry', EJECT ??

{ PURPOSE:
{   Processes the ADD_JOB_CATEGORY_ENTRY command.
{
{ DESIGN:
{   Determines the attributes to update, fetches the categories to add
{   and makes a request to add them to the attributes.

  PROCEDURE jmp$_add_job_category_entry
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_addjce) add_job_category_entry (
{   initiation_excluded_categories, iec: (by_name) any of
{       key all keyend
{       list of name
{     anyend = $optional
{   initiation_required_categories, irc: (by_name) any of
{       key all keyend
{       list of name
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type2: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 55, 42, 912], clc$command, 5, 3, 0, 0, 0,
            0, 3, 'OSM$MANAS_ADDJCE'], [['IEC                            ',
            clc$abbreviation_entry, 1], ['INITIATION_EXCLUDED_CATEGORIES ',
            clc$nominal_entry, 1], ['INITIATION_REQUIRED_CATEGORIES ',
            clc$nominal_entry, 2], ['IRC                            ',
            clc$abbreviation_entry, 2], ['STATUS                         ',
            clc$nominal_entry, 3]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 2

      [[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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$initiation_excluded_categorie = 1 {INITIATION_EXCLUDED_CATEGORIES} ,
      p$initiation_required_categorie = 2 {INITIATION_REQUIRED_CATEGORIES} ,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      values: jmt$object_attribute;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$get_attributes (jmc$profile_controls, #SEQ (pdt),
          ^pvt, values, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$change_object (jmc$profile_controls, current_controls, values,
          jmc$add_list_items, status);

  PROCEND jmp$_add_job_category_entry;
?? TITLE := 'jmp$_activate_profile', EJECT ??

{ PURPOSE:
{   This interface does the processing for the ACTIVATE_PROFILE command.
{
{ NOTES:
{   See JMM$UPDATE_SYSTEM_TABLES

  PROCEDURE jmp$_activate_profile
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_actp) activate_profile (
{   profile, p: file = $user.scheduling_profile
{   enable_job_reclassification, ejr: boolean = false
{   output, o: file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          default_value: string (24),
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (5),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 56, 9, 699], clc$command, 7, 4, 0, 0, 0,
            0, 4, 'OSM$MANAS_ACTP'], [['EJR                            ',
            clc$abbreviation_entry, 2], ['ENABLE_JOB_RECLASSIFICATION    ',
            clc$nominal_entry, 2], ['O                              ',
            clc$abbreviation_entry, 3], ['OUTPUT                         ',
            clc$nominal_entry, 3], ['P                              ',
            clc$abbreviation_entry, 1], ['PROFILE                        ',
            clc$nominal_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 4]], [

{ PARAMETER 1

      [6, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_default_parameter, 0, 24],

{ PARAMETER 2

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_default_parameter, 0, 5],

{ PARAMETER 3

      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [7, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type], '$user.scheduling_profile'],

{ PARAMETER 2

      [[1, 0, clc$boolean_type], 'false'],

{ PARAMETER 3

      [[1, 0, clc$file_type]],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$profile = 1,
      p$enable_job_reclassification = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      profile_changes: jmt$profile_changes;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$activate_system_profile (profile_access_id,
          pvt [p$profile].value^.file_value^,
          pvt [p$enable_job_reclassification].value^.boolean_value.value,
          profile_changes, status);
    IF status.normal THEN
      jmp$display_profile_changes (profile_changes, pvt [p$output], status);
      prevent_profile_file_update := FALSE;
    IFEND;

  PROCEND jmp$_activate_profile;
?? TITLE := 'jmp$_change_application', EJECT ??

{ PURPOSE:
{   Processes the CHANGE_APPLICATION command.
{
{ DESIGN:
{   Determines the applications to update, fetches the changed attributes
{   and makes a request to change them.

  PROCEDURE jmp$_change_application
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_chaa) change_application (
{   application_name, application_names, an: any of
{       key all keyend
{       list of name
{     anyend = $current_application
{   cyclic_aging_interval, cai: (by_name) any of
{       key default, unspecified keyend
{       integer jmc$lowest_aging_interval..jmc$highest_aging_interval
{     anyend = $optional
{   enable_application_scheduling, eas: (by_name) any of
{       key default keyend
{       boolean
{     anyend = $optional
{   maximum_working_set, maxws: (by_name) any of
{       key default, unlimited, unspecified keyend
{       integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{     anyend = $optional
{   minimum_working_set, minws: (by_name) any of
{       key default, unspecified keyend
{       integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{     anyend = $optional
{   page_aging_interval, pai: (by_name) any of
{       key default, unspecified keyend
{       integer jmc$lowest_aging_interval..jmc$highest_aging_interval
{     anyend = $optional
{   service_class, sc: (by_name) any of
{       key default, unspecified keyend
{       name
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 16] of clt$pdt_parameter_name,
        parameters: array [1 .. 8] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (20),
        recend,
        type2: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type3: 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,
          recend,
        recend,
        type4: 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 .. 3] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type5: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type6: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type7: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type8: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 57, 7, 661], clc$command, 16, 8, 0, 0, 0,
            0, 8, 'OSM$MANAS_CHAA'], [['AN                             ',
            clc$abbreviation_entry, 1], ['APPLICATION_NAME               ',
            clc$nominal_entry, 1], ['APPLICATION_NAMES              ',
            clc$alias_entry, 1], ['CAI                            ',
            clc$abbreviation_entry, 2], ['CYCLIC_AGING_INTERVAL          ',
            clc$nominal_entry, 2], ['EAS                            ',
            clc$abbreviation_entry, 3], ['ENABLE_APPLICATION_SCHEDULING  ',
            clc$nominal_entry, 3], ['MAXIMUM_WORKING_SET            ',
            clc$nominal_entry, 4], ['MAXWS                          ',
            clc$abbreviation_entry, 4], ['MINIMUM_WORKING_SET            ',
            clc$nominal_entry, 5], ['MINWS                          ',
            clc$abbreviation_entry, 5], ['PAGE_AGING_INTERVAL            ',
            clc$nominal_entry, 6], ['PAI                            ',
            clc$abbreviation_entry, 6], ['SC                             ',
            clc$abbreviation_entry, 7], ['SERVICE_CLASS                  ',
            clc$nominal_entry, 7], ['STATUS                         ',
            clc$nominal_entry, 8]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 20],

{ PARAMETER 2

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 121, clc$optional_parameter, 0,
            0],

{ PARAMETER 3

      [7, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [8, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 158, clc$optional_parameter, 0,
            0],

{ PARAMETER 5

      [10, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 121, clc$optional_parameter, 0,
            0],

{ PARAMETER 6

      [12, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 121, clc$optional_parameter, 0,
            0],

{ PARAMETER 7

      [15, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 106, clc$optional_parameter, 0,
            0],

{ PARAMETER 8

      [16, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            '$current_application'],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 81, [[1, 0, clc$keyword_type],
            [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNSPECIFIED                    ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
            jmc$highest_aging_interval, 10]]],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type], FALSE,
            2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 3, [[1, 0, clc$boolean_type]]],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 118, [[1, 0, clc$keyword_type],
            [3], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNLIMITED                      ',
            clc$nominal_entry, clc$normal_usage_entry, 2],
            ['UNSPECIFIED                    ', clc$nominal_entry,
            clc$normal_usage_entry, 3]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
            jmc$highest_working_set_size, 10]]],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 81, [[1, 0, clc$keyword_type],
            [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNSPECIFIED                    ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
            jmc$highest_working_set_size, 10]]],

{ PARAMETER 6

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 81, [[1, 0, clc$keyword_type],
            [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNSPECIFIED                    ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
            jmc$highest_aging_interval, 10]]],

{ PARAMETER 7

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2],
            81, [[1, 0, clc$keyword_type], [2],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNSPECIFIED                    ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 5,
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 8

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$application_name = 1,
      p$cyclic_aging_interval = 2,
      p$enable_application_scheduling = 3,
      p$maximum_working_set = 4,
      p$minimum_working_set = 5,
      p$page_aging_interval = 6,
      p$service_class = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    VAR
      values: jmt$object_attribute;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_application;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$get_attributes (jmc$profile_application, #SEQ (pdt), ^pvt, values,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$change_object (jmc$profile_application, pvt [p$application_name].
          value^, values, jmc$update, status);

  PROCEND jmp$_change_application;
?? TITLE := 'jmp$_change_controls', EJECT ??

{ PURPOSE:
{   Processes the CHANGE_CONTROLS command.
{
{ DESIGN:
{   Determines the controls to update, fetches the changed attributes
{   and makes a request to change them.

  PROCEDURE jmp$_change_controls
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_chac) change_controls (
{   cpu_dispatching_allocation, cda: (by_name) any of
{       key default keyend
{       list 1..8 of record
{         dispatching_priority: range of any of
{           integer 1..8
{           key p1 p2 p3 p4 p5 p6 p7 p8 keyend
{         anyend
{         minimum_percent: any of
{           key default keyend
{           integer 0..100
{         anyend = $optional
{         maximum_percent: any of
{           key default keyend
{           integer 0..100
{         anyend = $optional
{         enforce_maximum: any of
{           key default keyend
{           boolean
{         anyend = $optional
{       recend
{     anyend = $optional
{   cpu_dispatching_interval, cdi: (by_name) any of
{       key default keyend
{       integer 1..600
{     anyend = $optional
{   cpu_quantum_time, cqt: (by_name) any of
{       key default keyend
{       integer 1000..100000
{     anyend = $optional
{   dual_state_priority_control, dspc: (by_name) any of
{       key default keyend
{       list 1..10 of record
{         dispatching_priority: range of any of
{           integer 1..10
{           key p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 keyend
{         anyend
{         dual_state_priority: any of
{           key default keyend
{           integer 1..10
{         anyend = $optional
{         subpriority: any of
{           key default keyend
{           integer 1..15
{         anyend = $optional
{       recend
{     anyend = $optional
{   enable_job_leveling, ejl: (by_name) any of
{       key default keyend
{       boolean
{     anyend = $optional
{   idle_dispatching_queue_time, idqt: (by_name) any of
{       key default, unlimited keyend
{       integer lowest_idle_disp_q_time..highest_idle_disp_q_time
{     anyend = $optional
{   initiation_excluded_categories, iec: (by_name) any of
{       key default, all, none keyend
{       list of name
{     anyend = $optional
{   initiation_required_categories, irc: (by_name) any of
{       key default, all, none keyend
{       list of name
{     anyend = $optional
{   job_leveling_interval, jli: (by_name) any of
{       key default keyend
{       integer jmc$lowest_service_interval..jmc$highest_service_interval
{     anyend = $optional
{   job_leveling_priority_bias, jlpb: (by_name) any of
{       key default keyend
{       integer jmc$lowest_priority_bias..jmc$highest_priority_bias
{     anyend = $optional
{   scheduling_memory_levels, sml: (by_name) any of
{       key default keyend
{       record
{         target: any of
{           key default keyend
{         integer jmc$lowest_sched_memory_level..jmc$highest_sched_memory_level
{         anyend = $optional
{         thrashing: any of
{           key default keyend
{         integer jmc$lowest_sched_memory_level..jmc$highest_sched_memory_level
{         anyend = $optional
{       recend
{     anyend = $optional
{   service_calculation_interval, sci: (by_name) any of
{       key default keyend
{       integer jmc$lowest_service_interval..jmc$highest_service_interval
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 25] of clt$pdt_parameter_name,
        parameters: array [1 .. 13] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$record_type_qualifier,
              field_spec_1: clt$field_specification,
              element_type_spec_1: record
                header: clt$type_specification_header,
                qualifier: clt$range_type_qualifier,
                element_type_spec: 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$integer_type_qualifier,
                  recend,
                  type_size_2: clt$type_specification_size,
                  element_type_spec_2: record
                    header: clt$type_specification_header,
                    qualifier: clt$keyword_type_qualifier,
                    keyword_specs: array [1 .. 8] of clt$keyword_specification,
                  recend,
                recend,
              recend,
              field_spec_2: clt$field_specification,
              element_type_spec_2: 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$integer_type_qualifier,
                recend,
              recend,
              field_spec_3: clt$field_specification,
              element_type_spec_3: 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$integer_type_qualifier,
                recend,
              recend,
              field_spec_4: clt$field_specification,
              element_type_spec_4: 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,
                recend,
              recend,
            recend,
          recend,
        recend,
        type2: 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$integer_type_qualifier,
          recend,
        recend,
        type3: 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$integer_type_qualifier,
          recend,
        recend,
        type4: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$record_type_qualifier,
              field_spec_1: clt$field_specification,
              element_type_spec_1: record
                header: clt$type_specification_header,
                qualifier: clt$range_type_qualifier,
                element_type_spec: 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$integer_type_qualifier,
                  recend,
                  type_size_2: clt$type_specification_size,
                  element_type_spec_2: record
                    header: clt$type_specification_header,
                    qualifier: clt$keyword_type_qualifier,
                    keyword_specs: array [1 .. 10] of
                          clt$keyword_specification,
                  recend,
                recend,
              recend,
              field_spec_2: clt$field_specification,
              element_type_spec_2: 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$integer_type_qualifier,
                recend,
              recend,
              field_spec_3: clt$field_specification,
              element_type_spec_3: 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$integer_type_qualifier,
                recend,
              recend,
            recend,
          recend,
        recend,
        type5: 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,
          recend,
        recend,
        type6: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type7: 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 .. 3] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type8: 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 .. 3] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type9: 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$integer_type_qualifier,
          recend,
        recend,
        type10: 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$integer_type_qualifier,
          recend,
        recend,
        type11: 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$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: 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$integer_type_qualifier,
              recend,
            recend,
          recend,
        recend,
        type12: 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$integer_type_qualifier,
          recend,
        recend,
        type13: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 10, 58, 42, 247], clc$command, 25, 13, 0, 0,
            0, 0, 13, 'OSM$MANAS_CHAC'], [['CDA                            ',
            clc$abbreviation_entry, 1], ['CDI                            ',
            clc$abbreviation_entry, 2], ['CPU_DISPATCHING_ALLOCATION     ',
            clc$nominal_entry, 1], ['CPU_DISPATCHING_INTERVAL       ',
            clc$nominal_entry, 2], ['CPU_QUANTUM_TIME               ',
            clc$nominal_entry, 3], ['CQT                            ',
            clc$abbreviation_entry, 3], ['DSPC                           ',
            clc$abbreviation_entry, 4], ['DUAL_STATE_PRIORITY_CONTROL    ',
            clc$nominal_entry, 4], ['EJL                            ',
            clc$abbreviation_entry, 5], ['ENABLE_JOB_LEVELING            ',
            clc$nominal_entry, 5], ['IDLE_DISPATCHING_QUEUE_TIME    ',
            clc$nominal_entry, 6], ['IDQT                           ',
            clc$abbreviation_entry, 6], ['IEC                            ',
            clc$abbreviation_entry, 7], ['INITIATION_EXCLUDED_CATEGORIES ',
            clc$nominal_entry, 7], ['INITIATION_REQUIRED_CATEGORIES ',
            clc$nominal_entry, 8], ['IRC                            ',
            clc$abbreviation_entry, 8], ['JLI                            ',
            clc$abbreviation_entry, 9], ['JLPB                           ',
            clc$abbreviation_entry, 10], ['JOB_LEVELING_INTERVAL          ',
            clc$nominal_entry, 9], ['JOB_LEVELING_PRIORITY_BIAS     ',
            clc$nominal_entry, 10], ['SCHEDULING_MEMORY_LEVELS       ',
            clc$nominal_entry, 11], ['SCI                            ',
            clc$abbreviation_entry, 12], ['SERVICE_CALCULATION_INTERVAL   ',
            clc$nominal_entry, 12], ['SML                            ',
            clc$abbreviation_entry, 11], ['STATUS                         ',
            clc$nominal_entry, 13]], [

{ PARAMETER 1

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 816, clc$optional_parameter, 0,
            0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [8, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 787, clc$optional_parameter, 0,
            0],

{ PARAMETER 5

      [10, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [11, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 121, clc$optional_parameter, 0,
            0],

{ PARAMETER 7

      [14, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 159, clc$optional_parameter, 0,
            0],

{ PARAMETER 8

      [15, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 159, clc$optional_parameter, 0,
            0],

{ PARAMETER 9

      [19, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],

{ PARAMETER 10

      [20, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],

{ PARAMETER 11

      [21, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 311, clc$optional_parameter, 0,
            0],

{ PARAMETER 12

      [23, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],

{ PARAMETER 13

      [25, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2],
            44, [[1, 0, clc$keyword_type], [1],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 752,
            [[1, 0, clc$list_type], [736, 1, 8, FALSE],
            [[1, 0, clc$record_type], [4], ['DISPATCHING_PRIORITY           ',
            clc$required_field, 350], [[1, 0, clc$range_type],
            [343], [[1, 0, clc$union_type], [[clc$integer_type,
            clc$keyword_type], FALSE, 2], 20,
            [[1, 0, clc$integer_type], [1, 8, 10]], 303,
            [[1, 0, clc$keyword_type], [8], [['P1                             '
            , clc$nominal_entry, clc$normal_usage_entry, 1],
            ['P2                             ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['P3                             ',
            clc$nominal_entry, clc$normal_usage_entry, 3],
            ['P4                             ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['P5                             ',
            clc$nominal_entry, clc$normal_usage_entry, 5],
            ['P6                             ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['P7                             ',
            clc$nominal_entry, clc$normal_usage_entry, 7],
            ['P8                             ', clc$nominal_entry,
            clc$normal_usage_entry, 8]]]]], ['MINIMUM_PERCENT                ',
            clc$optional_field, 84], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        '
            , clc$nominal_entry, clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [0, 100, 10]]],
            ['MAXIMUM_PERCENT                ', clc$optional_field, 84],
            [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
            FALSE, 2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [0, 100, 10]]],
            ['ENFORCE_MAXIMUM                ', clc$optional_field, 67],
            [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type],
            FALSE, 2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 3, [[1, 0, clc$boolean_type]]]]]],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [1, 600, 10]]],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [1000, 100000, 10]]],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2],
            44, [[1, 0, clc$keyword_type], [1],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 723,
            [[1, 0, clc$list_type], [707, 1, 10, FALSE],
            [[1, 0, clc$record_type], [3], ['DISPATCHING_PRIORITY           ',
            clc$required_field, 424], [[1, 0, clc$range_type],
            [417], [[1, 0, clc$union_type], [[clc$integer_type,
            clc$keyword_type], FALSE, 2], 20,
            [[1, 0, clc$integer_type], [1, 10, 10]], 377,
            [[1, 0, clc$keyword_type], [10], [[
            'P1                             ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['P10                            ',
            clc$nominal_entry, clc$normal_usage_entry, 10],
            ['P2                             ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['P3                             ',
            clc$nominal_entry, clc$normal_usage_entry, 3],
            ['P4                             ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['P5                             ',
            clc$nominal_entry, clc$normal_usage_entry, 5],
            ['P6                             ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['P7                             ',
            clc$nominal_entry, clc$normal_usage_entry, 7],
            ['P8                             ', clc$nominal_entry,
            clc$normal_usage_entry, 8], ['P9                             ',
            clc$nominal_entry, clc$normal_usage_entry, 9]]]]],
            ['DUAL_STATE_PRIORITY            ', clc$optional_field, 84],
            [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
            FALSE, 2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [1, 10, 10]]],
            ['SUBPRIORITY                    ', clc$optional_field, 84],
            [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
            FALSE, 2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [1, 15, 10]]]]]],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type], FALSE,
            2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 3, [[1, 0, clc$boolean_type]]],

{ PARAMETER 6

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 81, [[1, 0, clc$keyword_type],
            [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNLIMITED                      ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [lowest_idle_disp_q_time,
            highest_idle_disp_q_time, 10]]],

{ PARAMETER 7

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2],
            118, [[1, 0, clc$keyword_type], [3],
            [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['DEFAULT                        ',
            clc$nominal_entry, clc$normal_usage_entry, 1],
            ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 3]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 8

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2],
            118, [[1, 0, clc$keyword_type], [3],
            [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['DEFAULT                        ',
            clc$nominal_entry, clc$normal_usage_entry, 1],
            ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 3]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 9

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_service_interval,
            jmc$highest_service_interval, 10]]],

{ PARAMETER 10

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_priority_bias,
            jmc$highest_priority_bias, 10]]],

{ PARAMETER 11

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$record_type], FALSE, 2],
            44, [[1, 0, clc$keyword_type], [1],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 247,
            [[1, 0, clc$record_type], [2], ['TARGET                         ',
            clc$optional_field, 84], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        '
            , clc$nominal_entry, clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_sched_memory_level,
            jmc$highest_sched_memory_level, 10]]],
            ['THRASHING                      ', clc$optional_field, 84],
            [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
            FALSE, 2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_sched_memory_level,
            jmc$highest_sched_memory_level, 10]]]]],

{ PARAMETER 12

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_service_interval,
            jmc$highest_service_interval, 10]]],

{ PARAMETER 13

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$cpu_dispatching_allocation = 1,
      p$cpu_dispatching_interval = 2,
      p$cpu_quantum_time = 3,
      p$dual_state_priority_control = 4,
      p$enable_job_leveling = 5,
      p$idle_dispatching_queue_time = 6,
      p$initiation_excluded_categorie = 7 {INITIATION_EXCLUDED_CATEGORIES} ,
      p$initiation_required_categorie = 8 {INITIATION_REQUIRED_CATEGORIES} ,
      p$job_leveling_interval = 9,
      p$job_leveling_priority_bias = 10,
      p$scheduling_memory_levels = 11,
      p$service_calculation_interval = 12,
      p$status = 13;

    VAR
      pvt: array [1 .. 13] of clt$parameter_value;

    VAR
      values: jmt$object_attribute;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_controls;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$get_attributes (jmc$profile_controls, #SEQ (pdt),
          ^pvt, values, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$change_object (jmc$profile_controls, current_controls, values,
          jmc$update, status);

  PROCEND jmp$_change_controls;
?? TITLE := 'jmp$_change_job_class', EJECT ??

{ PURPOSE:
{   Processes the CHANGE_JOB_CLASS command.
{
{ DESIGN:
{   Determines the job classes to update, fetches the changed attributes
{   and makes a request to change them.

  PROCEDURE jmp$_change_job_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_chajcl) change_job_class (
{   class_name, class_names, cn: any of
{       key all keyend
{       list of name
{     anyend = $current_job_class
{   cpu_time_limit, ctl: (by_name) any of
{       key default, unlimited, system_default keyend
{       integer jmc$lowest_cpu_time_limit..jmc$highest_cpu_time_limit
{     anyend = $optional
{   cyclic_aging_interval, cai: (by_name) any of
{       key default keyend
{       record
{         default: any of
{           key default keyend
{           integer jmc$lowest_aging_interval..jmc$highest_aging_interval
{         anyend = $optional
{         minimum: any of
{           key default keyend
{           integer jmc$lowest_aging_interval..jmc$highest_aging_interval
{         anyend = $optional
{         maximum: any of
{           key default keyend
{           integer jmc$lowest_aging_interval..jmc$highest_aging_interval
{         anyend = $optional
{       recend
{     anyend = $optional
{   detached_job_wait_time, djwt: (by_name) any of
{       key default keyend
{       record
{         default: any of
{           key default, unlimited keyend
{         integer jmc$lowest_det_job_wait_time..jmc$highest_det_job_wait_time
{         anyend = $optional
{         minimum: any of
{           key default, unlimited keyend
{         integer jmc$lowest_det_job_wait_time..jmc$highest_det_job_wait_time
{         anyend = $optional
{         maximum: any of
{           key default, unlimited keyend
{         integer jmc$lowest_det_job_wait_time..jmc$highest_det_job_wait_time
{         anyend = $optional
{       recend
{     anyend = $optional
{   enable_class_initiation, eci: (by_name) any of
{       key default keyend
{       boolean
{     anyend = $optional
{   epilog, e: (by_name) any of
{       key default, none, unspecified keyend
{       file
{     anyend = $optional
{   immediate_initiation_candidate, iic: (by_name) any of
{       key default keyend
{       boolean
{     anyend = $optional
{   initial_service_class, isc: (by_name) any of
{       key default, none keyend
{        name
{     anyend = $optional
{   initial_working_set, iws: (by_name) any of
{       key default keyend
{       integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{     anyend = $optional
{   initiation_age_interval, iai: (by_name) any of
{       key default, unlimited keyend
{       integer lowest_prio_age_interval..highest_prio_age_interval
{     anyend = $optional
{   initiation_level, il: (by_name) any of
{       key default keyend
{       record
{         preferred: any of
{           key default, unlimited keyend
{         integer jmc$lowest_max_initiated_jobs..jmc$highest_max_initiated_jobs
{         anyend
{       recend
{     anyend = $optional
{   job_leveling_priority_bias, jlpb: (by_name) any of
{       key default keyend
{       integer jmc$lowest_priority_bias..jmc$highest_priority_bias
{     anyend = $optional
{   magnetic_tape_limit, mtl: (by_name) any of
{       key default, unlimited keyend
{       integer jmc$lowest_magnetic_tape_limit..jmc$highest_magnetic_tape_limit
{     anyend = $optional
{   maximum_working_set, maxws: (by_name) any of
{       key default keyend
{       record
{         default: any of
{           key default, unlimited keyend
{           integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{         anyend = $optional
{         minimum: any of
{           key default, unlimited keyend
{           integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{         anyend = $optional
{         maximum: any of
{           key default, unlimited keyend
{           integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{         anyend = $optional
{       recend
{     anyend = $optional
{   minimum_working_set, minws: (by_name) any of
{       key default keyend
{       record
{         default: any of
{           key default keyend
{           integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{         anyend = $optional
{         minimum: any of
{           key default keyend
{           integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{         anyend = $optional
{         maximum: any of
{           key default keyend
{           integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{         anyend = $optional
{       recend
{     anyend = $optional
{   page_aging_interval, pai: (by_name) any of
{       key default keyend
{       record
{         default: any of
{           key default keyend
{           integer jmc$lowest_aging_interval..jmc$highest_aging_interval
{         anyend = $optional
{         minimum: any of
{           key default keyend
{           integer jmc$lowest_aging_interval..jmc$highest_aging_interval
{         anyend = $optional
{         maximum: any of
{           key default keyend
{           integer jmc$lowest_aging_interval..jmc$highest_aging_interval
{         anyend = $optional
{       recend
{     anyend = $optional
{   prolog, p: (by_name) any of
{       key default, none, unspecified keyend
{       file
{     anyend = $optional
{   selection_priority, sp: (by_name) any of
{       key default keyend
{       record
{         initial: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{         maximum: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{         increment: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{       recend
{     anyend = $optional
{   sru_limit, sl: (by_name) any of
{       key default, unlimited, system_default keyend
{       integer jmc$lowest_sru_limit..jmc$highest_sru_limit
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 40] of clt$pdt_parameter_name,
        parameters: array [1 .. 20] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (18),
        recend,
        type2: 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 .. 3] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type3: 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$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_3: clt$field_specification,
            element_type_spec_3: 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$integer_type_qualifier,
              recend,
            recend,
          recend,
        recend,
        type4: 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$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: 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 .. 2] of clt$keyword_specification,
              recend,
              type_size_2: clt$type_specification_size,
              element_type_spec_2: record
                header: clt$type_specification_header,
                qualifier: clt$integer_type_qualifier,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: 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 .. 2] of clt$keyword_specification,
              recend,
              type_size_2: clt$type_specification_size,
              element_type_spec_2: record
                header: clt$type_specification_header,
                qualifier: clt$integer_type_qualifier,
              recend,
            recend,
            field_spec_3: clt$field_specification,
            element_type_spec_3: 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 .. 2] of clt$keyword_specification,
              recend,
              type_size_2: clt$type_specification_size,
              element_type_spec_2: record
                header: clt$type_specification_header,
                qualifier: clt$integer_type_qualifier,
              recend,
            recend,
          recend,
        recend,
        type5: 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,
          recend,
        recend,
        type6: 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 .. 3] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
        recend,
        type7: 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,
          recend,
        recend,
        type8: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type9: 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$integer_type_qualifier,
          recend,
        recend,
        type10: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type11: 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$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: 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 .. 2] of clt$keyword_specification,
              recend,
              type_size_2: clt$type_specification_size,
              element_type_spec_2: record
                header: clt$type_specification_header,
                qualifier: clt$integer_type_qualifier,
              recend,
            recend,
          recend,
        recend,
        type12: 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$integer_type_qualifier,
          recend,
        recend,
        type13: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type14: 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$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: 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 .. 2] of clt$keyword_specification,
              recend,
              type_size_2: clt$type_specification_size,
              element_type_spec_2: record
                header: clt$type_specification_header,
                qualifier: clt$integer_type_qualifier,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: 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 .. 2] of clt$keyword_specification,
              recend,
              type_size_2: clt$type_specification_size,
              element_type_spec_2: record
                header: clt$type_specification_header,
                qualifier: clt$integer_type_qualifier,
              recend,
            recend,
            field_spec_3: clt$field_specification,
            element_type_spec_3: 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 .. 2] of clt$keyword_specification,
              recend,
              type_size_2: clt$type_specification_size,
              element_type_spec_2: record
                header: clt$type_specification_header,
                qualifier: clt$integer_type_qualifier,
              recend,
            recend,
          recend,
        recend,
        type15: 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$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_3: clt$field_specification,
            element_type_spec_3: 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$integer_type_qualifier,
              recend,
            recend,
          recend,
        recend,
        type16: 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$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_3: clt$field_specification,
            element_type_spec_3: 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$integer_type_qualifier,
              recend,
            recend,
          recend,
        recend,
        type17: 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 .. 3] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
        recend,
        type18: 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$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_3: clt$field_specification,
            element_type_spec_3: 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$integer_type_qualifier,
              recend,
            recend,
          recend,
        recend,
        type19: 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 .. 3] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type20: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 3, 4, 688], clc$command, 40, 20, 0, 0, 0,
            0, 20, 'OSM$MANAS_CHAJCL'], [['CAI                            ',
            clc$abbreviation_entry, 3], ['CLASS_NAME                     ',
            clc$nominal_entry, 1], ['CLASS_NAMES                    ',
            clc$alias_entry, 1], ['CN                             ',
            clc$abbreviation_entry, 1], ['CPU_TIME_LIMIT                 ',
            clc$nominal_entry, 2], ['CTL                            ',
            clc$abbreviation_entry, 2], ['CYCLIC_AGING_INTERVAL          ',
            clc$nominal_entry, 3], ['DETACHED_JOB_WAIT_TIME         ',
            clc$nominal_entry, 4], ['DJWT                           ',
            clc$abbreviation_entry, 4], ['E                              ',
            clc$abbreviation_entry, 6], ['ECI                            ',
            clc$abbreviation_entry, 5], ['ENABLE_CLASS_INITIATION        ',
            clc$nominal_entry, 5], ['EPILOG                         ',
            clc$nominal_entry, 6], ['IAI                            ',
            clc$abbreviation_entry, 10], ['IIC                            ',
            clc$abbreviation_entry, 7], ['IL                             ',
            clc$abbreviation_entry, 11], ['IMMEDIATE_INITIATION_CANDIDATE ',
            clc$nominal_entry, 7], ['INITIAL_SERVICE_CLASS          ',
            clc$nominal_entry, 8], ['INITIAL_WORKING_SET            ',
            clc$nominal_entry, 9], ['INITIATION_AGE_INTERVAL        ',
            clc$nominal_entry, 10], ['INITIATION_LEVEL               ',
            clc$nominal_entry, 11], ['ISC                            ',
            clc$abbreviation_entry, 8], ['IWS                            ',
            clc$abbreviation_entry, 9], ['JLPB                           ',
            clc$abbreviation_entry, 12], ['JOB_LEVELING_PRIORITY_BIAS     ',
            clc$nominal_entry, 12], ['MAGNETIC_TAPE_LIMIT            ',
            clc$nominal_entry, 13], ['MAXIMUM_WORKING_SET            ',
            clc$nominal_entry, 14], ['MAXWS                          ',
            clc$abbreviation_entry, 14], ['MINIMUM_WORKING_SET            ',
            clc$nominal_entry, 15], ['MINWS                          ',
            clc$abbreviation_entry, 15], ['MTL                            ',
            clc$abbreviation_entry, 13], ['P                              ',
            clc$abbreviation_entry, 17], ['PAGE_AGING_INTERVAL            ',
            clc$nominal_entry, 16], ['PAI                            ',
            clc$abbreviation_entry, 16], ['PROLOG                         ',
            clc$nominal_entry, 17], ['SELECTION_PRIORITY             ',
            clc$nominal_entry, 18], ['SL                             ',
            clc$abbreviation_entry, 19], ['SP                             ',
            clc$abbreviation_entry, 18], ['SRU_LIMIT                      ',
            clc$nominal_entry, 19], ['STATUS                         ',
            clc$nominal_entry, 20]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 18],

{ PARAMETER 2

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 158, clc$optional_parameter, 0,
            0],

{ PARAMETER 3

      [7, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 431, clc$optional_parameter, 0,
            0],

{ PARAMETER 4

      [8, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 542, clc$optional_parameter, 0,
            0],

{ PARAMETER 5

      [12, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [13, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 141, clc$optional_parameter, 0,
            0],

{ PARAMETER 7

      [17, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [18, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 106, clc$optional_parameter, 0,
            0],

{ PARAMETER 9

      [19, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],

{ PARAMETER 10

      [20, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 121, clc$optional_parameter, 0,
            0],

{ PARAMETER 11

      [21, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 228, clc$optional_parameter, 0,
            0],

{ PARAMETER 12

      [25, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],

{ PARAMETER 13

      [26, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 121, clc$optional_parameter, 0,
            0],

{ PARAMETER 14

      [27, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 542, clc$optional_parameter, 0,
            0],

{ PARAMETER 15

      [29, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 431, clc$optional_parameter, 0,
            0],

{ PARAMETER 16

      [33, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 431, clc$optional_parameter, 0,
            0],

{ PARAMETER 17

      [35, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 141, clc$optional_parameter, 0,
            0],

{ PARAMETER 18

      [36, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 431, clc$optional_parameter, 0,
            0],

{ PARAMETER 19

      [39, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 158, clc$optional_parameter, 0,
            0],

{ PARAMETER 20

      [40, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            '$current_job_class'],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 118, [[1, 0, clc$keyword_type],
            [3], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_DEFAULT                 ',
            clc$nominal_entry, clc$normal_usage_entry, 3],
            ['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_cpu_time_limit,
            jmc$highest_cpu_time_limit, 10]]],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$record_type], FALSE, 2],
            44, [[1, 0, clc$keyword_type], [1],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 367,
            [[1, 0, clc$record_type], [3], ['DEFAULT                        ',
            clc$optional_field, 84], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        '
            , clc$nominal_entry, clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
            jmc$highest_aging_interval, 10]]],
            ['MINIMUM                        ', clc$optional_field, 84],
            [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
            FALSE, 2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
            jmc$highest_aging_interval, 10]]],
            ['MAXIMUM                        ', clc$optional_field, 84],
            [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
            FALSE, 2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
            jmc$highest_aging_interval, 10]]]]],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$record_type], FALSE, 2],
            44, [[1, 0, clc$keyword_type], [1],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 478,
            [[1, 0, clc$record_type], [3], ['DEFAULT                        ',
            clc$optional_field, 121], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['DEFAULT                        '
            , clc$nominal_entry, clc$normal_usage_entry, 1],
            ['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_det_job_wait_time,
            jmc$highest_det_job_wait_time, 10]]],
            ['MINIMUM                        ', clc$optional_field, 121],
            [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
            FALSE, 2], 81, [[1, 0, clc$keyword_type],
            [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNLIMITED                      ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_det_job_wait_time,
            jmc$highest_det_job_wait_time, 10]]],
            ['MAXIMUM                        ', clc$optional_field, 121],
            [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
            FALSE, 2], 81, [[1, 0, clc$keyword_type],
            [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNLIMITED                      ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_det_job_wait_time,
            jmc$highest_det_job_wait_time, 10]]]]],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type], FALSE,
            2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 3, [[1, 0, clc$boolean_type]]],

{ PARAMETER 6

      [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type], FALSE, 2],
            118, [[1, 0, clc$keyword_type], [3],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ',
            clc$nominal_entry, clc$normal_usage_entry, 2],
            ['UNSPECIFIED                    ', clc$nominal_entry,
            clc$normal_usage_entry, 3]]], 3, [[1, 0, clc$file_type]]],

{ PARAMETER 7

      [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type], FALSE,
            2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 3, [[1, 0, clc$boolean_type]]],

{ PARAMETER 8

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2],
            81, [[1, 0, clc$keyword_type], [2],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 5,
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 9

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
            jmc$highest_working_set_size, 10]]],

{ PARAMETER 10

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 81, [[1, 0, clc$keyword_type],
            [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNLIMITED                      ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [lowest_prio_age_interval,
            highest_prio_age_interval, 10]]],

{ PARAMETER 11

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$record_type], FALSE, 2],
            44, [[1, 0, clc$keyword_type], [1],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 164,
            [[1, 0, clc$record_type], [1], ['PREFERRED                      ',
            clc$required_field, 121], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['DEFAULT                        '
            , clc$nominal_entry, clc$normal_usage_entry, 1],
            ['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_max_initiated_jobs,
            jmc$highest_max_initiated_jobs, 10]]]]],

{ PARAMETER 12

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_priority_bias,
            jmc$highest_priority_bias, 10]]],

{ PARAMETER 13

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 81, [[1, 0, clc$keyword_type],
            [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNLIMITED                      ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_magnetic_tape_limit,
            jmc$highest_magnetic_tape_limit, 10]]],

{ PARAMETER 14

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$record_type], FALSE, 2],
            44, [[1, 0, clc$keyword_type], [1],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 478,
            [[1, 0, clc$record_type], [3], ['DEFAULT                        ',
            clc$optional_field, 121], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['DEFAULT                        '
            , clc$nominal_entry, clc$normal_usage_entry, 1],
            ['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
            jmc$highest_working_set_size, 10]]],
            ['MINIMUM                        ', clc$optional_field, 121],
            [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
            FALSE, 2], 81, [[1, 0, clc$keyword_type],
            [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNLIMITED                      ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
            jmc$highest_working_set_size, 10]]],
            ['MAXIMUM                        ', clc$optional_field, 121],
            [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
            FALSE, 2], 81, [[1, 0, clc$keyword_type],
            [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNLIMITED                      ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
            jmc$highest_working_set_size, 10]]]]],

{ PARAMETER 15

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$record_type], FALSE, 2],
            44, [[1, 0, clc$keyword_type], [1],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 367,
            [[1, 0, clc$record_type], [3], ['DEFAULT                        ',
            clc$optional_field, 84], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        '
            , clc$nominal_entry, clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
            jmc$highest_working_set_size, 10]]],
            ['MINIMUM                        ', clc$optional_field, 84],
            [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
            FALSE, 2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
            jmc$highest_working_set_size, 10]]],
            ['MAXIMUM                        ', clc$optional_field, 84],
            [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
            FALSE, 2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
            jmc$highest_working_set_size, 10]]]]],

{ PARAMETER 16

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$record_type], FALSE, 2],
            44, [[1, 0, clc$keyword_type], [1],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 367,
            [[1, 0, clc$record_type], [3], ['DEFAULT                        ',
            clc$optional_field, 84], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        '
            , clc$nominal_entry, clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
            jmc$highest_aging_interval, 10]]],
            ['MINIMUM                        ', clc$optional_field, 84],
            [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
            FALSE, 2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
            jmc$highest_aging_interval, 10]]],
            ['MAXIMUM                        ', clc$optional_field, 84],
            [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
            FALSE, 2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
            jmc$highest_aging_interval, 10]]]]],

{ PARAMETER 17

      [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type], FALSE, 2],
            118, [[1, 0, clc$keyword_type], [3],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ',
            clc$nominal_entry, clc$normal_usage_entry, 2],
            ['UNSPECIFIED                    ', clc$nominal_entry,
            clc$normal_usage_entry, 3]]], 3, [[1, 0, clc$file_type]]],

{ PARAMETER 18

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$record_type], FALSE, 2],
            44, [[1, 0, clc$keyword_type], [1],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 367,
            [[1, 0, clc$record_type], [3], ['INITIAL                        ',
            clc$optional_field, 84], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        '
            , clc$nominal_entry, clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
            jmc$highest_job_priority, 10]]], ['MAXIMUM                        '
            , clc$optional_field, 84], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        '
            , clc$nominal_entry, clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
            jmc$highest_job_priority, 10]]], ['INCREMENT                      '
            , clc$optional_field, 84], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        '
            , clc$nominal_entry, clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
            jmc$highest_job_priority, 10]]]]],

{ PARAMETER 19

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 118, [[1, 0, clc$keyword_type],
            [3], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_DEFAULT                 ',
            clc$nominal_entry, clc$normal_usage_entry, 3],
            ['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_sru_limit,
            jmc$highest_sru_limit, 10]]],

{ PARAMETER 20

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$class_name = 1,
      p$cpu_time_limit = 2,
      p$cyclic_aging_interval = 3,
      p$detached_job_wait_time = 4,
      p$enable_class_initiation = 5,
      p$epilog = 6,
      p$immediate_initiation_candidat = 7 {IMMEDIATE_INITIATION_CANDIDATE} ,
      p$initial_service_class = 8,
      p$initial_working_set = 9,
      p$initiation_age_interval = 10,
      p$initiation_level = 11,
      p$job_leveling_priority_bias = 12,
      p$magnetic_tape_limit = 13,
      p$maximum_working_set = 14,
      p$minimum_working_set = 15,
      p$page_aging_interval = 16,
      p$prolog = 17,
      p$selection_priority = 18,
      p$sru_limit = 19,
      p$status = 20;

    VAR
      pvt: array [1 .. 20] of clt$parameter_value;

    VAR
      values: jmt$object_attribute;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_job_class;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$get_attributes (jmc$profile_job_class, #SEQ (pdt), ^pvt, values,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$change_object (jmc$profile_job_class, pvt [p$class_name].value^,
          values, jmc$update, status);

  PROCEND jmp$_change_job_class;
?? TITLE := 'change_output_class', EJECT ??

{ PURPOSE:
{   Processes the_CHANGE_OUTPUT_CLASS command.
{
{ DESIGN:
{   Determines the output classes to update, fetches the changed attributes
{   and makes a request to change them.
{
{ NOTES:
{   Until output classes are supported this command is hidden and has not
{   effect on the actual scheduling tables.

  PROCEDURE jmp$_change_output_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_chaoc) change_output_class (
{   class_name, class_names, cn: any of
{       key all keyend
{       list of name
{     anyend = $current_output_class
{   delivery_priority, dp: (by_name) any of
{       key default keyend
{       record
{         minimum: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{         maximum: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{         output_ate_increment: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{       recend
{     anyend = $optional
{   enable_class_scheduling, ecs: (by_name) any of
{       key default keyend
{       boolean
{     anyend = $optional
{   output_age_interval, oai: (by_name) any of
{       key default, unlimited keyend
{       integer jmc$lowest_prio_age_interval..jmc$highest_prio_age_interval
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 10] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (21),
        recend,
        type2: 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$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_3: clt$field_specification,
            element_type_spec_3: 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$integer_type_qualifier,
              recend,
            recend,
          recend,
        recend,
        type3: 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,
          recend,
        recend,
        type4: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 4, 42, 436], clc$command, 10, 5, 0, 0, 0,
            0, 5, 'OSM$MANAS_CHAOC'], [['CLASS_NAME                     ',
            clc$nominal_entry, 1], ['CLASS_NAMES                    ',
            clc$alias_entry, 1], ['CN                             ',
            clc$abbreviation_entry, 1], ['DELIVERY_PRIORITY              ',
            clc$nominal_entry, 2], ['DP                             ',
            clc$abbreviation_entry, 2], ['ECS                            ',
            clc$abbreviation_entry, 3], ['ENABLE_CLASS_SCHEDULING        ',
            clc$nominal_entry, 3], ['OAI                            ',
            clc$abbreviation_entry, 4], ['OUTPUT_AGE_INTERVAL            ',
            clc$nominal_entry, 4], ['STATUS                         ',
            clc$nominal_entry, 5]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 21],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 431, clc$optional_parameter, 0,
            0],

{ PARAMETER 3

      [7, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [9, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 121, clc$optional_parameter, 0,
            0],

{ PARAMETER 5

      [10, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            '$current_output_class'],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$record_type], FALSE, 2],
            44, [[1, 0, clc$keyword_type], [1],
            [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 367,
            [[1, 0, clc$record_type], [3], ['MINIMUM                        ',
            clc$optional_field, 84], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        '
            , clc$nominal_entry, clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
            jmc$highest_job_priority, 10]]], ['MAXIMUM                        '
            , clc$optional_field, 84], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        '
            , clc$nominal_entry, clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
            jmc$highest_job_priority, 10]]], ['OUTPUT_ATE_INCREMENT           '
            , clc$optional_field, 84], [[1, 0, clc$union_type],
            [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['DEFAULT                        '
            , clc$nominal_entry, clc$normal_usage_entry, 1]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
            jmc$highest_job_priority, 10]]]]],

{ PARAMETER 3

      [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type], FALSE,
            2], 44, [[1, 0, clc$keyword_type],
            [1], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 3, [[1, 0, clc$boolean_type]]],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE,
            2], 81, [[1, 0, clc$keyword_type],
            [2], [['DEFAULT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['UNLIMITED                      ',
            clc$nominal_entry, clc$normal_usage_entry, 2]]], 20,
            [[1, 0, clc$integer_type], [jmc$lowest_prio_age_interval,
            jmc$highest_prio_age_interval, 10]]],

{ PARAMETER 5

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$class_name = 1,
      p$delivery_priority = 2,
      p$enable_class_scheduling = 3,
      p$output_age_interval = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      values: jmt$object_attribute;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_output_class;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$get_attributes (jmc$profile_output_class, #SEQ (pdt), ^pvt, values,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$change_object (jmc$profile_output_class, pvt [p$class_name].value^,
          values, jmc$update, status);

  PROCEND jmp$_change_output_class;
?? TITLE := 'jmp$_change_service_class', EJECT ??

{ PURPOSE:
{   Processes the CHANGE_SERVICE_CLASS command.
{
{ DESIGN:
{   Determines the service classes to update, fetches the changed attributes
{   and makes a request to change them.

  PROCEDURE jmp$_change_service_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_chasc) change_service_class (
{   class_name, class_names, cn: any of
{       key all keyend
{       list of name
{     anyend = $current_service_class
{   aio_limit, aiol: (by_name) any of
{       key default keyend
{       integer jmc$lowest_aio_limit..jmc$highest_aio_limit
{     anyend = $optional
{   class_service_threshold, cst: (by_name) any of
{       key default, unlimited keyend
{       integer jmc$lowest_service_accumulator..jmc$highest_service_accumulator
{     anyend = $optional
{   dispatching_control, dc: (by_name) any of
{       key default keyend
{       list 1..5 of record
{         dispatching_priority: any of
{           key default p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 keyend
{           integer 1..10
{          anyend
{         service_time: any of
{           key unlimited keyend
{           integer lowest_service_limit..highest_service_limit
{          anyend = $optional
{         minor_timeslice: any of
{           key default keyend
{           integer jmc$lowest_task_time_slice..jmc$highest_task_time_slice
{          anyend = $optional
{         major_timeslice: any of
{           key default keyend
{           integer jmc$lowest_task_time_slice..jmc$highest_task_time_slice
{          anyend = $optional
{        recend
{     anyend = $optional
{   guaranteed_service_quantum, gsq: (by_name) any of
{       key default, unlimited keyend
{       integer jmc$lowest_service_accumulator..jmc$highest_service_accumulator
{     anyend = $optional
{   long_wait_think_time, lwtt: (by_name) any of
{       key default keyend
{       integer jmc$low_long_wait_think_time..jmc$high_long_wait_think_time
{     anyend = $optional
{   maximum_active_jobs, maxaj: (by_name) any of
{       key default, unlimited keyend
{       integer jmc$lowest_maximum_active_jobs..jmc$highest_maximum_active_jobs
{     anyend = $optional
{   next_service_class, nsc: (by_name) any of
{       key default, none keyend
{       name
{     anyend = $optional
{   scheduling_priority, sp: (by_name) any of
{       key default keyend
{       record
{         minimum: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{         maximum: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{         swap_age_increment: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{         ready_task_increment: any of
{           key default keyend
{           integer jmc$lowest_job_priority..jmc$highest_job_priority
{         anyend = $optional
{       recend
{     anyend = $optional
{   service_factors, sf: (by_name) any of
{       key default keyend
{       record
{         CPU: any of
{           key default keyend
{           integer ..
{             jmc$lowest_service_factor_value..jmc$highest_service_factor_valu
{         anyend = $optional
{         memory: any of
{           key default keyend
{           integer ..
{             jmc$lowest_service_factor_value..jmc$highest_service_factor_valu
{         anyend = $optional
{         residence: any of
{           key default keyend
{           integer ..
{             jmc$lowest_service_factor_value..jmc$highest_service_factor_valu
{         anyend = $optional
{         IO: any of
{           key default keyend
{           integer ..
{             jmc$lowest_service_factor_value..jmc$highest_service_factor_valu
{         anyend = $optional
{       recend
{     anyend = $optional
{   swap_age_interval, sai: (by_name) any of
{       key default, unlimited keyend
{       integer lowest_prio_age_interval..highest_prio_age_interval
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 24] of clt$pdt_parameter_name,
      parameters: array [1 .. 12] 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (22),
      recend,
      type2: 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$integer_type_qualifier,
        recend,
      recend,
      type3: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type4: 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$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: 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 .. 11] of clt$keyword_specification,
              recend,
              type_size_2: clt$type_specification_size,
              element_type_spec_2: record
                header: clt$type_specification_header,
                qualifier: clt$integer_type_qualifier,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_3: clt$field_specification,
            element_type_spec_3: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_4: clt$field_specification,
            element_type_spec_4: 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$integer_type_qualifier,
              recend,
            recend,
          recend,
        recend,
      recend,
      type5: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type6: 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$integer_type_qualifier,
        recend,
      recend,
      type7: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type8: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type9: 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$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: 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$integer_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type10: 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$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: 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$integer_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type11: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type12: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 8, 12, 15, 14, 51, 153],
    clc$command, 24, 12, 0, 0, 0, 0, 12, 'OSM$MANAS_CHASC'], [
    ['AIOL                           ',clc$abbreviation_entry, 2],
    ['AIO_LIMIT                      ',clc$nominal_entry, 2],
    ['CLASS_NAME                     ',clc$nominal_entry, 1],
    ['CLASS_NAMES                    ',clc$alias_entry, 1],
    ['CLASS_SERVICE_THRESHOLD        ',clc$nominal_entry, 3],
    ['CN                             ',clc$abbreviation_entry, 1],
    ['CST                            ',clc$abbreviation_entry, 3],
    ['DC                             ',clc$abbreviation_entry, 4],
    ['DISPATCHING_CONTROL            ',clc$nominal_entry, 4],
    ['GSQ                            ',clc$abbreviation_entry, 5],
    ['GUARANTEED_SERVICE_QUANTUM     ',clc$nominal_entry, 5],
    ['LONG_WAIT_THINK_TIME           ',clc$nominal_entry, 6],
    ['LWTT                           ',clc$abbreviation_entry, 6],
    ['MAXAJ                          ',clc$abbreviation_entry, 7],
    ['MAXIMUM_ACTIVE_JOBS            ',clc$nominal_entry, 7],
    ['NEXT_SERVICE_CLASS             ',clc$nominal_entry, 8],
    ['NSC                            ',clc$abbreviation_entry, 8],
    ['SAI                            ',clc$abbreviation_entry, 11],
    ['SCHEDULING_PRIORITY            ',clc$nominal_entry, 9],
    ['SERVICE_FACTORS                ',clc$nominal_entry, 10],
    ['SF                             ',clc$abbreviation_entry, 10],
    ['SP                             ',clc$abbreviation_entry, 9],
    ['STATUS                         ',clc$nominal_entry, 12],
    ['SWAP_AGE_INTERVAL              ',clc$nominal_entry, 11]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 22],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 121, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 937, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 121, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 121, clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 106, clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 551, clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 551, clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 121, clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    '$current_service_class'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_aio_limit, jmc$highest_aio_limit
  , 10]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_service_accumulator,
  jmc$highest_service_accumulator, 10]]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    873, [[1, 0, clc$list_type], [857, 1, 5, 0, FALSE, FALSE],
        [[1, 0, clc$record_type], [4],
        ['DISPATCHING_PRIORITY           ', clc$required_field, 454], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
          FALSE, 2],
          414, [[1, 0, clc$keyword_type], [11], [
            ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
            ['P1                             ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
            ['P10                            ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
            ['P2                             ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
            ['P3                             ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
            ['P4                             ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
            ['P5                             ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
            ['P6                             ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
            ['P7                             ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
            ['P8                             ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
            ['P9                             ', clc$nominal_entry,
  clc$normal_usage_entry, 10]]
            ],
          20, [[1, 0, clc$integer_type], [1, 10, 10]]
          ],
        ['SERVICE_TIME                   ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
          FALSE, 2],
          44, [[1, 0, clc$keyword_type], [1], [
            ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
            ],
          20, [[1, 0, clc$integer_type], [lowest_service_limit,
  highest_service_limit, 10]]
          ],
        ['MINOR_TIMESLICE                ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
          FALSE, 2],
          44, [[1, 0, clc$keyword_type], [1], [
            ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
            ],
          20, [[1, 0, clc$integer_type], [jmc$lowest_task_time_slice,
  jmc$highest_task_time_slice, 10]]
          ],
        ['MAJOR_TIMESLICE                ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
          FALSE, 2],
          44, [[1, 0, clc$keyword_type], [1], [
            ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
            ],
          20, [[1, 0, clc$integer_type], [jmc$lowest_task_time_slice,
  jmc$highest_task_time_slice, 10]]
          ]
        ]
      ]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_service_accumulator,
  jmc$highest_service_accumulator, 10]]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$low_long_wait_think_time,
  jmc$high_long_wait_think_time, 10]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_maximum_active_jobs,
  jmc$highest_maximum_active_jobs, 10]]
    ],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$record_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    487, [[1, 0, clc$record_type], [4],
      ['MINIMUM                        ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
  jmc$highest_job_priority, 10]]
        ],
      ['MAXIMUM                        ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
  jmc$highest_job_priority, 10]]
        ],
      ['SWAP_AGE_INCREMENT             ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
  jmc$highest_job_priority, 10]]
        ],
      ['READY_TASK_INCREMENT           ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_job_priority,
  jmc$highest_job_priority, 10]]
        ]
      ]
    ],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$record_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    487, [[1, 0, clc$record_type], [4],
      ['CPU                            ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_service_factor_value,
  jmc$highest_service_factor_valu, 10]]
        ],
      ['MEMORY                         ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_service_factor_value,
  jmc$highest_service_factor_valu, 10]]
        ],
      ['RESIDENCE                      ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_service_factor_value,
  jmc$highest_service_factor_valu, 10]]
        ],
      ['IO                             ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [jmc$lowest_service_factor_value,
  jmc$highest_service_factor_valu, 10]]
        ]
      ]
    ],
{ PARAMETER 11
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [lowest_prio_age_interval,
  highest_prio_age_interval, 10]]
    ],
{ PARAMETER 12
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$class_name = 1,
      p$aio_limit = 2,
      p$class_service_threshold = 3,
      p$dispatching_control = 4,
      p$guaranteed_service_quantum = 5,
      p$long_wait_think_time = 6,
      p$maximum_active_jobs = 7,
      p$next_service_class = 8,
      p$scheduling_priority = 9,
      p$service_factors = 10,
      p$swap_age_interval = 11,
      p$status = 12;

    VAR
      pvt: array [1 .. 12] of clt$parameter_value;

    VAR
      values: jmt$object_attribute;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_service_class;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$get_attributes (jmc$profile_service_class, #SEQ (pdt), ^pvt, values,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$change_object (jmc$profile_service_class, pvt [p$class_name].value^,
          values, jmc$update, status);

  PROCEND jmp$_change_service_class;
?? TITLE := 'jmp$_delete_job_category_entry', EJECT ??

{ PURPOSE:
{   Processes the DELETE_JOB_CATEGORY_ENTRY command.
{
{ DESIGN:
{   Determines the attributes to update, fetches the categories to delete
{   and makes a request to delete them from the attributes.

  PROCEDURE jmp$_delete_job_category_entry
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_deljce) delete_job_category_entry (
{   initiation_excluded_categories, iec: (by_name) any of
{       key all keyend
{       list of name
{     anyend = $optional
{   initiation_required_categories, irc: (by_name) any of
{       key all keyend
{       list of name
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type2: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 7, 10, 346], clc$command, 5, 3, 0, 0, 0,
            0, 3, 'OSM$MANAS_DELJCE'], [['IEC                            ',
            clc$abbreviation_entry, 1], ['INITIATION_EXCLUDED_CATEGORIES ',
            clc$nominal_entry, 1], ['INITIATION_REQUIRED_CATEGORIES ',
            clc$nominal_entry, 2], ['IRC                            ',
            clc$abbreviation_entry, 2], ['STATUS                         ',
            clc$nominal_entry, 3]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 2

      [[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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$initiation_excluded_categorie = 1 {INITIATION_EXCLUDED_CATEGORIES} ,
      p$initiation_required_categorie = 2 {INITIATION_REQUIRED_CATEGORIES} ,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      values: jmt$object_attribute;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$get_attributes (jmc$profile_controls, #SEQ (pdt),
          ^pvt, values, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$change_object (jmc$profile_controls, current_controls, values,
          jmc$delete_list_items, status);

  PROCEND jmp$_delete_job_category_entry;
?? TITLE := 'end_handler', EJECT ??

{ PURPOSE:
{   Cleans up for the utility if an abort occurs.

  PROCEDURE end_handler
    (    termination_status: ost$status;
     VAR status: ost$status);

    VAR
      local_status: ost$status;

    status.normal := TRUE;

    jmp$clear_utility_active (profile_access_id, local_status);

  PROCEND end_handler;
?? TITLE := 'jmp$_quit ', EJECT ??

{ PURPOSE:
{   Processes the QUIT command which exits the utility.
{
{ DESIGN:
{   The routine checks the SAVE_CHANGES parameter to see if the system tables
{   are to be updated with the profile active in the utility.  If so it
{   updates the system tables with this profile.
{
{ NOTES:
{   This update is not allowed if the profile was recovered from the system
{   tables rather then the system profile file.

  PROCEDURE jmp$_quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_qui) quit (
{   save_change, sc: boolean = true
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          default_value: string (4),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 7, 33, 18], clc$command, 3, 2, 0, 0, 0, 0,
            2, 'OSM$MANAS_QUI'], [['SAVE_CHANGE                    ',
            clc$nominal_entry, 1], ['SC                             ',
            clc$abbreviation_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 2]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_default_parameter, 0, 4],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$boolean_type], 'true'],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$save_change = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    IF pvt [p$save_change].value^.boolean_value.value THEN
      jmp$update_system_profile (profile_access_id,
            prevent_profile_file_update, status);
      IF NOT status.normal THEN
        RETURN
      IFEND;
    IFEND;

    clp$end_include (utility_name, status);

  PROCEND jmp$_quit;
?? TITLE := 'jmp$_read_system_tables', EJECT ??

{ PURPOSE:
{   Processes the READ_SYSTEM_TABLES command.
{
{ DESIGN:
{   This command makes a call to a procedure to build a profile from the
{   current system tables.  These table can then be displayed to see if
{   they have the desired data and form.
{
{ NOTES:
{   This is a hidden command for ARH debugging purposes only.  It should
{   be deleted before the system is released.

  PROCEDURE jmp$_read_system_tables
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_reast) read_system_tables (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 9, 26, 11, 7, 57, 356], clc$command, 1, 1, 0, 0, 0,
            0, 1, 'OSM$MANAS_REAST'], [['STATUS                         ',
            clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$build_profile_from_system (jmv$new_profile, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$build_category_object (jmv$new_profile, status);
    IF status.normal THEN
      prevent_profile_file_update := TRUE;
      jmp$set_profile (jmv$new_profile);
    IFEND;

  PROCEND jmp$_read_system_tables;
?? TITLE := 'jmp$_write_profile', EJECT ??

{ PURPOSE:
{   Process the WRITE_PROFILE command.
{
{ DESIGN:
{   Write the working profile data to the specified file.
{
{ NOTES:
{   See JMM$ADMINISTER_PROFILE.

  PROCEDURE jmp$_write_profile
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_wrip) write_profile (
{   result, r: file = $user.scheduling_profile.$next
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          default_value: string (30),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 8, 16, 251], clc$command, 3, 2, 0, 0, 0,
            0, 2, 'OSM$MANAS_WRIP'], [['R                              ',
            clc$abbreviation_entry, 1], ['RESULT                         ',
            clc$nominal_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 2]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_default_parameter, 0, 30],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type], '$user.scheduling_profile.$next'],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$result = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$write_profile (pvt [p$result].value^.file_value^, jmv$the_profile,
          status);

  PROCEND jmp$_write_profile;
?? TITLE := '[XDCL] jmp$_manage_active_scheduling', EJECT ??

{ PURPOSE:
{   Processes the MANAGE_ACTIVE_SCHEDULING command which starts up a utilty.
{
{ DESIGN:
{   This routine sets the MANAS interlock, recovers the scheduling profile,
{   and then starts the utility.

  PROCEDURE [XDCL] jmp$_manage_active_scheduling
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas) manage_active_scheduling (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 9, 23, 11, 46, 57, 655], clc$command, 1, 1, 0, 0, 0,
            0, 1, 'OSM$MANAS'], [['STATUS                         ',
            clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      current_mainframe_id: pmt$mainframe_id,
      severity: ost$status_severity,
      local_status: ost$status;

    #keypoint (osk$entry, 0, jmk$manage_active_scheduling);

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, 0, jmk$manage_active_scheduling);
      RETURN
    IFEND;

    pmp$get_mainframe_id (current_mainframe_id, status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, 0, jmk$manage_active_scheduling);
      RETURN
    IFEND;
    current_controls.kind := clc$name;
    current_controls.name_value := current_mainframe_id;

    jmp$build_default_profile (status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, 0, jmk$manage_active_scheduling);
      RETURN;
    IFEND;

    pmp$establish_end_handler (^end_handler, status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, 0, jmk$manage_active_scheduling);
      RETURN;
    IFEND;

    jmp$recover_profile (profile_access_id, prevent_profile_file_update,
          status);
    IF NOT status.normal THEN
      osp$get_status_severity (status.condition, severity, local_status);
      IF severity > osc$warning_status THEN
        #keypoint (osk$exit, 0, jmk$manage_active_scheduling);
        RETURN;
      IFEND;
      osp$generate_message (status, local_status);
    IFEND;

    utility_attributes [1].command_table := command_table;
    utility_attributes [2].function_processor_table := jmv$utility_functions;
    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, 0, jmk$manage_active_scheduling);
      RETURN
    IFEND;

    jmv$modify_display_attributes := ^jmp$update_object_statistics;

    clp$include_file (command_file, '', utility_name, status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, 0, jmk$manage_active_scheduling);
      RETURN
    IFEND;

    jmp$clear_utility_active (profile_access_id, local_status);

    pmp$disestablish_end_handler (^end_handler, local_status);

    clp$end_utility (utility_name, status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, 0, jmk$manage_active_scheduling);
      RETURN
    IFEND;

    #keypoint (osk$exit, 0, jmk$manage_active_scheduling);

  PROCEND jmp$_manage_active_scheduling;
MODEND jmm$manage_active_scheduling;
*DECK DECK=JMM$MANAGE_ACTIVE_SCHEDULING_PD EXPAND=TRUE
  create_program_description (manage_active_scheduling manas) ..
     l=('$system.osf$builtin_library') sp=jmp$_manage_active_scheduling ..
     dm=off
*DECK DECK=JMM$MANAGE_JOB_UTILITY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : Manage Job Utility' ??
MODULE jmm$manage_job_utility;

{ PURPOSE:
{   This module contains the command and subcommands for the NOS/VE Manage
{ Job Utility.  The utility is used to manage Jobs in NOS/VE.
{
{ DESIGN:
{   This utility is a standalone utility outside of the operating system.  It is
{ available to all users.  Some commands may be restricted to a certain class of
{ users, e.g. system operators.  This restriction will be noted with any affected
{ commands.
{
{   This utility runs in the caller's ring.
{
{   Commands in this utility are designed to process an entire list of arguments
{ and report errors as they occur.  (This is intended for future sub-commands).

?? NEWTITLE := 'Global Declarations Referenced By This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc jmc$job_management_id
*copyc jmc$system_family
*copyc jme$job_history_conditions
*copyc jme$queued_file_conditions
*copyc osd$integer_limits
*copyc ost$status
?? POP ??
*copyc avp$system_administrator
*copyc avp$system_operator
*copyc clp$begin_utility
*copyc clp$build_standard_title
*copyc clp$change_variable
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_file
*copyc clp$count_list_elements
*copyc clp$create_environment_variable
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc clp$make_file_value
*copyc clp$make_list_value
*copyc clp$make_name_value
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc fsp$build_file_ref_from_elems
*copyc jmp$activate_job
*copyc jmp$determine_name_kind
*copyc jmp$get_input_attributes
*copyc jmp$get_job_counts
*copyc jmp$get_job_path_elements
*copyc jmp$get_job_status
*copyc jmp$log_restored_job
*copyc jmp$system_job
*copyc jmp$validate_name
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$format_message
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_multi_item_info
*copyc pmp$get_family_names
*copyc pmp$get_legible_date_time
*copyc clv$value_descriptors
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared By This Module', EJECT ??

*copy clv$display_variables

  SECTION
    read_only: READ;

?? OLDTITLE ??
?? NEWTITLE := 'Commands for the Manage_Job Utility', EJECT ??

  CONST
    utility_prompt_length = 2,
    utility_prompt = 'MJ';

  VAR
    job_state_names: [STATIC, READ, read_only] array [jmt$job_state] of string (10) := ['DEFERRED', 'QUEUED',
          'INITIATED', 'TERMINATED', 'COMPLETED'],
    utility_name: [STATIC, READ, read_only] clt$utility_name := 'manage_job',
    work_area: amt$segment_pointer;

  VAR
    display_control: clt$display_control,
    error_file: [STATIC] fst$path := ':$LOCAL.$ERRORS',
    error_file_open: [STATIC] boolean := FALSE,
    output_file: [STATIC] fst$path := ':$LOCAL.$OUTPUT',
    system_administrator: boolean,
    system_operator: boolean;

{ table name=manage_job_commands type=command section_name=read_only scope=local
{ command (change_list_options            , change_list_option, chalo) p=change_list_options cm=local
{ command (quit                           , qui) p=quit cm=local
{ command (select_job                     , select_jobs, selj) p=select_job cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    manage_job_commands: [STATIC, READ, read_only] ^clt$command_table := ^manage_job_commands_entries,

    manage_job_commands_entries: [STATIC, READ, read_only] array [1 .. 8] of clt$command_table_entry := [
          {} ['CHALO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^change_list_options],
          {} ['CHANGE_LIST_OPTION             ', clc$alias_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^change_list_options],
          {} ['CHANGE_LIST_OPTIONS            ', clc$nominal_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^change_list_options],
          {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^quit],
          {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^quit],
          {} ['SELECT_JOB                     ', clc$nominal_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^select_job],
          {} ['SELECT_JOBS                    ', clc$alias_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^select_job],
          {} ['SELJ                           ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^select_job]];

?? POP ??

{ table name=operator_manj_commands type=command section_name=read_only scope=local
{ command activate_job_files p=activate_job_files cm=local
{ command (change_list_options            , change_list_option, chalo) p=change_list_options cm=local
{ command log_restored_job_files p=log_restored_job_files cm=local
{ command (quit                           , qui) p=quit cm=local
{ command (select_job                     , select_jobs, selj) p=select_job cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    operator_manj_commands: [STATIC, READ, read_only] ^clt$command_table := ^operator_manj_commands_entries,

    operator_manj_commands_entries: [STATIC, READ, read_only] array [1 .. 10] of clt$command_table_entry := [
          {} ['ACTIVATE_JOB_FILES             ', clc$nominal_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^activate_job_files],
          {} ['CHALO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^change_list_options],
          {} ['CHANGE_LIST_OPTION             ', clc$alias_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^change_list_options],
          {} ['CHANGE_LIST_OPTIONS            ', clc$nominal_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^change_list_options],
          {} ['LOG_RESTORED_JOB_FILES         ', clc$nominal_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^log_restored_job_files],
          {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^quit],
          {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^quit],
          {} ['SELECT_JOB                     ', clc$nominal_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^select_job],
          {} ['SELECT_JOBS                    ', clc$alias_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^select_job],
          {} ['SELJ                           ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^select_job]];

?? POP ??

{ table name=sys_admin_functions type=function section_name=read_only scope=local
{ function $queued_job_path p=queued_job_path cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    sys_admin_functions: [STATIC, READ, read_only] ^clt$function_processor_table :=
          ^sys_admin_functions_entries,

    sys_admin_functions_entries: [STATIC, READ, read_only] array [1 .. 1] of
          clt$function_proc_table_entry := [
          {} ['$QUEUED_JOB_PATH               ', clc$nominal_entry, clc$normal_usage_entry, 1,
          clc$linked_call, ^queued_job_path]];

?? POP ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$manage_job_utility', EJECT ??

{ PURPOSE:
{   This is the entry point that begins the manage job utility.

  PROGRAM jmp$manage_job_utility
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (jmm$manj) manage_job, manage_jobs, manj (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 1, 28, 7, 54, 8, 712], clc$command, 1, 1, 0, 0, 0, 0, 1, 'JMM$MANJ'],
            [['STATUS                         ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

{ TYPE
{   selected_jobs_type: list 0 .. clc$max_list_size of name
{ TYPEND;

?? PUSH (LISTEXT := ON) ??

    VAR
      type_specification: [STATIC, READ, cls$declaration_section] record
        header: clt$type_specification_header,
        name: string (18),
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend := [[1, 18, clc$list_type], 'SELECTED_JOBS_TYPE',
            [5, 0, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]];

?? POP ??

    VAR
      utility_attributes_p: ^clt$utility_attributes;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    system_administrator := avp$system_administrator ();
    system_operator := avp$system_operator ();

    IF system_administrator THEN
      PUSH utility_attributes_p: [1 .. 5];
    ELSE
      PUSH utility_attributes_p: [1 .. 4];
    IFEND;
    utility_attributes_p^ [1].key := clc$utility_command_search_mode;
    utility_attributes_p^ [1].command_search_mode := clc$global_command_search;
    utility_attributes_p^ [2].key := clc$utility_command_table;
    IF system_administrator OR system_operator THEN
      utility_attributes_p^ [2].command_table := operator_manj_commands;
    ELSE
      utility_attributes_p^ [2].command_table := manage_job_commands;
    IFEND;
    utility_attributes_p^ [3].key := clc$utility_prompt;
    utility_attributes_p^ [3].prompt.value := utility_prompt;
    utility_attributes_p^ [3].prompt.size := utility_prompt_length;
    utility_attributes_p^ [4].key := clc$utility_termination_command;
    utility_attributes_p^ [4].termination_command := 'quit';
    IF system_administrator THEN
      utility_attributes_p^ [5].key := clc$utility_function_proc_table;
      utility_attributes_p^ [5].function_processor_table := sys_admin_functions;
    IFEND;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, work_area, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Begin the utility environment.  Establish the command list, and scan the
{ command file for commands.

    clp$begin_utility (utility_name, utility_attributes_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$create_environment_variable ('JMV$SELECTED_JOBS', clc$utility_scope, clc$read_write,
          clc$immediate_evaluation, #SEQ (type_specification), NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, utility_prompt, utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ End the utility environment and exit the utility.

    clp$end_utility (utility_name, status);

  PROCEND jmp$manage_job_utility;
?? NEWTITLE := 'activate_job_files', EJECT ??

  PROCEDURE activate_job_files
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ procedure (jmm$manj_actjf) activate_job_files (
{   files_activated, fa: (var) list 0..clc$max_list_size of name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 10, 14, 14, 14, 15, 900],
    clc$command, 3, 2, 0, 0, 0, 1, 2, 'JMM$MANJ_ACTJF'], [
    ['FA                             ',clc$abbreviation_entry, 1],
    ['FILES_ACTIVATED                ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 21,
  clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 0, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$files_activated = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    CONST
      maximum_result_item_count = 3,
      ri_system_job_name = 1,
      ri_input_file_location = 2,
      ri_login_family = 3;

    VAR
      catalog_segment_pointer: amt$segment_pointer,
      cycle_selector: pft$cycle_selector,
      family_index: pmt$family_name_count,
      family_name_count: pmt$family_name_count,
      family_name_list: ^pmt$family_name_list,
      file_count: 0 .. clc$max_list_size,
      files_activated: ^clt$data_value,
      ignore_status: ost$status,
      known_job_count: jmt$job_count_range,
      known_jobs_p: ^jmt$job_status_results,
      list_value: ^clt$data_value,
      local_status: ost$status,
      path_p: ^pft$path,
      status_options_p: ^jmt$job_status_options,
      status_results_keys_p: ^jmt$results_keys;

?? NEWTITLE := 'read_directory', EJECT ??

{
{    The purpose of this request is to read the directory of a specified
{  catalog.   A sequence is used as a placeholder for the directory.
{  The directory is returned as a pointer to an adaptable array of names.
{
{        READ_DIRECTORY (CATALOG_PATH, CATALOG_SEQUENCE_P, DIRECTORY_ARRAY_P, STATUS);
{
{ CATALOG_PATH: (input) This is the path of the catalog to read.
{
{ CATALOG_SEQUENCE_P: (input/output) This is a sequence used by the permanent file
{        interfaces for storing the raw catalog data.
{
{ DIRECTORY_ARRAY_P: (output) This is a pointer to an adaptable array of the
{        names in the catalog's directory.
{
{ STATUS: (output) This is the status of the request.
{

    PROCEDURE read_directory
      (    catalog_path: pft$path;
       VAR catalog_sequence_p: ^SEQ ( * );
       VAR directory_array_p: pft$p_directory_array;
       VAR status: ost$status);

      VAR
        group: pft$group,
        info_record_p: pft$p_info_record;

      status.normal := TRUE;
      RESET catalog_sequence_p;
      group.group_type := pfc$public;
      directory_array_p := NIL;

{ Get the raw catalog data.

      pfp$get_multi_item_info (catalog_path, group, $pft$catalog_info_selections [],
            $pft$file_info_selections [pfc$file_description], catalog_sequence_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Find the first info record in the sequence.

      RESET catalog_sequence_p;
      pfp$find_next_info_record (catalog_sequence_p, info_record_p, status);
      IF status.normal AND (info_record_p = NIL) THEN
        osp$set_status_abnormal ('JM', jme$unable_to_recover_catalog, catalog_path [1], status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Get an array of names of entities in the catalog.

      pfp$find_directory_array (info_record_p, directory_array_p, status);

    PROCEND read_directory;
?? OLDTITLE ??
?? NEWTITLE := 'recover_input_queue', EJECT ??

{ PURPOSE:
{   The purpose of this request is to recover a standard input queue catalog.
{
{ DESIGN:
{   Read the names of the files in the input queue.  Compare this list of names with the list of names in
{ the KJL.  If there is no entry in the KJL, then the job has not been queued, so attempt to recover it.

    PROCEDURE recover_input_queue
      (    family_name: ost$name;
           subcatalog_name: ost$name;
           known_jobs_p: ^jmt$job_status_results;
           known_jobs_count: jmt$job_count_range;
       VAR node: ^clt$data_value;
       VAR work_area: ^clt$work_area;
       VAR catalog_sequence_p: ^SEQ ( * );
       VAR status: ost$status);

      VAR
        directory_array_p: pft$p_directory_array,
        ignore_status: ost$status,
        known_job_index: jmt$job_count_range,
        local_status: ost$status,
        name_index: pft$array_index,
        path_p: ^pft$path,
        system_job_name: jmt$system_supplied_name;

      status.normal := TRUE;
      PUSH path_p: [pfc$family_name_index .. pfc$subcatalog_name_index];
      path_p^ [pfc$family_name_index] := family_name;
      path_p^ [pfc$master_catalog_name_index] := jmc$system_user;
      path_p^ [pfc$subcatalog_name_index] := subcatalog_name;

{ Read the job input catalog.

      read_directory (path_p^, catalog_sequence_p, directory_array_p, local_status);
      IF NOT local_status.normal THEN
        display_status_error (local_status, ignore_status);
        RETURN;
      IFEND;

{ Recover the input queue.

      IF directory_array_p <> NIL THEN

      /recover_all_files/
        FOR name_index := 1 TO UPPERBOUND (directory_array_p^) DO

          system_job_name := directory_array_p^ [name_index].name;

{ Check to see if the job is already known to the system.

          search_known_jobs (system_job_name, known_jobs_p, known_jobs_count, known_job_index);
          IF known_job_index <> 0 THEN
            CASE known_jobs_p^ [known_job_index]^ [ri_input_file_location].input_file_location OF

            = jmc$ifl_login_family_queue =
              IF (family_name = known_jobs_p^ [known_job_index]^ [ri_login_family].login_family) AND
                    (subcatalog_name <> jmc$sf_job_input_catalog) THEN
                CYCLE /recover_all_files/;
              IFEND;

            = jmc$ifl_store_and_forward_queue =
              IF subcatalog_name = jmc$sf_job_input_catalog THEN
                CYCLE /recover_all_files/;
              IFEND;

            = jmc$ifl_system_input_queue =
              IF (family_name = jmc$system_family) AND (subcatalog_name <> jmc$sf_job_input_catalog) THEN
                CYCLE /recover_all_files/;
              IFEND;

            = jmc$ifl_no_input_file_exists =
              ;

            ELSE
              ;

            CASEND;

            osp$set_status_abnormal (jmc$job_management_id, jme$input_was_not_recovered, system_job_name,
                  local_status);
            display_status_error (local_status, ignore_status);
            CYCLE /recover_all_files/;
          IFEND;

{ The job is not in the KJL.  Try to recover the command file.

          jmp$activate_job (system_job_name, family_name, subcatalog_name, {recover_using_abort_disposition}
                FALSE, {ignore_client_initiated_jobs} TRUE, local_status);

          IF local_status.normal THEN
            clp$make_list_value (work_area, node^.link);
            IF node^.link = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              RETURN;
            IFEND;

            node := node^.link;
            clp$make_name_value (system_job_name, work_area, node^.element_value);
            IF node^.element_value = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              RETURN;
            IFEND;
          ELSE
            osp$set_status_abnormal (jmc$job_management_id, jme$input_was_not_recovered, system_job_name,
                  status);
            display_status_error (local_status, ignore_status);
            display_status_error (status, ignore_status);
            status.normal := TRUE;
          IFEND;
        FOREND /recover_all_files/;
      IFEND;

    PROCEND recover_input_queue;
?? OLDTITLE ??
?? NEWTITLE := 'search_known_jobs', EJECT ??

{ PURPOSE:
{   The purpose of this request is to search a table of job names from the KJL
{ for a specific system job name.
{
{ DESIGN:
{   Search the table of job names using a binary search algorithm.  Return a
{ boolean which gives the result of the search.

    PROCEDURE search_known_jobs
      (    system_job_name: jmt$system_supplied_name;
           known_jobs_p: ^jmt$job_status_results;
           known_jobs_count: jmt$job_count_range;
       VAR position: jmt$job_count_range);

      VAR
        temp: integer,
        lower: jmt$job_count_range,
        upper: jmt$job_count_range;

      lower := 1;
      upper := known_jobs_count;

    /binary_search/
      WHILE lower <= upper DO
        temp := lower + upper;
        position := temp DIV 2;
        IF system_job_name = known_jobs_p^ [position]^ [ri_system_job_name].system_job_name THEN
          RETURN;
        ELSE
          IF system_job_name > known_jobs_p^ [position]^ [ri_system_job_name].system_job_name THEN
            lower := position + 1;
          ELSE
            upper := position - 1;
          IFEND;
        IFEND;
      WHILEND /binary_search/;
      position := 0;

    PROCEND search_known_jobs;
?? OLDTITLE ??
?? NEWTITLE := 'sort_known_jobs', EJECT ??

    PROCEDURE sort_known_jobs
      (    known_jobs_p: ^jmt$job_status_results;
           known_jobs_count: jmt$job_count_range);

      VAR
        gap: integer,
        start: integer,
        current: integer,
        swap: array [ri_system_job_name .. ri_login_family] of jmt$job_status_result;

{ Use shell sort technique.

      gap := known_jobs_count;
      WHILE gap > 1 DO
        gap := 2 * (gap DIV 4) + 1;
        FOR start := 1 TO known_jobs_count - gap DO
          current := start;
          WHILE (current > 0) AND (known_jobs_p^ [current]^ [ri_system_job_name].system_job_name >
                known_jobs_p^ [current + gap]^ [ri_system_job_name].system_job_name) DO
            swap := known_jobs_p^ [current]^;
            known_jobs_p^ [current]^ := known_jobs_p^ [current + gap]^;
            known_jobs_p^ [current + gap]^ := swap;
            current := current - gap;
          WHILEND;
        FOREND;
      WHILEND;
    PROCEND sort_known_jobs;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    local_status.normal := TRUE;
    ignore_status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Build a list of the known jobs on this system/cluster.

    PUSH status_options_p: [1 .. 1];
    status_options_p^ [1].key := jmc$continue_request_to_servers;
    status_options_p^ [1].continue_request_to_servers := TRUE;

    PUSH status_results_keys_p: [ri_system_job_name .. ri_login_family];
    status_results_keys_p^ [ri_system_job_name] := jmc$system_job_name;
    status_results_keys_p^ [ri_input_file_location] := jmc$input_file_location;
    status_results_keys_p^ [ri_login_family] := jmc$login_family;

    RESET work_area.sequence_pointer;

    jmp$get_job_status (status_options_p, status_results_keys_p, work_area.sequence_pointer, known_jobs_p,
          known_job_count, status);
    IF NOT status.normal THEN
      IF status.condition = jme$no_jobs_were_found THEN
        known_job_count := 0;
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    sort_known_jobs (known_jobs_p, known_job_count);

{ Recover the input queues - only recover jobs that are not already in the KJL.

{ Create a scratch sequence to use with the permanent file interfaces.

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, catalog_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Find the family names on the system.
{ Each family has its own input queue catalog.  Its form is:
{   :<family_name>.$SYSTEM.$JOB_INPUT_QUEUE.

{ Make a guess at the number of family names defined.  The pmp$get_family_names request
{ only returns abnormal status if the result array is too small.

    PUSH family_name_list: [1 .. 10];
    pmp$get_family_names (family_name_list^, family_name_count, local_status);
    IF NOT local_status.normal THEN
      PUSH family_name_list: [1 .. family_name_count];
      pmp$get_family_names (family_name_list^, family_name_count, { ignore } local_status);
    IFEND;

    clp$make_list_value (work_area.sequence_pointer, files_activated);
    IF files_activated = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);
    establish_display_title ('activate_job_files');

    list_value := files_activated;

  /recover_each_family_job_queue/
    FOR family_index := 1 TO family_name_count DO
      recover_input_queue (family_name_list^ [family_index], jmc$job_input_catalog, known_jobs_p,
            known_job_count, list_value, work_area.sequence_pointer, catalog_segment_pointer.sequence_pointer,
            status);
      IF NOT status.normal THEN
        EXIT /recover_each_family_job_queue/;
      IFEND;
    FOREND /recover_each_family_job_queue/;

    IF status.normal THEN
      recover_input_queue (jmc$system_family, jmc$sf_job_input_catalog, known_jobs_p, known_job_count,
            list_value, work_area.sequence_pointer, catalog_segment_pointer.sequence_pointer, status);
    IFEND;

    IF error_file_open THEN
      close_error_file (ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

    mmp$delete_scratch_segment (catalog_segment_pointer, ignore_status);

{ Return the activated system job names as the FILES_ACTIVATED parameter.

    IF pvt [p$files_activated].specified THEN

{ Skip the empty first list element if the list has some real names in it.

      IF files_activated^.link <> NIL THEN
        files_activated := files_activated^.link;
      IFEND;

      clp$change_variable (pvt [p$files_activated].variable^, files_activated, status);
    IFEND;

  PROCEND activate_job_files;
?? OLDTITLE ??
?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   Attempt to cleanup on block exit if something doesn't work.

  PROCEDURE abort_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    VAR
      ignore_status: ost$status;

    IF error_file_open THEN
      clp$close_display (display_control, ignore_status);
      error_file_open := FALSE;
      #SPOIL (error_file_open);
    IFEND;

  PROCEND abort_handler;
?? OLDTITLE ??
?? NEWTITLE := 'change_list_options', EJECT ??

  PROCEDURE change_list_options
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (jmm$mano_chalo) change_list_options, change_list_option, chalo (
{   errors, error, e: file = $optional
{   output, o: file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 10, 24, 10, 1, 20, 479],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'JMM$MANO_CHALO'], [
    ['E                              ',clc$abbreviation_entry, 1],
    ['ERROR                          ',clc$alias_entry, 1],
    ['ERRORS                         ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$errors = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$errors].specified THEN
      error_file := pvt [p$errors].value^.file_value^;
    IFEND;

    IF pvt [p$output].specified THEN
      output_file := pvt [p$output].value^.file_value^;
    IFEND;

  PROCEND change_list_options;
?? OLDTITLE ??
?? NEWTITLE := 'close_error_file', EJECT ??

  PROCEDURE close_error_file
    (VAR status: ost$status);

    IF error_file_open THEN
      clp$close_display (display_control, status);
      IF status.normal THEN
        error_file_open := FALSE;
        #SPOIL (error_file_open);
      IFEND;
    IFEND;

  PROCEND close_error_file;
?? OLDTITLE ??
?? NEWTITLE := 'display_status_error', EJECT ??

  PROCEDURE display_status_error
    (    error_status: ost$status;
     VAR status: ost$status);

    VAR
      line_count: 1 .. osc$max_status_message_lines,
      status_message_p: ^ost$status_message,
      status_message_line_count_p: ^ost$status_message_line_count,
      status_message_line_p: ^ost$status_message_line,
      status_message_line_size_p: ^ost$status_message_line_size,
      status_message: ost$status_message;

    IF error_status.normal THEN
      RETURN;
    IFEND;

    IF NOT error_file_open THEN
      open_error_file (error_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    osp$format_message (error_status, osc$full_message_level, display_control.page_width, status_message,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    status_message_p := ^status_message;
    RESET status_message_p;
    NEXT status_message_line_count_p IN status_message_p;
    FOR line_count := 1 TO status_message_line_count_p^ DO
      NEXT status_message_line_size_p IN status_message_p;
      NEXT status_message_line_p: [status_message_line_size_p^] IN status_message_p;
      clp$put_display (display_control, status_message_line_p^, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;
  PROCEND display_status_error;
?? OLDTITLE ??
?? NEWTITLE := 'establish_display_title', EJECT ??

  PROCEDURE [INLINE] establish_display_title
    (    command_title: string ( * ));

    clv$titles_built := FALSE;
    clv$command_name := command_title;

  PROCEND establish_display_title;
?? OLDTITLE ??
?? NEWTITLE := 'log_restored_job_files', EJECT ??

  PROCEDURE log_restored_job_files
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ procedure (jmm$manj_logrjf) log_restored_job_files (
{   files_restored, fr: list 0..clc$max_list_size of name = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 10, 14, 14, 14, 16, 367],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'JMM$MANJ_LOGRJF'], [
    ['FILES_RESTORED                 ',clc$nominal_entry, 1],
    ['FR                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 0, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$files_restored = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      ignore_status: ost$status,
      job_count: 0 .. clc$max_list_size,
      job_list: ^clt$data_value,
      job_name: jmt$name,
      job_number: 0 .. clc$max_list_size,
      local_status: ost$status;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);
    establish_display_title ('log_restored_job_files');
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  Process the FILES_RESTORED parameter.

    job_count := clp$count_list_elements (pvt [p$files_restored].value);
    job_list := pvt [p$files_restored].value;

  /log_each_file/
    FOR job_number := 1 TO job_count DO
      jmp$determine_name_kind (job_list^.element_value^.name_value, job_name, local_status);
      IF NOT local_status.normal THEN
        display_status_error (local_status, ignore_status);
      ELSEIF job_name.kind <> jmc$system_supplied_name THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, job_name.user_supplied_name,
              local_status);
        display_status_error (local_status, ignore_status);
      ELSE

        jmp$log_restored_job (job_name.system_supplied_name, local_status);
        IF NOT local_status.normal THEN
          IF local_status.condition = jme$jh_job_history_not_active THEN
            status := local_status;
            EXIT /log_each_file/;
          IFEND;

          display_status_error (local_status, ignore_status);
        IFEND;
      IFEND;

      job_list := job_list^.link;
    FOREND /log_each_file/;

    IF error_file_open THEN
      close_error_file (ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND log_restored_job_files;
?? OLDTITLE ??
?? NEWTITLE := 'open_error_file', EJECT ??

  PROCEDURE open_error_file
    (    error_file: fst$file_reference;
     VAR status: ost$status);

    VAR
      default_ring_attributes: amt$ring_attributes;

    status.normal := TRUE;
    IF NOT error_file_open THEN

      default_ring_attributes.r1 := #RING (^default_ring_attributes);
      default_ring_attributes.r2 := #RING (^default_ring_attributes);
      default_ring_attributes.r3 := #RING (^default_ring_attributes);

      clp$open_display_reference (error_file, ^clp$new_page_procedure, fsc$list, default_ring_attributes,
            display_control, status);
      IF status.normal THEN
        error_file_open := TRUE;
        #SPOIL (error_file_open);
      IFEND;
    IFEND;

  PROCEND open_error_file;
?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle', EJECT ??

  PROCEDURE [INLINE] put_subtitle
    (VAR display_control: clt$display_control;
     VAR status: ost$status);

{ These displays do not have subtitles.  This is merely a dummy routine to keep the module consistant
{ with those that do produce subtitles.

  PROCEND put_subtitle;
?? OLDTITLE ??
?? NEWTITLE := 'queued_job_path', EJECT ??

  PROCEDURE queued_job_path
    (    parameter_list: clt$parameter_list;
     VAR work_area { input, output } : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ function (jmm$manj_$qjp) $queued_job_path (
{   names: list 0..clc$max_list_size of name = jmv$selected_jobs)

?? 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$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        default_value: string (17),
      recend,
    recend := [
    [1,
    [89, 10, 14, 14, 14, 16, 767],
    clc$function, 1, 1, 0, 0, 0, 0, 0, 'JMM$MANJ_$QJP'], [
    ['NAMES                          ',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, 21,
  clc$optional_default_parameter, 0, 17]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 0, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'jmv$selected_jobs']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$names = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      file_reference: string (fsc$max_path_size),
      ignore_status: ost$status,
      job_name: jmt$name,
      name_count: 0 .. clc$max_list_size,
      name_list: ^clt$data_value,
      name_number: 0 .. clc$max_list_size,
      node: ^clt$data_value,
      path: jmt$queue_file_path;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_list_value (work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    node := result;

{ Process the NAMES parameter.

    name_count := clp$count_list_elements (pvt [p$names].value);
    name_list := pvt [p$names].value;

  /get_each_path/
    FOR name_number := 1 TO name_count DO

      jmp$determine_name_kind (name_list^.element_value^.name_value, job_name, status);
      IF NOT status.normal THEN
        EXIT /get_each_path/;
      IFEND;
      IF job_name.kind <> jmc$system_supplied_name THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, job_name.user_supplied_name,
              status);
        EXIT /get_each_path/;
      IFEND;

      jmp$get_job_path_elements (job_name.system_supplied_name, path, status);
      IF NOT status.normal THEN
        EXIT /get_each_path/;
      IFEND;

      fsp$build_file_ref_from_elems (^path, file_reference, status);
      IF NOT status.normal THEN
        EXIT /get_each_path/;
      IFEND;

      clp$make_list_value (work_area, node^.link);
      IF node^.link = NIL THEN
        osp$set_status_condition (cle$work_area_overflow, status);
        EXIT /get_each_path/;
      IFEND;

      node := node^.link;
      clp$make_file_value (file_reference, work_area, node^.element_value);
      IF node^.element_value = NIL THEN
        osp$set_status_condition (cle$work_area_overflow, status);
        EXIT /get_each_path/;
      IFEND;

      name_list := name_list^.link;
    FOREND /get_each_path/;

{ Skip the empty first list element if the list has some real items in it.

    IF result^.link <> NIL THEN
      result := result^.link;
    IFEND;

  PROCEND queued_job_path;
?? OLDTITLE ??
?? NEWTITLE := 'quit', EJECT ??

  PROCEDURE quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (jmm$manj_qui) quit, qui (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 1, 29, 9, 16, 58, 596], clc$command, 1, 1, 0, 0, 0, 0, 1, 'JMM$MANJ_QUI'],
            [['STATUS                         ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      ignore_status: ost$status;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$delete_scratch_segment (work_area, ignore_status);

    clp$end_include (utility_name, status);

{ Exit the utility.

  PROCEND quit;
?? OLDTITLE ??
?? NEWTITLE := 'select_job', EJECT ??

  PROCEDURE select_job
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (jmm$manj_selj) select_job, select_jobs, selj (
{   control_family, control_families, cf: list of name = $optional
{   control_user, control_users, cu: list of name = $optional
{   job_category_name, job_category_names, jcn: list of name = $optional
{   job_class, job_classes, jc: list of name = $optional
{   job_deferred_by_operator, jdbo: boolean = $optional
{   job_deferred_by_user, jdbu: boolean = $optional
{   job_qualifier, job_qualifiers, jq: list of name = $optional
{   job_state, job_states, js: any of
{       key
{         all
{       keyend
{       list of key
{         (deferred, d)
{         (queued, q)
{         (initiated, i)
{         (terminated, t)
{         (completed, c)
{       keyend
{     anyend = $optional
{   login_account, login_accounts, la: list of name = $optional
{   login_family, login_families, lf: list of name = $optional
{   login_project, login_projects, lp: list of name = $optional
{   login_user, login_users, lu: list of name = $optional
{   name, names, n: list of name = $optional
{   site_information, si: list of string 0..jmc$site_information_size = $optional
{   user_information, ui: list of string 0..jmc$user_information_size = $optional
{   maximum_selection, ms: any of
{       key
{         all
{       keyend
{       integer 1..jmc$maximum_job_count
{     anyend = all
{   mainframe, mainframes, m: key
{       all
{       (current, c)
{     keyend = current
{   job_selection_list, jsl: (VAR) list 0..clc$max_list_size of name = jmv$selected_jobs
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 49] of clt$pdt_parameter_name,
      parameters: array [1 .. 19] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type8: 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 .. 10] of clt$keyword_specification,
          recend,
        recend,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type13: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type14: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type15: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type16: 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$integer_type_qualifier,
        recend,
        default_value: string (3),
      recend,
      type17: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type18: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        default_value: string (17),
      recend,
      type19: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 2, 13, 20, 29, 27, 678],
    clc$command, 49, 19, 0, 0, 0, 1, 19, 'JMM$MANJ_SELJ'], [
    ['CF                             ',clc$abbreviation_entry, 1],
    ['CONTROL_FAMILIES               ',clc$alias_entry, 1],
    ['CONTROL_FAMILY                 ',clc$nominal_entry, 1],
    ['CONTROL_USER                   ',clc$nominal_entry, 2],
    ['CONTROL_USERS                  ',clc$alias_entry, 2],
    ['CU                             ',clc$abbreviation_entry, 2],
    ['JC                             ',clc$abbreviation_entry, 4],
    ['JCN                            ',clc$abbreviation_entry, 3],
    ['JDBO                           ',clc$abbreviation_entry, 5],
    ['JDBU                           ',clc$abbreviation_entry, 6],
    ['JOB_CATEGORY_NAME              ',clc$nominal_entry, 3],
    ['JOB_CATEGORY_NAMES             ',clc$alias_entry, 3],
    ['JOB_CLASS                      ',clc$nominal_entry, 4],
    ['JOB_CLASSES                    ',clc$alias_entry, 4],
    ['JOB_DEFERRED_BY_OPERATOR       ',clc$nominal_entry, 5],
    ['JOB_DEFERRED_BY_USER           ',clc$nominal_entry, 6],
    ['JOB_QUALIFIER                  ',clc$nominal_entry, 7],
    ['JOB_QUALIFIERS                 ',clc$alias_entry, 7],
    ['JOB_SELECTION_LIST             ',clc$nominal_entry, 18],
    ['JOB_STATE                      ',clc$nominal_entry, 8],
    ['JOB_STATES                     ',clc$alias_entry, 8],
    ['JQ                             ',clc$abbreviation_entry, 7],
    ['JS                             ',clc$abbreviation_entry, 8],
    ['JSL                            ',clc$abbreviation_entry, 18],
    ['LA                             ',clc$abbreviation_entry, 9],
    ['LF                             ',clc$abbreviation_entry, 10],
    ['LOGIN_ACCOUNT                  ',clc$nominal_entry, 9],
    ['LOGIN_ACCOUNTS                 ',clc$alias_entry, 9],
    ['LOGIN_FAMILIES                 ',clc$alias_entry, 10],
    ['LOGIN_FAMILY                   ',clc$nominal_entry, 10],
    ['LOGIN_PROJECT                  ',clc$nominal_entry, 11],
    ['LOGIN_PROJECTS                 ',clc$alias_entry, 11],
    ['LOGIN_USER                     ',clc$nominal_entry, 12],
    ['LOGIN_USERS                    ',clc$alias_entry, 12],
    ['LP                             ',clc$abbreviation_entry, 11],
    ['LU                             ',clc$abbreviation_entry, 12],
    ['M                              ',clc$abbreviation_entry, 17],
    ['MAINFRAME                      ',clc$nominal_entry, 17],
    ['MAINFRAMES                     ',clc$alias_entry, 17],
    ['MAXIMUM_SELECTION              ',clc$nominal_entry, 16],
    ['MS                             ',clc$abbreviation_entry, 16],
    ['N                              ',clc$abbreviation_entry, 13],
    ['NAME                           ',clc$nominal_entry, 13],
    ['NAMES                          ',clc$alias_entry, 13],
    ['SI                             ',clc$abbreviation_entry, 14],
    ['SITE_INFORMATION               ',clc$nominal_entry, 14],
    ['STATUS                         ',clc$nominal_entry, 19],
    ['UI                             ',clc$abbreviation_entry, 15],
    ['USER_INFORMATION               ',clc$nominal_entry, 15]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 5
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 6
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 7
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 8
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 457,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [27, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 10
    [30, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 11
    [31, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 12
    [33, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 13
    [43, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 14
    [46, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 24, clc$optional_parameter,
  0, 0],
{ PARAMETER 15
    [49, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 24, clc$optional_parameter,
  0, 0],
{ PARAMETER 16
    [40, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 17
    [38, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 18
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 21,
  clc$optional_default_parameter, 0, 17],
{ PARAMETER 19
    [47, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 3
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 4
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 5
    [[1, 0, clc$boolean_type]],
{ PARAMETER 6
    [[1, 0, clc$boolean_type]],
{ PARAMETER 7
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 8
    [[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]]
      ],
    393, [[1, 0, clc$list_type], [377, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [10], [
        ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['COMPLETED                      ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['DEFERRED                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['INITIATED                      ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['Q                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['QUEUED                         ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['TERMINATED                     ', clc$nominal_entry, clc$normal_usage_entry, 4]]
        ]
      ]
    ],
{ PARAMETER 9
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 10
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 11
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 12
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 13
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 14
    [[1, 0, clc$list_type], [8, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$string_type], [0, jmc$site_information_size, FALSE]]
    ],
{ PARAMETER 15
    [[1, 0, clc$list_type], [8, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$string_type], [0, jmc$user_information_size, FALSE]]
    ],
{ PARAMETER 16
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, jmc$maximum_job_count, 10]]
    ,
    'all'],
{ PARAMETER 17
    [[1, 0, clc$keyword_type], [3], [
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['CURRENT                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'current'],
{ PARAMETER 18
    [[1, 0, clc$list_type], [5, 0, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'jmv$selected_jobs'],
{ PARAMETER 19
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$control_family = 1,
      p$control_user = 2,
      p$job_category_name = 3,
      p$job_class = 4,
      p$job_deferred_by_operator = 5,
      p$job_deferred_by_user = 6,
      p$job_qualifier = 7,
      p$job_state = 8,
      p$login_account = 9,
      p$login_family = 10,
      p$login_project = 11,
      p$login_user = 12,
      p$name = 13,
      p$site_information = 14,
      p$user_information = 15,
      p$maximum_selection = 16,
      p$mainframe = 17,
      p$job_selection_list = 18,
      p$status = 19;

    VAR
      pvt: array [1 .. 19] of clt$parameter_value;

    VAR
      attribute_count: clt$parameter_count,
      i: ost$non_negative_integers,
      input_attribute_options_p: ^jmt$input_attribute_options,
      input_attribute_results_keys_p: ^jmt$results_keys,
      input_attribute_results_p: ^jmt$input_attribute_results,
      job_category_index: jmt$job_category_count,
      job_index: ost$non_negative_integers,
      job_matches_criteria: boolean,
      job_qualifier_index: 1 .. jmc$maximum_job_qualifiers,
      job_selection_list: ^clt$data_value,
      job_state: jmt$job_state,
      list_value: ^clt$data_value,
      maximum_selection: 1 .. jmc$maximum_job_count,
      number_of_inputs_found: jmt$job_status_count,
      number_of_inputs_selected: 0 .. jmc$maximum_job_count,
      number_of_names: ost$non_negative_integers,
      parameter_index: clt$parameter_count,
      value: ^clt$data_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Using the items specified as selection items, build a set of "search" criteria
{ for the jmp$get_input_attributes request.  Using the other specified items as
{ "requested" information, call the interface jmp$get_input_attributes request.
{ This returns an array of job's with their attributes.
{ NOTE:
{   A subset of the select_job selection parameters is used as search criteria
{ on the jmp$get_input_attributes request as a performance measure.  This way,
{ the fewest number of files need to be attached within the request.

    attribute_count := p$maximum_selection - 1;
    PUSH input_attribute_options_p: [1 .. attribute_count + 1];
    PUSH input_attribute_results_keys_p: [1 .. attribute_count];

    RESET work_area.sequence_pointer;
    number_of_names := 0;

    FOR parameter_index := 1 TO attribute_count DO
      input_attribute_options_p^ [parameter_index].key := jmc$null_attribute;
      input_attribute_results_keys_p^ [parameter_index] := jmc$null_attribute;
      IF pvt [parameter_index].specified THEN
        CASE parameter_index OF
        = p$control_family =
          IF clp$count_list_elements (pvt [parameter_index].value) = 1 THEN
            input_attribute_options_p^ [parameter_index].key := jmc$control_family;
            input_attribute_options_p^ [parameter_index].control_family :=
                  pvt [parameter_index].value^.element_value^.name_value;
          ELSE
            input_attribute_results_keys_p^ [parameter_index] := jmc$control_family;
          IFEND;

        = p$control_user =
          IF clp$count_list_elements (pvt [parameter_index].value) = 1 THEN
            input_attribute_options_p^ [parameter_index].key := jmc$control_user;
            input_attribute_options_p^ [parameter_index].control_user :=
                  pvt [parameter_index].value^.element_value^.name_value;
          ELSE
            input_attribute_results_keys_p^ [parameter_index] := jmc$control_user;
          IFEND;

        = p$job_category_name =
          input_attribute_results_keys_p^ [parameter_index] := jmc$job_category_list;

        = p$job_class =
          input_attribute_results_keys_p^ [parameter_index] := jmc$job_class;

        = p$job_deferred_by_operator =
          input_attribute_options_p^ [parameter_index].key := jmc$job_deferred_by_operator;
          input_attribute_options_p^ [parameter_index].job_deferred_by_operator := pvt [parameter_index].
                value^.boolean_value.value;

        = p$job_deferred_by_user =
          input_attribute_options_p^ [parameter_index].key := jmc$job_deferred_by_user;
          input_attribute_options_p^ [parameter_index].job_deferred_by_user :=
                pvt [parameter_index].value^.boolean_value.value;

        = p$job_qualifier =
          input_attribute_results_keys_p^ [parameter_index] := jmc$job_qualifier_list;

        = p$job_state =

{ If the keyword ALL was specified for job_state there is no need to get the attribute value.

          IF pvt [p$job_state].value^.kind = clc$list THEN
            input_attribute_options_p^ [parameter_index].key := jmc$job_state_set;
            input_attribute_options_p^ [parameter_index].job_state_set := $jmt$job_state_set [];
            FOR job_state := LOWERVALUE (jmt$job_state) TO UPPERVALUE (jmt$job_state) DO
              value := pvt [p$job_state].value;
              WHILE (value <> NIL) AND (job_state_names [job_state] <> value^.element_value^.name_value) DO
                value := value^.link;
              WHILEND;
              IF (value <> NIL) THEN
                input_attribute_options_p^ [parameter_index].job_state_set :=
                      input_attribute_options_p^ [parameter_index].job_state_set +
                      $jmt$job_state_set [job_state];
              IFEND;
            FOREND;
          IFEND;

        = p$login_account =
          input_attribute_results_keys_p^ [parameter_index] := jmc$login_account;

        = p$login_family =
          IF clp$count_list_elements (pvt [parameter_index].value) = 1 THEN
            input_attribute_options_p^ [parameter_index].key := jmc$login_family;
            input_attribute_options_p^ [parameter_index].login_family :=
                  pvt [parameter_index].value^.element_value^.name_value;
          ELSE
            input_attribute_results_keys_p^ [parameter_index] := jmc$login_family;
          IFEND;

        = p$login_project =
          input_attribute_results_keys_p^ [parameter_index] := jmc$login_project;

        = p$login_user =
          IF clp$count_list_elements (pvt [parameter_index].value) = 1 THEN
            input_attribute_options_p^ [parameter_index].key := jmc$login_user;
            input_attribute_options_p^ [parameter_index].login_user :=
                  pvt [parameter_index].value^.element_value^.name_value;
          ELSE
            input_attribute_results_keys_p^ [parameter_index] := jmc$login_user;
          IFEND;

        = p$name =
          number_of_names := clp$count_list_elements (pvt [p$name].value);
          input_attribute_options_p^ [parameter_index].key := jmc$name_list;
          PUSH input_attribute_options_p^ [parameter_index].name_list: [1 .. number_of_names];

          value := pvt [p$name].value;
          FOR i := 1 TO number_of_names DO
            jmp$determine_name_kind (value^.element_value^.name_value,
                  input_attribute_options_p^ [parameter_index].name_list^ [i], status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            value := value^.link;
          FOREND;

        = p$site_information =
          input_attribute_results_keys_p^ [parameter_index] := jmc$site_information;

        = p$user_information =
          input_attribute_results_keys_p^ [parameter_index] := jmc$user_information;
        ELSE
          input_attribute_results_keys_p^ [parameter_index] := jmc$null_attribute;

        CASEND;
      IFEND;
    FOREND;

{ The system job name is always returned

    input_attribute_results_keys_p^ [p$name] := jmc$system_job_name;
    input_attribute_options_p^ [attribute_count + 1].key := jmc$continue_request_to_servers;
    IF pvt [p$mainframe].value^.keyword_value = 'CURRENT' THEN
      input_attribute_options_p^ [attribute_count + 1].continue_request_to_servers := FALSE;
    ELSE
      input_attribute_options_p^ [attribute_count + 1].continue_request_to_servers := TRUE;
    IFEND;

    jmp$get_input_attributes (input_attribute_options_p, input_attribute_results_keys_p,
          work_area.sequence_pointer, input_attribute_results_p, number_of_inputs_found, status);

    IF NOT status.normal THEN
      IF status.condition = jme$no_jobs_were_found THEN
        status.normal := TRUE;
        number_of_inputs_found := 0;
      ELSE
        RETURN;
      IFEND;
    IFEND;

{ Using the results of the above request, test each "requested" information value
{ against the appropriate select_job selection parameter.  If the job's value and
{ the parameter value(s) agree for each criteria specified, add the job to the
{ job selection list.  Otherwise, skip the job and go to the next job.

    maximum_selection := jmc$maximum_job_count;
    IF pvt [p$maximum_selection].specified AND (pvt [p$maximum_selection].value^.kind = clc$integer) THEN
      maximum_selection := pvt [p$maximum_selection].value^.integer_value.value;
    IFEND;
    number_of_inputs_selected := 0;

    NEXT job_selection_list IN work_area.sequence_pointer;
    job_selection_list^.kind := clc$list;
    job_selection_list^.element_value := NIL;
    job_selection_list^.link := NIL;
    job_selection_list^.generated_via_list_rest := FALSE;
    list_value := job_selection_list;

  /select_jobs_from_list/
    FOR job_index := 1 TO number_of_inputs_found DO
      job_matches_criteria := TRUE;

    /compare_job_attributes/
      FOR parameter_index := 1 TO attribute_count DO
        IF pvt [parameter_index].specified AND (input_attribute_results_keys_p^ [parameter_index] <>
              jmc$null_attribute) THEN
          CASE parameter_index OF
          = p$control_family =
            value := pvt [p$control_family].value;
            WHILE (value <> NIL) AND (input_attribute_results_p^ [job_index]^ [parameter_index].
                  control_family <> value^.element_value^.name_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              job_matches_criteria := FALSE;
              EXIT /compare_job_attributes/;
            IFEND;

          = p$control_user =
            value := pvt [p$control_user].value;
            WHILE (value <> NIL) AND (input_attribute_results_p^ [job_index]^ [parameter_index].
                  control_user <> value^.element_value^.name_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              job_matches_criteria := FALSE;
              EXIT /compare_job_attributes/;
            IFEND;

          = p$job_category_name =
            value := pvt [p$job_category_name].value;

          /find_job_category/
            BEGIN
              WHILE value <> NIL DO
                FOR job_category_index := 1 TO input_attribute_results_p^ [job_index]^ [parameter_index].
                      job_category_list.category_count DO
                  IF (input_attribute_results_p^ [job_index]^ [parameter_index].job_category_list.
                        category_list^ [job_category_index] = value^.element_value^.name_value) THEN
                    EXIT /find_job_category/;
                  IFEND;
                FOREND;
                value := value^.link;
              WHILEND;
              job_matches_criteria := FALSE;
              EXIT /compare_job_attributes/;
            END /find_job_category/;

          = p$job_class =
            value := pvt [p$job_class].value;
            WHILE (value <> NIL) AND (input_attribute_results_p^ [job_index]^ [parameter_index].job_class <>
                  value^.element_value^.name_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              job_matches_criteria := FALSE;
              EXIT /compare_job_attributes/;
            IFEND;

          = p$job_qualifier =
            value := pvt [p$job_qualifier].value;

          /find_job_qualifier/
            BEGIN
              WHILE value <> NIL DO
                FOR job_qualifier_index := 1 TO jmc$maximum_job_qualifiers DO
                  IF (input_attribute_results_p^ [job_index]^ [parameter_index].
                        job_qualifier_list^ [job_qualifier_index] = value^.element_value^.name_value) THEN
                    EXIT /find_job_qualifier/;
                  IFEND;
                FOREND;
                value := value^.link;
              WHILEND;
              job_matches_criteria := FALSE;
              EXIT /compare_job_attributes/;
            END /find_job_qualifier/;

          = p$login_account =
            value := pvt [p$login_account].value;
            WHILE (value <> NIL) AND (input_attribute_results_p^ [job_index]^ [parameter_index].
                  login_account <> value^.element_value^.name_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              job_matches_criteria := FALSE;
              EXIT /compare_job_attributes/;
            IFEND;

          = p$login_family =
            value := pvt [p$login_family].value;
            WHILE (value <> NIL) AND (input_attribute_results_p^ [job_index]^ [parameter_index].
                  login_family <> value^.element_value^.name_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              job_matches_criteria := FALSE;
              EXIT /compare_job_attributes/;
            IFEND;

          = p$login_project =
            value := pvt [p$login_project].value;
            WHILE (value <> NIL) AND (input_attribute_results_p^ [job_index]^ [parameter_index].
                  login_project <> value^.element_value^.name_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              job_matches_criteria := FALSE;
              EXIT /compare_job_attributes/;
            IFEND;

          = p$login_user =
            value := pvt [p$login_user].value;
            WHILE (value <> NIL) AND (input_attribute_results_p^ [job_index]^ [parameter_index].login_user <>
                  value^.element_value^.name_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              job_matches_criteria := FALSE;
              EXIT /compare_job_attributes/;
            IFEND;

          = p$site_information =
            value := pvt [p$site_information].value;
            WHILE (value <> NIL) AND (input_attribute_results_p^ [job_index]^ [parameter_index].
                  site_information^ <> value^.element_value^.string_value^) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              job_matches_criteria := FALSE;
              EXIT /compare_job_attributes/;
            IFEND;

          = p$user_information =
            value := pvt [p$user_information].value;
            WHILE (value <> NIL) AND (input_attribute_results_p^ [job_index]^ [parameter_index].
                  user_information^ <> value^.element_value^.string_value^) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              job_matches_criteria := FALSE;
              EXIT /compare_job_attributes/;
            IFEND;

          ELSE
            ;

          CASEND;
        IFEND;
      FOREND /compare_job_attributes/;
      IF job_matches_criteria THEN
        number_of_inputs_selected := number_of_inputs_selected + 1;

        IF list_value^.element_value <> NIL THEN
          NEXT list_value^.link IN work_area.sequence_pointer;
          list_value := list_value^.link;
          list_value^.kind := clc$list;
        IFEND;

        NEXT list_value^.element_value IN work_area.sequence_pointer;
        list_value^.element_value^.kind := clc$name;
        list_value^.element_value^.name_value := input_attribute_results_p^ [job_index]^ [p$name].
              system_job_name;
        list_value^.link := NIL;
        list_value^.generated_via_list_rest := FALSE;

        IF number_of_inputs_selected = maximum_selection THEN
          EXIT /select_jobs_from_list/;
        IFEND;
      IFEND;
    FOREND /select_jobs_from_list/;

    clp$change_variable (pvt [p$job_selection_list].variable^, job_selection_list, status);
  PROCEND select_job;
*copy clp$new_page_procedure
?? OLDTITLE ??
MODEND jmm$manage_job_utility;
*DECK DECK=JMM$MANAGE_JOB_UTILITY_PD EXPAND=TRUE
create_program_description name=(manage_job, manage_jobs, manj) sp=jmp$manage_job_utility ..
      l='$system.osf$system_library' tel=warning lmo=none lm=$null dm=off
*DECK DECK=JMM$MANAGE_OUTPUT_UTILITY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : Manage Output Utility' ??
MODULE jmm$manage_output_utility;

{ PURPOSE:
{   This module contains the command and subcommands for the NOS/VE Manage
{ Output Utility.  The utility is used to manage output files in NOS/VE.
{
{ DESIGN:
{   This utility is a standalone utility outside of the operating system.  It is
{ available to all users.  Some commands may be restricted to a certain class of
{ users, e.g. system operators.  This restriction will be noted with any affected
{ commands.
{
{   This utility runs in the caller's ring.
{
{   Commands in this utility are designed to process an entire list of arguments
{ and report errors as they occur.  (This is intended for future sub-commands).

?? NEWTITLE := 'Global Declarations Referenced By This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc jmc$job_management_id
*copyc jmc$system_family
*copyc jme$job_history_conditions
*copyc jme$queued_file_conditions
*copyc jmt$attribute_keys
*copyc jmt$attribute_values
*copyc jmt$error_status_list
*copyc osd$integer_limits
*copyc ost$status
?? POP ??
*copyc avp$system_administrator
*copyc avp$system_operator
*copyc clp$begin_utility
*copyc clp$build_standard_title
*copyc clp$change_variable
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_file
*copyc clp$count_list_elements
*copyc clp$create_environment_variable
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc clp$make_file_value
*copyc clp$make_list_value
*copyc clp$make_name_value
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc fsp$build_file_ref_from_elems
*copyc jmp$activate_output
*copyc jmp$combine_offline_output
*copyc jmp$determine_name_kind
*copyc jmp$display_attributes
*copyc jmp$get_output_attributes
*copyc jmp$get_output_counts
*copyc jmp$get_output_path_elements
*copyc jmp$get_output_status
*copyc jmp$log_restored_output
*copyc jmp$system_job
*copyc jmp$validate_name
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$format_message
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_multi_item_info
*copyc pmp$get_legible_date_time
*copyc osv$lower_to_upper
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared By This Module', EJECT ??

*copy clv$display_variables

  SECTION
    read_only: READ;

  CONST
    utility_prompt_length = 2,
    utility_prompt = 'MO';

  VAR
    display_control: [STATIC] clt$display_control,
    error_file: [STATIC] fst$path := ':$LOCAL.$ERRORS',
    error_file_open: [STATIC] boolean := FALSE,
    output_file: [STATIC] fst$path := ':$LOCAL.$OUTPUT',
    system_administrator: boolean,
    system_operator: boolean;

  VAR
    data_mode_names: [STATIC, READ, read_only] array [jmt$data_mode] of string (13) := ['CODED',
          'RHF_STRUCTURE', 'TRANSPARENT'],
    output_state_names: [STATIC, READ, read_only] array [jmt$output_state] of string (10) := ['DEFERRED',
          'QUEUED', 'INITIATED', 'TERMINATED', 'COMPLETED'],
    utility_name: [STATIC, READ, read_only] clt$utility_name := 'manage_output',
    work_area: amt$segment_pointer;

?? OLDTITLE ??
?? NEWTITLE := 'Commands for the Manage_Output Utility', EJECT ??

{ table name=manage_output_commands type=command section_name=read_only scope=local
{ command (change_list_options            , change_list_option, chalo) p=change_list_options cm=local
{ command (quit                           , qui) p=quit cm=local
{ command (select_output                  , selo) p=select_output cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    manage_output_commands: [STATIC, READ, read_only] ^clt$command_table := ^manage_output_commands_entries,

    manage_output_commands_entries: [STATIC, READ, read_only] array [1 .. 7] of clt$command_table_entry := [
          {} ['CHALO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^change_list_options],
          {} ['CHANGE_LIST_OPTION             ', clc$alias_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^change_list_options],
          {} ['CHANGE_LIST_OPTIONS            ', clc$nominal_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^change_list_options],
          {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^quit],
          {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^quit],
          {} ['SELECT_OUTPUT                  ', clc$nominal_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^select_output],
          {} ['SELO                           ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^select_output]];

?? POP ??

{ table name=operator_mano_commands type=command section_name=read_only scope=local
{ command activate_output_files p=activate_output_files cm=local
{ command (change_list_options            , change_list_option, chalo) p=change_list_options cm=local
{ command (combine_offline_output         , comoo) p=combine_offline_output cm=local
{ command (forward_offline_output         , foroo) p=jmm$forward_offline_output cm=procedure
{ command log_restored_output_files p=log_restored_output_files cm=local
{ command (quit                           , qui) p=quit cm=local
{ command (select_output                  , selo) p=select_output cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    operator_mano_commands: [STATIC, READ, read_only] ^clt$command_table := ^operator_mano_commands_entries,

    operator_mano_commands_entries: [STATIC, READ, read_only] array [1 .. 13] of clt$command_table_entry := [
          {} ['ACTIVATE_OUTPUT_FILES          ', clc$nominal_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^activate_output_files],
          {} ['CHALO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^change_list_options],
          {} ['CHANGE_LIST_OPTION             ', clc$alias_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^change_list_options],
          {} ['CHANGE_LIST_OPTIONS            ', clc$nominal_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^change_list_options],
          {} ['COMBINE_OFFLINE_OUTPUT         ', clc$nominal_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^combine_offline_output],
          {} ['COMOO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^combine_offline_output],
          {} ['FOROO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$proc_call, 'JMM$FORWARD_OFFLINE_OUTPUT'],
          {} ['FORWARD_OFFLINE_OUTPUT         ', clc$nominal_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$proc_call, 'JMM$FORWARD_OFFLINE_OUTPUT'],
          {} ['LOG_RESTORED_OUTPUT_FILES      ', clc$nominal_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^log_restored_output_files],
          {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
          clc$automatically_log, clc$linked_call, ^quit],
          {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 6,
          clc$automatically_log, clc$linked_call, ^quit],
          {} ['SELECT_OUTPUT                  ', clc$nominal_entry, clc$normal_usage_entry, 7,
          clc$automatically_log, clc$linked_call, ^select_output],
          {} ['SELO                           ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
          clc$automatically_log, clc$linked_call, ^select_output]];

?? POP ??

{ table name=sys_admin_functions type=function section_name=read_only scope=local
{ function $queued_output_path p=queued_output_path cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    sys_admin_functions: [STATIC, READ, read_only] ^clt$function_processor_table :=
          ^sys_admin_functions_entries,

    sys_admin_functions_entries: [STATIC, READ, read_only] array [1 .. 1] of
          clt$function_proc_table_entry := [
          {} ['$QUEUED_OUTPUT_PATH            ', clc$nominal_entry, clc$normal_usage_entry, 1,
          clc$linked_call, ^queued_output_path]];

?? POP ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$manage_output_utility', EJECT ??

{ PURPOSE:
{   This is the entry point that begins the manage output utility.

  PROGRAM jmp$manage_output_utility
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (jmm$mano) manage_output, mano (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 1, 27, 12, 47, 15, 159], clc$command, 1, 1, 0, 0, 0, 0, 1, 'JMM$MANO'],
            [['STATUS                         ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

{ TYPE
{   selected_output_type: list 0 .. clc$max_list_size of name
{ TYPEND;

?? PUSH (LISTEXT := ON) ??

    VAR
      type_specification: [STATIC, READ, cls$declaration_section] record
        header: clt$type_specification_header,
        name: string (20),
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend := [[1, 20, clc$list_type], 'SELECTED_OUTPUT_TYPE',
            [5, 0, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]];

?? POP ??

    VAR
      utility_attributes_p: ^clt$utility_attributes;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    system_administrator := avp$system_administrator ();
    system_operator := avp$system_operator ();

    IF system_administrator THEN
      PUSH utility_attributes_p: [1 .. 5];
    ELSE
      PUSH utility_attributes_p: [1 .. 4];
    IFEND;
    utility_attributes_p^ [1].key := clc$utility_command_search_mode;
    utility_attributes_p^ [1].command_search_mode := clc$global_command_search;
    utility_attributes_p^ [2].key := clc$utility_command_table;
    IF system_administrator OR system_operator THEN
      utility_attributes_p^ [2].command_table := operator_mano_commands;
    ELSE
      utility_attributes_p^ [2].command_table := manage_output_commands;
    IFEND;
    utility_attributes_p^ [3].key := clc$utility_prompt;
    utility_attributes_p^ [3].prompt.value := utility_prompt;
    utility_attributes_p^ [3].prompt.size := utility_prompt_length;
    utility_attributes_p^ [4].key := clc$utility_termination_command;
    utility_attributes_p^ [4].termination_command := 'quit';
    IF system_administrator THEN
      utility_attributes_p^ [5].key := clc$utility_function_proc_table;
      utility_attributes_p^ [5].function_processor_table := sys_admin_functions;
    IFEND;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, work_area, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Begin the utility environment.  Establish the command list, and scan the
{ command file for commands.

    clp$begin_utility (utility_name, utility_attributes_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$create_environment_variable ('JMV$SELECTED_OUTPUT', clc$utility_scope, clc$read_write,
          clc$immediate_evaluation, #SEQ (type_specification), NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, utility_prompt, utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ End the utility environment and exit the utility.

    clp$end_utility (utility_name, status);

  PROCEND jmp$manage_output_utility;
?? NEWTITLE := 'activate_output_files', EJECT ??

  PROCEDURE activate_output_files
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ procedure (jmm$mano_actof) activate_output_files (
{   files_activated, fa: (var) list 0..clc$max_list_size of name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 10, 14, 14, 14, 17, 114],
    clc$command, 3, 2, 0, 0, 0, 1, 2, 'JMM$MANO_ACTOF'], [
    ['FA                             ',clc$abbreviation_entry, 1],
    ['FILES_ACTIVATED                ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 21,
  clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 0, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$files_activated = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    CONST
      maximum_result_item_count = 2,
      ri_system_file_name = 1,
      ri_output_destination_usage = 2;

    VAR
      catalog_segment_pointer: amt$segment_pointer,
      file_count: 0 .. clc$max_list_size,
      file_list: ^clt$data_value,
      file_number: 1 .. clc$max_list_size,
      files_activated: ^clt$data_value,
      ignore_status: ost$status,
      known_output_count: jmt$output_count_range,
      known_output_p: ^jmt$output_status_results,
      list_value: ^clt$data_value,
      local_status: ost$status,
      status_result_keys_p: ^jmt$results_keys;

?? NEWTITLE := 'read_directory', EJECT ??

{
{    The purpose of this request is to read the directory of a specified
{  catalog.   A sequence is used as a placeholder for the directory.
{  The directory is returned as a pointer to an adaptable array of names.
{
{        READ_DIRECTORY (CATALOG_PATH, CATALOG_SEQUENCE_P, DIRECTORY_ARRAY_P, STATUS);
{
{ CATALOG_PATH: (input) This is the path of the catalog to read.
{
{ CATALOG_SEQUENCE_P: (input/output) This is a sequence used by the permanent file
{        interfaces for storing the raw catalog data.
{
{ DIRECTORY_ARRAY_P: (output) This is a pointer to an adaptable array of the
{        names in the catalog's directory.
{
{ STATUS: (output) This is the status of the request.
{

    PROCEDURE read_directory
      (    catalog_path: pft$path;
       VAR catalog_sequence_p: ^SEQ ( * );
       VAR directory_array_p: pft$p_directory_array;
       VAR status: ost$status);

      VAR
        group: pft$group,
        info_record_p: pft$p_info_record;

      status.normal := TRUE;
      RESET catalog_sequence_p;
      group.group_type := pfc$public;
      directory_array_p := NIL;

{ Get the raw catalog data.

      pfp$get_multi_item_info (catalog_path, group, $pft$catalog_info_selections [],
            $pft$file_info_selections [pfc$file_description], catalog_sequence_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Find the first info record in the sequence.

      RESET catalog_sequence_p;
      pfp$find_next_info_record (catalog_sequence_p, info_record_p, status);
      IF status.normal AND (info_record_p = NIL) THEN
        osp$set_status_abnormal ('JM', jme$unable_to_recover_catalog, catalog_path [1], status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Get an array of names of entities in the catalog.

      pfp$find_directory_array (info_record_p, directory_array_p, status);

    PROCEND read_directory;
?? OLDTITLE ??
?? NEWTITLE := 'recover_output_queue', EJECT ??

{ PURPOSE:
{   The purpose of this request is to recover the standard output queue catalog.
{
{ DESIGN:
{   Compare the names of the files in the catalog with the list of names in the KOL.  If there is no
{ entry in the KOL, then the output has not been queued, so attempt to recover it.

    PROCEDURE recover_output_queue
      (    subcatalog_name: ost$name;
           known_output_p: ^jmt$output_status_results;
           known_output_count: jmt$output_count_range;
       VAR node: ^clt$data_value;
       VAR work_area: ^clt$work_area;
       VAR catalog_sequence_p: ^SEQ ( * );
       VAR status: ost$status);

      VAR
        directory_array_p: pft$p_directory_array,
        ignore_status: ost$status,
        known_output_index: jmt$output_count_range,
        local_status: ost$status,
        name_index: pft$array_index,
        output_destination_usage: jmt$destination_usage,
        path_p: ^pft$path,
        system_file_name: jmt$system_supplied_name;

      status.normal := TRUE;
      PUSH path_p: [pfc$family_name_index .. pfc$subcatalog_name_index];
      path_p^ [pfc$family_name_index] := jmc$system_family;
      path_p^ [pfc$master_catalog_name_index] := jmc$system_user;
      path_p^ [pfc$subcatalog_name_index] := subcatalog_name;

{ Read the output catalog.

      read_directory (path_p^, catalog_sequence_p, directory_array_p, local_status);
      IF NOT local_status.normal THEN
        display_status_error (local_status, ignore_status);
        RETURN;
      IFEND;

{ Recover the output queue.

      IF directory_array_p <> NIL THEN

      /recover_all_files/
        FOR name_index := 1 TO UPPERBOUND (directory_array_p^) DO

          system_file_name := directory_array_p^ [name_index].name;

{ Check to see if the output file is known to the system.

          search_known_output (system_file_name, known_output_p, known_output_count, known_output_index);
          IF known_output_index <> 0 THEN
            output_destination_usage := known_output_p^ [known_output_index]^ [ri_output_destination_usage].
                  output_destination_usage;
            IF subcatalog_name = jmc$sf_job_output_catalog THEN
              IF (output_destination_usage = jmc$public_usage) OR
                    (output_destination_usage = jmc$private_usage) OR
                    (output_destination_usage = jmc$dual_state_usage) THEN

                osp$set_status_abnormal (jmc$job_management_id, jme$output_was_not_recovered,
                      system_file_name, local_status);
                display_status_error (local_status, ignore_status);

              IFEND;
            ELSEIF (output_destination_usage <> jmc$public_usage) AND
                  (output_destination_usage <> jmc$private_usage) AND
                  (output_destination_usage <> jmc$dual_state_usage) THEN

{             osp$set_status_abnormal (jmc$job_management_id, jme$output_was_not_recovered, system_file_name,
{                   local_status);
{             display_status_error (local_status, ignore_status);

            IFEND;

            CYCLE /recover_all_files/;
          IFEND;

{ The file is not in the KOL.  Try to recover the file.

          jmp$activate_output (system_file_name, subcatalog_name, local_status);
          IF local_status.normal THEN
            clp$make_list_value (work_area, node^.link);
            IF node^.link = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              RETURN;
            IFEND;

            node := node^.link;
            clp$make_name_value (system_file_name, work_area, node^.element_value);
            IF node^.element_value = NIL THEN
              osp$set_status_condition (cle$work_area_overflow, status);
              RETURN;
            IFEND;
          ELSE
            osp$set_status_abnormal (jmc$job_management_id, jme$output_was_not_recovered, system_file_name,
                  status);
            display_status_error (local_status, ignore_status);
            display_status_error (status, ignore_status);
            status.normal := TRUE;
          IFEND;
        FOREND /recover_all_files/;
      IFEND;
    PROCEND recover_output_queue;
?? OLDTITLE ??
?? NEWTITLE := 'search_known_output', EJECT ??

{ PURPOSE:
{   The purpose of this request is to search a table of file names from the KOL
{ for a specific system file name.
{
{ DESIGN:
{   Search the table of file names using a binary search algorithm.  Return a
{ boolean which gives the result of the search.

    PROCEDURE search_known_output
      (    system_file_name: jmt$system_supplied_name;
           known_output_p: ^jmt$output_status_results;
           known_output_count: jmt$output_count_range;
       VAR position: jmt$output_count_range);

      VAR
        temp: integer,
        lower: jmt$output_count_range,
        upper: jmt$output_count_range;

      lower := 1;
      upper := known_output_count;

    /binary_search/
      WHILE lower <= upper DO
        temp := lower + upper;
        position := temp DIV 2;
        IF system_file_name = known_output_p^ [position]^ [1].system_file_name THEN
          RETURN;
        ELSE
          IF system_file_name > known_output_p^ [position]^ [1].system_file_name THEN
            lower := position + 1;
          ELSE
            upper := position - 1;
          IFEND;
        IFEND;
      WHILEND /binary_search/;
      position := 0;

    PROCEND search_known_output;
?? OLDTITLE ??
?? NEWTITLE := 'sort_known_outputs', EJECT ??

    PROCEDURE sort_known_outputs
      (    known_outputs_p: ^jmt$output_status_results;
           known_output_count: jmt$output_count_range);

      VAR
        gap: integer,
        start: integer,
        current: integer,
        swap: array [ri_system_file_name .. ri_output_destination_usage] of jmt$output_status_result;

{ Use shell sort technique.

      gap := known_output_count;
      WHILE gap > 1 DO
        gap := 2 * (gap DIV 4) + 1;
        FOR start := 1 TO known_output_count - gap DO
          current := start;
          WHILE (current > 0) AND (known_outputs_p^ [current]^ [1].
                system_file_name > known_outputs_p^ [current + gap]^ [1].system_file_name) DO
            swap := known_outputs_p^ [current]^;
            known_outputs_p^ [current]^ := known_outputs_p^ [current + gap]^;
            known_outputs_p^ [current + gap]^ := swap;
            current := current - gap;
          WHILEND;
        FOREND;
      WHILEND;
    PROCEND sort_known_outputs;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    local_status.normal := TRUE;
    ignore_status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Build a list of the known outputs on this system.

    RESET work_area.sequence_pointer;
    PUSH status_result_keys_p: [ri_system_file_name .. ri_output_destination_usage];
    status_result_keys_p^ [ri_system_file_name] := jmc$system_file_name;
    status_result_keys_p^ [ri_output_destination_usage] := jmc$output_destination_usage;
    jmp$get_output_status (NIL, status_result_keys_p, work_area.sequence_pointer, known_output_p,
          known_output_count, status);

    IF NOT status.normal THEN
      IF status.condition = jme$no_outputs_were_found THEN
        known_output_count := 0;
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    sort_known_outputs (known_output_p, known_output_count);

{ Create a scratch sequence to use for the permanent file interfaces.

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, catalog_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_list_value (work_area.sequence_pointer, files_activated);
    IF files_activated = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
    IFEND;

    establish_display_title ('activate_output_files');
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    list_value := files_activated;
    recover_output_queue (jmc$job_output_catalog, known_output_p, known_output_count, list_value,
          work_area.sequence_pointer, catalog_segment_pointer.sequence_pointer, status);
    IF status.normal THEN
      recover_output_queue (jmc$sf_job_output_catalog, known_output_p, known_output_count, list_value,
            work_area.sequence_pointer, catalog_segment_pointer.sequence_pointer, status);
    IFEND;

    IF error_file_open THEN
      close_error_file (ignore_status);
    IFEND;

    mmp$delete_scratch_segment (catalog_segment_pointer, ignore_status);

{ Return the activated system file names as the FILES_ACTIVATED parameter.

    IF pvt [p$files_activated].specified THEN

{ Skip the empty first list element if the list has some real names in it.

      IF files_activated^.link <> NIL THEN
        files_activated := files_activated^.link;
      IFEND;

      clp$change_variable (pvt [p$files_activated].variable^, files_activated, status);
    IFEND;

  PROCEND activate_output_files;
?? OLDTITLE ??
?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   Attempt to cleanup on block exit if something doesn't work.

  PROCEDURE abort_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    VAR
      ignore_status: ost$status;

    IF error_file_open THEN
      clp$close_display (display_control, ignore_status);
      error_file_open := FALSE;
      #SPOIL (error_file_open);
    IFEND;

  PROCEND abort_handler;
?? OLDTITLE ??
?? NEWTITLE := 'change_list_options', EJECT ??

  PROCEDURE change_list_options
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (jmm$mano_chalo) change_list_options, change_list_option, chalo (
{   errors, error, e: file = $optional
{   output, o: file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 10, 24, 10, 1, 20, 479],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'JMM$MANO_CHALO'], [
    ['E                              ',clc$abbreviation_entry, 1],
    ['ERROR                          ',clc$alias_entry, 1],
    ['ERRORS                         ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$errors = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$errors].specified THEN
      error_file := pvt [p$errors].value^.file_value^;
    IFEND;

    IF pvt [p$output].specified THEN
      output_file := pvt [p$output].value^.file_value^;
    IFEND;

  PROCEND change_list_options;
?? OLDTITLE ??
?? NEWTITLE := 'close_error_file', EJECT ??

  PROCEDURE close_error_file
    (VAR status: ost$status);

    IF error_file_open THEN
      clp$close_display (display_control, status);
      IF status.normal THEN
        error_file_open := FALSE;
        #SPOIL (error_file_open);
      IFEND;
    IFEND;

  PROCEND close_error_file;
?? OLDTITLE ??
?? NEWTITLE := 'combine_offline_output', EJECT ??

  PROCEDURE combine_offline_output
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (jmm$mano_comoo) combine_offline_output, comoo (
{   tape_file, tf: file = $required
{   device, d: name = $required
{   number, n: any of
{       key
{         all
{       keyend
{       integer 1..jmc$maximum_output_count
{     anyend = 1
{   output, o: file = $optional
{   errors, e: file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: 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$integer_type_qualifier,
        recend,
        default_value: string (1),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 10, 27, 13, 29, 3, 625],
    clc$command, 11, 6, 2, 0, 0, 0, 6, 'JMM$MANO_COMOO'], [
    ['D                              ',clc$abbreviation_entry, 2],
    ['DEVICE                         ',clc$nominal_entry, 2],
    ['E                              ',clc$abbreviation_entry, 5],
    ['ERRORS                         ',clc$nominal_entry, 5],
    ['N                              ',clc$abbreviation_entry, 3],
    ['NUMBER                         ',clc$nominal_entry, 3],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OUTPUT                         ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 6],
    ['TAPE_FILE                      ',clc$nominal_entry, 1],
    ['TF                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 6
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, jmc$maximum_output_count, 10]]
    ,
    '1'],
{ PARAMETER 4
    [[1, 0, clc$file_type]],
{ PARAMETER 5
    [[1, 0, clc$file_type]],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$tape_file = 1,
      p$device = 2,
      p$number = 3,
      p$output = 4,
      p$errors = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      attribute_index: jmt$attribute_keys,
      attribute_values_pp: ^array [1 .. * ] of ^jmt$attribute_values,
      attribute_values_seq_p: ^SEQ ( * ),
      combined_file_count: jmt$output_count_range,
      combined_file_index: jmt$output_count_range,
      combined_file_list_p: ^array [1 .. * ] of jmt$output_descriptor,
      error_file_count: jmt$output_count_range,
      error_file_index: jmt$output_count_range,
      error_file_list_p: ^jmt$error_status_list,
      error_file_path: fst$path,
      file: clt$file,
      number_of_files_to_combine: jmt$output_count_range,
      output_file_path: fst$path;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Determine how many files to copy to the tape.

    IF pvt [p$number].value^.kind = clc$keyword THEN
      number_of_files_to_combine := jmc$maximum_output_count;
    ELSE
      number_of_files_to_combine := pvt [p$number].value^.integer_value.value;
    IFEND;

{ Call ring 3 to copy files to the tape.

    RESET work_area.sequence_pointer;
    NEXT combined_file_list_p: [1 .. jmc$maximum_output_count] IN work_area.sequence_pointer;
    NEXT error_file_list_p: [1 .. jmc$maximum_output_count] IN work_area.sequence_pointer;
    jmp$combine_offline_output (pvt [p$tape_file].value^.file_value^, pvt [p$device].value^.name_value,
          number_of_files_to_combine, combined_file_count, combined_file_list_p^, error_file_count,
          error_file_list_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Format attributes of files that were written to tape and write them to the
{ output file.

    IF pvt [p$output].specified THEN
      output_file_path := pvt [p$output].value^.file_value^;
    ELSE
      output_file_path := output_file;
    IFEND;
    IF combined_file_count > 0 THEN
      PUSH attribute_values_pp: [1 .. combined_file_count];
      FOR combined_file_index := 1 TO combined_file_count DO
        PUSH attribute_values_pp^ [combined_file_index]: [1 .. 32];

        attribute_index := 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$comment_banner;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].comment_banner :=
              combined_file_list_p^ [combined_file_index].comment_banner;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$control_family;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].control_family :=
              combined_file_list_p^ [combined_file_index].control_family;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$control_user;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].
              control_user := combined_file_list_p^ [combined_file_index].control_user;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$copies;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].
              copies := combined_file_list_p^ [combined_file_index].copies;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$data_mode;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].
              data_mode := combined_file_list_p^ [combined_file_index].data_mode;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$device;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].
              device := combined_file_list_p^ [combined_file_index].device;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$device_type;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].
              device_type := combined_file_list_p^ [combined_file_index].device_type;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$external_characteristics;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].external_characteristics :=
              combined_file_list_p^ [combined_file_index].external_characteristics;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$file_size;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].
              file_size := combined_file_list_p^ [combined_file_index].file_size;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$forms_code;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].
              forms_code := combined_file_list_p^ [combined_file_index].forms_code;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$login_account;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].
              login_account := combined_file_list_p^ [combined_file_index].login_account;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$login_family;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].
              login_family := combined_file_list_p^ [combined_file_index].login_family;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$login_project;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].
              login_project := combined_file_list_p^ [combined_file_index].login_project;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$login_user;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].
              login_user := combined_file_list_p^ [combined_file_index].login_user;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$output_destination_family;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].output_destination_family :=
              combined_file_list_p^ [combined_file_index].output_destination_family;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$station_operator;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].station_operator :=
              combined_file_list_p^ [combined_file_index].station_operator;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$origin_application_name;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].origin_application_name :=
              combined_file_list_p^ [combined_file_index].originating_application_name;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$output_class;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].
              output_class := combined_file_list_p^ [combined_file_index].output_class;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$output_destination;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].output_destination :=
              combined_file_list_p^ [combined_file_index].output_destination;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$output_priority;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].output_priority :=
              combined_file_list_p^ [combined_file_index].output_priority;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$output_submission_time;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].output_submission_time :=
              combined_file_list_p^ [combined_file_index].output_submission_time;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$remote_host_directive;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].remote_host_directive :=
              ^combined_file_list_p^ [combined_file_index].remote_host_directive;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$routing_banner;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].routing_banner :=
              combined_file_list_p^ [combined_file_index].routing_banner;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$site_information;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].site_information :=
              ^combined_file_list_p^ [combined_file_index].site_information;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$station;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].
              station := combined_file_list_p^ [combined_file_index].station;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$system_file_name;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].system_file_name :=
              combined_file_list_p^ [combined_file_index].system_file_name;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$system_job_name;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].system_job_name :=
              combined_file_list_p^ [combined_file_index].system_job_name;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$user_file_name;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].user_file_name :=
              combined_file_list_p^ [combined_file_index].user_file_name;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$user_information;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].user_information :=
              ^combined_file_list_p^ [combined_file_index].user_information;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$user_file_name;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].user_file_name :=
              combined_file_list_p^ [combined_file_index].user_file_name;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$vertical_print_density;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].vertical_print_density :=
              combined_file_list_p^ [combined_file_index].vertical_print_density;

        attribute_index := attribute_index + 1;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].key := jmc$vfu_load_procedure;
        attribute_values_pp^ [combined_file_index]^ [attribute_index].vfu_load_procedure :=
              combined_file_list_p^ [combined_file_index].vfu_load_procedure;
      FOREND;

      clp$convert_string_to_file (output_file_path, file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      attribute_values_seq_p := #SEQ (attribute_values_pp);
      jmp$display_attributes (attribute_values_seq_p, combined_file_count, NIL, NIL, 0, file,
            'combine_offline_output', status);

      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Format attributes and error status of files that were not written to tape and
{ write them to the error file.

    IF pvt [p$errors].specified THEN
      error_file_path := pvt [p$errors].value^.file_value^;
    ELSE
      error_file_path := error_file;
    IFEND;
    IF error_file_count > 0 THEN
      osp$establish_block_exit_hndlr (^abort_handler);
      establish_display_title ('combine_offline_output');

      FOR error_file_index := 1 TO error_file_count DO
        display_status_error (error_file_list_p^ [error_file_index].status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

      close_error_file (status);
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND combine_offline_output;
?? OLDTITLE ??
?? NEWTITLE := 'display_status_error', EJECT ??

  PROCEDURE display_status_error
    (    error_status: ost$status;
     VAR status: ost$status);

    VAR
      line_count: 1 .. osc$max_status_message_lines,
      status_message_p: ^ost$status_message,
      status_message_line_count_p: ^ost$status_message_line_count,
      status_message_line_p: ^ost$status_message_line,
      status_message_line_size_p: ^ost$status_message_line_size,
      status_message: ost$status_message;

    IF error_status.normal THEN
      RETURN;
    IFEND;

    IF NOT error_file_open THEN
      open_error_file (error_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    osp$format_message (error_status, osc$full_message_level, display_control.page_width, status_message,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    status_message_p := ^status_message;
    RESET status_message_p;
    NEXT status_message_line_count_p IN status_message_p;
    FOR line_count := 1 TO status_message_line_count_p^ DO
      NEXT status_message_line_size_p IN status_message_p;
      NEXT status_message_line_p: [status_message_line_size_p^] IN status_message_p;
      clp$put_display (display_control, status_message_line_p^, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;
  PROCEND display_status_error;
?? OLDTITLE ??
?? NEWTITLE := 'establish_display_title', EJECT ??

  PROCEDURE [INLINE] establish_display_title
    (    command_title: string ( * ));

    clv$titles_built := FALSE;
    clv$command_name := command_title;

  PROCEND establish_display_title;
?? OLDTITLE ??
?? NEWTITLE := 'log_restored_output_files', EJECT ??

  PROCEDURE log_restored_output_files
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ procedure (jmm$mano_logrof) log_restored_output_files (
{   files_restored, fr: list 0..clc$max_list_size of name = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 10, 14, 14, 14, 17, 521],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'JMM$MANO_LOGROF'], [
    ['FILES_RESTORED                 ',clc$nominal_entry, 1],
    ['FR                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 0, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$files_restored = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      file_count: 0 .. clc$max_list_size,
      file_list: ^clt$data_value,
      file_number: 0 .. clc$max_list_size,
      ignore_status: ost$status,
      local_status: ost$status,
      output_name: jmt$name;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);
    establish_display_title ('log_restored_output_files');
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  Process the FILES_RESTORED parameter.

    file_count := clp$count_list_elements (pvt [p$files_restored].value);
    file_list := pvt [p$files_restored].value;

  /log_each_file/
    FOR file_number := 1 TO file_count DO

      jmp$determine_name_kind (file_list^.element_value^.name_value, output_name, local_status);
      IF NOT local_status.normal THEN
        display_status_error (local_status, ignore_status);
      ELSEIF output_name.kind <> jmc$system_supplied_name THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, output_name.user_supplied_name,
              local_status);
        display_status_error (local_status, ignore_status);
      ELSE

        jmp$log_restored_output (output_name.system_supplied_name, local_status);
        IF NOT local_status.normal THEN
          display_status_error (local_status, ignore_status);

          IF local_status.condition = jme$jh_job_history_not_active THEN
            EXIT /log_each_file/;
          IFEND;
        IFEND;
      IFEND;

      file_list := file_list^.link;
    FOREND /log_each_file/;

    IF error_file_open THEN
      close_error_file (ignore_status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND log_restored_output_files;
?? OLDTITLE ??
?? NEWTITLE := 'open_error_file', EJECT ??

  PROCEDURE open_error_file
    (    error_file: fst$file_reference;
     VAR status: ost$status);

    VAR
      default_ring_attributes: amt$ring_attributes;

    status.normal := TRUE;
    IF NOT error_file_open THEN

      default_ring_attributes.r1 := #RING (^default_ring_attributes);
      default_ring_attributes.r2 := #RING (^default_ring_attributes);
      default_ring_attributes.r3 := #RING (^default_ring_attributes);

      clp$open_display_reference (error_file, ^clp$new_page_procedure, fsc$list, default_ring_attributes,
            display_control, status);
      IF status.normal THEN
        error_file_open := TRUE;
        #SPOIL (error_file_open);
      IFEND;
    IFEND;

  PROCEND open_error_file;
?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle', EJECT ??

  PROCEDURE [INLINE] put_subtitle
    (VAR display_control: clt$display_control;
     VAR status: ost$status);

{ These displays do not have subtitles.  This is merely a dummy routine to keep the module consistant
{ with those that do produce subtitles.

  PROCEND put_subtitle;
?? OLDTITLE ??
?? NEWTITLE := 'queued_output_path', EJECT ??

  PROCEDURE queued_output_path
    (    parameter_list: clt$parameter_list;
     VAR work_area { input, output } : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ function (jmm$mano_$qop) $queued_output_path (
{   names: list 0..clc$max_list_size of name = jmv$selected_output)

?? 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$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        default_value: string (19),
      recend,
    recend := [
    [1,
    [89, 10, 14, 14, 14, 17, 899],
    clc$function, 1, 1, 0, 0, 0, 0, 0, 'JMM$MANO_$QOP'], [
    ['NAMES                          ',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, 21,
  clc$optional_default_parameter, 0, 19]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 0, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'jmv$selected_output']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$names = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      file_reference: string (fsc$max_path_size),
      ignore_status: ost$status,
      output_name: jmt$name,
      name_count: 0 .. clc$max_list_size,
      name_list: ^clt$data_value,
      name_number: 0 .. clc$max_list_size,
      node: ^clt$data_value,
      path: jmt$queue_file_path;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_list_value (work_area, result);
    IF result = NIL THEN
      osp$set_status_condition (cle$work_area_overflow, status);
      RETURN;
    IFEND;
    node := result;

{ Process the NAMES parameter.

    name_count := clp$count_list_elements (pvt [p$names].value);
    name_list := pvt [p$names].value;

  /get_each_path/
    FOR name_number := 1 TO name_count DO

      jmp$determine_name_kind (name_list^.element_value^.name_value, output_name, status);
      IF NOT status.normal THEN
        EXIT /get_each_path/;
      IFEND;
      IF output_name.kind <> jmc$system_supplied_name THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, output_name.system_supplied_name,
              status);
        EXIT /get_each_path/;
      IFEND;

      jmp$get_output_path_elements (output_name.system_supplied_name, path, status);
      IF NOT status.normal THEN
        EXIT /get_each_path/;
      IFEND;

      fsp$build_file_ref_from_elems (^path, file_reference, status);
      IF NOT status.normal THEN
        EXIT /get_each_path/;
      IFEND;

      clp$make_list_value (work_area, node^.link);
      IF node^.link = NIL THEN
        osp$set_status_condition (cle$work_area_overflow, status);
        EXIT /get_each_path/;
      IFEND;

      node := node^.link;
      clp$make_file_value (file_reference, work_area, node^.element_value);
      IF node^.element_value = NIL THEN
        osp$set_status_condition (cle$work_area_overflow, status);
        EXIT /get_each_path/;
      IFEND;

      name_list := name_list^.link;
    FOREND /get_each_path/;

{ Skip the empty first list element if the list has some real items in it.

    IF result^.link <> NIL THEN
      result := result^.link;
    IFEND;

  PROCEND queued_output_path;
?? OLDTITLE ??
?? NEWTITLE := 'quit', EJECT ??

  PROCEDURE quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (jmm$mano_qui) quit, qui (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 1, 29, 9, 17, 28, 807], clc$command, 1, 1, 0, 0, 0, 0, 1, 'JMM$MANO_QUI'],
            [['STATUS                         ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      ignore_status: ost$status;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$delete_scratch_segment (work_area, ignore_status);

    clp$end_include (utility_name, status);

{ Exit the utility.

  PROCEND quit;
?? OLDTITLE ??
?? NEWTITLE := 'select_output', EJECT ??

  PROCEDURE select_output
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (jmm$mano_selo) select_output, selo (
{   comment_banner, comment_banners, cb: list of string 0..jmc$output_comment_banner_size = $optional
{   control_family, control_families, cf: list of name = $optional
{   control_user, control_users, cu: list of name = $optional
{   data_mode, dm: list of key
{       (coded, c)
{       (transparent, t)
{     keyend = $optional
{   device, devices, d: list of any of
{       key
{         automatic
{       keyend
{       name
{     anyend = $optional
{   external_characteristics, ec: list of any of
{       key
{         normal
{       keyend
{       string 0..jmc$ext_characteristics_size
{     anyend = $optional
{   forms_code, forms_codes, fc: list of any of
{       key
{         normal
{       keyend
{       string 0..jmc$forms_code_size
{     anyend = $optional
{   login_account, login_accounts, la: list of name = $optional
{   login_family, login_families, lf: list of name = $optional
{   login_project, login_projects, lp: list of name = $optional
{   login_user, login_users, lu: list of name = $optional
{   name, names, n: list of name = $optional
{   operator_family, operator_families, of: list of name = $optional
{   operator_user, operator_users, ou: list of name = $optional
{   output_class, output_classes, oc: list of name = $optional
{   output_deferred_by_operator, odbo: boolean = $optional
{   output_deferred_by_user, odbu: boolean = $optional
{   output_destination, output_destinations, ode: list of any of
{       name
{       string 0..osc$max_name_size
{     anyend = $optional
{   output_destination_usage, odu: list of any of
{       key
{         dual_state, ntf, private, public, qtf
{       keyend
{       name
{     anyend = $optional
{   output_priority, output_priorities, op: list of name = $optional
{   output_state, output_states, os: any of
{       key
{         all
{       keyend
{       list of key
{         (deferred, d)
{         (queued, q)
{         (initiated, i)
{         (terminated, t)
{         (completed, c)
{       keyend
{     anyend = $optional
{   remote_host_directive, remote_host_directives, rhd: list of ..
{     string 0..jmc$remote_host_directive_size = $optional
{   routing_banner, routing_banners, rb: list of string 0..jmc$output_routing_banner_size = $optional
{   site_information, si: list of string 0..jmc$site_information_size = $optional
{   station, stations, s: list of any of
{       key
{         automatic
{       keyend
{       name
{     anyend = $optional
{   system_job_name, system_job_names, sjn: list of name = $optional
{   user_information, ui: list of string 0..jmc$user_information_size = $optional
{   user_job_name, user_job_names, ujn: list of name = $optional
{   vertical_print_density, vertical_print_densities, vpd: list of key
{       six, eight, none
{     keyend = $optional
{   vfu_load_procedure, vfu_load_procedures, vlp: list of any of
{       key
{         none
{       keyend
{       name
{     anyend = $optional
{   maximum_selection, ms: any of
{       key
{         all
{       keyend
{       integer 1..jmc$maximum_output_count
{     anyend = all
{   mainframe, mainframes, m: key
{       all
{       (current, c)
{     keyend = current
{   output_selection_list, osl: (VAR) list 0..clc$max_list_size of name = jmv$selected_output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 91] of clt$pdt_parameter_name,
      parameters: array [1 .. 34] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type4: 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 .. 4] of clt$keyword_specification,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$string_type_qualifier,
          recend,
        recend,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$string_type_qualifier,
          recend,
        recend,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type13: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type14: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type15: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type16: record
        header: clt$type_specification_header,
      recend,
      type17: record
        header: clt$type_specification_header,
      recend,
      type18: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$name_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
      recend,
      type19: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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 .. 5] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type20: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type21: 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 .. 10] of clt$keyword_specification,
          recend,
        recend,
      recend,
      type22: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type23: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type24: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type25: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
      recend,
      type26: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type27: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type28: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type29: 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 .. 3] of clt$keyword_specification,
        recend,
      recend,
      type30: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
      recend,
      type31: 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$integer_type_qualifier,
        recend,
        default_value: string (3),
      recend,
      type32: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type33: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        default_value: string (19),
      recend,
      type34: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 2, 13, 20, 30, 31, 721],
    clc$command, 91, 34, 0, 0, 0, 1, 34, 'JMM$MANO_SELO'], [
    ['CB                             ',clc$abbreviation_entry, 1],
    ['CF                             ',clc$abbreviation_entry, 2],
    ['COMMENT_BANNER                 ',clc$nominal_entry, 1],
    ['COMMENT_BANNERS                ',clc$alias_entry, 1],
    ['CONTROL_FAMILIES               ',clc$alias_entry, 2],
    ['CONTROL_FAMILY                 ',clc$nominal_entry, 2],
    ['CONTROL_USER                   ',clc$nominal_entry, 3],
    ['CONTROL_USERS                  ',clc$alias_entry, 3],
    ['CU                             ',clc$abbreviation_entry, 3],
    ['D                              ',clc$abbreviation_entry, 5],
    ['DATA_MODE                      ',clc$nominal_entry, 4],
    ['DEVICE                         ',clc$nominal_entry, 5],
    ['DEVICES                        ',clc$alias_entry, 5],
    ['DM                             ',clc$abbreviation_entry, 4],
    ['EC                             ',clc$abbreviation_entry, 6],
    ['EXTERNAL_CHARACTERISTICS       ',clc$nominal_entry, 6],
    ['FC                             ',clc$abbreviation_entry, 7],
    ['FORMS_CODE                     ',clc$nominal_entry, 7],
    ['FORMS_CODES                    ',clc$alias_entry, 7],
    ['LA                             ',clc$abbreviation_entry, 8],
    ['LF                             ',clc$abbreviation_entry, 9],
    ['LOGIN_ACCOUNT                  ',clc$nominal_entry, 8],
    ['LOGIN_ACCOUNTS                 ',clc$alias_entry, 8],
    ['LOGIN_FAMILIES                 ',clc$alias_entry, 9],
    ['LOGIN_FAMILY                   ',clc$nominal_entry, 9],
    ['LOGIN_PROJECT                  ',clc$nominal_entry, 10],
    ['LOGIN_PROJECTS                 ',clc$alias_entry, 10],
    ['LOGIN_USER                     ',clc$nominal_entry, 11],
    ['LOGIN_USERS                    ',clc$alias_entry, 11],
    ['LP                             ',clc$abbreviation_entry, 10],
    ['LU                             ',clc$abbreviation_entry, 11],
    ['M                              ',clc$abbreviation_entry, 32],
    ['MAINFRAME                      ',clc$nominal_entry, 32],
    ['MAINFRAMES                     ',clc$alias_entry, 32],
    ['MAXIMUM_SELECTION              ',clc$nominal_entry, 31],
    ['MS                             ',clc$abbreviation_entry, 31],
    ['N                              ',clc$abbreviation_entry, 12],
    ['NAME                           ',clc$nominal_entry, 12],
    ['NAMES                          ',clc$alias_entry, 12],
    ['OC                             ',clc$abbreviation_entry, 15],
    ['ODBO                           ',clc$abbreviation_entry, 16],
    ['ODBU                           ',clc$abbreviation_entry, 17],
    ['ODE                            ',clc$abbreviation_entry, 18],
    ['ODU                            ',clc$abbreviation_entry, 19],
    ['OF                             ',clc$abbreviation_entry, 13],
    ['OP                             ',clc$abbreviation_entry, 20],
    ['OPERATOR_FAMILIES              ',clc$alias_entry, 13],
    ['OPERATOR_FAMILY                ',clc$nominal_entry, 13],
    ['OPERATOR_USER                  ',clc$nominal_entry, 14],
    ['OPERATOR_USERS                 ',clc$alias_entry, 14],
    ['OS                             ',clc$abbreviation_entry, 21],
    ['OSL                            ',clc$abbreviation_entry, 33],
    ['OU                             ',clc$abbreviation_entry, 14],
    ['OUTPUT_CLASS                   ',clc$nominal_entry, 15],
    ['OUTPUT_CLASSES                 ',clc$alias_entry, 15],
    ['OUTPUT_DEFERRED_BY_OPERATOR    ',clc$nominal_entry, 16],
    ['OUTPUT_DEFERRED_BY_USER        ',clc$nominal_entry, 17],
    ['OUTPUT_DESTINATION             ',clc$nominal_entry, 18],
    ['OUTPUT_DESTINATIONS            ',clc$alias_entry, 18],
    ['OUTPUT_DESTINATION_USAGE       ',clc$nominal_entry, 19],
    ['OUTPUT_PRIORITIES              ',clc$alias_entry, 20],
    ['OUTPUT_PRIORITY                ',clc$nominal_entry, 20],
    ['OUTPUT_SELECTION_LIST          ',clc$nominal_entry, 33],
    ['OUTPUT_STATE                   ',clc$nominal_entry, 21],
    ['OUTPUT_STATES                  ',clc$alias_entry, 21],
    ['RB                             ',clc$abbreviation_entry, 23],
    ['REMOTE_HOST_DIRECTIVE          ',clc$nominal_entry, 22],
    ['REMOTE_HOST_DIRECTIVES         ',clc$alias_entry, 22],
    ['RHD                            ',clc$abbreviation_entry, 22],
    ['ROUTING_BANNER                 ',clc$nominal_entry, 23],
    ['ROUTING_BANNERS                ',clc$alias_entry, 23],
    ['S                              ',clc$abbreviation_entry, 25],
    ['SI                             ',clc$abbreviation_entry, 24],
    ['SITE_INFORMATION               ',clc$nominal_entry, 24],
    ['SJN                            ',clc$abbreviation_entry, 26],
    ['STATION                        ',clc$nominal_entry, 25],
    ['STATIONS                       ',clc$alias_entry, 25],
    ['STATUS                         ',clc$nominal_entry, 34],
    ['SYSTEM_JOB_NAME                ',clc$nominal_entry, 26],
    ['SYSTEM_JOB_NAMES               ',clc$alias_entry, 26],
    ['UI                             ',clc$abbreviation_entry, 27],
    ['UJN                            ',clc$abbreviation_entry, 28],
    ['USER_INFORMATION               ',clc$nominal_entry, 27],
    ['USER_JOB_NAME                  ',clc$nominal_entry, 28],
    ['USER_JOB_NAMES                 ',clc$alias_entry, 28],
    ['VERTICAL_PRINT_DENSITIES       ',clc$alias_entry, 29],
    ['VERTICAL_PRINT_DENSITY         ',clc$nominal_entry, 29],
    ['VFU_LOAD_PROCEDURE             ',clc$nominal_entry, 30],
    ['VFU_LOAD_PROCEDURES            ',clc$alias_entry, 30],
    ['VLP                            ',clc$abbreviation_entry, 30],
    ['VPD                            ',clc$abbreviation_entry, 29]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 24, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 171,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 88, clc$optional_parameter,
  0, 0],
{ PARAMETER 7
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 88, clc$optional_parameter,
  0, 0],
{ PARAMETER 8
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 9
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 10
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 11
    [28, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 12
    [38, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 13
    [48, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 14
    [49, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 15
    [54, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 16
    [56, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 17
    [57, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 18
    [58, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 49, clc$optional_parameter,
  0, 0],
{ PARAMETER 19
    [60, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 233,
  clc$optional_parameter, 0, 0],
{ PARAMETER 20
    [62, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 21
    [64, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 457,
  clc$optional_parameter, 0, 0],
{ PARAMETER 22
    [67, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 24, clc$optional_parameter,
  0, 0],
{ PARAMETER 23
    [70, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 24, clc$optional_parameter,
  0, 0],
{ PARAMETER 24
    [74, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 24, clc$optional_parameter,
  0, 0],
{ PARAMETER 25
    [76, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$optional_parameter,
  0, 0],
{ PARAMETER 26
    [79, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 27
    [83, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 24, clc$optional_parameter,
  0, 0],
{ PARAMETER 28
    [84, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 29
    [87, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 134,
  clc$optional_parameter, 0, 0],
{ PARAMETER 30
    [88, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$optional_parameter,
  0, 0],
{ PARAMETER 31
    [35, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 32
    [33, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 33
    [63, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 21,
  clc$optional_default_parameter, 0, 19],
{ PARAMETER 34
    [78, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [8, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$string_type], [0, jmc$output_comment_banner_size, FALSE]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 3
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 4
    [[1, 0, clc$list_type], [155, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [4], [
      ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['CODED                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['TRANSPARENT                    ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ]
    ],
{ PARAMETER 5
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['AUTOMATIC                      ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 6
    [[1, 0, clc$list_type], [72, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$string_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['NORMAL                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      8, [[1, 0, clc$string_type], [0, jmc$ext_characteristics_size, FALSE]]
      ]
    ],
{ PARAMETER 7
    [[1, 0, clc$list_type], [72, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$string_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['NORMAL                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      8, [[1, 0, clc$string_type], [0, jmc$forms_code_size, FALSE]]
      ]
    ],
{ PARAMETER 8
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 9
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 10
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 11
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 12
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 13
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 14
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 15
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 16
    [[1, 0, clc$boolean_type]],
{ PARAMETER 17
    [[1, 0, clc$boolean_type]],
{ PARAMETER 18
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
      FALSE, 2],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
      8, [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]]
      ]
    ],
{ PARAMETER 19
    [[1, 0, clc$list_type], [217, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      192, [[1, 0, clc$keyword_type], [5], [
        ['DUAL_STATE                     ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['NTF                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['PRIVATE                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['PUBLIC                         ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['QTF                            ', clc$nominal_entry, clc$normal_usage_entry, 5]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 20
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 21
    [[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]]
      ],
    393, [[1, 0, clc$list_type], [377, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [10], [
        ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['COMPLETED                      ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['DEFERRED                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['INITIATED                      ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['Q                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['QUEUED                         ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['TERMINATED                     ', clc$nominal_entry, clc$normal_usage_entry, 4]]
        ]
      ]
    ],
{ PARAMETER 22
    [[1, 0, clc$list_type], [8, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$string_type], [0, jmc$remote_host_directive_size, FALSE]]
    ],
{ PARAMETER 23
    [[1, 0, clc$list_type], [8, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$string_type], [0, jmc$output_routing_banner_size, FALSE]]
    ],
{ PARAMETER 24
    [[1, 0, clc$list_type], [8, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$string_type], [0, jmc$site_information_size, FALSE]]
    ],
{ PARAMETER 25
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['AUTOMATIC                      ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 26
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 27
    [[1, 0, clc$list_type], [8, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$string_type], [0, jmc$user_information_size, FALSE]]
    ],
{ PARAMETER 28
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 29
    [[1, 0, clc$list_type], [118, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [3], [
      ['EIGHT                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['SIX                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ],
{ PARAMETER 30
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 31
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, jmc$maximum_output_count, 10]]
    ,
    'all'],
{ PARAMETER 32
    [[1, 0, clc$keyword_type], [3], [
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['CURRENT                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'current'],
{ PARAMETER 33
    [[1, 0, clc$list_type], [5, 0, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'jmv$selected_output'],
{ PARAMETER 34
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$comment_banner = 1,
      p$control_family = 2,
      p$control_user = 3,
      p$data_mode = 4,
      p$device = 5,
      p$external_characteristics = 6,
      p$forms_code = 7,
      p$login_account = 8,
      p$login_family = 9,
      p$login_project = 10,
      p$login_user = 11,
      p$name = 12,
      p$operator_family = 13,
      p$operator_user = 14,
      p$output_class = 15,
      p$output_deferred_by_operator = 16,
      p$output_deferred_by_user = 17,
      p$output_destination = 18,
      p$output_destination_usage = 19,
      p$output_priority = 20,
      p$output_state = 21,
      p$remote_host_directive = 22,
      p$routing_banner = 23,
      p$site_information = 24,
      p$station = 25,
      p$system_job_name = 26,
      p$user_information = 27,
      p$user_job_name = 28,
      p$vertical_print_density = 29,
      p$vfu_load_procedure = 30,
      p$maximum_selection = 31,
      p$mainframe = 32,
      p$output_selection_list = 33,
      p$status = 34;

    VAR
      pvt: array [1 .. 34] of clt$parameter_value;

    VAR
      attribute_count: clt$parameter_count,
      attribute_found: boolean,
      external_characteristics: string (jmc$ext_characteristics_size),
      forms_code: string (jmc$forms_code_size),
      i: ost$non_negative_integers,
      job_name: jmt$name,
      list_value: ^clt$data_value,
      maximum_selection: 1 .. jmc$maximum_output_count,
      name_found: boolean,
      number_of_names: ost$non_negative_integers,
      number_of_outputs_found: jmt$output_status_count,
      number_of_outputs_selected: 0 .. jmc$maximum_output_count,
      output_attribute_options_p: ^jmt$output_attribute_options,
      output_attribute_results_keys_p: ^jmt$results_keys,
      output_attribute_results_p: ^jmt$output_attribute_results,
      output_destination: ost$name,
      output_index: ost$non_negative_integers,
      output_matches_criteria: boolean,
      output_selection_list: ^clt$data_value,
      output_state: jmt$output_state,
      parameter_index: clt$parameter_count,
      valid_name: jmt$name,
      value: ^clt$data_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Push one attribute and one result key for each selectable attribute.  The parameter
{ maximum_selection is the first non-selectable attribute parameter.

    attribute_count := p$maximum_selection - 1;
    PUSH output_attribute_options_p: [1 .. attribute_count + 1];
    PUSH output_attribute_results_keys_p: [1 .. attribute_count];

{ Using the items specified as selection items, build a set of "search" criteria
{ for the jmp$get_output_attributes request.  Using the other specified items as
{ "requested" information, call the interface jmp$get_output_attributes.  This
{ returns an array of output file's with their attributes.
{ NOTE:
{   A subset of the select_output selection parameters is used as search criteria
{ on the jmp$get_output_attributes request as a performance measure.  This way,
{ the fewest number of files need to be attached within the request.

    RESET work_area.sequence_pointer;

    number_of_names := 0;

    FOR parameter_index := 1 TO attribute_count DO
      output_attribute_options_p^ [parameter_index].key := jmc$null_attribute;
      output_attribute_results_keys_p^ [parameter_index] := jmc$null_attribute;
      IF pvt [parameter_index].specified THEN
        CASE parameter_index OF
        = p$comment_banner =
          output_attribute_results_keys_p^ [parameter_index] := jmc$comment_banner;

        = p$control_family =
          IF clp$count_list_elements (pvt [parameter_index].value) = 1 THEN
            output_attribute_options_p^ [parameter_index].key := jmc$control_family;
            output_attribute_options_p^ [parameter_index].control_family :=
                  pvt [parameter_index].value^.element_value^.name_value;
          ELSE
            output_attribute_results_keys_p^ [parameter_index] := jmc$control_family;
          IFEND;

        = p$control_user =
          IF clp$count_list_elements (pvt [parameter_index].value) = 1 THEN
            output_attribute_options_p^ [parameter_index].key := jmc$control_user;
            output_attribute_options_p^ [parameter_index].control_user :=
                  pvt [parameter_index].value^.element_value^.name_value;
          ELSE
            output_attribute_results_keys_p^ [parameter_index] := jmc$control_user;
          IFEND;

        = p$data_mode =
          output_attribute_results_keys_p^ [parameter_index] := jmc$data_mode;

        = p$device =
          output_attribute_results_keys_p^ [parameter_index] := jmc$device;

        = p$external_characteristics =
          output_attribute_results_keys_p^ [parameter_index] := jmc$external_characteristics;

        = p$forms_code =
          output_attribute_results_keys_p^ [parameter_index] := jmc$forms_code;

        = p$login_account =
          output_attribute_results_keys_p^ [parameter_index] := jmc$login_account;

        = p$login_family =
          IF clp$count_list_elements (pvt [parameter_index].value) = 1 THEN
            output_attribute_options_p^ [parameter_index].key := jmc$login_family;
            output_attribute_options_p^ [parameter_index].login_family :=
                  pvt [parameter_index].value^.element_value^.name_value;
          ELSE
            output_attribute_results_keys_p^ [parameter_index] := jmc$login_family;
          IFEND;

        = p$login_project =
          output_attribute_results_keys_p^ [parameter_index] := jmc$login_project;

        = p$login_user =
          IF clp$count_list_elements (pvt [parameter_index].value) = 1 THEN
            output_attribute_options_p^ [parameter_index].key := jmc$login_user;
            output_attribute_options_p^ [parameter_index].login_user :=
                  pvt [parameter_index].value^.element_value^.name_value;
          ELSE
            output_attribute_results_keys_p^ [parameter_index] := jmc$login_user;
          IFEND;

        = p$name =
          number_of_names := clp$count_list_elements (pvt [p$name].value);
          output_attribute_options_p^ [parameter_index].key := jmc$name_list;
          PUSH output_attribute_options_p^ [parameter_index].name_list: [1 .. number_of_names];

          value := pvt [p$name].value;
          FOR i := 1 TO number_of_names DO
            jmp$determine_name_kind (value^.element_value^.name_value,
                  output_attribute_options_p^ [parameter_index].name_list^ [i], status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            value := value^.link;
          FOREND;

        = p$operator_family =
          output_attribute_results_keys_p^ [parameter_index] := jmc$output_destination_family;

        = p$operator_user =
          output_attribute_results_keys_p^ [parameter_index] := jmc$station_operator;

        = p$output_class =
          output_attribute_results_keys_p^ [parameter_index] := jmc$output_class;

        = p$output_deferred_by_operator =
          output_attribute_options_p^ [parameter_index].key := jmc$output_deferred_by_operator;
          output_attribute_options_p^ [parameter_index].output_deferred_by_operator :=
                pvt [parameter_index].value^.boolean_value.value;

        = p$output_deferred_by_user =
          output_attribute_options_p^ [parameter_index].key := jmc$output_deferred_by_user;
          output_attribute_options_p^ [parameter_index].output_deferred_by_user := pvt [parameter_index].
                value^.boolean_value.value;

        = p$output_destination =
          output_attribute_results_keys_p^ [parameter_index] := jmc$output_destination;

        = p$output_destination_usage =
          IF clp$count_list_elements (pvt [parameter_index].value) = 1 THEN
            output_attribute_options_p^ [parameter_index].key := jmc$output_destination_usage;
            output_attribute_options_p^ [parameter_index].output_destination_usage :=
                  pvt [parameter_index].value^.element_value^.name_value;
          ELSE
            output_attribute_results_keys_p^ [parameter_index] := jmc$output_destination_usage;
          IFEND;

        = p$output_priority =
          output_attribute_results_keys_p^ [parameter_index] := jmc$output_priority;

        = p$output_state =

{ If the keyword ALL was specified for output_state there is no need to get the attribute value.

          IF pvt [p$output_state].value^.kind = clc$list THEN
            output_attribute_options_p^ [parameter_index].key := jmc$output_state_set;
            output_attribute_options_p^ [parameter_index].output_state_set := $jmt$output_state_set [];
            FOR output_state := LOWERVALUE (jmt$output_state) TO UPPERVALUE (jmt$output_state) DO
              value := pvt [p$output_state].value;
              WHILE (value <> NIL) AND (output_state_names [output_state] <>
                    value^.element_value^.name_value) DO
                value := value^.link;
              WHILEND;
              IF (value <> NIL) THEN
                output_attribute_options_p^ [parameter_index].output_state_set :=
                      output_attribute_options_p^ [parameter_index].output_state_set +
                      $jmt$output_state_set [output_state];
              IFEND;
            FOREND;
          IFEND;

        = p$remote_host_directive =
          output_attribute_results_keys_p^ [parameter_index] := jmc$remote_host_directive;

        = p$routing_banner =
          output_attribute_results_keys_p^ [parameter_index] := jmc$routing_banner;

        = p$site_information =
          output_attribute_results_keys_p^ [parameter_index] := jmc$site_information;

        = p$station =
          output_attribute_results_keys_p^ [parameter_index] := jmc$station;

        = p$system_job_name =
          IF clp$count_list_elements (pvt [parameter_index].value) = 1 THEN
            output_attribute_options_p^ [parameter_index].key := jmc$system_job_name;
            output_attribute_options_p^ [parameter_index].system_job_name :=
                  pvt [parameter_index].value^.element_value^.name_value;
          ELSE
            output_attribute_results_keys_p^ [parameter_index] := jmc$system_job_name;
          IFEND;

        = p$user_information =
          output_attribute_results_keys_p^ [parameter_index] := jmc$user_information;

        = p$user_job_name =
          IF clp$count_list_elements (pvt [parameter_index].value) = 1 THEN
            output_attribute_options_p^ [parameter_index].key := jmc$user_job_name;
            output_attribute_options_p^ [parameter_index].user_job_name :=
                  pvt [parameter_index].value^.element_value^.name_value;
          ELSE
            output_attribute_results_keys_p^ [parameter_index] := jmc$user_job_name;
          IFEND;

        = p$vertical_print_density =
          output_attribute_results_keys_p^ [parameter_index] := jmc$vertical_print_density;

        = p$vfu_load_procedure =
          output_attribute_results_keys_p^ [parameter_index] := jmc$vfu_load_procedure;


        ELSE
        CASEND;
      IFEND;
    FOREND;

{ The system file name must always be returned.

    output_attribute_results_keys_p^ [p$name] := jmc$system_file_name;
    output_attribute_options_p^ [attribute_count + 1].key := jmc$continue_request_to_servers;
    IF pvt [p$mainframe].value^.keyword_value = 'CURRENT' THEN
      output_attribute_options_p^ [attribute_count + 1].continue_request_to_servers := FALSE;
    ELSE
      output_attribute_options_p^ [attribute_count + 1].continue_request_to_servers := TRUE;
    IFEND;

    jmp$get_output_attributes (output_attribute_options_p, output_attribute_results_keys_p,
          work_area.sequence_pointer, output_attribute_results_p, number_of_outputs_found, status);

    IF NOT status.normal THEN
      IF status.condition = jme$no_outputs_were_found THEN
        status.normal := TRUE;
        number_of_outputs_found := 0;
      ELSE
        RETURN;
      IFEND;
    IFEND;

{ Using the results of the above request, test each "requested" information value
{ against the appropriate select_output selection parameter.  If the output file's
{ value and the parameter value(s) agree for each criteria specified, add the file
{ to the output selection list.  Otherwise, skip the file and go to the next one.

    maximum_selection := jmc$maximum_output_count;
    IF pvt [p$maximum_selection].specified AND (pvt [p$maximum_selection].value^.kind = clc$integer) THEN
      maximum_selection := pvt [p$maximum_selection].value^.integer_value.value;
    IFEND;
    number_of_outputs_selected := 0;

    NEXT output_selection_list IN work_area.sequence_pointer;
    output_selection_list^.kind := clc$list;
    output_selection_list^.element_value := NIL;
    output_selection_list^.link := NIL;
    output_selection_list^.generated_via_list_rest := FALSE;
    list_value := output_selection_list;

  /select_output_from_list/
    FOR output_index := 1 TO number_of_outputs_found DO
      output_matches_criteria := TRUE;

    /compare_output_attributes/
      FOR parameter_index := 1 TO attribute_count DO
        IF (pvt [parameter_index].specified) AND (output_attribute_results_keys_p^ [parameter_index] <>
              jmc$null_attribute) THEN
          CASE parameter_index OF
          = p$comment_banner =
            value := pvt [p$comment_banner].value;
            WHILE (value <> NIL) AND (output_attribute_results_p^ [output_index]^ [parameter_index].
                  comment_banner <> value^.element_value^.string_value^) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$control_family =
            value := pvt [p$control_family].value;
            WHILE (value <> NIL) AND (output_attribute_results_p^ [output_index]^ [parameter_index].
                  control_family <> value^.element_value^.name_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$control_user =
            value := pvt [p$control_user].value;
            WHILE (value <> NIL) AND (output_attribute_results_p^ [output_index]^ [parameter_index].
                  control_user <> value^.element_value^.name_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$data_mode =
            value := pvt [p$data_mode].value;
            WHILE (value <> NIL) AND (data_mode_names [output_attribute_results_p^ [output_index]^
                  [parameter_index].data_mode] <> value^.element_value^.keyword_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$device =
            value := pvt [p$device].value;
            attribute_found := FALSE;
            WHILE (value <> NIL) AND (NOT attribute_found) DO
              IF value^.element_value^.kind = clc$name THEN
                attribute_found := (output_attribute_results_p^ [output_index]^ [parameter_index].device =
                      value^.element_value^.name_value);
              ELSE {value^.element_value^.kind = clc$keyword
                attribute_found := (output_attribute_results_p^ [output_index]^ [parameter_index].device =
                      value^.element_value^.keyword_value);
              IFEND;

              value := value^.link;
            WHILEND;
            IF NOT attribute_found THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$external_characteristics =
            value := pvt [p$external_characteristics].value;
            attribute_found := FALSE;
            WHILE (value <> NIL) AND (NOT attribute_found) DO
              IF value^.element_value^.kind = clc$string THEN
                #TRANSLATE (osv$lower_to_upper, value^.element_value^.string_value^,
                      external_characteristics);
                attribute_found := (output_attribute_results_p^ [output_index]^ [parameter_index].
                      external_characteristics = external_characteristics);
              ELSE {value^.element_value^.kind = clc$keyword
                attribute_found := (output_attribute_results_p^ [output_index]^ [parameter_index].
                      external_characteristics = value^.element_value^.keyword_value);
              IFEND;

              value := value^.link;
            WHILEND;
            IF NOT attribute_found THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$forms_code =
            value := pvt [p$forms_code].value;
            attribute_found := FALSE;
            WHILE (value <> NIL) AND (NOT attribute_found) DO
              IF value^.element_value^.kind = clc$string THEN
                #TRANSLATE (osv$lower_to_upper, value^.element_value^.string_value^, forms_code);
                attribute_found := (output_attribute_results_p^ [output_index]^ [parameter_index].forms_code =
                      forms_code);
              ELSE {value^.element_value^.kind = clc$keyword
                attribute_found := (output_attribute_results_p^ [output_index]^ [parameter_index].forms_code =
                      value^.element_value^.keyword_value);
              IFEND;

              value := value^.link;
            WHILEND;
            IF NOT attribute_found THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$login_account =
            value := pvt [p$login_account].value;
            WHILE (value <> NIL) AND (output_attribute_results_p^ [output_index]^ [parameter_index].
                  login_account <> value^.element_value^.name_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$login_family =
            value := pvt [p$login_family].value;
            WHILE (value <> NIL) AND (output_attribute_results_p^ [output_index]^ [parameter_index].
                  login_family <> value^.element_value^.name_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$login_project =
            value := pvt [p$login_project].value;
            WHILE (value <> NIL) AND (output_attribute_results_p^ [output_index]^ [parameter_index].
                  login_project <> value^.element_value^.name_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$login_user =
            value := pvt [p$login_user].value;
            WHILE (value <> NIL) AND (output_attribute_results_p^ [output_index]^ [parameter_index].
                  login_user <> value^.element_value^.name_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$operator_family =
            value := pvt [p$operator_family].value;
            WHILE (value <> NIL) AND (output_attribute_results_p^ [output_index]^ [parameter_index].
                  output_destination_family <> value^.element_value^.name_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$operator_user =
            value := pvt [p$operator_user].value;
            WHILE (value <> NIL) AND (output_attribute_results_p^ [output_index]^ [parameter_index].
                  station_operator <> value^.element_value^.name_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$output_class =
            value := pvt [p$output_class].value;
            WHILE (value <> NIL) AND (output_attribute_results_p^ [output_index]^ [parameter_index].
                  output_class <> value^.element_value^.name_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$output_destination =
            value := pvt [p$output_destination].value;
            attribute_found := FALSE;
            WHILE (value <> NIL) AND (NOT attribute_found) DO
              IF value^.element_value^.kind = clc$string THEN
                #TRANSLATE (osv$lower_to_upper, value^.element_value^.string_value^, output_destination);
                attribute_found := (output_attribute_results_p^ [output_index]^ [parameter_index].
                      output_destination = output_destination);
              ELSE {value^.element_value^.kind = clc$name
                attribute_found := (output_attribute_results_p^ [output_index]^ [parameter_index].
                      output_destination = value^.element_value^.name_value);
              IFEND;

              value := value^.link;
            WHILEND;
            IF NOT attribute_found THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$output_destination_usage =
            value := pvt [p$output_destination_usage].value;
            attribute_found := FALSE;
            WHILE (value <> NIL) AND (NOT attribute_found) DO
              IF value^.element_value^.kind = clc$name THEN
                attribute_found := (output_attribute_results_p^ [output_index]^ [parameter_index].
                      output_destination_usage = value^.element_value^.name_value);
              ELSE {value^.element_value^.kind = clc$keyword
                attribute_found := (output_attribute_results_p^ [output_index]^ [parameter_index].
                      output_destination_usage = value^.element_value^.keyword_value);
              IFEND;

              value := value^.link;
            WHILEND;
            IF NOT attribute_found THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$output_priority =
            value := pvt [p$output_priority].value;
            WHILE (value <> NIL) AND (output_attribute_results_p^ [output_index]^ [parameter_index].
                  output_priority <> value^.element_value^.name_value) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$remote_host_directive =
            value := pvt [p$remote_host_directive].value;
            WHILE (value <> NIL) AND (output_attribute_results_p^ [output_index]^ [parameter_index].
                  remote_host_directive^.parameters <> value^.element_value^.string_value^) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$routing_banner =
            value := pvt [p$routing_banner].value;
            WHILE (value <> NIL) AND (output_attribute_results_p^ [output_index]^ [parameter_index].
                  routing_banner <> value^.element_value^.string_value^) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$site_information =
            value := pvt [p$site_information].value;
            WHILE (value <> NIL) AND (output_attribute_results_p^ [output_index]^ [parameter_index].
                  site_information^ <> value^.element_value^.string_value^) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$station =
            value := pvt [p$station].value;
            attribute_found := FALSE;
            WHILE (value <> NIL) AND (NOT attribute_found) DO
              IF value^.element_value^.kind = clc$name THEN
                attribute_found := (output_attribute_results_p^ [output_index]^ [parameter_index].station =
                      value^.element_value^.name_value);
              ELSE {value^.element_value^.kind = clc$keyword
                attribute_found := (output_attribute_results_p^ [output_index]^ [parameter_index].station =
                      value^.element_value^.keyword_value);
              IFEND;

              value := value^.link;
            WHILEND;
            IF NOT attribute_found THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$system_job_name =
            value := pvt [p$system_job_name].value;
            name_found := FALSE;
            WHILE (value <> NIL) AND (NOT name_found) DO
              job_name.kind := jmc$system_supplied_name;
              job_name.system_supplied_name := value^.element_value^.name_value;
              jmp$validate_name (job_name, valid_name, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              name_found := (output_attribute_results_p^ [output_index]^ [parameter_index].system_job_name =
                    valid_name.system_supplied_name);
              value := value^.link;
            WHILEND;
            IF NOT name_found THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$user_information =
            value := pvt [p$user_information].value;
            WHILE (value <> NIL) AND (output_attribute_results_p^ [output_index]^ [parameter_index].
                  user_information^ <> value^.element_value^.string_value^) DO
              value := value^.link;
            WHILEND;
            IF value = NIL THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$user_job_name =
            value := pvt [p$user_job_name].value;
            name_found := FALSE;
            WHILE (value <> NIL) AND (NOT name_found) DO
              job_name.kind := jmc$user_supplied_name;
              job_name.user_supplied_name := value^.element_value^.name_value;
              jmp$validate_name (job_name, valid_name, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              name_found := (output_attribute_results_p^ [output_index]^ [parameter_index].user_job_name =
                    valid_name.user_supplied_name);
              value := value^.link;
            WHILEND;
            IF NOT name_found THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$vertical_print_density =
            value := pvt [p$vertical_print_density].value;
            CASE output_attribute_results_p^ [output_index]^ [parameter_index].vertical_print_density OF
            = jmc$vertical_print_density_none =
              WHILE (value <> NIL) AND (value^.element_value^.keyword_value <> 'NONE') DO
                value := value^.link;
              WHILEND;

            = jmc$vertical_print_density_6 =
              WHILE (value <> NIL) AND (value^.element_value^.keyword_value <> 'SIX') DO
                value := value^.link;
              WHILEND;

            = jmc$vertical_print_density_8 =
              WHILE (value <> NIL) AND (value^.element_value^.keyword_value <> 'EIGHT') DO
                value := value^.link;
              WHILEND;

            ELSE
              ;

            CASEND;
            IF value = NIL THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          = p$vfu_load_procedure =
            value := pvt [p$vfu_load_procedure].value;
            attribute_found := FALSE;
            WHILE (value <> NIL) AND (NOT attribute_found) DO
              IF value^.element_value^.kind = clc$name THEN
                attribute_found := (output_attribute_results_p^ [output_index]^ [parameter_index].
                      vfu_load_procedure = value^.element_value^.name_value);
              ELSE {value^.element_value^.kind = clc$keyword
                attribute_found := (output_attribute_results_p^ [output_index]^ [parameter_index].
                      vfu_load_procedure = osc$null_name);
              IFEND;

              value := value^.link;
            WHILEND;
            IF NOT attribute_found THEN
              output_matches_criteria := FALSE;
              EXIT /compare_output_attributes/;
            IFEND;

          ELSE
            ;

          CASEND;
        IFEND;
      FOREND /compare_output_attributes/;
      IF output_matches_criteria THEN
        number_of_outputs_selected := number_of_outputs_selected + 1;

        IF list_value^.element_value <> NIL THEN
          NEXT list_value^.link IN work_area.sequence_pointer;
          list_value := list_value^.link;
          list_value^.kind := clc$list;
        IFEND;

        NEXT list_value^.element_value IN work_area.sequence_pointer;
        list_value^.element_value^.kind := clc$name;
        list_value^.element_value^.name_value := output_attribute_results_p^ [output_index]^ [p$name].
              system_file_name;
        list_value^.link := NIL;
        list_value^.generated_via_list_rest := FALSE;

        IF number_of_outputs_selected = maximum_selection THEN
          EXIT /select_output_from_list/;
        IFEND;
      IFEND;
    FOREND /select_output_from_list/;

    clp$change_variable (pvt [p$output_selection_list].variable^, output_selection_list, status);
  PROCEND select_output;
*copy clp$new_page_procedure
?? OLDTITLE ??
MODEND jmm$manage_output_utility;
*DECK DECK=JMM$MANAGE_OUTPUT_UTILITY_PD EXPAND=TRUE
create_program_description name=(manage_output, mano) sp=jmp$manage_output_utility ..
      l='$system.osf$system_library' tel=warning lmo=none lm=$null dm=off
*DECK DECK=JMM$MANAGE_QFILE_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
MODULE jmm$manage_qfile_interfaces;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$job_management_id
*copyc ofe$error_codes
*copyc ost$caller_identifier
?? POP ??
*copyc amp$return
*copyc avp$system_displays
*copyc avp$system_operator
*copyc fsp$copy_data_and_close_files
*copyc jmp$close_files_for_copqf
*copyc jmp$get_qfile_attributes
*copyc jmp$open_files_for_copqf
*copyc jmp$terminate_qfile
*copyc jmp$validate_name
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$copy_qfile', EJECT ??
*copy jmh$copy_qfile

  PROCEDURE [XDCL, #GATE] jmp$copy_qfile
    (    system_file_name: jmt$system_supplied_name;
         target_file: fst$file_reference;
         target_ring: ost$valid_ring;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      control_info: fst$copy_control_information,
      good_name: jmt$name,
      ignore_status: ost$status,
      potential_name: jmt$name,
      qfile_fid: amt$file_identifier,
      qfile_lfn: amt$local_file_name,
      target_fid: amt$file_identifier;

?? NEWTITLE := 'abort_handler', EJECT ??
    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

{ The following call works for queue files as well as output files since its parameters are
{ amt$local_file_name and amt$file_identifier, i.e. not specific to output files.

      jmp$close_files_for_copqf (qfile_fid, qfile_lfn, target_fid, ignore_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    IF caller_id.ring > osc$sj_ring_3 THEN
      IF NOT avp$system_operator () THEN
        osp$set_status_abnormal (jmc$job_management_id, ofe$sou_not_active,
              'SYSTEM_OPERATION', status);
        RETURN;
      IFEND;
    IFEND;

{ Validate specified system_file_name.

    potential_name.kind := jmc$system_supplied_name;
    potential_name.system_supplied_name := system_file_name;
    jmp$validate_name (potential_name, good_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

{ Retrieve the control information required by fsp$copy_data_and_close_files.

    jmp$open_files_for_copqf (good_name.system_supplied_name, target_file, target_ring, control_info,
          qfile_fid, qfile_lfn, target_fid, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

{ Copy the queue file into the target file.  Ignore any ring validation error condition.  Close the
{ files at ring 3.

    fsp$copy_data_and_close_files (qfile_fid, target_fid, control_info, status);

{ The following call works for queue files as well as output files since its parameters are
{ amt$local_file_name and amt$file_identifier, i.e. not specific to output files.

    IF NOT status.normal THEN
      IF (status.condition = ame$ring_validation_error) THEN
        jmp$close_files_for_copqf (qfile_fid, qfile_lfn, target_fid, status);
      ELSE
        jmp$close_files_for_copqf (qfile_fid, qfile_lfn, target_fid, ignore_status);
      IFEND;
    ELSE
      amp$return (qfile_lfn, status);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND jmp$copy_qfile;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$util_get_qfile_attributes', EJECT ??
*copy jmh$util_get_qfile_attributes

  PROCEDURE [XDCL, #GATE] jmp$util_get_qfile_attributes
    (    attribute_options_p: ^jmt$qfile_attribute_options;
         attribute_results_keys_p: ^jmt$results_keys;
     VAR attribute_work_area_p: ^SEQ ( * );
     VAR attribute_results_p: ^jmt$qfile_attribute_results;
     VAR number_of_qfiles_found: jmt$qfile_status_count;
     VAR status: ost$status);

    IF (NOT avp$system_displays ()) AND (NOT avp$system_operator ()) THEN
      osp$set_status_abnormal (jmc$job_management_id, ofe$sou_not_active,
            'SYSTEM_DISPLAYS or SYSTEM_OPERATION', status);
      RETURN;
    IFEND;

    jmp$get_qfile_attributes (attribute_options_p, attribute_results_keys_p, attribute_work_area_p,
          attribute_results_p, number_of_qfiles_found, status);
  PROCEND jmp$util_get_qfile_attributes;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$util_terminate_qfile', EJECT ??
*copy jmh$util_terminate_qfile

  PROCEDURE [XDCL, #GATE] jmp$util_terminate_qfile
    (    system_file_name: jmt$system_supplied_name;
         termination_options_p: ^jmt$qfile_termination_options;
     VAR status: ost$status);

    IF NOT avp$system_operator () THEN
      osp$set_status_abnormal (jmc$job_management_id, ofe$sou_not_active, 'SYSTEM_OPERATION', status);
      RETURN;
    IFEND;

    jmp$terminate_qfile (system_file_name, termination_options_p, status);
  PROCEND jmp$util_terminate_qfile;
?? OLDTITLE ??
MODEND jmm$manage_qfile_interfaces;
*DECK DECK=JMM$MANAGE_QFILE_UTILITY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : Manage Queue File Utility' ??
MODULE jmm$manage_qfile_utility;

{ PURPOSE:
{   This module contains the command and subcommands for the NOS/VE Manage
{ Queue File Utility.  The utility is used to manage generic queue files in NOS/VE.
{
{ DESIGN:
{   This utility is a standalone utility outside of the operating system.  It is
{ available only to users with one of the following validation capabilities active:
{ system_displays, system_operation.
{
{   Commands in this utility are designed to process an entire list of arguments
{ and report errors as they occur.  (This is intended for future sub-commands).
{

?? NEWTITLE := 'Global Declarations Referenced By This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc jmc$job_management_id
*copyc jmc$system_family
*copyc jme$queued_file_conditions
*copyc jmt$attribute_keys
*copyc jmt$attribute_keys_set
*copyc jmt$attribute_values
*copyc jmt$error_status_list
*copyc jmt$name_list
*copyc jmt$qfile_attribute_count
*copyc jmt$system_supplied_name_list
*copyc jmt$work_area
*copyc ofe$error_codes
*copyc osd$integer_limits
*copyc ost$caller_identifier
*copyc ost$status
?? POP ??
*copyc avp$system_displays
*copyc avp$system_operator
*copyc clp$begin_utility
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_file
*copyc clp$count_list_elements
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc clp$make_boolean_value
*copyc clp$make_date_time_value
*copyc clp$make_file_value
*copyc clp$make_keyword_value
*copyc clp$make_list_value
*copyc clp$make_name_value
*copyc clp$make_record_value
*copyc clp$make_string_value
*copyc clp$make_time_increment_value
*copyc clp$make_unspecified_value
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc jmp$copy_qfile
*copyc jmp$display_attributes
*copyc jmp$get_attribute_index
*copyc jmp$get_attribute_name
*copyc jmp$util_get_qfile_attributes
*copyc jmp$util_terminate_qfile
*copyc jmp$validate_name
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$format_message
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared By This Module', EJECT ??

*copy clv$display_variables

  SECTION
    read_only: READ;

  CONST
    utility_prompt = 'MQF';

  VAR
    display_control: [STATIC] clt$display_control,
    error_file: [STATIC] fst$path := ':$LOCAL.$ERRORS',
    error_file_open: [STATIC] boolean := FALSE,
    output_file: [STATIC] fst$path := ':$LOCAL.OUTPUT';

  VAR
    data_mode_names: [STATIC, READ, read_only] array [jmt$data_mode] of string (13) := ['CODED',
          'RHF_STRUCTURE', 'TRANSPARENT'],
    qfile_state_names: [STATIC, READ, read_only] array [jmt$qfile_state] of string (10) := ['DEFERRED',
          'QUEUED', 'INITIATED', 'TERMINATED', 'COMPLETED'],
    utility_name: [STATIC, READ, read_only] clt$utility_name := 'manage_queue_files',
    manqf_work_area: amt$segment_pointer;

  CONST
    qfile_max_keys = 10;

?? OLDTITLE ??
?? NEWTITLE := 'Commands for the Manage_Queue_File Utility', EJECT ??

{ table name=manage_queue_file_comma type=command section_name=read_only ..
{   scope=local
{ command (change_list_options, change_list_option, chalo) ..
{   p=change_list_options cm=local
{ command (copy_queue_file, copqf) p=copy_queue_file cm=local
{ command (display_queue_file_attribute, display_queue_file_attributes, ..
{   disqfa)       p=display_queue_file_attribute cm=local
{ command (quit, end_manage_queue_file, end_manage_queue_files, endmqf, ..
{   qui) p=quit cm=local
{ command (terminate_queue_file, terminate_queue_files, terqf) ..
{   p=terminate_queue_file cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  manage_queue_file_comma: [STATIC, READ, read_only] ^clt$command_table
      := ^manage_queue_file_comma_entries,

  manage_queue_file_comma_entries: [STATIC, READ, read_only] array [1 ..
      16] of clt$command_table_entry := [
  {} ['CHALO                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^change_list_options],
  {} ['CHANGE_LIST_OPTION             ', clc$alias_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^change_list_options],
  {} ['CHANGE_LIST_OPTIONS            ', clc$nominal_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^change_list_options],
  {} ['COPQF                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^copy_queue_file],
  {} ['COPY_QUEUE_FILE                ', clc$nominal_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^copy_queue_file],
  {} ['DISPLAY_QUEUE_FILE_ATTRIBUTE   ', clc$nominal_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^display_queue_file_attribute],
  {} ['DISPLAY_QUEUE_FILE_ATTRIBUTES  ', clc$alias_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^display_queue_file_attribute],
  {} ['DISQFA                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^display_queue_file_attribute],
  {} ['ENDMQF                         ', clc$alias_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^quit],
  {} ['END_MANAGE_QUEUE_FILE          ', clc$alias_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^quit],
  {} ['END_MANAGE_QUEUE_FILES         ', clc$alias_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^quit],
  {} ['QUI                            ', clc$abbreviation_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^quit],
  {} ['QUIT                           ', clc$nominal_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^quit],
  {} ['TERMINATE_QUEUE_FILE           ', clc$nominal_entry,
        clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
        ^terminate_queue_file],
  {} ['TERMINATE_QUEUE_FILES          ', clc$alias_entry,
        clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
        ^terminate_queue_file],
  {} ['TERQF                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
        ^terminate_queue_file]];

?? POP ??

{ table name=manage_queue_file_funct type=function    ..
{   section_name=read_only scope=local
{ function $queue_file_attributes p=queue_file_attributes cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    manage_queue_file_funct: [STATIC, READ, read_only] ^clt$function_processor_table :=
          ^manage_queue_file_funct_entries,

    manage_queue_file_funct_entries: [STATIC, READ, read_only] array [1 .. 1] of
          clt$function_proc_table_entry := [
          {} ['$QUEUE_FILE_ATTRIBUTES         ', clc$nominal_entry, clc$normal_usage_entry, 1,
          clc$linked_call, ^queue_file_attributes]];

?? POP ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$_manage_queue_file_utility', EJECT ??

{ PURPOSE:
{   This is the entry point that begins the manage queue file utility.

  PROCEDURE [XDCL, #GATE] jmp$_manage_queue_file_utility
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (jmm$manqf) manage_queue_file, manage_queue_files, manqf (
{    status)

?? 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,
      recend,
    recend := [
    [1,
    [90, 2, 28, 16, 23, 24, 475],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'JMM$MANQF'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      utility_attributes_p: ^clt$utility_attributes;

    status.normal := TRUE;
    IF (NOT avp$system_displays ()) AND (NOT avp$system_operator ()) THEN
      osp$set_status_abnormal (jmc$job_management_id, ofe$sou_not_active,
            'SYSTEM_DISPLAYS or SYSTEM_OPERATION', status);
      RETURN;
    IFEND;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    PUSH utility_attributes_p: [1 .. 5];
    utility_attributes_p^ [1].key := clc$utility_command_search_mode;
    utility_attributes_p^ [1].command_search_mode := clc$global_command_search;
    utility_attributes_p^ [2].key := clc$utility_command_table;
    utility_attributes_p^ [2].command_table := manage_queue_file_comma;
    utility_attributes_p^ [3].key := clc$utility_prompt;
    utility_attributes_p^ [3].prompt.value := utility_prompt;
    utility_attributes_p^ [3].prompt.size := STRLENGTH (utility_prompt);
    utility_attributes_p^ [4].key := clc$utility_termination_command;
    utility_attributes_p^ [4].termination_command := 'quit';
    utility_attributes_p^ [5].key := clc$utility_function_proc_table;
    utility_attributes_p^ [5].function_processor_table := manage_queue_file_funct;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, manqf_work_area, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Begin the utility environment.  Establish the command list, and scan the
{ command file for commands.

    clp$begin_utility (utility_name, utility_attributes_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, utility_prompt, utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$delete_scratch_segment (manqf_work_area, { ignore } status);
    status.normal := TRUE;

{ End the utility environment and exit the utility.

    clp$end_utility (utility_name, status);

  PROCEND jmp$_manage_queue_file_utility;
?? OLDTITLE ??
?? NEWTITLE := 'change_list_options', EJECT ??

{ This procedure is the command processor for the change_list_options subcommand.

  PROCEDURE change_list_options
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (jmm$manqf_chalo) change_list_options, change_list_option, chalo (
{    errors, error, e: file = $optional
{    output, o: file = $optional
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 2, 28, 16, 23, 28, 607],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'JMM$MANQF_CHALO'], [
    ['E                              ',clc$abbreviation_entry, 1],
    ['ERROR                          ',clc$alias_entry, 1],
    ['ERRORS                         ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$errors = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$errors].specified THEN
      error_file := pvt [p$errors].value^.file_value^;
    IFEND;

    IF pvt [p$output].specified THEN
      output_file := pvt [p$output].value^.file_value^;
    IFEND;

  PROCEND change_list_options;
?? OLDTITLE ??
?? NEWTITLE := 'close_error_file', EJECT ??

  PROCEDURE close_error_file
    (VAR status: ost$status);

    IF error_file_open THEN
      clp$close_display (display_control, status);
      IF status.normal THEN
        error_file_open := FALSE;
        #SPOIL (error_file_open);
      IFEND;
    IFEND;

  PROCEND close_error_file;
?? OLDTITLE ??
?? NEWTITLE := 'display_status_error', EJECT ??

  PROCEDURE display_status_error
    (    error_status: ost$status;
     VAR status: ost$status);

    VAR
      line_count: 1 .. osc$max_status_message_lines,
      status_message_p: ^ost$status_message,
      status_message_line_count_p: ^ost$status_message_line_count,
      status_message_line_p: ^ost$status_message_line,
      status_message_line_size_p: ^ost$status_message_line_size,
      status_message: ost$status_message;

    IF error_status.normal THEN
      RETURN;
    IFEND;

    IF NOT error_file_open THEN
      open_error_file (error_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    osp$format_message (error_status, osc$full_message_level, display_control.page_width, status_message,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    status_message_p := ^status_message;
    RESET status_message_p;
    NEXT status_message_line_count_p IN status_message_p;
    FOR line_count := 1 TO status_message_line_count_p^ DO
      NEXT status_message_line_size_p IN status_message_p;
      NEXT status_message_line_p: [status_message_line_size_p^] IN status_message_p;
      clp$put_display (display_control, status_message_line_p^, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;
  PROCEND display_status_error;
?? OLDTITLE ??
?? NEWTITLE := 'open_error_file', EJECT ??

  PROCEDURE open_error_file
    (    error_file: fst$file_reference;
     VAR status: ost$status);

    VAR
      default_ring_attributes: amt$ring_attributes;

    status.normal := TRUE;
    IF NOT error_file_open THEN

      default_ring_attributes.r1 := #RING (^default_ring_attributes);
      default_ring_attributes.r2 := #RING (^default_ring_attributes);
      default_ring_attributes.r3 := #RING (^default_ring_attributes);

      clp$open_display_reference (error_file, ^clp$new_page_procedure, fsc$list, default_ring_attributes,
            display_control, status);
      IF status.normal THEN
        error_file_open := TRUE;
        #SPOIL (error_file_open);
      IFEND;
    IFEND;

  PROCEND open_error_file;
?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle', EJECT ??

  PROCEDURE [INLINE] put_subtitle
    (VAR display_control: clt$display_control;
     VAR status: ost$status);

{ These displays do not have subtitles.  This is merely a dummy routine to keep the module consistant
{ with those that do produce subtitles.

  PROCEND put_subtitle;
?? OLDTITLE ??
?? NEWTITLE := 'quit', EJECT ??

{ This procedure is the command processor for the quit subcommand.

  PROCEDURE quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (jmm$manqf_qui) quit, end_manage_queue_file, ..
{ end_manage_queue_files, endmqf, qui (
{     status)

?? 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,
      recend,
    recend := [
    [1,
    [90, 7, 13, 15, 48, 7, 429],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'JMM$MANQF_QUI'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_include (utility_name, status);

{ Exit the utility.

  PROCEND quit;
?? OLDTITLE ??
?? NEWTITLE := 'copy_queue_file', EJECT ??

{ This procedure is the command processor for the copy_queue_file subcommand.

  PROCEDURE copy_queue_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (jmm$manqf_copqf) copy_queue_file, copqf (
{     name, n: name = $required
{     output, o: file = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [95, 11, 28, 13, 0, 7, 948],
    clc$command, 5, 3, 2, 0, 0, 0, 3, 'JMM$MANQF_COPQF'], [
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      caller_id: ost$caller_identifier,
      good_name: jmt$name,
      ignore_status: ost$status,
      local_status: ost$status,
      potential_name: jmt$name;

    status.normal := TRUE;
    IF NOT avp$system_operator () THEN
      osp$set_status_abnormal (jmc$job_management_id, ofe$sou_not_active, 'SYSTEM_OPERATION', status);
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Process NAME parameter.
{ Call jmp$validate_name to ensure that the caller supplied one of the forms of the
{ system-supplied name.  Interface jmp$copy_qfile requires a system-supplied name,
{ not just a name.

    potential_name.kind := jmc$system_supplied_name;
    potential_name.system_supplied_name := pvt [p$name].value^.name_value;
    jmp$validate_name (potential_name, good_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    #CALLER_ID (caller_id);

    jmp$copy_qfile (good_name.system_supplied_name, pvt [p$output].value^.file_value^,
          caller_id.ring, local_status);
    IF NOT local_status.normal THEN
      display_status_error (local_status, ignore_status);
    IFEND;

    IF error_file_open THEN
      close_error_file (ignore_status);
    IFEND;
  PROCEND copy_queue_file;
?? OLDTITLE ??
?? NEWTITLE := 'display_queue_file_attribute', EJECT ??

{ This procedure is the command processor for the display_queue_file_attribute subcommand.

  PROCEDURE display_queue_file_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (jmm$manqf_disqfa) display_queue_file_attribute, ..
{  display_queue_file_attributes, disqfa (
{    system_file_name, system_file_names, sfn: any of
{        key
{          all
{        keyend
{        list of name
{      anyend = $required
{    display_option, display_options, do: any of
{        key
{          all
{        keyend
{        list of key
{          (application_name, an)
{          (data_mode, dm)
{          (deferred_by_application, dba)
{          (destination, d)
{          (earliest_run_time, ert)
{          (latest_run_time, lrt)
{          (purge_delay, pd)
{          (remote_host_directive, rhd)
{          (state, s)
{          (system_file_name, sfn)
{        keyend
{      anyend = all
{    output, o: file = $output
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: 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 .. 20] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 8, 22, 17, 56, 30, 736],
    clc$command, 9, 4, 1, 0, 0, 0, 4, 'JMM$MANQF_DISQFA'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['SFN                            ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['SYSTEM_FILE_NAME               ',clc$nominal_entry, 1],
    ['SYSTEM_FILE_NAMES              ',clc$alias_entry, 1]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 827, clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[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]]
      ],
    763, [[1, 0, clc$list_type], [747, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [20], [
        ['AN                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['APPLICATION_NAME               ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['D                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['DATA_MODE                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['DBA                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['DEFERRED_BY_APPLICATION        ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['DESTINATION                    ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['DM                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['EARLIEST_RUN_TIME              ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['ERT                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['LATEST_RUN_TIME                ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
        ['LRT                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['PD                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
        ['PURGE_DELAY                    ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
        ['REMOTE_HOST_DIRECTIVE          ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
        ['RHD                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
        ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
        ['SFN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
        ['STATE                          ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
        ['SYSTEM_FILE_NAME               ', clc$nominal_entry,
  clc$normal_usage_entry, 10]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$system_file_name = 1,
      p$display_option = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    TYPE
      qfile_name_list = array [1 .. * ] of record
        name: jmt$system_supplied_name,
        valid: boolean,
      recend;

    VAR
      attribute_options_p: ^jmt$qfile_attribute_options,
      attribute_results_keys_p: ^jmt$results_keys,
      attribute_results_p: ^jmt$qfile_attribute_results,
      attribute_results_seq_p: ^SEQ ( * ),
      candidate_name: jmt$name,
      display_all_files: boolean,
      display_option_list_p: ^clt$data_value,
      get_attribute: jmt$attribute_keys,
      get_key_count: 0 .. qfile_max_keys,
      get_key_number: 0 .. qfile_max_keys,
      get_keys: jmt$attribute_keys_set,
      inserted_system_file_name: boolean,
      key_index: 0 .. qfile_max_keys,
      name_count: 0 .. clc$max_list_size,
      name_index: 0 .. clc$max_list_size,
      name_list_p: ^clt$data_value,
      name_number: 0 .. clc$max_list_size,
      not_found_list_p: ^jmt$name_list,
      not_found_list_size: jmt$qfile_attribute_count,
      number_of_qfiles_found: jmt$qfile_attribute_count,
      output_file: clt$file,
      qfile_found: boolean,
      qfile_index: jmt$qfile_attribute_count,
      qfile_name_list_p: ^qfile_name_list,
      qfiles_found_p: ^jmt$system_supplied_name_list,
      valid_name: jmt$name,
      valid_name_count: jmt$qfile_attribute_count,
      valid_name_index: jmt$qfile_attribute_count;

?? NEWTITLE := '[INLINE] add_to_attributes', EJECT ??

    PROCEDURE [INLINE] add_to_attributes
      (    get_attribute_key: jmt$attribute_keys);

      IF get_attribute_key IN get_keys THEN
        get_key_number := get_key_number + 1;
        attribute_results_keys_p^ [get_key_number] := get_attribute_key;
      IFEND;
    PROCEND add_to_attributes;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Process SYSTEM_FILE_NAME parameter.

    display_all_files := FALSE;
    IF pvt [p$system_file_name].value^.kind = clc$keyword THEN { The only keyword is ALL.
      display_all_files := TRUE;
      PUSH attribute_options_p: [1 .. 1];
      attribute_options_p^ [1].key := jmc$null_attribute;
    ELSE
      name_list_p := pvt [p$system_file_name].value;
      name_count := clp$count_list_elements (pvt [p$system_file_name].value);
      PUSH attribute_options_p: [1 .. 1];
      attribute_options_p^ [1].key := jmc$system_supplied_name_list;
      candidate_name.kind := jmc$system_supplied_name;
      PUSH qfile_name_list_p: [1 .. name_count];
      valid_name_count := 0;
      FOR name_index := 1 TO name_count DO
        candidate_name.system_supplied_name := name_list_p^.element_value^.name_value;
        jmp$validate_name (candidate_name, valid_name, status);
        IF status.normal THEN
          valid_name_count := valid_name_count + 1;
          qfile_name_list_p^ [name_index].name := valid_name.system_supplied_name;
          qfile_name_list_p^ [name_index].valid := TRUE;
        ELSE
          qfile_name_list_p^ [name_index].name := candidate_name.system_supplied_name;
          qfile_name_list_p^ [name_index].valid := FALSE;
        IFEND;
        name_list_p := name_list_p^.link;
      FOREND;
      PUSH attribute_options_p^ [1].system_supplied_name_list: [1 .. valid_name_count];
      valid_name_index := 0;
      FOR name_index := 1 TO name_count DO
        IF qfile_name_list_p^ [name_index].valid THEN
          valid_name_index := valid_name_index + 1;
          attribute_options_p^ [1].system_supplied_name_list^ [valid_name_index] :=
                qfile_name_list_p^ [name_index].name;
        IFEND;
      FOREND;
    IFEND;

{ Process DISPLAY_OPTION parameter.

    get_keys := $jmt$attribute_keys_set [];
    get_key_count := 0;
    get_key_number := 0;
    IF pvt [p$display_option].value^.kind = clc$keyword THEN { The only keyword is ALL.
      get_keys := $jmt$attribute_keys_set [jmc$application_name, jmc$data_mode, jmc$deferred_by_application,
            jmc$destination, jmc$earliest_run_time, jmc$latest_run_time, jmc$purge_delay,
            jmc$remote_host_directive, jmc$qfile_state, jmc$system_file_name];
      get_key_count := qfile_max_keys;
    ELSE
      display_option_list_p := pvt [p$display_option].value;
      WHILE display_option_list_p <> NIL DO
        jmp$get_attribute_index (display_option_list_p^.element_value^.keyword_value, get_attribute);
        IF NOT (get_attribute IN get_keys) THEN
          get_keys := get_keys + $jmt$attribute_keys_set [get_attribute];
          get_key_count := get_key_count + 1;
        IFEND;
        display_option_list_p := display_option_list_p^.link;
      WHILEND;
    IFEND;

    IF NOT display_all_files THEN
      inserted_system_file_name := NOT (jmc$system_file_name IN get_keys);
      get_keys := get_keys + $jmt$attribute_keys_set [jmc$system_file_name];
      IF inserted_system_file_name THEN
        get_key_count := get_key_count + 1;
      IFEND;
    IFEND;

    PUSH attribute_results_keys_p: [1 .. get_key_count];
    add_to_attributes (jmc$application_name);
    add_to_attributes (jmc$data_mode);
    add_to_attributes (jmc$deferred_by_application);
    add_to_attributes (jmc$destination);
    add_to_attributes (jmc$earliest_run_time);
    add_to_attributes (jmc$latest_run_time);
    add_to_attributes (jmc$purge_delay);
    add_to_attributes (jmc$remote_host_directive);
    add_to_attributes (jmc$qfile_state);
    add_to_attributes (jmc$system_file_name);

    RESET manqf_work_area.sequence_pointer;
    jmp$util_get_qfile_attributes (attribute_options_p, attribute_results_keys_p,
          manqf_work_area.sequence_pointer, attribute_results_p, number_of_qfiles_found, status);

    IF NOT status.normal THEN
      IF status.condition = jme$no_qfiles_were_found THEN
        number_of_qfiles_found := 0;
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

{ Build a list of queue file names that were not found.

    not_found_list_size := 0;
    IF NOT display_all_files THEN
      PUSH not_found_list_p: [1 .. name_count];
      IF number_of_qfiles_found > 0 THEN
        PUSH qfiles_found_p: [1 .. number_of_qfiles_found];
        FOR qfile_index := 1 TO number_of_qfiles_found DO
          FOR key_index := 1 TO UPPERBOUND (attribute_results_p^ [qfile_index]^) DO
            IF attribute_results_p^ [qfile_index]^ [key_index].key = jmc$system_file_name THEN
              qfiles_found_p^ [qfile_index] := attribute_results_p^ [qfile_index]^ [key_index].
                    system_file_name;
              IF inserted_system_file_name THEN
                attribute_results_p^ [qfile_index]^ [key_index].key := jmc$null_attribute;
              IFEND;
            IFEND;
          FOREND;
        FOREND;
      IFEND;

      FOR name_number := 1 TO name_count DO
        IF qfile_name_list_p^ [name_number].valid THEN
          qfile_found := FALSE;
          qfile_index := 1;
          WHILE NOT qfile_found AND (qfile_index <= number_of_qfiles_found) DO
            qfile_found := (qfile_name_list_p^ [name_number].name = qfiles_found_p^ [qfile_index]);
            qfile_index := qfile_index + 1;
          WHILEND;
          IF NOT qfile_found THEN
            not_found_list_size := not_found_list_size + 1;
            not_found_list_p^ [not_found_list_size].system_supplied_name :=
                  qfile_name_list_p^ [name_number].name;
          IFEND;
        ELSE { not valid
          not_found_list_size := not_found_list_size + 1;
          not_found_list_p^ [not_found_list_size].system_supplied_name :=
                qfile_name_list_p^ [name_number].name;
        IFEND;
      FOREND;
    IFEND;

    IF not_found_list_size = 0 THEN
      not_found_list_p := NIL;
    IFEND;

    attribute_results_seq_p := #SEQ (attribute_results_p);

{ Process OUTPUT parameter.

    clp$convert_string_to_file (pvt [p$output].value^.file_value^, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$display_attributes (attribute_results_seq_p, number_of_qfiles_found, { header_display_list_p } NIL,
          not_found_list_p, not_found_list_size, output_file, 'display_queue_file_attribute', status);

  PROCEND display_queue_file_attribute;
?? OLDTITLE ??
?? NEWTITLE := 'queue_file_attributes', EJECT ??

{ This procedure is the function processor for the MANQF $QUEUE_FILE_ATTRIBUTES function.

  PROCEDURE queue_file_attributes
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{    FUNCTION (jmm$$manqf_quefa) $queue_file_attributes (
{      queue_files: any of
{          key
{            all
{          keyend
{          list of name
{        anyend = all
{      attributes: any of
{          key
{            all
{          keyend
{          list of key
{            (system_file_name, sfn)
{            (application_name, an)
{            (data_mode, dm)
{            (deferred_by_application, dba)
{            (destination, d)
{            (earliest_run_time, ert)
{            (latest_run_time, lrt)
{            (purge_delay, pd)
{            (remote_host_directive, rhd)
{            (state, s)
{          keyend
{        anyend = all)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: 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 .. 20] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
    recend := [
    [1,
    [90, 8, 22, 17, 56, 5, 478],
    clc$function, 2, 2, 0, 0, 0, 0, 0, 'JMM$$MANQF_QUEFA'], [
    ['ATTRIBUTES                     ',clc$nominal_entry, 2],
    ['QUEUE_FILES                    ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 85, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [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, 827, 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[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]]
      ],
    763, [[1, 0, clc$list_type], [747, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [20], [
        ['AN                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['APPLICATION_NAME               ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['D                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['DATA_MODE                      ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['DBA                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['DEFERRED_BY_APPLICATION        ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['DESTINATION                    ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['DM                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['EARLIEST_RUN_TIME              ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
        ['ERT                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['LATEST_RUN_TIME                ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
        ['LRT                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
        ['PD                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
        ['PURGE_DELAY                    ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
        ['REMOTE_HOST_DIRECTIVE          ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
        ['RHD                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
        ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
        ['SFN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['STATE                          ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
        ['SYSTEM_FILE_NAME               ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
        ]
      ]
    ,
    'all']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$queue_files = 1,
      p$attributes = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    TYPE
      qfile_name_list = array [1 .. * ] of record
        name: jmt$system_supplied_name,
        valid: boolean,
      recend;

    VAR
      attribute_options_p: ^jmt$qfile_attribute_options,
      attribute_results_keys_p: ^jmt$results_keys,
      attribute_results_p: ^jmt$qfile_attribute_results,
      attribute_work_area_p: ^jmt$work_area,
      candidate_name: jmt$name,
      display_all_files: boolean,
      display_option_list_p: ^clt$data_value,
      found: boolean,
      get_attribute: jmt$attribute_keys,
      get_key_count: 0 .. qfile_max_keys,
      get_key_number: 0 .. qfile_max_keys,
      get_keys: jmt$attribute_keys_set,
      inserted_system_file_name: boolean,
      key_array_index: 0 .. qfile_max_keys,
      key_index: 0 .. qfile_max_keys,
      key_names_p: ^array [1 .. * ] of ost$name,
      name_count: 0 .. clc$max_list_size,
      name_index: 0 .. clc$max_list_size,
      name_list_p: ^clt$data_value,
      number_of_qfiles_found: jmt$qfile_attribute_count,
      qfile_index: jmt$qfile_attribute_count,
      qfile_name_list_p: ^qfile_name_list,
      size_of_sequence: ost$non_negative_integers,
      valid_name: jmt$name,
      valid_name_count: jmt$qfile_attribute_count,
      valid_name_index: jmt$qfile_attribute_count,
      value_pp: ^^clt$data_value;

?? NEWTITLE := '[INLINE] add_to_attributes', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to add an attribute key to an array of keys.

    PROCEDURE [INLINE] add_to_attributes
      (    get_attribute_key: jmt$attribute_keys);

      IF get_attribute_key IN get_keys THEN
        get_key_number := get_key_number + 1;
        attribute_results_keys_p^ [get_key_number] := get_attribute_key;
      IFEND;
    PROCEND add_to_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'build_attributes', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to build the attributes record for a
{ specified queue file.

    PROCEDURE build_attributes
      (    key_names_p: ^array [1 .. * ] of ost$name;
           attribute_result_p: ^array [1 .. * ] of jmt$qfile_attribute_result;
       VAR work_area_p: ^clt$work_area;
       VAR result_p: ^clt$data_value);

      CONST
        none_keyword = 'NONE';

      VAR
        date_time: clt$date_time,
        field_index: 0 .. qfile_max_keys,
        field_values_p: ^array [1 .. * ] of clt$field_value,
        key_index: 1 .. qfile_max_keys;

      clp$make_record_value (UPPERBOUND (key_names_p^), work_area_p, result_p);
      field_values_p := result_p^.field_values;
      field_index := 0;

      FOR key_index := 1 TO UPPERBOUND (attribute_result_p^) DO
        IF attribute_result_p^ [key_index].key = jmc$null_attribute THEN

{ Skip this entry.

        ELSE
          field_index := field_index + 1;
          field_values_p^ [field_index].name := key_names_p^ [field_index];
          CASE attribute_result_p^ [key_index].key OF
          = jmc$system_file_name =
            clp$make_name_value (attribute_result_p^ [key_index].system_file_name, work_area_p,
                  field_values_p^ [field_index].value);

          = jmc$application_name =
            clp$make_name_value (attribute_result_p^ [key_index].application_name, work_area_p,
                  field_values_p^ [field_index].value);

          = jmc$data_mode =
            IF attribute_result_p^ [key_index].data_mode = jmc$coded_data THEN
              clp$make_keyword_value ('CODED', work_area_p, field_values_p^ [field_index].value);
            ELSE
              clp$make_keyword_value ('TRANSPARENT', work_area_p, field_values_p^ [field_index].value);
            IFEND;

          = jmc$deferred_by_application =
            clp$make_boolean_value (attribute_result_p^ [key_index].deferred_by_application,
                  clc$yes_no_boolean, work_area_p, field_values_p^ [field_index].value);

          = jmc$destination =
            clp$make_name_value (attribute_result_p^ [key_index].
                  destination, work_area_p, field_values_p^ [field_index].value);

          = jmc$earliest_run_time =
            IF attribute_result_p^ [key_index].earliest_run_time.specified THEN
              date_time.value := attribute_result_p^ [key_index].earliest_run_time.date_time;
              date_time.date_specified := TRUE;
              date_time.time_specified := TRUE;
              clp$make_date_time_value (date_time, work_area_p, field_values_p^ [field_index].value);
            ELSE
              clp$make_keyword_value (none_keyword, work_area_p, field_values_p^ [field_index].value);
            IFEND;

          = jmc$latest_run_time =
            IF attribute_result_p^ [key_index].latest_run_time.specified THEN
              date_time.value := attribute_result_p^ [key_index].latest_run_time.date_time;
              date_time.date_specified := TRUE;
              date_time.time_specified := TRUE;
              clp$make_date_time_value (date_time, work_area_p, field_values_p^ [field_index].value);
            ELSE
              clp$make_keyword_value (none_keyword, work_area_p, field_values_p^ [field_index].value);
            IFEND;

          = jmc$purge_delay =
            IF attribute_result_p^ [key_index].purge_delay^.specified THEN
              clp$make_time_increment_value (^attribute_result_p^ [key_index].purge_delay^.time_increment,
                    work_area_p, field_values_p^ [field_index].value);
            ELSE
              clp$make_keyword_value (none_keyword, work_area_p, field_values_p^ [field_index].value);
            IFEND;

          = jmc$remote_host_directive =
            IF attribute_result_p^ [key_index].remote_host_directive^.size > 0 THEN
              clp$make_string_value (attribute_result_p^ [key_index].
                    remote_host_directive^.parameters (1, attribute_result_p^ [key_index].
                    remote_host_directive^.size), work_area_p, field_values_p^ [field_index].value);
            ELSE
              clp$make_string_value ('', work_area_p, field_values_p^ [field_index].value);
            IFEND;

          = jmc$qfile_state =
            IF attribute_result_p^ [key_index].qfile_state = jmc$deferred_qfile THEN
              clp$make_keyword_value ('DEFERRED', work_area_p, field_values_p^ [field_index].value);
            ELSEIF attribute_result_p^ [key_index].qfile_state = jmc$queued_qfile THEN
              clp$make_keyword_value ('QUEUED', work_area_p, field_values_p^ [field_index].value);
            ELSEIF attribute_result_p^ [key_index].qfile_state = jmc$initiated_qfile THEN
              clp$make_keyword_value ('INITIATED', work_area_p, field_values_p^ [field_index].value);
            ELSEIF attribute_result_p^ [key_index].qfile_state = jmc$terminated_qfile THEN
              clp$make_keyword_value ('TERMINATED', work_area_p, field_values_p^ [field_index].value);
            ELSE { attribute_result_p^ [key_index].qfile_state = jmc$completed_qfile
              clp$make_keyword_value ('COMPLETED', work_area_p, field_values_p^ [field_index].value);
            IFEND;
          ELSE
            ;

          CASEND;
        IFEND;
      FOREND;

    PROCEND build_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'build_unspecified_attributes', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to build the attributes record for a
{ queue file that was not found or whose name was invalid.

    PROCEDURE build_unspecified_attributes
      (    key_names_p: ^array [1 .. * ] of ost$name;
           qfile_name: jmt$system_supplied_name;
       VAR work_area_p: ^clt$work_area;
       VAR result_p: ^clt$data_value);

      VAR
        field_index: 0 .. qfile_max_keys,
        field_values_p: ^array [1 .. * ] of clt$field_value;

      clp$make_record_value (UPPERBOUND (key_names_p^), work_area_p, result_p);
      field_values_p := result_p^.field_values;

      FOR field_index := 1 TO UPPERBOUND (key_names_p^) DO
        field_values_p^ [field_index].name := key_names_p^ [field_index];
        IF key_names_p^ [field_index] = 'SYSTEM_FILE_NAME' THEN
          clp$make_name_value (qfile_name, work_area_p, field_values_p^ [field_index].value);
        ELSE
          clp$make_unspecified_value (work_area_p, field_values_p^ [field_index].value);
        IFEND;
      FOREND;

    PROCEND build_unspecified_attributes;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    result := NIL;
    value_pp := ^result;
    attribute_results_p := NIL;

{ Process QUEUE_FILES parameter.

    display_all_files := FALSE;
    IF pvt [p$queue_files].value^.kind = clc$keyword THEN { The only keyword is ALL.
      display_all_files := TRUE;
      PUSH attribute_options_p: [1 .. 1];
      attribute_options_p^ [1].key := jmc$null_attribute;
    ELSE { A list of queue files was specified.
      name_list_p := pvt [p$queue_files].value;
      candidate_name.kind := jmc$system_supplied_name;
      PUSH attribute_options_p: [1 .. 1];
      attribute_options_p^ [1].key := jmc$system_supplied_name_list;

      name_count := clp$count_list_elements (pvt [p$queue_files].value);

{ Check if names given were valid system-supplied names. Build a list of the
{ names marked valid or invalid so later we can build an attributes record with unspecified values
{ for each invalid name.

      PUSH qfile_name_list_p: [1 .. name_count];
      valid_name_count := 0;
      FOR name_index := 1 TO name_count DO
        candidate_name.system_supplied_name := name_list_p^.element_value^.name_value;
        jmp$validate_name (candidate_name, valid_name, status);
        IF status.normal THEN
          valid_name_count := valid_name_count + 1;
          qfile_name_list_p^ [name_index].name := valid_name.system_supplied_name;
          qfile_name_list_p^ [name_index].valid := TRUE;
        ELSE
          status.normal := TRUE;
          qfile_name_list_p^ [name_index].name := candidate_name.system_supplied_name;
          qfile_name_list_p^ [name_index].valid := FALSE;
        IFEND;
        name_list_p := name_list_p^.link;
      FOREND;
      PUSH attribute_options_p^ [1].system_supplied_name_list: [1 .. valid_name_count];
      valid_name_index := 0;
      FOR name_index := 1 TO name_count DO
        IF qfile_name_list_p^ [name_index].valid THEN
          valid_name_index := valid_name_index + 1;
          attribute_options_p^ [1].system_supplied_name_list^ [valid_name_index] :=
                qfile_name_list_p^ [name_index].name;
        IFEND;
      FOREND;
    IFEND;

{ Process ATTRIBUTES parameter.

    get_keys := $jmt$attribute_keys_set [];
    get_key_count := 0;
    get_key_number := 0;
    IF pvt [p$attributes].value^.kind = clc$keyword THEN { The only keyword is ALL.
      get_keys := $jmt$attribute_keys_set [jmc$system_file_name, jmc$application_name, jmc$data_mode,
            jmc$deferred_by_application, jmc$destination, jmc$earliest_run_time, jmc$latest_run_time,
            jmc$purge_delay, jmc$remote_host_directive, jmc$qfile_state];
      get_key_count := qfile_max_keys;
    ELSE
      display_option_list_p := pvt [p$attributes].value;
      WHILE display_option_list_p <> NIL DO
        jmp$get_attribute_index (display_option_list_p^.element_value^.keyword_value, get_attribute);
        IF NOT (get_attribute IN get_keys) THEN
          get_keys := get_keys + $jmt$attribute_keys_set [get_attribute];
          get_key_count := get_key_count + 1;
        IFEND;
        display_option_list_p := display_option_list_p^.link;
      WHILEND;
    IFEND;

    IF NOT display_all_files THEN
      inserted_system_file_name := NOT (jmc$system_file_name IN get_keys);
      get_keys := get_keys + $jmt$attribute_keys_set [jmc$system_file_name];
      IF inserted_system_file_name THEN
        get_key_count := get_key_count + 1;
      IFEND;
    IFEND;

    PUSH attribute_results_keys_p: [1 .. get_key_count];

{ Later code depends on jmc$system_file_name being the first key.

    add_to_attributes (jmc$system_file_name);
    add_to_attributes (jmc$application_name);
    add_to_attributes (jmc$data_mode);
    add_to_attributes (jmc$deferred_by_application);
    add_to_attributes (jmc$destination);
    add_to_attributes (jmc$earliest_run_time);
    add_to_attributes (jmc$latest_run_time);
    add_to_attributes (jmc$purge_delay);
    add_to_attributes (jmc$remote_host_directive);
    add_to_attributes (jmc$qfile_state);

    RESET manqf_work_area.sequence_pointer;
    jmp$util_get_qfile_attributes (attribute_options_p, attribute_results_keys_p,
          manqf_work_area.sequence_pointer, attribute_results_p, number_of_qfiles_found, status);

    IF NOT status.normal THEN
      IF status.condition = jme$no_qfiles_were_found THEN
        status.normal := TRUE;
        clp$make_list_value (work_area, result);
      IFEND;
      IF display_all_files THEN
        RETURN;
      IFEND;
    IFEND;

{ Build results.

    IF display_all_files THEN
      PUSH key_names_p: [1 .. get_key_count];
      FOR key_index := 1 TO get_key_count DO
        jmp$get_attribute_name (attribute_results_keys_p^ [key_index], key_names_p^ [key_index]);
      FOREND;

      FOR name_index := 1 TO number_of_qfiles_found DO
        clp$make_list_value (work_area, value_pp^);
        build_attributes (key_names_p, attribute_results_p^ [name_index], work_area,
              value_pp^^.element_value);
        value_pp := ^value_pp^^.link;
      FOREND;
    ELSE
      IF inserted_system_file_name THEN
        PUSH key_names_p: [1 .. (get_key_count - 1)];
        key_array_index := 0;

      /get_key_names/
        FOR key_index := 1 TO get_key_count DO
          IF attribute_results_keys_p^ [key_index] = jmc$system_file_name THEN
            CYCLE /get_key_names/;
          ELSE
            key_array_index := key_array_index + 1;
            jmp$get_attribute_name (attribute_results_keys_p^ [key_index], key_names_p^ [key_array_index]);
          IFEND;
        FOREND /get_key_names/;
      ELSE
        PUSH key_names_p: [1 .. get_key_count];
        FOR key_index := 1 TO get_key_count DO
          jmp$get_attribute_name (attribute_results_keys_p^ [key_index], key_names_p^ [key_index]);
        FOREND;
      IFEND;

{ For each queue file specified, if it was valid and found, then build attributes record from results,
{ otherwise build attributes record with unspecified values.

      FOR name_index := 1 TO name_count DO
        clp$make_list_value (work_area, value_pp^);
        IF qfile_name_list_p^ [name_index].valid THEN
          qfile_index := 1;
          found := FALSE;
          IF attribute_results_p <> NIL THEN

          /find_attributes_for_sfn/
            WHILE (NOT found) AND (qfile_index <= number_of_qfiles_found) DO
              IF attribute_results_p^ [qfile_index]^ [1].key = jmc$system_file_name THEN
                IF qfile_name_list_p^ [name_index].name = attribute_results_p^ [qfile_index]^ [1].
                      system_file_name THEN
                  found := TRUE;
                  EXIT /find_attributes_for_sfn/;
                IFEND;
              IFEND;
              qfile_index := qfile_index + 1;
            WHILEND /find_attributes_for_sfn/;
          IFEND;
          IF found THEN
            IF inserted_system_file_name THEN
              attribute_results_p^ [qfile_index]^ [1].key := jmc$null_attribute;
            IFEND;
            build_attributes (key_names_p, attribute_results_p^ [qfile_index], work_area,
                  value_pp^^.element_value);
          ELSE
            build_unspecified_attributes (key_names_p, qfile_name_list_p^ [name_index].name, work_area,
                  value_pp^^.element_value);
          IFEND;
        ELSE { not valid
          build_unspecified_attributes (key_names_p, qfile_name_list_p^ [name_index].name, work_area,
                value_pp^^.element_value);
        IFEND;
        value_pp := ^value_pp^^.link;
      FOREND;
    IFEND;

  PROCEND queue_file_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'terminate_queue_file', EJECT ??

{ This procedure is the command processor for the terminate_queue_file subcommand.

  PROCEDURE terminate_queue_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (jmm$manqf_terqf) terminate_queue_file, terminate_queue_files, ..
{ terqf (
{   name, names, n: list of name = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 3, 30, 12, 57, 48, 329],
    clc$command, 4, 2, 1, 0, 0, 0, 2, 'JMM$MANQF_TERQF'], [
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 21, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      good_name: jmt$name,
      ignore_status: ost$status,
      local_status: ost$status,
      name_list_p: ^clt$data_value,
      potential_name: jmt$name;

    status.normal := TRUE;
    IF NOT avp$system_operator () THEN
      osp$set_status_abnormal (jmc$job_management_id, ofe$sou_not_active, 'SYSTEM_OPERATION', status);
      RETURN;
    IFEND;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Process NAME parameter.
{ Call jmp$validate_name to ensure that the caller supplied one of the forms of the
{ system-supplied name.  Interface jmp$util_terminate_qfile requires a system-supplied name,
{ not just a name.

    name_list_p := pvt [p$name].value;
    potential_name.kind := jmc$system_supplied_name;
    WHILE name_list_p <> NIL DO
      potential_name.system_supplied_name := name_list_p^.element_value^.name_value;
      jmp$validate_name (potential_name, good_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      jmp$util_terminate_qfile (good_name.system_supplied_name, { termination_options_p } NIL, local_status);
      IF NOT local_status.normal THEN
        display_status_error (local_status, ignore_status);
      IFEND;
      name_list_p := name_list_p^.link;
    WHILEND;

    IF error_file_open THEN
      close_error_file (ignore_status);
    IFEND;
  PROCEND terminate_queue_file;
?? OLDTITLE ??
*copy clp$new_page_procedure
?? OLDTITLE ??
MODEND jmm$manage_qfile_utility;
*DECK DECK=JMM$MANAGE_QUEUE_FILE_UTILITY EXPAND=TRUE
MODULE jmm$manage_queue_file_utility;
MODEND jmm$manage_queue_file_utility;
*DECK DECK=JMM$MANAGE_QUEUE_FILE_UTIL_PD EXPAND=TRUE
create_program_description name=(manage_queue_file, manage_queue_files, manqf) ..
      starting_procedure=jmp$_manage_queue_file_utility ..
      library=('$system.osf$system_library' '$system.osf$system_library_46d') termination_error_level=warning ..
      load_map_options=none load_map=$null debug_mode=off
*DECK DECK=JMM$MANAGE_SYSTEM_SUPPLIED_NAME EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Job Management - system supplied name management interfaces' ??
MODULE jmm$manage_system_supplied_name;

{ Purpose: This module is responsible for the initialization and generation of
{          system supplied names assigned by NOS/VE queue file management.

{ Design: The management of system supplied names across deadstarts has one
{         requirement.  DO NOT EVER assign a name to a job or output file
{         when one currently has that name.
{
{         The current implementation defines EVER as sometime over approximately
{         a year - it is assumed that by the time the system supplied name
{         "wraps" all the way around to the point where it is back at its original
{         starting place all jobs will have completed execution.  Given the current
{         form of the system supplied name, it is estimated that we can't submit
{         enough jobs or output files in a year's time frame to cause the system
{         supplied name to "wrap".
{
{         A value of the last system supplied name (SSN) assigned by NOS/VE is kept
{         in an area in the Recovery Deadstart File (RDF).  Every X times that a
{         SSN is generated, the value in the RDF is updated; the update occurs as
{         part of the System Job's Job-Monitor Loop.  At each deadstart of NOS/VE,
{         the last SSN assigned by NOS/VE is retrieved from the RDF and X additional
{         values are generated.  This new value is then saved in the RDF.  Then net
{         result is that some values in the system supplied name will not be assigned,
{         but no duplicates will be assigned.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc jmt$system_supplied_name_mask
*copyc oss$mainframe_pageable
*copyc ost$deadstart_phase
*copyc ost$signature_lock
?? POP ??
*copyc dsp$determine_if_entry_in_rdf
*copyc dsp$get_data_from_rdf
*copyc dsp$store_data_in_rdf
*copyc osp$initialize_sig_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$clear_mainframe_sig_lock
*copyc tmp$ready_system_task1
*copyc jmv$ssn_previous_sequence
*copyc jmv$system_supplied_name
?? OLDTITLE ??
?? NEWTITLE := 'Declarations Declared in this Module', EJECT ??

{ The value of update_ssn_frequency is somewhat arbitrary.  It should be large
{ enough that we don't have to constantly update the last assigned System
{ Supplied Name.

  CONST
    update_ssn_frequency = 1000;

{ Jmv$ssn_previous_sequence and jmv$system_supplied_name are defined in jmm$job_scheduler_monitor_mode
{ so that the short form of the system supplied name may be used with the system core debugger.

  VAR
    jmv$number_of_ssns_since_update: [XDCL, STATIC, oss$mainframe_pageable] integer := 0,
    jmv$update_last_used_ssn: [XDCL, STATIC, oss$mainframe_pageable] boolean := FALSE,
    jmv$system_supplied_name_lock: [XDCL, STATIC, oss$mainframe_pageable] ost$signature_lock,
    jmv$system_job_ssn: [XDCL, #GATE, STATIC, oss$mainframe_pageable] jmt$system_supplied_name;

?? OLDTITLE ??
?? NEWTITLE := 'decrement_sequence', EJECT ??
{
{    The purpose of this request is to accept the alphabetical sequence portion of
{  the system supplied name and to decrement it to its predicessor value.  That is,
{  determine the value which, when incremented, will produce the supplied value.
{

  PROCEDURE [INLINE] decrement_sequence
    (VAR sequence: jmt$ssn_sequence_number);

    VAR
      index: 1 .. jmc$ssn_sequence_number_size;

    FOR index := jmc$ssn_sequence_number_size DOWNTO 1 DO
      IF sequence (index) = 'A' THEN
        sequence (index) := 'Z';
      ELSE
        sequence (index) := PRED (sequence (index));
        RETURN;
      IFEND;
    FOREND;
  PROCEND decrement_sequence;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$initialize_ssn', EJECT ??
*copyc jmh$initialize_ssn

  PROCEDURE [XDCL, #GATE] jmp$initialize_ssn
    (    deadstart_phase: ost$deadstart_phase;
     VAR status: ost$status);

    VAR
      entry_in_rdf_exists: boolean,
      ignore_system_supplied_name: jmt$system_supplied_name,
      frequency_count: 1 .. update_ssn_frequency,
      last_used_ssn_seq_p: ^SEQ ( * ),
      last_used_ssn: jmt$system_supplied_name,
      system_job_ssn_mask: jmt$system_supplied_name_mask;

    status.normal := TRUE;
    IF deadstart_phase = osc$installation_deadstart THEN
      jmv$system_supplied_name.system_supplied_name := jmv$system_job_ssn;

{ Update the value in the RDF area - the area exists but is empty

      last_used_ssn := jmv$system_supplied_name.system_supplied_name;
      dsp$store_data_in_rdf (dsc$rdf_system_supplied_name, dsc$rdf_production, #SEQ (last_used_ssn));

    ELSE { osc$normal_deadstart, i.e. continuation
      dsp$determine_if_entry_in_rdf (dsc$rdf_system_supplied_name, dsc$rdf_production, entry_in_rdf_exists);

{ If the entry exists, simply read it - otherwise, this is an "upgrade" deadstart

      IF entry_in_rdf_exists THEN

{ Retrieve the value from the RDF area for the last ssn assigned.
{ NOTE: this request updates the variable last_used_ssn

        last_used_ssn_seq_p := #SEQ (last_used_ssn);
        RESET last_used_ssn_seq_p;
        dsp$get_data_from_rdf (dsc$rdf_system_supplied_name, dsc$rdf_production, last_used_ssn_seq_p);
        jmv$system_supplied_name.system_supplied_name := last_used_ssn;
        system_job_ssn_mask.system_supplied_name := jmv$system_job_ssn;
        jmv$system_supplied_name.model := system_job_ssn_mask.model;
        jmv$system_supplied_name.serial_number := system_job_ssn_mask.serial_number;
      ELSE

{ Treat an upgrade deadstart the same as an installation deadstart

        jmv$system_supplied_name.system_supplied_name := jmv$system_job_ssn;

{ Update the value in the RDF area

        last_used_ssn := jmv$system_supplied_name.system_supplied_name;
        dsp$store_data_in_rdf (dsc$rdf_system_supplied_name, dsc$rdf_production, #SEQ (last_used_ssn));
      IFEND;
    IFEND;

    jmv$ssn_previous_sequence := jmv$system_supplied_name.sequence;
    decrement_sequence (jmv$ssn_previous_sequence);
    osp$initialize_sig_lock (jmv$system_supplied_name_lock);

    IF deadstart_phase <> osc$installation_deadstart THEN

{ Generate "frequency" count occurences of this - as soon as run-virtual-system gets called
{ it will "update" the last name assigned - if, for some reason, deadstart should fail before
{ then, that's okay since no multi-mainframe jobs will be submitted or processed until we make
{ it to osp$run_virtual_system.

      FOR frequency_count := 1 TO update_ssn_frequency DO
        qfp$assign_system_supplied_name (ignore_system_supplied_name);
      FOREND;
      jmv$update_last_used_ssn := TRUE;
    IFEND;
  PROCEND jmp$initialize_ssn;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$update_ssn_sequence', EJECT ??
*copyc jmh$update_ssn_sequence

  PROCEDURE [XDCL, #GATE] jmp$update_ssn_sequence
    (    system_supplied_name: jmt$system_supplied_name);

    VAR
      system_supplied_name_mask: jmt$system_supplied_name_mask;

    osp$set_mainframe_sig_lock (jmv$system_supplied_name_lock);
    system_supplied_name_mask.system_supplied_name := system_supplied_name;
    jmv$system_supplied_name.sequence := system_supplied_name_mask.sequence;
    jmv$system_supplied_name.counter := system_supplied_name_mask.counter;
    jmv$ssn_previous_sequence := jmv$system_supplied_name.sequence;
    decrement_sequence (jmv$ssn_previous_sequence);
    jmv$update_last_used_ssn := TRUE;
    jmv$number_of_ssns_since_update := 0;
    osp$clear_mainframe_sig_lock (jmv$system_supplied_name_lock);
  PROCEND jmp$update_ssn_sequence;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$assign_system_supplied_name', EJECT ??
*copyc qfh$assign_system_supplied_name

  PROCEDURE [XDCL, #GATE] qfp$assign_system_supplied_name
    (VAR system_supplied_name: jmt$system_supplied_name);

?? NEWTITLE := 'increment_counter' ??

    PROCEDURE [INLINE] increment_counter
      (VAR counter: jmt$ssn_counter;
       VAR rollover: boolean);

      VAR
        index: 1 .. jmc$ssn_counter_size;

      rollover := FALSE;
      FOR index := jmc$ssn_counter_size DOWNTO 1 DO
        IF counter (index) = '9' THEN
          counter (index) := '0';
        ELSE
          counter (index) := SUCC (counter (index));
          RETURN;
        IFEND;
      FOREND;

      rollover := TRUE;
    PROCEND increment_counter;
?? OLDTITLE ??
?? NEWTITLE := 'increment_sequence', EJECT ??

    PROCEDURE [INLINE] increment_sequence
      (VAR sequence: jmt$ssn_sequence_number;
       VAR rollover: boolean);

      VAR
        index: 1 .. jmc$ssn_sequence_number_size;

      rollover := FALSE;
      jmv$ssn_previous_sequence := sequence;
      FOR index := jmc$ssn_sequence_number_size DOWNTO 1 DO
        IF sequence (index) = 'Z' THEN
          sequence (index) := 'A';
        ELSE
          sequence (index) := SUCC (sequence (index));
          RETURN;
        IFEND;
      FOREND;

      rollover := TRUE;
    PROCEND increment_sequence;
?? OLDTITLE ??
?? EJECT ??

    VAR
      ignore_status: ost$status,
      rollover: boolean,
      ssn: jmt$system_supplied_name_mask;

    osp$set_mainframe_sig_lock (jmv$system_supplied_name_lock);
    ssn := jmv$system_supplied_name;
    increment_counter (ssn.counter, rollover);

{ If the counter rolls, must advance the sequence

    IF rollover THEN
      increment_sequence (ssn.sequence, rollover);

      { If the sequence rolls, must start over - note the recursive call
      { before procedure exit - we can't reassign the system job's ssn.

      IF rollover THEN
        ssn.system_supplied_name := jmv$system_job_ssn;
      IFEND;
    IFEND;

    jmv$system_supplied_name := ssn;

{ update the frequency count - if we have exceeded the limit, notify the system job's
{ job monitor task.

    jmv$number_of_ssns_since_update := jmv$number_of_ssns_since_update + 1;
    IF jmv$number_of_ssns_since_update >= update_ssn_frequency THEN
      jmv$update_last_used_ssn := TRUE;
      jmv$number_of_ssns_since_update := 0;
      tmp$ready_system_task (tmc$stid_job_monitor, ignore_status);
    IFEND;
    osp$clear_mainframe_sig_lock (jmv$system_supplied_name_lock);

    IF rollover THEN
      qfp$assign_system_supplied_name (ssn.system_supplied_name);
    IFEND;
    system_supplied_name := ssn.system_supplied_name;
  PROCEND qfp$assign_system_supplied_name;
?? OLDTITLE ??
?? NEWTITLE := '[XDLC, #GATE] qfp$update_last_used_ssn', EJECT ??
*copyc qfh$update_last_used_ssn

  PROCEDURE [XDCL, #GATE] qfp$update_last_used_ssn;

    VAR
      last_used_ssn: jmt$system_supplied_name;

    IF jmv$update_last_used_ssn THEN
      jmv$update_last_used_ssn := FALSE;

      { Update the value in the RDF sequence - this request should not be made too often.
      { It is currently done every update_ssn_frequency times.

      last_used_ssn := jmv$system_supplied_name.system_supplied_name;
      dsp$store_data_in_rdf (dsc$rdf_system_supplied_name, dsc$rdf_production, #SEQ (last_used_ssn));
    IFEND;
  PROCEND qfp$update_last_used_ssn;
?? OLDTITLE ??
MODEND jmm$manage_system_supplied_name;
*DECK DECK=JMM$NAME_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE job management name query program interfaces' ??
MODULE jmm$name_manager;

{ PURPOSE:
{   This module contains the job-management name query interfaces.

?? NEWTITLE := 'Global Declarations Referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_limits
*copyc cle$ecc_lexical
*copyc dft$rpc_parameters
*copyc jme$queued_file_conditions
*copyc jmk$keypoints
*copyc jmt$job_name_list
*copyc jmt$job_status_count
*copyc jmt$job_status_options
*copyc jmt$job_status_results
*copyc jmt$name
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc oss$job_paged_literal
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc clp$validate_name
*copyc i#compare_collated
*copyc jmp$get_job_status
*copyc jmp$get_result_size
*copyc jmp$system_job
*copyc jmp$update_ssn_sequence
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$verify_system_privilege
*copyc pmp$convert_mainframe_to_binary
*copyc pmp$get_job_names
*copyc qfp$get_job_internal_info
*copyc qfp$list_jobs_via_mode
*copyc jmv$ssn_previous_sequence
*copyc jmv$system_supplied_name
?? TITLE := 'Global Variables Declared in this Module', EJECT ??

  VAR
    jmv$ssn_mask: [STATIC, READ, oss$job_paged_literal] string (256) := $CHAR (00) CAT $CHAR (01) CAT
          $CHAR (02) CAT $CHAR (03) CAT $CHAR (04) CAT $CHAR (05) CAT $CHAR (06) CAT $CHAR (07) CAT
          $CHAR (08) CAT $CHAR (09) CAT $CHAR (10) CAT $CHAR (11) CAT $CHAR (12) CAT $CHAR (13) CAT
          $CHAR (14) CAT $CHAR (15) CAT $CHAR (16) CAT $CHAR (17) CAT $CHAR (18) CAT $CHAR (19) CAT
          $CHAR (20) CAT $CHAR (21) CAT $CHAR (22) CAT $CHAR (23) CAT $CHAR (24) CAT $CHAR (25) CAT
          $CHAR (26) CAT $CHAR (27) CAT $CHAR (28) CAT $CHAR (29) CAT $CHAR (30) CAT $CHAR (31) CAT
          ' !"#$%&''()*+,-./0000000000:;<=>?@AAAAAAAAAAAAAAAAAAAAAAAAAA[\]^_@AAAAAAAAAAAAAAAAAAAAAAAAAA{|}^'
          CAT $CHAR (127) CAT $CHAR (128) CAT $CHAR (129) CAT $CHAR (130) CAT $CHAR (131) CAT $CHAR (132) CAT
          $CHAR (133) CAT $CHAR (134) CAT $CHAR (135) CAT $CHAR (136) CAT $CHAR (137) CAT $CHAR (138) CAT
          $CHAR (139) CAT $CHAR (140) CAT $CHAR (141) CAT $CHAR (142) CAT $CHAR (143) CAT $CHAR (144) CAT
          $CHAR (145) CAT $CHAR (146) CAT $CHAR (147) CAT $CHAR (148) CAT $CHAR (149) CAT $CHAR (150) CAT
          $CHAR (151) CAT $CHAR (152) CAT $CHAR (153) CAT $CHAR (154) CAT $CHAR (155) CAT $CHAR (156) CAT
          $CHAR (157) CAT $CHAR (158) CAT $CHAR (159) CAT $CHAR (160) CAT $CHAR (161) CAT $CHAR (162) CAT
          $CHAR (163) CAT $CHAR (164) CAT $CHAR (165) CAT $CHAR (166) CAT $CHAR (167) CAT $CHAR (168) CAT
          $CHAR (169) CAT $CHAR (170) CAT $CHAR (171) CAT $CHAR (172) CAT $CHAR (173) CAT $CHAR (174) CAT
          $CHAR (175) CAT $CHAR (176) CAT $CHAR (177) CAT $CHAR (178) CAT $CHAR (179) CAT $CHAR (180) CAT
          $CHAR (181) CAT $CHAR (182) CAT $CHAR (183) CAT $CHAR (184) CAT $CHAR (185) CAT $CHAR (186) CAT
          $CHAR (187) CAT $CHAR (188) CAT $CHAR (189) CAT $CHAR (190) CAT $CHAR (191) CAT $CHAR (192) CAT
          $CHAR (193) CAT $CHAR (194) CAT $CHAR (195) CAT $CHAR (196) CAT $CHAR (197) CAT $CHAR (198) CAT
          $CHAR (199) CAT $CHAR (200) CAT $CHAR (201) CAT $CHAR (202) CAT $CHAR (203) CAT $CHAR (204) CAT
          $CHAR (205) CAT $CHAR (206) CAT $CHAR (207) CAT $CHAR (208) CAT $CHAR (209) CAT $CHAR (210) CAT
          $CHAR (211) CAT $CHAR (212) CAT $CHAR (213) CAT $CHAR (214) CAT $CHAR (215) CAT $CHAR (216) CAT
          $CHAR (217) CAT $CHAR (218) CAT $CHAR (219) CAT $CHAR (220) CAT $CHAR (221) CAT $CHAR (222) CAT
          $CHAR (223) CAT $CHAR (224) CAT $CHAR (225) CAT $CHAR (226) CAT $CHAR (227) CAT $CHAR (228) CAT
          $CHAR (229) CAT $CHAR (230) CAT $CHAR (231) CAT $CHAR (232) CAT $CHAR (233) CAT $CHAR (234) CAT
          $CHAR (235) CAT $CHAR (236) CAT $CHAR (237) CAT $CHAR (238) CAT $CHAR (239) CAT $CHAR (240) CAT
          $CHAR (241) CAT $CHAR (242) CAT $CHAR (243) CAT $CHAR (244) CAT $CHAR (245) CAT $CHAR (246) CAT
          $CHAR (247) CAT $CHAR (248) CAT $CHAR (249) CAT $CHAR (250) CAT $CHAR (251) CAT $CHAR (252) CAT
          $CHAR (253) CAT $CHAR (254) CAT $CHAR (255);

?? TITLE := '[XDCL] jmp$convert_name_to_ssn', EJECT ??
*copy jmh$convert_name_to_ssn

  PROCEDURE [XDCL] jmp$convert_name_to_ssn
    (    name: string ( * <= osc$max_name_size);
         privileged_job: boolean;
     VAR system_supplied_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      job_status_options_p: ^jmt$job_status_options,
      job_status_results_keys_p: ^jmt$results_keys,
      job_status_results_p: ^jmt$job_status_results,
      job_status_results_seq_p: ^jmt$work_area,
      number_of_jobs_found: jmt$job_status_count,
      size_of_sequence: ost$segment_length,
      valid_name: jmt$name;

    status.normal := TRUE;

    jmp$determine_name_kind (name, valid_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH job_status_options_p: [1 .. 2];
    job_status_options_p^ [1].key := jmc$name_list;
    PUSH job_status_options_p^ [1].name_list: [1 .. 1];
    job_status_options_p^ [1].name_list^ [1] := valid_name;
    job_status_options_p^ [2].key := jmc$privilege;
    job_status_options_p^ [2].privilege := jmc$users_default_privilege;
    IF privileged_job THEN
      job_status_options_p^ [2].privilege := jmc$privileged;
    IFEND;

    PUSH job_status_results_keys_p: [1 .. 1];
    job_status_results_keys_p^ [1] := jmc$system_job_name;
    jmp$get_result_size ({number_of_jobs} 1, #SEQ (job_status_results_keys_p^), size_of_sequence);
    PUSH job_status_results_seq_p: [[REP size_of_sequence OF cell]];

    jmp$get_job_status (job_status_options_p, job_status_results_keys_p, job_status_results_seq_p,
          job_status_results_p, number_of_jobs_found, status);
    IF number_of_jobs_found = 0 THEN
      osp$set_status_abnormal ('JM', jme$name_not_found, name, status);
    ELSEIF number_of_jobs_found > 1 THEN
      osp$set_status_abnormal ('JM', jme$duplicate_name, name, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    system_supplied_name := job_status_results_p^ [1]^ [1].system_job_name;

  PROCEND jmp$convert_name_to_ssn;
?? TITLE := '[XDCL, #GATE] jmp$determine_name_kind', EJECT ??
*copy jmh$determine_name_kind

  PROCEDURE [XDCL, #GATE] jmp$determine_name_kind
    (    candidate_name: string ( * <= osc$max_name_size);
     VAR name: jmt$name;
     VAR status: ost$status);

    VAR
      compare_ssn: record
        case boolean of
        = FALSE =
          name: ost$name,
        = TRUE =
          system_supplied_name: jmt$system_supplied_name_mask,
        casend,
      recend,
      verified_name: ost$name,
      system_supplied_name: jmt$system_supplied_name_mask,
      length: integer,
      valid_name: boolean;

?? NEWTITLE := '      convert_alpha_to_numeric', EJECT ??

{    The purpose of this request is to convert the alphabetical characters in a string to the
{  character zero ('0').  It is assumed that the input string has all alphabetical characters
{  in upper case.

    PROCEDURE [INLINE] convert_alpha_to_numeric
      (VAR stng: string ( * ));

      VAR
        index: integer;

      length := STRLENGTH (stng);
      FOR index := 1 TO STRLENGTH (stng) DO
        IF (stng (index) >= 'A') AND (stng (index) <= 'Z') THEN
          stng (index) := '0';
        IFEND;
      FOREND;
    PROCEND convert_alpha_to_numeric;

?? OLDTITLE ??

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, jmk$determine_name_kind);

    clp$validate_name (candidate_name, verified_name, valid_name);
    IF NOT valid_name THEN
      osp$set_status_abnormal ('cl', cle$improper_name, candidate_name, status);
      #KEYPOINT (osk$exit, 0, jmk$determine_name_kind);
      RETURN;
    IFEND;

{ The model number may be alpha-numeric - we need to convert the characters in the name in the
{ model# position in order for the compare collated to complete successfully if the model number
{ has an alphabetical character in it.

    compare_ssn.name := verified_name;
    convert_alpha_to_numeric (compare_ssn.system_supplied_name.model);

    IF i#compare_collated (compare_ssn.name, jmc$full_system_supplied_name, jmv$ssn_mask) = 0 THEN
      name.kind := jmc$system_supplied_name;
      name.system_supplied_name := verified_name;

    ELSEIF i#compare_collated (verified_name, jmc$long_system_supplied_name, jmv$ssn_mask) = 0 THEN
      name.kind := jmc$system_supplied_name;
      system_supplied_name := jmv$system_supplied_name;
      system_supplied_name.sequence := verified_name (2, jmc$ssn_sequence_number_size);
      system_supplied_name.counter := verified_name (6, jmc$ssn_counter_size);
      name.system_supplied_name := system_supplied_name.system_supplied_name;

    ELSEIF i#compare_collated (verified_name, jmc$short_system_supplied_name, jmv$ssn_mask) = 0 THEN
      name.kind := jmc$system_supplied_name;
      system_supplied_name := jmv$system_supplied_name;
      IF system_supplied_name.counter < verified_name (2, jmc$ssn_counter_size) THEN
        system_supplied_name.sequence := jmv$ssn_previous_sequence;
      IFEND;
      system_supplied_name.counter := verified_name (2, jmc$ssn_counter_size);
      name.system_supplied_name := system_supplied_name.system_supplied_name;

    ELSE
      name.kind := jmc$user_supplied_name;
      name.user_supplied_name := verified_name;
    IFEND;
    #KEYPOINT (osk$exit, 0, jmk$determine_name_kind);
  PROCEND jmp$determine_name_kind;
?? TITLE := '[XDCL] jmp$get_job_ijl_ordinal', EJECT ??
*copy jmh$get_job_ijl_ordinal

  PROCEDURE [XDCL] jmp$get_job_ijl_ordinal
    (    name: string ( * <= osc$max_name_size);
         privileged_job: boolean;
     VAR ijl_ordinal: jmt$ijl_ordinal;
     VAR system_supplied_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      job_internal_info: jmt$job_internal_information;

    status.normal := TRUE;

    jmp$convert_name_to_ssn (name, privileged_job, system_supplied_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    qfp$get_job_internal_info (system_supplied_name, job_internal_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    ijl_ordinal := job_internal_info.ijl_ordinal;
  PROCEND jmp$get_job_ijl_ordinal;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$get_job_names_by_user', EJECT ??
*copy jmh$get_job_names_by_user

  PROCEDURE [XDCL] jmp$get_job_names_by_user
    (    user: ost$name;
         family: ost$name;
         job_name_list_p: ^jmt$job_name_list;
     VAR number_of_jobs_found: jmt$job_status_count;
     VAR status: ost$status);

    VAR
      job_status_options_p: ^jmt$job_status_options,
      job_status_results_keys_p: ^jmt$results_keys,
      job_status_results_p: ^jmt$job_status_results,
      job_status_results_seq_p: ^jmt$work_area,
      result_index: jmt$job_status_count,
      size_of_sequence: ost$segment_length;

    status.normal := TRUE;

    PUSH job_status_options_p: [1 .. 5];
    job_status_options_p^ [1].key := jmc$login_user;
    job_status_options_p^ [1].login_user := user;
    job_status_options_p^ [2].key := jmc$login_family;
    job_status_options_p^ [2].login_family := family;
    job_status_options_p^ [3].key := jmc$job_state_set;
    job_status_options_p^ [3].job_state_set := $jmt$job_state_set [jmc$initiated_job, jmc$terminating_job];
    job_status_options_p^ [4].key := jmc$privilege;
    job_status_options_p^ [4].privilege := jmc$privileged;
    job_status_options_p^ [5].key := jmc$continue_request_to_servers;
    job_status_options_p^ [5].continue_request_to_servers := TRUE;

    PUSH job_status_results_keys_p: [1 .. 2];
    job_status_results_keys_p^ [1] := jmc$system_job_name;
    job_status_results_keys_p^ [2] := jmc$client_mainframe_id;

    jmp$get_result_size (UPPERBOUND (job_name_list_p^), #SEQ (job_status_results_keys_p^), size_of_sequence);
    PUSH job_status_results_seq_p: [[REP size_of_sequence OF cell]];

    jmp$get_job_status (job_status_options_p, job_status_results_keys_p, job_status_results_seq_p,
          job_status_results_p, number_of_jobs_found, status);
    IF (number_of_jobs_found > UPPERBOUND (job_name_list_p^)) THEN
      osp$set_status_condition (jme$result_array_too_small, status);
    ELSEIF number_of_jobs_found = 0 THEN
      osp$set_status_condition (jme$no_jobs_were_found, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR result_index := 1 TO number_of_jobs_found DO
      job_name_list_p^ [result_index].system_job_name := job_status_results_p^ [result_index]^ [1].
            system_job_name;
      pmp$convert_mainframe_to_binary (job_status_results_p^ [result_index]^ [2].client_mainframe_id,
            job_name_list_p^ [result_index].mainframe_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;
  PROCEND jmp$get_job_names_by_user;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$job_exists', EJECT ??
*copy jmh$job_exists

  PROCEDURE [XDCL, #GATE] jmp$job_exists
    (    name: string ( * <= osc$max_name_size);
         job_state_set: jmt$job_state_set;
     VAR job_exists: boolean;
     VAR status: ost$status);

    VAR
      job_status_options_p: ^jmt$job_status_options,
      job_status_results_p: ^jmt$job_status_results,
      job_status_results_seq_p: ^jmt$work_area,
      number_of_jobs_found: jmt$job_status_count,
      valid_name: jmt$name;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, jmk$job_exists);

    job_exists := FALSE;

    jmp$determine_name_kind (name, valid_name, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$job_exists);
      RETURN;
    IFEND;

    PUSH job_status_options_p: [1 .. 3];
    job_status_options_p^ [1].key := jmc$name_list;
    PUSH job_status_options_p^ [1].name_list: [1 .. 1];
    job_status_options_p^ [1].name_list^ [1] := valid_name;
    job_status_options_p^ [2].key := jmc$job_state_set;
    job_status_options_p^ [2].job_state_set := job_state_set;
    job_status_options_p^ [3].key := jmc$privilege;
    job_status_options_p^ [3].privilege := jmc$privileged;
    job_status_results_seq_p := NIL;
    job_status_results_p := NIL;

    jmp$get_job_status (job_status_options_p, {job_status_results_keys_p} NIL, job_status_results_seq_p,
          job_status_results_p, number_of_jobs_found, status);
    IF number_of_jobs_found = 0 THEN
      status.normal := TRUE;
      #KEYPOINT (osk$exit, 0, jmk$job_exists);
      RETURN;
    ELSEIF number_of_jobs_found > 1 THEN
      osp$set_status_abnormal ('JM', jme$duplicate_name, name, status);
    IFEND;
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$job_exists);
      RETURN;
    IFEND;

    job_exists := TRUE;
    #KEYPOINT (osk$exit, 0, jmk$job_exists);
  PROCEND jmp$job_exists;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$list_jobs_via_mode', EJECT ??
*copy jmh$list_jobs_via_mode

  PROCEDURE [XDCL] jmp$list_jobs_via_mode
    (    mode: jmt$job_mode;
     VAR ssn_job_name_list: array [1 .. * ] of jmt$system_supplied_name;
     VAR number_returned: integer;
     VAR status: ost$status);

    status.normal := TRUE;

    qfp$list_jobs_via_mode (mode, ssn_job_name_list, number_returned, status);
  PROCEND jmp$list_jobs_via_mode;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$validate_name', EJECT ??
*copy jmh$validate_name

  PROCEDURE [XDCL, #GATE] jmp$validate_name
    (    candidate_name: jmt$name;
     VAR name: jmt$name;
     VAR status: ost$status);

    VAR
      valid_name: jmt$name,
      clname: ost$name,
      verified_name: ost$name;

    status.normal := TRUE;

    CASE candidate_name.kind OF
    = jmc$system_supplied_name =
      clname := candidate_name.system_supplied_name;
      jmp$determine_name_kind (clname, valid_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF valid_name.kind <> jmc$system_supplied_name THEN
        osp$set_status_abnormal ('JM', jme$illegal_ssn, candidate_name.system_supplied_name, status);
        RETURN;
      IFEND;

      name := valid_name;

    = jmc$user_supplied_name =
      clname := candidate_name.user_supplied_name;

      jmp$determine_name_kind (clname, valid_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF valid_name.kind <> jmc$user_supplied_name THEN
        osp$set_status_abnormal ('JM', jme$illegal_usn, candidate_name.user_supplied_name, status);
        RETURN;
      IFEND;

      name := valid_name;

    ELSE
      ;
    CASEND;
  PROCEND jmp$validate_name;
?? TITLE := '[XDCL, #GATE] jmp$set_system_sequence_number', EJECT ??
*copyc jmh$set_system_sequence_number

  PROCEDURE [XDCL, #GATE] jmp$set_system_sequence_number
    (    system_sequence_number: string ( * <= osc$max_name_size);
     VAR status: ost$status);

    VAR
      candidate_name: jmt$name,
      valid_name: jmt$name;

    status.normal := TRUE;

    osp$verify_system_privilege;
    candidate_name.kind := jmc$system_supplied_name;
    candidate_name.system_supplied_name := system_sequence_number;
    jmp$validate_name (candidate_name, valid_name, status);
    IF status.normal THEN
      jmp$update_ssn_sequence (valid_name.system_supplied_name);
    IFEND;
  PROCEND jmp$set_system_sequence_number;
?? OLDTITLE ??
MODEND jmm$name_manager;
*DECK DECK=JMM$OFFLINE_OUTPUT_SUPPORT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Offline Output Device Support' ??
MODULE jmm$offline_output_support;

{ PURPOSE:
{   This module contains the code for the NOS/VE Management of offline output
{   devices.
{
{ DESIGN:
{   This code executes in ring 3.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc fst$file_reference
*copyc jme$queued_file_conditions
*copyc jmt$error_status_list
*copyc jmt$output_count_range
*copyc jmt$output_descriptor
*copyc jmt$output_device
*copyc ofe$error_codes
*copyc osd$integer_limits
*copyc ost$caller_identifier
*copyc ost$status
*copyc pmt$entry_point_reference
?? POP ??
*copyc amp$get_next
*copyc amp$put_next
*copyc avp$system_administrator
*copyc avp$system_operator
*copyc clp$validate_name
*copyc fsp$close_file
*copyc fsp$open_file
*copyc jmp$acquire_new_output
*copyc jmp$close_output_file
*copyc jmp$new_output_exists
*copyc jmp$open_output_file
*copyc jmp$register_output_application
*copyc jmp$release_output_files
*copyc jmp$set_output_completed
*copyc jmp$set_output_initiated
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
?? OLDTITLE ??
?? NEWTITLE := 'jmp$combine_offline_output', EJECT ??
*copy jmh$combine_offline_output

{ DESIGN:
{   Verify that SOU is active with system administration or system operation
{   capability.
{
{   Validate the device name and initialize the combined_file_count and error_file_count.
{
{   Register as the application OSA$COMBINE_OFFLINE_OUTPUT for the output_destination_usage
{   of OFFLINE.
{
{   Open the tape file and verify that it has a device class of magnetic tape.
{
{   While files exist, and less than "number_of_files_to_combine" files have been
{   copied to tape, acquire a new output file.  If the device of the output file
{   does not match the device name specified on the request then set the output file
{   as completed indicating that it could not be disposed of and acquire another new
{   file.
{
{   If the device names match, then open the output file and copy it record by record
{   to the tape.  Close the output file.  If any errors occured, add the file to the
{   error file list and set the output as completed indicating that the file could
{   not be disposed of.  If no errors occured, add the file to the output file list
{   and set the output completed indicating that the file was disposed of.  This removes
{   the file from the output queue.
{
{   When all files are gone, close the tape file and unregister the application
{   OSA$COMBINE_OFFLINE_OUTPUT.

  PROCEDURE [XDCL, #GATE] jmp$combine_offline_output
    (    tape_file_path: fst$file_reference;
         device_name: jmt$output_device;
         number_of_files_to_combine: jmt$output_count_range;
     VAR combined_file_count: jmt$output_count_range;
     VAR combined_file_list: array [1 .. * ] of jmt$output_descriptor;
     VAR error_file_count: jmt$output_count_range;
     VAR error_file_list: jmt$error_status_list;
     VAR status: ost$status);

    CONST
      combine_application_name = 'OSA$COMBINE_OFFLINE_OUTPUT     ',
      combine_destination_usage_name = 'OFFLINE                        ';

    VAR
      attribute_validation_p: ^fst$file_cycle_attributes,
      byte_address: amt$file_byte_address,
      caller_id: ost$caller_identifier,
      combined_file_limit: ost$non_negative_integers,
      error_file_limit: ost$non_negative_integers,
      file_attachment_p: ^fst$attachment_options,
      file_position: amt$file_position,
      local_status: ost$status,
      null_file_access_procedure: pmt$entry_point_reference,
      output_descriptor: jmt$output_descriptor,
      queue_file_identifier: amt$file_identifier,
      queue_file_open: boolean,
      queue_file_password: jmt$queue_file_password,
      scratch_segment_created: boolean,
      tape_file_identifier: amt$file_identifier,
      tape_file_open: boolean,
      transfer_count: amt$transfer_count,
      valid_device_name: jmt$output_device,
      valid_name: boolean,
      work_area_p: ^cell,
      working_storage_area: amt$segment_pointer,
      working_storage_area_size: amt$working_storage_length;

?? NEWTITLE := 'comoo_block_exit_handler', EJECT ??

    PROCEDURE comoo_block_exit_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF tape_file_open THEN
        fsp$close_file (tape_file_identifier, ignore_status);
      IFEND;
      IF scratch_segment_created THEN
        mmp$delete_scratch_segment (working_storage_area, ignore_status);
      IFEND;
      IF queue_file_open THEN
        jmp$close_output_file (queue_file_identifier, ignore_status);
      IFEND;
      jmp$release_output_files;
    PROCEND comoo_block_exit_handler;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    local_status.normal := TRUE;
    #CALLER_ID (caller_id);
    tape_file_open := FALSE;
    scratch_segment_created := FALSE;
    queue_file_open := FALSE;
    #SPOIL (tape_file_open, scratch_segment_created, queue_file_open);

    IF NOT (avp$system_administrator () OR avp$system_operator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_administration or system_operation', status);
      RETURN;
    IFEND;

    clp$validate_name (device_name, valid_device_name, valid_name);
    IF NOT valid_name THEN
      osp$set_status_abnormal ('CL', cle$improper_name, device_name, status);
    IFEND;

    combined_file_count := 0;
    error_file_count := 0;

    combined_file_limit := UPPERBOUND (combined_file_list);
    IF combined_file_limit > number_of_files_to_combine THEN
      combined_file_limit := number_of_files_to_combine;
    IFEND;

    error_file_limit := UPPERBOUND (error_file_list);

    jmp$register_output_application (combine_application_name, combine_destination_usage_name,
          queue_file_password, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Setup a block exit handler to cleanup should a problem occur.

    osp$establish_block_exit_hndlr (^comoo_block_exit_handler);

    PUSH file_attachment_p: [1 .. 3];
    file_attachment_p^ [1].selector := fsc$access_and_share_modes;
    file_attachment_p^ [1].access_modes.selector := fsc$specific_access_modes;
    file_attachment_p^ [1].access_modes.value := $fst$file_access_options
          [fsc$shorten, fsc$append, fsc$modify, fsc$read];
    file_attachment_p^ [1].share_modes.selector := fsc$specific_share_modes;
    file_attachment_p^ [1].share_modes.value := $fst$file_access_options [];
    file_attachment_p^ [2].selector := fsc$allowed_device_classes;
    file_attachment_p^ [2].allowed_device_classes := $fst$device_classes
          [fsc$magnetic_tape_device];
    file_attachment_p^ [3].selector := fsc$validation_ring;
    file_attachment_p^ [3].validation_ring := caller_id.ring;

    null_file_access_procedure.entry_point := osc$null_name;
    null_file_access_procedure.object_library := '';
    PUSH attribute_validation_p: [1 .. 1];
    attribute_validation_p^ [1].selector := fsc$file_access_procedure_name;
    attribute_validation_p^ [1].file_access_procedure_name := ^null_file_access_procedure;

    fsp$open_file (tape_file_path, amc$record, file_attachment_p, {default_creation_attributes} NIL,
          {mandated_creation_attributes} NIL, attribute_validation_p, {attribute_override} NIL,
          tape_file_identifier, status);
    IF NOT status.normal THEN
      jmp$release_output_files;
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    tape_file_open := TRUE;
    #SPOIL (tape_file_open, tape_file_identifier);

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, working_storage_area, status);
    IF NOT status.normal THEN
      fsp$close_file (tape_file_identifier, {ignore} local_status);
      tape_file_open := FALSE;
      #SPOIL (tape_file_open);
      jmp$release_output_files;
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    scratch_segment_created := TRUE;
    #SPOIL (scratch_segment_created, working_storage_area);

    RESET working_storage_area.sequence_pointer;
    NEXT work_area_p IN working_storage_area.sequence_pointer;
    working_storage_area_size := osc$max_segment_length;

    WHILE (combined_file_count < combined_file_limit) AND
          (jmp$new_output_exists (combine_destination_usage_name)) DO
      local_status.normal := TRUE;
      jmp$acquire_new_output (combine_destination_usage_name, output_descriptor, local_status);
      IF local_status.normal AND (output_descriptor.device = valid_device_name) THEN
        jmp$set_output_initiated (combine_destination_usage_name, output_descriptor.system_file_name,
              local_status);
        IF local_status.normal THEN
          jmp$open_output_file (output_descriptor.system_file_name, amc$record,
                combine_destination_usage_name, queue_file_password, queue_file_identifier, local_status);
          IF local_status.normal THEN
            #SPOIL (queue_file_open);
            queue_file_open := TRUE;
            #SPOIL (queue_file_open, queue_file_identifier);

            file_position := amc$boi;
            WHILE local_status.normal AND (file_position <> amc$eoi) DO
              amp$get_next (queue_file_identifier, work_area_p, working_storage_area_size, transfer_count,
                    byte_address, file_position, local_status);
              IF local_status.normal THEN
                amp$put_next (tape_file_identifier, work_area_p, transfer_count, byte_address, local_status);
              IFEND;
            WHILEND;
            IF (file_position = amc$eoi) OR (status.condition = ame$input_after_eoi) THEN
              jmp$close_output_file (queue_file_identifier, {ignore} local_status);
              #SPOIL (queue_file_open);
              queue_file_open := FALSE;
              #SPOIL (queue_file_open);
              jmp$set_output_completed (combine_destination_usage_name, output_descriptor.system_file_name,
                    {completed_successfully} TRUE, {ignore} local_status);
              combined_file_count := combined_file_count + 1;
              combined_file_list [combined_file_count] := output_descriptor;
              local_status.normal := TRUE;
            ELSE
              IF error_file_count < error_file_limit THEN
                error_file_count := error_file_count + 1;
                error_file_list [error_file_count].system_supplied_name := output_descriptor.system_file_name;
                error_file_list [error_file_count].status := local_status;
              IFEND; { error list full
              jmp$close_output_file (queue_file_identifier, {ignore} local_status);
              #SPOIL (queue_file_open);
              queue_file_open := FALSE;
              #SPOIL (queue_file_open);
            IFEND;
          IFEND; { set output initiated
        ELSE
          IF error_file_count < error_file_limit THEN
            error_file_count := error_file_count + 1;
            error_file_list [error_file_count].system_supplied_name := output_descriptor.system_file_name;
            error_file_list [error_file_count].status := local_status;
          IFEND; { error list full
        IFEND; { couldn't open file
      IFEND; { file with correct device acquired
    WHILEND;

    mmp$delete_scratch_segment (working_storage_area, {ignore} local_status);
    #SPOIL (scratch_segment_created);
    scratch_segment_created := FALSE;
    #SPOIL (scratch_segment_created);
    fsp$close_file (tape_file_identifier, status);
    #SPOIL (tape_file_open);
    tape_file_open := FALSE;
    #SPOIL (tape_file_open);
    jmp$release_output_files;
    osp$disestablish_cond_handler;

{ If no files with the specified device were found, report it as an error.

    IF status.normal AND (combined_file_count = 0) AND (error_file_count = 0) THEN
      osp$set_status_condition (jme$no_outputs_were_found, status);
    IFEND;
  PROCEND jmp$combine_offline_output;
?? OLDTITLE ??
MODEND jmm$offline_output_support;
*DECK DECK=JMM$OPERATOR_FACILITY_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOSVE job management operator facility command procedures' ??
MODULE jmm$operator_facility_commands;

{ PURPOSE:
{   This module contains the command processors for the Job Management related
{ operator facility commands.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc jme$queued_file_conditions
*copyc jmk$keypoints
*copyc jmt$attribute_keys_set
*copyc jmt$attribute_values
*copyc jmt$job_counts
*copyc jmt$job_status_count
*copyc jmt$job_status_options
*copyc jmt$job_status_results
*copyc jmt$output_counts
*copyc jmt$output_status_count
*copyc jmt$output_status_options
*copyc jmt$output_status_results
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*copyc clp$convert_string_to_file
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc jmp$change_attribute_defaults
*copyc jmp$change_terminate_job_action
*copyc jmp$display_attributes
*copyc jmp$get_job_status
*copyc jmp$get_output_status
*copyc jmp$get_terminate_job_action
*copyc jmp$idle_system
*copyc jmp$resume_system
*copyc jmp$system_job
*copyc jmp$set_system_sequence_number
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
?? TITLE := '[XDCL, #GATE] clp$change_job_attr_default_cmd', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$change_job_attr_default_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$chajad) change_job_attribute_default, change_job_attribute_defaults, chajad (
{   job_mode, jm: any of
{       key
{         all
{       keyend
{       list of key
{         (batch, b)
{         (interactive, i)
{       keyend
{     anyend = all
{   cpu_time_limit, ctl: any of
{       key
{         required, unlimited
{       keyend
{       integer jmc$lowest_cpu_time_limit..jmc$highest_cpu_time_limit
{     anyend = $optional
{   job_abort_disposition, jad: key
{       (restart, r)
{       (terminate, t)
{     keyend = $optional
{   job_class, jc: name = $optional
{   job_deferred_by_operator, jdbo: boolean = $optional
{   job_destination_usage, jdu: key
{       ve, ve_family, ve_local, ve_qtf
{     keyend = $optional
{   job_qualifier, job_qualifiers, jq: any of
{       key
{         none, required
{       keyend
{       list 1..jmc$maximum_job_qualifiers of name
{     anyend = $optional
{   job_recovery_disposition, jrd: key
{       (continue, c)
{       (restart, r)
{       (terminate, t)
{     keyend = $optional
{   login_family, lf: name = $optional
{   magnetic_tape_limit, mtl: any of
{       key
{         required, unlimited, unspecified
{       keyend
{       integer jmc$lowest_magnetic_tape_limit..jmc$highest_magnetic_tape_limit
{     anyend = $optional
{   maximum_working_set, maxws: any of
{       key
{         required, unlimited
{       keyend
{       integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{     anyend = $optional
{   output_class, oc: key
{       normal
{     keyend = $optional
{   output_deferred_by_operator, odbo: boolean = $optional
{   output_destination_usage, destination_usage, du, odu: any of
{       key
{         dual_state, ntf, private, public, qtf
{       keyend
{       name
{     anyend = $optional
{   purge_delay, pd: any of
{       key
{         none
{       keyend
{       time_increment
{     anyend = $optional
{   site_information, si: string 0..jmc$site_information_size = $optional
{   sru_limit, sl: any of
{       key
{         required, unlimited
{       keyend
{       integer jmc$lowest_sru_limit..jmc$highest_sru_limit
{     anyend = $optional
{   station, s: name = $optional
{   vertical_print_density, vpd: key
{       six, eight, none, file
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 42] of clt$pdt_parameter_name,
      parameters: array [1 .. 20] 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 .. 4] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type7: 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 .. 2] 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$name_type_qualifier,
          recend,
        recend,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type10: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type11: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 1] of clt$keyword_specification,
      recend,
      type13: record
        header: clt$type_specification_header,
      recend,
      type14: 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 .. 5] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type15: 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,
        recend,
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type17: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type18: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type19: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type20: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 7, 8, 15, 40, 21, 820],
    clc$command, 42, 20, 0, 0, 0, 0, 20, 'OSM$CHAJAD'], [
    ['CPU_TIME_LIMIT                 ',clc$nominal_entry, 2],
    ['CTL                            ',clc$abbreviation_entry, 2],
    ['DESTINATION_USAGE              ',clc$alias_entry, 14],
    ['DU                             ',clc$alias_entry, 14],
    ['JAD                            ',clc$abbreviation_entry, 3],
    ['JC                             ',clc$abbreviation_entry, 4],
    ['JDBO                           ',clc$abbreviation_entry, 5],
    ['JDU                            ',clc$abbreviation_entry, 6],
    ['JM                             ',clc$abbreviation_entry, 1],
    ['JOB_ABORT_DISPOSITION          ',clc$nominal_entry, 3],
    ['JOB_CLASS                      ',clc$nominal_entry, 4],
    ['JOB_DEFERRED_BY_OPERATOR       ',clc$nominal_entry, 5],
    ['JOB_DESTINATION_USAGE          ',clc$nominal_entry, 6],
    ['JOB_MODE                       ',clc$nominal_entry, 1],
    ['JOB_QUALIFIER                  ',clc$nominal_entry, 7],
    ['JOB_QUALIFIERS                 ',clc$alias_entry, 7],
    ['JOB_RECOVERY_DISPOSITION       ',clc$nominal_entry, 8],
    ['JQ                             ',clc$abbreviation_entry, 7],
    ['JRD                            ',clc$abbreviation_entry, 8],
    ['LF                             ',clc$abbreviation_entry, 9],
    ['LOGIN_FAMILY                   ',clc$nominal_entry, 9],
    ['MAGNETIC_TAPE_LIMIT            ',clc$nominal_entry, 10],
    ['MAXIMUM_WORKING_SET            ',clc$nominal_entry, 11],
    ['MAXWS                          ',clc$abbreviation_entry, 11],
    ['MTL                            ',clc$abbreviation_entry, 10],
    ['OC                             ',clc$abbreviation_entry, 12],
    ['ODBO                           ',clc$abbreviation_entry, 13],
    ['ODU                            ',clc$abbreviation_entry, 14],
    ['OUTPUT_CLASS                   ',clc$nominal_entry, 12],
    ['OUTPUT_DEFERRED_BY_OPERATOR    ',clc$nominal_entry, 13],
    ['OUTPUT_DESTINATION_USAGE       ',clc$nominal_entry, 14],
    ['PD                             ',clc$abbreviation_entry, 15],
    ['PURGE_DELAY                    ',clc$nominal_entry, 15],
    ['S                              ',clc$abbreviation_entry, 18],
    ['SI                             ',clc$abbreviation_entry, 16],
    ['SITE_INFORMATION               ',clc$nominal_entry, 16],
    ['SL                             ',clc$abbreviation_entry, 17],
    ['SRU_LIMIT                      ',clc$nominal_entry, 17],
    ['STATION                        ',clc$nominal_entry, 18],
    ['STATUS                         ',clc$nominal_entry, 20],
    ['VERTICAL_PRINT_DENSITY         ',clc$nominal_entry, 19],
    ['VPD                            ',clc$abbreviation_entry, 19]],
    [
{ PARAMETER 1
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 235,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 6
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 122,
  clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 10
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 158,
  clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 44, clc$optional_parameter,
  0, 0],
{ PARAMETER 13
    [30, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 14
    [31, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 217,
  clc$optional_parameter, 0, 0],
{ PARAMETER 15
    [33, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 67, clc$optional_parameter,
  0, 0],
{ PARAMETER 16
    [36, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 17
    [38, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 18
    [39, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 19
    [41, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 20
    [40, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    171, [[1, 0, clc$list_type], [155, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [4], [
        ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['BATCH                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['INTERACTIVE                    ', clc$nominal_entry, clc$normal_usage_entry, 2]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['REQUIRED                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_cpu_time_limit, jmc$highest_cpu_time_limit, 10]]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['RESTART                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 5
    [[1, 0, clc$boolean_type]],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [4], [
    ['VE                             ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['VE_FAMILY                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['VE_LOCAL                       ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['VE_QTF                         ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['REQUIRED                       ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, jmc$maximum_job_qualifiers, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 8
    [[1, 0, clc$keyword_type], [6], [
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CONTINUE                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['RESTART                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 9
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['REQUIRED                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_magnetic_tape_limit, jmc$highest_magnetic_tape_limit, 10]]
    ],
{ PARAMETER 11
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['REQUIRED                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_working_set_size, jmc$highest_working_set_size, 10]]
    ],
{ PARAMETER 12
    [[1, 0, clc$keyword_type], [1], [
    ['NORMAL                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 13
    [[1, 0, clc$boolean_type]],
{ PARAMETER 14
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    192, [[1, 0, clc$keyword_type], [5], [
      ['DUAL_STATE                     ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['NTF                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['PRIVATE                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['PUBLIC                         ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['QTF                            ', clc$nominal_entry, clc$normal_usage_entry, 5]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 15
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$time_increment_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$time_increment_type]]
    ],
{ PARAMETER 16
    [[1, 0, clc$string_type], [0, jmc$site_information_size, FALSE]],
{ PARAMETER 17
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['REQUIRED                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_sru_limit, jmc$highest_sru_limit, 10]]
    ],
{ PARAMETER 18
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 19
    [[1, 0, clc$keyword_type], [4], [
    ['EIGHT                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['FILE                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['SIX                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 20
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$job_mode = 1,
      p$cpu_time_limit = 2,
      p$job_abort_disposition = 3,
      p$job_class = 4,
      p$job_deferred_by_operator = 5,
      p$job_destination_usage = 6,
      p$job_qualifier = 7,
      p$job_recovery_disposition = 8,
      p$login_family = 9,
      p$magnetic_tape_limit = 10,
      p$maximum_working_set = 11,
      p$output_class = 12,
      p$output_deferred_by_operator = 13,
      p$output_destination_usage = 14,
      p$purge_delay = 15,
      p$site_information = 16,
      p$sru_limit = 17,
      p$station = 18,
      p$vertical_print_density = 19,
      p$status = 20;

    VAR
      pvt: array [1 .. 20] of clt$parameter_value;

    VAR
      change_batch: boolean,
      change_interactive: boolean,
      default_attribute_changes: ^jmt$default_attribute_changes,
      default_attribute_index: 0 .. p$vertical_print_density,
      index: 1 .. clc$max_list_size,
      list_count: 0 .. clc$max_list_size,
      number_of_default_attributes: 0 .. p$vertical_print_density,
      qualifier_options: ^clt$data_value,
      set_list: ^clt$data_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    default_attribute_index := 0;
    number_of_default_attributes := 0;

    FOR index := p$cpu_time_limit TO p$vertical_print_density DO
      IF pvt [index].specified THEN
        number_of_default_attributes := number_of_default_attributes + 1;
      IFEND;
    FOREND;

    PUSH default_attribute_changes: [1 .. number_of_default_attributes];

{  Process CPU_TIME_LIMIT parameter.

    IF pvt [p$cpu_time_limit].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$cpu_time_limit;
      IF pvt [p$cpu_time_limit].value^.kind = clc$integer THEN
        default_attribute_changes^ [default_attribute_index].cpu_time_limit := pvt [p$cpu_time_limit].
              value^.integer_value.value;
      ELSE
        IF pvt [p$cpu_time_limit].value^.keyword_value = 'REQUIRED' THEN
          default_attribute_changes^ [default_attribute_index].cpu_time_limit := jmc$required_cpu_time_limit;
        ELSE { pvt [p$cpu_time_limit].value^.keyword_value = 'UNLIMITED'.
          default_attribute_changes^ [default_attribute_index].cpu_time_limit := jmc$unlimited_cpu_time_limit;
        IFEND;
      IFEND;
    IFEND;

{  Process JOB_ABORT_DISPOSITION parameter.

    IF pvt [p$job_abort_disposition].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$job_abort_disposition;
      IF pvt [p$job_abort_disposition].value^.keyword_value = 'RESTART' THEN
        default_attribute_changes^ [default_attribute_index].job_abort_disposition := jmc$restart_on_abort;
      ELSE { TERMINATE is the only other choice. }
        default_attribute_changes^ [default_attribute_index].job_abort_disposition := jmc$terminate_on_abort;
      IFEND;
    IFEND;

{ Process JOB_CLASS parameter.

    IF pvt [p$job_class].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$job_class;
      default_attribute_changes^ [default_attribute_index].job_class := pvt [p$job_class].value^.name_value;
    IFEND;

{  Process JOB_DEFERRED_BY_OPERATOR parameter.

    IF pvt [p$job_deferred_by_operator].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$job_deferred_by_operator;
      default_attribute_changes^ [default_attribute_index].
            job_deferred_by_operator := pvt [p$job_deferred_by_operator].value^.boolean_value.value;
    IFEND;

{  Process JOB_DESTINATION_USAGE parameter.

    IF pvt [p$job_destination_usage].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$job_destination_usage;
      default_attribute_changes^ [default_attribute_index].job_destination_usage :=
            pvt [p$job_destination_usage].value^.keyword_value;
    IFEND;

{  Process JOB_QUALIFIER parameter.

    IF pvt [p$job_qualifier].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$job_qualifier_list;
      IF pvt [p$job_qualifier].value^.kind = clc$keyword THEN
        PUSH default_attribute_changes^ [default_attribute_index].job_qualifier_list: [1 .. 1];
        IF pvt [p$job_qualifier].value^.keyword_value = 'NONE' THEN
          default_attribute_changes^ [default_attribute_index].job_qualifier_list^ [1] := osc$null_name;
        ELSE { keyword_value = 'REQUIRED'}
          default_attribute_changes^ [default_attribute_index].job_qualifier_list^ [1] :=
                pvt [p$job_qualifier].value^.keyword_value;
        IFEND;
      ELSE
        list_count := clp$count_list_elements (pvt [p$job_qualifier].value);
        PUSH default_attribute_changes^ [default_attribute_index].job_qualifier_list: [1 .. list_count];
        qualifier_options := pvt [p$job_qualifier].value;
        FOR index := 1 TO list_count DO
          default_attribute_changes^ [default_attribute_index].job_qualifier_list^ [index] :=
                qualifier_options^.element_value^.name_value;
          qualifier_options := qualifier_options^.link;
        FOREND;
      IFEND;
    IFEND;

{  Process JOB_RECOVERY_DISPOSITION parameter.

    IF pvt [p$job_recovery_disposition].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$job_recovery_disposition;
      IF pvt [p$job_recovery_disposition].value^.keyword_value = 'RESTART' THEN
        default_attribute_changes^ [default_attribute_index].job_recovery_disposition :=
              jmc$restart_on_recovery;
      ELSEIF pvt [p$job_recovery_disposition].value^.keyword_value = 'CONTINUE' THEN
        default_attribute_changes^ [default_attribute_index].job_recovery_disposition :=
              jmc$continue_on_recovery;
      ELSE { pvt [p$job_recovery_disposition].value^.keyword_value = 'TERMINATE'.
        default_attribute_changes^ [default_attribute_index].job_recovery_disposition :=
              jmc$terminate_on_recovery;
      IFEND;
    IFEND;

{  Process LOGIN_FAMILY parameter.

    IF pvt [p$login_family].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$login_family;
      default_attribute_changes^ [default_attribute_index].login_family := pvt [p$login_family].
            value^.name_value;
    IFEND;

{  Process MAGNETIC_TAPE_LIMIT parameter.

    IF pvt [p$magnetic_tape_limit].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$magnetic_tape_limit;
      IF pvt [p$magnetic_tape_limit].value^.kind = clc$integer THEN
        default_attribute_changes^ [default_attribute_index].
              magnetic_tape_limit := pvt [p$magnetic_tape_limit].value^.integer_value.value;
      ELSE
        IF pvt [p$magnetic_tape_limit].value^.keyword_value = 'UNSPECIFIED' THEN
          default_attribute_changes^ [default_attribute_index].magnetic_tape_limit :=
                jmc$unspecified_mag_tape_limit;
        ELSEIF pvt [p$magnetic_tape_limit].value^.keyword_value = 'REQUIRED' THEN
          default_attribute_changes^ [default_attribute_index].magnetic_tape_limit :=
                jmc$required_mag_tape_limit;
        ELSE { pvt [p$magnetic_tape_limit].value^.keyword_value = 'UNLIMITED'.
          default_attribute_changes^ [default_attribute_index].magnetic_tape_limit :=
                jmc$unlimited_mag_tape_limit;
        IFEND;
      IFEND;
    IFEND;

{  Process MAXIMUM_WORKING_SET parameter.

    IF pvt [p$maximum_working_set].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$maximum_working_set;
      IF pvt [p$maximum_working_set].value^.kind = clc$integer THEN
        default_attribute_changes^ [default_attribute_index].
              maximum_working_set := pvt [p$maximum_working_set].value^.integer_value.value;
      ELSE
        IF pvt [p$maximum_working_set].value^.keyword_value = 'REQUIRED' THEN
          default_attribute_changes^ [default_attribute_index].maximum_working_set :=
                jmc$required_working_set_size;
        ELSE { pvt [p$maximum_working_set].value^.keyword_value = 'UNLIMITED'.
          default_attribute_changes^ [default_attribute_index].maximum_working_set :=
                jmc$unlimited_working_set_size;
        IFEND;
      IFEND;
    IFEND;

{  Process OUTPUT_CLASS parameter.

    IF pvt [p$output_class].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$output_class;
      default_attribute_changes^ [default_attribute_index].output_class := pvt [p$output_class].
            value^.name_value;
    IFEND;

{  Process OUTPUT_DEFERRED_BY_OPERATOR parameter.

    IF pvt [p$output_deferred_by_operator].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$output_deferred_by_operator;
      default_attribute_changes^ [default_attribute_index].
            output_deferred_by_operator := pvt [p$output_deferred_by_operator].value^.boolean_value.value;
    IFEND;

{  Process OUTPUT_DESTINATION_USAGE parameter.

    IF pvt [p$output_destination_usage].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$output_destination_usage;
      IF pvt [p$output_destination_usage].value^.kind = clc$name THEN
        default_attribute_changes^ [default_attribute_index].
              output_destination_usage := pvt [p$output_destination_usage].value^.name_value;
      ELSE
        default_attribute_changes^ [default_attribute_index].
              output_destination_usage := pvt [p$output_destination_usage].value^.keyword_value;
      IFEND;
    IFEND;

{  Process PURGE_DELAY parameter.

    IF pvt [p$purge_delay].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$purge_delay;
      PUSH default_attribute_changes^ [default_attribute_index].purge_delay;
      IF pvt [p$purge_delay].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        default_attribute_changes^ [default_attribute_index].purge_delay^.specified := FALSE;
      ELSE
        default_attribute_changes^ [default_attribute_index].purge_delay^.specified := TRUE;
        default_attribute_changes^ [default_attribute_index].
              purge_delay^.time_increment := pvt [p$purge_delay].value^.time_increment_value^;
      IFEND;
    IFEND;

{  Process SITE_INFORMATION parameter.

    IF pvt [p$site_information].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$site_information;
      PUSH default_attribute_changes^ [default_attribute_index].site_information;
      default_attribute_changes^ [default_attribute_index].site_information^ := pvt [p$site_information].
            value^.string_value^;
    IFEND;

{  Process SRU_LIMIT parameter.

    IF pvt [p$sru_limit].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$sru_limit;
      IF pvt [p$sru_limit].value^.kind = clc$integer THEN
        default_attribute_changes^ [default_attribute_index].sru_limit := pvt [p$sru_limit].
              value^.integer_value.value;
      ELSE
        IF pvt [p$sru_limit].value^.keyword_value = 'REQUIRED' THEN
          default_attribute_changes^ [default_attribute_index].sru_limit := jmc$required_sru_limit;
        ELSE { pvt [p$sru_limit].value^.keyword_value = 'UNLIMITED'.
          default_attribute_changes^ [default_attribute_index].sru_limit := jmc$unlimited_sru_limit;
        IFEND;
      IFEND;
    IFEND;

{  Process STATION parameter.

    IF pvt [p$station].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$station;
      default_attribute_changes^ [default_attribute_index].station := pvt [p$station].value^.name_value;
    IFEND;

{  Process VERTICAL_PRINT_DENSITY parameter.

    IF pvt [p$vertical_print_density].specified THEN
      default_attribute_index := default_attribute_index + 1;
      default_attribute_changes^ [default_attribute_index].key := jmc$vertical_print_density;
      IF pvt [p$vertical_print_density].value^.keyword_value = 'FILE' THEN
        default_attribute_changes^ [default_attribute_index].vertical_print_density :=
              jmc$vertical_print_density_file;
      ELSEIF pvt [p$vertical_print_density].value^.keyword_value = 'NONE' THEN
        default_attribute_changes^ [default_attribute_index].vertical_print_density :=
              jmc$vertical_print_density_none;
      ELSEIF pvt [p$vertical_print_density].value^.keyword_value = 'SIX' THEN
        default_attribute_changes^ [default_attribute_index].vertical_print_density :=
              jmc$vertical_print_density_6;
      ELSE { pvt [p$vertical_print_density].value^.keyword_value = 'EIGHT'
        default_attribute_changes^ [default_attribute_index].vertical_print_density :=
              jmc$vertical_print_density_8;
      IFEND;
    IFEND;

{  Process JOB_MODE parameter.

    change_batch := FALSE;
    change_interactive := FALSE;

    IF pvt [p$job_mode].value^.kind = clc$keyword THEN { the only keyword allowed is ALL. }
      change_batch := TRUE;
      change_interactive := TRUE;
    ELSE
      set_list := pvt [p$job_mode].value;
      WHILE set_list <> NIL DO
        IF set_list^.element_value^.keyword_value = 'BATCH' THEN
          change_batch := TRUE;
        ELSE { set_list^.element_value^.keyword_value = 'INTERACTIVE' THEN
          change_interactive := TRUE;
        IFEND;
        set_list := set_list^.link;
      WHILEND;
    IFEND;

    IF change_batch THEN
      jmp$change_attribute_defaults (jmc$batch, default_attribute_changes, status);
    IFEND;

    IF status.normal AND change_interactive THEN
      jmp$change_attribute_defaults (jmc$interactive_connected, default_attribute_changes, status);
    IFEND;
  PROCEND clp$change_job_attr_default_cmd;
?? TITLE := '[XDCL] jmp$change_job_name_counter', EJECT ??

  PROCEDURE [XDCL] jmp$change_job_name_counter
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT change_job_name_counter (
{   counter, c: name jmc$long_ssn_size..jmc$long_ssn_size = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      change_job_name_counter: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^change_job_name_counter_names, ^change_job_name_counter_params];

    VAR
      change_job_name_counter_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['COUNTER', 1], ['C', 1], ['STATUS', 2]];

    VAR
      change_job_name_counter_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ COUNTER C

      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$name_value, jmc$long_ssn_size, jmc$long_ssn_size]],

{ STATUS

      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      value: clt$value;

    #KEYPOINT (osk$entry, 0, jmk$change_job_name_counter);

    IF NOT jmp$system_job () THEN
      osp$set_status_abnormal ('JM', jme$must_be_system_job, 'jmp$change_job_name_counter', status);
      #KEYPOINT (osk$exit, 0, jmk$change_job_name_counter);
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, change_job_name_counter, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$change_job_name_counter);
      RETURN;
    IFEND;

    clp$get_value ('COUNTER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$change_job_name_counter);
      RETURN;
    IFEND;

    jmp$set_system_sequence_number (value.name.value, status);
    #KEYPOINT (osk$exit, 0, jmk$change_job_name_counter);
  PROCEND jmp$change_job_name_counter;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$_change_kill_job_action', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$_change_kill_job_action
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$sysou_chakja) change_kill_job_action, chakja (
{   kill_option, ko: any of
{       key
{         (kill_disabled, kd)
{       keyend
{       list of key
{         (operator_kill_enabled, oke)
{         (user_kill_enabled, uke)
{       keyend
{     anyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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 .. 2] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 4] of clt$keyword_specification,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 2, 3, 13, 30, 25, 12],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$SYSOU_CHAKJA'], [
    ['KILL_OPTION                    ',clc$nominal_entry, 1],
    ['KO                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 272,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['KD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['KILL_DISABLED                  ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    171, [[1, 0, clc$list_type], [155, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [4], [
        ['OKE                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['OPERATOR_KILL_ENABLED          ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['UKE                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['USER_KILL_ENABLED              ', clc$nominal_entry, clc$normal_usage_entry, 2]]
        ]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$kill_option = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      keyword_list: ^clt$data_value,
      terminate_job_action_set: jmt$terminate_job_action_set;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$kill_option].value^.kind = clc$keyword THEN

{ The only "keyword" value is KILL_DISABLED.  All other selections come  in as list of key.

      terminate_job_action_set := $jmt$terminate_job_action_set [jmc$tja_kill_disabled];
    ELSE
      terminate_job_action_set := $jmt$terminate_job_action_set [];
      keyword_list := pvt [p$kill_option].value;
      WHILE keyword_list <> NIL DO
        IF keyword_list^.element_value^.keyword_value = 'OPERATOR_KILL_ENABLED' THEN
          terminate_job_action_set := terminate_job_action_set +
                $jmt$terminate_job_action_set [jmc$tja_operator_kill_enabled];
        ELSE { IF keyword_list^.element_value^.keyword_value = 'USER_KILL_ENABLED' THEN
          terminate_job_action_set := terminate_job_action_set +
                $jmt$terminate_job_action_set [jmc$tja_user_kill_enabled];
        IFEND;
        keyword_list := keyword_list^.link;
      WHILEND;
    IFEND;

    jmp$change_terminate_job_action (terminate_job_action_set, status);
  PROCEND jmp$_change_kill_job_action;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] clp$display_all_input_command', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$display_all_input_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT display_all_input_pdt(
{ USER, U: NAME OR KEY all = all
{ FAMILY_NAME, FN: NAME OR KEY all = all
{ OUTPUT, O: FILE = $OUTPUT
{ STATUS)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_all_input_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^display_all_input_pdt_names, ^display_all_input_pdt_params];

    VAR
      display_all_input_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
            clt$parameter_name_descriptor := [['USER', 1], ['U', 1], ['FAMILY_NAME', 2], ['FN', 2],
            ['OUTPUT', 3], ['O', 3], ['STATUS', 4]];

    VAR
      display_all_input_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
            clt$parameter_descriptor := [

{ USER U

      [[clc$optional_with_default, ^display_all_input_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$name_value, 1, osc$max_name_size]],

{ FAMILY_NAME FN

      [[clc$optional_with_default, ^display_all_input_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$name_value, 1, osc$max_name_size]],

{ OUTPUT O

      [[clc$optional_with_default, ^display_all_input_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$file_value]],

{ STATUS

      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      display_all_input_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

    VAR
      display_all_input_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

    VAR
      display_all_input_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??

    VAR
      ignore_status: ost$status,
      job_status_count: jmt$job_status_count,
      job_status_options_p: ^jmt$job_status_options,
      job_status_results_keys_p: ^jmt$results_keys,
      job_status_results_p: ^jmt$job_status_results,
      job_status_results_seq: ^SEQ ( * ),
      segment_pointer: amt$segment_pointer,
      value: clt$value;

?? NEWTITLE := 'handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that arise.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (segment_pointer, ignore_status);
      IFEND;
      IF status.normal THEN
        osp$set_status_from_condition ('JM', condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_all_input_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH job_status_options_p: [1 .. 2];

    clp$get_value ('USER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.name.value = 'ALL' THEN
      job_status_options_p^ [1].key := jmc$null_attribute;
    ELSE
      job_status_options_p^ [1].key := jmc$login_user;
      job_status_options_p^ [1].login_user := value.name.value;
    IFEND;

    clp$get_value ('FAMILY_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.name.value = 'ALL' THEN
      job_status_options_p^ [2].key := jmc$null_attribute;
    ELSE
      job_status_options_p^ [2].key := jmc$login_family;
      job_status_options_p^ [2].login_family := value.name.value;
    IFEND;

    PUSH job_status_results_keys_p: [1 .. 6];
    job_status_results_keys_p^ [1] := jmc$job_class;
    job_status_results_keys_p^ [2] := jmc$job_state;
    job_status_results_keys_p^ [3] := jmc$login_family;
    job_status_results_keys_p^ [4] := jmc$login_user;
    job_status_results_keys_p^ [5] := jmc$operator_action_posted;
    job_status_results_keys_p^ [6] := jmc$system_job_name;

    segment_pointer.sequence_pointer := NIL;
    #SPOIL (segment_pointer);

    osp$establish_block_exit_hndlr (^handle_block_exit);
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$get_job_status (job_status_options_p, job_status_results_keys_p, segment_pointer.sequence_pointer,
          job_status_results_p, job_status_count, status);
    IF NOT status.normal THEN
      IF status.condition = jme$no_jobs_were_found THEN
        status.normal := TRUE;
        job_status_count := 0;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    job_status_results_seq := #SEQ (job_status_results_p);
    jmp$display_attributes (job_status_results_seq, job_status_count, NIL, NIL, 0, value.file,
          'display_all_input', status);

    mmp$delete_scratch_segment (segment_pointer, ignore_status);
    osp$disestablish_cond_handler;
  PROCEND clp$display_all_input_command;
?? TITLE := '[XDCL] clp$display_all_output_command', EJECT ??

  PROCEDURE [XDCL, #GATE] clp$display_all_output_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT display_all_output_pdt (
{   USER, U : NAME OR KEY all = all
{   FAMILY_NAME, FN : NAME OR KEY all = all
{   OUTPUT, O : FILE = $OUTPUT
{   STATUS)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_all_output_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^display_all_output_pdt_names, ^display_all_output_pdt_params];

    VAR
      display_all_output_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
            clt$parameter_name_descriptor := [['USER', 1], ['U', 1], ['FAMILY_NAME', 2], ['FN', 2],
            ['OUTPUT', 3], ['O', 3], ['STATUS', 4]];

    VAR
      display_all_output_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
            clt$parameter_descriptor := [

{ USER U

      [[clc$optional_with_default, ^display_all_output_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$name_value, 1, osc$max_name_size]],

{ FAMILY_NAME FN

      [[clc$optional_with_default, ^display_all_output_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$name_value, 1, osc$max_name_size]],

{ OUTPUT O

      [[clc$optional_with_default, ^display_all_output_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$file_value]],

{ STATUS

      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      display_all_output_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

    VAR
      display_all_output_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

    VAR
      display_all_output_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??

    VAR
      ignore_status: ost$status,
      output_status_count: jmt$output_status_count,
      output_status_options_p: ^jmt$output_status_options,
      output_status_results_p: ^jmt$output_status_results,
      output_status_results_seq: ^SEQ ( * ),
      segment_pointer: amt$segment_pointer,
      status_results_keys_p: ^jmt$results_keys,
      value: clt$value;

?? NEWTITLE := 'handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that arise.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (segment_pointer, ignore_status);
      IFEND;
      IF status.normal THEN
        osp$set_status_from_condition ('JM', condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_all_output_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    segment_pointer.sequence_pointer := NIL;
    #SPOIL (segment_pointer.sequence_pointer);
    PUSH output_status_options_p: [1 .. 2];

    clp$get_value ('USER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.name.value = 'ALL' THEN
      output_status_options_p^ [1].key := jmc$null_attribute;
    ELSE
      output_status_options_p^ [1].key := jmc$login_user;
      output_status_options_p^ [1].login_user := value.name.value;
    IFEND;

    clp$get_value ('FAMILY_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.name.value = 'ALL' THEN
      output_status_options_p^ [2].key := jmc$null_attribute;
    ELSE
      output_status_options_p^ [2].key := jmc$login_family;
      output_status_options_p^ [2].login_family := value.name.value;
    IFEND;

    osp$establish_block_exit_hndlr (^handle_block_exit);
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET segment_pointer.sequence_pointer;

    PUSH status_results_keys_p: [1 .. 3];
    status_results_keys_p^ [1] := jmc$system_file_name;
    status_results_keys_p^ [2] := jmc$system_job_name;
    status_results_keys_p^ [3] := jmc$user_file_name;

    jmp$get_output_status (output_status_options_p, status_results_keys_p, segment_pointer.sequence_pointer,
          output_status_results_p, output_status_count, status);
    IF NOT status.normal THEN
      IF status.condition = jme$no_outputs_were_found THEN
        status.normal := TRUE;
        output_status_count := 0;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_status_results_seq := #SEQ (output_status_results_p);
    jmp$display_attributes (output_status_results_seq, output_status_count, NIL, NIL, 0, value.file,
          'display_all_output', status);

    mmp$delete_scratch_segment (segment_pointer, ignore_status);
    osp$disestablish_cond_handler;

  PROCEND clp$display_all_output_command;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$_display_kill_job_action', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$_display_kill_job_action
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$sysou_diskja) display_kill_job_action, diskja (
{   output, o: file = $OUTPUT
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 2, 3, 13, 46, 47, 764],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$SYSOU_DISKJA'], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$OUTPUT'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      kill_job_action_set_p: ^jmt$attribute_values,
      kill_job_action_set_pp: ^array [1 .. * ] of ^jmt$attribute_values,
      kill_job_action_set_seq_p: ^SEQ ( * ),
      output_file: clt$file,
      terminate_job_action_set: jmt$terminate_job_action_set;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH kill_job_action_set_p: [1 .. 1];
    kill_job_action_set_p^ [1].key := jmc$terminate_job_action_set;
    jmp$get_terminate_job_action (kill_job_action_set_p^ [1].terminate_job_action_set, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH kill_job_action_set_pp: [1 .. 1];
    kill_job_action_set_pp^ [1] := kill_job_action_set_p;
    kill_job_action_set_seq_p := #SEQ (kill_job_action_set_pp);

{  Process OUTPUT parameter.

    clp$convert_string_to_file (pvt [p$output].value^.file_value^, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$display_attributes (kill_job_action_set_seq_p, 1, NIL, NIL, 0, output_file, 'display_kill_job_action',
          status);

  PROCEND jmp$_display_kill_job_action;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] clp$idle_jobs_command', EJECT ??

  PROCEDURE [XDCL] clp$idle_jobs_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT idle_jobs_pdt (
{       status)

?? PUSH (LISTEXT := ON) ??

    VAR
      idle_jobs_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^idle_jobs_pdt_names, ^idle_jobs_pdt_params];

    VAR
      idle_jobs_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      idle_jobs_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS

      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, idle_jobs_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$idle_system (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND clp$idle_jobs_command;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] clp$resume_jobs_command', EJECT ??

  PROCEDURE [XDCL] clp$resume_jobs_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT resume_jobs_pdt (
{       status)

?? PUSH (LISTEXT := ON) ??

    VAR
      resume_jobs_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^resume_jobs_pdt_names, ^resume_jobs_pdt_params];

    VAR
      resume_jobs_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      resume_jobs_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
            clt$parameter_descriptor := [

{ STATUS

      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, resume_jobs_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$resume_system (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
  PROCEND clp$resume_jobs_command;
MODEND jmm$operator_facility_commands;
*DECK DECK=JMM$OPER_COMMAND_REQUESTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : Operator Commands' ??
MODULE jmm$oper_command_requests;

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc CLD$VALUE
*copyc CLE$ECC_MISCELLANEOUS
*copyc CLE$ECC_PARAMETER_LIST
*copyc jmc$job_management_id
*copyc jme$job_scheduler_conditions
*copyc jmk$keypoints
*copyc jmt$swapout_reasons
*copyc OST$STATUS
?? POP ??
*copyc clp$evaluate_parameters
*copyc CLP$SCAN_PARAMETER_LIST
*copyc CLP$GET_VALUE
*copyc CLP$GET_SET_COUNT
*copyc CLP$SCAN_PARAMETER_LIST
*copyc JMP$SWAPOUT_JOB
*copyc JMP$SWAPIN_JOB
*copyc jmp$test_for_system_idle
*copyc osp$set_status_abnormal
*copyc pmp$wait

?? TITLE := '[XDCL] jmp$oper_swapin_of_job ', EJECT ??

{ PDT swap_rqst_pdt (
{  JOB_NAME, JN: NAME = $REQUIRED
{  STATUS)


  VAR
    swap_rqst_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
      [^swap_rqst_pdt_names, ^swap_rqst_pdt_params];

  VAR
    swap_rqst_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 ..
      3] of clt$parameter_name_descriptor := [['JOB_NAME', 1], ['JN', 1], ['STATUS', 2]];

  VAR
    swap_rqst_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
      clt$parameter_descriptor := [

{ JOB_NAME JN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

  PROCEDURE [XDCL, #GATE] jmp$oper_swapin_of_job (parameter_list: clt$parameter_list;
    VAR status: ost$status);

    VAR
      job_name: clt$value;

    clp$scan_parameter_list (parameter_list, swap_rqst_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_value ('JOB_NAME', 1, 1, clc$low, job_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$swapin_job (job_name, status);
  PROCEND jmp$oper_swapin_of_job;
?? TITLE := '[XDCL] jmp$oper_swapout_of_job ', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$oper_swapout_of_job (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE (osm$swaoj) swap_out_job, swaoj (
{   job_name, jn: name = $REQUIRED
{   disable_recovery, dr: boolean = FALSE
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 2, 3, 11, 28, 7, 93],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'OSM$SWAOJ'], [
    ['DISABLE_RECOVERY               ',clc$nominal_entry, 2],
    ['DR                             ',clc$abbreviation_entry, 2],
    ['JN                             ',clc$abbreviation_entry, 1],
    ['JOB_NAME                       ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$boolean_type],
    'FALSE'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$job_name = 1,
      p$disable_recovery = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    jmp$swapout_job (pvt [p$job_name].value^.name_value, pvt [p$disable_recovery].value^.boolean_value.value,
          status);
  PROCEND jmp$oper_swapout_of_job;
?? TITLE := '[XDCL] jmp$display_sch_table ', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display the attributes of the job scheduler
{   table.
{ NOTES:
{   This request is retained for compatibility.  It is replaced functionally by
{   commands under the ADMINISTER_SCHEDULING and MANAGE_ACTIVE_SCHEDULING utilities.

  PROCEDURE [XDCL] jmp$display_sch_table
    (    param_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT dst_pdt (
{ output,o: FILE =$OUTPUT
{ STATUS);


  VAR
    dst_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
      [^dst_pdt_names, ^dst_pdt_params];

  VAR
    dst_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of clt$parameter_name_descriptor
      := [['OUTPUT', 1],
      ['O', 1],
      ['STATUS', 2]];

  VAR
    dst_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ OUTPUT O }
      [[clc$optional_with_default, ^dst_pdt_dv1],
      1, 1,
      1, 1,
      clc$value_range_not_allowed,
      [NIL,
      clc$file_value]],

{ STATUS }
      [[clc$optional],
      1, 1,
      1, 1,
      clc$value_range_not_allowed,
      [NIL,
      clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

  VAR
    dst_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

    clp$scan_parameter_list (param_list, dst_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Issue a warning message stating that this command has been replaced by
{ the ADMINISTER_SCHEDULING and MANAGE_ACTIVE_SCHEDULING utilities.

    osp$set_status_abnormal (jmc$job_management_id, jme$use_adms_or_manas_utility, '', status);

  PROCEND jmp$display_sch_table;
?? TITLE := '[XDCL] jmp$change_scheduler_table_cmnd ', EJECT ??

{ PURPOSE:
{   The purpose of this request is to change the attributes of the job scheduler
{   table.
{ NOTES:
{   This request is retained for compatibility.  It is replaced functionally by
{   commands under the ADMINISTER_SCHEDULING and MANAGE_ACTIVE_SCHEDULING utilities.

  PROCEDURE [XDCL] jmp$change_scheduler_table_cmnd
    (    parm_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT chast_pdt (
{ service_calc_interval,sci: INTEGER 1 .. 300
{ idle_dispatching_queue_time,idqt: INTEGER 10 .. 36000
{ target_memory,tm: INTEGER 0 .. 100000
{ thrashing_level,tl: INTEGER 0 .. 100000
{ STATUS);

?? PUSH (LISTEXT := ON) ??

  VAR
    chast_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^chast_pdt_names, ^chast_pdt_params
      ];

  VAR
    chast_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 9] of
      clt$parameter_name_descriptor := [['SERVICE_CALC_INTERVAL', 1], ['SCI', 1], [
      'IDLE_DISPATCHING_QUEUE_TIME', 2], ['IDQT', 2], ['TARGET_MEMORY', 3], ['TM', 3], ['THRASHING_LEVEL', 4]
      , ['TL', 4], ['STATUS', 5]];

  VAR
    chast_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of clt$parameter_descriptor := [

{ SERVICE_CALC_INTERVAL SCI }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 1, 300]],

{ IDLE_DISPATCHING_QUEUE_TIME IDQT }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 10, 36000]],

{ TARGET_MEMORY TM }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 100000]],

{ THRASHING_LEVEL TL }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 100000]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    clp$scan_parameter_list (parm_list, chast_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Issue a warning message stating that this command has been replaced by
{ the ADMINISTER_SCHEDULING and MANAGE_ACTIVE_SCHEDULING utilities.

    osp$set_status_abnormal (jmc$job_management_id, jme$use_adms_or_manas_utility, '', status);

  PROCEND jmp$change_scheduler_table_cmnd;
?? TITLE := '[XDCL] jmp$wait_system_idle_comnd ', EJECT ??

  PROCEDURE [XDCL] jmp$wait_system_idle_comnd (param_list: clt$parameter_list;
                 VAR status: ost$status);


{ PDT wait_system_idle_pdt (
{   TIME, T: integer 0 .. 100000000 = $required
{   STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    wait_system_idle_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^wait_system_idle_pdt_names, ^wait_system_idle_pdt_params];

  VAR
    wait_system_idle_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['TIME', 1], ['T', 1], ['STATUS', 2]];

  VAR
    wait_system_idle_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
      clt$parameter_descriptor := [

{ TIME T }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 100000000]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
   VAR
    time_left: integer,
    wait_ms: integer,
    value: clt$value,
    end_wait_time: integer;

    #keypoint (osk$entry, 0, jmk$wait_system_idle_comnd);

    clp$scan_parameter_list(param_list, wait_system_idle_pdt, status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, 0, jmk$wait_system_idle_comnd);
      RETURN;
    IFEND;

    clp$get_value ('TIME', 1, 1,clc$low, value, status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, 0, jmk$wait_system_idle_comnd);
      RETURN;
    IFEND;

    end_wait_time := 1000 * value.int.value + #free_running_clock (0);

    REPEAT
      jmp$test_for_system_idle (status);
      time_left := end_wait_time - #free_running_clock (0);
      IF NOT status.normal AND (time_left > 0) THEN
        wait_ms := time_left DIV 1000;
        pmp$wait (wait_ms, wait_ms);
      IFEND;
    UNTIL (time_left <= 0) OR status.normal;

    #keypoint (osk$exit, 0, jmk$wait_system_idle_comnd);

  PROCEND jmp$wait_system_idle_comnd;
MODEND jmm$oper_command_requests;
*DECK DECK=JMM$PROCESS_JOB_HISTORY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management: Job History Interfaces' ??
MODULE jmm$process_job_history;
?? PUSH (LISTEXT := ON) ??
*copyc fsc$max_path_size
*copyc fst$evaluated_file_reference
*copyc fst$file_reference
*copyc fst$path_handle_name
*copyc jmc$maximum_output_count
*copyc jmc$system_family
*copyc jme$job_history_conditions
*copyc jml$user_id
*copyc jmt$beginning_log_position
*copyc jmt$jh_descriptive_data
*copyc jmt$job_history_event
*copyc jmt$job_history_job_name_entry
*copyc jmt$job_history_sorted_order
*copyc jmt$name
*copyc oss$job_paged_literal
*copyc ost$user_identification
*copyc pmt$family_name_list
*copyc sfd$type_declarations
*copyc sft$global_log_statistic_header
?? POP ??
*copyc clp$close_display
*copyc clp$convert_str_to_path_handle
*copyc clp$new_display_line
*copyc clp$open_display
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc clp$trimmed_string_size
*copyc jmp$get_log_entry
*copyc jmp$ready_log_file
*copyc jmp$system_job
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_condition
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pmp$get_legible_date_time

  TYPE
    formatted_line_range = 1 .. 3,
    formatted_data = record
      line_count: formatted_line_range,
      lines: array [formatted_line_range] of string (osc$max_string_size),
    recend;

?? NEWTITLE := '[XDCL] jmp$process_job_history', EJECT ??

  PROCEDURE [XDCL] jmp$process_job_history
    (    current_control_user: ost$user_identification;
         current_login_user: ost$user_identification;
         requested_sort_order: jmt$job_history_sorted_order;
         trace_job_children: boolean;
         trace_job_output: boolean;
         trace_all_jobs: boolean;
         trace_all_output: boolean;
         display_output_history_command: boolean;
         job_names_requested: ^array [1 .. * ] of ost$name;
         family_names_requested: ^pmt$family_name_list;
         output_files_requested: ^array [1 .. * ] of jmt$name;
         start_log_search: jmt$beginning_log_position;
         output_file: ^fst$file_reference;
         input_file: ^fst$file_reference;
     VAR status: ost$status);


    VAR
      an_event_was_displayed: boolean,
      buffer: sft$statistic_buffer,
      delete_status: ost$status,
      descriptor_p: ^sft$descriptive_data,
      event_count_p: ^ost$non_negative_integers,
      file_id: amt$file_identifier,
      file_position: amt$file_position,
      first_job_event: ^jmt$job_history_event,
      first_job_started: ^jmt$job_history_event,
      header_p: ^sft$global_log_statistic_header,
      job_event_segment_created: boolean,
      job_event_segment_pointer: amt$segment_pointer,
      jobs_to_be_traced: ^jmt$job_history_job_name_entry,
      last_job_event: ^jmt$job_history_event,
      last_job_started: ^jmt$job_history_event,
      last_output_started: ^jmt$job_history_event,
      output_event: boolean,
      queuing_started_entry: boolean,
      scratch_segment_created: boolean,
      scratch_segment_pointer: amt$segment_pointer,
      scratch_sequence_p: ^SEQ ( * ),
      sfn_p: ^jmt$system_supplied_name,
      system_job: boolean,
      valid_entry: boolean;

?? NEWTITLE := 'cleanup_on_block_exit', EJECT ??

{ PURPOSE:
{ The purpose of this request is to cleanup when an unexpected block exit
{ condition occurs.

    PROCEDURE cleanup_on_block_exit
      (    condition: pmt$condition;
           condition_descriptor_p: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF scratch_segment_created THEN
        mmp$delete_scratch_segment (scratch_segment_pointer, ignore_status);
      IFEND;
      IF job_event_segment_created THEN
        mmp$delete_scratch_segment (job_event_segment_pointer, ignore_status);
      IFEND;

    PROCEND cleanup_on_block_exit;
?? OLDTITLE ??
?? EJECT ??
    status.normal := TRUE;

{ Since this code executes in the user ring, the condition handler must be established
{ before any request that could require cleanup is done.

    scratch_segment_created := FALSE;
    job_event_segment_created := FALSE;
    #SPOIL (scratch_segment_created, job_event_segment_created);
    osp$establish_block_exit_hndlr (^cleanup_on_block_exit);

{ Scratch_sequence_p is used when there are output files specified.  The sequence
{ is used to store the unique system supplied name of any output files found.

    #SPOIL (scratch_segment_created);
    scratch_segment_created := TRUE;
    #SPOIL (scratch_segment_created);
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, scratch_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    scratch_sequence_p := scratch_segment_pointer.sequence_pointer;
    RESET scratch_sequence_p;
    NEXT event_count_p IN scratch_sequence_p;
    event_count_p^ := 0;

    #SPOIL (job_event_segment_created);
    job_event_segment_created := TRUE;
    #SPOIL (job_event_segment_created);
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, job_event_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET job_event_segment_pointer.sequence_pointer;


    jmp$ready_log_file (start_log_search, current_login_user, input_file, buffer, file_position, header_p,
          descriptor_p, file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jobs_to_be_traced := NIL;

    NEXT last_job_event IN job_event_segment_pointer.sequence_pointer;
    IF last_job_event = NIL THEN
      osp$set_status_condition (jme$no_space_for_allocate, status);
      RETURN;
    IFEND;

    last_job_event^.next_job := NIL;
    last_job_event^.next_event := NIL;
    first_job_event := last_job_event;

    NEXT last_job_started IN job_event_segment_pointer.sequence_pointer;
    IF last_job_started = NIL THEN
      osp$set_status_condition (jme$no_space_for_allocate, status);
      RETURN;
    IFEND;

    last_job_started^.next_job := NIL;
    last_job_started^.next_event := NIL;

    first_job_started := last_job_started;
    last_output_started := last_job_started;

    system_job := jmp$system_job ();

    WHILE file_position <> amc$eoi DO

      crack_log_entry (current_control_user, current_login_user, header_p, descriptor_p, trace_job_children,
            family_names_requested, job_names_requested, trace_all_jobs, trace_all_output,
            job_event_segment_pointer.sequence_pointer, jobs_to_be_traced, valid_entry, queuing_started_entry,
            scratch_sequence_p, status);

      IF system_job THEN

{ If this is the system job, save all job events; the system job should be able to look
{ at all job histories

        save_log_entry (header_p, descriptor_p, queuing_started_entry, trace_job_output,
              job_event_segment_pointer.sequence_pointer, last_job_event, last_job_started,
              last_output_started, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        IF valid_entry THEN
          IF display_output_history_command THEN
            IF queuing_started_entry AND (header_p^.statistic_code = jml$job_queuing_started) THEN
              save_log_entry (header_p, descriptor_p, queuing_started_entry, trace_job_output,
                    job_event_segment_pointer.sequence_pointer, last_job_event, last_job_started,
                    last_output_started, status);
            ELSE
              trace_output_events (output_files_requested, header_p, descriptor_p, trace_all_output,
                    output_event, scratch_sequence_p);
              IF output_event THEN
                save_log_entry (header_p, descriptor_p, queuing_started_entry, trace_job_output,
                      job_event_segment_pointer.sequence_pointer, last_job_event, last_job_started,
                      last_output_started, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              IFEND;
            IFEND;
          ELSE { display_job_history command }
            save_log_entry (header_p, descriptor_p, queuing_started_entry, trace_job_output,
                  job_event_segment_pointer.sequence_pointer, last_job_event, last_job_started,
                  last_output_started, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      jmp$get_log_entry (file_id, buffer, file_position, header_p, descriptor_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    WHILEND;

    IF (first_job_started <> last_job_started) OR (first_job_started <> last_output_started) THEN
      display_job_events (requested_sort_order, first_job_event, first_job_started, family_names_requested,
            display_output_history_command, output_file, an_event_was_displayed, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ This code handles the case in DISPLAY_OUTPUT_HISTORY where the requested job name is found, but
{ the requested output file name is not found.  It prevents the problem of no output being returned
{ from the command.  Suggestions for a less awkward implementation are welcome.

      IF NOT an_event_was_displayed THEN
        osp$set_status_condition (jme$jh_no_jobs_to_display, status);
      IFEND;
    ELSE
      osp$set_status_condition (jme$jh_no_jobs_to_display, status);
    IFEND;

    mmp$delete_scratch_segment (job_event_segment_pointer, delete_status);
    #SPOIL (job_event_segment_created);
    job_event_segment_created := FALSE;
    #SPOIL (job_event_segment_created);
    mmp$delete_scratch_segment (scratch_segment_pointer, delete_status);
    #SPOIL (scratch_segment_created);
    scratch_segment_created := FALSE;
    #SPOIL (scratch_segment_created);
    osp$disestablish_cond_handler;

  PROCEND jmp$process_job_history;
?? OLDTITLE ??
?? NEWTITLE := 'crack_log_entry', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to dismantle a statistic and retrieve
{   the information needed to determine that an event is part of a job to
{   be traced. Using this information (ie. job_name) it verifies it's to be
{   traced and if so adds the job_event to the internal list of jobs.
{ NOTE:
{   If the statistic is a job_queuing_started or output_queuing_started
{   statistic, the procedure verifies
{   that it meets the trace criteria, ie. the job name is requested or the job
{   belongs to a requested family. If it is not this statistic, the event is
{   checked against the internal list of jobs that have previously been determined
{   to be traced.

  PROCEDURE crack_log_entry
    (    current_control_user: ost$user_identification;
         current_login_user: ost$user_identification;
         header_p: ^sft$global_log_statistic_header;
         descriptor_p: ^sft$descriptive_data;
         trace_job_children: boolean;
         family_names_requested: ^pmt$family_name_list;
         job_names_requested: ^array [1 .. * ] of ost$name;
         trace_all_jobs: boolean;
         trace_all_output: boolean;
     VAR job_event_seq: ^SEQ ( * );
     VAR jobs_to_be_traced: ^jmt$job_history_job_name_entry;
     VAR valid_entry: boolean;
     VAR queuing_started_entry: boolean;
     VAR scratch_sequence_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      add_to_job_list: boolean,
      check_job: ^jmt$job_history_job_name_entry,
      data_array: ^array [1 .. * ] of string (osc$max_name_size),
      event_count_p: ^ost$non_negative_integers,
      i: integer,
      job_array_index: integer,
      job_entry: ^jmt$job_history_job_name_entry,
      sfn_p: ^jmt$system_supplied_name;

?? NEWTITLE := 'verify_job_is_to_be_traced', EJECT ??

{ PURPOSE:
{ The purpose of this routine is to verify that a job event is included in the
{ trace criteria, ie. is a given job name or belongs to a given family.

    PROCEDURE verify_job_is_to_be_traced
      (    job_names_requested: ^array [1 .. * ] of ost$name;
           job_name: string (osc$max_name_size);
           user_job_name: string (osc$max_name_size);
           parent_jobs_name: string (osc$max_name_size);
           jobs_to_be_traced: ^jmt$job_history_job_name_entry;
           trace_job_children: boolean;
           family_names_requested: ^pmt$family_name_list;
           login_family: ost$name;
       VAR add_to_job_list: boolean);

      VAR
        i: integer,
        j: integer,
        job_entry: ^jmt$job_history_job_name_entry;

      add_to_job_list := FALSE;

      FOR i := LOWERBOUND (job_names_requested^) TO UPPERBOUND (job_names_requested^) DO
        IF (job_names_requested^ [i] = job_name (1, jmc$system_supplied_name_size)) OR
              (job_names_requested^ [i] = user_job_name (1, osc$max_name_size)) THEN

          FOR j := LOWERBOUND (family_names_requested^) TO UPPERBOUND (family_names_requested^) DO
            IF (family_names_requested^ [j] = login_family) THEN
              add_to_job_list := TRUE;
              RETURN;
            IFEND;
          FOREND;
        IFEND;
      FOREND;
      IF trace_job_children THEN
        job_entry := jobs_to_be_traced;

        WHILE job_entry <> NIL DO
          IF job_entry^.job_name = parent_jobs_name THEN
            FOR j := LOWERBOUND (family_names_requested^) TO UPPERBOUND (family_names_requested^) DO
              IF family_names_requested^ [j] = login_family THEN
                add_to_job_list := TRUE;
                RETURN;
              IFEND;
            FOREND;
          IFEND;
          job_entry := job_entry^.nnext;
        WHILEND;

      IFEND;
    PROCEND verify_job_is_to_be_traced;
?? OLDTITLE ??
?? NEWTITLE := 'verify_output_is_to_be_traced', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to determine if an output event
{   meets the criteria to be traced:
{
{   1. Does the system file name match one of the requested file names?
{   2. Is the output from one of the requested jobs?
{   3. Is the output from one of the requested families?
{
{ NOTE:
{   Output cannot be traced via the output_queuing_started statistic
{   if the user job name instead of the system job name is given for
{   the job name parameter on the DISOH or DISJH command.  There is
{   no user job name field in the output_queuing_started statistic.

    PROCEDURE verify_output_is_to_be_traced
      (    system_file_name: string (osc$max_name_size);
           system_job_name: string (osc$max_name_size);
           job_names_requested: ^array [1 .. * ] of ost$name;
           family_names_requested: ^pmt$family_name_list;
           login_family: ost$name;
       VAR add_to_job_list: boolean;
       VAR scratch_sequence_p: ^SEQ ( * ));

      VAR
        event_count_p: ^ost$non_negative_integers,
        family_array_index: integer,
        file_array_index: integer,
        job_array_index: integer,
        sfn_p: ^jmt$system_supplied_name;

      add_to_job_list := FALSE;
      RESET scratch_sequence_p;
      NEXT event_count_p IN scratch_sequence_p;

    /check_file_names/
      FOR file_array_index := 1 TO event_count_p^ DO
        NEXT sfn_p IN scratch_sequence_p;
        IF (sfn_p^ = system_file_name (1, jmc$system_supplied_name_size)) THEN

          IF job_names_requested = NIL THEN

{ job_names_requested = NIL implies trace_all_jobs = TRUE.

          /check_family_names_all_jobs/
            FOR family_array_index := LOWERBOUND (family_names_requested^)
                  TO UPPERBOUND (family_names_requested^) DO
              IF (family_names_requested^ [family_array_index] = login_family) THEN
                add_to_job_list := TRUE;
                RETURN;
              IFEND;
            FOREND /check_family_names_all_jobs/;
          ELSE

          /check_job_names/
            FOR job_array_index := LOWERBOUND (job_names_requested^) TO UPPERBOUND (job_names_requested^) DO
              IF (job_names_requested^ [job_array_index] = system_job_name (1, jmc$system_supplied_name_size))
                    THEN

              /check_family_names/
                FOR family_array_index := LOWERBOUND (family_names_requested^)
                      TO UPPERBOUND (family_names_requested^) DO
                  IF (family_names_requested^ [family_array_index] = login_family) THEN
                    add_to_job_list := TRUE;
                    RETURN;
                  IFEND;
                FOREND /check_family_names/;
              IFEND;
            FOREND /check_job_names/;
          IFEND;
        IFEND;
      FOREND /check_file_names/;
    PROCEND verify_output_is_to_be_traced;
?? OLDTITLE ??
?? NEWTITLE := 'add_job_to_trace_list', EJECT ??

    PROCEDURE add_job_to_trace_list
      (    job_name: string (osc$max_name_size);
       VAR job_event_seq: ^SEQ ( * );
       VAR jobs_to_be_traced: ^jmt$job_history_job_name_entry;
       VAR status: ost$status);

      VAR
        job_entry: ^jmt$job_history_job_name_entry;

      status.normal := TRUE;

      NEXT job_entry IN job_event_seq;
      IF job_entry = NIL THEN
        osp$set_status_condition (jme$no_space_for_allocate, status);
        RETURN;
      IFEND;

      job_entry^.job_name (1, jmc$system_supplied_name_size) := job_name (1, jmc$system_supplied_name_size);
      job_entry^.nnext := jobs_to_be_traced;
      jobs_to_be_traced := job_entry;

    PROCEND add_job_to_trace_list;
?? OLDTITLE ??
?? EJECT ??

{ Start of Crack_log_entry.

    status.normal := TRUE;

    queuing_started_entry := FALSE;
    valid_entry := FALSE;
    add_to_job_list := FALSE;

{ check if this is the first time the job has been seen and determine if it's to be traced;
{ tracing of a job is determined by the job_queuing_started statistic. If this statistic
{ is not found, a job cannot be traced. Tracing of output routed from another machine is
{ determined by the output_queuing_started statistic.

    IF (header_p^.statistic_code = jml$job_queuing_started) OR
          (header_p^.statistic_code = jml$output_queuing_started) THEN
      queuing_started_entry := TRUE;
      IF header_p^.statistic_code = jml$job_queuing_started THEN

        PUSH data_array: [1 .. jmc$jqs_max_desc_data_fields];
        crack_descriptive_data (jml$job_queuing_started, descriptor_p, data_array);
        IF data_array^ [jmc$jqs_parent_job_name] = jmc$blank_system_supplied_name THEN
          data_array^ [jmc$jqs_parent_job_name] := header_p^.job_name;
        IFEND;

        IF ((current_login_user.user = data_array^ [jmc$jqs_control_user]) AND
              (current_login_user.family = data_array^ [jmc$jqs_control_family])) OR
              ((current_login_user.user = data_array^ [jmc$jqs_login_user]) AND
              (current_login_user.family = data_array^ [jmc$jqs_login_family])) THEN

          IF trace_all_jobs THEN

          /check_for_login_family/
            FOR i := LOWERBOUND (family_names_requested^) TO UPPERBOUND (family_names_requested^) DO
              IF family_names_requested^ [i] = data_array^ [jmc$jqs_login_family] THEN
                add_to_job_list := TRUE;
                EXIT /check_for_login_family/;
              IFEND;
            FOREND /check_for_login_family/;
          ELSE
            verify_job_is_to_be_traced (job_names_requested, data_array^ [jmc$jqs_system_job_name],
                  data_array^ [jmc$jqs_user_job_name], data_array^ [jmc$jqs_parent_job_name],
                  jobs_to_be_traced, trace_job_children, family_names_requested,
                  data_array^ [jmc$jqs_login_family], add_to_job_list);
          IFEND;
          valid_entry := add_to_job_list;

{ Check if a job_queuing_started statistic has already been found for this job.
{ Don't put the job_entry in the trace list twice.

          IF (jobs_to_be_traced <> NIL) AND add_to_job_list THEN
            check_job := jobs_to_be_traced;

          /check_for_job_in_trace_list/
            REPEAT
              IF check_job^.job_name = data_array^ [jmc$jqs_system_job_name] THEN
                add_to_job_list := FALSE;

{ Clear the queuing_started_entry flag to prevent the statistic from being flagged as the start of a new job
{ when it is saved later.

                queuing_started_entry := FALSE;

                EXIT /check_for_job_in_trace_list/;
              IFEND;
              check_job := check_job^.nnext;
            UNTIL check_job = NIL;
          IFEND;
          IF add_to_job_list THEN
            add_job_to_trace_list (data_array^ [jmc$jqs_system_job_name], job_event_seq, jobs_to_be_traced,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            valid_entry := TRUE;
          IFEND;
        IFEND;
      ELSE { output_queuing_started statistic

        PUSH data_array: [1 .. jmc$oqs_max_desc_data_fields];
        crack_descriptive_data (jml$output_queuing_started, descriptor_p, data_array);

        IF ((current_login_user.user = data_array^ [jmc$oqs_control_user]) AND
              (current_login_user.family = data_array^ [jmc$oqs_control_family])) OR
              ((current_login_user.user = data_array^ [jmc$oqs_login_user]) AND
              (current_login_user.family = data_array^ [jmc$oqs_login_family])) THEN

          IF trace_all_output THEN

          /check_oqs_for_login_family/
            FOR i := LOWERBOUND (family_names_requested^) TO UPPERBOUND (family_names_requested^) DO
              IF family_names_requested^ [i] = data_array^ [jmc$oqs_login_family] THEN
                IF job_names_requested <> NIL THEN
                  FOR job_array_index := LOWERBOUND (job_names_requested^)
                        TO UPPERBOUND (job_names_requested^) DO
                    IF job_names_requested^ [job_array_index] = data_array^ [jmc$oqs_system_job_name] THEN
                      add_to_job_list := TRUE;
                      EXIT /check_oqs_for_login_family/;
                    IFEND;
                  FOREND;
                ELSE

{ job_names_requested = NIL implies trace_all_jobs = TRUE.

                  add_to_job_list := TRUE;
                  EXIT /check_oqs_for_login_family/;
                IFEND;
              IFEND;
            FOREND /check_oqs_for_login_family/;
          ELSE
            RESET scratch_sequence_p;
            NEXT event_count_p IN scratch_sequence_p;
            IF event_count_p^ <> 0 THEN
              verify_output_is_to_be_traced (data_array^ [jmc$oqs_system_file_name],
                    data_array^ [jmc$oqs_system_job_name], job_names_requested, family_names_requested,
                    data_array^ [jmc$oqs_login_family], add_to_job_list, scratch_sequence_p);
            IFEND;
          IFEND;
          valid_entry := add_to_job_list;

{ Check if a queuing started statistic has already been found for this output file.
{ Don't put the job_entry in the trace list twice.

          IF (jobs_to_be_traced <> NIL) AND add_to_job_list THEN
            check_job := jobs_to_be_traced;

          /check_for_oqs_job_in_trace_list/
            REPEAT
              IF check_job^.job_name = data_array^ [jmc$oqs_system_job_name] THEN
                add_to_job_list := FALSE;

{ Clear the queuing_started_entry flag to prevent the statistic from being flagged as the start of a new
{ output file when it is saved later.

                queuing_started_entry := FALSE;

                EXIT /check_for_oqs_job_in_trace_list/;
              IFEND;
              check_job := check_job^.nnext;
            UNTIL check_job = NIL;
          IFEND;
          IF add_to_job_list THEN
            add_job_to_trace_list (data_array^ [jmc$oqs_system_job_name], job_event_seq, jobs_to_be_traced,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    job_entry := jobs_to_be_traced;

    WHILE (NOT valid_entry) AND (job_entry <> NIL) DO

{ If the SJN of the statistic emitter matches the SJN of a job to be traced, the statistic data should be
{ saved.  Omit matching job_queuing_started stats, since they are for child jobs, and were emitted by
{ jmp$submit_job in the parent.  Omit matching job_file_deleted stats, since they are for child jobs which
{ were never initiated, and must not appear in the history of the job that terminated them.
{ This is in lieu of creating a distinct event thread in the event sequence for each job to be traced.

      IF (job_entry^.job_name = header_p^.job_name) AND (header_p^.statistic_code <>
            jml$job_queuing_started) AND (header_p^.statistic_code <> jml$job_file_deleted) THEN

{ The second test in the above IF statement prevents the job_queuing_started entry
{ for child jobs from being displayed when a DISJH of the parent job is entered.

        valid_entry := TRUE;
      ELSE
        check_system_job_stats (job_entry^.job_name, header_p, descriptor_p, valid_entry);
      IFEND;
      job_entry := job_entry^.nnext;
    WHILEND;

  PROCEND crack_log_entry;
?? OLDTITLE ??
?? NEWTITLE := 'check_system_job_stats', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to check the statistics emitted by the
{   system that need to be traced.
{
{ NOTE:
{   Currently, the print_plot_initiated, print_plot_terminated, non_recovery_of_job,
{   job_forwarding_started, output_forwarding_started and change_output_attributes
{   are such statistics, i.e. the system job name in the statistic header is that of
{   the system job.  The name of the job that caused the statistic to be emitted
{   is part of the statistic's descriptive data.

  PROCEDURE check_system_job_stats
    (    job_name: jmt$system_supplied_name;
         header_p: ^sft$global_log_statistic_header;
         descriptor_p: ^sft$descriptive_data;
     VAR valid_entry: boolean);

    VAR
      data_array: ^array [1 .. * ] of string (osc$max_name_size);

    valid_entry := FALSE;

    CASE header_p^.statistic_code OF
    = jml$job_forwarding_started =
      PUSH data_array: [1 .. jmc$jfs_max_desc_data_fields];
      crack_descriptive_data (jml$job_forwarding_started, descriptor_p, data_array);

      IF job_name = data_array^ [jmc$jfs_system_job_name] THEN
        valid_entry := TRUE;
      IFEND;

    = jml$output_forwarding_started =
      PUSH data_array: [1 .. jmc$ofs_max_desc_data_fields];
      crack_descriptive_data (jml$output_forwarding_started, descriptor_p, data_array);

      IF job_name = data_array^ [jmc$ofs_system_job_name] THEN
        valid_entry := TRUE;
      IFEND;

    = jml$output_queuing_started =
      PUSH data_array: [1 .. jmc$oqs_max_desc_data_fields];
      crack_descriptive_data (jml$output_queuing_started, descriptor_p, data_array);

      IF job_name = data_array^ [jmc$oqs_system_job_name] THEN
        valid_entry := TRUE;
      IFEND;

    = jml$print_plot_initiated =
      PUSH data_array: [1 .. jmc$ppi_max_desc_data_fields];
      crack_descriptive_data (jml$print_plot_initiated, descriptor_p, data_array);

      IF job_name = data_array^ [jmc$ppi_system_job_name] THEN
        valid_entry := TRUE;
      IFEND;

    = jml$print_plot_terminated =
      PUSH data_array: [1 .. jmc$ppt_max_desc_data_fields];
      crack_descriptive_data (jml$print_plot_terminated, descriptor_p, data_array);

      IF job_name = data_array^ [jmc$ppt_system_job_name] THEN
        valid_entry := TRUE;
      IFEND;

    = jml$job_file_deleted =
      PUSH data_array: [1 .. jmc$jfd_max_desc_data_fields];
      crack_descriptive_data (jml$job_file_deleted, descriptor_p, data_array);

      IF job_name = data_array^ [jmc$jfd_system_job_name] THEN
        valid_entry := TRUE;
      IFEND;

    = jml$output_file_deleted =
      PUSH data_array: [1 .. jmc$ofd_max_desc_data_fields];
      crack_descriptive_data (jml$output_file_deleted, descriptor_p, data_array);

      IF job_name = data_array^ [jmc$ofd_system_job_name] THEN
        valid_entry := TRUE;
      IFEND;

    = jml$non_recovery_of_job =
      PUSH data_array: [1 .. jmc$nroj_max_desc_data_fields];
      crack_descriptive_data (jml$non_recovery_of_job, descriptor_p, data_array);

      IF job_name = data_array^ [jmc$nroj_system_job_name] THEN
        valid_entry := TRUE;
      IFEND;

    = jml$change_output_attributes =
      PUSH data_array: [1 .. jmc$coa_max_desc_data_fields];
      crack_descriptive_data (jml$change_output_attributes, descriptor_p, data_array);

      IF job_name = data_array^ [jmc$coa_system_job_name] THEN
        valid_entry := TRUE;
      IFEND;
    ELSE

{ do nothing - ignore any statistic other than valid job history statistics

    CASEND;

  PROCEND check_system_job_stats;
?? OLDTITLE ??
?? NEWTITLE := 'crack_descriptive_data', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to extract information from the descriptive data
{   field of the statistic.
{
{ NOTE:
{   Each job history statistic has differenct information in it's descriptive data field
{   This information is defined in the Local_job_history ERS.  This info is formatted
{   at the time the statistic is emitted.  If this information is changed in the system, this
{   procedure would also need to be changed.

  PROCEDURE crack_descriptive_data
    (    statistic_code: sft$statistic_code;
         descriptor_p: ^sft$descriptive_data;
     VAR data_array: ^array [1 .. * ] of string (osc$max_name_size));

    VAR
      data_size: integer;

    data_size := 1;

    CASE statistic_code OF
    = jml$job_queuing_started =
      data_array^ [jmc$jqs_system_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$jqs_user_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$jqs_login_family] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$jqs_login_user] (1, osc$max_name_size) := descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$jqs_control_family] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$jqs_control_user] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$jqs_station] (1, osc$max_name_size) := descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

{ Conditionally extract the job queuing reason and parent job name.

      IF (data_size + osc$max_name_size - 1) < STRLENGTH (descriptor_p^) THEN
        data_array^ [jmc$jqs_reason] (1, osc$max_name_size) := descriptor_p^ (data_size, osc$max_name_size);
        data_size := data_size + osc$max_name_size;

        data_array^ [jmc$jqs_parent_job_name] (1, osc$max_name_size) :=
              descriptor_p^ (data_size, jmc$system_supplied_name_size);
      ELSE
        data_array^ [jmc$jqs_reason] (1, osc$max_name_size) := osc$null_name;

        data_array^ [jmc$jqs_parent_job_name] (1, osc$max_name_size) := jmc$blank_system_supplied_name;
      IFEND;

    = jml$job_queuing_aborted =

      data_array^ [jmc$jqa_system_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$jqa_reason] (1, osc$max_name_size) := descriptor_p^ (data_size, osc$max_name_size);

      data_array^ [jmc$jqa_reason] (1, osc$max_name_size) := descriptor_p^ (data_size, osc$max_name_size);

    = jml$job_file_deleted =

      data_array^ [jmc$jfd_system_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$jfd_reason] (1, osc$max_name_size) := descriptor_p^ (data_size, osc$max_name_size);

    = jml$output_queuing_started =

      data_array^ [jmc$oqs_system_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$oqs_login_family] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$oqs_login_user] (1, osc$max_name_size) := descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$oqs_system_file_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$oqs_control_family] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$oqs_control_user] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$oqs_station] (1, osc$max_name_size) := descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

{ Conditionally extract the output queuing reason.

      IF (data_size + osc$max_name_size - 1) <= STRLENGTH (descriptor_p^) THEN
        data_array^ [jmc$jqs_reason] (1, osc$max_name_size) := descriptor_p^ (data_size, osc$max_name_size);
        data_size := data_size + osc$max_name_size;
      ELSE
        data_array^ [jmc$jqs_reason] (1, osc$max_name_size) := osc$null_name;
      IFEND;

    = jml$output_queuing_aborted =

      data_array^ [jmc$oqa_system_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$oqa_system_file_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$oqa_reason] (1, osc$max_name_size) := descriptor_p^ (data_size, osc$max_name_size);

    = jml$output_file_deleted =

      data_array^ [jmc$ofd_system_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$ofd_system_file_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$ofd_reason] (1, osc$max_name_size) := descriptor_p^ (data_size, osc$max_name_size);

    = jml$job_forwarding_started =

      data_array^ [jmc$jfs_system_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);

    = jml$output_forwarding_started =

      data_array^ [jmc$ofs_system_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$ofs_system_file_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$ofs_application_name] := descriptor_p^ (data_size, osc$max_name_size);

    = jml$job_initiated =

      data_array^ [jmc$ji_system_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);

    = jml$job_terminated =

      data_array^ [jmc$jt_system_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$jt_system_file_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$jt_output_disposition] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$jt_reason] (1, osc$max_name_size) := descriptor_p^ (data_size, osc$max_name_size);

    = jml$print_plot_initiated =
      data_array^ [jmc$ppi_system_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$ppi_system_file_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$ppi_application_name] := descriptor_p^ (data_size, osc$max_name_size);

    = jml$print_plot_terminated =

      data_array^ [jmc$ppt_system_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$ppt_system_file_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);

    = jml$submit_job_executed =

      data_array^ [jmc$sje_system_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$sje_job_destination] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$sje_job_destination_usage] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$sje_user_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);

    = jml$print_plot_file_executed =

      data_array^ [jmc$ppfe_system_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$ppfe_system_file_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$ppfe_output_destination] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$ppfe_output_dest_usage] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$ppfe_user_file_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);

    = jml$job_history_message =

      data_array^ [jmc$jhm_system_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);

{ Do not crack message here.  It could be too big to fit
{ easily into data_array^.

    = jml$non_recovery_of_job =

      data_array^ [jmc$nroj_system_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$nroj_reason] (1, osc$max_name_size) := descriptor_p^ (data_size, osc$max_name_size);

    = jml$change_output_attributes =

      data_array^ [jmc$coa_system_job_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$coa_system_file_name] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, jmc$system_supplied_name_size);
      data_size := data_size + jmc$system_supplied_name_size;

      data_array^ [jmc$coa_control_family] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$coa_control_user] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$coa_output_destination] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$coa_output_dest_usage] (1, osc$max_name_size) :=
            descriptor_p^ (data_size, osc$max_name_size);
      data_size := data_size + osc$max_name_size;

      data_array^ [jmc$coa_station] (1, osc$max_name_size) := descriptor_p^ (data_size, osc$max_name_size);

    ELSE

{ do nothing - ignore any statistic other than valid job history statistics

    CASEND

  PROCEND crack_descriptive_data;
?? OLDTITLE ??
?? NEWTITLE := 'trace_output_events', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to determine if an output event is
{   from a user requested output file.
{
{   1. Is it an output event.
{   2. Is all output to be printed.
{   3. If the event is from print_plot_file_executed then if the user supplied
{      file name matches the output file requested then save the system supplied name.
{   4. For all other events check for the system_supplied_name field matching an element
{      in the scratch sequence.

  PROCEDURE trace_output_events
    (    output_files_requested: ^array [1 .. * ] of jmt$name;
         header_p: ^sft$global_log_statistic_header;
         descriptor_p: ^sft$descriptive_data;
         trace_all_output: boolean;
     VAR output_event: boolean;
     VAR scratch_sequence_p: ^SEQ ( * ));

    VAR
      data_array: ^array [1 .. * ] of string (osc$max_name_size),
      event_count_p: ^ost$non_negative_integers,
      i: integer,
      sfns_already_assigned_p: ^array [1 .. * ] of jmt$system_supplied_name,
      sfn_p: ^jmt$system_supplied_name;

    output_event := FALSE;
    IF (header_p^.statistic_code = jml$job_terminated) OR
          (header_p^.statistic_code = jml$output_queuing_started) OR
          (header_p^.statistic_code = jml$output_queuing_aborted) OR
          (header_p^.statistic_code = jml$output_file_deleted) OR
          (header_p^.statistic_code = jml$output_forwarding_started) OR
          (header_p^.statistic_code = jml$print_plot_initiated) OR
          (header_p^.statistic_code = jml$print_plot_terminated) OR
          (header_p^.statistic_code = jml$print_plot_file_executed) OR
          (header_p^.statistic_code = jml$change_output_attributes) THEN
      IF trace_all_output THEN
        output_event := TRUE;
        RETURN;
      ELSE {not trace_all_output}
        RESET scratch_sequence_p;
        NEXT event_count_p IN scratch_sequence_p;
        CASE header_p^.statistic_code OF
        = jml$job_terminated =
          PUSH data_array: [1 .. jmc$jt_max_desc_data_fields];
          crack_descriptive_data (header_p^.statistic_code, descriptor_p, data_array);

          FOR i := 1 TO event_count_p^ DO
            NEXT sfn_p IN scratch_sequence_p;
            IF sfn_p^ = data_array^ [jmc$jt_system_file_name] THEN
              output_event := TRUE;
              RETURN;
            IFEND;
          FOREND;

        = jml$output_queuing_started =
          PUSH data_array: [1 .. jmc$oqs_max_desc_data_fields];
          crack_descriptive_data (header_p^.statistic_code, descriptor_p, data_array);

          FOR i := 1 TO event_count_p^ DO
            NEXT sfn_p IN scratch_sequence_p;
            IF sfn_p^ = data_array^ [jmc$oqs_system_file_name] THEN
              output_event := TRUE;
              RETURN;
            IFEND;
          FOREND;

        = jml$output_queuing_aborted =
          PUSH data_array: [1 .. jmc$oqa_max_desc_data_fields];
          crack_descriptive_data (header_p^.statistic_code, descriptor_p, data_array);

          FOR i := 1 TO event_count_p^ DO
            NEXT sfn_p IN scratch_sequence_p;
            IF sfn_p^ = data_array^ [jmc$oqa_system_file_name] THEN
              output_event := TRUE;
              RETURN;
            IFEND;
          FOREND;

        = jml$output_file_deleted =
          PUSH data_array: [1 .. jmc$ofd_max_desc_data_fields];
          crack_descriptive_data (jml$output_file_deleted, descriptor_p, data_array);

          FOR i := 1 TO event_count_p^ DO
            NEXT sfn_p IN scratch_sequence_p;
            IF sfn_p^ = data_array^ [jmc$ofd_system_file_name] THEN
              output_event := TRUE;
              RETURN;
            IFEND;
          FOREND;

        = jml$output_forwarding_started =
          PUSH data_array: [1 .. jmc$ofs_max_desc_data_fields];
          crack_descriptive_data (header_p^.statistic_code, descriptor_p, data_array);

          FOR i := 1 TO event_count_p^ DO
            NEXT sfn_p IN scratch_sequence_p;
            IF sfn_p^ = data_array^ [jmc$ofs_system_file_name] THEN
              output_event := TRUE;
              RETURN;
            IFEND;
          FOREND;

{ This case will determine if the user_supplied_name field in the event equals one of the output files
{ requested, if so add the system supplied name to the scratch sequence.
{ Note:  The user supplied name exists only on the print_plot_file_executed event.  This means the
{ system_supplied_name must be saved for future evaluation to determine if the event is also for this
{ user_supplied_name output.

        = jml$print_plot_file_executed =
          PUSH data_array: [1 .. jmc$ppfe_max_desc_data_fields];
          crack_descriptive_data (header_p^.statistic_code, descriptor_p, data_array);

          FOR i := LOWERBOUND (output_files_requested^) TO UPPERBOUND (output_files_requested^) DO
            IF output_files_requested^ [i].kind = jmc$user_supplied_name THEN
              IF output_files_requested^ [i].user_supplied_name = data_array^ [jmc$ppfe_user_file_name] THEN
                IF event_count_p^ > 0 THEN
                  NEXT sfns_already_assigned_p: [1 .. event_count_p^] IN scratch_sequence_p;
                IFEND;
                NEXT sfn_p IN scratch_sequence_p;
                sfn_p^ := data_array^ [jmc$ppfe_system_file_name];
                event_count_p^ := event_count_p^ +1;
                output_event := TRUE;
                RETURN;
              IFEND;
            IFEND;

            IF output_files_requested^ [i].kind = jmc$system_supplied_name THEN
              IF output_files_requested^ [i].system_supplied_name =
                    data_array^ [jmc$ppfe_system_file_name] THEN
                IF event_count_p^ > 0 THEN
                  NEXT sfns_already_assigned_p: [1 .. event_count_p^] IN scratch_sequence_p;
                IFEND;
                NEXT sfn_p IN scratch_sequence_p;
                sfn_p^ := data_array^ [jmc$ppfe_system_file_name];
                event_count_p^ := event_count_p^ +1;
                output_event := TRUE;
                RETURN;
              IFEND;
            IFEND;

          FOREND;

        = jml$print_plot_initiated =
          PUSH data_array: [1 .. jmc$ppi_max_desc_data_fields];
          crack_descriptive_data (header_p^.statistic_code, descriptor_p, data_array);

          FOR i := 1 TO event_count_p^ DO
            NEXT sfn_p IN scratch_sequence_p;
            IF sfn_p^ = data_array^ [jmc$ppi_system_file_name] THEN
              output_event := TRUE;
              RETURN;
            IFEND;
          FOREND;

        = jml$print_plot_terminated =
          PUSH data_array: [1 .. jmc$ppt_max_desc_data_fields];
          crack_descriptive_data (header_p^.statistic_code, descriptor_p, data_array);

          FOR i := 1 TO event_count_p^ DO
            NEXT sfn_p IN scratch_sequence_p;
            IF sfn_p^ = data_array^ [jmc$ppt_system_file_name] THEN
              output_event := TRUE;
              RETURN;
            IFEND;
          FOREND;

        = jml$change_output_attributes =
          PUSH data_array: [1 .. jmc$coa_max_desc_data_fields];
          crack_descriptive_data (header_p^.statistic_code, descriptor_p, data_array);

          FOR i := 1 TO event_count_p^ DO
            NEXT sfn_p IN scratch_sequence_p;
            IF sfn_p^ = data_array^ [jmc$coa_system_file_name] THEN
              output_event := TRUE;
              RETURN;
            IFEND;
          FOREND;

        ELSE

{ do nothing - ignore any statistic other than valid job history statistics

        CASEND;
      IFEND;

    ELSE
      output_event := FALSE;
    IFEND;

  PROCEND trace_output_events;
?? OLDTITLE ??
?? NEWTITLE := 'save_log_entry', EJECT ??

  PROCEDURE save_log_entry
    (    header_p: ^sft$global_log_statistic_header;
         descriptor_p: ^sft$descriptive_data;
         queuing_started_entry: boolean;
         trace_job_output: boolean;
     VAR job_event_seq: ^SEQ ( * );
     VAR last_job_event: ^jmt$job_history_event;
     VAR last_job_started: ^jmt$job_history_event;
     VAR last_output_started: ^jmt$job_history_event;
     VAR status: ost$status);

    VAR
      job_event: ^jmt$job_history_event;

    status.normal := TRUE;

    IF trace_job_output THEN
      NEXT job_event IN job_event_seq;
      IF job_event = NIL THEN
        osp$set_status_condition (jme$no_space_for_allocate, status);
        RETURN;
      IFEND;

      NEXT job_event^.header IN job_event_seq;
      IF job_event^.header = NIL THEN
        osp$set_status_condition (jme$no_space_for_allocate, status);
        RETURN;
      IFEND;

      job_event^.header^ := header_p^;

      NEXT job_event^.descriptive_data: [header_p^.descriptive_data_size] IN job_event_seq;
      IF job_event^.descriptive_data = NIL THEN
        osp$set_status_condition (jme$no_space_for_allocate, status);
        RETURN;
      IFEND;

      job_event^.descriptive_data^ := descriptor_p^;

      job_event^.next_job := NIL;
      job_event^.next_event := NIL;
      last_job_event^.next_event := job_event;
      last_job_event := job_event;

      IF queuing_started_entry THEN
        IF header_p^.statistic_code = jml$job_queuing_started THEN
          last_job_started^.next_job := job_event;
          last_job_started := job_event;
        ELSE
          IF (last_output_started^.next_job <> NIL) AND (last_output_started^.next_job^.header^.
                statistic_code = jml$job_queuing_started) THEN

{ There must have been a job_queuing_started statistic found before the current
{ output_queuing_started statistic, so we don't need to mark this one.

            ;
          ELSE
            last_output_started^.next_job := job_event;
            last_output_started := job_event;
          IFEND;
        IFEND;
      IFEND;

    ELSE
      IF (header_p^.statistic_code = jml$output_queuing_started) OR
            (header_p^.statistic_code = jml$output_queuing_aborted) OR
            (header_p^.statistic_code = jml$output_forwarding_started) OR
            (header_p^.statistic_code = jml$output_file_deleted) OR
            (header_p^.statistic_code = jml$print_plot_initiated) OR
            (header_p^.statistic_code = jml$print_plot_terminated) OR
            (header_p^.statistic_code = jml$change_output_attributes) THEN
        RETURN;
      ELSE
        NEXT job_event IN job_event_seq;
        IF job_event = NIL THEN
          osp$set_status_condition (jme$no_space_for_allocate, status);
          RETURN;
        IFEND;

        NEXT job_event^.header IN job_event_seq;
        IF job_event^.header = NIL THEN
          osp$set_status_condition (jme$no_space_for_allocate, status);
          RETURN;
        IFEND;

        job_event^.header^ := header_p^;

        NEXT job_event^.descriptive_data: [header_p^.descriptive_data_size] IN job_event_seq;
        IF job_event^.descriptive_data = NIL THEN
          osp$set_status_condition (jme$no_space_for_allocate, status);
          RETURN;
        IFEND;

        job_event^.descriptive_data^ := descriptor_p^;

        job_event^.next_job := NIL;
        job_event^.next_event := NIL;
        last_job_event^.next_event := job_event;
        last_job_event := job_event;

        IF queuing_started_entry THEN
          last_job_started^.next_job := job_event;
          last_job_started := job_event;
        IFEND;

      IFEND;
    IFEND;

  PROCEND save_log_entry;
?? OLDTITLE ??
?? NEWTITLE := 'display_job_events', EJECT ??

  PROCEDURE display_job_events
    (    requested_sort_order: jmt$job_history_sorted_order;
         first_job_event: ^jmt$job_history_event;
         first_job_started: ^jmt$job_history_event;
         family_names_requested: ^array [1 .. * ] of ost$name;
         display_output_history_command: boolean;
         output_file: ^fst$file_reference;
     VAR an_event_was_displayed: boolean;
     VAR status: ost$status);

    VAR
      current_family_name: ost$name,
      current_job_name: jmt$system_supplied_name,
      data_array: ^array [1 .. * ] of string (osc$max_name_size),
      descriptive_data_string: formatted_data,
      delete_allowed: boolean,
      display_control: clt$display_control,
      evaluated_file_reference: fst$evaluated_file_reference,
      header_string: string (80),
      i: integer,
      include_open_pos_in_handle: boolean,
      job_event: ^jmt$job_history_event,
      line_index: formatted_line_range,
      output: clt$file,
      path_handle_name: fst$path_handle_name,
      resolve_path: boolean,
      system_job_name: jmt$system_supplied_name,
      trace_job: ^jmt$job_history_event;

?? NEWTITLE := 'new_page_proc', EJECT ??

    PROCEDURE new_page_proc
      (VAR display_control: clt$display_control;
           new_page_number: integer;
       VAR status: ost$status);

      VAR
        date: ost$date,
        i: integer,
        page_header: string (80),
        time: ost$time;

      clp$reset_for_next_display_page (display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      page_header := ' ';

      IF display_output_history_command THEN
        page_header (1, 22) := 'DISPLAY OUTPUT HISTORY';
      ELSE
        page_header (1, 19) := 'DISPLAY JOB HISTORY';
      IFEND;

      STRINGREP (page_header (77, * ), i, display_control.page_number);

      pmp$get_legible_date_time (osc$mdy_date, date, osc$ampm_time, time, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      page_header (50, 8) := date.mdy;
      page_header (40, 8) := time.hms;

      clp$put_display (display_control, page_header, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, 2, status);

    PROCEND new_page_proc;
?? OLDTITLE ??
?? NEWTITLE := 'output_current_job', EJECT ??

    PROCEDURE output_current_job
      (    current_job_name: jmt$system_supplied_name;
           job_event: ^jmt$job_history_event;
           display_output_history_command: boolean;
       VAR an_event_was_displayed: boolean;
       VAR status: ost$status);

      VAR
        line_index: formatted_line_range,
        local_job_event: ^jmt$job_history_event,
        system_job_name: jmt$system_supplied_name,
        valid_entry: boolean;

      status.normal := TRUE;

      local_job_event := job_event;

      WHILE local_job_event <> NIL DO

      /display_block/
        BEGIN
          IF NOT ((display_output_history_command) AND (local_job_event^.header^.statistic_code =
                jml$job_queuing_started)) THEN
            check_system_job_stats (current_job_name, local_job_event^.header,
                  local_job_event^.descriptive_data, valid_entry);

            IF (valid_entry) OR ((local_job_event^.header^.job_name = current_job_name) AND
                  (local_job_event^.header^.statistic_code <> jml$job_file_deleted)) OR
                  (local_job_event^.header^.statistic_code = jml$job_queuing_started) THEN

{ Format descriptive data before formatting header in order to get
{ system_job_name from descriptive data.

              format_descriptive_data (local_job_event^.header, local_job_event^.descriptive_data,
                    descriptive_data_string, system_job_name);
              IF (local_job_event^.header^.statistic_code = jml$job_queuing_started) AND
                    (system_job_name <> current_job_name) THEN

{ This is a job_queuing_started statistic for a job other than the current job, so skip it.

                EXIT /display_block/;
              IFEND;
              format_header (local_job_event^.header, system_job_name, header_string, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              clp$put_display (display_control, header_string, clc$trim, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              clp$new_display_line (display_control, 0, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              an_event_was_displayed := TRUE;

              FOR line_index := 1 TO descriptive_data_string.line_count DO
                clp$put_display (display_control, descriptive_data_string.lines [line_index], clc$trim,
                      status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                clp$new_display_line (display_control, 0, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              FOREND;

              clp$new_display_line (display_control, 1, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

            IFEND;
          IFEND;
        END /display_block/;
        local_job_event := local_job_event^.next_event;
      WHILEND;

    PROCEND output_current_job;
?? OLDTITLE ??
?? EJECT ??
    delete_allowed := FALSE;
    resolve_path := TRUE;
    include_open_pos_in_handle := TRUE;
    clp$convert_str_to_path_handle (output_file^, delete_allowed, resolve_path, include_open_pos_in_handle,
          path_handle_name, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    status.normal := TRUE;
    output.local_file_name := path_handle_name;
    header_string := ' ';
    an_event_was_displayed := FALSE;

    clp$open_display (output, ^new_page_proc, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE requested_sort_order OF
    = jmc$sort_by_time =

      job_event := first_job_event^.next_event;
      WHILE job_event <> NIL DO

{
{  If the statistic is JOB_QUEUING_STARTED and we are processing the display_output_history
{  command the statistic will not be put into the display.
{

        IF ((NOT display_output_history_command) OR (job_event^.header^.statistic_code <>
              jml$job_queuing_started)) THEN

{ Format descriptive data before formatting header in order to get
{ system_job_name from descriptive data.

          format_descriptive_data (job_event^.header, job_event^.descriptive_data, descriptive_data_string,
                system_job_name);

          format_header (job_event^.header, system_job_name, header_string, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_display (display_control, header_string, clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$new_display_line (display_control, 0, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          an_event_was_displayed := TRUE;

          FOR line_index := 1 TO descriptive_data_string.line_count DO
            clp$put_display (display_control, descriptive_data_string.lines [line_index], clc$trim, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$new_display_line (display_control, 0, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND;

          clp$new_display_line (display_control, 1, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        job_event := job_event^.next_event;
      WHILEND;

    = jmc$sort_by_job =

      trace_job := first_job_started^.next_job;
      job_event := first_job_event^.next_event;

      REPEAT
        IF trace_job^.header^.statistic_code = jml$job_queuing_started THEN
          PUSH data_array: [1 .. jmc$jqs_max_desc_data_fields];
          crack_descriptive_data (trace_job^.header^.statistic_code, trace_job^.descriptive_data, data_array);
          current_job_name := data_array^ [jmc$jqs_system_job_name] (1, jmc$system_supplied_name_size);
        ELSEIF trace_job^.header^.statistic_code = jml$output_queuing_started THEN
          PUSH data_array: [1 .. jmc$oqs_max_desc_data_fields];
          crack_descriptive_data (trace_job^.header^.statistic_code, trace_job^.descriptive_data, data_array);
          current_job_name := data_array^ [jmc$oqs_system_job_name] (1, jmc$system_supplied_name_size);
        ELSE
          osp$set_status_condition (jme$jh_internal_error, status);
          RETURN;
        IFEND;

        output_current_job (current_job_name, job_event, display_output_history_command,
              an_event_was_displayed, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        trace_job := trace_job^.next_job;

      UNTIL trace_job = NIL;

    = jmc$sort_by_family =

      trace_job := first_job_started^.next_job;
      job_event := first_job_event^.next_event;

      FOR i := LOWERBOUND (family_names_requested^) TO UPPERBOUND (family_names_requested^) DO
        REPEAT
          IF trace_job^.header^.statistic_code = jml$job_queuing_started THEN
            PUSH data_array: [1 .. jmc$jqs_max_desc_data_fields];
            crack_descriptive_data (trace_job^.header^.statistic_code, trace_job^.descriptive_data,
                  data_array);
            current_family_name := data_array^ [jmc$jqs_login_family] (1, osc$max_name_size);
            current_job_name := data_array^ [jmc$jqs_system_job_name] (1, jmc$system_supplied_name_size);
          ELSEIF trace_job^.header^.statistic_code = jml$output_queuing_started THEN
            PUSH data_array: [1 .. jmc$oqs_max_desc_data_fields];
            crack_descriptive_data (trace_job^.header^.statistic_code, trace_job^.descriptive_data,
                  data_array);
            current_family_name := data_array^ [jmc$oqs_login_family] (1, osc$max_name_size);
            current_job_name := data_array^ [jmc$oqs_system_job_name] (1, jmc$system_supplied_name_size);
          ELSE
            osp$set_status_condition (jme$jh_internal_error, status);
            RETURN;
          IFEND;
          IF family_names_requested^ [i] = current_family_name THEN

            output_current_job (current_job_name, job_event, display_output_history_command,
                  an_event_was_displayed, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

          IFEND;

          trace_job := trace_job^.next_job;
          job_event := trace_job;

        UNTIL trace_job = NIL;
        trace_job := first_job_started^.next_job;
        job_event := first_job_event^.next_event;
      FOREND;

    ELSE
      osp$set_status_condition (jme$jh_internal_error, status);
    CASEND;

    clp$close_display (display_control, status);

  PROCEND display_job_events;
?? OLDTITLE ??
?? NEWTITLE := 'format_header', EJECT ??

  PROCEDURE format_header
    (    header_p: ^sft$global_log_statistic_header;
         system_job_name: jmt$system_supplied_name;
     VAR header_string: string (80);
     VAR status: ost$status);

    VAR
      data_size: 1 .. 80,
      date_value: ost$date,
      event_index: integer,
      event_name: [STATIC, READ, oss$job_paged_literal] array
            [jml$first_history_statistic .. jml$last_history_statistic] of ost$name :=
            ['JOB_QUEUING_STARTED            ', 'JOB_QUEUING_ABORTED            ',
            'OUTPUT_QUEUING_STARTED         ', 'OUTPUT_QUEUING_ABORTED         ',
            'JOB_FORWARDING_STARTED         ', 'OUTPUT_FORWARDING_STARTED      ',
            'JOB_INITIATED                  ', 'JOB_TERMINATED                 ',
            'PRINT_PLOT_INITIATED           ', 'PRINT_PLOT_TERMINATED          ',
            'SUBMIT_JOB_EXECUTED            ', 'PRINT_PLOT_FILE_EXECUTED       ',
            'HISTORY_MESSAGE                ', 'NON_RECOVERY_OF_JOB            ',
            'CHANGE_OUTPUT_ATTRIBUTES       ', 'JOB_FILE_DELETED               ',
            'OUTPUT_FILE_DELETED            '],
      time_value: ost$time;

    status.normal := TRUE;
    data_size := 1;

    header_string (data_size, jmc$system_supplied_name_size) :=
          system_job_name (1, jmc$system_supplied_name_size);
    data_size := data_size + jmc$system_supplied_name_size + 2;

    event_index := header_p^.statistic_code;
    IF (event_index < LOWERBOUND (event_name)) OR (event_index > UPPERBOUND (event_name)) THEN
      RETURN;
    IFEND;
    header_string (data_size, osc$max_name_size) := event_name [event_index];
    data_size := data_size + osc$max_name_size + 2;

    pmp$format_compact_date (header_p^.date_time, osc$mdy_date, date_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    header_string (data_size, 8) := date_value.mdy (1, 8);
    data_size := data_size + 10;

    pmp$format_compact_time (header_p^.date_time, osc$hms_time, time_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    header_string (data_size, 8) := time_value.millisecond (1, 8);

  PROCEND format_header;
?? OLDTITLE ??
?? NEWTITLE := 'format_descriptive_data', EJECT ??

  PROCEDURE format_descriptive_data
    (    header: ^sft$global_log_statistic_header;
         descriptive_data: ^sft$descriptive_data;
     VAR data_string: formatted_data;
     VAR system_job_name: jmt$system_supplied_name);


    VAR
      data_array: ^array [1 .. * ] of string (osc$max_name_size),
      data_size: 1 .. osc$max_string_size,
      line_index: formatted_line_range,
      message_size: 1 .. osc$max_string_size,
      str_size: 0 .. osc$max_name_size;

    data_string.line_count := 1;
    FOR line_index := 1 TO UPPERBOUND (data_string.lines) DO
      data_string.lines [line_index] := '';
    FOREND;
    data_size := 1;
    system_job_name := jmc$blank_system_supplied_name;

{ Don't put the system_job_name into the data_string; it goes into the header_string.
{ The one exception to this is the submit_job_executed statistic, in which the
{ system_job_name in the descriptive data is that of the submitted job so it goes
{ into the data_string.

    CASE header^.statistic_code OF
    = jml$job_queuing_started =

      PUSH data_array: [1 .. jmc$jqs_max_desc_data_fields];
      crack_descriptive_data (header^.statistic_code, descriptive_data, data_array);

      system_job_name := data_array^ [jmc$jqs_system_job_name];
      data_string.line_count := 2;

      data_string.lines [1] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [1] (data_size, 4) := 'UJN=';
      data_size := data_size + 4;

      str_size := clp$trimmed_string_size (data_array^ [jmc$jqs_user_job_name]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$jqs_user_job_name] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 14) := ', LOGIN_USER=:';
      data_size := data_size + 14;

      str_size := clp$trimmed_string_size (data_array^ [jmc$jqs_login_family]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$jqs_login_family] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 1) := '.';
      data_size := data_size + 1;

      str_size := clp$trimmed_string_size (data_array^ [jmc$jqs_login_user]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$jqs_login_user] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 1) := ',';

      data_size := 1;

      data_string.lines [2] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [2] (data_size, 14) := 'CONTROL_USER=:';
      data_size := data_size + 14;

      str_size := clp$trimmed_string_size (data_array^ [jmc$jqs_control_family]);
      data_string.lines [2] (data_size, str_size) := data_array^ [jmc$jqs_control_family] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [2] (data_size, 1) := '.';
      data_size := data_size + 1;

      str_size := clp$trimmed_string_size (data_array^ [jmc$jqs_control_user]);
      data_string.lines [2] (data_size, str_size) := data_array^ [jmc$jqs_control_user] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [2] (data_size, 10) := ', STATION=';
      data_size := data_size + 10;

      str_size := clp$trimmed_string_size (data_array^ [jmc$jqs_station]);
      data_string.lines [2] (data_size, str_size) := data_array^ [jmc$jqs_station] (1, str_size);
      data_size := data_size + str_size;

      IF data_array^ [jmc$jqs_reason] <> osc$null_name THEN
        data_string.line_count := 3;
        data_size := 1;

        data_string.lines [2] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
        data_size := data_size + jmc$system_supplied_name_size;

        data_string.lines [3] (data_size, 7) := 'REASON=';
        data_size := data_size + 7;

        str_size := clp$trimmed_string_size (data_array^ [jmc$jqs_reason]);
        data_string.lines [3] (data_size, str_size) := data_array^ [jmc$jqs_reason] (1, str_size);
        data_size := data_size + str_size;
      IFEND;

    = jml$job_queuing_aborted =

      PUSH data_array: [1 .. jmc$jqa_max_desc_data_fields];
      crack_descriptive_data (header^.statistic_code, descriptive_data, data_array);

      system_job_name := data_array^ [jmc$jqa_system_job_name];
      data_string.lines [1] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [1] (data_size, 7) := 'REASON=';
      data_size := data_size + 7;

      str_size := clp$trimmed_string_size (data_array^ [jmc$jqa_reason]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$jqa_reason] (1, str_size);
      data_size := data_size + str_size;

    = jml$job_file_deleted =

      PUSH data_array: [1 .. jmc$jfd_max_desc_data_fields];
      crack_descriptive_data (header^.statistic_code, descriptive_data, data_array);

      system_job_name := data_array^ [jmc$jfd_system_job_name];
      data_string.lines [1] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [1] (data_size, 7) := 'REASON=';
      data_size := data_size + 7;

      str_size := clp$trimmed_string_size (data_array^ [jmc$jfd_reason]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$jfd_reason] (1, str_size);
      data_size := data_size + str_size;

    = jml$output_queuing_started =

      PUSH data_array: [1 .. jmc$oqs_max_desc_data_fields];
      crack_descriptive_data (header^.statistic_code, descriptive_data, data_array);

      system_job_name := data_array^ [jmc$oqs_system_job_name];
      data_string.line_count := 2;

      data_string.lines [1] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [1] (data_size, 12) := 'LOGIN_USER=:';
      data_size := data_size + 12;

      str_size := clp$trimmed_string_size (data_array^ [jmc$oqs_login_family]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$oqs_login_family] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 1) := '.';
      data_size := data_size + 1;

      str_size := clp$trimmed_string_size (data_array^ [jmc$oqs_login_user]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$oqs_login_user] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 6) := ', SFN=';
      data_size := data_size + 6;

      str_size := clp$trimmed_string_size (data_array^ [jmc$oqs_system_file_name]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$oqs_system_file_name] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 1) := ',';

      data_size := 1;

      data_string.lines [2] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [2] (data_size, 14) := 'CONTROL_USER=:';
      data_size := data_size + 14;

      str_size := clp$trimmed_string_size (data_array^ [jmc$oqs_control_family]);
      data_string.lines [2] (data_size, str_size) := data_array^ [jmc$oqs_control_family] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [2] (data_size, 1) := '.';
      data_size := data_size + 1;

      str_size := clp$trimmed_string_size (data_array^ [jmc$oqs_control_user]);
      data_string.lines [2] (data_size, str_size) := data_array^ [jmc$oqs_control_user] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [2] (data_size, 10) := ', STATION=';
      data_size := data_size + 10;

      str_size := clp$trimmed_string_size (data_array^ [jmc$oqs_station]);
      data_string.lines [2] (data_size, str_size) := data_array^ [jmc$oqs_station] (1, str_size);
      data_size := data_size + str_size;

      IF data_array^ [jmc$oqs_reason] <> osc$null_name THEN
        data_string.line_count := 3;
        data_size := 1;

        data_string.lines [2] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
        data_size := data_size + jmc$system_supplied_name_size;

        data_string.lines [3] (data_size, 7) := 'REASON=';
        data_size := data_size + 7;

        str_size := clp$trimmed_string_size (data_array^ [jmc$oqs_reason]);
        data_string.lines [3] (data_size, str_size) := data_array^ [jmc$oqs_reason] (1, str_size);
        data_size := data_size + str_size;
      IFEND;

    = jml$output_queuing_aborted =

      PUSH data_array: [1 .. jmc$oqa_max_desc_data_fields];
      crack_descriptive_data (header^.statistic_code, descriptive_data, data_array);

      system_job_name := data_array^ [jmc$oqa_system_job_name];
      data_string.lines [1] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [1] (data_size, 4) := 'SFN=';
      data_size := data_size + 4;

      str_size := clp$trimmed_string_size (data_array^ [jmc$oqa_system_file_name]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$oqa_system_file_name] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 9) := ', REASON=';
      data_size := data_size + 9;

      str_size := clp$trimmed_string_size (data_array^ [jmc$oqa_reason]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$oqa_reason] (1, str_size);
      data_size := data_size + str_size;

    = jml$output_file_deleted =

      PUSH data_array: [1 .. jmc$ofd_max_desc_data_fields];
      crack_descriptive_data (header^.statistic_code, descriptive_data, data_array);

      system_job_name := data_array^ [jmc$ofd_system_job_name];
      data_string.lines [1] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [1] (data_size, 4) := 'SFN=';
      data_size := data_size + 4;

      str_size := clp$trimmed_string_size (data_array^ [jmc$ofd_system_file_name]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$ofd_system_file_name] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 9) := ', REASON=';
      data_size := data_size + 9;

      str_size := clp$trimmed_string_size (data_array^ [jmc$ofd_reason]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$ofd_reason] (1, str_size);
      data_size := data_size + str_size;

    = jml$job_forwarding_started =

      PUSH data_array: [1 .. jmc$jfs_max_desc_data_fields];
      crack_descriptive_data (header^.statistic_code, descriptive_data, data_array);

      system_job_name := data_array^ [jmc$jfs_system_job_name];

    = jml$output_forwarding_started =

      PUSH data_array: [1 .. jmc$ofs_max_desc_data_fields];
      crack_descriptive_data (header^.statistic_code, descriptive_data, data_array);

      system_job_name := data_array^ [jmc$ofs_system_job_name];
      data_string.lines [1] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [1] (data_size, 4) := 'SFN=';
      data_size := data_size + 4;

      str_size := clp$trimmed_string_size (data_array^ [jmc$ofs_system_file_name]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$ofs_system_file_name] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 11) := ', APP_NAME=';
      data_size := data_size + 11;

      str_size := clp$trimmed_string_size (data_array^ [jmc$ofs_application_name]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$ofs_application_name] (1, str_size);
      data_size := data_size + str_size;

    = jml$job_initiated =

      PUSH data_array: [1 .. jmc$ji_max_desc_data_fields];
      crack_descriptive_data (header^.statistic_code, descriptive_data, data_array);

      system_job_name := data_array^ [jmc$ji_system_job_name];

    = jml$job_terminated =

      PUSH data_array: [1 .. jmc$jt_max_desc_data_fields];
      crack_descriptive_data (header^.statistic_code, descriptive_data, data_array);

      system_job_name := data_array^ [jmc$jt_system_job_name];
      data_string.lines [1] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [1] (data_size, 4) := 'SFN=';
      data_size := data_size + 4;

      str_size := clp$trimmed_string_size (data_array^ [jmc$jt_system_file_name]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$jt_system_file_name] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 21) := ', OUTPUT_DISPOSITION=';
      data_size := data_size + 21;

      str_size := clp$trimmed_string_size (data_array^ [jmc$jt_output_disposition]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$jt_output_disposition] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 9) := ', REASON=';
      data_size := data_size + 9;

      str_size := clp$trimmed_string_size (data_array^ [jmc$jt_reason]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$jt_reason] (1, str_size);
      data_size := data_size + str_size;

    = jml$print_plot_initiated =

      PUSH data_array: [1 .. jmc$ppi_max_desc_data_fields];
      crack_descriptive_data (header^.statistic_code, descriptive_data, data_array);

      system_job_name := data_array^ [jmc$ppi_system_job_name];
      data_string.lines [1] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [1] (data_size, 4) := 'SFN=';
      data_size := data_size + 4;

      str_size := clp$trimmed_string_size (data_array^ [jmc$ppi_system_file_name]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$ppi_system_file_name] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 11) := ', APP_NAME=';
      data_size := data_size + 11;

      str_size := clp$trimmed_string_size (data_array^ [jmc$ppi_application_name]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$ppi_application_name] (1, str_size);
      data_size := data_size + str_size;

    = jml$print_plot_terminated =

      PUSH data_array: [1 .. jmc$ppt_max_desc_data_fields];
      crack_descriptive_data (header^.statistic_code, descriptive_data, data_array);

      system_job_name := data_array^ [jmc$ppt_system_job_name];
      data_string.lines [1] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [1] (data_size, 4) := 'SFN=';
      data_size := data_size + 4;

      str_size := clp$trimmed_string_size (data_array^ [jmc$ppt_system_file_name]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$ppt_system_file_name] (1, str_size);
      data_size := data_size + str_size;

    = jml$submit_job_executed =

      PUSH data_array: [1 .. jmc$sje_max_desc_data_fields];
      crack_descriptive_data (header^.statistic_code, descriptive_data, data_array);

{ For the submit_job_executed statistic, the system_job_name of the submitting job is in the
{ statistic header and is put out in the header_string. The system_job_name of the submitted job
{ is in the statistic's descriptive data and is put out in the data_string.

      system_job_name := header^.job_name (1, jmc$system_supplied_name_size);
      data_string.lines [1] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [1] (data_size, 4) := 'SJN=';
      data_size := data_size + 4;

      str_size := clp$trimmed_string_size (data_array^ [jmc$sje_system_job_name]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$sje_system_job_name] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 18) := ', JOB_DESTINATION=';
      data_size := data_size + 18;

      str_size := clp$trimmed_string_size (data_array^ [jmc$sje_job_destination]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$sje_job_destination] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 24) := ', JOB_DESTINATION_USAGE=';
      data_size := data_size + 24;

      str_size := clp$trimmed_string_size (data_array^ [jmc$sje_job_destination_usage]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$sje_job_destination_usage] (1,
            str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 6) := ', UJN=';
      data_size := data_size + 6;

      str_size := clp$trimmed_string_size (data_array^ [jmc$sje_user_job_name]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$sje_user_job_name] (1, str_size);

    = jml$print_plot_file_executed =

      PUSH data_array: [1 .. jmc$ppfe_max_desc_data_fields];
      crack_descriptive_data (header^.statistic_code, descriptive_data, data_array);

      system_job_name := data_array^ [jmc$ppfe_system_job_name];
      data_string.lines [1] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [1] (data_size, 4) := 'SFN=';
      data_size := data_size + 4;

      str_size := clp$trimmed_string_size (data_array^ [jmc$ppfe_system_file_name]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$ppfe_system_file_name] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 21) := ', OUTPUT_DESTINATION=';
      data_size := data_size + 21;

      str_size := clp$trimmed_string_size (data_array^ [jmc$ppfe_output_destination]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$ppfe_output_destination] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 27) := ', OUTPUT_DESTINATION_USAGE=';
      data_size := data_size + 27;

      str_size := clp$trimmed_string_size (data_array^ [jmc$ppfe_output_dest_usage]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$ppfe_output_dest_usage] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 17) := ', USER_FILE_NAME=';
      data_size := data_size + 17;

      str_size := clp$trimmed_string_size (data_array^ [jmc$ppfe_user_file_name]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$ppfe_user_file_name] (1, str_size);

    = jml$job_history_message =

{ Use crack_descriptive_data just to get system_job_name. Don't crack message.

      PUSH data_array: [1 .. jmc$jhm_system_job_name];
      crack_descriptive_data (header^.statistic_code, descriptive_data, data_array);

      system_job_name := data_array^ [jmc$jhm_system_job_name];
      data_string.lines [1] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [1] (data_size, 8) := 'MESSAGE=';
      data_size := data_size + 8;

      message_size := header^.descriptive_data_size - jmc$system_supplied_name_size;
      data_string.lines [1] (data_size, message_size) := descriptive_data^
            (jmc$system_supplied_name_size + 1, message_size);

    = jml$non_recovery_of_job =

      PUSH data_array: [1 .. jmc$nroj_max_desc_data_fields];
      crack_descriptive_data (header^.statistic_code, descriptive_data, data_array);

      system_job_name := data_array^ [jmc$nroj_system_job_name];
      data_string.lines [1] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [1] (data_size, 7) := 'REASON=';
      data_size := data_size + 7;

      str_size := clp$trimmed_string_size (data_array^ [jmc$nroj_reason]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$nroj_reason] (1, str_size);

    = jml$change_output_attributes =

      PUSH data_array: [1 .. jmc$coa_max_desc_data_fields];
      crack_descriptive_data (header^.statistic_code, descriptive_data, data_array);

      system_job_name := data_array^ [jmc$coa_system_job_name];
      data_string.line_count := 2;

      data_string.lines [1] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [1] (data_size, 4) := 'SFN=';
      data_size := data_size + 4;

      str_size := clp$trimmed_string_size (data_array^ [jmc$coa_system_file_name]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$coa_system_file_name] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 16) := ', CONTROL_USER=:';
      data_size := data_size + 16;

      str_size := clp$trimmed_string_size (data_array^ [jmc$coa_control_family]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$coa_control_family] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 1) := '.';
      data_size := data_size + 1;

      str_size := clp$trimmed_string_size (data_array^ [jmc$coa_control_user]);
      data_string.lines [1] (data_size, str_size) := data_array^ [jmc$coa_control_user] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [1] (data_size, 1) := ',';

      data_size := 1;

      data_string.lines [2] (data_size, jmc$system_supplied_name_size) := jmc$blank_system_supplied_name;
      data_size := data_size + jmc$system_supplied_name_size;

      data_string.lines [2] (data_size, 19) := 'OUTPUT_DESTINATION=';
      data_size := data_size + 19;

      str_size := clp$trimmed_string_size (data_array^ [jmc$coa_output_destination]);
      data_string.lines [2] (data_size, str_size) := data_array^ [jmc$coa_output_destination] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [2] (data_size, 27) := ', OUTPUT_DESTINATION_USAGE=';
      data_size := data_size + 27;

      str_size := clp$trimmed_string_size (data_array^ [jmc$coa_output_dest_usage]);
      data_string.lines [2] (data_size, str_size) := data_array^ [jmc$coa_output_dest_usage] (1, str_size);
      data_size := data_size + str_size;

      data_string.lines [2] (data_size, 10) := ', STATION=';
      data_size := data_size + 10;

      str_size := clp$trimmed_string_size (data_array^ [jmc$coa_station]);
      data_string.lines [2] (data_size, str_size) := data_array^ [jmc$coa_station] (1, str_size);

    ELSE

{ do nothing - ignore any statistic other than valid job history statistics

    CASEND;

  PROCEND format_descriptive_data;
?? OLDTITLE ??
MODEND jmm$process_job_history;
*DECK DECK=JMM$PROFILE_DISPLAY_COMMANDS EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Scheduling : Profile Display Commands' ??
MODULE jmm$profile_display_commands;

{ PURPOSE:
{   This module defines the commands used to display objects on the profile.
{   It is used by ADMINISTER_SCHEDULING and MANAGE_ACTIVE_SCHEDLING to
{   process the commands -
{
{    display_application in MANAGE_ACTIVE_SCHEDULING or
{      display_attributes in ADMINISTER_APPLICATION.
{
{    display_controls in MANAGE_ACTIVE_SCHEDULING or
{      display_attributes in ADMINISTER_CONTROLS.
{
{    display_job_class in MANAGE_ACTIVE_SCHEDULING or
{      display_attributes in ADMINISTER_JOB_CLASS.
{
{    display_service_class in MANAGE_ACTIVE_SCHEDULING or
{      display_attributes in ADMINISTER_SERVICE_CLASS.
{
{    display_output_class in MANAGE_ACTIVE_SCHEDULING or
{      display_attributes in ADMINISTER_OUTPUT_CLASS.
{
{    display_job_categories in MANAGE_ACTIVE_SCHEDULING and
{      administer_scheduling.
{
{    display_job priorities in MANAGE_ACTIVE_SCHEDULING and
{      administer_scheduling.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$job_management_id
*copyc jme$object_display_errors
?? POP ??
*copyc clp$evaluate_parameters
*copyc jmp$display_objects
*copyc jmp$get_object_list

*copyc jmv$current_profile_level
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$_display_application ', EJECT ??

{ PURPOSE:
{   Processes the DISPLAY_ATTRIBUTE command in ADMINISTER_SCHEDULING or
{   the DISPLAY_APPLICATION command in MANAGE_ACTIVE_SCHEDULING.
{
{ DESIGN:
{   Determine the applications to display and display their attribute values.
{
{ NOTES:
{   See JMM$ADMINISTER_DISPLAY.

  PROCEDURE [XDCL] jmp$_display_application
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_disa) display_application (
{   application_name, application_names, an: any of
{       key all keyend
{       list of name
{     anyend = $current_application
{   display_option, display_options, do: any of
{       key all keyend
{       list of key
{         (cyclic_aging_interval, cai)
{         (enable_application_scheduling, eas)
{         (maximum_working_set, maxws)
{         (minimum_working_set, minws)
{         (page_aging_interval, pai)
{         (service_class, sc)
{       hidden_key
{         (definition_name, dn)
{       keyend
{     anyend = all
{   group_option, group_options, go: any of
{       key all keyend
{       list of key
{         (membership, m), (limit, l), (priority, p)
{         (statistic, s), (definition, d), (control, c)
{       keyend
{     anyend = $optional
{   output, o: (by_name) file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 12] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (20),
        recend,
        type2: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$keyword_type_qualifier,
              keyword_specs: array [1 .. 14] of clt$keyword_specification,
            recend,
          recend,
          default_value: string (3),
        recend,
        type3: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$keyword_type_qualifier,
              keyword_specs: array [1 .. 12] of clt$keyword_specification,
            recend,
          recend,
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 11, 37, 606], clc$command, 12, 5, 0, 0, 0,
            0, 5, 'OSM$MANAS_DISA'], [['AN                             ',
            clc$abbreviation_entry, 1], ['APPLICATION_NAME               ',
            clc$nominal_entry, 1], ['APPLICATION_NAMES              ',
            clc$alias_entry, 1], ['DISPLAY_OPTION                 ',
            clc$nominal_entry, 2], ['DISPLAY_OPTIONS                ',
            clc$alias_entry, 2], ['DO                             ',
            clc$abbreviation_entry, 2], ['GO                             ',
            clc$abbreviation_entry, 3], ['GROUP_OPTION                   ',
            clc$nominal_entry, 3], ['GROUP_OPTIONS                  ',
            clc$alias_entry, 3], ['O                              ',
            clc$abbreviation_entry, 4], ['OUTPUT                         ',
            clc$nominal_entry, 4], ['STATUS                         ',
            clc$nominal_entry, 5]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 20],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 605,
            clc$optional_default_parameter, 0, 3],

{ PARAMETER 3

      [8, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 531,
            clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [11, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [12, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            '$current_application'],

{ PARAMETER 2

      [[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]]], 541,
            [[1, 0, clc$list_type], [525, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [14], [[
            'CAI                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['CYCLIC_AGING_INTERVAL          ',
            clc$nominal_entry, clc$normal_usage_entry, 1],
            ['DEFINITION_NAME                ', clc$nominal_entry,
            clc$hidden_entry, 7], ['DN                             ',
            clc$abbreviation_entry, clc$hidden_entry, 7],
            ['EAS                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['ENABLE_APPLICATION_SCHEDULING  ',
            clc$nominal_entry, clc$normal_usage_entry, 2],
            ['MAXIMUM_WORKING_SET            ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['MAXWS                          ',
            clc$abbreviation_entry, clc$normal_usage_entry, 3],
            ['MINIMUM_WORKING_SET            ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['MINWS                          ',
            clc$abbreviation_entry, clc$normal_usage_entry, 4],
            ['PAGE_AGING_INTERVAL            ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['PAI                            ',
            clc$abbreviation_entry, clc$normal_usage_entry, 5],
            ['SC                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['SERVICE_CLASS                  ',
            clc$nominal_entry, clc$normal_usage_entry, 6]]]], 'all'],

{ PARAMETER 3

      [[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]]], 467,
            [[1, 0, clc$list_type], [451, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [12], [[
            'C                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['CONTROL                        ',
            clc$nominal_entry, clc$normal_usage_entry, 6],
            ['D                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['DEFINITION                     ',
            clc$nominal_entry, clc$normal_usage_entry, 5],
            ['L                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['LIMIT                          ',
            clc$nominal_entry, clc$normal_usage_entry, 2],
            ['M                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['MEMBERSHIP                     ',
            clc$nominal_entry, clc$normal_usage_entry, 1],
            ['P                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['PRIORITY                       ',
            clc$nominal_entry, clc$normal_usage_entry, 3],
            ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['STATISTIC                      ',
            clc$nominal_entry, clc$normal_usage_entry, 4]]]]],

{ PARAMETER 4

      [[1, 0, clc$file_type]],

{ PARAMETER 5

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$application_name = 1,
      p$display_option = 2,
      p$group_option = 3,
      p$output = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_application;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$display_objects (jmc$profile_application, FALSE,
          pvt [p$application_name], pvt [p$display_option],
          pvt [p$group_option], pvt [p$output], status);

  PROCEND jmp$_display_application;
?? TITLE := '[XDCL] jmp$_display_controls ', EJECT ??

{ PURPOSE:
{   Processes the DISPLAY_ATTRIBUTE command of ADMINISTER_SCHEDULING and
{   the DISPLAY_CONTROLS command of MANAGE_ACTIVE_SCHEDULING.
{
{ DESIGN:
{   Determine the controls to display and display their attribute values.
{
{ NOTES:
{   See JMM$ADMINISTER_DISPLAY.

  PROCEDURE [XDCL] jmp$_display_controls
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_disc) display_controls (
{   mainframe_name, controls_name, controls_names, ..
{     mainframe_names, mn, cn: any of
{       key all keyend
{       list of name
{     anyend = $current_mainframe
{   display_option, display_options, do: any of
{       key all keyend
{       list of key
{         (abbreviation, a)
{         (cpu_dispatching_allocation, cda)
{         (cpu_dispatching_interval, cdi)
{         (cpu_quantum_time, cqt)
{         (dual_state_priority_control, dspc)
{         (enable_job_leveling, ejl)
{         (idle_dispatching_queue_time, idqt)
{         (initiation_excluded_categories, iec)
{         (initiation_required_categories, irc)
{         (job_leveling_interval, jli)
{         (job_leveling_priority_bias, jlpb)
{         (scheduling_memory_levels, sml)
{         (service_calculation_interval, sci)
{         (validation_excluded_categories, vec)
{         (validation_required_categories, vrc)
{       hidden_key
{         (profile_identification, pi)
{       keyend
{     anyend = all
{   group_option, group_options, go: any of
{       key all keyend
{       list of key
{         (membership, m), (limit, l), (priority, p)
{         (statistic, s), (definition, d), (control, c)
{       keyend
{     anyend = $optional
{   output, o: (by_name) file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 15] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (18),
        recend,
        type2: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$keyword_type_qualifier,
              keyword_specs: array [1 .. 32] of clt$keyword_specification,
            recend,
          recend,
          default_value: string (3),
        recend,
        type3: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$keyword_type_qualifier,
              keyword_specs: array [1 .. 12] of clt$keyword_specification,
            recend,
          recend,
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 12, 24, 480], clc$command, 15, 5, 0, 0, 0,
            0, 5, 'OSM$MANAS_DISC'], [['CN                             ',
            clc$abbreviation_entry, 1], ['CONTROLS_NAME                  ',
            clc$alias_entry, 1], ['CONTROLS_NAMES                 ',
            clc$alias_entry, 1], ['DISPLAY_OPTION                 ',
            clc$nominal_entry, 2], ['DISPLAY_OPTIONS                ',
            clc$alias_entry, 2], ['DO                             ',
            clc$abbreviation_entry, 2], ['GO                             ',
            clc$abbreviation_entry, 3], ['GROUP_OPTION                   ',
            clc$nominal_entry, 3], ['GROUP_OPTIONS                  ',
            clc$alias_entry, 3], ['MAINFRAME_NAME                 ',
            clc$nominal_entry, 1], ['MAINFRAME_NAMES                ',
            clc$alias_entry, 1], ['MN                             ',
            clc$alias_entry, 1], ['O                              ',
            clc$abbreviation_entry, 4], ['OUTPUT                         ',
            clc$nominal_entry, 4], ['STATUS                         ',
            clc$nominal_entry, 5]], [

{ PARAMETER 1

      [10, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 18],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 1271,
            clc$optional_default_parameter, 0, 3],

{ PARAMETER 3

      [8, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 531,
            clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [14, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [15, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            '$current_mainframe'],

{ PARAMETER 2

      [[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]]], 1207,
            [[1, 0, clc$list_type], [1191, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [32], [[
            'A                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['ABBREVIATION                   ',
            clc$nominal_entry, clc$normal_usage_entry, 1],
            ['CDA                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['CDI                            ',
            clc$abbreviation_entry, clc$normal_usage_entry, 3],
            ['CPU_DISPATCHING_ALLOCATION     ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['CPU_DISPATCHING_INTERVAL       ',
            clc$nominal_entry, clc$normal_usage_entry, 3],
            ['CPU_QUANTUM_TIME               ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['CQT                            ',
            clc$abbreviation_entry, clc$normal_usage_entry, 4],
            ['DSPC                           ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['DUAL_STATE_PRIORITY_CONTROL    ',
            clc$nominal_entry, clc$normal_usage_entry, 5],
            ['EJL                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['ENABLE_JOB_LEVELING            ',
            clc$nominal_entry, clc$normal_usage_entry, 6],
            ['IDLE_DISPATCHING_QUEUE_TIME    ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['IDQT                           ',
            clc$abbreviation_entry, clc$normal_usage_entry, 7],
            ['IEC                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 8], ['INITIATION_EXCLUDED_CATEGORIES ',
            clc$nominal_entry, clc$normal_usage_entry, 8],
            ['INITIATION_REQUIRED_CATEGORIES ', clc$nominal_entry,
            clc$normal_usage_entry, 9], ['IRC                            ',
            clc$abbreviation_entry, clc$normal_usage_entry, 9],
            ['JLI                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 10], ['JLPB                           ',
            clc$abbreviation_entry, clc$normal_usage_entry, 11],
            ['JOB_LEVELING_INTERVAL          ', clc$nominal_entry,
            clc$normal_usage_entry, 10], ['JOB_LEVELING_PRIORITY_BIAS     ',
            clc$nominal_entry, clc$normal_usage_entry, 11],
            ['PI                             ', clc$abbreviation_entry,
            clc$hidden_entry, 16], ['PROFILE_IDENTIFICATION         ',
            clc$nominal_entry, clc$hidden_entry, 16],
            ['SCHEDULING_MEMORY_LEVELS       ', clc$nominal_entry,
            clc$normal_usage_entry, 12], ['SCI                            ',
            clc$abbreviation_entry, clc$normal_usage_entry, 13],
            ['SERVICE_CALCULATION_INTERVAL   ', clc$nominal_entry,
            clc$normal_usage_entry, 13], ['SML                            ',
            clc$abbreviation_entry, clc$normal_usage_entry, 12],
            ['VALIDATION_EXCLUDED_CATEGORIES ', clc$nominal_entry,
            clc$normal_usage_entry, 14], ['VALIDATION_REQUIRED_CATEGORIES ',
            clc$nominal_entry, clc$normal_usage_entry, 15],
            ['VEC                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 14], ['VRC                            ',
            clc$abbreviation_entry, clc$normal_usage_entry, 15]]]], 'all'],

{ PARAMETER 3

      [[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]]], 467,
            [[1, 0, clc$list_type], [451, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [12], [[
            'C                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['CONTROL                        ',
            clc$nominal_entry, clc$normal_usage_entry, 6],
            ['D                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['DEFINITION                     ',
            clc$nominal_entry, clc$normal_usage_entry, 5],
            ['L                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['LIMIT                          ',
            clc$nominal_entry, clc$normal_usage_entry, 2],
            ['M                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['MEMBERSHIP                     ',
            clc$nominal_entry, clc$normal_usage_entry, 1],
            ['P                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['PRIORITY                       ',
            clc$nominal_entry, clc$normal_usage_entry, 3],
            ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['STATISTIC                      ',
            clc$nominal_entry, clc$normal_usage_entry, 4]]]]],

{ PARAMETER 4

      [[1, 0, clc$file_type]],

{ PARAMETER 5

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$mainframe_name = 1,
      p$display_option = 2,
      p$group_option = 3,
      p$output = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_controls;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$display_objects (jmc$profile_controls, FALSE, pvt [p$mainframe_name],
          pvt [p$display_option], pvt [p$group_option], pvt [p$output],
          status);

  PROCEND jmp$_display_controls;
?? TITLE := '[XDCL] jmp$_display_job_class', EJECT ??

{ PURPOSE:
{   Processes the DISPLAY_ATTRIBUTE command of ADMINISTER_JOB_CLASS and
{   the DISPLAY_JOB_CLASS command of MANAGE_ACTIVE_SCHEDULING.
{
{ DESIGN:
{   Determine the job classes to display and display their attribute values.
{
{ NOTES:
{   See JMM$ADMINISTER_DISPLAY.

  PROCEDURE [XDCL] jmp$_display_job_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_disjcl) display_job_class (
{   class_name, class_names, cn: any of
{       key all keyend
{       list of name
{     anyend = $current_job_class
{   display_option, display_options, do: any of
{       key all keyend
{       list of key
{         (abbreviation, a)
{         (automatic_class_selection, acs)
{         (cpu_time_limit, ctl)
{         (cyclic_aging_interval, cai)
{         (defer_on_submit, dos)
{         (detached_job_wait_time, djwt)
{         (enable_class_initiation, eci)
{         (epilog, e)
{         (excluded_categories, ec)
{         (immediate_initiation_candidate, iic)
{         (initial_service_class, isc)
{         (initial_working_set, iws)
{         (initiated_jobs, ij)
{         (initiation_age_interval, iai)
{         (initiation_level, il)
{         (job_leveling_priority_bias, jlpb)
{         (magnetic_tape_limit, mtl)
{         (maximum_working_set, maxws)
{         (minimum_working_set, minws)
{         (multiple_job_bias, mjb)
{         (page_aging_interval, pai)
{         (prolog, p)
{         (queued_jobs, qj)
{         (required_categories, rc)
{         (selection_priority, sp)
{         (sru_limit, sl)
{       hidden_key
{         (definition_name, dn)
{         (profile_index, pi)
{         (job_class_index, jci)
{       keyend
{     anyend = all
{   group_option, group_options, go: any of
{       key all keyend
{       list of key
{         (membership, m), (limit, l), (priority, p)
{         (statistic, s), (definition, d), (control, c)
{       keyend
{     anyend = $optional
{   output, o: (by_name) file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 12] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (18),
      recend,
      type2: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 58] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type3: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 12] of clt$keyword_specification,
          recend,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 1, 29, 9, 54, 5, 76],
    clc$command, 12, 5, 0, 0, 0, 0, 5, 'OSM$MANAS_DISJCL'], [
    ['CLASS_NAME                     ',clc$nominal_entry, 1],
    ['CLASS_NAMES                    ',clc$alias_entry, 1],
    ['CN                             ',clc$abbreviation_entry, 1],
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['GO                             ',clc$abbreviation_entry, 3],
    ['GROUP_OPTION                   ',clc$nominal_entry, 3],
    ['GROUP_OPTIONS                  ',clc$alias_entry, 3],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OUTPUT                         ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 18],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 2233, clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 531, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    '$current_job_class'],
{ PARAMETER 2
    [[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]]
      ],
    2169, [[1, 0, clc$list_type], [2153, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [58], [
        ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['ABBREVIATION                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['ACS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['AUTOMATIC_CLASS_SELECTION      ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['CAI                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['CPU_TIME_LIMIT                 ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['CTL                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['CYCLIC_AGING_INTERVAL          ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['DEFER_ON_SUBMIT                ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['DEFINITION_NAME                ', clc$nominal_entry,
  clc$hidden_entry, 27],
        ['DETACHED_JOB_WAIT_TIME         ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
        ['DJWT                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['DN                             ', clc$abbreviation_entry,
  clc$hidden_entry, 27],
        ['DOS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['E                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
        ['EC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
        ['ECI                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
        ['ENABLE_CLASS_INITIATION        ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
        ['EPILOG                         ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
        ['EXCLUDED_CATEGORIES            ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
        ['IAI                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 14],
        ['IIC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
        ['IJ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 13],
        ['IL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 15],
        ['IMMEDIATE_INITIATION_CANDIDATE ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
        ['INITIAL_SERVICE_CLASS          ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
        ['INITIAL_WORKING_SET            ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
        ['INITIATED_JOBS                 ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
        ['INITIATION_AGE_INTERVAL        ', clc$nominal_entry,
  clc$normal_usage_entry, 14],
        ['INITIATION_LEVEL               ', clc$nominal_entry,
  clc$normal_usage_entry, 15],
        ['ISC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 11],
        ['IWS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 12],
        ['JCI                            ', clc$abbreviation_entry,
  clc$hidden_entry, 29],
        ['JLPB                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 16],
        ['JOB_CLASS_INDEX                ', clc$nominal_entry,
  clc$hidden_entry, 29],
        ['JOB_LEVELING_PRIORITY_BIAS     ', clc$nominal_entry,
  clc$normal_usage_entry, 16],
        ['MAGNETIC_TAPE_LIMIT            ', clc$nominal_entry,
  clc$normal_usage_entry, 17],
        ['MAXIMUM_WORKING_SET            ', clc$nominal_entry,
  clc$normal_usage_entry, 18],
        ['MAXWS                          ', clc$abbreviation_entry,
  clc$normal_usage_entry, 18],
        ['MINIMUM_WORKING_SET            ', clc$nominal_entry,
  clc$normal_usage_entry, 19],
        ['MINWS                          ', clc$abbreviation_entry,
  clc$normal_usage_entry, 19],
        ['MJB                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 20],
        ['MTL                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 17],
        ['MULTIPLE_JOB_BIAS              ', clc$nominal_entry,
  clc$normal_usage_entry, 20],
        ['P                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 22],
        ['PAGE_AGING_INTERVAL            ', clc$nominal_entry,
  clc$normal_usage_entry, 21],
        ['PAI                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 21],
        ['PI                             ', clc$abbreviation_entry,
  clc$hidden_entry, 28],
        ['PROFILE_INDEX                  ', clc$nominal_entry,
  clc$hidden_entry, 28],
        ['PROLOG                         ', clc$nominal_entry,
  clc$normal_usage_entry, 22],
        ['QJ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 23],
        ['QUEUED_JOBS                    ', clc$nominal_entry,
  clc$normal_usage_entry, 23],
        ['RC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 24],
        ['REQUIRED_CATEGORIES            ', clc$nominal_entry,
  clc$normal_usage_entry, 24],
        ['SELECTION_PRIORITY             ', clc$nominal_entry,
  clc$normal_usage_entry, 25],
        ['SL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 26],
        ['SP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 25],
        ['SRU_LIMIT                      ', clc$nominal_entry,
  clc$normal_usage_entry, 26]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[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]]
      ],
    467, [[1, 0, clc$list_type], [451, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [12], [
        ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['CONTROL                        ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
        ['D                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['DEFINITION                     ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['LIMIT                          ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['M                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['MEMBERSHIP                     ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['P                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['PRIORITY                       ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['STATISTIC                      ', clc$nominal_entry,
  clc$normal_usage_entry, 4]]
        ]
      ]
    ],
{ PARAMETER 4
    [[1, 0, clc$file_type]],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$class_name = 1,
      p$display_option = 2,
      p$group_option = 3,
      p$output = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_job_class;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$display_objects (jmc$profile_job_class, FALSE, pvt [p$class_name],
          pvt [p$display_option], pvt [p$group_option], pvt [p$output],
          status);

  PROCEND jmp$_display_job_class;
?? TITLE := '[XDCL] jmp$_display_job_category', EJECT ??

{ PURPOSE:
{   Processes the DISPLAY_JOB_CATEGORY command for ADMINISTER_SCHEDULING and
{   MANAGE_ACTIVE_SCHEDULING.
{
{ DESIGN:
{   Determine the job categories to display and display them.
{
{ NOTES:
{   See JMM$ADMINISTER_DISPLAY.

  PROCEDURE [XDCL] jmp$_display_job_category
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_disjca) display_job_category (
{   category_name, category_names, cn: any of
{       key all keyend
{       list of name
{     anyend = $current_job_category
{   output, o: (by_name) file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 6] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (21),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 13, 56, 63], clc$command, 6, 3, 0, 0, 0,
            0, 3, 'OSM$MANAS_DISJCA'], [['CATEGORY_NAME                  ',
            clc$nominal_entry, 1], ['CATEGORY_NAMES                 ',
            clc$alias_entry, 1], ['CN                             ',
            clc$abbreviation_entry, 1], ['O                              ',
            clc$abbreviation_entry, 2], ['OUTPUT                         ',
            clc$nominal_entry, 2], ['STATUS                         ',
            clc$nominal_entry, 3]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 21],

{ PARAMETER 2

      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [6, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            '$current_job_category'],

{ PARAMETER 2

      [[1, 0, clc$file_type]],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$category_name = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      ommitted: clt$parameter_value;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_category;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    ommitted.specified := FALSE;
    ommitted.passing_method := clc$pass_by_value;
    ommitted.value := NIL;
    jmp$display_objects (jmc$profile_category, TRUE, pvt [p$category_name],
          ommitted, ommitted, pvt [p$output], status);

  PROCEND jmp$_display_job_category;
?? TITLE := '[XDCL] jmp$_display_job_priority', EJECT ??

{ PURPOSE:
{   Processes the DISPLAY_JOB_PRIORITY command for ADMINISTER_SCHEDULING and
{   MANAGE_ACTIVE_SCHEDULING.
{
{ DESIGN:
{   Determine the job priorities to display and display them.
{
{ NOTES:
{   See JMM$ADMINISTER_DISPLAY.

  PROCEDURE [XDCL] jmp$_display_job_priority
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_disjp) display_job_priority (
{   priority_name, priority_names, pn: any of
{       key all keyend
{       list of name
{     anyend = all
{   output, o: (by_name) file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 6] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (3),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 14, 24, 575], clc$command, 6, 3, 0, 0, 0,
            0, 3, 'OSM$MANAS_DISJP'], [['O                              ',
            clc$abbreviation_entry, 2], ['OUTPUT                         ',
            clc$nominal_entry, 2], ['PN                             ',
            clc$abbreviation_entry, 1], ['PRIORITY_NAME                  ',
            clc$nominal_entry, 1], ['PRIORITY_NAMES                 ',
            clc$alias_entry, 1], ['STATUS                         ',
            clc$nominal_entry, 3]], [

{ PARAMETER 1

      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 3],

{ PARAMETER 2

      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [6, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'all'],

{ PARAMETER 2

      [[1, 0, clc$file_type]],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$priority_name = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      ommitted: clt$parameter_value;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_priority;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    ommitted.specified := FALSE;
    ommitted.passing_method := clc$pass_by_value;
    ommitted.value := NIL;
    jmp$display_objects (jmc$profile_priority, TRUE, pvt [p$priority_name],
          ommitted, ommitted, pvt [p$output], status);

  PROCEND jmp$_display_job_priority;
?? TITLE := '[XDCL] jmp$_display_output_class', EJECT ??

{ PURPOSE:
{   Processes the DISPLAY_ATTRIBUTE command for ADMINISTER_OUTPUT_CLASS and
{   the DISPLAY_OUTPUT_CLASS command for MANAGE_ACTIVE_SCHEDULING.
{
{ DESIGN:
{   Determine the output classes to display and display their attribute values.
{
{ NOTES:
{   See JMM$ADMINISTER_DISPLAY.

  PROCEDURE [XDCL] jmp$_display_output_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_disoc) display_output_class (
{   class_name, class_names, cn: any of
{       key all keyend
{       list of name
{     anyend = $current_output_class
{   display_option, display_options, do: any of
{       key all keyend
{       list of key
{         (abbreviation, a)
{         (delivery_priority, dp)
{         (enable_class_scheduling, ecs)
{         (output_age_interval, oai)
{       hidden_key
{         (definition_name, dn)
{         (output_class_index, oci)
{       keyend
{     anyend = all
{   group_option, group_options, go: any of
{       key all keyend
{       list of key
{         (membership, m), (limit, l), (priority, p)
{         (statistic, s), (definition, d), (control, c)
{       keyend
{     anyend = $optional
{   output, o: (by_name) file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 12] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (21),
        recend,
        type2: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$keyword_type_qualifier,
              keyword_specs: array [1 .. 12] of clt$keyword_specification,
            recend,
          recend,
          default_value: string (3),
        recend,
        type3: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$keyword_type_qualifier,
              keyword_specs: array [1 .. 12] of clt$keyword_specification,
            recend,
          recend,
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 11, 15, 8, 660], clc$command, 12, 5, 0, 0, 0,
            0, 5, 'OSM$MANAS_DISOC'], [['CLASS_NAME                     ',
            clc$nominal_entry, 1], ['CLASS_NAMES                    ',
            clc$alias_entry, 1], ['CN                             ',
            clc$abbreviation_entry, 1], ['DISPLAY_OPTION                 ',
            clc$nominal_entry, 2], ['DISPLAY_OPTIONS                ',
            clc$alias_entry, 2], ['DO                             ',
            clc$abbreviation_entry, 2], ['GO                             ',
            clc$abbreviation_entry, 3], ['GROUP_OPTION                   ',
            clc$nominal_entry, 3], ['GROUP_OPTIONS                  ',
            clc$alias_entry, 3], ['O                              ',
            clc$abbreviation_entry, 4], ['OUTPUT                         ',
            clc$nominal_entry, 4], ['STATUS                         ',
            clc$nominal_entry, 5]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 85,
            clc$optional_default_parameter, 0, 21],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 531,
            clc$optional_default_parameter, 0, 3],

{ PARAMETER 3

      [8, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 531,
            clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [11, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [12, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            '$current_output_class'],

{ PARAMETER 2

      [[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]]], 467,
            [[1, 0, clc$list_type], [451, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [12], [[
            'A                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['ABBREVIATION                   ',
            clc$nominal_entry, clc$normal_usage_entry, 1],
            ['DEFINITION_NAME                ', clc$nominal_entry,
            clc$hidden_entry, 5], ['DELIVERY_PRIORITY              ',
            clc$nominal_entry, clc$normal_usage_entry, 2],
            ['DN                             ', clc$abbreviation_entry,
            clc$hidden_entry, 5], ['DP                             ',
            clc$abbreviation_entry, clc$normal_usage_entry, 2],
            ['ECS                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['ENABLE_CLASS_SCHEDULING        ',
            clc$nominal_entry, clc$normal_usage_entry, 3],
            ['OAI                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['OCI                            ',
            clc$abbreviation_entry, clc$hidden_entry, 6],
            ['OUTPUT_AGE_INTERVAL            ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['OUTPUT_CLASS_INDEX             ',
            clc$nominal_entry, clc$hidden_entry, 6]]]], 'all'],

{ PARAMETER 3

      [[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]]], 467,
            [[1, 0, clc$list_type], [451, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [12], [[
            'C                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['CONTROL                        ',
            clc$nominal_entry, clc$normal_usage_entry, 6],
            ['D                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['DEFINITION                     ',
            clc$nominal_entry, clc$normal_usage_entry, 5],
            ['L                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['LIMIT                          ',
            clc$nominal_entry, clc$normal_usage_entry, 2],
            ['M                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['MEMBERSHIP                     ',
            clc$nominal_entry, clc$normal_usage_entry, 1],
            ['P                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['PRIORITY                       ',
            clc$nominal_entry, clc$normal_usage_entry, 3],
            ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['STATISTIC                      ',
            clc$nominal_entry, clc$normal_usage_entry, 4]]]]],

{ PARAMETER 4

      [[1, 0, clc$file_type]],

{ PARAMETER 5

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$class_name = 1,
      p$display_option = 2,
      p$group_option = 3,
      p$output = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_output_class;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$display_objects (jmc$profile_output_class, FALSE, pvt [p$class_name],
          pvt [p$display_option], pvt [p$group_option], pvt [p$output],
          status);

  PROCEND jmp$_display_output_class;
?? TITLE := '[XDCL] jmp$_display_service_class', EJECT ??

{ PURPOSE:
{   Processes the DISPLAY_ATTRIBUTE command for ADMINISTER_SERVICE_CLASS and
{   the DISPLAY_SERVICE_CLASS command for MANAGE_ACTIVE_SCHEDULING.
{
{ DESIGN:
{   Determine the service classes to display and display their attribute
{   values.
{
{ NOTES:
{   See JMM$ADMINISTER_DISPLAY.

  PROCEDURE [XDCL] jmp$_display_service_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manas_dissc) display_service_class (
{   class_name, class_names, cn: any of
{       key all keyend
{       list of name
{     anyend = $current_service_class
{   display_option, display_options, do: any of
{       key all keyend
{       list of key
{         (abbreviation, a)
{         (active_jobs, aj)
{         (aio_limit, aiol)
{         (class_service_threshold, cst)
{         (dispatching_control, dc)
{         (enable_class_execution, ece)
{         (guaranteed_service_quantum, gsq)
{         (long_wait_think_time, lwtt)
{         (maximum_active_jobs, maxaj)
{         (next_service_class, nsc)
{         (queued_jobs, qj)
{         (scheduling_priority, sp)
{         (service_factors, sf)
{         (swap_age_interval, sai)
{         (swapped_jobs, sj)
{       hidden_key
{         (definition_name, dn)
{         (service_class_index, sci)
{       keyend
{     anyend = all
{   group_option, group_options, go: any of
{       key all keyend
{       list of key
{         (membership, m), (limit, l), (priority, p)
{         (statistic, s), (definition, d), (control, c)
{       keyend
{     anyend = $optional
{   output, o: (by_name) file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 12] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (22),
      recend,
      type2: 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 .. 34] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type3: 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 .. 12] of clt$keyword_specification,
          recend,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 8, 12, 15, 23, 23, 208],
    clc$command, 12, 5, 0, 0, 0, 0, 5, 'OSM$MANAS_DISSC'], [
    ['CLASS_NAME                     ',clc$nominal_entry, 1],
    ['CLASS_NAMES                    ',clc$alias_entry, 1],
    ['CN                             ',clc$abbreviation_entry, 1],
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['GO                             ',clc$abbreviation_entry, 3],
    ['GROUP_OPTION                   ',clc$nominal_entry, 3],
    ['GROUP_OPTIONS                  ',clc$alias_entry, 3],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OUTPUT                         ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 22],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 1345, clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 531, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    '$current_service_class'],
{ PARAMETER 2
    [[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]]
      ],
    1281, [[1, 0, clc$list_type], [1265, 1, clc$max_list_size, 0, FALSE, FALSE]
  ,
        [[1, 0, clc$keyword_type], [34], [
        ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['ABBREVIATION                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['ACTIVE_JOBS                    ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['AIOL                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['AIO_LIMIT                      ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['AJ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['CLASS_SERVICE_THRESHOLD        ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['CST                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['DC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['DEFINITION_NAME                ', clc$nominal_entry,
  clc$hidden_entry, 16],
        ['DISPATCHING_CONTROL            ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['DN                             ', clc$abbreviation_entry,
  clc$hidden_entry, 16],
        ['ECE                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['ENABLE_CLASS_EXECUTION         ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
        ['GSQ                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
        ['GUARANTEED_SERVICE_QUANTUM     ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
        ['LONG_WAIT_THINK_TIME           ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
        ['LWTT                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
        ['MAXAJ                          ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
        ['MAXIMUM_ACTIVE_JOBS            ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
        ['NEXT_SERVICE_CLASS             ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
        ['NSC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
        ['QJ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 11],
        ['QUEUED_JOBS                    ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
        ['SAI                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 14],
        ['SCHEDULING_PRIORITY            ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
        ['SCI                            ', clc$abbreviation_entry,
  clc$hidden_entry, 17],
        ['SERVICE_CLASS_INDEX            ', clc$nominal_entry,
  clc$hidden_entry, 17],
        ['SERVICE_FACTORS                ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
        ['SF                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 13],
        ['SJ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 15],
        ['SP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 12],
        ['SWAPPED_JOBS                   ', clc$nominal_entry,
  clc$normal_usage_entry, 15],
        ['SWAP_AGE_INTERVAL              ', clc$nominal_entry,
  clc$normal_usage_entry, 14]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[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]]
      ],
    467, [[1, 0, clc$list_type], [451, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [12], [
        ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['CONTROL                        ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
        ['D                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['DEFINITION                     ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['LIMIT                          ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['M                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['MEMBERSHIP                     ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['P                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['PRIORITY                       ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['STATISTIC                      ', clc$nominal_entry,
  clc$normal_usage_entry, 4]]
        ]
      ]
    ],
{ PARAMETER 4
    [[1, 0, clc$file_type]],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$class_name = 1,
      p$display_option = 2,
      p$group_option = 3,
      p$output = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    status.normal := TRUE;

    jmv$current_profile_level := jmc$profile_service_class;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    jmp$display_objects (jmc$profile_service_class, FALSE, pvt [p$class_name],
          pvt [p$display_option], pvt [p$group_option], pvt [p$output],
          status);

  PROCEND jmp$_display_service_class;
MODEND jmm$profile_display_commands;
*DECK DECK=JMM$PROGRAM_LEVEL_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE job management program level interfaces' ??
MODULE jmm$program_level_interfaces;

{ Purpose: This module contains the procedures that provide the NOS/VE
{          program level interfaces for Job Management.

?? NEWTITLE := '    Global Declarations Referenced by this Module', EJECT ??

*copyc jmp$manage_sense_switches
*copyc jmv$executing_within_system_job
*copyc jmv$jcb
*copyc jmv$job_class_table_p
*copyc jmv$jmtr_xcb
*copyc jmv$maximum_job_class_in_use
*copyc jmv$max_service_class_in_use
*copyc jmv$service_classes
*copyc osp$get_family_names
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$get_microsecond_clock
*copyc pmp$send_signal
*copyc qfp$get_job_internal_info

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jme$job_scheduler_conditions
*copyc jmk$keypoints
*copyc jmt$clock_time
*copyc jmt$job_class
*copyc jmt$job_class_name
*copyc jmt$job_internal_information
*copyc jmt$job_mode
*copyc jmt$job_system_id
*copyc jmt$sense_switch_signal
*copyc jmt$system_job_parameters
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc pme$program_services_exceptions
*copyc pmk$keypoints
*copyc pmt$family_name_count
*copyc pmt$family_name_list
*copyc pmt$sense_switches
*copyc oss$mainframe_pageable
*copyc oss$mainframe_paged_literal
*copyc ost$date_time
*copyc ost$execution_control_block
*copyc ost$user_identification
*copyc ost$status
*copyc tmc$signal_identifiers
?? POP ??

?? TITLE := '    Global Variables Declared in this Module', EJECT ??

  CONST
    priority_table_size = 15;

  VAR
    priority_table: [STATIC, READ, oss$mainframe_paged_literal] array [1 .. priority_table_size] of record
      dispatching_priority: jmt$dispatching_priority,
      name: string (7),
    recend := [[jmc$null_dispatching_priority, 'DEFAULT'], [jmc$priority_p1, 'P1     '], [jmc$priority_p2,
          'P2     '], [jmc$priority_p3, 'P3     '], [jmc$priority_p4, 'P4     '],
          [jmc$priority_p5, 'P5     '], [jmc$priority_p6, 'P6     '], [jmc$priority_p7, 'P7     '],
          [jmc$priority_p8, 'P8     '], [jmc$priority_p9, 'P9     '], [jmc$priority_p10, 'P10    '],
          [jmc$priority_p11, 'P11    '], [jmc$priority_p12, 'P12    '], [jmc$priority_p13, 'P13    '],
          [jmc$priority_p14, 'P14    ']];

  VAR
    jmv$null_date_time: [XDCL, #GATE, STATIC, READ, oss$mainframe_paged_literal] ost$date_time :=
          [0, 1, 1, 0, 0, 0, 0];
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$convert_date_time_to_clock', EJECT ??
*copy jmh$convert_date_time_to_clock

  PROCEDURE [XDCL, #GATE] jmp$convert_date_time_to_clock
    (    date_time: ost$date_time;
     VAR free_running_clock_value: jmt$clock_time);

    VAR
      days_cummulative_by_month: [STATIC, READ, oss$mainframe_paged_literal] array [1 .. 12] of
            0 .. 366 := [0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334];

    VAR
      number_of_days: integer;

    number_of_days := date_time.year * 365 + ((date_time.year DIV 4) + 1) +
          days_cummulative_by_month [date_time.month] + date_time.day;

    IF ((date_time.year MOD 4) = 0) AND (date_time.month <= 2) THEN
      number_of_days := number_of_days - 1;
    IFEND;

    free_running_clock_value := (((((number_of_days * 24) + date_time.hour) * 60 + date_time.minute) *
          60 + date_time.second) * 1000 + date_time.millisecond) * 1000;
  PROCEND jmp$convert_date_time_to_clock;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$determine_dis_priority', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$determine_dis_priority
    (    name: ost$name;
     VAR dispatching_priority: jmt$dispatching_priority;
     VAR status: ost$status);

    VAR
      i: 1 .. priority_table_size;

    status.normal := TRUE;

    FOR i := 1 TO priority_table_size DO
      IF priority_table [i].name = name THEN
        dispatching_priority := priority_table [i].dispatching_priority;
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal ('JM', jme$invalid_dispatch_priority, ' ', status);

  PROCEND jmp$determine_dis_priority;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$determine_dis_priority_name', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$determine_dis_priority_name
    (    dispatching_priority: jmt$dispatching_priority;
     VAR priority_name: ost$name;
     VAR status: ost$status);

    VAR
      i: 1 .. priority_table_size;

    status.normal := TRUE;
    FOR i := 1 TO priority_table_size DO
      IF priority_table [i].dispatching_priority = dispatching_priority THEN
        priority_name := priority_table [i].name;
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_condition (jme$invalid_dispatch_priority, status);
  PROCEND jmp$determine_dis_priority_name;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$determine_job_class', EJECT ??
*copy jmh$determine_job_class

  PROCEDURE [XDCL, #GATE] jmp$determine_job_class
    (    job_class_name: jmt$job_class_name;
     VAR job_class: jmt$job_class;
     VAR status: ost$status);

    VAR
      class_index: jmt$job_class;

    status.normal := TRUE;

    FOR class_index := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
      IF (job_class_name = jmv$job_class_table_p^ [class_index].name) OR
            (job_class_name = jmv$job_class_table_p^ [class_index].abbreviation) THEN
        IF jmv$job_class_table_p^ [class_index].defined THEN
          job_class := class_index;
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    osp$set_status_condition (jme$job_class_not_defined, status);
  PROCEND jmp$determine_job_class;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$determine_job_class_name', EJECT ??
*copy jmh$determine_job_class_name

  PROCEDURE [XDCL, #GATE] jmp$determine_job_class_name
    (    job_class: jmt$job_class;
     VAR job_class_name: jmt$job_class_name;
     VAR status: ost$status);

    status.normal := TRUE;

    IF jmv$job_class_table_p^ [job_class].defined THEN
      job_class_name := jmv$job_class_table_p^ [job_class].name;
    ELSE
      osp$set_status_condition (jme$job_class_not_defined, status);
    IFEND;

  PROCEND jmp$determine_job_class_name;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$determine_job_class_abbrev', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$determine_job_class_abbrev
    (    job_class: jmt$job_class;
     VAR job_class_abbrev: jmt$job_class_name;
     VAR status: ost$status);

    status.normal := TRUE;

    IF jmv$job_class_table_p^ [job_class].defined THEN
      IF jmv$job_class_table_p^ [job_class].abbreviation <> '                               ' THEN
        job_class_abbrev := jmv$job_class_table_p^ [job_class].abbreviation;
      ELSE
        job_class_abbrev := jmv$job_class_table_p^ [job_class].name;
      IFEND;
    ELSE
      osp$set_status_condition (jme$service_class_not_defined, status);
    IFEND;

  PROCEND jmp$determine_job_class_abbrev;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$determine_service_class', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$determine_service_class
    (    service_class_name: jmt$service_class_name;
     VAR service_class: jmt$service_class_index;
     VAR status: ost$status);

    VAR
      class_index: jmt$service_class_index,
      service_class_p: ^jmt$service_class_entry;

    status.normal := TRUE;

    FOR class_index := jmc$system_service_class TO jmv$max_service_class_in_use DO
      service_class_p := jmv$service_classes [class_index];
      IF (service_class_p <> NIL) AND service_class_p^.attributes.defined THEN
        IF (service_class_name = service_class_p^.attributes.name) OR
              (service_class_name = service_class_p^.attributes.abbreviation) THEN
          service_class := class_index;
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    osp$set_status_condition (jme$service_class_not_defined, status);
  PROCEND jmp$determine_service_class;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$determine_serv_class_name', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$determine_serv_class_name
    (    service_class: jmt$service_class_index;
     VAR service_class_name: jmt$service_class_name;
     VAR status: ost$status);

    VAR
      service_class_p: ^jmt$service_class_entry;

    status.normal := TRUE;

    service_class_p := jmv$service_classes [service_class];
    IF (service_class_p <> NIL) AND service_class_p^.attributes.defined THEN
      service_class_name := service_class_p^.attributes.name;
    ELSE
      osp$set_status_condition (jme$service_class_not_defined, status);
    IFEND;

  PROCEND jmp$determine_serv_class_name;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$determine_serv_class_abbrev', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$determine_serv_class_abbrev
    (    service_class: jmt$service_class_index;
     VAR service_class_abbrev: jmt$service_class_name;
     VAR status: ost$status);

    VAR
      service_class_p: ^jmt$service_class_entry;

    status.normal := TRUE;

    service_class_p := jmv$service_classes [service_class];
    IF (service_class_p <> NIL) AND service_class_p^.attributes.defined THEN
      service_class_abbrev := service_class_p^.attributes.abbreviation;
      IF service_class_abbrev = '                               ' THEN
        service_class_abbrev := service_class_p^.attributes.name;
      IFEND;
    ELSE
      osp$set_status_condition (jme$service_class_not_defined, status);
    IFEND;

  PROCEND jmp$determine_serv_class_abbrev;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$expand_job_class_abbrev', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$expand_job_class_abbrev
    (VAR job_class_name: jmt$job_class_name;
     VAR status: ost$status);

    VAR
      class_index: jmt$job_class;

    status.normal := TRUE;

    FOR class_index := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
      IF (job_class_name = jmv$job_class_table_p^ [class_index].name) OR
            (job_class_name = jmv$job_class_table_p^ [class_index].abbreviation) THEN
        IF jmv$job_class_table_p^ [class_index].defined THEN
          job_class_name := jmv$job_class_table_p^ [class_index].name;
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    osp$set_status_condition (jme$job_class_not_defined, status);
  PROCEND jmp$expand_job_class_abbrev;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_user_identification', EJECT ??
*copy pmh$get_user_identification

  PROCEDURE [XDCL, #GATE] pmp$get_user_identification
    (VAR identification: ost$user_identification;
     VAR status: ost$status);

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, pmk$get_user_identification);

    identification := jmv$jcb.user_id;
    #KEYPOINT (osk$exit, 0, pmk$get_user_identification);
  PROCEND pmp$get_user_identification;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_family_names', EJECT ??
*copy pmh$get_family_names

  PROCEDURE [XDCL, #GATE] pmp$get_family_names
    (VAR family_names: pmt$family_name_list;
     VAR name_count: pmt$family_name_count;
     VAR status: ost$status);

    status.normal := TRUE;

    osp$get_family_names (family_names, name_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF name_count > UPPERBOUND (family_names) THEN
      osp$set_status_abnormal ('PM', pme$result_array_too_small, 'FAMILY_NAMES', status);
    IFEND;
  PROCEND pmp$get_family_names;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_job_monitor_gtid', EJECT ??
*copy pmh$get_job_monitor_gtid

  PROCEDURE [XDCL, #GATE] pmp$get_job_monitor_gtid
    (VAR global_task_id: ost$global_task_id;
     VAR status: ost$status);

    status.normal := TRUE;
    global_task_id := jmv$jcb.job_monitor_id;

  PROCEND pmp$get_job_monitor_gtid;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_job_names', EJECT ??
*copy pmh$get_job_names

  PROCEDURE [XDCL, #GATE] pmp$get_job_names
    (VAR user_supplied_name: jmt$user_supplied_name;
     VAR system_supplied_name: jmt$system_supplied_name;
     VAR status: ost$status);

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, pmk$get_job_names);

    user_supplied_name := jmv$jcb.jobname;
    system_supplied_name := jmv$jcb.system_name;
    #KEYPOINT (osk$exit, 0, pmk$get_job_names);
  PROCEND pmp$get_job_names;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_job_mode', EJECT ??
*copy pmh$get_job_mode

  PROCEDURE [XDCL, #GATE] pmp$get_job_mode
    (VAR mode: jmt$job_mode;
     VAR status: ost$status);

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, pmk$get_job_mode);

    mode := jmv$jcb.ijle_p^.job_mode;
    #KEYPOINT (osk$exit, 0, pmk$get_job_mode);
  PROCEND pmp$get_job_mode;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$manage_sense_switches', EJECT ??
*copy pmh$manage_sense_switches

  PROCEDURE [XDCL, #GATE] pmp$manage_sense_switches
    (    ON: pmt$sense_switches;
         OFF: pmt$sense_switches;
     VAR current: pmt$sense_switches;
     VAR status: ost$status);

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, pmk$manage_sense_switches);

    jmp$manage_sense_switches (ON, OFF);
    current := jmv$jcb.sense_switches;
    #KEYPOINT (osk$exit, 0, pmk$manage_sense_switches);
  PROCEND pmp$manage_sense_switches;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$get_job_internal_info', EJECT ??
*copy jmh$get_job_internal_info

  PROCEDURE [XDCL, #GATE] jmp$get_job_internal_info
    (    system_supplied_name: jmt$system_supplied_name;
     VAR job_internal_info: jmt$job_internal_information;
     VAR status: ost$status);

    status.normal := TRUE;

    qfp$get_job_internal_info (system_supplied_name, job_internal_info, status);
  PROCEND jmp$get_job_internal_info;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$job_monitor_xcb', EJECT ??
*copy jmh$job_monitor_xcb

  FUNCTION [XDCL, #GATE] jmp$job_monitor_xcb: ^ost$execution_control_block;

    jmp$job_monitor_xcb := ^jmv$jmtr_xcb;
  FUNCEND jmp$job_monitor_xcb;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$system_job', EJECT ??
*copy jmh$system_job

  FUNCTION [XDCL, #GATE] jmp$system_job: boolean;

    jmp$system_job := jmv$executing_within_system_job;
  FUNCEND jmp$system_job;


MODEND jmm$program_level_interfaces;
*DECK DECK=JMM$QUEUE_FILE_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management: job management commands' ??
MODULE jmm$queue_file_commands;

{ PURPOSE:
{   This module contains the SCL command processors for the NOS/VE user job
{ management queue file commands.
{
{ DESIGN:
{   The command processors in this module are defined by the queue file
{ management ERS DCS#A6668.  The procedures in this module execute in the
{ callers ring (2DD).

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc cle$ecc_command_processing
*copyc cle$ecc_control_statement
*copyc cle$ecc_parameter_list
*copyc cle$ecc_parsing
*copyc cle$improper_substitution_mark
*copyc cle$unexpected_call_to
*copyc clt$control_statement_info
*copyc clt$file_reference
*copyc clt$input_data_line_header
*copyc clt$when_condition
*copyc jme$job_deleted_via_command
*copyc jme$queued_file_conditions
*copyc jme$operator_queue_backup
*copyc jme$operator_queue_restore
*copyc jme$output_deleted_via_command
*copyc jmt$attribute_keys_set
*copyc jmt$job_state_set
*copyc jmt$job_status_count
*copyc jmt$job_status_options
*copyc jmt$job_status_results
*copyc jmt$job_submission_options
*copyc jmt$job_termination_options
*copyc jmt$name
*copyc jmt$name_list
*copyc jmt$output_status_count
*copyc jmt$output_status_options
*copyc jmt$output_status_results
*copyc jmt$output_submission_options
*copyc jmt$output_termination_options
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc osd$virtual_address
*copyc ost$status
*copyc ost$user_identification
*copyc pmt$sense_switches
?? POP ??
*copyc amp$put_next
*copyc amp$return
*copyc avp$system_administrator
*copyc avp$system_operator
*copyc clp$change_variable
*copyc clp$convert_string_to_file
*copyc clp$evaluate_parameters
*copyc clp$count_list_elements
*copyc clp$find_current_block
*copyc clp$get_command_search_mode
*copyc clp$get_interpreter_mode
*copyc clp$get_type_information
*copyc clp$get_variable
*copyc clp$get_work_area
*copyc clp$prepare_delayed_block
*copyc fsp$close_file
*copyc fsp$copy_data_and_close_files
*copyc fsp$open_file
*copyc jmp$change_input_attributes
*copyc jmp$change_job_attributes
*copyc jmp$change_output_attributes
*copyc jmp$close_files_for_copof
*copyc jmp$convert_name_to_ssn
*copyc jmp$determine_name_kind
*copyc jmp$display_attributes
*copyc jmp$get_attribute_defaults
*copyc jmp$get_attribute_index
*copyc jmp$get_input_attributes
*copyc jmp$get_job_attributes
*copyc jmp$get_job_status
*copyc jmp$get_output_attributes
*copyc jmp$get_output_status
*copyc jmp$get_result_size
*copyc jmp$open_files_for_copof
*copyc jmp$print_file
*copyc jmp$submit_job
*copyc jmp$submit_detached_job
*copyc jmp$switch_command_r3
*copyc jmp$terminate_job
*copyc jmp$terminate_output
*copyc jmp$update_display_message
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$get_status_condition_name
*copyc osp$i_await_activity_completion
*copyc osp$set_status_abnormal
*copyc pmp$get_unique_name
*copyc pmp$get_user_identification
*copyc pmp$manage_sense_switches
*copyc amv$nil_file_identifier
*copyc clv$non_substitution_mark

  CONST
    no_queue_space_wait_time = 300000; { in milliseconds - five minutes

?? TITLE := '[XDCL] jmp$display_job_status', EJECT ??
*copy jmh$display_job_status

  PROCEDURE [XDCL] jmp$display_job_status
    (    file: fst$file_reference;
         display_options: jmt$attribute_keys_set;
         job_names: clt$data_value;
     VAR status: ost$status);

{ This constant represents the maximum number of parameters specified on the
{ command.

    CONST
      maximum_get_keys = 16,
      non_duplicate_hidden_keys = 3;

    TYPE
      jobs_names = record
        system_job_name: jmt$system_supplied_name,
        user_job_name: jmt$user_supplied_name,
      recend;

    VAR
      attribute_key: jmt$attribute_keys,
      display_all_jobs: boolean,
      get_keys: jmt$attribute_keys_set,
      get_key_number: 0 .. maximum_get_keys + non_duplicate_hidden_keys,
      get_key_count: 0 .. maximum_get_keys + non_duplicate_hidden_keys,
      inserted_system_job_name: boolean,
      inserted_user_job_name: boolean,
      job_index: jmt$job_status_count,
      jobs_found: ^array [1 .. * ] of jobs_names,
      key_number: 0 .. maximum_get_keys + non_duplicate_hidden_keys,
      name_count: 0 .. clc$max_list_size,
      name_found: boolean,
      name_list: ^clt$data_value,
      name_number: 0 .. clc$max_list_size,
      not_found_list_p: ^jmt$name_list,
      not_found_list_size: jmt$job_status_count,
      number_of_jobs_found: jmt$job_status_count,
      output_file: clt$file,
      size_of_sequence: ost$segment_length,
      status_options_p: ^jmt$job_status_options,
      status_results_keys_p: ^jmt$results_keys,
      status_results_p: ^jmt$job_status_results,
      status_results_seq: ^SEQ ( * ),
      status_results_work_area_p: ^jmt$work_area,
      user_supplied_name: jmt$user_supplied_name;

?? NEWTITLE := 'add_to_attributes', EJECT ??

    PROCEDURE [INLINE] add_to_attributes
      (    get_attribute_key: jmt$attribute_keys);

      IF get_attribute_key IN get_keys THEN
        get_key_number := get_key_number + 1;
        status_results_keys_p^ [get_key_number] := get_attribute_key;
      IFEND;

    PROCEND add_to_attributes;
?? OLDTITLE ??

    status.normal := TRUE;

{  Process NAME parameter.

    PUSH status_options_p: [1 .. 2];
    status_options_p^ [1].key := jmc$name_list;
    status_options_p^ [1].name_list := NIL;
    status_options_p^ [2].key := jmc$continue_request_to_servers;
    status_options_p^ [2].continue_request_to_servers := TRUE;

    display_all_jobs := FALSE;
    IF job_names.kind = clc$keyword THEN { the only keyword allowed is ALL. }
      status_options_p^ [1].key := jmc$null_attribute;
      display_all_jobs := TRUE;

{ Make a guess at the number of names.  Calls to jmp$get_job_status (found below) will
{ ensure getting 'ALL' jobs.

      name_count := 5;

    ELSEIF job_names.kind = clc$name THEN
      name_count := 1;
      PUSH status_options_p^ [1].name_list: [1 .. name_count];
      jmp$determine_name_kind (job_names.name_value, status_options_p^ [1].name_list^ [1], status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    ELSE
      name_list := ^job_names;
      name_count := clp$count_list_elements (name_list);
      PUSH status_options_p^ [1].name_list: [1 .. name_count];
      FOR name_number := 1 TO name_count DO
        jmp$determine_name_kind (name_list^.element_value^.name_value, status_options_p^ [1].
              name_list^ [name_number], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        name_list := name_list^.link;
      FOREND;
    IFEND;

    get_key_number := 0;
    get_key_count := 0;

    get_keys := display_options;
    IF NOT display_all_jobs THEN
      inserted_system_job_name := NOT (jmc$system_job_name IN get_keys);
      inserted_user_job_name := NOT (jmc$user_job_name IN get_keys);
      get_keys := get_keys + $jmt$attribute_keys_set [jmc$user_job_name, jmc$system_job_name];
    IFEND;

    FOR attribute_key := LOWERVALUE (attribute_key) TO UPPERVALUE (attribute_key) DO
      IF attribute_key IN get_keys THEN
        get_key_count := get_key_count + 1;
      IFEND;
    FOREND;

    PUSH status_results_keys_p: [1 .. get_key_count];
    add_to_attributes (jmc$client_mainframe_id);
    add_to_attributes (jmc$control_family);
    add_to_attributes (jmc$control_user);
    add_to_attributes (jmc$cpu_time_used);
    add_to_attributes (jmc$display_message);
    add_to_attributes (jmc$input_file_location);
    add_to_attributes (jmc$job_class);
    add_to_attributes (jmc$job_class_position);
    add_to_attributes (jmc$job_destination_usage);
    add_to_attributes (jmc$job_initiation_time);
    add_to_attributes (jmc$job_mode);
    add_to_attributes (jmc$job_state);
    add_to_attributes (jmc$login_family);
    add_to_attributes (jmc$login_user);
    add_to_attributes (jmc$operator_action_posted);
    add_to_attributes (jmc$page_faults);
    add_to_attributes (jmc$server_mainframe_id);
    add_to_attributes (jmc$system_job_name);
    add_to_attributes (jmc$user_job_name);

    jmp$get_result_size (name_count * 2, #SEQ (status_results_keys_p^), size_of_sequence);
    PUSH status_results_work_area_p: [[REP size_of_sequence OF cell]];

    jmp$get_job_status (status_options_p, status_results_keys_p, status_results_work_area_p, status_results_p,
          number_of_jobs_found, status);

    WHILE (NOT status.normal) AND (status.condition = jme$work_area_too_small) DO
      status.normal := TRUE;
      jmp$get_result_size (number_of_jobs_found + 1, #SEQ (status_results_keys_p^), size_of_sequence);
      PUSH status_results_work_area_p: [[REP size_of_sequence OF cell]];
      jmp$get_job_status (status_options_p, status_results_keys_p, status_results_work_area_p,
            status_results_p, number_of_jobs_found, status);
    WHILEND;

    IF NOT status.normal THEN
      IF status.condition = jme$no_jobs_were_found THEN
        number_of_jobs_found := 0;
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

{ Build a list of the job names that were not found.

    not_found_list_size := 0;

    IF NOT display_all_jobs THEN
      PUSH not_found_list_p: [1 .. name_count];

      IF number_of_jobs_found > 0 THEN
        PUSH jobs_found: [1 .. number_of_jobs_found];
        FOR job_index := 1 TO number_of_jobs_found DO
          FOR key_number := 1 TO UPPERBOUND (status_results_p^ [job_index]^) DO
            IF status_results_p^ [job_index]^ [key_number].key = jmc$system_job_name THEN
              jobs_found^ [job_index].system_job_name := status_results_p^ [job_index]^ [key_number].
                    system_job_name;
              IF inserted_system_job_name THEN
                status_results_p^ [job_index]^ [key_number].key := jmc$null_attribute;
              IFEND;
            ELSEIF status_results_p^ [job_index]^ [key_number].key = jmc$user_job_name THEN
              jobs_found^ [job_index].user_job_name := status_results_p^ [job_index]^ [key_number].
                    user_job_name;
              IF inserted_user_job_name THEN
                status_results_p^ [job_index]^ [key_number].key := jmc$null_attribute;
              IFEND;
            IFEND;
          FOREND;
        FOREND;
      IFEND;

      FOR name_number := 1 TO name_count DO
        name_found := FALSE;
        IF status_options_p^ [1].name_list^ [name_number].kind = jmc$system_supplied_name THEN
          job_index := 1;
          WHILE NOT name_found AND (job_index <= number_of_jobs_found) DO
            name_found := (status_options_p^ [1].name_list^ [name_number].
                  system_supplied_name = jobs_found^ [job_index].system_job_name);
            job_index := job_index + 1;
          WHILEND;
        ELSE
          job_index := 1;
          WHILE NOT name_found AND (job_index <= number_of_jobs_found) DO
            name_found := (status_options_p^ [1].name_list^ [name_number].
                  user_supplied_name = jobs_found^ [job_index].user_job_name);
            job_index := job_index + 1;
          WHILEND;
        IFEND;
        IF NOT name_found THEN
          not_found_list_size := not_found_list_size + 1;
          not_found_list_p^ [not_found_list_size] := status_options_p^ [1].name_list^ [name_number];
        IFEND;
      FOREND;
    IFEND;

    IF not_found_list_size = 0 THEN
      not_found_list_p := NIL;
    IFEND;

    status_results_seq := #SEQ (status_results_p);

{  Process OUTPUT parameter.

    clp$convert_string_to_file (file, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$display_attributes (status_results_seq, number_of_jobs_found, NIL, not_found_list_p,
          not_found_list_size, output_file, 'display_job_status', status);

  PROCEND jmp$display_job_status;
?? TITLE := '[XDCL] jmp$jobend_statement', EJECT ??

  PROCEDURE [XDCL] jmp$jobend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);


    osp$set_status_abnormal ('CL', cle$unexpected_control_statemnt, 'JOBEND', status);

  PROCEND jmp$jobend_statement;
?? TITLE := '[XDCL] jmp$_change_input_attribute', EJECT ??

  PROCEDURE [XDCL] jmp$_change_input_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (osm$chaia) change_input_attribute, change_input_attributes, cha..
{ ia (
{    name, names, n: list of name = $required
{    comment_banner, cb: string 0..jmc$output_comment_banner_size = $optional
{    copies, c: integer 1..jmc$output_copy_count_max = $optional
{    cpu_time_limit, ctl: any of
{        key
{          system_default, unlimited, unspecified
{        keyend
{        integer jmc$lowest_cpu_time_limit..jmc$highest_cpu_time_limit
{      anyend = $optional
{    device, d: any of
{        key
{          automatic
{        keyend
{        name
{      anyend = $optional
{    earliest_print_time, ept: any of
{        key
{          none
{        keyend
{        date_time
{      anyend = $optional
{    earliest_run_time, ert: any of
{        key
{          none
{        keyend
{        date_time
{      anyend = $optional
{    external_characteristics, ec: any of
{        key
{          normal
{        keyend
{        string 0..jmc$ext_characteristics_size
{      anyend = $optional
{    forms_code, fc: any of
{        key
{          normal
{        keyend
{        string 0..jmc$forms_code_size
{      anyend = $optional
{    job_abort_disposition, jad: key
{        (restart, r)
{        (terminate, t)
{      keyend = $optional
{    job_class, jc: name = $optional
{    job_deferred_by_operator, jdbo: boolean = $optional
{    job_deferred_by_user, jdbu: boolean = $optional
{    job_qualifier, job_qualifiers, jq: any of
{        key
{          none, system_default
{        keyend
{        list 1..jmc$maximum_job_qualifiers of name
{      anyend = $optional
{    job_recovery_disposition, jrd: key
{        (continue, c)
{        (restart, r)
{        (terminate, t)
{      keyend = $optional
{    latest_print_time, lpt: any of
{        key
{          none
{        keyend
{        date_time
{      anyend = $optional
{    latest_run_time, lrt: any of
{        key
{          none
{        keyend
{        date_time
{      anyend = $optional
{    login_account, la: any of
{        key
{          unspecified
{        keyend
{        name
{      anyend = $optional
{    login_project, lp: any of
{        key
{          unspecified
{        keyend
{        name
{      anyend = $optional
{    magnetic_tape_limit, mtl: any of
{        key
{          system_default, unlimited, unspecified
{        keyend
{        integer jmc$lowest_magnetic_tape_limit..jmc$highest_magnetic_tape_li..
{ mit
{      anyend = $optional
{    maximum_working_set, maxws: any of
{        key
{          system_default, unlimited, unspecified
{        keyend
{        integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{      anyend = $optional
{    operator_family, of: name = $optional
{    operator_user, ou: name = $optional
{    output_class, oc: key
{        normal
{      keyend = $optional
{    output_deferred_by_user, odbu: boolean = $optional
{    output_destination, ode: any of
{        string 0..osc$max_name_size
{        name
{      anyend = $optional
{    output_destination_usage, odu: any of
{        key
{          dual_state, ntf, private, public, qtf
{        keyend
{        name
{      anyend = $optional
{    output_disposition, odi: any of
{        key
{          (discard_all_output, dao)
{          (discard_standard_output, dso)
{          (local, l)
{          (printer, p)
{          (wait_queue, wt, wq)
{        keyend
{        file
{      anyend = $optional
{    output_priority, op: key
{        low, medium, high
{      keyend = $optional
{    purge_delay, pd: any of
{        key
{          none
{        keyend
{        time_increment
{      anyend = $optional
{    remote_host_directive, rhd: string 0..jmc$remote_host_directive_size = $..
{ optional
{    routing_banner, rb: string 0..jmc$output_routing_banner_size = $optional
{    site_information, si: (BY_NAME, ADVANCED) string 0..jmc$site_information..
{ _size = $optional
{    sru_limit, sl: any of
{        key
{          system_default, unlimited, unspecified
{        keyend
{        integer jmc$lowest_sru_limit..jmc$highest_sru_limit
{      anyend = $optional
{    station, s: any of
{        key
{          automatic
{        keyend
{        name
{      anyend = $optional
{    user_information, ui: string 0..jmc$user_information_size = $optional
{    user_job_name, ujn: name = $optional
{    vertical_print_density, vpd: key
{        six, eight, none, file
{      keyend = $optional
{    vfu_load_procedure, vlp: any of
{        key
{          none
{        keyend
{        name
{      anyend = $optional
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 81] of clt$pdt_parameter_name,
      parameters: array [1 .. 40] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type5: 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$name_type_qualifier,
        recend,
      recend,
      type6: 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$date_time_type_qualifier,
        recend,
      recend,
      type7: 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$date_time_type_qualifier,
        recend,
      recend,
      type8: 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$string_type_qualifier,
        recend,
      recend,
      type9: 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$string_type_qualifier,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type12: record
        header: clt$type_specification_header,
      recend,
      type13: record
        header: clt$type_specification_header,
      recend,
      type14: 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 .. 2] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type15: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type16: 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$date_time_type_qualifier,
        recend,
      recend,
      type17: 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$date_time_type_qualifier,
        recend,
      recend,
      type18: 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$name_type_qualifier,
        recend,
      recend,
      type19: 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$name_type_qualifier,
        recend,
      recend,
      type20: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type21: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type22: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type23: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type24: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 1] of clt$keyword_specification,
      recend,
      type25: record
        header: clt$type_specification_header,
      recend,
      type26: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type27: 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 .. 5] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type28: 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 .. 11] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type29: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      type30: 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,
        recend,
      recend,
      type31: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type32: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type33: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type34: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type35: 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$name_type_qualifier,
        recend,
      recend,
      type36: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type37: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type38: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type39: 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$name_type_qualifier,
        recend,
      recend,
      type40: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 23, 9, 7, 53, 391],
    clc$command, 81, 40, 1, 1, 0, 0, 40, 'OSM$CHAIA'], [
    ['C                              ',clc$abbreviation_entry, 3],
    ['CB                             ',clc$abbreviation_entry, 2],
    ['COMMENT_BANNER                 ',clc$nominal_entry, 2],
    ['COPIES                         ',clc$nominal_entry, 3],
    ['CPU_TIME_LIMIT                 ',clc$nominal_entry, 4],
    ['CTL                            ',clc$abbreviation_entry, 4],
    ['D                              ',clc$abbreviation_entry, 5],
    ['DEVICE                         ',clc$nominal_entry, 5],
    ['EARLIEST_PRINT_TIME            ',clc$nominal_entry, 6],
    ['EARLIEST_RUN_TIME              ',clc$nominal_entry, 7],
    ['EC                             ',clc$abbreviation_entry, 8],
    ['EPT                            ',clc$abbreviation_entry, 6],
    ['ERT                            ',clc$abbreviation_entry, 7],
    ['EXTERNAL_CHARACTERISTICS       ',clc$nominal_entry, 8],
    ['FC                             ',clc$abbreviation_entry, 9],
    ['FORMS_CODE                     ',clc$nominal_entry, 9],
    ['JAD                            ',clc$abbreviation_entry, 10],
    ['JC                             ',clc$abbreviation_entry, 11],
    ['JDBO                           ',clc$abbreviation_entry, 12],
    ['JDBU                           ',clc$abbreviation_entry, 13],
    ['JOB_ABORT_DISPOSITION          ',clc$nominal_entry, 10],
    ['JOB_CLASS                      ',clc$nominal_entry, 11],
    ['JOB_DEFERRED_BY_OPERATOR       ',clc$nominal_entry, 12],
    ['JOB_DEFERRED_BY_USER           ',clc$nominal_entry, 13],
    ['JOB_QUALIFIER                  ',clc$nominal_entry, 14],
    ['JOB_QUALIFIERS                 ',clc$alias_entry, 14],
    ['JOB_RECOVERY_DISPOSITION       ',clc$nominal_entry, 15],
    ['JQ                             ',clc$abbreviation_entry, 14],
    ['JRD                            ',clc$abbreviation_entry, 15],
    ['LA                             ',clc$abbreviation_entry, 18],
    ['LATEST_PRINT_TIME              ',clc$nominal_entry, 16],
    ['LATEST_RUN_TIME                ',clc$nominal_entry, 17],
    ['LOGIN_ACCOUNT                  ',clc$nominal_entry, 18],
    ['LOGIN_PROJECT                  ',clc$nominal_entry, 19],
    ['LP                             ',clc$abbreviation_entry, 19],
    ['LPT                            ',clc$abbreviation_entry, 16],
    ['LRT                            ',clc$abbreviation_entry, 17],
    ['MAGNETIC_TAPE_LIMIT            ',clc$nominal_entry, 20],
    ['MAXIMUM_WORKING_SET            ',clc$nominal_entry, 21],
    ['MAXWS                          ',clc$abbreviation_entry, 21],
    ['MTL                            ',clc$abbreviation_entry, 20],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['OC                             ',clc$abbreviation_entry, 24],
    ['ODBU                           ',clc$abbreviation_entry, 25],
    ['ODE                            ',clc$abbreviation_entry, 26],
    ['ODI                            ',clc$abbreviation_entry, 28],
    ['ODU                            ',clc$abbreviation_entry, 27],
    ['OF                             ',clc$abbreviation_entry, 22],
    ['OP                             ',clc$abbreviation_entry, 29],
    ['OPERATOR_FAMILY                ',clc$nominal_entry, 22],
    ['OPERATOR_USER                  ',clc$nominal_entry, 23],
    ['OU                             ',clc$abbreviation_entry, 23],
    ['OUTPUT_CLASS                   ',clc$nominal_entry, 24],
    ['OUTPUT_DEFERRED_BY_USER        ',clc$nominal_entry, 25],
    ['OUTPUT_DESTINATION             ',clc$nominal_entry, 26],
    ['OUTPUT_DESTINATION_USAGE       ',clc$nominal_entry, 27],
    ['OUTPUT_DISPOSITION             ',clc$nominal_entry, 28],
    ['OUTPUT_PRIORITY                ',clc$nominal_entry, 29],
    ['PD                             ',clc$abbreviation_entry, 30],
    ['PURGE_DELAY                    ',clc$nominal_entry, 30],
    ['RB                             ',clc$abbreviation_entry, 32],
    ['REMOTE_HOST_DIRECTIVE          ',clc$nominal_entry, 31],
    ['RHD                            ',clc$abbreviation_entry, 31],
    ['ROUTING_BANNER                 ',clc$nominal_entry, 32],
    ['S                              ',clc$abbreviation_entry, 35],
    ['SI                             ',clc$abbreviation_entry, 33],
    ['SITE_INFORMATION               ',clc$nominal_entry, 33],
    ['SL                             ',clc$abbreviation_entry, 34],
    ['SRU_LIMIT                      ',clc$nominal_entry, 34],
    ['STATION                        ',clc$nominal_entry, 35],
    ['STATUS                         ',clc$nominal_entry, 40],
    ['UI                             ',clc$abbreviation_entry, 36],
    ['UJN                            ',clc$abbreviation_entry, 37],
    ['USER_INFORMATION               ',clc$nominal_entry, 36],
    ['USER_JOB_NAME                  ',clc$nominal_entry, 37],
    ['VERTICAL_PRINT_DENSITY         ',clc$nominal_entry, 38],
    ['VFU_LOAD_PROCEDURE             ',clc$nominal_entry, 39],
    ['VLP                            ',clc$abbreviation_entry, 39],
    ['VPD                            ',clc$abbreviation_entry, 38]],
    [
{ PARAMETER 1
    [43, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 21, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 158, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 72, clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 72, clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 13
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 14
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 122, clc$optional_parameter, 0, 0],
{ PARAMETER 15
    [27, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_parameter, 0, 0],
{ PARAMETER 16
    [31, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [32, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 18
    [33, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 19
    [34, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 20
    [38, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 158, clc$optional_parameter, 0, 0],
{ PARAMETER 21
    [39, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 158, clc$optional_parameter, 0, 0],
{ PARAMETER 22
    [52, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 23
    [53, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 24
    [55, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 44, clc$optional_parameter, 0, 0],
{ PARAMETER 25
    [56, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 26
    [57, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 27
    [58, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 217, clc$optional_parameter, 0, 0],
{ PARAMETER 28
    [59, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 437, clc$optional_parameter, 0, 0],
{ PARAMETER 29
    [60, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 118, clc$optional_parameter, 0, 0],
{ PARAMETER 30
    [62, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 31
    [64, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 32
    [66, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 33
    [69, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 34
    [71, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 158, clc$optional_parameter, 0, 0],
{ PARAMETER 35
    [72, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 36
    [76, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 37
    [77, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 38
    [78, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],
{ PARAMETER 39
    [79, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 40
    [73, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$string_type], [0, jmc$output_comment_banner_size, FALSE]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, jmc$output_copy_count_max, 10]],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_cpu_time_limit,
  jmc$highest_cpu_time_limit, 10]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['AUTOMATIC                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$date_time_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time
  ], $clt$date_time_tenses [clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$date_time_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time
  ], $clt$date_time_tenses [clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$string_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NORMAL                         ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [0, jmc$ext_characteristics_size, FALSE]]
    ],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$string_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NORMAL                         ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [0, jmc$forms_code_size, FALSE]]
    ],
{ PARAMETER 10
    [[1, 0, clc$keyword_type], [4], [
    ['R                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['RESTART                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 11
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 12
    [[1, 0, clc$boolean_type]],
{ PARAMETER 13
    [[1, 0, clc$boolean_type]],
{ PARAMETER 14
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, jmc$maximum_job_qualifiers, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 15
    [[1, 0, clc$keyword_type], [6], [
    ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['CONTINUE                       ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['R                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['RESTART                        ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['T                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['TERMINATE                      ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 16
    [[1, 0, clc$union_type], [[clc$date_time_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time
  ], $clt$date_time_tenses [clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 17
    [[1, 0, clc$union_type], [[clc$date_time_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time
  ], $clt$date_time_tenses [clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 18
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['UNSPECIFIED                    ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 19
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['UNSPECIFIED                    ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 20
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_magnetic_tape_limit,
  jmc$highest_magnetic_tape_limit, 10]]
    ],
{ PARAMETER 21
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
  jmc$highest_working_set_size, 10]]
    ],
{ PARAMETER 22
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 23
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 24
    [[1, 0, clc$keyword_type], [1], [
    ['NORMAL                         ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 25
    [[1, 0, clc$boolean_type]],
{ PARAMETER 26
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 27
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    192, [[1, 0, clc$keyword_type], [5], [
      ['DUAL_STATE                     ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NTF                            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['PRIVATE                        ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['PUBLIC                         ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['QTF                            ', clc$nominal_entry,
  clc$normal_usage_entry, 5]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 28
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    414, [[1, 0, clc$keyword_type], [11], [
      ['DAO                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
      ['DISCARD_ALL_OUTPUT             ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['DISCARD_STANDARD_OUTPUT        ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['DSO                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
      ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
      ['LOCAL                          ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['P                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
      ['PRINTER                        ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['WAIT_QUEUE                     ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
      ['WQ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
      ['WT                             ', clc$alias_entry,
  clc$normal_usage_entry, 5]]
      ],
    3, [[1, 0, clc$file_type]]
    ],
{ PARAMETER 29
    [[1, 0, clc$keyword_type], [3], [
    ['HIGH                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['LOW                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['MEDIUM                         ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 30
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$time_increment_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$time_increment_type]]
    ],
{ PARAMETER 31
    [[1, 0, clc$string_type], [0, jmc$remote_host_directive_size, FALSE]],
{ PARAMETER 32
    [[1, 0, clc$string_type], [0, jmc$output_routing_banner_size, FALSE]],
{ PARAMETER 33
    [[1, 0, clc$string_type], [0, jmc$site_information_size, FALSE]],
{ PARAMETER 34
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_sru_limit, jmc$highest_sru_limit
  , 10]]
    ],
{ PARAMETER 35
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['AUTOMATIC                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 36
    [[1, 0, clc$string_type], [0, jmc$user_information_size, FALSE]],
{ PARAMETER 37
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 38
    [[1, 0, clc$keyword_type], [4], [
    ['EIGHT                          ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['FILE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['SIX                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 39
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 40
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$comment_banner = 2,
      p$copies = 3,
      p$cpu_time_limit = 4,
      p$device = 5,
      p$earliest_print_time = 6,
      p$earliest_run_time = 7,
      p$external_characteristics = 8,
      p$forms_code = 9,
      p$job_abort_disposition = 10,
      p$job_class = 11,
      p$job_deferred_by_operator = 12,
      p$job_deferred_by_user = 13,
      p$job_qualifier = 14,
      p$job_recovery_disposition = 15,
      p$latest_print_time = 16,
      p$latest_run_time = 17,
      p$login_account = 18,
      p$login_project = 19,
      p$magnetic_tape_limit = 20,
      p$maximum_working_set = 21,
      p$operator_family = 22,
      p$operator_user = 23,
      p$output_class = 24,
      p$output_deferred_by_user = 25,
      p$output_destination = 26,
      p$output_destination_usage = 27,
      p$output_disposition = 28,
      p$output_priority = 29,
      p$purge_delay = 30,
      p$remote_host_directive = 31,
      p$routing_banner = 32,
      p$site_information = 33,
      p$sru_limit = 34,
      p$station = 35,
      p$user_information = 36,
      p$user_job_name = 37,
      p$vertical_print_density = 38,
      p$vfu_load_procedure = 39,
      p$status = 40;

    VAR
      pvt: array [1 .. 40] of clt$parameter_value;

    CONST
      max_input_attfributes = p$vfu_load_procedure;

    VAR
      default_job_attributes_p: ^jmt$default_attribute_results,
      index: 1 .. p$status,
      input_attribute_changes: ^jmt$input_attribute_changes,
      input_attribute_index: 0 .. p$status - 2,
      job_qualifier_count: 0 .. clc$max_list_size,
      job_qualifier_index: 1 .. jmc$maximum_job_qualifiers,
      list_count: 0 .. clc$max_list_size,
      name_list: ^clt$data_value,
      number_of_input_attributes: 0 .. max_input_attfributes,
      qualifier_options: ^clt$data_value,
      valid_name: jmt$name;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    input_attribute_changes := NIL;
    input_attribute_index := 0;
    number_of_input_attributes := 0;

    FOR index := p$comment_banner TO p$vfu_load_procedure DO
      CASE pvt [index].passing_method OF
      = clc$pass_by_value =
        IF pvt [index].value <> NIL THEN
          number_of_input_attributes := number_of_input_attributes + 1;
        IFEND;
      = clc$pass_by_reference =
        IF pvt [index].variable <> NIL THEN
          number_of_input_attributes := number_of_input_attributes + 1;
        IFEND;
      CASEND;
    FOREND;

    IF number_of_input_attributes <> 0 THEN
      PUSH input_attribute_changes: [1 .. number_of_input_attributes];
    IFEND;

{  Process COMMENT_BANNER parameter.

    IF pvt [p$comment_banner].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$comment_banner;
      input_attribute_changes^ [input_attribute_index].comment_banner :=
            pvt [p$comment_banner].value^.string_value^;
    IFEND;

{  Process COPIES parameter.

    IF pvt [p$copies].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$copies;
      input_attribute_changes^ [input_attribute_index].copies := pvt [p$copies].value^.integer_value.value;
    IFEND;

{  Process CPU_TIME_LIMIT parameter.

    IF pvt [p$cpu_time_limit].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$cpu_time_limit;
      IF pvt [p$cpu_time_limit].value^.kind = clc$integer THEN
        input_attribute_changes^ [input_attribute_index].cpu_time_limit :=
              pvt [p$cpu_time_limit].value^.integer_value.value;
      ELSE
        IF pvt [p$cpu_time_limit].value^.keyword_value = 'UNSPECIFIED' THEN
          input_attribute_changes^ [input_attribute_index].cpu_time_limit := jmc$unspecified_cpu_time_limit;
        ELSEIF pvt [p$cpu_time_limit].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
          input_attribute_changes^ [input_attribute_index].cpu_time_limit := jmc$system_default_cpu_time_lim;
        ELSE { pvt [p$cpu_time_limit].value^.keyword_value = 'UNLIMITED'.
          input_attribute_changes^ [input_attribute_index].cpu_time_limit := jmc$unlimited_cpu_time_limit;
        IFEND;
      IFEND;
    IFEND;

{  Process DEVICE parameter.

    IF pvt [p$device].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$device;
      IF pvt [p$device].value^.kind = clc$name THEN
        input_attribute_changes^ [input_attribute_index].device := pvt [p$device].value^.name_value;
      ELSE
        input_attribute_changes^ [input_attribute_index].device := pvt [p$device].value^.keyword_value;
      IFEND;
    IFEND;

{  Process EARLIEST_PRINT_TIME parameter.

    IF pvt [p$earliest_print_time].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$earliest_print_time;
      IF pvt [p$earliest_print_time].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        input_attribute_changes^ [input_attribute_index].earliest_print_time.specified := FALSE;
      ELSE
        input_attribute_changes^ [input_attribute_index].earliest_print_time.specified := TRUE;
        input_attribute_changes^ [input_attribute_index].earliest_print_time.date_time :=
              pvt [p$earliest_print_time].value^.date_time_value.value;
      IFEND;
    IFEND;

{  Process EARLIEST_RUN_TIME parameter.

    IF pvt [p$earliest_run_time].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$earliest_run_time;
      IF pvt [p$earliest_run_time].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        input_attribute_changes^ [input_attribute_index].earliest_run_time.specified := FALSE;
      ELSE
        input_attribute_changes^ [input_attribute_index].earliest_run_time.specified := TRUE;
        input_attribute_changes^ [input_attribute_index].earliest_run_time.date_time :=
              pvt [p$earliest_run_time].value^.date_time_value.value;
      IFEND;
    IFEND;

{  Process EXTERNAL_CHARACTERISTICS parameter.

    IF pvt [p$external_characteristics].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$external_characteristics;
      IF pvt [p$external_characteristics].value^.kind = clc$keyword THEN { the only keyword is NORMAL. }
        input_attribute_changes^ [input_attribute_index].external_characteristics :=
              pvt [p$external_characteristics].value^.keyword_value;
      ELSE
        input_attribute_changes^ [input_attribute_index].external_characteristics :=
              pvt [p$external_characteristics].value^.string_value^;
      IFEND;
    IFEND;

{  Process FORMS_CODE parameter.

    IF pvt [p$forms_code].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$forms_code;
      IF pvt [p$forms_code].value^.kind = clc$keyword THEN { the only keyword allowed is NORMAL. }
        input_attribute_changes^ [input_attribute_index].forms_code := pvt [p$forms_code].value^.
              keyword_value;
      ELSE
        input_attribute_changes^ [input_attribute_index].forms_code := pvt [p$forms_code].value^.
              string_value^;
      IFEND;
    IFEND;

{  Process JOB_ABORT_DISPOSITION parameter.

    IF pvt [p$job_abort_disposition].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$job_abort_disposition;
      IF pvt [p$job_abort_disposition].value^.keyword_value = 'RESTART' THEN
        input_attribute_changes^ [input_attribute_index].job_abort_disposition := jmc$restart_on_abort;
      ELSE { TERMINATE is the only other choice. }
        input_attribute_changes^ [input_attribute_index].job_abort_disposition := jmc$terminate_on_abort;
      IFEND;
    IFEND;

{ Process JOB_CLASS parameter.

    IF pvt [p$job_class].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$job_class;
      input_attribute_changes^ [input_attribute_index].job_class := pvt [p$job_class].value^.name_value;
    IFEND;

{  Process JOB_DEFERRED_BY_OPERATOR parameter.

    IF pvt [p$job_deferred_by_operator].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$job_deferred_by_operator;
      input_attribute_changes^ [input_attribute_index].job_deferred_by_operator :=
            pvt [p$job_deferred_by_operator].value^.boolean_value.value;
    IFEND;

{  Process JOB_DEFERRED_BY_USER parameter.

    IF pvt [p$job_deferred_by_user].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$job_deferred_by_user;
      input_attribute_changes^ [input_attribute_index].job_deferred_by_user :=
            pvt [p$job_deferred_by_user].value^.boolean_value.value;
    IFEND;

{  Process JOB_QUALIFIER parameter.

    IF pvt [p$job_qualifier].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$job_qualifier_list;
      IF pvt [p$job_qualifier].value^.kind = clc$keyword THEN
        IF pvt [p$job_qualifier].value^.keyword_value = 'NONE' THEN
          PUSH input_attribute_changes^ [input_attribute_index].job_qualifier_list: [1 .. 1];
          input_attribute_changes^ [input_attribute_index].job_qualifier_list^ [1] := osc$null_name;
        ELSE { keyword_value = 'SYSTEM_DEFAULT'}
          PUSH default_job_attributes_p: [1 .. 1];
          default_job_attributes_p^ [1].key := jmc$job_qualifier_list;
          PUSH input_attribute_changes^ [input_attribute_index].job_qualifier_list:
                [1 .. jmc$maximum_job_qualifiers];
          default_job_attributes_p^ [1].job_qualifier_list :=
                input_attribute_changes^ [input_attribute_index].job_qualifier_list;

{  Input attributes can be changed only for batch jobs.

          jmp$get_attribute_defaults (jmc$batch, default_job_attributes_p, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      ELSE
        list_count := clp$count_list_elements (pvt [p$job_qualifier].value);
        PUSH input_attribute_changes^ [input_attribute_index].job_qualifier_list: [1 .. list_count];
        qualifier_options := pvt [p$job_qualifier].value;
        FOR index := 1 TO list_count DO
          input_attribute_changes^ [input_attribute_index].job_qualifier_list^ [index] :=
                qualifier_options^.element_value^.name_value;
          qualifier_options := qualifier_options^.link;
        FOREND;
      IFEND;
    IFEND;

{  Process JOB_RECOVERY_DISPOSITION parameter.

    IF pvt [p$job_recovery_disposition].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$job_recovery_disposition;
      IF pvt [p$job_recovery_disposition].value^.keyword_value = 'RESTART' THEN
        input_attribute_changes^ [input_attribute_index].job_recovery_disposition := jmc$restart_on_recovery;
      ELSEIF pvt [p$job_recovery_disposition].value^.keyword_value = 'CONTINUE' THEN
        input_attribute_changes^ [input_attribute_index].job_recovery_disposition := jmc$continue_on_recovery;
      ELSE { pvt [p$job_recovery_disposition].value^.keyword_value = 'TERMINATE'.
        input_attribute_changes^ [input_attribute_index].job_recovery_disposition :=
              jmc$terminate_on_recovery;
      IFEND;
    IFEND;

{  Process LATEST_PRINT_TIME parameter.

    IF pvt [p$latest_print_time].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$latest_print_time;
      IF pvt [p$latest_print_time].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        input_attribute_changes^ [input_attribute_index].latest_print_time.specified := FALSE;
      ELSE
        input_attribute_changes^ [input_attribute_index].latest_print_time.specified := TRUE;
        input_attribute_changes^ [input_attribute_index].latest_print_time.date_time :=
              pvt [p$latest_print_time].value^.date_time_value.value;
      IFEND;
    IFEND;

{  Process LATEST_RUN_TIME parameter.

    IF pvt [p$latest_run_time].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$latest_run_time;
      IF pvt [p$latest_run_time].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        input_attribute_changes^ [input_attribute_index].latest_run_time.specified := FALSE;
      ELSE
        input_attribute_changes^ [input_attribute_index].latest_run_time.specified := TRUE;
        input_attribute_changes^ [input_attribute_index].latest_run_time.date_time :=
              pvt [p$latest_run_time].value^.date_time_value.value;
      IFEND;
    IFEND;

{  Process LOGIN_ACCOUNT parameter.

    IF pvt [p$login_account].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$login_account;
      IF pvt [p$login_account].value^.kind = clc$name THEN
        input_attribute_changes^ [input_attribute_index].login_account :=
              pvt [p$login_account].value^.name_value;
      ELSE { kind = clc$keyword.
        IF pvt [p$login_account].value^.keyword_value = 'UNSPECIFIED' THEN
          input_attribute_changes^ [input_attribute_index].login_account := osc$null_name;
        ELSE
          input_attribute_changes^ [input_attribute_index].login_account :=
                pvt [p$login_account].value^.keyword_value;
        IFEND;
      IFEND;
    IFEND;

{  Process LOGIN_PROJECT parameter.

    IF pvt [p$login_project].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$login_project;
      IF pvt [p$login_project].value^.kind = clc$name THEN
        input_attribute_changes^ [input_attribute_index].login_project :=
              pvt [p$login_project].value^.name_value;
      ELSE { kind = clc$keyword.
        IF pvt [p$login_project].value^.keyword_value = 'UNSPECIFIED' THEN
          input_attribute_changes^ [input_attribute_index].login_project := osc$null_name;
        ELSE
          input_attribute_changes^ [input_attribute_index].login_project :=
                pvt [p$login_project].value^.keyword_value;
        IFEND;
      IFEND;
    IFEND;

{  Process MAGNETIC_TAPE_LIMIT parameter.

    IF pvt [p$magnetic_tape_limit].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$magnetic_tape_limit;
      IF pvt [p$magnetic_tape_limit].value^.kind = clc$integer THEN
        input_attribute_changes^ [input_attribute_index].magnetic_tape_limit :=
              pvt [p$magnetic_tape_limit].value^.integer_value.value;
      ELSE
        IF pvt [p$magnetic_tape_limit].value^.keyword_value = 'UNSPECIFIED' THEN
          input_attribute_changes^ [input_attribute_index].magnetic_tape_limit :=
                jmc$unspecified_mag_tape_limit;
        ELSEIF pvt [p$magnetic_tape_limit].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
          input_attribute_changes^ [input_attribute_index].magnetic_tape_limit :=
                jmc$system_default_mag_tape_lim;
        ELSE { pvt [p$magnetic_tape_limit].value^.keyword_value = 'UNLIMITED'.
          input_attribute_changes^ [input_attribute_index].magnetic_tape_limit :=
                jmc$unlimited_mag_tape_limit;
        IFEND;
      IFEND;
    IFEND;

{  Process MAXIMUM_WORKING_SET parameter.

    IF pvt [p$maximum_working_set].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$maximum_working_set;
      IF pvt [p$maximum_working_set].value^.kind = clc$integer THEN
        input_attribute_changes^ [input_attribute_index].maximum_working_set :=
              pvt [p$maximum_working_set].value^.integer_value.value;
      ELSE
        IF pvt [p$maximum_working_set].value^.keyword_value = 'UNSPECIFIED' THEN
          input_attribute_changes^ [input_attribute_index].maximum_working_set :=
                jmc$unspecified_work_set_size;
        ELSEIF pvt [p$maximum_working_set].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
          input_attribute_changes^ [input_attribute_index].maximum_working_set :=
                jmc$system_default_work_set_siz;
        ELSE { pvt [p$maximum_working_set].value^.keyword_value = 'UNLIMITED'.
          input_attribute_changes^ [input_attribute_index].maximum_working_set :=
                jmc$unlimited_working_set_size;
        IFEND;
      IFEND;
    IFEND;

{  Process OPERATOR_FAMILY parameter.

    IF pvt [p$operator_family].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$output_destination_family;
      input_attribute_changes^ [input_attribute_index].output_destination_family :=
            pvt [p$operator_family].value^.name_value;
    IFEND;

{  Process OPERATOR_USER parameter.

    IF pvt [p$operator_user].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$station_operator;
      input_attribute_changes^ [input_attribute_index].station_operator :=
            pvt [p$operator_user].value^.name_value;
    IFEND;

{  Process OUTPUT_CLASS parameter.

    IF pvt [p$output_class].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$output_class;
      input_attribute_changes^ [input_attribute_index].output_class :=
            pvt [p$output_class].value^.keyword_value;
    IFEND;

{  Process OUTPUT_DEFERRED_BY_USER parameter.

    IF pvt [p$output_deferred_by_user].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$output_deferred_by_user;
      input_attribute_changes^ [input_attribute_index].output_deferred_by_user :=
            pvt [p$output_deferred_by_user].value^.boolean_value.value;
    IFEND;

{  Process OUTPUT_DESTINATION parameter.

    IF pvt [p$output_destination].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$output_destination;
      IF pvt [p$output_destination].value^.kind = clc$name THEN
        input_attribute_changes^ [input_attribute_index].output_destination :=
              pvt [p$output_destination].value^.name_value;
      ELSE
        input_attribute_changes^ [input_attribute_index].output_destination :=
              pvt [p$output_destination].value^.string_value^;

      IFEND;
    IFEND;

{  Process OUTPUT_DESTINATION_USAGE parameter.

    IF pvt [p$output_destination_usage].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$output_destination_usage;
      IF pvt [p$output_destination_usage].value^.kind = clc$name THEN
        input_attribute_changes^ [input_attribute_index].output_destination_usage :=
              pvt [p$output_destination_usage].value^.name_value;
      ELSE
        input_attribute_changes^ [input_attribute_index].output_destination_usage :=
              pvt [p$output_destination_usage].value^.keyword_value;
      IFEND;
    IFEND;

{  Process OUTPUT_DISPOSITION parameter.

    IF pvt [p$output_disposition].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$output_disposition;
      IF pvt [p$output_disposition].value^.kind = clc$file THEN
        input_attribute_changes^ [input_attribute_index].output_disposition.key := jmc$standard_output_path;
        PUSH input_attribute_changes^ [input_attribute_index].output_disposition.standard_output_path;
        input_attribute_changes^ [input_attribute_index].output_disposition.standard_output_path^ :=
              pvt [p$output_disposition].value^.file_value^;
      ELSE
        IF pvt [p$output_disposition].value^.keyword_value = 'PRINTER' THEN
          input_attribute_changes^ [input_attribute_index].output_disposition.key :=
                jmc$normal_output_disposition;
        ELSEIF pvt [p$output_disposition].value^.keyword_value = 'DISCARD_ALL_OUTPUT' THEN
          input_attribute_changes^ [input_attribute_index].output_disposition.key := jmc$discard_all_output;
        ELSEIF pvt [p$output_disposition].value^.keyword_value = 'DISCARD_STANDARD_OUTPUT' THEN
          input_attribute_changes^ [input_attribute_index].output_disposition.key :=
                jmc$discard_standard_output;
        ELSEIF pvt [p$output_disposition].value^.keyword_value = 'LOCAL' THEN
          input_attribute_changes^ [input_attribute_index].output_disposition.key :=
                jmc$local_output_disposition;
        ELSE { pvt [p$output_disposition].value^.keyword_value = "WAIT_QUEUE'.
          input_attribute_changes^ [input_attribute_index].output_disposition.key := jmc$wait_queue_path;
          input_attribute_changes^ [input_attribute_index].output_disposition.wait_queue_path := NIL;
        IFEND;
      IFEND;
    IFEND;

{  Process OUTPUT_PRIORITY parameter.

    IF pvt [p$output_priority].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$output_priority;
      input_attribute_changes^ [input_attribute_index].output_priority :=
            pvt [p$output_priority].value^.keyword_value;
    IFEND;

{  Process PURGE_DELAY parameter.

    IF pvt [p$purge_delay].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$purge_delay;
      PUSH input_attribute_changes^ [input_attribute_index].purge_delay;
      IF pvt [p$purge_delay].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        input_attribute_changes^ [input_attribute_index].purge_delay^.specified := FALSE;
      ELSE
        input_attribute_changes^ [input_attribute_index].purge_delay^.specified := TRUE;
        input_attribute_changes^ [input_attribute_index].purge_delay^.time_increment :=
              pvt [p$purge_delay].value^.time_increment_value^;
      IFEND;
    IFEND;

{  Process REMOTE_HOST_DIRECTIVE parameter.

    IF pvt [p$remote_host_directive].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$remote_host_directive;
      PUSH input_attribute_changes^ [input_attribute_index].remote_host_directive;
      input_attribute_changes^ [input_attribute_index].remote_host_directive^.size :=
            STRLENGTH (pvt [p$remote_host_directive].value^.string_value^);
      input_attribute_changes^ [input_attribute_index].remote_host_directive^.parameters :=
            pvt [p$remote_host_directive].value^.string_value^;
    IFEND;

{  Process ROUTING_BANNER parameter.

    IF pvt [p$routing_banner].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$routing_banner;
      input_attribute_changes^ [input_attribute_index].routing_banner :=
            pvt [p$routing_banner].value^.string_value^;
    IFEND;

{  Process SITE_INFORMATION parameter.

    IF pvt [p$site_information].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$site_information;
      PUSH input_attribute_changes^ [input_attribute_index].site_information;
      input_attribute_changes^ [input_attribute_index].site_information^ :=
            pvt [p$site_information].value^.string_value^;
    IFEND;

{  Process SRU_LIMIT parameter.

    IF pvt [p$sru_limit].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$sru_limit;
      IF pvt [p$sru_limit].value^.kind = clc$integer THEN
        input_attribute_changes^ [input_attribute_index].sru_limit :=
              pvt [p$sru_limit].value^.integer_value.value;
      ELSE
        IF pvt [p$sru_limit].value^.keyword_value = 'UNSPECIFIED' THEN
          input_attribute_changes^ [input_attribute_index].sru_limit := jmc$unspecified_sru_limit;
        ELSEIF pvt [p$sru_limit].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
          input_attribute_changes^ [input_attribute_index].sru_limit := jmc$system_default_sru_limit;
        ELSE { pvt [p$sru_limit].value^.keyword_value = 'UNLIMITED'.
          input_attribute_changes^ [input_attribute_index].sru_limit := jmc$unlimited_sru_limit;
        IFEND;
      IFEND;
    IFEND;

{  Process STATION parameter.

    IF pvt [p$station].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$station;
      IF pvt [p$station].value^.kind = clc$keyword THEN
        input_attribute_changes^ [input_attribute_index].station := pvt [p$station].value^.keyword_value;
      ELSE
        input_attribute_changes^ [input_attribute_index].station := pvt [p$station].value^.name_value;
      IFEND;
    IFEND;

{  Process USER_INFORMATION parameter.

    IF pvt [p$user_information].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$user_information;
      PUSH input_attribute_changes^ [input_attribute_index].user_information;
      input_attribute_changes^ [input_attribute_index].user_information^ :=
            pvt [p$user_information].value^.string_value^;
    IFEND;

{  Process USER_JOB_NAME parameter.

    IF pvt [p$user_job_name].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$user_job_name;
      input_attribute_changes^ [input_attribute_index].user_job_name :=
            pvt [p$user_job_name].value^.name_value;
    IFEND;

{  Process VERTICAL_PRINT_DENSITY parameter.

    IF pvt [p$vertical_print_density].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$vertical_print_density;
      IF pvt [p$vertical_print_density].value^.keyword_value = 'FILE' THEN
        input_attribute_changes^ [input_attribute_index].vertical_print_density :=
              jmc$vertical_print_density_file;
      ELSEIF pvt [p$vertical_print_density].value^.keyword_value = 'NONE' THEN
        input_attribute_changes^ [input_attribute_index].vertical_print_density :=
              jmc$vertical_print_density_none;
      ELSEIF pvt [p$vertical_print_density].value^.keyword_value = 'SIX' THEN
        input_attribute_changes^ [input_attribute_index].vertical_print_density :=
              jmc$vertical_print_density_6;
      ELSE { pvt [p$vertical_print_density].value^.keyword_value = 'EIGHT'.
        input_attribute_changes^ [input_attribute_index].vertical_print_density :=
              jmc$vertical_print_density_8;
      IFEND;
    IFEND;

{  Process VFU_LOAD_PROCEDURE parameter.

    IF pvt [p$vfu_load_procedure].specified THEN
      input_attribute_index := input_attribute_index + 1;
      input_attribute_changes^ [input_attribute_index].key := jmc$vfu_load_procedure;
      IF pvt [p$vfu_load_procedure].value^.kind = clc$keyword THEN
        input_attribute_changes^ [input_attribute_index].vfu_load_procedure := osc$null_name;
      ELSE
        input_attribute_changes^ [input_attribute_index].vfu_load_procedure :=
              pvt [p$vfu_load_procedure].value^.name_value;
      IFEND;
    IFEND;

{  Process NAME parameter.

    name_list := pvt [p$name].value;

    WHILE name_list <> NIL DO
      jmp$determine_name_kind (name_list^.element_value^.name_value, valid_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      jmp$change_input_attributes (valid_name, input_attribute_changes, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      name_list := name_list^.link;
    WHILEND;

  PROCEND jmp$_change_input_attribute;
?? TITLE := '[XDCL] jmp$_change_job_attribute', EJECT ??

  PROCEDURE [XDCL] jmp$_change_job_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (osm$chaja) change_job_attribute, change_job_attributes, chaja (
{    comment_banner, cb: string 0..jmc$output_comment_banner_size = $optional
{    copies, c: integer 1..jmc$output_copy_count_max = $optional
{    cyclic_aging_interval, cai: integer jmc$lowest_aging_interval..jmc$highe..
{ st_aging_interval = $optional
{    detached_job_wait_time, djwt: any of
{        key
{          unlimited
{        keyend
{        integer jmc$lowest_det_job_wait_time..jmc$highest_det_job_wait_time
{      anyend = $optional
{    device, d: any of
{        key
{          automatic
{        keyend
{        name
{      anyend = $optional
{    dispatching_priority, dp: any of
{        key
{          default
{        keyend
{        name
{      anyend = $optional
{    earliest_print_time, ept: any of
{        key
{          none
{        keyend
{        date_time
{      anyend = $optional
{    external_characteristics, ec: any of
{        key
{          normal
{        keyend
{        string 0..jmc$ext_characteristics_size
{      anyend = $optional
{    forms_code, fc: any of
{        key
{          normal
{        keyend
{        string 0..jmc$forms_code_size
{      anyend = $optional
{    job_abort_disposition, jad: key
{        (restart, r)
{        (terminate, t)
{      keyend = $optional
{    job_recovery_disposition, jrd: key
{        (continue, c)
{        (restart, r)
{        (terminate, t)
{      keyend = $optional
{    latest_print_time, lpt: any of
{        key
{          none
{        keyend
{        date_time
{      anyend = $optional
{    maximum_working_set, maxws: any of
{        key
{          system_default, unlimited
{        keyend
{        integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{      anyend = $optional
{    minimum_working_set, minws: integer jmc$lowest_working_set_size..jmc$hig..
{ hest_working_set_size = $optional
{    operator_family, destination_family, df, of: name = $optional
{    operator_user, so, station_operator, ou: name = $optional
{    output_class, oc: key
{        normal
{      keyend = $optional
{    output_deferred_by_user, odbu: boolean = $optional
{    output_destination, ode: any of
{        string 0..osc$max_name_size
{        name
{      anyend = $optional
{    output_destination_usage, destination_usage, du, odu: any of
{        key
{          dual_state, ntf, private, public, qtf
{        keyend
{        name
{      anyend = $optional
{    output_disposition, odi: any of
{        key
{          (discard_all_output, dao)
{          (discard_standard_output, dso)
{          (local, l)
{          (printer, p)
{          (wait_queue, wt, wq)
{        keyend
{        file
{      anyend = $optional
{    output_priority, op: key
{        low, medium, high
{      keyend = $optional
{    page_aging_interval, pai: integer jmc$lowest_aging_interval..jmc$highest..
{ _aging_interval = $optional
{    purge_delay, pd: any of
{        key
{          none
{        keyend
{        time_increment
{      anyend = $optional
{    remote_host_directive, dsrp, dual_state_route_parameters, rhd: string ..
{      0..jmc$remote_host_directive_size = $optional
{    routing_banner, rb: string 0..jmc$output_routing_banner_size = $optional
{    site_information, si: (BY_NAME, ADVANCED) string 0..jmc$site_information..
{ _size = $optional
{    station, s: any of
{        key
{          automatic
{        keyend
{        name
{      anyend = $optional
{    user_information, ui: string 0..jmc$user_information_size = $optional
{    vertical_print_density, vpd: key
{        six, eight, none, file
{      keyend = $optional
{    vfu_load_procedure, vlp: any of
{        key
{          none
{        keyend
{        name
{      anyend = $optional
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 71] of clt$pdt_parameter_name,
      parameters: array [1 .. 32] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: 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$integer_type_qualifier,
        recend,
      recend,
      type5: 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$name_type_qualifier,
        recend,
      recend,
      type6: 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$name_type_qualifier,
        recend,
      recend,
      type7: 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$date_time_type_qualifier,
        recend,
      recend,
      type8: 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$string_type_qualifier,
        recend,
      recend,
      type9: 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$string_type_qualifier,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type12: 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$date_time_type_qualifier,
        recend,
      recend,
      type13: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type14: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type15: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type17: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 1] of clt$keyword_specification,
      recend,
      type18: record
        header: clt$type_specification_header,
      recend,
      type19: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type20: 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 .. 5] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type21: 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 .. 11] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type22: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      type23: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type24: 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,
        recend,
      recend,
      type25: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type26: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type27: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type28: 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$name_type_qualifier,
        recend,
      recend,
      type29: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type30: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type31: 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$name_type_qualifier,
        recend,
      recend,
      type32: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 23, 9, 15, 4, 97],
    clc$command, 71, 32, 0, 1, 0, 0, 32, 'OSM$CHAJA'], [
    ['C                              ',clc$abbreviation_entry, 2],
    ['CAI                            ',clc$abbreviation_entry, 3],
    ['CB                             ',clc$abbreviation_entry, 1],
    ['COMMENT_BANNER                 ',clc$nominal_entry, 1],
    ['COPIES                         ',clc$nominal_entry, 2],
    ['CYCLIC_AGING_INTERVAL          ',clc$nominal_entry, 3],
    ['D                              ',clc$abbreviation_entry, 5],
    ['DESTINATION_FAMILY             ',clc$alias_entry, 15],
    ['DESTINATION_USAGE              ',clc$alias_entry, 20],
    ['DETACHED_JOB_WAIT_TIME         ',clc$nominal_entry, 4],
    ['DEVICE                         ',clc$nominal_entry, 5],
    ['DF                             ',clc$alias_entry, 15],
    ['DISPATCHING_PRIORITY           ',clc$nominal_entry, 6],
    ['DJWT                           ',clc$abbreviation_entry, 4],
    ['DP                             ',clc$abbreviation_entry, 6],
    ['DSRP                           ',clc$alias_entry, 25],
    ['DU                             ',clc$alias_entry, 20],
    ['DUAL_STATE_ROUTE_PARAMETERS    ',clc$alias_entry, 25],
    ['EARLIEST_PRINT_TIME            ',clc$nominal_entry, 7],
    ['EC                             ',clc$abbreviation_entry, 8],
    ['EPT                            ',clc$abbreviation_entry, 7],
    ['EXTERNAL_CHARACTERISTICS       ',clc$nominal_entry, 8],
    ['FC                             ',clc$abbreviation_entry, 9],
    ['FORMS_CODE                     ',clc$nominal_entry, 9],
    ['JAD                            ',clc$abbreviation_entry, 10],
    ['JOB_ABORT_DISPOSITION          ',clc$nominal_entry, 10],
    ['JOB_RECOVERY_DISPOSITION       ',clc$nominal_entry, 11],
    ['JRD                            ',clc$abbreviation_entry, 11],
    ['LATEST_PRINT_TIME              ',clc$nominal_entry, 12],
    ['LPT                            ',clc$abbreviation_entry, 12],
    ['MAXIMUM_WORKING_SET            ',clc$nominal_entry, 13],
    ['MAXWS                          ',clc$abbreviation_entry, 13],
    ['MINIMUM_WORKING_SET            ',clc$nominal_entry, 14],
    ['MINWS                          ',clc$abbreviation_entry, 14],
    ['OC                             ',clc$abbreviation_entry, 17],
    ['ODBU                           ',clc$abbreviation_entry, 18],
    ['ODE                            ',clc$abbreviation_entry, 19],
    ['ODI                            ',clc$abbreviation_entry, 21],
    ['ODU                            ',clc$abbreviation_entry, 20],
    ['OF                             ',clc$abbreviation_entry, 15],
    ['OP                             ',clc$abbreviation_entry, 22],
    ['OPERATOR_FAMILY                ',clc$nominal_entry, 15],
    ['OPERATOR_USER                  ',clc$nominal_entry, 16],
    ['OU                             ',clc$abbreviation_entry, 16],
    ['OUTPUT_CLASS                   ',clc$nominal_entry, 17],
    ['OUTPUT_DEFERRED_BY_USER        ',clc$nominal_entry, 18],
    ['OUTPUT_DESTINATION             ',clc$nominal_entry, 19],
    ['OUTPUT_DESTINATION_USAGE       ',clc$nominal_entry, 20],
    ['OUTPUT_DISPOSITION             ',clc$nominal_entry, 21],
    ['OUTPUT_PRIORITY                ',clc$nominal_entry, 22],
    ['PAGE_AGING_INTERVAL            ',clc$nominal_entry, 23],
    ['PAI                            ',clc$abbreviation_entry, 23],
    ['PD                             ',clc$abbreviation_entry, 24],
    ['PURGE_DELAY                    ',clc$nominal_entry, 24],
    ['RB                             ',clc$abbreviation_entry, 26],
    ['REMOTE_HOST_DIRECTIVE          ',clc$nominal_entry, 25],
    ['RHD                            ',clc$abbreviation_entry, 25],
    ['ROUTING_BANNER                 ',clc$nominal_entry, 26],
    ['S                              ',clc$abbreviation_entry, 28],
    ['SI                             ',clc$abbreviation_entry, 27],
    ['SITE_INFORMATION               ',clc$nominal_entry, 27],
    ['SO                             ',clc$alias_entry, 16],
    ['STATION                        ',clc$nominal_entry, 28],
    ['STATION_OPERATOR               ',clc$alias_entry, 16],
    ['STATUS                         ',clc$nominal_entry, 32],
    ['UI                             ',clc$abbreviation_entry, 29],
    ['USER_INFORMATION               ',clc$nominal_entry, 29],
    ['VERTICAL_PRINT_DENSITY         ',clc$nominal_entry, 30],
    ['VFU_LOAD_PROCEDURE             ',clc$nominal_entry, 31],
    ['VLP                            ',clc$abbreviation_entry, 31],
    ['VPD                            ',clc$abbreviation_entry, 30]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 72, clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 72, clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [27, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 13
    [31, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 121, clc$optional_parameter, 0, 0],
{ PARAMETER 14
    [33, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 15
    [42, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 16
    [43, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [45, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 44, clc$optional_parameter, 0, 0],
{ PARAMETER 18
    [46, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 19
    [47, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 20
    [48, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 217, clc$optional_parameter, 0, 0],
{ PARAMETER 21
    [49, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 437, clc$optional_parameter, 0, 0],
{ PARAMETER 22
    [50, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 118, clc$optional_parameter, 0, 0],
{ PARAMETER 23
    [51, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 24
    [54, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 25
    [56, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 26
    [58, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 27
    [61, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 28
    [63, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 29
    [67, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 30
    [68, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],
{ PARAMETER 31
    [69, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 32
    [65, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, jmc$output_comment_banner_size, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, jmc$output_copy_count_max, 10]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
  jmc$highest_aging_interval, 10]],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_det_job_wait_time,
  jmc$highest_det_job_wait_time, 10]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['AUTOMATIC                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$date_time_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time
  ], $clt$date_time_tenses [clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$string_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NORMAL                         ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [0, jmc$ext_characteristics_size, FALSE]]
    ],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$string_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NORMAL                         ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [0, jmc$forms_code_size, FALSE]]
    ],
{ PARAMETER 10
    [[1, 0, clc$keyword_type], [4], [
    ['R                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['RESTART                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 11
    [[1, 0, clc$keyword_type], [6], [
    ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['CONTINUE                       ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['R                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['RESTART                        ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['T                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['TERMINATE                      ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 12
    [[1, 0, clc$union_type], [[clc$date_time_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time
  ], $clt$date_time_tenses [clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 13
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
  jmc$highest_working_set_size, 10]]
    ],
{ PARAMETER 14
    [[1, 0, clc$integer_type], [jmc$lowest_working_set_size,
  jmc$highest_working_set_size, 10]],
{ PARAMETER 15
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 16
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 17
    [[1, 0, clc$keyword_type], [1], [
    ['NORMAL                         ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 18
    [[1, 0, clc$boolean_type]],
{ PARAMETER 19
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 20
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    192, [[1, 0, clc$keyword_type], [5], [
      ['DUAL_STATE                     ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NTF                            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['PRIVATE                        ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['PUBLIC                         ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['QTF                            ', clc$nominal_entry,
  clc$normal_usage_entry, 5]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 21
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    414, [[1, 0, clc$keyword_type], [11], [
      ['DAO                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
      ['DISCARD_ALL_OUTPUT             ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['DISCARD_STANDARD_OUTPUT        ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['DSO                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
      ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
      ['LOCAL                          ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['P                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
      ['PRINTER                        ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['WAIT_QUEUE                     ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
      ['WQ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
      ['WT                             ', clc$alias_entry,
  clc$normal_usage_entry, 5]]
      ],
    3, [[1, 0, clc$file_type]]
    ],
{ PARAMETER 22
    [[1, 0, clc$keyword_type], [3], [
    ['HIGH                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['LOW                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['MEDIUM                         ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 23
    [[1, 0, clc$integer_type], [jmc$lowest_aging_interval,
  jmc$highest_aging_interval, 10]],
{ PARAMETER 24
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$time_increment_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$time_increment_type]]
    ],
{ PARAMETER 25
    [[1, 0, clc$string_type], [0, jmc$remote_host_directive_size, FALSE]],
{ PARAMETER 26
    [[1, 0, clc$string_type], [0, jmc$output_routing_banner_size, FALSE]],
{ PARAMETER 27
    [[1, 0, clc$string_type], [0, jmc$site_information_size, FALSE]],
{ PARAMETER 28
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['AUTOMATIC                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 29
    [[1, 0, clc$string_type], [0, jmc$user_information_size, FALSE]],
{ PARAMETER 30
    [[1, 0, clc$keyword_type], [4], [
    ['EIGHT                          ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['FILE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['SIX                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 31
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 32
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$comment_banner = 1,
      p$copies = 2,
      p$cyclic_aging_interval = 3,
      p$detached_job_wait_time = 4,
      p$device = 5,
      p$dispatching_priority = 6,
      p$earliest_print_time = 7,
      p$external_characteristics = 8,
      p$forms_code = 9,
      p$job_abort_disposition = 10,
      p$job_recovery_disposition = 11,
      p$latest_print_time = 12,
      p$maximum_working_set = 13,
      p$minimum_working_set = 14,
      p$operator_family = 15,
      p$operator_user = 16,
      p$output_class = 17,
      p$output_deferred_by_user = 18,
      p$output_destination = 19,
      p$output_destination_usage = 20,
      p$output_disposition = 21,
      p$output_priority = 22,
      p$page_aging_interval = 23,
      p$purge_delay = 24,
      p$remote_host_directive = 25,
      p$routing_banner = 26,
      p$site_information = 27,
      p$station = 28,
      p$user_information = 29,
      p$vertical_print_density = 30,
      p$vfu_load_procedure = 31,
      p$status = 32;

    VAR
      pvt: array [1 .. 32] of clt$parameter_value;

    CONST
      max_job_attributes = p$vfu_load_procedure;

    VAR
      job_attribute_changes: ^jmt$job_attribute_changes,
      job_attribute_index: 0 .. max_job_attributes,
      number_of_job_attributes: 0 .. max_job_attributes;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    job_attribute_changes := NIL;
    number_of_job_attributes := 0;

    FOR job_attribute_index := p$comment_banner TO p$vfu_load_procedure DO
      CASE pvt [job_attribute_index].passing_method OF
      = clc$pass_by_value =
        IF pvt [job_attribute_index].value <> NIL THEN
          number_of_job_attributes := number_of_job_attributes + 1;
        IFEND;
      = clc$pass_by_reference =
        IF pvt [job_attribute_index].variable <> NIL THEN
          number_of_job_attributes := number_of_job_attributes + 1;
        IFEND;
      CASEND;
    FOREND;

    job_attribute_index := 0;

    IF number_of_job_attributes <> 0 THEN
      PUSH job_attribute_changes: [1 .. number_of_job_attributes];
    IFEND;

{  Process COMMENT_BANNER parameter.

    IF pvt [p$comment_banner].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$comment_banner;
      job_attribute_changes^ [job_attribute_index].comment_banner :=
            pvt [p$comment_banner].value^.string_value^;
    IFEND;

{  Process COPIES parameter.

    IF pvt [p$copies].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$copies;
      job_attribute_changes^ [job_attribute_index].copies := pvt [p$copies].value^.integer_value.value;
    IFEND;

{  Process CYCLIC_AGING_INTERVAL parameter.

    IF pvt [p$cyclic_aging_interval].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$cyclic_aging_interval;
      job_attribute_changes^ [job_attribute_index].cyclic_aging_interval :=
            pvt [p$cyclic_aging_interval].value^.integer_value.value;
    IFEND;

{  Process DETACHED_JOB_WAIT_TIME parameter.

    IF pvt [p$detached_job_wait_time].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$detached_job_wait_time;
      IF pvt [p$detached_job_wait_time].value^.kind = clc$integer THEN
        job_attribute_changes^ [job_attribute_index].detached_job_wait_time :=
              pvt [p$detached_job_wait_time].value^.integer_value.value;
      ELSE { UNLIMITED is the only KEYWORD allowed.
        job_attribute_changes^ [job_attribute_index].detached_job_wait_time :=
              jmc$unlimited_det_job_wait_time;
      IFEND;
    IFEND;

{  Process DEVICE parameter.

    IF pvt [p$device].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$device;
      IF pvt [p$device].value^.kind = clc$name THEN
        job_attribute_changes^ [job_attribute_index].device := pvt [p$device].value^.name_value;
      ELSE
        job_attribute_changes^ [job_attribute_index].device := pvt [p$device].value^.keyword_value;
      IFEND;
    IFEND;

{  Process DISPATCHING_PRIORITY parameter.

    IF pvt [p$dispatching_priority].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$dispatching_priority;
      IF pvt [p$dispatching_priority].value^.kind = clc$name THEN
        job_attribute_changes^ [job_attribute_index].dispatching_priority :=
              pvt [p$dispatching_priority].value^.name_value;
      ELSE { pvt [p$dispatching_priority].value^.kind = clc$keyword.
        job_attribute_changes^ [job_attribute_index].dispatching_priority :=
              pvt [p$dispatching_priority].value^.keyword_value;
      IFEND;
    IFEND;

{  Process EARLIEST_PRINT_TIME parameter.

    IF pvt [p$earliest_print_time].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$earliest_print_time;
      IF pvt [p$earliest_print_time].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        job_attribute_changes^ [job_attribute_index].earliest_print_time.specified := FALSE;
      ELSE
        job_attribute_changes^ [job_attribute_index].earliest_print_time.specified := TRUE;
        job_attribute_changes^ [job_attribute_index].earliest_print_time.date_time :=
              pvt [p$earliest_print_time].value^.date_time_value.value;
      IFEND;
    IFEND;

{  Process EXTERNAL_CHARACTERISTICS parameter.

    IF pvt [p$external_characteristics].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$external_characteristics;
      IF pvt [p$external_characteristics].value^.kind = clc$keyword THEN { the only keyword is NORMAL. }
        job_attribute_changes^ [job_attribute_index].external_characteristics :=
              pvt [p$external_characteristics].value^.keyword_value;
      ELSE
        job_attribute_changes^ [job_attribute_index].external_characteristics :=
              pvt [p$external_characteristics].value^.string_value^;
      IFEND;
    IFEND;

{  Process FORMS_CODE parameter.

    IF pvt [p$forms_code].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$forms_code;
      IF pvt [p$forms_code].value^.kind = clc$keyword THEN { the only keyword allowed is NORMAL. }
        job_attribute_changes^ [job_attribute_index].forms_code := pvt [p$forms_code].value^.keyword_value;
      ELSE
        job_attribute_changes^ [job_attribute_index].forms_code := pvt [p$forms_code].value^.string_value^;
      IFEND;
    IFEND;

{  Process JOB_ABORT_DISPOSITION parameter.

    IF pvt [p$job_abort_disposition].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$job_abort_disposition;
      IF pvt [p$job_abort_disposition].value^.keyword_value = 'RESTART' THEN
        job_attribute_changes^ [job_attribute_index].job_abort_disposition := jmc$restart_on_abort;
      ELSE { TERMINATE is the only other choice. }
        job_attribute_changes^ [job_attribute_index].job_abort_disposition := jmc$terminate_on_abort;
      IFEND;
    IFEND;

{  Process JOB_RECOVERY_DISPOSITION parameter.

    IF pvt [p$job_recovery_disposition].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$job_recovery_disposition;
      IF pvt [p$job_recovery_disposition].value^.keyword_value = 'RESTART' THEN
        job_attribute_changes^ [job_attribute_index].job_recovery_disposition := jmc$restart_on_recovery;
      ELSEIF pvt [p$job_recovery_disposition].value^.keyword_value = 'CONTINUE' THEN
        job_attribute_changes^ [job_attribute_index].job_recovery_disposition := jmc$continue_on_recovery;
      ELSE { pvt [p$job_recovery_disposition].value^.keyword_value = 'TERMINATE'.
        job_attribute_changes^ [job_attribute_index].job_recovery_disposition := jmc$terminate_on_recovery;
      IFEND;
    IFEND;

{  Process LATEST_PRINT_TIME parameter.

    IF pvt [p$latest_print_time].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$latest_print_time;
      IF pvt [p$latest_print_time].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        job_attribute_changes^ [job_attribute_index].latest_print_time.specified := FALSE;
      ELSE
        job_attribute_changes^ [job_attribute_index].latest_print_time.specified := TRUE;
        job_attribute_changes^ [job_attribute_index].latest_print_time.date_time :=
              pvt [p$latest_print_time].value^.date_time_value.value;
      IFEND;
    IFEND;

{  Process MAXIMUM_WORKING_SET parameter.

    IF pvt [p$maximum_working_set].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$maximum_working_set;
      IF pvt [p$maximum_working_set].value^.kind = clc$integer THEN
        job_attribute_changes^ [job_attribute_index].maximum_working_set := pvt [p$maximum_working_set].
              value^.integer_value.value;
      ELSE
        IF pvt [p$maximum_working_set].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
          job_attribute_changes^ [job_attribute_index].maximum_working_set := jmc$system_default_work_set_siz;
        ELSE { pvt [p$maximum_working_set].value^.keyword_value = 'UNLIMITED'.
          job_attribute_changes^ [job_attribute_index].maximum_working_set := jmc$unlimited_working_set_size;
        IFEND;
      IFEND;
    IFEND;

{  Process MINIMUM_WORKING_SET parameter.

    IF pvt [p$minimum_working_set].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$minimum_working_set;
      job_attribute_changes^ [job_attribute_index].minimum_working_set :=
            pvt [p$minimum_working_set].value^.integer_value.value;
    IFEND;

{  Process OPERATOR_FAMILY parameter.

    IF pvt [p$operator_family].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$output_destination_family;
      job_attribute_changes^ [job_attribute_index].output_destination_family := pvt [p$operator_family].
            value^.name_value;
    IFEND;

{  Process OPERATOR_USER parameter.

    IF pvt [p$operator_user].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$station_operator;
      job_attribute_changes^ [job_attribute_index].station_operator := pvt [p$operator_user].value^.
            name_value;
    IFEND;

{  Process OUTPUT_CLASS parameter.

    IF pvt [p$output_class].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$output_class;
      job_attribute_changes^ [job_attribute_index].output_class := pvt [p$output_class].value^.keyword_value;
    IFEND;

{  Process OUTPUT_DEFERRED_BY_USER parameter.

    IF pvt [p$output_deferred_by_user].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$output_deferred_by_user;
      job_attribute_changes^ [job_attribute_index].output_deferred_by_user :=
            pvt [p$output_deferred_by_user].value^.boolean_value.value;
    IFEND;

{  Process OUTPUT_DESTINATION parameter.

    IF pvt [p$output_destination].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$output_destination;
      IF pvt [p$output_destination].value^.kind = clc$name THEN
        job_attribute_changes^ [job_attribute_index].output_destination :=
              pvt [p$output_destination].value^.name_value;
      ELSE
        job_attribute_changes^ [job_attribute_index].output_destination :=
              pvt [p$output_destination].value^.string_value^;

      IFEND;
    IFEND;

{  Process OUTPUT_DESTINATION_USAGE parameter.

    IF pvt [p$output_destination_usage].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$output_destination_usage;
      IF pvt [p$output_destination_usage].value^.kind = clc$name THEN
        job_attribute_changes^ [job_attribute_index].output_destination_usage :=
              pvt [p$output_destination_usage].value^.name_value;
      ELSE
        job_attribute_changes^ [job_attribute_index].output_destination_usage :=
              pvt [p$output_destination_usage].value^.keyword_value;

      IFEND;
    IFEND;

{  Process OUTPUT_DISPOSITION parameter.

    IF pvt [p$output_disposition].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$output_disposition;
      IF pvt [p$output_disposition].value^.kind = clc$file THEN
        job_attribute_changes^ [job_attribute_index].output_disposition.key := jmc$standard_output_path;
        PUSH job_attribute_changes^ [job_attribute_index].output_disposition.standard_output_path;
        job_attribute_changes^ [job_attribute_index].output_disposition.standard_output_path^ :=
              pvt [p$output_disposition].value^.file_value^;
      ELSE
        IF pvt [p$output_disposition].value^.keyword_value = 'PRINTER' THEN
          job_attribute_changes^ [job_attribute_index].output_disposition.key :=
                jmc$normal_output_disposition;
        ELSEIF pvt [p$output_disposition].value^.keyword_value = 'DISCARD_ALL_OUTPUT' THEN
          job_attribute_changes^ [job_attribute_index].output_disposition.key := jmc$discard_all_output;
        ELSEIF pvt [p$output_disposition].value^.keyword_value = 'DISCARD_STANDARD_OUTPUT' THEN
          job_attribute_changes^ [job_attribute_index].output_disposition.key := jmc$discard_standard_output;
        ELSEIF pvt [p$output_disposition].value^.keyword_value = 'LOCAL' THEN
          job_attribute_changes^ [job_attribute_index].output_disposition.key := jmc$local_output_disposition;
        ELSE { pvt [p$output_disposition].value^.keyword_value = 'WAIT_QUEUE'.
          job_attribute_changes^ [job_attribute_index].output_disposition.key := jmc$wait_queue_path;
          job_attribute_changes^ [job_attribute_index].output_disposition.wait_queue_path := NIL;
        IFEND;
      IFEND;
    IFEND;

{  Process OUTPUT_PRIORITY parameter.

    IF pvt [p$output_priority].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$output_priority;
      job_attribute_changes^ [job_attribute_index].output_priority :=
            pvt [p$output_priority].value^.keyword_value;
    IFEND;

{  Process PAGE_AGING_INTERVAL parameter.

    IF pvt [p$page_aging_interval].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$page_aging_interval;
      job_attribute_changes^ [job_attribute_index].page_aging_interval :=
            pvt [p$page_aging_interval].value^.integer_value.value;
    IFEND;

{  Process PURGE_DELAY parameter.

    IF pvt [p$purge_delay].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$purge_delay;
      PUSH job_attribute_changes^ [job_attribute_index].purge_delay;
      IF pvt [p$purge_delay].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        job_attribute_changes^ [job_attribute_index].purge_delay^.specified := FALSE;
      ELSE
        job_attribute_changes^ [job_attribute_index].purge_delay^.specified := TRUE;
        job_attribute_changes^ [job_attribute_index].purge_delay^.time_increment := pvt [p$purge_delay].
              value^.time_increment_value^;
      IFEND;
    IFEND;

{  Process REMOTE_HOST_DIRECTIVE parameter.

    IF pvt [p$remote_host_directive].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$remote_host_directive;
      PUSH job_attribute_changes^ [job_attribute_index].remote_host_directive;
      job_attribute_changes^ [job_attribute_index].remote_host_directive^.size :=
            STRLENGTH (pvt [p$remote_host_directive].value^.string_value^);
      job_attribute_changes^ [job_attribute_index].remote_host_directive^.parameters :=
            pvt [p$remote_host_directive].value^.string_value^;
    IFEND;

{  Process ROUTING_BANNER parameter.

    IF pvt [p$routing_banner].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$routing_banner;
      job_attribute_changes^ [job_attribute_index].routing_banner :=
            pvt [p$routing_banner].value^.string_value^;
    IFEND;

{  Process SITE_INFORMATION parameter.

    IF pvt [p$site_information].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$site_information;
      PUSH job_attribute_changes^ [job_attribute_index].site_information;
      job_attribute_changes^ [job_attribute_index].site_information^ :=
            pvt [p$site_information].value^.string_value^;
    IFEND;

{  Process STATION parameter.

    IF pvt [p$station].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$station;
      IF pvt [p$station].value^.kind = clc$keyword THEN
        job_attribute_changes^ [job_attribute_index].station := pvt [p$station].value^.keyword_value;
      ELSE
        job_attribute_changes^ [job_attribute_index].station := pvt [p$station].value^.name_value;
      IFEND;
    IFEND;

{  Process USER_INFORMATION parameter.

    IF pvt [p$user_information].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$user_information;
      PUSH job_attribute_changes^ [job_attribute_index].user_information;
      job_attribute_changes^ [job_attribute_index].user_information^ :=
            pvt [p$user_information].value^.string_value^;
    IFEND;

{  Process VERTICAL_PRINT_DENSITY parameter.

    IF pvt [p$vertical_print_density].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$vertical_print_density;
      IF pvt [p$vertical_print_density].value^.keyword_value = 'FILE' THEN
        job_attribute_changes^ [job_attribute_index].vertical_print_density :=
              jmc$vertical_print_density_file;
      ELSEIF pvt [p$vertical_print_density].value^.keyword_value = 'NONE' THEN
        job_attribute_changes^ [job_attribute_index].vertical_print_density :=
              jmc$vertical_print_density_none;
      ELSEIF pvt [p$vertical_print_density].value^.keyword_value = 'SIX' THEN
        job_attribute_changes^ [job_attribute_index].vertical_print_density := jmc$vertical_print_density_6;
      ELSE { pvt [p$vertical_print_density].value^.keyword_value = 'EIGHT'
        job_attribute_changes^ [job_attribute_index].vertical_print_density := jmc$vertical_print_density_8;
      IFEND;
    IFEND;

{  Process VFU_LOAD_PROCEDURE parameter.

    IF pvt [p$vfu_load_procedure].specified THEN
      job_attribute_index := job_attribute_index + 1;
      job_attribute_changes^ [job_attribute_index].key := jmc$vfu_load_procedure;
      IF pvt [p$vfu_load_procedure].value^.kind = clc$keyword THEN
        job_attribute_changes^ [job_attribute_index].vfu_load_procedure := osc$null_name;
      ELSE
        job_attribute_changes^ [job_attribute_index].vfu_load_procedure :=
              pvt [p$vfu_load_procedure].value^.name_value;
      IFEND;
    IFEND;

    jmp$change_job_attributes (job_attribute_changes, status);

  PROCEND jmp$_change_job_attribute;
?? TITLE := '[XDCL] jmp$_change_output_attribute', EJECT ??

  PROCEDURE [XDCL] jmp$_change_output_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (osm$chaoa) change_output_attribute, change_output_attributes, c..
{ haoa (
{    name, names, n: list of name = $required
{    comment_banner, cb: string 0..jmc$output_comment_banner_size = $optional
{    copies, c: integer 1..jmc$output_copy_count_max = $optional
{    device, d: any of
{        key
{          automatic
{        keyend
{        name
{      anyend = $optional
{    earliest_print_time, ept: any of
{        key
{          none
{        keyend
{        date_time
{      anyend = $optional
{    external_characteristics, ec: any of
{        key
{          normal
{        keyend
{        string 0..jmc$ext_characteristics_size
{      anyend = $optional
{    forms_code, fc: any of
{        key
{          normal
{        keyend
{        string 0..jmc$forms_code_size
{      anyend = $optional
{    latest_print_time, lpt: any of
{        key
{          none
{        keyend
{        date_time
{      anyend = $optional
{    operator_family, destination_family, df, of: name = $optional
{    operator_user, so, station_operator, ou: name = $optional
{    output_class, oc: key
{        normal
{      keyend = $optional
{    output_deferred_by_operator, odbo: boolean = $optional
{    output_deferred_by_user, odbu: boolean = $optional
{    output_destination, ode: any of
{        string 0..osc$max_name_size
{        name
{      anyend = $optional
{    output_destination_usage, destination_usage, du, odu: any of
{        key
{          dual_state, ntf, private, public, qtf
{        keyend
{        name
{      anyend = $optional
{    output_priority, op: key
{        low, medium, high
{      keyend = $optional
{    purge_delay, pd: any of
{        key
{          none
{        keyend
{        time_increment
{      anyend = $optional
{    remote_host_directive, dsrp, dual_state_route_parameters, rhd: string ..
{      0..jmc$remote_host_directive_size = $optional
{    reprint_disposition, rd: key
{        (discard, d)
{        (reprint, r)
{      keyend = $optional
{    routing_banner, rb: string 0..jmc$output_routing_banner_size = $optional
{    site_information, si: (BY_NAME, ADVANCED) string 0..jmc$site_information..
{ _size = $optional
{    station, s: any of
{        key
{          automatic
{        keyend
{        name
{      anyend = $optional
{    user_information, ui: string 0..jmc$user_information_size = $optional
{    vertical_print_density, vpd: key
{        six, eight, none
{      keyend = $optional
{    vfu_load_procedure, vlp: any of
{        key
{          none
{        keyend
{        name
{      anyend = $optional
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 60] of clt$pdt_parameter_name,
      parameters: array [1 .. 26] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: 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$name_type_qualifier,
        recend,
      recend,
      type5: 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$date_time_type_qualifier,
        recend,
      recend,
      type6: 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$string_type_qualifier,
        recend,
      recend,
      type7: 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$string_type_qualifier,
        recend,
      recend,
      type8: 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$date_time_type_qualifier,
        recend,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 1] of clt$keyword_specification,
      recend,
      type12: record
        header: clt$type_specification_header,
      recend,
      type13: record
        header: clt$type_specification_header,
      recend,
      type14: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type15: 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 .. 5] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      type17: 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,
        recend,
      recend,
      type18: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type19: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type20: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type21: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type22: 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$name_type_qualifier,
        recend,
      recend,
      type23: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type24: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      type25: 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$name_type_qualifier,
        recend,
      recend,
      type26: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 23, 9, 20, 7, 718],
    clc$command, 60, 26, 1, 1, 0, 0, 26, 'OSM$CHAOA'], [
    ['C                              ',clc$abbreviation_entry, 3],
    ['CB                             ',clc$abbreviation_entry, 2],
    ['COMMENT_BANNER                 ',clc$nominal_entry, 2],
    ['COPIES                         ',clc$nominal_entry, 3],
    ['D                              ',clc$abbreviation_entry, 4],
    ['DESTINATION_FAMILY             ',clc$alias_entry, 9],
    ['DESTINATION_USAGE              ',clc$alias_entry, 15],
    ['DEVICE                         ',clc$nominal_entry, 4],
    ['DF                             ',clc$alias_entry, 9],
    ['DSRP                           ',clc$alias_entry, 18],
    ['DU                             ',clc$alias_entry, 15],
    ['DUAL_STATE_ROUTE_PARAMETERS    ',clc$alias_entry, 18],
    ['EARLIEST_PRINT_TIME            ',clc$nominal_entry, 5],
    ['EC                             ',clc$abbreviation_entry, 6],
    ['EPT                            ',clc$abbreviation_entry, 5],
    ['EXTERNAL_CHARACTERISTICS       ',clc$nominal_entry, 6],
    ['FC                             ',clc$abbreviation_entry, 7],
    ['FORMS_CODE                     ',clc$nominal_entry, 7],
    ['LATEST_PRINT_TIME              ',clc$nominal_entry, 8],
    ['LPT                            ',clc$abbreviation_entry, 8],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['OC                             ',clc$abbreviation_entry, 11],
    ['ODBO                           ',clc$abbreviation_entry, 12],
    ['ODBU                           ',clc$abbreviation_entry, 13],
    ['ODE                            ',clc$abbreviation_entry, 14],
    ['ODU                            ',clc$abbreviation_entry, 15],
    ['OF                             ',clc$abbreviation_entry, 9],
    ['OP                             ',clc$abbreviation_entry, 16],
    ['OPERATOR_FAMILY                ',clc$nominal_entry, 9],
    ['OPERATOR_USER                  ',clc$nominal_entry, 10],
    ['OU                             ',clc$abbreviation_entry, 10],
    ['OUTPUT_CLASS                   ',clc$nominal_entry, 11],
    ['OUTPUT_DEFERRED_BY_OPERATOR    ',clc$nominal_entry, 12],
    ['OUTPUT_DEFERRED_BY_USER        ',clc$nominal_entry, 13],
    ['OUTPUT_DESTINATION             ',clc$nominal_entry, 14],
    ['OUTPUT_DESTINATION_USAGE       ',clc$nominal_entry, 15],
    ['OUTPUT_PRIORITY                ',clc$nominal_entry, 16],
    ['PD                             ',clc$abbreviation_entry, 17],
    ['PURGE_DELAY                    ',clc$nominal_entry, 17],
    ['RB                             ',clc$abbreviation_entry, 20],
    ['RD                             ',clc$abbreviation_entry, 19],
    ['REMOTE_HOST_DIRECTIVE          ',clc$nominal_entry, 18],
    ['REPRINT_DISPOSITION            ',clc$nominal_entry, 19],
    ['RHD                            ',clc$abbreviation_entry, 18],
    ['ROUTING_BANNER                 ',clc$nominal_entry, 20],
    ['S                              ',clc$abbreviation_entry, 22],
    ['SI                             ',clc$abbreviation_entry, 21],
    ['SITE_INFORMATION               ',clc$nominal_entry, 21],
    ['SO                             ',clc$alias_entry, 10],
    ['STATION                        ',clc$nominal_entry, 22],
    ['STATION_OPERATOR               ',clc$alias_entry, 10],
    ['STATUS                         ',clc$nominal_entry, 26],
    ['UI                             ',clc$abbreviation_entry, 23],
    ['USER_INFORMATION               ',clc$nominal_entry, 23],
    ['VERTICAL_PRINT_DENSITY         ',clc$nominal_entry, 24],
    ['VFU_LOAD_PROCEDURE             ',clc$nominal_entry, 25],
    ['VLP                            ',clc$abbreviation_entry, 25],
    ['VPD                            ',clc$abbreviation_entry, 24]],
    [
{ PARAMETER 1
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 21, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 72, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 72, clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [31, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [32, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [34, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 44, clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [35, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 13
    [36, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 14
    [37, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 15
    [38, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 217, clc$optional_parameter, 0, 0],
{ PARAMETER 16
    [39, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 118, clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [41, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 18
    [44, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 19
    [45, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],
{ PARAMETER 20
    [47, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 21
    [50, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 22
    [52, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 23
    [56, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 24
    [57, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 118, clc$optional_parameter, 0, 0],
{ PARAMETER 25
    [58, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 26
    [54, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$string_type], [0, jmc$output_comment_banner_size, FALSE]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, jmc$output_copy_count_max, 10]],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['AUTOMATIC                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$date_time_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time
  ], $clt$date_time_tenses [clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$string_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NORMAL                         ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [0, jmc$ext_characteristics_size, FALSE]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$string_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NORMAL                         ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [0, jmc$forms_code_size, FALSE]]
    ],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$date_time_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time
  ], $clt$date_time_tenses [clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 9
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 10
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 11
    [[1, 0, clc$keyword_type], [1], [
    ['NORMAL                         ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 12
    [[1, 0, clc$boolean_type]],
{ PARAMETER 13
    [[1, 0, clc$boolean_type]],
{ PARAMETER 14
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 15
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    192, [[1, 0, clc$keyword_type], [5], [
      ['DUAL_STATE                     ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NTF                            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['PRIVATE                        ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['PUBLIC                         ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['QTF                            ', clc$nominal_entry,
  clc$normal_usage_entry, 5]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 16
    [[1, 0, clc$keyword_type], [3], [
    ['HIGH                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['LOW                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['MEDIUM                         ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 17
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$time_increment_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$time_increment_type]]
    ],
{ PARAMETER 18
    [[1, 0, clc$string_type], [0, jmc$remote_host_directive_size, FALSE]],
{ PARAMETER 19
    [[1, 0, clc$keyword_type], [4], [
    ['D                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['DISCARD                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['R                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['REPRINT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 20
    [[1, 0, clc$string_type], [0, jmc$output_routing_banner_size, FALSE]],
{ PARAMETER 21
    [[1, 0, clc$string_type], [0, jmc$site_information_size, FALSE]],
{ PARAMETER 22
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['AUTOMATIC                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 23
    [[1, 0, clc$string_type], [0, jmc$user_information_size, FALSE]],
{ PARAMETER 24
    [[1, 0, clc$keyword_type], [3], [
    ['EIGHT                          ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['SIX                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 25
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 26
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$comment_banner = 2,
      p$copies = 3,
      p$device = 4,
      p$earliest_print_time = 5,
      p$external_characteristics = 6,
      p$forms_code = 7,
      p$latest_print_time = 8,
      p$operator_family = 9,
      p$operator_user = 10,
      p$output_class = 11,
      p$output_deferred_by_operator = 12,
      p$output_deferred_by_user = 13,
      p$output_destination = 14,
      p$output_destination_usage = 15,
      p$output_priority = 16,
      p$purge_delay = 17,
      p$remote_host_directive = 18,
      p$reprint_disposition = 19,
      p$routing_banner = 20,
      p$site_information = 21,
      p$station = 22,
      p$user_information = 23,
      p$vertical_print_density = 24,
      p$vfu_load_procedure = 25,
      p$status = 26;

    VAR
      pvt: array [1 .. 26] of clt$parameter_value;

    CONST
      max_output_attributes = p$vfu_load_procedure;

    VAR
      index: 0 .. max_output_attributes,
      name_list: ^clt$data_value,
      number_of_output_attributes: 0 .. max_output_attributes,
      output_attribute_index: 0 .. max_output_attributes,
      valid_name: jmt$name,
      output_attribute_changes: ^jmt$output_attribute_changes;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_attribute_changes := NIL;
    output_attribute_index := 0;
    number_of_output_attributes := 0;

    FOR index := p$comment_banner TO p$vfu_load_procedure DO
      CASE pvt [index].passing_method OF
      = clc$pass_by_value =
        IF pvt [index].value <> NIL THEN
          number_of_output_attributes := number_of_output_attributes + 1;
        IFEND;
      = clc$pass_by_reference =
        IF pvt [index].variable <> NIL THEN
          number_of_output_attributes := number_of_output_attributes + 1;
        IFEND;
      CASEND;
    FOREND;

    IF number_of_output_attributes <> 0 THEN
      PUSH output_attribute_changes: [1 .. number_of_output_attributes];
    IFEND;

{  Process COMMENT_BANNER parameter.

    IF pvt [p$comment_banner].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$comment_banner;
      output_attribute_changes^ [output_attribute_index].comment_banner :=
            pvt [p$comment_banner].value^.string_value^;
    IFEND;

{  Process COPIES parameter.

    IF pvt [p$copies].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$copies;
      output_attribute_changes^ [output_attribute_index].copies := pvt [p$copies].value^.integer_value.value;
    IFEND;

{  Process DEVICE parameter.

    IF pvt [p$device].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$device;
      IF pvt [p$device].value^.kind = clc$name THEN
        output_attribute_changes^ [output_attribute_index].device := pvt [p$device].value^.name_value;
      ELSE
        output_attribute_changes^ [output_attribute_index].device := pvt [p$device].value^.keyword_value;
      IFEND;
    IFEND;

{  Process EARLIEST_PRINT_TIME parameter.

    IF pvt [p$earliest_print_time].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$earliest_print_time;
      IF pvt [p$earliest_print_time].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        output_attribute_changes^ [output_attribute_index].earliest_print_time.specified := FALSE;
      ELSE
        output_attribute_changes^ [output_attribute_index].earliest_print_time.specified := TRUE;
        output_attribute_changes^ [output_attribute_index].earliest_print_time.date_time :=
              pvt [p$earliest_print_time].value^.date_time_value.value;
      IFEND;
    IFEND;

{  Process EXTERNAL_CHARACTERISTICS parameter.

    IF pvt [p$external_characteristics].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$external_characteristics;
      IF pvt [p$external_characteristics].value^.kind = clc$keyword THEN { the only keyword is NORMAL. }
        output_attribute_changes^ [output_attribute_index].external_characteristics :=
              pvt [p$external_characteristics].value^.keyword_value;
      ELSE
        output_attribute_changes^ [output_attribute_index].external_characteristics :=
              pvt [p$external_characteristics].value^.string_value^;
      IFEND;
    IFEND;

{  Process FORMS_CODE parameter.

    IF pvt [p$forms_code].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$forms_code;
      IF pvt [p$forms_code].value^.kind = clc$keyword THEN { the only keyword allowed is NORMAL. }
        output_attribute_changes^ [output_attribute_index].forms_code :=
              pvt [p$forms_code].value^.keyword_value;
      ELSE
        output_attribute_changes^ [output_attribute_index].forms_code :=
              pvt [p$forms_code].value^.string_value^;
      IFEND;
    IFEND;

{  Process LATEST_PRINT_TIME parameter.

    IF pvt [p$latest_print_time].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$latest_print_time;
      IF pvt [p$latest_print_time].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        output_attribute_changes^ [output_attribute_index].latest_print_time.specified := FALSE;
      ELSE
        output_attribute_changes^ [output_attribute_index].latest_print_time.specified := TRUE;
        output_attribute_changes^ [output_attribute_index].latest_print_time.date_time :=
              pvt [p$latest_print_time].value^.date_time_value.value;
      IFEND;
    IFEND;

{  Process OPERATOR_FAMILY parameter.

    IF pvt [p$operator_family].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$output_destination_family;
      output_attribute_changes^ [output_attribute_index].output_destination_family :=
            pvt [p$operator_family].value^.name_value;
    IFEND;

{  Process OPERATOR_USER parameter.

    IF pvt [p$operator_user].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$station_operator;
      output_attribute_changes^ [output_attribute_index].station_operator :=
            pvt [p$operator_user].value^.name_value;
    IFEND;

{  Process OUTPUT_CLASS parameter.

    IF pvt [p$output_class].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$output_class;
      output_attribute_changes^ [output_attribute_index].output_class :=
            pvt [p$output_class].value^.keyword_value;
    IFEND;

{  Process OUTPUT_DEFERRED_BY_OPERATOR parameter.

    IF pvt [p$output_deferred_by_operator].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$output_deferred_by_operator;
      output_attribute_changes^ [output_attribute_index].output_deferred_by_operator :=
            pvt [p$output_deferred_by_operator].value^.boolean_value.value;
    IFEND;

{  Process OUTPUT_DEFERRED_BY_USER parameter.

    IF pvt [p$output_deferred_by_user].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$output_deferred_by_user;
      output_attribute_changes^ [output_attribute_index].output_deferred_by_user :=
            pvt [p$output_deferred_by_user].value^.boolean_value.value;
    IFEND;

{  Process OUTPUT_DESTINATION parameter.

    IF pvt [p$output_destination].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$output_destination;
      IF pvt [p$output_destination].value^.kind = clc$name THEN
        output_attribute_changes^ [output_attribute_index].output_destination :=
              pvt [p$output_destination].value^.name_value;
      ELSE
        output_attribute_changes^ [output_attribute_index].output_destination :=
              pvt [p$output_destination].value^.string_value^;
      IFEND;
    IFEND;

{  Process OUTPUT_DESTINATION_USAGE parameter.

    IF pvt [p$output_destination_usage].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$output_destination_usage;
      IF pvt [p$output_destination_usage].value^.kind = clc$name THEN
        output_attribute_changes^ [output_attribute_index].output_destination_usage :=
              pvt [p$output_destination_usage].value^.name_value;
      ELSE
        output_attribute_changes^ [output_attribute_index].output_destination_usage :=
              pvt [p$output_destination_usage].value^.keyword_value;
      IFEND;
    IFEND;

{  Process OUTPUT_PRIORITY parameter.

    IF pvt [p$output_priority].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$output_priority;
      output_attribute_changes^ [output_attribute_index].output_priority :=
            pvt [p$output_priority].value^.keyword_value;
    IFEND;

{  Process PURGE_DELAY parameter.

    IF pvt [p$purge_delay].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$purge_delay;
      PUSH output_attribute_changes^ [output_attribute_index].purge_delay;
      IF pvt [p$purge_delay].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        output_attribute_changes^ [output_attribute_index].purge_delay^.specified := FALSE;
      ELSE
        output_attribute_changes^ [output_attribute_index].purge_delay^.specified := TRUE;
        output_attribute_changes^ [output_attribute_index].purge_delay^.time_increment :=
              pvt [p$purge_delay].value^.time_increment_value^;
      IFEND;
    IFEND;

{  Process REMOTE_HOST_DIRECTIVE parameter.

    IF pvt [p$remote_host_directive].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$remote_host_directive;
      PUSH output_attribute_changes^ [output_attribute_index].remote_host_directive;
      output_attribute_changes^ [output_attribute_index].remote_host_directive^.size :=
            STRLENGTH (pvt [p$remote_host_directive].value^.string_value^);
      output_attribute_changes^ [output_attribute_index].remote_host_directive^.parameters :=
            pvt [p$remote_host_directive].value^.string_value^;
    IFEND;

{  Process REPRINT_DISPOSITION parameter.

    IF pvt [p$reprint_disposition].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$reprint_disposition;
      IF pvt [p$reprint_disposition].value^.keyword_value = 'REPRINT' THEN
        output_attribute_changes^ [output_attribute_index].reprint_disposition := jmc$rd_reprint_file;
      ELSE { DISCARD is the only other choice. }
        output_attribute_changes^ [output_attribute_index].reprint_disposition := jmc$rd_discard_file;
      IFEND;
    IFEND;

{  Process ROUTING_BANNER parameter.

    IF pvt [p$routing_banner].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$routing_banner;
      output_attribute_changes^ [output_attribute_index].routing_banner :=
            pvt [p$routing_banner].value^.string_value^;
    IFEND;

{  Process SITE_INFORMATION parameter.

    IF pvt [p$site_information].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$site_information;
      PUSH output_attribute_changes^ [output_attribute_index].site_information;
      output_attribute_changes^ [output_attribute_index].site_information^ :=
            pvt [p$site_information].value^.string_value^;
    IFEND;

{  Process STATION parameter.

    IF pvt [p$station].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$station;
      IF pvt [p$station].value^.kind = clc$keyword THEN
        output_attribute_changes^ [output_attribute_index].station := pvt [p$station].value^.keyword_value;
      ELSE
        output_attribute_changes^ [output_attribute_index].station := pvt [p$station].value^.name_value;
      IFEND;
    IFEND;

{  Process USER_INFORMATION parameter.

    IF pvt [p$user_information].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$user_information;
      PUSH output_attribute_changes^ [output_attribute_index].user_information;
      output_attribute_changes^ [output_attribute_index].user_information^ :=
            pvt [p$user_information].value^.string_value^;
    IFEND;

{  Process VERTICAL_PRINT_DENSITY parameter.

    IF pvt [p$vertical_print_density].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$vertical_print_density;
      IF pvt [p$vertical_print_density].value^.keyword_value = 'NONE' THEN
        output_attribute_changes^ [output_attribute_index].vertical_print_density :=
              jmc$vertical_print_density_none;
      ELSEIF pvt [p$vertical_print_density].value^.keyword_value = 'SIX' THEN
        output_attribute_changes^ [output_attribute_index].vertical_print_density :=
              jmc$vertical_print_density_6;
      ELSE { pvt [p$vertical_print_density].value^.keyword_value = 'EIGHT'
        output_attribute_changes^ [output_attribute_index].vertical_print_density :=
              jmc$vertical_print_density_8;
      IFEND;
    IFEND;

{  Process VFU_LOAD_PROCEDURE parameter.

    IF pvt [p$vfu_load_procedure].specified THEN
      output_attribute_index := output_attribute_index + 1;
      output_attribute_changes^ [output_attribute_index].key := jmc$vfu_load_procedure;
      IF pvt [p$vfu_load_procedure].value^.kind = clc$keyword THEN
        output_attribute_changes^ [output_attribute_index].vfu_load_procedure := osc$null_name;
      ELSE
        output_attribute_changes^ [output_attribute_index].vfu_load_procedure :=
              pvt [p$vfu_load_procedure].value^.name_value;
      IFEND;
    IFEND;

{  Process NAME parameter.

    name_list := pvt [p$name].value;

    WHILE name_list <> NIL DO
      jmp$determine_name_kind (name_list^.element_value^.name_value, valid_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      jmp$change_output_attributes (valid_name, output_attribute_changes, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      name_list := name_list^.link;
    WHILEND;

  PROCEND jmp$_change_output_attribute;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$_copy_output_file', EJECT ??

  PROCEDURE [XDCL] jmp$_copy_output_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$copof) copy_output_file, copof (
{   name, n: name = $REQUIRED
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 4, 10, 12, 31, 5, 804],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'OSM$COPOF'], [
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      control_info: fst$copy_control_information,
      ignore_status: ost$status,
      output_fid: amt$file_identifier,
      output_lfn: amt$local_file_name,
      output_name: jmt$name,
      target_fid: amt$file_identifier;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      jmp$close_files_for_copof (output_fid, output_lfn, target_fid, ignore_status);

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    ignore_status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Process NAME parameter.  Validate the supplied name.

    jmp$determine_name_kind (pvt [p$name].value^.name_value, output_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Retrieve the control information required by fsp$copy_data_and_close_files.

    osp$establish_block_exit_hndlr (^abort_handler);
    jmp$open_files_for_copof (output_name, pvt [p$output].value^.file_value^, control_info, output_fid,
          output_lfn, target_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Copy the output file into the target file.  Ignore any ring validation error condition.  Close the files
{ at ring 3.

    fsp$copy_data_and_close_files (output_fid, target_fid, control_info, status);

    IF NOT status.normal THEN
      IF (status.condition = ame$ring_validation_error) THEN
        jmp$close_files_for_copof (output_fid, output_lfn, target_fid, status);
      ELSE
        jmp$close_files_for_copof (output_fid, output_lfn, target_fid, ignore_status);
      IFEND;
    ELSE
      amp$return (output_lfn, status);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND jmp$_copy_output_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$_display_input_attribute', EJECT ??

  PROCEDURE [XDCL] jmp$_display_input_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (osm$disia) display_input_attribute, display_input_attributes, ..
{   disia (
{     name, names, n: list of name = $required
{     display_option, display_options, do: any of
{         key
{           all
{         keyend
{         list of key
{           (comment_banner, cb)
{           (control_family, cf)
{           (control_user, cu)
{           (copies, c)
{           (cpu_time_limit, ctl)
{           (data_mode, dm)
{           (device, d)
{           (earliest_print_time, ept)
{           (earliest_run_time, ert)
{           (external_characteristics, ec)
{           (forms_code, fc)
{           (job_abort_disposition, jad)
{           (job_class, jc)
{           (job_deferred_by_operator, jdbo)
{           (job_deferred_by_user, jdbu)
{           (job_destination, jd)
{           (job_destination_usage, jdu)
{           (job_execution_ring, jer)
{           (job_mode, jm)
{           (job_qualifier, job_qualifiers, jq)
{           (job_recovery_disposition, jrd)
{           (job_size, js)
{           (job_submission_time, jst)
{           (latest_print_time, lpt)
{           (latest_run_time, lrt)
{           (login_account, la)
{           (login_family, lf)
{           (login_project, lp)
{           (login_user, lu)
{           (magnetic_tape_limit, mtl)
{           (maximum_working_set, maxws)
{           (operator_family, of)
{           (operator_user, ou)
{           (originating_application_name, oan)
{           (output_class, oc)
{           (output_deferred_by_user, odbu)
{           (output_destination, ode)
{           (output_destination_usage, odu)
{           (output_disposition, odi)
{           (output_priority, op)
{           (purge_delay, pd)
{           (remote_host_directive, rhd)
{           (routing_banner, rb)
{           (site_information, si)
{           (sru_limit, sl)
{           (station, s)
{           (system_job_name, sjn)
{           (user_information, ui)
{           (user_job_name, ujn)
{           (vertical_print_density, vpd)
{           (vfu_load_procedure, vlp)
{         keyend
{       anyend = osd$disia_display_options, all
{     output, o: file = $OUTPUT
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: 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 .. 103] of clt$keyword_specification,
          recend,
        recend,
        default_name: string (25),
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [93, 5, 18, 11, 23, 19, 737],
    clc$command, 9, 4, 1, 0, 0, 0, 4, 'OSM$DISIA'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 21, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3898, clc$optional_default_parameter, 25, 3
  ],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[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]]
      ],
    3834, [[1, 0, clc$list_type], [3818, 1, clc$max_list_size, 0, FALSE, FALSE]
  ,
        [[1, 0, clc$keyword_type], [103], [
        ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['CB                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['CF                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['COMMENT_BANNER                 ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['CONTROL_FAMILY                 ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['CONTROL_USER                   ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['COPIES                         ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['CPU_TIME_LIMIT                 ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['CTL                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['CU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['D                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
        ['DATA_MODE                      ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
        ['DEVICE                         ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
        ['DM                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['EARLIEST_PRINT_TIME            ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
        ['EARLIEST_RUN_TIME              ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
        ['EC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
        ['EPT                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
        ['ERT                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
        ['EXTERNAL_CHARACTERISTICS       ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
        ['FC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 11],
        ['FORMS_CODE                     ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
        ['JAD                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 12],
        ['JC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 13],
        ['JD                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 16],
        ['JDBO                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 14],
        ['JDBU                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 15],
        ['JDU                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 17],
        ['JER                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 18],
        ['JM                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 19],
        ['JOB_ABORT_DISPOSITION          ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
        ['JOB_CLASS                      ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
        ['JOB_DEFERRED_BY_OPERATOR       ', clc$nominal_entry,
  clc$normal_usage_entry, 14],
        ['JOB_DEFERRED_BY_USER           ', clc$nominal_entry,
  clc$normal_usage_entry, 15],
        ['JOB_DESTINATION                ', clc$nominal_entry,
  clc$normal_usage_entry, 16],
        ['JOB_DESTINATION_USAGE          ', clc$nominal_entry,
  clc$normal_usage_entry, 17],
        ['JOB_EXECUTION_RING             ', clc$nominal_entry,
  clc$normal_usage_entry, 18],
        ['JOB_MODE                       ', clc$nominal_entry,
  clc$normal_usage_entry, 19],
        ['JOB_QUALIFIER                  ', clc$nominal_entry,
  clc$normal_usage_entry, 20],
        ['JOB_QUALIFIERS                 ', clc$alias_entry,
  clc$normal_usage_entry, 20],
        ['JOB_RECOVERY_DISPOSITION       ', clc$nominal_entry,
  clc$normal_usage_entry, 21],
        ['JOB_SIZE                       ', clc$nominal_entry,
  clc$normal_usage_entry, 22],
        ['JOB_SUBMISSION_TIME            ', clc$nominal_entry,
  clc$normal_usage_entry, 23],
        ['JQ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 20],
        ['JRD                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 21],
        ['JS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 22],
        ['JST                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 23],
        ['LA                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 26],
        ['LATEST_PRINT_TIME              ', clc$nominal_entry,
  clc$normal_usage_entry, 24],
        ['LATEST_RUN_TIME                ', clc$nominal_entry,
  clc$normal_usage_entry, 25],
        ['LF                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 27],
        ['LOGIN_ACCOUNT                  ', clc$nominal_entry,
  clc$normal_usage_entry, 26],
        ['LOGIN_FAMILY                   ', clc$nominal_entry,
  clc$normal_usage_entry, 27],
        ['LOGIN_PROJECT                  ', clc$nominal_entry,
  clc$normal_usage_entry, 28],
        ['LOGIN_USER                     ', clc$nominal_entry,
  clc$normal_usage_entry, 29],
        ['LP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 28],
        ['LPT                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 24],
        ['LRT                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 25],
        ['LU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 29],
        ['MAGNETIC_TAPE_LIMIT            ', clc$nominal_entry,
  clc$normal_usage_entry, 30],
        ['MAXIMUM_WORKING_SET            ', clc$nominal_entry,
  clc$normal_usage_entry, 31],
        ['MAXWS                          ', clc$abbreviation_entry,
  clc$normal_usage_entry, 31],
        ['MTL                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 30],
        ['OAN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 34],
        ['OC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 35],
        ['ODBU                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 36],
        ['ODE                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 37],
        ['ODI                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 39],
        ['ODU                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 38],
        ['OF                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 32],
        ['OP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 40],
        ['OPERATOR_FAMILY                ', clc$nominal_entry,
  clc$normal_usage_entry, 32],
        ['OPERATOR_USER                  ', clc$nominal_entry,
  clc$normal_usage_entry, 33],
        ['ORIGINATING_APPLICATION_NAME   ', clc$nominal_entry,
  clc$normal_usage_entry, 34],
        ['OU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 33],
        ['OUTPUT_CLASS                   ', clc$nominal_entry,
  clc$normal_usage_entry, 35],
        ['OUTPUT_DEFERRED_BY_USER        ', clc$nominal_entry,
  clc$normal_usage_entry, 36],
        ['OUTPUT_DESTINATION             ', clc$nominal_entry,
  clc$normal_usage_entry, 37],
        ['OUTPUT_DESTINATION_USAGE       ', clc$nominal_entry,
  clc$normal_usage_entry, 38],
        ['OUTPUT_DISPOSITION             ', clc$nominal_entry,
  clc$normal_usage_entry, 39],
        ['OUTPUT_PRIORITY                ', clc$nominal_entry,
  clc$normal_usage_entry, 40],
        ['PD                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 41],
        ['PURGE_DELAY                    ', clc$nominal_entry,
  clc$normal_usage_entry, 41],
        ['RB                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 43],
        ['REMOTE_HOST_DIRECTIVE          ', clc$nominal_entry,
  clc$normal_usage_entry, 42],
        ['RHD                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 42],
        ['ROUTING_BANNER                 ', clc$nominal_entry,
  clc$normal_usage_entry, 43],
        ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 46],
        ['SI                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 44],
        ['SITE_INFORMATION               ', clc$nominal_entry,
  clc$normal_usage_entry, 44],
        ['SJN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 47],
        ['SL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 45],
        ['SRU_LIMIT                      ', clc$nominal_entry,
  clc$normal_usage_entry, 45],
        ['STATION                        ', clc$nominal_entry,
  clc$normal_usage_entry, 46],
        ['SYSTEM_JOB_NAME                ', clc$nominal_entry,
  clc$normal_usage_entry, 47],
        ['UI                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 48],
        ['UJN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 49],
        ['USER_INFORMATION               ', clc$nominal_entry,
  clc$normal_usage_entry, 48],
        ['USER_JOB_NAME                  ', clc$nominal_entry,
  clc$normal_usage_entry, 49],
        ['VERTICAL_PRINT_DENSITY         ', clc$nominal_entry,
  clc$normal_usage_entry, 50],
        ['VFU_LOAD_PROCEDURE             ', clc$nominal_entry,
  clc$normal_usage_entry, 51],
        ['VLP                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 51],
        ['VPD                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 50]]
        ]
      ]
    ,
    'OSD$DISIA_DISPLAY_OPTIONS',
    'all'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$OUTPUT'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$display_option = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

{ This constant represents the maximum number of display options specified on the
{ command.

    CONST
      max_get_key_count = 51;

    VAR
      display_option_list: ^clt$data_value,
      get_attribute_count: integer,
      get_attribute_key: jmt$attribute_keys,
      get_attribute_number: integer,
      get_keys: jmt$attribute_keys_set,
      input_attribute_options_p: ^jmt$input_attribute_options,
      input_attribute_results_keys_p: ^jmt$results_keys,
      input_attribute_results_p: ^jmt$input_attribute_results,
      input_attribute_results_seq: ^SEQ ( * ),
      name_count: 0 .. clc$max_list_size,
      name_list: ^clt$data_value,
      name_number: 1 .. clc$max_list_size,
      number_of_inputs_found: jmt$job_status_count,
      output_file: clt$file,
      result_size: ost$segment_length,
      work_area_p: ^jmt$work_area;

?? NEWTITLE := 'add_to_attributes', EJECT ??

    PROCEDURE [INLINE] add_to_attributes
      (    get_attribute_key: jmt$attribute_keys);

      IF get_attribute_key IN get_keys THEN
        get_attribute_number := get_attribute_number + 1;
        input_attribute_results_keys_p^ [get_attribute_number] := get_attribute_key;
      IFEND;

    PROCEND add_to_attributes;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  Process NAME parameter.

    name_count := clp$count_list_elements (pvt [p$name].value);
    name_list := pvt [p$name].value;

    PUSH input_attribute_options_p: [1 .. 2];
    input_attribute_options_p^ [1].key := jmc$name_list;
    PUSH input_attribute_options_p^ [1].name_list: [1 .. name_count];
    input_attribute_options_p^ [2].key := jmc$continue_request_to_servers;
    input_attribute_options_p^ [2].continue_request_to_servers := TRUE;

    FOR name_number := 1 TO name_count DO
      jmp$determine_name_kind (name_list^.element_value^.name_value, input_attribute_options_p^ [1].
            name_list^ [name_number], status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      name_list := name_list^.link;
    FOREND;
    get_attribute_number := 0;

{  Process DISPLAY_OPTION parameter.

    IF pvt [p$display_option].value^.kind = clc$keyword THEN { the only keyword allowed is ALL. }
      get_attribute_count := max_get_key_count;
      get_keys := $jmt$attribute_keys_set [jmc$comment_banner, jmc$control_family, jmc$control_user,
            jmc$copies, jmc$cpu_time_limit, jmc$data_mode, jmc$device, jmc$earliest_print_time,
            jmc$earliest_run_time, jmc$external_characteristics, jmc$forms_code, jmc$job_abort_disposition,
            jmc$job_class, jmc$job_deferred_by_operator, jmc$job_deferred_by_user, jmc$job_destination_family,
            jmc$job_destination_usage, jmc$job_execution_ring, jmc$job_mode, jmc$job_qualifier_list,
            jmc$job_recovery_disposition, jmc$job_size, jmc$job_submission_time, jmc$latest_print_time,
            jmc$latest_run_time, jmc$login_account, jmc$login_family, jmc$login_project, jmc$login_user,
            jmc$magnetic_tape_limit, jmc$maximum_working_set, jmc$origin_application_name, jmc$output_class,
            jmc$output_deferred_by_user, jmc$output_destination, jmc$output_destination_family,
            jmc$output_destination_usage, jmc$output_disposition, jmc$output_priority, jmc$purge_delay,
            jmc$remote_host_directive, jmc$routing_banner, jmc$site_information, jmc$sru_limit, jmc$station,
            jmc$station_operator, jmc$system_job_name, jmc$user_information, jmc$user_job_name,
            jmc$vertical_print_density, jmc$vfu_load_procedure];

    ELSE {process the display option list.

      get_keys := $jmt$attribute_keys_set [];
      get_attribute_count := 0;

      display_option_list := pvt [p$display_option].value;
      WHILE display_option_list <> NIL DO
        jmp$get_attribute_index (display_option_list^.element_value^.keyword_value, get_attribute_key);
        IF NOT (get_attribute_key IN get_keys) THEN
          get_keys := get_keys + $jmt$attribute_keys_set [get_attribute_key];
          get_attribute_count := get_attribute_count + 1;
        IFEND;
        display_option_list := display_option_list^.link;
      WHILEND;
    IFEND;

    PUSH input_attribute_results_keys_p: [1 .. get_attribute_count];
    add_to_attributes (jmc$comment_banner);
    add_to_attributes (jmc$control_family);
    add_to_attributes (jmc$control_user);
    add_to_attributes (jmc$copies);
    add_to_attributes (jmc$cpu_time_limit);
    add_to_attributes (jmc$data_mode);
    add_to_attributes (jmc$device);
    add_to_attributes (jmc$earliest_print_time);
    add_to_attributes (jmc$earliest_run_time);
    add_to_attributes (jmc$external_characteristics);
    add_to_attributes (jmc$forms_code);
    add_to_attributes (jmc$job_abort_disposition);
    add_to_attributes (jmc$job_class);
    add_to_attributes (jmc$job_deferred_by_operator);
    add_to_attributes (jmc$job_deferred_by_user);
    add_to_attributes (jmc$job_destination_family);
    add_to_attributes (jmc$job_destination_usage);
    add_to_attributes (jmc$job_execution_ring);
    add_to_attributes (jmc$job_mode);
    add_to_attributes (jmc$job_qualifier_list);
    add_to_attributes (jmc$job_recovery_disposition);
    add_to_attributes (jmc$job_size);
    add_to_attributes (jmc$job_submission_time);
    add_to_attributes (jmc$latest_print_time);
    add_to_attributes (jmc$latest_run_time);
    add_to_attributes (jmc$login_account);
    add_to_attributes (jmc$login_family);
    add_to_attributes (jmc$login_project);
    add_to_attributes (jmc$login_user);
    add_to_attributes (jmc$magnetic_tape_limit);
    add_to_attributes (jmc$maximum_working_set);
    add_to_attributes (jmc$output_destination_family); { operator_family
    add_to_attributes (jmc$station_operator); { operator_user
    add_to_attributes (jmc$origin_application_name);
    add_to_attributes (jmc$output_class);
    add_to_attributes (jmc$output_deferred_by_user);
    add_to_attributes (jmc$output_destination);
    add_to_attributes (jmc$output_destination_usage);
    add_to_attributes (jmc$output_disposition);
    add_to_attributes (jmc$output_priority);
    add_to_attributes (jmc$purge_delay);
    add_to_attributes (jmc$remote_host_directive);
    add_to_attributes (jmc$routing_banner);
    add_to_attributes (jmc$site_information);
    add_to_attributes (jmc$sru_limit);
    add_to_attributes (jmc$station);
    add_to_attributes (jmc$system_job_name);
    add_to_attributes (jmc$user_information);
    add_to_attributes (jmc$user_job_name);
    add_to_attributes (jmc$vertical_print_density);
    add_to_attributes (jmc$vfu_load_procedure);

    jmp$get_result_size (name_count + 1, #SEQ (input_attribute_results_keys_p^), result_size);
    PUSH work_area_p: [[REP result_size OF cell]];
    RESET work_area_p;
    jmp$get_input_attributes (input_attribute_options_p, input_attribute_results_keys_p, work_area_p,
          input_attribute_results_p, number_of_inputs_found, status);

    WHILE (NOT status.normal) AND (status.condition = jme$work_area_too_small) DO
      status.normal := TRUE;

      jmp$get_result_size (number_of_inputs_found + 1, #SEQ (input_attribute_results_keys_p^), result_size);
      PUSH work_area_p: [[REP result_size OF cell]];
      RESET work_area_p;
      jmp$get_input_attributes (input_attribute_options_p, input_attribute_results_keys_p, work_area_p,
            input_attribute_results_p, number_of_inputs_found, status);
    WHILEND;

    IF NOT status.normal THEN
      IF status.condition = jme$no_jobs_were_found THEN
        status.normal := TRUE;
        number_of_inputs_found := 0;
      ELSE
        RETURN;
      IFEND;
    IFEND;

{  Process OUTPUT parameter.

    clp$convert_string_to_file (pvt [p$output].value^.file_value^, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    input_attribute_results_seq := #SEQ (input_attribute_results_p);
    jmp$display_attributes (input_attribute_results_seq, number_of_inputs_found, NIL, NIL, 0, output_file,
          'display_input_attributes', status);

  PROCEND jmp$_display_input_attribute;
?? TITLE := '[XDCL] jmp$_display_job_attribute', EJECT ??

  PROCEDURE [XDCL] jmp$_display_job_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$disja) display_job_attribute, display_job_attributes, disja (
{   display_option, display_options, do: any of
{       key
{         all
{       keyend
{       list of key
{         (comment_banner, cb)
{         (control_family, cf)
{         (control_user, cu)
{         (copies, c)
{         (cyclic_aging_interval, cai)
{         (detached_job_wait_time, djwt)
{         (device, d)
{         (dispatching_priority, dp)
{         (earliest_print_time, ept)
{         (earliest_run_time, ert)
{         (external_characteristics, ec)
{         (forms_code, fc)
{         (job_abort_disposition, jad)
{         (job_class, jc)
{         (job_mode, jm)
{         (job_qualifier, job_qualifiers, jq)
{         (job_recovery_disposition, jrd)
{         (job_size, js)
{         (job_submission_time, jst)
{         (latest_print_time, lpt)
{         (latest_run_time, lrt)
{         (login_account, la)
{         (login_family, lf)
{         (login_project, lp)
{         (login_user, lu)
{         (maximum_working_set, maxws)
{         (minimum_working_set, minws)
{         (operator_family, of)
{         (operator_user, ou)
{         (originating_application_name, oan)
{         (output_class, oc)
{         (output_deferred_by_user, odbu)
{         (output_destination, ode)
{         (output_destination_usage, odu)
{         (output_disposition, odi)
{         (output_priority, op)
{         (page_aging_interval, pai)
{         (purge_delay, pd)
{         (remote_host_directive, rhd)
{         (routing_banner, rb)
{         (sense_switches, ss)
{         (service_class, sc)
{         (site_information, si)
{         (station, s)
{         (system_job_name, sjn)
{         (user_information, ui)
{         (user_job_name, ujn)
{         (vertical_print_density, vpd)
{         (vfu_load_procedure, vlp)
{       hidden_key
{         (qt, queued_time)
{         (destination_family, df)
{         (station_operator, so)
{         (destination_usage, du)
{         (dual_state_route_parameters, dsrp)
{       keyend
{     anyend = all
{   output, o: file = $OUTPUT
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 6] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$keyword_type_qualifier,
              keyword_specs: array [1 .. 109] of clt$keyword_specification,
            recend,
          recend,
          default_value: string (3),
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 2, 25, 15, 41, 18, 718], clc$command, 6, 3, 0, 0, 0, 0, 3, 'OSM$DISJA'],
            [['DISPLAY_OPTION                 ', clc$nominal_entry, 1],
            ['DISPLAY_OPTIONS                ', clc$alias_entry, 1],
            ['DO                             ', clc$abbreviation_entry, 1],
            ['O                              ', clc$abbreviation_entry, 2],
            ['OUTPUT                         ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 4120, clc$optional_default_parameter, 0, 3],

{ PARAMETER 2

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 3

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ 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]]], 4056, [[1, 0, clc$list_type], [4040, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [109], [['C                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['CAI                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['CB                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['CF                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['COMMENT_BANNER                 ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['CONTROL_FAMILY                 ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['CONTROL_USER                   ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['COPIES                         ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['CU                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['CYCLIC_AGING_INTERVAL          ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['D                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['DESTINATION_FAMILY             ', clc$nominal_entry,
            clc$hidden_entry, 51], ['DESTINATION_USAGE              ', clc$nominal_entry, clc$hidden_entry,
            53], ['DETACHED_JOB_WAIT_TIME         ', clc$nominal_entry, clc$normal_usage_entry, 6],
            ['DEVICE                         ', clc$nominal_entry, clc$normal_usage_entry, 7],
            ['DF                             ', clc$abbreviation_entry, clc$hidden_entry, 51],
            ['DISPATCHING_PRIORITY           ', clc$nominal_entry, clc$normal_usage_entry, 8],
            ['DJWT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
            ['DP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
            ['DSRP                           ', clc$abbreviation_entry, clc$hidden_entry, 54],
            ['DU                             ', clc$abbreviation_entry, clc$hidden_entry, 53],
            ['DUAL_STATE_ROUTE_PARAMETERS    ', clc$nominal_entry, clc$hidden_entry, 54],
            ['EARLIEST_PRINT_TIME            ', clc$nominal_entry, clc$normal_usage_entry, 9],
            ['EARLIEST_RUN_TIME              ', clc$nominal_entry, clc$normal_usage_entry, 10],
            ['EC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
            ['EPT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
            ['ERT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
            ['EXTERNAL_CHARACTERISTICS       ', clc$nominal_entry, clc$normal_usage_entry, 11],
            ['FC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
            ['FORMS_CODE                     ', clc$nominal_entry, clc$normal_usage_entry, 12],
            ['JAD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
            ['JC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
            ['JM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
            ['JOB_ABORT_DISPOSITION          ', clc$nominal_entry, clc$normal_usage_entry, 13],
            ['JOB_CLASS                      ', clc$nominal_entry, clc$normal_usage_entry, 14],
            ['JOB_MODE                       ', clc$nominal_entry, clc$normal_usage_entry, 15],
            ['JOB_QUALIFIER                  ', clc$nominal_entry, clc$normal_usage_entry, 16],
            ['JOB_QUALIFIERS                 ', clc$alias_entry, clc$normal_usage_entry, 16],
            ['JOB_RECOVERY_DISPOSITION       ', clc$nominal_entry, clc$normal_usage_entry, 17],
            ['JOB_SIZE                       ', clc$nominal_entry, clc$normal_usage_entry, 18],
            ['JOB_SUBMISSION_TIME            ', clc$nominal_entry, clc$normal_usage_entry, 19],
            ['JQ                             ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
            ['JRD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
            ['JS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
            ['JST                            ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
            ['LA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 22],
            ['LATEST_PRINT_TIME              ', clc$nominal_entry, clc$normal_usage_entry, 20],
            ['LATEST_RUN_TIME                ', clc$nominal_entry, clc$normal_usage_entry, 21],
            ['LF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 23],
            ['LOGIN_ACCOUNT                  ', clc$nominal_entry, clc$normal_usage_entry, 22],
            ['LOGIN_FAMILY                   ', clc$nominal_entry, clc$normal_usage_entry, 23],
            ['LOGIN_PROJECT                  ', clc$nominal_entry, clc$normal_usage_entry, 24],
            ['LOGIN_USER                     ', clc$nominal_entry, clc$normal_usage_entry, 25],
            ['LP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 24],
            ['LPT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 20],
            ['LRT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 21],
            ['LU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 25],
            ['MAXIMUM_WORKING_SET            ', clc$nominal_entry, clc$normal_usage_entry, 26],
            ['MAXWS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 26],
            ['MINIMUM_WORKING_SET            ', clc$nominal_entry, clc$normal_usage_entry, 27],
            ['MINWS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 27],
            ['OAN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 30],
            ['OC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 31],
            ['ODBU                           ', clc$abbreviation_entry, clc$normal_usage_entry, 32],
            ['ODE                            ', clc$abbreviation_entry, clc$normal_usage_entry, 33],
            ['ODI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 35],
            ['ODU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 34],
            ['OF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 28],
            ['OP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 36],
            ['OPERATOR_FAMILY                ', clc$nominal_entry, clc$normal_usage_entry, 28],
            ['OPERATOR_USER                  ', clc$nominal_entry, clc$normal_usage_entry, 29],
            ['ORIGINATING_APPLICATION_NAME   ', clc$nominal_entry, clc$normal_usage_entry, 30],
            ['OU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 29],
            ['OUTPUT_CLASS                   ', clc$nominal_entry, clc$normal_usage_entry, 31],
            ['OUTPUT_DEFERRED_BY_USER        ', clc$nominal_entry, clc$normal_usage_entry, 32],
            ['OUTPUT_DESTINATION             ', clc$nominal_entry, clc$normal_usage_entry, 33],
            ['OUTPUT_DESTINATION_USAGE       ', clc$nominal_entry, clc$normal_usage_entry, 34],
            ['OUTPUT_DISPOSITION             ', clc$nominal_entry, clc$normal_usage_entry, 35],
            ['OUTPUT_PRIORITY                ', clc$nominal_entry, clc$normal_usage_entry, 36],
            ['PAGE_AGING_INTERVAL            ', clc$nominal_entry, clc$normal_usage_entry, 37],
            ['PAI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 37],
            ['PD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 38],
            ['PURGE_DELAY                    ', clc$nominal_entry, clc$normal_usage_entry, 38],
            ['QT                             ', clc$nominal_entry, clc$hidden_entry, 50],
            ['QUEUED_TIME                    ', clc$abbreviation_entry, clc$hidden_entry, 50],
            ['RB                             ', clc$abbreviation_entry, clc$normal_usage_entry, 40],
            ['REMOTE_HOST_DIRECTIVE          ', clc$nominal_entry, clc$normal_usage_entry, 39],
            ['RHD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 39],
            ['ROUTING_BANNER                 ', clc$nominal_entry, clc$normal_usage_entry, 40],
            ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 44],
            ['SC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 42],
            ['SENSE_SWITCHES                 ', clc$nominal_entry, clc$normal_usage_entry, 41],
            ['SERVICE_CLASS                  ', clc$nominal_entry, clc$normal_usage_entry, 42],
            ['SI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 43],
            ['SITE_INFORMATION               ', clc$nominal_entry, clc$normal_usage_entry, 43],
            ['SJN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 45],
            ['SO                             ', clc$abbreviation_entry, clc$hidden_entry, 52],
            ['SS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 41],
            ['STATION                        ', clc$nominal_entry, clc$normal_usage_entry, 44],
            ['STATION_OPERATOR               ', clc$nominal_entry, clc$hidden_entry, 52],
            ['SYSTEM_JOB_NAME                ', clc$nominal_entry, clc$normal_usage_entry, 45],
            ['UI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 46],
            ['UJN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 47],
            ['USER_INFORMATION               ', clc$nominal_entry, clc$normal_usage_entry, 46],
            ['USER_JOB_NAME                  ', clc$nominal_entry, clc$normal_usage_entry, 47],
            ['VERTICAL_PRINT_DENSITY         ', clc$nominal_entry, clc$normal_usage_entry, 48],
            ['VFU_LOAD_PROCEDURE             ', clc$nominal_entry, clc$normal_usage_entry, 49],
            ['VLP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 49],
            ['VPD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 48]]]],
            'all'],

{ PARAMETER 2

      [[1, 0, clc$file_type], '$OUTPUT'],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$display_option = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

{ This constant represents the maximum number of parameters specified on the
{ command.

    CONST
      max_get_key_count = 49;

    VAR
      display_option_list: ^clt$data_value,
      get_attribute_count: 0 .. max_get_key_count,
      get_attribute_number: 0 .. max_get_key_count,
      get_attribute_key: jmt$attribute_keys,
      get_keys: jmt$attribute_keys_set,
      job_attribute_p: ^jmt$job_attribute_results,
      job_attribute_results_pp: ^array [1 .. * ] of ^jmt$job_attribute_results,
      job_attribute_results_seq: ^SEQ ( * ),
      output_file: clt$file;

?? NEWTITLE := 'add_to_attributes', EJECT ??

    PROCEDURE [INLINE] add_to_attributes
      (    get_attribute_key: jmt$attribute_keys);

      IF get_attribute_key IN get_keys THEN
        get_attribute_number := get_attribute_number + 1;
        job_attribute_p^ [get_attribute_number].key := get_attribute_key;

        CASE get_attribute_key OF
        = jmc$job_qualifier_list =
          PUSH job_attribute_p^ [get_attribute_number].job_qualifier_list: [1 .. jmc$maximum_job_qualifiers];

        = jmc$output_disposition =
          PUSH job_attribute_p^ [get_attribute_number].output_disposition.standard_output_path;

        = jmc$purge_delay =
          PUSH job_attribute_p^ [get_attribute_number].purge_delay;

        = jmc$remote_host_directive =
          PUSH job_attribute_p^ [get_attribute_number].remote_host_directive;

        = jmc$site_information =
          PUSH job_attribute_p^ [get_attribute_number].site_information;

        = jmc$user_information =
          PUSH job_attribute_p^ [get_attribute_number].user_information;

        ELSE
        CASEND;
      IFEND;

    PROCEND add_to_attributes;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_keys := $jmt$attribute_keys_set [];
    get_attribute_count := 0;
    get_attribute_number := 0;


    IF pvt [p$display_option].value^.kind = clc$keyword THEN { the only keyword allowed is ALL. }
      get_attribute_count := max_get_key_count;
      get_keys := $jmt$attribute_keys_set [jmc$comment_banner, jmc$control_family, jmc$control_user,
            jmc$copies, jmc$cyclic_aging_interval, jmc$detached_job_wait_time, jmc$device,
            jmc$dispatching_priority, jmc$earliest_print_time, jmc$earliest_run_time,
            jmc$external_characteristics, jmc$forms_code, jmc$job_abort_disposition, jmc$job_class,
            jmc$job_mode, jmc$job_qualifier_list, jmc$job_recovery_disposition, jmc$job_size,
            jmc$job_submission_time, jmc$latest_print_time, jmc$latest_run_time, jmc$login_account,
            jmc$login_family, jmc$login_project, jmc$login_user, jmc$maximum_working_set,
            jmc$minimum_working_set, jmc$origin_application_name, jmc$output_class,
            jmc$output_deferred_by_user, jmc$output_destination, jmc$output_destination_family,
            jmc$output_destination_usage, jmc$output_disposition, jmc$output_priority,
            jmc$page_aging_interval, jmc$purge_delay, jmc$remote_host_directive, jmc$routing_banner,
            jmc$sense_switches, jmc$service_class, jmc$site_information, jmc$station, jmc$station_operator,
            jmc$system_job_name, jmc$user_information, jmc$user_job_name, jmc$vertical_print_density,
            jmc$vfu_load_procedure];

    ELSE

      display_option_list := pvt [p$display_option].value;
      WHILE display_option_list <> NIL DO

{  Some attributes are NOT available in the attribute table - check for them
{  explicitly.

        IF (display_option_list^.element_value^.keyword_value = 'QUEUED_TIME') THEN
          get_attribute_key := jmc$job_submission_time;
        ELSE
          jmp$get_attribute_index (display_option_list^.element_value^.keyword_value, get_attribute_key);
        IFEND;

        IF NOT (get_attribute_key IN get_keys) THEN
          get_keys := get_keys + $jmt$attribute_keys_set [get_attribute_key];
          get_attribute_count := get_attribute_count + 1;
        IFEND;
        display_option_list := display_option_list^.link;
      WHILEND;
    IFEND;

    PUSH job_attribute_p: [1 .. get_attribute_count];
    add_to_attributes (jmc$comment_banner);
    add_to_attributes (jmc$control_family);
    add_to_attributes (jmc$control_user);
    add_to_attributes (jmc$copies);
    add_to_attributes (jmc$cyclic_aging_interval);
    add_to_attributes (jmc$detached_job_wait_time);
    add_to_attributes (jmc$device);
    add_to_attributes (jmc$dispatching_priority);
    add_to_attributes (jmc$earliest_print_time);
    add_to_attributes (jmc$earliest_run_time);
    add_to_attributes (jmc$external_characteristics);
    add_to_attributes (jmc$forms_code);
    add_to_attributes (jmc$job_abort_disposition);
    add_to_attributes (jmc$job_class);
    add_to_attributes (jmc$job_mode);
    add_to_attributes (jmc$job_qualifier_list);
    add_to_attributes (jmc$job_recovery_disposition);
    add_to_attributes (jmc$job_size);
    add_to_attributes (jmc$job_submission_time);
    add_to_attributes (jmc$latest_print_time);
    add_to_attributes (jmc$latest_run_time);
    add_to_attributes (jmc$login_account);
    add_to_attributes (jmc$login_family);
    add_to_attributes (jmc$login_project);
    add_to_attributes (jmc$login_user);
    add_to_attributes (jmc$maximum_working_set);
    add_to_attributes (jmc$minimum_working_set);
    add_to_attributes (jmc$output_destination_family); { operator_family
    add_to_attributes (jmc$station_operator); { operator_user
    add_to_attributes (jmc$origin_application_name);
    add_to_attributes (jmc$output_class);
    add_to_attributes (jmc$output_deferred_by_user);
    add_to_attributes (jmc$output_destination);
    add_to_attributes (jmc$output_destination_usage);
    add_to_attributes (jmc$output_disposition);
    add_to_attributes (jmc$output_priority);
    add_to_attributes (jmc$page_aging_interval);
    add_to_attributes (jmc$purge_delay);
    add_to_attributes (jmc$remote_host_directive);
    add_to_attributes (jmc$routing_banner);
    add_to_attributes (jmc$sense_switches);
    add_to_attributes (jmc$service_class);
    add_to_attributes (jmc$site_information);
    add_to_attributes (jmc$station);
    add_to_attributes (jmc$system_job_name);
    add_to_attributes (jmc$user_information);
    add_to_attributes (jmc$user_job_name);
    add_to_attributes (jmc$vertical_print_density);
    add_to_attributes (jmc$vfu_load_procedure);

    jmp$get_job_attributes (job_attribute_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH job_attribute_results_pp: [1 .. 1];
    job_attribute_results_pp^ [1] := job_attribute_p;
    job_attribute_results_seq := #SEQ (job_attribute_results_pp);

{  Process OUTPUT parameter.

    clp$convert_string_to_file (pvt [p$output].value^.file_value^, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$display_attributes (job_attribute_results_seq, 1, NIL, NIL, 0, output_file, 'display_job_attributes',
          status);

  PROCEND jmp$_display_job_attribute;
?? TITLE := '[XDCL] jmp$_display_job_attribute_def', EJECT ??

  PROCEDURE [XDCL] jmp$_display_job_attribute_def
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$disjad) display_job_attribute_default, display_job_attribute_defaults, disjad (
{   job_mode, jm: any of
{       key
{         all
{       keyend
{       list of key
{         (batch, b)
{         (interactive, i)
{       keyend
{     anyend = all
{   display_option, display_options, do: any of
{       key
{         all
{       keyend
{       list of key
{         (cpu_time_limit, ctl)
{         (job_abort_disposition, jad)
{         (job_class, jc)
{         (job_deferred_by_operator, jdbo)
{         (job_destination_usage, jdu)
{         (job_qualifier, job_qualifiers, jq)
{         (job_recovery_disposition, jrd)
{         (login_family, lf)
{         (magnetic_tape_limit, mtl)
{         (maximum_working_set, maxws)
{         (output_class, oc)
{         (output_deferred_by_operator, odbo)
{         (output_destination_usage, odu)
{         (purge_delay, pd)
{         (site_information, si)
{         (sru_limit, sl)
{         (station, s)
{         (vertical_print_density, vpd)
{       hidden_key
{         (destination_usage, du)
{       keyend
{     anyend = all
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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 .. 4] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: 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 .. 39] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 7, 8, 14, 4, 54, 666],
    clc$command, 8, 4, 0, 0, 0, 0, 4, 'OSM$DISJAD'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['JM                             ',clc$abbreviation_entry, 1],
    ['JOB_MODE                       ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 235,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1530,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    171, [[1, 0, clc$list_type], [155, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [4], [
        ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['BATCH                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['INTERACTIVE                    ', clc$nominal_entry, clc$normal_usage_entry, 2]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[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]]
      ],
    1466, [[1, 0, clc$list_type], [1450, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [39], [
        ['CPU_TIME_LIMIT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['CTL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['DESTINATION_USAGE              ', clc$nominal_entry, clc$hidden_entry, 19],
        ['DU                             ', clc$abbreviation_entry, clc$hidden_entry, 19],
        ['JAD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['JC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['JDBO                           ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['JDU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['JOB_ABORT_DISPOSITION          ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['JOB_CLASS                      ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['JOB_DEFERRED_BY_OPERATOR       ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['JOB_DESTINATION_USAGE          ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['JOB_QUALIFIER                  ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['JOB_QUALIFIERS                 ', clc$alias_entry, clc$normal_usage_entry, 6],
        ['JOB_RECOVERY_DISPOSITION       ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['JQ                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['JRD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
        ['LF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
        ['LOGIN_FAMILY                   ', clc$nominal_entry, clc$normal_usage_entry, 8],
        ['MAGNETIC_TAPE_LIMIT            ', clc$nominal_entry, clc$normal_usage_entry, 9],
        ['MAXIMUM_WORKING_SET            ', clc$nominal_entry, clc$normal_usage_entry, 10],
        ['MAXWS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
        ['MTL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
        ['OC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
        ['ODBO                           ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
        ['ODU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
        ['OUTPUT_CLASS                   ', clc$nominal_entry, clc$normal_usage_entry, 11],
        ['OUTPUT_DEFERRED_BY_OPERATOR    ', clc$nominal_entry, clc$normal_usage_entry, 12],
        ['OUTPUT_DESTINATION_USAGE       ', clc$nominal_entry, clc$normal_usage_entry, 13],
        ['PD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
        ['PURGE_DELAY                    ', clc$nominal_entry, clc$normal_usage_entry, 14],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
        ['SI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
        ['SITE_INFORMATION               ', clc$nominal_entry, clc$normal_usage_entry, 15],
        ['SL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
        ['SRU_LIMIT                      ', clc$nominal_entry, clc$normal_usage_entry, 16],
        ['STATION                        ', clc$nominal_entry, clc$normal_usage_entry, 17],
        ['VERTICAL_PRINT_DENSITY         ', clc$nominal_entry, clc$normal_usage_entry, 18],
        ['VPD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 18]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$job_mode = 1,
      p$display_option = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    CONST
      maximum_attribute_count = 18;

    VAR
      attribute_key: jmt$attribute_keys,
      batch_default_attribute_p: ^jmt$default_attribute_results,
      default_attribute_result_index: 0 .. 2, { 2 is the number of job modes
      default_attribute_results_pp: ^array [1 .. * ] of ^jmt$default_attribute_results,
      default_attribute_results_seq: ^SEQ ( * ),
      display_attribute_count: 0 .. maximum_attribute_count,
      display_attribute_number: 0 .. maximum_attribute_count,
      display_batch: boolean,
      display_interactive: boolean,
      display_keys: jmt$attribute_keys_set,
      display_option_list: ^clt$data_value,
      header_display_list_p: ^jmt$header_display_information,
      interactive_default_attribute_p: ^jmt$default_attribute_results,
      output_file: clt$file,
      set_list: ^clt$data_value;

?? NEWTITLE := 'add_to_attributes', EJECT ??

    PROCEDURE [INLINE] add_to_attributes
      (    attribute_key: jmt$attribute_keys);

      IF attribute_key IN display_keys THEN
        display_attribute_number := display_attribute_number + 1;
        batch_default_attribute_p^ [display_attribute_number].key := attribute_key;
        interactive_default_attribute_p^ [display_attribute_number].key := attribute_key;
        CASE attribute_key OF
        = jmc$site_information =
          PUSH batch_default_attribute_p^ [display_attribute_number].site_information;
          PUSH interactive_default_attribute_p^ [display_attribute_number].site_information;

        = jmc$job_qualifier_list =
          PUSH batch_default_attribute_p^ [display_attribute_number].job_qualifier_list:
                [1 .. jmc$maximum_job_qualifiers];
          PUSH interactive_default_attribute_p^ [display_attribute_number].job_qualifier_list:
                [1 .. jmc$maximum_job_qualifiers];

        = jmc$purge_delay =
          PUSH batch_default_attribute_p^ [display_attribute_number].purge_delay;
          PUSH interactive_default_attribute_p^ [display_attribute_number].purge_delay;
        ELSE
        CASEND;
      IFEND;
    PROCEND add_to_attributes;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    display_keys := $jmt$attribute_keys_set [];
    display_attribute_count := 0;
    display_attribute_number := 0;

    IF pvt [p$display_option].value^.kind = clc$keyword THEN { the only keyword allowed is ALL. }
      display_keys := $jmt$attribute_keys_set [jmc$cpu_time_limit, jmc$job_abort_disposition, jmc$job_class,
            jmc$job_deferred_by_operator, jmc$job_destination_usage, jmc$job_qualifier_list,
            jmc$job_recovery_disposition, jmc$login_family, jmc$magnetic_tape_limit, jmc$maximum_working_set,
            jmc$output_class, jmc$output_deferred_by_operator, jmc$output_destination_usage, jmc$purge_delay,
            jmc$site_information, jmc$sru_limit, jmc$station, jmc$vertical_print_density];

      display_attribute_count := maximum_attribute_count;
    ELSE

      display_option_list := pvt [p$display_option].value;

      WHILE display_option_list <> NIL DO
        jmp$get_attribute_index (display_option_list^.element_value^.keyword_value, attribute_key);
        IF NOT (attribute_key IN display_keys) THEN
          display_attribute_count := display_attribute_count + 1;
          display_keys := display_keys + $jmt$attribute_keys_set [attribute_key];
        IFEND;
        display_option_list := display_option_list^.link;
      WHILEND;
    IFEND;

    PUSH batch_default_attribute_p: [1 .. display_attribute_count];
    PUSH interactive_default_attribute_p: [1 .. display_attribute_count];
    add_to_attributes (jmc$cpu_time_limit);
    add_to_attributes (jmc$job_abort_disposition);
    add_to_attributes (jmc$job_class);
    add_to_attributes (jmc$job_deferred_by_operator);
    add_to_attributes (jmc$job_destination_usage);
    add_to_attributes (jmc$job_qualifier_list);
    add_to_attributes (jmc$job_recovery_disposition);
    add_to_attributes (jmc$login_family);
    add_to_attributes (jmc$magnetic_tape_limit);
    add_to_attributes (jmc$maximum_working_set);
    add_to_attributes (jmc$output_class);
    add_to_attributes (jmc$output_deferred_by_operator);
    add_to_attributes (jmc$output_destination_usage);
    add_to_attributes (jmc$purge_delay);
    add_to_attributes (jmc$site_information);
    add_to_attributes (jmc$sru_limit);
    add_to_attributes (jmc$station);
    add_to_attributes (jmc$vertical_print_density);

    jmp$get_attribute_defaults (jmc$interactive_connected, interactive_default_attribute_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$get_attribute_defaults (jmc$batch, batch_default_attribute_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH default_attribute_results_pp: [1 .. 2];
    PUSH header_display_list_p: [1 .. 2];
    default_attribute_result_index := 0;

{  Process JOB_MODE parameter.

    display_batch := FALSE;
    display_interactive := FALSE;

    IF pvt [p$job_mode].value^.kind = clc$keyword THEN { the only keyword allowed is ALL. }
      display_batch := TRUE;
      display_interactive := TRUE;
    ELSE
      set_list := pvt [p$job_mode].value;
      WHILE set_list <> NIL DO
        IF set_list^.element_value^.keyword_value = 'BATCH' THEN
          display_batch := TRUE;
        ELSE { set_list^.element_value^.keyword_value = 'INTERACTIVE'.
          display_interactive := TRUE;
        IFEND;
        set_list := set_list^.link;
      WHILEND;
    IFEND;

    IF display_batch THEN
      default_attribute_result_index := default_attribute_result_index + 1;
      default_attribute_results_pp^ [default_attribute_result_index] := batch_default_attribute_p;
      header_display_list_p^ [default_attribute_result_index].value := 'Job_Mode: BATCH';
      header_display_list_p^ [default_attribute_result_index].size := 15;
    IFEND;

    IF display_interactive THEN
      default_attribute_result_index := default_attribute_result_index + 1;
      default_attribute_results_pp^ [default_attribute_result_index] := interactive_default_attribute_p;
      header_display_list_p^ [default_attribute_result_index].value := 'Job_Mode: INTERACTIVE';
      header_display_list_p^ [default_attribute_result_index].size := 21;
    IFEND;

    default_attribute_results_seq := #SEQ (default_attribute_results_pp);

{  Process OUTPUT parameter.

    clp$convert_string_to_file (pvt [p$output].value^.file_value^, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$display_attributes (default_attribute_results_seq, default_attribute_result_index,
          header_display_list_p, NIL, 0, output_file, 'display_job_attribute_default', status);


  PROCEND jmp$_display_job_attribute_def;
?? TITLE := '[XDCL] jmp$_display_job_status', EJECT ??

  PROCEDURE [XDCL] jmp$_display_job_status
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$disjs) display_job_status, disjs (
{   name, jn, job_name, job_names, names, n: any of
{       key
{         all
{       keyend
{       list of name
{     anyend = $job(system_job_name)
{   display_option, display_options, do: any of
{       key
{         all
{       keyend
{       list of key
{         (control_family, cf)
{         (control_user, cu)
{         (cpu_time_used, ctu)
{         (display_message, dm)
{         (job_class, jc)
{         (job_class_position, jcp)
{         (job_destination_usage, jdu)
{         (job_initiation_time, jit)
{         (job_mode, jm)
{         (job_state, js)
{         (login_family, lf)
{         (login_user, lu)
{         (operator_action_posted, oap)
{         (page_faults, pf)
{         (system_job_name, sjn)
{         (user_job_name, ujn)
{       hidden_key
{         (client_mainframe_identifier, cmi)
{         (input_file_location, ifl)
{         (server_mainframe_identifier, smi)
{       keyend
{     anyend = osd$disjs_display_options,
{     (cpu_time_used, display_message, job_state, page_faults, system_job_name)
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 12] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          default_value: string (21),
        recend,
        type2: 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$keyword_type_qualifier,
              keyword_specs: array [1 .. 38] of clt$keyword_specification,
            recend,
          recend,
          default_name: string (25),
          default_value: string (73),
        recend,
        type3: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 7, 19, 19, 23, 34, 588], clc$command, 12, 4, 0, 0, 0, 0, 4, 'OSM$DISJS'],
            [['DISPLAY_OPTION                 ', clc$nominal_entry, 2],
            ['DISPLAY_OPTIONS                ', clc$alias_entry, 2],
            ['DO                             ', clc$abbreviation_entry, 2],
            ['JN                             ', clc$alias_entry, 1],
            ['JOB_NAME                       ', clc$alias_entry, 1],
            ['JOB_NAMES                      ', clc$alias_entry, 1],
            ['N                              ', clc$abbreviation_entry, 1],
            ['NAME                           ', clc$nominal_entry, 1],
            ['NAMES                          ', clc$alias_entry, 1],
            ['O                              ', clc$abbreviation_entry, 3],
            ['OUTPUT                         ', clc$nominal_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 21],

{ PARAMETER 2

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 1493, clc$optional_default_parameter, 25, 73],

{ PARAMETER 3

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 4

      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ 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]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]],
            '$job(system_job_name)'],

{ PARAMETER 2

      [[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]]], 1429, [[1, 0, clc$list_type], [1413, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [38], [['CF                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['CLIENT_MAINFRAME_IDENTIFIER    ', clc$nominal_entry,
            clc$hidden_entry, 17], ['CMI                            ', clc$abbreviation_entry,
            clc$hidden_entry, 17], ['CONTROL_FAMILY                 ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['CONTROL_USER                   ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['CPU_TIME_USED                  ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['CTU                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['CU                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['DISPLAY_MESSAGE                ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['DM                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['IFL                            ', clc$abbreviation_entry,
            clc$hidden_entry, 18], ['INPUT_FILE_LOCATION            ', clc$nominal_entry, clc$hidden_entry,
            18], ['JC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
            ['JCP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
            ['JDU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
            ['JIT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
            ['JM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
            ['JOB_CLASS                      ', clc$nominal_entry, clc$normal_usage_entry, 5],
            ['JOB_CLASS_POSITION             ', clc$nominal_entry, clc$normal_usage_entry, 6],
            ['JOB_DESTINATION_USAGE          ', clc$nominal_entry, clc$normal_usage_entry, 7],
            ['JOB_INITIATION_TIME            ', clc$nominal_entry, clc$normal_usage_entry, 8],
            ['JOB_MODE                       ', clc$nominal_entry, clc$normal_usage_entry, 9],
            ['JOB_STATE                      ', clc$nominal_entry, clc$normal_usage_entry, 10],
            ['JS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
            ['LF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
            ['LOGIN_FAMILY                   ', clc$nominal_entry, clc$normal_usage_entry, 11],
            ['LOGIN_USER                     ', clc$nominal_entry, clc$normal_usage_entry, 12],
            ['LU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
            ['OAP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
            ['OPERATOR_ACTION_POSTED         ', clc$nominal_entry, clc$normal_usage_entry, 13],
            ['PAGE_FAULTS                    ', clc$nominal_entry, clc$normal_usage_entry, 14],
            ['PF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
            ['SERVER_MAINFRAME_IDENTIFIER    ', clc$nominal_entry, clc$hidden_entry, 19],
            ['SJN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
            ['SMI                            ', clc$abbreviation_entry, clc$hidden_entry, 19],
            ['SYSTEM_JOB_NAME                ', clc$nominal_entry, clc$normal_usage_entry, 15],
            ['UJN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
            ['USER_JOB_NAME                  ', clc$nominal_entry, clc$normal_usage_entry, 16]]]],
            'OSD$DISJS_DISPLAY_OPTIONS',
            '(cpu_time_used, display_message, job_state, page_faults, system_job_name)'],

{ PARAMETER 3

      [[1, 0, clc$file_type], '$output'],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$name = 1,
      p$display_option = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      get_attribute: jmt$attribute_keys,
      get_keys: jmt$attribute_keys_set,
      display_option_list: ^clt$data_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    get_keys := $jmt$attribute_keys_set [];

    IF pvt [p$display_option].value^.kind = clc$keyword THEN { the only keyword allowed is ALL. }
      get_keys := $jmt$attribute_keys_set [jmc$control_family, jmc$control_user, jmc$cpu_time_used,
            jmc$display_message, jmc$job_class, jmc$job_class_position, jmc$job_destination_usage,
            jmc$job_initiation_time, jmc$job_mode, jmc$job_state, jmc$login_family, jmc$login_user,
            jmc$operator_action_posted, jmc$page_faults, jmc$system_job_name, jmc$user_job_name];
    ELSE

      display_option_list := pvt [p$display_option].value;
      WHILE display_option_list <> NIL DO
        jmp$get_attribute_index (display_option_list^.element_value^.keyword_value, get_attribute);
        IF NOT (get_attribute IN get_keys) THEN
          get_keys := get_keys + $jmt$attribute_keys_set [get_attribute];
        IFEND;
        display_option_list := display_option_list^.link;
      WHILEND;
    IFEND;

    jmp$display_job_status (pvt [p$output].value^.file_value^, get_keys, pvt [p$name].value^, status);

  PROCEND jmp$_display_job_status;
?? TITLE := '[XDCL] jmp$_display_output_attribute', EJECT ??

  PROCEDURE [XDCL] jmp$_display_output_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (osm$disoa) display_output_attribute, display_output_attributes..
{ , ..
{   disoa (
{     name, names, n: list of name = $required
{     display_option, display_options, do: any of
{         key
{           all
{         keyend
{         list of key
{           (comment_banner, cb)
{           (control_family, cf)
{           (control_user, cu)
{           (copies, c)
{           (copies_printed, cp)
{           (data_mode, dm)
{           (device, d)
{           (device_type, dt)
{           (earliest_print_time, ept)
{           (external_characteristics, ec)
{           (file_position, fp)
{           (file_size, fs)
{           (forms_code, fc)
{           (latest_print_time, lpt)
{           (login_account, la)
{           (login_family, lf)
{           (login_project, lp)
{           (login_user, lu)
{           (operator_family, of)
{           (operator_user, ou)
{           (originating_application_name, oan)
{           (output_class, oc)
{           (output_deferred_by_operator, odbo)
{           (output_deferred_by_user, odbu)
{           (output_destination, ode)
{           (output_destination_usage, odu)
{           (output_priority, op)
{           (output_submission_time, ost)
{           (purge_delay, pd)
{           (remote_host_directive, rhd)
{           (routing_banner, rb)
{           (site_information, si)
{           (station, s)
{           (system_file_name, sfn)
{           (system_job_name, sjn)
{           (user_file_name, ufn)
{           (user_information, ui)
{           (user_job_name, ujn)
{           (vertical_print_density, vpd)
{           (vfu_load_procedure, vlp)
{         hidden_key
{           (destination_family, df)
{           (station_operator, so)
{           (destination_usage, du)
{           (qt, queued_time)
{           (dual_state_route_parameters, dsrp)
{         keyend
{       anyend = osd$disoa_display_options, all
{     output, o: file = $OUTPUT
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: 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 .. 90] of clt$keyword_specification,
          recend,
        recend,
        default_name: string (25),
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [93, 5, 18, 11, 24, 0, 903],
    clc$command, 9, 4, 1, 0, 0, 0, 4, 'OSM$DISOA'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 21, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3417, clc$optional_default_parameter, 25, 3
  ],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[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]]
      ],
    3353, [[1, 0, clc$list_type], [3337, 1, clc$max_list_size, 0, FALSE, FALSE]
  ,
        [[1, 0, clc$keyword_type], [90], [
        ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['CB                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['CF                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['COMMENT_BANNER                 ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['CONTROL_FAMILY                 ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['CONTROL_USER                   ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['COPIES                         ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['COPIES_PRINTED                 ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['CP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['CU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['D                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
        ['DATA_MODE                      ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
        ['DESTINATION_FAMILY             ', clc$nominal_entry,
  clc$hidden_entry, 41],
        ['DESTINATION_USAGE              ', clc$nominal_entry,
  clc$hidden_entry, 43],
        ['DEVICE                         ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
        ['DEVICE_TYPE                    ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
        ['DF                             ', clc$abbreviation_entry,
  clc$hidden_entry, 41],
        ['DM                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['DSRP                           ', clc$abbreviation_entry,
  clc$hidden_entry, 45],
        ['DT                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
        ['DU                             ', clc$abbreviation_entry,
  clc$hidden_entry, 43],
        ['DUAL_STATE_ROUTE_PARAMETERS    ', clc$nominal_entry,
  clc$hidden_entry, 45],
        ['EARLIEST_PRINT_TIME            ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
        ['EC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
        ['EPT                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
        ['EXTERNAL_CHARACTERISTICS       ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
        ['FC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 13],
        ['FILE_POSITION                  ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
        ['FILE_SIZE                      ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
        ['FORMS_CODE                     ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
        ['FP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 11],
        ['FS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 12],
        ['LA                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 15],
        ['LATEST_PRINT_TIME              ', clc$nominal_entry,
  clc$normal_usage_entry, 14],
        ['LF                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 16],
        ['LOGIN_ACCOUNT                  ', clc$nominal_entry,
  clc$normal_usage_entry, 15],
        ['LOGIN_FAMILY                   ', clc$nominal_entry,
  clc$normal_usage_entry, 16],
        ['LOGIN_PROJECT                  ', clc$nominal_entry,
  clc$normal_usage_entry, 17],
        ['LOGIN_USER                     ', clc$nominal_entry,
  clc$normal_usage_entry, 18],
        ['LP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 17],
        ['LPT                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 14],
        ['LU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 18],
        ['OAN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 21],
        ['OC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 22],
        ['ODBO                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 23],
        ['ODBU                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 24],
        ['ODE                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 25],
        ['ODU                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 26],
        ['OF                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 19],
        ['OP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 27],
        ['OPERATOR_FAMILY                ', clc$nominal_entry,
  clc$normal_usage_entry, 19],
        ['OPERATOR_USER                  ', clc$nominal_entry,
  clc$normal_usage_entry, 20],
        ['ORIGINATING_APPLICATION_NAME   ', clc$nominal_entry,
  clc$normal_usage_entry, 21],
        ['OST                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 28],
        ['OU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 20],
        ['OUTPUT_CLASS                   ', clc$nominal_entry,
  clc$normal_usage_entry, 22],
        ['OUTPUT_DEFERRED_BY_OPERATOR    ', clc$nominal_entry,
  clc$normal_usage_entry, 23],
        ['OUTPUT_DEFERRED_BY_USER        ', clc$nominal_entry,
  clc$normal_usage_entry, 24],
        ['OUTPUT_DESTINATION             ', clc$nominal_entry,
  clc$normal_usage_entry, 25],
        ['OUTPUT_DESTINATION_USAGE       ', clc$nominal_entry,
  clc$normal_usage_entry, 26],
        ['OUTPUT_PRIORITY                ', clc$nominal_entry,
  clc$normal_usage_entry, 27],
        ['OUTPUT_SUBMISSION_TIME         ', clc$nominal_entry,
  clc$normal_usage_entry, 28],
        ['PD                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 29],
        ['PURGE_DELAY                    ', clc$nominal_entry,
  clc$normal_usage_entry, 29],
        ['QT                             ', clc$nominal_entry,
  clc$hidden_entry, 44],
        ['QUEUED_TIME                    ', clc$abbreviation_entry,
  clc$hidden_entry, 44],
        ['RB                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 31],
        ['REMOTE_HOST_DIRECTIVE          ', clc$nominal_entry,
  clc$normal_usage_entry, 30],
        ['RHD                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 30],
        ['ROUTING_BANNER                 ', clc$nominal_entry,
  clc$normal_usage_entry, 31],
        ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 33],
        ['SFN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 34],
        ['SI                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 32],
        ['SITE_INFORMATION               ', clc$nominal_entry,
  clc$normal_usage_entry, 32],
        ['SJN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 35],
        ['SO                             ', clc$abbreviation_entry,
  clc$hidden_entry, 42],
        ['STATION                        ', clc$nominal_entry,
  clc$normal_usage_entry, 33],
        ['STATION_OPERATOR               ', clc$nominal_entry,
  clc$hidden_entry, 42],
        ['SYSTEM_FILE_NAME               ', clc$nominal_entry,
  clc$normal_usage_entry, 34],
        ['SYSTEM_JOB_NAME                ', clc$nominal_entry,
  clc$normal_usage_entry, 35],
        ['UFN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 36],
        ['UI                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 37],
        ['UJN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 38],
        ['USER_FILE_NAME                 ', clc$nominal_entry,
  clc$normal_usage_entry, 36],
        ['USER_INFORMATION               ', clc$nominal_entry,
  clc$normal_usage_entry, 37],
        ['USER_JOB_NAME                  ', clc$nominal_entry,
  clc$normal_usage_entry, 38],
        ['VERTICAL_PRINT_DENSITY         ', clc$nominal_entry,
  clc$normal_usage_entry, 39],
        ['VFU_LOAD_PROCEDURE             ', clc$nominal_entry,
  clc$normal_usage_entry, 40],
        ['VLP                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 40],
        ['VPD                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 39]]
        ]
      ]
    ,
    'OSD$DISOA_DISPLAY_OPTIONS',
    'all'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$OUTPUT'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$display_option = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

{ This constant represents the maximum number of parameters specified on the
{ command.

    CONST
      max_get_key_count = 40;

    VAR
      display_option_list: ^clt$data_value,
      get_attribute_count: integer,
      get_attribute_key: jmt$attribute_keys,
      get_attribute_number: integer,
      get_keys: jmt$attribute_keys_set,
      name_count: 0 .. clc$max_list_size,
      name_list: ^clt$data_value,
      name_number: 1 .. clc$max_list_size,
      number_of_outputs_found: jmt$output_status_count,
      output_attribute_options_p: ^jmt$output_attribute_options,
      output_attribute_results_keys_p: ^jmt$results_keys,
      output_attribute_results_p: ^jmt$output_attribute_results,
      output_attribute_results_seq: ^SEQ ( * ),
      output_file: clt$file,
      result_size: ost$segment_length,
      work_area_p: ^jmt$work_area;

?? NEWTITLE := 'add_to_attributes', EJECT ??

    PROCEDURE [INLINE] add_to_attributes
      (    get_attribute_key: jmt$attribute_keys);

      IF get_attribute_key IN get_keys THEN
        get_attribute_number := get_attribute_number + 1;
        output_attribute_results_keys_p^ [get_attribute_number] := get_attribute_key;
      IFEND;

    PROCEND add_to_attributes;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  Process NAME parameter.

    name_count := clp$count_list_elements (pvt [p$name].value);
    name_list := pvt [p$name].value;

    PUSH output_attribute_options_p: [1 .. 2];
    output_attribute_options_p^ [1].key := jmc$name_list;
    PUSH output_attribute_options_p^ [1].name_list: [1 .. name_count];
    output_attribute_options_p^ [2].key := jmc$continue_request_to_servers;
    output_attribute_options_p^ [2].continue_request_to_servers := TRUE;

    FOR name_number := 1 TO name_count DO
      jmp$determine_name_kind (name_list^.element_value^.name_value, output_attribute_options_p^ [1].
            name_list^ [name_number], status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      name_list := name_list^.link;
    FOREND;

    get_keys := $jmt$attribute_keys_set [];
    get_attribute_count := 0;
    get_attribute_number := 0;

{  Process DISPLAY_OPTION parameter.

    IF pvt [p$display_option].value^.kind = clc$keyword THEN { the only keyword allowed is ALL. }
      get_attribute_count := max_get_key_count;
      get_keys := $jmt$attribute_keys_set [jmc$comment_banner, jmc$control_family, jmc$control_user,
            jmc$copies, jmc$copies_printed, jmc$data_mode, jmc$device, jmc$device_type,
            jmc$earliest_print_time, jmc$external_characteristics, jmc$file_position, jmc$file_size,
            jmc$forms_code, jmc$latest_print_time, jmc$login_account, jmc$login_family, jmc$login_project,
            jmc$login_user, jmc$origin_application_name, jmc$output_class, jmc$output_deferred_by_operator,
            jmc$output_deferred_by_user, jmc$output_destination, jmc$output_destination_family,
            jmc$output_destination_usage, jmc$output_priority, jmc$output_submission_time, jmc$purge_delay,
            jmc$remote_host_directive, jmc$routing_banner, jmc$site_information, jmc$station,
            jmc$station_operator, jmc$system_file_name, jmc$system_job_name, jmc$user_file_name,
            jmc$user_information, jmc$user_job_name, jmc$vertical_print_density, jmc$vfu_load_procedure];

    ELSE {process the display option list.

      display_option_list := pvt [p$display_option].value;
      WHILE display_option_list <> NIL DO
        jmp$get_attribute_index (display_option_list^.element_value^.keyword_value, get_attribute_key);
        IF NOT (get_attribute_key IN get_keys) THEN
          get_keys := get_keys + $jmt$attribute_keys_set [get_attribute_key];
          get_attribute_count := get_attribute_count + 1;
        IFEND;
        display_option_list := display_option_list^.link;
      WHILEND;
    IFEND;

    PUSH output_attribute_results_keys_p: [1 .. get_attribute_count];
    add_to_attributes (jmc$comment_banner);
    add_to_attributes (jmc$control_family);
    add_to_attributes (jmc$control_user);
    add_to_attributes (jmc$copies);
    add_to_attributes (jmc$copies_printed);
    add_to_attributes (jmc$data_mode);
    add_to_attributes (jmc$device);
    add_to_attributes (jmc$device_type);
    add_to_attributes (jmc$earliest_print_time);
    add_to_attributes (jmc$external_characteristics);
    add_to_attributes (jmc$file_position);
    add_to_attributes (jmc$file_size);
    add_to_attributes (jmc$forms_code);
    add_to_attributes (jmc$latest_print_time);
    add_to_attributes (jmc$login_account);
    add_to_attributes (jmc$login_family);
    add_to_attributes (jmc$login_project);
    add_to_attributes (jmc$login_user);
    add_to_attributes (jmc$output_destination_family); { operator_family
    add_to_attributes (jmc$station_operator); { operator_user
    add_to_attributes (jmc$origin_application_name);
    add_to_attributes (jmc$output_class);
    add_to_attributes (jmc$output_deferred_by_operator);
    add_to_attributes (jmc$output_deferred_by_user);
    add_to_attributes (jmc$output_destination);
    add_to_attributes (jmc$output_destination_usage);
    add_to_attributes (jmc$output_priority);
    add_to_attributes (jmc$output_submission_time);
    add_to_attributes (jmc$purge_delay);
    add_to_attributes (jmc$remote_host_directive);
    add_to_attributes (jmc$routing_banner);
    add_to_attributes (jmc$site_information);
    add_to_attributes (jmc$station);
    add_to_attributes (jmc$system_file_name);
    add_to_attributes (jmc$system_job_name);
    add_to_attributes (jmc$user_file_name);
    add_to_attributes (jmc$user_information);
    add_to_attributes (jmc$user_job_name);
    add_to_attributes (jmc$vertical_print_density);
    add_to_attributes (jmc$vfu_load_procedure);

    jmp$get_result_size (name_count + 1, #SEQ (output_attribute_results_keys_p^), result_size);
    PUSH work_area_p: [[REP result_size OF cell]];
    RESET work_area_p;

    jmp$get_output_attributes (output_attribute_options_p, output_attribute_results_keys_p, work_area_p,
          output_attribute_results_p, number_of_outputs_found, status);

    WHILE (NOT status.normal) AND (status.condition = jme$work_area_too_small) DO
      status.normal := TRUE;

      jmp$get_result_size (number_of_outputs_found + 1, #SEQ (output_attribute_results_keys_p^), result_size);
      PUSH work_area_p: [[REP result_size OF cell]];
      RESET work_area_p;
      jmp$get_output_attributes (output_attribute_options_p, output_attribute_results_keys_p, work_area_p,
            output_attribute_results_p, number_of_outputs_found, status);
    WHILEND;

    IF NOT status.normal THEN
      IF status.condition = jme$no_outputs_were_found THEN
        status.normal := TRUE;
        number_of_outputs_found := 0;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    output_attribute_results_seq := #SEQ (output_attribute_results_p);

{  Process OUTPUT parameter.

    clp$convert_string_to_file (pvt [p$output].value^.file_value^, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$display_attributes (output_attribute_results_seq, number_of_outputs_found, NIL, NIL, 0, output_file,
          'display_output_attributes', status);

  PROCEND jmp$_display_output_attribute;
?? TITLE := '[XDCL] jmp$_display_output_status', EJECT ??

  PROCEDURE [XDCL] jmp$_display_output_status
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (osm$disos) display_output_status, disos (
{     name, names, n: any of
{         key
{           all
{         keyend
{         list of name
{       anyend = all
{     display_option, display_options, do: any of
{         key
{           all
{         keyend
{         list of key
{           (control_family, cf)
{           (control_user, cu)
{           (login_family, lf)
{           (login_user, lu)
{           (output_destination_usage, odu)
{           (output_state, os)
{           (system_file_name, sfn)
{           (system_job_name, sjn)
{           (user_file_name, ufn)
{         keyend
{       anyend = osd$disos_display_options, (output_state system_file_name us..
{ er_file_name)
{     output, o: file = $output
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: 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 .. 18] of clt$keyword_specification,
          recend,
        recend,
        default_name: string (25),
        default_value: string (46),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [93, 3, 26, 10, 58, 11, 963],
    clc$command, 9, 4, 0, 0, 0, 0, 4, 'OSM$DISOS'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 753, clc$optional_default_parameter, 25, 46
  ],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[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]]
      ],
    689, [[1, 0, clc$list_type], [673, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [18], [
        ['CF                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['CONTROL_FAMILY                 ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['CONTROL_USER                   ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['CU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['LF                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['LOGIN_FAMILY                   ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['LOGIN_USER                     ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['LU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['ODU                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['OS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['OUTPUT_DESTINATION_USAGE       ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['OUTPUT_STATE                   ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
        ['SFN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
        ['SJN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
        ['SYSTEM_FILE_NAME               ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
        ['SYSTEM_JOB_NAME                ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
        ['UFN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
        ['USER_FILE_NAME                 ', clc$nominal_entry,
  clc$normal_usage_entry, 9]]
        ]
      ]
    ,
    'OSD$DISOS_DISPLAY_OPTIONS',
    '(output_state system_file_name user_file_name)'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$display_option = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

{ This constant represents the maximum number of parameters specified on the
{ command.

    CONST
      maximum_get_keys = 9;

    TYPE
      file_names = record
        system_file_name: jmt$system_supplied_name,
        user_file_name: jmt$user_supplied_name,
      recend;

    VAR
      display_all_outputs: boolean,
      display_option_list: ^clt$data_value,
      files_found: ^array [1 .. * ] of file_names,
      file_index: jmt$output_status_count,
      get_attribute: jmt$attribute_keys,
      get_keys: jmt$attribute_keys_set,
      get_key_count: 0 .. maximum_get_keys,
      get_key_number: 0 .. maximum_get_keys,
      inserted_system_file_name: boolean,
      inserted_user_file_name: boolean,
      key_number: 0 .. maximum_get_keys,
      name_count: 0 .. clc$max_list_size,
      name_found: boolean,
      name_list: ^clt$data_value,
      name_number: 1 .. clc$max_list_size,
      not_found_list_p: ^jmt$name_list,
      not_found_list_size: jmt$output_status_count,
      number_of_outputs_found: jmt$output_status_count,
      result_size: ost$segment_length,
      status_options_p: ^jmt$output_status_options,
      status_results_keys_p: ^jmt$results_keys,
      status_results_p: ^jmt$output_status_results,
      status_results_seq: ^SEQ ( * ),
      status_work_area_p: ^SEQ ( * ),
      output_file: clt$file;

?? NEWTITLE := 'add_to_attributes', EJECT ??

    PROCEDURE [INLINE] add_to_attributes
      (    get_attribute_key: jmt$attribute_keys);

      IF get_attribute_key IN get_keys THEN
        get_key_number := get_key_number + 1;
        status_results_keys_p^ [get_key_number] := get_attribute_key;
      IFEND;
    PROCEND add_to_attributes;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  Process NAME parameter.

    display_all_outputs := FALSE;
    PUSH status_options_p: [1 .. 2];
    status_options_p^ [1].key := jmc$name_list;
    status_options_p^ [1].name_list := NIL;
    status_options_p^ [2].key := jmc$continue_request_to_servers;
    status_options_p^ [2].continue_request_to_servers := TRUE;

    IF pvt [p$name].value^.kind = clc$keyword THEN { the only keyword allowed is ALL. }
      display_all_outputs := TRUE;
      status_options_p^ [1].key := jmc$null_attribute;

{ Make a guess at the number of names.  Calls to jmp$get_output_status (found below) will
{ ensure getting 'ALL' jobs.

      name_count := 5;
    ELSE

      name_count := clp$count_list_elements (pvt [p$name].value);
      name_list := pvt [p$name].value;
      PUSH status_options_p^ [1].name_list: [1 .. name_count];
      FOR name_number := 1 TO name_count DO
        jmp$determine_name_kind (name_list^.element_value^.name_value, status_options_p^ [1].
              name_list^ [name_number], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        name_list := name_list^.link;
      FOREND;
    IFEND;

    get_keys := $jmt$attribute_keys_set [];
    get_key_number := 0;
    get_key_count := 0;

    IF pvt [p$display_option].value^.kind = clc$keyword THEN { the only keyword allowed is ALL. }
      get_keys := $jmt$attribute_keys_set [jmc$control_family, jmc$control_user, jmc$login_family,
            jmc$login_user, jmc$output_destination_usage, jmc$output_state, jmc$system_file_name,
            jmc$system_job_name, jmc$user_file_name];
      get_key_count := maximum_get_keys;
    ELSE

      display_option_list := pvt [p$display_option].value;
      WHILE display_option_list <> NIL DO
        jmp$get_attribute_index (display_option_list^.element_value^.keyword_value, get_attribute);
        IF NOT (get_attribute IN get_keys) THEN
          get_keys := get_keys + $jmt$attribute_keys_set [get_attribute];
          get_key_count := get_key_count + 1;
        IFEND;
        display_option_list := display_option_list^.link;
      WHILEND;
    IFEND;

    IF NOT display_all_outputs THEN
      inserted_system_file_name := NOT (jmc$system_file_name IN get_keys);
      IF inserted_system_file_name THEN
        get_keys := get_keys + $jmt$attribute_keys_set [jmc$system_file_name];
        get_key_count := get_key_count + 1;
      IFEND;
      inserted_user_file_name := NOT (jmc$user_file_name IN get_keys);
      IF inserted_user_file_name THEN
        get_keys := get_keys + $jmt$attribute_keys_set [jmc$user_file_name];
        get_key_count := get_key_count + 1;
      IFEND;
    IFEND;

    PUSH status_results_keys_p: [1 .. get_key_count];
    add_to_attributes (jmc$control_family);
    add_to_attributes (jmc$control_user);
    add_to_attributes (jmc$login_family);
    add_to_attributes (jmc$login_user);
    add_to_attributes (jmc$output_destination_usage);
    add_to_attributes (jmc$output_state);
    add_to_attributes (jmc$system_file_name);
    add_to_attributes (jmc$system_job_name);
    add_to_attributes (jmc$user_file_name);

    jmp$get_result_size (name_count * 2, #SEQ (status_results_keys_p^), result_size);
    PUSH status_work_area_p: [[REP result_size OF cell]];
    RESET status_work_area_p;
    jmp$get_output_status (status_options_p, status_results_keys_p, status_work_area_p, status_results_p,
          number_of_outputs_found, status);

    WHILE (NOT status.normal) AND (status.condition = jme$work_area_too_small) DO
      status.normal := TRUE;
      jmp$get_result_size (number_of_outputs_found + 10, #SEQ (status_results_keys_p^), result_size);
      PUSH status_work_area_p: [[REP result_size OF cell]];
      RESET status_work_area_p;
      jmp$get_output_status (status_options_p, status_results_keys_p, status_work_area_p, status_results_p,
            number_of_outputs_found, status);

    WHILEND;
    IF NOT status.normal THEN
      IF status.condition = jme$no_outputs_were_found THEN
        status.normal := TRUE;
        number_of_outputs_found := 0;
      ELSE
        RETURN;
      IFEND;
    IFEND;

{ Build a list of the output names that were not found.

    not_found_list_size := 0;

    IF NOT display_all_outputs THEN
      PUSH not_found_list_p: [1 .. name_count];

      IF number_of_outputs_found > 0 THEN
        PUSH files_found: [1 .. number_of_outputs_found];
        FOR file_index := 1 TO number_of_outputs_found DO
          FOR key_number := 1 TO UPPERBOUND (status_results_p^ [file_index]^) DO
            IF status_results_p^ [file_index]^ [key_number].key = jmc$system_file_name THEN
              files_found^ [file_index].system_file_name := status_results_p^ [file_index]^ [key_number].
                    system_file_name;
              IF inserted_system_file_name THEN
                status_results_p^ [file_index]^ [key_number].key := jmc$null_attribute;
              IFEND;
            ELSEIF status_results_p^ [file_index]^ [key_number].key = jmc$user_file_name THEN
              files_found^ [file_index].user_file_name := status_results_p^ [file_index]^ [key_number].
                    user_file_name;
              IF inserted_user_file_name THEN
                status_results_p^ [file_index]^ [key_number].key := jmc$null_attribute;
              IFEND;
            IFEND;
          FOREND;
        FOREND;
      IFEND;

      FOR name_number := 1 TO name_count DO
        name_found := FALSE;
        IF status_options_p^ [1].name_list^ [name_number].kind = jmc$system_supplied_name THEN
          file_index := 1;
          WHILE NOT name_found AND (file_index <= number_of_outputs_found) DO
            name_found := (status_options_p^ [1].name_list^ [name_number].system_supplied_name =
                  files_found^ [file_index].system_file_name);
            file_index := file_index + 1;
          WHILEND;
        ELSE
          file_index := 1;
          WHILE NOT name_found AND (file_index <= number_of_outputs_found) DO
            name_found := (status_options_p^ [1].name_list^ [name_number].
                  user_supplied_name = files_found^ [file_index].user_file_name);
            file_index := file_index + 1;
          WHILEND;
        IFEND;
        IF NOT name_found THEN
          not_found_list_size := not_found_list_size + 1;
          not_found_list_p^ [not_found_list_size] := status_options_p^ [1].name_list^ [name_number];
        IFEND;
      FOREND;
    IFEND;

    IF not_found_list_size = 0 THEN
      not_found_list_p := NIL;
    IFEND;

    status_results_seq := #SEQ (status_results_p);

{  Process OUTPUT parameter.

    clp$convert_string_to_file (pvt [p$output].value^.file_value^, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$display_attributes (status_results_seq, number_of_outputs_found, NIL, not_found_list_p,
          not_found_list_size, output_file, 'display_output_status', status);

  PROCEND jmp$_display_output_status;
?? TITLE := '[XDCL] jmp$_job', EJECT ??

  PROCEDURE [XDCL] jmp$_job
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$job) job (
{   user_job_name, jn, job_name, ujn: name = $job(login_user)
{   cpu_time_limit, ctl: any of
{       key
{         system_default, unlimited
{       keyend
{       integer jmc$lowest_cpu_time_limit..jmc$highest_cpu_time_limit
{     anyend = $optional
{   earliest_run_time, ert: date_time = $optional
{   job_abort_disposition, jad: key
{       (restart, r)
{       (terminate, t)
{     keyend = $optional
{   job_class, jc: name = $optional
{   job_deferred_by_user, jdbu: boolean = false
{   job_destination_usage, jdu: key
{       ve, ve_family, ve_local
{     keyend = $optional
{   job_execution_ring, jer: integer osc$sj_ring_1..osc$user_ring_2 = $optional
{   job_qualifier, job_qualifiers, jq: any of
{       key
{         none, system_default
{       keyend
{       list 1..jmc$maximum_job_qualifiers of name
{     anyend = $optional
{   job_recovery_disposition, jrd: key
{       (continue, c)
{       (restart, r)
{       (terminate, t)
{     keyend = $optional
{   latest_run_time, lrt: date_time = $optional
{   login_account, la: name = $job(login_account)
{   login_project, lp: name = $job(login_project)
{   magnetic_tape_limit, mtl: any of
{       key
{         system_default, unlimited, unspecified
{       keyend
{       integer jmc$lowest_magnetic_tape_limit..jmc$highest_magnetic_tape_limit
{     anyend = $optional
{   maximum_working_set, maxws: any of
{       key
{         system_default, unlimited
{       keyend
{       integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{     anyend = $optional
{   operator_family, of: name = $job(operator_family)
{   operator_user, ou: name = $job(operator_user)
{   output_disposition, odi: any of
{       key
{         (discard_all_output, dao)
{         (discard_standard_output, dso)
{         (printer, p)
{         (wait_queue, wt, wq)
{       keyend
{       file
{     anyend = printer
{   sru_limit, sl: any of
{       key
{         system_default, unlimited
{       keyend
{       integer jmc$lowest_sru_limit..jmc$highest_sru_limit
{     anyend = $optional
{   station, s: any of
{       key
{         automatic
{       keyend
{       name
{     anyend = $job(station)
{   substitution_mark, sm: any of
{       key
{         none
{       keyend
{       string 1
{     anyend = none
{   user_information, ui: string 0..jmc$user_information_size = $job(user_information)
{   system_job_name, sjn: (VAR) any of
{       string
{       name
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 50] of clt$pdt_parameter_name,
      parameters: array [1 .. 24] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (16),
      recend,
      type2: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$date_time_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type9: 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 .. 2] 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$name_type_qualifier,
          recend,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$date_time_type_qualifier,
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (19),
      recend,
      type13: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (19),
      recend,
      type14: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type15: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (21),
      recend,
      type17: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (19),
      recend,
      type18: 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 .. 9] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
        default_value: string (7),
      recend,
      type19: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type20: 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$name_type_qualifier,
        recend,
        default_value: string (13),
      recend,
      type21: 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$string_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type22: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (22),
      recend,
      type23: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type24: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 1, 9, 14, 49, 8, 215],
    clc$command, 50, 24, 0, 0, 0, 1, 24, 'OSM$JOB'], [
    ['CPU_TIME_LIMIT                 ',clc$nominal_entry, 2],
    ['CTL                            ',clc$abbreviation_entry, 2],
    ['EARLIEST_RUN_TIME              ',clc$nominal_entry, 3],
    ['ERT                            ',clc$abbreviation_entry, 3],
    ['JAD                            ',clc$abbreviation_entry, 4],
    ['JC                             ',clc$abbreviation_entry, 5],
    ['JDBU                           ',clc$abbreviation_entry, 6],
    ['JDU                            ',clc$abbreviation_entry, 7],
    ['JER                            ',clc$abbreviation_entry, 8],
    ['JN                             ',clc$alias_entry, 1],
    ['JOB_ABORT_DISPOSITION          ',clc$nominal_entry, 4],
    ['JOB_CLASS                      ',clc$nominal_entry, 5],
    ['JOB_DEFERRED_BY_USER           ',clc$nominal_entry, 6],
    ['JOB_DESTINATION_USAGE          ',clc$nominal_entry, 7],
    ['JOB_EXECUTION_RING             ',clc$nominal_entry, 8],
    ['JOB_NAME                       ',clc$alias_entry, 1],
    ['JOB_QUALIFIER                  ',clc$nominal_entry, 9],
    ['JOB_QUALIFIERS                 ',clc$alias_entry, 9],
    ['JOB_RECOVERY_DISPOSITION       ',clc$nominal_entry, 10],
    ['JQ                             ',clc$abbreviation_entry, 9],
    ['JRD                            ',clc$abbreviation_entry, 10],
    ['LA                             ',clc$abbreviation_entry, 12],
    ['LATEST_RUN_TIME                ',clc$nominal_entry, 11],
    ['LOGIN_ACCOUNT                  ',clc$nominal_entry, 12],
    ['LOGIN_PROJECT                  ',clc$nominal_entry, 13],
    ['LP                             ',clc$abbreviation_entry, 13],
    ['LRT                            ',clc$abbreviation_entry, 11],
    ['MAGNETIC_TAPE_LIMIT            ',clc$nominal_entry, 14],
    ['MAXIMUM_WORKING_SET            ',clc$nominal_entry, 15],
    ['MAXWS                          ',clc$abbreviation_entry, 15],
    ['MTL                            ',clc$abbreviation_entry, 14],
    ['ODI                            ',clc$abbreviation_entry, 18],
    ['OF                             ',clc$abbreviation_entry, 16],
    ['OPERATOR_FAMILY                ',clc$nominal_entry, 16],
    ['OPERATOR_USER                  ',clc$nominal_entry, 17],
    ['OU                             ',clc$abbreviation_entry, 17],
    ['OUTPUT_DISPOSITION             ',clc$nominal_entry, 18],
    ['S                              ',clc$abbreviation_entry, 20],
    ['SJN                            ',clc$abbreviation_entry, 23],
    ['SL                             ',clc$abbreviation_entry, 19],
    ['SM                             ',clc$abbreviation_entry, 21],
    ['SRU_LIMIT                      ',clc$nominal_entry, 19],
    ['STATION                        ',clc$nominal_entry, 20],
    ['STATUS                         ',clc$nominal_entry, 24],
    ['SUBSTITUTION_MARK              ',clc$nominal_entry, 21],
    ['SYSTEM_JOB_NAME                ',clc$nominal_entry, 23],
    ['UI                             ',clc$abbreviation_entry, 22],
    ['UJN                            ',clc$abbreviation_entry, 1],
    ['USER_INFORMATION               ',clc$nominal_entry, 22],
    ['USER_JOB_NAME                  ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [50, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 16],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 6
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 7
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 9
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 122,
  clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 12
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 19],
{ PARAMETER 13
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 19],
{ PARAMETER 14
    [28, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 158,
  clc$optional_parameter, 0, 0],
{ PARAMETER 15
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 16
    [34, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 21],
{ PARAMETER 17
    [35, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 19],
{ PARAMETER 18
    [37, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 363,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 19
    [42, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 20
    [43, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 0, 13],
{ PARAMETER 21
    [45, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 72,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 22
    [49, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 22],
{ PARAMETER 23
    [46, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 33,
  clc$optional_parameter, 0, 0],
{ PARAMETER 24
    [44, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    '$job(login_user)'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_cpu_time_limit, jmc$highest_cpu_time_limit, 10]]
    ],
{ PARAMETER 3
    [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [clc$past
  , clc$present, clc$future]]],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [4], [
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['RESTART                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 5
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 6
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 7
    [[1, 0, clc$keyword_type], [3], [
    ['VE                             ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['VE_FAMILY                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['VE_LOCAL                       ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 8
    [[1, 0, clc$integer_type], [osc$sj_ring_1, osc$user_ring_2, 10]],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, jmc$maximum_job_qualifiers, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 10
    [[1, 0, clc$keyword_type], [6], [
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CONTINUE                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['RESTART                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 11
    [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [clc$past
  , clc$present, clc$future]]],
{ PARAMETER 12
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    '$job(login_account)'],
{ PARAMETER 13
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    '$job(login_project)'],
{ PARAMETER 14
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_magnetic_tape_limit, jmc$highest_magnetic_tape_limit, 10]]
    ],
{ PARAMETER 15
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_working_set_size, jmc$highest_working_set_size, 10]]
    ],
{ PARAMETER 16
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    '$job(operator_family)'],
{ PARAMETER 17
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    '$job(operator_user)'],
{ PARAMETER 18
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    340, [[1, 0, clc$keyword_type], [9], [
      ['DAO                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DISCARD_ALL_OUTPUT             ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['DISCARD_STANDARD_OUTPUT        ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['DSO                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['PRINTER                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['WAIT_QUEUE                     ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['WQ                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['WT                             ', clc$alias_entry, clc$normal_usage_entry, 4]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'printer'],
{ PARAMETER 19
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_sru_limit, jmc$highest_sru_limit, 10]]
    ],
{ PARAMETER 20
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['AUTOMATIC                      ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    '$job(station)'],
{ PARAMETER 21
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$string_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [1, 1, FALSE]]
    ,
    'none'],
{ PARAMETER 22
    [[1, 0, clc$string_type], [0, jmc$user_information_size, FALSE],
    '$job(user_information)'],
{ PARAMETER 23
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 24
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$user_job_name = 1,
      p$cpu_time_limit = 2,
      p$earliest_run_time = 3,
      p$job_abort_disposition = 4,
      p$job_class = 5,
      p$job_deferred_by_user = 6,
      p$job_destination_usage = 7,
      p$job_execution_ring = 8,
      p$job_qualifier = 9,
      p$job_recovery_disposition = 10,
      p$latest_run_time = 11,
      p$login_account = 12,
      p$login_project = 13,
      p$magnetic_tape_limit = 14,
      p$maximum_working_set = 15,
      p$operator_family = 16,
      p$operator_user = 17,
      p$output_disposition = 18,
      p$sru_limit = 19,
      p$station = 20,
      p$substitution_mark = 21,
      p$user_information = 22,
      p$system_job_name = 23,
      p$status = 24;

    VAR
      pvt: array [1 .. 24] of clt$parameter_value;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (file_id, ignore_status);
      IF return_file THEN
        amp$return (unique_file_name, ignore_status);
        return_file := FALSE;
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    CONST
      max_submission_options = p$user_information,
      max_submission_option_index = max_submission_options + submission_option_offset,
      submission_option_offset = 3;

    VAR
      access_mode: clt$data_access_mode,
      block: ^clt$block,
      class: clt$variable_class,
      default_job_attributes_p: ^jmt$default_attribute_results,
      evaluation_method: clt$expression_eval_method,
      file_attachment: array [1 .. 2] of fst$attachment_option,
      file_id: amt$file_identifier,
      ignore_byte_address: amt$file_byte_address,
      ignore_can_be_echoed: boolean,
      ignore_ready_index: integer,
      index: p$user_job_name .. p$user_information,
      interpreter_mode: clt$interpreter_modes,
      job_qualifier_count: 0 .. clc$max_list_size,
      job_qualifier_index: 1 .. clc$max_list_size,
      job_qualifier_options: ^clt$data_value,
      job_submission_options: ^jmt$job_submission_options,
      line_header: ^clt$input_data_line_header,
      line_text: ^clt$command_line,
      local_status: ost$status,
      number_of_submission_options: 0 .. max_submission_options,
      return_file: boolean,
      search_mode: clt$command_search_modes,
      statement_area: ^clt$collect_statement_area,
      submission_option_index: submission_option_offset .. max_submission_option_index,
      substitution_mark: clt$substitution_mark,
      system_job_name: clt$data_value,
      system_supplied_job_name: jmt$system_supplied_name,
      type_information: clt$type_information,
      type_specification: ^clt$type_specification,
      unique_file_name: ost$name,
      user_id: ost$user_identification,
      value: ^clt$data_value,
      wait_list_p: ^ost$i_wait_list,
      work_area_p: ^^clt$work_area;


    status.normal := TRUE;
    substitution_mark.specified := FALSE;
    clp$get_interpreter_mode (interpreter_mode);

    IF interpreter_mode <> clc$skip_mode THEN
      clp$find_current_block (block);
      clp$get_command_search_mode (search_mode);
      IF (search_mode = clc$exclusive_command_search) AND block^.use_command_search_mode THEN
        osp$set_status_abnormal ('CL', cle$not_allowed_in_exclusive, 'JOB/JOBEND', status);
        RETURN;
      IFEND;

      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pmp$get_user_identification (user_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{  Initialize submission_option_index to account for the first three elements of the
{  job_submission_options array.  These elements are always required to define the user
{  information regarding the job.

      submission_option_index := submission_option_offset;
      number_of_submission_options := 0;

      FOR index := p$user_job_name TO p$user_information DO
        IF (index <> p$substitution_mark) THEN
          CASE pvt [index].passing_method OF
          = clc$pass_by_value =
            IF pvt [index].value <> NIL THEN
              number_of_submission_options := number_of_submission_options + 1;
            IFEND;
          = clc$pass_by_reference =
            IF pvt [index].variable <> NIL THEN
              number_of_submission_options := number_of_submission_options + 1;
            IFEND;
          CASEND;
        IFEND;
      FOREND;

      PUSH job_submission_options: [1 .. submission_option_index + number_of_submission_options];
      job_submission_options^ [1].key := jmc$login_command_supplied;
      job_submission_options^ [1].login_command_supplied := FALSE;
      job_submission_options^ [2].key := jmc$login_user;
      job_submission_options^ [2].login_user := user_id.user;
      job_submission_options^ [3].key := jmc$login_family;
      job_submission_options^ [3].login_family := user_id.family;

{  Process LOGIN_ACCOUNT parameter.

      submission_option_index := submission_option_index + 1;
      job_submission_options^ [submission_option_index].key := jmc$login_account;
      job_submission_options^ [submission_option_index].login_account :=
            pvt [p$login_account].value^.name_value;

{  Process LOGIN_PROJECT parameter.

      submission_option_index := submission_option_index + 1;
      job_submission_options^ [submission_option_index].key := jmc$login_project;
      job_submission_options^ [submission_option_index].login_project :=
            pvt [p$login_project].value^.name_value;

{  Process CPU_TIME_LIMIT parameter.

      IF pvt [p$cpu_time_limit].specified THEN
        submission_option_index := submission_option_index + 1;
        job_submission_options^ [submission_option_index].key := jmc$cpu_time_limit;
        IF pvt [p$cpu_time_limit].value^.kind = clc$integer THEN
          job_submission_options^ [submission_option_index].cpu_time_limit :=
                pvt [p$cpu_time_limit].value^.integer_value.value;
        ELSE { clc$keyword.
          IF pvt [p$cpu_time_limit].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
            job_submission_options^ [submission_option_index].cpu_time_limit :=
                  jmc$system_default_cpu_time_lim;
          ELSE { IF value.name.value = 'UNLIMITED' THEN
            job_submission_options^ [submission_option_index].cpu_time_limit := jmc$unlimited_cpu_time_limit;
          IFEND;
        IFEND;
      IFEND;

{  Process EARLIEST_RUN_TIME parameter.

      IF pvt [p$earliest_run_time].specified THEN
        submission_option_index := submission_option_index + 1;
        job_submission_options^ [submission_option_index].key := jmc$earliest_run_time;
        job_submission_options^ [submission_option_index].earliest_run_time.specified := TRUE;
        job_submission_options^ [submission_option_index].earliest_run_time.date_time :=
              pvt [p$earliest_run_time].value^.date_time_value.value;
      IFEND;

{  Process JOB_ABORT_DISPOSITION parameter.

      IF pvt [p$job_abort_disposition].specified THEN
        submission_option_index := submission_option_index + 1;
        job_submission_options^ [submission_option_index].key := jmc$job_abort_disposition;
        IF pvt [p$job_abort_disposition].value^.keyword_value = 'RESTART' THEN
          job_submission_options^ [submission_option_index].job_abort_disposition := jmc$restart_on_abort;
        ELSE { TERMINATE is the only other choice. }
          job_submission_options^ [submission_option_index].job_abort_disposition := jmc$terminate_on_abort;
        IFEND;
      IFEND;

{ Process JOB_CLASS parameter.

      IF pvt [p$job_class].specified THEN
        submission_option_index := submission_option_index + 1;
        job_submission_options^ [submission_option_index].key := jmc$job_class;
        job_submission_options^ [submission_option_index].job_class := pvt [p$job_class].value^.name_value;
      IFEND;

{  Process JOB_DEFERRED_BY_USER parameter.

      submission_option_index := submission_option_index + 1;
      job_submission_options^ [submission_option_index].key := jmc$job_deferred_by_user;
      job_submission_options^ [submission_option_index].job_deferred_by_user :=
            pvt [p$job_deferred_by_user].value^.boolean_value.value;

{ Process JOB_DESTINATION_USAGE parameter.

      IF pvt [p$job_destination_usage].specified THEN
        submission_option_index := submission_option_index + 1;
        job_submission_options^ [submission_option_index].key := jmc$job_destination_usage;
        job_submission_options^ [submission_option_index].job_destination_usage :=
              pvt [p$job_destination_usage].value^.keyword_value;
      IFEND;

{  Process JOB_EXECUTION_RING parameter.

      IF pvt [p$job_execution_ring].specified THEN
        submission_option_index := submission_option_index + 1;
        job_submission_options^ [submission_option_index].key := jmc$job_execution_ring;
        job_submission_options^ [submission_option_index].job_execution_ring :=
              pvt [p$job_execution_ring].value^.integer_value.value;
      IFEND;

{  Process JOB_QUALIFIER parameter.

      IF pvt [p$job_qualifier].specified THEN
        submission_option_index := submission_option_index + 1;
        job_submission_options^ [submission_option_index].key := jmc$job_qualifier_list;
        IF pvt [p$job_qualifier].value^.kind = clc$keyword THEN
          IF pvt [p$job_qualifier].value^.keyword_value = 'NONE' THEN
            PUSH job_submission_options^ [submission_option_index].job_qualifier_list: [1 .. 1];
            job_submission_options^ [submission_option_index].job_qualifier_list^ [1] := osc$null_name;
          ELSE { keyword_value = 'SYSTEM_DEFAULT'}
            PUSH default_job_attributes_p: [1 .. 1];
            default_job_attributes_p^ [1].key := jmc$job_qualifier_list;
            PUSH job_submission_options^ [submission_option_index].job_qualifier_list:
                  [1 .. jmc$maximum_job_qualifiers];
            default_job_attributes_p^ [1].job_qualifier_list :=
                  job_submission_options^ [submission_option_index].job_qualifier_list;
            jmp$get_attribute_defaults (jmc$batch, default_job_attributes_p, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        ELSE
          job_qualifier_count := clp$count_list_elements (pvt [p$job_qualifier].value);
          PUSH job_submission_options^ [submission_option_index].job_qualifier_list:
                [1 .. job_qualifier_count];
          job_qualifier_options := pvt [p$job_qualifier].value;
          FOR job_qualifier_index := 1 TO job_qualifier_count DO
            job_submission_options^ [submission_option_index].job_qualifier_list^ [job_qualifier_index] :=
                  job_qualifier_options^.element_value^.name_value;
            job_qualifier_options := job_qualifier_options^.link;
          FOREND;
        IFEND;
      IFEND;

{  Process JOB_RECOVERY_DISPOSITION parameter.

      IF pvt [p$job_recovery_disposition].specified THEN
        submission_option_index := submission_option_index + 1;
        job_submission_options^ [submission_option_index].key := jmc$job_recovery_disposition;
        IF pvt [p$job_recovery_disposition].value^.keyword_value = 'RESTART' THEN
          job_submission_options^ [submission_option_index].job_recovery_disposition :=
                jmc$restart_on_recovery;
        ELSEIF pvt [p$job_recovery_disposition].value^.keyword_value = 'CONTINUE' THEN
          job_submission_options^ [submission_option_index].job_recovery_disposition :=
                jmc$continue_on_recovery;
        ELSE { pvt [p$job_recovery_disposition].value^.keyword_value = 'TERMINATE'.
          job_submission_options^ [submission_option_index].job_recovery_disposition :=
                jmc$terminate_on_recovery;
        IFEND;
      IFEND;

{  Process LATEST_RUN_TIME parameter.

      IF pvt [p$latest_run_time].specified THEN
        submission_option_index := submission_option_index + 1;
        job_submission_options^ [submission_option_index].key := jmc$latest_run_time;
        job_submission_options^ [submission_option_index].latest_run_time.specified := TRUE;
        job_submission_options^ [submission_option_index].latest_run_time.date_time :=
              pvt [p$latest_run_time].value^.date_time_value.value;
      IFEND;

{  Process MAGNETIC_TAPE_LIMIT parameter.

      IF pvt [p$magnetic_tape_limit].specified THEN
        submission_option_index := submission_option_index + 1;
        job_submission_options^ [submission_option_index].key := jmc$magnetic_tape_limit;
        IF pvt [p$magnetic_tape_limit].value^.kind = clc$integer THEN
          job_submission_options^ [submission_option_index].magnetic_tape_limit :=
                pvt [p$magnetic_tape_limit].value^.integer_value.value;
        ELSE
          IF pvt [p$magnetic_tape_limit].value^.keyword_value = 'UNSPECIFIED' THEN
            job_submission_options^ [submission_option_index].magnetic_tape_limit :=
                  jmc$unspecified_mag_tape_limit;
          ELSEIF pvt [p$magnetic_tape_limit].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
            job_submission_options^ [submission_option_index].magnetic_tape_limit :=
                  jmc$system_default_mag_tape_lim;
          ELSE { pvt [p$magnetic_tape_limit].value^.keyword_value = 'UNLIMITED'.
            job_submission_options^ [submission_option_index].magnetic_tape_limit :=
                  jmc$unlimited_mag_tape_limit;
          IFEND;
        IFEND;
      IFEND;

{  Process MAXIMUM_WORKING_SET parameter.

      IF pvt [p$maximum_working_set].specified THEN
        submission_option_index := submission_option_index + 1;
        job_submission_options^ [submission_option_index].key := jmc$maximum_working_set;
        IF pvt [p$maximum_working_set].value^.kind = clc$integer THEN
          job_submission_options^ [submission_option_index].maximum_working_set :=
                pvt [p$maximum_working_set].value^.integer_value.value;
        ELSE
          IF pvt [p$maximum_working_set].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
            job_submission_options^ [submission_option_index].maximum_working_set :=
                  jmc$system_default_work_set_siz;
          ELSE { pvt [p$maximum_working_set].value^.keyword_value = 'UNLIMITED'.
            job_submission_options^ [submission_option_index].maximum_working_set :=
                  jmc$unlimited_working_set_size;
          IFEND;
        IFEND;
      IFEND;

{  Process OPERATOR_FAMILY parameter.

      submission_option_index := submission_option_index + 1;
      job_submission_options^ [submission_option_index].key := jmc$output_destination_family;
      job_submission_options^ [submission_option_index].output_destination_family :=
            pvt [p$operator_family].value^.name_value;

{  Process OPERATOR_USER parameter.

      submission_option_index := submission_option_index + 1;
      job_submission_options^ [submission_option_index].key := jmc$station_operator;
      job_submission_options^ [submission_option_index].station_operator :=
            pvt [p$operator_user].value^.name_value;

{  Process OUTPUT_DISPOSITION parameter.

      submission_option_index := submission_option_index + 1;
      job_submission_options^ [submission_option_index].key := jmc$output_disposition;
      IF pvt [p$output_disposition].value^.kind = clc$file THEN
        job_submission_options^ [submission_option_index].output_disposition.key := jmc$standard_output_path;
        PUSH job_submission_options^ [submission_option_index].output_disposition.standard_output_path;
        job_submission_options^ [submission_option_index].output_disposition.standard_output_path^ :=
              pvt [p$output_disposition].value^.file_value^;
      ELSE
        IF pvt [p$output_disposition].value^.keyword_value = 'PRINTER' THEN
          job_submission_options^ [submission_option_index].output_disposition.key :=
                jmc$normal_output_disposition;
        ELSEIF pvt [p$output_disposition].value^.keyword_value = 'DISCARD_ALL_OUTPUT' THEN
          job_submission_options^ [submission_option_index].output_disposition.key := jmc$discard_all_output;
        ELSEIF pvt [p$output_disposition].value^.keyword_value = 'DISCARD_STANDARD_OUTPUT' THEN
          job_submission_options^ [submission_option_index].output_disposition.key :=
                jmc$discard_standard_output;
        ELSE { pvt [p$output_disposition].value^.keyword_value = 'WAIT_QUEUE'.
          job_submission_options^ [submission_option_index].output_disposition.key := jmc$wait_queue_path;
          job_submission_options^ [submission_option_index].output_disposition.wait_queue_path := NIL;
        IFEND;
      IFEND;

{  Process SRU_LIMIT parameter.

      IF pvt [p$sru_limit].specified THEN
        submission_option_index := submission_option_index + 1;
        job_submission_options^ [submission_option_index].key := jmc$sru_limit;
        IF pvt [p$sru_limit].value^.kind = clc$integer THEN
          job_submission_options^ [submission_option_index].sru_limit :=
                pvt [p$sru_limit].value^.integer_value.value;
        ELSE
          IF pvt [p$sru_limit].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
            job_submission_options^ [submission_option_index].sru_limit := jmc$system_default_sru_limit;
          ELSE { pvt [p$sru_limit].value^.keyword_value = 'UNLIMITED'.
            job_submission_options^ [submission_option_index].sru_limit := jmc$unlimited_sru_limit;
          IFEND;
        IFEND;
      IFEND;

{  Process STATION parameter.

      submission_option_index := submission_option_index + 1;
      job_submission_options^ [submission_option_index].key := jmc$station;
      IF pvt [p$station].value^.kind = clc$keyword THEN
        job_submission_options^ [submission_option_index].station := pvt [p$station].value^.keyword_value;
      ELSE
        job_submission_options^ [submission_option_index].station := pvt [p$station].value^.name_value;
      IFEND;

{  Process SUBSTITUTION_MARK parameter.

      IF pvt [p$substitution_mark].value^.kind = clc$string THEN
        IF clv$non_substitution_mark [pvt [p$substitution_mark].value^.string_value^ (1)] THEN
          osp$set_status_abnormal ('CL', cle$improper_substitution_mark,
                pvt [p$substitution_mark].value^.string_value^ (1), status);
          RETURN;
        ELSE
          substitution_mark.specified := TRUE;
          substitution_mark.value := pvt [p$substitution_mark].value^.string_value^ (1);
        IFEND;
      IFEND;

{  Process USER_INFORMATION parameter.

      submission_option_index := submission_option_index + 1;
      job_submission_options^ [submission_option_index].key := jmc$user_information;
      PUSH job_submission_options^ [submission_option_index].user_information;
      job_submission_options^ [submission_option_index].user_information^ :=
            pvt [p$user_information].value^.string_value^;

{  Process USER_JOB_NAME parameter.

      submission_option_index := submission_option_index + 1;
      job_submission_options^ [submission_option_index].key := jmc$user_job_name;
      job_submission_options^ [submission_option_index].user_job_name :=
            pvt [p$user_job_name].value^.name_value;
    IFEND;

    clp$prepare_delayed_block (interpreter_mode, 'JOB', 'JOBEND', 'job', '', substitution_mark,
          statement_area, ignore_can_be_echoed, status);
    IF (NOT status.normal) OR (interpreter_mode <> clc$interpret_mode) THEN
      RETURN;
    IFEND;

    IF statement_area = NIL THEN
      osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'JOB statement', status);
      RETURN;
    IFEND;
    pmp$get_unique_name (unique_file_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /write_job_file/
    BEGIN
      file_id := amv$nil_file_identifier;
      #SPOIL (file_id);
      return_file := FALSE;
      #SPOIL (return_file);
      osp$establish_block_exit_hndlr (^abort_handler);

      file_attachment [1].selector := fsc$access_and_share_modes;
      file_attachment [1].access_modes.selector := fsc$specific_access_modes;
      file_attachment [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
      file_attachment [1].share_modes.selector := fsc$specific_share_modes;
      file_attachment [1].share_modes.value := $fst$file_access_options [];
      file_attachment [2].selector := fsc$open_share_modes;
      file_attachment [2].open_share_modes := $fst$file_access_options [];

      fsp$open_file (unique_file_name, amc$record, ^file_attachment, NIL, NIL, NIL, NIL, file_id, status);
      IF NOT status.normal THEN
        EXIT /write_job_file/;
      IFEND;
      return_file := TRUE;
      #SPOIL (return_file);

      RESET statement_area;
      NEXT line_header IN statement_area;

    /write_lines/
      WHILE line_header <> NIL DO
        NEXT line_text: [line_header^.line_size] IN statement_area;
        IF line_text = NIL THEN
          osp$set_status_abnormal ('CL', cle$unexpected_call_to, 'jmp$_job', status);
          EXIT /write_lines/;
        IFEND;
        amp$put_next (file_id, line_text, line_header^.line_size, ignore_byte_address, status);
        IF NOT status.normal THEN
          EXIT /write_lines/;
        IFEND;
        NEXT line_header IN statement_area;
      WHILEND /write_lines/;

      fsp$close_file (file_id, local_status);

{ If status is not normal from /write_lines/ block, report that status rather
{ than the status
{ from fsp$close_file.

      IF (NOT local_status.normal) AND status.normal THEN
        status := local_status;
      IFEND;
      IF NOT status.normal THEN
        EXIT /write_job_file/;
      IFEND;

      REPEAT
        jmp$submit_job (unique_file_name, job_submission_options, system_supplied_job_name, status);
        IF (NOT status.normal) AND (status.condition = jme$no_space_for_file) THEN
          jmp$update_display_message (status);

{ Wait for a while before retrying to give the system a chance to get some space back.

          PUSH wait_list_p: [1 .. 1];
          wait_list_p^ [1].activity := osc$i_await_time;
          wait_list_p^ [1].milliseconds := no_queue_space_wait_time;
          osp$i_await_activity_completion (wait_list_p^, ignore_ready_index, {ignore} local_status);
          local_status.normal := TRUE;
        IFEND;
      UNTIL status.normal OR (status.condition <> jme$no_space_for_file);
      IF NOT status.normal THEN
        EXIT /write_job_file/;
      IFEND;

{  Process SYSTEM_JOB_NAME parameter.

      IF pvt [p$system_job_name].specified THEN
        clp$get_work_area (#RING (^work_area_p), work_area_p, status);
        IF NOT status.normal THEN
          EXIT /write_job_file/;
        IFEND;

        clp$get_variable (pvt [p$system_job_name].variable^, work_area_p^, class, access_mode,
              evaluation_method, type_specification, value, status);
        IF NOT status.normal THEN
          EXIT /write_job_file/;
        IFEND;

        clp$get_type_information (type_specification, work_area_p^, type_information, status);
        IF NOT status.normal THEN
          EXIT /write_job_file/;
        IFEND;

        CASE type_information.kind OF
        = clc$name_type =
          system_job_name.kind := clc$name;
          system_job_name.name_value := system_supplied_job_name;
        ELSE { = clc$string_type =
          system_job_name.kind := clc$string;
          PUSH system_job_name.string_value: [jmc$system_supplied_name_size];
          system_job_name.string_value^ := system_supplied_job_name;
        CASEND;

        clp$change_variable (pvt [p$system_job_name].variable^, ^system_job_name, status);

      IFEND;

    END /write_job_file/;

    IF return_file THEN
      amp$return (unique_file_name, local_status);
      return_file := FALSE;
      #SPOIL (return_file);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND jmp$_job;
?? TITLE := '[XDCL] jmp$_print_file', EJECT ??

  PROCEDURE [XDCL] jmp$_print_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (osm$prif) print_file, print_files, prif (
{    file, files, f: list of file = $required
{    comment_banner, cb: string 0..jmc$output_comment_banner_size = $job(comm..
{ ent_banner)
{    copies, c: integer 1..jmc$output_copy_count_max = $job(copies)
{    data_mode, dm: key
{        (coded, c)
{        (transparent, t)
{      keyend = coded
{    device, d: any of
{        key
{          automatic
{        keyend
{        name
{      anyend = $job(device)
{    device_type, dt: key
{       printer, plotter, punch
{      keyend = $optional
{    earliest_print_time, ept: any of
{        key
{          none
{        keyend
{        date_time
{      anyend = $job(earliest_print_time)
{    external_characteristics, ec: any of
{        key
{          normal
{        keyend
{        string 0..jmc$ext_characteristics_size
{      anyend = $job(external_characteristics)
{    forms_code, fc: any of
{        key
{          normal
{        keyend
{        string 0..jmc$forms_code_size
{      anyend = $job(forms_code)
{    latest_print_time, lpt: any of
{        key
{          none
{        keyend
{        date_time
{      anyend = $job(latest_print_time)
{    operator_family, destination_family, df, of: name = $job(operator_family)
{    operator_user, so, station_operator, ou: name = $job(operator_user)
{    output_class, oc: key
{        normal
{      keyend = $job(output_class)
{    output_deferred_by_user, odbu: boolean = $job(output_deferred_by_user)
{    output_destination, ode: any of
{        string 0..osc$max_name_size
{        name
{      anyend = $job(output_destination)
{    output_destination_usage, destination_usage, du, odu: any of
{        key
{          dual_state, ntf, private, public, qtf
{        keyend
{        name
{      anyend = $optional
{    output_disposition, odi: key
{        (local, l)
{        (printer, p)
{        (wait_queue, wq)
{      keyend = $optional
{    output_priority, op: key
{        low, medium, high
{      keyend = $job(output_priority)
{    purge_delay, pd: any of
{        key
{          none
{        keyend
{        time_increment
{      anyend = $optional
{    remote_host_directive, dsrp, dual_state_route_parameters, rhd: string 0..
{ ..jmc$remote_host_directive_size =
{      $job(remote_host_directive)
{    routing_banner, rb: string 0..jmc$output_routing_banner_size = $job(rout..
{ ing_banner)
{    station, s: any of
{        key
{          automatic
{        keyend
{        name
{      anyend = $job(station)
{    user_file_name, user_file_names, ufn: list of name = $optional
{    user_information, ui: string 0..jmc$user_information_size = $job(user_in..
{ formation)
{    vertical_print_density, vpd: key
{        six, eight, none, file
{      keyend = $job(vertical_print_density)
{    vfu_load_procedure, vlp: any of
{        key
{          none
{        keyend
{        name
{      anyend = $job(vfu_load_procedure)
{    system_file_name, sfn: (VAR) any of
{        name
{        list of name
{      anyend = $optional
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 65] of clt$pdt_parameter_name,
      parameters: array [1 .. 28] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (20),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (12),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type5: 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$name_type_qualifier,
        recend,
        default_value: string (12),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      type7: 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$date_time_type_qualifier,
        recend,
        default_value: string (25),
      recend,
      type8: 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$string_type_qualifier,
        recend,
        default_value: string (30),
      recend,
      type9: 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$string_type_qualifier,
        recend,
        default_value: string (16),
      recend,
      type10: 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$date_time_type_qualifier,
        recend,
        default_value: string (23),
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (21),
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (19),
      recend,
      type13: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 1] of clt$keyword_specification,
        default_value: string (18),
      recend,
      type14: record
        header: clt$type_specification_header,
        default_value: string (29),
      recend,
      type15: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        default_value: string (24),
      recend,
      type16: 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 .. 5] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type17: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type18: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
        default_value: string (21),
      recend,
      type19: 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,
        recend,
      recend,
      type20: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (27),
      recend,
      type21: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (20),
      recend,
      type22: 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$name_type_qualifier,
        recend,
        default_value: string (13),
      recend,
      type23: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type24: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (22),
      recend,
      type25: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (28),
      recend,
      type26: 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$name_type_qualifier,
        recend,
        default_value: string (24),
      recend,
      type27: 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$name_type_qualifier,
        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$name_type_qualifier,
          recend,
        recend,
      recend,
      type28: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 3, 22, 9, 17, 32, 887],
    clc$command, 65, 28, 1, 0, 0, 1, 28, 'OSM$PRIF'], [
    ['C                              ',clc$abbreviation_entry, 3],
    ['CB                             ',clc$abbreviation_entry, 2],
    ['COMMENT_BANNER                 ',clc$nominal_entry, 2],
    ['COPIES                         ',clc$nominal_entry, 3],
    ['D                              ',clc$abbreviation_entry, 5],
    ['DATA_MODE                      ',clc$nominal_entry, 4],
    ['DESTINATION_FAMILY             ',clc$alias_entry, 11],
    ['DESTINATION_USAGE              ',clc$alias_entry, 16],
    ['DEVICE                         ',clc$nominal_entry, 5],
    ['DEVICE_TYPE                    ',clc$nominal_entry, 6],
    ['DF                             ',clc$alias_entry, 11],
    ['DM                             ',clc$abbreviation_entry, 4],
    ['DSRP                           ',clc$alias_entry, 20],
    ['DT                             ',clc$abbreviation_entry, 6],
    ['DU                             ',clc$alias_entry, 16],
    ['DUAL_STATE_ROUTE_PARAMETERS    ',clc$alias_entry, 20],
    ['EARLIEST_PRINT_TIME            ',clc$nominal_entry, 7],
    ['EC                             ',clc$abbreviation_entry, 8],
    ['EPT                            ',clc$abbreviation_entry, 7],
    ['EXTERNAL_CHARACTERISTICS       ',clc$nominal_entry, 8],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FC                             ',clc$abbreviation_entry, 9],
    ['FILE                           ',clc$nominal_entry, 1],
    ['FILES                          ',clc$alias_entry, 1],
    ['FORMS_CODE                     ',clc$nominal_entry, 9],
    ['LATEST_PRINT_TIME              ',clc$nominal_entry, 10],
    ['LPT                            ',clc$abbreviation_entry, 10],
    ['OC                             ',clc$abbreviation_entry, 13],
    ['ODBU                           ',clc$abbreviation_entry, 14],
    ['ODE                            ',clc$abbreviation_entry, 15],
    ['ODI                            ',clc$abbreviation_entry, 17],
    ['ODU                            ',clc$abbreviation_entry, 16],
    ['OF                             ',clc$abbreviation_entry, 11],
    ['OP                             ',clc$abbreviation_entry, 18],
    ['OPERATOR_FAMILY                ',clc$nominal_entry, 11],
    ['OPERATOR_USER                  ',clc$nominal_entry, 12],
    ['OU                             ',clc$abbreviation_entry, 12],
    ['OUTPUT_CLASS                   ',clc$nominal_entry, 13],
    ['OUTPUT_DEFERRED_BY_USER        ',clc$nominal_entry, 14],
    ['OUTPUT_DESTINATION             ',clc$nominal_entry, 15],
    ['OUTPUT_DESTINATION_USAGE       ',clc$nominal_entry, 16],
    ['OUTPUT_DISPOSITION             ',clc$nominal_entry, 17],
    ['OUTPUT_PRIORITY                ',clc$nominal_entry, 18],
    ['PD                             ',clc$abbreviation_entry, 19],
    ['PURGE_DELAY                    ',clc$nominal_entry, 19],
    ['RB                             ',clc$abbreviation_entry, 21],
    ['REMOTE_HOST_DIRECTIVE          ',clc$nominal_entry, 20],
    ['RHD                            ',clc$abbreviation_entry, 20],
    ['ROUTING_BANNER                 ',clc$nominal_entry, 21],
    ['S                              ',clc$abbreviation_entry, 22],
    ['SFN                            ',clc$abbreviation_entry, 27],
    ['SO                             ',clc$alias_entry, 12],
    ['STATION                        ',clc$nominal_entry, 22],
    ['STATION_OPERATOR               ',clc$alias_entry, 12],
    ['STATUS                         ',clc$nominal_entry, 28],
    ['SYSTEM_FILE_NAME               ',clc$nominal_entry, 27],
    ['UFN                            ',clc$abbreviation_entry, 23],
    ['UI                             ',clc$abbreviation_entry, 24],
    ['USER_FILE_NAME                 ',clc$nominal_entry, 23],
    ['USER_FILE_NAMES                ',clc$alias_entry, 23],
    ['USER_INFORMATION               ',clc$nominal_entry, 24],
    ['VERTICAL_PRINT_DENSITY         ',clc$nominal_entry, 25],
    ['VFU_LOAD_PROCEDURE             ',clc$nominal_entry, 26],
    ['VLP                            ',clc$abbreviation_entry, 26],
    ['VPD                            ',clc$abbreviation_entry, 25]],
    [
{ PARAMETER 1
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 19, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 20],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 12],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 5],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_default_parameter, 0, 12],
{ PARAMETER 6
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 118, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_default_parameter, 0, 25],
{ PARAMETER 8
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 72, clc$optional_default_parameter, 0, 30],
{ PARAMETER 9
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 72, clc$optional_default_parameter, 0, 16],
{ PARAMETER 10
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_default_parameter, 0, 23],
{ PARAMETER 11
    [35, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 21],
{ PARAMETER 12
    [36, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 19],
{ PARAMETER 13
    [38, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 44, clc$optional_default_parameter, 0, 18],
{ PARAMETER 14
    [39, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 29],
{ PARAMETER 15
    [40, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_default_parameter, 0, 24],
{ PARAMETER 16
    [41, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 217, clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [42, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_parameter, 0, 0],
{ PARAMETER 18
    [43, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 118, clc$optional_default_parameter, 0, 21],
{ PARAMETER 19
    [45, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 20
    [47, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 27],
{ PARAMETER 21
    [49, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 20],
{ PARAMETER 22
    [53, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_default_parameter, 0, 13],
{ PARAMETER 23
    [59, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 21, clc$optional_parameter, 0, 0],
{ PARAMETER 24
    [61, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 22],
{ PARAMETER 25
    [62, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 28],
{ PARAMETER 26
    [63, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_default_parameter, 0, 24],
{ PARAMETER 27
    [56, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 46, clc$optional_parameter, 0, 0],
{ PARAMETER 28
    [55, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$string_type], [0, jmc$output_comment_banner_size, FALSE],
    '$job(comment_banner)'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, jmc$output_copy_count_max, 10],
    '$job(copies)'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [4], [
    ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['CODED                          ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['TRANSPARENT                    ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'coded'],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['AUTOMATIC                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    '$job(device)'],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [3], [
    ['PLOTTER                        ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['PRINTER                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['PUNCH                          ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$date_time_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time
  ], $clt$date_time_tenses [clc$past, clc$present, clc$future]]]
    ,
    '$job(earliest_print_time)'],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$string_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NORMAL                         ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [0, jmc$ext_characteristics_size, FALSE]]
    ,
    '$job(external_characteristics)'],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$string_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NORMAL                         ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [0, jmc$forms_code_size, FALSE]]
    ,
    '$job(forms_code)'],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$date_time_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time
  ], $clt$date_time_tenses [clc$past, clc$present, clc$future]]]
    ,
    '$job(latest_print_time)'],
{ PARAMETER 11
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    '$job(operator_family)'],
{ PARAMETER 12
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    '$job(operator_user)'],
{ PARAMETER 13
    [[1, 0, clc$keyword_type], [1], [
    ['NORMAL                         ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ,
    '$job(output_class)'],
{ PARAMETER 14
    [[1, 0, clc$boolean_type],
    '$job(output_deferred_by_user)'],
{ PARAMETER 15
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    '$job(output_destination)'],
{ PARAMETER 16
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    192, [[1, 0, clc$keyword_type], [5], [
      ['DUAL_STATE                     ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NTF                            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['PRIVATE                        ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['PUBLIC                         ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['QTF                            ', clc$nominal_entry,
  clc$normal_usage_entry, 5]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 17
    [[1, 0, clc$keyword_type], [6], [
    ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['LOCAL                          ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['P                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['PRINTER                        ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['WAIT_QUEUE                     ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['WQ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 18
    [[1, 0, clc$keyword_type], [3], [
    ['HIGH                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['LOW                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['MEDIUM                         ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    '$job(output_priority)'],
{ PARAMETER 19
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$time_increment_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$time_increment_type]]
    ],
{ PARAMETER 20
    [[1, 0, clc$string_type], [0, jmc$remote_host_directive_size, FALSE],
    '$job(remote_host_directive)'],
{ PARAMETER 21
    [[1, 0, clc$string_type], [0, jmc$output_routing_banner_size, FALSE],
    '$job(routing_banner)'],
{ PARAMETER 22
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['AUTOMATIC                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    '$job(station)'],
{ PARAMETER 23
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 24
    [[1, 0, clc$string_type], [0, jmc$user_information_size, FALSE],
    '$job(user_information)'],
{ PARAMETER 25
    [[1, 0, clc$keyword_type], [4], [
    ['EIGHT                          ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['FILE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['SIX                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ,
    '$job(vertical_print_density)'],
{ PARAMETER 26
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    '$job(vfu_load_procedure)'],
{ PARAMETER 27
    [[1, 0, clc$union_type], [[clc$list_type, clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 28
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$comment_banner = 2,
      p$copies = 3,
      p$data_mode = 4,
      p$device = 5,
      p$device_type = 6,
      p$earliest_print_time = 7,
      p$external_characteristics = 8,
      p$forms_code = 9,
      p$latest_print_time = 10,
      p$operator_family = 11,
      p$operator_user = 12,
      p$output_class = 13,
      p$output_deferred_by_user = 14,
      p$output_destination = 15,
      p$output_destination_usage = 16,
      p$output_disposition = 17,
      p$output_priority = 18,
      p$purge_delay = 19,
      p$remote_host_directive = 20,
      p$routing_banner = 21,
      p$station = 22,
      p$user_file_name = 23,
      p$user_information = 24,
      p$vertical_print_density = 25,
      p$vfu_load_procedure = 26,
      p$system_file_name = 27,
      p$status = 28;

    VAR
      pvt: array [1 .. 28] of clt$parameter_value;

    CONST
      max_output_options = p$vfu_load_procedure;

    VAR
      access_mode: clt$data_access_mode,
      class: clt$variable_class,
      evaluation_method: clt$expression_eval_method,
      file_count: 1 .. clc$max_list_size,
      file_list: ^clt$data_value,
      file_number: 1 .. clc$max_list_size,
      ignore_ready_index: integer,
      ignore_status: ost$status,
      index: 0 .. max_output_options,
      list_value: ^clt$data_value,
      number_of_output_options: 0 .. max_output_options,
      output_submission_index: 0 .. max_output_options,
      output_submission_options: ^jmt$output_submission_options,
      system_file_name: ^clt$data_value,
      system_supplied_name: jmt$system_supplied_name,
      system_supplied_name_is_blank: boolean,
      type_information: clt$type_information,
      type_specification: ^clt$type_specification,
      user_file_name_count: 0 .. clc$max_list_size,
      user_file_name_list: ^clt$data_value,
      value: ^clt$data_value,
      wait_list_p: ^ost$i_wait_list,
      work_area_p: ^^clt$work_area;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_submission_options := NIL;
    file_count := clp$count_list_elements (pvt [p$file].value);
    IF pvt [p$user_file_name].specified THEN
      user_file_name_count := clp$count_list_elements (pvt [p$user_file_name].value);
    ELSE
      user_file_name_count := 0;
    IFEND;

    IF user_file_name_count > file_count THEN
      osp$set_status_abnormal ('CL', cle$too_many_values, 'USER_FILE_NAME', status);
      RETURN;
    IFEND;

    output_submission_index := 0;
    number_of_output_options := 0;

    FOR index := p$comment_banner TO p$vfu_load_procedure DO
      CASE pvt [index].passing_method OF
      = clc$pass_by_value =
        IF pvt [index].value <> NIL THEN
          number_of_output_options := number_of_output_options + 1;
        IFEND;
      = clc$pass_by_reference =
        IF pvt [index].variable <> NIL THEN
          number_of_output_options := number_of_output_options + 1;
        IFEND;
      CASEND;
    FOREND;

    IF number_of_output_options <> 0 THEN
      PUSH output_submission_options: [1 .. number_of_output_options];
    IFEND;

{  Process COMMENT_BANNER parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$comment_banner;
    output_submission_options^ [output_submission_index].comment_banner :=
          pvt [p$comment_banner].value^.string_value^;

{  Process COPIES parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$copies;
    output_submission_options^ [output_submission_index].copies := pvt [p$copies].value^.integer_value.value;

{  Process DATA_MODE parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$data_mode;
    IF pvt [p$data_mode].value^.keyword_value = 'CODED' THEN
      output_submission_options^ [output_submission_index].data_mode := jmc$coded_data;
    ELSE { pvt [p$data_mode].value^.keyword_value = 'TRANSPARENT'.
      output_submission_options^ [output_submission_index].data_mode := jmc$transparent_data;
    IFEND;

{  Process DEVICE parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$device;
    IF pvt [p$device].value^.kind = clc$name THEN
      output_submission_options^ [output_submission_index].device := pvt [p$device].value^.name_value;
    ELSE
      output_submission_options^ [output_submission_index].device := pvt [p$device].value^.keyword_value;
    IFEND;

{  Process DEVICE_TYPE parameter.

    IF pvt [p$device_type].specified THEN
      output_submission_index := output_submission_index + 1;
      output_submission_options^ [output_submission_index].key := jmc$device_type;
      IF pvt [p$device_type].value^.keyword_value = 'PRINTER' THEN
        output_submission_options^ [output_submission_index].device_type := jmc$output_device_printer;
      ELSEIF pvt [p$device_type].value^.keyword_value = 'PLOTTER' THEN
        output_submission_options^ [output_submission_index].device_type := jmc$output_device_plotter;
      ELSE { pvt [p$device_type].value^.keyword_value = 'PUNCH'.
        output_submission_options^ [output_submission_index].device_type := jmc$output_device_punch;
      IFEND;
    IFEND;

{  Process EARLIEST_PRINT_TIME parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$earliest_print_time;
    IF pvt [p$earliest_print_time].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
      output_submission_options^ [output_submission_index].earliest_print_time.specified := FALSE;
    ELSE
      output_submission_options^ [output_submission_index].earliest_print_time.specified := TRUE;
      output_submission_options^ [output_submission_index].
            earliest_print_time.date_time := pvt [p$earliest_print_time].value^.date_time_value.value;
    IFEND;

{  Process EXTERNAL_CHARACTERISTICS parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$external_characteristics;
    IF pvt [p$external_characteristics].value^.kind = clc$keyword THEN { the only keyword is NORMAL. }
      output_submission_options^ [output_submission_index].
            external_characteristics := pvt [p$external_characteristics].value^.keyword_value;
    ELSE
      output_submission_options^ [output_submission_index].
            external_characteristics := pvt [p$external_characteristics].value^.string_value^;
    IFEND;

{  Process FORMS_CODE parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$forms_code;
    IF pvt [p$forms_code].value^.kind = clc$keyword THEN { the only keyword allowed is NORMAL. }
      output_submission_options^ [output_submission_index].forms_code := pvt [p$forms_code].
            value^.keyword_value;
    ELSE
      output_submission_options^ [output_submission_index].forms_code := pvt [p$forms_code].
            value^.string_value^;
    IFEND;

{  Process LATEST_PRINT_TIME parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$latest_print_time;
    IF pvt [p$latest_print_time].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
      output_submission_options^ [output_submission_index].latest_print_time.specified := FALSE;
    ELSE
      output_submission_options^ [output_submission_index].latest_print_time.specified := TRUE;
      output_submission_options^ [output_submission_index].
            latest_print_time.date_time := pvt [p$latest_print_time].value^.date_time_value.value;
    IFEND;

{  Process OPERATOR_FAMILY parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$output_destination_family;
    output_submission_options^ [output_submission_index].output_destination_family :=
          pvt [p$operator_family].value^.name_value;

{  Process OPERATOR_USER parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$station_operator;
    output_submission_options^ [output_submission_index].station_operator :=
          pvt [p$operator_user].value^.name_value;

{  Process OUTPUT_CLASS parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$output_class;
    output_submission_options^ [output_submission_index].output_class :=
          pvt [p$output_class].value^.keyword_value;

{  Process OUTPUT_DEFERRED_BY_USER parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$output_deferred_by_user;
    output_submission_options^ [output_submission_index].output_deferred_by_user :=
          pvt [p$output_deferred_by_user].value^.boolean_value.value;

{  Process OUTPUT_DESTINATION parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$output_destination;
    IF pvt [p$output_destination].value^.kind = clc$name THEN
      output_submission_options^ [output_submission_index].output_destination :=
            pvt [p$output_destination].value^.name_value;
    ELSE
      output_submission_options^ [output_submission_index].output_destination :=
            pvt [p$output_destination].value^.string_value^;
    IFEND;

{  Process OUTPUT_DESTINATION_USAGE parameter.

    IF pvt [p$output_destination_usage].specified THEN
      output_submission_index := output_submission_index + 1;
      output_submission_options^ [output_submission_index].key := jmc$output_destination_usage;
      IF pvt [p$output_destination_usage].value^.kind = clc$name THEN
        output_submission_options^ [output_submission_index].
              output_destination_usage := pvt [p$output_destination_usage].value^.name_value;
      ELSE
        output_submission_options^ [output_submission_index].
              output_destination_usage := pvt [p$output_destination_usage].value^.keyword_value;
      IFEND;
    IFEND;

{  Process OUTPUT_DISPOSITION parameter.

    IF pvt [p$output_disposition].specified THEN
      output_submission_index := output_submission_index + 1;
      output_submission_options^ [output_submission_index].key := jmc$output_disposition;
      IF pvt [p$output_disposition].value^.keyword_value = 'PRINTER' THEN
        output_submission_options^ [output_submission_index].output_disposition.key :=
              jmc$normal_output_disposition;
      ELSEIF pvt [p$output_disposition].value^.keyword_value = 'LOCAL' THEN
        output_submission_options^ [output_submission_index].output_disposition.key :=
              jmc$local_output_disposition;
      ELSE { pvt [p$output_disposition].value^.keyword_value = 'WAIT_QUEUE'.
        output_submission_options^ [output_submission_index].output_disposition.key := jmc$wait_queue_path;
        output_submission_options^ [output_submission_index].output_disposition.wait_queue_path := NIL;
      IFEND;
    IFEND;

{  Process OUTPUT_PRIORITY parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$output_priority;
    output_submission_options^ [output_submission_index].output_priority :=
          pvt [p$output_priority].value^.keyword_value;

{  Process PURGE_DELAY parameter.

    IF pvt [p$purge_delay].specified THEN
      output_submission_index := output_submission_index + 1;
      output_submission_options^ [output_submission_index].key := jmc$purge_delay;
      PUSH output_submission_options^ [output_submission_index].purge_delay;
      IF pvt [p$purge_delay].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        output_submission_options^ [output_submission_index].purge_delay^.specified := FALSE;
      ELSE
        output_submission_options^ [output_submission_index].purge_delay^.specified := TRUE;
        output_submission_options^ [output_submission_index].
              purge_delay^.time_increment := pvt [p$purge_delay].value^.time_increment_value^;
      IFEND;
    IFEND;

{  Process REMOTE_HOST_DIRECTIVE parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$remote_host_directive;
    PUSH output_submission_options^ [output_submission_index].remote_host_directive;
    output_submission_options^ [output_submission_index].remote_host_directive^.size :=
          STRLENGTH (pvt [p$remote_host_directive].value^.string_value^);
    output_submission_options^ [output_submission_index].remote_host_directive^.parameters :=
          pvt [p$remote_host_directive].value^.string_value^;

{  Process ROUTING_BANNER parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$routing_banner;
    output_submission_options^ [output_submission_index].routing_banner :=
          pvt [p$routing_banner].value^.string_value^;

{  Process STATION parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$station;
    IF pvt [p$station].value^.kind = clc$keyword THEN
      output_submission_options^ [output_submission_index].station := pvt [p$station].value^.keyword_value;
    ELSE
      output_submission_options^ [output_submission_index].station := pvt [p$station].value^.name_value;
    IFEND;

{  Process USER_INFORMATION parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$user_information;
    PUSH output_submission_options^ [output_submission_index].user_information;
    output_submission_options^ [output_submission_index].user_information^ :=
          pvt [p$user_information].value^.string_value^;

{  Process VERTICAL_PRINT_DENSITY parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$vertical_print_density;
    IF pvt [p$vertical_print_density].value^.keyword_value = 'FILE' THEN
      output_submission_options^ [output_submission_index].vertical_print_density :=
            jmc$vertical_print_density_file;
    ELSEIF pvt [p$vertical_print_density].value^.keyword_value = 'NONE' THEN
      output_submission_options^ [output_submission_index].vertical_print_density :=
            jmc$vertical_print_density_none;
    ELSEIF pvt [p$vertical_print_density].value^.keyword_value = 'SIX' THEN
      output_submission_options^ [output_submission_index].vertical_print_density :=
            jmc$vertical_print_density_6;
    ELSE { pvt [p$vertical_print_density].value^.keyword_value = 'EIGHT'
      output_submission_options^ [output_submission_index].vertical_print_density :=
            jmc$vertical_print_density_8;
    IFEND;

{  Process VFU_LOAD_PROCEDURE parameter.

    output_submission_index := output_submission_index + 1;
    output_submission_options^ [output_submission_index].key := jmc$vfu_load_procedure;
    IF pvt [p$vfu_load_procedure].value^.kind = clc$keyword THEN
      output_submission_options^ [output_submission_index].vfu_load_procedure := osc$null_name;
    ELSE
      output_submission_options^ [output_submission_index].vfu_load_procedure :=
            pvt [p$vfu_load_procedure].value^.name_value;
    IFEND;

{  Process FILE,  SYSTEM_FILE_NAME, and USER_FILE_NAME parameters.

    IF pvt [p$system_file_name].specified THEN
      clp$get_work_area (#RING (^work_area_p), work_area_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$get_variable (pvt [p$system_file_name].variable^, work_area_p^, class, access_mode,
            evaluation_method, type_specification, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$get_type_information (type_specification, work_area_p^, type_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE type_information.kind OF
      = clc$list_type =
        PUSH list_value;
        system_file_name := list_value;
        system_file_name^.kind := clc$list;
        system_file_name^.element_value := NIL;
        system_file_name^.link := NIL;
        system_file_name^.generated_via_list_rest := FALSE;
      ELSE { = clc$name_type =
        PUSH system_file_name;
        system_file_name^.kind := clc$name;
      CASEND;
    IFEND;

    file_list := pvt [p$file].value;
    IF user_file_name_count <> 0 THEN
      output_submission_index := output_submission_index + 1;
      user_file_name_list := pvt [p$user_file_name].value;
    ELSE
      user_file_name_list := NIL;
    IFEND;

    system_supplied_name_is_blank := FALSE;

    FOR file_number := 1 TO file_count DO
      IF (user_file_name_list = NIL) AND (user_file_name_count <> 0) THEN
        output_submission_options^ [output_submission_index].key := jmc$null_attribute;
      ELSEIF user_file_name_list <> NIL THEN
        output_submission_options^ [output_submission_index].key := jmc$user_file_name;
        output_submission_options^ [output_submission_index].user_file_name :=
              user_file_name_list^.element_value^.name_value;
        user_file_name_list := user_file_name_list^.link;
      IFEND;

      REPEAT
        jmp$print_file (file_list^.element_value^.file_value^, output_submission_options,
              system_supplied_name, status);
        IF (NOT status.normal) AND (status.condition = jme$no_space_for_file) THEN
          jmp$update_display_message (status);

{ Wait for a while before retrying to give the system a chance to get some space back.

          PUSH wait_list_p: [1 .. 1];
          wait_list_p^ [1].activity := osc$i_await_time;
          wait_list_p^ [1].milliseconds := no_queue_space_wait_time;
          osp$i_await_activity_completion (wait_list_p^, ignore_ready_index, ignore_status);
        IFEND;
      UNTIL status.normal OR (status.condition <> jme$no_space_for_file);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Check for a blank system_supplied_name.  We do not want to write the system_file_name
{ variable if one or more are blank.

      IF system_supplied_name = jmc$blank_system_supplied_name THEN
        system_supplied_name_is_blank := TRUE;
      IFEND;

      IF pvt [p$system_file_name].specified AND (NOT system_supplied_name_is_blank) THEN
        IF system_file_name^.kind = clc$list THEN
          IF list_value^.element_value <> NIL THEN
            PUSH list_value^.link;
            list_value := list_value^.link;
            list_value^.kind := clc$list;
          IFEND;
          PUSH list_value^.element_value;
          list_value^.element_value^.kind := clc$name;
          list_value^.element_value^.name_value := system_supplied_name;
          list_value^.link := NIL;
          list_value^.generated_via_list_rest := FALSE;
        ELSE { clc$name.
          IF file_number = 1 THEN
            system_file_name^.name_value := system_supplied_name;
          IFEND;
        IFEND;
      IFEND;

      file_list := file_list^.link;
    FOREND;

    IF pvt [p$system_file_name].specified AND (NOT system_supplied_name_is_blank) THEN
      clp$change_variable (pvt [p$system_file_name].variable^, system_file_name, status);
    IFEND;

  PROCEND jmp$_print_file;
?? TITLE := '[XDCL] jmp$_set_sense_switch', EJECT ??

  PROCEDURE [XDCL] jmp$_set_sense_switch
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$setss) set_sense_switch, set_sense_switches, setss (
{   name, jn, job_name, n: name = $optional
{   on: list of range of integer 1..8 = $optional
{   off: list of range of integer 1..8 = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 3, 9, 13, 46, 10, 506], clc$command, 7, 4, 0, 0, 0, 0, 4, 'OSM$SETSS'],
            [['JN                             ', clc$alias_entry, 1],
            ['JOB_NAME                       ', clc$alias_entry, 1],
            ['N                              ', clc$abbreviation_entry, 1],
            ['NAME                           ', clc$nominal_entry, 1],
            ['OFF                            ', clc$nominal_entry, 3],
            ['ON                             ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 43, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 43, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$list_type], [27, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$range_type], [20], [[1, 0, clc$integer_type], [1, 8, 10]]]],

{ PARAMETER 3

      [[1, 0, clc$list_type], [27, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$range_type], [20], [[1, 0, clc$integer_type], [1, 8, 10]]]],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$name = 1,
      p$on = 2,
      p$off = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      off_list: ^clt$data_value,
      on_list: ^clt$data_value,
      switch_on: pmt$sense_switches,
      switch_off: pmt$sense_switches,
      ignore_resulting_switches: pmt$sense_switches,
      index: 1 .. clc$max_list_size,
      range: 1 .. 8,
      system_supplied_name: jmt$system_supplied_name;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    switch_on := $pmt$sense_switches [];
    switch_off := $pmt$sense_switches [];

{  Process ON parameter.

    on_list := pvt [p$on].value;

    WHILE on_list <> NIL DO
      FOR range := on_list^.element_value^.low_value^.integer_value.value TO on_list^.element_value^.
            high_value^.integer_value.value DO
        switch_on := switch_on + $pmt$sense_switches [range];
      FOREND;
      on_list := on_list^.link;
    WHILEND;

{  Process OFF parameter.

    off_list := pvt [p$off].value;

    WHILE off_list <> NIL DO
      FOR range := off_list^.element_value^.low_value^.integer_value.value TO off_list^.element_value^.
            high_value^.integer_value.value DO
        switch_off := switch_off + $pmt$sense_switches [range];
      FOREND;
      off_list := off_list^.link;
    WHILEND;

    IF (switch_on + switch_off) = $pmt$sense_switches [] THEN
      osp$set_status_abnormal ('CL', cle$required_parameter_omitted, 'ON or OFF', status);
      RETURN;
    IFEND;

{  Process NAME parameter.

    IF pvt [p$name].specified THEN
      jmp$switch_command_r3 (pvt [p$name].value^.name_value, switch_on, switch_off, status);
    ELSE

{  If job name is not specified, sense switches are set for the job
{  executing command.

      pmp$manage_sense_switches (switch_on, switch_off, ignore_resulting_switches, status);
    IFEND;

  PROCEND jmp$_set_sense_switch;
?? TITLE := '[XDCL] jmp$_submit_detached', EJECT ??

  PROCEDURE [XDCL] jmp$_submit_detached
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE submit_detached_job, subdj (
{     user_information, ui: string 0..jmc$user_information_size = ''
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (2),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 28, 14, 0, 49, 840],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['STATUS                         ',clc$nominal_entry, 2],
    ['UI                             ',clc$abbreviation_entry, 1],
    ['USER_INFORMATION               ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, jmc$user_information_size, FALSE],
    ''''''],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$user_information = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$submit_detached_job (pvt [p$user_information].value^.string_value^, status);

  PROCEND jmp$_submit_detached;
?? TITLE := '[XDCL] jmp$_submit_job', EJECT ??

  PROCEDURE [XDCL] jmp$_submit_job
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$subj) submit_job, submit_jobs, subj (
{   file, files, f: list of file = $required
{   cpu_time_limit, ctl: any of
{       key
{         system_default, unlimited, unspecified
{       keyend
{       integer jmc$lowest_cpu_time_limit..jmc$highest_cpu_time_limit
{     anyend = $optional
{   earliest_run_time, ert: any of
{       key
{         none
{       keyend
{       date_time
{     anyend = $optional
{   job_abort_disposition, jad: key
{       (restart, r)
{       (terminate, t)
{     keyend = $optional
{   job_class, jc: name = $optional
{   job_deferred_by_user, jdbu: boolean = $optional
{   job_destination, jd: any of
{       string 0..osc$max_name_size
{       name
{     anyend = $optional
{   job_destination_usage, jdu: any of
{       key
{         ntf, qtf, ve, ve_family, ve_local, ve_qtf
{       keyend
{       name
{     anyend = $optional
{   job_execution_ring, jer: integer osc$sj_ring_1..osc$user_ring_2 = $optional
{   job_qualifier, job_qualifiers, jq: any of
{       key
{         none, system_default
{       keyend
{       list 1..jmc$maximum_job_qualifiers of name
{     anyend = $optional
{   job_recovery_disposition, jrd: key
{       (continue, c)
{       (restart, r)
{       (terminate, t)
{     keyend = $optional
{   latest_run_time, lrt: any of
{       key
{         none
{       keyend
{       date_time
{     anyend = $optional
{   login_family, family_name, fn, lf: name = $optional
{   magnetic_tape_limit, mtl: any of
{       key
{         system_default, unlimited, unspecified
{       keyend
{       integer jmc$lowest_magnetic_tape_limit..jmc$highest_magnetic_tape_limit
{     anyend = $optional
{   maximum_working_set, maxws: any of
{       key
{         system_default, unlimited, unspecified
{       keyend
{       integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{     anyend = $optional
{   operator_family, of: name = $job(operator_family)
{   operator_user, ou: name = $job(operator_user)
{   output_disposition, so, standard_output, odi: any of
{       key
{         (discard_all_output, dao)
{         (discard_standard_output, dso)
{         (local, l)
{         (printer, p)
{         (wait_queue, wt, wq)
{       keyend
{       file
{     anyend = printer
{   remote_host_directive, rhd: string 0..jmc$remote_host_directive_size = $optional
{   sru_limit, sl: any of
{       key
{         system_default, unlimited, unspecified
{       keyend
{       integer jmc$lowest_sru_limit..jmc$highest_sru_limit
{     anyend = $optional
{   station, s: any of
{       key
{         automatic
{       keyend
{       name
{     anyend = $job(station)
{   user_information, ui: string 0..jmc$user_information_size = $optional
{   user_job_name, jn, job_name, ujn: list of name = $optional
{   system_job_name, sjn: (VAR) any of
{       string
{       name
{       list of name
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 57] of clt$pdt_parameter_name,
      parameters: array [1 .. 25] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type3: 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$date_time_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
      type7: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type8: 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 .. 6] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type10: 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 .. 2] 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$name_type_qualifier,
          recend,
        recend,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type12: 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$date_time_type_qualifier,
        recend,
      recend,
      type13: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type14: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type15: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (21),
      recend,
      type17: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (19),
      recend,
      type18: 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 .. 11] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
        default_value: string (7),
      recend,
      type19: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type20: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type21: 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$name_type_qualifier,
        recend,
        default_value: string (13),
      recend,
      type22: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type23: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type24: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier_v2,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type25: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 7, 8, 15, 12, 50, 553],
    clc$command, 57, 25, 1, 0, 0, 1, 25, 'OSM$SUBJ'], [
    ['CPU_TIME_LIMIT                 ',clc$nominal_entry, 2],
    ['CTL                            ',clc$abbreviation_entry, 2],
    ['EARLIEST_RUN_TIME              ',clc$nominal_entry, 3],
    ['ERT                            ',clc$abbreviation_entry, 3],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FAMILY_NAME                    ',clc$alias_entry, 13],
    ['FILE                           ',clc$nominal_entry, 1],
    ['FILES                          ',clc$alias_entry, 1],
    ['FN                             ',clc$alias_entry, 13],
    ['JAD                            ',clc$abbreviation_entry, 4],
    ['JC                             ',clc$abbreviation_entry, 5],
    ['JD                             ',clc$abbreviation_entry, 7],
    ['JDBU                           ',clc$abbreviation_entry, 6],
    ['JDU                            ',clc$abbreviation_entry, 8],
    ['JER                            ',clc$abbreviation_entry, 9],
    ['JN                             ',clc$alias_entry, 23],
    ['JOB_ABORT_DISPOSITION          ',clc$nominal_entry, 4],
    ['JOB_CLASS                      ',clc$nominal_entry, 5],
    ['JOB_DEFERRED_BY_USER           ',clc$nominal_entry, 6],
    ['JOB_DESTINATION                ',clc$nominal_entry, 7],
    ['JOB_DESTINATION_USAGE          ',clc$nominal_entry, 8],
    ['JOB_EXECUTION_RING             ',clc$nominal_entry, 9],
    ['JOB_NAME                       ',clc$alias_entry, 23],
    ['JOB_QUALIFIER                  ',clc$nominal_entry, 10],
    ['JOB_QUALIFIERS                 ',clc$alias_entry, 10],
    ['JOB_RECOVERY_DISPOSITION       ',clc$nominal_entry, 11],
    ['JQ                             ',clc$abbreviation_entry, 10],
    ['JRD                            ',clc$abbreviation_entry, 11],
    ['LATEST_RUN_TIME                ',clc$nominal_entry, 12],
    ['LF                             ',clc$abbreviation_entry, 13],
    ['LOGIN_FAMILY                   ',clc$nominal_entry, 13],
    ['LRT                            ',clc$abbreviation_entry, 12],
    ['MAGNETIC_TAPE_LIMIT            ',clc$nominal_entry, 14],
    ['MAXIMUM_WORKING_SET            ',clc$nominal_entry, 15],
    ['MAXWS                          ',clc$abbreviation_entry, 15],
    ['MTL                            ',clc$abbreviation_entry, 14],
    ['ODI                            ',clc$abbreviation_entry, 18],
    ['OF                             ',clc$abbreviation_entry, 16],
    ['OPERATOR_FAMILY                ',clc$nominal_entry, 16],
    ['OPERATOR_USER                  ',clc$nominal_entry, 17],
    ['OU                             ',clc$abbreviation_entry, 17],
    ['OUTPUT_DISPOSITION             ',clc$nominal_entry, 18],
    ['REMOTE_HOST_DIRECTIVE          ',clc$nominal_entry, 19],
    ['RHD                            ',clc$abbreviation_entry, 19],
    ['S                              ',clc$abbreviation_entry, 21],
    ['SJN                            ',clc$abbreviation_entry, 24],
    ['SL                             ',clc$abbreviation_entry, 20],
    ['SO                             ',clc$alias_entry, 18],
    ['SRU_LIMIT                      ',clc$nominal_entry, 20],
    ['STANDARD_OUTPUT                ',clc$alias_entry, 18],
    ['STATION                        ',clc$nominal_entry, 21],
    ['STATUS                         ',clc$nominal_entry, 25],
    ['SYSTEM_JOB_NAME                ',clc$nominal_entry, 24],
    ['UI                             ',clc$abbreviation_entry, 22],
    ['UJN                            ',clc$abbreviation_entry, 23],
    ['USER_INFORMATION               ',clc$nominal_entry, 22],
    ['USER_JOB_NAME                  ',clc$nominal_entry, 23]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 158,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 6
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 7
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 33, clc$optional_parameter,
  0, 0],
{ PARAMETER 8
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 254,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 10
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 122,
  clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 13
    [31, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 14
    [33, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 158,
  clc$optional_parameter, 0, 0],
{ PARAMETER 15
    [34, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 158,
  clc$optional_parameter, 0, 0],
{ PARAMETER 16
    [39, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 21],
{ PARAMETER 17
    [40, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 19],
{ PARAMETER 18
    [42, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 437,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 19
    [43, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 20
    [49, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 158,
  clc$optional_parameter, 0, 0],
{ PARAMETER 21
    [51, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 0, 13],
{ PARAMETER 22
    [56, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 23
    [57, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 24
    [53, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 58,
  clc$optional_parameter, 0, 0],
{ PARAMETER 25
    [52, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_cpu_time_limit, jmc$highest_cpu_time_limit, 10]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$date_time_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [
  clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [4], [
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['RESTART                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 5
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 6
    [[1, 0, clc$boolean_type]],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    229, [[1, 0, clc$keyword_type], [6], [
      ['NTF                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['QTF                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['VE                             ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['VE_FAMILY                      ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['VE_LOCAL                       ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['VE_QTF                         ', clc$nominal_entry, clc$normal_usage_entry, 6]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 9
    [[1, 0, clc$integer_type], [osc$sj_ring_1, osc$user_ring_2, 10]],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, jmc$maximum_job_qualifiers, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 11
    [[1, 0, clc$keyword_type], [6], [
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CONTINUE                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['RESTART                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 12
    [[1, 0, clc$union_type], [[clc$date_time_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [
  clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 13
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 14
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_magnetic_tape_limit, jmc$highest_magnetic_tape_limit, 10]]
    ],
{ PARAMETER 15
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_working_set_size, jmc$highest_working_set_size, 10]]
    ],
{ PARAMETER 16
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    '$job(operator_family)'],
{ PARAMETER 17
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    '$job(operator_user)'],
{ PARAMETER 18
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    414, [[1, 0, clc$keyword_type], [11], [
      ['DAO                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DISCARD_ALL_OUTPUT             ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['DISCARD_STANDARD_OUTPUT        ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['DSO                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['LOCAL                          ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['PRINTER                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['WAIT_QUEUE                     ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['WQ                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['WT                             ', clc$alias_entry, clc$normal_usage_entry, 5]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'printer'],
{ PARAMETER 19
    [[1, 0, clc$string_type], [0, jmc$remote_host_directive_size, FALSE]],
{ PARAMETER 20
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_sru_limit, jmc$highest_sru_limit, 10]]
    ],
{ PARAMETER 21
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['AUTOMATIC                      ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    '$job(station)'],
{ PARAMETER 22
    [[1, 0, clc$string_type], [0, jmc$user_information_size, FALSE]],
{ PARAMETER 23
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 24
    [[1, 0, clc$union_type], [[clc$list_type, clc$name_type, clc$string_type],
    FALSE, 3],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 25
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$cpu_time_limit = 2,
      p$earliest_run_time = 3,
      p$job_abort_disposition = 4,
      p$job_class = 5,
      p$job_deferred_by_user = 6,
      p$job_destination = 7,
      p$job_destination_usage = 8,
      p$job_execution_ring = 9,
      p$job_qualifier = 10,
      p$job_recovery_disposition = 11,
      p$latest_run_time = 12,
      p$login_family = 13,
      p$magnetic_tape_limit = 14,
      p$maximum_working_set = 15,
      p$operator_family = 16,
      p$operator_user = 17,
      p$output_disposition = 18,
      p$remote_host_directive = 19,
      p$sru_limit = 20,
      p$station = 21,
      p$user_information = 22,
      p$user_job_name = 23,
      p$system_job_name = 24,
      p$status = 25;

    VAR
      pvt: array [1 .. 25] of clt$parameter_value;

    VAR
      access_mode: clt$data_access_mode,
      class: clt$variable_class,
      default_job_attributes_p: ^jmt$default_attribute_results,
      evaluation_method: clt$expression_eval_method,
      file_count: 0 .. clc$max_list_size,
      file_list: ^clt$data_value,
      file_number: 0 .. clc$max_list_size,
      ignore_ready_index: integer,
      ignore_status: ost$status,
      index: 0 .. p$user_job_name,
      job_qualifier_count: 0 .. clc$max_list_size,
      job_qualifier_index: 1 .. clc$max_list_size,
      job_qualifier_options: ^clt$data_value,
      job_submission_index: 0 .. p$user_job_name,
      job_submission_options: ^jmt$job_submission_options,
      list_value: ^clt$data_value,
      number_of_submission_options: 0 .. p$user_job_name,
      type_information: clt$type_information,
      type_specification: ^clt$type_specification,
      user_job_name_count: 0 .. clc$max_list_size,
      user_job_name_list: ^clt$data_value,
      system_job_name: ^clt$data_value,
      system_supplied_name: jmt$system_supplied_name,
      wait_list_p: ^ost$i_wait_list,
      work_area_p: ^^clt$work_area,
      value: ^clt$data_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    job_submission_options := NIL;
    file_count := clp$count_list_elements (pvt [p$file].value);
    IF pvt [p$user_job_name].specified THEN
      user_job_name_count := clp$count_list_elements (pvt [p$user_job_name].value);
    ELSE
      user_job_name_count := 0;
    IFEND;

    IF user_job_name_count > file_count THEN
      osp$set_status_abnormal ('CL', cle$too_many_values, 'USER_JOB_NAME', status);
      RETURN;
    IFEND;

    job_submission_index := 0;
    number_of_submission_options := 0;

    FOR index := p$cpu_time_limit TO p$user_job_name DO
      CASE pvt [index].passing_method OF
      = clc$pass_by_value =
        IF pvt [index].value <> NIL THEN
          number_of_submission_options := number_of_submission_options + 1;
        IFEND;
      = clc$pass_by_reference =
        IF pvt [index].variable <> NIL THEN
          number_of_submission_options := number_of_submission_options + 1;
        IFEND;
      CASEND;
    FOREND;

    IF number_of_submission_options <> 0 THEN
      PUSH job_submission_options: [1 .. number_of_submission_options];
    IFEND;

{  Process CPU_TIME_LIMIT parameter.

    IF pvt [p$cpu_time_limit].specified THEN
      job_submission_index := job_submission_index + 1;
      job_submission_options^ [job_submission_index].key := jmc$cpu_time_limit;
      IF pvt [p$cpu_time_limit].value^.kind = clc$integer THEN
        job_submission_options^ [job_submission_index].cpu_time_limit :=
              pvt [p$cpu_time_limit].value^.integer_value.value;
      ELSE
        IF pvt [p$cpu_time_limit].value^.keyword_value = 'UNSPECIFIED' THEN
          job_submission_options^ [job_submission_index].cpu_time_limit := jmc$unspecified_cpu_time_limit;
        ELSEIF pvt [p$cpu_time_limit].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
          job_submission_options^ [job_submission_index].cpu_time_limit := jmc$system_default_cpu_time_lim;
        ELSE { pvt [p$cpu_time_limit].value^.keyword_value = 'UNLIMITED'.
          job_submission_options^ [job_submission_index].cpu_time_limit := jmc$unlimited_cpu_time_limit;
        IFEND;
      IFEND;
    IFEND;

{  Process EARLIEST_RUN_TIME parameter.

    IF pvt [p$earliest_run_time].specified THEN
      job_submission_index := job_submission_index + 1;
      job_submission_options^ [job_submission_index].key := jmc$earliest_run_time;
      IF pvt [p$earliest_run_time].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        job_submission_options^ [job_submission_index].earliest_run_time.specified := FALSE;
      ELSE
        job_submission_options^ [job_submission_index].earliest_run_time.specified := TRUE;
        job_submission_options^ [job_submission_index].earliest_run_time.date_time :=
              pvt [p$earliest_run_time].value^.date_time_value.value;
      IFEND;
    IFEND;

{  Process JOB_ABORT_DISPOSITION parameter.

    IF pvt [p$job_abort_disposition].specified THEN
      job_submission_index := job_submission_index + 1;
      job_submission_options^ [job_submission_index].key := jmc$job_abort_disposition;
      IF pvt [p$job_abort_disposition].value^.keyword_value = 'RESTART' THEN
        job_submission_options^ [job_submission_index].job_abort_disposition := jmc$restart_on_abort;
      ELSE { TERMINATE is the only other choice. }
        job_submission_options^ [job_submission_index].job_abort_disposition := jmc$terminate_on_abort;
      IFEND;
    IFEND;

{ Process JOB_CLASS parameter.

    IF pvt [p$job_class].specified THEN
      job_submission_index := job_submission_index + 1;
      job_submission_options^ [job_submission_index].key := jmc$job_class;
      job_submission_options^ [job_submission_index].job_class := pvt [p$job_class].value^.name_value;
    IFEND;

{  Process JOB_DEFERRED_BY_USER parameter.

    IF pvt [p$job_deferred_by_user].specified THEN
      job_submission_index := job_submission_index + 1;
      job_submission_options^ [job_submission_index].key := jmc$job_deferred_by_user;
      job_submission_options^ [job_submission_index].job_deferred_by_user :=
            pvt [p$job_deferred_by_user].value^.boolean_value.value;
    IFEND;

{  Process JOB_DESTINATION parameter.

    IF pvt [p$job_destination].specified THEN
      job_submission_index := job_submission_index + 1;
      job_submission_options^ [job_submission_index].key := jmc$job_destination_family;
      IF pvt [p$job_destination].value^.kind = clc$name THEN
        job_submission_options^ [job_submission_index].job_destination_family := pvt [p$job_destination].
              value^.name_value;
      ELSE
        job_submission_options^ [job_submission_index].job_destination_family := pvt [p$job_destination].
              value^.string_value^;
      IFEND;
    IFEND;

{  Process JOB_DESTINATION_USAGE parameter.

    IF pvt [p$job_destination_usage].specified THEN
      job_submission_index := job_submission_index + 1;
      job_submission_options^ [job_submission_index].key := jmc$job_destination_usage;
      IF pvt [p$job_destination_usage].value^.kind = clc$name THEN
        job_submission_options^ [job_submission_index].job_destination_usage :=
              pvt [p$job_destination_usage].value^.name_value;
      ELSE
        job_submission_options^ [job_submission_index].job_destination_usage :=
              pvt [p$job_destination_usage].value^.keyword_value;
      IFEND;
    IFEND;

{  Process JOB_EXECUTION_RING parameter.

    IF pvt [p$job_execution_ring].specified THEN
      job_submission_index := job_submission_index + 1;
      job_submission_options^ [job_submission_index].key := jmc$job_execution_ring;
      job_submission_options^ [job_submission_index].job_execution_ring :=
            pvt [p$job_execution_ring].value^.integer_value.value;
    IFEND;

{  Process JOB_QUALIFIER parameter.

    IF pvt [p$job_qualifier].specified THEN
      job_submission_index := job_submission_index + 1;
      job_submission_options^ [job_submission_index].key := jmc$job_qualifier_list;
      IF pvt [p$job_qualifier].value^.kind = clc$keyword THEN
        IF pvt [p$job_qualifier].value^.keyword_value = 'NONE' THEN
          PUSH job_submission_options^ [job_submission_index].job_qualifier_list: [1 .. 1];
          job_submission_options^ [job_submission_index].job_qualifier_list^ [1] := osc$null_name;
        ELSE { keyword_value = 'SYSTEM_DEFAULT'}
          PUSH default_job_attributes_p: [1 .. 1];
          default_job_attributes_p^ [1].key := jmc$job_qualifier_list;
          PUSH job_submission_options^ [job_submission_index].job_qualifier_list:
                [1 .. jmc$maximum_job_qualifiers];
          default_job_attributes_p^ [1].job_qualifier_list :=
                job_submission_options^ [job_submission_index].job_qualifier_list;
          jmp$get_attribute_defaults (jmc$batch, default_job_attributes_p, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      ELSE
        job_qualifier_count := clp$count_list_elements (pvt [p$job_qualifier].value);
        PUSH job_submission_options^ [job_submission_index].job_qualifier_list: [1 .. job_qualifier_count];
        job_qualifier_options := pvt [p$job_qualifier].value;
        FOR job_qualifier_index := 1 TO job_qualifier_count DO
          job_submission_options^ [job_submission_index].job_qualifier_list^ [job_qualifier_index] :=
                job_qualifier_options^.element_value^.name_value;
          job_qualifier_options := job_qualifier_options^.link;
        FOREND;
      IFEND;
    IFEND;

{  Process JOB_RECOVERY_DISPOSITION parameter.

    IF pvt [p$job_recovery_disposition].specified THEN
      job_submission_index := job_submission_index + 1;
      job_submission_options^ [job_submission_index].key := jmc$job_recovery_disposition;
      IF pvt [p$job_recovery_disposition].value^.keyword_value = 'RESTART' THEN
        job_submission_options^ [job_submission_index].job_recovery_disposition := jmc$restart_on_recovery;
      ELSEIF pvt [p$job_recovery_disposition].value^.keyword_value = 'CONTINUE' THEN
        job_submission_options^ [job_submission_index].job_recovery_disposition := jmc$continue_on_recovery;
      ELSE { pvt [p$job_recovery_disposition].value^.keyword_value = 'TERMINATE'.
        job_submission_options^ [job_submission_index].job_recovery_disposition := jmc$terminate_on_recovery;
      IFEND;
    IFEND;

{  Process LATEST_RUN_TIME parameter.

    IF pvt [p$latest_run_time].specified THEN
      job_submission_index := job_submission_index + 1;
      job_submission_options^ [job_submission_index].key := jmc$latest_run_time;
      IF pvt [p$latest_run_time].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        job_submission_options^ [job_submission_index].latest_run_time.specified := FALSE;
      ELSE
        job_submission_options^ [job_submission_index].latest_run_time.specified := TRUE;
        job_submission_options^ [job_submission_index].latest_run_time.date_time :=
              pvt [p$latest_run_time].value^.date_time_value.value;
      IFEND;
    IFEND;

{  Process LOGIN_FAMILY parameter.

    IF pvt [p$login_family].specified THEN
      job_submission_index := job_submission_index + 1;
      job_submission_options^ [job_submission_index].key := jmc$login_family;
      job_submission_options^ [job_submission_index].login_family := pvt [p$login_family].value^.name_value;
    IFEND;

{  Process MAGNETIC_TAPE_LIMIT parameter.

    IF pvt [p$magnetic_tape_limit].specified THEN
      job_submission_index := job_submission_index + 1;
      job_submission_options^ [job_submission_index].key := jmc$magnetic_tape_limit;
      IF pvt [p$magnetic_tape_limit].value^.kind = clc$integer THEN
        job_submission_options^ [job_submission_index].magnetic_tape_limit :=
              pvt [p$magnetic_tape_limit].value^.integer_value.value;
      ELSE
        IF pvt [p$magnetic_tape_limit].value^.keyword_value = 'UNSPECIFIED' THEN
          job_submission_options^ [job_submission_index].magnetic_tape_limit :=
                jmc$unspecified_mag_tape_limit;
        ELSEIF pvt [p$magnetic_tape_limit].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
          job_submission_options^ [job_submission_index].magnetic_tape_limit :=
                jmc$system_default_mag_tape_lim;
        ELSE { pvt [p$magnetic_tape_limit].value^.keyword_value = 'UNLIMITED'.
          job_submission_options^ [job_submission_index].magnetic_tape_limit := jmc$unlimited_mag_tape_limit;
        IFEND;
      IFEND;
    IFEND;

{  Process MAXIMUM_WORKING_SET parameter.

    IF pvt [p$maximum_working_set].specified THEN
      job_submission_index := job_submission_index + 1;
      job_submission_options^ [job_submission_index].key := jmc$maximum_working_set;
      IF pvt [p$maximum_working_set].value^.kind = clc$integer THEN
        job_submission_options^ [job_submission_index].maximum_working_set :=
              pvt [p$maximum_working_set].value^.integer_value.value;
      ELSE
        IF pvt [p$maximum_working_set].value^.keyword_value = 'UNSPECIFIED' THEN
          job_submission_options^ [job_submission_index].maximum_working_set := jmc$unspecified_work_set_size;
        ELSEIF pvt [p$maximum_working_set].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
          job_submission_options^ [job_submission_index].maximum_working_set :=
                jmc$system_default_work_set_siz;
        ELSE { pvt [p$maximum_working_set].value^.keyword_value = 'UNLIMITED'.
          job_submission_options^ [job_submission_index].maximum_working_set :=
                jmc$unlimited_working_set_size;
        IFEND;
      IFEND;
    IFEND;

{  Process OPERATOR_FAMILY parameter.

    job_submission_index := job_submission_index + 1;
    job_submission_options^ [job_submission_index].key := jmc$output_destination_family;
    job_submission_options^ [job_submission_index].output_destination_family := pvt [p$operator_family].
          value^.name_value;

{  Process OPERATOR_USER parameter.

    job_submission_index := job_submission_index + 1;
    job_submission_options^ [job_submission_index].key := jmc$station_operator;
    job_submission_options^ [job_submission_index].station_operator := pvt [p$operator_user].value^.
          name_value;

{  Process OUTPUT_DISPOSITION parameter.

    job_submission_index := job_submission_index + 1;
    job_submission_options^ [job_submission_index].key := jmc$output_disposition;
    IF pvt [p$output_disposition].value^.kind = clc$file THEN
      job_submission_options^ [job_submission_index].output_disposition.key := jmc$standard_output_path;
      PUSH job_submission_options^ [job_submission_index].output_disposition.standard_output_path;
      job_submission_options^ [job_submission_index].output_disposition.standard_output_path^ :=
            pvt [p$output_disposition].value^.file_value^;
    ELSE
      IF pvt [p$output_disposition].value^.keyword_value = 'PRINTER' THEN
        job_submission_options^ [job_submission_index].output_disposition.key :=
              jmc$normal_output_disposition;
      ELSEIF pvt [p$output_disposition].value^.keyword_value = 'DISCARD_ALL_OUTPUT' THEN
        job_submission_options^ [job_submission_index].output_disposition.key := jmc$discard_all_output;
      ELSEIF pvt [p$output_disposition].value^.keyword_value = 'DISCARD_STANDARD_OUTPUT' THEN
        job_submission_options^ [job_submission_index].output_disposition.key := jmc$discard_standard_output;
      ELSEIF pvt [p$output_disposition].value^.keyword_value = 'LOCAL' THEN
        job_submission_options^ [job_submission_index].output_disposition.key := jmc$local_output_disposition;
      ELSE { pvt [p$output_disposition].value^.keyword_value = 'WAIT_QUEUE'.
        job_submission_options^ [job_submission_index].output_disposition.key := jmc$wait_queue_path;
        job_submission_options^ [job_submission_index].output_disposition.wait_queue_path := NIL;
      IFEND;
    IFEND;

{  Process REMOTE_HOST_DIRECTIVE parameter.

    IF pvt [p$remote_host_directive].specified THEN
      job_submission_index := job_submission_index + 1;
      job_submission_options^ [job_submission_index].key := jmc$remote_host_directive;
      PUSH job_submission_options^ [job_submission_index].remote_host_directive;
      job_submission_options^ [job_submission_index].remote_host_directive^.size :=
            STRLENGTH (pvt [p$remote_host_directive].value^.string_value^);
      job_submission_options^ [job_submission_index].remote_host_directive^.parameters :=
            pvt [p$remote_host_directive].value^.string_value^;
    IFEND;

{  Process SRU_LIMIT parameter.

    IF pvt [p$sru_limit].specified THEN
      job_submission_index := job_submission_index + 1;
      job_submission_options^ [job_submission_index].key := jmc$sru_limit;
      IF pvt [p$sru_limit].value^.kind = clc$integer THEN
        job_submission_options^ [job_submission_index].sru_limit :=
              pvt [p$sru_limit].value^.integer_value.value;
      ELSE
        IF pvt [p$sru_limit].value^.keyword_value = 'UNSPECIFIED' THEN
          job_submission_options^ [job_submission_index].sru_limit := jmc$unspecified_sru_limit;
        ELSEIF pvt [p$sru_limit].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
          job_submission_options^ [job_submission_index].sru_limit := jmc$system_default_sru_limit;
        ELSE { pvt [p$sru_limit].value^.keyword_value = 'UNLIMITED'.
          job_submission_options^ [job_submission_index].sru_limit := jmc$unlimited_sru_limit;
        IFEND;
      IFEND;
    IFEND;

{  Process STATION parameter.

    job_submission_index := job_submission_index + 1;
    job_submission_options^ [job_submission_index].key := jmc$station;
    IF pvt [p$station].value^.kind = clc$keyword THEN
      job_submission_options^ [job_submission_index].station := pvt [p$station].value^.keyword_value;
    ELSE
      job_submission_options^ [job_submission_index].station := pvt [p$station].value^.name_value;
    IFEND;

{  Process USER_INFORMATION parameter.

    IF pvt [p$user_information].specified THEN
      job_submission_index := job_submission_index + 1;
      job_submission_options^ [job_submission_index].key := jmc$user_information;
      PUSH job_submission_options^ [job_submission_index].user_information;
      job_submission_options^ [job_submission_index].user_information^ :=
            pvt [p$user_information].value^.string_value^;
    IFEND;

{  Process FILE,  SYSTEM_JOB_NAME, and USER_JOB_NAME parameters.

    IF pvt [p$system_job_name].specified THEN
      clp$get_work_area (#RING (^work_area_p), work_area_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$get_variable (pvt [p$system_job_name].variable^, work_area_p^, class, access_mode,
            evaluation_method, type_specification, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$get_type_information (type_specification, work_area_p^, type_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE type_information.kind OF
      = clc$list_type =
        PUSH list_value;
        system_job_name := list_value;
        system_job_name^.kind := clc$list;
        system_job_name^.element_value := NIL;
        system_job_name^.link := NIL;
        system_job_name^.generated_via_list_rest := FALSE;
      = clc$name_type =
        PUSH system_job_name;
        system_job_name^.kind := clc$name;
      ELSE { = clc$string_type =
        PUSH system_job_name;
        PUSH system_job_name^.string_value: [jmc$system_supplied_name_size];
        system_job_name^.kind := clc$string;
      CASEND;
    IFEND;

    file_list := pvt [p$file].value;
    IF user_job_name_count <> 0 THEN
      user_job_name_list := pvt [p$user_job_name].value;
      job_submission_index := job_submission_index + 1;
    ELSE
      user_job_name_list := NIL;
    IFEND;

    FOR file_number := 1 TO file_count DO
      IF (file_number <= user_job_name_count) AND (user_job_name_list <> NIL) THEN
        job_submission_options^ [job_submission_index].key := jmc$user_job_name;
        job_submission_options^ [job_submission_index].user_job_name :=
              user_job_name_list^.element_value^.name_value;
        user_job_name_list := user_job_name_list^.link;
      ELSEIF user_job_name_count <> 0 THEN
        job_submission_options^ [job_submission_index].key := jmc$null_attribute;
      IFEND;

      REPEAT
        jmp$submit_job (file_list^.element_value^.file_value^, job_submission_options, system_supplied_name,
              status);
        IF (NOT status.normal) AND (status.condition = jme$no_space_for_file) THEN
          jmp$update_display_message (status);

{ Wait for a while before retrying to give the system a chance to get some space back.

          PUSH wait_list_p: [1 .. 1];
          wait_list_p^ [1].activity := osc$i_await_time;
          wait_list_p^ [1].milliseconds := no_queue_space_wait_time;
          osp$i_await_activity_completion (wait_list_p^, ignore_ready_index, ignore_status);
        IFEND;
      UNTIL status.normal OR (status.condition <> jme$no_space_for_file);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF pvt [p$system_job_name].specified THEN
        IF system_job_name^.kind = clc$list THEN
          IF list_value^.element_value <> NIL THEN
            PUSH list_value^.link;
            list_value := list_value^.link;
            list_value^.kind := clc$list;
          IFEND;
          PUSH list_value^.element_value;
          list_value^.element_value^.kind := clc$name;
          list_value^.element_value^.name_value := system_supplied_name;
          list_value^.link := NIL;
          list_value^.generated_via_list_rest := FALSE;
        ELSEIF system_job_name^.kind = clc$name THEN
          IF file_number = 1 THEN
            system_job_name^.name_value := system_supplied_name;
          IFEND;
        ELSE { clc$string.
          IF file_number = 1 THEN
            system_job_name^.string_value^ := system_supplied_name;
          IFEND;
        IFEND;
      IFEND;

      file_list := file_list^.link;
    FOREND;

    IF pvt [p$system_job_name].specified THEN
      clp$change_variable (pvt [p$system_job_name].variable^, system_job_name, status);
    IFEND;

  PROCEND jmp$_submit_job;
?? TITLE := '[XDCL] jmp$_terminate_job', EJECT ??

  PROCEDURE [XDCL] jmp$_terminate_job
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$terj) terminate_job, terminate_jobs, terj (
{   name, jn, job_name, job_names, names, n: list of name = $required
{   job_state, s, state, js: any of
{       key
{         all
{       keyend
{       list of key
{         (deferred, d)
{         (queued, q)
{         (initiated, i)
{         (terminated, t)
{       keyend
{     anyend = all
{   output_disposition, odi: key
{       (discard_standard_output, dso)
{       (printer, p)
{       (wait_queue, wt, wq)
{     keyend = $optional
{   reason, r: (ADVANCED) any of
{       key
{         (operator_backup, ob)
{         (none, n)
{       keyend
{       name
{     anyend = none
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 15] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 8] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 7] of clt$keyword_specification,
      recend,
      type4: 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 .. 4] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 9, 29, 11, 55, 45, 786],
    clc$command, 15, 5, 1, 1, 0, 0, 5, 'OSM$TERJ'], [
    ['JN                             ',clc$alias_entry, 1],
    ['JOB_NAME                       ',clc$alias_entry, 1],
    ['JOB_NAMES                      ',clc$alias_entry, 1],
    ['JOB_STATE                      ',clc$nominal_entry, 2],
    ['JS                             ',clc$abbreviation_entry, 2],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['ODI                            ',clc$abbreviation_entry, 3],
    ['OUTPUT_DISPOSITION             ',clc$nominal_entry, 3],
    ['R                              ',clc$abbreviation_entry, 4],
    ['REASON                         ',clc$nominal_entry, 4],
    ['S                              ',clc$alias_entry, 2],
    ['STATE                          ',clc$alias_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 383,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 266,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [12, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 180,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 5
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[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]]
      ],
    319, [[1, 0, clc$list_type], [303, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [8], [
        ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['DEFERRED                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['INITIATED                      ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['Q                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['QUEUED                         ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['TERMINATED                     ', clc$nominal_entry, clc$normal_usage_entry, 4]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [7], [
    ['DISCARD_STANDARD_OUTPUT        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['DSO                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['PRINTER                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['WAIT_QUEUE                     ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['WQ                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['WT                             ', clc$alias_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    155, [[1, 0, clc$keyword_type], [4], [
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['OB                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['OPERATOR_BACKUP                ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'none'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$job_state = 2,
      p$output_disposition = 3,
      p$reason = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

{ This constant represents the maximum number of parameters specified on the
{ command plus one for forcing the request to go to server mainframes in a
{ cluster.

    CONST
      max_termination_options = 4;

    VAR
      value: clt$value,
      name_number: 1 .. clc$max_list_size,
      job_name: jmt$name,
      job_state_list: ^clt$data_value,
      job_state_list_index: 0 .. clc$max_list_size,
      name_list: ^clt$data_value,
      job_termination_options: ^jmt$job_termination_options,
      reason: ost$name;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH job_termination_options: [1 .. max_termination_options];

{  Process JOB_STATE parameter.

    job_termination_options^ [1].key := jmc$job_state_set;
    job_termination_options^ [1].job_state_set := $jmt$job_state_set [];
    IF pvt [p$job_state].value^.kind = clc$keyword THEN { option = ALL
      job_termination_options^ [1].job_state_set := -$jmt$job_state_set [jmc$completed_job];
    ELSE
      job_state_list := pvt [p$job_state].value;
      WHILE job_state_list <> NIL DO
        IF job_state_list^.element_value^.keyword_value = 'DEFERRED' THEN
          job_termination_options^ [1].job_state_set := job_termination_options^ [1].job_state_set +
                $jmt$job_state_set [jmc$deferred_job];
        ELSEIF job_state_list^.element_value^.keyword_value = 'QUEUED' THEN
          job_termination_options^ [1].job_state_set := job_termination_options^ [1].job_state_set +
                $jmt$job_state_set [jmc$queued_job];
        ELSEIF job_state_list^.element_value^.keyword_value = 'INITIATED' THEN
          job_termination_options^ [1].job_state_set := job_termination_options^ [1].job_state_set +
                $jmt$job_state_set [jmc$initiated_job];
        ELSE { 'TERMINATED'
          job_termination_options^ [1].job_state_set := job_termination_options^ [1].job_state_set +
                $jmt$job_state_set [jmc$terminating_job];
        IFEND;
        job_state_list := job_state_list^.link;
      WHILEND;
    IFEND;

{  Process OUTPUT_DISPOSITION parameter.

    IF pvt [p$output_disposition].specified THEN
      job_termination_options^ [2].key := jmc$output_disposition;
      IF pvt [p$output_disposition].value^.keyword_value = 'DISCARD_STANDARD_OUTPUT' THEN
        job_termination_options^ [2].output_disposition.key := jmc$discard_standard_output;
      ELSEIF pvt [p$output_disposition].value^.keyword_value = 'PRINTER' THEN
        job_termination_options^ [2].output_disposition.key := jmc$normal_output_disposition;
      ELSE { pvt [p$output_disposition].value^.keyword_value = 'WAIT_QUEUE'.
        job_termination_options^ [2].output_disposition.key := jmc$wait_queue_path;
        job_termination_options^ [2].output_disposition.wait_queue_path := NIL;
      IFEND;
    ELSE
      job_termination_options^ [2].key := jmc$null_attribute;
    IFEND;

    job_termination_options^ [3].key := jmc$continue_request_to_servers;
    job_termination_options^ [3].continue_request_to_servers := TRUE;

{Process REASON parameter.

    job_termination_options^ [4].key := jmc$termination_reason;
    job_termination_options^ [4].reason_p := ^reason;
    IF (NOT avp$system_administrator ()) AND (NOT avp$system_operator ()) THEN
      osp$get_status_condition_name (jme$job_deleted_via_command, reason, {ignore} status);
    ELSEIF pvt [p$reason].value^.kind = clc$keyword THEN
      IF pvt [p$reason].value^.keyword_value = 'NONE' THEN
        osp$get_status_condition_name (jme$job_deleted_via_command, reason, {ignore} status);
      ELSE
        osp$get_status_condition_name (jme$operator_queue_backup, reason, {ignore} status);
      IFEND;
    ELSE
      reason := pvt [p$reason].value^.name_value;
    IFEND;

{Process NAME parameter.

    name_list := pvt [p$name].value;

    WHILE name_list <> NIL DO
      jmp$determine_name_kind (name_list^.element_value^.name_value, job_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      jmp$terminate_job (job_name, job_termination_options, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      name_list := name_list^.link;
    WHILEND;

  PROCEND jmp$_terminate_job;
?? TITLE := '[XDCL] jmp$_terminate_output', EJECT ??

  PROCEDURE [XDCL] jmp$_terminate_output
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$tero) terminate_output, tero (
{   name, names, n: any of
{       key output keyend
{       list of name
{     anyend = $required
{   output_state, os: key
{       all
{       (deferred, d)
{       (queued, q)
{       (initiated, i)
{       (completed, c)
{     keyend = all
{   reason, r: (ADVANCED) any of
{       key
{         (operator_backup, ob)
{         (none, n)
{       keyend
{       name
{     anyend = none
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 9] of clt$keyword_specification,
        default_value: string (3),
      recend,
      type3: 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 .. 4] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 10, 4, 22, 29, 56, 675],
    clc$command, 8, 4, 1, 1, 0, 0, 4, 'OSM$TERO'], [
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['OS                             ',clc$abbreviation_entry, 2],
    ['OUTPUT_STATE                   ',clc$nominal_entry, 2],
    ['R                              ',clc$abbreviation_entry, 3],
    ['REASON                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 340,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [7, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 180,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['OUTPUT                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [9], [
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['COMPLETED                      ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['DEFERRED                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['INITIATED                      ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['Q                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['QUEUED                         ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    155, [[1, 0, clc$keyword_type], [4], [
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['OB                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['OPERATOR_BACKUP                ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'none'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$output_state = 2,
      p$reason = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      job_attribute_changes_p: ^jmt$job_attribute_changes,
      name_list: ^clt$data_value,
      name_number: 1 .. clc$max_list_size,
      output_name: jmt$name,
      output_termination_options: ^jmt$output_termination_options;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH output_termination_options: [1 .. 2];

{  Process OUTPUT_STATE parameter.

    output_termination_options^ [1].key := jmc$output_state_set;
    output_termination_options^ [1].output_state_set := $jmt$output_state_set [];
    IF pvt [p$output_state].value^.keyword_value = 'ALL' THEN
      output_termination_options^ [1].output_state_set := -$jmt$output_state_set [jmc$terminated_output];
    ELSEIF pvt [p$output_state].value^.keyword_value = 'DEFERRED' THEN
      output_termination_options^ [1].output_state_set := $jmt$output_state_set [jmc$deferred_output];
    ELSEIF pvt [p$output_state].value^.keyword_value = 'QUEUED' THEN
      output_termination_options^ [1].output_state_set := $jmt$output_state_set [jmc$queued_output];
    ELSEIF pvt [p$output_state].value^.keyword_value = 'INITIATED' THEN
      output_termination_options^ [1].output_state_set := $jmt$output_state_set [jmc$initiated_output];
    ELSE { keyword_value = 'COMPLETED'
      output_termination_options^ [1].output_state_set := $jmt$output_state_set [jmc$completed_output];
    IFEND;

{Process REASON parameter.

    output_termination_options^ [2].key := jmc$termination_reason;
    IF (NOT avp$system_administrator ()) AND (NOT avp$system_operator ()) THEN
      osp$get_status_condition_name (jme$output_deleted_via_command, output_termination_options^ [2].reason,
            {ignore} status);
    ELSEIF pvt [p$reason].value^.kind = clc$keyword THEN
      IF pvt [p$reason].value^.keyword_value = 'NONE' THEN
        osp$get_status_condition_name (jme$output_deleted_via_command, output_termination_options^ [2].reason,
              {ignore} status);
      ELSE
        osp$get_status_condition_name (jme$operator_queue_backup, output_termination_options^ [2].reason,
              {ignore} status);
      IFEND;
    ELSE
      output_termination_options^ [2].reason := pvt [p$reason].value^.name_value;
    IFEND;

{Process NAME parameter.

    name_list := pvt [p$name].value;

    IF name_list^.kind = clc$keyword THEN
      PUSH job_attribute_changes_p: [1 .. 1];
      job_attribute_changes_p^ [1].key := jmc$output_disposition;
      job_attribute_changes_p^ [1].output_disposition.key := jmc$discard_standard_output;
      jmp$change_job_attributes (job_attribute_changes_p, status);
      IF NOT status.normal THEN
        RETURN
      IFEND;
    ELSE
      WHILE name_list <> NIL DO
        jmp$determine_name_kind (name_list^.element_value^.name_value, output_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        jmp$terminate_output (output_name, output_termination_options, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        name_list := name_list^.link;
      WHILEND;
    IFEND;

  PROCEND jmp$_terminate_output;
MODEND jmm$queue_file_commands;

*DECK DECK=JMM$QUEUE_FILE_JOB_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Job Management Queued Files Job Interfaces' ??
MODULE jmm$queue_file_job_manager;

{ PURPOSE:
{   This module contains the queue file job management interfaces.  These interfaces control access to,
{ submission of, and manipulation of jobs.
{
{ DESIGN:
{   The program interfaces contained in this module are designed in such a fashion that binary
{ compatibility can be maintained.  Any change to the size of a record element in a variant record
{ will result in an interface breakage.  These procedures operate in rings 2 and 3 with a call bracket
{ of ring 13.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_attributes
*copyc amt$local_file_name
*copyc avc$validation_field_names
*copyc avc$system_defined_limit_names
*copyc ave$validation_interface_errors
*copyc avt$name_list_size
*copyc avt$password
*copyc cle$ecc_lexical
*copyc clt$command_line_size
*copyc fst$file_reference
*copyc jmc$change_input_attributes
*copyc jmc$class_names
*copyc jmc$get_input_attributes
*copyc jmc$get_job_status
*copyc jmc$job_management_id
*copyc jmc$maximum_system_label_length
*copyc jmc$submit_job
*copyc jmc$system_family
*copyc jmc$terminate_job
*copyc jme$job_categorization_errors
*copyc jme$job_history_conditions
*copyc jme$job_on_another_mainframe
*copyc jme$job_scheduler_conditions
*copyc jme$no_space_for_file
*copyc jme$operator_queue_restore
*copyc jme$queued_file_conditions
*copyc jme$served_family_unavailable
*copyc jme$work_area_too_small
*copyc jmk$keypoints
*copyc jmt$attribute_keys_set
*copyc jmt$clock_time
*copyc jmt$full_job_category_list
*copyc jmt$input_application_index
*copyc jmt$input_attribute_changes
*copyc jmt$input_attribute_options
*copyc jmt$input_attribute_results
*copyc jmt$input_descriptor
*copyc jmt$input_file_location
*copyc jmt$job_class_limits
*copyc jmt$job_control_block
*copyc jmt$job_counts
*copyc jmt$job_count_range
*copyc jmt$job_state_set
*copyc jmt$job_status_count
*copyc jmt$job_status_options
*copyc jmt$job_status_results
*copyc jmt$job_submission_options
*copyc jmt$job_system_label
*copyc jmt$job_termination_options
*copyc jmt$leveled_job_connect_data
*copyc jmt$mainframe_leveling_data
*copyc jmt$mainframes_searched_list
*copyc jmt$maximum_mainframes
*copyc jmt$name
*copyc jmt$name_list
*copyc jmt$output_disposition
*copyc jmt$output_system_label
*copyc jmt$queue_file_password
*copyc jmt$queue_file_path
*copyc jmt$release_input_file_list
*copyc jmt$results_keys
*copyc jmt$submit_job_variations
*copyc jmt$system_supplied_name
*copyc jmt$terminate_job_action
*copyc jmt$user_supplied_name
*copyc jmt$work_area
*copyc ofe$error_codes
*copyc osc$deadstart
*copyc osc$dual_state_interactive
*copyc osc$file_transfer_server
*copyc osc$space_unavailable_condition
*copyc osc$submit_job
*copyc osc$timesharing
*copyc osc$xterm_application_name
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc oss$task_private
*copyc oss$task_shared
*copyc ost$caller_identifier
*copyc ost$date_time
*copyc ost$status
*copyc ost$user_identification
*copyc pmt$family_name_list
*copyc sfc$unlimited
*copyc sye$job_recovery_conditions
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$return
*copyc avp$configuration_administrator
*copyc avp$get_capability
*copyc avp$prevalidate_job
*copyc avp$security_option_active
*copyc avp$system_administrator
*copyc avp$system_displays
*copyc avp$system_operator
*copyc clp$convert_file_ref_to_string
*copyc clp$evaluate_file_reference
*copyc clp$convert_string_to_file_ref
*copyc clp$get_job_parameters
*copyc clp$get_login_parameters
*copyc clp$pop_parameters
*copyc clp$push_sub_parameters_block
*copyc clp$trimmed_string_size
*copyc clp$validate_name
*copyc dfp$check_job_recovery
*copyc dfp$get_family_access
*copyc dfp$get_partner_mainframes
*copyc dfp$send_remote_procedure_call
*copyc fsp$close_file
*copyc fsp$open_file
*copyc fsp$subsystem_copy_file
*copyc i#current_sequence_position
*copyc i#move
*copyc ifp$invoke_pause_utility
*copyc jmp$convert_date_time_dif_to_us
*copyc jmp$copy_seq_to_result_array
*copyc jmp$determine_job_class
*copyc jmp$emit_communication_stat
*copyc jmp$emit_job_history_statistics
*copyc jmp$general_purpose_cluster_rpc
*copyc jmp$get_attribute_name
*copyc jmp$get_data_packet_size
*copyc jmp$get_jm_work_area
*copyc jmp$get_result_size
*copyc jmp$get_scheduling_admin_status
*copyc jmp$expand_job_class_abbrev
*copyc jmp$mainframe_get_leveling_data
*copyc jmp$select_interactive_job_dest
*copyc jmp$system_job
*copyc jmp$validate_attribute_options
*copyc jmp$validate_name
*copyc jmp$validate_status_options
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc nap$parse_accounting_data
*copyc nap$set_server_job_init_pending
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$check_client_leveled_access
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$force_access_violation
*copyc osp$get_status_condition_name
*copyc osp$is_caller_system_privileged
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$verify_system_privilege
*copyc pfp$attach
*copyc pfp$begin_system_authority
*copyc pfp$define
*copyc pfp$define_catalog
*copyc pfp$end_system_authority
*copyc pfp$purge
*copyc pmp$continue_to_cause
*copyc pmp$convert_binary_mainframe_id
*copyc pmp$convert_mainframe_to_binary
*copyc pmp$execute
*copyc pmp$get_account_project
*copyc pmp$get_compact_date_time
*copyc pmp$get_job_names
*copyc pmp$get_mainframe_id
*copyc pmp$get_microsecond_clock
*copyc pmp$get_pseudo_mainframe_id
*copyc pmp$get_unique_name
*copyc pmp$get_user_identification
*copyc pmp$wait
*copyc qfp$acquire_modified_input
*copyc qfp$acquire_new_input
*copyc qfp$activate_deferred_family
*copyc qfp$assign_system_supplied_name
*copyc qfp$categorize_job
*copyc qfp$change_input_attributes
*copyc qfp$change_terminate_job_action
*copyc qfp$check_for_profile_mismatch
*copyc qfp$defer_deactivated_family
*copyc qfp$determine_mainframe_fitness
*copyc qfp$get_input_file_location
*copyc qfp$get_input_q_from_unassigned
*copyc qfp$get_job_counts
*copyc qfp$get_job_status
*copyc qfp$read_job_system_label
*copyc qfp$rebuild_executing_job
*copyc qfp$rebuild_input_queue
*copyc qfp$register_input_application
*copyc qfp$release_input_files
*copyc qfp$remove_job_from_kjl
*copyc qfp$set_input_completed
*copyc qfp$set_input_initiated
*copyc qfp$set_job_class_limits
*copyc qfp$submit_job
*copyc qfp$terminate_acquired_input
*copyc qfp$terminate_job
*copyc qfp$validate_input_file_access
*copyc qfp$write_job_system_label
*copyc sfp$emit_audit_statistic
*copyc syp$system_is_idling
*copyc clv$standard_files
*copyc jmv$default_job_attributes
*copyc jmv$enable_queue_file_access
*copyc jmv$job_attributes
*copyc jmv$job_category_data
*copyc jmv$job_class_table_p
*copyc jmv$job_history_active
*copyc jmv$job_management_work_area_p
*copyc jmv$job_scheduler_table
*copyc jmv$kjl_p
*copyc jmv$kjlx_p
*copyc jmv$known_job_list
*copyc jmv$sched_profile_is_loading
*copyc jmv$system_job_ssn
*copyc osv$lower_to_upper
*copyc osv$task_private_heap
*copyc qfv$terminate_job_action_set

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    uppercase_required = 'REQUIRED';

  TYPE
    mainframe_chaia_parameters = record
      system_job_name: jmt$system_supplied_name,
      login_family: ost$name,
      input_file_location: jmt$input_file_location,
      system_changing_attributes: boolean,
      privileged_for_status: boolean,
      beginning_job_class: jmt$job_class_name,
      attribute_change_count: ost$non_negative_integers,
    recend;

  TYPE
    mainframe_getia_parameters = record
      status_option_count: ost$non_negative_integers,
      attach_file: boolean,
      results_keys_count: ost$non_negative_integers,
    recend;

  TYPE
    mainframe_getjs_parameters = record
      user_identification: ost$user_identification,
      caller_ssn: jmt$system_supplied_name,
      privileged_job: boolean,
      valid_for_scheduling_displays: boolean,
      status_option_count: ost$non_negative_integers,
      status_results_count: ost$non_negative_integers,
    recend;

  TYPE
    server_submit_job_parameters = record
      immediate_initiation_candidate: boolean,
      executing_on_server: boolean,
      origin_mainframe_id: pmt$mainframe_id,
    recend;

  TYPE
    terminate_job_request = record
      job_state_set: jmt$job_state_set,
      output_disposition_key_known: boolean,
      output_disposition_key: jmt$output_disposition_keys,
      operator_job: boolean,
      reason: ost$name,
      case server: boolean of
      = TRUE =
        server_mainframe_id: pmt$mainframe_id,
      = FALSE =
        ,
      casend,
    recend;

  VAR
    task_has_registered_application: [STATIC, oss$task_private] boolean := FALSE,
    task_status_p: [STATIC, oss$task_private] ^pmt$task_status := NIL;

?? OLDTITLE ??
?? NEWTITLE := 'acquire_input', EJECT ??

{ PURPOSE:
{   The purpose of this request is to acquire a file from the input queue.  What this means is to attach
{ the file and read its input system label information.  A subset of this information is then placed in
{ a descriptor that describes the file being acquired.

  PROCEDURE acquire_input
    (    input_destination_usage: jmt$destination_usage;
         new_input: boolean;
     VAR input_descriptor: jmt$input_descriptor;
     VAR status: ost$status);

    VAR
      cycle_selector: pft$cycle_selector,
      ignore_status: ost$status,
      input_name: jmt$name,
      local_file_name: amt$local_file_name,
      password: pft$password,
      path_p: ^pft$path,
      system_label: jmt$job_system_label,
      usage_selections: pft$usage_selections;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      IF status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    ignore_status.normal := TRUE;

    IF syp$system_is_idling () THEN
      osp$set_status_condition (jme$input_queue_is_empty, status);
      RETURN;
    IFEND;

{ Acquire the file

    IF new_input THEN
      qfp$acquire_new_input (input_destination_usage, input_descriptor, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      qfp$acquire_modified_input (input_destination_usage, input_descriptor, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Attach the file so we can read the system label and get the attributes

    pmp$get_unique_name (local_file_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ This can only be the store-and-forward queue.  Jobs that belong to the local VE system(s) will not have
{ their command files touched by this request.  The only applications that can have files attached are
{ applications that access the store-and-forward queue.  With this in mind, osc$null_name is supplied as
{ the family name.

    determine_file_path (jmc$ifl_store_and_forward_queue, osc$null_name, input_descriptor.system_job_name,
          path_p);
    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := 1;
    password := osc$null_name;
    usage_selections := $pft$usage_selections [pfc$read];

    osp$establish_block_exit_hndlr (^handle_block_exit);
    pfp$begin_system_authority;
    pfp$attach (local_file_name, path_p^, cycle_selector, password, usage_selections, usage_selections,
          pfc$wait, status);
    pfp$end_system_authority;
    osp$disestablish_cond_handler;
    IF NOT status.normal THEN
      input_name.kind := jmc$system_supplied_name;
      input_name.system_supplied_name := input_descriptor.system_job_name;
      jmp$terminate_job (input_name, NIL, ignore_status);
      RETURN;
    IFEND;

{ Read the input file's system label

    qfp$read_job_system_label (local_file_name, system_label, status);
    IF NOT status.normal THEN
      amp$return (local_file_name, ignore_status);
      RETURN;
    IFEND;

{ Release the file in case somebody needs it for write

    amp$return (local_file_name, status);

{ Set up the fields in the input descriptor

    input_descriptor.comment_banner := system_label.job_attributes.comment_banner;
    input_descriptor.control_family := system_label.job_attributes.job_controller.family;
    input_descriptor.control_user := system_label.job_attributes.job_controller.user;
    input_descriptor.copies := system_label.job_attributes.copy_count;
    input_descriptor.data_declaration := system_label.data_declaration;
    input_descriptor.data_mode := system_label.data_mode;
    input_descriptor.device := system_label.job_attributes.device;
    input_descriptor.disposition_code := system_label.disposition_code;
    input_descriptor.earliest_run_time := system_label.job_attributes.earliest_run_time;
    input_descriptor.earliest_print_time := system_label.job_attributes.earliest_print_time;
    input_descriptor.external_characteristics := system_label.job_attributes.external_characteristics;
    input_descriptor.forms_code := system_label.job_attributes.forms_code;
    input_descriptor.implicit_routing_text := system_label.job_attributes.implicit_routing_text;
    input_descriptor.job_class := system_label.job_class_name;
    input_descriptor.job_destination_family := system_label.job_destination_family;
    input_descriptor.job_destination_usage := system_label.job_destination_usage;
    input_descriptor.job_execution_ring := system_label.job_execution_ring;
    input_descriptor.job_input_device := system_label.job_attributes.job_input_device;
    input_descriptor.job_size := system_label.job_attributes.job_size;
    input_descriptor.job_submission_time := system_label.job_attributes.job_submission_time;
    input_descriptor.latest_run_time := system_label.job_attributes.latest_run_time;
    input_descriptor.latest_print_time := system_label.job_attributes.latest_print_time;
    input_descriptor.login_account := system_label.login_account;
    input_descriptor.login_command_supplied := system_label.job_attributes.login_command_supplied;
    input_descriptor.login_family := system_label.login_user_identification.family;
    input_descriptor.login_project := system_label.login_project;
    input_descriptor.login_user := system_label.login_user_identification.user;
    input_descriptor.originating_application_name := system_label.job_attributes.originating_application_name;
    input_descriptor.originating_login_account := system_label.originating_login_account;
    input_descriptor.originating_login_family := system_label.originating_login_family;
    input_descriptor.originating_login_project := system_label.originating_login_project;
    input_descriptor.originating_login_user := system_label.originating_login_user;
    input_descriptor.originating_system_job_name := system_label.job_attributes.originating_ssn;
    input_descriptor.output_class := system_label.job_attributes.output_class;
    input_descriptor.output_destination := system_label.job_attributes.output_destination;
    input_descriptor.output_destination_family := system_label.job_attributes.output_destination_family;
    input_descriptor.output_destination_usage := system_label.job_attributes.output_destination_usage;
    input_descriptor.output_disposition.key := system_label.job_attributes.output_disposition_key;
    input_descriptor.output_disposition.standard_output_path := NIL;
    input_descriptor.output_priority := system_label.job_attributes.output_priority;
    input_descriptor.purge_delay := system_label.job_attributes.purge_delay;
    input_descriptor.remote_host_directive := system_label.job_attributes.remote_host_directive;
    input_descriptor.routing_banner := system_label.job_attributes.routing_banner;
    input_descriptor.site_information := system_label.job_attributes.site_information;
    input_descriptor.source_logical_id := system_label.job_attributes.source_logical_id;
    input_descriptor.station := system_label.job_attributes.station;
    input_descriptor.station_operator := system_label.job_attributes.station_operator;
    input_descriptor.system_job_name := system_label.system_job_name;
    input_descriptor.system_job_parameters := system_label.job_attributes.system_job_parameters;
    input_descriptor.system_routing_text := system_label.job_attributes.system_routing_text;
    input_descriptor.user_information := system_label.job_attributes.user_information;
    input_descriptor.user_job_name := system_label.user_job_name;
    input_descriptor.vertical_print_density := system_label.job_attributes.vertical_print_density;
    input_descriptor.vfu_load_procedure := system_label.job_attributes.vfu_load_procedure;
  PROCEND acquire_input;
?? OLDTITLE ??
?? NEWTITLE := 'call_server_submit_job', EJECT ??

{ PURPOSE:
{   The purpose of this request is to call the server mainframe for processing
{   a submitted job.  Batch jobs are placed in the server's Known Job List (KJL).
{   The server must be called for interactive leveled jobs to determine where the
{   job should execute.  If it is determined that the interactive job should
{   execute on the server, the job will be placed in the server's KJL.

  PROCEDURE call_server_submit_job
    (    job_system_label: jmt$job_system_label;
         immediate_initiation_candidate: boolean;
         originating_mainframe_id: pmt$mainframe_id;
     VAR destination_mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      data_size: dft$send_data_size,
      ignore_recovery_occurred: boolean,
      ignore_status_p: ^ost$status,
      local_job_system_label_p: ^jmt$job_system_label,
      local_dest_mainframe_id_p: ^pmt$mainframe_id,
      parameter_size: dft$send_parameter_size,
      queue_entry_location: dft$rpc_queue_entry_location,
      receive_from_server_data_p: dft$p_receive_data,
      receive_from_server_params_p: dft$p_receive_parameters,
      send_to_server_data_p: dft$p_send_data,
      send_to_server_parameters_p: dft$p_send_parameters,
      server_location: dft$server_location,
      server_submit_job_params_p: ^server_submit_job_parameters;

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, ignore_status);
      EXIT call_server_submit_job;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    server_location.server_location_selector := dfc$family_name;
    server_location.family_name := job_system_label.login_user_identification.family;

    REPEAT
      dfp$begin_ch_remote_proc_call (server_location, { allowed_when_server_deactivated } TRUE,
            queue_entry_location, send_to_server_parameters_p, send_to_server_data_p, status);
      IF NOT status.normal THEN

{***  Now what?? - the command file is on the server yet we can't make a KJL entry...
{ assume that the server crashed and will re-queue the job when it re-deadstarts?

        RETURN;
      IFEND;

{ Build the data and parameters to send to the server.
{ The RPC sequences have already been reset.

      NEXT server_submit_job_params_p IN send_to_server_parameters_p;
      server_submit_job_params_p^.immediate_initiation_candidate := immediate_initiation_candidate;
      server_submit_job_params_p^.executing_on_server := TRUE;
      server_submit_job_params_p^.origin_mainframe_id := originating_mainframe_id;

      NEXT local_job_system_label_p IN send_to_server_data_p;
      local_job_system_label_p^ := job_system_label;

      parameter_size := i#current_sequence_position (send_to_server_parameters_p);
      data_size := i#current_sequence_position (send_to_server_data_p);

      dfp$send_remote_procedure_call (queue_entry_location, dfc$rpc_jl_submit_job, parameter_size, data_size,
            receive_from_server_params_p, receive_from_server_data_p, status);
      IF status.normal THEN
        NEXT local_dest_mainframe_id_p IN receive_from_server_params_p;
        destination_mainframe_id := local_dest_mainframe_id_p^;

        dfp$end_ch_remote_proc_call (queue_entry_location, status);
      ELSE
        PUSH ignore_status_p;
        dfp$end_ch_remote_proc_call (queue_entry_location, ignore_status_p^);
        IF status.condition = dfe$job_needs_recovery THEN
          dfp$check_job_recovery (ignore_recovery_occurred);
        IFEND;
      IFEND;
    UNTIL status.normal OR (status.condition <> dfe$job_needs_recovery);
  PROCEND call_server_submit_job;
?? OLDTITLE ??
?? NEWTITLE := 'convert_limit_information', EJECT ??

{ PURPOSE:
{   The purpose of this request is to translate the user's requested limit information
{ into an assigned set of limits.  This request also ensures that if job qualifiers
{ are required that they are indeed present.

  PROCEDURE convert_limit_information
    (VAR system_label {input, output} : jmt$job_system_label;
     VAR status: ost$status);

    VAR
      job_qualifier_index: 1 .. jmc$maximum_job_qualifiers;

    status.normal := TRUE;

    IF system_label.limit_information.cpu_time_limit_specified THEN
      system_label.limit_information.cpu_time_limit_assigned :=
            system_label.limit_information.cpu_time_limit_requested;
    ELSE
      system_label.limit_information.cpu_time_limit_assigned := jmc$unspecified_cpu_time_limit;
    IFEND;
    IF system_label.limit_information.cpu_time_limit_assigned = jmc$system_default_cpu_time_lim THEN
      system_label.limit_information.cpu_time_limit_assigned :=
            jmv$default_job_attributes [system_label.job_mode].cpu_time_limit;
    IFEND;
    IF (system_label.limit_information.cpu_time_limit_assigned = jmc$required_cpu_time_limit) OR
          ((system_label.limit_information.cpu_time_limit_assigned = jmc$unspecified_cpu_time_limit) AND
          (jmv$default_job_attributes [system_label.job_mode].cpu_time_limit = jmc$required_cpu_time_limit))
          THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$missing_parameter, 'CPU_TIME_LIMIT', status);
      RETURN;
    IFEND;

    IF system_label.limit_information.magnetic_tape_limit_specified THEN
      system_label.limit_information.magnetic_tape_limit_assigned :=
            system_label.limit_information.magnetic_tape_limit_requested;
    ELSE
      system_label.limit_information.magnetic_tape_limit_assigned := jmc$unspecified_mag_tape_limit;
    IFEND;
    IF system_label.limit_information.magnetic_tape_limit_assigned = jmc$system_default_mag_tape_lim THEN
      system_label.limit_information.magnetic_tape_limit_assigned :=
            jmv$default_job_attributes [system_label.job_mode].magnetic_tape_limit;
    IFEND;
    IF (system_label.limit_information.magnetic_tape_limit_assigned = jmc$required_mag_tape_limit) OR
          ((system_label.limit_information.magnetic_tape_limit_assigned = jmc$unspecified_mag_tape_limit) AND
          (jmv$default_job_attributes [system_label.job_mode].magnetic_tape_limit =
          jmc$required_mag_tape_limit)) THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$missing_parameter, 'MAGNETIC_TAPE_LIMIT', status);
      RETURN;
    IFEND;

    IF system_label.limit_information.maximum_working_set_specified THEN
      system_label.limit_information.maximum_working_set_assigned :=
            system_label.limit_information.maximum_working_set_requested;
    ELSE
      system_label.limit_information.maximum_working_set_assigned := jmc$unspecified_work_set_size;
    IFEND;
    IF system_label.limit_information.maximum_working_set_assigned = jmc$system_default_work_set_siz THEN
      system_label.limit_information.maximum_working_set_assigned :=
            jmv$default_job_attributes [system_label.job_mode].maximum_working_set;
    IFEND;
    IF (system_label.limit_information.maximum_working_set_assigned = jmc$required_working_set_size) OR
          ((system_label.limit_information.maximum_working_set_assigned = jmc$unspecified_work_set_size) AND
          (jmv$default_job_attributes [system_label.job_mode].maximum_working_set =
          jmc$required_working_set_size)) THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$missing_parameter, 'MAXIMUM_WORKING_SET', status);
      RETURN;
    IFEND;

    IF system_label.limit_information.sru_limit_specified THEN
      system_label.limit_information.sru_limit_assigned := system_label.limit_information.sru_limit_requested;
    ELSE
      system_label.limit_information.sru_limit_assigned := jmc$unspecified_sru_limit;
    IFEND;
    IF system_label.limit_information.sru_limit_assigned = jmc$system_default_sru_limit THEN
      system_label.limit_information.sru_limit_assigned :=
            jmv$default_job_attributes [system_label.job_mode].sru_limit;
    IFEND;
    IF (system_label.limit_information.sru_limit_assigned = jmc$required_sru_limit) OR
          ((system_label.limit_information.sru_limit_assigned = jmc$unspecified_sru_limit) AND
          (jmv$default_job_attributes [system_label.job_mode].sru_limit = jmc$required_cpu_time_limit)) THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$missing_parameter, 'SRU_LIMIT', status);
      RETURN;
    IFEND;

    IF jmv$default_job_attributes [system_label.job_mode].job_qualifier_list [1] = uppercase_required THEN

    /search_for_specified_qualifiers/
      FOR job_qualifier_index := 1 TO jmc$maximum_job_qualifiers DO
        IF (system_label.job_attributes.job_qualifier_list [job_qualifier_index] <> osc$null_name) AND
              (system_label.job_attributes.job_qualifier_list [job_qualifier_index] <>
              uppercase_required) THEN
          EXIT /search_for_specified_qualifiers/;
        ELSEIF job_qualifier_index = jmc$maximum_job_qualifiers THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$missing_parameter, 'JOB_QUALIFIER', status);
        IFEND;
      FOREND /search_for_specified_qualifiers/;
    IFEND;
  PROCEND convert_limit_information;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] determine_file_path', EJECT ??

{ PURPOSE:
{   The purpose of this request is to PUSH the correct path name for an input file on the requestor's
{ stack.  The correct path is determined by the input file's destination usage and family name.
{
{ NOTES:
{   This procedure MUST be INLINE.

  PROCEDURE [INLINE] determine_file_path
    (    input_file_location: jmt$input_file_location;
         family_name: ost$name;
         system_job_name: jmt$system_supplied_name;
     VAR path_p: ^pft$path);

    PUSH path_p: [1 .. 4];
    path_p^ [2] := jmc$system_user;

    path_p^ [4] := system_job_name;

    determine_file_catalogs (input_file_location, family_name, path_p^ [1], path_p^ [3]);
  PROCEND determine_file_path;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] determine_file_catalogs', EJECT ??

{ PURPOSE:
{   The purpose of this request is to determine which sub-catalog a file is in based on its job
{   destination usage and family name.
{
{ NOTES:
{   This request will return a file path of the store and forward queue for a file that has no
{   input file.  This should never happen - only the system job does not have an input file.

  PROCEDURE [INLINE] determine_file_catalogs
    (    input_file_location: jmt$input_file_location;
         family_name: ost$name;
     VAR master_catalog: ost$name;
     VAR sub_catalog: ost$name);

    IF input_file_location = jmc$ifl_system_input_queue THEN
      master_catalog := jmc$system_family;
      sub_catalog := jmc$job_input_catalog;

    ELSEIF input_file_location = jmc$ifl_login_family_queue THEN
      master_catalog := family_name;
      sub_catalog := jmc$job_input_catalog;
    ELSE { IF input_file_location = jmc$ifl_store_and_forward_queue THEN
      master_catalog := jmc$system_family;
      sub_catalog := jmc$sf_job_input_catalog;
    IFEND;
  PROCEND determine_file_catalogs;
?? OLDTITLE ??
?? NEWTITLE := 'get_terminal_name' ??
?? EJECT ??

{ PURPOSE:
{   The purpose of this request is get the terminal name from the accounting
{ information contained in the job_input_device.

  PROCEDURE get_terminal_name
    (    system_label: jmt$job_system_label;
     VAR terminal_name_found: boolean;
     VAR terminal_name: ost$name);

    VAR
      get_accounting_data_p: ^nat$accounting_data_fields,
      local_status: ost$status,
      peer_accounting_information_p: ^string ( * ),
      submit_job_variation: jmt$submit_job_variations;

    terminal_name_found := FALSE;

    IF system_label.job_attributes.originating_application_name = osc$timesharing THEN

{ If this is an ordinary timesharing job, get the terminal name from the job input attributes.

      IF system_label.job_attributes.system_job_parameters.system_job_parameter_count = 0 THEN
        PUSH peer_accounting_information_p: [system_label.job_attributes.job_input_device.size];
        peer_accounting_information_p^ := system_label.job_attributes.job_input_device.text;
      ELSE
        i#move (^system_label.job_attributes.system_job_parameters.system_job_parameter,
              ^submit_job_variation, #SIZE (submit_job_variation));

{ If this is a submit resulting from a detach job or leveled job, get the terminal name from
{ the original job.  Otherwise, there is no terminal name.

        IF (submit_job_variation.kind = jmc$connection_switch) OR
              (submit_job_variation.kind = jmc$remote_connection_switch) THEN
          PUSH peer_accounting_information_p: [jmv$job_attributes.job_input_device.size];
          peer_accounting_information_p^ := jmv$job_attributes.job_input_device.text;
        ELSE
          peer_accounting_information_p := NIL;
        IFEND;
      IFEND;

      IF peer_accounting_information_p <> NIL THEN
        PUSH get_accounting_data_p: [1 .. 1];
        get_accounting_data_p^ [1].kind := nac$ca_device_name;
        nap$parse_accounting_data (peer_accounting_information_p, NIL, get_accounting_data_p, local_status);
        IF local_status.normal THEN
          terminal_name := get_accounting_data_p^ [1].device_name;
          terminal_name_found := TRUE;
        IFEND;
      IFEND;
    IFEND;

  PROCEND get_terminal_name;
?? OLDTITLE ??
?? NEWTITLE := 'terminate_job', EJECT ??

{ The purpose of this request is to terminate a job.  This request is made on the
{ server mainframe on which the job resides.

  PROCEDURE terminate_job
    (    system_job_name: jmt$system_supplied_name;
         job_state_set: jmt$job_state_set;
         output_disposition_key_known: boolean;
         output_disposition_key: jmt$output_disposition_keys;
         operator_job: boolean;
         reason: ost$name;
     VAR status: ost$status);

    VAR
      client_location: dft$server_location,
      client_mainframe_id: pmt$mainframe_id,
      cycle_selector: pft$cycle_selector,
      data_size: dft$send_data_size,
      delete_input_file: boolean,
      family_name: ost$name,
      ignore_status: ost$status,
      input_file_location: jmt$input_file_location,
      job_assigned_to_client: boolean,
      local_remove_job_from_kjl_p: ^boolean,
      local_system_job_name_p: ^jmt$system_supplied_name,
      local_terminate_job_request_p: ^terminate_job_request,
      parameter_size: dft$send_parameter_size,
      password: pft$password,
      path_p: ^pft$path,
      queue_entry_location: dft$rpc_queue_entry_location,
      receive_from_server_data_p: dft$p_receive_data,
      receive_from_server_params_p: dft$p_receive_parameters,
      remove_job_from_kjl: boolean,
      send_to_server_data_p: dft$p_send_data,
      send_to_server_parameters_p: dft$p_send_parameters;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      IF status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;
?? OLDTITLE ??
?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, ignore_status);
      EXIT terminate_job;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    remove_job_from_kjl := FALSE;

    qfp$terminate_job (system_job_name, job_state_set, output_disposition_key_known, output_disposition_key,
          operator_job, family_name, delete_input_file, input_file_location, job_assigned_to_client,
          client_mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF job_assigned_to_client THEN
      client_location.server_location_selector := dfc$mainframe_id;
      client_location.server_mainframe := client_mainframe_id;

      dfp$begin_ch_remote_proc_call (client_location, { allowed_when_server_deactivated } FALSE,
            queue_entry_location, send_to_server_parameters_p, send_to_server_data_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Build the data and parameters to send to the server.
{ The RPC sequences have already been reset.

      NEXT local_system_job_name_p IN send_to_server_parameters_p;
      local_system_job_name_p^ := system_job_name;
      NEXT local_terminate_job_request_p IN send_to_server_parameters_p;
      local_terminate_job_request_p^.server := FALSE;
      local_terminate_job_request_p^.job_state_set := job_state_set;
      local_terminate_job_request_p^.output_disposition_key_known := output_disposition_key_known;
      local_terminate_job_request_p^.output_disposition_key := output_disposition_key;
      local_terminate_job_request_p^.operator_job := operator_job;
      local_terminate_job_request_p^.reason := reason;
      parameter_size := i#current_sequence_position (send_to_server_parameters_p);
      data_size := i#current_sequence_position (send_to_server_data_p);

      dfp$send_remote_procedure_call (queue_entry_location, dfc$rpc_jl_terminate_job, parameter_size,
            data_size, receive_from_server_params_p, receive_from_server_data_p, status);
      IF status.normal THEN
        NEXT local_remove_job_from_kjl_p IN receive_from_server_params_p;
        remove_job_from_kjl := local_remove_job_from_kjl_p^;
        delete_input_file := remove_job_from_kjl;
        dfp$end_ch_remote_proc_call (queue_entry_location, status);
      ELSE
        dfp$end_ch_remote_proc_call (queue_entry_location, ignore_status);
      IFEND;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF remove_job_from_kjl THEN
      qfp$remove_job_from_kjl (system_job_name);
    IFEND;

    IF delete_input_file THEN

      IF jmv$job_history_active THEN
        jmp$emit_job_history_statistics (jml$job_file_deleted, osc$null_name, system_job_name,
              jmc$blank_system_supplied_name, NIL, NIL, reason, jmc$blank_system_supplied_name, status);
      IFEND;

      determine_file_path (input_file_location, family_name, system_job_name, path_p);
      cycle_selector.cycle_option := pfc$specific_cycle;
      cycle_selector.cycle_number := 1;
      password := osc$null_name;
      osp$establish_block_exit_hndlr (^handle_block_exit);
      pfp$begin_system_authority;
      pfp$purge (path_p^, cycle_selector, password, status);
      pfp$end_system_authority;
      osp$disestablish_cond_handler;
    IFEND;
  PROCEND terminate_job;
?? OLDTITLE ??
?? NEWTITLE := 'terminate_job_on_server', EJECT ??

{ PURPOSE:
{   The purpose of this request is to terminate a job that resides on a mainframe.
{ other than the requesting mainframe.  This request is used to locate the server
{ mainframe on which a job resides.

  PROCEDURE terminate_job_on_server
    (    system_job_name: jmt$system_supplied_name;
         server_mainframe_id: pmt$mainframe_id;
         server_terminate_job_request: terminate_job_request;
     VAR mainframes_searched_count: { input, output } jmt$maximum_mainframes;
     VAR mainframes_searched_list: { input, output } jmt$mainframes_searched_list;
     VAR job_terminated: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, ignore_status);
      EXIT terminate_job_on_server;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??

    VAR
      data_size: dft$send_data_size,
      local_job_terminated_p: ^boolean,
      local_mf_searched_count_p: ^jmt$maximum_mainframes,
      local_mf_searched_list_p: ^jmt$mainframes_searched_list,
      local_status: ost$status,
      local_system_job_name_p: ^jmt$system_supplied_name,
      local_terminate_job_request_p: ^terminate_job_request,
      parameter_size: dft$send_parameter_size,
      queue_entry_location: dft$rpc_queue_entry_location,
      receive_from_server_data_p: dft$p_receive_data,
      receive_from_server_params_p: dft$p_receive_parameters,
      send_to_server_data_p: dft$p_send_data,
      send_to_server_parameters_p: dft$p_send_parameters,
      server_location: dft$server_location;

    status.normal := TRUE;
    job_terminated := FALSE;
    server_location.server_location_selector := dfc$mainframe_id;
    server_location.server_mainframe := server_mainframe_id;

{ If the server can't be called, then return and try elsewhere.

    dfp$begin_ch_remote_proc_call (server_location, { allowed_when_server_deactivated } FALSE,
          queue_entry_location, send_to_server_parameters_p, send_to_server_data_p, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

{ Build the data and parameters to send to the server.
{ The RPC sequences have already been reset.

    NEXT local_system_job_name_p IN send_to_server_parameters_p;
    local_system_job_name_p^ := system_job_name;
    NEXT local_terminate_job_request_p IN send_to_server_parameters_p;
    local_terminate_job_request_p^ := server_terminate_job_request;

    NEXT local_mf_searched_count_p IN send_to_server_data_p;
    local_mf_searched_count_p^ := mainframes_searched_count;
    NEXT local_mf_searched_list_p IN send_to_server_data_p;
    local_mf_searched_list_p^ := mainframes_searched_list;

    parameter_size := i#current_sequence_position (send_to_server_parameters_p);
    data_size := i#current_sequence_position (send_to_server_data_p);

    dfp$send_remote_procedure_call (queue_entry_location, dfc$rpc_jl_terminate_job, parameter_size, data_size,
          receive_from_server_params_p, receive_from_server_data_p, status);
    IF status.normal THEN
      NEXT local_job_terminated_p IN receive_from_server_params_p;
      job_terminated := local_job_terminated_p^;

      NEXT local_mf_searched_count_p IN receive_from_server_data_p;
      mainframes_searched_count := local_mf_searched_count_p^;
      NEXT local_mf_searched_list_p IN receive_from_server_data_p;
      mainframes_searched_list := local_mf_searched_list_p^;

    IFEND;
    dfp$end_ch_remote_proc_call (queue_entry_location, { ignore } local_status);

  PROCEND terminate_job_on_server;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$acquire_modified_input', EJECT ??
*copy jmh$acquire_modified_input

  PROCEDURE [XDCL, #GATE] jmp$acquire_modified_input
    (    input_destination_usage: jmt$destination_usage;
     VAR input_descriptor: jmt$input_descriptor;
     VAR status: ost$status);

    #KEYPOINT (osk$entry, 0, jmk$acquire_modified_input);
    status.normal := TRUE;
    acquire_input (input_destination_usage, FALSE, input_descriptor, status);
    #KEYPOINT (osk$exit, 0, jmk$acquire_modified_input);
  PROCEND jmp$acquire_modified_input;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$acquire_new_input', EJECT ??
*copy jmh$acquire_new_input

  PROCEDURE [XDCL, #GATE] jmp$acquire_new_input
    (    input_destination_usage: jmt$destination_usage;
     VAR input_descriptor: jmt$input_descriptor;
     VAR status: ost$status);

    #KEYPOINT (osk$entry, 0, jmk$acquire_new_input);
    status.normal := TRUE;
    acquire_input (input_destination_usage, TRUE, input_descriptor, status);
    #KEYPOINT (osk$exit, 0, jmk$acquire_new_input);
  PROCEND jmp$acquire_new_input;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$activate_deferred_family', EJECT ??
*copy jmh$activate_deferred_family

  PROCEDURE [XDCL] jmp$activate_deferred_family
    (    activated_family_list: ^pmt$family_name_list);

    VAR
      family_name: ost$name,
      family_name_index: ost$non_negative_integers;

    IF activated_family_list <> NIL THEN
      FOR family_name_index := 1 TO UPPERBOUND (activated_family_list^) DO
        family_name := activated_family_list^ [family_name_index];
        qfp$activate_deferred_family (family_name);
      FOREND;
    IFEND;
  PROCEND jmp$activate_deferred_family;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$activate_job', EJECT ??
*copy jmh$activate_job

{ DESIGN:
{   Check if the caller is a system administrator or operator.  If so, call jmp$rebuild_input_queue to
{ recover the job's command file.

  PROCEDURE [XDCL, #GATE] jmp$activate_job
    (    system_job_name: jmt$system_supplied_name;
         family_name: ost$name;
         subcatalog_name: ost$name;
         recover_using_abort_disposition: boolean;
         ignore_client_initiated_jobs: boolean;
     VAR status: ost$status);

    status.normal := TRUE;

    IF NOT (avp$system_administrator () OR avp$system_operator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_administration OR system_operation', status);
      RETURN;
    IFEND;

    jmp$rebuild_input_queue (system_job_name, family_name, subcatalog_name, recover_using_abort_disposition,
          ignore_client_initiated_jobs, {job_deferred_by_operator} FALSE, status);

  PROCEND jmp$activate_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$call_server_terminate_job', EJECT ??
*copy jmh$call_server_terminate_job

  PROCEDURE [XDCL] jmp$call_server_terminate_job
    (    system_job_name: jmt$system_supplied_name;
         server_mainframe_id: pmt$mainframe_id;
         job_state_set: jmt$job_state_set;
         output_disposition_key_known: boolean;
         output_disposition_key: jmt$output_disposition_keys;
         operator_job: boolean;
         reason: ost$name;
     VAR status: ost$status);

    VAR
      job_terminated: boolean,
      mainframe_id: pmt$mainframe_id,
      mainframes_searched_count: jmt$maximum_mainframes,
      mainframes_searched_list: jmt$mainframes_searched_list,
      mainframes_searched_list_index: jmt$maximum_mainframes,
      server_binary_mainframe_id: pmt$binary_mainframe_id,
      server_directly_connected: boolean,
      server_mainframe_count: dft$partner_mainframe_count,
      server_mainframe_index: dft$partner_mainframe_count,
      server_mainframe_list: array [1 .. dfc$maximum_partner_mainframes] of dft$partner_mainframe_entry,
      server_terminate_job_request: terminate_job_request;

    status.normal := TRUE;

{ Place this mainframe in the mainframes searched list.

    mainframes_searched_count := 1;
    pmp$get_pseudo_mainframe_id (mainframes_searched_list [1]);
    pmp$convert_mainframe_to_binary (server_mainframe_id, server_binary_mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    server_directly_connected := FALSE;
    server_terminate_job_request.server := TRUE;
    server_terminate_job_request.server_mainframe_id := server_mainframe_id;
    server_terminate_job_request.job_state_set := job_state_set;
    server_terminate_job_request.output_disposition_key_known := output_disposition_key_known;
    server_terminate_job_request.output_disposition_key := output_disposition_key;
    server_terminate_job_request.operator_job := operator_job;
    server_terminate_job_request.reason := reason;

    dfp$get_partner_mainframes ({ partners_are_servers } TRUE, ^server_mainframe_list,
          server_mainframe_count);

{ See if the server is directly connected to this mainframe.  If so it can simply
{ be called.  If NOT, a remote procedure call will be required until a mainframe is
{ reached which can access the server or the server cannot be found.

  /search_for_server_mainframe/
    FOR server_mainframe_index := 1 TO server_mainframe_count DO
      IF server_mainframe_list [server_mainframe_index].mainframe_id = server_binary_mainframe_id THEN
        server_directly_connected := TRUE;
        terminate_job_on_server (system_job_name, server_mainframe_id, server_terminate_job_request,
              mainframes_searched_count, mainframes_searched_list, job_terminated, status);
        EXIT /search_for_server_mainframe/;
      IFEND;
    FOREND /search_for_server_mainframe/;

    IF NOT server_directly_connected THEN

    /call_each_server_mainframe/
      FOR server_mainframe_index := 1 TO server_mainframe_count DO
        IF mainframes_searched_count < jmc$maximum_mainframes THEN

{ If the server has already been called then try another server.

          FOR mainframes_searched_list_index := 1 TO mainframes_searched_count DO
            IF mainframes_searched_list [mainframes_searched_list_index] =
                  server_mainframe_list [server_mainframe_index].mainframe_id THEN
              CYCLE /call_each_server_mainframe/;
            IFEND;
          FOREND;
          IF server_mainframe_list [server_mainframe_index].partner_state = dfc$active THEN
            pmp$convert_binary_mainframe_id (server_mainframe_list [server_mainframe_index].mainframe_id,
                  mainframe_id, { ignore } status);
            status.normal := TRUE;
            terminate_job_on_server (system_job_name, mainframe_id, server_terminate_job_request,
                  mainframes_searched_count, mainframes_searched_list, job_terminated, status);
            IF job_terminated THEN
              EXIT /call_each_server_mainframe/;
            IFEND;
          IFEND;
        ELSE
          EXIT /call_each_server_mainframe/;
        IFEND;
      FOREND /call_each_server_mainframe/;
    IFEND;
    IF NOT job_terminated THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_job_name, status);
    IFEND;
  PROCEND jmp$call_server_terminate_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$change_input_attributes', EJECT ??
*copy jmh$change_input_attributes

  PROCEDURE [XDCL, #GATE] jmp$change_input_attributes
    (    input_name: jmt$name;
         input_attribute_changes: ^jmt$input_attribute_changes;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      change_index: integer,
      ignore_status: ost$status,
      jm_work_area_p: ^jmt$work_area,
      job_status_results_keys_p: ^jmt$results_keys,
      job_status_results_seq_p: ^jmt$work_area,
      job_qualifier_index: 1 .. jmc$maximum_job_qualifiers,
      job_status_options_p: ^jmt$job_status_options,
      job_status_results_p: ^jmt$job_status_results,
      local_attribute_changes_p: ^jmt$input_attribute_changes,
      local_output_disposition_path_p: ^fst$path,
      local_parameters_p: ^mainframe_chaia_parameters,
      local_purge_delay_p: ^jmt$time_increment,
      local_remote_host_directive_p: ^jmt$remote_host_directive,
      local_site_information_p: ^jmt$site_information,
      local_user_information_p: ^jmt$user_information,
      mainframes_processed: jmt$rpc_mainframes_processed,
      number_of_data_packets: ost$non_negative_integers,
      number_of_jobs_found: jmt$job_count_range,
      parsed_file_reference: fst$parsed_file_reference,
      privileged_job: boolean,
      privileged_job_for_status: boolean,
      scl_name: ost$name,
      scratch_segment: amt$segment_pointer,
      size_of_sequence: ost$segment_length,
      system_changing_attributes: boolean,
      target_mainframe_reached: boolean,
      target_options_p: ^SEQ ( * ),
      target_options_size: ost$non_negative_integers,
      valid_name: boolean;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      CASE condition.selector OF
      = pmc$block_exit_processing =
        mmp$delete_scratch_segment (scratch_segment, ignore_status);
        IF status.normal THEN
          osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
        IFEND;

      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;
    PROCEND condition_handler;

?? OLDTITLE ??
?? EJECT ??

    ignore_status.normal := TRUE;
    status.normal := TRUE;
    #CALLER_ID (caller_id);

    system_changing_attributes := (osp$is_caller_system_privileged () AND (caller_id.ring <= osc$tsrv_ring));
    privileged_job := osp$is_caller_system_privileged () OR jmv$enable_queue_file_access OR
          avp$system_operator ();
    jmp$get_scheduling_admin_status ({local} ignore_status);
    privileged_job_for_status := system_changing_attributes OR avp$system_operator () OR ignore_status.normal;

    PUSH job_status_options_p: [1 .. 4];
    job_status_options_p^ [1].key := jmc$name_list;
    PUSH job_status_options_p^ [1].name_list: [1 .. 1];
    job_status_options_p^ [1].name_list^ [1] := input_name;
    job_status_options_p^ [2].key := jmc$include_the_system_job;
    job_status_options_p^ [2].include_the_system_job := FALSE;
    job_status_options_p^ [3].key := jmc$privilege;
    IF privileged_job_for_status THEN
      job_status_options_p^ [3].privilege := jmc$privileged;
    ELSE
      job_status_options_p^ [3].privilege := jmc$not_privileged;
    IFEND;
    job_status_options_p^ [4].key := jmc$continue_request_to_servers;
    job_status_options_p^ [4].continue_request_to_servers := TRUE;

    PUSH job_status_results_keys_p: [1 .. 7];
    job_status_results_keys_p^ [1] := jmc$system_job_name;
    job_status_results_keys_p^ [2] := jmc$job_state;
    job_status_results_keys_p^ [3] := jmc$input_file_location;
    job_status_results_keys_p^ [4] := jmc$login_family;
    job_status_results_keys_p^ [5] := jmc$job_class;
    job_status_results_keys_p^ [6] := jmc$job_mode;
    job_status_results_keys_p^ [7] := jmc$server_mainframe_id;

    jmp$get_result_size ({number_of_jobs} 1, #SEQ (job_status_results_keys_p^), size_of_sequence);
    PUSH job_status_results_seq_p: [[REP size_of_sequence OF cell]];

{ If we are able to status the input file, we have control over the file
{ so we can change the attributes of the file

    jmp$get_job_status (job_status_options_p, job_status_results_keys_p, job_status_results_seq_p,
          job_status_results_p, number_of_jobs_found, status);
    IF number_of_jobs_found = 0 THEN
      IF input_name.kind = jmc$system_supplied_name THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, input_name.system_supplied_name,
              status);
      ELSE
        osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, input_name.user_supplied_name,
              status);
      IFEND;
    ELSEIF number_of_jobs_found > 1 THEN
      IF input_name.kind = jmc$system_supplied_name THEN { Can't ever happen
        osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_name, input_name.system_supplied_name,
              status);
      ELSE
        osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_name, input_name.user_supplied_name,
              status);
      IFEND;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF job_status_results_p^ [1]^ [6].job_mode <> jmc$batch THEN
      osp$set_status_condition (jme$cannot_change_interactive, status);
      RETURN;
    IFEND;

    IF job_status_results_p^ [1]^ [2].job_state IN $jmt$job_state_set
          [jmc$initiated_job, jmc$terminating_job] THEN

{ In order for the job state to be terminating, the file must either be initiated or the application
{ responsible for the file will momentarily return the file to queue file management.  In any case,
{ the same error (jme$input_is_initiated) is reported since the latter is not likely to occur.

      IF input_name.kind = jmc$system_supplied_name THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$input_is_initiated,
              input_name.system_supplied_name, status);
      ELSE
        osp$set_status_abnormal (jmc$job_management_id, jme$input_is_initiated, input_name.user_supplied_name,
              status);
      IFEND;
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, scratch_segment, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET scratch_segment.sequence_pointer;

    NEXT local_parameters_p IN scratch_segment.sequence_pointer;
    local_parameters_p^.system_job_name := job_status_results_p^ [1]^ [1].system_job_name;
    local_parameters_p^.login_family := job_status_results_p^ [1]^ [4].login_family;
    local_parameters_p^.input_file_location := job_status_results_p^ [1]^ [3].input_file_location;
    local_parameters_p^.system_changing_attributes := system_changing_attributes;
    local_parameters_p^.privileged_for_status := privileged_job_for_status;
    local_parameters_p^.beginning_job_class := job_status_results_p^ [1]^ [5].job_class;

{ Check attribute changes and setup to call the cluster remote procedure target.

    IF input_attribute_changes = NIL THEN
      local_parameters_p^.attribute_change_count := 0;
    ELSE
      local_parameters_p^.attribute_change_count := UPPERBOUND (input_attribute_changes^);
      NEXT local_attribute_changes_p: [1 .. local_parameters_p^.attribute_change_count] IN
            scratch_segment.sequence_pointer;

    /process_changes/
      FOR change_index := 1 TO local_parameters_p^.attribute_change_count DO
        local_attribute_changes_p^ [change_index].key := input_attribute_changes^ [change_index].key;
        CASE input_attribute_changes^ [change_index].key OF
        = jmc$comment_banner =
          local_attribute_changes_p^ [change_index].comment_banner :=
                input_attribute_changes^ [change_index].comment_banner;

        = jmc$copies =
          local_attribute_changes_p^ [change_index].copies := input_attribute_changes^ [change_index].copies;

        = jmc$cpu_time_limit =
          local_attribute_changes_p^ [change_index].cpu_time_limit :=
                input_attribute_changes^ [change_index].cpu_time_limit;

        = jmc$device =
          clp$validate_name (input_attribute_changes^ [change_index].device, scl_name, valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name, input_attribute_changes^ [change_index].device,
                  status);
            EXIT /process_changes/;
          IFEND;
          local_attribute_changes_p^ [change_index].device := scl_name;

        = jmc$earliest_print_time =
          local_attribute_changes_p^ [change_index].earliest_print_time :=
                input_attribute_changes^ [change_index].earliest_print_time;

        = jmc$earliest_run_time =
          local_attribute_changes_p^ [change_index].earliest_run_time :=
                input_attribute_changes^ [change_index].earliest_run_time;

        = jmc$encrypted_password =
          IF system_changing_attributes THEN
            IF input_attribute_changes^ [change_index].encrypted_password = osc$null_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    input_attribute_changes^ [change_index].encrypted_password, status);
              EXIT /process_changes/;
            IFEND;
            local_attribute_changes_p^ [change_index].encrypted_password :=
                  input_attribute_changes^ [change_index].encrypted_password;
          ELSE
            osp$force_access_violation;
          IFEND;

        = jmc$external_characteristics =
          #TRANSLATE (osv$lower_to_upper, input_attribute_changes^ [change_index].external_characteristics,
                local_attribute_changes_p^ [change_index].external_characteristics);

        = jmc$forms_code =
          #TRANSLATE (osv$lower_to_upper, input_attribute_changes^ [change_index].forms_code,
                local_attribute_changes_p^ [change_index].forms_code);

        = jmc$job_abort_disposition =
          local_attribute_changes_p^ [change_index].job_abort_disposition :=
                input_attribute_changes^ [change_index].job_abort_disposition;

        = jmc$job_class =
          clp$validate_name (input_attribute_changes^ [change_index].job_class, scl_name, valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name,
                  input_attribute_changes^ [change_index].job_class, status);
            EXIT /process_changes/;
          IFEND;
          local_attribute_changes_p^ [change_index].job_class := scl_name;

        = jmc$job_deferred_by_operator =
          IF NOT privileged_job THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$requires_operator_privilege,
                  'JOB_DEFERRED_BY_OPERATOR', status);
            EXIT /process_changes/;
          IFEND;
          local_attribute_changes_p^ [change_index].job_deferred_by_operator :=
                input_attribute_changes^ [change_index].job_deferred_by_operator;

        = jmc$job_deferred_by_user =
          local_attribute_changes_p^ [change_index].job_deferred_by_user :=
                input_attribute_changes^ [change_index].job_deferred_by_user;

        = jmc$job_qualifier_list =
          NEXT local_attribute_changes_p^ [change_index].job_qualifier_list:
                [1 .. jmc$maximum_job_qualifiers] IN scratch_segment.sequence_pointer;
          FOR job_qualifier_index := 1 TO jmc$maximum_job_qualifiers DO
            IF (input_attribute_changes^ [change_index].job_qualifier_list <> NIL) AND
                  (UPPERBOUND (input_attribute_changes^ [change_index].job_qualifier_list^) >=
                  job_qualifier_index) THEN
              IF input_attribute_changes^ [change_index].job_qualifier_list^ [job_qualifier_index] =
                    osc$null_name THEN
                scl_name := osc$null_name;
              ELSE
                clp$validate_name (input_attribute_changes^ [change_index].
                      job_qualifier_list^ [job_qualifier_index], scl_name, valid_name);
                IF NOT valid_name THEN
                  osp$set_status_abnormal ('CL', cle$improper_name,
                        input_attribute_changes^ [change_index].job_qualifier_list^ [job_qualifier_index],
                        status);
                  EXIT /process_changes/;
                IFEND;
              IFEND;
              local_attribute_changes_p^ [change_index].job_qualifier_list^ [job_qualifier_index] := scl_name;
            ELSE
              local_attribute_changes_p^ [change_index].job_qualifier_list^ [job_qualifier_index] :=
                    osc$null_name;
            IFEND;
          FOREND;

        = jmc$job_recovery_disposition =
          local_attribute_changes_p^ [change_index].job_recovery_disposition :=
                input_attribute_changes^ [change_index].job_recovery_disposition;

        = jmc$latest_print_time =
          local_attribute_changes_p^ [change_index].latest_print_time :=
                input_attribute_changes^ [change_index].latest_print_time;

        = jmc$latest_run_time =
          local_attribute_changes_p^ [change_index].latest_run_time :=
                input_attribute_changes^ [change_index].latest_run_time;

        = jmc$login_account =
          IF input_attribute_changes^ [change_index].login_account = osc$null_name THEN
            scl_name := osc$null_name;
          ELSE
            clp$validate_name (input_attribute_changes^ [change_index].login_account, scl_name, valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    input_attribute_changes^ [change_index].login_account, status);
              EXIT /process_changes/;
            IFEND;
          IFEND;
          local_attribute_changes_p^ [change_index].login_account := scl_name;

        = jmc$login_project =
          IF input_attribute_changes^ [change_index].login_project = osc$null_name THEN
            scl_name := osc$null_name;
          ELSE
            clp$validate_name (input_attribute_changes^ [change_index].login_project, scl_name, valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    input_attribute_changes^ [change_index].login_project, status);
              EXIT /process_changes/;
            IFEND;
          IFEND;
          local_attribute_changes_p^ [change_index].login_project := scl_name;

        = jmc$magnetic_tape_limit =
          local_attribute_changes_p^ [change_index].magnetic_tape_limit :=
                input_attribute_changes^ [change_index].magnetic_tape_limit;

        = jmc$maximum_working_set =
          local_attribute_changes_p^ [change_index].maximum_working_set :=
                input_attribute_changes^ [change_index].maximum_working_set;

        = jmc$null_attribute =
          ;

        = jmc$output_class =
          clp$validate_name (input_attribute_changes^ [change_index].output_class, scl_name, valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name,
                  input_attribute_changes^ [change_index].output_class, status);
            EXIT /process_changes/;
          IFEND;
          local_attribute_changes_p^ [change_index].output_class := scl_name;

        = jmc$output_deferred_by_user =
          local_attribute_changes_p^ [change_index].output_deferred_by_user :=
                input_attribute_changes^ [change_index].output_deferred_by_user;

        = jmc$output_destination =
          clp$validate_name (input_attribute_changes^ [change_index].output_destination, scl_name,
                valid_name);
          IF valid_name THEN
            local_attribute_changes_p^ [change_index].output_destination := scl_name;
          ELSE
            #TRANSLATE (osv$lower_to_upper, input_attribute_changes^ [change_index].output_destination,
                  local_attribute_changes_p^ [change_index].output_destination);
          IFEND;

        = jmc$output_destination_family =
          clp$validate_name (input_attribute_changes^ [change_index].output_destination_family, scl_name,
                valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name,
                  input_attribute_changes^ [change_index].output_destination_family, status);
            EXIT /process_changes/;
          IFEND;
          local_attribute_changes_p^ [change_index].output_destination_family := scl_name;

        = jmc$output_destination_usage =
          clp$validate_name (input_attribute_changes^ [change_index].output_destination_usage, scl_name,
                valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name,
                  input_attribute_changes^ [change_index].output_destination_usage, status);
            EXIT /process_changes/;
          IFEND;
          local_attribute_changes_p^ [change_index].output_destination_usage := scl_name;

        = jmc$output_disposition =
          local_attribute_changes_p^ [change_index].output_disposition.key :=
                input_attribute_changes^ [change_index].output_disposition.key;
          IF local_attribute_changes_p^ [change_index].output_disposition.key = jmc$standard_output_path THEN
            NEXT local_output_disposition_path_p IN scratch_segment.sequence_pointer;

            clp$convert_string_to_file_ref (input_attribute_changes^ [change_index].output_disposition.
                  standard_output_path^, parsed_file_reference, status);
            IF NOT status.normal THEN
              EXIT /process_changes/;
            IFEND;
            IF parsed_file_reference.path (parsed_file_reference.first_name.index,
                  parsed_file_reference.first_name.size) = '$LOCAL' THEN
              osp$set_status_condition (jme$permanent_file_required, status);
              EXIT /process_changes/;
            IFEND;
            local_output_disposition_path_p^ := parsed_file_reference.
                  path (1, parsed_file_reference.complete_path_size);
          IFEND;

        = jmc$output_priority =
          clp$validate_name (input_attribute_changes^ [change_index].output_priority, scl_name, valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name,
                  input_attribute_changes^ [change_index].output_priority, status);
            EXIT /process_changes/;
          IFEND;
          local_attribute_changes_p^ [change_index].output_priority := scl_name;

        = jmc$purge_delay =
          NEXT local_purge_delay_p IN scratch_segment.sequence_pointer;
          local_purge_delay_p^ := input_attribute_changes^ [change_index].purge_delay^;

        = jmc$remote_host_directive =
          NEXT local_remote_host_directive_p IN scratch_segment.sequence_pointer;
          local_remote_host_directive_p^ := input_attribute_changes^ [change_index].remote_host_directive^;

        = jmc$routing_banner =
          local_attribute_changes_p^ [change_index].routing_banner :=
                input_attribute_changes^ [change_index].routing_banner;

        = jmc$site_information =
          IF avp$system_operator () THEN
            NEXT local_site_information_p IN scratch_segment.sequence_pointer;
            local_site_information_p^ := input_attribute_changes^ [change_index].site_information^;
          ELSE
            osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_operation', status);
            EXIT /process_changes/;
          IFEND;

        = jmc$sru_limit =
          local_attribute_changes_p^ [change_index].sru_limit :=
                input_attribute_changes^ [change_index].sru_limit;

        = jmc$station =
          clp$validate_name (input_attribute_changes^ [change_index].station, scl_name, valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name, input_attribute_changes^ [change_index].station,
                  status);
            EXIT /process_changes/;
          IFEND;
          local_attribute_changes_p^ [change_index].station := scl_name;

        = jmc$station_operator =
          clp$validate_name (input_attribute_changes^ [change_index].station_operator, scl_name, valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name,
                  input_attribute_changes^ [change_index].station_operator, status);
            EXIT /process_changes/;
          IFEND;
          local_attribute_changes_p^ [change_index].station_operator := scl_name;

        = jmc$user_information =
          NEXT local_user_information_p IN scratch_segment.sequence_pointer;
          local_user_information_p^ := input_attribute_changes^ [change_index].user_information^;

        = jmc$user_job_name =
          clp$validate_name (input_attribute_changes^ [change_index].user_job_name, scl_name, valid_name);
          IF NOT valid_name THEN
            osp$set_status_abnormal ('CL', cle$improper_name,
                  input_attribute_changes^ [change_index].user_job_name, status);
            EXIT /process_changes/;
          IFEND;
          local_attribute_changes_p^ [change_index].user_job_name := scl_name;

        = jmc$vertical_print_density =
          local_attribute_changes_p^ [change_index].vertical_print_density :=
                input_attribute_changes^ [change_index].vertical_print_density;

          IF local_attribute_changes_p^ [change_index].vertical_print_density >
                jmc$vertical_print_density_6 THEN
            local_attribute_changes_p^ [change_index].vertical_print_density := jmc$vertical_print_density_8;
          IFEND;

        = jmc$vfu_load_procedure =
          IF input_attribute_changes^ [change_index].vfu_load_procedure <> osc$null_name THEN
            clp$validate_name (input_attribute_changes^ [change_index].vfu_load_procedure, scl_name,
                  valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    input_attribute_changes^ [change_index].vfu_load_procedure, status);
              EXIT /process_changes/;
            IFEND;
            local_attribute_changes_p^ [change_index].vfu_load_procedure := scl_name;
          ELSE
            local_attribute_changes_p^ [change_index].vfu_load_procedure := osc$null_name;
          IFEND;

        ELSE
          jmp$get_attribute_name (input_attribute_changes^ [change_index].key, scl_name);
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'INPUT_ATTRIBUTE_CHANGES', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$change_input_attributes, status);
          EXIT /process_changes/;
        CASEND;
      FOREND /process_changes/;
      IF NOT status.normal THEN
        mmp$delete_scratch_segment (scratch_segment, ignore_status);
        osp$disestablish_cond_handler;
        RETURN;
      IFEND;
    IFEND;

    mainframes_processed.count := 0;
    target_options_size := i#current_sequence_position (scratch_segment.sequence_pointer);
    RESET scratch_segment.sequence_pointer;
    NEXT target_options_p: [[REP target_options_size OF cell]] IN scratch_segment.sequence_pointer;
    RESET target_options_p;
    jm_work_area_p := NIL;

    jmp$general_purpose_cluster_rpc (job_status_results_p^ [1]^ [7].server_mainframe_id,
          jmc$gpro_change_input_attribute, {data_packet_size} 0, mainframes_processed, target_options_p,
          jm_work_area_p, target_mainframe_reached, mainframes_processed, number_of_data_packets, status);

    IF status.normal THEN
      mmp$delete_scratch_segment (scratch_segment, status);
    ELSE
      mmp$delete_scratch_segment (scratch_segment, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;
  PROCEND jmp$change_input_attributes;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$change_terminate_job_action', EJECT ??
*copy jmh$change_terminate_job_action

  PROCEDURE [XDCL, #GATE] jmp$change_terminate_job_action
    (    terminate_job_action_set: jmt$terminate_job_action_set;
     VAR status: ost$status);

    status.normal := TRUE;

    IF NOT avp$configuration_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      RETURN;
    IFEND;
    qfp$change_terminate_job_action (terminate_job_action_set);
  PROCEND jmp$change_terminate_job_action;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$close_input_file', EJECT ??
*copy jmh$close_input_file

  PROCEDURE [XDCL, #GATE] jmp$close_input_file
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

    #KEYPOINT (osk$entry, 0, jmk$close_input_file);
    status.normal := TRUE;
    fsp$close_file (file_identifier, status);
    #KEYPOINT (osk$exit, 0, jmk$close_input_file);

  PROCEND jmp$close_input_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$cluster_get_leveling_data', EJECT ??
*copy jmh$cluster_get_leveling_data

  PROCEDURE [XDCL] jmp$cluster_get_leveling_data
    (    target_mainframe_id: pmt$mainframe_id;
         target_options_p: ^SEQ ( * );
         data_packet_size: ost$segment_length;
     VAR data_area_p: {input, output} ^SEQ ( * );
     VAR mainframes_processed: jmt$rpc_mainframes_processed;
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      target_mainframe_reached: boolean;


    status.normal := TRUE;

    mainframes_processed.count := 0;

    jmp$general_purpose_cluster_rpc (target_mainframe_id, jmc$gpro_get_leveling_data, data_packet_size,
          mainframes_processed, target_options_p, data_area_p, target_mainframe_reached, mainframes_processed,
          number_of_data_packets, status);

  PROCEND jmp$cluster_get_leveling_data;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$defer_deactivated_family', EJECT ??
*copy jmh$defer_deactivated_family

  PROCEDURE [XDCL] jmp$defer_deactivated_family
    (    deactivated_family_list: ^pmt$family_name_list);

    VAR
      family_name: ost$name,
      family_name_index: ost$non_negative_integers;

    IF deactivated_family_list <> NIL THEN
      FOR family_name_index := 1 TO UPPERBOUND (deactivated_family_list^) DO
        family_name := deactivated_family_list^ [family_name_index];
        qfp$defer_deactivated_family (family_name);
      FOREND;
    IFEND;
  PROCEND jmp$defer_deactivated_family;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$get_input_attributes', EJECT ??
*copy jmh$get_input_attributes

  PROCEDURE [XDCL, #GATE] jmp$get_input_attributes
    (    input_attribute_options_p: ^jmt$input_attribute_options;
         input_attribute_results_keys_p: ^jmt$results_keys;
     VAR work_area_p: ^jmt$work_area;
     VAR input_attribute_results_p: ^jmt$input_attribute_results;
     VAR number_of_jobs_found: jmt$job_status_count;
     VAR status: ost$status);

    VAR
      continue_request_to_servers: boolean,
      ignore_status: ost$status,
      jm_work_area_p: ^jmt$work_area,
      job_status_options_p: ^jmt$job_status_options,
      local_parameters_p: ^mainframe_getia_parameters,
      local_results_keys_p: ^jmt$results_keys,
      local_status_keys_p: ^jmt$results_keys,
      mainframes_processed: jmt$rpc_mainframes_processed,
      number_of_data_packets: ost$non_negative_integers,
      option_index: ost$positive_integers,
      privileged_job: boolean,
      result_element_size: ost$segment_length,
      result_index: ost$positive_integers,
      save_work_area_p: ^jmt$work_area,
      scl_name: ost$name,
      scratch_segment: amt$segment_pointer,
      target_mainframe_id: pmt$mainframe_id,
      target_mainframe_reached: boolean,
      target_options_p: ^SEQ ( * ),
      target_options_size: ost$non_negative_integers;


?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      mmp$delete_scratch_segment (scratch_segment, ignore_status);
      IF status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;

?? OLDTITLE ??
?? EJECT ??

{ BEGIN: jmp$get_input_attributes

    status.normal := TRUE;
    ignore_status.normal := TRUE;
    number_of_jobs_found := 0;
    continue_request_to_servers := FALSE;

    privileged_job := avp$system_operator () OR avp$system_displays ();
    IF NOT privileged_job THEN
      jmp$get_scheduling_admin_status (status);
      IF status.normal THEN
        privileged_job := TRUE;
      ELSE
        status.normal := TRUE;
      IFEND;
    IFEND;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, scratch_segment, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET scratch_segment.sequence_pointer;
    osp$establish_block_exit_hndlr (^handle_block_exit);

    NEXT local_parameters_p IN scratch_segment.sequence_pointer;

    IF input_attribute_options_p = NIL THEN
      local_parameters_p^.status_option_count := 3;

      NEXT job_status_options_p: [1 .. 3] IN scratch_segment.sequence_pointer;
      option_index := 1;

    ELSE
      save_work_area_p := scratch_segment.sequence_pointer;
      jmp$validate_attribute_options (jmc$get_input_attributes, 'INPUT_ATTRIBUTE_OPTIONS_P',
            #SEQ (input_attribute_options_p^), { number_of_options_to_add } 3, continue_request_to_servers,
            local_parameters_p^.status_option_count, scratch_segment.sequence_pointer, status);
      IF NOT status.normal THEN
        mmp$delete_scratch_segment (scratch_segment, ignore_status);
        osp$disestablish_cond_handler;
        RETURN;
      IFEND;

      NEXT job_status_options_p: [1 .. local_parameters_p^.status_option_count] IN save_work_area_p;
      option_index := local_parameters_p^.status_option_count - 2;

    IFEND;

    job_status_options_p^ [option_index].key := jmc$privilege;
    IF privileged_job THEN
      job_status_options_p^ [option_index].privilege := jmc$privileged;
    ELSE
      job_status_options_p^ [option_index].privilege := jmc$not_privileged;
    IFEND;
    job_status_options_p^ [option_index + 1].key := jmc$include_the_system_job;
    job_status_options_p^ [option_index + 1].include_the_system_job := FALSE;
    job_status_options_p^ [option_index + 2].key := jmc$user_identification;
    NEXT job_status_options_p^ [option_index + 2].user_identification IN scratch_segment.sequence_pointer;
    pmp$get_user_identification (job_status_options_p^ [option_index + 2].user_identification^,
          ignore_status);

    local_parameters_p^.attach_file := FALSE;

{ Verify that the result array is only requesting valid fields, i.e. fields that are returned by
{ this request.

    IF input_attribute_results_keys_p = NIL THEN
      local_parameters_p^.results_keys_count := 0;
      result_element_size := 0;
    ELSE
      local_parameters_p^.results_keys_count := UPPERBOUND (input_attribute_results_keys_p^);

{ Make two copies of the results keys.  One for what to return, the other a list of values that the status
{ request is to return.

      NEXT local_results_keys_p: [1 .. local_parameters_p^.results_keys_count] IN
            scratch_segment.sequence_pointer;
      NEXT local_status_keys_p: [1 .. local_parameters_p^.results_keys_count] IN
            scratch_segment.sequence_pointer;

      local_results_keys_p^ := input_attribute_results_keys_p^;
      local_status_keys_p^ := input_attribute_results_keys_p^;

      FOR result_index := 1 TO local_parameters_p^.results_keys_count DO
        CASE local_results_keys_p^ [result_index] OF
        = jmc$comment_banner, jmc$copies, jmc$cpu_time_limit, jmc$data_mode, jmc$device,
              jmc$earliest_print_time, jmc$earliest_run_time, jmc$external_characteristics, jmc$forms_code,
              jmc$job_abort_disposition, jmc$job_category_list, jmc$job_destination_family,
              jmc$job_execution_ring, jmc$job_qualifier_list, jmc$job_recovery_disposition, jmc$job_size,
              jmc$job_submission_time, jmc$latest_print_time, jmc$latest_run_time, jmc$login_account,
              jmc$login_project, jmc$magnetic_tape_limit, jmc$maximum_working_set,
              jmc$origin_application_name, jmc$output_class, jmc$output_deferred_by_user,
              jmc$output_destination, jmc$output_destination_family {operator_family} ,
              jmc$output_destination_usage, jmc$output_disposition, jmc$output_priority, jmc$purge_delay,
              jmc$remote_host_directive, jmc$routing_banner, jmc$site_information, jmc$sru_limit, jmc$station,
              jmc$station_operator {operator_user} , jmc$user_information, jmc$vertical_print_density,
              jmc$vfu_load_procedure =
          local_parameters_p^.attach_file := TRUE;
          local_status_keys_p^ [result_index] := jmc$null_attribute;

        = jmc$control_family, jmc$control_user, jmc$job_class, jmc$job_deferred_by_operator,
              jmc$job_deferred_by_user, jmc$job_destination_usage, jmc$job_mode, jmc$job_state,
              jmc$login_family, jmc$login_user, jmc$null_attribute, jmc$system_job_name, jmc$user_job_name =

        ELSE
          jmp$get_attribute_name (local_results_keys_p^ [result_index], scl_name);
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'INPUT_ATTRIBUTE_RESULTS_KEYS_P',
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$get_input_attributes, status);
          mmp$delete_scratch_segment (scratch_segment, ignore_status);
          osp$disestablish_cond_handler;
          RETURN;
        CASEND;

      FOREND; { result index

      jmp$get_data_packet_size (local_results_keys_p, result_element_size, status);
      IF NOT status.normal THEN
        mmp$delete_scratch_segment (scratch_segment, ignore_status);
        osp$disestablish_cond_handler;
        RETURN;
      IFEND;
    IFEND;

    IF continue_request_to_servers THEN
      target_mainframe_id := pmc$null_mainframe_id;
    ELSE
      pmp$get_mainframe_id (target_mainframe_id, ignore_status);
    IFEND;

    mainframes_processed.count := 0;
    target_options_size := i#current_sequence_position (scratch_segment.sequence_pointer);
    RESET scratch_segment.sequence_pointer;
    NEXT target_options_p: [[REP target_options_size OF cell]] IN scratch_segment.sequence_pointer;
    RESET target_options_p;
    NEXT jm_work_area_p: [[REP (osc$max_segment_length - target_options_size) OF cell]] IN
          scratch_segment.sequence_pointer;
    RESET jm_work_area_p;

    jmp$general_purpose_cluster_rpc (target_mainframe_id, jmc$gpro_get_input_attributes,
          {data_packet_size} result_element_size, mainframes_processed, target_options_p, jm_work_area_p,
          target_mainframe_reached, mainframes_processed, number_of_data_packets, status);
    IF NOT status.normal THEN
      IF status.condition = jme$work_area_too_small THEN
        number_of_jobs_found := number_of_data_packets;
      IFEND;
      mmp$delete_scratch_segment (scratch_segment, ignore_status);
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

    number_of_jobs_found := number_of_data_packets;
    IF number_of_jobs_found = 0 THEN
      osp$set_status_condition (jme$no_jobs_were_found, status);
    ELSEIF input_attribute_results_keys_p <> NIL THEN
      RESET jm_work_area_p;
      save_work_area_p := work_area_p;
      jmp$copy_seq_to_result_array (UPPERBOUND (input_attribute_results_keys_p^), number_of_jobs_found,
            input_attribute_results_keys_p, jm_work_area_p, work_area_p, status);
      NEXT input_attribute_results_p: [1 .. number_of_jobs_found] IN save_work_area_p;
    IFEND;

    IF status.normal THEN
      mmp$delete_scratch_segment (scratch_segment, status);
    ELSE
      mmp$delete_scratch_segment (scratch_segment, ignore_status);
    IFEND;
    osp$disestablish_cond_handler;
  PROCEND jmp$get_input_attributes;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$get_input_q_from_unassigned', EJECT ??
*copy jmh$get_input_q_from_unassigned

  PROCEDURE [XDCL, #GATE] jmp$get_input_q_from_unassigned
    (VAR system_supplied_names: array [1 .. * ] of jmt$system_supplied_name;
     VAR number_of_jobs_found: integer;
     VAR status: ost$status);

    VAR
      local_name_list_p: ^array [1 .. * ] of jmt$system_supplied_name,
      local_status: ost$status;

    status.normal := TRUE;

    jmp$get_scheduling_admin_status (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    number_of_jobs_found := 0;
    PUSH local_name_list_p: [1 .. UPPERBOUND (system_supplied_names)];

    qfp$get_input_q_from_unassigned (local_name_list_p^, number_of_jobs_found, local_status);
    system_supplied_names := local_name_list_p^;
    IF NOT local_status.normal THEN
      status := local_status;
    ELSEIF number_of_jobs_found > UPPERBOUND (system_supplied_names) THEN
      osp$set_status_condition (jme$result_array_too_small, status);
    IFEND;
  PROCEND jmp$get_input_q_from_unassigned;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$get_job_counts', EJECT ??
*copy jmh$get_job_counts

  PROCEDURE [XDCL, #GATE] jmp$get_job_counts
    (VAR job_counts: jmt$job_counts;
     VAR status: ost$status);

    status.normal := TRUE;

    qfp$get_job_counts (job_counts);
  PROCEND jmp$get_job_counts;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$get_job_path_elements', EJECT ??
*copy jmh$get_job_path_elements

  PROCEDURE [XDCL, #GATE] jmp$get_job_path_elements
    (    system_job_name: jmt$system_supplied_name;
     VAR path: jmt$queue_file_path;
     VAR status: ost$status);

    VAR
      candidate_name: jmt$name,
      good_name: jmt$name,
      input_file_location: jmt$input_file_location,
      local_path_p: ^pft$path,
      login_family: ost$family_name;

    status.normal := TRUE;
    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_administration', status);
      RETURN;
    IFEND;

    candidate_name.kind := jmc$system_supplied_name;
    candidate_name.system_supplied_name := system_job_name;
    jmp$validate_name (candidate_name, good_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    qfp$get_input_file_location (good_name.system_supplied_name, input_file_location, login_family, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF input_file_location <> jmc$ifl_no_input_file_exists THEN

{ Determine the job's command file path.

      determine_file_path (input_file_location, login_family, good_name.system_supplied_name, local_path_p);
      path := local_path_p^;

    ELSE
      osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_job_name, status);
    IFEND;
  PROCEND jmp$get_job_path_elements;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$get_job_status', EJECT ??
*copy jmh$get_job_status

  PROCEDURE [XDCL, #GATE] jmp$get_job_status
    (    job_status_options_p: ^jmt$job_status_options;
         job_status_results_keys_p: ^jmt$results_keys;
     VAR work_area_p: ^jmt$work_area;
     VAR job_status_results_p: ^jmt$job_status_results;
     VAR number_of_jobs_found: jmt$job_status_count;
     VAR status: ost$status);

    CONST
      bytes_that_can_be_pushed = 32767;

    VAR
      caller_id: ost$caller_identifier,
      caller_privileged: boolean,
      continue_request_to_servers: boolean,
      jm_work_area_p: ^jmt$work_area,
      local_parameters_p: ^mainframe_getjs_parameters,
      local_status: ost$status,
      local_status_results_keys_p: ^jmt$results_keys,
      mainframes_processed: jmt$rpc_mainframes_processed,
      number_of_data_packets: ost$non_negative_integers,
      options_p: ^SEQ ( * ),
      options_size: ost$non_negative_integers,
      result_index: ost$positive_integers,
      save_work_area_p: ^jmt$work_area,
      scl_name: ost$name,
      seq_job_status_results_size: ost$segment_length,
      target_mainframe_id: pmt$mainframe_id,
      target_mainframe_reached: boolean,
      target_options_p: ^SEQ ( * ),
      user_job_name: jmt$user_supplied_name;


    #KEYPOINT (osk$entry, 0, jmk$get_job_status);
    #CALLER_ID (caller_id);
    status.normal := TRUE;
    number_of_jobs_found := 0;
    continue_request_to_servers := FALSE;
    jm_work_area_p := NIL;

    IF work_area_p <> NIL THEN
      IF (jmv$job_management_work_area_p = NIL) AND (#SIZE (work_area_p^) <= bytes_that_can_be_pushed) THEN
        PUSH jm_work_area_p: [[REP #SIZE (work_area_p^) OF cell]];
      ELSE
        jmp$get_jm_work_area (jm_work_area_p, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;
    PUSH target_options_p: [[REP dfc$maximum_user_data_area OF cell]];

    RESET target_options_p;
    NEXT local_parameters_p IN target_options_p;

    pmp$get_user_identification (local_parameters_p^.user_identification, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$get_job_status);
      RETURN;
    IFEND;

    pmp$get_job_names (user_job_name, local_parameters_p^.caller_ssn, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$get_job_status);
      RETURN;
    IFEND;

    local_parameters_p^.privileged_job := avp$system_operator () OR avp$system_displays ();
    IF NOT local_parameters_p^.privileged_job THEN
      jmp$get_scheduling_admin_status (local_status);
      IF local_status.normal THEN
        local_parameters_p^.privileged_job := TRUE;
      IFEND;
    IFEND;

    avp$get_capability (avc$scheduling_displays, avc$user, local_parameters_p^.valid_for_scheduling_displays,
          local_status);
    IF NOT local_status.normal THEN
      local_parameters_p^.valid_for_scheduling_displays := TRUE;
    IFEND;

    IF job_status_options_p = NIL THEN
      local_parameters_p^.status_option_count := 0;
    ELSE

      caller_privileged := (osp$is_caller_system_privileged () AND (caller_id.ring <= osc$tsrv_ring));

      jmp$validate_status_options (jmc$get_job_status, 'JOB_STATUS_OPTIONS_P', #SEQ (job_status_options_p^),
            caller_privileged, local_parameters_p^.privileged_job, local_parameters_p^.user_identification,
            continue_request_to_servers, local_parameters_p^.status_option_count, target_options_p, status);
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, jmk$get_job_status);
        RETURN;
      IFEND;

    IFEND;

{ Verify that result is only asking for valid fields, i.e. supported fields.

    IF job_status_results_keys_p = NIL THEN
      local_parameters_p^.status_results_count := 0;
      seq_job_status_results_size := 0;
    ELSE
      local_parameters_p^.status_results_count := UPPERBOUND (job_status_results_keys_p^);
      NEXT local_status_results_keys_p: [1 .. local_parameters_p^.status_results_count] IN target_options_p;

      local_status_results_keys_p^ := job_status_results_keys_p^;

      FOR result_index := 1 TO local_parameters_p^.status_results_count DO
        CASE local_status_results_keys_p^ [result_index] OF
        = jmc$client_mainframe_id, jmc$control_family, jmc$control_user, jmc$cpu_time_used,
              jmc$display_message, jmc$input_file_location, jmc$internal_index, jmc$job_class,
              jmc$job_class_position, jmc$job_deferred_by_operator, jmc$job_deferred_by_user,
              jmc$job_destination_usage, jmc$job_initiation_time, jmc$job_mode, jmc$job_state,
              jmc$login_family, jmc$login_user, jmc$null_attribute, jmc$operator_action_posted,
              jmc$page_faults, jmc$server_mainframe_id, jmc$system_job_name, jmc$user_job_name =
        ELSE
          jmp$get_attribute_name (local_status_results_keys_p^ [result_index], scl_name);
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'JOB_STATUS_RESULTS_KEYS_P', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$get_job_status, status);
          #KEYPOINT (osk$exit, 0, jmk$get_job_status);
          RETURN;
        CASEND;
      FOREND;

      jmp$get_data_packet_size (local_status_results_keys_p, seq_job_status_results_size, status);
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, jmk$get_job_status);
        RETURN;
      IFEND;
    IFEND;

    IF continue_request_to_servers THEN
      target_mainframe_id := pmc$null_mainframe_id;
    ELSE
      pmp$get_mainframe_id (target_mainframe_id, {ignore} local_status);
    IFEND;
    mainframes_processed.count := 0;
    options_size := i#current_sequence_position (target_options_p);
    RESET target_options_p;
    NEXT options_p: [[REP options_size OF cell]] IN target_options_p;

    jmp$general_purpose_cluster_rpc (target_mainframe_id, jmc$gpro_get_job_status,
          {data_packet_size} seq_job_status_results_size, mainframes_processed, options_p, jm_work_area_p,
          target_mainframe_reached, mainframes_processed, number_of_data_packets, status);
    IF NOT status.normal THEN
      IF status.condition = jme$work_area_too_small THEN
        number_of_jobs_found := number_of_data_packets;
      IFEND;
      #KEYPOINT (osk$exit, 0, jmk$get_job_status);
      RETURN;
    IFEND;

    number_of_jobs_found := number_of_data_packets;
    IF number_of_jobs_found = 0 THEN
      osp$set_status_condition (jme$no_jobs_were_found, status);
    ELSEIF (job_status_results_keys_p <> NIL) THEN
      RESET jm_work_area_p;
      save_work_area_p := work_area_p;
      jmp$copy_seq_to_result_array (UPPERBOUND (job_status_results_keys_p^), number_of_jobs_found,
            job_status_results_keys_p, jm_work_area_p, work_area_p, status);
      NEXT job_status_results_p: [1 .. number_of_jobs_found] IN save_work_area_p;
    IFEND;
    #KEYPOINT (osk$exit, 0, jmk$get_job_status);

  PROCEND jmp$get_job_status;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$get_leveling_data', EJECT ??
*copy jmh$get_leveling_data

  PROCEDURE [XDCL] jmp$get_leveling_data
    (    target_options_p: ^SEQ ( * );
     VAR data_area_p: {input, output} ^SEQ ( * );
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      data_size: ost$segment_length,
      leveling_data: ^SEQ ( * ),
      mainframe_leveling_data_p: ^jmt$mainframe_leveling_data,
      segment: amt$segment_pointer;


    status.normal := TRUE;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET segment.sequence_pointer;

    jmp$mainframe_get_leveling_data (target_options_p, segment.sequence_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    number_of_data_packets := 1;

    data_size := i#current_sequence_position (segment.sequence_pointer);
    NEXT mainframe_leveling_data_p IN data_area_p;
    NEXT leveling_data: [[REP data_size OF cell]] IN data_area_p;

    pmp$get_mainframe_id (mainframe_leveling_data_p^.mainframe_id, {ignore} status);
    mainframe_leveling_data_p^.mainframe_data_size := data_size;

    RESET segment.sequence_pointer;
    i#move (segment.sequence_pointer, leveling_data, data_size);

    mmp$delete_scratch_segment (segment, status);
  PROCEND jmp$get_leveling_data;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$log_restored_job', EJECT ??
*copy jmh$log_restored_job

  PROCEDURE [XDCL, #GATE] jmp$log_restored_job
    (    system_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      candidate_name: jmt$name,
      cycle_selector: pft$cycle_selector,
      ignore_status: ost$status,
      local_file_name: amt$local_file_name,
      operator_restore: ost$name,
      password: pft$password,
      path: jmt$queue_file_path,
      system_label: jmt$job_system_label,
      usage_selections: pft$usage_selections,
      valid_name: jmt$name;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      IF status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    ignore_status.normal := TRUE;

    IF NOT (avp$system_administrator () OR avp$system_operator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_administration OR system_operation', status);
      RETURN;
    IFEND;

{ Check for active job history statistic logging.

    IF NOT jmv$job_history_active THEN
      osp$set_status_condition (jme$jh_job_history_not_active, status);
      RETURN;
    IFEND;

{ Verify that the system_job_name is a legal system supplied name.

    candidate_name.kind := jmc$system_supplied_name;
    candidate_name.system_supplied_name := system_job_name;
    jmp$validate_name (candidate_name, valid_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Attach the job file.

    jmp$get_job_path_elements (valid_name.system_supplied_name, path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_unique_name (local_file_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := 1;
    password := osc$null_name;
    usage_selections := $pft$usage_selections [pfc$read];

    osp$establish_block_exit_hndlr (^handle_block_exit);
    pfp$begin_system_authority;
    pfp$attach (local_file_name, path, cycle_selector, password, usage_selections, usage_selections, pfc$wait,
          status);
    IF NOT status.normal THEN
      pfp$purge (path, cycle_selector, password, ignore_status);
      pfp$end_system_authority;
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

{ Read the job file's system label.

    qfp$read_job_system_label (local_file_name, system_label, status);
    amp$return (local_file_name, ignore_status);

    IF NOT status.normal THEN
      pfp$purge (path, cycle_selector, password, ignore_status);
      pfp$end_system_authority;
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

{ Verify that the system_job_name matches in the label and the catalog.

    IF system_job_name <> system_label.system_job_name THEN
      osp$set_status_condition (sye$job_damaged, status);
      pfp$purge (path, cycle_selector, password, ignore_status);
      pfp$end_system_authority;
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

{ If the job is an interactive job, then don't log it.

    IF system_label.job_mode = jmc$interactive_connected THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$cant_recover_job, 'an interactive queued', status);
      pfp$purge (path, cycle_selector, password, ignore_status);
      pfp$end_system_authority;
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

    pfp$end_system_authority;
    osp$disestablish_cond_handler;

    operator_restore := osc$null_name;
    osp$get_status_condition_name (jme$operator_queue_restore, operator_restore, ignore_status);

    jmp$emit_job_history_statistics (jml$job_queuing_started, osc$null_name, valid_name.system_supplied_name,
          jmc$blank_system_supplied_name, ^system_label, NIL, operator_restore,
          system_label.job_attributes.originating_ssn, status);

  PROCEND jmp$log_restored_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$modified_input_exists', EJECT ??
*copy jmh$modified_input_exists

  FUNCTION [XDCL, #GATE] jmp$modified_input_exists
    (    input_destination_usage: jmt$destination_usage): boolean;

    VAR
      application_index: jmt$input_application_index,
      input_exists: boolean;

    #KEYPOINT (osk$entry, 0, jmk$modified_input_exists);

    application_index := UPPERBOUND (jmv$known_job_list.application_table);
    WHILE (jmv$known_job_list.application_table [application_index].destination_usage <>
          input_destination_usage) AND (application_index <> jmc$unassigned_input_index) DO
      application_index := application_index - 1;
    WHILEND;

    input_exists := (application_index <> jmc$unassigned_input_index) AND
          (jmv$known_job_list.application_table [application_index].state_data [jmc$kjl_application_modified].
          number_of_entries > 0);
    jmp$modified_input_exists := input_exists AND (NOT syp$system_is_idling ());

    #KEYPOINT (osk$exit, 0, jmk$modified_input_exists);

  FUNCEND jmp$modified_input_exists;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$new_input_exists', EJECT ??
*copy jmh$new_input_exists

  FUNCTION [XDCL, #GATE] jmp$new_input_exists
    (    input_destination_usage: jmt$destination_usage): boolean;

    VAR
      application_index: jmt$input_application_index,
      input_exists: boolean;

    #KEYPOINT (osk$entry, 0, jmk$new_input_exists);

    application_index := UPPERBOUND (jmv$known_job_list.application_table);
    WHILE (jmv$known_job_list.application_table [application_index].destination_usage <>
          input_destination_usage) AND (application_index <> jmc$unassigned_input_index) DO
      application_index := application_index - 1;
    WHILEND;

    input_exists := (application_index <> jmc$unassigned_input_index) AND
          (jmv$known_job_list.application_table [application_index].state_data [jmc$kjl_application_new].
          number_of_entries > 0);
    jmp$new_input_exists := input_exists AND (NOT syp$system_is_idling ());

    #KEYPOINT (osk$exit, 0, jmk$new_input_exists);

  FUNCEND jmp$new_input_exists;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$get_terminate_job_action', EJECT ??
*copy jmh$get_terminate_job_action

  PROCEDURE [XDCL, #GATE] jmp$get_terminate_job_action
    (VAR terminate_job_action_set: jmt$terminate_job_action_set;
     VAR status: ost$status);

    status.normal := TRUE;
    IF NOT (avp$configuration_administrator () OR avp$system_displays ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration OR system_displays',
            status);
      RETURN;
    IFEND;

    terminate_job_action_set := qfv$terminate_job_action_set;
  PROCEND jmp$get_terminate_job_action;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$mainframe_change_input_attr', EJECT ??
*copy jmh$mainframe_change_input_attr

  PROCEDURE [XDCL] jmp$mainframe_change_input_attr
    (    target_options_p: ^SEQ ( * );
     VAR data_area_p: {input, output} ^SEQ ( * );
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      active_profile_version: ost$name,
      assigned_job_class: jmt$job_class,
      change_index: integer,
      current_date_time: ost$date_time,
      current_microsecond_clock: jmt$clock_time,
      cycle_selector: pft$cycle_selector,
      earliest_clock_time_to_initiate: jmt$clock_time,
      ignore_encrypted_password: ost$name,
      ignore_status: ost$status,
      latest_clock_time_to_initiate: jmt$clock_time,
      leveled_job: boolean,
      local_attribute_changes_p: ^jmt$input_attribute_changes,
      local_file_name: amt$local_file_name,
      local_output_disposition_path_p: ^fst$path,
      local_parameters_p: ^mainframe_chaia_parameters,
      local_purge_delay_p: ^jmt$time_increment,
      local_remote_host_directive_p: ^jmt$remote_host_directive,
      local_site_information_p: ^jmt$site_information,
      local_user_information_p: ^jmt$user_information,
      options_seq_p: ^SEQ ( * ),
      password: pft$password,
      path_p: ^pft$path,
      profile_mismatch: boolean,
      share_selections: pft$share_selections,
      store_and_forward_job: boolean,
      system_label: jmt$job_system_label,
      usage_selections: pft$usage_selections,
      valid_mainframe_set: jmt$valid_mainframe_set,
      wait_option: pft$wait,
      write_label: boolean;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit and interactive
{   conditions that arise from the attempt to attach a file in the input queue.
{   If the file is busy, the attach processor goes into long term wait without
{   establishing a condition handler for interactive conditions - so it does
{   not exit.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      CASE condition.selector OF
      = pmc$block_exit_processing =
        pfp$end_system_authority;
        IF status.normal THEN
          osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
        IFEND;

      = ifc$interactive_condition =
        IF condition.interactive_condition = ifc$pause_break THEN
          ifp$invoke_pause_utility (handler_status);
        ELSE
          osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          EXIT jmp$mainframe_change_input_attr;
        IFEND;

      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;
    PROCEND condition_handler;

?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    ignore_status.normal := TRUE;
    number_of_data_packets := 0;

    options_seq_p := target_options_p;
    RESET options_seq_p;
    NEXT local_parameters_p IN options_seq_p;

{ Attach the file so we can read the system label and get the attributes

    pmp$get_unique_name (local_file_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    determine_file_path (local_parameters_p^.input_file_location, local_parameters_p^.login_family,
          local_parameters_p^.system_job_name, path_p);
    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := 1;
    password := osc$null_name;
    IF local_parameters_p^.system_changing_attributes THEN
      wait_option := pfc$no_wait;
      usage_selections := $pft$usage_selections [pfc$read];
      share_selections := $pft$share_selections [pfc$read];
    ELSE
      wait_option := pfc$wait;
      usage_selections := $pft$usage_selections [pfc$read, pfc$modify];
      share_selections := $pft$share_selections [];
    IFEND;

{ Prepare in case the file is busy and the attach goes into long-term-wait.

    osp$establish_condition_handler (^condition_handler, {block_exit} TRUE);

    pfp$begin_system_authority;
    pfp$attach (local_file_name, path_p^, cycle_selector, password, usage_selections, share_selections,
          wait_option, status);
    pfp$end_system_authority;
    osp$disestablish_cond_handler;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Read the input file's system label

    qfp$read_job_system_label (local_file_name, system_label, status);
    IF NOT status.normal THEN
      amp$return (local_file_name, ignore_status);
      RETURN;
    IFEND;

{ Check attribute changes and change the local copy of the system label

    IF local_parameters_p^.attribute_change_count > 0 THEN
      NEXT local_attribute_changes_p: [1 .. local_parameters_p^.attribute_change_count] IN options_seq_p;

      FOR change_index := 1 TO local_parameters_p^.attribute_change_count DO
        CASE local_attribute_changes_p^ [change_index].key OF
        = jmc$comment_banner =
          system_label.job_attributes.comment_banner := local_attribute_changes_p^ [change_index].
                comment_banner;

        = jmc$copies =
          system_label.job_attributes.copy_count := local_attribute_changes_p^ [change_index].copies;

        = jmc$cpu_time_limit =
          system_label.limit_information.cpu_time_limit_specified := TRUE;
          system_label.limit_information.cpu_time_limit_requested :=
                local_attribute_changes_p^ [change_index].cpu_time_limit;

        = jmc$device =
          system_label.job_attributes.device := local_attribute_changes_p^ [change_index].device;

        = jmc$earliest_print_time =
          system_label.job_attributes.earliest_print_time :=
                local_attribute_changes_p^ [change_index].earliest_print_time;

        = jmc$earliest_run_time =
          system_label.job_attributes.earliest_run_time := local_attribute_changes_p^ [change_index].
                earliest_run_time;

        = jmc$encrypted_password =
          system_label.login_password := local_attribute_changes_p^ [change_index].encrypted_password;

        = jmc$external_characteristics =
          system_label.job_attributes.external_characteristics :=
                local_attribute_changes_p^ [change_index].external_characteristics;

        = jmc$forms_code =
          system_label.job_attributes.forms_code := local_attribute_changes_p^ [change_index].forms_code;

        = jmc$job_abort_disposition =
          system_label.job_abort_disposition := local_attribute_changes_p^ [change_index].
                job_abort_disposition;

        = jmc$job_class =
          system_label.job_class_name := local_attribute_changes_p^ [change_index].job_class;

        = jmc$job_deferred_by_operator =
          system_label.job_deferred_by_operator := local_attribute_changes_p^ [change_index].
                job_deferred_by_operator;

        = jmc$job_deferred_by_user =
          system_label.job_deferred_by_user := local_attribute_changes_p^ [change_index].job_deferred_by_user;

        = jmc$job_qualifier_list =
          NEXT local_attribute_changes_p^ [change_index].job_qualifier_list:
                [1 .. jmc$maximum_job_qualifiers] IN options_seq_p;
          system_label.job_attributes.job_qualifier_list := local_attribute_changes_p^ [change_index].
                job_qualifier_list^;

        = jmc$job_recovery_disposition =
          system_label.job_recovery_disposition := local_attribute_changes_p^ [change_index].
                job_recovery_disposition;

        = jmc$latest_print_time =
          system_label.job_attributes.latest_print_time := local_attribute_changes_p^ [change_index].
                latest_print_time;

        = jmc$latest_run_time =
          system_label.job_attributes.latest_run_time := local_attribute_changes_p^ [change_index].
                latest_run_time;

        = jmc$login_account =
          system_label.login_account := local_attribute_changes_p^ [change_index].login_account;

        = jmc$login_project =
          system_label.login_project := local_attribute_changes_p^ [change_index].login_project;

        = jmc$magnetic_tape_limit =
          system_label.limit_information.magnetic_tape_limit_specified := TRUE;
          system_label.limit_information.magnetic_tape_limit_requested :=
                local_attribute_changes_p^ [change_index].magnetic_tape_limit;

        = jmc$maximum_working_set =
          system_label.limit_information.maximum_working_set_specified := TRUE;
          system_label.limit_information.maximum_working_set_requested :=
                local_attribute_changes_p^ [change_index].maximum_working_set;

        = jmc$null_attribute =
          ;

        = jmc$output_class =
          system_label.job_attributes.output_class := local_attribute_changes_p^ [change_index].output_class;

        = jmc$output_deferred_by_user =
          system_label.job_attributes.output_deferred_by_user :=
                local_attribute_changes_p^ [change_index].output_deferred_by_user;

        = jmc$output_destination =
          system_label.job_attributes.output_destination := local_attribute_changes_p^ [change_index].
                output_destination;

        = jmc$output_destination_family =
          system_label.job_attributes.output_destination_family :=
                local_attribute_changes_p^ [change_index].output_destination_family;

        = jmc$output_destination_usage =
          system_label.job_attributes.output_destination_usage :=
                local_attribute_changes_p^ [change_index].output_destination_usage;

        = jmc$output_disposition =
          system_label.job_attributes.output_disposition_key :=
                local_attribute_changes_p^ [change_index].output_disposition.key;
          IF system_label.job_attributes.output_disposition_key = jmc$standard_output_path THEN
            NEXT local_output_disposition_path_p IN options_seq_p;
            system_label.job_attributes.output_disposition_path := local_output_disposition_path_p^;
          IFEND;

        = jmc$output_priority =
          system_label.job_attributes.output_priority := local_attribute_changes_p^ [change_index].
                output_priority;

        = jmc$purge_delay =
          NEXT local_purge_delay_p IN options_seq_p;
          system_label.job_attributes.purge_delay := local_purge_delay_p^;

        = jmc$remote_host_directive =
          NEXT local_remote_host_directive_p IN options_seq_p;
          system_label.job_attributes.remote_host_directive := local_remote_host_directive_p^;

        = jmc$routing_banner =
          system_label.job_attributes.routing_banner := local_attribute_changes_p^ [change_index].
                routing_banner;

        = jmc$site_information =
          NEXT local_site_information_p IN options_seq_p;
          system_label.job_attributes.site_information := local_site_information_p^;

        = jmc$sru_limit =
          system_label.limit_information.sru_limit_specified := TRUE;
          system_label.limit_information.sru_limit_requested :=
                local_attribute_changes_p^ [change_index].sru_limit;

        = jmc$station =
          system_label.job_attributes.station := local_attribute_changes_p^ [change_index].station;

        = jmc$station_operator =
          system_label.job_attributes.station_operator := local_attribute_changes_p^ [change_index].
                station_operator;

        = jmc$user_information =
          NEXT local_user_information_p IN options_seq_p;
          system_label.job_attributes.user_information := local_user_information_p^;

        = jmc$user_job_name =
          system_label.user_job_name := local_attribute_changes_p^ [change_index].user_job_name;

        = jmc$vertical_print_density =
          system_label.job_attributes.vertical_print_density :=
                local_attribute_changes_p^ [change_index].vertical_print_density;

        = jmc$vfu_load_procedure =
          system_label.job_attributes.vfu_load_procedure := local_attribute_changes_p^ [change_index].
                vfu_load_procedure;

        ELSE
        CASEND;
      FOREND;
    IFEND;

{ set up clock info for deferred jobs

    pmp$get_compact_date_time (current_date_time, status);
    IF NOT status.normal THEN
      amp$return (local_file_name, ignore_status);
      RETURN;
    IFEND;

    pmp$get_microsecond_clock (current_microsecond_clock, status);
    IF NOT status.normal THEN
      amp$return (local_file_name, ignore_status);
      RETURN;
    IFEND;

    IF system_label.job_attributes.earliest_run_time.specified THEN
      jmp$convert_date_time_dif_to_us (current_date_time, system_label.job_attributes.earliest_run_time.
            date_time, current_microsecond_clock, earliest_clock_time_to_initiate);
    ELSE
      earliest_clock_time_to_initiate := jmc$earliest_clock_time;
    IFEND;

    IF system_label.job_attributes.latest_run_time.specified THEN
      jmp$convert_date_time_dif_to_us (current_date_time, system_label.job_attributes.latest_run_time.
            date_time, current_microsecond_clock, latest_clock_time_to_initiate);
    ELSE
      latest_clock_time_to_initiate := jmc$latest_clock_time;
    IFEND;

    store_and_forward_job := local_parameters_p^.input_file_location = jmc$ifl_store_and_forward_queue;

{ If the request was not done by an operator or scheduling administrator then
{ change the job submission time.

    IF NOT local_parameters_p^.privileged_for_status THEN
      system_label.job_attributes.job_submission_time := current_date_time;
    IFEND;

  /determine_job_class/
    WHILE TRUE DO
      WHILE jmv$sched_profile_is_loading DO
        pmp$wait (500, 500);
      WHILEND;
      active_profile_version := jmv$job_scheduler_table.profile_identification;
      IF (system_label.job_class_name <> jmc$automatic_class_name) AND
            (system_label.job_class_name <> osc$null_name) AND
            (system_label.job_class_name <> jmc$system_default_class_name) THEN
        jmp$expand_job_class_abbrev (system_label.job_class_name, ignore_status);
      IFEND;

{ If not a store and forward job, prevalidate the job unless it is in the
{ UNASSIGNED job class and was initially submitted under the current scheduler
{ profile.  Refresh the class index of the initial submission job class for the job
{ in UNASSIGNED since it may have changed even if the profile version has the
{ same structure.

      IF NOT store_and_forward_job THEN
        IF (local_parameters_p^.attribute_change_count > 0) OR
              (active_profile_version <> system_label.active_profile_version) OR
              (local_parameters_p^.beginning_job_class <> jmc$unassigned_class_name) THEN

{ Convert the requested limits into preliminary assigned limits.

          convert_limit_information (system_label, status);
          IF NOT status.normal THEN
            amp$return (local_file_name, ignore_status);
            RETURN;
          IFEND;

          prevalidate_job (system_label.login_user_identification, {password_encrypted} TRUE, system_label,
                assigned_job_class, ignore_encrypted_password, status);
          IF NOT status.normal THEN
            qfp$check_for_profile_mismatch (active_profile_version, profile_mismatch);
            IF profile_mismatch OR jmv$sched_profile_is_loading THEN
              CYCLE /determine_job_class/;
            IFEND;
            amp$return (local_file_name, ignore_status);
            RETURN;
          IFEND;
        ELSE
          jmp$determine_job_class (system_label.assigned_job_class, assigned_job_class, status);
          IF NOT status.normal THEN
            qfp$check_for_profile_mismatch (active_profile_version, profile_mismatch);
            IF profile_mismatch OR jmv$sched_profile_is_loading THEN
              status.normal := TRUE;
              CYCLE /determine_job_class/;
            IFEND;
            osp$set_status_abnormal (jmc$job_management_id, jme$job_class_does_not_exist,
                  system_label.assigned_job_class, status);
            amp$return (local_file_name, ignore_status);
            RETURN;
          IFEND;
        IFEND;

{ See if the job fits any mainframes in the scheduling profile.

        leveled_job := (system_label.job_destination_usage <> jmc$ve_local_usage) AND
              (local_parameters_p^.input_file_location = jmc$ifl_login_family_queue);
        qfp$determine_mainframe_fitness (system_label.job_category_set, leveled_job,
              system_label.login_user_identification.family, valid_mainframe_set, status);
        IF NOT status.normal THEN
          qfp$check_for_profile_mismatch (active_profile_version, profile_mismatch);
          IF profile_mismatch OR jmv$sched_profile_is_loading THEN
            status.normal := TRUE;
            CYCLE /determine_job_class/;
          IFEND;
          amp$return (local_file_name, ignore_status);
          RETURN;
        IFEND;
      ELSE
        valid_mainframe_set := $jmt$valid_mainframe_set [];
      IFEND;

{ Update tables

      system_label.active_profile_version := active_profile_version;
      qfp$change_input_attributes (system_label, assigned_job_class,
            local_parameters_p^.privileged_for_status, earliest_clock_time_to_initiate,
            latest_clock_time_to_initiate, current_microsecond_clock, valid_mainframe_set, status);
      IF NOT status.normal THEN
        IF (status.condition <> jme$scheduling_profile_changed) THEN
          amp$return (local_file_name, ignore_status);
          RETURN;
        ELSE
          CYCLE /determine_job_class/;
        IFEND;
      IFEND;

      EXIT /determine_job_class/;
    WHILEND /determine_job_class/;

{ Write the result system label to the input file

    write_label := TRUE;
    qfp$write_job_system_label (local_file_name, write_label, system_label, status);
    IF NOT status.normal THEN
      amp$return (local_file_name, ignore_status);
      RETURN;
    IFEND;

{ Release the file in case somebody needs it

    amp$return (local_file_name, status);

  PROCEND jmp$mainframe_change_input_attr;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$mainframe_get_input_attribu', EJECT ??
*copy jmh$mainframe_get_input_attribu

  PROCEDURE [XDCL] jmp$mainframe_get_input_attribu
    (    target_options_p: ^SEQ ( * );
     VAR data_area_p: {input, output} ^SEQ ( * );
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      boolean_p: ^boolean,
      copies_p: ^jmt$output_copy_count,
      cpu_time_limit_p: ^jmt$cpu_time_limit,
      cycle_selector: pft$cycle_selector,
      data_mode_p: ^jmt$data_mode,
      date_time_p: ^jmt$date_time,
      external_characteristics_p: ^jmt$external_characteristics,
      forms_code_p: ^jmt$forms_code,
      ignore_status: ost$status,
      input_index: jmt$job_count_range,
      job_abort_disposition_p: ^jmt$job_abort_disposition,
      job_category_count_p: ^jmt$job_category_count,
      job_category_index: jmt$job_category_count,
      job_category_list_p: ^jmt$full_job_category_list,
      job_mode_p: ^jmt$job_mode,
      job_qualifier_list_p: ^jmt$job_qualifier_list,
      job_recovery_disposition_p: ^jmt$job_recovery_disposition,
      job_size_p: ^jmt$job_size,
      job_state_p: ^jmt$job_state,
      job_status_results_p: ^jmt$job_status_results,
      kjl_index: jmt$kjl_index,
      local_file_name: amt$local_file_name,
      local_parameters_p: ^mainframe_getia_parameters,
      local_results_keys_p: ^jmt$results_keys,
      local_status_keys_p: ^jmt$results_keys,
      local_status_name_count_p: ^ost$non_negative_integers,
      local_status_options_p: ^jmt$job_status_options,
      magnetic_tape_limit_p: ^jmt$magnetic_tape_limit,
      maximum_working_set_p: ^jmt$working_set_size,
      name_value_p: ^ost$name,
      number_of_jobs_statused: jmt$job_count_range,
      option_index: ost$positive_integers,
      options_seq_p: ^SEQ ( * ),
      os_date_time_p: ^ost$date_time,
      output_disposition_key_p: ^jmt$output_disposition_keys,
      output_disposition_path_p: ^fst$path,
      password: pft$password,
      path_p: ^pft$path,
      remote_host_directive_p: ^jmt$remote_host_directive,
      result_index: ost$positive_integers,
      ring_p: ^ost$ring,
      scratch_segment: amt$segment_pointer,
      site_information_p: ^jmt$site_information,
      sru_limit_p: ^jmt$sru_limit,
      status_results_keys_p: ^jmt$results_keys,
      system_file_name_p: ^jmt$system_supplied_name,
      system_label: jmt$job_system_label,
      system_label_p: ^jmt$job_system_label,
      time_increment_p: ^jmt$time_increment,
      usage_selections: pft$usage_selections,
      user_information_p: ^jmt$user_information,
      vertical_print_density_p: ^jmt$vertical_print_density,
      work_area_full: boolean;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      mmp$delete_scratch_segment (scratch_segment, ignore_status);
      pfp$end_system_authority;
      IF status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;

?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    ignore_status.normal := TRUE;

    options_seq_p := target_options_p;
    RESET options_seq_p;
    NEXT local_parameters_p IN options_seq_p;

{ By definition, the number of status options is non-zero.

    NEXT local_status_options_p: [1 .. local_parameters_p^.status_option_count] IN options_seq_p;
    FOR option_index := 1 TO local_parameters_p^.status_option_count DO
      CASE local_status_options_p^ [option_index].key OF
      = jmc$name_list =
        NEXT local_status_name_count_p IN options_seq_p;
        IF local_status_name_count_p^ = 0 THEN
          local_status_options_p^ [option_index].name_list := NIL;
        ELSE
          NEXT local_status_options_p^ [option_index].name_list: [1 .. local_status_name_count_p^] IN
                options_seq_p;
        IFEND;

      = jmc$user_identification =
        NEXT local_status_options_p^ [option_index].user_identification IN options_seq_p;

      ELSE
      CASEND;
    FOREND;

    IF local_parameters_p^.results_keys_count = 0 THEN
      local_results_keys_p := NIL;
      local_status_keys_p := NIL;
      status_results_keys_p := NIL;
    ELSE
      NEXT local_results_keys_p: [1 .. local_parameters_p^.results_keys_count] IN options_seq_p;
      NEXT local_status_keys_p: [1 .. local_parameters_p^.results_keys_count] IN options_seq_p;
      PUSH status_results_keys_p: [1 .. local_parameters_p^.results_keys_count + 5];
      FOR result_index := 1 TO local_parameters_p^.results_keys_count DO
        status_results_keys_p^ [result_index] := local_status_keys_p^ [result_index];
      FOREND;
      status_results_keys_p^ [local_parameters_p^.results_keys_count + 1] := jmc$login_family;
      status_results_keys_p^ [local_parameters_p^.results_keys_count + 2] := jmc$system_job_name;
      status_results_keys_p^ [local_parameters_p^.results_keys_count + 3] := jmc$input_file_location;
      status_results_keys_p^ [local_parameters_p^.results_keys_count + 4] := jmc$internal_index;
      status_results_keys_p^ [local_parameters_p^.results_keys_count + 5] := jmc$job_mode;

    IFEND;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, scratch_segment, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET scratch_segment.sequence_pointer;

    jmp$get_job_status (local_status_options_p, status_results_keys_p, scratch_segment.sequence_pointer,
          job_status_results_p, number_of_jobs_statused, status);
    IF NOT status.normal THEN
      IF status.condition = jme$no_jobs_were_found THEN
        number_of_jobs_statused := 0;
        status.normal := TRUE;
      ELSE
        mmp$delete_scratch_segment (scratch_segment, ignore_status);
        RETURN;
      IFEND;
    IFEND;

    number_of_data_packets := 0;
    work_area_full := FALSE;
    IF local_results_keys_p <> NIL THEN

    /fetch_attributes_for_files/
      FOR input_index := 1 TO number_of_jobs_statused DO
        IF local_parameters_p^.attach_file THEN
          IF (job_status_results_p^ [input_index]^ [local_parameters_p^.results_keys_count + 5].job_mode =
                jmc$batch) THEN

{ Attach the file so we can read the system label and get the attributes

            pmp$get_unique_name (local_file_name, { ignore } status);
            determine_file_path (job_status_results_p^ [input_index]^
                  [local_parameters_p^.results_keys_count + 3].input_file_location,
                  job_status_results_p^ [input_index]^ [local_parameters_p^.results_keys_count +
                  1].login_family, job_status_results_p^ [input_index]^
                  [local_parameters_p^.results_keys_count + 2].system_job_name, path_p);
            cycle_selector.cycle_option := pfc$specific_cycle;
            cycle_selector.cycle_number := 1;
            password := osc$null_name;
            usage_selections := $pft$usage_selections [pfc$read];

            osp$establish_block_exit_hndlr (^handle_block_exit);
            pfp$begin_system_authority;
            pfp$attach (local_file_name, path_p^, cycle_selector, password, usage_selections,
                  usage_selections, pfc$wait, { local } status);
            pfp$end_system_authority;
            osp$disestablish_cond_handler;
            IF NOT status.normal THEN
              status.normal := TRUE;
              CYCLE /fetch_attributes_for_files/;
            IFEND;

{ Read the input file's system label

            qfp$read_job_system_label (local_file_name, system_label, status);
            IF NOT status.normal THEN
              amp$return (local_file_name, ignore_status);
              mmp$delete_scratch_segment (scratch_segment, ignore_status);
              RETURN;
            IFEND;

{ Release the file in case somebody needs it for write access

            amp$return (local_file_name, status);

          ELSE { job_mode is interactive
            kjl_index := job_status_results_p^ [input_index]^ [local_parameters_p^.results_keys_count +
                  4].internal_index;
            system_label_p := jmv$kjlx_p^ [kjl_index].system_label_p;
            IF system_label_p = NIL THEN
              CYCLE /fetch_attributes_for_files/;
            IFEND;
            system_label := system_label_p^;

{ If the KJL entry has disappeared then skip the entry.

            IF jmv$kjl_p^ [kjl_index].system_job_name <> job_status_results_p^ [input_index]^
                  [local_parameters_p^.results_keys_count + 2].system_job_name THEN
              CYCLE /fetch_attributes_for_files/;
            IFEND;
          IFEND;
        IFEND;

        number_of_data_packets := number_of_data_packets + 1;

        IF NOT work_area_full THEN

        /fill_in_each_result_field/
          FOR result_index := 1 TO local_parameters_p^.results_keys_count DO
            CASE local_results_keys_p^ [result_index] OF
            = jmc$comment_banner =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := system_label.job_attributes.comment_banner;

            = jmc$control_family =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := job_status_results_p^ [input_index]^ [result_index].control_family;

            = jmc$control_user =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := job_status_results_p^ [input_index]^ [result_index].control_user;

            = jmc$copies =
              NEXT copies_p IN data_area_p;
              IF copies_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              copies_p^ := system_label.job_attributes.copy_count;

            = jmc$cpu_time_limit =
              NEXT cpu_time_limit_p IN data_area_p;
              IF cpu_time_limit_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              cpu_time_limit_p^ := system_label.limit_information.cpu_time_limit_assigned;

            = jmc$data_mode =
              NEXT data_mode_p IN data_area_p;
              IF data_mode_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              data_mode_p^ := system_label.data_mode;

            = jmc$device =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := system_label.job_attributes.device;

            = jmc$earliest_print_time =
              NEXT date_time_p IN data_area_p;
              IF date_time_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              date_time_p^ := system_label.job_attributes.earliest_print_time;

            = jmc$earliest_run_time =
              NEXT date_time_p IN data_area_p;
              IF date_time_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              date_time_p^ := system_label.job_attributes.earliest_run_time;

            = jmc$external_characteristics =
              NEXT external_characteristics_p IN data_area_p;
              IF external_characteristics_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              external_characteristics_p^ := system_label.job_attributes.external_characteristics;

            = jmc$forms_code =
              NEXT forms_code_p IN data_area_p;
              IF forms_code_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              forms_code_p^ := system_label.job_attributes.forms_code;

            = jmc$job_abort_disposition =
              NEXT job_abort_disposition_p IN data_area_p;
              IF job_abort_disposition_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              job_abort_disposition_p^ := system_label.job_abort_disposition;

            = jmc$job_category_list =
              NEXT job_category_count_p IN data_area_p;
              IF job_category_count_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              NEXT job_category_list_p IN data_area_p;
              IF job_category_list_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              job_category_count_p^ := 0;
              FOR job_category_index := LOWERBOUND (jmv$job_category_data.category_names^)
                    TO UPPERBOUND (jmv$job_category_data.category_names^) DO
                IF job_category_index IN system_label.job_category_set THEN
                  job_category_count_p^ := job_category_count_p^ +1;
                  job_category_list_p^ [job_category_count_p^] :=
                        jmv$job_category_data.category_names^ [job_category_index].name;
                IFEND;
              FOREND;

            = jmc$job_class =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := job_status_results_p^ [input_index]^ [result_index].job_class;

            = jmc$job_deferred_by_operator =
              NEXT boolean_p IN data_area_p;
              IF boolean_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              boolean_p^ := job_status_results_p^ [input_index]^ [result_index].job_deferred_by_operator;

            = jmc$job_deferred_by_user =
              NEXT boolean_p IN data_area_p;
              IF boolean_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              boolean_p^ := job_status_results_p^ [input_index]^ [result_index].job_deferred_by_user;

            = jmc$job_destination_family =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := system_label.job_destination_family;

            = jmc$job_destination_usage =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := job_status_results_p^ [input_index]^ [result_index].job_destination_usage;

            = jmc$job_execution_ring =
              NEXT ring_p IN data_area_p;
              IF ring_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              ring_p^ := system_label.job_execution_ring;

            = jmc$job_mode =
              NEXT job_mode_p IN data_area_p;
              IF job_mode_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              job_mode_p^ := job_status_results_p^ [input_index]^ [result_index].job_mode;

            = jmc$job_qualifier_list =
              NEXT job_qualifier_list_p: [1 .. jmc$maximum_job_qualifiers] IN data_area_p;
              IF job_qualifier_list_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              job_qualifier_list_p^ := system_label.job_attributes.job_qualifier_list;

            = jmc$job_recovery_disposition =
              NEXT job_recovery_disposition_p IN data_area_p;
              IF job_recovery_disposition_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              job_recovery_disposition_p^ := system_label.job_recovery_disposition;

            = jmc$job_state =
              NEXT job_state_p IN data_area_p;
              IF job_state_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              job_state_p^ := job_status_results_p^ [input_index]^ [result_index].job_state;

            = jmc$job_size =
              NEXT job_size_p IN data_area_p;
              IF job_size_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              job_size_p^ := system_label.job_attributes.job_size;

            = jmc$job_submission_time =
              NEXT os_date_time_p IN data_area_p;
              IF os_date_time_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              os_date_time_p^ := system_label.job_attributes.job_submission_time;

            = jmc$latest_print_time =
              NEXT date_time_p IN data_area_p;
              IF date_time_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              date_time_p^ := system_label.job_attributes.latest_print_time;

            = jmc$latest_run_time =
              NEXT date_time_p IN data_area_p;
              IF date_time_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              date_time_p^ := system_label.job_attributes.latest_run_time;

            = jmc$login_account =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := system_label.login_account;

            = jmc$login_family =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := job_status_results_p^ [input_index]^ [result_index].login_family;

            = jmc$login_project =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := system_label.login_project;

            = jmc$login_user =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := job_status_results_p^ [input_index]^ [result_index].login_user;

            = jmc$magnetic_tape_limit =
              NEXT magnetic_tape_limit_p IN data_area_p;
              IF magnetic_tape_limit_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              magnetic_tape_limit_p^ := system_label.limit_information.magnetic_tape_limit_assigned;

            = jmc$maximum_working_set =
              NEXT maximum_working_set_p IN data_area_p;
              IF maximum_working_set_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              maximum_working_set_p^ := system_label.limit_information.maximum_working_set_assigned;

            = jmc$null_attribute =
              ;

            = jmc$origin_application_name =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := system_label.job_attributes.originating_application_name;

            = jmc$output_class =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := system_label.job_attributes.output_class;

            = jmc$output_deferred_by_user =
              NEXT boolean_p IN data_area_p;
              IF boolean_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              boolean_p^ := system_label.job_attributes.output_deferred_by_user;

            = jmc$output_destination =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := system_label.job_attributes.output_destination;

            = jmc$output_destination_family = { operator_family
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := system_label.job_attributes.output_destination_family;

            = jmc$output_destination_usage =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := system_label.job_attributes.output_destination_usage;

            = jmc$output_disposition =
              NEXT output_disposition_key_p IN data_area_p;
              IF output_disposition_key_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              NEXT output_disposition_path_p IN data_area_p;
              IF output_disposition_path_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              output_disposition_key_p^ := system_label.job_attributes.output_disposition_key;
              IF output_disposition_key_p^ = jmc$standard_output_path THEN
                output_disposition_path_p^ := system_label.job_attributes.output_disposition_path;
              IFEND;

            = jmc$output_priority =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := system_label.job_attributes.output_priority;

            = jmc$purge_delay =
              NEXT time_increment_p IN data_area_p;
              IF time_increment_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              time_increment_p^ := system_label.job_attributes.purge_delay;

            = jmc$remote_host_directive =
              NEXT remote_host_directive_p IN data_area_p;
              IF remote_host_directive_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              remote_host_directive_p^ := system_label.job_attributes.remote_host_directive;

            = jmc$routing_banner =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := system_label.job_attributes.routing_banner;

            = jmc$site_information =
              NEXT site_information_p IN data_area_p;
              IF site_information_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              site_information_p^ := system_label.job_attributes.site_information;

            = jmc$sru_limit =
              NEXT sru_limit_p IN data_area_p;
              IF sru_limit_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              sru_limit_p^ := system_label.limit_information.sru_limit_assigned;

            = jmc$station =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := system_label.job_attributes.station;

            = jmc$station_operator = { operator_user
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := system_label.job_attributes.station_operator;

            = jmc$system_job_name =
              NEXT system_file_name_p IN data_area_p;
              IF system_file_name_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              system_file_name_p^ := job_status_results_p^ [input_index]^ [result_index].system_job_name;

            = jmc$user_information =
              NEXT user_information_p IN data_area_p;
              IF user_information_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              user_information_p^ := system_label.job_attributes.user_information;

            = jmc$user_job_name =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := job_status_results_p^ [input_index]^ [result_index].user_job_name;

            = jmc$vertical_print_density =
              NEXT vertical_print_density_p IN data_area_p;
              IF vertical_print_density_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              vertical_print_density_p^ := system_label.job_attributes.vertical_print_density;

            = jmc$vfu_load_procedure =
              NEXT name_value_p IN data_area_p;
              IF name_value_p = NIL THEN
                work_area_full := TRUE;
                EXIT /fill_in_each_result_field/;
              IFEND;
              name_value_p^ := system_label.job_attributes.vfu_load_procedure;

            ELSE
            CASEND;
          FOREND /fill_in_each_result_field/;


        IFEND;
      FOREND /fetch_attributes_for_files/;
    IFEND;

    IF work_area_full THEN
      osp$set_status_condition (jme$work_area_too_small, status);
    IFEND;

    mmp$delete_scratch_segment (scratch_segment, ignore_status);
  PROCEND jmp$mainframe_get_input_attribu;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$mainframe_get_job_status', EJECT ??
*copy jmh$mainframe_get_job_status

  PROCEDURE [XDCL] jmp$mainframe_get_job_status
    (    target_options_p: ^SEQ ( * );
     VAR data_area_p: {input, output} ^SEQ ( * );
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      local_parameters_p: ^mainframe_getjs_parameters,
      local_status_name_count_p: ^ost$non_negative_integers,
      local_status_options_p: ^jmt$job_status_options,
      local_status_results_keys_p: ^jmt$results_keys,
      number_of_jobs_found: jmt$job_status_count,
      options_seq_p: ^SEQ ( * ),
      status_option_index: ost$non_negative_integers;

    status.normal := TRUE;
    options_seq_p := target_options_p;
    RESET options_seq_p;
    NEXT local_parameters_p IN options_seq_p;

    IF local_parameters_p^.status_option_count = 0 THEN
      local_status_options_p := NIL;
    ELSE
      NEXT local_status_options_p: [1 .. local_parameters_p^.status_option_count] IN options_seq_p;

      FOR status_option_index := 1 TO local_parameters_p^.status_option_count DO
        IF local_status_options_p^ [status_option_index].key = jmc$name_list THEN
          NEXT local_status_name_count_p IN options_seq_p;
          IF local_status_name_count_p^ = 0 THEN
            local_status_options_p^ [status_option_index].name_list := NIL;
          ELSE
            NEXT local_status_options_p^ [status_option_index].name_list: [1 .. local_status_name_count_p^] IN
                  options_seq_p;
          IFEND;
        IFEND;
      FOREND;
    IFEND;

    IF local_parameters_p^.status_results_count = 0 THEN
      local_status_results_keys_p := NIL;
    ELSE
      NEXT local_status_results_keys_p: [1 .. local_parameters_p^.status_results_count] IN options_seq_p;
    IFEND;

    qfp$get_job_status (local_parameters_p^.user_identification, local_parameters_p^.caller_ssn,
          local_parameters_p^.privileged_job, local_parameters_p^.valid_for_scheduling_displays,
          local_status_options_p, local_status_results_keys_p, data_area_p, number_of_jobs_found, status);
    number_of_data_packets := number_of_jobs_found;
  PROCEND jmp$mainframe_get_job_status;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL #GATE] jmp$open_input_file', EJECT ??
*copy jmh$open_input_file

  PROCEDURE [XDCL, #GATE] jmp$open_input_file
    (    system_job_name: jmt$system_supplied_name;
         access_level: amt$access_level;
         destination_usage: jmt$destination_usage;
         queue_file_password: jmt$queue_file_password;
     VAR file_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      attachment_options_p: ^fst$attachment_options,
      attribute_override_p: ^fst$file_cycle_attributes,
      caller_id: ost$caller_identifier,
      family_name: ost$name,
      file_path: fst$path,
      file_path_size: 0 .. fsc$max_path_size,
      master_catalog: ost$name,
      sub_catalog: ost$name;

?? NEWTITLE := '    [INLINE] add_to_file_path', EJECT ??

    PROCEDURE [INLINE] add_to_file_path
      (    path_element_string: string ( * <= osc$max_name_size));

      VAR
        string_length: 1 .. osc$max_name_size;

      string_length := clp$trimmed_string_size (path_element_string);
      file_path (file_path_size + 1, string_length) := path_element_string;
      file_path_size := file_path_size + string_length;
    PROCEND add_to_file_path;

?? OLDTITLE ??
?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      IF status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??

    #KEYPOINT (osk$entry, 0, jmk$open_input_file);
    status.normal := TRUE;
    #CALLER_ID (caller_id);

{ Validate that the caller deserves access to the file.

    qfp$validate_input_file_access (system_job_name, destination_usage, queue_file_password, family_name,
          status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$open_input_file);
      RETURN;
    IFEND;

    determine_file_catalogs (jmc$ifl_store_and_forward_queue, family_name, master_catalog, sub_catalog);

{ Build the file path for the open request.

    file_path_size := 0;
    add_to_file_path (':');
    add_to_file_path (master_catalog);
    add_to_file_path ('.');
    add_to_file_path (jmc$system_user);
    add_to_file_path ('.');
    add_to_file_path (sub_catalog);
    add_to_file_path ('.');
    add_to_file_path (system_job_name);

{ Attach the file for read access and open the file with the rings of the caller

    PUSH attribute_override_p: [1 .. 1];
    attribute_override_p^ [1].selector := fsc$ring_attributes;
    attribute_override_p^ [1].ring_attributes.r1 := osc$tsrv_ring;
    attribute_override_p^ [1].ring_attributes.r2 := caller_id.ring;
    attribute_override_p^ [1].ring_attributes.r3 := caller_id.ring;

    PUSH attachment_options_p: [1 .. 2];
    attachment_options_p^ [1].selector := fsc$access_and_share_modes;
    attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options_p^ [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options_p^ [1].share_modes.value := $fst$file_access_options [fsc$read];
    attachment_options_p^ [2].selector := fsc$open_share_modes;
    attachment_options_p^ [2].open_share_modes := $fst$file_access_options [fsc$read];

    osp$establish_block_exit_hndlr (^handle_block_exit);
    pfp$begin_system_authority;
    fsp$open_file (file_path (1, file_path_size), access_level, attachment_options_p, NIL, NIL, NIL,
          attribute_override_p, file_identifier, status);
    pfp$end_system_authority;
    osp$disestablish_cond_handler;
    #KEYPOINT (osk$exit, 0, jmk$open_input_file);
  PROCEND jmp$open_input_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$rebuild_executing_job', EJECT ??
*copy jmh$rebuild_executing_job

  PROCEDURE [XDCL] jmp$rebuild_executing_job
    (    system_job_name: jmt$system_supplied_name;
         jcb_p: ^jmt$job_control_block);

    VAR
      current_microsecond_clock: jmt$clock_time;

    current_microsecond_clock := #FREE_RUNNING_CLOCK (0);

    qfp$rebuild_executing_job (current_microsecond_clock, system_job_name, jcb_p^);
  PROCEND jmp$rebuild_executing_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$rebuild_input_queue', EJECT ??
*copy jmh$rebuild_input_queue

{ DESIGN:
{   If there are any problems attempting to recover a file in the queue the file should be
{ deleted if the problem is with the file.  If the problem is with the configuration, e.g.
{ some fundamental NOS/VE requests do not work leave the file in the queue until the next
{ deadstart.

  PROCEDURE [XDCL] jmp$rebuild_input_queue
    (    system_job_name: jmt$system_supplied_name;
         family_name: ost$name;
         subcatalog_name: ost$name;
         recover_using_abort_disposition: boolean;
         ignore_client_initiated_jobs: boolean;
         job_deferred_by_operator: boolean;
     VAR status: ost$status);

    VAR
      candidate_name: jmt$name,
      current_date_time: ost$date_time,
      current_mainframe_id: pmt$mainframe_id,
      current_microsecond_clock: jmt$clock_time,
      cycle_selector: pft$cycle_selector,
      earliest_clock_time_to_initiate: jmt$clock_time,
      ignore_status: ost$status,
      input_file_location: jmt$input_file_location,
      job_class: jmt$job_class,
      job_submission_time: jmt$clock_time,
      latest_clock_time_to_initiate: jmt$clock_time,
      leveler_status: jmt$jl_job_leveler_status,
      local_family: boolean,
      local_file_name: amt$local_file_name,
      login_family_access: dft$family_access,
      login_family_available: boolean,
      password: pft$password,
      path_p: ^pft$path,
      server_state: dft$server_state,
      system_label: jmt$job_system_label,
      usage_selections: pft$usage_selections,
      valid_name: jmt$name,
      write_label: boolean;


    status.normal := TRUE;
    ignore_status.normal := TRUE;
    write_label := FALSE;

{ Verify that the system_job_name is a legal system supplied name.

    candidate_name.kind := jmc$system_supplied_name;
    candidate_name.system_supplied_name := system_job_name;
    jmp$validate_name (candidate_name, valid_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_unique_name (local_file_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH path_p: [1 .. 4];
    path_p^ [1] := family_name;
    path_p^ [2] := jmc$system_user;
    path_p^ [3] := subcatalog_name;
    path_p^ [4] := system_job_name;
    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := 1;
    password := osc$null_name;
    usage_selections := $pft$usage_selections [pfc$read];

    pfp$attach (local_file_name, path_p^, cycle_selector, password, usage_selections, usage_selections,
          pfc$wait, status);
    IF NOT status.normal THEN
      pfp$purge (path_p^, cycle_selector, password, ignore_status);
      RETURN;
    IFEND;

{ If we can't read the system label - then we can't recover it

    qfp$read_job_system_label (local_file_name, system_label, status);
    IF NOT status.normal THEN
      amp$return (local_file_name, ignore_status);
      pfp$purge (path_p^, cycle_selector, password, ignore_status);
      RETURN;
    IFEND;

{ Verify that the system_job_name matches in the label and the catalog

    IF system_job_name <> system_label.system_job_name THEN
      osp$set_status_condition (sye$job_damaged, status);
      amp$return (local_file_name, ignore_status);
      pfp$purge (path_p^, cycle_selector, password, ignore_status);
      RETURN;
    IFEND;

{ If the job is an interactive job - don't recover it

    IF system_label.job_mode = jmc$interactive_connected THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$cant_recover_job, 'an interactive queued', status);
      amp$return (local_file_name, ignore_status);
      pfp$purge (path_p^, cycle_selector, password, ignore_status);
      RETURN;
    IFEND;

    IF recover_using_abort_disposition AND (system_label.job_abort_disposition = jmc$terminate_on_abort) THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$job_recovery_or_abort_set, 'TERMINATED', status);
      amp$return (local_file_name, ignore_status);
      pfp$purge (path_p^, cycle_selector, password, ignore_status);
      RETURN;
    IFEND;

{ If the job was initiated on this mainframe then it should be recovered as queued.
{ If the job was initiated on a client and ignore_client_initiated_jobs is TRUE then
{ the input file should be recovered as queued.

    IF system_label.job_initiation_location <> '' THEN
      pmp$get_mainframe_id (current_mainframe_id, { ignore } status);
      IF (system_label.job_initiation_location = current_mainframe_id) OR ignore_client_initiated_jobs THEN
        system_label.job_initiation_location := '';
        write_label := TRUE;
      IFEND;
    IFEND;

{ If the job should be deferred, set the attribute in the system label.

    IF job_deferred_by_operator THEN
      system_label.job_deferred_by_operator := job_deferred_by_operator;
      write_label := TRUE;
    IFEND;

    IF write_label THEN
      qfp$write_job_system_label (local_file_name, write_label, system_label, status);
    IFEND;

{ Determine the input file's location.

    IF subcatalog_name = jmc$sf_job_input_catalog THEN
      input_file_location := jmc$ifl_store_and_forward_queue;
    ELSEIF family_name = jmc$system_family THEN
      input_file_location := jmc$ifl_system_input_queue;
    ELSE
      input_file_location := jmc$ifl_login_family_queue;
    IFEND;

{ set up clock info for deferred jobs

    pmp$get_compact_date_time (current_date_time, status);
    IF NOT status.normal THEN
      amp$return (local_file_name, ignore_status);
      RETURN;
    IFEND;
    pmp$get_microsecond_clock (current_microsecond_clock, status);
    IF NOT status.normal THEN
      amp$return (local_file_name, ignore_status);
      RETURN;
    IFEND;

    IF system_label.job_attributes.earliest_run_time.specified THEN
      jmp$convert_date_time_dif_to_us (current_date_time, system_label.job_attributes.earliest_run_time.
            date_time, current_microsecond_clock, earliest_clock_time_to_initiate);
    ELSE
      earliest_clock_time_to_initiate := jmc$earliest_clock_time;
    IFEND;

    IF system_label.job_attributes.latest_run_time.specified THEN
      jmp$convert_date_time_dif_to_us (current_date_time, system_label.job_attributes.latest_run_time.
            date_time, current_microsecond_clock, latest_clock_time_to_initiate);
    ELSE
      latest_clock_time_to_initiate := jmc$latest_clock_time;
    IFEND;

{ Calculate the value for the job's job submission time clock value.

    jmp$convert_date_time_dif_to_us (current_date_time, system_label.job_attributes.job_submission_time,
          current_microsecond_clock, job_submission_time);

    IF input_file_location = jmc$ifl_store_and_forward_queue THEN
      job_class := jmc$null_job_class;
    ELSE
      job_class := jmc$unassigned_job_class;
    IFEND;

    dfp$get_family_access (system_label.login_user_identification.family, local_family, login_family_access,
          server_state, leveler_status);
    IF local_family AND (dfc$remote_file_access IN login_family_access) THEN
      login_family_available := (server_state = dfc$active) AND
            ((login_family_access * $dft$family_access [dfc$remote_login_access,
            dfc$job_leveling_access]) <> $dft$family_access []);
    ELSE
      login_family_available := local_family;
    IFEND;

    qfp$rebuild_input_queue (system_label, earliest_clock_time_to_initiate, latest_clock_time_to_initiate,
          current_microsecond_clock, job_submission_time, job_class, input_file_location,
          login_family_available, status);
    IF NOT status.normal THEN
      amp$return (local_file_name, ignore_status);
    ELSE
      amp$return (local_file_name, status);
    IFEND;

  PROCEND jmp$rebuild_input_queue;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$register_input_application', EJECT ??
*copy jmh$register_input_application

  PROCEDURE [XDCL, #GATE] jmp$register_input_application
    (    application_name: ost$name;
         input_destination_usage: jmt$destination_usage;
     VAR queue_file_password: jmt$queue_file_password;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      privileged_job: boolean,
      valid_name: boolean,
      valid_application_name: ost$name,
      valid_destination_usage: ost$name;

    #KEYPOINT (osk$entry, 0, jmk$register_input_application);

    status.normal := TRUE;
    #CALLER_ID (caller_id);

    privileged_job := (caller_id.ring <= osc$sj_ring_3) OR jmv$enable_queue_file_access OR jmp$system_job ();
    IF NOT privileged_job THEN
      osp$force_access_violation;
    IFEND;

    clp$validate_name (application_name, valid_application_name, valid_name);
    IF NOT valid_name THEN
      osp$set_status_abnormal ('CL', cle$improper_name, application_name, status);
      #KEYPOINT (osk$exit, 0, jmk$register_input_application);
      RETURN;
    IFEND;

    clp$validate_name (input_destination_usage, valid_destination_usage, valid_name);
    IF NOT valid_name THEN
      osp$set_status_abnormal ('CL', cle$improper_name, input_destination_usage, status);
      #KEYPOINT (osk$exit, 0, jmk$register_input_application);
      RETURN;
    IFEND;

    pmp$get_unique_name (queue_file_password, status);
    IF status.normal THEN
      qfp$register_input_application (valid_application_name, valid_destination_usage, queue_file_password,
            status);
      IF status.normal THEN
        task_has_registered_application := TRUE;
      IFEND;
    IFEND;
    #KEYPOINT (osk$exit, 0, jmk$register_input_application);
  PROCEND jmp$register_input_application;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$release_input_files', EJECT ??
*copy jmh$release_input_files

  PROCEDURE [XDCL] jmp$release_input_files;

    VAR
      release_file_list: ^jmt$release_input_file_list,
      release_file_count: jmt$job_count_range,
      release_file_index: jmt$job_count_range,
      ignore_status: ost$status,
      path_p: ^pft$path,
      cycle_selector: pft$cycle_selector,
      password: pft$password;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      pfp$end_system_authority;
      IF ignore_status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, ignore_status, local_status);
      IFEND;
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??

    IF NOT task_has_registered_application THEN
      RETURN;
    IFEND;

    ignore_status.normal := TRUE;

    PUSH release_file_list: [1 .. jmc$maximum_job_count];
    release_file_count := 0;

{ Since the release_file_list is at the maximum, no test will be necessary to verify that
{ the release_file_count does not exceed the upperbound of the list.

    qfp$release_input_files (release_file_list, release_file_count);

    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := 1;
    password := osc$null_name;
    PUSH path_p: [1 .. 4];
    path_p^ [2] := jmc$system_user;

{ This can only be the store-and-forward queue.  Jobs that belong to the local VE system(s) will not have
{ their command files manipulated by this request.  The only applications that can have files attached are
{ applications that access the store-and-forward queue.  With this in mind, osc$null_name is supplied as
{ the family name.

    osp$establish_block_exit_hndlr (^handle_block_exit);
    pfp$begin_system_authority;

  /purge_all_released_files/
    FOR release_file_index := 1 TO release_file_count DO
      determine_file_catalogs (release_file_list^ [release_file_index].input_file_location, osc$null_name,
            path_p^ [1], path_p^ [3]);
      path_p^ [4] := release_file_list^ [release_file_index].system_job_name;
      pfp$purge (path_p^, cycle_selector, password, ignore_status);
    FOREND /purge_all_released_files/;

    pfp$end_system_authority;
    osp$disestablish_cond_handler;
  PROCEND jmp$release_input_files;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$resubmit_queued_input_job', EJECT ??
*copy jmh$resubmit_queued_input_job

  PROCEDURE [XDCL, #GATE] jmp$resubmit_queued_input_job
    (    system_supplied_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      input_name: jmt$name,
      local_status: ost$status;

    status.normal := TRUE;

    jmp$get_scheduling_admin_status (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;
    input_name.kind := jmc$system_supplied_name;
    input_name.system_supplied_name := system_supplied_name;
    jmp$change_input_attributes (input_name, NIL, local_status);
    status := local_status;
  PROCEND jmp$resubmit_queued_input_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$server_submit_job', EJECT ??
*copy jmh$server_submit_job

  PROCEDURE [XDCL] jmp$server_submit_job
    (VAR received_from_client_params_p { Input } : dft$p_receive_parameters;
     VAR received_from_client_data_p { Input } : dft$p_receive_data;
     VAR send_to_client_params_p { Output } : dft$p_send_parameters;
     VAR send_to_client_data_p { Output } : dft$p_send_data;
     VAR parameter_size: dft$send_parameter_size;
     VAR data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      assigned_job_class: jmt$job_class,
      current_date_time: ost$date_time,
      current_microsecond_clock: jmt$clock_time,
      cycle_selector: pft$cycle_selector,
      destination_mainframe_id: pmt$mainframe_id,
      earliest_clock_time_to_initiate: jmt$clock_time,
      ignore_status: ost$status,
      ignore_job_queued_this_mainfr: boolean,
      job_system_label_p: ^jmt$job_system_label,
      latest_clock_time_to_initiate: jmt$clock_time,
      leveled_job: boolean,
      local_file_name: amt$local_file_name,
      local_mainframe_id_p: ^pmt$mainframe_id,
      password: pft$password,
      path_p: ^pft$path,
      profile_mismatch: boolean,
      profile_mismatch_or_loading: boolean,
      server_submit_job_params_p: ^server_submit_job_parameters,
      submit_variation: jmt$submit_job_variations,
      usage_selections: pft$usage_selections,
      valid_mainframe_set: jmt$valid_mainframe_set;

?? NEWTITLE := 'categorize_job', EJECT ??

{ PURPOSE:
{   The purpose of this request is to assign and validate allowed values
{   for specific job attributes.

    PROCEDURE categorize_job
      (VAR job_system_label: jmt$job_system_label;
       VAR profile_mismatch_or_loading: boolean;
       VAR assigned_job_class: jmt$job_class;
       VAR status: ost$status);

      VAR
        ignore_encrypted_password: ost$name,
        ignore_status: ost$status;


      profile_mismatch_or_loading := FALSE;
      job_system_label_p^.active_profile_version := jmv$job_scheduler_table.profile_identification;

      convert_limit_information (job_system_label, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      prevalidate_job (job_system_label.login_user_identification, { password_encrypted } TRUE,
            job_system_label, assigned_job_class, ignore_encrypted_password, status);
      IF NOT status.normal THEN
        qfp$check_for_profile_mismatch (job_system_label_p^.active_profile_version, profile_mismatch);
        profile_mismatch_or_loading := profile_mismatch OR jmv$sched_profile_is_loading;
      IFEND;
    PROCEND categorize_job;
?? OLDTITLE ??
?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      IF status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;
?? OLDTITLE ??
?? EJECT ??
    status.normal := TRUE;

{ The RPC sequences have already been reset.
{ Unpack the information passed from the client.

    NEXT server_submit_job_params_p IN received_from_client_params_p;

    NEXT job_system_label_p IN received_from_client_data_p;

    NEXT local_mainframe_id_p IN send_to_client_params_p;
    pmp$get_mainframe_id (local_mainframe_id_p^, ignore_status);
    parameter_size := i#current_sequence_position (send_to_client_params_p);
    data_size := 0;

{ Determine earliest and latest initiation times.

    pmp$get_microsecond_clock (current_microsecond_clock, ignore_status);
    pmp$get_compact_date_time (current_date_time, ignore_status);

    IF job_system_label_p^.job_attributes.earliest_run_time.specified THEN
      jmp$convert_date_time_dif_to_us (current_date_time, job_system_label_p^.job_attributes.
            earliest_run_time.date_time, current_microsecond_clock, earliest_clock_time_to_initiate);
    ELSE
      earliest_clock_time_to_initiate := jmc$earliest_clock_time;
    IFEND;
    IF job_system_label_p^.job_attributes.latest_run_time.specified THEN
      jmp$convert_date_time_dif_to_us (current_date_time, job_system_label_p^.job_attributes.latest_run_time.
            date_time, current_microsecond_clock, latest_clock_time_to_initiate);
    ELSE
      latest_clock_time_to_initiate := jmc$latest_clock_time;
    IFEND;

  /determine_job_class/
    REPEAT

      WHILE jmv$sched_profile_is_loading DO
        pmp$wait (500, 500);
      WHILEND;

{ Verify that the profile identifiers of the two mainframe match.  If the profiles
{ do not match then the job must be categorized on the server.

      qfp$check_for_profile_mismatch (job_system_label_p^.active_profile_version, profile_mismatch);
      IF NOT profile_mismatch THEN
        jmp$determine_job_class (job_system_label_p^.assigned_job_class, assigned_job_class, status);
        IF NOT status.normal THEN
          qfp$check_for_profile_mismatch (job_system_label_p^.active_profile_version, profile_mismatch);
          IF profile_mismatch OR jmv$sched_profile_is_loading THEN
            status.normal := TRUE;
            CYCLE /determine_job_class/;
          ELSE
            osp$set_status_abnormal (jmc$job_management_id, jme$job_class_does_not_exist,
                  job_system_label_p^.assigned_job_class, status);
            EXIT /determine_job_class/;
          IFEND;
        IFEND;

      ELSEIF (job_system_label_p^.job_mode <> jmc$interactive_connected) THEN
        determine_file_path (jmc$ifl_login_family_queue, job_system_label_p^.login_user_identification.family,
              job_system_label_p^.system_job_name, path_p);
        pmp$get_unique_name (local_file_name, ignore_status);
        cycle_selector.cycle_option := pfc$specific_cycle;
        cycle_selector.cycle_number := 1;
        password := osc$null_name;
        usage_selections := $pft$usage_selections [pfc$read];
        osp$establish_block_exit_hndlr (^handle_block_exit);
        pfp$begin_system_authority;
        pfp$attach (local_file_name, path_p^, cycle_selector, password, usage_selections, usage_selections,
              pfc$wait, status);
        pfp$end_system_authority;
        osp$disestablish_cond_handler;

{ Read the input file's system label

        qfp$read_job_system_label (local_file_name, job_system_label_p^, status);
        IF NOT status.normal THEN
          amp$return (local_file_name, ignore_status);
          EXIT /determine_job_class/;
        IFEND;

        categorize_job (job_system_label_p^, profile_mismatch_or_loading, assigned_job_class, status);
        IF NOT status.normal THEN
          IF profile_mismatch_or_loading THEN
            status.normal := TRUE;
            CYCLE /determine_job_class/;
          ELSE
            amp$return (local_file_name, ignore_status);
            EXIT /determine_job_class/;
          IFEND;
        IFEND;

        qfp$write_job_system_label (local_file_name, { write_label } TRUE, job_system_label_p^, status);
        IF NOT status.normal THEN
          amp$return (local_file_name, ignore_status);
          EXIT /determine_job_class/;
        IFEND;

        amp$return (local_file_name, status);
        IF NOT status.normal THEN
          EXIT /determine_job_class/;
        IFEND;

      ELSEIF (job_system_label_p^.job_mode = jmc$interactive_connected) THEN
        categorize_job (job_system_label_p^, profile_mismatch_or_loading, assigned_job_class, status);
        IF NOT status.normal THEN
          IF profile_mismatch_or_loading THEN
            status.normal := TRUE;
            CYCLE /determine_job_class/;
          ELSE
            EXIT /determine_job_class/;
          IFEND;
        IFEND;
      IFEND;

{ Determine the fitness of the job for the mainframes that are available.

      IF server_submit_job_params_p^.executing_on_server THEN
        leveled_job := job_system_label_p^.job_destination_usage = jmc$ve_usage;
        qfp$determine_mainframe_fitness (job_system_label_p^.job_category_set, leveled_job,
              job_system_label_p^.login_user_identification.family, valid_mainframe_set, status);
        IF status.normal THEN
          IF leveled_job AND (job_system_label_p^.job_mode <> jmc$batch) AND
                jmv$job_scheduler_table.enable_job_leveling THEN
            level_interactive_job (valid_mainframe_set, assigned_job_class, earliest_clock_time_to_initiate,
                  latest_clock_time_to_initiate, current_microsecond_clock,
                  server_submit_job_params_p^.origin_mainframe_id, job_system_label_p^, local_mainframe_id_p^,
                  status);
          ELSE
            IF job_system_label_p^.job_mode <> jmc$batch THEN
              submit_variation.kind := jmc$remote_connection_switch;
              job_system_label_p^.job_attributes.system_job_parameters.system_job_parameter_count :=
                    #SIZE (submit_variation);
              i#move (^submit_variation, ^job_system_label_p^.job_attributes.system_job_parameters.
                    system_job_parameter, #SIZE (submit_variation));
              nap$set_server_job_init_pending (osc$timesharing, {server_job_init_pending = } TRUE, status);
            IFEND;

            IF status.normal THEN
              IF jmv$job_history_active THEN
                jmp$emit_job_history_statistics (jml$job_queuing_started, osc$null_name,
                      job_system_label_p^.system_job_name, jmc$blank_system_supplied_name, job_system_label_p,
                      NIL, osc$null_name, job_system_label_p^.job_attributes.originating_ssn, ignore_status);
              IFEND;

              qfp$submit_job (job_system_label_p^, assigned_job_class, earliest_clock_time_to_initiate,
                    latest_clock_time_to_initiate, current_microsecond_clock,
                    {job_submission_time} current_microsecond_clock,
                    server_submit_job_params_p^.immediate_initiation_candidate, jmc$ifl_login_family_queue,
                    valid_mainframe_set, status);
            IFEND;
          IFEND;
        IFEND;
      ELSE

{ NOT server_submit_job_params_p^.executing_on_server - this only occurs when
{ called from call_client_submit_job.

        valid_mainframe_set := $jmt$valid_mainframe_set [1];
        submit_variation.kind := jmc$remote_connection_switch;
        job_system_label_p^.job_attributes.system_job_parameters.system_job_parameter_count :=
              #SIZE (submit_variation);
        i#move (^submit_variation, ^job_system_label_p^.job_attributes.system_job_parameters.
              system_job_parameter, #SIZE (submit_variation));
        nap$set_server_job_init_pending (osc$timesharing, {server_job_init_pending = } TRUE, status);

        IF status.normal THEN
          IF jmv$job_history_active THEN
            jmp$emit_job_history_statistics (jml$job_queuing_started, osc$null_name,
                  job_system_label_p^.system_job_name, jmc$blank_system_supplied_name, job_system_label_p,
                  NIL, osc$null_name, job_system_label_p^.job_attributes.originating_ssn, ignore_status);
          IFEND;

          qfp$submit_job (job_system_label_p^, assigned_job_class, earliest_clock_time_to_initiate,
                latest_clock_time_to_initiate, current_microsecond_clock,
                {job_submission_time} current_microsecond_clock,
                server_submit_job_params_p^.immediate_initiation_candidate, jmc$ifl_login_family_queue,
                valid_mainframe_set, status);
        IFEND;
      IFEND;
    UNTIL status.normal OR (status.condition <> jme$scheduling_profile_changed);

  PROCEND jmp$server_submit_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$server_terminate_job', EJECT ??
*copy jmh$server_terminate_job

  PROCEDURE [XDCL] jmp$server_terminate_job
    (VAR received_from_client_params_p { Input } : dft$p_receive_parameters;
     VAR received_from_client_data_p { Input } : dft$p_receive_data;
     VAR send_to_client_params_p { Output } : dft$p_send_parameters;
     VAR send_to_client_data_p { Output } : dft$p_send_data;
     VAR parameter_size: dft$send_parameter_size;
     VAR data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      binary_server_mainframe_id: pmt$binary_mainframe_id,
      current_binary_mainframe_id: pmt$binary_mainframe_id,
      current_mainframe_id: pmt$mainframe_id,
      ignore_client_mainframe_id: pmt$mainframe_id,
      ignore_family_name: ost$name,
      ignore_input_file_location: jmt$input_file_location,
      ignore_job_assigned_to_client: boolean,
      job_terminated: boolean,
      local_job_terminated_p: ^boolean,
      local_mf_searched_count_p: ^jmt$maximum_mainframes,
      local_mf_searched_list_p: ^jmt$mainframes_searched_list,
      local_remove_job_from_kjl_p: ^boolean,
      local_system_job_name_p: ^jmt$system_supplied_name,
      local_terminate_job_request_p: ^terminate_job_request,
      mainframes_searched_count: jmt$maximum_mainframes,
      mainframes_searched_list: jmt$mainframes_searched_list,
      mainframes_searched_list_index: jmt$maximum_mainframes,
      server_directly_connected: boolean,
      server_mainframe_count: dft$partner_mainframe_count,
      server_mainframe_id: pmt$mainframe_id,
      server_mainframe_index: dft$partner_mainframe_count,
      server_mainframe_list: array [1 .. dfc$maximum_partner_mainframes] of dft$partner_mainframe_entry;

    status.normal := TRUE;

{ The RPC sequences have already been reset.

    NEXT local_system_job_name_p IN received_from_client_params_p;
    NEXT local_terminate_job_request_p IN received_from_client_params_p;

    IF local_terminate_job_request_p^.server THEN
      NEXT local_mf_searched_count_p IN received_from_client_data_p;
      mainframes_searched_count := local_mf_searched_count_p^;
      NEXT local_mf_searched_list_p IN received_from_client_data_p;
      mainframes_searched_list := local_mf_searched_list_p^;

{ Place this mainframe in the mainframes searched list.

      mainframes_searched_count := mainframes_searched_count + 1;
      pmp$get_pseudo_mainframe_id (current_binary_mainframe_id);
      mainframes_searched_list [mainframes_searched_count] := current_binary_mainframe_id;
      pmp$get_mainframe_id (current_mainframe_id, { ignore } status);

{ If this is the server then terminate the job.  If this is not the server then
{ call the server if it is directly connected.  If the server is not directly
{ connected call all other available server mainframes that have not been called.

      IF current_mainframe_id = local_terminate_job_request_p^.server_mainframe_id THEN

        job_terminated := TRUE;

        terminate_job (local_system_job_name_p^, local_terminate_job_request_p^.job_state_set,
              local_terminate_job_request_p^.output_disposition_key_known,
              local_terminate_job_request_p^.output_disposition_key,
              local_terminate_job_request_p^.operator_job, local_terminate_job_request_p^.reason, status);

      ELSE

        dfp$get_partner_mainframes ({ partners_are_servers } TRUE, ^server_mainframe_list,
              server_mainframe_count);

{ See if the server is directly connected to this mainframe.  If so it can simply
{ be called.  If NOT, a remote procedure call will be required until a mainframe is
{ reached which can access the server or the server cannot be found.

        pmp$convert_mainframe_to_binary (local_terminate_job_request_p^.server_mainframe_id,
              binary_server_mainframe_id, { ignore } status);
        status.normal := TRUE;
        server_directly_connected := FALSE;

      /search_for_server_mainframe/
        FOR server_mainframe_index := 1 TO server_mainframe_count DO
          IF server_mainframe_list [server_mainframe_index].mainframe_id = binary_server_mainframe_id THEN
            server_directly_connected := TRUE;
            terminate_job_on_server (local_system_job_name_p^,
                  local_terminate_job_request_p^.server_mainframe_id, local_terminate_job_request_p^,
                  mainframes_searched_count, mainframes_searched_list, job_terminated, status);
            EXIT /search_for_server_mainframe/;
          IFEND;
        FOREND /search_for_server_mainframe/;

        IF NOT server_directly_connected THEN

        /call_each_server_mainframe/
          FOR server_mainframe_index := 1 TO server_mainframe_count DO
            IF mainframes_searched_count < jmc$maximum_mainframes THEN

{ If the server has already been called then try another server.

              FOR mainframes_searched_list_index := 1 TO mainframes_searched_count DO
                IF mainframes_searched_list [mainframes_searched_list_index] =
                      server_mainframe_list [server_mainframe_index].mainframe_id THEN
                  CYCLE /call_each_server_mainframe/;
                IFEND;
              FOREND;
              IF server_mainframe_list [server_mainframe_index].partner_state = dfc$active THEN
                pmp$convert_binary_mainframe_id (server_mainframe_list [server_mainframe_index].mainframe_id,
                      server_mainframe_id, { ignore } status);
                status.normal := TRUE;
                terminate_job_on_server (local_system_job_name_p^, server_mainframe_id,
                      local_terminate_job_request_p^, mainframes_searched_count, mainframes_searched_list,
                      job_terminated, status);
              IFEND;
            ELSE
              EXIT /call_each_server_mainframe/;
            IFEND;
          FOREND /call_each_server_mainframe/;
        IFEND;
      IFEND;
      NEXT local_job_terminated_p IN send_to_client_params_p;
      local_job_terminated_p^ := job_terminated;

      NEXT local_mf_searched_count_p IN send_to_client_data_p;
      local_mf_searched_count_p^ := mainframes_searched_count;
      NEXT local_mf_searched_list_p IN send_to_client_data_p;
      local_mf_searched_list_p^ := mainframes_searched_list;

    ELSE { client request
      NEXT local_remove_job_from_kjl_p IN send_to_client_params_p;
      qfp$terminate_job (local_system_job_name_p^, local_terminate_job_request_p^.job_state_set,
            local_terminate_job_request_p^.output_disposition_key_known,
            local_terminate_job_request_p^.output_disposition_key,
            local_terminate_job_request_p^.operator_job, ignore_family_name,
            { delete_input_file } local_remove_job_from_kjl_p^, ignore_input_file_location,
            ignore_job_assigned_to_client, ignore_client_mainframe_id, status);

{ If the job was not found on the client the job should still be removed from the server.

      IF (NOT status.normal) AND (status.condition = jme$name_not_found) THEN
        local_remove_job_from_kjl_p^ := TRUE;
        status.normal := TRUE;
      IFEND;
    IFEND;
    parameter_size := i#current_sequence_position (send_to_client_params_p);
    data_size := i#current_sequence_position (send_to_client_data_p);
  PROCEND jmp$server_terminate_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$set_input_completed', EJECT ??
*copy jmh$set_input_completed

  PROCEDURE [XDCL, #GATE] jmp$set_input_completed
    (    input_destination_usage: jmt$destination_usage;
         system_job_name: jmt$system_supplied_name;
         completed_successfully: boolean;
     VAR status: ost$status);

    VAR
      cycle_selector: pft$cycle_selector,
      delete_input_file: boolean,
      password: pft$password,
      path_p: ^pft$path;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      IF status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??

    #KEYPOINT (osk$entry, 0, jmk$set_input_completed);

    status.normal := TRUE;

    qfp$set_input_completed (input_destination_usage, system_job_name, completed_successfully,
          delete_input_file, status);
    IF status.normal THEN
      IF delete_input_file THEN

{ This can only be the store-and-forward queue.  Jobs that belong to the local VE system(s) will not have
{ their command files touched by this request.  The only applications that can have files attached are
{ applications that access the store-and-forward queue.  With this in mind, osc$null_name is supplied as
{ the family name.

        determine_file_path (jmc$ifl_store_and_forward_queue, osc$null_name, system_job_name, path_p);
        cycle_selector.cycle_option := pfc$specific_cycle;
        cycle_selector.cycle_number := 1;
        password := osc$null_name;
        osp$establish_block_exit_hndlr (^handle_block_exit);
        pfp$begin_system_authority;
        pfp$purge (path_p^, cycle_selector, password, status);
        pfp$end_system_authority;
        osp$disestablish_cond_handler;
      IFEND;
    IFEND;
    #KEYPOINT (osk$exit, 0, jmk$set_input_completed);
  PROCEND jmp$set_input_completed;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$set_input_initiated', EJECT ??
*copy jmh$set_input_initiated

  PROCEDURE [XDCL, #GATE] jmp$set_input_initiated
    (    input_destination_usage: jmt$destination_usage;
         system_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      ignore_status: ^ost$status;

    #KEYPOINT (osk$entry, 0, jmk$set_input_initiated);
    status.normal := TRUE;
    qfp$set_input_initiated (input_destination_usage, system_job_name, status);

    IF jmv$job_history_active AND status.normal THEN
      PUSH ignore_status;
      jmp$emit_job_history_statistics (jml$job_forwarding_started, osc$null_name, system_job_name,
            jmc$blank_system_supplied_name, NIL, NIL, osc$null_name, jmc$blank_system_supplied_name,
            ignore_status^);
    IFEND;
    #KEYPOINT (osk$exit, 0, jmk$set_input_initiated);
  PROCEND jmp$set_input_initiated;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$set_job_class_limits', EJECT ??
*copy jmh$set_job_class_limits

  PROCEDURE [XDCL, #GATE] jmp$set_job_class_limits
    (    job_class_set: jmt$job_class_set;
         class_limit_value: jmt$job_count_range;
     VAR status: ost$status);

    osp$verify_system_privilege;
    status.normal := TRUE;

    IF NOT avp$system_operator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_operator', status);
      RETURN;
    IFEND;

    qfp$set_job_class_limits (job_class_set, class_limit_value);
  PROCEND jmp$set_job_class_limits;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$submit_job', EJECT ??
*copy jmh$submit_job

{ DESIGN:
{   This interface will accept multiple occurrences of the same attribute.  Only the last value specified
{ for a particular attribute (submission option) will be used.

  PROCEDURE [XDCL, #GATE] jmp$submit_job
    (    file_reference: fst$file_reference;
         job_submission_options: ^jmt$job_submission_options;
     VAR system_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      assigned_job_class: jmt$job_class,
      caller_identification: ost$caller_identifier,
      command_file_password: pft$password,
      command_file_path_p: ^pft$path,
      current_date_time: ost$date_time,
      current_mainframe_id: pmt$mainframe_id,
      current_microsecond_clock: jmt$clock_time,
      cycle_selector: pft$cycle_selector,
      destination_mainframe_id: pmt$mainframe_id,
      earliest_clock_time_to_initiate: jmt$clock_time,
      encrypted_password: ost$name,
      encrypted_password_supplied: boolean,
      evaluated_file_reference: fst$evaluated_file_reference,
      explicit_login_command_p: ^string ( * ),
      file_path: fst$path,
      file_path_size: fst$path_size,
      ignore_status: ost$status,
      immediate_initiation_candidate: boolean,
      inherit_job_attributes: boolean,
      input_file_location: jmt$input_file_location,
      job_label_exists: boolean,
      job_submission_time: jmt$clock_time,
      latest_clock_time_to_initiate: jmt$clock_time,
      leveled_access: boolean,
      leveled_job: boolean,
      login_family_defined: boolean,
      privileged_job: boolean,
      profile_mismatch: boolean,
      reason: ost$name,
      remote_host_directive_inherited: boolean,
      server_location: dft$server_location,
      statistic_data: jmt$comm_acct_statistic_data,
      store_and_forward_job: boolean,
      submit_job_to_server: boolean,
      submit_of_command_file: boolean,
      submit_variation: jmt$submit_job_variations,
      system_label: jmt$job_system_label,
      user_identification: ost$user_identification,
      valid_mainframe_set: jmt$valid_mainframe_set;

?? NEWTITLE := '    assign_default_attributes', EJECT ??

{ PURPOSE:
{   The purpose of this request is to assign the default job attribute values to a job that is being
{ submitted.
{
{ DESIGN:
{   If the job is being submitted by the system on behalf of a user use the "system" defaults for the
{ job attribute values.  Otherwise, use the submitting users job attribute values as the defaults for
{ the job attribute values.

    PROCEDURE assign_default_attributes
      (    user_identification: ost$user_identification;
           inherit_job_attributes: boolean;
       VAR system_label: jmt$job_system_label;
       VAR status: ost$status);

      VAR
        use_user_attributes: boolean;

      status.normal := TRUE;

{ If the caller is a user, use the user default attributes
{ If the caller is the system, submitting a user job, use system defaults
{ If the caller is the system, submitting system job, use user defaults
{ If the caller asked not to inherit the job attributes use system defaults

      use_user_attributes := (NOT (jmp$system_job () AND (NOT (user_identification =
            system_label.login_user_identification)))) AND inherit_job_attributes;

{ Assign job attribute defaults

      IF use_user_attributes THEN
        system_label.job_attributes.comment_banner := jmv$job_attributes.comment_banner;
        system_label.job_attributes.copy_count := jmv$job_attributes.copy_count;
        system_label.job_attributes.device := jmv$job_attributes.device;
        system_label.job_attributes.earliest_print_time := jmv$job_attributes.earliest_print_time;
        system_label.job_attributes.external_characteristics := jmv$job_attributes.external_characteristics;
        system_label.job_attributes.forms_code := jmv$job_attributes.forms_code;
        system_label.job_attributes.implicit_routing_text := jmv$job_attributes.implicit_routing_text;
        system_label.job_attributes.job_controller := jmv$job_attributes.job_controller;
        system_label.job_attributes.job_input_device := jmv$job_attributes.job_input_device;
        system_label.job_attributes.latest_print_time := jmv$job_attributes.latest_print_time;
        system_label.job_attributes.output_destination := jmv$job_attributes.output_destination;
        system_label.job_attributes.output_destination_family := jmv$job_attributes.output_destination_family;
        system_label.job_attributes.output_destination_usage := jmv$job_attributes.output_destination_usage;
        system_label.job_attributes.output_priority := jmv$job_attributes.output_priority;
        system_label.job_attributes.purge_delay := jmv$job_attributes.purge_delay;
        system_label.job_attributes.remote_host_directive := jmv$job_attributes.remote_host_directive;
        system_label.job_attributes.routing_banner := jmv$job_attributes.routing_banner;
        system_label.job_attributes.source_logical_id := jmv$job_attributes.source_logical_id;
        system_label.job_attributes.station := jmv$job_attributes.station;
        system_label.job_attributes.station_operator := jmv$job_attributes.station_operator;
        IF system_label.job_attributes.user_information = '' THEN
          system_label.job_attributes.user_information := jmv$job_attributes.user_information;
        IFEND;
        system_label.job_attributes.vertical_print_density := jmv$job_attributes.vertical_print_density;
        system_label.job_attributes.vfu_load_procedure := jmv$job_attributes.vfu_load_procedure;
      ELSE
        system_label.job_attributes.comment_banner := '';
        system_label.job_attributes.copy_count := 1;
        system_label.job_attributes.device := jmv$default_job_attributes [system_label.job_mode].device;
        system_label.job_attributes.earliest_print_time.specified := FALSE;
        system_label.job_attributes.external_characteristics :=
              jmv$default_job_attributes [system_label.job_mode].external_characteristics;
        system_label.job_attributes.forms_code := jmv$default_job_attributes [system_label.job_mode].
              forms_code;
        system_label.job_attributes.implicit_routing_text.size := 0;
        system_label.job_attributes.implicit_routing_text.text := '';
        system_label.job_attributes.job_controller := system_label.login_user_identification;
        system_label.job_attributes.job_input_device.size := 0;
        system_label.job_attributes.job_input_device.text := '';
        system_label.job_attributes.latest_print_time.specified := FALSE;
        system_label.job_attributes.output_destination := osc$null_name;
        system_label.job_attributes.output_destination_family := osc$null_name;
        system_label.job_attributes.output_destination_usage :=
              jmv$default_job_attributes [system_label.job_mode].output_destination_usage;
        system_label.job_attributes.output_priority := jmv$default_job_attributes [system_label.job_mode].
              output_priority;
        system_label.job_attributes.purge_delay := jmv$default_job_attributes [system_label.job_mode].
              purge_delay;
        system_label.job_attributes.remote_host_directive.size := 0;
        system_label.job_attributes.remote_host_directive.parameters := '';
        system_label.job_attributes.routing_banner := '';
        system_label.job_attributes.source_logical_id := '';
        system_label.job_attributes.station := 'AUTOMATIC';
        system_label.job_attributes.station_operator := osc$null_name;
        system_label.job_attributes.vertical_print_density :=
              jmv$default_job_attributes [system_label.job_mode].vertical_print_density;
        system_label.job_attributes.vfu_load_procedure := jmv$default_job_attributes [system_label.job_mode].
              vfu_load_procedure;
      IFEND;

{ Override attributes that are not inheritable

      pmp$get_compact_date_time (system_label.job_attributes.job_submission_time, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      system_label.job_attributes.output_class := jmv$default_job_attributes [system_label.job_mode].
            output_class;
      system_label.job_attributes.output_deferred_by_user := FALSE;
      system_label.job_attributes.output_disposition_key := jmc$normal_output_disposition;

      system_label.job_attributes.output_disposition_path := '';
      system_label.job_attributes.site_information := jmv$default_job_attributes [system_label.job_mode].
            site_information;
      system_label.job_attributes.system_job_parameters.system_job_parameter := '';
      system_label.job_attributes.system_job_parameters.system_job_parameter_count := 0;
      system_label.job_attributes.system_routing_text.parameters := '';
      system_label.job_attributes.system_routing_text.size := 0;
    PROCEND assign_default_attributes;

?? OLDTITLE ??
?? NEWTITLE := '    assign_default_label_values', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to assign some default values for several items in the job label.
{
{ NOTES:
{   Any attributes that represent parameters on the LOGIN command must be initialized
{ by this procedure.

    PROCEDURE assign_default_label_values
      (    user_identification: ost$user_identification;
       VAR system_label: jmt$job_system_label;
       VAR status: ost$status);

      VAR
        submitter_job_name: jmt$user_supplied_name;

      status.normal := TRUE;

{ system_label.version is not used.

      pmp$get_job_names (submitter_job_name, system_label.job_attributes.originating_ssn, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      system_label.active_profile_version := osc$null_name;
      system_label.assigned_job_class := osc$null_name;
      system_label.data_declaration := '';
      system_label.data_mode := jmc$coded_data;
      system_label.disposition_code := '';
      system_label.job_category_set := $jmt$job_category_set [];
      system_label.job_class_name := osc$null_name;
      system_label.job_deferred_by_user := FALSE;
      system_label.job_destination_family := osc$null_name;
      system_label.job_destination_usage := jmv$default_job_attributes [jmc$batch].job_destination_usage;
      system_label.job_execution_ring := osc$invalid_ring;
      system_label.job_initiation_location := '';
      system_label.job_mode := jmc$batch;
      system_label.job_priority := osc$null_name;
      system_label.limit_information.cpu_time_limit_specified := FALSE;
      system_label.limit_information.cpu_time_limit_assigned := sfc$unlimited;
      system_label.limit_information.magnetic_tape_limit_specified := FALSE;
      system_label.limit_information.magnetic_tape_limit_assigned := 0;
      system_label.limit_information.maximum_working_set_specified := FALSE;
      system_label.limit_information.maximum_working_set_assigned := 20000;
      system_label.limit_information.sru_limit_specified := FALSE;
      system_label.limit_information.sru_limit_assigned := sfc$unlimited;
      system_label.login_account := osc$null_name;
      system_label.login_project := osc$null_name;
      system_label.login_password := osc$null_name;
      system_label.login_user_identification.user := osc$null_name;
      system_label.login_user_identification.family := osc$null_name;
      system_label.optional_user_capability := osc$null_name;
      pmp$get_account_project (system_label.originating_login_account, system_label.originating_login_project,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      system_label.originating_login_family := user_identification.family;
      system_label.originating_login_user := user_identification.user;
      system_label.perform_class_validation := TRUE;
      system_label.required_user_capability := osc$null_name;
      system_label.system_job_name := '';
      system_label.user_job_name := osc$null_name;
      system_label.job_attributes.earliest_run_time.specified := FALSE;
      system_label.job_attributes.latest_run_time.specified := FALSE;
      system_label.job_attributes.login_command_supplied := TRUE;
      system_label.job_attributes.originating_application_name := osc$submit_job;
      system_label.job_attributes.process_user_prolog_and_epilog := TRUE;
      system_label.job_attributes.user_information := '';
    PROCEND assign_default_label_values;

?? OLDTITLE ??
?? NEWTITLE := '    determine_if_job_label_exists', EJECT ??

{ PURPOSE:
{   This procedure determines if the job being submitted already has its attributes
{   defined (i.e., it has a label associated with it).

    PROCEDURE determine_if_job_label_exists
      (    file_reference: fst$file_reference;
       VAR system_label: jmt$job_system_label;
       VAR job_label_exists: boolean;
       VAR status: ost$status);


      status.normal := TRUE;

{ Try to read a job label from the file being submitted.

      qfp$read_job_system_label (file_reference, system_label, status);
      IF status.normal THEN
        job_label_exists := TRUE;
      ELSEIF status.condition = jme$read_job_system_label THEN
        osp$set_status_condition (jme$sl_version_mismatch, status);
      ELSEIF (status.condition <> jme$sl_version_mismatch) THEN
        status.normal := TRUE;
        job_label_exists := FALSE;
      IFEND;
    PROCEND determine_if_job_label_exists;
?? OLDTITLE ??
?? NEWTITLE := '    determine_job_attributes', EJECT ??

{ PURPOSE:
{   The purpose of this request is to pass through the job submission options and override the default
{ job attribute values with explicit values provided by the caller.

    PROCEDURE determine_job_attributes
      (    job_submission_options_p: ^jmt$job_submission_options;
           privileged_job: boolean;
       VAR system_label: jmt$job_system_label;
       VAR immediate_initiation_candidate: boolean;
       VAR current_date_time: ost$date_time;
       VAR current_microsecond_clock: jmt$clock_time;
       VAR earliest_clock_time_to_initiate: jmt$clock_time;
       VAR latest_clock_time_to_initiate: jmt$clock_time;
       VAR remote_host_directive_inherited: boolean;
       VAR status: ost$status);

      VAR
        option_index: ost$positive_integers,
        parsed_file_reference: fst$parsed_file_reference,
        scl_name: ost$name,
        valid_name: boolean;

      status.normal := TRUE;
      immediate_initiation_candidate := FALSE;
      remote_host_directive_inherited := (system_label.job_attributes.remote_host_directive.size > 0);

{ Override the default values for the system label - if necessary

      IF job_submission_options_p <> NIL THEN
        FOR option_index := 1 TO UPPERBOUND (job_submission_options_p^) DO
          CASE job_submission_options_p^ [option_index].key OF
          = jmc$comment_banner =
            system_label.job_attributes.comment_banner := job_submission_options_p^ [option_index].
                  comment_banner;

          = jmc$copies =
            system_label.job_attributes.copy_count := job_submission_options_p^ [option_index].copies;

          = jmc$device =
            clp$validate_name (job_submission_options_p^ [option_index].device, scl_name, valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_submission_options_p^ [option_index].device, status);
              RETURN;
            IFEND;
            system_label.job_attributes.device := scl_name;

          = jmc$earliest_print_time =
            system_label.job_attributes.earliest_print_time :=
                  job_submission_options_p^ [option_index].earliest_print_time;

          = jmc$earliest_run_time =
            system_label.job_attributes.earliest_run_time := job_submission_options_p^ [option_index].
                  earliest_run_time;

          = jmc$external_characteristics =
            #TRANSLATE (osv$lower_to_upper, job_submission_options_p^ [option_index].external_characteristics,
                  system_label.job_attributes.external_characteristics);

          = jmc$forms_code =
            #TRANSLATE (osv$lower_to_upper, job_submission_options_p^ [option_index].forms_code,
                  system_label.job_attributes.forms_code);

          = jmc$job_abort_disposition =
            system_label.job_abort_disposition := job_submission_options_p^ [option_index].
                  job_abort_disposition;

          = jmc$job_recovery_disposition =
            system_label.job_recovery_disposition := job_submission_options_p^ [option_index].
                  job_recovery_disposition;

          = jmc$latest_print_time =
            system_label.job_attributes.latest_print_time := job_submission_options_p^ [option_index].
                  latest_print_time;

          = jmc$latest_run_time =
            system_label.job_attributes.latest_run_time := job_submission_options_p^ [option_index].
                  latest_run_time;

          = jmc$output_deferred_by_user =
            system_label.job_attributes.output_deferred_by_user :=
                  job_submission_options_p^ [option_index].output_deferred_by_user;

          = jmc$output_destination =
            clp$validate_name (job_submission_options_p^ [option_index].output_destination, scl_name,
                  valid_name);
            IF valid_name THEN
              system_label.job_attributes.output_destination := scl_name;
            ELSE { The value must be a string
              #TRANSLATE (osv$lower_to_upper, job_submission_options_p^ [option_index].output_destination,
                    system_label.job_attributes.output_destination);
            IFEND;

          = jmc$output_destination_family =
            clp$validate_name (job_submission_options_p^ [option_index].output_destination_family, scl_name,
                  valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_submission_options_p^ [option_index].output_destination_family, status);
              RETURN;
            IFEND;
            system_label.job_attributes.output_destination_family := scl_name;

          = jmc$output_destination_usage =
            clp$validate_name (job_submission_options_p^ [option_index].output_destination_usage, scl_name,
                  valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_submission_options_p^ [option_index].output_destination_usage, status);
              RETURN;
            IFEND;
            system_label.job_attributes.output_destination_usage := scl_name;

          = jmc$output_disposition =
            system_label.job_attributes.output_disposition_key :=
                  job_submission_options_p^ [option_index].output_disposition.key;
            IF system_label.job_attributes.output_disposition_key = jmc$standard_output_path THEN
              system_label.job_attributes.output_disposition_path :=
                    job_submission_options_p^ [option_index].output_disposition.standard_output_path^;
              clp$convert_string_to_file_ref (job_submission_options_p^ [option_index].output_disposition.
                    standard_output_path^, parsed_file_reference, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              IF parsed_file_reference.path (parsed_file_reference.first_name.index,
                    parsed_file_reference.first_name.size) = '$LOCAL' THEN
                osp$set_status_condition (jme$permanent_file_required, status);
                RETURN;
              IFEND;
              system_label.job_attributes.output_disposition_path := parsed_file_reference.
                    path (1, parsed_file_reference.complete_path_size);
            IFEND;

          = jmc$purge_delay =
            system_label.job_attributes.purge_delay := job_submission_options_p^ [option_index].purge_delay^;

          = jmc$remote_host_directive =
            system_label.job_attributes.remote_host_directive :=
                  job_submission_options_p^ [option_index].remote_host_directive^;
            remote_host_directive_inherited := FALSE;

          = jmc$routing_banner =
            system_label.job_attributes.routing_banner := job_submission_options_p^ [option_index].
                  routing_banner;

          = jmc$station =
            clp$validate_name (job_submission_options_p^ [option_index].station, scl_name, valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_submission_options_p^ [option_index].station, status);
              RETURN;
            IFEND;
            system_label.job_attributes.station := scl_name;

          = jmc$station_operator =
            clp$validate_name (job_submission_options_p^ [option_index].station_operator, scl_name,
                  valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_submission_options_p^ [option_index].station_operator, status);
              RETURN;
            IFEND;
            system_label.job_attributes.station_operator := scl_name;

          = jmc$user_information =
            system_label.job_attributes.user_information := job_submission_options_p^ [option_index].
                  user_information^;

          = jmc$vertical_print_density =
            system_label.job_attributes.vertical_print_density :=
                  job_submission_options_p^ [option_index].vertical_print_density;

          = jmc$vfu_load_procedure =
            clp$validate_name (job_submission_options_p^ [option_index].vfu_load_procedure, scl_name,
                  valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_submission_options_p^ [option_index].vfu_load_procedure, status);
              RETURN;
            IFEND;
            system_label.job_attributes.vfu_load_procedure := scl_name;

{ The following submission options require special privilege to specify them


          = jmc$control_family =

{ If the caller is not privileged abort the task by forcing an access violation.

            IF NOT privileged_job THEN
              osp$force_access_violation;
            IFEND;
            clp$validate_name (job_submission_options_p^ [option_index].control_family, scl_name, valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_submission_options_p^ [option_index].control_family, status);
              RETURN;
            IFEND;
            system_label.job_attributes.job_controller.family := scl_name;

          = jmc$control_user =

{ If the caller is not privileged abort the task by forcing an access violation.

            IF NOT privileged_job THEN
              osp$force_access_violation;
            IFEND;
            clp$validate_name (job_submission_options_p^ [option_index].control_user, scl_name, valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_submission_options_p^ [option_index].control_user, status);
              RETURN;
            IFEND;
            system_label.job_attributes.job_controller.user := scl_name;

          = jmc$data_mode =

{ If the caller is not privileged abort the task by forcing an access violation.

            IF NOT privileged_job THEN
              osp$force_access_violation;
            IFEND;
            system_label.data_mode := job_submission_options_p^ [option_index].data_mode;

          = jmc$data_declaration =

{ If the caller is not privileged abort the task by forcing an access violation.

            IF NOT privileged_job THEN
              osp$force_access_violation;
            IFEND;
            system_label.data_declaration := job_submission_options_p^ [option_index].data_declaration;

          = jmc$disposition_code =

{ If the caller is not privileged abort the task by forcing an access violation.

            IF NOT privileged_job THEN
              osp$force_access_violation;
            IFEND;
            system_label.disposition_code := job_submission_options_p^ [option_index].disposition_code;

          = jmc$immediate_init_candidate =

{ If the caller is not privileged abort the task by forcing an access violation.

            IF NOT privileged_job THEN
              osp$force_access_violation;
            IFEND;
            immediate_initiation_candidate := job_submission_options_p^ [option_index].
                  immediate_init_candidate;

          = jmc$implicit_routing_text =

{ If the caller is not privileged abort the task by forcing an access violation.

            IF NOT privileged_job THEN
              osp$force_access_violation;
            IFEND;
            system_label.job_attributes.implicit_routing_text :=
                  job_submission_options_p^ [option_index].implicit_routing_text^;

          = jmc$job_input_device =

{ If the caller is not privileged abort the task by forcing an access violation.

            IF NOT privileged_job THEN
              osp$force_access_violation;
            IFEND;
            system_label.job_attributes.job_input_device := job_submission_options_p^ [option_index].
                  job_input_device^;

          = jmc$site_information =

{ If the caller is not privileged abort the task by forcing an access violation.

            IF NOT privileged_job THEN
              osp$force_access_violation;
            IFEND;
            system_label.job_attributes.site_information := job_submission_options_p^ [option_index].
                  site_information^;

          = jmc$source_logical_id =

{ If the caller is not privileged abort the task by forcing an access violation.

            IF NOT privileged_job THEN
              osp$force_access_violation;
            IFEND;
            system_label.job_attributes.source_logical_id := job_submission_options_p^ [option_index].
                  source_logical_id;

          = jmc$system_job_parameters =

{ If the caller is not privileged abort the task by forcing an access violation.

            IF NOT privileged_job THEN
              osp$force_access_violation;
            IFEND;
            system_label.job_attributes.system_job_parameters :=
                  job_submission_options_p^ [option_index].system_job_parameters^;

          = jmc$system_routing_text =

{ If the caller is not privileged abort the task by forcing an access violation.

            IF NOT privileged_job THEN
              osp$force_access_violation;
            IFEND;
            system_label.job_attributes.system_routing_text :=
                  job_submission_options_p^ [option_index].system_routing_text^;

          ELSE
            ; { nothing }
          CASEND;
        FOREND;
      IFEND;


{ Determine earliest and latest initiation times.

      pmp$get_microsecond_clock (current_microsecond_clock, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      pmp$get_compact_date_time (current_date_time, { ignore } status);

      IF system_label.job_attributes.earliest_run_time.specified THEN
        jmp$convert_date_time_dif_to_us (current_date_time,
              system_label.job_attributes.earliest_run_time.date_time, current_microsecond_clock,
              earliest_clock_time_to_initiate);
      ELSE
        earliest_clock_time_to_initiate := jmc$earliest_clock_time;
      IFEND;
      IF system_label.job_attributes.latest_run_time.specified THEN
        jmp$convert_date_time_dif_to_us (current_date_time,
              system_label.job_attributes.latest_run_time.date_time, current_microsecond_clock,
              latest_clock_time_to_initiate);
      ELSE
        latest_clock_time_to_initiate := jmc$latest_clock_time;
      IFEND;

{ Make sure that station_operator and output_destination_family are set

      IF system_label.job_attributes.station_operator = osc$null_name THEN
        system_label.job_attributes.station_operator := system_label.login_user_identification.user;
      IFEND;
      IF system_label.job_attributes.output_destination_family = osc$null_name THEN
        system_label.job_attributes.output_destination_family :=
              system_label.login_user_identification.family;
      IFEND;
      IF system_label.job_attributes.output_destination = osc$null_name THEN
        system_label.job_attributes.output_destination := system_label.login_user_identification.family;
      IFEND;

{ If the job is interactive, override the attributes of earliest_run_time, latest_run_time
{ job_deferred_by_user, and job_destination_usage.

      IF system_label.job_mode <> jmc$batch THEN
        system_label.job_deferred_by_user := FALSE;
        system_label.job_attributes.earliest_run_time.specified := FALSE;
        system_label.job_attributes.latest_run_time.specified := FALSE;
        IF (system_label.job_destination_usage <> jmc$ve_usage) AND
              (system_label.job_destination_usage <> jmc$ve_local_usage) AND
              (system_label.job_destination_usage <> jmc$ve_family_usage) THEN
          system_label.job_destination_usage := jmv$default_job_attributes [jmc$interactive_connected].
                job_destination_usage;
        IFEND;
        IF (system_label.job_attributes.originating_application_name <> osc$timesharing) THEN
          system_label.job_destination_usage := jmc$ve_local_usage;
        IFEND;
        earliest_clock_time_to_initiate := jmc$earliest_clock_time;
        latest_clock_time_to_initiate := jmc$latest_clock_time;
      IFEND;

{ If the usage is NTF the control_family and control_user are re-assigned.

      IF system_label.job_destination_usage = jmc$ntf_usage THEN
        system_label.job_attributes.job_controller.family :=
              system_label.job_attributes.output_destination_family;
        system_label.job_attributes.job_controller.user := system_label.job_attributes.station_operator;
      IFEND;

    PROCEND determine_job_attributes;

?? OLDTITLE ??
?? NEWTITLE := 'determine_job_destination', EJECT ??

{ PURPOSE:
{   The purpose of this request is to check the job_destination_family to see if it is a local family
{   and reset the job_destination_family and job_destination_usage as necessary.
{
{ DESIGN:
{   If the job_destination_usage is supplied with a remote value and the job_destination_family
{   is undefined an error is returned.
{
{   If the login_family is a local family and the job_destination_usage is jmc$ve_qtf_usage the
{   job_destination_usage will be reset to jmc$ve_usage.
{
{   If the login_family is NOT a local family and the job_destination_usage is jmc$ve_qtf_usage
{   the job_destination_usage will be reset to jmc$qtf_usage.
{
{   If the job_destination_family is undefined, it is given a value of the login family.
{
{ NOTES:
{   If a job is destined for a remote system via QTF and the output_disposition is supplied
{ as a permanent file an error is returned by this request.  When QTF supports
{ allowing a permanent file this restriction will be removed.

    PROCEDURE determine_job_destination
      (    login_family_defined: boolean;
           remote_host_directive_inherited: boolean;
       VAR system_label: { input, output } jmt$job_system_label;
       VAR input_file_location: jmt$input_file_location;
       VAR store_and_forward_job: boolean;
       VAR submit_job_to_server: boolean;
       VAR leveled_job: boolean;
       VAR status: ost$status);

      VAR
        leveler_status: jmt$jl_job_leveler_status,
        local_family: boolean,
        login_family_access: dft$family_access,
        operation_information_p: ^sft$audit_information,
        original_job_destination_usage: jmt$destination_usage,
        private_or_shared_family: boolean,
        served_family: boolean,
        server_state: dft$server_state,
        terminal_name: ost$name,
        terminal_name_found: boolean;


?? EJECT ??
      status.normal := TRUE;

      dfp$get_family_access (system_label.login_user_identification.family, local_family, login_family_access,
            server_state, leveler_status);

      IF local_family AND (dfc$remote_file_access IN login_family_access) THEN
        IF server_state <> dfc$active THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$served_family_unavailable,
                system_label.login_user_identification.family, status);
          RETURN;
        IFEND;
      IFEND;
      IF NOT local_family THEN
        login_family_access := $dft$family_access [];
      IFEND;
      private_or_shared_family := local_family AND (login_family_access = $dft$family_access []);
      served_family := ((login_family_access * $dft$family_access
            [dfc$remote_login_access, dfc$job_leveling_access]) <> $dft$family_access []);
      original_job_destination_usage := system_label.job_destination_usage;
      IF system_label.job_destination_usage = jmc$ve_qtf_usage THEN
        IF local_family THEN
          system_label.job_destination_usage := jmc$ve_usage;
        ELSE
          system_label.job_destination_usage := jmc$qtf_usage;
        IFEND;
      IFEND;

      IF system_label.job_destination_usage = jmc$ve_local_usage THEN
        submit_job_to_server := FALSE;
        IF private_or_shared_family THEN
          input_file_location := jmc$ifl_login_family_queue;
        ELSEIF served_family THEN
          input_file_location := jmc$ifl_system_input_queue;
        ELSE
          osp$set_status_abnormal (jmc$job_management_id, pfe$unknown_family,
                system_label.login_user_identification.family, status);
          IF avp$security_option_active (avc$vso_security_audit) THEN
            PUSH operation_information_p;
            operation_information_p^.audited_operation := sfc$ao_val_prevalidate_user;
            operation_information_p^.user_identification.family_name_p :=
                  ^system_label.login_user_identification.family;
            operation_information_p^.user_identification.user_name_p :=
                  ^system_label.login_user_identification.user;
            operation_information_p^.user_identification.account_name_p := ^system_label.login_account;
            operation_information_p^.user_identification.project_name_p := ^system_label.login_project;

            get_terminal_name (system_label, terminal_name_found, terminal_name);
            IF terminal_name_found THEN
              operation_information_p^.user_identification.terminal_name_p := ^terminal_name;
            ELSE
              operation_information_p^.user_identification.terminal_name_p := NIL;
            IFEND;

            sfp$emit_audit_statistic (operation_information_p^, status);
          IFEND;
          RETURN;
        IFEND;

      ELSEIF system_label.job_destination_usage = jmc$ve_family_usage THEN
        IF NOT local_family THEN
          osp$set_status_abnormal (jmc$job_management_id, pfe$unknown_family,
                system_label.login_user_identification.family, status);
          IF avp$security_option_active (avc$vso_security_audit) THEN
            PUSH operation_information_p;
            operation_information_p^.audited_operation := sfc$ao_val_prevalidate_user;
            operation_information_p^.user_identification.family_name_p :=
                  ^system_label.login_user_identification.family;
            operation_information_p^.user_identification.user_name_p :=
                  ^system_label.login_user_identification.user;
            operation_information_p^.user_identification.account_name_p := ^system_label.login_account;
            operation_information_p^.user_identification.project_name_p := ^system_label.login_project;

            get_terminal_name (system_label, terminal_name_found, terminal_name);
            IF terminal_name_found THEN
              operation_information_p^.user_identification.terminal_name_p := ^terminal_name;
            ELSE
              operation_information_p^.user_identification.terminal_name_p := NIL;
            IFEND;

            sfp$emit_audit_statistic (operation_information_p^, status);
          IFEND;
          RETURN;
        IFEND;
        input_file_location := jmc$ifl_login_family_queue;

{ Submit the job to the server only if this is not the job's server.

        submit_job_to_server := NOT private_or_shared_family;
        system_label.job_destination_usage := jmc$ve_local_usage;

      ELSEIF system_label.job_destination_usage = jmc$ve_usage THEN
        IF NOT (private_or_shared_family OR served_family) THEN
          osp$set_status_abnormal (jmc$job_management_id, pfe$unknown_family,
                system_label.login_user_identification.family, status);
          IF avp$security_option_active (avc$vso_security_audit) THEN
            PUSH operation_information_p;
            operation_information_p^.audited_operation := sfc$ao_val_prevalidate_user;
            operation_information_p^.user_identification.family_name_p :=
                  ^system_label.login_user_identification.family;
            operation_information_p^.user_identification.user_name_p :=
                  ^system_label.login_user_identification.user;
            operation_information_p^.user_identification.account_name_p := ^system_label.login_account;
            operation_information_p^.user_identification.project_name_p := ^system_label.login_project;

            get_terminal_name (system_label, terminal_name_found, terminal_name);
            IF terminal_name_found THEN
              operation_information_p^.user_identification.terminal_name_p := ^terminal_name;
            ELSE
              operation_information_p^.user_identification.terminal_name_p := NIL;
            IFEND;

            sfp$emit_audit_statistic (operation_information_p^, status);
          IFEND;
          RETURN;
        IFEND;
        IF served_family AND (NOT (dfc$job_leveling_access IN login_family_access)) THEN
          input_file_location := jmc$ifl_system_input_queue;
        ELSE
          input_file_location := jmc$ifl_login_family_queue;
        IFEND;
        submit_job_to_server := (dfc$job_leveling_access IN login_family_access);

      ELSE { QTF and others
        input_file_location := jmc$ifl_store_and_forward_queue;
        submit_job_to_server := FALSE;
      IFEND;

      store_and_forward_job := (input_file_location = jmc$ifl_store_and_forward_queue);
      leveled_job := (system_label.job_destination_usage = jmc$ve_usage) AND (NOT served_family);

{ If the job_destination_family is unassigned give it the login family as a value.

      IF system_label.job_destination_family = osc$null_name THEN
        IF store_and_forward_job AND (original_job_destination_usage <> jmc$ve_qtf_usage) THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$parameter_required_when, 'JOB_DESTINATION',
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'JOB_DESTINATION_USAGE', status);
          RETURN;
        IFEND;
        system_label.job_destination_family := system_label.login_user_identification.family;
      IFEND;

      IF store_and_forward_job AND (NOT login_family_defined) THEN
        system_label.login_user_identification.family := osc$null_name;
      IFEND;

      IF (system_label.job_destination_usage = jmc$qtf_usage) AND
            (system_label.job_attributes.output_disposition_key = jmc$standard_output_path) THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter_value, '<file value>', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'OUTPUT_DISPOSITION', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'SUBMIT_JOB', status);
      IFEND;

      IF store_and_forward_job AND remote_host_directive_inherited THEN
        system_label.job_attributes.remote_host_directive.size := 0;
        system_label.job_attributes.remote_host_directive.parameters := '';
      IFEND;
    PROCEND determine_job_destination;
?? OLDTITLE ??
?? NEWTITLE := '    determine_login_defaults', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to traverse the submission options array and override any login
{ related default attributes.  This procedure also attempts to validate that the user is only using
{ supported submission options.
{
{ DESIGN:
{   In validating the submission options only the key selectors are validated.  Should the users
{ submission options be subject to change by some user process (such as an asynchronous task) the
{ only impact that it can have is for options to be ignored later.  The major reason for even
{ checking this is an attempt to provide callers with an appropriate diagnostic if possible.
{ Validation for values of specific submission options is done when each option is being used.
{ Any time that an attribute is added it must be added to the set or to the case statement.
{ It should only be added to the case statement if it is a login default.

    PROCEDURE determine_login_defaults
      (    job_submission_options_p: ^jmt$job_submission_options;
           privileged_job: boolean;
       VAR system_label: jmt$job_system_label;
       VAR explicit_login_command_p: ^string ( * );
       VAR status: ost$status);

      VAR
        candidate_system_job_name: jmt$name,
        option_index: ost$positive_integers,
        scl_name: ost$name,
        valid_name: boolean,
        valid_system_job_name: jmt$name;

      status.normal := TRUE;
      explicit_login_command_p := NIL;

      IF job_submission_options_p <> NIL THEN

      /assign_and_validate/
        FOR option_index := 1 TO UPPERBOUND (job_submission_options_p^) DO
          IF NOT (job_submission_options_p^ [option_index].key IN $jmt$attribute_keys_set [

          jmc$comment_banner, jmc$copies, jmc$cpu_time_limit, jmc$device, jmc$earliest_print_time,
                jmc$earliest_run_time, jmc$encrypted_password, jmc$external_characteristics, jmc$forms_code,
                jmc$inherit_job_attributes, jmc$job_abort_disposition, jmc$job_class,
                jmc$job_deferred_by_operator, jmc$job_deferred_by_user, jmc$job_destination_family,
                jmc$job_destination_usage, jmc$job_execution_ring, jmc$job_priority, jmc$job_qualifier_list,
                jmc$job_recovery_disposition, jmc$latest_print_time, jmc$latest_run_time, jmc$login_account,
                jmc$login_family, jmc$login_password, jmc$login_project, jmc$login_user,
                jmc$magnetic_tape_limit, jmc$maximum_working_set, jmc$null_attribute,
                jmc$output_deferred_by_user, jmc$output_destination, jmc$output_destination_family,
                jmc$output_destination_usage, jmc$output_disposition, jmc$purge_delay,
                jmc$remote_host_directive, jmc$routing_banner, jmc$sru_limit, jmc$station,
                jmc$station_operator, jmc$user_information, jmc$user_job_name, jmc$vertical_print_density,
                jmc$vfu_load_procedure, jmc$control_family, jmc$control_user, jmc$data_declaration,
                jmc$data_mode, jmc$disposition_code, jmc$immediate_init_candidate, jmc$implicit_routing_text,
                jmc$job_input_device, jmc$optional_user_capability, jmc$required_user_capability,
                jmc$site_information, jmc$source_logical_id, jmc$system_job_parameters,
                jmc$system_routing_text]) THEN

            CASE job_submission_options_p^ [option_index].key OF
            = jmc$default_login_account =
              clp$validate_name (job_submission_options_p^ [option_index].default_login_account, scl_name,
                    valid_name);
              IF NOT valid_name THEN
                osp$set_status_abnormal ('CL', cle$improper_name,
                      job_submission_options_p^ [option_index].default_login_account, status);
                EXIT /assign_and_validate/;
              IFEND;
              system_label.login_account := scl_name;

            = jmc$default_login_family =
              clp$validate_name (job_submission_options_p^ [option_index].default_login_family, scl_name,
                    valid_name);
              IF NOT valid_name THEN
                osp$set_status_abnormal ('CL', cle$improper_name,
                      job_submission_options_p^ [option_index].default_login_family, status);
                EXIT /assign_and_validate/;
              IFEND;
              system_label.login_user_identification.family := scl_name;

            = jmc$default_login_project =
              clp$validate_name (job_submission_options_p^ [option_index].default_login_project, scl_name,
                    valid_name);
              IF NOT valid_name THEN
                osp$set_status_abnormal ('CL', cle$improper_name,
                      job_submission_options_p^ [option_index].default_login_project, status);
                EXIT /assign_and_validate/;
              IFEND;
              system_label.login_project := scl_name;

            = jmc$default_login_user =
              clp$validate_name (job_submission_options_p^ [option_index].default_login_user, scl_name,
                    valid_name);
              IF NOT valid_name THEN
                osp$set_status_abnormal ('CL', cle$improper_name,
                      job_submission_options_p^ [option_index].default_login_user, status);
                EXIT /assign_and_validate/;
              IFEND;
              system_label.login_user_identification.user := scl_name;

{ The following require special privilege

            = jmc$login_command =

{ If the caller is not privileged abort the task by forcing an access violation.

              IF NOT privileged_job THEN
                osp$force_access_violation;
              IFEND;

{ The caller has specified an explict login command.  Save a pointer to it so we can build a
{ parameter list and process the login after other default attributes are set.

              explicit_login_command_p := job_submission_options_p^ [option_index].login_command;

            = jmc$login_command_supplied =

{ If the caller is not privileged abort the task by forcing an access violation.

              IF NOT privileged_job THEN
                osp$force_access_violation;
              IFEND;
              system_label.job_attributes.login_command_supplied :=
                    job_submission_options_p^ [option_index].login_command_supplied;

            = jmc$omit_class_validation =

{ If the caller is not privileged abort the task by forcing an access violation.

              IF NOT privileged_job THEN
                osp$force_access_violation;
              IFEND;
              system_label.perform_class_validation := NOT job_submission_options_p^ [option_index].
                    omit_class_validation;

            = jmc$omit_user_prolog_and_epilog =

{ If the caller is not privileged abort the task by forcing an access violation.

              IF NOT privileged_job THEN
                osp$force_access_violation;
              IFEND;
              system_label.job_attributes.process_user_prolog_and_epilog :=
                    NOT job_submission_options_p^ [option_index].omit_user_prolog_and_epilog;

            = jmc$origin_application_name =

{ If the caller is not privileged abort the task by forcing an access violation.

              IF NOT privileged_job THEN
                osp$force_access_violation;
              IFEND;
              clp$validate_name (job_submission_options_p^ [option_index].origin_application_name, scl_name,
                    valid_name);
              IF NOT valid_name THEN
                osp$set_status_abnormal ('CL', cle$improper_name,
                      job_submission_options_p^ [option_index].origin_application_name, status);
                EXIT /assign_and_validate/;
              IFEND;
              system_label.job_attributes.originating_application_name := scl_name;

            = jmc$system_job_name =

{ If the caller is not privileged abort the task by forcing an access violation.

              IF NOT privileged_job THEN
                osp$force_access_violation;
              IFEND;

{ Specifying a blank system supplied name forces a NEW system supplied name to be assigned to a file.
{ This allows an application to "Loopback" on the same mainframe.

              IF job_submission_options_p^ [option_index].system_job_name <>
                    jmc$blank_system_supplied_name THEN
                candidate_system_job_name.kind := jmc$system_supplied_name;
                candidate_system_job_name.system_supplied_name :=
                      job_submission_options_p^ [option_index].system_job_name;
                jmp$validate_name (candidate_system_job_name, valid_system_job_name, status);
                IF NOT status.normal THEN
                  EXIT /assign_and_validate/;
                IFEND;
                system_label.system_job_name := valid_system_job_name.system_supplied_name;
              ELSE
                system_label.system_job_name := jmc$blank_system_supplied_name;
              IFEND;

            ELSE
              jmp$get_attribute_name (job_submission_options_p^ [option_index].key, scl_name);
              osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, 'JOB_SUBMISSION_OPTIONS', status);
              osp$append_status_parameter (osc$status_parameter_delimiter, jmc$submit_job, status);
              EXIT /assign_and_validate/;
            CASEND;
          IFEND;
        FOREND /assign_and_validate/;
      IFEND;
    PROCEND determine_login_defaults;

?? OLDTITLE ??
?? NEWTITLE := '    determine_login_elements', EJECT ??

{ PURPOSE:
{   The purpose of this request is to "crack" the login command supplied with the job and then pass through
{ the submission options to determine any additional login related attributes.

    PROCEDURE determine_login_elements
      (    file_reference: fst$file_reference;
           caller_ring: ost$valid_ring;
           user_identification: ost$user_identification;
           job_submission_options_p: ^jmt$job_submission_options;
           privileged_job: boolean;
           explicit_login_command_p: ^string ( * );
           job_label_exists: boolean;
       VAR encrypted_password_supplied: boolean;
       VAR login_family_defined: boolean;
       VAR inherit_job_attributes: boolean;
       VAR system_label: jmt$job_system_label;
       VAR status: ost$status);

      VAR
        candidate_usn: jmt$name,
        ignore_status: ost$status,
        job_qualifier_index: 1 .. jmc$maximum_job_qualifiers,
        login_command_in_file: boolean,
        option_index: ost$positive_integers,
        parameter_list_seq_p: ^clt$parameter_list,
        parameter_list_size_p: ^clt$command_line_size,
        parameter_list_text_p: ^string ( * ),
        scl_name: ost$name,
        valid_name: boolean,
        valid_usn: jmt$name;

      status.normal := TRUE;
      ignore_status.normal := TRUE;
      encrypted_password_supplied := FALSE;
      inherit_job_attributes := TRUE;

{ Change the job mode if necessary

      IF (system_label.job_attributes.originating_application_name = osc$dual_state_interactive) OR
            (system_label.job_attributes.originating_application_name = osc$timesharing) OR
            (system_label.job_attributes.originating_application_name = osc$xterm_application_name) THEN
        system_label.job_mode := jmc$interactive_connected;
      IFEND;

{ Set LOGIN values that are dependent on the job mode.

      IF NOT job_label_exists THEN
        system_label.job_abort_disposition := jmv$default_job_attributes [system_label.job_mode].
              job_abort_disposition;
        system_label.job_destination_usage := jmv$default_job_attributes [system_label.job_mode].
              job_destination_usage;
        system_label.job_recovery_disposition := jmv$default_job_attributes [system_label.job_mode].
              job_recovery_disposition;
        system_label.job_attributes.job_qualifier_list := jmv$default_job_attributes [system_label.job_mode].
              job_qualifier_list;
      IFEND;
      system_label.job_deferred_by_operator := jmv$default_job_attributes [system_label.job_mode].
            job_deferred_by_operator;

{ Test for valid use of $NULL as the file name

      IF (file_reference = ':$LOCAL.$NULL.1') AND ((system_label.job_mode <> jmc$interactive_connected) OR
            system_label.job_attributes.login_command_supplied) THEN
        osp$set_status_condition (jme$cant_use_$null, status);
        RETURN;
      IFEND;

{ Crack the login statement in the command file.  If the command file has the login command of another
{ type of system this request will return a status that indicates that the login command in the command
{ file is invalid.  If there is a login command it MUST be valid.

      IF system_label.job_attributes.login_command_supplied AND (NOT job_label_exists) THEN
        clp$get_job_parameters (caller_ring, file_reference, system_label, login_command_in_file, status);
        IF NOT status.normal THEN
          IF login_command_in_file THEN
            RETURN;
          ELSE
            status.normal := TRUE;
          IFEND;
        IFEND;
      IFEND;

{ Crack the user supplied login command if there is one.  The login command must be converted to a
{ parameter_list and then cracked as the parameters of a login command.

      IF explicit_login_command_p <> NIL THEN
        PUSH parameter_list_seq_p: [[REP (STRLENGTH (explicit_login_command_p^) +
              #SIZE (clt$command_line_size)) OF cell]];
        RESET parameter_list_seq_p;
        NEXT parameter_list_size_p IN parameter_list_seq_p;
        parameter_list_size_p^ := STRLENGTH (explicit_login_command_p^);
        NEXT parameter_list_text_p: [parameter_list_size_p^] IN parameter_list_seq_p;
        parameter_list_text_p^ := explicit_login_command_p^;

        clp$push_sub_parameters_block ({ lookup_functions_and_variables } FALSE);
        clp$get_login_parameters (parameter_list_seq_p^, system_label, status);
        clp$pop_parameters (ignore_status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

{ Make a pass through submission options to determine specified parameters.

      IF job_submission_options_p <> NIL THEN

      /assign_login_elements/
        FOR option_index := 1 TO UPPERBOUND (job_submission_options_p^) DO
          CASE job_submission_options_p^ [option_index].key OF
          = jmc$cpu_time_limit =
            system_label.limit_information.cpu_time_limit_specified := TRUE;
            system_label.limit_information.cpu_time_limit_requested :=
                  job_submission_options_p^ [option_index].cpu_time_limit;

          = jmc$job_class =
            clp$validate_name (job_submission_options_p^ [option_index].job_class, scl_name, valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_submission_options_p^ [option_index].job_class, status);
              RETURN;
            IFEND;
            system_label.job_class_name := scl_name;

          = jmc$job_deferred_by_user =
            system_label.job_deferred_by_user := job_submission_options_p^ [option_index].
                  job_deferred_by_user;

          = jmc$job_destination_family =
            clp$validate_name (job_submission_options_p^ [option_index].job_destination_family, scl_name,
                  valid_name);
            IF valid_name THEN
              system_label.job_destination_family := scl_name;
            ELSE { The value must be a string.
              #TRANSLATE (osv$lower_to_upper, job_submission_options_p^ [option_index].job_destination_family,
                    system_label.job_destination_family);
            IFEND;

          = jmc$job_destination_usage =
            clp$validate_name (job_submission_options_p^ [option_index].job_destination_usage, scl_name,
                  valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_submission_options_p^ [option_index].job_destination_usage, status);
              RETURN;
            IFEND;
            system_label.job_destination_usage := scl_name;

          = jmc$job_execution_ring =
            system_label.job_execution_ring := job_submission_options_p^ [option_index].job_execution_ring;

          = jmc$job_qualifier_list =
            FOR job_qualifier_index := 1 TO jmc$maximum_job_qualifiers DO
              IF (job_submission_options_p^ [option_index].job_qualifier_list <> NIL) AND
                    (UPPERBOUND (job_submission_options_p^ [option_index].job_qualifier_list^) >=
                    job_qualifier_index) THEN
                IF job_submission_options_p^ [option_index].job_qualifier_list^ [job_qualifier_index] =
                      osc$null_name THEN
                  scl_name := osc$null_name;
                ELSE
                  clp$validate_name (job_submission_options_p^ [option_index].
                        job_qualifier_list^ [job_qualifier_index], scl_name, valid_name);
                  IF NOT valid_name THEN
                    osp$set_status_abnormal ('CL', cle$improper_name,
                          job_submission_options_p^ [option_index].job_qualifier_list^ [job_qualifier_index],
                          status);
                    RETURN;
                  IFEND;
                IFEND;
                system_label.job_attributes.job_qualifier_list [job_qualifier_index] := scl_name;
              ELSE
                system_label.job_attributes.job_qualifier_list [job_qualifier_index] := osc$null_name;
              IFEND;
            FOREND;

          = jmc$login_account =
            clp$validate_name (job_submission_options_p^ [option_index].login_account, scl_name, valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_submission_options_p^ [option_index].login_account, status);
              RETURN;
            IFEND;
            system_label.login_account := scl_name;

          = jmc$login_family =
            clp$validate_name (job_submission_options_p^ [option_index].login_family, scl_name, valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_submission_options_p^ [option_index].login_family, status);
              RETURN;
            IFEND;
            system_label.login_user_identification.family := scl_name;

          = jmc$login_password =
            clp$validate_name (job_submission_options_p^ [option_index].login_password, scl_name, valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_submission_options_p^ [option_index].login_password, status);
              RETURN;
            IFEND;
            system_label.login_password := scl_name;

          = jmc$login_project =
            clp$validate_name (job_submission_options_p^ [option_index].login_project, scl_name, valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_submission_options_p^ [option_index].login_project, status);
              RETURN;
            IFEND;
            system_label.login_project := scl_name;

          = jmc$login_user =
            clp$validate_name (job_submission_options_p^ [option_index].login_user, scl_name, valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_submission_options_p^ [option_index].login_user, status);
              RETURN;
            IFEND;
            system_label.login_user_identification.user := scl_name;

          = jmc$magnetic_tape_limit =
            system_label.limit_information.magnetic_tape_limit_specified := TRUE;
            system_label.limit_information.magnetic_tape_limit_requested :=
                  job_submission_options_p^ [option_index].magnetic_tape_limit;

          = jmc$maximum_working_set =
            system_label.limit_information.maximum_working_set_specified := TRUE;
            system_label.limit_information.maximum_working_set_requested :=
                  job_submission_options_p^ [option_index].maximum_working_set;

          = jmc$sru_limit =
            system_label.limit_information.sru_limit_specified := TRUE;
            system_label.limit_information.sru_limit_requested :=
                  job_submission_options_p^ [option_index].sru_limit;

          = jmc$user_job_name =
            candidate_usn.kind := jmc$user_supplied_name;
            candidate_usn.user_supplied_name := job_submission_options_p^ [option_index].user_job_name;
            jmp$validate_name (candidate_usn, valid_usn, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            system_label.user_job_name := valid_usn.user_supplied_name;

{ The following require special privilege

          = jmc$job_deferred_by_operator =

{ If the caller is not privileged abort the task by forcing an access violation.

            IF NOT privileged_job THEN
              osp$force_access_violation;
            IFEND;
            system_label.job_deferred_by_operator := job_submission_options_p^ [option_index].
                  job_deferred_by_operator;

          = jmc$encrypted_password =
            IF caller_ring > osc$sj_ring_3 THEN
              osp$force_access_violation;
            IFEND;
            encrypted_password_supplied := TRUE;
            system_label.login_password := job_submission_options_p^ [option_index].encrypted_password;

          = jmc$inherit_job_attributes =
            IF caller_ring > osc$sj_ring_3 THEN
              osp$force_access_violation;
            IFEND;
            inherit_job_attributes := job_submission_options_p^ [option_index].inherit_job_attributes;

          = jmc$required_user_capability =

{ If the caller is not privileged abort the task by forcing an access violation.

            IF NOT privileged_job THEN
              osp$force_access_violation;
            IFEND;
            clp$validate_name (job_submission_options_p^ [option_index].required_user_capability, scl_name,
                  valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('CL', cle$improper_name,
                    job_submission_options_p^ [option_index].required_user_capability, status);
              RETURN;
            IFEND;
            system_label.required_user_capability := scl_name;

          ELSE
            ; { nothing }
          CASEND;
        FOREND /assign_login_elements/;
      IFEND;


{ Assign the correct default login family

      login_family_defined := (system_label.login_user_identification.family <> osc$null_name);

      IF NOT login_family_defined THEN
        IF system_label.job_attributes.originating_application_name = osc$submit_job THEN
          system_label.login_user_identification.family := user_identification.family;
        ELSE
          system_label.login_user_identification.family := jmv$default_job_attributes [system_label.job_mode].
                login_family;
        IFEND;
      IFEND;

{ Check to see if there is a user_job_name

      IF system_label.user_job_name = osc$null_name THEN
        system_label.user_job_name := system_label.login_user_identification.user;
      IFEND;
    PROCEND determine_login_elements;

?? OLDTITLE ??
?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      IF status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;

?? OLDTITLE ??
?? NEWTITLE := '    process_command_file_and_label', EJECT ??

{ PURPOSE:
{   The purpose of this request is to place the command file into the proper input queue and
{ correctly write the job system label to the file.

    PROCEDURE process_command_file_and_label
      (    file_reference: fst$file_reference;
           path_p: ^pft$path;
           command_file_password: pft$password;
           caller_ring: ost$ring;
           job_label_exists: boolean;
           store_and_forward_job: boolean;
       VAR system_label: jmt$job_system_label;
       VAR status: ost$status);

      CONST
        unit_separator = $CHAR (1f(16));

      VAR
        command_file_name: amt$local_file_name,
        contains_data: boolean,
        cycle_selector: pft$cycle_selector,
        file_identifier: amt$file_identifier,
        get_attributes_p: ^amt$get_attributes,
        ignore_status: ost$status,
        input_attachment_options_p: ^fst$attachment_options,
        input_catalog_path_p: ^pft$path,
        input_validation_attributes_p: ^fst$file_cycle_attributes,
        local_file: boolean,
        mandated_creation_attributes: ^fst$file_cycle_attributes,
        null_file_access_procedure: pmt$entry_point_reference,
        old_file: boolean,
        output_attachment_options_p: ^fst$attachment_options,
        system_job_name_assigned: boolean,
        write_label: boolean;

?? NEWTITLE := 'handle_out_of_space', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with the out of space condition.

      PROCEDURE handle_out_of_space
        (    condition: pmt$condition;
             condition_information_p: ^pmt$condition_information;
             sfsa_p: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);

        VAR
          ignore_status: ost$status;

        IF (condition.selector = pmc$user_defined_condition) AND
              (condition.user_condition_name = osc$space_unavailable_condition) THEN
          osp$set_status_condition (jme$no_space_for_file, status);
          amp$return (command_file_name, ignore_status);
          osp$establish_block_exit_hndlr (^handle_block_exit);
          pfp$begin_system_authority;
          pfp$purge (path_p^, cycle_selector, command_file_password, ignore_status);
          pfp$end_system_authority;
          osp$disestablish_cond_handler;
          EXIT process_command_file_and_label;
        ELSEIF condition.selector = pmc$block_exit_processing THEN
          pfp$end_system_authority;
          IF status.normal THEN
            osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
          IFEND;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      PROCEND handle_out_of_space;
?? OLDTITLE ??
?? EJECT ??
      status.normal := TRUE;
      cycle_selector.cycle_option := pfc$specific_cycle;
      cycle_selector.cycle_number := 1;

{ If the system supplied name in the label has a value then one does not need to be assigned.

      system_job_name_assigned := system_label.system_job_name <> '';

{ Force variables used by the out of space condition handler to memory.
{ Establish the condition handler.

      #SPOIL (command_file_name, cycle_selector);

      osp$establish_condition_handler (^handle_out_of_space, {block_exit} TRUE);
      pfp$begin_system_authority;

      REPEAT
        IF NOT system_job_name_assigned THEN
          qfp$assign_system_supplied_name (system_label.system_job_name);
        IFEND;
        command_file_name := system_label.system_job_name;
        path_p^ [4] := command_file_name;
        pfp$define (command_file_name, path_p^, cycle_selector, command_file_password, pfc$maximum_retention,
              pfc$log, status);
        IF NOT status.normal THEN
          IF (status.condition = pfe$unknown_last_subcatalog) OR
                (status.condition = pfe$unknown_nth_subcatalog) THEN
            PUSH input_catalog_path_p: [1 .. 3];
            input_catalog_path_p^ [1] := path_p^ [1];
            input_catalog_path_p^ [2] := path_p^ [2];
            input_catalog_path_p^ [3] := path_p^ [3];
            pfp$define_catalog (input_catalog_path_p^, status);
            IF status.normal THEN
              osp$set_status_condition (pfe$duplicate_cycle, status)
            IFEND;
          ELSEIF (status.condition = pfe$duplicate_cycle) THEN
            system_job_name_assigned := FALSE;
          IFEND;
        IFEND;
      UNTIL (status.normal) OR (status.condition <> pfe$duplicate_cycle);
      pfp$end_system_authority;
      osp$disestablish_cond_handler;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF jmv$job_history_active THEN
        IF (NOT jmp$system_job ()) OR (jmp$system_job () AND
              (system_label.job_mode <> jmc$interactive_connected)) THEN
          jmp$emit_job_history_statistics (jml$submit_job_executed, osc$null_name,
                system_label.system_job_name, jmc$blank_system_supplied_name, ^system_label, NIL,
                osc$null_name, jmc$blank_system_supplied_name, ignore_status);
        IFEND;
      IFEND;


{ Create the file in the input queue.

      IF (file_reference = ':$LOCAL.$NULL.1') THEN
        IF system_label.job_mode = jmc$interactive_connected THEN
          PUSH mandated_creation_attributes: [1 .. 2];
          mandated_creation_attributes^ [1].selector := fsc$file_contents_and_processor;
          mandated_creation_attributes^ [1].file_contents := fsc$legible_data;
          mandated_creation_attributes^ [1].file_processor := fsc$scl;
          mandated_creation_attributes^ [2].selector := fsc$ring_attributes;
          mandated_creation_attributes^ [2].ring_attributes.r1 := osc$tsrv_ring;
          mandated_creation_attributes^ [2].ring_attributes.r2 := osc$tsrv_ring;
          mandated_creation_attributes^ [2].ring_attributes.r3 := osc$tsrv_ring;

{ In order to put ring attributes on the file and force the label to be written it is necessary to
{ open and close the input file.

          fsp$open_file (command_file_name, amc$record, NIL, NIL, mandated_creation_attributes, NIL, NIL,
                file_identifier, status);
          IF NOT status.normal THEN
            fsp$close_file (file_identifier, ignore_status);
            amp$return (command_file_name, ignore_status);
            osp$establish_block_exit_hndlr (^handle_block_exit);
            pfp$begin_system_authority;
            pfp$purge (path_p^, cycle_selector, command_file_password, ignore_status);
            pfp$end_system_authority;
            osp$disestablish_cond_handler;
            RETURN;
          IFEND;

          fsp$close_file (file_identifier, status);
          IF NOT status.normal THEN
            amp$return (command_file_name, ignore_status);
            osp$establish_block_exit_hndlr (^handle_block_exit);
            pfp$begin_system_authority;
            pfp$purge (path_p^, cycle_selector, command_file_password, ignore_status);
            pfp$end_system_authority;
            osp$disestablish_cond_handler;
            RETURN;
          IFEND;
        ELSE

{ Can't get here - this should have been precluded in determine_login_elements

          osp$set_status_condition (jme$cant_use_$null, status);
          amp$return (command_file_name, ignore_status);
          osp$establish_block_exit_hndlr (^handle_block_exit);
          pfp$begin_system_authority;
          pfp$purge (path_p^, cycle_selector, command_file_password, ignore_status);
          pfp$end_system_authority;
          osp$disestablish_cond_handler;
          RETURN;
        IFEND;
      ELSE
        null_file_access_procedure.entry_point := osc$null_name;
        null_file_access_procedure.object_library := '';
        PUSH input_validation_attributes_p: [1 .. 1];
        input_validation_attributes_p^ [1].selector := fsc$file_access_procedure_name;
        input_validation_attributes_p^ [1].file_access_procedure_name := ^null_file_access_procedure;

        PUSH input_attachment_options_p: [1 .. 9];
        input_attachment_options_p^ [1].selector := fsc$access_and_share_modes;
        input_attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;
        input_attachment_options_p^ [1].access_modes.value := $fst$file_access_options [fsc$read];
        input_attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;
        input_attachment_options_p^ [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
        input_attachment_options_p^ [2].selector := fsc$allowed_device_classes;
        input_attachment_options_p^ [2].allowed_device_classes := $fst$device_classes
              [fsc$mass_storage_device];
        input_attachment_options_p^ [3].selector := fsc$create_file;
        input_attachment_options_p^ [3].create_file := FALSE;
        input_attachment_options_p^ [4].selector := fsc$free_behind;
        input_attachment_options_p^ [4].free_behind := TRUE;
        input_attachment_options_p^ [5].selector := fsc$open_position;
        input_attachment_options_p^ [5].open_position := amc$open_at_boi;
        input_attachment_options_p^ [6].selector := fsc$private_read;
        input_attachment_options_p^ [6].private_read := TRUE;
        input_attachment_options_p^ [7].selector := fsc$sequential_access;
        input_attachment_options_p^ [7].sequential_access := TRUE;
        input_attachment_options_p^ [8].selector := fsc$validation_ring;
        input_attachment_options_p^ [8].validation_ring := caller_ring;

{ The access mode of EXECUTE is required to allow jmp$submit_job to copy a file
{ with execute only permission.  This can only be done from ring 3.

        input_attachment_options_p^ [9].selector := fsc$access_and_share_modes;
        input_attachment_options_p^ [9].access_modes.selector := fsc$specific_access_modes;
        input_attachment_options_p^ [9].access_modes.value := $fst$file_access_options [fsc$execute];
        input_attachment_options_p^ [9].share_modes.selector := fsc$specific_share_modes;
        input_attachment_options_p^ [9].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];

        PUSH output_attachment_options_p: [1 .. 2];
        output_attachment_options_p^ [1].selector := fsc$free_behind;
        output_attachment_options_p^ [1].free_behind := TRUE;
        output_attachment_options_p^ [2].selector := fsc$sequential_access;
        output_attachment_options_p^ [2].sequential_access := TRUE;

        IF NOT store_and_forward_job THEN
          PUSH mandated_creation_attributes: [1 .. 5];
          mandated_creation_attributes^ [1].selector := fsc$ring_attributes;
          mandated_creation_attributes^ [1].ring_attributes.r1 := osc$tsrv_ring;
          mandated_creation_attributes^ [1].ring_attributes.r2 := osc$tsrv_ring;
          mandated_creation_attributes^ [1].ring_attributes.r3 := osc$tsrv_ring;
          mandated_creation_attributes^ [2].selector := fsc$file_contents_and_processor;
          mandated_creation_attributes^ [2].file_contents := fsc$legible_data;
          mandated_creation_attributes^ [2].file_processor := fsc$scl;
          mandated_creation_attributes^ [3].selector := fsc$block_type;
          mandated_creation_attributes^ [3].block_type := amc$system_specified;
          mandated_creation_attributes^ [4].selector := fsc$file_organization;
          mandated_creation_attributes^ [4].file_organization := amc$sequential;
          mandated_creation_attributes^ [5].selector := fsc$record_type;
          mandated_creation_attributes^ [5].record_type := amc$variable;

        ELSE
          IF system_label.data_mode = jmc$coded_data THEN
            PUSH mandated_creation_attributes: [1 .. 6];
            mandated_creation_attributes^ [1].selector := fsc$ring_attributes;
            mandated_creation_attributes^ [1].ring_attributes.r1 := osc$tsrv_ring;
            mandated_creation_attributes^ [1].ring_attributes.r2 := osc$tsrv_ring;
            mandated_creation_attributes^ [1].ring_attributes.r3 := osc$tsrv_ring;
            mandated_creation_attributes^ [2].selector := fsc$file_contents_and_processor;
            mandated_creation_attributes^ [2].file_contents := fsc$legible_data;
            mandated_creation_attributes^ [2].file_processor := fsc$scl;
            mandated_creation_attributes^ [3].selector := fsc$block_type;
            mandated_creation_attributes^ [3].block_type := amc$system_specified;
            mandated_creation_attributes^ [4].selector := fsc$file_organization;
            mandated_creation_attributes^ [4].file_organization := amc$sequential;
            mandated_creation_attributes^ [5].selector := fsc$record_type;
            mandated_creation_attributes^ [5].record_type := amc$trailing_char_delimited;
            mandated_creation_attributes^ [6].selector := fsc$record_delimiting_character;
            mandated_creation_attributes^ [6].record_delimiting_character := unit_separator;
          ELSE { data_mode is transparent or rhf_structure
            PUSH mandated_creation_attributes: [1 .. 1];
            mandated_creation_attributes^ [1].selector := fsc$ring_attributes;
            mandated_creation_attributes^ [1].ring_attributes.r1 := osc$tsrv_ring;
            mandated_creation_attributes^ [1].ring_attributes.r2 := osc$tsrv_ring;
            mandated_creation_attributes^ [1].ring_attributes.r3 := osc$tsrv_ring;
          IFEND;
        IFEND;

        osp$establish_condition_handler (^handle_out_of_space, {block_exit} FALSE);
        fsp$subsystem_copy_file (file_reference, command_file_name, input_attachment_options_p,
              output_attachment_options_p, input_validation_attributes_p, {output_attribute_validation} NIL,
              mandated_creation_attributes, status);
        IF NOT status.normal THEN
          amp$return (command_file_name, ignore_status);

{ This overwrites the out of space handler's definition so we don't need to
{ disestablish it.

          osp$establish_block_exit_hndlr (^handle_block_exit);
          pfp$begin_system_authority;
          pfp$purge (path_p^, cycle_selector, command_file_password, ignore_status);
          pfp$end_system_authority;
          osp$disestablish_cond_handler;
          RETURN;
        IFEND;
        osp$disestablish_cond_handler;

      IFEND;

{ Establish the size of the command file

      IF system_label.job_mode <> jmc$interactive_connected THEN
        PUSH get_attributes_p: [1 .. 1];
        get_attributes_p^ [1].key := amc$file_length;
        amp$get_file_attributes (command_file_name, get_attributes_p^, local_file, old_file, contains_data,
              status);
        IF NOT status.normal THEN
          amp$return (command_file_name, ignore_status);
          osp$establish_block_exit_hndlr (^handle_block_exit);
          pfp$begin_system_authority;
          pfp$purge (path_p^, cycle_selector, command_file_password, ignore_status);
          pfp$end_system_authority;
          osp$disestablish_cond_handler;
          RETURN;
        IFEND;
        system_label.job_attributes.job_size := get_attributes_p^ [1].file_length;
      ELSE
        system_label.job_attributes.job_size := 0;
      IFEND;

{ Since the file already exists in the input queue the label must be written immediately.

      write_label := TRUE;
      qfp$write_job_system_label (command_file_name, write_label, system_label, status);
      IF NOT status.normal THEN
        amp$return (command_file_name, ignore_status);
        osp$establish_block_exit_hndlr (^handle_block_exit);
        pfp$begin_system_authority;
        pfp$purge (path_p^, cycle_selector, command_file_password, ignore_status);
        pfp$end_system_authority;
        osp$disestablish_cond_handler;
        RETURN;
      IFEND;

      amp$return (command_file_name, status);
      IF NOT status.normal THEN
        osp$establish_block_exit_hndlr (^handle_block_exit);
        pfp$begin_system_authority;
        pfp$purge (path_p^, cycle_selector, command_file_password, ignore_status);
        pfp$end_system_authority;
        osp$disestablish_cond_handler;
      IFEND;
    PROCEND process_command_file_and_label;
?? OLDTITLE ??
?? EJECT ??
?? NEWTITLE := 'switch_remote_connection', EJECT ??

    PROCEDURE switch_remote_connection
      (    job_name: jmt$system_supplied_name;
           destination_mainframe_id: pmt$mainframe_id;
           encrypted_password: ost$name;
       VAR status: ost$status);

      VAR
        leveled_job_connect_data_p: ^jmt$leveled_job_connect_data,
        program_attributes: ^pmt$program_attributes,
        program_description: ^pmt$program_description,
        program_parameters: ^pmt$program_parameters,
        size_of_parameters: ost$non_negative_integers,
        system_job_name_p: ^jmt$system_supplied_name,
        task_id: pmt$task_id;


      status.normal := TRUE;

      PUSH program_description: [[REP 1 OF pmt$program_attributes]];
      RESET program_description;
      NEXT program_attributes IN program_description;
      program_attributes^.contents := $pmt$prog_description_contents
            [pmc$starting_proc_specified, pmc$load_map_file_specified, pmc$load_map_options_specified,
            pmc$term_error_level_specified, pmc$abort_file_specified, pmc$debug_mode_specified];
      program_attributes^.starting_procedure := 'JMP$SWITCH_REMOTE_CONNECTION';
      program_attributes^.load_map_file := clv$standard_files [clc$sf_null_file].path_handle_name;
      program_attributes^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
      program_attributes^.termination_error_level := pmc$warning_load_errors;
      program_attributes^.abort_file := clv$standard_files [clc$sf_null_file].path_handle_name;
      program_attributes^.debug_mode := FALSE;

      PUSH program_parameters: [[REP 1 OF jmt$leveled_job_connect_data]];
      RESET program_parameters;
      NEXT leveled_job_connect_data_p IN program_parameters;
      leveled_job_connect_data_p^.system_job_name := job_name;
      leveled_job_connect_data_p^.destination_mainframe_id := destination_mainframe_id;
      leveled_job_connect_data_p^.encrypted_password := encrypted_password;

      IF task_status_p = NIL THEN
        ALLOCATE task_status_p IN osv$task_private_heap^;
      IFEND;
      pmp$execute (program_description^, program_parameters^, osc$nowait, task_id, task_status_p^, status);

    PROCEND switch_remote_connection;

?? OLDTITLE, EJECT ??
    #CALLER_ID (caller_identification);
    #KEYPOINT (osk$entry, 0, jmk$submit_job);
    status.normal := TRUE;
    ignore_status.normal := TRUE;
    pmp$get_mainframe_id (current_mainframe_id, ignore_status);

{ Does the caller deserve special privileges?

    privileged_job := osp$is_caller_system_privileged () OR (caller_identification.ring <= osc$sj_ring_3) OR
          jmv$enable_queue_file_access OR jmp$system_job ();

    IF syp$system_is_idling () THEN
      osp$set_status_condition (jme$maximum_jobs, status);
      #KEYPOINT (osk$exit, 0, jmk$submit_job);
      RETURN;
    IFEND;

    clp$evaluate_file_reference (file_reference, $clt$file_ref_parsing_options [],
          {resolve_cycle_number} FALSE, evaluated_file_reference, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$submit_job);
      RETURN;
    IFEND;

{ The following special code allows submit_job of $local.command.

    IF evaluated_file_reference.path_handle_info.path_handle_present AND
          (evaluated_file_reference.path_handle_info.path_handle.segment_offset =
          clv$standard_files [clc$sf_command_file].path_handle.segment_offset) AND
          (evaluated_file_reference.path_handle_info.path_handle.assignment_counter =
          clv$standard_files [clc$sf_command_file].path_handle.assignment_counter) THEN
      file_path := clv$standard_files [clc$sf_command_file].path_handle_name;
      file_path_size := osc$max_name_size;
      submit_of_command_file := TRUE;
    ELSE
      submit_of_command_file := FALSE;
      clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} FALSE, file_path,
            file_path_size, status);
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, jmk$submit_job);
        RETURN;
      IFEND;
    IFEND;

    pmp$get_user_identification (user_identification, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$submit_job);
      RETURN;
    IFEND;

{ Find out what kind of submit job is taking place.

    determine_if_job_label_exists (file_path (1, file_path_size), system_label, job_label_exists, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$submit_job);
      RETURN;
    IFEND;

{ If there is not a label then some label attributes must be pre-initialized.

    IF NOT job_label_exists THEN
      assign_default_label_values (user_identification, system_label, status);
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, jmk$submit_job);
        RETURN;
      IFEND;
    ELSE

{ The System_Job_Name in the job label must be zeroed out in order to submit
{ the command file as a job.  If this is not done, an attempt will be made to
{ assign the same name to the job.
{ When loopback of QTF support is added, this code can probably be removed.

      IF submit_of_command_file THEN
        system_label.system_job_name := jmc$blank_system_supplied_name;
      IFEND;
    IFEND;

{ Get any login defaults specified in the submission options.  This process also verifies that
{ only supported submission options are being specified.

    determine_login_defaults (job_submission_options, privileged_job, system_label, explicit_login_command_p,
          status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$submit_job);
      RETURN;
    IFEND;

    determine_login_elements (file_path (1, file_path_size), caller_identification.ring, user_identification,
          job_submission_options, privileged_job, explicit_login_command_p, job_label_exists,
          encrypted_password_supplied, login_family_defined, inherit_job_attributes, system_label, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$submit_job);
      RETURN;
    IFEND;

    IF NOT job_label_exists THEN
      assign_default_attributes (user_identification, inherit_job_attributes, system_label, status);
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, jmk$submit_job);
        RETURN;
      IFEND;
    IFEND;

    determine_job_attributes (job_submission_options, privileged_job, system_label,
          immediate_initiation_candidate, current_date_time, current_microsecond_clock,
          earliest_clock_time_to_initiate, latest_clock_time_to_initiate, remote_host_directive_inherited,
          status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$submit_job);
      RETURN;
    IFEND;

{ If the originating_application_name is PTF/QTF/NTF/BTF/REXEC/NQS, and the user and
{ family are $system, do not allow the job to continue.

    IF (system_label.login_user_identification.user = '$SYSTEM                        ') AND
       (system_label.login_user_identification.family = '$SYSTEM                        ') AND
       (system_label.job_attributes.originating_application_name <> osc$deadstart) AND
       (system_label.job_attributes.originating_application_name <> osc$submit_job) THEN
      osp$set_status_abnormal (jmc$job_management_id, ave$bad_user_validation_info,
            ' ', status);
      RETURN;
    IFEND;

    IF job_label_exists THEN

{ Calculate the value for the job's job submission time clock value.

      jmp$convert_date_time_dif_to_us (current_date_time, system_label.job_attributes.job_submission_time,
            current_microsecond_clock, job_submission_time);

    ELSE
      job_submission_time := current_microsecond_clock;
    IFEND;
    determine_job_destination (login_family_defined, remote_host_directive_inherited, system_label,
          input_file_location, store_and_forward_job, submit_job_to_server, leveled_job, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$submit_job);
      RETURN;
    IFEND;

  /determine_job_class/
    WHILE TRUE DO
      WHILE jmv$sched_profile_is_loading DO
        pmp$wait (500, 500);
      WHILEND;

      system_label.active_profile_version := jmv$job_scheduler_table.profile_identification;
      IF (system_label.job_class_name <> osc$null_name) AND
            (system_label.job_class_name <> jmc$automatic_class_name) AND
            (system_label.job_class_name <> jmc$system_default_class_name) THEN
        jmp$expand_job_class_abbrev (system_label.job_class_name, ignore_status);
      IFEND;

      IF NOT store_and_forward_job THEN

{ Convert the user's requested limit information to preliminary assigned limits.

        convert_limit_information (system_label, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        prevalidate_job (user_identification, {password_encrypted} encrypted_password_supplied OR
              (submit_of_command_file AND (system_label.job_mode = jmc$batch)), system_label,
              assigned_job_class, encrypted_password, status);
        IF NOT status.normal THEN
          qfp$check_for_profile_mismatch (system_label.active_profile_version, profile_mismatch);
          IF profile_mismatch OR jmv$sched_profile_is_loading THEN
            CYCLE /determine_job_class/;
          IFEND;
          #KEYPOINT (osk$exit, 0, jmk$submit_job);
          RETURN;
        IFEND;

        IF jmv$job_class_table_p^ [assigned_job_class].defer_on_submit THEN
          system_label.job_deferred_by_operator := TRUE;
        IFEND;

      ELSE
        assigned_job_class := jmc$null_job_class;
      IFEND;

{ Determine the path elements for the job's command file.

      determine_file_path (input_file_location, system_label.login_user_identification.family,
            system_label.system_job_name, command_file_path_p);
      command_file_password := osc$null_name;
      cycle_selector.cycle_option := pfc$specific_cycle;
      cycle_selector.cycle_number := 1;

      IF system_label.job_mode = jmc$interactive_connected THEN
        qfp$assign_system_supplied_name (system_label.system_job_name);
        system_label.job_attributes.job_size := 0;
      ELSE
        process_command_file_and_label (file_path (1, file_path_size), command_file_path_p,
              command_file_password, caller_identification.ring, job_label_exists, store_and_forward_job,
              system_label, status);
        IF NOT status.normal THEN
          #KEYPOINT (osk$exit, 0, jmk$submit_job);
          RETURN;
        IFEND;
      IFEND;

{ Assign the requestor's system job name.

      system_job_name := system_label.system_job_name;

      IF submit_job_to_server THEN
        call_server_submit_job (system_label, immediate_initiation_candidate, current_mainframe_id,
              destination_mainframe_id, status);
        IF status.normal AND (system_label.job_mode <> jmc$batch) THEN
          IF (destination_mainframe_id <> current_mainframe_id) THEN
            switch_remote_connection (system_label.system_job_name, destination_mainframe_id,
                  encrypted_password, status);
          ELSE
            IF jmv$job_history_active THEN
              jmp$emit_job_history_statistics (jml$job_queuing_started, osc$null_name, system_job_name,
                    jmc$blank_system_supplied_name, ^system_label, NIL, osc$null_name,
                    system_label.job_attributes.originating_ssn, ignore_status);
            IFEND;

            qfp$submit_job (system_label, assigned_job_class, earliest_clock_time_to_initiate,
                  latest_clock_time_to_initiate, current_microsecond_clock, job_submission_time,
                  immediate_initiation_candidate, input_file_location, valid_mainframe_set, status);
          IFEND;
        IFEND;
      ELSE

{ Determine the fitness of the job for the mainframes that are available.

        qfp$determine_mainframe_fitness (system_label.job_category_set, leveled_job,
              system_label.login_user_identification.family, valid_mainframe_set, status);
        IF status.normal THEN
          osp$check_client_leveled_access (system_label.login_user_identification.family, leveled_access);
          IF ((system_label.job_mode <> jmc$batch) AND (system_label.job_destination_usage = jmc$ve_usage) AND
                jmv$job_scheduler_table.enable_job_leveling AND leveled_access) THEN
            level_interactive_job (valid_mainframe_set, assigned_job_class, earliest_clock_time_to_initiate,
                  latest_clock_time_to_initiate, current_microsecond_clock, current_mainframe_id,
                  system_label, destination_mainframe_id, status);
            IF status.normal THEN
              IF (destination_mainframe_id <> current_mainframe_id) THEN
                switch_remote_connection (system_label.system_job_name, destination_mainframe_id,
                      encrypted_password, status);
              ELSE
                IF jmv$job_history_active THEN
                  jmp$emit_job_history_statistics (jml$job_queuing_started, osc$null_name, system_job_name,
                        jmc$blank_system_supplied_name, ^system_label, NIL, osc$null_name,
                        system_label.job_attributes.originating_ssn, ignore_status);
                IFEND;

                qfp$submit_job (system_label, assigned_job_class, earliest_clock_time_to_initiate,
                      latest_clock_time_to_initiate, current_microsecond_clock, job_submission_time,
                      immediate_initiation_candidate, input_file_location, valid_mainframe_set, status);
              IFEND;
            IFEND;
          ELSE
            IF jmv$job_history_active THEN
              jmp$emit_job_history_statistics (jml$job_queuing_started, osc$null_name, system_job_name,
                    jmc$blank_system_supplied_name, ^system_label, NIL, osc$null_name,
                    system_label.job_attributes.originating_ssn, ignore_status);
            IFEND;

            qfp$submit_job (system_label, assigned_job_class, earliest_clock_time_to_initiate,
                  latest_clock_time_to_initiate, current_microsecond_clock, job_submission_time,
                  immediate_initiation_candidate, input_file_location, valid_mainframe_set, status);
          IFEND;
        IFEND;
      IFEND;

      IF NOT status.normal THEN
        IF (status.condition <> jme$scheduling_profile_changed) AND jmv$job_history_active THEN
          reason := '';
          osp$get_status_condition_name (status.condition, reason, ignore_status);
          jmp$emit_job_history_statistics (jml$job_queuing_aborted, osc$null_name, system_job_name,
                jmc$blank_system_supplied_name, NIL, NIL, reason, jmc$blank_system_supplied_name,
                ignore_status);
        IFEND;
        IF system_label.job_mode <> jmc$interactive_connected THEN
          osp$establish_block_exit_hndlr (^handle_block_exit);
          pfp$begin_system_authority;
          pfp$purge (command_file_path_p^, cycle_selector, command_file_password, ignore_status);
          pfp$end_system_authority;
          osp$disestablish_cond_handler;
        IFEND;
        IF (status.condition = jme$scheduling_profile_changed) THEN
          CYCLE /determine_job_class/;
        ELSEIF (status.condition = jme$duplicate_name) THEN
          system_label.system_job_name := '';

{ After detecting the duplicate system job name another attempt to prevalidate
{ the job and reassigning a new name to the job will be done with the encrypted
{ password, so the flag encrypted_password_supplied should be made TRUE.

          encrypted_password_supplied := TRUE;
          CYCLE /determine_job_class/;
        IFEND;
      IFEND;

      EXIT /determine_job_class/;
    WHILEND /determine_job_class/;

    IF status.normal THEN

{ If the caller is a user, emit the submit_job statistic.
{ If the caller is the system, submitting a system job, emit the submit_job statistic.
{ If the caller is the system, submitting a user job, do not emit the statistic.

      IF (NOT jmp$system_job ()) OR (user_identification = system_label.login_user_identification) THEN
        statistic_data.statistic_id := jmc$ca_submit_job;
        PUSH statistic_data.submit_job;
        statistic_data.submit_job^.job_size := system_label.job_attributes.job_size;
        statistic_data.submit_job^.system_job_name := system_label.system_job_name;
        jmp$emit_communication_stat (statistic_data);
      IFEND;
    IFEND;

    #KEYPOINT (osk$exit, 0, jmk$submit_job);
  PROCEND jmp$submit_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$terminate_acquired_input', EJECT ??
*copy jmh$terminate_acquired_input

  PROCEDURE [XDCL, #GATE] jmp$terminate_acquired_input
    (    input_destination_usage: jmt$destination_usage;
     VAR system_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      delete_input_file: boolean,
      cycle_selector: pft$cycle_selector,
      path_p: ^pft$path,
      password: pft$password;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      IF status.normal THEN
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);
      IFEND;
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??

    #KEYPOINT (osk$entry, 0, jmk$terminate_acquired_input);

    status.normal := TRUE;

    qfp$terminate_acquired_input (input_destination_usage, system_job_name, delete_input_file, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$terminate_acquired_input);
      RETURN;
    IFEND;

    IF delete_input_file THEN

{ This can only be the store-and-forward queue.  Jobs that belong to the local VE system(s) will not have
{ their command files touched by this request.  The only applications that can have files attached are
{ applications that access the store-and-forward queue.  With this in mind, osc$null_name is supplied as
{ the family name.

      determine_file_path (jmc$ifl_store_and_forward_queue, osc$null_name, system_job_name, path_p);
      cycle_selector.cycle_option := pfc$specific_cycle;
      cycle_selector.cycle_number := 1;
      password := osc$null_name;
      osp$establish_block_exit_hndlr (^handle_block_exit);
      pfp$begin_system_authority;
      pfp$purge (path_p^, cycle_selector, password, status);
      pfp$end_system_authority;
      osp$disestablish_cond_handler;
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, jmk$terminate_acquired_input);
        RETURN;
      IFEND;
    IFEND;
    #KEYPOINT (osk$exit, 0, jmk$terminate_acquired_input);
  PROCEND jmp$terminate_acquired_input;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$terminated_input_exists', EJECT ??
*copy jmh$terminated_input_exists

  FUNCTION [XDCL, #GATE] jmp$terminated_input_exists
    (    input_destination_usage: jmt$destination_usage): boolean;

    VAR
      application_index: jmt$input_application_index,
      input_exists: boolean;

    #KEYPOINT (osk$entry, 0, jmk$terminated_input_exists);
    application_index := UPPERBOUND (jmv$known_job_list.application_table);
    WHILE (jmv$known_job_list.application_table [application_index].destination_usage <>
          input_destination_usage) AND (application_index <> jmc$unassigned_input_index) DO
      application_index := application_index - 1;
    WHILEND;

    input_exists := (application_index <> jmc$unassigned_input_index) AND
          (jmv$known_job_list.application_table [application_index].
          state_data [jmc$kjl_application_terminated].number_of_entries > 0);
    jmp$terminated_input_exists := input_exists AND (NOT syp$system_is_idling ());
    #KEYPOINT (osk$exit, 0, jmk$terminated_input_exists);
  FUNCEND jmp$terminated_input_exists;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$terminate_job', EJECT ??
*copy jmh$terminate_job

  PROCEDURE [XDCL, #GATE] jmp$terminate_job
    (    job_name: jmt$name;
         job_termination_options: ^jmt$job_termination_options;
     VAR status: ost$status);

    VAR
      continue_request_to_servers: boolean,
      executing_mainframe_id: pmt$mainframe_id,
      job_state_set: jmt$job_state_set,
      job_status_options_p: ^jmt$job_status_options,
      job_status_results_keys_p: ^jmt$results_keys,
      job_status_results_p: ^jmt$job_status_results,
      job_status_results_seq_p: ^jmt$work_area,
      job_to_terminate: jmt$name,
      local_status: ost$status,
      number_of_jobs_found: jmt$job_status_count,
      option_index: ost$positive_integers,
      output_disposition_key: jmt$output_disposition_keys,
      output_disposition_key_known: boolean,
      privileged_job: boolean,
      reason: ost$name,
      scl_name: ost$name,
      size_of_sequence: ost$segment_length,
      ssn_of_caller: jmt$system_supplied_name,
      usn_of_caller: jmt$user_supplied_name;


    #KEYPOINT (osk$entry, 0, jmk$terminate_job);
    status.normal := TRUE;

{ Set default values

    continue_request_to_servers := FALSE;
    job_state_set := -$jmt$job_state_set [];
    output_disposition_key_known := FALSE;
    reason := osc$null_name;

{ Override default values - if necessary

    IF job_termination_options <> NIL THEN

    /validate_termination_options/
      FOR option_index := 1 TO UPPERBOUND (job_termination_options^) DO
        CASE job_termination_options^ [option_index].key OF
        = jmc$continue_request_to_servers =
          continue_request_to_servers := job_termination_options^ [option_index].continue_request_to_servers;

        = jmc$job_state_set =
          IF job_termination_options^ [option_index].job_state_set = $jmt$job_state_set [] THEN
            osp$set_status_condition (jme$job_state_is_null, status);
            EXIT /validate_termination_options/;
          IFEND;
          job_state_set := job_termination_options^ [option_index].job_state_set;

        = jmc$null_attribute =
          ;

        = jmc$output_disposition =
          output_disposition_key := job_termination_options^ [option_index].output_disposition.key;
          output_disposition_key_known := TRUE;
          IF (output_disposition_key = jmc$standard_output_path) OR
                (output_disposition_key = jmc$local_output_disposition) THEN
            jmp$get_attribute_name (job_termination_options^ [option_index].key, scl_name);
            osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter_value, scl_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'JOB_TERMINATION_OPTIONS', status);
            osp$append_status_parameter (osc$status_parameter_delimiter, jmc$terminate_job, status);
            EXIT /validate_termination_options/;
          IFEND;

        = jmc$termination_reason =
          reason := job_termination_options^ [option_index].reason_p^;

        ELSE
          jmp$get_attribute_name (job_termination_options^ [option_index].key, scl_name);
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'JOB_TERMINATION_OPTIONS', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$terminate_job, status);
          EXIT /validate_termination_options/;
        CASEND;
      FOREND /validate_termination_options/;
    IFEND;
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$terminate_job);
      RETURN;
    IFEND;

    jmp$validate_name (job_name, job_to_terminate, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$terminate_job);
      RETURN;
    IFEND;
    IF job_to_terminate.kind = jmc$system_supplied_name THEN
      scl_name := job_to_terminate.system_supplied_name;
    ELSE
      scl_name := job_to_terminate.user_supplied_name;
    IFEND;

    pmp$get_job_names (usn_of_caller, ssn_of_caller, { ignore } status);
    IF job_to_terminate.kind = jmc$system_supplied_name THEN
      IF ssn_of_caller = job_to_terminate.system_supplied_name THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$tried_to_self_destruct,
              job_to_terminate.system_supplied_name, status);
        #KEYPOINT (osk$exit, 0, jmk$terminate_job);
        RETURN;
      IFEND;
    ELSE
      IF usn_of_caller = job_to_terminate.user_supplied_name THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$tried_to_self_destruct,
              job_to_terminate.user_supplied_name, status);
        #KEYPOINT (osk$exit, 0, jmk$terminate_job);
        RETURN;
      IFEND;
    IFEND;

    privileged_job := avp$system_operator ();
    IF NOT privileged_job THEN
      jmp$get_scheduling_admin_status (local_status);
      IF local_status.normal THEN
        privileged_job := TRUE;
      IFEND;
    IFEND;

    PUSH job_status_options_p: [1 .. 4];
    job_status_options_p^ [1].key := jmc$name_list;
    PUSH job_status_options_p^ [1].name_list: [1 .. 1];
    job_status_options_p^ [1].name_list^ [1] := job_to_terminate;
    job_status_options_p^ [2].key := jmc$job_state_set;
    job_status_options_p^ [2].job_state_set := job_state_set;
    job_status_options_p^ [3].key := jmc$continue_request_to_servers;
    job_status_options_p^ [3].continue_request_to_servers := continue_request_to_servers;
    job_status_options_p^ [4].key := jmc$privilege;
    IF privileged_job THEN
      job_status_options_p^ [4].privilege := jmc$privileged;
    ELSE
      job_status_options_p^ [4].privilege := jmc$not_privileged;
    IFEND;

    PUSH job_status_results_keys_p: [1 .. 3];
    job_status_results_keys_p^ [1] := jmc$system_job_name;
    job_status_results_keys_p^ [2] := jmc$server_mainframe_id;
    job_status_results_keys_p^ [3] := jmc$input_file_location;

    jmp$get_result_size ({number_of_jobs} 1, #SEQ (job_status_results_keys_p^), size_of_sequence);
    PUSH job_status_results_seq_p: [[REP size_of_sequence OF cell]];

    jmp$get_job_status (job_status_options_p, job_status_results_keys_p, job_status_results_seq_p,
          job_status_results_p, number_of_jobs_found, status);
    IF number_of_jobs_found = 0 THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, scl_name, status);
    ELSEIF number_of_jobs_found > 1 THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_name, scl_name, status);
    IFEND;
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, jmk$terminate_job);
      RETURN;
    IFEND;

    IF job_status_results_p^ [1]^ [3].input_file_location = jmc$ifl_no_input_file_exists THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$job_cannot_be_terminated,
            job_status_results_p^ [1]^ [1].system_job_name, status);
      #KEYPOINT (osk$exit, 0, jmk$terminate_job);
      RETURN;
    IFEND;

    pmp$get_mainframe_id (executing_mainframe_id, { ignore } status);
    IF executing_mainframe_id = job_status_results_p^ [1]^ [2].server_mainframe_id THEN
      terminate_job (job_status_results_p^ [1]^ [1].system_job_name, job_state_set,
            output_disposition_key_known, output_disposition_key, privileged_job, reason, status);

    ELSEIF continue_request_to_servers THEN
      jmp$call_server_terminate_job (job_status_results_p^ [1]^ [1].
            system_job_name, job_status_results_p^ [1]^ [2].server_mainframe_id, job_state_set,
            output_disposition_key_known, output_disposition_key, privileged_job, reason, status);

    ELSE { Shouldn't be able to get here - the status request should have inhibited it.
      IF job_to_terminate.kind = jmc$system_supplied_name THEN
        scl_name := job_to_terminate.system_supplied_name;
      ELSE
        scl_name := job_to_terminate.user_supplied_name;
      IFEND;
      osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, scl_name, status);
    IFEND;

    #KEYPOINT (osk$exit, 0, jmk$terminate_job);
  PROCEND jmp$terminate_job;
?? OLDTITLE ??
?? NEWTITLE := 'level_interactive_job', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to determine where an interactive leveled
{   job should execute and queue, send or return it to its destination as
{   necessary.

{ DESIGN:
{   This procedure must be called on the server.  It will generate a list of
{   mainframe identifiers that may be valid destinations for an interactive
{   leveled job.  A procedure, which is implemented as a site hook, is called to
{   choose one of the mainframes from this list.  If the selected mainframe is
{   the current mainframe, the job is queued here.  If the selected mainframe is
{   the originating mainframe, (the mainframe the user originally created the
{   connection to), the job is not queued by this request, instead it will be
{   queued upon return to the originating mainframe.  If any other mainframe is
{   selected, a remote procedure call will be made to that mainframe to queue it there.

  PROCEDURE level_interactive_job
    (    valid_mainframe_set: jmt$valid_mainframe_set;
         assigned_job_class: jmt$job_class;
         earliest_clock_time_to_initiate: jmt$clock_time;
         latest_clock_time_to_initiate: jmt$clock_time;
         current_microsecond_clock: jmt$clock_time;
         originating_mainframe: pmt$mainframe_id;
     VAR system_label {input, output} : jmt$job_system_label;
     VAR selected_mainframe: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      continue_selection: boolean,
      current_mainframe_id: pmt$mainframe_id,
      interactive_job_info: ^jmt$interactive_job_info,
      mainframe: 1 .. jmc$maximum_mainframes,
      number_of_valid_mainframes: 0 .. jmc$maximum_mainframes,
      submit_variation: jmt$submit_job_variations,
      valid_mainframe: 0 .. jmc$maximum_mainframes,
      valid_mainframe_list: ^array [1 .. * ] of pmt$mainframe_id;

?? NEWTITLE := 'call_client_submit_job', EJECT ??

{ PURPOSE:
{   The purpose of this request is to submit an interactive leveled job from
{   a server to a client mainframe.

    PROCEDURE call_client_submit_job
      (    job_system_label: jmt$job_system_label;
           originating_mainframe_id: pmt$mainframe_id;
           destination_mainframe_id: pmt$mainframe_id;
       VAR status: ost$status);

      VAR
        client_location: dft$server_location,
        data_size: dft$send_data_size,
        ignore_recovery_occurred: boolean,
        ignore_status_p: ^ost$status,
        local_job_system_label_p: ^jmt$job_system_label,
        parameter_size: dft$send_parameter_size,
        queue_entry_location: dft$rpc_queue_entry_location,
        receive_from_server_data_p: dft$p_receive_data,
        receive_from_server_params_p: dft$p_receive_parameters,
        send_to_server_data_p: dft$p_send_data,
        send_to_server_parameters_p: dft$p_send_parameters,
        server_submit_job_params_p: ^server_submit_job_parameters;

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

      PROCEDURE dfp$remote_procedure_call_ch
        (    condition: pmt$condition;
             cond_desc: ^pmt$condition_information;
             save: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);

        VAR
          ignore_status: ost$status;


        dfp$ch_cleanup;
        osp$set_status_from_condition (dfc$file_server_id, condition, save, status, ignore_status);
        EXIT call_client_submit_job;

      PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??

      status.normal := TRUE;

      client_location.server_location_selector := dfc$mainframe_id;
      client_location.server_mainframe := destination_mainframe_id;

      REPEAT
        dfp$begin_ch_remote_proc_call (client_location, { allowed_when_server_deactivated } TRUE,
              queue_entry_location, send_to_server_parameters_p, send_to_server_data_p, status);
        IF NOT status.normal THEN

{***  Now what?? - the command file is on the server yet we can't make a KJL entry...
{ assume that the server crashed and will re-queue the job when it re-deadstarts?

          RETURN;
        IFEND;

{ Build the data and parameters to send to the server.
{ The RPC sequences have already been reset.

        NEXT server_submit_job_params_p IN send_to_server_parameters_p;
        server_submit_job_params_p^.immediate_initiation_candidate := TRUE;
        server_submit_job_params_p^.executing_on_server := FALSE;
        server_submit_job_params_p^.origin_mainframe_id := originating_mainframe_id;

        NEXT local_job_system_label_p IN send_to_server_data_p;
        local_job_system_label_p^ := job_system_label;

        parameter_size := i#current_sequence_position (send_to_server_parameters_p);
        data_size := i#current_sequence_position (send_to_server_data_p);

        dfp$send_remote_procedure_call (queue_entry_location, dfc$rpc_jl_submit_job, parameter_size,
              data_size, receive_from_server_params_p, receive_from_server_data_p, status);
        IF status.normal THEN

{ Ignore destination_mainframe_id returned in receive_from_server_params_p by jmp$server_submit_job.

          dfp$end_ch_remote_proc_call (queue_entry_location, status);
        ELSE
          PUSH ignore_status_p;
          dfp$end_ch_remote_proc_call (queue_entry_location, ignore_status_p^);
          IF status.condition = dfe$job_needs_recovery THEN
            dfp$check_job_recovery (ignore_recovery_occurred);
          IFEND;
        IFEND;
      UNTIL status.normal OR (status.condition <> dfe$job_needs_recovery);
    PROCEND call_client_submit_job;
?? OLDTITLE ??
?? NEWTITLE := 'set_interactive_job_info', EJECT ??

{ PURPOSE:
{   The purpose of this request is to copy some of the information contained in
{   the system label to a data structure that is passed on to the site hook
{   that chooses the mainframe an interactive job should execute on.

    PROCEDURE set_interactive_job_info
      (    job_system_label: jmt$job_system_label;
       VAR interactive_job_info: jmt$interactive_job_info);


      interactive_job_info.assigned_job_class := job_system_label.assigned_job_class;
      interactive_job_info.comment_banner := job_system_label.job_attributes.comment_banner;
      interactive_job_info.copy_count := job_system_label.job_attributes.copy_count;
      interactive_job_info.cpu_time_limit_specified := job_system_label.limit_information.
            cpu_time_limit_specified;
      interactive_job_info.cpu_time_limit_requested := job_system_label.limit_information.
            cpu_time_limit_requested;
      interactive_job_info.cpu_time_limit_assigned := job_system_label.limit_information.
            cpu_time_limit_assigned;
      interactive_job_info.device := job_system_label.job_attributes.device;
      interactive_job_info.earliest_print_time := job_system_label.job_attributes.earliest_print_time;
      interactive_job_info.external_characteristics := job_system_label.job_attributes.
            external_characteristics;
      interactive_job_info.forms_code := job_system_label.job_attributes.forms_code;
      interactive_job_info.job_abort_disposition := job_system_label.job_abort_disposition;
      interactive_job_info.job_category_set := job_system_label.job_category_set;
      interactive_job_info.job_class_name := job_system_label.job_class_name;
      interactive_job_info.job_destination_family := job_system_label.job_destination_family;
      interactive_job_info.job_destination_usage := job_system_label.job_destination_usage;
      interactive_job_info.job_execution_ring := job_system_label.job_execution_ring;
      interactive_job_info.job_input_device := job_system_label.job_attributes.job_input_device;
      interactive_job_info.job_mode := job_system_label.job_mode;
      interactive_job_info.job_priority := job_system_label.job_priority;
      interactive_job_info.job_qualifier_list := job_system_label.job_attributes.job_qualifier_list;
      interactive_job_info.job_recovery_disposition := job_system_label.job_recovery_disposition;
      interactive_job_info.latest_print_time := job_system_label.job_attributes.latest_print_time;
      interactive_job_info.login_account := job_system_label.login_account;
      interactive_job_info.login_project := job_system_label.login_project;
      interactive_job_info.login_user_identification := job_system_label.login_user_identification;
      interactive_job_info.magnetic_tape_limit_specified :=
            job_system_label.limit_information.magnetic_tape_limit_specified;
      interactive_job_info.magnetic_tape_limit_requested :=
            job_system_label.limit_information.magnetic_tape_limit_requested;
      interactive_job_info.magnetic_tape_limit_assigned :=
            job_system_label.limit_information.magnetic_tape_limit_assigned;
      interactive_job_info.maximum_working_set_specified :=
            job_system_label.limit_information.maximum_working_set_specified;
      interactive_job_info.maximum_working_set_requested :=
            job_system_label.limit_information.maximum_working_set_requested;
      interactive_job_info.maximum_working_set_assigned :=
            job_system_label.limit_information.maximum_working_set_assigned;
      interactive_job_info.operator_family := job_system_label.job_attributes.output_destination_family;
      interactive_job_info.operator_user := job_system_label.job_attributes.station_operator;
      interactive_job_info.originating_application_name :=
            job_system_label.job_attributes.originating_application_name;
      interactive_job_info.output_deferred_by_user := job_system_label.job_attributes.output_deferred_by_user;
      interactive_job_info.output_destination := job_system_label.job_attributes.output_destination;
      interactive_job_info.output_destination_usage := job_system_label.job_attributes.
            output_destination_usage;
      interactive_job_info.output_disposition_key := job_system_label.job_attributes.output_disposition_key;
      interactive_job_info.output_disposition_path := job_system_label.job_attributes.output_disposition_path;
      interactive_job_info.perform_class_validation := job_system_label.perform_class_validation;
      interactive_job_info.purge_delay := job_system_label.job_attributes.purge_delay;
      interactive_job_info.remote_host_directive := job_system_label.job_attributes.remote_host_directive;
      interactive_job_info.routing_banner := job_system_label.job_attributes.routing_banner;
      interactive_job_info.sru_limit_specified := job_system_label.limit_information.sru_limit_specified;
      interactive_job_info.sru_limit_requested := job_system_label.limit_information.sru_limit_requested;
      interactive_job_info.sru_limit_assigned := job_system_label.limit_information.sru_limit_assigned;
      interactive_job_info.station := job_system_label.job_attributes.station;
      interactive_job_info.system_job_name := job_system_label.system_job_name;
      interactive_job_info.user_information := job_system_label.job_attributes.user_information;
      interactive_job_info.user_job_name := job_system_label.user_job_name;
      interactive_job_info.vertical_print_density := job_system_label.job_attributes.vertical_print_density;
      interactive_job_info.vfu_load_procedure := job_system_label.job_attributes.vfu_load_procedure;

    PROCEND set_interactive_job_info;
?? OLDTITLE ??

    status.normal := TRUE;

    pmp$get_mainframe_id (current_mainframe_id, {ignore} status);
    status.normal := TRUE;

    number_of_valid_mainframes := 0;
    FOR mainframe := 1 TO jmc$maximum_mainframes DO
      IF mainframe IN valid_mainframe_set THEN
        number_of_valid_mainframes := number_of_valid_mainframes + 1;
      IFEND;
    FOREND;

    IF number_of_valid_mainframes > 0 THEN
      PUSH valid_mainframe_list: [1 .. number_of_valid_mainframes];
      valid_mainframe := 0;
      FOR mainframe := 1 TO jmc$maximum_mainframes DO
        IF mainframe IN valid_mainframe_set THEN
          valid_mainframe := valid_mainframe + 1;
          pmp$convert_binary_mainframe_id (jmv$job_scheduler_table.validation_categories_p^ [mainframe].
                binary_mainframe_id, valid_mainframe_list^ [valid_mainframe], {ignore} status);
          status.normal := TRUE;
        IFEND;
      FOREND;

      PUSH interactive_job_info;
      set_interactive_job_info (system_label, interactive_job_info^);

    /select_a_mainframe/
      WHILE TRUE DO
        jmp$select_interactive_job_dest (valid_mainframe_list^, interactive_job_info^, selected_mainframe,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF selected_mainframe = pmc$null_mainframe_id THEN

{ If no mainframe is selected, terminate the login.

          osp$set_status_condition (jme$maximum_jobs, status);
          EXIT /select_a_mainframe/;

        ELSEIF selected_mainframe = originating_mainframe THEN

{ The originating mainframe has been chosen, the job will be queued there when we return.

          EXIT /select_a_mainframe/;

        ELSEIF (selected_mainframe = current_mainframe_id) THEN

{ The server mainframe has been chosen, queue the job here.

          submit_variation.kind := jmc$remote_connection_switch;
          system_label.job_attributes.system_job_parameters.system_job_parameter_count :=
                #SIZE (submit_variation);
          i#move (^submit_variation, ^system_label.job_attributes.system_job_parameters.
                system_job_parameter, #SIZE (submit_variation));
          nap$set_server_job_init_pending (osc$timesharing, {server_job_init_pending = } TRUE, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF jmv$job_history_active THEN
            jmp$emit_job_history_statistics (jml$job_queuing_started, osc$null_name,
                  system_label.system_job_name, jmc$blank_system_supplied_name, ^system_label, NIL,
                  osc$null_name, system_label.job_attributes.originating_ssn, {ignore} status);
            status.normal := TRUE;
          IFEND;

          qfp$submit_job (system_label, assigned_job_class, earliest_clock_time_to_initiate,
                latest_clock_time_to_initiate, current_microsecond_clock,
                {job_submission_time} current_microsecond_clock, {immediate_initiation_candidate} TRUE,
                jmc$ifl_login_family_queue, valid_mainframe_set, status);

        ELSE

{ Submit the job to the chosen client mainframe.

          call_client_submit_job (system_label, originating_mainframe, selected_mainframe, status);
        IFEND;

        IF NOT status.normal THEN
          continue_selection := FALSE;
          FOR valid_mainframe := 1 TO UPPERBOUND (valid_mainframe_list^) DO
            IF valid_mainframe_list^ [valid_mainframe] = selected_mainframe THEN
              valid_mainframe_list^ [valid_mainframe] := pmc$null_mainframe_id;
            IFEND;
            IF valid_mainframe_list^ [valid_mainframe] <> pmc$null_mainframe_id THEN
              continue_selection := TRUE;
            IFEND;
          FOREND;
          IF continue_selection THEN
            CYCLE /select_a_mainframe/;
          IFEND;
          osp$set_status_condition (jme$maximum_jobs, status);
        IFEND;

        EXIT /select_a_mainframe/;
      WHILEND /select_a_mainframe/;
    ELSE
      osp$set_status_condition (jme$maximum_jobs, status);
    IFEND;

  PROCEND level_interactive_job;
?? OLDTITLE ??
?? NEWTITLE := 'prevalidate_job', EJECT ??

{ PURPOSE:
{   The purpose of this request is to pre-validate the job defined by the values in the system job label
{ and retrieve any unknown values (attributes) from the validation file.

  PROCEDURE prevalidate_job
    (    user_identification: ost$user_identification;
         password_encrypted: boolean;
     VAR system_label: jmt$job_system_label;
     VAR assigned_job_class: jmt$job_class;
     VAR encrypted_password: ost$name;
     VAR status: ost$status);

    VAR
      batch_password_can_default: boolean,
      default_attributes: ^avt$validation_items,
      i: ost$non_negative_integers,
      interactive_job: boolean,
      number_of_valid_job_classes: ost$non_negative_integers,
      omit_password_validation: boolean,
      perform_class_validation: boolean,
      terminal_name: ost$name,
      terminal_name_found: boolean,
      valid_job_classes: ^jmt$job_class_list,
      validation_attributes: ^avt$validation_items,
      validation_cpu_time_limit: jmt$cpu_time_limit,
      validation_magnetic_tape_limit: sft$counter,
      validation_sru_limit: jmt$sru_limit;

?? NEWTITLE := 'assign_cpu_time_limit', EJECT ??

{ PURPOSE:
{   The purpose of this request is to assign a cpu time limit to the job
{   defined by the system job label.

    PROCEDURE assign_cpu_time_limit
      (    assigned_job_class: jmt$job_class;
       VAR system_label: jmt$job_system_label;
       VAR status: ost$status);

{ If no cpu time limit has been assigned, assign the system default value if the
{ job has automatic selection to a job class and assign the job class value if
{ the job has been assigned to a specific job class.

      IF system_label.limit_information.cpu_time_limit_assigned = jmc$unspecified_cpu_time_limit THEN
        IF system_label.assigned_job_class = jmc$automatic_class_name THEN
          system_label.limit_information.cpu_time_limit_assigned :=
                jmv$default_job_attributes [system_label.job_mode].cpu_time_limit;
        ELSE
          IF jmv$job_class_table_p^ [assigned_job_class].cpu_time_limit = jmc$system_default_cpu_time_lim THEN
            system_label.limit_information.cpu_time_limit_assigned :=
                  jmv$default_job_attributes [system_label.job_mode].cpu_time_limit;
          ELSE
            system_label.limit_information.cpu_time_limit_assigned :=
                  jmv$job_class_table_p^ [assigned_job_class].cpu_time_limit;
          IFEND;
        IFEND;
        IF system_label.limit_information.cpu_time_limit_assigned = jmc$required_cpu_time_limit THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$missing_parameter, 'CPU_TIME_LIMIT', status);
          RETURN;
        IFEND;

{ In all cases, restrict the cpu time limit assigned to the maximum for which
{ the user is validated.

        IF system_label.limit_information.cpu_time_limit_assigned > validation_cpu_time_limit THEN
          system_label.limit_information.cpu_time_limit_assigned := validation_cpu_time_limit;
        IFEND;
      IFEND;
    PROCEND assign_cpu_time_limit;

?? OLDTITLE ??
?? NEWTITLE := 'assign_magnetic_tape_limit', EJECT ??

{ PURPOSE:
{   The purpose of this request is to assign a magnetic tape limit to the job
{   defined by the system job label.

    PROCEDURE assign_magnetic_tape_limit
      (    assigned_job_class: jmt$job_class;
       VAR system_label: jmt$job_system_label;
       VAR status: ost$status);

{ If no magnetic tape limit has been assigned, assign the system default value.

      IF system_label.limit_information.magnetic_tape_limit_assigned = jmc$unspecified_mag_tape_limit THEN
        system_label.limit_information.magnetic_tape_limit_assigned :=
              jmv$default_job_attributes [system_label.job_mode].magnetic_tape_limit;
        IF system_label.limit_information.magnetic_tape_limit_assigned = jmc$required_mag_tape_limit THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$missing_parameter, 'MAGNETIC_TAPE_LIMIT',
                status);
          RETURN;
        IFEND;
      IFEND;
    PROCEND assign_magnetic_tape_limit;

?? OLDTITLE ??
?? NEWTITLE := 'assign_maximum_working_set', EJECT ??

{ PURPOSE:
{   The purpose of this request is to assign a maximum working set to the job
{   defined by the system job label.

    PROCEDURE assign_maximum_working_set
      (    assigned_job_class: jmt$job_class;
       VAR system_label: jmt$job_system_label;
       VAR status: ost$status);

{ If no maximum working set has been assigned, assign the system default value
{ if the job has automatic selection to a job class and assign the job class
{ default value if the job has been assigned to a specific job class.

      IF system_label.limit_information.maximum_working_set_assigned = jmc$unspecified_work_set_size THEN
        IF system_label.assigned_job_class = jmc$automatic_class_name THEN
          system_label.limit_information.maximum_working_set_assigned :=
                jmv$default_job_attributes [system_label.job_mode].maximum_working_set;
          IF system_label.limit_information.maximum_working_set_assigned = jmc$required_working_set_size THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$missing_parameter, 'MAXIMUM_WORKING_SET',
                  status);
            RETURN;
          IFEND;
        ELSE
          system_label.limit_information.maximum_working_set_assigned :=
                jmv$job_class_table_p^ [assigned_job_class].maximum_working_set.default;
        IFEND;
      IFEND;
    PROCEND assign_maximum_working_set;

?? OLDTITLE ??
?? NEWTITLE := 'assign_sru_limit', EJECT ??

{ PURPOSE:
{   The purpose of this request is to assign an sru limit to the job defined
{   by the system job label.

    PROCEDURE assign_sru_limit
      (    assigned_job_class: jmt$job_class;
       VAR system_label: jmt$job_system_label;
       VAR status: ost$status);

{ If no sru limit has been assigned, assign the system default value if the job
{ has automatic selection to a job class and assign the job class value if the
{ job has been assigned to a specific job class.

      IF system_label.limit_information.sru_limit_assigned = jmc$unspecified_sru_limit THEN
        IF system_label.assigned_job_class = jmc$automatic_class_name THEN
          system_label.limit_information.sru_limit_assigned :=
                jmv$default_job_attributes [system_label.job_mode].sru_limit;
        ELSE
          IF jmv$job_class_table_p^ [assigned_job_class].sru_limit = jmc$system_default_sru_limit THEN
            system_label.limit_information.sru_limit_assigned :=
                  jmv$default_job_attributes [system_label.job_mode].sru_limit;
          ELSE
            system_label.limit_information.sru_limit_assigned :=
                  jmv$job_class_table_p^ [assigned_job_class].sru_limit;
          IFEND;
        IFEND;
        IF system_label.limit_information.sru_limit_assigned = jmc$required_sru_limit THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$missing_parameter, 'SRU_LIMIT', status);
          RETURN;
        IFEND;

{ In all cases, restrict the sru limit assigned to the maximum for which the
{ user is validated.

        IF system_label.limit_information.sru_limit_assigned > validation_sru_limit THEN
          system_label.limit_information.sru_limit_assigned := validation_sru_limit;
        IFEND;
      IFEND;
    PROCEND assign_sru_limit;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    interactive_job := (system_label.job_attributes.originating_application_name =
          osc$dual_state_interactive) OR (system_label.job_attributes.originating_application_name =
          osc$timesharing) OR (system_label.job_attributes.originating_application_name =
          osc$xterm_application_name);
    batch_password_can_default := (user_identification = system_label.login_user_identification);

    omit_password_validation := ((interactive_job OR batch_password_can_default) AND
          (system_label.login_password = osc$null_name)) OR password_encrypted;

    perform_class_validation := FALSE;
    system_label.assigned_job_class := system_label.job_class_name;
    valid_job_classes := NIL;

{ Define the attributes to be validated against the validation file.

    PUSH validation_attributes: [1 .. 9];
    IF omit_password_validation THEN
      validation_attributes^ [1].key := avc$null_validation_key;
    ELSE
      validation_attributes^ [1].key := avc$password_key;
      validation_attributes^ [1].password := system_label.login_password;
    IFEND;
    IF system_label.job_attributes.originating_application_name = osc$dual_state_interactive THEN
      validation_attributes^ [2].key := avc$null_validation_key;
    ELSE
      validation_attributes^ [2].key := avc$account_project_key;
      validation_attributes^ [2].account_name := system_label.login_account;
      validation_attributes^ [2].project_name := system_label.login_project;
    IFEND;
    IF system_label.perform_class_validation AND (system_label.job_class_name <> osc$null_name) THEN
      validation_attributes^ [3].key := avc$job_class_name_key;
      validation_attributes^ [3].job_class_name := system_label.job_class_name;
    ELSE
      validation_attributes^ [3].key := avc$null_validation_key;
    IFEND;
    IF system_label.job_execution_ring <> osc$invalid_ring THEN
      validation_attributes^ [4].key := avc$job_execution_ring_key;
      validation_attributes^ [4].job_execution_ring := system_label.job_execution_ring;
    ELSE
      validation_attributes^ [4].key := avc$null_validation_key;
    IFEND;
    IF system_label.required_user_capability <> osc$null_name THEN
      validation_attributes^ [5].key := avc$required_capability_key;
      validation_attributes^ [5].required_capability := system_label.required_user_capability;
    ELSE
      validation_attributes^ [5].key := avc$null_validation_key;
    IFEND;
    IF system_label.limit_information.cpu_time_limit_assigned <> jmc$unspecified_cpu_time_limit THEN
      validation_attributes^ [6].key := avc$job_limit_key;
      validation_attributes^ [6].limit_name := avc$cpu_time_limit_name;
      validation_attributes^ [6].user_specified := TRUE;
      validation_attributes^ [6].job_maximum := system_label.limit_information.cpu_time_limit_assigned;
    ELSE
      validation_attributes^ [6].key := avc$null_validation_key;
    IFEND;
    IF system_label.limit_information.sru_limit_assigned <> jmc$unspecified_sru_limit THEN
      validation_attributes^ [7].key := avc$job_limit_key;
      validation_attributes^ [7].limit_name := avc$sru_limit_name;
      validation_attributes^ [7].user_specified := TRUE;
      validation_attributes^ [7].job_maximum := system_label.limit_information.sru_limit_assigned;
    ELSE
      validation_attributes^ [7].key := avc$null_validation_key;
    IFEND;
    IF system_label.limit_information.magnetic_tape_limit_assigned <> jmc$unspecified_mag_tape_limit THEN
      validation_attributes^ [8].key := avc$job_limit_key;
      validation_attributes^ [8].limit_name := avc$magnetic_tape_limit_name;
      validation_attributes^ [8].user_specified := TRUE;
      validation_attributes^ [8].job_maximum := system_label.limit_information.magnetic_tape_limit_assigned;
    ELSE
      validation_attributes^ [8].key := avc$null_validation_key;
    IFEND;

{ Get the terminal name to be passed on to prevalidation of timesharing jobs.

    get_terminal_name (system_label, terminal_name_found, terminal_name);
    IF terminal_name_found THEN
      validation_attributes^ [9].key := avc$terminal_name;
      validation_attributes^ [9].terminal_name := terminal_name;
    ELSE
      validation_attributes^ [9].key := avc$null_validation_key;
    IFEND;

{ Define the attributes to be returned from the validation file.

    PUSH default_attributes: [1 .. 7];
    default_attributes^ [1].key := avc$password_key;
    IF system_label.job_class_name = osc$null_name THEN
      default_attributes^ [2].key := avc$job_class_defaults_key;
    ELSE
      default_attributes^ [2].key := avc$null_validation_key;
    IFEND;
    IF system_label.job_attributes.originating_application_name = osc$dual_state_interactive THEN
      default_attributes^ [3].key := avc$optional_capability_key;
      default_attributes^ [3].optional_capability := avc$dual_state_prompt;
    ELSE
      default_attributes^ [3].key := avc$null_validation_key;
    IFEND;
    IF system_label.limit_information.cpu_time_limit_assigned = jmc$unspecified_cpu_time_limit THEN
      default_attributes^ [4].key := avc$job_limit_key;
      default_attributes^ [4].limit_name := avc$cpu_time_limit_name;
      default_attributes^ [4].user_specified := FALSE;
    ELSE
      default_attributes^ [4].key := avc$null_validation_key;
    IFEND;
    IF system_label.limit_information.sru_limit_assigned = jmc$unspecified_sru_limit THEN
      default_attributes^ [5].key := avc$job_limit_key;
      default_attributes^ [5].limit_name := avc$sru_limit_name;
      default_attributes^ [5].user_specified := FALSE;
    ELSE
      default_attributes^ [5].key := avc$null_validation_key;
    IFEND;
    IF (system_label.job_class_name = jmc$automatic_class_name) OR
          (system_label.job_class_name = osc$null_name) OR (system_label.job_class_name =
          jmc$system_default_class_name) THEN
      default_attributes^ [6].key := avc$valid_job_classes_key;
      PUSH valid_job_classes: [1 .. avc$maximum_name_list_size];
      default_attributes^ [6].job_classes := valid_job_classes;
    ELSE
      default_attributes^ [6].key := avc$null_validation_key;
    IFEND;
    IF system_label.limit_information.magnetic_tape_limit_assigned = jmc$unspecified_mag_tape_limit THEN
      default_attributes^ [7].key := avc$job_limit_key;
      default_attributes^ [7].limit_name := avc$magnetic_tape_limit_name;
      default_attributes^ [7].user_specified := FALSE;
    ELSE
      default_attributes^ [7].key := avc$null_validation_key;
    IFEND;

    avp$prevalidate_job (system_label.login_user_identification.user,
          system_label.login_user_identification.family, validation_attributes, default_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    encrypted_password := default_attributes^ [1].password;

{ Update values from the user values in the validation file.

    IF NOT password_encrypted THEN
      system_label.login_password := encrypted_password;
    IFEND;

    IF system_label.job_class_name = osc$null_name THEN
      IF system_label.job_mode = jmc$interactive_connected THEN
        system_label.assigned_job_class := default_attributes^ [2].interactive_job_class_default;
      ELSE
        system_label.assigned_job_class := default_attributes^ [2].batch_job_class_default;
      IFEND;
    IFEND;

    IF system_label.job_attributes.originating_application_name = osc$dual_state_interactive THEN
      system_label.optional_user_capability := default_attributes^ [3].optional_capability;
    IFEND;

    IF system_label.limit_information.cpu_time_limit_assigned = jmc$unspecified_cpu_time_limit THEN
      validation_cpu_time_limit := default_attributes^ [4].job_maximum;
    IFEND;

    IF system_label.limit_information.sru_limit_assigned = jmc$unspecified_sru_limit THEN
      validation_sru_limit := default_attributes^ [5].job_maximum;
    IFEND;

    IF system_label.limit_information.magnetic_tape_limit_assigned = jmc$unspecified_mag_tape_limit THEN
      validation_magnetic_tape_limit := default_attributes^ [7].job_maximum;
    IFEND;

    IF valid_job_classes <> NIL THEN
      number_of_valid_job_classes := default_attributes^ [6].count;
    IFEND;

{ Determine the job class name and index if they are known.

    IF system_label.assigned_job_class = jmc$system_default_class_name THEN
      IF system_label.perform_class_validation THEN
        perform_class_validation := TRUE;
      IFEND;
      IF system_label.job_mode = jmc$interactive_connected THEN
        system_label.assigned_job_class := jmv$default_job_attributes [system_label.job_mode].job_class;
      ELSE
        system_label.assigned_job_class := jmv$default_job_attributes [system_label.job_mode].job_class;
      IFEND;
    IFEND;

    IF (system_label.assigned_job_class = jmc$none_class_name) THEN
      IF system_label.job_mode = jmc$interactive_connected THEN
        osp$set_status_condition (jme$interactive_access_denied, status);
      ELSE
        osp$set_status_condition (jme$batch_access_denied, status);
      IFEND;
      RETURN;
    IFEND;

    IF (system_label.assigned_job_class <> jmc$automatic_class_name) THEN
      IF (valid_job_classes <> NIL) AND perform_class_validation THEN

      /validate_job_class/
        BEGIN
          FOR i := 1 TO number_of_valid_job_classes DO
            IF (system_label.assigned_job_class = valid_job_classes^ [i]) OR
                  (valid_job_classes^ [i] = jmc$all_class_name) THEN
              EXIT /validate_job_class/;
            IFEND;
          FOREND;
          osp$set_status_abnormal ('AV', ave$bad_job_class, system_label.assigned_job_class, status);
          RETURN;
        END /validate_job_class/;
      IFEND;

      jmp$determine_job_class (system_label.assigned_job_class, assigned_job_class, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$job_class_does_not_exist,
              system_label.assigned_job_class, status);
        RETURN;
      IFEND;
    IFEND;

{ Determine the job class if it is unknown.

    IF valid_job_classes = NIL THEN
      PUSH valid_job_classes: [1 .. 1];
      valid_job_classes^ [1] := system_label.assigned_job_class;
      number_of_valid_job_classes := 1;
    IFEND;

    qfp$categorize_job (valid_job_classes^, number_of_valid_job_classes, system_label, assigned_job_class,
          status);

{ Assign the limits to the job.

    assign_cpu_time_limit (assigned_job_class, system_label, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    assign_magnetic_tape_limit (assigned_job_class, system_label, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    assign_maximum_working_set (assigned_job_class, system_label, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    assign_sru_limit (assigned_job_class, system_label, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ If the magnetic tape limit is still unspecified then assign the limit to the job class value.

    IF system_label.limit_information.magnetic_tape_limit_assigned = jmc$unspecified_mag_tape_limit THEN
      system_label.limit_information.magnetic_tape_limit_assigned :=
            jmv$job_class_table_p^ [assigned_job_class].magnetic_tape_limit;
      IF system_label.limit_information.magnetic_tape_limit_assigned > validation_magnetic_tape_limit THEN
        system_label.limit_information.magnetic_tape_limit_assigned := validation_magnetic_tape_limit;
      IFEND;
    IFEND;
  PROCEND prevalidate_job;
?? OLDTITLE ??
MODEND jmm$queue_file_job_manager;
*DECK DECK=JMM$QUEUE_FILE_LEVELER_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Job Leveler Management Ring 3' ??
MODULE jmm$queue_file_leveler_manager;

{ PURPOSE:
{   This module contains the interfaces responsible for the validation and
{   processing of requests made by the job leveler task.
{
{ DESIGN:
{   The procedures in this module execute in ring 3 and are callable from ring 6.
{  They are used solely to support the job leveler task and its operations.
{
{ NOTES:
{   These ring 3 routines validate that the caller is the job leveler task.  As
{   a result, it is assumed that the parameter values passed to the request are valid
{   and need not be copied or protected further if the caller is the expected caller.
{   If the caller of an interface in this module is not the job leveler task, an
{   access violation is forced and the task is aborted.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfc$server_mainframes_catalog
*copyc dft$rpc_parameters
*copyc jmc$job_management_id
*copyc jmc$system_family
*copyc jme$queued_file_conditions
*copyc jmt$jl_assigned_job_list
*copyc jmt$jl_job_class_data
*copyc jmt$jl_job_class_priorities
*copyc jmt$jl_leveler_server_request
*copyc jmt$jl_missing_job_list
*copyc jmt$jl_restart_file_version
*copyc jmt$jl_scheduling_data
*copyc jmt$jl_server_job_end_info
*copyc jmt$jl_server_job_list
*copyc jmt$jl_server_job_priorities
*copyc jmt$jl_unassigned_job_list
*copyc jmt$job_category_set
*copyc jmt$job_count_range
*copyc jmt$service_interval
*copyc jmt$valid_mainframe_set
*copyc oss$job_paged_literal
*copyc ost$global_task_id
*copyc ost$status
*copyc pmt$binary_mainframe_id
?? POP ??
*copyc amp$get_segment_pointer
*copyc dfp$get_partner_mainframes
*copyc dfp$send_remote_procedure_call
*copyc fsp$build_file_ref_from_elems
*copyc fsp$close_file
*copyc fsp$open_file
*copyc i#current_sequence_position
*copyc i#move
*copyc jmp$change_input_attributes
*copyc jmp$get_recovery_restart_file
*copyc jmp$rebuild_input_queue
*copyc jmp$system_job
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$force_access_violation
*copyc osp$generate_log_message
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$system_error
*copyc osp$verify_system_privilege
*copyc pfp$begin_system_authority
*copyc pfp$end_system_authority
*copyc pfp$purge
*copyc pmp$convert_binary_mainframe_id
*copyc pmp$get_pseudo_mainframe_id
*copyc pmp$get_executing_task_gtid
*copyc pmp$log_ascii
*copyc pmp$long_term_wait
*copyc qfp$assign_jobs_to_client
*copyc qfp$assign_server_jobs
*copyc qfp$clear_server_job_classes
*copyc qfp$determine_needed_priorities
*copyc qfp$determine_need_for_jobs
*copyc qfp$discard_server_jobs
*copyc qfp$get_server_jobs
*copyc qfp$ready_job_leveler
*copyc qfp$register_job_leveler
*copyc qfp$set_leveler_ready
*copyc qfp$unassign_client_jobs
*copyc qfp$unassign_server_jobs
*copyc qfp$update_server_priorities
*copyc qfp$verify_client_assigned_jobs
*copyc qfp$verify_inactive_server
*copyc qfp$wait_for_leveler_deactivate
*copyc jmv$executing_within_system_job
*copyc jmv$jcb
*copyc jmv$job_scheduler_table
*copyc jmv$kjl_p
*copyc jmv$kjlx_p
*copyc jmv$known_job_list
*copyc jmv$leveler_profile_loading
*copyc qfv$leveler_readied
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

{ The maximum_assigned_job_list_size is the number of jobs that the assign request
{ will allow to be assigned at one time.  The physical limitation on the number is
{ defined to be the size of sequence that can be transferred back to the client
{ divided by the size of an assigned job list entry.  The number chosen here is
{ a practical limit, versus a physical limit.

  CONST
    maximum_assigned_job_list_size = 1000;

  VAR
    null_global_task_id: [STATIC, READ, oss$job_paged_literal] ost$global_task_id := [0, 0];

?? OLDTITLE ??
?? NEWTITLE := 'log_recovery_message', EJECT ??

{ The purpose of this procedure is to log recovery related information to the
{ system log and job log.

  PROCEDURE log_recovery_message
    (    error_message: string ( * );
         bad_status: ost$status);

    VAR
      logset: pmt$ascii_logset,
      log_origin: pmt$log_msg_origin,
      ignore_status: ost$status;

    ignore_status.normal := TRUE;
    log_origin := pmc$msg_origin_system;
    logset := $pmt$ascii_logset [pmc$system_log, pmc$job_log];

    IF error_message <> '' THEN
      pmp$log_ascii (error_message, logset, log_origin, ignore_status);
    IFEND;

    IF NOT bad_status.normal THEN
      osp$generate_log_message (logset, bad_status, ignore_status);
    IFEND;
  PROCEND log_recovery_message;
?? OLDTITLE ??
?? NEWTITLE := 'verify_client_assigned_jobs', EJECT ??

{ PURPOSE:
{    This request will verify that the jobs assigned to a client mainframe match the
{ list of jobs the server believes are assigned to the client.  For any job that the
{ server believes is initiated on the client, that the client does not know about, the
{ job_recovery and job_abort dispositions will be used to determine the fate of the job.
{
{ DESIGN:
{   This request is called only on the server mainframe.

  PROCEDURE verify_client_assigned_jobs
    (    client_mainframe_id: pmt$binary_mainframe_id;
         server_job_list_p: ^jmt$jl_server_job_list;
         restart_job_list_p: ^jmt$jl_restart_job_list);

?? NEWTITLE := 'handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      pfp$end_system_authority;
    PROCEND handle_block_exit;
?? OLDTITLE, EJECT ??

    VAR
      cycle_selector: pft$cycle_selector,
      ignore_status: ost$status,
      input_attribute_changes_p: ^jmt$input_attribute_changes,
      input_file_name: jmt$name,
      local_status: ost$status,
      missing_job_count: jmt$job_count_range,
      missing_job_list_index: jmt$job_count_range,
      missing_job_list_p: ^jmt$jl_missing_job_list,
      password: pft$password,
      path_p: ^pft$path,
      restart_job_index: jmt$job_count_range;

    PUSH missing_job_list_p: [1 .. jmc$maximum_job_count];
    qfp$verify_client_assigned_jobs (client_mainframe_id, server_job_list_p, missing_job_list_p,
          missing_job_count);

    IF missing_job_count > 0 THEN
      input_file_name.kind := jmc$system_supplied_name;
      PUSH input_attribute_changes_p: [1 .. 1];
      input_attribute_changes_p^ [1].key := jmc$null_attribute;

      PUSH path_p: [1 .. 4];
      path_p^ [1] := osc$null_name;
      path_p^ [2] := jmc$system_user;
      path_p^ [3] := jmc$job_input_catalog;
      path_p^ [4] := osc$null_name;
      cycle_selector.cycle_option := pfc$specific_cycle;
      cycle_selector.cycle_number := 1;
      password := osc$null_name;
      osp$establish_block_exit_hndlr (^handle_block_exit);
      pfp$begin_system_authority;

    /search_for_missing_jobs/
      FOR missing_job_list_index := 1 TO missing_job_count DO
        local_status.normal := TRUE;

{ Search for the job in the restart job list.  If the job is in the restart list
{ it may need to be recovered.  If the job is not in the restart job list, its
{ recovery or abort disposition was set to terminate or the job had completed.

        IF restart_job_list_p <> NIL THEN

        /search_restart_job_list/
          FOR restart_job_index := 1 TO UPPERBOUND (restart_job_list_p^) DO
            IF missing_job_list_p^ [missing_job_list_index].system_job_name =
                  restart_job_list_p^ [restart_job_index].system_job_name THEN
              jmp$rebuild_input_queue (missing_job_list_p^ [missing_job_list_index].system_job_name,
                    missing_job_list_p^ [missing_job_list_index].login_family, jmc$job_input_catalog,
                    restart_job_list_p^ [restart_job_index].recover_using_abort_disposition,
                    {ignore_client_initiated_jobs} TRUE, {job_deferred_by_operator} FALSE, local_status);
              IF local_status.normal THEN
                input_file_name.system_supplied_name := missing_job_list_p^ [missing_job_list_index].
                      system_job_name;
                osp$set_status_abnormal (jmc$job_management_id, jme$input_was_recovered,
                      missing_job_list_p^ [missing_job_list_index].system_job_name, local_status);
                log_recovery_message ('', local_status);

{ Passing the null attribute versus NIL for the input attribute changes forces change input attributes
{ to recategorize and prevalidate the job again.

                jmp$change_input_attributes (input_file_name, input_attribute_changes_p, local_status);
                IF NOT local_status.normal THEN

{ Log the error.  After file server recovery completes manas can be used to
{ resubmit the jobs.  They are in the unassigned job class.

                  log_recovery_message (missing_job_list_p^ [missing_job_list_index].system_job_name,
                        local_status);
                IFEND;
                CYCLE /search_for_missing_jobs/;
              ELSE
                EXIT /search_restart_job_list/;
              IFEND;
            IFEND;
          FOREND /search_restart_job_list/;
        IFEND;

{ The input file was not recovered - purge it.

        osp$set_status_abnormal (jmc$job_management_id, jme$input_was_not_recovered,
              missing_job_list_p^ [missing_job_list_index].system_job_name, ignore_status);
        log_recovery_message ('', ignore_status);
        log_recovery_message ('', local_status);
        path_p^ [1] := missing_job_list_p^ [missing_job_list_index].login_family;
        path_p^ [4] := missing_job_list_p^ [missing_job_list_index].system_job_name;

        pfp$purge (path_p^, cycle_selector, password, ignore_status);

      FOREND /search_for_missing_jobs/;
      pfp$end_system_authority;
      osp$disestablish_cond_handler;
    IFEND;
  PROCEND verify_client_assigned_jobs;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$assign_server_jobs', EJECT ??
*copy jmh$assign_server_jobs

  PROCEDURE [XDCL, #GATE] jmp$assign_server_jobs
    (    server_mainframe_id: pmt$binary_mainframe_id;
         assigned_job_list_p: { output } ^jmt$jl_assigned_job_list;
     VAR number_of_jobs_assigned: jmt$job_count_range;
     VAR status: ost$status);

    jmp$verify_job_leveler;
    qfp$assign_server_jobs (server_mainframe_id, assigned_job_list_p, number_of_jobs_assigned, status);
  PROCEND jmp$assign_server_jobs;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$call_job_leveler_server', EJECT ??
*copy jmh$call_job_leveler_server

  PROCEDURE [XDCL, #GATE] jmp$call_job_leveler_server
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR leveler_server_request { input, output } : jmt$jl_leveler_server_request;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT jmp$call_job_leveler_server;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??

    VAR
      data_size: dft$send_data_size,
      ignore_status: ost$status,
      local_assigned_job_list_p: ^jmt$jl_assigned_job_list,
      local_assigned_job_count_p: ^jmt$job_count_range,
      local_categories_p: ^jmt$job_category_set,
      local_client_mainframe_id_p: ^pmt$binary_mainframe_id,
      local_job_class_data_p: ^jmt$jl_job_class_data,
      local_job_class_priorities_p: ^jmt$jl_job_class_priorities,
      local_job_leveling_enabled_p: ^boolean,
      local_profile_id_p: ^ost$name,
      local_profile_mismatch_p: ^boolean,
      local_request_kind_p: ^jmt$jl_request_kind,
      local_restart_job_count_p: ^jmt$job_count_range,
      local_restart_job_list_p: ^jmt$jl_restart_job_list,
      local_server_job_count_p: ^jmt$job_count_range,
      local_server_job_list_p: ^jmt$jl_server_job_list,
      local_server_job_priorities_p: ^jmt$jl_server_job_priorities,
      local_unassigned_job_list_p: ^jmt$jl_unassigned_job_list,
      local_unassigned_job_count_p: ^jmt$job_count_range,
      queue_entry_location: dft$rpc_queue_entry_location,
      parameter_size: dft$send_parameter_size,
      receive_from_server_data_p: dft$p_receive_data,
      receive_from_server_params_p: dft$p_receive_parameters,
      send_to_server_data_p: dft$p_send_data,
      send_to_server_parameters_p: dft$p_send_parameters,
      server_location: dft$server_location;

    IF (leveler_server_request.request_kind = jmc$jl_ready_levelers_request) THEN
      osp$verify_system_privilege;
    ELSEIF (leveler_server_request.request_kind = jmc$jl_signon_request) THEN
      IF NOT jmp$system_job () THEN
        osp$force_access_violation;
      IFEND;
    ELSE
      jmp$verify_job_leveler;
    IFEND;

{ Need to convert the server's mainframe id to a queue entry location.

    server_location.server_location_selector := dfc$mainframe_id;
    pmp$convert_binary_mainframe_id (server_mainframe_id, server_location.server_mainframe,
          { ignore } status);
    dfp$begin_ch_remote_proc_call (server_location, { allowed_when_server_deactivated } TRUE,
          queue_entry_location, send_to_server_parameters_p, send_to_server_data_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Build the send to server parameters and data to send to the server mainframe.
{ RPC sequences are already reset.

    NEXT local_client_mainframe_id_p IN send_to_server_parameters_p;
    pmp$get_pseudo_mainframe_id (local_client_mainframe_id_p^);
    NEXT local_request_kind_p IN send_to_server_parameters_p;
    local_request_kind_p^ := leveler_server_request.request_kind;
    CASE leveler_server_request.request_kind OF
    = jmc$jl_signon_request =
      NEXT local_server_job_count_p IN send_to_server_data_p;
      IF leveler_server_request.signon_request.server_job_list_p = NIL THEN
        local_server_job_count_p^ := 0;
      ELSE
        local_server_job_count_p^ := UPPERBOUND (leveler_server_request.signon_request.server_job_list_p^);
        NEXT local_server_job_list_p: [1 .. local_server_job_count_p^] IN send_to_server_data_p;
        local_server_job_list_p^ := leveler_server_request.signon_request.server_job_list_p^;
      IFEND;
      NEXT local_restart_job_count_p IN send_to_server_data_p;
      IF leveler_server_request.signon_request.restart_job_list_p = NIL THEN
        local_restart_job_count_p^ := 0;
      ELSE
        local_restart_job_count_p^ := UPPERBOUND (leveler_server_request.signon_request.restart_job_list_p^);
        NEXT local_restart_job_list_p: [1 .. local_restart_job_count_p^] IN send_to_server_data_p;
        local_restart_job_list_p^ := leveler_server_request.signon_request.restart_job_list_p^;
      IFEND;

    = jmc$jl_normal_request =
      NEXT local_profile_id_p IN send_to_server_parameters_p;
      local_profile_id_p^ := leveler_server_request.normal_request.active_profile_id;
      NEXT local_categories_p IN send_to_server_parameters_p;
      local_categories_p^ := leveler_server_request.normal_request.initiation_required_categories;
      NEXT local_categories_p IN send_to_server_parameters_p;
      local_categories_p^ := leveler_server_request.normal_request.initiation_excluded_categories;
      NEXT local_job_class_data_p IN send_to_server_parameters_p;
      local_job_class_data_p^ := leveler_server_request.normal_request.leveler_job_class_data;
      NEXT local_job_class_priorities_p IN send_to_server_parameters_p;
      local_job_class_priorities_p^ := leveler_server_request.normal_request.job_class_priorities;
      NEXT local_unassigned_job_count_p IN send_to_server_data_p;
      IF leveler_server_request.normal_request.unassigned_job_list_p = NIL THEN
        local_unassigned_job_count_p^ := 0;
      ELSE
        local_unassigned_job_count_p^ := UPPERBOUND (leveler_server_request.normal_request.
              unassigned_job_list_p^);
        NEXT local_unassigned_job_list_p: [1 .. local_unassigned_job_count_p^] IN send_to_server_data_p;
        local_unassigned_job_list_p^ := leveler_server_request.normal_request.unassigned_job_list_p^;
      IFEND;

    = jmc$jl_unassign_jobs_request =
      NEXT local_unassigned_job_count_p IN send_to_server_data_p;
      IF leveler_server_request.unassign_jobs_request.unassigned_job_list_p = NIL THEN
        local_unassigned_job_count_p^ := 0;
      ELSE
        local_unassigned_job_count_p^ := UPPERBOUND (leveler_server_request.unassign_jobs_request.
              unassigned_job_list_p^);
        NEXT local_unassigned_job_list_p: [1 .. local_unassigned_job_count_p^] IN send_to_server_data_p;
        local_unassigned_job_list_p^ := leveler_server_request.unassign_jobs_request.unassigned_job_list_p^;
      IFEND;

    = jmc$jl_signoff_request =
      NEXT local_unassigned_job_count_p IN send_to_server_data_p;
      IF leveler_server_request.signoff_request.unassigned_job_list_p = NIL THEN
        local_unassigned_job_count_p^ := 0;
      ELSE
        local_unassigned_job_count_p^ := UPPERBOUND (leveler_server_request.signoff_request.
              unassigned_job_list_p^);
        NEXT local_unassigned_job_list_p: [1 .. local_unassigned_job_count_p^] IN send_to_server_data_p;
        local_unassigned_job_list_p^ := leveler_server_request.signoff_request.unassigned_job_list_p^;
      IFEND;

    = jmc$jl_ready_levelers_request =
      ; { Nothing.

    ELSE
      dfp$end_ch_remote_proc_call (queue_entry_location, ignore_status);
      osp$system_error ('Unknown Job Leveler request.', NIL);
    CASEND;
    parameter_size := i#current_sequence_position (send_to_server_parameters_p);
    data_size := i#current_sequence_position (send_to_server_data_p);

    dfp$send_remote_procedure_call (queue_entry_location, dfc$rpc_jl_job_leveler_server, parameter_size,
          data_size, receive_from_server_params_p, receive_from_server_data_p, status);
    IF status.normal THEN
      IF leveler_server_request.request_kind = jmc$jl_normal_request THEN
        NEXT local_profile_mismatch_p IN receive_from_server_params_p;
        NEXT local_job_leveling_enabled_p IN receive_from_server_params_p;
        leveler_server_request.normal_request.profile_mismatch := local_profile_mismatch_p^;
        leveler_server_request.normal_request.job_leveling_enabled := local_job_leveling_enabled_p^;
        IF local_profile_mismatch_p^ OR (NOT local_job_leveling_enabled_p^) THEN

{ There is a profile mismatch error or leveling is disabled - for now, don't do anything.

        ELSE
          NEXT local_server_job_priorities_p IN receive_from_server_params_p;
          leveler_server_request.normal_request.server_job_priorities := local_server_job_priorities_p^;

          NEXT local_assigned_job_count_p IN receive_from_server_data_p;
          leveler_server_request.normal_request.assigned_job_count := local_assigned_job_count_p^;
          IF leveler_server_request.normal_request.assigned_job_count > 0 THEN
            NEXT local_assigned_job_list_p: [1 .. leveler_server_request.normal_request.assigned_job_count] IN
                  receive_from_server_data_p;
            i#move (local_assigned_job_list_p, leveler_server_request.normal_request.
                  assigned_job_list_p, #SIZE (jmt$jl_assigned_job) *
                  leveler_server_request.normal_request.assigned_job_count);
          IFEND;
        IFEND;
      IFEND;
      dfp$end_ch_remote_proc_call (queue_entry_location, status);
    ELSE { IF NOT status.normal THEN
      dfp$end_ch_remote_proc_call (queue_entry_location, ignore_status);
    IFEND;
  PROCEND jmp$call_job_leveler_server;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$called_by_job_leveler', EJECT ??
*copy jmh$called_by_job_leveler

  FUNCTION [XDCL] jmp$called_by_job_leveler: boolean;

    VAR
      global_task_id: ost$global_task_id;

    pmp$get_executing_task_gtid (global_task_id);
    jmp$called_by_job_leveler := jmv$known_job_list.application_table [jmc$ve_input_application_index].
          global_task_id = global_task_id;
  FUNCEND jmp$called_by_job_leveler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$clear_server_job_classes', EJECT ??
*copy jmh$clear_server_job_classes

  PROCEDURE [XDCL, #GATE] jmp$clear_server_job_classes;

    jmp$verify_job_leveler;
    qfp$clear_server_job_classes;
  PROCEND jmp$clear_server_job_classes;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$deactivate_job_leveling', EJECT ??
*copy jmh$deactivate_job_leveling

  PROCEDURE [XDCL] jmp$deactivate_job_leveling
    (VAR status: ost$status);

    CONST
      deactivate_wait_time_sec = 60; { One minute

    VAR
      client_mainframe_count: dft$partner_mainframe_count,
      client_mainframe_index: dft$partner_mainframe_count,
      client_mainframe_list: array [1 .. dfc$maximum_partner_mainframes] of dft$partner_mainframe_entry,
      ignore_status: ost$status,
      ignore_task_executing: boolean,
      leveler_client_request: jmt$jl_leveler_server_request,
      leveler_deactivated: boolean;

    status.normal := TRUE;
    jmp$ready_job_leveler_task (ignore_task_executing);

{ Ready the job leveler tasks that are executing on any client mainframes.  Remember, levelers execute on
{ clients, not servers.

    dfp$get_partner_mainframes ({ partners_are_servers } FALSE, ^client_mainframe_list,
          client_mainframe_count);
    leveler_client_request.request_kind := jmc$jl_ready_levelers_request;
    FOR client_mainframe_index := 1 TO client_mainframe_count DO
      IF client_mainframe_list [client_mainframe_index].partner_state = dfc$active THEN
        jmp$call_job_leveler_server (client_mainframe_list [client_mainframe_index].mainframe_id,
              leveler_client_request, ignore_status);
      IFEND;
    FOREND;

    qfp$wait_for_leveler_deactivate (deactivate_wait_time_sec, leveler_deactivated);
    IF NOT leveler_deactivated THEN
      osp$set_status_condition (jme$leveler_not_responding, status);
    IFEND;
  PROCEND jmp$deactivate_job_leveling;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$determine_needed_priorities', EJECT ??
*copy jmh$determine_needed_priorities

  PROCEDURE [XDCL, #GATE] jmp$determine_needed_priorities
    (    leveler_job_class_data: jmt$jl_job_class_data;
     VAR job_class_priorities: jmt$jl_job_class_priorities);

    jmp$verify_job_leveler;
    qfp$determine_needed_priorities (leveler_job_class_data, job_class_priorities);
  PROCEND jmp$determine_needed_priorities;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$determine_need_for_jobs', EJECT ??
*copy jmh$determine_need_for_jobs

  PROCEDURE [XDCL, #GATE] jmp$determine_need_for_jobs
    (VAR leveler_job_class_data: jmt$jl_job_class_data);

    jmp$verify_job_leveler;
    qfp$determine_need_for_jobs (leveler_job_class_data);
  PROCEND jmp$determine_need_for_jobs;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$discard_server_jobs', EJECT ??
*copy jmh$discard_server_jobs

  PROCEDURE [XDCL, #GATE] jmp$discard_server_jobs
    (    server_mainframe_id: pmt$binary_mainframe_id);

    jmp$verify_job_leveler;
    qfp$discard_server_jobs (server_mainframe_id);
  PROCEND jmp$discard_server_jobs;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$get_client_scheduling_data', EJECT ??
*copy jmh$get_client_scheduling_data

  PROCEDURE [XDCL, #GATE] jmp$get_client_scheduling_data
    (VAR scheduling_data: jmt$jl_scheduling_data);

    jmp$verify_job_leveler;
    scheduling_data.job_leveling_interval := jmv$job_scheduler_table.job_leveling_interval;
    scheduling_data.profile_identification := jmv$job_scheduler_table.profile_identification;
    scheduling_data.initiation_required_categories := jmv$job_scheduler_table.initiation_required_categories;
    scheduling_data.initiation_excluded_categories := jmv$job_scheduler_table.initiation_excluded_categories;
    scheduling_data.job_leveling_enabled := jmv$job_scheduler_table.enable_job_leveling;
    scheduling_data.profile_loading_in_progress := jmv$leveler_profile_loading;
  PROCEND jmp$get_client_scheduling_data;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$get_server_job_end_info', EJECT ??
*copy jmh$get_server_job_end_info

  PROCEDURE [XDCL] jmp$get_server_job_end_info
    (VAR job_end_information: jmt$jl_server_job_end_info);

    VAR
      kjl_index: jmt$kjl_index;

    kjl_index := jmv$jcb.job_id;
    pmp$get_pseudo_mainframe_id (job_end_information.client_mainframe_id);
    job_end_information.server_mainframe_id := jmv$known_job_list.server_data.
          state_data [jmv$kjl_p^ [kjl_index].server_index].mainframe_id;
    job_end_information.system_job_name := jmv$jcb.system_name;
    job_end_information.server_kjl_index := jmv$kjl_p^ [kjl_index].server_kjl_index;
    job_end_information.job_requests_restart := jmv$kjlx_p^ [kjl_index].restart_job;

  PROCEND jmp$get_server_job_end_info;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$job_is_being_leveled', EJECT ??
*copy jmh$job_is_being_leveled

  FUNCTION [XDCL] jmp$job_is_being_leveled: boolean;

    jmp$job_is_being_leveled := (jmv$kjl_p^ [jmv$jcb.job_id].server_index <>
          jmc$kjl_server_this_mainframe) AND (NOT jmv$executing_within_system_job) AND
          (jmv$kjlx_p^ [jmv$jcb.job_id].job_mode = jmc$batch);
  FUNCEND jmp$job_is_being_leveled;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$job_leveler_server', EJECT ??
*copy jmh$job_leveler_server

  PROCEDURE [XDCL] jmp$job_leveler_server
    (VAR received_from_client_params_p { Input } : dft$p_receive_parameters;
     VAR received_from_client_data_p { Input } : dft$p_receive_data;
     VAR send_to_client_params_p { Output } : dft$p_send_parameters;
     VAR send_to_client_data_p { Output } : dft$p_send_data;
     VAR parameter_size: dft$send_parameter_size;
     VAR data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      active_profile_id_p: ^ost$name,
      assigned_job_list_p: ^jmt$jl_assigned_job_list,
      assigned_job_count_p: ^jmt$job_count_range,
      client_mainframe_id_p: ^pmt$binary_mainframe_id,
      excluded_categories_p: ^jmt$job_category_set,
      ignore_leveler_executing: boolean,
      job_class_data_p: ^jmt$jl_job_class_data,
      job_class_priorities_p: ^jmt$jl_job_class_priorities,
      job_leveling_enabled_p: ^boolean,
      profile_mismatch_p: ^boolean,
      request_kind_p: ^jmt$jl_request_kind,
      required_categories_p: ^jmt$job_category_set,
      restart_job_count_p: ^jmt$job_count_range,
      restart_job_list_p: ^jmt$jl_restart_job_list,
      server_job_count_p: ^jmt$job_count_range,
      server_job_list_p: ^jmt$jl_server_job_list,
      server_job_priorities_p: ^jmt$jl_server_job_priorities,
      unassigned_job_count_p: ^jmt$job_count_range,
      unassigned_job_list_p: ^jmt$jl_unassigned_job_list;

    status.normal := TRUE;

{ RPC sequences are already reset.

    NEXT client_mainframe_id_p IN received_from_client_params_p;
    NEXT request_kind_p IN received_from_client_params_p;

    CASE request_kind_p^ OF
    = jmc$jl_signon_request =
      NEXT server_job_count_p IN received_from_client_data_p;
      IF server_job_count_p^ = 0 THEN
        server_job_list_p := NIL;
      ELSE
        NEXT server_job_list_p: [1 .. server_job_count_p^] IN received_from_client_data_p;
      IFEND;
      NEXT restart_job_count_p IN received_from_client_data_p;
      IF restart_job_count_p^ = 0 THEN
        restart_job_list_p := NIL;
      ELSE
        NEXT restart_job_list_p: [1 .. restart_job_count_p^] IN received_from_client_data_p;
      IFEND;

      verify_client_assigned_jobs (client_mainframe_id_p^, server_job_list_p, restart_job_list_p);

    = jmc$jl_normal_request =
      NEXT active_profile_id_p IN received_from_client_params_p;
      NEXT required_categories_p IN received_from_client_params_p;
      NEXT excluded_categories_p IN received_from_client_params_p;
      NEXT job_class_data_p IN received_from_client_params_p;
      NEXT job_class_priorities_p IN received_from_client_params_p;

{ Unassign the jobs in the unassigned job list.

      NEXT unassigned_job_count_p IN received_from_client_data_p;
      IF unassigned_job_count_p^ = 0 THEN
        unassigned_job_list_p := NIL;
      ELSE
        NEXT unassigned_job_list_p: [1 .. unassigned_job_count_p^] IN received_from_client_data_p;
      IFEND;

      qfp$unassign_client_jobs (client_mainframe_id_p^, unassigned_job_list_p);

{ Assign jobs as the client requested.

      NEXT profile_mismatch_p IN send_to_client_params_p;
      profile_mismatch_p^ := (active_profile_id_p^ <> jmv$job_scheduler_table.profile_identification) OR
            jmv$leveler_profile_loading;
      NEXT job_leveling_enabled_p IN send_to_client_params_p;
      job_leveling_enabled_p^ := jmv$job_scheduler_table.enable_job_leveling;

      NEXT server_job_priorities_p IN send_to_client_params_p;

      NEXT assigned_job_count_p IN send_to_client_data_p;
      IF profile_mismatch_p^ OR (NOT job_leveling_enabled_p^) THEN
        assigned_job_count_p^ := 0;
      ELSE

        NEXT assigned_job_list_p: [1 .. maximum_assigned_job_list_size] IN send_to_client_data_p;
        qfp$assign_jobs_to_client (client_mainframe_id_p^, job_class_data_p^, job_class_priorities_p^,
              required_categories_p^, excluded_categories_p^, assigned_job_list_p, assigned_job_count_p^,
              server_job_priorities_p^);
        RESET send_to_client_data_p TO assigned_job_list_p;
        IF assigned_job_count_p^ > 0 THEN
          NEXT assigned_job_list_p: [1 .. assigned_job_count_p^] IN send_to_client_data_p;
        IFEND;
      IFEND;

    = jmc$jl_unassign_jobs_request =
      NEXT unassigned_job_count_p IN received_from_client_data_p;
      IF unassigned_job_count_p^ = 0 THEN
        unassigned_job_list_p := NIL;
      ELSE
        NEXT unassigned_job_list_p: [1 .. unassigned_job_count_p^] IN received_from_client_data_p;
      IFEND;

      qfp$unassign_client_jobs (client_mainframe_id_p^, unassigned_job_list_p);

    = jmc$jl_signoff_request =
      NEXT unassigned_job_count_p IN received_from_client_data_p;
      IF unassigned_job_count_p^ = 0 THEN
        unassigned_job_list_p := NIL;
      ELSE
        NEXT unassigned_job_list_p: [1 .. unassigned_job_count_p^] IN received_from_client_data_p;
      IFEND;

      qfp$unassign_client_jobs (client_mainframe_id_p^, unassigned_job_list_p);

    = jmc$jl_ready_levelers_request =
      jmp$ready_job_leveler_task (ignore_leveler_executing);

    ELSE
      osp$system_error ('Unknown job leveler request from client.', NIL);
    CASEND;

    parameter_size := i#current_sequence_position (send_to_client_params_p);
    data_size := i#current_sequence_position (send_to_client_data_p);
  PROCEND jmp$job_leveler_server;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$leveler_wait', EJECT ??
*copy jmh$leveler_wait

  PROCEDURE [XDCL, #GATE] jmp$leveler_wait
    (    job_leveling_interval: jmt$service_interval);

    CONST
      number_of_us_in_a_ms = 1000,
      number_of_us_in_a_second = 1000000;

    VAR
      end_wait_time: jmt$clock_time,
      requested_wait_time: jmt$clock_time,
      start_wait_time: jmt$clock_time;

    jmp$verify_job_leveler;
    start_wait_time := #FREE_RUNNING_CLOCK (0);
    end_wait_time := start_wait_time + (job_leveling_interval * number_of_us_in_a_second);
    WHILE (NOT qfv$leveler_readied) AND (start_wait_time < end_wait_time) DO
      requested_wait_time := (end_wait_time - start_wait_time) DIV number_of_us_in_a_ms;
      pmp$long_term_wait (requested_wait_time, requested_wait_time);
      start_wait_time := #FREE_RUNNING_CLOCK (0);
    WHILEND;
    qfp$set_leveler_ready (FALSE);
  PROCEND jmp$leveler_wait;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$reconcile_leveled_jobs', EJECT ??
*copy jmh$reconcile_leveled_jobs

  PROCEDURE [XDCL] jmp$reconcile_leveled_jobs
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

    VAR
      attachment_options_p: ^fst$attachment_options,
      cycle_selector: pft$cycle_selector,
      ignore_status: ost$status,
      leveler_server_request: jmt$jl_leveler_server_request,
      local_status: ost$status,
      restart_file_version_p: ^jmt$jl_restart_file_version,
      restart_job_count_p: ^jmt$job_count_range,
      restart_job_sequence_p: ^SEQ ( * ),
      scratch_segment_pointer: amt$segment_pointer,
      scratch_sequence_p: ^SEQ ( * ),
      segment_pointer: amt$segment_pointer,
      server_ascii_mainframe_id: pmt$mainframe_id,
      server_file_exists: boolean,
      server_file_identifier: amt$file_identifier,
      server_file_path: fst$path,
      server_file_path_p: ^pft$path,
      server_job_count: jmt$job_count_range;

    status.normal := TRUE;
    pmp$convert_binary_mainframe_id (server_mainframe_id, server_ascii_mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, scratch_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    scratch_sequence_p := scratch_segment_pointer.sequence_pointer;
    RESET scratch_sequence_p;

    leveler_server_request.request_kind := jmc$jl_signon_request;
    NEXT leveler_server_request.signon_request.server_job_list_p: [1 .. jmc$maximum_job_count] IN
          scratch_sequence_p;
    qfp$get_server_jobs (server_mainframe_id, leveler_server_request.signon_request.server_job_list_p,
          server_job_count);
    RESET scratch_sequence_p TO leveler_server_request.signon_request.server_job_list_p;
    IF server_job_count = 0 THEN
      leveler_server_request.signon_request.server_job_list_p := NIL;
    ELSE
      NEXT leveler_server_request.signon_request.server_job_list_p: [1 .. server_job_count] IN
            scratch_sequence_p;
    IFEND;

{ Open the server file and retrieve the restart job list.
{ If the file cannot be opened for read access assume that it does not exist.

    PUSH server_file_path_p: [1 .. 4];
    server_file_path_p^ [1] := jmc$system_family;
    server_file_path_p^ [2] := jmc$system_user;
    server_file_path_p^ [3] := dfc$server_mainframes_catalog;
    jmp$get_recovery_restart_file (server_ascii_mainframe_id, server_file_path_p^ [4]);

    fsp$build_file_ref_from_elems (server_file_path_p, server_file_path, ignore_status);
    PUSH attachment_options_p: [1 .. 2];
    attachment_options_p^ [1].selector := fsc$access_and_share_modes;
    attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options_p^ [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options_p^ [1].share_modes.value := $fst$file_access_options [];
    attachment_options_p^ [2].selector := fsc$open_share_modes;
    attachment_options_p^ [2].open_share_modes := $fst$file_access_options [];
    fsp$open_file (server_file_path, amc$segment, attachment_options_p, NIL, NIL, NIL, NIL,
          server_file_identifier, local_status);
    IF local_status.normal THEN
      server_file_exists := TRUE;
      amp$get_segment_pointer (server_file_identifier, amc$sequence_pointer, segment_pointer, local_status);
      IF local_status.normal THEN
        restart_job_sequence_p := segment_pointer.sequence_pointer;
        RESET restart_job_sequence_p;
        NEXT restart_file_version_p IN restart_job_sequence_p;
        IF restart_file_version_p^ = jmc$jl_rfv_version_1 THEN
          NEXT restart_job_count_p IN restart_job_sequence_p;
          IF restart_job_count_p = NIL THEN
            leveler_server_request.signon_request.restart_job_list_p := NIL;
          ELSE
            IF restart_job_count_p^ = 0 THEN
              leveler_server_request.signon_request.restart_job_list_p := NIL;
            ELSE
              NEXT leveler_server_request.signon_request.restart_job_list_p: [1 .. restart_job_count_p^] IN
                    restart_job_sequence_p;
            IFEND;
          IFEND;
        ELSE
          leveler_server_request.signon_request.restart_job_list_p := NIL;
        IFEND;
      ELSE
        leveler_server_request.signon_request.restart_job_list_p := NIL;
      IFEND;

    ELSE { couldn't open the file
      server_file_exists := FALSE;
      leveler_server_request.signon_request.restart_job_list_p := NIL;
    IFEND;

    jmp$call_job_leveler_server (server_mainframe_id, leveler_server_request, status);

    IF server_file_exists THEN
      fsp$close_file (server_file_identifier, ignore_status);
      IF status.normal THEN
        cycle_selector.cycle_option := pfc$specific_cycle;
        cycle_selector.cycle_number := 1;
        pfp$purge (server_file_path_p^, cycle_selector, { password } osc$null_name, status);
      IFEND;
    IFEND;
    mmp$delete_scratch_segment (scratch_segment_pointer, ignore_status);
  PROCEND jmp$reconcile_leveled_jobs;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$ready_job_leveler_task', EJECT ??
*copy jmh$ready_job_leveler_task

  PROCEDURE [XDCL] jmp$ready_job_leveler_task
    (VAR task_executing: boolean);

    task_executing := jmv$known_job_list.application_table [jmc$ve_input_application_index].global_task_id <>
          null_global_task_id;
    IF task_executing THEN
      qfp$ready_job_leveler;
    IFEND;
  PROCEND jmp$ready_job_leveler_task;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$register_job_leveler', EJECT ??
*copy jmh$register_job_leveler

  PROCEDURE [XDCL, #GATE] jmp$register_job_leveler;

    IF NOT jmp$system_job () THEN
      osp$force_access_violation;
    IFEND;

    qfp$register_job_leveler;
  PROCEND jmp$register_job_leveler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$unassign_server_jobs', EJECT ??
*copy jmh$unassign_server_jobs

  PROCEDURE [XDCL, #GATE] jmp$unassign_server_jobs
    (    server_mainframe_id: pmt$binary_mainframe_id;
         unassign_all_jobs: boolean;
         job_class_priorities: jmt$jl_job_class_priorities;
         unassigned_job_list { output } : ^jmt$jl_unassigned_job_list;
     VAR number_of_unassigned_jobs: jmt$job_count_range);

    jmp$verify_job_leveler;
    qfp$unassign_server_jobs (server_mainframe_id, unassign_all_jobs, job_class_priorities,
          unassigned_job_list, number_of_unassigned_jobs);
  PROCEND jmp$unassign_server_jobs;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$update_server_priorities', EJECT ??
*copy jmh$update_server_priorities

  PROCEDURE [XDCL, #GATE] jmp$update_server_priorities
    (    highest_server_priorities: jmt$jl_server_job_priorities);

    jmp$verify_job_leveler;
    qfp$update_server_priorities (highest_server_priorities);
  PROCEND jmp$update_server_priorities;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$verify_inactive_server', EJECT ??
*copy jmh$verify_inactive_server

  PROCEDURE [XDCL, #GATE] jmp$verify_inactive_server
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR server_inactive: boolean);

    jmp$verify_job_leveler;
    qfp$verify_inactive_server (server_mainframe_id, server_inactive);
  PROCEND jmp$verify_inactive_server;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$verify_job_leveler', EJECT ??
*copy jmh$verify_job_leveler

  PROCEDURE [XDCL] jmp$verify_job_leveler;

    VAR
      global_task_id: ost$global_task_id;

    pmp$get_executing_task_gtid (global_task_id);
    IF jmv$known_job_list.application_table [jmc$ve_input_application_index].global_task_id <>
          global_task_id THEN
      osp$force_access_violation;
    IFEND;
  PROCEND jmp$verify_job_leveler;
?? OLDTITLE ??
MODEND jmm$queue_file_leveler_manager;
*DECK DECK=JMM$QUEUE_FILE_OUTPUT_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE: Job Management Queued Files Output Interfaces' ??                                     
MODULE jmm$queue_file_output_manager;                                                                         
                                                                                                              
{ PURPOSE:                                                                                                    
{   This module contains the queue file output management interfaces.  These interfaces control the           
{ access to, submission of, and manipulation of output files.                                                 
{                                                                                                             
{ DESIGN:                                                                                                     
{   The program interfaces contained in this module are designed in such a fashion that binary                
{ compatibility can be maintained.  Any change to the size of a record element in a variant record            
{ will result in an interface breakage.  These procedures operate in rings 2 and 3 with a call bracket        
{ of ring 13.                                                                                                 
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc amt$access_level                                                                                       
*copyc amt$file_attributes                                                                                    
*copyc amt$local_file_name                                                                                    
*copyc avc$validation_field_names                                                                             
*copyc ave$validation_interface_errors                                                                        
*copyc cle$ecc_lexical                                                                                        
*copyc fme$file_management_errors                                                                             
*copyc fst$file_reference                                                                                     
*copyc i#compare_collated                                                                                     
*copyc i#current_sequence_position                                                                            
*copyc jmc$change_output_attributes                                                                           
*copyc jmc$default_forms_code                                                                                 
*copyc jmc$get_output_attributes                                                                              
*copyc jmc$get_output_status                                                                                  
*copyc jmc$job_management_id                                                                                  
*copyc jmc$print_file                                                                                         
*copyc jmc$system_family                                                                                      
*copyc jmc$terminate_output                                                                                   
*copyc jme$internal_work_area_overflow                                                                        
*copyc jme$job_history_conditions                                                                             
*copyc jme$queued_file_conditions                                                                             
*copyc jme$not_validated_for_copof                                                                            
*copyc jme$no_space_for_file                                                                                  
*copyc jme$operator_queue_restore                                                                             
*copyc jme$work_area_too_small                                                                                
*copyc jmk$keypoints                                                                                          
*copyc jml$user_id                                                                                            
*copyc jmt$attribute_keys_set                                                                                 
*copyc jmt$destination_usage                                                                                  
*copyc jmt$name                                                                                               
*copyc jmt$name_list                                                                                          
*copyc jmt$output_attribute_changes                                                                           
*copyc jmt$output_attribute_options                                                                           
*copyc jmt$output_attribute_results                                                                           
*copyc jmt$output_count_range                                                                                 
*copyc jmt$output_counts                                                                                      
*copyc jmt$output_descriptor                                                                                  
*copyc jmt$output_disposition_keys                                                                            
*copyc jmt$output_mechanism                                                                                   
*copyc jmt$output_state_set                                                                                   
*copyc jmt$output_status_count                                                                                
*copyc jmt$output_status_options                                                                              
*copyc jmt$output_status_results                                                                              
*copyc jmt$output_status_updates                                                                              
*copyc jmt$output_submission_options                                                                          
*copyc jmt$output_system_id                                                                                   
*copyc jmt$output_system_label                                                                                
*copyc jmt$output_termination_options                                                                         
*copyc jmt$queue_file_password                                                                                
*copyc jmt$queue_file_path                                                                                    
*copyc jmt$release_output_file_list                                                                           
*copyc jmt$system_supplied_name                                                                               
*copyc jmt$user_supplied_name                                                                                 
*copyc ofe$error_codes                                                                                        
*copyc osc$dual_state_batch                                                                                   
*copyc osc$space_unavailable_condition                                                                        
*copyc osd$virtual_address                                                                                    
*copyc oss$task_private                                                                                       
*copyc ost$caller_identifier                                                                                  
*copyc ost$date_time                                                                                          
*copyc ost$status                                                                                             
*copyc ost$user_identification                                                                                
*copyc pmt$entry_point_reference                                                                              
?? POP ??                                                                                                     
*copyc amp$get_file_attributes                                                                                
*copyc amp$return                                                                                             
*copyc avp$get_capability                                                                                     
*copyc avp$ring_nominal                                                                                       
*copyc avp$system_administrator                                                                               
*copyc avp$system_displays                                                                                    
*copyc avp$system_operator                                                                                    
*copyc bap$set_local_name_abnormal                                                                            
*copyc bap$validate_file_identifier                                                                           
*copyc clp$convert_string_to_file                                                                             
*copyc clp$get_fs_path_elements                                                                               
*copyc clp$trimmed_string_size                                                                                
*copyc clp$validate_name                                                                                      
*copyc fsp$close_file                                                                                         
*copyc fsp$copy_file                                                                                          
*copyc fsp$open_and_get_type_of_copy                                                                          
*copyc fsp$open_file                                                                                          
*copyc fsp$path_element                                                                                       
*copyc fsp$subsystem_copy_file                                                                                
*copyc ifp$invoke_pause_utility                                                                               
*copyc jmp$convert_date_time_dif_to_us                                                                        
*copyc jmp$copy_seq_to_result_array                                                                           
*copyc jmp$emit_communication_stat                                                                            
*copyc jmp$emit_job_history_statistics                                                                        
*copyc jmp$general_purpose_cluster_rpc                                                                        
*copyc jmp$get_attribute_name                                                                                 
*copyc jmp$get_data_packet_size                                                                               
*copyc jmp$get_jm_work_area                                                                                   
*copyc jmp$get_result_size                                                                                    
*copyc jmp$system_job                                                                                         
*copyc jmp$validate_attribute_options                                                                         
*copyc jmp$validate_name                                                                                      
*copyc jmp$validate_status_options                                                                            
*copyc mmp$create_scratch_segment                                                                             
*copyc mmp$delete_scratch_segment                                                                             
*copyc osp$append_status_parameter                                                                            
*copyc osp$disestablish_cond_handler                                                                          
*copyc osp$establish_block_exit_hndlr                                                                         
*copyc osp$establish_condition_handler                                                                        
*copyc osp$force_access_violation                                                                             
*copyc osp$generate_log_message                                                                               
*copyc osp$get_status_condition_name                                                                          
*copyc osp$is_caller_system_privileged                                                                        
*copyc osp$set_status_abnormal                                                                                
*copyc osp$set_status_condition                                                                               
*copyc osp$set_status_from_condition                                                                          
*copyc osp$verify_system_privilege                                                                            
*copyc pfp$attach                                                                                             
*copyc pfp$begin_system_authority                                                                             
*copyc pfp$define                                                                                             
*copyc pfp$define_catalog                                                                                     
*copyc pfp$end_system_authority                                                                               
*copyc pfp$purge                                                                                              
*copyc pmp$compute_date_time                                                                                  
*copyc pmp$compute_date_time_increment                                                                        
*copyc pmp$continue_to_cause                                                                                  
*copyc pmp$get_compact_date_time                                                                              
*copyc pmp$get_job_mode                                                                                       
*copyc pmp$get_job_names                                                                                      
*copyc pmp$get_mainframe_id                                                                                   
*copyc pmp$get_microsecond_clock                                                                              
*copyc pmp$get_unique_name                                                                                    
*copyc pmp$get_user_identification                                                                            
*copyc pmp$ready_task                                                                                         
*copyc qfp$acquire_modified_output                                                                            
*copyc qfp$acquire_new_output                                                                                 
*copyc qfp$assign_system_supplied_name                                                                        
*copyc qfp$change_output_attributes                                                                           
*copyc qfp$get_application_name                                                                               
*copyc qfp$get_output_counts                                                                                  
*copyc qfp$get_output_status                                                                                  
*copyc qfp$print_file                                                                                         
*copyc qfp$purge_expired_file                                                                                 
*copyc qfp$purge_printed_file                                                                                 
*copyc qfp$read_output_system_label                                                                           
*copyc qfp$rebuild_output_queue                                                                               
*copyc qfp$register_output_application                                                                        
*copyc qfp$release_output_files                                                                               
*copyc qfp$set_output_completed                                                                               
*copyc qfp$set_output_initiated                                                                               
*copyc qfp$terminate_acquired_output                                                                          
*copyc qfp$terminate_output                                                                                   
*copyc qfp$validate_output_file_access                                                                        
*copyc qfp$write_output_system_label                                                                          
*copyc rhp$get_link_user_descriptor                                                                           
*copyc syp$system_is_idling                                                                                   
*copyc amv$nil_file_identifier                                                                                
*copyc avv$account_name                                                                                       
*copyc avv$project_name                                                                                       
*copyc jmv$default_job_attributes                                                                             
*copyc jmv$enable_queue_file_access                                                                           
*copyc jmv$jcb                                                                                                
*copyc jmv$job_attributes                                                                                     
*copyc jmv$job_disposition_code                                                                               
*copyc jmv$job_history_active                                                                                 
*copyc jmv$job_management_work_area_p                                                                         
*copyc jmv$kjlx_p                                                                                             
*copyc jmv$known_output_list                                                                                  
*copyc osv$lower_to_upper                                                                                     
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'Global Declarations Declared by this Module', EJECT ??                                        
                                                                                                              
  TYPE                                                                                                        
    mainframe_chaoa_parameters = record                                                                       
      privileged_job: boolean,                                                                                
      system_file_name: jmt$system_supplied_name,                                                             
      output_destination_usage: jmt$destination_usage,                                                        
      attribute_change_count: ost$non_negative_integers,                                                      
    recend;                                                                                                   
                                                                                                              
  TYPE                                                                                                        
    mainframe_getoa_parameters = record                                                                       
      status_option_count: ost$non_negative_integers,                                                         
      attach_file: boolean,                                                                                   
      results_keys_count: ost$non_negative_integers,                                                          
    recend;                                                                                                   
                                                                                                              
  TYPE                                                                                                        
    mainframe_getos_parameters = record                                                                       
      user_identification: ost$user_identification,                                                           
      privileged_job: boolean,                                                                                
      status_option_count: ost$non_negative_integers,                                                         
      status_results_count: ost$non_negative_integers,                                                        
    recend;                                                                                                   
                                                                                                              
  TYPE                                                                                                        
    mainframe_tero_parameters = record                                                                        
      system_file_name: jmt$system_supplied_name,                                                             
      reason: ost$name,                                                                                       
      output_state_set: jmt$output_state_set,                                                                 
    recend;                                                                                                   
                                                                                                              
  VAR                                                                                                         
    task_has_registered_application: [STATIC, oss$task_private] boolean := FALSE;                             
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'acquire_output', EJECT ??                                                                     
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this request is to acquire a file from the output queue.  What this means is to attach     
{ the file and read its output system label information.  A subset of this information is then placed in      
{ a descriptor that describes the file being acquired.                                                        
                                                                                                              
  PROCEDURE acquire_output                                                                                    
    (    output_destination_usage: jmt$destination_usage;                                                     
         new_output: boolean;                                                                                 
     VAR output_descriptor: jmt$output_descriptor;                                                            
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      ignore_status: ost$status,                                                                              
      system_label: jmt$output_system_label,                                                                  
      output_name: jmt$name,                                                                                  
      local_file: boolean,                                                                                    
      old_file: boolean,                                                                                      
      contains_data: boolean,                                                                                 
      file_attributes: ^amt$get_attributes,                                                                   
      local_file_name: amt$local_file_name,                                                                   
      usage_selections: pft$usage_selections,                                                                 
      path_p: ^pft$path,                                                                                      
      cycle_selector: pft$cycle_selector,                                                                     
      password: pft$password;                                                                                 
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      pfp$end_system_authority;                                                                               
      IF status.normal THEN                                                                                   
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);      
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
    ignore_status.normal := TRUE;                                                                             
                                                                                                              
    IF syp$system_is_idling () THEN                                                                           
      osp$set_status_abnormal (jmc$job_management_id, jme$output_queue_is_empty, '', status);                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Acquire the file                                                                                            
                                                                                                              
    IF new_output THEN                                                                                        
      qfp$acquire_new_output (output_destination_usage, output_descriptor, status);                           
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
    ELSE                                                                                                      
      qfp$acquire_modified_output (output_destination_usage, output_descriptor, status);                      
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Attach the file so we can read the system label and get the attributes                                      
                                                                                                              
    pmp$get_unique_name (local_file_name, status);                                                            
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    determine_file_path (output_destination_usage, output_descriptor.system_file_name, path_p);               
    cycle_selector.cycle_option := pfc$specific_cycle;                                                        
    cycle_selector.cycle_number := 1;                                                                         
    password := osc$null_name;                                                                                
    usage_selections := $pft$usage_selections [pfc$read];                                                     
                                                                                                              
    osp$establish_block_exit_hndlr (^handle_block_exit);                                                      
    pfp$begin_system_authority;                                                                               
    pfp$attach (local_file_name, path_p^, cycle_selector, password, usage_selections, usage_selections,       
          pfc$wait, status);                                                                                  
    pfp$end_system_authority;                                                                                 
    osp$disestablish_cond_handler;                                                                            
    IF NOT status.normal THEN                                                                                 
      output_name.kind := jmc$system_supplied_name;                                                           
      output_name.system_supplied_name := output_descriptor.system_file_name;                                 
      jmp$terminate_output (output_name, NIL, ignore_status);                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Read the output file's system label                                                                         
                                                                                                              
    qfp$read_output_system_label (local_file_name, system_label, status);                                     
    IF NOT status.normal THEN                                                                                 
      amp$return (local_file_name, ignore_status);                                                            
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Get the necessary file attributes for the output file                                                       
                                                                                                              
    PUSH file_attributes: [1 .. 4];                                                                           
    file_attributes^ [1].key := amc$file_length;                                                              
    file_attributes^ [2].key := amc$page_format;                                                              
    file_attributes^ [3].key := amc$page_length;                                                              
    file_attributes^ [4].key := amc$page_width;                                                               
    amp$get_file_attributes (local_file_name, file_attributes^, local_file, old_file, contains_data, status); 
    IF NOT status.normal THEN                                                                                 
      amp$return (local_file_name, ignore_status);                                                            
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Release the file in case somebody needs it for write access                                                 
                                                                                                              
    amp$return (local_file_name, status);                                                                     
                                                                                                              
{ Set up the fields in the output descriptor                                                                  
                                                                                                              
    output_descriptor.comment_banner := system_label.comment_banner;                                          
    output_descriptor.control_family := system_label.output_controller.family;                                
    output_descriptor.control_user := system_label.output_controller.user;                                    
    output_descriptor.copies := system_label.copy_count;                                                      
    output_descriptor.copies_printed := system_label.copies_printed;                                          
    output_descriptor.data_declaration := system_label.data_declaration;                                      
    output_descriptor.data_mode := system_label.data_mode;                                                    
    output_descriptor.device := system_label.device;                                                          
    output_descriptor.device_type := system_label.device_type;                                                
    output_descriptor.disposition_code := system_label.disposition_code;                                      
    IF system_label.output_destination_usage = jmc$dual_state_usage THEN                                      
      output_descriptor.dual_state_account := system_label.dual_state_account;                                
      output_descriptor.dual_state_family_name := system_label.dual_state_family_name;                        
      output_descriptor.dual_state_password := system_label.dual_state_password;                              
      output_descriptor.dual_state_project := system_label.dual_state_project;                                
      output_descriptor.dual_state_user := system_label.dual_state_user;                                      
    ELSE                                                                                                      
      output_descriptor.dual_state_account := osc$null_name;                                                  
      output_descriptor.dual_state_family_name := osc$null_name;                                              
      output_descriptor.dual_state_password := osc$null_name;                                                 
      output_descriptor.dual_state_project := osc$null_name;                                                  
      output_descriptor.dual_state_user := osc$null_name;                                                     
    IFEND;                                                                                                    
    output_descriptor.earliest_print_time := system_label.earliest_print_time;                                
    output_descriptor.external_characteristics := system_label.external_characteristics;                      
    output_descriptor.file_position := system_label.file_position;                                            
    output_descriptor.file_size := file_attributes^ [1].file_length;                                          
    output_descriptor.forms_code := system_label.forms_code;                                                  
    output_descriptor.implicit_routing_text := system_label.implicit_routing_text;                            
    output_descriptor.latest_print_time := system_label.latest_print_time;                                    
    output_descriptor.login_account := system_label.login_account;                                            
    output_descriptor.login_family := system_label.login_user_identification.family;                          
    output_descriptor.login_project := system_label.login_project;                                            
    output_descriptor.login_user := system_label.login_user_identification.user;                              
    output_descriptor.originating_application_name := system_label.originating_application_name;              
    output_descriptor.output_class := system_label.output_class;                                              
    output_descriptor.output_destination := system_label.output_destination;                                  
    output_descriptor.output_destination_family := system_label.output_destination_family;                    
    output_descriptor.output_destination_usage := system_label.output_destination_usage;                      
    output_descriptor.output_disposition_key := system_label.output_disposition_key;                          
    output_descriptor.output_priority := system_label.output_priority;                                        
    output_descriptor.output_submission_time := system_label.output_submission_time;                          
    output_descriptor.page_format := file_attributes^ [2].page_format;                                        
    output_descriptor.page_length := file_attributes^ [3].page_length;                                        
    output_descriptor.page_width := file_attributes^ [4].page_width;                                          
    output_descriptor.purge_delay := system_label.purge_delay;                                                
    output_descriptor.remote_host_directive := system_label.remote_host_directive;                            
    output_descriptor.routing_banner := system_label.routing_banner;                                          
    output_descriptor.site_information := system_label.site_information;                                      
    output_descriptor.source_logical_id := system_label.source_logical_id;                                    
    output_descriptor.station := system_label.station;                                                        
    output_descriptor.station_operator := system_label.station_operator;                                      
    output_descriptor.system_file_name := system_label.system_file_name;                                      
    output_descriptor.system_job_name := system_label.system_job_name;                                        
    output_descriptor.system_routing_text := system_label.system_routing_text;                                
    output_descriptor.user_file_name := system_label.user_file_name;                                          
    output_descriptor.user_information := system_label.user_information;                                      
    output_descriptor.user_job_name := system_label.user_job_name;                                            
    output_descriptor.vertical_print_density := system_label.vertical_print_density;                          
    output_descriptor.vfu_load_procedure := system_label.vfu_load_procedure;                                  
  PROCEND acquire_output;                                                                                     
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[INLINE] determine_file_path', EJECT ??                                                       
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this request is to PUSH the correct path name for an output file on the requestors         
{ stack.                                                                                                      
{                                                                                                             
{ NOTES:                                                                                                      
{   This procedure MUST be INLINE.                                                                            
                                                                                                              
  PROCEDURE [INLINE] determine_file_path                                                                      
    (    output_destination_usage: jmt$destination_usage;                                                     
         system_file_name: jmt$system_supplied_name;                                                          
     VAR path_p: ^pft$path);                                                                                  
                                                                                                              
    PUSH path_p: [1 .. 4];                                                                                    
    path_p^ [1] := jmc$system_family;                                                                         
    path_p^ [2] := jmc$system_user;                                                                           
    determine_file_catalog (output_destination_usage, path_p^ [3]);                                           
    path_p^ [4] := system_file_name;                                                                          
  PROCEND determine_file_path;                                                                                
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[INLINE] determine_file_catalog', EJECT ??                                                    
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this request is to determine which catalog a file is in based on its output                
{ destination usage                                                                                           
                                                                                                              
  PROCEDURE [INLINE] determine_file_catalog                                                                   
    (    output_destination_usage: jmt$destination_usage;                                                     
     VAR output_catalog: ost$name);                                                                           
                                                                                                              
    IF (output_destination_usage = jmc$dual_state_usage) OR (output_destination_usage = jmc$private_usage) OR 
          (output_destination_usage = jmc$public_usage) THEN                                                  
      output_catalog := jmc$job_output_catalog;                                                               
    ELSE                                                                                                      
      output_catalog := jmc$job_output_catalog;                                                               
                                                                                                              
{***  output_catalog := jmc$sf_job_output_catalog;                                                            
                                                                                                              
    IFEND;                                                                                                    
  PROCEND determine_file_catalog;                                                                             
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$acquire_modified_output', EJECT ??                                          
*copy jmh$acquire_modified_output                                                                             
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$acquire_modified_output                                                         
    (    output_destination_usage: jmt$destination_usage;                                                     
     VAR output_descriptor: jmt$output_descriptor;                                                            
     VAR status: ost$status);                                                                                 
                                                                                                              
    status.normal := TRUE;                                                                                    
    #KEYPOINT (osk$entry, 0, jmk$acquire_modified_output);                                                    
                                                                                                              
    acquire_output (output_destination_usage, FALSE, output_descriptor, status);                              
    #KEYPOINT (osk$exit, 0, jmk$acquire_modified_output);                                                     
  PROCEND jmp$acquire_modified_output;                                                                        
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$acquire_new_output', EJECT ??                                               
*copy jmh$acquire_new_output                                                                                  
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$acquire_new_output                                                              
    (    output_destination_usage: jmt$destination_usage;                                                     
     VAR output_descriptor: jmt$output_descriptor;                                                            
     VAR status: ost$status);                                                                                 
                                                                                                              
    status.normal := TRUE;                                                                                    
    #KEYPOINT (osk$entry, 0, jmk$acquire_new_output);                                                         
                                                                                                              
    acquire_output (output_destination_usage, TRUE, output_descriptor, status);                               
    #KEYPOINT (osk$exit, 0, jmk$acquire_new_output);                                                          
  PROCEND jmp$acquire_new_output;                                                                             
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$activate_output', EJECT ??                                                  
*copy jmh$activate_output                                                                                     
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$activate_output                                                                 
    (    system_file_name: jmt$system_supplied_name;                                                          
         subcatalog_name: ost$name;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
    status.normal := TRUE;                                                                                    
    IF NOT (avp$system_administrator () OR avp$system_operator ()) THEN                                       
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_administration OR system_operation', status);
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    jmp$rebuild_output_queue (system_file_name, subcatalog_name, status);                                     
                                                                                                              
  PROCEND jmp$activate_output;                                                                                
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$change_output_attributes', EJECT ??                                         
*copy jmh$change_output_attributes                                                                            
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$change_output_attributes                                                        
    (    output_name: jmt$name;                                                                               
         output_attribute_changes: ^jmt$output_attribute_changes;                                             
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      change_index: integer,                                                                                  
      ignore_status: ost$status,                                                                              
      jm_work_area_p: ^jmt$work_area,                                                                         
      local_attribute_changes_p: ^jmt$output_attribute_changes,                                               
      local_parameters_p: ^mainframe_chaoa_parameters,                                                        
      local_purge_delay_p: ^jmt$time_increment,                                                               
      local_remote_host_directive_p: ^jmt$remote_host_directive,                                              
      local_site_information_p: ^jmt$site_information,                                                        
      local_user_information_p: ^jmt$user_information,                                                        
      mainframes_processed: jmt$rpc_mainframes_processed,                                                     
      number_of_data_packets: ost$non_negative_integers,                                                      
      number_of_outputs_found: jmt$output_status_count,                                                       
      output_status_options_p: ^jmt$output_status_options,                                                    
      output_status_results_p: ^jmt$output_status_results,                                                    
      privileged_job: boolean,                                                                                
      scl_name: ost$name,                                                                                     
      scratch_segment: amt$segment_pointer,                                                                   
      status_results_keys_p: ^jmt$results_keys,                                                               
      status_result_size: ost$segment_length,                                                                 
      status_work_area_p: ^SEQ ( * ),                                                                         
      target_mainframe_reached: boolean,                                                                      
      target_options_p: ^SEQ ( * ),                                                                           
      target_options_size: ost$non_negative_integers,                                                         
      valid_name: boolean;                                                                                    
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      CASE condition.selector OF                                                                              
      = pmc$block_exit_processing =                                                                           
        mmp$delete_scratch_segment (scratch_segment, ignore_status);                                          
        IF status.normal THEN                                                                                 
          osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);    
        IFEND;                                                                                                
                                                                                                              
      ELSE                                                                                                    
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);                               
      CASEND;                                                                                                 
    PROCEND handle_block_exit;                                                                                
?? OLDTITLE ??                                                                                                
?? EJECT ??                                                                                                   
                                                                                                              
    #KEYPOINT (osk$entry, 0, jmk$change_output_attributes);                                                   
    ignore_status.normal := TRUE;                                                                             
    status.normal := TRUE;                                                                                    
                                                                                                              
    privileged_job := avp$system_operator ();                                                                 
                                                                                                              
    PUSH output_status_options_p: [1 .. 3];                                                                   
    output_status_options_p^ [1].key := jmc$name_list;                                                        
    PUSH output_status_options_p^ [1].name_list: [1 .. 1];                                                    
    output_status_options_p^ [1].name_list^ [1] := output_name;                                               
    output_status_options_p^ [2].key := jmc$privilege;                                                        
    IF privileged_job THEN                                                                                    
      output_status_options_p^ [2].privilege := jmc$privileged;                                               
    ELSE                                                                                                      
      output_status_options_p^ [2].privilege := jmc$not_privileged;                                           
    IFEND;                                                                                                    
    output_status_options_p^ [3].key := jmc$continue_request_to_servers;                                      
    output_status_options_p^ [3].continue_request_to_servers := TRUE;                                         
                                                                                                              
    PUSH status_results_keys_p: [1 .. 4];                                                                     
    status_results_keys_p^ [1] := jmc$system_file_name;                                                       
    status_results_keys_p^ [2] := jmc$output_state;                                                           
    status_results_keys_p^ [3] := jmc$output_destination_usage;                                               
    status_results_keys_p^ [4] := jmc$client_mainframe_id;                                                    
                                                                                                              
{ If we are able to status the output file, we have control over the file                                     
{ so we can change the attributes of the file                                                                 
                                                                                                              
    jmp$get_result_size ({number_of_items} 1, #SEQ (status_results_keys_p^), status_result_size);             
    PUSH status_work_area_p: [[REP status_result_size OF cell]];                                              
    RESET status_work_area_p;                                                                                 
                                                                                                              
    jmp$get_output_status (output_status_options_p, status_results_keys_p, status_work_area_p,                
          output_status_results_p, number_of_outputs_found, status);                                          
    IF NOT status.normal THEN                                                                                 
      IF status.condition = jme$work_area_too_small THEN                                                      
        IF output_name.kind = jmc$system_supplied_name THEN { Can't ever happen                               
          osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_name,                                 
                output_name.system_supplied_name, status);                                                    
        ELSE                                                                                                  
          osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_name, output_name.user_supplied_name, 
                status);                                                                                      
        IFEND;                                                                                                
      IFEND;                                                                                                  
      #KEYPOINT (osk$exit, 0, jmk$change_output_attributes);                                                  
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF output_status_results_p^ [1]^ [2].output_state IN $jmt$output_state_set                                
          [jmc$initiated_output, jmc$terminated_output] THEN                                                  
                                                                                                              
{ In order for the output state to be terminated, the file must either be printing or the application         
{ responsible for the file will momentarily return the file to queue file management.  In any case,           
{ the same error (jme$output_is_initiated) is reported since the later is not likely to occur.                
                                                                                                              
      IF output_name.kind = jmc$system_supplied_name THEN                                                     
        osp$set_status_abnormal (jmc$job_management_id, jme$output_is_initiated,                              
              output_name.system_supplied_name, status);                                                      
      ELSE                                                                                                    
        osp$set_status_abnormal (jmc$job_management_id, jme$output_is_initiated,                              
              output_name.user_supplied_name, status);                                                        
      IFEND;                                                                                                  
      #KEYPOINT (osk$exit, 0, jmk$change_output_attributes);                                                  
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Pack up the required information and pass it to the general purpose request.                                
                                                                                                              
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, scratch_segment, status);            
    IF NOT status.normal THEN                                                                                 
      #KEYPOINT (osk$exit, 0, jmk$change_output_attributes);                                                  
      RETURN;                                                                                                 
    IFEND;                                                                                                    
    RESET scratch_segment.sequence_pointer;                                                                   
                                                                                                              
    osp$establish_block_exit_hndlr (^handle_block_exit);                                                      
                                                                                                              
    NEXT local_parameters_p IN scratch_segment.sequence_pointer;                                              
                                                                                                              
    local_parameters_p^.privileged_job := privileged_job;                                                     
    local_parameters_p^.system_file_name := output_status_results_p^ [1]^ [1].system_file_name;               
    local_parameters_p^.output_destination_usage := output_status_results_p^ [1]^ [3].                        
          output_destination_usage;                                                                           
                                                                                                              
    IF output_attribute_changes = NIL THEN                                                                    
      local_parameters_p^.attribute_change_count := 0;                                                        
    ELSE                                                                                                      
      local_parameters_p^.attribute_change_count := UPPERBOUND (output_attribute_changes^);                   
      NEXT local_attribute_changes_p: [1 .. local_parameters_p^.attribute_change_count] IN                    
            scratch_segment.sequence_pointer;                                                                 
                                                                                                              
      IF local_attribute_changes_p <> NIL THEN                                                                
                                                                                                              
      /validate_changes/                                                                                      
        FOR change_index := 1 TO UPPERBOUND (output_attribute_changes^) DO                                    
          local_attribute_changes_p^ [change_index].key := output_attribute_changes^ [change_index].key;      
                                                                                                              
          CASE output_attribute_changes^ [change_index].key OF                                                
          = jmc$comment_banner =                                                                              
            local_attribute_changes_p^ [change_index].comment_banner :=                                       
                  output_attribute_changes^ [change_index].comment_banner;                                    
                                                                                                              
          = jmc$copies =                                                                                      
            local_attribute_changes_p^ [change_index].copies :=                                               
                  output_attribute_changes^ [change_index].copies;                                            
                                                                                                              
          = jmc$device =                                                                                      
            clp$validate_name (output_attribute_changes^ [change_index].device, scl_name, valid_name);        
            IF NOT valid_name THEN                                                                            
              osp$set_status_abnormal ('CL', cle$improper_name,                                               
                    output_attribute_changes^ [change_index].device, status);                                 
              EXIT /validate_changes/;                                                                        
            IFEND;                                                                                            
            local_attribute_changes_p^ [change_index].device := scl_name;                                     
                                                                                                              
          = jmc$earliest_print_time =                                                                         
            local_attribute_changes_p^ [change_index].earliest_print_time :=                                  
                  output_attribute_changes^ [change_index].earliest_print_time;                               
                                                                                                              
          = jmc$external_characteristics =                                                                    
            #TRANSLATE (osv$lower_to_upper, output_attribute_changes^ [change_index].external_characteristics,
                  local_attribute_changes_p^ [change_index].external_characteristics);                        
                                                                                                              
          = jmc$forms_code =                                                                                  
            #TRANSLATE (osv$lower_to_upper, output_attribute_changes^ [change_index].forms_code,              
                  local_attribute_changes_p^ [change_index].forms_code);                                      
                                                                                                              
          = jmc$latest_print_time =                                                                           
            local_attribute_changes_p^ [change_index].latest_print_time :=                                    
                  output_attribute_changes^ [change_index].latest_print_time;                                 
                                                                                                              
          = jmc$null_attribute =                                                                              
            ;                                                                                                 
                                                                                                              
          = jmc$output_class =                                                                                
            clp$validate_name (output_attribute_changes^ [change_index].output_class, scl_name, valid_name);  
            IF NOT valid_name THEN                                                                            
              osp$set_status_abnormal ('CL', cle$improper_name,                                               
                    output_attribute_changes^ [change_index].output_class, status);                           
              EXIT /validate_changes/;                                                                        
            IFEND;                                                                                            
            local_attribute_changes_p^ [change_index].output_class := scl_name;                               
                                                                                                              
          = jmc$output_deferred_by_operator =                                                                 
            IF NOT privileged_job THEN                                                                        
              osp$set_status_abnormal (jmc$job_management_id, jme$requires_operator_privilege,                
                    'OUTPUT_DEFERRED_BY_OPERATOR', status);                                                   
              EXIT /validate_changes/;                                                                        
            IFEND;                                                                                            
            local_attribute_changes_p^ [change_index].output_deferred_by_operator :=                          
                  output_attribute_changes^ [change_index].output_deferred_by_operator;                       
                                                                                                              
          = jmc$output_deferred_by_user =                                                                     
            local_attribute_changes_p^ [change_index].output_deferred_by_user :=                              
                  output_attribute_changes^ [change_index].output_deferred_by_user;                           
                                                                                                              
          = jmc$output_destination =                                                                          
            clp$validate_name (output_attribute_changes^ [change_index].output_destination, scl_name,         
                  valid_name);                                                                                
            IF valid_name THEN                                                                                
              local_attribute_changes_p^ [change_index].output_destination := scl_name;                       
            ELSE                                                                                              
              #TRANSLATE (osv$lower_to_upper, output_attribute_changes^ [change_index].output_destination,    
                    local_attribute_changes_p^ [change_index].output_destination);                            
            IFEND;                                                                                            
                                                                                                              
          = jmc$output_destination_family =                                                                   
            clp$validate_name (output_attribute_changes^ [change_index].output_destination_family, scl_name,  
                  valid_name);                                                                                
            IF NOT valid_name THEN                                                                            
              osp$set_status_abnormal ('CL', cle$improper_name,                                               
                    output_attribute_changes^ [change_index].output_destination_family, status);              
              EXIT /validate_changes/;                                                                        
            IFEND;                                                                                            
            local_attribute_changes_p^ [change_index].output_destination_family := scl_name;                  
                                                                                                              
          = jmc$output_destination_usage =                                                                    
            clp$validate_name (output_attribute_changes^ [change_index].output_destination_usage, scl_name,   
                  valid_name);                                                                                
            IF NOT valid_name THEN                                                                            
              osp$set_status_abnormal ('CL', cle$improper_name,                                               
                    output_attribute_changes^ [change_index].output_destination_usage, status);               
              EXIT /validate_changes/;                                                                        
            IFEND;                                                                                            
            local_attribute_changes_p^ [change_index].output_destination_usage := scl_name;                   
                                                                                                              
          = jmc$output_priority =                                                                             
            clp$validate_name (output_attribute_changes^ [change_index].output_priority, scl_name,            
                  valid_name);                                                                                
            IF NOT valid_name THEN                                                                            
              osp$set_status_abnormal ('CL', cle$improper_name,                                               
                    output_attribute_changes^ [change_index].output_priority, status);                        
              EXIT /validate_changes/;                                                                        
            IFEND;                                                                                            
            local_attribute_changes_p^ [change_index].output_priority := scl_name;                            
                                                                                                              
          = jmc$purge_delay =                                                                                 
                                                                                                              
{ If the purge delay has changed, the output disposition time has changed.                                    
                                                                                                              
            NEXT local_purge_delay_p IN scratch_segment.sequence_pointer;                                     
            local_purge_delay_p^ := output_attribute_changes^ [change_index].purge_delay^;                    
                                                                                                              
          = jmc$remote_host_directive =                                                                       
            NEXT local_remote_host_directive_p IN scratch_segment.sequence_pointer;                           
            local_remote_host_directive_p^ := output_attribute_changes^ [change_index].remote_host_directive^;
                                                                                                              
          = jmc$reprint_disposition =                                                                         
            local_attribute_changes_p^ [change_index].reprint_disposition :=                                  
                  output_attribute_changes^ [change_index].reprint_disposition;                               
                                                                                                              
          = jmc$routing_banner =                                                                              
            local_attribute_changes_p^ [change_index].routing_banner :=                                       
                  output_attribute_changes^ [change_index].routing_banner;                                    
                                                                                                              
          = jmc$site_information =                                                                            
                                                                                                              
            IF avp$system_operator () THEN                                                                    
              NEXT local_site_information_p IN scratch_segment.sequence_pointer;                              
              local_site_information_p^ := output_attribute_changes^ [change_index].site_information^;        
            ELSE                                                                                              
              osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_operation', status);                 
              EXIT /validate_changes/;                                                                        
            IFEND;                                                                                            
                                                                                                              
          = jmc$station =                                                                                     
            clp$validate_name (output_attribute_changes^ [change_index].station, scl_name, valid_name);       
            IF NOT valid_name THEN                                                                            
              osp$set_status_abnormal ('CL', cle$improper_name,                                               
                    output_attribute_changes^ [change_index].station, status);                                
              EXIT /validate_changes/;                                                                        
            IFEND;                                                                                            
            local_attribute_changes_p^ [change_index].station := scl_name;                                    
                                                                                                              
          = jmc$station_operator =                                                                            
            clp$validate_name (output_attribute_changes^ [change_index].station_operator, scl_name,           
                  valid_name);                                                                                
            IF NOT valid_name THEN                                                                            
              osp$set_status_abnormal ('CL', cle$improper_name,                                               
                    output_attribute_changes^ [change_index].station_operator, status);                       
              EXIT /validate_changes/;                                                                        
            IFEND;                                                                                            
            local_attribute_changes_p^ [change_index].station_operator := scl_name;                           
                                                                                                              
          = jmc$user_information =                                                                            
            NEXT local_user_information_p IN scratch_segment.sequence_pointer;                                
            local_user_information_p^ := output_attribute_changes^ [change_index].user_information^;          
                                                                                                              
          = jmc$vertical_print_density =                                                                      
            local_attribute_changes_p^ [change_index].vertical_print_density :=                               
                  output_attribute_changes^ [change_index].vertical_print_density;                            
                                                                                                              
            IF local_attribute_changes_p^ [change_index].vertical_print_density >                             
                  jmc$vertical_print_density_6 THEN                                                           
              local_attribute_changes_p^ [change_index].vertical_print_density :=                             
                    jmc$vertical_print_density_8;                                                             
                                                                                                              
            ELSEIF local_attribute_changes_p^ [change_index].vertical_print_density =                         
                  jmc$vertical_print_density_file THEN                                                        
              jmp$get_attribute_name (output_attribute_changes^ [change_index].key, scl_name);                
              osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter_value, scl_name, status); 
              osp$append_status_parameter (osc$status_parameter_delimiter, 'OUTPUT_ATTRIBUTE_CHANGES',        
                    status);                                                                                  
              osp$append_status_parameter (osc$status_parameter_delimiter, jmc$change_output_attributes,      
                    status);                                                                                  
              EXIT /validate_changes/;                                                                        
            IFEND;                                                                                            
                                                                                                              
          = jmc$vfu_load_procedure =                                                                          
            IF output_attribute_changes^ [change_index].vfu_load_procedure <> osc$null_name THEN              
              clp$validate_name (output_attribute_changes^ [change_index].vfu_load_procedure, scl_name,       
                    valid_name);                                                                              
              IF NOT valid_name THEN                                                                          
                osp$set_status_abnormal ('CL', cle$improper_name,                                             
                      output_attribute_changes^ [change_index].vfu_load_procedure, status);                   
                EXIT /validate_changes/;                                                                      
              IFEND;                                                                                          
              local_attribute_changes_p^ [change_index].vfu_load_procedure := scl_name;                       
            ELSE                                                                                              
              local_attribute_changes_p^ [change_index].vfu_load_procedure := osc$null_name;                  
            IFEND;                                                                                            
                                                                                                              
          ELSE                                                                                                
            jmp$get_attribute_name (output_attribute_changes^ [change_index].key, scl_name);                  
            osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);         
            osp$append_status_parameter (osc$status_parameter_delimiter, 'OUTPUT_ATTRIBUTE_CHANGES', status); 
            osp$append_status_parameter (osc$status_parameter_delimiter, jmc$change_output_attributes,        
                  status);                                                                                    
            EXIT /validate_changes/;                                                                          
          CASEND;                                                                                             
        FOREND /validate_changes/;                                                                            
      ELSE                                                                                                    
        osp$set_status_condition (jme$internal_work_area_overflow, status);                                   
      IFEND;                                                                                                  
                                                                                                              
      IF NOT status.normal THEN                                                                               
        mmp$delete_scratch_segment (scratch_segment, ignore_status);                                          
        osp$disestablish_cond_handler;                                                                        
        #KEYPOINT (osk$exit, 0, jmk$change_output_attributes);                                                
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
    IFEND;                                                                                                    
                                                                                                              
{ Call the general purpose RPC processor to change the output attributes.                                     
                                                                                                              
    mainframes_processed.count := 0;                                                                          
    target_options_size := i#current_sequence_position (scratch_segment.sequence_pointer);                    
    RESET scratch_segment.sequence_pointer;                                                                   
    NEXT target_options_p: [[REP target_options_size OF cell]] IN scratch_segment.sequence_pointer;           
    RESET target_options_p;                                                                                   
    jm_work_area_p := NIL;                                                                                    
    jmp$general_purpose_cluster_rpc (output_status_results_p^ [1]^ [4].client_mainframe_id,                   
          jmc$gpro_change_output_attribut, {data_packet_size} 0, mainframes_processed, target_options_p,      
          jm_work_area_p, target_mainframe_reached, mainframes_processed, number_of_data_packets, status);    
                                                                                                              
    mmp$delete_scratch_segment (scratch_segment, ignore_status);                                              
    osp$disestablish_cond_handler;                                                                            
    #KEYPOINT (osk$exit, 0, jmk$change_output_attributes);                                                    
  PROCEND jmp$change_output_attributes;                                                                       
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$close_files_for_copof', EJECT ??                                            
*copy jmh$close_files_for_copof                                                                               
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$close_files_for_copof                                                           
    (    output_fid: amt$file_identifier;                                                                     
         output_lfn: amt$local_file_name;                                                                     
         target_fid: amt$file_identifier;                                                                     
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      file_id_is_valid: boolean,                                                                              
      file_instance: ^bat$task_file_entry,                                                                    
      local_status: ost$status;                                                                               
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
{ Verify that the caller is part of NOS/VE, not an application.                                               
                                                                                                              
    osp$verify_system_privilege;                                                                              
                                                                                                              
{ Close the files and detach the output queue file.                                                           
                                                                                                              
    IF output_fid <> amv$nil_file_identifier THEN                                                             
      bap$validate_file_identifier (output_fid, file_instance, file_id_is_valid);                             
      IF file_id_is_valid THEN                                                                                
        fsp$close_file (output_fid, status);                                                                  
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    amp$return (output_lfn, local_status);                                                                    
    IF status.normal AND (NOT local_status.normal) THEN                                                       
      status := local_status;                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF target_fid <> amv$nil_file_identifier THEN                                                             
      bap$validate_file_identifier (target_fid, file_instance, file_id_is_valid);                             
      IF file_id_is_valid THEN                                                                                
        fsp$close_file (target_fid, local_status);                                                            
        IF status.normal AND (NOT local_status.normal) THEN                                                   
          status := local_status;                                                                             
        IFEND;                                                                                                
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
  PROCEND jmp$close_files_for_copof;                                                                          
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$close_output_file', EJECT ??                                                
*copy jmh$close_output_file                                                                                   
                                                                                                              
{ DESIGN:                                                                                                     
{   This procedure will close a file with the specified file identifier.                                      
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$close_output_file                                                               
    (    file_identifier: amt$file_identifier;                                                                
     VAR status: ost$status);                                                                                 
                                                                                                              
    #KEYPOINT (osk$entry, 0, jmk$close_output_file);                                                          
    status.normal := TRUE;                                                                                    
    fsp$close_file (file_identifier, status);                                                                 
    #KEYPOINT (osk$exit, 0, jmk$close_output_file);                                                           
                                                                                                              
  PROCEND jmp$close_output_file;                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$get_output_counts', EJECT ??                                                
*copy jmh$get_output_counts                                                                                   
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$get_output_counts                                                               
    (VAR output_counts: jmt$output_counts;                                                                    
     VAR status: ost$status);                                                                                 
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    qfp$get_output_counts (output_counts, status);                                                            
  PROCEND jmp$get_output_counts;                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$get_output_attributes', EJECT ??                                            
*copy jmh$get_output_attributes                                                                               
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$get_output_attributes                                                           
    (    output_attribute_options_p: ^jmt$output_attribute_options;                                           
         output_attribute_results_keys_p: ^jmt$results_keys;                                                  
     VAR work_area_p: ^jmt$work_area;                                                                         
     VAR output_attribute_results_p: ^jmt$output_attribute_results;                                           
     VAR number_of_outputs_found: jmt$output_status_count;                                                    
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      continue_request_to_servers: boolean,                                                                   
      good_name: jmt$name,                                                                                    
      ignore_status: ost$status,                                                                              
      jm_work_area_p: ^jmt$work_area,                                                                         
      local_parameters_p: ^mainframe_getoa_parameters,                                                        
      local_results_keys_p: ^jmt$results_keys,                                                                
      local_status_keys_p: ^jmt$results_keys,                                                                 
      local_status_name_count_p: ^ost$non_negative_integers,                                                  
      mainframes_processed: jmt$rpc_mainframes_processed,                                                     
      name_index: integer,                                                                                    
      number_of_data_packets: ost$non_negative_integers,                                                      
      option_index: ost$non_negative_integers,                                                                
      output_status_options_p: ^jmt$output_status_options,                                                    
      privileged_job: boolean,                                                                                
      result_element_size: ost$segment_length,                                                                
      result_index: ost$non_negative_integers,                                                                
      save_work_area_p: ^jmt$work_area,                                                                       
      scl_name: ost$name,                                                                                     
      scratch_segment: amt$segment_pointer,                                                                   
      specified_keys: jmt$attribute_keys_set,                                                                 
      target_mainframe_id: pmt$mainframe_id,                                                                  
      target_mainframe_reached: boolean,                                                                      
      target_options_p: ^SEQ ( * ),                                                                           
      target_options_size: ost$non_negative_integers,                                                         
      valid_name: boolean;                                                                                    
                                                                                                              
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise.                                                                                                    
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      mmp$delete_scratch_segment (scratch_segment, ignore_status);                                            
      IF status.normal THEN                                                                                   
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);      
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
{ BEGIN: jmp$get_output_attributes                                                                            
                                                                                                              
    status.normal := TRUE;                                                                                    
    number_of_outputs_found := 0;                                                                             
    continue_request_to_servers := FALSE;                                                                     
                                                                                                              
    privileged_job := avp$system_operator () OR avp$system_displays ();                                       
                                                                                                              
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, scratch_segment, status);            
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
    RESET scratch_segment.sequence_pointer;                                                                   
                                                                                                              
    osp$establish_block_exit_hndlr (^handle_block_exit);                                                      
                                                                                                              
    NEXT local_parameters_p IN scratch_segment.sequence_pointer;                                              
                                                                                                              
    IF output_attribute_options_p = NIL THEN                                                                  
      local_parameters_p^.status_option_count := 2;                                                           
      NEXT output_status_options_p: [1 .. local_parameters_p^.status_option_count] IN                         
            scratch_segment.sequence_pointer;                                                                 
      option_index := 1;                                                                                      
                                                                                                              
    ELSE                                                                                                      
      save_work_area_p := scratch_segment.sequence_pointer;                                                   
      jmp$validate_attribute_options (jmc$get_output_attributes, 'OUTPUT_ATTRIBUTE_OPTIONS_P',                
            #SEQ (output_attribute_options_p^), { number_of_options_to_add } 2, continue_request_to_servers,  
            local_parameters_p^.status_option_count, scratch_segment.sequence_pointer, status);               
      IF NOT status.normal THEN                                                                               
        mmp$delete_scratch_segment (scratch_segment, ignore_status);                                          
        osp$disestablish_cond_handler;                                                                        
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      NEXT output_status_options_p: [1 .. local_parameters_p^.status_option_count] IN save_work_area_p;       
      option_index := local_parameters_p^.status_option_count - 1;                                            
    IFEND;                                                                                                    
                                                                                                              
    output_status_options_p^ [option_index].key := jmc$privilege;                                             
    IF privileged_job THEN                                                                                    
      output_status_options_p^ [option_index].privilege := jmc$privileged;                                    
    ELSE                                                                                                      
      output_status_options_p^ [option_index].privilege := jmc$not_privileged;                                
    IFEND;                                                                                                    
    output_status_options_p^ [option_index + 1].key := jmc$user_identification;                               
    NEXT output_status_options_p^ [option_index + 1].user_identification IN scratch_segment.sequence_pointer; 
    pmp$get_user_identification (output_status_options_p^ [option_index + 1].user_identification^,            
          ignore_status);                                                                                     
                                                                                                              
    local_parameters_p^.attach_file := FALSE;                                                                 
                                                                                                              
{ Verify that result is only asking for valid fields                                                          
                                                                                                              
    IF output_attribute_results_keys_p = NIL THEN                                                             
      local_parameters_p^.results_keys_count := 0;                                                            
      result_element_size := 0;                                                                               
    ELSE                                                                                                      
      local_parameters_p^.results_keys_count := UPPERBOUND (output_attribute_results_keys_p^);                
                                                                                                              
{ Make two copies of the result keys.  One for what to return, the other a list of values that                
{ the status request is to return.                                                                            
                                                                                                              
      NEXT local_results_keys_p: [1 .. local_parameters_p^.results_keys_count] IN                             
            scratch_segment.sequence_pointer;                                                                 
      NEXT local_status_keys_p: [1 .. local_parameters_p^.results_keys_count] IN                              
            scratch_segment.sequence_pointer;                                                                 
                                                                                                              
      local_results_keys_p^ := output_attribute_results_keys_p^;                                              
      local_status_keys_p^ := output_attribute_results_keys_p^;                                               
                                                                                                              
      FOR result_index := 1 TO local_parameters_p^.results_keys_count DO                                      
        CASE local_results_keys_p^ [result_index] OF                                                          
        = jmc$comment_banner, jmc$copies, jmc$copies_printed, jmc$data_mode, jmc$device, jmc$device_type,     
              jmc$earliest_print_time, jmc$external_characteristics, jmc$file_position, jmc$file_size,        
              jmc$forms_code, jmc$latest_print_time, jmc$login_account, jmc$login_project,                    
              jmc$origin_application_name, jmc$output_class, jmc$output_destination,                          
              jmc$output_destination_family { operator_family } , jmc$output_priority,                        
              jmc$output_submission_time, jmc$purge_delay, jmc$remote_host_directive, jmc$routing_banner,     
              jmc$site_information, jmc$station, jmc$station_operator { operator_user } ,                     
              jmc$user_information, jmc$vertical_print_density, jmc$vfu_load_procedure =                      
          local_parameters_p^.attach_file := TRUE;                                                            
          local_status_keys_p^ [result_index] := jmc$null_attribute;                                          
                                                                                                              
        = jmc$control_family, jmc$control_user, jmc$login_family, jmc$login_user, jmc$null_attribute,         
              jmc$output_deferred_by_operator, jmc$output_deferred_by_user, jmc$output_destination_usage,     
              jmc$output_state, jmc$system_file_name, jmc$system_job_name, jmc$user_file_name,                
              jmc$user_job_name =                                                                             
                                                                                                              
        ELSE                                                                                                  
          jmp$get_attribute_name (local_results_keys_p^ [result_index], scl_name);                            
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'OUTPUT_ATTRIBUTE_RESULTS_KEYS_P',     
                status);                                                                                      
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$get_output_attributes, status);    
          mmp$delete_scratch_segment (scratch_segment, ignore_status);                                        
          osp$disestablish_cond_handler;                                                                      
          RETURN;                                                                                             
        CASEND;                                                                                               
                                                                                                              
      FOREND; { result index                                                                                  
                                                                                                              
      jmp$get_data_packet_size (local_results_keys_p, result_element_size, status);                           
      IF NOT status.normal THEN                                                                               
        mmp$delete_scratch_segment (scratch_segment, ignore_status);                                          
        osp$disestablish_cond_handler;                                                                        
        RETURN;                                                                                               
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    IF continue_request_to_servers THEN                                                                       
      target_mainframe_id := pmc$null_mainframe_id;                                                           
    ELSE                                                                                                      
      pmp$get_mainframe_id (target_mainframe_id, ignore_status);                                              
    IFEND;                                                                                                    
                                                                                                              
    mainframes_processed.count := 0;                                                                          
    target_options_size := i#current_sequence_position (scratch_segment.sequence_pointer);                    
    RESET scratch_segment.sequence_pointer;                                                                   
    NEXT target_options_p: [[REP target_options_size OF cell]] IN scratch_segment.sequence_pointer;           
    RESET target_options_p;                                                                                   
    NEXT jm_work_area_p: [[REP (osc$max_segment_length - target_options_size) OF cell]] IN                    
          scratch_segment.sequence_pointer;                                                                   
    RESET jm_work_area_p;                                                                                     
                                                                                                              
    jmp$general_purpose_cluster_rpc (target_mainframe_id, jmc$gpro_get_output_attributes,                     
          {data_packet_size} result_element_size, mainframes_processed, target_options_p, jm_work_area_p,     
          target_mainframe_reached, mainframes_processed, number_of_data_packets, status);                    
    IF NOT status.normal THEN                                                                                 
      IF status.condition = jme$work_area_too_small THEN                                                      
        number_of_outputs_found := number_of_data_packets;                                                    
      IFEND;                                                                                                  
      mmp$delete_scratch_segment (scratch_segment, ignore_status);                                            
      osp$disestablish_cond_handler;                                                                          
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    number_of_outputs_found := number_of_data_packets;                                                        
    IF number_of_outputs_found = 0 THEN                                                                       
      osp$set_status_condition (jme$no_outputs_were_found, status);                                           
    ELSEIF output_attribute_results_keys_p <> NIL THEN                                                        
      RESET jm_work_area_p;                                                                                   
      save_work_area_p := work_area_p;                                                                        
      jmp$copy_seq_to_result_array (UPPERBOUND (output_attribute_results_keys_p^), number_of_outputs_found,   
            output_attribute_results_keys_p, jm_work_area_p, work_area_p, status);                            
      NEXT output_attribute_results_p: [1 .. number_of_outputs_found] IN save_work_area_p;                    
    IFEND;                                                                                                    
                                                                                                              
    IF status.normal THEN                                                                                     
      mmp$delete_scratch_segment (scratch_segment, status);                                                   
    ELSE                                                                                                      
      mmp$delete_scratch_segment (scratch_segment, ignore_status);                                            
    IFEND;                                                                                                    
                                                                                                              
    osp$disestablish_cond_handler;                                                                            
  PROCEND jmp$get_output_attributes;                                                                          
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$get_output_path_elements', EJECT ??                                         
*copy jmh$get_output_path_elements                                                                            
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$get_output_path_elements                                                        
    (    system_file_name: jmt$system_supplied_name;                                                          
     VAR path: jmt$queue_file_path;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      candidate_name: jmt$name,                                                                               
      good_name: jmt$name,                                                                                    
      local_path_p: ^pft$path,                                                                                
      number_of_outputs_found: jmt$output_status_count,                                                       
      output_status_options_p: ^jmt$output_status_options,                                                    
      output_status_results_p: ^jmt$output_status_results,                                                    
      privileged_job: boolean,                                                                                
      status_results_keys_p: ^jmt$results_keys,                                                               
      status_result_size: ost$segment_length,                                                                 
      status_work_area_p: ^SEQ ( * );                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
    number_of_outputs_found := 0;                                                                             
    privileged_job := avp$system_administrator ();                                                            
    IF NOT privileged_job THEN                                                                                
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_administration', status);                    
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    candidate_name.kind := jmc$system_supplied_name;                                                          
    candidate_name.system_supplied_name := system_file_name;                                                  
    jmp$validate_name (candidate_name, good_name, status);                                                    
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    PUSH output_status_options_p: [1 .. 2];                                                                   
    output_status_options_p^ [1].key := jmc$name_list;                                                        
    PUSH output_status_options_p^ [1].name_list: [1 .. 1];                                                    
    output_status_options_p^ [1].name_list^ [1] := good_name;                                                 
    output_status_options_p^ [2].key := jmc$privilege;                                                        
    output_status_options_p^ [2].privilege := jmc$privileged;                                                 
                                                                                                              
    PUSH status_results_keys_p: [1 .. 2];                                                                     
    status_results_keys_p^ [1] := jmc$system_file_name;                                                       
    status_results_keys_p^ [2] := jmc$output_destination_usage;                                               
                                                                                                              
    jmp$get_result_size ({number_of_items} 1, #SEQ (status_results_keys_p^), status_result_size);             
    PUSH status_work_area_p: [[REP status_result_size OF cell]];                                              
    RESET status_work_area_p;                                                                                 
                                                                                                              
    jmp$get_output_status (output_status_options_p, status_results_keys_p, status_work_area_p,                
          output_status_results_p, number_of_outputs_found, status);                                          
    IF NOT status.normal THEN                                                                                 
      IF status.condition = jme$no_outputs_were_found THEN                                                    
        osp$set_status_abnormal ('JM', jme$name_not_found, system_file_name, status);                         
      IFEND;                                                                                                  
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Determine the output's file path.                                                                           
                                                                                                              
    determine_file_path (output_status_results_p^ [1]^ [2].output_destination_usage,                          
          output_status_results_p^ [1]^ [1].system_file_name, local_path_p);                                  
    path := local_path_p^;                                                                                    
                                                                                                              
  PROCEND jmp$get_output_path_elements;                                                                       
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$get_output_status', EJECT ??                                                
*copy jmh$get_output_status                                                                                   
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$get_output_status                                                               
    (    output_status_options_p: ^jmt$output_status_options;                                                 
         output_status_results_keys_p: ^jmt$results_keys;                                                     
     VAR work_area_p: ^jmt$work_area;                                                                         
     VAR output_status_results_p: ^jmt$output_status_results;                                                 
     VAR number_of_outputs_found: jmt$output_status_count;                                                    
     VAR status: ost$status);                                                                                 
                                                                                                              
    CONST                                                                                                     
      bytes_that_can_be_pushed = 32767;                                                                       
                                                                                                              
    VAR                                                                                                       
      caller_id: ost$caller_identifier,                                                                       
      caller_privileged: boolean,                                                                             
      continue_request_to_servers: boolean,                                                                   
      good_name: jmt$name,                                                                                    
      jm_work_area_p: ^jmt$work_area,                                                                         
      local_parameters_p: ^mainframe_getos_parameters,                                                        
      local_status: ost$status,                                                                               
      local_status_name_count_p: ^ost$non_negative_integers,                                                  
      local_status_options_p: ^jmt$output_status_options,                                                     
      local_status_results_keys_p: ^jmt$results_keys,                                                         
      mainframes_processed: jmt$rpc_mainframes_processed,                                                     
      name_index: integer,                                                                                    
      number_of_data_packets: ost$non_negative_integers,                                                      
      option_index: integer,                                                                                  
      options_p: ^SEQ ( * ),                                                                                  
      options_size: ost$non_negative_integers,                                                                
      output_index: integer,                                                                                  
      privileged_job: boolean,                                                                                
      result_index: integer,                                                                                  
      save_work_area_p: ^jmt$work_area,                                                                       
      scl_name: ost$name,                                                                                     
      seq_output_status_results_size: ost$segment_length,                                                     
      specified_keys: jmt$attribute_keys_set,                                                                 
      target_mainframe_id: pmt$mainframe_id,                                                                  
      target_mainframe_reached: boolean,                                                                      
      target_options_p: ^SEQ ( * ),                                                                           
      user_identification: ost$user_identification,                                                           
      valid_name: boolean;                                                                                    
                                                                                                              
                                                                                                              
    #CALLER_ID (caller_id);                                                                                   
    status.normal := TRUE;                                                                                    
    number_of_outputs_found := 0;                                                                             
    continue_request_to_servers := FALSE;                                                                     
    jm_work_area_p := NIL;                                                                                    
                                                                                                              
    IF work_area_p <> NIL THEN                                                                                
      IF (jmv$job_management_work_area_p = NIL) AND (#SIZE (work_area_p^) <= bytes_that_can_be_pushed) THEN   
        PUSH jm_work_area_p: [[REP #SIZE (work_area_p^) OF cell]];                                            
      ELSE                                                                                                    
        jmp$get_jm_work_area (jm_work_area_p, status);                                                        
        IF NOT status.normal THEN                                                                             
          RETURN;                                                                                             
        IFEND;                                                                                                
      IFEND;                                                                                                  
    IFEND;                                                                                                    
    PUSH target_options_p: [[REP dfc$maximum_user_data_area OF cell]];                                        
                                                                                                              
    RESET target_options_p;                                                                                   
                                                                                                              
    NEXT local_parameters_p IN target_options_p;                                                              
                                                                                                              
    pmp$get_user_identification (local_parameters_p^.user_identification, status);                            
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    local_parameters_p^.privileged_job := avp$system_operator () OR avp$system_displays ();                   
                                                                                                              
    IF output_status_options_p = NIL THEN                                                                     
      local_parameters_p^.status_option_count := 0;                                                           
    ELSE                                                                                                      
      caller_privileged := osp$is_caller_system_privileged () AND (caller_id.ring <= osc$tsrv_ring);          
      jmp$validate_status_options (jmc$get_output_status, 'OUTPUT_STATUS_OPTIONS_P',                          
            #SEQ (output_status_options_p^), caller_privileged, local_parameters_p^.privileged_job,           
            local_parameters_p^.user_identification, continue_request_to_servers,                             
            local_parameters_p^.status_option_count, target_options_p, status);                               
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
    IFEND;                                                                                                    
                                                                                                              
{ Verify that result is only asking for valid fields                                                          
                                                                                                              
    IF output_status_results_keys_p = NIL THEN                                                                
      local_parameters_p^.status_results_count := 0;                                                          
      seq_output_status_results_size := 0;                                                                    
    ELSE                                                                                                      
      local_parameters_p^.status_results_count := UPPERBOUND (output_status_results_keys_p^);                 
      NEXT local_status_results_keys_p: [1 .. local_parameters_p^.status_results_count] IN target_options_p;  
                                                                                                              
      local_status_results_keys_p^ := output_status_results_keys_p^;                                          
                                                                                                              
      FOR result_index := 1 TO UPPERBOUND (local_status_results_keys_p^) DO                                   
        CASE local_status_results_keys_p^ [result_index] OF                                                   
        = jmc$client_mainframe_id, jmc$control_family, jmc$control_user, jmc$login_family, jmc$login_user,    
              jmc$null_attribute, jmc$output_deferred_by_operator, jmc$output_deferred_by_user,               
              jmc$output_destination_usage, jmc$output_state, jmc$system_file_name, jmc$system_job_name,      
              jmc$user_file_name, jmc$user_job_name =                                                         
                                                                                                              
        ELSE                                                                                                  
          jmp$get_attribute_name (local_status_results_keys_p^ [result_index], scl_name);                     
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'OUTPUT_STATUS_RESULTS_KEYS_P',        
                status);                                                                                      
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$get_output_status, status);        
          RETURN;                                                                                             
        CASEND;                                                                                               
      FOREND;                                                                                                 
                                                                                                              
      jmp$get_data_packet_size (local_status_results_keys_p, seq_output_status_results_size, status);         
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    IF continue_request_to_servers THEN                                                                       
      target_mainframe_id := pmc$null_mainframe_id;                                                           
    ELSE                                                                                                      
      pmp$get_mainframe_id (target_mainframe_id, {ignore} local_status);                                      
    IFEND;                                                                                                    
    mainframes_processed.count := 0;                                                                          
                                                                                                              
    options_size := i#current_sequence_position (target_options_p);                                           
    RESET target_options_p;                                                                                   
    NEXT options_p: [[REP options_size OF cell]] IN target_options_p;                                         
                                                                                                              
    jmp$general_purpose_cluster_rpc (target_mainframe_id, jmc$gpro_get_output_status,                         
          {data_packet_size} seq_output_status_results_size, mainframes_processed, options_p, jm_work_area_p, 
          target_mainframe_reached, mainframes_processed, number_of_data_packets, status);                    
    IF NOT status.normal THEN                                                                                 
      IF status.condition = jme$work_area_too_small THEN                                                      
        number_of_outputs_found := number_of_data_packets;                                                    
      IFEND;                                                                                                  
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    number_of_outputs_found := number_of_data_packets;                                                        
    IF number_of_outputs_found = 0 THEN                                                                       
      osp$set_status_condition (jme$no_outputs_were_found, status);                                           
    ELSEIF (output_status_results_keys_p <> NIL) THEN                                                         
      RESET jm_work_area_p;                                                                                   
      save_work_area_p := work_area_p;                                                                        
      jmp$copy_seq_to_result_array (UPPERBOUND (output_status_results_keys_p^), number_of_outputs_found,      
            output_status_results_keys_p, jm_work_area_p, work_area_p, status);                               
      NEXT output_status_results_p: [1 .. number_of_outputs_found] IN save_work_area_p;                       
    IFEND;                                                                                                    
  PROCEND jmp$get_output_status;                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$log_restored_output', EJECT ??                                              
*copy jmh$log_restored_output                                                                                 
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$log_restored_output                                                             
    (    system_file_name: jmt$system_supplied_name;                                                          
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      candidate_name: jmt$name,                                                                               
      cycle_selector: pft$cycle_selector,                                                                     
      date_time: ost$date_time,                                                                               
      good_name: jmt$name,                                                                                    
      ignore_status: ost$status,                                                                              
      local_file: boolean,                                                                                    
      local_file_name: amt$local_file_name,                                                                   
      name_index: integer,                                                                                    
      operator_restore: ost$name,                                                                             
      output_label: jmt$output_system_label,                                                                  
      password: pft$password,                                                                                 
      path: jmt$queue_file_path,                                                                              
      result_index: integer,                                                                                  
      scl_name: ost$name,                                                                                     
      share_selections: pft$share_selections,                                                                 
      specified_keys: jmt$attribute_keys_set,                                                                 
      usage_selections: pft$usage_selections,                                                                 
      valid_name: boolean;                                                                                    
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      pfp$end_system_authority;                                                                               
      IF status.normal THEN                                                                                   
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);      
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
    ignore_status.normal := TRUE;                                                                             
                                                                                                              
    IF NOT (avp$system_administrator () OR avp$system_operator ()) THEN                                       
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_administration OR system_operation', status);
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Check for active job history statistic logging.                                                             
                                                                                                              
    IF NOT jmv$job_history_active THEN                                                                        
      osp$set_status_condition (jme$jh_job_history_not_active, status);                                       
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    candidate_name.kind := jmc$system_supplied_name;                                                          
    candidate_name.system_supplied_name := system_file_name;                                                  
    jmp$validate_name (candidate_name, good_name, status);                                                    
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    jmp$get_output_path_elements (good_name.system_supplied_name, path, status);                              
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Attach the file so we can read the system label.                                                            
                                                                                                              
    pmp$get_unique_name (local_file_name, ignore_status);                                                     
    cycle_selector.cycle_option := pfc$specific_cycle;                                                        
    cycle_selector.cycle_number := 1;                                                                         
    password := osc$null_name;                                                                                
    usage_selections := $pft$usage_selections [pfc$read];                                                     
                                                                                                              
    osp$establish_block_exit_hndlr (^handle_block_exit);                                                      
    pfp$begin_system_authority;                                                                               
    pfp$attach (local_file_name, path, cycle_selector, password, usage_selections, usage_selections, pfc$wait,
          status);                                                                                            
    IF NOT status.normal THEN                                                                                 
      pfp$purge (path, cycle_selector, password, ignore_status);                                              
      pfp$end_system_authority;                                                                               
      osp$disestablish_cond_handler;                                                                          
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Read the output file's system label.                                                                        
                                                                                                              
    qfp$read_output_system_label (local_file_name, output_label, status);                                     
    amp$return (local_file_name, ignore_status);                                                              
                                                                                                              
    IF NOT status.normal THEN                                                                                 
      pfp$purge (path, cycle_selector, password, ignore_status);                                              
      pfp$end_system_authority;                                                                               
      osp$disestablish_cond_handler;                                                                          
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    pfp$end_system_authority;                                                                                 
    osp$disestablish_cond_handler;                                                                            
                                                                                                              
    operator_restore := osc$null_name;                                                                        
    osp$get_status_condition_name (jme$operator_queue_restore, operator_restore, ignore_status);              
                                                                                                              
    jmp$emit_job_history_statistics (jml$output_queuing_started, osc$null_name, output_label.system_job_name, 
          output_label.system_file_name, NIL, ^output_label, operator_restore, jmc$blank_system_supplied_name,
          status);                                                                                            
                                                                                                              
  PROCEND jmp$log_restored_output;                                                                            
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$mainframe_change_output_att', EJECT ??                                      
*copy jmh$mainframe_change_output_att                                                                         
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$mainframe_change_output_att                                                     
    (    target_options_p: ^SEQ ( * );                                                                        
     VAR data_area_p: {input, output} ^SEQ ( * );                                                             
     VAR number_of_data_packets: ost$non_negative_integers;                                                   
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      application_gtid: ost$global_task_id,                                                                   
      change_index: integer,                                                                                  
      changed_output_controller: boolean,                                                                     
      cycle_selector: pft$cycle_selector,                                                                     
      current_date_time: ost$date_time,                                                                       
      current_microsecond_clock: jmt$clock_time,                                                              
      date_time: ost$date_time,                                                                               
      delete_output_file: boolean,                                                                            
      earliest_clock_time_to_print: jmt$clock_time,                                                           
      ignore_status: ost$status,                                                                              
      latest_clock_time_to_print: jmt$clock_time,                                                             
      local_file_name: amt$local_file_name,                                                                   
      local_attribute_changes_p: ^jmt$output_attribute_changes,                                               
      local_parameters_p: ^mainframe_chaoa_parameters,                                                        
      local_purge_delay_p: ^jmt$time_increment,                                                               
      local_remote_host_directive_p: ^jmt$remote_host_directive,                                              
      local_site_information_p: ^jmt$site_information,                                                        
      local_user_information_p: ^jmt$user_information,                                                        
      new_path_p: ^pft$path,                                                                                  
      notify_application: boolean,                                                                            
      number_of_outputs_found: jmt$output_status_count,                                                       
      old_destination_usage: jmt$destination_usage,                                                           
      options_p: ^SEQ ( * ),                                                                                  
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      privileged_job: boolean,                                                                                
      purge_delay_clock_time: jmt$clock_time,                                                                 
      reprint_disposition: jmt$reprint_disposition,                                                           
      scl_name: ost$name,                                                                                     
      scratch_segment: amt$segment_pointer,                                                                   
      share_selections: pft$share_selections,                                                                 
      system_label: jmt$output_system_label,                                                                  
      usage_selections: pft$usage_selections,                                                                 
      valid_name: boolean;                                                                                    
                                                                                                              
?? NEWTITLE := 'condition_handler', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit and interactive                                  
{   conditions that arise from the attempt to attach a file in the input queue.                               
{   If the file is busy, the attach processor goes into long term wait without                                
{   establishing a condition handler for interactive conditions - so it does                                  
{   not exit.  When pfp$attach gets changed to work correctly, this handler                                   
{   will no longer need to handle interactive conditions.                                                     
                                                                                                              
    PROCEDURE condition_handler                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      CASE condition.selector OF                                                                              
      = pmc$block_exit_processing =                                                                           
        pfp$end_system_authority;                                                                             
        IF status.normal THEN                                                                                 
          osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);    
        IFEND;                                                                                                
                                                                                                              
      = ifc$interactive_condition =                                                                           
        IF condition.interactive_condition = ifc$pause_break THEN                                             
          ifp$invoke_pause_utility (handler_status);                                                          
        ELSE                                                                                                  
          osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);    
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);                             
          EXIT jmp$mainframe_change_output_att;                                                               
        IFEND;                                                                                                
                                                                                                              
      ELSE                                                                                                    
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);                               
      CASEND;                                                                                                 
    PROCEND condition_handler;                                                                                
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'move_file_to_another_queue', EJECT ??                                                         
                                                                                                              
{ PURPOSE:                                                                                                    
{   This procedure will move a file from one physical output queue catalog to another one.                    
{                                                                                                             
{ DESIGN:                                                                                                     
{   Copy the file from the source catalog to the destination catalog.  Write the label to                     
{ the destination file.  Write a damaged label to the source file.  Purge the source file.                    
{                                                                                                             
{ Writing the labels to the files are memory operations - NOT I/O operations.  This reduces                   
{ the likelyhood of failure.  It would be fatal to NOS/VE if a queue file with the same system                
{ supplied name was recovered twice on the same mainframe.   The damaged label is written to                  
{ insure that this won't happen.                                                                              
{                                                                                                             
{ NOTES:                                                                                                      
{   Currently, this procedure is not used.                                                                    
{                                                                                                             
{   There is a window if the system fails and the label for the destination file has been flushed             
{ to the catalog yet the label for the source file has not been updated or flushed to disk.                   
                                                                                                              
    PROCEDURE move_file_to_another_queue                                                                      
      (    source_path_p: ^pft$path,                                                                          
           destination_path_p: ^pft$path;                                                                     
           system_label: jmt$output_system_label;                                                             
       VAR source_file_name: amt$local_file_name;                                                             
       VAR status: ost$status);                                                                               
                                                                                                              
      CONST                                                                                                   
        unit_separator = $CHAR (1f(16)),                                                                      
        damaged = 'Damaged_Label';                                                                            
                                                                                                              
      VAR                                                                                                     
        cycle_selector: pft$cycle_selector,                                                                   
        destination_file_name: amt$local_file_name,                                                           
        ignore_status: ost$status,                                                                            
        input_validation_attributes_p: ^fst$file_cycle_attributes,                                            
        local_system_label: jmt$output_system_label,                                                          
        null_file_access_procedure: pmt$entry_point_reference,                                                
        output_creation_attributes_p: ^fst$file_cycle_attributes,                                             
        password: pft$password;                                                                               
                                                                                                              
      status.normal := TRUE;                                                                                  
      local_system_label := system_label;                                                                     
                                                                                                              
      password := osc$null_name;                                                                              
      destination_file_name := system_label.system_file_name;                                                 
      osp$establish_condition_handler (^condition_handler, {block_exit} TRUE);                                
      pfp$begin_system_authority;                                                                             
      pfp$define (destination_file_name, destination_path_p^, cycle_selector, password, pfc$maximum_retention,
            pfc$log, status);                                                                                 
      pfp$end_system_authority;                                                                               
      osp$disestablish_cond_handler;                                                                          
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
{ Make the appropriate copy - to t-record if the file is coded - raw copy if the file is transparent.         
                                                                                                              
      null_file_access_procedure.entry_point := osc$null_name;                                                
      null_file_access_procedure.object_library := '';                                                        
      PUSH input_validation_attributes_p: [1 .. 1];                                                           
      input_validation_attributes_p^ [1].selector := fsc$file_access_procedure_name;                          
      input_validation_attributes_p^ [1].file_access_procedure_name := ^null_file_access_procedure;           
                                                                                                              
      IF system_label.data_mode = jmc$coded_data THEN                                                         
        PUSH output_creation_attributes_p: [1 .. 6];                                                          
        output_creation_attributes_p^ [2].selector := fsc$file_contents_and_processor;                        
        output_creation_attributes_p^ [2].file_contents := fsc$list;                                          
        output_creation_attributes_p^ [2].file_processor := fsc$unknown_processor;                            
        output_creation_attributes_p^ [3].selector := fsc$block_type;                                         
        output_creation_attributes_p^ [3].block_type := amc$system_specified;                                 
        output_creation_attributes_p^ [4].selector := fsc$record_delimiting_character;                        
        output_creation_attributes_p^ [4].record_delimiting_character := unit_separator;                      
        output_creation_attributes_p^ [5].selector := fsc$record_type;                                        
        output_creation_attributes_p^ [5].record_type := amc$trailing_char_delimited;                         
        output_creation_attributes_p^ [6].selector := fsc$file_organization;                                  
        output_creation_attributes_p^ [6].file_organization := amc$sequential;                                
                                                                                                              
      ELSE { transparent data }                                                                               
        PUSH output_creation_attributes_p: [1 .. 1];                                                          
      IFEND;                                                                                                  
      output_creation_attributes_p^ [1].selector := fsc$ring_attributes;                                      
      output_creation_attributes_p^ [1].ring_attributes.r1 := osc$tsrv_ring;                                  
      output_creation_attributes_p^ [1].ring_attributes.r2 := osc$tsrv_ring;                                  
      output_creation_attributes_p^ [1].ring_attributes.r3 := osc$tsrv_ring;                                  
                                                                                                              
      fsp$copy_file (source_file_name, destination_file_name, input_validation_attributes_p, NIL,             
            output_creation_attributes_p, status);                                                            
      IF NOT status.normal THEN                                                                               
        amp$return (destination_file_name, ignore_status);                                                    
        osp$establish_condition_handler (^condition_handler, {block_exit} TRUE);                              
        pfp$begin_system_authority;                                                                           
        pfp$purge (destination_path_p^, cycle_selector, password, ignore_status);                             
        pfp$end_system_authority;                                                                             
        osp$disestablish_cond_handler;                                                                        
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
{ Write the label in the file that was just created.                                                          
                                                                                                              
      qfp$write_output_system_label (destination_file_name, {  write_label } TRUE, local_system_label,        
            status);                                                                                          
      IF NOT status.normal THEN                                                                               
        amp$return (destination_file_name, ignore_status);                                                    
        osp$establish_condition_handler (^condition_handler, {block_exit} TRUE);                              
        pfp$begin_system_authority;                                                                           
        pfp$purge (destination_path_p^, cycle_selector, password, ignore_status);                             
        pfp$end_system_authority;                                                                             
        osp$disestablish_cond_handler;                                                                        
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      amp$return (destination_file_name, status);                                                             
      IF NOT status.normal THEN                                                                               
        osp$establish_condition_handler (^condition_handler, {block_exit} TRUE);                              
        pfp$begin_system_authority;                                                                           
        pfp$purge (destination_path_p^, cycle_selector, password, ignore_status);                             
        pfp$end_system_authority;                                                                             
        osp$disestablish_cond_handler;                                                                        
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      source_file_name := destination_file_name;                                                              
                                                                                                              
{ Damage the original file and then purge it.                                                                 
                                                                                                              
      local_system_label.version := damaged;                                                                  
      qfp$write_output_system_label (source_file_name, { write_label } TRUE, local_system_label,              
            ignore_status);                                                                                   
      osp$establish_condition_handler (^condition_handler, {block_exit} TRUE);                                
      pfp$begin_system_authority;                                                                             
      pfp$purge (source_path_p^, cycle_selector, password, status);                                           
      pfp$end_system_authority;                                                                               
      osp$disestablish_cond_handler;                                                                          
    PROCEND move_file_to_another_queue;                                                                       
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
{ BEGIN: jmp$mainframe_change_output_att                                                                      
                                                                                                              
    ignore_status.normal := TRUE;                                                                             
    status.normal := TRUE;                                                                                    
    number_of_data_packets := 0;                                                                              
                                                                                                              
    pmp$get_compact_date_time (current_date_time, ignore_status);                                             
    changed_output_controller := FALSE;                                                                       
                                                                                                              
    options_p := target_options_p;                                                                            
    RESET options_p;                                                                                          
    NEXT local_parameters_p IN options_p;                                                                     
                                                                                                              
{ Attach the file so we can read the system label and get the attributes                                      
                                                                                                              
    pmp$get_unique_name (local_file_name, status);                                                            
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    determine_file_path (local_parameters_p^.output_destination_usage, local_parameters_p^.system_file_name,  
          path_p);                                                                                            
    cycle_selector.cycle_option := pfc$specific_cycle;                                                        
    cycle_selector.cycle_number := 1;                                                                         
    password := osc$null_name;                                                                                
    usage_selections := $pft$usage_selections [pfc$read, pfc$modify];                                         
    share_selections := $pft$share_selections [pfc$read];                                                     
                                                                                                              
{ Prepare in case the file is busy and the attach goes into long-term-wait.                                   
                                                                                                              
    osp$establish_condition_handler (^condition_handler, {block_exit} TRUE);                                  
                                                                                                              
    pfp$begin_system_authority;                                                                               
    pfp$attach (local_file_name, path_p^, cycle_selector, password, usage_selections, share_selections,       
          pfc$wait, status);                                                                                  
    pfp$end_system_authority;                                                                                 
    osp$disestablish_cond_handler;                                                                            
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Read the output file's system label                                                                         
                                                                                                              
    qfp$read_output_system_label (local_file_name, system_label, status);                                     
    IF NOT status.normal THEN                                                                                 
      amp$return (local_file_name, ignore_status);                                                            
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Save the destination usage of the file.                                                                     
                                                                                                              
    old_destination_usage := system_label.output_destination_usage;                                           
    reprint_disposition := jmc$rd_no_change;                                                                  
                                                                                                              
{ Check attribute changes and change the local copy of the system label                                       
                                                                                                              
    IF local_parameters_p^.attribute_change_count > 0 THEN                                                    
                                                                                                              
      NEXT local_attribute_changes_p: [1 .. local_parameters_p^.attribute_change_count] IN options_p;         
                                                                                                              
    /process_changes/                                                                                         
      FOR change_index := 1 TO local_parameters_p^.attribute_change_count DO                                  
        CASE local_attribute_changes_p^ [change_index].key OF                                                 
        = jmc$comment_banner =                                                                                
          system_label.comment_banner := local_attribute_changes_p^ [change_index].comment_banner;            
                                                                                                              
        = jmc$copies =                                                                                        
          system_label.copy_count := local_attribute_changes_p^ [change_index].copies;                        
                                                                                                              
        = jmc$device =                                                                                        
          system_label.device := local_attribute_changes_p^ [change_index].device;                            
                                                                                                              
        = jmc$earliest_print_time =                                                                           
          system_label.earliest_print_time := local_attribute_changes_p^ [change_index].earliest_print_time;  
                                                                                                              
        = jmc$external_characteristics =                                                                      
          system_label.external_characteristics := local_attribute_changes_p^ [change_index].                 
                external_characteristics;                                                                     
                                                                                                              
        = jmc$forms_code =                                                                                    
          system_label.forms_code := local_attribute_changes_p^ [change_index].forms_code;                    
                                                                                                              
        = jmc$latest_print_time =                                                                             
          system_label.latest_print_time := local_attribute_changes_p^ [change_index].latest_print_time;      
                                                                                                              
        = jmc$null_attribute =                                                                                
          ;                                                                                                   
                                                                                                              
        = jmc$output_class =                                                                                  
          system_label.output_class := local_attribute_changes_p^ [change_index].output_class;                
                                                                                                              
        = jmc$output_deferred_by_operator =                                                                   
          system_label.output_deferred_by_operator := local_attribute_changes_p^ [change_index].              
                output_deferred_by_operator;                                                                  
                                                                                                              
        = jmc$output_deferred_by_user =                                                                       
          system_label.output_deferred_by_user := local_attribute_changes_p^ [change_index].                  
                output_deferred_by_user;                                                                      
                                                                                                              
        = jmc$output_destination =                                                                            
          system_label.output_destination := local_attribute_changes_p^ [change_index].output_destination;    
          changed_output_controller := TRUE;                                                                  
                                                                                                              
        = jmc$output_destination_family =                                                                     
          system_label.output_destination_family := local_attribute_changes_p^ [change_index].                
                output_destination_family;                                                                    
          changed_output_controller := TRUE;                                                                  
                                                                                                              
        = jmc$output_destination_usage =                                                                      
          system_label.output_destination_usage := local_attribute_changes_p^ [change_index].                 
                output_destination_usage;                                                                     
                                                                                                              
{ If the file's data mode was transparent - don't allow remote host to get the file.                          
                                                                                                              
          IF (system_label.data_mode = jmc$transparent_data) AND                                              
                (system_label.output_destination_usage = jmc$dual_state_usage) THEN                           
            osp$set_status_condition (jme$invalid_data_mode, status);                                         
            EXIT /process_changes/;                                                                           
          IFEND;                                                                                              
          changed_output_controller := TRUE;                                                                  
                                                                                                              
        = jmc$output_priority =                                                                               
          system_label.output_priority := local_attribute_changes_p^ [change_index].output_priority;          
                                                                                                              
        = jmc$purge_delay =                                                                                   
                                                                                                              
{ If the purge delay has changed, the output disposition time has changed.                                    
                                                                                                              
          NEXT local_purge_delay_p IN options_p;                                                              
          system_label.output_disposition_time.date_time := current_date_time;                                
          system_label.purge_delay := local_purge_delay_p^;                                                   
                                                                                                              
        = jmc$remote_host_directive =                                                                         
          NEXT local_remote_host_directive_p IN options_p;                                                    
          system_label.remote_host_directive := local_remote_host_directive_p^;                               
                                                                                                              
        = jmc$reprint_disposition =                                                                           
          reprint_disposition := local_attribute_changes_p^ [change_index].reprint_disposition;               
                                                                                                              
        = jmc$routing_banner =                                                                                
          system_label.routing_banner := local_attribute_changes_p^ [change_index].routing_banner;            
                                                                                                              
        = jmc$site_information =                                                                              
          NEXT local_site_information_p IN options_p;                                                         
          system_label.site_information := local_site_information_p^;                                         
                                                                                                              
        = jmc$station =                                                                                       
          system_label.station := local_attribute_changes_p^ [change_index].station;                          
                                                                                                              
        = jmc$station_operator =                                                                              
          system_label.station_operator := local_attribute_changes_p^ [change_index].station_operator;        
          changed_output_controller := TRUE;                                                                  
                                                                                                              
        = jmc$user_information =                                                                              
          NEXT local_user_information_p IN options_p;                                                         
          system_label.user_information := local_user_information_p^;                                         
                                                                                                              
        = jmc$vertical_print_density =                                                                        
          system_label.vertical_print_density := local_attribute_changes_p^ [change_index].                   
                vertical_print_density;                                                                       
                                                                                                              
        = jmc$vfu_load_procedure =                                                                            
          system_label.vfu_load_procedure := local_attribute_changes_p^ [change_index].vfu_load_procedure;    
                                                                                                              
        ELSE                                                                                                  
          jmp$get_attribute_name (local_attribute_changes_p^ [change_index].key, scl_name);                   
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'OUTPUT_ATTRIBUTE_CHANGES', status);   
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$change_output_attributes, status); 
          EXIT /process_changes/;                                                                             
        CASEND;                                                                                               
      FOREND /process_changes/;                                                                               
      IF NOT status.normal THEN                                                                               
        amp$return (local_file_name, ignore_status);                                                          
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
{ React to special change requirements                                                                        
                                                                                                              
      IF changed_output_controller THEN                                                                       
        IF (system_label.output_destination_usage = jmc$private_usage) OR                                     
              (system_label.output_destination_usage = jmc$ntf_usage) THEN                                    
          system_label.output_controller.user := system_label.station_operator;                               
          system_label.output_controller.family := system_label.output_destination_family;                    
        ELSE                                                                                                  
          changed_output_controller := FALSE;                                                                 
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
{ Check to see if the destination usage has changed                                                           
                                                                                                              
      IF old_destination_usage <> system_label.output_destination_usage THEN                                  
        determine_file_path (system_label.output_destination_usage, system_label.system_file_name,            
              new_path_p);                                                                                    
        IF new_path_p^ [3] <> path_p^ [3] THEN                                                                
                                                                                                              
{ If the file requires a different path as a result of the change in the destination usage it must be moved.  
                                                                                                              
{ For now.. Don't allow it to happen - if a store and forward queue is required, allow it then.               
                                                                                                              
          jmp$get_attribute_name (jmc$output_destination_usage, scl_name);                                    
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter_value, scl_name, status);     
          osp$append_status_parameter (osc$status_parameter_delimiter, 'OUTPUT_ATTRIBUTE_CHANGES', status);   
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$change_output_attributes, status); 
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
{ Calculate the earliest_print_time, latest_print_time and purge_delay if necessary.                          
                                                                                                              
      pmp$get_microsecond_clock (current_microsecond_clock, ignore_status);                                   
                                                                                                              
      IF system_label.earliest_print_time.specified THEN                                                      
        jmp$convert_date_time_dif_to_us (current_date_time, system_label.earliest_print_time.date_time,       
              current_microsecond_clock, earliest_clock_time_to_print);                                       
      ELSE                                                                                                    
        earliest_clock_time_to_print := jmc$earliest_clock_time;                                              
      IFEND;                                                                                                  
                                                                                                              
      IF system_label.latest_print_time.specified THEN                                                        
        jmp$convert_date_time_dif_to_us (current_date_time, system_label.latest_print_time.date_time,         
              current_microsecond_clock, latest_clock_time_to_print);                                         
      ELSE                                                                                                    
        latest_clock_time_to_print := jmc$latest_clock_time;                                                  
      IFEND;                                                                                                  
                                                                                                              
{ If the file has been printed (i.e. disposition time is available) and a purge delay has been supplied then  
{ calculate the free-running clock value at which the file can be purged.                                     
{ At this point the output disposition time is the current time .. so the net result                          
{ is that no matter what time the file was printed, it will be purged according to the purge delay            
{ supplied.  If the purge_delay has not changed, the output disposition time will be the previous output      
{ disposition time.  This value is typically the time at which the file was printed.                          
                                                                                                              
      IF system_label.purge_delay.specified AND system_label.output_disposition_time.specified THEN           
        pmp$compute_date_time (system_label.output_disposition_time.date_time,                                
              system_label.purge_delay.time_increment, date_time, status);                                    
        IF NOT status.normal THEN                                                                             
          amp$return (local_file_name, ignore_status);                                                        
          RETURN;                                                                                             
        IFEND;                                                                                                
        jmp$convert_date_time_dif_to_us (current_date_time, date_time, current_microsecond_clock,             
              purge_delay_clock_time);                                                                        
      ELSE                                                                                                    
        purge_delay_clock_time := jmc$earliest_clock_time;                                                    
      IFEND;                                                                                                  
                                                                                                              
      IF system_label.output_disposition_time.specified AND (reprint_disposition = jmc$rd_reprint_file) THEN  
        IF latest_clock_time_to_print <= current_microsecond_clock THEN                                       
          osp$set_status_abnormal (jmc$job_management_id, jme$latest_print_time_expired, '', status);         
          amp$return (local_file_name, ignore_status);                                                        
          RETURN;                                                                                             
        ELSE                                                                                                  
          system_label.output_disposition_time.specified := FALSE;                                            
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
{ If request was not made by an operator then change the output submission time.                              
                                                                                                              
      IF NOT local_parameters_p^.privileged_job THEN                                                          
        system_label.output_submission_time := current_date_time;                                             
      IFEND;                                                                                                  
                                                                                                              
{ Update the Known Output List                                                                                
                                                                                                              
      qfp$change_output_attributes (system_label, earliest_clock_time_to_print, latest_clock_time_to_print,   
            purge_delay_clock_time, current_microsecond_clock, reprint_disposition, notify_application,       
            application_gtid, delete_output_file, status);                                                    
      IF NOT status.normal THEN                                                                               
        amp$return (local_file_name, ignore_status);                                                          
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      IF jmv$job_history_active THEN                                                                          
        jmp$emit_job_history_statistics (jml$change_output_attributes, osc$null_name,                         
              system_label.system_job_name, system_label.system_file_name, NIL, ^system_label, osc$null_name, 
              jmc$blank_system_supplied_name, ignore_status);                                                 
      IFEND;                                                                                                  
                                                                                                              
      IF delete_output_file THEN                                                                              
                                                                                                              
{ We only want control on block exit - not for interactive so only establish the                              
{ condition handler for block exit.                                                                           
                                                                                                              
        osp$establish_block_exit_hndlr (^condition_handler);                                                  
        pfp$begin_system_authority;                                                                           
        pfp$purge (path_p^, cycle_selector, password, status);                                                
        pfp$end_system_authority;                                                                             
        osp$disestablish_cond_handler;                                                                        
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
{ Write the result system label to the output file                                                            
                                                                                                              
      qfp$write_output_system_label (local_file_name, { write_label } TRUE, system_label, status);            
      IF NOT status.normal THEN                                                                               
        amp$return (local_file_name, ignore_status);                                                          
        RETURN;                                                                                               
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Release the file in case somebody needs it                                                                  
                                                                                                              
    amp$return (local_file_name, status);                                                                     
    IF notify_application THEN                                                                                
      pmp$ready_task (application_gtid, ignore_status);                                                       
    IFEND;                                                                                                    
  PROCEND jmp$mainframe_change_output_att;                                                                    
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] jmp$mainframe_get_output_attrib', EJECT ??                                             
*copy jmh$mainframe_get_output_attrib                                                                         
                                                                                                              
  PROCEDURE [XDCL] jmp$mainframe_get_output_attrib                                                            
    (    target_options_p: ^SEQ ( * );                                                                        
     VAR data_area_p: {input, output} ^SEQ ( * );                                                             
     VAR number_of_data_packets: ost$non_negative_integers;                                                   
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      boolean_p: ^boolean,                                                                                    
      contains_data: boolean,                                                                                 
      copies_p: ^jmt$output_copy_count,                                                                       
      current_date_time: ost$date_time,                                                                       
      cycle_selector: pft$cycle_selector,                                                                     
      data_mode_p: ^jmt$data_mode,                                                                            
      date_time: ost$date_time,                                                                               
      date_time_p: ^jmt$date_time,                                                                            
      device_type_p: ^jmt$output_device_type,                                                                 
      external_characteristics_p: ^jmt$external_characteristics,                                              
      file_attributes: ^amt$get_attributes,                                                                   
      file_position_p: ^jmt$output_file_position,                                                             
      file_size_p: ^jmt$output_file_size,                                                                     
      forms_code_p: ^jmt$forms_code,                                                                          
      ignore_status: ost$status,                                                                              
      local_file: boolean,                                                                                    
      local_file_name: amt$local_file_name,                                                                   
      local_parameters_p: ^mainframe_getoa_parameters,                                                        
      local_results_keys_p: ^jmt$results_keys,                                                                
      local_status_keys_p: ^jmt$results_keys,                                                                 
      local_status_name_count_p: ^ost$non_negative_integers,                                                  
      local_status_options_p: ^jmt$output_status_options,                                                     
      name_value_p: ^ost$name,                                                                                
      number_of_outputs_statused: jmt$output_count_range,                                                     
      old_file: boolean,                                                                                      
      options_seq_p: ^SEQ ( * ),                                                                              
      os_date_time_p: ^ost$date_time,                                                                         
      output_index: jmt$output_count_range,                                                                   
      output_state_p: ^jmt$output_state,                                                                      
      output_status_results_p: ^jmt$output_status_results,                                                    
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      remote_host_directive_p: ^jmt$remote_host_directive,                                                    
      result_index: ost$positive_integers,                                                                    
      scratch_segment: amt$segment_pointer,                                                                   
      share_selections: pft$share_selections,                                                                 
      site_information_p: ^jmt$site_information,                                                              
      status_option_index: ost$non_negative_integers,                                                         
      status_results_keys_p: ^jmt$results_keys,                                                               
      system_file_name_p: ^jmt$system_supplied_name,                                                          
      system_label: jmt$output_system_label,                                                                  
      time_increment_p: ^jmt$time_increment,                                                                  
      usage_selections: pft$usage_selections,                                                                 
      user_identification: ost$user_identification,                                                           
      user_information_p: ^jmt$user_information,                                                              
      vertical_print_density_p: ^jmt$vertical_print_density,                                                  
      work_area_full: boolean;                                                                                
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      mmp$delete_scratch_segment (scratch_segment, ignore_status);                                            
      pfp$end_system_authority;                                                                               
      IF status.normal THEN                                                                                   
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);      
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    options_seq_p := target_options_p;                                                                        
    RESET options_seq_p;                                                                                      
    NEXT local_parameters_p IN options_seq_p;                                                                 
                                                                                                              
{ By definition, the number of status options is non-zero.                                                    
                                                                                                              
    NEXT local_status_options_p: [1 .. local_parameters_p^.status_option_count] IN options_seq_p;             
    FOR status_option_index := 1 TO local_parameters_p^.status_option_count DO                                
      CASE local_status_options_p^ [status_option_index].key OF                                               
      = jmc$name_list =                                                                                       
        NEXT local_status_name_count_p IN options_seq_p;                                                      
        IF local_status_name_count_p^ = 0 THEN                                                                
          local_status_options_p^ [status_option_index].name_list := NIL;                                     
        ELSE                                                                                                  
          NEXT local_status_options_p^ [status_option_index].name_list: [1 .. local_status_name_count_p^] IN  
                options_seq_p;                                                                                
        IFEND;                                                                                                
                                                                                                              
      = jmc$user_identification =                                                                             
        NEXT local_status_options_p^ [status_option_index].user_identification IN options_seq_p;              
                                                                                                              
      ELSE                                                                                                    
      CASEND;                                                                                                 
    FOREND;                                                                                                   
                                                                                                              
    IF local_parameters_p^.results_keys_count = 0 THEN                                                        
      local_results_keys_p := NIL;                                                                            
      local_status_keys_p := NIL;                                                                             
    ELSE                                                                                                      
      NEXT local_results_keys_p: [1 .. local_parameters_p^.results_keys_count] IN options_seq_p;              
      NEXT local_status_keys_p: [1 .. local_parameters_p^.results_keys_count] IN options_seq_p;               
    IFEND;                                                                                                    
                                                                                                              
    IF local_status_keys_p <> NIL THEN                                                                        
      PUSH status_results_keys_p: [1 .. local_parameters_p^.results_keys_count + 2];                          
      FOR result_index := 1 TO local_parameters_p^.results_keys_count DO                                      
        status_results_keys_p^ [result_index] := local_status_keys_p^ [result_index];                         
      FOREND;                                                                                                 
      status_results_keys_p^ [local_parameters_p^.results_keys_count + 1] := jmc$system_file_name;            
      status_results_keys_p^ [local_parameters_p^.results_keys_count + 2] := jmc$output_destination_usage;    
    ELSE                                                                                                      
      status_results_keys_p := NIL;                                                                           
    IFEND;                                                                                                    
                                                                                                              
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, scratch_segment, status);            
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    RESET scratch_segment.sequence_pointer;                                                                   
    jmp$get_output_status (local_status_options_p, status_results_keys_p, scratch_segment.sequence_pointer,   
          output_status_results_p, number_of_outputs_statused, status);                                       
    IF NOT status.normal THEN                                                                                 
      IF status.condition = jme$no_outputs_were_found THEN                                                    
        number_of_outputs_statused := 0;                                                                      
        status.normal := TRUE;                                                                                
      ELSE                                                                                                    
        mmp$delete_scratch_segment (scratch_segment, ignore_status);                                          
        RETURN;                                                                                               
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    number_of_data_packets := 0;                                                                              
    work_area_full := FALSE;                                                                                  
    IF local_results_keys_p <> NIL THEN                                                                       
                                                                                                              
    /fetch_attributes_for_files/                                                                              
      FOR output_index := 1 TO number_of_outputs_statused DO                                                  
                                                                                                              
{ Only attach the file if attributes are being requested that require us to do so.  The procedure             
{ jmp$get_output_attributes determines this once and passes the result to all mainframes.                     
                                                                                                              
        IF local_parameters_p^.attach_file THEN                                                               
                                                                                                              
{ Attach the file so we can read the system label and get the attributes                                      
                                                                                                              
          pmp$get_unique_name (local_file_name, { ignore } status);                                           
                                                                                                              
          determine_file_path (output_status_results_p^ [output_index]^                                       
                [local_parameters_p^.results_keys_count + 2].output_destination_usage,                        
                output_status_results_p^ [output_index]^ [local_parameters_p^.results_keys_count +            
                1].system_file_name, path_p);                                                                 
          cycle_selector.cycle_option := pfc$specific_cycle;                                                  
          cycle_selector.cycle_number := 1;                                                                   
          password := osc$null_name;                                                                          
          usage_selections := $pft$usage_selections [pfc$read];                                               
          share_selections := $pft$share_selections [pfc$read, pfc$modify];                                   
                                                                                                              
          osp$establish_block_exit_hndlr (^handle_block_exit);                                                
          pfp$begin_system_authority;                                                                         
          pfp$attach (local_file_name, path_p^, cycle_selector, password, usage_selections, share_selections, 
                pfc$wait, status);                                                                            
          pfp$end_system_authority;                                                                           
          osp$disestablish_cond_handler;                                                                      
          IF NOT status.normal THEN                                                                           
            status.normal := TRUE;                                                                            
            CYCLE /fetch_attributes_for_files/;                                                               
          IFEND;                                                                                              
                                                                                                              
{ Read the output file's system label                                                                         
                                                                                                              
          qfp$read_output_system_label (local_file_name, system_label, status);                               
          IF NOT status.normal THEN                                                                           
            amp$return (local_file_name, ignore_status);                                                      
            mmp$delete_scratch_segment (scratch_segment, ignore_status);                                      
            RETURN;                                                                                           
          IFEND;                                                                                              
                                                                                                              
{ Get the necessary file attributes for the output file                                                       
                                                                                                              
          PUSH file_attributes: [1 .. 1];                                                                     
          file_attributes^ [1].key := amc$file_length;                                                        
          amp$get_file_attributes (local_file_name, file_attributes^, local_file, old_file, contains_data,    
                status);                                                                                      
          IF NOT status.normal THEN                                                                           
            amp$return (local_file_name, ignore_status);                                                      
            mmp$delete_scratch_segment (scratch_segment, ignore_status);                                      
            RETURN;                                                                                           
          IFEND;                                                                                              
                                                                                                              
{ Release the file in case somebody needs it for write access                                                 
                                                                                                              
          amp$return (local_file_name, status);                                                               
        IFEND;                                                                                                
                                                                                                              
        number_of_data_packets := number_of_data_packets + 1;                                                 
                                                                                                              
        IF NOT work_area_full THEN                                                                            
                                                                                                              
        /fill_in_each_result_field/                                                                           
          FOR result_index := 1 TO local_parameters_p^.results_keys_count DO                                  
            CASE local_results_keys_p^ [result_index] OF                                                      
            = jmc$comment_banner =                                                                            
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := system_label.comment_banner;                                                   
                                                                                                              
            = jmc$control_family =                                                                            
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := output_status_results_p^ [output_index]^ [result_index].control_family;        
                                                                                                              
            = jmc$control_user =                                                                              
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := output_status_results_p^ [output_index]^ [result_index].control_user;          
                                                                                                              
            = jmc$copies =                                                                                    
              NEXT copies_p IN data_area_p;                                                                   
              IF copies_p = NIL THEN                                                                          
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              copies_p^ := system_label.copy_count;                                                           
                                                                                                              
            = jmc$copies_printed =                                                                            
              NEXT copies_p IN data_area_p;                                                                   
              IF copies_p = NIL THEN                                                                          
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              copies_p^ := system_label.copies_printed;                                                       
                                                                                                              
            = jmc$data_mode =                                                                                 
              NEXT data_mode_p IN data_area_p;                                                                
              IF data_mode_p = NIL THEN                                                                       
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              data_mode_p^ := system_label.data_mode;                                                         
                                                                                                              
            = jmc$device =                                                                                    
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := system_label.device;                                                           
                                                                                                              
            = jmc$device_type =                                                                               
              NEXT device_type_p IN data_area_p;                                                              
              IF device_type_p = NIL THEN                                                                     
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              device_type_p^ := system_label.device_type;                                                     
                                                                                                              
            = jmc$earliest_print_time =                                                                       
              NEXT date_time_p IN data_area_p;                                                                
              IF date_time_p = NIL THEN                                                                       
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              date_time_p^ := system_label.earliest_print_time;                                               
                                                                                                              
            = jmc$external_characteristics =                                                                  
              NEXT external_characteristics_p IN data_area_p;                                                 
              IF external_characteristics_p = NIL THEN                                                        
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              external_characteristics_p^ := system_label.external_characteristics;                           
                                                                                                              
            = jmc$file_position =                                                                             
              NEXT file_position_p IN data_area_p;                                                            
              IF file_position_p = NIL THEN                                                                   
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              file_position_p^ := system_label.file_position;                                                 
                                                                                                              
            = jmc$file_size =                                                                                 
              NEXT file_size_p IN data_area_p;                                                                
              IF file_size_p = NIL THEN                                                                       
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              file_size_p^ := file_attributes^ [1].file_length;                                               
                                                                                                              
            = jmc$forms_code =                                                                                
              NEXT forms_code_p IN data_area_p;                                                               
              IF forms_code_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              forms_code_p^ := system_label.forms_code;                                                       
                                                                                                              
            = jmc$latest_print_time =                                                                         
              NEXT date_time_p IN data_area_p;                                                                
              IF date_time_p = NIL THEN                                                                       
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              date_time_p^ := system_label.latest_print_time;                                                 
                                                                                                              
            = jmc$login_account =                                                                             
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := system_label.login_account;                                                    
                                                                                                              
            = jmc$login_family =                                                                              
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := output_status_results_p^ [output_index]^ [result_index].login_family;          
                                                                                                              
            = jmc$login_project =                                                                             
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := system_label.login_project;                                                    
                                                                                                              
            = jmc$login_user =                                                                                
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := output_status_results_p^ [output_index]^ [result_index].login_user;            
                                                                                                              
            = jmc$null_attribute =                                                                            
              ;                                                                                               
                                                                                                              
            = jmc$origin_application_name =                                                                   
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := system_label.originating_application_name;                                     
                                                                                                              
            = jmc$output_class =                                                                              
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := system_label.output_class;                                                     
                                                                                                              
            = jmc$output_deferred_by_operator =                                                               
              NEXT boolean_p IN data_area_p;                                                                  
              IF boolean_p = NIL THEN                                                                         
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              boolean_p^ := output_status_results_p^ [output_index]^ [result_index].                          
                    output_deferred_by_operator;                                                              
                                                                                                              
            = jmc$output_deferred_by_user =                                                                   
              NEXT boolean_p IN data_area_p;                                                                  
              IF boolean_p = NIL THEN                                                                         
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              boolean_p^ := output_status_results_p^ [output_index]^ [result_index].output_deferred_by_user;  
                                                                                                              
            = jmc$output_destination =                                                                        
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := system_label.output_destination;                                               
                                                                                                              
            = jmc$output_destination_family =                                                                 
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := system_label.output_destination_family;                                        
                                                                                                              
            = jmc$output_destination_usage =                                                                  
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := output_status_results_p^ [output_index]^ [result_index].                       
                    output_destination_usage;                                                                 
                                                                                                              
            = jmc$output_priority =                                                                           
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := system_label.output_priority;                                                  
                                                                                                              
            = jmc$output_state =                                                                              
              NEXT output_state_p IN data_area_p;                                                             
              IF output_state_p = NIL THEN                                                                    
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              output_state_p^ := output_status_results_p^ [output_index]^ [result_index].output_state;        
                                                                                                              
            = jmc$output_submission_time =                                                                    
              NEXT os_date_time_p IN data_area_p;                                                             
              IF os_date_time_p = NIL THEN                                                                    
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              os_date_time_p^ := system_label.output_submission_time;                                         
                                                                                                              
            = jmc$purge_delay =                                                                               
              NEXT time_increment_p IN data_area_p;                                                           
              IF time_increment_p = NIL THEN                                                                  
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              IF system_label.output_disposition_time.specified THEN                                          
                pmp$compute_date_time (system_label.output_disposition_time.date_time,                        
                      system_label.purge_delay.time_increment, date_time, ignore_status);                     
                pmp$get_compact_date_time (current_date_time, ignore_status);                                 
                pmp$compute_date_time_increment (current_date_time, date_time,                                
                      time_increment_p^.time_increment, ignore_status);                                       
                time_increment_p^.specified := TRUE;                                                          
              ELSE                                                                                            
                time_increment_p^ := system_label.purge_delay;                                                
              IFEND;                                                                                          
                                                                                                              
            = jmc$remote_host_directive =                                                                     
              NEXT remote_host_directive_p IN data_area_p;                                                    
              IF remote_host_directive_p = NIL THEN                                                           
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              remote_host_directive_p^ := system_label.remote_host_directive;                                 
                                                                                                              
            = jmc$routing_banner =                                                                            
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := system_label.routing_banner;                                                   
                                                                                                              
            = jmc$site_information =                                                                          
              NEXT site_information_p IN data_area_p;                                                         
              IF site_information_p = NIL THEN                                                                
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              site_information_p^ := system_label.site_information;                                           
                                                                                                              
            = jmc$station =                                                                                   
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := system_label.station;                                                          
                                                                                                              
            = jmc$station_operator =                                                                          
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := system_label.station_operator;                                                 
                                                                                                              
            = jmc$system_file_name =                                                                          
              NEXT system_file_name_p IN data_area_p;                                                         
              IF system_file_name_p = NIL THEN                                                                
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              system_file_name_p^ := output_status_results_p^ [output_index]^ [result_index].system_file_name;
                                                                                                              
            = jmc$system_job_name =                                                                           
              NEXT system_file_name_p IN data_area_p;                                                         
              IF system_file_name_p = NIL THEN                                                                
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              system_file_name_p^ := output_status_results_p^ [output_index]^ [result_index].system_job_name; 
                                                                                                              
            = jmc$user_file_name =                                                                            
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := output_status_results_p^ [output_index]^ [result_index].user_file_name;        
                                                                                                              
            = jmc$user_information =                                                                          
              NEXT user_information_p IN data_area_p;                                                         
              IF user_information_p = NIL THEN                                                                
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              user_information_p^ := system_label.user_information;                                           
                                                                                                              
            = jmc$user_job_name =                                                                             
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := output_status_results_p^ [output_index]^ [result_index].user_job_name;         
                                                                                                              
            = jmc$vertical_print_density =                                                                    
              NEXT vertical_print_density_p IN data_area_p;                                                   
              IF vertical_print_density_p = NIL THEN                                                          
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              vertical_print_density_p^ := system_label.vertical_print_density;                               
                                                                                                              
            = jmc$vfu_load_procedure =                                                                        
              NEXT name_value_p IN data_area_p;                                                               
              IF name_value_p = NIL THEN                                                                      
                work_area_full := TRUE;                                                                       
                EXIT /fill_in_each_result_field/;                                                             
              IFEND;                                                                                          
              name_value_p^ := system_label.vfu_load_procedure;                                               
                                                                                                              
            ELSE                                                                                              
              ;                                                                                               
            CASEND;                                                                                           
          FOREND /fill_in_each_result_field/;                                                                 
        IFEND;                                                                                                
      FOREND /fetch_attributes_for_files/;                                                                    
                                                                                                              
      IF work_area_full THEN                                                                                  
        osp$set_status_condition (jme$work_area_too_small, status);                                           
      IFEND;                                                                                                  
                                                                                                              
      mmp$delete_scratch_segment (scratch_segment, ignore_status);                                            
    IFEND;                                                                                                    
  PROCEND jmp$mainframe_get_output_attrib;                                                                    
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] jmp$mainframe_get_output_status', EJECT ??                                             
*copy jmh$mainframe_get_output_status                                                                         
                                                                                                              
  PROCEDURE [XDCL] jmp$mainframe_get_output_status                                                            
    (    target_options_p: ^SEQ ( * );                                                                        
     VAR data_area_p: {input, output} ^SEQ ( * );                                                             
     VAR number_of_data_packets: ost$non_negative_integers;                                                   
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      local_parameters_p: ^mainframe_getos_parameters,                                                        
      local_status_name_count_p: ^ost$non_negative_integers,                                                  
      local_status_options_p: ^jmt$output_status_options,                                                     
      local_status_results_keys_p: ^jmt$results_keys,                                                         
      number_of_outputs_found: jmt$output_status_count,                                                       
      options_seq_p: ^SEQ ( * ),                                                                              
      status_option_index: ost$non_negative_integers;                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
    options_seq_p := target_options_p;                                                                        
    RESET options_seq_p;                                                                                      
    NEXT local_parameters_p IN options_seq_p;                                                                 
                                                                                                              
    IF local_parameters_p^.status_option_count = 0 THEN                                                       
      local_status_options_p := NIL;                                                                          
    ELSE                                                                                                      
      NEXT local_status_options_p: [1 .. local_parameters_p^.status_option_count] IN options_seq_p;           
                                                                                                              
      FOR status_option_index := 1 TO local_parameters_p^.status_option_count DO                              
        IF local_status_options_p^ [status_option_index].key = jmc$name_list THEN                             
          NEXT local_status_name_count_p IN options_seq_p;                                                    
          IF local_status_name_count_p^ = 0 THEN                                                              
            local_status_options_p^ [status_option_index].name_list := NIL;                                   
          ELSE                                                                                                
            NEXT local_status_options_p^ [status_option_index].name_list: [1 .. local_status_name_count_p^] IN
                  options_seq_p;                                                                              
          IFEND;                                                                                              
        IFEND;                                                                                                
      FOREND;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF local_parameters_p^.status_results_count = 0 THEN                                                      
      local_status_results_keys_p := NIL;                                                                     
    ELSE                                                                                                      
      NEXT local_status_results_keys_p: [1 .. local_parameters_p^.status_results_count] IN options_seq_p;     
    IFEND;                                                                                                    
                                                                                                              
    qfp$get_output_status (local_parameters_p^.user_identification, local_parameters_p^.privileged_job,       
          local_status_options_p, local_status_results_keys_p, data_area_p, number_of_outputs_found, status); 
    number_of_data_packets := number_of_outputs_found;                                                        
  PROCEND jmp$mainframe_get_output_status;                                                                    
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] jmp$mainframe_terminate_output', EJECT ??                                              
*copy jmh$mainframe_terminate_output                                                                          
                                                                                                              
  PROCEDURE [XDCL] jmp$mainframe_terminate_output                                                             
    (    target_options_p: ^SEQ ( * );                                                                        
     VAR data_area_p: {input, output} ^SEQ ( * );                                                             
     VAR number_of_data_packets: ost$non_negative_integers;                                                   
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      cycle_selector: pft$cycle_selector,                                                                     
      delete_output_file: boolean,                                                                            
      local_parameters_p: ^mainframe_tero_parameters,                                                         
      options_seq_p: ^SEQ ( * ),                                                                              
      output_destination_usage: jmt$destination_usage,                                                        
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      statistic_data: jmt$comm_acct_statistic_data,                                                           
      system_job_name: jmt$system_supplied_name;                                                              
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      pfp$end_system_authority;                                                                               
      IF status.normal THEN                                                                                   
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);      
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
                                                                                                              
?? OLDTITLE ??                                                                                                
?? EJECT ??                                                                                                   
    status.normal := TRUE;                                                                                    
    number_of_data_packets := 0;                                                                              
    options_seq_p := target_options_p;                                                                        
    RESET options_seq_p;                                                                                      
    NEXT local_parameters_p IN options_seq_p;                                                                 
                                                                                                              
    qfp$terminate_output (local_parameters_p^.system_file_name, local_parameters_p^.output_state_set,         
          system_job_name, output_destination_usage, delete_output_file, status);                             
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF delete_output_file THEN                                                                                
                                                                                                              
      IF jmv$job_history_active THEN                                                                          
        jmp$emit_job_history_statistics (jml$output_file_deleted, osc$null_name, system_job_name,             
              local_parameters_p^.system_file_name, NIL, NIL, local_parameters_p^.reason,                     
              jmc$blank_system_supplied_name, status);                                                        
      IFEND;                                                                                                  
                                                                                                              
      determine_file_path (output_destination_usage, local_parameters_p^.system_file_name, path_p);           
                                                                                                              
      statistic_data.statistic_id := jmc$ca_output_queue_residency;                                           
      PUSH statistic_data.output_queue_residency;                                                             
      statistic_data.output_queue_residency^.output_file_path := path_p;                                      
      jmp$emit_communication_stat (statistic_data);                                                           
                                                                                                              
      cycle_selector.cycle_option := pfc$specific_cycle;                                                      
      cycle_selector.cycle_number := 1;                                                                       
      password := osc$null_name;                                                                              
      osp$establish_block_exit_hndlr (^handle_block_exit);                                                    
      pfp$begin_system_authority;                                                                             
      pfp$purge (path_p^, cycle_selector, password, status);                                                  
      pfp$end_system_authority;                                                                               
      osp$disestablish_cond_handler;                                                                          
    IFEND;                                                                                                    
  PROCEND jmp$mainframe_terminate_output;                                                                     
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$modified_output_exists', EJECT ??                                           
*copy jmh$modified_output_exists                                                                              
                                                                                                              
  FUNCTION [XDCL, #GATE] jmp$modified_output_exists                                                           
    (    output_destination_usage: jmt$destination_usage): boolean;                                           
                                                                                                              
    VAR                                                                                                       
      application_index: jmt$output_application_index,                                                        
      output_exists: boolean;                                                                                 
                                                                                                              
    #KEYPOINT (osk$entry, 0, jmk$modified_output_exists);                                                     
    application_index := UPPERBOUND (jmv$known_output_list.application_table);                                
    WHILE (jmv$known_output_list.application_table [application_index].destination_usage <>                   
          output_destination_usage) AND (application_index <> jmc$unassigned_output_index) DO                 
      application_index := application_index - 1;                                                             
    WHILEND;                                                                                                  
                                                                                                              
    output_exists := (application_index <> jmc$unassigned_output_index) AND                                   
          (jmv$known_output_list.application_table [application_index].                                       
          state_data [jmc$kol_application_modified].number_of_entries > 0);                                   
    jmp$modified_output_exists := output_exists AND (NOT syp$system_is_idling ());                            
    #KEYPOINT (osk$exit, 0, jmk$modified_output_exists);                                                      
  FUNCEND jmp$modified_output_exists;                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$new_output_exists', EJECT ??                                                
*copy jmh$new_output_exists                                                                                   
                                                                                                              
  FUNCTION [XDCL, #GATE] jmp$new_output_exists                                                                
    (    output_destination_usage: jmt$destination_usage): boolean;                                           
                                                                                                              
    VAR                                                                                                       
      application_index: jmt$output_application_index,                                                        
      output_exists: boolean;                                                                                 
                                                                                                              
    #KEYPOINT (osk$entry, 0, jmk$new_output_exists);                                                          
    application_index := UPPERBOUND (jmv$known_output_list.application_table);                                
    WHILE (jmv$known_output_list.application_table [application_index].destination_usage <>                   
          output_destination_usage) AND (application_index <> jmc$unassigned_output_index) DO                 
      application_index := application_index - 1;                                                             
    WHILEND;                                                                                                  
                                                                                                              
    output_exists := (application_index <> jmc$unassigned_output_index) AND                                   
          (jmv$known_output_list.application_table [application_index].state_data [jmc$kol_application_new].  
          number_of_entries > 0);                                                                             
    jmp$new_output_exists := output_exists AND (NOT syp$system_is_idling ());                                 
    #KEYPOINT (osk$exit, 0, jmk$new_output_exists);                                                           
  FUNCEND jmp$new_output_exists;                                                                              
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$open_files_for_copof', EJECT ??                                             
*copy jmh$open_files_for_copof                                                                                
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$open_files_for_copof                                                            
    (    output_file_name: jmt$name;                                                                          
         target_file: fst$file_reference;                                                                     
     VAR control_info: fst$copy_control_information;                                                          
     VAR output_fid: amt$file_identifier;                                                                     
     VAR output_lfn: amt$local_file_name;                                                                     
     VAR target_fid: amt$file_identifier;                                                                     
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      attribute_override_p: ^fst$file_cycle_attributes,                                                       
      caller_id: ost$caller_identifier,                                                                       
      copof_capability: boolean,                                                                              
      cycle_selector: pft$cycle_selector,                                                                     
      ignore_status: ost$status,                                                                              
      number_of_outputs_found: jmt$output_status_count,                                                       
      output_attachment_options_p: ^fst$attachment_options,                                                   
      output_file_user_id: ost$user_identification,                                                           
      output_local_file_name: amt$local_file_name,                                                            
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      result_size: ost$segment_length,                                                                        
      share_selections: pft$share_selections,                                                                 
      status_options_p: ^jmt$output_status_options,                                                           
      status_results_keys_p: ^jmt$results_keys,                                                               
      status_results_p: ^jmt$output_status_results,                                                           
      status_work_area_p: ^jmt$work_area,                                                                     
      target_attachment_options_p: ^fst$attachment_options,                                                   
      target_creation_attributes_p: ^fst$file_cycle_attributes,                                               
      usage_selections: pft$usage_selections,                                                                 
      user_identification: ost$user_identification;                                                           
                                                                                                              
?? NEWTITLE := 'condition_handler', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit and interactive                                  
{   conditions that arise from the attempt to attach a file in the input queue.                               
{   If the file is busy, the attach processor goes into long term wait without                                
{   establishing a condition handler for interactive conditions - so it does                                  
{   not exit.  When pfp$attach gets changed to work correctly, this handler                                   
{   will no longer need to handle interactive conditions.                                                     
                                                                                                              
    PROCEDURE condition_handler                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      CASE condition.selector OF                                                                              
      = pmc$block_exit_processing =                                                                           
        pfp$end_system_authority;                                                                             
        IF status.normal THEN                                                                                 
          osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);    
        IFEND;                                                                                                
                                                                                                              
      = ifc$interactive_condition =                                                                           
        IF condition.interactive_condition = ifc$pause_break THEN                                             
          ifp$invoke_pause_utility (handler_status);                                                          
        ELSE                                                                                                  
          osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);    
          pmp$continue_to_cause (pmc$execute_standard_procedure, ignore_status);                              
          EXIT jmp$open_files_for_copof;                                                                      
        IFEND;                                                                                                
                                                                                                              
      ELSE                                                                                                    
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);                               
      CASEND;                                                                                                 
    PROCEND condition_handler;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
    ignore_status.normal := TRUE;                                                                             
    output_fid := amv$nil_file_identifier;                                                                    
    target_fid := amv$nil_file_identifier;                                                                    
                                                                                                              
    pmp$get_unique_name (output_local_file_name, ignore_status);                                              
    output_lfn := output_local_file_name;                                                                     
                                                                                                              
    #CALLER_ID (caller_id);                                                                                   
                                                                                                              
{ Verify that the caller is part of NOS/VE, not an application.                                               
                                                                                                              
    osp$verify_system_privilege;                                                                              
                                                                                                              
{ Verify that the user has the copy_output_files validation capability.                                       
                                                                                                              
    avp$get_capability (avc$copy_output_files, avc$user, copof_capability, status);                           
    IF NOT status.normal THEN                                                                                 
      IF (status.condition = ave$unknown_field) OR (status.condition = ave$field_was_deleted) THEN            
        osp$set_status_condition (jme$not_validated_for_copof, status);                                       
      IFEND;                                                                                                  
      RETURN;                                                                                                 
    IFEND;                                                                                                    
    IF NOT copof_capability THEN                                                                              
      osp$set_status_condition (jme$not_validated_for_copof, status);                                         
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Process output_file_name parameter.  Validate the supplied name.                                            
                                                                                                              
    PUSH status_options_p: [1 .. 1];                                                                          
    status_options_p^ [1].key := jmc$name_list;                                                               
    status_options_p^ [1].name_list := NIL;                                                                   
    PUSH status_options_p^ [1].name_list: [1 .. 1];                                                           
    status_options_p^ [1].name_list^ [1] := output_file_name;                                                 
                                                                                                              
    PUSH status_results_keys_p: [1 .. 6];                                                                     
    status_results_keys_p^ [1] := jmc$system_file_name;                                                       
    status_results_keys_p^ [2] := jmc$output_destination_usage;                                               
    status_results_keys_p^ [3] := jmc$control_family;                                                         
    status_results_keys_p^ [4] := jmc$control_user;                                                           
    status_results_keys_p^ [5] := jmc$login_family;                                                           
    status_results_keys_p^ [6] := jmc$login_user;                                                             
                                                                                                              
    jmp$get_result_size ({number_of_items} 1, #SEQ (status_results_keys_p^), result_size);                    
    PUSH status_work_area_p: [[REP result_size OF cell]];                                                     
    RESET status_work_area_p;                                                                                 
    jmp$get_output_status (status_options_p, status_results_keys_p, status_work_area_p, status_results_p,     
          number_of_outputs_found, status);                                                                   
                                                                                                              
    IF NOT status.normal THEN                                                                                 
      IF status.condition = jme$no_outputs_were_found THEN                                                    
        IF output_file_name.kind = jmc$system_supplied_name THEN                                              
          osp$set_status_abnormal ('JM', jme$name_not_found, output_file_name.system_supplied_name, status);  
        ELSE                                                                                                  
          osp$set_status_abnormal ('JM', jme$name_not_found, output_file_name.user_supplied_name, status);    
        IFEND;                                                                                                
      ELSE                                                                                                    
        IF status.condition = jme$work_area_too_small THEN                                                    
          IF output_file_name.kind = jmc$system_supplied_name THEN                                            
            osp$set_status_abnormal ('JM', jme$duplicate_name, output_file_name.system_supplied_name, status);
          ELSE                                                                                                
            osp$set_status_abnormal ('JM', jme$duplicate_name, output_file_name.user_supplied_name, status);  
          IFEND;                                                                                              
        IFEND;                                                                                                
      IFEND;                                                                                                  
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Verify that the calling user is the login or control user for the output file.                              
                                                                                                              
    pmp$get_user_identification (user_identification, status);                                                
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF NOT avp$system_operator () THEN                                                                        
      IF (user_identification.family <> status_results_p^ [1]^ [5].login_family) OR                           
            (user_identification.user <> status_results_p^ [1]^ [6].login_user) THEN                          
        IF (user_identification.family <> status_results_p^ [1]^ [3].control_family) OR                       
              (user_identification.user <> status_results_p^ [1]^ [4].control_user) THEN                      
          IF output_file_name.kind = jmc$system_supplied_name THEN                                            
            osp$set_status_abnormal ('JM', jme$name_not_found, output_file_name.system_supplied_name, status);
          ELSE                                                                                                
            osp$set_status_abnormal ('JM', jme$name_not_found, output_file_name.user_supplied_name, status);  
          IFEND;                                                                                              
          RETURN;                                                                                             
        IFEND;                                                                                                
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Attach the output queue file.                                                                               
                                                                                                              
    determine_file_path (status_results_p^ [1]^ [2].output_destination_usage,                                 
          status_results_p^ [1]^ [1].system_file_name, path_p);                                               
    cycle_selector.cycle_option := pfc$specific_cycle;                                                        
    cycle_selector.cycle_number := 1;                                                                         
    password := osc$null_name;                                                                                
    usage_selections := $pft$usage_selections [pfc$read];                                                     
    share_selections := $pft$share_selections [pfc$read, pfc$modify];                                         
                                                                                                              
    osp$establish_condition_handler (^condition_handler, {block_exit} TRUE);                                  
    pfp$begin_system_authority;                                                                               
    pfp$attach (output_local_file_name, path_p^, cycle_selector, password, usage_selections, share_selections,
          pfc$wait, status);                                                                                  
    pfp$end_system_authority;                                                                                 
    osp$disestablish_cond_handler;                                                                            
                                                                                                              
    IF NOT status.normal THEN                                                                                 
      amp$return (output_local_file_name, ignore_status);                                                     
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Set up options for opening the output queue file.                                                           
                                                                                                              
    PUSH output_attachment_options_p: [1 .. 2];                                                               
    output_attachment_options_p^ [1].selector := fsc$access_and_share_modes;                                  
    output_attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;                      
    output_attachment_options_p^ [1].access_modes.value := $fst$file_access_options [fsc$read];               
    output_attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;                        
    output_attachment_options_p^ [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$modify];    
    output_attachment_options_p^ [2].selector := fsc$open_share_modes;                                        
    output_attachment_options_p^ [2].open_share_modes := $fst$file_access_options [fsc$read, fsc$modify];     
                                                                                                              
{ Set up attachment options for opening the target file.                                                      
                                                                                                              
    PUSH target_attachment_options_p: [1 .. 3];                                                               
    target_attachment_options_p^ [1].selector := fsc$access_and_share_modes;                                  
    target_attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;                      
    target_attachment_options_p^ [1].access_modes.value := $fst$file_access_options                           
          [fsc$append, fsc$modify, fsc$shorten];                                                              
    target_attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;                        
    target_attachment_options_p^ [1].share_modes.value := $fst$file_access_options [];                        
    target_attachment_options_p^ [2].selector := fsc$open_share_modes;                                        
    target_attachment_options_p^ [2].open_share_modes := -$fst$file_access_options [];                        
    target_attachment_options_p^ [3].selector := fsc$validation_ring;                                         
    target_attachment_options_p^ [3].validation_ring := caller_id.ring;                                       
                                                                                                              
    PUSH target_creation_attributes_p: [1 .. 1];                                                              
    target_creation_attributes_p^ [1].selector := fsc$ring_attributes;                                        
    target_creation_attributes_p^ [1].ring_attributes.r1 := caller_id.ring;                                   
    target_creation_attributes_p^ [1].ring_attributes.r2 := caller_id.ring;                                   
    target_creation_attributes_p^ [1].ring_attributes.r3 := caller_id.ring;                                   
                                                                                                              
{ Open the files and obtain the copy control information.                                                     
                                                                                                              
    fsp$open_and_get_type_of_copy (output_local_file_name, target_file, output_attachment_options_p,          
          target_attachment_options_p, { input_attribute_validation } NIL,                                    
          { output_attribute_validation } NIL, target_creation_attributes_p, output_fid, target_fid,          
          control_info, status);                                                                              
    IF NOT status.normal THEN                                                                                 
      IF (output_fid <> amv$nil_file_identifier) THEN                                                         
        fsp$close_file (output_fid, ignore_status);                                                           
        output_fid := amv$nil_file_identifier;                                                                
        #SPOIL (output_fid);                                                                                  
      IFEND;                                                                                                  
                                                                                                              
      amp$return (output_local_file_name, ignore_status);                                                     
                                                                                                              
      IF (target_fid <> amv$nil_file_identifier) THEN                                                         
        fsp$close_file (target_fid, ignore_status);                                                           
        target_fid := amv$nil_file_identifier;                                                                
        #SPOIL (target_fid);                                                                                  
      IFEND;                                                                                                  
                                                                                                              
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    fsp$close_file (output_fid, ignore_status);                                                               
    output_fid := amv$nil_file_identifier;                                                                    
    #SPOIL (output_fid);                                                                                      
                                                                                                              
{ Reopen the output queue file for read access at the caller's ring.                                          
                                                                                                              
    PUSH attribute_override_p: [1 .. 1];                                                                      
    attribute_override_p^ [1].selector := fsc$ring_attributes;                                                
    attribute_override_p^ [1].ring_attributes.r1 := osc$tsrv_ring;                                            
    attribute_override_p^ [1].ring_attributes.r2 := caller_id.ring;                                           
    attribute_override_p^ [1].ring_attributes.r3 := caller_id.ring;                                           
                                                                                                              
    fsp$open_file (output_local_file_name, amc$record, output_attachment_options_p,                           
          { default_creation_attributes } NIL, { mandated_creation_attributes } NIL,                          
          { attribute_validation } NIL, attribute_override_p, output_fid, status);                            
    IF NOT status.normal THEN                                                                                 
      amp$return (output_local_file_name, ignore_status);                                                     
      IF (target_fid <> amv$nil_file_identifier) THEN                                                         
        fsp$close_file (target_fid, ignore_status);                                                           
        target_fid := amv$nil_file_identifier;                                                                
        #SPOIL (target_fid);                                                                                  
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
  PROCEND jmp$open_files_for_copof;                                                                           
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL #GATE] jmp$open_output_file', EJECT ??                                                  
*copy jmh$open_output_file                                                                                    
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$open_output_file                                                                
    (    system_file_name: jmt$system_supplied_name;                                                          
         access_level: amt$access_level;                                                                      
         destination_usage: jmt$destination_usage;                                                            
         queue_file_password: jmt$queue_file_password;                                                        
     VAR file_identifier: amt$file_identifier;                                                                
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      attachment_options_p: ^fst$attachment_options,                                                          
      attribute_override_p: ^fst$file_cycle_attributes,                                                       
      caller_id: ost$caller_identifier,                                                                       
      file_path: fst$path,                                                                                    
      file_path_size: 0 .. fsc$max_path_size,                                                                 
      ignore_status: ost$status,                                                                              
      sub_catalog: ost$name;                                                                                  
                                                                                                              
?? NEWTITLE := '[INLINE] add_to_file_path', EJECT ??                                                          
                                                                                                              
    PROCEDURE [INLINE] add_to_file_path                                                                       
      (    path_string: string ( * <= osc$max_name_size));                                                    
                                                                                                              
      VAR                                                                                                     
        string_length: 1 .. osc$max_name_size;                                                                
                                                                                                              
      string_length := clp$trimmed_string_size (path_string);                                                 
      file_path (file_path_size + 1, string_length) := path_string;                                           
      file_path_size := file_path_size + string_length;                                                       
    PROCEND add_to_file_path;                                                                                 
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      pfp$end_system_authority;                                                                               
      IF status.normal THEN                                                                                   
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);      
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    #KEYPOINT (osk$entry, 0, jmk$open_output_file);                                                           
    status.normal := TRUE;                                                                                    
    ignore_status.normal := TRUE;                                                                             
    #CALLER_ID (caller_id);                                                                                   
                                                                                                              
{ Validate that the caller deserves access to the file.                                                       
                                                                                                              
    qfp$validate_output_file_access (system_file_name, destination_usage, queue_file_password, status);       
    IF NOT status.normal THEN                                                                                 
      #KEYPOINT (osk$exit, 0, jmk$open_output_file);                                                          
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Build the file path for the open request.                                                                   
                                                                                                              
    file_path_size := 0;                                                                                      
    add_to_file_path (':');                                                                                   
    add_to_file_path (jmc$system_family);                                                                     
    add_to_file_path ('.');                                                                                   
    add_to_file_path (jmc$system_user);                                                                       
    add_to_file_path ('.');                                                                                   
    determine_file_catalog (destination_usage, sub_catalog);                                                  
    add_to_file_path (sub_catalog);                                                                           
    add_to_file_path ('.');                                                                                   
    add_to_file_path (system_file_name);                                                                      
                                                                                                              
{ Attach the file for read access and open the file with the rings of the caller                              
                                                                                                              
    PUSH attribute_override_p: [1 .. 1];                                                                      
    attribute_override_p^ [1].selector := fsc$ring_attributes;                                                
    attribute_override_p^ [1].ring_attributes.r1 := osc$tsrv_ring;                                            
    attribute_override_p^ [1].ring_attributes.r2 := caller_id.ring;                                           
    attribute_override_p^ [1].ring_attributes.r3 := caller_id.ring;                                           
                                                                                                              
    PUSH attachment_options_p: [1 .. 2];                                                                      
    attachment_options_p^ [1].selector := fsc$access_and_share_modes;                                         
    attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;                             
    attachment_options_p^ [1].access_modes.value := $fst$file_access_options [fsc$read];                      
    attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;                               
    attachment_options_p^ [1].share_modes.value := $fst$file_access_options [fsc$read];                       
    attachment_options_p^ [2].selector := fsc$open_share_modes;                                               
    attachment_options_p^ [2].open_share_modes := $fst$file_access_options [fsc$read];                        
                                                                                                              
    osp$establish_block_exit_hndlr (^handle_block_exit);                                                      
    pfp$begin_system_authority;                                                                               
    fsp$open_file (file_path (1, file_path_size), access_level, attachment_options_p, NIL, NIL, NIL,          
          attribute_override_p, file_identifier, status);                                                     
    pfp$end_system_authority;                                                                                 
    osp$disestablish_cond_handler;                                                                            
    #KEYPOINT (osk$exit, 0, jmk$open_output_file);                                                            
  PROCEND jmp$open_output_file;                                                                               
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$print_file', EJECT ??                                                       
*copy jmh$print_file                                                                                          
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$print_file                                                                      
    (    file_reference: fst$file_reference;                                                                  
         output_submission_options: ^jmt$output_submission_options;                                           
     VAR system_file_name: jmt$system_supplied_name;                                                          
     VAR status: ost$status);                                                                                 
                                                                                                              
    CONST                                                                                                     
      wait_queue = '$WAIT_QUEUE',                                                                             
      unit_separator = $CHAR (1f(16));                                                                        
                                                                                                              
    VAR                                                                                                       
      caller_identifier: ost$caller_identifier,                                                               
      contains_data: boolean,                                                                                 
      current_date_time: ost$date_time,                                                                       
      current_microsecond_clock: jmt$clock_time,                                                              
      cycle_selector: pft$cycle_selector,                                                                     
      date_time: ost$date_time,                                                                               
      earliest_clock_time_to_print: jmt$clock_time,                                                           
      file: clt$file,                                                                                         
      file_attributes: ^amt$get_attributes,                                                                   
      file_name: ost$name,                                                                                    
      files_vert_print_density: jmt$vertical_print_density,                                                   
      ignore_status: ost$status,                                                                              
      input_attachment_options_p: ^fst$attachment_options,                                                    
      input_validation_attributes_p: ^fst$file_cycle_attributes,                                              
      latest_clock_time_to_print: jmt$clock_time,                                                             
      local_file: boolean,                                                                                    
      null_file_access_procedure: pmt$entry_point_reference,                                                  
      old_file: boolean,                                                                                      
      output_attachment_options_p: ^fst$attachment_options,                                                   
      output_creation_attributes_p: ^fst$file_cycle_attributes,                                               
      output_disposition_key: jmt$output_disposition_keys,                                                    
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      permanent_file_name: amt$local_file_name,                                                               
      privileged_job: boolean,                                                                                
      reason: ost$name,                                                                                       
      statistic_data: jmt$comm_acct_statistic_data,                                                           
      store_and_forward_file: boolean,                                                                        
      system_label: jmt$output_system_label,                                                                  
      system_label_already_existed: boolean,                                                                  
      user_identification: ost$user_identification,                                                           
      wait_queue_file: boolean;                                                                               
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      pfp$end_system_authority;                                                                               
      IF status.normal THEN                                                                                   
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);      
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'handle_out_of_space', EJECT ??                                                                
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with the out of space condition.                                 
                                                                                                              
    PROCEDURE handle_out_of_space                                                                             
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      IF (condition.selector = pmc$user_defined_condition) AND                                                
            (condition.user_condition_name = osc$space_unavailable_condition) THEN                            
        osp$set_status_condition (jme$no_space_for_file, status);                                             
        amp$return (permanent_file_name, ignore_status);                                                      
        osp$establish_block_exit_hndlr (^handle_block_exit);                                                  
        pfp$begin_system_authority;                                                                           
        pfp$purge (path_p^, cycle_selector, password, ignore_status);                                         
        pfp$end_system_authority;                                                                             
        osp$disestablish_cond_handler;                                                                        
        EXIT jmp$print_file;                                                                                  
      ELSEIF condition.selector = pmc$block_exit_processing THEN                                              
        pfp$end_system_authority;                                                                             
        IF status.normal THEN                                                                                 
          osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);    
        IFEND;                                                                                                
                                                                                                              
      ELSE                                                                                                    
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);                               
      IFEND;                                                                                                  
    PROCEND handle_out_of_space;                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'build_standard_label', EJECT ??                                                               
                                                                                                              
{ PURPOSE:                                                                                                    
{   Build the label for the queued output file.                                                               
                                                                                                              
    PROCEDURE build_standard_label                                                                            
      (    file_name: ost$name;                                                                               
       VAR files_vert_print_density: jmt$vertical_print_density;                                              
       VAR system_label: jmt$output_system_label;                                                             
       VAR status: ost$status);                                                                               
                                                                                                              
      VAR                                                                                                     
        contains_data: boolean,                                                                               
        evaluated_file_reference: fst$evaluated_file_reference,                                               
        file_attributes: ^amt$get_attributes,                                                                 
        ignore_status: ost$status,                                                                            
        job_mode: jmt$job_mode,                                                                               
        link_user_descriptor: rht$link_user_descriptor,                                                       
        local_file: boolean,                                                                                  
        old_file: boolean;                                                                                    
                                                                                                              
      status.normal := TRUE;                                                                                  
                                                                                                              
{ Determine the file attributes.                                                                              
                                                                                                              
      PUSH file_attributes: [1 .. 1];                                                                         
      file_attributes^ [1].key := amc$vertical_print_density;                                                 
      amp$get_file_attributes (file_name, file_attributes^, local_file, old_file, contains_data, status);     
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
      IF file_attributes^ [1].vertical_print_density = LOWERVALUE (amt$vertical_print_density) THEN           
        files_vert_print_density := jmc$vertical_print_density_6;                                             
      ELSE                                                                                                    
        files_vert_print_density := jmc$vertical_print_density_8;                                             
      IFEND;                                                                                                  
                                                                                                              
      pmp$get_job_names (system_label.user_job_name, system_label.system_job_name, ignore_status);            
      pmp$get_user_identification (system_label.login_user_identification, ignore_status);                    
                                                                                                              
      pmp$get_job_mode (job_mode, ignore_status);                                                             
      IF job_mode <> jmc$batch THEN                                                                           
        job_mode := jmc$interactive_connected;                                                                
      IFEND;                                                                                                  
                                                                                                              
      rhp$get_link_user_descriptor (link_user_descriptor, status);                                            
      IF status.normal THEN                                                                                   
        system_label.dual_state_account := link_user_descriptor.charge;                                       
        system_label.dual_state_family_name := link_user_descriptor.family;                                   
        system_label.dual_state_password := link_user_descriptor.password;                                    
        system_label.dual_state_project := link_user_descriptor.project;                                      
        system_label.dual_state_user := link_user_descriptor.user;                                            
      ELSE                                                                                                    
        system_label.dual_state_account := osc$null_name;                                                     
        system_label.dual_state_family_name := osc$null_name;                                                 
        system_label.dual_state_password := osc$null_name;                                                    
        system_label.dual_state_project := osc$null_name;                                                     
        system_label.dual_state_user := osc$null_name;                                                        
      IFEND;                                                                                                  
                                                                                                              
{ Determine the default user_file_name                                                                        
                                                                                                              
      clp$get_fs_path_elements (file_name, evaluated_file_reference, status);                                 
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
      system_label.user_file_name := fsp$path_element (^evaluated_file_reference,                             
            evaluated_file_reference.number_of_path_elements) ^;                                              
                                                                                                              
{ system_label.version is not used.                                                                           
                                                                                                              
      system_label.comment_banner := jmv$job_attributes.comment_banner;                                       
      system_label.copies_printed := 0;                                                                       
      system_label.copy_count := jmv$job_attributes.copy_count;                                               
      system_label.data_declaration := '';                                                                    
      system_label.data_mode := jmc$coded_data;                                                               
      system_label.device_type := jmc$output_device_printer;                                                  
      system_label.disposition_code := jmv$job_disposition_code;                                              
      system_label.earliest_print_time := jmv$job_attributes.earliest_print_time;                             
      system_label.external_characteristics := jmv$job_attributes.external_characteristics;                   
      system_label.file_position := 0;                                                                        
      system_label.forms_code := jmv$job_attributes.forms_code;                                               
      system_label.implicit_routing_text := jmv$job_attributes.implicit_routing_text;                         
      system_label.latest_print_time := jmv$job_attributes.latest_print_time;                                 
      system_label.login_account := avv$account_name;                                                         
      system_label.login_project := avv$project_name;                                                         
      system_label.originating_application_name := jmv$job_attributes.originating_application_name;           
      system_label.output_class := jmv$job_attributes.output_class;                                           
      system_label.output_controller := jmv$job_attributes.job_controller;                                    
      system_label.output_deferred_by_operator := jmv$default_job_attributes [job_mode].                      
            output_deferred_by_operator;                                                                      
      system_label.output_deferred_by_user := jmv$job_attributes.output_deferred_by_user;                     
      system_label.output_destination := jmv$job_attributes.output_destination;                               
      system_label.output_destination_family := jmv$job_attributes.output_destination_family;                 
                                                                                                              
{ If the output_disposition for the job is local then use the system default for the output_destination_usage.
                                                                                                              
      IF (jmv$kjlx_p^ [jmv$jcb.job_id].output_disposition_key = jmc$local_output_disposition) THEN            
        IF job_mode = jmc$batch THEN                                                                          
          system_label.output_destination_usage := jmv$default_job_attributes [jmc$batch].                    
                output_destination_usage;                                                                     
        ELSE                                                                                                  
          system_label.output_destination_usage := jmv$default_job_attributes [jmc$interactive_connected].    
                output_destination_usage;                                                                     
        IFEND;                                                                                                
      ELSE                                                                                                    
        system_label.output_destination_usage := jmv$job_attributes.output_destination_usage;                 
      IFEND;                                                                                                  
      system_label.device := jmv$job_attributes.device;                                                       
      system_label.output_disposition_key := jmv$kjlx_p^ [jmv$jcb.job_id].output_disposition_key;             
      system_label.output_disposition_time.date_time := system_label.output_submission_time;                  
      system_label.output_disposition_time.specified := FALSE;                                                
      system_label.output_priority := jmv$job_attributes.output_priority;                                     
      system_label.output_submission_time := current_date_time;                                               
      system_label.purge_delay := jmv$job_attributes.purge_delay;                                             
      system_label.remote_host_directive := jmv$job_attributes.remote_host_directive;                         
      system_label.routing_banner := jmv$job_attributes.routing_banner;                                       
      system_label.site_information := jmv$job_attributes.site_information;                                   
      system_label.source_logical_id := jmv$job_attributes.source_logical_id;                                 
      system_label.station := jmv$job_attributes.station;                                                     
      system_label.station_operator := jmv$job_attributes.station_operator;                                   
      system_label.system_file_name := '';                                                                    
      system_label.system_routing_text.size := 0;                                                             
      system_label.system_routing_text.parameters := '';                                                      
      system_label.user_information := jmv$job_attributes.user_information;                                   
      system_label.vfu_load_procedure := jmv$job_attributes.vfu_load_procedure;                               
                                                                                                              
{ Reassign the vertical print density if the job attributes specify a vertical print density                  
                                                                                                              
      IF jmv$job_attributes.vertical_print_density = jmc$vertical_print_density_file THEN                     
        system_label.vertical_print_density := files_vert_print_density;                                      
      ELSE                                                                                                    
        system_label.vertical_print_density := jmv$job_attributes.vertical_print_density;                     
      IFEND;                                                                                                  
                                                                                                              
    PROCEND build_standard_label;                                                                             
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'update_label_with_user_options', EJECT ??                                                     
                                                                                                              
{ PURPOSE:                                                                                                    
{   Validates the submission options and updates the system label.                                            
                                                                                                              
    PROCEDURE update_label_with_user_options                                                                  
      (    output_submission_options: ^jmt$output_submission_options;                                         
           files_vert_print_density: jmt$vertical_print_density;                                              
       VAR system_label: jmt$output_system_label;                                                             
       VAR status: ost$status);                                                                               
                                                                                                              
      VAR                                                                                                     
        candidate_system_file_name: jmt$name,                                                                 
        candidate_usn: jmt$name,                                                                              
        option_index: integer,                                                                                
        scl_name: ost$name,                                                                                   
        valid_name: boolean,                                                                                  
        valid_system_file_name: jmt$name,                                                                     
        valid_usn: jmt$name;                                                                                  
                                                                                                              
      status.normal := TRUE;                                                                                  
      IF output_submission_options = NIL THEN                                                                 
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      FOR option_index := 1 TO UPPERBOUND (output_submission_options^) DO                                     
        CASE output_submission_options^ [option_index].key OF                                                 
        = jmc$comment_banner =                                                                                
          system_label.comment_banner := output_submission_options^ [option_index].comment_banner;            
                                                                                                              
        = jmc$copies =                                                                                        
          system_label.copy_count := output_submission_options^ [option_index].copies;                        
                                                                                                              
        = jmc$data_mode =                                                                                     
          system_label.data_mode := output_submission_options^ [option_index].data_mode;                      
                                                                                                              
        = jmc$device =                                                                                        
          clp$validate_name (output_submission_options^ [option_index].device, scl_name, valid_name);         
          IF NOT valid_name THEN                                                                              
            osp$set_status_abnormal ('CL', cle$improper_name, output_submission_options^ [option_index].      
                  device, status);                                                                            
            RETURN;                                                                                           
          IFEND;                                                                                              
          system_label.device := scl_name;                                                                    
                                                                                                              
        = jmc$device_type =                                                                                   
          system_label.device_type := output_submission_options^ [option_index].device_type;                  
                                                                                                              
        = jmc$earliest_print_time =                                                                           
          system_label.earliest_print_time := output_submission_options^ [option_index].earliest_print_time;  
                                                                                                              
        = jmc$external_characteristics =                                                                      
          #TRANSLATE (osv$lower_to_upper, output_submission_options^ [option_index].external_characteristics, 
                system_label.external_characteristics);                                                       
                                                                                                              
        = jmc$forms_code =                                                                                    
          #TRANSLATE (osv$lower_to_upper, output_submission_options^ [option_index].forms_code,               
                system_label.forms_code);                                                                     
                                                                                                              
        = jmc$latest_print_time =                                                                             
          system_label.latest_print_time := output_submission_options^ [option_index].latest_print_time;      
                                                                                                              
        = jmc$null_attribute =                                                                                
          ;                                                                                                   
                                                                                                              
        = jmc$output_class =                                                                                  
          clp$validate_name (output_submission_options^ [option_index].output_class, scl_name, valid_name);   
          IF NOT valid_name THEN                                                                              
            osp$set_status_abnormal ('CL', cle$improper_name,                                                 
                  output_submission_options^ [option_index].output_class, status);                            
            RETURN;                                                                                           
          IFEND;                                                                                              
          system_label.output_class := scl_name;                                                              
                                                                                                              
        = jmc$output_deferred_by_user =                                                                       
          system_label.output_deferred_by_user := output_submission_options^ [option_index].                  
                output_deferred_by_user;                                                                      
                                                                                                              
        = jmc$output_destination =                                                                            
          clp$validate_name (output_submission_options^ [option_index].output_destination, scl_name,          
                valid_name);                                                                                  
          IF valid_name THEN                                                                                  
            system_label.output_destination := scl_name;                                                      
          ELSE                                                                                                
            #TRANSLATE (osv$lower_to_upper, output_submission_options^ [option_index].output_destination,     
                  system_label.output_destination);                                                           
          IFEND;                                                                                              
                                                                                                              
        = jmc$output_destination_family =                                                                     
          clp$validate_name (output_submission_options^ [option_index].output_destination_family, scl_name,   
                valid_name);                                                                                  
          IF NOT valid_name THEN                                                                              
            osp$set_status_abnormal ('CL', cle$improper_name,                                                 
                  output_submission_options^ [option_index].output_destination_family, status);               
            RETURN;                                                                                           
          IFEND;                                                                                              
          system_label.output_destination_family := scl_name;                                                 
                                                                                                              
        = jmc$output_destination_usage =                                                                      
          clp$validate_name (output_submission_options^ [option_index].output_destination_usage, scl_name,    
                valid_name);                                                                                  
          IF NOT valid_name THEN                                                                              
            osp$set_status_abnormal ('CL', cle$improper_name,                                                 
                  output_submission_options^ [option_index].output_destination_usage, status);                
            RETURN;                                                                                           
          IFEND;                                                                                              
          system_label.output_destination_usage := scl_name;                                                  
                                                                                                              
        = jmc$output_disposition =                                                                            
          output_disposition_key := output_submission_options^ [option_index].output_disposition.key;         
          IF (output_disposition_key = jmc$local_output_disposition) OR                                       
                (output_disposition_key = jmc$normal_output_disposition) OR                                   
                (output_disposition_key = jmc$wait_queue_path) THEN                                           
            system_label.output_disposition_key := output_submission_options^ [option_index].                 
                  output_disposition.key;                                                                     
          ELSE                                                                                                
            jmp$get_attribute_name (output_submission_options^ [option_index].key, scl_name);                 
            osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter_value, scl_name, status);   
            osp$append_status_parameter (osc$status_parameter_delimiter, 'OUTPUT_SUBMISSION_OPTIONS', status);
            osp$append_status_parameter (osc$status_parameter_delimiter, jmc$print_file, status);             
            RETURN;                                                                                           
          IFEND;                                                                                              
                                                                                                              
        = jmc$output_priority =                                                                               
          clp$validate_name (output_submission_options^ [option_index].output_priority, scl_name, valid_name);
          IF NOT valid_name THEN                                                                              
            osp$set_status_abnormal ('CL', cle$improper_name,                                                 
                  output_submission_options^ [option_index].output_priority, status);                         
            RETURN;                                                                                           
          IFEND;                                                                                              
          system_label.output_priority := scl_name;                                                           
                                                                                                              
        = jmc$purge_delay =                                                                                   
          system_label.purge_delay := output_submission_options^ [option_index].purge_delay^;                 
                                                                                                              
        = jmc$remote_host_directive =                                                                         
          system_label.remote_host_directive := output_submission_options^ [option_index].                    
                remote_host_directive^;                                                                       
                                                                                                              
        = jmc$routing_banner =                                                                                
          system_label.routing_banner := output_submission_options^ [option_index].routing_banner;            
                                                                                                              
        = jmc$station =                                                                                       
          clp$validate_name (output_submission_options^ [option_index].station, scl_name, valid_name);        
          IF NOT valid_name THEN                                                                              
            osp$set_status_abnormal ('CL', cle$improper_name,                                                 
                  output_submission_options^ [option_index].station, status);                                 
            RETURN;                                                                                           
          IFEND;                                                                                              
          system_label.station := scl_name;                                                                   
                                                                                                              
        = jmc$station_operator =                                                                              
          clp$validate_name (output_submission_options^ [option_index].station_operator, scl_name,            
                valid_name);                                                                                  
          IF NOT valid_name THEN                                                                              
            osp$set_status_abnormal ('CL', cle$improper_name,                                                 
                  output_submission_options^ [option_index].station_operator, status);                        
            RETURN;                                                                                           
          IFEND;                                                                                              
          system_label.station_operator := scl_name;                                                          
                                                                                                              
        = jmc$user_file_name =                                                                                
          candidate_usn.kind := jmc$user_supplied_name;                                                       
          candidate_usn.user_supplied_name := output_submission_options^ [option_index].user_file_name;       
          jmp$validate_name (candidate_usn, valid_usn, status);                                               
          IF NOT status.normal THEN                                                                           
            RETURN;                                                                                           
          IFEND;                                                                                              
          system_label.user_file_name := valid_usn.user_supplied_name;                                        
                                                                                                              
        = jmc$user_information =                                                                              
          system_label.user_information := output_submission_options^ [option_index].user_information^;       
                                                                                                              
        = jmc$vertical_print_density =                                                                        
          system_label.vertical_print_density := output_submission_options^ [option_index].                   
                vertical_print_density;                                                                       
                                                                                                              
          IF system_label.vertical_print_density = jmc$vertical_print_density_file THEN                       
            system_label.vertical_print_density := files_vert_print_density;                                  
          ELSEIF system_label.vertical_print_density > jmc$vertical_print_density_6 THEN                      
            system_label.vertical_print_density := jmc$vertical_print_density_8;                              
          IFEND;                                                                                              
                                                                                                              
        = jmc$vfu_load_procedure =                                                                            
          IF output_submission_options^ [option_index].vfu_load_procedure <> osc$null_name THEN               
            clp$validate_name (output_submission_options^ [option_index].vfu_load_procedure, scl_name,        
                  valid_name);                                                                                
            IF NOT valid_name THEN                                                                            
              osp$set_status_abnormal ('CL', cle$improper_name,                                               
                    output_submission_options^ [option_index].vfu_load_procedure, status);                    
              RETURN;                                                                                         
            IFEND;                                                                                            
            system_label.vfu_load_procedure := scl_name;                                                      
          ELSE                                                                                                
            system_label.vfu_load_procedure := osc$null_name;                                                 
          IFEND;                                                                                              
                                                                                                              
{ The following set of attributes require special privilege to specify them                                   
                                                                                                              
        = jmc$control_family =                                                                                
                                                                                                              
{ If the caller is not privileged abort the task by forcing an access violation.                              
                                                                                                              
          IF NOT privileged_job THEN                                                                          
            osp$force_access_violation;                                                                       
          IFEND;                                                                                              
          clp$validate_name (output_submission_options^ [option_index].control_family, scl_name, valid_name); 
          IF NOT valid_name THEN                                                                              
            osp$set_status_abnormal ('CL', cle$improper_name,                                                 
                  output_submission_options^ [option_index].control_family, status);                          
            RETURN;                                                                                           
          IFEND;                                                                                              
          system_label.output_controller.family := scl_name;                                                  
                                                                                                              
        = jmc$control_user =                                                                                  
                                                                                                              
{ If the caller is not privileged abort the task by forcing an access violation.                              
                                                                                                              
          IF NOT privileged_job THEN                                                                          
            osp$force_access_violation;                                                                       
          IFEND;                                                                                              
          clp$validate_name (output_submission_options^ [option_index].control_user, scl_name, valid_name);   
          IF NOT valid_name THEN                                                                              
            osp$set_status_abnormal ('CL', cle$improper_name,                                                 
                  output_submission_options^ [option_index].control_user, status);                            
            RETURN;                                                                                           
          IFEND;                                                                                              
          system_label.output_controller.user := scl_name;                                                    
                                                                                                              
        = jmc$data_declaration =                                                                              
                                                                                                              
{ If the caller is not privileged abort the task by forcing an access violation.                              
                                                                                                              
          IF NOT privileged_job THEN                                                                          
            osp$force_access_violation;                                                                       
          IFEND;                                                                                              
          system_label.data_declaration := output_submission_options^ [option_index].data_declaration;        
                                                                                                              
        = jmc$disposition_code =                                                                              
                                                                                                              
{ If the caller is not privileged abort the task by forcing an access violation.                              
                                                                                                              
          IF NOT privileged_job THEN                                                                          
            osp$force_access_violation;                                                                       
          IFEND;                                                                                              
          system_label.disposition_code := output_submission_options^ [option_index].disposition_code;        
                                                                                                              
        = jmc$implicit_routing_text =                                                                         
                                                                                                              
{ If the caller is not privileged abort the task by forcing an access violation.                              
                                                                                                              
          IF NOT privileged_job THEN                                                                          
            osp$force_access_violation;                                                                       
          IFEND;                                                                                              
          system_label.implicit_routing_text := output_submission_options^ [option_index].                    
                implicit_routing_text^;                                                                       
                                                                                                              
        = jmc$login_account =                                                                                 
                                                                                                              
{ If the caller is not privileged abort the task by forcing an access violation.                              
                                                                                                              
          IF NOT privileged_job THEN                                                                          
            osp$force_access_violation;                                                                       
          IFEND;                                                                                              
          clp$validate_name (output_submission_options^ [option_index].login_account, scl_name, valid_name);  
          IF NOT valid_name THEN                                                                              
            osp$set_status_abnormal ('CL', cle$improper_name,                                                 
                  output_submission_options^ [option_index].login_account, status);                           
            RETURN;                                                                                           
          IFEND;                                                                                              
          system_label.login_account := scl_name;                                                             
                                                                                                              
        = jmc$login_family =                                                                                  
                                                                                                              
{ If the caller is not privileged abort the task by forcing an access violation.                              
                                                                                                              
          IF NOT privileged_job THEN                                                                          
            osp$force_access_violation;                                                                       
          IFEND;                                                                                              
          clp$validate_name (output_submission_options^ [option_index].login_family, scl_name, valid_name);   
          IF NOT valid_name THEN                                                                              
            osp$set_status_abnormal ('CL', cle$improper_name,                                                 
                  output_submission_options^ [option_index].login_family, status);                            
            RETURN;                                                                                           
          IFEND;                                                                                              
          system_label.login_user_identification.family := scl_name;                                          
                                                                                                              
        = jmc$login_project =                                                                                 
                                                                                                              
{ If the caller is not privileged abort the task by forcing an access violation.                              
                                                                                                              
          IF NOT privileged_job THEN                                                                          
            osp$force_access_violation;                                                                       
          IFEND;                                                                                              
          clp$validate_name (output_submission_options^ [option_index].login_project, scl_name, valid_name);  
          IF NOT valid_name THEN                                                                              
            osp$set_status_abnormal ('CL', cle$improper_name,                                                 
                  output_submission_options^ [option_index].login_project, status);                           
            RETURN;                                                                                           
          IFEND;                                                                                              
          system_label.login_project := scl_name;                                                             
                                                                                                              
        = jmc$login_user =                                                                                    
                                                                                                              
{ If the caller is not privileged abort the task by forcing an access violation.                              
                                                                                                              
          IF NOT privileged_job THEN                                                                          
            osp$force_access_violation;                                                                       
          IFEND;                                                                                              
          clp$validate_name (output_submission_options^ [option_index].login_user, scl_name, valid_name);     
          IF NOT valid_name THEN                                                                              
            osp$set_status_abnormal ('CL', cle$improper_name,                                                 
                  output_submission_options^ [option_index].login_user, status);                              
            RETURN;                                                                                           
          IFEND;                                                                                              
          system_label.login_user_identification.user := scl_name;                                            
                                                                                                              
        = jmc$origin_application_name =                                                                       
                                                                                                              
{ If the caller is not privileged abort the task by forcing an access violation.                              
                                                                                                              
          IF NOT privileged_job THEN                                                                          
            osp$force_access_violation;                                                                       
          IFEND;                                                                                              
          clp$validate_name (output_submission_options^ [option_index].origin_application_name, scl_name,     
                valid_name);                                                                                  
          IF NOT valid_name THEN                                                                              
            osp$set_status_abnormal ('CL', cle$improper_name,                                                 
                  output_submission_options^ [option_index].origin_application_name, status);                 
            RETURN;                                                                                           
          IFEND;                                                                                              
          system_label.originating_application_name := scl_name;                                              
                                                                                                              
        = jmc$source_logical_id =                                                                             
                                                                                                              
{ If the caller is not privileged abort the task by forcing an access violation.                              
                                                                                                              
          IF NOT privileged_job THEN                                                                          
            osp$force_access_violation;                                                                       
          IFEND;                                                                                              
          system_label.source_logical_id := output_submission_options^ [option_index].source_logical_id;      
                                                                                                              
        = jmc$system_file_name =                                                                              
                                                                                                              
{ If the caller is not privileged abort the task by forcing an access violation.                              
                                                                                                              
          IF NOT privileged_job THEN                                                                          
            osp$force_access_violation;                                                                       
          IFEND;                                                                                              
                                                                                                              
{ A blank system supplied name indicates that a "new" system file name should be assigned.                    
{ This provides output applications with the ability to perform a "Loopback".                                 
                                                                                                              
          IF output_submission_options^ [option_index].system_file_name <> jmc$blank_system_supplied_name THEN
            candidate_system_file_name.kind := jmc$system_supplied_name;                                      
            candidate_system_file_name.system_supplied_name :=                                                
                  output_submission_options^ [option_index].system_file_name;                                 
            jmp$validate_name (candidate_system_file_name, valid_system_file_name, status);                   
            IF NOT status.normal THEN                                                                         
              RETURN;                                                                                         
            IFEND;                                                                                            
            system_label.system_file_name := valid_system_file_name.system_supplied_name;                     
          ELSE                                                                                                
            system_label.system_file_name := jmc$blank_system_supplied_name;                                  
          IFEND;                                                                                              
                                                                                                              
        = jmc$system_routing_text =                                                                           
                                                                                                              
{ If the caller is not privileged abort the task by forcing an access violation.                              
                                                                                                              
          IF NOT privileged_job THEN                                                                          
            osp$force_access_violation;                                                                       
          IFEND;                                                                                              
          system_label.system_routing_text := output_submission_options^ [option_index].system_routing_text^; 
                                                                                                              
        = jmc$user_job_name =                                                                                 
                                                                                                              
{ If the caller is not privileged abort the task by forcing an access violation.                              
                                                                                                              
          IF NOT privileged_job THEN                                                                          
            osp$force_access_violation;                                                                       
          IFEND;                                                                                              
          clp$validate_name (output_submission_options^ [option_index].user_job_name, scl_name, valid_name);  
          IF NOT valid_name THEN                                                                              
            osp$set_status_abnormal ('CL', cle$improper_name,                                                 
                  output_submission_options^ [option_index].user_job_name, status);                           
            RETURN;                                                                                           
          IFEND;                                                                                              
          system_label.user_job_name := scl_name;                                                             
                                                                                                              
        ELSE                                                                                                  
          jmp$get_attribute_name (output_submission_options^ [option_index].key, scl_name);                   
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'OUTPUT_SUBMISSION_OPTIONS', status);  
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$print_file, status);               
          RETURN;                                                                                             
        CASEND;                                                                                               
      FOREND;                                                                                                 
    PROCEND update_label_with_user_options;                                                                   
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    #KEYPOINT (osk$entry, 0, jmk$print_file);                                                                 
    status.normal := TRUE;                                                                                    
    ignore_status.normal := TRUE;                                                                             
                                                                                                              
    #CALLER_ID (caller_identifier);                                                                           
    privileged_job := (caller_identifier.ring <= osc$sj_ring_3) OR jmv$enable_queue_file_access OR            
          jmp$system_job ();                                                                                  
                                                                                                              
{ Set up static and default values                                                                            
                                                                                                              
    pmp$get_compact_date_time (current_date_time, { ignore } status);                                         
                                                                                                              
    clp$convert_string_to_file (file_reference, file, status);                                                
    IF NOT status.normal THEN                                                                                 
      #KEYPOINT (osk$exit, 0, jmk$print_file);                                                                
      RETURN;                                                                                                 
    IFEND;                                                                                                    
    file_name := file.local_file_name;                                                                        
                                                                                                              
{ Test to see if the user is validated to print the file at his/her current ring level.                       
                                                                                                              
    #CALLER_ID (caller_identifier);                                                                           
                                                                                                              
{ Test to see if the output file already has a system label.  If it does then the                             
{ defaulting does not take place.                                                                             
                                                                                                              
    qfp$read_output_system_label (file_name, system_label, status);                                           
    IF status.normal THEN                                                                                     
                                                                                                              
      files_vert_print_density := system_label.vertical_print_density;                                        
      system_label_already_existed := TRUE;                                                                   
    ELSE {NOT status.normal ==> The file did not have a system label                                          
                                                                                                              
      IF status.condition = jme$read_output_system_label THEN                                                 
        osp$set_status_abnormal (jmc$job_management_id, jme$sl_version_mismatch, '', status);                 
        #KEYPOINT (osk$exit, 0, jmk$print_file);                                                              
        RETURN;                                                                                               
      IFEND;                                                                                                  
      status.normal := TRUE;                                                                                  
                                                                                                              
      system_label_already_existed := FALSE;                                                                  
      build_standard_label (file_name, files_vert_print_density, system_label, status);                       
      IF NOT status.normal THEN                                                                               
        #KEYPOINT (osk$exit, 0, jmk$print_file);                                                              
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
    IFEND; {NOT status.normal ==> The file did not have a system label                                        
                                                                                                              
{ Override default values for the system label - if necessary                                                 
                                                                                                              
    update_label_with_user_options (output_submission_options, files_vert_print_density, system_label,        
          status);                                                                                            
    IF NOT status.normal THEN                                                                                 
      #KEYPOINT (osk$exit, 0, jmk$print_file);                                                                
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Is the output file destined for the store and forward queue??                                               
                                                                                                              
    store_and_forward_file := NOT ((system_label.output_destination_usage = jmc$public_usage) OR              
          (system_label.output_destination_usage = jmc$private_usage) OR                                      
          (system_label.output_destination_usage = jmc$dual_state_usage));                                    
                                                                                                              
{ Check destination usage for special cases                                                                   
                                                                                                              
    IF system_label.output_destination_usage = jmc$dual_state_usage THEN                                      
                                                                                                              
{ remote host cannot handle transparent data - change it to coded                                             
                                                                                                              
      system_label.data_mode := jmc$coded_data;                                                               
                                                                                                              
    ELSEIF (system_label.output_destination_usage = jmc$private_usage) OR                                     
          (system_label.output_destination_usage = jmc$ntf_usage) THEN                                        
      system_label.output_controller.family := system_label.output_destination_family;                        
      system_label.output_controller.user := system_label.station_operator;                                   
    IFEND;                                                                                                    
                                                                                                              
{ Assign defaults to the routing and comment banners if they are empty.                                       
                                                                                                              
    IF system_label.comment_banner = osc$null_name THEN                                                       
      system_label.comment_banner := system_label.user_file_name;                                             
    IFEND;                                                                                                    
    IF system_label.routing_banner = osc$null_name THEN                                                       
      system_label.routing_banner := system_label.output_controller.user;                                     
    IFEND;                                                                                                    
                                                                                                              
{ Determine if the file should be printed or NOT.  If the file should not be printed simply exit              
{ with normal status.                                                                                         
                                                                                                              
    IF (system_label.output_disposition_key = jmc$discard_all_output) THEN                                    
      system_file_name := jmc$blank_system_supplied_name;                                                     
      #KEYPOINT (osk$exit, 0, jmk$print_file);                                                                
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Calculate the earliest_print_time, latest_print_time and purge_delay if necessary.                          
                                                                                                              
    pmp$get_microsecond_clock (current_microsecond_clock, ignore_status);                                     
                                                                                                              
    IF system_label.earliest_print_time.specified THEN                                                        
      jmp$convert_date_time_dif_to_us (current_date_time, system_label.earliest_print_time.date_time,         
            current_microsecond_clock, earliest_clock_time_to_print);                                         
    ELSE                                                                                                      
      earliest_clock_time_to_print := jmc$earliest_clock_time;                                                
    IFEND;                                                                                                    
                                                                                                              
    IF system_label.latest_print_time.specified THEN                                                          
      jmp$convert_date_time_dif_to_us (current_date_time, system_label.latest_print_time.date_time,           
            current_microsecond_clock, latest_clock_time_to_print);                                           
    ELSE                                                                                                      
      latest_clock_time_to_print := jmc$latest_clock_time;                                                    
    IFEND;                                                                                                    
                                                                                                              
{ The output system label is now completely built                                                             
                                                                                                              
    password := osc$null_name;                                                                                
                                                                                                              
{ Make the appropriate copy - to t-record if the file is coded - raw copy if the file is transparent.         
                                                                                                              
    null_file_access_procedure.entry_point := osc$null_name;                                                  
    null_file_access_procedure.object_library := '';                                                          
    PUSH input_validation_attributes_p: [1 .. 1];                                                             
    input_validation_attributes_p^ [1].selector := fsc$file_access_procedure_name;                            
    input_validation_attributes_p^ [1].file_access_procedure_name := ^null_file_access_procedure;             
                                                                                                              
    PUSH input_attachment_options_p: [1 .. 8];                                                                
    input_attachment_options_p^ [1].selector := fsc$access_and_share_modes;                                   
    input_attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;                       
    input_attachment_options_p^ [1].access_modes.value := $fst$file_access_options [fsc$read];                
    input_attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;                         
    input_attachment_options_p^ [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];    
    input_attachment_options_p^ [2].selector := fsc$allowed_device_classes;                                   
    input_attachment_options_p^ [2].allowed_device_classes := $fst$device_classes [fsc$mass_storage_device];  
    input_attachment_options_p^ [3].selector := fsc$create_file;                                              
    input_attachment_options_p^ [3].create_file := FALSE;                                                     
    input_attachment_options_p^ [4].selector := fsc$free_behind;                                              
    input_attachment_options_p^ [4].free_behind := TRUE;                                                      
    input_attachment_options_p^ [5].selector := fsc$open_position;                                            
    input_attachment_options_p^ [5].open_position := amc$open_at_boi;                                         
    input_attachment_options_p^ [6].selector := fsc$private_read;                                             
    input_attachment_options_p^ [6].private_read := TRUE;                                                     
    input_attachment_options_p^ [7].selector := fsc$sequential_access;                                        
    input_attachment_options_p^ [7].sequential_access := TRUE;                                                
    input_attachment_options_p^ [8].selector := fsc$validation_ring;                                          
    input_attachment_options_p^ [8].validation_ring := caller_identifier.ring;                                
                                                                                                              
    PUSH output_attachment_options_p: [1 .. 2];                                                               
    output_attachment_options_p^ [1].selector := fsc$free_behind;                                             
    output_attachment_options_p^ [1].free_behind := TRUE;                                                     
    output_attachment_options_p^ [2].selector := fsc$sequential_access;                                       
    output_attachment_options_p^ [2].sequential_access := TRUE;                                               
                                                                                                              
    IF system_label.data_mode = jmc$coded_data THEN                                                           
      PUSH output_creation_attributes_p: [1 .. 6];                                                            
      output_creation_attributes_p^ [1].selector := fsc$ring_attributes;                                      
                                                                                                              
{ Ring attributes are set below.                                                                              
                                                                                                              
      output_creation_attributes_p^ [2].selector := fsc$file_contents_and_processor;                          
      output_creation_attributes_p^ [2].file_contents := fsc$list;                                            
      output_creation_attributes_p^ [2].file_processor := fsc$unknown_processor;                              
      output_creation_attributes_p^ [3].selector := fsc$block_type;                                           
      output_creation_attributes_p^ [3].block_type := amc$system_specified;                                   
      output_creation_attributes_p^ [4].selector := fsc$record_delimiting_character;                          
      output_creation_attributes_p^ [4].record_delimiting_character := unit_separator;                        
      output_creation_attributes_p^ [5].selector := fsc$record_type;                                          
      output_creation_attributes_p^ [5].record_type := amc$trailing_char_delimited;                           
      output_creation_attributes_p^ [6].selector := fsc$file_organization;                                    
      output_creation_attributes_p^ [6].file_organization := amc$sequential;                                  
                                                                                                              
    ELSE { transparent data }                                                                                 
      PUSH output_creation_attributes_p: [1 .. 1];                                                            
      output_creation_attributes_p^ [1].selector := fsc$ring_attributes;                                      
                                                                                                              
{ Ring attributes are set below.                                                                              
                                                                                                              
    IFEND;                                                                                                    
                                                                                                              
    wait_queue_file := (system_label.output_disposition_key = jmc$wait_queue_path) AND                        
          (system_label.source_logical_id = '');                                                              
                                                                                                              
    IF system_label.system_file_name = '' THEN                                                                
      qfp$assign_system_supplied_name (system_label.system_file_name);                                        
    IFEND;                                                                                                    
                                                                                                              
  /print_file/                                                                                                
    WHILE TRUE DO                                                                                             
                                                                                                              
      permanent_file_name := system_label.system_file_name;                                                   
      system_file_name := system_label.system_file_name;                                                      
                                                                                                              
      IF jmv$job_history_active THEN                                                                          
        IF NOT jmp$system_job () THEN                                                                         
          jmp$emit_job_history_statistics (jml$print_plot_file_executed, osc$null_name,                       
                system_label.system_job_name, system_file_name, NIL, ^system_label, osc$null_name,            
                jmc$blank_system_supplied_name, ignore_status);                                               
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
{ If the file is not going to the store-and-forward queue it may belong in the user's wait                    
{ queue.  The catalog :$FAMILY.$USER.$WAIT_QUEUE is created and the file will be placed                       
{ there without a label.                                                                                      
                                                                                                              
      IF wait_queue_file THEN                                                                                 
        PUSH path_p: [1 .. 3];                                                                                
        path_p^ [1] := system_label.login_user_identification.family;                                         
        path_p^ [2] := system_label.login_user_identification.user;                                           
        path_p^ [3] := wait_queue;                                                                            
        pfp$define_catalog (path_p^, ignore_status);                                                          
                                                                                                              
        PUSH path_p: [1 .. 4];                                                                                
        path_p^ [1] := system_label.login_user_identification.family;                                         
        path_p^ [2] := system_label.login_user_identification.user;                                           
        path_p^ [3] := wait_queue;                                                                            
        path_p^ [4] := system_label.user_job_name;                                                            
                                                                                                              
        cycle_selector.cycle_option := pfc$highest_cycle;                                                     
        pfp$define (permanent_file_name, path_p^, cycle_selector, password, pfc$maximum_retention, pfc$log,   
              status);                                                                                        
        IF status.normal THEN                                                                                 
          output_creation_attributes_p^ [1].ring_attributes.r1 := avp$ring_nominal ();                        
          output_creation_attributes_p^ [1].ring_attributes.r2 := avp$ring_nominal ();                        
          output_creation_attributes_p^ [1].ring_attributes.r3 := avp$ring_nominal ();                        
                                                                                                              
          fsp$subsystem_copy_file (file_name, permanent_file_name, input_attachment_options_p,                
                output_attachment_options_p, input_validation_attributes_p, {output_attribute_validation} NIL,
                output_creation_attributes_p, status);                                                        
        IFEND;                                                                                                
        IF status.normal THEN                                                                                 
          amp$return (permanent_file_name, status);                                                           
          IF jmv$job_history_active THEN                                                                      
            jmp$emit_job_history_statistics (jml$output_queuing_started, osc$null_name,                       
                  system_label.system_job_name, system_file_name, NIL, ^system_label, osc$null_name,          
                  jmc$blank_system_supplied_name, ignore_status);                                             
          IFEND;                                                                                              
          EXIT /print_file/;                                                                                  
        IFEND;                                                                                                
        amp$return (permanent_file_name, ignore_status);                                                      
        wait_queue_file := FALSE;                                                                             
      IFEND;                                                                                                  
                                                                                                              
      determine_file_path (system_label.output_destination_usage, system_file_name, path_p);                  
      cycle_selector.cycle_option := pfc$specific_cycle;                                                      
      cycle_selector.cycle_number := 1;                                                                       
                                                                                                              
{ Force variables used by the out of space condition handler to memory.                                       
{ Establish the condition handler.                                                                            
                                                                                                              
      #SPOIL (path_p, permanent_file_name, cycle_selector, password);                                         
                                                                                                              
      osp$establish_condition_handler (^handle_out_of_space, {block_exit} TRUE);                              
      pfp$begin_system_authority;                                                                             
      pfp$define (permanent_file_name, path_p^, cycle_selector, password, pfc$maximum_retention, pfc$log,     
            status);                                                                                          
      pfp$end_system_authority;                                                                               
      osp$disestablish_cond_handler;                                                                          
      IF NOT status.normal THEN                                                                               
        IF (status.condition = pfe$duplicate_cycle) THEN                                                      
          status.normal := TRUE;                                                                              
          qfp$assign_system_supplied_name (system_label.system_file_name);                                    
          CYCLE /print_file/;                                                                                 
        IFEND;                                                                                                
        EXIT /print_file/;                                                                                    
      IFEND;                                                                                                  
                                                                                                              
      output_creation_attributes_p^ [1].ring_attributes.r1 := osc$tsrv_ring;                                  
      output_creation_attributes_p^ [1].ring_attributes.r2 := osc$tsrv_ring;                                  
      output_creation_attributes_p^ [1].ring_attributes.r3 := osc$tsrv_ring;                                  
                                                                                                              
      osp$establish_condition_handler (^handle_out_of_space, {block_exit} FALSE);                             
                                                                                                              
      fsp$subsystem_copy_file (file_name, permanent_file_name, input_attachment_options_p,                    
            output_attachment_options_p, input_validation_attributes_p, {output_attribute_validation} NIL,    
            output_creation_attributes_p, status);                                                            
      IF NOT status.normal THEN                                                                               
        amp$return (permanent_file_name, ignore_status);                                                      
                                                                                                              
{ This overwrites the out of space handler's definition so we don't need to                                   
{ disestablish it.                                                                                            
                                                                                                              
        osp$establish_block_exit_hndlr (^handle_block_exit);                                                  
        pfp$begin_system_authority;                                                                           
        pfp$purge (path_p^, cycle_selector, password, ignore_status);                                         
        pfp$end_system_authority;                                                                             
        osp$disestablish_cond_handler;                                                                        
        EXIT /print_file/;                                                                                    
      IFEND;                                                                                                  
      osp$disestablish_cond_handler;                                                                          
                                                                                                              
      PUSH file_attributes: [1 .. 1];                                                                         
      file_attributes^ [1].key := amc$file_length;                                                            
      amp$get_file_attributes (permanent_file_name, file_attributes^, local_file, old_file, contains_data,    
            ignore_status);                                                                                   
      system_label.file_size := file_attributes^ [1].file_length;                                             
                                                                                                              
      qfp$write_output_system_label (permanent_file_name, { write_label } TRUE, system_label, status);        
      IF NOT status.normal THEN                                                                               
        amp$return (permanent_file_name, ignore_status);                                                      
        osp$establish_block_exit_hndlr (^handle_block_exit);                                                  
        pfp$begin_system_authority;                                                                           
        pfp$purge (path_p^, cycle_selector, password, ignore_status);                                         
        pfp$end_system_authority;                                                                             
        osp$disestablish_cond_handler;                                                                        
        EXIT /print_file/;                                                                                    
      IFEND;                                                                                                  
                                                                                                              
      amp$return (permanent_file_name, status);                                                               
      IF NOT status.normal THEN                                                                               
        osp$establish_block_exit_hndlr (^handle_block_exit);                                                  
        pfp$begin_system_authority;                                                                           
        pfp$purge (path_p^, cycle_selector, password, ignore_status);                                         
        pfp$end_system_authority;                                                                             
        osp$disestablish_cond_handler;                                                                        
        EXIT /print_file/;                                                                                    
      IFEND;                                                                                                  
                                                                                                              
      IF jmv$job_history_active THEN                                                                          
        jmp$emit_job_history_statistics (jml$output_queuing_started, osc$null_name,                           
              system_label.system_job_name, system_file_name, NIL, ^system_label, osc$null_name,              
              jmc$blank_system_supplied_name, ignore_status);                                                 
      IFEND;                                                                                                  
                                                                                                              
{ Enter the file in the Known Output List.                                                                    
                                                                                                              
      qfp$print_file (system_label, earliest_clock_time_to_print, latest_clock_time_to_print,                 
            current_microsecond_clock, status);                                                               
      IF NOT status.normal THEN                                                                               
        IF jmv$job_history_active THEN                                                                        
          reason := '';                                                                                       
          osp$get_status_condition_name (status.condition, reason, ignore_status);                            
          jmp$emit_job_history_statistics (jml$output_queuing_aborted, osc$null_name,                         
                system_label.system_job_name, system_file_name, NIL, NIL, reason,                             
                jmc$blank_system_supplied_name, ignore_status);                                               
        IFEND;                                                                                                
        osp$establish_block_exit_hndlr (^handle_block_exit);                                                  
        pfp$begin_system_authority;                                                                           
        pfp$purge (path_p^, cycle_selector, password, ignore_status);                                         
        pfp$end_system_authority;                                                                             
        osp$disestablish_cond_handler;                                                                        
        IF status.condition = jme$duplicate_name THEN                                                         
          status.normal := TRUE;                                                                              
          qfp$assign_system_supplied_name (system_label.system_file_name);                                    
          CYCLE /print_file/;                                                                                 
        IFEND;                                                                                                
                                                                                                              
      ELSE                                                                                                    
        pmp$get_user_identification (user_identification, ignore_status);                                     
        IF (NOT jmp$system_job ()) OR (user_identification = system_label.login_user_identification) THEN     
          statistic_data.statistic_id := jmc$ca_print_file;                                                   
          PUSH statistic_data.print_file;                                                                     
          statistic_data.print_file^.file_size := system_label.file_size;                                     
          statistic_data.print_file^.user_file_name := system_label.user_file_name;                           
          statistic_data.print_file^.system_file_name := system_label.system_file_name;                       
          jmp$emit_communication_stat (statistic_data);                                                       
        IFEND;                                                                                                
                                                                                                              
      IFEND;                                                                                                  
      EXIT /print_file/;                                                                                      
    WHILEND /print_file/;                                                                                     
                                                                                                              
    #KEYPOINT (osk$exit, 0, jmk$print_file);                                                                  
  PROCEND jmp$print_file;                                                                                     
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] jmp$purge_expired_file', EJECT ??                                                      
*copy jmh$purge_expired_file                                                                                  
                                                                                                              
  PROCEDURE [XDCL] jmp$purge_expired_file;                                                                    
                                                                                                              
    VAR                                                                                                       
      cycle_selector: pft$cycle_selector,                                                                     
      ignore_status: ost$status,                                                                              
      output_destination_usage: jmt$destination_usage,                                                        
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      statistic_data: jmt$comm_acct_statistic_data,                                                           
      system_file_name: jmt$system_supplied_name;                                                             
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      pfp$end_system_authority;                                                                               
    PROCEND handle_block_exit;                                                                                
?? OLDTITLE ??                                                                                                
?? EJECT ??                                                                                                   
                                                                                                              
    qfp$purge_expired_file (system_file_name, output_destination_usage);                                      
    IF system_file_name <> jmc$blank_system_supplied_name THEN                                                
      determine_file_path (output_destination_usage, system_file_name, path_p);                               
                                                                                                              
      statistic_data.statistic_id := jmc$ca_output_queue_residency;                                           
      PUSH statistic_data.output_queue_residency;                                                             
      statistic_data.output_queue_residency^.output_file_path := path_p;                                      
      jmp$emit_communication_stat (statistic_data);                                                           
                                                                                                              
      cycle_selector.cycle_option := pfc$specific_cycle;                                                      
      cycle_selector.cycle_number := 1;                                                                       
      password := osc$null_name;                                                                              
      osp$establish_block_exit_hndlr (^handle_block_exit);                                                    
      pfp$begin_system_authority;                                                                             
      pfp$purge (path_p^, cycle_selector, password, ignore_status);                                           
      pfp$end_system_authority;                                                                               
      osp$disestablish_cond_handler;                                                                          
    IFEND;                                                                                                    
  PROCEND jmp$purge_expired_file;                                                                             
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] jmp$purge_printed_file', EJECT ??                                                      
*copy jmh$purge_printed_file                                                                                  
                                                                                                              
  PROCEDURE [XDCL] jmp$purge_printed_file;                                                                    
                                                                                                              
    VAR                                                                                                       
      cycle_selector: pft$cycle_selector,                                                                     
      ignore_status: ost$status,                                                                              
      output_destination_usage: jmt$destination_usage,                                                        
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      statistic_data: jmt$comm_acct_statistic_data,                                                           
      system_file_name: jmt$system_supplied_name;                                                             
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      pfp$end_system_authority;                                                                               
    PROCEND handle_block_exit;                                                                                
?? OLDTITLE ??                                                                                                
?? EJECT ??                                                                                                   
                                                                                                              
    qfp$purge_printed_file (system_file_name, output_destination_usage);                                      
    IF system_file_name <> jmc$blank_system_supplied_name THEN                                                
      determine_file_path (output_destination_usage, system_file_name, path_p);                               
                                                                                                              
      statistic_data.statistic_id := jmc$ca_output_queue_residency;                                           
      PUSH statistic_data.output_queue_residency;                                                             
      statistic_data.output_queue_residency^.output_file_path := path_p;                                      
      jmp$emit_communication_stat (statistic_data);                                                           
                                                                                                              
      cycle_selector.cycle_option := pfc$specific_cycle;                                                      
      cycle_selector.cycle_number := 1;                                                                       
      password := osc$null_name;                                                                              
      osp$establish_block_exit_hndlr (^handle_block_exit);                                                    
      pfp$begin_system_authority;                                                                             
      pfp$purge (path_p^, cycle_selector, password, ignore_status);                                           
      pfp$end_system_authority;                                                                               
      osp$disestablish_cond_handler;                                                                          
    IFEND;                                                                                                    
  PROCEND jmp$purge_printed_file;                                                                             
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] jmp$rebuild_output_queue', EJECT ??                                                    
*copy jmh$rebuild_output_queue                                                                                
                                                                                                              
  PROCEDURE [XDCL] jmp$rebuild_output_queue                                                                   
    (    system_file_name: jmt$system_supplied_name;                                                          
         subcatalog_name: ost$name;                                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      current_date_time: ost$date_time,                                                                       
      current_microsecond_clock: jmt$clock_time,                                                              
      cycle_selector: pft$cycle_selector,                                                                     
      date_time: ost$date_time,                                                                               
      earliest_clock_time_to_print: jmt$clock_time,                                                           
      ignore_status: ost$status,                                                                              
      latest_clock_time_to_print: jmt$clock_time,                                                             
      local_file_name: amt$local_file_name,                                                                   
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      purge_delay_clock_time: jmt$clock_time,                                                                 
      scl_name: ost$name,                                                                                     
      system_label: jmt$output_system_label,                                                                  
      system_supplied_name: jmt$system_supplied_name,                                                         
      usage_selections: pft$usage_selections,                                                                 
      valid_name: boolean;                                                                                    
                                                                                                              
    status.normal := TRUE;                                                                                    
    ignore_status.normal := TRUE;                                                                             
                                                                                                              
                                                                                                              
    clp$validate_name (system_file_name, scl_name, valid_name);                                               
    IF NOT valid_name THEN                                                                                    
      osp$set_status_abnormal ('CL', cle$improper_name, system_file_name, status);                            
      RETURN;                                                                                                 
    IFEND;                                                                                                    
    system_supplied_name := scl_name;                                                                         
                                                                                                              
    pmp$get_unique_name (local_file_name, status);                                                            
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    PUSH path_p: [1 .. 4];                                                                                    
    path_p^ [1] := jmc$system_family;                                                                         
    path_p^ [2] := jmc$system_user;                                                                           
    path_p^ [3] := subcatalog_name;                                                                           
    path_p^ [4] := system_supplied_name;                                                                      
    cycle_selector.cycle_option := pfc$specific_cycle;                                                        
    cycle_selector.cycle_number := 1;                                                                         
    password := osc$null_name;                                                                                
    usage_selections := $pft$usage_selections [pfc$read];                                                     
                                                                                                              
    pfp$attach (local_file_name, path_p^, cycle_selector, password, usage_selections, usage_selections,       
          pfc$wait, status);                                                                                  
    IF NOT status.normal THEN                                                                                 
      pfp$purge (path_p^, cycle_selector, password, ignore_status);                                           
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ If we can't read the system label - don't recover it                                                        
{ In fact, delete the output file                                                                             
                                                                                                              
    qfp$read_output_system_label (local_file_name, system_label, status);                                     
    IF NOT status.normal THEN                                                                                 
      amp$return (local_file_name, ignore_status);                                                            
      pfp$purge (path_p^, cycle_selector, password, ignore_status);                                           
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Calculate the earliest_print_time, latest_print_time and purge_delay if necessary.                          
                                                                                                              
    pmp$get_microsecond_clock (current_microsecond_clock, ignore_status);                                     
    pmp$get_compact_date_time (current_date_time, ignore_status);                                             
                                                                                                              
                                                                                                              
{ If the file has been printed (i.e. disposition time is available) and a purge delay has been supplied then  
{ calculate the free-running clock value at which the file can be purged.                                     
{ The desired algorithm for a file that has been printed is:                                                  
{                                                                                                             
{   output_disposition_time = output_disposition_time + down_time;                                            
{   purge_delay_clock_time = output_disposition_time + purge_delay - current_time + microsecond_clock;        
{                                                                                                             
{ Currently the quantity (DOWN_TIME) is unknown so a file may get purged                                      
{ due to the system being down when its purge delay expires.                                                  
                                                                                                              
    IF system_label.output_disposition_time.specified THEN                                                    
      earliest_clock_time_to_print := jmc$earliest_clock_time;                                                
      latest_clock_time_to_print := jmc$latest_clock_time;                                                    
      IF system_label.purge_delay.specified THEN                                                              
        pmp$compute_date_time (system_label.output_disposition_time.date_time,                                
              system_label.purge_delay.time_increment, date_time, status);                                    
        IF NOT status.normal THEN                                                                             
          amp$return (local_file_name, ignore_status);                                                        
          RETURN;                                                                                             
        IFEND;                                                                                                
        jmp$convert_date_time_dif_to_us (current_date_time, date_time, current_microsecond_clock,             
              purge_delay_clock_time);                                                                        
      ELSE                                                                                                    
        purge_delay_clock_time := jmc$earliest_clock_time;                                                    
      IFEND;                                                                                                  
    ELSE                                                                                                      
      IF system_label.earliest_print_time.specified THEN                                                      
        jmp$convert_date_time_dif_to_us (current_date_time, system_label.earliest_print_time.date_time,       
              current_microsecond_clock, earliest_clock_time_to_print);                                       
      ELSE                                                                                                    
        earliest_clock_time_to_print := jmc$earliest_clock_time;                                              
      IFEND;                                                                                                  
                                                                                                              
      IF system_label.latest_print_time.specified THEN                                                        
        jmp$convert_date_time_dif_to_us (current_date_time, system_label.latest_print_time.date_time,         
              current_microsecond_clock, latest_clock_time_to_print);                                         
      ELSE                                                                                                    
        latest_clock_time_to_print := jmc$latest_clock_time;                                                  
      IFEND;                                                                                                  
      purge_delay_clock_time := jmc$earliest_clock_time;                                                      
    IFEND;                                                                                                    
                                                                                                              
    qfp$rebuild_output_queue (system_label, earliest_clock_time_to_print, latest_clock_time_to_print,         
          purge_delay_clock_time, current_microsecond_clock, status);                                         
    IF NOT status.normal THEN                                                                                 
      amp$return (local_file_name, ignore_status);                                                            
    ELSE                                                                                                      
      amp$return (local_file_name, status);                                                                   
    IFEND;                                                                                                    
                                                                                                              
  PROCEND jmp$rebuild_output_queue;                                                                           
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$register_output_application', EJECT ??                                      
*copy jmh$register_output_application                                                                         
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$register_output_application                                                     
    (    application_name: ost$name;                                                                          
         output_destination_usage: jmt$destination_usage;                                                     
     VAR queue_file_password: jmt$queue_file_password;                                                        
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      caller_id: ost$caller_identifier,                                                                       
      privileged_job: boolean,                                                                                
      valid_name: boolean,                                                                                    
      valid_application_name: ost$name,                                                                       
      valid_destination_usage: ost$name;                                                                      
                                                                                                              
    #KEYPOINT (osk$entry, 0, jmk$register_output_application);                                                
    status.normal := TRUE;                                                                                    
    #CALLER_ID (caller_id);                                                                                   
                                                                                                              
    privileged_job := (caller_id.ring <= osc$sj_ring_3) OR jmv$enable_queue_file_access OR jmp$system_job (); 
    IF NOT privileged_job THEN                                                                                
      osp$force_access_violation;                                                                             
    IFEND;                                                                                                    
                                                                                                              
    clp$validate_name (application_name, valid_application_name, valid_name);                                 
    IF NOT valid_name THEN                                                                                    
      osp$set_status_abnormal ('CL', cle$improper_name, application_name, status);                            
      #KEYPOINT (osk$exit, 0, jmk$register_output_application);                                               
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    clp$validate_name (output_destination_usage, valid_destination_usage, valid_name);                        
    IF NOT valid_name THEN                                                                                    
      osp$set_status_abnormal ('CL', cle$improper_name, output_destination_usage, status);                    
      #KEYPOINT (osk$exit, 0, jmk$register_output_application);                                               
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    pmp$get_unique_name (queue_file_password, status);                                                        
    IF status.normal THEN                                                                                     
      qfp$register_output_application (valid_application_name, valid_destination_usage, queue_file_password,  
            status);                                                                                          
      IF status.normal THEN                                                                                   
        task_has_registered_application := TRUE;                                                              
      IFEND;                                                                                                  
    IFEND;                                                                                                    
    #KEYPOINT (osk$exit, 0, jmk$register_output_application);                                                 
  PROCEND jmp$register_output_application;                                                                    
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] jmp$release_output_files', EJECT ??                                                    
*copy jmh$release_output_files                                                                                
                                                                                                              
  PROCEDURE [XDCL] jmp$release_output_files;                                                                  
                                                                                                              
    VAR                                                                                                       
      release_file_list: ^jmt$release_output_file_list,                                                       
      release_file_count: jmt$output_count_range,                                                             
      release_file_index: jmt$output_count_range,                                                             
      ignore_status: ost$status,                                                                              
      path_p: ^pft$path,                                                                                      
      statistic_data: jmt$comm_acct_statistic_data,                                                           
      cycle_selector: pft$cycle_selector,                                                                     
      password: pft$password;                                                                                 
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        local_status: ost$status;                                                                             
                                                                                                              
      pfp$end_system_authority;                                                                               
      IF ignore_status.normal THEN                                                                            
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, ignore_status, local_status);
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    IF NOT task_has_registered_application THEN                                                               
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    ignore_status.normal := TRUE;                                                                             
                                                                                                              
    statistic_data.statistic_id := jmc$ca_output_queue_residency;                                             
    PUSH statistic_data.output_queue_residency;                                                               
                                                                                                              
    PUSH release_file_list: [1 .. jmc$maximum_output_count];                                                  
    release_file_count := 0;                                                                                  
                                                                                                              
{ Since the release_file_list is at the maximum, no test will be necessary to verify that                     
{ the release_file_count does not exceed the upperbound of the list.                                          
                                                                                                              
    qfp$release_output_files (release_file_list, release_file_count);                                         
                                                                                                              
    cycle_selector.cycle_option := pfc$specific_cycle;                                                        
    cycle_selector.cycle_number := 1;                                                                         
    password := osc$null_name;                                                                                
    PUSH path_p: [1 .. 4];                                                                                    
    path_p^ [1] := jmc$system_family;                                                                         
    path_p^ [2] := jmc$system_user;                                                                           
                                                                                                              
    osp$establish_block_exit_hndlr (^handle_block_exit);                                                      
    pfp$begin_system_authority;                                                                               
                                                                                                              
  /purge_all_released_files/                                                                                  
    FOR release_file_index := 1 TO release_file_count DO                                                      
      determine_file_catalog (release_file_list^ [release_file_index].output_destination_usage, path_p^ [3]); 
      path_p^ [4] := release_file_list^ [release_file_index].system_file_name;                                
      statistic_data.output_queue_residency^.output_file_path := path_p;                                      
      jmp$emit_communication_stat (statistic_data);                                                           
      pfp$purge (path_p^, cycle_selector, password, ignore_status);                                           
    FOREND /purge_all_released_files/;                                                                        
                                                                                                              
    pfp$end_system_authority;                                                                                 
    osp$disestablish_cond_handler;                                                                            
  PROCEND jmp$release_output_files;                                                                           
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$set_output_completed', EJECT ??                                             
*copy jmh$set_output_completed                                                                                
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$set_output_completed                                                            
    (    output_destination_usage: jmt$destination_usage;                                                     
         system_file_name: jmt$system_supplied_name;                                                          
         completed_successfully: boolean;                                                                     
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      cycle_selector: pft$cycle_selector,                                                                     
      current_clock_time: jmt$clock_time,                                                                     
      date_time: ost$date_time,                                                                               
      delete_output_file: boolean,                                                                            
      ignore_status: ost$status,                                                                              
      local_file_name: amt$local_file_name,                                                                   
      local_status: ost$status,                                                                               
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      purge_delay_clock_time: jmt$clock_time,                                                                 
      share_selections: pft$usage_selections,                                                                 
      statistic_data: jmt$comm_acct_statistic_data,                                                           
      system_job_name: jmt$system_supplied_name,                                                              
      system_label: jmt$output_system_label,                                                                  
      usage_selections: pft$usage_selections;                                                                 
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      pfp$end_system_authority;                                                                               
      IF status.normal THEN                                                                                   
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);      
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
    #KEYPOINT (osk$entry, 0, jmk$output_completed);                                                           
    determine_file_path (output_destination_usage, system_file_name, path_p);                                 
    cycle_selector.cycle_option := pfc$specific_cycle;                                                        
    cycle_selector.cycle_number := 1;                                                                         
    password := osc$null_name;                                                                                
                                                                                                              
    IF completed_successfully THEN                                                                            
      pmp$get_unique_name (local_file_name, ignore_status);                                                   
      usage_selections := $pft$usage_selections [pfc$read, pfc$modify];                                       
      share_selections := $pft$share_selections [pfc$read];                                                   
      osp$establish_block_exit_hndlr (^handle_block_exit);                                                    
      pfp$begin_system_authority;                                                                             
      pfp$attach (local_file_name, path_p^, cycle_selector, password, usage_selections, usage_selections,     
            pfc$wait, status);                                                                                
      pfp$end_system_authority;                                                                               
                                                                                                              
{ The attach has completed - dump the handler                                                                 
                                                                                                              
      osp$disestablish_cond_handler;                                                                          
      IF NOT status.normal THEN                                                                               
        #KEYPOINT (osk$exit, 0, jmk$output_completed);                                                        
        RETURN;                                                                                               
      IFEND;                                                                                                  
      qfp$read_output_system_label (local_file_name, system_label, status);                                   
      IF NOT status.normal THEN                                                                               
        #KEYPOINT (osk$exit, 0, jmk$output_completed);                                                        
        RETURN;                                                                                               
      IFEND;                                                                                                  
      pmp$get_microsecond_clock (current_clock_time, ignore_status);                                          
      pmp$get_compact_date_time (system_label.output_disposition_time.date_time, ignore_status);              
      system_label.output_disposition_time.specified := TRUE;                                                 
      IF system_label.purge_delay.specified THEN                                                              
        pmp$compute_date_time (system_label.output_disposition_time.date_time,                                
              system_label.purge_delay.time_increment, date_time, ignore_status);                             
        jmp$convert_date_time_dif_to_us (system_label.output_disposition_time.date_time, date_time,           
              current_clock_time, purge_delay_clock_time);                                                    
      ELSE                                                                                                    
        purge_delay_clock_time := jmc$earliest_clock_time;                                                    
      IFEND;                                                                                                  
    ELSE                                                                                                      
      purge_delay_clock_time := jmc$earliest_clock_time;                                                      
    IFEND;                                                                                                    
                                                                                                              
    qfp$set_output_completed (output_destination_usage, system_file_name, completed_successfully,             
          purge_delay_clock_time, current_clock_time, delete_output_file, system_job_name, status);           
    IF status.normal THEN                                                                                     
      IF jmv$job_history_active THEN                                                                          
        IF (output_destination_usage = jmc$dual_state_usage) OR                                               
              (output_destination_usage = jmc$private_usage) OR                                               
              (output_destination_usage = jmc$public_usage) THEN                                              
          jmp$emit_job_history_statistics (jml$print_plot_terminated, osc$null_name, system_job_name,         
                system_file_name, NIL, NIL, osc$null_name, jmc$blank_system_supplied_name, local_status);     
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
      IF delete_output_file THEN                                                                              
                                                                                                              
{ The file must be detached because the output queue residency statistic will                                 
{ require that the file be re-attached to emit the correct information.                                       
                                                                                                              
        IF completed_successfully THEN                                                                        
          amp$return (local_file_name, ignore_status);                                                        
        IFEND;                                                                                                
        statistic_data.statistic_id := jmc$ca_output_queue_residency;                                         
        PUSH statistic_data.output_queue_residency;                                                           
        statistic_data.output_queue_residency^.output_file_path := path_p;                                    
        jmp$emit_communication_stat (statistic_data);                                                         
                                                                                                              
        osp$establish_block_exit_hndlr (^handle_block_exit);                                                  
        pfp$begin_system_authority;                                                                           
        pfp$purge (path_p^, cycle_selector, password, status);                                                
        pfp$end_system_authority;                                                                             
        osp$disestablish_cond_handler;                                                                        
      ELSEIF completed_successfully THEN                                                                      
                                                                                                              
{ Write the updated output file's system label                                                                
                                                                                                              
        qfp$write_output_system_label (local_file_name, { write_label } TRUE, system_label, status);          
        IF status.normal THEN                                                                                 
          amp$return (local_file_name, status);                                                               
        ELSE                                                                                                  
          amp$return (local_file_name, ignore_status);                                                        
        IFEND;                                                                                                
      IFEND;                                                                                                  
    ELSE                                                                                                      
      amp$return (local_file_name, ignore_status);                                                            
    IFEND;                                                                                                    
                                                                                                              
    #KEYPOINT (osk$exit, 0, jmk$output_completed);                                                            
  PROCEND jmp$set_output_completed;                                                                           
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$set_output_initiated', EJECT ??                                             
*copy jmh$set_output_initiated                                                                                
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$set_output_initiated                                                            
    (    output_destination_usage: jmt$destination_usage;                                                     
         system_file_name: jmt$system_supplied_name;                                                          
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      application_name: ost$name,                                                                             
      local_status: ost$status,                                                                               
      system_job_name: jmt$system_supplied_name;                                                              
                                                                                                              
    #KEYPOINT (osk$entry, 0, jmk$set_output_initiated);                                                       
    status.normal := TRUE;                                                                                    
                                                                                                              
    qfp$set_output_initiated (output_destination_usage, system_file_name, system_job_name, status);           
    IF status.normal AND jmv$job_history_active THEN                                                          
      qfp$get_application_name (output_destination_usage, application_name);                                  
      IF (output_destination_usage = jmc$dual_state_usage) OR                                                 
            (output_destination_usage = jmc$private_usage) OR                                                 
            (output_destination_usage = jmc$public_usage) THEN                                                
        jmp$emit_job_history_statistics (jml$print_plot_initiated, osc$null_name, system_job_name,            
              system_file_name, NIL, NIL, application_name, jmc$blank_system_supplied_name, local_status);    
      ELSE                                                                                                    
        jmp$emit_job_history_statistics (jml$output_forwarding_started, osc$null_name, system_job_name,       
              system_file_name, NIL, NIL, application_name, jmc$blank_system_supplied_name, local_status);    
      IFEND;                                                                                                  
    IFEND;                                                                                                    
    #KEYPOINT (osk$exit, 0, jmk$set_output_initiated);                                                        
  PROCEND jmp$set_output_initiated;                                                                           
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$terminate_acquired_output', EJECT ??                                        
*copy jmh$terminate_acquired_output                                                                           
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$terminate_acquired_output                                                       
    (    output_destination_usage: jmt$destination_usage;                                                     
     VAR system_file_name: jmt$system_supplied_name;                                                          
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      delete_output_file: boolean,                                                                            
      cycle_selector: pft$cycle_selector,                                                                     
      ignore_status: ost$status,                                                                              
      path_p: ^pft$path,                                                                                      
      password: pft$password,                                                                                 
      statistic_data: jmt$comm_acct_statistic_data,                                                           
      system_job_name: jmt$system_supplied_name;                                                              
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      pfp$end_system_authority;                                                                               
      IF status.normal THEN                                                                                   
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);      
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    status.normal := TRUE;                                                                                    
    #KEYPOINT (osk$entry, 0, jmk$terminate_acquired_output);                                                  
                                                                                                              
    qfp$terminate_acquired_output (output_destination_usage, system_file_name, system_job_name,               
          delete_output_file, status);                                                                        
    IF NOT status.normal THEN                                                                                 
      #KEYPOINT (osk$exit, 0, jmk$terminate_acquired_output);                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF delete_output_file THEN                                                                                
      IF jmv$job_history_active THEN                                                                          
        jmp$emit_job_history_statistics (jml$print_plot_terminated, osc$null_name, system_job_name,           
              system_file_name, NIL, NIL, osc$null_name, jmc$blank_system_supplied_name, ignore_status);      
      IFEND;                                                                                                  
      determine_file_path (output_destination_usage, system_file_name, path_p);                               
                                                                                                              
      statistic_data.statistic_id := jmc$ca_output_queue_residency;                                           
      PUSH statistic_data.output_queue_residency;                                                             
      statistic_data.output_queue_residency^.output_file_path := path_p;                                      
      jmp$emit_communication_stat (statistic_data);                                                           
                                                                                                              
      cycle_selector.cycle_option := pfc$specific_cycle;                                                      
      cycle_selector.cycle_number := 1;                                                                       
      password := osc$null_name;                                                                              
      osp$establish_block_exit_hndlr (^handle_block_exit);                                                    
      pfp$begin_system_authority;                                                                             
      pfp$purge (path_p^, cycle_selector, password, status);                                                  
      pfp$end_system_authority;                                                                               
      osp$disestablish_cond_handler;                                                                          
    IFEND;                                                                                                    
    #KEYPOINT (osk$exit, 0, jmk$terminate_acquired_output);                                                   
  PROCEND jmp$terminate_acquired_output;                                                                      
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$terminated_output_exists', EJECT ??                                         
*copy jmh$terminated_output_exists                                                                            
                                                                                                              
  FUNCTION [XDCL, #GATE] jmp$terminated_output_exists                                                         
    (    output_destination_usage: jmt$destination_usage): boolean;                                           
                                                                                                              
    VAR                                                                                                       
      application_index: jmt$output_application_index,                                                        
      output_exists: boolean;                                                                                 
                                                                                                              
    #KEYPOINT (osk$entry, 0, jmk$terminated_output_exists);                                                   
    application_index := UPPERBOUND (jmv$known_output_list.application_table);                                
    WHILE (jmv$known_output_list.application_table [application_index].destination_usage <>                   
          output_destination_usage) AND (application_index <> jmc$unassigned_output_index) DO                 
      application_index := application_index - 1;                                                             
    WHILEND;                                                                                                  
                                                                                                              
    output_exists := (application_index <> jmc$unassigned_output_index) AND                                   
          (jmv$known_output_list.application_table [application_index].                                       
          state_data [jmc$kol_application_terminated].number_of_entries > 0);                                 
    jmp$terminated_output_exists := output_exists AND (NOT syp$system_is_idling ());                          
    #KEYPOINT (osk$exit, 0, jmk$terminated_output_exists);                                                    
  FUNCEND jmp$terminated_output_exists;                                                                       
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$terminate_output', EJECT ??                                                 
*copy jmh$terminate_output                                                                                    
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$terminate_output                                                                
    (    output_name: jmt$name;                                                                               
         output_termination_options: ^jmt$output_termination_options;                                         
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      caller_id: ost$caller_identifier,                                                                       
      jm_work_area_p: ^jmt$work_area,                                                                         
      local_parameters_p: ^mainframe_tero_parameters,                                                         
      mainframes_processed: jmt$rpc_mainframes_processed,                                                     
      number_of_data_packets: ost$non_negative_integers,                                                      
      number_of_outputs_found: jmt$output_status_count,                                                       
      option_index: integer,                                                                                  
      output_state_set: jmt$output_state_set,                                                                 
      output_to_terminate: jmt$name,                                                                          
      reason: ost$name,                                                                                       
      scl_name: ost$name,                                                                                     
      status_options_p: ^jmt$output_status_options,                                                           
      status_results_keys_p: ^jmt$results_keys,                                                               
      status_results_p: ^jmt$output_status_results,                                                           
      status_result_size: ost$segment_length,                                                                 
      status_work_area_p: ^SEQ ( * ),                                                                         
      target_mainframe_reached: boolean,                                                                      
      target_options_p: ^SEQ ( * );                                                                           
                                                                                                              
    #KEYPOINT (osk$entry, 0, jmk$terminate_output);                                                           
    #CALLER_ID (caller_id);                                                                                   
    status.normal := TRUE;                                                                                    
                                                                                                              
{ Set defaults                                                                                                
                                                                                                              
    output_state_set := -$jmt$output_state_set [];                                                            
    reason := osc$null_name;                                                                                  
                                                                                                              
{ Override defaults if necessary                                                                              
                                                                                                              
    IF output_termination_options <> NIL THEN                                                                 
      FOR option_index := 1 TO UPPERBOUND (output_termination_options^) DO                                    
        CASE output_termination_options^ [option_index].key OF                                                
        = jmc$null_attribute =                                                                                
          ;                                                                                                   
                                                                                                              
        = jmc$output_state_set =                                                                              
          IF output_termination_options^ [option_index].output_state_set = $jmt$output_state_set [] THEN      
            osp$set_status_abnormal (jmc$job_management_id, jme$output_state_is_null, '', status);            
            #KEYPOINT (osk$exit, 0, jmk$terminate_output);                                                    
            RETURN;                                                                                           
          IFEND;                                                                                              
          output_state_set := output_termination_options^ [option_index].output_state_set;                    
                                                                                                              
        = jmc$termination_reason =                                                                            
          reason := output_termination_options^ [option_index].reason;                                        
                                                                                                              
        ELSE                                                                                                  
          jmp$get_attribute_name (output_termination_options^ [option_index].key, scl_name);                  
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'OUTPUT_TERMINATION_OPTIONS', status); 
          osp$append_status_parameter (osc$status_parameter_delimiter, jmc$terminate_output, status);         
          #KEYPOINT (osk$exit, 0, jmk$terminate_output);                                                      
          RETURN;                                                                                             
        CASEND;                                                                                               
      FOREND;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    jmp$validate_name (output_name, output_to_terminate, status);                                             
    IF NOT status.normal THEN                                                                                 
      #KEYPOINT (osk$exit, 0, jmk$terminate_output);                                                          
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    PUSH status_options_p: [1 .. 4];                                                                          
    status_options_p^ [1].key := jmc$name_list;                                                               
    PUSH status_options_p^ [1].name_list: [1 .. 1];                                                           
    status_options_p^ [1].name_list^ [1] := output_to_terminate;                                              
    status_options_p^ [2].key := jmc$output_state_set;                                                        
    status_options_p^ [2].output_state_set := output_state_set;                                               
    status_options_p^ [3].key := jmc$privilege;                                                               
    IF avp$system_operator () OR (caller_id.ring <= osc$tsrv_ring) THEN                                       
      status_options_p^ [3].privilege := jmc$privileged;                                                      
    ELSE                                                                                                      
      status_options_p^ [3].privilege := jmc$not_privileged;                                                  
    IFEND;                                                                                                    
    status_options_p^ [4].key := jmc$continue_request_to_servers;                                             
    status_options_p^ [4].continue_request_to_servers := TRUE;                                                
                                                                                                              
    PUSH status_results_keys_p: [1 .. 2];                                                                     
    status_results_keys_p^ [1] := jmc$system_file_name;                                                       
    status_results_keys_p^ [2] := jmc$client_mainframe_id;                                                    
                                                                                                              
{ If we are able to status the output file, we have control over the file                                     
{ so we can change the attributes of the file                                                                 
                                                                                                              
    jmp$get_result_size ({number_of_items} 1, #SEQ (status_results_keys_p^), status_result_size);             
    PUSH status_work_area_p: [[REP status_result_size OF cell]];                                              
    RESET status_work_area_p;                                                                                 
                                                                                                              
    jmp$get_output_status (status_options_p, status_results_keys_p, status_work_area_p, status_results_p,     
          number_of_outputs_found, status);                                                                   
    IF NOT status.normal THEN                                                                                 
      IF status.condition = jme$work_area_too_small THEN                                                      
        IF output_name.kind = jmc$system_supplied_name THEN { Can't ever happen                               
          osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_name,                                 
                output_name.system_supplied_name, status);                                                    
        ELSE                                                                                                  
          osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_name, output_name.user_supplied_name, 
                status);                                                                                      
        IFEND;                                                                                                
      ELSEIF status.condition = jme$no_outputs_were_found THEN                                                
        IF output_name.kind = jmc$system_supplied_name THEN                                                   
          osp$set_status_abnormal ('JM', jme$name_not_found, output_name.system_supplied_name, status);       
        ELSE                                                                                                  
          osp$set_status_abnormal ('JM', jme$name_not_found, output_name.user_supplied_name, status);         
        IFEND;                                                                                                
      IFEND;                                                                                                  
      #KEYPOINT (osk$exit, 0, jmk$terminate_output);                                                          
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    PUSH target_options_p: [[REP (#SIZE (jmt$system_supplied_name) + #SIZE (reason) +                         
          #SIZE (jmt$output_state_set)) OF cell]];                                                            
    RESET target_options_p;                                                                                   
    NEXT local_parameters_p IN target_options_p;                                                              
    local_parameters_p^.system_file_name := status_results_p^ [1]^ [1].system_file_name;                      
    local_parameters_p^.reason := reason;                                                                     
    local_parameters_p^.output_state_set := output_state_set;                                                 
                                                                                                              
{ Call the general purpose RPC processor to terminate the output file.                                        
                                                                                                              
    mainframes_processed.count := 0;                                                                          
    jm_work_area_p := NIL;                                                                                    
    jmp$general_purpose_cluster_rpc (status_results_p^ [1]^ [2].client_mainframe_id,                          
          jmc$gpro_terminate_output, {data_packet_size} 0, mainframes_processed, target_options_p,            
          jm_work_area_p, target_mainframe_reached, mainframes_processed, number_of_data_packets, status);    
    #KEYPOINT (osk$exit, 0, jmk$terminate_output);                                                            
  PROCEND jmp$terminate_output;                                                                               
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL, #GATE] jmp$update_output_status', EJECT ??                                             
*copy jmh$update_output_status                                                                                
                                                                                                              
  PROCEDURE [XDCL, #GATE] jmp$update_output_status                                                            
    (    system_file_name: jmt$system_supplied_name;                                                          
         destination_usage: jmt$destination_usage;                                                            
         queue_file_password: jmt$queue_file_password;                                                        
         output_status_updates: ^jmt$output_status_updates;                                                   
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      cycle_selector: pft$cycle_selector,                                                                     
      ignore_status: ost$status,                                                                              
      local_file_name: amt$local_file_name,                                                                   
      password: pft$password,                                                                                 
      path_p: ^pft$path,                                                                                      
      scl_name: ost$name,                                                                                     
      share_selections: pft$share_selections,                                                                 
      system_label: jmt$output_system_label,                                                                  
      update_index: integer,                                                                                  
      usage_selections: pft$usage_selections;                                                                 
                                                                                                              
?? NEWTITLE := 'handle_block_exit', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   The purpose of this procedure is to deal with block exit conditions that                                  
{   arise while system_authority is in effect.                                                                
                                                                                                              
    PROCEDURE handle_block_exit                                                                               
      (    condition: pmt$condition;                                                                          
           condition_information_p: ^pmt$condition_information;                                               
           sfsa_p: ^ost$stack_frame_save_area;                                                                
       VAR handler_status: ost$status);                                                                       
                                                                                                              
      VAR                                                                                                     
        ignore_status: ost$status;                                                                            
                                                                                                              
      pfp$end_system_authority;                                                                               
      IF status.normal THEN                                                                                   
        osp$set_status_from_condition (jmc$job_management_id, condition, sfsa_p, status, ignore_status);      
      IFEND;                                                                                                  
    PROCEND handle_block_exit;                                                                                
                                                                                                              
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
    #KEYPOINT (osk$entry, 0, jmk$update_output_status);                                                       
    ignore_status.normal := TRUE;                                                                             
    status.normal := TRUE;                                                                                    
                                                                                                              
{ Validate that the application has permission to access the file.                                            
                                                                                                              
    qfp$validate_output_file_access (system_file_name, destination_usage, queue_file_password, status);       
    IF NOT status.normal THEN                                                                                 
      #KEYPOINT (osk$exit, 0, jmk$update_output_status);                                                      
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    pmp$get_unique_name (local_file_name, status);                                                            
    IF NOT status.normal THEN                                                                                 
      #KEYPOINT (osk$exit, 0, jmk$update_output_status);                                                      
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    determine_file_path (destination_usage, system_file_name, path_p);                                        
    cycle_selector.cycle_option := pfc$specific_cycle;                                                        
    cycle_selector.cycle_number := 1;                                                                         
    password := osc$null_name;                                                                                
    usage_selections := $pft$usage_selections [pfc$read, pfc$modify];                                         
    share_selections := $pft$share_selections [pfc$read];                                                     
    osp$establish_block_exit_hndlr (^handle_block_exit);                                                      
    pfp$begin_system_authority;                                                                               
    pfp$attach (local_file_name, path_p^, cycle_selector, password, usage_selections, share_selections,       
          pfc$wait, status);                                                                                  
    pfp$end_system_authority;                                                                                 
    osp$disestablish_cond_handler;                                                                            
    IF NOT status.normal THEN                                                                                 
      #KEYPOINT (osk$exit, 0, jmk$update_output_status);                                                      
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Read the output file's system label                                                                         
                                                                                                              
    qfp$read_output_system_label (local_file_name, system_label, status);                                     
    IF NOT status.normal THEN                                                                                 
      amp$return (local_file_name, ignore_status);                                                            
      #KEYPOINT (osk$exit, 0, jmk$update_output_status);                                                      
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Check update changes and change the local copy of the system label                                          
                                                                                                              
    IF output_status_updates <> NIL THEN                                                                      
                                                                                                              
    /process_changes/                                                                                         
      FOR update_index := 1 TO UPPERBOUND (output_status_updates^) DO                                         
        CASE output_status_updates^ [update_index].key OF                                                     
        = jmc$copies_printed =                                                                                
          system_label.copies_printed := output_status_updates^ [update_index].copies_printed;                
                                                                                                              
        = jmc$file_position =                                                                                 
          system_label.file_position := output_status_updates^ [update_index].file_position;                  
                                                                                                              
        = jmc$null_attribute =                                                                                
          ;                                                                                                   
                                                                                                              
        ELSE                                                                                                  
          jmp$get_attribute_name (output_status_updates^ [update_index].key, scl_name);                       
          osp$set_status_abnormal (jmc$job_management_id, jme$invalid_parameter, scl_name, status);           
          osp$append_status_parameter (osc$status_parameter_delimiter, 'OUTPUT_STATUS_UPDATES', status);      
          osp$append_status_parameter (osc$status_parameter_delimiter, 'jmp$update_output_status', status);   
          EXIT /process_changes/;                                                                             
        CASEND;                                                                                               
      FOREND /process_changes/;                                                                               
      IF NOT status.normal THEN                                                                               
        amp$return (local_file_name, ignore_status);                                                          
        #KEYPOINT (osk$exit, 0, jmk$update_output_status);                                                    
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
{ Write the result system label to the output file                                                            
                                                                                                              
      qfp$write_output_system_label (local_file_name, { write_label } TRUE, system_label, status);            
      IF NOT status.normal THEN                                                                               
        amp$return (local_file_name, ignore_status);                                                          
        #KEYPOINT (osk$exit, 0, jmk$update_output_status);                                                    
        RETURN;                                                                                               
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Release the file in case somebody needs it                                                                  
                                                                                                              
    amp$return (local_file_name, status);                                                                     
    #KEYPOINT (osk$exit, 0, jmk$update_output_status);                                                        
  PROCEND jmp$update_output_status;                                                                           
MODEND jmm$queue_file_output_manager;                                                                         
*DECK DECK=JMM$QUEUE_FILE_SCHED_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE job management queued file/job scheduler interfaces', ??
MODULE jmm$queue_file_sched_interfaces;

{ PURPOSE:
{   This module contains the interfaces used by the Queue File Management and
{   the Job Scheduler to perform their communication.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmt$candidate_queued_jobs
*copyc jmt$kjl_application_state_set
*copyc jmt$kjl_index
*copyc jmt$job_class
*copyc oss$mainframe_pageable
*copyc ost$status
?? POP ??
*copyc jmp$job_selection_priority
*copyc jmp$set_examine_queue_event
*copyc osp$begin_system_activity
*copyc osp$clear_mainframe_sig_lock
*copyc osp$end_system_activity
*copyc osp$set_mainframe_sig_lock
*copyc pmp$get_compact_date_time
*copyc qfp$job_selection_priority
*copyc qfp$ready_job_leveler
*copyc qfp$relink_kjl_application
*copyc qfp$relink_kjl_client
*copyc qfp$relink_kjl_entry
*copyc qfp$relink_kjl_server
*copyc syp$wait
*copyc syp$system_is_idling
*copyc tmp$ready_system_task1
*copyc jmv$job_class_table_p
*copyc jmv$job_counts
*copyc jmv$job_scheduler_event
*copyc jmv$job_scheduler_table
*copyc jmv$kjl_p
*copyc jmv$kjlx_p
*copyc jmv$known_job_list
*copyc jmv$maximum_job_class_in_use
*copyc jmv$prevent_activation_of_jobs
*copyc jmv$sched_profile_is_loading
*copyc osv$mainframe_pageable_heap
*copyc qfv$kjl_lock
*copyc syv$recovering_job_count
?? OLDTITLE ??
?? NEWTITLE := 'Global Variables Declared by this Module', EJECT ??

  VAR
    jmv$candidate_queued_jobs: [XDCL, #GATE, oss$mainframe_pageable] jmt$candidate_queued_jobs,
    jmv$candidates_can_be_acquired: [XDCL, #GATE, oss$mainframe_pageable] boolean := TRUE,
    jmv$next_job_cand_refresh_time: [XDCL, #GATE, oss$mainframe_pageable] integer := 0,
    jmv$refresh_job_candidates: [XDCL, #GATE, oss$mainframe_pageable] boolean := TRUE;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$force_candidate_refresh' ??
*copy jmh$force_candidate_refresh

  PROCEDURE [XDCL] jmp$force_candidate_refresh
    (    flush_candidate_queue: boolean);

    jmv$candidates_can_be_acquired := NOT flush_candidate_queue;
    jmv$refresh_job_candidates := TRUE;
    jmp$set_examine_queue_event (jmc$examine_input_queue, jmc$null_job_class, { unconditional } TRUE);

{ Call osp$begin_system_activity to keep the task's priority high while the KJL lock
{ is clear.

    osp$begin_system_activity;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);

{ As soon as the variable jmv$refresh_job_candidates goes to FALSE it means that the job
{ scheduler has the KJL locked and is refreshing the candidate queue.  The next thing
{ is to lock the KJL to gain exclusive access.

    #SPOIL (jmv$refresh_job_candidates);
    WHILE jmv$refresh_job_candidates DO
      syp$wait ({milliseconds} 50);
      #SPOIL (jmv$refresh_job_candidates);
    WHILEND;
    osp$set_mainframe_sig_lock (qfv$kjl_lock);
    osp$end_system_activity;
    jmv$candidates_can_be_acquired := TRUE;
    jmv$refresh_job_candidates := TRUE;
    jmp$set_examine_queue_event (jmc$examine_input_queue, jmc$null_job_class, { unconditional } TRUE);
  PROCEND jmp$force_candidate_refresh;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$notify_job_scheduler_of_job', EJECT ??
*copy jmh$notify_job_scheduler_of_job

{ NOTES:
{   It is assumed that the Known Job List (KJL) is locked when this request is made.

  PROCEDURE [XDCL] jmp$notify_job_scheduler_of_job
    (    job_class: jmt$job_class;
         new_kjl_index: jmt$kjl_index);

    VAR
      current_time: jmt$clock_time,
      kjl_index: jmt$kjl_index;

{ Find the best initiation candidate in the job class.

    kjl_index := jmv$known_job_list.queued_class_entries [job_class].first_queued_class_entry;

    IF kjl_index <> jmc$kjl_undefined_index THEN

      IF jmv$candidate_queued_jobs [job_class].candidate_available THEN

{ If the current candidate is modified or terminated, notify the job scheduler
{ unconditionally.

        IF NOT assignable_job (jmv$candidate_queued_jobs [job_class].kjl_index) THEN
          jmv$refresh_job_candidates := TRUE;
          jmp$set_examine_queue_event (jmc$examine_input_queue, job_class, { unconditional } TRUE);
        ELSEIF jmv$candidate_queued_jobs [job_class].kjl_index <> kjl_index THEN
          IF new_kjl_index <> jmc$kjl_undefined_index THEN

{ If the current candidate is no longer the best candidate, notify the job scheduler.

            current_time := #FREE_RUNNING_CLOCK (0);
            IF jmp$job_selection_priority (current_time, new_kjl_index,
                  job_class) > jmp$job_selection_priority (current_time,
                  jmv$candidate_queued_jobs [job_class].kjl_index, job_class) THEN
              jmv$refresh_job_candidates := TRUE;
              jmp$set_examine_queue_event (jmc$examine_input_queue, job_class, { unconditional } FALSE);
            IFEND;
          IFEND;
        IFEND;
      ELSEIF within_class_limits (job_class) THEN

{ If a candidate can be initiated, notify the job scheduler.

      /search_for_candidate/
        WHILE kjl_index <> jmc$kjl_undefined_index DO
          IF eligible_job_categories (jmv$kjl_p^ [kjl_index].job_category_set) THEN
            jmv$refresh_job_candidates := TRUE;
            jmp$set_examine_queue_event (jmc$examine_input_queue, job_class, { unconditional } FALSE);
            EXIT /search_for_candidate/;
          IFEND;
          kjl_index := jmv$kjl_p^ [kjl_index].class_forward_link;
        WHILEND /search_for_candidate/;
      IFEND;
    IFEND;
  PROCEND jmp$notify_job_scheduler_of_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$notify_queued_files_job_end', EJECT ??
*copy jmh$notify_queued_files_job_end

  PROCEDURE [XDCL] jmp$notify_queued_files_job_end
    (    kjl_index: jmt$kjl_index);

    VAR
      job_class: jmt$job_class;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    job_class := jmv$kjl_p^ [kjl_index].job_class;

    IF jmv$known_job_list.queued_class_entries [job_class].termination_count < jmc$maximum_job_count THEN
      jmv$known_job_list.queued_class_entries [job_class].termination_count :=
            jmv$known_job_list.queued_class_entries [job_class].termination_count + 1;
    IFEND;
    jmv$job_counts.initiated_jobs := jmv$job_counts.initiated_jobs - 1;
    jmv$job_counts.job_class_counts [job_class].completed_jobs :=
          jmv$job_counts.job_class_counts [job_class].completed_jobs + 1;
    jmv$job_counts.job_class_counts [job_class].initiated_jobs :=
          jmv$job_counts.job_class_counts [job_class].initiated_jobs - 1;
    IF jmv$kjlx_p^ [kjl_index].job_mode <> jmc$batch THEN
      jmv$job_counts.interactive_jobs := jmv$job_counts.interactive_jobs - 1;
    IFEND;

{ If the job says to restart, put it in as a queued job - If the jobs login family is not available then
{ defer the job - otherwise remove it from the KJL.

    IF jmv$kjlx_p^ [kjl_index].restart_job THEN
      qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index, jmc$kjl_application_new);
      qfp$relink_kjl_client (kjl_index, jmc$kjl_client_undefined);
      qfp$relink_kjl_entry (kjl_index, job_class, jmc$kjl_queued_entry);
      jmp$notify_job_scheduler_of_job (job_class, kjl_index);

    ELSEIF NOT jmv$kjl_p^ [kjl_index].login_family_available THEN
      qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index, jmc$kjl_application_unused);
      qfp$relink_kjl_client (kjl_index, jmc$kjl_client_undefined);
      qfp$relink_kjl_entry (kjl_index, job_class, jmc$kjl_deferred_entry);
      jmp$notify_job_scheduler_of_job (job_class, jmc$kjl_undefined_index);

    ELSE
      IF jmv$kjlx_p^ [kjl_index].system_label_p <> NIL THEN
        FREE jmv$kjlx_p^ [kjl_index].system_label_p IN osv$mainframe_pageable_heap^;
      IFEND;
      qfp$relink_kjl_client (kjl_index, jmc$kjl_client_undefined);
      qfp$relink_kjl_server (kjl_index, jmc$kjl_server_undefined);
      qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index, jmc$kjl_application_unused);
      qfp$relink_kjl_entry (kjl_index, job_class, jmc$kjl_unused_entry);
      jmp$notify_job_scheduler_of_job (job_class, jmc$kjl_undefined_index);
    IFEND;

    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND jmp$notify_queued_files_job_end;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$refresh_job_candidates', EJECT ??
*copy jmh$refresh_job_candidates

  PROCEDURE [XDCL, #GATE] jmp$refresh_job_candidates;

    VAR
      kjl_index: jmt$kjl_index,
      job_class: jmt$job_class;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);
    jmv$refresh_job_candidates := FALSE;
    jmv$next_job_cand_refresh_time := UPPERVALUE (integer);

  /refresh_jobs_in_class/
    FOR job_class := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
      IF jmv$candidate_queued_jobs [job_class].candidate_available THEN

{ Check if the available candidate job should be removed from the candidate queue.
{ Remove it if it is no longer a candidate or not the best one.

        IF (NOT within_class_limits (job_class)) OR (NOT eligible_job_categories
              (jmv$kjl_p^ [jmv$candidate_queued_jobs [job_class].kjl_index].job_category_set)) OR
              (NOT assignable_job (jmv$candidate_queued_jobs [job_class].kjl_index)) OR
              (special_circumstances ()) THEN

{ Save the kjl index of the current candidate.  The current candidate cannot be the
{ best candidate any longer.  So keep the current candidate's kjl index and find the
{ new best candidate if there is one.  Then, remove the current candidate from the
{ application and client threads.

          kjl_index := jmv$candidate_queued_jobs [job_class].kjl_index;
          refresh_job_in_class (job_class);

{ Relink the entry as "unacquired".

          qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index, jmc$kjl_application_new);
          qfp$relink_kjl_client (kjl_index, jmc$kjl_client_undefined);

{ If the current candidate is not the first on in the list, there may be a new best
{ candidate.

        ELSEIF NOT (jmv$candidate_queued_jobs [job_class].kjl_index =
              jmv$known_job_list.queued_class_entries [job_class].first_queued_class_entry) THEN

{ Relink the entry as "unacquired".

          qfp$relink_kjl_application (jmv$candidate_queued_jobs [job_class].kjl_index,
                jmc$ve_input_application_index, jmc$kjl_application_new);
          qfp$relink_kjl_client (jmv$candidate_queued_jobs [job_class].kjl_index, jmc$kjl_client_undefined);
          refresh_job_in_class (job_class);
        IFEND;
      ELSE
        refresh_job_in_class (job_class);
      IFEND;
    FOREND /refresh_jobs_in_class/;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND jmp$refresh_job_candidates;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$refresh_job_candidate_class', EJECT ??
*copy jmh$refresh_job_candidate_class

  PROCEDURE [XDCL, #GATE] jmp$refresh_job_candidate_class
    (    job_class: jmt$job_class;
         initiation_succeeded: boolean);

    VAR
      ignore_status: ost$status,
      kjl_index: jmt$kjl_index;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);
    kjl_index := jmv$candidate_queued_jobs [job_class].kjl_index;

    IF initiation_succeeded THEN

{ Relink the entry as initiated so far as the scheduler application is concerned.

      qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index, jmc$kjl_application_initiated);
      jmv$kjlx_p^ [kjl_index].restart_job := FALSE;
      jmv$kjl_p^ [kjl_index].initiated_job_list_ordinal :=
            jmv$candidate_queued_jobs [job_class].initiated_job_list_ordinal;
      jmv$kjlx_p^ [kjl_index].job_monitor_global_task_id :=
            jmv$candidate_queued_jobs [job_class].job_monitor_global_task_id;
      pmp$get_compact_date_time (jmv$kjlx_p^ [kjl_index].job_initiation_time, ignore_status);
      jmv$job_counts.initiated_jobs := jmv$job_counts.initiated_jobs + 1;
      jmv$job_counts.job_class_counts [job_class].initiated_jobs := jmv$job_counts.
            job_class_counts [job_class].initiated_jobs + 1;

      IF jmv$kjlx_p^ [kjl_index].job_mode <> jmc$batch THEN
        jmv$job_counts.interactive_jobs := jmv$job_counts.interactive_jobs + 1;
      IFEND;

{ CAUTION: The relink of the entry must be done after ALL fields in the KJL are set - this
{          is because it is possible for a job to begin execution before the scheduler gets
{          here.  There is a point in JMP$INITIALIZE_JOB_ENVIRONMENT where the job will wait
{          for its KJL entry to become "initiated" before it goes on to a point where it will
{          have need to reference its KJL entry.

      qfp$relink_kjl_entry (kjl_index, job_class, jmc$kjl_initiated_entry);

      refresh_job_in_class (job_class);
    ELSE
      IF NOT assignable_job (kjl_index) THEN

        refresh_job_in_class (job_class);

{ Relink the job from the Scheduler application.

        qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index, jmc$kjl_application_new);
        qfp$relink_kjl_client (kjl_index, jmc$kjl_client_undefined);
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND jmp$refresh_job_candidate_class;
?? OLDTITLE ??
?? NEWTITLE := 'assignable_job', EJECT ??

{ PURPOSE:
{   The purpose of this function is to indicate if the job can be assigned as a
{ candidate for initiation.

  FUNCTION [INLINE] assignable_job
    (    kjl_index: jmt$kjl_index): boolean;

    assignable_job := (jmv$kjl_p^ [kjl_index].application_state IN
          -$jmt$kjl_application_state_set [jmc$kjl_application_terminated, jmc$kjl_application_modified]);
  FUNCEND assignable_job;
?? OLDTITLE ??
?? NEWTITLE := 'eligible_job_categories', EJECT ??

{ PURPOSE:
{   The purpose of this function is to indicate if the given categories would
{   allow a job to initiate on this mainframe.
{ DESIGN:
{   Check that the given categories contain all of the categories which are
{   required for initiation on this mainframe and none of the categories which
{   are excluded from initiation on this mainframe.

  FUNCTION [INLINE] eligible_job_categories
    (    categories: jmt$job_category_set): boolean;

    eligible_job_categories := ((jmv$job_scheduler_table.initiation_required_categories * categories) =
          jmv$job_scheduler_table.initiation_required_categories) AND
          ((jmv$job_scheduler_table.initiation_excluded_categories * categories) = $jmt$job_category_set []);

  FUNCEND eligible_job_categories;
?? OLDTITLE ??
?? NEWTITLE := 'refresh_job_in_class', EJECT ??

{ PURPOSE:
{   The purpose of this request is to refresh the job candidate queue for job scheduler. It is refreshed
{ when a place is open in the job class.  This request is made only via a request from the Job Scheduler.

  PROCEDURE refresh_job_in_class
    (    job_class: jmt$job_class);

    VAR
      candidate_for_this_mainframe: boolean,
      ignore_status_p: ^ost$status,
      job_priority: jmt$job_priority,
      kjl_index: jmt$kjl_index,
      ready_time: integer;

    jmv$candidate_queued_jobs [job_class].candidate_available := FALSE;
    IF within_class_limits (job_class) AND (NOT special_circumstances ()) THEN
      kjl_index := jmv$known_job_list.queued_class_entries [job_class].first_queued_class_entry;
      candidate_for_this_mainframe := FALSE;

{ Find the best candidate that is in the KJL for this job class.

      WHILE (kjl_index <> jmc$kjl_undefined_index) AND (NOT candidate_for_this_mainframe) DO
        candidate_for_this_mainframe := eligible_job_categories (jmv$kjl_p^ [kjl_index].job_category_set) AND
              (NOT jmv$known_job_list.queued_class_entries [job_class].class_blocked_for_initiation) AND
              (assignable_job (kjl_index));
        IF NOT candidate_for_this_mainframe THEN
          kjl_index := jmv$kjl_p^ [kjl_index].class_forward_link;
        IFEND;
      WHILEND;

{ If there is a job in the KJL or a job on a server mainframe then continue.
{ If the highest priority job is on the server, ready the job leveler task and
{ block the job class from initiation.  Otherwise, initiate the available job.

      IF candidate_for_this_mainframe OR (jmv$known_job_list.queued_class_entries [job_class].
            server_mainframe_priority > 0) THEN
        job_priority := qfp$job_selection_priority (#FREE_RUNNING_CLOCK (0), kjl_index);
        IF (jmv$known_job_list.queued_class_entries [job_class].number_of_jobs_needed = 0) AND
              (jmv$known_job_list.queued_class_entries [job_class].server_mainframe_priority >
              job_priority) THEN
          IF jmv$known_job_list.queued_class_entries [job_class].server_mainframe_priority <
                jmv$job_class_table_p^ [job_class].selection_priority.threshold THEN
            RETURN;
          IFEND;
          jmv$known_job_list.queued_class_entries [job_class].class_blocked_for_initiation := TRUE;
          qfp$ready_job_leveler;
        ELSEIF candidate_for_this_mainframe AND (job_priority >=
              jmv$job_class_table_p^ [job_class].selection_priority.threshold) THEN
          jmv$candidate_queued_jobs [job_class].candidate_available := TRUE;

{ NOTE: scheduler will setup the node when needed.

          jmv$candidate_queued_jobs [job_class].job_submission_time :=
                jmv$kjl_p^ [kjl_index].job_submission_time;
          jmv$candidate_queued_jobs [job_class].kjl_index := kjl_index;
          jmv$candidate_queued_jobs [job_class].system_supplied_name := jmv$kjl_p^ [kjl_index].
                system_job_name;
          jmv$candidate_queued_jobs [job_class].user_supplied_name := jmv$kjl_p^ [kjl_index].user_job_name;

{ Relink the entry to indicate that the Job Scheduler application has acquired the file.

          qfp$relink_kjl_client (kjl_index, jmc$kjl_client_this_mainframe);
          qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index,
                jmc$kjl_application_acquired);
        ELSEIF candidate_for_this_mainframe THEN

{ The best candidate job cannot initiate just yet.  Determine when it will be
{ able to initiate and make sure the scheduler will wake up in time to detect
{ it.

          IF (jmv$job_class_table_p^ [job_class].selection_priority.increment > 0) AND
                (jmv$job_class_table_p^ [job_class].initiation_age_interval <>
                jmc$unlimited_prio_age_interval) THEN
            ready_time := #FREE_RUNNING_CLOCK (0) + (jmv$job_class_table_p^ [job_class].selection_priority.
                  threshold - job_priority) * jmv$job_class_table_p^ [job_class].initiation_age_interval DIV
                  jmv$job_class_table_p^ [job_class].selection_priority.increment;
            IF ready_time < jmv$next_job_cand_refresh_time THEN
              jmv$next_job_cand_refresh_time := ready_time;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND refresh_job_in_class;
?? OLDTITLE ??
?? NEWTITLE := 'special_circumstances', EJECT ??

{ PURPOSE:
{   The purpose of this function is to indicate if the system is in a special state so that
{ jobs cannot be made available to the job scheduler.

  FUNCTION [INLINE] special_circumstances: boolean;

    special_circumstances := (syv$recovering_job_count > 0) OR syp$system_is_idling () OR
          jmv$sched_profile_is_loading OR (NOT jmv$candidates_can_be_acquired) OR
          jmv$prevent_activation_of_jobs;
  FUNCEND special_circumstances;
?? OLDTITLE ??
?? NEWTITLE := 'within_class_limits', EJECT ??

{ PURPOSE:
{   The purpose of this function is to indicate if the initiation of the job is permitted based on
{ the job class restrictions.

  FUNCTION [INLINE] within_class_limits
    (    job_class: jmt$job_class): boolean;

    within_class_limits := ((jmv$job_class_table_p^ [job_class].initiation_level.preferred >
          jmv$job_counts.job_class_counts [job_class].initiated_jobs) AND
          (jmv$job_class_table_p^ [job_class].enable_class_initiation) AND
          (jmv$job_class_table_p^ [job_class].required_categories *
          jmv$job_scheduler_table.initiation_excluded_categories = $jmt$job_category_set []) AND
          (jmv$job_class_table_p^ [job_class].excluded_categories *
          jmv$job_scheduler_table.initiation_required_categories = $jmt$job_category_set []));

  FUNCEND within_class_limits;
?? OLDTITLE ??
MODEND jmm$queue_file_sched_interfaces;
*DECK DECK=JMM$SAVE_RECOVERY_INFORMATION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE job management recovery interfaces', ??
MODULE jmm$save_recovery_information;

{ PURPOSE:
{   This module contains the interfaces used to save information in the address
{   space of the job that is required in order to recover the job.
{
{ DESIGN:
{   Information required only for recovery by a job should not be part of the
{ job's working set but needs to be in the job's address space.  The recovery
{ information saved is in the job pageable segment.  Using aligned allocation
{ in job pageable, the information begins on a page boundary and always consists
{ of an allocation that is an integral number of pages.  After being updated,
{ this information is written to disk (without wait) and the page(s) can be
{ removed from the job's working set.  The procedures in this module execute
{ in ring 2.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_recovery_information
*copyc oss$job_pageable
*copyc ost$status
?? POP ??
*copyc mmp$write_modified_pages
*copyc osv$job_pageable_heap
*copyc osv$page_size
?? OLDTITLE ??
?? NEWTITLE := 'Global Variables Declared by this Module', EJECT ??

  VAR
    jmv$job_recovery_information_p: [XDCL, #GATE, oss$job_pageable] ^jmt$job_recovery_information := NIL;

?? OLDTITLE ??
?? NEWTITLE := 'allocate_recovery_information', EJECT ??
{ PURPOSE:
{   The purpose of this request is to allocate job recovery information in the
{ job pageable segment.

  PROCEDURE allocate_recovery_information;

{ The type integral_pages is aligned on a large page size.  This will force any
{ the structure to begin on a page boundary when the page size is anywhere up
{ to 65,536 bytes.  If the page size is larger than this value, this type may
{ need to change.  When changing the alignment value to a larger value, keep in
{ mind the amount of data being saved in comparison to the page size.  If the
{ page size is 20 times greater than the amount of information being saved, it
{ is probably not useful to change this type.

    TYPE
      integral_pages = record
        bytes: ALIGNED [0 MOD 65536] array [1 .. * ] of cell,
      recend;

    VAR
      converter_p: ^cell,
      recovery_info_size_in_bytes: integer,
      recovery_information_p: ^integral_pages;

    IF jmv$job_recovery_information_p = NIL THEN
      recovery_info_size_in_bytes := osv$page_size;
      WHILE recovery_info_size_in_bytes < #SIZE (jmt$job_recovery_information) DO
        recovery_info_size_in_bytes := recovery_info_size_in_bytes + osv$page_size;
      WHILEND;

      ALLOCATE recovery_information_p: [1 .. recovery_info_size_in_bytes] IN osv$job_pageable_heap^;
      converter_p := recovery_information_p;
      jmv$job_recovery_information_p := converter_p;
    IFEND;
  PROCEND allocate_recovery_information;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$save_recovery_information', EJECT ??
*copy jmh$save_recovery_information

  PROCEDURE [XDCL, #GATE] jmp$save_recovery_information
    (    job_system_label_p: ^jmt$job_system_label);

    allocate_recovery_information;
    jmv$job_recovery_information_p^.job_system_label := job_system_label_p^;
  PROCEND jmp$save_recovery_information;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$write_recovery_info_to_disk', EJECT ??
*copy jmh$write_recovery_info_to_disk
{ DESIGN:
{   When the pages have been written to disk they are taken out of the job's
{ working set and placed in the available queue.

  PROCEDURE [XDCL, #GATE] jmp$write_recovery_info_to_disk;

    VAR
      ignore_status: ost$status;

    IF jmv$job_recovery_information_p <> NIL THEN
      mmp$write_modified_pages (jmv$job_recovery_information_p, #SIZE (jmt$job_recovery_information),
            osc$nowait, ignore_status);
    IFEND;
  PROCEND jmp$write_recovery_info_to_disk;
?? OLDTITLE ??
MODEND jmm$save_recovery_information;

*DECK DECK=JMM$SELECT_INTERACTIVE_JOB_DEST EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Job Management : Interactive Load Leveling' ??
MODULE jmm$select_interactive_job_dest;

{ PURPOSE:
{   This module contains a procedure that chooses a mainframe from a list
{   of mainframes in a cluster, that an interactive job will be submitted to
{   for execution.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$maximum_mainframes
*copyc jmt$interactive_job_info
*copyc jmt$scheduling_attr_results
*copyc jmt$scheduling_results_keys
*copyc jmt$mainframe_leveling_data
*copyc pmt$mainframe_id
?? POP ??
*copyc jmp$cluster_get_leveling_data
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$select_interactive_job_dest', EJECT ??
*copy jmh$select_interactive_job_dest

  PROCEDURE [XDCL] jmp$select_interactive_job_dest
    (    valid_mainframe_list: array [1 .. * ] of pmt$mainframe_id;
         interactive_job_info: jmt$interactive_job_info;
     VAR selected_mainframe: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      data: ^SEQ ( * ),
      ignore_status: ost$status,
      job_class_name_p: ^ost$name,
      leveling_data_size: ost$segment_length,
      mainframe_index: 1 .. jmc$maximum_mainframes,
      mainframe_leveling_data_p: ^jmt$mainframe_leveling_data,
      mainframes_processed: jmt$rpc_mainframes_processed,
      max_room_in_class: real,
      number_of_data_packets: ost$non_negative_integers,
      number_of_keys_p: ^ost$non_negative_integers,
      room_in_class: real,
      send_data_p: ^SEQ ( * ),
      send_data_size: ost$segment_length,
      scheduling_attr_results_p: ^jmt$scheduling_attr_results,
      scheduling_results_keys_p: ^jmt$scheduling_results_keys,
      segment: amt$segment_pointer,
      target_mainframe_id: pmt$mainframe_id,
      valid_mainframe_index: 1 .. jmc$maximum_mainframes;


    status.normal := TRUE;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential,
          segment, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET segment.sequence_pointer;

    send_data_size := #SIZE (ost$name) + #SIZE (ost$non_negative_integers) +
          (5 * #SIZE (jmt$scheduling_attribute_keys));
    PUSH send_data_p: [[REP send_data_size OF cell]];

    RESET send_data_p;
    NEXT job_class_name_p IN send_data_p;
    job_class_name_p^ := interactive_job_info.assigned_job_class;
    NEXT number_of_keys_p IN send_data_p;
    number_of_keys_p^ := 5;
    NEXT scheduling_results_keys_p: [1 .. 5] IN send_data_p;
    scheduling_results_keys_p^ [1] := jmc$sak_active_jobs;
    scheduling_results_keys_p^ [2] := jmc$sak_enable_job_leveling;
    scheduling_results_keys_p^ [3] := jmc$sak_maximum_active_jobs;
    scheduling_results_keys_p^ [4] := jmc$sak_queued_jobs;
    scheduling_results_keys_p^ [5] := jmc$sak_swapped_jobs;

    leveling_data_size := #SIZE (jmt$mainframe_leveling_data) +
          (UPPERBOUND (scheduling_results_keys_p^) *
          #SIZE (jmt$scheduling_attr_result));

{ Call all mainframes in the cluster.

    target_mainframe_id := pmc$null_mainframe_id;

    jmp$cluster_get_leveling_data (target_mainframe_id, send_data_p,
          leveling_data_size, segment.sequence_pointer, mainframes_processed,
          number_of_data_packets, status);
    IF status.normal THEN
      max_room_in_class := 0.0;
      selected_mainframe := pmc$null_mainframe_id;

      RESET segment.sequence_pointer;
      FOR mainframe_index := 1 TO number_of_data_packets DO
        NEXT mainframe_leveling_data_p IN segment.sequence_pointer;
        NEXT data: [[REP mainframe_leveling_data_p^.mainframe_data_size OF
              cell]] IN segment.sequence_pointer;
        RESET data;
        NEXT scheduling_attr_results_p: [1 .. 5] IN data;

      /find_mainframe_in_list/
        FOR valid_mainframe_index := 1 TO UPPERBOUND (valid_mainframe_list) DO
          IF valid_mainframe_list [valid_mainframe_index] =
                mainframe_leveling_data_p^.mainframe_id THEN
            IF scheduling_attr_results_p^ [2].enable_job_leveling THEN

              room_in_class := $REAL (scheduling_attr_results_p^ [3].
                    maximum_active_jobs - scheduling_attr_results_p^ [1].
                    active_jobs - scheduling_attr_results_p^ [4].queued_jobs -
                    scheduling_attr_results_p^ [5].swapped_jobs) /
                    $REAL (scheduling_attr_results_p^ [3].maximum_active_jobs);

              IF room_in_class > max_room_in_class THEN
                max_room_in_class := room_in_class;
                selected_mainframe := valid_mainframe_list
                      [valid_mainframe_index];
              IFEND;
            IFEND;
            EXIT /find_mainframe_in_list/;
          IFEND;
        FOREND /find_mainframe_in_list/;
      FOREND;
    IFEND;

    mmp$delete_scratch_segment (segment, ignore_status);

  PROCEND jmp$select_interactive_job_dest;
?? OLDTITLE ??

MODEND jmm$select_interactive_job_dest;
*DECK DECK=JMM$SETUP_FOR_LEVELING EXPAND=TRUE

PROCEDURE setup_for_leveling, setfl (
  mainframe, m: key
      (fruit, f)
      (grain, g)
    keyend = $required
  fruit_mainframe_id, fmi: name 17..17 = $optional
  grain_mainframe_id, gmi: name 17..17 = $optional
  initial_install, ii: boolean = TRUE
  number_of_task_queue_entries, notqe: integer 1..50 = 4
  status)

  IF mainframe = fruit THEN
    IF NOT $specified(grain_mainframe_id) THEN
      EXIT_PROC WITH $status(false, 'xx', 0, 'missing grain mainframe id')
    IFEND
    mf_grain = grain_mainframe_id
    mf_fruit = $name($mainframe(id))
  ELSE
    IF NOT $specified(fruit_mainframe_id) THEN
      EXIT_PROC WITH $status(false, 'xx', 0, 'missing fruit mainframe id')
    IFEND
    mf_grain = $name($mainframe(id))
    mf_fruit = fruit_mainframe_id
  IFEND

  IF mainframe = fruit THEN
    IF initial_install THEN
      create_family family_name=apple family_administrator=test password=testx
      create_family family_name=kiwi family_administrator=test password=testx
      create_family family_name=pear family_administrator=test password=testx
    IFEND

    MANAGE_FILE_SERVER
      doit client grain_mainframe_id activate=false fn=none notqe=number_of_task_queue_entries
      doit server grain_mainframe_id activate=false notqe=number_of_task_queue_entries
      IF initial_install THEN
        change_client_access grain_mainframe_id family=apple family_access=leveled_access
        change_client_access grain_mainframe_id family=kiwi family_access=login
      IFEND
    QUIT

  ELSE
    IF initial_install THEN
      create_family family_name=wheat family_administrator=test password=testx
      create_family family_name=oats family_administrator=test password=testx
      create_family family_name=barley family_administrator=test password=testx
    IFEND

    MANAGE_FILE_SERVER
      doit client fruit_mainframe_id activate=false fn=none notqe=number_of_task_queue_entries
      doit server fruit_mainframe_id activate=false notqe=number_of_task_queue_entries
      IF initial_install THEN
        change_client_access fruit_mainframe_id family=wheat family_access=leveled_access
        change_client_access fruit_mainframe_id family=oats family_access=login
      IFEND
    QUIT

    IF initial_install THEN
      ADMINISTER_VALIDATIONS
        CREATE_USER user=test
          change_login_password new_password=testx
          change_capability add=all
        QUIT
      QUIT

      ADMINISTER_SCHEDULING
        create_default_profile
        create_job_category fruit jq=fruit
        create_job_category grain jq=grain
        create_job_category other jq=other
        ADMINISTER_CONTROLS
          change_attributes abbreviation=grain enable_job_leveling=true job_leveling_interval=20 ..
                validation_excluded_categories=fruit initiation_excluded_categories=fruit
          create_controls fruit_mainframe_id
          change_attributes abbreviation=fruit enable_job_leveling=true job_leveling_interval=20 ..
                validation_excluded_categories=grain initiation_excluded_categories=grain
          create_controls $system_0830_0000
          change_attributes abbreviation=other validation_required_categories=other ..
                initiation_required_categories=other
          add_job_category_entry (grain fruit) validation_excluded_categories=other ..
                initiation_excluded_categories=other
        QUIT
        write_profile :oats.$system.system_profile
      QUIT yes

COLLECT_TEXT :oats.$system.trace_job sm='?'
  PROCEDURE trace_job (
    sjn: name = $required
    status)

    mf?mf_grain? = grain
    mf?mf_fruit? = fruit
    mfnone = no_mainframe

    mf_queued = $job_status(sjn server_mainframe_identifier)
    put_line ' Job initially queued on: '//$vname('mf'//mf_queued)
    REPEAT
      wait 1000
      IF $job_status(sjn client_mainframe_identifier) <> mf_queued THEN
        mf_queued = $job_status(sjn client_mainframe_identifier)
        put_line '  assigned to '//$vname('mf'//mf_queued)
      IFEND
    UNTIL $job_status(sjn state) = initiated
    mf_initiated = $job_status(sjn client_mainframe_identifier)
    put_line '  initiated on '//$vname('mf'//mf_initiated)

  PROCEND trace_job
**
      crefp :oats.$system.trace_job public am=(read execute) sm=none

    IFEND
  IFEND

PROCEND setup_for_leveling

*DECK DECK=JMM$SET_JOB_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Job Management Job Attribute Interfaces' ??
MODULE jmm$set_job_attributes;

{ PURPOSE:
{   This module contains the interfaces that physically set a job's attributes, both as a result of job
{   initiation and as a result of a user changing a job's attributes directly or through the initiation
{   of an application for which special scheduling is done.
{
{ DESIGN:
{   These procedures operate in ring 2 with a call bracket of 3.  When a job's attributes are changed
{ the ring 2 interface jmp$set_job_attributes is called.  This procedure will directly change the Job
{ Pageable job attribute structure and will call a ring one interface to change the other job attributes.
{
{   When a job initiates its job attributes are initialized by the procedure jmp$initialize_job_attributes.
{ This procedure will take the values from the job's system label built by jmp$submit_job.  If the job is
{ the system job that "becomes" at deadstart the values used are a pre-defined set.
{
{   The ring 2 interface jmp$set_application_scheduling is called when an application starts that has
{ special scheduling requirements.  This call overrides the job attributes that need to be changed while
{ the application is executing.  The job attributes are restored when the application completes by
{ calling jmp$end_application_scheduling.  When an attribute is overridden by application scheduling
{ the jmp$set_job_attributes call will only change the pageable copy of the attribute and not call the
{ ring one interface.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$class_names
*copyc jmc$system_family
*copyc jme$queued_file_conditions
*copyc jmk$keypoints
*copyc jmt$application_attributes
*copyc jmt$job_attribute_changes
*copyc jmt$job_attributes
*copyc jmt$job_execution_attributes
*copyc jmt$job_system_label
*copyc jmt$rb_scheduler_requests
*copyc osc$deadstart
*copyc osc$xterm_application_name
*copyc oss$job_pageable
*copyc ost$status
?? POP ??

*copyc jmp$get_ijle_p
*copyc osp$clear_job_signature_lock
*copyc osp$initialize_sig_lock
*copyc osp$set_job_signature_lock
*copyc qfp$discard_job_output
*copyc qfp$set_job_attributes
*copyc jmv$default_job_attributes
*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc jmv$job_class_table_p
*copyc jmv$kjl_p
*copyc jmv$kjlx_p
*copyc jmv$service_classes
*copyc jmv$xterm_job

?? TITLE := 'Global Variables Declared by this Module', EJECT ??

{ The job attribute structure is statically initialized only to present a reasonable set of
{ attributes for an output file if a job should abort early during job begin.  This is not
{ expected to happen often, but is necessary to indicate the file'e existance.

?? FMT (FORMAT := OFF) ??
  VAR
    jmv$job_attributes: [XDCL, #GATE, oss$job_pageable] jmt$job_attributes := [
         { comment_banner } 'SYSTEM_ERROR - See Site Info',
         { copy_count } 1,
         { device } 'AUTOMATIC',
         { earliest_run_time } [FALSE],
         { earliest_print_time } [FALSE],
         { external_characteristics } 'NORMAL',
         { forms_code } 'NORMAL',
         { implicit_routing_text} [0, ''],
         { job_controller } [jmc$system_user, jmc$system_family],
         { job_initiation_time } [0, 1, 1, 0, 0, 0, 0],
         { job_input_device } [0, ''],
         { job_qualifier_list } [REP jmc$maximum_job_qualifiers OF osc$null_name],
         { job_size } 0,
         { job_submission_time } *,
         { latest_run_time } [FALSE],
         { latest_print_time } [FALSE],
         { login_command_supplied } TRUE,
         { originating_application_name } 'OSA$JOB_BEGIN',
         { originating_ssn } jmc$full_system_supplied_name,
         { output_class } 'NORMAL',
         { output_deferred_by_user } FALSE,
         { output_destination } '',
         { output_destination_family } jmc$system_family,
         { output_destination_usage } 'SYSTEM_ERROR',
         { output_disposition_key } jmc$normal_output_disposition,
         { output_disposition_path } '',
         { output_priority } 'LOW',
         { processor_user_prolog_and_epilog } TRUE,
         { purge_delay } [FALSE],
         { remote_host_directive } [0, ''],
         { routing_banner } 'SYSTEM_ERROR - See Site Info',
         { source_logical_id } '',
         { site_information } 'The job has aborted as part of initiation.  The job attributes have not ' CAT
                              'been initialized.  The Job Log in the standard output file contains the ' CAT
                              'status of the initiation failure.  To print this file change the OUTPUT_' CAT
                              'DESTINATION_USAGE.',
         { station } 'AUTOMATIC',
         { station_operator } jmc$system_user,
         { system_job_parameters } [0, ''],
         { system_routing_text } [0, ''],
         { user_information } 'A system error occured during job initiation.  See Site_Information ' CAT
                              'for additional information.',
         { vertical_print_density } jmc$vertical_print_density_none,
         { vfu_load_procedure } osc$null_name];
?? FMT (FORMAT := ON) ??

  VAR
    jmv$job_disposition_code: [XDCL, #GATE, oss$job_pageable] jmt$disposition_code,
    jmv$job_execution_attributes: [XDCL, #GATE, oss$job_pageable] jmt$job_execution_attributes;

?? TITLE := 'jmp$end_application_scheduling', EJECT ??
*copyc jmh$end_application_scheduling

  PROCEDURE [XDCL, #GATE] jmp$end_application_scheduling
    (VAR status: ost$status);

    VAR
      old_service_accumulator: jmt$service_accumulator,
      attribute: jmt$job_attribute_change;

    status.normal := TRUE;
    osp$set_job_signature_lock (jmv$job_execution_attributes.lock);

    IF jmv$job_execution_attributes.maximum_ws_overridden THEN
      attribute.key := jmc$maximum_working_set;
      attribute.maximum_working_set := jmv$job_execution_attributes.maximum_working_set;
      qfp$set_job_attributes (attribute, status);
      jmv$job_execution_attributes.maximum_ws_overridden := FALSE;
    IFEND;

    IF jmv$job_execution_attributes.minimum_ws_overridden THEN
      attribute.key := jmc$minimum_working_set;
      attribute.minimum_working_set := jmv$job_execution_attributes.minimum_working_set;
      qfp$set_job_attributes (attribute, status);
      jmv$job_execution_attributes.minimum_ws_overridden := FALSE;
    IFEND;

    IF jmv$job_execution_attributes.page_ai_overridden THEN
      attribute.key := jmc$page_aging_interval;
      attribute.page_aging_interval := jmv$job_execution_attributes.page_aging_interval;
      qfp$set_job_attributes (attribute, status);
      jmv$job_execution_attributes.page_ai_overridden := FALSE;
    IFEND;

    IF jmv$job_execution_attributes.cyclic_ai_overridden THEN
      attribute.key := jmc$cyclic_aging_interval;
      attribute.cyclic_aging_interval := jmv$job_execution_attributes.cyclic_aging_interval;
      qfp$set_job_attributes (attribute, status);
      jmv$job_execution_attributes.cyclic_ai_overridden := FALSE;
    IFEND;

    IF jmv$job_execution_attributes.service_class_overridden THEN
      set_service_class (jmc$unspecified_service_class, 0, old_service_accumulator);
    IFEND;

    osp$clear_job_signature_lock (jmv$job_execution_attributes.lock);

  PROCEND jmp$end_application_scheduling;
?? TITLE := 'jmp$initialize_job_attributes', EJECT ??
*copyc jmh$initialize_job_attributes

  PROCEDURE [XDCL, #GATE] jmp$initialize_job_attributes
    (    system_label_p: ^jmt$job_system_label;
     VAR status: ost$status);

    status.normal := TRUE;

{ A NIL system_label_p implies the system job

    IF system_label_p = NIL THEN
      jmv$job_attributes.comment_banner := osc$null_name;
      jmv$job_attributes.copy_count := 1;
      jmv$job_attributes.device := jmv$default_job_attributes [jmc$batch].device;
      jmv$job_attributes.earliest_run_time.specified := FALSE;
      jmv$job_attributes.earliest_print_time.specified := FALSE;
      jmv$job_attributes.external_characteristics := jmv$default_job_attributes [jmc$batch].
            external_characteristics;
      jmv$job_attributes.forms_code := jmv$default_job_attributes [jmc$batch].forms_code;
      jmv$job_attributes.implicit_routing_text.size := 0;
      jmv$job_attributes.implicit_routing_text.text := '';
      jmv$job_attributes.job_controller := jmv$jcb.user_id;
      jmv$job_attributes.job_initiation_time := jmv$kjlx_p^ [jmv$jcb.job_id].job_initiation_time;
      jmv$job_attributes.job_input_device.size := 0;
      jmv$job_attributes.job_input_device.text := '';
      jmv$job_attributes.job_qualifier_list := jmv$default_job_attributes [jmc$batch].job_qualifier_list;
      jmv$job_attributes.job_submission_time := jmv$kjlx_p^ [jmv$jcb.job_id].job_initiation_time;
      jmv$job_attributes.job_size := 0;
      jmv$job_attributes.latest_run_time.specified := FALSE;
      jmv$job_attributes.latest_print_time.specified := FALSE;
      jmv$job_attributes.login_command_supplied := FALSE;
      jmv$job_attributes.originating_application_name := osc$deadstart;
      jmv$job_attributes.originating_ssn := jmv$jcb.system_name;
      jmv$job_attributes.output_class := jmv$default_job_attributes [jmc$batch].output_class;
      jmv$job_attributes.output_deferred_by_user := FALSE;
      jmv$job_attributes.output_destination := jmv$jcb.user_id.family;
      jmv$job_attributes.output_destination_family := jmv$jcb.user_id.family;
      jmv$job_attributes.output_destination_usage := jmv$default_job_attributes [jmc$batch].
            output_destination_usage;
      jmv$job_attributes.output_disposition_key := jmc$normal_output_disposition;
      jmv$job_attributes.output_disposition_path := '';
      jmv$job_attributes.output_priority := jmv$default_job_attributes [jmc$batch].output_priority;
      jmv$job_attributes.process_user_prolog_and_epilog := TRUE;
      jmv$job_attributes.purge_delay.specified := FALSE;
      jmv$job_attributes.remote_host_directive.size := 0;
      jmv$job_attributes.remote_host_directive.parameters := '';
      jmv$job_attributes.routing_banner := osc$null_name;
      jmv$job_attributes.site_information := jmv$default_job_attributes [jmc$batch].site_information;
      jmv$job_attributes.source_logical_id := '';
      jmv$job_attributes.station := jmv$default_job_attributes [jmc$batch].station;
      jmv$job_attributes.station_operator := jmv$jcb.user_id.user;
      jmv$job_attributes.system_job_parameters.system_job_parameter := '';
      jmv$job_attributes.system_job_parameters.system_job_parameter_count := 0;
      jmv$job_attributes.system_routing_text.size := 0;
      jmv$job_attributes.system_routing_text.parameters := '';
      jmv$job_attributes.user_information := '';
      jmv$job_attributes.vertical_print_density := jmv$default_job_attributes [jmc$batch].
            vertical_print_density;
      jmv$job_attributes.vfu_load_procedure := jmv$default_job_attributes [jmc$batch].vfu_load_procedure;
      jmv$job_disposition_code := '  ';
    ELSE
      jmv$job_attributes := system_label_p^.job_attributes;
      jmv$job_disposition_code := system_label_p^.disposition_code;
      jmv$xterm_job := (osc$xterm_application_name = jmv$job_attributes.originating_application_name);
    IFEND;
    jmv$job_execution_attributes.maximum_working_set := jmv$jcb.max_working_set_size;
    jmv$job_execution_attributes.maximum_ws_overridden := FALSE;
    jmv$job_execution_attributes.minimum_working_set := jmv$jcb.min_working_set_size;
    jmv$job_execution_attributes.minimum_ws_overridden := FALSE;
    jmv$job_execution_attributes.page_aging_interval := jmv$jcb.page_aging_interval;
    jmv$job_execution_attributes.page_ai_overridden := FALSE;
    jmv$job_execution_attributes.cyclic_aging_interval := jmv$jcb.cyclic_aging_interval;
    jmv$job_execution_attributes.cyclic_ai_overridden := FALSE;
    jmv$job_execution_attributes.service_class_overridden := FALSE;
    osp$initialize_sig_lock (jmv$job_execution_attributes.lock);
  PROCEND jmp$initialize_job_attributes;
?? TITLE := 'jmp$set_application_scheduling', EJECT ??
*copyc jmh$set_application_scheduling

  PROCEDURE [XDCL, #GATE] jmp$set_application_scheduling
    (    application_attributes: jmt$application_attributes;
         new_service_accumulator: jmt$service_accumulator;
     VAR old_service_accumulator: jmt$service_accumulator;
     VAR status: ost$status);

    VAR
      attribute: jmt$job_attribute_change;

    status.normal := TRUE;
    osp$set_job_signature_lock (jmv$job_execution_attributes.lock);

    attribute.key := jmc$maximum_working_set;
    IF application_attributes.maximum_working_set <> jmc$unspecified_work_set_size THEN
      attribute.maximum_working_set := application_attributes.maximum_working_set;
      jmv$job_execution_attributes.maximum_ws_overridden := TRUE;
      qfp$set_job_attributes (attribute, status);
    ELSEIF jmv$job_execution_attributes.maximum_ws_overridden THEN
      attribute.maximum_working_set := jmv$job_execution_attributes.maximum_working_set;
      jmv$job_execution_attributes.maximum_ws_overridden := FALSE;
      qfp$set_job_attributes (attribute, status);
    IFEND;

    attribute.key := jmc$minimum_working_set;
    IF application_attributes.minimum_working_set <> jmc$unspecified_work_set_size THEN
      attribute.minimum_working_set := application_attributes.minimum_working_set;
      jmv$job_execution_attributes.minimum_ws_overridden := TRUE;
      qfp$set_job_attributes (attribute, status);
    ELSEIF jmv$job_execution_attributes.minimum_ws_overridden THEN
      attribute.minimum_working_set := jmv$job_execution_attributes.minimum_working_set;
      jmv$job_execution_attributes.minimum_ws_overridden := FALSE;
      qfp$set_job_attributes (attribute, status);
    IFEND;

    attribute.key := jmc$page_aging_interval;
    IF application_attributes.page_aging_interval <> jmc$unspecified_aging_interval THEN
      attribute.page_aging_interval := application_attributes.page_aging_interval;
      jmv$job_execution_attributes.page_ai_overridden := TRUE;
      qfp$set_job_attributes (attribute, status);
    ELSEIF jmv$job_execution_attributes.page_ai_overridden THEN
      attribute.page_aging_interval := jmv$job_execution_attributes.page_aging_interval;
      jmv$job_execution_attributes.page_ai_overridden := FALSE;
      qfp$set_job_attributes (attribute, status);
    IFEND;

    attribute.key := jmc$cyclic_aging_interval;
    IF application_attributes.cyclic_aging_interval <> jmc$unspecified_aging_interval THEN
      attribute.cyclic_aging_interval := application_attributes.cyclic_aging_interval;
      jmv$job_execution_attributes.cyclic_ai_overridden := TRUE;
      qfp$set_job_attributes (attribute, status);
    ELSEIF jmv$job_execution_attributes.cyclic_ai_overridden THEN
      attribute.cyclic_aging_interval := jmv$job_execution_attributes.cyclic_aging_interval;
      jmv$job_execution_attributes.cyclic_ai_overridden := FALSE;
      qfp$set_job_attributes (attribute, status);
    IFEND;

    attribute.key := jmc$service_class;
    IF application_attributes.service_class_index <> jmc$unspecified_service_class THEN
      set_service_class (application_attributes.service_class_index, new_service_accumulator,
            old_service_accumulator);
    ELSEIF jmv$job_execution_attributes.service_class_overridden THEN
      set_service_class (jmc$unspecified_service_class, new_service_accumulator, old_service_accumulator);
    ELSE
      old_service_accumulator := 0;
    IFEND;

    osp$clear_job_signature_lock (jmv$job_execution_attributes.lock);

  PROCEND jmp$set_application_scheduling;
?? TITLE := 'jmp$set_job_attributes', EJECT ??
*copyc jmh$set_job_attributes

  PROCEDURE [XDCL, #GATE] jmp$set_job_attributes
    (    job_attribute_changes: ^jmt$job_attribute_changes;
     VAR status: ost$status);

    VAR
      attribute_index: integer;

    #KEYPOINT (osk$entry, 0, jmk$set_job_attributes);
    status.normal := TRUE;

    FOR attribute_index := LOWERBOUND (job_attribute_changes^) TO UPPERBOUND (job_attribute_changes^) DO
      CASE job_attribute_changes^ [attribute_index].key OF
      = jmc$comment_banner =
        jmv$job_attributes.comment_banner := job_attribute_changes^ [attribute_index].comment_banner;

      = jmc$copies =
        jmv$job_attributes.copy_count := job_attribute_changes^ [attribute_index].copies;

      = jmc$cyclic_aging_interval =
        osp$set_job_signature_lock (jmv$job_execution_attributes.lock);
        jmv$job_execution_attributes.cyclic_aging_interval :=
              job_attribute_changes^ [attribute_index].cyclic_aging_interval;
        IF NOT jmv$job_execution_attributes.cyclic_ai_overridden THEN
          qfp$set_job_attributes (job_attribute_changes^ [attribute_index], status);
        IFEND;
        osp$clear_job_signature_lock (jmv$job_execution_attributes.lock);

      = jmc$detached_job_wait_time =
        qfp$set_job_attributes (job_attribute_changes^ [attribute_index], status);

      = jmc$device =
        jmv$job_attributes.device := job_attribute_changes^ [attribute_index].device;

      = jmc$dispatching_priority =
        qfp$set_job_attributes (job_attribute_changes^ [attribute_index], status);

      = jmc$earliest_print_time =
        jmv$job_attributes.earliest_print_time := job_attribute_changes^ [attribute_index].
              earliest_print_time;

      = jmc$external_characteristics =
        jmv$job_attributes.external_characteristics := job_attribute_changes^ [attribute_index].
              external_characteristics;

      = jmc$forms_code =
        jmv$job_attributes.forms_code := job_attribute_changes^ [attribute_index].forms_code;

      = jmc$job_abort_disposition =
        qfp$set_job_attributes (job_attribute_changes^ [attribute_index], status);

      = jmc$job_recovery_disposition =
        qfp$set_job_attributes (job_attribute_changes^ [attribute_index], status);

      = jmc$latest_print_time =
        jmv$job_attributes.latest_print_time := job_attribute_changes^ [attribute_index].latest_print_time;

      = jmc$maximum_working_set =
        osp$set_job_signature_lock (jmv$job_execution_attributes.lock);
        jmv$job_execution_attributes.maximum_working_set :=
              job_attribute_changes^ [attribute_index].maximum_working_set;
        IF NOT jmv$job_execution_attributes.maximum_ws_overridden THEN
          qfp$set_job_attributes (job_attribute_changes^ [attribute_index], status);
        IFEND;
        osp$clear_job_signature_lock (jmv$job_execution_attributes.lock);

      = jmc$minimum_working_set =
        osp$set_job_signature_lock (jmv$job_execution_attributes.lock);
        jmv$job_execution_attributes.minimum_working_set :=
              job_attribute_changes^ [attribute_index].minimum_working_set;
        IF NOT jmv$job_execution_attributes.minimum_ws_overridden THEN
          qfp$set_job_attributes (job_attribute_changes^ [attribute_index], status);
        IFEND;
        osp$clear_job_signature_lock (jmv$job_execution_attributes.lock);

      = jmc$null_attribute =
        ;

      = jmc$output_class =
        jmv$job_attributes.output_class := job_attribute_changes^ [attribute_index].output_class;

      = jmc$output_deferred_by_user =
        jmv$job_attributes.output_deferred_by_user := job_attribute_changes^ [attribute_index].
              output_deferred_by_user;

      = jmc$output_destination =
        jmv$job_attributes.output_destination := job_attribute_changes^ [attribute_index].output_destination;

      = jmc$output_destination_family =
        jmv$job_attributes.output_destination_family := job_attribute_changes^ [attribute_index].
              output_destination_family;

      = jmc$output_destination_usage =
        jmv$job_attributes.output_destination_usage := job_attribute_changes^ [attribute_index].
              output_destination_usage;

      = jmc$output_disposition =
        jmv$job_attributes.output_disposition_key := job_attribute_changes^ [attribute_index].
              output_disposition.key;
        IF jmv$job_attributes.output_disposition_key = jmc$standard_output_path THEN
          jmv$job_attributes.output_disposition_path := job_attribute_changes^ [attribute_index].
                output_disposition.standard_output_path^;
        ELSE
          jmv$job_attributes.output_disposition_path := '';
        IFEND;
        qfp$discard_job_output (jmv$job_attributes.output_disposition_key);

      = jmc$output_priority =
        jmv$job_attributes.output_priority := job_attribute_changes^ [attribute_index].output_priority;

      = jmc$page_aging_interval =
        osp$set_job_signature_lock (jmv$job_execution_attributes.lock);
        jmv$job_execution_attributes.page_aging_interval :=
              job_attribute_changes^ [attribute_index].page_aging_interval;
        IF NOT jmv$job_execution_attributes.page_ai_overridden THEN
          qfp$set_job_attributes (job_attribute_changes^ [attribute_index], status);
        IFEND;
        osp$clear_job_signature_lock (jmv$job_execution_attributes.lock);

      = jmc$purge_delay =
        jmv$job_attributes.purge_delay := job_attribute_changes^ [attribute_index].purge_delay^;

      = jmc$remote_host_directive =
        jmv$job_attributes.remote_host_directive := job_attribute_changes^ [attribute_index].
              remote_host_directive^;

      = jmc$routing_banner =
        jmv$job_attributes.routing_banner := job_attribute_changes^ [attribute_index].routing_banner;

      = jmc$site_information =
        jmv$job_attributes.site_information := job_attribute_changes^ [attribute_index].site_information^;

      = jmc$station =
        jmv$job_attributes.station := job_attribute_changes^ [attribute_index].station;

      = jmc$station_operator =
        jmv$job_attributes.station_operator := job_attribute_changes^ [attribute_index].station_operator;

      = jmc$user_information =
        jmv$job_attributes.user_information := job_attribute_changes^ [attribute_index].user_information^;

      = jmc$vertical_print_density =
        jmv$job_attributes.vertical_print_density := job_attribute_changes^ [attribute_index].
              vertical_print_density;

      = jmc$vfu_load_procedure =
        jmv$job_attributes.vfu_load_procedure := job_attribute_changes^ [attribute_index].vfu_load_procedure;

      ELSE
        ;
      CASEND;
    FOREND;
    #KEYPOINT (osk$exit, 0, jmk$set_job_attributes);
  PROCEND jmp$set_job_attributes;
?? TITLE := 'jmp$set_job_input_device', EJECT ??

{ PURPOSE:
{   This procedure changes the value of the job_input_device job attribute.

  PROCEDURE [XDCL, #GATE] jmp$set_job_input_device
    (    job_input_device: jmt$job_input_device);

    jmv$job_attributes.job_input_device := job_input_device;
  PROCEND jmp$set_job_input_device;
?? TITLE := 'set_service_class', EJECT ??

{  Purpose
{    Sets or resets the service class of the job based on changes introduced
{    by application scheduling.
{
{  Design
{    If the provided service class is specified and valid then the service
{    class of the job is changed to the provided service class.  The old
{    service class index and accumulator is saved if this is the initial
{    change.  If the specified service class is unspecified or invalid and
{    the service class had been overridden by a previous call then the
{    service class and accumulator are reset to the original values.  If
{    the service class no longer exists then the initial service class in
{    the job class table is used.

  PROCEDURE set_service_class
    (    service_class_index: jmt$service_class_index;
         new_service_accumulator: jmt$service_accumulator;
     VAR old_service_accumulator: jmt$service_accumulator);

    VAR
      keep_old_service_data: boolean,
      rb: jmt$rb_scheduler_requests,
      ijle_p: ^jmt$initiated_job_list_entry;

    IF (service_class_index <> jmc$unspecified_service_class) AND
          (jmv$service_classes [service_class_index] <> NIL) AND
          jmv$service_classes [service_class_index]^.attributes.defined THEN
      rb.new_service_class := service_class_index;
      rb.new_service_accumulator := new_service_accumulator;
      keep_old_service_data := NOT jmv$job_execution_attributes.service_class_overridden;
      jmv$job_execution_attributes.service_class_overridden := TRUE;

    ELSEIF jmv$job_execution_attributes.service_class_overridden THEN
      rb.new_service_class := jmv$job_execution_attributes.service_class_index;
      rb.new_service_accumulator := jmv$job_execution_attributes.service_accumulator;
      jmv$job_execution_attributes.service_class_overridden := FALSE;
      keep_old_service_data := FALSE;

      IF (jmv$service_classes [rb.new_service_class] = NIL) OR NOT jmv$service_classes
            [rb.new_service_class]^.attributes.defined THEN
        rb.new_service_class := jmv$job_class_table_p^ [jmv$kjl_p^ [jmv$jcb.job_id].job_class].
              initial_service_class_index;
      IFEND;

    ELSE
      RETURN;
    IFEND;

    rb.reqcode := syc$rc_job_scheduler_request;
    rb.sub_reqcode := jmc$src_class_switch;
    rb.system_supplied_name := jmv$jcb.system_name;
    rb.old_service_class := jmc$null_service_class;
    rb.old_service_accumulator := 0;

    i#call_monitor (#LOC (rb), #SIZE (rb));

    old_service_accumulator := rb.old_service_accumulator;
    IF keep_old_service_data THEN
      jmv$job_execution_attributes.service_class_index := rb.old_service_class;
      jmv$job_execution_attributes.service_accumulator := rb.old_service_accumulator;
    IFEND;
  PROCEND set_service_class;

MODEND jmm$set_job_attributes;
*DECK DECK=JMM$SWITCH_REMOTE_CONNECTION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Interactive Load Leveling' ??
MODULE jmm$switch_remote_connection;

{ PURPOSE:
{   This module contains the procedures to initiate the switching of a
{   connection to a destination job on another mainframe.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc clt$parameter_list
*copyc jmt$leveled_job_connect_data
*copyc jmt$paired_connection_data
*copyc osc$timesharing
*copyc osc$timesharing_terminal_file
*copyc oss$job_paged_literal
*copyc ost$free_running_clock
?? POP ??
*copyc amp$return
*copyc fsp$close_file
*copyc fsp$open_file
*copyc iip$vtp_create_paired_connect
*copyc iip$vtp_delete_paired_connect
*copyc jmp$generate_timesharing_title
*copyc nap$acquire_specific_connection
*copyc nap$attach_specific_server_appl
*copyc nap$detach_specific_server_appl
*copyc nap$get_attributes
*copyc nlp$register_nominal_connection
*copyc osp$generate_log_message
*copyc pmp$convert_mainframe_to_binary
*copyc pmp$get_unique_name
*copyc pmp$log_ascii
*copyc pmp$long_term_wait
*copyc rmp$request_terminal
?? OLDTITLE ??
?? NEWTITLE := 'log_unexpected_message', EJECT ??

  PROCEDURE log_unexpected_message
    (    message: string ( * ));

    VAR
      local_status: ost$status;

    pmp$log_ascii (message, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
          local_status);
  PROCEND log_unexpected_message;
?? OLDTITLE ??
?? NEWTITLE := 'log_unexpected_status', EJECT ??

  PROCEDURE log_unexpected_status
    (    error_status: ost$status);

    VAR
      local_status: ost$status;

    osp$generate_log_message ($pmt$ascii_logset [pmc$system_log, pmc$job_log], error_status, local_status);
  PROCEND log_unexpected_status;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$switch_remote_connection', EJECT ??

{ PURPOSE:
{   The purpose of this request is to initiate the switching of a connection from
{   one mainframe to another.  A request to create a paired connection is made
{   and the response to this request is handled.

  PROCEDURE [XDCL, #GATE] jmp$switch_remote_connection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? NEWTITLE := 'create_paired_connection', EJECT ??

    PROCEDURE create_paired_connection
      (    file_id: amt$file_identifier;
           system_job_name: jmt$system_supplied_name;
           network_file_name: ost$name;
           destination_mainframe_id: pmt$mainframe_id;
           encrypted_password: ost$name;
       VAR status: ost$status);

      CONST
        paired_connect_timeout_interval = 120000; { in milliseconds

      VAR
        binary_mainframe_id: pmt$binary_mainframe_id,
        current_clock: ost$free_running_clock,
        ignore_status: ost$status,
        paired_connection_data: jmt$paired_connection_data,
        paired_connection_data_p: ^jmt$paired_connection_data,
        termination_data_p: ^SEQ ( * ),
        termination_attributes_p: ^nat$get_attributes,
        time_left: integer,
        timesharing_title: ost$name;


      status.normal := TRUE;

      pmp$convert_mainframe_to_binary (destination_mainframe_id, binary_mainframe_id, ignore_status);
      jmp$generate_timesharing_title (binary_mainframe_id, timesharing_title);

      paired_connection_data.connection_request := jmc$pcr_leveled_job_request;
      paired_connection_data.leveled_job_request.system_job_name := system_job_name;
      paired_connection_data.leveled_job_request.encrypted_password := encrypted_password;

      iip$vtp_create_paired_connect (file_id, timesharing_title, #SEQ (paired_connection_data),
            paired_connect_timeout_interval, status);
      IF NOT status.normal THEN
        log_unexpected_message ('Create paired connection failed with...');
        log_unexpected_status (status);
        paired_connection_data.connection_request := jmc$pcr_leveled_job_results;
        paired_connection_data.leveled_job_results.successful := FALSE;
        iip$vtp_delete_paired_connect (file_id, #SEQ (paired_connection_data), status);
        IF NOT status.normal THEN
          log_unexpected_message ('Delete paired connection failed with...');
          log_unexpected_status (status);
        IFEND;
      ELSE

        PUSH termination_attributes_p: [1 .. 1];
        termination_attributes_p^ [1].kind := nac$connection_state;
        termination_attributes_p^ [1].connection_state := nac$established;
        current_clock := #FREE_RUNNING_CLOCK (0);
        time_left := paired_connect_timeout_interval;
        WHILE (time_left > 0) AND (termination_attributes_p^ [1].connection_state <> nac$terminated) DO
          pmp$long_term_wait (time_left DIV 12, time_left DIV 12);
          nap$get_attributes (network_file_name, termination_attributes_p^, ignore_status);
          time_left := paired_connect_timeout_interval - ((#FREE_RUNNING_CLOCK (0) - current_clock) DIV 1000);
        WHILEND;

        IF (termination_attributes_p^ [1].connection_state = nac$terminated) THEN

{ Need to look at the peer termination data to verify that the job was disconnected due
{ to the leveled job accepting the switched connection successfully.

          PUSH termination_data_p: [[REP 256 OF cell]];
          PUSH termination_attributes_p: [1 .. 1];
          termination_attributes_p^ [1].kind := nac$peer_termination_data;
          termination_attributes_p^ [1].peer_termination_data := termination_data_p;
          nap$get_attributes (network_file_name, termination_attributes_p^, status);
          IF NOT status.normal THEN
            log_unexpected_message ('Unable to get peer termination data for a paired connection.');
            log_unexpected_status (status);
          ELSE
            RESET termination_data_p;
            NEXT paired_connection_data_p IN termination_data_p;
            IF (paired_connection_data_p = NIL) OR (termination_attributes_p^ [1].
                  peer_termination_data_length < #SIZE (paired_connection_data_p^)) OR
                  (paired_connection_data_p^.connection_request <> jmc$pcr_leveled_job_results) OR
                  (NOT paired_connection_data_p^.leveled_job_results.successful) THEN

              log_unexpected_message (
                    'Job disconnected while waiting for partner mainframe to delete the connection.');
            IFEND;
          IFEND;
        ELSE

{ Backout - The job should have been disconnected.  The target job must not have picked up the connection.
{   Delete the paired connection and return.

          log_unexpected_message ('The target job failed to delete the paired connection.');
          paired_connection_data.connection_request := jmc$pcr_leveled_job_results;
          paired_connection_data.leveled_job_results.successful := FALSE;
          iip$vtp_delete_paired_connect (file_id, #SEQ (paired_connection_data), status);
          IF NOT status.normal THEN
            log_unexpected_message ('Delete paired connection failed with...');
            log_unexpected_status (status);
          IFEND;
        IFEND;
      IFEND;

    PROCEND create_paired_connection;
?? OLDTITLE ??
?? EJECT ??

    CONST
      acquire_timeout = 60,
      max_connections = 1;

    VAR
      access_creation_selections: ^fst$file_cycle_attributes,
      access_selections: ^fst$attachment_options,
      create_attributes: ^nat$create_attributes,
      destination_mainframe_id: pmt$mainframe_id,
      encrypted_password: ost$name,
      file_id: amt$file_identifier,
      ignore_status: ost$status,
      leveled_job_connect_data_p: ^jmt$leveled_job_connect_data,
      network_file_name: ost$name,
      null_conn_attribute: ^ift$connection_attributes,
      parameter_list_p: ^clt$parameter_list,
      system_job_name_p: ^jmt$system_supplied_name,
      terminal_file_name: ost$name;


    status.normal := TRUE;

    parameter_list_p := ^parameter_list;
    RESET parameter_list_p;
    NEXT leveled_job_connect_data_p IN parameter_list_p;

    nap$attach_specific_server_appl (leveled_job_connect_data_p^.system_job_name, osc$timesharing,
          {max_connections} 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH create_attributes: [1 .. 2];
    create_attributes^ [1].kind := nac$data_transfer_timeout;
    create_attributes^ [1].data_transfer_timeout := nac$max_wait_time;
    create_attributes^ [2].kind := nac$receive_wait_swapout;
    create_attributes^ [2].receive_wait_swapout := TRUE;

    pmp$get_unique_name (network_file_name, ignore_status);
    nap$acquire_specific_connection (leveled_job_connect_data_p^.system_job_name, osc$timesharing,
          network_file_name, create_attributes, acquire_timeout, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$detach_specific_server_appl (leveled_job_connect_data_p^.system_job_name, osc$timesharing, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH null_conn_attribute: [1 .. 1];
    null_conn_attribute^ [1].key := ifc$null_connection_attribute;

    pmp$get_unique_name (terminal_file_name, ignore_status);
    rmp$request_terminal (terminal_file_name, ^network_file_name, null_conn_attribute^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH access_selections: [1 .. 1];
    access_selections^ [1].selector := fsc$access_and_share_modes;
    access_selections^ [1].access_modes.selector := fsc$specific_access_modes;
    access_selections^ [1].access_modes.value := $fst$file_access_options [fsc$read, fsc$append, fsc$modify];
    access_selections^ [1].share_modes.selector := fsc$required_share_modes;

    PUSH access_creation_selections: [1 .. 1];
    access_creation_selections^ [1].selector := fsc$file_contents_and_processor;
    access_creation_selections^ [1].file_contents := amc$list;
    access_creation_selections^ [1].file_processor := osc$null_name;

    fsp$open_file (terminal_file_name, amc$record, access_selections, access_creation_selections,
          access_creation_selections, NIL, NIL, file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_paired_connection (file_id, leveled_job_connect_data_p^.system_job_name, network_file_name,
          leveled_job_connect_data_p^.destination_mainframe_id,
          leveled_job_connect_data_p^.encrypted_password, status);

    fsp$close_file (file_id, ignore_status);
    amp$return (terminal_file_name, ignore_status);
    amp$return (network_file_name, ignore_status);

  PROCEND jmp$switch_remote_connection;
?? OLDTITLE ??
MODEND jmm$switch_remote_connection;
*DECK DECK=JMM$SYSTEM_LABEL_ACCESS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE job system label access procedures' ??
MODULE jmm$system_label_access;

{ PURPOSE:
{   This module contains the job-management procedures for accessing queue file
{   labels.

{ NOTES:
{ o Elements contained in the label of a queue file must be a multiple of eight bits
{   in length.  If they are not, #unchecked_conversion will produce problems with unset
{   bits and produce range errors.
{
{ o It is assumed that the following types will never change.  If they do, the 1.4.1 label
{   conversion code will stop functioning.
{     jmt$job_system_label_version
{     jmt$output_system_label_version
{     jmt$system_supplied_name
{     ost$date_time
{     ost$name
{     pmt$time_increment
{
{ o If an existing attribute needs to change its type, a new element identifier should be assigned
{   to preserve compatibility of the queue file label.  If the change is binary compatible, then the
{   existing element identifier in the queue file label can be used for as long as uninitialized bits
{   were previously initialized to zero (this zero pre-initialization would be
{   done by the process which packs the queue file label).

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??

*copyc fmp$get_jl_pointer2
*copyc fmp$put_jl_pointer
*copyc osp$set_status_condition

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jme$queued_file_conditions
*copyc jme$read_qfile_system_label
*copyc jme$write_qfile_system_label
*copyc jmt$job_system_label
*copyc jmt$output_system_label
*copyc jmt$qfile_system_label
*copyc ost$status
?? POP ??
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

{ This type defines the structure of the NOS/VE job_system_label at version
{ JL_version_0011.  This version was introduced in the 1.4.1 release of
{ NOS/VE.


{ This type depends on the following types not changing:
{   jmt$job_system_label_version
{   jmt$system_supplied_name
{   ost$date_time
{   ost$name
{   pmt$time_increment

  CONST
    new_job_system_label_version = 'JL_version_0012',
    old_job_system_label_version = 'JL_version_0011';

  TYPE
    old_job_system_label = record
      version: jmt$job_system_label_version,
      active_profile_version: ost$name,
      assigned_job_class: ost$name,
      data_declaration: string (2),
      data_mode: 0 .. 2,
      disposition_code: string (2),
      job_abort_disposition: 0 .. 1,
      job_attributes: old_job_attributes,
      job_category_set: set of 0 .. 63,
      job_class_name: ost$name,
      job_deferred_by_operator: boolean,
      job_deferred_by_user: boolean,
      job_destination_family: ost$name,
      job_destination_usage: ost$name,
      job_execution_ring: 0 .. 15,
      job_initiation_location: string (17),
      job_mode: 0 .. 4,
      job_priority: ost$name,
      job_recovery_disposition: 0 .. 2,
      limit_information: old_job_label_limit_information,
      login_account: ost$name,
      login_project: ost$name,
      login_password: ost$name,
      login_user_identification: record
        user: ost$name,
        family: ost$name,
      recend,
      optional_user_capability: ost$name,
      originating_login_account: ost$name,
      originating_login_family: ost$name,
      originating_login_project: ost$name,
      originating_login_user: ost$name,
      perform_class_validation: boolean,
      required_user_capability: ost$name,
      system_job_name: jmt$system_supplied_name,
      user_job_name: ost$name,
    recend;

  TYPE
    old_job_label_limit_information = record
      cpu_time_limit_specified: boolean,
      cpu_time_limit_requested: integer,
      cpu_time_limit_assigned: integer,
      magnetic_tape_limit_specified: boolean,
      magnetic_tape_limit_requested: 0 .. 104,
      magnetic_tape_limit_assigned: 0 .. 104,
      maximum_working_set_specified: boolean,
      maximum_working_set_requested: 20 .. 65004,
      maximum_working_set_assigned: 20 .. 65004,
      sru_limit_specified: boolean,
      sru_limit_requested: integer,
      sru_limit_assigned: integer,
    recend;

  TYPE
    old_job_attributes = record
      comment_banner: ost$name,
      copy_count: 0 .. 10,
      device: ost$name,
      earliest_run_time: old_date_time,
      earliest_print_time: old_date_time,
      external_characteristics: string (6),
      forms_code: string (6),
      implicit_routing_text: record
        size: 0 .. 256,
        text: string (256),
      recend,
      job_controller: record
        user: ost$name,
        family: ost$name,
      recend,
      job_initiation_time: ost$date_time,
      job_input_device: record
        size: 0 .. 256,
        text: string (256),
      recend,
      job_qualifier_list: array [1 .. 5] of ost$name,
      job_size: 0 .. 07fffffff(16),
      job_submission_time: ost$date_time,
      latest_run_time: old_date_time,
      latest_print_time: old_date_time,
      login_command_supplied: boolean,
      originating_application_name: ost$name,
      originating_ssn: jmt$system_supplied_name,
      output_class: ost$name,
      output_deferred_by_user: boolean,
      output_destination: ost$name,
      output_destination_family: ost$name, { operator_family
      output_destination_usage: ost$name,
      output_disposition_key: 0 .. 5,
      output_disposition_path: string (512),
      output_priority: ost$name,
      process_user_prolog_and_epilog: boolean,
      purge_delay: old_time_increment,
      remote_host_directive: record
        size: 0 .. 256,
        parameters: string (256),
      recend,
      routing_banner: ost$name,
      source_logical_id: ost$name,
      site_information: string (256),
      station: ost$name,
      station_operator: ost$name, { operator_user
      system_job_parameters: record
        system_job_parameter_count: 0 .. 256,
        system_job_parameter: string (256),
      recend,
      system_routing_text: record
        size: 0 .. 256,
        parameters: string (256),
      recend,
      user_information: string (256),
      vertical_print_density: 0 .. 8,
      vfu_load_procedure: ost$name,
    recend;

  TYPE
    old_date_time = record
      case specified: boolean of
      = TRUE =
        date_time: ost$date_time,
      = FALSE =
        ,
      casend,
    recend;

  TYPE
    old_time_increment = record
      case specified: boolean of
      = TRUE =
        time_increment: pmt$time_increment,
      = FALSE =
        ,
      casend,
    recend;

{ This type defines the structure of the NOS/VE output_system_label at version
{ OL_version_0009.  This version was introduced in the 1.4.1 release of
{ NOS/VE.


{ This type depends on the following types not changing:
{   jmt$output_system_label_version
{   jmt$system_supplied_name
{   ost$date_time
{   ost$name
{   pmt$time_increment

  CONST
    new_output_system_label_version = 'OL_version_0010',
    old_output_system_label_version = 'OL_version_0009';


  TYPE
    old_output_system_label = record
      version: jmt$output_system_label_version,
      comment_banner: ost$name,
      copies_printed: 0 .. 10,
      copy_count: 0 .. 10,
      data_declaration: string (2),
      data_mode: 0 .. 2,
      device: ost$name,
      device_type: 0 .. 2,
      disposition_code: string (2),
      dual_state_account: ost$name,
      dual_state_family_name: ost$name,
      dual_state_password: ost$name,
      dual_state_project: ost$name,
      dual_state_user: ost$name,
      earliest_print_time: old_date_time,
      external_characteristics: string (6),
      file_position: 0 .. 07fffffff(16),
      file_size: 0 .. 07fffffff(16),
      forms_code: string (6),
      implicit_routing_text: record
        size: 0 .. 256,
        text: string (256),
      recend,
      latest_print_time: old_date_time,
      login_account: ost$name,
      login_project: ost$name,
      login_user_identification: record
        user: ost$name,
        family: ost$name,
      recend,
      originating_application_name: ost$name,
      output_class: ost$name,
      output_controller: record
        user: ost$name,
        family: ost$name,
      recend,
      output_deferred_by_operator: boolean,
      output_deferred_by_user: boolean,
      output_destination: ost$name,
      output_destination_family: ost$name, { operator_family
      output_destination_usage: ost$name,
      output_disposition_key: 0 .. 5,
      output_disposition_time: old_date_time,
      output_priority: ost$name,
      output_submission_time: ost$date_time,
      purge_delay: old_time_increment,
      remote_host_directive: record
        size: 0 .. 256,
        parameters: string (256),
      recend,
      routing_banner: ost$name,
      site_information: string (256),
      source_logical_id: ost$name,
      station: ost$name,
      station_operator: ost$name, { operator_user
      system_file_name: jmt$system_supplied_name,
      system_job_name: jmt$system_supplied_name,
      system_routing_text: record
        size: 0 .. 256,
        parameters: string (256),
      recend,
      user_information: string (256),
      user_file_name: ost$name,
      user_job_name: ost$name,
      vertical_print_density: 0 .. 8,
      vfu_load_procedure: ost$name,
    recend;

  TYPE
    t$label_element_header = record
      element_identifier: t$element_identifier,
      element_size: t$element_size,
    recend,
    t$element_identifier = 0 .. c$maximum_elements,
    t$element_size = 0 .. c$maximum_element_size;

  CONST
    c$maximum_elements = 1000,
    c$maximum_element_size = 32767;

  CONST
    c$active_profile_version = 10,
    c$application_attributes = 15,
    c$application_name = 17,
    c$assigned_job_class = 20,
    c$comment_banner = 30,
    c$control_family = 40,
    c$control_user = 50,
    c$copies_printed = 60,
    c$copy_count = 70,
    c$cpu_time_limit_assigned = 80,
    c$cpu_time_limit_requested = 90,
    c$cpu_time_limit_specified = 100,
    c$data_declaration = 110,
    c$data_mode = 120,
    c$deferred_by_application = 125,
    c$destination = 128,
    c$device = 130,
    c$device_type = 140,
    c$disposition_code = 150,
    c$disposition_time = 155,
    c$dual_state_account = 160,
    c$dual_state_family = 170,
    c$dual_state_password = 180,
    c$dual_state_project = 190,
    c$dual_state_user = 200,
    c$earliest_print_time = 210,
    c$earliest_run_time = 220,
    c$external_characteristics = 230,
    c$file_position = 240,
    c$file_size = 250,
    c$forms_code = 260,
    c$implicit_routing_text = 270,
    c$job_abort_disposition = 280,
    c$job_category_set = 290,
    c$job_class_name = 300,
    c$job_deferred_by_operator = 310,
    c$job_deferred_by_user = 320,
    c$job_destination_family = 330,
    c$job_destination_usage = 340,
    c$job_execution_ring = 350,
    c$job_initiation_location = 360,
    c$job_initiation_time = 370,
    c$job_input_device = 380,
    c$job_mode = 390,
    c$job_priority = 400,
    c$job_qualifier_list = 410,
    c$job_recovery_disposition = 420,
    c$job_submission_time = 430,
    c$latest_print_time = 440,
    c$latest_run_time = 450,
    c$login_account = 460,
    c$login_command_supplied = 470,
    c$login_family = 480,
    c$login_password = 490,
    c$login_project = 500,
    c$login_user = 510,
    c$magnetic_tape_limit_assigned = 520,
    c$magnetic_tape_limit_requested = 530,
    c$magnetic_tape_limit_specified = 540,
    c$maximum_working_set_assigned = 550,
    c$maximum_working_set_requested = 560,
    c$maximum_working_set_specified = 570,
    c$optional_user_capability = 580,
    c$originating_application_name = 590,
    c$originating_login_account = 600,
    c$originating_login_family = 610,
    c$originating_login_project = 620,
    c$originating_login_user = 630,
    c$originating_ssn = 640,
    c$output_class = 650,
    c$output_deferred_by_operator = 660,
    c$output_deferred_by_user = 670,
    c$output_destination = 680,
    c$output_destination_family = 690,
    c$output_destination_usage = 700,
    c$output_disposition_key = 710,
    c$output_disposition_path = 720,
    c$output_disposition_time = 730,
    c$output_priority = 740,
    c$output_submission_time = 750,
    c$perform_class_validation = 760,
    c$process_user_prolog_epilog = 770,
    c$purge_delay = 780,
    c$remote_host_directive = 790,
    c$required_user_capability = 800,
    c$routing_banner = 810,
    c$site_information = 820,
    c$source_logical_id = 830,
    c$sru_limit_assigned = 840,
    c$sru_limit_requested = 850,
    c$sru_limit_specified = 860,
    c$station = 870,
    c$station_operator = 880,
    c$system_file_name = 890,
    c$system_job_name = 900,
    c$system_job_parameters = 910,
    c$system_routing_text = 920,
    c$user_file_name = 930,
    c$user_information = 940,
    c$user_job_name = 950,
    c$version = 960,
    c$vertical_print_density = 970,
    c$vfu_load_procedure = 980;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$read_job_system_label', EJECT ??
*copy qfh$read_job_system_label

  PROCEDURE [XDCL, #GATE] qfp$read_job_system_label
    (    file_reference: fst$file_reference;
     VAR system_label: jmt$job_system_label;
     VAR status: ost$status);

    VAR
      job_label_p: ^SEQ ( * ),
      job_label_version_p: ^jmt$job_system_label_version;

?? NEWTITLE := 'unpack_old_job_label', EJECT ??

    PROCEDURE unpack_old_job_label
      (VAR job_label_p {input} : ^SEQ ( * );
       VAR system_label: jmt$job_system_label);

      VAR
        job_system_label_p: ^old_job_system_label;

      RESET job_label_p;
      NEXT job_system_label_p IN job_label_p;
      system_label.version := job_system_label_p^.version;
      system_label.active_profile_version := job_system_label_p^.active_profile_version;
      system_label.assigned_job_class := job_system_label_p^.assigned_job_class;
      system_label.data_declaration := job_system_label_p^.data_declaration;
      #UNCHECKED_CONVERSION (job_system_label_p^.data_mode, system_label.data_mode);
      system_label.disposition_code := job_system_label_p^.disposition_code;
      #UNCHECKED_CONVERSION (job_system_label_p^.job_abort_disposition, system_label.job_abort_disposition);
      system_label.job_attributes.comment_banner := job_system_label_p^.job_attributes.comment_banner;
      system_label.job_attributes.copy_count := job_system_label_p^.job_attributes.copy_count;
      system_label.job_attributes.device := job_system_label_p^.job_attributes.device;
      system_label.job_attributes.earliest_run_time := job_system_label_p^.job_attributes.earliest_run_time;
      system_label.job_attributes.earliest_print_time := job_system_label_p^.job_attributes.
            earliest_print_time;
      system_label.job_attributes.external_characteristics :=
            job_system_label_p^.job_attributes.external_characteristics;
      system_label.job_attributes.forms_code := job_system_label_p^.job_attributes.forms_code;
      system_label.job_attributes.implicit_routing_text :=
            job_system_label_p^.job_attributes.implicit_routing_text;
      system_label.job_attributes.job_controller := job_system_label_p^.job_attributes.job_controller;
      system_label.job_attributes.job_initiation_time := job_system_label_p^.job_attributes.
            job_initiation_time;
      system_label.job_attributes.job_input_device := job_system_label_p^.job_attributes.job_input_device;
      system_label.job_attributes.job_qualifier_list := job_system_label_p^.job_attributes.job_qualifier_list;
      system_label.job_attributes.job_size := job_system_label_p^.job_attributes.job_size;
      system_label.job_attributes.job_submission_time := job_system_label_p^.job_attributes.
            job_submission_time;
      system_label.job_attributes.latest_run_time := job_system_label_p^.job_attributes.latest_run_time;
      system_label.job_attributes.latest_print_time := job_system_label_p^.job_attributes.latest_print_time;
      system_label.job_attributes.login_command_supplied :=
            job_system_label_p^.job_attributes.login_command_supplied;
      system_label.job_attributes.originating_application_name :=
            job_system_label_p^.job_attributes.originating_application_name;
      system_label.job_attributes.originating_ssn := job_system_label_p^.job_attributes.originating_ssn;
      system_label.job_attributes.output_class := job_system_label_p^.job_attributes.output_class;
      system_label.job_attributes.output_deferred_by_user :=
            job_system_label_p^.job_attributes.output_deferred_by_user;
      system_label.job_attributes.output_destination := job_system_label_p^.job_attributes.output_destination;
      system_label.job_attributes.output_destination_family :=
            job_system_label_p^.job_attributes.output_destination_family;
      system_label.job_attributes.output_destination_usage :=
            job_system_label_p^.job_attributes.output_destination_usage;
      #UNCHECKED_CONVERSION (job_system_label_p^.job_attributes.output_disposition_key,
            system_label.job_attributes.output_disposition_key);
      system_label.job_attributes.output_disposition_path :=
            job_system_label_p^.job_attributes.output_disposition_path;
      system_label.job_attributes.output_priority := job_system_label_p^.job_attributes.output_priority;
      system_label.job_attributes.process_user_prolog_and_epilog :=
            job_system_label_p^.job_attributes.process_user_prolog_and_epilog;
      system_label.job_attributes.purge_delay := job_system_label_p^.job_attributes.purge_delay;
      system_label.job_attributes.remote_host_directive :=
            job_system_label_p^.job_attributes.remote_host_directive;
      system_label.job_attributes.routing_banner := job_system_label_p^.job_attributes.routing_banner;
      system_label.job_attributes.source_logical_id := job_system_label_p^.job_attributes.source_logical_id;
      system_label.job_attributes.site_information := job_system_label_p^.job_attributes.site_information;
      system_label.job_attributes.station := job_system_label_p^.job_attributes.station;
      system_label.job_attributes.station_operator := job_system_label_p^.job_attributes.station_operator;
      system_label.job_attributes.system_job_parameters :=
            job_system_label_p^.job_attributes.system_job_parameters;
      system_label.job_attributes.system_routing_text := job_system_label_p^.job_attributes.
            system_routing_text;
      system_label.job_attributes.user_information := job_system_label_p^.job_attributes.user_information;
      #UNCHECKED_CONVERSION (job_system_label_p^.job_attributes.vertical_print_density,
            system_label.job_attributes.vertical_print_density);
      system_label.job_attributes.vfu_load_procedure := job_system_label_p^.job_attributes.vfu_load_procedure;
      #UNCHECKED_CONVERSION (job_system_label_p^.job_category_set, system_label.job_category_set);
      system_label.job_class_name := job_system_label_p^.job_class_name;
      system_label.job_deferred_by_operator := job_system_label_p^.job_deferred_by_operator;
      system_label.job_deferred_by_user := job_system_label_p^.job_deferred_by_user;
      system_label.job_destination_family := job_system_label_p^.job_destination_family;
      system_label.job_destination_usage := job_system_label_p^.job_destination_usage;
      system_label.job_execution_ring := job_system_label_p^.job_execution_ring;
      system_label.job_initiation_location := job_system_label_p^.job_initiation_location;
      #UNCHECKED_CONVERSION (job_system_label_p^.job_mode, system_label.job_mode);
      system_label.job_priority := job_system_label_p^.job_priority;
      #UNCHECKED_CONVERSION (job_system_label_p^.job_recovery_disposition,
            system_label.job_recovery_disposition);
      system_label.limit_information.cpu_time_limit_specified :=
            job_system_label_p^.limit_information.cpu_time_limit_specified;
      system_label.limit_information.cpu_time_limit_requested :=
            job_system_label_p^.limit_information.cpu_time_limit_requested;
      system_label.limit_information.cpu_time_limit_assigned :=
            job_system_label_p^.limit_information.cpu_time_limit_assigned;
      system_label.limit_information.magnetic_tape_limit_specified :=
            job_system_label_p^.limit_information.magnetic_tape_limit_specified;
      system_label.limit_information.magnetic_tape_limit_requested :=
            job_system_label_p^.limit_information.magnetic_tape_limit_requested;
      system_label.limit_information.magnetic_tape_limit_assigned :=
            job_system_label_p^.limit_information.magnetic_tape_limit_assigned;
      system_label.limit_information.maximum_working_set_specified :=
            job_system_label_p^.limit_information.maximum_working_set_specified;
      system_label.limit_information.maximum_working_set_requested :=
            job_system_label_p^.limit_information.maximum_working_set_requested;
      system_label.limit_information.maximum_working_set_assigned :=
            job_system_label_p^.limit_information.maximum_working_set_assigned;
      system_label.limit_information.sru_limit_specified :=
            job_system_label_p^.limit_information.sru_limit_specified;
      system_label.limit_information.sru_limit_requested :=
            job_system_label_p^.limit_information.sru_limit_requested;
      system_label.limit_information.sru_limit_assigned :=
            job_system_label_p^.limit_information.sru_limit_assigned;
      system_label.login_account := job_system_label_p^.login_account;
      system_label.login_password := job_system_label_p^.login_password;
      system_label.login_project := job_system_label_p^.login_project;
      system_label.login_user_identification := job_system_label_p^.login_user_identification;
      system_label.optional_user_capability := job_system_label_p^.optional_user_capability;
      system_label.originating_login_account := job_system_label_p^.originating_login_account;
      system_label.originating_login_family := job_system_label_p^.originating_login_family;
      system_label.originating_login_project := job_system_label_p^.originating_login_project;
      system_label.originating_login_user := job_system_label_p^.originating_login_user;
      system_label.perform_class_validation := job_system_label_p^.perform_class_validation;
      system_label.required_user_capability := job_system_label_p^.required_user_capability;
      system_label.system_job_name := job_system_label_p^.system_job_name;
      system_label.user_job_name := job_system_label_p^.user_job_name;

{ Initialize the fields that have been added to the job label since 1.4.1 with
{ default values.

{ Currently, there are none.

    PROCEND unpack_old_job_label;
?? OLDTITLE ??
?? NEWTITLE := 'unpack_standard_job_label', EJECT ??

    PROCEDURE unpack_standard_job_label
      (VAR job_label_p {input} : ^SEQ ( * );
       VAR system_label: jmt$job_system_label;
       VAR status: ost$status);

      VAR
        element_p: ^string ( * <= c$maximum_element_size),
        field_header_p: ^t$label_element_header;

      status.normal := TRUE;

{ Initialize any fields that have been added to the standard job system label since it
{ was of the form of the old label (1.5.2).

{ Currently, there are no new fields.

      system_label.version := new_job_system_label_version;

      NEXT field_header_p IN job_label_p;
      WHILE field_header_p <> NIL DO
        IF field_header_p^.element_size > 0 THEN
          NEXT element_p: [field_header_p^.element_size] IN job_label_p;
          IF element_p = NIL THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
        ELSE
          element_p := NIL;
        IFEND;

        CASE field_header_p^.element_identifier OF
        = c$active_profile_version =
          IF field_header_p^.element_size <> #SIZE (system_label.active_profile_version) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.active_profile_version);

        = c$assigned_job_class =
          IF field_header_p^.element_size <> #SIZE (system_label.assigned_job_class) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.assigned_job_class);

        = c$comment_banner =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.comment_banner) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.comment_banner);

        = c$control_family =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.job_controller.family) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.job_controller.family);

        = c$control_user =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.job_controller.user) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.job_controller.user);

        = c$copy_count =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.copy_count) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.copy_count);

        = c$cpu_time_limit_assigned =
          IF field_header_p^.element_size <> #SIZE (system_label.limit_information.cpu_time_limit_assigned)
                THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.limit_information.cpu_time_limit_assigned);

        = c$cpu_time_limit_requested =
          IF field_header_p^.element_size <> #SIZE (system_label.limit_information.cpu_time_limit_requested)
                THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.limit_information.cpu_time_limit_requested);

        = c$cpu_time_limit_specified =
          IF field_header_p^.element_size <> #SIZE (system_label.limit_information.cpu_time_limit_specified)
                THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.limit_information.cpu_time_limit_specified);

        = c$data_declaration =
          IF field_header_p^.element_size <> #SIZE (system_label.data_declaration) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.data_declaration);

        = c$data_mode =
          IF field_header_p^.element_size <> #SIZE (system_label.data_mode) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.data_mode);

        = c$device =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.device) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.device);

        = c$disposition_code =
          IF field_header_p^.element_size <> #SIZE (system_label.disposition_code) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.disposition_code);

        = c$earliest_print_time =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.earliest_print_time) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.earliest_print_time);

        = c$earliest_run_time =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.earliest_run_time) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.earliest_run_time);

        = c$external_characteristics =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.external_characteristics) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.external_characteristics);

        = c$file_size =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.job_size) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.job_size);

        = c$forms_code =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.forms_code) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.forms_code);

        = c$implicit_routing_text =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.implicit_routing_text) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.implicit_routing_text);

        = c$job_abort_disposition =
          IF field_header_p^.element_size <> #SIZE (system_label.job_abort_disposition) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_abort_disposition);

        = c$job_category_set =
          IF field_header_p^.element_size <> #SIZE (system_label.job_category_set) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_category_set);

        = c$job_class_name =
          IF field_header_p^.element_size <> #SIZE (system_label.job_class_name) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_class_name);

        = c$job_deferred_by_operator =
          IF field_header_p^.element_size <> #SIZE (system_label.job_deferred_by_operator) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_deferred_by_operator);

        = c$job_deferred_by_user =
          IF field_header_p^.element_size <> #SIZE (system_label.job_deferred_by_user) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_deferred_by_user);

        = c$job_destination_family =
          IF field_header_p^.element_size <> #SIZE (system_label.job_destination_family) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_destination_family);

        = c$job_destination_usage =
          IF field_header_p^.element_size <> #SIZE (system_label.job_destination_usage) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_destination_usage);

        = c$job_execution_ring =
          IF field_header_p^.element_size <> #SIZE (system_label.job_execution_ring) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_execution_ring);

        = c$job_initiation_location =
          IF field_header_p^.element_size <> #SIZE (system_label.job_initiation_location) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_initiation_location);

        = c$job_initiation_time =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.job_initiation_time) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.job_initiation_time);

        = c$job_input_device =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.job_input_device) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.job_input_device);

        = c$job_mode =
          IF field_header_p^.element_size <> #SIZE (system_label.job_mode) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_mode);

        = c$job_priority =
          IF field_header_p^.element_size <> #SIZE (system_label.job_priority) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_priority);

        = c$job_qualifier_list =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.job_qualifier_list) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.job_qualifier_list);

        = c$job_recovery_disposition =
          IF field_header_p^.element_size <> #SIZE (system_label.job_recovery_disposition) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_recovery_disposition);

        = c$job_submission_time =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.job_submission_time) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.job_submission_time);

        = c$latest_print_time =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.latest_print_time) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.latest_print_time);

        = c$latest_run_time =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.latest_run_time) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.latest_run_time);

        = c$login_account =
          IF field_header_p^.element_size <> #SIZE (system_label.login_account) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.login_account);

        = c$login_command_supplied =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.login_command_supplied) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.login_command_supplied);

        = c$login_family =
          IF field_header_p^.element_size <> #SIZE (system_label.login_user_identification.family) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.login_user_identification.family);

        = c$login_password =
          IF field_header_p^.element_size <> #SIZE (system_label.login_password) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.login_password);

        = c$login_project =
          IF field_header_p^.element_size <> #SIZE (system_label.login_project) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.login_project);

        = c$login_user =
          IF field_header_p^.element_size <> #SIZE (system_label.login_user_identification.user) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.login_user_identification.user);

        = c$magnetic_tape_limit_assigned =
          IF field_header_p^.element_size <> #SIZE (system_label.limit_information.
                magnetic_tape_limit_assigned) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.limit_information.magnetic_tape_limit_assigned);

        = c$magnetic_tape_limit_requested =
          IF field_header_p^.element_size <> #SIZE (system_label.limit_information.
                magnetic_tape_limit_requested) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.limit_information.magnetic_tape_limit_requested);

        = c$magnetic_tape_limit_specified =
          IF field_header_p^.element_size <> #SIZE (system_label.limit_information.
                magnetic_tape_limit_specified) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.limit_information.magnetic_tape_limit_specified);

        = c$maximum_working_set_assigned =
          IF field_header_p^.element_size <> #SIZE (system_label.limit_information.
                maximum_working_set_assigned) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.limit_information.maximum_working_set_assigned);

        = c$maximum_working_set_requested =
          IF field_header_p^.element_size <> #SIZE (system_label.limit_information.
                maximum_working_set_requested) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.limit_information.maximum_working_set_requested);

        = c$maximum_working_set_specified =
          IF field_header_p^.element_size <> #SIZE (system_label.limit_information.
                maximum_working_set_specified) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.limit_information.maximum_working_set_specified);

        = c$optional_user_capability =
          IF field_header_p^.element_size <> #SIZE (system_label.optional_user_capability) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.optional_user_capability);

        = c$originating_application_name =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.originating_application_name)
                THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.originating_application_name);

        = c$originating_login_account =
          IF field_header_p^.element_size <> #SIZE (system_label.originating_login_account) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.originating_login_account);

        = c$originating_login_family =
          IF field_header_p^.element_size <> #SIZE (system_label.originating_login_family) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.originating_login_family);

        = c$originating_login_project =
          IF field_header_p^.element_size <> #SIZE (system_label.originating_login_project) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.originating_login_project);

        = c$originating_login_user =
          IF field_header_p^.element_size <> #SIZE (system_label.originating_login_user) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.originating_login_user);

        = c$originating_ssn =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.originating_ssn) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.originating_ssn);

        = c$output_class =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.output_class) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.output_class);

        = c$output_deferred_by_user =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.output_deferred_by_user) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.output_deferred_by_user);

        = c$output_destination =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.output_destination) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.output_destination);

        = c$output_destination_family =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.output_destination_family)
                THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.output_destination_family);

        = c$output_destination_usage =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.output_destination_usage) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.output_destination_usage);

        = c$output_disposition_key =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.output_disposition_key) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.output_disposition_key);

        = c$output_disposition_path =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.output_disposition_path) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.output_disposition_path);

        = c$output_priority =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.output_priority) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.output_priority);

        = c$perform_class_validation =
          IF field_header_p^.element_size <> #SIZE (system_label.perform_class_validation) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.perform_class_validation);

        = c$process_user_prolog_epilog =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.
                process_user_prolog_and_epilog) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.process_user_prolog_and_epilog);

        = c$purge_delay =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.purge_delay) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.purge_delay);

        = c$remote_host_directive =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.remote_host_directive) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.remote_host_directive);

        = c$required_user_capability =
          IF field_header_p^.element_size <> #SIZE (system_label.required_user_capability) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.required_user_capability);

        = c$routing_banner =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.routing_banner) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.routing_banner);

        = c$site_information =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.site_information) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.site_information);

        = c$source_logical_id =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.source_logical_id) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.source_logical_id);

        = c$sru_limit_assigned =
          IF field_header_p^.element_size <> #SIZE (system_label.limit_information.sru_limit_assigned) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.limit_information.sru_limit_assigned);

        = c$sru_limit_requested =
          IF field_header_p^.element_size <> #SIZE (system_label.limit_information.sru_limit_requested) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.limit_information.sru_limit_requested);

        = c$sru_limit_specified =
          IF field_header_p^.element_size <> #SIZE (system_label.limit_information.sru_limit_specified) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.limit_information.sru_limit_specified);

        = c$station =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.station) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.station);

        = c$station_operator =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.station_operator) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.station_operator);

        = c$system_job_name =
          IF field_header_p^.element_size <> #SIZE (system_label.system_job_name) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.system_job_name);

        = c$system_job_parameters =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.system_job_parameters) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.system_job_parameters);

        = c$system_routing_text =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.system_routing_text) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.system_routing_text);

        = c$user_information =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.user_information) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.user_information);

        = c$user_job_name =
          IF field_header_p^.element_size <> #SIZE (system_label.user_job_name) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.user_job_name);

        = c$version =

{ Shouldn't ever get here, but, just in case...

        = c$vertical_print_density =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.vertical_print_density) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.vertical_print_density);

        = c$vfu_load_procedure =
          IF field_header_p^.element_size <> #SIZE (system_label.job_attributes.vfu_load_procedure) THEN
            osp$set_status_condition (jme$read_job_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.job_attributes.vfu_load_procedure);

        ELSE

{ An unknown label element has been found.  The label must have been generated on
{ a predecessor system to the currently executing system.  Ignore unknown attributes.

        CASEND;

        NEXT field_header_p IN job_label_p;
      WHILEND;
    PROCEND unpack_standard_job_label;
?? OLDTITLE ??
?? EJECT ??
    status.normal := TRUE;

    fmp$get_jl_pointer (file_reference, {append} FALSE, job_label_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET job_label_p;
    NEXT job_label_version_p IN job_label_p;
    IF job_label_version_p = NIL THEN
      osp$set_status_condition (jme$read_job_system_label, status);
      RETURN;
    IFEND;

    IF job_label_version_p^ = old_job_system_label_version THEN
      unpack_old_job_label (job_label_p, system_label);
    ELSEIF job_label_version_p^ = new_job_system_label_version THEN
      unpack_standard_job_label (job_label_p, system_label, status);
    ELSE
      osp$set_status_condition (jme$sl_version_mismatch, status);
      RETURN;
    IFEND;

  PROCEND qfp$read_job_system_label;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$read_output_system_label', EJECT ??
*copy qfh$read_output_system_label

  PROCEDURE [XDCL, #GATE] qfp$read_output_system_label
    (    file_reference: fst$file_reference;
     VAR system_label: jmt$output_system_label;
     VAR status: ost$status);

    VAR
      output_label_p: ^SEQ ( * ),
      output_label_version_p: ^jmt$output_system_label_version;

?? NEWTITLE := 'unpack_old_output_label', EJECT ??

    PROCEDURE unpack_old_output_label
      (VAR output_label_p {input} : ^SEQ ( * );
       VAR system_label: jmt$output_system_label);

      VAR
        output_system_label_p: ^old_output_system_label;

      status.normal := TRUE;
      RESET output_label_p;
      NEXT output_system_label_p IN output_label_p;
      system_label.version := output_system_label_p^.version;
      system_label.comment_banner := output_system_label_p^.comment_banner;
      system_label.copies_printed := output_system_label_p^.copies_printed;
      system_label.copy_count := output_system_label_p^.copy_count;
      system_label.data_declaration := output_system_label_p^.data_declaration;
      #UNCHECKED_CONVERSION (output_system_label_p^.data_mode, system_label.data_mode);
      system_label.device := output_system_label_p^.device;
      #UNCHECKED_CONVERSION (output_system_label_p^.device_type, system_label.device_type);
      system_label.disposition_code := output_system_label_p^.disposition_code;
      system_label.dual_state_account := output_system_label_p^.dual_state_account;
      system_label.dual_state_family_name := output_system_label_p^.dual_state_family_name;
      system_label.dual_state_password := output_system_label_p^.dual_state_password;
      system_label.dual_state_project := output_system_label_p^.dual_state_project;
      system_label.dual_state_user := output_system_label_p^.dual_state_user;
      system_label.earliest_print_time := output_system_label_p^.earliest_print_time;
      system_label.external_characteristics := output_system_label_p^.external_characteristics;
      system_label.file_position := output_system_label_p^.file_position;
      system_label.file_size := output_system_label_p^.file_size;
      system_label.forms_code := output_system_label_p^.forms_code;
      system_label.implicit_routing_text := output_system_label_p^.implicit_routing_text;
      system_label.latest_print_time := output_system_label_p^.latest_print_time;
      system_label.login_account := output_system_label_p^.login_account;
      system_label.login_project := output_system_label_p^.login_project;
      system_label.login_user_identification := output_system_label_p^.login_user_identification;
      system_label.originating_application_name := output_system_label_p^.originating_application_name;
      system_label.output_class := output_system_label_p^.output_class;
      system_label.output_controller := output_system_label_p^.output_controller;
      system_label.output_deferred_by_operator := output_system_label_p^.output_deferred_by_operator;
      system_label.output_deferred_by_user := output_system_label_p^.output_deferred_by_user;
      system_label.output_destination := output_system_label_p^.output_destination;
      system_label.output_destination_family := output_system_label_p^.output_destination_family;
      system_label.output_destination_usage := output_system_label_p^.output_destination_usage;
      #UNCHECKED_CONVERSION (output_system_label_p^.output_disposition_key,
            system_label.output_disposition_key);
      system_label.output_disposition_time := output_system_label_p^.output_disposition_time;
      system_label.output_priority := output_system_label_p^.output_priority;
      system_label.output_submission_time := output_system_label_p^.output_submission_time;
      system_label.purge_delay := output_system_label_p^.purge_delay;
      system_label.remote_host_directive := output_system_label_p^.remote_host_directive;
      system_label.routing_banner := output_system_label_p^.routing_banner;
      system_label.site_information := output_system_label_p^.site_information;
      system_label.source_logical_id := output_system_label_p^.source_logical_id;
      system_label.station := output_system_label_p^.station;
      system_label.station_operator := output_system_label_p^.station_operator;
      system_label.system_file_name := output_system_label_p^.system_file_name;
      system_label.system_job_name := output_system_label_p^.system_job_name;
      system_label.system_routing_text := output_system_label_p^.system_routing_text;
      system_label.user_information := output_system_label_p^.user_information;
      system_label.user_file_name := output_system_label_p^.user_file_name;
      system_label.user_job_name := output_system_label_p^.user_job_name;
      #UNCHECKED_CONVERSION (output_system_label_p^.vertical_print_density,
            system_label.vertical_print_density);
      system_label.vfu_load_procedure := output_system_label_p^.vfu_load_procedure;

{ Initialize the fields that have been added to the output label since 1.4.1 with
{ default values.

{ Currently, there are none.

    PROCEND unpack_old_output_label;
?? OLDTITLE ??
?? NEWTITLE := 'unpack_standard_output_label', EJECT ??

    PROCEDURE unpack_standard_output_label
      (VAR output_label_p {input} : ^SEQ ( * );
       VAR system_label: jmt$output_system_label;
       VAR status: ost$status);

      VAR
        element_p: ^string ( * <= c$maximum_element_size),
        field_header_p: ^t$label_element_header;

      status.normal := TRUE;

{ Initialize any fields that have been added to the output system label since it
{ was of the form of the old label (1.5.2).

{ Currently, there are no new fields.

      system_label.version := new_output_system_label_version;

      NEXT field_header_p IN output_label_p;
      WHILE field_header_p <> NIL DO
        IF field_header_p^.element_size > 0 THEN
          NEXT element_p: [field_header_p^.element_size] IN output_label_p;
          IF element_p = NIL THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
        ELSE
          element_p := NIL;
        IFEND;

        CASE field_header_p^.element_identifier OF
        = c$comment_banner =
          IF field_header_p^.element_size <> #SIZE (system_label.comment_banner) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.comment_banner);

        = c$control_family =
          IF field_header_p^.element_size <> #SIZE (system_label.output_controller.family) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.output_controller.family);

        = c$control_user =
          IF field_header_p^.element_size <> #SIZE (system_label.output_controller.user) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.output_controller.user);

        = c$copies_printed =
          IF field_header_p^.element_size <> #SIZE (system_label.copies_printed) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.copies_printed);

        = c$copy_count =
          IF field_header_p^.element_size <> #SIZE (system_label.copy_count) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.copy_count);

        = c$data_declaration =
          IF field_header_p^.element_size <> #SIZE (system_label.data_declaration) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.data_declaration);

        = c$data_mode =
          IF field_header_p^.element_size <> #SIZE (system_label.data_mode) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.data_mode);

        = c$device =
          IF field_header_p^.element_size <> #SIZE (system_label.device) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.device);

        = c$device_type =
          IF field_header_p^.element_size <> #SIZE (system_label.device_type) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.device_type);

        = c$disposition_code =
          IF field_header_p^.element_size <> #SIZE (system_label.disposition_code) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.disposition_code);

        = c$dual_state_account =
          IF field_header_p^.element_size <> #SIZE (system_label.dual_state_account) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.dual_state_account);

        = c$dual_state_family =
          IF field_header_p^.element_size <> #SIZE (system_label.dual_state_family_name) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.dual_state_family_name);

        = c$dual_state_password =
          IF field_header_p^.element_size <> #SIZE (system_label.dual_state_password) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.dual_state_password);

        = c$dual_state_project =
          IF field_header_p^.element_size <> #SIZE (system_label.dual_state_project) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.dual_state_project);

        = c$dual_state_user =
          IF field_header_p^.element_size <> #SIZE (system_label.dual_state_user) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.dual_state_user);

        = c$earliest_print_time =
          IF field_header_p^.element_size <> #SIZE (system_label.earliest_print_time) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.earliest_print_time);

        = c$external_characteristics =
          IF field_header_p^.element_size <> #SIZE (system_label.external_characteristics) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.external_characteristics);

        = c$file_position =
          IF field_header_p^.element_size <> #SIZE (system_label.file_position) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.file_position);

        = c$file_size =
          IF field_header_p^.element_size <> #SIZE (system_label.file_size) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.file_size);

        = c$forms_code =
          IF field_header_p^.element_size <> #SIZE (system_label.forms_code) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.forms_code);

        = c$implicit_routing_text =
          IF field_header_p^.element_size <> #SIZE (system_label.implicit_routing_text) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.implicit_routing_text);

        = c$latest_print_time =
          IF field_header_p^.element_size <> #SIZE (system_label.latest_print_time) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.latest_print_time);

        = c$login_account =
          IF field_header_p^.element_size <> #SIZE (system_label.login_account) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.login_account);

        = c$login_family =
          IF field_header_p^.element_size <> #SIZE (system_label.login_user_identification.family) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.login_user_identification.family);

        = c$login_project =
          IF field_header_p^.element_size <> #SIZE (system_label.login_project) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.login_project);

        = c$login_user =
          IF field_header_p^.element_size <> #SIZE (system_label.login_user_identification.user) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.login_user_identification.user);

        = c$originating_application_name =
          IF field_header_p^.element_size <> #SIZE (system_label.originating_application_name) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.originating_application_name);

        = c$output_class =
          IF field_header_p^.element_size <> #SIZE (system_label.output_class) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.output_class);

        = c$output_deferred_by_operator =
          IF field_header_p^.element_size <> #SIZE (system_label.output_deferred_by_operator) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.output_deferred_by_operator);

        = c$output_deferred_by_user =
          IF field_header_p^.element_size <> #SIZE (system_label.output_deferred_by_user) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.output_deferred_by_user);

        = c$output_destination =
          IF field_header_p^.element_size <> #SIZE (system_label.output_destination) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.output_destination);

        = c$output_destination_family =
          IF field_header_p^.element_size <> #SIZE (system_label.output_destination_family) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.output_destination_family);

        = c$output_destination_usage =
          IF field_header_p^.element_size <> #SIZE (system_label.output_destination_usage) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.output_destination_usage);

        = c$output_disposition_key =
          IF field_header_p^.element_size <> #SIZE (system_label.output_disposition_key) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.output_disposition_key);

        = c$output_disposition_time =
          IF field_header_p^.element_size <> #SIZE (system_label.output_disposition_time) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.output_disposition_time);

        = c$output_priority =
          IF field_header_p^.element_size <> #SIZE (system_label.output_priority) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.output_priority);

        = c$output_submission_time =
          IF field_header_p^.element_size <> #SIZE (system_label.output_submission_time) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.output_submission_time);

        = c$purge_delay =
          IF field_header_p^.element_size <> #SIZE (system_label.purge_delay) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.purge_delay);

        = c$remote_host_directive =
          IF field_header_p^.element_size <> #SIZE (system_label.remote_host_directive) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.remote_host_directive);

        = c$routing_banner =
          IF field_header_p^.element_size <> #SIZE (system_label.routing_banner) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.routing_banner);

        = c$site_information =
          IF field_header_p^.element_size <> #SIZE (system_label.site_information) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.site_information);

        = c$source_logical_id =
          IF field_header_p^.element_size <> #SIZE (system_label.source_logical_id) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.source_logical_id);

        = c$station =
          IF field_header_p^.element_size <> #SIZE (system_label.station) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.station);

        = c$station_operator =
          IF field_header_p^.element_size <> #SIZE (system_label.station_operator) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.station_operator);

        = c$system_file_name =
          IF field_header_p^.element_size <> #SIZE (system_label.system_file_name) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.system_file_name);

        = c$system_job_name =
          IF field_header_p^.element_size <> #SIZE (system_label.system_job_name) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.system_job_name);

        = c$system_routing_text =
          IF field_header_p^.element_size <> #SIZE (system_label.system_routing_text) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.system_routing_text);

        = c$user_file_name =
          IF field_header_p^.element_size <> #SIZE (system_label.user_file_name) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.user_file_name);

        = c$user_information =
          IF field_header_p^.element_size <> #SIZE (system_label.user_information) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.user_information);

        = c$user_job_name =
          IF field_header_p^.element_size <> #SIZE (system_label.user_job_name) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.user_job_name);

        = c$version =

{ Shouldn't ever happen, but just in case...

        = c$vertical_print_density =
          IF field_header_p^.element_size <> #SIZE (system_label.vertical_print_density) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.vertical_print_density);

        = c$vfu_load_procedure =
          IF field_header_p^.element_size <> #SIZE (system_label.vfu_load_procedure) THEN
            osp$set_status_condition (jme$read_output_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.vfu_load_procedure);

        ELSE

{ An unknown label element has been found.  The label must have been generated on
{ a predecessor system to the currently executing system.  Ignore unknown attributes.

        CASEND;

        NEXT field_header_p IN output_label_p;
      WHILEND;
    PROCEND unpack_standard_output_label;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;

    fmp$get_jl_pointer (file_reference, {append} FALSE, output_label_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET output_label_p;
    NEXT output_label_version_p IN output_label_p;
    IF output_label_version_p = NIL THEN
      osp$set_status_condition (jme$read_output_system_label, status);
      RETURN;
    IFEND;

    IF output_label_version_p^ = old_output_system_label_version THEN
      unpack_old_output_label (output_label_p, system_label);
    ELSEIF output_label_version_p^ = new_output_system_label_version THEN
      unpack_standard_output_label (output_label_p, system_label, status);
    ELSE
      osp$set_status_condition (jme$sl_version_mismatch, status);
      RETURN;
    IFEND;

  PROCEND qfp$read_output_system_label;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$read_qfile_system_label', EJECT ??
*copy qfh$read_qfile_system_label

  PROCEDURE [XDCL, #GATE] qfp$read_qfile_system_label
    (    file_reference: fst$file_reference;
     VAR system_label: jmt$qfile_system_label;
     VAR status: ost$status);

    VAR
      qfile_label_p: ^SEQ ( * );

?? NEWTITLE := 'unpack_standard_qfile_label', EJECT ??

    PROCEDURE unpack_standard_qfile_label
      (VAR qfile_label_p {input} : ^SEQ ( * );
       VAR system_label: jmt$qfile_system_label;
       VAR status: ost$status);

      VAR
        element_p: ^string ( * <= c$maximum_element_size),
        field_header_p: ^t$label_element_header;

      status.normal := TRUE;

      NEXT field_header_p IN qfile_label_p;
      WHILE field_header_p <> NIL DO
        IF field_header_p^.element_size > 0 THEN
          NEXT element_p: [field_header_p^.element_size] IN qfile_label_p;
          IF element_p = NIL THEN
            osp$set_status_condition (jme$read_qfile_system_label, status);
            RETURN;
          IFEND;
        ELSE
          element_p := NIL;
        IFEND;

        CASE field_header_p^.element_identifier OF
        = c$application_name =
          IF field_header_p^.element_size <> #SIZE (system_label.application_name) THEN
            osp$set_status_condition (jme$read_qfile_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.application_name);

        = c$data_mode =
          IF field_header_p^.element_size <> #SIZE (system_label.data_mode) THEN
            osp$set_status_condition (jme$read_qfile_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.data_mode);

        = c$deferred_by_application =
          IF field_header_p^.element_size <> #SIZE (system_label.deferred_by_application) THEN
            osp$set_status_condition (jme$read_qfile_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.deferred_by_application);

        = c$destination =
          IF field_header_p^.element_size <> #SIZE (system_label.destination) THEN
            osp$set_status_condition (jme$read_qfile_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.destination);

        = c$disposition_time =
          IF field_header_p^.element_size <> #SIZE (system_label.disposition_time) THEN
            osp$set_status_condition (jme$read_qfile_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.disposition_time);

        = c$earliest_run_time =
          IF field_header_p^.element_size <> #SIZE (system_label.earliest_run_time) THEN
            osp$set_status_condition (jme$read_qfile_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.earliest_run_time);

        = c$latest_run_time =
          IF field_header_p^.element_size <> #SIZE (system_label.latest_run_time) THEN
            osp$set_status_condition (jme$read_qfile_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.latest_run_time);

        = c$purge_delay =
          IF field_header_p^.element_size <> #SIZE (system_label.purge_delay) THEN
            osp$set_status_condition (jme$read_qfile_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.purge_delay);

        = c$remote_host_directive =
          IF field_header_p^.element_size <> #SIZE (system_label.remote_host_directive) THEN
            osp$set_status_condition (jme$read_qfile_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.remote_host_directive);

        = c$system_file_name =
          IF field_header_p^.element_size <> #SIZE (system_label.system_file_name) THEN
            osp$set_status_condition (jme$read_qfile_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.system_file_name);

        = c$application_attributes =

{ The actual size of the application attributes may be <= the size of the type defined
{ in the system label.

          IF field_header_p^.element_size > #SIZE (system_label.application_attributes) THEN
            osp$set_status_condition (jme$read_qfile_system_label, status);
            RETURN;
          IFEND;
          #UNCHECKED_CONVERSION (element_p^, system_label.application_attributes);

        ELSE

{ An unknown label element has been found.  The label must have been generated on
{ a predecessor system to the currently executing system.  Ignore unknown attributes.

        CASEND;

        NEXT field_header_p IN qfile_label_p;
      WHILEND;
    PROCEND unpack_standard_qfile_label;
?? OLDTITLE ??
?? EJECT ??
    status.normal := TRUE;

    fmp$get_jl_pointer (file_reference, {append} FALSE, qfile_label_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET qfile_label_p;

    unpack_standard_qfile_label (qfile_label_p, system_label, status);

  PROCEND qfp$read_qfile_system_label;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$write_job_system_label', EJECT ??
*copy qfh$write_job_system_label

  PROCEDURE [XDCL, #GATE] qfp$write_job_system_label
    (    file_reference: fst$file_reference;
         write_label: boolean;
         system_label: jmt$job_system_label;
     VAR status: ost$status);

    VAR
      job_label_p: ^SEQ ( * );

?? NEWTITLE := 'pack_standard_job_label', EJECT ??

    PROCEDURE pack_standard_job_label
      (    system_label: jmt$job_system_label;
       VAR job_label_p {input, output} : ^SEQ ( * );
       VAR status: ost$status);

      VAR
        element_p: ^string ( * <= c$maximum_element_size),
        field_header_p: ^t$label_element_header,
        job_label_version_p: ^jmt$job_system_label_version;

?? NEWTITLE := '[INLINE] add_element_to_label', EJECT ??

{ NOTE:
{   The variable field_header_p is declared in the enclosing procedure for
{   performance reasons.  If it were placed in the add_element_to_label procedure
{   the dynamic space pointer (DSP) would be increased every time the inline
{   was called.


      PROCEDURE [INLINE] add_element_to_label
        (    element_identifier: t$element_identifier;
             element_size: t$element_size;
         VAR element_p: ^string ( * <= c$maximum_element_size);
         VAR status: ost$status);

        NEXT field_header_p IN job_label_p;
        IF field_header_p = NIL THEN
          osp$set_status_condition (jme$write_job_system_label, status);
          RETURN;
        IFEND;
        field_header_p^.element_size := element_size;
        field_header_p^.element_identifier := element_identifier;
        IF element_size > 0 THEN
          NEXT element_p: [element_size] IN job_label_p;
          IF element_p = NIL THEN
            osp$set_status_condition (jme$write_job_system_label, status);
            RETURN;
          IFEND;
        ELSE
          element_p := NIL;
        IFEND;
      PROCEND add_element_to_label;
?? OLDTITLE ??
?? EJECT ??

      status.normal := TRUE;
      field_header_p := NIL;

      RESET job_label_p;
      NEXT job_label_version_p IN job_label_p;
      IF job_label_version_p = NIL THEN
        osp$set_status_condition (jme$write_job_system_label, status);
        RETURN;
      IFEND;
      job_label_version_p^ := new_job_system_label_version;

      add_element_to_label (c$active_profile_version, #SIZE (system_label.active_profile_version), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.active_profile_version, element_p^);

      add_element_to_label (c$assigned_job_class, #SIZE (system_label.assigned_job_class), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.assigned_job_class, element_p^);

      add_element_to_label (c$comment_banner, #SIZE (system_label.job_attributes.comment_banner), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.comment_banner, element_p^);

      add_element_to_label (c$control_family, #SIZE (system_label.job_attributes.job_controller.family),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.job_controller.family, element_p^);

      add_element_to_label (c$control_user, #SIZE (system_label.job_attributes.job_controller.user),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.job_controller.user, element_p^);

      add_element_to_label (c$copy_count, #SIZE (system_label.job_attributes.copy_count), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.copy_count, element_p^);

      add_element_to_label (c$cpu_time_limit_assigned, #SIZE (system_label.limit_information.
            cpu_time_limit_assigned), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.limit_information.cpu_time_limit_assigned, element_p^);

      add_element_to_label (c$cpu_time_limit_requested, #SIZE (system_label.limit_information.
            cpu_time_limit_requested), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.limit_information.cpu_time_limit_requested, element_p^);

      add_element_to_label (c$cpu_time_limit_specified, #SIZE (system_label.limit_information.
            cpu_time_limit_specified), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.limit_information.cpu_time_limit_specified, element_p^);

      add_element_to_label (c$data_declaration, #SIZE (system_label.data_declaration), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.data_declaration, element_p^);

      add_element_to_label (c$data_mode, #SIZE (system_label.data_mode), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.data_mode, element_p^);

      add_element_to_label (c$device, #SIZE (system_label.job_attributes.device), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.device, element_p^);

      add_element_to_label (c$disposition_code, #SIZE (system_label.disposition_code), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.disposition_code, element_p^);

      add_element_to_label (c$earliest_print_time, #SIZE (system_label.job_attributes.earliest_print_time),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.earliest_print_time, element_p^);

      add_element_to_label (c$earliest_run_time, #SIZE (system_label.job_attributes.earliest_run_time),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.earliest_run_time, element_p^);

      add_element_to_label (c$external_characteristics, #SIZE (system_label.job_attributes.
            external_characteristics), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.external_characteristics, element_p^);

      add_element_to_label (c$file_size, #SIZE (system_label.job_attributes.job_size), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.job_size, element_p^);

      add_element_to_label (c$forms_code, #SIZE (system_label.job_attributes.forms_code), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.forms_code, element_p^);

      add_element_to_label (c$implicit_routing_text, #SIZE (system_label.job_attributes.
            implicit_routing_text), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.implicit_routing_text, element_p^);

      add_element_to_label (c$job_abort_disposition, #SIZE (system_label.job_abort_disposition), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_abort_disposition, element_p^);

      add_element_to_label (c$job_category_set, #SIZE (system_label.job_category_set), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_category_set, element_p^);

      add_element_to_label (c$job_class_name, #SIZE (system_label.job_class_name), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_class_name, element_p^);

      add_element_to_label (c$job_deferred_by_operator, #SIZE (system_label.job_deferred_by_operator),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_deferred_by_operator, element_p^);

      add_element_to_label (c$job_deferred_by_user, #SIZE (system_label.job_deferred_by_user), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_deferred_by_user, element_p^);

      add_element_to_label (c$job_destination_family, #SIZE (system_label.job_destination_family), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_destination_family, element_p^);

      add_element_to_label (c$job_destination_usage, #SIZE (system_label.job_destination_usage), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_destination_usage, element_p^);

      add_element_to_label (c$job_execution_ring, #SIZE (system_label.job_execution_ring), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_execution_ring, element_p^);

      add_element_to_label (c$job_initiation_location, #SIZE (system_label.job_initiation_location),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_initiation_location, element_p^);

      add_element_to_label (c$job_initiation_time, #SIZE (system_label.job_attributes.job_initiation_time),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.job_initiation_time, element_p^);

      add_element_to_label (c$job_input_device, #SIZE (system_label.job_attributes.job_input_device),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.job_input_device, element_p^);

      add_element_to_label (c$job_mode, #SIZE (system_label.job_mode), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_mode, element_p^);

      add_element_to_label (c$job_priority, #SIZE (system_label.job_priority), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_priority, element_p^);

      add_element_to_label (c$job_qualifier_list, #SIZE (system_label.job_attributes.job_qualifier_list),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.job_qualifier_list, element_p^);

      add_element_to_label (c$job_recovery_disposition, #SIZE (system_label.job_recovery_disposition),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_recovery_disposition, element_p^);

      add_element_to_label (c$job_submission_time, #SIZE (system_label.job_attributes.job_submission_time),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.job_submission_time, element_p^);

      add_element_to_label (c$latest_print_time, #SIZE (system_label.job_attributes.latest_print_time),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.latest_print_time, element_p^);

      add_element_to_label (c$latest_run_time, #SIZE (system_label.job_attributes.latest_run_time), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.latest_run_time, element_p^);

      add_element_to_label (c$login_account, #SIZE (system_label.login_account), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.login_account, element_p^);

      add_element_to_label (c$login_command_supplied, #SIZE (system_label.job_attributes.
            login_command_supplied), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.login_command_supplied, element_p^);

      add_element_to_label (c$login_family, #SIZE (system_label.login_user_identification.family), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.login_user_identification.family, element_p^);

      add_element_to_label (c$login_password, #SIZE (system_label.login_password), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.login_password, element_p^);

      add_element_to_label (c$login_project, #SIZE (system_label.login_project), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.login_project, element_p^);

      add_element_to_label (c$login_user, #SIZE (system_label.login_user_identification.user), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.login_user_identification.user, element_p^);

      add_element_to_label (c$magnetic_tape_limit_assigned,
            #SIZE (system_label.limit_information.magnetic_tape_limit_assigned), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.limit_information.magnetic_tape_limit_assigned, element_p^);

      add_element_to_label (c$magnetic_tape_limit_requested,
            #SIZE (system_label.limit_information.magnetic_tape_limit_requested), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.limit_information.magnetic_tape_limit_requested, element_p^);

      add_element_to_label (c$magnetic_tape_limit_specified,
            #SIZE (system_label.limit_information.magnetic_tape_limit_specified), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.limit_information.magnetic_tape_limit_specified, element_p^);

      add_element_to_label (c$maximum_working_set_assigned,
            #SIZE (system_label.limit_information.maximum_working_set_assigned), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.limit_information.maximum_working_set_assigned, element_p^);

      add_element_to_label (c$maximum_working_set_requested,
            #SIZE (system_label.limit_information.maximum_working_set_requested), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.limit_information.maximum_working_set_requested, element_p^);

      add_element_to_label (c$maximum_working_set_specified,
            #SIZE (system_label.limit_information.maximum_working_set_specified), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.limit_information.maximum_working_set_specified, element_p^);

      add_element_to_label (c$optional_user_capability, #SIZE (system_label.optional_user_capability),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.optional_user_capability, element_p^);

      add_element_to_label (c$originating_application_name,
            #SIZE (system_label.job_attributes.originating_application_name), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.originating_application_name, element_p^);

      add_element_to_label (c$originating_login_account, #SIZE (system_label.originating_login_account),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.originating_login_account, element_p^);

      add_element_to_label (c$originating_login_family, #SIZE (system_label.originating_login_family),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.originating_login_family, element_p^);

      add_element_to_label (c$originating_login_project, #SIZE (system_label.originating_login_project),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.originating_login_project, element_p^);

      add_element_to_label (c$originating_login_user, #SIZE (system_label.originating_login_user), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.originating_login_user, element_p^);

      add_element_to_label (c$originating_ssn, #SIZE (system_label.job_attributes.originating_ssn), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.originating_ssn, element_p^);

      add_element_to_label (c$output_class, #SIZE (system_label.job_attributes.output_class), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.output_class, element_p^);

      add_element_to_label (c$output_deferred_by_user, #SIZE (system_label.job_attributes.
            output_deferred_by_user), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.output_deferred_by_user, element_p^);

      add_element_to_label (c$output_destination, #SIZE (system_label.job_attributes.output_destination),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.output_destination, element_p^);

      add_element_to_label (c$output_destination_family, #SIZE (system_label.job_attributes.
            output_destination_family), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.output_destination_family, element_p^);

      add_element_to_label (c$output_destination_usage, #SIZE (system_label.job_attributes.
            output_destination_usage), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.output_destination_usage, element_p^);

      add_element_to_label (c$output_disposition_key, #SIZE (system_label.job_attributes.
            output_disposition_key), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.output_disposition_key, element_p^);

      add_element_to_label (c$output_disposition_path, #SIZE (system_label.job_attributes.
            output_disposition_path), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.output_disposition_path, element_p^);

      add_element_to_label (c$output_priority, #SIZE (system_label.job_attributes.output_priority), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.output_priority, element_p^);

      add_element_to_label (c$perform_class_validation, #SIZE (system_label.perform_class_validation),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.perform_class_validation, element_p^);

      add_element_to_label (c$process_user_prolog_epilog, #SIZE (system_label.job_attributes.
            process_user_prolog_and_epilog), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.process_user_prolog_and_epilog, element_p^);

      add_element_to_label (c$purge_delay, #SIZE (system_label.job_attributes.purge_delay), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.purge_delay, element_p^);

      add_element_to_label (c$remote_host_directive, #SIZE (system_label.job_attributes.
            remote_host_directive), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.remote_host_directive, element_p^);

      add_element_to_label (c$required_user_capability, #SIZE (system_label.required_user_capability),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.required_user_capability, element_p^);

      add_element_to_label (c$routing_banner, #SIZE (system_label.job_attributes.routing_banner), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.routing_banner, element_p^);

      add_element_to_label (c$site_information, #SIZE (system_label.job_attributes.site_information),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.site_information, element_p^);

      add_element_to_label (c$source_logical_id, #SIZE (system_label.job_attributes.source_logical_id),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.source_logical_id, element_p^);

      add_element_to_label (c$sru_limit_assigned, #SIZE (system_label.limit_information.sru_limit_assigned),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.limit_information.sru_limit_assigned, element_p^);

      add_element_to_label (c$sru_limit_requested, #SIZE (system_label.limit_information.sru_limit_requested),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.limit_information.sru_limit_requested, element_p^);

      add_element_to_label (c$sru_limit_specified, #SIZE (system_label.limit_information.sru_limit_specified),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.limit_information.sru_limit_specified, element_p^);

      add_element_to_label (c$station, #SIZE (system_label.job_attributes.station), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.station, element_p^);

      add_element_to_label (c$station_operator, #SIZE (system_label.job_attributes.station_operator),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.station_operator, element_p^);

      add_element_to_label (c$system_job_name, #SIZE (system_label.system_job_name), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.system_job_name, element_p^);

      add_element_to_label (c$system_job_parameters, #SIZE (system_label.job_attributes.
            system_job_parameters), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.system_job_parameters, element_p^);

      add_element_to_label (c$system_routing_text, #SIZE (system_label.job_attributes.system_routing_text),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.system_routing_text, element_p^);

      add_element_to_label (c$user_information, #SIZE (system_label.job_attributes.user_information),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.user_information, element_p^);

      add_element_to_label (c$user_job_name, #SIZE (system_label.user_job_name), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.user_job_name, element_p^);

      add_element_to_label (c$vertical_print_density, #SIZE (system_label.job_attributes.
            vertical_print_density), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.vertical_print_density, element_p^);

      add_element_to_label (c$vfu_load_procedure, #SIZE (system_label.job_attributes.vfu_load_procedure),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.job_attributes.vfu_load_procedure, element_p^);

    PROCEND pack_standard_job_label;
?? OLDTITLE ??
?? EJECT ??
    status.normal := TRUE;

    fmp$get_jl_pointer (file_reference, {append} TRUE, job_label_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pack_standard_job_label (system_label, job_label_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fmp$put_jl_pointer (file_reference, write_label, job_label_p, status);
  PROCEND qfp$write_job_system_label;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$write_output_system_label', EJECT ??
*copy qfh$write_output_system_label

  PROCEDURE [XDCL, #GATE] qfp$write_output_system_label
    (    file_reference: fst$file_reference;
         write_label: boolean;
         system_label: jmt$output_system_label;
     VAR status: ost$status);

    VAR
      output_label_p: ^SEQ ( * );

?? NEWTITLE := 'pack_standard_output_label', EJECT ??

    PROCEDURE pack_standard_output_label
      (    system_label: jmt$output_system_label;
       VAR output_label_p {input} : ^SEQ ( * );
       VAR status: ost$status);

      VAR
        element_p: ^string ( * <= c$maximum_element_size),
        field_header_p: ^t$label_element_header,
        output_label_version_p: ^jmt$output_system_label_version;

?? NEWTITLE := '[INLINE] add_element_to_label', EJECT ??

{ NOTE:
{   The variable field_header_p is declared in the enclosing procedure for
{   performance reasons.  If it were placed in the add_element_to_label procedure
{   the dynamic space pointer (DSP) would be increased every time the inline
{   was called.

      PROCEDURE [INLINE] add_element_to_label
        (    element_identifier: t$element_identifier;
             element_size: t$element_size;
         VAR element_p: ^string ( * <= c$maximum_element_size);
         VAR status: ost$status);

        NEXT field_header_p IN output_label_p;
        IF field_header_p = NIL THEN
          osp$set_status_condition (jme$write_output_system_label, status);
          RETURN;
        IFEND;
        field_header_p^.element_size := element_size;
        field_header_p^.element_identifier := element_identifier;
        IF element_size > 0 THEN
          NEXT element_p: [element_size] IN output_label_p;
          IF element_p = NIL THEN
            osp$set_status_condition (jme$write_output_system_label, status);
            RETURN;
          IFEND;
        ELSE
          element_p := NIL;
        IFEND;
      PROCEND add_element_to_label;
?? OLDTITLE ??
?? EJECT ??

      status.normal := TRUE;

      RESET output_label_p;
      NEXT output_label_version_p IN output_label_p;
      IF output_label_version_p = NIL THEN
        osp$set_status_condition (jme$write_output_system_label, status);
        RETURN;
      IFEND;
      output_label_version_p^ := new_output_system_label_version;

      add_element_to_label (c$comment_banner, #SIZE (system_label.comment_banner), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.comment_banner, element_p^);

      add_element_to_label (c$control_family, #SIZE (system_label.output_controller.family), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.output_controller.family, element_p^);

      add_element_to_label (c$control_user, #SIZE (system_label.output_controller.user), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.output_controller.user, element_p^);

      add_element_to_label (c$copies_printed, #SIZE (system_label.copies_printed), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.copies_printed, element_p^);

      add_element_to_label (c$copy_count, #SIZE (system_label.copy_count), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.copy_count, element_p^);

      add_element_to_label (c$data_declaration, #SIZE (system_label.data_declaration), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.data_declaration, element_p^);

      add_element_to_label (c$data_mode, #SIZE (system_label.data_mode), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.data_mode, element_p^);

      add_element_to_label (c$device, #SIZE (system_label.device), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.device, element_p^);

      add_element_to_label (c$device_type, #SIZE (system_label.device_type), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.device_type, element_p^);

      add_element_to_label (c$disposition_code, #SIZE (system_label.disposition_code), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.disposition_code, element_p^);

      add_element_to_label (c$dual_state_account, #SIZE (system_label.dual_state_account), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.dual_state_account, element_p^);

      add_element_to_label (c$dual_state_family, #SIZE (system_label.dual_state_family_name), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.dual_state_family_name, element_p^);

      add_element_to_label (c$dual_state_password, #SIZE (system_label.dual_state_password), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.dual_state_password, element_p^);

      add_element_to_label (c$dual_state_project, #SIZE (system_label.dual_state_project), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.dual_state_project, element_p^);

      add_element_to_label (c$dual_state_user, #SIZE (system_label.dual_state_user), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.dual_state_user, element_p^);

      add_element_to_label (c$earliest_print_time, #SIZE (system_label.earliest_print_time), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.earliest_print_time, element_p^);

      add_element_to_label (c$external_characteristics, #SIZE (system_label.external_characteristics),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.external_characteristics, element_p^);

      add_element_to_label (c$file_position, #SIZE (system_label.file_position), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.file_position, element_p^);

      add_element_to_label (c$file_size, #SIZE (system_label.file_size), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.file_size, element_p^);

      add_element_to_label (c$forms_code, #SIZE (system_label.forms_code), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.forms_code, element_p^);

      add_element_to_label (c$implicit_routing_text, #SIZE (system_label.implicit_routing_text), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.implicit_routing_text, element_p^);

      add_element_to_label (c$latest_print_time, #SIZE (system_label.latest_print_time), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.latest_print_time, element_p^);

      add_element_to_label (c$login_account, #SIZE (system_label.login_account), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.login_account, element_p^);

      add_element_to_label (c$login_family, #SIZE (system_label.login_user_identification.family), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.login_user_identification.family, element_p^);

      add_element_to_label (c$login_project, #SIZE (system_label.login_project), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.login_project, element_p^);

      add_element_to_label (c$login_user, #SIZE (system_label.login_user_identification.user), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.login_user_identification.user, element_p^);

      add_element_to_label (c$originating_application_name, #SIZE (system_label.originating_application_name),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.originating_application_name, element_p^);

      add_element_to_label (c$output_class, #SIZE (system_label.output_class), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.output_class, element_p^);

      add_element_to_label (c$output_deferred_by_operator, #SIZE (system_label.output_deferred_by_operator),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.output_deferred_by_operator, element_p^);

      add_element_to_label (c$output_deferred_by_user, #SIZE (system_label.output_deferred_by_user),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.output_deferred_by_user, element_p^);

      add_element_to_label (c$output_destination, #SIZE (system_label.output_destination), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.output_destination, element_p^);

      add_element_to_label (c$output_destination_family, #SIZE (system_label.output_destination_family),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.output_destination_family, element_p^);

      add_element_to_label (c$output_destination_usage, #SIZE (system_label.output_destination_usage),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.output_destination_usage, element_p^);

      add_element_to_label (c$output_disposition_key, #SIZE (system_label.output_disposition_key), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.output_disposition_key, element_p^);

      add_element_to_label (c$output_disposition_time, #SIZE (system_label.output_disposition_time),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.output_disposition_time, element_p^);

      add_element_to_label (c$output_priority, #SIZE (system_label.output_priority), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.output_priority, element_p^);

      add_element_to_label (c$output_submission_time, #SIZE (system_label.output_submission_time), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.output_submission_time, element_p^);

      add_element_to_label (c$purge_delay, #SIZE (system_label.purge_delay), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.purge_delay, element_p^);

      add_element_to_label (c$remote_host_directive, #SIZE (system_label.remote_host_directive), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.remote_host_directive, element_p^);

      add_element_to_label (c$routing_banner, #SIZE (system_label.routing_banner), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.routing_banner, element_p^);

      add_element_to_label (c$site_information, #SIZE (system_label.site_information), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.site_information, element_p^);

      add_element_to_label (c$source_logical_id, #SIZE (system_label.source_logical_id), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.source_logical_id, element_p^);

      add_element_to_label (c$station, #SIZE (system_label.station), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.station, element_p^);

      add_element_to_label (c$station_operator, #SIZE (system_label.station_operator), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.station_operator, element_p^);

      add_element_to_label (c$system_file_name, #SIZE (system_label.system_file_name), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.system_file_name, element_p^);

      add_element_to_label (c$system_job_name, #SIZE (system_label.system_job_name), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.system_job_name, element_p^);

      add_element_to_label (c$system_routing_text, #SIZE (system_label.system_routing_text), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.system_routing_text, element_p^);

      add_element_to_label (c$user_file_name, #SIZE (system_label.user_file_name), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.user_file_name, element_p^);

      add_element_to_label (c$user_information, #SIZE (system_label.user_information), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.user_information, element_p^);

      add_element_to_label (c$user_job_name, #SIZE (system_label.user_job_name), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.user_job_name, element_p^);

      add_element_to_label (c$vertical_print_density, #SIZE (system_label.vertical_print_density), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.vertical_print_density, element_p^);

      add_element_to_label (c$vfu_load_procedure, #SIZE (system_label.vfu_load_procedure), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.vfu_load_procedure, element_p^);

    PROCEND pack_standard_output_label;
?? OLDTITLE ??
?? EJECT ??
    status.normal := TRUE;

    fmp$get_jl_pointer (file_reference, {append} TRUE, output_label_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pack_standard_output_label (system_label, output_label_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fmp$put_jl_pointer (file_reference, write_label, output_label_p, status);
  PROCEND qfp$write_output_system_label;
?? NEWTITLE := '[XDCL, #GATE] qfp$write_qfile_system_label', EJECT ??
*copy qfh$write_qfile_system_label

  PROCEDURE [XDCL, #GATE] qfp$write_qfile_system_label
    (    file_reference: fst$file_reference;
         write_label: boolean;
         system_label: jmt$qfile_system_label;
         application_attributes_size: jmt$qsl_appl_attr_contents_size;
     VAR status: ost$status);

    VAR
      qfile_label_p: ^SEQ ( * );

?? NEWTITLE := 'pack_standard_qfile_label', EJECT ??

    PROCEDURE pack_standard_qfile_label
      (    system_label: jmt$qfile_system_label;
           application_attributes_size: jmt$qfile_appl_attr_size;
       VAR qfile_label_p {input} : ^SEQ ( * );
       VAR status: ost$status);

      VAR
        element_p: ^string ( * <= c$maximum_element_size),
        field_header_p: ^t$label_element_header;

?? NEWTITLE := '[INLINE] add_element_to_label', EJECT ??

{ NOTE:
{   The variable field_header_p is declared in the enclosing procedure for
{   performance reasons.  If it were placed in the add_element_to_label procedure
{   the dynamic space pointer (DSP) would be increased every time the inline
{   was called.

      PROCEDURE [INLINE] add_element_to_label
        (    element_identifier: t$element_identifier;
             element_size: t$element_size;
         VAR element_p: ^string ( * <= c$maximum_element_size);
         VAR status: ost$status);

        NEXT field_header_p IN qfile_label_p;
        IF field_header_p = NIL THEN
          osp$set_status_condition (jme$write_qfile_system_label, status);
          RETURN;
        IFEND;
        field_header_p^.element_size := element_size;
        field_header_p^.element_identifier := element_identifier;
        IF element_size > 0 THEN
          NEXT element_p: [element_size] IN qfile_label_p;
          IF element_p = NIL THEN
            osp$set_status_condition (jme$write_qfile_system_label, status);
            RETURN;
          IFEND;
        ELSE
          element_p := NIL;
        IFEND;
      PROCEND add_element_to_label;
?? OLDTITLE ??
?? EJECT ??

      status.normal := TRUE;

      RESET qfile_label_p;

      add_element_to_label (c$data_mode, #SIZE (system_label.data_mode), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.data_mode, element_p^);

      add_element_to_label (c$deferred_by_application, #SIZE (system_label.deferred_by_application),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.deferred_by_application, element_p^);

      add_element_to_label (c$destination, #SIZE (system_label.destination), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.destination, element_p^);

      add_element_to_label (c$disposition_time, #SIZE (system_label.disposition_time),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.disposition_time, element_p^);

      add_element_to_label (c$earliest_run_time, #SIZE (system_label.earliest_run_time), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.earliest_run_time, element_p^);

      add_element_to_label (c$latest_run_time, #SIZE (system_label.latest_run_time), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.latest_run_time, element_p^);

      add_element_to_label (c$application_name, #SIZE (system_label.application_name),
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.application_name, element_p^);

      add_element_to_label (c$purge_delay, #SIZE (system_label.purge_delay), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.purge_delay, element_p^);

      add_element_to_label (c$remote_host_directive, #SIZE (system_label.remote_host_directive), element_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.remote_host_directive, element_p^);

      add_element_to_label (c$system_file_name, #SIZE (system_label.system_file_name), element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.system_file_name, element_p^);

      add_element_to_label (c$application_attributes, application_attributes_size,
            element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #UNCHECKED_CONVERSION (system_label.application_attributes, element_p^);

    PROCEND pack_standard_qfile_label;
?? OLDTITLE ??
?? EJECT ??
    status.normal := TRUE;

    fmp$get_jl_pointer (file_reference, {append} TRUE, qfile_label_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET qfile_label_p;

    pack_standard_qfile_label (system_label, application_attributes_size, qfile_label_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fmp$put_jl_pointer (file_reference, write_label, qfile_label_p, status);
  PROCEND qfp$write_qfile_system_label;
?? OLDTITLE ??
MODEND jmm$system_label_access;
*DECK DECK=JMM$THE_STUBS EXPAND=TRUE

?? NEWTITLE := 'NOS/VE Job Scheduling : the_stubs' ??
MODULE jmm$the_stubs;

{ PURPOSE:
{   Simulate the behaviour of the ring 3 scheduling interfaces.
{
{ NOTES:
{   This deck is for testing purposes only and must have no 'osf$' library
{   in the deck header groups when in the source library.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_state
*copyc fst$file_reference
*copyc jmc$job_management_id
*copyc jmc$sched_profile_deadstart_id
*copyc jme$job_scheduler_conditions
*copyc jme$queued_file_conditions
*copyc jmt$application_attributes
*copyc jmt$application_index
*copyc jmt$application_name
*copyc jmt$application_set
*copyc jmt$application_table
*copyc jmt$class_kind
*copyc jmt$defined_classes
*copyc jmt$dispatching_control
*copyc jmt$job_category_data
*copyc jmt$job_class
*copyc jmt$job_class_attributes
*copyc jmt$job_class_set
*copyc jmt$job_class_statistics
*copyc jmt$job_class_table
*copyc jmt$job_scheduler_table
*copyc jmt$profile_header
*copyc jmt$profile_index_to_job_class
*copyc jmt$service_class_attributes
*copyc jmt$service_class_index
*copyc jmt$service_class_set
*copyc jmt$service_class_statistics
*copyc jmt$service_class_table
*copyc jmt$system_profile_cycle_number
*copyc jmt$system_supplied_name
*copyc osd$integer_limits
*copyc ost$binary_unique_name
*copyc ost$caller_identifier
*copyc ost$status
*copyc pme$program_services_exceptions
*copyc pmt$binary_mainframe_id
*copyc pmt$mainframe_id
*copyc pmt$processor_state
?? POP ??
*copyc amp$return
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc clp$convert_string_to_file
*copyc clp$get_variable
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc pfp$change
*copyc pfp$purge
*copyc pmp$abort
*copyc pmp$convert_mainframe_to_binary
*copyc pmp$generate_unique_name
*copyc pmp$get_job_names
*copyc pmp$get_mainframe_id
*copyc rmp$request_mass_storage
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    jmv$profile_index_to_job_class: [XDCL] jmt$profile_index_to_job_class;

{ *copyc jmc$system_scheduling_profile

  CONST
    jmc$scheduling_profile_family = osc$null_name,
    jmc$scheduling_profile_user = osc$null_name,
    jmc$scheduling_profile_catalog = 'SCHEDULING                     ',
    jmc$scheduling_profile_filename = 'OSF$SYSTEM_PROFILE             ',
    jmc$scheduling_profile_cycle = 2,
    jmc$scheduling_profile_pathname = '$USER.SCHEDULING.OSF$SYSTEM_PROFILE',
    jmc$scheduling_profile_path_siz = 35,
    jmc$scheduling_profile_password = osc$null_name;

  VAR
    utility_active: boolean := FALSE,
    path: array [1 .. 4] of pft$name := [jmc$scheduling_profile_family,
          jmc$scheduling_profile_user, jmc$scheduling_profile_catalog,
          jmc$scheduling_profile_filename],
    password: [STATIC] pft$password := ' ';

  VAR
    the_access_id: ost$binary_unique_name :=
          [1234, osc$cyber_180_model_835, 1987, 4, 29, 16, 33, 10, 1111, 0];

  TYPE
    maximums = record
      max_jc: integer,
      max_jci: integer,
      max_sc: integer,
      max_sci: integer,
      max_ap: integer,
      max_cat: integer,
    recend;

  VAR
    jobs_moved: integer := 5,
    the_max: maximums := [10, 10, 10, 10, 10, 65];

  VAR
    the_applications: ^jmt$application_table,
    the_job_classes: ^jmt$job_class_table,
    the_service_classes: ^jmt$service_class_table;

  VAR
    validation_list: array [1 .. 1] of jmt$mainframe_entry :=
          [['$SYSTEM_0855_0109', [030(16), 0109(10)], [], []]],
    the_controls: jmt$job_scheduler_table :=
          [10000, FALSE, 10, jmc$sched_profile_deadstart_id, 100,
          [REP 8 of [0, 100, FALSE]], 10, [[1, 8], [1, 8], [2, 8], [2, 8],
          [3, 8], [3, 8], [4, 8], [4, 8], [5, 8], [5, 8]], 1000, [], [],
          [100, 200], ^validation_list, 0];

  VAR
    jc_default: jmt$job_class_attributes := [TRUE, 0, 0, 'DEFAULT_JOB_CLASS',
          'default_job_class', ' ', NIL, NIL, TRUE, FALSE, 'NORMAL', 0, 200,
          [1000000000, 10000, 1000000000], [0, 0], [1000, 20, 2000],
          [20, 20, 1000], [10000, 10000, 1000000000], 1000000000,
          [18000, 18000, 18000], 0, 1000000000, FALSE, [], 0, [],
          1, 0, [300, 600, 1, 300]];

  VAR
    default_job_classes: array [1 .. 4] of jmt$job_class_attributes := [

{ 1

    [TRUE, 1, 1, 'JC_SYSTEM', 'SYSTEM', 'S', NIL, NIL, TRUE, FALSE, 'NORMAL',
          2, 80, [1000000000, 10000, 1000000000], [20, 20], [1000, 20, 2000],
          [20, 20, 1000], [10000, 10000, 1000000000], 1000000000,
          [18000, 18000, 18000], 0, 1000000000, FALSE, [], 0, [],
          1, 0, [700, 1000, 1, 700]],

{ 2

    [TRUE, 2, 2, 'JC_MAINTENANCE', 'MAINTENANCE', 'M', NIL, NIL, TRUE, TRUE,
          'NORMAL', 3, 65, [1000000000, 10000, 1000000000], [50, 0],
          [1000, 20, 2000], [20, 20, 1000], [10000, 10000, 1000000000],
          1000000000, [18000, 18000, 18000], 0, 1000000000, FALSE, [], 0, [],
          1, 0, [500, 700, 100, 500]],

{ 3

    [TRUE, 3, 3, 'JC_UNASSIGNED', 'UNASSIGNED', 'U', NIL, NIL, FALSE, FALSE,
          'NORMAL', 1, 800, [1000000000, 10000, 1000000000], [50, 0],
          [1000, 20, 2000], [20, 20, 1000], [10000, 10000, 1000000000],
          1000000000, [18000, 18000, 18000], 0, 1000000000, FALSE, [], 0, [],
          1, 0, [200, 250, 1, 200]],

{ 4

    [FALSE, 0, 0, 'BAD_JC', 'bad_jc', '-', NIL, NIL, TRUE, FALSE, 'NORMAL', 0,
          200, [1000000000, 10000, 1000000000], [0, 0], [1000, 20, 2000],
          [20, 20, 1000], [10000, 10000, 1000000000], 1000000000,
          [18000, 18000, 18000], 0, 1000000000, FALSE, [], 0, [],
          1, 0, [300, 600, 1, 300]]];

  VAR
    sc_default: jmt$service_class_attributes := [TRUE, 0,
          'DEFAULT_SERVICE_CLASS', 'default_service_class', ' ', 60000, 10000,
          6000, 0,50, 1, [1, 0, 0, 0], [[TRUE, 3, 1000, [10000, 10000000]],
          REP 4 of [FALSE, 0, 0, [0, 0]]], [100, 600, 100, 0], 1];

  VAR
    default_service_classes: array [1 .. 4] of
          jmt$service_class_attributes := [

{ 1

    [TRUE, 1, 'SC_SYSTEM', 'SYSTEM', 'S', 60000, 10000, 500, 0, 20, 2,
          [1, 0, 0, 0], [[TRUE, 3, 1000, [10000, 10000000]], REP 4 of
          [TRUE, 0, 0, [0, 0]]], [600, 1000, 100, 0], 1],

{ 2

    [TRUE, 2, 'SC_MAINTENANCE', 'MAINTENANCE', 'M', 60000, 10000, 1000, 0,
          100, 3, [1, 0, 0, 0], [[TRUE, 3, 1000, [10000, 10000000]], REP 4 of
          [TRUE, 0, 0, [0, 0]]], [200, 700, 100, 100], 1],

{ 3

    [TRUE, 3, 'SC_UNASSIGNED', 'UNASSIGNED', 'U', 60000, 10000, 100, 0,
          50, 1, [1, 0, 0, 0], [[TRUE, 1, 1000, [10000, 10000000]], REP 4 of
          [TRUE, 0, 0, [0, 0]]], [50, 250, 1, 0], 1],

{ 4

    [FALSE, 0, 'BAD_SC', 'bad_sc,', ' ', 60000, 10000, 6000, 0, 50, 1,
          [1, 0, 0, 0], [[TRUE, 3, 1000, [10000, 10000000]], REP 4 of
          [TRUE, 0, 0, [0, 0]]], [100, 600, 100, 0], 1]];

  VAR
    ap_default: jmt$application_attributes := [TRUE, 'DEFAULT_APPLICATION',
          'default_application', TRUE, 0, 0, 0, 0, 0];

  VAR
    default_applications: array [1 .. 1] of jmt$application_attributes := [
          { 1} [FALSE, 'NONE', 'name', TRUE, 0, 0, 0, 0, 0]];

  VAR
    jmv$job_category_data: jmt$job_category_data := [NIL, [REP 14 of []], NIL];

  VAR
    required_attributes: [STATIC] array [1 .. 3] of
          fst$file_cycle_attribute := [[fsc$file_contents_and_processor,
          'SCHEDULING_PROFILE', 'ADMINISTER_SCHEDULING'],
          [fsc$file_organization, amc$byte_addressable],
          [fsc$record_type, amc$undefined]];

  VAR
    base_file: string (20) := 'ACTIVE_PROFILE';

  VAR
    controls_p: ^jmt$job_scheduler_table,
    job_classes_p: ^jmt$job_class_table,
    service_classes_p: ^jmt$service_class_table,
    applications_p: ^jmt$application_table,
    category_data_p: ^jmt$job_category_data;

?? TITLE := 'initiated_jobs_in_job_class', EJECT ??

  FUNCTION initiated_jobs_in_job_class
    (    job_class_index: jmt$job_class): boolean;

    initiated_jobs_in_job_class := the_job_classes^ [job_class_index].
          enable_class_initiation AND (the_job_classes^ [job_class_index].
          initiation_level.preferred > 0);
    initiated_jobs_in_job_class := FALSE;

  FUNCEND initiated_jobs_in_job_class;

?? TITLE := 'jobs_in_service_class', EJECT ??

  FUNCTION jobs_in_service_class
    (    service_class_index: jmt$service_class_index): boolean;

{         This function will return a 'TRUE' value if there are jobs initiated
{         in the given service class.

    jobs_in_service_class := the_service_classes^ [service_class_index].
          maximum_active_jobs > 0;
    jobs_in_service_class := FALSE;

  FUNCEND jobs_in_service_class;
?? TITLE := 'jmp$verify_utility_access_id', EJECT ??

  PROCEDURE jmp$verify_utility_access_id
    (    access_id: ost$binary_unique_name;
     VAR status: ost$status);

    status.normal := TRUE;
    IF NOT utility_active THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$no_utility_is_active,
            '', status);
      RETURN;
    IFEND;

    IF access_id <> the_access_id THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$access_id_mismatch,
            '', status);
      RETURN;
    IFEND;
  PROCEND jmp$verify_utility_access_id;
?? TITLE := '[XDCL, #GATE] jmp$abort_deadstart', EJECT ??

*copyc jmh$abort_deadstart

  PROCEDURE [XDCL, #GATE] jmp$abort_deadstart
    (    display_message: string ( * );
         display_status: ost$status;
     VAR status: ost$status);

{  jme$must_be_system_job

    pmp$abort (display_status);

  PROCEND jmp$abort_deadstart;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$change_profile_cycle', EJECT ??
*copy jmh$change_profile_cycle

  PROCEDURE [XDCL, #GATE] jmp$change_profile_cycle
    (    access_id: ost$binary_unique_name;
     VAR status: ost$status);

    VAR
      change_list: array [1 .. 1] of pft$change_descriptor,
      file_cycle: pft$cycle_selector,
      local_access_id: ost$binary_unique_name,
      local_status: ost$status;

    status.normal := TRUE;
    local_access_id := access_id;
    jmp$verify_utility_access_id (local_access_id, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    file_cycle.cycle_option := pfc$specific_cycle;
    file_cycle.cycle_number := 1;

    change_list [1].change_type := pfc$cycle_number_change;
    change_list [1].cycle_number := 2;

    pfp$change (path, file_cycle, password, change_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND jmp$change_profile_cycle;
?? OLDTITLE ??
?? TITLE := '[XDCL, #GATE] jmp$clear_utility_active', EJECT ??

*copyc jmh$clear_utility_active

  PROCEDURE [XDCL, #GATE] jmp$clear_utility_active
    (    access_id: ost$binary_unique_name;
     VAR status: ost$status);

{       jme$must_be_scheduling_admin
{       jme$no_utility_is_active

    jmp$verify_utility_access_id (access_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    utility_active := FALSE;
    write_system_tables (status);
  PROCEND jmp$clear_utility_active;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$close_system_profile', EJECT ??
*copy jmh$close_system_profile

  PROCEDURE [XDCL, #GATE] jmp$close_system_profile
    (    access_id: ost$binary_unique_name;
         detach_file: boolean;
         file_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      local_access_id: ost$binary_unique_name,
      local_status: ost$status;

    local_access_id := access_id;
    jmp$verify_utility_access_id (local_access_id, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    fsp$close_file (file_identifier, status);

    IF status.normal AND detach_file THEN
      amp$return (jmc$scheduling_profile_pathname CAT '.1', status);
    IFEND;

  PROCEND jmp$close_system_profile;
?? TITLE := 'delete_classes', EJECT ??

  PROCEDURE delete_classes
    (    job_classes: jmt$job_class_set;
         service_classes: jmt$service_class_set;
         applications: jmt$application_set;
     VAR status: ost$status);

    VAR
      ai: jmt$application_index,
      am: jmt$application_index,
      jci: jmt$job_class,
      sci: jmt$service_class_index;

{            jme$class_or_appl_not_defined
{            jme$delete_class_still_active
{            jme$must_be scheduling_admin
{            jme$no_delete_of_default_class
{            jme$no_profile_is_loading
{            jme$no_utility_is_active

    FOR ai := 1 TO UPPERBOUND (the_applications^) DO
      IF ai IN applications THEN
        IF NOT the_applications^ [ai].defined THEN
          osp$set_status_abnormal (jmc$job_management_id,
                jme$class_or_appl_not_defined, 'Application', status);
          osp$append_status_integer (osc$status_parameter_delimiter, ai, 10,
                FALSE, status);
          RETURN;
        IFEND;
      IFEND;
    FOREND;

{  Delete job classes

    FOR jci := 1 TO UPPERBOUND (the_job_classes^) DO
      IF jci IN job_classes THEN { validity checked in check_installability
        the_job_classes^ [jci].defined := FALSE;
      IFEND;
    FOREND;

{  Delete service classes

    FOR sci := 1 TO UPPERBOUND (the_service_classes^) DO
      IF sci IN service_classes THEN { validity checked in check_installability
        the_service_classes^ [sci].defined := FALSE;
      IFEND;
    FOREND;

{   Remove references to deleted service classes from job classes.

    FOR jci := 1 TO UPPERBOUND (the_job_classes^) DO
      IF the_job_classes^ [jci].defined THEN
        IF the_service_classes^ [the_job_classes^ [jci].
              initial_service_class_index].defined THEN
          the_job_classes^ [jci].initial_service_class_index := 3;
        IFEND;
      IFEND;
    FOREND;

{   Remove references to deleted service classes from other service classes.

    FOR sci := 1 TO UPPERBOUND (the_service_classes^) DO
      IF the_service_classes^ [sci].defined THEN
        IF the_service_classes^ [sci].next_service_class_index > 0 THEN
          IF the_service_classes^ [the_service_classes^ [sci].
                next_service_class_index].defined THEN
            the_service_classes^ [sci].next_service_class_index := sci;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

{   Remove references to deleted service classes from applications

    am := 1;
    FOR ai := 1 TO UPPERBOUND (the_applications^) DO
      IF ai IN applications THEN
        the_applications^ [ai].defined := FALSE;
      ELSEIF the_applications^ [ai].defined THEN
        IF the_applications^ [ai].service_class_index > 0 THEN
          IF NOT the_service_classes^ [the_applications^ [ai].
                service_class_index].defined THEN
            the_applications^ [ai].service_class_index := 0;
          IFEND;
        IFEND;
        the_applications^ [am] := the_applications^ [ai];
        am := am + 1;
      IFEND;
    FOREND;

    FOR ai := am TO UPPERBOUND (the_applications^) DO
      the_applications^ [ai].defined := FALSE;
    FOREND;
  PROCEND delete_classes;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$delete_profile_cycle', EJECT ??
*copy jmh$delete_profile_cycle

  PROCEDURE [XDCL, #GATE] jmp$delete_profile_cycle
    (    access_id: ost$binary_unique_name;
         cycle_number: jmt$system_profile_cycle_number;
     VAR status: ost$status);

    VAR
      local_access_id: ost$binary_unique_name,
      local_status: ost$status;

    status.normal := TRUE;
    local_access_id := access_id;
    jmp$verify_utility_access_id (local_access_id, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    delete_profile_cycle (cycle_number, status);

  PROCEND jmp$delete_profile_cycle;
?? OLDTITLE ??
?? TITLE := '[XDCL, #GATE] jmp$get_application_record', EJECT ??

*copyc jmh$get_application_record

  PROCEDURE [XDCL, #GATE] jmp$get_application_record
    (    application_name: jmt$application_name;
     VAR application_record: jmt$application_attributes;
     VAR status: ost$status);

{         Return the attribute record for the given application name.

    VAR
      ai: jmt$application_index;

{            jme$class_or_appl_not_defined
{            jme$must_be_scheduling_admin

    osp$set_status_abnormal (jmc$job_management_id,
          jme$class_or_appl_not_defined, 'Application', status);
    osp$append_status_integer (osc$status_parameter_delimiter, ai, 10, FALSE,
          status);
    FOR ai := 1 TO UPPERBOUND (the_applications^) DO
      IF NOT the_applications^ [ai].defined THEN
        RETURN;
      IFEND;
      IF the_applications^ [ai].name = application_name THEN
        application_record := the_applications^ [ai];
        status.normal := TRUE;
        RETURN;
      IFEND;
    FOREND;

  PROCEND jmp$get_application_record;
?? TITLE := '[XDCL, #GATE] jmp$get_category_data', EJECT ??

*copyc jmh$get_category_data

  PROCEDURE [XDCL, #GATE] jmp$get_category_data
    (VAR category_data: jmt$job_category_data;
     VAR storage_p: ^SEQ ( * );
     VAR status: ost$status);

{             jme$must_be_scheduling_admin

    RESET storage_p;
    category_data := jmv$job_category_data;
    IF category_data.item_list <> NIL THEN
      NEXT category_data.item_list: [[REP #SIZE (category_data.item_list^) OF
            cell]] IN storage_p;
      category_data.item_list^ := jmv$job_category_data.item_list^;
    IFEND;
    IF category_data.category_names <> NIL THEN
      NEXT category_data.category_names: [0 .. UPPERBOUND (category_data.
            category_names^)] IN storage_p;
      category_data.category_names^ := jmv$job_category_data.category_names^;
    IFEND;
    status.normal := TRUE;

  PROCEND jmp$get_category_data;
?? TITLE := '[XDCL, #GATE] jmp$get_default_class_values', EJECT ??

*copyc jmh$get_default_class_values

  PROCEDURE [XDCL, #GATE] jmp$get_default_class_values
    (VAR job_class_defaults: jmt$job_class_attributes;
     VAR service_class_defaults: jmt$service_class_attributes;
     VAR application_defaults: jmt$application_attributes;
     VAR status: ost$status);

{         Return the default values for a job class, service class,
{         and application record.

    job_class_defaults := jc_default;
    service_class_defaults := sc_default;
    application_defaults := ap_default;
    status.normal := TRUE;

  PROCEND jmp$get_default_class_values;
?? TITLE := '[XDCL, #GATE] jmp$get_defined_classes', EJECT ??

*copyc jmh$get_defined_classes

  PROCEDURE [XDCL, #GATE] jmp$get_defined_classes
    (    class_kind: jmt$class_kind;
     VAR defined_classes: jmt$defined_classes;
     VAR number_of_classes: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      i: integer,
      j: integer;

{             jme$error_in_job_class_ranking
{             jme$must_be_scheduling_admin

    status.normal := TRUE;
    j := 0;
    CASE class_kind OF
    = jmc$job_class =
      i := the_job_classes^ [jmc$unassigned_job_class].next_rank_class;
      WHILE i <> 0 DO
        IF the_job_classes^ [i].defined THEN
          IF the_job_classes^ [i].automatic_class_selection THEN
            j := j + 1;
            defined_classes [j].name := the_job_classes^ [i].name;
            defined_classes [j].index := i;
          IFEND;
        IFEND;
        i := the_job_classes^ [i].next_rank_class;
      WHILEND;

      FOR i := 1 TO UPPERBOUND (the_job_classes^) DO
        IF the_job_classes^ [i].defined THEN
          IF NOT the_job_classes^ [i].automatic_class_selection THEN
            j := j + 1;
            defined_classes [j].name := the_job_classes^ [i].name;
            defined_classes [j].index := i;
          IFEND;
        IFEND;
      FOREND;

    = jmc$service_class =
      FOR i := 1 TO UPPERBOUND (the_service_classes^) DO
        IF the_service_classes^ [i].defined THEN
          j := j + 1;
          defined_classes [j].name := the_service_classes^ [i].name;
          defined_classes [j].index := i;
        IFEND;
      FOREND;

    = jmc$application =
      FOR i := 1 TO UPPERBOUND (the_applications^) DO
        IF the_applications^ [i].defined THEN
          j := j + 1;
          defined_classes [j].name := the_applications^ [i].name;
          defined_classes [j].index := i;
        IFEND;
      FOREND;
    CASEND;

    number_of_classes := j;
  PROCEND jmp$get_defined_classes;
?? TITLE := '[XDCL, #GATE] jmp$get_input_q_from_unassigned', EJECT ??

*copyc jmh$get_input_q_from_unassigned

  PROCEDURE [XDCL] jmp$get_input_q_from_unassigned
    (VAR system_supplied_names: array [1 .. * ] of jmt$system_supplied_name;
     VAR number_of_jobs_found: integer;
     VAR status: ost$status);

    VAR
      i: integer,
      j: integer,
      sjn: jmt$system_supplied_name,
      ujn: jmt$user_supplied_name,
      un: ost$unique_name;

    status.normal := TRUE;
    number_of_jobs_found := jobs_moved;
    IF UPPERBOUND (system_supplied_names) < number_of_jobs_found THEN
      osp$set_status_abnormal (jmc$job_management_id,
            jme$result_array_too_small, '', status);
      RETURN;
    IFEND;

    pmp$get_job_names (ujn, sjn, status);
    FOR i := 1 TO number_of_jobs_found DO
      pmp$generate_unique_name (un, status);
      system_supplied_names [i] := sjn;
      system_supplied_names [i] (16, 4) := un.sequence_number (3, 4);
    FOREND;

  PROCEND jmp$get_input_q_from_unassigned;
?? TITLE := '[XDCL, #GATE] jmp$get_job_class_record', EJECT ??

*copyc jmh$get_job_class_record

  PROCEDURE [XDCL, #GATE] jmp$get_job_class_record
    (    job_class_index: jmt$job_class;
     VAR job_class_record: jmt$job_class_attributes;
     VAR storage_p: ^SEQ ( * );
     VAR status: ost$status);

{             jme$class_or_appl_not_defined
{             jme$must_be_scheduling_admin

    RESET storage_p;

    IF NOT the_job_classes^ [job_class_index].defined THEN
      osp$set_status_abnormal (jmc$job_management_id,
            jme$class_or_appl_not_defined, 'Job Class', status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            job_class_index, 10, FALSE, status);
      RETURN;
    IFEND;

    job_class_record := the_job_classes^ [job_class_index];
    IF job_class_record.prolog_p <> NIL THEN
      NEXT job_class_record.prolog_p: [STRLENGTH (job_class_record.
            prolog_p^)] IN storage_p;
      job_class_record.prolog_p^ := the_job_classes^ [job_class_index].
            prolog_p^;
    IFEND;
    IF job_class_record.epilog_p <> NIL THEN
      NEXT job_class_record.epilog_p: [STRLENGTH (job_class_record.
            epilog_p^)] IN storage_p;
      job_class_record.epilog_p^ := the_job_classes^ [job_class_index].
            epilog_p^;
    IFEND;
    status.normal := TRUE;

  PROCEND jmp$get_job_class_record;
?? TITLE := '[XDCL, #GATE] jmp$get_job_class_statistics', EJECT ??

*copyc jmh$get_job_class_statistics

  PROCEDURE [XDCL, #GATE] jmp$get_job_class_statistics
    (    job_class_index: jmt$job_class;
     VAR job_class_statistics: jmt$job_class_statistics;
     VAR status: ost$status);

{             jme$class_or_appl_not_defined
{             jme$must_be_scheduling_admin

    IF NOT the_job_classes^ [job_class_index].defined THEN
      osp$set_status_abnormal (jmc$job_management_id,
            jme$class_or_appl_not_defined, 'Job Class', status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            job_class_index, 10, FALSE, status);
      RETURN;
    ELSE
      job_class_statistics.queued_jobs := job_class_index * 2;
      job_class_statistics.initiated_jobs := job_class_index + 10;
    IFEND;
    status.normal := TRUE;

  PROCEND jmp$get_job_class_statistics;
?? TITLE := '[XDCL, #GATE] jmp$get_length_of_sched_tables', EJECT ??

*copyc jmh$get_length_of_sched_tables

  PROCEDURE [XDCL, #GATE] jmp$get_length_of_sched_tables
    (VAR maximum_job_classes: jmt$job_class;
     VAR maximum_job_class_index: jmt$job_class;
     VAR maximum_service_classes: jmt$service_class_index;
     VAR maximum_service_class_index: jmt$service_class_index;
     VAR maximum_applications: jmt$application_index;
     VAR maximum_categories: integer;
     VAR status: ost$status);

{             jme$must_be_scheduling_admin

    maximum_job_classes := the_max.max_jc;
    maximum_service_classes := the_max.max_sc;
    maximum_applications := the_max.max_ap;
    maximum_job_class_index := the_max.max_jci;
    maximum_service_class_index := the_max.max_sci;
    maximum_categories := 64;
    status.normal := TRUE;

  PROCEND jmp$get_length_of_sched_tables;
?? TITLE := '[XDCL, #GATE] jmp$get_scheduler_table', EJECT ??

*copyc jmh$get_scheduler_table

  PROCEDURE [XDCL, #GATE] jmp$get_scheduler_table
    (VAR scheduler_table: jmt$job_scheduler_table;
     VAR data_p: ^SEQ ( * );
     VAR status: ost$status);

{             jme$must_be_scheduling_admin

    VAR
      mainframe_id: pmt$mainframe_id;

    status.normal := TRUE;
    scheduler_table := the_controls;
    RESET data_p;
    NEXT scheduler_table.validation_categories_p:
          [1 .. UPPERBOUND (the_controls.validation_categories_p^)] IN data_p;
    scheduler_table.validation_categories_p^ :=
          the_controls.validation_categories_p^;
    IF scheduler_table.profile_identification =
          jmc$sched_profile_deadstart_id THEN
      pmp$get_mainframe_id (mainframe_id, status);
      IF status.normal THEN
        scheduler_table.validation_categories_p^ [1].mainframe_id :=
              mainframe_id;
        pmp$convert_mainframe_to_binary (mainframe_id,
              scheduler_table.validation_categories_p^ [1].binary_mainframe_id,
              status);
      IFEND;
    IFEND;

  PROCEND jmp$get_scheduler_table;
?? TITLE := '[XDCL, #GATE] jmp$get_service_class_record', EJECT ??

*copyc jmh$get_service_class_record

  PROCEDURE [XDCL, #GATE] jmp$get_service_class_record
    (    service_class_index: jmt$service_class_index;
     VAR service_class_record: jmt$service_class_attributes;
     VAR status: ost$status);

{             jme$class_or_appl_not_defined
{             jme$must_be_scheduling_admin

    IF NOT the_service_classes^ [service_class_index].defined THEN
      osp$set_status_abnormal (jmc$job_management_id,
            jme$class_or_appl_not_defined, 'Service Class', status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            service_class_index, 10, FALSE, status);
      RETURN;
    IFEND;

    service_class_record := the_service_classes^ [service_class_index];
    status.normal := TRUE;

  PROCEND jmp$get_service_class_record;
?? TITLE := '[XDCL, #GATE] jmp$get_service_class_stats', EJECT ??

*copyc jmh$get_service_class_stats

  PROCEDURE [XDCL, #GATE] jmp$get_service_class_stats
    (    service_class_index: jmt$service_class_index;
     VAR service_class_statistics: jmt$service_class_statistics;
     VAR status: ost$status);

{             jme$class_or_appl_not_defined
{             jme$must_be_scheduling_admin

    IF NOT the_service_classes^ [service_class_index].defined THEN
      osp$set_status_abnormal (jmc$job_management_id,
            jme$class_or_appl_not_defined, 'Service Class', status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            service_class_index, 10, FALSE, status);
      RETURN;
    IFEND;
    status.normal := TRUE;
    service_class_statistics.active_jobs := service_class_index + 5;
    service_class_statistics.queued_jobs := service_class_index * 2;
    service_class_statistics.swapped_jobs := service_class_index + 1;

  PROCEND jmp$get_service_class_stats;
?? TITLE := 'delete_profile_cycle', EJECT ??

{ PURPOSE:
{   Deletes the specified cycle of the system profile file.

  PROCEDURE delete_profile_cycle
    (    cycle_number: pft$cycle_number;
     VAR status: ost$status);

    VAR
      the_cycle: pft$cycle_selector;

    the_cycle.cycle_option := pfc$specific_cycle;
    the_cycle.cycle_number := cycle_number;

    pfp$purge (path, the_cycle, password, status);
    IF NOT status.normal AND (status.condition = pfe$unknown_cycle) THEN
      status.normal := TRUE;
    IFEND;

  PROCEND delete_profile_cycle;
?? TITLE := 'move_jobs', EJECT ??

{ PURPOSE:
{   This request moves jobs from the specified job classes into the
{   UNASSIGNED job class.

  PROCEDURE move_jobs
    (    move_job_classes: jmt$job_class_set;
     VAR status: ost$status);

    VAR
      count: integer,
      jci: jmt$job_class;

{             jme$not_all_jobs_were_moved

    jobs_moved := 0;
    FOR jci := 1 TO UPPERBOUND (the_job_classes^) DO
      IF jci IN move_job_classes THEN
        jmp$move_input_q_to_unassigned (jci, count, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;
  PROCEND move_jobs;
?? TITLE := '[XDCL, #GATE] jmp$install_profile', EJECT ??

*copyc jmh$install_profile

  PROCEDURE [XDCL, #GATE] jmp$install_profile
    (    access_id: ost$binary_unique_name;
         job_class_entries_p: ^jmt$job_class_table;
         service_class_entries_p: ^jmt$service_class_table;
         application_entries_p: ^jmt$application_table;
         controls_entry: jmt$job_scheduler_table;
         category_data: jmt$job_category_data;
         move_job_classes: jmt$job_class_set;
         deleted_job_classes: jmt$job_class_set;
         deleted_service_classes: jmt$service_class_set;
         deleted_applications: jmt$application_set;
         delete_profile_cycle2: boolean;
     VAR status: ost$status);

    VAR
      local_status: ost$status;

{             jme$access_id_mismatch
{             jme$applications_not_sorted
{             jme$class_abbrev_not_unique
{             jme$class_index_already_in_use
{             jme$class_or_appl_not_defined
{             jme$class_or_appl_not_unique
{             jme$delete_class_still_active
{             jme$excess_class_in_sched_table
{             jme$must_be_scheduling_admin
{             jme$not_all_jobs_were_moved
{             jme$no_delete_of_default_class
{             jme$no_utility_is_active
{             jme$profile_cycle2_lost
{             jme$profile_not_installed
{             jme$profile_too_large

    jmp$verify_utility_access_id (access_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    verify_profile (job_class_entries_p, service_class_entries_p,
          application_entries_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    check_installability (deleted_job_classes, deleted_service_classes,
          job_class_entries_p, service_class_entries_p, application_entries_p,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$set_sched_profile_loading (TRUE, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    move_jobs (move_job_classes, status);
    IF NOT status.normal THEN
      jmp$set_sched_profile_loading (FALSE, local_status);
      RETURN;
    IFEND;

    delete_classes (deleted_job_classes, deleted_service_classes,
          deleted_applications, status);

    IF delete_profile_cycle2 THEN
      delete_profile_cycle (2, status);
    IFEND;

    install_profile (job_class_entries_p, service_class_entries_p,
          application_entries_p, controls_entry, category_data, status);

    jmp$set_sched_profile_loading (FALSE, local_status);

  PROCEND jmp$install_profile;

?? TITLE := 'install_profile', EJECT ??

  PROCEDURE install_profile
    (    job_classes_p: ^jmt$job_class_table;
         service_classes_p: ^jmt$service_class_table;
         applications_p: ^jmt$application_table;
         controls: jmt$job_scheduler_table;
         categories: jmt$job_category_data;
     VAR status: ost$status);

    VAR
      ai: jmt$application_index,
      an: jmt$application_name,
      first_ranked_class: integer,
      i: integer,
      jci: jmt$job_class,
      sci: jmt$service_class_index;

{             jme$applications_not_sorted
{             jme$class_abbrev_not_unique
{             jme$class_index_already_in_use
{             jme$class_or_appl_not_defined
{             jme$class_or_appl_not_unique
{             jme$excess_class_in_sched_table
{             jme$profile_not_installed
{             jme$profile_too_large

    FOR i := 1 TO UPPERBOUND (service_classes_p^) DO
      sci := service_classes_p^ [i].index;
      the_service_classes^ [sci] := service_classes_p^ [i];
    FOREND;

    the_job_classes^ [jmc$unassigned_job_class].next_rank_class := 0;
    first_ranked_class := 0;
    FOR i := UPPERBOUND (job_classes_p^) DOWNTO 1 DO
      jci := job_classes_p^ [i].index;
      IF the_job_classes^ [jci].prolog_p <> NIL THEN
        FREE the_job_classes^ [jci].prolog_p;
      IFEND;
      IF the_job_classes^ [jci].epilog_p <> NIL THEN
        FREE the_job_classes^ [jci].epilog_p;
      IFEND;
      the_job_classes^ [jci] := job_classes_p^ [i];
      jmv$profile_index_to_job_class [job_classes_p^ [i].profile_index] := jci;
      IF the_job_classes^ [jci].prolog_p <> NIL THEN
        ALLOCATE the_job_classes^ [jci].prolog_p:
              [STRLENGTH (the_job_classes^ [jci].prolog_p^)];
        the_job_classes^ [jci].prolog_p^ := job_classes_p^ [i].prolog_p^;
      IFEND;
      IF the_job_classes^ [jci].epilog_p <> NIL THEN
        ALLOCATE the_job_classes^ [jci].epilog_p:
              [STRLENGTH (the_job_classes^ [jci].epilog_p^)];
        the_job_classes^ [jci].epilog_p^ := job_classes_p^ [i].epilog_p^;
      IFEND;
      IF the_job_classes^ [jci].automatic_class_selection THEN
        the_job_classes^ [jci].next_rank_class := first_ranked_class;
        first_ranked_class := jci;
      ELSE
        the_job_classes^ [jci].next_rank_class := 0;
      IFEND;
    FOREND;
    the_job_classes^ [jmc$unassigned_job_class].next_rank_class :=
          first_ranked_class;

{         - reallocate the valid_categories array of the controls table

{         - reallocate the applications table and store the applications
{           in ascending order

    FOR ai := 1 TO UPPERBOUND (the_applications^) DO
      the_applications^ [ai].defined := FALSE;
    FOREND;

    IF applications_p <> NIL THEN
      FOR ai := 1 TO UPPERBOUND (applications_p^) DO
        the_applications^ [ai] := applications_p^ [ai];
      FOREND;
    IFEND;

    IF jmv$job_category_data.item_list <> NIL THEN
      FREE jmv$job_category_data.item_list;
      jmv$job_category_data.item_list := NIL;
    IFEND;

    IF jmv$job_category_data.category_names <> NIL THEN
      FREE jmv$job_category_data.category_names;
      jmv$job_category_data.category_names := NIL;
    IFEND;

    jmv$job_category_data := categories;
    IF categories.item_list <> NIL THEN
      ALLOCATE jmv$job_category_data.item_list:
            [[REP #SIZE (categories.item_list^) OF cell]];
      jmv$job_category_data.item_list^ := categories.item_list^;
    IFEND;

    IF categories.category_names <> NIL THEN
      ALLOCATE jmv$job_category_data.category_names:
            [0 .. UPPERBOUND (categories.category_names^)];
      jmv$job_category_data.category_names^ := categories.category_names^;
    IFEND;

    FREE the_controls.validation_categories_p;

    the_controls := controls;

    ALLOCATE the_controls.validation_categories_p:
          [1 .. UPPERBOUND (controls.validation_categories_p^)];
    the_controls.validation_categories_p^ := controls.validation_categories_p^;
  PROCEND install_profile;

?? TITLE := 'verify_profile', EJECT ??

  PROCEDURE verify_profile
    (    job_classes_p: ^jmt$job_class_table;
         service_classes_p: ^jmt$service_class_table;
         applications_p: ^jmt$application_table;
     VAR status: ost$status);

    VAR
      ai: jmt$application_index,
      i: integer,
      jci: jmt$job_class,
      sci: jmt$service_class_index;

{   IF the_max.max_jc < UPPERBOUND (job_classes_p^) THEN
{     osp$set_status_abnormal (jmc$job_management_id, jme$profile_too_large,
{           'Maximum job classes', status);
{     osp$append_status_integer (osc$status_parameter_delimiter,
{     the_max.max_jc,
{           10, FALSE, status);
{     RETURN;
{   ELSEIF the_max.max_sc < UPPERBOUND (service_classes_p^) THEN
{     osp$set_status_abnormal (jmc$job_management_id, jme$profile_too_large,
{           'Maximum Service classes', status);
{     osp$append_status_integer (osc$status_parameter_delimiter,
{     the_max.max_sc,
{           10, FALSE, status);
{     RETURN;
{   IFEND;

    FOR i := 1 TO UPPERBOUND (service_classes_p^) DO
      sci := service_classes_p^ [i].index;
      IF sci > the_max.max_sci THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$profile_too_large,
              'Maximum service class index', status);
        osp$append_status_integer (osc$status_parameter_delimiter, sci, 10,
              FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              the_max.max_sci, 10, FALSE, status);
        RETURN;
      IFEND;
    FOREND;

    FOR i := UPPERBOUND (job_classes_p^) DOWNTO 1 DO
      jci := job_classes_p^ [i].index;
      IF jci > the_max.max_jci THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$profile_too_large,
              'Maximum job class index', status);
        osp$append_status_integer (osc$status_parameter_delimiter, jci, 10,
              FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              the_max.max_jci, 10, FALSE, status);
        RETURN;
      IFEND;
    FOREND;

    IF applications_p <> NIL THEN
      IF the_max.max_ap < UPPERBOUND (applications_p^) THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$profile_too_large,
              'Applications', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              UPPERBOUND (applications_p^), 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              the_max.max_ap, 10, FALSE, status);
        RETURN;
      IFEND;
    IFEND;

    status.normal := TRUE;

  PROCEND verify_profile;
?? TITLE := 'check_installability', EJECT ??

{ PURPOSE:
{   This routine checks for active jobs in the deleted job and service classes.

  PROCEDURE check_installability
    (    deleted_job_classes: jmt$job_class_set;
         deleted_service_classes: jmt$service_class_set;
         job_classes_p: ^jmt$job_class_table;
         service_classes_p: ^jmt$service_class_table;
         applications_p: ^jmt$application_table;
     VAR status: ost$status);

    VAR
      ai: jmt$application_index,
      an: jmt$application_name,
      first_ranked_class: integer,
      i: integer,
      jci: jmt$job_class,
      sci: jmt$service_class_index;

{             jme$applications_not_sorted
{             jme$class_abbrev_not_unique
{             jme$class_index_already_in_use
{             jme$class_or_appl_not_defined
{             jme$class_or_appl_not_unique
{             jme$excess_class_in_sched_table
{             jme$profile_not_installed
{             jme$profile_too_large

    status.normal := TRUE;

    FOR sci := 1 TO UPPERBOUND (the_service_classes^) DO
      IF sci IN deleted_service_classes THEN
        IF NOT the_service_classes^ [sci].defined THEN
          osp$set_status_abnormal (jmc$job_management_id,
                jme$class_or_appl_not_defined, 'Service Class', status);
          osp$append_status_integer (osc$status_parameter_delimiter, sci, 10,
                FALSE, status);
          RETURN;
        ELSEIF sci < 4 THEN
          osp$set_status_abnormal (jmc$job_management_id,
                jme$no_delete_of_default_class, 'Service Class', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                the_service_classes^ [sci].name, status);
          RETURN;
        ELSEIF jobs_in_service_class (sci) THEN
          osp$set_status_abnormal (jmc$job_management_id,
                jme$delete_class_still_active, 'Service Class', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                the_service_classes^ [sci].name, status);
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    FOR i := 1 TO UPPERBOUND (service_classes_p^) DO
      sci := service_classes_p^ [i].index;
      IF NOT (sci IN deleted_service_classes) AND
            the_service_classes^ [sci].defined THEN
        IF the_service_classes^ [sci].name <> service_classes_p^ [i].name THEN
          osp$set_status_abnormal (jmc$job_management_id,
                jme$class_index_already_in_use, 'Service Class', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                the_service_classes^ [sci].name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, sci, 10,
                FALSE, status);
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    FOR jci := 1 TO UPPERBOUND (the_job_classes^) DO
      IF jci IN deleted_job_classes THEN
        IF NOT the_job_classes^ [jci].defined THEN
          osp$set_status_abnormal (jmc$job_management_id,
                jme$class_or_appl_not_defined, 'Job Class', status);
          osp$append_status_integer (osc$status_parameter_delimiter, jci, 10,
                FALSE, status);
          RETURN;
        ELSEIF jci < 4 THEN
          osp$set_status_abnormal (jmc$job_management_id,
                jme$no_delete_of_default_class, 'Job Class', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                the_job_classes^ [jci].name, status);
          RETURN;
        ELSEIF initiated_jobs_in_job_class (jci) THEN
          osp$set_status_abnormal (jmc$job_management_id,
                jme$delete_class_still_active, 'Job Class', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                the_job_classes^ [jci].name, status);
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    FOR i := UPPERBOUND (job_classes_p^) DOWNTO 1 DO
      jci := job_classes_p^ [i].index;
      IF NOT (jci IN deleted_job_classes) AND the_job_classes^ [jci].
            defined THEN
        IF (the_job_classes^ [jci].name <> job_classes_p^ [i].name) THEN
          osp$set_status_abnormal (jmc$job_management_id,
                jme$class_index_already_in_use, 'Job Class', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                the_job_classes^ [jci].name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, sci, 10,
                FALSE, status);
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    IF applications_p <> NIL THEN
      an := osc$null_name;
      FOR ai := 1 TO UPPERBOUND (applications_p^) DO
        IF applications_p^ [ai].name < an THEN
          osp$set_status_abnormal (jmc$job_management_id,
                jme$applications_not_sorted, applications_p^ [ai].name,
                status);
          RETURN;
        IFEND;
        an := applications_p^ [ai].name;
      FOREND;
    IFEND;

  PROCEND check_installability;
?? TITLE := 'jmp$move_input_q_to_unassigned', EJECT ??

  PROCEDURE jmp$move_input_q_to_unassigned
    (    job_class_index: jmt$job_class;
     VAR number_of_jobs: integer;
     VAR status: ost$status);

{             jme$class_or_appl_not_defined
{             jme$must_be_scheduling_admin
{             jme$not_all_jobs_were_moved

    IF NOT the_job_classes^ [job_class_index].defined THEN
      osp$set_status_abnormal (jmc$job_management_id,
            jme$class_or_appl_not_defined, 'Job Class', status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            job_class_index, 10, FALSE, status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    number_of_jobs := job_class_index * 2;
    jobs_moved := jobs_moved + number_of_jobs;

  PROCEND jmp$move_input_q_to_unassigned;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$open_system_profile', EJECT ??
*copy jmh$open_system_profile

  PROCEDURE [XDCL, #GATE] jmp$open_system_profile
    (    access_id: ost$binary_unique_name;
         cycle_number: jmt$system_profile_cycle_number;
         open_for_write: boolean;
         validation_attributes_p: ^fst$file_cycle_attributes;
     VAR file_identifier: amt$file_identifier;
     VAR status: ost$status);

    CONST
      path_size = jmc$scheduling_profile_path_siz + 2;

    VAR
      attachment_options_p: ^fst$attachment_options,
      attribute_override_p: ^fst$file_cycle_attributes,
      caller_id: ost$caller_identifier,
      file_path: string (path_size),
      local_access_id: ost$binary_unique_name,
      local_status: ost$status;

    status.normal := TRUE;
    local_access_id := access_id;
    jmp$verify_utility_access_id (local_access_id, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    #CALLER_ID (caller_id);

    file_path := jmc$scheduling_profile_pathname CAT '.1';
    IF cycle_number = 2 THEN
      file_path (path_size) := '2';
    IFEND;

{ Attach the file for read access and open the file with the rings of the
{ caller

    PUSH attribute_override_p: [1 .. 1];
    attribute_override_p^ [1].selector := fsc$ring_attributes;
    attribute_override_p^ [1].ring_attributes.r1 := osc$tsrv_ring;
    attribute_override_p^ [1].ring_attributes.r2 := caller_id.ring;
    attribute_override_p^ [1].ring_attributes.r3 := caller_id.ring;
    attribute_override_p := NIL;

    PUSH attachment_options_p: [1 .. 3];
    attachment_options_p^ [1].selector := fsc$access_and_share_modes;
    attachment_options_p^ [1].access_modes.selector :=
          fsc$specific_access_modes;
    attachment_options_p^ [1].access_modes.value :=
          $fst$file_access_options [fsc$read];
    attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options_p^ [1].share_modes.value :=
          $fst$file_access_options [fsc$read];
    attachment_options_p^ [2].selector := fsc$open_position;
    attachment_options_p^ [2].open_position := amc$open_at_boi;
    attachment_options_p^ [3].selector := fsc$create_file;
    attachment_options_p^ [3].create_file := FALSE;

    IF open_for_write THEN
      attachment_options_p^ [1].access_modes.value :=
            $fst$file_access_options [fsc$read, fsc$append, fsc$modify,
            fsc$shorten];
      attachment_options_p^ [3].create_file := TRUE;
      rmp$request_mass_storage (file_path, rmc$unspecified_allocation_size,
            rmc$unspecified_file_size, rmc$unspecified_file_class,
            rmc$unspecified_vsn, {volume_overflow_allowed =} TRUE, status);
    IFEND;
    IF status.normal THEN
      fsp$open_file (file_path, amc$segment, attachment_options_p, NIL,
            validation_attributes_p, validation_attributes_p,
            attribute_override_p, file_identifier, status);
    IFEND;

  PROCEND jmp$open_system_profile;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$reactivate_job_leveling' ??
*copyc jmh$reactivate_job_leveling

  PROCEDURE [XDCL, #GATE] jmp$reactivate_job_leveling
    (    access_id: ost$binary_unique_name;
     VAR status: ost$status);

    jmp$verify_utility_access_id (access_id, status);

  PROCEND jmp$reactivate_job_leveling;
?? TITLE := '[XDCL, #GATE] jmp$resubmit_queued_input_job', EJECT ??

*copyc jmh$resubmit_queued_input_job

  PROCEDURE [XDCL, #GATE] jmp$resubmit_queued_input_job
    (    system_supplied_name: jmt$system_supplied_name;
     VAR status: ost$status);

{             jme$job_class_must_be_disabled
{             jme$job_is_in_termination
{             jme$name_not_found

    status.normal := TRUE;
    IF system_supplied_name (18, 2) < '05' THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$invalid_job_class,
            '', status);
    IFEND;
    jobs_moved := 0;

  PROCEND jmp$resubmit_queued_input_job;
?? TITLE := 'jmp$set_sched_profile_loading', EJECT ??

  PROCEDURE jmp$set_sched_profile_loading
    (    profile_is_loading: boolean;
     VAR status: ost$status);

{             jme$must_be_scheduling_admin

    status.normal := TRUE;

  PROCEND jmp$set_sched_profile_loading;
?? TITLE := '[XDCL, #GATE] jmp$set_utility_active', EJECT ??

*copyc jmh$set_utility_active

  PROCEDURE [XDCL, #GATE] jmp$set_utility_active
    (VAR access_id: ost$binary_unique_name;
     VAR status: ost$status);

{             jme$another_utility_is_active
{             jme$must_be_scheduling_admin

    status.normal := TRUE;
    IF utility_active THEN
      osp$set_status_abnormal (jmc$job_management_id,
            jme$another_utility_is_active, '', status);
      RETURN;
    IFEND;
    utility_active := TRUE;

    read_system_tables (status);
    IF status.normal THEN
      access_id := the_access_id;
    IFEND;
  PROCEND jmp$set_utility_active;
?? TITLE := '[XDCL, #GATE] jmp$update_profile', EJECT ??

*copyc jmh$update_profile

  PROCEDURE [XDCL, #GATE] jmp$update_profile
    (    access_id: ost$binary_unique_name;
         changed_job_classes_p: ^jmt$job_class_table;
         changed_service_classes_p: ^jmt$service_class_table;
         changed_applications_p: ^jmt$application_table;
         controls_p: ^jmt$job_scheduler_table;
     VAR status: ost$status);

    VAR
      ai: jmt$application_index,
      i: integer,
      jci: jmt$job_class,
      nrc: integer,
      sci: jmt$service_class_index;

{             jme$access_id_mismatch
{             jme$class_index_conflict
{             jme$class_or_appl_not_defined
{             jme$must_be_scheduling_admin
{             jme$no_utility_is_active

    jmp$verify_utility_access_id (access_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF changed_service_classes_p <> NIL THEN
      FOR i := 1 TO UPPERBOUND (changed_service_classes_p^) DO
        sci := changed_service_classes_p^ [i].index;
        IF NOT the_service_classes^ [sci].defined THEN
          osp$set_status_abnormal (jmc$job_management_id,
                jme$class_or_appl_not_defined, 'Service Class', status);
          osp$append_status_integer (osc$status_parameter_delimiter, sci, 10,
                FALSE, status);
          RETURN;
        IFEND;
        IF the_service_classes^ [sci].profile_identification <>
              changed_service_classes_p^ [i].profile_identification THEN
          osp$set_status_abnormal (jmc$job_management_id,
                jme$class_index_conflict, 'Job Class', status);
          RETURN;
        IFEND;
        the_service_classes^ [sci] := changed_service_classes_p^ [i];
      FOREND;
    IFEND;

    IF changed_job_classes_p <> NIL THEN
      FOR i := 1 TO UPPERBOUND (changed_job_classes_p^) DO
        jci := changed_job_classes_p^ [i].index;
        IF NOT the_job_classes^ [jci].defined THEN
          osp$set_status_abnormal (jmc$job_management_id,
                jme$class_or_appl_not_defined, 'Job Class', status);
          osp$append_status_integer (osc$status_parameter_delimiter, jci, 10,
                FALSE, status);
          RETURN;
        IFEND;
        IF the_job_classes^ [jci].profile_identification <>
              changed_job_classes_p^ [i].profile_identification THEN
          osp$set_status_abnormal (jmc$job_management_id,
                jme$class_index_conflict, 'Job Class', status);
          RETURN;
        IFEND;
        IF the_job_classes^ [jci].prolog_p <> NIL THEN
          FREE the_job_classes^ [jci].prolog_p;
        IFEND;
        IF the_job_classes^ [jci].epilog_p <> NIL THEN
          FREE the_job_classes^ [jci].epilog_p;
        IFEND;
        nrc := the_job_classes^ [jci].next_rank_class;
        the_job_classes^ [jci] := changed_job_classes_p^ [i];
        the_job_classes^ [jci].next_rank_class := nrc;
        IF the_job_classes^ [jci].prolog_p <> NIL THEN
          ALLOCATE the_job_classes^ [jci].prolog_p:
                [STRLENGTH (the_job_classes^ [jci].prolog_p^)];
          the_job_classes^ [jci].prolog_p^ :=
                changed_job_classes_p^ [i].prolog_p^;
        IFEND;
        IF the_job_classes^ [jci].epilog_p <> NIL THEN
          ALLOCATE the_job_classes^ [jci].epilog_p:
                [STRLENGTH (the_job_classes^ [jci].epilog_p^)];
          the_job_classes^ [jci].epilog_p^ :=
                changed_job_classes_p^ [i].epilog_p^;
        IFEND;
      FOREND;
    IFEND;

    IF changed_applications_p <> NIL THEN

    /next_application/
      FOR i := 1 TO UPPERBOUND (changed_applications_p^) DO
        FOR ai := 1 TO UPPERBOUND (the_applications^) DO
          IF the_applications^ [ai].name = changed_applications_p^ [i].
                name THEN
            the_applications^ [ai] := changed_applications_p^ [i];
            CYCLE /next_application/;
          IFEND;
        FOREND;
        osp$set_status_abnormal (jmc$job_management_id,
              jme$class_index_conflict, 'Applications', status);
        RETURN;
      FOREND /next_application/;
    IFEND;

    IF controls_p <> NIL THEN
      the_controls.enable_job_leveling := controls_p^.enable_job_leveling;
      the_controls.job_leveling_interval := controls_p^.job_leveling_interval;
      the_controls.service_calculation_interval :=
            controls_p^.service_calculation_interval;
      the_controls.idle_dispatching_queue_time :=
            controls_p^.idle_dispatching_queue_time;
      the_controls.scheduling_memory_levels :=
            controls_p^.scheduling_memory_levels;
      the_controls.initiation_required_categories :=
            controls_p^.initiation_required_categories;
      the_controls.initiation_excluded_categories :=
            controls_p^.initiation_excluded_categories;
      the_controls.job_leveling_priority_bias :=
            controls_p^.job_leveling_priority_bias;
    IFEND;
  PROCEND jmp$update_profile;
?? TITLE := 'read_system_tables', EJECT ??

  PROCEDURE read_system_tables
    (VAR status: ost$status);

    VAR
      read_attachment: [STATIC] array [1 .. 2] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes,
            [fsc$read]], [fsc$specific_share_modes, []]],
            [fsc$open_position, amc$open_at_boi]];

    VAR
      fid: amt$file_identifier,
      local_status: ost$status,
      seg_ptr: amt$segment_pointer,
      the_seq: ^SEQ ( * );

    VAR
      cd: jmt$job_category_data,
      epilog_p: ^fst$file_reference,
      i: integer,
      j: integer,
      k: integer,
      prolog_p: ^fst$file_reference,
      the_header: jmt$profile_header,
      tm: ^maximums,
      validation_categories: ^jmt$mainframe_categories;

    VAR
      access_mode: clt$data_access_mode,
      class: clt$variable_class,
      evaluation_method: clt$expression_eval_method,
      type_specification: ^clt$type_specification,
      value: ^clt$data_value,
      work_area: ^clt$work_area;

  /read_file/
    BEGIN

      fsp$open_file (base_file, amc$segment, ^read_attachment, NIL, NIL,
            ^required_attributes, NIL, fid, status);
      IF NOT status.normal THEN
        EXIT /read_file/;
      IFEND;

      amp$get_segment_pointer (fid, amc$sequence_pointer, seg_ptr, status);
      IF NOT status.normal THEN
        EXIT /read_file/;
      IFEND;
      RESET seg_ptr.sequence_pointer;
      the_seq := seg_ptr.sequence_pointer;

      NEXT tm IN the_seq;
      the_max := tm^;

      NEXT controls_p IN the_seq;
      the_controls := controls_p^;

      NEXT validation_categories: [1 .. UPPERBOUND (the_controls.
            validation_categories_p^)] IN the_seq;
      ALLOCATE the_controls.validation_categories_p:
            [1 .. UPPERBOUND (validation_categories^)];
      the_controls.validation_categories_p^ := validation_categories^;

      NEXT job_classes_p: [1 .. the_max.max_jci] IN the_seq;
      NEXT service_classes_p: [1 .. the_max.max_sci] IN the_seq;
      NEXT applications_p: [1 .. the_max.max_ap] IN the_seq;

      ALLOCATE the_job_classes: [1 .. the_max.max_jci];
      ALLOCATE the_service_classes: [1 .. the_max.max_sci];
      ALLOCATE the_applications: [1 .. the_max.max_ap];

      the_job_classes^ := job_classes_p^;
      the_service_classes^ := service_classes_p^;
      the_applications^ := applications_p^;

      FOR i := 1 TO UPPERBOUND (the_job_classes^) DO
        IF the_job_classes^ [i].defined THEN
          prolog_p := the_job_classes^ [i].prolog_p;
          IF prolog_p <> NIL THEN
            NEXT prolog_p: [STRLENGTH (prolog_p^)] IN the_seq;
            ALLOCATE the_job_classes^ [i].prolog_p: [STRLENGTH (prolog_p^)];
            the_job_classes^ [i].prolog_p^ := prolog_p^;
          IFEND;
          epilog_p := the_job_classes^ [i].epilog_p;
          IF epilog_p <> NIL THEN
            NEXT epilog_p: [STRLENGTH (epilog_p^)] IN the_seq;
            ALLOCATE the_job_classes^ [i].epilog_p: [STRLENGTH (epilog_p^)];
            the_job_classes^ [i].epilog_p^ := epilog_p^;
          IFEND;
        IFEND;
      FOREND;

      NEXT category_data_p IN the_seq;
      jmv$job_category_data := category_data_p^;
      cd := category_data_p^;

      IF cd.item_list <> NIL THEN
        NEXT cd.item_list: [[REP #SIZE (cd.item_list^) OF cell]] IN the_seq;
        ALLOCATE jmv$job_category_data.item_list:
              [[REP #SIZE (cd.item_list^) OF cell]];
        jmv$job_category_data.item_list^ := cd.item_list^;
      IFEND;

      IF cd.category_names <> NIL THEN
        NEXT cd.category_names: [0 .. UPPERBOUND (cd.category_names^)] IN
              the_seq;
        ALLOCATE jmv$job_category_data.category_names:
              [0 .. UPPERBOUND (cd.category_names^)];
        jmv$job_category_data.category_names^ := cd.category_names^;
      IFEND;

      fsp$close_file (fid, local_status);
      RETURN;

    END /read_file/;

    fsp$close_file (fid, local_status);

    PUSH work_area: [[REP 100 OF clt$data_value]];
    clp$get_variable ('SCHEDULER_LIMITS', work_area, class, access_mode,
          evaluation_method, type_specification, value, local_status);
    IF local_status.normal THEN
      i := 1;
      WHILE (value <> NIL) AND (value^.kind = clc$list) DO
        IF value^.element_value^.kind = clc$integer THEN
          j := value^.element_value^.integer_value.value;
          CASE i OF
          = 1 =
            the_max.max_jc := j;
            the_max.max_jci := j;
          = 2 =
            the_max.max_jci := j;
          = 3 =
            the_max.max_sc := j;
            the_max.max_sci := j;
          = 4 =
            the_max.max_sci := j;
          = 5 =
            the_max.max_ap := j;
          ELSE
          CASEND;
        IFEND;
        i := i + 1;
        value := value^.link;
      WHILEND;
    IFEND;

    read_profile (the_header, status);
    IF status.normal THEN
      IF the_max.max_jci < the_header.maximum_job_class_index THEN
        the_max.max_jci := the_header.maximum_job_class_index;
      IFEND;
      IF the_max.max_sci < the_header.maximum_service_class_index THEN
        the_max.max_sci := the_header.maximum_service_class_index;
      IFEND;
      IF the_max.max_ap < the_header.application_count THEN
        the_max.max_ap := the_header.application_count;
      IFEND;
    IFEND;

    ALLOCATE the_controls.validation_categories_p:
          [1 .. UPPERBOUND (validation_list)];
    the_controls.validation_categories_p^ := validation_list;

    ALLOCATE the_job_classes: [1 .. the_max.max_jci];
    ALLOCATE the_service_classes: [1 .. the_max.max_sci];
    ALLOCATE the_applications: [1 .. the_max.max_ap];

    FOR i := 1 TO the_max.max_jci DO
      IF i < 4 THEN
        the_job_classes^ [i] := default_job_classes [i];
      ELSE
        the_job_classes^ [i] := default_job_classes [4];
      IFEND;
    FOREND;

    FOR i := 1 TO the_max.max_sci DO
      IF i < 4 THEN
        the_service_classes^ [i] := default_service_classes [i];
      ELSE
        the_service_classes^ [i] := default_service_classes [4];
      IFEND;
    FOREND;

    FOR i := 1 TO the_max.max_ap DO
      the_applications^ [i] := default_applications [1];
    FOREND;

    status.normal := TRUE;
  PROCEND read_system_tables;
?? TITLE := 'write_system_tables [xdcl]', EJECT ??

  PROCEDURE write_system_tables
    (VAR status: ost$status);

    VAR
      write_attachment: [STATIC] array [1 .. 3] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes,
            [fsc$read, fsc$append, fsc$modify, fsc$shorten]],
            [fsc$specific_share_modes, []]], [fsc$create_file, TRUE],
            [fsc$open_position, amc$open_at_boi]];

    VAR
      fid: amt$file_identifier,
      local_status: ost$status,
      seg_ptr: amt$segment_pointer,
      the_seq: ^SEQ ( * );

    VAR
      cd: jmt$job_category_data,
      epilog_p: ^fst$file_reference,
      i: integer,
      prolog_p: ^fst$file_reference,
      tm: ^maximums,
      validation_categories: ^jmt$mainframe_categories;

    fsp$open_file (base_file, amc$segment, ^write_attachment, NIL,
          ^required_attributes, ^required_attributes, NIL, fid, status);
    IF NOT status.normal THEN
      fsp$close_file (fid, local_status);
      RETURN
    IFEND;

    amp$get_segment_pointer (fid, amc$sequence_pointer, seg_ptr, status);
    IF NOT status.normal THEN
      fsp$close_file (fid, local_status);
      RETURN
    IFEND;
    RESET seg_ptr.sequence_pointer;
    the_seq := seg_ptr.sequence_pointer;

    NEXT tm IN the_seq;
    tm^ := the_max;

    NEXT controls_p IN the_seq;
    controls_p^ := the_controls;

    NEXT validation_categories: [1 .. UPPERBOUND (the_controls.
          validation_categories_p^)] IN the_seq;
    validation_categories^ := the_controls.validation_categories_p^;

    NEXT job_classes_p: [1 .. the_max.max_jci] IN the_seq;
    NEXT service_classes_p: [1 .. the_max.max_sci] IN the_seq;
    NEXT applications_p: [1 .. the_max.max_ap] IN the_seq;

    job_classes_p^ := the_job_classes^;
    service_classes_p^ := the_service_classes^;
    applications_p^ := the_applications^;

    FOR i := 1 TO UPPERBOUND (the_job_classes^) DO
      IF the_job_classes^ [i].defined THEN
        IF the_job_classes^ [i].prolog_p <> NIL THEN
          NEXT prolog_p: [STRLENGTH (the_job_classes^ [i].prolog_p^)] IN
                the_seq;
          prolog_p^ := the_job_classes^ [i].prolog_p^;
        IFEND;
        IF the_job_classes^ [i].epilog_p <> NIL THEN
          NEXT epilog_p: [STRLENGTH (the_job_classes^ [i].epilog_p^)] IN
                the_seq;
          epilog_p^ := the_job_classes^ [i].epilog_p^;
        IFEND;
      IFEND;
    FOREND;

    NEXT category_data_p IN the_seq;
    cd := jmv$job_category_data;

    IF cd.item_list <> NIL THEN
      NEXT cd.item_list: [[REP #SIZE (cd.item_list^) OF cell]] IN the_seq;
      cd.item_list^ := jmv$job_category_data.item_list^;
      FREE jmv$job_category_data.item_list;
    IFEND;

    IF cd.category_names <> NIL THEN
      NEXT cd.category_names: [0 .. UPPERBOUND (cd.category_names^)] IN
            the_seq;
      cd.category_names^ := jmv$job_category_data.category_names^;
      FREE jmv$job_category_data.category_names;
    IFEND;
    category_data_p^ := cd;

    fsp$close_file (fid, status);

  PROCEND write_system_tables;

?? TITLE := 'read_profile', EJECT ??

{ PURPOSE:
{   This interface reads the profile from the specified file.

  PROCEDURE read_profile
    (VAR profile_header: jmt$profile_header;
     VAR status: ost$status);

    VAR
      profile_file: ^SEQ ( * );

    VAR
      read_attachment: [STATIC] array [1 .. 2] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes,
            [fsc$read]], [fsc$specific_share_modes, []]],
            [fsc$open_position, amc$open_at_boi]];

    VAR
      required_attributes: [STATIC] array [1 .. 3] of
            fst$file_cycle_attribute := [[fsc$file_contents_and_processor,
            'SCHEDULING_PROFILE', 'ADMINISTER_SCHEDULING'],
            [fsc$file_organization, amc$byte_addressable],
            [fsc$record_type, amc$undefined]];

    VAR
      file: clt$file,
      header: ^jmt$profile_header,
      local_status: ost$status,
      profile_file_identifier: amt$file_identifier,
      segment_pointer: amt$segment_pointer;

    clp$convert_string_to_file (jmc$scheduling_profile_pathname, file, status);

    fsp$open_file (file.local_file_name, amc$segment, ^read_attachment, NIL,
          NIL, ^required_attributes, NIL, profile_file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /read_file/
    BEGIN

      amp$get_segment_pointer (profile_file_identifier, amc$sequence_pointer,
            segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /read_file/;
      IFEND;

      RESET segment_pointer.sequence_pointer;
      profile_file := segment_pointer.sequence_pointer;

      NEXT header IN profile_file;
      IF header = NIL THEN
        status.normal := FALSE;
        EXIT /read_file/;
      IFEND;

      IF header^.version <> jmc$profile_version THEN
        status.normal := FALSE;
        EXIT /read_file/;
      IFEND;

      profile_header := header^;

    END /read_file/;

    fsp$close_file (profile_file_identifier, local_status);
  PROCEND read_profile;

MODEND jmm$the_stubs;

*DECK DECK=JMM$TIMESHARING_SIGNAL_HANDLER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE job management timesharing signal handler module' ??
MODULE jmm$timesharing_signal_handler;

{ Purpose: This module contains the signal handler for the timesharing application
{          signals.  It also contains the necessary support interfaces for the condition
{          handling of the interactive conditions associated with the timesharing signals.

{ Notes: The path of a timesharing (interactive) condition is sort of awkward.  The path
{        is as follows (ignoring block exit processing):

{        JMP$TIMESHARING_SIGNAL_HANDLER gets control via a signal from networks.
{          pmp$disable_ts_io_in_tasks
{
{          pmp$begin_timesharing_condition
{          pmp$enable_timesharing_io
{
{          pmp$dispose_interactive_cond

{        PMP$DISPOSE_INTERACTIVE_COND does the following:
{          jmp$begin_timesharing_handler
{
{          find_the_users_handler
{          if found then
{            execute_it
{          else                            / if psa <> nil then
{            post_ring_crossing_condition <    jmp$begin_timesharing_handler
{          ifend                           \ ifend
{
{          jmp$end_timesharing_handler

{        PROCESS_DELAYED_CONDITION does the following:
{          jmp$begin_timesharing_handler
{
{          find_the_users_handler
{          if found then
{            execute_it
{          else                            / if psa <> nil then
{            post_ring_crossing_condition <    jmp$begin_timesharing_handler
{          ifend                           \ ifend
{
{          jmp$end_timesharing_handler
{
{          jmp$end_timesharing_handler (this offsets the call in pmp$dispose_interactive_cond)

{        JMP$BEGIN_TIMESHARING_HANDLER
{          pmp$begin_timesharing_handler

{        JMP$END_TIMESHARING_HANDLER
{          pmp$end_timesharing_handler
{
{          if pmp$zero_ts_conditions_in_task then
{            pmp$enable_ts_io_in_tasks
{          ifend

{        1.  In order to do I/O on the connection, a task's pmp$ts_task_io_enabled request must
{            return a value of true.  NOTE: the job monitor task can always do I/O on the connection.
{        2.  A count of the number of condition handlers that have been invoked in a task is kept.
{            When this count is zero, it indicates that all condition handlers have been processed to
{            completion in the task.  This implies that the task is no longer processing any conditions.
{            This being the case, we call pmp$enable_ts_io_in_tasks to re-enable io in the appropriate
{            tasks.
{        3.  User interrupts (user status commands) are processed within the job monitor task.


?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ave$validation_interface_errors
*copyc clc$standard_file_names
*copyc ifc$interrupt
*copyc ifc$interrupt_timesharing_io
*copyc ife$error_codes
*copyc ift$condition_codes
*copyc iiv$connection_desc_ptr
*copyc jmc$job_management_id
*copyc jmc$submit_detached_jobs
*copyc jme$cannot_detach_xterm_job
*copyc jme$invalid_paired_connection
*copyc jme$multiple_detached_jobs
*copyc jme$transaction_job_disconnect
*copyc jme$unlimited_timeout_message
*copyc jme$queued_file_conditions
*copyc jmt$paired_connection_data
*copyc jmt$service_data
*copyc jmt$submit_job_variations
*copyc jmt$timesharing_signal
*copyc nae$application_interfaces
*copyc osc$timesharing
*copyc osc$timesharing_terminal_file
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc ost$global_task_id
*copyc ost$status
*copyc pmt$binary_mainframe_id
*copyc pmt$condition
*copyc pmt$signal
*copyc sft$audit_information
*copyc syv$nosve_job_template
*copyc syv$clone_enabled
*copyc syv$job_initialization_complete
*copyc tmc$signal_identifiers
*copyc tmc$wait_times
*copyc avc$accounting_statistics
?? POP ??
*copyc amp$flush
*copyc amp$put_next
*copyc avp$get_capability
*copyc avp$security_option_active
*copyc clp$find_current_job_synch_task
*copyc clp$get_processing_phase
*copyc clp$get_system_file_id
*copyc clp$include_command
*copyc clp$put_job_output
*copyc fmp$disconnect_for_clone
*copyc fmp$create_network_file
*copyc fsp$close_file
*copyc fsp$open_file
*copyc ifp$disconnect
*copyc ifp$get_terminal_attributes
*copyc ifp$change_terminal_attributes
*copyc ifp$reconnect
*copyc iip$interrupt_timesharing_io
*copyc iip$restore_term_conn_atributes
*copyc iip$set_terminal_name
*copyc iip$st_clone_connection
*copyc iip$vtp_create_paired_connect
*copyc iip$vtp_del_paired_con_first
*copyc iip$vtp_delete_paired_connect
*copyc i#move
*copyc jmp$determine_name_kind
*copyc jmp$display_job_status
*copyc jmp$emit_communication_stat
*copyc jmp$get_encrypted_password
*copyc jmp$get_job_attributes
*copyc jmp$get_job_internal_info
*copyc jmp$get_job_status
*copyc jmp$get_result_size
*copyc jmp$is_dual_state_job
*copyc jmp$is_xterm_job
*copyc jmp$logout
*copyc jmp$set_job_input_device
*copyc jmp$set_job_mode
*copyc jmp$submit_job
*copyc jmp$system_job
*copyc jmp$terminate_job
*copyc jmp$update_display_message
*copyc jmp$validate_user
*copyc lgp$display_log
*copyc nac$null_connection_id
*copyc nap$acquire_connection
*copyc nap$clone_connection
*copyc nap$attach_server_application
*copyc nap$cancel_switch_offer
*copyc nap$change_attributes
*copyc nap$detach_server_application
*copyc nap$get_attributes
*copyc nap$get_connect_data
*copyc nap$parse_accounting_data
*copyc nap$se_synchronize_confirm
*copyc nap$se_clear_request
*copyc nlp$accept_switch_offer
*copyc nlp$offer_connection_switch
*copyc nlp$record_nominal_disconnect
*copyc nlp$register_nominal_connection
*copyc nlp$simulate_connection_broken
*copyc nlp$unsimulate_connection_broke
*copyc ofp$display_status_message
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$format_message
*copyc osp$generate_log_message
*copyc osp$i_await_activity
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$system_error
*copyc osp$verify_system_privilege
*copyc pmp$begin_timesharing_condition
*copyc pmp$begin_timesharing_handler
*copyc pmp$cause_condition
*copyc pmp$compute_date_time
*copyc pmp$continue_to_cause
*copyc pmp$convert_binary_mainframe_id
*copyc pmp$convert_mainframe_to_binary
*copyc pmp$disable_ts_io_in_tasks
*copyc pmp$display_active_tasks
*copyc pmp$dispose_interactive_cond
*copyc pmp$enable_ts_io_in_tasks
*copyc pmp$enable_timesharing_io
*copyc pmp$end_timesharing_handler
*copyc pmp$establish_condition_handler
*copyc pmp$exit
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pmp$get_compact_date_time
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_global_task_id
*copyc pmp$get_job_mode
*copyc pmp$get_job_names
*copyc pmp$get_mainframe_id
*copyc pmp$get_pseudo_mainframe_id
*copyc pmp$get_user_identification
*copyc pmp$log
*copyc pmp$log_ascii
*copyc pmp$long_term_wait
*copyc pmp$send_signal
*copyc pmp$signal_all_child_tasks
*copyc pmp$ts_task_io_enabled
*copyc pmp$zero_ts_conditions_in_task
*copyc qfp$set_terminal_name
*copyc rmp$request_terminal
*copyc sfp$emit_audit_statistic
*copyc sfp$emit_statistic
*copyc jmv$cluster_attach_job_enabled
*copyc jmv$jcb
*copyc jmv$job_attributes
*copyc jmv$kjl_p
*copyc jmv$kjlx_p
*copyc jmv$system_job_ssn
*copyc jmv$terminal_io_disabled
*copyc pmv$task_execution_phase
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by this Module', EJECT ??

  CONST
    connection_switch_timeout = 120000, { in milliseconds
    pause_break_char = '1';

  VAR
    jmv$job_timed_out: [STATIC, XDCL, oss$task_shared] boolean := FALSE,
    jmv$timesharing_job: [STATIC, XDCL, #GATE, oss$task_shared] boolean := FALSE,
    jmv$ts_interactive_condition: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
          [pmc$condition_combination, $pmt$condition_combination [ifc$interactive_condition]],
    jmv$ts_disconnect_time: [STATIC, XDCL, oss$task_shared] integer := 0,
    jmv$ts_disconnect_time_left: [STATIC, XDCL, oss$task_shared] integer := 0,
    jmv$interactive_conds_disabled: [STATIC, XDCL, oss$task_shared] boolean := FALSE,
    jmv$ts_job_disconnected: [STATIC, XDCL, #GATE, oss$task_shared] boolean := FALSE,
    jmv$initialized_as_disconnected: [STATIC, XDCL, #GATE, oss$task_shared] boolean := FALSE,
    jmv$connection_acquired: [STATIC, XDCL, #GATE, oss$task_shared] boolean := TRUE,
    jmv$user_breaks_enabled: [STATIC, XDCL, #GATE, oss$task_shared] boolean := FALSE,
    jmv$xterm_job: [STATIC, XDCL, #GATE, oss$task_shared] boolean := FALSE;

?? OLDTITLE ??
?? NEWTITLE := 'log_message', EJECT ??

  PROCEDURE log_message
    (    message: string ( * ));

    VAR
      local_status: ost$status;

    pmp$log (message, local_status);
  PROCEND log_message;
?? OLDTITLE ??
?? NEWTITLE := 'log_status', EJECT ??

  PROCEDURE log_status
    (    error_status: ost$status);

    VAR
      local_status: ost$status;

    osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], error_status, local_status);
  PROCEND log_status;
?? OLDTITLE ??
?? NEWTITLE := 'log_unexpected_message', EJECT ??

  PROCEDURE log_unexpected_message
    (    message: string ( * ));

    VAR
      local_status: ost$status;

    pmp$log_ascii (message, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
          local_status);
  PROCEND log_unexpected_message;
?? OLDTITLE ??
?? NEWTITLE := 'log_unexpected_status', EJECT ??

  PROCEDURE log_unexpected_status
    (    error_status: ost$status);

    VAR
      local_status: ost$status;

    osp$generate_log_message ($pmt$ascii_logset [pmc$system_log, pmc$job_log], error_status, local_status);
  PROCEND log_unexpected_status;
?? OLDTITLE ??
?? NEWTITLE := 'output_message', EJECT ??

  PROCEDURE output_message
    (    message: string ( * ));

    VAR
      local_status: ost$status;

    clp$put_job_output (message, local_status);
  PROCEND output_message;
?? OLDTITLE ??
?? NEWTITLE := 'put_and_flush_output', EJECT ??

  PROCEDURE put_and_flush_output
    (    text: string ( * );
     VAR status: ost$status);

    VAR
      file_id: amt$file_identifier,
      ignore_byte_address: amt$file_byte_address;

    clp$get_system_file_id (clc$job_output, file_id, status);
    IF status.normal THEN
      amp$put_next (file_id, ^text, STRLENGTH (text), ignore_byte_address, status);
      IF status.normal THEN
        amp$flush (file_id, osc$nowait, status);
      IFEND;
    IFEND;

  PROCEND put_and_flush_output;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$enable_user_breaks', EJECT ??
*copy jmh$enable_user_breaks

  PROCEDURE [XDCL, #GATE] jmp$enable_user_breaks;

    osp$verify_system_privilege;
    jmv$user_breaks_enabled := TRUE;

  PROCEND jmp$enable_user_breaks;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$disable_user_breaks', EJECT ??
*copy jmh$disable_user_breaks

  PROCEDURE [XDCL] jmp$disable_user_breaks;

    jmv$user_breaks_enabled := FALSE;

  PROCEND jmp$disable_user_breaks;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$attach_timesharing_job', EJECT ??
*copy jmh$attach_timesharing_job

  PROCEDURE [XDCL, #GATE] jmp$attach_timesharing_job
    (    job_name: string ( * <= osc$max_name_size);
     VAR status: ost$status);

    VAR
      binary_mainframe_id: pmt$binary_mainframe_id,
      current_mainframe_id: pmt$mainframe_id,
      job_status_options_p: ^jmt$job_status_options,
      job_status_results_keys_p: ^jmt$results_keys,
      job_status_results_p: ^jmt$job_status_results,
      job_status_results_seq_p: ^jmt$work_area,
      job_status_count: jmt$job_status_count,
      user_identification: ost$user_identification,
      job_internal_info: jmt$job_internal_information,
      job_mode: jmt$job_mode,
      size_of_sequence: ost$segment_length,
      timesharing_signal: jmt$timesharing_signal;

    osp$verify_system_privilege;
    status.normal := TRUE;

    pmp$get_job_mode (job_mode, status);
    IF (NOT status.normal) OR (job_mode <> jmc$interactive_connected) THEN
      RETURN;
    IFEND;

    pmp$get_user_identification (user_identification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH job_status_options_p: [1 .. 6];
    job_status_options_p^ [1].key := jmc$job_mode_set;
    job_status_options_p^ [1].job_mode_set := $jmt$job_mode_set
          [jmc$interactive_cmnd_disconnect, jmc$interactive_line_disconnect, jmc$interactive_sys_disconnect];
    job_status_options_p^ [3].key := jmc$login_user;
    job_status_options_p^ [3].login_user := user_identification.user;
    job_status_options_p^ [4].key := jmc$login_family;
    job_status_options_p^ [4].login_family := user_identification.family;
    job_status_options_p^ [5].key := jmc$job_state_set;
    job_status_options_p^ [5].job_state_set := $jmt$job_state_set [jmc$initiated_job];
    job_status_options_p^ [6].key := jmc$continue_request_to_servers;
    job_status_options_p^ [6].continue_request_to_servers := jmv$cluster_attach_job_enabled;

    IF job_name = osc$null_name THEN
      job_status_options_p^ [2].key := jmc$null_attribute;
    ELSE
      job_status_options_p^ [2].key := jmc$name_list;
      PUSH job_status_options_p^ [2].name_list: [1 .. 1];

      jmp$determine_name_kind (job_name, job_status_options_p^ [2].name_list^ [1], status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    PUSH job_status_results_keys_p: [1 .. 2];
    job_status_results_keys_p^ [1] := jmc$system_job_name;
    job_status_results_keys_p^ [2] := jmc$client_mainframe_id;
    jmp$get_result_size ({number_of_jobs} 1, #SEQ (job_status_results_keys_p^), size_of_sequence);
    PUSH job_status_results_seq_p: [[REP size_of_sequence OF cell]];

    jmp$get_job_status (job_status_options_p, job_status_results_keys_p, job_status_results_seq_p,
          job_status_results_p, job_status_count, status);
    IF NOT status.normal THEN
      IF status.condition = jme$work_area_too_small THEN
        osp$set_status_condition (jme$multiple_detached_jobs, status);
      ELSEIF status.condition = jme$no_jobs_were_found THEN
        osp$set_status_abnormal ('JM', jme$name_not_found, job_name, status);
      IFEND;
      RETURN;
    IFEND;

{ Check to see if the job is running on the current mainframe.

    pmp$get_mainframe_id (current_mainframe_id, {ignore} status);
    IF current_mainframe_id = job_status_results_p^ [1]^ [2].client_mainframe_id THEN

      jmp$get_job_internal_info (job_status_results_p^ [1]^ [1].system_job_name, job_internal_info, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Check to see if the job originated from a compatible network -

      IF job_internal_info.timesharing_job <> jmv$timesharing_job THEN
        osp$set_status_abnormal ('JM', jme$incompatible_network_origin, job_name, status);
        RETURN;
      IFEND;
    ELSE
      job_internal_info.jmtr_global_taskid.index := 0;
      job_internal_info.jmtr_global_taskid.seqno := 0;
    IFEND;

{ Ensure that the screen is cleared if the request is issued from
{ within a screen mode application.  Writing to the terminal using
{ a "line mode" instance of open causes this via a "context switch".
{ (If we're in "line mode", this has no effect.

    put_and_flush_output ('', status);
    status.normal := TRUE {don't care if it didn't work} ;


    IF jmv$timesharing_job THEN

{ Simulate the breaking of the connection

      nlp$simulate_connection_broken (osc$timesharing_terminal_file, status);
      IF NOT status.normal THEN
        log_status (status);
        RETURN;
      IFEND;

{ Signal the job monitor task to disconnect

      timesharing_signal.signal_id := jmc$timesharing_signal_id;
      timesharing_signal.signal_contents.signal_kind := jmc$timesharing_disconnect;
      timesharing_signal.signal_contents.disconnect.disconnect_reason := jmc$ts_attach_job;
      timesharing_signal.signal_contents.disconnect.target_job_global_task_id :=
            job_internal_info.jmtr_global_taskid;
      timesharing_signal.signal_contents.disconnect.target_job_system_supplied_name :=
            job_status_results_p^ [1]^ [1].system_job_name;
      pmp$convert_mainframe_to_binary (job_status_results_p^ [1]^ [2].client_mainframe_id,
            binary_mainframe_id, {ignore} status);
      timesharing_signal.signal_contents.disconnect.target_job_mainframe_id := binary_mainframe_id;

      pmp$send_signal (jmv$jcb.job_monitor_id, timesharing_signal.signal, status);
    ELSE

      IF current_mainframe_id = job_status_results_p^ [1]^ [2].client_mainframe_id THEN
        ifp$reconnect (job_internal_info.jmtr_global_taskid, status);
      ELSE
        osp$set_status_abnormal (jmc$job_management_id, jme$incompatible_network_origin, job_name, status);
        RETURN;
      IFEND;
    IFEND;
    IF NOT status.normal THEN
      log_unexpected_status (status);
      output_message ('The attempt to attach a job failed - check the job log for details.');
    IFEND;
  PROCEND jmp$attach_timesharing_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$begin_timesharing_handler', EJECT ??
*copy jmh$begin_timesharing_handler

  PROCEDURE [XDCL, #GATE] jmp$begin_timesharing_handler
    (    condition: ift$interactive_condition);

    osp$verify_system_privilege;
    IF jmp$system_job () OR (condition = ifc$interrupt) THEN
      RETURN;
    IFEND;

{ Another handler has become active or a delayed condition has been posted.

    pmp$begin_timesharing_handler;
  PROCEND jmp$begin_timesharing_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$cluster_attach_job_enabled: boolean', EJECT ??

  FUNCTION [XDCL, #GATE] jmp$cluster_attach_job_enabled: boolean;

    jmp$cluster_attach_job_enabled := jmv$cluster_attach_job_enabled;
  FUNCEND jmp$cluster_attach_job_enabled;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$detach_timesharing_job', EJECT ??
*copy jmh$detach_timesharing_job

  PROCEDURE [XDCL, #GATE] jmp$detach_timesharing_job
    (VAR status: ost$status);

    VAR
      job_mode: jmt$job_mode,
      timesharing_signal: jmt$timesharing_signal;

    osp$verify_system_privilege;
    status.normal := TRUE;

    pmp$get_job_mode (job_mode, status);
    IF (NOT status.normal) OR (job_mode <> jmc$interactive_connected) THEN
      RETURN;
    IFEND;

    IF jmv$timesharing_job THEN

{ Simulate the connection as being broken

      nlp$simulate_connection_broken (osc$timesharing_terminal_file, status);
      IF NOT status.normal THEN
        log_status (status);
        RETURN;
      IFEND;

{ Signal the job_monitor task to disconnect

      timesharing_signal.signal_id := jmc$timesharing_signal_id;
      timesharing_signal.signal_contents.signal_kind := jmc$timesharing_disconnect;
      timesharing_signal.signal_contents.disconnect.disconnect_reason := jmc$ts_detach_job;

      pmp$send_signal (jmv$jcb.job_monitor_id, timesharing_signal.signal, status);

    ELSEIF jmp$is_dual_state_job () THEN
      ifp$disconnect (status);
    ELSE { This is an xterm job.
      osp$set_status_abnormal ('JM', jme$cannot_detach_xterm_job, '', status);
      RETURN;
    IFEND;
    IF NOT status.normal THEN
      log_unexpected_status (status);
      output_message ('The attempt to detach the current job failed - check the job log for details.');
    IFEND;
  PROCEND jmp$detach_timesharing_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$end_timesharing_handler', EJECT ??
*copy jmh$end_timesharing_handler

  PROCEDURE [XDCL, #GATE] jmp$end_timesharing_handler
    (    condition: ift$interactive_condition);

    VAR
      timesharing_signal: jmt$timesharing_signal,
      local_status: ost$status;

    osp$verify_system_privilege;
    IF jmp$system_job () OR (condition = ifc$interrupt) THEN
      RETURN;
    IFEND;
    local_status.normal := TRUE;

{ Another handler has be completed or a delayed condition has been processed.

    pmp$end_timesharing_handler;

{ Have all condition handlers in the task been completed?

    IF pmp$zero_ts_conditions_in_task () THEN

{ All conditions in this task have been processed.  Re-enable IO in the appropriate tasks

      pmp$enable_ts_io_in_tasks;

{ Give all tasks in the job a push to get them started doing IO again.

      timesharing_signal.signal_id := jmc$timesharing_signal_id;
      timesharing_signal.signal_contents.signal_kind := jmc$timesharing_restart_tasks;
      timesharing_signal.signal_contents.restart_tasks := jmc$ts_restart_child_tasks;
      pmp$send_signal (jmv$jcb.job_monitor_id, timesharing_signal.signal, local_status);
      IF NOT local_status.normal THEN
        log_unexpected_status (local_status);
      IFEND;
    IFEND;
  PROCEND jmp$end_timesharing_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$generate_timesharing_title', EJECT ??
*copy jmh$generate_timesharing_title

  PROCEDURE [XDCL] jmp$generate_timesharing_title
    (    binary_mainframe_id: pmt$binary_mainframe_id;
     VAR timesharing_title: ost$name);

    CONST
      null_timesharing_title = '0000_0000$OSA$TIMESHARING';

    VAR
      local_status: ost$status,
      mainframe_id: pmt$mainframe_id;

    local_status.normal := TRUE;
    timesharing_title := null_timesharing_title;

    pmp$convert_binary_mainframe_id (binary_mainframe_id, mainframe_id, local_status);
    IF local_status.normal THEN
      timesharing_title (1, pmc$processor_model_number_size) :=
            mainframe_id (9, pmc$processor_model_number_size);
      timesharing_title (6, pmc$processor_serial_num_size) :=
            mainframe_id (14, pmc$processor_serial_num_size);
    IFEND;
  PROCEND jmp$generate_timesharing_title;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$handle_ts_io_req_failure', EJECT ??

  PROCEDURE [XDCL] jmp$handle_ts_io_req_failure
    (VAR status: ost$status);

    VAR
      executing_gtid: ost$global_task_id,
      established_handler: pmt$established_handler,
      ignore_status: ost$status,
      job_monitor_task: boolean;

?? NEWTITLE := 'handle_condition', EJECT ??

    PROCEDURE handle_condition
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      jmv$ts_disconnect_time_left := 0;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      CASE condition.interactive_condition OF
      = ifc$pause_break =
        osp$set_status_condition (ife$pause_break_received, status);

      = ifc$terminate_break =
        osp$set_status_condition (ife$terminate_break_received, status);

      = ifc$terminal_connection_broken =
        osp$set_status_condition (ife$connection_break_disconnect, status);

      = ifc$job_reconnect =
        osp$set_status_condition (ife$terminal_reconnected_to_job, status);

      ELSE
        osp$set_status_abnormal (ifc$interactive_facility_id, 0, 'unknown interactive condition encountered.',
              status);
      CASEND;

      EXIT jmp$handle_ts_io_req_failure;
    PROCEND handle_condition;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    ignore_status.normal := TRUE;

{ Check to see if the job is going through termination

    IF (jmv$kjl_p^ [jmv$jcb.job_id].entry_kind = jmc$kjl_terminated_entry) OR jmv$terminal_io_disabled THEN
      osp$set_status_condition (jme$job_is_in_termination, status);
      RETURN;
    IFEND;

{ Check to see if the task is going through termination

    IF (pmv$task_execution_phase > pmc$task_executing) THEN
      osp$set_status_condition (jme$task_is_in_termination, status);
      RETURN;
    IFEND;

{ Check to see if we are a transaction job that has interactive conditions disabled.

    IF jmv$initialized_as_disconnected AND jmv$interactive_conds_disabled THEN
      osp$set_status_condition (jme$transaction_job_disconnect, status);
      RETURN;
    IFEND;

{ Cause the interactive condition to pull us out if any io operations are pending.

    pmp$cause_condition (ifc$interrupt_timesharing_io, NIL, ignore_status);

{ Check to see if we are disconnected.

    IF jmv$ts_job_disconnected THEN
      jmp$timeout_timesharing_job (status);

    ELSE

{ Check to see if the task can do I/O on the connection.

      IF NOT pmp$ts_task_io_enabled () THEN
        pmp$establish_condition_handler (jmv$ts_interactive_condition, ^handle_condition,
              ^established_handler, status);
        IF NOT status.normal THEN
          log_unexpected_status (status);
        IFEND;

{ Wait for something to happen.

        WHILE NOT pmp$ts_task_io_enabled () DO
          pmp$long_term_wait (tmc$infinite_wait, 100000000);
        WHILEND;
        osp$set_status_condition (ife$pause_break_received, status);
        RETURN;
      IFEND;
    IFEND;
  PROCEND jmp$handle_ts_io_req_failure;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$handle_ts_system_disconnect', EJECT ??

  PROCEDURE [XDCL] jmp$handle_ts_system_disconnect
    (VAR status: ost$status);

    VAR
      timesharing_signal: jmt$timesharing_signal;

    status.normal := TRUE;

    IF jmv$timesharing_job THEN
      nlp$register_nominal_connection (osc$timesharing_terminal_file, status);
      IF NOT status.normal THEN
        log_unexpected_message ('Could not register the nominal connection in a recovered job.');
        log_unexpected_status (status);
        status.normal := TRUE;
      IFEND;

      timesharing_signal.signal_id := jmc$timesharing_signal_id;
      timesharing_signal.signal_contents.signal_kind := jmc$timesharing_disconnect;
      timesharing_signal.signal_contents.disconnect.disconnect_reason := jmc$ts_system_disconnect;

      pmp$send_signal (jmv$jcb.job_monitor_id, timesharing_signal.signal, status);
    IFEND;

    IF NOT status.normal THEN
      log_unexpected_status (status);
    IFEND;
  PROCEND jmp$handle_ts_system_disconnect;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$initialize_timesharing', EJECT ??

  PROCEDURE [XDCL] jmp$initialize_timesharing
    (VAR status: ost$status);

    CONST
      acquire_timeout = 60,
      max_connections = 1;

    VAR
      connection_attributes: ^nat$create_attributes,
      connection_exists: boolean,
      get_terminal_name: array [1 .. 1] of nat$accounting_data_field,
      ignore_status: ost$status,
      job_input_device_p: ^string ( * ),
      job_parameters: jmt$system_job_parameters,
      local_status: ost$status,
      mainframe_id: pmt$mainframe_id,
      paired_connection_data: jmt$paired_connection_data,
      submit_variation: jmt$submit_job_variations,
      wait_list_p: ^ost$i_wait_list,
      wait_complete: boolean,
      wait_activity: integer;


    status.normal := TRUE;
    jmv$timesharing_job := TRUE;

    job_parameters := jmv$kjlx_p^ [jmv$jcb.job_id].system_label_p^.job_attributes.system_job_parameters;

{ If there are no job parameters then the job is an initial submit on the local mainframe,
{ otherwise the type of submit is encoded in the job parameters

    PUSH connection_attributes: [1 .. 2];
    connection_attributes^ [1].kind := nac$data_transfer_timeout;
    connection_attributes^ [1].data_transfer_timeout := nac$max_wait_time;
    connection_attributes^ [2].kind := nac$receive_wait_swapout;
    connection_attributes^ [2].receive_wait_swapout := TRUE;

    IF job_parameters.system_job_parameter_count = 0 THEN
      nap$attach_server_application (osc$timesharing, max_connections, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      nap$acquire_connection (osc$timesharing, osc$timesharing_terminal_file, connection_attributes,
            acquire_timeout, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      nap$detach_server_application (osc$timesharing, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      i#move (^job_parameters.system_job_parameter, ^submit_variation, #SIZE (submit_variation));

      CASE submit_variation.kind OF
      = jmc$submit_detached_job =
        login_as_disconnected (status);
        RETURN;

      = jmc$connection_switch =

{ Wait for a switch offer to be made

        PUSH wait_list_p: [1 .. 2];
        wait_list_p^ [1].activity := osc$i_await_time;
        wait_list_p^ [1].milliseconds := connection_switch_timeout;
        wait_list_p^ [2].activity := nac$i_await_switch_offer;
        wait_list_p^ [2].source := submit_variation.job_offering_connection;
        osp$i_await_activity (wait_list_p^, wait_activity, wait_complete, status);

{ Did something go wrong or did we timeout? - if so - consider it an error

        IF (NOT status.normal) OR (wait_activity = 1) THEN
          log_unexpected_message ('A connection switch was never offered.');
          IF status.normal THEN
            osp$set_status_condition (ife$disconnected_job_timeout, status);
          IFEND;
          RETURN;
        IFEND;

        IF syv$clone_enabled AND syv$nosve_job_template THEN
          connection_exists := TRUE;
        ELSE
          connection_exists := FALSE;
        IFEND;

        nlp$accept_switch_offer (osc$timesharing_terminal_file, submit_variation.job_offering_connection,
              connection_attributes, connection_exists, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = jmc$remote_connection_switch =

        nap$attach_server_application (osc$timesharing, max_connections, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        nap$acquire_connection (osc$timesharing, osc$timesharing_terminal_file, connection_attributes,
              acquire_timeout, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        nap$detach_server_application (osc$timesharing, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        paired_connection_data.connection_request := jmc$pcr_leveled_job_results;
        paired_connection_data.leveled_job_results.successful := TRUE;

        iip$vtp_del_paired_con_first (#SEQ (paired_connection_data), local_status);
        IF NOT local_status.normal THEN
          log_unexpected_message ('initialize_timesharing - iip$vtp_del_paired_con_first failed with...');
          log_unexpected_status (local_status);
        IFEND;

      ELSE

{Unknown type of submit request

        osp$system_error ('Unknown submit request', NIL);
      CASEND;
    IFEND;

    nlp$register_nominal_connection (osc$timesharing_terminal_file, status);

    PUSH job_input_device_p: [jmv$kjlx_p^ [jmv$jcb.job_id].system_label_p^.job_attributes.job_input_device.
          size];
    job_input_device_p^ := jmv$kjlx_p^ [jmv$jcb.job_id].system_label_p^.job_attributes.job_input_device.text;
    get_terminal_name [1].kind := nac$ca_device_name;
    nap$parse_accounting_data (job_input_device_p, NIL, ^get_terminal_name, local_status);
    IF local_status.normal AND (get_terminal_name [1].kind = nac$ca_device_name) THEN
      qfp$set_terminal_name (get_terminal_name [1].device_name);
    ELSE
      qfp$set_terminal_name (osc$null_name);
    IFEND;
  PROCEND jmp$initialize_timesharing;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$set_interactive_cond_state', EJECT ??
*copy jmh$set_interactive_cond_state

  PROCEDURE [XDCL, #GATE] jmp$set_interactive_cond_state
    (    interactive_conditions_enabled: boolean);

    IF jmv$initialized_as_disconnected THEN
      jmv$interactive_conds_disabled := NOT interactive_conditions_enabled;
    IFEND;
  PROCEND jmp$set_interactive_cond_state;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$signal_pair_connect_target', EJECT ??
*copy jmh$signal_pair_connect_target

  PROCEDURE [XDCL] jmp$signal_pair_connect_target
    (    system_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      job_internal_info: jmt$job_internal_information,
      reconnect_signal: jmt$timesharing_signal;

    status.normal := TRUE;

    jmp$get_job_internal_info (system_job_name, job_internal_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT job_internal_info.timesharing_job THEN
      osp$set_status_abnormal ('JM', jme$incompatible_network_origin, system_job_name, status);
      RETURN;
    IFEND;

    reconnect_signal.signal_id := jmc$timesharing_signal_id;
    reconnect_signal.signal_contents.signal_kind := jmc$timesharing_reconnect;
    reconnect_signal.signal_contents.reconnect.system_supplied_job_name := jmv$jcb.system_name;
    reconnect_signal.signal_contents.reconnect.paired_connection_reconnect := TRUE;
    pmp$send_signal (job_internal_info.jmtr_global_taskid, reconnect_signal.signal, status);
  PROCEND jmp$signal_pair_connect_target;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$timeout_timesharing_job', EJECT ??

  PROCEDURE [XDCL] jmp$timeout_timesharing_job
    (VAR status: ost$status);

    VAR
      local_status: ost$status,
      signal: jmt$timesharing_signal;

?? NEWTITLE := 'handle_condition', EJECT ??

    PROCEDURE handle_condition
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      IF condition.selector = pmc$block_exit_processing THEN

        jmv$ts_disconnect_time_left := 0;
      ELSE

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

        IF condition.selector = ifc$interactive_condition THEN
          CASE condition.interactive_condition OF
          = ifc$pause_break =
            osp$set_status_condition (ife$pause_break_received, status);

          = ifc$terminate_break =
            osp$set_status_condition (ife$terminate_break_received, status);

          = ifc$terminal_connection_broken =
            osp$set_status_condition (ife$connection_break_disconnect, status);

          = ifc$job_reconnect =
            osp$set_status_condition (ife$terminal_reconnected_to_job, status);

          ELSE
            osp$set_status_abnormal (ifc$interactive_facility_id, 0,
                  'unknown interactive condition encountered.', status);
          CASEND;

          EXIT jmp$timeout_timesharing_job;
        IFEND;
      IFEND;
    PROCEND handle_condition;
?? OLDTITLE ??
?? NEWTITLE := 'update_display_message', EJECT ??

{ PURPOSE:
{   The purpose of this request is to update the display message for display job
{ status to indicate when a job will timeout.

    PROCEDURE update_display_message
      (    timeout_time_left: integer);

      VAR
        current_date_time: ost$date_time,
        date: ost$date,
        local_status: ost$status,
        message_status: ost$status,
        time: ost$time,
        time_left: pmt$time_increment,
        timeout_time: ost$date_time;

      time_left.year := 0;
      time_left.month := 0;
      time_left.day := 0;
      time_left.hour := 0;
      time_left.minute := 0;
      time_left.second := timeout_time_left;
      time_left.millisecond := 0;

      pmp$get_compact_date_time (current_date_time, { ignore } local_status);
      pmp$compute_date_time (current_date_time, time_left, timeout_time, local_status);
      IF local_status.normal THEN
        pmp$format_compact_date (timeout_time, osc$iso_date, date, { ignore } local_status);
        pmp$format_compact_time (timeout_time, osc$hms_time, time, { ignore } local_status);
        osp$set_status_abnormal (jmc$job_management_id, jme$terminal_timeout_message, date.iso,
              message_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, time.hms, message_status);
        jmp$update_display_message (message_status);
      IFEND;
    PROCEND update_display_message;
?? OLDTITLE ??
?? EJECT ??

    osp$establish_condition_handler (^handle_condition, {block_exit} TRUE);

    log_message ('Disconnect timeout begins.');

{ NOTE: all values used are in seconds.

    IF jmp$is_xterm_job () THEN

{ Xterm does not currently support attach job, so disconnect immediately.

      jmv$ts_disconnect_time_left := 0;
    ELSEIF jmv$ts_disconnect_time_left = 0 THEN
      jmv$ts_disconnect_time := #FREE_RUNNING_CLOCK (0) DIV 1000000;

{ Assign detach job wait time in seconds

      jmv$ts_disconnect_time_left := jmv$jcb.detached_job_wait_time;
    IFEND;

  /await_timeout/
    BEGIN
      WHILE jmv$ts_disconnect_time_left > 0 DO
        IF jmv$jcb.detached_job_wait_time = jmc$unlimited_det_job_wait_time THEN
          osp$set_status_condition (jme$unlimited_timeout_message, local_status);
          jmp$update_display_message (local_status);
        ELSE
          update_display_message (jmv$ts_disconnect_time_left);
        IFEND;
        pmp$long_term_wait (jmv$ts_disconnect_time_left * 1000, jmv$ts_disconnect_time_left * 1000);

{ Have we been reconnected ??

        IF NOT jmv$ts_job_disconnected THEN
          jmv$ts_disconnect_time_left := 0;
          EXIT /await_timeout/;
        IFEND;

        IF jmv$jcb.detached_job_wait_time <> jmc$unlimited_det_job_wait_time THEN
          jmv$ts_disconnect_time_left := jmv$jcb.detached_job_wait_time -
                ((#FREE_RUNNING_CLOCK (0) DIV 1000000) - jmv$ts_disconnect_time);

{ If the disconnect time left exceeds the detach job wait time, the free running
{ clock for the disconnect time must be in the future.  This could possible happen
{ during a recovery deadstart (although it isn't supposed to).
{ In any case, if this happens, restart the timeout from the beginning using
{ the current free-running clock as the detached time.

          IF jmv$ts_disconnect_time_left > jmv$jcb.detached_job_wait_time THEN
            jmv$ts_disconnect_time := #FREE_RUNNING_CLOCK (0) DIV 1000000;
            jmv$ts_disconnect_time_left := jmv$jcb.detached_job_wait_time;
          IFEND;
        IFEND;
      WHILEND;

{ The job has timed out - signal its death.

      IF NOT jmv$job_timed_out THEN
        signal.signal_id := jmc$timesharing_signal_id;
        signal.signal_contents.signal_kind := jmc$timesharing_timeout;
        pmp$send_signal (jmv$jcb.job_monitor_id, signal.signal, status);
        jmv$job_timed_out := TRUE;
      IFEND;

{ Return with abnormal status to the user

      osp$set_status_condition (jme$job_is_in_termination, status);
      osp$disestablish_cond_handler;
      RETURN;
    END /await_timeout/;

{ Can the task do IO?

    IF NOT pmp$ts_task_io_enabled () THEN
      WHILE NOT pmp$ts_task_io_enabled () DO
        pmp$long_term_wait (tmc$infinite_wait, 100000000);
      WHILEND;
      osp$set_status_condition (ife$pause_break_received, status);
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

    osp$disestablish_cond_handler;
    status.normal := TRUE;
  PROCEND jmp$timeout_timesharing_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$timesharing_signal_handler', EJECT ??

  PROCEDURE [XDCL] jmp$timesharing_signal_handler
    (    originator: ost$global_task_id;
         signal: pmt$signal);

    VAR
      local_status: ost$status,
      executing_in_job_synch_task: boolean,
      signal_processed: boolean,
      executing_gtid: ost$global_task_id,
      statistic_data: jmt$comm_acct_statistic_data,
      submit_variation: jmt$submit_job_variations,
      timesharing_signal: jmt$timesharing_signal;

?? NEWTITLE := 'check_for_special_signals', EJECT ??

    PROCEDURE check_for_special_signals
      (    timesharing_signal: jmt$timesharing_signal;
       VAR processed_signal: boolean;
       VAR status: ost$status);

      VAR
        display_option_selection: lgt$display_option_selection,
        job_name: clt$data_value,
        job_name_p: ^jmt$job_attribute_results,
        message: [STATIC, READ, oss$job_paged_literal] string (2) := $CHAR (0D(16)) CAT $CHAR (0A(16)),
        cl_processing_phase: clt$processing_phase;


      status.normal := TRUE;
      processed_signal := TRUE;

      CASE timesharing_signal.signal_contents.signal_kind OF
      = jmc$timesharing_interrupt =

{ A user interrupt was received.  Process the interrupt.

        clp$get_processing_phase (cl_processing_phase, status);
        IF status.normal AND (clc$user_prolog_phase <= cl_processing_phase) AND
              (cl_processing_phase <= clc$user_epilog_phase) AND (NOT jmv$interactive_conds_disabled) THEN

          IF NOT jmv$terminal_io_disabled THEN
            CASE timesharing_signal.signal_contents.interrupt (1) OF
            = 'A', 'a' =
              pmp$display_active_tasks (':$LOCAL.OUTPUT.1', status);
              put_and_flush_output (message, status);

            = 'D', 'd' =
              jmp$detach_timesharing_job (status);

            = 'J', 'j' =
              job_name.kind := clc$keyword;
              job_name.keyword_value := 'ALL';
              jmp$display_job_status (':$LOCAL.OUTPUT.1', $jmt$attribute_keys_set
                    [jmc$cpu_time_used, jmc$display_message, jmc$job_state, jmc$page_faults,
                    jmc$system_job_name], job_name, status);
              put_and_flush_output (message, status);

            = 'L', 'l' =
              display_option_selection.display_options := lgc$count;
              display_option_selection.count := 10;
              lgp$display_log (clc$display_job_log, display_option_selection, ':$LOCAL.OUTPUT.1', status);
              put_and_flush_output (message, status);

            = 'X', 'x' =
              ;
            ELSE
              job_name.kind := clc$name;
              PUSH job_name_p: [1 .. 1];
              job_name_p^ [1].key := jmc$system_job_name;
              jmp$get_job_attributes (job_name_p, status);
              job_name.name_value := job_name_p^ [1].system_job_name;
              jmp$display_job_status (':$LOCAL.OUTPUT.1', $jmt$attribute_keys_set
                    [jmc$cpu_time_used, jmc$display_message, jmc$page_faults], job_name, status);
              put_and_flush_output (message, status);
            CASEND;
          IFEND;

          CASE timesharing_signal.signal_contents.interrupt (1) OF
          = 'X', 'x' =
            osp$set_status_condition (jme$user_requested_exit, status);
            pmp$exit (status);

          ELSE
          CASEND;

        ELSE {before user prolog or after user epilog}
          log_message ('User interrupt ignored');
          status.normal := TRUE;
        IFEND;

      = jmc$timesharing_restart_tasks =

{ Restart the appropriate task(s).

        IF timesharing_signal.signal_contents.restart_tasks = jmc$ts_restart_child_tasks THEN
          pmp$signal_all_child_tasks (timesharing_signal.signal, status);
        IFEND;

      = jmc$timesharing_timeout =

        log_message ('Disconnect timeout completed.');

{ The job has been disconnected for the detached job wait time.  Let's end it.

        osp$set_status_condition (ife$disconnected_job_timeout, status);
        pmp$exit (status);

      ELSE
        processed_signal := FALSE;
      CASEND;
    PROCEND check_for_special_signals;
?? OLDTITLE ??
?? NEWTITLE := 'raise_condition', EJECT ??

    PROCEDURE raise_condition
      (    timesharing_signal: jmt$timesharing_signal);

?? NEWTITLE := 'handle_disconnect', EJECT ??

      PROCEDURE handle_disconnect
        (    timesharing_signal: jmt$timesharing_signal;
         VAR cause_condition: boolean);

        CONST
          paired_connect_timeout_interval = 120000; { in milliseconds

        VAR
          current_clock: ost$free_running_clock,
          current_mainframe_id: pmt$binary_mainframe_id,
          file_id: amt$file_identifier,
          destination_title: ost$name,
          job_termination_options: ^jmt$job_termination_options,
          paired_connection_data: jmt$paired_connection_data,
          paired_connection_data_p: ^jmt$paired_connection_data,
          termination_data_p: ^SEQ ( * ),
          termination_attributes_p: ^nat$get_attributes,
          submitted_job_name: jmt$name,
          wait_list_p: ^ost$i_wait_list,
          wait_complete: boolean,
          wait_activity: integer,
          wait_file: amt$local_file_name,
          job_attribute_p: ^jmt$job_attribute_results,
          job_submission_options: ^jmt$job_submission_options,
          reconnect_signal: jmt$timesharing_signal,
          terminate_signal: jmt$timesharing_signal,
          unsimulate_broken_status: ost$status,
          time_left: integer,
          local_status: ost$status,
          ignore_status: ost$status;

?? NEWTITLE := 'send_line_disconnect', EJECT ??

        PROCEDURE send_line_disconnect;

          VAR
            local_status: ost$status,
            disconnect_signal: jmt$timesharing_signal;

          log_message ('The job was disconnected while a non-nominal operation was pending.');

          disconnect_signal.signal_id := jmc$timesharing_signal_id;
          disconnect_signal.signal_contents.signal_kind := jmc$timesharing_disconnect;
          disconnect_signal.signal_contents.disconnect.disconnect_reason := jmc$ts_line_disconnect;
          pmp$send_signal (jmv$jcb.job_monitor_id, disconnect_signal.signal, local_status);
        PROCEND send_line_disconnect;

?? OLDTITLE, EJECT ??

        unsimulate_broken_status.normal := TRUE;
        cause_condition := TRUE;

        CASE timesharing_signal.signal_contents.disconnect.disconnect_reason OF

        = jmc$ts_line_disconnect =
          jmp$set_job_mode (jmc$interactive_line_disconnect, ignore_status);

        = jmc$ts_attach_job =

          pmp$get_pseudo_mainframe_id (current_mainframe_id);
          IF current_mainframe_id = timesharing_signal.signal_contents.disconnect.target_job_mainframe_id THEN

{ Offer the target job the connection

            nlp$offer_connection_switch (osc$timesharing_terminal_file,
                  timesharing_signal.signal_contents.disconnect.target_job_system_supplied_name, TRUE,
                  local_status);
            IF NOT local_status.normal THEN
              log_unexpected_status (local_status);
              nlp$unsimulate_connection_broke (osc$timesharing_terminal_file, unsimulate_broken_status);
              IF pmp$zero_ts_conditions_in_task () THEN
                pmp$enable_ts_io_in_tasks;
              IFEND;
              nlp$register_nominal_connection (osc$timesharing_terminal_file, ignore_status);
              jmv$ts_job_disconnected := FALSE;
              IF NOT unsimulate_broken_status.normal THEN
                send_line_disconnect;
              ELSE
                output_message (' The attempt to offer the switch to the target job failed.');
              IFEND;
              cause_condition := FALSE;
              RETURN;
            IFEND;

{ Signal the target with a reconnect request using the SSN and target GTID

            reconnect_signal.signal_id := jmc$timesharing_signal_id;
            reconnect_signal.signal_contents.signal_kind := jmc$timesharing_reconnect;
            reconnect_signal.signal_contents.reconnect.system_supplied_job_name := jmv$jcb.system_name;
            reconnect_signal.signal_contents.reconnect.paired_connection_reconnect := FALSE;
            pmp$send_signal (timesharing_signal.signal_contents.disconnect.target_job_global_task_id,
                  reconnect_signal.signal, local_status);
            IF NOT local_status.normal THEN
              log_unexpected_status (local_status);
              nap$cancel_switch_offer (osc$timesharing_terminal_file, ignore_status);
              nlp$unsimulate_connection_broke (osc$timesharing_terminal_file, unsimulate_broken_status);
              IF pmp$zero_ts_conditions_in_task () THEN
                pmp$enable_ts_io_in_tasks;
              IFEND;
              nlp$register_nominal_connection (osc$timesharing_terminal_file, ignore_status);
              jmv$ts_job_disconnected := FALSE;
              IF NOT unsimulate_broken_status.normal THEN
                send_line_disconnect;
              ELSE
                output_message (' The attempt to signal the target job failed.');
              IFEND;
              cause_condition := FALSE;
              RETURN;
            IFEND;

{ Wait for the signaled job to pick up to connection

            PUSH wait_list_p: [1 .. 2];
            wait_list_p^ [1].activity := osc$i_await_time;
            wait_list_p^ [1].milliseconds := connection_switch_timeout;
            wait_list_p^ [2].activity := nac$i_await_switch_accept;
            wait_file := osc$timesharing_terminal_file;
            wait_list_p^ [2].file := ^wait_file;
            osp$i_await_activity (wait_list_p^, wait_activity, wait_complete, local_status);

{ Did something go wrong or did we timeout? - if so - consider it an error an back out.

            IF (NOT local_status.normal) OR (wait_activity = 1) THEN
              IF local_status.normal THEN
                log_message ('The switch offer was not accepted by the target job.');
              ELSE
                log_unexpected_status (local_status);
              IFEND;
              nap$cancel_switch_offer (osc$timesharing_terminal_file, ignore_status);
              nlp$unsimulate_connection_broke (osc$timesharing_terminal_file, unsimulate_broken_status);
              IF pmp$zero_ts_conditions_in_task () THEN
                pmp$enable_ts_io_in_tasks;
              IFEND;
              nlp$register_nominal_connection (osc$timesharing_terminal_file, ignore_status);
              jmv$ts_job_disconnected := FALSE;
              IF NOT unsimulate_broken_status.normal THEN
                send_line_disconnect;
              ELSE
                output_message (' The switch offer was not accepted by the target job.');
              IFEND;
              cause_condition := FALSE;
              RETURN;
            IFEND;

          ELSE { The job is on a different mainframe
            paired_connection_data.connection_request := jmc$pcr_attach_job_request;
            paired_connection_data.attach_job_request.system_job_name :=
                  timesharing_signal.signal_contents.disconnect.target_job_system_supplied_name;
            jmp$get_encrypted_password (paired_connection_data.attach_job_request.encrypted_password,
                  ignore_status);
            jmp$generate_timesharing_title (timesharing_signal.signal_contents.disconnect.
                  target_job_mainframe_id, destination_title);

{ IO in all tasks has ended.  Enable IO (that is, back out of the simulation of
{ the disconnect).  This will allow this task to do IO on the connection, which is
{ required in order to create a paired connection.
{ It is possible that the job will disconnect while in wait.  In fact, a clear
{ will be sent from the other host which will cause a disconnect to occur.
{ If that is the case, This request was sucessful.

            nlp$unsimulate_connection_broke (osc$timesharing_terminal_file, unsimulate_broken_status);
            jmv$ts_job_disconnected := FALSE;

            clp$get_system_file_id (clc$job_output, file_id, ignore_status);
            iip$vtp_create_paired_connect (file_id, destination_title, #SEQ (paired_connection_data),
                  paired_connect_timeout_interval, local_status);
            IF NOT local_status.normal THEN
              log_unexpected_message ('Create paired connection failed with...');
              log_unexpected_status (local_status);
              paired_connection_data.connection_request := jmc$pcr_attach_job_results;
              paired_connection_data.attach_job_results.successful := FALSE;
              iip$vtp_delete_paired_connect (file_id, #SEQ (paired_connection_data), local_status);
              IF NOT local_status.normal THEN
                log_unexpected_message ('Delete paired connection failed with...');
                log_unexpected_status (local_status);
              IFEND;
              IF NOT jmv$ts_job_disconnected THEN
                IF pmp$zero_ts_conditions_in_task () THEN
                  pmp$enable_ts_io_in_tasks;
                IFEND;
                nlp$register_nominal_connection (osc$timesharing_terminal_file, ignore_status);
                output_message (' The attempt to reconnect to the target job failed.');
              IFEND;
              cause_condition := FALSE;
              RETURN;
            IFEND;

            PUSH termination_attributes_p: [1 .. 1];
            termination_attributes_p^ [1].kind := nac$connection_state;
            termination_attributes_p^ [1].connection_state := nac$established;
            current_clock := #FREE_RUNNING_CLOCK (0);
            time_left := paired_connect_timeout_interval;
            WHILE (NOT jmv$ts_job_disconnected) AND (time_left > 0) AND
                  (termination_attributes_p^ [1].connection_state <> nac$terminated) DO
              pmp$long_term_wait (time_left DIV 12, time_left DIV 12);
              nap$get_attributes (osc$timesharing_terminal_file, termination_attributes_p^, local_status);
              time_left := paired_connect_timeout_interval - ((#FREE_RUNNING_CLOCK (0) - current_clock) DIV
                    1000);
            WHILEND;

            IF jmv$ts_job_disconnected OR (termination_attributes_p^ [1].connection_state =
                  nac$terminated) THEN

{ Need to look at the peer termination data to verify that the job was disconnected due
{ to a successful attach job request - The peer termination data should contain the
{ fact that the attach job request was successful.

              PUSH termination_data_p: [[REP 256 OF cell]];
              PUSH termination_attributes_p: [1 .. 1];
              termination_attributes_p^ [1].kind := nac$peer_termination_data;
              termination_attributes_p^ [1].peer_termination_data := termination_data_p;
              nap$get_attributes (osc$timesharing_terminal_file, termination_attributes_p^, local_status);
              IF NOT local_status.normal THEN
                log_unexpected_message ('Unable to get peer termination data for a paired connection.');
                log_unexpected_status (local_status);
                cause_condition := FALSE;
                RETURN;
              ELSE
                RESET termination_data_p;
                NEXT paired_connection_data_p IN termination_data_p;
                IF (paired_connection_data_p = NIL) OR (termination_attributes_p^ [1].
                      peer_termination_data_length < #SIZE (paired_connection_data_p^)) OR
                      (paired_connection_data_p^.connection_request <> jmc$pcr_attach_job_results) OR
                      (NOT paired_connection_data_p^.attach_job_results.successful) THEN

                  log_message (
                        'Job disconnected while waiting for partner mainframe to delete the connection.');
                  cause_condition := FALSE;
                  RETURN;
                IFEND;
              IFEND;
            ELSE

{ Backout - The job should have been disconnected.  The target job must not have picked up the connection.
{   Delete the paired connection and return.

              log_unexpected_message ('The target job failed to delete the paired connection.');
              paired_connection_data.connection_request := jmc$pcr_attach_job_results;
              paired_connection_data.attach_job_results.successful := FALSE;
              iip$vtp_delete_paired_connect (file_id, #SEQ (paired_connection_data), local_status);
              IF NOT local_status.normal THEN
                log_unexpected_message ('Delete paired connection failed with...');
                log_unexpected_status (local_status);
              IFEND;
              IF NOT jmv$ts_job_disconnected THEN
                IF pmp$zero_ts_conditions_in_task () THEN
                  pmp$enable_ts_io_in_tasks;
                IFEND;
                nlp$register_nominal_connection (osc$timesharing_terminal_file, ignore_status);
                output_message (' The attempt to reconnect to the target job failed.');
              IFEND;
              cause_condition := FALSE;
              RETURN;
            IFEND;

          IFEND;

{ Signal the job_monitor task to go away (timeout)

          terminate_signal.signal_id := jmc$timesharing_signal_id;
          terminate_signal.signal_contents.signal_kind := jmc$timesharing_timeout;
          pmp$send_signal (jmv$jcb.job_monitor_id, terminate_signal.signal, ignore_status);

{ Set the job mode to tell the world that the job is disconnected.

          jmp$set_job_mode (jmc$interactive_cmnd_disconnect, ignore_status);




        = jmc$ts_detach_job =

{ Get the required information about the user

          PUSH job_attribute_p: [1 .. 5];
          job_attribute_p^ [1].key := jmc$login_family;
          job_attribute_p^ [2].key := jmc$login_user;
          job_attribute_p^ [3].key := jmc$login_account;
          job_attribute_p^ [4].key := jmc$login_project;
          job_attribute_p^ [5].key := jmc$job_class;
          jmp$get_job_attributes (job_attribute_p, ignore_status);

{ Submit a job with the SSN value for system job parameters

          PUSH job_submission_options: [1 .. 10];
          job_submission_options^ [1].key := jmc$origin_application_name;
          job_submission_options^ [1].origin_application_name := osc$timesharing;
          job_submission_options^ [2].key := jmc$login_command_supplied;
          job_submission_options^ [2].login_command_supplied := FALSE;
          job_submission_options^ [3].key := jmc$login_family;
          job_submission_options^ [3].login_family := job_attribute_p^ [1].login_family;
          job_submission_options^ [4].key := jmc$login_user;
          job_submission_options^ [4].login_user := job_attribute_p^ [2].login_user;
          job_submission_options^ [5].key := jmc$immediate_init_candidate;
          job_submission_options^ [5].immediate_init_candidate := TRUE;
          job_submission_options^ [6].key := jmc$job_class;
          job_submission_options^ [6].job_class := job_attribute_p^ [5].job_class;
          job_submission_options^ [7].key := jmc$system_job_parameters;
          PUSH job_submission_options^ [7].system_job_parameters;
          job_submission_options^ [8].key := jmc$login_account;
          job_submission_options^ [8].login_account := job_attribute_p^ [3].login_account;
          job_submission_options^ [9].key := jmc$login_project;
          job_submission_options^ [9].login_project := job_attribute_p^ [4].login_project;
          job_submission_options^ [10].key := jmc$job_destination_usage;
          job_submission_options^ [10].job_destination_usage := jmc$ve_local_usage;
          submit_variation.kind := jmc$connection_switch;
          submit_variation.job_offering_connection := jmv$jcb.system_name;
          job_submission_options^ [7].system_job_parameters^.system_job_parameter_count :=
                #SIZE (submit_variation);
          i#move (^submit_variation, ^job_submission_options^ [7].system_job_parameters^.
                system_job_parameter, #SIZE (submit_variation));
          submitted_job_name.kind := jmc$system_supplied_name;

          jmp$submit_job (clc$null_file, job_submission_options, submitted_job_name.system_supplied_name,
                local_status);
          IF NOT local_status.normal THEN
            log_status (local_status);
            nlp$unsimulate_connection_broke (osc$timesharing_terminal_file, unsimulate_broken_status);
            IF pmp$zero_ts_conditions_in_task () THEN
              pmp$enable_ts_io_in_tasks;
            IFEND;
            nlp$register_nominal_connection (osc$timesharing_terminal_file, ignore_status);
            jmv$ts_job_disconnected := FALSE;
            IF NOT unsimulate_broken_status.normal THEN
              send_line_disconnect;
            ELSE
              output_message (' The attempt to submit a new job failed - see the job log for details.');
            IFEND;
            cause_condition := FALSE;
            RETURN;
          IFEND;

{ Offer the submitted job the connection

          nlp$offer_connection_switch (osc$timesharing_terminal_file, submitted_job_name.system_supplied_name,
                TRUE, local_status);
          IF NOT local_status.normal THEN
            log_unexpected_status (local_status);
            PUSH job_termination_options: [1 .. 1];
            job_termination_options^ [1].key := jmc$output_disposition;
            job_termination_options^ [1].output_disposition.key := jmc$discard_standard_output;
            jmp$terminate_job (submitted_job_name, job_termination_options, ignore_status);
            nlp$unsimulate_connection_broke (osc$timesharing_terminal_file, unsimulate_broken_status);
            IF pmp$zero_ts_conditions_in_task () THEN
              pmp$enable_ts_io_in_tasks;
            IFEND;
            nlp$register_nominal_connection (osc$timesharing_terminal_file, ignore_status);
            jmv$ts_job_disconnected := FALSE;
            IF NOT unsimulate_broken_status.normal THEN
              send_line_disconnect;
            ELSE
              output_message (' The attempt to offer the connection to the new job failed.');
            IFEND;
            cause_condition := FALSE;
            RETURN;
          IFEND;

{ Wait for the job submitted to pick up the connection.

          PUSH wait_list_p: [1 .. 2];
          wait_list_p^ [1].activity := osc$i_await_time;
          wait_list_p^ [1].milliseconds := connection_switch_timeout;
          wait_list_p^ [2].activity := nac$i_await_switch_accept;
          wait_file := osc$timesharing_terminal_file;
          wait_list_p^ [2].file := ^wait_file;
          osp$i_await_activity (wait_list_p^, wait_activity, wait_complete, local_status);

{ Did something go wrong or did we timeout? - if so - consider it an error and back out.

          IF (NOT local_status.normal) OR (wait_activity = 1) THEN
            IF local_status.normal THEN
              log_message ('The switch offer was not accepted by the new job.');
            ELSE
              log_unexpected_status (local_status);
            IFEND;
            nap$cancel_switch_offer (osc$timesharing_terminal_file, ignore_status);
            PUSH job_termination_options: [1 .. 1];
            job_termination_options^ [1].key := jmc$output_disposition;
            job_termination_options^ [1].output_disposition.key := jmc$discard_standard_output;
            jmp$terminate_job (submitted_job_name, job_termination_options, ignore_status);
            nlp$unsimulate_connection_broke (osc$timesharing_terminal_file, unsimulate_broken_status);
            IF pmp$zero_ts_conditions_in_task () THEN
              pmp$enable_ts_io_in_tasks;
            IFEND;
            nlp$register_nominal_connection (osc$timesharing_terminal_file, ignore_status);
            jmv$ts_job_disconnected := FALSE;
            IF NOT unsimulate_broken_status.normal THEN
              send_line_disconnect;
            ELSE
              output_message (' The switch offer was not accepted by the new job.');
            IFEND;
            cause_condition := FALSE;
            RETURN;
          IFEND;

{ Set the job mode to let the world know that the job is disconnected.

          jmp$set_job_mode (jmc$interactive_cmnd_disconnect, ignore_status);

        = jmc$ts_system_disconnect =
          jmp$set_job_mode (jmc$interactive_sys_disconnect, ignore_status);

        ELSE
          log_unexpected_message ('An unknown disconnect message was received.');
          output_message ('A problem occured within disconnect processing - see the job log for details');
          cause_condition := FALSE;
          RETURN;
        CASEND;


{ Emit the statistic AV21 for all cases of disconnect_reason

        sfp$emit_statistic (avc$detach_job, '', NIL, ignore_status);


        log_message ('Interactive disconnect.');

      PROCEND handle_disconnect;
?? OLDTITLE ??
?? NEWTITLE := 'handle_reconnect', EJECT ??

      PROCEDURE handle_reconnect
        (    timesharing_signal: jmt$timesharing_signal;
         VAR cause_condition: boolean);

        VAR
          file_id: amt$file_identifier,
          get_attributes: array [1 .. 1] of nat$get_attribute,
          get_terminal_name: array [1 .. 1] of nat$accounting_data_field,
          ignore_status: ost$status,
          job_attribute_p: ^jmt$job_attribute_results,
          job_input_device: jmt$job_input_device,
          local_status: ost$status,
          operation_information_p: ^sft$audit_information,
          operation_status_p: ^ost$status,
          paired_connection_data: jmt$paired_connection_data,
          peer_accounting_info: ^string ( * );

{ Accept the switch offer using the SSN in the signal

        nlp$accept_switch_offer (osc$timesharing_terminal_file,
              timesharing_signal.signal_contents.reconnect.system_supplied_job_name, NIL, TRUE, local_status);
        IF NOT local_status.normal THEN
          log_unexpected_message ('Could not get the switched connection.');
          log_unexpected_status (local_status);
          IF pmp$zero_ts_conditions_in_task () THEN
            pmp$enable_ts_io_in_tasks;
            cause_condition := FALSE;
            RETURN;
          IFEND;
        IFEND;

{ At this point we are committed to attaching the job to the terminal.

        IF timesharing_signal.signal_contents.reconnect.paired_connection_reconnect THEN
          paired_connection_data.connection_request := jmc$pcr_attach_job_results;
          paired_connection_data.attach_job_results.successful := TRUE;

{ Allow the job to do IO on a connection.  This allows another task to open
{ the file to delete the paired connection.

          jmv$ts_job_disconnected := FALSE;
          pmp$enable_timesharing_io;
          clp$get_system_file_id (clc$job_output, file_id, ignore_status);
          iip$vtp_delete_paired_connect (file_id, #SEQ (paired_connection_data), local_status);
          jmv$ts_job_disconnected := TRUE;
          IF NOT local_status.normal THEN
            log_unexpected_message ('handle_reconnect - iip$vtp_delete_paired_connect failed with...');
            log_unexpected_status (local_status);
          IFEND;
        IFEND;

        nlp$register_nominal_connection (osc$timesharing_terminal_file, ignore_status);

{ Emit the statistic AV22 for the reconnected job

        sfp$emit_statistic (avc$attach_job, '', NIL, ignore_status);

{ Change the job mode to connected

        jmp$set_job_mode (jmc$interactive_connected, ignore_status);

{ Reset the Terminal_Name terminal attribute in the connection description and the
{ Job_Input_Device job attribute.

        get_attributes [1].kind := nac$peer_accounting_information;
        PUSH get_attributes [1].peer_accounting_information: [[REP 256 OF char]];
        nap$get_attributes (osc$timesharing_terminal_file, get_attributes, local_status);
        IF NOT local_status.normal THEN
          log_message ('Error getting Peer Accounting Information from NAP$GET_ATTRIBUTES.');
          log_status (local_status);
        IFEND;

        IF get_attributes [1].peer_accounting_info_length <> 0 THEN
          RESET get_attributes [1].peer_accounting_information;
          NEXT peer_accounting_info: [get_attributes [1].peer_accounting_info_length] IN
                get_attributes [1].peer_accounting_information;

          job_input_device.size := get_attributes [1].peer_accounting_info_length;
          job_input_device.text := peer_accounting_info^;
          jmp$set_job_input_device (job_input_device);

          get_terminal_name [1].kind := nac$ca_device_name;
          nap$parse_accounting_data (peer_accounting_info, NIL, ^get_terminal_name, local_status);
          IF local_status.normal AND (get_terminal_name [1].kind = nac$ca_device_name) THEN
            iip$set_terminal_name (get_terminal_name [1].device_name);
          ELSE
            IF NOT local_status.normal THEN
              log_message ('Error getting Device Name from NAP$PARSE_ACCOUNTING_DATA.');
            IFEND;
            iip$set_terminal_name (osc$null_name);
          IFEND;
        ELSE
          iip$set_terminal_name (osc$null_name);
        IFEND;

{ Emit the audit statistic if necessary.

        IF avp$security_option_active (avc$vso_security_audit) THEN
          PUSH job_attribute_p: [1 .. 4];
          job_attribute_p^ [1].key := jmc$login_family;
          job_attribute_p^ [2].key := jmc$login_user;
          job_attribute_p^ [3].key := jmc$login_account;
          job_attribute_p^ [4].key := jmc$login_project;
          jmp$get_job_attributes (job_attribute_p, ignore_status);

          PUSH operation_information_p;
          operation_information_p^.audited_operation := sfc$ao_job_user_identification;
          operation_information_p^.user_identification.family_name_p := ^job_attribute_p^ [1].login_family;
          operation_information_p^.user_identification.user_name_p := ^job_attribute_p^ [2].login_user;
          operation_information_p^.user_identification.account_name_p := ^job_attribute_p^ [3].login_account;
          operation_information_p^.user_identification.project_name_p := ^job_attribute_p^ [4].login_project;
          IF local_status.normal AND (get_terminal_name [1].kind = nac$ca_device_name) THEN
            operation_information_p^.user_identification.terminal_name_p := ^get_terminal_name [1].
                  device_name;
          ELSE
            operation_information_p^.user_identification.terminal_name_p := NIL;
          IFEND;
          PUSH operation_status_p;
          operation_status_p^.normal := TRUE;
          sfp$emit_audit_statistic (operation_information_p^, operation_status_p^);
        IFEND;

{ Unmark the job as being disconnected

        log_message ('Interactive reconnect.');
        jmv$ts_job_disconnected := FALSE;

{ Restore the active connection attributes of the reconnected job.

        iip$restore_term_conn_atributes (local_status);
        IF NOT local_status.normal THEN
          log_unexpected_message ('Error restoring the active connection attributes of the reconnected job.');
          log_unexpected_status (local_status);
        IFEND;

      PROCEND handle_reconnect;
?? OLDTITLE ??
?? NEWTITLE := 'confirm_synchronization', EJECT ??

      PROCEDURE confirm_synchronization
        (VAR status: ost$status);

        VAR
          ignore_status: ost$status,
          terminal_file_id: amt$file_identifier;

        fsp$open_file (osc$timesharing_terminal_file, amc$record, NIL, NIL, NIL, NIL, NIL, terminal_file_id,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        nap$se_synchronize_confirm (terminal_file_id, status);
        IF NOT status.normal THEN
          fsp$close_file (terminal_file_id, ignore_status);
          RETURN;
        IFEND;

        fsp$close_file (terminal_file_id, status);
      PROCEND confirm_synchronization;

?? OLDTITLE, EJECT ??

      VAR
        condition_id: ift$interactive_condition,
        cause_condition: boolean,
        local_status: ost$status,
        ignore_status: ost$status;

      cause_condition := TRUE;

      CASE timesharing_signal.signal_contents.signal_kind OF

      = jmc$timesharing_disconnect =
        condition_id := ifc$terminal_connection_broken;

        handle_disconnect (timesharing_signal, cause_condition);
        IF (NOT cause_condition) THEN
          RETURN;
        IFEND;

{ Enable IO within this task - this request must take place only when if
{ a condition is going to be raised.

        pmp$begin_timesharing_condition;
        pmp$enable_timesharing_io;

{ We must back-out of the condition state for the task.  That is, pretend as though a handler was called and
{ ate the condition and then returned.  This is a kludge, but it is cleaner than confusing the normal path
{ of conditions through timesharing more than it is.
{ The above requests, pmp$begin_timesharing_condition and pmp$enable_timesharing_io have the effect as
{ follows:
{ o The task's condition count in the TCB is incremented by one.
{ o The task's enable/disable flag for terminal IO is enabled.
{ If a condition is not going to be raised, the task's condition count must, potentially be reduced...but we
{ can't unconditionally reset it to zero.  The number of conditions within a task, only goes to zero when the
{ number of handlers processing that condition goes from one to zero (see module design section).  This is
{ complicated by the presence of multiple synch requests from the user.  Therefore, treat it as though a
{ condition handler were called, jmp$begin_timesharing_handler and the condition handler ate the condition.
{ This returns control and jmp$end_timesharing_handler is called, which, if necessary, will put the TCB back
{ into the proper state.  This is analogous to what pmp$dispose_interactive_cond does.

        IF jmv$interactive_conds_disabled THEN
          jmp$begin_timesharing_handler (condition_id);
          jmp$end_timesharing_handler (condition_id);
          RETURN;
        IFEND;

      = jmc$timesharing_reconnect =
        condition_id := ifc$job_reconnect;

        handle_reconnect (timesharing_signal, cause_condition);
        IF (NOT cause_condition) THEN
          RETURN;
        IFEND;

{ Enable IO within this task - this request must take place only when if
{ a condition is going to be raised.

        pmp$begin_timesharing_condition;
        pmp$enable_timesharing_io;

{ We must back-out of the condition state for the task.  That is, pretend as though a handler was called and
{ ate the condition and then returned.  This is a kludge, but it is cleaner than confusing the normal path
{ of conditions through timesharing more than it is.
{ The above requests, pmp$begin_timesharing_condition and pmp$enable_timesharing_io have the effect as
{ follows:
{ o The task's condition count in the TCB is incremented by one.
{ o The task's enable/disable flag for terminal IO is enabled.
{ If a condition is not going to be raised, the task's condition count must, potentially be reduced...but we
{ can't unconditionally reset it to zero.  The number of conditions within a task, only goes to zero when the
{ number of handlers processing that condition goes from one to zero (see module design section).  This is
{ complicated by the presence of multiple synch requests from the user.  Therefore, treat it as though a
{ condition handler were called, jmp$begin_timesharing_handler and the condition handler ate the condition.
{ This returns control and jmp$end_timesharing_handler is called, which, if necessary, will put the TCB back
{ into the proper state.  This is analogous to what pmp$dispose_interactive_cond does.

        IF jmv$interactive_conds_disabled THEN
          jmp$begin_timesharing_handler (condition_id);
          jmp$end_timesharing_handler (condition_id);
          RETURN;
        IFEND;

      = jmc$timesharing_synchronize =

{ Enable IO within this task - this request must take place before synchronization takes place
{ otherwise the job can hang.  If this is not the job monitor task, and we synchronize first, and
{ then enable IO, the job monitor task could begin processing another synch request and disable IO
{ and this could radically confuse the enable/disable state of a task so far as terminal IO is
{ concerned.

        pmp$begin_timesharing_condition;
        pmp$enable_timesharing_io;

{ This request synchronizes the connection - this enables NAM/VE to send additional synchronize
{ requests - we will ignore such requests until we go into a long term wait or exit from ring three.
{ If this request should ever fail for some reason - the job will hang - as a result of this
{ occuring - an attempt will be made to bring the job down as if the user had entered logout.
{ If the request should fail due to a connection broken, an error will be returned - in this case,
{ the desired solution is to "ignore" the synchronize and not raise a condition.

        confirm_synchronization (local_status);
        IF NOT local_status.normal THEN
          IF (local_status.condition = nae$connection_terminated) OR
                (local_status.condition = nae$connection_not_established) THEN
            RETURN; { Don't raise the condition
          ELSE
            log_unexpected_status (local_status);
            log_unexpected_message ('An attempt to synchronize a NAM/VE connection has occured.');
            log_unexpected_message ('Attempting to logout the job gracefully.');
            jmp$logout (ignore_status);
          IFEND;
        IFEND;

        IF timesharing_signal.signal_contents.synchronize (1) = pause_break_char THEN
          condition_id := ifc$pause_break;
        ELSE
          condition_id := ifc$terminate_break;
        IFEND;

        log_message ('User break received.');

        IF jmv$terminal_io_disabled OR (NOT jmv$user_breaks_enabled) OR (jmv$interactive_conds_disabled) THEN

{ We must back-out of the condition state for the task.  That is, pretend as though a handler was called and
{ ate the condition and then returned.  This is a kludge, but it is cleaner than confusing the normal path
{ of conditions through timesharing more than it is.
{ The above requests, pmp$begin_timesharing_condition and pmp$enable_timesharing_io have the effect as
{ follows:
{ o The task's condition count in the TCB is incremented by one.
{ o The task's enable/disable flag for terminal IO is enabled.
{ If a condition is not going to be raised, the task's condition count must, potentially be reduced...but we
{ can't unconditionally reset it to zero.  The number of conditions within a task, only goes to zero when the
{ number of handlers processing that condition goes from one to zero (see module design section).  This is
{ complicated by the presence of multiple synch requests from the user.  Therefore, treat it as though a
{ condition handler were called, jmp$begin_timesharing_handler and the condition handler ate the condition.
{ This returns control and jmp$end_timesharing_handler is called, which, if necessary, will put the TCB back
{ into the proper state.  This is analogous to what pmp$dispose_interactive_cond does.

          jmp$begin_timesharing_handler (condition_id);
          jmp$end_timesharing_handler (condition_id);
          RETURN;
        IFEND

      ELSE
        log_unexpected_message ('An attempt was made to raise an unknown interactive condition.');
        output_message ('A unknown interactive condition has occured - examine the job log for details.');
        RETURN;
      CASEND;

{ Raise the interactive condition in the current ring.

      pmp$dispose_interactive_cond (condition_id);
    PROCEND raise_condition;
?? OLDTITLE ??
?? NEWTITLE := 'signal_job_synchronous_task', EJECT ??

{ NOTE: This request is only called by the job monitor task.

    PROCEDURE signal_job_synchronous_task
      (    signal: pmt$signal;
       VAR excuting_in_job_synch_task: boolean;
       VAR status: ost$status);

      VAR
        task_id: pmt$task_id,
        current_synchronous_gtid: ost$global_task_id;

      status.normal := TRUE;
      executing_in_job_synch_task := FALSE;

      clp$find_current_job_synch_task (task_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      pmp$get_global_task_id (task_id, current_synchronous_gtid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF current_synchronous_gtid <> jmv$jcb.job_monitor_id THEN
        pmp$send_signal (current_synchronous_gtid, signal, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSE
        executing_in_job_synch_task := TRUE;
      IFEND;
    PROCEND signal_job_synchronous_task;
?? OLDTITLE ??
?? NEWTITLE := 'timesharing_block_exit_handler', EJECT ??

    PROCEDURE timesharing_block_exit_handler
      (    condition: pmt$condition;
           ignore_condition_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      raise_condition (timesharing_signal);
      handler_status.normal := TRUE;
    PROCEND timesharing_block_exit_handler;

?? OLDTITLE, EJECT ??


    timesharing_signal.signal := signal;

{ Check for special signals.

    check_for_special_signals (timesharing_signal, signal_processed, local_status);
    IF NOT local_status.normal THEN
      log_unexpected_status (local_status);
    IFEND;
    IF signal_processed THEN
      RETURN;
    IFEND;

{ Check to see if this is the job_monitor task.

    pmp$get_executing_task_gtid (executing_gtid);
    IF executing_gtid = jmv$jcb.job_monitor_id THEN

{ We only want to propogate the signal if the job is a timesharing or xterm job.

      IF NOT jmv$timesharing_job THEN
        IF NOT jmp$is_xterm_job () THEN
          log_unexpected_message ('Received a timesharing signal in a NON-timesharing job.');
          RETURN;
        IFEND;
      IFEND;

{ If the signal is disconnect - mark the job as disconnected (internally)

      IF (timesharing_signal.signal_contents.signal_kind = jmc$timesharing_disconnect) THEN

{ Mark the job as disconnected

        IF jmv$ts_job_disconnected THEN
          log_unexpected_message ('Received a disconnect signal in a disconnected job.');
          RETURN;
        IFEND;
        jmv$ts_job_disconnected := TRUE;

        statistic_data.statistic_id := jmc$ca_interactive_interval;
        jmp$emit_communication_stat (statistic_data);

        IF timesharing_signal.signal_contents.disconnect.disconnect_reason = jmc$ts_line_disconnect THEN

{ Call a network interface to indicate that the nominal connection has been disconnected

          nlp$record_nominal_disconnect (osc$timesharing_terminal_file, local_status);
          IF NOT local_status.normal THEN
            log_unexpected_status (local_status);
          IFEND;
        IFEND;
      IFEND;

{ Disable IO within all tasks in the job - except job monitor
{ Having gotten this far indicates that we should raise a condition within the current
{ job synchronous task.

      pmp$disable_ts_io_in_tasks;

{ Send a signal (if necessary) to the current job synchronous task.

      signal_job_synchronous_task (timesharing_signal.signal, executing_in_job_synch_task, local_status);
      IF NOT local_status.normal THEN
        signal_job_synchronous_task (timesharing_signal.signal, executing_in_job_synch_task, local_status);
        IF NOT local_status.normal THEN
          log_unexpected_message ('Couldn''t signal the current synchronous task.');
          log_unexpected_status (local_status);

{ If problems, raise the condition in the job monitor task

          executing_in_job_synch_task := TRUE;
        IFEND;
      IFEND;

{ If we are not the current job synchronous task then we are done.

      IF NOT executing_in_job_synch_task THEN
        RETURN;
      IFEND;
    IFEND;

{ The rest of the code contained in this signal handler is executed by the job's
{ current job synchronous task, i.e., the task that the user is talking to.

{ Establish a block exit handler in case we see a non-local exit.

    osp$establish_block_exit_hndlr (^timesharing_block_exit_handler);

{ Interrupt all terminal manager I/O requests.  This request may potentially be interrupted.
{ This signal handler may be invoked again by a disconnect or and reconnect request.  The
{ CDCNET connection is frozen by any synchronize requests so any further synchronize requests
{ will be "ignored" until the confirmation is sent to NAM/VE.

    iip$interrupt_timesharing_io (local_status);
    IF NOT local_status.normal THEN
      log_unexpected_status (local_status);
    IFEND;

{ Disestablish the block exit handler - the following operations do not require protection.

    osp$disestablish_cond_handler;

{ At this point, no tasks in the job have any active I/O requests and they can't start any.
{ This request determines the identity of the condition to be raised.  It also performs any
{ pre-condition processing that is necessary.  It then raises the condition in the task.

    raise_condition (timesharing_signal);

  PROCEND jmp$timesharing_signal_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$validate_paired_connection', EJECT ??
*copy jmh$validate_paired_connection

  PROCEDURE [XDCL] jmp$validate_paired_connection
    (    unvalidated_connection_data_p: ^SEQ ( * );
     VAR login_family: ost$name;
     VAR login_user: ost$name;
     VAR system_job_name: jmt$system_supplied_name;
     VAR connection_request_kind: jmt$paired_connection_request;
     VAR status: ost$status);

    VAR
      job_status_count: jmt$job_status_count,
      job_status_options_p: ^jmt$job_status_options,
      job_status_results_keys_p: ^jmt$results_keys,
      job_status_results_seq_p: ^jmt$work_area,
      job_status_results_p: ^jmt$job_status_results,
      paired_connection_data_p: ^jmt$paired_connection_data,
      paired_connection_seq_p: ^SEQ ( * ),
      size_of_sequence: ost$segment_length,
      validation_options_p: ^jmt$user_validation_options;

    status.normal := TRUE;

    paired_connection_seq_p := unvalidated_connection_data_p;
    RESET paired_connection_seq_p;
    NEXT paired_connection_data_p IN paired_connection_seq_p;
    IF paired_connection_data_p = NIL THEN
      osp$set_status_condition (jme$invalid_paired_connection, status);
      RETURN;
    IFEND;

    IF (paired_connection_data_p^.connection_request <> jmc$pcr_attach_job_request) AND
          (paired_connection_data_p^.connection_request <> jmc$pcr_leveled_job_request) THEN
      osp$set_status_condition (jme$invalid_paired_connection, status);
      RETURN;
    IFEND;

    connection_request_kind := paired_connection_data_p^.connection_request;

    PUSH job_status_options_p: [1 .. 1];
    job_status_options_p^ [1].key := jmc$name_list;
    PUSH job_status_options_p^ [1].name_list: [1 .. 1];
    job_status_options_p^ [1].name_list^ [1].kind := jmc$system_supplied_name;
    IF (paired_connection_data_p^.connection_request = jmc$pcr_attach_job_request) THEN
      job_status_options_p^ [1].name_list^ [1].system_supplied_name :=
            paired_connection_data_p^.attach_job_request.system_job_name;
    ELSE {paired_connection_data_p^.connection_request = jmc$pcr_leveled_job_request
      job_status_options_p^ [1].name_list^ [1].system_supplied_name :=
            paired_connection_data_p^.leveled_job_request.system_job_name;
    IFEND;

    PUSH job_status_results_keys_p: [1 .. 2];
    job_status_results_keys_p^ [1] := jmc$login_family;
    job_status_results_keys_p^ [2] := jmc$login_user;

    jmp$get_result_size ({job_count} 1, #SEQ (job_status_results_keys_p^), size_of_sequence);
    PUSH job_status_results_seq_p: [[REP size_of_sequence OF cell]];
    RESET job_status_results_seq_p;
    jmp$get_job_status (job_status_options_p, job_status_results_keys_p, job_status_results_seq_p,
          job_status_results_p, job_status_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH validation_options_p: [1 .. 1];
    validation_options_p^ [1].key := jmc$encrypted_password;
    IF (paired_connection_data_p^.connection_request = jmc$pcr_attach_job_request) THEN
      validation_options_p^ [1].encrypted_password := paired_connection_data_p^.attach_job_request.
            encrypted_password;
    ELSE {paired_connection_data_p^.connection_request = jmc$pcr_leveled_job_request
      validation_options_p^ [1].encrypted_password := paired_connection_data_p^.leveled_job_request.
            encrypted_password;
    IFEND;

    jmp$validate_user (job_status_results_p^ [1]^ [1].login_family, job_status_results_p^ [1]^ [2].login_user,
          validation_options_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (paired_connection_data_p^.connection_request = jmc$pcr_attach_job_request) THEN
      system_job_name := paired_connection_data_p^.attach_job_request.system_job_name;
    ELSE {paired_connection_data_p^.connection_request = jmc$pcr_leveled_job_request
      system_job_name := paired_connection_data_p^.leveled_job_request.system_job_name;
    IFEND;
    login_family := job_status_results_p^ [1]^ [1].login_family;
    login_user := job_status_results_p^ [1]^ [2].login_user;
  PROCEND jmp$validate_paired_connection;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$clone_login', EJECT ??

  PROCEDURE [XDCL] jmp$clone_login
    (VAR status: ost$status);

    CONST
      paired_connect_timeout_interval = 120000; { in milliseconds

    VAR
      binary_mainframe_id: pmt$binary_mainframe_id,
      connection_attributes: ^nat$create_attributes,
      encrypted_password: ost$name,
      executing_job_name: jmt$system_supplied_name,
      get_attributes: array [1 .. 1] of nat$get_attribute,
      get_terminal_name: array [1 .. 1] of nat$accounting_data_field,
      ignore_status: ost$status,
      job_input_device: jmt$job_input_device,
      job_parameters: jmt$system_job_parameters,
      local_status: ost$status,
      paired_connection_data: jmt$paired_connection_data,
      peer_accounting_info: ^string ( * ),
      submit_variation: jmt$submit_job_variations,
      timesharing_title: ost$name,
      user_supplied_name: jmt$user_supplied_name;

    CONST
      acquire_timeout = 60,
      max_connections = 1;

    job_parameters := jmv$kjlx_p^ [jmv$jcb.job_id].system_label_p^.job_attributes.system_job_parameters;

    fmp$disconnect_for_clone (osc$timesharing_terminal_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH connection_attributes: [1 .. 2];
    connection_attributes^ [1].kind := nac$data_transfer_timeout;
    connection_attributes^ [1].data_transfer_timeout := nac$max_wait_time;
    connection_attributes^ [2].kind := nac$receive_wait_swapout;
    connection_attributes^ [2].receive_wait_swapout := TRUE;

{If there are no job parameters then the job is an initial submit
{otherwise the type of submit is encoded in the job parameters

    IF job_parameters.system_job_parameter_count = 0 THEN
      nap$attach_server_application (osc$timesharing, max_connections, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      nap$clone_connection (osc$timesharing, osc$timesharing_terminal_file, NIL, acquire_timeout, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      nap$change_attributes (osc$timesharing_terminal_file, connection_attributes^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      nap$detach_server_application (osc$timesharing, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      nlp$register_nominal_connection (osc$timesharing_terminal_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      i#move (^job_parameters.system_job_parameter, ^submit_variation, #SIZE (submit_variation));
      IF submit_variation.kind = jmc$submit_detached_job THEN
        login_as_disconnected (status);
        RETURN;
      ELSEIF (submit_variation.kind = jmc$connection_switch) THEN
        jmp$initialize_timesharing (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSEIF (submit_variation.kind = jmc$remote_connection_switch) THEN
        nap$attach_server_application (osc$timesharing, max_connections, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        nap$clone_connection (osc$timesharing, osc$timesharing_terminal_file, NIL, acquire_timeout, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        nap$change_attributes (osc$timesharing_terminal_file, connection_attributes^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        nap$detach_server_application (osc$timesharing, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        paired_connection_data.connection_request := jmc$pcr_leveled_job_results;
        paired_connection_data.leveled_job_results.successful := TRUE;

        iip$vtp_del_paired_con_first (#SEQ (paired_connection_data), local_status);
        IF NOT local_status.normal THEN
          log_unexpected_message ('clone_login - iip$vtp_del_paired_con_first failed with...');
          log_unexpected_status (local_status);
        IFEND;

        nlp$register_nominal_connection (osc$timesharing_terminal_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSE

{Unknown type of submit request

        osp$system_error ('Unknown submit request', NIL);
      IFEND;
    IFEND;

{ Change the job mode to connected

    jmp$set_job_mode (jmc$interactive_connected, status);
    status.normal := TRUE;

{ Reset the Terminal_Name terminal attribute in the connection description and the
{ Job_Input_Device job attribute.

    get_attributes [1].kind := nac$peer_accounting_information;
    PUSH get_attributes [1].peer_accounting_information: [[REP 256 OF char]];
    nap$get_attributes (osc$timesharing_terminal_file, get_attributes, status);

    IF (status.normal) AND (get_attributes [1].peer_accounting_info_length <> 0) THEN
      RESET get_attributes [1].peer_accounting_information;
      NEXT peer_accounting_info: [get_attributes [1].peer_accounting_info_length] IN
            get_attributes [1].peer_accounting_information;

      job_input_device.size := get_attributes [1].peer_accounting_info_length;
      job_input_device.text := peer_accounting_info^;
      jmp$set_job_input_device (job_input_device);

      get_terminal_name [1].kind := nac$ca_device_name;
      nap$parse_accounting_data (peer_accounting_info, NIL, ^get_terminal_name, status);
      IF status.normal AND (get_terminal_name [1].kind = nac$ca_device_name) THEN
        iip$set_terminal_name (get_terminal_name [1].device_name);
      ELSE
        IF NOT status.normal THEN
          status.normal := TRUE;
        IFEND;
        iip$set_terminal_name (osc$null_name);
      IFEND;
    ELSE
      iip$set_terminal_name (osc$null_name);
    IFEND;

    iip$st_clone_connection (status);

  PROCEND jmp$clone_login;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$acquire_connection', EJECT ??
*copy jmh$acquire_connection

  PROCEDURE [XDCL, #GATE] jmp$acquire_connection
    (    server_name: ost$name;
     VAR service_data: jmt$service_data;
     VAR service_data_length: jmt$service_data_length;
     VAR status: ost$status);

    VAR
      connection_attributes: ^nat$create_attributes,
      get_attributes: array [1 .. 1] of nat$get_attribute,
      get_terminal_name: array [1 .. 1] of nat$accounting_data_field,
      ignore_status: ost$status,
      job_input_device: jmt$job_input_device,
      peer_accounting_info: ^string ( * ),
      timeout: nat$wait_time,
      terminal_attributes: array [1 .. 2] of ift$terminal_attribute;

    CONST
      max_connections = 1;


    nap$attach_server_application (server_name, max_connections, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ File must be marked as disconnected to acquire a new connection.  The
{ disconnect must occur after the nap$attach_server_application request in
{ case the caller specified an unknown server_name.

    fmp$disconnect_for_clone (osc$timesharing_terminal_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$clone_connection (server_name, osc$timesharing_terminal_file, NIL, nac$max_wait_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH connection_attributes: [1 .. 2];
    connection_attributes^ [1].kind := nac$data_transfer_timeout;
    connection_attributes^ [1].data_transfer_timeout := nac$max_wait_time;
    connection_attributes^ [2].kind := nac$receive_wait_swapout;
    connection_attributes^ [2].receive_wait_swapout := TRUE;

    nap$change_attributes (osc$timesharing_terminal_file, connection_attributes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$detach_server_application (server_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nlp$register_nominal_connection (osc$timesharing_terminal_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Change the job mode to connected

    jmp$set_job_mode (jmc$interactive_connected, ignore_status);
    jmv$ts_job_disconnected := FALSE;
    pmp$enable_ts_io_in_tasks;
    status.normal := TRUE;

{ Reset the Terminal_Name terminal attribute in the connection description and the
{ Job_Input_Device job attribute.

    get_attributes [1].kind := nac$peer_accounting_information;
    PUSH get_attributes [1].peer_accounting_information: [[REP 256 OF char]];
    nap$get_attributes (osc$timesharing_terminal_file, get_attributes, status);

    IF (status.normal) AND (get_attributes [1].peer_accounting_info_length <> 0) THEN
      RESET get_attributes [1].peer_accounting_information;
      NEXT peer_accounting_info: [get_attributes [1].peer_accounting_info_length] IN
            get_attributes [1].peer_accounting_information;

      job_input_device.size := get_attributes [1].peer_accounting_info_length;
      job_input_device.text := peer_accounting_info^;
      jmp$set_job_input_device (job_input_device);

      get_terminal_name [1].kind := nac$ca_device_name;
      nap$parse_accounting_data (peer_accounting_info, NIL, ^get_terminal_name, status);
      IF status.normal AND (get_terminal_name [1].kind = nac$ca_device_name) THEN
        iip$set_terminal_name (get_terminal_name [1].device_name);
      ELSE
        status.normal := TRUE;
        iip$set_terminal_name (osc$null_name);
      IFEND;
    ELSE
      iip$set_terminal_name (osc$null_name);
    IFEND;

    iip$st_clone_connection (status);

    jmv$connection_acquired := TRUE;

{The following causes the new terminal attributes to be
{rippled thru open files

    terminal_attributes [1].key := ifc$page_width;
    terminal_attributes [2].key := ifc$page_length;
    ifp$get_terminal_attributes (clc$job_output, terminal_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    ifp$change_terminal_attributes (clc$job_output, terminal_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_attributes [1].kind := nac$peer_connect_data;
    PUSH get_attributes [1].peer_connect_data: [[REP 256 OF char]];
    nap$get_attributes (osc$timesharing_terminal_file, get_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    nap$get_connect_data (get_attributes [1].peer_connect_data, service_data, service_data_length, status);

  PROCEND jmp$acquire_connection;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$return_connection', EJECT ??
*copy jmh$return_connection

  PROCEDURE [XDCL, #GATE] jmp$return_connection
    (VAR status: ost$status);

?? NEWTITLE := 'handle_condition', EJECT ??

    PROCEDURE handle_condition
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF condition.selector = ifc$interactive_condition THEN
        RETURN;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND handle_condition;

?? OLDTITLE, EJECT ??

    VAR
      local_status: ost$status;

    IF NOT jmv$connection_acquired THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^handle_condition, FALSE);

    nap$se_clear_request (osc$timesharing_terminal_file, status);

{ Note that the disconnect signal sent by the above call is sent to the
{ jobmonitor task.  This code is probably not running in the job monitor
{ task, so there will be a delay until the signal is processed by the jobmonitor
{ and the condition is sent back to this task......
{ (or this is not the job synch task and the condition will not come to this task)
{ The following call to long term wait allows the signal to be processed by
{ the jobmonitor task and the disconnect condition sent to this task and
{ be eaten by this procedures condition handler so that it will not be visible
{ to the caller(s).

    pmp$long_term_wait (2000, 2000);

{ Now you might say that the following call to nlp$record_nominal_disconnect
{ is not required because it will be called as a result of the disconnect
{ signal sent by nap$se_clear_request.  That is sometimes true.  And
{ sometimes not due to the signal processing described above.  This is a
{ failsafe call.

    nlp$record_nominal_disconnect (osc$timesharing_terminal_file, local_status);

    jmv$connection_acquired := FALSE;

  PROCEND jmp$return_connection;
?? OLDTITLE ??
?? NEWTITLE := 'login_as_disconnected', EJECT ??

{ This procedure initializes the timesharing environment for a job started
{ by jmp$submit_detached_job.
{ This procedure always runs in the job monitor task.

  PROCEDURE login_as_disconnected
    (VAR status: ost$status);

    IF (NOT syv$clone_enabled) OR (NOT syv$nosve_job_template) OR (NOT syv$job_initialization_complete) THEN
      fmp$create_network_file (osc$timesharing_terminal_file, nac$null_connection_id, nac$terminated, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    jmp$set_job_mode (jmc$interactive_sys_disconnect, status);
    jmv$initialized_as_disconnected := TRUE;
    jmv$connection_acquired := FALSE;
    jmv$ts_job_disconnected := TRUE;
    pmp$disable_ts_io_in_tasks;

  PROCEND login_as_disconnected;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$submit_detached_job', EJECT ??
*copy jmh$submit_detached_job

  PROCEDURE [XDCL, #GATE] jmp$submit_detached_job
    (    user_information: string ( * <= jmc$user_information_size);
     VAR status: ost$status);

    VAR
      capability: boolean,
      submitted_job_name: jmt$system_supplied_name,
      job_attribute_p: ^jmt$job_attribute_results,
      job_submission_options: ^jmt$job_submission_options,
      submit_variation: jmt$submit_job_variations;

    avp$get_capability (jmc$submit_detached_jobs, avc$user, capability, status);
    IF (NOT status.normal) OR (NOT capability) THEN
      osp$set_status_abnormal ('AV', ave$missing_required_capability, jmc$submit_detached_jobs, status);
      RETURN;
    IFEND;

    PUSH job_attribute_p: [1 .. 3];
    job_attribute_p^ [1].key := jmc$login_family;
    job_attribute_p^ [2].key := jmc$login_user;
    job_attribute_p^ [3].key := jmc$job_class;
    jmp$get_job_attributes (job_attribute_p, status);
    PUSH job_submission_options: [1 .. 9];
    job_submission_options^ [1].key := jmc$origin_application_name;
    job_submission_options^ [1].origin_application_name := osc$timesharing;
    job_submission_options^ [2].key := jmc$login_command_supplied;
    job_submission_options^ [2].login_command_supplied := FALSE;
    job_submission_options^ [3].key := jmc$login_family;
    job_submission_options^ [3].login_family := job_attribute_p^ [1].login_family;
    job_submission_options^ [4].key := jmc$login_user;
    job_submission_options^ [4].login_user := job_attribute_p^ [2].login_user;
    job_submission_options^ [5].key := jmc$immediate_init_candidate;
    job_submission_options^ [5].immediate_init_candidate := TRUE;
    job_submission_options^ [6].key := jmc$job_class;
    job_submission_options^ [6].job_class := job_attribute_p^ [3].job_class;
    job_submission_options^ [7].key := jmc$system_job_parameters;
    PUSH job_submission_options^ [7].system_job_parameters;
    submit_variation.kind := jmc$submit_detached_job;
    job_submission_options^ [7].system_job_parameters^.system_job_parameter_count := #SIZE (submit_variation);
    i#move (^submit_variation, ^job_submission_options^ [7].system_job_parameters^.system_job_parameter,
          #SIZE (submit_variation));
    job_submission_options^ [8].key := jmc$user_information;
    PUSH job_submission_options^ [8].user_information;
    job_submission_options^ [8].user_information^ := user_information;
    job_submission_options^ [9].key := jmc$job_destination_usage;
    job_submission_options^ [9].job_destination_usage := jmc$ve_local_usage;

    jmp$submit_job (clc$null_file, job_submission_options, submitted_job_name, status);

  PROCEND jmp$submit_detached_job;
?? OLDTITLE ??
MODEND jmm$timesharing_signal_handler;
*DECK DECK=JMM$UPDATE_OBJECT_STATISTICS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Scheduling : Update object statistics' ??
MODULE jmm$update_object_statistics;

{ PURPOSE:
{   This module contains the routine to update the statistics for an
{   object on the profile.
{
{ NOTES:
{   See JMM$ADMINISTER_DEFINITIONS, JMM$ADMINISTER_ATTRIBUTES.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$profile_constants
*copyc jmt$service_class_statistics
*copyc jmt$object_attribute
*copyc jmt$profile_object
?? RIGHT := 79, POP ??
*copyc jmp$get_job_class_statistics
*copyc jmp$get_service_class_stats
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??
?? NEWTITLE := '[XDCL] jmp$update_object_statistics' ??

{ PURPOSE:
{   Fetch the statistics for the specified class and add them to the
{   specified attribute list.

  PROCEDURE [XDCL] jmp$update_object_statistics
    (    the_object: jmt$profile_object;
     VAR attributes: jmt$object_attribute;
     VAR status: ost$status);

    VAR
      job_class_statistics: jmt$job_class_statistics,
      service_class_statistics: jmt$service_class_statistics;

    CASE the_object.kind OF
    = jmc$profile_job_class =
      jmp$get_job_class_statistics (the_object.index, job_class_statistics,
            status);
      attributes.attribute_list^ [jmc$jc_queued_jobs].kind := jmc$number;
      attributes.attribute_list^ [jmc$jc_queued_jobs].number :=
            job_class_statistics.queued_jobs;
      attributes.attribute_list^ [jmc$jc_initiated_jobs].kind := jmc$number;
      attributes.attribute_list^ [jmc$jc_initiated_jobs].number :=
            job_class_statistics.initiated_jobs;
    = jmc$profile_service_class =
      jmp$get_service_class_stats (the_object.index, service_class_statistics,
            status);
      attributes.attribute_list^ [jmc$sc_queued_jobs].kind := jmc$number;
      attributes.attribute_list^ [jmc$sc_queued_jobs].number :=
            service_class_statistics.queued_jobs;
      attributes.attribute_list^ [jmc$sc_active_jobs].kind := jmc$number;
      attributes.attribute_list^ [jmc$sc_active_jobs].number :=
            service_class_statistics.active_jobs;
      attributes.attribute_list^ [jmc$sc_swapped_jobs].kind := jmc$number;
      attributes.attribute_list^ [jmc$sc_swapped_jobs].number :=
            service_class_statistics.swapped_jobs;
    ELSE
    CASEND;
  PROCEND jmp$update_object_statistics;
MODEND jmm$update_object_statistics;
*DECK DECK=JMM$VALIDATE_USER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management : User Validation Interfaces' ??
MODULE jmm$validate_user;

{ PURPOSE:
{   This module contains the routine to validate specific user attributes.
{
{ DESIGN:
{   This module will access the user's validation file and verify the user's
{ validation information.  This module resides in the 23D library.  The
{ interface contained in this module is only callable by a job with a login
{ family of $SYSTEM and a login user of $SYSTEM.

?? NEWTITLE := 'Global Declarations Referenced By This Module' ??
?? PUSH (LISTEXT := ON) ??
*copyc ave$validation_interface_errors
*copyc cle$ecc_lexical
*copyc jmc$system_family
*copyc jme$invalid_parameter
*copyc jmt$user_validation_options
*copyc osd$integer_limits
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc avp$prevalidate_job
*copyc clp$validate_name
*copyc jmp$get_attribute_name
*copyc osp$append_status_parameter
*copyc osp$force_access_violation
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$get_user_identification
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] jmp$validate_user', EJECT ??
*copy jmh$validate_user

  PROCEDURE [XDCL, #GATE] jmp$validate_user
    (    login_family: ost$name;
         login_user: ost$name;
         user_validation_options_p: ^jmt$user_validation_options;
     VAR status: ost$status);

    CONST
      password_index = 1;

    VAR
      index: ost$non_negative_integers,
      name_is_valid: boolean,
      scl_name: ost$name,
      user_identification: ost$user_identification,
      valid_encrypted_password: ost$name,
      valid_family: ost$name,
      valid_password: ost$name,
      valid_user: ost$name,
      validation_default: array [1 .. 1] of avt$validation_item,
      validation_options: array [1 .. 1] of avt$validation_item;

    status.normal := TRUE;

{ Verify that the requesting user is valid.  If not, "waste-em!"

    pmp$get_user_identification (user_identification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (user_identification.user <> jmc$system_user) OR (user_identification.family <> jmc$system_family) THEN
      osp$force_access_violation;
    IFEND;

    clp$validate_name (login_family, valid_family, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal ('CL', cle$improper_name, login_family, status);
      RETURN;
    IFEND;
    clp$validate_name (login_user, valid_user, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal ('CL', cle$improper_name, login_user, status);
      RETURN;
    IFEND;

    valid_password := osc$null_name;
    valid_encrypted_password := osc$null_name;
    validation_default [1].key := avc$null_validation_key;
    validation_options [1].key := avc$null_validation_key;

    IF user_validation_options_p <> NIL THEN
      FOR index := 1 TO UPPERBOUND (user_validation_options_p^) DO
        CASE user_validation_options_p^ [index].key OF

        = jmc$encrypted_password =
          valid_encrypted_password := user_validation_options_p^ [index].encrypted_password;

        = jmc$login_password =
          valid_password := user_validation_options_p^ [index].login_password;

        = jmc$null_attribute =
          ;

        ELSE
          jmp$get_attribute_name (user_validation_options_p^ [index].key, scl_name);
          osp$set_status_abnormal ('JM', jme$invalid_parameter, scl_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'USER_VALIDATION_OPTIONS_P', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'JMP$VALIDATE_USER', status);
          RETURN;
        CASEND
      FOREND;
    IFEND;

    IF valid_encrypted_password <> osc$null_name THEN
      validation_default [1].key := avc$password_key;
    IFEND;
    IF valid_password <> osc$null_name THEN
      validation_options [1].key := avc$password_key;
      validation_options [1].password := valid_password;
    IFEND;

    avp$prevalidate_job (valid_user, valid_family, ^validation_options, ^validation_default, status);
    IF status.normal THEN
      IF (valid_encrypted_password <> osc$null_name) AND (valid_encrypted_password <>
            validation_default [1].password) THEN
        osp$set_status_condition (ave$bad_user_validation_info, status);
      IFEND;
    IFEND;

  PROCEND jmp$validate_user;
?? OLDTITLE ??
MODEND jmm$validate_user;
*DECK DECK=JMP$ABORT_DEADSTART EXPAND=FALSE

  PROCEDURE [XREF] jmp$abort_deadstart
    (    display_message: string ( * );
         display_status: ost$status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$ACQUIRE_CONNECTION EXPAND=FALSE
  PROCEDURE [XREF] jmp$acquire_connection
    (    server_name: ost$name;
     VAR service_data: jmt$service_data;
     VAR service_data_length: jmt$service_data_length;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_data
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$ACQUIRE_MODIFIED_INPUT EXPAND=FALSE

  PROCEDURE [XREF] jmp$acquire_modified_input
    (    job_destination_usage: jmt$destination_usage;
     VAR input_descriptor: jmt$input_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$destination_usage
*copyc jmt$input_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=JMP$ACQUIRE_MODIFIED_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] jmp$acquire_modified_output
    (    output_destination_usage: jmt$destination_usage;
     VAR output_descriptor: jmt$output_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$destination_usage
*copyc jmt$output_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=JMP$ACQUIRE_MODIFIED_QFILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$acquire_modified_qfile
    (    application_name: ost$name;
         attribute_keys_p: ^jmt$results_keys;
     VAR attribute_work_area_p: ^jmt$work_area;
     VAR attribute_results_p: ^jmt$qfile_attribute_results;
     VAR system_file_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$qfile_appl_not_permitted
*copyc jme$generic_queue_is_empty
*copyc jme$work_area_too_small
*copyc jmt$qfile_attribute_results
*copyc jmt$results_keys
*copyc jmt$system_supplied_name
*copyc jmt$work_area
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$ACQUIRE_NEW_INPUT EXPAND=FALSE

  PROCEDURE [XREF] jmp$acquire_new_input
    (    job_destination_usage: jmt$destination_usage;
     VAR input_descriptor: jmt$input_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$destination_usage
*copyc jmt$input_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=JMP$ACQUIRE_NEW_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] jmp$acquire_new_output
    (    output_destination_usage: jmt$destination_usage;
     VAR output_descriptor: jmt$output_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$destination_usage
*copyc jmt$output_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=JMP$ACQUIRE_NEW_QFILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$acquire_new_qfile
    (    application_name: ost$name;
         attribute_keys_p: ^jmt$results_keys;
     VAR attribute_work_area_p: ^jmt$work_area;
     VAR attribute_results_p: ^jmt$qfile_attribute_results;
     VAR system_file_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$qfile_appl_not_permitted
*copyc jme$generic_queue_is_empty
*copyc jme$work_area_too_small
*copyc jmt$qfile_attribute_results
*copyc jmt$results_keys
*copyc jmt$system_supplied_name
*copyc jmt$work_area
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$ACTIVATE_DEFERRED_FAMILY EXPAND=FALSE

  PROCEDURE [XREF] jmp$activate_deferred_family
    (    activated_family_list: ^pmt$family_name_list);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$family_name_list
?? POP ??
*DECK DECK=JMP$ACTIVATE_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$activate_job
    (    system_job_name: jmt$system_supplied_name;
         family_name: ost$name;
         subcatalog_name: ost$name;
         recover_using_abort_disposition: boolean;
         ignore_client_initiated_jobs: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ofe$error_codes
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$ACTIVATE_JOB_MODE_SWAPPER EXPAND=FALSE

PROCEDURE [XREF] jmp$activate_job_mode_swapper;
*DECK DECK=JMP$ACTIVATE_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] jmp$activate_output
    (    system_file_name: jmt$system_supplied_name;
         subcatalog_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ofe$error_codes
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$ACTIVATE_SYSTEM_PROFILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$activate_system_profile
    (    access_id: ost$binary_unique_name;
         new_profile: fst$file_reference;
         allow_job_reclassification: boolean;
     VAR profile_changes: jmt$profile_changes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jme$activate_profile_errors
*copyc jmt$profile_changes
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$ACTIVATE_SYS_JOB_TEMPLATE EXPAND=FALSE
PROCEDURE [XREF] jmp$activate_sys_job_template(template_name: ost$name;
                 VAR code_base_ptr: ost$external_code_base_pointer,
                     status: ost$status);
??PUSH(LIST := OFF)??
*copyc OST$STATUS
*copyc OST$NAME
*copyc OSD$CODE_BASE_POINTER
??POP??
*DECK DECK=JMP$ADD_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] jmp$add_object
    (    the_kind: jmt$profile_object_kinds;
         the_name: string ( * );
         the_attributes: jmt$object_attribute;
     VAR the_object: jmt$profile_object_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$profile_object_errors
*copyc jmt$profile_object
*copyc ost$status
?? POP ??
*DECK DECK=JMP$ADD_TO_MAXAJ_LIMIT_SET EXPAND=FALSE

  PROCEDURE [XREF] jmp$add_to_maxaj_limit_set (class: jmt$service_class_index);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_class_index
?? POP ??
*DECK DECK=JMP$ADD_TO_SERVER_RESTART_FILE EXPAND=FALSE

    PROCEDURE [XREF] jmp$add_to_server_restart_file
      (    swap_file_path_p: ^pft$path;
           recover_using_abort_disposition: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=JMP$ADJUST_AGE_INTERVAL EXPAND=FALSE
PROCEDURE [XREF] adjust_age_interval;
*DECK DECK=JMP$ADJUST_PRIORITY_OF_NEW_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$adjust_priority_of_new_job(index: jmt$kjl_index);

?? PUSH(LISTEXT := ON) ??
*copyc jmt$kjl_index
?? POP ??
*DECK DECK=JMP$ADJUST_SWAPIN_CAND_PRIO EXPAND=FALSE

  PROCEDURE [XREF] jmp$adjust_swapin_cand_prio
    (    ijl_ordinal: jmt$ijl_ordinal;
         current_time: jmt$clock_time);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$clock_time
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=JMP$ALLOCATE_MORE_IJL_SPACE EXPAND=FALSE
PROCEDURE [XREF] jmp$allocate_more_ijl_space (ijl_bn: jmt$ijl_block_number);

?? PUSH(LIST := OFF) ??
*copyc JMT$IJL_ORDINAL
?? POP ??
*DECK DECK=JMP$ALL_JOBS_SWAPPED_FOR_IDLING EXPAND=FALSE

  FUNCTION [XREF] jmp$all_jobs_swapped_for_idling: boolean;

*DECK DECK=JMP$ASSIGN_AJL_ENTRY EXPAND=FALSE
PROCEDURE [XREF] jmp$assign_ajl_entry (asid: ost$asid,
      ijl_o: jmt$ijl_ordinal;
      caller: 0 .. 010(16);
      must_assign: boolean;
  VAR ajl_o: jmt$ajl_ordinal;
  VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$hardware_subranges
*copyc jmc$ajl_caller
*copyc jmt$ijl_ordinal
*copyc jmt$ajl_ordinal
*copyc syt$monitor_status
?? POP ??
*DECK DECK=JMP$ASSIGN_AJL_WITH_LOCK EXPAND=FALSE

PROCEDURE [XREF] jmp$assign_ajl_with_lock
  (   asid: ost$asid;
      ijl_o: jmt$ijl_ordinal;
      caller: 0 .. 010(16);
      must_assign: boolean;
  VAR ajl_o: jmt$ajl_ordinal;
  VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$hardware_subranges
*copyc jmc$ajl_caller
*copyc jmt$ijl_ordinal
*copyc jmt$ajl_ordinal
*copyc syt$monitor_status
?? POP ??
*DECK DECK=JMP$ASSIGN_SERVER_JOBS EXPAND=FALSE

  PROCEDURE [XREF] jmp$assign_server_jobs
    (    server_mainframe_id: pmt$binary_mainframe_id;
         assigned_job_list_p: { output } ^jmt$jl_assigned_job_list;
     VAR number_of_jobs_assigned: jmt$job_count_range;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$jl_assigned_job_list
*copyc jmt$job_count_range
*copyc ost$status
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=JMP$ATTACH_TIMESHARING_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$attach_timesharing_job (
        job_name: string ( * <= osc$max_name_size );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$AUTO_INIT_SET EXPAND=FALSE
  PROCEDURE [XREF] jmp$auto_init_set (
    autostart: jmt$initiation_conditions;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc JMT$INITIATION_CONDITIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=JMP$BACKUP_JOB_FILES EXPAND=TRUE
PROCEDURE jmp$backup_job_files (
  control_family, control_families, cf: list of name = $optional
  control_user, control_users, cu: list of name = $optional
  job_category_name, job_category_names, jcn: list of name = $optional
  job_class, job_classes, jc: list of name = $optional
  job_deferred_by_operator, jdbo: boolean = $optional
  job_deferred_by_user, jdbu: boolean = $optional
  job_qualifier, job_qualifiers, jq: list of name = $optional
  job_state, job_states, js: any of
      key
        all
      keyend
      list of key
        (deferred, d)
        (queued, q)
      keyend
    anyend = $optional
  login_account, login_accounts, la: list of name = $optional
  login_family, login_families, lf: list of name = $optional
  login_project, login_projects, lp: list of name = $optional
  login_user, login_users, lu: list of name = $optional
  name, names, n: list of name = $optional
  site_information, si: list of string 0..256 = $optional
  user_information, ui: list of string 0..256 = $optional
  maximum_selection, maxs: any of
      key
        all
      keyend
      integer 1..65535
    anyend = all
  vsn, vsns, v: list of any of
      name 1..6
      string 1..6
    anyend = $optional
  vsn_prefix, vp: any of
      name 1..5
      string 1..5
    anyend = $optional
  vsn_count, vc: integer 1..11881376 = 15
  increment_scheme, is: key
      (alphabetic, a)
      (decimal, d)
    keyend = decimal
  type, t: key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = mt9$1600
  delete_file, delete_files, df: boolean = true
  excluded_file_list, efl: (VAR) list 0..$max_list of name = $optional
  backup_file,bf : file = $optional
  output, o: file = $OUTPUT
  errors, e: file = $ERRORS
  unload_volume, uv: boolean = TRUE
  status)

" Confirm that we are in the system_operator_utility with the system_administration and system_operation
" capabilities active.

  WHEN COMMAND_FAULT DO
    exit procedure with $status(FALSE 'OF' ofe$sou_not_active 'system_administration and system_operation')
  WHENEND

  VAR
    active_capabilities: file = $unique($local)
    ignore_status: status
    lines: list 0..$max_list of string
  VAREND

  system_operator_utility.display_active_capabilities output=active_capabilities
  get_line variable=lines input=active_capabilities
  detach_file file=active_capabilities status=ignore_status
  IF $nil($select_wild_card_strings(lines '*system_administration*' basic)) OR ..
     $nil($select_wild_card_strings(lines '*system_operation*' basic)) THEN
    exit procedure with $status(FALSE 'OF' ofe$sou_not_active 'system_administration and system_operation')
  IFEND

  CANCEL COMMAND_FAULT
  VAR
    constructed_vsn_list: list 1..$max_list of string 6
    queue_backup: file = $unique($local)
    vsn_list: list 1..$max_list of string 1..6
  VAREND

  " Construct the list of VSNs for the backup tape set.

  IF $specified(vsn) THEN
    IF $specified(vsn_prefix) THEN
      exit procedure with $status(FALSE 'JM' jme$incompatible_vsn_params '')
    IFEND
    IF $nil(vsn) THEN
      exit procedure with $status(FALSE 'JM' jme$empty_vsn_list '')
    IFEND
    vsn_list = $string(vsn)

  ELSEIF NOT $specified(vsn_prefix) THEN
    IF NOT $specified(backup_file) THEN
      exit procedure with $status(FALSE 'JM' jme$vsn_or_vsnp_or_bf_required '')
    IFEND
  ELSE
    pup$construct_volume_list vsn_count=vsn_count vsn_prefix=vsn_prefix increment_scheme=increment_scheme ..
          volume_list=constructed_vsn_list
    vsn_list = constructed_vsn_list
  IFEND
  $system.MANAGE_JOBS
    change_list_options output=output errors=errors

" Construct a list of system job names of the jobs to back up.

"$FORMAT=OFF"
    VAR
      all_known_jobs: list 0..$max_list of name
      catalog_paths: list 0..$max_list of string 2..512
      chosen_states: list of key
          (deferred, d)
          (queued, q)
          keyend = (deferred queued)
      command_file: file = $unique(:$local)
      desired_jobs: list 0..$max_list of name
      desired_paths: list 0..$max_list of file
      excluded_jobs: list 0..$max_list of name
      excluded_paths: list 0..$max_list of file
    VAREND

"$FORMAT=ON"

    IF $specified(job_state) THEN
      IF $generic_type(job_state) <> KEY THEN
        chosen_states = job_state
      IFEND
    IFEND
    select_jobs job_state=(deferred queued) maximum_selection=all job_selection_list=all_known_jobs
    select_jobs control_family=control_family control_user=control_user job_category_name=job_category_name ..
          job_class=job_class job_deferred_by_operator=job_deferred_by_operator ..
          job_deferred_by_user=job_deferred_by_user job_qualifier=job_qualifier job_state=chosen_states ..
          login_account=login_account login_family=login_family login_project=login_project ..
          login_user=login_user name=name site_information=site_information ..
          user_information=user_information maximum_selection=maximum_selection ..
          job_selection_list=desired_jobs
    FOR each JOB in desired_jobs DO
      change_input_attributes names=JOB job_deferred_by_operator=true status=ignore_status
      IF NOT ignore_status.normal THEN
        desired_jobs=$difference(desired_jobs job)
      IFEND
    FOREND
    display_input_attributes names=desired_jobs display_option=all output=output

" Generate a list of the unique catalog paths associated with the desired
" jobs.

    desired_paths = $queued_job_path(desired_jobs)
    catalog_count = 0
    find_unique_catalog_paths: ..
      FOR EACH file_path IN desired_paths DO
        FOR catalog_index = 1 TO catalog_count DO
          CYCLE find_unique_catalog_paths WHEN $path(file_path, catalog) = catalog_paths(catalog_index)
        FOREND
        catalog_count = catalog_count + 1
        IF catalog_count = 1 THEN
          catalog_paths = $path(file_path, catalog)
        ELSE
          put_line line='catalog_paths=(..' o=command_file
          FOR index = 1 TO catalog_count-1 DO
            put_line line=''''//catalog_paths(index)//''',..' o=command_file.$eoi
          FOREND
          put_line line=''''//$path(file_path, catalog)//'''..' o=command_file.$eoi
          put_line line=')' o=command_file.$eoi
          include_file file=command_file
        IFEND
      FOREND find_unique_catalog_paths

" Generate a list of the jobs that are not to be backed up.

      excluded_jobs = $difference(all_known_jobs desired_jobs)
      IF NOT $nil(excluded_jobs) THEN
        excluded_paths = $queued_job_path(excluded_jobs)
      IFEND

" Backup the job command files to tape. "

      WHEN any_fault DO
        change_input_attributes names=desired_jobs job_deferred_by_operator=false
        IF NOT $SPECIFIED(BACKUP_FILE) THEN
          detach_file file=queue_backup unload_volume=unload_volume status=ignore_status
        IFEND
        EXIT_PROC
      WHENEND

      TASK ring=3
        IF NOT $SPECIFIED(BACKUP_FILE) THEN
          request_magnetic_tape queue_backup recorded_vsn=vsn_list ring=true type=type
        ELSE
          QUEUE_BACKUP=BACKUP_FILE
        IFEND
        BACKUP_PERMANENT_FILES backup_file=queue_backup list=output.$eoi
          IF NOT $nil(excluded_paths) THEN
            FOR EACH file_path IN excluded_paths DO
              exclude_file file=file_path
            FOREND
          IFEND
          FOR catalog_index = 1 TO catalog_count DO
            backup_catalog catalog=$fname(catalog_paths(catalog_index))
          FOREND
        QUIT " backup_permanent_files "
        IF NOT $SPECIFIED(BACKUP_FILE) THEN
          detach_file file=queue_backup unload_volume=unload_volume
        IFEND
      TASKEND

" Terminate or reenable the jobs for initiation. "

      IF delete_files THEN
        terminate_jobs names=desired_jobs reason=operator_backup
      ELSE
        change_input_attributes names=desired_jobs job_deferred_by_operator=false
      IFEND

" Return a list of known jobs that were not backed up as the excluded_file_list value.

    IF $specified(excluded_file_list) THEN
      excluded_file_list = excluded_jobs
    IFEND

  QUIT " manage_jobs "

PROCEND jmp$backup_job_files
*DECK DECK=JMP$BACKUP_OUTPUT_FILES EXPAND=TRUE
PROCEDURE jmp$backup_output_files (
  comment_banner, comment_banners, cb: list of string 0..31 = $optional
  control_family, control_families, cf: list of name = $optional
  control_user, control_users, cu: list of name = $optional
  data_mode, dm: list of key
      (coded, c)
      (transparent, t)
    keyend = $optional
  device, devices, d: list of any of
      key
        automatic
      keyend
      name
    anyend = $optional
  external_characteristics, ec: list of any of
      key
        normal
      keyend
      string 0..6
    anyend = $optional
  forms_code, forms_codes, fc: list of any of
      key
        normal
      keyend
      string 0..6
    anyend = $optional
  login_account, login_accounts, la: list of name = $optional
  login_family, login_families, lf: list of name = $optional
  login_project, login_projects, lp: list of name = $optional
  login_user, login_users, lu: list of name = $optional
  name, names, n: list of name = $optional
  operator_family, operator_families, of: list of name = $optional
  operator_user, operator_users, ou: list of name = $optional
  output_class, output_classes, oc: list of name = $optional
  output_deferred_by_operator, odbo: boolean = $optional
  output_deferred_by_user, odbu: boolean = $optional
  output_destination, output_destinations, ode: list of any of
      name
      string 0..31
    anyend = $optional
  output_destination_usage, odu: list of any of
      key
        dual_state, ntf, private, public, qtf
      keyend
      name
    anyend = $optional
  output_priority, output_priorities, op: list of name = $optional
  output_state, output_states, os: any of
      key
        all
      keyend
      list of key
        (deferred, d)
        (queued, q)
        (completed, c)
      keyend
    anyend = $optional
  remote_host_directive, remote_host_directives, rhd: list of string 0..256 = $optional
  routing_banner, routing_banners, rb: list of string 0..31 = $optional
  site_information, si: list of string 0..256 = $optional
  station, stations, s: list of any of
      key
        automatic
      keyend
      name
    anyend = $optional
  system_job_name, system_job_names, sjn: list of name = $optional
  user_information, ui: list of string 0..256 = $optional
  vertical_print_density, vertical_print_densities, vpd: list of key
      six, eight, none
    keyend = $optional
  vfu_load_procedure, vfu_load_procedures, vlp: list of any of
      key
        none
      keyend
      name
    anyend = $optional
  maximum_selection, maxs: any of
      key
        all
      keyend
      integer 1..65535
    anyend = all
  vsn, vsns, v: list of any of
      name 1..6
      string 1..6
    anyend = $optional
  vsn_prefix, vp: any of
      name 1..5
      string 1..5
    anyend = $optional
  vsn_count, vc: integer 1..11881376 = 15
  increment_scheme, is: key
      (alphabetic, a)
      (decimal, d)
    keyend = decimal
  type, t: key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = mt9$1600
  delete_file, delete_files, df: boolean = true
  excluded_file_list, efl: (VAR) list 0..$max_list of name = $optional
  backup_file, bf: file = $optional
  output, o: file = $OUTPUT
  errors, e: file = $ERRORS
  status)

" Confirm that we are in the system_operator_utility with the system_administration and system_operation
" capabilities active.

  WHEN command_fault DO
    EXIT procedure WITH $status(FALSE 'OF' ofe$sou_not_active 'system_administration and system_operation')
  WHENEND

  VAR
    active_capabilities: file = $unique($local)
    ignore_status: status
    lines: list 0..$max_list of string
  VAREND

  system_operator_utility.display_active_capabilities output=active_capabilities
  get_line variable=lines input=active_capabilities
  detach_file file=active_capabilities status=ignore_status
  IF $NIL($select_wild_card_strings(lines '*system_administration*' basic)) OR ..
     $NIL($select_wild_card_strings(lines '*system_operation*' basic)) THEN
    EXIT procedure WITH $status(FALSE 'OF' ofe$sou_not_active 'system_administration and system_operation')
  IFEND
  CANCEL command_fault

  VAR
    constructed_vsn_list: list 1..$max_list of string 6
    queue_backup: file = $unique($local)
    vsn_list: list 1..$max_list of string 1..6
  VAREND

" Construct the list of VSNs for the backup tape set.

  IF $SPECIFIED(vsn) THEN
    IF $SPECIFIED(vsn_prefix) THEN
      EXIT procedure WITH $status(FALSE 'JM' jme$incompatible_vsn_params '')
    IFEND
    IF $NIL(vsn) THEN
      EXIT procedure with $status(FALSE 'JM' jme$empty_vsn_list '')
    IFEND
    vsn_list = $STRING(vsn)

    ELSEIF NOT $SPECIFIED(vsn_prefix) THEN
      IF NOT $SPECIFIED(backup_file) THEN
        EXIT procedure WITH $status(FALSE 'JM' jme$vsn_or_vsnp_or_bf_required '')
      IFEND
    ELSE
      pup$construct_volume_list vsn_count=vsn_count vsn_prefix=vsn_prefix increment_scheme=increment_scheme ..
            volume_list=constructed_vsn_list
      vsn_list = constructed_vsn_list
    IFEND

    $system.MANAGE_OUTPUT

      change_list_options output=output errors=errors

" Construct a list of system file names of the outputs to back up.

"$FORMAT=OFF"
      VAR
        all_known_outputs: list 0..$max_list of name
        chosen_states: list of key
          (deferred, d)
          (queued, q)
          (completed, c)
        keyend = (deferred queued completed)
        desired_outputs: list 0..$max_list of name
        desired_paths: list 0..$max_list of file
      VAREND
"$FORMAT=ON"

      IF $SPECIFIED(output_state) THEN
        IF $GENERIC_TYPE(output_state) <> KEY THEN
          chosen_states = output_state
        IFEND
      IFEND
      select_output output_state=(deferred queued completed) maximum_selection=all ..
           output_selection_list=all_known_outputs
      select_output comment_banner=comment_banner control_family=control_family control_user=control_user ..
           data_mode=data_mode device=device external_characteristics=external_characteristics ..
           forms_code=forms_code login_account=login_account login_family=login_family ..
           login_project=login_project login_user=login_user name=name operator_family=operator_family ..
           operator_user=operator_user output_class=output_class ..
           output_deferred_by_operator=output_deferred_by_operator ..
           output_deferred_by_user=output_deferred_by_user output_destination=output_destination ..
           output_destination_usage=output_destination_usage output_priority=output_priority ..
           output_state=chosen_states remote_host_directive=remote_host_directive ..
           routing_banner=routing_banner site_information=site_information station=station ..
           system_job_name=system_job_name user_information=user_information ..
           vertical_print_density=vertical_print_density vfu_load_procedure=vfu_load_procedure ..
           maximum_selection=maximum_selection output_selection_list=desired_outputs

      FOR EACH output_selected in desired_outputs DO
        change_output_attributes names=output_selected output_deferred_by_operator=true ..
              status=ignore_status
        IF NOT ignore_status.normal THEN
          desired_outputs=$DIFFERENCE(desired_outputs output_selected)
        IFEND
      FOREND
      display_output_attributes names=desired_outputs display_option=all output=output

" Backup the output files to tape. "

      desired_paths = $queued_output_path(desired_outputs)

      WHEN any_fault DO
        change_output_attributes names=desired_outputs output_deferred_by_operator=false
        EXIT_PROC
      WHENEND

      TASK ring=3
        IF NOT $SPECIFIED(backup_file) THEN
          request_magnetic_tape queue_backup recorded_vsn=vsn_list ring=true type=type
        ELSE
          queue_backup = backup_file
        IFEND
        BACKUP_PERMANENT_FILES backup_file=queue_backup list=output.$eoi

          FOR EACH output_path IN desired_paths DO
            backup_file file=output_path
          FOREND
        QUIT " backup_permanent_files "
        IF NOT $SPECIFIED(backup_file) THEN
          detach_file file=queue_backup
        IFEND
      TASKEND
      CANCEL any_fault

" Terminate or reactivate the outputs. "

      IF delete_files THEN
        terminate_output names=desired_outputs reason=operator_backup
      ELSE
        change_output_attributes names=desired_outputs output_deferred_by_operator=false
      IFEND

" Return a list of known outputs that were not backed up as the excluded_file_list value.

    IF $SPECIFIED(excluded_file_list) THEN
      excluded_file_list = $DIFFERENCE(all_known_outputs desired_outputs)
    IFEND

  QUIT

PROCEND jmp$backup_output_files
*DECK DECK=JMP$BEGIN_TIMESHARING_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] jmp$begin_timesharing_handler (
         condition: ift$interactive_condition);

?? PUSH (LISTEXT := ON) ??
*copyc ift$condition_codes
?? POP ??
*DECK DECK=JMP$BRING_UP_JOB_TASKS EXPAND=FALSE
  PROCEDURE [XREF] bring_up_job_tasks(ajl: jmt$ajl_ordinal);
?? PUSH( LIST := OFF) ??
*copyc JMT$AJL_ORDINAL
?? POP ??
*DECK DECK=JMP$BUILD_CATEGORY_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] jmp$build_category_object
    (VAR profile: jmt$profile_data;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$profile_data
*copyc ost$status
?? POP ??
*DECK DECK=JMP$BUILD_DEFAULT_PROFILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$build_default_profile
    (VAR status: ost$status);

*DECK DECK=JMP$BUILD_PROFILE_FROM_SYSTEM EXPAND=FALSE

  PROCEDURE [XREF] jmp$build_profile_from_system
    (VAR profile: jmt$profile_data;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$profile_data
*copyc ost$status
?? POP ??
*DECK DECK=JMP$BUILD_QUEUES EXPAND=FALSE
PROCEDURE [XREF] build_queues;
*DECK DECK=JMP$BUILD_TABLES_FROM_PROFILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$build_tables_from_profile
    (    profile: jmt$profile_data;
         compress: boolean;
     VAR job_class_table: ^jmt$job_class_table;
     VAR service_class_table: ^jmt$service_class_table;
     VAR application_table: ^jmt$application_table;
     VAR job_scheduler_table: jmt$job_scheduler_table;
     VAR job_category_table: jmt$job_category_data;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$application_table
*copyc jmt$job_class_table
*copyc jmt$job_scheduler_table
*copyc jmt$profile_data
*copyc jmt$service_class_table
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CALCULATE_SERVICE EXPAND=FALSE

  PROCEDURE [XREF] jmp$calculate_service
    (    ijle_p: ^jmt$initiated_job_list_entry;
     VAR service_used: integer);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=JMP$CALLED_BY_JOB_LEVELER EXPAND=FALSE

  FUNCTION [XREF] jmp$called_by_job_leveler: boolean;

*DECK DECK=JMP$CALL_JOB_LEVELER_SERVER EXPAND=FALSE

  PROCEDURE [XREF] jmp$call_job_leveler_server
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR leveler_server_request { input, output } :
          jmt$jl_leveler_server_request;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$jl_leveler_server_request
*copyc ost$status
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=JMP$CALL_JOB_SWAPPER EXPAND=FALSE

PROCEDURE [XREF] jmp$call_job_swapper;

*DECK DECK=JMP$CHANGE_ATTRIBUTE_DEFAULTS EXPAND=FALSE

  PROCEDURE [XREF] jmp$change_attribute_defaults
    (    job_mode: jmt$job_mode;
         default_attribute_changes: ^jmt$default_attribute_changes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$default_attribute_changes
*copyc jmt$job_mode
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=JMP$CHANGE_DISPATCHING_PRIORITY EXPAND=FALSE

PROCEDURE [XREF] jmp$change_dispatching_priority
  (    job_name: clt$value;
       dispatching_priority: jmt$dispatching_priority;
   VAR status: ost$status);

?? PUSH(LIST := OFF) ??
*copyc cld$value
*copyc jmt$dispatching_priority
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CHANGE_DISPATCHING_PRIOR_R1 EXPAND=FALSE

  PROCEDURE [XREF] jmp$change_dispatching_prior_r1
    (    request_origin: tmt$change_priority_origin;
         ijl_ordinal: jmt$ijl_ordinal;
         system_supplied_name: jmt$system_supplied_name;
         dispatching_control_info: jmt$dispatching_control_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$dispatching_control_info
*copyc jmt$ijl_ordinal
*copyc jmt$system_supplied_name
*copyc tmt$change_priority_origin
?? POP ??
*DECK DECK=JMP$CHANGE_IJL_ENTRY_STATUS EXPAND=FALSE

{ PURPOSE:
{   This is the monitor mode procedure to change the entry status of a job.  The caller
{   of procedure must set the PTL lock if the entry status change is a SWAPPED/NOT SWAPPED
{   transition because the swapped job counts will be changed.

  PROCEDURE [INLINE] jmp$change_ijl_entry_status
    (    ijle_p: ^jmt$initiated_job_list_entry;
         new_entry_status: jmt$ijl_entry_status);

    VAR
      old_entry_status: jmt$ijl_entry_status;

    old_entry_status := ijle_p^.entry_status;

    jmv$ijl_entry_status_statistics [old_entry_status] [new_entry_status] :=
          jmv$ijl_entry_status_statistics [old_entry_status] [new_entry_status] + 1;

    ijle_p^.entry_status := new_entry_status;

    IF (old_entry_status <= jmc$ies_swapin_in_progress) AND
          (new_entry_status > jmc$ies_swapin_in_progress) THEN
      jmp$increment_swapped_job_count (ijle_p);

    ELSEIF (old_entry_status > jmc$ies_swapin_in_progress) AND
          (new_entry_status <= jmc$ies_swapin_in_progress) THEN
      jmp$decrement_swapped_job_count (ijle_p);
    IFEND;

  PROCEND jmp$change_ijl_entry_status;
*DECK DECK=JMP$CHANGE_INPUT_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] jmp$change_input_attributes
    (    input_name: jmt$name;
         input_attribute_changes: ^jmt$input_attribute_changes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$name
*copyc jmt$input_attribute_changes
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CHANGE_JOB_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] jmp$change_job_attributes
    (    job_attribute_changes: ^jmt$job_attribute_changes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc jme$job_monitor_conditions
*copyc jme$queued_file_conditions
*copyc jmt$job_attribute_changes
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CHANGE_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] jmp$change_object
    (    object_kind: jmt$profile_object_kinds;
         objects: clt$data_value;
         new_attributes: jmt$object_attribute;
         how: jmt$ways_to_change_object;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$profile_object_errors
*copyc clt$data_value
*copyc jmt$object_attribute
*copyc jmt$profile_object_kinds
*copyc jmt$ways_to_change_object
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CHANGE_OUTPUT_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] jmp$change_output_attributes
    (    output_name: jmt$name;
         output_attribute_changes: ^jmt$output_attribute_changes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$output_attribute_changes
*copyc jmt$name
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=JMP$CHANGE_PROFILE_CYCLE EXPAND=FALSE
  PROCEDURE [XREF] jmp$change_profile_cycle
    (    access_id: ost$binary_unique_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CHANGE_QFILE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] jmp$change_qfile_attributes
    (    system_file_name: jmt$system_supplied_name;
         attribute_changes_p: ^jmt$qfile_attribute_changes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc jme$illegal_ssn
*copyc jme$invalid_parameter
*copyc jme$latest_run_time_expired
*copyc jme$name_not_found
*copyc jme$qfile_is_initiated
*copyc jmt$qfile_attribute_changes
*copyc jmt$system_supplied_name
*copyc ofe$error_codes
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CHANGE_TERMINATE_JOB_ACTION EXPAND=FALSE

  PROCEDURE [XREF] jmp$change_terminate_job_action
    (    terminate_job_action_set: jmt$terminate_job_action_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$terminate_job_action
*copyc ost$status
*copyc ofe$error_codes
?? POP ??
*DECK DECK=JMP$CHANGE_VFU_LOAD_IMAGE EXPAND=FALSE

  PROCEDURE [XREF] jmp$change_vfu_load_image
    (    vfu_load_image: jmt$vfu_load_image;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$vfu_load_image
*copyc ost$status
?? POP ??

*DECK DECK=JMP$CHECK_ACTIVE_JOB_LIMITS EXPAND=FALSE

  PROCEDURE [XREF] jmp$check_active_job_limits
    (    service_class_set: jmt$service_class_set);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_class_set
?? POP ??
*DECK DECK=JMP$CHECK_SCHEDULER_MEMORY_WAIT EXPAND=FALSE

  PROCEDURE [INLINE] jmp$check_scheduler_memory_wait;

?? PUSH (LISTEXT := ON) ??
*copyc jmv$job_sched_events_selected
*copyc jmv$job_scheduler_event
*copyc jmv$memory_needed_by_scheduler
*copyc jmp$set_scheduler_memory_event
*copyc jmt$job_scheduler_event


    IF (jmv$job_sched_events_selected [jmc$needed_memory_available]) AND
          (mmv$reassignable_page_frames.now >= jmv$memory_needed_by_scheduler) THEN
      IF NOT jmv$job_scheduler_event [jmc$needed_memory_available] THEN
        jmp$set_scheduler_memory_event;
      IFEND;
    IFEND;
  PROCEND jmp$check_scheduler_memory_wait;

?? POP ??
*DECK DECK=JMP$CLEANUP_UNRECOVERED_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$cleanup_unrecovered_job
    (    ijl_ordinal: jmt$ijl_ordinal);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=JMP$CLEAN_UP_JFT_RESIDUE EXPAND=FALSE

  PROCEDURE [XREF] jmp$clean_up_jtf_residue (VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=JMP$CLEAR_ACTIVATE_EVENT EXPAND=FALSE
 PROCEDURE [XREF] jmp$clear_activate_event;

*DECK DECK=JMP$CLEAR_IDLE_SYSTEM_EVENT EXPAND=FALSE

  PROCEDURE [XREF] jmp$clear_idle_system_event;
*DECK DECK=JMP$CLEAR_LEVELER_PROFILE_FLAG EXPAND=FALSE

  PROCEDURE [XREF] jmp$clear_leveler_profile_flag
    (    access_id: ost$binary_unique_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CLEAR_LOWER_MAXAJ_EVENT EXPAND=FALSE

  PROCEDURE [XREF] jmp$clear_lower_maxaj_event;

*DECK DECK=JMP$CLEAR_MEMORY_RES_SWAP_FIELD EXPAND=FALSE

  PROCEDURE [XREF] jmp$clear_memory_res_swap_field (ijl_ord: jmt$ijl_ordinal);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=JMP$CLEAR_OPERATOR_EVENT EXPAND=FALSE
 PROCEDURE [XREF] jmp$clear_operator_event;
*DECK DECK=JMP$CLEAR_SCHEDULER_EVENT EXPAND=FALSE

  PROCEDURE [XREF] jmp$clear_scheduler_event (event: jmt$job_scheduler_events);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_scheduler_event
?? POP ??
*DECK DECK=JMP$CLEAR_SCHED_EVENT_SELECTION EXPAND=FALSE

  PROCEDURE [XREF] jmp$clear_sched_event_selection
    (    event: jmt$job_scheduler_events);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_scheduler_event
?? POP ??
*DECK DECK=JMP$CLEAR_SERVER_JOB_CLASSES EXPAND=FALSE

  PROCEDURE [XREF] jmp$clear_server_job_classes;

*DECK DECK=JMP$CLEAR_UTILITY_ACTIVE EXPAND=FALSE

  PROCEDURE [XREF] jmp$clear_utility_active
    (    access_id: ost$binary_unique_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CLEAR_UTILITY_ACTIVE_FLAG EXPAND=FALSE

  PROCEDURE [XREF] jmp$clear_utility_active_flag
    (    access_id: ost$binary_unique_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CLONE_LOGIN EXPAND=FALSE
PROCEDURE [XREF] jmp$clone_login (
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CLOSE_FILES_FOR_COPOF EXPAND=TRUE
  PROCEDURE [XREF] jmp$close_files_for_copof
    (    output_fid: amt$file_identifier;
         output_lfn: amt$local_file_name;
         target_fid: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CLOSE_FILES_FOR_COPQF EXPAND=FALSE

  PROCEDURE [XREF] jmp$close_files_for_copqf
    (    qfile_fid: amt$file_identifier;
         qfile_lfn: amt$local_file_name;
         target_fid: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CLOSE_INPUT_FILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$close_input_file
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??

*DECK DECK=JMP$CLOSE_OUTPUT_FILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$close_output_file
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CLOSE_QFILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$close_qfile
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CLOSE_SYSTEM_PROFILE EXPAND=FALSE
  PROCEDURE [XREF] jmp$close_system_profile
    (    access_id: ost$binary_unique_name;
         detach_file: boolean;
         file_identifier: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CLUSTER_ATTACH_JOB_ENABLED EXPAND=FALSE
  FUNCTION [XREF] jmp$cluster_attach_job_enabled: boolean;

*DECK DECK=JMP$CLUSTER_GET_LEVELING_DATA EXPAND=FALSE

  PROCEDURE [XREF] jmp$cluster_get_leveling_data
    (    target_mainframe_id: pmt$mainframe_id;
         target_options_p: ^SEQ ( * );
         data_packet_size: ost$segment_length;
     VAR data_area_p: {input, output} ^SEQ ( * );
     VAR mainframes_processed: jmt$rpc_mainframes_processed;
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$rpc_mainframes_processed
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=JMP$COMBINE_OFFLINE_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] jmp$combine_offline_output
    (    tape_file_path: fst$file_reference;
         device_name: jmt$output_device;
         number_of_files_to_combine: jmt$output_count_range;
     VAR combined_file_count: jmt$output_count_range;
     VAR combined_file_list: array [1 .. * ] of jmt$output_descriptor;
     VAR error_file_count: jmt$output_count_range;
     VAR error_file_list: jmt$error_status_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jmt$error_status_list
*copyc jmt$output_count_range
*copyc jmt$output_descriptor
*copyc jmt$output_device
*copyc ost$status
?? POP ??
*DECK DECK=JMP$COMPUTE_TOTAL_MEMORY_USED EXPAND=FALSE
    PROCEDURE [inline] jmp$compute_total_memory_used (ijl_p: ^jmt$initiated_job_list_entry;
                                            VAR total_memory: 0 .. osc$max_page_frames);

   VAR
    i: mmt$job_page_queue_index,
    memory_sum: 0 .. osc$max_page_frames;

    memory_sum := 0;
    FOR i := mmc$pq_job_fixed TO mmc$pq_job_working_set DO
      memory_sum := memory_sum + ijl_p^.job_page_queue_list [i].count;
    FOREND;
    total_memory := memory_sum;
  PROCEND;
*DECK DECK=JMP$CONVERT_DATE_TIME_DIF_TO_US EXPAND=FALSE

  PROCEDURE [INLINE] jmp$convert_date_time_dif_to_us
    (    base_date_time: ost$date_time;
         date_time: ost$date_time;
         current_clock_time: jmt$clock_time;
     VAR free_running_clock_value: jmt$clock_time);

?? PUSH (LISTEXT := ON) ??
    VAR
      base_date_time_clock_time: jmt$clock_time,
      date_time_clock: jmt$clock_time;

    jmp$convert_date_time_to_clock (base_date_time, base_date_time_clock_time);
    jmp$convert_date_time_to_clock (date_time, date_time_clock);

    free_running_clock_value := date_time_clock - base_date_time_clock_time +
          current_clock_time;
  PROCEND jmp$convert_date_time_dif_to_us;

*copy jmh$convert_date_time_dif_to_us

*copyc jmt$clock_time
*copyc ost$date_time
*copyc jmp$convert_date_time_to_clock
?? POP ??
*DECK DECK=JMP$CONVERT_DATE_TIME_TO_CLOCK EXPAND=FALSE

  PROCEDURE [XREF] jmp$convert_date_time_to_clock (date_time: ost$date_time;
    VAR microsecond_clock_value: jmt$clock_time);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc jmt$clock_time
?? POP ??
*DECK DECK=JMP$CONVERT_DISP_PR_TO_STRING EXPAND=FALSE

  PROCEDURE [XREF] jmp$convert_disp_pr_to_string (
        dispatching_priority: jmt$dispatching_priority;
    VAR str: ost$string;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$dispatching_priority
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=JMP$CONVERT_JOB_TEMPLATE_FILE EXPAND=FALSE
PROCEDURE [XREF] jmp$convert_job_template_file( lfn: amt$local_file_name;
                 VAR status: ost$status);

?? PUSH(LIST := OFF) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=JMP$CONVERT_NAME_TO_SSN EXPAND=FALSE

  PROCEDURE [XREF] jmp$convert_name_to_ssn (
        name: string ( * <= osc$max_name_size );
        privileged_job: boolean;
    VAR system_supplied_name: jmt$system_supplied_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CONVERT_STRING_TO_DISP_PR EXPAND=FALSE

  PROCEDURE [XREF] jmp$convert_string_to_disp_pr (name: ost$name;
    VAR dispatching_priority: jmt$dispatching_priority;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc jmt$dispatching_priority
?? POP ??
*DECK DECK=JMP$COPY_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] jmp$copy_attributes
    (    old_attributes: jmt$object_attribute;
     VAR new_attributes: jmt$object_attribute);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$object_attribute
?? POP ??
*DECK DECK=JMP$COPY_QFILE EXPAND=TRUE
  PROCEDURE [XREF] jmp$copy_qfile
    (    system_file_name: jmt$system_supplied_name;
         target_file: fst$file_reference;
         target_ring: ost$valid_ring;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jme$name_not_found
*copyc jmt$system_supplied_name
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=JMP$COPY_SEQ_TO_RESULT_ARRAY EXPAND=FALSE

  PROCEDURE [XREF] jmp$copy_seq_to_result_array
    (    number_of_keys: ost$positive_integers;
         number_of_packets_in_sequence: ost$non_negative_integers,
         results_keys_p: ^jmt$results_keys;
     VAR jm_work_area_p: ^jmt$work_area;
     VAR user_work_area_p: ^jmt$work_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$work_area_too_small
*copyc jmt$results_keys
*copyc jmt$work_area
*copyc osd$integer_limits
*copyc ost$status
?? POP ??
*DECK DECK=JMP$CREATE_TASK_PRIVATE EXPAND=FALSE
  PROCEDURE [xref] jmp$create_task_private (VAR status: ost$status);

*copyc OST$STATUS
*DECK DECK=JMP$DEACTIVATE_JOB_LEVELING EXPAND=FALSE

  PROCEDURE [XREF] jmp$deactivate_job_leveling
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc ost$status
?? POP ??
*DECK DECK=JMP$DECREMENT_LW_THRESHOLD EXPAND=FALSE

  PROCEDURE [XREF] jmp$decrement_lw_threshold
    (    node: jmt$node);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$node
?? POP ??
*DECK DECK=JMP$DECREMENT_SWAPPED_JOB_COUNT EXPAND=FALSE
  PROCEDURE [XREF] jmp$decrement_swapped_job_count(ijle_p: ^jmt$initiated_job_list_entry);

?? PUSH(LIST := OFF) ??
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=JMP$DEFAULT_JOB_RESOURCE_HNDLR EXPAND=FALSE

  PROCEDURE [XREF] jmp$default_job_resource_hndlr
    (    condition: pmt$condition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$condition
?? POP ??
*DECK DECK=JMP$DEFER_DEACTIVATED_FAMILY EXPAND=FALSE

  PROCEDURE [XREF] jmp$defer_deactivated_family
    (    deactivated_family_list: ^pmt$family_name_list);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$family_name_list
?? POP ??
*DECK DECK=JMP$DEFINE_AND_PERMIT_CATALOGS EXPAND=FALSE

  PROCEDURE [XREF] jmp$define_and_permit_catalogs (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=JMP$DELETE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] jmp$delete_attributes
    (VAR object_attributes: jmt$object_attribute);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$object_attribute
?? POP ??
*DECK DECK=JMP$DELETE_IJL_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] jmp$delete_ijl_entry
    (    ijl_ordinal: jmt$ijl_ordinal);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=JMP$DELETE_NON_INHERITED_SEGS EXPAND=TRUE
 PROCEDURE [XREF] jmp$delete_non_inherited_segs (VAR status: ost$status);

*DECK DECK=JMP$DELETE_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] jmp$delete_object
    (    object_kind: jmt$profile_object_kinds;
         objects: clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc jme$profile_object_errors
*copyc jmt$profile_object_kinds
*copyc ost$status
?? POP ??

*DECK DECK=JMP$DELETE_PROFILE_CYCLE EXPAND=FALSE
  PROCEDURE [XREF] jmp$delete_profile_cycle
    (    access_id: ost$binary_unique_name;
         cycle_number: jmt$system_profile_cycle_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_profile_cycle_number
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$DELETE_SWAPIN_CANDIDATE EXPAND=FALSE

  PROCEDURE [XREF] jmp$delete_swapin_candidate (ijl_ord: jmt$ijl_ordinal;
        class: jmt$service_class_index);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc jmt$service_class_index
?? POP ??
*DECK DECK=JMP$DELETE_TASK_PRIVATE EXPAND=FALSE

   PROCEDURE[xref] jmp$delete_task_private
                 (xcb_p: ^ost$execution_control_block;
                 VAR status: ost$status);
*DECK DECK=JMP$DETACH_TIMESHARING_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$detach_timesharing_job (
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$DETERMINE_DIS_PRIORITY EXPAND=FALSE

  PROCEDURE [XREF] jmp$determine_dis_priority
    (    name: ost$name;
     VAR dispatching_priority: jmt$dispatching_priority;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$dispatching_priority
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$DETERMINE_DIS_PRIORITY_NAME EXPAND=FALSE

  PROCEDURE [XREF] jmp$determine_dis_priority_name
    (    dispatching_priority: jmt$dispatching_priority;
     VAR priority_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$dispatching_priority
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$DETERMINE_JOB_CLASS EXPAND=FALSE

  PROCEDURE [XREF] jmp$determine_job_class (
        job_class_name: jmt$job_class_name;
    VAR job_class: jmt$job_class;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
*copyc jmt$job_class_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$DETERMINE_JOB_CLASS_ABBREV EXPAND=FALSE

  PROCEDURE [XREF] jmp$determine_job_class_abbrev
    (    job_class: jmt$job_class;
     VAR job_class_abbrev: jmt$job_class_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
*copyc jmt$job_class_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$DETERMINE_JOB_CLASS_NAME EXPAND=FALSE

  PROCEDURE [XREF] jmp$determine_job_class_name (
        job_class: jmt$job_class;
    VAR job_class_name: jmt$job_class_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
*copyc jmt$job_class_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$DETERMINE_NAME_KIND EXPAND=FALSE

  PROCEDURE [XREF] jmp$determine_name_kind
    (    candidate_name: string ( * <= osc$max_name_size);
     VAR name: jmt$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc jmt$name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$DETERMINE_NEEDED_PRIORITIES EXPAND=FALSE

  PROCEDURE [XREF] jmp$determine_needed_priorities
    (    leveler_job_class_data: jmt$jl_job_class_data;
     VAR job_class_priorities: jmt$jl_job_class_priorities);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$jl_job_class_data
*copyc jmt$jl_job_class_priorities
?? POP ??
*DECK DECK=JMP$DETERMINE_NEED_FOR_JOBS EXPAND=FALSE

  PROCEDURE [XREF] jmp$determine_need_for_jobs
    (VAR leveler_job_class_data: jmt$jl_job_class_data);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$jl_job_class_data
?? POP ??
*DECK DECK=JMP$DETERMINE_SERVICE_CLASS EXPAND=FALSE

  PROCEDURE [XREF] jmp$determine_service_class
    (    service_class_name: jmt$service_class_name;
     VAR service_class: jmt$service_class_index;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_class_name
*copyc jmt$service_class_index
*copyc ost$status
?? POP ??
*DECK DECK=JMP$DETERMINE_SERV_CLASS_ABBREV EXPAND=FALSE

  PROCEDURE [XREF] jmp$determine_serv_class_abbrev
    (    service_class: jmt$service_class_index;
     VAR service_class_abbrev: jmt$service_class_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_class_index
*copyc jmt$service_class_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$DETERMINE_SERV_CLASS_NAME EXPAND=FALSE

  PROCEDURE [XREF] jmp$determine_serv_class_name
    (    service_class: jmt$service_class_index;
     VAR service_class_name: jmt$service_class_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_class_index
*copyc jmt$service_class_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$DISABLE_USER_BREAKS EXPAND=FALSE


  PROCEDURE [XREF] jmp$disable_user_breaks;
*DECK DECK=JMP$DISCARD_SERVER_JOBS EXPAND=FALSE

  PROCEDURE [XREF] jmp$discard_server_jobs
    (    server_mainframe_id: pmt$binary_mainframe_id);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=JMP$DISPLAY_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] jmp$display_attributes
    (VAR attribute_values_seq: ^SEQ ( * );
         number_to_display: integer,
         header_display_list_p: ^jmt$header_display_information,
         not_found_name_list_p: ^jmt$name_list;
         not_found_name_list_count: integer;
         file: clt$file;
         command_title: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$file
*copyc jmt$attribute_keys
*copyc jmt$header_display_information
*copyc jmt$name_list
*copyc ost$status
?? POP ??
*DECK DECK=JMP$DISPLAY_JOB_STATUS EXPAND=FALSE

  PROCEDURE [XREF] jmp$display_job_status
    (    file: fst$file_reference;
         display_options: jmt$attribute_keys_set;
         job_names: clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc fst$file_reference
*copyc jmt$attribute_keys_set
?? POP ??
*DECK DECK=JMP$DISPLAY_OBJECTS EXPAND=FALSE

  PROCEDURE [XREF] jmp$display_objects
    (    object_kind: jmt$profile_object_kinds;
         suppress_empty_attributes: boolean;
         object_names: clt$parameter_value;
         attribute_parameter: clt$parameter_value;
         group_parameter: clt$parameter_value;
         output_parameter: clt$parameter_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_value
*copyc jme$object_display_errors
*copyc jmt$profile_object_kinds
*copyc ost$status
?? POP ??

*DECK DECK=JMP$DISPLAY_OBJECTS_BY_GROUPS EXPAND=FALSE

  PROCEDURE [XREF] jmp$display_objects_by_groups
    (    object_list: clt$data_value;
         group_list: clt$parameter_value;
         suppress_empty_attributes: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$parameter_value
*copyc jme$object_display_errors
*copyc ost$status
?? POP ??
*DECK DECK=JMP$DISPLAY_OUTPUT_STATUS EXPAND=FALSE

  PROCEDURE [XREF] jmp$display_output_status (status_p: ^jmt$output_status_results;
        number_returned: jmt$output_status_count;
        output_name_list_p: ^jmt$name_list;
        file: clt$file;
        command_title: string( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$output_status_results
*copyc jmt$output_status_count
*copyc jmt$name_list
*copyc clt$file
*copyc ost$status
?? POP ??

*DECK DECK=JMP$DISPLAY_PROFILE_CHANGES EXPAND=FALSE

  PROCEDURE [XREF] jmp$display_profile_changes
    (    the_changes: jmt$profile_changes;
         output_file: clt$parameter_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_value
*copyc jme$object_display_errors
*copyc jmt$profile_changes
*copyc ost$status
?? POP ??
*DECK DECK=JMP$DISPLAY_PROFILE_SUMMARY EXPAND=FALSE

  PROCEDURE [XREF] jmp$display_profile_summary
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=JMP$EMIT_COMMUNICATION_STAT EXPAND=FALSE

  PROCEDURE [XREF] jmp$emit_communication_stat
    (    statistic_data: jmt$comm_acct_statistic_data);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$comm_acct_statistic_data
?? POP ??

*DECK DECK=JMP$EMIT_JOB_HISTORY_STATISTICS EXPAND=FALSE

  PROCEDURE [XREF] jmp$emit_job_history_statistics
    (    statistic_code: sft$statistic_code;
         disposition: ost$name;
         system_job_name: jmt$system_supplied_name;
         system_file_name: jmt$system_supplied_name;
         system_label_p: ^jmt$job_system_label;
         output_system_label_p: ^jmt$output_system_label;
         reason: ost$name;
         parent_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc sfd$type_declarations
*copyc jml$user_id
*copyc jmt$job_system_label
*copyc jmt$output_system_label
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$ENABLE_EXIT_PROCESSING EXPAND=FALSE


PROCEDURE [XREF] jmp$enable_exit_processing;
*DECK DECK=JMP$ENABLE_TERMINAL_IO EXPAND=FALSE

PROCEDURE [XREF] jmp$enable_terminal_io;
*DECK DECK=JMP$ENABLE_USER_BREAKS EXPAND=FALSE


  PROCEDURE [XREF] jmp$enable_user_breaks;
*DECK DECK=JMP$END_APPLICATION_SCHEDULING EXPAND=FALSE

  PROCEDURE [XREF] jmp$end_application_scheduling
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$END_TIMESHARING_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] jmp$end_timesharing_handler (
         condition: ift$interactive_condition);

?? PUSH (LISTEXT := ON) ??
*copyc ift$condition_codes
?? POP ??
*DECK DECK=JMP$EXECUTE_JOB_TEMPL_TASK EXPAND=FALSE
 {deck contents deleted by JLG on 11-1-84
*DECK DECK=JMP$EXIT_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$exit_job;

*DECK DECK=JMP$EXPAND_JOB_CLASS_ABBREV EXPAND=FALSE

  PROCEDURE [XREF] jmp$expand_job_class_abbrev (
    VAR job_class_name: jmt$job_class_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
*copyc jmt$job_class_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$FIND_AND_INSERT_SWAPIN_CAND EXPAND=FALSE

  PROCEDURE [XREF] jmp$find_and_insert_swapin_cand (current_time: jmt$clock_time);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$clock_time
?? POP ??
*DECK DECK=JMP$FIND_JSN EXPAND=FALSE
  PROCEDURE [XREF] jmp$find_jsn (jsn: string (* <= jmc$system_supplied_name_size);
    VAR ijle_p: ^jmt$initiated_job_list_entry;
    VAR ijlo: jmt$ijl_ordinal);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc jmt$system_supplied_name
?? POP ??
*DECK DECK=JMP$FORCE_CANDIDATE_REFRESH EXPAND=FALSE

  PROCEDURE [XREF] jmp$force_candidate_refresh
    (    flush_candidate_queue: boolean);
*DECK DECK=JMP$FREE_AJL_ENTRY EXPAND=FALSE
PROCEDURE [XREF] jmp$free_ajl_entry
  (    ijle_p: ^jmt$initiated_job_list_entry;
       caller: 0 .. 10(16));

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
*copyc jmc$ajl_caller
?? POP ??
*DECK DECK=JMP$FREE_AJL_WITH_LOCK EXPAND=FALSE

PROCEDURE [XREF] jmp$free_ajl_with_lock
  (    ijle_p: ^jmt$initiated_job_list_entry;
       caller: 0 .. 10(16));

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
*copyc jmc$ajl_caller
?? POP ??
*DECK DECK=JMP$FREE_SWAP_RESIDENT_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$free_swap_resident_job;
*DECK DECK=JMP$GENERAL_PURPOSE_CLUSTER_RPC EXPAND=FALSE

  PROCEDURE [XREF] jmp$general_purpose_cluster_rpc
    (    target_mainframe_id: pmt$mainframe_id;
         procedure_ordinal: jmt$general_purpose_rpc_ordinal;
         data_packet_size: ost$segment_length;
         mainframes_processed_so_far: jmt$rpc_mainframes_processed;
         target_options_p: ^SEQ ( * );
     VAR data_area_p: {input, output} ^SEQ ( * );
     VAR target_mainframe_reached: boolean;
     VAR mainframes_processed: jmt$rpc_mainframes_processed;
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_parameters
*copyc jmt$general_purpose_rpc_ordinal
*copyc jmt$rpc_mainframes_processed
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=JMP$GENERATE_PROFILE_DEF EXPAND=FALSE

  PROCEDURE [XREF] jmp$generate_profile_def
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GENERATE_TIMESHARING_TITLE EXPAND=FALSE

  PROCEDURE [XREF] jmp$generate_timesharing_title
    (    binary_mainframe_id: pmt$binary_mainframe_id;
     VAR timesharing_title: ost$name);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=JMP$GET_ACCOUNT_PROJECT_SPECIF EXPAND=FALSE


  FUNCTION [XREF] jmp$get_account_project_specif: boolean;

*DECK DECK=JMP$GET_ACTIVE_SCHEDULING_ATTR EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_active_scheduling_attr
    (    job_class_name: ost$name;
         scheduling_results_keys_p: ^jmt$scheduling_results_keys;
     VAR work_area_p: {input, output} ^jmt$work_area;
     VAR scheduling_attribute_results_p: ^jmt$scheduling_attr_results;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$work_area_too_small
*copyc jme$job_class_not_defined
*copyc jmt$scheduling_attr_results
*copyc jmt$scheduling_results_keys
*copyc jmt$work_area
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_APPLICATION_RECORD EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_application_record
    (    application_name: jmt$application_name;
     VAR application_record: jmt$application_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$application_attributes
*copyc jmt$application_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_attributes
    (    the_kind: jmt$profile_object_kinds;
         parameter_description_table: ^clt$parameter_description_table;
         parameter_value_table: ^clt$parameter_value_table;
     VAR the_attributes: jmt$object_attribute;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_description_table
*copyc clt$parameter_value_table
*copyc jme$object_attribute_errors
*copyc jmt$object_attribute
*copyc jmt$profile_object_kinds
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_ATTRIBUTES_FOR_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_attributes_for_display
    (    profile: jmt$profile_data;
         the_object: jmt$profile_object;
     VAR values: jmt$object_attribute;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$profile_data
*copyc jmt$profile_object
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_ATTRIBUTE_DEFAULTS EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_attribute_defaults
    (    job_mode: jmt$job_mode;
         default_attribute_results: ^jmt$default_attribute_results;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$default_attribute_results
*copyc jmt$job_mode
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_ATTRIBUTE_INDEX EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_attribute_index
    (    attribute_name: string ( * <= osc$max_name_size);
     VAR attribute_index: jmt$attribute_keys);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$attribute_keys
*copyc ost$name
?? POP ??
*DECK DECK=JMP$GET_ATTRIBUTE_NAME EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_attribute_name
    (    attribute_index: jmt$attribute_keys;
     VAR attribute_name: ost$name);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$attribute_keys
*copyc ost$name
?? POP ??
*DECK DECK=JMP$GET_CATEGORY_DATA EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_category_data
    (VAR category_data: jmt$job_category_data;
     VAR data_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_category_data
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_CLIENT_SCHEDULING_DATA EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_client_scheduling_data
    (VAR scheduling_data: jmt$jl_scheduling_data);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$jl_scheduling_data
?? POP ??
*DECK DECK=JMP$GET_DATA_PACKET_SIZE EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_data_packet_size
    (    results_keys_p: ^jmt$results_keys;
     VAR data_packet_size: ost$segment_length;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$results_keys
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_DEFAULT_CLASS_VALUES EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_default_class_values
    (VAR job_class_defaults: jmt$job_class_attributes;
     VAR service_class_defaults: jmt$service_class_attributes;
     VAR application_defaults: jmt$application_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$application_attributes
*copyc jmt$job_class_attributes
*copyc jmt$service_class_attributes
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_DEFINED_CLASSES EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_defined_classes
    (    class_kind: jmt$class_kind;
     VAR defined_classes: jmt$defined_classes;
     VAR number_of_classes: ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$class_kind
*copyc jmt$defined_classes
*copyc osd$integer_limits
*copyc ost$status
?? POP ??

*DECK DECK=JMP$GET_ENCRYPTED_PASSWORD EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_encrypted_password
    (VAR encrypted_password: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_IJLE_P EXPAND=FALSE
  PROCEDURE [inline] jmp$get_ijle_p (ijl_ordinal: jmt$ijl_ordinal;
    VAR ijle_p: ^jmt$initiated_job_list_entry);

?? PUSH (LISTEXT := ON) ??
    ijle_p := ^jmv$ijl_p.block_p^ [ijl_ordinal.block_number].index_p^ [ijl_ordinal.block_index];

  PROCEND jmp$get_ijle_p;

{* * * requires deck jmv$ijl_p * * *}
*copyc jmt$initiated_job_list_entry
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=JMP$GET_INPUT_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_input_attributes
    (    input_attribute_options_p: ^jmt$input_attribute_options;
         input_attribute_results_keys_p: ^jmt$results_keys;
     VAR work_area_p: ^jmt$work_area;
     VAR input_attribute_results_p: ^jmt$input_attribute_results;
     VAR number_of_jobs_found: jmt$job_status_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$work_area_too_small
*copyc jmt$input_attribute_options
*copyc jmt$input_attribute_results
*copyc jmt$job_status_count
*copyc jmt$results_keys
*copyc jmt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_INPUT_Q_FROM_UNASSIGNED EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_input_q_from_unassigned
    (VAR system_supplied_names: array [1 .. * ] of jmt$system_supplied_name;
     VAR number_of_jobs_found: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_JM_WORK_AREA EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_jm_work_area
    (VAR jm_work_area_p: ^jmt$work_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_JOB_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_job_attributes
    (    job_attribute_results: ^jmt$job_attribute_results;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$job_attribute_results
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_JOB_CLASS_EPILOG EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_job_class_epilog
    (VAR job_class_epilog: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_JOB_CLASS_PROLOG EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_job_class_prolog
    (VAR job_class_prolog: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_JOB_CLASS_RECORD EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_job_class_record
    (    job_class_index: jmt$job_class;
     VAR job_class_record: jmt$job_class_attributes;
     VAR data_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
*copyc jmt$job_class_attributes
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_JOB_CLASS_STATISTICS EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_job_class_statistics
    (    job_class_index: jmt$job_class;
     VAR job_class_statistics: jmt$job_class_statistics;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
*copyc jmt$job_class_statistics
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_JOB_COMMAND_INPUT_LFN EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_job_command_input_lfn (VAR local_file_name: amt$local_file_name);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
?? POP ??
*DECK DECK=JMP$GET_JOB_COUNTS EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_job_counts (
    VAR job_counts: jmt$job_counts;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_counts
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_JOB_IJL_ORDINAL EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_job_ijl_ordinal (
        name: string ( * <= osc$max_name_size );
        privileged_job: boolean;
    VAR ijl_ordinal: jmt$ijl_ordinal;
    VAR system_supplied_name: jmt$system_supplied_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_JOB_INTERNAL_INFO EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_job_internal_info (
        system_supplied_name: jmt$system_supplied_name;
    VAR job_internal_info: jmt$job_internal_information;
    VAR status: ost$status);

?? PUSH (LISTEXT:=ON) ??
*copyc jmt$system_supplied_name
*copyc jmt$job_internal_information
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??

*DECK DECK=JMP$GET_JOB_NAMES_BY_USER EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_job_names_by_user
    (    user: ost$name;
         family: ost$name;
         job_name_list_p: ^jmt$job_name_list;
     VAR number_of_jobs_found: jmt$job_status_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$job_name_list
*copyc jmt$job_status_count
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_JOB_NAME_VIA_GTID EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_job_name_via_gtid
    (    global_task_id: ost$global_task_id;
     VAR system_supplied_name: jmt$system_supplied_name;
     VAR job_exists: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$global_task_id
?? POP ??

*DECK DECK=JMP$GET_JOB_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_job_parameters (
    VAR job_parameters: jmt$system_job_parameters;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_job_parameters
*copyc ost$status
?? POP ??

*DECK DECK=JMP$GET_JOB_PATH_ELEMENTS EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_job_path_elements
    (    system_job_name: jmt$system_supplied_name;
     VAR path: jmt$queue_file_path;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$queue_file_path
*copyc jmt$system_supplied_name
*copyc ofe$error_codes
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_JOB_RESOURCE_CONDITION EXPAND=FALSE
 PROCEDURE [XREF] jmp$get_job_resource_condition (VAR condition:
  jmt$job_resource_condition;
    VAR status: ost$status);

*copyc ost$status
*copyc jmd$job_resource_condition
*DECK DECK=JMP$GET_JOB_STATUS EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_job_status
    (    job_status_options_p: ^jmt$job_status_options;
         job_status_results_keys_p: ^jmt$results_keys;
     VAR work_area_p: ^jmt$work_area;
     VAR job_status_results_p: ^jmt$job_status_results;
     VAR number_of_jobs_found: jmt$job_status_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jme$work_area_too_small
*copyc jmt$job_status_count
*copyc jmt$job_status_options
*copyc jmt$job_status_results
*copyc jmt$results_keys
*copyc jmt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_JOB_STATUS_SIZE EXPAND=FALSE
*DECK DECK=JMP$GET_LENGTH_OF_SCHED_TABLES EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_length_of_sched_tables
    (VAR maximum_job_classes: jmt$job_class;
     VAR maximum_job_class_index: jmt$job_class;
     VAR maximum_service_classes: jmt$service_class_index;
     VAR maximum_service_class_index: jmt$service_class_index;
     VAR maximum_applications: jmt$application_index;
     VAR maximum_categories: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$application_index
*copyc jmt$job_class
*copyc jmt$service_class_index
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_LEVELING_DATA EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_leveling_data
    (    target_options_p: ^SEQ ( * );
     VAR data_area_p: {input, output} ^SEQ ( * );
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_LOG_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_log_entry (file: amt$file_identifier;
    VAR buffer: sft$statistic_buffer;
    VAR file_position: amt$file_position;
    VAR p_header: ^sft$global_log_statistic_header;
    VAR p_descriptor: ^sft$descriptive_data;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc sfd$type_declarations
*copyc sft$statistic_buffer
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_MULTIPRO_OPTIONS_R1 EXPAND=FALSE
  PROCEDURE [XREF] jmp$get_multipro_options_r1 (VAR multiprocessing_allowed: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_MULTIPRO_OPTIONS_R3 EXPAND=FALSE
  PROCEDURE [XREF] jmp$get_multipro_options_r3 (VAR multiprocessing_allowed: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_NEXT_ENTRY EXPAND=FALSE
PROCEDURE [XREF] jmp$get_next_entry(VAR done: BOOLEAN; kjl_thd: jmt$kjl_ordinal;
                                       VAR next_entry: jmt$kjl_ordinal);
?? PUSH(LIST := OFF) ??
*copyc JMT$KJL_ORDINAL
?? POP ??
*DECK DECK=JMP$GET_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_object
    (    the_name: string ( * );
         the_kind: jmt$profile_object_kinds;
     VAR the_object: jmt$profile_object_reference;
     VAR previous_object: jmt$profile_object_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$profile_object_errors
*copyc jmt$profile_object
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_OBJECT_LIST EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_object_list
    (    name: string ( * );
         kind: jmt$profile_object_kinds;
     VAR list: jmt$profile_object_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$profile_object_errors
*copyc jmt$profile_object_list
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_OUTPUT_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_output_attributes
    (    output_attribute_options_p: ^jmt$output_attribute_options;
         output_attribute_results_keys_p: ^jmt$results_keys;
     VAR work_area_p: ^jmt$work_area;
     VAR output_attribute_results_p: ^jmt$output_attribute_results;
     VAR number_of_outputs_found: jmt$output_status_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$work_area_too_small
*copyc jmt$output_attribute_options
*copyc jmt$output_attribute_results
*copyc jmt$output_status_count
*copyc jmt$results_keys
*copyc jmt$work_area
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=JMP$GET_OUTPUT_COUNTS EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_output_counts (
    VAR output_counts: jmt$output_counts;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$output_counts
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_OUTPUT_PATH_ELEMENTS EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_output_path_elements
    (    system_file_name: jmt$system_supplied_name;
     VAR path: jmt$queue_file_path;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$queue_file_path
*copyc jmt$system_supplied_name
*copyc ofe$error_codes
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_OUTPUT_STATUS EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_output_status
    (    output_status_options_p: ^jmt$output_status_options;
         output_status_results_keys_p: ^jmt$results_keys;
     VAR work_area_p: ^jmt$work_area;
     VAR output_status_results_p: ^jmt$output_status_results;
     VAR number_of_outputs_found: jmt$output_status_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$work_area_too_small
*copyc jmt$output_status_options
*copyc jmt$output_status_results
*copyc jmt$output_status_count
*copyc jmt$results_keys
*copyc jmt$work_area
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=JMP$GET_PAGE_COUNT_OF_LW_QUEUE EXPAND=FALSE
*DECK DECK=JMP$GET_QFILE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_qfile_attributes
    (    attribute_options_p: ^jmt$qfile_attribute_options;
         attribute_results_keys_p: ^jmt$results_keys;
     VAR attribute_work_area_p: ^jmt$work_area;
     VAR attribute_results_p: ^jmt$qfile_attribute_results;
     VAR number_of_qfiles_found: jmt$qfile_status_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc jme$duplicate_attribute_key
*copyc jme$invalid_parameter
*copyc jme$no_qfiles_were_found
*copyc jme$work_area_too_small
*copyc jmt$qfile_attribute_options
*copyc jmt$qfile_attribute_results
*copyc jmt$qfile_status_count
*copyc jmt$results_keys
*copyc jmt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_QFILE_ATTRIBUTES_SIZE EXPAND=FALSE
*DECK DECK=JMP$GET_QFILE_STATUS EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_qfile_status
    (    status_options_p: ^jmt$qfile_status_options;
         status_results_keys_p: ^jmt$results_keys;
     VAR status_work_area_p: ^jmt$work_area;
     VAR status_results_p: ^jmt$qfile_status_results;
     VAR number_of_qfiles_found: jmt$qfile_status_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc jme$duplicate_attribute_key
*copyc jme$invalid_parameter
*copyc jme$no_qfiles_were_found
*copyc jme$work_area_too_small
*copyc jmt$qfile_status_options
*copyc jmt$qfile_status_results
*copyc jmt$qfile_status_count
*copyc jmt$results_keys
*copyc jmt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_QFILE_STATUS_SIZE EXPAND=FALSE
*DECK DECK=JMP$GET_RECOVERY_RESTART_FILE EXPAND=FALSE

  PROCEDURE [INLINE] jmp$get_recovery_restart_file
    (    server_mainframe_id: pmt$mainframe_id;
     VAR restart_file_name: ost$name);

?? PUSH (LISTEXT := ON) ??

    CONST
      prototype_file_name = 'DFF$system_mmmm_ssss_RESTART';

    restart_file_name := prototype_file_name;
    restart_file_name (4, pmc$mainframe_id_size) := server_mainframe_id;
  PROCEND jmp$get_recovery_restart_file;

*copy jmh$get_recovery_restart_file

*copyc ost$name
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=JMP$GET_RESULT_SIZE EXPAND=FALSE
  PROCEDURE [XREF] jmp$get_result_size
    (    number_of_items: ost$non_negative_integers;
         results_keys_seq_p: ^SEQ ( * );
     VAR size: ost$segment_length);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$results_keys
*copyc osd$integer_limits
*copyc osd$virtual_address
?? POP ??
*DECK DECK=JMP$GET_SCHEDULER_TABLE EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_scheduler_table
    (VAR scheduler_table: jmt$job_scheduler_table;
     VAR data_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_scheduler_table
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_SCHEDULING_ADMIN_STATUS EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_scheduling_admin_status
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_SERVER_JOB_END_INFO EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_server_job_end_info
    (VAR job_end_information: jmt$jl_server_job_end_info);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$jl_server_job_end_info
?? POP ??
*DECK DECK=JMP$GET_SERVICE_CLASS_RECORD EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_service_class_record
    (    service_class_index: jmt$service_class_index;
     VAR service_class_record: jmt$service_class_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_class_attributes
*copyc jmt$service_class_index
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_SERVICE_CLASS_STATS EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_service_class_stats
    (    service_class_index: jmt$service_class_index;
     VAR service_class_statistics: jmt$service_class_statistics;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_class_index
*copyc jmt$service_class_statistics
*copyc ost$status
?? POP ??
*DECK DECK=JMP$GET_TERMINATE_JOB_ACTION EXPAND=FALSE

  PROCEDURE [XREF] jmp$get_terminate_job_action
    (VAR terminate_job_action_set: jmt$terminate_job_action_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$terminate_job_action
*copyc ost$status
*copyc ofe$error_codes
?? POP ??
*DECK DECK=JMP$HANDLE_JOB_RESOURCE_SIGNAL EXPAND=FALSE

  PROCEDURE [XREF] jmp$handle_job_resource_signal (originator:
    ost$global_task_id;
        signal: pmt$signal);

?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc PMT$SIGNAL
?? POP ??
*DECK DECK=JMP$HANDLE_LOGOUT_FLAG EXPAND=FALSE

  PROCEDURE [XREF] jmp$handle_logout_flag ( flaf_id: ost$system_flag);

?? PUSH (LISTEXT := ON) ??
*copyc OST$SYSTEM_FLAG
?? POP ??
*DECK DECK=JMP$HANDLE_SIGNAL_SENSE_SWITCH EXPAND=FALSE

  PROCEDURE [XREF] jmp$handle_signal_sense_switch(originator: ost$global_task_id;
    signal: pmt$signal);

?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc PMT$SIGNAL
?? POP ??
*DECK DECK=JMP$HANDLE_TS_IO_REQ_FAILURE EXPAND=FALSE

  PROCEDURE [XREF] jmp$handle_ts_io_req_failure (
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$HANDLE_TS_SYSTEM_DISCONNECT EXPAND=FALSE

  PROCEDURE [XREF] jmp$handle_ts_system_disconnect (
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$IDETERMINE_JOB_CLASS_ABBREV EXPAND=FALSE

  PROCEDURE [INLINE] jmp$idetermine_job_class_abbrev
    (    job_class: jmt$job_class;
     VAR abbrev: string (2));

?? PUSH (LISTEXT := ON) ??
      abbrev := jmv$job_class_table_p^ [job_class].abbreviation (1, 2);
      IF abbrev (1) = ' ' THEN
        abbrev := jmv$job_class_table_p^ [job_class].name (1, 2);
      IFEND;

  PROCEND jmp$idetermine_job_class_abbrev;

*copyc jmv$job_class_table_p
?? POP ??
*DECK DECK=JMP$IDETERMINE_SERV_CLASS_ABBRE EXPAND=FALSE

  PROCEDURE [INLINE] jmp$idetermine_serv_class_abbre
    (    service_class: jmt$service_class_index;
     VAR abbrev: string (2));

?? PUSH (LISTEXT := ON) ??
      abbrev := jmv$service_classes [service_class]^.attributes.abbreviation (1, 2);
      IF abbrev (1) = ' ' THEN
        abbrev := jmv$service_classes [service_class]^.attributes.name (1, 2);
      IFEND;

  PROCEND jmp$idetermine_serv_class_abbre;

*copyc jmv$service_classes
?? POP ??
*DECK DECK=JMP$IDLE_ADVANCE_LW_JOBS EXPAND=FALSE

  PROCEDURE [XREF] jmp$idle_advance_lw_jobs;

*DECK DECK=JMP$IDLE_JOBS EXPAND=FALSE

  PROCEDURE [XREF] jmp$idle_jobs (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$IDLE_SYSTEM EXPAND=FALSE
{ This deck will be deleted.  It is a temporary deck.
  PROCEDURE [XREF] jmp$idle_system (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$IDLING_SWAPFILE_UPDATE EXPAND=FALSE

  PROCEDURE [XREF] jmp$idling_swapfile_update
    (    ijlo: jmt$ijl_ordinal;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc ost$status
?? POP ??
*DECK DECK=JMP$IDLING_SWAP_ALL_JOBS EXPAND=FALSE

  PROCEDURE [XREF] jmp$idling_swap_all_jobs;

*DECK DECK=JMP$IJL_BLOCK_VALID EXPAND=FALSE

  FUNCTION [INLINE] jmp$ijl_block_valid
    (    ijl_ordinal: jmt$ijl_ordinal): boolean;

    jmp$ijl_block_valid := NOT (jmv$ijl_p.block_p^ [ijl_ordinal.block_number].index_p = NIL);

  FUNCEND jmp$ijl_block_valid;
*DECK DECK=JMP$IJL_DETAILED_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] jmp$ijl_detailed_display
    (    window_id: dpt$window_id;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$status
?? POP ??
*DECK DECK=JMP$INCREMENT_IJL_IN_USE_COUNT EXPAND=FALSE

  PROCEDURE [XREF] jmp$increment_ijl_in_use_count
    (    ijl_block_number: jmt$ijl_block_number);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
?? POP ??

*DECK DECK=JMP$INCREMENT_SWAPPED_JOB_COUNT EXPAND=FALSE

  PROCEDURE [XREF]  jmp$increment_swapped_job_count (ijle_p: ^jmt$initiated_job_list_entry);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=JMP$INCR_SCHEDULER_STATISTICS EXPAND=FALSE

  PROCEDURE [XREF] jmp$incr_scheduler_statistics (scheduler_statistic:
        jmt$sched_statistic_elements);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_scheduler_statistics
?? POP ??
*DECK DECK=JMP$INCR_SCHED_SERV_STATISTICS EXPAND=FALSE

  PROCEDURE [XREF] jmp$incr_sched_serv_statistics
    (    scheduler_statistic: jmt$sched_statistic_elements;
         class: jmt$service_class_index);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_scheduler_statistics
?? POP ??
*DECK DECK=JMP$INHIBIT_EXIT_PROCESSING EXPAND=FALSE

PROCEDURE [XREF] jmp$inhibit_exit_processing;
*DECK DECK=JMP$INITIALIZE_AJL_IJL EXPAND=FALSE

  PROCEDURE [XREF] jmp$initialize_ajl_ijl;
*DECK DECK=JMP$INITIALIZE_JCB EXPAND=FALSE

  PROCEDURE [XREF] jmp$initialize_jcb;
*DECK DECK=JMP$INITIALIZE_JOB_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] jmp$initialize_job_attributes (
        system_label_p: ^jmt$job_system_label;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_system_label
*copyc ost$status
?? POP ??
*DECK DECK=JMP$INITIALIZE_JOB_ENVIRONMENT EXPAND=FALSE

  PROCEDURE [XREF] jmp$initialize_job_environment
            (VAR jmtr_initial_ring: ost$ring;
             VAR jmtr_program_description_p: ^pmt$program_description;
             VAR jmtr_program_parameters_p: ^pmt$program_parameters;
             VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_DESCRIPTION
*copyc PMT$PROGRAM_PARAMETERS
*copyc OST$STATUS
*copyc OSD$VIRTUAL_ADDRESS
?? POP ??
*DECK DECK=JMP$INITIALIZE_JOB_LOCAL_TABLES EXPAND=FALSE

  PROCEDURE [XREF] jmp$initialize_job_local_tables (
        system_label_p: ^jmt$job_system_label;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_system_label
*copyc ost$status
?? POP ??
*DECK DECK=JMP$INITIALIZE_JOB_MODE EXPAND=FALSE
PROCEDURE [XREF] jmp$initialize_job_mode;
*DECK DECK=JMP$INITIALIZE_JOB_TABLES EXPAND=FALSE

  PROCEDURE [XREF] jmp$initialize_job_tables
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$INITIALIZE_SCHEDULER_TABLES EXPAND=FALSE

  PROCEDURE [XREF] jmp$initialize_scheduler_tables
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=JMP$INITIALIZE_SCHED_RING_2 EXPAND=FALSE
PROCEDURE [XREF] jmp$initialize_sched_ring_2;
*DECK DECK=JMP$INITIALIZE_SCHED_VARIABLES EXPAND=FALSE

  PROCEDURE [XREF] jmp$initialize_sched_variables;

*DECK DECK=JMP$INITIALIZE_SSN EXPAND=FALSE

  PROCEDURE [XREF] jmp$initialize_ssn
    (    deadstart_phase: ost$deadstart_phase;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$deadstart_phase
*copyc ost$status
?? POP ??
*DECK DECK=JMP$INITIALIZE_TIMESHARING EXPAND=FALSE

  PROCEDURE [XREF] jmp$initialize_timesharing (
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$INITIATE_JOB EXPAND=FALSE
   PROCEDURE[xref] jmp$initiate_job (kjl_ord: jmt$kjl_ordinal;
      VAR status: ost$status );

?? PUSH (LISTEXT := ON) ??
*copyc JMT$KJL_ORDINAL
*copyc OST$STATUS
?? POP ??

*DECK DECK=JMP$INITIATE_JOB_FROM_SCHEDULER EXPAND=FALSE

  PROCEDURE [XREF] jmp$initiate_job_from_scheduler (
        node: jmt$node;
        ijl_ord: jmt$ijl_ordinal;
        service_class: jmt$service_class_index;
    VAR status: ost$status);

?? PUSH(LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc jmt$node
*copyc jmt$service_class_index
*copyc ost$status
?? POP ??
*DECK DECK=JMP$INIT_CPU_DEPENDENT_NAMES EXPAND=FALSE

  PROCEDURE [XREF] jmp$init_cpu_dependent_names (
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$INSTALL_PROFILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$install_profile
    (    access_id: ost$binary_unique_name;
         job_class_entries_p: ^jmt$job_class_table;
         service_class_entries_p: ^jmt$service_class_table;
         application_entries_p: ^jmt$application_table;
         controls_entry: jmt$job_scheduler_table;
         category_data: jmt$job_category_data;
         move_job_classes: jmt$job_class_set;
         deleted_job_classes: jmt$job_class_set;
         deleted_service_classes: jmt$service_class_set;
         deleted_applications: jmt$application_set;
         delete_profile_cycle2: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$application_set
*copyc jmt$application_table
*copyc jmt$job_category_data
*copyc jmt$job_class_set
*copyc jmt$job_class_table
*copyc jmt$job_scheduler_table
*copyc jmt$service_class_set
*copyc jmt$service_class_table
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$INSTALL_PROFILE_IN_TABLES EXPAND=FALSE

  PROCEDURE [XREF] jmp$install_profile_in_tables
    (    access_id: ost$binary_unique_name;
         job_class_entries_p: ^jmt$job_class_table;
         service_class_entries_p: ^jmt$service_class_table;
         application_entries_p: ^jmt$application_table;
         controls_entry: jmt$job_scheduler_table;
         category_data: jmt$job_category_data;
         deleted_job_classes: jmt$job_class_set;
         deleted_service_classes: jmt$service_class_set;
         deleted_applications: jmt$application_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$application_set
*copyc jmt$application_table
*copyc jmt$job_category_data
*copyc jmt$job_class_set
*copyc jmt$job_class_table
*copyc jmt$job_scheduler_table
*copyc jmt$service_class_set
*copyc jmt$service_class_table
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$INSTALL_SYS_JOB_TEMPLATE EXPAND=FALSE
PROCEDURE [XREF] jmp$install_sys_job_template(name: ost$name;
                 VAR status: ost$status);
?? PUSH(LIST := OFF) ??
*copyc OST$NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=JMP$INTERNAL_ERROR EXPAND=FALSE

  PROCEDURE [XREF] jmp$internal_error
    (    location: integer);

*DECK DECK=JMP$INVOKE_EPILOG_PROCESSING EXPAND=FALSE

  PROCEDURE [XREF] jmp$invoke_epilog_processing;

*DECK DECK=JMP$IS_DUAL_STATE_JOB EXPAND=FALSE
  FUNCTION [XREF] jmp$is_dual_state_job: boolean;

*DECK DECK=JMP$IS_XTERM_JOB EXPAND=FALSE
  FUNCTION [XREF] jmp$is_xterm_job: boolean;

*DECK DECK=JMP$IS_XTERM_TASK EXPAND=FALSE
  FUNCTION [XREF] jmp$is_xterm_task
    (    task_id: pmt$task_id): boolean;

?? PUSH (LISTEXT := OFF) ??
*copyc pmt$task_id
?? POP ??
*DECK DECK=JMP$JM_CHANGE_IJL_ENTRY_STATUS EXPAND=FALSE

{ PURPOSE:
{   This is the job mode procedure to change the entry status of a job.  The only type of change
{   allowed is from one swapped status to another, so the swapped job count does not have to be
{   changed (swapped job count CANNOT be changed in job mode).

  PROCEDURE [INLINE] jmp$jm_change_ijl_entry_status
    (    ijle_p: ^jmt$initiated_job_list_entry;
         new_entry_status: jmt$ijl_entry_status);

    VAR
      old_entry_status: jmt$ijl_entry_status;

    old_entry_status := ijle_p^.entry_status;

    jmv$ijl_entry_status_statistics [old_entry_status] [new_entry_status] :=
          jmv$ijl_entry_status_statistics [old_entry_status] [new_entry_status] + 1;

    ijle_p^.entry_status := new_entry_status;

  PROCEND jmp$jm_change_ijl_entry_status;
*DECK DECK=JMP$JOBEND_STATEMENT EXPAND=FALSE

  PROCEDURE [XREF] jmp$jobend_statement
    (    info: clt$control_statement_info;
     VAR parse {input, output} : clt$parse_state;
     VAR work_area {input, output} : ^clt$work_area;
     VAR cause_condition {input, output} : clt$when_condition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$control_statement_info
*copyc clt$parse_state
*copyc clt$when_condition
*copyc clt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=JMP$JOB_BEGIN EXPAND=FALSE

  PROCEDURE [XREF] jmp$job_begin (
    VAR users_nominal_ring: ost$ring);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
?? POP ??
*DECK DECK=JMP$JOB_BOOT EXPAND=FALSE
PROCEDURE [XREF] jmp$job_boot;
*DECK DECK=JMP$JOB_END EXPAND=FALSE

  PROCEDURE [XREF] jmp$job_end;
*DECK DECK=JMP$JOB_EXISTS EXPAND=FALSE

  PROCEDURE [XREF] jmp$job_exists (
        name: string ( * <= osc$max_name_size );
        job_state_set: jmt$job_state_set;
    VAR job_exists: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc jme$queued_file_conditions
*copyc jmt$job_state_set
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$JOB_FILE_FAP EXPAND=FALSE

  FUNCTION [XREF] jmp$job_file_fap (local_file_name: amt$local_file_name): amt$fap_pointer;

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMT$LOCAL_FILE_NAME
?? POP ??
*DECK DECK=JMP$JOB_INITIALIZED EXPAND=FALSE
FUNCTION [XREF] jmp$job_initialized: boolean;
*DECK DECK=JMP$JOB_IS_BEING_LEVELED EXPAND=FALSE

  FUNCTION [XREF] jmp$job_is_being_leveled: boolean;
*DECK DECK=JMP$JOB_LEVELER_SERVER EXPAND=FALSE

  PROCEDURE [XREF] jmp$job_leveler_server
    (VAR received_from_client_params_p { Input } : dft$p_receive_parameters;
     VAR received_from_client_data_p { Input } : dft$p_receive_data;
     VAR send_to_client_params_p { Output } : dft$p_send_parameters;
     VAR send_to_client_data_p { Output } : dft$p_send_data;
     VAR parameter_size: dft$send_parameter_size;
     VAR data_size: dft$send_data_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_parameters
*copyc ost$status
?? POP ??
*DECK DECK=JMP$JOB_MONITOR_XCB EXPAND=FALSE

  FUNCTION [XREF] jmp$job_monitor_xcb: ^ost$execution_control_block;

?? PUSH (LISTEXT := ON) ??
*copyc OST$EXECUTION_CONTROL_BLOCK
?? POP ??
*DECK DECK=JMP$JOB_SCHEDULER_MONITOR EXPAND=FALSE
{------------------------------------------------------
{}
{ common deck name
{ jmxsch
{}
{}
PROCEDURE [XREF] jmp$job_scheduler_monitor;
{}
{------end of common deck jmxsch----------------------------
*DECK DECK=JMP$JOB_SELECTION_PRIORITY EXPAND=FALSE

  FUNCTION [INLINE] jmp$job_selection_priority
    (    current_time: jmt$clock_time;
         kjl_index: jmt$kjl_index;
         job_class: jmt$job_class): jmt$job_priority;

?? PUSH (LISTEXT := ON) ??

    VAR
      age_interval: integer,
      job_priority: integer;

    IF kjl_index = jmc$kjl_undefined_index THEN
      job_priority := 0;
    ELSE

      IF jmv$job_class_table_p^ [job_class].initiation_age_interval <>
            jmc$unlimited_prio_age_interval THEN
        age_interval := ((current_time - jmv$kjl_p^ [kjl_index].
              job_submission_time) DIV jmv$job_class_table_p^ [job_class].
              initiation_age_interval);
      ELSE
        age_interval := 0; { no aging
      IFEND;
      job_priority := age_interval * jmv$job_class_table_p^ [job_class].
            selection_priority.increment + jmv$job_class_table_p^ [job_class].
            selection_priority.initial + jmv$kjl_p^ [kjl_index].priority_bias;
      IF job_priority > UPPERVALUE (jmt$job_priority) THEN
        job_priority := UPPERVALUE (jmt$job_priority);
      ELSEIF job_priority < LOWERVALUE (jmt$job_priority) THEN
        job_priority := LOWERVALUE (jmt$job_priority);
      IFEND;
    IFEND;
    jmp$job_selection_priority := job_priority;
  FUNCEND jmp$job_selection_priority;

*copyc jmh$job_selection_priority

*copyc jmt$clock_time
*copyc jmt$job_priority
*copyc jmt$kjl_index
*copyc jmv$job_class_table_p
?? POP ??
*DECK DECK=JMP$JOB_SWAP_FUNCTION_PROCESSOR EXPAND=FALSE
PROCEDURE [XREF] jmp$job_swap_function_processor;
*DECK DECK=JMP$LEVELER_WAIT EXPAND=FALSE

  PROCEDURE [XREF] jmp$leveler_wait
    (    job_leveling_interval: jmt$service_interval);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_interval
?? POP ??
*DECK DECK=JMP$LINK_NON_DISPATCHABLE_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$link_non_dispatchable_job
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=JMP$LIST_JOBS_VIA_MODE EXPAND=FALSE

  PROCEDURE [XREF] jmp$list_jobs_via_mode
    (    mode: jmt$job_mode;
     VAR job_list: array [1 .. * ] of jmt$system_supplied_name;
     VAR count: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_mode
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$LOAD_SYSTEM_JOB_TEMPLATE EXPAND=FALSE
PROCEDURE [XREF] jmp$load_system_job_template(template_name: ost$name;
                 VAR code_base_ptr: ^ost$external_code_base_pointer,
                     status: ost$status);
??PUSH(LIST := OFF)??
*copyc OST$STATUS
*copyc OST$NAME
*copyc OSD$CODE_BASE_POINTER
??POP??
*DECK DECK=JMP$LOAD_SYS_JOB_TEMPLATE EXPAND=FALSE

  PROCEDURE [XREF] jmp$load_sys_job_template
    (    name: ost$name;
     VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$LOCK_AJL EXPAND=FALSE

{ This procedure is called when we need access to the job fixed of a job that
{ may or may not have an ajl assigned.

  PROCEDURE [INLINE] jmp$lock_ajl
    (    ijle_p: ^jmt$initiated_job_list_entry;
         ijlo: jmt$ijl_ordinal;
     VAR ajlo: jmt$ajl_ordinal);

    VAR
      ajl_ordinal: jmt$ajl_ordinal,
      status: syt$monitor_status;

    tmp$set_lock (tmv$ptl_lock);
    ajl_ordinal := ijle_p^.ajl_ordinal;
    IF ajl_ordinal = jmc$null_ajl_ordinal THEN
      jmp$assign_ajl_with_lock (ijle_p^.job_fixed_asid, ijlo, jmc$lock_ajl, TRUE {MUST_ASSIGN},
            ajlo, status);
    ELSE
      jmv$ajl_p^ [ajl_ordinal].in_use := jmv$ajl_p^ [ajl_ordinal].in_use + jmc$lock_ajl;
      ajlo := ajl_ordinal;
    IFEND;
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND jmp$lock_ajl;

?? PUSH (LISTEXT := ON) ??
*copyc jmc$ajl_caller
*copyc jmc$null_ajl_ordinal

*copyc jmp$assign_ajl_with_lock
*copyc tmp$clear_lock
*copyc tmp$set_lock

*copyc jmv$ajl_p
*copyc tmv$ptl_lock
?? POP ??

*DECK DECK=JMP$LOCK_AJL_WITH_LOCK EXPAND=FALSE

{ This procedure is called when we need access to the job fixed of a job that
{ may or may not have an ajl assigned.  The caller must have the PTL lock set.

  PROCEDURE [INLINE] jmp$lock_ajl_with_lock
    (    ijle_p: ^jmt$initiated_job_list_entry;
         ijlo: jmt$ijl_ordinal;
     VAR ajlo: jmt$ajl_ordinal);

    VAR
      ajl_ordinal: jmt$ajl_ordinal,
      status: syt$monitor_status;

    ajl_ordinal := ijle_p^.ajl_ordinal;
    IF ajl_ordinal = jmc$null_ajl_ordinal THEN
      jmp$assign_ajl_with_lock (ijle_p^.job_fixed_asid, ijlo, jmc$lock_ajl, TRUE {MUST_ASSIGN},
            ajlo, status);
    ELSE
      jmv$ajl_p^ [ajl_ordinal].in_use := jmv$ajl_p^ [ajl_ordinal].in_use + jmc$lock_ajl;
      ajlo := ajl_ordinal;
    IFEND;

  PROCEND jmp$lock_ajl_with_lock;

?? PUSH (LISTEXT := ON) ??
*copyc jmc$ajl_caller
*copyc jmc$null_ajl_ordinal

*copyc jmp$assign_ajl_with_lock
?? POP ??
*DECK DECK=JMP$LOGOUT EXPAND=FALSE

  PROCEDURE [XREF] jmp$logout
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$job_monitor_conditions
*copyc ost$status
?? POP ??
*DECK DECK=JMP$LOG_EDITED_LOGIN_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] jmp$log_edited_login_command
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$LOG_RESTORED_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$log_restored_job
    (    system_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$job_history_conditions
*copyc jme$queued_file_conditions
*copyc jmt$system_supplied_name
*copyc ofe$error_codes
*copyc ost$status
*copyc sye$job_recovery_conditions
?? POP ??
*DECK DECK=JMP$LOG_RESTORED_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] jmp$log_restored_output
    (    system_file_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$job_history_conditions
*copyc jme$queued_file_conditions
*copyc jmt$system_supplied_name
*copyc ofe$error_codes
*copyc ost$status
?? POP ??
*DECK DECK=JMP$MAINFRAME_CHANGE_INPUT_ATTR EXPAND=FALSE
  PROCEDURE [XREF] jmp$mainframe_change_input_attr
    (    target_options_p: ^SEQ ( * );
     VAR data_area_p: {input, output} ^SEQ ( * );
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$job_class_does_not_exist
*copyc osd$integer_limits
*copyc ost$status
?? POP ??
*DECK DECK=JMP$MAINFRAME_CHANGE_OUTPUT_ATT EXPAND=FALSE
  PROCEDURE [XREF] jmp$mainframe_change_output_att
    (    target_options_p: ^SEQ ( * );
     VAR data_area_p: {input, output} ^SEQ ( * );
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$invalid_parameter
*copyc jme$latest_print_time_expired
*copyc osd$integer_limits
*copyc ost$status
?? POP ??
*DECK DECK=JMP$MAINFRAME_GET_INPUT_ATTRIBU EXPAND=FALSE
  PROCEDURE [XREF] jmp$mainframe_get_input_attribu
    (    target_options_p: ^SEQ ( * );
     VAR data_area_p: {input, output} ^SEQ ( * );
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$work_area_too_small
*copyc osd$integer_limits
*copyc ost$status
?? POP ??
*DECK DECK=JMP$MAINFRAME_GET_JOB_STATUS EXPAND=FALSE
  PROCEDURE [XREF] jmp$mainframe_get_job_status
    (    target_options_p: ^SEQ ( * );
     VAR data_area_p {input, output} : ^SEQ ( * );
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
*copyc ost$status
?? POP ??
*DECK DECK=JMP$MAINFRAME_GET_LEVELING_DATA EXPAND=FALSE

  PROCEDURE [XREF] jmp$mainframe_get_leveling_data
    (    send_data_p: ^SEQ ( * );
     VAR work_area_p: ^jmt$work_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=JMP$MAINFRAME_GET_OUTPUT_ATTRIB EXPAND=FALSE
  PROCEDURE [XREF] jmp$mainframe_get_output_attrib
    (    target_options_p: ^SEQ ( * );
     VAR data_area_p: {input, output} ^SEQ ( * );
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$work_area_too_small
*copyc osd$integer_limits
*copyc ost$status
?? POP ??

*DECK DECK=JMP$MAINFRAME_GET_OUTPUT_STATUS EXPAND=FALSE
  PROCEDURE [XREF] jmp$mainframe_get_output_status
    (    target_options_p: ^SEQ ( * );
     VAR data_area_p: {input, output} ^SEQ ( * );
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
*copyc ost$status
?? POP ??

*DECK DECK=JMP$MAINFRAME_SET_SENSE_SWITCH EXPAND=FALSE
  PROCEDURE [XREF] jmp$mainframe_set_sense_switch
    (    target_options_p: ^SEQ ( * );
     VAR data_area_p: {input, output} ^SEQ ( * );
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
*copyc ost$status
?? POP ??

*DECK DECK=JMP$MAINFRAME_TERMINATE_OUTPUT EXPAND=FALSE
  PROCEDURE [XREF] jmp$mainframe_terminate_output
    (    target_options_p: ^SEQ ( * );
     VAR data_area_p: {input, output} ^SEQ ( * );
     VAR number_of_data_packets: ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
*copyc ost$status
?? POP ??
*DECK DECK=JMP$MANAGE_SENSE_SWITCHES EXPAND=FALSE

  PROCEDURE [XREF] jmp$manage_sense_switches ( on: pmt$sense_switches;
    off: pmt$sense_switches);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$SENSE_SWITCHES
?? POP ??

*DECK DECK=JMP$MANAGE_SWAP_LIST_LOCK EXPAND=FALSE
PROCEDURE [XREF] jmp$manage_swap_list_lock(lock: BOOLEAN);
*DECK DECK=JMP$MESSAGE_WAITING_FLAG_HNDLR EXPAND=FALSE
  PROCEDURE [XREF] jmp$message_waiting_flag_hndlr
    (    flag_id: ost$system_flag);

?? PUSH (LISTEXT := ON) ??
*copyc ost$system_flag
?? POP ??
*DECK DECK=JMP$MODIFIED_INPUT_EXISTS EXPAND=FALSE

  FUNCTION [XREF] jmp$modified_input_exists
    (    job_destination_usage: jmt$destination_usage): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
?? POP ??

*DECK DECK=JMP$MODIFIED_OUTPUT_EXISTS EXPAND=FALSE

  FUNCTION [XREF] jmp$modified_output_exists
    (    output_destination_usage: jmt$destination_usage): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
?? POP ??
*DECK DECK=JMP$MODIFIED_QFILE_EXISTS EXPAND=FALSE

  FUNCTION [XREF] jmp$modified_qfile_exists
    (    application_name: ost$name): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=JMP$MOVE_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] jmp$move_object
    (    object_kind: jmt$profile_object_kinds;
         objects: clt$data_value;
         destination_name: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc jme$profile_object_errors
*copyc jmt$profile_object_kinds
*copyc ost$status
?? POP ??
*DECK DECK=JMP$MTR_JOB_SCHEDULER_REQUESTS EXPAND=FALSE

  PROCEDURE [XREF] jmp$mtr_job_scheduler_requests (VAR request_block: jmt$rb_scheduler_requests);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$rb_scheduler_requests
?? POP ??
*DECK DECK=JMP$NEW_INPUT_EXISTS EXPAND=FALSE

  FUNCTION [XREF] jmp$new_input_exists
    (    job_destination_usage: jmt$destination_usage): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
?? POP ??
*DECK DECK=JMP$NEW_OUTPUT_EXISTS EXPAND=FALSE

  FUNCTION [XREF] jmp$new_output_exists
    (    output_destination_usage: jmt$destination_usage): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
?? POP ??
*DECK DECK=JMP$NEW_QFILE_EXISTS EXPAND=FALSE

  FUNCTION [XREF] jmp$new_qfile_exists
    (    application_name: ost$name): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=JMP$NOTIFY_JOB_SCHEDULER_OF_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$notify_job_scheduler_of_job
    (    job_class: jmt$job_class,
         new_kjl_index: jmt$kjl_index);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
*copyc jmt$kjl_index
?? POP ??
*DECK DECK=JMP$NOTIFY_QUEUED_FILES_JOB_END EXPAND=FALSE

  PROCEDURE [XREF] jmp$notify_queued_files_job_end (
        kjl_index: jmt$kjl_index);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$kjl_index
?? POP ??
*DECK DECK=JMP$OPEN_FILES_FOR_COPOF EXPAND=TRUE

  PROCEDURE [XREF] jmp$open_files_for_copof
    (    output_file_name: jmt$name;
         target_file: fst$file_reference;
     VAR control_info: fst$copy_control_information;
     VAR output_fid: amt$file_identifier;
     VAR output_lfn: amt$local_file_name;
     VAR target_fid: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$not_validated_for_copof
*copyc jme$queued_file_conditions
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc fst$copy_control_information
*copyc fst$file_reference
*copyc jmt$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$OPEN_FILES_FOR_COPQF EXPAND=TRUE
  PROCEDURE [XREF] jmp$open_files_for_copqf
    (    system_file_name: jmt$system_supplied_name;
         target_file: fst$file_reference;
         target_ring: ost$valid_ring;
     VAR control_info: fst$copy_control_information;
     VAR qfile_fid: amt$file_identifier;
     VAR qfile_lfn: amt$local_file_name;
     VAR target_fid: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc fst$copy_control_information
*copyc fst$file_reference
*copyc jme$name_not_found
*copyc jmt$system_supplied_name
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=JMP$OPEN_INPUT_FILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$open_input_file
    (    system_job_name: jmt$system_supplied_name;
         access_level: amt$access_level;
         job_destination_usage: jmt$destination_usage;
         queue_file_password: jmt$queue_file_password;
     VAR file_identifier: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$access_level
*copyc amt$file_identifier
*copyc jme$queued_file_conditions
*copyc jmt$destination_usage
*copyc jmt$queue_file_password
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??

*DECK DECK=JMP$OPEN_OUTPUT_FILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$open_output_file
    (    system_file_name: jmt$system_supplied_name;
         access_level: amt$access_level;
         output_destination_usage: jmt$destination_usage;
         queue_file_password: jmt$queue_file_password;
     VAR file_identifier: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$access_level
*copyc amt$file_identifier
*copyc jme$queued_file_conditions
*copyc jmt$destination_usage
*copyc jmt$queue_file_password
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$OPEN_QFILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$open_qfile
    (    system_file_name: jmt$system_supplied_name;
         access_level: amt$access_level;
         application_name: ost$name;
         qfile_password: jmt$queue_file_password;
     VAR file_identifier: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$access_level
*copyc amt$file_identifier
*copyc jme$application_name_incorrect
*copyc jme$name_not_found
*copyc jme$qfile_appl_not_permitted
*copyc jmt$queue_file_password
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$OPEN_SYSTEM_PROFILE EXPAND=FALSE
  PROCEDURE [XREF] jmp$open_system_profile
    (    access_id: ost$binary_unique_name;
         cycle_number: jmt$system_profile_cycle_number;
         open_for_write: boolean;
         validation_attributes_p: ^fst$file_cycle_attributes;
     VAR profile_file_identifier: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc fst$attachment_options
*copyc fst$file_cycle_attributes
*copyc jmt$system_profile_cycle_number
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$OPERATOR_JOB EXPAND=FALSE

  FUNCTION [XREF] jmp$operator_job: boolean;
{--------------------------------------------------------------------
{                       WARNING!!!
{ This function will be eliminated in the near future.
{ Use jmp$system_job or a capability-based validation instead.
{---------------------------------------------------------------------
*DECK DECK=JMP$PERFORM_PHYSICAL_SWAPOUT EXPAND=FALSE

  PROCEDURE [XREF] jmp$perform_physical_swapout
    (    node: jmt$node;
         swapout_reason: jmt$swapout_reasons;
         class:  jmt$service_class_index;
         memory_needed: mmt$page_Frame_index;
     VAR status: ost$status);

?? PUSH(LIST := OFF) ??
*copyc jmt$node
*copyc jmt$swapout_reasons
*copyc jmt$service_class_index
*copyc mmt$page_frame_index
*copyc ost$status
?? POP ??
*DECK DECK=JMP$PRINT_FILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$print_file
    (    file_reference: fst$file_reference;
         output_submission_options: ^jmt$output_submission_options;
     VAR system_file_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$ring_validation_errors
*copyc cle$ecc_lexical
*copyc fst$file_reference
*copyc jme$invalid_parameter
*copyc jme$maximum_output
*copyc jme$no_space_for_file
*copyc jme$sl_version_mismatch
*copyc jmt$output_submission_options
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$PROCESS_ACTIVATE_JOB EXPAND=FALSE
  PROCEDURE [XREF] jmp$process_activate_job;
*DECK DECK=JMP$PROCESS_CHANGE_DISPATCHING EXPAND=FALSE

  PROCEDURE [XREF] jmp$process_change_dispatching;

*DECK DECK=JMP$PROCESS_DAMAGED_JOBS EXPAND=FALSE

  PROCEDURE [XREF] jmp$process_damaged_jobs;

*DECK DECK=JMP$PROCESS_JOB_HISTORY EXPAND=FALSE
  PROCEDURE [XREF] jmp$process_job_history
    (    current_control_user: ost$user_identification;
         current_login_user: ost$user_identification;
         requested_sort_order: jmt$job_history_sorted_order;
         trace_job_children: boolean;
         trace_job_output: boolean;
         trace_all_jobs: boolean;
         trace_all_output: boolean;
         display_output_history_command: boolean;
         job_names_requested: ^array [1 .. * ] of ost$name;
         family_names_requested: ^pmt$family_name_list;
         output_files_requested: ^array [1 .. * ] of jmt$name;
         start_log_search: jmt$beginning_log_position;
         output_file: ^fst$file_reference;
         input_file: ^fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jmt$job_history_sorted_order
*copyc jmt$name
*copyc jmt$beginning_log_position
*copyc ost$name
*copyc ost$status
*copyc ost$user_identification
*copyc pmt$family_name_list
?? POP ??
*DECK DECK=JMP$PROCESS_OPERATOR_REQUESTS EXPAND=FALSE

  PROCEDURE [XREF] jmp$process_operator_requests (VAR status: ost$status);

?? PUSH(LIST := OFF) ??
*copyc ost$status
?? POP ??

*DECK DECK=JMP$PROCESS_READY_TASK_IN_JOB EXPAND=FALSE
  PROCEDURE [XREF] jmp$process_ready_task_in_job;
*DECK DECK=JMP$PROCESS_SUBSYST_PRIO_CHANGE EXPAND=FALSE

  PROCEDURE [XREF] jmp$process_subsyst_prio_change;

*DECK DECK=JMP$PROCESS_TERMINAL_CLEAR EXPAND=FALSE

  PROCEDURE [XREF] jmp$process_terminal_clear;

*DECK DECK=JMP$PROCESS_TERMINAL_WAIT EXPAND=FALSE
PROCEDURE [XREF] jmp$process_terminal_wait(wait_estimate: INTEGER);
*DECK DECK=JMP$PROCESS_TERMINATED_JOB EXPAND=FALSE
PROCEDURE [XREF] jmp$process_terminated_job;
*DECK DECK=JMP$PROCESS_THRASHING EXPAND=FALSE
  PROCEDURE [XREF] jmp$process_thrashing;
*DECK DECK=JMP$PURGE_EXPIRED_FILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$purge_expired_file;

*DECK DECK=JMP$PURGE_EXPIRED_QUEUE_FILE EXPAND=FALSE
  PROCEDURE [XREF] jmp$purge_expired_queue_file;

*DECK DECK=JMP$PURGE_JOB_TEMPLATE_FILE EXPAND=FALSE
PROCEDURE [XREF] jmp$purge_job_template_file( name: ost$name;
                     VAR status: ost$status);
?? PUSH(LIST := OFF) ??
*copyc OST$NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=JMP$PURGE_PRINTED_FILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$purge_printed_file;

*DECK DECK=JMP$PURGE_PROCESSED_QUEUE_FILE EXPAND=FALSE
  PROCEDURE [XREF] jmp$purge_processed_queue_file;

*DECK DECK=JMP$QUEUE_OPERATOR_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] jmp$queue_operator_request
    (    operator_request: jmt$operator_request;
         ijl_ordinal: jmt$ijl_ordinal;
         system_supplied_name: jmt$system_supplied_name;
         dispatching_priority: jmt$dispatching_priority;
         disable_recovery: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$dispatching_priority
*copyc jmt$ijl_ordinal
*copyc jmt$operator_request_list
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$QUICK_LOAD_OF_JOB_TEMPLATE EXPAND=FALSE
PROCEDURE [XREF] jmp$quick_load_of_job_template (name: ost$name; VAR
                         code_base_p: ost$external_code_base_pointer,
                         status: ost$status);
?? PUSH(LIST := OFF) ??
*copyc OST$STATUS
*copyc OST$NAME
?? POP ??
*DECK DECK=JMP$RB_INITIATE_MON_CALL EXPAND=FALSE
   PROCEDURE[xref] jmp$rb_initiate_mon_call ( kjl_ord: jmt$kjl_ordinal;
     xcb_p: ^ost$execution_control_block;
     VAR status: ost$status);

*copyc JMT$KJL_ORDINAL
*copyc OST$EXECUTION_CONTROL_BLOCK
*copyc OST$STATUS
*DECK DECK=JMP$REACTIVATE_JOB_LEVELING EXPAND=FALSE

  PROCEDURE [XREF] jmp$reactivate_job_leveling
    (    access_id: ost$binary_unique_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??

*DECK DECK=JMP$READY_JOB_LEVELER_TASK EXPAND=FALSE

  PROCEDURE [XREF] jmp$ready_job_leveler_task
    (VAR task_executing: boolean);
*DECK DECK=JMP$READY_LOG_FILE EXPAND=FALSE


  PROCEDURE [XREF] jmp$ready_log_file
    (    start_log_search: jmt$beginning_log_position;
         current_login_user: ost$user_identification;
         file: ^fst$file_reference;
     VAR buffer: sft$statistic_buffer;
     VAR file_position: amt$file_position;
     VAR p_header: ^sft$global_log_statistic_header;
     VAR p_descriptor: ^sft$descriptive_data;
     VAR input_file: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amp$open
*copyc amp$get_next
*copyc fst$file_reference
*copyc jmt$beginning_log_position
*copyc ost$status
*copyc ost$user_identification
*copyc sft$global_log_statistic_header
*copyc sfd$type_declarations
*copyc sft$statistic_buffer
?? POP ??
*DECK DECK=JMP$READY_NON_DISPATCHABLE_JOBS EXPAND=FALSE

  PROCEDURE [XREF] jmp$ready_non_dispatchable_jobs
    (    dispatching_priority: jmt$dispatching_priority);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$dispatching_priority
?? POP ??
*DECK DECK=JMP$READY_TASK_IN_SWAPPED_JOB EXPAND=FALSE
  PROCEDURE [XREF] jmp$ready_task_in_swapped_job (ijl_ord: jmt$ijl_ordinal;
        ijle_p: ^jmt$initiated_job_list_entry);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=JMP$READ_APPLICATION_RECORD EXPAND=FALSE

  PROCEDURE [XREF] jmp$read_application_record
    (    application_name: jmt$application_name;
     VAR application_index: {input, output} jmt$application_index;
     VAR application_record: jmt$application_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$application_attributes
*copyc jmt$application_index
*copyc jmt$application_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$READ_CATEGORY_DATA EXPAND=FALSE

  PROCEDURE [XREF] jmp$read_category_data
    (VAR category_data: jmt$job_category_data;
     VAR data_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_category_data
*copyc ost$status
?? POP ??
*DECK DECK=JMP$READ_DEFINED_APPLICATIONS EXPAND=FALSE

  PROCEDURE [XREF] jmp$read_defined_applications
    (VAR defined_applications: jmt$defined_classes;
     VAR number_of_applications: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$defined_classes
*copyc ost$status
?? POP ??

*DECK DECK=JMP$READ_DEFINED_CLASSES EXPAND=FALSE

  PROCEDURE [XREF] jmp$read_defined_classes
    (    class_kind: jmt$class_kind;
     VAR defined_classes: jmt$defined_classes;
     VAR number_of_classes: ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$class_kind
*copyc jmt$defined_classes
*copyc osd$integer_limits
*copyc ost$status
?? POP ??

*DECK DECK=JMP$READ_JOB_CLASS_RECORD EXPAND=FALSE

  PROCEDURE [XREF] jmp$read_job_class_record
    (    job_class_index: jmt$job_class;
     VAR job_class_record: jmt$job_class_attributes;
     VAR data_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
*copyc jmt$job_class_attributes
*copyc ost$status
?? POP ??
*DECK DECK=JMP$READ_PROFILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$read_profile
    (    base_file: fst$file_reference;
     VAR the_profile: jmt$profile_data;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jme$profile_errors
*copyc jmt$profile_data
*copyc ost$status
?? POP ??
*DECK DECK=JMP$READ_SCHEDULER_TABLE EXPAND=FALSE

  PROCEDURE [XREF] jmp$read_scheduler_table
    (VAR scheduler_table: jmt$job_scheduler_table;
     VAR data_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_scheduler_table
*copyc ost$status
?? POP ??
*DECK DECK=JMP$READ_SYSTEM_PROFILE EXPAND=FALSE
  PROCEDURE [XREF] jmp$read_system_profile
    (    access_id: ost$binary_unique_name;
         cycle_number: jmt$system_profile_cycle_number;
     VAR the_profile: jmt$profile_data;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$profile_data
*copyc jmt$system_profile_cycle_number
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$REBUILD_EXECUTING_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$rebuild_executing_job (
        system_supplied_job_name: jmt$system_supplied_name;
        jcb_p: ^jmt$job_control_block);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc jmt$job_control_block
?? POP ??
*DECK DECK=JMP$REBUILD_GENERIC_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] jmp$rebuild_generic_queue (
        system_file_name: jmt$system_supplied_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$REBUILD_INPUT_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] jmp$rebuild_input_queue
    (    system_job_name: jmt$system_supplied_name;
         family_name: ost$name;
         subcatalog_name: ost$name;
         recover_using_abort_disposition: boolean;
         ignore_client_initiated_jobs: boolean;
         job_deferred_by_operator: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$REBUILD_OUTPUT_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] jmp$rebuild_output_queue (
        system_file_name: jmt$system_supplied_name;
        subcatalog_name: ost$name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$RECOGNIZE_JOB_DEAD EXPAND=FALSE
  PROCEDURE [XREF] jmp$recognize_job_dead (ijl_ordinal: jmt$ijl_ordinal);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=JMP$RECOGNIZE_THRASHING EXPAND=FALSE
  PROCEDURE [XREF] jmp$recognize_thrashing;

*DECK DECK=JMP$RECONCILE_LEVELED_JOBS EXPAND=FALSE

  PROCEDURE [XREF] jmp$reconcile_leveled_jobs
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=JMP$RECORD_JOB_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] jmp$record_job_attributes
    (    job_attributes_p: ^jmt$job_attributes;
         job_recovery_information_p: ^jmt$job_recovery_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_attributes
*copyc jmt$job_recovery_information
*copyc ost$status
?? POP ??
*DECK DECK=JMP$RECOVER_INPUT_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] jmp$recover_input_queue
    (    family_name: ost$name;
         defer_input_queue: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$RECOVER_PROFILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$recover_profile
    (VAR access_id: ost$binary_unique_name;
     VAR prevent_update_of_profile_file: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$activate_profile_errors
*copyc ost$status
?? POP ??
*DECK DECK=JMP$RECOVER_QUEUES EXPAND=FALSE

  PROCEDURE [XREF] jmp$recover_queues
    (    swap_file_recovery_list: ^jmt$swap_file_recovery_list;
         swap_file_recovery_list_count: jmt$job_count_range;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_count_range
*copyc jmt$swap_file_recovery_list
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=JMP$RECOVER_SWAPIN_JOBS EXPAND=FALSE

 PROCEDURE [XREF] jmp$recover_swapin_jobs;

*DECK DECK=JMP$REFRESH_JOB_CANDIDATES EXPAND=FALSE

  PROCEDURE [XREF] jmp$refresh_job_candidates;
*DECK DECK=JMP$REFRESH_JOB_CANDIDATE_CLASS EXPAND=FALSE

  PROCEDURE [XREF] jmp$refresh_job_candidate_class (
        job_class: jmt$job_class;
        initiation_succeeded: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
?? POP ??
*DECK DECK=JMP$REGISTER_INPUT_APPLICATION EXPAND=FALSE

  PROCEDURE [XREF] jmp$register_input_application
    (    application_name: ost$name;
         job_destination_usage: jmt$destination_usage;
     VAR queue_file_password: jmt$queue_file_password;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc jme$queued_file_conditions
*copyc jmt$destination_usage
*copyc jmt$queue_file_password
*copyc ost$name
*copyc ost$status
?? POP ??

*DECK DECK=JMP$REGISTER_JOB_LEVELER EXPAND=FALSE

  PROCEDURE [XREF] jmp$register_job_leveler;

*DECK DECK=JMP$REGISTER_OUTPUT_APPLICATION EXPAND=FALSE

  PROCEDURE [XREF] jmp$register_output_application
    (    application_name: ost$name;
         output_destination_usage: jmt$destination_usage;
     VAR queue_file_password: jmt$queue_file_password;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc jme$queued_file_conditions
*copyc jmt$destination_usage
*copyc jmt$queue_file_password
*copyc ost$name
*copyc ost$status
?? POP ??

*DECK DECK=JMP$REGISTER_QFILE_APPLICATION EXPAND=FALSE

  PROCEDURE [XREF] jmp$register_qfile_application
    (    application_name: ost$name;
         registration_options_p: ^jmt$qfile_registration_options;
     VAR queue_file_password: jmt$queue_file_password;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc jme$application_table_is_full
*copyc jmt$qfile_registration_options
*copyc jmt$queue_file_password
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$RELEASE_GENERIC_QUEUE_FILES EXPAND=FALSE
  PROCEDURE [XREF] jmp$release_generic_queue_files;

*DECK DECK=JMP$RELEASE_INPUT_FILES EXPAND=FALSE

  PROCEDURE [XREF] jmp$release_input_files;

*DECK DECK=JMP$RELEASE_OUTPUT_FILES EXPAND=FALSE

  PROCEDURE [XREF] jmp$release_output_files;

*DECK DECK=JMP$RELINK_TO_END_OF_SWAPIN_Q EXPAND=FALSE

  PROCEDURE [XREF] jmp$relink_to_end_of_swapin_q
    (    ijl_ordinal: jmt$ijl_ordinal);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
?? POP ??

*DECK DECK=JMP$REORDER_SWAPIN_QUEUES EXPAND=FALSE

  PROCEDURE [XREF] jmp$reorder_swapin_queues
    (    class_set: jmt$service_class_set);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_class_set
?? POP ??

*DECK DECK=JMP$RESET_ACTIVATE_EVENT EXPAND=FALSE

  PROCEDURE [XREF] jmp$reset_activate_event;
*DECK DECK=JMP$RESET_ACTIVATE_EVENTS_SELS EXPAND=FALSE

  PROCEDURE [XREF] jmp$reset_activate_events_sels;

*DECK DECK=JMP$RESET_ADVANCE_LW_SWAPS EXPAND=FALSE

  PROCEDURE [XREF] jmp$reset_advance_lw_swaps
    (VAR memory_flushed_from_lw_queue: mmt$page_frame_index);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_index
?? POP ??
*DECK DECK=JMP$RESET_DISPATCHING_PRIORITY EXPAND=FALSE

  PROCEDURE [XREF] jmp$reset_dispatching_priority;
*DECK DECK=JMP$RESET_IJL_SEARCH_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] jmp$reset_ijl_search_block
    (    ijl_block_number: jmt$ijl_block_number);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=JMP$RESET_JOB_TO_SWAPPED_OUT EXPAND=FALSE

  PROCEDURE [XREF] jmp$reset_job_to_swapped_out (ijl_o: jmt$ijl_ordinal);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=JMP$RESET_MAX_CLASS_WORKING_SET EXPAND=FALSE

  PROCEDURE [INLINE] jmp$reset_max_class_working_set;

    VAR
      job_class: jmt$job_class;

{ JMV$MAX_CLASS_WORKING_SET does not include the maximum working set of the System Job.  Therefore, If there
{ is only one job in the system job class, do not use the maximum of the system job class.

    IF jmv$job_counts.job_class_counts [jmc$system_job_class].initiated_jobs > 1  THEN
      jmv$max_class_working_set := jmv$job_class_table_p^ [jmc$system_job_class].maximum_working_set.maximum;
    ELSE
      jmv$max_class_working_set := 0;
    IFEND;
    FOR  job_class := jmc$maintenance_job_class TO jmv$maximum_job_class_in_use DO
      IF (jmv$job_counts.job_class_counts [job_class].initiated_jobs > 0) AND (jmv$max_class_working_set <
            jmv$job_class_table_p^ [job_class].maximum_working_set.maximum) THEN
          jmv$max_class_working_set := jmv$job_class_table_p^ [job_class].maximum_working_set.maximum;
      IFEND;
    FOREND;

  PROCEND jmp$reset_max_class_working_set;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
*copyc jmv$job_class_table_p
*copyc jmv$job_counts
*copyc jmv$max_class_working_set
*copyc jmv$maximum_job_class_in_use
?? POP ??
*DECK DECK=JMP$RESET_TIME_TO_WAKE_SCHED EXPAND=FALSE

PROCEDURE [XREF] jmp$reset_time_to_wake_sched;

*DECK DECK=JMP$RESTORE_DISPATCHING_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] jmp$restore_dispatching_control
    (    dispatching_control_info: jmt$dispatching_control_info);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$dispatching_control_info
?? POP ??
*DECK DECK=JMP$RESTORE_JOB_ENVIRONMENT EXPAND=FALSE
PROCEDURE [XREF] jmp$restore_job_environment(node: jmt$node;
                          VAR status: ost$status);
?? PUSH(LIST := OFF) ??
*copyc OST$STATUS
*copyc jmt$node
?? POP ??
*DECK DECK=JMP$RESTORE_JOB_FILES EXPAND=TRUE
PROCEDURE jmp$restore_job_files (
  control_family, control_families, cf: list of name = $optional
  control_user, control_users, cu: list of name = $optional
  job_category_name, job_category_names, jcn: list of name = $optional
  job_class, job_classes, jc: list of name = $optional
  job_deferred_by_user, jdbu: boolean = $optional
  job_qualifier, job_qualifiers, jq: list of name = $optional
  login_account, login_accounts, la: list of name = $optional
  login_family, login_families, lf: list of name = $optional
  login_project, login_projects, lp: list of name = $optional
  login_user, login_users, lu: list of name = $optional
  name, names, n: list of name = $optional
  site_information, si: list of string 0..256 = $optional
  user_information, ui: list of string 0..256 = $optional
  maximum_selection, maxs: any of
      key
        all
      keyend
      integer 1..65535
    anyend = all
  vsn, vsns, v: list of any of
      name 1..6
      string 1..6
    anyend = $optional
  vsn_prefix, vp: any of
      name 1..5
      string 1..5
    anyend = $optional
  vsn_count, vc: integer 1..11881376 = 15
  vsn_suffix, vs: any = $optional
  increment_scheme, is: key
      (alphabetic, a)
      (decimal, d)
    keyend = decimal
  type, t: key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = mt9$1600
  excluded_file_list, efl: (VAR) list 0..$max_list of name = $optional
  backup_file ,bf:file = $optional
  output, o: file = $OUTPUT
  errors, e: file = $ERRORS
  unload_volume, uv: boolean = TRUE
  status)

" Confirm that we are in the system_operator_utility with the system_administration and system_operation
" capabilities active.

  WHEN COMMAND_FAULT DO
    EXIT PROCEDURE WITH $STATUS(FALSE 'OF' ofe$sou_not_active 'system_administration and system_operation')
  WHENEND

  VAR
    active_capabilities: file = $unique($local)
    ignore_status: status
    lines: list 0..$max_list of string
  VAREND

  system_operator_utility.display_active_capabilities output=active_capabilities
  get_line variable=lines input=active_capabilities
  detach_file file=active_capabilities status=ignore_status
  IF $nil($select_wild_card_strings(lines '*system_administration*' basic)) OR ..
     $nil($select_wild_card_strings(lines '*system_operation*' basic)) THEN
    EXIT PROCEDURE WITH $STATUS(FALSE 'OF' ofe$sou_not_active 'system_administration and system_operation')
  IFEND

  CANCEL COMMAND_FAULT
  VAR
    constructed_vsn_list: list 1..$max_list of string 6
    current_ring: integer 1..15 = $ring
    output_created: boolean = NOT $file(output assigned)
    queue_backup: file = $unique($local)
    vsn_list: list 1..$max_list of string 1..6
  VAREND

  WHEN ANY_FAULT DO
    IF NOT $SPECIFIED(backup_file) THEN
      detach_file file=queue_backup unload_volume=unload_volume status=ignore_status
    IFEND
    IF output_created THEN
      change_file_attributes file=output ring_attributes=(current_ring current_ring current_ring)
    IFEND
    EXIT_PROC
  WHENEND

" Construct the list of VSNs for the backup tape set.

  IF $specified(vsn) THEN
    IF $specified(vsn_prefix) OR $specified(vsn_suffix) THEN
      EXIT PROCEDURE WITH $STATUS(FALSE 'JM' jme$incompatible_vsn_params '')
    IFEND
    IF $NIL(vsn) THEN
      EXIT PROCEDURE WITH $STATUS(FALSE 'JM' jme$empty_vsn_list '')
    IFEND
    vsn_list = $string(vsn)

  ELSEIF NOT ($specified(vsn_prefix) OR $specified(vsn_suffix)) THEN
    IF NOT $specified(backup_FILE) THEN
      EXIT PROCEDURE WITH $STATUS(FALSE 'JM' jme$vsn_vsnp_vsns_bf_required '')
    IFEND
  ELSE
    pup$construct_volume_list vsn_count=vsn_count vsn_prefix=vsn_prefix increment_scheme=increment_scheme ..
          volume_list=constructed_vsn_list
    vsn_list = constructed_vsn_list
  IFEND

" Restore all the files on the specified backup tape set.

  TASK RING=3
    IF NOT $SPECIFIED(BACKUP_FILE) THEN
      request_magnetic_tape queue_backup recorded_vsn=vsn_list ring=false type=type
    ELSE
      queue_backup=backup_file
    IFEND
    RESTORE_PERMANENT_FILES list=output
      restore_all_files backup_file=queue_backup status=ignore_status
    QUIT " restore_permanent_files "
    IF NOT $SPECIFIED(backup_file) THEN
      detach_file file=queue_backup unload_volume=unload_volume status=ignore_status
    IFEND
    IF output_created THEN
      change_file_attributes file=output ring_attributes=(current_ring current_ring current_ring)
    IFEND
  TASKEND
  CANCEL ANY_FAULT
  $system.MANAGE_JOBS

    change_list_options output=output errors=errors

"$FORMAT=OFF"
    VAR
      activated_jobs: list 0..$max_list of name
      desired_jobs: list 0..$max_list of name
      selected_jobs: list 0..$max_list of name
      unwanted_jobs: list 0..$max_list of name
    VAREND
"$FORMAT=ON"

" Activate all jobs that were restored or otherwise inactive but present in the input queue catalogs.

    activate_job_files files_activated=activated_jobs

" Construct a list of system job names of the desired jobs to restore.

    select_jobs control_family=control_family control_user=control_user job_category_name=job_category_name ..
          job_class=job_class job_deferred_by_operator=TRUE ..
          job_deferred_by_user=job_deferred_by_user job_qualifier=job_qualifier login_account=login_account ..
          login_family=login_family login_project=login_project login_user=login_user name=name ..
          site_information=site_information user_information=user_information ..
          maximum_selection=maximum_selection job_selection_list=selected_jobs

    desired_jobs = $intersection(activated_jobs selected_jobs)
    unwanted_jobs = $difference(activated_jobs selected_jobs)

" Get rid of the unchosen jobs, and return their system job names as the excluded_file_list argument.

    IF NOT $NIL(unwanted_jobs) THEN
      terminate_jobs names=unwanted_jobs reason=none
    IFEND
    IF $SPECIFIED(excluded_file_list) THEN
      excluded_file_list = unwanted_jobs
    IFEND

" Emit job_queuing_started history statistics for the desired jobs and reenable them for initiation.

    IF NOT $NIL(desired_jobs) THEN
      log_restored_job_files files_restored=desired_jobs
      display_input_attributes names=desired_jobs display_option=all output=output.$eoi
      change_input_attributes names=desired_jobs job_deferred_by_operator=false
    IFEND

  QUIT " manage_jobs "

PROCEND jmp$restore_job_files
*DECK DECK=JMP$RESTORE_OUTPUT_FILES EXPAND=TRUE
PROCEDURE jmp$restore_output_files (
  comment_banner, comment_banners, cb: list of string 0..31 = $optional
  control_family, control_families, cf: list of name = $optional
  control_user, control_users, cu: list of name = $optional
  data_mode, dm: list of key
      (coded, c)
      (transparent, t)
    keyend = $optional
  device, devices, d: list of any of
      key
        automatic
      keyend
      name
    anyend = $optional
  external_characteristics, ec: list of any of
      key
        normal
      keyend
      string 0..6
    anyend = $optional
  forms_code, forms_codes, fc: list of any of
      key
        normal
      keyend
      string 0..6
    anyend = $optional
  login_account, login_accounts, la: list of name = $optional
  login_family, login_families, lf: list of name = $optional
  login_project, login_projects, lp: list of name = $optional
  login_user, login_users, lu: list of name = $optional
  name, names, n: list of name = $optional
  operator_family, operator_families, of: list of name = $optional
  operator_user, operator_users, ou: list of name = $optional
  output_class, output_classes, oc: list of name = $optional
  output_deferred_by_user, odbu: boolean = $optional
  output_destination, output_destinations, ode: list of any of
      name
      string 0..31
    anyend = $optional
  output_destination_usage, odu: list of any of
      key
        dual_state, ntf, private, public, qtf
      keyend
      name
    anyend = $optional
  output_priority, output_priorities, op: list of name = $optional
  remote_host_directive, remote_host_directives, rhd: list of string 0..256 = $optional
  routing_banner, routing_banners, rb: list of string 0..31 = $optional
  site_information, si: list of string 0..256 = $optional
  station, stations, s: list of any of
      key
        automatic
      keyend
      name
    anyend = $optional
  system_job_name, system_job_names, sjn: list of name = $optional
  user_information, ui: list of string 0..256 = $optional
  vertical_print_density, vertical_print_densities, vpd: list of key
      six, eight, none
    keyend = $optional
  vfu_load_procedure, vfu_load_procedures, vlp: list of any of
      key
        none
      keyend
      name
    anyend = $optional
  maximum_selection, maxs: any of
      key
        all
      keyend
      integer 1..65535
    anyend = all
  vsn, vsns, v: list of any of
      name 1..6
      string 1..6
    anyend = $optional
  vsn_prefix, vp: any of
      name 1..5
      string 1..5
    anyend = $optional
  vsn_count, vc: integer 1..11881376 = 15
  vsn_suffix, vs: any = $optional
  increment_scheme, is: key
      (alphabetic, a)
      (decimal, d)
    keyend = decimal
  type, t: key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = mt9$1600
  backup_file, bf:file = $optional
  excluded_file_list, efl: (VAR) list 0..$max_list of name = $optional
  output, o: file = $OUTPUT
  errors, e: file = $ERRORS
  status)

  " Confirm that we are in the system_operator_utility with the system_administration and system_operation
  " capabilities active.

  WHEN command_fault DO
  exit procedure with $status(FALSE 'OF' ofe$sou_not_active 'system_administration and system_operation')
  WHENEND

  VAR
    active_capabilities: file = $unique($local)
    ignore_status: status
    lines: list 0..$max_list of string
  VAREND

  system_operator_utility.display_active_capabilities output=active_capabilities
  get_line variable=lines input=active_capabilities
  detach_file file=active_capabilities status=ignore_status
  IF $nil($select_wild_card_strings(lines '*system_administration*' basic)) OR ..
     $nil($select_wild_card_strings(lines '*system_operation*' basic)) THEN
    exit procedure with $status(FALSE 'OF' ofe$sou_not_active 'system_administration and system_operation')
  IFEND
  CANCEL command_fault
  VAR
    constructed_vsn_list: list 1..$max_list of string 6
    current_ring: integer 1..15 = $ring
    output_created: boolean = NOT $file(output assigned)
    queue_backup: file = $unique($local)
    vsn_list: list 1..$max_list of string 1..6
  VAREND

  IF $specified(vsn) THEN
    IF $specified(vsn_prefix) OR $specified(vsn_suffix) THEN
      exit procedure with $status(FALSE 'JM' jme$incompatible_vsn_params '')
    IFEND
    IF $nil(vsn) THEN
      exit procedure with $status(FALSE 'JM' jme$empty_vsn_list '')
    IFEND
    vsn_list = $string(vsn)

    ELSEIF NOT ($specified(vsn_prefix) OR $specified(vsn_suffix)) THEN
    IF NOT $specified(backup_file) THEN
      exit procedure with $status(FALSE 'JM' jme$vsn_vsnp_vsns_bf_required '')
    IFEND
    ELSE
    pup$construct_volume_list vsn_count=vsn_count vsn_prefix=vsn_prefix increment_scheme=increment_scheme ..
          volume_list=constructed_vsn_list
    vsn_list = constructed_vsn_list
  IFEND

  " Restore all the files on the specified backup tape set.
  TASK ring=3
     IF NOT $specified(backup_file) THEN
    request_magnetic_tape queue_backup recorded_vsn=vsn_list ring=false type=type
     ELSE
    queue_backup=backup_file
     IFEND
    RESTORE_PERMANENT_FILES list=output
      restore_all_files backup_file=queue_backup status=ignore_status
    QUIT
     IF NOT $specified(backup_file) THEN
     detach_file file=queue_backup
     IFEND
    IF output_created THEN
      change_file_attributes file=output ring_attributes=(current_ring current_ring current_ring)
    IFEND
  TASKEND

  $system.MANAGE_OUTPUT

    change_list_options output=output errors=errors

    "$FORMAT=OFF"
    VAR
      activated_files: list 0..$max_list of name
      desired_files: list 0..$max_list of name
      selected_files: list 0..$max_list of name
      unwanted_files: list 0..$max_list of name
    VAREND
    "$FORMAT=ON"

    " Activate all files that were restored or otherwise inactive but present in the output queue catalogs.

    activate_output_files files_activated=activated_files

    " Construct a list of system file names of the desired outputs to restore.

    select_output comment_banner=comment_banner control_family=control_family control_user=control_user ..
          data_mode=data_mode device=device external_characteristics=external_characteristics ..
          forms_code=forms_code login_account=login_account login_family=login_family ..
          login_project=login_project login_user=login_user name=name operator_family=operator_family ..
          operator_user=operator_user output_class=output_class output_deferred_by_operator=TRUE ..
          output_deferred_by_user=output_deferred_by_user output_destination=output_destination ..
          output_destination_usage=output_destination_usage output_priority=output_priority ..
          remote_host_directive=remote_host_directive routing_banner=routing_banner ..
          site_information=site_information station=station system_job_name=system_job_name ..
          user_information=user_information vertical_print_density=vertical_print_density ..
          vfu_load_procedure=vfu_load_procedure maximum_selection=maximum_selection ..
          output_selection_list=selected_files

    desired_files = $intersection(activated_files selected_files)
    unwanted_files = $difference(activated_files selected_files)

    " Get rid of the unchosen outputs, and return their system file names as the excluded_file_list argument.

    IF NOT $nil(unwanted_files) THEN
      terminate_output names=unwanted_files reason=none
    IFEND
    IF $specified(excluded_file_list) THEN
      excluded_file_list = unwanted_files
    IFEND

    " Emit output_queuing_started history statistics for the desired outputs and reenable them for initiation.

    IF NOT $nil(desired_files) THEN
      log_restored_output_files files_restored=desired_files
      display_output_attributes names=desired_files display_option=all output=output.$eoi
      change_output_attributes names=desired_files output_deferred_by_operator=false
    IFEND
  QUIT

PROCEND jmp$restore_output_files
*DECK DECK=JMP$RESUBMIT_QUEUED_INPUT_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$resubmit_queued_input_job
    (    system_supplied_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$RESUME_ACTIVATION_OF_JOBS EXPAND=FALSE

  PROCEDURE [XREF] jmp$resume_activation_of_jobs;

*DECK DECK=JMP$RESUME_JOBS EXPAND=FALSE

  PROCEDURE [XREF] jmp$resume_jobs (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$RESUME_SYSTEM EXPAND=FALSE
{ This deck will be deleted.  It is a temporary deck.
  PROCEDURE [XREF] jmp$resume_system (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$RESURRECT_DEAD_JOBS EXPAND=FALSE

  PROCEDURE [XREF] jmp$resurrect_dead_jobs;

*DECK DECK=JMP$RETURN_CONNECTION EXPAND=FALSE
  PROCEDURE [XREF] jmp$return_connection
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SAVE_JOB_TEMPLATES EXPAND=FALSE

  PROCEDURE [XREF] jmp$save_job_templates( VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=JMP$SAVE_RECOVERY_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] jmp$save_recovery_information
    (    job_system_label_p: ^jmt$job_system_label);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_system_label
?? POP ??
*DECK DECK=JMP$SAVE_SFID_OF_SWAP_FILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$save_sfid_of_swap_file (sfid: dmt$system_file_id;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=JMP$SAVE_SYSTEM_CORE_TEMPLATE EXPAND=FALSE

  PROCEDURE [XREF] jmp$save_system_core_template( VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=JMP$SCAN_AJL_FOR_SERVICE EXPAND=FALSE

PROCEDURE [XREF] jmp$scan_ajl_for_service;
*DECK DECK=JMP$SCAN_FOR_FORCED_SWAPOUT EXPAND=FALSE
{ PROCEDURE [XREF] jmp$scan_for_forced_swapout;
*DECK DECK=JMP$SCHED_SWAPIN_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$sched_swapin_job (ijl_ordinal: jmt$ijl_ordinal;
        system_supplied_name: jmt$system_supplied_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc jmt$system_supplied_name
*copyc OST$STATUS
?? POP ??
*DECK DECK=JMP$SCHED_SWAPOUT_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$sched_swapout_job (ijl_ordinal: jmt$ijl_ordinal;
      system_supplied_name: jmt$system_supplied_name;
    VAR status: ost$status);

?? PUSH(LIST := OFF) ??
*copyc jmt$ijl_ordinal
*copyc jmt$system_supplied_name
*copyc OST$STATUS
?? POP ??
*DECK DECK=JMP$SELECT_INTERACTIVE_JOB_DEST EXPAND=FALSE

    PROCEDURE [XREF] jmp$select_interactive_job_dest
      (    valid_mainframe_list: array [1 .. * ] of pmt$mainframe_id;
           interactive_job_info: jmt$interactive_job_info;
       VAR selected_mainframe: pmt$mainframe_id;
       VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$interactive_job_info
*copyc pmt$mainframe_id
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SELECT_JOB_FOR_THRASHING EXPAND=FALSE

  PROCEDURE [XREF] jmp$select_job_for_thrashing
    (VAR node: jmt$node;
     VAR class: jmt$service_class_index;
     VAR ws: integer;
     VAR done: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$node
*copyc jmt$service_class_index
?? POP ??
*DECK DECK=JMP$SELECT_RESET_DISP_PR EXPAND=FALSE

  PROCEDURE [XREF] jmp$select_reset_disp_pr;
*DECK DECK=JMP$SELECT_RESET_DISP_PR_R2 EXPAND=FALSE

  PROCEDURE [XREF] jmp$select_reset_disp_pr_r2;
*DECK DECK=JMP$SELECT_RESET_DISP_PR_R3 EXPAND=FALSE

  PROCEDURE [XREF] jmp$select_reset_disp_pr_r3;

*DECK DECK=JMP$SELECT_SCHEDULER_AJLO_EVENT EXPAND=FALSE

  PROCEDURE [XREF] jmp$select_scheduler_ajlo_event (class: jmt$service_class_index);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_class_index
?? POP ??
*DECK DECK=JMP$SELECT_SCHEDULER_SHORT_WAIT EXPAND=FALSE

  PROCEDURE [XREF] jmp$select_scheduler_short_wait;

*DECK DECK=JMP$SELECT_SCHED_MEMORY_EVENT EXPAND=FALSE

  PROCEDURE [XREF] jmp$select_sched_memory_event (ws: mmt$page_frame_index;
        class: jmt$service_class_index);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_class_index
*copyc mmt$page_frame_index
?? POP ??
*DECK DECK=JMP$SELECT_SCHED_SERVICE_WAIT EXPAND=FALSE

  PROCEDURE [XREF] jmp$select_sched_service_wait;
*DECK DECK=JMP$SEND_JOB_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] jmp$send_job_message
    (    target_mainframe_id: pmt$mainframe_id;
         job_message: jmt$job_message;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$job_message_error
*copyc jmt$job_message
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=JMP$SERVER_GENERAL_PURPOSE_RPC EXPAND=FALSE

  PROCEDURE [XREF] jmp$server_general_purpose_rpc
    (VAR received_from_client_params_p { Input } : dft$p_receive_parameters;
     VAR received_from_client_data_p { Input } : dft$p_receive_data;
     VAR send_to_client_params_p { Output } : dft$p_send_parameters;
     VAR send_to_client_data_p { Output } : dft$p_send_data;
     VAR parameter_size: dft$send_parameter_size;
     VAR data_size: dft$send_data_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_parameters
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SERVER_GET_JOB_STATUS EXPAND=FALSE
*DECK DECK=JMP$SERVER_JOB_BEGIN EXPAND=FALSE

  PROCEDURE [XREF] jmp$server_job_begin
    (VAR received_from_client_params_p { Input } : dft$p_receive_parameters;
     VAR received_from_client_data_p { Input } : dft$p_receive_data;
     VAR send_to_client_params_p { Output } : dft$p_send_parameters;
     VAR send_to_client_data_p { Output } : dft$p_send_data;
     VAR parameter_size: dft$send_parameter_size;
     VAR data_size: dft$send_data_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_parameters
*copyc ost$status
?? POP ??

*DECK DECK=JMP$SERVER_SEND_JOB_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] jmp$server_send_job_message
    (VAR received_from_client_params_p { Input } : dft$p_receive_parameters;
     VAR received_from_client_data_p { Input } : dft$p_receive_data;
     VAR send_to_client_params_p { Output } : dft$p_send_parameters;
     VAR send_to_client_data_p { Output } : dft$p_send_data;
     VAR parameter_size: dft$send_parameter_size;
     VAR data_size: dft$send_data_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_parameters
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SERVER_SUBMIT_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$server_submit_job
    (VAR received_from_client_params_p { Input } : dft$p_receive_parameters;
     VAR received_from_client_data_p { Input } : dft$p_receive_data;
     VAR send_to_client_params_p { Output } : dft$p_send_parameters;
     VAR send_to_client_data_p { Output } : dft$p_send_data;
     VAR parameter_size: dft$send_parameter_size;
     VAR data_size: dft$send_data_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_parameters
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SERVER_TERMINATE_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$server_terminate_job
    (VAR received_from_client_params_p { Input } : dft$p_receive_parameters;
     VAR received_from_client_data_p { Input } : dft$p_receive_data;
     VAR send_to_client_params_p { Output } : dft$p_send_parameters;
     VAR send_to_client_data_p { Output } : dft$p_send_data;
     VAR parameter_size: dft$send_parameter_size;
     VAR data_size: dft$send_data_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_parameters
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SET_ACCOUNT_PROJECT_SPECIF EXPAND=FALSE


  PROCEDURE [XREF] jmp$set_account_project_specif (account_project_specified: boolean;
    VAR status: ost$status);

?? PUSH ( LIST := OFF {LISTEXT:=ON} ) ??
*copyc OST$STATUS
?? POP ??

*DECK DECK=JMP$SET_ALL_JOBS_SWAPPED_VAR EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_all_jobs_swapped_var;

*DECK DECK=JMP$SET_APPLICATION_SCHEDULING EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_application_scheduling
    (    application_attributes: jmt$application_attributes;
         new_service_accumulator: jmt$service_accumulator;
     VAR old_service_accumulator: jmt$service_accumulator;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$application_attributes
*copyc jmt$service_accumulator
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SET_CLASS_BELOW_MAXAJ_LIMIT EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_class_below_maxaj_limit
    (   service_class_set: jmt$service_class_set);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_class_set
?? POP ??
*DECK DECK=JMP$SET_DEFAULT_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_default_attributes
    (    the_kind: jmt$profile_object_kinds;
         default_value: clt$parameter_value;
     VAR the_attributes: jmt$object_attribute;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc jme$profile_object_errors
*copyc jmt$profile_data
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SET_DISPLAY_MESSAGE_POINTER EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_display_message_pointer
    (    display_message_p: ^oft$display_message_info);

?? PUSH (LISTEXT := ON) ??
*copyc oft$display_message_info
?? POP ??
*DECK DECK=JMP$SET_ENTRY_STATUS_TO_RT EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_entry_status_to_rt
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=JMP$SET_EVENT_AND_READY_SCHED EXPAND=TRUE

  PROCEDURE [XREF] jmp$set_event_and_ready_sched (event: jmt$job_scheduler_events);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_scheduler_event
?? POP ??
*DECK DECK=JMP$SET_EXAMINE_INPUT_EVENT EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_examine_input_event;
*DECK DECK=JMP$SET_EXAMINE_QUEUE_EVENT EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_examine_queue_event
    (    event: jmt$job_scheduler_events;
         job_class: jmt$job_class;
         unconditional: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
*copyc jmt$job_scheduler_event
?? POP ??
*DECK DECK=JMP$SET_HIGH_SWAPIN_PRIORITY EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_high_swapin_priority
    (    ijl_ordinal: jmt$ijl_ordinal);

??PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
?? POP ??

*DECK DECK=JMP$SET_IDLE_SYSTEM_EVENT EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_idle_system_event;
*DECK DECK=JMP$SET_INPUT_COMPLETED EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_input_completed
    (    job_destination_usage: jmt$destination_usage;
         system_job_name: jmt$system_supplied_name;
         completed_successfully: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$destination_usage
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SET_INPUT_INITIATED EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_input_initiated
    (    job_destination_usage: jmt$destination_usage;
         system_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$destination_usage
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SET_INTERACTIVE_COND_STATE EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_interactive_cond_state
    (    interactive_conditions_enabled: boolean);

*DECK DECK=JMP$SET_JOB_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_job_attributes
    (    job_attribute_changes: ^jmt$job_attribute_changes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_attribute_changes
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=JMP$SET_JOB_CLASS_LIMITS EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_job_class_limits (
        job_class_set: jmt$job_class_set;
        class_limit_value: jmt$job_count_range;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class_set
*copyc jmt$job_count_range
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SET_JOB_HISTORY_STATE EXPAND=TRUE

  PROCEDURE [XREF] jmp$set_job_history_state
    (    state: boolean);
*DECK DECK=JMP$SET_JOB_INPUT_DEVICE EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_job_input_device
    (    job_input_device: jmt$job_input_device);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_input_device
?? POP ??
*DECK DECK=JMP$SET_JOB_MODE EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_job_mode
    (    mode: jmt$job_mode;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_mode
*copyc ost$status
?? POP ??

*DECK DECK=JMP$SET_JOB_RESOURCE_CONDITION EXPAND=FALSE
  PROCEDURE [XREF] jmp$set_job_resource_condition (condition : jmt$job_resource_condition;
    VAR status: ost$status);

*copyc ost$status
*copyc jmd$job_resource_condition

*DECK DECK=JMP$SET_JOB_SWAP_STATUS EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_job_swap_status (ajl_ordinal: jmt$ajl_ordinal;
        swap_status: jmt$swap_status;
    VAR abort_swap: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc JMT$AJL_ORDINAL
?? POP ??
*DECK DECK=JMP$SET_JOB_TERMINATED EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_job_terminated
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=JMP$SET_JOB_TERMINATION_STATUS EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_job_termination_status
    (    status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SET_JOB_TERM_DISPOSITION EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_job_term_disposition;
*DECK DECK=JMP$SET_JOB_UNSWAPPABLE EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_job_unswappable (VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=JMP$SET_LOWER_MAXAJ_EVENT EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_lower_maxaj_event;

*DECK DECK=JMP$SET_MULTIPROCESSING_R1 EXPAND=FALSE
 PROCEDURE [XREF] jmp$set_multiprocessing_r1 (new_multiprocessing_state:
  ost$name;
  processor_id_set : ost$processor_id_set;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$processor_id_set
*copyc ost$status
*copyc ost$name
?? POP ??
*DECK DECK=JMP$SET_MULTIPROCESSING_R3 EXPAND=FALSE
 PROCEDURE [XREF] jmp$set_multiprocessing_r3 (multiprocessing_state: ost$name;
    processor_id_set : ost$processor_id_set;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$processor_id_set
*copyc ost$status
*copyc ost$name
?? POP ??
*DECK DECK=JMP$SET_OBJECT_DEFAULT EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_object_default
    (    object_kind: jmt$profile_object_kinds;
         objects: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$profile_object_kinds
*copyc clt$data_value
?? POP ??
*DECK DECK=JMP$SET_OPERATOR_EVENT EXPAND=FALSE
  PROCEDURE [XREF] jmp$set_operator_event;
*DECK DECK=JMP$SET_OUTPUT_COMPLETED EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_output_completed
    (    output_destination_usage: jmt$destination_usage;
         system_file_name: jmt$system_supplied_name;
         completed_successfully: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$destination_usage
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??

*DECK DECK=JMP$SET_OUTPUT_INITIATED EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_output_initiated
    (    output_destination_usage: jmt$destination_usage;
         system_file_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$destination_usage
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SET_PROFILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_profile
    (VAR profile: jmt$profile_data);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$profile_data
?? POP ??
*DECK DECK=JMP$SET_PROFILE_LOADING_FLAG EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_profile_loading_flag
    (    profile_is_loading: boolean;
         new_profile_id: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SET_QFILE_COMPLETED EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_qfile_completed
    (    application_name: ost$name;
         system_file_name: jmt$system_supplied_name;
         completed_successfully: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$application_name_incorrect
*copyc jme$name_not_found
*copyc jme$qfile_appl_not_permitted
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SET_QFILE_INITIATED EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_qfile_initiated
    (    application_name: ost$name;
         system_file_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$application_name_incorrect
*copyc jme$name_not_found
*copyc jme$qfile_appl_not_permitted
*copyc jme$qfile_cannot_initiate
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SET_SCHEDULER_EVENT EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_scheduler_event (event: jmt$job_scheduler_events);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_scheduler_event
?? POP ??
*DECK DECK=JMP$SET_SCHEDULER_MEMORY_EVENT EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_scheduler_memory_event;

*DECK DECK=JMP$SET_SCHEDULER_TIME_EVENT EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_scheduler_time_event;

*DECK DECK=JMP$SET_SCHED_FLAG EXPAND=FALSE
  PROCEDURE [XREF] jmp$set_sched_flag(on_or_off: BOOLEAN);

*DECK DECK=JMP$SET_SCHED_SERVICE_CALC_TIME EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_sched_service_calc_time;

*DECK DECK=JMP$SET_SCHED_THRASHING_EVENT EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_sched_thrashing_event;

*DECK DECK=JMP$SET_SWAPOUT_CANDIDATE EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_swapout_candidate
    (    ajl_ordinal: jmt$ajl_ordinal;
         swapout_reason: jmt$swapout_reasons);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ajl_ordinal
*copyc jmt$swapout_reasons
?? POP ??
*DECK DECK=JMP$SET_SYSTEM_SEQUENCE_NUMBER EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_system_sequence_number
    (    system_sequence_number: string (* <= osc$max_name_size);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SET_UNABLE_TO_SWAP_FLAG EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_unable_to_swap_flag
    (     ijl_ordinal: jmt$ijl_ordinal);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=JMP$SET_UTILITY_ACTIVE EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_utility_active
    (VAR access_id: ost$binary_unique_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SET_UTILITY_ACTIVE_FLAG EXPAND=FALSE

  PROCEDURE [XREF] jmp$set_utility_active_flag
    (VAR access_id: ost$binary_unique_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SIGNAL_PAIR_CONNECT_TARGET EXPAND=FALSE

  PROCEDURE [XREF] jmp$signal_pair_connect_target
    (    system_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SUBMIT_DETACHED_JOB EXPAND=FALSE
  PROCEDURE [XREF] jmp$submit_detached_job
    (    user_information: STRING (* <= jmc$user_information_size);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc jmt$user_information
?? POP ??
*DECK DECK=JMP$SUBMIT_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$submit_job
    (    file_reference: fst$file_reference;
         job_submission_options: ^jmt$job_submission_options;
     VAR system_supplied_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$ring_validation_errors
*copyc cle$ecc_lexical
*copyc fst$file_reference
*copyc jme$invalid_parameter
*copyc jme$maximum_jobs
*copyc jme$must_be_system_job
*copyc jme$no_space_for_file
*copyc jmt$job_submission_options
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SUBMIT_QFILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$submit_qfile
    (    file_reference: fst$file_reference;
         application_name: ost$name;
         submission_options_p: ^jmt$qfile_submission_options;
     VAR system_file_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$ring_validation_errors
*copyc cle$ecc_lexical
*copyc fst$file_reference
*copyc jme$invalid_destination
*copyc jme$invalid_parameter
*copyc jme$invalid_rhd
*copyc jme$maximum_generic_qfiles
*copyc jme$sl_version_mismatch
*copyc jmt$qfile_submission_options
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SUBSYSTEM_PRIORITY_CHANGE EXPAND=FALSE

  PROCEDURE [XREF] jmp$subsystem_priority_change
    (    ijle_p: ^jmt$initiated_job_list_entry);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=JMP$SWAPIN_JOB EXPAND=FALSE

PROCEDURE [XREF] jmp$swapin_job
  (    job_name: clt$value;
   VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc OST$STATUS
?? POP ??
*DECK DECK=JMP$SWAPIN_JOB_SIGNAL_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] jmp$swapin_job_signal_handler (originator:
    ost$global_task_id;
        signal: pmt$signal);
?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc PMT$SIGNAL
?? POP ??
*DECK DECK=JMP$SWAPOUT_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$swapout_job
    (    job_name: ost$name;
         disable_recovery: boolean;
     VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SWAP_JOBS_FOR_LOWER_MAXAJ EXPAND=FALSE

  PROCEDURE [XREF] jmp$swap_jobs_for_lower_maxaj;

*DECK DECK=JMP$SWAP_JOB_FOR_MEMORY_RESERVE EXPAND=FALSE

  PROCEDURE [XREF] jmp$swap_job_for_memory_reserve;

*DECK DECK=JMP$SWAP_NON_DISPATCHABLE_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$swap_non_dispatchable_job
    (    ajl_ordinal: jmt$ajl_ordinal);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ajl_ordinal
?? POP ??
*DECK DECK=JMP$SWAP_SIGNAL_HANDLER EXPAND=FALSE
PROCEDURE [XREF] jmp$swap_signal_handler(recipient: ost$global_task_id,
                         signal: pmt$signal);
?? PUSH(LIST := OFF) ??
*copyc PMT$SIGNAL
*copyc OST$GLOBAL_TASK_ID
?? POP ??
*DECK DECK=JMP$SWITCH_COMMAND_R3 EXPAND=FALSE

  PROCEDURE [XREF] jmp$switch_command_r3 (
        name: string ( * <= osc$max_name_size);
        on: pmt$sense_switches;
        off: pmt$sense_switches;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$sense_switches
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$SYSTEM_ERROR EXPAND=FALSE

  PROCEDURE [XREF] jmp$system_error (error_message: string ( * );
    status: ^ost$status);

?? PUSH ( LIST := OFF {LISTEXT:=ON} ) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=JMP$SYSTEM_JOB EXPAND=FALSE

  FUNCTION [XREF] jmp$system_job: boolean;

*DECK DECK=JMP$TERMINATED_INPUT_EXISTS EXPAND=FALSE

  FUNCTION [XREF] jmp$terminated_input_exists
    (    job_destination_usage: jmt$destination_usage): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
?? POP ??
*DECK DECK=JMP$TERMINATED_OUTPUT_EXISTS EXPAND=FALSE

  FUNCTION [XREF] jmp$terminated_output_exists
    (    output_destination_usage: jmt$destination_usage): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
?? POP ??
*DECK DECK=JMP$TERMINATED_QFILE_EXISTS EXPAND=FALSE

  FUNCTION [XREF] jmp$terminated_qfile_exists
    (    application_name: ost$name): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=JMP$TERMINATE_ACQUIRED_INPUT EXPAND=FALSE

  PROCEDURE [XREF] jmp$terminate_acquired_input
    (    job_destination_usage: jmt$destination_usage;
     VAR system_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$destination_usage
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$TERMINATE_ACQUIRED_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] jmp$terminate_acquired_output
    (    output_destiantion_usage: jmt$destination_usage;
     VAR system_file_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$destination_usage
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$TERMINATE_ACQUIRED_QFILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$terminate_acquired_qfile
    (    application_name: ost$name;
     VAR system_file_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$generic_queue_is_empty
*copyc jme$qfile_appl_not_permitted
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$TERMINATE_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$terminate_job
    (   job_name: jmt$name;
        job_termination_options: ^jmt$job_termination_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$name
*copyc jmt$job_termination_options
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=JMP$TERMINATE_JOB_FLAG_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] jmp$terminate_job_flag_handler
    (    flag_id: ost$system_flag);

?? PUSH (LISTEXT := ON) ??
*copyc ost$system_flag
?? POP ??

*DECK DECK=JMP$TERMINATE_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] jmp$terminate_output
    (    output_name: jmt$name;
         output_termination_options: ^jmt$output_termination_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$name
*copyc jmt$output_termination_options
*copyc ost$status
?? POP ??

*DECK DECK=JMP$TERMINATE_QFILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$terminate_qfile
    (    system_file_name: jmt$system_supplied_name;
         termination_options_p: ^jmt$qfile_termination_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$invalid_parameter
*copyc jme$name_not_found
*copyc jme$qfile_already_terminated
*copyc jme$qfile_state_is_null
*copyc jmt$qfile_termination_options
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$TERMINATE_SIGNAL_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] jmp$terminate_signal_handler (originator: ost$global_task_id;
        signal: pmt$signal);

?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc PMT$SIGNAL
?? POP ??
*DECK DECK=JMP$TEST_FOR_SYSTEM_IDLE EXPAND=FALSE

  PROCEDURE [XREF] jmp$test_for_system_idle (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$TEST_FOR_SYSTEM_IDLE_R1 EXPAND=FALSE

  PROCEDURE [XREF] jmp$test_for_system_idle_r1 (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$TIMESHARING EXPAND=FALSE
FUNCTION [XREF] jmp$timesharing: boolean;
*DECK DECK=JMP$TIMESHARING_SIGNAL_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] jmp$timesharing_signal_handler (
        originator: ost$global_task_id;
        signal: pmt$signal);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc pmt$signal
?? POP ??
*DECK DECK=JMP$TRAP_HANDLER EXPAND=FALSE
  PROCEDURE [XREF] jmp$trap_handler;

*DECK DECK=JMP$TS_IO_REQUEST_VALID EXPAND=FALSE

  FUNCTION [INLINE] jmp$ts_io_request_valid: boolean;

?? PUSH (LISTEXT := ON) ??

    jmp$ts_io_request_valid := (pmp$ts_task_io_enabled () AND (NOT jmv$ts_job_disconnected))
           AND (NOT jmv$terminal_io_disabled);
  FUNCEND jmp$ts_io_request_valid;

*copyc jmv$ts_job_disconnected
*copyc jmv$terminal_io_disabled
*copyc pmp$ts_task_io_enabled
?? POP ??
*DECK DECK=JMP$UNASSIGN_SERVER_JOBS EXPAND=FALSE

  PROCEDURE [XREF] jmp$unassign_server_jobs
    (    server_mainframe_id: pmt$binary_mainframe_id;
         unassign_all_jobs: boolean;
         job_class_priorities: jmt$jl_job_class_priorities;
         unassigned_job_list { output } : ^jmt$jl_unassigned_job_list;
     VAR number_of_unassigned_jobs: jmt$job_count_range);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$jl_job_class_priorities
*copyc jmt$jl_unassigned_job_list
*copyc jmt$job_count_range
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=JMP$UNLOCK_AJL EXPAND=FALSE

  PROCEDURE [INLINE] jmp$unlock_ajl
    (    ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      ajlo: jmt$ajl_ordinal;

    tmp$set_lock (tmv$ptl_lock);
    ajlo := ijle_p^.ajl_ordinal;
    IF (jmv$ajl_p^ [ajlo].in_use = jmc$lock_ajl) THEN
      jmp$free_ajl_with_lock (ijle_p, jmc$lock_ajl);
    ELSE
      jmv$ajl_p^ [ajlo].in_use := jmv$ajl_p^ [ajlo].in_use - jmc$lock_ajl;
    IFEND;
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND jmp$unlock_ajl;

?? PUSH (LISTEXT := ON) ??
*copyc jmc$ajl_caller

*copyc jmp$free_ajl_with_lock
*copyc tmp$clear_lock
*copyc tmp$set_lock

*copyc jmv$ajl_p
*copyc tmv$ptl_lock
?? POP ??
*DECK DECK=JMP$UNLOCK_AJL_WITH_LOCK EXPAND=FALSE

  PROCEDURE [INLINE] jmp$unlock_ajl_with_lock
    (    ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      ajlo: jmt$ajl_ordinal;

    ajlo := ijle_p^.ajl_ordinal;
    IF (jmv$ajl_p^ [ajlo].in_use = jmc$lock_ajl) THEN
      jmp$free_ajl_with_lock (ijle_p, jmc$lock_ajl);
    ELSE
      jmv$ajl_p^ [ajlo].in_use := jmv$ajl_p^ [ajlo].in_use - jmc$lock_ajl;
    IFEND;

  PROCEND jmp$unlock_ajl_with_lock;

?? PUSH (LISTEXT := ON) ??
*copyc jmc$ajl_caller

*copyc jmp$free_ajl_with_lock
?? POP ??
*DECK DECK=JMP$UPDATE_DISPLAY_MESSAGE EXPAND=FALSE
  PROCEDURE [XREF] jmp$update_display_message
    (    message_status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMP$UPDATE_JOB_TEMPLATE_SDT EXPAND=FALSE

  PROCEDURE [XREF] jmp$update_job_template_sdt(pva: ^cell;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=JMP$UPDATE_LAST_USED_SSN EXPAND=FALSE

  PROCEDURE [XREF] jmp$update_last_used_ssn
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=JMP$UPDATE_OBJECT_STATISTICS EXPAND=FALSE

  PROCEDURE [XREF] jmp$update_object_statistics
    (    the_object: jmt$profile_object;
     VAR attributes: jmt$object_attribute;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$object_attribute
*copyc jmt$profile_object
?? POP ??
*DECK DECK=JMP$UPDATE_OUTPUT_STATUS EXPAND=FALSE

  PROCEDURE [XREF] jmp$update_output_status
    (    system_file_name: jmt$system_supplied_name;
         output_destination_usage: jmt$destination_usage;
         queue_file_password: jmt$queue_file_password;
         output_status_updates: ^jmt$output_status_updates;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$destination_usage
*copyc jmt$queue_file_password
*copyc jmt$system_supplied_name
*copyc jmt$output_status_updates
*copyc ost$status
?? POP ??
*DECK DECK=JMP$UPDATE_PROFILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$update_profile
    (    access_id: ost$binary_unique_name;
         changed_job_classes_p: ^jmt$job_class_table;
         changed_service_classes_p: ^jmt$service_class_table;
         changed_applications_p: ^jmt$application_table;
         controls_p: ^jmt$job_scheduler_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$application_table
*copyc jmt$job_class_table
*copyc jmt$job_scheduler_table
*copyc jmt$service_class_table
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$UPDATE_PROFILE_IN_TABLES EXPAND=FALSE

  PROCEDURE [XREF] jmp$update_profile_in_tables
    (    access_id: ost$binary_unique_name;
         changed_job_classes_p: ^jmt$job_class_table;
         changed_service_classes_p: ^jmt$service_class_table;
         changed_applications_p: ^jmt$application_table;
         controls_p: ^jmt$job_scheduler_table;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$application_table
*copyc jmt$job_class_table
*copyc jmt$job_scheduler_table
*copyc jmt$service_class_table
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$UPDATE_QFILE_STATUS EXPAND=FALSE

  PROCEDURE [XREF] jmp$update_qfile_status
    (    system_file_name: jmt$system_supplied_name;
         application_name: ost$name;
         qfile_password: jmt$queue_file_password;
         qfile_status_updates_p: ^jmt$qfile_status_updates;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$application_name_incorrect
*copyc jme$invalid_parameter
*copyc jme$name_not_found
*copyc jme$qfile_appl_not_permitted
*copyc jmt$qfile_status_updates
*copyc jmt$queue_file_password
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$UPDATE_SERVER_PRIORITIES EXPAND=FALSE

  PROCEDURE [XREF] jmp$update_server_priorities
    (    highest_server_priorities: jmt$jl_server_job_priorities);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$jl_server_job_priorities
?? POP ??
*DECK DECK=JMP$UPDATE_SERVICE_CLASS_STATS EXPAND=FALSE

  PROCEDURE [XREF] jmp$update_service_class_stats
    (    ijle_p: ^jmt$initiated_job_list_entry);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=JMP$UPDATE_SSN_SEQUENCE EXPAND=FALSE

  PROCEDURE [XREF] jmp$update_ssn_sequence
    (    system_supplied_name: jmt$system_supplied_name);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
?? POP ??
*DECK DECK=JMP$UPDATE_SYSTEM_PROFILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$update_system_profile
    (    access_id: ost$binary_unique_name;
         prevent_update_of_profile_file: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$activate_profile_errors
*copyc ost$status
?? POP ??
*DECK DECK=JMP$UTIL_GET_QFILE_ATTRIBUTES EXPAND=FALSE
  PROCEDURE [XREF] jmp$util_get_qfile_attributes
    (    attribute_options_p: ^jmt$qfile_attribute_options;
         attribute_results_keys_p: ^jmt$results_keys;
     VAR attribute_work_area_p: ^SEQ ( * );
     VAR attribute_results_p: ^jmt$qfile_attribute_results;
     VAR number_of_qfiles_found: jmt$qfile_status_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc jme$duplicate_attribute_key
*copyc jme$invalid_parameter
*copyc jme$no_qfiles_were_found
*copyc jme$work_area_too_small
*copyc jmt$qfile_attribute_options
*copyc jmt$qfile_attribute_results
*copyc jmt$qfile_status_count
*copyc jmt$results_keys
*copyc ofe$error_codes
*copyc ost$status
?? POP ??
*DECK DECK=JMP$UTIL_TERMINATE_QFILE EXPAND=FALSE
  PROCEDURE [XREF] jmp$util_terminate_qfile
    (    system_file_name: jmt$system_supplied_name;
         termination_options_p: ^jmt$qfile_termination_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$invalid_parameter
*copyc jme$name_not_found
*copyc jme$qfile_already_terminated
*copyc jme$qfile_state_is_null
*copyc jmt$qfile_termination_options
*copyc jmt$system_supplied_name
*copyc ofe$error_codes
*copyc ost$status
?? POP ??
*DECK DECK=JMP$VALIDATE_ATTRIBUTE_OPTIONS EXPAND=FALSE

  PROCEDURE [XREF] jmp$validate_attribute_options
    (    request_name: string ( * );
         parameter_name: string ( * );
         options_seq_p: ^SEQ ( * );
         number_of_options_to_add: ost$non_negative_integers;
     VAR continue_request_to_servers: boolean;
     VAR number_of_valid_options: ost$non_negative_integers;
     VAR target_options_seq_p: ^jmt$work_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc jme$duplicate_attribute_key
*copyc jme$invalid_parameter
*copyc jmt$attribute_values
*copyc jmt$work_area
*copyc osd$integer_limits
*copyc ost$status
?? POP ??
*DECK DECK=JMP$VALIDATE_NAME EXPAND=FALSE

    PROCEDURE [XREF] jmp$validate_name (
          candidate_name: jmt$name;
      VAR name: jmt$name;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$VALIDATE_PAIRED_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] jmp$validate_paired_connection
    (    unvalidated_connection_data_p: ^SEQ ( * );
     VAR login_family: ost$name;
     VAR login_user: ost$name;
     VAR system_job_name: jmt$system_supplied_name;
     VAR connection_request_kind: jmt$paired_connection_request;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$invalid_paired_connection
*copyc jmt$system_supplied_name
*copyc jmt$paired_connection_data
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$VALIDATE_STATUS_OPTIONS EXPAND=FALSE

  PROCEDURE [XREF] jmp$validate_status_options
    (    request_name: string ( * );
         parameter_name: string ( * );
         options_seq_p: ^SEQ ( * );
         caller_privileged: boolean;
     VAR privileged_job: boolean;
     VAR user_identification: ost$user_identification;
     VAR continue_request_to_servers: boolean;
     VAR valid_option_count: ost$non_negative_integers;
     VAR target_options_seq_p: ^jmt$work_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc jme$duplicate_attribute_key
*copyc jme$invalid_parameter
*copyc jmt$attribute_values
*copyc jmt$work_area
*copyc osd$integer_limits
*copyc ost$name
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=JMP$VALIDATE_USER EXPAND=FALSE
  PROCEDURE [XREF] jmp$validate_user
    (    login_family: ost$name;
         login_user: ost$name;
         user_validation_options_p: ^jmt$user_validation_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ave$validation_interface_errors
*copyc cle$ecc_lexical
*copyc jme$invalid_parameter
*copyc jmt$user_validation_options
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$VERIFY_INACTIVE_SERVER EXPAND=FALSE

  PROCEDURE [XREF] jmp$verify_inactive_server
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR server_inactive: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=JMP$VERIFY_INVITATION_CANDIDATE EXPAND=FALSE
FUNCTION [XREF]  verify_initiation_candidate (class: jmt$job_class): BOOLEAN;

*DECK DECK=JMP$VERIFY_JOB_LEVELER EXPAND=FALSE

  PROCEDURE [XREF] jmp$verify_job_leveler;
*DECK DECK=JMP$VERIFY_UTILITY_ACCESS_ID EXPAND=FALSE

  PROCEDURE [XREF] jmp$verify_utility_access_id
    (    access_id: ost$binary_unique_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$WRITE_PROFILE EXPAND=FALSE

  PROCEDURE [XREF] jmp$write_profile
    (    base_file: fst$file_reference;
     VAR the_profile: jmt$profile_data;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jmt$profile_data
*copyc ost$status
?? POP ??

*DECK DECK=JMP$WRITE_RECOVERY_INFO_TO_DISK EXPAND=FALSE

  PROCEDURE [XREF] jmp$write_recovery_info_to_disk;

*DECK DECK=JMP$WRITE_SYSTEM_PROFILE EXPAND=FALSE
  PROCEDURE [XREF] jmp$write_system_profile
    (    profile_access_id: ost$binary_unique_name;
     VAR the_profile: jmt$profile_data;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$profile_data
*copyc ost$binary_unique_name
*copyc ost$status
?? POP ??
*DECK DECK=JMP$_JOB EXPAND=FALSE

  PROCEDURE [XREF] jmp$_job
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=JMT$ACTIVE_JOB_LIST EXPAND=FALSE
{AJL - This deck defines the AJL. An entry in the AJL exists for each job
{that is in memory, in the process of being swapped in, or is swapped out
{but is being accessed temporarily by the system.  The AJL
{is also used to control the mapping of job fixed segments in the
{address space of monitor.

{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{
  TYPE
    jmt$active_job_list_entry = RECORD
      in_use: ALIGNED [0 MOD 8] 0 .. 0ffffff(16),
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      job_is_good_swap_candidate: boolean,
      time_freed: ost$free_running_clock,
    RECEND,

    jmt$active_job_list = ARRAY [0 .. *] of jmt$active_job_list_entry;

*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc ost$hardware_subranges
*DECK DECK=JMT$ACTIVE_JOB_QUEUE EXPAND=FALSE

  CONST
    jmc$null_active_job_queue_link = 0;

  TYPE
    jmt$active_job_queue_range = 0..jmc$max_active_jobs,

    jmt$active_job_queue_element = RECORD
          link: jmt$active_job_queue_range,
          node: jmt$node,
    RECEND,

    jmt$active_job_queue = ARRAY [*] of jmt$active_job_queue_element,

    jmt$active_job_queue_header = ARRAY [jmt$service_class_index] of jmt$active_job_queue_range;

*copyc jmc$maximum_constants
*copyc jmt$node
*copyc jmt$service_class_index
*DECK DECK=JMT$AGING_INTERVAL EXPAND=FALSE

{ The aging interval has a unit of microseconds.

  TYPE
    jmt$aging_interval = ost$aging_interval;

{ The following constants define the range of values permitted on SCL
{ parameter definitions and the internal representation for the keyword,
{ UNSPECIFIED.

  CONST
    jmc$lowest_aging_interval = 1000,
*IF $true(osv$unix)
    jmc$highest_aging_interval = 7ffffffe(16),
    jmc$unspecified_aging_interval = 7fffffff(16);
*ELSE
    jmc$highest_aging_interval = 3600000000,
    jmc$unspecified_aging_interval = jmc$highest_aging_interval +
          jmc$unspecified_offset;
*IFEND

*copyc jmc$attribute_keyword_offsets
*copyc ost$aging_interval
*DECK DECK=JMT$AIO_LIMIT EXPAND=FALSE

  TYPE
    jmt$aio_limit = 0 .. 5000000;

{ The following constants define the range of values permitted on SCL
{ parameter definitions on the scheduling commands.

  CONST
    jmc$lowest_aio_limit = 0,
    jmc$highest_aio_limit = 5000000;
*DECK DECK=JMT$AJL_ORDINAL EXPAND=FALSE

{ * * * * * common deck JMDAJLO: Active Job List Ordinal * * * * * }

TYPE
  jmt$ajl_ordinal = 0 .. jmc$max_ajl_ord;

{ * * * * * end of deck jmdajlo. . . . . . . . . . . . . * * * * * }

*copyc JMC$MAXIMUM_CONSTANTS
*DECK DECK=JMT$AJL_STATUS EXPAND=FALSE
{! * * * deck deleted by SUPER_SWAP_1 - change references to JMT$ACTIVE_JOB_LIST}
*copyc jmt$active_job_list
*DECK DECK=JMT$APPLICATION_ATTRIBUTES EXPAND=FALSE

  TYPE
    jmt$application_attributes = record

{ Define the Definition group attributes.

      defined: boolean,
      profile_identification: ost$name,
      name: jmt$application_name,
      enable_application_scheduling: boolean,

{ Define the Control group attributes.

      cyclic_aging_interval: jmt$aging_interval, { microseconds
      maximum_working_set: jmt$working_set_size, { pages
      minimum_working_set: jmt$working_set_size, { pages
      page_aging_interval: jmt$aging_interval, { microseconds
      service_class_index: jmt$service_class_index,
    recend;

*copyc jmt$aging_interval
*copyc jmt$application_name
*copyc jmt$service_class_index
*copyc jmt$working_set_size
*copyc ost$name
*DECK DECK=JMT$APPLICATION_INDEX EXPAND=FALSE

  TYPE
    jmt$application_index = 0 .. jmc$maximum_application_index;

  CONST
    jmc$maximum_application_index = 255;

*DECK DECK=JMT$APPLICATION_NAME EXPAND=FALSE

  TYPE
    jmt$application_name = ost$name;

*copyc ost$name
*DECK DECK=JMT$APPLICATION_SET EXPAND=FALSE

  TYPE
    jmt$application_set = set of jmt$application_index;

*copyc jmt$application_index
*DECK DECK=JMT$APPLICATION_TABLE EXPAND=FALSE

  TYPE
    jmt$application_table = array [1 .. * ] of jmt$application_attributes;

*copyc jmt$application_attributes
*DECK DECK=JMT$ATTRIBUTE_KEYS EXPAND=FALSE

  TYPE
    jmt$attribute_keys = 0 .. jmc$maximum_attribute_index;

  CONST
    jmc$maximum_attribute_index = 1000;

  CONST
    jmc$unknown_attribute = 0,
    jmc$application_attributes_1 = 3,
    jmc$application_attributes_2 = 4,
    jmc$application_attributes_3 = 5,
    jmc$application_attributes_4 = 6,
    jmc$application_attributes_5 = 7,
    jmc$application_attributes_6 = 8,
    jmc$application_attributes_7 = 9,
    jmc$application_attributes_8 = 10,
    jmc$application_attributes_9 = 11,
    jmc$application_attributes_10 = 12,
    jmc$application_name = 15,
    jmc$c170_os_type = 20,
    jmc$client_mainframe_id = 25,
    jmc$comment_banner = 30,
    jmc$continue_request_to_servers = 35,
    jmc$control_family = 40,
    jmc$control_user = 50,
    jmc$copies = 60,
    jmc$copies_printed = 70,
    jmc$cpu_time_limit = 80,
    jmc$cpu_time_used = 90,
    jmc$cyclic_aging_interval = 100,
    jmc$data_declaration = 110,
    jmc$data_mode = 120,
    jmc$default_login_account = 130,
    jmc$default_login_family = 140,
    jmc$default_login_password = 150,
    jmc$default_login_project = 160,
    jmc$default_login_user = 170,
    jmc$deferred_by_application = 175,
    jmc$destination = 177,
    jmc$detached_job_wait_time = 180,
    jmc$device = 190,
    jmc$device_type = 200,
    jmc$dispatching_priority = 210,
    jmc$display_message = 220,
    jmc$disposition_code = 225,
    jmc$earliest_print_time = 230,
    jmc$earliest_run_time = 240,
    jmc$encrypted_password = 245,
    jmc$external_characteristics = 250,
    jmc$file_position = 260,
    jmc$file_size = 270,
    jmc$forms_code = 280,
    jmc$immediate_init_candidate = 290,
    jmc$implicit_routing_text = 300,
    jmc$include_the_system_job = 305,
    jmc$inherit_job_attributes = 306,
    jmc$input_file_location = 308,
    jmc$internal_index = 310, { kjl or kol index
    jmc$job_abort_disposition = 315,
    jmc$job_category_list = 318,
    jmc$job_class = 320,
    jmc$job_class_list = 330,
    jmc$job_class_position = 331,
    jmc$job_deferred_by_operator = 334,
    jmc$job_deferred_by_user = 335,
    jmc$job_destination_family = 340, { job_destination
    jmc$job_destination_usage = 350,
    jmc$job_execution_ring = 360,
    jmc$job_initiation_time = 365,
    jmc$job_input_device = 370,
    jmc$job_mode = 380,
    jmc$job_mode_set = 390,
    jmc$job_priority = 400,
    jmc$job_qualifier_list = 410,
    jmc$job_recovery_disposition = 415,
    jmc$job_size = 420,
    jmc$job_state = 430,
    jmc$job_state_set = 440,
    jmc$job_submission_time = 450,
    jmc$latest_print_time = 460,
    jmc$latest_run_time = 470,
    jmc$login_account = 480,
    jmc$login_command = 490,
    jmc$login_command_supplied = 500,
    jmc$login_family = 510,
    jmc$login_password = 520,
    jmc$login_project = 530,
    jmc$login_user = 540,
    jmc$magnetic_tape_limit = 550,
    jmc$maximum_working_set = 560,
    jmc$minimum_working_set = 570,
    jmc$name_list = 580,

{ The key jmc$notify_on_terminate is used when an application
{ registers with the generic queue file manager to indicate whether or not the
{ application should be notified when a file has been terminated even
{ though its attributes cannot be changed.

    jmc$notify_on_terminate = 585,
    jmc$null_attribute = 590,
    jmc$omit_class_validation = 600,
    jmc$omit_user_prolog_and_epilog = 610,
    jmc$operator_action_posted = 620,
    jmc$operator_job = 630,
    jmc$optional_user_capability = 640,
    jmc$origin_application_name = 650,
    jmc$os_version = 660,
    jmc$output_class = 670,
    jmc$output_deferred_by_operator = 673,
    jmc$output_deferred_by_user = 674,
    jmc$output_destination = 677,
    jmc$output_destination_family = 680, { operator_family
    jmc$output_destination_usage = 690,
    jmc$output_disposition = 700,
    jmc$output_priority = 710,
    jmc$output_state = 720,
    jmc$output_state_set = 730,
    jmc$output_submission_time = 740,
    jmc$page_aging_interval = 750,
    jmc$page_faults = 760,
    jmc$privilege = 765,
    jmc$processing_phase = 770,
    jmc$purge_delay = 780,
    jmc$qfile_state = 782,
    jmc$qfile_state_set = 783,
    jmc$recovery_disposition = 785,
    jmc$remote_host_directive = 790,
    jmc$reprint_disposition = 795,
    jmc$required_user_capability = 800,
    jmc$rerun_disposition = 805,
    jmc$routing_banner = 810,
    jmc$sense_switches = 820,
    jmc$server_mainframe_id = 825,
    jmc$service_class = 830,
    jmc$site_information = 840,
    jmc$source_logical_id = 850,
    jmc$sru_limit = 860,
    jmc$station = 880,
    jmc$station_operator = 890, { operator_user
    jmc$system_job = 900,
    jmc$system_job_parameters = 910,
    jmc$system_file_name = 920,
    jmc$system_job_name = 930,
    jmc$system_routing_text = 940,
    jmc$system_supplied_name_list = 942,
    jmc$terminate_job_action_set = 945,
    jmc$termination_reason = 947,
    jmc$user_file_name = 950,
    jmc$user_identification = 955,
    jmc$user_information = 960,
    jmc$user_job_name = 970,
    jmc$validation_ring = 975,
    jmc$vertical_print_density = 980,
    jmc$vfu_load_procedure = 990;

*DECK DECK=JMT$ATTRIBUTE_KEYS_SET EXPAND=FALSE

  TYPE
    jmt$attribute_keys_set = set of jmt$attribute_keys;

*copyc jmt$attribute_keys
*DECK DECK=JMT$ATTRIBUTE_VALUES EXPAND=FALSE

  TYPE
    jmt$attribute_values = array [1 .. * ] of jmt$attribute_value;

  TYPE
    jmt$attribute_value = record
      case key: jmt$attribute_keys of
      = jmc$application_name =
        application_name: ost$name,
      = jmc$c170_os_type =
        c170_os_type: ost$170_os_type,
      = jmc$client_mainframe_id =
        client_mainframe_id: pmt$mainframe_id,
      = jmc$comment_banner =
        comment_banner: jmt$output_comment_banner,
      = jmc$continue_request_to_servers =
        continue_request_to_servers: boolean,
      = jmc$control_family =
        control_family: ost$name,
      = jmc$control_user =
        control_user: ost$name,
      = jmc$copies =
        copies: jmt$output_copy_count,
      = jmc$copies_printed =
        copies_printed: jmt$output_copy_count,
      = jmc$cpu_time_limit =
        cpu_time_limit: jmt$cpu_time_limit,
      = jmc$cpu_time_used =
        cpu_time_used: jmt$cpu_time_used,
      = jmc$cyclic_aging_interval =
        cyclic_aging_interval: jmt$aging_interval,
      = jmc$data_declaration =
        data_declaration: jmt$data_declaration,
      = jmc$data_mode =
        data_mode: jmt$data_mode,
      = jmc$deferred_by_application =
        deferred_by_application: boolean,
      = jmc$destination =
        destination: ost$name,
      = jmc$detached_job_wait_time =
        detached_job_wait_time: jmt$detached_job_wait_time,
      = jmc$device =
        device: jmt$output_device,
      = jmc$device_type =
        device_type: jmt$output_device_type,
      = jmc$dispatching_priority =
        dispatching_priority: ost$name,
      = jmc$display_message =
        display_message: ^jmt$display_message,
      = jmc$earliest_print_time =
        earliest_print_time: jmt$date_time,
      = jmc$earliest_run_time =
        earliest_run_time: jmt$date_time,
      = jmc$external_characteristics =
        external_characteristics: jmt$external_characteristics,
      = jmc$file_position =
        file_position: jmt$output_file_position,
      = jmc$file_size =
        file_size: jmt$output_file_size,
      = jmc$forms_code =
        forms_code: jmt$forms_code,
      = jmc$include_the_system_job =
        include_the_system_job: boolean,
      = jmc$input_file_location =
        input_file_location: jmt$input_file_location,
      = jmc$internal_index =
        internal_index: integer,
      = jmc$job_abort_disposition =
        job_abort_disposition: jmt$job_abort_disposition,
      = jmc$job_category_list =
        job_category_list: jmt$job_category_list,
      = jmc$job_class =
        job_class: jmt$job_class_name,
      = jmc$job_class_position =
        job_class_position: jmt$job_count_range,
      = jmc$job_deferred_by_operator =
        job_deferred_by_operator: boolean,
      = jmc$job_deferred_by_user =
        job_deferred_by_user: boolean,
      = jmc$job_destination_family = { job_destination
        job_destination_family: ost$name,
      = jmc$job_destination_usage =
        job_destination_usage: jmt$destination_usage,
      = jmc$job_execution_ring =
        job_execution_ring: ost$ring,
      = jmc$job_initiation_time =
        job_initiation_time: jmt$date_time,
      = jmc$job_mode =
        job_mode: jmt$job_mode,
      = jmc$job_mode_set =
        job_mode_set: jmt$job_mode_set,
      = jmc$job_priority =
        job_priority: jmt$job_priority_name,
      = jmc$job_qualifier_list =
        job_qualifier_list: ^jmt$job_qualifier_list,
      = jmc$job_recovery_disposition =
        job_recovery_disposition: jmt$job_recovery_disposition,
      = jmc$job_size =
        job_size: jmt$job_size,
      = jmc$job_state =
        job_state: jmt$job_state,
      = jmc$job_state_set =
        job_state_set: jmt$job_state_set,
      = jmc$job_submission_time =
        job_submission_time: ost$date_time,
      = jmc$latest_print_time =
        latest_print_time: jmt$date_time,
      = jmc$latest_run_time =
        latest_run_time: jmt$date_time,
      = jmc$login_account =
        login_account: avt$account_name,
      = jmc$login_family =
        login_family: ost$name,
      = jmc$login_project =
        login_project: avt$project_name,
      = jmc$login_user =
        login_user: ost$name,
      = jmc$magnetic_tape_limit =
        magnetic_tape_limit: jmt$magnetic_tape_limit,
      = jmc$maximum_working_set =
        maximum_working_set: jmt$working_set_size,
      = jmc$minimum_working_set =
        minimum_working_set: jmt$working_set_size,
      = jmc$name_list =
        name_list: ^jmt$name_list,
      = jmc$null_attribute =
        ,
      = jmc$operator_action_posted =
        operator_action_posted: boolean,
      = jmc$operator_job =
        operator_job: boolean,
      = jmc$origin_application_name =
        origin_application_name: ost$name,
      = jmc$os_version =
        os_version: pmt$os_name,
      = jmc$output_class =
        output_class: jmt$output_class_name,
      = jmc$output_deferred_by_operator =
        output_deferred_by_operator: boolean,
      = jmc$output_deferred_by_user =
        output_deferred_by_user: boolean,
      = jmc$output_destination =
        output_destination: ost$name,
      = jmc$output_destination_family = { operator_family
        output_destination_family: ost$name,
      = jmc$output_destination_usage =
        output_destination_usage: jmt$destination_usage,
      = jmc$output_priority =
        output_priority: jmt$output_priority,
      = jmc$output_state =
        output_state: jmt$output_state,
      = jmc$output_state_set =
        output_state_set: jmt$output_state_set,
      = jmc$output_submission_time =
        output_submission_time: ost$date_time,
      = jmc$page_aging_interval =
        page_aging_interval: jmt$aging_interval,
      = jmc$page_faults =
        page_faults: jmt$page_faults,
      = jmc$privilege =
        privilege: jmt$privilege,
      = jmc$processing_phase =
        processing_phase: jmt$job_processing_phase,
      = jmc$purge_delay =
        purge_delay: ^jmt$time_increment,
      = jmc$qfile_state =
        qfile_state: jmt$qfile_state,
      = jmc$remote_host_directive =
        remote_host_directive: ^jmt$remote_host_directive,
      = jmc$routing_banner =
        routing_banner: jmt$output_routing_banner,
      = jmc$sense_switches =
        sense_switches: pmt$sense_switches,
      = jmc$server_mainframe_id =
        server_mainframe_id: pmt$mainframe_id,
      = jmc$service_class =
        service_class: jmt$service_class_name,
      = jmc$site_information =
        site_information: ^jmt$site_information,
      = jmc$source_logical_id =
        source_logical_id: jmt$source_logical_id,
      = jmc$sru_limit =
        sru_limit: jmt$sru_limit,
      = jmc$output_disposition =
        output_disposition: jmt$output_disposition,
      = jmc$station =
        station: jmt$station,
      = jmc$station_operator = { operator_user
        station_operator: jmt$station_operator,
      = jmc$system_file_name =
        system_file_name: jmt$system_supplied_name,
      = jmc$system_job =
        system_job: boolean,
      = jmc$system_job_name =
        system_job_name: jmt$system_supplied_name,
      = jmc$terminate_job_action_set =
        terminate_job_action_set: jmt$terminate_job_action_set,
      = jmc$user_file_name =
        user_file_name: jmt$user_supplied_name,
      = jmc$user_identification =
        user_identification: ^ost$user_identification,
      = jmc$user_information =
        user_information: ^jmt$user_information,
      = jmc$user_job_name =
        user_job_name: jmt$user_supplied_name,
      = jmc$vertical_print_density =
        vertical_print_density: jmt$vertical_print_density,
      = jmc$vfu_load_procedure =
        vfu_load_procedure: jmt$vfu_load_procedure,
      casend,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc jmt$aging_interval
*copyc jmt$attribute_keys
*copyc jmt$cpu_time_limit
*copyc jmt$cpu_time_used
*copyc jmt$data_declaration
*copyc jmt$data_mode
*copyc jmt$date_time
*copyc jmt$destination_usage
*copyc jmt$detached_job_wait_time
*copyc jmt$display_message
*copyc jmt$forms_code
*copyc jmt$external_characteristics
*copyc jmt$input_file_location
*copyc jmt$job_abort_disposition
*copyc jmt$job_category_list
*copyc jmt$job_class_name
*copyc jmt$job_count_range
*copyc jmt$job_mode
*copyc jmt$job_mode_set
*copyc jmt$job_priority_name
*copyc jmt$job_processing_phase
*copyc jmt$job_qualifier_list
*copyc jmt$job_recovery_disposition
*copyc jmt$job_size
*copyc jmt$job_state
*copyc jmt$job_state_set
*copyc jmt$magnetic_tape_limit
*copyc jmt$name_list
*copyc jmt$output_class_name
*copyc jmt$output_comment_banner
*copyc jmt$output_copy_count
*copyc jmt$output_device
*copyc jmt$output_device_type
*copyc jmt$output_disposition
*copyc jmt$output_file_position
*copyc jmt$output_file_size
*copyc jmt$output_priority
*copyc jmt$output_routing_banner
*copyc jmt$output_state
*copyc jmt$output_state_set
*copyc jmt$page_faults
*copyc jmt$privilege
*copyc jmt$qfile_state
*copyc jmt$remote_host_directive
*copyc jmt$service_class_name
*copyc jmt$site_information
*copyc jmt$source_logical_id
*copyc jmt$sru_limit
*copyc jmt$station
*copyc jmt$station_operator
*copyc jmt$system_supplied_name
*copyc jmt$terminate_job_action
*copyc jmt$time_increment
*copyc jmt$user_information
*copyc jmt$user_supplied_name
*copyc jmt$vertical_print_density
*copyc jmt$vfu_load_procedure
*copyc jmt$working_set_size
*copyc osd$virtual_address
*copyc ost$170_os_type
*copyc ost$date_time
*copyc ost$name
*copyc ost$user_identification
*copyc pmt$mainframe_id
*copyc pmt$os_name
*copyc pmt$sense_switches
*DECK DECK=JMT$BEGINNING_LOG_POSITION EXPAND=FALSE

TYPE
  jmt$beginning_log_position = (jmc$today, jmc$session, jmc$boi);
*DECK DECK=JMT$CANDIDATE_QUEUED_JOBS EXPAND=FALSE

  TYPE
    jmt$candidate_queued_jobs = array [jmt$job_class] of jmt$candidate_queued_job;

  TYPE
    jmt$candidate_queued_job = record
      candidate_available: boolean,
      job_submission_time: jmt$clock_time,
      self_terminating_job: boolean,
      kjl_index: jmt$kjl_index,
      system_supplied_name: jmt$system_supplied_name,
      user_supplied_name: jmt$user_supplied_name,
      initiated_job_list_ordinal: jmt$ijl_ordinal,
      job_monitor_global_task_id: ost$global_task_id,
    recend;

*copyc jmt$clock_time
*copyc jmt$job_class
*copyc jmt$kjl_index
*copyc jmt$ijl_ordinal
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc ost$global_task_id
*DECK DECK=JMT$CHANGE_DISPATCHING_LIST EXPAND=FALSE

  TYPE
    jmt$change_dispatching_list = record
      lock: ost$signature_lock,
      dispatching_control_changes_p: ^jmt$dispatching_control_changes,
    recend,

    jmt$dispatching_control_changes = record
      change_service_class: jmt$service_class_index,
      dispatching_control_info: jmt$dispatching_control,
      dispatching_control_changes_p: ^jmt$dispatching_control_changes,
    recend;

*copyc jmt$dispatching_control
*copyc jmt$service_class_index
*copyc ost$signature_lock

*DECK DECK=JMT$CHARACTER_CONVERSION EXPAND=FALSE

  TYPE
    jmt$character_conversion = (jmc$ascii, jmc$display_code_64);
*DECK DECK=JMT$CLASS_KIND EXPAND=FALSE

  TYPE
    jmt$class_kind = (jmc$job_class, jmc$service_class, jmc$output_class,
          jmc$application);

*DECK DECK=JMT$CLOCK_TIME EXPAND=FALSE

  TYPE
    jmt$clock_time = integer;

  CONST
    jmc$earliest_clock_time = 0,
    jmc$latest_clock_time = 0ffffffffffff(16);
*DECK DECK=JMT$COMM_ACCT_STATISTIC_DATA EXPAND=FALSE

  CONST
    jmc$ca_input_file = 1,
    jmc$ca_output_file = 2,
    jmc$ca_output_queue_residency = 3,
    jmc$ca_print_file = 4,
    jmc$ca_submit_job = 5,
    jmc$ca_standard_output_file = 6,
    jmc$ca_request_pf_transfer = 7,
    jmc$ca_target_pf_transfer = 8,
    jmc$ca_origin_qf_transfer = 9,
    jmc$ca_dest_qf_transfer = 10,
    jmc$ca_interactive_interval = 11,
    jmc$ca_ftp_client_ctrl_connect = 12,
    jmc$ca_ftp_client_data_connect = 13,
    jmc$ca_ftp_server_ctrl_connect = 14,
    jmc$ca_ftp_server_data_connect = 15,
    jmc$ca_last_statistic = jmc$ca_ftp_server_data_connect,
    jmc$ca_max_statistic = 0ff(16);

  TYPE
    jmt$ca_statistic_kind = 0 .. jmc$ca_max_statistic;

  TYPE
    jmt$comm_acct_statistic_data = record
      case statistic_id: jmt$ca_statistic_kind of
      = jmc$ca_input_file =
        input_file: ^jmt$input_file_statistic_data,
      = jmc$ca_output_file =
        output_file: ^jmt$output_file_statistic_data,
      = jmc$ca_output_queue_residency =
        output_queue_residency: ^jmt$output_queue_residency_data,
      = jmc$ca_print_file =
        print_file: ^jmt$print_file_statistic_data,
      = jmc$ca_submit_job =
        submit_job: ^jmt$submit_job_statistic_data,
      = jmc$ca_standard_output_file =
        ,
      = jmc$ca_request_pf_transfer =
        request_perm_file_transfer: ^jmt$ptf_statistic_data,
      = jmc$ca_target_pf_transfer =
        target_perm_file_transfer: ^jmt$ptf_statistic_data,
      = jmc$ca_origin_qf_transfer =
        origin_queue_file_transfer: ^jmt$qtf_statistic_data,
      = jmc$ca_dest_qf_transfer =
        dest_queue_file_transfer: ^jmt$qtf_dest_statistic_data,
      = jmc$ca_interactive_interval =
        ,
      = jmc$ca_ftp_client_ctrl_connect, jmc$ca_ftp_client_data_connect,
        jmc$ca_ftp_server_ctrl_connect, jmc$ca_ftp_server_data_connect =
        ftp_statistics: ^jmt$ftp_statistic_data,
      casend,
    recend;

*copyc jmt$input_file_statistic_data
*copyc jmt$output_file_statistic_data
*copyc jmt$output_queue_residency_data
*copyc jmt$print_file_statistic_data
*copyc jmt$submit_job_statistic_data
*copyc jmt$ftp_statistic_data
*copyc jmt$ptf_statistic_data
*copyc jmt$qtf_statistic_data
*copyc jmt$qtf_dest_statistic_data
*DECK DECK=JMT$COMPLETED_JOB_COUNT_RANGE EXPAND=FALSE


  TYPE
    jmt$completed_job_count_range = 0 .. jmc$max_completed_job_count;

*copyc jmc$max_completed_job_count
*DECK DECK=JMT$CPU_DISPATCHING_ALLOCATION EXPAND=FALSE

  TYPE
    jmt$cpu_dispatching_allocation = array [jmt$user_dispatching_priority] of
          jmt$dispatching_allocation,

    jmt$dispatching_allocation = record
      minimum: 0 .. 100,
      maximum: 0 .. 100,
      enforce_maximum: boolean,
    recend;

*copyc jmt$dispatching_priority
*DECK DECK=JMT$CPU_TIME_LIMIT EXPAND=FALSE

{ The cpu time limit has a unit of seconds.

  TYPE
    jmt$cpu_time_limit = 0 .. jmc$cpu_time_limit_maximum;

  CONST
    jmc$cpu_time_limit_maximum = sfc$unlimited;

{ The following constants define the range of values permitted on SCL
{ parameter definitions and the internal representation for the keywords,
{ UNSPECIFIED, REQUIRED, SYSTEM_DEFAULT, and UNLIMITED.

  CONST
    jmc$lowest_cpu_time_limit = 1,
*IF $true(osv$unix)
    jmc$highest_cpu_time_limit = 7ffffffe(16),
    jmc$unspecified_cpu_time_limit = 7fffffff(16),
    jmc$required_cpu_time_limit = 7fffffff(16),
    jmc$system_default_cpu_time_lim = 7fffffff(16),
*ELSE
    jmc$highest_cpu_time_limit = 7fffffffffff(16), { 2**48 - 1
    jmc$unspecified_cpu_time_limit = jmc$highest_cpu_time_limit +
          jmc$unspecified_offset,
    jmc$required_cpu_time_limit = jmc$highest_cpu_time_limit +
          jmc$required_offset,
    jmc$system_default_cpu_time_lim = jmc$highest_cpu_time_limit +
          jmc$system_default_offset,
*IFEND
    jmc$unlimited_cpu_time_limit = jmc$cpu_time_limit_maximum;

*copyc jmc$attribute_keyword_offsets
*copyc sfc$unlimited
*DECK DECK=JMT$CPU_TIME_USED EXPAND=TRUE

{ The cpu time used is in the unit of milliseconds.

  TYPE
    jmt$cpu_time_used = record
      job_mode_time: 0 .. jmc$cpu_time_used_maximum,
      monitor_mode_time: 0 .. jmc$cpu_time_used_maximum,
    recend;

*IF $true(osv$unix)

  CONST
    jmc$cpu_time_used_maximum = 7fffffff(16);

*ELSE

  CONST
    jmc$cpu_time_used_maximum = 07fffffffffffffff(16);

*IFEND

*DECK DECK=JMT$DATA_DECLARATION EXPAND=TRUE

  TYPE
    jmt$data_declaration = string (jmc$data_declaration_size);

  CONST
    jmc$data_declaration_size = 2;



*DECK DECK=JMT$DATA_MODE EXPAND=FALSE

  TYPE
    jmt$data_mode = (jmc$coded_data, jmc$rhf_structure, jmc$transparent_data);
*DECK DECK=JMT$DATE_TIME EXPAND=FALSE

  TYPE
    jmt$date_time = record
      case specified: boolean of
      = TRUE =
        date_time: ost$date_time,
      = FALSE =
        ,
      casend,
    recend;

*copyc ost$date_time
*DECK DECK=JMT$DEFAULT_AND_RANGE_PARAMETER EXPAND=FALSE

  TYPE
    jmt$default_and_range_parameter = RECORD
      default: integer,
      minimum: integer,
      maximum: integer,
    RECEND;
*DECK DECK=JMT$DEFAULT_ATTRIBUTE_CHANGES EXPAND=FALSE

  TYPE
    jmt$default_attribute_changes = array [1 .. * ] of
          jmt$default_attribute_change;

  TYPE
    jmt$default_attribute_change = record
      case key: jmt$attribute_keys of
      = jmc$cpu_time_limit =
        cpu_time_limit: jmt$cpu_time_limit,
      = jmc$job_abort_disposition =
        job_abort_disposition: jmt$job_abort_disposition,
      = jmc$job_class =
        job_class: jmt$job_class_name,
      = jmc$job_deferred_by_operator =
        job_deferred_by_operator: boolean,
      = jmc$job_destination_usage =
        job_destination_usage: jmt$destination_usage,
      = jmc$job_qualifier_list =
        job_qualifier_list: ^jmt$job_qualifier_list,
      = jmc$job_recovery_disposition =
        job_recovery_disposition: jmt$job_recovery_disposition,
      = jmc$login_family =
        login_family: ost$name,
      = jmc$magnetic_tape_limit =
        magnetic_tape_limit: jmt$magnetic_tape_limit,
      = jmc$maximum_working_set =
        maximum_working_set: jmt$working_set_size,
      = jmc$null_attribute =
        ,
      = jmc$output_class =
        output_class: jmt$output_class_name,
      = jmc$output_deferred_by_operator =
        output_deferred_by_operator: boolean,
      = jmc$output_destination_usage =
        output_destination_usage: jmt$destination_usage,
      = jmc$purge_delay =
        purge_delay: ^jmt$time_increment,
      = jmc$site_information =
        site_information: ^jmt$site_information,
      = jmc$sru_limit =
        sru_limit: jmt$sru_limit,
      = jmc$station =
        station: jmt$station,
      = jmc$vertical_print_density =
        vertical_print_density: jmt$vertical_print_density,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$cpu_time_limit
*copyc jmt$destination_usage
*copyc jmt$job_abort_disposition
*copyc jmt$job_class_name
*copyc jmt$job_qualifier_list
*copyc jmt$job_recovery_disposition
*copyc jmt$magnetic_tape_limit
*copyc jmt$output_class_name
*copyc jmt$site_information
*copyc jmt$sru_limit
*copyc jmt$station
*copyc jmt$time_increment
*copyc jmt$vertical_print_density
*copyc jmt$working_set_size
*copyc ost$name
*DECK DECK=JMT$DEFAULT_ATTRIBUTE_RESULTS EXPAND=FALSE

  TYPE
    jmt$default_attribute_results = array [1 .. * ] of
          jmt$default_attribute_result;

  TYPE
    jmt$default_attribute_result = record
      case key: jmt$attribute_keys of
      = jmc$cpu_time_limit =
        cpu_time_limit: jmt$cpu_time_limit,
      = jmc$job_abort_disposition =
        job_abort_disposition: jmt$job_abort_disposition,
      = jmc$job_class =
        job_class: jmt$job_class_name,
      = jmc$job_deferred_by_operator =
        job_deferred_by_operator: boolean,
      = jmc$job_destination_usage =
        job_destination_usage: jmt$destination_usage,
      = jmc$job_qualifier_list =
        job_qualifier_list: ^jmt$job_qualifier_list,
      = jmc$job_recovery_disposition =
        job_recovery_disposition: jmt$job_recovery_disposition,
      = jmc$login_family =
        login_family: ost$name,
      = jmc$magnetic_tape_limit =
        magnetic_tape_limit: jmt$magnetic_tape_limit,
      = jmc$maximum_working_set =
        maximum_working_set: jmt$working_set_size,
      = jmc$null_attribute =
        ,
      = jmc$output_class =
        output_class: jmt$output_class_name,
      = jmc$output_deferred_by_operator =
        output_deferred_by_operator: boolean,
      = jmc$output_destination_usage =
        output_destination_usage: jmt$destination_usage,
      = jmc$purge_delay =
        purge_delay: ^jmt$time_increment,
      = jmc$site_information =
        site_information: ^jmt$site_information,
      = jmc$sru_limit =
        sru_limit: jmt$sru_limit,
      = jmc$station =
        station: jmt$station,
      = jmc$vertical_print_density =
        vertical_print_density: jmt$vertical_print_density,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$cpu_time_limit
*copyc jmt$destination_usage
*copyc jmt$job_abort_disposition
*copyc jmt$job_class_name
*copyc jmt$job_qualifier_list
*copyc jmt$job_recovery_disposition
*copyc jmt$magnetic_tape_limit
*copyc jmt$output_class_name
*copyc jmt$site_information
*copyc jmt$sru_limit
*copyc jmt$station
*copyc jmt$time_increment
*copyc jmt$vertical_print_density
*copyc jmt$working_set_size
*copyc ost$name
*DECK DECK=JMT$DEFAULT_JOB_ATTRIBUTES EXPAND=FALSE

  TYPE
    jmt$default_job_attributes = array [jmc$batch .. jmc$interactive_connected]
          of jmt$default_job_attribute;

  TYPE
    jmt$default_job_attribute = record
      cpu_time_limit: jmt$cpu_time_limit,
      device: jmt$output_device,
      external_characteristics: jmt$external_characteristics,
      forms_code: jmt$forms_code,
      job_abort_disposition: jmt$job_abort_disposition,
      job_class: jmt$job_class_name,
      job_deferred_by_operator: boolean,
      job_destination_usage: jmt$destination_usage,
      job_qualifier_list: array [1 .. jmc$maximum_job_qualifiers] of ost$name,
      job_recovery_disposition: jmt$job_recovery_disposition,
      login_family: ost$name,
      magnetic_tape_limit: jmt$magnetic_tape_limit,
      maximum_working_set: jmt$working_set_size,
      output_class: jmt$output_class_name,
      output_deferred_by_operator: boolean,
      output_destination_usage: jmt$destination_usage,
      output_priority: jmt$output_priority,
      purge_delay: jmt$time_increment,
      site_information: jmt$site_information,
      sru_limit: jmt$sru_limit,
      station: jmt$station,
      vertical_print_density: jmt$vertical_print_density,
      vfu_load_procedure: jmt$vfu_load_procedure,
    recend;

*copyc jmt$cpu_time_limit
*copyc jmt$destination_usage
*copyc jmt$external_characteristics
*copyc jmt$forms_code
*copyc jmt$job_abort_disposition
*copyc jmt$job_class_name
*copyc jmt$job_mode
*copyc jmt$job_qualifier_list
*copyc jmt$job_recovery_disposition
*copyc jmt$magnetic_tape_limit
*copyc jmt$output_class_name
*copyc jmt$output_device
*copyc jmt$output_priority
*copyc jmt$site_information
*copyc jmt$sru_limit
*copyc jmt$station
*copyc jmt$time_increment
*copyc jmt$vertical_print_density
*copyc jmt$vfu_load_procedure
*copyc jmt$working_set_size
*copyc ost$name
*DECK DECK=JMT$DEFINED_CLASSES EXPAND=FALSE

  TYPE
    jmt$defined_classes = array [1 .. * ] of jmt$defined_class;

  TYPE
    jmt$defined_class = record
      name: ost$name,
      index: ost$non_negative_integers,
    recend;

*copyc osd$integer_limits
*copyc ost$name
*DECK DECK=JMT$DELAYED_SWAPIN_WORK EXPAND=FALSE
{Define list of special work that must be done to a job environment when
{the job is next swapped in.
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
    jmt$delayed_swapin_work = SET OF (jmc$dsw_job_recovery, jmc$dsw_update_debug_lists,
        jmc$dsw_update_keypoint_masks, jmc$dsw_job_asid_changed, jmc$dsw_job_shared_asid_changed,
        jmc$dsw_update_job_task_enviro, jmc$dsw_recovery_swap_io_error, jmc$dsw_update_server_files,
        jmc$dsw_adjust_cpu_selections, jmc$dsw_io_error_while_swapped, jmc$dsw_unused_10, jmc$dsw_unused_11,
        jmc$dsw_unused_12, jmc$dsw_unused_13, jmc$dsw_unused_14, jmc$dsw_unused_15);

   TYPE
    jmt$delayed_swapin_work_record = record
      delayed_swapin_work: jmt$delayed_swapin_work,
      { The inhibit_access_work and terminate_access_work are only used when
      { update server files is include in the set.
      inhibit_access_work: dft$mainframe_set,
      terminate_access_work: dft$mainframe_set,
    recend;

*copyc dft$mainframe_set
*DECK DECK=JMT$DESTINATION_USAGE EXPAND=FALSE

  TYPE
    jmt$destination_usage = ost$name;

?? FMT (FORMAT := OFF) ??
  CONST
    jmc$dual_state_usage = 'DUAL_STATE                     ',
    jmc$private_usage    = 'PRIVATE                        ',
    jmc$public_usage     = 'PUBLIC                         ',
    jmc$qtf_usage        = 'QTF                            ',
    jmc$ntf_usage        = 'NTF                            ',
    jmc$ve_usage         = 'VE                             ',
    jmc$ve_family_usage  = 'VE_FAMILY                      ',
    jmc$ve_local_usage   = 'VE_LOCAL                       ',
    jmc$ve_qtf_usage     = 'VE_QTF                         ';
?? FMT (FORMAT := ON) ??

*copyc ost$name
*DECK DECK=JMT$DETACHED_JOB_WAIT_TIME EXPAND=FALSE

  TYPE
    jmt$detached_job_wait_time = 0..jmc$detached_job_wait_time_max;

  CONST
    jmc$detached_job_wait_time_max = jmc$highest_det_job_wait_time +
          jmc$unlimited_offset;

{ The following constants define the range of values permitted on SCL
{ parameter definitions and the internal representation for the keyword,
{ UNLIMITED.

  CONST

    jmc$lowest_det_job_wait_time = 0,
    jmc$highest_det_job_wait_time = 36000,
    jmc$unlimited_det_job_wait_time = jmc$highest_det_job_wait_time +
          jmc$unlimited_offset;

*copyc jmc$attribute_keyword_offsets
*DECK DECK=JMT$DISPATCHING_CONTROL EXPAND=FALSE

  TYPE
    jmt$dispatching_control= ARRAY [jmt$dispatching_control_index] OF
          jmt$dispatching_controls,

    jmt$dispatching_controls = RECORD
      set_defined: boolean,
      dispatching_priority: jmt$dispatching_priority,
      service_limit: ost$free_running_clock, { microseconds
      dispatching_timeslice: jmt$time_slice_values,
    RECEND;

{ The following constants define the range of values permitted on SCL
{ parameter definitions and the internal representation for the keyword,
{ UNLIMITED, for the service limit element of the record.  Service limit
{ has a unit of microseconds internally but is specified in milliseconds
{ externally.

  CONST
*IF $true(osv$unix)
    jmc$dc_maximum_service_limit = 7fffffff(16), { microseconds
    jmc$highest_service_limit = 7fffffff(16), { microseconds
*ELSE
    jmc$dc_maximum_service_limit = 0ffffffffffff(16), { microseconds
    jmc$highest_service_limit = 3600000000, { microseconds
*IFEND
    jmc$lowest_service_limit = 1000; { microseconds

  TYPE
    jmt$time_slice_values = RECORD
      minor: jmt$task_time_slice,
      major: jmt$task_time_slice,
    RECEND;

*copyc jmt$dispatching_control_index
*copyc jmt$dispatching_priority
*copyc jmt$task_time_slice
*copyc ost$free_running_clock

*DECK DECK=JMT$DISPATCHING_CONTROL_INDEX EXPAND=FALSE

  CONST
    jmc$min_dispatching_control = 1,
    jmc$max_dispatching_control = 5;

  TYPE
    jmt$dispatching_control_index = jmc$min_dispatching_control ..
          jmc$max_dispatching_control;

*DECK DECK=JMT$DISPATCHING_CONTROL_INFO EXPAND=FALSE

  TYPE
    jmt$dispatching_control_info = RECORD
      dispatching_control_index: jmt$dispatching_control_index,
      dispatching_priority: jmt$dispatching_priority,
      service_remaining: ost$free_running_clock,
    RECEND;

*copyc jmt$dispatching_control_index
*copyc jmt$dispatching_priority
*DECK DECK=JMT$DISPATCHING_INTERVAL EXPAND=FALSE

  TYPE
    jmt$dispatching_interval = 0 .. 600;
*DECK DECK=JMT$DISPATCHING_PRIORITY EXPAND=FALSE

{ Define 180 job and task cpu priorities. For purposes of sharing the CPU in
{ dual state, the equivalent 170 priorities are also shown in comments.

  TYPE
    jmt$dispatching_priority = 0 .. jmc$max_dispatching_priority,
    jmt$user_dispatching_priority = jmc$priority_p1 .. jmc$priority_p8,
    jmt$system_dispatching_priority = jmc$priority_p10 .. jmc$priority_p14,
    jmt$dispatching_priority_bias = -jmc$max_dispatching_priority ..
          jmc$max_dispatching_priority;



{  Jmc$dp_conversion is used to change a dispatching priority to a bit number
{  that is used in dispatching priority sets.  Because task switch uses
{  #unchecked_conversion to select elements from the dispatching control sets
{  rather than the CYBIL IN set manipulator, the bit stored in the sets has to
{  be a "converted" dispatching priority.  The leftmost bit in the set
{  represents the highest dispatching priority.  The following table relates
{  priorities and bits:
{------------------------------------------------------------------------------
{    Dispatching                       Dispatching      Conversion
{     Priority        Dispatching       Priority         Function
{       Name           Priority           Bit            Returns
{    -----------      -----------      -----------      ----------
{        P1                2               14                2
{        P2                3               13                3
{        P3                4               12                4
{        P4                5               11                5
{        P5                6               10                6
{        P6                7                9                7
{        P7                8                8                8
{        P8                9                7                9
{        P9               10                6               10
{        P10              11                5               11
{        P11              12                4               12
{        P12              13                3               13
{        P13              14                2               14
{        P14              15                1               15
{------------------------------------------------------------------------------

  CONST

    jmc$dp_conversion = 16,

    jmc$max_dispatching_priority = 15,
    jmc$min_dispatching_priority = 2, { Minimum dispatchable priority
    jmc$null_dispatching_priority = 0;

{ The following constants define the range of values permitted on SCL
{ parameter definitions. The values are specified internally as one number
{ greater than the external values.  The following internal range of 2 .. 11
{ is specified as 1 .. 10 externally.

  CONST
    jmc$lowest_dispatching_priority = 2,
    jmc$highest_dispatch_priority = 11;

  CONST
    jmc$priority_p1 = 2, { 170 - 10 }
    jmc$priority_p2 = 3, { 170 - 10 }
    jmc$priority_p3 = 4, { 170 - 20 }
    jmc$priority_p4 = 5, { 170 - 20 }
    jmc$priority_p5 = 6, { 170 - 30 }
    jmc$priority_p6 = 7, { 170 - 30 }
    jmc$priority_p7 = 8, { 170 - 40 }
    jmc$priority_p8 = 9, { 170 - 40 }
    jmc$priority_p9 = 10, { 170 - 50 }
    jmc$priority_p10 = 11, { 170 - 50 }
    jmc$priority_p11 = 12, { 170 - 60 }
    jmc$priority_p12 = 13, { 170 - 60 }
    jmc$priority_p13 = 14, { 170 - 70 }
    jmc$priority_p14 = 15; { 170 - 70 }


*DECK DECK=JMT$DISPATCHING_PRIORITY_SET EXPAND=FALSE

  TYPE
    jmt$dispatching_priority_set = SET OF jmt$dispatching_priority;

*copyc jmt$dispatching_priority
*DECK DECK=JMT$DISPLAY_MESSAGE EXPAND=FALSE

  TYPE
    jmt$display_message = record
      size: 0 .. jmc$display_message_size,
      value: string (jmc$display_message_size),
    recend;

  CONST
    jmc$display_message_size = 64;

  CONST
    jmc$dm_login_family_unavailable = 'The job''s login family is unavailable.'
          ,
    jmc$dm_job_deferred_by_operator = 'JOB_DEFERRED_BY_OPERATOR = TRUE',
    jmc$dm_job_deferred_by_user = 'JOB_DEFERRED_BY_USER = TRUE',
    jmc$dm_waiting_for_ert =
          'The job''s EARLIEST_RUN_TIME has not arrived yet.';

*DECK DECK=JMT$DISPOSITION_CODE EXPAND=FALSE

  TYPE
    jmt$disposition_code = string (jmc$disposition_code_size);

  CONST
    jmc$disposition_code_size = 2;

*DECK DECK=JMT$DUAL_STATE_PRIORITY_CONTROL EXPAND=FALSE

  TYPE
    jmt$dual_state_priority_control = array
          [jmc$priority_p1 .. jmc$priority_p10] of
          jmt$dual_state_priority_entry,

    jmt$dual_state_priority_entry = record
      priority: jmt$dual_state_priority,
      subpriority: jmt$dual_state_subpriority,
    recend,

    jmt$dual_state_priority = 0 .. 7,
    jmt$dual_state_subpriority = 1 .. 15;

*copyc jmt$dispatching_priority
*DECK DECK=JMT$ERROR_STATUS_LIST EXPAND=FALSE

  TYPE
    jmt$error_status_list = array [1 .. * ] of jmt$error_status;

  TYPE
    jmt$error_status = record
      system_supplied_name: jmt$system_supplied_name,
      status: ost$status,
    recend;

*copyc jmt$system_supplied_name
*copyc ost$status
*DECK DECK=JMT$EXECUTING_TASK_ENTRY EXPAND=FALSE

  TYPE
    jmt$executing_task_entry=record
      task_name: pmt$program_name,
      task_id: pmt$task_id,
      task_status: pmt$task_status,
    recend;

*copyc PMT$PROGRAM_NAME
*copyc PMT$TASK_ID
*copyc PMT$TASK_STATUS

*DECK DECK=JMT$EXTERNAL_CHARACTERISTICS EXPAND=FALSE

  TYPE
    jmt$external_characteristics = string (jmc$ext_characteristics_size);

  CONST
    jmc$ext_characteristics_size = 6;

*DECK DECK=JMT$FORMS_CODE EXPAND=FALSE

  TYPE
    jmt$forms_code = string (jmc$forms_code_size);

  CONST
    jmc$forms_code_size = 6;
*DECK DECK=JMT$FTP_STATISTIC_DATA EXPAND=FALSE
  CONST
    jmc$ftp_boolean_length = 5,
    jmc$ftp_command_length = 255,
    jmc$ftp_ip_addr_length = 15,
    jmc$ftp_port_number_length = 5;

  TYPE
    jmt$ftp_statistic_data = record
      connect_time: ost$non_negative_integers,
      requesting_mainframe_address: string (jmc$ftp_ip_addr_length),
      requesting_port_number: string (jmc$ftp_port_number_length),
      target_mainframe_address: string (jmc$ftp_ip_addr_length),
      target_port_number: string (jmc$ftp_port_number_length),
      command: string (jmc$ftp_command_length),
      successful: string (jmc$ftp_boolean_length),
      bytes_received: ost$non_negative_integers,
      case boolean of
      = FALSE =
        bytes_sent: ost$non_negative_integers,
      = TRUE =
        file_size: ost$non_negative_integers,
      casend,
    recend;

*copyc osd$integer_limits
*DECK DECK=JMT$FULL_JOB_CATEGORY_LIST EXPAND=FALSE

  TYPE
    jmt$full_job_category_list = array [1 .. jmc$maximum_job_category_count] of
          ost$name;

*copyc jmt$job_category_list
*copyc ost$name
*DECK DECK=JMT$GENERAL_PURPOSE_RPC_ORDINAL EXPAND=FALSE

{ Add all entries before the ordinal jmc$gpro_unused_ordinal

  TYPE
    jmt$general_purpose_rpc_ordinal = (
?? FMT (FORMAT := OFF) ??
      jmc$gpro_get_job_status        , { used for jmp$get_job_status
      jmc$gpro_get_output_status     , { used for jmp$get_output_status
      jmc$gpro_get_output_attributes , { used for jmp$get_output_attributes
      jmc$gpro_get_input_attributes  , { used for jmp$get_input_attributes
      jmc$gpro_change_output_attribut, { used for jmp$change_output_attributes
      jmc$gpro_change_input_attribute, { used for jmp$change_input_attributes
      jmc$gpro_terminate_output      , { used for jmp$terminate_output
      jmc$gpro_set_sense_switches    , { used for jmp$switch_command_r3
      jmc$gpro_get_leveling_data     , { used for jmp$get_leveling_data
      jmc$gpro_unused_ordinal          { not used
?? FMT (FORMAT := ON) ??
    );

*DECK DECK=JMT$HEADER_DISPLAY_INFORMATION EXPAND=FALSE

  TYPE
    jmt$header_display_information = array [1 .. *] of ost$string;

*copyc ost$string
*DECK DECK=JMT$IDLE_DISPATCHING_CONTROLS EXPAND=FALSE

  TYPE
    jmt$idle_dispatching_controls = RECORD
      unblocked_priorities: jmt$dispatching_priority_set,
      maximums_exceeded: jmt$dispatching_priority_set,
      controls: jmt$idle_dispatch_controls,
    RECEND,

      jmt$idle_dispatch_controls = ARRAY [jmt$dispatching_priority] OF jmt$idle_dispatching_entry,

    jmt$idle_dispatching_entry = RECORD
      blocked: boolean,
      idle_noticed_once: boolean,
      timestamp: ost$free_running_clock,
      last_cp_time: ost$free_running_clock,
    RECEND;

*copyc jmt$dispatching_priority
*copyc jmt$dispatching_priority_set
*copyc ost$free_running_clock
*DECK DECK=JMT$IDLE_DISPATCHING_QUEUE_TIME EXPAND=FALSE

{ The idle dispatching queue time has a unit of microseconds.

  TYPE
    jmt$idle_dispatching_queue_time = ost$free_running_clock;

{ The following constants define the range of values permitted on SCL
{ parameter definitions and the internal representation for the keyword,
{ UNLIMITED.  Idle dispatching queue time has a unit of microseconds
{ internally but is specified in seconds externally.
{
{ As long as the unlimited constant is defined as the upperbound of the
{ free running clock, there is no need to test the idle dispatching
{ queue time of a job for this unlimited value since this value
{ will never be reached.

  CONST
    jmc$lowest_idle_disp_q_time = 10 * 1000000, { microseconds
    jmc$highest_idle_disp_q_time = 36000 * 1000000, { microseconds
    jmc$unlimited_idle_disp_q_time = osc$free_running_clock_maximum;

*copyc ost$free_running_clock
*DECK DECK=JMT$IJLE_SIZE EXPAND=FALSE

  TYPE
    jmt$ijle_size = 0 .. 65535;
*DECK DECK=JMT$IJL_DISPATCHING_CONTROL EXPAND=FALSE
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
    jmt$ijl_dispatching_control = record
      dispatching_control_index: jmt$dispatching_control_index,
      dispatching_priority: jmt$dispatching_priority,
      user_requested_dispatching_prio: jmt$dispatching_priority,
      operator_set_dispatching_prio: jmt$dispatching_priority,
      service_remaining: ost$free_running_clock,
      cp_service_at_class_switch: integer,
    RECEND;

*copyc jmt$dispatching_priority
*copyc jmt$dispatching_control
*copyc jmt$dispatching_control_index
*copyc ost$free_running_clock
*DECK DECK=JMT$IJL_ENTRY_STATUS EXPAND=FALSE

{ NOTE:  The ijl entry statuses are order dependant for swap direction checking.  The constants
{ jmc$ies_swapped_in and jmc$ies_swapped_job are defined for swap direction checking in swapper.
{ If a job's entry status is less than jmc$ies_swapped_out, then the swap direction is IN.
{ If the entry status is greater than jmc$ies_swapped_in, then the swap direction is OUT.

  TYPE
    jmt$ijl_entry_status = (jmc$ies_entry_free,
                            jmc$ies_job_terminating,
                            jmc$ies_job_in_memory_non_swap,
                            jmc$ies_job_in_memory,
                            jmc$ies_swapin_in_progress,
                            jmc$ies_job_swapped,
                            jmc$ies_operator_force_out,
                            jmc$ies_system_force_out,
                            jmc$ies_job_damaged,
                            jmc$ies_ready_task,
                            jmc$ies_swapin_candidate);

  CONST
    jmc$ies_swapped_in = jmc$ies_swapin_in_progress,
    jmc$ies_swapped_out = jmc$ies_job_swapped;
*DECK DECK=JMT$IJL_ENTRY_STATUS_STATISTICS EXPAND=FALSE

{ Define statistics kept for IJL entry status transitions.

  TYPE
    jmt$ijl_entry_status_statistics = ARRAY [jmt$ijl_entry_status] OF ARRAY [jmt$ijl_entry_status] OF
        0 .. 0ffffffff(16);

*copyc jmt$initiated_job_list_entry
*DECK DECK=JMT$IJL_ORDINAL EXPAND=FALSE
{  Define IJL ordinal. An IJL ordinal is packed record that consists of
{     two parts:
{     block_number - an index into an array of pointers to small arrays
{                    of IJL entries
{     block_index  - an index into the small array of IJL entries
{
{  For optimum efficiency, the number of bits in an IJL ordinal should be
{  a multiple of 8 bits and each component of the ordinal should be
{  0 .. 2**n-1.

  TYPE
    jmt$ijl_ordinal = packed RECORD
      block_number: jmt$ijl_block_number,
      block_index: jmt$ijl_block_index,
    RECEND,

    jmt$ijl_block_number = 0 .. 2047,
    jmt$ijl_block_index = 0 .. 31;

  CONST
    jmc$max_ijl_entries = 2048 * 32,
    jmc$max_ijl_index_count = 32;
*DECK DECK=JMT$IJL_P EXPAND=FALSE
{ Define structure used to point to the Initiated Job List (IJL).

  TYPE
    jmt$ijl_p = RECORD
      block_p: jmt$initiated_job_list_p,
      max_block_in_use: jmt$ijl_block_number,
      start_search_block: jmt$ijl_block_number,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_p
?? POP ??
*DECK DECK=JMT$IJL_SERVICE_CLASS_STATS EXPAND=FALSE

  TYPE

*IF $true(osv$unix)
    jmt$ijl_page_fault_count = 0 .. 7fffffff(16),
*ELSE
    jmt$ijl_page_fault_count = 0 .. 0ffffffff(16),
*IFEND

    jmt$ijl_service_class_stats = record
      cp_time: ost$cp_time,
      page_faults: jmt$ijl_page_stats,
      swapouts: jmt$ijl_swap_counts,
    recend,

    jmt$ijl_page_stats = record
      disk: jmt$ijl_page_fault_count,
      reclaimed: jmt$ijl_page_fault_count,
      assigned: jmt$ijl_page_fault_count,
    recend;

*copyc jmt$ijl_swap_counts
*copyc ost$cp_time
*DECK DECK=JMT$IJL_STATISTICS EXPAND=FALSE
{Define statistics record that is kept in the IJL.
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
    jmt$ijl_statistics = record
      cp_time: ost$cp_time,
      paging_statistics: ost$paging_statistics,
      perm_file_space: sft$counter,
      temp_file_space: sft$counter,
      ready_task_count: 0 .. 0ffff(16),
      tasks_not_in_long_wait: 0 .. 0ffff(16),
    recend;

*copyc OST$CP_TIME
*copyc OST$PAGING_STATISTICS
*copyc sft$counter
*DECK DECK=JMT$IJL_SWAP_COUNTS EXPAND=FALSE

  TYPE
    jmt$ijl_swap_counts = record
      long_wait: jmt$ijl_swap_count,
      job_mode: jmt$ijl_swap_count,
    recend,

    jmt$ijl_swap_count = 0 .. 0ffffff(16);
*DECK DECK=JMT$IJL_SWAP_STATUS EXPAND=FALSE
{Define swap status field used in IJL (initiated job list entry).

  TYPE
    jmt$ijl_swap_status = (jmc$iss_null,
        jmc$iss_executing,
        jmc$iss_idle_tasks_initiated,
        jmc$iss_job_idle_tasks_complete,
        jmc$iss_swapped_no_io,
        jmc$iss_flush_am_pages,
        jmc$iss_job_allocate_swap_file,
        jmc$iss_wait_allocate_swap_file,
        jmc$iss_allocate_swap_file,
        jmc$iss_wait_job_io_complete,
        jmc$iss_job_io_complete,
        jmc$iss_wait_allocate_sfd,
        jmc$iss_allocate_sfd,
        jmc$iss_swapped_io_cannot_init,
        jmc$iss_initiate_swapout_io,
        jmc$iss_wait_swapout_io_init,
        jmc$iss_swapout_io_initiated,
        jmc$iss_swapout_io_complete,
        jmc$iss_swapped_io_complete,
        jmc$iss_free_swapped_memory,
        {Note: jmc$iss_swapout_complete is used by syp$get_job_swap_status
        {to determine if JWS pages were recovered (or not) by DM file recovery
        jmc$iss_swapout_complete,
        jmc$iss_swapin_requested,
        jmc$iss_swapin_resource_claimed,
        jmc$iss_wait_swapin_io_init,
        jmc$iss_swapin_io_initiated,
        jmc$iss_swapin_io_complete),

    jmt$swapout = jmc$iss_idle_tasks_initiated .. jmc$iss_swapout_complete,
    jmt$swapin = jmc$iss_swapin_requested .. jmc$iss_swapin_io_complete;

{ The following constants are used to inhibit access to jobs that are in
{ the process of being swapped.  Memory manager io is inhibited if swap status
{ is greater than jmc$inhibit_memory_manager_io (MMP$GET_INHIBIT_IO_STATUS).
{ XCB access is inhibited if swap status is greater than jmc$inhibit_xcb_access
{ (TMP$GET_XCB_ACESS_STATUS).

  CONST
    jmc$inhibit_memory_manager_io = jmc$iss_swapped_no_io,
    jmc$inhibit_xcb_access = jmc$iss_swapped_io_cannot_init;

*DECK DECK=JMT$IMPLICIT_ROUTING_TEXT EXPAND=FALSE

  TYPE
    jmt$implicit_routing_text = record
      size: 0 .. jmc$implicit_routing_text_size,
      text: string (jmc$implicit_routing_text_size),
    recend;

  CONST
    jmc$implicit_routing_text_size = 256;
*DECK DECK=JMT$INITIATED_JOB_LIST_ENTRY EXPAND=FALSE

{
{ IJL - (Initiated Job List) An entry exists in this table for each job that
{       has been initiated and has not terminated.
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{



  TYPE
    jmt$initiated_job_list_entry = record
      system_supplied_name: ALIGNED [0 MOD 8] jmt$system_supplied_name,
      job_name: ost$name,
      entry_status: jmt$ijl_entry_status,
      ajl_ordinal: jmt$ajl_ordinal,
      kjl_ordinal: jmt$kjl_index,
      swap_status: jmt$ijl_swap_status,
      next_swap_status: jmt$ijl_swap_status,
      last_swap_status: jmt$ijl_swap_status,
      inhibit_swap_count: 0 .. 0ffffff(16),
      active_io_page_count: 0 .. 0ffffff(16),
      active_io_requests: 0 .. 0ffff(16),
      swap_queue_link: jst$ijl_swap_queue_link,
      job_fixed_asid: ost$asid,
      long_wait_aging_complete: boolean,
      notify_swapper_when_io_complete: boolean,
      scheduling_dispatching_priority: jmt$dispatching_priority,
      dispatching_control: jmt$ijl_dispatching_control,
      job_monitor_taskid: ost$global_task_id,
      job_mode: jmt$job_mode,
      executing_task_count: 0 .. 0ff(16),
      multiprocessing_allowed: boolean,
      memory_reserve_request: mmt$memory_reserve_request,
      swapin_candidate_queue: jmt$ijl_ordinal,
      swapin_candidate_queue_dp: jmt$dispatching_priority,
      estimated_ready_time: ost$free_running_clock,
      last_think_time: ost$free_running_clock,
      age_purge_timestamp: ost$free_running_clock,
      sfd_purge_timestamp: ost$free_running_clock,
      job_scheduler_data: jmt$scheduling_data,
      job_page_queue_list: mmt$job_page_queue_list,
      swap_data: jmt$swap_data,
      swap_io_control: jst$io_control_information,
      sfd_p: ^jst$swap_file_descriptor,
      system_breakpoint_selected: boolean,
      delayed_swapin_work: jmt$delayed_swapin_work,
      inhibit_access_work: dft$mainframe_set,
      terminate_access_work: dft$mainframe_set,
      statistics: jmt$ijl_statistics,
      service_class_statistics: jmt$ijl_service_class_stats,
      job_fixed_contiguous_pages: 0 .. 0ff(16),
      hung_task_in_job: boolean,
      job_damaged_during_recovery: boolean,
      maxws_aio_slowdown_display: 0 .. 0ff(16),
      unable_to_swap_idle_flag: boolean,
      queue_file_information: jmt$queue_file_ijl_information,
      display_message: oft$display_message_info,
      relative_priority_enabled: boolean,
      task_created_after_last_swap: boolean,
      interactive_task_gtid: ost$global_task_id,
      cp_time_last_dc_reset: ost$cp_time_value,
      active_cart_tape_write: 0 .. 0ff(16),
      override_job_working_set_max: boolean,
      segment_lock_count: integer,
    RECEND,

    jmt$scheduling_data = RECORD
      ready_task_link: jmt$ijl_ordinal,
      service_accumulator: jmt$service_accumulator,
      service_accumulator_since_swap: jmt$service_accumulator,
      guaranteed_service_remaining: jmt$service_accumulator,
      last_cptime: ost$cp_time_value,
*IF $true(osv$unix)
      last_page_fault_count: 0 .. 7fffffff(16),
*ELSE
      last_page_fault_count: 0 .. 0ffffffffff(16),
*IFEND
      job_swap_counts: jmt$ijl_swap_counts,
      swapout_reason: jmt$swapout_reasons,
      priority: jmt$job_priority,
      unaged_swap_queue_priority: jmt$job_priority,
      swapin_q_priority_timestamp: ost$free_running_clock,
      job_class: jmt$job_class,
      service_class: jmt$service_class_index,
    RECEND,

    jmt$swap_data = record
      swap_file_sfid: dmt$system_file_id,
      swapping_io_error: iot$io_error,
      swapped_job_page_count: 0 .. osc$max_page_frames,
      swap_file_length_in_pages: 0 .. osc$max_page_frames,
      asid_reassigned_timestamp: ost$free_running_clock,
      timestamp: ost$free_running_clock,
      swapout_timestamp: ost$free_running_clock,
      long_wait_expire_time: ost$free_running_clock,
      reassigned_job_fixed_asti: mmt$ast_index,
      swapped_job_entry: jmt$swapped_job_entry,
    RECEND,

*IF $true(osv$unix)
    jmt$service_counts = 0 .. 7fffffff(16),
*ELSE
    jmt$service_counts = 0 .. 0ffffffffffff(16),
*IFEND

    jst$swap_direction = (jsc$sd_in, jsc$sd_out);

*copyc dft$mainframe_set
*copyc dmt$system_file_id
*copyc jmt$ajl_ordinal
*copyc jmt$delayed_swapin_work
*copyc jmt$dispatching_priority
*copyc jmt$ijl_dispatching_control
*copyc jmt$ijl_entry_status
*copyc jmt$ijl_swap_status
*copyc jmt$ijl_ordinal
*copyc jmt$ijl_service_class_stats
*copyc jmt$ijl_statistics
*copyc jmt$job_class
*copyc jmt$job_mode
*copyc jmt$job_priority
*copyc jmt$kjl_index
*copyc jmt$queue_file_ijl_information
*copyc jmt$service_accumulator
*copyc jmt$service_class_index
*copyc jmt$swapout_reasons
*copyc jmt$swapped_job_entry
*copyc jmt$system_supplied_name
*copyc jst$ijl_swap_queue_link
*copyc jst$io_control_information
*copyc jst$swap_file_descriptor
*copyc mmt$ast_index
*copyc mmt$memory_reserve_request
*copyc mmt$page_queue_list
*copyc oft$display_message_info
*copyc ost$global_task_id
*copyc ost$cp_time
*copyc ost$hardware_subranges
*copyc ost$name
*copyc jmt$dispatching_control
*copyc iot$io_error
*DECK DECK=JMT$INITIATED_JOB_LIST_P EXPAND=FALSE
{  Define structures used to manage the IJL arrays.
{  Force word alignment for performance.

  TYPE
    jmt$initiated_job_list_block = RECORD
      in_use_count: ALIGNED [0 MOD 8] 0 .. jmc$max_ijl_index_count,
      terminated_job: boolean,
      index_p: ^ARRAY [jmt$ijl_block_index] OF jmt$initiated_job_list_entry,
    RECEND,

    jmt$initiated_job_list_p = ^ARRAY [0 .. *] OF jmt$initiated_job_list_block;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=JMT$INITIATE_SYSTEM_IDLE EXPAND=FALSE
{Define signal sent to the system job monitor to initiate a system idle.

  TYPE
    jmt$initiate_system_idle = record
      idle_code: syt$180_idle_code,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc syt$180_idle_code
?? POP ??

*DECK DECK=JMT$INITIATION_CONDITIONS EXPAND=FALSE

  TYPE
    jmt$initiation_conditions = (jmc$automatic_initiation, jmc$scheduler_initiation,
                                 jmc$interactive_initiation);

*DECK DECK=JMT$INPUT_APPLICATION_INDEX EXPAND=FALSE

  TYPE
    jmt$input_application_index = 0 .. jmc$maximum_input_applications;

  CONST
    jmc$ve_input_application_index = 1,
    jmc$unassigned_input_index = 0;

*copyc jmc$maximum_input_applications

*DECK DECK=JMT$INPUT_APPLICATION_TABLE EXPAND=FALSE

  TYPE
    jmt$input_application_table = array [jmt$input_application_index] of
          jmt$input_application_data;

  TYPE
    jmt$input_application_data = record
      application_name: ost$name,
      destination_usage: jmt$destination_usage,
      global_task_id: ost$global_task_id,
      queue_file_password: ost$name,
      state_data: jmt$input_appl_state_data,
    recend;

  TYPE
    jmt$input_appl_state_data = array [jmt$kjl_application_state] of
          jmt$input_appl_state_entry;

  TYPE
    jmt$input_appl_state_entry = record
      first_entry: jmt$kjl_index,
      last_entry: jmt$kjl_index,
      number_of_entries: jmt$job_count_range,
    recend;

*copyc jmt$destination_usage
*copyc jmt$input_application_index
*copyc jmt$kjl_application_state
*copyc jmt$kjl_index
*copyc jmt$job_count_range
*copyc ost$global_task_id
*copyc ost$name


*DECK DECK=JMT$INPUT_ATTRIBUTE_CHANGES EXPAND=FALSE

  TYPE
    jmt$input_attribute_changes = array [1 .. * ] of
          jmt$input_attribute_change;

  TYPE
    jmt$input_attribute_change = record
      case key: jmt$attribute_keys of
      = jmc$comment_banner =
        comment_banner: jmt$output_comment_banner,
      = jmc$copies =
        copies: jmt$output_copy_count,
      = jmc$cpu_time_limit =
        cpu_time_limit: jmt$cpu_time_limit,
      = jmc$device =
        device: jmt$output_device,
      = jmc$earliest_print_time =
        earliest_print_time: jmt$date_time,
      = jmc$earliest_run_time =
        earliest_run_time: jmt$date_time,
      = jmc$encrypted_password =
        encrypted_password: ost$name,
      = jmc$external_characteristics =
        external_characteristics: jmt$external_characteristics,
      = jmc$forms_code =
        forms_code: jmt$forms_code,
      = jmc$job_abort_disposition =
        job_abort_disposition: jmt$job_abort_disposition,
      = jmc$job_class =
        job_class: jmt$job_class_name,
      = jmc$job_deferred_by_operator =
        job_deferred_by_operator: boolean,
      = jmc$job_deferred_by_user =
        job_deferred_by_user: boolean,
      = jmc$job_qualifier_list =
        job_qualifier_list: ^jmt$job_qualifier_list,
      = jmc$job_recovery_disposition =
        job_recovery_disposition: jmt$job_recovery_disposition,
      = jmc$latest_print_time =
        latest_print_time: jmt$date_time,
      = jmc$latest_run_time =
        latest_run_time: jmt$date_time,
      = jmc$login_account =
        login_account: avt$account_name,
      = jmc$login_project =
        login_project: avt$project_name,
      = jmc$magnetic_tape_limit =
        magnetic_tape_limit: jmt$magnetic_tape_limit,
      = jmc$maximum_working_set =
        maximum_working_set: jmt$working_set_size,
      = jmc$null_attribute =
        ,
      = jmc$output_class =
        output_class: jmt$output_class_name,
      = jmc$output_deferred_by_user =
        output_deferred_by_user: boolean,
      = jmc$output_destination =
        output_destination: ost$name,
      = jmc$output_destination_family = { operator_family
        output_destination_family: ost$name,
      = jmc$output_destination_usage =
        output_destination_usage: jmt$destination_usage,
      = jmc$output_disposition =
        output_disposition: jmt$output_disposition,
      = jmc$output_priority =
        output_priority: jmt$output_priority,
      = jmc$purge_delay =
        purge_delay: ^jmt$time_increment,
      = jmc$remote_host_directive =
        remote_host_directive: ^jmt$remote_host_directive,
      = jmc$routing_banner =
        routing_banner: jmt$output_routing_banner,
      = jmc$site_information =
        site_information: ^jmt$site_information,
      = jmc$sru_limit =
        sru_limit: jmt$sru_limit,
      = jmc$station =
        station: jmt$station,
      = jmc$station_operator = { operator_user
        station_operator: jmt$station_operator,
      = jmc$user_information =
        user_information: ^jmt$user_information,
      = jmc$user_job_name =
        user_job_name: jmt$user_supplied_name,
      = jmc$vertical_print_density =
        vertical_print_density: jmt$vertical_print_density,
      = jmc$vfu_load_procedure =
        vfu_load_procedure: jmt$vfu_load_procedure,
      casend,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc jmt$attribute_keys
*copyc jmt$cpu_time_limit
*copyc jmt$date_time
*copyc jmt$destination_usage
*copyc jmt$external_characteristics
*copyc jmt$forms_code
*copyc jmt$job_abort_disposition
*copyc jmt$job_class_name
*copyc jmt$job_qualifier_list
*copyc jmt$job_recovery_disposition
*copyc jmt$magnetic_tape_limit
*copyc jmt$output_class_name
*copyc jmt$output_comment_banner
*copyc jmt$output_copy_count
*copyc jmt$output_device
*copyc jmt$output_disposition
*copyc jmt$output_priority
*copyc jmt$output_routing_banner
*copyc jmt$remote_host_directive
*copyc jmt$site_information
*copyc jmt$sru_limit
*copyc jmt$station
*copyc jmt$station_operator
*copyc jmt$time_increment
*copyc jmt$user_information
*copyc jmt$user_supplied_name
*copyc jmt$vertical_print_density
*copyc jmt$vfu_load_procedure
*copyc jmt$working_set_size
*copyc ost$name
*DECK DECK=JMT$INPUT_ATTRIBUTE_OPTIONS EXPAND=FALSE

  TYPE
    jmt$input_attribute_options = array [1 .. * ] of
          jmt$input_attribute_option;

  TYPE
    jmt$input_attribute_option = record
      case key: jmt$attribute_keys of
      = jmc$continue_request_to_servers =
        continue_request_to_servers: boolean,
      = jmc$control_family =
        control_family: ost$name,
      = jmc$control_user =
        control_user: ost$name,
      = jmc$job_deferred_by_operator =
        job_deferred_by_operator: boolean,
      = jmc$job_deferred_by_user =
        job_deferred_by_user: boolean,
      = jmc$job_state_set =
        job_state_set: jmt$job_state_set,
      = jmc$login_family =
        login_family: ost$name,
      = jmc$login_user =
        login_user: ost$name,
      = jmc$name_list =
        name_list: ^jmt$name_list,
      = jmc$null_attribute =
        ,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$name_list
*copyc jmt$job_state_set
*copyc ost$name
*DECK DECK=JMT$INPUT_ATTRIBUTE_RESULTS EXPAND=FALSE

  TYPE
    jmt$input_attribute_results = array [1 .. * ] of ^array [1 .. * ] of
          jmt$input_attribute_result;

  TYPE
    jmt$input_attribute_result = record
      case key: jmt$attribute_keys of
      = jmc$comment_banner =
        comment_banner: jmt$output_comment_banner,
      = jmc$control_family =
        control_family: ost$name,
      = jmc$control_user =
        control_user: ost$name,
      = jmc$copies =
        copies: jmt$output_copy_count,
      = jmc$cpu_time_limit =
        cpu_time_limit: jmt$cpu_time_limit,
      = jmc$data_mode =
        data_mode: jmt$data_mode,
      = jmc$device =
        device: jmt$output_device,
      = jmc$earliest_print_time =
        earliest_print_time: jmt$date_time,
      = jmc$earliest_run_time =
        earliest_run_time: jmt$date_time,
      = jmc$external_characteristics =
        external_characteristics: jmt$external_characteristics,
      = jmc$forms_code =
        forms_code: jmt$forms_code,
      = jmc$job_abort_disposition =
        job_abort_disposition: jmt$job_abort_disposition,
      = jmc$job_category_list =
        job_category_list: jmt$job_category_list,
      = jmc$job_class =
        job_class: jmt$job_class_name,
      = jmc$job_deferred_by_operator =
        job_deferred_by_operator: boolean,
      = jmc$job_deferred_by_user =
        job_deferred_by_user: boolean,
      = jmc$job_destination_family = { job_destination
        job_destination_family: ost$name,
      = jmc$job_destination_usage =
        job_destination_usage: jmt$destination_usage,
      = jmc$job_execution_ring =
        job_execution_ring: ost$ring,
      = jmc$job_mode =
        job_mode: jmt$job_mode,
      = jmc$job_qualifier_list =
        job_qualifier_list: ^jmt$job_qualifier_list,
      = jmc$job_recovery_disposition =
        job_recovery_disposition: jmt$job_recovery_disposition,
      = jmc$job_state =
        job_state: jmt$job_state,
      = jmc$job_size =
        job_size: jmt$job_size,
      = jmc$job_submission_time =
        job_submission_time: ost$date_time,
      = jmc$latest_print_time =
        latest_print_time: jmt$date_time,
      = jmc$latest_run_time =
        latest_run_time: jmt$date_time,
      = jmc$login_account =
        login_account: ost$name,
      = jmc$login_family =
        login_family: ost$name,
      = jmc$login_project =
        login_project: ost$name,
      = jmc$login_user =
        login_user: ost$name,
      = jmc$magnetic_tape_limit =
        magnetic_tape_limit: jmt$magnetic_tape_limit,
      = jmc$maximum_working_set =
        maximum_working_set: jmt$working_set_size,
      = jmc$null_attribute =
        ,
      = jmc$origin_application_name =
        origin_application_name: ost$name,
      = jmc$output_class =
        output_class: jmt$output_class_name,
      = jmc$output_deferred_by_user =
        output_deferred_by_user: boolean,
      = jmc$output_destination =
        output_destination: ost$name,
      = jmc$output_destination_family = { operator_family
        output_destination_family: ost$name,
      = jmc$output_destination_usage =
        output_destination_usage: jmt$destination_usage,
      = jmc$output_disposition =
        output_disposition: jmt$output_disposition,
      = jmc$output_priority =
        output_priority: jmt$output_priority,
      = jmc$purge_delay =
        purge_delay: ^jmt$time_increment,
      = jmc$remote_host_directive =
        remote_host_directive: ^jmt$remote_host_directive,
      = jmc$routing_banner =
        routing_banner: jmt$output_routing_banner,
      = jmc$site_information =
        site_information: ^jmt$site_information,
      = jmc$sru_limit =
        sru_limit: jmt$sru_limit,
      = jmc$station =
        station: jmt$station,
      = jmc$station_operator = { operator_user
        station_operator: jmt$station_operator,
      = jmc$system_job_name =
        system_job_name: jmt$system_supplied_name,
      = jmc$user_information =
        user_information: ^jmt$user_information,
      = jmc$user_job_name =
        user_job_name: jmt$user_supplied_name,
      = jmc$vertical_print_density =
        vertical_print_density: jmt$vertical_print_density,
      = jmc$vfu_load_procedure =
        vfu_load_procedure: jmt$vfu_load_procedure,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$cpu_time_limit
*copyc jmt$data_mode
*copyc jmt$date_time
*copyc jmt$destination_usage
*copyc jmt$external_characteristics
*copyc jmt$forms_code
*copyc jmt$job_abort_disposition
*copyc jmt$job_category_list
*copyc jmt$job_class_name
*copyc jmt$job_mode
*copyc jmt$job_qualifier_list
*copyc jmt$job_recovery_disposition
*copyc jmt$job_size
*copyc jmt$job_state
*copyc jmt$magnetic_tape_limit
*copyc jmt$output_class_name
*copyc jmt$output_comment_banner
*copyc jmt$output_copy_count
*copyc jmt$output_device
*copyc jmt$output_device_type
*copyc jmt$output_disposition
*copyc jmt$output_priority
*copyc jmt$output_routing_banner
*copyc jmt$remote_host_directive
*copyc jmt$site_information
*copyc jmt$sru_limit
*copyc jmt$station
*copyc jmt$station_operator
*copyc jmt$system_supplied_name
*copyc jmt$time_increment
*copyc jmt$user_information
*copyc jmt$user_supplied_name
*copyc jmt$vertical_print_density
*copyc jmt$vfu_load_procedure
*copyc jmt$working_set_size
*copyc osd$virtual_address
*copyc ost$date_time
*copyc ost$name
*DECK DECK=JMT$INPUT_DESCRIPTOR EXPAND=FALSE

  TYPE
    jmt$input_descriptor = record
      comment_banner: jmt$output_comment_banner,
      control_family: ost$name,
      control_user: ost$name,
      copies: jmt$output_copy_count,
      data_declaration: jmt$data_declaration,
      data_mode: jmt$data_mode,
      device: jmt$output_device,
      disposition_code: jmt$disposition_code,
      earliest_run_time: jmt$date_time,
      earliest_print_time: jmt$date_time,
      external_characteristics: jmt$external_characteristics,
      forms_code: jmt$forms_code,
      implicit_routing_text: jmt$implicit_routing_text,
      job_class: jmt$job_class_name,
      job_destination_family: ost$name, { job_destination
      job_destination_usage: jmt$destination_usage,
      job_execution_ring: ost$ring,
      job_input_device: jmt$job_input_device,
      job_size: jmt$job_size,
      job_submission_time: ost$date_time,
      latest_run_time: jmt$date_time,
      latest_print_time: jmt$date_time,
      login_account: avt$account_name,
      login_command_supplied: boolean,
      login_family: ost$name,
      login_project: avt$project_name,
      login_user: ost$name,
      originating_application_name: ost$name,
      originating_login_account: avt$account_name,
      originating_login_family: ost$name,
      originating_login_project: avt$project_name,
      originating_login_user: ost$name,
      originating_system_job_name: jmt$system_supplied_name,
      output_class: jmt$output_class_name,
      output_destination: ost$name,
      output_destination_family: ost$name, { operator_family
      output_destination_usage: jmt$destination_usage,
      output_disposition: jmt$output_disposition,
      output_priority: jmt$output_priority,
      purge_delay: jmt$time_increment,
      remote_host_directive: jmt$remote_host_directive,
      routing_banner: jmt$output_routing_banner,
      source_logical_id: jmt$source_logical_id,
      site_information: jmt$site_information,
      station: jmt$station,
      station_operator: jmt$station_operator, { operator_user
      system_job_name: jmt$system_supplied_name,
      system_job_parameters: jmt$system_job_parameters,
      system_routing_text: jmt$system_routing_text,
      user_information: jmt$user_information,
      user_job_name: jmt$user_supplied_name,
      vertical_print_density: jmt$vertical_print_density,
      vfu_load_procedure: jmt$vfu_load_procedure,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc jmt$data_declaration
*copyc jmt$data_mode
*copyc jmt$date_time
*copyc jmt$destination_usage
*copyc jmt$disposition_code
*copyc jmt$external_characteristics
*copyc jmt$forms_code
*copyc jmt$implicit_routing_text
*copyc jmt$job_class_name
*copyc jmt$job_input_device
*copyc jmt$job_size
*copyc jmt$output_class_name
*copyc jmt$output_comment_banner
*copyc jmt$output_copy_count
*copyc jmt$output_device
*copyc jmt$output_disposition
*copyc jmt$output_priority
*copyc jmt$output_routing_banner
*copyc jmt$remote_host_directive
*copyc jmt$site_information
*copyc jmt$source_logical_id
*copyc jmt$station
*copyc jmt$station_operator
*copyc jmt$system_job_parameters
*copyc jmt$system_routing_text
*copyc jmt$system_supplied_name
*copyc jmt$time_increment
*copyc jmt$user_information
*copyc jmt$user_supplied_name
*copyc jmt$vertical_print_density
*copyc jmt$vfu_load_procedure
*copyc osd$virtual_address
*copyc ost$date_time
*copyc ost$name
*DECK DECK=JMT$INPUT_FILE_LOCATION EXPAND=FALSE

  TYPE
    jmt$input_file_location = 0 .. 255;

  CONST
    jmc$ifl_no_input_file_exists = 0,
    jmc$ifl_system_input_queue = 1,
    jmc$ifl_store_and_forward_queue = 2,
    jmc$ifl_login_family_queue = 3;
*DECK DECK=JMT$INPUT_FILE_STATISTIC_DATA EXPAND=FALSE

  TYPE
    jmt$input_file_statistic_data = record
      job_input_device: jmt$job_input_device,
      job_system_label_p: ^cell,
    recend;

*copyc jmt$job_input_device
*DECK DECK=JMT$INTERACTIVE_JOB_INFO EXPAND=FALSE

  TYPE
    jmt$interactive_job_info = record
      assigned_job_class: jmt$job_class_name,
      comment_banner: jmt$output_comment_banner,
      copy_count: jmt$output_copy_count,
      cpu_time_limit_specified: boolean,
      cpu_time_limit_requested: jmt$cpu_time_limit,
      cpu_time_limit_assigned: jmt$cpu_time_limit,
      device: jmt$output_device,
      earliest_print_time: jmt$date_time,
      external_characteristics: jmt$external_characteristics,
      forms_code: jmt$forms_code,
      job_abort_disposition: jmt$job_abort_disposition,
      job_category_set: jmt$job_category_set,
      job_class_name: jmt$job_class_name,
      job_destination_family: ost$name,
      job_destination_usage: jmt$destination_usage,
      job_execution_ring: ost$ring,
      job_input_device: jmt$job_input_device,
      job_mode: jmt$job_mode,
      job_priority: jmt$job_priority_name,
      job_qualifier_list: array [1 .. jmc$maximum_job_qualifiers] of ost$name,
      job_recovery_disposition: jmt$job_recovery_disposition,
      latest_print_time: jmt$date_time,
      sru_limit_specified: boolean,
      sru_limit_requested: jmt$sru_limit,
      sru_limit_assigned: jmt$sru_limit,
      login_account: avt$account_name,
      login_project: avt$project_name,
      login_user_identification: ost$user_identification,
      magnetic_tape_limit_specified: boolean,
      magnetic_tape_limit_requested: jmt$magnetic_tape_limit,
      magnetic_tape_limit_assigned: jmt$magnetic_tape_limit,
      maximum_working_set_specified: boolean,
      maximum_working_set_requested: jmt$working_set_size,
      maximum_working_set_assigned: jmt$working_set_size,
      operator_family: ost$name,
      operator_user: jmt$station_operator,
      originating_application_name: ost$name,
      output_deferred_by_user: boolean,
      output_destination: ost$name,
      output_destination_usage: jmt$destination_usage,
      output_disposition_key: jmt$output_disposition_keys,
      output_disposition_path: fst$path,
      perform_class_validation: boolean,
      purge_delay: jmt$time_increment,
      remote_host_directive: jmt$remote_host_directive,
      routing_banner: jmt$output_routing_banner,
      station: jmt$station,
      system_job_name: jmt$system_supplied_name,
      user_information: jmt$user_information,
      user_job_name: jmt$user_supplied_name,
      vertical_print_density: jmt$vertical_print_density,
      vfu_load_procedure: jmt$vfu_load_procedure,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc fst$path
*copyc jmt$cpu_time_limit
*copyc jmt$date_time
*copyc jmt$destination_usage
*copyc jmt$external_characteristics
*copyc jmt$forms_code
*copyc jmt$job_abort_disposition
*copyc jmt$job_category_set
*copyc jmt$job_class_name
*copyc jmt$job_input_device
*copyc jmt$job_mode
*copyc jmt$job_priority_name
*copyc jmt$job_qualifier_list
*copyc jmt$job_recovery_disposition
*copyc jmt$magnetic_tape_limit
*copyc jmt$output_comment_banner
*copyc jmt$output_copy_count
*copyc jmt$output_device
*copyc jmt$output_disposition
*copyc jmt$output_routing_banner
*copyc jmt$remote_host_directive
*copyc jmt$sru_limit
*copyc jmt$station
*copyc jmt$station_operator
*copyc jmt$system_supplied_name
*copyc jmt$time_increment
*copyc jmt$user_information
*copyc jmt$user_supplied_name
*copyc jmt$vertical_print_density
*copyc jmt$vfu_load_procedure
*copyc jmt$working_set_size
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$user_identification


*DECK DECK=JMT$JH_DESCRIPTIVE_DATA EXPAND=FALSE

  CONST

{ jml$job_queuing_started

    jmc$jqs_system_job_name = 1,
    jmc$jqs_user_job_name = 2,
    jmc$jqs_login_family = 3,
    jmc$jqs_login_user = 4,
    jmc$jqs_control_family = 5,
    jmc$jqs_control_user = 6,
    jmc$jqs_station = 7,
    jmc$jqs_reason = 8,
    jmc$jqs_parent_job_name = 9,
    jmc$jqs_max_desc_data_fields = jmc$jqs_parent_job_name,

{ jml$job_queuing_aborted

    jmc$jqa_system_job_name = 1,
    jmc$jqa_reason = 2,
    jmc$jqa_max_desc_data_fields = jmc$jqa_reason,

{ jml$output_queuing_started

    jmc$oqs_system_job_name = 1,
    jmc$oqs_login_family = 2,
    jmc$oqs_login_user = 3,
    jmc$oqs_system_file_name = 4,
    jmc$oqs_control_family = 5,
    jmc$oqs_control_user = 6,
    jmc$oqs_station = 7,
    jmc$oqs_reason = 8,
    jmc$oqs_max_desc_data_fields = jmc$oqs_reason,

{ jml$output_queuing_aborted

    jmc$oqa_system_job_name = 1,
    jmc$oqa_system_file_name = 2,
    jmc$oqa_reason = 3,
    jmc$oqa_max_desc_data_fields = jmc$oqa_reason,

{ jml$job_forwarding_started

    jmc$jfs_system_job_name = 1,
    jmc$jfs_max_desc_data_fields = jmc$jfs_system_job_name,

{ jml$output_forwarding_started

    jmc$ofs_system_job_name = 1,
    jmc$ofs_system_file_name = 2,
    jmc$ofs_application_name = 3,
    jmc$ofs_max_desc_data_fields = jmc$ofs_application_name,

{ jml$job_initiated

    jmc$ji_system_job_name = 1,
    jmc$ji_max_desc_data_fields = jmc$ji_system_job_name,

{ jml$job_terminated

    jmc$jt_system_job_name = 1,
    jmc$jt_system_file_name = 2,
    jmc$jt_output_disposition = 3,
    jmc$jt_reason = 4,
    jmc$jt_max_desc_data_fields = jmc$jt_reason,

{ jml$print_plot_initiated

    jmc$ppi_system_job_name = 1,
    jmc$ppi_system_file_name = 2,
    jmc$ppi_application_name = 3,
    jmc$ppi_max_desc_data_fields = jmc$ppi_application_name,

{ jml$print_plot_terminated

    jmc$ppt_system_job_name = 1,
    jmc$ppt_system_file_name = 2,
    jmc$ppt_max_desc_data_fields = jmc$ppt_system_file_name,

{ jml$submit_job_executed

    jmc$sje_system_job_name = 1,
    jmc$sje_job_destination = 2,
    jmc$sje_job_destination_usage = 3,
    jmc$sje_user_job_name = 4,
    jmc$sje_max_desc_data_fields = jmc$sje_user_job_name,

{ jml$print_plot_file_executed

    jmc$ppfe_system_job_name = 1,
    jmc$ppfe_system_file_name = 2,
    jmc$ppfe_output_destination = 3,
    jmc$ppfe_output_dest_usage = 4,
    jmc$ppfe_user_file_name = 5,
    jmc$ppfe_max_desc_data_fields = jmc$ppfe_user_file_name,

{ jml$job_history_message

    jmc$jhm_system_job_name = 1,
    jmc$jhm_message = 2,
    jmc$jhm_max_desc_data_fields = jmc$jhm_message,

{ jml$non_recovery_of_job

    jmc$nroj_system_job_name = 1,
    jmc$nroj_reason = 2,
    jmc$nroj_max_desc_data_fields = jmc$nroj_reason,

{ jml$change_output_attributes

    jmc$coa_system_job_name = 1,
    jmc$coa_system_file_name = 2,
    jmc$coa_control_family = 3,
    jmc$coa_control_user = 4,
    jmc$coa_output_destination = 5,
    jmc$coa_output_dest_usage = 6,
    jmc$coa_station = 7,
    jmc$coa_max_desc_data_fields = jmc$coa_station,

{ jml$job_file_deleted

    jmc$jfd_system_job_name = 1,
    jmc$jfd_reason = 2,
    jmc$jfd_max_desc_data_fields = jmc$jfd_reason,

{ jml$output_file_deleted

    jmc$ofd_system_job_name = 1,
    jmc$ofd_system_file_name = 2,
    jmc$ofd_reason = 3,
    jmc$ofd_max_desc_data_fields = jmc$ofd_reason;

*DECK DECK=JMT$JL_ASSIGNED_JOB_LIST EXPAND=FALSE

  TYPE
    jmt$jl_assigned_job_list = array [1 .. * ] of jmt$jl_assigned_job;

  TYPE
    jmt$jl_assigned_job = record
      system_job_name: jmt$system_supplied_name,
      user_job_name: jmt$user_supplied_name,
      login_user_identification: ost$user_identification,
      control_user_identification: ost$user_identification,
      originating_ssn: jmt$system_supplied_name,
      job_submission_time: jmt$clock_time,
      latest_clock_time_to_initiate: jmt$clock_time,
      job_class: jmt$job_class,
      job_category_set: jmt$job_category_set,
      output_disposition_key: jmt$output_disposition_keys,
      server_kjl_index: jmt$kjl_index,
    recend;

*copyc jmt$clock_time
*copyc jmt$job_category_set
*copyc jmt$job_class
*copyc jmt$kjl_index
*copyc jmt$output_disposition_keys
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc ost$user_identification
*DECK DECK=JMT$JL_JOB_CLASS_DATA EXPAND=FALSE

  TYPE
    jmt$jl_job_class_data = array [jmt$job_class] of jmt$jl_class_counts;

  TYPE
    jmt$jl_class_counts = record
      termination_count: jmt$job_count_range,
      room_in_class: jmt$maximum_initiated_jobs,
      class_maximum: jmt$maximum_initiated_jobs,
    recend;

*copyc jmt$job_class
*copyc jmt$job_count_range
*copyc jmt$maximum_initiated_jobs
*DECK DECK=JMT$JL_JOB_CLASS_PRIORITIES EXPAND=FALSE

  TYPE
    jmt$jl_job_class_priorities = array [jmt$job_class] of
          jmt$jl_job_class_priority;

  TYPE
    jmt$jl_job_class_priority = record
      job_priority: jmt$job_priority,
      based_on_selection_priority: boolean,
    recend;

*copyc jmt$job_class
*copyc jmt$job_priority
*DECK DECK=JMT$JL_JOB_LEVELER_STATUS EXPAND=FALSE

  TYPE
    jmt$jl_job_leveler_status = record
      leveler_state: jmt$jl_job_leveler_state,
      cleanup_completed: boolean,
    recend;

  TYPE
    jmt$jl_job_leveler_state = (jmc$jl_leveler_disabled,
          jmc$jl_leveler_enabled, jmc$jl_server_profile_mismatch);

*DECK DECK=JMT$JL_LEVELER_SERVER_REQUEST EXPAND=FALSE

  TYPE
    jmt$jl_leveler_server_request = record
      case request_kind: jmt$jl_request_kind of
      = jmc$jl_signon_request =
        signon_request: jmt$jl_signon_request,
      = jmc$jl_normal_request =
        normal_request: jmt$jl_normal_request,
      = jmc$jl_unassign_jobs_request =
        unassign_jobs_request: jmt$jl_unassign_jobs_request,
      = jmc$jl_signoff_request =
        signoff_request: jmt$jl_signoff_request,
      = jmc$jl_ready_levelers_request =
        ,
      casend,
    recend;

  TYPE
    jmt$jl_signon_request = record
      server_job_list_p: ^jmt$jl_server_job_list,
      restart_job_list_p: ^jmt$jl_restart_job_list,
    recend;

  TYPE
    jmt$jl_normal_request = record
      active_profile_id: ost$name,
      initiation_required_categories: jmt$job_category_set,
      initiation_excluded_categories: jmt$job_category_set,
      leveler_job_class_data: jmt$jl_job_class_data,
      job_class_priorities: jmt$jl_job_class_priorities,
      unassigned_job_list_p: ^jmt$jl_unassigned_job_list,
      assigned_job_list_p: ^jmt$jl_assigned_job_list,
      assigned_job_count: jmt$job_count_range,
      server_job_priorities: jmt$jl_server_job_priorities,
      profile_mismatch: boolean,
      job_leveling_enabled: boolean,
    recend;

  TYPE
    jmt$jl_unassign_jobs_request = record
      unassigned_job_list_p: ^jmt$jl_unassigned_job_list,
    recend;

  TYPE
    jmt$jl_signoff_request = record
      unassigned_job_list_p: ^jmt$jl_unassigned_job_list,
    recend;

*copyc jmt$jl_assigned_job_list
*copyc jmt$jl_job_class_data
*copyc jmt$jl_job_class_priorities
*copyc jmt$jl_request_kind
*copyc jmt$jl_restart_job_list
*copyc jmt$jl_server_job_list
*copyc jmt$jl_server_job_priorities
*copyc jmt$jl_unassigned_job_list
*copyc jmt$job_category_set
*copyc jmt$job_count_range
*copyc ost$name
*DECK DECK=JMT$JL_MISSING_JOB_LIST EXPAND=FALSE

  TYPE
    jmt$jl_missing_job_list = array [1 .. * ] of jmt$jl_missing_job_list_entry;

  TYPE
    jmt$jl_missing_job_list_entry = record
      system_job_name: jmt$system_supplied_name,
      login_family: ost$name,
    recend;

*copyc jmt$system_supplied_name
*copyc ost$name
*DECK DECK=JMT$JL_REQUEST_KIND EXPAND=FALSE

  TYPE
    jmt$jl_request_kind = (jmc$jl_signon_request, jmc$jl_normal_request,
          jmc$jl_unassign_jobs_request, jmc$jl_signoff_request,
          jmc$jl_ready_levelers_request);
*DECK DECK=JMT$JL_RESTART_FILE_VERSION EXPAND=FALSE

  TYPE
    jmt$jl_restart_file_version = (jmc$jl_rfv_version_0, jmc$jl_rfv_version_1);

*DECK DECK=JMT$JL_RESTART_JOB_LIST EXPAND=FALSE

  TYPE
    jmt$jl_restart_job_list = array [1 .. * ] of jmt$jl_restart_job;

  TYPE
    jmt$jl_restart_job = record
      system_job_name: jmt$system_supplied_name,
      recover_using_abort_disposition: boolean,
    recend;

*copyc jmt$system_supplied_name
*DECK DECK=JMT$JL_SCHEDULING_DATA EXPAND=FALSE

  TYPE
    jmt$jl_scheduling_data = record
      job_leveling_interval: jmt$service_interval, { seconds
      profile_identification: ost$name,
      initiation_required_categories: jmt$job_category_set,
      initiation_excluded_categories: jmt$job_category_set,
      job_leveling_enabled: boolean,
      profile_loading_in_progress: boolean,
    recend;

*copyc jmt$job_category_set
*copyc jmt$service_interval
*copyc ost$name
*DECK DECK=JMT$JL_SERVER_JOB_END_INFO EXPAND=FALSE

  TYPE
    jmt$jl_server_job_end_info = record
      client_mainframe_id: pmt$binary_mainframe_id,
      server_mainframe_id: pmt$binary_mainframe_id,
      system_job_name: jmt$system_supplied_name,
      server_kjl_index: jmt$kjl_index,
      job_requests_restart: boolean,
    recend;

*copyc jmt$kjl_index
*copyc jmt$system_supplied_name
*copyc pmt$binary_mainframe_id
*DECK DECK=JMT$JL_SERVER_JOB_LIST EXPAND=FALSE

  TYPE
    jmt$jl_server_job_list = array [1 .. * ] of jmt$jl_server_job;

  TYPE
    jmt$jl_server_job = record
      system_job_name: jmt$system_supplied_name,
      kjl_entry_kind: jmt$kjl_entry_kind,
      server_kjl_index: jmt$kjl_index,
    recend;

*copyc jmt$kjl_entry_kind
*copyc jmt$kjl_index
*copyc jmt$system_supplied_name

*DECK DECK=JMT$JL_SERVER_JOB_PRIORITIES EXPAND=FALSE

  TYPE
    jmt$jl_server_job_priorities = array [jmt$job_class] of jmt$job_priority;

*copyc jmt$job_class
*copyc jmt$job_priority
*DECK DECK=JMT$JL_UNASSIGNED_JOB_LIST EXPAND=FALSE

  TYPE
    jmt$jl_unassigned_job_list = array [1 .. * ] of jmt$jl_unassigned_job;

  TYPE
    jmt$jl_unassigned_job = record
      system_job_name: jmt$system_supplied_name,
      server_kjl_index: jmt$kjl_index,
    recend;

*copyc jmt$kjl_index
*copyc jmt$system_supplied_name
*DECK DECK=JMT$JOB_ABORT_DISPOSITION EXPAND=FALSE

  TYPE
    jmt$job_abort_disposition = (jmc$restart_on_abort, jmc$terminate_on_abort);
*DECK DECK=JMT$JOB_ATTRIBUTES EXPAND=FALSE

  TYPE
    jmt$job_attributes = record
      comment_banner: jmt$output_comment_banner,
      copy_count: jmt$output_copy_count,
      device: jmt$output_device,
      earliest_run_time: jmt$date_time,
      earliest_print_time: jmt$date_time,
      external_characteristics: jmt$external_characteristics,
      forms_code: jmt$forms_code,
      implicit_routing_text: jmt$implicit_routing_text,
      job_controller: ost$user_identification,
      job_initiation_time: ost$date_time,
      job_input_device: jmt$job_input_device,
      job_qualifier_list: array [1 .. jmc$maximum_job_qualifiers] of ost$name,
      job_size: jmt$job_size,
      job_submission_time: ost$date_time,
      latest_run_time: jmt$date_time,
      latest_print_time: jmt$date_time,
      login_command_supplied: boolean,
      originating_application_name: ost$name,
      originating_ssn: jmt$system_supplied_name,
      output_class: jmt$output_class_name,
      output_deferred_by_user: boolean,
      output_destination: ost$name,
      output_destination_family: ost$name, { operator_family
      output_destination_usage: jmt$destination_usage,
      output_disposition_key: jmt$output_disposition_keys,
      output_disposition_path: fst$path,
      output_priority: jmt$output_priority,
      process_user_prolog_and_epilog: boolean,
      purge_delay: jmt$time_increment,
      remote_host_directive: jmt$remote_host_directive,
      routing_banner: jmt$output_routing_banner,
      source_logical_id: jmt$source_logical_id,
      site_information: jmt$site_information,
      station: jmt$station,
      station_operator: jmt$station_operator, { operator_user
      system_job_parameters: jmt$system_job_parameters,
      system_routing_text: jmt$system_routing_text,
      user_information: jmt$user_information,
      vertical_print_density: jmt$vertical_print_density,
      vfu_load_procedure: jmt$vfu_load_procedure,
    recend;

*copyc fst$path
*copyc jmt$date_time
*copyc jmt$destination_usage
*copyc jmt$external_characteristics
*copyc jmt$forms_code
*copyc jmt$implicit_routing_text
*copyc jmt$job_input_device
*copyc jmt$job_qualifier_list
*copyc jmt$job_size
*copyc jmt$output_class_name
*copyc jmt$output_comment_banner
*copyc jmt$output_copy_count
*copyc jmt$output_device
*copyc jmt$output_disposition
*copyc jmt$output_priority
*copyc jmt$output_routing_banner
*copyc jmt$remote_host_directive
*copyc jmt$site_information
*copyc jmt$source_logical_id
*copyc jmt$station
*copyc jmt$station_operator
*copyc jmt$system_job_parameters
*copyc jmt$system_routing_text
*copyc jmt$system_supplied_name
*copyc jmt$time_increment
*copyc jmt$user_information
*copyc jmt$vertical_print_density
*copyc jmt$vfu_load_procedure
*copyc ost$date_time
*copyc ost$name
*copyc ost$user_identification
*DECK DECK=JMT$JOB_ATTRIBUTE_CHANGES EXPAND=FALSE

  TYPE
    jmt$job_attribute_changes = array [1 .. * ] of jmt$job_attribute_change;

  TYPE
    jmt$job_attribute_change = record
      case key: jmt$attribute_keys of
      = jmc$comment_banner =
        comment_banner: jmt$output_comment_banner,
      = jmc$copies =
        copies: jmt$output_copy_count,
      = jmc$cyclic_aging_interval =
        cyclic_aging_interval: jmt$aging_interval,
      = jmc$detached_job_wait_time =
        detached_job_wait_time: jmt$detached_job_wait_time,
      = jmc$device =
        device: jmt$output_device,
      = jmc$dispatching_priority =
        dispatching_priority: ost$name,
      = jmc$earliest_print_time =
        earliest_print_time: jmt$date_time,
      = jmc$external_characteristics =
        external_characteristics: jmt$external_characteristics,
      = jmc$forms_code =
        forms_code: jmt$forms_code,
      = jmc$job_abort_disposition =
        job_abort_disposition: jmt$job_abort_disposition,
      = jmc$job_recovery_disposition =
        job_recovery_disposition: jmt$job_recovery_disposition,
      = jmc$latest_print_time =
        latest_print_time: jmt$date_time,
      = jmc$maximum_working_set =
        maximum_working_set: jmt$working_set_size,
      = jmc$minimum_working_set =
        minimum_working_set: jmt$working_set_size,
      = jmc$null_attribute =
        ,
      = jmc$output_class =
        output_class: jmt$output_class_name,
      = jmc$output_deferred_by_user =
        output_deferred_by_user: boolean,
      = jmc$output_destination =
        output_destination: ost$name,
      = jmc$output_destination_family =
        output_destination_family: ost$name,
      = jmc$output_destination_usage =
        output_destination_usage: jmt$destination_usage,
      = jmc$output_disposition =
        output_disposition: jmt$output_disposition,
      = jmc$output_priority =
        output_priority: jmt$output_priority,
      = jmc$page_aging_interval =
        page_aging_interval: jmt$aging_interval,
      = jmc$purge_delay =
        purge_delay: ^jmt$time_increment,
      = jmc$remote_host_directive =
        remote_host_directive: ^jmt$remote_host_directive,
      = jmc$routing_banner =
        routing_banner: jmt$output_routing_banner,
      = jmc$site_information =
        site_information: ^jmt$site_information,
      = jmc$station =
        station: jmt$station,
      = jmc$station_operator =
        station_operator: jmt$station_operator,
      = jmc$user_information =
        user_information: ^jmt$user_information,
      = jmc$vertical_print_density =
        vertical_print_density: jmt$vertical_print_density,
      = jmc$vfu_load_procedure =
        vfu_load_procedure: jmt$vfu_load_procedure,
      casend,
    recend;

*copyc jmt$aging_interval
*copyc jmt$attribute_keys
*copyc jmt$date_time
*copyc jmt$destination_usage
*copyc jmt$detached_job_wait_time
*copyc jmt$external_characteristics
*copyc jmt$forms_code
*copyc jmt$job_abort_disposition
*copyc jmt$job_recovery_disposition
*copyc jmt$output_class_name
*copyc jmt$output_comment_banner
*copyc jmt$output_copy_count
*copyc jmt$output_device
*copyc jmt$output_disposition
*copyc jmt$output_priority
*copyc jmt$output_routing_banner
*copyc jmt$remote_host_directive
*copyc jmt$site_information
*copyc jmt$station
*copyc jmt$station_operator
*copyc jmt$time_increment
*copyc jmt$user_information
*copyc jmt$working_set_size
*copyc jmt$vertical_print_density
*copyc jmt$vfu_load_procedure
*copyc ost$name
*DECK DECK=JMT$JOB_ATTRIBUTE_RESULTS EXPAND=FALSE

  TYPE
    jmt$job_attribute_results = array [1 .. * ] of jmt$job_attribute_result;

  TYPE
    jmt$job_attribute_result = record
      case key: jmt$attribute_keys of
      = jmc$c170_os_type =
        c170_os_type: ost$170_os_type,
      = jmc$comment_banner =
        comment_banner: jmt$output_comment_banner,
      = jmc$control_family =
        control_family: ost$name,
      = jmc$control_user =
        control_user: ost$name,
      = jmc$copies =
        copies: jmt$output_copy_count,
      = jmc$cyclic_aging_interval =
        cyclic_aging_interval: jmt$aging_interval,
      = jmc$detached_job_wait_time =
        detached_job_wait_time: jmt$detached_job_wait_time,
      = jmc$device =
        device: jmt$output_device,
      = jmc$dispatching_priority =
        dispatching_priority: ost$name,
      = jmc$earliest_print_time =
        earliest_print_time: jmt$date_time,
      = jmc$earliest_run_time =
        earliest_run_time: jmt$date_time,
      = jmc$external_characteristics =
        external_characteristics: jmt$external_characteristics,
      = jmc$forms_code =
        forms_code: jmt$forms_code,
      = jmc$job_abort_disposition =
        job_abort_disposition: jmt$job_abort_disposition,
      = jmc$job_recovery_disposition =
        job_recovery_disposition: jmt$job_recovery_disposition,
      = jmc$job_class =
        job_class: jmt$job_class_name,
      = jmc$job_input_device =
        job_input_device: ^jmt$job_input_device,
      = jmc$job_mode =
        job_mode: jmt$job_mode,
      = jmc$job_qualifier_list =
        job_qualifier_list: ^jmt$job_qualifier_list,
      = jmc$job_size =
        job_size: jmt$job_size,
      = jmc$job_submission_time =
        job_submission_time: ost$date_time,
      = jmc$latest_print_time =
        latest_print_time: jmt$date_time,
      = jmc$latest_run_time =
        latest_run_time: jmt$date_time,
      = jmc$login_account =
        login_account: avt$account_name,
      = jmc$login_family =
        login_family: ost$name,
      = jmc$login_project =
        login_project: avt$project_name,
      = jmc$login_user =
        login_user: ost$name,
      = jmc$maximum_working_set =
        maximum_working_set: jmt$working_set_size,
      = jmc$minimum_working_set =
        minimum_working_set: jmt$working_set_size,
      = jmc$null_attribute =
        ,
      = jmc$operator_job =
        operator_job: boolean,
      = jmc$origin_application_name =
        origin_application_name: ost$name,
      = jmc$os_version =
        os_version: pmt$os_name,
      = jmc$output_class =
        output_class: jmt$output_class_name,
      = jmc$output_deferred_by_user =
        output_deferred_by_user: boolean,
      = jmc$output_destination =
        output_destination: ost$name,
      = jmc$output_destination_family = { operator_family
        output_destination_family: ost$name,
      = jmc$output_destination_usage =
        output_destination_usage: jmt$destination_usage,
      = jmc$output_disposition =
        output_disposition: jmt$output_disposition,
      = jmc$output_priority =
        output_priority: jmt$output_priority,
      = jmc$page_aging_interval =
        page_aging_interval: jmt$aging_interval,
      = jmc$processing_phase =
        processing_phase: jmt$job_processing_phase,
      = jmc$purge_delay =
        purge_delay: ^jmt$time_increment,
      = jmc$remote_host_directive =
        remote_host_directive: ^jmt$remote_host_directive,
      = jmc$routing_banner =
        routing_banner: jmt$output_routing_banner,
      = jmc$sense_switches =
        sense_switches: pmt$sense_switches,
      = jmc$service_class =
        service_class: jmt$service_class_name,
      = jmc$site_information =
        site_information: ^jmt$site_information,
      = jmc$station =
        station: jmt$station,
      = jmc$station_operator = { operator_user
        station_operator: jmt$station_operator,
      = jmc$system_job =
        system_job: boolean,
      = jmc$system_job_name =
        system_job_name: jmt$system_supplied_name,
      = jmc$user_information =
        user_information: ^jmt$user_information,
      = jmc$user_job_name =
        user_job_name: jmt$user_supplied_name,
      = jmc$vertical_print_density =
        vertical_print_density: jmt$vertical_print_density,
      = jmc$vfu_load_procedure =
        vfu_load_procedure: jmt$vfu_load_procedure,
      casend,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc jmt$aging_interval
*copyc jmt$attribute_keys
*copyc jmt$date_time
*copyc jmt$destination_usage
*copyc jmt$detached_job_wait_time
*copyc jmt$forms_code
*copyc jmt$external_characteristics
*copyc jmt$job_abort_disposition
*copyc jmt$job_class_name
*copyc jmt$job_input_device
*copyc jmt$job_mode
*copyc jmt$job_processing_phase
*copyc jmt$job_qualifier_list
*copyc jmt$job_recovery_disposition
*copyc jmt$job_size
*copyc jmt$job_state
*copyc jmt$output_class_name
*copyc jmt$output_comment_banner
*copyc jmt$output_copy_count
*copyc jmt$output_device
*copyc jmt$output_disposition
*copyc jmt$output_priority
*copyc jmt$output_routing_banner
*copyc jmt$remote_host_directive
*copyc jmt$service_class_name
*copyc jmt$site_information
*copyc jmt$station
*copyc jmt$station_operator
*copyc jmt$system_supplied_name
*copyc jmt$time_increment
*copyc jmt$user_information
*copyc jmt$user_supplied_name
*copyc jmt$vertical_print_density
*copyc jmt$vfu_load_procedure
*copyc jmt$working_set_size
*copyc ost$170_os_type
*copyc ost$date_time
*copyc ost$name
*copyc pmt$os_name
*copyc pmt$sense_switches
*DECK DECK=JMT$JOB_CATEGORIZATION_OPTIONS EXPAND=FALSE

  TYPE
    jmt$job_categorization_options = array [1 .. * ] of jmt$job_categorization_option;

  TYPE
    jmt$job_categorization_option = record
      case key: jmt$attribute_keys of
      = jmc$cpu_time_limit =
        cpu_time_limit: jmt$cpu_time_limit,
      = jmc$job_class_list =
        job_class_list: ^jmt$job_class_list,
      = jmc$job_mode =
        job_mode: jmt$job_mode,
      = jmc$job_qualifier_list =
        job_qualifier_list: ^jmt$job_qualifier_list,
      = jmc$login_account =
        login_account: avt$account_name,
      = jmc$login_family =
        login_family: ost$name,
      = jmc$login_project =
        login_project: avt$project_name,
      = jmc$login_user =
        login_user: ost$name,
      = jmc$magnetic_tape_limit =
        magnetic_tape_limit: jmt$magnetic_tape_limit,
      = jmc$maximum_working_set =
        maximum_working_set: jmt$working_set_size,
      = jmc$null_attribute =
        ,
      = jmc$origin_application_name =
        origin_application_name: ost$name,
      = jmc$sru_limit =
        sru_limit: jmt$sru_limit,
      casend,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc jmt$attribute_keys
*copyc jmt$cpu_time_limit
*copyc jmt$job_class_list
*copyc jmt$job_mode
*copyc jmt$job_qualifier_list
*copyc jmt$magnetic_tape_limit
*copyc jmt$sru_limit
*copyc jmt$working_set_size
*copyc ost$name
*DECK DECK=JMT$JOB_CATEGORIZATION_RESULTS EXPAND=FALSE

  TYPE
    jmt$job_categorization_results = array [1 .. *] of jmt$job_categorization_result;

  TYPE
    jmt$job_categorization_result = record
      case key: jmt$attribute_keys of
      = jmc$cpu_time_limit =
        cpu_time_limit: jmt$cpu_time_limit,
      = jmc$job_category_set =
        job_category_set: jmt$job_category_set,
      = jmc$job_class =
        job_class: jmt$job_class_name,
      = jmc$magnetic_tape_limit =
        magnetic_tape_limit: jmt$magnetic_tape_limit,
      = jmc$maximum_working_set =
        maximum_working_set: jmt$working_set_size,
      = jmc$null_attribute =
        ,
      = jmc$sru_limit =
        sru_limit: jmt$sru_limit,
      casend,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc jmt$attribute_keys
*copyc jmt$cpu_time_limit
*copyc jmt$job_category_set
*copyc jmt$job_class_name
*copyc jmt$job_mode
*copyc jmt$job_qualifier_list
*copyc jmt$magnetic_tape_limit
*copyc jmt$sru_limit
*copyc jmt$working_set_size
*copyc ost$name

*DECK DECK=JMT$JOB_CATEGORY EXPAND=FALSE

  TYPE
    jmt$job_category = 0 .. jmc$maximum_job_categories;

  CONST
    jmc$maximum_job_categories = 63,
    jmc$number_of_job_categories = jmc$maximum_job_categories + 1;
*DECK DECK=JMT$JOB_CATEGORY_DATA EXPAND=FALSE

  TYPE
    jmt$job_category_data = record
      item_list: ^jmt$job_category_item_list,
      initial_set_values: jmt$job_category_set_list,
      category_names: ^jmt$job_category_name_list,
    recend;

  TYPE
    jmt$job_category_item_list = SEQ ( * ),
    jmt$job_category_set_list = array [jmt$job_category_item_kind] of
          jmt$job_category_set,
    jmt$job_category_name_list = array [0 .. * ] of record
      name: ost$name,
      definition_name: ost$name,
    recend;

  TYPE
    jmt$job_category_item = record
      categories: jmt$job_category_set,
      skip_item: jmt$job_category_reference,
      next_item: jmt$job_category_reference,
      case kind: jmt$job_category_item_kind of
      = jmc$ca_cpu_time_limit, jmc$ca_sru_time_limit, jmc$ca_mag_tape_limit,
            jmc$ca_working_set =
        number: integer,
      = jmc$ca_login_account, jmc$ca_login_project, jmc$ca_login_family,
            jmc$ca_login_user, jmc$ca_user_job_name,
            jmc$ca_orig_application_name, jmc$ca_job_mode,
            jmc$ca_job_qualifier =
        name: ost$name,
      = jmc$ca_or_conditions =
        members: jmt$job_category_set,
      casend,
    recend;

  TYPE
    jmt$job_category_item_kind = (jmc$ca_cpu_time_limit, jmc$ca_sru_time_limit,
          jmc$ca_mag_tape_limit, jmc$ca_working_set, jmc$ca_login_account,
          jmc$ca_login_project, jmc$ca_login_family, jmc$ca_login_user,
          jmc$ca_user_job_name, jmc$ca_orig_application_name, jmc$ca_job_mode,
          jmc$ca_job_priority, jmc$ca_job_qualifier, jmc$ca_or_conditions);

  TYPE
    jmt$job_category_reference = REL (jmt$job_category_item_list)
          ^jmt$job_category_item;

*copyc jmt$job_category_set
*copyc ost$name
*DECK DECK=JMT$JOB_CATEGORY_LIST EXPAND=FALSE

  TYPE
    jmt$job_category_list = record
      category_count: jmt$job_category_count,
      category_list: ^array [1 .. * ] of ost$name,
    recend;

  TYPE
    jmt$job_category_count = 0 .. jmc$maximum_job_category_count;

  CONST
    jmc$maximum_job_category_count = 64;

*copyc ost$name
*DECK DECK=JMT$JOB_CATEGORY_SET EXPAND=FALSE

  TYPE
    jmt$job_category_set = SET of jmt$job_category;

*copyc jmt$job_category
*DECK DECK=JMT$JOB_CLASS EXPAND=FALSE

{ This deck defines the type for job classes.  Any time the job class
{ table (jmv$job_class_table_p) needs to be scanned, the scan should
{ be from jmc$system_job_class (the first defined class) to
{ jmv$maximum_job_class_in_use (the index of the highest defined class).

  CONST
    jmc$null_job_class = 0,
    jmc$system_job_class = 1,
    jmc$maintenance_job_class = 2,
    jmc$unassigned_job_class = 3,
    jmc$lowest_site_job_class = 4,
    jmc$minimum_job_classes = 3,
    jmc$maximum_job_classes = 255;

  TYPE
    jmt$job_class = 0 .. jmc$maximum_job_classes;
*DECK DECK=JMT$JOB_CLASS_ATTRIBUTES EXPAND=FALSE

  TYPE
    jmt$job_class_attributes = record

{ Define the Definition group attributes.

      defined: boolean,
      index: jmt$job_class,
      profile_index: jmt$job_class,
      profile_identification: ost$name,
      name: jmt$job_class_name,
      abbreviation: jmt$job_class_name,
      prolog_p: ^fst$file_reference,
      epilog_p: ^fst$file_reference,
      enable_class_initiation: boolean,
      immediate_initiation_candidate: boolean,
      default_output_class: jmt$output_class_name,
      initial_service_class_index: jmt$service_class_index,
      initial_working_set: jmt$working_set_size, { pages

{ Define the Control group attributes.

      cyclic_aging_interval: jmt$aging_min_max_default, { microseconds
      defer_on_submit: boolean,
      initiation_level: jmt$job_initiation_level,
      maximum_working_set: jmt$ws_min_max_default, { pages
      minimum_working_set: jmt$ws_min_max_default, { pages
      page_aging_interval: jmt$aging_min_max_default, { microseconds

{ Define the Limit group attributes.

      cpu_time_limit: jmt$cpu_time_limit, { seconds
      detached_job_wait_time: jmt$det_wait_min_max_default, { seconds
      magnetic_tape_limit: jmt$magnetic_tape_limit,
      sru_limit: jmt$sru_limit,

{ Define the Membership group attributes.

      automatic_class_selection: boolean,
      excluded_categories: jmt$job_category_set,
      next_rank_class: jmt$job_class,
      required_categories: jmt$job_category_set,

{ Define the Priority group attributes.

      initiation_age_interval: jmt$priority_aging_interval, { microseconds
      job_leveling_priority_bias: jmt$priority_bias,
      multiple_job_bias: jmt$priority_bias,
      selection_priority: jmt$selection_priority,

    recend;


  TYPE
    jmt$aging_min_max_default = record
      default: jmt$aging_interval,
      minimum: jmt$aging_interval,
      maximum: jmt$aging_interval,
    recend,

    jmt$det_wait_min_max_default = record
      default: jmt$detached_job_wait_time,
      minimum: jmt$detached_job_wait_time,
      maximum: jmt$detached_job_wait_time,
    recend,

    jmt$ws_min_max_default = record
      default: jmt$working_set_size,
      minimum: jmt$working_set_size,
      maximum: jmt$working_set_size,
    recend;

*copyc fst$file_reference
*copyc jmt$aging_interval
*copyc jmt$cpu_time_limit
*copyc jmt$detached_job_wait_time
*copyc jmt$job_category_set
*copyc jmt$job_class
*copyc jmt$job_class_name
*copyc jmt$job_initiation_level
*copyc jmt$magnetic_tape_limit
*copyc jmt$output_class_name
*copyc jmt$priority_aging_interval
*copyc jmt$priority_bias
*copyc jmt$selection_priority
*copyc jmt$service_class_index
*copyc jmt$service_class_name
*copyc jmt$sru_limit
*copyc jmt$working_set_size
*copyc ost$name
*DECK DECK=JMT$JOB_CLASS_COUNTS EXPAND=FALSE

  TYPE
    jmt$job_class_counts = array [jmt$job_class] of jmt$job_class_count,
    jmt$job_class_count = record
      queued_jobs: jmt$job_count_range,
      initiated_jobs: jmt$job_count_range,
      swapped_jobs: jmt$job_count_range,
      completed_jobs: jmt$completed_job_count_range,
    recend;

*copyc jmt$completed_job_count_range
*copyc jmt$job_class
*copyc jmt$job_count_range
*DECK DECK=JMT$JOB_CLASS_LIMITS EXPAND=FALSE

  TYPE
    jmt$job_class_limits = array [jmt$job_class] of jmt$job_count_range;

*copyc jmt$job_class
*copyc jmt$job_count_range
*DECK DECK=JMT$JOB_CLASS_LIST EXPAND=FALSE

  TYPE
    jmt$job_class_list = array [1 .. * ] of jmt$job_class_name;

*copyc jmt$job_class_name
*DECK DECK=JMT$JOB_CLASS_NAME EXPAND=FALSE

  TYPE
    jmt$job_class_name = ost$name;

*copyc ost$name
*DECK DECK=JMT$JOB_CLASS_SET EXPAND=FALSE

  TYPE
    jmt$job_class_set = SET OF jmt$job_class;

*copyc jmt$job_class
*DECK DECK=JMT$JOB_CLASS_STATISTICS EXPAND=FALSE

  TYPE
    jmt$job_class_statistics = record
      queued_jobs: jmt$job_count_range,
      initiated_jobs: jmt$job_count_range,
    recend;

*copyc jmt$job_count_range
*DECK DECK=JMT$JOB_CLASS_STATS EXPAND=FALSE


  TYPE
    jmt$job_class_stats = ARRAY [1 .. *] OF jmt$job_class_stat_entry;

*copyc jmt$job_class_stat_entry
*DECK DECK=JMT$JOB_CLASS_STAT_ENTRY EXPAND=FALSE

  TYPE
    jmt$job_class_stat_entry = record
      job_class_counters: jmt$job_class_counters,
      job_class_names: jmt$job_class_names,
    recend;

  TYPE
    jmt$job_class_counters = record
      queued_jobs: jmt$job_count_range,
      initiated_jobs: jmt$job_count_range,
      swapped_jobs: jmt$job_count_range,
      completed_jobs: jmt$completed_job_count_range,
    recend;

  TYPE
    jmt$job_class_names = record
      name: jmt$job_class_name,
      abbreviation: jmt$job_class_name,
    recend;

*copyc jmt$completed_job_count_range
*copyc jmt$job_count_range
*copyc jmt$job_class_name
*DECK DECK=JMT$JOB_CLASS_TABLE EXPAND=FALSE

{ This deck defines the type for the job class table.  Any time the job class
{ table (jmv$job_class_table_p) needs to be scanned, the scan should be from
{ jmc$system_job_class (the first defined class) to
{ jmv$maximum_job_class_in_use (the index of the highest class in use).

  TYPE
    jmt$job_class_table = array [1 .. *] of jmt$job_class_attributes;

*copyc jmt$job_class_attributes
*DECK DECK=JMT$JOB_CONTROL_BLOCK EXPAND=FALSE

{ This common deck contains the type declarations for the }
{ JOB CONTROL BLOCK (JCB). }

{ The JCB is used to maintain information on a job. }

  { * * * * WARNING - If the length of this table grows * * * *}
{    * * * *    beyond 256 bytes, the constant <jrootsiz>* * * *}
{    * * * *    in the common deck ASMBCOM must be changed.* * *}
{    * * * *    There also be other changes required!!!    * * *}

TYPE
  jmt$job_control_block = record

{ The jcb_identifier MUST be the first field in the JCB.

    jcb_identifier: 0 .. 0ffff(16),

{ The following fields are referenced by assembly code; the offsets must not change unless
{ the deck tma$task_switch is changed.

    last_lpid_for_job: 0 .. 0ff(16),

{ End of fields referenced by assembly code.

    system_name: jmt$system_supplied_name,
    jobname: jmt$user_supplied_name,
    job_id: jmt$job_system_id,
    user_id: ost$user_identification,
    job_monitor_id: ost$global_task_id,
    ijle_p: ^jmt$initiated_job_list_entry,
    ijl_ordinal: jmt$ijl_ordinal,
    server_mainframe_id: pmt$binary_mainframe_id,
    last_execution_time: ost$free_running_clock,
    cptime_next_age_working_set: ost$cp_time_value,
    cptime_signal_last_sent: ost$cp_time_value,
*IF $true(osv$unix)
    signal_interval:  0 .. 7FFFFFFF(16),
*ELSE
    signal_interval:  0 .. 0FFFFFFFF(16),
*IFEND
    max_working_set_size: jmt$working_set_size,
    min_working_set_size: jmt$working_set_size,
    page_aging_interval: ost$aging_interval,
    cyclic_aging_interval: ost$aging_interval,
    detached_job_wait_time: jmt$detached_job_wait_time,
    next_cyclic_aging_time: ost$free_running_clock,
    sense_switches: pmt$sense_switches,
    perm_file_job_warning_limit: sft$counter,
    perm_file_job_warning_checking: boolean,
    perm_file_job_maximum_limit: sft$counter,
    temp_file_job_warning_limit: sft$counter,
    temp_file_job_warning_checking: boolean,
    temp_file_job_maximum_limit: sft$counter,
    swapped_job_entry: jmt$swapped_job_entry,
    account_project_specified: boolean,
  recend;

*copyc jmt$detached_job_wait_time
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc jmt$job_system_id
*copyc jmt$swapped_job_entry
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc jmt$working_set_size
*copyc ost$aging_interval
*copyc ost$cp_time
*copyc ost$global_task_id
*copyc ost$hardware_subranges
*copyc ost$user_identification
*copyc pmt$binary_mainframe_id
*copyc pmt$sense_switches
*copyc sft$counter
*DECK DECK=JMT$JOB_COUNTS EXPAND=FALSE

  TYPE
    jmt$job_counts = record
      queued_jobs: jmt$job_count_range,
      initiated_jobs: jmt$job_count_range,
      interactive_jobs: jmt$job_count_range,
      job_class_counts: jmt$job_class_counts,
      service_class_counts: jmt$service_class_counts,
    recend;

*copyc jmt$job_count_range
*copyc jmt$job_class_counts
*copyc jmt$service_class_counts
*DECK DECK=JMT$JOB_COUNT_RANGE EXPAND=FALSE

  TYPE
    jmt$job_count_range = 0 .. jmc$maximum_job_count;

*copyc jmc$maximum_job_count
*DECK DECK=JMT$JOB_EXECUTION_ATTRIBUTES EXPAND=FALSE

  TYPE
    jmt$job_execution_attributes = record
      lock: ost$signature_lock,
      cyclic_ai_overridden: boolean,
      cyclic_aging_interval: jmt$aging_interval,
      maximum_ws_overridden: boolean,
      maximum_working_set: jmt$working_set_size,
      minimum_ws_overridden: boolean,
      minimum_working_set: jmt$working_set_size,
      page_ai_overridden: boolean,
      page_aging_interval: jmt$aging_interval,
      service_class_overridden: boolean,
      service_class_index: jmt$service_class_index,
      service_accumulator: jmt$service_accumulator,
    recend;

*copyc jmt$aging_interval
*copyc jmt$application_name
*copyc jmt$service_accumulator
*copyc jmt$service_class_index
*copyc jmt$working_set_size
*copyc ost$name
*copyc ost$signature_lock_status
*DECK DECK=JMT$JOB_HISTORY_EVENT EXPAND=FALSE

TYPE
  jmt$job_history_event = record
    header: ^sft$global_log_statistic_header,
    descriptive_data: ^sft$descriptive_data,
    next_job: ^jmt$job_history_event,
    next_event: ^jmt$job_history_event,
  recend;

*copyc sfd$type_declarations
*copyc sft$global_log_statistic_header
*DECK DECK=JMT$JOB_HISTORY_JOB_NAME_ENTRY EXPAND=FALSE

  TYPE
    jmt$job_history_job_name_entry = record
      job_name: jmt$system_supplied_name,
      nnext: ^jmt$job_history_job_name_entry,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
?? POP ??
*DECK DECK=JMT$JOB_HISTORY_SORTED_ORDER EXPAND=FALSE

TYPE
  jmt$job_history_sorted_order = (jmc$sort_by_time, jmc$sort_by_job,
        jmc$sort_by_family);
*DECK DECK=JMT$JOB_INITIATION_LEVEL EXPAND=FALSE

  TYPE
    jmt$job_initiation_level = record
      preferred: jmt$maximum_initiated_jobs,
      maximum_increment: jmt$maximum_initiated_jobs,
    recend;

*copyc jmt$maximum_initiated_jobs

*DECK DECK=JMT$JOB_INPUT_DEVICE EXPAND=FALSE

  TYPE
    jmt$job_input_device = record
      size: 0 .. jmc$job_input_device_size,
      text: string (jmc$job_input_device_size),
    recend;

  CONST
    jmc$job_input_device_size = 256;
*DECK DECK=JMT$JOB_INTERNAL_INFORMATION EXPAND=FALSE

  TYPE
    jmt$job_internal_information = record
      jmtr_global_taskid: ost$global_task_id,
      job_mode: jmt$job_mode,
      ijl_ordinal: jmt$ijl_ordinal,
      timesharing_job: boolean,
    recend;

*copyc jmt$ijl_ordinal
*copyc jmt$job_mode
*copyc ost$global_task_id

*DECK DECK=JMT$JOB_LIMITS EXPAND=FALSE
{Dummy deck - replacewhen real deck is available.
*DECK DECK=JMT$JOB_MESSAGE EXPAND=FALSE

{ This type contains information of a general nature regarding the type of
{ message and some specific information about the message.  The size of the
{ maximum variant of this type is used for every creation of the type.  So...
{ keep it to a reasonable size.  Any additional data should be handled using
{ pointers nested within this type.

{ This type is used in remote procedure calls.  When used in this fashion, any
{ pointer values are invalid until the remote procedure call procedure on the
{ server initializes them.  This is the SERVER's responsibility.

  TYPE
    jmt$job_message = record
      case message_kind: jmt$job_message_kind of
      = jmc$jmk_null_message =
        ,

      = jmc$jmk_unseen_mail_message =
        unseen_mail_message: jmt$unseen_mail_message,
      casend,
    recend;

*copyc jmt$unseen_mail_message
*copyc jmt$job_message_kind
*DECK DECK=JMT$JOB_MESSAGE_KIND EXPAND=FALSE

  TYPE
    jmt$job_message_kind = (jmc$jmk_null_message, jmc$jmk_unseen_mail_message);

*DECK DECK=JMT$JOB_MODE EXPAND=FALSE

  TYPE
    jmt$job_mode = (jmc$batch, jmc$interactive_connected,
      jmc$interactive_cmnd_disconnect, jmc$interactive_line_disconnect,
      jmc$interactive_sys_disconnect);
*DECK DECK=JMT$JOB_MODE_SET EXPAND=FALSE

  TYPE
    jmt$job_mode_set = SET OF jmt$job_mode;

*copyc jmt$job_mode
*DECK DECK=JMT$JOB_NAME_LIST EXPAND=FALSE

  TYPE
    jmt$job_name_list = array [1 .. * ] of jmt$job_name_list_entry;

  TYPE
    jmt$job_name_list_entry = record
      system_job_name: jmt$system_supplied_name,
      mainframe_id: pmt$binary_mainframe_id,
    recend;

*copyc jmt$system_supplied_name
*copyc pmt$binary_mainframe_id
*DECK DECK=JMT$JOB_OUTPUT_DISPOSITION EXPAND=FALSE

  TYPE
    jmt$job_output_disposition = (jmc$discard_job_output,
      jmc$retain_job_output);
*DECK DECK=JMT$JOB_OUTPUT_DISPOSITION_SET EXPAND=FALSE

  TYPE
    jmt$job_output_disposition_set = SET OF jmt$job_output_disposition;

*copyc jmt$job_output_disposition
*DECK DECK=JMT$JOB_PRIORITY EXPAND=FALSE

  TYPE
    jmt$job_priority = 0 .. 0ffffff(16);

{ The following constants define the range of values permitted on SCL
{ parameter definitions.

  CONST
    jmc$lowest_job_priority = 0,
    jmc$highest_job_priority = 16000000;

*DECK DECK=JMT$JOB_PRIORITY_NAME EXPAND=FALSE

  TYPE
    jmt$job_priority_name = ost$name;

*copyc ost$name
*DECK DECK=JMT$JOB_PROCESSING_PHASE EXPAND=FALSE

  TYPE
    jmt$job_processing_phase = 0 .. 1600;

  CONST
    jmc$jpp_job_begin_phase = 100,
    jmc$jpp_system_prolog_phase = 200,
    jmc$jpp_class_prolog_phase = 300,
    jmc$jpp_account_prolog_phase = 400,
    jmc$jpp_project_prolog_phase = 500,
    jmc$jpp_member_prolog_phase = 600,
    jmc$jpp_user_prolog_phase = 700,
    jmc$jpp_command_phase = 800,
    jmc$jpp_user_epilog_phase = 900,
    jmc$jpp_member_epilog_phase = 1000,
    jmc$jpp_project_epilog_phase = 1100,
    jmc$jpp_account_epilog_phase = 1200,
    jmc$jpp_class_epilog_phase = 1300,
    jmc$jpp_system_epilog_phase = 1400,
    jmc$jpp_job_end_phase = 1500;

*DECK DECK=JMT$JOB_QUALIFIER_LIST EXPAND=FALSE

  TYPE
    jmt$job_qualifier_list = array [1 .. * ] of ost$name;

  CONST
    jmc$maximum_job_qualifiers = 5;

*DECK DECK=JMT$JOB_RECOVERY_DISPOSITION EXPAND=FALSE

  TYPE
    jmt$job_recovery_disposition = (jmc$continue_on_recovery,
          jmc$restart_on_recovery, jmc$terminate_on_recovery);

*DECK DECK=JMT$JOB_RECOVERY_INFORMATION EXPAND=FALSE

  TYPE
    jmt$job_recovery_information = record
      job_system_label: jmt$job_system_label,
    recend;

*copyc jmt$job_system_label
*DECK DECK=JMT$JOB_RESOURCE_FAULT EXPAND=FALSE

  TYPE
    jmt$job_resource_fault = jmt$job_resource_condition;

*copyc JMD$JOB_RESOURCE_CONDITION
*DECK DECK=JMT$JOB_RESOURCE_SIGNAL EXPAND=FALSE


  TYPE
    jmt$job_resource_signal = record
      case boolean of
      = true =
        signal: pmt$signal,

      = false =
        signal_id: pmt$signal_id,
        signal_contents: jmt$job_resource_condition,
      casend,
    recend;

*copyc jmd$job_resource_condition
*copyc pmt$signal
*DECK DECK=JMT$JOB_SCHEDULER_EVENT EXPAND=FALSE
  TYPE
    jmt$job_scheduler_events = (jmc$job_is_good_swapout_cand,
                                jmc$ready_task_in_job,
                                jmc$job_terminated,
                                jmc$recovery_swap_io_error,
                                jmc$recovery_swapin,
                                jmc$recovery_job_damaged,
                                jmc$call_job_swapper,
                                jmc$process_operator_request,
                                jmc$change_dispatching_controls,
                                jmc$subsystem_priority_change,
                                jmc$swap_jobs_for_lower_maxaj,
                                jmc$swap_job_for_memory_reserve,
                                jmc$system_is_thrashing,
                                jmc$system_is_idling,
                                jmc$examine_input_queue,
                                jmc$examine_swapin_queue,
                                jmc$scheduler_wake_time,
                                jmc$needed_memory_available,
                                jmc$needed_ajlo_available),

    jmt$job_scheduler_event = ARRAY [jmt$job_scheduler_events] of boolean,

    jmt$job_sched_event_selections = ARRAY [jmt$job_scheduler_events] of boolean;
*DECK DECK=JMT$JOB_SCHEDULER_STATISTICS EXPAND=FALSE

{ Adding a new element to this array of statistics will require changes to
{ JMM$JOB_SCHEDULER_UTILITY and CLM$DISPLAY_SYSTEM_DATA, and recompiling OSM$FETCH_STATISTICAL_DATA

  TYPE
    jmt$sched_statistic_elements =(jmc$lower_prio_swap_count,
                                   jmc$thrashing_in_activate_jobs,
                                   jmc$queues_emptied_count,
                                   jmc$none_left_activation_viol,
                                   jmc$bad_status_on_activate,
                                   jmc$ready_task_event_count,
                                   jmc$advance_swap_event_count,
                                   jmc$job_terminated_event_count,
                                   jmc$idle_system_event_count,
                                   jmc$lower_maxaj_event_count,
                                   jmc$memory_reserve_event_count,
                                   jmc$swapout_candidate_event_cnt,
                                   jmc$system_thrashing_event_cnt,
                                   jmc$exit_thrashing_none_to_swap,
                                   jmc$operator_request_event_cnt,
                                   jmc$activate_event_count,
                                   jmc$memory_available_in_lw_q,
                                   jmc$wait_for_memory,
                                   jmc$memory_wait_no_preempt,
                                   jmc$memory_wait_act_viol,
                                   jmc$wait_for_ajlo,
                                   jmc$ajlo_wait_no_preempt,
                                   jmc$ajlo_wait_act_viol,
                                   jmc$short_wait,
                                   jmc$long_wait,
                                   jmc$restore_job_in_memory,
                                   jmc$called_advance_lw_job,
                                   jmc$large_ws_bad_status_on_act,
                                   jmc$large_ws_job_activated,
                                   jmc$large_ws_mem_avail_in_lw_q,
                                   jmc$large_ws_preempt_for_memory,
                                   jmc$large_ws_relink_no_preempt,
                                   jmc$large_ws_relink_job_too_big,
                                   jmc$age_shared_q_bad_status,
                                   jmc$age_shared_q_activated,
                                   jmc$change_dispatching,
                                   jmc$recovery_swap_error,
                                   jmc$change_subsystem_priority,
                                   jmc$recovery_swapin_event_count,
                                   jmc$bad_status_after_age_job,
                                   jmc$activate_after_age_job),

    jmt$job_scheduler_statistics = array [jmt$sched_statistic_elements] of 0 .. 0ffffffff(16);
*DECK DECK=JMT$JOB_SCHEDULER_TABLE EXPAND=FALSE

  TYPE
    jmt$job_scheduler_table = record

{ Define the Definition group attributes.

      cpu_quantum_time: ost$task_time_slice, { microseconds
      enable_job_leveling: boolean,
      job_leveling_interval: jmt$service_interval, { seconds
      profile_identification: ost$name,
      service_calculation_interval: jmt$service_interval, { seconds

{ Define the Control group attributes.

      cpu_dispatching_allocation: jmt$cpu_dispatching_allocation,
            {percentage of interval
      dispatching_allocation_interval: jmt$dispatching_interval, {seconds
      dual_state_priority_control: jmt$dual_state_priority_control,
      idle_dispatching_queue_time: jmt$idle_dispatching_queue_time, { microsecs
      initiation_excluded_categories: jmt$job_category_set, { current mainframe
      initiation_required_categories: jmt$job_category_set, { current mainframe
      scheduling_memory_levels: jmt$scheduling_memory_levels, { pages

{ Define the Membership group attributes.

      validation_categories_p: ^jmt$mainframe_categories,

{ Define the Priority group attributes.

      job_leveling_priority_bias: jmt$priority_bias,

    recend;


  TYPE
    jmt$scheduling_memory_levels = record
      thrashing: jmt$scheduling_memory_level,
      target: jmt$scheduling_memory_level,
    recend;

*copyc jmt$cpu_dispatching_allocation
*copyc jmt$dispatching_interval
*copyc jmt$dual_state_priority_control
*copyc jmt$idle_dispatching_queue_time
*copyc jmt$job_category_set
*copyc jmt$mainframe_categories
*copyc jmt$priority_bias
*copyc jmt$scheduling_memory_level
*copyc jmt$service_interval
*copyc ost$name
*copyc ost$task_time_slice
*DECK DECK=JMT$JOB_SCHED_SERV_CLASS_STATS EXPAND=FALSE
  TYPE
    jmt$job_sched_serv_class_stats = array
          [1 .. jmc$maximum_service_classes] of jmt$job_sched_serv_class_stat,

    jmt$job_sched_serv_class_stat = record
      memory_wait: 0 .. 0ffffffff(16),
      ajl_wait: 0 .. 0ffffffff(16),
    recend;

*copyc jmt$service_class_index
*DECK DECK=JMT$JOB_SIZE EXPAND=FALSE

  TYPE
    jmt$job_size = 0 .. 07fffffff(16);
*DECK DECK=JMT$JOB_STATE EXPAND=FALSE

  TYPE
    jmt$job_state = (jmc$deferred_job, jmc$queued_job, jmc$initiated_job,
          jmc$terminating_job, jmc$completed_job);


*DECK DECK=JMT$JOB_STATE_SET EXPAND=FALSE

  TYPE
    jmt$job_state_set = SET OF jmt$job_state;

*copyc jmt$job_state
*DECK DECK=JMT$JOB_STATISTICS EXPAND=FALSE
{Define job statistics record. This record is not kept in any system table but is constructed
{when required from information kept in several system tables.

  TYPE
    jmt$job_statistics = record
      cp_time: ost$cp_time,
      paging_statistics: ost$paging_statistics,
      working_set_size: 0 .. 0ffff(16),
      ready_task_count: 0 .. 0ffff(16),
    recend;

*copyc OST$CP_TIME
*copyc OST$PAGING_STATISTICS
*DECK DECK=JMT$JOB_STATUS_COUNT EXPAND=FALSE

  TYPE
    jmt$job_status_count = 0 .. jmc$max_job_status_count;

  CONST
    jmc$max_job_status_count = jmc$maximum_job_count;

*copyc jmc$maximum_job_count
*DECK DECK=JMT$JOB_STATUS_OPTIONS EXPAND=FALSE

  TYPE
    jmt$job_status_options = array [1 .. * ] of jmt$job_status_option;

  TYPE
    jmt$job_status_option = record
      case key: jmt$attribute_keys of
      = jmc$continue_request_to_servers =
        continue_request_to_servers: boolean,
      = jmc$control_family =
        control_family: ost$name,
      = jmc$control_user =
        control_user: ost$name,
      = jmc$include_the_system_job =
        include_the_system_job: boolean,
      = jmc$job_deferred_by_operator =
        job_deferred_by_operator: boolean,
      = jmc$job_deferred_by_user =
        job_deferred_by_user: boolean,
      = jmc$job_mode_set =
        job_mode_set: jmt$job_mode_set,
      = jmc$job_state_set =
        job_state_set: jmt$job_state_set,
      = jmc$login_family =
        login_family: ost$name,
      = jmc$login_user =
        login_user: ost$name,
      = jmc$name_list =
        name_list: ^jmt$name_list,
      = jmc$null_attribute =
        ,
      = jmc$privilege =
        privilege: jmt$privilege,

{ The following option(s) can only be used by NOS/VE.

      = jmc$user_identification =
        user_identification: ^ost$user_identification,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$job_mode_set
*copyc jmt$job_state_set
*copyc jmt$name_list
*copyc jmt$privilege
*copyc ost$name
*copyc ost$user_identification
*DECK DECK=JMT$JOB_STATUS_RESULTS EXPAND=FALSE

  TYPE
    jmt$job_status_results = array [1 .. * ] of ^array [1 .. * ] of
          jmt$job_status_result;

  TYPE
    jmt$job_status_result = record
      case key: jmt$attribute_keys of
      = jmc$client_mainframe_id =
        client_mainframe_id: pmt$mainframe_id,
      = jmc$control_family =
        control_family: ost$name,
      = jmc$control_user =
        control_user: ost$name,
      = jmc$cpu_time_used =
        cpu_time_used: jmt$cpu_time_used,
      = jmc$display_message =
        display_message: ^jmt$display_message,
      = jmc$input_file_location =
        input_file_location: jmt$input_file_location,
      = jmc$internal_index =
        internal_index: integer,
      = jmc$job_class =
        job_class: jmt$job_class_name,
      = jmc$job_class_position =
        job_class_position: jmt$job_count_range,
      = jmc$job_deferred_by_operator =
        job_deferred_by_operator: boolean,
      = jmc$job_deferred_by_user =
        job_deferred_by_user: boolean,
      = jmc$job_destination_usage =
        job_destination_usage: jmt$destination_usage,
      = jmc$job_initiation_time =
        job_initiation_time: jmt$date_time,
      = jmc$job_mode =
        job_mode: jmt$job_mode,
      = jmc$job_state =
        job_state: jmt$job_state,
      = jmc$login_family =
        login_family: ost$name,
      = jmc$login_user =
        login_user: ost$name,
      = jmc$null_attribute =
        ,
      = jmc$operator_action_posted =
        operator_action_posted: boolean,
      = jmc$page_faults =
        page_faults: jmt$page_faults,
      = jmc$server_mainframe_id =
        server_mainframe_id: pmt$mainframe_id,
      = jmc$system_job_name =
        system_job_name: jmt$system_supplied_name,
      = jmc$user_job_name =
        user_job_name: jmt$user_supplied_name,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$cpu_time_used
*copyc jmt$date_time
*copyc jmt$destination_usage
*copyc jmt$display_message
*copyc jmt$input_file_location
*copyc jmt$job_class_name
*copyc jmt$job_count_range
*copyc jmt$job_mode
*copyc jmt$job_state
*copyc jmt$page_faults
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc ost$name
*copyc pmt$mainframe_id

*DECK DECK=JMT$JOB_STATUS_RESULTS_KEYS EXPAND=FALSE

  TYPE
    jmt$job_status_results_keys = jmt$results_keys;

*copyc jmt$results_keys
*DECK DECK=JMT$JOB_SUBMISSION_OPTIONS EXPAND=FALSE

  TYPE
    jmt$job_submission_options = array [1 .. * ] of jmt$job_submission_option;

  TYPE
    jmt$job_submission_option = record
      case key: jmt$attribute_keys of
      = jmc$comment_banner =
        comment_banner: jmt$output_comment_banner,
      = jmc$copies =
        copies: jmt$output_copy_count,
      = jmc$cpu_time_limit =
        cpu_time_limit: jmt$cpu_time_limit,
      = jmc$default_login_account =
        default_login_account: ost$name,
      = jmc$default_login_family =
        default_login_family: ost$name,
      = jmc$default_login_project =
        default_login_project: ost$name,
      = jmc$default_login_user =
        default_login_user: ost$name,
      = jmc$device =
        device: jmt$output_device,
      = jmc$earliest_print_time =
        earliest_print_time: jmt$date_time,
      = jmc$earliest_run_time =
        earliest_run_time: jmt$date_time,
      = jmc$external_characteristics =
        external_characteristics: jmt$external_characteristics,
      = jmc$forms_code =
        forms_code: jmt$forms_code,
      = jmc$job_abort_disposition =
        job_abort_disposition: jmt$job_abort_disposition,
      = jmc$job_class =
        job_class: jmt$job_class_name,
      = jmc$job_deferred_by_user =
        job_deferred_by_user: boolean,
      = jmc$job_destination_family = { job_destination
        job_destination_family: ost$name,
      = jmc$job_destination_usage =
        job_destination_usage: jmt$destination_usage,
      = jmc$job_execution_ring =
        job_execution_ring: ost$ring,
      = jmc$job_priority =
        job_priority: jmt$job_priority_name,
      = jmc$job_qualifier_list =
        job_qualifier_list: ^jmt$job_qualifier_list,
      = jmc$job_recovery_disposition =
        job_recovery_disposition: jmt$job_recovery_disposition,
      = jmc$latest_print_time =
        latest_print_time: jmt$date_time,
      = jmc$latest_run_time =
        latest_run_time: jmt$date_time,
      = jmc$login_account =
        login_account: ost$name,
      = jmc$login_family =
        login_family: ost$name,
      = jmc$login_password =
        login_password: ost$name,
      = jmc$login_project =
        login_project: ost$name,
      = jmc$login_user =
        login_user: ost$name,
      = jmc$magnetic_tape_limit =
        magnetic_tape_limit: jmt$magnetic_tape_limit,
      = jmc$maximum_working_set =
        maximum_working_set: jmt$working_set_size,
      = jmc$null_attribute =
        ,
      = jmc$output_deferred_by_user =
        output_deferred_by_user: boolean,
      = jmc$output_destination =
        output_destination: ost$name,
      = jmc$output_destination_family = { operator_family
        output_destination_family: ost$name,
      = jmc$output_destination_usage =
        output_destination_usage: jmt$destination_usage,
      = jmc$output_disposition =
        output_disposition: jmt$output_disposition,
      = jmc$purge_delay =
        purge_delay: ^jmt$time_increment,
      = jmc$remote_host_directive =
        remote_host_directive: ^jmt$remote_host_directive,
      = jmc$routing_banner =
        routing_banner: jmt$output_routing_banner,
      = jmc$sru_limit =
        sru_limit: jmt$sru_limit,
      = jmc$station =
        station: jmt$station,
      = jmc$station_operator = { operator_user
        station_operator: jmt$station_operator,
      = jmc$user_information =
        user_information: ^jmt$user_information,
      = jmc$user_job_name =
        user_job_name: jmt$user_supplied_name,
      = jmc$vertical_print_density =
        vertical_print_density: jmt$vertical_print_density,
      = jmc$vfu_load_procedure =
        vfu_load_procedure: jmt$vfu_load_procedure,

{ The following options may only be used by NOS/VE.

      = jmc$control_family =
        control_family: ost$name,
      = jmc$control_user =
        control_user: ost$name,
      = jmc$data_declaration =
        data_declaration: jmt$data_declaration,
      = jmc$data_mode =
        data_mode: jmt$data_mode,
      = jmc$disposition_code =
        disposition_code: jmt$disposition_code,
      = jmc$encrypted_password =
        encrypted_password: ost$name,
      = jmc$immediate_init_candidate =
        immediate_init_candidate: boolean,
      = jmc$implicit_routing_text =
        implicit_routing_text: ^jmt$implicit_routing_text,
      = jmc$inherit_job_attributes =
        inherit_job_attributes: boolean,
      = jmc$job_deferred_by_operator =
        job_deferred_by_operator: boolean,
      = jmc$job_input_device =
        job_input_device: ^jmt$job_input_device,
      = jmc$login_command =
        login_command: ^string ( * ),
      = jmc$login_command_supplied =
        login_command_supplied: boolean,
      = jmc$omit_class_validation =
        omit_class_validation: boolean,
      = jmc$omit_user_prolog_and_epilog =
        omit_user_prolog_and_epilog: boolean,
      = jmc$optional_user_capability =
        optional_user_capability: ost$name,
      = jmc$origin_application_name =
        origin_application_name: ost$name,
      = jmc$required_user_capability =
        required_user_capability: ost$name,
      = jmc$site_information =
        site_information: ^jmt$site_information,
      = jmc$source_logical_id =
        source_logical_id: jmt$source_logical_id,
      = jmc$system_job_name =
        system_job_name: jmt$system_supplied_name,
      = jmc$system_job_parameters =
        system_job_parameters: ^jmt$system_job_parameters,
      = jmc$system_routing_text =
        system_routing_text: ^jmt$system_routing_text,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$cpu_time_limit
*copyc jmt$data_declaration
*copyc jmt$data_mode
*copyc jmt$date_time
*copyc jmt$destination_usage
*copyc jmt$disposition_code
*copyc jmt$external_characteristics
*copyc jmt$forms_code
*copyc jmt$implicit_routing_text
*copyc jmt$job_abort_disposition
*copyc jmt$job_class_name
*copyc jmt$job_input_device
*copyc jmt$job_priority_name
*copyc jmt$job_qualifier_list
*copyc jmt$job_recovery_disposition
*copyc jmt$magnetic_tape_limit
*copyc jmt$output_comment_banner
*copyc jmt$output_copy_count
*copyc jmt$output_device
*copyc jmt$output_disposition
*copyc jmt$output_routing_banner
*copyc jmt$remote_host_directive
*copyc jmt$site_information
*copyc jmt$source_logical_id
*copyc jmt$sru_limit
*copyc jmt$station
*copyc jmt$station_operator
*copyc jmt$system_job_parameters
*copyc jmt$system_routing_text
*copyc jmt$system_supplied_name
*copyc jmt$time_increment
*copyc jmt$user_information
*copyc jmt$user_supplied_name
*copyc jmt$vertical_print_density
*copyc jmt$vfu_load_procedure
*copyc jmt$working_set_size
*copyc osd$virtual_address
*copyc ost$name
*DECK DECK=JMT$JOB_SYSTEM_ID EXPAND=FALSE

  TYPE
    jmt$job_system_id = jmt$kjl_index;

*copyc jmt$kjl_index
*DECK DECK=JMT$JOB_SYSTEM_LABEL EXPAND=FALSE

  TYPE
    jmt$job_system_label = record
      version: jmt$job_system_label_version,
      active_profile_version: ost$name,
      assigned_job_class: jmt$job_class_name,
      data_declaration: jmt$data_declaration,
      data_mode: jmt$data_mode,
      disposition_code: jmt$disposition_code,
      job_abort_disposition: jmt$job_abort_disposition,
      job_attributes: jmt$job_attributes,
      job_category_set: jmt$job_category_set,
      job_class_name: jmt$job_class_name,
      job_deferred_by_operator: boolean,
      job_deferred_by_user: boolean,
      job_destination_family: ost$name,
      job_destination_usage: jmt$destination_usage,
      job_execution_ring: ost$ring,
      job_initiation_location: pmt$mainframe_id,
      job_mode: jmt$job_mode,
      job_priority: jmt$job_priority_name,
      job_recovery_disposition: jmt$job_recovery_disposition,
      limit_information: jmt$job_label_limit_information,
      login_account: avt$account_name,
      login_project: avt$project_name,
      login_password: avt$password,
      login_user_identification: ost$user_identification,
      optional_user_capability: ost$name,
      originating_login_account: avt$account_name,
      originating_login_family: ost$name,
      originating_login_project: avt$project_name,
      originating_login_user: ost$name,
      perform_class_validation: boolean,
      required_user_capability: ost$name,
      system_job_name: jmt$system_supplied_name,
      user_job_name: jmt$user_supplied_name,
    recend;

  TYPE
    jmt$job_label_limit_information = record
      cpu_time_limit_specified: boolean,
      cpu_time_limit_requested: jmt$cpu_time_limit,
      cpu_time_limit_assigned: jmt$cpu_time_limit,
      magnetic_tape_limit_specified: boolean,
      magnetic_tape_limit_requested: jmt$magnetic_tape_limit,
      magnetic_tape_limit_assigned: jmt$magnetic_tape_limit,
      maximum_working_set_specified: boolean,
      maximum_working_set_requested: jmt$working_set_size,
      maximum_working_set_assigned: jmt$working_set_size,
      sru_limit_specified: boolean,
      sru_limit_requested: jmt$sru_limit,
      sru_limit_assigned: jmt$sru_limit,
    recend;

*copyc avt$account_name
*copyc avt$password
*copyc avt$project_name
*copyc fst$path
*copyc jmt$cpu_time_limit
*copyc jmt$data_declaration
*copyc jmt$data_mode
*copyc jmt$destination_usage
*copyc jmt$disposition_code
*copyc jmt$job_abort_disposition
*copyc jmt$job_attributes
*copyc jmt$job_category_set
*copyc jmt$job_class
*copyc jmt$job_class_name
*copyc jmt$job_mode
*copyc jmt$job_priority_name
*copyc jmt$job_recovery_disposition
*copyc jmt$job_system_label_version
*copyc jmt$magnetic_tape_limit
*copyc jmt$output_destination
*copyc jmt$sru_limit
*copyc jmt$system_job_parameters
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc jmt$working_set_size
*copyc osd$virtual_address
*copyc ost$date_time
*copyc ost$name
*copyc ost$user_identification
*copyc pmt$mainframe_id

*DECK DECK=JMT$JOB_SYSTEM_LABEL_VERSION EXPAND=FALSE

  TYPE
    jmt$job_system_label_version = STRING (jmc$job_sl_version_size);

  CONST
    jmc$job_sl_version_size = 15;
*DECK DECK=JMT$JOB_TEMPLATE_ENTRY EXPAND=FALSE
  TYPE
    jmt$job_template_entry = RECORD
      { PUT HEADER INFO HERE IN FUTURE
      job_template: ARRAY [*] of jmt$job_templ_segment,
    RECEND,
    jmt$job_templ_segment = RECORD
      tasking_segment: BOOLEAN,
      seg_no: ost$segment,
      sdt: mmt$segment_descriptor,
      sdtx: mmt$segment_descriptor_extended,
      CASE writeable_segment: BOOLEAN OF
      =TRUE=
        static_data_p: ^ARRAY [*] OF CELL,
      CASEND,
    RECEND;

*copyc MMT$SEGMENT_DESCRIPTOR_TABLE
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE_EX
*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=JMT$JOB_TERMINATION_OPTIONS EXPAND=FALSE

  TYPE
    jmt$job_termination_options = array [1 .. * ] of
          jmt$job_termination_option;

  TYPE
    jmt$job_termination_option = record
      case key: jmt$attribute_keys of
      = jmc$continue_request_to_servers =
        continue_request_to_servers: boolean,
      = jmc$job_state_set =
        job_state_set: jmt$job_state_set,
      = jmc$null_attribute =
        ,
      = jmc$output_disposition =
        output_disposition: jmt$output_disposition,
      = jmc$termination_reason =
        reason_p: ^ost$name,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$job_state_set
*copyc jmt$output_disposition
*copyc ost$name
*DECK DECK=JMT$JOB_TERM_DISPOSITION EXPAND=FALSE

  TYPE
    jmt$job_term_disposition = (jmc$discard_job, jmc$retain_job);
*DECK DECK=JMT$JOB_TERM_DISPOSITION_SET EXPAND=FALSE

  TYPE
    jmt$job_term_disposition_set = SET OF jmt$job_term_disposition;

*copyc jmt$job_term_disposition
*DECK DECK=JMT$KJL_APPLICATION_STATE EXPAND=FALSE

  TYPE
    jmt$kjl_application_state = (jmc$kjl_application_unused,
          jmc$kjl_application_new, jmc$kjl_application_acquired,
          jmc$kjl_application_modified, jmc$kjl_application_initiated,
          jmc$kjl_application_terminated);



*DECK DECK=JMT$KJL_APPLICATION_STATE_SET EXPAND=FALSE

  TYPE
    jmt$kjl_application_state_set = SET OF jmt$kjl_application_state;

*copyc jmt$kjl_application_state
*DECK DECK=JMT$KJL_CLIENT_DATA EXPAND=FALSE

  TYPE
    jmt$kjl_client_data = record
      state_data: array [1 .. jmc$kjl_maximum_clients] of jmt$kjl_client_entry,
    recend;

  TYPE
    jmt$kjl_client_entry = record
      mainframe_id: pmt$binary_mainframe_id,
      first_entry: jmt$kjl_index,
      last_entry: jmt$kjl_index,
      number_of_entries: jmt$kjl_index,
    recend;

*copyc jmc$kjl_maximum_clients
*copyc jmt$kjl_index
*copyc pmt$binary_mainframe_id
*DECK DECK=JMT$KJL_CLIENT_INDEX EXPAND=FALSE

  TYPE
    jmt$kjl_client_index = 0 .. jmc$kjl_maximum_clients;

  CONST
    jmc$kjl_client_undefined = 0,
    jmc$kjl_client_this_mainframe = 1;

*copyc jmc$kjl_maximum_clients
*DECK DECK=JMT$KJL_ENTRY_KIND EXPAND=FALSE

  TYPE
    jmt$kjl_entry_kind = (jmc$kjl_unused_entry, jmc$kjl_deferred_entry,
          jmc$kjl_queued_entry, jmc$kjl_assigned_entry,
          jmc$kjl_initiated_entry, jmc$kjl_terminated_entry,
          jmc$kjl_completed_entry);


*DECK DECK=JMT$KJL_ENTRY_KIND_SET EXPAND=FALSE

  TYPE
    jmt$kjl_entry_kind_set = set of jmt$kjl_entry_kind;

*copyc jmt$kjl_entry_kind
*DECK DECK=JMT$KJL_INDEX EXPAND=FALSE

  TYPE
    jmt$kjl_index = 0 .. jmc$kjl_maximum_entries;

  CONST
    jmc$kjl_undefined_index = 0;

*copyc jmc$kjl_maximum_entries
*DECK DECK=JMT$KJL_ORDINAL EXPAND=FALSE

{ * * * * * common deck JMDKJLO: Known Job List Ordinal * * * * * }

TYPE
  jmt$kjl_ordinal = 0 .. jmc$max_kjl_ord;

{ * * * * * end of deck jmdkjlo . . . . . . . . . . . . * * * * * }

*copyc JMC$MAXIMUM_CONSTANTS
*DECK DECK=JMT$KJL_SERVER_DATA EXPAND=FALSE

  TYPE
    jmt$kjl_server_data = record
      state_data: array [1 .. jmc$kjl_maximum_servers] of jmt$kjl_server_entry,
    recend;

  TYPE
    jmt$kjl_server_entry = record
      mainframe_id: pmt$binary_mainframe_id,
      first_entry: jmt$kjl_index,
      last_entry: jmt$kjl_index,
      number_of_entries: jmt$kjl_index,
    recend;

*copyc jmc$kjl_maximum_servers
*copyc jmt$kjl_index
*copyc pmt$binary_mainframe_id

*DECK DECK=JMT$KJL_SERVER_INDEX EXPAND=FALSE

  TYPE
    jmt$kjl_server_index = 0 .. jmc$kjl_maximum_servers;

  CONST
    jmc$kjl_server_undefined = 0,
    jmc$kjl_server_this_mainframe = 1;

*copyc jmc$kjl_maximum_servers
*DECK DECK=JMT$KNOWN_JOB_LIST EXPAND=FALSE

  TYPE
    jmt$known_job_list = record
      state_data: array [jmt$kjl_entry_kind] of jmt$kjl_state_data,
      application_table: jmt$input_application_table,
      queued_class_entries: jmt$queued_class_entries,
      client_data: jmt$kjl_client_data,
      server_data: jmt$kjl_server_data,
      kjl_p: ^array [1 .. * ] of jmt$known_job_list_entry,
      kjlx_p: ^array [1 .. * ] of jmt$known_job_list_extended,
    recend;

  TYPE
    jmt$kjl_state_data = record
      first_entry: jmt$kjl_index,
      last_entry: jmt$kjl_index,
      number_of_entries: jmt$job_count_range,
    recend;

*copyc jmt$input_application_table
*copyc jmt$job_count_range
*copyc jmt$kjl_client_data
*copyc jmt$kjl_index
*copyc jmt$kjl_server_data
*copyc jmt$known_job_list_entry
*copyc jmt$known_job_list_extended
*copyc jmt$queued_class_entries
*DECK DECK=JMT$KNOWN_JOB_LIST_ENTRY EXPAND=FALSE

  TYPE
    jmt$known_job_list_entry = record
      system_job_name: jmt$system_supplied_name,
      user_job_name: jmt$user_supplied_name,
      initiated_job_list_ordinal: jmt$ijl_ordinal,
      job_submission_time: jmt$clock_time,
      earliest_clock_time_to_initiate: jmt$clock_time,
      job_class: jmt$job_class,
      job_category_set: jmt$job_category_set,
      job_priority: jmt$job_priority,
      job_deferred_by_operator: boolean,
      job_deferred_by_user: boolean,
      login_family_available: boolean,
      destination_usage: jmt$destination_usage,
      next_destination_usage: jmt$destination_usage,
      priority_bias: -jmc$highest_job_priority .. jmc$highest_job_priority,
      application_state: jmt$kjl_application_state,
      application_forward_link: jmt$kjl_index,
      application_reverse_link: jmt$kjl_index,
      entry_kind: jmt$kjl_entry_kind,
      forward_link: jmt$kjl_index,
      reverse_link: jmt$kjl_index,
      class_forward_link: jmt$kjl_index,
      class_reverse_link: jmt$kjl_index,
      client_index: jmt$kjl_client_index,
      client_forward_link: jmt$kjl_index,
      client_reverse_link: jmt$kjl_index,
      server_index: jmt$kjl_server_index,
      server_forward_link: jmt$kjl_index,
      server_reverse_link: jmt$kjl_index,
      server_kjl_index: jmt$kjl_index,
    recend;

*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc jmt$ijl_ordinal
*copyc jmt$clock_time
*copyc jmt$destination_usage
*copyc jmt$job_category_set
*copyc jmt$job_class
*copyc jmt$job_priority
*copyc jmt$kjl_application_state
*copyc jmt$kjl_client_index
*copyc jmt$kjl_entry_kind
*copyc jmt$kjl_index
*copyc jmt$kjl_server_index
*DECK DECK=JMT$KNOWN_JOB_LIST_EXTENDED EXPAND=FALSE

  TYPE
    jmt$known_job_list_extended = record
      login_user_identification: ost$user_identification,
      job_controller: ost$user_identification,
      originating_ssn: jmt$system_supplied_name,
      latest_clock_time_to_initiate: jmt$clock_time,
      job_mode: jmt$job_mode,
      job_monitor_global_task_id: ost$global_task_id,
      output_disposition_key: jmt$output_disposition_keys,
      input_file_location: jmt$input_file_location,
      valid_mainframe_set: jmt$valid_mainframe_set,
      timesharing_job: boolean,
      restart_job: boolean,
      job_initiation_time: ost$date_time,
      system_label_p: ^jmt$job_system_label,
      terminal_name: ift$terminal_name,
    recend;

*copyc ift$terminal_name
*copyc jmt$clock_time
*copyc jmt$destination_usage
*copyc jmt$input_file_location
*copyc jmt$job_mode
*copyc jmt$job_system_label
*copyc jmt$output_disposition_keys
*copyc jmt$system_supplied_name
*copyc jmt$valid_mainframe_set
*copyc ost$date_time
*copyc ost$global_task_id
*copyc ost$user_identification
*DECK DECK=JMT$KNOWN_OUTPUT_LIST EXPAND=FALSE

  TYPE
    jmt$known_output_list = record
      state_data: array [jmt$kol_entry_kind] of jmt$kol_state_data,
      application_table: jmt$output_application_table,
      kol_p: ^array [1 .. * ] of jmt$known_output_list_entry,
    recend;

  TYPE
    jmt$kol_state_data = record
      first_entry: jmt$kol_index,
      last_entry: jmt$kol_index,
      number_of_entries: jmt$output_count_range,
    recend;

*copyc jmt$kol_entry_kind
*copyc jmt$kol_index
*copyc jmt$known_output_list_entry
*copyc jmt$output_application_table
*copyc jmt$output_count_range
*DECK DECK=JMT$KNOWN_OUTPUT_LIST_ENTRY EXPAND=FALSE

  TYPE
    jmt$known_output_list_entry = record
      system_file_name: jmt$system_supplied_name,
      user_file_name: jmt$user_supplied_name,
      login_user_identification: ost$user_identification,
      output_controller: ost$user_identification,
      output_submission_clock_time: jmt$clock_time,
      earliest_clock_time_to_print: jmt$clock_time,
      latest_clock_time_to_print: jmt$clock_time,
      purge_delay: jmt$clock_time,
      output_deferred_by_operator: boolean,
      output_deferred_by_user: boolean,
      destination_usage: jmt$destination_usage,
      next_destination_usage: jmt$destination_usage,
      system_job_name: jmt$system_supplied_name,
      user_job_name: jmt$user_supplied_name,
      application_state: jmt$kol_application_state,
      application_forward_link: jmt$kol_index,
      application_reverse_link: jmt$kol_index,
      entry_kind: jmt$kol_entry_kind,
      forward_link: jmt$kol_index,
      reverse_link: jmt$kol_index,
    recend;

*copyc jmt$clock_time
*copyc jmt$destination_usage
*copyc jmt$kol_application_state
*copyc jmt$kol_entry_kind
*copyc jmt$kol_index
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc ost$user_identification
*DECK DECK=JMT$KNOWN_QFILE_LIST EXPAND=FALSE

  TYPE
    jmt$known_qfile_list = record
      state_data: array [jmt$kql_entry_kind] of jmt$kql_state_data,
      application_table: jmt$qfile_application_table,
      kql_p: ^array [1 .. * ] of jmt$known_qfile_list_entry,
    recend;

  TYPE
    jmt$kql_state_data = record
      first_entry: jmt$kql_index,
      last_entry: jmt$kql_index,
      number_of_entries: jmt$qfile_count_range,
    recend;

*copyc jmt$kql_entry_kind
*copyc jmt$kql_index
*copyc jmt$known_qfile_list_entry
*copyc jmt$qfile_application_table
*copyc jmt$qfile_count_range
*DECK DECK=JMT$KNOWN_QFILE_LIST_ENTRY EXPAND=FALSE

  TYPE
    jmt$known_qfile_list_entry = record
      system_file_name: jmt$system_supplied_name,
      earliest_clock_time_to_process: jmt$clock_time,
      latest_clock_time_to_process: jmt$clock_time,
      purge_delay: jmt$clock_time,
      deferred_by_application: boolean,
      application_name: ost$name,
      next_application_name: ost$name,
      application_state: jmt$kql_application_state,
      application_forward_link: jmt$kql_index,
      application_reverse_link: jmt$kql_index,
      entry_kind: jmt$kql_entry_kind,
      forward_link: jmt$kql_index,
      reverse_link: jmt$kql_index,
    recend;

*copyc jmt$clock_time
*copyc jmt$kql_application_state
*copyc jmt$kql_entry_kind
*copyc jmt$kql_index
*copyc jmt$system_supplied_name
*copyc ost$name
*DECK DECK=JMT$KOL_APPLICATION_STATE EXPAND=FALSE

  TYPE
    jmt$kol_application_state = (jmc$kol_application_unused, jmc$kol_application_new,
      jmc$kol_application_acquired, jmc$kol_application_modified,
      jmc$kol_application_printing, jmc$kol_application_terminated);

*DECK DECK=JMT$KOL_ENTRY_KIND EXPAND=FALSE

  TYPE
    jmt$kol_entry_kind = (jmc$kol_unused_entry, jmc$kol_deferred_entry,
          jmc$kol_queued_entry, jmc$kol_initiated_entry,
          jmc$kol_terminated_entry, jmc$kol_completed_entry);


*DECK DECK=JMT$KOL_ENTRY_KIND_SET EXPAND=FALSE

  TYPE
    jmt$kol_entry_kind_set = SET OF jmt$kol_entry_kind;

*copyc jmt$kol_entry_kind
*DECK DECK=JMT$KOL_INDEX EXPAND=FALSE

  TYPE
    jmt$kol_index = 0 .. jmc$kol_maximum_entries;

  CONST
    jmc$kol_undefined_index = 0;

*copyc jmc$kol_maximum_entries
*DECK DECK=JMT$KOL_ORDINAL EXPAND=FALSE

{ * * * * * common deck JMDKOLO: Known Job List Ordinal * * * * * }

TYPE
  jmt$kol_ordinal = 0 .. jmc$max_kol_ord;

{ * * * * * end of deck jmdkolo . . . . . . . . . . . . * * * * * }

*copyc JMC$MAXIMUM_CONSTANTS
*DECK DECK=JMT$KOL_SEARCH_KEYS EXPAND=FALSE

  TYPE
    jmt$kol_search_keys = (jmc$kol_system_file_name, jmc$kol_user_file_name,
          jmc$kol_output_controller, jmc$kol_login_user_id,
          jmc$kol_null_criterion);

*DECK DECK=JMT$KQL_APPLICATION_STATE EXPAND=FALSE

  TYPE
    jmt$kql_application_state = (jmc$kql_application_unused,
          jmc$kql_application_new, jmc$kql_application_acquired,
          jmc$kql_application_modified, jmc$kql_application_processing,
          jmc$kql_application_terminated);

*DECK DECK=JMT$KQL_ENTRY_KIND EXPAND=FALSE

  TYPE
    jmt$kql_entry_kind = (jmc$kql_unused_entry, jmc$kql_deferred_entry,
          jmc$kql_queued_entry, jmc$kql_initiated_entry,
          jmc$kql_terminated_entry, jmc$kql_completed_entry);

*DECK DECK=JMT$KQL_ENTRY_KIND_SET EXPAND=FALSE

  TYPE
    jmt$kql_entry_kind_set = set of jmt$kql_entry_kind;

*copyc jmt$kql_entry_kind
*DECK DECK=JMT$KQL_INDEX EXPAND=FALSE

  TYPE
    jmt$kql_index = 0 .. jmc$maximum_qfile_count;

  CONST
    jmc$kql_undefined_index = 0;

*copyc jmc$maximum_qfile_count
*DECK DECK=JMT$LEVELED_JOB_CONNECT_DATA EXPAND=FALSE

  TYPE
    jmt$leveled_job_connect_data = record
      system_job_name: jmt$system_supplied_name,
      destination_mainframe_id: pmt$mainframe_id,
      encrypted_password: ost$name,
    recend;

*copyc jmt$system_supplied_name
*copyc ost$name
*copyc pmt$mainframe_id
*DECK DECK=JMT$LEVELED_JOB_LIST EXPAND=FALSE
*DECK DECK=JMT$LOCK_FUNCTIONS EXPAND=FALSE
TYPE
     jmt$lock_functions = (lock_ajl,lock_kjl,unlock_ajl,unlock_kjl,lock_both,
                         unlock_both);
*DECK DECK=JMT$LONG_WAIT_SWAP_THRESHOLD EXPAND=FALSE

  TYPE
    jmt$long_wait_swap_threshold = ARRAY [jmc$lowest_dispatching_priority ..
          jmc$highest_dispatch_priority] of mmt$page_frame_index;

*copyc jmt$dispatching_priority
*copyc mmt$page_frame_index
*DECK DECK=JMT$LONG_WAIT_THINK_TIME EXPAND=FALSE

*IF $true(osv$unix)

{ This is a millisecond value, up to 20 hours.

  TYPE
    jmt$long_wait_think_time = 0 .. jmc$high_long_wait_think_time;

*ELSE

{ This is a microsecond value, up to 20 hours.

  TYPE
    jmt$long_wait_think_time = 0 .. jmc$high_long_wait_think_time * 1000;

*IFEND

{ The following constants define the range of values permitted on SCL
{ parameter definitions.  The value is specified in milliseconds on the
{ scheduling commands.

  CONST
    jmc$low_long_wait_think_time = 0,
    jmc$high_long_wait_think_time = 864400000;
*DECK DECK=JMT$MAGNETIC_TAPE_LIMIT EXPAND=FALSE

  TYPE
    jmt$magnetic_tape_limit = 0 .. jmc$magnetic_tape_limit_maximum;

  CONST
    jmc$magnetic_tape_limit_maximum = jmc$highest_magnetic_tape_limit +
          jmc$keyword_offset_maximum;

{ The following constants define the range of values permitted on SCL
{ parameter definitions and the internal representation for the keywords,
{ UNLIMITED, UNSPECIFIED, REQUIRED and SYSTEM_DEFAULT.

  CONST
    jmc$lowest_magnetic_tape_limit = 0,
    jmc$highest_magnetic_tape_limit = 100,
    jmc$unlimited_mag_tape_limit = jmc$highest_magnetic_tape_limit +
          jmc$unlimited_offset,
    jmc$unspecified_mag_tape_limit = jmc$highest_magnetic_tape_limit +
          jmc$unspecified_offset,
    jmc$required_mag_tape_limit = jmc$highest_magnetic_tape_limit +
          jmc$required_offset,
    jmc$system_default_mag_tape_lim = jmc$highest_magnetic_tape_limit +
          jmc$system_default_offset;

*copyc jmc$attribute_keyword_offsets
*DECK DECK=JMT$MAINFRAMES_SEARCHED_LIST EXPAND=FALSE

  TYPE
    jmt$mainframes_searched_list = array [1 .. jmc$maximum_mainframes] of
          pmt$binary_mainframe_id;

*copyc jmc$maximum_mainframes
*copyc pmt$binary_mainframe_id
*DECK DECK=JMT$MAINFRAME_CATEGORIES EXPAND=FALSE

  TYPE
    jmt$mainframe_categories = array [1 .. * ] of jmt$mainframe_entry;

  TYPE
    jmt$mainframe_entry = record
      mainframe_id: pmt$mainframe_id,
      binary_mainframe_id: pmt$binary_mainframe_id,
      excluded: jmt$job_category_set,
      required: jmt$job_category_set,
    recend;

*copyc jmt$job_category_set
*copyc pmt$binary_mainframe_id
*copyc pmt$mainframe_id
*DECK DECK=JMT$MAINFRAME_LEVELING_DATA EXPAND=FALSE

  TYPE
    jmt$mainframe_leveling_data = record
      mainframe_id: pmt$mainframe_id,
      mainframe_data_size: ost$segment_length,
    recend;

*copyc osd$virtual_address
*copyc pmt$mainframe_id
*DECK DECK=JMT$MAXIMUM_ACTIVE_JOBS EXPAND=FALSE

  TYPE
    jmt$maximum_active_jobs = 0 .. jmc$max_active_jobs;

{ The following constants define the range of values permitted on SCL
{ parameter definitions and the internal representation for the keyword,
{ UNLIMITED.

  CONST
    jmc$lowest_maximum_active_jobs = 0,
    jmc$highest_maximum_active_jobs = jmc$max_active_jobs,
    jmc$unlimited_max_active_jobs = jmc$max_active_jobs;

*copyc jmc$maximum_constants
*DECK DECK=JMT$MAXIMUM_INITIATED_JOBS EXPAND=FALSE

  TYPE
    jmt$maximum_initiated_jobs = 0 .. jmc$max_ijl_ord;

{ The following constants define the range of values permitted on SCL
{ parameter definitions and the internal representation for the keyword,
{ UNLIMITED.

  CONST
    jmc$lowest_max_initiated_jobs = 0,
    jmc$highest_max_initiated_jobs = 10000,
    jmc$unlimited_max_init_jobs = jmc$highest_max_initiated_jobs;

*copyc jmc$maximum_constants
*DECK DECK=JMT$MAXIMUM_MAINFRAMES EXPAND=FALSE

  TYPE
    jmt$maximum_mainframes = 0 .. jmc$maximum_mainframes;

*copyc jmc$maximum_mainframes
*DECK DECK=JMT$MODIFY_DISPLAY_ATTRIBUTES EXPAND=FALSE

  TYPE
    jmt$modify_display_attributes = procedure
           (    the_object: jmt$profile_object;
            VAR attributes: jmt$object_attribute;
            VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$profile_object
*copyc jmt$object_attribute
*copyc ost$status
?? POP ??
*DECK DECK=JMT$MTR_SERV_CLASS_STAT_ENTRY EXPAND=FALSE
  TYPE
    jmt$mtr_serv_class_stat_entry = record
      cp_time: jmt$service_class_cp_time,
      page_faults: jmt$service_class_page_faults,
      swap_stats: jmt$service_class_swap_stats,
    recend,

    jmt$service_class_cp_time = record
      job_mode: jmt$sc_cp_stat,
      monitor_mode: jmt$sc_cp_stat,
    recend,

    jmt$service_class_page_faults = record
      disk: jmt$sc_pf_stat,
      reclaimed: jmt$sc_pf_stat,
      assigned: jmt$sc_pf_stat,
    recend,

    jmt$service_class_swap_stats = record
      long_wait_swaps: jmt$sc_swap_count,
      job_mode_swaps: jmt$sc_swap_count,
      swapped_pages: jmt$sc_swap_stat,
      residence_time: jmt$sc_swap_stat,
      swap_wait_time: jmt$sc_swap_stat,
      scheduler_swapins: jmt$sc_swap_count,
      swap_to_ready_time: jmt$sc_swap_stat,
      swap_to_ready_count: jmt$sc_swap_count,
    recend,

    jmt$sc_cp_stat = 0 .. 0ffffffffffff(16),
    jmt$sc_pf_stat = 0 .. 0ffffffffffff(16),
    jmt$sc_swap_stat = 0 .. 0ffffffffffff(16),
    jmt$sc_swap_count = 0 .. 0ffffffffff(16);

*DECK DECK=JMT$NAME EXPAND=FALSE

  TYPE
    jmt$name = record
      case kind: jmt$name_kind of
      = jmc$system_supplied_name =
        system_supplied_name: jmt$system_supplied_name,
      = jmc$user_supplied_name =
        user_supplied_name: jmt$user_supplied_name,
      casend,
    recend;

  TYPE
    jmt$name_kind = (jmc$system_supplied_name, jmc$user_supplied_name);

*copyc jmt$user_supplied_name
*copyc jmt$system_supplied_name
*DECK DECK=JMT$NAME_LIST EXPAND=FALSE

  TYPE
    jmt$name_list = ARRAY [ 1 .. *] OF jmt$name;

*copyc jmt$name
*DECK DECK=JMT$NODE EXPAND=FALSE

  TYPE
    jmt$phases = (active, queued_thd, swapped),

    jmt$node =  RECORD
               dispatching_priority: jmt$dispatching_priority,
               priority: jmt$job_priority,
               ws: mmt$page_frame_index,
               CASE qtype: jmt$phases OF
                 = active, swapped =
                      ijl_ord: jmt$ijl_ordinal,
                      service_since_swap: jmt$service_accumulator,
                 = queued_thd =
                      job_class: jmt$job_class,
               CASEND
               RECEND;

*copyc jmt$dispatching_priority
*copyc jmt$job_class
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc jmt$job_priority
*DECK DECK=JMT$OBJECT_ATTRIBUTE EXPAND=FALSE

  TYPE
    jmt$object_attribute = record
      case kind: jmt$object_attribute_kinds of
      = jmc$type, jmc$list, jmc$range, jmc$editable_list =
        attribute_list: ^jmt$object_attribute_list,
      = jmc$number, jmc$dispatching_priority =
        number: integer,
      = jmc$boolean =
        bool: boolean,
      = jmc$name =
        name: ^ost$name,
      = jmc$file =
        file: ^fst$file_reference,
      = jmc$object =
        object_p: jmt$profile_object_reference,
        profile_object_index: 0 .. jmc$maximum_objects_on_profile,
      casend,
    recend;

  TYPE
    jmt$object_attribute_list = array [1 .. * ] of jmt$object_attribute;

*copyc fst$file_reference
*copyc jmc$maximum_objects_on_profile
*copyc jmc$profile_constants
*copyc jmt$object_attribute_index
*copyc jmt$object_attribute_kinds
*copyc jmt$profile_object
*copyc ost$name
*DECK DECK=JMT$OBJECT_ATTRIBUTE_INDEX EXPAND=FALSE

  TYPE
    jmt$object_attribute_index = 0 .. jmc$max_attribute_index;

  CONST
    jmc$max_attribute_index = 4000;

*DECK DECK=JMT$OBJECT_ATTRIBUTE_KINDS EXPAND=FALSE

  TYPE
    jmt$object_attribute_kinds = (jmc$type, jmc$list, jmc$editable_list,
          jmc$range, jmc$number, jmc$boolean, jmc$name, jmc$file, jmc$object,
          jmc$dispatching_priority, jmc$unused_kind_c, jmc$unused_kind_d,
          jmc$empty, jmc$none, jmc$all, jmc$unlimited, jmc$unspecified,
          jmc$default, jmc$system_default);

*DECK DECK=JMT$OBJECT_DEFINITION EXPAND=FALSE

  TYPE
    jmt$object_definition = array [jmt$profile_object_kinds] of record
      declaration: jmt$profile_declaration,
      fetch_attribute_defaults: jmt$fetch_attribute_defaults,
      maximum_number_of_objects: 0 .. jmc$maximum_objects_on_profile,
      check_attributes: jmt$attribute_check_routine,
      sorted_parameters: ^jmt$object_parameter_list,
    recend;

  TYPE
    jmt$fetch_attribute_defaults = ^procedure
           (    profile: jmt$profile_data;
                the_object: jmt$profile_object;
            VAR defaults: jmt$object_attribute);

  TYPE
    jmt$attribute_check_routine = ^procedure
           (    the_object: jmt$profile_object;
            VAR status: ost$status);

*copyc jmc$maximum_objects_on_profile
*copyc jmt$object_attribute
*copyc jmt$object_parameter_list
*copyc jmt$profile_declaration
*copyc jmt$profile_object
*copyc jmt$profile_object_kinds
*copyc ost$status
*DECK DECK=JMT$OBJECT_PARAMETER_LIST EXPAND=FALSE

  TYPE
    jmt$object_parameter_list = array [1 .. * ] of
          jmt$object_parameter_element;

  TYPE
    jmt$object_parameter_element = record
      name: ost$name,
      attribute_index: jmt$object_attribute_index,
      abbreviation: boolean,
    recend;

*DECK DECK=JMT$OPERATOR_REQUEST_LIST EXPAND=FALSE

 TYPE

   jmt$operator_request_list = record
     lock: ost$signature_lock,
     request_list: array[ jmt$request_list_index ] of jmt$request_list_entry,
         recend,

   jmt$request_list_entry = record
     in_use: boolean,
     operator_request:  jmt$operator_request,
     ijl_ordinal: jmt$ijl_ordinal,
     system_supplied_name: jmt$system_supplied_name,
     dispatching_priority: jmt$dispatching_priority,
   recend,

   jmt$request_list_index = 1..10,

   jmt$operator_request = (jmc$or_swapout, jmc$or_swapin,
     jmc$or_change_dispatching_prio);

*copyc jmt$dispatching_priority
*copyc jmt$ijl_ordinal
*copyc jmt$system_supplied_name
*copyc ost$signature_lock
*DECK DECK=JMT$OUTPUT_APPLICATION_TABLE EXPAND=FALSE

  TYPE
    jmt$output_application_table = array [jmt$output_application_index] of
          jmt$output_application_data;

  TYPE
    jmt$output_application_index = 0 .. jmc$maximum_output_applications;

  CONST
    jmc$unassigned_output_index = 0;

  TYPE
    jmt$output_application_data = record
      application_name: ost$name,
      destination_usage: jmt$destination_usage,
      global_task_id: ost$global_task_id,
      queue_file_password: ost$name,
      state_data: jmt$output_appl_state_data,
    recend;

  TYPE
    jmt$output_appl_state_data = array [jmt$kol_application_state] of
          jmt$output_appl_state_entry;

  TYPE
    jmt$output_appl_state_entry = record
      first_entry: jmt$kol_index,
      last_entry: jmt$kol_index,
      number_of_entries: jmt$output_count_range,
    recend;

*copyc jmc$maximum_output_applications
*copyc jmt$destination_usage
*copyc jmt$kol_application_state
*copyc jmt$kol_index
*copyc jmt$output_count_range
*copyc ost$global_task_id
*copyc ost$name
*DECK DECK=JMT$OUTPUT_ATTRIBUTE_CHANGES EXPAND=FALSE

  TYPE
    jmt$output_attribute_changes = array [1 .. * ] of
          jmt$output_attribute_change;

  TYPE
    jmt$output_attribute_change = record
      case key: jmt$attribute_keys of
      = jmc$comment_banner =
        comment_banner: jmt$output_comment_banner,
      = jmc$copies =
        copies: jmt$output_copy_count,
      = jmc$device =
        device: jmt$output_device,
      = jmc$earliest_print_time =
        earliest_print_time: jmt$date_time,
      = jmc$external_characteristics =
        external_characteristics: jmt$external_characteristics,
      = jmc$forms_code =
        forms_code: jmt$forms_code,
      = jmc$latest_print_time =
        latest_print_time: jmt$date_time,
      = jmc$null_attribute =
        ,
      = jmc$output_class =
        output_class: jmt$output_class_name,
      = jmc$output_deferred_by_operator =
        output_deferred_by_operator: boolean,
      = jmc$output_deferred_by_user =
        output_deferred_by_user: boolean,
      = jmc$output_destination =
        output_destination: ost$name,
      = jmc$output_destination_family =
        output_destination_family: ost$name,
      = jmc$output_destination_usage =
        output_destination_usage: jmt$destination_usage,
      = jmc$output_priority =
        output_priority: jmt$output_priority,
      = jmc$purge_delay =
        purge_delay: ^jmt$time_increment,
      = jmc$remote_host_directive =
        remote_host_directive: ^jmt$remote_host_directive,
      = jmc$reprint_disposition =
        reprint_disposition: jmt$reprint_disposition,
      = jmc$routing_banner =
        routing_banner: jmt$output_routing_banner,
      = jmc$site_information =
        site_information: ^jmt$site_information,
      = jmc$station =
        station: jmt$station,
      = jmc$station_operator =
        station_operator: jmt$station_operator,
      = jmc$user_information =
        user_information: ^jmt$user_information,
      = jmc$vertical_print_density =
        vertical_print_density: jmt$vertical_print_density,
      = jmc$vfu_load_procedure =
        vfu_load_procedure: jmt$vfu_load_procedure,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$date_time
*copyc jmt$destination_usage
*copyc jmt$external_characteristics
*copyc jmt$forms_code
*copyc jmt$output_class_name
*copyc jmt$output_comment_banner
*copyc jmt$output_copy_count
*copyc jmt$output_device
*copyc jmt$output_priority
*copyc jmt$output_routing_banner
*copyc jmt$remote_host_directive
*copyc jmt$reprint_disposition
*copyc jmt$site_information
*copyc jmt$station
*copyc jmt$station_operator
*copyc jmt$time_increment
*copyc jmt$user_information
*copyc jmt$vertical_print_density
*copyc jmt$vfu_load_procedure
*copyc ost$name
*DECK DECK=JMT$OUTPUT_ATTRIBUTE_OPTIONS EXPAND=FALSE

  TYPE
    jmt$output_attribute_options = array [1 .. * ] of
          jmt$output_attribute_option;

  TYPE
    jmt$output_attribute_option = record
      case key: jmt$attribute_keys of
      = jmc$continue_request_to_servers =
        continue_request_to_servers: boolean,
      = jmc$control_family =
        control_family: ost$name,
      = jmc$control_user =
        control_user: ost$name,
      = jmc$login_family =
        login_family: ost$name,
      = jmc$login_user =
        login_user: ost$name,
      = jmc$name_list =
        name_list: ^jmt$name_list,
      = jmc$null_attribute =
        ,
      = jmc$output_deferred_by_operator =
        output_deferred_by_operator: boolean,
      = jmc$output_deferred_by_user =
        output_deferred_by_user: boolean,
      = jmc$output_destination_usage =
        output_destination_usage: jmt$destination_usage,
      = jmc$output_state_set =
        output_state_set: jmt$output_state_set,
      = jmc$system_job_name =
        system_job_name: jmt$system_supplied_name,
      = jmc$user_job_name =
        user_job_name: jmt$user_supplied_name,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$destination_usage
*copyc jmt$name_list
*copyc jmt$output_state_set
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc ost$name
*DECK DECK=JMT$OUTPUT_ATTRIBUTE_RESULTS EXPAND=FALSE

  TYPE
    jmt$output_attribute_results = array [1 .. * ] of ^array [1 .. * ] of
          jmt$output_attribute_result;

  TYPE
    jmt$output_attribute_result = record
      case key: jmt$attribute_keys of
      = jmc$comment_banner =
        comment_banner: jmt$output_comment_banner,
      = jmc$control_family =
        control_family: ost$name,
      = jmc$control_user =
        control_user: ost$name,
      = jmc$copies =
        copies: jmt$output_copy_count,
      = jmc$copies_printed =
        copies_printed: jmt$output_copy_count,
      = jmc$data_mode =
        data_mode: jmt$data_mode,
      = jmc$device =
        device: jmt$output_device,
      = jmc$device_type =
        device_type: jmt$output_device_type,
      = jmc$earliest_print_time =
        earliest_print_time: jmt$date_time,
      = jmc$external_characteristics =
        external_characteristics: jmt$external_characteristics,
      = jmc$file_position =
        file_position: jmt$output_file_position,
      = jmc$file_size =
        file_size: jmt$output_file_size,
      = jmc$forms_code =
        forms_code: jmt$forms_code,
      = jmc$latest_print_time =
        latest_print_time: jmt$date_time,
      = jmc$login_account =
        login_account: ost$name,
      = jmc$login_family =
        login_family: ost$name,
      = jmc$login_project =
        login_project: ost$name,
      = jmc$login_user =
        login_user: ost$name,
      = jmc$null_attribute =
        ,
      = jmc$origin_application_name =
        origin_application_name: ost$name,
      = jmc$output_class =
        output_class: jmt$output_class_name,
      = jmc$output_deferred_by_operator =
        output_deferred_by_operator: boolean,
      = jmc$output_deferred_by_user =
        output_deferred_by_user: boolean,
      = jmc$output_destination =
        output_destination: ost$name,
      = jmc$output_destination_family = { operator_family
        output_destination_family: ost$name,
      = jmc$output_destination_usage =
        output_destination_usage: jmt$destination_usage,
      = jmc$output_priority =
        output_priority: jmt$output_priority,
      = jmc$output_state =
        output_state: jmt$output_state,
      = jmc$output_submission_time =
        output_submission_time: ost$date_time,
      = jmc$purge_delay =
        purge_delay: ^jmt$time_increment,
      = jmc$remote_host_directive =
        remote_host_directive: ^jmt$remote_host_directive,
      = jmc$routing_banner =
        routing_banner: jmt$output_routing_banner,
      = jmc$site_information =
        site_information: ^jmt$site_information,
      = jmc$station =
        station: jmt$station,
      = jmc$station_operator = { operator_user
        station_operator: jmt$station_operator,
      = jmc$system_file_name =
        system_file_name: jmt$system_supplied_name,
      = jmc$system_job_name =
        system_job_name: jmt$system_supplied_name,
      = jmc$user_file_name =
        user_file_name: jmt$user_supplied_name,
      = jmc$user_information =
        user_information: ^jmt$user_information,
      = jmc$user_job_name =
        user_job_name: jmt$user_supplied_name,
      = jmc$vertical_print_density =
        vertical_print_density: jmt$vertical_print_density,
      = jmc$vfu_load_procedure =
        vfu_load_procedure: jmt$vfu_load_procedure,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$data_mode
*copyc jmt$date_time
*copyc jmt$destination_usage
*copyc jmt$external_characteristics
*copyc jmt$forms_code
*copyc jmt$output_class_name
*copyc jmt$output_comment_banner
*copyc jmt$output_copy_count
*copyc jmt$output_device
*copyc jmt$output_device_type
*copyc jmt$output_file_position
*copyc jmt$output_file_size
*copyc jmt$output_priority
*copyc jmt$output_routing_banner
*copyc jmt$output_state
*copyc jmt$remote_host_directive
*copyc jmt$site_information
*copyc jmt$station
*copyc jmt$station_operator
*copyc jmt$system_supplied_name
*copyc jmt$time_increment
*copyc jmt$user_information
*copyc jmt$user_supplied_name
*copyc jmt$vertical_print_density
*copyc jmt$vfu_load_procedure
*copyc ost$date_time
*copyc ost$name
*copyc ost$name
*DECK DECK=JMT$OUTPUT_CLASS EXPAND=FALSE
{
*DECK DECK=JMT$OUTPUT_CLASS_ATTRIBUTES EXPAND=FALSE

  TYPE
    jmt$output_class_attributes = RECORD

{ Define the Definition group attributes.

      defined: boolean,
      index: jmt$output_class_index,
      profile_identification: ost$name,
      name: jmt$output_class_name,
      abbreviation: jmt$output_class_name,
      enable_class_scheduling: boolean,

{ Define the Priority group attributes.

      delivery_priority: jmt$delivery_priority,
      output_age_interval: jmt$priority_aging_interval, { microseconds

    RECEND;


  TYPE
    jmt$delivery_priority = RECORD
      initial: jmt$job_priority,
      maximum: jmt$job_priority,
      increment: jmt$job_priority,
    RECEND;

*copyc jmt$job_priority
*copyc jmt$output_class_index
*copyc jmt$output_class_name
*copyc jmt$priority_aging_interval
*copyc ost$name
*DECK DECK=JMT$OUTPUT_CLASS_INDEX EXPAND=FALSE

{ This deck defines the type for output classes.  Any time the output
{ class table (jmv$output_class_table_p) needs to be scanned, the scan
{ should be from jmc$system_output_class (the first defined class) to
{ jmv$maximum_output_class_in_use (the index of the highest defined_class).

  CONST
    jmc$null_output_class = 0,
    jmc$system_output_class = 1,
    jmc$lowest_site_output_class = 2,
    jmc$minimum_output_classes = 1,
    jmc$maximum_output_classes = 63;

  TYPE
    jmt$output_class_index = 0 .. jmc$maximum_output_classes;
*DECK DECK=JMT$OUTPUT_CLASS_NAME EXPAND=FALSE

  TYPE
    jmt$output_class_name = ost$name;

*copyc ost$name

*DECK DECK=JMT$OUTPUT_CLASS_TABLE EXPAND=FALSE

{ This deck defines the type for the output class table.  Any time the output class table
{ (jmv$output_class_table_p) needs to be scanned, the scan should be from jmc$system_output_class
{ (the first defined class) to jmv$maximum_output_class_in_use (the index of the highest defined class).

  TYPE
    jmt$output_class_table = ARRAY [1 .. *] OF jmt$output_class_attributes;

*copyc jmt$output_class_attributes
*DECK DECK=JMT$OUTPUT_COMMENT_BANNER EXPAND=FALSE

  TYPE
    jmt$output_comment_banner = STRING (jmc$output_comment_banner_size);

  CONST
    jmc$output_comment_banner_size = 31;

*DECK DECK=JMT$OUTPUT_COPY_COUNT EXPAND=FALSE

  TYPE
    jmt$output_copy_count = 0 .. jmc$output_copy_count_max;

  CONST
    jmc$output_copy_count_max = 100;
*DECK DECK=JMT$OUTPUT_COUNTS EXPAND=FALSE

  TYPE
    jmt$output_counts = record
      state_data: array [jmt$output_state] of jmt$output_count_range,
    recend;

*copyc jmt$output_count_range
*copyc jmt$output_state
*DECK DECK=JMT$OUTPUT_COUNT_RANGE EXPAND=FALSE

  TYPE
    jmt$output_count_range = 0 .. jmc$maximum_output_count;

*copyc jmc$maximum_output_count
*DECK DECK=JMT$OUTPUT_DESCRIPTOR EXPAND=FALSE

  TYPE
    jmt$output_descriptor = record
      comment_banner: jmt$output_comment_banner,
      control_family: ost$name,
      control_user: ost$name,
      copies: jmt$output_copy_count,
      copies_printed: jmt$output_copy_count,
      data_declaration: jmt$data_declaration,
      data_mode: jmt$data_mode,
      device: jmt$output_device,
      device_type: jmt$output_device_type,
      disposition_code: jmt$disposition_code,
      dual_state_account: avt$account_name,
      dual_state_family_name: ost$name,
      dual_state_password: avt$password,
      dual_state_project: avt$project_name,
      dual_state_user: ost$name,
      earliest_print_time: jmt$date_time,
      external_characteristics: jmt$external_characteristics,
      file_position: jmt$output_file_position,
      file_size: jmt$output_file_size,
      forms_code: jmt$forms_code,
      implicit_routing_text: jmt$implicit_routing_text,
      latest_print_time: jmt$date_time,
      login_account: avt$account_name,
      login_family: ost$name,
      login_project: avt$project_name,
      login_user: ost$name,
      originating_application_name: ost$name,
      output_class: jmt$output_class_name,
      output_destination: ost$name,
      output_destination_family: ost$name, { operator_family
      output_destination_usage: jmt$destination_usage,
      output_disposition_key: jmt$output_disposition_keys,
      output_priority: jmt$output_priority,
      output_submission_time: ost$date_time,
      page_format: amt$page_format,
      page_length: amt$page_length,
      page_width: amt$page_width,
      purge_delay: jmt$time_increment,
      remote_host_directive: jmt$remote_host_directive,
      routing_banner: jmt$output_routing_banner,
      site_information: jmt$site_information,
      source_logical_id: jmt$source_logical_id,
      station: jmt$station,
      station_operator: jmt$station_operator, { operator_user
      system_file_name: jmt$system_supplied_name,
      system_job_name: jmt$system_supplied_name,
      system_routing_text: jmt$system_routing_text,
      user_file_name: jmt$user_supplied_name,
      user_information: jmt$user_information,
      user_job_name: jmt$user_supplied_name,
      vertical_print_density: jmt$vertical_print_density,
      vfu_load_procedure: jmt$vfu_load_procedure,
    recend;

*copyc amt$page_format
*copyc amt$page_length
*copyc amt$page_width
*copyc avt$account_name
*copyc avt$password
*copyc avt$project_name
*copyc jmt$data_declaration
*copyc jmt$data_mode
*copyc jmt$date_time
*copyc jmt$destination_usage
*copyc jmt$disposition_code
*copyc jmt$external_characteristics
*copyc jmt$forms_code
*copyc jmt$implicit_routing_text
*copyc jmt$output_class_name
*copyc jmt$output_comment_banner
*copyc jmt$output_copy_count
*copyc jmt$output_device
*copyc jmt$output_device_type
*copyc jmt$output_disposition_keys
*copyc jmt$output_file_position
*copyc jmt$output_file_size
*copyc jmt$output_priority
*copyc jmt$output_routing_banner
*copyc jmt$remote_host_directive
*copyc jmt$site_information
*copyc jmt$source_logical_id
*copyc jmt$station
*copyc jmt$station_operator
*copyc jmt$system_routing_text
*copyc jmt$system_supplied_name
*copyc jmt$time_increment
*copyc jmt$user_information
*copyc jmt$user_supplied_name
*copyc jmt$vertical_print_density
*copyc jmt$vfu_load_procedure
*copyc ost$date_time
*copyc ost$name
*DECK DECK=JMT$OUTPUT_DESTINATION EXPAND=FALSE

  TYPE
    jmt$output_destination = ost$user_identification;

*copyc ost$user_identification
*DECK DECK=JMT$OUTPUT_DEVICE EXPAND=FALSE

  TYPE
    jmt$output_device = ost$name;

*copyc ost$name
*DECK DECK=JMT$OUTPUT_DEVICE_TYPE EXPAND=FALSE

  TYPE
    jmt$output_device_type = (jmc$output_device_printer,
          jmc$output_device_plotter, jmc$output_device_punch);
*DECK DECK=JMT$OUTPUT_DISPOSITION EXPAND=FALSE

  TYPE
    jmt$output_disposition = record
      case key: jmt$output_disposition_keys of
      = jmc$discard_all_output =
        ,
      = jmc$discard_standard_output =
        ,
      = jmc$local_output_disposition =
        ,
      = jmc$normal_output_disposition =
        ,
      = jmc$standard_output_path =
        standard_output_path: ^fst$path,
      = jmc$wait_queue_path =
        wait_queue_path: ^fst$path,
      casend,
    recend;

*copyc fst$path
*copyc jmt$output_disposition_keys
*DECK DECK=JMT$OUTPUT_DISPOSITION_KEYS EXPAND=FALSE

  TYPE
    jmt$output_disposition_keys = (jmc$discard_all_output,
          jmc$discard_standard_output, jmc$local_output_disposition,
          jmc$normal_output_disposition, jmc$standard_output_path,
          jmc$wait_queue_path);

*DECK DECK=JMT$OUTPUT_FILE_POSITION EXPAND=FALSE

  TYPE
    jmt$output_file_position = 0 .. 07fffffff(16);
*DECK DECK=JMT$OUTPUT_FILE_SIZE EXPAND=FALSE

  TYPE
    jmt$output_file_size = 0 .. 07fffffff(16);
*DECK DECK=JMT$OUTPUT_FILE_STATISTIC_DATA EXPAND=FALSE

  TYPE
    jmt$output_file_statistic_data = record
      connect_time: ost$non_negative_integers,
      number_of_lines: ost$non_negative_integers,
      output_descriptor: jmt$output_descriptor,
      network_file_name: fst$path,
    recend;

*copyc fst$path
*copyc jmt$output_descriptor
*copyc osd$integer_limits
*DECK DECK=JMT$OUTPUT_MECHANISM EXPAND=FALSE

  TYPE
    jmt$output_mechanism = (jmc$remote_host_facility,
          jmc$status_and_control_facility);
*DECK DECK=JMT$OUTPUT_PARAMETERS EXPAND=FALSE

  TYPE
    jmt$output_parameters = record
      output_parameter_count : 0 .. jmc$max_output_parameters,
      output_parameter : STRING (jmc$max_output_parameters),
    recend;

  CONST
    jmc$max_output_parameters = 256;
*DECK DECK=JMT$OUTPUT_PRIORITY EXPAND=FALSE

  TYPE
    jmt$output_priority = ost$name;

*copyc ost$name
*DECK DECK=JMT$OUTPUT_QUEUE_RESIDENCY_DATA EXPAND=FALSE

  TYPE
    jmt$output_queue_residency_data = record
      output_file_path: ^pft$path,
    recend;

*copyc pfd$permanent_file_definitions
*DECK DECK=JMT$OUTPUT_ROUTING_BANNER EXPAND=FALSE

  TYPE
    jmt$output_routing_banner = STRING (jmc$output_routing_banner_size);

  CONST
    jmc$output_routing_banner_size = 31;
*DECK DECK=JMT$OUTPUT_STATE EXPAND=FALSE

  TYPE
    jmt$output_state = (jmc$deferred_output, jmc$queued_output,
          jmc$initiated_output, jmc$terminated_output, jmc$completed_output);



*DECK DECK=JMT$OUTPUT_STATE_SET EXPAND=FALSE

  TYPE
    jmt$output_state_set = SET OF jmt$output_state;

*copyc jmt$output_state
*DECK DECK=JMT$OUTPUT_STATUS_COUNT EXPAND=FALSE

  TYPE
    jmt$output_status_count = 0 .. jmc$max_output_status_count;

  CONST
    jmc$max_output_status_count = jmc$maximum_output_count;

*copyc jmc$maximum_output_count
*DECK DECK=JMT$OUTPUT_STATUS_OPTIONS EXPAND=FALSE

  TYPE
    jmt$output_status_options = array [1 .. * ] of jmt$output_status_option;

  TYPE
    jmt$output_status_option = record
      case key: jmt$attribute_keys of
      = jmc$continue_request_to_servers =
        continue_request_to_servers: boolean,
      = jmc$control_family =
        control_family: ost$name,
      = jmc$control_user =
        control_user: ost$name,
      = jmc$login_family =
        login_family: ost$name,
      = jmc$login_user =
        login_user: ost$name,
      = jmc$name_list =
        name_list: ^jmt$name_list,
      = jmc$null_attribute =
        ,
      = jmc$output_deferred_by_operator =
        output_deferred_by_operator: boolean,
      = jmc$output_deferred_by_user =
        output_deferred_by_user: boolean,
      = jmc$output_destination_usage =
        output_destination_usage: jmt$destination_usage,
      = jmc$output_state_set =
        output_state_set: jmt$output_state_set,
      = jmc$privilege =
        privilege: jmt$privilege,
      = jmc$system_job_name =
        system_job_name: jmt$system_supplied_name,
      = jmc$user_job_name =
        user_job_name: jmt$user_supplied_name,

{ The following option(s) can only be used by NOS/VE.

      = jmc$user_identification =
        user_identification: ^ost$user_identification,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$destination_usage
*copyc jmt$name_list
*copyc jmt$privilege
*copyc jmt$output_state_set
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc ost$name
*copyc ost$user_identification
*DECK DECK=JMT$OUTPUT_STATUS_RESULTS EXPAND=FALSE

  TYPE
    jmt$output_status_results = array [1 .. * ] of ^array [1 .. * ] of
          jmt$output_status_result;

  TYPE
    jmt$output_status_result = record
      case key: jmt$attribute_keys of
      = jmc$client_mainframe_id =
        client_mainframe_id: pmt$mainframe_id,
      = jmc$control_family =
        control_family: ost$name,
      = jmc$control_user =
        control_user: ost$name,
      = jmc$login_family =
        login_family: ost$name,
      = jmc$login_user =
        login_user: ost$name,
      = jmc$null_attribute =
        ,
      = jmc$output_deferred_by_operator =
        output_deferred_by_operator: boolean,
      = jmc$output_deferred_by_user =
        output_deferred_by_user: boolean,
      = jmc$output_destination_usage =
        output_destination_usage: jmt$destination_usage,
      = jmc$output_state =
        output_state: jmt$output_state,
      = jmc$system_file_name =
        system_file_name: jmt$system_supplied_name,
      = jmc$system_job_name =
        system_job_name: jmt$system_supplied_name,
      = jmc$user_file_name =
        user_file_name: jmt$user_supplied_name,
      = jmc$user_job_name =
        user_job_name: jmt$user_supplied_name,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$destination_usage
*copyc jmt$output_state
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc ost$name
*copyc pmt$mainframe_id
*DECK DECK=JMT$OUTPUT_STATUS_UPDATES EXPAND=FALSE

  TYPE
    jmt$output_status_updates = array [1 .. * ] of jmt$output_status_update;

  TYPE
    jmt$output_status_update = record
      case key: jmt$attribute_keys of
      = jmc$copies_printed =
        copies_printed: jmt$output_copy_count,
      = jmc$file_position =
        file_position: jmt$output_file_position,
      = jmc$null_attribute =
        ,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$output_copy_count
*copyc jmt$output_file_position
*DECK DECK=JMT$OUTPUT_SUBMISSION_OPTIONS EXPAND=FALSE

  TYPE
    jmt$output_submission_options = array [1 .. * ] of
          jmt$output_submission_option;

  TYPE
    jmt$output_submission_option = record
      case key: jmt$attribute_keys of
      = jmc$comment_banner =
        comment_banner: jmt$output_comment_banner,
      = jmc$copies =
        copies: jmt$output_copy_count,
      = jmc$data_mode =
        data_mode: jmt$data_mode,
      = jmc$device =
        device: jmt$output_device,
      = jmc$device_type =
        device_type: jmt$output_device_type,
      = jmc$earliest_print_time =
        earliest_print_time: jmt$date_time,
      = jmc$external_characteristics =
        external_characteristics: jmt$external_characteristics,
      = jmc$forms_code =
        forms_code: jmt$forms_code,
      = jmc$latest_print_time =
        latest_print_time: jmt$date_time,
      = jmc$null_attribute =
        ,
      = jmc$output_class =
        output_class: jmt$output_class_name,
      = jmc$output_deferred_by_user =
        output_deferred_by_user: boolean,
      = jmc$output_destination =
        output_destination: ost$name,
      = jmc$output_destination_family = { operator_family
        output_destination_family: ost$name,
      = jmc$output_destination_usage =
        output_destination_usage: jmt$destination_usage,
      = jmc$output_disposition =
        output_disposition: jmt$output_disposition,
      = jmc$output_priority =
        output_priority: jmt$output_priority,
      = jmc$purge_delay =
        purge_delay: ^jmt$time_increment,
      = jmc$remote_host_directive =
        remote_host_directive: ^jmt$remote_host_directive,
      = jmc$routing_banner =
        routing_banner: jmt$output_routing_banner,
      = jmc$station =
        station: jmt$station,
      = jmc$station_operator = { operator_user
        station_operator: jmt$station_operator,
      = jmc$user_file_name =
        user_file_name: jmt$user_supplied_name,
      = jmc$user_information =
        user_information: ^jmt$user_information,
      = jmc$vertical_print_density =
        vertical_print_density: jmt$vertical_print_density,
      = jmc$vfu_load_procedure =
        vfu_load_procedure: jmt$vfu_load_procedure,

{ The following selections may only be used by NOS/VE.

      = jmc$control_family =
        control_family: ost$name,
      = jmc$control_user =
        control_user: ost$name,
      = jmc$data_declaration =
        data_declaration: jmt$data_declaration,
      = jmc$disposition_code =
        disposition_code: jmt$disposition_code,
      = jmc$implicit_routing_text =
        implicit_routing_text: ^jmt$implicit_routing_text,
      = jmc$login_account =
        login_account: avt$account_name,
      = jmc$login_family =
        login_family: ost$name,
      = jmc$login_project =
        login_project: avt$project_name,
      = jmc$login_user =
        login_user: ost$name,
      = jmc$origin_application_name =
        origin_application_name: ost$name,
      = jmc$source_logical_id =
        source_logical_id: jmt$source_logical_id,
      = jmc$system_file_name =
        system_file_name: jmt$system_supplied_name,
      = jmc$system_routing_text =
        system_routing_text: ^jmt$system_routing_text,
      = jmc$user_job_name =
        user_job_name: jmt$user_supplied_name,
      casend,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc jmt$attribute_keys
*copyc jmt$data_declaration
*copyc jmt$data_mode
*copyc jmt$date_time
*copyc jmt$destination_usage
*copyc jmt$disposition_code
*copyc jmt$external_characteristics
*copyc jmt$forms_code
*copyc jmt$implicit_routing_text
*copyc jmt$output_class_name
*copyc jmt$output_comment_banner
*copyc jmt$output_copy_count
*copyc jmt$output_device
*copyc jmt$output_device_type
*copyc jmt$output_disposition
*copyc jmt$output_priority
*copyc jmt$output_routing_banner
*copyc jmt$remote_host_directive
*copyc jmt$source_logical_id
*copyc jmt$station
*copyc jmt$station_operator
*copyc jmt$system_routing_text
*copyc jmt$system_supplied_name
*copyc jmt$time_increment
*copyc jmt$user_information
*copyc jmt$user_supplied_name
*copyc jmt$vertical_print_density
*copyc jmt$vfu_load_procedure
*copyc ost$name
*DECK DECK=JMT$OUTPUT_SYSTEM_ID EXPAND=FALSE

  TYPE
    jmt$output_system_id = jmt$kol_index;

*copyc jmt$kol_index
*DECK DECK=JMT$OUTPUT_SYSTEM_LABEL EXPAND=FALSE

  TYPE
    jmt$output_system_label = record
      version: jmt$output_system_label_version,
      comment_banner: jmt$output_comment_banner,
      copies_printed: jmt$output_copy_count,
      copy_count: jmt$output_copy_count,
      data_declaration: jmt$data_declaration,
      data_mode: jmt$data_mode,
      device: jmt$output_device,
      device_type: jmt$output_device_type,
      disposition_code: jmt$disposition_code,
      dual_state_account: avt$account_name,
      dual_state_family_name: ost$name,
      dual_state_password: avt$password,
      dual_state_project: avt$project_name,
      dual_state_user: ost$name,
      earliest_print_time: jmt$date_time,
      external_characteristics: jmt$external_characteristics,
      file_position: jmt$output_file_position,
      file_size: jmt$output_file_size,
      forms_code: jmt$forms_code,
      implicit_routing_text: jmt$implicit_routing_text,
      latest_print_time: jmt$date_time,
      login_account: avt$account_name,
      login_project: avt$project_name,
      login_user_identification: ost$user_identification,
      originating_application_name: ost$name,
      output_class: jmt$output_class_name,
      output_controller: ost$user_identification,
      output_deferred_by_operator: boolean,
      output_deferred_by_user: boolean,
      output_destination: ost$name,
      output_destination_family: ost$name, { operator_family
      output_destination_usage: jmt$destination_usage,
      output_disposition_key: jmt$output_disposition_keys,
      output_disposition_time: jmt$date_time,
      output_priority: jmt$output_priority,
      output_submission_time: ost$date_time,
      purge_delay: jmt$time_increment,
      remote_host_directive: jmt$remote_host_directive,
      routing_banner: jmt$output_routing_banner,
      site_information: jmt$site_information,
      source_logical_id: jmt$source_logical_id,
      station: jmt$station,
      station_operator: jmt$station_operator, { operator_user
      system_file_name: jmt$system_supplied_name,
      system_job_name: jmt$system_supplied_name,
      system_routing_text: jmt$system_routing_text,
      user_information: jmt$user_information,
      user_file_name: jmt$user_supplied_name,
      user_job_name: jmt$user_supplied_name,
      vertical_print_density: jmt$vertical_print_density,
      vfu_load_procedure: jmt$vfu_load_procedure,
    recend;

*copyc avt$account_name
*copyc avt$password
*copyc avt$project_name
*copyc jmt$data_declaration
*copyc jmt$data_mode
*copyc jmt$date_time
*copyc jmt$destination_usage
*copyc jmt$disposition_code
*copyc jmt$external_characteristics
*copyc jmt$forms_code
*copyc jmt$implicit_routing_text
*copyc jmt$output_class_name
*copyc jmt$output_comment_banner
*copyc jmt$output_copy_count
*copyc jmt$output_device
*copyc jmt$output_device_type
*copyc jmt$output_disposition_keys
*copyc jmt$output_file_position
*copyc jmt$output_file_size
*copyc jmt$output_mechanism
*copyc jmt$output_priority
*copyc jmt$output_routing_banner
*copyc jmt$output_system_label_version
*copyc jmt$output_term_disposition
*copyc jmt$remote_host_directive
*copyc jmt$site_information
*copyc jmt$source_logical_id
*copyc jmt$station
*copyc jmt$station_operator
*copyc jmt$system_routing_text
*copyc jmt$system_supplied_name
*copyc jmt$time_increment
*copyc jmt$user_information
*copyc jmt$user_supplied_name
*copyc jmt$vertical_print_density
*copyc jmt$vfu_load_procedure
*copyc ost$date_time
*copyc ost$name
*copyc ost$user_identification
*DECK DECK=JMT$OUTPUT_SYSTEM_LABEL_VERSION EXPAND=FALSE

  TYPE
    jmt$output_system_label_version = STRING (jmc$output_sl_version_size);

  CONST
    jmc$output_sl_version_size = 15;
*DECK DECK=JMT$OUTPUT_TERMINATION_OPTIONS EXPAND=FALSE

  TYPE
    jmt$output_termination_options = array [1 .. * ] of
          jmt$output_termination_option;

  TYPE
    jmt$output_termination_option = record
      case key: jmt$attribute_keys of
      = jmc$null_attribute =
        ,
      = jmc$output_state_set =
        output_state_set: jmt$output_state_set,
      = jmc$termination_reason =
        reason: ost$name,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$output_state_set
*copyc ost$name
*DECK DECK=JMT$OUTPUT_TERM_DISPOSITION EXPAND=FALSE

  TYPE
    jmt$output_term_disposition = (jmc$discard_output, jmc$retain_output);
*DECK DECK=JMT$OUTPUT_TERM_DISPOSITION_SET EXPAND=FALSE

  TYPE
    jmt$output_term_disposition_set = SET OF jmt$output_term_disposition;

*copyc jmt$output_term_disposition
*DECK DECK=JMT$PAGE_FAULTS EXPAND=FALSE

  TYPE
    jmt$page_faults = record
      pages_reclaimed_from_memory: jmt$page_fault_range,
      pages_read_from_disk: jmt$page_fault_range,
      new_pages_assigned: jmt$page_fault_range,
    recend;

  TYPE
    jmt$page_fault_range = 0 .. jmc$page_fault_maximum;

*IF $true(osv$unix)

  CONST
    jmc$page_fault_maximum = 7fffffff(16);

*ELSE

  CONST
    jmc$page_fault_maximum = 0ffffffffffff(16);

*IFEND

*DECK DECK=JMT$PAIRED_CONNECTION_DATA EXPAND=FALSE

  TYPE
    jmt$paired_connection_data = record
      case connection_request: jmt$paired_connection_request of
      = jmc$pcr_null_request =
        ,
      = jmc$pcr_attach_job_request =
        attach_job_request: jmt$pcr_attach_job_request,
      = jmc$pcr_attach_job_results =
        attach_job_results: jmt$pcr_attach_job_results,
      = jmc$pcr_leveled_job_request =
        leveled_job_request: jmt$pcr_leveled_job_request,
      = jmc$pcr_leveled_job_results =
        leveled_job_results: jmt$pcr_leveled_job_results,
      casend,
    recend;

  TYPE
    jmt$paired_connection_request = (jmc$pcr_null_request,
          jmc$pcr_attach_job_request, jmc$pcr_attach_job_results,
          jmc$pcr_leveled_job_request, jmc$pcr_leveled_job_results);

  TYPE
    jmt$pcr_attach_job_request = record
      system_job_name: jmt$system_supplied_name,
      encrypted_password: ost$name,
    recend;

  TYPE
    jmt$pcr_attach_job_results = record
      successful: boolean,
      condition: ost$status_condition_code,
    recend;

  TYPE
    jmt$pcr_leveled_job_request = record
      system_job_name: jmt$system_supplied_name,
      encrypted_password: ost$name,
    recend;

  TYPE
    jmt$pcr_leveled_job_results = record
      successful: boolean,
      condition: ost$status_condition_code,
    recend;

*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status_condition_code
*DECK DECK=JMT$PRINT_FILE_STATISTIC_DATA EXPAND=FALSE

  TYPE
    jmt$print_file_statistic_data = record
      file_size: ost$non_negative_integers,
      user_file_name: ost$name,
      system_file_name: jmt$system_supplied_name,
    recend;

*copyc jmt$system_supplied_name
*copyc osd$integer_limits
*copyc ost$name
*DECK DECK=JMT$PRIORITY_AGING_INTERVAL EXPAND=FALSE

{ The priority aging interval has a unit of microseconds.

  TYPE
    jmt$priority_aging_interval = 0 .. jmc$priority_aging_interval_max;

*IF $true(osv$unix)

  CONST
    jmc$priority_aging_interval_max = 7fffffff(16);

*ELSE

  CONST
    jmc$priority_aging_interval_max = jmc$highest_prio_age_interval +
          jmc$keyword_offset_maximum;

*IFEND

{ The following constants define the range of values permitted on SCL
{ parameter definitions and the internal representation for the keyword,
{ UNLIMITED.

*IF $true(osv$unix)

  CONST
    jmc$lowest_prio_age_interval = 1 * 1000000, { microseconds
    jmc$highest_prio_age_interval = 7ffffffe(16), { microseconds
    jmc$unlimited_prio_age_interval = 7fffffff(16);

*ELSE

  CONST
    jmc$lowest_prio_age_interval = 1 * 1000000, { microseconds
    jmc$highest_prio_age_interval = 36000 * 1000000, { microseconds
    jmc$unlimited_prio_age_interval = jmc$highest_prio_age_interval +
          jmc$unlimited_offset;

*IFEND

*copyc jmc$attribute_keyword_offsets
*DECK DECK=JMT$PRIORITY_BIAS EXPAND=FALSE

  TYPE
    jmt$priority_bias = -jmc$priority_bias_maximum .. jmc$priority_bias_maximum
          ;

  CONST
    jmc$priority_bias_maximum = 0ffffff(16);

{ The following constants define the range of values permitted on SCL
{ parameter definitions.

  CONST
    jmc$lowest_priority_bias = -8000000,
    jmc$highest_priority_bias = 8000000;

*DECK DECK=JMT$PRIVILEGE EXPAND=FALSE

  TYPE
    jmt$privilege = (jmc$privileged, jmc$not_privileged,
          jmc$users_default_privilege);
*DECK DECK=JMT$PROFILE_CHANGES EXPAND=FALSE

  TYPE
    jmt$profile_changes = record
      objects_changed: array [jmt$profile_object_kinds] of jmt$object_changes,
      move_classes: jmt$object_name_list,
      resubmitted_jobs: jmt$resubmitted_job_list,
    recend;

  TYPE
    jmt$object_name_list = ^array [1 .. * ] of ost$name,
    jmt$object_changes = record
      new_objects: jmt$object_name_list,
      deleted_objects: jmt$object_name_list,
      changed_objects: jmt$object_name_list,
    recend;

  TYPE
    jmt$resubmitted_job_list = ^array [1 .. * ] of jmt$resubmitted_job_data,
    jmt$resubmitted_job_data = record
      job_name: ost$name,
      status: ost$status,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$profile_object_kinds
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=JMT$PROFILE_DATA EXPAND=FALSE

  TYPE
    jmt$profile_data = record
      definition_id: ost$name,
      objects: array [jmt$profile_object_kinds] of
            jmt$profile_object_reference,
      count: array [jmt$profile_object_kinds] of
            0 .. jmc$maximum_objects_on_profile,
    recend;

  CONST
    jmc$standard_profile = 'standard_profile';

*copyc jmc$maximum_objects_on_profile
*copyc jmt$profile_object

*DECK DECK=JMT$PROFILE_DECLARATION EXPAND=FALSE

  TYPE
    jmt$profile_declaration = record
      name: ost$name,
      abbreviation: string (5),
      group: jmt$profile_group,
      case kind: jmt$object_attribute_kinds of
      = jmc$type, jmc$list, jmc$range, jmc$editable_list =
        count: jmt$object_attribute_index,
        declarations: ^jmt$profile_declaration_list,
      = jmc$number, jmc$dispatching_priority =
        minimum: integer,
        maximum: integer,
      = jmc$object =
        object_kind: jmt$profile_object_kinds,
      casend,
    recend;

  TYPE
    jmt$profile_declaration_list = array [1 .. * ] of ^jmt$profile_declaration;

*copyc jmt$object_attribute_index
*copyc jmt$object_attribute_kinds
*copyc jmt$profile_group
*copyc jmt$profile_object_kinds
*copyc ost$name
*DECK DECK=JMT$PROFILE_GROUP EXPAND=FALSE

  TYPE
    jmt$profile_group = (jmc$definition_group, jmc$control_group,
          jmc$limit_group, jmc$membership_group, jmc$priority_group,
          jmc$statistic_group, jmc$data_group),

    jmt$group_set = set of jmt$profile_group;

*DECK DECK=JMT$PROFILE_HEADER EXPAND=FALSE

  TYPE
    jmt$profile_header = record
      version: ost$name,
      definition_id: ost$name,
      object_count: integer,
      maximum_job_class_index: ost$non_negative_integers,
      maximum_service_class_index: ost$non_negative_integers,
      application_count: ost$non_negative_integers,
    recend;

  CONST
    jmc$profile_version = 'VERSION 1';

*copyc osd$integer_limits
*copyc ost$name
*DECK DECK=JMT$PROFILE_INDEX_TO_JOB_CLASS EXPAND=FALSE

  TYPE
    jmt$profile_index_to_job_class = array [1 .. jmc$maximum_job_classes] of
          jmt$job_class;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
?? POP ??
*DECK DECK=JMT$PROFILE_OBJECT EXPAND=FALSE

  TYPE
    jmt$profile_object = record
      name: ost$name,
      definition_id: ost$name,
      behaviour_id: ost$name,
      kind: jmt$profile_object_kinds,
      permanent: boolean,
      changed: boolean,
      references: 0 .. jmc$maximum_objects_on_profile,
      profile_index: 0 .. jmc$maximum_objects_on_profile,
      index: 0 .. jmc$maximum_objects_on_profile,
      attributes: jmt$object_attribute,
      next_object: jmt$profile_object_reference,
    recend,

    jmt$profile_object_reference = ^jmt$profile_object;

  CONST
    jmc$standard_behaviour = 'standard_behaviour';

*copyc jmc$maximum_objects_on_profile
*copyc jmt$profile_object_kinds
*copyc jmt$object_attribute
*copyc ost$name
*DECK DECK=JMT$PROFILE_OBJECT_KINDS EXPAND=FALSE

  TYPE
    jmt$profile_object_kinds = (jmc$profile_category, jmc$profile_priority,
          jmc$profile_output_category, jmc$profile_reserved,
          jmc$profile_controls, jmc$profile_job_class,
          jmc$profile_service_class, jmc$profile_output_class,
          jmc$profile_application);

*DECK DECK=JMT$PROFILE_OBJECT_LIST EXPAND=FALSE

  TYPE
    jmt$profile_object_list = record
      object_kind: jmt$profile_object_kinds,
      case list_kind: jmt$object_attribute_kinds of
      = jmc$list =
        pname: ost$name,
        count: integer,
      = jmc$name =
        name: ost$name,
      casend,
    recend;

*copyc jmt$object_attribute_kinds
*copyc jmt$profile_object_kinds
*copyc ost$name
*DECK DECK=JMT$PROFILE_SET EXPAND=FALSE

  TYPE
    jmt$profile_set = set of 0 .. 255;

*DECK DECK=JMT$PTF_STATISTIC_DATA EXPAND=FALSE

  TYPE
    jmt$ptf_statistic_data = record
      connect_time: ost$non_negative_integers,
      file_size: ost$non_negative_integers,
      bytes_transferred: ost$non_negative_integers,
      requesting_mainframe_name: ost$name,
      target_mainframe_name: ost$name,
      command_string: ost$string,
    recend;

*copyc osd$integer_limits
*copyc ost$name
*copyc ost$string
*DECK DECK=JMT$QFILE_APPLICATION_ATTRS EXPAND=FALSE
{ The total amount of space the queue file application attributes may take
{ is given by jmc$max_qfile_appl_attr_size.  This space may be
{ divided into 1 through 10 "hunks" of application attributes,
{ as the application writer desires, but the total of these "hunks" can
{ never be more than jmc$max_qfile_appl_attr_size.

{ Writers of applications should be aware that these attributes
{ will not be preserved if the queue file is transferred via QTF
{ over a non-VE relay, e.g. via a NOS or VAX system.

  CONST
    jmc$max_qfile_appl_attr_size = 10000;

  CONST
    jmc$max_number_of_appl_attr = 10;

  TYPE
    jmt$qfile_appl_attr_size = 0 .. jmc$max_qfile_appl_attr_size;

  TYPE
    jmt$qfile_application_attrs = record
      size: jmt$qfile_appl_attr_size,
      attributes_p: ^cell,
    recend;

*DECK DECK=JMT$QFILE_APPLICATION_TABLE EXPAND=FALSE

  TYPE
    jmt$qfile_application_table = array [jmt$qfile_application_index] of
          jmt$qfile_application_data;

  TYPE
    jmt$qfile_application_index = 0 .. jmc$maximum_qfile_applications;

  CONST
    jmc$unassigned_qfile_index = 0;

  TYPE
    jmt$qfile_application_data = record
      application_name: ost$name,
      global_task_id: ost$global_task_id,
      queue_file_password: ost$name,
      registration_options: record
        notify_on_terminate: boolean,
      recend,
      state_data: jmt$qfile_appl_state_data,
    recend;

  TYPE
    jmt$qfile_appl_state_data = array [jmt$kql_application_state] of
          jmt$qfile_appl_state_entry;

  TYPE
    jmt$qfile_appl_state_entry = record
      first_entry: jmt$kql_index,
      last_entry: jmt$kql_index,
      number_of_entries: jmt$qfile_count_range,
    recend;

*copyc jmc$maximum_qfile_applications
*copyc jmt$kql_application_state
*copyc jmt$kql_index
*copyc jmt$qfile_count_range
*copyc ost$global_task_id
*copyc ost$name
*DECK DECK=JMT$QFILE_ATTRIBUTE_CHANGES EXPAND=FALSE

  TYPE
    jmt$qfile_attribute_changes = array [1 .. * ] of
          jmt$qfile_attribute_change;

  TYPE
    jmt$qfile_attribute_change = record
      case key: jmt$attribute_keys of
      = jmc$application_attributes_1, jmc$application_attributes_2,
            jmc$application_attributes_3, jmc$application_attributes_4,
            jmc$application_attributes_5, jmc$application_attributes_6,
            jmc$application_attributes_7, jmc$application_attributes_8,
            jmc$application_attributes_9, jmc$application_attributes_10 =
        application_attributes: jmt$qfile_application_attrs,
      = jmc$deferred_by_application =
        deferred_by_application: boolean,
      = jmc$destination =
        destination: ost$name,
      = jmc$earliest_run_time =
        earliest_run_time: jmt$date_time,
      = jmc$latest_run_time =
        latest_run_time: jmt$date_time,
      = jmc$null_attribute =
        ,
      = jmc$purge_delay =
        purge_delay: ^jmt$time_increment,
      = jmc$remote_host_directive =
        remote_host_directive: ^jmt$remote_host_directive,
      = jmc$rerun_disposition =
        rerun_disposition: jmt$rerun_disposition,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$date_time
*copyc jmt$qfile_application_attrs
*copyc jmt$remote_host_directive
*copyc jmt$rerun_disposition
*copyc jmt$time_increment
*copyc ost$name
*DECK DECK=JMT$QFILE_ATTRIBUTE_COUNT EXPAND=FALSE

  TYPE
    jmt$qfile_attribute_count = 0 .. jmc$max_qfile_attribute_count;

  CONST
    jmc$max_qfile_attribute_count = jmc$maximum_qfile_count;

*copyc jmc$maximum_qfile_count
*DECK DECK=JMT$QFILE_ATTRIBUTE_KEYS EXPAND=FALSE

  TYPE
    jmt$qfile_attribute_keys = jmt$results_keys;

*copyc jmt$results_keys
*DECK DECK=JMT$QFILE_ATTRIBUTE_OPTIONS EXPAND=FALSE

  TYPE
    jmt$qfile_attribute_options = array [1 .. * ] of
          jmt$qfile_attribute_option;

  TYPE
    jmt$qfile_attribute_option = record
      case key: jmt$attribute_keys of
      = jmc$application_name =
        application_name: ost$name,
      = jmc$null_attribute =
        ,
      = jmc$qfile_state_set =
        qfile_state_set: jmt$qfile_state_set,
      = jmc$system_supplied_name_list =
        system_supplied_name_list: ^jmt$system_supplied_name_list,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$qfile_state_set
*copyc jmt$system_supplied_name_list
*copyc ost$name
*DECK DECK=JMT$QFILE_ATTRIBUTE_RESULTS EXPAND=FALSE

  TYPE
    jmt$qfile_attribute_results = array [1 .. * ] of ^array [1 .. * ] of
          jmt$qfile_attribute_result;

  TYPE
    jmt$qfile_attribute_result = record
      case key: jmt$attribute_keys of
      = jmc$application_attributes_1, jmc$application_attributes_2,
            jmc$application_attributes_3, jmc$application_attributes_4,
            jmc$application_attributes_5, jmc$application_attributes_6,
            jmc$application_attributes_7, jmc$application_attributes_8,
            jmc$application_attributes_9, jmc$application_attributes_10 =
        application_attributes: jmt$qfile_application_attrs,
      = jmc$application_name =
        application_name: ost$name,
      = jmc$data_mode =
        data_mode: jmt$data_mode,
      = jmc$deferred_by_application =
        deferred_by_application: boolean,
      = jmc$destination =
        destination: ost$name,
      = jmc$earliest_run_time =
        earliest_run_time: jmt$date_time,
      = jmc$latest_run_time =
        latest_run_time: jmt$date_time,
      = jmc$null_attribute =
        ,
      = jmc$purge_delay =
        purge_delay: ^jmt$time_increment,
      = jmc$qfile_state =
        qfile_state: jmt$qfile_state,
      = jmc$remote_host_directive =
        remote_host_directive: ^jmt$remote_host_directive,
      = jmc$system_file_name =
        system_file_name: jmt$system_supplied_name,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$data_mode
*copyc jmt$date_time
*copyc jmt$qfile_application_attrs
*copyc jmt$qfile_state
*copyc jmt$remote_host_directive
*copyc jmt$system_supplied_name
*copyc jmt$time_increment
*copyc ost$name
*DECK DECK=JMT$QFILE_COUNT_RANGE EXPAND=FALSE
  TYPE
    jmt$qfile_count_range = 0 .. jmc$maximum_qfile_count;

*copyc jmc$maximum_qfile_count
*DECK DECK=JMT$QFILE_REGISTRATION_OPTIONS EXPAND=FALSE
  TYPE
    jmt$qfile_registration_options = array [1 .. * ] of
          jmt$qfile_registration_option;

{ Any registration options added here must also be added to
{ jmt$application_data in jmt$qfile_application_table.

  TYPE
    jmt$qfile_registration_option = record
      case key: jmt$attribute_keys of
      = jmc$notify_on_terminate =
        notify_on_terminate: boolean,
      = jmc$null_attribute =
        ,
      casend,
    recend;

*copyc jmt$attribute_keys
*DECK DECK=JMT$QFILE_STATE EXPAND=FALSE

  TYPE
    jmt$qfile_state = (jmc$deferred_qfile, jmc$queued_qfile,
          jmc$initiated_qfile, jmc$terminated_qfile, jmc$completed_qfile);

*DECK DECK=JMT$QFILE_STATE_SET EXPAND=FALSE

  TYPE
    jmt$qfile_state_set = set of jmt$qfile_state;

*copyc jmt$qfile_state
*DECK DECK=JMT$QFILE_STATUS_COUNT EXPAND=FALSE

  TYPE
    jmt$qfile_status_count = 0 .. jmc$max_qfile_status_count;

  CONST
    jmc$max_qfile_status_count = jmc$maximum_qfile_count;

*copyc jmc$maximum_qfile_count
*DECK DECK=JMT$QFILE_STATUS_OPTIONS EXPAND=FALSE

  TYPE
    jmt$qfile_status_options = array [1 .. * ] of jmt$qfile_status_option;

  TYPE
    jmt$qfile_status_option = record
      case key: jmt$attribute_keys of
      = jmc$application_name =
        application_name: ost$name,
      = jmc$null_attribute =
        ,
      = jmc$qfile_state_set =
        qfile_state_set: jmt$qfile_state_set,
      = jmc$system_supplied_name_list =
        system_supplied_name_list: ^jmt$system_supplied_name_list,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$qfile_state_set
*copyc jmt$system_supplied_name_list
*copyc ost$name
*DECK DECK=JMT$QFILE_STATUS_RESULTS EXPAND=FALSE

  TYPE
    jmt$qfile_status_results = array [1 .. * ] of ^array [1 .. * ] of
          jmt$qfile_status_result;

  TYPE
    jmt$qfile_status_result = record
      case key: jmt$attribute_keys of
      = jmc$application_name =
        application_name: ost$name,
      = jmc$null_attribute =
        ,
      = jmc$qfile_state =
        qfile_state: jmt$qfile_state,
      = jmc$system_file_name =
        system_file_name: jmt$system_supplied_name,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$qfile_state
*copyc jmt$system_supplied_name
*copyc ost$name
*DECK DECK=JMT$QFILE_STATUS_UPDATES EXPAND=FALSE

  TYPE
    jmt$qfile_status_updates = array [1 .. * ] of jmt$qfile_status_update;

  TYPE
    jmt$qfile_status_update = record
      case key: jmt$attribute_keys of
      = jmc$application_attributes_1, jmc$application_attributes_2,
            jmc$application_attributes_3, jmc$application_attributes_4,
            jmc$application_attributes_5, jmc$application_attributes_6,
            jmc$application_attributes_7, jmc$application_attributes_8,
            jmc$application_attributes_9, jmc$application_attributes_10 =
        application_attributes: jmt$qfile_application_attrs,
      = jmc$null_attribute =
        ,
      casend,
    recend;

*copyc jmt$qfile_application_attrs
*copyc jmt$attribute_keys
*DECK DECK=JMT$QFILE_SUBMISSION_OPTIONS EXPAND=FALSE

  TYPE
    jmt$qfile_submission_options = array [1 .. * ] of
          jmt$qfile_submission_option;

{ These are the defaults for the submission options that are not
{ provided on the jmp$submit_qfile call:
{
{        application_attributes 1-10:  none
{        data_mode:                    coded
{        deferred_by_application:      false
{        destination:                  null string  **
{        earliest_run_time:            none
{        latest_run_time:              none
{        purge_delay:                  none
{        remote_host_directive:        null string  **
{        system_file_name:             assigned by system
{        validation_ring:              osc$user_ring (11)
{
{  ** If the application_name is QTF, these options must be provided.
{
{ The validation_ring option specifies the ring to be used to
{ validate attachment of the file to be submitted to the queue.

  TYPE
    jmt$qfile_submission_option = record
      case key: jmt$attribute_keys of
      = jmc$application_attributes_1, jmc$application_attributes_2,
            jmc$application_attributes_3, jmc$application_attributes_4,
            jmc$application_attributes_5, jmc$application_attributes_6,
            jmc$application_attributes_7, jmc$application_attributes_8,
            jmc$application_attributes_9, jmc$application_attributes_10 =
        application_attributes: jmt$qfile_application_attrs,
      = jmc$data_mode =
        data_mode: jmt$data_mode,
      = jmc$deferred_by_application =
        deferred_by_application: boolean,
      = jmc$destination =
        destination: ost$name,
      = jmc$earliest_run_time =
        earliest_run_time: jmt$date_time,
      = jmc$latest_run_time =
        latest_run_time: jmt$date_time,
      = jmc$null_attribute =
        ,
      = jmc$purge_delay =
        purge_delay: ^jmt$time_increment,
      = jmc$remote_host_directive =
        remote_host_directive: ^jmt$remote_host_directive,
      = jmc$system_file_name =
        system_file_name: jmt$system_supplied_name,
      = jmc$validation_ring =
        validation_ring: ost$valid_ring,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$data_mode
*copyc jmt$date_time
*copyc jmt$qfile_application_attrs
*copyc jmt$remote_host_directive
*copyc jmt$system_supplied_name
*copyc jmt$time_increment
*copyc osd$virtual_address
*copyc ost$name
*DECK DECK=JMT$QFILE_SYSTEM_LABEL EXPAND=FALSE

{ This constant is the maximum size of the application_attributes field
{ in the qfile system label. It is calculated as follows.
{   (10 * SIZE (jmt$attribute_keys))
{ + (10 * SIZE (jmt$qfile_appl_attr_size))
{ + (jmc$max_qfile_appl_attr_size)

  CONST
    jmc$qsl_appl_attr_contents_size = 10040;

  TYPE
    jmt$qsl_appl_attr_contents_size = 0 .. jmc$qsl_appl_attr_contents_size;

  TYPE
    jmt$qsl_appl_attr_contents = SEQ (REP jmc$qsl_appl_attr_contents_size of cell);

  TYPE
    jmt$qfile_system_label = record
      data_mode: jmt$data_mode,
      deferred_by_application: boolean,
      destination: ost$name,
      disposition_time: jmt$date_time,
      earliest_run_time: jmt$date_time,
      latest_run_time: jmt$date_time,
      application_name: ost$name,
      purge_delay: jmt$time_increment,
      remote_host_directive: jmt$remote_host_directive,
      system_file_name: jmt$system_supplied_name,
      application_attributes: jmt$qsl_appl_attr_contents,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$data_mode
*copyc jmt$date_time
*copyc jmt$qfile_application_attrs
*copyc jmt$remote_host_directive
*copyc jmt$system_supplied_name
*copyc jmt$time_increment
*copyc ost$date_time
*copyc ost$name
*DECK DECK=JMT$QFILE_TERMINATION_OPTIONS EXPAND=FALSE
  TYPE
    jmt$qfile_termination_options = array [1 .. * ] of
          jmt$qfile_termination_option;

  TYPE
    jmt$qfile_termination_option = record
      case key: jmt$attribute_keys of
      = jmc$null_attribute =
        ,
      = jmc$qfile_state_set =
        qfile_state_set: jmt$qfile_state_set,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc jmt$qfile_state_set
*DECK DECK=JMT$QTF_DEST_STATISTIC_DATA EXPAND=FALSE

  TYPE
    jmt$qtf_dest_statistic_data = record
      case kind: jmt$qtf_dest_statistic_kind of
      = jmc$input_file =
        job_input_device: jmt$job_input_device,
        job_system_label_p: ^cell,
      = jmc$output_file =
        output_file_name: amt$local_file_name,
        data: jmt$qtf_statistic_data,
      casend,
    recend;

*copyc amt$local_file_name
*copyc jmt$job_input_device
*copyc jmt$qtf_dest_statistic_kind
*copyc jmt$qtf_statistic_data
*DECK DECK=JMT$QTF_DEST_STATISTIC_KIND EXPAND=FALSE

  TYPE
    jmt$qtf_dest_statistic_kind = (jmc$input_file, jmc$output_file);
*DECK DECK=JMT$QTF_STATISTIC_DATA EXPAND=FALSE

  TYPE
    jmt$qtf_statistic_data = record
      file_size: ost$non_negative_integers,
      user_identification: ost$user_identification,
      account_name: avt$account_name,
      project_name: avt$project_name,
      system_job_name: jmt$system_supplied_name,
      user_job_name: jmt$user_supplied_name,
      origin_mainframe_name: ost$name,
      dest_mainframe_name: ost$name,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc ost$name
*copyc osd$integer_limits
*copyc ost$user_identification
*DECK DECK=JMT$QUEUED_CLASS_ENTRIES EXPAND=FALSE

  TYPE
    jmt$queued_class_entries = array [jmt$job_class] of jmt$queued_class_entry;

  TYPE
    jmt$queued_class_entry = record
      first_queued_class_entry: jmt$kjl_index,
      last_queued_class_entry: jmt$kjl_index,

{ number_of_entries: jmt$job_count_range; - is available in jmv$job_counts

      termination_count: jmt$job_count_range,
      number_of_jobs_needed: jmt$job_count_range,
      server_mainframe_priority: jmt$job_priority,
      class_blocked_for_initiation: boolean,
    recend;

*copyc jmt$job_class
*copyc jmt$job_count_range
*copyc jmt$job_priority
*copyc jmt$kjl_index
*DECK DECK=JMT$QUEUE_FILE_IJL_INFORMATION EXPAND=FALSE
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
    jmt$queue_file_ijl_information = record
      job_abort_disposition: jmt$job_abort_disposition,
      job_recovery_disposition: jmt$job_recovery_disposition,
      input_file_location: jmt$input_file_location,
    recend;

*copyc jmt$input_file_location
*copyc jmt$job_abort_disposition
*copyc jmt$job_recovery_disposition
*DECK DECK=JMT$QUEUE_FILE_PASSWORD EXPAND=FALSE

  TYPE
    jmt$queue_file_password = ost$name;

*copyc ost$name
*DECK DECK=JMT$QUEUE_FILE_PATH EXPAND=FALSE

  TYPE
    jmt$queue_file_path = array [pfc$family_name_index ..
          pfc$subcatalog_name_index+1] of pft$name;

*copyc pfd$permanent_file_definitions
*DECK DECK=JMT$RB_SCHEDULER_REQUESTS EXPAND=FALSE

{ Define the types for job scheduler monitor requests and sub-request codes.

  TYPE

    jmt$rb_sched_sub_reqcodes = (jmc$null_request, jmc$src_operator_swap_in,
          jmc$src_idling_advance_swaps, jmc$src_class_switch,
          jmc$src_change_dispatching_ctrl, jmc$src_cleanup_unrecovered_job,
          jmc$src_sched_profile_loading, jmc$src_dispatching_allocation,
          jmc$src_swapin_recovered_jobs, jmc$src_process_damaged_jobs),

{ The following requests are issued by job scheduler with the exception of
{ jmc$src_sched_profile_loading which is issued by a job activating a new
{ scheduling profile.  The jmc$src_class_switch request is also issued by
{ a job to change its own service class.

    jmt$rb_scheduler_requests = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      case sub_reqcode: jmt$rb_sched_sub_reqcodes of
      = jmc$src_operator_swap_in, jmc$src_cleanup_unrecovered_job  =
          ijl_ordinal: jmt$ijl_ordinal,
      = jmc$src_idling_advance_swaps =
          ,
      = jmc$src_class_switch =
          system_supplied_name: jmt$system_supplied_name,
          new_service_class: jmt$service_class_index,
          new_service_accumulator: jmt$service_accumulator,
          old_service_class: jmt$service_class_index,
          old_service_accumulator: jmt$service_accumulator,
      = jmc$src_change_dispatching_ctrl =
          ,
      = jmc$src_sched_profile_loading =
          ,
      = jmc$src_dispatching_allocation =
          ,
      = jmc$src_swapin_recovered_jobs =
          ,
      = jmc$src_process_damaged_jobs =
          ,
      casend,
    recend;

*copyc jmt$ijl_ordinal
*copyc jmt$system_supplied_name
*copyc jmt$service_class_index
*copyc syt$monitor_status
*copyc syc$monitor_request_codes
*DECK DECK=JMT$RB_SERVICE_CLASS_STATISTICS EXPAND=FALSE

  TYPE
    jmt$rb_service_class_statistics = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      fill: 0..0ff(16),
    recend;

*copyc syc$monitor_request_codes
*copyc syt$monitor_status
*DECK DECK=JMT$RELEASE_INPUT_FILE_LIST EXPAND=FALSE

  TYPE
    jmt$release_input_file_list = array [1 .. * ] of
          jmt$release_input_file_entry;

  TYPE
    jmt$release_input_file_entry = record
      system_job_name: jmt$system_supplied_name,
      input_file_location: jmt$input_file_location,
      login_family: ost$name,
    recend;

*copyc jmt$input_file_location
*copyc jmt$system_supplied_name
*copyc ost$name
*DECK DECK=JMT$RELEASE_OUTPUT_FILE_LIST EXPAND=FALSE

  TYPE
    jmt$release_output_file_list = array [1 .. * ] of
          jmt$release_output_file_element;

  TYPE
    jmt$release_output_file_element = record
      system_file_name: jmt$system_supplied_name,
      output_destination_usage: jmt$destination_usage,
    recend;

*copyc jmt$destination_usage
*copyc jmt$system_supplied_name
*DECK DECK=JMT$REMOTE_HOST_DIRECTIVE EXPAND=FALSE
{ THIS COMMENT APPLIES TO FILES IN THE GENERIC QUEUE ONLY.
{ If a generic queue file is to be processed by QTF, then
{ the remote host directive parameters field contains a string of
{ parameters in SCL format.  These are attributes to be
{ specified when the destination is reached.
{ Attributes that can be specified and their abbreviations are:
{  APPLICATION_NAME (AN)
{  DEFERRED_BY_APPLICATION (DBA)
{  DESTINATION (D)
{  EARLIEST_RUN_TIME (ERT)
{  LATEST_RUN_TIME (LRT)
{  PURGE_DELAY (PD)
{  REMOTE_HOST_DIRECTIVE (RHD)

  TYPE
    jmt$remote_host_directive = record
      size: 0 .. jmc$remote_host_directive_size,
      parameters: string (jmc$remote_host_directive_size),
    recend;

  CONST
    jmc$remote_host_directive_size = 256;
*DECK DECK=JMT$REPRINT_DISPOSITION EXPAND=FALSE

  TYPE
    jmt$reprint_disposition = (jmc$rd_no_change, jmc$rd_discard_file,
          jmc$rd_reprint_file);
*DECK DECK=JMT$RERUN_DISPOSITION EXPAND=FALSE
  TYPE
    jmt$rerun_disposition = (jmc$rr_no_change, jmc$rr_discard_file,
          jmc$rr_rerun_file);

*DECK DECK=JMT$RESULTS EXPAND=FALSE

  TYPE
    jmt$results = array [1 .. * ] of ^jmt$attribute_values;

*copyc jmt$attribute_values
*DECK DECK=JMT$RESULTS_KEYS EXPAND=FALSE
  TYPE
    jmt$results_keys = array [1 .. * ] of jmt$attribute_keys;

*copyc jmt$attribute_keys
*DECK DECK=JMT$ROUTING_EXTERNAL EXPAND=FALSE

{ File Routing General Definitions. }

  CONST
    jmc$routing_repeat_count_max = 0ff(16),

    jmc$queue_file_priority_max = 0ffff(16),

    jmc$queue_entry_number_max = 0ffff(16),

    jmc$queue_entry_count_max = 500,

    jmc$routing_form_code_size = 4,

    jmc$routing_address_size = 135,

    jmc$job_position_size = 80;

  TYPE
    jmt$routing_external = (jmc$routing_external_default,
      jmc$routing_external_ascii96, jmc$routing_external_ascii64,
      jmc$routing_external_coded, jmc$routing_external_binary,
      jmc$routing_external_ins1, jmc$routing_external_ins2),

    jmt$routing_external_set = set OF jmt$routing_external,

    jmt$routing_form_code = string (jmc$routing_form_code_size),

    jmt$routing_repeat_count = 1 .. jmc$routing_repeat_count_max,

    jmt$routing_address = string (jmc$routing_address_size),

    jmt$queue_type = (jmc$queue_type_default, jmc$queue_type_input,
      jmc$queue_type_print, jmc$queue_type_punch, jmc$queue_type_execute,
      jmc$queue_type_printing, jmc$queue_type_all,
      jmc$queue_type_local, jmc$queue_type_ins1, jmc$queue_type_ins2),

    jmt$queue_type_set = set OF jmt$queue_type,

    jmt$queue_file_priority = 0 .. jmc$queue_file_priority_max,

    jmt$queue_entry_number = 1 .. jmc$queue_entry_number_max,

    jmt$execution_state = (jmc$estate_execute, jmc$estate_swapped_out, jmc$estate_wait_memory,
      jmc$estate_wait_terminal, jmc$estate_wait_pf, jmc$estate_wait_tape),

    jmt$job_position = string (jmc$job_position_size);


*DECK DECK=JMT$RPC_MAINFRAMES_PROCESSED EXPAND=FALSE
  TYPE
    jmt$rpc_mainframes_processed = record
      count: jmt$maximum_mainframes,
      mainframes: jmt$mainframes_searched_list,
    recend;

*copyc jmt$maximum_mainframes
*copyc jmt$mainframes_searched_list
*DECK DECK=JMT$SCHEDULER_TABLES_ACCESS EXPAND=FALSE

  TYPE
    jmt$scheduler_tables_access = record
      lock: ost$signature_lock,
      count: integer, { soft-lock access count
    recend;

*copyc ost$signature_lock_status
*DECK DECK=JMT$SCHEDULING_ATTRIBUTE_KEYS EXPAND=FALSE

  TYPE
    jmt$scheduling_attribute_keys = 0 .. jmc$maximum_sched_attr_index;

  CONST
    jmc$maximum_sched_attr_index = 250;

  CONST
    jmc$sak_unknown_attribute = 0,

    jmc$sak_active_jobs = 10,
    jmc$sak_enable_class_initiation = 20,
    jmc$sak_enable_job_leveling = 30,
    jmc$sak_initiation_age_interval = 40,
    jmc$sak_initiation_level = 50,
    jmc$sak_job_leveling_prior_bias = 60,
    jmc$sak_maximum_active_jobs = 70,
    jmc$sak_null_attribute = 80,
    jmc$sak_queued_jobs = 90,
    jmc$sak_selection_priority = 100,
    jmc$sak_swapped_jobs = 110;

*DECK DECK=JMT$SCHEDULING_ATTR_RESULTS EXPAND=FALSE

  TYPE
    jmt$scheduling_attr_results = array [1 .. * ] of
          jmt$scheduling_attr_result;

  TYPE
    jmt$scheduling_attr_result = record
      case key: jmt$scheduling_attribute_keys of
      = jmc$sak_active_jobs =
        active_jobs: jmt$job_count_range,
      = jmc$sak_enable_class_initiation =
        enable_class_initiation: boolean,
      = jmc$sak_enable_job_leveling =
        enable_job_leveling: boolean,
      = jmc$sak_initiation_age_interval =
        initiation_age_interval: jmt$priority_aging_interval,
      = jmc$sak_initiation_level =
        initiation_level: jmt$job_initiation_level,
      = jmc$sak_job_leveling_prior_bias =
        job_leveling_priority_bias: jmt$priority_bias,
      = jmc$sak_maximum_active_jobs =
        maximum_active_jobs: jmt$maximum_active_jobs,
      = jmc$sak_null_attribute =
        ,
      = jmc$sak_queued_jobs =
        queued_jobs: jmt$job_count_range,
      = jmc$sak_selection_priority =
        selection_priority: jmt$selection_priority,
      = jmc$sak_swapped_jobs =
        swapped_jobs: jmt$job_count_range,
      casend,
    recend;

*copyc jmt$scheduling_attribute_keys
*copyc jmt$job_count_range
*copyc jmt$selection_priority
*copyc jmt$priority_bias
*copyc jmt$maximum_active_jobs
*copyc jmt$job_initiation_level
*copyc jmt$priority_aging_interval
*DECK DECK=JMT$SCHEDULING_MEMORY_LEVEL EXPAND=FALSE

{ A memory level for the scheduler is in units of pages.

  TYPE
    jmt$scheduling_memory_level = 0 .. jmc$scheduling_memory_level_max;

  CONST
    jmc$scheduling_memory_level_max = jmc$highest_sched_memory_level;

{ The following constants define the range of values permitted on SCL
{ parameter definitions.

  CONST
    jmc$lowest_sched_memory_level = 0,
    jmc$highest_sched_memory_level = 100000;

*DECK DECK=JMT$SCHEDULING_RESULTS_KEYS EXPAND=FALSE

  TYPE
    jmt$scheduling_results_keys = array [1 .. * ] of
          jmt$scheduling_attribute_keys;

*copyc jmt$scheduling_attribute_keys
*DECK DECK=JMT$SCHEDULING_UTILITY_USAGE EXPAND=FALSE

  TYPE
    jmt$scheduling_utility_usage = record
      lock: ost$signature_lock,
      active: boolean,
      global_task_id: ost$global_task_id,
      access_id: ost$binary_unique_name,
    recend;

*copyc ost$binary_unique_name
*copyc ost$global_task_id
*copyc ost$signature_lock_status
*DECK DECK=JMT$SCHED_SERV_CLASS_STAT_ENTRY EXPAND=FALSE

  TYPE
    jmt$sched_serv_class_stat_entry = record
      active_jobs: jmt$job_count_range,
      swapin_queue_size: 0 .. jmc$max_ijl_ord,
      memory_waits: 0 .. 0ffffffff(16),
      ajl_waits: 0 .. 0ffffffff(16),
    recend;

*copyc jmt$job_count_range
*copyc jmc$maximum_constants
*DECK DECK=JMT$SCHED_SIGNAL_CONTENTS EXPAND=FALSE

{ JMDSGNL - Defines the contents of the signal sent to the SCHEDULER.

  TYPE
    jmt$sched_signal_contents = record
      kjlo: jmt$kjl_ordinal,
      CASE id: jmt$signal_id OF
        = jmc$id_min_timeout =
          min_timeout: ost$free_running_clock,
      CASEND,
    recend,

    jmt$signal_id = (jmc$id_swapin_job,jmc$id_min_timeout,jmc$id_dummy);

*copyc JMT$KJL_ORDINAL
*copyc OST$HARDWARE_SUBRANGES
*DECK DECK=JMT$SEG_ATTR EXPAND=FALSE
    TYPE
    jmt$seg_attr = RECORD
       sfid_needed: BOOLEAN,
       seg_len: INTEGER,
       segnumber: ost$segment,
       sdt: mmt$segment_descriptor,
       sdtx: mmt$segment_descriptor_extended,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc MMT$ATTRIBUTE_KEYWORD
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE_EX
?? POP ??
*DECK DECK=JMT$SELECTION_PRIORITY EXPAND=FALSE

  TYPE
    jmt$selection_priority = record
      initial: jmt$job_priority,
      maximum: jmt$job_priority,
      increment: jmt$job_priority,
      threshold: jmt$job_priority,
    recend;

*copyc jmt$job_priority
*DECK DECK=JMT$SENSE_SWITCH_SIGNAL EXPAND=FALSE

TYPE
  jmt$sense_switch_signal = record
    on: pmt$sense_switches,
    off: pmt$sense_switches,
  recend;

*copyc PMT$SENSE_SWITCHES
*DECK DECK=JMT$SERVICE_ACCUMULATOR EXPAND=FALSE

  TYPE
    jmt$service_accumulator = 0 .. jmc$service_accumulator_maximum;

*IF $true(osv$unix)

  CONST
    jmc$service_accumulator_maximum = 7fffffff(16);

*ELSE

  CONST
    jmc$service_accumulator_maximum = 0ffffffffffff(16);

*IFEND

{ The following constants define the range of values permitted on SCL
{ parameter definitions and the internal representation for the keyword,
{ UNLIMITED.

  CONST
    jmc$lowest_service_accumulator = 0;

*IF $true(osv$unix)

  CONST
    jmc$highest_service_accumulator = 7ffffffe(16),
    jmc$unlimited_service_accum = 7fffffff(16);

*ELSE

  CONST
    jmc$highest_service_accumulator = 100000000000,
    jmc$unlimited_service_accum = jmc$highest_service_accumulator +
          jmc$unlimited_offset;

*IFEND

*copyc jmc$attribute_keyword_offsets
*DECK DECK=JMT$SERVICE_CLASS_ATTRIBUTES EXPAND=FALSE

  TYPE
    jmt$service_class_attributes = RECORD

{ Define the Definition group attributes.

      defined: boolean,
      index: jmt$service_class_index,
      profile_identification: ost$name,
      name: jmt$service_class_name,
      abbreviation: jmt$service_class_name,

{ Define the Control group attributes.

      aio_limit: jmt$aio_limit,
      class_service_threshold: jmt$service_accumulator,
      guaranteed_service_quantum: jmt$service_accumulator,
      long_wait_think_time: jmt$long_wait_think_time,
      maximum_active_jobs: jmt$maximum_active_jobs,
      next_service_class_index: jmt$service_class_index,
      service_factors: ARRAY [jmt$service_factors] OF jmt$service_factor_value,

{ Define the Priority group attributes.

      dispatching_control: jmt$dispatching_control,
      scheduling_priority: jmt$scheduling_priority,
      swap_age_interval: jmt$priority_aging_interval, { microseconds

    RECEND;

  TYPE

    jmt$scheduling_priority = RECORD
      minimum: jmt$job_priority,
      maximum: jmt$job_priority,
      swap_age_increment: jmt$job_priority,
      ready_task_increment: jmt$job_priority,
    RECEND;

*copyc jmt$aio_limit
*copyc jmt$dispatching_control
*copyc jmt$dispatching_priority
*copyc jmt$job_priority
*copyc jmt$long_wait_think_time
*copyc jmt$maximum_active_jobs
*copyc jmt$priority_aging_interval
*copyc jmt$service_accumulator
*copyc jmt$service_class_index
*copyc jmt$service_class_name
*copyc jmt$service_factors
*copyc jmt$service_factor_value
*copyc ost$name
*DECK DECK=JMT$SERVICE_CLASS_COUNTS EXPAND=FALSE

  TYPE
    jmt$service_class_counts = ARRAY [jmt$service_class_index] OF jmt$service_class_count,
    jmt$service_class_count = RECORD
      scheduler_initiated_jobs: jmt$job_count_range,
      swapped_jobs: jmt$job_count_range,
    RECEND;

*copyc jmt$job_count_range
*copyc jmt$service_class_index
*DECK DECK=JMT$SERVICE_CLASS_ENTRY EXPAND=FALSE
  TYPE
    jmt$service_class_entry = record
       attributes: jmt$service_class_attributes,
       statistics: jmt$mtr_serv_class_stat_entry,
    recend;

*copyc jmt$service_class_attributes
*copyc jmt$mtr_serv_class_stat_entry
*DECK DECK=JMT$SERVICE_CLASS_INDEX EXPAND=FALSE

{ This deck defines the type for service classes.  Any time the service
{ class table (jmv$service_class_table_p) needs to be scanned, the scan
{ should be from jmc$system_service_class (the first defined class) to
{ jmv$max_service_class_in_use (the index of the highest defined class).

  CONST
    jmc$null_service_class = 0,
    jmc$unspecified_service_class = jmc$null_service_class,
    jmc$system_service_class = 1,
    jmc$maintenance_service_class = 2,
    jmc$unassigned_service_class = 3,
    jmc$lowest_site_service_class = 4,
    jmc$minimum_service_classes = 3,
    jmc$maximum_service_classes = 255;

  TYPE
    jmt$service_class_index = 0 .. jmc$maximum_service_classes;
*DECK DECK=JMT$SERVICE_CLASS_NAME EXPAND=FALSE

  TYPE
    jmt$service_class_name = ost$name;

*copyc ost$name
*DECK DECK=JMT$SERVICE_CLASS_SET EXPAND=FALSE

  TYPE
    jmt$service_class_set = SET OF jmt$service_class_index;

*copyc jmt$service_class_index
*DECK DECK=JMT$SERVICE_CLASS_STATISTICS EXPAND=FALSE

  TYPE
    jmt$service_class_statistics = record
      queued_jobs: jmt$job_count_range,
      active_jobs: jmt$job_count_range,
      swapped_jobs: jmt$job_count_range,
    recend;

*copyc jmt$job_count_range
*DECK DECK=JMT$SERVICE_CLASS_STATS EXPAND=FALSE

  TYPE
    jmt$service_class_stats = ARRAY [1 .. *] OF jmt$service_class_stat_entry;

*copyc jmt$service_class_stat_entry
*DECK DECK=JMT$SERVICE_CLASS_STAT_ENTRY EXPAND=FALSE

  TYPE
    jmt$service_class_stat_entry = record
      mtr_stats: jmt$mtr_serv_class_stat_entry,
      sched_stats: jmt$sched_serv_class_stat_entry,
      name: jmt$service_class_name,
    recend;

*copyc jmt$mtr_serv_class_stat_entry
*copyc jmt$sched_serv_class_stat_entry
*copyc jmt$service_class_name
*DECK DECK=JMT$SERVICE_CLASS_TABLE EXPAND=FALSE

{ This deck defines the type for the service class table.  Any time the
{ service class table (jmv$service_class_table_p) needs to be scanned,
{ the scan should be from jmc$system_service_class (the first defined class)
{ to jmv$max_service_class_in_use (the index of the highest defined class).

  TYPE
    jmt$service_class_table = array [1 .. *] of jmt$service_class_attributes;

*copyc jmt$service_class_attributes
*DECK DECK=JMT$SERVICE_DATA EXPAND=FALSE
  CONST
    jmc$max_service_data_length = 256;

  TYPE
    jmt$service_data = string (jmc$max_service_data_length),
    jmt$service_data_length = 0 .. jmc$max_service_data_length;

*DECK DECK=JMT$SERVICE_FACTORS EXPAND=FALSE

  TYPE
    jmt$service_factors = (jmc$sf_cpu, jmc$sf_memory, jmc$sf_residence,
          jmc$sf_io);
*DECK DECK=JMT$SERVICE_FACTOR_VALUE EXPAND=FALSE

  TYPE
    jmt$service_factor_value = 0 .. jmc$service_factor_value_max;

  CONST
    jmc$service_factor_value_max = jmc$highest_service_factor_valu;

{ The following constants define the range of values permitted on SCL
{ parameter definitions.

  CONST
    jmc$lowest_service_factor_value = 0,
    jmc$highest_service_factor_valu = 100;
*DECK DECK=JMT$SERVICE_INTERVAL EXPAND=FALSE

{ The service interval has a unit of seconds.

  TYPE
    jmt$service_interval = 0 .. jmc$service_interval_maximum;

  CONST
    jmc$service_interval_maximum = jmc$highest_service_interval;

{ The following constants define the range of values permitted on SCL
{ parameter definitions.

  CONST
    jmc$lowest_service_interval = 1,
    jmc$highest_service_interval = 3600;

*DECK DECK=JMT$SITE_INFORMATION EXPAND=FALSE

  TYPE
    jmt$site_information = string (jmc$site_information_size);

  CONST
    jmc$site_information_size = 256;
*DECK DECK=JMT$SOURCE_LOGICAL_ID EXPAND=FALSE

  TYPE
    jmt$source_logical_id = string (jmc$source_logical_id_size);

  CONST
    jmc$source_logical_id_size = 31;
*DECK DECK=JMT$SRU_LIMIT EXPAND=FALSE

  TYPE
    jmt$sru_limit = 0 .. jmc$sru_limit_maximum;

  CONST
    jmc$sru_limit_maximum = sfc$unlimited;

{ The following constants define the range of values permitted on SCL
{ parameter definitions and the internal representation for the keywords,
{ UNSPECIFIED, REQUIRED, SYSTEM_DEFAULT, and UNLIMITED.

  CONST
    jmc$lowest_sru_limit = 1,
*IF $true(osv$unix)
    jmc$highest_sru_limit = 7ffffffe(16),
    jmc$unspecified_sru_limit = 7fffffff(16),
    jmc$required_sru_limit = 7fffffff(16),
    jmc$system_default_sru_limit = 7fffffff(16),
*ELSE
    jmc$highest_sru_limit = 7fffffffffff(16), { 2**48 -1
    jmc$unspecified_sru_limit = jmc$highest_sru_limit + jmc$unspecified_offset,
    jmc$required_sru_limit = jmc$highest_sru_limit + jmc$required_offset,
    jmc$system_default_sru_limit = jmc$highest_sru_limit +
          jmc$system_default_offset,
*IFEND
    jmc$unlimited_sru_limit = jmc$sru_limit_maximum;

*copyc jmc$attribute_keyword_offsets
*copyc sfc$unlimited
*DECK DECK=JMT$SSN_COUNTER EXPAND=FALSE

  TYPE
    jmt$ssn_counter = string (jmc$ssn_counter_size);

  CONST
    jmc$ssn_counter_size = 4;
*DECK DECK=JMT$SSN_MODEL_NUMBER EXPAND=FALSE

  TYPE
    jmt$ssn_model_number = string (jmc$ssn_model_number_size);

  CONST
   jmc$ssn_model_number_size = 4;
*DECK DECK=JMT$SSN_SEQUENCE_NUMBER EXPAND=FALSE

  TYPE
    jmt$ssn_sequence_number = STRING (jmc$ssn_sequence_number_size);

  CONST
    jmc$ssn_sequence_number_size = 3;
*DECK DECK=JMT$SSN_SERIAL_NUMBER EXPAND=FALSE

  TYPE
    jmt$ssn_serial_number = string (jmc$ssn_serial_number_size);

 CONST
    jmc$ssn_serial_number_size = 4;
*DECK DECK=JMT$STATION EXPAND=FALSE

  TYPE
    jmt$station = ost$name;

*copyc ost$name
*DECK DECK=JMT$STATION_OPERATOR EXPAND=FALSE

  TYPE
    jmt$station_operator = ost$name;

*copyc ost$name
*DECK DECK=JMT$STATION_USAGE EXPAND=FALSE

  TYPE
    jmt$station_usage = (jmc$public_station, jmc$private_station,
          jmc$foreign_station);
*DECK DECK=JMT$SUBMIT_JOB_STATISTIC_DATA EXPAND=FALSE

  TYPE
    jmt$submit_job_statistic_data = record
      job_size: ost$non_negative_integers,
      system_job_name: jmt$system_supplied_name,
    recend;

*copyc jmt$system_supplied_name
*copyc osd$integer_limits
*DECK DECK=JMT$SUBMIT_JOB_VARIATIONS EXPAND=FALSE

  TYPE
    jmc$submit_job_variations = (jmc$connection_switch,
          jmc$submit_detached_job, jmc$remote_connection_switch);

  TYPE
    jmt$submit_job_variations = record
      case kind: jmc$submit_job_variations of
      = jmc$connection_switch =
        job_offering_connection: jmt$system_supplied_name,
      = jmc$submit_detached_job, jmc$remote_connection_switch =
      casend,
    recend;

*copyc jmt$system_supplied_name
*copyc ost$name
*DECK DECK=JMT$SWAPIN_CANDIDATE_Q_HEADER EXPAND=FALSE

  TYPE
    jmt$swapin_candidate_q_header = RECORD
      swapin_candidate_queue: jmt$ijl_ordinal,
      number_of_jobs_in_queue:  0 .. jmc$max_ijl_ord,
      end_of_dp_q: ARRAY [jmc$priority_p1..jmc$priority_p14] OF jmt$ijl_ordinal,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$dispatching_priority
*copyc jmt$ijl_ordinal
*copyc jmc$maximum_constants
?? POP ??
*DECK DECK=JMT$SWAPOUT_REASONS EXPAND=FALSE

  TYPE
    jmt$swapout_reasons = (jmc$sr_null,
                           jmc$sr_operator_request,
                           jmc$sr_thrashing,
                           jmc$sr_lower_priority,
                           jmc$sr_idling_system_swapout,
                           jmc$sr_long_wait,
                           jmc$sr_memory_reserve_request,
                           jmc$sr_idle_dispatching,
                           jmc$sr_job_damaged);

*DECK DECK=JMT$SWAPPED_JOB_ENTRY EXPAND=FALSE


{  Type definition for swapped job entry.

  TYPE
    jmt$swapped_job_entry = record
      available_modified_page_count: 0 .. osc$max_page_frames,
      job_page_queue_count: ARRAY [mmt$job_page_queue_index]
        OF 0 .. osc$max_page_frames,
      swap_file_descriptor_page_count: 0 .. 65535,
    recend;

*copyc mmt$page_frame_queue_id
*copyc ost$page_table
*copyc ost$hardware_subranges
*DECK DECK=JMT$SWAP_FILE_RECOVERY_INFO EXPAND=FALSE

  TYPE
    jmt$swap_file_recovery_info = record
      system_job_name: jmt$system_supplied_name,
      local_file_name: amt$local_file_name,
      recovery_disposition_available: boolean,
      job_recovery_disposition: jmt$job_recovery_disposition,
      command_file_exists: boolean,
    recend;

*copyc amt$local_file_name
*copyc jmt$job_recovery_disposition
*copyc jmt$system_supplied_name
*DECK DECK=JMT$SWAP_FILE_RECOVERY_LIST EXPAND=FALSE

  TYPE
    jmt$swap_file_recovery_list = array [1 .. * ] of
          jmt$swap_file_recovery_info;

*copyc jmt$swap_file_recovery_info
*DECK DECK=JMT$SWAP_FILE_USER_INFO EXPAND=FALSE

{ This type cannot exceed amc$user_info bytes in length.

  TYPE
    jmt$swap_file_user_info = record
      version: jmt$swap_file_user_info_version,
      server_mainframe_id: pmt$binary_mainframe_id,
    recend;

  TYPE
    jmt$swap_file_user_info_version = (jmc$swap_file_version_unknown,
          jmc$swap_file_version_1);

*copyc pmt$binary_mainframe_id
*DECK DECK=JMT$SYSTEM_CORE_TEMPLATE EXPAND=FALSE

TYPE
jmt$system_core_template = record
  job_fixed_template_p: ^ARRAY [*] OF cell,
  jcb_p: ^jmt$job_control_block,
  xcb_p: ^ost$execution_control_block,
  sdt_p: ^ARRAY [0..4095] OF mmt$segment_descriptor,
  sdtx_p: ^ARRAY [0..4095] OF mmt$segment_descriptor_extended,
  jmtr_xcb_offset: ost$segment_offset,
recend;

*copyc JMT$JOB_CONTROL_BLOCK
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE_EX
*copyc OST$EXECUTION_CONTROL_BLOCK
*copyc OSD$VIRTUAL_ADDRESS

*DECK DECK=JMT$SYSTEM_JOB_PARAMETERS EXPAND=FALSE

  TYPE
    jmt$system_job_parameters = record
      system_job_parameter_count : 0 .. jmc$max_system_job_parameters,
      system_job_parameter : STRING ( jmc$max_system_job_parameters ),
    recend;

  CONST
    jmc$max_system_job_parameters = 256;
*DECK DECK=JMT$SYSTEM_LABEL_INFO_LENGTH EXPAND=FALSE

TYPE
  jmt$system_label_info_length = 0 .. jmc$maximum_system_label_info;

CONST
  jmc$maximum_system_label_info = jmc$maximum_system_label_length;

*copyc jmc$maximum_system_label_length
*DECK DECK=JMT$SYSTEM_PROFILE_CYCLE_NUMBER EXPAND=FALSE
  TYPE
    jmt$system_profile_cycle_number = 1 .. 2;

*DECK DECK=JMT$SYSTEM_ROUTING_TEXT EXPAND=FALSE

  TYPE
    jmt$system_routing_text = record
      size: 0 .. jmc$system_routing_text_size,
      parameters: string (jmc$system_routing_text_size),
    recend;

  CONST
    jmc$system_routing_text_size = 256;

*DECK DECK=JMT$SYSTEM_SUPPLIED_NAME EXPAND=FALSE

{ The system supplied name is of the form $MMMM_NNNN_SSS_CCCC }

  TYPE
    jmt$system_supplied_name = string (jmc$system_supplied_name_size);

  CONST
    jmc$system_supplied_name_size = 19,
    jmc$long_ssn_size = 9,
    jmc$short_ssn_size = 5,
    jmc$full_system_supplied_name = '$0000_0000_AAA_0000',
    jmc$long_system_supplied_name = '$AAA_0000',
    jmc$short_system_supplied_name = '$0000',
    jmc$blank_system_supplied_name = '                   ';
*DECK DECK=JMT$SYSTEM_SUPPLIED_NAME_LIST EXPAND=FALSE
  TYPE
    jmt$system_supplied_name_list = array [1 .. * ] of
          jmt$system_supplied_name;

*copyc jmt$system_supplied_name
*DECK DECK=JMT$SYSTEM_SUPPLIED_NAME_MASK EXPAND=FALSE

{ A system_supplied_name is of the form $MMM_NNNN_SSS_CCCC }

  TYPE
    jmt$system_supplied_name_mask = record
      case boolean of
      = true =
        system_supplied_name: jmt$system_supplied_name,
      = false =
        dollar: string(1),
        model: jmt$ssn_model_number,
        underscore_1: string(1),
        serial_number: jmt$ssn_serial_number,
        underscore_2: string(1),
        sequence: jmt$ssn_sequence_number,
        underscore_3: string(1),
        counter: jmt$ssn_counter,
      casend,
    recend;

*copyc jmt$ssn_counter
*copyc jmt$ssn_model_number
*copyc jmt$ssn_sequence_number
*copyc jmt$ssn_serial_number
*copyc jmt$system_supplied_name
*DECK DECK=JMT$TASK_TIME_SLICE EXPAND=FALSE




{ The task time slice has a unit of microseconds.

  TYPE
    jmt$task_time_slice = ost$task_time_slice;

{ The following constants define the range of values permitted on SCL
{ parameter definitions.

  CONST
    jmc$lowest_task_time_slice = 1,
    jmc$highest_task_time_slice = 100;

*copyc ost$task_time_slice
*DECK DECK=JMT$TASK_TO_EXECUTE_ENTRY EXPAND=FALSE

  TYPE
    jmt$task_to_execute_entry=record
      task_name: pmt$program_name,
      run_on_hardware: boolean,
      run_on_simulator: boolean,
      ignore_execution_errors: boolean,
    recend;

*copyc PMT$PROGRAM_NAME
*DECK DECK=JMT$TERMINATE_JOB_ACTION EXPAND=FALSE

  TYPE
    jmt$terminate_job_action = (jmc$tja_kill_disabled,
          jmc$tja_operator_kill_enabled, jmc$tja_user_kill_enabled);

  TYPE
    jmt$terminate_job_action_set = set of jmt$terminate_job_action;
*DECK DECK=JMT$TIMESHARING_SIGNAL EXPAND=FALSE

  TYPE
    jmt$timesharing_signal = record
      case boolean of
      = TRUE =
        signal: pmt$signal,

      = FALSE =
        signal_id: pmt$signal_id,
        signal_contents: jmt$timesharing_signal_contents,
      casend,
    recend;

  TYPE
    jmt$timesharing_signal_contents = record
      case signal_kind: jmt$timesharing_signal_kind of
      = jmc$timesharing_disconnect =
        disconnect: jmt$timesharing_disconnect,

      = jmc$timesharing_interrupt =
        interrupt: jmt$timesharing_interrupt,

      = jmc$timesharing_reconnect =
        reconnect: jmt$timesharing_reconnect,

      = jmc$timesharing_restart_tasks =
        restart_tasks: jmt$timesharing_restart_tasks,

      = jmc$timesharing_synchronize =
        synchronize: jmt$timesharing_synchronize,

      = jmc$timesharing_timeout =
        ,
      casend,
    recend;

  TYPE
    jmt$timesharing_signal_kind = (jmc$timesharing_disconnect,
          jmc$timesharing_interrupt, jmc$timesharing_reconnect,
          jmc$timesharing_restart_tasks, jmc$timesharing_synchronize,
          jmc$timesharing_timeout);

  TYPE
    jmt$timesharing_disconnect = record
      case disconnect_reason: jmt$ts_disconnect_reason of
      = jmc$ts_line_disconnect =
        ,
      = jmc$ts_attach_job =
        target_job_global_task_id: ost$global_task_id,
        target_job_system_supplied_name: jmt$system_supplied_name,
        target_job_mainframe_id: pmt$binary_mainframe_id,

      = jmc$ts_detach_job =
        ,
      = jmc$ts_system_disconnect =
        ,
      casend,
    recend;

  TYPE
    jmt$ts_disconnect_reason = (jmc$ts_line_disconnect, jmc$ts_attach_job,
          jmc$ts_detach_job, jmc$ts_system_disconnect);

  TYPE
    jmt$timesharing_interrupt = string (nac$se_max_interrupt_data_len);

  TYPE
    jmt$timesharing_restart_tasks = (jmc$ts_restart_child_tasks,
          jmc$ts_restart_jmtr_task);

  TYPE
    jmt$timesharing_reconnect = record
      system_supplied_job_name: jmt$system_supplied_name,
      paired_connection_reconnect: boolean,
    recend;

  TYPE
    jmt$timesharing_synchronize = string (nac$se_max_synch_data_length);

*copyc jmt$system_supplied_name
*copyc nat$se_interrupt_data_length
*copyc nat$se_synchronize_data_length
*copyc ost$global_task_id
*copyc pmt$binary_mainframe_id
*copyc pmt$signal
*DECK DECK=JMT$TIME_INCREMENT EXPAND=FALSE

  TYPE
    jmt$time_increment = record
      case specified: boolean of
      = TRUE =
        time_increment: pmt$time_increment,
      = FALSE =
        ,
      casend,
    recend;

*copyc pmt$time_increment
*DECK DECK=JMT$TRICK_IJLO_VARIANT_RECORD EXPAND=FALSE

  TYPE
    jmt$trick_ijlo_variant_record = record
      case 0..1 of
      = 0 =
        ijl_ordinal: jmt$ijl_ordinal,
      = 1 =
        ijl_integer: integer,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=JMT$UNSEEN_MAIL_MESSAGE EXPAND=FALSE

  TYPE
    jmt$unseen_mail_message = record
      user_id: ost$user_identification,
    recend;

*copyc ost$user_identification
*DECK DECK=JMT$USER_INFORMATION EXPAND=FALSE

  TYPE
    jmt$user_information = string (jmc$user_information_size);

  CONST
    jmc$user_information_size = 256;
*DECK DECK=JMT$USER_JOB_PARAMETERS EXPAND=FALSE

  TYPE
    jmt$user_job_parameters = record
      user_job_parameter_count : 0 .. jmc$max_user_job_parameters,
      user_job_parameter : STRING ( jmc$max_user_job_parameters ),
    recend;

  CONST
    jmc$max_user_job_parameters = 256;
*DECK DECK=JMT$USER_SUPPLIED_NAME EXPAND=FALSE

  TYPE
    jmt$user_supplied_name = ost$name;

*copyc ost$name
*DECK DECK=JMT$USER_VALIDATION_OPTIONS EXPAND=FALSE
  TYPE
    jmt$user_validation_options = array [1 .. * ] of
          jmt$user_validation_option;

  TYPE
    jmt$user_validation_option = record
      case key: jmt$attribute_keys of
      = jmc$encrypted_password =
        encrypted_password: ost$name,
      = jmc$login_password =
        login_password: ost$name,
      = jmc$null_attribute =
        ,
      casend,
    recend;

*copyc jmt$attribute_keys
*copyc ost$name
*DECK DECK=JMT$VALID_MAINFRAME_SET EXPAND=FALSE

  TYPE
    jmt$valid_mainframe_set = set of 1 .. jmc$maximum_mainframes;

*copyc jmc$maximum_mainframes
*DECK DECK=JMT$VERTICAL_PRINT_DENSITY EXPAND=FALSE

  TYPE
    jmt$vertical_print_density = (jmc$vertical_print_density_file,
          jmc$vertical_print_density_none, jmc$vertical_print_density_6,
          jmc$vertical_print_density_7, jmc$vertical_print_density_8,
          jmc$vertical_print_density_9, jmc$vertical_print_density_10,
          jmc$vertical_print_density_11, jmc$vertical_print_density_12);
*DECK DECK=JMT$VFU_LOAD_PROCEDURE EXPAND=FALSE

  TYPE
    jmt$vfu_load_procedure = ost$name;

*copyc ost$name
*DECK DECK=JMT$WAYS_TO_CHANGE_OBJECT EXPAND=FALSE

  TYPE
    jmt$ways_to_change_object = (jmc$replace, jmc$update, jmc$add_list_items,
          jmc$delete_list_items);

*DECK DECK=JMT$WORKING_SET_SIZE EXPAND=FALSE

  TYPE
    jmt$working_set_size = 0 .. jmc$working_set_size_maximum;

  CONST
    jmc$working_set_size_maximum = jmc$highest_working_set_size +
          jmc$keyword_offset_maximum;

{ The following constants define the range of values permitted on SCL
{ parameter definitions and the internal representation for the keywords,
{ UNLIMITED, UNSPECIFIED, REQUIRED, and SYSTEM_DEFAULT.

  CONST
    jmc$lowest_working_set_size = 20,
    jmc$highest_working_set_size = 65000,
    jmc$unlimited_working_set_size = jmc$highest_working_set_size +
          jmc$unlimited_offset,
    jmc$unspecified_work_set_size = jmc$highest_working_set_size +
          jmc$unspecified_offset,
    jmc$required_working_set_size = jmc$highest_working_set_size +
          jmc$required_offset,
    jmc$system_default_work_set_siz = jmc$highest_working_set_size +
          jmc$system_default_offset;

*copyc jmc$attribute_keyword_offsets
*DECK DECK=JMT$WORK_AREA EXPAND=FALSE

  TYPE
    jmt$work_area = SEQ ( * );
*DECK DECK=JMV$AJL_LOCK EXPAND=FALSE
VAR
  jmv$ajl_lock: [XREF] ost$signature_lock;

?? PUSH(LIST := OFF) ??
*copyc ost$signature_lock
?? POP ??
*DECK DECK=JMV$AJL_P EXPAND=FALSE
{Pointer to the AJL.}
  VAR
    jmv$ajl_p: [XREF] ^jmt$active_job_list;
?? PUSH (LISTEXT := ON) ??
*copyc JMT$ACTIVE_JOB_LIST
?? POP ??
*DECK DECK=JMV$APPLICATION_TABLE_P EXPAND=FALSE

  VAR
    jmv$application_table_p: [XREF] ^jmt$application_table;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$application_table
?? POP ??
*DECK DECK=JMV$AUTOMATIC_JOB_INIT EXPAND=FALSE
  VAR
    jmv$automatic_job_init: [XREF] jmt$initiation_conditions;

?? PUSH (LISTEXT := ON) ??
*copyc JMT$INITIATION_CONDITIONS
?? POP ??
*DECK DECK=JMV$CANDIDATE_QUEUED_JOBS EXPAND=FALSE

  VAR
    jmv$candidate_queued_jobs: [XREF] jmt$candidate_queued_jobs;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$candidate_queued_jobs
?? POP ??
*DECK DECK=JMV$CHANGE_DISPATCHING_LIST EXPAND=FALSE

  VAR
    jmv$change_dispatching_list: [XREF] jmt$change_dispatching_list;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$change_dispatching_list
?? POP ??
*DECK DECK=JMV$CLASSES_IN_MAXAJ_LIMIT_WAIT EXPAND=FALSE

  VAR
    jmv$classes_in_maxaj_limit_wait: [XREF] jmt$service_class_set;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_class_set
?? POP ??
*DECK DECK=JMV$CLASSES_IN_RESOURCE_WAIT EXPAND=FALSE

  VAR
    jmv$classes_in_resource_wait: [XREF] jmt$service_class_set;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_class_set
?? POP ??
*DECK DECK=JMV$CLUSTER_ATTACH_JOB_ENABLED EXPAND=FALSE
  VAR
    jmv$cluster_attach_job_enabled: [XREF] boolean;
*DECK DECK=JMV$CONNECTION_ACQUIRED EXPAND=FALSE
  VAR
    jmv$connection_acquired: [XREF] boolean;

*DECK DECK=JMV$CURRENT_CLASS_NAME EXPAND=FALSE

  VAR
    jmv$current_class_name: [XREF] array [jmt$profile_object_kinds] of
          ^array [1 .. * ] of ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$profile_object_kinds
*copyc ost$name
?? POP ??
*DECK DECK=JMV$CURRENT_PROFILE_LEVEL EXPAND=FALSE

  VAR
    jmv$current_profile_level: [XREF] jmt$profile_object_kinds;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$profile_object_kinds
?? POP ??
*DECK DECK=JMV$DEFAULT_APPLICATION_ATTR EXPAND=FALSE


  VAR
    jmv$default_application_attr: [XREF] jmt$application_attributes;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$application_attributes
?? POP ??
*DECK DECK=JMV$DEFAULT_JOB_ATTRIBUTES EXPAND=FALSE

  VAR
    jmv$default_job_attributes: [XREF] jmt$default_job_attributes;

?? PUSH(LISTEXT := ON) ??
*copyc jmt$default_job_attributes
?? POP ??
*DECK DECK=JMV$DEFAULT_JOB_CLASS_ATTR EXPAND=FALSE

  VAR
    jmv$default_job_class_attr: [XREF] jmt$job_class_attributes;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class_attributes
?? POP ??
*DECK DECK=JMV$DEFAULT_OUTPUT_CLASS_ATTR EXPAND=FALSE

  VAR
    jmv$default_output_class_attr: [XREF] jmt$output_class_attributes;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$output_class_attributes
?? POP ??
*DECK DECK=JMV$DEFAULT_SERVICE_CLASS_ATTR EXPAND=FALSE

  VAR
    jmv$default_service_class_attr: [XREF] jmt$service_class_attributes;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_class_attributes
?? POP ??
*DECK DECK=JMV$DELETE_OLD_TEMPLATES EXPAND=FALSE
  VAR
    jmv$delete_old_templates: [XREF] boolean;

*DECK DECK=JMV$DISPATCHING_PRIORITY_NAMES EXPAND=FALSE

  VAR
    jmv$dispatching_priority_names: [XREF, READ, oss$job_paged_literal]
          array [1 .. 10] of string (3);

?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=JMV$ENABLE_QUEUE_FILE_ACCESS EXPAND=FALSE

  VAR
    jmv$enable_queue_file_access: [XREF] boolean;
*DECK DECK=JMV$EXECUTING_WITHIN_SYSTEM_JOB EXPAND=FALSE

  VAR
    jmv$executing_within_system_job: [XREF, oss$job_fixed] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc OSS$JOB_FIXED
?? POP ??
*DECK DECK=JMV$HIGHEST_RANK_JOB_CLASS EXPAND=FALSE

  VAR
    jmv$highest_rank_job_class: [XREF] jmt$job_class;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
?? POP ??
*DECK DECK=JMV$IDLE_DISPATCHING_CONTROLS EXPAND=FALSE

  VAR
    jmv$idle_dispatching_controls: [XREF] jmt$idle_dispatching_controls;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$idle_dispatching_controls
?? POP ??
*DECK DECK=JMV$IJLE_SIZE EXPAND=FALSE

  VAR
    jmv$ijle_size: [XREF] jmt$ijle_size;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijle_size
?? POP ??
*DECK DECK=JMV$IJL_ENTRY_STATUS_STATISTICS EXPAND=FALSE

  VAR
    jmv$ijl_entry_status_statistics: [XREF] jmt$ijl_entry_status_statistics;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_entry_status_statistics
?? POP ??
*DECK DECK=JMV$IJL_P EXPAND=FALSE
{Define pointer to Initiated Job List (IJL).

  VAR
    jmv$ijl_p: [XREF]  jmt$ijl_p;
?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_p
?? POP ??
*DECK DECK=JMV$IJL_READY_TASK_LIST EXPAND=FALSE

  VAR

{ NOTE:  Because this variable is read/written by both job mode and monitor mode scheduler,
{ it is a locked variable and can be referenced only via the compare_swap procedures.

    jmv$ijl_ready_task_list: [XREF] integer;

*DECK DECK=JMV$INITIALIZED_AS_DISCONNECTED EXPAND=FALSE
  VAR
    jmv$initialized_as_disconnected: [XREF] boolean;

*DECK DECK=JMV$INPUT_FILE_RECOVERY_OPTION EXPAND=FALSE
{ Defines the recovery options for input files.  The options are:
{  0 - Recover all input files (the default).
{  1 - Don't recover any input files.

  VAR
    jmv$input_file_recovery_option: [XREF, oss$mainframe_pageable] ost$byte;

?? PUSH (LISTEXT := ON) ??
  CONST
    jmc$ifro_recover_all_files = 0,
    jmc$ifro_recover_no_files = 1;

*copyc oss$mainframe_pageable
*copyc ost$byte
?? POP ??
*DECK DECK=JMV$JCB EXPAND=FALSE
{Job Control Block (JCB).}

  VAR
    jmv$jcb: [XREF] jmt$job_control_block;
?? PUSH (LISTEXT := ON) ??
*copyc JMT$JOB_CONTROL_BLOCK
?? POP ??
*DECK DECK=JMV$JMTR_XCB EXPAND=FALSE

  VAR
    jmv$jmtr_xcb: [XREF] ost$execution_control_block;

?? PUSH (LISTEXT := ON) ??
*copyc OST$EXECUTION_CONTROL_BLOCK
?? POP ??

*DECK DECK=JMV$JOB_ATTRIBUTES EXPAND=FALSE

  VAR
   jmv$job_attributes: [XREF] jmt$job_attributes;

?? PUSH(LISTEXT := ON) ??
*copyc jmt$job_attributes
?? POP ??
*DECK DECK=JMV$JOB_CATEGORY_DATA EXPAND=FALSE

  VAR
    jmv$job_category_data: [XREF] jmt$job_category_data;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_category_data
?? POP ??
*DECK DECK=JMV$JOB_CLASS_LIMITS EXPAND=FALSE

  VAR
    jmv$job_class_limits: [XREF] jmt$job_class_limits;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class_limits
?? POP ??
*DECK DECK=JMV$JOB_CLASS_TABLE_P EXPAND=FALSE

  VAR
    jmv$job_class_table_p: [XREF] ^jmt$job_class_table;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class_table
?? POP ??
*DECK DECK=JMV$JOB_COMMAND_INPUT_FAP_P EXPAND=FALSE

  VAR
    jmv$job_command_input_fap_p: [XREF] amt$fap_pointer;

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??

*DECK DECK=JMV$JOB_COUNTS EXPAND=FALSE

  VAR
    jmv$job_counts: [XREF] jmt$job_counts;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_counts
?? POP ??
*DECK DECK=JMV$JOB_COUNTS_LOCK EXPAND=FALSE

  VAR
    jmv$job_counts_lock: [XREF] ost$signature_lock;

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??
*DECK DECK=JMV$JOB_DISPOSITION_CODE EXPAND=FALSE

  VAR
    jmv$job_disposition_code: [XREF, oss$job_pageable] jmt$disposition_code;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$disposition_code
*copyc oss$job_pageable
?? POP ??
*DECK DECK=JMV$JOB_EXECUTION_ATTRIBUTES EXPAND=FALSE

  VAR
    jmv$job_execution_attributes: [XREF] jmt$job_execution_attributes;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_execution_attributes
?? POP ??
*DECK DECK=JMV$JOB_HISTORY_ACTIVE EXPAND=TRUE

  VAR
    jmv$job_history_active: [XREF] boolean;

*DECK DECK=JMV$JOB_INPUT_FAP_P EXPAND=FALSE

  VAR
    jmv$job_input_fap_p: [XREF] amt$fap_pointer;

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=JMV$JOB_MANAGEMENT_WORK_AREA_P EXPAND=FALSE

  VAR
    jmv$job_management_work_area_p: [XREF, oss$task_private] ^jmt$work_area;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$work_area
*copyc oss$task_private
?? POP ??
*DECK DECK=JMV$JOB_OUTPUT_FAP_P EXPAND=FALSE

  VAR
    jmv$job_output_fap_p: [XREF] amt$fap_pointer;

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=JMV$JOB_RECOVERY_INFORMATION_P EXPAND=FALSE

  VAR
    jmv$job_recovery_information_p: [XREF, READ] ^jmt$job_recovery_information;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_recovery_information
?? POP ??
*DECK DECK=JMV$JOB_RESOURCE_CONDITION EXPAND=FALSE
 VAR
    jmv$job_resource_condition: [XREF] jmt$job_resource_condition;

*copyc jmd$job_resource_condition
*DECK DECK=JMV$JOB_SCHEDULER_EVENT EXPAND=FALSE
  VAR
    jmv$job_scheduler_event: [XREF]  jmt$job_scheduler_event;

?? PUSH(LISTEXT := ON) ??
*copyc jmt$job_scheduler_event
?? POP ??
*DECK DECK=JMV$JOB_SCHEDULER_STATISTICS EXPAND=FALSE

  VAR
    jmv$job_scheduler_statistics: [XREF] jmt$job_scheduler_statistics;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_scheduler_statistics
?? POP ??
*DECK DECK=JMV$JOB_SCHEDULER_TABLE EXPAND=FALSE

  VAR
    jmv$job_scheduler_table: [XREF] jmt$job_scheduler_table;

?? PUSH (LISTEXT := ON) ??
*copyc JMT$JOB_SCHEDULER_TABLE
?? POP ??
*DECK DECK=JMV$JOB_SCHED_EVENTS_SELECTED EXPAND=FALSE

  VAR
    jmv$job_sched_events_selected: [XREF] jmt$job_sched_event_selections;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_scheduler_event
?? POP ??
*DECK DECK=JMV$JOB_SCHED_SERV_CLASS_STATS EXPAND=FALSE
  VAR
    jmv$job_sched_serv_class_stats: [XREF, oss$mainframe_wired]
          jmt$job_sched_serv_class_stats;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_sched_serv_class_stats
*copyc oss$mainframe_wired
?? POP ??
*DECK DECK=JMV$JOB_TERMINATION_STATUS EXPAND=FALSE

  VAR
    jmv$job_termination_status: [XREF] ^ost$status;

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=JMV$JOB_TRAP_HANDLER EXPAND=FALSE
{Pointer to job trap handler.

  VAR
    jmv$job_trap_handler: [XREF] ^PROCEDURE;

*DECK DECK=JMV$KJLX_P EXPAND=FALSE

  VAR
    jmv$kjlx_p: [XREF] ^array [1 .. * ] of jmt$known_job_list_extended;

?? PUSH(LISTEXT := ON) ??
*copyc jmt$known_job_list_extended
?? POP ??
*DECK DECK=JMV$KJL_P EXPAND=FALSE

  VAR
    jmv$kjl_p: [XREF] ^array [1 .. * ] of jmt$known_job_list_entry;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$known_job_list_entry
?? POP ??
*DECK DECK=JMV$KNOWN_JOB_LIST EXPAND=FALSE

  VAR
    jmv$known_job_list: [XREF] jmt$known_job_list;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$known_job_list
?? POP ??
*DECK DECK=JMV$KNOWN_OUTPUT_LIST EXPAND=FALSE

  VAR
    jmv$known_output_list: [XREF] jmt$known_output_list;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$known_output_list
?? POP ??
*DECK DECK=JMV$KNOWN_QFILE_LIST EXPAND=FALSE
  VAR
    jmv$known_qfile_list: [XREF, oss$mainframe_pageable] jmt$known_qfile_list;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$known_qfile_list
*copyc oss$mainframe_pageable
?? POP ??
*DECK DECK=JMV$KOL_P EXPAND=FALSE

  VAR
    jmv$kol_p: [XREF] ^array [1 .. * ] of jmt$known_output_list_entry;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$known_output_list_entry
?? POP ??
*DECK DECK=JMV$KQL_P EXPAND=FALSE

  VAR
    jmv$kql_p: [XREF] ^array [1 .. * ] of jmt$known_qfile_list_entry;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$known_qfile_list_entry
?? POP ??
*DECK DECK=JMV$LAST_SERVICE_CALC_TIME EXPAND=FALSE

  VAR
    jmv$last_service_calc_time: [XREF] ost$free_running_clock;

?? PUSH (LISTEXT := ON) ??
*copyc ost$free_running_clock
?? POP ??
*DECK DECK=JMV$LAST_USED_APPLICATION_INDEX EXPAND=FALSE

  VAR
    jmv$last_used_application_index: [XREF, oss$mainframe_pageable]
          jmt$qfile_application_index;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$qfile_application_table
*copyc oss$mainframe_pageable
?? POP ??
*DECK DECK=JMV$LEVELER_PROFILE_LOADING EXPAND=FALSE

  VAR
    jmv$leveler_profile_loading: [XREF, oss$mainframe_pageable] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_pageable
?? POP ??
*DECK DECK=JMV$LONG_WAIT_SWAP_THRESHOLD EXPAND=FALSE

{ This variable is used by swapper to determine if a swapped job should be left
{ in the long wait queue, or if the job should be swapped to disk.  The array is
{ indexed by dispatching priority.  Each array element holds the number of pages
{ needed by scheduler to activate all swapin candidates of equal and higher
{ dispatching priorities.

  VAR
    jmv$long_wait_swap_threshold: [XREF] jmt$long_wait_swap_threshold;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$long_wait_swap_threshold
?? POP ??
*DECK DECK=JMV$MAXIMUM_JOB_CLASSES EXPAND=FALSE

  VAR
    jmv$maximum_job_classes: [XREF] 0..0ffffffff(16);

*DECK DECK=JMV$MAXIMUM_JOB_CLASS_IN_USE EXPAND=FALSE

  VAR
    jmv$maximum_job_class_in_use: [XREF] jmt$job_class;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
?? POP ??

*DECK DECK=JMV$MAXIMUM_KNOWN_JOBS EXPAND=FALSE

  VAR
    jmv$maximum_known_jobs: [XREF, oss$mainframe_pageable] ost$halfword;

?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_pageable
*copyc ost$halfword
?? POP ??
*DECK DECK=JMV$MAXIMUM_KNOWN_OUTPUTS EXPAND=FALSE

  VAR
    jmv$maximum_known_outputs: [XREF, oss$mainframe_pageable] ost$halfword;

?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_pageable
*copyc ost$halfword
?? POP ??
*DECK DECK=JMV$MAXIMUM_OUTPUT_CLASSES EXPAND=FALSE

  VAR
    jmv$maximum_output_classes: [XREF] 0..0ffffffff(16);

*DECK DECK=JMV$MAXIMUM_OUTPUT_CLASS_IN_USE EXPAND=FALSE

  VAR
    jmv$maximum_output_class_in_use: [XREF] jmt$output_class_index;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$output_class_index
?? POP ??

*DECK DECK=JMV$MAXIMUM_PROFILE_INDEX EXPAND=FALSE

  VAR
    jmv$maximum_profile_index: [XREF] jmt$job_class;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
?? POP ??
*DECK DECK=JMV$MAXIMUM_SERVICE_CLASSES EXPAND=FALSE

  VAR
    jmv$maximum_service_classes: [XREF] 0..0ffffffff(16);

*DECK DECK=JMV$MAX_AJL_ORDINAL_IN_USE EXPAND=FALSE

VAR
  jmv$max_ajl_ordinal_in_use: [XREF] jmt$ajl_ordinal;


?? PUSH (LISTEXT := ON) ??
*copyc jmt$ajl_ordinal
?? POP ??
*DECK DECK=JMV$MAX_CLASS_WORKING_SET EXPAND=FALSE

  VAR
    jmv$max_class_working_set: [XREF] jmt$working_set_size;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$working_set_size
?? POP ??
*DECK DECK=JMV$MAX_SERVICE_CLASS_IN_USE EXPAND=FALSE

  VAR
    jmv$max_service_class_in_use: [XREF] jmt$service_class_index;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_class_index
?? POP ??

*DECK DECK=JMV$MEMORY_NEEDED_BY_SCHEDULER EXPAND=FALSE

  VAR
    jmv$memory_needed_by_scheduler: [XREF] mmt$page_frame_index;

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_index
?? POP ??
*DECK DECK=JMV$MEMORY_QUEUE_UPDATE_BY_SWAP EXPAND=FALSE

  VAR
    jmv$memory_queue_update_by_swap: [XREF] 0 .. 0ffff(16);
*DECK DECK=JMV$MODIFY_DISPLAY_ATTRIBUTES EXPAND=FALSE

  VAR
    jmv$modify_display_attributes: [XREF] ^jmt$modify_display_attributes;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$modify_display_attributes
?? POP ??
*DECK DECK=JMV$NEW_PROFILE EXPAND=FALSE

  VAR
    jmv$new_profile: [XREF] jmt$profile_data;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$profile_data
?? POP ??

*DECK DECK=JMV$NEXT_JOB_CAND_REFRESH_TIME EXPAND=FALSE
  VAR
    jmv$next_job_cand_refresh_time: [XREF, oss$mainframe_pageable] integer;

?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_pageable
?? POP ??
*DECK DECK=JMV$NULL_DATE_TIME EXPAND=FALSE

  VAR
    jmv$null_date_time: [XREF] ost$date_time;

*copyc ost$date_time
*DECK DECK=JMV$NULL_IJL_ORDINAL EXPAND=FALSE

  VAR
    jmv$null_ijl_ordinal: [XREF] jmt$ijl_ordinal;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=JMV$NUMBER_FREE_AJL_ENTRIES EXPAND=FALSE

VAR
  jmv$number_free_ajl_entries: [XREF] integer;
*DECK DECK=JMV$OBJECT_DEFINITION EXPAND=FALSE

  VAR
    jmv$object_definition: [XREF] jmt$object_definition;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$object_definition
?? POP ??
*DECK DECK=JMV$OBJECT_HEAP EXPAND=FALSE

  VAR
    jmv$object_heap: [XREF] ^HEAP ( * );

*DECK DECK=JMV$OUTPUT_CLASS_TABLE_P EXPAND=FALSE

  VAR
    jmv$output_class_table_p: [XREF] ^jmt$output_class_table;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$output_class_table
?? POP ??
*DECK DECK=JMV$OUTPUT_FILE_RECOVERY_OPTION EXPAND=FALSE
{ Defines the recovery options for output files.  The options are:
{  0 - Recover all output files (the default).
{  1 - Don't recover any output files.

  VAR
    jmv$output_file_recovery_option: [XREF, oss$mainframe_pageable] ost$byte;

?? PUSH (LISTEXT := ON) ??
  CONST
    jmc$ofro_recover_all_files = 0,
    jmc$ofro_recover_no_files = 1;

*copyc oss$mainframe_pageable
*copyc ost$byte
?? POP ??
*DECK DECK=JMV$PREVENT_ACTIVATION_OF_JOBS EXPAND=FALSE

  VAR
    jmv$prevent_activation_of_jobs: [XREF] boolean;
*DECK DECK=JMV$PROFILE_INDEX_TO_JOB_CLASS EXPAND=FALSE

  VAR
    jmv$profile_index_to_job_class: [XREF] jmt$profile_index_to_job_class;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$profile_index_to_job_class
?? POP ??
*DECK DECK=JMV$PURGE_EXPIRED_QFILE_TIME EXPAND=FALSE

  VAR
    jmv$purge_expired_qfile_time: [XREF] jmt$clock_time;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$clock_time
?? POP ??
*DECK DECK=JMV$PURGE_PROCESSED_QFILE_TIME EXPAND=FALSE

  VAR
    jmv$purge_processed_qfile_time: [XREF] jmt$clock_time;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$clock_time
?? POP ??
*DECK DECK=JMV$QFILE_RECOVERY_OPTION EXPAND=FALSE
{ Defines the recovery options for generic queue files.  The options are:
{  0 - Recover all generic queue files (the default).
{  1 - Don't recover any generic queue files.

  VAR
    jmv$qfile_recovery_option: [XREF, oss$mainframe_pageable] ost$byte;

?? PUSH (LISTEXT := ON) ??

  CONST
    jmc$qro_recover_all_files = 0,
    jmc$qro_recover_no_files = 1;

*copyc oss$mainframe_pageable
*copyc ost$byte
?? POP ??
*DECK DECK=JMV$READY_DEFERRED_QFILE_TIME EXPAND=FALSE

  VAR
    jmv$ready_deferred_qfile_time: [XREF] jmt$clock_time;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$clock_time
?? POP ??
*DECK DECK=JMV$RECOVERY_JOB_TEMPLATE_NAME EXPAND=FALSE

  VAR
    jmv$recovery_job_template_name: [XREF] ost$name;

?? PUSH ( LIST := OFF {LISTEXT:=ON} ) ??
*copyc OST$NAME
?? POP ??
*DECK DECK=JMV$REFRESH_JOB_CANDIDATES EXPAND=FALSE

  VAR
    jmv$refresh_job_candidates: [XREF] boolean;
*DECK DECK=JMV$SCAN_IDLE_DISPATCH_INTERVAL EXPAND=FALSE

  VAR
    jmv$scan_idle_dispatch_interval: [XREF] integer;
*DECK DECK=JMV$SCHEDULER_TABLES_ACCESS EXPAND=FALSE

  VAR
    jmv$scheduler_tables_access: [XREF] jmt$scheduler_tables_access;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$scheduler_tables_access
?? POP ??
*DECK DECK=JMV$SCHEDULER_WAIT_TIME EXPAND=FALSE

  VAR
    jmv$scheduler_wait_time: [XREF] integer;
*DECK DECK=JMV$SCHEDULING_UTILITY_USAGE EXPAND=FALSE

  VAR
    jmv$scheduling_utility_usage: [XREF] jmt$scheduling_utility_usage;

*copyc jmt$scheduling_utility_usage
*DECK DECK=JMV$SCHED_MEMORY_WAIT_FACTOR EXPAND=FALSE

  VAR
    jmv$sched_memory_wait_factor: [XREF] integer;

*DECK DECK=JMV$SCHED_PROFILE_IS_LOADING EXPAND=FALSE

  VAR
    jmv$sched_profile_is_loading: [XREF] boolean;

*DECK DECK=JMV$SCHED_SERVICE_CALC_TIME EXPAND=FALSE

  VAR
    jmv$sched_service_calc_time: [XREF] ost$free_running_clock;
*DECK DECK=JMV$SDT EXPAND=FALSE


{  Define variable that is the address (PVA) of the segment descriptor
{  table (SDT).  The pointer is valid in job mode during deadstart.

  VAR
    jmv$sdt: [XREF] mmt$max_sdt;

?? PUSH (LISTEXT := ON) ??
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE
?? POP ??
*DECK DECK=JMV$SDTX EXPAND=FALSE


{  Define variable that is the address (PVA) of the segment descriptor table
{  extended (SDTX).  The pointer is valid in job mode during deadstart.

  VAR
    jmv$sdtx: [XREF] ^mmt$segment_descriptor_table_ex;

?? PUSH (LISTEXT := ON) ??
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE_EX
?? POP ??
*DECK DECK=JMV$SERVICE_CLASSES EXPAND=FALSE
  VAR
    jmv$service_classes: [XREF, oss$mainframe_wired]
          array [jmt$service_class_index] of ^jmt$service_class_entry;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_class_entry
*copyc jmt$service_class_index
*copyc oss$mainframe_wired
?? POP ??

*DECK DECK=JMV$SERVICE_CLASS_STATS_LOCK EXPAND=FALSE

  VAR
    jmv$service_class_stats_lock: [XREF] tmt$ptl_lock;

?? PUSH (LISTEXT := ON) ??
*copyc tmt$ptl_lock
?? POP ??
*DECK DECK=JMV$SSN_MASK EXPAND=FALSE
  VAR
    jmv$ssn_mask : [XREF, READ, oss$mainframe_paged_literal] string (256);

?? PUSH ( LISTEXT := ON ) ??
*copyc oss$mainframe_paged_literal
?? POP ??
*DECK DECK=JMV$SSN_PREVIOUS_SEQUENCE EXPAND=FALSE

  VAR
    jmv$ssn_previous_sequence: [XREF] jmt$ssn_sequence_number;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ssn_sequence_number
?? POP ??
*DECK DECK=JMV$SUBSYSTEM_PRIORITY_CHANGES EXPAND=FALSE

  VAR
    jmv$subsystem_priority_changes: [XREF] PACKED ARRAY [jmt$service_class_index] of boolean;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_class_index
?? POP ??
*DECK DECK=JMV$SWAPIN_CANDIDATE_QUEUE EXPAND=FALSE

  VAR
    jmv$swapin_candidate_queue: [XREF] array [jmt$service_class_index] of jmt$swapin_candidate_q_header;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$swapin_candidate_q_header
?? POP ??
*DECK DECK=JMV$SWAP_FILE_ALLOCATION_SIZE EXPAND=FALSE
{Define allocation size for swap files.

  VAR
    jmv$swap_file_allocation_size: [XREF] 0 .. 0ffffffff(16);

*DECK DECK=JMV$SWAP_JOBS_IN_LONG_WAIT EXPAND=FALSE
{Define boolean that specifies whether jobs that go into long wait should be
{swapped immediately.

  VAR
    jmv$swap_jobs_in_long_wait: [XREF] boolean;

*DECK DECK=JMV$SYSTEM_AJL_ORDINAL EXPAND=FALSE
{Define value of AJL ORDINAL used by the system job

  VAR
    jmv$system_ajl_ordinal: [XREF]jmt$ajl_ordinal;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ajl_ordinal
?? POP ??
*DECK DECK=JMV$SYSTEM_CORE_ID EXPAND=FALSE

  VAR
    jmv$system_core_id: [XREF] ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=JMV$SYSTEM_CORE_TEMPLATE EXPAND=FALSE
VAR
  jmv$system_core_template: [XREF] jmt$system_core_template;
?? PUSH(LIST := OFF) ??
*copyc JMT$SYSTEM_CORE_TEMPLATE
?? POP ??
*DECK DECK=JMV$SYSTEM_IJL_ORDINAL EXPAND=FALSE
  VAR
    jmv$system_ijl_ordinal: [XREF] jmt$ijl_ordinal;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=JMV$SYSTEM_JOB_SSN EXPAND=FALSE

  VAR
    jmv$system_job_ssn: [XREF] jmt$system_supplied_name;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
?? POP ??
*DECK DECK=JMV$SYSTEM_JOB_TEMPLATE_NAME EXPAND=FALSE

  VAR
    jmv$system_job_template_name: [XREF] ost$name;

?? PUSH ( LIST := OFF {LISTEXT:=ON} ) ??
*copyc OST$NAME
?? POP ??
*DECK DECK=JMV$SYSTEM_JOB_TEMPLATE_P EXPAND=FALSE
 VAR
     jmv$system_job_template_p: [XREF] ^jmt$job_template_entry;
?? PUSH(LIST := OFF) ??
*copyc JMT$JOB_TEMPLATE_ENTRY
?? POP ??
*DECK DECK=JMV$SYSTEM_SUPPLIED_NAME EXPAND=FALSE

  VAR
    jmv$system_supplied_name: [XREF] jmt$system_supplied_name_mask;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name_mask
?? POP ??
*DECK DECK=JMV$TASK_PRIVATE_TEMPL_P EXPAND=FALSE
 VAR
    jmv$task_private_templ_p: [XREF] ^pmt$task_template;
?? PUSH(LIST := OFF) ??
*copyc PMT$TASK_TEMPLATE
?? POP ??
*DECK DECK=JMV$TERMINAL_IO_DISABLED EXPAND=FALSE


  VAR
    jmv$terminal_io_disabled: [XREF] boolean;
*DECK DECK=JMV$THE_PROFILE EXPAND=FALSE

  VAR
    jmv$the_profile: [XREF] jmt$profile_data;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$profile_data
?? POP ??
*DECK DECK=JMV$TIMESHARING_JOB EXPAND=FALSE

  VAR
    jmv$timesharing_job: [XREF] boolean;
*DECK DECK=JMV$TIME_TO_PURGE_EXPIRED_FILE EXPAND=FALSE

  VAR
    jmv$time_to_purge_expired_file: [XREF] jmt$clock_time;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$clock_time
?? POP ??
*DECK DECK=JMV$TIME_TO_PURGE_PRINTED_FILE EXPAND=FALSE

  VAR
    jmv$time_to_purge_printed_file: [XREF] jmt$clock_time;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$clock_time
?? POP ??
*DECK DECK=JMV$TIME_TO_READY_DEFERRED_FILE EXPAND=FALSE

  VAR
    jmv$time_to_ready_deferred_file: [XREF] jmt$clock_time;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$clock_time
?? POP ??
*DECK DECK=JMV$TIME_TO_READY_DEFERRED_JOB EXPAND=FALSE

  VAR
    jmv$time_to_ready_deferred_job: [XREF] jmt$clock_time;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$clock_time
?? POP ??
*DECK DECK=JMV$TIME_TO_WAKE_SCHEDULER EXPAND=FALSE

  VAR
    jmv$time_to_wake_scheduler: [XREF] ost$free_running_clock;

?? PUSH (LISTEXT := ON) ??
*copyc ost$hardware_subranges
?? POP ??
*DECK DECK=JMV$TOTAL_SWAPPED_JOBS EXPAND=FALSE
   VAR
    jmv$total_swapped_jobs: [XREF] INTEGER;
*DECK DECK=JMV$TS_JOB_DISCONNECTED EXPAND=FALSE

  VAR
    jmv$ts_job_disconnected: [XREF] boolean;
*DECK DECK=JMV$USER_BREAKS_ENABLED EXPAND=FALSE

  VAR
    jmv$user_breaks_enabled: [XREF] boolean;
*DECK DECK=JMV$UTILITY_FUNCTIONS EXPAND=FALSE

  VAR
    jmv$utility_functions: [XREF] ^clt$function_processor_table;

?? PUSH (LISTEXT := ON) ??
*copyc clt$function_processor_table
?? POP ??
*DECK DECK=JMV$WORKING_STORAGE EXPAND=FALSE

  VAR
    jmv$working_storage: [XREF] ^SEQ ( * );

*DECK DECK=JMV$XCB_P EXPAND=FALSE
{Contains a pointer to the XCB of the currently executing task. The
{pointer is valid in job mode.

  VAR
    jmv$xcb_p: [XREF] ^ost$execution_control_block;
?? PUSH (LISTEXT := ON) ??
*copyc OST$EXECUTION_CONTROL_BLOCK
?? pop ??
*DECK DECK=JMV$XTERM_JOB EXPAND=FALSE

  VAR
    jmv$xterm_job: [XREF] boolean;

*DECK DECK=JSE$CONDITION_CODES EXPAND=FALSE


?? NEWTITLE := 'ERROR CODES FOR JOB SWAPPER : ''JS'' 0 .. 7', EJECT ??
?? FMT (FORMAT := OFF) ??
  CONST
    jsc$min_ecc = (($INTEGER ('J') * 100(16)) + $INTEGER ('S')) * 1000000(16),
    jsc$min_ecc_js {base error condition code} = jsc$min_ecc {***KLUDGE***},


    jse$not_enough_mem_for_swap_in = jsc$min_ecc_js + 0,
    {E+ Not enough memory in free and available queue to swap job in.}

    jse$unimplemented_subfunction = jsc$min_ecc_js + 1,
    {E+ Unimplemented job swapping monitor subfunction.}

    jse$pt_full_on_swap_in = jsc$min_ecc_js + 2,
    {E+ Page table full on swap in.}

    jse$unable_to_idle_all_tasks = jsc$min_ecc_js + 3,
    {E+ Unable to idle all tasks in the job.}

    jse$job_terminated = jsc$min_ecc_js + 4,
    {E+ Attempted to swap a job that has terminated.}

    jse$job_not_in_long_wait = jsc$min_ecc_js + 5,
    {E+ Attempted a conditional swap of a job not in long wait.}

    jse$job_executing_non_swappable = jsc$min_ecc_js + 6,
    {E+ Job is executing and not swappable.}

    jse$swapin_rejected_pages_freed = jsc$min_ecc_js + 7,
    {E+ Swapin rejected because swapout still active and pages have been freed.}

    jse$swapout_and_job_swapped_out = jsc$min_ecc_js + 8,
    {E+ Job mode swapout request for job already swapped out.}

    jse$swap_file_not_allocated = jsc$min_ecc_js + 9,
    {E+ Swap file not allocated--job mode will be called to allocate.}

    jse$swap_file_volume_unavail = jsc$min_ecc_js + 10,
    {E+ Swap file volume is unavailable.}

    jse$bad_swap_file_data_detected = jsc$min_ecc_js + 11,
    {E+ Bad data was detected in the swap file--the job is dead.}

    jse$job_aged_not_swapped = jsc$min_ecc_js + 12;
    {E+ The job was aged to free memory, not swapped.}

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=JSH$MONITOR_SWAP_IN EXPAND=FALSE

{
{   The purpose of this procedure is to swap a job in that is in long wait.
{ The job may be in the long wait queue, swapped out or in some intermediate
{ state.  The job is swapped in from whatever state it is in.
{
{        JSP$MONITOR_SWAP_IN (IJL_ORDINAL)
{
{ IJL_ORDINAL: (input) This parameter specifies the index in the ijl table
{        of the entry for this job.
{

*DECK DECK=JSH$MONITOR_SWAP_OUT EXPAND=FALSE

{
{   The purpose of this procedure is to prepare the specified job
{ for swapout to mass storage. If memory is needed the swapout IO
{ will be initiated and the memory freed.  How far the swap
{ progresses is determined by memory thresholds.
{
{            JSP$MONITOR_SWAP_OUT (IJL_ORDINAL)
{
{ IJL_ORDINAL: (input) This parameter is the 'ijl_ordinal' of the job
{        being swapped.
{
*DECK DECK=JSH$SWAP_JOB_IN EXPAND=FALSE

{
{   The purpose of this procedure is to read the swapped job image from mass
{ storage into memory and place job in active state so that execution can
{ proceed.
{
{        JSP$SWAP_JOB_IN (IJL_ORDINAL, STATUS)
{
{ IJL_ORDINAL: (input) This parameter specifies the index in the ijl table
{        of the entry for this job.
{
{ STATUS: (output) This paramter is where the request status is returned
{        to the caller.
{
*DECK DECK=JSH$SWAP_JOB_OUT EXPAND=FALSE

{
{ PURPOSE:
{   The purpose of this procedure is to logically swap out a job.
{
{            JSP$SWAP_JOB_OUT (IJL_ORDINAL, SWAPOUT_REASON, STATUS)
{
{   IJL_ORDINAL: (input) This parameter is the 'ijl_ordinal' of the job
{        being swapped.
{
{   SWAPOUT_REASON: (input) This parameter indicates why the job is being
{        swapped out.
{
{   MEMORY_NEEDED: (input) This parameter specifies the number of pages needed
{        by scheduler if this swapout is a preemption for memory only.  This
{        parameter must be 0 if the swapout is for some other reason (ie.,
{        thrashing, maxaj limit, idle_system).
{
{   STATUS: (output) This parameter returns the request status.
{
*DECK DECK=JSK$KEYPOINTS EXPAND=FALSE

{  Define keypoint codes for JSM$ modules

  CONST

    jsk$monitor_swap_in = jsk$base + 0,
      {E  'jsp$monitor_swap_in' }
      {X  'jsp$monitor_swap_in' }

    jsk$flush_am_pages_to_disk = jsk$base + 1,
      {E  'jsp$flush_am_pages_to_disk' }
      {X  'jsp$flush_am_pages_to_disk' }

    jsk$mtr_job_swapping_requests = jsk$base + 2,
      {E  'jsp$mtr_job_swapping_requests' }
      {X  'jsp$mtr_job_swapping_requests' }

    jsk$long_wait_aging = jsk$base + 3,
      {E  'jsp$long_wait_aging' }
      {X  'jsp$long_wait_aging' }

    jsk$swap_polling = jsk$base + 4,
      {E  'jsp$swap_polling' }
      {X  'jsp$swap_polling' }

    jsk$free_swapped_jobs_mm_resour = jsk$base + 5,
      {E  'jsp$free_swapped_jobs_mm_resour' }
      {X  'jsp$free_swapped_jobs_mm_resour' }

    jsk$initiate_swapout_io = jsk$base + 6,
      {E  'jsp$initiate_swapout_io' }
      {X  'jsp$initiate_swapout_io' }

    jsk$free_swapped_jobs_memory = jsk$base + 7,
      {E  'jsp$free_swapped_jobs_memory' }
      {X  'jsp$free_swapped_jobs_memory' }

    jsk$limit = jsk$base + 100;

*copyc AMK$BASE_KEYPOINT_VALUES





*DECK DECK=JSM$JOB_SWAPPER EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'JSM$JOB_SWAPPER' ??
MODULE jsm$job_swapper {JSMJS} ;

{
{   The purpose of this module is to swap jobs in and out.  When this
{ module called the job should be in an idle state.  Swapping a job is
{ the process of collecting all of the pages of the job currently in
{ memory and writing them to mass storage along with the information
{ necessary to read job from mass storage and put into state such that
{ execution may proceed.  Swapping a job in is the process of moving the
{ job image from mass storage back into memory.
{

?? PUSH (LISTEXT := ON) ??
*copyc dmt$error_condition_codes
*copyc dmt$minimum_allocation_unit
*copyc jmt$active_job_list
*copyc jmt$ajl_ordinal
*copyc jmt$swapped_job_entry
*copyc jse$condition_codes
*copyc jst$rb_job_swapping_functions
*copyc jst$swap_state_statistics
*copyc jst$swap_file_descriptor
*copyc jmt$initiated_job_list_entry
*copyc jmt$ijl_ordinal
*copyc ioe$st_errors
*copyc ost$status
*copyc sft$file_space_limit_kind
*copyc syc$monitor_request_codes
?? POP ??



{  External procedures called by this module.

*copyc dmp$allocate_file_space_r1
*copyc dmp$file_on_down_volume
*copyc dmp$reallocate_file_space
*copyc dmp$reassign_file
*copyc dmp$set_eoi
*copyc i#call_monitor
*copyc jmp$get_ijle_p
*copyc lgp$add_entry_to_system_log
*copyc pmp$delay
*copyc syp$set_status_from_mtr_status


{  Global variables referenced by this module.

*copyc jmv$ijl_p
*copyc jmv$null_ijl_ordinal
*copyc jsv$ijl_swap_queue_list
*copyc jsv$swap_state_statistics
*copyc osv$page_size
?? TITLE := 'ISSUE_MONITOR_REQUEST' ??
?? EJECT ??
{
{     The purpose of this procedure is to issue a monitor request to perform swapping functions
{  that require none of the variants in the request block.
{

  PROCEDURE [INLINE] issue_monitor_request
    (    ijl_ordinal: jmt$ijl_ordinal;
         subfunction: jst$job_swapping_subfunctions;
     VAR status: ost$status);


    VAR
      request_block: jst$rb_job_swapping_functions;


    request_block.reqcode := syc$rc_job_swapping_functions;
    request_block.ijl_ordinal := ijl_ordinal;
    request_block.subfunction := subfunction;

    i#call_monitor (#LOC (request_block), #SIZE (request_block));

    syp$set_status_from_mtr_status (request_block.status, status);

  PROCEND issue_monitor_request;

?? TITLE := 'JSP$ADVANCE_LONG_WAIT_SWAP', EJECT ??

  PROCEDURE [XDCL, #GATE] jsp$advance_long_wait_jobs
    (    flush_all_pages: boolean;
     VAR pages_flushed_from_lw_queue: mmt$page_frame_index);

{ The purpose of this procedure is to advance the swapping of jobs in the long wait
{ queue until the specified amount of memory is freed.

    VAR
      request_block: jst$rb_job_swapping_functions;

    request_block.reqcode := syc$rc_job_swapping_functions;
    request_block.ijl_ordinal := jmv$null_ijl_ordinal;
    request_block.subfunction := jsc$jss_initiate_swapout_io;
    request_block.flush_all_pages := flush_all_pages;

    i#call_monitor (#LOC (request_block), #SIZE (request_block));

    pages_flushed_from_lw_queue := request_block.pages_flushed;

  PROCEND jsp$advance_long_wait_jobs;

?? TITLE := '[XDCL] jsp$help_monitor_mode_swapper', EJECT ??

  PROCEDURE [XDCL] jsp$help_monitor_mode_swapper;

{
{     The purpose of this procedure is to do some work for the monitor mode swapper that it
{  can not do itself.  There will be certain situations when the swap file can not be
{  allocated in monitor mode, or the swap file may need to be reassigned if it is on a downed
{  volume.
{
{ Check if the volume is down.  Reassign the swap file if it is, otherwise wait and try to allocate again.

    TYPE
      message_type = (jsc$mt_reassign_file, jsc$mt_report_status);

    PROCEDURE log_message
      (    request: message_type;
           ijle_p: ^jmt$initiated_job_list_entry);

      VAR
        ignore_status: ost$status,
        log_time: ost$time,
        msg: string (80);

      msg (1, *) := ' ';
      IF request = jsc$mt_reassign_file THEN
        msg (1, 37) := 'Attempt to reassign swap file of job ';
        msg (38, 31) := ijle_p^.system_supplied_name;
      ELSE
        IF ijle_p^.swap_data.swapping_io_error = ioc$unrecovered_error_unit_down THEN
          msg (1, 48) := 'Unable to reassign swap file. Abandoned swap of ';
        ELSE
          msg (1, 48) := 'Unable to allocate swap file. Abandoned swap of ';
        IFEND;
        msg (49, 31) := ijle_p^.system_supplied_name;
      IFEND;
      lgp$add_entry_to_system_log (pmc$msg_origin_system, msg, log_time, ignore_status);
    PROCEND log_message;

?? TITLE := '[XDCL, #GATE] jsp$help_monitor_mode_swapper', EJECT ??


    VAR
      file_reassigned: boolean,
      fix_swap_file_pass: 0 .. 10,
      ijl_bn: jmt$ijl_block_number,
      ijl_bi: jmt$ijl_block_index,
      ijle_p: ^jmt$initiated_job_list_entry,
      ijl_ordinal: jmt$ijl_ordinal,
      local_status: ost$status,
      file_on_down_volume: boolean,
      status: ost$status,
      total_swapped_page_count: integer;

  /search_for_job_1/
    FOR ijl_bn := LOWERBOUND (jmv$ijl_p.block_p^) TO jmv$ijl_p.max_block_in_use DO
      IF (jmv$ijl_p.block_p^ [ijl_bn].index_p <> NIL) THEN

      /search_for_job_2/
        FOR ijl_bi := LOWERVALUE (jmt$ijl_block_index) TO UPPERVALUE (jmt$ijl_block_index) DO
          ijl_ordinal.block_number := ijl_bn;
          ijl_ordinal.block_index := ijl_bi;
          ijle_p := ^jmv$ijl_p.block_p^ [ijl_bn].index_p^ [ijl_bi];
          fix_swap_file_pass := 0;
          file_reassigned := FALSE;

        /fix_swap_file/
          REPEAT
            fix_swap_file_pass := fix_swap_file_pass + 1;
            CASE ijle_p^.swap_status OF
            = jmc$iss_job_allocate_swap_file, jmc$iss_swapped_io_cannot_init =
              CASE ijle_p^.swap_data.swapping_io_error OF

              = ioc$allocate_file_space =
                total_swapped_page_count := ijle_p^.swap_data.swapped_job_page_count +
                      ijle_p^.swap_data.swapped_job_entry.swap_file_descriptor_page_count;
                IF ijle_p^.swap_data.swap_file_length_in_pages < total_swapped_page_count THEN
                  dmp$allocate_file_space_r1 (ijle_p^.swap_data.swap_file_sfid,
                     0, (total_swapped_page_count * osv$page_size), 0, osc$nowait,
                     sfc$no_limit, status);
                  IF NOT status.normal THEN
                    dmp$file_on_down_volume (ijle_p^.swap_data.swap_file_sfid, file_on_down_volume);
                    IF file_on_down_volume THEN
                      IF NOT file_reassigned THEN
                        ijle_p^.swap_data.swapping_io_error := ioc$unrecovered_error_unit_down;
                      ELSE
                        EXIT /fix_swap_file/;
                      IFEND;
                    ELSE
                      pmp$delay (1000, local_status);
                    IFEND;
                  ELSE

{ The following call to device management is required to insure that EOI of the swap file is set.
{ This is only required for the situation where the job is swapped out and is not swapped in
{ again until we are attempting job recovery. This call can be removed when the procedure
{ DMP$FETCH_CHAPTER_INFO sets EOI of a file on a write instead of a read.

                    dmp$set_eoi (ijle_p^.swap_data.swap_file_sfid,
                      (total_swapped_page_count * osv$page_size), status);
                  IFEND;
                ELSE
                  CYCLE /search_for_job_2/;
                IFEND;

              = ioc$media_error, ioc$unrecovered_error =
                dmp$reallocate_file_space (ijle_p^.swap_data.swap_file_sfid, FALSE, status);
                IF NOT status.normal THEN
                  ijle_p^.swap_data.swapping_io_error := ioc$unrecovered_error_unit_down;
                IFEND;

              = ioc$unrecovered_error_unit_down =
                ijle_p^.swap_data.swap_file_length_in_pages := 0;
                log_message (jsc$mt_reassign_file, ijle_p);
                total_swapped_page_count := ijle_p^.swap_data.swapped_job_page_count +
                      ijle_p^.swap_data.swapped_job_entry.swap_file_descriptor_page_count;
                dmp$reassign_file (ijle_p^.swap_data.swap_file_sfid,
                      (total_swapped_page_count * osv$page_size), status);
                IF NOT status.normal THEN
                  IF status.condition = dme$io_active THEN
                    pmp$delay (1000, local_status);
                  ELSEIF status.condition = dme$unable_to_alloc_all_space THEN
                    file_reassigned := TRUE;
                    ijle_p^.swap_data.swapping_io_error := ioc$allocate_file_space;
                  ELSE
                    EXIT /fix_swap_file/;
                  IFEND;
                ELSE
                  dmp$set_eoi (ijle_p^.swap_data.swap_file_sfid,
                      (total_swapped_page_count * osv$page_size), status);
                  ijle_p^.swap_data.swap_file_length_in_pages := total_swapped_page_count;
                IFEND;

              ELSE
                CYCLE /search_for_job_2/;
              CASEND;
            ELSE
              CYCLE /search_for_job_2/;
            CASEND;
          UNTIL status.normal OR (fix_swap_file_pass = 10);

          IF NOT status.normal THEN
            log_message (jsc$mt_report_status, ijle_p);
            status.normal := TRUE;
          ELSE
            issue_monitor_request (ijl_ordinal, jsc$jss_advance_swap, status);
          IFEND;

        FOREND /search_for_job_2/;
      IFEND;
    FOREND /search_for_job_1/;

  PROCEND jsp$help_monitor_mode_swapper;

?? TITLE := '[XDCL] jsp$special_job_swapout', EJECT ??

{ PURPOSE:
{   This procedure issues the monitor request to process an operator swapout.

  PROCEDURE [XDCL] jsp$special_job_swapout
    (    ijl_ordinal: jmt$ijl_ordinal;
         reason: jmt$swapout_reasons;
     VAR status: ost$status);

    VAR
      request_block: jst$rb_job_swapping_functions;

    request_block.reqcode := syc$rc_job_swapping_functions;
    request_block.ijl_ordinal := ijl_ordinal;
    request_block.subfunction := jsc$jss_special_swapout;
    request_block.swapout_reason := reason;
    request_block.memory_needed := 0;

    i#call_monitor (#LOC (request_block), #SIZE (request_block));

    syp$set_status_from_mtr_status (request_block.status, status);

  PROCEND jsp$special_job_swapout;


?? TITLE := 'JSP$RESET_MAXIMUM_TIME' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] jsp$reset_maximum_time;

    VAR
      i: jmt$ijl_swap_status,
      j: jmt$ijl_swap_status;

    FOR i := LOWERBOUND (jsv$swap_state_statistics) TO UPPERBOUND (jsv$swap_state_statistics) DO
      FOR j := LOWERBOUND (jsv$swap_state_statistics) TO UPPERBOUND (jsv$swap_state_statistics) DO
        jsv$swap_state_statistics [i] [j].maximum_time := 0;
      FOREND;
    FOREND;

  PROCEND jsp$reset_maximum_time;
?? TITLE := 'JSP$SWAP_JOB_IN' ??
?? EJECT ??

  PROCEDURE [XDCL] jsp$swap_job_in
    (    ijl_ordinal: jmt$ijl_ordinal;
     VAR status: ost$status);

*copy jsh$swap_job_in


    issue_monitor_request (ijl_ordinal, jsc$jss_swap_job_in, status);

  PROCEND jsp$swap_job_in;

?? TITLE := '[XDCL] jsp$swap_job_out', EJECT ??

*copy jsh$swap_job_out

  PROCEDURE [XDCL] jsp$swap_job_out
    (    ijl_ordinal: jmt$ijl_ordinal;
         swapout_reason: jmt$swapout_reasons;
         memory_needed: mmt$page_frame_index;
     VAR status: ost$status);

    VAR
      request_block: jst$rb_job_swapping_functions;

    request_block.reqcode := syc$rc_job_swapping_functions;
    request_block.ijl_ordinal := ijl_ordinal;
    request_block.subfunction := jsc$jss_swap_job_out;
    request_block.swapout_reason := swapout_reason;
    request_block.memory_needed := memory_needed;

    i#call_monitor (#LOC (request_block), #SIZE (request_block));

    syp$set_status_from_mtr_status (request_block.status, status);

  PROCEND jsp$swap_job_out;
MODEND jsm$job_swapper;
*DECK DECK=JSM$MONITOR_MODE_JOB_SWAPPER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE js : monitor mode job swapper' ??
MODULE jsm$monitor_mode_job_swapper;

{
{   The purpose of this module is to do the work necessary to swap jobs in and
{ out once it has been informed to do so.  Some work may have to be done in
{ job mode having to do with allocating the swap file.
{
{   The actual swapping of the job is a serial function in a multi cpu system
{ although the requests can be received asynchronously to request a swap or
{ advance a swap.  These asynchronous requests are serialized by noting the
{ event, the actual work is performed when the job swapper (jsp$swap_polling)
{ is called from mtm$monitor_interrupt_handler asynchronous loop.  Procedures
{ that can be entered asynchronously are marked.
{



{  Define compile time variable to control compilation of debug code.

  ?VAR
    debug: boolean := FALSE?;

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc syc$test_jr_constants
*copyc mmc$debug_constants
*copyc jst$swap_file_page_count
*copyc dmt$error_condition_codes
*copyc dmt$file_allocation_status
*copyc gft$file_desc_entry_p
*copyc gft$locked_file_desc_entry_p
*copyc gft$page_status
*copyc gft$system_file_identifier
*copyc jmt$job_control_block
*copyc iot$io_error
*copyc ioe$st_errors
*copyc jmc$null_ajl_ordinal
*copyc jmc$special_dispatch_priorities
*copyc jme$job_scheduler_conditions
*copyc jmt$job_scheduler_event
*copyc jmt$long_wait_swap_threshold
*copyc jse$condition_codes
*copyc jsk$keypoints
*copyc jst$ijl_swap_queue_list
*copyc jst$ijl_lock
*copyc jst$rb_job_swapping_functions
*copyc jst$swapping_event
*copyc jst$swap_state_statistics
*copyc jst$swap_file_statistics
*copyc mmt$active_segment_table
*copyc mmt$buffer_descriptor
*copyc mmt$make_pt_entry_status
*copyc mmt$page_frame_index
*copyc mmt$page_queue_list
*copyc mmt$page_frame_queue_id
*copyc mmt$write_page_to_disk_status
*copyc mtc$job_fixed_segment
*copyc osd$virtual_address
*copyc ost$global_task_id
*copyc ost$heap
*copyc osk$keypoint_class_codes
*copyc ptk$performance_keypoints
*copyc mme$condition_codes
*copyc ost$hardware_subranges
*copyc osc$processor_defined_registers
*copyc ost$page_table
*copyc sft$file_space_limit_kind
*copyc tme$monitor_mode_exceptions
*copyc tmt$ptl_lock
*copyc tmt$task_status
*copyc syv$perf_keypoints_enabled
*copyc mmt$io_identifier
?? POP ??


{  External procedures referenced by this module.

*copyc dfp$fetch_page_status
*copyc dfp$set_task_segment_state
*copyc dfv$file_server_debug_enabled
*copyc dmp$allocate_file_space
*copyc dmp$set_fau_state
*copyc dmp$recover_job_dm_tables
*copyc dpp$display_error
*copyc gfp$mtr_get_fde_p
*copyc gfp$mtr_get_locked_fde_p
*copyc i#build_adaptable_array_ptr
*copyc i$real_memory_address
*copyc iop$ensure_tape_io_complete
*copyc iop$pager_io
*copyc jmp$activate_job_mode_swapper
*copyc jmp$assign_ajl_entry
*copyc jmp$assign_ajl_with_lock
*copyc jmp$change_ijl_entry_status
*copyc jmp$check_scheduler_memory_wait
*copyc jmp$decrement_swapped_job_count
*copyc jmp$free_ajl_entry
*copyc jmp$free_ajl_with_lock
*copyc jmp$get_ijle_p
*copyc jmp$increment_swapped_job_count
*copyc jmp$recognize_job_dead
*copyc jmp$reset_job_to_swapped_out
*copyc jmp$set_entry_status_to_rt
*copyc jmp$set_scheduler_event
*copyc jsp$set_relink_lock
*copyc jsp$clear_relink_lock
*copyc mmp$asid
*copyc mmp$claim_pages_for_swapin
*copyc mmp$dump_shared_queue
*copyc mmp$free_memory_in_job_queues
*copyc mmp$replenish_free_queues
*copyc mmp$get_verify_asti_in_fde
*copyc mmp$sva_purge_all_page_map
*copyc mmp$remove_swapped_shared_pages
*copyc mmp$age_job_working_set
*copyc mmp$remove_stale_pages
*copyc mmp$assign_asid
*copyc mmp$assign_specific_asid
*copyc mmp$assign_page_to_monitor
*copyc mmp$asti
*copyc mmp$conditional_purge_all_map
*copyc mmp$delete_page_from_monitor
*copyc mmp$free_asid
*copyc mmp$delete_pt_entry
*copyc mmp$get_max_sdt_sdtx_pointer
*copyc mmp$make_pt_entry
*copyc mmp$nudge_periodic_call
*copyc mmp$process_page_table_full
*copyc mmp$purge_all_map_proc
*copyc mmp$relink_page_frame
*copyc mmp$trim_job_working_set
*copyc mmp$write_page_to_disk
*copyc mtp$cst_p
*copyc mtp$error_stop
*copyc mtp$set_status_abnormal
*copyc tmp$clear_lock
*copyc tmp$find_next_xcb
*copyc tmp$idle_tasks_in_job
*copyc tmp$monitor_flag_job_tasks
*copyc tmp$restart_idled_tasks
*copyc tmp$set_lock
*copyc tmp$set_monitor_flag
*copyc tmp$set_up_debug_registers
*copyc tmp$update_job_task_environment

{  Global variables referenced by this module.

*copyc dmv$active_volume_table
*copyc jmv$ajl_p
*copyc jmv$ijl_entry_status_statistics
*copyc jmv$ijl_p
*copyc jmv$long_wait_swap_threshold
*copyc jmv$null_ijl_ordinal
*copyc jmv$service_classes
*copyc jmv$service_class_stats_lock
*copyc jmv$system_ajl_ordinal
*copyc jmv$system_ijl_ordinal
*copyc jmv$system_job_ssn
*copyc jsv$time_to_call_job_swapper
*copyc mmv$aggressive_aging_level
*copyc mmv$aging_algorithm
*copyc mmv$ast_p
*copyc mmv$gpql
*copyc mmv$initial_job_fixed_ast_entry
*copyc mmv$max_working_set_size
*copyc mmv$max_template_segment_number
*copyc mmv$min_avail_pages
*copyc mmv$multiple_page_maps
*copyc mmv$pft_p
*copyc mmv$reserved_page_count
*copyc mmv$last_active_shared_queue
*copyc mmv$swapping_aic
*copyc mmv$time_changed_global_asid
*copyc mmv$time_changed_template_asid
*copyc mmv$pt_p
*copyc mmv$reassignable_page_frames
*copyc mtv$dual_state_cpu_number
*copyc mtv$monitor_segment_table
*copyc mtv$scb
*copyc mtv$system_job_monitor_xcb_p
*copyc osv$170_os_type
*copyc osv$page_size
*copyc osv$time_to_check_asyn
*copyc tmv$dedicate_a_cpu_to_nos
*copyc tmv$ptl_lock
*copyc tmv$swapin_in_progress
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

{  Global constants defined by this module.

?? FMT (FORMAT := OFF) ??

  CONST
    reassigned_asid_list_length = 20,

{  Define trace indexes for swap trace buffer.  JSC$TI_UNUSED_XX identifies free indexes.

    jsc$ti_min_index = 0,
    jsc$ti_no_memory_for_swap_in = 1,
    jsc$ti_new_job_fixed_asid = 2,
    jsc$ti_reuse_job_fixed_asid = 3,
    jsc$ti_reuse_job_fixed_asid_as = 4,    { Reassign old ASID to job fixed.}
    jsc$ti_no_pages_for_sfd_on_si = 5,
    jsc$ti_sfd_freed = 6,
    jsc$ti_free_memory_si_aborted = 7,
    jsc$ti_free_memory = 8,
    jsc$ti_no_mem_from_claim_pages = 9,
    jsc$ti_pager_io_error = 10,
    jsc$ti_move_am_back_to_am = 11,
    jsc$ti_move_am_back_to_am_pc = 12,     { Page count of pages moved back to available modified.}
    jsc$ti_flush_am_pc = 13,               { Page count of pages in am that were flushed.}
    jsc$ti_flush_am_relink = 14,           { Move am back to jws--write to disk reject.}
    jsc$ti_flush_am_ready = 15,            { Task ready after flush.}
    jsc$ti_swapping_queue_and_exec = 16,   { Swap status of executing and swap direction of in.}
    jsc$ti_allocate_swap_file = 17,        { Call DM to allocate swap file in monitor mode.}
    jsc$ti_allocate_swap_file_jm = 18,     { Allocate swap file in job mode.}
    jsc$ti_dm_transient_error = 19,        { Device management transient error.}
    jsc$ti_change_asid_again = 20,
    jsc$ti_change_asid = 21,
    jsc$ti_change_asid_sfd = 22,           { Update changed ASID's in swap file descriptor.}

{  Trace indexes for events during reset to memory manager tables.

    jsc$ti_rmmt_no_change = 24,            { No change in ASID.}
    jsc$ti_rmmt_pf = 25,                   { ASID change of page belonging to a permanent file.}
    jsc$ti_rmmt_pf_rec_ptm = 26,           { Assign new ASID on job recovery and modified.}
    jsc$ti_rmmt_pf_rec_ptu = 27,           { Job recovery, relink unmodified page into free queue.}
    jsc$ti_rmmt_pf_assign_asid = 28,       { Not job recovery, assign new ASID.}
    jsc$ti_rmmt_pf_reuse_asid = 29,        { Not job recovery, reuse ASID.}
    jsc$ti_rmmt_lf_assign_asid = 30,       { Assign ASID for page assigned to local file.}
    jsc$ti_rmmt_lf_reuse_asid = 31,        { Reuse ASID for page assigned to local file.}
    jsc$ti_rmmt_pt_done = 32,
    jsc$ti_rmmt_pt_full = 33,
    jsc$ti_rmmt_pt_full_failed = 34,
    jsc$ti_rmmt_pt_full_succ = 35,         { Succeeded in recovering from page table full.}
    jsc$ti_rmmt_pte_exists_pf = 36,        { Permanent file page is now in shared queue.}
    jsc$ti_rmmt_pte_exists_am = 37,        { Local file page is still in Avail modeified queue.}
    jsc$ti_rmmt_pte_exists_a = 38,         { Local file page found in Avail queue.}
    jsc$ti_rmmt_pte_exists_err = 39,       { Local file page found in Swapped error queue.}

{  Trace buffer indexes for reset xcb and sdt tables.

    jsc$ti_rxcb_temp_asids_changed = 40,
    jsc$ti_rxcb_job_asids_changed = 41,
    jsc$ti_rxcb_glob_asids_changed = 42,
    jsc$ti_rxcb_fix_xcb_sdt = 43,
    jsc$ti_rxcb_fix_asids = 44,
    jsc$ti_rxcb_fix_templ_asid = 45,
    jsc$ti_pt_full_reassign_jf = 46,
    jsc$ti_rxcb_fix_jf_asid = 47,
    jsc$ti_rxcb_fix_job_asid = 48,
    jsc$ti_rxcb_zero_job_asid = 49,
    jsc$ti_rxcb_recovery = 53,
    jsc$ti_rxcb_zero_asid = 54,            { Reset tables zeroed out an ASID in a segment table.}

    jsc$ti_lwa = 55,                       { Long wait aging called}
    jsc$ti_lwa_cp_age = 56,                { called cp aging}
    jsc$ti_lwa_stale_pages_rem = 57,       { total number of pages removed}
    jsc$ti_lwa_stale_mod_pages_rem = 58,   { number modified pages removed}
    jsc$ti_lwa_ready_task = 59,            { long wait aging caused task to go ready.}

    jsc$ti_swapin_io_error = 60,
    jsc$ti_swapout_io_error = 61,
    jsc$ti_sif_idle_tasks_init = 63,       { Swap in from idle tasks initiated.}
    jsc$ti_sif_wait_state = 64,            { Swap in from a wait state.}
    jsc$ti_sif_swapout_io_init = 65,       { Swap in from swap out io initiated or completed.}
    jsc$ti_swapout_int_by_swapin = 67,     { Swap in requested on job being swapped out.}
    jsc$ti_swapin_int_by_swapout = 68,     { Swap out requested on job being swapped in.}
    jsc$ti_no_ajl_ord_for_swap_in = 69,    { Swap in aborted, could not assign AJL ordinal.}
    jsc$ti_swapout_from_job_mode = 76,     { Swapout request from job mode}
    jsc$ti_swapout_from_mtr_mode = 77,     { Swapout from monitor mode.}
    jsc$ti_swapin_from_job_mode = 78,      { Swapin from job mode.}
    jsc$ti_swapin_from_mtr_mode = 79,      { Swapin from monitor mode.}
    jsc$ti_swapin_mtr_direct = 80,         { Swapin from monitor mode - S0 to R.}
    jsc$ti_swapin_req_status_bad = 81,     { Swapin from job mode--advance_swap got bad status.}
    jsc$ti_cd_idle_task_complete = 82,     { Change direction to in detected in idld task complete.}
    jsc$ti_sif_idled_tasks_comp = 83,      { Swap in from idle tasks complete.}
    jsc$ti_cd_idle_task_complete_2 = 86,   { Change direction to IN in idle task complete--2nd check.}
    jsc$ti_reserve_memory_failed = 87,     { Memory no longer available for reserve request on swapin.}
    jsc$ti_cd_to_in_at_s2 = 88,            { Changed direction to in at swapped_io_complete.}
    jsc$ti_cd_to_in_at_s = 89,             { Changed direction to in at swapout_complete.}
    jsc$ti_init_swapin_io_error = 90,      { IO error discovered upon swapin io complete.}
    jsc$ti_init_swapout_io_error = 91,     { IO error discovered upon swapout io complete.}
    jsc$ti_swapout_disk_down = 93,         { Disk down discovered upon swapout io complete.}
    jsc$ti_swapin_disk_down = 94,          { Disk down discovered upn swapin io compelete.}
    jsc$ti_zero_out_pages_for_sfd_1 = 95,  { Abort swapout at wait alloc sfd--swapin req--0 out pages needed.}
    jsc$ti_zero_out_pages_for_sfd_2 = 96,  { Adv swapout from wait alloc sfd--polling--0 out pages needed.}
    jsc$ti_no_ajlo_swapin_before_io = 97,  { No ajlo available in swapin_before_io. }
    jsc$ti_dump_shared_q_for_sfd = 98,     { Dump the shared queue to get pages for an SFD.}
    jsc$ti_dump_shared_queue = 99,         { Dump the shared queue to claim enough pages to swap a job in.}
    jsc$ti_free_readied_s2_job = 100,      { Free an S2 job that has been readied in order to use its memory.}
    jsc$ti_no_ajlo_swapin_after_io = 101,  { No ajlo available in swapin_after_io. }
    jsc$ti_advance_from_cannot_init = 103, { Advance swap state from io_cannot_init to io_not_init. }
    jsc$ti_page_q_counts_different = 104,  { Page q counts different at job_io_complete. }
    jsc$ti_mtr_req_adv_from_aj = 105,      { Mtr request to advance from job_allocate_swap_file. }
    jsc$ti_mtr_req_adv_from_sd = 106,      { Mtr request to advance from swapped_io_cannot_init. }
    jsc$ti_recalculate_sje = 107,          { Recalculate the sje after removing a job shared page. }
    jsc$ti_recal_sje_s0 = 108,             { Recalculate the sje -- S0 state. }
    jsc$ti_recal_sje_s2 = 109,             { Recalculate the sje -- S2 state. }

    jsc$ti_riop_relinked = 110,            { Pages relinked into JWS from swapped error queue.}
    jsc$ti_riop_mem_freed = 111,           { IO error page belonging to a job that had freed memory.}
    jsc$ti_riop_m_bit_reset = 112,         { Pages that needed to have M bit set.}
    jsc$ti_riop_init = 113,                { IO error occurred on an initial write.}

    jsc$ti_no_ajlo_mtr_swapin = 114,
    jsc$ti_no_s2_job_found = 115,          { Mmv$reassignable_page_frames.now has gone bad.}
    jsc$ti_now_count_reset = 116,

    jsc$ti_job_aged_before_swap = 117,     { Age before swap tried.
    jsc$ti_age_before_swap_pages = 118,    { Number of pages freed by aging.
    jsc$ti_age_before_swap_okay = 119,     { Aging freed enough pages.  Do not continue swapout.

    jsc$ti_max_index = 150;

?? FMT (FORMAT := ON) ??

{  Global variables defined by this module.

  VAR
    osv$debug: [XREF] array [0 .. 15] of integer,
    jsv$age_jws_before_swap: [XDCL, #GATE] boolean := FALSE,
    jsv$age_before_swap_percentage: [XDCL, #GATE] integer := 0,
    jsv$swap_trace: [XDCL] array [jsc$ti_min_index .. jsc$ti_max_index] of integer,

{  Define variable used to serialize job swapper access to the IJL when necessary.  Check calls
{  to tmp$set_lock and tmp$clear_lock for these cases.

    jsv$ijl_serial_lock: [XDCL] tmt$ptl_lock := [FALSE, 0],
    jsv$ijl_relink_lock: [XDCL, #GATE] jst$ijl_lock := [FALSE,[0,0]],
    jsv$write_stale_pages: [XDCL, #GATE] boolean := FALSE,
    jsv$swap_file_page_count: [XDCL, #GATE] jst$swap_file_page_count,
    jsv$ijl_swap_queue_list: [XDCL, #GATE] jst$ijl_swap_queue_list :=
          [[[0, 0], [0, 0], 0], [[0, 0], [0, 0], 0], [[0, 0], [0, 0], 0], [[0, 0], [0, 0], 0], [[0, 0],
          [0, 0], 0], [[0, 0], [0, 0], 0]],
    jsv$enable_swap_file_statistics: [XDCL, #GATE] boolean := FALSE,
    jsv$enable_swap_resident: [XDCL, #GATE] boolean := TRUE,
    jsv$enable_swap_resident_no_io: [XDCL, #GATE] boolean := TRUE,
    jsv$enable_debug_code: [XDCL, #GATE] boolean := FALSE,
    jsv$halt_on_swapin_failure: [XDCL, #GATE] boolean := FALSE,
    jsv$free_working_set_on_swapout: [XDCL, #GATE] boolean := FALSE,
    jsv$max_pages_first_swap_task: [XDCL, #GATE] integer := 65536,
    jsv$max_time_swap_io_complete: [XDCL, #GATE] integer := 200000000,
    jsv$max_time_swap_io_not_init: [XDCL, #GATE] integer := 100000000,
    jsv$maximum_pages_to_swap: [XDCL, #GATE] integer := 65536,
    jsv$pages_needed_for_sfd: [XDCL] integer := 0,
    jsv$swap_state_statistics: [XDCL, #GATE] jst$swap_state_statistics,
    jsv$swap_file_statistics: [XDCL, #GATE] jst$swap_file_statistics :=
          [[0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
          0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], 0],
    jsv$swapped_page_entry_size: [XDCL, #GATE] 0 .. 0ff(16) := 82, {deadstart init resets exactly}
    jsv$think_expiration_time: [XDCL, #GATE] integer := 15000000,
    syv$allow_jr_test: [XDCL, #GATE] boolean := FALSE,
    syv$test_jr_system: [XDCL, #GATE] syt$test_jr_set := $syt$test_jr_set [];

 VAR
  null_sva: 0 .. 0ffffffffffff(16);

{
{  Global type definitions defined by this module.
{

  TYPE
    cybil_pointer_trick = record
      case pointer_type: 0 .. 1 of
      = 0 =
        sfd_p: ^jst$swap_file_descriptor,
      = 1 =
        pva: ost$pva,
      casend,
    recend;

  VAR
    kt: packed record
      case boolean of
      = TRUE =
        s: string (5),
      = FALSE =
        f1: 0 .. 0fffff(16),
        f2: 0 .. 0fff(16),
      casend,
    recend;


  PROCEDURE [INLINE] trace
    (    trace_index: jsc$ti_min_index .. jsc$ti_max_index;
         j: integer);

    jsv$swap_trace [trace_index] := jsv$swap_trace [trace_index] + j;
  PROCEND trace;


  TYPE
    jst$relink_swap_q_trace = record
      index: 0 .. 65535,
      info: array [0 .. 63] of record
        rt_ijl: jmt$ijl_ordinal,
        rt_new_queue: jst$ijl_swap_queue_id,
        rt_old_swap_q_link: jst$ijl_swap_queue_link,
        rt_new_swap_q_link: jst$ijl_swap_queue_link,
        rt_current_q_list: jst$ijl_swap_queue_list_entry,
        rt_new_q_list: jst$ijl_swap_queue_list_entry,
      recend,
    recend;

  VAR
    jsv$relink_swap_q_trace: [XDCL] jst$relink_swap_q_trace;

?? TITLE := 'ADVANCE_SWAP', EJECT ??

  PROCEDURE advance_swap
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry;
     VAR set_polling_event: boolean;
     VAR status: syt$monitor_status);

{
{     The purpose of this procedure is to advance the swap as far as it can go without
{  waiting.  The swap is advanced until abnormal status is returned or a wait to complete
{  condition is encountered.  If next_swap_status <> jmc$iss_null then that is moved
{  to swap_status and another cycle is taken through the advance swap, current swap status
{  is processed first however.  NEXT_SWAP_STATUS is used to indicate that a swap wait state
{  has completed and advancing the swap should continue.  NEXT_SWAP_STATUS is set in the
{  procedures that can be entered asynchronously in this module.
{
{  NOTE:
{     Abnormal status is returned only for those conditions that abort the swap.
{
{     Mmv$reassignable_page_frames must be maintained.  Swapped_io_not_initiated and
{     swapped_io_cannot_initiate contains the job queues page count.  Soon includes the
{     job queues plus the SFD page count.
{

    VAR
      change_swap_direction: boolean,
      initiate_swapout_io: boolean,
      job_page_count: mmt$page_frame_index,
      last_swap_status: jmt$ijl_swap_status,
      pages_removed: mmt$page_frame_index,
      queue_id: mmt$job_page_queue_index,
      total_swapped_page_count: 0 .. osc$max_page_frames;


    IF ijle_p^.swap_queue_link.queue_id <> jsc$isqi_swapping THEN
      mtp$error_stop ('JS - advance_swap called for job not in swapping queue.');
    IFEND;

    status.normal := TRUE;
    set_polling_event := FALSE;
    last_swap_status := ijle_p^.swap_status;

    WHILE status.normal DO
      CASE ijle_p^.swap_status OF

      = jmc$iss_executing = {  R }

        IF ijle_p^.entry_status > jmc$ies_swapped_in THEN
          mtp$error_stop ('JS -- bad swap status - swapout executing job');
        ELSE

{  Cover the case where may go through the advance swap loop one time after job has been swapped in.

          trace (jsc$ti_swapping_queue_and_exec, 1);
          RETURN;
        IFEND;

      = jmc$iss_job_idle_tasks_complete = { TJ }

        IF ijle_p^.entry_status < jmc$ies_swapped_out THEN
          trace (jsc$ti_sif_idled_tasks_comp, 1);
          ijle_p^.next_swap_status := jmc$iss_null;
          restart_idled_tasks (ijl_ordinal, ijle_p);
          RETURN;
        ELSE
          jmp$free_ajl_entry (ijle_p, jmc$swapping_ajl);
          calculate_swapped_pages (ijle_p);
          jsv$swap_file_page_count.swap_count := jsv$swap_file_page_count.swap_count + 1;
          jsv$swap_file_page_count.page_count := jsv$swap_file_page_count.page_count +
                ijle_p^.swap_data.swapped_job_page_count;

{ Assumption:  This is a job mode swapout, not a long wait swapout.  Therefore, swap the job to disk if
{ memory is needed for swapin candidates of any priority.

          initiate_swapout_io := ((mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon) <=
                jmv$long_wait_swap_threshold [jmc$lowest_dispatching_priority]) OR
                NOT jsv$enable_swap_resident_no_io;

          IF ijle_p^.entry_status < jmc$ies_swapped_out THEN
            trace (jsc$ti_cd_idle_task_complete, 1);
            swapin_before_io (ijl_ordinal, ijle_p);
            RETURN;
          ELSEIF NOT initiate_swapout_io THEN
            jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapped_io_not_init);
            advance_swap_state (ijle_p, jmc$iss_swapped_no_io);

{ Recheck swap direction.  There is a timing problem here; direction can change just after it is checked
{ above, and the job sits in the S0 queue for two minutes before advancing.

            IF ijle_p^.entry_status < jmc$ies_swapped_out THEN
              jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapping);
              trace (jsc$ti_cd_idle_task_complete_2, 1);
            ELSE
              RETURN;
            IFEND;

          ELSE
            advance_swap_state (ijle_p, jmc$iss_flush_am_pages);
          IFEND;
        IFEND;

      = jmc$iss_swapped_no_io = { S0 }

        IF ijle_p^.entry_status < jmc$ies_swapped_out THEN
          swapin_before_io (ijl_ordinal, ijle_p);
          RETURN;

        ELSE
          jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapping);
          advance_swap_state (ijle_p, jmc$iss_flush_am_pages);
        IFEND;

      = jmc$iss_flush_am_pages = { FA }

        flush_am_pages_to_disk (ijl_ordinal, ijle_p);
        calculate_sfd_length (ijle_p);
        advance_swap_state (ijle_p, jmc$iss_allocate_swap_file);

      = jmc$iss_allocate_swap_file = { AF }

        IF ijle_p^.swap_data.swapping_io_error <= ioc$allocate_file_space THEN
          allocate_swap_file (ijle_p, status);
          IF NOT status.normal THEN
            IF status.condition = dme$transient_error THEN
              advance_swap_state (ijle_p, jmc$iss_wait_allocate_swap_file);
              set_polling_event := TRUE;
            ELSE
              ijle_p^.swap_data.swapping_io_error := ioc$allocate_file_space;
              advance_swap_state (ijle_p, jmc$iss_job_allocate_swap_file);
              jmp$activate_job_mode_swapper;
            IFEND;
            status.normal := TRUE;
            RETURN;
          ELSE
            mmv$reassignable_page_frames.swapout_io_not_initiated :=
                  mmv$reassignable_page_frames.swapout_io_not_initiated -
                  ijle_p^.swap_data.swapped_job_page_count + ijle_p^.job_fixed_contiguous_pages;
            mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon +
                  ijle_p^.swap_data.swapped_job_page_count - ijle_p^.job_fixed_contiguous_pages;

            ijle_p^.notify_swapper_when_io_complete := TRUE;
            IF ijle_p^.inhibit_swap_count <> 0 THEN

{ Check if any cartridge tape writes are active and if so, call iop$ensure_tape_io_complete.
{ The active_cart_tape_write in the ijl entry is incremented/decremented in iom$tape_queue_manager_mtr
{ when pages are being locked/unlocked for cartridge tape writes.

              IF ijle_p^.active_cart_tape_write > 0 THEN  { Ensure controller buffer will flush
                iop$ensure_tape_io_complete (ijle_p^.system_supplied_name);
              IFEND;
              advance_swap_state (ijle_p, jmc$iss_wait_job_io_complete);
              RETURN;
            ELSE
              ijle_p^.notify_swapper_when_io_complete := FALSE;
              advance_swap_state (ijle_p, jmc$iss_job_io_complete);
            IFEND;
          IFEND;
        ELSE

{ The swap file encountered an error on a previous swapout.  Call job mode swapper to try to
{ reassign or reallocate the swap file.

          advance_swap_state (ijle_p, jmc$iss_job_allocate_swap_file);
          jmp$activate_job_mode_swapper;
          RETURN;
        IFEND;

      = jmc$iss_job_io_complete = { JC }

{ Verify that page queue counts are the same; if io completed abnormally the page queue counts
{ may be differrent.  The swap file descriptor needs to be re-allocated. Swapout_io_not_initiated
{ and soon needs to be updated.

        IF (ijle_p^.swap_data.swapped_job_entry.job_page_queue_count [mmc$pq_job_io_error] <>
              ijle_p^.job_page_queue_list [mmc$pq_job_io_error].count) OR
              (ijle_p^.swap_data.swapped_job_entry.job_page_queue_count [mmc$pq_job_working_set] <>
              ijle_p^.job_page_queue_list [mmc$pq_job_working_set].count) THEN

          trace (jsc$ti_page_q_counts_different, 1);
          mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon -
                ijle_p^.swap_data.swapped_job_page_count + ijle_p^.job_fixed_contiguous_pages;
          calculate_swapped_pages (ijle_p);
          calculate_sfd_length (ijle_p);
          advance_swap_state (ijle_p, jmc$iss_allocate_swap_file);
        ELSE
          advance_swap_state (ijle_p, jmc$iss_allocate_sfd);
        IFEND;

      = jmc$iss_allocate_sfd = { AD }

        assign_pages_for_sfd (ijle_p, ijl_ordinal, jsc$sd_out, status);
        IF NOT status.normal AND (status.condition = mme$no_free_pages) THEN

{ Try freeing enough pages from the shared queue for the sfd and try to allocate the sfd again.  If there
{ still are not enough free pages then cause mmp$periodic_call to be called to do some aging.

          status.normal := TRUE;
          trace (jsc$ti_dump_shared_q_for_sfd, 1);
          mmp$dump_shared_queue (ijle_p^.swap_data.swapped_job_entry.swap_file_descriptor_page_count);
          assign_pages_for_sfd (ijle_p, ijl_ordinal, jsc$sd_out, status);
          IF NOT status.normal THEN
            status.normal := TRUE;
            jsv$pages_needed_for_sfd := jsv$pages_needed_for_sfd +
                  ijle_p^.swap_data.swapped_job_entry.swap_file_descriptor_page_count;
            mmp$nudge_periodic_call;
            advance_swap_state (ijle_p, jmc$iss_wait_allocate_sfd);
            set_polling_event := TRUE;
            RETURN;
          IFEND;
        ELSEIF NOT status.normal THEN
          status.normal := TRUE;
          advance_swap_state (ijle_p, jmc$iss_wait_allocate_sfd);
          set_polling_event := TRUE;
          RETURN;
        IFEND;

{ When the job was last swapped in and the old swap file descriptor freed, the IJL.PURGE_MAP_TIMESTAMP
{ was set equal to the value of the free running clock. The page map must be purged if it has not been
{ purged since that time. If the map is NOT purged, references to the SFD may use the OLD page frames
{ that were assigned at the PREVIOUS swapin. Purging of the map has been delayed since it will usually
{ NOT be required at this point since something else will have purged the map.

        mmp$conditional_purge_all_map (ijle_p^.sfd_purge_timestamp);

{ XCB access will be inhibited from now on.  Set the timestamp now for reassigning ASIDs.

        ijle_p^.swap_data.asid_reassigned_timestamp := #FREE_RUNNING_CLOCK (0);
        advance_swap_state (ijle_p, jmc$iss_initiate_swapout_io);

      = jmc$iss_swapped_io_cannot_init = { SD }

        mmv$reassignable_page_frames.swapout_io_cannot_initiate :=
              mmv$reassignable_page_frames.swapout_io_cannot_initiate -
              ijle_p^.swap_data.swapped_job_page_count + ijle_p^.job_fixed_contiguous_pages;
        IF ijle_p^.entry_status < jmc$ies_swapped_out THEN
          swapin_after_io (ijl_ordinal, ijle_p);
          RETURN;
        ELSE
          mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon +
                ijle_p^.swap_data.swapped_job_page_count - ijle_p^.job_fixed_contiguous_pages;
          advance_swap_state (ijle_p, jmc$iss_allocate_sfd);
        IFEND;
        trace (jsc$ti_advance_from_cannot_init, 1);

      = jmc$iss_initiate_swapout_io = { OS }

        total_swapped_page_count := ijle_p^.swap_data.swapped_job_page_count +
              ijle_p^.swap_data.swapped_job_entry.swap_file_descriptor_page_count;
        job_swapping_io (ijl_ordinal, ijle_p, ijle_p^.swap_data.swap_file_sfid, ioc$swap_out,
              total_swapped_page_count, ijle_p^.swap_io_control, status);

        IF NOT status.normal THEN
          IF status.condition = ioe$unit_disabled THEN
            trace (jsc$ti_init_swapout_io_error, 1);
            ijle_p^.swap_data.swapping_io_error := ioc$unrecovered_error_unit_down;
            process_io_error_on_swapout (ijl_ordinal, ijle_p, set_polling_event);

          ELSE
            set_polling_event := TRUE;
            advance_swap_state (ijle_p, jmc$iss_wait_swapout_io_init);
          IFEND;

          status.normal := TRUE;
          RETURN;
        ELSE
          advance_swap_state (ijle_p, jmc$iss_swapout_io_initiated);
        IFEND;

      = jmc$iss_swapout_io_complete = { OC }

        IF ijle_p^.swap_data.swapping_io_error <> ioc$no_error THEN
          ijle_p^.swap_io_control.spd_index := LOWERVALUE (mmt$page_frame_index);
          IF ijle_p^.swap_data.swapping_io_error = ioc$unrecovered_error_unit_down THEN
            trace (jsc$ti_swapout_disk_down, 1);
            advance_swap_state (ijle_p, jmc$iss_initiate_swapout_io);
          ELSE
            trace (jsc$ti_swapout_io_error, 1);
            process_io_error_on_swapout (ijl_ordinal, ijle_p, set_polling_event);
            RETURN;
          IFEND;

        ELSE
          free_swap_file_descriptor (ijle_p, ijl_ordinal);

          IF (mmv$reassignable_page_frames.now < mmv$min_avail_pages) OR NOT jsv$enable_swap_resident THEN
            last_swap_status := jmc$iss_swapout_io_complete;
            advance_swap_state (ijle_p, jmc$iss_free_swapped_memory);
          ELSE

{  Increment reassignable page frames NOW and decrement SOON.

            mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon -
                  ijle_p^.swap_data.swapped_job_page_count + ijle_p^.job_fixed_contiguous_pages;
            mmv$reassignable_page_frames.now := mmv$reassignable_page_frames.now +
                  ijle_p^.swap_data.swapped_job_page_count - ijle_p^.job_fixed_contiguous_pages;
            advance_swap_state (ijle_p, jmc$iss_swapped_io_complete);
            jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapped_io_completed);

{ Recheck the swap direction.
{ On a dual CPU system, the swap direction may have changed (because a
{ ready task was processed in tmp$switch_task) just as the swap status
{ was advanced to swapped_io_completed.

            IF ijle_p^.entry_status < jmc$ies_swapped_out THEN
              jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapping);
              trace (jsc$ti_cd_to_in_at_s2, 1);
            ELSE
              RETURN;
            IFEND;
          IFEND;
        IFEND;

      = jmc$iss_swapped_io_complete = { S2 }

        IF ijle_p^.entry_status < jmc$ies_swapped_out THEN
          ijle_p^.swap_io_control.spd_index := LOWERVALUE (mmt$page_frame_index);
          mmv$reassignable_page_frames.now := mmv$reassignable_page_frames.now -
                ijle_p^.swap_data.swapped_job_page_count + ijle_p^.job_fixed_contiguous_pages;
          swapin_after_io (ijl_ordinal, ijle_p);
          RETURN;
        ELSE
          last_swap_status := jmc$iss_swapped_io_complete;
          advance_swap_state (ijle_p, jmc$iss_free_swapped_memory);
        IFEND;

      = jmc$iss_free_swapped_memory = { FM }

        free_swapped_jobs_mm_resources (ijle_p, ijl_ordinal, last_swap_status);
        advance_swap_state (ijle_p, jmc$iss_swapout_complete);
        jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapped_out);

{ Do not return yet; need to loop through again to check swap direction.
{ On a dual CPU system, the swap direction may have changed (because a
{ ready task was processed in tmp$switch_task) just as the swap status
{ was advanced to swapout_complete.


      = jmc$iss_swapout_complete = {  S }

        IF ijle_p^.entry_status < jmc$ies_swapped_out THEN

{ Check if the job is in the swapping queue; because of dual CPU timing, the
{ job may have been relinked to the swapped out queue after the job was readied
{ and direction set to IN.

          IF ijle_p^.swap_queue_link.queue_id <> jsc$isqi_swapping THEN
            jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapping);
            trace (jsc$ti_cd_to_in_at_s, 1);
          IFEND;

{ Add up the swapped job page count again.  If job shared pages were removed from the
{ job's working set while the job was in the swapped_io_complete (S2) state, the
{ swapped job page count was changed to reflect the new (lower) working set size.
{ However, all pages that were written out need to be read back in, so the swapped
{ job page count needs to be reset to the total written out.

          job_page_count := 0;
          FOR queue_id := LOWERVALUE (mmt$job_page_queue_index) TO UPPERVALUE (mmt$job_page_queue_index) DO
            job_page_count := job_page_count + ijle_p^.swap_data.swapped_job_entry.
                  job_page_queue_count [queue_id];
          FOREND;
          ijle_p^.swap_data.swapped_job_page_count := job_page_count;
          advance_swap_state (ijle_p, jmc$iss_swapin_requested);
        ELSE
          RETURN;
        IFEND;

      = jmc$iss_swapin_requested = { IR }

        ijle_p^.swap_io_control.spd_index := LOWERVALUE (mmt$page_frame_index);
        claim_pages_for_swap_in (ijl_ordinal, ijle_p, status);

        IF NOT status.normal THEN
          advance_swap_state (ijle_p, jmc$iss_swapout_complete);
          jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapped_out);
          jmp$reset_job_to_swapped_out (ijl_ordinal);
          RETURN;
        ELSE
          advance_swap_state (ijle_p, jmc$iss_swapin_resource_claimed);
        IFEND;


      = jmc$iss_swapin_resource_claimed = { IS }

        total_swapped_page_count := ijle_p^.swap_data.swapped_job_page_count +
              ijle_p^.swap_data.swapped_job_entry.swap_file_descriptor_page_count;
        job_swapping_io (ijl_ordinal, ijle_p, ijle_p^.swap_data.swap_file_sfid, ioc$swap_in,
              total_swapped_page_count, ijle_p^.swap_io_control, status);
        IF NOT status.normal THEN
          IF status.condition = ioe$unit_disabled THEN
            trace (jsc$ti_init_swapin_io_error, 1);
            process_io_error_on_swapin (ijl_ordinal, ijle_p);
            RETURN;

          ELSE
            advance_swap_state (ijle_p, jmc$iss_wait_swapin_io_init);
            set_polling_event := TRUE;
            status.normal := TRUE;
          IFEND;
        ELSE
          tmv$swapin_in_progress := tmv$swapin_in_progress + 1;
          advance_swap_state (ijle_p, jmc$iss_swapin_io_initiated);
        IFEND;

        RETURN;

      = jmc$iss_swapin_io_complete = { IC }

        tmv$swapin_in_progress := tmv$swapin_in_progress - 1;
        IF ijle_p^.swap_data.swapping_io_error <> ioc$no_error THEN
          IF ijle_p^.swap_data.swapping_io_error = ioc$unrecovered_error_unit_down THEN
            trace (jsc$ti_swapin_disk_down, 1);
            advance_swap_state (ijle_p, jmc$iss_swapin_resource_claimed);
            ijle_p^.swap_io_control.spd_index := LOWERVALUE (mmt$page_frame_index);
          ELSE
            trace (jsc$ti_swapin_io_error, 1);
            process_io_error_on_swapin (ijl_ordinal, ijle_p);
            RETURN;
          IFEND;

        ELSEIF ijle_p^.entry_status > jmc$ies_swapped_in THEN

{  Abort the swapin, received request to swap job out again.

          trace (jsc$ti_swapin_int_by_swapout, 1);
          free_swapped_jobs_mm_resources (ijle_p, ijl_ordinal, jmc$iss_swapin_io_complete);
          ?IF debug = TRUE THEN
            IF syv$allow_jr_test THEN
              IF syc$tjr_mtr_fsjmmr IN syv$test_jr_system THEN
                mtp$error_stop ('JOB RECOVERY TEST');
              IFEND;
            IFEND;
          ?IFEND
          advance_swap_state (ijle_p, jmc$iss_swapout_complete);
          jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapped_out);
          jmp$free_ajl_entry (ijle_p, jmc$swapping_ajl);
          RETURN;
        ELSE

{  Restore memory manager tables for job image read from mass storage, update ASID's in job's
{  segment tables and the system file table.  Swap status is advanced to executing if successful.

          reset_swapped_job_mm_tables (ijl_ordinal, ijle_p, ijle_p^.swap_data.swapped_job_entry,
                ijle_p^.sfd_p, status);
          IF NOT status.normal THEN
            IF status.condition = jse$pt_full_on_swap_in THEN
              advance_swap_state (ijle_p, jmc$iss_swapout_complete);
              jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapped_out);
              jmp$reset_job_to_swapped_out (ijl_ordinal);
              jmp$free_ajl_entry (ijle_p, jmc$swapping_ajl);
            ELSEIF status.condition = jse$bad_swap_file_data_detected THEN
              jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapped_out);
              free_swapped_jobs_mm_resources (ijle_p, ijl_ordinal, jmc$iss_swapin_io_complete);
              advance_swap_state (ijle_p, jmc$iss_swapout_complete);
              jmp$recognize_job_dead (ijl_ordinal);
              jmp$free_ajl_entry (ijle_p, jmc$swapping_ajl);
            ELSE
              mtp$error_stop ('JS - unexpected status on reset MM tables');
            IFEND;
          IFEND;

          RETURN;
        IFEND;

      ELSE

{  Process the unselected case, check if change in swap direction or if next swap status is set.

        last_swap_status := ijle_p^.swap_status;
        change_swap_direction := ((last_swap_status <= UPPERVALUE (jmt$swapout)) AND
              (last_swap_status >= LOWERVALUE (jmt$swapout)) AND
              (ijle_p^.entry_status < jmc$ies_swapped_out)) OR
              ((last_swap_status <= UPPERVALUE (jmt$swapin)) AND
              (last_swap_status >= LOWERVALUE (jmt$swapin)) AND (ijle_p^.entry_status > jmc$ies_swapped_in));
        IF change_swap_direction THEN
          IF ijle_p^.entry_status < jmc$ies_swapped_out THEN
            trace (jsc$ti_swapout_int_by_swapin, 1);
            direction_changed_to_in (ijl_ordinal, ijle_p);
            RETURN;
          ELSE {direction is out}
            IF ijle_p^.next_swap_status = jmc$iss_swapin_io_complete THEN
              advance_swap_state (ijle_p, ijle_p^.next_swap_status);
              ijle_p^.next_swap_status := jmc$iss_null;
            ELSE
              mtp$error_stop ('JS--bad swap status-swapin changed direction');
            IFEND;
          IFEND;
        ELSEIF (ijle_p^.next_swap_status <> jmc$iss_null) THEN
          advance_swap_state (ijle_p, ijle_p^.next_swap_status);
          ijle_p^.next_swap_status := jmc$iss_null;
        ELSE
          RETURN;
        IFEND;
      CASEND;
    WHILEND;

  PROCEND advance_swap;
?? TITLE := 'ADVANCE_SWAP_STATE', EJECT ??

{
{  This procedure is responsible for updating the job swap status in the IJL. In addition
{  to maintaining job status, this procedure also keep statistics on the total amount of
{  time spent in a state and the new state that was entered from the current state. This is
{  maintained in a 2-dimensional matrix as follows:
{
{
{                             new state
{                    xx xx xx xx xx xx xx xx        each element in the matrix contains:
{                    xx xx xx xx xx xx xx xx           count - number of transitions between states
{           old      xx xx xx xx xx xx xx xx           time -  total time spent in old state prior to
{           state    xx xx xx xx xx xx xx xx                   transition to new state
{                    xx xx xx xx xx xx xx xx
{



  PROCEDURE advance_swap_state
    (    ijle_p: ^jmt$initiated_job_list_entry;
         new_swap_status: jmt$ijl_swap_status);

    VAR
      current_time: ost$free_running_clock,
      delta_time: ost$free_running_clock,
      old_swap_status: jmt$ijl_swap_status;

    old_swap_status := ijle_p^.swap_status;
    ijle_p^.last_swap_status := old_swap_status;
    current_time := #FREE_RUNNING_CLOCK (0);
    delta_time := current_time - ijle_p^.swap_data.timestamp;

    jsv$swap_state_statistics [old_swap_status] [new_swap_status].
          count := jsv$swap_state_statistics [old_swap_status] [new_swap_status].count + 1;

    jsv$swap_state_statistics [old_swap_status] [new_swap_status].
          total_time := jsv$swap_state_statistics [old_swap_status] [new_swap_status].total_time + delta_time;

    IF delta_time > jsv$swap_state_statistics [old_swap_status] [new_swap_status].maximum_time THEN
      IF delta_time > UPPERVALUE (jsv$swap_state_statistics [old_swap_status] [new_swap_status].
            maximum_time) THEN
        jsv$swap_state_statistics [old_swap_status] [new_swap_status].
              maximum_time := UPPERVALUE (jsv$swap_state_statistics [old_swap_status] [new_swap_status].
              maximum_time);
      ELSE
        jsv$swap_state_statistics [old_swap_status] [new_swap_status].maximum_time := delta_time;
      IFEND;
    IFEND;

    ijle_p^.swap_data.timestamp := current_time;
    ijle_p^.swap_status := new_swap_status;

  PROCEND advance_swap_state;
?? TITLE := 'ALLOCATE_SWAP_FILE', EJECT ??

{ PURPOSE:
{   This procedure determines if the swap file is large enough, and allocates more space if necessary.

  PROCEDURE allocate_swap_file
    (    ijle_p: ^jmt$initiated_job_list_entry;
     VAR status: syt$monitor_status);

    VAR
      fde_p: gft$locked_file_desc_entry_p,
      file_status: dmt$file_allocation_status,
      ignore_aus_obtained: amt$file_byte_address,
      ignore_overflow: boolean,
      total_swapped_page_count: 0 .. osc$max_page_frames;

    status.normal := TRUE;

    total_swapped_page_count := ijle_p^.swap_data.swapped_job_page_count +
          ijle_p^.swap_data.swapped_job_entry.swap_file_descriptor_page_count;
    IF total_swapped_page_count > ijle_p^.swap_data.swap_file_length_in_pages THEN
      gfp$mtr_get_locked_fde_p (ijle_p^.swap_data.swap_file_sfid, ijle_p, fde_p);
      dmp$allocate_file_space (fde_p, 0, total_swapped_page_count * osv$page_size - 1, sfc$no_limit,
            ignore_aus_obtained, ignore_overflow, file_status);
      trace (jsc$ti_allocate_swap_file, 1);

      CASE file_status OF
      = dmc$fas_file_allocated =
        ijle_p^.swap_data.swap_file_length_in_pages := total_swapped_page_count;
        fde_p^.eoi_byte_address := total_swapped_page_count * osv$page_size;
        fde_p^.flags.eoi_modified := TRUE;

      = dmc$fas_job_mode_work_required =
        trace (jsc$ti_allocate_swap_file_jm, 1);
        mtp$set_status_abnormal ('JS', jse$swap_file_not_allocated, status);

      = dmc$fas_temp_reject =
        trace (jsc$ti_dm_transient_error, 1);
        mtp$set_status_abnormal ('DM', dme$transient_error, status);

      ELSE
        mtp$error_stop ('JS - unexpected status from dmp$allocate_file_space');
      CASEND;
    IFEND;

  PROCEND allocate_swap_file;
?? TITLE := 'ASSIGN PAGES FOR SFD', EJECT ??

  PROCEDURE assign_pages_for_sfd
    (    ijle_p: ^jmt$initiated_job_list_entry;
         ijl_ordinal: jmt$ijl_ordinal;
         direction: jst$swap_direction;
     VAR status: syt$monitor_status);

{
{     This procedure assigns the pages for the swap file descriptor in job fixed of the job being
{  swapped in or out.
{

    VAR
      ajlo: jmt$ajl_ordinal,
      jcb_p: ^jmt$job_control_block,
      ptr_to_sfd: ^^cell,
      rma: integer,
      sfd_cell_p: ^cell,
      sfd_offset: integer,
      sfd_page_count: 0 .. osc$max_page_frames,
      total_swapped_page_count: 0 .. osc$max_page_frames,
      try: integer;

    sfd_page_count := ijle_p^.swap_data.swapped_job_entry.swap_file_descriptor_page_count;
    total_swapped_page_count := ijle_p^.swap_data.swapped_job_page_count + sfd_page_count;
    sfd_offset := osv$page_size * 3713 + 10000000(16);
    ajlo := ijle_p^.ajl_ordinal;

    IF direction = jsc$sd_out THEN
      jmp$assign_ajl_entry (ijle_p^.job_fixed_asid, ijl_ordinal, jmc$lock_ajl, TRUE {must assign} , ajlo,
            status);
    IFEND;

{ Allocate pages at the end JOB FIXED for the SFD. If the request is rejected because of page
{table full, try several times before giving up - use a different PVA on each try.

    try := 10;

    REPEAT
      sfd_offset := sfd_offset + osv$page_size * 471;
      sfd_cell_p := #ADDRESS (1, ajlo + mtc$job_fixed_segment, sfd_offset);
      mmp$assign_page_to_monitor (sfd_cell_p, sfd_page_count, FALSE, status);
      IF NOT status.normal AND ((status.condition <> mme$page_table_full) OR (try = 0)) THEN
        IF direction = jsc$sd_out THEN
          jmp$free_ajl_entry (ijle_p, jmc$lock_ajl);
        IFEND;
        RETURN;
      IFEND;
      try := try - 1;
    UNTIL status.normal;

{ Update the IJL with SFD descriptive information. Set up the swap io control block
{ with the information required for build_lock_rma_list.

    ptr_to_sfd := #LOC (ijle_p^.sfd_p);
    i#build_adaptable_array_ptr (1, ajlo + mtc$job_fixed_segment, sfd_offset,
          #SIZE (jst$swapped_page_descriptor) * total_swapped_page_count, 0,
          #SIZE (jst$swapped_page_descriptor), #LOC (ptr_to_sfd^));
    i#real_memory_address (sfd_cell_p, rma);
    ijle_p^.swap_io_control.swap_file_descriptor_pfti := rma DIV osv$page_size;
    IF direction = jsc$sd_out THEN

{ Set up jcb with the swapped_job_entry.  It is used by job recovery.

      jcb_p := #ADDRESS (1, mtc$job_fixed_segment + ajlo, 0);
      jcb_p^.swapped_job_entry := ijle_p^.swap_data.swapped_job_entry;

      ijle_p^.sfd_p^.swapped_job_entry := ijle_p^.swap_data.swapped_job_entry;
      ijle_p^.sfd_p^.ijl_entry := ijle_p^;

      jmp$free_ajl_entry (ijle_p, jmc$lock_ajl);
    IFEND;

    mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon + sfd_page_count;

  PROCEND assign_pages_for_sfd;

?? TITLE := 'CALCULATE_SFD_LENGTH', EJECT ??

  PROCEDURE calculate_sfd_length
    (    ijle_p: ^jmt$initiated_job_list_entry);

{
{  This procedure calculates the swap file descriptor length and set the value in the IJL.
{

    VAR
      job_page_count: 0 .. osc$max_page_frames,
      sfd_p: ^jst$swap_file_descriptor,
      sfd_page_count: 0 .. osc$max_page_frames;


    job_page_count := ijle_p^.swap_data.swapped_job_page_count;

{ Determine number of pages to allocate for the swap file descriptor.  The following algorithm makes a
{ guess that 1 page is required, then iterates until the size is correct.

    PUSH sfd_p: [0 .. 0]; {used to get size of a sfd with 1 entry}
    sfd_page_count := 1 + (#SIZE (sfd_p^) + #SIZE (jst$swapped_page_descriptor) * job_page_count - 1) DIV
          osv$page_size;
    WHILE ((job_page_count + sfd_page_count - 1) * #SIZE (jst$swapped_page_descriptor) + #SIZE (sfd_p^)) >
          (sfd_page_count * osv$page_size) DO
      sfd_page_count := sfd_page_count + 1;
    WHILEND;

    ijle_p^.swap_data.swapped_job_entry.swap_file_descriptor_page_count := sfd_page_count;

  PROCEND calculate_sfd_length;
?? TITLE := 'CALCULATE_SWAPPED_PAGES' ??
?? EJECT ??

  PROCEDURE [INLINE] calculate_swapped_pages
    (    ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      job_page_count: mmt$page_frame_index,
      job_queue_id: mmt$job_page_queue_index;

    job_page_count := 0;

    FOR job_queue_id := LOWERVALUE (mmt$job_page_queue_index) TO UPPERVALUE (mmt$job_page_queue_index) DO
      job_page_count := job_page_count + ijle_p^.job_page_queue_list [job_queue_id].count;
      ijle_p^.swap_data.swapped_job_entry.job_page_queue_count [job_queue_id] :=
            ijle_p^.job_page_queue_list [job_queue_id].count;
    FOREND;

    ijle_p^.swap_data.swapped_job_page_count := job_page_count;

    mmv$reassignable_page_frames.swapout_io_not_initiated :=
          mmv$reassignable_page_frames.swapout_io_not_initiated + ijle_p^.swap_data.swapped_job_page_count -
          ijle_p^.job_fixed_contiguous_pages;

  PROCEND calculate_swapped_pages;

?? TITLE := 'CLAIM_PAGES_FOR_SWAP_IN' ??
?? EJECT ??

  PROCEDURE claim_pages_for_swap_in
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry;
     VAR status: syt$monitor_status);

{
{   The purpose of this procedure is to claim the number of pages needed to
{ swap the job in.  The pages are linked in the proper queues at this time
{ except the available modified pages are linked into the job working set
{ queue.
{

    VAR
      ajl_ordinal: jmt$ajl_ordinal,
      ast_index: mmt$ast_index,
      temp_asti: mmt$ast_index,
      asid: ost$asid,
      aste_p: ^mmt$active_segment_table_entry,
      queue: mmt$global_page_queue_index,
      sum_shared: integer,
      total_swapped_page_count: 0 .. osc$max_page_frames,
      update_segnum_sfd_p: cybil_pointer_trick;

    status.normal := TRUE;
    total_swapped_page_count := ijle_p^.swap_data.swapped_job_page_count +
          ijle_p^.swap_data.swapped_job_entry.swap_file_descriptor_page_count;

{  Check if there is enough memory in the free and availble queues to swap this job in.

    IF ((total_swapped_page_count >= mmv$reassignable_page_frames.now) OR
          (total_swapped_page_count >= (mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon -
          mmv$aggressive_aging_level_2))) THEN

{ Raid the shared queue if there are enough pages in it to swapin the job.

      sum_shared := 0;
      FOR queue := mmc$pq_shared_first TO mmv$last_active_shared_queue DO
        sum_shared := sum_shared + mmv$gpql [queue].pqle.count;
      FOREND;
      IF (mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon + sum_shared -
            mmv$aggressive_aging_level_2) > total_swapped_page_count THEN
        trace (jsc$ti_dump_shared_queue, 1);
        mmp$dump_shared_queue (total_swapped_page_count);
      IFEND;

{ If there is still not enough memory, RETURN bad status.

      IF (total_swapped_page_count >= mmv$reassignable_page_frames.now) OR
            (total_swapped_page_count >= (mmv$reassignable_page_frames.now +
            mmv$reassignable_page_frames.soon - mmv$aggressive_aging_level_2)) THEN
        trace (jsc$ti_no_memory_for_swap_in, 1);
        mtp$set_status_abnormal ('JS', jse$not_enough_mem_for_swap_in, status);
        RETURN;
      IFEND;
    IFEND;


{   Reclaim the old job fixed ASID or assign a new one if the old one is in use.

    asid := ijle_p^.job_fixed_asid;

    mmp$asti (asid, ast_index);
    aste_p := ^mmv$ast_p^ [ast_index];
    IF (jmc$dsw_job_recovery IN ijle_p^.delayed_swapin_work) OR (aste_p^.ijl_ordinal <> ijl_ordinal) THEN
      trace (jsc$ti_new_job_fixed_asid, 1);
      mmp$assign_asid (asid, temp_asti, aste_p);
      ijle_p^.job_fixed_asid := asid;
    ELSE
      trace (jsc$ti_reuse_job_fixed_asid, 1);
      IF NOT aste_p^.in_use THEN
        trace (jsc$ti_reuse_job_fixed_asid_as, 1);
        mmp$assign_specific_asid (aste_p);
      IFEND;
    IFEND;
    aste_p^ := mmv$initial_job_fixed_ast_entry;
    aste_p^.ijl_ordinal := ijl_ordinal;

{ Assign an ajl entry to the job.

    jmp$assign_ajl_entry (asid, ijl_ordinal, jmc$swapping_ajl, FALSE {must assign} , ajl_ordinal, status);
    IF NOT status.normal THEN
      trace (jsc$ti_no_ajl_ord_for_swap_in, 1);
      RETURN;
    IFEND;

    IF syv$perf_keypoints_enabled.swapping_keypoints THEN
      kt.s := ijle_p^.system_supplied_name (16, 4);
      #KEYPOINT (osk$performance, osk$m * kt.f1, ptk$swapin_job_name_1);
      #KEYPOINT (osk$performance, osk$m * ((kt.f2 * 256) + ajl_ordinal), ptk$swapin_job_name_2);
    IFEND;

{ Assign new page frames for the job and swap file descriptor.

    mmp$claim_pages_for_swapin (ijle_p^.swap_data.swapped_job_entry, aste_p, ijl_ordinal,
          ijle_p^.job_page_queue_list, status);
    IF NOT status.normal THEN
      trace (jsc$ti_no_mem_from_claim_pages, 1);
      jmp$free_ajl_entry (ijle_p, jmc$swapping_ajl);
      mmp$free_asid (asid, aste_p);
      mtp$set_status_abnormal ('JS', jse$not_enough_mem_for_swap_in, status);
      RETURN;
    IFEND;

    assign_pages_for_sfd (ijle_p, ijl_ordinal, jsc$sd_in, status);
    IF NOT status.normal THEN
      trace (jsc$ti_no_pages_for_sfd_on_si, 1);
      mmp$free_memory_in_job_queues (ijle_p^.job_page_queue_list, TRUE, FALSE, FALSE);
      jmp$free_ajl_entry (ijle_p, jmc$swapping_ajl);
      mmp$free_asid (asid, aste_p);
      mtp$set_status_abnormal ('JS', jse$not_enough_mem_for_swap_in, status);
    IFEND;

  PROCEND claim_pages_for_swap_in;
?? TITLE := 'COMPLETE_SWAPIN' ??
?? EJECT ??

  PROCEDURE complete_swapin
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry;
         available_modified_page_count: 0 .. osc$max_page_frames);

{
{     The purpose of this procedure is to perform the tasks to complete the swapin of a job after
{  the memory manager tables have been restored.  This procedure sets the proper swap status and
{  relinks the job into the null swapping queue.
{

    VAR
      jcb_p: ^jmt$job_control_block;


{  Move pages back to the available modified queue if they belong there.

    IF available_modified_page_count > 0 THEN
      move_am_to_am (ijle_p, available_modified_page_count);
    IFEND;

    jcb_p := #ADDRESS (1, mtc$job_fixed_segment + ijle_p^.ajl_ordinal, 0);
    jcb_p^.next_cyclic_aging_time := #FREE_RUNNING_CLOCK (0) + jcb_p^.next_cyclic_aging_time;

    restart_idled_tasks (ijl_ordinal, ijle_p);

    IF (available_modified_page_count > 0) THEN
      mmp$replenish_free_queues (0);
    IFEND;

  PROCEND complete_swapin;
?? TITLE := 'FLUSH_AM_PAGES_TO_DISK', EJECT ??

  PROCEDURE flush_am_pages_to_disk
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry);

{  This prcedure will initiate IO to disk to write out the pages in the available modified
{  queue that belong to the specified job.  If IO fails for any reason the page will be moved
{  to the job working set.

    VAR
      ajlo: jmt$ajl_ordinal,
      fde_p: gft$locked_file_desc_entry_p,
      io_id: mmt$io_identifier,
      modified_pages_removed: 0 .. osc$max_page_frames,
      next_pfti: mmt$page_frame_index,
      pfti: mmt$page_frame_index,
      status: syt$monitor_status,
      write_status: mmt$write_page_to_disk_status;

    #KEYPOINT (osk$entry, 0, jsk$flush_am_pages_to_disk);

{  Set up an AJL ordinal for use by mmp$write_page_to_disk.

    jmp$assign_ajl_entry (ijle_p^.job_fixed_asid, ijl_ordinal, jmc$lock_ajl, TRUE {must assign} , ajlo,
          status);
    modified_pages_removed := 0;
    pfti := mmv$gpql [mmc$pq_avail_modified].pqle.link.bkw;

    io_id.specified := FALSE;

  /scan_available_modified_queue/
    WHILE pfti <> 0 DO
      next_pfti := mmv$pft_p^ [pfti].link.bkw;
      IF (mmv$pft_p^ [pfti].aste_p^.ijl_ordinal = ijl_ordinal) AND mmv$pt_p^ [mmv$pft_p^ [pfti].pti].m THEN
        IF mmv$pft_p^ [pfti].aste_p^.sfid.residence = gfc$tr_system_wait_recovery THEN
          EXIT /scan_available_modified_queue/;
        IFEND;
        gfp$mtr_get_locked_fde_p (mmv$pft_p^ [pfti].aste_p^.sfid, ijle_p, fde_p);
        mmp$write_page_to_disk (fde_p, pfti, ioc$write_page, io_id, FALSE, write_status);
        trace (jsc$ti_flush_am_pc, 1);
        IF mmv$pt_p^ [mmv$pft_p^ [pfti].pti].m THEN

{  Write_status <> ws_ok.

          mmp$relink_page_frame (pfti, mmc$pq_job_working_set);
          modified_pages_removed := modified_pages_removed + 1;
          trace (jsc$ti_flush_am_relink, 1);
        IFEND;
      IFEND;
      pfti := next_pfti;
    WHILEND /scan_available_modified_queue/;

    jmp$free_ajl_entry (ijle_p, jmc$lock_ajl);

    IF modified_pages_removed <> 0 THEN
      ijle_p^.swap_data.swapped_job_entry.available_modified_page_count :=
            ijle_p^.swap_data.swapped_job_entry.available_modified_page_count + modified_pages_removed;
      mmv$reassignable_page_frames.swapout_io_not_initiated :=
            mmv$reassignable_page_frames.swapout_io_not_initiated - ijle_p^.swap_data.swapped_job_page_count +
            ijle_p^.job_fixed_contiguous_pages;
      calculate_swapped_pages (ijle_p);
    IFEND;

    IF ijle_p^.statistics.ready_task_count > 0 THEN
      trace (jsc$ti_flush_am_ready, 1);
    IFEND;

    #KEYPOINT (osk$exit, 0, jsk$flush_am_pages_to_disk);

  PROCEND flush_am_pages_to_disk;

?? TITLE := 'FREE_SWAPPED_JOBS_MM_RESOURCES' ??
?? EJECT ??

  PROCEDURE free_swapped_jobs_mm_resources
    (    ijle_p: ^jmt$initiated_job_list_entry;
         ijl_ordinal: jmt$ijl_ordinal;
         last_swap_status: jmt$ijl_swap_status);

{
{   The purpose of this procedure is to free the memory manager resources
{  of each page in memory of the job being swapped out.  The swap file
{  descriptor is freed if it has not already been.
{
{  NOTE:
{       last_swap_status                    swap_status                        reason/routine
{   jmc$iss_swapin_io_complete       jmc$iss_swapin_resource_claimed       process_io_error_on_swapin
{                                    jmc$iss_swapin_io_complete            process_io_error_on_swapin
{                                    jmc$iss_swapin_io_complete            direction change
{                                    jmc$iss_swapin_io_complete            page table full
{                                    jmc$iss_swapin_io_complete            bad swap file data
{   jmc$iss_swapout_io_complete      jmc$iss_free_swapped_memory           advance_swap - OC -> FM
{   jmc$iss_swapped_io_complete      jmc$iss_free_swapped_memory           jsp$free_swap_resident_job
{   jmc$iss_free_swapped_memory      jmc$iss_free_swapped_memory           jsp$adv_expired_swapped_jobs
{

    #KEYPOINT (osk$entry, 0, jsk$free_swapped_jobs_mm_resour);

{  The swap file descriptor has not been freed if last_swap_status is jmc$iss_swapin_io_complete.

    IF ijle_p^.sfd_p <> NIL THEN
      free_swap_file_descriptor (ijle_p, ijl_ordinal);
      trace (jsc$ti_sfd_freed, 1);
    IFEND;

    IF ijle_p^.swap_status >= jmc$iss_swapin_resource_claimed THEN

{  Swapin aborted.  Free the pages we claimed.

      mmp$free_memory_in_job_queues (ijle_p^.job_page_queue_list, TRUE {increment now} , FALSE
            {decrement soon} , FALSE);
      trace (jsc$ti_free_memory_si_aborted, 1);
    ELSEIF last_swap_status = jmc$iss_swapout_io_complete THEN

{ Going directly from OC to FM to S.  Update NOW and SOON.

      mmp$free_memory_in_job_queues (ijle_p^.job_page_queue_list, TRUE {increment now} ,
            TRUE {decrement soon}, FALSE);
      trace (jsc$ti_free_memory, 1);
    ELSE {advancing from S2 to FM to S}

{  NOW and SOON were updated when we went from OC to S2.

      mmp$free_memory_in_job_queues (ijle_p^.job_page_queue_list, FALSE {increment now} , FALSE
            {decrement soon} , FALSE);
      trace (jsc$ti_free_memory, 1);
    IFEND;

    #KEYPOINT (osk$exit, 0, jsk$free_swapped_jobs_mm_resour);

  PROCEND free_swapped_jobs_mm_resources;
?? TITLE := 'FREE_SWAP_FILE_DESCRIPTOR', EJECT ??

  PROCEDURE [INLINE] free_swap_file_descriptor
    (    ijle_p: ^jmt$initiated_job_list_entry;
         ijl_ordinal: jmt$ijl_ordinal);

{
{     The purpose of this procedure is to free the swap file descriptor from monitor's address
{  space.
{

    VAR
      ajlo: jmt$ajl_ordinal,
      need_ajl: boolean,
      status: syt$monitor_status,
      update_segnum_sfd_p: cybil_pointer_trick;

    need_ajl := (ijle_p^.ajl_ordinal = jmc$null_ajl_ordinal);
    IF need_ajl THEN
      jmp$assign_ajl_entry (ijle_p^.job_fixed_asid, ijl_ordinal, jmc$lock_ajl, TRUE {must assign} , ajlo,
            status);
      update_segnum_sfd_p.sfd_p := ijle_p^.sfd_p;
      update_segnum_sfd_p.pva.seg := ajlo + mtc$job_fixed_segment;
      ijle_p^.sfd_p := update_segnum_sfd_p.sfd_p;
    IFEND;

    mmp$delete_page_from_monitor (ijle_p^.sfd_p, ijle_p^.swap_data.swapped_job_entry.
          swap_file_descriptor_page_count, status);

    IF need_ajl THEN
      jmp$free_ajl_entry (ijle_p, jmc$lock_ajl);
    IFEND;

    IF NOT status.normal THEN
      mtp$error_stop ('JS - unable to free SFD');
    IFEND;
    ijle_p^.sfd_p := NIL;

{  Decrement reassignable page frames SOON. NOW was incremented when the swap file descriptor
{  pages were deleted from monitor's address space above.

    mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon -
          ijle_p^.swap_data.swapped_job_entry.swap_file_descriptor_page_count;

{ Update the MAP_PURGE_TIMESTAMP. Pages assigned to the SFD were just deleted. Before the job next swaps
{ out or in and attempts to reference the SFD, the page map must be purged. The timestamp is used to
{ remember the time the SFD was freed.

    ijle_p^.sfd_purge_timestamp := #FREE_RUNNING_CLOCK (0);

  PROCEND free_swap_file_descriptor;

?? TITLE := 'JOB_MODE_SWAPOUT', EJECT ??

{ PURPOSE:
{   This procedure processes the swap_job_out or the special_swapout monitor swapping requests.
{ DESIGN:
{   The caller must have the PTL lock set so that entry status is not changing through the task switch/
{   monitor swap path, and because the entry status change done by this procedure will cause the swapped
{   job count to change.
{   NOTE:  The caller has verified that the job's entry status is either in memory or swapin in progress.

  PROCEDURE [INLINE] job_mode_swapout
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry;
         swap_reason: jmt$swapout_reasons;
         memory_needed: mmt$page_frame_index;
     VAR poll_swapping: boolean;
     VAR status: syt$monitor_status);

    VAR
      frc: ost$free_running_clock,
      jcb_p: ^jmt$job_control_block,
      job_page_count: mmt$page_frame_index,
      mcount: integer,
      minws: mmt$page_frame_index,
      old_entry_status: jmt$ijl_entry_status,
      pages_now: mmt$page_frame_index,
      queue_id: mmt$job_page_queue_index,
      rcount: integer;

    { If age_jws_before_swap is set, try to age the working set of the job to free enough memory.  If
    { enough memory is freed, do not swap the job.  Memory needed will be 0 if this is a "special" swapout;
    { if it is a preemption just to get memory, memory_needed will be greater than 0.  Determine the number
    { of pages freed by noting the difference in the NOW count; both the monitor interlock and the PTL lock
    { are set, so no other process can be changing the NOW count.

    IF (memory_needed > 0) AND jsv$age_jws_before_swap AND (ijle_p^.entry_status = jmc$ies_job_in_memory) THEN
      pages_now := mmv$reassignable_page_frames.now;
      jcb_p := #ADDRESS (1, mtc$job_fixed_segment + ijle_p^.ajl_ordinal, 0);
      IF jsv$age_before_swap_percentage <> 0 THEN
        minws := jcb_p^.min_working_set_size - ((jcb_p^.min_working_set_size *
              jsv$age_before_swap_percentage) DIV 100);
      ELSE
        minws := jcb_p^.min_working_set_size;
      IFEND;
      mmp$age_job_working_set (ijle_p, jcb_p);
      mmp$remove_stale_pages (ijle_p^.job_page_queue_list [mmc$pq_job_working_set], 1, jcb_p, ijle_p,
            mmc$pq_avail_modified, minws, mcount, rcount);
      pages_now := mmv$reassignable_page_frames.now - pages_now;
      trace (jsc$ti_job_aged_before_swap, 1);
      trace (jsc$ti_age_before_swap_pages, pages_now);
      IF pages_now >= memory_needed THEN
        trace (jsc$ti_age_before_swap_okay, 1);
        mtp$set_status_abnormal ('JS', jse$job_aged_not_swapped, status);
        RETURN;
      IFEND;
    IFEND;

    old_entry_status := ijle_p^.entry_status;

    IF swap_reason = jmc$sr_operator_request THEN
      jmp$change_ijl_entry_status (ijle_p, jmc$ies_operator_force_out);
    ELSEIF swap_reason = jmc$sr_job_damaged THEN
      jmp$change_ijl_entry_status (ijle_p, jmc$ies_job_damaged);
    ELSE
      IF ijle_p^.statistics.ready_task_count > 0 THEN
        jmp$set_entry_status_to_rt (ijl_ordinal, ijle_p);
      ELSE
        jmp$change_ijl_entry_status (ijle_p, jmc$ies_job_swapped);
      IFEND;
    IFEND;

    IF old_entry_status = jmc$ies_swapin_in_progress THEN

{ If the swap status is an end state, the job must have been made a swapin candidate and relinked to the
{ swapping queue just before this monitor request got the PTL lock.  The job needs to be relinked back
{ to the proper swap queue.  Otherwise, the job must be in a blocked state (waiting for I/O, etc.).
{ Leave the job in the swapping queue. Advance_swap will advance it to the next end state.

      IF ijle_p^.swap_status = jmc$iss_swapped_io_cannot_init THEN
        jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapped_io_cannot_init);
      ELSEIF ijle_p^.swap_status = jmc$iss_swapped_io_complete THEN
        jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapped_io_completed);
      ELSEIF ijle_p^.swap_status = jmc$iss_swapout_complete THEN
        jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapped_out);
      IFEND;

    ELSE

{ Old_entry_status = jmc$ies_in_memory, so swap the job out.

      sched_trace (jsc$sc_swapout_job_mode, ijl_ordinal);

      ijle_p^.job_scheduler_data.swapout_reason := swap_reason;
      ijle_p^.job_scheduler_data.job_swap_counts.job_mode :=
            ijle_p^.job_scheduler_data.job_swap_counts.job_mode + 1;

      IF ijle_p^.swap_status = jmc$iss_executing THEN
        trace (jsc$ti_swapout_from_job_mode, 1);
        IF syv$perf_keypoints_enabled.swapping_keypoints THEN
          #KEYPOINT (osk$performance, osk$m * ijle_p^.ajl_ordinal, ptk$ajl_for_swap_out);
        IFEND;
        jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapping);

{  Set close approximation of swapped job page count for job mode job scheduler.  The count is also
{  used for the service class statistics.

        job_page_count := 0;
        FOR queue_id := LOWERVALUE (mmt$job_page_queue_index) TO UPPERVALUE (mmt$job_page_queue_index) DO
          job_page_count := job_page_count + ijle_p^.job_page_queue_list [queue_id].count;
        FOREND;

        ijle_p^.swap_data.swapped_job_page_count := job_page_count;
        ijle_p^.swap_io_control.spd_index := LOWERVALUE (mmt$page_frame_index);

{ This is a job mode swapout, not a long wait swapout; do not consider the service class long_wait_think_time.

        frc := #FREE_RUNNING_CLOCK (0);
        ijle_p^.swap_data.long_wait_expire_time := frc;

{ Swap_data.timestamp is still the time when the job completed swapin.  Swapin to swapout is residence time.

        ijle_p^.swap_data.swapout_timestamp := frc;

        tmp$set_lock (jmv$service_class_stats_lock);
        jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.statistics.swap_stats.
              residence_time := jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.statistics.
              swap_stats.residence_time + (ijle_p^.swap_data.swapout_timestamp - ijle_p^.swap_data.timestamp);
        jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.statistics.swap_stats.swapped_pages :=
              jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.statistics.swap_stats.
              swapped_pages + ijle_p^.swap_data.swapped_job_page_count;
        tmp$clear_lock (jmv$service_class_stats_lock);

        tmp$idle_tasks_in_job (ijle_p^.ajl_ordinal, ijle_p^.job_scheduler_data.swapout_reason, status);
        IF status.normal THEN
          ijle_p^.delayed_swapin_work := $jmt$delayed_swapin_work [];

{ Dont clear inhibit - let it be cleared by either server job recovery
{ or by the job when it detects that the server is not longer inactive.

          ijle_p^.terminate_access_work := $dft$mainframe_set [];
          advance_swap_state (ijle_p, jmc$iss_job_idle_tasks_complete);
          set_swapping_event (jsc$se_immediate);
          poll_swapping := FALSE;
        ELSEIF status.condition = jse$unable_to_idle_all_tasks THEN
          status.normal := TRUE;
          advance_swap_state (ijle_p, jmc$iss_idle_tasks_initiated);
        ELSE
          mtp$error_stop ('JS - UNEXPECTED CONDITION FROM IDLE TASKS');
        IFEND;

        ?IF debug = TRUE THEN
          IF syv$allow_jr_test THEN
            IF syc$tjr_mtr_mvamjws IN syv$test_jr_system THEN
              mtp$error_stop ('JOB RECOVERY TEST');
            IFEND;
          IFEND;
        ?IFEND
      IFEND;
    IFEND;

  PROCEND job_mode_swapout;

?? TITLE := 'JOB_SWAPPING_IO' ??
?? EJECT ??

{ PURPOSE:
{   This procedure performs the io necessary to swap a job in or out.

  PROCEDURE job_swapping_io
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry;
         sfid: dmt$system_file_id;
         io_function: iot$io_function;
         total_swapped_page_count: 0 .. osc$max_page_frames;
     VAR io_control_information: jst$io_control_information;
     VAR status: syt$monitor_status);


    VAR
      ajlo: jmt$ajl_ordinal,
      buffer_descriptor: mmt$buffer_descriptor,
      fde_p: gft$file_desc_entry_p,
      io_id: mmt$io_identifier,
      jcb_p: ^jmt$job_control_block,
      page_count: mmt$page_frame_index,
      page_status: gft$page_status,
      update_segnum_sfd_p: cybil_pointer_trick;


    io_id.specified := FALSE;
    io_id.ijl_ordinal := ijl_ordinal;

    IF io_function = ioc$swap_out THEN

{  Add a temporary segment table entry to monitor's segment table for the job fixed segment of the job
{  being swapped.  Update the sfd_p in the IJL entry too.

      jmp$assign_ajl_entry (ijle_p^.job_fixed_asid, ijl_ordinal, jmc$lock_ajl, TRUE {must assign} , ajlo,
            status);
      update_segnum_sfd_p.sfd_p := ijle_p^.sfd_p;
      update_segnum_sfd_p.pva.seg := ajlo + mtc$job_fixed_segment;
      ijle_p^.sfd_p := update_segnum_sfd_p.sfd_p;
      ijle_p^.sfd_p^.ijl_entry := ijle_p^;
      jcb_p := #ADDRESS (1, update_segnum_sfd_p.pva.seg, 0);
      jcb_p^.swapped_job_entry := ijle_p^.swap_data.swapped_job_entry;
    IFEND;

{  Issue the necessary IO requests to swap job out.

    buffer_descriptor.buffer_descriptor_type := mmc$bd_job_swapping_io;
    buffer_descriptor.ijl_ordinal := ijl_ordinal;

  /initiate_swap_io/
    BEGIN
      gfp$mtr_get_locked_fde_p (sfid, ijle_p, fde_p);
      REPEAT
        page_count := (total_swapped_page_count - io_control_information.spd_index);
        IF page_count > fde_p^.allocation_unit_size DIV osv$page_size THEN
          page_count := fde_p^.allocation_unit_size DIV osv$page_size;
        IFEND;

        buffer_descriptor.page_count := page_count;
        iop$pager_io (fde_p, io_control_information.spd_index * osv$page_size, buffer_descriptor,
              page_count * osv$page_size, io_function, io_id, status);
        IF NOT status.normal THEN
          trace (jsc$ti_pager_io_error, 1);
          EXIT /initiate_swap_io/;
        IFEND;
      UNTIL io_control_information.spd_index >= total_swapped_page_count;
    END /initiate_swap_io/;

    IF io_function = ioc$swap_out THEN
      jmp$free_ajl_entry (ijle_p, jmc$lock_ajl);
    IFEND;

{ Both callers of job_swapping_io check only for condition = ioe$unit_disabled.  All other 'bad'
{ statuses are assumed to be a transient error--the job is advanced to a wait_io_init state;
{ swapper will try to initiate the io again shortly.

    IF NOT status.normal THEN
      IF status.condition = ioe$unit_disabled THEN

{ Reset spd_index--if io is initiated again the io will start at the beginning.

        ijle_p^.swap_io_control.spd_index := LOWERVALUE (mmt$page_frame_index);
        ijle_p^.swap_data.swapping_io_error := ioc$unrecovered_error_unit_down;
        IF ijle_p^.active_io_page_count > 0 THEN
          status.normal := TRUE;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      ijle_p^.notify_swapper_when_io_complete := TRUE;
    IFEND;

  PROCEND job_swapping_io;
?? TITLE := 'MOVE_AM_TO_AM' ??
?? EJECT ??

  PROCEDURE move_am_to_am
    (    ijle_p: ^jmt$initiated_job_list_entry;
         available_modified_page_count: 0 .. osc$max_page_frames);

{
{   The purpose of this procedure is to move pages back to the  available modified
{ queue that belong to specified job. This procedure is used if a swapout request is aborted.
{

    VAR
      pfti: mmt$page_frame_index,
      i: integer;


    trace (jsc$ti_move_am_back_to_am, 1);
    trace (jsc$ti_move_am_back_to_am_pc, available_modified_page_count);
    pfti := ijle_p^.job_page_queue_list [mmc$pq_job_working_set].link.fwd;
    WHILE (pfti <> 0) AND (NOT mmv$pt_p^ [mmv$pft_p^ [pfti].pti].v) AND
          (mmv$pft_p^ [pfti].locked_page = mmc$lp_not_locked) DO
      mmp$relink_page_frame (pfti, mmc$pq_avail_modified);
      pfti := ijle_p^.job_page_queue_list [mmc$pq_job_working_set].link.fwd;
    WHILEND;

    ijle_p^.swap_data.swapped_job_entry.available_modified_page_count := 0;

  PROCEND move_am_to_am;
?? TITLE := 'PROCESS_IO_ERROR_ON_SWAPIN', EJECT ??

  PROCEDURE process_io_error_on_swapin
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry);

{  IO completed abnormally, free resources, put the job in swapped-out state and tell the scheduler.

    free_swapped_jobs_mm_resources (ijle_p, ijl_ordinal, jmc$iss_swapin_io_complete);
    advance_swap_state (ijle_p, jmc$iss_swapout_complete);
    jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapped_out);
    jmp$recognize_job_dead (ijl_ordinal);
    jmp$free_ajl_entry (ijle_p, jmc$swapping_ajl);

  PROCEND process_io_error_on_swapin;
?? TITLE := 'PROCESS_IO_ERROR_ON_SWAPOUT', EJECT ??

  PROCEDURE process_io_error_on_swapout
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry;
     VAR set_polling_event: boolean);

    advance_swap_state (ijle_p, jmc$iss_swapped_io_cannot_init);
    mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon -
          ijle_p^.swap_data.swapped_job_page_count + ijle_p^.job_fixed_contiguous_pages;
    mmv$reassignable_page_frames.swapout_io_cannot_initiate :=
          mmv$reassignable_page_frames.swapout_io_cannot_initiate + ijle_p^.swap_data.swapped_job_page_count -
          ijle_p^.job_fixed_contiguous_pages;
    jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapped_io_cannot_init);
    free_swap_file_descriptor (ijle_p, ijl_ordinal);

{ Recheck swap direction before returning to prevent timing problems with a task of the job going ready.

    IF ijle_p^.entry_status < jmc$ies_swapped_out THEN
      jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapping);
      set_polling_event := TRUE;
    ELSE
      jmp$activate_job_mode_swapper;
    IFEND;

  PROCEND process_io_error_on_swapout;

?? TITLE := 'RECLAIM_IO_ERROR_PAGES', EJECT ??

  PROCEDURE reclaim_io_error_pages
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      boffset: integer,
      eoffset: integer,
      fde_p: gft$file_desc_entry_p,
      next_pfti: mmt$page_frame_index,
      pfte_p: ^mmt$page_frame_table_entry,
      pfti: mmt$page_frame_index,
      status: syt$monitor_status,
      tu_pfte_p: ^mmt$page_frame_table_entry,
      tu_pfti: mmt$page_frame_index;


    pfti := mmv$gpql [mmc$pq_swapped_io_error].pqle.link.bkw;

    WHILE pfti <> 0 DO
      pfte_p := ^mmv$pft_p^ [pfti];
      next_pfti := pfte_p^.link.bkw;
      IF (pfte_p^.aste_p^.ijl_ordinal = ijl_ordinal) THEN
        trace (jsc$ti_riop_relinked, 1);
        mmp$relink_page_frame (pfti, mmc$pq_job_io_error);
        gfp$mtr_get_locked_fde_p (pfte_p^.aste_p^.sfid, ijle_p, fde_p);

{  Reset the modified bit for all pages in this TU if memory was freed.  If the io error
{  occurred after the job was in the JC state and there was a page in the JWS or Job IO
{  error queue in the write request (due to multiple page write), the page was not moved
{  to an error queue and the modified bit is no longer set.  Unlock rma list resets the
{  modified bit while processing the error but it is lost if memory is freed.

        IF ijle_p^.last_swap_status > jmc$iss_swapped_io_complete {S2} THEN
          trace (jsc$ti_riop_mem_freed, 1);
          boffset := pfte_p^.sva.offset DIV fde_p^.allocation_unit_size * fde_p^.allocation_unit_size;
          eoffset := boffset + fde_p^.allocation_unit_size;
          tu_pfti := pfte_p^.aste_p^.pft_link.fwd;

          WHILE tu_pfti <> 0 DO
            tu_pfte_p := ^mmv$pft_p^ [tu_pfti];
            IF (tu_pfte_p^.sva.offset >= boffset) AND (tu_pfte_p^.sva.offset < eoffset) AND
                  (tu_pfte_p^.queue_id >= mmc$pq_job_base) THEN
              trace (jsc$ti_riop_m_bit_reset, 1);
              mmv$pt_p^ [tu_pfte_p^.pti].m := TRUE;
            IFEND;
            tu_pfti := mmv$pft_p^ [tu_pfti].segment_link.fwd;
          WHILEND;
        IFEND;

{  If the io error occured on an initial write, reset the fau state.

        IF (pfte_p^.io_error = ioc$error_on_init) OR (pfte_p^.io_error = ioc$unit_down_on_init) THEN
          trace (jsc$ti_riop_init, 1);
          dmp$set_fau_state (fde_p, pfte_p^.sva.offset, status);
        IFEND;

      IFEND;
      pfti := next_pfti;
    WHILEND;

  PROCEND reclaim_io_error_pages;

?? TITLE := 'RECOVER_JOB_DM_TABLES', EJECT ??

  PROCEDURE recover_job_dm_tables
    (    ijle_p: ^jmt$initiated_job_list_entry;
         ijl_ordinal: jmt$ijl_ordinal;
         system_job_monitor_sdtx_p: ^mmt$segment_descriptor_table_ex);

{
{  This procedure is called to update job information if the swapin is the FIRST swapin of the job
{  that has occurred since a system recovery. This procedure does the following:
{    . reset some info in the SDTX dealing with locked pages/segments.
{    . modifies the SFIDs in the SDTXs of each task to show the segment is waiting for recovery.
{    . sets the dispatching priority in the XCB to the system job priority.
{    . clears the read/write count in the FDE for each job file.
{

    VAR
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      segment_number: ost$segment,
      sfid: gft$system_file_identifier,
      status: syt$monitor_status,
      system_fde_p: gft$file_desc_entry_p,
      system_ijle_p: ^jmt$initiated_job_list_entry,
      xcb_p: ^ost$execution_control_block,
      xcb_state: tmt$find_next_xcb_state;


    jmp$get_ijle_p (jmv$system_ijl_ordinal, system_ijle_p);

    tmp$find_next_xcb (tmc$fnx_swapping_job, ijle_p, ijl_ordinal, xcb_state, xcb_p);

    WHILE xcb_p <> NIL DO

      tmp$set_monitor_flag (xcb_p^.global_task_id, syc$mf_cause_job_recovery, status);
      IF NOT status.normal THEN
        mtp$error_stop ('JS - cant set job recovery flag');
      IFEND;

      xcb_p^.keypoint_enable := FALSE;
      mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);
      FOR segment_number := 0 TO xcb_p^.xp.segment_table_length DO
        IF sdt_p^.st [segment_number].ste.vl <> osc$vl_invalid_entry THEN
          sdtx_p^.sdtx_table [segment_number].assign_active := osc$max_segment_length;
          sdtx_p^.sdtx_table [segment_number].segment_lock := mmc$lss_none;

{ If the segment is a template segment (open_validating_ring is 0), copy the sfid from the system job
{ monitor.  Otherwise, if the segment is for a permanent file, mark the file as waiting for recovery.

          IF sdtx_p^.sdtx_table [segment_number].open_validating_ring_number = 0 THEN
            sdtx_p^.sdtx_table [segment_number].sfid := system_job_monitor_sdtx_p^.
                  sdtx_table [segment_number].sfid;
          ELSEIF sdtx_p^.sdtx_table [segment_number].sfid.residence = gfc$tr_system THEN
            sdtx_p^.sdtx_table [segment_number].sfid.residence := gfc$tr_system_wait_recovery;
          IFEND;

          IF (sdtx_p^.sdtx_table [segment_number].shadow_info.shadow_segment_kind <> mmc$ssk_none) AND
                (sdtx_p^.sdtx_table [segment_number].shadow_info.shadow_sfid.residence = gfc$tr_system) THEN
            sdtx_p^.sdtx_table [segment_number].shadow_info.shadow_sfid.residence :=
                  gfc$tr_system_wait_recovery;
          IFEND;
        IFEND;
      FOREND;

      xcb_p^.dispatching_priority := jmc$priority_system_job;

      tmp$find_next_xcb (tmc$fnx_continue, NIL, jmv$null_ijl_ordinal, xcb_state, xcb_p);

    WHILEND;

    dmp$recover_job_dm_tables (ijle_p);

  PROCEND recover_job_dm_tables;

?? TITLE := 'RELINK_SWAP_QUEUE' ??
?? EJECT ??

  PROCEDURE [XDCL] jsp$relink_swap_queue
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry;
         new_queue: jst$ijl_swap_queue_id);

{
{     The purpose of this procedure is to move and IJL entry from one swap queue
{ to the end of another and maintain queue counts.  Process must be serialized for
{ multiple processors.
{

    VAR
      backward_ijle_p: ^jmt$initiated_job_list_entry,
      current_queue: jst$ijl_swap_queue_id,
      forward_ijle_p: ^jmt$initiated_job_list_entry,
      last_entry_in_queue: jmt$ijl_ordinal,
      last_ijle_p: ^jmt$initiated_job_list_entry;


    tmp$set_lock (jsv$ijl_serial_lock);

    jsp$set_relink_lock (ijl_ordinal);

    last_entry_in_queue := jsv$ijl_swap_queue_list [new_queue].backward_link;
    current_queue := ijle_p^.swap_queue_link.queue_id;

    jsv$relink_swap_q_trace.index := jsv$relink_swap_q_trace.index + 1;
    IF jsv$relink_swap_q_trace.index > 63 THEN
      jsv$relink_swap_q_trace.index := 0;
    IFEND;
    jsv$relink_swap_q_trace.info[jsv$relink_swap_q_trace.index].rt_ijl := ijl_ordinal;
    jsv$relink_swap_q_trace.info[jsv$relink_swap_q_trace.index].rt_new_queue := new_queue;
    jsv$relink_swap_q_trace.info[jsv$relink_swap_q_trace.index].rt_old_swap_q_link :=
         ijle_p^.swap_queue_link;

    IF current_queue = new_queue THEN
      IF new_queue <> jsc$isqi_swapping THEN
        mtp$error_stop ('JS - relink_swap_queue called to relink to same queue.');
      ELSE
        jsp$clear_relink_lock;
        tmp$clear_lock (jsv$ijl_serial_lock);
        RETURN;
      IFEND;
    IFEND;

{  Remove entry from old swap queue if it is not in the null queue.

    IF current_queue <> jsc$isqi_null THEN
      IF ijle_p^.swap_queue_link.backward_link <> jmv$null_ijl_ordinal THEN
        jmp$get_ijle_p (ijle_p^.swap_queue_link.backward_link, backward_ijle_p);
        backward_ijle_p^.swap_queue_link.forward_link := ijle_p^.swap_queue_link.forward_link;
      ELSE
        jsv$ijl_swap_queue_list [current_queue].forward_link := ijle_p^.swap_queue_link.forward_link;
      IFEND;

      IF ijle_p^.swap_queue_link.forward_link <> jmv$null_ijl_ordinal THEN
        jmp$get_ijle_p (ijle_p^.swap_queue_link.forward_link, forward_ijle_p);
        forward_ijle_p^.swap_queue_link.backward_link := ijle_p^.swap_queue_link.backward_link;
      ELSE
        jsv$ijl_swap_queue_list [current_queue].backward_link := ijle_p^.swap_queue_link.backward_link;
      IFEND;

      jsv$ijl_swap_queue_list [current_queue].count := jsv$ijl_swap_queue_list [current_queue].count - 1;
    IFEND;

    IF jsv$ijl_swap_queue_list [current_queue].backward_link = jmv$null_ijl_ordinal THEN
      IF jsv$ijl_swap_queue_list [current_queue].forward_link <> jmv$null_ijl_ordinal THEN
        mtp$error_stop ('JS - swap queue linkage error.');
      IFEND;
    ELSE
      IF jsv$ijl_swap_queue_list [current_queue].forward_link = jmv$null_ijl_ordinal THEN
        mtp$error_stop ('JS - swap queue linkage error.');
      IFEND;
    IFEND;

{  Add entry to the end of the new queue unless it is the null queue.  If it is the null queue just change
{  the queue id.  Entries in the null queue are not linked.

    IF new_queue <> jsc$isqi_null THEN
      IF last_entry_in_queue <> jmv$null_ijl_ordinal THEN
        jmp$get_ijle_p (last_entry_in_queue, last_ijle_p);
        last_ijle_p^.swap_queue_link.forward_link := ijl_ordinal;
        ijle_p^.swap_queue_link.backward_link := last_entry_in_queue;
      ELSE
        ijle_p^.swap_queue_link.backward_link := jmv$null_ijl_ordinal;
        jsv$ijl_swap_queue_list [new_queue].forward_link := ijl_ordinal;
      IFEND;

      ijle_p^.swap_queue_link.forward_link := jmv$null_ijl_ordinal;
      jsv$ijl_swap_queue_list [new_queue].backward_link := ijl_ordinal;
      jsv$ijl_swap_queue_list [new_queue].count := jsv$ijl_swap_queue_list [new_queue].count + 1;
    IFEND;

{  Check queue links for correctness.

    IF jsv$ijl_swap_queue_list [new_queue].backward_link = jmv$null_ijl_ordinal THEN
      IF jsv$ijl_swap_queue_list [new_queue].forward_link <> jmv$null_ijl_ordinal THEN
        mtp$error_stop ('JS - swap queue linkage error.');
      IFEND;
    ELSE
      IF jsv$ijl_swap_queue_list [new_queue].forward_link = jmv$null_ijl_ordinal THEN
        mtp$error_stop ('JS - swap queue linkage error.');
      IFEND;
    IFEND;

    ijle_p^.swap_queue_link.queue_id := new_queue;

    jsv$relink_swap_q_trace.info [jsv$relink_swap_q_trace.index].rt_current_q_list :=
         jsv$ijl_swap_queue_list [current_queue];
    jsv$relink_swap_q_trace.info [jsv$relink_swap_q_trace.index].rt_new_q_list :=
         jsv$ijl_swap_queue_list [new_queue];
    jsv$relink_swap_q_trace.info [jsv$relink_swap_q_trace.index].rt_new_swap_q_link :=
         ijle_p^.swap_queue_link;

    jsp$clear_relink_lock;
    tmp$clear_lock (jsv$ijl_serial_lock);

  PROCEND jsp$relink_swap_queue;
?? TITLE := 'RESET_SWAPPED_JOB_MM_TABLES', EJECT ??

{
{   The purpose of this procedure is restore the memory manager tables so that the job being swapped
{   in may proceed with execution from the point at which it was interrupted when swapped out.  The
{   page frame table, page table and AST table are updated for the page frames swapped
{   out.  If an asid is reassigned the asid is updated in each task's segment table and the system
{   file table.  The segment table address in each task's exchanges package is also updated.
{


  PROCEDURE reset_swapped_job_mm_tables
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry;
         swapped_job_entry: jmt$swapped_job_entry;
     VAR sfd_p: ^jst$swap_file_descriptor;
     VAR status: syt$monitor_status);


?? NEWTITLE := 'change_asids_in_sfd' ??
?? EJECT ??

{ PURPOSE:
{   This procedure is called whenever an ASID is reassigned during swapin.
{ DESIGN:
{    The procedure does the following:
{    . Scan the rest of the SPD array. Remaining entries that used the old ASID are updated to
{         reflect the new ASID.

    PROCEDURE change_asids_in_sfd
      (    starting_spd_index: 0 .. osc$max_page_frames;
           new_asid: ost$asid;
           new_asti: mmt$ast_index;
           new_aste_p: ^mmt$active_segment_table_entry;
           ijle_p: ^jmt$initiated_job_list_entry;
           changing_jf_asid: boolean);

      VAR
        existing_entry: boolean,
        fde_p: gft$locked_file_desc_entry_p,
        old_asid: ost$asid,
        spd_index: 0 .. osc$max_page_frames;


{  Change the ASIDs in the rest of the SFD for each that used the ASID that was just reassigned.
{  The entries in the SFD prior to the current dont have to be changed since they will never be referenced
{  again.
{  Pages can have their ASID changed more than once; the entry_updated flag helps to differentiate those
{  pages from other pages.  For example, if asid AAAA changes to BBBB, and later BBBB changes to CCCC, the
{  the entry_updated flag differentiates BBBB pages that had been AAAA pages from pages that happened
{  to be using asid BBBB when they swapped out.

      reset_changed_asid := TRUE;
      old_asid := sfd_p^.swapped_page_descriptors [starting_spd_index].pft_entry.sva.asid;
      existing_entry := sfd_p^.swapped_page_descriptors [starting_spd_index].entry_updated;
      IF existing_entry THEN
        trace (jsc$ti_change_asid_again, 1);
      ELSE
        trace (jsc$ti_change_asid, 1);
      IFEND;
      FOR spd_index := starting_spd_index TO UPPERBOUND (sfd_p^.swapped_page_descriptors) DO
        IF (existing_entry = sfd_p^.swapped_page_descriptors [spd_index].entry_updated) AND
              (old_asid = sfd_p^.swapped_page_descriptors [spd_index].pft_entry.sva.asid) THEN
          trace (jsc$ti_change_asid_sfd, 1);
          sfd_p^.swapped_page_descriptors [spd_index].page_table_entry.pageid.asid := new_asid;
          sfd_p^.swapped_page_descriptors [spd_index].pft_entry.sva.asid := new_asid;
          sfd_p^.swapped_page_descriptors [spd_index].pft_entry.aste_p := new_aste_p;
          sfd_p^.swapped_page_descriptors [spd_index].entry_updated := TRUE;
        IFEND;
      FOREND;

      IF (new_aste_p^.sfid.residence <> gfc$tr_system_wait_recovery) AND (NOT changing_jf_asid) THEN
        gfp$mtr_get_locked_fde_p (new_aste_p^.sfid, ijle_p, fde_p);
        fde_p^.asti := new_asti;
      IFEND;

    PROCEND change_asids_in_sfd;
?? OLDTITLE ??
?? EJECT ??

    VAR
      changing_jf_asid: boolean,
      count: integer,
      current_queue_id: mmt$page_frame_queue_id,
      found_sva: boolean,
      existing_pfti: mmt$page_frame_index,
      existing_pfte_p: ^mmt$page_frame_table_entry,
      fde_p: gft$file_desc_entry_p,
      jf_asid: ost$asid,
      jf_asid_changed: boolean,
      jf_aste_p: ^mmt$active_segment_table_entry,
      jf_asti: mmt$ast_index,
      jf_sfid: gft$system_file_identifier,
      live_aste_p: ^mmt$active_segment_table_entry,
      mpt_count: integer,
      mpt_status: mmt$make_pt_entry_status,
      msg: string (70),
      new_asid: ost$asid,
      new_aste_p: ^mmt$active_segment_table_entry,
      new_asti: mmt$ast_index,
      next_pfti: mmt$page_frame_index,
      pfti: mmt$page_frame_index,
      pt_full_status: mmt$pt_full_status,
      pti: integer,
      recovery: boolean,
      reset_changed_asid: boolean,
      spd_index: 0 .. osc$max_page_frames,
      spd_p: ^jst$swapped_page_descriptor;

{ When the job was last swapped out and the old swap file descriptor freed, the IJL.PURGE_MAP_TIMESTAMP
{ was set equal to the value of the free running clock. The page map must be purged if it has not been
{ purged since that time. If the map is NOT purged, references to the SFD may use the OLD page frames
{ that were assigned at the PREVIOUS swapout. Purging of the map has been delayed since it will usually
{ NOT be required at this point since something else will have purged the map.

    IF mmv$multiple_page_maps THEN
       mmp$purge_all_map_proc;
     ELSE
       null_sva := 0;
       #Purge_buffer(osc$purge_all_page_seg_map,null_sva);
    IFEND;



{ The following code will verify the swap file descriptor. The action the system will take
{ upon finding corrupted data in the swap file descriptor depends on the value of the
{ system attribute-HALT_ON_SWAPIN_FAILURE.

    IF sfd_p^.ijl_entry.system_supplied_name <> ijle_p^.system_supplied_name THEN
      IF jsv$halt_on_swapin_failure THEN
        mtp$error_stop ('Bad swap file descriptor data detected.');
      ELSE
        msg := ' Job XXXXXXXXXXXXXXXXXXX is dead. Bad swap data detected.';
        msg (6, 19) := ijle_p^.system_supplied_name;
        dpp$display_error (msg);
        ijle_p^.hung_task_in_job := TRUE;
        IF ijle_p^.queue_file_information.job_abort_disposition = jmc$restart_on_abort THEN
          ijle_p^.queue_file_information.job_recovery_disposition := jmc$restart_on_recovery;
        ELSE { jmc$terminate_on_abort
          ijle_p^.queue_file_information.job_recovery_disposition := jmc$terminate_on_recovery;
        IFEND;
        status.normal := FALSE;
        status.condition := jse$bad_swap_file_data_detected;
        RETURN;
      IFEND;
    IFEND;

    current_queue_id := LOWERVALUE (mmt$job_page_queue_index);
    pfti := ijle_p^.job_page_queue_list [current_queue_id].link.bkw;
    spd_index := LOWERBOUND (sfd_p^.swapped_page_descriptors);

{ If this is the first swapin since a system recovery, the old AST entry cannot be referenced since
{ the AST may have moved. Set a flag for subsequent use to indicate if this is a recovery swapin.

    recovery := jmc$dsw_job_recovery IN ijle_p^.delayed_swapin_work;
    jf_asid_changed := FALSE;
    reset_changed_asid := FALSE;

{ Restore the SFID in the ASTE for the job fixed segment.  (The sfid was unknown when the aste was assigned
{ in claim_pages_for_swapin.  Pick up the sfid from the first page of the swapped page descripto, which is
{ a job fixed page.  The job fixed sfid will not change.)

    jf_asid := ijle_p^.job_fixed_asid;
    mmp$asti (jf_asid, jf_asti);
    jf_aste_p := ^mmv$ast_p^ [jf_asti];
    jf_sfid := sfd_p^.swapped_page_descriptors [spd_index].ast_entry.sfid;
    jf_aste_p^.sfid := jf_sfid;

{  If the ASID of job fixed has changed, update the ASIDs in the swap file descriptor.
{  NOTE:  The swapped page descriptor entry_updated field was set to TRUE by mmp$build_lock_rma_list
{  for all job fixed pages.  This was done to differentiate job fixed pages from other fixed pages.
{  When scanning each page in the swap file descriptor to see if the ASID needs to be reclaimed/
{  reassigned, nothing will need to be done for job fixed pages, because they have been updated
{  here, if necessary.

    IF (ijle_p^.job_fixed_asid <> sfd_p^.swapped_page_descriptors [spd_index].pft_entry.sva.asid) OR
          (recovery) THEN
      change_asids_in_sfd (spd_index, jf_asid, jf_asti, jf_aste_p, ijle_p, TRUE);
      jf_asid_changed := TRUE;
    IFEND;


{ Loop through each page in the swap file descriptor.
{ Reclaim the old ASID if it is still available (may still be assigned) or assign a new ASID
{ if the old ASID has been reused for something else. Make PT entries for each page.

    WHILE pfti <> 0 DO
      next_pfti := mmv$pft_p^ [pfti].link.bkw;
      spd_p := ^sfd_p^.swapped_page_descriptors [spd_index];
      live_aste_p := spd_p^.pft_entry.aste_p;

{   If the SPD entry has already been updated (as a result of reassigning the ASID and updating the SPD
{   array), skip the following blocks of code that assign/reclaim the AST entry.
{   Note: 'entry_updated' is reset by mmp$build_lock_rma_list on swapout.

      IF spd_p^.entry_updated THEN

{nothing needs to be done

        trace (jsc$ti_rmmt_no_change, 1);

{   If the page belongs to a permanent file the ASID can be reclaimed only if the AST entry is still
{   assigned to the same SFID. (AST is not actually reclaimed - its still assigned)
{   If the AST is not still assigned, check with DM to see if another ASID has been assigned.
{   If this is a recovery swapin, throw the page away unless it's been modified; if the page has been
{   modified, set the AST entry to indicate the page is awaiting recovery.
{
{   NOTE:  After a new asid is assigned, the ast entry information is copied from the swapped page
{   descriptor ast entry.  Because the spd ast entry contains stale information with respect to
{   pages_in_memory and pft_link, those fields must be zeroed out in the new entry.  (This occurs
{   after each call to mmp$assign_asid.

      ELSEIF (spd_p^.ast_entry.sfid.residence = gfc$tr_system) THEN
        trace (jsc$ti_rmmt_pf, 1);
        IF recovery THEN
          IF spd_p^.page_table_entry.m THEN
            trace (jsc$ti_rmmt_pf_rec_ptm, 1);
            mmp$assign_asid (new_asid, new_asti, new_aste_p);
            spd_p^.ast_entry.sfid.residence := gfc$tr_system_wait_recovery;
            new_aste_p^ := spd_p^.ast_entry;
            new_aste_p^.pages_in_memory := 0;
            new_aste_p^.pft_link.bkw := 0;
            new_aste_p^.pft_link.fwd := 0;
            change_asids_in_sfd (spd_index, new_asid, new_asti, new_aste_p, ijle_p, FALSE);
          ELSE
            trace (jsc$ti_rmmt_pf_rec_ptu, 1);
            mmp$relink_page_frame (pfti, mmc$pq_free);
            pfti := 0; {prevent making PT entry}
          IFEND;
        ELSEIF (spd_p^.ast_entry.sfid <> live_aste_p^.sfid) OR NOT live_aste_p^.in_use THEN
          gfp$mtr_get_fde_p (spd_p^.ast_entry.sfid, ijle_p, fde_p);
          new_asti := fde_p^.asti;
          IF new_asti = 0 THEN
            trace (jsc$ti_rmmt_pf_assign_asid, 1);
            mmp$assign_asid (new_asid, new_asti, new_aste_p);
            new_aste_p^ := spd_p^.ast_entry;
            new_aste_p^.pages_in_memory := 0;
            new_aste_p^.pft_link.bkw := 0;
            new_aste_p^.pft_link.fwd := 0;
          ELSE
            trace (jsc$ti_rmmt_pf_reuse_asid, 1);
            mmp$asid (new_asti, new_asid);
            new_aste_p := ^mmv$ast_p^ [new_asti];
          IFEND;
          change_asids_in_sfd (spd_index, new_asid, new_asti, new_aste_p, ijle_p, FALSE);
        IFEND;

{   If the segment is a local file or transient segment, the ASID can NOT be reclaimed if some other job
{   has used the AST entry since the current job used it OR the AST entry has already been assigned to be
{   used for another segment of current job.

      ELSEIF recovery OR (live_aste_p^.ijl_ordinal <> ijl_ordinal) OR
            (live_aste_p^.in_use AND (live_aste_p^.sfid <> spd_p^.ast_entry.sfid)) THEN
        trace (jsc$ti_rmmt_lf_assign_asid, 1);
        mmp$assign_asid (new_asid, new_asti, new_aste_p);
        new_aste_p^ := spd_p^.ast_entry;
        new_aste_p^.pages_in_memory := 0;
        new_aste_p^.pft_link.bkw := 0;
        new_aste_p^.pft_link.fwd := 0;
        change_asids_in_sfd (spd_index, new_asid, new_asti, new_aste_p, ijle_p, FALSE);

{   The same ASID can be used. If the AST entry is not currently assigned it must be reclaimed. The AST
{   might still be assigned if pages of the segment remained in the AVAIL queue while the job was swapped out.
{   Preserve the live ast entry pages_in_memory and pft_link fields.  (The spd ast_entry contains stale
{   information in those two fields.)

      ELSEIF NOT live_aste_p^.in_use THEN
        trace (jsc$ti_rmmt_lf_reuse_asid, 1);
        mmp$assign_specific_asid (live_aste_p);
        spd_p^.ast_entry.pages_in_memory := live_aste_p^.pages_in_memory;
        spd_p^.ast_entry.pft_link.bkw := live_aste_p^.pft_link.bkw;
        spd_p^.ast_entry.pft_link.fwd := live_aste_p^.pft_link.fwd;
        live_aste_p^ := spd_p^.ast_entry;
      IFEND;



{  Create and reserve the page table entry. (If the page has been discarded, PFTI is zero.)

      IF pfti <> 0 THEN
        mpt_count := 0;
        REPEAT

{ Zero out the segment link in the swapped page descriptor pft_entry;  the links in the entry are
{ left over from when the job was running before.  (Non-zero links in make_pt_entry will cause a failure.)

          spd_p^.pft_entry.segment_link.bkw := 0;
          spd_p^.pft_entry.segment_link.fwd := 0;
          mmp$make_pt_entry (spd_p^.pft_entry.sva, pfti, spd_p^.pft_entry.aste_p, ^spd_p^.pft_entry,
                mpt_status);

{    If the page table entry was made sucessfully, restore the PFT entry and the page table V C M bits.
{    Zero out the pft.active_io_count in case PFTS io was active when the swapped page descriptor
{    information was captured.  Clear the flawed bit in case the old page was flawed.

          CASE mpt_status OF
          = mmc$mpt_done = { Normal return
            trace (jsc$ti_rmmt_pt_done, 1);
            spd_p^.pft_entry.link := mmv$pft_p^ [pfti].link;
            mmv$pft_p^ [pfti] := spd_p^.pft_entry;
            mmv$pft_p^ [pfti].task_queue.head := 0;
            mmv$pft_p^ [pfti].task_queue.tail := 0;
            mmv$pft_p^ [pfti].active_io_count := 0;
            mmv$pft_p^ [pfti].flawed := FALSE;
            pti := spd_p^.pft_entry.pti;
            mmv$pt_p^ [pti].u := spd_p^.page_table_entry.u;
            mmv$pt_p^ [pti].m := spd_p^.page_table_entry.m;
            mmv$pt_p^ [pti].v := spd_p^.page_table_entry.v;

{    If a page table full reject occurred, call MM to process the PT full condition. If still not successful
{    abort the swappin and free the resources assigned to the job. If page table full processing was
{    successful and the ASID was changed, update the CHANGED ASID list.

          = mmc$mpt_page_table_full =
            changing_jf_asid := (spd_p^.pft_entry.sva.asid = jf_asid);
            mmp$process_page_table_full (spd_p^.pft_entry.sva, new_asid, new_asti, new_aste_p,
                  pt_full_status);
            trace (jsc$ti_rmmt_pt_full, 1);
            mpt_count := mpt_count + 1;
            IF (pt_full_status = mmc$pfs_failed) OR (mpt_count > 20) THEN
              IF spd_p^.pft_entry.aste_p^.pages_in_memory = 0 THEN
                mmp$free_asid (spd_p^.pft_entry.sva.asid, spd_p^.pft_entry.aste_p);
              IFEND;
              trace (jsc$ti_rmmt_pt_full_failed, 1);
              free_swapped_jobs_mm_resources (ijle_p, ijl_ordinal, jmc$iss_swapin_io_complete);
              mtp$set_status_abnormal ('JS', jse$pt_full_on_swap_in, status);
              RETURN;
            ELSEIF pt_full_status = mmc$pfs_input_asid_reassigned THEN
              trace (jsc$ti_rmmt_pt_full_succ, 1);
              change_asids_in_sfd (spd_index, new_asid, new_asti, new_aste_p, ijle_p, changing_jf_asid);
              IF changing_jf_asid THEN
                jf_asid_changed := TRUE;
                jf_asid := new_asid;
                jf_asti := new_asti;
                trace (jsc$ti_pt_full_reassign_jf, 1);
              IFEND;
            IFEND;

{    If an entry already exists, it better belong to a permanent file that is now in
{    a shared queue or to a local file in one of the invalid page table queues or the
{    io error while swapped queue.

          = mmc$mpt_page_already_exists =
            #HASH_SVA (spd_p^.pft_entry.sva, pti, count, found_sva);
            IF NOT found_sva THEN
              mtp$error_stop ('JS - cannot find existing job_shared page.');
            IFEND;
            existing_pfti := mmv$pt_p^ [pti].rma * 512 DIV osv$page_size;
            existing_pfte_p := ^mmv$pft_p^ [existing_pfti];

{  IF a page in the jws had io active when memory was freed, it was put into the available modified
{  queue.  If IO has not yet completed, the page is still there.  We will delete the new page coming in
{  incase the IO completes with an error and we need to reset the modified bit.  IO completed normally
{  if the existing page is in the available queue and we can just delete it.  If an io error occurred,
{  the existing page is in the swapped io error queue.  We will delete the new page coming in and
{  reclaim the io error page later in swapin.

            IF (existing_pfte_p^.aste_p^.sfid.residence = gfc$tr_job) THEN
              IF (existing_pfte_p^.queue_id = mmc$pq_avail) THEN
                trace (jsc$ti_rmmt_pte_exists_a, 1);
                mmp$delete_pt_entry (existing_pfti, TRUE);
                mmp$relink_page_frame (existing_pfti, mmc$pq_free);
              ELSEIF ((existing_pfte_p^.queue_id = mmc$pq_swapped_io_error) OR
                    (existing_pfte_p^.queue_id = mmc$pq_avail_modified)) THEN
                IF (existing_pfte_p^.queue_id = mmc$pq_swapped_io_error) THEN
                  trace (jsc$ti_rmmt_pte_exists_err, 1);
                ELSE
                  trace (jsc$ti_rmmt_pte_exists_am, 1);
                IFEND;
                mmp$relink_page_frame (pfti, mmc$pq_free);
                mpt_status := mmc$mpt_done;
              ELSE
                mtp$error_stop ('JS - Page table entry already exists on swap in (reset tables).');
              IFEND;
            ELSEIF (existing_pfte_p^.aste_p^.queue_id >= mmc$pq_shared_first) AND
                  (existing_pfte_p^.aste_p^.queue_id <= mmc$pq_shared_last) THEN
              trace (jsc$ti_rmmt_pte_exists_pf, 1);
              mmp$relink_page_frame (pfti, mmc$pq_free);
              mpt_status := mmc$mpt_done;
            ELSE
              mtp$error_stop ('JS - Page table entry already exists on swap in (reset tables).');
            IFEND;
          CASEND;

        UNTIL mpt_status = mmc$mpt_done;
      IFEND;

{  Get next page frame index.

      WHILE ((next_pfti = 0) OR (next_pfti = ijle_p^.swap_io_control.swap_file_descriptor_pfti)) AND
            (current_queue_id < UPPERVALUE (mmt$job_page_queue_index)) DO
        current_queue_id := SUCC (current_queue_id);
        next_pfti := ijle_p^.job_page_queue_list [current_queue_id].link.bkw;
      WHILEND;

      pfti := next_pfti;

      spd_index := spd_index + 1;

    WHILEND;

    IF jf_asid_changed THEN
      gfp$mtr_get_locked_fde_p (jf_sfid, ijle_p, fde_p);
      fde_p^.asti := jf_asti;
    IFEND;

    reset_sdt_xcb_tables (ijl_ordinal, ijle_p, TRUE, reset_changed_asid);

  PROCEND reset_swapped_job_mm_tables;
?? TITLE := 'RESET_SDT_XCB_TABLES', EJECT ??

{
{ PURPOSE:
{   This procedure is called at the end of swapin to reset XCB and SDT information that may
{   have changed while the job was swapped out.
{ DESIGN:
{   The segment tables RMAs are fixed, if necessary.  If any ASIDs changed while the job was
{   swapped out, the old ASIDs must be zeroed out in the segment tables of all tasks of the job.
{   On the next page fault for a page of a segment with a zeroed out ASID, the ASID will be
{   obtained from the FDE.

  PROCEDURE reset_sdt_xcb_tables
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry;
         reset_sdt_addresses: boolean;
         reset_changed_asid: boolean);

    VAR
      asid: ost$asid,
      aste_p: ^mmt$active_segment_table_entry,
      asti: mmt$ast_index,
      fde_p: gft$locked_file_desc_entry_p,
      fix_asid: boolean,
      global_asids_changed: boolean,
      jf_asti: mmt$ast_index,
      job_asids_changed: boolean,
      max_segnum: integer,
      max_segnum_to_update: integer,
      recovery: boolean,
      rma: integer,
      segment_number: ost$segment,
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      system_job_monitor_sdt_p: mmt$max_sdt_p,
      system_job_monitor_sdtx_p: mmt$max_sdtx_p,
      template_asids_changed: boolean,
      timestamp: integer,
      xcb_p: ^ost$execution_control_block,
      xcb_state: tmt$find_next_xcb_state;

    mmp$get_max_sdt_sdtx_pointer (mtv$system_job_monitor_xcb_p, system_job_monitor_sdt_p,
          system_job_monitor_sdtx_p);

    recovery := jmc$dsw_job_recovery IN ijle_p^.delayed_swapin_work;

{  If this is the first swapin of this job since job recovery occurred, device management tables
{  need to be recovered.

    IF recovery THEN
      trace (jsc$ti_rxcb_recovery, 1);
      recover_job_dm_tables (ijle_p, ijl_ordinal, system_job_monitor_sdtx_p);
    IFEND;

{  Determine the kinds of updates that have to be made to the ASIDs in the segment tables of tasks in the
{  job. GLOBAL_ASIDS_HAVE_CHANGED means an ASID of a shared/sharable segment has changed since the job was
{  was swapped. JOB_ASIDS_HAVE_CHANGED means a job local ASID was changed on swapin OR a job local ASID that
{  belonged to the job was reassigned while the job was swapped out but no pages of the segment were in
{  in the swap file.

    timestamp := ijle_p^.swap_data.asid_reassigned_timestamp;
    global_asids_changed := (mmv$time_changed_global_asid > timestamp) OR
          (jmc$dsw_job_shared_asid_changed IN ijle_p^.delayed_swapin_work);
    job_asids_changed := (reset_changed_asid) OR (jmc$dsw_job_asid_changed IN ijle_p^.delayed_swapin_work);
    template_asids_changed := mmv$time_changed_template_asid > timestamp;
    IF template_asids_changed THEN
      trace (jsc$ti_rxcb_temp_asids_changed, 1);
    IFEND;
    IF job_asids_changed THEN
      trace (jsc$ti_rxcb_job_asids_changed, 1);
    IFEND;
    IF global_asids_changed THEN
      trace (jsc$ti_rxcb_glob_asids_changed, 1);
    IFEND;

{ Determine the maximum segment number that may have to be updated. If ONLY template ASIDs have changed
{ the max segnum is determined by the largest template segment number in use. Otherwise all segments have
{ to be examined.

    IF global_asids_changed OR job_asids_changed THEN
      max_segnum_to_update := 4096;
    ELSEIF template_asids_changed THEN
      max_segnum_to_update := mmv$max_template_segment_number;
    ELSE
      max_segnum_to_update := 0;
    IFEND;

{ Update the tables in job fixed. Fix the segment table RMA in each XCB. Update the ASIDS in
{ the segment tables if necessary.

    IF (max_segnum_to_update > 0) OR reset_sdt_addresses THEN
      tmp$find_next_xcb (tmc$fnx_swapping_job, ijle_p, ijl_ordinal, xcb_state, xcb_p);

      WHILE xcb_p <> NIL DO
        trace (jsc$ti_rxcb_fix_xcb_sdt, 1);
        mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);

        IF reset_sdt_addresses THEN
          i#real_memory_address (sdt_p, rma);
          xcb_p^.xp.segment_table_address_1 := rma DIV 10000(16);
          xcb_p^.xp.segment_table_address_2 := rma MOD 10000(16);
        IFEND;

        IF max_segnum_to_update > 0 THEN
          trace (jsc$ti_rxcb_fix_asids, 1);
          max_segnum := max_segnum_to_update;
          IF max_segnum = 4096 THEN
            max_segnum := xcb_p^.xp.segment_table_length;
          IFEND;
          FOR segment_number := 0 TO max_segnum DO
            IF (sdt_p^.st [segment_number].ste.vl <> osc$vl_invalid_entry) AND
                  (sdt_p^.st [segment_number].ste.asid <> 0) THEN

              IF NOT recovery THEN
                aste_p := ^mmv$ast_p^ [sdt_p^.st [segment_number].asti];
              IFEND;
              IF recovery OR
                    ((NOT aste_p^.in_use) OR (aste_p^.sfid <> sdtx_p^.sdtx_table [segment_number].sfid) OR
                    ((aste_p^.sfid.residence = gfc$tr_job) AND (ijl_ordinal <> aste_p^.ijl_ordinal))) THEN

                IF (sdtx_p^.sdtx_table [segment_number].open_validating_ring_number = 0) AND
                      (sdtx_p^.sdtx_table [segment_number].sfid = system_job_monitor_sdtx_p^.
                      sdtx_table [segment_number].sfid) THEN
                  sdt_p^.st [segment_number] := system_job_monitor_sdt_p^.st [segment_number];
                  trace (jsc$ti_rxcb_fix_templ_asid, 1);

                ELSEIF segment_number = osc$segnum_job_fixed_heap THEN
                  sdt_p^.st [segment_number].ste.asid := ijle_p^.job_fixed_asid;
                  mmp$asti (ijle_p^.job_fixed_asid, jf_asti);
                  sdt_p^.st [segment_number].asti := jf_asti;
                  trace (jsc$ti_rxcb_fix_jf_asid, 1);

                ELSEIF (sdtx_p^.sdtx_table [segment_number].sfid.residence = gfc$tr_system) OR
                      (sdtx_p^.sdtx_table [segment_number].sfid.residence = gfc$tr_job) THEN
                  gfp$mtr_get_locked_fde_p (sdtx_p^.sdtx_table [segment_number].sfid, ijle_p, fde_p);
                  IF (sdtx_p^.sdtx_table [segment_number].sfid.residence = gfc$tr_job) THEN
                    mmp$get_verify_asti_in_fde (fde_p, sdtx_p^.sdtx_table [segment_number].sfid, ijl_ordinal,
                          asti);
                  ELSE
                    asti := fde_p^.asti;
                  IFEND;
                  IF asti <> 0 THEN
                    mmp$asid (asti, asid);
                    sdt_p^.st [segment_number].ste.asid := asid;
                    sdt_p^.st [segment_number].asti := asti;
                    trace (jsc$ti_rxcb_fix_job_asid, 1);
                  ELSE
                    sdt_p^.st [segment_number].ste.asid := 0;
                    trace (jsc$ti_rxcb_zero_job_asid, 1);
                  IFEND;
                ELSE
                  sdt_p^.st [segment_number].ste.asid := 0;
                  trace (jsc$ti_rxcb_zero_asid, 1);
                IFEND;
              IFEND;

            IFEND;
          FOREND;
        IFEND;

        tmp$find_next_xcb (tmc$fnx_continue, NIL, jmv$null_ijl_ordinal, xcb_state, xcb_p);

      WHILEND;
    IFEND;

    IF jmc$dsw_adjust_cpu_selections IN ijle_p^.delayed_swapin_work THEN
      update_processor_selections (ijle_p, ijl_ordinal);
    IFEND;

{ Debug lists need to be updated on the first swapin for job recovery.  Update the debug lists in each XCB.

    IF jmc$dsw_update_debug_lists IN ijle_p^.delayed_swapin_work THEN
      ijle_p^.system_breakpoint_selected := FALSE;
      tmp$find_next_xcb (tmc$fnx_swapping_job, ijle_p, ijl_ordinal, xcb_state, xcb_p);
      WHILE xcb_p <> NIL DO
        tmp$set_up_debug_registers (xcb_p^.global_task_id.index, ijle_p, xcb_p);
        tmp$find_next_xcb (tmc$fnx_continue, NIL, jmv$null_ijl_ordinal, xcb_state, xcb_p);
      WHILEND;
    IFEND;

    IF jmc$dsw_update_server_files IN ijle_p^.delayed_swapin_work THEN
      update_server_files (ijle_p, ijl_ordinal);
    IFEND;

{  The swap file descriptor has not been freed if we are swapping in from disk.

    IF ijle_p^.sfd_p <> NIL THEN
      free_swap_file_descriptor (ijle_p, ijl_ordinal);
    IFEND;

{ Swap status is advanced to executing.

    complete_swapin (ijl_ordinal, ijle_p, ijle_p^.swap_data.swapped_job_entry.available_modified_page_count);

  PROCEND reset_sdt_xcb_tables;

?? TITLE := 'RESTART_IDLED_TASKS', EJECT ??

  PROCEDURE [INLINE] restart_idled_tasks
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry);

{
{      The purpose of this procedure is to restart the tasks that have been idled for swapping.
{  There are some timing considerations with multiple CPUs and the dispatcher.  At the time
{  this procedure is called the job is effectively swapped in.  The job's swap_status is set to
{  indicate job executing.  The job is also relinked into the null swap queue so that it can
{  be swapped out again if it goes into long wait before finishing the final cleanup for
{  swapping in.
{  It is not necessary to set the PTL lock to change entry status, because the transition will
{  not cause the swapped job count to change.  The job cannot swap out asynchronously on another
{  processor in long wait because the tasks have not been restarted until after the entry status
{  change.
{  The PTL lock must be set however to prevent the other processor from relinking the job into
{  the swapping queue as a result of a monitor swap in.  It is possible in a dual state system
{  for the entry status to be changed to swapin_in_progress and advance swap to run and get
{  here before the job is linked to the swapping queue.

    tmp$set_lock (tmv$ptl_lock);
    jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_null);
    tmp$clear_lock (tmv$ptl_lock);
    advance_swap_state (ijle_p, jmc$iss_executing);
    jmp$change_ijl_entry_status (ijle_p, jmc$ies_job_in_memory);

{  Update counts if the job has reserved memory through the mmp$assign_pages request

    IF ijle_p^.memory_reserve_request.requested_page_count > 0 THEN
      IF (mmv$reassignable_page_frames.now - mmv$aggressive_aging_level_2) >
            ijle_p^.memory_reserve_request.requested_page_count THEN
        ijle_p^.memory_reserve_request.reserved_page_count :=
              ijle_p^.memory_reserve_request.reserved_page_count +
              ijle_p^.memory_reserve_request.requested_page_count;
        mmv$reserved_page_count := mmv$reserved_page_count +
              ijle_p^.memory_reserve_request.requested_page_count;
      ELSE
        trace (jsc$ti_reserve_memory_failed, 1);
      IFEND;
      ijle_p^.memory_reserve_request.requested_page_count := 0;
    IFEND;

{ If something in the job/task environment has changed, update it.

    IF jmc$dsw_update_job_task_enviro IN ijle_p^.delayed_swapin_work THEN
      tmp$update_job_task_environment (ijle_p, ijl_ordinal, tmc$fnx_swapping_job);
    IFEND;

{ While the job was swapped, if writes to local files completed with an io error, the pages
{ were put into the swapped io error queue.  Reclaim those pages.

    IF jmc$dsw_io_error_while_swapped IN ijle_p^.delayed_swapin_work THEN
      reclaim_io_error_pages (ijl_ordinal, ijle_p);
    IFEND;

    IF syv$perf_keypoints_enabled.swapping_stack_trace THEN
      tmp$monitor_flag_job_tasks (syc$mf_for_keypoint_traceback, ijle_p);
    IFEND;


{  The XCB of this job can now be modified.
{  This job is a candidate for being swapped out again.

    tmp$restart_idled_tasks (ijle_p^.ajl_ordinal);

{ While the job was swapped, if a segment that has pages in the working set changed so its
{ pages are now in the shared queue, remove the pages from the jws

    IF jmc$dsw_job_shared_asid_changed IN ijle_p^.delayed_swapin_work THEN
      mmp$remove_swapped_shared_pages (ijle_p);
    IFEND;

  PROCEND restart_idled_tasks;

?? TITLE := 'SELECT_BEST_CANDIDATE', EJECT ??

  PROCEDURE select_best_candidate
    (    first_ijl_queue_link: jmt$ijl_ordinal;
         swap_resident_queue: boolean;
     VAR selected_jobs_ijl_ordinal: jmt$ijl_ordinal;
     VAR selected_jobs_ijle_p: ^jmt$initiated_job_list_entry);

{ The purpose of this procedure is to select a job from the swap queue initiated by the
{ specified ijl queue link.  The job is selected that most exceeds think time or has the
{ longest estimated ready time.
{ If a job from the long wait queue is being selected, the long_wait_expire_time and the
{ priority of the job are considered.  The job will be selected only if pages are needed
{ for other jobs of equal or higher priority or the long_wait_expire_time has elapsed.

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      ijl_ordinal: jmt$ijl_ordinal,
      max_ijle_p: ^jmt$initiated_job_list_entry,
      max_ijlo: jmt$ijl_ordinal,
      min_ijle_p: ^jmt$initiated_job_list_entry,
      min_ijlo: jmt$ijl_ordinal,
      max_estimated_ready_time: integer,
      min_estimated_ready_time: integer;

    min_ijlo := jmv$null_ijl_ordinal;
    max_ijlo := jmv$null_ijl_ordinal;
    max_ijle_p := NIL;
    max_estimated_ready_time := 0;
    min_estimated_ready_time := 0ffffffffffff(16);
    ijl_ordinal := first_ijl_queue_link;

    REPEAT
      jmp$get_ijle_p (ijl_ordinal, ijle_p);
      IF swap_resident_queue OR ((#FREE_RUNNING_CLOCK (0) > ijle_p^.swap_data.long_wait_expire_time) OR
            ((mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon) <=
            jmv$long_wait_swap_threshold [ijle_p^.scheduling_dispatching_priority])) THEN
        IF ijle_p^.estimated_ready_time > max_estimated_ready_time THEN
          max_estimated_ready_time := ijle_p^.estimated_ready_time;
          max_ijlo := ijl_ordinal;
          max_ijle_p := ijle_p;
        IFEND;
        IF ijle_p^.estimated_ready_time < min_estimated_ready_time THEN
          min_estimated_ready_time := ijle_p^.estimated_ready_time;
          min_ijlo := ijl_ordinal;
          min_ijle_p := ijle_p;
        IFEND;
      IFEND;
      ijl_ordinal := ijle_p^.swap_queue_link.forward_link;
    UNTIL ijl_ordinal = jmv$null_ijl_ordinal;

{ If there is no candidate because of the long_wait_expire_time, both min_ijlo and max_ijlo are
{ null.  If there is any candidate, both min_ijlo and max_ijlo are non-null.  If a candidate
{ (min_ijlo) has exceeded THINK_EXPIRATION_TIME, select that candidate; otherwise select the
{ candidate that has the longest estimated ready time.

    IF (min_ijlo <> jmv$null_ijl_ordinal) AND ((#FREE_RUNNING_CLOCK (0) - min_estimated_ready_time) >
          jsv$think_expiration_time) THEN
      selected_jobs_ijl_ordinal := min_ijlo;
      selected_jobs_ijle_p := min_ijle_p;
    ELSE
      selected_jobs_ijl_ordinal := max_ijlo;
      selected_jobs_ijle_p := max_ijle_p;
    IFEND;

  PROCEND select_best_candidate;

?? TITLE := 'SET_SWAPPING_EVENT', EJECT ??

  PROCEDURE [INLINE] set_swapping_event
    (    event_time: jst$swapping_event);

{
{     This procedure sets up the flags so that mtm$monitor_interrupt_handler will recall
{ jsp$advance_swap immediately for swapping activity or later for polling purposes.
{

    VAR
      cst_p: ^ost$cpu_state_table;


    jsv$time_to_call_job_swapper := #FREE_RUNNING_CLOCK (0) + event_time;

    IF event_time = jsc$se_immediate THEN
      mtp$cst_p (cst_p);
      cst_p^.dispatch_control.asynchronous_interrupts_pending := TRUE;
      osv$time_to_check_asyn := 0;
    IFEND;

  PROCEND set_swapping_event;
?? TITLE := 'DIRECTION_CHANGED_TO_IN', EJECT ??

  PROCEDURE direction_changed_to_in
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry);

{
{     The purpose of this procedure is to swapin a job that is currently
{  being swapped out.
{

    VAR
      swap_status: jmt$ijl_swap_status;

    swap_status := ijle_p^.swap_status;

    IF swap_status = jmc$iss_idle_tasks_initiated THEN
      trace (jsc$ti_sif_idle_tasks_init, 1);
      restart_idled_tasks (ijl_ordinal, ijle_p);
      ijle_p^.next_swap_status := jmc$iss_null;

      ?IF debug = TRUE THEN
        IF syv$allow_jr_test THEN
          IF syc$tjr_mtr_rit IN syv$test_jr_system THEN
            mtp$error_stop ('JOB RECOVERY TEST');
          IFEND;
        IFEND;
      ?IFEND
    ELSEIF (swap_status = jmc$iss_job_allocate_swap_file) OR
          (swap_status = jmc$iss_wait_allocate_swap_file) OR (swap_status = jmc$iss_wait_job_io_complete) OR
          (swap_status = jmc$iss_wait_allocate_sfd) THEN
      trace (jsc$ti_sif_wait_state, 1);
      IF swap_status = jmc$iss_wait_allocate_sfd THEN
        jsv$pages_needed_for_sfd := 0;
        trace (jsc$ti_zero_out_pages_for_sfd_1, 1);
      IFEND;
      ijle_p^.next_swap_status := jmc$iss_null;
      swapin_before_io (ijl_ordinal, ijle_p);
      ?IF debug = TRUE THEN
        IF syv$allow_jr_test THEN
          IF syc$tjr_mtr_mamtam IN syv$test_jr_system THEN
            mtp$error_stop ('JOB RECOVERY TEST');
          IFEND;
        IFEND;
      ?IFEND

    ELSEIF (swap_status = jmc$iss_swapout_io_initiated) OR (swap_status = jmc$iss_wait_swapout_io_init) THEN
      trace (jsc$ti_sif_swapout_io_init, 1);
      swapin_after_io (ijl_ordinal, ijle_p);
    ELSE
      mtp$error_stop ('JS - inconsistant swap status on swap direction change.');
    IFEND;

  PROCEND direction_changed_to_in;
?? TITLE := 'SWAPIN_BEFORE_IO', EJECT ??

  PROCEDURE swapin_before_io
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      ajl_ordinal: jmt$ajl_ordinal,
      status: syt$monitor_status;

    jmp$assign_ajl_entry (ijle_p^.job_fixed_asid, ijl_ordinal, jmc$swapping_ajl, FALSE {must assign} ,
          ajl_ordinal, status);
    IF NOT status.normal THEN
      trace (jsc$ti_no_ajlo_swapin_before_io, 1);
      IF (ijle_p^.swap_status = jmc$iss_wait_job_io_complete) OR
            (ijle_p^.swap_status = jmc$iss_wait_allocate_sfd) THEN
        mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon -
              ijle_p^.swap_data.swapped_job_page_count + ijle_p^.job_fixed_contiguous_pages;
        mmv$reassignable_page_frames.swapout_io_not_initiated :=
              mmv$reassignable_page_frames.swapout_io_not_initiated +
              ijle_p^.swap_data.swapped_job_page_count - ijle_p^.job_fixed_contiguous_pages;
      IFEND;
      advance_swap_state (ijle_p, jmc$iss_swapped_no_io);
      jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapped_io_not_init);
      jmp$reset_job_to_swapped_out (ijl_ordinal);
      RETURN;
    IFEND;

    IF syv$perf_keypoints_enabled.swapping_keypoints THEN
      kt.s := ijle_p^.system_supplied_name (16, 4);
      #KEYPOINT (osk$performance, osk$m * kt.f1, ptk$swapin_job_name_1);
      #KEYPOINT (osk$performance, osk$m * ((kt.f2 * 256) + ajl_ordinal), ptk$swapin_job_name_2);
    IFEND;

    IF (ijle_p^.swap_status <= jmc$iss_allocate_swap_file) THEN
      mmv$reassignable_page_frames.swapout_io_not_initiated :=
            mmv$reassignable_page_frames.swapout_io_not_initiated - ijle_p^.swap_data.swapped_job_page_count +
            ijle_p^.job_fixed_contiguous_pages;
    ELSEIF (ijle_p^.swap_status = jmc$iss_wait_job_io_complete) OR
          (ijle_p^.swap_status = jmc$iss_wait_allocate_sfd) THEN
      mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon -
            ijle_p^.swap_data.swapped_job_page_count + ijle_p^.job_fixed_contiguous_pages;
    IFEND;

{ Swap status is advanced to executing.

    complete_swapin (ijl_ordinal, ijle_p, ijle_p^.swap_data.swapped_job_entry.available_modified_page_count);

  PROCEND swapin_before_io;
?? TITLE := 'SWAPIN_AFTER_IO', EJECT ??

  PROCEDURE swapin_after_io
    (    ijl_ordinal: jmt$ijl_ordinal;
         ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      ajl_ordinal: jmt$ajl_ordinal,
      status: syt$monitor_status,
      update_segnum_sfd_p: cybil_pointer_trick;

    jmp$assign_ajl_entry (ijle_p^.job_fixed_asid, ijl_ordinal, jmc$swapping_ajl, FALSE {must assign} ,
          ajl_ordinal, status);
    IF NOT status.normal THEN
      trace (jsc$ti_no_ajlo_swapin_after_io, 1);
      IF (ijle_p^.swap_status = jmc$iss_swapped_io_cannot_init) THEN
        mmv$reassignable_page_frames.swapout_io_cannot_initiate :=
              mmv$reassignable_page_frames.swapout_io_cannot_initiate +
              ijle_p^.swap_data.swapped_job_page_count - ijle_p^.job_fixed_contiguous_pages;
        jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapped_io_cannot_init);
      ELSEIF (ijle_p^.swap_status = jmc$iss_swapped_io_complete) THEN
        mmv$reassignable_page_frames.now := mmv$reassignable_page_frames.now +
              ijle_p^.swap_data.swapped_job_page_count - ijle_p^.job_fixed_contiguous_pages;
        jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapped_io_completed);
      ELSEIF (ijle_p^.swap_status = jmc$iss_swapout_io_initiated) OR
            (ijle_p^.swap_status = jmc$iss_wait_swapout_io_init) THEN

{ Do nothing. Just need to reset job to swapped out.  Should only be here if called from
{ direction_changed_to_in.

      ELSE
        mtp$error_stop ('BAD SWAP STATUS-SWAPIN AFTER IO');
      IFEND;
      jmp$reset_job_to_swapped_out (ijl_ordinal);
      RETURN;

    ELSEIF (ijle_p^.swap_status = jmc$iss_swapout_io_initiated) OR
          (ijle_p^.swap_status = jmc$iss_wait_swapout_io_init) THEN
      ijle_p^.notify_swapper_when_io_complete := FALSE;
      update_segnum_sfd_p.sfd_p :=ijle_p^.sfd_p;
      update_segnum_sfd_p.pva.seg := ajl_ordinal + mtc$job_fixed_segment;
      ijle_p^.sfd_p := update_segnum_sfd_p.sfd_p;
      free_swap_file_descriptor (ijle_p, ijl_ordinal);

{  Update reassignable page frames to reflect swapout io aborted, job is being swapped in.

      mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon -
            ijle_p^.swap_data.swapped_job_page_count + ijle_p^.job_fixed_contiguous_pages;
      ijle_p^.swap_io_control.spd_index := LOWERVALUE (mmt$page_frame_index);
      ijle_p^.next_swap_status := jmc$iss_null;
    IFEND;

    IF syv$perf_keypoints_enabled.swapping_keypoints THEN
      kt.s := ijle_p^.system_supplied_name (16, 4);
      #KEYPOINT (osk$performance, osk$m * kt.f1, ptk$swapin_job_name_1);
      #KEYPOINT (osk$performance, osk$m * ((kt.f2 * 256) + ajl_ordinal), ptk$swapin_job_name_2);
    IFEND;

{ Swap status is advanced to executing.

    reset_sdt_xcb_tables (ijl_ordinal, ijle_p, FALSE, FALSE);

  PROCEND swapin_after_io;
?? TITLE := 'UPDATE_PROCESSOR_SELECTIONS', EJECT ??

{ PURPOSE:
{   This procedure is called before swapin of a job is complete in order to readjust the processors which a
{   job has selected and on which its tasks will execute.  A change has most likely occurred in the state of
{   a processor and this change must be reflected in the job's processor selections contained in the execution
{   control block.

  PROCEDURE update_processor_selections
    (    ijle_p: ^jmt$initiated_job_list_entry;
         ijl_ordinal: jmt$ijl_ordinal);

    VAR
      processor_selections: ost$processor_id_set,
      xcb_p: ^ost$execution_control_block,
      xcb_state: tmt$find_next_xcb_state;

    tmp$find_next_xcb (tmc$fnx_swapping_job, ijle_p, ijl_ordinal, xcb_state, xcb_p);

    IF ijle_p^.job_scheduler_data.job_class = jmc$maintenance_job_class THEN
      processor_selections := mtv$scb.cpus.logically_on;
    ELSE
      processor_selections := mtv$scb.cpus.available_for_use;
    IFEND;

    WHILE xcb_p <> NIL DO
      IF xcb_p^.requested_processor_selections * processor_selections = $ost$processor_id_set [] THEN
        xcb_p^.processor_selections := processor_selections;
      ELSEIF (osv$170_os_type <> osc$ot7_none) AND tmv$dedicate_a_cpu_to_nos AND
            (xcb_p^.processor_selections = $ost$processor_id_set [mtv$dual_state_cpu_number]) THEN
        xcb_p^.processor_selections := processor_selections;
      ELSE
        xcb_p^.processor_selections := xcb_p^.requested_processor_selections * processor_selections;
      IFEND;
      tmp$find_next_xcb (tmc$fnx_continue, NIL, jmv$null_ijl_ordinal, xcb_state, xcb_p);
    WHILEND;

  PROCEND update_processor_selections;
?? TITLE := 'UPDATE_SERVER_FILES', EJECT ??

  PROCEDURE update_server_files
    (    ijle_p: ^jmt$initiated_job_list_entry;
         ijl_ordinal: jmt$ijl_ordinal);

    VAR
      fde_p: gft$file_desc_entry_p,
      msg: string (70),
      next_pfti: mmt$page_frame_index,
      page_status: gft$page_status,
      pfti: mmt$page_frame_index;

    pfti := ijle_p^.job_page_queue_list [mmc$pq_job_working_set].link.bkw;

{ It is not necessary to clear the valid bit before checking the modified bit in this case; the job is
{ in the process of swapping in, so nothing else can be referencing the pages.

    WHILE pfti <> 0 DO
      next_pfti := mmv$pft_p^ [pfti].link.bkw;
      IF mmv$pft_p^ [pfti].aste_p^.sfid.residence <> gfc$tr_system_wait_recovery THEN
        gfp$mtr_get_fde_p (mmv$pft_p^ [pfti].aste_p^.sfid, ijle_p, fde_p);
        IF fde_p^.media = gfc$fm_served_file THEN
          dfp$fetch_page_status (fde_p, 0, page_status);
          IF (page_status = gfc$ps_server_terminated) OR ((page_status = gfc$ps_volume_unavailable) AND
                (NOT mmv$pt_p^ [mmv$pft_p^ [pfti].pti].m)) THEN

{ If the server is terminated or server is unavailable and we are reading, delete the page.

            mmp$delete_pt_entry (pfti, TRUE);
            mmp$relink_page_frame (pfti, mmc$pq_free);
          IFEND;
        IFEND;
      IFEND;
      pfti := next_pfti;
    WHILEND;

{ Debug display

    IF dfv$file_server_debug_enabled THEN
      IF (ijle_p^.terminate_access_work = $dft$mainframe_set []) AND
            (ijle_p^.inhibit_access_work = $dft$mainframe_set []) THEN
        msg := ' Job XXXXXXXXXXXXXXXXXXX swap in - server inactivation.';
        msg (6, 19) := ijle_p^.system_supplied_name;
        dpp$display_error (msg);
      IFEND;
      IF ijle_p^.inhibit_access_work <> $dft$mainframe_set [] THEN
        msg := ' Job XXXXXXXXXXXXXXXXXXX swap in - server inhibit access.';
        msg (6, 19) := ijle_p^.system_supplied_name;
        dpp$display_error (msg);
      IFEND;
      IF ijle_p^.terminate_access_work <> $dft$mainframe_set [] THEN
        msg := ' Job XXXXXXXXXXXXXXXXXXX swap in - server terminate access.';
        msg (6, 19) := ijle_p^.system_supplied_name;
        dpp$display_error (msg);
      IFEND;
    IFEND;

    IF (ijle_p^.terminate_access_work = $dft$mainframe_set []) AND
          (ijle_p^.inhibit_access_work = $dft$mainframe_set []) THEN

{ There is no need to change the access state.

      RETURN;
    IFEND;
    dfp$set_task_segment_state (tmc$fnx_swapping_job, ijle_p, ijl_ordinal, ijle_p^.inhibit_access_work,
          ijle_p^.terminate_access_work);

{ Dont clear inhibit - let it be cleared by either job recovery
{ or by the job when it detects that the server is not longer inactive.

    ijle_p^.terminate_access_work := $dft$mainframe_set [];
  PROCEND update_server_files;

?? TITLE := 'JSP$ADV_EXPIRED_SWAPPED_JOBS', EJECT ??

  PROCEDURE [XDCL] jsp$adv_expired_swapped_jobs
    (    swap_queue_id: jst$swapped_but_still_in_memory);

{
{   The purpose of this procedure is to advance jobs that are swapped but still in memory
{ and have exceeded the maximum time that can be spent in the respective swap queue.
{   The task_switch/ready_task/monitor_swap_in runs asynchronously in monitor, so we may
{ discover that the job saved as next_ijl_ordinal is no longer in the expected queue because
{ the task_switch path has swapped it in.  In that case, just exit and the rest of the jobs
{ in the S0 or S2 queue will be advanced on the next call (called by periodic).  The PTL
{ lock must be set while the job's swap_queue_link is re-checked to verify that the job is
{ still in the expected swap queue.  The swap state must be advanced while the PTL lock is
{ still set so that the task_switch path cannot be asynchronously finding the job in the S0 or
{ S2 state and swapping it in.

    VAR
      current_time: integer,
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      next_ijl_ordinal: jmt$ijl_ordinal,
      swap_state: jmt$ijl_swap_status,
      time_limit: integer;

    current_time := #FREE_RUNNING_CLOCK (0);
    IF swap_queue_id = jsc$isqi_swapped_io_not_init THEN
      time_limit := jsv$max_time_swap_io_not_init;
      swap_state := jmc$iss_flush_am_pages;
    ELSEIF swap_queue_id = jsc$isqi_swapped_io_completed THEN
      time_limit := jsv$max_time_swap_io_complete;
      swap_state := jmc$iss_free_swapped_memory;
    ELSE

{  Unexpected swap queue identifier.

      RETURN;
    IFEND;

    ijl_ordinal := jsv$ijl_swap_queue_list [swap_queue_id].forward_link;
    WHILE ijl_ordinal <> jmv$null_ijl_ordinal DO
      jmp$get_ijle_p (ijl_ordinal, ijle_p);
      IF (ijle_p^.swap_queue_link.queue_id <> swap_queue_id) THEN
        RETURN;
      IFEND;
      next_ijl_ordinal := ijle_p^.swap_queue_link.forward_link;

      IF (ijle_p^.estimated_ready_time + time_limit) < current_time THEN
        tmp$set_lock (tmv$ptl_lock);
        IF (ijle_p^.swap_queue_link.queue_id <> swap_queue_id) THEN
          tmp$clear_lock (tmv$ptl_lock);
          RETURN;
        IFEND;
        advance_swap_state (ijle_p, swap_state);
        tmp$clear_lock (tmv$ptl_lock);
        jsp$monitor_advance_swap (ijl_ordinal);
      IFEND;
      ijl_ordinal := next_ijl_ordinal;
    WHILEND;

  PROCEND jsp$adv_expired_swapped_jobs;

?? TITLE := 'JSP$FLUSH_LONG_WAIT_QUEUE', EJECT ??

  PROCEDURE jsp$flush_long_wait_queue;

{ The purpose of this procedure is to initiate the swapout IO on swapped jobs
{ that have not had IO initiated.  All pages currently in the long wait queue will
{ be advanced to disk.  The flush_all_pages option on the monitor request which called this
{ procedure is used by assign_contiguous_memory and idle_system.
{ NOTE:  The PTL lock must be set while selecting a candidate from the swapped_
{ io_not_init swapping queue.  This is necessary to prevent task switch/monitor swapin
{ path from swapping a job in on the other CPU while it is being selected to swap
{ to disk.  The job selected must be advanced to the next swap state so that the other
{ processor can not do a monitor swapin on the job when the PTL lock is released.

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      ijl_ordinal: jmt$ijl_ordinal;

    #keypoint (osk$entry, 0, jsk$initiate_swapout_io);

    tmp$set_lock (tmv$ptl_lock);
    ijl_ordinal := jsv$ijl_swap_queue_list [jsc$isqi_swapped_io_not_init].forward_link;

    WHILE ijl_ordinal <> jmv$null_ijl_ordinal DO

      jmp$get_ijle_p (ijl_ordinal, ijle_p);
      advance_swap_state (ijle_p, jmc$iss_flush_am_pages);
      tmp$clear_lock (tmv$ptl_lock);

      jsp$monitor_advance_swap (ijl_ordinal);

      tmp$set_lock (tmv$ptl_lock);
      ijl_ordinal := jsv$ijl_swap_queue_list [jsc$isqi_swapped_io_not_init].forward_link;
    WHILEND;

    tmp$clear_lock (tmv$ptl_lock);

    #keypoint (osk$exit, 0, jsk$initiate_swapout_io);

  PROCEND jsp$flush_long_wait_queue;

?? TITLE := '[XDCL] jsp$free_swap_resident_job', EJECT ??

{ PURPOSE:
{   This procedure advances the swapout of a swap resident (swapped_io_complete) job so
{   that its memory will be freed.
{ DESIGN:
{   An entry status of swapin_in_progress indicates that the swap resident job has just
{   been readied on another processor and is in the swapping queue to swap in.  Memory
{   manager needs the memory that the job is holding right now, however, so the job must
{   be reset to swapped out so that it will swap in through the job mode scheduler path.
{   Because dispatcher can ready tasks and swapin jobs in monitor asynchronously, the ptl
{   lock must be set during the advance swap.  With the ptl lock set, dispatcher cannot
{   swapin a job through jmp$ready_task_in_swapped_job while the advance swap out is
{   going on.

  PROCEDURE [XDCL] jsp$free_swap_resident_job
    (    swap_resident_ijlo: jmt$ijl_ordinal;
         swap_resident_ijle_p: ^jmt$initiated_job_list_entry);

    jsp$relink_swap_queue (swap_resident_ijlo, swap_resident_ijle_p, jsc$isqi_swapping);

    tmp$set_lock (tmv$ptl_lock);

    IF swap_resident_ijle_p^.entry_status = jmc$ies_swapin_in_progress THEN
      trace (jsc$ti_free_readied_s2_job, 1);
      jmp$reset_job_to_swapped_out (swap_resident_ijlo);
    IFEND;
    jsp$monitor_advance_swap (swap_resident_ijlo);

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND jsp$free_swap_resident_job;

?? TITLE := 'JSP$FREE_SWAPPED_JOBS_MEMORY', EJECT ??

  PROCEDURE [XDCL] jsp$free_swapped_jobs_memory
    (    ijl_ordinal: jmt$ijl_ordinal;
         s2_queue_only: boolean;
     VAR job_found: boolean);

{  The main purpose of this procedure is to select a swap-resident job (swapout IO has completed)
{  and free its memory.  The job selected is the one that most exceeds think time or has
{  the longest estimated ready time.  A null ijl ordinal passed into this procedure indicates
{  that memory manager needs memory from ANY swap resident job.  A job is selected from the
{  swapped_io_completed queue; if no jobs can be found in that queue, it is because all S2
{  jobs have been readied by dispatcher on another processor.  The S2 job has been relinked to
{  the swapping queue to swap in when swapper next executes.  The memory is still available to
{  be freed; the swapping queue must be searched to find the S2 job.
{  A second use of the procedure is to free the memory of a specific swap resident job so the the
{  memory used by the job can be given to a task needing contiguous memory.  Memory manager selects
{  the job to be freed and passes in the job's ijl ordinal.
{  To be fault tolerant in case now has been corrupted, if no S2 job is found, just return.


    VAR
      swap_resident_ijle_p: ^jmt$initiated_job_list_entry,
      swap_resident_ijlo: jmt$ijl_ordinal,
      swap_resident_q_head: jmt$ijl_ordinal;

    #keypoint (osk$entry, 0, jsk$free_swapped_jobs_memory);

    job_found := TRUE;
    swap_resident_ijlo := jmv$null_ijl_ordinal;

    IF ijl_ordinal = jmv$null_ijl_ordinal THEN
      tmp$set_lock (jsv$ijl_serial_lock);

      swap_resident_q_head := jsv$ijl_swap_queue_list [jsc$isqi_swapped_io_completed].forward_link;
      IF swap_resident_q_head <> jmv$null_ijl_ordinal THEN
        select_best_candidate (swap_resident_q_head, TRUE, swap_resident_ijlo, swap_resident_ijle_p);
      ELSEIF (NOT s2_queue_only) THEN
        swap_resident_ijlo := jsv$ijl_swap_queue_list [jsc$isqi_swapping].forward_link;
      /find_swap_resident_job/
        WHILE swap_resident_ijlo <> jmv$null_ijl_ordinal DO
          jmp$get_ijle_p (swap_resident_ijlo, swap_resident_ijle_p);
          IF swap_resident_ijle_p^.swap_status = jmc$iss_swapped_io_complete THEN
            EXIT /find_swap_resident_job/;
          IFEND;
          swap_resident_ijlo := swap_resident_ijle_p^.swap_queue_link.forward_link;
        WHILEND /find_swap_resident_job/;
      IFEND;

      tmp$clear_lock (jsv$ijl_serial_lock);

      IF swap_resident_ijlo <> jmv$null_ijl_ordinal THEN
        jsp$free_swap_resident_job (swap_resident_ijlo, swap_resident_ijle_p);
      ELSE
        job_found := FALSE;
        trace (jsc$ti_no_s2_job_found, 1);
        IF NOT s2_queue_only THEN
          mmv$reassignable_page_frames.now := mmv$gpql [mmc$pq_free].pqle.count +
                mmv$gpql [mmc$pq_avail].pqle.count;
          trace (jsc$ti_now_count_reset, 1);
        IFEND;
      IFEND;

    ELSE
      jsp$monitor_advance_swap (ijl_ordinal);
    IFEND;

    #keypoint (osk$exit, 0, jsk$free_swapped_jobs_memory);

  PROCEND jsp$free_swapped_jobs_memory;


?? TITLE := 'JSP$IDLE_TASKS_COMPLETE', EJECT ??

  PROCEDURE [XDCL] jsp$idle_tasks_complete
    (    ijl_ordinal: jmt$ijl_ordinal);

{
{     The purpose of this procedure is to record that all tasks are idled for a job being
{  swapped out.  The swapout can now be advanced.
{
{  NOTE: It is possible that this procedure is executing in more than 1 cpu simultaneously.
{

    VAR
      ijle_p: ^jmt$initiated_job_list_entry;


    jmp$get_ijle_p (ijl_ordinal, ijle_p);

    IF (ijle_p^.swap_status = jmc$iss_idle_tasks_initiated) THEN
      ijle_p^.next_swap_status := jmc$iss_job_idle_tasks_complete;
      ijle_p^.delayed_swapin_work := $jmt$delayed_swapin_work [];

{ Dont clear inhibit - let it be cleared by either server job recovery
{ or by the job when it detects that the server is not longer inactive.

      ijle_p^.terminate_access_work := $dft$mainframe_set [];
      set_swapping_event (jsc$se_immediate);
    IFEND;

  PROCEND jsp$idle_tasks_complete;

?? TITLE := 'JMP$INITIATE_SWAPOUT_IO', EJECT ??

  PROCEDURE [XDCL] jsp$initiate_swapout_io
    (VAR pages_flushed: mmt$page_frame_index);

{ The purpose of this procedure is to initiate the swapout IO on swapped jobs
{ that have not had IO initiated to make memory available.  Jobs are advanced
{ until IO is initiated on enough pages to bring mmv$reassignable_page_frames.now + .soon
{ up to the number of pages requested or until all jobs have had swapout IO initiated.
{ Dispatching priority and whether a job has expired its long_wait_think_time are considered
{ when deciding whether to flush a job to disk.  If memory is needed by jobs of higher or
{ equal dispatching priority, the job will be flushed to disk.  If memory is needed by jobs
{ of lower dispatching priority, the job will be flushed to disk only if it has expired its
{ long_wait_think_time.  NOTE:  The pages_needed array has been set so that each array element
{ reflects the number of pages needed for that dispatching priority and all higher priorities.
{ NOTE:  The PTL lock must be set while selecting a candidate from the swapped_
{ io_not_init swapping queue.  This is necessary to prevent task switch/monitor swapin
{ path from swapping a job in on the other CPU while it is being selected to swap
{ to disk.  The job selected must be advanced to the next swap state so that the other
{ processor can not do a monitor swapin on the job when the PTL lock is released.

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      ijl_ordinal: jmt$ijl_ordinal,
      max_pages_needed: mmt$page_frame_index,
      selected_jobs_ijle_p: ^jmt$initiated_job_list_entry,
      selected_jobs_ijl_ordinal: jmt$ijl_ordinal;

    #keypoint (osk$entry, 0, jsk$initiate_swapout_io);

    pages_flushed := 0;
    max_pages_needed := jmv$long_wait_swap_threshold [jmc$lowest_dispatching_priority] -
          (mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon);

    WHILE max_pages_needed > pages_flushed DO
      tmp$set_lock (tmv$ptl_lock);
      ijl_ordinal := jsv$ijl_swap_queue_list [jsc$isqi_swapped_io_not_init].forward_link;

      IF ijl_ordinal = jmv$null_ijl_ordinal THEN
        tmp$clear_lock (tmv$ptl_lock);
        #keypoint (osk$exit, 0, jsk$initiate_swapout_io);
        RETURN;
      IFEND;

      select_best_candidate (ijl_ordinal, FALSE, selected_jobs_ijl_ordinal, selected_jobs_ijle_p);

      IF selected_jobs_ijl_ordinal = jmv$null_ijl_ordinal THEN
        tmp$clear_lock (tmv$ptl_lock);
        #keypoint (osk$exit, 0, jsk$initiate_swapout_io);
        RETURN;
      IFEND;

      advance_swap_state (selected_jobs_ijle_p, jmc$iss_flush_am_pages);
      tmp$clear_lock (tmv$ptl_lock);

      jsp$monitor_advance_swap (selected_jobs_ijl_ordinal);
      pages_flushed := pages_flushed + selected_jobs_ijle_p^.swap_data.swapped_job_page_count;
    WHILEND;

    #keypoint (osk$exit, 0, jsk$initiate_swapout_io);

  PROCEND jsp$initiate_swapout_io;

?? TITLE := 'JSP$IO_COMPLETE', EJECT ??

  PROCEDURE [XDCL] jsp$io_complete
    (    ijle_p: ^jmt$initiated_job_list_entry);

{
{     The purpose of this procedure is to record that swap io has completed and the swap can
{  now be advanced.
{
{  NOTE: It is possible that this procedure is executing in more than 1 cpu simultaneously.
{


    ijle_p^.notify_swapper_when_io_complete := FALSE;

    CASE ijle_p^.swap_status OF
    = jmc$iss_wait_job_io_complete =
      ijle_p^.next_swap_status := jmc$iss_job_io_complete;
    = jmc$iss_swapout_io_initiated =
      ijle_p^.next_swap_status := jmc$iss_swapout_io_complete;
    = jmc$iss_swapin_io_initiated =
      ijle_p^.next_swap_status := jmc$iss_swapin_io_complete;
    ELSE
      RETURN;
    CASEND;

    set_swapping_event (jsc$se_immediate);

  PROCEND jsp$io_complete;
?? TITLE := 'JSP$LONG_WAIT_AGING', EJECT ??

{
{ The purpose of this procedure is to age the working set of a job going into LONG WAIT.
{

  PROCEDURE [XDCL] jsp$long_wait_aging
    (    ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      cptime: integer,
      fde_p: gft$file_desc_entry_p,
      ijl_ordinal: jmt$ijl_ordinal,
      initial_rtc: integer,
      jcb_p: ^jmt$job_control_block,
      maximum_pages_to_swap: integer,
      minimum_working_set: jmt$working_set_size,
      modified_pages_removed: integer,
      page_age_limit: integer,
      pfti: mmt$page_frame_index,
      queueid: mmt$page_frame_queue_id,
      segment_number: ost$segment,
      total_pages_removed: integer;

    #KEYPOINT (osk$entry, 0, jsk$long_wait_aging);

    jcb_p := #ADDRESS (1, mtc$job_fixed_segment + ijle_p^.ajl_ordinal, 0);
    initial_rtc := ijle_p^.statistics.ready_task_count;

    IF mmv$aging_algorithm >= 4 THEN
      cptime := ijle_p^.statistics.cp_time.time_spent_in_job_mode;
    ELSE
      cptime := ijle_p^.statistics.cp_time.time_spent_in_job_mode +
            ijle_p^.statistics.cp_time.time_spent_in_mtr_mode;
    IFEND;

    trace (jsc$ti_lwa, 1);

    IF cptime > (jcb_p^.cptime_next_age_working_set + 2 * jcb_p^.page_aging_interval) THEN
      trace (jsc$ti_lwa_cp_age, 1);
      mmp$age_job_working_set (ijle_p, jcb_p);
    IFEND;

    IF jsv$free_working_set_on_swapout THEN
      page_age_limit := 0;
      minimum_working_set := 0;
    ELSE { This is the usual case.  Freeing the working set is for test purposes. }
      page_age_limit := mmv$swapping_aic;
      minimum_working_set := jcb_p^.min_working_set_size;
    IFEND;

    mmp$remove_stale_pages (ijle_p^.job_page_queue_list [mmc$pq_job_working_set], page_age_limit, jcb_p,
          ijle_p, mmc$pq_avail_modified, minimum_working_set, modified_pages_removed, total_pages_removed);

    trace (jsc$ti_lwa_stale_pages_rem, total_pages_removed);
    trace (jsc$ti_lwa_stale_mod_pages_rem, modified_pages_removed);

    IF ijle_p^.task_created_after_last_swap THEN
      maximum_pages_to_swap := jsv$max_pages_first_swap_task;
    ELSE
      maximum_pages_to_swap := jsv$maximum_pages_to_swap;
    IFEND;

    IF (ijle_p^.job_page_queue_list [mmc$pq_job_working_set].count > maximum_pages_to_swap) THEN
      mmp$trim_job_working_set (ijle_p, jcb_p, TRUE); {true= trim_to_swap_size
    IFEND;

    ijle_p^.task_created_after_last_swap := FALSE;

    IF ijle_p^.statistics.ready_task_count > initial_rtc THEN
      trace (jsc$ti_lwa_ready_task, 1);
    IFEND;

{ Update the MAP_PURGE_TIMESTAMP. Since long wait aging may have cleared page table
{ 'used' bits and NOT purge the page map, we have to insure that the map is purged before
{ the job is next allowed to run. Although the map could be purged at this point, it is
{ defered until the job is swapped in. Usually something else will have purged the map by
{ this time and no purge will be required.

    ijle_p^.age_purge_timestamp := #FREE_RUNNING_CLOCK (0);

{ Purge maps now in case we decided not to swap out.

    mmp$conditional_purge_all_map (ijle_p^.age_purge_timestamp);

{ The following code will count the pages being swapped out and determine the segment that the
{ page belongs to. Segments greater than or equal to 40(16) are combined and output as pages
{ of segment 40(16).

    IF jsv$enable_swap_file_statistics THEN
      pfti := ijle_p^.job_page_queue_list [mmc$pq_job_working_set].link.bkw;
      WHILE pfti <> 0 DO
        gfp$mtr_get_fde_p (mmv$pft_p^ [pfti].aste_p^.sfid, ijle_p, fde_p);
        IF fde_p^.last_segment_number >= 40(16) THEN
          segment_number := 40(16);
        ELSE
          segment_number := fde_p^.last_segment_number;
        IFEND;
        jsv$swap_file_statistics.total_pages_per_segment [segment_number] :=
              jsv$swap_file_statistics.total_pages_per_segment [segment_number] + 1;
        pfti := mmv$pft_p^ [pfti].link.bkw;
      WHILEND;
      jsv$swap_file_statistics.total_pages_per_segment [3] :=
            jsv$swap_file_statistics.total_pages_per_segment [3] +
            ijle_p^.job_page_queue_list [mmc$pq_job_fixed].count;
      jsv$swap_file_statistics.total_swaps := jsv$swap_file_statistics.total_swaps + 1;
    IFEND;


    IF syv$perf_keypoints_enabled.swapping_keypoints THEN
      pfti := ijle_p^.job_page_queue_list [mmc$pq_job_working_set].link.bkw;
      WHILE pfti <> 0 DO
        gfp$mtr_get_fde_p (mmv$pft_p^ [pfti].aste_p^.sfid, ijle_p, fde_p);
        #KEYPOINT (osk$performance, osk$m * fde_p^.last_segment_number, ptk$swapping_segment);
        #KEYPOINT (osk$performance, osk$m * (mmv$pft_p^ [pfti].sva.offset DIV osv$page_size),
              ptk$swapping_page_number);
        pfti := mmv$pft_p^ [pfti].link.bkw;
      WHILEND;
      #KEYPOINT (osk$performance, osk$m * ijle_p^.job_page_queue_list [mmc$pq_job_fixed].count,
            ptk$swapping_job_fixed);
      #KEYPOINT (osk$performance, osk$m * modified_pages_removed, ptk$swapping_modified_pages);
      #KEYPOINT (osk$performance, osk$m * total_pages_removed, ptk$swapping_removed_pages);
      ijl_ordinal := jmv$ajl_p^ [ijle_p^.ajl_ordinal].ijl_ordinal;
      #KEYPOINT (osk$performance, osk$m * (ijl_ordinal.block_number * 32 + ijl_ordinal.block_index),
            ptk$swapping_ijl_ordinal);
    IFEND;

    #KEYPOINT (osk$exit, 0, jsk$long_wait_aging);

  PROCEND jsp$long_wait_aging;
?? TITLE := 'JSP$MONITOR_ADVANCE_SWAP', EJECT ??

  PROCEDURE [XDCL] jsp$monitor_advance_swap
    (    ijl_ordinal: jmt$ijl_ordinal);

{
{     The purpose of this procedure is to advance the swap of jobs that are
{  in one of the swapped but memory resident queues.
{
{     NOTE: It is the responsibility of the caller to update the swap queue
{  statistics.
{
{  NOTE: This procedure is entered serially if running with multiple cpu's.
{

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      poll_swapping: boolean,
      status: syt$monitor_status;


    jmp$get_ijle_p (ijl_ordinal, ijle_p);

    jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapping);

{  This has to call advance_swap directly because memory manager may need memory and it expects to
{  get it immediately.

    advance_swap (ijl_ordinal, ijle_p, poll_swapping, status);

    IF poll_swapping THEN
      set_swapping_event (jsc$se_polling);
    IFEND;

  PROCEND jsp$monitor_advance_swap;
?? TITLE := 'TRACE BUFFER FOR SCHEDULER SWAPPING REQUESTS' ??
?? EJECT ??

  CONST
    num_sched_swapping_calls = 60;

  TYPE
    jst$swapping_request_type = (jsc$sc_swapout_job_mode, jsc$sc_swapout_mtr_mode, jsc$sc_swapin_job_mode,
          jsc$sc_swapin_mtr_mode, jsc$sc_swapin_mtr_direct);

  VAR
    jsv$sched_swapping_requests: [XDCL] record
      next_index: integer,
      sched_requests: array [0 .. num_sched_swapping_calls - 1] of record
        request_type: ALIGNED [0 MOD 16] jst$swapping_request_type,
        ijlo: jmt$ijl_ordinal,
        timestamp: ost$free_running_clock,
      recend,
    recend;

  PROCEDURE [INLINE] sched_trace
    (    request_type: jst$swapping_request_type;
         ijlo: jmt$ijl_ordinal);

    VAR
      i: integer;

    i := jsv$sched_swapping_requests.next_index;
    jsv$sched_swapping_requests.next_index := (i + 1) MOD num_sched_swapping_calls;
    jsv$sched_swapping_requests.sched_requests [i].request_type := request_type;
    jsv$sched_swapping_requests.sched_requests [i].ijlo := ijlo;
    jsv$sched_swapping_requests.sched_requests [i].timestamp := #FREE_RUNNING_CLOCK (0);

  PROCEND sched_trace;

?? TITLE := 'JSP$MONITOR_SWAP_IN' ??
?? EJECT ??

  PROCEDURE [XDCL] jsp$monitor_swap_in
    (    ijl_ordinal: jmt$ijl_ordinal);

*copy jsh$monitor_swap_in

    VAR
      ajl_ordinal: jmt$ajl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      jcb_p: ^jmt$job_control_block,
      status: syt$monitor_status;

    #KEYPOINT (osk$entry, 0, jsk$monitor_swap_in);

    jmp$get_ijle_p (ijl_ordinal, ijle_p);


    IF ijle_p^.swap_status = jmc$iss_swapped_no_io THEN
      sched_trace (jsc$sc_swapin_mtr_direct, ijl_ordinal);
      trace (jsc$ti_swapin_mtr_direct, 1);

{  We could just call swapin_before_io here, but for performance reasons we
{  will inline the necessary code instead.
{
{  ***  duplicated in swapin_before_io  ***

      jmp$assign_ajl_with_lock (ijle_p^.job_fixed_asid, ijl_ordinal, jmc$swapping_ajl, FALSE {must assign} ,
            ajl_ordinal, status);
      IF NOT status.normal THEN
        trace (jsc$ti_no_ajlo_mtr_swapin, 1);
        jmp$change_ijl_entry_status (ijle_p, jmc$ies_swapin_in_progress);
        jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapping);
        set_swapping_event (jsc$se_immediate);
        RETURN;
      IFEND;

{  If the ajl ordinal is invalid due to a processor switch just exit. The
{  job state will remain unchanged and we will address the swapin later.

      IF ijle_p^.ajl_ordinal = jmc$null_ajl_ordinal THEN
         RETURN;
      IFEND;

      IF syv$perf_keypoints_enabled.swapping_keypoints THEN
        kt.s := ijle_p^.system_supplied_name (16, 4);
        #KEYPOINT (osk$performance, osk$m * kt.f1, ptk$swapin_job_name_1);
        #KEYPOINT (osk$performance, osk$m * ((kt.f2 * 256) + ajl_ordinal), ptk$swapin_job_name_2);
      IFEND;

      mmv$reassignable_page_frames.swapout_io_not_initiated :=
            mmv$reassignable_page_frames.swapout_io_not_initiated - ijle_p^.swap_data.swapped_job_page_count +
            ijle_p^.job_fixed_contiguous_pages;

{     *** duplicated in complete_swapin ***

      jcb_p := #ADDRESS (1, mtc$job_fixed_segment + ijle_p^.ajl_ordinal, 0);
      jcb_p^.next_cyclic_aging_time := #FREE_RUNNING_CLOCK (0) + jcb_p^.next_cyclic_aging_time;

{       *** duplicated in restart_idled_tasks ***

      jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_null);
      advance_swap_state (ijle_p, jmc$iss_executing);

      jmp$change_ijl_entry_status (ijle_p, jmc$ies_job_in_memory);

{  Update counts if the job has reserved memory through the mmp$assign_pages request

      IF ijle_p^.memory_reserve_request.requested_page_count > 0 THEN
        IF (mmv$reassignable_page_frames.now - mmv$aggressive_aging_level_2) >
              ijle_p^.memory_reserve_request.requested_page_count THEN
          ijle_p^.memory_reserve_request.reserved_page_count :=
                ijle_p^.memory_reserve_request.reserved_page_count +
                ijle_p^.memory_reserve_request.requested_page_count;
          mmv$reserved_page_count := mmv$reserved_page_count +
                ijle_p^.memory_reserve_request.requested_page_count;
        ELSE
          trace (jsc$ti_reserve_memory_failed, 1);
        IFEND;
        ijle_p^.memory_reserve_request.requested_page_count := 0;
      IFEND;

      IF syv$perf_keypoints_enabled.swapping_stack_trace THEN
        tmp$monitor_flag_job_tasks (syc$mf_for_keypoint_traceback, ijle_p);
      IFEND;

      tmp$restart_idled_tasks (ijle_p^.ajl_ordinal);
    ELSE
      sched_trace (jsc$sc_swapin_mtr_mode, ijl_ordinal);
      trace (jsc$ti_swapin_from_mtr_mode, 1);
      jmp$change_ijl_entry_status (ijle_p, jmc$ies_swapin_in_progress);
      jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapping);
      set_swapping_event (jsc$se_immediate);
    IFEND;

    #KEYPOINT (osk$exit, 0, jsk$monitor_swap_in);

  PROCEND jsp$monitor_swap_in;
?? TITLE := 'JSP$MONITOR_SWAP_OUT' ??
?? EJECT ??

  PROCEDURE [XDCL] jsp$monitor_swap_out
    (    ijl_ordinal: jmt$ijl_ordinal);

*copy jsh$monitor_swap_out

    VAR
      frc: ost$free_running_clock,
      ijle_p: ^jmt$initiated_job_list_entry,
      initiate_swapout_io: boolean,
      job_page_count: mmt$page_frame_index,
      queue_id: mmt$job_page_queue_index;

    sched_trace (jsc$sc_swapout_mtr_mode, ijl_ordinal);
    frc := #FREE_RUNNING_CLOCK (0);

    jmp$get_ijle_p (ijl_ordinal, ijle_p);
    IF ijle_p^.swap_queue_link.queue_id = jsc$isqi_null THEN
      trace (jsc$ti_swapout_from_mtr_mode, 1);

      jmp$change_ijl_entry_status (ijle_p, jmc$ies_job_swapped);

{ ** This code is combined from code for job mode swap out requests and code in advance swap for
{ ** swap state jmc$iss_job_idle_tasks_complete - TJ.

      IF syv$perf_keypoints_enabled.swapping_keypoints THEN
        #KEYPOINT (osk$performance, osk$m * ijle_p^.ajl_ordinal, ptk$ajl_for_swap_out);
      IFEND;
      ijle_p^.swap_io_control.spd_index := LOWERVALUE (mmt$page_frame_index);
      ijle_p^.delayed_swapin_work := $jmt$delayed_swapin_work [];

{ Dont clear inhibit - let it be cleared by either server job recovery
{ or by the job when it detects that the server is not longer inactive.

      ijle_p^.terminate_access_work := $dft$mainframe_set [];

{ Swap_data.timestamp is still the time when the job completed swapin.  Swapin to swapout is residence time.

      ijle_p^.swap_data.swapout_timestamp := frc;

{ To prevent the situation of a task executing after monitor_swap_out has been called,
{ dispatcher idled tasks before calling scheduler/swapper to swapout the job for long
{ wait.  We advance the swap status of the job to swapped_no_io.

      jmp$free_ajl_with_lock (ijle_p, jmc$swapping_ajl);

{  Set close approximation of swapped job page count for job mode job scheduler.  The count is also
{  used for the service class statistics.

      calculate_swapped_pages (ijle_p);
      jsv$swap_file_page_count.swap_count := jsv$swap_file_page_count.swap_count + 1;
      jsv$swap_file_page_count.page_count := jsv$swap_file_page_count.page_count +
            ijle_p^.swap_data.swapped_job_page_count;

      tmp$set_lock (jmv$service_class_stats_lock);
      jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.statistics.swap_stats.residence_time :=
            jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.statistics.swap_stats.
            residence_time + (ijle_p^.swap_data.swapout_timestamp - ijle_p^.swap_data.timestamp);
      jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.statistics.swap_stats.swapped_pages :=
            jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.statistics.swap_stats.
            swapped_pages + ijle_p^.swap_data.swapped_job_page_count;
      tmp$clear_lock (jmv$service_class_stats_lock);


      ijle_p^.swap_data.long_wait_expire_time := frc + jmv$service_classes [ijle_p^.job_scheduler_data.
            service_class]^.attributes.long_wait_think_time;

{ If the job belongs to a service class that has a long_wait_think_time, initiate I/O only if memory is
{ needed for jobs of equal or higher priority.  If there is no long_wait_think_time, swap the job to disk
{ if memory is needed for a job of any priority.

      IF jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.attributes.
            long_wait_think_time > 0 THEN
        initiate_swapout_io := ((mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon) <=
              jmv$long_wait_swap_threshold [ijle_p^.scheduling_dispatching_priority]) OR
              NOT jsv$enable_swap_resident_no_io;
      ELSE
        initiate_swapout_io := ((mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon) <=
              jmv$long_wait_swap_threshold [jmc$lowest_dispatching_priority]) OR
              NOT jsv$enable_swap_resident_no_io;
      IFEND;

{ ** End duplicate code **

      IF NOT initiate_swapout_io THEN
        advance_swap_state (ijle_p, jmc$iss_swapped_no_io);
        jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapped_io_not_init);
      ELSE
        advance_swap_state (ijle_p, jmc$iss_flush_am_pages);
        jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapping);
        set_swapping_event (jsc$se_immediate);
      IFEND;

    ELSE
      mtp$error_stop ('JS - jsp$monitor_swap_out called for job not in null queue.');
    IFEND;

  PROCEND jsp$monitor_swap_out;
?? TITLE := 'JSP$MTR_JOB_SWAPPING_REQUESTS' ??
?? EJECT ??

  PROCEDURE [XDCL] jsp$mtr_job_swapping_requests
    (VAR request_block: jst$rb_job_swapping_functions);

{
{  The purpose of this procedure is to process job swapping monitor requests from the job mode job
{  swapper.  The JOB SCHEDULER task is executing all the swapping requests (but not set_delayed_swapin_work).
{
{  NOTE: This procedure is entered serially if running with multiple cpu's.
{

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      ijl_ordinal: jmt$ijl_ordinal,
      poll_swapping: boolean;

    #KEYPOINT (osk$entry, 0, jsk$mtr_job_swapping_requests);

    request_block.status.normal := TRUE;
    poll_swapping := TRUE;
    ijl_ordinal := request_block.ijl_ordinal;
    jmp$get_ijle_p (ijl_ordinal, ijle_p);

{  Process the job swapping subfunctions.

    CASE request_block.subfunction OF

    = jsc$jss_swap_job_in =
      sched_trace (jsc$sc_swapin_job_mode, ijl_ordinal);
      trace (jsc$ti_swapin_from_job_mode, 1);

      jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapping);

{ Set PTL lock because the swapped_job_count will be changed.  It can also be changed through the
{ task switch/monitor swap path.

      tmp$set_lock (tmv$ptl_lock);
      jmp$change_ijl_entry_status (ijle_p, jmc$ies_swapin_in_progress);
      tmp$clear_lock (tmv$ptl_lock);
      advance_swap (ijl_ordinal, ijle_p, poll_swapping, request_block.status);
      IF NOT request_block.status.normal THEN
        trace (jsc$ti_swapin_req_status_bad, 1);
      IFEND;

      tmp$set_lock (jmv$service_class_stats_lock);
      jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.statistics.swap_stats.swap_wait_time :=
            jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.statistics.swap_stats.
            swap_wait_time + (#FREE_RUNNING_CLOCK (0) - ijle_p^.job_scheduler_data.
            swapin_q_priority_timestamp);
      jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.statistics.swap_stats.
            scheduler_swapins := jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.statistics.
            swap_stats.scheduler_swapins + 1;
      tmp$clear_lock (jmv$service_class_stats_lock);

    = jsc$jss_swap_job_out =

{ The PTL lock must be set to check entry status, to prevent it from changing asynchronously on
{ another processor through the dispatcher/monitor swap path.
{ If the job's entry status is less than in_memory, the job is non_swappable.  If the entry status is
{ greater than swapin in progress, the job is already in a swapped out state.  In either case, do nothing.
{ The job can be swapped only if the entry status is in_memory or swapin_in_progress.

      tmp$set_lock (tmv$ptl_lock);

      IF (ijle_p^.entry_status = jmc$ies_job_in_memory) OR
            (ijle_p^.entry_status = jmc$ies_swapin_in_progress) THEN
        job_mode_swapout (ijl_ordinal, ijle_p, request_block.swapout_reason, request_block.memory_needed,
              poll_swapping, request_block.status);
      IFEND;

      tmp$clear_lock (tmv$ptl_lock);

    = jsc$jss_special_swapout =

{ The PTL lock must be set so that the job cannot go into long wait or go ready on another processor while
{ status is being checked/changed here.
{ If the job's entry status is less than in_memory, the job is non-swappable and must be left alone.
{ If the job's entry status is greater than swapin_in_progress, the job is already in a swapped out state;
{ the entry status must be changed to operator_force_out.  If the entry status is in_memory or swapin_in_
{ progress, the job must be swapped.

      tmp$set_lock (tmv$ptl_lock);

      IF ijle_p^.entry_status < jmc$ies_job_in_memory THEN
        mtp$set_status_abnormal ('JM', jme$job_cant_be_swapped, request_block.status);

      ELSEIF ijle_p^.entry_status > jmc$ies_swapin_in_progress THEN
        IF ijle_p^.entry_status = jmc$ies_job_swapped THEN
          IF request_block.swapout_reason = jmc$sr_operator_request THEN
            jmp$change_ijl_entry_status (ijle_p, jmc$ies_operator_force_out);
          ELSE
            jmp$change_ijl_entry_status (ijle_p, jmc$ies_job_damaged);
            ijle_p^.job_scheduler_data.swapout_reason := jmc$sr_job_damaged;
          IFEND;
        ELSEIF ijle_p^.entry_status = jmc$ies_system_force_out THEN
          IF request_block.swapout_reason = jmc$sr_operator_request THEN
            mtp$set_status_abnormal ('JM', jme$job_dead_cannot_swap, request_block.status);
          ELSE
            jmp$change_ijl_entry_status (ijle_p, jmc$ies_job_damaged);
          IFEND;
        ELSEIF ijle_p^.entry_status = jmc$ies_operator_force_out THEN
          IF request_block.swapout_reason = jmc$sr_job_damaged THEN
            jmp$change_ijl_entry_status (ijle_p, jmc$ies_job_damaged);
          IFEND;

        ELSE

{ The entry status must be ready_task.  It cannot be job_damaged or swapin_candidate;
{ job mode scheduler checks for those statuses and would not have issued the monitor request.
{ It is too tricky to try to remove the job from the ready task list, so return bad status.  JOB SCHEDULER
{ will advance the job from ready_task to swapin_candidate, and process the operator swapout from there.

          mtp$set_status_abnormal ('JM', jme$job_in_ready_task_state, request_block.status);
        IFEND;

      ELSE { entry status = jmc$ies_job_in_memory or jmc$ies_swapin_in_progress }

        job_mode_swapout (ijl_ordinal, ijle_p, request_block.swapout_reason, 0, poll_swapping,
              request_block.status);
        jmp$set_scheduler_event (jmc$examine_swapin_queue);
      IFEND;

      tmp$clear_lock (tmv$ptl_lock);

    = jsc$jss_advance_swap =
      ijle_p^.swap_data.swapping_io_error := ioc$no_error;
      CASE ijle_p^.swap_status OF
      = jmc$iss_job_allocate_swap_file =
        trace (jsc$ti_mtr_req_adv_from_aj, 1);
        ijle_p^.next_swap_status := jmc$iss_allocate_swap_file;
        advance_swap (ijl_ordinal, ijle_p, poll_swapping, request_block.status);

      = jmc$iss_swapped_io_cannot_init =
        trace (jsc$ti_mtr_req_adv_from_sd, 1);
        jsp$relink_swap_queue (ijl_ordinal, ijle_p, jsc$isqi_swapping);
        advance_swap (ijl_ordinal, ijle_p, poll_swapping, request_block.status);

      ELSE
      CASEND;

    = jsc$jss_initiate_swapout_io =
      IF request_block.flush_all_pages THEN
        jsp$flush_long_wait_queue;
      ELSE
        jsp$initiate_swapout_io (request_block.pages_flushed);
      IFEND;

    ELSE
      mtp$error_stop ('JS - unimplemented subfunction code');
    CASEND;

    IF poll_swapping THEN
      set_swapping_event (jsc$se_polling);
    IFEND;

    #KEYPOINT (osk$exit, 0, jsk$mtr_job_swapping_requests);

  PROCEND jsp$mtr_job_swapping_requests;

?? TITLE := '[XDCL] jsp$recalculate_swapped_pages', EJECT ??

{ PURPOSE:
{   This procedure recalculates the swapped_job_entry.jws page count and the
{   number of reassignable page frames when job shared pages are removed
{   from the working set of a swapping job.
{ NOTE:
{   Only job working set pages cound have been removed.

  PROCEDURE [XDCL] jsp$recalculate_swapped_pages
    (    ijle_p: ^jmt$initiated_job_list_entry;
         pages_removed: mmt$page_frame_index);

    VAR
      dsw_job_shared_asid_changed: [STATIC] jmt$delayed_swapin_work := [jmc$dsw_job_shared_asid_changed];

    trace (jsc$ti_recalculate_sje, pages_removed);

    ijle_p^.swap_data.swapped_job_page_count := ijle_p^.swap_data.swapped_job_page_count - pages_removed;

    IF (ijle_p^.swap_status >= jmc$iss_swapped_no_io) AND
          (ijle_p^.swap_status <= jmc$iss_allocate_swap_file) THEN
      ijle_p^.swap_data.swapped_job_entry.job_page_queue_count [mmc$pq_job_working_set] :=
            ijle_p^.swap_data.swapped_job_entry.job_page_queue_count [mmc$pq_job_working_set] - pages_removed;
      mmv$reassignable_page_frames.swapout_io_not_initiated :=
            mmv$reassignable_page_frames.swapout_io_not_initiated - pages_removed;
      trace (jsc$ti_recal_sje_s0, pages_removed);
    ELSEIF (ijle_p^.swap_status >= jmc$iss_wait_job_io_complete) AND
          (ijle_p^.swap_status <= jmc$iss_allocate_sfd) THEN
      ijle_p^.swap_data.swapped_job_entry.job_page_queue_count [mmc$pq_job_working_set] :=
            ijle_p^.swap_data.swapped_job_entry.job_page_queue_count [mmc$pq_job_working_set] - pages_removed;
      mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon - pages_removed;
    ELSEIF ijle_p^.swap_status = jmc$iss_swapped_io_cannot_init THEN
      ijle_p^.swap_data.swapped_job_entry.job_page_queue_count [mmc$pq_job_working_set] :=
            ijle_p^.swap_data.swapped_job_entry.job_page_queue_count [mmc$pq_job_working_set] - pages_removed;
      mmv$reassignable_page_frames.swapout_io_cannot_initiate :=
            mmv$reassignable_page_frames.swapout_io_cannot_initiate - pages_removed;
    ELSEIF ijle_p^.swap_status = jmc$iss_swapped_io_complete THEN
      mmv$reassignable_page_frames.now := mmv$reassignable_page_frames.now - pages_removed;
      ijle_p^.delayed_swapin_work := ijle_p^.delayed_swapin_work + dsw_job_shared_asid_changed;
      trace (jsc$ti_recal_sje_s2, pages_removed);
    IFEND;

  PROCEND jsp$recalculate_swapped_pages;

?? TITLE := 'JSP$SET_DELAYED_SWAPIN_WORK_MTR', EJECT ??

  PROCEDURE [XDCL] jsp$set_delayed_swapin_work_mtr
    (    delayed_swapin_work: jmt$delayed_swapin_work_record);

    VAR
      i: integer,
      ijle_p: ^jmt$initiated_job_list_entry,
      j: integer;


  /set_ijle_work/
    FOR i := LOWERBOUND (jmv$ijl_p.block_p^) TO jmv$ijl_p.max_block_in_use DO

      IF jmv$ijl_p.block_p^ [i].index_p <> NIL THEN

      /ijl_inner_loop/
        FOR j := LOWERVALUE (jmt$ijl_block_index) TO UPPERVALUE (jmt$ijl_block_index) DO

          ijle_p := ^jmv$ijl_p.block_p^ [i].index_p^ [j];
          IF ijle_p^.entry_status <> jmc$ies_entry_free THEN
            ijle_p^.delayed_swapin_work := ijle_p^.delayed_swapin_work +
                  delayed_swapin_work.delayed_swapin_work;
            IF jmc$dsw_update_server_files IN delayed_swapin_work.delayed_swapin_work THEN
              ijle_p^.terminate_access_work := ijle_p^.terminate_access_work +
                    delayed_swapin_work.terminate_access_work;
              ijle_p^.inhibit_access_work := ijle_p^.inhibit_access_work +
                    delayed_swapin_work.inhibit_access_work;

{ The termination should always have precedence over inhibit.

              ijle_p^.inhibit_access_work := ijle_p^.inhibit_access_work - ijle_p^.terminate_access_work;
            IFEND;
          IFEND;

        FOREND /ijl_inner_loop/; { j }

      IFEND;

    FOREND /set_ijle_work/; { i }

  PROCEND jsp$set_delayed_swapin_work_mtr;
?? TITLE := 'JSP$SWAP_POLLING', EJECT ??

  PROCEDURE [XDCL] jsp$swap_polling;

{
{     The purpose of this procedure is to advance the swap for jobs that are
{ waiting for events dependent on resource availability (resources such as memory
{ or disk space).  The resources are needed to swap the job not to execute it.
{
{  NOTE: This procedure is entered serially if running with multiple cpu's.
{

    VAR
      change_swap_direction: boolean,
      ijle_p: ^jmt$initiated_job_list_entry,
      ijl_ordinal: jmt$ijl_ordinal,
      last_swap_status: jmt$ijl_swap_status,
      next_ijl_ordinal: jmt$ijl_ordinal,
      poll_swapper_again: boolean,
      poll_swapping: boolean,
      status: syt$monitor_status;

    #KEYPOINT (osk$entry, 0, jsk$swap_polling);

{  Set time to call swapper to maximum value so that it won't be called until necessary.
{  This is done now so that if an asynchronous request is received from another cpu it
{  will not be lost.

    jsv$time_to_call_job_swapper := UPPERVALUE (ost$free_running_clock);

{  Advance swap on jobs in the swap queue.

    ijl_ordinal := jsv$ijl_swap_queue_list [jsc$isqi_swapping].forward_link;
    poll_swapper_again := FALSE;

  /poll_jobs_being_swapped/
    WHILE ijl_ordinal <> jmv$null_ijl_ordinal DO
      jmp$get_ijle_p (ijl_ordinal, ijle_p);
      next_ijl_ordinal := ijle_p^.swap_queue_link.forward_link;

      last_swap_status := ijle_p^.swap_status;
      change_swap_direction := ((last_swap_status <= UPPERVALUE (jmt$swapout)) AND
            (last_swap_status >= LOWERVALUE (jmt$swapout)) AND
            (ijle_p^.entry_status < jmc$ies_swapped_out)) OR ((last_swap_status <=
            UPPERVALUE (jmt$swapin)) AND (last_swap_status >= LOWERVALUE (jmt$swapin)) AND
            (ijle_p^.entry_status > jmc$ies_swapped_in));

      CASE ijle_p^.swap_status OF
      = jmc$iss_executing, jmc$iss_job_idle_tasks_complete, jmc$iss_swapped_no_io, jmc$iss_flush_am_pages,
            jmc$iss_swapped_io_cannot_init, jmc$iss_swapped_io_complete, jmc$iss_swapout_complete =

{  Continue advancing the swap.

      = jmc$iss_wait_allocate_sfd =
        jsv$pages_needed_for_sfd := 0;
        trace (jsc$ti_zero_out_pages_for_sfd_2, 1);
        advance_swap_state (ijle_p, jmc$iss_allocate_sfd);
      = jmc$iss_wait_allocate_swap_file =
        advance_swap_state (ijle_p, jmc$iss_allocate_swap_file);
      = jmc$iss_wait_swapout_io_init =
        advance_swap_state (ijle_p, jmc$iss_initiate_swapout_io);
      = jmc$iss_wait_swapin_io_init =
        advance_swap_state (ijle_p, jmc$iss_swapin_resource_claimed);

      ELSE

{  Swap status is either jmc$iss_idle_tasks_initiated, jmc$iss_job_allocate_swap_file,
{  jmc$iss_wait_job_io_complete, jmc$iss_swapout_io_initiated, or jmc$iss_swapin_io_initiated.
{  All other states are pass thru states and will never come through here.

        IF (ijle_p^.next_swap_status = jmc$iss_null) AND ((NOT change_swap_direction) OR
              (ijle_p^.swap_status = jmc$iss_swapin_io_initiated)) THEN
          ijl_ordinal := next_ijl_ordinal;
          CYCLE /poll_jobs_being_swapped/
        IFEND;
      CASEND;

      advance_swap (ijl_ordinal, ijle_p, poll_swapping, status);

      IF poll_swapping THEN
        poll_swapper_again := TRUE;
      IFEND;

      ijl_ordinal := next_ijl_ordinal;
    WHILEND /poll_jobs_being_swapped/;

    IF (poll_swapper_again) AND (jsv$time_to_call_job_swapper = UPPERVALUE (ost$free_running_clock)) THEN
      set_swapping_event (jsc$se_polling);
    IFEND;

    #KEYPOINT (osk$exit, 0, jsk$swap_polling);

  PROCEND jsp$swap_polling;

MODEND jsm$monitor_mode_job_swapper;
*DECK DECK=JSP$ADVANCE_LONG_WAIT_JOBS EXPAND=FALSE

  PROCEDURE [XREF] jsp$advance_long_wait_jobs
    (    flush_all_pages: boolean;
     VAR pages_flushed_from_lw_queue: mmt$page_frame_index);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_index
?? POP ??
*DECK DECK=JSP$ADV_EXPIRED_SWAPPED_JOBS EXPAND=FALSE

   PROCEDURE [XREF] jsp$adv_expired_swapped_jobs (swap_queue_id: jst$swapped_but_still_in_memory);

?? PUSH (LISTEXT := ON) ??
*copyc jst$ijl_swap_queue_link
?? POP ??

*DECK DECK=JSP$CLEAR_RELINK_LOCK EXPAND=FALSE


PROCEDURE [INLINE] jsp$clear_relink_lock;

      VAR
       jmv$null_ijl_ordinal: [XREF] jmt$ijl_ordinal;

      jsv$ijl_relink_lock.lock := FALSE;
      jsv$ijl_relink_lock.lock_owner := jmv$null_ijl_ordinal;

PROCEND   jsp$clear_relink_lock;

?? PUSH (LISTEXT := ON) ??
*copyc jst$ijl_lock
?? POP ??
*DECK DECK=JSP$FREE_SWAPPED_JOBS_MEMORY EXPAND=FALSE

   PROCEDURE [XREF] jsp$free_swapped_jobs_memory
     (    ijl_ordinal: jmt$ijl_ordinal;
          s2_queue_only: boolean;
      VAR job_found: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc JMT$IJL_ORDINAL
?? POP ??
*DECK DECK=JSP$FREE_SWAP_RESIDENT_JOB EXPAND=FALSE

  PROCEDURE [XREF] jsp$free_swap_resident_job
    (    swap_resident_ijlo: jmt$ijl_ordinal;
         swap_resident_ijle_p: ^jmt$initiated_job_list_entry);
*DECK DECK=JSP$HELP_MONITOR_MODE_SWAPPER EXPAND=FALSE

PROCEDURE [XREF] jsp$help_monitor_mode_swapper;
*DECK DECK=JSP$IDLE_TASKS_COMPLETE EXPAND=FALSE
  PROCEDURE [XREF] jsp$idle_tasks_complete (ijl_ordinal: jmt$ijl_ordinal);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=JSP$INITIATE_SWAPOUT_IO EXPAND=FALSE

  PROCEDURE [XREF] jsp$initiate_swapout_io
    (VAR pages_flushed: mmt$page_frame_index);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_index
?? POP ??
*DECK DECK=JSP$IO_COMPLETE EXPAND=FALSE
  PROCEDURE [XREF] jsp$io_complete (ijle_p: ^jmt$initiated_job_list_entry);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=JSP$LONG_WAIT_AGING EXPAND=FALSE

  PROCEDURE [XREF] jsp$long_wait_aging (ijle_p: ^jmt$initiated_job_list_entry);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=JSP$MONITOR_ADVANCE_SWAP EXPAND=FALSE
  PROCEDURE [XREF] jsp$monitor_advance_swap (ijl_ordinal: jmt$ijl_ordinal);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=JSP$MONITOR_SWAP_IN EXPAND=FALSE
 PROCEDURE [XREF] jsp$monitor_swap_in (ijl_ordinal: jmt$ijl_ordinal);

?? PUSH (LIST := OFF) ??
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=JSP$MONITOR_SWAP_OUT EXPAND=FALSE
 PROCEDURE [XREF] jsp$monitor_swap_out (ijl_ordinal: jmt$ijl_ordinal);

?? PUSH (LIST := OFF) ??
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=JSP$RECALCULATE_SWAPPED_PAGES EXPAND=FALSE

  PROCEDURE [XREF] jsp$recalculate_swapped_pages
    (   ijle_p: ^jmt$initiated_job_list_entry;
        pages_removed: mmt$page_frame_index);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
*copyc mmt$page_frame_index
?? POP ??
*DECK DECK=JSP$RELINK_SWAP_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] jsp$relink_swap_queue (ijl_ordinal: jmt$ijl_ordinal;
        ijle_p: ^jmt$initiated_job_list_entry;
        new_queue: jst$ijl_swap_queue_id);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc jst$ijl_swap_queue_link
?? POP ??
*DECK DECK=JSP$RESET_MAXIMUM_TIME EXPAND=FALSE

  PROCEDURE [XREF] jsp$reset_maximum_time;
*DECK DECK=JSP$SET_DELAYED_SWAPIN_WORK_MTR EXPAND=FALSE

  PROCEDURE [XREF] jsp$set_delayed_swapin_work_mtr
    (    delayed_swapin_work: jmt$delayed_swapin_work_record);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$delayed_swapin_work
?? POP ??

*DECK DECK=JSP$SET_DELAYED_SWAPIN_WORK_R1 EXPAND=FALSE
*DECK DECK=JSP$SET_RELINK_LOCK EXPAND=FALSE


  PROCEDURE [INLINE] jsp$set_relink_lock (ijl_ord: jmt$ijl_ordinal);


      VAR
      old_traps: 0 ..3,
      lock_already_set: boolean;

      REPEAT
        i#mtr_disable_traps (old_traps);
        #test_set (jsv$ijl_relink_lock.lock, lock_already_set);
         IF lock_already_set THEN
           i#mtr_restore_traps (old_traps);
           { maybe wait or something later }
         IFEND;
      UNTIL NOT lock_already_set;
        #test_set (jsv$ijl_relink_lock.lock, lock_already_set);
        jsv$ijl_relink_lock.lock_owner := ijl_ord;
        i#mtr_restore_traps (old_traps);

PROCEND jsp$set_relink_lock;

?? POP ??

*DECK DECK=JSP$SPECIAL_JOB_SWAPOUT EXPAND=FALSE

  PROCEDURE [XREF] jsp$special_job_swapout
    (    ijl_ordinal: jmt$ijl_ordinal;
         reason: jmt$swapout_reasons;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc jmt$swapout_reasons
?? POP ??
*DECK DECK=JSP$SWAP_JOB_IN EXPAND=FALSE

  PROCEDURE [XREF] jsp$swap_job_in (ijl_ordinal: jmt$ijl_ordinal;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc JMT$IJL_ORDINAL
*copyc OST$STATUS
?? POP ??
*DECK DECK=JSP$SWAP_JOB_OUT EXPAND=FALSE

  PROCEDURE [XREF] jsp$swap_job_out
    (    ijl_ordinal: jmt$ijl_ordinal;
         swapout_reason: jmt$swapout_reasons;
         memory_needed: mmt$page_frame_index;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc jmt$swapout_reasons
*copyc mmt$page_frame_index
*copyc ost$status
?? POP ??
*DECK DECK=JST$IJL_LOCK EXPAND=FALSE
TYPE
  jst$ijl_lock  = RECORD
       lock: aligned [0 MOD 8] boolean,
       lock_owner: jmt$ijl_ordinal,
    RECEND;

*copyc jmt$ijl_ordinal
*DECK DECK=JST$IJL_SWAP_QUEUE_LINK EXPAND=FALSE
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{
 TYPE
    jst$ijl_swap_queue_link = record
      queue_id: jst$ijl_swap_queue_id,
      backward_link: jmt$ijl_ordinal,
      forward_link: jmt$ijl_ordinal,
    recend,

    jst$ijl_swap_queue_id = (jsc$isqi_null, jsc$isqi_swapping, jsc$isqi_swapped_io_not_init,
      jsc$isqi_swapped_io_cannot_init, jsc$isqi_swapped_io_completed, jsc$isqi_swapped_out),

    jst$swapped_but_still_in_memory = jsc$isqi_swapped_io_not_init .. jsc$isqi_swapped_io_completed;

*copyc jmt$ijl_ordinal
*DECK DECK=JST$IJL_SWAP_QUEUE_LIST EXPAND=FALSE

{  Define the IJL queue list entry that contains the heads of the chains
{  that run through the IJL table.

  TYPE
    jst$ijl_swap_queue_list_entry = record
      backward_link: jmt$ijl_ordinal,
      forward_link: jmt$ijl_ordinal,
      count: 0 .. jmc$max_ijl_entries,
    recend,

{  Define the IJL swap queue list.

    jst$ijl_swap_queue_list = array [jst$ijl_swap_queue_id] of jst$ijl_swap_queue_list_entry;

*copyc jmt$ijl_ordinal
*copyc jst$ijl_swap_queue_link
*DECK DECK=JST$IO_CONTROL_INFORMATION EXPAND=FALSE
{Define information kept in the AJL to control swap IO initiation

  TYPE
    jst$io_control_information = record
        spd_index: mmt$page_frame_index,
        next_queue_id: mmt$page_frame_queue_id,
        next_pfti: mmt$page_frame_index,
        stop_pfti: mmt$page_frame_index,
        swap_file_descriptor_pfti: mmt$page_frame_index,
    RECEND;

*copyc mmt$page_frame_queue_id
*copyc mmt$page_frame_index
*DECK DECK=JST$RB_JOB_SWAPPING_FUNCTIONS EXPAND=FALSE

{  Define type definitions for monitor request block for job swapping
{  function and the various subfunctions.

  TYPE
    jst$job_swapping_subfunctions = (jsc$jss_swap_job_in, jsc$jss_swap_job_out,
      jsc$jss_advance_swap, jsc$jss_initiate_swapout_io, jsc$jss_special_swapout),

    jst$rb_job_swapping_functions = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      ijl_ordinal: jmt$ijl_ordinal,
      case subfunction: jst$job_swapping_subfunctions of
      = jsc$jss_swap_job_out, jsc$jss_special_swapout =
        swapout_reason: jmt$swapout_reasons,
        memory_needed: mmt$page_frame_index,
      = jsc$jss_initiate_swapout_io =
        flush_all_pages: boolean,
        pages_flushed: mmt$page_frame_index,
      casend,
    recend;

*copyc jmt$delayed_swapin_work
*copyc jmt$ijl_ordinal
*copyc jmt$ijl_swap_status
*copyc jmt$swapout_reasons
*copyc mmt$page_frame_index
*copyc syt$monitor_request_code
*copyc syc$monitor_request_codes
*DECK DECK=JST$SWAPPING_EVENT EXPAND=FALSE
{  Define the various swapping events.

  CONST
    jsc$se_immediate = 0,
    jsc$se_polling = 1000000; {1 second interval}

  TYPE
    jst$swapping_event = jsc$se_immediate .. jsc$se_polling;
*DECK DECK=JST$SWAP_FILE_DESCRIPTOR EXPAND=FALSE
{  Type definition for swap file descriptor.  This is part of the
{  swapped job image on mass storage and describes the swap file contents.

  TYPE
    jst$swap_file_descriptor = record
      ijl_entry: jmt$initiated_job_list_entry,
      swapped_job_entry: jmt$swapped_job_entry,
      swapped_page_descriptors: jst$swapped_page_descriptors,
    recend,

    jst$swapped_page_descriptors = array [0 .. *] of
      jst$swapped_page_descriptor,

    jst$swapped_page_descriptor = record
      pft_entry: mmt$page_frame_table_entry,
      page_table_entry: ost$page_table_entry,
      ast_entry: mmt$active_segment_table_entry,
      entry_updated: boolean,
      old_asid {used on swap in if asid reassigned} : ost$asid,
      changed_asid: jst$changed_asid_entry,
    recend,


{  The changed asid list is NOT logically part of the swapped page descriptor
{  but is imbedded in the same record entry since CYBIL does not
{  currently support record definitions that contain multiple adaptable
{  components.

    jst$changed_asid_entry = RECORD
      old_asid: ost$asid,
      new_asid: ost$asid,
      new_asti: mmt$ast_index,
    RECEND;

*copyc jmt$initiated_job_list_entry
*copyc jmt$swapped_job_entry
*copyc mmt$active_segment_table
*copyc mmt$ast_index
*copyc mmt$page_frame_index
*copyc mmt$page_frame_table
*copyc ost$hardware_subranges
*DECK DECK=JST$SWAP_FILE_PAGE_COUNT EXPAND=FALSE
{Define record used for determining average size of swap files.

  TYPE
    jst$swap_file_page_count = RECORD
      swap_count: 0 .. 0ffffffff(16),
      page_count: 0 .. 0ffffffff(16),
    RECEND;

*DECK DECK=JST$SWAP_FILE_STATISTICS EXPAND=FALSE

   TYPE
     jst$swap_file_statistics = record
       total_pages_per_segment: array [1 .. 40(16)] of integer,
       total_swaps: integer,
     recend;

*DECK DECK=JST$SWAP_STATE_STATISTICS EXPAND=FALSE
{Define statistics kept for time spent in each swap state

  TYPE
    jst$swap_state_statistics = ARRAY [jmt$ijl_swap_status] OF ARRAY [jmt$ijl_swap_status] OF
        jst$swap_state_statistics_entry,
    jst$swap_state_statistics_entry = RECORD
      total_time: integer,
      maximum_time: 0 .. 0ffffffff(16),
      count: 0 .. 0ffffffff(16),
    RECEND;
*copyc jmt$ijl_swap_status
*DECK DECK=JSV$AGE_BEFORE_SWAP_PERCENTAGE EXPAND=FALSE

  VAR
    jsv$age_before_swap_percentage: [XREF] integer;
*DECK DECK=JSV$AGE_JWS_BEFORE_SWAP EXPAND=FALSE

  VAR
    jsv$age_jws_before_swap: [XREF] boolean;
*DECK DECK=JSV$ENABLE_DEBUG_CODE EXPAND=FALSE

  VAR
    jsv$enable_debug_code: [XREF] boolean;

*DECK DECK=JSV$ENABLE_SWAP_FILE_STATISTICS EXPAND=FALSE

   VAR
     jsv$enable_swap_file_statistics: [XREF] boolean;
*DECK DECK=JSV$FREE_WORKING_SET_ON_SWAPOUT EXPAND=FALSE

  VAR
    jsv$free_working_set_on_swapout: [XREF] boolean;

*DECK DECK=JSV$HALT_ON_SWAPIN_FAILURE EXPAND=FALSE


  VAR
    jsv$halt_on_swapin_failure: [XREF] boolean;
*DECK DECK=JSV$IJL_SERIAL_LOCK EXPAND=FALSE

VAR
    jsv$ijl_serial_lock: [XREF] tmt$ptl_lock;

?? PUSH( LISTEXT := ON) ??
*copyc tmt$ptl_lock
?? POP ??
*DECK DECK=JSV$IJL_SWAP_QUEUE_LIST EXPAND=FALSE
 VAR
    jsv$ijl_swap_queue_list: [XREF] jst$ijl_swap_queue_list;

?? PUSH (LISTEXT := ON) ??
*copyc jst$ijl_swap_queue_list
?? POP ??
*DECK DECK=JSV$MAXIMUM_PAGES_TO_SWAP EXPAND=FALSE

   VAR
     jsv$maximum_pages_to_swap: [XREF] integer;
*DECK DECK=JSV$MAX_PAGES_FIRST_SWAP_TASK EXPAND=FALSE

  VAR
    jsv$max_pages_first_swap_task: [XREF] integer;
*DECK DECK=JSV$MAX_TIME_SWAP_IO_COMPLETE EXPAND=FALSE

  VAR
    jsv$max_time_swap_io_complete: [XREF] integer;
*DECK DECK=JSV$MAX_TIME_SWAP_IO_NOT_INIT EXPAND=FALSE

  VAR
    jsv$max_time_swap_io_not_init: [XREF] integer;

*DECK DECK=JSV$PAGES_NEEDED_FOR_SFD EXPAND=FALSE

  VAR
    jsv$pages_needed_for_sfd: [XREF] integer;

*DECK DECK=JSV$SWAPPED_PAGE_ENTRY_SIZE EXPAND=FALSE

  VAR
    jsv$swapped_page_entry_size: [XREF] 0..0ff(16);

*DECK DECK=JSV$SWAP_FILE_PAGE_COUNT EXPAND=FALSE
VAR
    jsv$swap_file_page_count: [XREF] jst$swap_file_page_count;

?? PUSH (LISTEXT := ON) ??
*copyc jst$swap_file_page_count
?? POP ??
*DECK DECK=JSV$SWAP_FILE_STATISTICS EXPAND=FALSE

  VAR
    jsv$swap_file_statistics: [XREF] jst$swap_file_statistics;

*copyc jst$swap_file_statistics
*DECK DECK=JSV$SWAP_STATE_STATISTICS EXPAND=FALSE
  VAR
    jsv$swap_state_statistics: [XREF] jst$swap_state_statistics;

?? PUSH (LISTEXT := ON) ??
*copyc jst$swap_state_statistics
?? POP ??
*DECK DECK=JSV$SWAP_STATUS_ID_ARRAY EXPAND=FALSE
{Define 2 character id used for identifying swap states.

  VAR
      jsv$swap_status_id_array: [static, oss$job_paged_literal, read]
         array [jmt$ijl_swap_status] of string (2) := [
               '  ',   { jmc$iss_null}
               ' R',   { jmc$iss_executing}
               'TI',   { jmc$iss_idle_tasks_initiated}
               'TJ',   { jmc$iss_job_idle_tasks_complete}
               'S0',   { jmc$iss_swapped_no_io}
               'FA',   { jmc$iss_flush_am_pages}
               'AJ',   { jmc$iss_job_allocate_swap_file}
               'AW',   { jmc$iss_wait_allocate_swap_file}
               'AF',   { jmc$iss_allocate_swap_file}
               'JW',   { jmc$iss_wait_job_io_complete}
               'JC',   { jmc$iss_job_io_complete}
               'DW',   { jmc$iss_wait_allocate_sfd}
               'AD',   { jmc$iss_allocate_sfd}
               'SD',   { jmc$iss_swapped_io_cannot_init}
               'OS',   { jmc$iss_initiate_swapout_io}
               'OW',   { jmc$iss_wait_swapout_io_init}
               'OI',   { jmc$iss_swapout_io_initiated}
               'OC',   { jmc$iss_swapout_io_complete}
               'S2',   { jmc$iss_swapped_io_complete}
               'FM',   { jmc$iss_free_swapped_memory}
               ' S',   { jmc$iss_swapout_complete}
               'IR',   { jmc$iss_swapin_requested}
               'IS',   { jmc$iss_swapin_resource_claimed}
               'IW',   { jmc$iss_wait_swapin_io_init}
               'II',   { jmc$iss_swapin_io_initiated}
               'IC'];  { jmc$iss_swapin_io_complete}
?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_swap_status
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=JSV$THINK_EXPIRATION_TIME EXPAND=FALSE

  VAR
    jsv$think_expiration_time: [XREF] integer;
*DECK DECK=JSV$TIME_TO_CALL_JOB_SWAPPER EXPAND=FALSE
{  Time for next periodic call to job swapper from
{mtm$monitor_interrupt_handler.

  VAR
    jsv$time_to_call_job_swapper: [XREF] integer;
*DECK DECK=KEYFILE_180_TO_SIM_FORMAT EXPAND=TRUE

MODULE keyfile_180_to_sim_format;
?? SET (CHKALL := OFF) ??
     {! ! ! no checking ! ! !}
?? PUSH (LISTEXT := ON) ??
*copyc PXIOTYP
*callall biz
*callall fz
?? POP ??
?? SKIP := 3 ??
{--------------------------------------------------------------------}
{              T Y P E S                                     }

  TYPE
    b1 = 0 .. 1,
    b4 = 0 .. 0f(16),
    b8 = 0 .. 0ff(16),
    b16 = 0 .. 0ffff(16),
    b23 = 0 .. 7fffff(16),
    b24 = 0 .. 0ffffff(16),
    b27 = 0 .. 07ffffff(16),
    b32 = 0 .. 0ffffffff(16),
    b12 = 0 .. 0fff(16),
    b15 = 0 .. 7fff(16),
    b7 = 0 .. 7f(16),
    b20 = 0 .. 0fffff(16);

  CONST
    bufsize = 100,
    sh4 = 10(16),
    s8 = 100(16),
    s16 = 10000(16),
    s24 = 1000000(16),
    s12 = 1000(16),
    s20 = 100000(16);


  TYPE
    pmf_record_type = (pmfr_keypoint, pmfr_overflow),
    pmf_record = record
      rec_type: pmf_record_type,
      time: 0 .. 3ffffff(16),
      class: 0 .. 0f(16),
      kcode: 0 .. 0ffffffff(16),
    recend;


  TYPE
    simblock = record
      s1,
      s2,
      s3,
      s4,
      s5,
      s6,
      s7: pmf_record,
    recend,
    packed_b56 = packed record
      f1: b4,
      o1: pmf_record_type,
      t1: b27,
      c1: b4,
      d1l: b24,
      f2: b4,
      d1r: b8,
      o2: pmf_record_type,
      t2: b27,
      c2: b4,
      d2l: b16,
      f3: b4,
      d2r: b16,
      o3: pmf_record_type,
      t3: b27,
      c3: b4,
      d3l: b8,
      f4: b4,
      d3r: b24,
      o4: pmf_record_type,
      t4: b27,
      c4: b4,
      f5: b4,
      d4: b32,
      o5: pmf_record_type,
      t5l: b23,
      f6: b4,
      t5r: b4,
      c5: b4,
      d5: b32,
      o6: pmf_record_type,
      t6l: b15,
      f7: b4,
      t6r: b12,
      c6: b4,
      d6: b32,
      o7: pmf_record_type,
      t7l: b7,
      f8: b4,
      t7r: b20,
      c7: b4,
      d7: b32,
    recend;

?? EJECT ??

  PROCEDURE convert (VAR h: packed_b56;
    VAR s: simblock);
    s.s1.rec_type := h.o1;
    s.s1.time := h.t1;
    s.s1.class := h.c1;
    s.s1.kcode := h.d1l * s8 + h.d1r;
    s.s2.rec_type := h.o2;
    s.s2.time := h.t2;
    s.s2.class := h.c2;
    s.s2.kcode := h.d2l * s16 + h.d2r;
    s.s3.rec_type := h.o3;
    s.s3.time := h.t3;
    s.s3.class := h.c3;
    s.s3.kcode := h.d3l * s24 + h.d3r;
    s.s4.rec_type := h.o4;
    s.s4.time := h.t4;
    s.s4.class := h.c4;
    s.s4.kcode := h.d4;
    s.s5.rec_type := h.o5;
    s.s5.time := h.t5l * sh4 + h.t5r;
    s.s5.class := h.c5;
    s.s5.kcode := h.d5;
    s.s6.rec_type := h.o6;
    s.s6.time := h.t6l * s12 + h.t6r;
    s.s6.class := h.c6;
    s.s6.kcode := h.d6;
    s.s7.rec_type := h.o7;
    s.s7.time := h.t7l * s20 + h.t7r;
    s.s7.class := h.c7;
    s.s7.kcode := h.d7;
  PROCEND convert;
?? EJECT ??

  PROGRAM [XDCL] main;

    VAR
      inbuf: array [1 .. bufsize] of packed_b56,
      outbuf: array [1 .. bufsize] of simblock,
      keypoints: integer,
      r: [STATIC] array [0 .. 7] of integer := [0, 0, 1, 2, 3, 4, 5, 6],
      words: integer,
      infile: file,
      outfile: file,
      i: integer;

    bi#open (infile, 'keyfile', old#, input#, first#);
    bi#open (outfile, 'sessmkf', new#, output#, first#);

    bi#get (infile, #LOC (inbuf), #SIZE (inbuf));
    f#words (infile, words);
    WHILE words <> 0 DO
      FOR i := 1 TO bufsize DO
        convert (inbuf [i], outbuf [i]);
      FOREND;
      keypoints := (words DIV 8) * 7 + r [words MOD 8];
      bi#put (outfile, #LOC (outbuf), #SIZE (pmf_record) * keypoints);
      bi#get (infile, #LOC (inbuf), #SIZE (inbuf));
      f#words (infile, words);
    WHILEND;

    bi#close (infile, first#);
    bi#close (outfile, first#);
  PROCEND main;
MODEND
*DECK DECK=KEYPOINT_FILE_PROCESSOR EXPAND=TRUE
MODULE keypoint_file_processor;

  CONST
    c_time = 2,
    c_timedif = 16,
    c_data = 25,
    c_dataerr = 37,
    c_dataid = 38,
    c_exclam = 47,
    c_trap = 48,
    c_mtrflag = 49,
    c_taskord = 51,
    c_levelzero = 54,
    c_section = 55,
    c_classid = 58,
    c_msg = 61,
    single_quote_code = 39;

*copyc osd$keypoints
*copyc OSK$KEYPOINT_CLASS_CODES

  TYPE
    keypoint_class_set = set of char,
    p_task_status = ^task_status_type,
    task_status_type = packed record
      mtrmode: boolean,
      traprtn: array [boolean] of boolean,
      time: integer,
    recend,
    pmf_record_type = (pmfr_keypoint, pmfr_overflow),
    pmf_record = record
      rec_type: pmf_record_type,
      time: 0 .. 3ffffff(16),
      class: 0 .. 0f(16),
      kcode: 0 .. 0ffffffff(16),
    recend,
    range_of_osk$m = 0 .. (osk$m - 1),
    flags = string (1),
    p_keypoint_rec = ^keypoint_rec,
    keypoint_rec = record
      class: 0 .. 16,
      data_length: range_of_osk$m,
      flag: flags,
      match_length: range_of_osk$m,
      match_value: range_of_osk$m,
      data_formatting: char,
      p_next: p_keypoint_rec,
      data_id: string (8),
      msg: string (40),
      count: integer,
    recend,
    area_keypoints = packed array [ * ] of p_keypoint_rec,
    p_area_keypoints = ^area_keypoints,
    p_area_rec_type = ^area_rec,
    area_rec = record
      section_id: string (31),
      low_base,
      high_base: range_of_osk$m,
      keypoint_array: p_area_keypoints,
      p_next: p_area_rec_type,
    recend,
    base_rec = record
      id: string (31),
      value: integer,
    recend,
    descriptor_code_array = packed array [char] of 0 .. 16;

?? SET (CHKALL := OFF) ??
?? PUSH (LISTEXT := ON) ??
*copyc PXIOTYP
*callall  lgz
*callall biz
*callall fz
?? POP ??
?? EJECT ??
{--------------------------------------------------------------------}
{--------------------------------------------------------------------}

  VAR
    current_class_code: array [0 .. 15] of char := [REP 16 of '*'],
    bases: array [1 .. 4] of base_rec := [['OSK$SYSTEM_CLASS',
      osk$system_class], ['OSK$PRODUCT_SET_CLASS', osk$product_set_class], [
      'OSK$USER_CLASS', osk$user_class], ['OSK$PMF_CONTROL', osk$pmf_control]],
    descriptor_code: descriptor_code_array,
    task_status_array: array [0 .. 255] of task_status_type,
    taskindex: integer,
    set_of_classes: keypoint_class_set,
    size_array: array [0 .. 52] of integer,
    maxprocid: integer,
    ignore_undefined: boolean,
    task_status: p_task_status,
    keybuf: array [1 .. 100] of pmf_record,
    keyindex,
    maxkeyindex: integer,
    descriptor_file,
    keyfile: file,
    kp: pmf_record,
    outline: string (136),
    p_descriptor: p_area_rec_type,
    listfile: file,
    mark: file_mark,
    tokl,
    lnlimit,
    i,
    j,
    int: integer,
    simicolon_found: boolean,
    input_line: string (136),
    tok: string (33);

?? EJECT ??
{--------------------------------------------------------------------}

{--------------------------------------------------------------------}

  PROCEDURE error (st: string ( * ));

    write_outline (' * * * * error - ');
    write_outline (st);

  PROCEND error;

?? EJECT ??
{------------------------------------------------------------------}
{------------------------------------------------------------------}

  PROCEDURE bcdtobin (str: string ( * );
        xlen: integer;
    VAR inperr: range_of_osk$m);

    VAR
      len: integer,
      base: range_of_osk$m,
      strbase: string (15),
      ch: char,
      i,
      k: integer;

    int := 0;
    len := xlen;
    IF len = 0 THEN
      RETURN;
    IFEND;

    IF str (len) = ')' THEN
      i := 1;
      WHILE str (i) <> '(' DO
        i := i + 1;
        IF i = len THEN
          error ('invalid base');
          write_outline (str);
          inperr := 1;
          RETURN;
        IFEND;
      WHILEND;
      strbase (1, len - i - 1) := str (i + 1, len - i - 1);
      bcdtobin (strbase, len - i - 1, base);
      len := i - 1;
    ELSE
      base := 10;
    IFEND;

    i := 1;
    WHILE i <= len DO
      ch := str (i);
      k := ORD (ch) - ORD ('0');
      IF (k > 9) OR (k < 0) THEN
        k := ORD (ch) - ORD ('A') + 10;
      IFEND;

      IF (k < 0) OR (k >= base) THEN
        inperr := 1;
        error ('non numeric in numeric field');
        write_outline (str);
        RETURN;
      IFEND;
      int := int * base + k;
      i := i + 1;
    WHILEND;


    inperr := int;
  PROCEND bcdtobin;

?? EJECT ??
{--------------------------------------------------------------------}

  PROCEDURE bintohex (VAR s: string ( * );
        xi: integer);

    VAR
      i,
      j,
      k: integer;

    j := STRLENGTH (s);
    i := xi;
    FOR k := 1 TO j DO
      s (k) := ' ';
    FOREND;

    REPEAT
      k := i MOD 16;
      IF k <= 9 THEN
        s (j) := CHR (k + ORD ('0'));
      ELSE
        s (j) := CHR (k - 10 + ORD ('A'));
      IFEND;
      i := i DIV 16;
      j := j - 1;
    UNTIL (j = 0);

  PROCEND bintohex;
?? SKIP := 3 ??

?? EJECT ??
{------------------------------------------------------------------}
{------------------------------------------------------------------}

  PROCEDURE bintodec (VAR s: string ( * );
        xi: integer);

    VAR
      neg: char,
      i,
      j,
      k: integer;

    j := STRLENGTH (s);
    i := xi;
    IF i < 0 THEN
      i := 0 - i;
      neg := '-';
    ELSE
      neg := ' ';
    IFEND;
    FOR k := 1 TO j DO
      s (k) := ' ';
    FOREND;

    REPEAT
      k := i MOD 10;
      IF k <= 9 THEN
        s (j) := CHR (k + ORD ('0'));
      ELSE
        s (j) := CHR (k - 10 + ORD ('A'));
      IFEND;
      i := i DIV 10;
      j := j - 1;
    UNTIL (j = 0) OR ((i = 0));
    IF j <> 0 THEN
      s (j) := neg;
    IFEND;

  PROCEND bintodec;
?? SKIP := 3 ??

?? EJECT ??
{------------------------------------------------------------------}
{------------------------------------------------------------------}

  PROCEDURE bintoascii (VAR s: string ( * );
        xi: integer);

    VAR
      i,
      j,
      k: integer;

    j := STRLENGTH (s);
    i := xi;
    FOR k := 1 TO j DO
      s (k) := ' ';
    FOREND;

    REPEAT
      k := i MOD 256;
      i := i DIV 256;
      IF k = 0 THEN
        s (j) := ' ';
      ELSE
        s (j) := CHR (k);
      IFEND;
      j := j - 1;
    UNTIL (j = 0) OR (i = 0);

  PROCEND bintoascii;

?? EJECT ??
{-----------------------------------------------------------------}
{-----------------------------------------------------------------}

  PROCEDURE gettoken (VAR input_line: string ( * );
    VAR inx: integer;
    VAR buf: string ( * );
    VAR len: integer);




    VAR
      i: integer,
      comflag: boolean;

    len := STRLENGTH (buf);
    FOR i := 1 TO len DO
      buf (i) := ' ';
    FOREND;

    comflag := FALSE;
    len := 0;

  /scanloop/

    WHILE TRUE DO
      WHILE (inx <> STRLENGTH (input_line)) AND (input_line (inx) = ' ') DO
        inx := inx + 1;
      WHILEND;
      IF inx = STRLENGTH (input_line) THEN
        IF mark = data# THEN
          input_line := ' ';
          lg#get (descriptor_file, lnlimit, input_line);
          f#mark (descriptor_file, mark);
          inx := 1;
          CYCLE /scanloop/;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      IF (input_line (inx) = ',') AND (comflag = FALSE) THEN
        comflag := TRUE;
        inx := inx + 1;

        CYCLE /scanloop/;
      IFEND;
      EXIT /scanloop/;
    WHILEND /scanloop/;


    WHILE (inx <> STRLENGTH (input_line)) AND ((input_line (inx) <> ' ') AND
          (input_line (inx) <> ',')) DO
      len := len + 1;

      IF (ORD (input_line (inx)) < ORD ('a')) OR (ORD (input_line (inx)) > ORD
            ('z')) THEN
        buf (len) := input_line (inx);
      ELSE
        buf (len) := CHR (ORD (input_line (inx)) - (ORD ('a') - ORD ('A')));
      IFEND;
      inx := inx + 1;
    WHILEND;


  PROCEND gettoken;

?? EJECT ??
{-----------------------------------------------------------------}
{-----------------------------------------------------------------}

  PROCEDURE read_descriptor (VAR p_descriptor: p_area_rec_type;
    VAR descriptor_file: file);

    VAR
      current_p_descriptor: p_area_rec_type;

    lg#open (descriptor_file, 'KEYDESC', old#, input#, first#);
    p_descriptor := NIL;
    REPEAT
      input_line := ' ';
      lg#get (descriptor_file, lnlimit, input_line);
      f#mark (descriptor_file, mark);
      j := 1;
      pass_space (j);
      IF input_line (j, * ) = '{$$$ START KEYPOINT CLASSES $$$}' THEN
        parse_defn_line (input_line, descriptor_file, descriptor_code);
      IFEND;
      IF input_line (j, * ) = '{$$$ START KEYPOINT IDENTIFIER BASES $$$}' THEN
        get_list_of_func_areas (input_line, descriptor_file, p_descriptor);
      IFEND;
      IF input_line (j, * ) = '{$$$ START KEYPOINT DESCRIPTIONS $$$}' THEN
        current_p_descriptor := p_descriptor;
        generate_keypoint_records (input_line, descriptor_file, p_descriptor,
              current_p_descriptor);
      IFEND;
    UNTIL (mark <> data#);
    lg#close (descriptor_file, first#);
  PROCEND read_descriptor;

?? EJECT ??
{----------------------------------------------------------------}
{----------------------------------------------------------------}

  PROCEDURE get_list_of_func_areas (VAR input_line: string ( * );
        descriptor_file: file;
    VAR p_area_rec: p_area_rec_type);

    VAR
      termination_found: boolean,
      i,
      j,
      k,
      lnlimit: integer,
      temp_p_area_rec: p_area_rec_type;

    PROCEDURE get_empty_area_rec (VAR p_area_rec: p_area_rec_type);
      ALLOCATE p_area_rec;
      IF p_area_rec = NIL THEN
        FOR i := 1 TO 20 DO
          write_outline ('need more memory');
        FOREND;
      ELSE
        p_area_rec^.section_id := '     ';
        p_area_rec^.low_base := 0;
        p_area_rec^.high_base := 0;
        p_area_rec^.keypoint_array := NIL;
        p_area_rec^.p_next := NIL;
      IFEND;
    PROCEND get_empty_area_rec;
    termination_found := FALSE;
    WHILE (NOT termination_found) AND (mark = data#) DO
      REPEAT
        j := 1;
        input_line := ' ';
        lg#get (descriptor_file, lnlimit, input_line);
        f#mark (descriptor_file, mark);
        k := 1;
        pass_space (k);
        termination_found := input_line (k, * ) =
          '{$$$ END KEYPOINT IDENTIFIER BASES $$$}';
        gettoken (input_line, j, tok, tokl);
      UNTIL (tok (3, 2) = 'K$') OR (mark <> data#) OR termination_found;
      IF tok (3, 2) = 'K$' THEN
        get_empty_area_rec (temp_p_area_rec);
        parse_area_line (input_line, temp_p_area_rec);
        temp_p_area_rec^.p_next := p_area_rec;
        p_area_rec := temp_p_area_rec;
        input_line := ' ';
      IFEND;
    WHILEND;
  PROCEND get_list_of_func_areas;

?? EJECT ??
{----------------------------------------------------------------}
{----------------------------------------------------------------}

  PROCEDURE parse_defn_line (VAR input_line: string ( * );
        descriptor_file: file;
    VAR descriptor_code: descriptor_code_array);

    VAR
      termination_found: boolean,
      j,
      k,
      base: integer,
      offset: range_of_osk$m,
      code_count: integer;

    set_of_classes := $keypoint_class_set [];
    termination_found := FALSE;
    code_count := 1;
    WHILE (NOT termination_found) AND (mark = data#) DO
      REPEAT
        input_line := ' ';
        lg#get (descriptor_file, lnlimit, input_line);
        f#mark (descriptor_file, mark);
        j := 1;
        k := 1;
        gettoken (input_line, j, tok, tokl);
        pass_space (k);
        termination_found := input_line (k, * ) =
          '{$$$ END KEYPOINT CLASSES $$$}';
      UNTIL (tok (3, 2) = 'K$') OR (mark <> data#) OR termination_found;
      IF tok (3, 2) = 'K$' THEN
        gettoken (input_line, j, tok, tokl);
        gettoken (input_line, j, tok, tokl);
        base := 16;
        FOR i := 1 TO UPPERBOUND (bases) DO
          IF tok = bases [i].id THEN
            base := bases [i].value;
          IFEND;
        FOREND;
        gettoken (input_line, j, tok, tokl);
        gettoken (input_line, j, tok, tokl);
        IF tokl > 1 THEN
          bcdtobin (tok, tokl - 1, offset);
        ELSE
          bcdtobin (tok, 1, offset);
        IFEND;
        gettoken (input_line, j, tok, tokl);
        IF base + offset < 16 THEN
          descriptor_code [tok (2)] := base + offset;
          set_of_classes := set_of_classes + $keypoint_class_set [tok (2)];
          current_class_code [base + offset] := tok (2);
        ELSE
          descriptor_code [tok (2)] := 16;
        IFEND;
        code_count := code_count + 1;
      IFEND;
    WHILEND;
  PROCEND parse_defn_line;

?? EJECT ??
{------------------------------------------------------------------}
{------------------------------------------------------------------}

  PROCEDURE parse_area_line (VAR input_line: string ( * );
        p_area_rec: p_area_rec_type);

    VAR
      j: integer;

    j := 1;
    gettoken (input_line, j, tok, tokl);
    p_area_rec^.section_id := tok;
    simicolon_found := FALSE;
    WHILE (tok (1) <> '{') AND (j < 100) DO
      IF tok (tokl, 1) = ';' THEN
        simicolon_found := TRUE;
      IFEND;
      gettoken (input_line, j, tok, tokl);
    WHILEND;
    tok (1, 1) := '0';
    bcdtobin (tok, tokl, p_area_rec^.low_base);
    gettoken (input_line, j, tok, tokl);
    gettoken (input_line, j, tok, tokl);
    bcdtobin (tok, tokl - 1, p_area_rec^.high_base);
  PROCEND parse_area_line;

?? EJECT ??
{-----------------------------------------------------------------}
{-----------------------------------------------------------------}

  PROCEDURE generate_keypoint_records (VAR input_line: string ( * );
        descriptor_file: file;
        p_descriptor: p_area_rec_type;
    VAR current_p_descriptor: p_area_rec_type);

    VAR
      termination_found: boolean,
      offset: range_of_osk$m,
      k: integer,
      p_descriptor_record: p_keypoint_rec;

    current_p_descriptor := p_descriptor;
    termination_found := FALSE;
    tok := ' ';
    WHILE (NOT termination_found) AND (mark = data#) DO
      IF tok (3, 2) <> 'K$' THEN
        REPEAT
          input_line := ' ';
          lg#get (descriptor_file, lnlimit, input_line);
          f#mark (descriptor_file, mark);
          j := 1;
          gettoken (input_line, j, tok, tokl);
          k := 1;
          pass_space (k);
          termination_found := input_line (k, * ) =
            '{$$$ END KEYPOINT DESCRIPTIONS $$$}';
        UNTIL (tok (3, 2) = 'K$') OR (mark <> data#) OR termination_found;
      IFEND;
      IF tok (3, 2) = 'K$' THEN
        parse_keypoint_line (input_line, p_descriptor, current_p_descriptor,
              offset);
        input_line := ' ';
        lg#get (descriptor_file, lnlimit, input_line);
        f#mark (descriptor_file, mark);
        k := 1;
        WHILE (input_line (k) = ' ') AND (k < 132) DO
          k := k + 1;
        WHILEND;
        termination_found := input_line (k, * ) =
          '{$$$ END KEYPOINT DESCRIPTIONS $$$}';
        j := 1;
        IF k < 132 THEN
          gettoken (input_line, j, tok, tokl);
        ELSE
          tok := ' ';
        IFEND;
        WHILE (offset >= 0) AND (mark = data#) AND (j <= 132) AND (tok (1, 1) =
              '{') AND (tok (2, 1) IN set_of_classes) DO
          parse_descriptor_line (input_line, p_descriptor_record);
          IF (p_descriptor <> NIL) AND (current_p_descriptor <> NIL) THEN
            IF current_p_descriptor^.keypoint_array = NIL THEN
              ALLOCATE current_p_descriptor^.keypoint_array:
                    [current_p_descriptor^.low_base .. current_p_descriptor^.
                    high_base];
              IF current_p_descriptor^.keypoint_array = NIL THEN
                FOR i := 1 TO 20 DO
                  write_outline ('need more memory');
                FOREND;
              ELSE
                FOR i := current_p_descriptor^.low_base TO
                      current_p_descriptor^.high_base DO
                  current_p_descriptor^.keypoint_array^ [i] := NIL;
                FOREND;
              IFEND;
            IFEND;
            IF (current_p_descriptor^.keypoint_array <> NIL) AND
                  ((current_p_descriptor^.low_base + offset) <=
                  current_p_descriptor^.high_base) THEN
              p_descriptor_record^.p_next := current_p_descriptor^.
                    keypoint_array^ [offset + current_p_descriptor^.low_base];
              current_p_descriptor^.keypoint_array^ [offset +
                    current_p_descriptor^.low_base] := p_descriptor_record;
              bintodec (tok, offset + current_p_descriptor^.low_base);
              p_descriptor_record := current_p_descriptor^.keypoint_array^
                    [offset + current_p_descriptor^.low_base];
            IFEND;
          IFEND;
          input_line := ' ';
          lg#get (descriptor_file, lnlimit, input_line);
          f#mark (descriptor_file, mark);
          k := 1;
          WHILE (input_line (k) = ' ') AND (k < 132) DO
            k := k + 1;
          WHILEND;
          termination_found := input_line (k, * ) =
            '{$$$ END KEYPOINT DESCRIPTIONS $$$}';
          j := 1;
          IF k < 132 THEN
            gettoken (input_line, j, tok, tokl);
          ELSE
            tok := ' ';
          IFEND;
        WHILEND;
      IFEND;
    WHILEND;
  PROCEND generate_keypoint_records;

?? EJECT ??
{------------------------------------------------------------------}
{------------------------------------------------------------------}

  PROCEDURE parse_keypoint_line (VAR input_line: string ( * );
        p_descriptor: p_area_rec_type;
    VAR current_p_descriptor: p_area_rec_type;
    VAR offset: range_of_osk$m);
    offset := 0;
    j := 1;
    REPEAT
      gettoken (input_line, j, tok, tokl);
    UNTIL (tok = '=') OR (j > 130);
    IF tok <> '=' THEN
      RETURN
    IFEND;
    gettoken (input_line, j, tok, tokl);
    IF (tok (tokl) = ',') OR (tok (tokl) = ';') THEN
      tok (tokl) := ' ';
      j := j - 1;
      tokl := tokl - 1;
    IFEND;
    IF (tok <> current_p_descriptor^.section_id) THEN
      search (p_descriptor, tok, current_p_descriptor);
      IF current_p_descriptor = NIL THEN
        current_p_descriptor := p_descriptor;
        RETURN;
      IFEND;
    IFEND;
    pass_space (j);
    IF input_line (j, 1) <> '+' THEN
      offset := 0;
    ELSE
      j := j + 1;
      gettoken (input_line, j, tok, tokl);
      IF (tok (tokl) = ',') OR (tok (tokl) = ';') THEN
        bcdtobin (tok, tokl - 1, offset);
      ELSE
        bcdtobin (tok, tokl, offset);
      IFEND;
    IFEND;
  PROCEND parse_keypoint_line;

?? EJECT ??
{-----------------------------------------------------------------}
{-----------------------------------------------------------------}

  PROCEDURE search (p_descriptor: p_area_rec_type;
        tok: string ( * );
    VAR current_p_descriptor: p_area_rec_type);
    current_p_descriptor := p_descriptor;
    WHILE (current_p_descriptor <> NIL) AND (current_p_descriptor^.section_id
          <> tok) DO
      current_p_descriptor := current_p_descriptor^.p_next;
    WHILEND;
  PROCEND search;

?? EJECT ??
{------------------------------------------------------------------}
{------------------------------------------------------------------}

  PROCEDURE parse_descriptor_line (VAR input_line: string ( * );
    VAR p_descriptor_record: p_keypoint_rec);

    VAR
      loc: integer;

    p_descriptor_record := NIL;
    loc := 1;
    WHILE (loc < 132) AND (input_line (loc) = ' ') DO
      loc := loc + 1;
    WHILEND;
    IF input_line (loc) <> '{' THEN
      RETURN
    IFEND;
    loc := loc + 1;
    IF input_line (loc) IN set_of_classes THEN
      gen_keypoint_descriptor_record (p_descriptor_record);
      p_descriptor_record^.class := descriptor_code [input_line (loc)];
      loc := loc + 1;
      pass_space (loc);
      IF (input_line (loc) = 'M') OR (input_line (loc) = 'N') OR (input_line
            (loc) = 'S') OR (input_line (loc) = 'T') THEN
        p_descriptor_record^.flag := input_line (loc);
        loc := loc + 1;
        pass_space (loc);
      IFEND;
      IF ORD (input_line (loc)) <> single_quote_code THEN
        gettoken (input_line, loc, tok, tokl);
        j := 1;
        WHILE (tok (j) <> '.') AND (j <= tokl) DO
          j := j + 1;
        WHILEND;
        bcdtobin (tok (1, j - 1), j - 1, p_descriptor_record^.match_length);
        bcdtobin (tok (j + 1, * ), tokl - j, p_descriptor_record^.match_value);
        loc := loc + 1;
        pass_space (loc);
      IFEND;
      i := 1;
      loc := loc + 1;
      WHILE (ORD (input_line (loc)) <> single_quote_code) AND (loc < 132) DO
        IF i < 41 THEN
          p_descriptor_record^.msg (i) := input_line (loc, 1);
          i := i + 1;
        IFEND;
        loc := loc + 1;
      WHILEND;
      loc := loc + 1;
      pass_space (loc);
      IF ORD (input_line (loc)) = single_quote_code THEN
        loc := loc + 1;
        i := 1;
        WHILE (ORD (input_line (loc)) <> single_quote_code) AND (loc < 132) DO
          IF i < 9 THEN
            p_descriptor_record^.data_id (i) := input_line (loc, 1);
            i := i + 1;
          IFEND;
          loc := loc + 1;
        WHILEND;
        loc := loc + 1;
        pass_space (loc);
        IF (input_line (loc) = 'A') OR (input_line (loc) = 'H') OR (input_line
              (loc) = 'I') THEN
          p_descriptor_record^.data_formatting := input_line (loc);
          loc := loc + 1;
          gettoken (input_line, loc, tok, tokl);
          IF tokl > 0 THEN
            IF tok (tokl) = '}' THEN
              bcdtobin (tok, tokl - 1, p_descriptor_record^.data_length);
            ELSE
              bcdtobin (tok, tokl, p_descriptor_record^.data_length);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND parse_descriptor_line;

?? EJECT ??
{___________
{------------------------------------------------------------------}
{------------------------------------------------------------------}

  PROCEDURE pass_space (VAR loc: integer);
    WHILE (input_line (loc) = ' ') AND (loc < 132) DO
      loc := loc + 1;
      IF (loc = 132) AND (mark = data#) THEN
        input_line := ' ';
        lg#get (descriptor_file, lnlimit, input_line);
        f#mark (descriptor_file, mark);
        loc := 1;
      IFEND;
    WHILEND;
  PROCEND pass_space;

?? EJECT ??
{------------------------------------------------------------------}
{------------------------------------------------------------------}

  PROCEDURE gen_keypoint_descriptor_record (VAR p_descriptor_record:
    p_keypoint_rec);
    ALLOCATE p_descriptor_record;
    IF p_descriptor_record = NIL THEN
      FOR i := 1 TO 20 DO
        write_outline ('need more memory');
      FOREND;
    ELSE
      p_descriptor_record^.class := 16;
      p_descriptor_record^.data_length := 0;
      p_descriptor_record^.flag := ' ';
      p_descriptor_record^.p_next := NIL;
      p_descriptor_record^.match_length := 0;
      p_descriptor_record^.match_value := 0;
      p_descriptor_record^.msg := ' ';
      p_descriptor_record^.data_formatting := 'I';
      p_descriptor_record^.data_id := ' ';
      p_descriptor_record^.count := 0;
    IFEND;
  PROCEND gen_keypoint_descriptor_record;
?? EJECT ??
{--------------------------------------------------------------------}

  PROCEDURE init_task_status;

    VAR
      i: integer;

    FOR i := 0 TO UPPERBOUND (task_status_array { 1} ) DO
      task_status_array [i].mtrmode := TRUE;
      task_status_array [i].traprtn [FALSE] := FALSE;
      task_status_array [i].traprtn [TRUE] := FALSE;
      task_status_array [i].time := 0;
    FOREND;

  PROCEND init_task_status;
?? EJECT ??
{--------------------------------------------------------------------}
{--------------------------------------------------------------------}

  PROCEDURE write_outline (outline: string ( * ));

    VAR
      i: integer;

    i := STRLENGTH (outline);
    WHILE outline (i) = ' ' DO
      i := i - 1;
    WHILEND;
    IF i <> 0 THEN
      lg#put (listfile, outline (1, i));
    IFEND;

  PROCEND write_outline;
?? EJECT ??
{--------------------------------------------------------------------}

  PROCEDURE print_keypoint_summary;

    VAR
      i: integer,
      area: p_area_rec_type,
      keypoint_rec: p_keypoint_rec,
      s8: string (8);

    lg#put (listfile, '1keypoint summary');
    outline := '  ';
    area := p_descriptor;
    WHILE area <> NIL DO
      IF area^.keypoint_array <> NIL THEN
        FOR i := area^.low_base TO area^.high_base DO
          keypoint_rec := area^.keypoint_array^ [i];
          WHILE keypoint_rec <> NIL DO
            IF keypoint_rec^.count <> 0 THEN
              bintodec (s8, keypoint_rec^.count);
              keypoint_rec^.count := 0;
              outline (10, 8) := s8;
              outline (20, 2) := area^.section_id (1, 2);
              outline (23) := current_class_code [keypoint_rec^.class];
              outline (25, 40) := keypoint_rec^.msg;
              write_outline (outline);
            IFEND;
            keypoint_rec := keypoint_rec^.p_next;
          WHILEND;
        FOREND;
      IFEND;
      area := area^.p_next;
    WHILEND;

  PROCEND print_keypoint_summary;
?? EJECT ??
{--------------------------------------------------------------------}

  PROCEDURE get_keypoint (VAR kp: pmf_record;
        inc: boolean;
    VAR eofflag: boolean);

    IF keyindex > maxkeyindex THEN
      bi#get (keyfile, #LOC (keybuf), #SIZE (keybuf));
      f#words (keyfile, maxkeyindex);
      IF maxkeyindex = 0 THEN
        eofflag := TRUE;
        RETURN;
      IFEND;
      maxkeyindex := maxkeyindex DIV #SIZE (keybuf [1]);
      keyindex := 1;
    IFEND;
    kp := keybuf [keyindex];
    eofflag := FALSE;
    IF inc THEN
      keyindex := keyindex + 1;
    IFEND;

  PROCEND get_keypoint;
?? EJECT ??
{--------------------------------------------------------------------}

  PROCEDURE keypoint_not_found (VAR kp: pmf_record);

    VAR
      s8: string (8);

    bintohex (s8, kp.class);

    outline (c_section, 2) := s8 (7, 2);
    bintohex (s8, kp.kcode);
    outline (c_data, 4) := '    ';
    outline (c_data + 4, 8) := s8;
    outline (c_dataid, 8) := '        ';
    bintodec (s8, (kp.kcode MOD osk$m));
    outline (c_msg, * ) := s8;

  PROCEND keypoint_not_found;
?? EJECT ??
{--------------------------------------------------------------------}

  PROCEDURE keypoint_found (VAR kp: pmf_record;
    VAR descp: p_keypoint_rec;
    VAR area: p_area_rec_type);

    VAR
      data_value: integer,
      kp2: pmf_record,
      indent_180: [STATIC] array [0 .. 15] of integer := [0, 0, 2, 2, 4, 0, 0,
        0, 0, 0, 0, 0, 0, 0, 0, 0],
      indent: integer,
      eofflag: boolean,
      s14: string (14);

    outline (c_section, 2) := area^.section_id;
    data_value := kp.kcode DIV osk$m;
    IF descp^.data_length > 20 THEN
      get_keypoint (kp2, FALSE, eofflag);
      IF NOT eofflag AND (current_class_code [kp2.class] = ' ') THEN
        get_keypoint (kp2, TRUE, eofflag);
        data_value := data_value * 100000000(16) + kp2.kcode;
      ELSE
        outline (c_dataerr) := '*';
      IFEND;
    IFEND;
    CASE descp^.data_formatting OF
    = 'I' =
      bintodec (s14, data_value);
    = 'H' =
      bintohex (s14, data_value);
    = 'A' =
      bintoascii (s14, data_value);
    ELSE
      s14 := '              ';
    CASEND;

  /lp3/
    FOR i := 1 TO 14 - descp^.data_length * 2 DO
      IF s14 (i) <> '0' THEN
        EXIT /lp3/;
      IFEND;
      s14 (i) := ' ';
    FOREND /lp3/;
    outline (c_data, 12) := s14 (3, 12);
    outline (c_dataid, 8) := descp^.data_id;
    outline (c_msg, 16) := '                ';
    IF (descp^.flag = 'T') OR (descp^.flag = 'M') THEN
      indent := 0;
    ELSE
      indent := indent_180 [kp.class];
    IFEND;
    outline (c_msg + indent, 40) := descp^.msg;

  PROCEND keypoint_found;
?? EJECT ??
{--------------------------------------------------------------------}

  PROCEDURE process_keypoint (VAR kp: pmf_record);

    CONST
      q = 1000000(16); {1/4th the range of kp.time}

    VAR
      s16: string (16),
      bias1: [STATIC] integer := 0,
      bias2: [STATIC] integer := 0,
      rel_time: integer,
      last_rel_time: [STATIC] integer := 0,
      area: p_area_rec_type,
      descp: p_keypoint_rec;

    outline := ' ';
    outline (c_dataerr) := ' ';
    outline (c_exclam) := '!';
    outline (c_levelzero) := ' ';
    area := p_descriptor;
    descp := NIL;

  /lp5/
    WHILE area <> NIL DO
      IF ((area^.low_base <= (kp.kcode MOD osk$m)) AND (area^.high_base >= (kp.
            kcode MOD osk$m))) AND (area^.keypoint_array <> NIL) THEN
        descp := area^.keypoint_array^ [(kp.kcode MOD osk$m)];
        WHILE (descp <> NIL) AND ((descp^.class <> kp.class) OR (descp^.
              match_value <> ((kp.kcode DIV osk$m) MOD size_array [descp^.
              match_length]))) DO
          descp := descp^.p_next;
        WHILEND;
        IF descp <> NIL THEN
          EXIT /lp5/;
        IFEND;
      IFEND;
      area := area^.p_next;
    WHILEND /lp5/;
    IF (descp = NIL) AND (ignore_undefined) THEN
      RETURN;
    IFEND;

    IF descp <> NIL THEN
      descp^.count := descp^.count + 1;

      IF (descp^.class = osk$entry) AND (descp^.flag = 'T') THEN
        task_status^.traprtn [task_status^.mtrmode] := TRUE;
      IFEND;
      IF (descp^.class = osk$entry) AND (descp^.flag = 'M') THEN
        task_status^.mtrmode := FALSE; {entry to job means exit mtr}
      IFEND;
    IFEND;

    rel_time := kp.time + bias1;
    IF kp.time < q THEN
      rel_time := rel_time + bias2;
    ELSEIF kp.time < (2 * q) THEN
      rel_time := rel_time + bias2;
      bias1 := bias1 + bias2;
      bias2 := 0;
    ELSEIF kp.time < (3 * q) THEN
      bias1 := bias1 + bias2;
      bias2 := 0;
    ELSE
      bias2 := 4 * q;
    IFEND;
    bintodec (s16, rel_time);
    outline (c_time, 13) := s16 (4, 13);
    bintohex (s16, taskindex);
    outline (c_taskord, 2) := s16 (15, 2);
    bintodec (s16, rel_time - last_rel_time);
    outline (c_timedif, 8) := s16 (9, 8);
    last_rel_time := rel_time;
    IF task_status^.mtrmode THEN
      outline (c_mtrflag) := 'M';
    ELSE
      outline (c_mtrflag) := 'J';
    IFEND;
    IF descp <> NIL THEN
      outline (c_classid) := current_class_code [descp^.class];
    ELSE
      outline (c_classid) := 'UNDEFINED';
    IFEND;
    IF task_status^.traprtn [task_status^.mtrmode] THEN
      outline (c_trap) := '*';
    ELSE
      outline (c_trap) := ' ';
    IFEND;

    IF descp = NIL THEN
      keypoint_not_found (kp);
    ELSE
      keypoint_found (kp, descp, area);
    IFEND;
    IF (current_class_code [kp.class] <> ' ') AND ((descp <> NIL) OR (NOT
          ignore_undefined)) THEN
      write_outline (outline);
    IFEND;

    IF descp <> NIL THEN
      IF (descp^.class = osk$exit) AND (descp^.flag = 'T') THEN
        task_status^.traprtn [task_status^.mtrmode] := FALSE;
      IFEND;
      IF (descp^.class = osk$exit) AND (descp^.flag = 'M') THEN
        task_status^.mtrmode := TRUE; {exit job means enter mtr}
      IFEND;
      IF (descp^.flag = 'S') THEN
        taskindex := kp.kcode DIV osk$m;
        task_status := ^task_status_array [taskindex];
      IFEND;
    IFEND;

    IF kp.rec_type = pmfr_overflow THEN
      lg#put (listfile,
        ' * * * * * * * *   LOST KEYPOINT(S) * * * * * * * * *');
    IFEND;


  PROCEND process_keypoint;
?? EJECT ??
{--------------------------------------------------------------------}

  PROCEDURE analyze_file;

    VAR
      eofflag: boolean;

    taskindex := 1;
    task_status := ^task_status_array [1];
    keyindex := 1;
    maxkeyindex := 0;
    outline := '  ';
    init_task_status;

    bi#open (keyfile, 'SESSMKF', old#, input#, first#);

    get_keypoint (kp, TRUE, eofflag);
    size_array [0] := 1;
    FOR i := 1 TO 52 DO
      size_array [i] := 2 * size_array [i - 1];
    FOREND;

  /lp6/
    WHILE NOT eofflag DO
      process_keypoint (kp);
      get_keypoint (kp, TRUE, eofflag);
    WHILEND /lp6/;

    bi#close (keyfile, first#);

    print_keypoint_summary;

  PROCEND analyze_file;
?? EJECT ??
{--------------------------------------------------------------------}

  PROGRAM [XDCL] main;

    lg#open (listfile, 'KEYFILE', old#, output#, first#);
    read_descriptor (p_descriptor, descriptor_file);

{process commands.}

    maxprocid := 256;
    ignore_undefined := FALSE;
    lg#put (listfile, '1 ');
    analyze_file;


    lg#close (listfile, first#);


  PROCEND main;

MODEND new_keypoint_interpreter;
*DECK DECK=KTM$KERMIT_SYSTEM_COMMAND EXPAND=TRUE
create_program_description ..
   name=(kermit) ..
   starting_procedure=ktp$kermit ..
   library=($system.kermit.bound_product) ..
   load_map=$null ..
   load_map_option=none ..
   termination_error_level=warning ..
   debug_mode=off
*DECK DECK=LGC$DEFAULT_PREALLOCATION_SIZE EXPAND=FALSE

  CONST
    lgc$default_preallocation_size = 4000(16);

*DECK DECK=LGC$LOGGING_SIZE_CONSTANTS EXPAND=FALSE

  CONST
    lgc$log_maximum_size = 75000000,
    lgc$log_overflow_size = 150000000,
    lgc$log_warning_size = 50000000;
*DECK DECK=LGC$LOGGING_STATISTICS EXPAND=FALSE

CONST
  lgc$start_of_log = lgc$min_ecc + 0,
  lgc$end_of_log = lgc$min_ecc + 1;

*copyc lgc$min_ecc

*DECK DECK=LGC$MAXIMUM_LOG_CYCLE EXPAND=FALSE
  CONST
    lgc$maximum_log_cycle = 0ffff(16);

*DECK DECK=LGC$MAXIMUM_LOG_ENTRY_SIZE EXPAND=FALSE
  CONST
    lgc$maximum_log_entry_size = 0fff(16);

*DECK DECK=LGC$MAXIMUM_LOG_SIZE EXPAND=FALSE
  CONST
    lgc$maximum_log_size = 150000000;

*DECK DECK=LGC$MIN_ECC EXPAND=FALSE

  CONST
    lgc$min_ecc = (($INTEGER ('L') * 100(16)) + $INTEGER ('G')) * 1000000(16);
*DECK DECK=LGE$CONDITION_CODES EXPAND=FALSE
*copyc lgc$min_ecc

*copyc lge$incorrect_statistic                    "LG 0"
*copyc lge$emission_set_overflow                  "LG 1"
*copyc lge$zero_period                            "LG 2"
*copyc lge$incorrect_time_increment               "LG 3"
*copyc lge$log_not_available                      "LG 4"
*copyc lge$log_full                               "LG 5"
*copyc lge$log_cycles_do_not_match                "LG 6"
*copyc lge$incorrect_move_length                  "LG 7"
*copyc lge$end_of_log                             "LG 8"
*copyc lge$not_local_log                          "LG 9"
*copyc lge$incorrect_log_ordinal                  "LG 10"
*copyc lge$unknown_log_file_identifier            "LG 11"
*copyc lge$corrupted_statistic                    "LG 12"
*copyc lge$not_global_log                         "LG 15"
*copyc lge$unknown_log_keyword                    "LG 16"
*copyc lge$corrupted_log                          "LG 17"
*copyc lge$statistic_buffer_required              "LG 18"
*copyc lge$write_privilege_reserved               "LG 19"
*copyc lge$write_priv_not_reserved                "LG 20"
*copyc lge$write_privilege_required               "LG 21"

*DECK DECK=LGE$CORRUPTED_LOG EXPAND=FALSE

  CONST
    lge$corrupted_log = lgc$min_ecc + 17;
    {E +P is corrupted.}

*copyc lgc$min_ecc
*DECK DECK=LGE$CORRUPTED_STATISTIC EXPAND=FALSE

  CONST
    lge$corrupted_statistic = lgc$min_ecc + 12;
    {E An error occured while parsing a statistic.}

*copyc lgc$min_ecc
*DECK DECK=LGE$EMISSION_SET_OVERFLOW EXPAND=FALSE

  CONST
    lge$emission_set_overflow = lgc$min_ecc + 1;
    {E Emission set overflow.}

*copyc lgc$min_ecc
*DECK DECK=LGE$END_OF_LOG EXPAND=FALSE

  CONST
    lge$end_of_log = lgc$min_ecc + 8;
    {E The end of +P has been reached.}

*copyc lgc$min_ecc
*DECK DECK=LGE$INCORRECT_LOG_ORDINAL EXPAND=FALSE

  CONST
    lge$incorrect_log_ordinal = lgc$min_ecc + 10;
    {E An incorrect log ordinal was passed to +P.}

*copyc lgc$min_ecc
*DECK DECK=LGE$INCORRECT_MOVE_LENGTH EXPAND=FALSE

  CONST
    lge$incorrect_move_length = lgc$min_ecc + 7;
    {E The move length calculated during the termination of +P was <= 0.}

*copyc lgc$min_ecc
*DECK DECK=LGE$INCORRECT_STATISTIC EXPAND=FALSE

  CONST
    lge$incorrect_statistic = lgc$min_ecc + 0;
    {E Incorrect statistic.}

*copyc lgc$min_ecc
*DECK DECK=LGE$INCORRECT_TIME_INCREMENT EXPAND=FALSE

  CONST
    lge$incorrect_time_increment = lgc$min_ecc + 3;
    {E Only hours:minutes:seconds are allowed.}

*copyc lgc$min_ecc
*DECK DECK=LGE$LOG_CYCLES_DO_NOT_MATCH EXPAND=FALSE

  CONST
    lge$log_cycles_do_not_match = lgc$min_ecc + 6;
    {E The log cycles do not match for +P.}

*copyc lgc$min_ecc
*DECK DECK=LGE$LOG_FULL EXPAND=FALSE

  CONST
    lge$log_full = lgc$min_ecc + 5;
    {E +P is full.}

*copyc lgc$min_ecc
*DECK DECK=LGE$LOG_NOT_AVAILABLE EXPAND=FALSE

  CONST
    lge$log_not_available = lgc$min_ecc + 4;
    {E +P is not available.}

*copyc lgc$min_ecc
*DECK DECK=LGE$NOT_GLOBAL_LOG EXPAND=FALSE

  CONST
    lge$not_global_log = lgc$min_ecc + 14;
    {E +P is not a global log.}

*copyc lgc$min_ecc
*DECK DECK=LGE$NOT_LOCAL_LOG EXPAND=FALSE

   CONST
    lge$not_local_log = lgc$min_ecc + 9;
    {E +P is not a local log.}

*copyc lgc$min_ecc
*DECK DECK=LGE$STATISTIC_BUFFER_REQUIRED EXPAND=FALSE

  CONST
    lge$statistic_buffer_required = lgc$min_ecc + 18;
    {E A statistic buffer must be provided on the call to +P.}

*copyc lgc$min_ecc
*DECK DECK=LGE$UNKNOWN_LOG_FILE_IDENTIFIER EXPAND=FALSE

   CONST
    lge$unknown_log_file_identifier = lgc$min_ecc + 11;
    {E +P is an unknown log file identifier.}

*copyc lgc$min_ecc
*DECK DECK=LGE$UNKNOWN_LOG_KEYWORD EXPAND=FALSE

  CONST
    lge$unknown_log_keyword = lgc$min_ecc + 15;
    {E +P is not a recognized log keyword value.}

*copyc lgc$min_ecc
*DECK DECK=LGE$WRITE_PRIVILEGE_REQUIRED EXPAND=FALSE

  CONST
    lge$write_privilege_required = lgc$min_ecc + 21;
    {E Write privilege must be reserved in order to execute this command.}

*copyc lgc$min_ecc
*DECK DECK=LGE$WRITE_PRIVILEGE_RESERVED EXPAND=FALSE

  CONST
    lge$write_privilege_reserved           = lgc$min_ecc + 19;
    {E Another user currently has write privilege reserved.}

*copyc lgc$min_ecc
*DECK DECK=LGE$WRITE_PRIV_NOT_RESERVED EXPAND=FALSE

  CONST
    lge$write_priv_not_reserved            = lgc$min_ecc + 20;
    {W Emission sets not written because write privilege was not }
    {previously reserved.}

*copyc lgc$min_ecc
*DECK DECK=LGE$ZERO_PERIOD EXPAND=FALSE

  CONST
    lge$zero_period = lgc$min_ecc + 2;
    {E Period may not be zero.}

*copyc lgc$min_ecc
*DECK DECK=LGH$ADD_ENTRY_GLOBAL_BINARY_LOG EXPAND=FALSE
{
{    The purpose of this request is to add an entry to a global binary log.
{
{       LGP$ADD_ENTRY_GLOBAL_BINARY_LOG (GLOBAL_BINARY_LOG, ENTRY_P, STATUS)
{
{ GLOBAL_BINARY_LOG: (input)  Specifies which binary log.
{
{ ENTRY_P: (input)  Specifies a pointer to the entry to be added to the log.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITION: lge$log_not_available
{
*DECK DECK=LGH$ADD_ENTRY_LOCAL_BINARY_LOG EXPAND=FALSE
{
{    The purpose of this request is to add an entry to a local binary log.
{
{       LGP$ADD_ENTRY_LOCAL_BINARY_LOG (LOCAL_BINARY_LOG, ENTRY_P, STATUS)
{
{ LOCAL_BINARY_LOG: (input)  Specifies which log.
{
{ ENTRY_P: (input)  Specifies a pointer to the entry to be added to the log.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITION: lge$log_not_available
{
*DECK DECK=LGH$ADD_ENTRY_TO_ASCII_LOG EXPAND=FALSE
{
{    The purpose of this request is to add an entry to the system log, the job
{ job log, or both logs.
{
{       LGP$ADD_ENTRY_TO_ASCII_LOG (ASCII_LOGSET, ORIGIN, TEXT, STATUS)
{
{ ASCII_LOGSET: (input)  Specifies which log(s).
{
{ ORIGIN: (input)  Specifies the type of originator for the message.
{
{ TEXT: (input)  Specifies the text of the message.
{
{ STATUS: (output) Variable to receive the completion status.
{       CONDITION: lge$log_not_available
{
*DECK DECK=LGH$ADD_ENTRY_TO_CRITICAL_LOG EXPAND=FALSE

{
{    The purpose of this request is to add an entry to the critical window log.
{
{       LGP$ADD_ENTRY_TO_CRITICAL_LOG (ORIGIN, TEXT, LOG_TIME, STATUS)
{
{ TEXT: (input)  Specifies the text of the message.
{
{ STATUS: (output) Variable to receive the completion status.
{       CONDITION: None
{
*DECK DECK=LGH$ADD_ENTRY_TO_SYSTEM_LOG EXPAND=FALSE
{
{    The purpose of this request is to add an entry to the system log.
{
{       LGP$ADD_ENTRY_TO_SYSTEM_LOG (ORIGIN, TEXT, LOG_TIME, STATUS)
{
{ ORIGIN: (input)  Specifies the type of originator for the message.
{
{ TEXT: (input)  Specifies the text of the message.
{
{ LOG_TIME: (output)  Variable to receive the time stamp placed on the log
{       entry.
{
{ STATUS: (output) Variable to receive the completion status.
{       CONDITION: None
{
*DECK DECK=LGH$APPEND_JOB_LOG_TO_OUTPUT EXPAND=FALSE
{
{   The purpose of this request is to append the job_log to the output
{ file and then release the segment containing the job_log. This better
{ be one of the last steps in the job termination process.
{
{       LGP$APPEND_JOB_LOG_TO_OUTPUT (STATUS)
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  -
{
{       IDENTIFIER: pmc$external_log_management_id.
{

*DECK DECK=LGH$CLOSE_LOG_FILE EXPAND=FALSE
{
{    The purpose of this request is to close a log file that was opened via the
{ LGP$OPEN_LOG_FILE interface.  This interface should be used (along with
{ LGP$OPEN_LOG_FILE and LGP$GET_NEXT_STATISTIC) to access any of the active
{ logs.  It allows access to logs by authorized users without requiring special
{ ring privilege validations.
{
{       LGP$CLOSE_LOG_FILE (log_file_identifier, status)
{
{ LOG_FILE_IDENTIFIER: (input)  Specifies the file identifier for a log opened
{       via the LGP$OPEN_LOG_FILE interface.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS: lge$unknown_log_file_identifier
{

*DECK DECK=LGH$DISPLAY_JOB_LOG EXPAND=FALSE

*DECK DECK=LGH$DISPLAY_LOG EXPAND=FALSE
{
{    The purpose of this request is to display the the system or job log to an
{ output file.
{
{       LGP$DISPLAY_LOG (DISPLAY_LOG_KIND, DISPLAY_OPTION_SELECTION, OUTPUT,
{             STATUS)
{
{ DISPLAY_LOG_KIND: (input)  Specifies type of display to be generated.
{
{ DISPLAY_OPTION_SELECTION: (input)  Specifies the display options for the
{       request.
{
{ OUTPUT: (input)  Specifies the file to which the output is displayed.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
*DECK DECK=LGH$GET_CRITICAL_LOG_READ_INFO EXPAND=FALSE

{    The purpose of this request is to get the information from the critical
{ window log control descriptor that is needed to read the critical window log.
{
{       LGP$GET_CRITICAL_LOG_READ_INFO (ENTRY_COUNT_FROM_END_OF_LOG,
{             LOG_CYCLE, LOG_DATA, ENDING_OFFSET, STATUS)
{
{ ENTRY_COUNT_FROM_END_OF_LOG: (input)  Specifies the number of log entries to
{       be backspaced over.  If zero is specified log data will be positioned
{       at the current end of the log.
{
{ LOG_CYCLE: (output)  Variable to receive the current log cycle.
{
{ LOG_DATA: (output)  Variable to recieve a copy of the log data sequence
{       pointer (positioned as specified by the ENTRY_COUNT_FROM_END_OF_LOG
{       parameter).
{
{ ENDING_OFFSET: (output)  Variable to receive the current ending offset for
{       the log.
{
{ STATUS: (output) Variable to receive the completion status.
{      CONDITION: None
*DECK DECK=LGH$GET_ENTRY_FROM_CRITICAL_LOG EXPAND=FALSE

{    The purpose of this request is to get an entry from the critical window
{    log.
{
{       LGP$GET_ENTRY_FROM_CRITICAL_LOG (LOG_CYCLE, LOG_DATA,
{             LOG_ENTRY_SIZE, LOG_ENTRY, STATUS)
{
{ LOG_CYCLE: (input)  Specifies the cycle of the critical window log which
{ LOG_DATA references.
{       It must match the active system log cycle or the request will fail.
{       This protects against the problems that would arise from trying to read
{       entries from a log that is being terminated (log termination increments
{       the log cycle).
{
{ LOG_DATA: (input, output)  Specifies the entry in the critical window log
{ which the
{       request is to get.  After this request returns, LOG_DATA is updated to
{       point at the next log entry.
{
{ LOG_ENTRY_SIZE: (output)  Variable to receive the actual size of the log
{       entry.
{
{ LOG_ENTRY: (output)  Variable to recieve a copy of the log entry.  Only as
{       much of the log entry as will fit will be returned.  The actual log
{       entry size is returned in the log entry header record.
{
{ STATUS: (output) Variable to receive the completion status.
{      CONDITION: None
*DECK DECK=LGH$GET_ENTRY_FROM_GLOBAL_LOG EXPAND=FALSE
{    The purpose of this request is to get an entry from a global log.
{
{       LGP$GET_ENTRY_FROM_GLOBAL_LOG (GLOBAL_LOG, LOG_CYCLE, LOG_DATA,
{             LOG_ENTRY_SIZE, LOG_ENTRY, STATUS)
{
{ GLOBAL_LOG: (input)  Specifies which log.
{
{ LOG_CYCLE: (input)  Specifies the cycle of the log which LOG_DATA references.
{       It must match the active system log cycle or the request will fail.
{       This protects against the problems that would arise from trying to read
{       entries from a log that is being terminated (log termination increments
{       the log cycle).
{
{ LOG_DATA: (input, output)  Specifies the entry in the system log which the
{       request is to get.  After this request returns, LOG_DATA is updated to
{       point at the next log entry.
{
{ LOG_ENTRY_SIZE: (output)  Variable to receive the actual size of the log
{       entry.
{
{ LOG_ENTRY: (output)  Variable to recieve a copy of the log entry.  Only as
{       much of the log entry as will fit will be returned.  The actual log
{       entry size is returned in the log entry header record.
{
{ STATUS: (output) Variable to receive the completion status.
{      CONDITION: lge$end_of_log
{                 lge$log_cycles_do_not_match
{                 lge$log_not_available
*DECK DECK=LGH$GET_ENTRY_FROM_LOCAL_LOG EXPAND=FALSE
{    The purpose of this request is to get an entry from a local log.
{
{       LGP$GET_ENTRY_FROM_LOCAL_LOG (LOCAL_LOG, LOG_CYCLE, LOG_DATA,
{             LOG_ENTRY_SIZE, LOG_ENTRY, STATUS)
{
{ LOCAL_LOG: (input)  Specifies which log.
{
{ LOG_CYCLE: (input)  Specifies the cycle of the log which LOG_DATA references.
{
{ LOG_DATA: (input, output)  Specifies the entry in the system log which the
{       request is to get.  After this request returns, LOG_DATA is updated to
{       point at the next log entry.
{
{ LOG_ENTRY_SIZE: (output)  Variable to receive the actual size of the log
{       entry.
{
{ LOG_ENTRY: (output)  Variable to recieve a copy of the log entry.  Only as
{       much of the log entry as will fit will be returned.  The actual log
{       entry size is returned in the log entry header record.
{
{ STATUS: (output) Variable to receive the completion status.
{      CONDITION: lge$end_of_log
{                 lge$log_cycles_do_not_match
{                 lge$log_not_available
{                 lge$not_local_log
*DECK DECK=LGH$GET_GLOBAL_DESCRIPTOR EXPAND=FALSE
{
{   The purpose of this request is to get information from the
{ log control descriptor for the designated global log.
{
{       LGP$GET_GLOBAL_DESCRIPTOR (GLOBAL_LOG, LOG_CYCLE, BASE_OFFSET,
{         WRITE_OFFSET, STATUS)
{
{ GLOBAL_LOG: (input) This parameter specifies the global whose log
{      control descriptor information is control desired.
{
{ LOG_CYCLE: (output) This parameter specifies the log cycle as
{      it currently exists.
{
{ BASE_OFFSET: (output) This parameter specifies the base address
{      as it currently exists.
{
{ WRITE_OFFSET: (output) This parameter specifies the write address
{      as it currently exists.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=LGH$GET_GLOBAL_LOG_READ_INFO EXPAND=FALSE
{    The purpose of this request is to get the information from a global log
{ control descriptor that is needed to read the global log.
{
{       LGP$GET_GLOBAL_LOG_READ_INFO (GLOBAL_LOG, ENTRY_COUNT_FROM_END_OF_LOG,
{             LOG_CYCLE, LOG_DATA, ENDING_OFFSET, STATUS)
{
{ GLOBAL_LOG: (input)  Specifies which log.
{
{ ENTRY_COUNT_FROM_END_OF_LOG: (input)  Specifies the number of log entries to
{       be backspaced over.  If zero is specified log data will be positioned
{       at the current end of the log.
{
{ LOG_CYCLE: (output)  Variable to receive the current log cycle.
{
{ LOG_DATA: (output)  Variable to recieve a copy of the log data sequence
{       pointer (positioned as specified by the ENTRY_COUNT_FROM_END_OF_LOG
{       parameter).
{
{ ENDING_OFFSET: (output)  Variable to receive the current ending offset for
{       the log.
{
{ STATUS: (output) Variable to receive the completion status.
{      CONDITION: lge$log_not_available
*DECK DECK=LGH$GET_LOCAL_LOG_READ_INFO EXPAND=FALSE
{    The purpose of this request is to get the information from a local log
{ control descriptor that is needed to read the global log.
{
{       LGP$GET_LOCAL_LOG_READ_INFO (LOCAL_LOG, ENTRY_COUNT_FROM_END_OF_LOG,
{             LOG_CYCLE, LOG_DATA, ENDING_OFFSET, STATUS)
{
{ LOCAL_LOG: (input)  Specifies which log.
{
{ ENTRY_COUNT_FROM_END_OF_LOG: (input)  Specifies the number of log entries to
{       be backspaced over.  If zero is specified log data will be positioned
{       at the current end of the log.
{
{ LOG_CYCLE: (output)  Variable to receive the current log cycle.
{
{ LOG_DATA: (output)  Variable to recieve a copy of the log data sequence
{       pointer (positioned as specified by the ENTRY_COUNT_FROM_END_OF_LOG
{       parameter).
{
{ ENDING_OFFSET: (output)  Variable to receive the current ending offset for
{       the log.
{
{ STATUS: (output) Variable to receive the completion status.
{      CONDITION: lge$log_not_available
{                 lge$not_local_log
*DECK DECK=LGH$GET_NEXT_STATISTIC EXPAND=FALSE
{
{    The purpose of this request is to get a copy of the next statistic from an
{ opened log file and return pointers to the statistic header, counters, and
{ descriptive_data in that statistic.  This interface should be used (along
{ with LGP$OPEN_LOG_FILE and LGP$CLOSE_LOG_FILE) to access any of the active
{ logs.  It allows access to logs by authorized users without requiring special
{ ring privilege validations.
{
{       LGP$GET_NEXT_STATISTIC (file_identifier, statistic_buffer,
{             statistic_header, counters, descriptive_data, status)
{
{ FILE_IDENTIFIER: (input)  Specifies the file identifier for an open log file.
{
{ STATISTIC_BUFFER: (input)  Specifies a buffer that the statistic can be
{       copied into.  The statistic is only copied into this buffer is the
{       request is reading an active log or if the statistic is in an old
{       format.
{
{ STATISTIC_HEADER: (output)  Variable to receive a pointer to the statistic
{       header.
{
{ COUNTERS: (output)  Variable to receive a pointer to the statistic counters.
{       If there are no counters on the statistic, a NIL pointer will be
{       returned.
{
{ DESCRIPTIVE_DATA: (output)  Variable to receive a pointer to the statistic
{       descriptive data.  If there is no descriptive data, a NIL pointer will
{       be returned.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS: lge$end_of_log
{                   lge$statistic_buffer_required
{                   lge$unknown_log_file_identifier
{
*DECK DECK=LGH$INITIALIZE_CRITICAL_LOG_LCD EXPAND=FALSE
{
{    The purpose of this request is to initialize a log control descriptor for
{ the critical window log.
{
{       LGP$INITIALIZE_CRITICAL_LOG_LCD (LOG, STATUS)
{
{ LOG: (input)  Specifies the sequence containing the log.
{
{ STATUS: (output) Variable to receive the completion status.
{       CONDITION: None
*DECK DECK=LGH$INITIALIZE_GLOBAL_LOG_LCD EXPAND=FALSE
{
{    The purpose of this request is to initialize log control descriptor for
{ the specified log.
{
{       LGP$INITIALIZE_GLOBAL_LOG_LCD (GLOBAL_LOG, LOG, STATUS)
{
{ GLOBAL_LOG: (input)  Specifies which log.
{
{ LOG: (input)  Specifies the sequence containing the log.
{
{ STATUS: (output) Variable to receive the completion status.
{       CONDITION: lge$log_full
{
*DECK DECK=LGH$INSTALL_GLOBAL_LOGS EXPAND=FALSE
{
{   The purpose of this request is to establish system level logging
{ for an installation deadstart.
{
{     LGP$INSTALL_GLOBAL_LOGS (STATUS)
{
{ STATUS: (output) This parameter specifies the request status.
{      CONDITION: pme$push_fail
{      IDENTIFIER: pmc$external_log_management_id
{
*DECK DECK=LGH$OPEN_LOG_FILE EXPAND=FALSE
{
{    The purpose of this request is to open a log file for read access.  This
{ interface should be used (along with LGP$GET_NEXT_STATISTIC and
{ LGP$CLOSE_LOG_FILE) to access any of the active logs.  It allows access to
{ logs by authorized users without requiring special ring privilege
{ validations.
{
{       LGP$OPEN_LOG_FILE (file, active_log, log_file_identifier, status)
{
{ FILE: (input)  Specifies the path for the log file to be opened.
{
{ ACTIVE_LOG: (output)  Variable to recieve an indication whether this is an
{       active log.
{
{ LOG FILE_IDENTIFIER: (output)  Variable to recieve the file identifier to
{        be used on subsequent requests.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS: ofe$sou_not_active
{
*DECK DECK=LGH$PARSE_STATISTIC EXPAND=FALSE
{
{    The purpose of this request is to get pointers to the statistic header,
{ counters and descriptive data in a statistic.
{
{       LGP$PARSE_STATISTIC (log_entry_p, statistic_buffer_p,
{             statistic_header_p, counters_p, descriptive_data_p, status)
{
{ LOG_ENTRY_P: (input, output)  Specifies a pointer to the sequence containing
{       the log entry to be parsed.  If the log entry requires conversion to a
{       new format, this sequence must be the same size as SFT$STATISTIC_BUFFER
{       in order to allow enough room for the converted statistic to be stored
{       in the sequence.
{
{ STATISTIC_HEADER_P: (output)  Variable to receive a pointer to the statistic
{       header.  If an obsolete statistic is being parsed, the statistic header
{       will be converted to the current format for a statistic header.
{
{ COUNTERS_P: (output)  Variable to receive a pointer to the statistic
{       counters.  If there are no counters on the statistic, a NIL pointer
{       will be returned.
{
{ DESCRIPTIVE_DATA_P: (output)  Variable to receive a pointer to the statistic
{       descriptive data.  If there is no descriptive data, a NIL pointer will
{       be returned.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{         sfe$corrupted_statistic
{         sfe$statistic_buffer_required
{
*DECK DECK=LGH$RECOVER_GLOBAL_LOGS EXPAND=FALSE
{
{   The purpose of this request is to establish the environment for
{ system level logging for a non-installation deadstart.  This
{ request will also recover any system level logging that occurred
{ during recovery, i.e. logging which took place in the environment
{ established by the LGP$SETUP_RECOVERY_LOGGING request.
{
{     LGP$RECOVER_GLOBAL_LOGS (STATUS)
{
{ STATUS: (output) This parameter specifies the request status.
{      CONDITION: pme$push_fail
{      IDENTIFIER: pmc$external_log_management_id
{
*DECK DECK=LGH$RELEASE_CRITICAL_LOG_SPACE EXPAND=FALSE
{
{    The purpose of this request is to move any log entries that have been
{ added since log termination was started to the beginning of the log sequence
{ and then release the unneeded disk space.
{
{       LGP$RELEASE_CRITICAL_LOG_SPACE (LOG_CYCLE,
{             FIRST_LOG_ENTRY_HEADER_P, STATUS)
{
{ LOG_CYCLE: (input)  Specifies the log cycle of the critical window log.
{
{ FIRST_LOG_ENTRY_HEADER_P: (input)  Specifies a pointer to the log entry
{       header that should be the first one on the log.  If this parameter
{       is NIL, the specified global log will set up to be empty.
{
{ STATUS: (output) Variable to receive the completion status.
{       CONDITION: lge$corrupted_log
{                  lge$incorrect_move_length
{                  lge$log_cycles_do_not_match
*DECK DECK=LGH$RELEASE_GLOBAL_LOG_SPACE EXPAND=FALSE
{
{    The purpose of this request is to move any log entries that have been
{ added since log termination was started to the beginning of the log sequence
{ and then release the unneeded disk space.
{
{       LGP$RELEASE_GLOBAL_LOG_SPACE (GLOBAL_LOG, LOG_CYCLE,
{             FIRST_LOG_ENTRY_HEADER_P, STATUS)
{
{ GLOBAL_LOG: (input)  Specifies which log.
{
{ LOG_CYCLE: (input)  Specifies the log cycle of the log.
{
{ FIRST_LOG_ENTRY_HEADER_P: (input)  Specifies a pointer to the log entry
{       header that should be the first one on the log.  If this parameter
{       is NIL, the specified global log will set up to be empty.
{
{ STATUS: (output) Variable to receive the completion status.
{       CONDITION: lge$incorrect_move_length
{                  lge$log_cycles_do_not_match
{                  lge$log_is_full
{
*DECK DECK=LGH$REWIND_LOG_FILE EXPAND=FALSE
{
{    The purpose of this request is to rewind a log file that was opened via the
{ LGP$OPEN_LOG_FILE interface.
{
{       LGP$REWIND_LOG_FILE (log_file_identifier, status)
{
{ LOG_FILE_IDENTIFIER: (input)  Specifies the file identifier for a log opened
{       via the LGP$OPEN_LOG_FILE interface.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{
*DECK DECK=LGH$SETUP_ACCESS_TO_LOCAL_LOGS EXPAND=FALSE
{
{    The purpose of this request is to establish the link between the job and
{ its local log files.  The local logs are created in this procedure and are
{ part of every subsequent task created for this job.
{
{       LGP$SETUP_ACCESS_TO_LOCAL_LOGS (STATUS)
{
{ STATUS: (output) This parameter specifies the result of the request.
{       CONDITION: lge$log_full
*DECK DECK=LGH$TERMINATE_CRITICAL_LOG EXPAND=FALSE
{
{    The purpose of this request is to copy the contents of the critical
{ window log to another file and then release the disk space occupied by the critical
{ window log.
{
{       LGP$TERMINATE_CRITICAL_LOG (TERMINATION_FILE, STATUS)
{
{ TERMINATION_FILE: (input)  Specifies the path of the file to receive a copy
{       of the contents of the critical window log.
{
{ STATUS: (output) This parameter specifies the result of the request.
{       CONDITION: lge$corrupted_log
{                  ofe$sou_not_active
*DECK DECK=LGH$TERMINATE_LOG EXPAND=FALSE
{
{    The purpose of this request is to copy the contents of the specified log
{ to another file and then release the disk space occupied by the log.
{
{       LGP$TERMINATE_LOG (GLOBAL_LOG, TERMINATION_FILE, STATUS)
{
{ GLOBAL_LOG: (input)  This parameter specifies the log to be terminated.
{
{ TERMINATION_FILE: (input)  Specifies the path of the file to receive a copy
{       of the contents of the specified log.
{
{ STATUS: (output) This parameter specifies the result of the request.
{       CONDITION: pme$log_cycles_do_not_match,
{
*DECK DECK=LGK$LOG_ASCII EXPAND=FALSE

{     LOGGING keypoints

  CONST
    lgk$log_ascii          = lgk$base + 0;
    {E  'pmp$log_ascii' }
    {X  'pmp$log_ascii' }

?? PUSH (LISTEXT := ON) ??
*copyc OSK$KEYPOINTS
?? POP ??
*DECK DECK=LGM$ACTIVATE_OS_STATISTICS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE lgm$activate_os_statistics;

{
{ PURPOSE:
{         This module provides the command language interfaces to the
{         emitting of os statistics.
{
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$scan_parameter_list
*copyc clp$get_value
?? POP ??
*copyc osp$activate_os_statistics
*copyc osp$deactivate_os_statistics
?? EJECT ??
?? TITLE := 'PROCEDURE lgp$activate_os_stats_command' ??

  PROCEDURE [XDCL] lgp$activate_os_stats_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ pdt init_os_stats_pdt (
{      jms_interval,ji : integer 1..999 = 1
{      pms_interval,pi : integer 1..999 = 5
{      status )

?? PUSH (LISTEXT := ON) ??

    VAR
      init_os_stats_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^init_os_stats_pdt_names,
        ^init_os_stats_pdt_params];

    VAR
      init_os_stats_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
        clt$parameter_name_descriptor := [['JMS_INTERVAL', 1], ['JI', 1], ['PMS_INTERVAL', 2], ['PI', 2], [
        'STATUS', 3]];

    VAR
      init_os_stats_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor
        := [

{ JMS_INTERVAL JI }
      [[clc$optional_with_default, ^init_os_stats_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$integer_value, 1, 999]],

{ PMS_INTERVAL PI }
      [[clc$optional_with_default, ^init_os_stats_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$integer_value, 1, 999]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      init_os_stats_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '1';

    VAR
      init_os_stats_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '5';

?? POP ??

    VAR
      jms_value,
      pms_value: clt$value;

    clp$scan_parameter_list (parameter_list, init_os_stats_pdt, status);
    IF status.normal THEN
      clp$get_value ('JMS_INTERVAL', 1, 1, clc$low, jms_value, status);
      IF status.normal THEN
        clp$get_value ('PMS_INTERVAL', 1, 1, clc$low, pms_value, status);
      IFEND;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$activate_os_statistics (jms_value.int.value * 60000000, pms_value.int.value * 60000000, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND lgp$activate_os_stats_command;
?? EJECT ??
?? TITLE := 'PROCEDURE lgp$deactivate_os_stats_command' ??

  PROCEDURE [XDCL] lgp$deactivate_os_stats_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);
{ pdt term_os_stats_pdt ( status )

?? PUSH (LISTEXT := ON) ??

    VAR
      term_os_stats_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^term_os_stats_pdt_names,
        ^term_os_stats_pdt_params];

    VAR
      term_os_stats_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
        clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      term_os_stats_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor
        := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??
    clp$scan_parameter_list (parameter_list, term_os_stats_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$deactivate_os_statistics (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND lgp$deactivate_os_stats_command;
MODEND lgm$activate_os_statistics;
*DECK DECK=LGM$COMMON_PROCESSORS EXPAND=TRUE
*DECK DECK=LGM$COMMON_PROCESSORS_R1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Logging: Common Processors Ring 1' ??
MODULE lgm$common_processors_r1;

{ PURPOSE:
{   This module contains common code used for both local and global logs in ring 1.
{!!!!NOTE!!!! Any modifications to this deck must be reflected in the module lgm$common_processors_r2.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmt$error_condition_codes
*copyc lge$corrupted_log
*copyc lge$end_of_log
*copyc lge$log_cycles_do_not_match
*copyc lge$log_full
*copyc lge$log_not_available
*copyc lgt$critical_log_control_desc
*copyc lgt$log_control_descriptor
*copyc lgt$log_cycle
*copyc lgt$log_entry
*copyc lgt$log_entry_header
?? POP ??
*copyc clp$trimmed_string_size
*copyc dpp$put_critical_message
*copyc i#build_adaptable_seq_pointer
*copyc i#current_sequence_position
*copyc i#move
*copyc mmp$os_preallocate_file_space
*copyc mmp$verify_no_space_available
*copyc osp$clear_job_signature_lock
*copyc osp$clear_mainframe_sig_lock
*copyc osp$monitor_fault_to_status
*copyc osp$set_job_signature_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc syp$establish_condition_handler
*copyc syp$disestablish_cond_handler
*copyc lgv$critical_log_name
*copyc lgv$log_names
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$add_critical_log_entry', EJECT ??
{ PURPOSE:
{ Adds an entry to the critical window log.  The caller of this procedure must interlock
{ the log before making this request.

  PROCEDURE [XDCL, #GATE] lgp$add_critical_log_entry
    (    entry_p: ^lgt$log_entry;
         log_control_descriptor_p: ^lgt$critical_log_control_desc;
     VAR status: ost$status);

    VAR
      log_entry_p: ^lgt$log_entry,
      local_log_data: ^SEQ ( * ),
      trailing_log_entry_header_p: ^lgt$log_entry_header;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Make sure that an error is returned in the event of an error.

    PROCEDURE condition_handler
      (    monitor_fault: ost$monitor_fault;
           save_area: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$monitor_fault_to_status (monitor_fault, save_area, status);
      EXIT lgp$add_critical_log_entry;

    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'preallocate_log_space', EJECT ??
{ PURPOSE:
{   Preallocates disk space for a log (if the log has not reached its maximum size).

    PROCEDURE preallocate_log_space
      (    log_control_descriptor_p: ^lgt$critical_log_control_desc;
       VAR local_log_data: ^SEQ ( * );
       VAR status: ost$status);

      TYPE
        variant_sequence_pointer = record
          case boolean of
          = TRUE =
            cybil_definition: cyt$sequence_pointer,
          = FALSE =
            normal_definition: ^SEQ ( * ),
          casend,
        recend;

      VAR
        local_status: ost$status,
        message: string (osc$max_string_size),
        message_length: integer,
        no_space_available: boolean,
        preallocated_size: ost$segment_length,
        sequence_pointer: variant_sequence_pointer;

      status.normal := TRUE;

      sequence_pointer.normal_definition := local_log_data;

{ If the log has not reached its maximum size, compute the new size.  Otherwise, return log full error.
{ The calculated size will always be an even multiple of the preallocation size.

      IF sequence_pointer.cybil_definition.length < log_control_descriptor_p^.maximum_size THEN
        preallocated_size := (((sequence_pointer.cybil_definition.length + lgc$maximum_log_entry_size) DIV
              log_control_descriptor_p^.preallocation_size) + 1) *
              log_control_descriptor_p^.preallocation_size;
        IF preallocated_size > log_control_descriptor_p^.maximum_size THEN
          preallocated_size := log_control_descriptor_p^.maximum_size;
        IFEND;

{ Preallocate the disk space.

        REPEAT
          mmp$os_preallocate_file_space (local_log_data, preallocated_size, 5, status);
          IF NOT status.normal THEN
            IF status.condition = dme$unable_to_alloc_all_space THEN
              mmp$verify_no_space_available (local_log_data, no_space_available, local_status);
              IF NOT local_status.normal OR no_space_available THEN
                RETURN;
              IFEND;
            ELSE
              RETURN;
            IFEND;
          IFEND;
        UNTIL status.normal;

{ Adjust the length of the log data sequence.

        sequence_pointer.cybil_definition.length := preallocated_size;
        local_log_data := sequence_pointer.normal_definition;

      ELSE
        log_control_descriptor_p^.log_full := TRUE;
        osp$set_status_abnormal ('LG', lge$log_full, lgv$critical_log_name, status);
      IFEND;

    PROCEND preallocate_log_space;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

{ Check if the log is available.

    IF log_control_descriptor_p^.log_data = NIL THEN
      osp$set_status_abnormal ('LG', lge$log_not_available, lgv$critical_log_name, status);
      RETURN;
    IFEND;

{ Check if the log is full.

    IF log_control_descriptor_p^.log_full THEN
      osp$set_status_abnormal ('LG', lge$log_full, lgv$critical_log_name, status);
      RETURN;
    IFEND;

{ Establish a condition handler.

    syp$establish_condition_handler (^condition_handler);
    /add_critical_log_entry/
    BEGIN

{ Make a copy of the log data sequence pointer and use it until the log entry has been successfully placed in
{ the log.

    local_log_data := log_control_descriptor_p^.log_data;

{ Allocate space in the log for the log entry.  If the entry will not fit, try to preallocate more space.

    NEXT log_entry_p: [[REP #SIZE (entry_p^) OF cell]] IN local_log_data;
    IF log_entry_p = NIL THEN
      preallocate_log_space (log_control_descriptor_p, local_log_data, status);
      IF NOT status.normal THEN
        EXIT /add_critical_log_entry/;
      IFEND;
      NEXT log_entry_p: [[REP #SIZE (entry_p^) OF cell]] IN local_log_data;
      IF log_entry_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$log_full, lgv$critical_log_name, status);
        EXIT /add_critical_log_entry/;
      IFEND;
    IFEND;

{ Allocate space in the log for the trailing log entry header.

    NEXT trailing_log_entry_header_p IN local_log_data;
    IF trailing_log_entry_header_p = NIL THEN
      preallocate_log_space (log_control_descriptor_p, local_log_data, status);
      IF NOT status.normal THEN
        EXIT /add_critical_log_entry/;
      IFEND;
      NEXT trailing_log_entry_header_p IN local_log_data;
      IF trailing_log_entry_header_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$log_full, lgv$critical_log_name, status);
        EXIT /add_critical_log_entry/;
      IFEND;
    IFEND;

{ Move the log entry into the log.

    log_entry_p^ := entry_p^;

{ Initialize the trailing log entry header.

    trailing_log_entry_header_p^.previous_size := #SIZE (entry_p^);
    trailing_log_entry_header_p^.current_size := 0;

{ Update current size in log entry header that preceeds the log entry.

    log_control_descriptor_p^.trailing_log_entry_header_p^.current_size := #SIZE (entry_p^);

{ Save pointer to the new trailing log entry header in the log control descriptor.

    log_control_descriptor_p^.trailing_log_entry_header_p := trailing_log_entry_header_p;

{ Update the actual log data sequence pointer.

    log_control_descriptor_p^.log_data := local_log_data;

    END /add_critical_log_entry/;
    syp$disestablish_cond_handler;

  PROCEND lgp$add_critical_log_entry;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lgp$add_log_entry', EJECT ??
{ PURPOSE:
{   Adds an entry to a log.  The caller of this procedure must interlock the log before making this request.

  PROCEDURE [XDCL] lgp$add_log_entry
    (    entry_p: ^lgt$log_entry;
         log_control_descriptor_p: ^lgt$log_control_descriptor;
     VAR status: ost$status);

    VAR
      local_log_data: ^SEQ ( * ),
      log_entry_p: ^lgt$log_entry,
      trailing_log_entry_header_p: ^lgt$log_entry_header;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Make sure that an error is returned in the event of an error.

    PROCEDURE condition_handler
      (    monitor_fault: ost$monitor_fault;
           save_area: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$monitor_fault_to_status (monitor_fault, save_area, status);
      EXIT lgp$add_log_entry;

    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'preallocate_log_space', EJECT ??
{ PURPOSE:
{   Preallocates disk space for a log (if the log has not reached its maximum size).

    PROCEDURE preallocate_log_space
      (    log_control_descriptor_p: ^lgt$log_control_descriptor;
       VAR local_log_data: ^SEQ ( * );
       VAR status: ost$status);

      TYPE
        variant_sequence_pointer = record
          case boolean of
          = TRUE =
            cybil_definition: cyt$sequence_pointer,
          = FALSE =
            normal_definition: ^SEQ ( * ),
          casend,
        recend;

      VAR
        local_status: ost$status,
        message: string (osc$max_string_size),
        message_length: integer,
        no_space_available: boolean,
        preallocated_size: ost$segment_length,
        sequence_pointer: variant_sequence_pointer;

      status.normal := TRUE;

      sequence_pointer.normal_definition := local_log_data;

{ If the log has not reached its maximum size, compute the new size.  Otherwise, return log full error.
{ The calculated size will always be an even multiple of the preallocation size.

      IF sequence_pointer.cybil_definition.length < log_control_descriptor_p^.maximum_size THEN
        preallocated_size := (((sequence_pointer.cybil_definition.length + lgc$maximum_log_entry_size) DIV
              log_control_descriptor_p^.preallocation_size) + 1) *
              log_control_descriptor_p^.preallocation_size;
        IF preallocated_size > log_control_descriptor_p^.maximum_size THEN
          preallocated_size := log_control_descriptor_p^.maximum_size;
        IFEND;

{ Preallocate the disk space.

        REPEAT
          mmp$os_preallocate_file_space (local_log_data, preallocated_size, 5, status);
          IF NOT status.normal THEN
            IF status.condition = dme$unable_to_alloc_all_space THEN
              mmp$verify_no_space_available (local_log_data, no_space_available, local_status);
              IF NOT local_status.normal OR no_space_available THEN
                RETURN;
              IFEND;
            ELSE
              RETURN;
            IFEND;
          IFEND;
        UNTIL status.normal;

{ Adjust the length of the log data sequence.

        sequence_pointer.cybil_definition.length := preallocated_size;
        local_log_data := sequence_pointer.normal_definition;

{ Inform the operator if a global log is getting too large (greater than 75% of maximum size).

        IF (i#current_sequence_position (local_log_data) > ((log_control_descriptor_p^.maximum_size * 3) DIV
              4)) AND (log_control_descriptor_p^.log IN -$pmt$global_logset []) THEN
          IF log_control_descriptor_p^.critical_log THEN
            STRINGREP (message, message_length, lgv$log_names [log_control_descriptor_p^.log] (1,
                  clp$trimmed_string_size (lgv$log_names [log_control_descriptor_p^.log])), ' is',
                  ($REAL (i#current_sequence_position (local_log_data)) / 1000000.0): 7: 2,
                  'M bytes long, system will terminate at', (log_control_descriptor_p^.maximum_size DIV
                  1000000), 'M bytes.');
          ELSE
            STRINGREP (message, message_length, lgv$log_names [log_control_descriptor_p^.log] (1,
                  clp$trimmed_string_size (lgv$log_names [log_control_descriptor_p^.log])), ' is',
                  ($REAL (i#current_sequence_position (local_log_data)) / 1000000.0): 7: 2,
                  'M bytes long, logging will stop at', (log_control_descriptor_p^.maximum_size DIV 1000000),
                  'M bytes.');
          IFEND;
          dpp$put_critical_message (message (1, message_length), {ignore} status);
          status.normal := TRUE;
        IFEND;
      ELSE
        log_control_descriptor_p^.log_full := TRUE;
        osp$set_status_abnormal ('LG', lge$log_full, lgv$log_names [log_control_descriptor_p^.log], status);
      IFEND;

    PROCEND preallocate_log_space;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

{ Check if the log is available.

    IF log_control_descriptor_p^.log_data = NIL THEN
      osp$set_status_abnormal ('LG', lge$log_not_available, lgv$log_names [log_control_descriptor_p^.log],
            status);
      RETURN;
    IFEND;

{ Check if the log is full.

    IF log_control_descriptor_p^.log_full THEN
      osp$set_status_abnormal ('LG', lge$log_full, lgv$log_names [log_control_descriptor_p^.log], status);
      RETURN;
    IFEND;

{ Establish a condition handler.

    syp$establish_condition_handler (^condition_handler);
    /add_log_entry/
    BEGIN

{ Make a copy of the log data sequence pointer and use it until the log entry has been successfully placed in
{ the log.

    local_log_data := log_control_descriptor_p^.log_data;

{ Allocate space in the log for the log entry.  If the entry will not fit, try to preallocate more space.

    NEXT log_entry_p: [[REP #SIZE (entry_p^) OF cell]] IN local_log_data;
    IF log_entry_p = NIL THEN
      preallocate_log_space (log_control_descriptor_p, local_log_data, status);
      IF NOT status.normal THEN
        EXIT /add_log_entry/;
      IFEND;
      NEXT log_entry_p: [[REP #SIZE (entry_p^) OF cell]] IN local_log_data;
      IF log_entry_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$log_full, lgv$log_names [log_control_descriptor_p^.log], status);
        EXIT /add_log_entry/;
      IFEND;
    IFEND;

{ Allocate space in the log for the trailing log entry header.

    NEXT trailing_log_entry_header_p IN local_log_data;
    IF trailing_log_entry_header_p = NIL THEN
      preallocate_log_space (log_control_descriptor_p, local_log_data, status);
      IF NOT status.normal THEN
        EXIT /add_log_entry/;
      IFEND;
      NEXT trailing_log_entry_header_p IN local_log_data;
      IF trailing_log_entry_header_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$log_full, lgv$log_names [log_control_descriptor_p^.log], status);
        EXIT /add_log_entry/;
      IFEND;
    IFEND;

{ Move the log entry into the log.

    log_entry_p^ := entry_p^;

{ Initialize the trailing log entry header.

    trailing_log_entry_header_p^.previous_size := #SIZE (entry_p^);
    trailing_log_entry_header_p^.current_size := 0;

{ Update current size in log entry header that preceeds the log entry.

    log_control_descriptor_p^.trailing_log_entry_header_p^.current_size := #SIZE (entry_p^);

{ Save pointer to the new trailing log entry header in the log control descriptor.

    log_control_descriptor_p^.trailing_log_entry_header_p := trailing_log_entry_header_p;

{ Update the actual log data sequence pointer.

    log_control_descriptor_p^.log_data := local_log_data;

    END /add_log_entry/;
    syp$disestablish_cond_handler;

  PROCEND lgp$add_log_entry;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$get_critical_read_info', EJECT ??
{ PURPOSE:
{   This procedure returns the log cycle and a log data sequence pointer that is positioned the specified
{   number of log entries from the end of the critical window log.  If the log does not contain the
{   specified number of entries, the log data sequence pointer is positioned to the beginning of the log.
{   If zero is specified for the number of entries, the log_data sequence will be positioned at the
{   current end of the log.

  PROCEDURE [XDCL, #GATE] lgp$get_critical_read_info
    (    log_control_descriptor_p: ^lgt$critical_log_control_desc;
         entry_count_from_end_of_log: ost$segment_length;
     VAR log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR ending_offset: amt$file_byte_address;
     VAR status: ost$status);

    VAR
      count: ost$segment_length,
      log_entry_header: lgt$log_entry_header,
      log_entry_header_p: ^lgt$log_entry_header;

?? NEWTITLE := 'condition_handler', EJECT ??
{ PURPOSE:
{   Make sure that the log interlock is cleared in the event of an error.

    PROCEDURE condition_handler
      (    monitor_fault: ost$monitor_fault;
           save_area: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$monitor_fault_to_status (monitor_fault, save_area, status);
      osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
      EXIT lgp$get_critical_read_info;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Lock the log before establishing the condition handler so that if the log was already locked
{ by another procedure in this task, this procedure doesn't unlock it.

    osp$set_mainframe_sig_lock (log_control_descriptor_p^.lock);
    syp$establish_condition_handler (^condition_handler);

{ Get the log cycle and log data sequence information.

    log_cycle := log_control_descriptor_p^.log_cycle;
    IF log_control_descriptor_p^.log_data <> NIL THEN

{ Return a log data sequence pointer that reflects a sequence that is the larger of the actual log data
{ sequence or the declared maximum size.  This is necessary because the maximum size specified for the
{ log may changed (up or down) from one deadstart to the next and the size of a recovered log could exceed
{ the specified maximum.

      IF #SIZE (log_control_descriptor_p^.log_data^) > log_control_descriptor_p^.maximum_size THEN
        log_data := log_control_descriptor_p^.log_data;
      ELSE
        i#build_adaptable_seq_pointer (#RING (log_control_descriptor_p^.log_data),
              #SEGMENT (log_control_descriptor_p^.log_data), #OFFSET (log_control_descriptor_p^.log_data),
              log_control_descriptor_p^.maximum_size, i#current_sequence_position
              (log_control_descriptor_p^.log_data), log_data);
      IFEND;
      ending_offset := #OFFSET (log_control_descriptor_p^.trailing_log_entry_header_p);
    ELSE
      log_data := NIL;
      ending_offset := 0;
    IFEND;

{ If a non zero entry count was specified, back up the specified number of entries.  Exit if the beginning of
{ the log is found.

    IF (entry_count_from_end_of_log <> 0) AND (log_control_descriptor_p^.log_data <> NIL) THEN
      log_entry_header_p := log_control_descriptor_p^.trailing_log_entry_header_p;
      RESET log_data TO log_entry_header_p;

    /find_starting_location_in_log/
      FOR count := 1 TO entry_count_from_end_of_log DO
        IF log_entry_header_p^.previous_size = 0 THEN
          EXIT /find_starting_location_in_log/;
        ELSE
          log_entry_header_p := #ADDRESS (#RING (log_data), #SEGMENT (log_data),
                (i#current_sequence_position (log_data) - (#SIZE (lgt$log_entry_header) +
                log_entry_header_p^.previous_size)));
          RESET log_data TO log_entry_header_p;
        IFEND;
      FOREND /find_starting_location_in_log/;
    IFEND;

{ Release the log interlock.

    osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
    syp$disestablish_cond_handler;

  PROCEND lgp$get_critical_read_info;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lgp$get_log_read_information', EJECT ??
{ PURPOSE:
{   This procedure returns the log cycle and a log data sequence pointer that is positioned the specified
{   number of log entries from the end of the log.  If the log does not contain the specified number of
{   entries, the log data sequence pointer is positioned to the beginning of the log.  If zero is specified
{   for the number of entries, the log_data sequence will be positioned at the current end of the log.

  PROCEDURE [XDCL] lgp$get_log_read_information
    (    log_control_descriptor_p: ^lgt$log_control_descriptor;
         entry_count_from_end_of_log: ost$segment_length;
     VAR log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR ending_offset: amt$file_byte_address;
     VAR status: ost$status);

    VAR
      count: ost$segment_length,
      log_entry_header: lgt$log_entry_header,
      log_entry_header_p: ^lgt$log_entry_header;

?? NEWTITLE := 'condition_handler', EJECT ??
{ PURPOSE:
{   Make sure that the log interlock is cleared in the event of an error.

    PROCEDURE condition_handler
      (    monitor_fault: ost$monitor_fault;
           save_area: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$monitor_fault_to_status (monitor_fault, save_area, status);
      lgp$unlock_log (log_control_descriptor_p);
      EXIT lgp$get_log_read_information;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Lock the log before establishing the condition handler so that if the log was already locked
{ by another procedure in this task, this procedure doesn't unlock it.

    lgp$lock_log (log_control_descriptor_p);
    syp$establish_condition_handler (^condition_handler);

{ Get the log cycle and log data sequence information.

    log_cycle := log_control_descriptor_p^.log_cycle;
    IF log_control_descriptor_p^.log_data <> NIL THEN

{ Return a log data sequence pointer that reflects a sequence that is the larger of the actual log data
{ sequence or the declared maximum size.  This is necessary because the maximum size specified for the
{ log may changed (up or down) from one deadstart to the next and the size of a recovered log could exceed
{ the specified maximum.

      IF #SIZE (log_control_descriptor_p^.log_data^) > log_control_descriptor_p^.maximum_size THEN
        log_data := log_control_descriptor_p^.log_data;
      ELSE
        i#build_adaptable_seq_pointer (#RING (log_control_descriptor_p^.log_data),
              #SEGMENT (log_control_descriptor_p^.log_data), #OFFSET (log_control_descriptor_p^.log_data),
              log_control_descriptor_p^.maximum_size, i#current_sequence_position
              (log_control_descriptor_p^.log_data), log_data);
      IFEND;
      ending_offset := #OFFSET (log_control_descriptor_p^.trailing_log_entry_header_p);
    ELSE
      log_data := NIL;
      ending_offset := 0;
    IFEND;

{ If a non zero entry count was specified, back up the specified number of entries.  Exit if the beginning of
{ the log is found.

    IF (entry_count_from_end_of_log <> 0) AND (log_control_descriptor_p^.log_data <> NIL) THEN
      log_entry_header_p := log_control_descriptor_p^.trailing_log_entry_header_p;
      RESET log_data TO log_entry_header_p;

    /find_starting_location_in_log/
      FOR count := 1 TO entry_count_from_end_of_log DO
        IF log_entry_header_p^.previous_size = 0 THEN
          EXIT /find_starting_location_in_log/;
        ELSE
          log_entry_header_p := #ADDRESS (#RING (log_data), #SEGMENT (log_data),
                (i#current_sequence_position (log_data) - (#SIZE (lgt$log_entry_header) +
                log_entry_header_p^.previous_size)));
          RESET log_data TO log_entry_header_p;
        IFEND;
      FOREND /find_starting_location_in_log/;
    IFEND;

{ Release the log interlock.

    lgp$unlock_log (log_control_descriptor_p);
    syp$disestablish_cond_handler;

  PROCEND lgp$get_log_read_information;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$get_critical_log_entry', EJECT ??
{ PURPOSE:
{   Retrieve an entry from the critical window log.

  PROCEDURE [XDCL, #GATE] lgp$get_critical_log_entry
    (    log_cycle: lgt$log_cycle;
         log_control_descriptor_p: ^lgt$critical_log_control_desc;
     VAR log_data: ^SEQ ( * );
     VAR log_entry_size: lgt$log_entry_size;
     VAR log_entry: lgt$log_entry;
     VAR status: ost$status);

    VAR
      log_entry_header_p: ^lgt$log_entry_header,
      log_entry_p: ^lgt$log_entry,
      local_log_data: ^SEQ ( * );

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Make sure that the log interlock is cleared in the event of an error.

    PROCEDURE condition_handler
      (    monitor_fault: ost$monitor_fault;
           save_area: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$monitor_fault_to_status (monitor_fault, save_area, status);
      osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
      EXIT lgp$get_critical_log_entry;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Check if the critical window log is available.

    IF log_control_descriptor_p^.log_data = NIL THEN
      osp$set_status_abnormal ('LG', lge$log_not_available, lgv$critical_log_name, status);
      RETURN;
    IFEND;

{ Establish a condition handler and interlock the critical window log.

    osp$set_mainframe_sig_lock (log_control_descriptor_p^.lock);
    syp$establish_condition_handler (^condition_handler);

  /log_locked/
    BEGIN

{ Verify that the specified log cycle matches the log cycle in the log control descriptor.

      IF log_cycle <> log_control_descriptor_p^.log_cycle THEN
        osp$set_status_abnormal ('LG', lge$log_cycles_do_not_match, lgv$critical_log_name, status);
        EXIT /log_locked/;
      IFEND;

{ Make a copy of log_data to be used until a log entry is successfully retrieved.

      local_log_data := log_data;

{ Get the log entry header.

      NEXT log_entry_header_p IN local_log_data;
      IF log_entry_header_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$corrupted_log, lgv$critical_log_name, status);
        EXIT /log_locked/;
      ELSEIF log_entry_header_p^.current_size = 0 THEN
        osp$set_status_abnormal ('LG', lge$end_of_log, lgv$critical_log_name, status);
        EXIT /log_locked/;
      IFEND;

{ Get the critical window log entry.

      NEXT log_entry_p: [[REP log_entry_header_p^.current_size OF cell]] IN local_log_data;
      IF log_entry_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$corrupted_log, lgv$critical_log_name, status);
        EXIT /log_locked/;
      IFEND;

{ Return the actual size of the critical window log entry and as much of the critical
{ window log entry as will fit.

      log_entry_size := log_entry_header_p^.current_size;
      IF log_entry_size <= #SIZE (log_entry) THEN
        i#move (log_entry_p, ^log_entry, log_entry_size);
      ELSE
        i#move (log_entry_p, ^log_entry, #SIZE (log_entry));
      IFEND;

{ Update log_data.

      log_data := local_log_data;

    END /log_locked/;

{ Release the log interlock.

    osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
    syp$disestablish_cond_handler;

  PROCEND lgp$get_critical_log_entry;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lgp$get_log_entry', EJECT ??
{ PURPOSE:
{   Retrieve an entry from a log.

  PROCEDURE [XDCL] lgp$get_log_entry
    (    log_cycle: lgt$log_cycle;
         log_control_descriptor_p: ^lgt$log_control_descriptor;
     VAR log_data: ^SEQ ( * );
     VAR log_entry_size: lgt$log_entry_size;
     VAR log_entry: lgt$log_entry;
     VAR status: ost$status);

    VAR
      local_log_data: ^SEQ ( * ),
      log_entry_header_p: ^lgt$log_entry_header,
      log_entry_p: ^lgt$log_entry;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Make sure that the log interlock is cleared in the event of an error.

    PROCEDURE condition_handler
      (    monitor_fault: ost$monitor_fault;
           save_area: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$monitor_fault_to_status (monitor_fault, save_area, status);
      lgp$unlock_log (log_control_descriptor_p);
      EXIT lgp$get_log_entry;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Check if the log is available.

    IF log_control_descriptor_p^.log_data = NIL THEN
      osp$set_status_abnormal ('LG', lge$log_not_available, lgv$log_names [log_control_descriptor_p^.log],
            status);
      RETURN;
    IFEND;

{ Establish a condition handler and interlock the log.

    syp$establish_condition_handler (^condition_handler);
    lgp$lock_log (log_control_descriptor_p);

  /log_locked/
    BEGIN

{ Verify that the specified log cycle matches the log cycle in the log control descriptor.

      IF log_cycle <> log_control_descriptor_p^.log_cycle THEN
        osp$set_status_abnormal ('LG', lge$log_cycles_do_not_match,
              lgv$log_names [log_control_descriptor_p^.log], status);
        EXIT /log_locked/;
      IFEND;

{ Make a copy of log_data to be used until a log entry is successfully retrieved.

      local_log_data := log_data;

{ Get the log entry header.

      NEXT log_entry_header_p IN local_log_data;
      IF log_entry_header_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$corrupted_log, lgv$log_names [log_control_descriptor_p^.log],
              status);
        EXIT /log_locked/;
      ELSEIF log_entry_header_p^.current_size = 0 THEN
        osp$set_status_abnormal ('LG', lge$end_of_log, lgv$log_names [log_control_descriptor_p^.log], status);
        EXIT /log_locked/;
      IFEND;

{ Get the log entry.

      NEXT log_entry_p: [[REP log_entry_header_p^.current_size OF cell]] IN local_log_data;
      IF log_entry_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$corrupted_log, lgv$log_names [log_control_descriptor_p^.log],
              status);
        EXIT /log_locked/;
      IFEND;

{ Return the actual size of the log entry and as much of the log entry as will fit.

      log_entry_size := log_entry_header_p^.current_size;
      IF log_entry_size <= #SIZE (log_entry) THEN
        i#move (log_entry_p, ^log_entry, log_entry_size);
      ELSE
        i#move (log_entry_p, ^log_entry, #SIZE (log_entry));
      IFEND;

{ Update log_data.

      log_data := local_log_data;

    END /log_locked/;

{ Release the log interlock.

    lgp$unlock_log (log_control_descriptor_p);
    syp$disestablish_cond_handler;

  PROCEND lgp$get_log_entry;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lgp$get_previous_crit_log_size', EJECT ??
{ PURPOSE:
{   Retrieve the size of the previous critical window log entry.

  PROCEDURE [XDCL] lgp$get_previous_crit_log_size
    (    log_cycle: lgt$log_cycle;
         log_control_descriptor_p: ^lgt$critical_log_control_desc;
     VAR log_data: ^SEQ ( * );
     VAR previous_size: lgt$log_entry_size;
     VAR status: ost$status);

    VAR
      log_entry_header_p: ^lgt$log_entry_header;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Make sure that the log interlock is cleared in the event of an error.

    PROCEDURE condition_handler
      (    monitor_fault: ost$monitor_fault;
           save_area: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$monitor_fault_to_status (monitor_fault, save_area, status);
      osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
      EXIT lgp$get_previous_crit_log_size;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Check if the critical window log is available.

    IF log_control_descriptor_p^.log_data = NIL THEN
      osp$set_status_abnormal ('LG', lge$log_not_available, lgv$critical_log_name,
            status);
      RETURN;
    IFEND;

{ Lock the log before establishing the condition handler so that if the log was already locked
{ by another procedure in this task, this procedure doesn't unlock it.

    osp$set_mainframe_sig_lock (log_control_descriptor_p^.lock);
    syp$establish_condition_handler (^condition_handler);

  /log_locked/
    BEGIN

{ Verify that the specified log cycle matches the log cycle in the log control descriptor.

      IF log_cycle <> log_control_descriptor_p^.log_cycle THEN
        osp$set_status_abnormal ('LG', lge$log_cycles_do_not_match,
              lgv$critical_log_name, status);
        EXIT /log_locked/;
      IFEND;

{ Get the log entry header.

      NEXT log_entry_header_p IN log_data;
      IF log_entry_header_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$corrupted_log, lgv$critical_log_name,
              status);
        EXIT /log_locked/;
      ELSE
        previous_size := log_entry_header_p^.previous_size;
      IFEND;

    END /log_locked/;

{ Release the log interlock.

    osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
    syp$disestablish_cond_handler;

  PROCEND lgp$get_previous_crit_log_size;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lgp$get_previous_log_entry_size', EJECT ??
{ PURPOSE:
{   Retrieve the size of the previous log entry.

  PROCEDURE [XDCL] lgp$get_previous_log_entry_size
    (    log_cycle: lgt$log_cycle;
         log_control_descriptor_p: ^lgt$log_control_descriptor;
     VAR log_data: ^SEQ ( * );
     VAR previous_size: lgt$log_entry_size;
     VAR status: ost$status);

    VAR
      log_entry_header_p: ^lgt$log_entry_header;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Make sure that the log interlock is cleared in the event of an error.

    PROCEDURE condition_handler
      (    monitor_fault: ost$monitor_fault;
           save_area: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$monitor_fault_to_status (monitor_fault, save_area, status);
      lgp$unlock_log (log_control_descriptor_p);
      EXIT lgp$get_previous_log_entry_size;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Check if the log is available.

    IF log_control_descriptor_p^.log_data = NIL THEN
      osp$set_status_abnormal ('LG', lge$log_not_available, lgv$log_names [log_control_descriptor_p^.log],
            status);
      RETURN;
    IFEND;

{ Lock the log before establishing the condition handler so that if the log was already locked
{ by another procedure in this task, this procedure doesn't unlock it.

    lgp$lock_log (log_control_descriptor_p);
    syp$establish_condition_handler (^condition_handler);

  /log_locked/
    BEGIN

{ Verify that the specified log cycle matches the log cycle in the log control descriptor.

      IF log_cycle <> log_control_descriptor_p^.log_cycle THEN
        osp$set_status_abnormal ('LG', lge$log_cycles_do_not_match,
              lgv$log_names [log_control_descriptor_p^.log], status);
        EXIT /log_locked/;
      IFEND;

{ Get the log entry header.

      NEXT log_entry_header_p IN log_data;
      IF log_entry_header_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$corrupted_log, lgv$log_names [log_control_descriptor_p^.log],
              status);
        EXIT /log_locked/;
      ELSE
        previous_size := log_entry_header_p^.previous_size;
      IFEND;

    END /log_locked/;

{ Release the log interlock.

    lgp$unlock_log (log_control_descriptor_p);
    syp$disestablish_cond_handler;

  PROCEND lgp$get_previous_log_entry_size;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] lgp$lock_log', EJECT ??
{ PURPOSE:
{   This procedure is used to set the appropriate type of lock on a log.

  PROCEDURE [INLINE] lgp$lock_log
    (    log_control_descriptor_p: ^lgt$log_control_descriptor);

    IF log_control_descriptor_p^.log IN (-$pmt$global_logset []) THEN
      osp$set_mainframe_sig_lock (log_control_descriptor_p^.lock);
    ELSE
      osp$set_job_signature_lock (log_control_descriptor_p^.lock);
    IFEND;

  PROCEND lgp$lock_log;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] lgp$unlock_log', EJECT ??
{ PURPOSE:
{   This procedure is used to clear the lock on a log.

  PROCEDURE [INLINE] lgp$unlock_log
    (    log_control_descriptor_p: ^lgt$log_control_descriptor);

    IF log_control_descriptor_p^.log IN (-$pmt$global_logset []) THEN
      osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
    ELSE
      osp$clear_job_signature_lock (log_control_descriptor_p^.lock);
    IFEND;

  PROCEND lgp$unlock_log;
?? OLDTITLE ??
MODEND lgm$common_processors_r1;
*DECK DECK=LGM$COMMON_PROCESSORS_R2 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Logging: Common Processors Ring 2' ??
MODULE lgm$common_processors_r2;

{ PURPOSE:
{   This module contains common code used for both local and global logs.
{!!!!NOTE!!!! Any modifications made to this module must be reflected in lgm$common_processors_r1.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc lge$corrupted_log
*copyc lge$end_of_log
*copyc lge$log_cycles_do_not_match
*copyc lge$log_full
*copyc lge$log_not_available
*copyc lgt$log_control_descriptor
*copyc lgt$log_cycle
*copyc lgt$log_entry
*copyc lgt$log_entry_header
?? POP ??
*copyc clp$trimmed_string_size
*copyc dpp$put_critical_message
*copyc i#build_adaptable_seq_pointer
*copyc i#current_sequence_position
*copyc i#move
*copyc mmp$os_preallocate_file_space
*copyc osp$clear_job_signature_lock
*copyc osp$clear_mainframe_sig_lock
*copyc osp$establish_condition_handler
*copyc osp$disestablish_cond_handler
*copyc osp$monitor_fault_to_status
*copyc osp$set_job_signature_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$test_sig_lock
*copyc pmp$continue_to_cause
*copyc lgv$log_names
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$add_log_entry', EJECT ??
{ PURPOSE:
{   Adds an entry to a log.  The caller of this procedure must interlock the log before making this request.

  PROCEDURE [XDCL, #GATE] lgp$add_log_entry
    (    entry_p: ^lgt$log_entry;
         log_control_descriptor_p: ^lgt$log_control_descriptor;
     VAR status: ost$status);

    VAR
      log_entry_p: ^lgt$log_entry,
      local_log_data: ^SEQ ( * ),
      trailing_log_entry_header_p: ^lgt$log_entry_header;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Make sure that an error is returned in the event of an error.

    PROCEDURE condition_handler
      (    condition {input} : pmt$condition;
           condition_descriptor {input} : ^pmt$condition_information;
           save_area {input, output} : ^ost$stack_frame_save_area;
       VAR ch_status {output} : ost$status);

       CASE condition.selector OF
       = pmc$system_conditions, mmc$segment_access_condition =
         pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
         EXIT lgp$add_log_entry;

       ELSE
         pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
         RETURN;
       CASEND;

    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'preallocate_log_space', EJECT ??
{ PURPOSE:
{   Preallocates disk space for a log (if the log has not reached its maximum size).

    PROCEDURE preallocate_log_space
      (    log_control_descriptor_p: ^lgt$log_control_descriptor;
       VAR local_log_data: ^SEQ ( * );
       VAR status: ost$status);

      TYPE
        variant_sequence_pointer = record
          case boolean of
          = TRUE =
            cybil_definition: cyt$sequence_pointer,
          = FALSE =
            normal_definition: ^SEQ ( * ),
          casend,
        recend;

      VAR
        message: string (osc$max_string_size),
        message_length: integer,
        preallocated_size: ost$segment_length,
        sequence_pointer: variant_sequence_pointer;

      status.normal := TRUE;

      sequence_pointer.normal_definition := local_log_data;

{ If the log has not reached its maximum size, compute the new size.  Otherwise, return log full error.
{ The calculated size will always be an even multiple of the preallocation size.

      IF sequence_pointer.cybil_definition.length < log_control_descriptor_p^.maximum_size THEN
        preallocated_size := (((sequence_pointer.cybil_definition.length + lgc$maximum_log_entry_size) DIV
              log_control_descriptor_p^.preallocation_size) + 1) *
              log_control_descriptor_p^.preallocation_size;
        IF preallocated_size > log_control_descriptor_p^.maximum_size THEN
          preallocated_size := log_control_descriptor_p^.maximum_size;
        IFEND;

{ Preallocate the disk space.

        mmp$os_preallocate_file_space (local_log_data, preallocated_size, 0, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Adjust the length of the log data sequence.

        sequence_pointer.cybil_definition.length := preallocated_size;
        local_log_data := sequence_pointer.normal_definition;

{ Inform the operator if a global log is getting too large (greater than 75% of maximum size).

        IF (i#current_sequence_position (local_log_data) > ((log_control_descriptor_p^.maximum_size * 3) DIV
              4)) AND (log_control_descriptor_p^.log IN -$pmt$global_logset []) THEN
          IF log_control_descriptor_p^.critical_log THEN
            STRINGREP (message, message_length, lgv$log_names [log_control_descriptor_p^.log] (1,
                  clp$trimmed_string_size (lgv$log_names [log_control_descriptor_p^.log])), ' is',
                  ($REAL (i#current_sequence_position (local_log_data)) / 1000000.0): 7: 2,
                  'M bytes long, system will terminate at', (log_control_descriptor_p^.maximum_size DIV
                  1000000), 'M bytes.');
          ELSE
            STRINGREP (message, message_length, lgv$log_names [log_control_descriptor_p^.log] (1,
                  clp$trimmed_string_size (lgv$log_names [log_control_descriptor_p^.log])), ' is',
                  ($REAL (i#current_sequence_position (local_log_data)) / 1000000.0): 7: 2,
                  'M bytes long, logging will stop at', (log_control_descriptor_p^.maximum_size DIV 1000000),
                  'M bytes.');
          IFEND;
          dpp$put_critical_message (message (1, message_length), {ignore} status);
          status.normal := TRUE;
        IFEND;
      ELSE
        log_control_descriptor_p^.log_full := TRUE;
        osp$set_status_abnormal ('LG', lge$log_full, lgv$log_names [log_control_descriptor_p^.log], status);
      IFEND;

    PROCEND preallocate_log_space;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

{ Check if the log is available.

    IF log_control_descriptor_p^.log_data = NIL THEN
      osp$set_status_abnormal ('LG', lge$log_not_available, lgv$log_names [log_control_descriptor_p^.log],
            status);
      RETURN;
    IFEND;

{ Check if the log is full.

    IF log_control_descriptor_p^.log_full THEN
      osp$set_status_abnormal ('LG', lge$log_full, lgv$log_names [log_control_descriptor_p^.log], status);
      RETURN;
    IFEND;

{ Establish a condition handler.

    osp$establish_condition_handler (^condition_handler, FALSE);

{ Make a copy of the log data sequence pointer and use it until the log entry has been successfully placed in
{ the log.

    local_log_data := log_control_descriptor_p^.log_data;

{ Allocate space in the log for the log entry.  If the entry will not fit, try to preallocate more space.

    NEXT log_entry_p: [[REP #SIZE (entry_p^) OF cell]] IN local_log_data;
    IF log_entry_p = NIL THEN
      preallocate_log_space (log_control_descriptor_p, local_log_data, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      NEXT log_entry_p: [[REP #SIZE (entry_p^) OF cell]] IN local_log_data;
      IF log_entry_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$log_full, lgv$log_names [log_control_descriptor_p^.log], status);
        RETURN;
      IFEND;
    IFEND;

{ Allocate space in the log for the trailing log entry header.

    NEXT trailing_log_entry_header_p IN local_log_data;
    IF trailing_log_entry_header_p = NIL THEN
      preallocate_log_space (log_control_descriptor_p, local_log_data, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      NEXT trailing_log_entry_header_p IN local_log_data;
      IF trailing_log_entry_header_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$log_full, lgv$log_names [log_control_descriptor_p^.log], status);
        RETURN;
      IFEND;
    IFEND;

{ Move the log entry into the log.

    log_entry_p^ := entry_p^;

{ Initialize the trailing log entry header.

    trailing_log_entry_header_p^.previous_size := #SIZE (entry_p^);
    trailing_log_entry_header_p^.current_size := 0;

{ Update current size in log entry header that preceeds the log entry.

    log_control_descriptor_p^.trailing_log_entry_header_p^.current_size := #SIZE (entry_p^);

{ Save pointer to the new trailing log entry header in the log control descriptor.

    log_control_descriptor_p^.trailing_log_entry_header_p := trailing_log_entry_header_p;

{ Update the actual log data sequence pointer.

    log_control_descriptor_p^.log_data := local_log_data;

    osp$disestablish_cond_handler;

  PROCEND lgp$add_log_entry;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$get_log_read_information', EJECT ??
{ PURPOSE:
{   This procedure returns the log cycle and a log data sequence pointer that is positioned the specified
{   number of log entries from the end of the log.  If the log does not contain the specified number of
{   entries, the log data sequence pointer is positioned to the beginning of the log.  If zero is specified
{   for the number of entries, the log_data sequence will be positioned at the current end of the log.

  PROCEDURE [XDCL, #GATE] lgp$get_log_read_information
    (    log_control_descriptor_p: ^lgt$log_control_descriptor;
         entry_count_from_end_of_log: ost$segment_length;
     VAR log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR ending_offset: amt$file_byte_address;
     VAR status: ost$status);

    VAR
      count: ost$segment_length,
      log_entry_header: lgt$log_entry_header,
      log_entry_header_p: ^lgt$log_entry_header;

?? NEWTITLE := 'condition_handler', EJECT ??
{ PURPOSE:
{   Make sure that the log interlock is cleared in the event of an error.

    PROCEDURE condition_handler
      (    condition {input} : pmt$condition;
           condition_descriptor {input} : ^pmt$condition_information;
           save_area {input, output} : ^ost$stack_frame_save_area;
       VAR ch_status {output} : ost$status);

      VAR
        lock_status: ost$signature_lock_status;


       CASE condition.selector OF
       = pmc$block_exit_processing =
         osp$test_sig_lock (log_control_descriptor_p^.lock, lock_status);
         IF lock_status = osc$sls_locked_by_current_task THEN
           lgp$unlock_log (log_control_descriptor_p);
         IFEND;
         RETURN;

       = pmc$system_conditions, mmc$segment_access_condition =
         pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
         EXIT lgp$get_log_read_information;

       ELSE
         pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
         RETURN;
       CASEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Lock the log before establishing the condition handler so that if the log was already locked
{ by another procedure in this task, this procedure doesn't unlock it.

    lgp$lock_log (log_control_descriptor_p);
    osp$establish_condition_handler (^condition_handler, TRUE);

{ Get the log cycle and log data sequence information.

    log_cycle := log_control_descriptor_p^.log_cycle;
    IF log_control_descriptor_p^.log_data <> NIL THEN

{ Return a log data sequence pointer that reflects a sequence that is the larger of the actual log data
{ sequence or the declared maximum size.  This is necessary because the maximum size specified for the
{ log may changed (up or down) from one deadstart to the next and the size of a recovered log could exceed
{ the specified maximum.

      IF #SIZE (log_control_descriptor_p^.log_data^) > log_control_descriptor_p^.maximum_size THEN
        log_data := log_control_descriptor_p^.log_data;
      ELSE
        i#build_adaptable_seq_pointer (#RING (log_control_descriptor_p^.log_data),
              #SEGMENT (log_control_descriptor_p^.log_data), #OFFSET (log_control_descriptor_p^.log_data),
              log_control_descriptor_p^.maximum_size, i#current_sequence_position
              (log_control_descriptor_p^.log_data), log_data);
      IFEND;
      ending_offset := #OFFSET (log_control_descriptor_p^.trailing_log_entry_header_p);
    ELSE
      log_data := NIL;
      ending_offset := 0;
    IFEND;

{ If a non zero entry count was specified, back up the specified number of entries.  Exit if the beginning of
{ the log is found.

    IF (entry_count_from_end_of_log <> 0) AND (log_control_descriptor_p^.log_data <> NIL) THEN
      log_entry_header_p := log_control_descriptor_p^.trailing_log_entry_header_p;
      RESET log_data TO log_entry_header_p;

    /find_starting_location_in_log/
      FOR count := 1 TO entry_count_from_end_of_log DO
        IF log_entry_header_p^.previous_size = 0 THEN
          EXIT /find_starting_location_in_log/;
        ELSE
          log_entry_header_p := #ADDRESS (#RING (log_data), #SEGMENT (log_data),
                (i#current_sequence_position (log_data) - (#SIZE (lgt$log_entry_header) +
                log_entry_header_p^.previous_size)));
          RESET log_data TO log_entry_header_p;
        IFEND;
      FOREND /find_starting_location_in_log/;
    IFEND;

{ Release the log interlock.

    lgp$unlock_log (log_control_descriptor_p);
    osp$disestablish_cond_handler;

  PROCEND lgp$get_log_read_information;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$get_log_entry', EJECT ??
{ PURPOSE:
{   Retrieve an entry from a log.

  PROCEDURE [XDCL, #GATE] lgp$get_log_entry
    (    log_cycle: lgt$log_cycle;
         log_control_descriptor_p: ^lgt$log_control_descriptor;
     VAR log_data: ^SEQ ( * );
     VAR log_entry_size: lgt$log_entry_size;
     VAR log_entry: lgt$log_entry;
     VAR status: ost$status);

    VAR
      log_entry_header_p: ^lgt$log_entry_header,
      log_entry_p: ^lgt$log_entry,
      local_log_data: ^SEQ ( * );

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Make sure that the log interlock is cleared in the event of an error.

    PROCEDURE condition_handler
      (    condition {input} : pmt$condition;
           condition_descriptor {input} : ^pmt$condition_information;
           save_area {input, output} : ^ost$stack_frame_save_area;
       VAR ch_status {output} : ost$status);

      VAR
        lock_status: ost$signature_lock_status;

       CASE condition.selector OF
       = pmc$block_exit_processing =
         osp$test_sig_lock (log_control_descriptor_p^.lock, lock_status);
         IF lock_status = osc$sls_locked_by_current_task THEN
           lgp$unlock_log (log_control_descriptor_p);
         IFEND;
         RETURN;

       = pmc$system_conditions, mmc$segment_access_condition =
         pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
         EXIT lgp$get_log_entry;

       ELSE
         pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
         RETURN;
       CASEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Check if the log is available.

    IF log_control_descriptor_p^.log_data = NIL THEN
      osp$set_status_abnormal ('LG', lge$log_not_available, lgv$log_names [log_control_descriptor_p^.log],
            status);
      RETURN;
    IFEND;

{ Establish a condition handler and interlock the log.

    osp$establish_condition_handler (^condition_handler, TRUE);
    lgp$lock_log (log_control_descriptor_p);

  /log_locked/
    BEGIN

{ Verify that the specified log cycle matches the log cycle in the log control descriptor.

      IF log_cycle <> log_control_descriptor_p^.log_cycle THEN
        osp$set_status_abnormal ('LG', lge$log_cycles_do_not_match,
              lgv$log_names [log_control_descriptor_p^.log], status);
        EXIT /log_locked/;
      IFEND;

{ Make a copy of log_data to be used until a log entry is successfully retrieved.

      local_log_data := log_data;

{ Get the log entry header.

      NEXT log_entry_header_p IN local_log_data;
      IF log_entry_header_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$corrupted_log, lgv$log_names [log_control_descriptor_p^.log],
              status);
        EXIT /log_locked/;
      ELSEIF log_entry_header_p^.current_size = 0 THEN
        osp$set_status_abnormal ('LG', lge$end_of_log, lgv$log_names [log_control_descriptor_p^.log], status);
        EXIT /log_locked/;
      IFEND;

{ Get the log entry.

      NEXT log_entry_p: [[REP log_entry_header_p^.current_size OF cell]] IN local_log_data;
      IF log_entry_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$corrupted_log, lgv$log_names [log_control_descriptor_p^.log],
              status);
        EXIT /log_locked/;
      IFEND;

{ Return the actual size of the log entry and as much of the log entry as will fit.

      log_entry_size := log_entry_header_p^.current_size;
      IF log_entry_size <= #SIZE (log_entry) THEN
        i#move (log_entry_p, ^log_entry, log_entry_size);
      ELSE
        i#move (log_entry_p, ^log_entry, #SIZE (log_entry));
      IFEND;

{ Update log_data.

      log_data := local_log_data;

    END /log_locked/;

{ Release the log interlock.

    lgp$unlock_log (log_control_descriptor_p);
    osp$disestablish_cond_handler;

  PROCEND lgp$get_log_entry;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$get_previous_log_entry_size', EJECT ??
{ PURPOSE:
{   Retrieve the size of the previous log entry.

  PROCEDURE [XDCL, #GATE] lgp$get_previous_log_entry_size
    (    log_cycle: lgt$log_cycle;
         log_control_descriptor_p: ^lgt$log_control_descriptor;
     VAR log_data: ^SEQ ( * );
     VAR previous_size: lgt$log_entry_size;
     VAR status: ost$status);

    VAR
      log_entry_header_p: ^lgt$log_entry_header;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Make sure that the log interlock is cleared in the event of an error.

    PROCEDURE condition_handler
      (    condition {input} : pmt$condition;
           condition_descriptor {input} : ^pmt$condition_information;
           save_area {input, output} : ^ost$stack_frame_save_area;
       VAR ch_status {output} : ost$status);

      VAR
        lock_status: ost$signature_lock_status;

       CASE condition.selector OF
       = pmc$block_exit_processing =
         osp$test_sig_lock (log_control_descriptor_p^.lock, lock_status);
         IF lock_status = osc$sls_locked_by_current_task THEN
           lgp$unlock_log (log_control_descriptor_p);
         IFEND;
         RETURN;

       = pmc$system_conditions, mmc$segment_access_condition =
         pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
         EXIT lgp$get_previous_log_entry_size;

       ELSE
         pmp$continue_to_cause (pmc$execute_standard_procedure, ch_status);
         RETURN;
       CASEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Check if the log is available.

    IF log_control_descriptor_p^.log_data = NIL THEN
      osp$set_status_abnormal ('LG', lge$log_not_available, lgv$log_names [log_control_descriptor_p^.log],
            status);
      RETURN;
    IFEND;

{ Lock the log before establishing the condition handler so that if the log was already locked
{ by another procedure in this task, this procedure doesn't unlock it.

    lgp$lock_log (log_control_descriptor_p);
    osp$establish_condition_handler (^condition_handler, TRUE);

  /log_locked/
    BEGIN

{ Verify that the specified log cycle matches the log cycle in the log control descriptor.

      IF log_cycle <> log_control_descriptor_p^.log_cycle THEN
        osp$set_status_abnormal ('LG', lge$log_cycles_do_not_match,
              lgv$log_names [log_control_descriptor_p^.log], status);
        EXIT /log_locked/;
      IFEND;

{ Get the log entry header.

      NEXT log_entry_header_p IN log_data;
      IF log_entry_header_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$corrupted_log, lgv$log_names [log_control_descriptor_p^.log],
              status);
        EXIT /log_locked/;
      ELSE
        previous_size := log_entry_header_p^.previous_size;
      IFEND;

    END /log_locked/;

{ Release the log interlock.

    lgp$unlock_log (log_control_descriptor_p);
    osp$disestablish_cond_handler;

  PROCEND lgp$get_previous_log_entry_size;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] lgp$lock_log', EJECT ??
{ PURPOSE:
{   This procedure is used to set the appropriate type of lock on a log.

  PROCEDURE [INLINE] lgp$lock_log
    (    log_control_descriptor_p: ^lgt$log_control_descriptor);

    IF log_control_descriptor_p^.log IN (-$pmt$global_logset []) THEN
      osp$set_mainframe_sig_lock (log_control_descriptor_p^.lock);
    ELSE
      osp$set_job_signature_lock (log_control_descriptor_p^.lock);
    IFEND;

  PROCEND lgp$lock_log;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] lgp$unlock_log', EJECT ??
{ PURPOSE:
{   This procedure is used to clear the lock on a log.

  PROCEDURE [INLINE] lgp$unlock_log
    (    log_control_descriptor_p: ^lgt$log_control_descriptor);

    IF log_control_descriptor_p^.log IN (-$pmt$global_logset []) THEN
      osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
    ELSE
      osp$clear_job_signature_lock (log_control_descriptor_p^.lock);
    IFEND;

  PROCEND lgp$unlock_log;
?? OLDTITLE ??
MODEND lgm$common_processors_r2;
*DECK DECK=LGM$DISPLAY_BINARY_LOG EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'Display_Binary_Log - Display NOS/VE Binary Log' ??
?? NEWTITLE := '   ' ??
MODULE lgm$display_binary_log;

  CONST
    maximum_integer = 7fffffffffff(16);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_expression_result
*copyc pme$logging_exceptions
*copyc ost$string
*copyc jmt$system_supplied_name
*copyc sfd$type_declarations
*copyc sft$statistic_buffer
*copyc pmp$get_unique_name
*copyc pmp$get_compact_date_time
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pmp$this_is_a_leap_year
*copyc sft$global_log_statistic_header
*copyc pmp$exit
*copyc amp$file
*copyc amp$rewind
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$close
*copyc amp$get_next
*copyc amp$put_next
*copyc pmd$system_log_interface
*copyc pmp$cause_condition
*copyc pmp$establish_condition_handler
*copyc osp$set_status_abnormal
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$status_condition_code
*copyc osp$unpack_status_condition
*copyc clp$scan_token
*copyc clp$convert_string_to_integer
*copyc clp$convert_value_to_string
*copyc clp$push_utility
*copyc clp$pop_utility
*copyc clp$scan_command_file
*copyc clp$end_scan_command_file
*copyc clp$scan_parameter_list
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$get_value
*copyc clp$test_parameter
*copyc clt$integer
*copyc cld$parameter_limits
*copyc clp$get_set_count
*copyc clp$get_path_description
*copyc clp$test_range
*copyc lgp$parse_statistic
*copyc pfp$define
*copyc pfp$define_catalog
?? POP ??
?? EJECT, TITLE := 'Global definitions' ??

  VAR
    input_buffer: sft$statistic_buffer,
    input_file_position: amt$file_position,
    p_stat_header: ^sft$global_log_statistic_header,
    p_stat_counters: sft$counters,
    p_stat_descript: ^sft$descriptive_data,
    abnormal_status: ost$status,
    input_file,
    output_file,
    command_file: amt$file_identifier,
    abnormal_condition: pmt$condition := [pmc$user_defined_condition, abnormal_status_condition],
    local_status: ost$status,
    input_file_name: amt$local_file_name,
    output_file_name: amt$local_file_name,
    group_file_name: amt$local_file_name,
    group_file_path: array [1 .. 3] of pft$name := [osc$null_name, osc$null_name, osc$null_name],
    file_byte_address: amt$file_byte_address;

  VAR
    log_type: pmt$global_binary_logs,
    input_from_file: boolean; { true if not reading from active log }

  VAR
    alpha_chars: [STATIC] set of char := ['A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M',
      'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'];

?? EJECT ??
{  Definitions for data analysis code  }

  CONST
    max_name_size = 32,
    blank_name = '                                ',
    blank_passw = '                               ',
    abnormal_status_condition = 'ABNORMAL_STATUS                ',
    default_output = '$OUTPUT                        ';

  TYPE
    name_type = string (max_name_size),

    task_succ_group_list = array [ * ] of ^group_ctl_blk,

    job_succ_group_list = array [ * ] of ^group_ctl_blk,

    metric_list = array [ * ] of ^metric_ctl_blk;

  TYPE
    pred_job_blk = record
      job_seq_number: jmt$system_supplied_name,
      pred_job_link: ^pred_job_blk,
    recend;

  TYPE
    pred_task_blk = record
      global_task_id: ost$global_task_id,
      pred_task_link: ^pred_task_blk,
    recend;

  TYPE
    stat_code_ctl_blk = record
      code_chain_link: ^stat_code_ctl_blk,
      stat_code: sft$statistic_code,
    recend;

  TYPE
    group_ctl_blk = record
      name: name_type,
      pred_task_group_name: name_type,
      pred_job_group_name: name_type,
      group_chain_link: ^group_ctl_blk,
      stat_specified: boolean,
      stat_code: sft$statistic_code,
      date_specified: boolean,
      time_specified: boolean,
      start_dt: ost$date_time,
      end_dt: ost$date_time,
      p_task_succ_group_list: ^task_succ_group_list,
      p_job_succ_group_list: ^job_succ_group_list,
      desc_specified: boolean,
      desc_data_size: 0 .. sfc$max_descriptive_data_size,
      desc_data: string (sfc$max_descriptive_data_size),
      between_active: boolean,
      p_metric_list: ^metric_list,
      copy_requested: boolean,
      copy_file_identifier: amt$file_identifier,
      p_pred_task_head: ^pred_task_blk,
      p_pred_job_head: ^pred_job_blk,
      desc_needed: boolean,
      p_desc_blk: ^desc_blk,
    recend;

  TYPE
    metric_ctl_blk = record
      name: name_type,
      group_name: name_type,
      metric_chain_link: ^metric_ctl_blk,
      p_group_ctl_blk: ^group_ctl_blk,
      element_sequence: amt$segment_pointer,
      element_count: integer,
      incremental: boolean,
      previous_value: integer,
      first_element: boolean,
      maximum: integer,
      minimum: integer,
      time_stamp_needed: boolean,
      p_report_ctl_blk: ^report_ctl_blk,
      file_identifier: amt$file_identifier,
      scale_factor: integer,
      unit: string (max_name_size),

      case metric_type: metric_types of
      = counter_metric =
        counter_number: 1 .. sfc$max_number_of_counters,
      casend,
    recend;

  TYPE
    metric_types = (counter_metric, interval_metric, expression_metric, undefined_metric);

  TYPE
    date_time_metric = record
      counter_value: integer,
      time_value: integer,
      date_value: integer,
    recend;

  TYPE
    input_log_blk = record
      log_chain_link: ^input_log_blk,
      log_file_name: amt$local_file_name,
      file_ref: clt$file_reference,
      start_time: ost$date_time,
      end_time: ost$date_time,
    recend;

  TYPE
    desc_blk = record
      desc_chain_link: ^desc_blk,
      count: integer,
      desc_data_size: 0 .. sfc$max_descriptive_data_size,
      desc_data: string (sfc$max_descriptive_data_size),
    recend;

?? EJECT ??

  TYPE
    report_ctl_blk = record
      report_chain_link: ^report_ctl_blk,
      title: ost$string,
      metric_name: name_type,
      p_metric_ctl_blk: ^metric_ctl_blk,
      case report_type: report_types of
      = summary_report =
        low_limit: integer,
        high_limit: integer,
        num: boolean,
        mean: boolean,
        min: boolean,
        max: boolean,
        variance: boolean,
        interval: boolean,
        sum: boolean,
        interval_value: integer,

      = distribution_report =
        x_low_limit,
        x_high_limit: integer,
        cnt_low_limit,
        cnt_high_limit: integer,
        display_option: display_types,
        x_interval: interval_types,

      = datades_report, dump_report, gen_group_file =
        group_name: name_type,
        p_group_ctl_blk: ^group_ctl_blk,
        counter_radix: array [1 .. sfc$max_number_of_counters] of 1 .. 16,
        file_name: amt$local_file_name,
        permanent: boolean,

      = time_distribution_report =
        metric_low_limit: 0 .. 0ffffffff(16),
        metric_high_limit: 0 .. 0ffffffff(16),

      casend,
    recend,

    report_types = (list_report, summary_report, distribution_report, datades_report, scatter_report,
      dump_report, gen_group_file, time_distribution_report),
    display_types = (max_min_bound, first_max_centered, second_max_centered),
    interval_types = (self_adjust, large, medium, small);

?? EJECT ??
{  Data structure variables  }

  VAR
    stat_name_chain_head: ^stat_code_ctl_blk,
    log_chain_head: ^input_log_blk,
    group_chain_head: ^group_ctl_blk,
    metric_chain_head: ^metric_ctl_blk,
    report_chain_head: ^report_ctl_blk,
    p_log_blk: ^input_log_blk;

  VAR
    p_access_array: ^array [ * ] of amt$access_selection,

    read_only_access_array: [STATIC, READ] array [1 .. 1] of amt$access_selection := [[amc$access_mode,
      $pft$usage_selections [pfc$read]]];

?? TITLE := 'DISBL Command Utility Processor', NEWTITLE := '  ' ??
?? EJECT, TITLE := 'Program header' ??

  PROGRAM lgp$display_binary_log (program_parameters: clt$parameter_list;
    VAR program_status: ost$status);

?? EJECT, TITLE := 'Local Variables' ??
?? RIGHT := 110 ??
{ PDT command_pdt (
{     input, i:  FILE
{     type, t:  KEY statistic, statistics, account,accounting,...
{       engineering = statistic
{     output, o: FILE = $OUTPUT
{     status )

?? PUSH (LISTEXT := ON) ??

    VAR
      command_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^command_pdt_names,
        ^command_pdt_params];

    VAR
      command_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
        clt$parameter_name_descriptor := [['INPUT', 1], ['I', 1], ['TYPE', 2], ['T', 2], ['OUTPUT', 3], ['O',
        3], ['STATUS', 4]];

    VAR
      command_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor := [

{ INPUT I }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ TYPE T }
      [[clc$optional_with_default, ^command_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
        [^command_pdt_kv2, clc$keyword_value]],

{ OUTPUT O }
      [[clc$optional_with_default, ^command_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      command_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of ost$name := ['STATISTIC',
        'STATISTICS', 'ACCOUNT', 'ACCOUNTING', 'ENGINEERING'];

    VAR
      command_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (9) := 'statistic';

    VAR
      command_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??
?? EJECT ??
{  The subcommand list  }

{ table sub_command_list t=c s=local
{ command (define_group                     ,defg) defg_subcommand cm=local
{ command (define_metric                    ,defm) defm_subcommand cm=local
{ command (display_summary                  ,diss) diss_subcommand cm=local
{ command (display_distribution             ,disd) disd_subcommand cm=local
{ command (display_logged_statistics        ,disls) disls_subcommand cm=local
{ command (display_time_distribution        ,distd) distd_subcommand cm=local
{ command (display_descriptive_data         ,disdd) disdd_subcommand cm=local
{ command (dump_group                       ,dumg) dumg_subcommand cm=local
{ command (generate_group_file              ,gengf) gengf_subcommand cm=local
{ command (quit                             ,qui) qui_subcommand cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??
VAR
  sub_command_list: [STATIC, READ] ^clt$command_table := ^sub_command_list_entries,

  sub_command_list_entries: [STATIC, READ] array [1 .. 20] of  clt$command_table_entry := [
  {} ['DEFG                           ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^defg_subcommand],
  {} ['DEFINE_GROUP                   ', clc$nominal_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^defg_subcommand],
  {} ['DEFINE_METRIC                  ', clc$nominal_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^defm_subcommand],
  {} ['DEFM                           ', clc$abbreviation_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^defm_subcommand],
  {} ['DISD                           ', clc$abbreviation_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^disd_subcommand],
  {} ['DISDD                          ', clc$abbreviation_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^disdd_subcommand],
  {} ['DISLS                          ', clc$abbreviation_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^disls_subcommand],
  {} ['DISPLAY_DESCRIPTIVE_DATA       ', clc$nominal_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^disdd_subcommand],
  {} ['DISPLAY_DISTRIBUTION           ', clc$nominal_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^disd_subcommand],
  {} ['DISPLAY_LOGGED_STATISTICS      ', clc$nominal_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^disls_subcommand],
  {} ['DISPLAY_SUMMARY                ', clc$nominal_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^diss_subcommand],
  {} ['DISPLAY_TIME_DISTRIBUTION      ', clc$nominal_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^distd_subcommand],
  {} ['DISS                           ', clc$abbreviation_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^diss_subcommand],
  {} ['DISTD                          ', clc$abbreviation_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^distd_subcommand],
  {} ['DUMG                           ', clc$abbreviation_entry, clc$advertised_entry, 8,
        clc$automatically_log, clc$linked_call, ^dumg_subcommand],
  {} ['DUMP_GROUP                     ', clc$nominal_entry, clc$advertised_entry, 8,
        clc$automatically_log, clc$linked_call, ^dumg_subcommand],
  {} ['GENERATE_GROUP_FILE            ', clc$nominal_entry, clc$advertised_entry, 9,
        clc$automatically_log, clc$linked_call, ^gengf_subcommand],
  {} ['GENGF                          ', clc$abbreviation_entry, clc$advertised_entry, 9,
        clc$automatically_log, clc$linked_call, ^gengf_subcommand],
  {} ['QUI                            ', clc$abbreviation_entry, clc$advertised_entry, 10,
        clc$automatically_log, clc$linked_call, ^qui_subcommand],
  {} ['QUIT                           ', clc$nominal_entry, clc$advertised_entry, 10,
        clc$automatically_log, clc$linked_call, ^qui_subcommand]];

?? POP ??


?? EJECT, TITLE := 'PROCEDURE initialize' ??

    PROCEDURE initialize;

      TYPE
        log_keywords = (account, accounting, statistic, statistics, engineering),
        keyword_set = set of log_keywords;

      VAR
        keyword_index: log_keywords,
        keyword_array: [STATIC, READ] array [log_keywords] of string (16) := ['ACCOUNT         ',
          'ACCOUNTING      ', 'STATISTIC       ', 'STATISTICS      ', 'ENGINEERING     '],

        log_name_array: [STATIC, READ] array [pmt$global_binary_logs] of amt$local_file_name := [
          '$ACCOUNT_LOG                   ', '$ENGINEERING_LOG               ',
          '$HISTORY_LOG                   ', '$SECURITY                      ',
          '$STATISTIC_LOG                 '];

      VAR
        parameter_value: clt$value;

      VAR
        output_access_array: [STATIC, READ] array [1 .. 1] of amt$access_selection := [[amc$file_contents,
          amc$list]];

      VAR
        set_count: 0 .. clc$max_value_sets,
        temp_index: integer,
        act_file: clt$file,
        path: ^pft$path,
        path_con: clt$path_container,
        cycle_sel: clt$cycle_selector,
        open_pos: clt$open_position,
        p_log_blk: ^input_log_blk,
        log_chain_tail: ^input_log_blk;


      stat_name_chain_head := NIL;
      log_chain_head := NIL;
      group_chain_head := NIL;
      metric_chain_head := NIL;
      report_chain_head := NIL;

      { Process the command parameters }

      clp$scan_parameter_list (program_parameters, command_pdt, local_status);
      check_status (local_status);

      { Process the INPUT parameter }

      clp$test_parameter ('INPUT', input_from_file, local_status);
      check_status (local_status);

      IF input_from_file THEN
        clp$get_set_count ('INPUT', set_count, local_status);
        check_status (local_status);
        IF set_count > 0 THEN
          FOR temp_index := 1 TO set_count DO
            clp$get_value ('INPUT', temp_index, 1, clc$low, parameter_value, local_status);
            check_status (local_status);
            ALLOCATE p_log_blk;
            p_log_blk^.log_file_name := parameter_value.file.local_file_name;
            clp$get_path_description (parameter_value.file, p_log_blk^.file_ref, path_con, path, cycle_sel,
                  open_pos, local_status);
            check_status (local_status);
            p_log_blk^.log_chain_link := NIL;
            IF log_chain_head = NIL THEN
              log_chain_head := p_log_blk;
            ELSE
              log_chain_tail^.log_chain_link := p_log_blk;
            IFEND;
            log_chain_tail := p_log_blk;
          FOREND;
        IFEND;
        p_access_array := ^read_only_access_array;
      IFEND;

      { Process the OUTPUT parameter }

      clp$get_value ('OUTPUT', 1, 1, clc$low, parameter_value, local_status);
      check_status (local_status);
      output_file_name := parameter_value.file.local_file_name;

      { Process the TYPE parameter }

      clp$get_value ('TYPE', 1, 1, clc$low, parameter_value, local_status);
      check_status (local_status);

    /identify_log/
      FOR keyword_index := account TO engineering DO
        IF keyword_array [keyword_index] (1, parameter_value.name.size) = parameter_value.name.value (1,
              parameter_value.name.size) THEN
          EXIT /identify_log/
        IFEND;
      FOREND /identify_log/;

      IF keyword_index IN $keyword_set [statistic, statistics] THEN
        log_type := pmc$statistic_log;
      IFEND;

      IF keyword_index IN $keyword_set [account, accounting] THEN
        log_type := pmc$account_log;
      IFEND;

      IF keyword_index IN $keyword_set [engineering] THEN
        log_type := pmc$engineering_log;
      IFEND;

      IF NOT input_from_file THEN
        ALLOCATE p_log_blk;
        p_log_blk^.log_file_name := log_name_array [log_type];
        act_file.local_file_name := log_name_array [log_type];
        clp$get_path_description (act_file, p_log_blk^.file_ref, path_con, path, cycle_sel, open_pos,
              local_status);
        check_status (local_status);
        p_log_blk^.log_chain_link := NIL;
        log_chain_head := p_log_blk;
        p_access_array := ^read_only_access_array;
      IFEND;


      { Input files will be opened in the main program before Proc scan_log }

      { Open the output file }

      amp$open (output_file_name, amc$record, ^output_access_array, output_file, local_status);
      check_status (local_status);

    PROCEND initialize;
?? EJECT, TITLE := 'FUNCTION in_group' ??

    FUNCTION in_group (p_group_ctl_blk: ^group_ctl_blk;
          p_header: ^sft$global_log_statistic_header;
          p_counters: sft$counters;
          p_descript: ^sft$descriptive_data): boolean;

      VAR
        stat_rec_dt,
        dt_lower_bound,
        dt_upper_bound: integer;

      in_group := FALSE;

      { check stat_id and stat_code }

      IF p_group_ctl_blk^.stat_specified AND (p_header^.statistic_code <> p_group_ctl_blk^.stat_code) THEN
        RETURN;
      IFEND;

      { check descriptive data }

      IF p_group_ctl_blk^.desc_specified AND ((p_header^.descriptive_data_size = 0) OR (p_group_ctl_blk^.
            desc_data (1, p_group_ctl_blk^.desc_data_size) <> p_descript^ (1, p_group_ctl_blk^.
            desc_data_size))) THEN
        RETURN;
      IFEND;

      { check the date range }

      IF p_group_ctl_blk^.date_specified THEN
        stat_rec_dt := p_header^.date_time.year * 10000 + p_header^.date_time.month * 100 + p_header^.
              date_time.day;
        dt_lower_bound := p_group_ctl_blk^.start_dt.year * 10000 + p_group_ctl_blk^.start_dt.month * 100 +
              p_group_ctl_blk^.start_dt.day;
        dt_upper_bound := p_group_ctl_blk^.end_dt.year * 10000 + p_group_ctl_blk^.end_dt.month * 100 +
              p_group_ctl_blk^.end_dt.day;
        IF (stat_rec_dt < dt_lower_bound) OR (stat_rec_dt > dt_upper_bound) THEN
          RETURN;
        IFEND;
      IFEND;

      { check the time range }

      IF p_group_ctl_blk^.time_specified THEN
        stat_rec_dt := p_header^.date_time.hour * 10000 + p_header^.date_time.minute * 100 + p_header^.
              date_time.second;
        dt_lower_bound := p_group_ctl_blk^.start_dt.hour * 10000 + p_group_ctl_blk^.start_dt.minute * 100 +
              p_group_ctl_blk^.start_dt.second;
        dt_upper_bound := p_group_ctl_blk^.end_dt.hour * 10000 + p_group_ctl_blk^.end_dt.minute * 100 +
              p_group_ctl_blk^.end_dt.second;
        IF (stat_rec_dt < dt_lower_bound) OR (stat_rec_dt > dt_upper_bound) THEN
          RETURN;
        IFEND;
      IFEND;

      in_group := TRUE;

    FUNCEND in_group;
?? EJECT, TITLE := 'PROCEDURE print_title' ??

    PROCEDURE print_title (ctl_blk: report_ctl_blk;
          report_title: string ( * ));

      VAR
        center: integer,
        dt_str1,
        dt_str2: string (20),
        from_dt,
        to_dt: ost$date_time,
        g_ctl_blk: group_ctl_blk,
        line_image: string (132);

      VAR
        dashes: [STATIC, READ] string (75) :=
          '---------------------------------------------------------------------------';

      line_image (1) := '1';
      line_image (2, * ) := ctl_blk.title.value (1, 131);
      print (line_image);

      line_image := ' Display_Binary_Log       ';
      print (line_image);

      IF (ctl_blk.report_type = datades_report) OR (ctl_blk.report_type = dump_report) THEN
          g_ctl_blk := ctl_blk.p_group_ctl_blk^;
      ELSE
          g_ctl_blk := ctl_blk.p_metric_ctl_blk^.p_group_ctl_blk^;
      IFEND;

      IF (g_ctl_blk.date_specified) OR (g_ctl_blk.time_specified) THEN
        convert_date_time (g_ctl_blk.start_dt, dt_str1);
        convert_date_time (g_ctl_blk.end_dt, dt_str2);
      IFEND;
      IF (g_ctl_blk.date_specified) AND (g_ctl_blk.time_specified) THEN
        line_image := ' DATE : ';
        line_image (32, 7) := 'TIME : ';
        line_image (17, 2) := '..';
        line_image (47, 2) := '..';
        line_image (9, 8) := dt_str1 (1, 8);
        line_image (19, 8) := dt_str2 (1, 8);
        line_image (39, 8) := dt_str1 (11, 8);
        line_image (49, 8) := dt_str2 (11, 8);
      ELSE
        IF g_ctl_blk.date_specified THEN
          line_image := ' DATE : ';
          line_image (17, 2) := '..';
          line_image (9, 8) := dt_str1 (1, 8);
          line_image (19, 8) := dt_str2 (1, 8);
        ELSE
          IF g_ctl_blk.time_specified THEN
            line_image := ' TIME : ';
            line_image (17, 2) := '..';
            line_image (9, 8) := dt_str1 (11, 8);
            line_image (19, 8) := dt_str2 (11, 8);
          IFEND;
        IFEND;
      IFEND;
      IF (g_ctl_blk.date_specified) OR (g_ctl_blk.time_specified) THEN
        print (line_image);
      IFEND;

      line_image := '-';
      print (line_image);

      IF (ctl_blk.report_type = distribution_report) OR (ctl_blk.report_type = datades_report) THEN
        center := 60;
      ELSE
        center := 40;
      IFEND;

      line_image (center - (#SIZE (report_title) DIV 2), * ) := report_title;
      print (line_image);

      line_image (center - (#SIZE (report_title) DIV 2), * ) := dashes (1, #SIZE (report_title));
      line_image (1) := ' ';
      print (line_image);


      print ('-');

    PROCEND print_title;
?? EJECT, TITLE := 'PROCEDURE display_log_info' ??

    PROCEDURE display_log_info;

      VAR
        line_image: string (132);

      p_log_blk := log_chain_head;

      WHILE p_log_blk <> NIL DO
        line_image := '0   *****  LOG   SCANNED:';
        line_image (30, p_log_blk^.file_ref.path_name_size) := p_log_blk^.file_ref.path_name (1, p_log_blk^.
              file_ref.path_name_size);
        print (line_image);
        line_image := '           STARTING TIME:';
        convert_date_time (p_log_blk^.start_time, line_image (30, 20));
        print (line_image);
        line_image := '           ENDING   TIME:';
        convert_date_time (p_log_blk^.end_time, line_image (30, 20));
        print (line_image);
        p_log_blk := p_log_blk^.log_chain_link;
      WHILEND;

    PROCEND display_log_info;
?? EJECT, TITLE := 'PROCEDURE link_blocks' ??

    PROCEDURE link_blocks;

      VAR
        p_group_ctl_blk: ^group_ctl_blk,
        p_group_blk_temp: ^group_ctl_blk,
        task_succ_index,
        job_succ_index: integer,
        p_task_succ_group_list: ^task_succ_group_list,
        p_job_succ_group_list: ^job_succ_group_list,
        temp_index: integer,
        p_metric_ctl_blk: ^metric_ctl_blk,
        p_metric_list: ^metric_list,
        p_report_ctl_blk: ^report_ctl_blk,
        file_name: ost$name,
        metric_list_index: integer,
        temp_p_desc_blk: ^desc_blk;

      VAR
        file_access_selections: [STATIC, READ] array [1 .. 1] of amt$access_selection := [[amc$return_option,
          amc$return_at_close]];

      { Loop through the group chain... }

      p_group_ctl_blk := group_chain_head;
      WHILE p_group_ctl_blk <> NIL DO
        { First, chain the predecessor and successors by pointer to
        { successor group lists ( task and job ) }

        p_group_blk_temp := group_chain_head;
        task_succ_index := 0;
        job_succ_index := 0;
        WHILE p_group_blk_temp <> NIL DO
          IF p_group_blk_temp^.pred_task_group_name = p_group_ctl_blk^.name THEN
            task_succ_index := task_succ_index + 1;
          IFEND;
          IF p_group_blk_temp^.pred_job_group_name = p_group_ctl_blk^.name THEN
            job_succ_index := job_succ_index + 1;
          IFEND;
          p_group_blk_temp := p_group_blk_temp^.group_chain_link;
        WHILEND;

        IF task_succ_index > 0 THEN
          ALLOCATE p_task_succ_group_list: [1 .. task_succ_index];
          FOR temp_index := 1 TO task_succ_index DO
            p_task_succ_group_list^ [temp_index] := NIL;
          FOREND;
          p_group_ctl_blk^.p_task_succ_group_list := p_task_succ_group_list;
        IFEND;
        IF job_succ_index > 0 THEN
          ALLOCATE p_job_succ_group_list: [1 .. job_succ_index];
          FOR temp_index := 1 TO job_succ_index DO
            p_job_succ_group_list^ [temp_index] := NIL;
          FOREND;
          p_group_ctl_blk^.p_job_succ_group_list := p_job_succ_group_list;
        IFEND;

        IF (task_succ_index > 0) OR (job_succ_index > 0) THEN
          p_group_blk_temp := group_chain_head;
          task_succ_index := 1;
          job_succ_index := 1;
          WHILE p_group_blk_temp <> NIL DO
            IF p_group_blk_temp^.pred_task_group_name = p_group_ctl_blk^.name THEN
              p_group_ctl_blk^.p_task_succ_group_list^ [task_succ_index] := p_group_blk_temp;
              task_succ_index := task_succ_index + 1;
            IFEND;
            IF p_group_blk_temp^.pred_job_group_name = p_group_ctl_blk^.name THEN
              p_group_ctl_blk^.p_job_succ_group_list^ [job_succ_index] := p_group_blk_temp;
              job_succ_index := job_succ_index + 1;
            IFEND;
            p_group_blk_temp := p_group_blk_temp^.group_chain_link;
          WHILEND;
        IFEND;

        { Second, count the number of metrics that specify the current
        { group. }

        metric_list_index := 0;
        p_metric_ctl_blk := metric_chain_head;
        WHILE p_metric_ctl_blk <> NIL DO
          IF p_metric_ctl_blk^.group_name = p_group_ctl_blk^.name THEN
            metric_list_index := metric_list_index + 1;
            p_metric_ctl_blk^.p_group_ctl_blk := p_group_ctl_blk;
          IFEND;
          p_metric_ctl_blk := p_metric_ctl_blk^.metric_chain_link;
        WHILEND;

        { If this group is used by at least one metric,
        { Allocate space for the metric list, and set the group
        { control block to point to it. }

        IF metric_list_index > 0 THEN

          ALLOCATE p_metric_list: [1 .. metric_list_index];
          p_group_ctl_blk^.p_metric_list := p_metric_list;

          { Loop through the metric chain again. This time, fill in
          { the entries in the metric list. }

          metric_list_index := 1;
          p_metric_ctl_blk := metric_chain_head;
          WHILE p_metric_ctl_blk <> NIL DO
            IF p_metric_ctl_blk^.group_name = p_group_ctl_blk^.name THEN
              p_metric_list^ [metric_list_index] := p_metric_ctl_blk;
              metric_list_index := metric_list_index + 1;
            IFEND;
            p_metric_ctl_blk := p_metric_ctl_blk^.metric_chain_link;
          WHILEND;

        IFEND;

        { Find the next group to link. }


        p_group_ctl_blk := p_group_ctl_blk^.group_chain_link;

      WHILEND;
?? EJECT ??
      { Scan through the report control blocks. }

      p_report_ctl_blk := report_chain_head;
      WHILE p_report_ctl_blk <> NIL DO

        CASE p_report_ctl_blk^.report_type OF

        = dump_report, gen_group_file =


          { If a dump report is requested, set the copy flag for the group. }

          find_group (p_report_ctl_blk^.group_name, p_group_ctl_blk);
          IF p_group_ctl_blk = NIL THEN

            osp$set_status_abnormal (pmc$external_log_management_id, pme$undefined_group_for_dump,
                  p_report_ctl_blk^.group_name, local_status);
            check_status (local_status);

          ELSE

            p_report_ctl_blk^.p_group_ctl_blk := p_group_ctl_blk;

            pmp$get_unique_name (file_name, local_status);
            check_status (local_status);
            amp$open (file_name, amc$record, ^file_access_selections, p_group_ctl_blk^.
                  copy_file_identifier, local_status);
            check_status (local_status);

            p_group_ctl_blk^.copy_requested := TRUE;

          IFEND;

        = datades_report =

          find_group (p_report_ctl_blk^.group_name, p_group_ctl_blk);
          IF p_group_ctl_blk = NIL THEN
            osp$set_status_abnormal (pmc$external_log_management_id, pme$undefined_group_for_dump,
                  p_report_ctl_blk^.group_name, local_status);
            check_status (local_status);
          ELSE
            p_group_ctl_blk^.desc_needed := TRUE;
            ALLOCATE temp_p_desc_blk;
            temp_p_desc_blk^.desc_chain_link := NIL;
            temp_p_desc_blk^.count := 0;
            temp_p_desc_blk^.desc_data := ' ';
            temp_p_desc_blk^.desc_data_size := 0;
            p_group_ctl_blk^.p_desc_blk := temp_p_desc_blk;
            p_report_ctl_blk^.p_group_ctl_blk := p_group_ctl_blk;
          IFEND;

        = summary_report, distribution_report =

          find_metric (p_report_ctl_blk^.metric_name, p_report_ctl_blk^.p_metric_ctl_blk);
          IF p_report_ctl_blk^.p_metric_ctl_blk = NIL THEN

            osp$set_status_abnormal (pmc$external_log_management_id, pme$undefined_metric, p_report_ctl_blk^.
                  metric_name, local_status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_report_ctl_blk^.title.value (1,
                  p_report_ctl_blk^.title.size), local_status);
            check_status (local_status);

          IFEND;

        = time_distribution_report =

          find_metric (p_report_ctl_blk^.metric_name, p_report_ctl_blk^.p_metric_ctl_blk);

          IF p_report_ctl_blk^.p_metric_ctl_blk = NIL THEN
            osp$set_status_abnormal (pmc$external_log_management_id, pme$undefined_metric, p_report_ctl_blk^.
                  metric_name, local_status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_report_ctl_blk^.title.value (1,
                  p_report_ctl_blk^.title.size), local_status);
            check_status (local_status);
          ELSE
            p_report_ctl_blk^.p_metric_ctl_blk^.time_stamp_needed := TRUE;
          IFEND;

        CASEND;

        p_report_ctl_blk := p_report_ctl_blk^.report_chain_link;

      WHILEND;


    PROCEND link_blocks;
?? EJECT, TITLE := 'PROCEDURE open_segs' ??

    PROCEDURE open_segs;

      VAR
        file_access_selections: [STATIC, READ] array [1 .. 1] of amt$access_selection := [[amc$return_option,
          amc$return_at_close]];

      VAR
        file_name: ost$name,
        p_metric_ctl_blk: ^metric_ctl_blk;

      { Loop through the metric control block chain. }

      p_metric_ctl_blk := metric_chain_head;
      WHILE p_metric_ctl_blk <> NIL DO

        { Set up the segment that will contain elements of this metric. }

        pmp$get_unique_name (file_name, local_status);
        check_status (local_status);
        amp$open (file_name, amc$segment, ^file_access_selections, p_metric_ctl_blk^.file_identifier,
              local_status);
        check_status (local_status);
        amp$get_segment_pointer (p_metric_ctl_blk^.file_identifier, amc$sequence_pointer, p_metric_ctl_blk^.
              element_sequence, local_status);
        check_status (local_status);

        { Initialize the variables in the metric control block that
        { accumulate information about this metric's values. }

        p_metric_ctl_blk^.element_count := 0;
        p_metric_ctl_blk^.maximum := - maximum_integer;
        p_metric_ctl_blk^.minimum := maximum_integer;

        { Find the next metric in the chain. }

        p_metric_ctl_blk := p_metric_ctl_blk^.metric_chain_link;

      WHILEND;


    PROCEND open_segs;
?? EJECT, TITLE := 'PROCEDURE scan_log' ??

    PROCEDURE scan_log;

      VAR
        first_record: boolean,
        task_found,
        job_found: boolean,
        temp_index: integer,
        p_group_ctl_blk: ^group_ctl_blk,
        p_metric_ctl_blk: ^metric_ctl_blk,
        p_header: ^sft$global_log_statistic_header,
        p_counters: sft$counters,
        p_descript: ^sft$descriptive_data;

      { Read the next statistic from the log. }
      first_record := TRUE;

      REPEAT

        get_stat_record (input_file, input_buffer, input_file_position, p_header, p_counters, p_descript,
              local_status);
        check_status (local_status);

        IF input_file_position <> amc$eoi THEN

          IF first_record THEN
            p_log_blk^.start_time := p_header^.date_time;
            first_record := FALSE;
          IFEND;
          p_log_blk^.end_time := p_header^.date_time;

          { Scan the group chain, identifying each group that this
          { statistic is a part of. }

          p_group_ctl_blk := group_chain_head;
          WHILE p_group_ctl_blk <> NIL DO
            IF in_group (p_group_ctl_blk, p_header, p_counters, p_descript) THEN

              { Check the desc data statistics needed for the group. If }
              { needed then update its desc chain. }

              IF p_group_ctl_blk^.desc_needed THEN
                enter_group_desc_data (p_group_ctl_blk, p_header, p_descript);
              IFEND;

              { Check task_succ_list to determine the task_id should be
              { put in the successor's pred_task-list. }

              IF p_group_ctl_blk^.p_task_succ_group_list <> NIL THEN
                FOR temp_index := LOWERBOUND (p_group_ctl_blk^.p_task_succ_group_list^) TO UPPERBOUND
                      (p_group_ctl_blk^.p_task_succ_group_list^) DO
                  add_task_to_succ (p_header^.task_id, p_group_ctl_blk^.p_task_succ_group_list^ [temp_index]);
                FOREND;
              IFEND;

              { Check job_seq_list to determine the job_seq should be
              { put in the successor's pred_job_list }

              IF p_group_ctl_blk^.p_job_succ_group_list <> NIL THEN
                FOR temp_index := LOWERBOUND (p_group_ctl_blk^.p_job_succ_group_list^) TO UPPERBOUND
                      (p_group_ctl_blk^.p_job_succ_group_list^) DO
                  add_job_to_succ (p_header^.job_name, p_group_ctl_blk^.p_job_succ_group_list^ [temp_index]);
                FOREND;
              IFEND;


              { When metric defined and no predecessor task or job,
              { enter_element }

              IF (p_group_ctl_blk^.p_metric_list <> NIL) AND (p_group_ctl_blk^.pred_task_group_name =
                    blank_name) AND (p_group_ctl_blk^.pred_job_group_name = blank_name) THEN
                enter_element (p_group_ctl_blk^.p_metric_list^, p_header, p_counters, p_descript);
              ELSE

                { Check the task_id in pred_task_list }

                IF (p_group_ctl_blk^.p_metric_list <> NIL) AND (p_group_ctl_blk^.pred_task_group_name <>
                      blank_name) AND (p_group_ctl_blk^.p_pred_task_head <> NIL) THEN
                  search_pred_task (p_header, p_group_ctl_blk^.p_pred_task_head, task_found);
                  IF task_found THEN
                    enter_element (p_group_ctl_blk^.p_metric_list^, p_header, p_counters, p_descript);
                  IFEND;
                IFEND;

                { check the job_seq in pred_job_list }

                IF (p_group_ctl_blk^.p_metric_list <> NIL) AND (p_group_ctl_blk^.pred_job_group_name <>
                      blank_name) AND (p_group_ctl_blk^.p_pred_job_head <> NIL) THEN
                  search_pred_job (p_header, p_group_ctl_blk^.p_pred_job_head, job_found);

                  { If element entered because of pred_task found, do not
                  { enter it again. }

                  IF job_found AND (NOT task_found) THEN
                    enter_element (p_group_ctl_blk^.p_metric_list^, p_header, p_counters, p_descript);
                  IFEND;
                IFEND;
              IFEND;


              IF p_group_ctl_blk^.copy_requested THEN

                put_stat_record (p_group_ctl_blk^.copy_file_identifier, p_header, p_counters, p_descript,
                      local_status);
                check_status (local_status);

              IFEND;

            IFEND;

            { Advance to the next group in the chain. }

            p_group_ctl_blk := p_group_ctl_blk^.group_chain_link;

          WHILEND;

        IFEND;

      UNTIL input_file_position = amc$eoi;

    PROCEND scan_log;
?? EJECT, TITLE := 'PROCEDURE add_task_to_succ' ??

    PROCEDURE add_task_to_succ (task_id: ost$global_task_id;
          p_group_blk: ^group_ctl_blk);

      VAR
        temp_p_task_blk: ^pred_task_blk;

      ALLOCATE temp_p_task_blk;
      temp_p_task_blk^.pred_task_link := p_group_blk^.p_pred_task_head;
      temp_p_task_blk^.global_task_id := task_id;
      p_group_blk^.p_pred_task_head := temp_p_task_blk;

    PROCEND add_task_to_succ;
?? EJECT, TITLE := 'PROCEDURE add_job_to_succ' ??

    PROCEDURE add_job_to_succ (job_seq: jmt$system_supplied_name;
          p_group_blk: ^group_ctl_blk);

      VAR
        temp_p_job_blk: ^pred_job_blk;

      ALLOCATE temp_p_job_blk;
      temp_p_job_blk^.pred_job_link := p_group_blk^.p_pred_job_head;
      temp_p_job_blk^.job_seq_number := job_seq;
      p_group_blk^.p_pred_job_head := temp_p_job_blk;

    PROCEND add_job_to_succ;
?? EJECT, TITLE := 'PROCEDURE search_pred_task' ??

    PROCEDURE search_pred_task (sp_header: ^sft$global_log_statistic_header;
      VAR head: ^pred_task_blk;
      VAR found: boolean);

      VAR
        p_current_blk,
        p_previous_blk: ^pred_task_blk;

      p_current_blk := head;
      p_previous_blk := NIL;
      found := FALSE;

      WHILE (p_current_blk <> NIL) AND (NOT found) DO
        IF p_current_blk^.global_task_id = sp_header^.task_id THEN
          found := TRUE;
        ELSE
          p_previous_blk := p_current_blk;
          p_current_blk := p_current_blk^.pred_task_link;
        IFEND;
      WHILEND;

      IF found AND (p_previous_blk = NIL) THEN
        head := head^.pred_task_link;
      ELSE
        IF found THEN
          p_previous_blk^.pred_task_link := p_current_blk^.pred_task_link;
        IFEND;
      IFEND;

      IF found THEN
        FREE p_current_blk;
      IFEND;

    PROCEND search_pred_task;
?? EJECT, TITLE := 'PROCEDURE search_pred_job' ??

    PROCEDURE search_pred_job (sp_header: ^sft$global_log_statistic_header;
      VAR head: ^pred_job_blk;
      VAR found: boolean);

      VAR
        p_current_blk,
        p_previous_blk: ^pred_job_blk;

      p_current_blk := head;
      p_previous_blk := NIL;
      found := FALSE;

      WHILE (p_current_blk <> NIL) AND (NOT found) DO
        IF p_current_blk^.job_seq_number = sp_header^.job_name THEN
          found := TRUE;
        ELSE
          p_previous_blk := p_current_blk;
          p_current_blk := p_current_blk^.pred_job_link;
        IFEND;
      WHILEND;

      IF found AND (p_previous_blk = NIL) THEN
        head := head^.pred_job_link;
      ELSE
        IF found THEN
          p_previous_blk^.pred_job_link := p_current_blk^.pred_job_link;
        IFEND;
      IFEND;

      IF found THEN
        FREE p_current_blk;
      IFEND;

    PROCEND search_pred_job;
?? EJECT, TITLE := 'PROCEDURE enter_element' ??

    PROCEDURE enter_element (input_metric_list: metric_list;
          p_header: ^sft$global_log_statistic_header;
          p_counters: sft$counters;
          p_descript: ^sft$descriptive_data);

      VAR
        date_time_value: ^date_time_metric,
        metric,
        temp_metric: integer,
        p_metric: ^integer,
        metric_index: integer,
        p_metric_ctl_blk: ^metric_ctl_blk;

      { Loop through the metric list. }

   /metric_loop/

      FOR metric_index := LOWERBOUND (input_metric_list) TO UPPERBOUND (input_metric_list) DO

        { Extract the current metric element. }

        p_metric_ctl_blk := input_metric_list [metric_index];
        CASE p_metric_ctl_blk^.metric_type OF
        = counter_metric =
          IF p_metric_ctl_blk^.incremental THEN
            IF p_metric_ctl_blk^.first_element THEN
              p_metric_ctl_blk^.first_element := FALSE;
              p_metric_ctl_blk^.previous_value := p_counters^ [p_metric_ctl_blk^.counter_number];
              CYCLE /metric_loop/;
            ELSE
              temp_metric := p_counters^ [p_metric_ctl_blk^.counter_number] -
                          p_metric_ctl_blk^.previous_value;
              p_metric_ctl_blk^.element_count := p_metric_ctl_blk^.element_count + 1;
              p_metric_ctl_blk^.previous_value := p_counters^ [p_metric_ctl_blk^.counter_number];
            IFEND;
          ELSE
            temp_metric := p_counters^ [p_metric_ctl_blk^.counter_number];
            p_metric_ctl_blk^.element_count := p_metric_ctl_blk^.element_count + 1;
          IFEND;
        = expression_metric =
          temp_metric := 1;
          p_metric_ctl_blk^.element_count := p_metric_ctl_blk^.element_count + 1;
        CASEND;

        { Apply the scale factor to the extracted metric. }
        { round off }

        IF p_metric_ctl_blk^.scale_factor = 1 THEN
          metric := temp_metric;
        ELSE
          metric := temp_metric DIV p_metric_ctl_blk^.scale_factor;
          IF temp_metric MOD p_metric_ctl_blk^.scale_factor >= p_metric_ctl_blk^.scale_factor DIV 2 THEN
            metric := metric + 1;
          IFEND;
        IFEND;

        { Put the metric into the element sequence segment. }

        IF p_metric_ctl_blk^.time_stamp_needed THEN
          NEXT date_time_value IN p_metric_ctl_blk^.element_sequence.sequence_pointer;
          date_time_value^.counter_value := metric;
          date_time_value^.time_value := time_in_seconds (p_header^.date_time);
          date_time_value^.date_value := date_in_days (p_header^.date_time);
        ELSE
          NEXT p_metric IN p_metric_ctl_blk^.element_sequence.sequence_pointer;
          p_metric^ := metric;
        IFEND;

        { Accumulate metric minimum and maximums. }

        IF metric > p_metric_ctl_blk^.maximum THEN
          p_metric_ctl_blk^.maximum := metric;
        IFEND;
        IF metric < p_metric_ctl_blk^.minimum THEN
          p_metric_ctl_blk^.minimum := metric;
        IFEND;

      FOREND /metric_loop/;

    PROCEND enter_element;
?? EJECT, TITLE := 'PROCEDURE enter_group_desc_data' ??

    PROCEDURE enter_group_desc_data (p_group_ctl_blk: ^group_ctl_blk;
          p_header: ^sft$global_log_statistic_header,
          p_descript: ^sft$descriptive_data);

      VAR
        temp_p_desc_blk1,
        temp_p_desc_blk2: ^desc_blk;

      temp_p_desc_blk1 := p_group_ctl_blk^.p_desc_blk;
      temp_p_desc_blk2 := temp_p_desc_blk1^.desc_chain_link;

      IF p_descript = NIL THEN
        temp_p_desc_blk1^.count := temp_p_desc_blk1^.count + 1;
        EXIT enter_group_desc_data;
      ELSE
        insert_to_desc_chain (p_descript, p_header^.descriptive_data_size, temp_p_desc_blk1,
              temp_p_desc_blk2);
      IFEND;

    PROCEND enter_group_desc_data;
?? EJECT, TITLE := 'PROCEDURE generate_reports' ??

    PROCEDURE generate_reports;

      VAR
        p_report_ctl_blk: ^report_ctl_blk;

      print_log_report_title;
      display_log_info;

      p_report_ctl_blk := report_chain_head;
      WHILE p_report_ctl_blk <> NIL DO
        CASE p_report_ctl_blk^.report_type OF
        = summary_report =
          display_summary (p_report_ctl_blk^);

        = dump_report =
          dump_group (p_report_ctl_blk^);

        = distribution_report =
          display_distribution (p_report_ctl_blk^);

        = time_distribution_report =
          display_time_distribution (p_report_ctl_blk^);

        = datades_report =
          display_descriptive_data (p_report_ctl_blk^);

        = gen_group_file =
          generate_file (p_report_ctl_blk^);

        CASEND;
        p_report_ctl_blk := p_report_ctl_blk^.report_chain_link;
      WHILEND;

    PROCEND generate_reports;
?? EJECT, TITLE := 'PROCEDURE display_summary' ??

    PROCEDURE display_summary (ctl_blk: report_ctl_blk);

      VAR
        p_metric: ^integer,
        sum: integer,
        square_sum: integer,
        p_metric_ctl_blk: ^metric_ctl_blk,
        line_image: string (136),
        mean: integer,
        metric_array: ^array [1 .. * ] of date_time_metric,
        metric_value: date_time_metric,
        local_status: ost$status,
        variance: integer,
        element_index: integer;

      { Generate the output report. }

      print_title (ctl_blk, 'Summary Report');

      sum := 0;
      square_sum := 0;

      p_metric_ctl_blk := ctl_blk.p_metric_ctl_blk;
      IF p_metric_ctl_blk^.element_count = 0 THEN
        print (' There are no elements for this metric.');
      ELSE
        RESET p_metric_ctl_blk^.element_sequence.sequence_pointer;

        IF p_metric_ctl_blk^.time_stamp_needed THEN
          NEXT metric_array: [1 .. p_metric_ctl_blk^.element_count] IN p_metric_ctl_blk^.element_sequence.
                sequence_pointer;

          FOR element_index := 1 TO p_metric_ctl_blk^.element_count DO
            metric_value := metric_array^ [element_index];
            sum := sum + metric_value.counter_value;
            square_sum := square_sum + (metric_value.counter_value * metric_value.counter_value);
          FOREND;
        ELSE
          FOR element_index := 1 TO p_metric_ctl_blk^.element_count DO
            NEXT p_metric IN p_metric_ctl_blk^.element_sequence.sequence_pointer;
            sum := sum + p_metric^;
            square_sum := square_sum + p_metric^ * p_metric^;
          FOREND;
        IFEND;

        IF ctl_blk.num = TRUE THEN
           line_image := '                       N = ';
           clp$convert_integer_to_rjstring (p_metric_ctl_blk^.element_count, 10, FALSE, ' ',
              line_image (27, 10), local_status);
           check_status (local_status);
           line_image (38, 8) := 'elements';
           print (line_image);
        IFEND;

        IF ctl_blk.mean = TRUE THEN
           mean := sum DIV p_metric_ctl_blk^.element_count;
           line_image := '0                   Mean = ';
           clp$convert_integer_to_rjstring (mean, 10, FALSE, ' ', line_image (27, 10), local_status);
           check_status (local_status);
           line_image (38, 32) := p_metric_ctl_blk^.unit;
           print (line_image);
        IFEND;

        { Compute and display the standard deviation and variance. }

        IF ctl_blk.variance = TRUE THEN
           IF p_metric_ctl_blk^.element_count > 1 THEN
              variance := (square_sum - p_metric_ctl_blk^.element_count * mean * mean) DIV (p_metric_ctl_blk^.
                   element_count - 1);
              line_image := '0               Variance = ';
              clp$convert_integer_to_rjstring (variance, 10, FALSE, ' ', line_image (27, 20), local_status);
              check_status (local_status);
              print (line_image);
           IFEND;
        IFEND;

        IF ctl_blk.min = TRUE THEN
           line_image := '0                Minimum = ';
           clp$convert_integer_to_rjstring (p_metric_ctl_blk^.minimum, 10, FALSE, ' ', line_image (27, 10),
                 local_status);
           check_status (local_status);
           line_image (38, 32) := p_metric_ctl_blk^.unit;
           print (line_image);
        IFEND;

        IF ctl_blk.max = TRUE THEN
           line_image := '0                Maximum = ';
           clp$convert_integer_to_rjstring (p_metric_ctl_blk^.maximum, 10, FALSE, ' ', line_image (27, 10),
                 local_status);
           check_status (local_status);
           line_image (38, 32) := p_metric_ctl_blk^.unit;
           print (line_image);
        IFEND;

        { Display the sum of all metric elements. }

        IF ctl_blk.sum = TRUE THEN
           line_image := '0                    Sum = ';
           clp$convert_integer_to_rjstring (sum, 10, FALSE, ' ', line_image (27, 10), local_status);
           check_status (local_status);
           line_image (38, 32) := p_metric_ctl_blk^.unit;
           print (line_image);
        IFEND;

      IFEND;

    PROCEND display_summary;

?? EJECT, TITLE := 'PROCEDURE display_descriptive_data' ??

    PROCEDURE display_descriptive_data (ctl_blk: report_ctl_blk);

      VAR
        p_temp_desc_blk1,
        p_temp_desc_blk2: ^desc_blk,
        largest_count,
        scale,
        position,
        temp_index,
        print_desc_index,
        print_desc_size,
        line_count,
        page_count: integer,
        new_page: boolean,
        count_base_line,
        divider_line,
        divider_line1,
        divider_line2,
        count_data_line: string (126),
        local_status: ost$status,
        temp_str: ost$string;

      print_title (ctl_blk, 'Descriptive Data Report');

      p_temp_desc_blk1 := ctl_blk.p_group_ctl_blk^.p_desc_blk;
      p_temp_desc_blk2 := p_temp_desc_blk1^.desc_chain_link;

      count_data_line := '  Total Number of Blank Descriptive Data Count  =';
      clp$convert_integer_to_rjstring (p_temp_desc_blk1^.count, 10, FALSE, ' ', count_data_line (50, 9),
            local_status);

{  Find the largest count in the chain  }
      largest_count := 0;
      WHILE p_temp_desc_blk2 <> NIL DO
        IF p_temp_desc_blk2^.count > largest_count THEN
          largest_count := p_temp_desc_blk2^.count;
        IFEND;
        p_temp_desc_blk2 := p_temp_desc_blk2^.desc_chain_link;
      WHILEND;

      IF largest_count = 0 THEN
        IF p_temp_desc_blk1^.count = 0 THEN
          print ('0 ***  There is no elements for this group');
        ELSE
          print (count_data_line);
          print ('0 ***  There is no other descriptive data');
        IFEND;
        RETURN;
      ELSE
        print (count_data_line);
      IFEND;
      p_temp_desc_blk1 := p_temp_desc_blk1^.desc_chain_link;

{  Calculate the scale by dividing 5  }
      IF largest_count MOD 5 <> 0 THEN
        largest_count := largest_count + (largest_count MOD 5);
      IFEND;
      IF largest_count < 5 THEN
        largest_count := 5;
      IFEND;
      scale := largest_count DIV 5;

      count_base_line := '                    DESCRIPTIVE DATA';
      count_base_line (63, 5) := 'COUNT';
      FOR temp_index := 1 TO 6 DO
        clp$convert_integer_to_string ((temp_index - 1) * scale, 10, FALSE, temp_str, local_status);
        count_base_line ((temp_index - 1) * 10 + 72, temp_str.size) := temp_str.value (1, temp_str.size);
      FOREND;

      divider_line := '  ';
      FOR temp_index := 2 TO 123 DO
        IF (temp_index MOD 10 = 2) AND (temp_index > 70) THEN
          divider_line (temp_index) := '+';
        ELSE
          divider_line (temp_index) := '-';
        IFEND;
      FOREND;

      page_count := 1;
      line_count := 0;
      print (count_base_line);
      print (divider_line);
      new_page := FALSE;
      divider_line1 := '  ';
      divider_line1 (2) := '|';
      divider_line1 (59) := '|';
      divider_line1 (71) := '|';
      divider_line1 (123) := '|';
      divider_line2 := ' ';
      FOR temp_index := 2 TO 123 DO
        divider_line2 (temp_index) := '-';
      FOREND;

      WHILE p_temp_desc_blk1 <> NIL DO
        IF new_page THEN
          print_title (ctl_blk, 'Descriptive Data Report ( Cont. )');
        IFEND;

        IF new_page THEN
          print (count_base_line);
          print (divider_line);
          new_page := FALSE;
        IFEND;

        count_data_line := '  ';
        IF p_temp_desc_blk1^.count <> 0 THEN
          print_desc_size := p_temp_desc_blk1^.desc_data_size;
          IF print_desc_size > 0 THEN
            IF print_desc_size > 56 THEN
              print_desc_size := 56;
            IFEND;
            count_data_line (2) := '|';
            count_data_line (3, print_desc_size) := p_temp_desc_blk1^.desc_data (1, print_desc_size);
            count_data_line (59) := '|';
            clp$convert_integer_to_rjstring (p_temp_desc_blk1^.count, 10, FALSE, ' ', count_data_line (60, 9),
                  local_status);
          ELSE
            count_data_line := ' ( NO DESCRIPTIVE DATA )';
          IFEND;

          { Calculate the graph position }

          count_data_line (71) := '|';
          count_data_line (123) := '|';
          position := (p_temp_desc_blk1^.count * 10) DIV scale;
          IF ((p_temp_desc_blk1^.count * 10) MOD scale) > (scale DIV 2) THEN
            position := position + 1;
          IFEND;
          FOR temp_index := 0 TO position DO
            count_data_line (temp_index + 72) := '*';
          FOREND;
          print (count_data_line);
          line_count := line_count + 1;

          IF p_temp_desc_blk1^.desc_data_size > 56 THEN
            count_data_line := ' |';
            count_data_line (59) := '|';
            count_data_line (71) := '|';
            count_data_line (123) := '|';
            print_desc_index := 57;
            REPEAT
              print_desc_size := p_temp_desc_blk1^.desc_data_size - print_desc_index + 1;
              IF print_desc_size > 56 THEN
                print_desc_size := 56;
              IFEND;
              count_data_line (3, 56) := p_temp_desc_blk1^.desc_data (print_desc_index, print_desc_size);
              print (count_data_line);
              line_count := line_count + 1;
              print_desc_index := print_desc_index + print_desc_size;
            UNTIL print_desc_index > p_temp_desc_blk1^.desc_data_size;
          IFEND;

          print (divider_line1);
          line_count := line_count + 1;
          IF line_count > 40 THEN
            print (divider_line2);
            line_count := 0;
            page_count := page_count + 1;
            new_page := TRUE;
          IFEND;
        IFEND;

        p_temp_desc_blk1 := p_temp_desc_blk1^.desc_chain_link;

      WHILEND;
      print (divider_line2);

    PROCEND display_descriptive_data;

?? EJECT, TITLE := 'PROCEDURE dump_group' ??

    PROCEDURE dump_group (ctl_blk: report_ctl_blk);

      VAR
         local_status: ost$status;


      amp$rewind (ctl_blk.p_group_ctl_blk^.copy_file_identifier, osc$wait, local_status);
      check_status (local_status);

      { Generate the report. }

      print_title (ctl_blk, 'Group Dump');


      REPEAT
        get_stat_record (ctl_blk.p_group_ctl_blk^.copy_file_identifier, input_buffer, input_file_position,
              p_stat_header, p_stat_counters, p_stat_descript, local_status);
        check_status (local_status);

        IF input_file_position <> amc$eoi THEN
          dump_record (p_stat_header, p_stat_counters, p_stat_descript, ^ctl_blk, local_status);
          check_status (local_status);
        IFEND;

      UNTIL input_file_position = amc$eoi;

    PROCEND dump_group;
?? EJECT, TITLE := 'PROCEDURE generate_file' ??

    PROCEDURE generate_file (ctl_blk: report_ctl_blk);

      VAR
        gf_access_selections: [STATIC, READ] array [1 .. 4] of amt$access_selection := [[amc$open_position,
          amc$open_no_positioning], [amc$file_contents, amc$legible], [amc$page_format, amc$continuous_form],
          [amc$page_width, 80]],
        group_file_attributes: [STATIC, READ] array [1 .. 3] of amt$file_item := [[amc$file_contents,
          amc$legible], [amc$page_format, amc$continuous_form], [amc$page_width, 80]],
        group_file_identifier: amt$file_identifier,
        cycle_selector: pft$cycle_selector;

      amp$rewind (ctl_blk.p_group_ctl_blk^.copy_file_identifier, osc$wait, local_status);
      check_status (local_status);

{  Create a new file or new cycle  }

      IF ctl_blk.permanent THEN
        group_file_path [3] := ctl_blk.file_name;
        cycle_selector.cycle_option := pfc$highest_cycle;
        pfp$define (ctl_blk.file_name, group_file_path, cycle_selector, blank_passw, 999, pfc$log,
              local_status);
        check_status (local_status);
      IFEND;

      IF ctl_blk.file_name <> default_output THEN
        amp$file (ctl_blk.file_name, group_file_attributes, local_status);
        check_status (local_status);
        amp$open (ctl_blk.file_name, amc$record, ^gf_access_selections, group_file_identifier, local_status);
        check_status (local_status);
      ELSE
        group_file_identifier := output_file;
      IFEND;

      REPEAT
        get_stat_record (ctl_blk.p_group_ctl_blk^.copy_file_identifier, input_buffer, input_file_position,
              p_stat_header, p_stat_counters, p_stat_descript, local_status);
        check_status (local_status);

        IF input_file_position <> amc$eoi THEN
          convert_log_to_gf_format (p_stat_header, p_stat_counters, p_stat_descript, group_file_identifier,
                local_status);
          check_status (local_status);
        IFEND;
      UNTIL input_file_position = amc$eoi;

      IF ctl_blk.file_name <> default_output THEN
        amp$close (group_file_identifier, local_status);
        check_status (local_status);
      IFEND;

    PROCEND generate_file;

?? EJECT, TITLE := 'PROCEDURE display_distribution' ??

    PROCEDURE display_distribution (VAR ctl_blk: report_ctl_blk);

      VAR

{  cnt_time_frame is the graph to be printed  }

        cnt_time_frame: array [1 .. 31] of string (116),
        time_base_line: string (126),
        high_line,
        low_line,
        msg_line: string (126),
        high_frame_line,
        low_frame_line: string (116),

{  distribution_array[ 1 ][ 1 .. 101 ] - 101 points are selected for }
{    CP response time according to users' selection or by default. }
{    defaults are maximum and minimum of the metric.               }
{  distribution_array[ 2 ][ 1 .. 101 ] - 101 counts for each time    }
{    points.                                                       }
{  distribution_array[ 3 ][ 1 .. 101 ] - 101 points for count axis.  }
{  distribution_array[ 4 ][ 1 .. 101 ] - the count_axis for 101      }
{    counts                                                        }

        distribution_array: array [1 .. 4] of array [1 .. 101] of integer,
        frame_scale,
        frame_factor: integer,
        p_metric: ^integer,
        p_metric_ctl_blk: ^metric_ctl_blk,
        out_low_x,
        out_high_x,
        in_frame_cnt,
        out_low_y,
        out_high_y: integer,
        frame_index,
        temp_index: integer,
        temp_str: ost$string,
        local_status: ost$status,
        x_int,
        half_x_int1,
        half_x_int2,
        y_int: integer,
        count_limit_exceed,
        y_low_default,
        y_high_default: boolean,
        x_high_low_equal,
        y_high_low_equal: boolean;

?? EJECT, TITLE := 'PROCEDURE set_up_x_ints ( sub proc )' ??

      PROCEDURE set_up_x_ints;

{  This procedure set up the time interval according to the high-low  }
{  time limits and count the elements in each time interval.  If high }
{  limit - low limit MOD 10 <> 0, then high limit will be patched to  }
{  make it = 0.  There are always 10 time intervals.  }
{ }

        VAR
          element_index,
          patch_to_high: integer;

        FOR temp_index := 1 TO 4 DO
          FOR frame_index := 1 TO 101 DO
            distribution_array [temp_index] [frame_index] := 0;
          FOREND;
        FOREND;

        in_frame_cnt := p_metric_ctl_blk^.element_count;
        out_low_x := 0;
        out_high_x := 0;

{  Check the time high low limits.  If not given, use defaults  }

        IF ctl_blk.x_low_limit < 0 THEN
          ctl_blk.x_low_limit := p_metric_ctl_blk^.minimum;
        IFEND;
        IF ctl_blk.x_high_limit < 0 THEN
          ctl_blk.x_high_limit := p_metric_ctl_blk^.maximum;
        IFEND;

{  Check high - low > 0.  If not, error  }

        IF ctl_blk.x_high_limit - ctl_blk.x_low_limit < 0 THEN
          osp$set_status_abnormal (pmc$external_log_management_id, pme$bad_high_low_limit,
            'BAD TIME HIGH LOW LIMIT', local_status);
          check_status (local_status);
        IFEND;

        IF ctl_blk.x_high_limit - ctl_blk.x_low_limit = 0 THEN
          ctl_blk.x_high_limit := ctl_blk.x_low_limit + 10;
          ctl_blk.x_interval := large;
          x_high_low_equal := TRUE;
        IFEND;

        IF ctl_blk.x_interval = self_adjust THEN
          IF ctl_blk.x_high_limit - ctl_blk.x_low_limit < 11 THEN
            frame_scale := 10;
          ELSE
            IF ctl_blk.x_high_limit - ctl_blk.x_low_limit < 501 THEN
              frame_scale := 20;
            ELSE
              frame_scale := 100;
            IFEND;
          IFEND;
        ELSE
          CASE ctl_blk.x_interval OF
          = large =
            frame_scale := 10;
          = medium =
            frame_scale := 20;
          = small =
            frame_scale := 100;
          CASEND;
        IFEND;

        CASE frame_scale OF
        = 10 =
          frame_factor := 10;
        = 20 =
          frame_factor := 5;
        = 100 =
          frame_factor := 1;
        CASEND;

        patch_to_high := (ctl_blk.x_high_limit - ctl_blk.x_low_limit) MOD frame_scale;
        IF patch_to_high <> 0 THEN
          patch_to_high := frame_scale - patch_to_high;
        IFEND;

        x_int := (ctl_blk.x_high_limit + patch_to_high - ctl_blk.x_low_limit) DIV frame_scale;
        half_x_int1 := x_int DIV 2;
        IF x_int MOD 2 = 0 THEN
          half_x_int2 := half_x_int1 - 1;
          IF half_x_int2 < 0 THEN
            half_x_int2 := 0;
          IFEND;
        ELSE
          half_x_int2 := half_x_int1;
        IFEND;

        FOR temp_index := 1 TO frame_scale + 1 DO
          distribution_array [1] [temp_index] := ctl_blk.x_low_limit + (temp_index - 1) * x_int;
        FOREND;

        RESET p_metric_ctl_blk^.element_sequence.sequence_pointer;
        FOR element_index := 1 TO p_metric_ctl_blk^.element_count DO
          NEXT p_metric IN p_metric_ctl_blk^.element_sequence.sequence_pointer;
          IF p_metric^ < ctl_blk.x_low_limit THEN
            out_low_x := out_low_x + 1;
          ELSE
            IF p_metric^ > ctl_blk.x_high_limit + patch_to_high THEN
              out_high_x := out_high_x + 1;
            ELSE

            /find_its_int/
              FOR temp_index := 1 TO frame_scale + 1 DO
                IF p_metric^ <= distribution_array [1] [temp_index] + half_x_int2 THEN
                  distribution_array [2] [temp_index] := distribution_array [2] [temp_index] + 1;
                  EXIT /find_its_int/;
                IFEND;
              FOREND /find_its_int/;
            IFEND;
          IFEND;
        FOREND;
        in_frame_cnt := in_frame_cnt - out_high_x - out_low_x;

      PROCEND set_up_x_ints;

?? EJECT, TITLE := 'PROCEDURE set_up_y_ints ( sub proc )' ??

      PROCEDURE set_up_y_ints;

        VAR
          max_cnt,
          min_cnt: integer,
          patch_to_high,
          y_temp: integer;

        IF ctl_blk.cnt_high_limit < 0 THEN
          y_high_default := TRUE;
          max_cnt := distribution_array [2] [1];
          FOR temp_index := 2 TO frame_scale + 1 DO
            IF max_cnt < distribution_array [2] [temp_index] THEN
              max_cnt := distribution_array [2] [temp_index];
            IFEND;
          FOREND;
          ctl_blk.cnt_high_limit := max_cnt;
        IFEND;
        IF ctl_blk.cnt_low_limit < 0 THEN
          y_low_default := TRUE;
          min_cnt := distribution_array [2] [1];
          FOR temp_index := 2 TO frame_scale + 1 DO
            IF min_cnt > distribution_array [2] [temp_index] THEN
              min_cnt := distribution_array [2] [temp_index];
            IFEND;
          FOREND;
          ctl_blk.cnt_low_limit := min_cnt;
        IFEND;

        IF ctl_blk.cnt_high_limit - ctl_blk.cnt_low_limit < 0 THEN
          osp$set_status_abnormal (pmc$external_log_management_id, pme$bad_high_low_limit,
            'BAD COUNT HIGH LOW LIMITS', local_status);
          check_status (local_status);
        IFEND;

        IF ctl_blk.cnt_high_limit - ctl_blk.cnt_low_limit = 0 THEN
          ctl_blk.cnt_high_limit := ctl_blk.cnt_low_limit + 10;
          y_high_low_equal := TRUE;
        IFEND;

        patch_to_high := (ctl_blk.cnt_high_limit - ctl_blk.cnt_low_limit) MOD 10;
        IF patch_to_high <> 0 THEN
          patch_to_high := 10 - patch_to_high;
        IFEND;
        y_int := (ctl_blk.cnt_high_limit + patch_to_high - ctl_blk.cnt_low_limit) DIV 10;
        FOR temp_index := 1 TO 11 DO
          distribution_array [3] [temp_index] := ctl_blk.cnt_low_limit + (temp_index - 1) * y_int;
        FOREND;

        FOR temp_index := 1 TO frame_scale + 1 DO
          IF distribution_array [2] [temp_index] >= ctl_blk.cnt_low_limit - y_int DIV 2 THEN
            y_temp := ((distribution_array [2] [temp_index] - ctl_blk.cnt_low_limit) * 30) DIV (y_int * 10) +
                  1;
            IF ((distribution_array [2] [temp_index] - ctl_blk.cnt_low_limit) * 30) MOD (y_int * 10) >= y_int
                  * 5 THEN
              y_temp := y_temp + 1;
            IFEND;
          ELSE
            y_temp := - 1;
          IFEND;
          distribution_array [4] [temp_index] := y_temp;
        FOREND;

      PROCEND set_up_y_ints;

?? EJECT, TITLE := 'PROCEDURE reset_x_bounds' ??

      PROCEDURE reset_x_bounds;

        VAR
          first_max,
          second_max,
          first_index,
          second_index: integer,
          temp_max,
          temp,
          old_x_span,
          adjustment: integer;

        old_x_span := distribution_array [1] [frame_scale + 1] - distribution_array [1] [1];
        first_max := distribution_array [2] [1];
        first_index := 1;
        FOR temp_index := 2 TO frame_scale + 1 DO
          IF first_max < distribution_array [2] [temp_index] THEN
            first_max := distribution_array [2] [temp_index];
            first_index := temp_index;
          IFEND;
        FOREND;

        IF ctl_blk.display_option = second_max_centered THEN
          temp_index := first_index - 2;
          second_max := 0;
          second_index := 0;
          IF temp_index >= 1 THEN
            IF distribution_array [2] [1] >= distribution_array [2] [2] THEN
              second_max := distribution_array [2] [1];
              second_index := 1;
            IFEND;
            WHILE temp_index > 1 DO
              IF (distribution_array [2] [temp_index] >= distribution_array [2] [temp_index - 1]) AND
                    (distribution_array [2] [temp_index] >= distribution_array [2] [temp_index + 1]) AND
                    (distribution_array [2] [temp_index] > second_max) THEN
                second_max := distribution_array [2] [temp_index];
                second_index := temp_index;
              IFEND;
              temp_index := temp_index - 1;
            WHILEND;
          IFEND;
          temp_index := first_index + 2;
          IF temp_index <= frame_scale + 1 THEN
            IF (distribution_array [2] [frame_scale + 1] >= distribution_array [2] [frame_scale]) AND
                  (distribution_array [2] [frame_scale + 1] > second_max) THEN
              second_max := distribution_array [2] [frame_scale + 1];
              second_index := frame_scale + 1;
            IFEND;
            WHILE temp_index < frame_scale + 1 DO
              IF (distribution_array [2] [temp_index] >= distribution_array [2] [temp_index - 1]) AND
                    (distribution_array [2] [temp_index] >= distribution_array [2] [temp_index + 1]) AND
                    (distribution_array [2] [temp_index] > second_max) THEN
                second_max := distribution_array [2] [temp_index];
                second_index := temp_index;
              IFEND;
              temp_index := temp_index + 1;
            WHILEND;
          IFEND;
        IFEND;

        IF ctl_blk.display_option = first_max_centered THEN
          adjustment := (old_x_span * 10) DIV 100;
          temp := first_index;
        ELSE
          IF second_index = 0 THEN
            print ('0   No second maximum can be found, first maximum centered');
            adjustment := (old_x_span * 10) DIV 100;
            temp := first_index;
          ELSE
            adjustment := (old_x_span * 20) DIV 100;
            temp := second_index;
          IFEND;
        IFEND;

        ctl_blk.x_high_limit := distribution_array [1] [temp] + adjustment;
        ctl_blk.x_low_limit := distribution_array [1] [temp] - adjustment;
        IF ctl_blk.x_high_limit > p_metric_ctl_blk^.maximum THEN
          ctl_blk.x_high_limit := p_metric_ctl_blk^.maximum;
        IFEND;
        IF ctl_blk.x_low_limit < p_metric_ctl_blk^.minimum THEN
          ctl_blk.x_low_limit := p_metric_ctl_blk^.minimum;
        IFEND;
        IF y_low_default THEN
          ctl_blk.cnt_low_limit := - 1;
        IFEND;
        IF y_high_default THEN
          ctl_blk.cnt_high_limit := - 1;
        IFEND;

      PROCEND reset_x_bounds;

?? EJECT, TITLE := 'PROCEDURE display_distribution ( Main )' ??

      print_title (ctl_blk, 'Distribution Report');

      p_metric_ctl_blk := ctl_blk.p_metric_ctl_blk;
      IF p_metric_ctl_blk^.element_count = 0 THEN
        print (' There are no elements for this metric.');
        RETURN;
      IFEND;

      y_low_default := FALSE;
      y_high_default := FALSE;
      x_high_low_equal := FALSE;
      y_high_low_equal := FALSE;

      FOR temp_index := 1 TO 31 DO
        cnt_time_frame [temp_index] := '  ';
      FOREND;

      set_up_x_ints;
      set_up_y_ints;

{  Check the display option  }

      IF ctl_blk.display_option <> max_min_bound THEN
        reset_x_bounds;
        set_up_x_ints;
        set_up_y_ints;
      IFEND;

      high_line := '  ';
      low_line := '  ';
      high_line (35, * ) := 'Number of Elements above X-axis High Limit  =';
      low_line (35, * ) := 'Number of Elements below X-axis Low  Limit  =';
      clp$convert_integer_to_rjstring (out_high_x, 10, FALSE, ' ', high_line (82, 7), local_status);
      check_status (local_status);
      clp$convert_integer_to_rjstring (out_low_x, 10, FALSE, ' ', low_line (82, 7), local_status);
      print (high_line);
      print (low_line);

      count_limit_exceed := FALSE;
      high_frame_line := '0 ';
      low_frame_line := '0 ';
      out_low_y := 0;
      out_high_y := 0;
      FOR temp_index := 1 TO frame_scale + 1 DO
        IF distribution_array [4] [temp_index] > 31 THEN
          out_high_y := out_high_y + distribution_array [2] [temp_index];
          high_frame_line ((temp_index - 1) * frame_factor + 16) := 'H';
          count_limit_exceed := TRUE;
        IFEND;
        IF distribution_array [4] [temp_index] < 1 THEN
          out_low_y := out_low_y + distribution_array [2] [temp_index];
          low_frame_line ((temp_index - 1) * frame_factor + 16) := 'L';
          count_limit_exceed := TRUE;
        IFEND;
      FOREND;
      in_frame_cnt := in_frame_cnt - out_low_y - out_high_y;

      high_line := '  ';
      low_line := '  ';
      msg_line := '  ';
      high_line (35, * ) := 'Number of Elements above Y-axis High Limit  =';
      low_line (35, * ) := 'Number of Elements below Y-axis Low  Limit  =';
      msg_line (35, * ) := 'Number of Elements within the Frame Limits  =';
      clp$convert_integer_to_rjstring (out_high_y, 10, FALSE, ' ', high_line (82, 7), local_status);
      check_status (local_status);
      IF x_high_low_equal OR y_high_low_equal THEN
        high_line (92, 8) := 'WARNING:';
      IFEND;
      clp$convert_integer_to_rjstring (out_low_y, 10, FALSE, ' ', low_line (82, 7), local_status);
      check_status (local_status);
      IF x_high_low_equal THEN
        low_line (92, * ) := 'X high and low limits are equal';
      IFEND;
      clp$convert_integer_to_rjstring (in_frame_cnt, 10, FALSE, ' ', msg_line (82, 7), local_status);
      check_status (local_status);
      IF y_high_low_equal THEN
        msg_line (92, * ) := 'Y high and low limits are equal';
      IFEND;
      print (high_line);
      print (low_line);
      print (msg_line);

      FOR temp_index := 1 TO 10 DO
        cnt_time_frame [1] (temp_index * 10 + 7, 10) := '---------+';
        cnt_time_frame [31] (temp_index * 10 + 7, 10) := '---------+';
      FOREND;

      FOR frame_index := 1 TO 31 DO

        IF frame_index MOD 3 = 1 THEN
          clp$convert_integer_to_rjstring (distribution_array [3] [frame_index DIV 3 + 1], 10, FALSE, ' ',
                cnt_time_frame [frame_index] (6, 10), local_status);
          check_status (local_status);
          cnt_time_frame [frame_index] (16) := '+';
          cnt_time_frame [frame_index] (116) := '+';
        ELSE
          cnt_time_frame [frame_index] (16) := '|';
          cnt_time_frame [frame_index] (116) := '|';
        IFEND;

        FOR temp_index := 1 TO frame_scale + 1 DO
          IF (frame_index >= 2) AND (distribution_array [4] [temp_index] >= frame_index) THEN
            cnt_time_frame [frame_index] ((temp_index - 1) * frame_factor + 16) := '*';
          IFEND;
        FOREND;

      FOREND;
      cnt_time_frame [31] (1) := '0';


      time_base_line := '  ';
      FOR temp_index := 1 TO 11 DO
        clp$convert_integer_to_string (distribution_array [1] [(temp_index - 1) * (10 DIV frame_factor) + 1],
              10, FALSE, temp_str, local_status);
        time_base_line ((temp_index - 1) * 10 + 16, temp_str.size) := temp_str.value (1, temp_str.size);
        check_status (local_status);
      FOREND;

      print (high_frame_line);
      frame_index := 31;
      REPEAT
        print (cnt_time_frame [frame_index]);
        frame_index := frame_index - 1;
      UNTIL frame_index = 0;
      print (time_base_line);
      print (low_frame_line);

      msg_line := '  ';
      msg_line (55, max_name_size) := p_metric_ctl_blk^.unit (1, max_name_size);
      print (msg_line);

      IF count_limit_exceed THEN
        print ('0               NOTES:');
        print ('                    H - The value on y-axis correspond to x-interval');
        print ('                        is higher than the y-axis upper bound');
        print ('                    L - The value on y-axis correspond to x-interval');
        print ('                        is lower than the y-axis lower bound');
      IFEND;

    PROCEND display_distribution;
?? EJECT, TITLE := 'PROCEDURE display_time_distribution' ??

    PROCEDURE display_time_distribution (ctl_blk: report_ctl_blk);

      CONST
        number_of_seconds_in_day = 86400;

      VAR
        distribution_array: array [1 .. 6] of array [1 .. 101] of integer,

{ distribution_array[1] [1 .. 101] - 101 points are selected on X-axis   }
{     for time intervals; this value is either given by the user or by   }
{     default.  The default is the beginning and ending date and time    }
{     of the log being processed.                                        }
{ distribution_array[2] [1 .. 101] - 101 values giving the lowest value  }
{     seen of the metric in the corresponding time interval.             }
{ distribution_array[3] [1 .. 101] - 101 values giving the highest value }
{     seen of the metric in the corresponding time interval.             }
{ distribution_array[4] [1 .. 101] - 101 points are selected on Y-axis   }
{     for element intervals; the interval is determined by the metric_   }
{     limits given on the display_time_distribution subcommand. Only     }
{     11 of these entries are used.                                      }
{ distribution_array[5] [1 .. 101] - 101 values giving the lowest value  }
{     to be used on the Y-axis for the corresponding time interval.      }
{ distribution_array[6] [1 .. 101] - 101 values giving the highest value }
{     to be used on the Y-axis for the corresponding time interval.      }

        graph: array [1 .. 31] of string (116);

?? EJECT, NEWTITLE := '  PROCEDURE initialize_arrays' ??

      PROCEDURE initialize_arrays;

        VAR
          i: 1 .. 6,
          j: 1 .. 101;

{ initialize distribution array }

        FOR i := 1 TO 6 DO
          IF (i = 2) THEN
            FOR j := 1 TO 101 DO
              distribution_array [i] [j] := maximum_integer;
            FOREND;
          ELSE
            FOR j := 1 TO 101 DO
              distribution_array [i] [j] := 0;
            FOREND;
          IFEND;
        FOREND;

{ initialize graph array }

        FOR j := 1 TO 31 DO
          graph [j] := ' ';
        FOREND;

      PROCEND initialize_arrays;

?? OLDTITLE ??
?? EJECT, NEWTITLE := '  PROCEDURE find_limits_for_date_and_time' ??

      PROCEDURE find_limits_for_date_and_time (VAR starting_date: integer;
        VAR ending_date: integer;
        VAR starting_time: integer;
        VAR ending_time: integer);


        VAR
          default_ending_date: integer,
          default_ending_time: integer,
          default_starting_date: integer,
          default_starting_time: integer,
          p_log_ctl_blk: ^input_log_blk,
          temp_date: integer,
          temp_time: integer;


        default_starting_date := maximum_integer;
        default_starting_time := maximum_integer;
        default_ending_date := 0;
        default_ending_time := 0;


        IF p_metric_ctl_blk^.p_group_ctl_blk^.date_specified THEN
          starting_date := date_in_days (p_metric_ctl_blk^.p_group_ctl_blk^.start_dt);
          ending_date := date_in_days (p_metric_ctl_blk^.p_group_ctl_blk^.start_dt);
        ELSE
          p_log_ctl_blk := log_chain_head;

          WHILE p_log_ctl_blk <> NIL DO
            temp_date := date_in_days (p_log_ctl_blk^.start_time);
            IF temp_date < default_starting_date THEN
              default_starting_date := temp_date;
            IFEND;
            temp_date := date_in_days (p_log_ctl_blk^.end_time);
            IF temp_date > default_ending_date THEN
              default_ending_date := temp_date;
            IFEND;
            p_log_ctl_blk := p_log_ctl_blk^.log_chain_link;
          WHILEND;

          starting_date := default_starting_date;
          ending_date := default_ending_date;
        IFEND;


        IF p_metric_ctl_blk^.p_group_ctl_blk^.time_specified THEN
          starting_time := time_in_seconds (p_metric_ctl_blk^.p_group_ctl_blk^.start_dt);
          ending_time := time_in_seconds (p_metric_ctl_blk^.p_group_ctl_blk^.end_dt);
        ELSE
          p_log_ctl_blk := log_chain_head;

          WHILE p_log_ctl_blk <> NIL DO
            temp_time := time_in_seconds (p_log_ctl_blk^.start_time);
            IF temp_time < default_starting_time THEN
              default_starting_time := temp_time;
            IFEND;
            temp_time := time_in_seconds (p_log_ctl_blk^.end_time);
            IF temp_time > default_ending_time THEN
              default_ending_time := temp_time;
            IFEND;
            p_log_ctl_blk := p_log_ctl_blk^.log_chain_link;
          WHILEND;

          starting_time := default_starting_time;
          ending_time := default_ending_time;
        IFEND;

      PROCEND find_limits_for_date_and_time;

?? OLDTITLE ??
?? EJECT, NEWTITLE := '  PROCEDURE set_up_x_axis' ??

      PROCEDURE set_up_x_axis (VAR x_high_low_equal: boolean;
        VAR time_interval: integer;
        VAR frame_scale: 1 .. 100;
        VAR starting_time: integer;
        VAR ending_time: integer);

        VAR
          ending_date: integer,
          index: 1 .. 101,
          patch_to_high: 0 .. 100,
          starting_date: integer;


        starting_date := 0;
        ending_date := 0;
        starting_time := 0;
        ending_time := 0;

        find_limits_for_date_and_time (starting_date, ending_date, starting_time, ending_time);

        IF (starting_date = ending_date) AND (starting_time = ending_time) THEN
          x_high_low_equal := TRUE;
          ending_time := starting_time + 10;
        IFEND;

        starting_time := number_of_seconds_in_day * starting_date + starting_time;
        ending_time := number_of_seconds_in_day * ending_date + ending_time;

        IF (ending_time - starting_time) < 11 THEN
          frame_scale := 10;
        ELSE
          IF (ending_time - starting_time) < 20 THEN
            frame_scale := 20;
          ELSE
            frame_scale := 100;
          IFEND;
        IFEND;

        patch_to_high := (ending_time - starting_time) MOD frame_scale;
        IF patch_to_high <> 0 THEN
          patch_to_high := frame_scale - patch_to_high;
        IFEND;

        time_interval := ((ending_time + patch_to_high) - starting_time) DIV frame_scale;

        FOR index := 1 TO frame_scale + 1 DO
          distribution_array [1] [index] := starting_time + ((index - 1) * time_interval);
        FOREND;

      PROCEND set_up_x_axis;

?? OLDTITLE ??
?? EJECT, NEWTITLE := '  PROCEDURE set_up_y_axis' ??

      PROCEDURE set_up_y_axis (VAR y_high_low_equal: boolean;
        VAR y_interval: integer);

        VAR
          index: 1 .. 101,
          patch_to_high: 0 .. 10,
          y_high_limit: integer,
          y_low_limit: integer;

        y_low_limit := ctl_blk.metric_low_limit;
        y_high_limit :=ctl_blk.metric_high_limit;


        IF y_low_limit = y_high_limit THEN
          y_high_limit := y_low_limit + 10;
          y_high_low_equal := TRUE;
        IFEND;

        patch_to_high := (y_high_limit - y_low_limit) MOD 10;
        IF patch_to_high <> 0 THEN
          patch_to_high := 10 - patch_to_high;
        IFEND;

        y_interval := ((y_high_limit + patch_to_high) - y_low_limit) DIV 10;

        FOR index := 1 TO 11 DO
          distribution_array [4] [index] := y_low_limit + ((index - 1) * y_interval);
        FOREND;

      PROCEND set_up_y_axis;
?? OLDTITLE ??
?? EJECT, NEWTITLE := '  PROCEDURE fill_in_distribution_array' ??

      PROCEDURE fill_in_distribution_array (p_metric_ctl_blk: ^metric_ctl_blk;
            y_interval: integer;
            time_interval: integer;
            frame_scale: 1 .. 100;
            starting_time: integer;
            ending_time: integer;
        VAR out_low_x: integer;
        VAR out_low_y: integer;
        VAR out_high_x: integer;
        VAR out_high_y: integer);


        VAR
          element_index: integer,
          half_time_interval: integer,
          high_element_value: integer,
          highest_value_on_y_axis: integer,
          index: 1 .. 101,
          low_element_value: integer,
          lowest_value_on_y_axis: integer,
          metric_array: ^array [1 .. * ] of date_time_metric,
          metric_value: date_time_metric,
          temp_time_value: integer,
          y_high_limit: integer,
          y_low_limit: integer,
          y_temp: integer;

        y_low_limit := ctl_blk.metric_low_limit;
        y_high_limit :=ctl_blk.metric_high_limit;

        lowest_value_on_y_axis := y_low_limit - (y_interval DIV 2);
        highest_value_on_y_axis := y_high_limit + (y_interval DIV 2);

        half_time_interval := time_interval DIV 2;

        RESET p_metric_ctl_blk^.element_sequence.sequence_pointer;

        NEXT metric_array: [1 .. p_metric_ctl_blk^.element_count] IN p_metric_ctl_blk^.element_sequence.
              sequence_pointer;

        FOR element_index := 1 TO p_metric_ctl_blk^.element_count DO
          metric_value := metric_array^ [element_index];
          temp_time_value := (metric_value.date_value * number_of_seconds_in_day) + metric_value.time_value;
          IF temp_time_value < starting_time THEN
            out_low_x := out_low_x + 1;
          ELSE
            IF temp_time_value > ending_time THEN
              out_high_x := out_high_x + 1;
            ELSE

            /find_its_interval/
              FOR index := 1 TO frame_scale DO
                IF ((distribution_array [1] [index] - half_time_interval) <= temp_time_value) AND
                      ((distribution_array [1] [index + 1] - half_time_interval) > temp_time_value) THEN
                  IF metric_value.counter_value < lowest_value_on_y_axis THEN
                    distribution_array [5] [index] := - 1;
                    out_low_y := out_low_y + 1;
                  ELSE
                    IF metric_value.counter_value > highest_value_on_y_axis THEN
                      distribution_array [6] [index] := - 1;
                      out_high_y := out_high_y + 1;
                    ELSE
                      IF metric_value.counter_value < distribution_array [2] [index] THEN
                        distribution_array [2] [index] := metric_value.counter_value;
                      IFEND;

                      IF metric_value.counter_value > distribution_array [3] [index] THEN
                        distribution_array [3] [index] := metric_value.counter_value;
                      IFEND;

                    IFEND;
                  IFEND;

                  EXIT /find_its_interval/;
                IFEND;
              FOREND /find_its_interval/;

            IFEND;
          IFEND;
        FOREND;


        FOR index := 1 TO frame_scale + 1 DO
          low_element_value := distribution_array [2] [index];
          IF (distribution_array [5] [index] <> - 1) AND (low_element_value <> maximum_integer) THEN
            y_temp := ((low_element_value - y_low_limit) * 30) DIV (y_interval * 10) + 1;
            IF ((low_element_value - y_low_limit) * 30) MOD (y_interval * 10) >= (y_interval * 5) THEN
              y_temp := y_temp + 1;
            IFEND;
            distribution_array [5] [index] := y_temp;
          IFEND;

          high_element_value := distribution_array [3] [index];
          IF (distribution_array [6] [index] <> - 1) AND (high_element_value <> 0) THEN
            y_temp := ((high_element_value - y_low_limit) * 30) DIV (y_interval * 10) + 1;
            IF ((high_element_value - y_low_limit) * 30) MOD (y_interval * 10) >= (y_interval * 5) THEN
              y_temp := y_temp + 1;
            IFEND;
            distribution_array [6] [index] := y_temp;
          IFEND;

        FOREND;

      PROCEND fill_in_distribution_array;

?? OLDTITLE ??
?? EJECT, NEWTITLE := '  PROCEDURE fill_in_graph_array' ??

      PROCEDURE fill_in_graph_array (frame_scale: 1 .. 100;
            frame_factor: 1 .. 10;
        VAR high_frame_line: string (116);
        VAR low_frame_line: string (116));

        VAR
          local_status: ost$status,
          y_index: 1 .. 31,
          x_index: 1 .. 116;

        FOR x_index := 1 TO 10 DO
          graph [1] (x_index * 10 + 7, 10) := '---------+';
          graph [31] (x_index * 10 + 7, 10) := '---------+';
        FOREND;

        FOR y_index := 1 TO 31 DO
          IF (y_index MOD 3) = 1 THEN
            clp$convert_integer_to_rjstring (distribution_array [4] [(y_index DIV 3) + 1], 10, FALSE, ' ',
                  graph [y_index] (6, 10), local_status);
            check_status (local_status);
            graph [y_index] (16) := '+';
            graph [y_index] (116) := '+';
          ELSE
            graph [y_index] (16) := '|';
            graph [y_index] (116) := '|';
          IFEND;
        FOREND;

        FOR x_index := 1 TO frame_scale + 1 DO
          IF distribution_array [5] [x_index] = - 1 THEN
            low_frame_line ((x_index - 1) * frame_factor + 16) := 'L';
          IFEND;
          IF distribution_array [6] [x_index] = - 1 THEN
            high_frame_line ((x_index - 1) * frame_factor + 16) := 'H';
          IFEND;
        FOREND;

        FOR x_index := 1 TO frame_scale + 1 DO
          FOR y_index := 1 TO 31 DO
            IF (distribution_array [5] [x_index] <= y_index) AND (distribution_array [6] [x_index] >= y_index)
                  THEN
              graph [y_index] ((x_index - 1) * frame_factor + 16) := '*';
            IFEND;
          FOREND;
        FOREND;

        graph [31] (1) := '0';

      PROCEND fill_in_graph_array;

?? OLDTITLE ??
?? EJECT, NEWTITLE := '  PROCEDURE calculate_date_time_lines' ??

      PROCEDURE calculate_date_time_lines (starting_time: integer;
            ending_time: integer;
            frame_scale: 1 .. 100;
            frame_factor: 1 .. 10;
        VAR time_base_line: string (126);
        VAR date_base_line: string (126));

        VAR
          date: 0 .. 365,
          frame_constant: 1 .. 10,
          hours: 0 .. 23,
          index: 1 .. 11,
          last_date: 0 .. 365,
          local_status: ost$status,
          minutes: 0 .. 59,
          seconds: 0 .. 59,
          temp_time_string: string (8),
          temp_time_value: integer,
          time: integer;

        last_date := 0;
        frame_constant := 10 DIV frame_factor;
        temp_time_string (3) := ':';
        temp_time_string (6) := ':';

        FOR index := 1 TO 11 DO
          temp_time_value := distribution_array [1] [(index - 1) * (frame_constant) + 1];
          date := temp_time_value DIV number_of_seconds_in_day;
          time := temp_time_value - (date * number_of_seconds_in_day);

          IF date <> last_date THEN
            last_date := date;
            clp$convert_integer_to_rjstring (date, 10, FALSE, '0', date_base_line (index * 10 + 6, 3),
                  local_status);
            check_status (local_status);
          IFEND;

          hours := time DIV 3600;
          minutes := (time - (hours * 3600)) DIV 60;
          seconds := (time - (hours * 3600) - (minutes * 60));

          clp$convert_integer_to_rjstring (hours, 10, FALSE, '0', temp_time_string (1, 2), local_status);
          check_status (local_status);

          clp$convert_integer_to_rjstring (minutes, 10, FALSE, '0', temp_time_string (4, 2), local_status);
          check_status (local_status);

          clp$convert_integer_to_rjstring (seconds, 10, FALSE, '0', temp_time_string (7, 2), local_status);
          check_status (local_status);

          time_base_line (index * 10 + 3, 8) := temp_time_string;

        FOREND;

      PROCEND calculate_date_time_lines;

?? OLDTITLE ??
?? EJECT ??

      VAR
        date_base_line: string (126),
        ending_time: integer,
        frame_scale: 1 .. 100,
        frame_factor: 1 .. 10,
        high_frame_line: string (116),
        in_frame_cnt: integer,
        local_status: ost$status,
        low_frame_line: string (116),
        out_low_x: integer,
        out_high_x: integer,
        out_low_y: integer,
        out_high_y: integer,
        p_metric_ctl_blk: ^metric_ctl_blk,
        starting_time: integer,
        time_base_line: string (126),
        time_interval: integer,
        unit_message_line: string (126),
        x_high_low_equal: boolean,
        y_high_low_equal: boolean,
        y_index: 1 .. 31,
        y_interval: integer;

      VAR
        x_axis_high_limit_msg: [STATIC] string (126) :=
          '                                 Number of Elements above X-axis High Limit  =',
        x_axis_low_limit_msg: [STATIC] string (126) :=
          '                                 Number of Elements below X-axis Low  Limit  =',
        y_axis_high_limit_msg: [STATIC] string (126) :=
          '                                 Number of Elements above Y-axis High Limit  =',
        y_axis_low_limit_msg: [STATIC] string (126) :=
          '                                 Number of Elements below Y-axis Low  Limit  =',
        points_within_graph_msg: [STATIC] string (126) :=
          '                                 Number of Elements within the Frame Limits  =';

?? EJECT ??

      print_title (ctl_blk, 'Time Distribution Report');

      p_metric_ctl_blk := ctl_blk.p_metric_ctl_blk;
      IF p_metric_ctl_blk^.element_count = 0 THEN
        print ('There are no elements for this metric.');
        RETURN;
      IFEND;

      initialize_arrays;

      out_low_x := 0;
      out_high_x := 0;
      x_high_low_equal := FALSE;
      out_low_y := 0;
      out_high_y := 0;
      y_high_low_equal := FALSE;

      set_up_x_axis (x_high_low_equal, time_interval, frame_scale, starting_time, ending_time);
      set_up_y_axis (y_high_low_equal, y_interval);

      fill_in_distribution_array (p_metric_ctl_blk, y_interval, time_interval, frame_scale, starting_time,
            ending_time, out_low_x, out_low_y, out_high_x, out_high_x);

      clp$convert_integer_to_rjstring (out_high_x, 10, FALSE, ' ', x_axis_high_limit_msg (82, 7),
            local_status);
      check_status (local_status);

      clp$convert_integer_to_rjstring (out_low_x, 10, FALSE, ' ', x_axis_low_limit_msg (82, 7), local_status);
      check_status (local_status);

      print (x_axis_high_limit_msg);
      print (x_axis_low_limit_msg);

      IF x_high_low_equal OR y_high_low_equal THEN
        y_axis_high_limit_msg (92, 8) := 'WARNING:';
        IF x_high_low_equal THEN
          y_axis_low_limit_msg (92, * ) := 'X high and low limits are equal';
        ELSE
          y_axis_low_limit_msg (92, * ) := 'Y high and low limits are equal';
        IFEND;
      IFEND;

      clp$convert_integer_to_rjstring (out_high_y, 10, FALSE, ' ', y_axis_high_limit_msg (82, 7),
            local_status);
      check_status (local_status);

      clp$convert_integer_to_rjstring (out_low_y, 10, FALSE, ' ', y_axis_low_limit_msg (82, 7), local_status);
      check_status (local_status);

      in_frame_cnt := p_metric_ctl_blk^.element_count - out_low_y - out_low_x - out_high_y - out_high_x;

      clp$convert_integer_to_rjstring (in_frame_cnt, 10, FALSE, ' ', points_within_graph_msg (82, 7),
            local_status);
      check_status (local_status);

      print (y_axis_high_limit_msg);
      print (y_axis_low_limit_msg);
      print (points_within_graph_msg);

      CASE frame_scale OF
      = 10 =
        frame_factor := 10;
      = 20 =
        frame_factor := 5;
      = 100 =
        frame_factor := 1;
      CASEND;

      high_frame_line := '0 ';
      low_frame_line := '0 ';

      fill_in_graph_array (frame_scale, frame_factor, high_frame_line, low_frame_line);

      print (high_frame_line);

      FOR y_index := 31 DOWNTO 1 DO
        print (graph [y_index]);
      FOREND;

      time_base_line := ' ';
      date_base_line := ' ';

      calculate_date_time_lines (starting_time, ending_time, frame_scale, frame_factor, time_base_line,
            date_base_line);

      print (time_base_line);
      print (date_base_line);
      print (low_frame_line);

      unit_message_line := ' ';
      unit_message_line (55, max_name_size) := p_metric_ctl_blk^.unit (1, max_name_size);
      print (unit_message_line);

      IF p_metric_ctl_blk^.element_count <> in_frame_cnt THEN
        print ('0               NOTES:');
        print ('                    H - The value on y-axis correspond to x-interval');
        print ('                        is higher than the y-axis upper bound');
        print ('                    L - The value on y-axis correspond to x-interval');
        print ('                        is lower than the y-axis lower bound');
      IFEND;

    PROCEND display_time_distribution;
?? EJECT, TITLE := 'Procedure condition_handler' ??

    PROCEDURE Condition_Handler (condition: pmt$condition;
       condition_descriptor: ^pmt$condition_information;
       save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      program_status := abnormal_status;
      EXIT lgp$display_binary_log;
    PROCEND Condition_handler;
?? EJECT, TITLE := 'Main Program' ??

    VAR
       establish_descriptor: pmt$established_handler;

    pmp$establish_condition_handler (abnormal_condition, ^condition_handler, ^establish_descriptor,
       program_status);
    IF NOT program_status.normal THEN
       RETURN;
    IFEND;

    initialize;


{  Set up the command utility environment, and start processing
{  subcommands.                                                  }

    clp$push_utility ('DISPLAY_BINARY_LOG             ', clc$global_command_search, sub_command_list, NIL,
          local_status);
    check_status (local_status);

    clp$scan_command_file (clc$current_command_input, 'DISPLAY_BINARY_LOG             ', 'DISBL',
          local_status);
    check_status (local_status);

{  Clean up after the user has entered a QUIT command.  }

    clp$pop_utility (local_status);
    check_status (local_status);

{  Link all of the control blocks set up by the subcommands.  }

    link_blocks;
    open_segs;
    p_log_blk := log_chain_head;
    WHILE p_log_blk <> NIL DO
      amp$open (p_log_blk^.log_file_name, amc$record, p_access_array, input_file, local_status);
      check_status (local_status);
      scan_log;
      amp$close (input_file, local_status);
      check_status (local_status);
      p_log_blk := p_log_blk^.log_chain_link;
    WHILEND;
    generate_reports;
    close_files;
  PROCEND lgp$display_binary_log;
?? OLDTITLE, TITLE := 'Common Procedures', NEWTITLE := '  ' ??
?? EJECT, TITLE := 'PROCEDURE check_status' ??

    PROCEDURE check_status (input_status: ost$status);

      IF NOT input_status.normal THEN
        close_files;
        abnormal_status := input_status;
        pmp$cause_condition (abnormal_status_condition, NIL, local_status);
      IFEND;

    PROCEND check_status;
?? EJECT, TITLE := 'PROCEDURE find_group' ??

  PROCEDURE find_group (group_name: name_type;
    VAR p_group_ctl_blk: ^group_ctl_blk);

    p_group_ctl_blk := group_chain_head;

    WHILE p_group_ctl_blk <> NIL DO
      IF p_group_ctl_blk^.name = group_name THEN
        RETURN;
      IFEND;
      p_group_ctl_blk := p_group_ctl_blk^.group_chain_link;
    WHILEND;

  PROCEND find_group;
?? EJECT, TITLE := 'print_log_report_title' ??

    PROCEDURE print_log_report_title;

      VAR
        line_image: string (132);

      print ('1 Logs Scanned by Display_Binary_Log');
      line_image := '  Display_Binary_Log        ';
      print (line_image);
      print ('-');
      print ('-');

    PROCEND print_log_report_title;
?? EJECT, TITLE := 'PROCEDURE close_files' ??

    PROCEDURE close_files;

      VAR
        local_status: ost$status,
        p_group_ctl_blk: ^group_ctl_blk,
        p_metric_ctl_blk: ^metric_ctl_blk;

      amp$close (output_file, local_status);


{ Now closing all metric files.

      p_metric_ctl_blk := metric_chain_head;
      WHILE p_metric_ctl_blk <> NIL DO

        amp$close (p_metric_ctl_blk^.file_identifier, local_status);

        p_metric_ctl_blk := p_metric_ctl_blk^.metric_chain_link;

      WHILEND;

{ Now closing all group files.

      p_group_ctl_blk := group_chain_head;
      WHILE p_group_ctl_blk <> NIL DO

        amp$close (p_group_ctl_blk^.copy_file_identifier, local_status);

        p_group_ctl_blk := p_group_ctl_blk^.group_chain_link;

      WHILEND;

    PROCEND close_files;
?? EJECT, TITLE := 'PROCEDURE convert_date_time' ??

    PROCEDURE convert_date_time (date_time: ost$date_time;
      VAR str: string (20));

      clp$convert_integer_to_rjstring (date_time.year, 10, FALSE, '0', str (1, 2), local_status);
      check_status (local_status);
      clp$convert_integer_to_rjstring (date_time.month, 10, FALSE, '0', str (4, 2), local_status);
      check_status (local_status);
      clp$convert_integer_to_rjstring (date_time.day, 10, FALSE, '0', str (7, 2), local_status);
      check_status (local_status);
      str (3) := '/';
      str (6) := '/';

      clp$convert_integer_to_rjstring (date_time.hour, 10, FALSE, '0', str (11, 2), local_status);
      check_status (local_status);
      clp$convert_integer_to_rjstring (date_time.minute, 10, FALSE, '0', str (14, 2), local_status);
      check_status (local_status);
      clp$convert_integer_to_rjstring (date_time.second, 10, FALSE, '0', str (17, 2), local_status);
      check_status (local_status);
      str (13) := ':';
      str (16) := ':';

    PROCEND convert_date_time;
?? EJECT, TITLE := 'PROCEDURE print' ??

    PROCEDURE print (text_line: string ( * ));

      VAR
        line_length: integer;

      line_length := #SIZE (text_line);

      WHILE (line_length > 1) AND (text_line (line_length) = ' ') DO
        line_length := line_length - 1;
      WHILEND;


      amp$put_next (output_file, #LOC (text_line), line_length, file_byte_address, local_status);
      check_status (local_status);

    PROCEND print;
?? EJECT, TITLE := 'PROCEDURE emit_statistics_report' ??

  PROCEDURE emit_statistics_report;
    VAR
      stat_blk: ^ sft$global_log_statistic_header,
      p_counters: sft$counters,
      p_descript: ^sft$descriptive_data,
      first_record: boolean,
      start_time,
      end_time: ost$date_time,
      local_status: ost$status,
      line_buffer: string (130);

    first_record := true;
    repeat
      get_stat_record (input_file, input_buffer, input_file_position, stat_blk, p_counters,
                       p_descript, local_status);
      check_status (local_status);
      IF input_file_position <> amc$eoi THEN
         IF first_record THEN
            first_record := false;
            start_time := stat_blk^.date_time;
         IFEND;
         end_time := stat_blk^.date_time;
         insert_into_code_list (stat_blk);
      IFEND;
    UNTIL input_file_position = amc$eoi;
    print_log_report_title;
    print_time_date_stat_hdr (start_time, end_time);
    print_code;
  PROCEND emit_statistics_report;
?? EJECT, TITLE := 'PROCEDURE insert_into_code_list' ??

  PROCEDURE insert_into_code_list (stat_blk: ^sft$global_log_statistic_header);

    VAR
       p_stat_code_ctl_blk: ^stat_code_ctl_blk,
       found_code: boolean,
       q,
       p: ^stat_code_ctl_blk;

    found_code := false;
    q := NIL;
    p := stat_name_chain_head;
    /find_code/
    WHILE p <> NIL DO
       IF p^.stat_code < stat_blk^.statistic_code THEN
          q := p;
          p := p^.code_chain_link;
       ELSEIF p^.stat_code > stat_blk^.statistic_code THEN
          EXIT /find_code/;
       ELSE
          found_code := true;
          EXIT /find_code/;
       IFEND;
     WHILEND /find_code/;

     IF NOT found_code THEN
        ALLOCATE p_stat_code_ctl_blk;
        p_stat_code_ctl_blk^.stat_code := stat_blk^.statistic_code;
        p_stat_code_ctl_blk^.code_chain_link := p;
        IF q = NIL THEN
           stat_name_chain_head := p_stat_code_ctl_blk;
        ELSE
           q^.code_chain_link := p_stat_code_ctl_blk;
        IFEND;
     IFEND;
  PROCEND insert_into_code_list;
?? EJECT, TITLE := 'PROCEDURE print_time_date_stat_hdr' ??

  PROCEDURE print_time_date_stat_hdr (start_time : ost$date_time;
    end_time : ost$date_time);

    VAR
       line_image: string (136),
       str1,
       str2: string (20);

    convert_date_time (start_time, str1);
    convert_date_time (end_time, str2);

    line_image := '   DATE : ';
    line_image (32,7) := 'TIME : ';
    line_image (19,2) := '..';
    line_image (49,2) := '..';
    line_image (11,8) := str1 (1,8);
    line_image (21,8) := str2 (1,8);
    line_image (41,8) := str1 (11,8);
    line_image (51,8) := str2 (11,8);
    print (line_image);
  PROCEND print_time_date_stat_hdr;
?? EJECT, TITLE := 'PROCEDURE print_code' ??

  PROCEDURE print_code;

    VAR
       statistic_string: string (10),
       buffer: string (130),
       buf_length: integer,
       q: ^stat_code_ctl_blk;

    q := stat_name_chain_head;
    buffer := ' ';
    buffer := '  STATISTICS ';
    print (buffer);
    WHILE q <> NIL DO
      buffer := ' ';
      get_statistic_string (q^.stat_code, statistic_string, local_status);
      IF NOT local_status.normal THEN
         RETURN;
      IFEND;
      STRINGREP (buffer, buf_length, '            ', statistic_string);
      print (buffer);
      q := q^.code_chain_link;
    WHILEND;
  PROCEND print_code;
?? EJECT, TITLE := 'PROCEDURE find_metric' ??

  PROCEDURE find_metric (metric_name: name_type;
    VAR p_metric_ctl_blk: ^metric_ctl_blk);

    p_metric_ctl_blk := metric_chain_head;

    WHILE p_metric_ctl_blk <> NIL DO
      IF p_metric_ctl_blk^.name = metric_name THEN
        RETURN;
      IFEND;
      p_metric_ctl_blk := p_metric_ctl_blk^.metric_chain_link;
    WHILEND;

  PROCEND find_metric;
?? EJECT, TITLE := 'PROCEDURE [INLINE] get_statistic_string' ??

  PROCEDURE [INLINE] get_statistic_string (statistic: sft$statistic_code;
    VAR statistic_string: string (10);
    VAR status: ost$status);

    VAR
      statistic_id: ost$status_identifier,
      statistic_number: ost$status_condition_number,
      num_string: ost$string,
      str_length: integer,
      str_value: ost$name;

    statistic_string := ' ';
    osp$unpack_status_condition (statistic, statistic_id, statistic_number);

    clp$convert_integer_to_string (statistic_number, 10, false, num_string, status);
    IF NOT status.normal THEN
      return;
    IFEND;

    STRINGREP (str_value, str_length, statistic_id, num_string.value(1, num_string.size));
    statistic_string := str_value (1, str_length);

  PROCEND get_statistic_string;
?? EJECT, TITLE := 'PROCEDURE dump_record' ??

  PROCEDURE dump_record (p_header: ^sft$global_log_statistic_header;
        p_counters: sft$counters;
        p_descript: ^sft$descriptive_data;
        report_ctl_blk: ^report_ctl_blk;
    VAR local_status: ost$status);

    VAR
      i: 0 .. 1,
      line_image: string (136),
      line_length: integer,
      statistic_string: string (10),
      counter_counter: 0 .. sfc$max_number_of_counters,
      line_position: integer;

    VAR
      stat_date: ost$date,
      stat_time: ost$time,
      task_id_index: string(5),
      task_id_seqno: string(3);

    { Dump the statistic record header }

    line_image := ' ';

    get_statistic_string (p_header^.statistic_code, statistic_string, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    pmp$format_compact_date (p_header^.date_time, osc$mdy_date, stat_date, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    pmp$format_compact_time (p_header^.date_time, osc$millisecond_time, stat_time, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;


    clp$convert_integer_to_rjstring (p_header^.task_id.index, 10, FALSE, ' ', task_id_index,
          local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;


    clp$convert_integer_to_rjstring (p_header^.task_id.seqno, 10, FALSE, '0', task_id_seqno,
          local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (line_image, line_length, ' ', statistic_string, '  ', stat_date.mdy,
      '  ', stat_time.millisecond, '  ', p_header^.job_name (1, jmc$system_supplied_name_size),
      ' ', task_id_index, '-', task_id_seqno);

    amp$put_next (output_file, ^line_image, line_length, file_byte_address, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    line_image := ' ';

    { Dump the descriptive data, if any }

    IF p_header^.descriptive_data_size > 0 THEN
      IF p_header^.descriptive_data_size > 128 THEN
        line_image (2, 128) := p_descript^;
        amp$put_next (output_file, ^line_image, #SIZE (line_image), file_byte_address, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
        line_image := ' ';
        line_image (2, *) := p_descript^ (129, p_header^.descriptive_data_size - 128);
        amp$put_next (output_file, ^line_image, #SIZE (line_image), file_byte_address, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
      ELSE
        line_image (2, p_header^.descriptive_data_size) := p_descript^;
        amp$put_next (output_file, ^line_image, #SIZE (line_image), file_byte_address, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    { Dump all of the counters }

    counter_counter := 1;
    line_position := 2;
    line_image := ' ';

    WHILE counter_counter <= p_header^.number_of_counters DO

      clp$convert_integer_to_rjstring (p_counters^ [counter_counter], report_ctl_blk^.counter_radix
            [counter_counter], TRUE, ' ', line_image (line_position, 25), local_status);
      IF NOT local_status.normal THEN
        RETURN;
      IFEND;
      line_position := line_position + 25;
      counter_counter := counter_counter + 1;
      IF line_position > (4 * 25) THEN
        amp$put_next (output_file, ^line_image, #SIZE (line_image), file_byte_address, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
        line_position := 2;
        line_image := ' ';
      IFEND;
    WHILEND;

    IF line_position > 2 THEN
      amp$put_next (output_file, ^line_image, #SIZE (line_image), file_byte_address, local_status);
      IF NOT local_status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    { Output a blank line to separate statistics }

    line_image (1) := ' ';
    amp$put_next (output_file, ^line_image (1), #SIZE (line_image (1)), file_byte_address,
          local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;


  PROCEND dump_record;
?? EJECT, TITLE := 'PROCEDURE convert_log_to_gf_format' ??

  PROCEDURE convert_log_to_gf_format (p_header: ^sft$global_log_statistic_header;
        p_counters: sft$counters;
        p_descript: ^sft$descriptive_data;
        gf_identifier: amt$file_identifier;
    VAR local_status: ost$status);

    VAR
      i: 0 .. 1,
      line_image: string (136),
      month: 0 .. 12,
      year: 0 .. 255,
      day: 1 .. 366,
      year_string: string (4),
      day_string: string (3),
      hour: string (2),
      minute: string (2),
      second: string (2),
      millisecond: string (3),
      number_of_counters: string (2),
      descriptive_data_size: string (3),
      task_id_index: string (5),
      task_id_seqno: string (3),
      line_length: integer,
      statistic_string: string (10),
      counter_counter: 0 .. sfc$max_number_of_counters,
      line_position: 1 .. 136;

    day := p_header^.date_time.day;
    month := p_header^.date_time.month - 1;
    year := p_header^.date_time.year;

    line_image := '  ';
    get_statistic_string (p_header^.statistic_code, statistic_string, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (year + 1900, 10, FALSE, '0', year_string, local_status);
    WHILE month >= 1 DO
      CASE month OF
      = 1, 3, 5, 7, 8, 10, 12 =
        day := day + 31;

      = 4, 6, 9, 11 =
        day := day + 30;

      = 2 =
        IF (year MOD 4) = 0 THEN
          day := day + 29;
        ELSE
          day := day + 28;
        IFEND;
      CASEND;
      month := month - 1;
    WHILEND;
    clp$convert_integer_to_rjstring (day, 10, FALSE, '0', day_string, local_status);
    clp$convert_integer_to_rjstring (p_header^.date_time.hour, 10, FALSE, '0', hour, local_status);
    clp$convert_integer_to_rjstring (p_header^.date_time.minute, 10, FALSE, '0', minute, local_status);
    clp$convert_integer_to_rjstring (p_header^.date_time.second, 10, FALSE, '0', second, local_status);
    clp$convert_integer_to_rjstring (p_header^.date_time.millisecond, 10, FALSE, '0', millisecond,
          local_status);
    clp$convert_integer_to_rjstring (p_header^.task_id.index, 10, FALSE, '0', task_id_index, local_status);
    clp$convert_integer_to_rjstring (p_header^.task_id.seqno, 10, FALSE, '0', task_id_seqno,
          local_status);
    clp$convert_integer_to_rjstring (p_header^.number_of_counters, 10, FALSE, ' ',
          number_of_counters, local_status);
    clp$convert_integer_to_rjstring (p_header^.descriptive_data_size, 10, FALSE, ' ',
          descriptive_data_size, local_status);

    STRINGREP (line_image, line_length, ' ', statistic_string, ' ', year_string, day_string, ' ',
          hour, ':', minute, ':', second, '.', millisecond, ' ', p_header^.job_name (1,
          jmc$system_supplied_name_size), ' ', task_id_index, '-', task_id_seqno, ' ',
          number_of_counters, ' ', descriptive_data_size);

    amp$put_next (gf_identifier, ^line_image, line_length, file_byte_address, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    line_image := '  ';
    counter_counter := 1;
    line_position := 1;
    WHILE p_header^.number_of_counters >= counter_counter DO
      clp$convert_integer_to_rjstring (p_counters^ [counter_counter], 10, FALSE, ' ', line_image
            (line_position, 20), local_status);
      IF (counter_counter MOD 4) = 0 THEN
        amp$put_next (gf_identifier, ^line_image, #SIZE (line_image), file_byte_address, local_status);
        line_position := 1;
        line_image := '  ';
      ELSE
        line_position := line_position + 20;
      IFEND;
      counter_counter := counter_counter + 1;
    WHILEND;
    IF (p_header^.number_of_counters MOD 4) <> 0 THEN
      amp$put_next (gf_identifier, ^line_image, #SIZE (line_image), file_byte_address, local_status);
    IFEND;

    line_image := '  ';
    IF p_header^.descriptive_data_size > 0 THEN
      IF p_header^.descriptive_data_size > 128 THEN
        line_image (2, 128) := p_descript^;
        amp$put_next (gf_identifier, ^line_image, #SIZE (line_image), file_byte_address, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
        line_image := ' ';
        line_image (2, *) := p_descript^ (129, p_header^.descriptive_data_size - 128);
        amp$put_next (gf_identifier, ^line_image, #SIZE (line_image), file_byte_address, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
      ELSE
        line_image (2, p_header^.descriptive_data_size) := p_descript^;
        amp$put_next (gf_identifier, ^line_image, #SIZE (line_image), file_byte_address, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

  PROCEND convert_log_to_gf_format;
?? EJECT, TITLE := 'PROCEDURE get_stat_record' ??

  PROCEDURE get_stat_record (file: amt$file_identifier;
    VAR buffer: sft$statistic_buffer;
    VAR file_position: amt$file_position;
    VAR p_header: ^sft$global_log_statistic_header;
    VAR p_counters: sft$counters;
    VAR p_descript: ^sft$descriptive_data;
    VAR local_status: ost$status);

    VAR
      transfer_count: amt$transfer_count,
      record_byte_address: amt$file_byte_address,
      p_buffer: ^sft$statistic_buffer;

    amp$get_next (file, #LOC (buffer), #SIZE (buffer), transfer_count, record_byte_address, file_position,
          local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    IF file_position <> amc$eoi THEN
      lgp$parse_statistic (^buffer, p_header, p_counters, p_descript, local_status);
    IFEND;

  PROCEND get_stat_record;
?? EJECT, TITLE := 'PROCEDURE put_stat_record' ??

  PROCEDURE put_stat_record (file: amt$file_identifier;
        p_header: ^sft$global_log_statistic_header;
        p_counters: sft$counters;
        p_descript: ^sft$descriptive_data;
    VAR local_status: ost$status);

    VAR
      record_size: integer,
      record_byte_address: amt$file_byte_address;

    { Note: This procedure assumes that the elements pointed to by the
    { various parameters are part of the same statistic within a single
    { buffer. }

    record_size := #SIZE (p_header^);
    IF p_counters <> NIL THEN
      record_size := record_size + #SIZE (p_counters^);
    IFEND;
    IF p_descript <> NIL THEN
      record_size := record_size + #SIZE (p_descript^);
    IFEND;

    amp$put_next (file, #LOC (p_header^), record_size, record_byte_address, local_status);

  PROCEND put_stat_record;
?? EJECT, TITLE := 'PROCEDURE link_report' ??

  PROCEDURE link_report (p_report_ctl_blk: ^report_ctl_blk);

    VAR
      p_last_block: ^report_ctl_blk;

    { Since the blocks are linked in the order they appear in
    { the command list, we must first find the last block on the
    { chain. }

    p_last_block := report_chain_head;
    IF p_last_block = NIL THEN
      report_chain_head := p_report_ctl_blk;
    ELSE
      WHILE p_last_block^.report_chain_link <> NIL DO
        p_last_block := p_last_block^.report_chain_link;
      WHILEND;

      p_last_block^.report_chain_link := p_report_ctl_blk;
    IFEND;

    p_report_ctl_blk^.report_chain_link := NIL;

  PROCEND link_report;
?? EJECT, TITLE := 'FUNCTION local_name_conflict' ??

  FUNCTION local_name_conflict (file_name: amt$local_file_name): boolean;

    VAR
      p_block: ^report_ctl_blk;

    { This function is used to detect local file name redefined caused }
    { by gengf subcommand when parameter PERMANENT = TRUE. }

    local_name_conflict := FALSE;
    p_block := report_chain_head;

    WHILE p_block <> NIL DO
      IF p_block^.report_type = gen_group_file THEN
        IF p_block^.file_name = file_name THEN
          local_name_conflict := TRUE;
          RETURN;
        IFEND;
      IFEND;
      p_block := p_block^.report_chain_link;
    WHILEND;

  FUNCEND local_name_conflict;

?? EJECT, TITLE := 'PROCEDURE insert_to_desc_chain' ??

  PROCEDURE insert_to_desc_chain (p_descript: ^sft$descriptive_data;
        d_size: 0 .. sfc$max_descriptive_data_size;
    VAR p_desc_blk1,
        p_desc_blk2: ^desc_blk);

    VAR
      found: boolean,
      temp_index: integer,
      p_temp_desc_blk: ^desc_blk;

    found := FALSE;

  /search_order/
    WHILE p_desc_blk2 <> NIL DO
      IF (d_size = p_desc_blk2^.desc_data_size) AND (p_descript^ (1, d_size) = p_desc_blk2^.desc_data (1,
            d_size)) THEN
        p_desc_blk2^.count := p_desc_blk2^.count + 1;
        found := TRUE;
        EXIT /search_order/;
      ELSE
        IF smaller_than (p_descript^, p_desc_blk2^.desc_data, d_size, p_desc_blk2^.desc_data_size) THEN
          EXIT /search_order/;
        IFEND;
      IFEND;
      p_desc_blk1 := p_desc_blk2;
      p_desc_blk2 := p_desc_blk1^.desc_chain_link;
    WHILEND /search_order/;

    IF NOT found THEN
      ALLOCATE p_temp_desc_blk;
      p_temp_desc_blk^.count := 1;
      p_temp_desc_blk^.desc_data (1, d_size) := p_descript^ (1, d_size);
      p_temp_desc_blk^.desc_data_size := d_size;
      p_temp_desc_blk^.desc_chain_link := p_desc_blk2;
      p_desc_blk1^.desc_chain_link := p_temp_desc_blk;
    IFEND;

  PROCEND insert_to_desc_chain;
?? EJECT, TITLE := 'FUNCTION smaller_than' ??

  FUNCTION smaller_than (str1,
        str2: sft$descriptive_data;
        size1,
        size2: 0 .. sfc$max_descriptive_data_size): boolean;

    VAR
      shorter_size,
      temp_index: 0 .. sfc$max_descriptive_data_size,
      str1_shorter,
      value_decided: boolean;

    value_decided := FALSE;
    IF size1 > size2 THEN
      shorter_size := size1;
      str1_shorter := TRUE;
    ELSE
      shorter_size := size2;
      str1_shorter := FALSE;
    IFEND;

  /compare_loop/
    FOR temp_index := 1 TO shorter_size DO
      IF str1 (temp_index) < str2 (temp_index) THEN
        smaller_than := TRUE;
        value_decided := TRUE;
        EXIT /compare_loop/;
      ELSE
        IF str1 (temp_index) > str2 (temp_index) THEN
          smaller_than := FALSE;
          value_decided := TRUE;
          EXIT /compare_loop/;
        IFEND;
      IFEND;
    FOREND /compare_loop/;

    IF (str1_shorter) AND (NOT value_decided) THEN
      smaller_than := TRUE;
    IFEND;
    IF (NOT str1_shorter) AND (NOT value_decided) THEN
      smaller_than := FALSE;
    IFEND;

  FUNCEND smaller_than;


?? EJECT, TITLE := 'PROCEDURE date_time_processor' ??
{  This procedure is called by SCL when it encounters a command parameter  }
{  of type time_value, date_value, or time_interval.  It translates the    }
{  text of the parameter into an integer with the data packed as indicated }
{  below.                                                                  }
{
{  This procedure can process both dates and times because they have       }
{  similar formats.  Both consist of one, two or three numbers, separated  }
{  by colons (time) or slashes (date).                                     }
{
{  Formats for the output integer:
{
{    date_value:     year*10000 + month*100 + day
{
{    time_value:     hours*10000 + minutes*100 + seconds
{
{    time_interval:  hours*3600 + minutes*60 + seconds                     }




  PROCEDURE date_time_processor (value_name: clt$application_value_name;
        keyword_values: ^array [1 .. * ] OF ost$name;
        text: string ( * );
    VAR value: clt$value;
    VAR local_status: ost$status);

    VAR
      current_date_time: ost$date_time,
      token: clt$token,
      dt1,
      dt2,
      dt3: integer;

    VAR
      error_code: ost$status_condition,
      expected_separator: char,
      index: ost$string_index;

    index := 1;

    value.kind := clc$integer_value;
    value.int.radix_specified := FALSE;

    { Remember what type of separator to expect, and what the error code
    { and defaults should be, depending on the type of parameter that we are }
    { processing. }

    IF value_name = 'TIME_VALUE                     ' THEN
      expected_separator := ':';
      error_code := pme$bad_time;
      dt2 := 0;
      dt3 := 0;
    ELSE
      IF value_name = 'DATE_VALUE                     ' THEN
        expected_separator := '/';
        error_code := pme$bad_date;
        dt2 := - 1;
        dt3 := - 1;
      ELSE
        expected_separator := ':';
        error_code := pme$bad_time;
        dt2 := - 1;
        dt3 := - 1;
      IFEND;
    IFEND;

    { Translate the first number. }

    clp$scan_token (text, index, token, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;
    IF token.kind <> clc$integer_token THEN
      osp$set_status_abnormal (pmc$external_log_management_id, error_code, text, local_status);
      RETURN;
    IFEND;
    dt1 := token.int.value;

    { See if there is more to the parameter. }

    IF STRLENGTH (text) > index THEN
      IF text (index) <> expected_separator THEN
        osp$set_status_abnormal (pmc$external_log_management_id, error_code, text, local_status);
        RETURN;
      IFEND;
      index := index + 1;

      { translate the second number. }

      clp$scan_token (text, index, token, local_status);
      IF NOT local_status.normal THEN
        RETURN;
      IFEND;
      IF token.kind <> clc$integer_token THEN
        osp$set_status_abnormal (pmc$external_log_management_id, error_code, text, local_status);
        RETURN;
      IFEND;
      dt2 := token.int.value;

      { See if there is more to the parameter. }

      IF STRLENGTH (text) > index THEN
        IF text (index) <> expected_separator THEN
          osp$set_status_abnormal (pmc$external_log_management_id, error_code, text, local_status);
          RETURN;
        IFEND;
        index := index + 1;

        { translate the third number. }

        clp$scan_token (text, index, token, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
        IF token.kind <> clc$integer_token THEN
          osp$set_status_abnormal (pmc$external_log_management_id, error_code, text, local_status);
          RETURN;
        IFEND;
        dt3 := token.int.value;

        { If there is more to the parameter, it must be an error. }

        IF STRLENGTH (text) > index THEN
          osp$set_status_abnormal (pmc$external_log_management_id, error_code, text, local_status);
          RETURN;
        IFEND;

      IFEND;
    IFEND;

    { Pack the numbers into a single integer, according to the type of
    { value being processed. }

    IF value_name = 'TIME_INTERVAL                  ' THEN
      value.int.value := dt1;
      IF dt2 > - 1 THEN
        value.int.value := (value.int.value * 60) + dt2;
        IF dt3 > - 1 THEN
          value.int.value := (value.int.value * 60) + dt3;
        IFEND;
      IFEND;
    IFEND;

    IF value_name = 'DATE_VALUE                     ' THEN
      pmp$get_compact_date_time (current_date_time, local_status);
      IF (dt2 = - 1) AND (dt3 = - 1) THEN
        dt2 := dt1;
        dt1 := current_date_time.month;
        dt3 := current_date_time.year;
      ELSE
        IF dt3 = - 1 THEN
          dt3 := current_date_time.year;
        IFEND;
      IFEND;
      value.int.value := dt3 * 10000 + dt1 * 100 + dt2;
    IFEND;

    IF value_name = 'TIME_VALUE                     ' THEN
      value.int.value := dt1 * 10000 + dt2 * 100 + dt3;
    IFEND;

  PROCEND date_time_processor;

?? EJECT, TITLE := 'PROCEDURE eval_time' ??

  PROCEDURE eval_time (parameter_time: integer;
    VAR date_time: ost$date_time);

    VAR
      temp_time: integer;

    temp_time := parameter_time;
    date_time.hour := temp_time DIV 10000;
    temp_time := temp_time MOD 10000;
    date_time.minute := temp_time DIV 100;
    date_time.second := temp_time MOD 100;

  PROCEND eval_time;

?? EJECT, TITLE := 'PROCEDURE eval_date' ??

  PROCEDURE eval_date (parameter_date: integer;
    VAR date_time: ost$date_time);

    VAR
      temp_date: integer;

    temp_date := parameter_date;
    date_time.year := temp_date DIV 10000;
    temp_date := temp_date MOD 10000;
    date_time.month := temp_date DIV 100;
    date_time.day := temp_date MOD 100;

  PROCEND eval_date;
?? EJECT, TITLE := 'FUNCTION time_in_seconds' ??

  FUNCTION time_in_seconds (time_value: ost$date_time): integer;

    time_in_seconds := (time_value.hour * 3600) + (time_value.minute * 60) + time_value.second;

  FUNCEND time_in_seconds;
?? EJECT, TITLE := 'FUNCTION date_in_days' ??

  FUNCTION date_in_days (date_value: ost$date_time): integer;

    VAR
      leap_year_cummulative_days: [STATIC, READ] array [0 .. 12] of 0 .. 366 := [0, 31, 60, 91, 121, 152, 182,
        213, 244, 274, 305, 335, 366],

      non_leap_year_cummulative_days: [STATIC, READ] array [0 .. 12] of 0 .. 366 := [0, 31, 59, 90, 120, 151,
        181, 212, 243, 273, 304, 334, 365];


    IF pmp$this_is_a_leap_year (date_value.year) THEN
      date_in_days := leap_year_cummulative_days [date_value.month - 1] + date_value.day;
    ELSE
      date_in_days := non_leap_year_cummulative_days [date_value.month - 1] + date_value.day;
    IFEND;

  FUNCEND date_in_days;


?? OLDTITLE, TITLE := 'Sub-command Processors', NEWTITLE := '  ' ??
?? EJECT, TITLE := 'PROCEDURE defg_subcommand' ??

  PROCEDURE defg_subcommand (subcommand_parameters: clt$parameter_list;
    VAR subcommand_status: ost$status);

    VAR
      initial_group_ctl_blk: [STATIC, READ] group_ctl_blk := [ * , { name } blank_name, { pred_task_group_name
        {} blank_name, { pred_job_group_name } NIL, { group_chain_link } FALSE, { stat_specified } * , {
          {stat_code } FALSE, { date_specified } FALSE, { time_specified } [0, 1, 1, 0, 0, 0, 0], { start_dt }
        [99, 12, 31, 23, 59, 59, 999], { end_dt } NIL, { p_task_succ_group_list } NIL, {
          {p_job_succ_group_list } FALSE, { desc_specified } * , { desc_data_size } * , { desc_data } TRUE, {
          {between_active } NIL, { p_metric_list } FALSE, { copy_requested } [ * , * ], { copy_file_identifier
          {} NIL, { p_pred_task_head } NIL, { p_pred_job_head } FALSE, { desc_needed } NIL { p_desc_blk } ];

?? RIGHT := 110 ??
{  PDT defg_pdt (
{    group,g:  NAME = $REQUIRED
{    statistic, s:  NAME
{    time, t:  RANGE OF time_value date_time_processor
{    date, d:  RANGE OF date_value date_time_processor
{    job_predecessor, jp: NAME
{    task_predecessor, tp:  NAME
{    descriptive_data, dd:  STRING
{    between, b:  LIST 2 OF NAME
{      )

?? PUSH (LISTEXT := ON) ??

    VAR
      defg_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^defg_pdt_names, ^defg_pdt_params];

    VAR
      defg_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 16] of
        clt$parameter_name_descriptor := [['GROUP', 1], ['G', 1], ['STATISTIC', 2], ['S', 2], ['TIME', 3],
        ['T', 3], ['DATE', 4], ['D', 4], ['JOB_PREDECESSOR', 5], ['JP', 5], ['TASK_PREDECESSOR', 6],
        ['TP', 6], ['DESCRIPTIVE_DATA', 7], ['DD', 7], ['BETWEEN', 8], ['B', 8]];

    VAR
      defg_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 8] of clt$parameter_descriptor := [

{ GROUP G }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATISTIC S }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ TIME T }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_allowed, [NIL, clc$application_value, 'TIME_VALUE',
        [clc$linked_av_scanner, ^date_time_processor]]],

{ DATE D }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_allowed, [NIL, clc$application_value, 'DATE_VALUE',
        [clc$linked_av_scanner, ^date_time_processor]]],

{ JOB_PREDECESSOR JP }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ TASK_PREDECESSOR TP }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ DESCRIPTIVE_DATA DD }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0,
        osc$max_string_size]],

{ BETWEEN B }
      [[clc$optional], 2, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]]];

?? POP ??

    VAR
      parameter_value: clt$value,
      p_group_ctl_blk: ^group_ctl_blk,
      parameter_specified: boolean,
      range_specified: boolean,
      str: ost$string,
      integer_value: clt$integer;

    clp$scan_parameter_list (subcommand_parameters, defg_pdt, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('GROUP', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

    str.value := parameter_value.name.value;
    str.size := parameter_value.name.size;

    p_group_ctl_blk := NIL;
    find_group (str.value (1, max_name_size), p_group_ctl_blk);
    IF p_group_ctl_blk <> NIL THEN
      osp$set_status_abnormal (pmc$external_log_management_id, pme$redefined_group, str.value (1, str.size),
            subcommand_status);
      RETURN;
    IFEND;

    { Set up a new control block for this group. }

    ALLOCATE p_group_ctl_blk;
    p_group_ctl_blk^ := initial_group_ctl_blk;

    { Put the group name into the control block. }

    p_group_ctl_blk^.name := str.value (1, max_name_size);

    { Process the STATISTIC parameter. }

    clp$get_value ('STATISTIC', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

    IF parameter_value.kind <> clc$unknown_value THEN
      p_group_ctl_blk^.stat_specified := TRUE;
      str.value := parameter_value.name.value;
      str.size := parameter_value.name.size;

      IF NOT (str.value (1) IN alpha_chars) OR NOT (str.value (2) IN alpha_chars) THEN
        osp$set_status_abnormal (pmc$external_log_management_id, pme$bad_statistic, str.value (1, str.size),
              subcommand_status);
        RETURN;
      IFEND;

      clp$convert_string_to_integer (str.value (3, str.size - 2), integer_value, subcommand_status);
      IF NOT subcommand_status.normal THEN
        osp$set_status_abnormal (pmc$external_log_management_id, pme$bad_statistic, str.value (1, str.size),
              subcommand_status);
        RETURN;
      IFEND;

      IF integer_value.value > osc$max_status_condition_number THEN
        osp$set_status_abnormal (pmc$external_log_management_id, pme$bad_statistic, str.value (1, str.size),
              subcommand_status);
        RETURN;
      ELSE
        p_group_ctl_blk^.stat_code := osp$status_condition_code (str.value (1,2), integer_value.value);
      IFEND;
    IFEND;

    { Process the TIME parameter }

    clp$get_value ('TIME', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    IF parameter_value.kind <> clc$unknown_value THEN
      p_group_ctl_blk^.time_specified := TRUE;
      eval_time (parameter_value.int.value, p_group_ctl_blk^.start_dt);
      clp$test_range ('TIME', 1, 1, range_specified, subcommand_status);
      IF NOT subcommand_status.normal THEN
        RETURN;
      IFEND;
      IF range_specified THEN
        clp$get_value ('TIME', 1, 1, clc$high, parameter_value, subcommand_status);
        IF NOT subcommand_status.normal THEN
          RETURN;
        IFEND;
        eval_time (parameter_value.int.value, p_group_ctl_blk^.end_dt);
      ELSE
        p_group_ctl_blk^.end_dt.hour := p_group_ctl_blk^.start_dt.hour;
        p_group_ctl_blk^.end_dt.minute := p_group_ctl_blk^.start_dt.minute;
        p_group_ctl_blk^.end_dt.second := p_group_ctl_blk^.start_dt.second;
      IFEND;
    IFEND;

    { Process the DATE parameter }

    clp$get_value ('DATE', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    IF parameter_value.kind <> clc$unknown_value THEN
      p_group_ctl_blk^.date_specified := TRUE;
      eval_date (parameter_value.int.value, p_group_ctl_blk^.start_dt);
      clp$test_range ('DATE', 1, 1, range_specified, subcommand_status);
      IF NOT subcommand_status.normal THEN
        RETURN;
      IFEND;
      IF range_specified THEN
        clp$get_value ('DATE', 1, 1, clc$high, parameter_value, subcommand_status);
        IF NOT subcommand_status.normal THEN
          RETURN;
        IFEND;
        eval_date (parameter_value.int.value, p_group_ctl_blk^.end_dt);
      ELSE
        p_group_ctl_blk^.end_dt.year := p_group_ctl_blk^.start_dt.year;
        p_group_ctl_blk^.end_dt.month := p_group_ctl_blk^.start_dt.month;
        p_group_ctl_blk^.end_dt.day := p_group_ctl_blk^.start_dt.day;
      IFEND;
    IFEND;

    { Process the descriptive_data command. }

    clp$get_value ('DESCRIPTIVE_DATA', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    IF parameter_value.kind <> clc$unknown_value THEN
      str := parameter_value.str;
      IF str.size = 0 THEN
        osp$set_status_abnormal (pmc$external_log_management_id, pme$null_desc_data, '', subcommand_status);
        RETURN;
      IFEND;
      p_group_ctl_blk^.desc_specified := TRUE;
      p_group_ctl_blk^.desc_data := str.value (1, str.size);
      p_group_ctl_blk^.desc_data_size := str.size;
    IFEND;

    { Process the task_predecessor parameter. }

    clp$get_value ('TASK_PREDECESSOR', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    IF parameter_value.kind <> clc$unknown_value THEN
      p_group_ctl_blk^.pred_task_group_name := parameter_value.name.value;
    IFEND;

    { Process the job_predecessor parameter. }

    clp$get_value ('JOB_PREDECESSOR', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    IF parameter_value.kind <> clc$unknown_value THEN
      p_group_ctl_blk^.pred_job_group_name := parameter_value.name.value;
    IFEND;

    p_group_ctl_blk^.group_chain_link := group_chain_head;
    group_chain_head := p_group_ctl_blk;

  PROCEND defg_subcommand;
?? EJECT, TITLE := 'PROCEDURE defm_subcommand' ??

  PROCEDURE defm_subcommand (subcommand_parameters: clt$parameter_list;
    VAR subcommand_status: ost$status);

{ PDT defm_pdt (
{   metric, m: NAME = $REQUIRED
{   group, g: NAME = $REQUIRED
{   scale_factor, sf: INTEGER
{   unit, u: STRING
{   counter, c: INTEGER 1..255
{   expression, e: STRING
{   incremental, i: BOOLEAN = FALSE
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    defm_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^defm_pdt_names, ^defm_pdt_params];

  VAR
    defm_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 14] of
      clt$parameter_name_descriptor := [['METRIC', 1], ['M', 1], ['GROUP', 2], ['G', 2], ['SCALE_FACTOR', 3],
      ['SF', 3], ['UNIT', 4], ['U', 4], ['COUNTER', 5], ['C', 5], ['EXPRESSION', 6], ['E', 6], ['INCREMENTAL'
      , 7], ['I', 7]];

  VAR
    defm_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 7] of clt$parameter_descriptor := [

{ METRIC M }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ GROUP G }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ SCALE_FACTOR SF }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, -9223372036854775806,
      9223372036854775807]],

{ UNIT U }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, osc$max_string_size
      ]],

{ COUNTER C }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 1, 255]],

{ EXPRESSION E }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, osc$max_string_size
      ]],

{ INCREMENTAL I }
    [[clc$optional_with_default, ^defm_pdt_dv7], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$boolean_value]]];

  VAR
    defm_pdt_dv7: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'FALSE';

?? POP ??

    VAR
      parameter_value: clt$value,
      parameter_specified: boolean,
      str: ost$string,
      p_group_ctl_blk: ^group_ctl_blk,
      p_metric_ctl_blk: ^metric_ctl_blk,
      p_metric_list: ^metric_list,
      p_old_metric_list: ^metric_list;


    clp$scan_parameter_list (subcommand_parameters, defm_pdt, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

    { set up the metric control block. }

    clp$get_value ('METRIC', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

    str.value := parameter_value.name.value;
    str.size := parameter_value.name.size;
    p_metric_ctl_blk := NIL;
    find_metric (str.value (1, max_name_size), p_metric_ctl_blk);

    IF p_metric_ctl_blk <> NIL THEN
      osp$set_status_abnormal (pmc$external_log_management_id, pme$redefined_metric, str.value (1, str.size),
            subcommand_status);
      RETURN;
    IFEND;

    ALLOCATE p_metric_ctl_blk;

    { Initialize the contents of the metric control block. }

    p_metric_ctl_blk^.name := str.value (1, max_name_size);
    p_metric_ctl_blk^.metric_type := undefined_metric;
    p_metric_ctl_blk^.time_stamp_needed := FALSE;
    p_metric_ctl_blk^.p_report_ctl_blk := NIL;

    clp$get_value ('GROUP', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    p_metric_ctl_blk^.group_name := parameter_value.name.value;

    { Process the SCALE_FACTOR parameter. }

    clp$get_value ('SCALE_FACTOR', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    IF parameter_value.kind <> clc$unknown_value THEN
      p_metric_ctl_blk^.scale_factor := parameter_value.int.value;
    ELSE
      p_metric_ctl_blk^.scale_factor := 1;
    IFEND;

    { Process the UNIT parameter. }

    clp$get_value ('UNIT', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    IF parameter_value.kind <> clc$unknown_value THEN
      p_metric_ctl_blk^.unit := parameter_value.str.value;
    ELSE
      p_metric_ctl_blk^.unit := ' ';
    IFEND;

    { Process the COUNTER parameter. }

    clp$get_value ('COUNTER', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    IF parameter_value.kind <> clc$unknown_value THEN
      IF p_metric_ctl_blk^.metric_type <> undefined_metric THEN
        osp$set_status_abnormal (pmc$external_log_management_id, pme$too_many_metric_types, p_metric_ctl_blk^.
              name, subcommand_status);
        RETURN;
      ELSE
        p_metric_ctl_blk^.metric_type := counter_metric;
        p_metric_ctl_blk^.counter_number := parameter_value.int.value;
      IFEND;
    IFEND;

    { Process the EXPRESSION parameter. }

    clp$get_value ('EXPRESSION', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    IF parameter_value.kind <> clc$unknown_value THEN
      IF parameter_value.str.value (1) <> '1' THEN
        osp$set_status_abnormal (pmc$external_log_management_id, pme$bad_expression, str.value,
              subcommand_status);
        RETURN;
      IFEND;
      p_metric_ctl_blk^.metric_type := expression_metric;
    IFEND;

    { Process the INCREMENTAL parameter. }

    clp$get_value ('INCREMENTAL', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
       RETURN;
    IFEND;
    p_metric_ctl_blk^.incremental := parameter_value.bool.value;
    p_metric_ctl_blk^.first_element := TRUE;

    { Make sure that a metric type has been specified. }

    IF p_metric_ctl_blk^.metric_type = undefined_metric THEN
      osp$set_status_abnormal (pmc$external_log_management_id, pme$no_metric_type, p_metric_ctl_blk^.name,
            subcommand_status);
      RETURN;
    IFEND;

    p_metric_ctl_blk^.metric_chain_link := metric_chain_head;
    metric_chain_head := p_metric_ctl_blk;

  PROCEND defm_subcommand;
?? EJECT, TITLE := 'PROCEDURE diss_subcommand' ??

  PROCEDURE diss_subcommand (subcommand_parameters: clt$parameter_list;
    VAR subcommand_status: ost$status);

?? RIGHT := 110 ??
{ PDT diss_pdt (
{   metric, m: NAME = $REQUIRED
{   title, t: STRING
{   display_statistic, ds: LIST OF KEY NUM MEAN MIN MAX VARIANCE INTERVAL SUM ALL = ALL
{   interval_value, iv: INTEGER = 0
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    diss_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^diss_pdt_names, ^diss_pdt_params];

  VAR
    diss_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 8] of
      clt$parameter_name_descriptor := [['METRIC', 1], ['M', 1], ['TITLE', 2], ['T', 2], ['DISPLAY_STATISTIC'
      , 3], ['DS', 3], ['INTERVAL_VALUE', 4], ['IV', 4]];

  VAR
    diss_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor := [

{ METRIC M }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ TITLE T }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, osc$max_string_size
      ]],

{ DISPLAY_STATISTIC DS }
    [[clc$optional_with_default, ^diss_pdt_dv3], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [^
      diss_pdt_kv3, clc$keyword_value]],

{ INTERVAL_VALUE IV }
    [[clc$optional_with_default, ^diss_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, -9223372036854775806, 9223372036854775807]]];

  VAR
    diss_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 8] of ost$name := ['NUM','MEAN','MIN'
      ,'MAX','VARIANCE','INTERVAL','SUM','ALL'];

  VAR
    diss_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'ALL';

  VAR
    diss_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

?? POP ??

    VAR
      p_report_ctl_blk: ^report_ctl_blk,
      parameter_value: clt$value,
      display_count: 0 .. clc$max_value_sets,
      index: integer,
      str: ost$string,
      parameter_specified: boolean;

    clp$scan_parameter_list (subcommand_parameters, diss_pdt, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

    { Set up the report control block, but do not yet link it into the chain. }
    ALLOCATE p_report_ctl_blk;
    p_report_ctl_blk^.report_type := summary_report;

    clp$get_value ('METRIC', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    str.value := parameter_value.name.value;
    str.size := parameter_value.name.size;
    p_report_ctl_blk^.metric_name := str.value (1, max_name_size);

    { Process the TITLE parameter. }

    clp$get_value ('TITLE', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    IF parameter_value.kind <> clc$unknown_value THEN
      p_report_ctl_blk^.title := parameter_value.str;
    ELSE
      p_report_ctl_blk^.title := str;
    IFEND;

    { Process the DISPLAY_STATISTIC parameter. }

     p_report_ctl_blk^.num := FALSE;
     p_report_ctl_blk^.mean := FALSE;
     p_report_ctl_blk^.min := FALSE;
     p_report_ctl_blk^.max := FALSE;
     p_report_ctl_blk^.variance := FALSE;
     p_report_ctl_blk^.interval := FALSE;
     p_report_ctl_blk^.sum := FALSE;

     clp$get_set_count ('DISPLAY_STATISTIC', display_count, subcommand_status);
     IF NOT subcommand_status.normal THEN
        RETURN;
     IFEND;
     /display_loop/
        FOR index := 1 to display_count DO
            clp$get_value ('DISPLAY_STATISTIC', index, 1, clc$low, parameter_value,
                            subcommand_status);
            IF NOT subcommand_status.normal THEN
               RETURN;
            IFEND;
            IF parameter_value.name.value = 'ALL' THEN
               p_report_ctl_blk^.num := TRUE;
               p_report_ctl_blk^.mean := TRUE;
               p_report_ctl_blk^.min := TRUE;
               p_report_ctl_blk^.max := TRUE;
               p_report_ctl_blk^.variance := TRUE;
               p_report_ctl_blk^.interval := TRUE;
               p_report_ctl_blk^.sum := TRUE;
               EXIT /display_loop/
            ELSEIF parameter_value.name.value = 'NUM' THEN
               p_report_ctl_blk^.num := TRUE;
            ELSEIF parameter_value.name.value = 'MEAN' THEN
               p_report_ctl_blk^.mean := TRUE;
            ELSEIF parameter_value.name.value = 'MIN' THEN
               p_report_ctl_blk^.min := TRUE;
            ELSEIF parameter_value.name.value = 'MAX' THEN
               p_report_ctl_blk^.max := TRUE;
            ELSEIF parameter_value.name.value = 'VARIANCE' THEN
               p_report_ctl_blk^.variance := TRUE;
            ELSEIF parameter_value.name.value = 'INTERVAL' THEN
               p_report_ctl_blk^.interval := TRUE;
            ELSEIF parameter_value.name.value = 'SUM' THEN
               p_report_ctl_blk^.sum := TRUE;
          IFEND;
     FOREND /display_loop/;

    { Process the INTERVAL_VALUE parameter. }

    clp$get_value ('INTERVAL_VALUE', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
       RETURN;
    IFEND;
    p_report_ctl_blk^.interval_value := parameter_value.int.value;

    { link the report control block into the chain. }
    link_report (p_report_ctl_blk);

  PROCEND diss_subcommand;

?? EJECT, TITLE := 'PROCEDURE disd_subcommand' ??

  PROCEDURE disd_subcommand (subcommand_parameters: clt$parameter_list;
    VAR subcommand_status: ost$status);

{ PDT disd_pdt (
{   metric, m:  NAME = $REQUIRED
{   title, t:  STRING
{   limit, limits, l:  LIST 2, 2 OF INTEGER
{   display_option, do: KEY max_min_bound, first_max_centered,
{                         second_max_centered = max_min_bound
{   x_interval, xi: KEY self_adjust, large, medium, small = self_adjust
{   )


?? PUSH (LIST := OFF) ??

    VAR
      disd_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^disd_pdt_names, ^disd_pdt_params];

    VAR
      disd_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 11] of
        clt$parameter_name_descriptor := [['METRIC', 1], ['M', 1], ['TITLE', 2], ['T', 2], ['LIMIT', 3], [
        'LIMITS', 3], ['L', 3], ['DISPLAY_OPTION', 4], ['DO', 4], ['X_INTERVAL', 5], ['XI', 5]];

    VAR
      disd_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of clt$parameter_descriptor := [

{ METRIC M }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ TITLE T }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0,
        osc$max_string_size]],

{ LIMIT LIMITS L }
      [[clc$optional], 1, 2, 2, 2, clc$value_range_not_allowed, [NIL, clc$integer_value, - 281474976710655,
        281474976710655]],

{ DISPLAY_OPTION  DO }
      [[clc$optional_with_default, ^disd_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [^disd_pdt_kv4,
        clc$keyword_value]],

{  X_INTERVAL  XI  }
      [[clc$optional_with_default, ^disd_pdt_dv5], 1, 1, 1, 1, clc$value_range_not_allowed, [^disd_pdt_kv5,
        clc$keyword_value]]];

    VAR
      disd_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (13) := 'MAX_MIN_BOUND';

    VAR
      disd_pdt_kv4: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of ost$name := ['MAX_MIN_BOUND',
        'FIRST_MAX_CENTERED', 'SECOND_MAX_CENTERED'];

    VAR
      disd_pdt_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (11) := 'SELF_ADJUST';

    VAR
      disd_pdt_kv5: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := ['SELF_ADJUST',
        'LARGE', 'MEDIUM', 'SMALL'];

?? POP ??

    VAR
      do_keyword_array: [STATIC, READ] array [display_types] of string (19) := ['MAX_MIN_BOUND      ',
        'FIRST_MAX_CENTERED ', 'SECOND_MAX_CENTERED'];

    VAR
      xi_keyword_array: [STATIC, READ] array [interval_types] of string (11) := ['SELF_ADJUST', 'LARGE      ',
        'MEDIUM     ', 'SMALL      '];

    VAR
      msg_line: string (80),
      p_report_ctl_blk: ^report_ctl_blk,
      parameter_value: clt$value,
      str: ost$string,
      parameter_specified: boolean,
      display_index: display_types,
      interval_index: interval_types,
      set_count: 0 .. clc$max_value_sets;

    clp$scan_parameter_list (subcommand_parameters, disd_pdt, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

    { Set up the report control block, but do not yet link it into the chain. }
    ALLOCATE p_report_ctl_blk;
    p_report_ctl_blk^.report_type := distribution_report;

    clp$get_value ('METRIC', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    str.value := parameter_value.name.value;
    str.size := parameter_value.name.size;
    p_report_ctl_blk^.metric_name := str.value (1, max_name_size);

    { Process the TITLE parameter. }

    clp$get_value ('TITLE', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    IF parameter_value.kind <> clc$unknown_value THEN
      p_report_ctl_blk^.title := parameter_value.str;
    ELSE
      p_report_ctl_blk^.title := str;
    IFEND;

    { Process the LIMIT parameter. }

    p_report_ctl_blk^.x_low_limit := - 1;
    p_report_ctl_blk^.x_high_limit := - 1;
    p_report_ctl_blk^.cnt_low_limit := - 1;
    p_report_ctl_blk^.cnt_high_limit := - 1;

    clp$test_parameter ('LIMIT', parameter_specified, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    IF parameter_specified THEN
      clp$get_set_count ('LIMIT', set_count, subcommand_status);
      IF NOT subcommand_status.normal THEN
        RETURN;
      IFEND;
      IF set_count > 0 THEN
        clp$get_value ('LIMIT', 1, 1, clc$low, parameter_value, subcommand_status);
        IF NOT subcommand_status.normal THEN
          RETURN;
        IFEND;
        p_report_ctl_blk^.x_low_limit := parameter_value.int.value;
        clp$get_value ('LIMIT', 1, 2, clc$low, parameter_value, subcommand_status);
        IF NOT subcommand_status.normal THEN
          RETURN;
        IFEND;
        p_report_ctl_blk^.x_high_limit := parameter_value.int.value;
        IF set_count > 1 THEN
          clp$get_value ('LIMIT', 2, 1, clc$low, parameter_value, subcommand_status);
          IF NOT subcommand_status.normal THEN
            RETURN;
          IFEND;
          p_report_ctl_blk^.cnt_low_limit := parameter_value.int.value;
          clp$get_value ('LIMIT', 2, 2, clc$low, parameter_value, subcommand_status);
          IF NOT subcommand_status.normal THEN
            RETURN;
          IFEND;
          p_report_ctl_blk^.cnt_high_limit := parameter_value.int.value;
        IFEND;
      IFEND;
    IFEND;

    clp$get_value ('DISPLAY_OPTION', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

  /identify_display/
    FOR display_index := max_min_bound TO second_max_centered DO
      IF do_keyword_array [display_index] (1, parameter_value.name.size) = parameter_value.name.value (1,
            parameter_value.name.size) THEN
        p_report_ctl_blk^.display_option := display_index;
        EXIT /identify_display/;
      IFEND;
    FOREND /identify_display/;

    clp$get_value ('X_INTERVAL', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

  /identify_interval/
    FOR interval_index := self_adjust TO small DO
      IF xi_keyword_array [interval_index] (1, parameter_value.name.size) = parameter_value.name.value (1,
            parameter_value.name.size) THEN
        p_report_ctl_blk^.x_interval := interval_index;
        EXIT /identify_interval/;
      IFEND;
    FOREND /identify_interval/;

    { link the report control block into the chain. }
    link_report (p_report_ctl_blk);

  PROCEND disd_subcommand;
?? EJECT, TITLE := 'PROCEDURE disls_subcommand' ??

  PROCEDURE disls_subcommand (subcommand_parameters: clt$parameter_list;
    VAR subcommand_status: ost$status);

{ PDT disls_pdt (
{   output, o: FILE = $OUTPUT
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    disls_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^disls_pdt_names, ^disls_pdt_params
      ];

  VAR
    disls_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of
      clt$parameter_name_descriptor := [['OUTPUT', 1], ['O', 1]];

  VAR
    disls_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ OUTPUT O }
    [[clc$optional_with_default, ^disls_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]]];

  VAR
    disls_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??

    VAR
      parameter_value: clt$value,
      saved: amt$file_identifier,
      output_access_array: [STATIC, READ] array [1..1] of amt$access_selection := [[amc$file_contents,
        amc$list]];

      clp$scan_parameter_list (subcommand_parameters, disls_pdt, subcommand_status);
      IF NOT subcommand_status.normal THEN
         RETURN;
      IFEND;

      {process the output parameter}
      clp$get_value ('OUTPUT', 1, 1, clc$low, parameter_value, subcommand_status);
      IF NOT subcommand_status.normal THEN
         RETURN;
      IFEND;

      p_log_blk := log_chain_head;
      saved := output_file;

      {open the output file}
      amp$open (parameter_value.file.local_file_name, amc$record, ^output_access_array, output_file,
                subcommand_status);
         check_status (subcommand_status);

      {open the input file}
      amp$open (p_log_blk^.log_file_name, amc$record, p_access_array, input_file, subcommand_status);
         check_status (subcommand_status);

      emit_statistics_report;

      amp$close (output_file, subcommand_status);
         check_status (subcommand_status);
      output_file := saved;
      amp$close (input_file, subcommand_status);
         check_status (subcommand_status);

  PROCEND  disls_subcommand;
?? EJECT, TITLE := 'PROCEDURE distd_subcommand' ??

  PROCEDURE distd_subcommand (subcommand_parameters: clt$parameter_list;
    VAR subcommand_status: ost$status);


?? RIGHT := 110 ??
{
{ pdt distd_pdt(
{   metric, m: name = $required
{   metric_limits, ml: list 2..2 of integer  = $required
{   title, t: string)

?? PUSH (LISTEXT := ON) ??

    VAR
      distd_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^distd_pdt_names,
        ^distd_pdt_params];

    VAR
      distd_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
        clt$parameter_name_descriptor := [['METRIC', 1], ['M', 1], ['METRIC_LIMITS', 2], ['ML', 2], ['TITLE',
        3], ['T', 3]];

    VAR
      distd_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ METRIC M }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ METRIC_LIMITS ML }
      [[clc$required], 2, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, - 281474976710655,
        281474976710655]],

{ TITLE T }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0,
        osc$max_string_size]]];

?? POP ??

    VAR
      p_report_ctl_blk: ^report_ctl_blk,
      parameter_value: clt$value,
      str: ost$string;


    clp$scan_parameter_list (subcommand_parameters, distd_pdt, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE p_report_ctl_blk;
    p_report_ctl_blk^.report_type := time_distribution_report;

    clp$get_value ('METRIC', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

    str.value := parameter_value.name.value;
    str.size := parameter_value.name.size;
    p_report_ctl_blk^.metric_name := str.value;


    clp$get_value ('TITLE', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

    IF parameter_value.kind <> clc$unknown_value THEN
      p_report_ctl_blk^.title := parameter_value.str;
    ELSE
      p_report_ctl_blk^.title := str;
    IFEND;

    clp$get_value ('METRIC_LIMITS', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

    p_report_ctl_blk^.metric_low_limit := parameter_value.int.value;

    clp$get_value ('METRIC_LIMITS', 2, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

    p_report_ctl_blk^.metric_high_limit := parameter_value.int.value;

    IF p_report_ctl_blk^.metric_high_limit < p_report_ctl_blk^.metric_low_limit THEN
      osp$set_status_abnormal (pmc$external_log_management_id, pme$bad_high_low_limit,
        'METRIC HIGH/LOW LIMITS ARE INCORRECT', subcommand_status);
      RETURN;
    IFEND;

    link_report (p_report_ctl_blk);

  PROCEND distd_subcommand;

?? EJECT, TITLE := 'PROCEDURE disdd_subcommand' ??

  PROCEDURE disdd_subcommand (subcommand_parameters: clt$parameter_list;
    VAR subcommand_status: ost$status);


{ PDT disdd_pdt (
{   group, g: NAME = $REQUIRED
{   title, t: STRING
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      disdd_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^disdd_pdt_names,
        ^disdd_pdt_params];

    VAR
      disdd_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
        clt$parameter_name_descriptor := [['GROUP', 1], ['G', 1], ['TITLE', 2], ['T', 2]];

    VAR
      disdd_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ GROUP G }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ TITLE T }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0,
        osc$max_string_size]]];

?? POP ??

    VAR
      parameter_value: clt$value,
      parameter_specified: boolean,
      str: ost$string,
      p_report_ctl_blk: ^report_ctl_blk;

    clp$scan_parameter_list (subcommand_parameters, disdd_pdt, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

{  Set up the report control block, but do not link it into the chain yet.  }

    ALLOCATE p_report_ctl_blk;
    p_report_ctl_blk^.report_type := datades_report;

{  Process the GROUP parameter  }
    clp$get_value ('GROUP', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    str.value := parameter_value.name.value;
    str.size := parameter_value.name.size;
    p_report_ctl_blk^.group_name := str.value (1, str.size);

{  Process the TITLE parameter  }

    clp$get_value ('TITLE', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    IF parameter_value.kind <> clc$unknown_value THEN
      p_report_ctl_blk^.title := parameter_value.str;
    ELSE
      p_report_ctl_blk^.title := str;
    IFEND;

    link_report (p_report_ctl_blk);

  PROCEND disdd_subcommand;

?? EJECT, TITLE := 'PROCEDURE dumg_subcommand' ??

  PROCEDURE dumg_subcommand (subcommand_parameters: clt$parameter_list;
    VAR subcommand_status: ost$status);

?? RIGHT := 110 ??
{ PDT dumg_pdt (
{   group, g:  NAME = $REQUIRED
{   counter_format, cf: list 1..255, 1..2 range of integer 1..255
{   title, t:  STRING
{     )

?? PUSH (LISTEXT := ON) ??

    VAR
      dumg_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^dumg_pdt_names, ^dumg_pdt_params];

    VAR
      dumg_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
        clt$parameter_name_descriptor := [['GROUP', 1], ['G', 1], ['COUNTER_FORMAT', 2], ['CF', 2], ['TITLE',
        3], ['T', 3]];

    VAR
      dumg_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ GROUP G }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ COUNTER_FORMAT CF }
      [[clc$optional], 1, 255, 1, 2, clc$value_range_allowed, [NIL, clc$integer_value, 1, 255]],

{ TITLE T }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0,
        osc$max_string_size]]];

?? POP ??

    CONST
      default_radix = 10;

    VAR
      high_counter_value: 1 .. sfc$max_number_of_counters,
      i: 0 .. sfc$max_number_of_counters,
      j: 0 .. sfc$max_number_of_counters,
      low_counter_value: 1 .. sfc$max_number_of_counters,
      p_report_ctl_blk: ^report_ctl_blk,
      parameter_value: clt$value,
      parameter_specified: boolean,
      radix: 8 .. 16,
      set_count: 0 .. clc$max_value_sets,
      str: ost$string;

    clp$scan_parameter_list (subcommand_parameters, dumg_pdt, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

    { Set up the report control block, but do not yet link it
    { into the report chain. }

    ALLOCATE p_report_ctl_blk;
    p_report_ctl_blk^.report_type := dump_report;

    { Process the GROUP parameter. }

    clp$get_value ('GROUP', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    str.value := parameter_value.name.value;
    str.size := parameter_value.name.size;
    p_report_ctl_blk^.group_name := str.value (1, str.size);

    { Process the COUNTER_FORMAT parameter}

    FOR i := 1 TO sfc$max_number_of_counters DO
      p_report_ctl_blk^.counter_radix [i] := default_radix;
    FOREND;

    clp$get_set_count ('COUNTER_FORMAT', set_count, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO set_count DO
      clp$get_value ('COUNTER_FORMAT', i, 1, clc$low, parameter_value, subcommand_status);
      IF NOT subcommand_status.normal THEN
        RETURN;
      IFEND;
      low_counter_value := parameter_value.int.value;

      clp$get_value ('COUNTER_FORMAT', i, 1, clc$high, parameter_value, subcommand_status);
      IF NOT subcommand_status.normal THEN
        RETURN;
      IFEND;
      high_counter_value := parameter_value.int.value;

      clp$get_value ('COUNTER_FORMAT', i, 2, clc$low, parameter_value, subcommand_status);
      IF NOT subcommand_status.normal THEN
        RETURN;
      IFEND;
      CASE parameter_value.int.value OF
      = 8, 10, 16 =
        radix := parameter_value.int.value;
      ELSE
        osp$set_status_abnormal ('CL', cle$integer_out_of_range, '', subcommand_status);
        osp$append_status_integer (osc$status_parameter_delimiter, parameter_value.int.value, parameter_value.
              int.radix, parameter_value.int.radix_specified, subcommand_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, ' for COUNTER_FORMAT radix',
              subcommand_status);
        RETURN;
      CASEND;

      FOR j := low_counter_value TO high_counter_value DO
        p_report_ctl_blk^.counter_radix [j] := radix;
      FOREND;

    FOREND;

    { Process the TITLE parameter. }

    clp$get_value ('TITLE', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    IF parameter_value.kind <> clc$unknown_value THEN
      p_report_ctl_blk^.title := parameter_value.str;
    ELSE
      p_report_ctl_blk^.title := str;
    IFEND;


    link_report (p_report_ctl_blk);

  PROCEND dumg_subcommand;
?? EJECT, TITLE := 'PROCEDURE gengf_subcommand' ??

  PROCEDURE gengf_subcommand (subcommand_parameters: clt$parameter_list;
    VAR subcommand_status: ost$status);

{ PDT gengf_pdt (
{   group, g: NAME = $REQUIRED
{   output, o: FILE = $OUTPUT
{     )

?? PUSH (LISTEXT := ON) ??

    VAR
      gengf_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^gengf_pdt_names,
        ^gengf_pdt_params];

    VAR
      gengf_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
        clt$parameter_name_descriptor := [['GROUP', 1], ['G', 1], ['OUTPUT', 2], ['O', 2]];

    VAR
      gengf_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ GROUP G }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ OUTPUT O }
      [[clc$optional_with_default, ^gengf_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$file_value]]];

    VAR
      gengf_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??

    VAR
      p_report_ctl_blk: ^report_ctl_blk,
      parameter_value: clt$value,
      parameter_specified: boolean,
      str: ost$string;

    clp$scan_parameter_list (subcommand_parameters, gengf_pdt, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;

{  Set up the report control block, but do not yet link it
{  into the report chain.

    ALLOCATE p_report_ctl_blk;
    p_report_ctl_blk^.report_type := gen_group_file;

{  Process the GROUP parameter.  }

    clp$get_value ('GROUP', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    p_report_ctl_blk^.group_name := parameter_value.name.value;

{  Process the OUTPUT parameter.  }

    clp$get_value ('OUTPUT', 1, 1, clc$low, parameter_value, subcommand_status);
    IF NOT subcommand_status.normal THEN
      RETURN;
    IFEND;
    p_report_ctl_blk^.file_name := parameter_value.file.local_file_name;

{  Process the PERMANENT parameter.  }
{  This parameter has been deleted and the value is now set to FALSE.  }

    p_report_ctl_blk^.permanent := FALSE;

    IF (p_report_ctl_blk^.permanent) AND (p_report_ctl_blk^.file_name = default_output) THEN
{  FREE p_report_ctl_blk;
      osp$set_status_abnormal (pmc$external_log_management_id, pme$output_permanent,
        ' $OUTPUT SHOULD NOT BE A PERMANENT FILE.', subcommand_status);
      RETURN;
    IFEND;

    IF (p_report_ctl_blk^.permanent) AND (local_name_conflict (p_report_ctl_blk^.file_name)) THEN
      FREE p_report_ctl_blk;
      osp$set_status_abnormal (pmc$external_log_management_id, pme$local_name_conflict,
        ' WHEN PARAMETER P=TRUE, PARAMETER O SHOULD NOT BE REDEFINED', subcommand_status);
      RETURN;
    IFEND;

    link_report (p_report_ctl_blk);

  PROCEND gengf_subcommand;
?? EJECT, TITLE := 'PROCEDURE qui_subcommand' ??

  PROCEDURE qui_subcommand (subcommand_parameters: clt$parameter_list;
    VAR status: ost$status);

{ PDT quit_pdt (
{   STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    quit_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^quit_pdt_names, ^quit_pdt_params];

  VAR
    quit_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
      clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    quit_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??


    clp$scan_parameter_list (subcommand_parameters, quit_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_scan_command_file ('DISPLAY_BINARY_LOG             ', status);

  PROCEND qui_subcommand;

MODEND lgm$display_binary_log;
*DECK DECK=LGM$GET_NEXT_STATISTIC EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Logging: Get Next Statistic Interfaces' ??
MODULE lgm$get_next_statistic;

{ PURPOSE:
{   This module contains the gated interfaces used to access the local and global logs.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc lge$corrupted_statistic
*copyc lge$end_of_log
*copyc lge$statistic_buffer_required
*copyc lgt$log_entry
*copyc lgt$log_entry_size
*copyc ost$caller_identifier
*copyc sft$statistic_buffer
*copyc sft$statistic_header
*copyc sft$counters
*copyc sft$descriptive_data
?? POP ??
*copyc i#move
*copyc lgp$get_next_log_entry
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
?? OLDTITLE, EJECT ??
?? NEWTITLE := '[XDCL, #GATE] lgp$get_next_statistic', EJECT ??
*copyc lgh$get_next_statistic

  PROCEDURE [XDCL, #GATE] lgp$get_next_statistic
    (    log_file_identifier: lgt$log_file_identifier;
         statistic_buffer_p: ^sft$statistic_buffer;
     VAR statistic_header_p: ^sft$statistic_header;
     VAR counters_p: sft$counters;
     VAR descriptive_data_p: ^sft$descriptive_data;
     VAR status: ost$status);

    VAR
      caller_identifier: ost$caller_identifier,
      local_log_data: ^SEQ ( * ),
      log_entry_p: ^lgt$log_entry,
      log_entry_size: lgt$log_entry_size;

    status.normal := TRUE;
    #CALLER_ID (caller_identifier);

{ Get the next statistic from the log.

    lgp$get_next_log_entry (log_file_identifier, statistic_buffer_p, log_entry_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Parse the statistic to get a pointer to the statistic header, counters and descriptive data.

    lgp$parse_statistic (log_entry_p, statistic_header_p, counters_p, descriptive_data_p, status);
    IF NOT status.normal THEN
      IF (status.condition = lge$statistic_buffer_required) AND (statistic_buffer_p <> NIL) THEN
        i#move (log_entry_p, statistic_buffer_p, #SIZE (log_entry_p^));
        lgp$parse_statistic (statistic_buffer_p, statistic_header_p, counters_p, descriptive_data_p,
               status);
      ELSE
        RETURN;
      IFEND;
    IFEND;

  PROCEND lgp$get_next_statistic;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$parse_statistic', EJECT ??
*copy lgh$parse_statistic

  PROCEDURE [XDCL, #GATE] lgp$parse_statistic
    (    log_entry_p: ^lgt$log_entry;
     VAR statistic_header_p: ^sft$statistic_header;
     VAR counters_p: sft$counters;
     VAR descriptive_data_p: ^sft$descriptive_data;
     VAR status: ost$status);

    VAR
      local_log_entry_p: ^lgt$log_entry;

?? NEWTITLE := 'parse_obsolete_statistic', EJECT ??
{ PURPOSE:
{   Converts an obsolete statistic to match the current statistic format and returns pointers to the
{   components of the statistic.

    PROCEDURE parse_obsolete_statistic
      (    log_entry_p: ^lgt$log_entry;
       VAR statistic_header_p: ^sft$statistic_header;
       VAR counters_p: sft$counters;
       VAR descriptive_data: ^sft$descriptive_data;
       VAR status: ost$status);

      TYPE
        sft$obsolete_statistic_header = record
          date_time: ost$date_time,
          statistic_code: sft$statistic_code,
          job_name: jmt$system_supplied_name,
          task_id: ost$global_task_id,
          number_of_counters: 0 .. 255,
          descriptive_data_size: 0 .. 255,
        recend;

      VAR
        local_log_entry_p: ^lgt$log_entry,
        obsolete_statistic_buffer_p: ^sft$statistic_buffer,
        obsolete_statistic_header_p: ^sft$obsolete_statistic_header,
        obsolete_statistic_counters_p: sft$counters,
        obsolete_statistic_desc_data_p: ^sft$descriptive_data;

      status.normal := TRUE;

{ Make sure log entry is in a sequence that matches the size of the obsolete statistic buffer.

      IF #SIZE (log_entry_p^) < #SIZE (sft$statistic_buffer) THEN
        osp$set_status_abnormal ('LG', lge$statistic_buffer_required, 'LGP$PARSE_STATISTIC', status);
        RETURN;
      IFEND;

      local_log_entry_p := log_entry_p;
      RESET local_log_entry_p;
      PUSH obsolete_statistic_buffer_p;
      obsolete_statistic_buffer_p^ := log_entry_p^;
      RESET obsolete_statistic_buffer_p;

{ Get a pointer to the obsolete statistic header.

      NEXT obsolete_statistic_header_p IN obsolete_statistic_buffer_p;
      IF obsolete_statistic_header_p = NIL THEN
        osp$set_status_condition (lge$corrupted_statistic, status);
        RETURN;
      IFEND;

{ Translate the obsolete statistic header into the current format for the statistic header.

      NEXT statistic_header_p IN local_log_entry_p;
      IF statistic_header_p = NIL THEN
        osp$set_status_condition (lge$corrupted_statistic, status);
        RETURN;
      IFEND;
      statistic_header_p^.version := sfc$statistic_version;
      statistic_header_p^.date_time := obsolete_statistic_header_p^.date_time;
      statistic_header_p^.statistic_code := obsolete_statistic_header_p^.statistic_code;
      statistic_header_p^.job_name := obsolete_statistic_header_p^.job_name;
      statistic_header_p^.task_id := obsolete_statistic_header_p^.task_id;
      statistic_header_p^.number_of_counters := obsolete_statistic_header_p^.number_of_counters;
      statistic_header_p^.descriptive_data_size := obsolete_statistic_header_p^.descriptive_data_size;

{ Get a pointer to the counters (if there are any).

      IF statistic_header_p^.number_of_counters <> 0 THEN
        NEXT obsolete_statistic_counters_p: [1 .. statistic_header_p^.number_of_counters] IN
              obsolete_statistic_buffer_p;
        IF obsolete_statistic_counters_p = NIL THEN
          osp$set_status_condition (lge$corrupted_statistic, status);
          RETURN;
        IFEND;
        NEXT counters_p: [1 .. statistic_header_p^.number_of_counters] IN local_log_entry_p;
        IF counters_p = NIL THEN
          osp$set_status_condition (lge$corrupted_statistic, status);
          RETURN;
        IFEND;
        counters_p^ := obsolete_statistic_counters_p^;
      ELSE
        counters_p := NIL;
      IFEND;

{ Get a pointer to the descriptive data.

      IF statistic_header_p^.descriptive_data_size <> 0 THEN
        NEXT obsolete_statistic_desc_data_p: [statistic_header_p^.descriptive_data_size] IN
              obsolete_statistic_buffer_p;
        IF obsolete_statistic_desc_data_p = NIL THEN
          osp$set_status_condition (lge$corrupted_statistic, status);
          RETURN;
        IFEND;
        NEXT descriptive_data_p: [statistic_header_p^.descriptive_data_size] IN local_log_entry_p;
        IF descriptive_data_p = NIL THEN
          osp$set_status_condition (lge$corrupted_statistic, status);
          RETURN;
        IFEND;
        descriptive_data_p^ := obsolete_statistic_desc_data_p^;
      ELSE
        descriptive_data_p := NIL;
      IFEND;

    PROCEND parse_obsolete_statistic;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    local_log_entry_p := log_entry_p;
    RESET local_log_entry_p;

{ Get a pointer to the statistic header.  If the log entry is not large enough to hold a statistic header
{ it must be an old style statistic.

    NEXT statistic_header_p IN local_log_entry_p;
    IF (statistic_header_p = NIL) OR (statistic_header_p^.version <> sfc$statistic_version) THEN
      parse_obsolete_statistic (log_entry_p, statistic_header_p, counters_p, descriptive_data_p, status);
    ELSE

{ Get a pointer to the counters (if there are any).

      IF statistic_header_p^.number_of_counters <> 0 THEN
        NEXT counters_p: [1 .. statistic_header_p^.number_of_counters] IN local_log_entry_p;
        IF counters_p = NIL THEN
          osp$set_status_condition (lge$corrupted_statistic, status);
          RETURN;
        IFEND;
      ELSE
        counters_p := NIL;
      IFEND;

{ Get a pointer to the descriptive data.

      IF statistic_header_p^.descriptive_data_size <> 0 THEN
        NEXT descriptive_data_p: [statistic_header_p^.descriptive_data_size] IN local_log_entry_p;
        IF descriptive_data_p = NIL THEN
          osp$set_status_condition (lge$corrupted_statistic, status);
          RETURN;
        IFEND;
      ELSE
        descriptive_data_p := NIL;
      IFEND;
    IFEND;

  PROCEND lgp$parse_statistic;
?? OLDTITLE ??
MODEND lgm$get_next_statistic;
*DECK DECK=LGM$GLOBAL_LOG_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Logging: Global Log Manager' ??
MODULE lgm$global_log_manager;

{ PURPOSE:
{   This module contains the code used to manage the global logs.
{
{ DESIGN:
{   The global logs are permanent files that are opened during deadstart and added to the job template so
{   that each job inherits access to the logs (each job is not required to attach and open them).  Information
{   about each global log is kept in the log's corresponding log control descriptor (LCD).
{
{   Access to a log is interlocked via a mainframe signature lock (contained in the log's LCD) and all global
{   log accesses eventually find their way to procedures in this module.  There are file entries that appear
{   in the $LOCAL catalog for each job that represent the global logs, but these files entries have a FAP
{   associated with them that calls the interfaces in this module.
{
{   The maximum size and critical flag for each log are defined as system attributes that have their values
{   copied into the appropriate LCD.  The global log manager uses these attributes to make sure that disk
{   space for the log is always preallocated and that the appropriate action is taken when the system is not
{   able to record an entry in a global log (e.g., the disks are full or a disk goes down).

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmt$error_condition_codes
*copyc dsc$system_log_file_size
*copyc lgc$default_preallocation_size
*copyc lge$corrupted_log
*copyc lge$end_of_log
*copyc lge$incorrect_move_length
*copyc lge$log_cycles_do_not_match
*copyc lge$log_not_available
*copyc lgt$critical_log_control_desc
*copyc lgt$entry_info
*copyc lgt$log_attribute_entry
*copyc lgt$log_read_activity
*copyc osd$virtual_address
*copyc oss$mainframe_pageable
*copyc oss$mainframe_paged_literal
*copyc pmt$global_binary_logs
*copyc pmt$global_logs
*copyc pmt$log_msg_origin
*copyc pmt$log_msg_text
*copyc pmt$logs
*copyc pmt$system_log_entry
?? POP ??
*copyc clp$trimmed_string_size
*copyc dpp$put_critical_message
*copyc dmp$attach_device_file
*copyc dmp$create_device_file
*copyc dmp$destroy_device_file
*copyc dmp$open_file
*copyc dmp$set_eoi
*copyc dmp$trim_file
*copyc gfp$get_segment_sfid
*copyc i#build_adaptable_seq_pointer
*copyc i#current_sequence_position
*copyc i#move
*copyc jmp$update_job_template_sdt
*copyc lgp$add_critical_log_entry
*copyc lgp$add_log_entry
*copyc lgp$get_critical_log_entry
*copyc lgp$get_critical_read_info
*copyc lgp$get_log_entry
*copyc lgp$get_log_read_information
*copyc lgp$get_previous_crit_log_size
*copyc lgp$get_previous_log_entry_size
*copyc mmp$change_seg_inheritance_r1
*copyc mmp$validate_segment_number
*copyc mmp$write_modified_pages
*copyc osp$clear_mainframe_sig_lock
*copyc osp$fatal_system_error
*copyc osp$initialize_sig_lock
*copyc osp$monitor_fault_to_status
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$get_job_names
*copyc pmp$get_time
*copyc syp$disestablish_cond_handler
*copyc syp$establish_condition_handler
*copyc dmv$system_device_information
*copyc dpv$critical_messages
*copyc dpv$critical_msgs_need_logging
*copyc lgv$critical_log_attributes
*copyc lgv$global_log_attributes
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module.', EJECT ??

{ The following translation table is used to remove the control codes from an ascii log entry before it is
{ placed in the log.  Unlike OSV$CONTROL_CODES_TO_QUEST_MARK, this table allows the top 128 ASCII charcters to
{ get through.

  VAR
    lgv$control_codes_to_quest_mark: [XDCL, #GATE, READ, oss$mainframe_paged_literal] string (256) :=
          '????????????' CAT '???????????????????? !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTU' CAT
          'VWXYZ[\]^_`abcdefghijkl' CAT 'mnopqrstuvwxyz{|}~?' CAT $CHAR (128) CAT $CHAR (129) CAT
          $CHAR (130) CAT $CHAR (131) CAT $CHAR (132) CAT $CHAR (133) CAT $CHAR (134) CAT $CHAR (135) CAT
          $CHAR (136) CAT $CHAR (137) CAT $CHAR (138) CAT $CHAR (139) CAT $CHAR (140) CAT $CHAR (141) CAT
          $CHAR (142) CAT $CHAR (143) CAT $CHAR (144) CAT $CHAR (145) CAT $CHAR (146) CAT $CHAR (147) CAT
          $CHAR (148) CAT $CHAR (149) CAT $CHAR (150) CAT $CHAR (151) CAT $CHAR (152) CAT $CHAR (153) CAT
          $CHAR (154) CAT $CHAR (155) CAT $CHAR (156) CAT $CHAR (157) CAT $CHAR (158) CAT $CHAR (159) CAT
          $CHAR (160) CAT $CHAR (161) CAT $CHAR (162) CAT $CHAR (163) CAT $CHAR (164) CAT $CHAR (165) CAT
          $CHAR (166) CAT $CHAR (167) CAT $CHAR (168) CAT $CHAR (169) CAT $CHAR (170) CAT $CHAR (171) CAT
          $CHAR (172) CAT $CHAR (173) CAT $CHAR (174) CAT $CHAR (175) CAT $CHAR (176) CAT $CHAR (177) CAT
          $CHAR (178) CAT $CHAR (179) CAT $CHAR (180) CAT $CHAR (181) CAT $CHAR (182) CAT $CHAR (183) CAT
          $CHAR (184) CAT $CHAR (185) CAT $CHAR (186) CAT $CHAR (187) CAT $CHAR (188) CAT $CHAR (189) CAT
          $CHAR (190) CAT $CHAR (191) CAT $CHAR (192) CAT $CHAR (193) CAT $CHAR (194) CAT $CHAR (195) CAT
          $CHAR (196) CAT $CHAR (197) CAT $CHAR (198) CAT $CHAR (199) CAT $CHAR (200) CAT $CHAR (201) CAT
          $CHAR (202) CAT $CHAR (203) CAT $CHAR (204) CAT $CHAR (205) CAT $CHAR (206) CAT $CHAR (207) CAT
          $CHAR (208) CAT $CHAR (209) CAT $CHAR (210) CAT $CHAR (211) CAT $CHAR (212) CAT $CHAR (213) CAT
          $CHAR (214) CAT $CHAR (215) CAT $CHAR (216) CAT $CHAR (217) CAT $CHAR (218) CAT $CHAR (219) CAT
          $CHAR (220) CAT $CHAR (221) CAT $CHAR (222) CAT $CHAR (223) CAT $CHAR (224) CAT $CHAR (225) CAT
          $CHAR (226) CAT $CHAR (227) CAT $CHAR (228) CAT $CHAR (229) CAT $CHAR (230) CAT $CHAR (231) CAT
          $CHAR (232) CAT $CHAR (233) CAT $CHAR (234) CAT $CHAR (235) CAT $CHAR (236) CAT $CHAR (237) CAT
          $CHAR (238) CAT $CHAR (239) CAT $CHAR (240) CAT $CHAR (241) CAT $CHAR (242) CAT $CHAR (243) CAT
          $CHAR (244) CAT $CHAR (245) CAT $CHAR (246) CAT $CHAR (247) CAT $CHAR (248) CAT $CHAR (249) CAT
          $CHAR (250) CAT $CHAR (251) CAT $CHAR (252) CAT $CHAR (253) CAT $CHAR (254) CAT $CHAR (255);

?? FMT (FORMAT := OFF) ??
  VAR
    lgv$global_log_ctl: [XDCL, #GATE, oss$mainframe_pageable] array [pmt$global_logs] of
          lgt$log_control_descriptor := [
          [*, pmc$account_log,       0, NIL, NIL, lgc$maximum_log_size,
                lgc$default_preallocation_size, FALSE, 0, FALSE],
          [*, pmc$engineering_log,   0, NIL, NIL, lgc$maximum_log_size,
                lgc$default_preallocation_size, FALSE, 0, FALSE],
          [*, pmc$history_log,       0, NIL, NIL, lgc$maximum_log_size,
                lgc$default_preallocation_size, FALSE, 0, FALSE],
          [*, pmc$security_log,      0, NIL, NIL, lgc$maximum_log_size,
                lgc$default_preallocation_size, FALSE, 0, FALSE],
          [*, pmc$statistic_log,     0, NIL, NIL, lgc$maximum_log_size,
                lgc$default_preallocation_size, FALSE, 0, FALSE],
          [*, pmc$system_log,        0, NIL, NIL, lgc$maximum_log_size,
                lgc$default_preallocation_size, FALSE, 0, FALSE]];

  VAR
    lgv$critical_log_ctl: [XDCL, #GATE, oss$mainframe_pageable] lgt$critical_log_control_desc := [
          *, 0, NIL, NIL, lgc$maximum_log_size,
          lgc$default_preallocation_size, FALSE, 0, FALSE];
?? FMT (FORMAT := ON) ??

  VAR
    lgv$log_names: [XDCL, #GATE, READ, oss$mainframe_paged_literal] array [pmt$logs] of
          ost$name := ['$JOB_ACCOUNT_LOG', '$JOB_STATISTIC_LOG', '$ACCOUNT_LOG', '$ENGINEERING_LOG',
          '$HISTORY_LOG', '$SECURITY_LOG', '$STATISTIC_LOG', '$SYSTEM_LOG', '$JOB_LOG'];

  VAR
    lgv$critical_log_name: [XDCL, #GATE, READ, oss$mainframe_paged_literal] ost$name :=
          '$CRITICAL_WINDOW_LOG';

  VAR
    lgv$origin_codes: [XDCL, #GATE, READ, oss$mainframe_paged_literal] array [pmt$log_msg_origin] of
          string (2) := ['CI', 'SY', 'PR', 'CS', 'RC'];

  VAR
    lgv$recovery_log_sfid: [XDCL, #GATE, oss$mainframe_pageable] dmt$system_file_id;

?? OLDTITLE ??
?? NEWTITLE := 'find_end_of_log', EJECT ??

  PROCEDURE find_end_of_log
    (    log_name: ost$name;
     VAR sequence_pointer: ^SEQ ( * );
     VAR trailing_log_entry_header_p: ^lgt$log_entry_header;
     VAR status: ost$status);

    VAR
      log_entry_p: ^lgt$log_entry,
      previous_log_entry_header_p: ^lgt$log_entry_header;

    status.normal := TRUE;

{ Get the first log entry header.

    RESET sequence_pointer;
    NEXT trailing_log_entry_header_p IN sequence_pointer;
    IF trailing_log_entry_header_p = NIL THEN
      osp$set_status_abnormal ('LG', lge$corrupted_log, log_name, status);
      RETURN;
    IFEND;
    trailing_log_entry_header_p^.previous_size := 0;

{ Find the end of the log.

    WHILE trailing_log_entry_header_p^.current_size <> 0 DO

{ Get the next log entry.

      NEXT log_entry_p: [[REP trailing_log_entry_header_p^.current_size OF cell]] IN sequence_pointer;
      IF log_entry_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$corrupted_log, log_name, status);
        RETURN;
      IFEND;

{ Get the next log entry header.

      previous_log_entry_header_p := trailing_log_entry_header_p;
      NEXT trailing_log_entry_header_p IN sequence_pointer;
      IF trailing_log_entry_header_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$corrupted_log, log_name, status);
        RETURN;
      IFEND;

{ If the log entry header is not consistent with the previous log entry header, the previous log entry header
{ is used as the end of the log.

      IF trailing_log_entry_header_p^.previous_size <> previous_log_entry_header_p^.current_size THEN
        RESET sequence_pointer TO log_entry_p;
        trailing_log_entry_header_p := previous_log_entry_header_p;
        trailing_log_entry_header_p^.current_size := 0;
        RETURN;
      IFEND;
    WHILEND;

  PROCEND find_end_of_log;
?? OLDTITLE ??
?? NEWTITLE := 'handle_lost_entry', EJECT ??
{ PURPOSE:
{   Deal with the loss of a log entry in the manner defined by the site.

  PROCEDURE handle_lost_entry
    (    log_control_descriptor_p: ^lgt$log_control_descriptor;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      message_length: integer,
      message_string: ost$string;

    IF log_control_descriptor_p^.critical_log THEN

{ If this is a critical log, the the system must be terminated when a log entry is lost.

      message_string.value := 'Unable to record messages in ';
      message_string.value (clp$trimmed_string_size (message_string.value) + 2, * ) :=
            lgv$log_names [log_control_descriptor_p^.log];
      message_string.size := clp$trimmed_string_size (message_string.value);
      message_string.value (message_string.size + 1) := '.';
      message_string.size := message_string.size + 1;
      osp$fatal_system_error (message_string.value (1, message_string.size), ^status);
    ELSE

{ If this is not a critical log and the log data pointer is not NIL, increment the lost message count in the
{ log control descriptor and tell the operator the first time a message is lost (or every 1000 messages).

      log_control_descriptor_p^.lost_message_count := log_control_descriptor_p^.lost_message_count + 1;
      IF (log_control_descriptor_p^.log_data <> NIL) AND
            (log_control_descriptor_p^.lost_message_count = 1) OR
            ((log_control_descriptor_P^.lost_message_count MOD 1000) = 0) THEN
        message_string.value := 'Losing messages sent to ';
        message_string.value (clp$trimmed_string_size (message_string.value) + 2, * ) :=
              lgv$log_names [log_control_descriptor_p^.log];
        message_string.size := clp$trimmed_string_size (message_string.value);
        message_string.value (message_string.size + 1) := '.';
        message_string.size := message_string.size + 1;
        dpp$put_critical_message (message_string.value (1, message_string.size), ignore_status);
        IF NOT status.normal THEN
          IF status.condition = lge$log_full THEN
            stringrep(message_string.value, message_length,
                  ' The ', lgv$log_names [log_control_descriptor_p^.log] (1,
                  clp$trimmed_string_size (lgv$log_names [log_control_descriptor_p^.log])),
                  ' is full, execute the TERMINATE_LOG command to clear the log.');
          ELSEIF status.condition = dme$unable_to_alloc_all_space THEN
            stringrep(message_string.value, message_length,
                  ' The system set is out of mass storage class K (system permanent file)',
                  ' space.  Logging cannot occur without class K space.  Please make ',
                  ' more class K space available by deleting files on the class K devices ',
                  ' or by adding class K to another device on the system set.');
          ELSE

{ An unexpected status occurred, display the condition in the critical window.

            stringrep(message_string.value, message_length,
                  ' Logging to ', lgv$log_names [log_control_descriptor_p^.log] (1,
                  clp$trimmed_string_size (lgv$log_names [log_control_descriptor_p^.log])),
                  ' failed with status: ', status.condition,
                  ', execute DISPLAY_VALUE $STATUS_CODE_NAME({condition}) to see the status code');
          IFEND;
          dpp$put_critical_message (message_string.value (1, message_length), ignore_status);
        IFEND;
      IFEND;
      status.normal := TRUE;
    IFEND;

  PROCEND handle_lost_entry;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$add_entry_global_binary_log', EJECT ??
*copy lgh$add_entry_global_binary_log

  PROCEDURE [XDCL, #GATE] lgp$add_entry_global_binary_log
    (    global_binary_log: pmt$global_binary_logs;
         entry_p: ^lgt$log_entry;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      length: integer,
      msg: string(osc$max_string_size),
      log_control_descriptor_p: ^lgt$log_control_descriptor;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Make sure that the log interlock is cleared in the event of an error.

    PROCEDURE condition_handler
      (    monitor_fault: ost$monitor_fault;
           save_area: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      VAR
        local_status: ost$status,
        length: integer,
        msg: string(osc$max_string_size);

      osp$monitor_fault_to_status (monitor_fault, save_area, local_status);
      handle_lost_entry (log_control_descriptor_p, local_status);
      osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
      EXIT lgp$add_entry_global_binary_log;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Get a pointer to the appropriate log control descriptor.

    log_control_descriptor_p := ^lgv$global_log_ctl [global_binary_log];
    #SPOIL (log_control_descriptor_p);

{ Interlock the log.

    osp$set_mainframe_sig_lock (log_control_descriptor_p^.lock);
    syp$establish_condition_handler (^condition_handler);

{ Add the entry to the log.  If everything works correctly, reset the lost message counter in the log
{ control descriptor.  If an error occurs, handle the loss of the entry in the manner defined by site
{ for this log.

    lgp$add_log_entry (entry_p, log_control_descriptor_p, status);
    IF status.normal THEN
      log_control_descriptor_p^.lost_message_count := 0;
    ELSE
      handle_lost_entry (log_control_descriptor_p, status);
    IFEND;

{ Clear the log interlock.

    osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
    syp$disestablish_cond_handler;

  PROCEND lgp$add_entry_global_binary_log;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$add_entry_to_critical_log', EJECT ??
*copy lgh$add_entry_to_critical_log

  PROCEDURE [XDCL, #GATE] lgp$add_entry_to_critical_log
    (    text: pmt$log_msg_text;
     VAR status: ost$status);

    VAR
      dummy_sdte_p: ^mmt$segment_descriptor,
      dummy_sdtxe_p: ^mmt$segment_descriptor_extended,
      log_control_descriptor_p: ^lgt$critical_log_control_desc,
      critical_log_entry_p: ^pmt$log_msg_text,
      system_supplied_name: jmt$system_supplied_name,
      text_size: lgt$log_entry_size,
      user_supplied_name: jmt$user_supplied_name;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Make sure that the log interlock is cleared in the event of an error.

    PROCEDURE condition_handler
      (    monitor_fault: ost$monitor_fault;
           save_area: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      VAR
        local_status: ost$status;

      osp$monitor_fault_to_status (monitor_fault, save_area, local_status);
      log_control_descriptor_p^.lost_message_count := log_control_descriptor_p^.lost_message_count + 1;
      osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
      EXIT lgp$add_entry_to_critical_log;

    PROCEND condition_handler;
?? NEWTITLE := 'update_critical_messages', EJECT ??

{ PURPOSE:
{   This procedure updates the critical message variable so the message can be logged in the critical log.

  PROCEDURE update_critical_messages (
    message: string(*);
    size: integer);

    VAR
      msg_index: 1..16,
      prev_msg_index: 1..16;

    msg_index := 1;
    While (msg_index < 16) AND (dpv$critical_messages [msg_index].size <> 0) DO
      msg_index := msg_index + 1;
    WHILEND;
    IF msg_index < 16 THEN
      dpv$critical_messages [msg_index].value := message;
      dpv$critical_messages [msg_index].size := size;
    ELSE
      msg_index := 2;
      prev_msg_index := 1;
      WHILE msg_index < 16 DO
        dpv$critical_messages [prev_msg_index].value := dpv$critical_messages [msg_index].value;
        dpv$critical_messages [prev_msg_index].size := dpv$critical_messages [msg_index].size;
        msg_index := msg_index + 1;
        prev_msg_index := prev_msg_index + 1;
      WHILEND;
      dpv$critical_messages [15].value := message;
      dpv$critical_messages [15].size := size;
    IFEND;
    dpv$critical_msgs_need_logging := TRUE;
  PROCEND update_critical_messages;
?? OLDTITLE ??
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

{ Get a pointer to the critical log control descriptor.

    log_control_descriptor_p := ^lgv$critical_log_ctl;
    #SPOIL (log_control_descriptor_p);

{ Validate that you can write into segment 18(16) (critical window log), device management tasks
{ cannot write into this segment (it does not exist in these tasks).

    mmp$validate_segment_number ({segment_number =} 18(16), dummy_sdte_p, dummy_sdtxe_p, status);
    IF NOT status.normal THEN
      update_critical_messages (text, STRLENGTH(text));
      RETURN;
    IFEND;

{ Interlock the log.

    osp$set_mainframe_sig_lock (log_control_descriptor_p^.lock);
    syp$establish_condition_handler (^condition_handler);

{ Format the critical window log entry.

    text_size := STRLENGTH (text);
    PUSH critical_log_entry_p: [text_size];

    #TRANSLATE (lgv$control_codes_to_quest_mark, text, critical_log_entry_p^);

{ Add the entry to the log.  If everything works correctly, reset the lost message counter in the log
{ control descriptor.  If an error occurs, handle the loss of the entry in the manner defined by site
{ for this log.

    lgp$add_critical_log_entry (#SEQ (critical_log_entry_p^), log_control_descriptor_p, status);
    IF status.normal THEN
      log_control_descriptor_p^.lost_message_count := 0;
    ELSE
      log_control_descriptor_p^.lost_message_count := log_control_descriptor_p^.lost_message_count + 1;
    IFEND;

{ Clear the log interlock.

    osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
    syp$disestablish_cond_handler;

  PROCEND lgp$add_entry_to_critical_log;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$add_entry_to_system_log', EJECT ??
*copy lgh$add_entry_to_system_log

  PROCEDURE [XDCL, #GATE] lgp$add_entry_to_system_log
    (    origin: pmt$log_msg_origin;
         text: pmt$log_msg_text;
     VAR log_time: ost$time;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      log_control_descriptor_p: ^lgt$log_control_descriptor,
      length: integer,
      msg: string(osc$max_string_size),
      system_log_entry_p: ^pmt$system_log_entry,
      system_supplied_name: jmt$system_supplied_name,
      text_size: lgt$log_entry_size,
      user_supplied_name: jmt$user_supplied_name;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Make sure that the log interlock is cleared in the event of an error.

    PROCEDURE condition_handler
      (    monitor_fault: ost$monitor_fault;
           save_area: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      VAR
        ignore_status: ost$status,
        length: integer,
        local_status: ost$status,
        msg: string(osc$max_string_size);

      osp$monitor_fault_to_status (monitor_fault, save_area, local_status);
      handle_lost_entry (log_control_descriptor_p, local_status);
      osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
      EXIT lgp$add_entry_to_system_log;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

{ Get a pointer to the appropriate log control descriptor.

    log_control_descriptor_p := ^lgv$global_log_ctl [pmc$system_log];
    #SPOIL (log_control_descriptor_p);

{ Interlock the log.

    osp$set_mainframe_sig_lock (log_control_descriptor_p^.lock);
    syp$establish_condition_handler (^condition_handler);

  /log_locked/
    BEGIN

{ Get the time stamp and job name for the log message.

      pmp$get_time (osc$millisecond_time, log_time, status);
      IF NOT status.normal THEN
        EXIT /log_locked/;
      IFEND;

      pmp$get_job_names (user_supplied_name, system_supplied_name, status);
      IF NOT status.normal THEN
        EXIT /log_locked/;
      IFEND;

{ Format the system log entry.

      text_size := lgc$maximum_log_entry_size - #SIZE (pmt$system_log_entry: [0]);
      IF STRLENGTH (text) < text_size THEN
        text_size := STRLENGTH (text);
      IFEND;
      PUSH system_log_entry_p: [text_size];

      system_log_entry_p^.time := log_time.millisecond;
      system_log_entry_p^.delimiter_1 (1) := '.';
      system_log_entry_p^.job_sequence_number := system_supplied_name;
      system_log_entry_p^.delimiter_2 (1) := '.';
      system_log_entry_p^.origin := lgv$origin_codes [origin];
      system_log_entry_p^.delimiter_3 (1) := '.';
      #TRANSLATE (lgv$control_codes_to_quest_mark, text, system_log_entry_p^.text);

{ Add the entry to the log.  If everything works correctly, reset the lost message counter in the log
{ control descriptor.  If an error occurs, handle the loss of the entry in the manner defined by site
{ for this log.

      lgp$add_log_entry (#SEQ (system_log_entry_p^), log_control_descriptor_p, status);
      IF status.normal THEN
        log_control_descriptor_p^.lost_message_count := 0;
      ELSE
        handle_lost_entry (log_control_descriptor_p, status);
      IFEND;
    END /log_locked/;

{ Clear the log interlock.

    osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
    syp$disestablish_cond_handler;

  PROCEND lgp$add_entry_to_system_log;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$get_critical_log_read_info', EJECT ??
*copy lgh$get_critical_log_read_info

  PROCEDURE [XDCL, #GATE] lgp$get_critical_log_read_info
     (   entry_count_from_end_of_log: ost$segment_length;
     VAR log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR ending_offset: amt$file_byte_address;
     VAR status: ost$status);

    VAR
      log_control_descriptor_p: ^lgt$critical_log_control_desc;

    status.normal := TRUE;

{ Get a pointer to the critical window log control descriptor.

    log_control_descriptor_p := ^lgv$critical_log_ctl;

{ Get the appropriate values from the log control descriptor.

    lgp$get_critical_read_info (log_control_descriptor_p, entry_count_from_end_of_log, log_cycle,
          log_data, ending_offset, status);

  PROCEND lgp$get_critical_log_read_info;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$get_entry_from_critical_log', EJECT ??
*copy lgh$get_entry_from_critical_log

  PROCEDURE [XDCL, #GATE] lgp$get_entry_from_critical_log
     (   log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR log_entry_size: lgt$log_entry_size;
     VAR log_entry: lgt$log_entry;
     VAR status: ost$status);

    VAR
      log_control_descriptor_p: ^lgt$critical_log_control_desc;

    status.normal := TRUE;

{ Get a pointer to the critical window log control descriptor.

    log_control_descriptor_p := ^lgv$critical_log_ctl;

{ Get a copy of the next log entry.

    lgp$get_critical_log_entry (log_cycle, log_control_descriptor_p, log_data, log_entry_size,
          log_entry, status);

  PROCEND lgp$get_entry_from_critical_log;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$get_entry_from_global_log', EJECT ??
*copy lgh$get_entry_from_global_log

  PROCEDURE [XDCL, #GATE] lgp$get_entry_from_global_log
    (    global_log: pmt$global_logs;
         log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR log_entry_size: lgt$log_entry_size;
     VAR log_entry: lgt$log_entry;
     VAR status: ost$status);

    VAR
      log_control_descriptor_p: ^lgt$log_control_descriptor;

    status.normal := TRUE;

{ Get a pointer to the appropriate log control descriptor.

    log_control_descriptor_p := ^lgv$global_log_ctl [global_log];

{ Get a copy of the next log entry.

    lgp$get_log_entry (log_cycle, log_control_descriptor_p, log_data, log_entry_size, log_entry, status);

  PROCEND lgp$get_entry_from_global_log;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$get_global_log_read_info', EJECT ??
*copy lgh$get_global_log_read_info

  PROCEDURE [XDCL, #GATE] lgp$get_global_log_read_info
    (    global_log: pmt$global_logs;
         entry_count_from_end_of_log: ost$segment_length;
     VAR log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR ending_offset: amt$file_byte_address;
     VAR status: ost$status);

    VAR
      log_control_descriptor_p: ^lgt$log_control_descriptor;

    status.normal := TRUE;

{ Get a pointer to the appropriate log control descriptor.

    log_control_descriptor_p := ^lgv$global_log_ctl [global_log];

{ Get the appropriate values from the log control descriptor.

    lgp$get_log_read_information (log_control_descriptor_p, entry_count_from_end_of_log, log_cycle, log_data,
          ending_offset, status);

  PROCEND lgp$get_global_log_read_info;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$get_critical_previous_size', EJECT ??

  PROCEDURE [XDCL, #GATE] lgp$get_critical_previous_size
    (    log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR previous_size: lgt$log_entry_size;
     VAR status: ost$status);

    VAR
      log_control_descriptor_p: ^lgt$critical_log_control_desc;

    status.normal := TRUE;

{ Get a pointer to the critical window log control descriptor.

    log_control_descriptor_p := ^lgv$critical_log_ctl;

{ Get the size of the previous log entry.

    lgp$get_previous_crit_log_size (log_cycle, log_control_descriptor_p, log_data, previous_size, status);

  PROCEND lgp$get_critical_previous_size;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$get_global_previous_size', EJECT ??

  PROCEDURE [XDCL, #GATE] lgp$get_global_previous_size
    (    global_log: pmt$global_logs;
         log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR previous_size: lgt$log_entry_size;
     VAR status: ost$status);

    VAR
      log_control_descriptor_p: ^lgt$log_control_descriptor;

    status.normal := TRUE;

{ Get a pointer to the appropriate log control descriptor.

    log_control_descriptor_p := ^lgv$global_log_ctl [global_log];

{ Get the size of the previous log entry.

    lgp$get_previous_log_entry_size (log_cycle, log_control_descriptor_p, log_data, previous_size, status);

  PROCEND lgp$get_global_previous_size;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$initialize_critical_log_lcd', EJECT ??
*copy lgh$initialize_critical_log_lcd

  PROCEDURE [XDCL, #GATE] lgp$initialize_critical_log_lcd
     (   log: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      ending_offset: amt$file_byte_address,
      log_control_descriptor_p: ^lgt$critical_log_control_desc,
      log_entry_p: ^lgt$log_entry,
      log_entry_header_p: ^lgt$log_entry_header,
      previous_log_entry_header_p: ^lgt$log_entry_header,
      sequence_pointer: ^SEQ ( * );

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Return an error to the caller if a condition occurs.

    PROCEDURE condition_handler
      (    monitor_fault: ost$monitor_fault;
           save_area: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$monitor_fault_to_status (monitor_fault, save_area, status);
      EXIT lgp$initialize_critical_log_lcd;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

{ Get a pointer to the critical window log control descriptor.

    log_control_descriptor_p := ^lgv$critical_log_ctl;

    syp$establish_condition_handler (^condition_handler);

{ Find the end of the log.

    sequence_pointer := log;
    find_end_of_log (lgv$critical_log_name, sequence_pointer, log_entry_header_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    ending_offset := i#current_sequence_position (sequence_pointer);

{ Initialize the critical window log control descriptor fields.

    osp$initialize_sig_lock (log_control_descriptor_p^.lock);
    log_control_descriptor_p^.log_cycle := LOWERVALUE (log_control_descriptor_p^.log_cycle);
    i#build_adaptable_seq_pointer (#RING (sequence_pointer), #SEGMENT (sequence_pointer),
          #OFFSET (sequence_pointer), ending_offset, ending_offset, log_control_descriptor_p^.log_data);
    log_control_descriptor_p^.trailing_log_entry_header_p := log_entry_header_p;
    log_control_descriptor_p^.maximum_size := lgv$critical_log_attributes.maximum_size * 1000000;
    log_control_descriptor_p^.preallocation_size := lgv$critical_log_attributes.preallocation_size;
    log_control_descriptor_p^.lost_message_count := 0;

{ If the log is more than 75% full, do not set the critical log indicator.  The operator will be required to
{ terminate the log before deadstart completes and terminate log will set the critical flag if necessary.

    IF ending_offset > ((log_control_descriptor_p^.maximum_size * 3) DIV 4) THEN
      log_control_descriptor_p^.critical_log := FALSE;
    ELSE
      log_control_descriptor_p^.critical_log := lgv$critical_log_attributes.critical;
    IFEND;

    syp$disestablish_cond_handler;

{ Add the log segment to the job template.

    jmp$update_job_template_sdt (log, status);

  PROCEND lgp$initialize_critical_log_lcd;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$initialize_global_log_lcd', EJECT ??
*copy lgh$initialize_global_log_lcd

  PROCEDURE [XDCL, #GATE] lgp$initialize_global_log_lcd
    (    global_log: pmt$global_logs;
         log: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      ending_offset: amt$file_byte_address,
      log_control_descriptor_p: ^lgt$log_control_descriptor,
      log_entry_p: ^lgt$log_entry,
      log_entry_header_p: ^lgt$log_entry_header,
      previous_log_entry_header_p: ^lgt$log_entry_header,
      sequence_pointer: ^SEQ ( * );

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Return an error to the caller if a condition occurs.

    PROCEDURE condition_handler
      (    monitor_fault: ost$monitor_fault;
           save_area: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$monitor_fault_to_status (monitor_fault, save_area, status);
      EXIT lgp$initialize_global_log_lcd;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

{ Get a pointer to the log control descriptor.

    log_control_descriptor_p := ^lgv$global_log_ctl [global_log];

    syp$establish_condition_handler (^condition_handler);

{ Find the end of the log.

    sequence_pointer := log;
    find_end_of_log (lgv$log_names [global_log], sequence_pointer, log_entry_header_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    ending_offset := i#current_sequence_position (sequence_pointer);

{ Initialize the log control descriptor fields.

    osp$initialize_sig_lock (log_control_descriptor_p^.lock);
    log_control_descriptor_p^.log := global_log;
    log_control_descriptor_p^.log_cycle := LOWERVALUE (log_control_descriptor_p^.log_cycle);
    i#build_adaptable_seq_pointer (#RING (sequence_pointer), #SEGMENT (sequence_pointer),
          #OFFSET (sequence_pointer), ending_offset, ending_offset, log_control_descriptor_p^.log_data);
    log_control_descriptor_p^.trailing_log_entry_header_p := log_entry_header_p;
    log_control_descriptor_p^.maximum_size := lgv$global_log_attributes [global_log].maximum_size * 1000000;
    log_control_descriptor_p^.preallocation_size := lgv$global_log_attributes [global_log].preallocation_size;
    log_control_descriptor_p^.lost_message_count := 0;

{ If the log is more than 75% full, do not set the critical log indicator.  The operator will be required to
{ terminate the log before deadstart completes and terminate log will set the critical flag if necessary.

    IF ending_offset > ((log_control_descriptor_p^.maximum_size * 3) DIV 4) THEN
      log_control_descriptor_p^.critical_log := FALSE;
    ELSE
      log_control_descriptor_p^.critical_log := lgv$global_log_attributes [global_log].critical;
    IFEND;

    syp$disestablish_cond_handler;

{ Add the log segment to the job template.

    jmp$update_job_template_sdt (log, status);

  PROCEND lgp$initialize_global_log_lcd;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$release_critical_log_space', EJECT ??
*copy lgh$release_critical_log_space

  PROCEDURE [XDCL, #GATE] lgp$release_critical_log_space
     (   log_cycle: lgt$log_cycle;
         first_log_entry_header_p: ^lgt$log_entry_header;
     VAR status: ost$status);

    VAR
      log_control_descriptor_p: ^lgt$critical_log_control_desc,
      log_entry_header: ^lgt$log_entry_header,
      system_file_id: dmt$system_file_id,
      new_eoi: ost$segment_offset,
      move_length: ost$relative_pointer;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Make sure that the log interlock is cleared in the event of an error.

    PROCEDURE condition_handler
      (    monitor_fault: ost$monitor_fault;
           save_area: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
      osp$monitor_fault_to_status (monitor_fault, save_area, status);
      EXIT lgp$release_critical_log_space;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Get a pointer to the critical window log control descriptor.

    log_control_descriptor_p := ^lgv$critical_log_ctl;
    #SPOIL (log_control_descriptor_p);

{ Interlock the log.

    osp$set_mainframe_sig_lock (log_control_descriptor_p^.lock);
    syp$establish_condition_handler (^condition_handler);

  /log_locked/
    BEGIN

{ Verify that the specified log cycle matches the actual log cycle.

      IF log_cycle <> log_control_descriptor_p^.log_cycle THEN
        osp$set_status_abnormal ('LG', lge$log_cycles_do_not_match, lgv$critical_log_name, status);
        EXIT /log_locked/;
      IFEND;

{ If the first log entry header pointer is not NIL move the log entries that need to be saved to the
{ beginning.  Otherwise set up the log to contain only the first log entry header (an empty log).

      IF first_log_entry_header_p <> NIL THEN

{ Compute the amount of data that must be moved (i.e., the log entries that have been added since log
{ termination began).

        move_length := i#current_sequence_position (log_control_descriptor_p^.log_data) -
              #OFFSET (first_log_entry_header_p);
        IF move_length < #SIZE (lgt$log_entry_header) THEN
          osp$set_status_abnormal ('LG', lge$incorrect_move_length, lgv$critical_log_name, status);
          EXIT /log_locked/;
        IFEND;

{ Reset the previous size entry in the first log entry header.

        first_log_entry_header_p^.previous_size := 0;

{ Move the data to the beginning of the log.

        i#move (first_log_entry_header_p, log_control_descriptor_p^.log_data, move_length);

{ Force the updated pages to disk.

        mmp$write_modified_pages (log_control_descriptor_p^.log_data,
              i#current_sequence_position (log_control_descriptor_p^.log_data), osc$wait, status);
        IF NOT status.normal THEN
          EXIT /log_locked/;
        IFEND;

{ Construct a new log data pointer that points to a sequence that matches the amount of data left in the log.

        i#build_adaptable_seq_pointer (#RING (log_control_descriptor_p^.log_data),
              #SEGMENT (log_control_descriptor_p^.log_data), #OFFSET (log_control_descriptor_p^.log_data),
              { size = } move_length, { current position = } move_length, log_control_descriptor_p^.log_data);

{ Construct a pointer to the trailing log entry header.

        log_control_descriptor_p^.trailing_log_entry_header_p :=
              #ADDRESS (#RING (log_control_descriptor_p^.log_data),
              #SEGMENT (log_control_descriptor_p^.log_data), move_length - #SIZE (lgt$log_entry_header));
      ELSE

{ Set up the log data sequence to be an empty log.

        move_length := #SIZE (lgt$log_entry_header);
        i#build_adaptable_seq_pointer (#RING (log_control_descriptor_p^.log_data),
              #SEGMENT (log_control_descriptor_p^.log_data), #OFFSET (log_control_descriptor_p^.log_data),
              { size = } move_length, { current position = } 0, log_control_descriptor_p^.log_data);
        RESET log_control_descriptor_p^.log_data;
        NEXT log_control_descriptor_p^.trailing_log_entry_header_p IN log_control_descriptor_p^.log_data;
        IF log_control_descriptor_p^.trailing_log_entry_header_p = NIL THEN
          osp$set_status_abnormal ('LG', lge$corrupted_log, lgv$critical_log_name, status);
          EXIT /log_locked/;
        IFEND;
        log_control_descriptor_p^.trailing_log_entry_header_p^.previous_size := 0;
        log_control_descriptor_p^.trailing_log_entry_header_p^.current_size := 0;
      IFEND;

{ Release the unneeded disk space.

      new_eoi := move_length + 1;

      gfp$get_segment_sfid (log_control_descriptor_p^.log_data, system_file_id, status);
      IF NOT status.normal THEN
        EXIT /log_locked/;
      IFEND;

      dmp$set_eoi (system_file_id, new_eoi, status);
      IF NOT status.normal THEN
        EXIT /log_locked/;
      IFEND;

      dmp$trim_file (system_file_id, new_eoi, status);
      IF NOT status.normal THEN
        EXIT /log_locked/;
      IFEND;

{ Make sure the maximum size and critical log flags are set to the correct values.

      log_control_descriptor_p^.maximum_size := lgv$critical_log_attributes.maximum_size * 1000000;
      log_control_descriptor_p^.critical_log := lgv$critical_log_attributes.critical;

{ Reset the lost message count and log full indicator.

      log_control_descriptor_p^.lost_message_count := 0;
      log_control_descriptor_p^.log_full := FALSE;

{ Increment the log cycle (wrapping to zero if necessary).

      IF log_control_descriptor_p^.log_cycle = lgc$maximum_log_cycle THEN
        log_control_descriptor_p^.log_cycle := 0;
      ELSE
        log_control_descriptor_p^.log_cycle := log_control_descriptor_p^.log_cycle + 1;
      IFEND;

    END /log_locked/;

{ Clear the log interlock.

    osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
    syp$disestablish_cond_handler;

  PROCEND lgp$release_critical_log_space;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$release_global_log_space', EJECT ??
*copy lgh$release_global_log_space

  PROCEDURE [XDCL, #GATE] lgp$release_global_log_space
    (    global_log: pmt$global_logs;
         log_cycle: lgt$log_cycle;
         first_log_entry_header_p: ^lgt$log_entry_header;
     VAR status: ost$status);

    VAR
      log_control_descriptor_p: ^lgt$log_control_descriptor,
      log_entry_header: ^lgt$log_entry_header,
      system_file_id: dmt$system_file_id,
      new_eoi: ost$segment_offset,
      move_length: ost$relative_pointer;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Make sure that the log interlock is cleared in the event of an error.

    PROCEDURE condition_handler
      (    monitor_fault: ost$monitor_fault;
           save_area: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
      osp$monitor_fault_to_status (monitor_fault, save_area, status);
      EXIT lgp$release_global_log_space;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Get a pointer to the log control_descriptor.

    log_control_descriptor_p := ^lgv$global_log_ctl [global_log];
    #SPOIL (log_control_descriptor_p);

{ Interlock the log.

    osp$set_mainframe_sig_lock (log_control_descriptor_p^.lock);
    syp$establish_condition_handler (^condition_handler);

  /log_locked/
    BEGIN

{ Verify that the specified log cycle matches the actual log cycle.

      IF log_cycle <> log_control_descriptor_p^.log_cycle THEN
        osp$set_status_abnormal ('LG', lge$log_cycles_do_not_match, lgv$log_names [global_log], status);
        EXIT /log_locked/;
      IFEND;

{ If the first log entry header pointer is not NIL move the log entries that need to be saved to the
{ beginning.  Otherwise set up the log to contain only the first log entry header (an empty log).

      IF first_log_entry_header_p <> NIL THEN

{ Compute the amount of data that must be moved (i.e., the log entries that have been added since log
{ termination began).

        move_length := i#current_sequence_position (log_control_descriptor_p^.log_data) -
              #OFFSET (first_log_entry_header_p);
        IF move_length < #SIZE (lgt$log_entry_header) THEN
          osp$set_status_abnormal ('LG', lge$incorrect_move_length, lgv$log_names [global_log], status);
          EXIT /log_locked/;
        IFEND;

{ Reset the previous size entry in the first log entry header.

        first_log_entry_header_p^.previous_size := 0;

{ Move the data to the beginning of the log.

        i#move (first_log_entry_header_p, log_control_descriptor_p^.log_data, move_length);

{ Force the updated pages to disk.

        mmp$write_modified_pages (log_control_descriptor_p^.log_data,
              i#current_sequence_position (log_control_descriptor_p^.log_data), osc$wait, status);
        IF NOT status.normal THEN
          EXIT /log_locked/;
        IFEND;

{ Construct a new log data pointer that points to a sequence that matches the amount of data left in the log.

        i#build_adaptable_seq_pointer (#RING (log_control_descriptor_p^.log_data),
              #SEGMENT (log_control_descriptor_p^.log_data), #OFFSET (log_control_descriptor_p^.log_data),
              { size = } move_length, { current position = } move_length, log_control_descriptor_p^.log_data);

{ Construct a pointer to the trailing log entry header.

        log_control_descriptor_p^.trailing_log_entry_header_p :=
              #ADDRESS (#RING (log_control_descriptor_p^.log_data),
              #SEGMENT (log_control_descriptor_p^.log_data), move_length - #SIZE (lgt$log_entry_header));
      ELSE

{ Set up the log data sequence to be an empty log.

        move_length := #SIZE (lgt$log_entry_header);
        i#build_adaptable_seq_pointer (#RING (log_control_descriptor_p^.log_data),
              #SEGMENT (log_control_descriptor_p^.log_data), #OFFSET (log_control_descriptor_p^.log_data),
              { size = } move_length, { current position = } 0, log_control_descriptor_p^.log_data);
        RESET log_control_descriptor_p^.log_data;
        NEXT log_control_descriptor_p^.trailing_log_entry_header_p IN log_control_descriptor_p^.log_data;
        IF log_control_descriptor_p^.trailing_log_entry_header_p = NIL THEN
          osp$set_status_abnormal ('LG', lge$corrupted_log, lgv$log_names [log_control_descriptor_p^.log],
                status);
          EXIT /log_locked/;
        IFEND;
        log_control_descriptor_p^.trailing_log_entry_header_p^.previous_size := 0;
        log_control_descriptor_p^.trailing_log_entry_header_p^.current_size := 0;
      IFEND;

{ Release the unneeded disk space.

      new_eoi := move_length + 1;

      gfp$get_segment_sfid (log_control_descriptor_p^.log_data, system_file_id, status);
      IF NOT status.normal THEN
        EXIT /log_locked/;
      IFEND;

      dmp$set_eoi (system_file_id, new_eoi, status);
      IF NOT status.normal THEN
        EXIT /log_locked/;
      IFEND;

      dmp$trim_file (system_file_id, new_eoi, status);
      IF NOT status.normal THEN
        EXIT /log_locked/;
      IFEND;

{ Make sure the maximum size and critical log flags are set to the correct values.

      log_control_descriptor_p^.maximum_size := lgv$global_log_attributes [global_log].maximum_size * 1000000;
      log_control_descriptor_p^.critical_log := lgv$global_log_attributes [global_log].critical;

{ Reset the lost message count and log full indicator.

      log_control_descriptor_p^.lost_message_count := 0;
      log_control_descriptor_p^.log_full := FALSE;

{ Increment the log cycle (wrapping to zero if necessary).

      IF log_control_descriptor_p^.log_cycle = lgc$maximum_log_cycle THEN
        log_control_descriptor_p^.log_cycle := 0;
      ELSE
        log_control_descriptor_p^.log_cycle := log_control_descriptor_p^.log_cycle + 1;
      IFEND;

    END /log_locked/;

{ Clear the log interlock.

    osp$clear_mainframe_sig_lock (log_control_descriptor_p^.lock);
    syp$disestablish_cond_handler;

  PROCEND lgp$release_global_log_space;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$setup_recovery_logging', EJECT ??

{ PURPOSE:
{   The purpose of this request is to provide an environment in which system level logging may take place
{   prior to the availablility of permanent files.  This environment is established during system recovery.
{   The environment established by this request does not support system level binary logging.

  PROCEDURE [XDCL, #GATE] lgp$setup_recovery_logging
    (VAR status: ost$status);

    VAR
      file_attributes: array [1 .. 1] of dmt$new_device_file_attribute,
      log_time: ost$time,
      recorded_vsn: rmt$recorded_vsn,
      segment_pointer: mmt$segment_pointer,
      user_supplied_name: ost$name;

    status.normal := TRUE;

{ Open the device file used to hold the recovery log.

    user_supplied_name := 'LGF$SYSTEM_LOG';
    recorded_vsn := dmv$system_device_recorded_vsn;
    file_attributes [1].keyword := dmc$file_limit;
    file_attributes [1].limit := UPPERVALUE (amt$file_limit);

    dmp$attach_device_file (recorded_vsn, user_supplied_name, lgv$recovery_log_sfid, status);
    IF status.normal THEN
      segment_pointer.kind := mmc$sequence_pointer;
      dmp$open_file (lgv$recovery_log_sfid, 3, 3, mmc$sar_write_extend, mmc$as_random,
            segment_pointer, status);
    IFEND;

{ If an error occured while opening the device file, attempt to recreate the device file.  If the device file
{ cannot be recreated, deadstart will be allowed to continue without the recovery log being available.

    IF NOT status.normal THEN
      dmp$destroy_device_file (recorded_vsn, user_supplied_name, {ignore} status);
      status.normal := TRUE;
      dmp$create_device_file (user_supplied_name, recorded_vsn, ^file_attributes, dsc$system_log_file_size,
            lgv$recovery_log_sfid, status);
      IF NOT status.normal THEN
        status.normal := TRUE;
        RETURN;
      IFEND;
      dmp$open_file (lgv$recovery_log_sfid, 3, 3, mmc$sar_write_extend, mmc$as_random,
            segment_pointer, status);
      IF NOT status.normal THEN
        status.normal := TRUE;
        RETURN;
      IFEND;
    IFEND;
    mmp$change_seg_inheritance_r1 (#SEGMENT (segment_pointer.cell_pointer), 1, mmc$si_share_segment, status);

{ Initialize the log control descriptor.  The log control descriptor for the system log is used for the
{ recovery log.

    osp$initialize_sig_lock (lgv$global_log_ctl [pmc$system_log].lock);
    lgv$global_log_ctl [pmc$system_log].log_data := segment_pointer.seq_pointer;
    RESET lgv$global_log_ctl [pmc$system_log].log_data;

    find_end_of_log (user_supplied_name, lgv$global_log_ctl [pmc$system_log].
          log_data, lgv$global_log_ctl [pmc$system_log].trailing_log_entry_header_p, status);

  PROCEND lgp$setup_recovery_logging;
?? OLDTITLE ??
MODEND lgm$global_log_manager;
*DECK DECK=LGM$INTERNAL_LOGGING_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Logging: Internal Logging Interfaces' ??
MODULE lgm$internal_logging_interfaces;

{ PURPOSE:
{   This module contains the non-gated interfaces used to access the local and global logs.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$system_family
*copyc lgt$log_version
*copyc ost$heap
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$get_next
*copyc amp$put_next
*copyc clp$evaluate_file_reference
*copyc clp$put_job_output
*copyc clp$trimmed_string_size
*copyc dmp$close_file
*copyc dmp$detach_device_file
*copyc fsp$build_file_ref_from_elems
*copyc fsp$change_segment_number
*copyc fsp$close_file
*copyc fsp$open_file
*copyc i#current_sequence_position
*copyc lgp$add_entry_to_system_log
*copyc lgp$get_entry_from_global_log
*copyc lgp$get_entry_from_local_log
*copyc lgp$get_local_log_read_info
*copyc lgp$initialize_critical_log_lcd
*copyc lgp$initialize_global_log_lcd
*copyc lgp$release_critical_log_space
*copyc lgp$release_global_log_space
*copyc lgp$terminate_critical_log
*copyc lgp$terminate_log
*copyc mmp$invalidate_segment
*copyc mmp$set_access_selections
*copyc osp$generate_log_message
*copyc osp$generate_output_message
*copyc osp$system_error
*copyc pfp$purge
*copyc pmp$get_date
*copyc pmp$zero_out_table
*copyc clv$standard_files
*copyc lgv$critical_log_ctl
*copyc lgv$global_log_ctl
*copyc lgv$critical_log_name
*copyc lgv$log_names
*copyc lgv$recovery_log_sfid
*copyc osv$lower_to_upper
?? OLDTITLE ??
?? NEWTITLE := 'create_critical_window_log', EJECT ??

{ PURPOSE:
{   This procedure creates a new critical window log file.

  PROCEDURE [XDCL] create_critical_window_log
    (VAR status: ost$status);

    VAR
      attachment_options: ^fst$attachment_options,
      cycle_selector: pft$cycle_selector,
      file_identifier: amt$file_identifier,
      file_reference: fst$path,
      ignore_status: ost$status,
      log_entry_header_p: ^lgt$log_entry_header,
      mandated_creation_attributes: ^fst$file_cycle_attributes,
      path_p: ^pft$path,
      segment_pointer: amt$segment_pointer;

    status.normal := TRUE;

{ Purge the high cycle of the file (just to make sure nothing is in the way).

    PUSH path_p: [1 .. 3];
    path_p^ [1] := jmc$system_family;
    path_p^ [2] := jmc$system_user;
    path_p^ [3] := lgv$critical_log_name;
    cycle_selector.cycle_option := pfc$highest_cycle;
    pfp$purge (path_p^, cycle_selector, osc$null_name, ignore_status);

{ Create the permanent file that will contain the log.

    fsp$build_file_ref_from_elems (path_p, file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH attachment_options: [1 .. 1];
    attachment_options^ [1].selector := fsc$access_and_share_modes;
    attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options^ [1].access_modes.value := $fst$file_access_options
          [fsc$append, fsc$modify, fsc$shorten, fsc$read];
    attachment_options^ [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options^ [1].share_modes.value := $fst$file_access_options [];

    PUSH mandated_creation_attributes: [1 .. 3];
    mandated_creation_attributes^ [1].selector := fsc$ring_attributes;
    mandated_creation_attributes^ [1].ring_attributes.r1 := osc$tsrv_ring;
    mandated_creation_attributes^ [1].ring_attributes.r2 := osc$tsrv_ring;
    mandated_creation_attributes^ [1].ring_attributes.r3 := osc$tsrv_ring;
    mandated_creation_attributes^ [2].selector := fsc$file_contents_and_processor;
    mandated_creation_attributes^ [2].file_processor := fsc$unknown_processor;
    mandated_creation_attributes^ [2].file_contents := fsc$ascii_log;
    mandated_creation_attributes^ [3].selector := fsc$user_information;
    mandated_creation_attributes^ [3].user_information := lgc$log_version;

    fsp$open_file (file_reference, amc$segment, attachment_options, NIL, mandated_creation_attributes, NIL,
          NIL, file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Assign the log to the appropriate segment number.

    fsp$change_segment_number (file_identifier, (osc$segnum_first_global_log - 7), osc$tmtr_ring,
          amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Inform the system that the segment will be accessed sequentially.

    mmp$set_access_selections (segment_pointer.sequence_pointer, mmc$as_sequential, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Place the first log entry header in the log.

    NEXT log_entry_header_p IN segment_pointer.sequence_pointer;
    IF log_entry_header_p = NIL THEN
      osp$set_status_abnormal ('LG', lge$log_full, lgv$critical_log_name, status);
      RETURN;
    IFEND;
    log_entry_header_p^.previous_size := 0;
    log_entry_header_p^.current_size := 0;
    RESET segment_pointer.sequence_pointer;

{ Initialize the critical window log control descriptor.

    lgp$initialize_critical_log_lcd (segment_pointer.sequence_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND create_critical_window_log;
?? OLDTITLE ??
?? NEWTITLE := 'create_global_log', EJECT ??

{ PURPOSE:
{   This procedure creates a new global log file.

  PROCEDURE [XDCL] create_global_log
    (    global_log: pmt$global_logs;
     VAR status: ost$status);

    VAR
      attachment_options: ^fst$attachment_options,
      cycle_selector: pft$cycle_selector,
      file_identifier: amt$file_identifier,
      file_reference: fst$path,
      ignore_status: ost$status,
      log_entry_header_p: ^lgt$log_entry_header,
      mandated_creation_attributes: ^fst$file_cycle_attributes,
      path_p: ^pft$path,
      segment_pointer: amt$segment_pointer;

    status.normal := TRUE;

{ Purge the high cycle of the file (just to make sure nothing is in the way).

    PUSH path_p: [1 .. 3];
    path_p^ [1] := jmc$system_family;
    path_p^ [2] := jmc$system_user;
    path_p^ [3] := lgv$log_names [global_log];
    cycle_selector.cycle_option := pfc$highest_cycle;
    pfp$purge (path_p^, cycle_selector, osc$null_name, ignore_status);

{ Create the permanent file that will contain the log.

    fsp$build_file_ref_from_elems (path_p, file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH attachment_options: [1 .. 1];
    attachment_options^ [1].selector := fsc$access_and_share_modes;
    attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options^ [1].access_modes.value := $fst$file_access_options
          [fsc$append, fsc$modify, fsc$shorten, fsc$read];
    attachment_options^ [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options^ [1].share_modes.value := $fst$file_access_options [];

    PUSH mandated_creation_attributes: [1 .. 3];
    mandated_creation_attributes^ [1].selector := fsc$ring_attributes;
    mandated_creation_attributes^ [1].ring_attributes.r1 := osc$tsrv_ring;
    mandated_creation_attributes^ [1].ring_attributes.r2 := osc$tsrv_ring;
    mandated_creation_attributes^ [1].ring_attributes.r3 := osc$tsrv_ring;
    mandated_creation_attributes^ [2].selector := fsc$file_contents_and_processor;
    mandated_creation_attributes^ [2].file_processor := fsc$unknown_processor;
    IF global_log = pmc$system_log THEN
      mandated_creation_attributes^ [2].file_contents := fsc$ascii_log;
    ELSE
      mandated_creation_attributes^ [2].file_contents := fsc$binary_log;
    IFEND;
    mandated_creation_attributes^ [3].selector := fsc$user_information;
    mandated_creation_attributes^ [3].user_information := lgc$log_version;

    fsp$open_file (file_reference, amc$segment, attachment_options, NIL, mandated_creation_attributes, NIL,
          NIL, file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Assign the log to the appropriate segment number.

    fsp$change_segment_number (file_identifier, lgp$log_segment_number (global_log), osc$tmtr_ring,
          amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Inform that system that the segment will be accessed sequentially.

    mmp$set_access_selections (segment_pointer.sequence_pointer, mmc$as_sequential, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Place the first log entry header in the log.

    NEXT log_entry_header_p IN segment_pointer.sequence_pointer;
    IF log_entry_header_p = NIL THEN
      osp$set_status_abnormal ('LG', lge$log_full, lgv$log_names [global_log], status);
      RETURN;
    IFEND;
    log_entry_header_p^.previous_size := 0;
    log_entry_header_p^.current_size := 0;
    RESET segment_pointer.sequence_pointer;

{ Initialize the corresponding log control descriptor.

    lgp$initialize_global_log_lcd (global_log, segment_pointer.sequence_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND create_global_log;
?? OLDTITLE ??
?? NEWTITLE := 'prompt_for_file_path', EJECT ??

{ PURPOSE:
{  Prompts the operator for the path of a file.

    PROCEDURE prompt_for_file_path
      (VAR file_reference: fst$file_reference;
       VAR file_reference_size: 0 .. fsc$max_path_size;
       VAR status: ost$status);

      VAR
        byte_address: amt$file_byte_address,
        evaluated_file_reference: fst$evaluated_file_reference,
        file_identifier: amt$file_identifier,
        file_position: amt$file_position,
        ignore_status: ost$status,
        input_file_path: fst$path,
        transfer_count: amt$transfer_count;

      status.normal := TRUE;

      fsp$open_file (':$LOCAL.INPUT.1', amc$record, NIL, NIL, NIL, NIL, NIL, file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      REPEAT
        status.normal := TRUE;

{ Get the file path from the operator.

        clp$put_job_output (' Please enter a temporary file path, permanent file path or $NULL.', status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        input_file_path := ' ';

        amp$get_next (file_identifier, ^input_file_path, #SIZE (input_file_path), transfer_count,
              byte_address, file_position, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Convert it to upper case and verify that it is a valid file path.

        #TRANSLATE (osv$lower_to_upper, input_file_path, file_reference);
        clp$evaluate_file_reference (file_reference, $clt$file_ref_parsing_options [], TRUE,
              evaluated_file_reference, status);
        IF NOT status.normal THEN
          clp$put_job_output (' --ERROR--  You must enter a valid file path.', ignore_status);
        IFEND;
      UNTIL status.normal;
      file_reference_size := transfer_count;

      fsp$close_file (file_identifier, status);

    PROCEND prompt_for_file_path;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'force_critical_log_termination', EJECT ??

{ PURPOSE:
{   This procedure asks the operator to supply the name of file to which the critical
{   window log can be terminated.

  PROCEDURE force_critical_log_termination
    (VAR status: ost$status);

    VAR
      file_path: fst$path,
      file_path_size: 0 .. fsc$max_path_size,
      ignore_status: ost$status,
      message: string (osc$max_string_size);

    status.normal := TRUE;

    clp$put_job_output (' ', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    message := ' ';
    message (2, * ) := lgv$critical_log_name;
    message (clp$trimmed_string_size (message) + 1, * ) := ' is too large and must be terminated.';
    clp$put_job_output (message (1, clp$trimmed_string_size (message)), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    REPEAT
      prompt_for_file_path (file_path, file_path_size, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_job_output (' ', status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Terminate the log to the specified file.  If $NULL was specified, simply discard the log.

      IF file_path <> '$NULL' THEN
        message := ' It will take a few moments to terminate ';
        message (clp$trimmed_string_size (message) + 2, * ) := lgv$critical_log_name;
        message (clp$trimmed_string_size (message) + 1, * ) := '.';
        clp$put_job_output (message (1, clp$trimmed_string_size (message)), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        lgp$terminate_critical_log (file_path (1, file_path_size), status);
        IF NOT status.normal THEN
          clp$put_job_output (' ', status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_job_output (' The following error occured while attempting to terminate the log.',
                ignore_status);
          osp$generate_output_message (status, ignore_status);
          clp$put_job_output (' Please try again. ($NULL may be used to discard the log.)', ignore_status);
        IFEND;
      ELSE
        lgp$release_critical_log_space (0, NIL, status);
        IF status.normal THEN
          message := ' ';
          message (2, * ) := lgv$critical_log_name;
          message (clp$trimmed_string_size (message) + 1, * ) := ' has been discarded.';
          clp$put_job_output (message (1, clp$trimmed_string_size (message)), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    UNTIL status.normal;

  PROCEND force_critical_log_termination;
?? OLDTITLE ??
?? NEWTITLE := 'force_log_termination', EJECT ??
{ PURPOSE:
{   This procedure asks the operator to supply the name of file to which the specified log can be terminated.

  PROCEDURE force_log_termination
    (    global_log: pmt$global_logs;
     VAR status: ost$status);

    VAR
      file_path: fst$path,
      file_path_size: 0 .. fsc$max_path_size,
      ignore_status: ost$status,
      message: string (osc$max_string_size);

    status.normal := TRUE;

    clp$put_job_output (' ', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    message := ' ';
    message (2, * ) := lgv$log_names [global_log];
    message (clp$trimmed_string_size (message) + 1, * ) := ' is too large and must be terminated.';
    clp$put_job_output (message (1, clp$trimmed_string_size (message)), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    REPEAT
      prompt_for_file_path (file_path, file_path_size, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_job_output (' ', status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Terminate the log to the specified file.  If $NULL was specified, simply discard the log.

      IF file_path <> '$NULL' THEN
        message := ' It will take a few moments to terminate ';
        message (clp$trimmed_string_size (message) + 2, * ) := lgv$log_names [global_log];
        message (clp$trimmed_string_size (message) + 1, * ) := '.';
        clp$put_job_output (message (1, clp$trimmed_string_size (message)), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        lgp$terminate_log (global_log, file_path (1, file_path_size), status);
        IF NOT status.normal THEN
          clp$put_job_output (' ', status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_job_output (' The following error occured while attempting to terminate the log.',
                ignore_status);
          osp$generate_output_message (status, ignore_status);
          clp$put_job_output (' Please try again. ($NULL may be used to discard the log.)', ignore_status);
        IFEND;
      ELSE
        lgp$release_global_log_space (global_log, 0, NIL, status);
        IF status.normal THEN
          message := ' ';
          message (2, * ) := lgv$log_names [global_log];
          message (clp$trimmed_string_size (message) + 1, * ) := ' has been discarded.';
          clp$put_job_output (message (1, clp$trimmed_string_size (message)), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    UNTIL status.normal;

  PROCEND force_log_termination;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lgp$append_job_log_to_output', EJECT ??

{ PURPOSE:
{   This procedure appends a copy of the job log to the output file.

  PROCEDURE [XDCL] lgp$append_job_log_to_output
    (VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      contains_data: boolean,
      display_line: ^string ( * ),
      display_line_size: lgt$log_entry_size,
      ending_offset: amt$file_byte_address,
      existing_file: boolean,
      file_attachment: ^fst$attachment_options,
      file_attributes: array [1 .. 1] of amt$get_item,
      ignore_status: ost$status,
      indentation_size: ost$string_size,
      local_file: boolean,
      log_cycle: lgt$log_cycle,
      log_data: ^SEQ ( * ),
      log_entry_index: 1 .. lgc$maximum_log_entry_size + 1,
      log_entry_size: lgt$log_entry_size,
      log_entry_p: ^string ( * ),
      output_file_id: amt$file_identifier;

    status.normal := TRUE;

{ Determine the page width for the output file.

    file_attributes [1].key := amc$page_width;
    amp$get_file_attributes (clv$standard_files [clc$sf_job_output_file].path_handle_name, file_attributes,
          local_file, existing_file, contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Open the output file.

    PUSH file_attachment: [1 .. 2];
    file_attachment^ [1].selector := fsc$access_and_share_modes;
    file_attachment^ [1].access_modes.selector := fsc$specific_access_modes;
    file_attachment^ [1].access_modes.value := $fst$file_access_options [fsc$append];
    file_attachment^ [1].share_modes.selector := fsc$specific_share_modes;
    file_attachment^ [1].share_modes.value := $fst$file_access_options
          [fsc$append, fsc$modify, fsc$shorten, fsc$read];
    file_attachment^ [2].selector := fsc$open_position;
    file_attachment^ [2].open_position := amc$open_at_eoi;

    fsp$open_file (clv$standard_files [clc$sf_job_output_file].path_handle_name, amc$record,
          file_attachment, {default_creation_attributes} NIL, { mandated_creation_attributes } NIL,
          {attribute_validation} NIL, {attribute_override} NIL, output_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Allocate space for the log entries read from the job log and the formatted output line.  The output line is
{ initialized to force a page eject at the start of the log.

    PUSH log_entry_p: [lgc$maximum_log_entry_size];
    PUSH display_line: [file_attributes [1].page_width + 1];
    display_line^ := '1';

{ Get the log cycle and log data sequence pointers for the job log.

    lgp$get_local_log_read_info (pmc$job_log, 0, log_cycle, log_data, ending_offset, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET log_data;

{ Copy the log to the output file.

    lgp$get_entry_from_local_log (pmc$job_log, log_cycle, log_data, log_entry_size, #SEQ (log_entry_p^) ^,
          status);

  /copy_log/
    WHILE status.normal DO

{ Write the log entry to the output file.  If the log entry is longer than the page width for the output file,
{ the log entry is wrapped to additional lines and each wrapped line is indented.

      log_entry_index := 1;
      indentation_size := 0;
      WHILE log_entry_index <= log_entry_size DO
        IF (log_entry_size - log_entry_index + 1) <= (file_attributes [1].page_width - indentation_size) THEN
          display_line_size := log_entry_size - log_entry_index + 1;
        ELSE
          display_line_size := file_attributes [1].page_width - indentation_size;
        IFEND;
        display_line^ (indentation_size + 2, display_line_size) :=
              log_entry_p^ (log_entry_index, display_line_size);
        amp$put_next (output_file_id, display_line, display_line_size + indentation_size + 1, byte_address,
              status);
        IF NOT status.normal THEN
          EXIT /copy_log/;
        IFEND;
        log_entry_index := log_entry_index + display_line_size;
        indentation_size := 2;
        display_line^ (1, indentation_size + 1) := '  ';
      WHILEND;

{ Get the next log entry.

      lgp$get_entry_from_local_log (pmc$job_log, log_cycle, log_data, log_entry_size, #SEQ (log_entry_p^) ^,
            status);
    WHILEND /copy_log/;
    IF status.condition = lge$end_of_log THEN
      status.normal := TRUE;
    IFEND;

    fsp$close_file (output_file_id, ignore_status);

  PROCEND lgp$append_job_log_to_output;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lgp$install_global_logs', EJECT ??

{ PURPOSE:
{   This procedure creates the global log files during an installation deadstart.

  PROCEDURE [XDCL] lgp$install_global_logs
    (VAR status: ost$status);

    VAR
      date: ost$date,
      global_log: pmt$global_logs,
      ignore_status: ost$status,
      message: string (osc$max_string_size),
      time: ost$time;

    status.normal := TRUE;

{ Create each of the global logs and the critical window log.  If an error prevents
{ the creation of a log, stop the deadstart.

    create_critical_window_log (status);
    IF NOT status.normal THEN
      message := 'Unable to create ';
      message (clp$trimmed_string_size (message) + 2, * ) := lgv$critical_log_name;
      osp$system_error (message (1, clp$trimmed_string_size (message)), ^status);
    IFEND;
    FOR global_log := LOWERBOUND (lgv$global_log_ctl) TO UPPERBOUND (lgv$global_log_ctl) DO
      create_global_log (global_log, status);
      IF NOT status.normal THEN
        message := 'Unable to create ';
        message (clp$trimmed_string_size (message) + 2, * ) := lgv$log_names [global_log];
        osp$system_error (message (1, clp$trimmed_string_size (message)), ^status);
      IFEND;
    FOREND;

{ Place an installation deadstart message in the system log.

    pmp$get_date (osc$month_date, date, {ignore} status);
    status.normal := TRUE;
    message := '**********  INSTALLATION DEADSTART ON  ';
    message (clp$trimmed_string_size (message) + 3, * ) := date.month;
    lgp$add_entry_to_system_log (pmc$msg_origin_system, message (1, clp$trimmed_string_size (message)), time,
          ignore_status);

  PROCEND lgp$install_global_logs;
?? OLDTITLE ??
?? NEWTITLE := 'lgp$log_segment_number', EJECT ??

{ PURPOSE:
{   This function returns the segment number that should be used for the specified global log.

  FUNCTION lgp$log_segment_number
    (    global_log: pmt$global_logs): ost$segment;

    CASE global_log OF
    = pmc$account_log =
      lgp$log_segment_number := osc$segnum_first_global_log;
    = pmc$engineering_log =
      lgp$log_segment_number := osc$segnum_first_global_log - 6;
{ special case the engineering log so we can eliminate references to seg 20(16)
    = pmc$history_log =
      lgp$log_segment_number := osc$segnum_first_global_log + 2;
    = pmc$security_log =
      lgp$log_segment_number := osc$segnum_first_global_log + 3;
    = pmc$statistic_log =
      lgp$log_segment_number := osc$segnum_first_global_log + 4;
    = pmc$system_log =
      lgp$log_segment_number := osc$segnum_system_dayfile;

{   = critical_window_log =
{     lgp$log_segment_number := osc$segnum_first_global_log - 7;
{
{   The critical window log is NOT a global log but is assigned a
{   segment.  This comment is here to let people know that segment 18(16)
{   belongs to the critical window log.

    ELSE
      lgp$log_segment_number := 0;
    CASEND;

  FUNCEND lgp$log_segment_number;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lgp$recover_global_logs', EJECT ??

{ PURPOSE:
{   This procedure recovers the global logs during a continuation deadstart.

  PROCEDURE [XDCL] lgp$recover_global_logs
    (VAR status: ost$status);

    VAR
      critical_recovery_status: ost$status,
      date: ost$date,
      global_log: pmt$global_logs,
      ignore_status: ost$status,
      message: string (osc$max_string_size),
      path: ^pft$path,
      recovery_log_data: ^SEQ ( * ),
      recovery_status: array [pmt$global_logs] of ost$status,
      time: ost$time;

?? NEWTITLE := 'copy_recovery_log', EJECT ??

{ PURPOSE:
{   This procedure is used to copy the contents of the recovery log to the system log after the system log has
{   been recovered and is available for use.

    PROCEDURE copy_recovery_log
      (VAR recovery_log_data: ^SEQ ( * );
       VAR status: ost$status);

      VAR
        file_modified: boolean,
        fmd_modified: boolean,
        log_entry_p: ^lgt$log_entry,
        log_entry_size: lgt$log_entry_size,
        text: ^string ( * ),
        time: ost$time;

      status.normal := TRUE;

{ Allocate space to hold the log entries as they are read.

      PUSH log_entry_p: [[REP lgc$maximum_log_entry_size OF cell]];

{ Copy the contents of the recovery log to the real system log.

      RESET recovery_log_data;
      lgp$get_entry_from_global_log (pmc$system_log, lgv$global_log_ctl [pmc$system_log].log_cycle,
            recovery_log_data, log_entry_size, log_entry_p^, status);
      WHILE status.normal DO
        RESET log_entry_p;
        NEXT text: [log_entry_size] IN log_entry_p;
        IF text <> NIL THEN
          lgp$add_entry_to_system_log (pmc$msg_origin_system, text^, time, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        lgp$get_entry_from_global_log (pmc$system_log, lgv$global_log_ctl [pmc$system_log].log_cycle,
              recovery_log_data, log_entry_size, log_entry_p^, status);
      WHILEND;
      IF status.condition = lge$end_of_log THEN
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;

{ Erase the contents of the recovery log.

      pmp$zero_out_table (recovery_log_data, i#current_sequence_position (recovery_log_data));

{ Close the recovery log device file.

      dmp$close_file (recovery_log_data, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{## Illegal to detach file - it is in the address space of other tasks in this job.
{##   dmp$detach_device_file (lgv$recovery_log_sfid, file_modified, fmd_modified, status);

      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND copy_recovery_log;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Save the log data sequence pointer for the recovery log.

    recovery_log_data := lgv$global_log_ctl [pmc$system_log].log_data;

{ Recover each of the global logs and the critical window log.
{ If a log cannot be recovered, it will be recreated.

    recover_critical_window_log (critical_recovery_status);
    IF NOT critical_recovery_status.normal THEN
      create_critical_window_log (status);
      IF NOT status.normal THEN
        message := 'Unable to recover or recreate ';
        message (clp$trimmed_string_size (message) + 2, * ) := lgv$critical_log_name;
        osp$system_error (message (1, clp$trimmed_string_size (message)), ^status);
      IFEND;
    IFEND;
    FOR global_log := LOWERBOUND (lgv$global_log_ctl) TO UPPERBOUND (lgv$global_log_ctl) DO
      recover_global_log (global_log, recovery_status [global_log]);
      IF (NOT recovery_status [global_log].normal) THEN
        create_global_log (global_log, status);
        IF NOT status.normal THEN
          message := 'Unable to recover or recreate ';
          message (clp$trimmed_string_size (message) + 2, * ) := lgv$log_names [global_log];
          osp$system_error (message (1, clp$trimmed_string_size (message)), ^status);
        IFEND;
      IFEND;
    FOREND;

{ Report any errors that occured during recovery in the system log.

    FOR global_log := LOWERBOUND (lgv$global_log_ctl) TO UPPERBOUND (lgv$global_log_ctl) DO
      IF NOT recovery_status [global_log].normal THEN
        message := '**********  THE FOLLOWING ERROR OCCURRED WHILE RECOVERING ';
        message (clp$trimmed_string_size (message) + 2, * ) := lgv$log_names [global_log];
        lgp$add_entry_to_system_log (pmc$msg_origin_system, message (1, clp$trimmed_string_size (message)),
              time, ignore_status);
        osp$generate_log_message ($pmt$ascii_logset [pmc$system_log], recovery_status [global_log],
              ignore_status);
        lgp$add_entry_to_system_log (pmc$msg_origin_system, '********** THE LOG WAS RECREATED', time,
              ignore_status);
      IFEND;
    FOREND;
    IF NOT critical_recovery_status.normal THEN
      message := '**********  THE FOLLOWING ERROR OCCURRED WHILE RECOVERING ';
      message (clp$trimmed_string_size (message) + 2, * ) := lgv$critical_log_name;
      lgp$add_entry_to_system_log (pmc$msg_origin_system, message (1, clp$trimmed_string_size (message)),
            time, ignore_status);
      osp$generate_log_message ($pmt$ascii_logset [pmc$system_log], critical_recovery_status,
            ignore_status);
      lgp$add_entry_to_system_log (pmc$msg_origin_system, '********** THE LOG WAS RECREATED', time,
            ignore_status);
    IFEND;

{ Record a recovery deadstart message in the system log.

    pmp$get_date (osc$month_date, date, ignore_status);
    message := '**********  RECOVERY DEADSTART ON  ';
    message (clp$trimmed_string_size (message) + 3, * ) := date.month;
    lgp$add_entry_to_system_log (pmc$msg_origin_system, message (1, clp$trimmed_string_size (message)), time,
          ignore_status);

{ Copy the entries from the recovery log to the recovered log.

    copy_recovery_log (recovery_log_data, recovery_status [global_log]);
    IF NOT recovery_status [global_log].normal THEN
      lgp$add_entry_to_system_log (pmc$msg_origin_system,
            '**********  THE FOLLOWING ERROR OCCURED WHILE COPYING THE RECOVERY LOG', time, ignore_status);
      osp$generate_log_message ($pmt$ascii_logset [pmc$system_log], recovery_status [global_log],
            ignore_status);
    IFEND;

  PROCEND lgp$recover_global_logs;
?? OLDTITLE ??
?? NEWTITLE := 'recover_critical_window_log', EJECT ??

{ PURPOSE:
{   This procedure is used to recover the critical window log.

  PROCEDURE recover_critical_window_log
    (VAR status: ost$status);

    VAR
      attachment_options: ^fst$attachment_options,
      file_identifier: amt$file_identifier,
      file_reference: fst$path,
      ignore_status: ost$status,
      path_p: ^pft$path,
      required_attributes: ^fst$file_cycle_attributes,
      segment_pointer: amt$segment_pointer;

    status.normal := TRUE;

{ Open the file that contains the log (the file must already exist and have the correct attributes).

    PUSH path_p: [1 .. 2];
    path_p^ [1] := '$user';
    path_p^ [2] := lgv$critical_log_name;
    fsp$build_file_ref_from_elems (path_p, file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH attachment_options: [1 .. 2];
    attachment_options^ [1].selector := fsc$access_and_share_modes;
    attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options^ [1].access_modes.value := $fst$file_access_options
          [fsc$append, fsc$modify, fsc$shorten, fsc$read];
    attachment_options^ [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options^ [1].share_modes.value := $fst$file_access_options [];
    attachment_options^ [2].selector := fsc$create_file;
    attachment_options^ [2].create_file := FALSE;

    PUSH required_attributes: [1 .. 3];
    required_attributes^ [1].selector := fsc$ring_attributes;
    required_attributes^ [1].ring_attributes.r1 := osc$tsrv_ring;
    required_attributes^ [1].ring_attributes.r2 := osc$tsrv_ring;
    required_attributes^ [1].ring_attributes.r3 := osc$tsrv_ring;
    required_attributes^ [2].selector := fsc$file_contents_and_processor;
    required_attributes^ [2].file_processor := fsc$unknown_processor;
    required_attributes^ [2].file_contents := fsc$ascii_log;
    required_attributes^ [3].selector := fsc$user_information;
    required_attributes^ [3].user_information := lgc$log_version;

    fsp$open_file (file_reference, amc$segment, attachment_options, NIL, NIL, required_attributes, NIL,
          file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /log_open/
    BEGIN

{ Assign the log to the appropriate segment number.

      fsp$change_segment_number (file_identifier, (osc$segnum_first_global_log - 7), osc$tmtr_ring,
            amc$sequence_pointer, segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /log_open/;
      IFEND;

{ Inform that system that the segment will be accessed sequentially.

      mmp$set_access_selections (segment_pointer.sequence_pointer, mmc$as_sequential, status);
      IF NOT status.normal THEN
        EXIT /log_open/;
      IFEND;

{ Initialize the critical_window log control descriptor.

      lgp$initialize_critical_log_lcd (segment_pointer.sequence_pointer, status);
      IF NOT status.normal THEN
        EXIT /log_open/;
      IFEND;

{ If the log is more than 75% full, terminate the log to a file specified by the operator.

      IF i#current_sequence_position (lgv$critical_log_ctl.log_data) >
            ((lgv$critical_log_ctl.maximum_size * 3) DIV 4) THEN
        force_critical_log_termination (status);
      IFEND;
    END /log_open/;

{ If an error occurs, close the log file and invalidate the log segment.

    IF NOT status.normal THEN
      fsp$close_file (file_identifier, ignore_status);
      mmp$invalidate_segment ((osc$segnum_first_global_log - 7), 1, NIL, ignore_status);
    IFEND;

  PROCEND recover_critical_window_log;
?? OLDTITLE ??
?? NEWTITLE := 'recover_global_log', EJECT ??

{ PURPOSE:
{   This procedure is used recover the specified global log.

  PROCEDURE recover_global_log
    (    global_log: pmt$global_logs;
     VAR status: ost$status);

    VAR
      attachment_options: ^fst$attachment_options,
      file_identifier: amt$file_identifier,
      file_reference: fst$path,
      ignore_status: ost$status,
      path_p: ^pft$path,
      required_attributes: ^fst$file_cycle_attributes,
      segment_pointer: amt$segment_pointer;

    status.normal := TRUE;

{ Open the file that contains the log (the file must already exist and have the correct attributes).

    PUSH path_p: [1 .. 2];
    path_p^ [1] := '$user';
    path_p^ [2] := lgv$log_names [global_log];
    fsp$build_file_ref_from_elems (path_p, file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH attachment_options: [1 .. 2];
    attachment_options^ [1].selector := fsc$access_and_share_modes;
    attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options^ [1].access_modes.value := $fst$file_access_options
          [fsc$append, fsc$modify, fsc$shorten, fsc$read];
    attachment_options^ [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options^ [1].share_modes.value := $fst$file_access_options [];
    attachment_options^ [2].selector := fsc$create_file;
    attachment_options^ [2].create_file := FALSE;

    PUSH required_attributes: [1 .. 3];
    required_attributes^ [1].selector := fsc$ring_attributes;
    required_attributes^ [1].ring_attributes.r1 := osc$tsrv_ring;
    required_attributes^ [1].ring_attributes.r2 := osc$tsrv_ring;
    required_attributes^ [1].ring_attributes.r3 := osc$tsrv_ring;
    required_attributes^ [2].selector := fsc$file_contents_and_processor;
    required_attributes^ [2].file_processor := fsc$unknown_processor;
    IF global_log = pmc$system_log THEN
      required_attributes^ [2].file_contents := fsc$ascii_log;
    ELSE
      required_attributes^ [2].file_contents := fsc$binary_log;
    IFEND;
    required_attributes^ [3].selector := fsc$user_information;
    required_attributes^ [3].user_information := lgc$log_version;

    fsp$open_file (file_reference, amc$segment, attachment_options, NIL, NIL, required_attributes, NIL,
          file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /log_open/
    BEGIN

{ Assign the log to the appropriate segment number.

      fsp$change_segment_number (file_identifier, lgp$log_segment_number (global_log), osc$tmtr_ring,
            amc$sequence_pointer, segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /log_open/;
      IFEND;

{ Inform that system that the segment will be accessed sequentially.

      mmp$set_access_selections (segment_pointer.sequence_pointer, mmc$as_sequential, status);
      IF NOT status.normal THEN
        EXIT /log_open/;
      IFEND;

{ Initialize the corresponding log control descriptor.

      lgp$initialize_global_log_lcd (global_log, segment_pointer.sequence_pointer, status);
      IF NOT status.normal THEN
        EXIT /log_open/;
      IFEND;

{ If the log is more than 75% full, terminate the log to a file specified by the operator.

      IF i#current_sequence_position (lgv$global_log_ctl [global_log].log_data) >
            ((lgv$global_log_ctl [global_log].maximum_size * 3) DIV 4) THEN
        force_log_termination (global_log, status);
      IFEND;
    END /log_open/;

{ If an error occurs, close the log file and invalidate the log segment.

    IF NOT status.normal THEN
      fsp$close_file (file_identifier, ignore_status);
      mmp$invalidate_segment (lgp$log_segment_number (global_log), 1, NIL, ignore_status);
    IFEND;

  PROCEND recover_global_log;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lgp$install_eng_log', EJECT ??

{ PURPOSE:
{   This procedure deletes the old engineering log segment during  deadstart.

  PROCEDURE [XDCL] lgp$install_eng_log
    (VAR status: ost$status);

    CONST
      old_engineering_log_number = 20(16);

    VAR
      date: ost$date,
      global_log: pmt$global_logs,
      message: string (osc$max_string_size),
      ignore_status: ost$status,
      time: ost$time;

    status.normal := TRUE;

      mmp$invalidate_segment (old_engineering_log_number, 1, NIL, ignore_status);

{ Place an recovery deadstart message in the system log.

    pmp$get_date (osc$month_date, date, ignore_status);
    message := '**********  MODIFIED ENGINEERING LOG ON  ';
    message (clp$trimmed_string_size (message) + 3, * ) := date.month;
    lgp$add_entry_to_system_log (pmc$msg_origin_system, message (1, clp$trimmed_string_size (message)), time,
          ignore_status);

  PROCEND lgp$install_eng_log;

MODEND lgm$internal_logging_interfaces;
*DECK DECK=LGM$LOCAL_LOG_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Logging: Local Log Manager' ??
MODULE lgm$local_log_manager;

{ PURPOSE:
{   This module contains the code used to manage the local logs.
{
{ DESIGN:
{   The local logs are segments that are created during job begin.  Information about each local log is kept
{   in the log's corresponding log control descriptor (LCD).
{
{   Access to a log is interlocked via a job signature lock (contained in the log's LCD) and all local log
{   accesses eventually find their way to procedures in this module.  There are file entries that appear in
{   the $LOCAL catalog for each job that represent the local logs, but these files entries have a FAP
{   associated with them that calls the interfaces in this module.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc lgc$default_preallocation_size
*copyc lge$end_of_log
*copyc lge$log_full
*copyc lge$log_cycles_do_not_match
*copyc lge$log_not_available
*copyc lge$not_local_log
*copyc osc$space_unavailable_condition
*copyc osc$volume_unavailable_cond
*copyc oss$job_pageable
*copyc oss$job_paged_literal
*copyc ost$heap
*copyc pmt$ascii_logset
*copyc pmt$global_logset
*copyc pmt$job_log_entry
*copyc pmt$local_binary_logs
*copyc pmt$log_msg_origin
*copyc pmt$log_msg_text
*copyc pmt$logs
?? POP ??
*copyc i#build_adaptable_seq_pointer
*copyc i#move
*copyc lgp$add_log_entry
*copyc lgp$add_entry_to_system_log
*copyc lgp$get_log_entry
*copyc lgp$get_log_read_information
*copyc lgp$get_previous_log_entry_size
*copyc mmp$change_segment_inheritance
*copyc mmp$create_segment
*copyc osp$clear_job_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$initialize_sig_lock
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$test_signature_lock
*copyc pmp$continue_to_cause
*copyc pmp$get_time
*copyc lgv$control_codes_to_quest_mark
*copyc lgv$log_names
*copyc lgv$origin_codes
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module.', EJECT ??
?? FMT (FORMAT := OFF) ??
{ This is the local log control descriptor array.  Entries for global logs are not used.

  VAR
    lgv$local_log_ctl: [XDCL, #GATE, oss$job_pageable] array [pmt$logs] of ^lgt$log_control_descriptor := [
          ^lgv$job_account_log_lcd, ^lgv$job_statistic_log_lcd, NIL, NIL, NIL, NIL, NIL, NIL,
          ^lgv$job_log_lcd],

    lgv$job_account_log_lcd: [STATIC, oss$job_pageable] lgt$log_control_descriptor :=
          [*, pmc$job_account_log,   0, NIL, NIL, lgc$maximum_log_size,
                lgc$default_preallocation_size, FALSE, 0, FALSE],

    lgv$job_statistic_log_lcd: [STATIC, oss$job_pageable] lgt$log_control_descriptor :=
          [*, pmc$job_statistic_log, 0, NIL, NIL, lgc$maximum_log_size,
                lgc$default_preallocation_size, FALSE, 0, FALSE],

    lgv$job_log_lcd: [STATIC, oss$job_pageable] lgt$log_control_descriptor :=
          [*, pmc$job_log,           0, NIL, NIL, lgc$maximum_log_size,
                lgc$default_preallocation_size, FALSE, 0, FALSE];
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$add_entry_local_binary_log', EJECT ??
*copy lgh$add_entry_local_binary_log

  PROCEDURE [XDCL, #GATE] lgp$add_entry_local_binary_log
    (    local_binary_log: pmt$local_binary_logs;
         entry_p: ^lgt$log_entry;
     VAR status: ost$status);

    VAR
      lock_status: ost$signature_lock_status,
      log_control_descriptor_p: ^lgt$log_control_descriptor;

?? NEWTITLE := 'condition_handler', EJECT ??
{ PURPOSE:
{   This is a condition handler that is used to insure that the lock on a local log is released if
{   an error occurs.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF
      = pmc$block_exit_processing =
        clear_job_sig_lock (log_control_descriptor_p^.lock);
      = pmc$user_defined_condition =
        IF ((condition.user_condition_name = osc$volume_unavailable_cond) OR
            (condition.user_condition_name = osc$space_unavailable_condition)) THEN
          EXIT lgp$add_entry_local_binary_log;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ Get a pointer to the appropriate log control descriptor.

    log_control_descriptor_p := lgv$local_log_ctl [local_binary_log];
    #SPOIL (log_control_descriptor_p);

{ Interlock the log.

    osp$establish_condition_handler (^condition_handler, TRUE);
    set_job_sig_lock (log_control_descriptor_p^.lock, lock_status);
    IF lock_status <> osc$sls_not_locked THEN
      RETURN;
    IFEND;
{ Add the entry to the log.  If the log is full, ignore the error (the message is lost).

    lgp$add_log_entry (entry_p, log_control_descriptor_p, status);
    IF (NOT status.normal) AND (status.condition = lge$log_full) THEN
      status.normal := TRUE;
    IFEND;

{ Clear the log interlock.

    clear_job_sig_lock (log_control_descriptor_p^.lock);
    osp$disestablish_cond_handler;

  PROCEND lgp$add_entry_local_binary_log;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$add_entry_to_ascii_log', EJECT ??
*copy lgh$add_entry_to_ascii_log

  PROCEDURE [XDCL, #GATE] lgp$add_entry_to_ascii_log
    (    ascii_logset: pmt$ascii_logset;
         origin: pmt$log_msg_origin;
         text: pmt$log_msg_text;
     VAR status: ost$status);

    VAR
      job_log_entry_p: ^pmt$job_log_entry,
      lock_status: ost$signature_lock_status,
      log_control_descriptor_p: ^lgt$log_control_descriptor,
      log_time: ost$time,
      text_size: lgt$log_entry_size;

?? NEWTITLE := 'condition_handler', EJECT ??
{ PURPOSE:
{   This is a condition handler that is used to insure that the lock on a local log is released if
{   an error occurs.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF
      = pmc$block_exit_processing =
        IF pmc$job_log IN ascii_logset THEN
          clear_job_sig_lock (log_control_descriptor_p^.lock);
        IFEND;
      = pmc$user_defined_condition =
        IF ((condition.user_condition_name = osc$volume_unavailable_cond) OR
            (condition.user_condition_name = osc$space_unavailable_condition)) THEN
          EXIT lgp$add_entry_to_ascii_log;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    IF pmc$job_log IN ascii_logset THEN

{ Get a pointer to the log control descriptor for the job log.

      log_control_descriptor_p := lgv$local_log_ctl [pmc$job_log];
      #SPOIL (log_control_descriptor_p);

{ Check if the job log is available.

      IF log_control_descriptor_p^.log_data = NIL THEN
        osp$set_status_abnormal ('LG', lge$log_not_available, lgv$log_names [pmc$job_log], status);
        RETURN;
      IFEND;

{ Interlock the job log.

      osp$establish_condition_handler (^condition_handler, TRUE);
      set_job_sig_lock (log_control_descriptor_p^.lock, lock_status);
      IF lock_status <> osc$sls_not_locked THEN
        RETURN;
      IFEND;
    IFEND;

{ If the message goes to the system log, record it there and get the time stamp used.  Otherwise, get the
{ current time to be used for the time stamp.

    IF pmc$system_log IN ascii_logset THEN
      lgp$add_entry_to_system_log (origin, text, log_time, status);
    ELSE
      pmp$get_time (osc$millisecond_time, log_time, status);
    IFEND;
    IF NOT status.normal THEN
      IF pmc$job_log IN ascii_logset THEN
        clear_job_sig_lock (log_control_descriptor_p^.lock);
      IFEND;
      RETURN;
    IFEND;

{ If the message goes to the job log: format it, record it in the log and clear the log interlock.
{ If the log is full, ignore the error (the message is lost).

    IF pmc$job_log IN ascii_logset THEN
      text_size := lgc$maximum_log_entry_size - #SIZE (pmt$job_log_entry: [0]);
      IF STRLENGTH (text) < text_size THEN
        text_size := STRLENGTH (text);
      IFEND;
      PUSH job_log_entry_p: [text_size];

      job_log_entry_p^.time := log_time.millisecond;
      job_log_entry_p^.delimiter_1 (1) := '.';
      job_log_entry_p^.origin := lgv$origin_codes [origin];
      job_log_entry_p^.delimiter_2 (1) := '.';
      #TRANSLATE (lgv$control_codes_to_quest_mark, text, job_log_entry_p^.text);

      lgp$add_log_entry (#SEQ (job_log_entry_p^), log_control_descriptor_p, status);
      IF (NOT status.normal) AND (status.condition = lge$log_full) THEN
        status.normal := TRUE;
      IFEND;

      clear_job_sig_lock (log_control_descriptor_p^.lock);
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND lgp$add_entry_to_ascii_log;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$get_entry_from_local_log', EJECT ??
*copy lgh$get_entry_from_local_log

  PROCEDURE [XDCL, #GATE] lgp$get_entry_from_local_log
    (    local_log: pmt$logs;
         log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR log_entry_size: lgt$log_entry_size;
     VAR log_entry: lgt$log_entry;
     VAR status: ost$status);

    VAR
      log_control_descriptor_p: ^lgt$log_control_descriptor;

    status.normal := TRUE;

{ Verify that the specified log is a local log.

    IF local_log IN (-$pmt$global_logset []) THEN
      osp$set_status_abnormal ('LG', lge$not_local_log, lgv$log_names [local_log], status);
      RETURN;
    IFEND;

{ Get a pointer to the appropriate log control descriptor.

    log_control_descriptor_p := lgv$local_log_ctl [local_log];

{ Return a copy of the log entry header and as much of the log entry as will fit.

    lgp$get_log_entry (log_cycle, log_control_descriptor_p, log_data, log_entry_size, log_entry, status);

  PROCEND lgp$get_entry_from_local_log;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$get_local_log_read_info', EJECT ??
*copy lgh$get_local_log_read_info

  PROCEDURE [XDCL, #GATE] lgp$get_local_log_read_info
    (    local_log: pmt$logs;
         entry_count_from_end_of_log: ost$segment_length;
     VAR log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR ending_offset: amt$file_byte_address;
     VAR status: ost$status);

    VAR
      log_control_descriptor_p: ^lgt$log_control_descriptor;

    status.normal := TRUE;

{ Verify that the specified log is a local log.

    IF local_log IN (-$pmt$global_logset []) THEN
      osp$set_status_abnormal ('LG', lge$not_local_log, lgv$log_names [local_log], status);
      RETURN;
    IFEND;

{ Get a pointer to the appropriate log control descriptor.

    log_control_descriptor_p := lgv$local_log_ctl [local_log];

{ Get the appropriate values from the log control descriptor.

    lgp$get_log_read_information (log_control_descriptor_p, entry_count_from_end_of_log, log_cycle, log_data,
          ending_offset, status);

  PROCEND lgp$get_local_log_read_info;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$get_local_previous_size', EJECT ??

  PROCEDURE [XDCL, #GATE] lgp$get_local_previous_size
    (    local_log: pmt$logs;
         log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR previous_size: lgt$log_entry_size;
     VAR status: ost$status);

    VAR
      log_control_descriptor_p: ^lgt$log_control_descriptor;

    status.normal := TRUE;

{ Get a pointer to the appropriate log control descriptor.

    log_control_descriptor_p := lgv$local_log_ctl [local_log];

{ Get the size of the previous log entry.

    lgp$get_previous_log_entry_size (log_cycle, log_control_descriptor_p, log_data, previous_size, status);

  PROCEND lgp$get_local_previous_size;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$setup_access_to_local_logs', EJECT ??
*copy lgh$setup_access_to_local_logs

  PROCEDURE [XDCL, #GATE] lgp$setup_access_to_local_logs
    (VAR status: ost$status);

    VAR
      initial_segment_attributes: [STATIC, READ, oss$job_paged_literal] array [1 .. 5] of
            mmt$attribute_descriptor := [
            {1} [mmc$kw_segment_number, osc$segnum_job_dayfile],
            {2} [mmc$kw_ring_numbers, 2, 3],
            {3} [mmc$kw_max_segment_length, lgc$maximum_log_size],
            {4} [mmc$kw_preset_value, pmc$initialize_to_zero],
            {5} [mmc$kw_hardware_attributes, [mmc$ha_read, mmc$ha_write]]],
      log: pmt$logs,
      segment_attributes: ^array [1 .. 5] of mmt$attribute_descriptor,
      segment_pointer: mmt$segment_pointer;

    status.normal := TRUE;

{ Initialize the segment attributes.

    PUSH segment_attributes;
    segment_attributes^ := initial_segment_attributes;

  /init_log_control_descriptor/
    FOR log := LOWERBOUND (lgv$local_log_ctl) TO UPPERBOUND (lgv$local_log_ctl) DO

{ Skip over the entries for global logs (they are not used).

      IF log IN (-$pmt$global_logset []) THEN
        CYCLE /init_log_control_descriptor/
      IFEND;

{ Initialize the signature lock used to control access to the log.

      osp$initialize_sig_lock (lgv$local_log_ctl [log]^.lock);

{ Make sure the job log is assigned to the correct segment number.  The other local logs do not have specific
{ segment numbers.

      IF log = pmc$job_log THEN
        segment_attributes^ [1] := initial_segment_attributes [1];
      ELSE
        segment_attributes^ [1].keyword := mmc$kw_null_keyword;
      IFEND;

{ Create the segment that will contain the log.

      mmp$create_segment (segment_attributes, mmc$sequence_pointer, 1, segment_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      mmp$change_segment_inheritance (segment_pointer.cell_pointer, mmc$si_share_segment, status);

{ Initialize the log data pointer.

      i#build_adaptable_seq_pointer (#RING (segment_pointer.seq_pointer),
          #SEGMENT (segment_pointer.seq_pointer), #OFFSET (segment_pointer.seq_pointer),
          #SIZE (lgt$log_entry_header), #SIZE (lgt$log_entry_header), lgv$local_log_ctl [log]^.log_data);
      RESET lgv$local_log_ctl [log]^.log_data;

{ Initialize the trailing log entry header.

      NEXT lgv$local_log_ctl [log]^.trailing_log_entry_header_p IN lgv$local_log_ctl [log]^.log_data;
      IF lgv$local_log_ctl [log]^.trailing_log_entry_header_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$log_full, lgv$log_names [log], status);
        RETURN;
      IFEND;
      lgv$local_log_ctl [log]^.trailing_log_entry_header_p^.previous_size := 0;
      lgv$local_log_ctl [log]^.trailing_log_entry_header_p^.current_size := 0;

    FOREND /init_log_control_descriptor/;

  PROCEND lgp$setup_access_to_local_logs;
?? OLDTITLE ??
?? NEWTITLE := 'clear_job_sig_lock', EJECT ??

  PROCEDURE clear_job_sig_lock
    (VAR lock: ost$signature_lock);

    VAR
      local_status: ost$status,
      lock_status: ost$signature_lock_status;

    osp$test_signature_lock (lock, lock_status, local_status);
    IF local_status.normal THEN
      IF lock_status = osc$sls_locked_by_current_task THEN
        osp$clear_job_signature_lock (lock);
      IFEND;
    IFEND;

  PROCEND clear_job_sig_lock;

?? OLDTITLE ??
?? NEWTITLE := 'set_job_sig_lock', EJECT ??

  PROCEDURE set_job_sig_lock
    (VAR lock: ost$signature_lock;
     VAR lock_status: ost$signature_lock_status);

    VAR
      local_status: ost$status;

    osp$test_signature_lock (lock, lock_status, local_status);
    IF local_status.normal THEN
      IF lock_status = osc$sls_not_locked THEN
        osp$set_job_signature_lock (lock);
      IFEND;
    IFEND;

  PROCEND set_job_sig_lock;
MODEND lgm$local_log_manager;
*DECK DECK=LGM$LOGGING_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Logging: Logging Command Processors' ??
MODULE lgm$logging_commands;

{ PURPOSE:
{  This module contains the command processors related to logging.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fst$path
*copyc lge$not_global_log
*copyc lge$unknown_log_keyword
*copyc pmt$global_logset
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc lgp$display_log
*copyc lgp$display_critical_log_attr
*copyc lgp$display_log_attributes
*copyc lgp$terminate_critical_log
*copyc lgp$terminate_log
*copyc osp$set_status_abnormal
*copyc pmp$get_date
?? OLDTITLE ??
?? NEWTITLE := 'determine_log_ordinal', EJECT ??
{ PURPOSE:
{   Translate the keyword value specified on a command into its corresponding log ordinal value.

  PROCEDURE determine_log_ordinal
    (    keyword_value: ost$name;
     VAR log_ordinal: pmt$logs;
     VAR status: ost$status);

    status.normal := TRUE;

    IF keyword_value = 'SYSTEM_LOG' THEN
      log_ordinal := pmc$system_log;
    ELSEIF keyword_value = 'ACCOUNT_LOG' THEN
      log_ordinal := pmc$account_log;
    ELSEIF keyword_value = 'ENGINEERING_LOG' THEN
      log_ordinal := pmc$engineering_log;
    ELSEIF keyword_value = 'HISTORY_LOG' THEN
      log_ordinal := pmc$history_log;
    ELSEIF keyword_value = 'JOB_ACCOUNT_LOG' THEN
      log_ordinal := pmc$job_account_log;
    ELSEIF keyword_value = 'JOB_LOG' THEN
      log_ordinal := pmc$job_log;
    ELSEIF keyword_value = 'JOB_STATISTIC_LOG' THEN
      log_ordinal := pmc$job_statistic_log;
    ELSEIF keyword_value = 'SECURITY_LOG' THEN
      log_ordinal := pmc$security_log;
    ELSEIF keyword_value = 'STATISTIC_LOG' THEN
      log_ordinal := pmc$statistic_log;
    ELSE
      osp$set_status_abnormal ('LG', lge$unknown_log_keyword, keyword_value, status)
    IFEND;

  PROCEND determine_log_ordinal;
?? OLDTITLE ??
?? NEWTITLE := 'lgp$_display_log', EJECT ??
{ PURPOSE:
{   Command processor for the DISPLAY_LOG command.

  PROCEDURE [XDCL, #GATE] lgp$_display_log
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$disl) display_log, disl (
{   display_option, display_options, do: any of
{       key
{         (all, a)
{         (last, l)
{       keyend
{       integer
{     anyend = all
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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 .. 4] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 23, 8, 50, 29, 875],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'OSM$DISL'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 1],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 1],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 195,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    155, [[1, 0, clc$keyword_type], [4], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['LAST                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$display_option = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      count: integer,
      display_option_selection: lgt$display_option_selection;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$display_option].value^.kind = clc$integer THEN
      IF pvt [p$display_option].value^.integer_value.value < 0 THEN
        IF pvt [p$display_option].value^.integer_value.value = clc$min_integer THEN
          count := -(pvt [p$display_option].value^.integer_value.value+1);
        ELSE
          count := -pvt [p$display_option].value^.integer_value.value;
        IFEND;
      ELSE
        count := pvt [p$display_option].value^.integer_value.value;
      IFEND;
      display_option_selection.display_options := lgc$count;
      IF count >= UPPERVALUE (display_option_selection.count) - 1 THEN
        display_option_selection.count := UPPERVALUE (display_option_selection.count) - 1;
      ELSE
        display_option_selection.count := count;
      IFEND;
    ELSE
      IF pvt [p$display_option].value^.keyword_value = 'ALL' THEN
        display_option_selection.display_options := lgc$all;
      ELSE
        display_option_selection.display_options := lgc$last;
      IFEND;
    IFEND;

    lgp$display_log (clc$display_job_log, display_option_selection, pvt [p$output].
          value^.file_value^, status);

  PROCEND lgp$_display_log;
?? OLDTITLE ??
?? NEWTITLE := 'lgp$_display_system_log', EJECT ??
{ PURPOSE:
{   Command processor for the DISPLAY_SYSTEM_LOG command.

  PROCEDURE [XDCL, #GATE] lgp$_display_system_log
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (osm$dissl) display_system_log, dissl (
{     display_option, display_options, do: any of
{         key
{           (all, a)
{           (last, l)
{         keyend
{         integer
{       anyend = last
{     output, o: file = $output
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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 .. 4] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [94, 1, 11, 9, 46, 47, 276],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'OSM$DISSL'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 1],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 1],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 195, clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    155, [[1, 0, clc$keyword_type], [4], [
      ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
      ['LAST                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]]
    ,
    'last'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$display_option = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      count: integer,
      display_option_selection: lgt$display_option_selection;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$display_option].value^.kind = clc$integer THEN
      IF pvt [p$display_option].value^.integer_value.value < 0 THEN
        IF pvt [p$display_option].value^.integer_value.value = clc$min_integer THEN
          count := -(pvt [p$display_option].value^.integer_value.value+1);
        ELSE
          count := -pvt [p$display_option].value^.integer_value.value;
        IFEND;
      ELSE
        count := pvt [p$display_option].value^.integer_value.value;
      IFEND;
      display_option_selection.display_options := lgc$count;
      IF count >= UPPERVALUE (display_option_selection.count) - 1 THEN
        display_option_selection.count := UPPERVALUE (display_option_selection.count) - 1;
      ELSE
        display_option_selection.count := count;
      IFEND;
    ELSE
      IF pvt [p$display_option].value^.keyword_value (1) = 'A' THEN
        display_option_selection.display_options := lgc$all;
      ELSE
        display_option_selection.display_options := lgc$last;
      IFEND;
    IFEND;

    lgp$display_log (clc$display_system_log, display_option_selection, pvt [p$output].value^.file_value^,
          status);

  PROCEND lgp$_display_system_log;
?? OLDTITLE ??
?? NEWTITLE := 'lgp$display_critical_window_log', EJECT ??
{ PURPOSE:
{   Command processor for the DISPLAY_CRITICAL_WINDOW_LOG command.

  PROCEDURE [XDCL, #GATE] lgp$display_critical_window_log
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (osm$discwl) display_critical_window_log, discwl (
{     display_option, display_options, do: any of
{         key
{           (all, a)
{           (last, l)
{         keyend
{         integer
{       anyend = last
{     output, o: file = $output
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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 .. 4] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [94, 1, 11, 9, 45, 16, 156],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'OSM$DISCWL'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 1],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 1],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 195, clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    155, [[1, 0, clc$keyword_type], [4], [
      ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
      ['LAST                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]]
    ,
    'last'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$display_option = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      count: integer,
      display_option_selection: lgt$display_option_selection;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$display_option].value^.kind = clc$integer THEN
      IF pvt [p$display_option].value^.integer_value.value < 0 THEN
        IF pvt [p$display_option].value^.integer_value.value = clc$min_integer THEN
          count := -(pvt [p$display_option].value^.integer_value.value+1);
        ELSE
          count := -pvt [p$display_option].value^.integer_value.value;
        IFEND;
      ELSE
        count := pvt [p$display_option].value^.integer_value.value;
      IFEND;
      display_option_selection.display_options := lgc$count;
      IF count >= UPPERVALUE (display_option_selection.count) - 1 THEN
        display_option_selection.count := UPPERVALUE (display_option_selection.count) - 1;
      ELSE
        display_option_selection.count := count;
      IFEND;
    ELSE
      IF pvt [p$display_option].value^.keyword_value (1) = 'A' THEN
        display_option_selection.display_options := lgc$all;
      ELSE
        display_option_selection.display_options := lgc$last;
      IFEND;
    IFEND;

    lgp$display_log (clc$display_critical_window_log, display_option_selection,
          pvt [p$output].value^.file_value^, status);

  PROCEND lgp$display_critical_window_log;
?? OLDTITLE ??
?? NEWTITLE := 'lgp$_display_log_attributes', EJECT ??
{ PURPOSE:
{   This is the command processor for the DISPLAY_LOG_ATTRIBUTES command.

  PROCEDURE [XDCL, #GATE] lgp$_display_log_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE display_log_attributes (
{     log, l: key
{         (account_log, account, al)
{         (critical_window_log, cwl)
{         (engineering_log, engineering, el)
{         (history_log, history, hl)
{         (job_account_log, jal)
{         (job_log, jl)
{         (job_statistic_log, jsl)
{         (security_log, security)
{         (statistic_log, statistic, sl)
{         (system_log, system)
{       keyend = system_log
{     output, o: file = $output
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 24] of clt$keyword_specification,
        default_value: string (10),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [93, 10, 13, 14, 9, 55, 37],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['L                              ',clc$abbreviation_entry, 1],
    ['LOG                            ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 895, clc$optional_default_parameter, 0, 10],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [24], [
    ['ACCOUNT                        ', clc$alias_entry,
  clc$normal_usage_entry, 1],
    ['ACCOUNT_LOG                    ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['AL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['CRITICAL_WINDOW_LOG            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['CWL                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['EL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['ENGINEERING                    ', clc$alias_entry,
  clc$normal_usage_entry, 3],
    ['ENGINEERING_LOG                ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['HISTORY                        ', clc$alias_entry,
  clc$normal_usage_entry, 4],
    ['HISTORY_LOG                    ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['HL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
    ['JAL                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
    ['JL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
    ['JOB_ACCOUNT_LOG                ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
    ['JOB_LOG                        ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
    ['JOB_STATISTIC_LOG              ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
    ['JSL                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
    ['SECURITY                       ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
    ['SECURITY_LOG                   ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
    ['SL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
    ['STATISTIC                      ', clc$alias_entry,
  clc$normal_usage_entry, 9],
    ['STATISTIC_LOG                  ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
    ['SYSTEM                         ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
    ['SYSTEM_LOG                     ', clc$nominal_entry,
  clc$normal_usage_entry, 10]]
    ,
    'system_log'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$log = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      log: pmt$logs;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$log].value^.keyword_value = 'CRITICAL_WINDOW_LOG            ') THEN
      lgp$display_critical_log_attr (pvt [p$output].value^.file_value^, status);
    ELSE
      determine_log_ordinal (pvt [p$log].value^.keyword_value, log, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      lgp$display_log_attributes (log, pvt [p$output].value^.file_value^, status);
    IFEND;

  PROCEND lgp$_display_log_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'lgp$_terminate_log', EJECT ??
{ PURPOSE:
{   This is the command processor for the TERMINATE_LOG command.

  PROCEDURE [XDCL, #GATE] lgp$_terminate_log
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (osm$terl) terminate_log, terl (
{     log, t, type, l: key
{         (account_log, account, al)
{         (critical_window_log, critical_window, cwl)
{         (engineering_log, engineering, el)
{         (history_log, history, hl)
{         (security_log, security)
{         (statistic_log, statistic, sl)
{         (system_log, system)
{       keyend = $required
{     file, f: file = $optional
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 19] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [95, 1, 5, 10, 57, 48, 234],
    clc$command, 7, 3, 1, 0, 0, 0, 3, 'OSM$TERL'], [
    ['F                              ',clc$abbreviation_entry, 2],
    ['FILE                           ',clc$nominal_entry, 2],
    ['L                              ',clc$abbreviation_entry, 1],
    ['LOG                            ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$alias_entry, 1],
    ['TYPE                           ',clc$alias_entry, 1]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 710, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [19], [
    ['ACCOUNT                        ', clc$alias_entry,
  clc$normal_usage_entry, 1],
    ['ACCOUNT_LOG                    ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['AL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['CRITICAL_WINDOW                ', clc$alias_entry,
  clc$normal_usage_entry, 2],
    ['CRITICAL_WINDOW_LOG            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['CWL                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['EL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['ENGINEERING                    ', clc$alias_entry,
  clc$normal_usage_entry, 3],
    ['ENGINEERING_LOG                ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['HISTORY                        ', clc$alias_entry,
  clc$normal_usage_entry, 4],
    ['HISTORY_LOG                    ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['HL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
    ['SECURITY                       ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
    ['SECURITY_LOG                   ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
    ['SL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
    ['STATISTIC                      ', clc$alias_entry,
  clc$normal_usage_entry, 6],
    ['STATISTIC_LOG                  ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
    ['SYSTEM                         ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
    ['SYSTEM_LOG                     ', clc$nominal_entry,
  clc$normal_usage_entry, 7]]
    ],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$log = 1,
      p$file = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      date: ost$date,
      global_log: pmt$global_logs,
      log: pmt$logs,
      termination_file: fst$path;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$log].value^.keyword_value <> 'CRITICAL_WINDOW_LOG            ') THEN
      determine_log_ordinal (pvt [p$log].value^.keyword_value, log, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF log in -$pmt$global_logset[] THEN
        global_log := log;
      ELSE
        osp$set_status_abnormal ('LG', lge$not_global_log, pvt [p$log].value^.keyword_value, status);
      IFEND;
    IFEND;

{ If the user specified a termination file use it.  Otherwise, construct a default termination file
{ reference of the form $USER.log_date.$NEXT.

    IF pvt [p$file].specified THEN
      termination_file := pvt [p$file].value^.file_value^;
    ELSE
      pmp$get_date (osc$ordinal_date, date, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      termination_file := '$USER.';
      IF (pvt [p$log].value^.keyword_value = 'CRITICAL_WINDOW_LOG            ') THEN
        termination_file (clp$trimmed_string_size (termination_file) + 1, * ) := 'CRITICAL_WINDOW';
      ELSE
        CASE global_log OF
        = pmc$account_log =
          termination_file (clp$trimmed_string_size (termination_file) + 1, * ) := 'ACCOUNT';
        = pmc$engineering_log =
          termination_file (clp$trimmed_string_size (termination_file) + 1, * ) := 'ENGINEERING';
        = pmc$history_log =
          termination_file (clp$trimmed_string_size (termination_file) + 1, * ) := 'HISTORY';
        = pmc$security_log =
          termination_file (clp$trimmed_string_size (termination_file) + 1, * ) := 'SECURITY';
        = pmc$statistic_log =
          termination_file (clp$trimmed_string_size (termination_file) + 1, * ) := 'STATISTIC';
        = pmc$system_log =
          termination_file (clp$trimmed_string_size (termination_file) + 1, * ) := 'SYSTEM';
        CASEND;
      IFEND;
      termination_file (clp$trimmed_string_size (termination_file) + 1, * ) := '_';
      termination_file (clp$trimmed_string_size (termination_file) + 1, * ) := date.ordinal;
      termination_file (clp$trimmed_string_size (termination_file) + 1, * ) := '.$NEXT';
    IFEND;

    IF (pvt [p$log].value^.keyword_value = 'CRITICAL_WINDOW_LOG            ') THEN
      lgp$terminate_critical_log (termination_file (1, clp$trimmed_string_size (termination_file)), status);
    ELSE
      lgp$terminate_log (global_log, termination_file (1, clp$trimmed_string_size (termination_file)),
            status);
    IFEND;

  PROCEND lgp$_terminate_log;
?? OLDTITLE ??
MODEND lgm$logging_commands;
*DECK DECK=LGM$LOGGING_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Logging: Logging Interfaces' ??
MODULE lgm$logging_interfaces;

{ PURPOSE:
{   This module contains the gated interfaces used to access the local and global logs.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc bat$record_header_type
*copyc clt$path_display_chunks
*copyc fsc$local
*copyc jmc$system_family
*copyc lgc$logging_statistics
*copyc lge$corrupted_log
*copyc lge$corrupted_statistic
*copyc lge$end_of_log
*copyc lge$incorrect_log_ordinal
*copyc lge$statistic_buffer_required
*copyc lge$unknown_log_file_identifier
*copyc lgt$display_option_selection
*copyc lgt$open_log_file_descriptor
*copyc ofe$error_codes
*copyc oss$task_shared
*copyc ost$caller_identifier
*copyc pmt$os_name
*copyc pmt$system_log_entry
*copyc sfc$statistic_version
*copyc sft$statistic_buffer
*copyc sft$statistic_header
*copyc sft$descriptive_data
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc avp$accounting_administrator
*copyc avp$configuration_administrator
*copyc avp$system_administrator
*copyc avp$system_displays
*copyc avp$system_operator
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_file_reference
*copyc clp$fetch_display_log_indices
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$right_justify_string
*copyc clp$store_display_log_indices
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc fsp$path_element
*copyc fsp$set_evaluated_file_abnormal
*copyc i#build_adaptable_seq_pointer
*copyc i#current_sequence_position
*copyc i#move
*copyc ifp$invoke_pause_utility
*copyc lgp$add_entry_global_binary_log
*copyc lgp$add_entry_to_critical_log
*copyc lgp$add_entry_to_system_log
*copyc lgp$get_critical_log_read_info
*copyc lgp$get_entry_from_global_log
*copyc lgp$get_entry_from_critical_log
*copyc lgp$get_entry_from_global_log
*copyc lgp$get_entry_from_local_log
*copyc lgp$get_global_log_read_info
*copyc lgp$get_local_log_read_info
*copyc lgp$release_critical_log_space
*copyc lgp$release_global_log_space
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$force_access_violation
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc pmp$continue_to_cause
*copyc pmp$get_unique_name
*copyc pmp$get_date
*copyc pmp$get_executing_task_gtid
*copyc sfp$build_statistic
*copyc tmp$dispose_of_signals_flags
*copyc clv$nil_display_control
*copyc lgv$critical_log_ctl
*copyc lgv$global_log_ctl
*copyc lgv$critical_log_name
*copyc lgv$log_names
*copyc lgv$local_log_ctl
*copyc osv$task_shared_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module.', EJECT ??

{ The following constant defines the number of log messages to be displayed/processed between calls to
{ TMP$DISPOSE_OF_SIGNALS_FLAGS (which allows handling of pause breaks and terminate breaks).

  CONST
    lgc$signal_flag_process_count = 32;

  VAR
    lgv$open_log_file_descriptor: [XDCL, oss$task_shared] ^lgt$open_log_file_descriptor := NIL;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$close_log_file', EJECT ??
*copyc lgh$close_log_file

  PROCEDURE [XDCL, #GATE] lgp$close_log_file
    (    log_file_identifier: lgt$log_file_identifier;
     VAR status: ost$status);

    VAR
      next_log_file_descriptor_p: ^lgt$open_log_file_descriptor,
      current_log_file_descriptor_p: ^lgt$open_log_file_descriptor,
      previous_log_file_descriptor_p: ^lgt$open_log_file_descriptor;

    status.normal := TRUE;

{ Find the open log file descriptor.

    current_log_file_descriptor_p := lgp$open_log_file_descriptor (log_file_identifier);
    IF current_log_file_descriptor_p = NIL THEN
      osp$set_status_abnormal ('LG', lge$unknown_log_file_identifier, log_file_identifier, status);
      RETURN;
    IFEND;

{ If this is not an active log, close the log file.

    IF NOT current_log_file_descriptor_p^.active_log THEN
      fsp$close_file (current_log_file_descriptor_p^.bam_file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Remove the open log file descriptor.

    previous_log_file_descriptor_p := current_log_file_descriptor_p^.backward;
    next_log_file_descriptor_p := current_log_file_descriptor_p^.forward;
    IF previous_log_file_descriptor_p = NIL THEN
      lgv$open_log_file_descriptor := next_log_file_descriptor_p;
      IF lgv$open_log_file_descriptor <> NIL THEN
        lgv$open_log_file_descriptor^.backward := NIL;
      IFEND;
    ELSE
      previous_log_file_descriptor_p^.forward := next_log_file_descriptor_p;
      IF next_log_file_descriptor_p <> NIL THEN
        next_log_file_descriptor_p^.backward := previous_log_file_descriptor_p;
      IFEND;
    IFEND;
    FREE current_log_file_descriptor_p IN osv$task_shared_heap^;

  PROCEND lgp$close_log_file;
?? OLDTITLE ??
?? NEWTITLE := 'lgp$display_log', EJECT ??
*copyc lgh$display_log

  PROCEDURE [XDCL, #GATE] lgp$display_log
    (    display_log_kind: clt$display_log_kind;
         display_option_selection: lgt$display_option_selection;
         output: fst$file_reference;
     VAR status: ost$status);

*copy clv$display_variables

    VAR
      backspace_count: ost$segment_length,
      byte_address: amt$file_byte_address,
      caller_identifier: ost$caller_identifier,
      default_ring_attributes: amt$ring_attributes,
      display_line: ^string ( * ),
      log_entry_index: 1 .. lgc$maximum_log_entry_size + 1,
      display_line_size: lgt$log_entry_size,
      display_control: clt$display_control,
      ending_offset: amt$file_byte_address,
      ignore_status: ost$status,
      indentation_size: 0 .. 2,
      indices: clt$display_log_indices,
      log_cycle: lgt$log_cycle,
      log_data: ^SEQ ( * ),
      log_entries_displayed: integer,
      log_entry_p: ^string ( * ),
      log_entry_size: lgt$log_entry_size;

?? NEWTITLE := 'condition_handler', EJECT ??
{ PURPOSE:
{   This condition handler is used to handle interactive pause break and terminate break conditions.  It also
{   insures that the output file is closed in the event of an error.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      IF condition.selector = ifc$interactive_condition THEN
        IF condition.interactive_condition = ifc$pause_break THEN
          ifp$invoke_pause_utility (local_status);
        ELSEIF condition.interactive_condition = ifc$terminate_break THEN
          osp$set_status_from_condition ('LG', condition, save_area, status, local_status);
          EXIT lgp$display_log;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        clp$close_display (display_control, local_status);
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'clp$new_page_procedure', EJECT ??
*copy clp$new_page_procedure
?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle', EJECT ??

    PROCEDURE put_subtitle
      (    display_control: clt$display_control;
       VAR status: ost$status);

{ The display_log output has no subtitles, this is merely a dummy routine used to keep the module consistent
{ with those that do produce subtitles.

    PROCEND put_subtitle;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    #CALLER_ID (caller_identifier);

{ If the request is to display the system or the critical window log, make sure the user has
{ the appropriate authority.

    IF ((display_log_kind = clc$display_system_log) OR
          (display_log_kind = clc$display_critical_window_log)) AND
          NOT (avp$system_operator () OR avp$system_displays ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_operation or system_displays', status);
      RETURN;
    IFEND;

{ Initialize the display control variable.

    display_control := clv$nil_display_control;
    #SPOIL (display_control);

    osp$establish_condition_handler (^condition_handler, TRUE);

  /display_log/
    BEGIN

{ Open the output file.

      default_ring_attributes.r1 := caller_identifier.ring;
      default_ring_attributes.r2 := caller_identifier.ring;
      default_ring_attributes.r3 := caller_identifier.ring;
      clp$open_display_reference (output, ^clp$new_page_procedure, fsc$list, default_ring_attributes,
            display_control, status);
      IF NOT status.normal THEN
        EXIT /display_log/;
      IFEND;
      clv$titles_built := FALSE;
      IF display_log_kind = clc$display_system_log THEN
        clv$command_name := 'display_system_log';
      ELSEIF display_log_kind = clc$display_critical_window_log THEN
        clv$command_name := 'display_critical_window_log';
      ELSE
        clv$command_name := 'display_log';
      IFEND;
      IF display_control.page_width < clc$narrow_page_width THEN
        display_control.page_width := clc$narrow_page_width;
      IFEND;

{ Allocate space to hold the copies of the log entries and to build the display output.

      PUSH log_entry_p: [lgc$maximum_log_entry_size];
      PUSH display_line: [display_control.page_width];

{ Initialize the log information needed to read the log.

      IF display_option_selection.display_options = lgc$count THEN
        backspace_count := display_option_selection.count;
      ELSE
        backspace_count := 0;
      IFEND;

      IF display_log_kind = clc$display_system_log THEN
        lgp$get_global_log_read_info (pmc$system_log, backspace_count, log_cycle, log_data, ending_offset,
              status);
      ELSEIF display_log_kind = clc$display_critical_window_log THEN
        lgp$get_critical_log_read_info (backspace_count, log_cycle,
              log_data, ending_offset, status);
      ELSE
        lgp$get_local_log_read_info (pmc$job_log, backspace_count, log_cycle, log_data, ending_offset,
              status);
      IFEND;
      IF NOT status.normal THEN
        EXIT /display_log/;
      IFEND;

      clp$fetch_display_log_indices (indices);

      IF display_option_selection.display_options = lgc$all THEN
        RESET log_data;
      ELSEIF display_option_selection.display_options = lgc$last THEN
        IF (indices [display_log_kind].last_display_log_entry = 0) OR
              (indices [display_log_kind].last_log_cycle <> log_cycle) THEN
          RESET log_data;
        ELSE
          i#build_adaptable_seq_pointer (#RING (log_data), #SEGMENT (log_data), #OFFSET (log_data),
                #SIZE (log_data^), indices [display_log_kind].last_display_log_entry, log_data);
        IFEND;
      IFEND;

{ Save the ending offset and log cycle.

      indices [display_log_kind].last_display_log_entry := ending_offset;
      indices [display_log_kind].last_log_cycle := log_cycle;
      clp$store_display_log_indices (indices);

{ Display the contents of the log.

      log_entries_displayed := 0;
      WHILE i#current_sequence_position (log_data) <= ending_offset DO

{ Periodically allow signals and flags to be processed.  This allows the user to interupt the display.

        IF (log_entries_displayed MOD lgc$signal_flag_process_count) = 0 THEN
          tmp$dispose_of_signals_flags (tmc$long_term_wait);
        IFEND;
        log_entries_displayed := log_entries_displayed + 1;

{ Get the log entry to be displayed.

        IF display_log_kind = clc$display_system_log THEN
          lgp$get_entry_from_global_log (pmc$system_log, log_cycle, log_data, log_entry_size,
                #SEQ (log_entry_p^) ^, status);
        ELSEIF display_log_kind = clc$display_critical_window_log THEN
          lgp$get_entry_from_critical_log (log_cycle, log_data, log_entry_size,
                #SEQ (log_entry_p^) ^, status);
        ELSE
          lgp$get_entry_from_local_log (pmc$job_log, log_cycle, log_data, log_entry_size,
                #SEQ (log_entry_p^) ^, status);
        IFEND;
        IF NOT status.normal THEN
          EXIT /display_log/;
        IFEND;

{ Display the log entry, wrapping to more than one line if necessary.

        log_entry_index := 1;
        indentation_size := 0;

        WHILE log_entry_index <= log_entry_size DO
          IF (log_entry_size - log_entry_index + 1) <= (display_control.page_width - indentation_size) THEN
            display_line_size := log_entry_size - log_entry_index + 1;
          ELSE
            display_line_size := display_control.page_width - indentation_size;
          IFEND;
          display_line^ (indentation_size + 1, display_line_size) :=
                log_entry_p^ (log_entry_index, display_line_size);
          clp$put_display (display_control, display_line^ (1, indentation_size + display_line_size), clc$trim,
                status);
          IF NOT status.normal THEN
            EXIT /display_log/;
          IFEND;
          log_entry_index := log_entry_index + display_line_size;
          indentation_size := 2;
          display_line^ (1, indentation_size) := '  ';
        WHILEND;
      WHILEND;
    END /display_log/;

{ Clear the end of log status or log cycles do not match error if necessary.

    IF NOT status.normal AND ((status.condition = lge$end_of_log) OR
          (status.condition = lge$log_cycles_do_not_match)) THEN
      status.normal := TRUE;
    IFEND;

    clp$close_display (display_control, ignore_status);
    osp$disestablish_cond_handler;

  PROCEND lgp$display_log;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$display_critical_log_attr', EJECT ??
{ PURPOSE:
{   Displays the information contained in the critical window log control descriptor.

  PROCEDURE [XDCL, #GATE] lgp$display_critical_log_attr
    (    output: fst$file_reference;
     VAR status: ost$status);

*copy clv$display_variables

    VAR
      caller_identifier: ost$caller_identifier,
      default_ring_attributes: amt$ring_attributes,
      display_line: string (osc$max_string_size),
      display_line_size: integer,
      display_control: clt$display_control,
      ignore_status: ost$status,
      log_control_descriptor_p: ^lgt$critical_log_control_desc;

?? NEWTITLE := 'condition_handler', EJECT ??
{ PURPOSE:
{   This condition handler is used to handle interactive pause break and terminate break conditions.  It also
{   insures that the output file is closed in the event of an error.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      IF condition.selector = ifc$interactive_condition THEN
        IF condition.interactive_condition = ifc$pause_break THEN
          ifp$invoke_pause_utility (local_status);
        ELSEIF condition.interactive_condition = ifc$terminate_break THEN
          osp$set_status_from_condition ('LG', condition, save_area, status, local_status);
          EXIT lgp$display_critical_log_attr;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        clp$close_display (display_control, local_status);
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'clp$new_page_procedure', EJECT ??
*copy clp$new_page_procedure
?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle', EJECT ??

    PROCEDURE put_subtitle
      (    display_control: clt$display_control;
       VAR status: ost$status);

{ The display_critical_log_attr output has no subtitles, this is merely a dummy routine used to keep the
{ module consistent with those that do produce subtitles.

    PROCEND put_subtitle;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    #CALLER_ID (caller_identifier);

{ Make sure the caller has system operation or system displays capability.

    IF NOT (avp$system_operator () OR avp$system_displays ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_operation or system_displays', status);
      RETURN;
    IFEND;

{ Initialize the display control variable.

    display_control := clv$nil_display_control;
    #SPOIL (display_control);

    osp$establish_condition_handler (^condition_handler, TRUE);

  /display_attributes/
    BEGIN

{ Open the output file.

      default_ring_attributes.r1 := caller_identifier.ring;
      default_ring_attributes.r2 := caller_identifier.ring;
      default_ring_attributes.r3 := caller_identifier.ring;
      clp$open_display_reference (output, ^clp$new_page_procedure, fsc$list, default_ring_attributes,
            display_control, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;
      clv$titles_built := FALSE;
      clv$command_name := 'display_critical_log_attributes';
      IF display_control.page_width < clc$narrow_page_width THEN
        display_control.page_width := clc$narrow_page_width;
      IFEND;

{ Get a pointer to the critical window log control descriptor.

      log_control_descriptor_p := ^lgv$critical_log_ctl;

{ Display the log name.

      STRINGREP (display_line, display_line_size, ' Log name: ',
            lgv$critical_log_name);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the log cycle.

      STRINGREP (display_line, display_line_size, ' Log cycle: ', log_control_descriptor_p^.log_cycle);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the log data PVA.

      STRINGREP (display_line, display_line_size, ' Log data PVA: ', log_control_descriptor_p^.log_data);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the log data size.

      STRINGREP (display_line, display_line_size, ' Log data size: ',
            #SIZE (log_control_descriptor_p^.log_data^));
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the log data position.

      STRINGREP (display_line, display_line_size, ' Log data position: ',
            i#current_sequence_position (log_control_descriptor_p^.log_data));
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the trailing log entry header pointer.

      STRINGREP (display_line, display_line_size, ' Trailing log entry header pointer: ',
            log_control_descriptor_p^.trailing_log_entry_header_p);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the maximum size.

      STRINGREP (display_line, display_line_size, ' Maximum size: ', log_control_descriptor_p^.maximum_size);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the preallocation size.

      STRINGREP (display_line, display_line_size, ' Preallocation size: ',
            log_control_descriptor_p^.preallocation_size);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the critical flag.

      STRINGREP (display_line, display_line_size, ' Critical: ', log_control_descriptor_p^.critical_log);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the lost message count.

      STRINGREP (display_line, display_line_size, ' Lost message count: ',
            log_control_descriptor_p^.lost_message_count);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display log full indicator.

      STRINGREP (display_line, display_line_size, ' Log full: ', log_control_descriptor_p^.log_full);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);

    END /display_attributes/;

    clp$close_display (display_control, ignore_status);
    osp$disestablish_cond_handler;

  PROCEND lgp$display_critical_log_attr;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$display_log_attributes', EJECT ??
{ PURPOSE:
{   Displays the information contained in the log control descriptor.

  PROCEDURE [XDCL, #GATE] lgp$display_log_attributes
    (    log: pmt$logs;
         output: fst$file_reference;
     VAR status: ost$status);

*copy clv$display_variables

    VAR
      caller_identifier: ost$caller_identifier,
      default_ring_attributes: amt$ring_attributes,
      display_line: string (osc$max_string_size),
      display_line_size: integer,
      display_control: clt$display_control,
      global_log: pmt$global_logs,
      ignore_status: ost$status,
      log_control_descriptor_p: ^lgt$log_control_descriptor;

?? NEWTITLE := 'condition_handler', EJECT ??
{ PURPOSE:
{   This condition handler is used to handle interactive pause break and terminate break conditions.  It also
{   insures that the output file is closed in the event of an error.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      IF condition.selector = ifc$interactive_condition THEN
        IF condition.interactive_condition = ifc$pause_break THEN
          ifp$invoke_pause_utility (local_status);
        ELSEIF condition.interactive_condition = ifc$terminate_break THEN
          osp$set_status_from_condition ('LG', condition, save_area, status, local_status);
          EXIT lgp$display_log_attributes;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        clp$close_display (display_control, local_status);
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'clp$new_page_procedure', EJECT ??
*copy clp$new_page_procedure
?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle', EJECT ??

    PROCEDURE put_subtitle
      (    display_control: clt$display_control;
       VAR status: ost$status);

{ The display_log_attributes output has no subtitles, this is merely a dummy routine used to keep the module
{ consistent with those that do produce subtitles.

    PROCEND put_subtitle;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    #CALLER_ID (caller_identifier);

{ Make sure the caller has system operation or system displays capability.

    IF NOT (avp$system_operator () OR avp$system_displays ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_operation or system_displays', status);
      RETURN;
    IFEND;

{ Initialize the display control variable.

    display_control := clv$nil_display_control;
    #SPOIL (display_control);

    osp$establish_condition_handler (^condition_handler, TRUE);

  /display_attributes/
    BEGIN

{ Open the output file.

      default_ring_attributes.r1 := caller_identifier.ring;
      default_ring_attributes.r2 := caller_identifier.ring;
      default_ring_attributes.r3 := caller_identifier.ring;
      clp$open_display_reference (output, ^clp$new_page_procedure, fsc$list, default_ring_attributes,
            display_control, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;
      clv$titles_built := FALSE;
      clv$command_name := 'display_log_attributes';
      IF display_control.page_width < clc$narrow_page_width THEN
        display_control.page_width := clc$narrow_page_width;
      IFEND;

{ Get a pointer to the appropriate log control descriptor.

      IF log IN -$pmt$global_logset [] THEN
        global_log := log;
        log_control_descriptor_p := ^lgv$global_log_ctl [global_log];
      ELSE
        log_control_descriptor_p := lgv$local_log_ctl [log];
      IFEND;

{ Display the log name.

      STRINGREP (display_line, display_line_size, ' Log name: ',
            lgv$log_names [log_control_descriptor_p^.log]);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the log cycle.

      STRINGREP (display_line, display_line_size, ' Log cycle: ', log_control_descriptor_p^.log_cycle);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the log data PVA.

      STRINGREP (display_line, display_line_size, ' Log data PVA: ', log_control_descriptor_p^.log_data);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the log data size.

      STRINGREP (display_line, display_line_size, ' Log data size: ',
            #SIZE (log_control_descriptor_p^.log_data^));
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the log data position.

      STRINGREP (display_line, display_line_size, ' Log data position: ',
            i#current_sequence_position (log_control_descriptor_p^.log_data));
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the trailing log entry header pointer.

      STRINGREP (display_line, display_line_size, ' Trailing log entry header pointer: ',
            log_control_descriptor_p^.trailing_log_entry_header_p);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the maximum size.

      STRINGREP (display_line, display_line_size, ' Maximum size: ', log_control_descriptor_p^.maximum_size);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the preallocation size.

      STRINGREP (display_line, display_line_size, ' Preallocation size: ',
            log_control_descriptor_p^.preallocation_size);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the critical flag.

      STRINGREP (display_line, display_line_size, ' Critical: ', log_control_descriptor_p^.critical_log);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display the lost message count.

      STRINGREP (display_line, display_line_size, ' Lost message count: ',
            log_control_descriptor_p^.lost_message_count);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_attributes/;
      IFEND;

{ Display log full indicator.

      STRINGREP (display_line, display_line_size, ' Log full: ', log_control_descriptor_p^.log_full);
      clp$put_display (display_control, display_line (1, display_line_size), clc$trim, status);

    END /display_attributes/;

    clp$close_display (display_control, ignore_status);
    osp$disestablish_cond_handler;

  PROCEND lgp$display_log_attributes;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$get_next_log_entry', EJECT ??
{ Retrieves the next log entry from a log.

  PROCEDURE [XDCL, #GATE] lgp$get_next_log_entry
    (    log_file_identifier: lgt$log_file_identifier;
         statistic_buffer_p: ^sft$statistic_buffer;
     VAR log_entry_p: ^lgt$log_entry;
     VAR status: ost$status);

    VAR
      bam_record_header_p: ^bat$record_header,
      caller_identifier: ost$caller_identifier,
      local_log_data: ^SEQ(*),
      log_entry_size: lgt$log_entry_size,
      open_log_file_descriptor_p: ^lgt$open_log_file_descriptor;

    status.normal := TRUE;
    #CALLER_ID (caller_identifier);

{ Find the open log file descriptor.

    open_log_file_descriptor_p := lgp$open_log_file_descriptor (log_file_identifier);
    IF open_log_file_descriptor_p = NIL THEN
      osp$set_status_abnormal ('LG', lge$unknown_log_file_identifier, log_file_identifier, status);
      RETURN;
    IFEND;

{ Make sure the caller has at least the same ring privilege as that used during the open request.

    IF caller_identifier.ring > open_log_file_descriptor_p^.open_ring THEN
      osp$force_access_violation;
    IFEND;

{ Get the next statistic from the log.

    IF open_log_file_descriptor_p^.active_log THEN
      IF statistic_buffer_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$statistic_buffer_required, 'LGP$GET_NEXT_STATISTIC', status);
        RETURN;
      IFEND;
      log_entry_p := statistic_buffer_p;
      IF open_log_file_descriptor_p^.global_log THEN
        lgp$get_entry_from_global_log (open_log_file_descriptor_p^.log, open_log_file_descriptor_p^.log_cycle,
              open_log_file_descriptor_p^.log_data, log_entry_size, log_entry_p^, status);
      ELSE
        lgp$get_entry_from_local_log (open_log_file_descriptor_p^.log, open_log_file_descriptor_p^.log_cycle,
              open_log_file_descriptor_p^.log_data, log_entry_size, log_entry_p^, status);
      IFEND;
    ELSE

{ Make a copy of the log_data sequence pointer to use until the log entry has been retrieved.

      local_log_data := open_log_file_descriptor_p^.log_data;

{ Get the BAM record header.

      NEXT bam_record_header_p IN local_log_data;
      IF bam_record_header_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$end_of_log, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, open_log_file_descriptor_p^.file_reference,
              status);
        RETURN;
      IFEND;
      log_entry_size := bam_record_header_p^.length;

{ Get a pointer to the log entry.

      NEXT log_entry_p: [[REP log_entry_size OF cell]] IN local_log_data;
      IF log_entry_p = NIL THEN
        osp$set_status_abnormal ('LG', lge$end_of_log, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, open_log_file_descriptor_p^.file_reference,
              status);
        RETURN;
      IFEND;

{ Update the log_data pointer in the open log file descriptor.

      open_log_file_descriptor_p^.log_data := local_log_data;

    IFEND;

  PROCEND lgp$get_next_log_entry;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$open_log_file', EJECT ??
*copyc lgh$open_log_file

  PROCEDURE [XDCL, #GATE] lgp$open_log_file
    (    log_file: fst$file_reference;
     VAR active_log: boolean;
     VAR log_file_identifier: lgt$log_file_identifier;
     VAR status: ost$status);

    VAR
      attachment_options: ^fst$attachment_options,
      caller_identifier: ost$caller_identifier,
      contains_data: boolean,
      ending_offset: amt$file_byte_address,
      evaluated_file_reference: fst$evaluated_file_reference,
      get_attributes: ^amt$get_attributes,
      file_exists: boolean,
      file_previously_opened: boolean,
      global_log: pmt$global_logs,
      log: pmt$logs,
      log_name: ost$name,
      new_open_log_file_descriptor_p: ^lgt$open_log_file_descriptor,
      segment_pointer: amt$segment_pointer,
      trailing_log_entry_header: lgt$log_entry_header;

    status.normal := TRUE;
    #CALLER_ID (caller_identifier);

{ Evaluate the file reference that was specified on the call.

    clp$evaluate_file_reference (log_file, $clt$file_ref_parsing_options [], TRUE, evaluated_file_reference,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Determine if the specified log is one of the active logs.

    active_log := FALSE;
    IF (fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local) THEN
      log_name := fsp$path_element (^evaluated_file_reference, 2) ^;
    ELSEIF (fsp$path_element (^evaluated_file_reference, 1) ^ = jmc$system_family) AND
          (fsp$path_element (^evaluated_file_reference, 2) ^ = jmc$system_user) THEN
      log_name := fsp$path_element (^evaluated_file_reference, 3) ^;
    ELSE
      log_name := osc$null_name;
    IFEND;

    IF log_name <> osc$null_name THEN
    /check_for_active_log/
      FOR log := LOWERVALUE (log) TO UPPERVALUE (log) DO
        IF log_name = lgv$log_names [log] THEN
          active_log := TRUE;
          EXIT /check_for_active_log/;
        IFEND;
      FOREND /check_for_active_log/;
    IFEND;

{ If this is an active global log, make sure the user is allowed to access the log.

    IF active_log AND (log IN (-$pmt$global_logset [])) THEN
      global_log := log;
      verify_authority (caller_identifier, global_log, {critical_window_log = } FALSE, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Get a unique name to use as the log file identifier.

    pmp$get_unique_name (log_file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Allocate an open log file descriptor and initialize it.

    ALLOCATE new_open_log_file_descriptor_p IN osv$task_shared_heap^;
    new_open_log_file_descriptor_p^.log_file_identifier := log_file_identifier;
    new_open_log_file_descriptor_p^.active_log := active_log;
    new_open_log_file_descriptor_p^.open_ring := caller_identifier.ring;

{ If this is an active log, get the necessary information from the log control descriptor.  Otherwise, open
{ the specified file for segment access.

    IF active_log THEN
      new_open_log_file_descriptor_p^.log := log;
      IF log IN (-$pmt$global_logset []) THEN
        new_open_log_file_descriptor_p^.global_log := TRUE;
        lgp$get_global_log_read_info (log, 0, new_open_log_file_descriptor_p^.log_cycle,
              new_open_log_file_descriptor_p^.log_data, ending_offset, status);
      ELSE
        new_open_log_file_descriptor_p^.global_log := FALSE;
        lgp$get_local_log_read_info (log, 0, new_open_log_file_descriptor_p^.log_cycle,
              new_open_log_file_descriptor_p^.log_data, ending_offset, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET new_open_log_file_descriptor_p^.log_data;
    ELSE

{ Verify the ring privilege of the caller against the file attributes.

      PUSH get_attributes: [1 .. 1];
      get_attributes^ [1].key := amc$ring_attributes;
      amp$get_file_attributes (log_file, get_attributes^, file_exists, file_previously_opened, contains_data,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF caller_identifier.ring > get_attributes^ [1].ring_attributes.r2 THEN
        fsp$set_evaluated_file_abnormal (evaluated_file_reference, ame$ring_validation_error, amc$open_req,
              '', status);
        RETURN;
      IFEND;

      PUSH attachment_options: [1 .. 6];
      attachment_options^ [1].selector := fsc$access_and_share_modes;
      attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options^ [1].access_modes.value := $fst$file_access_options [fsc$read];
      attachment_options^ [1].share_modes.selector := fsc$determine_from_access_modes;
      attachment_options^ [2].selector := fsc$create_file;
      attachment_options^ [2].create_file := FALSE;
      attachment_options^ [3].selector := fsc$open_position;
      attachment_options^ [3].open_position := amc$open_at_boi;
      attachment_options^ [4].selector := fsc$private_read;
      attachment_options^ [4].private_read := TRUE;
      attachment_options^ [5].selector := fsc$free_behind;
      attachment_options^ [5].free_behind := TRUE;
      attachment_options^ [6].selector := fsc$sequential_access;
      attachment_options^ [6].sequential_access := TRUE;

      fsp$open_file (log_file, amc$segment, attachment_options, NIL, NIL, NIL, NIL,
            new_open_log_file_descriptor_p^.bam_file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$get_segment_pointer (new_open_log_file_descriptor_p^.bam_file_identifier, amc$sequence_pointer,
            segment_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET segment_pointer.sequence_pointer;
      new_open_log_file_descriptor_p^.file_reference := log_file;
      new_open_log_file_descriptor_p^.log_data := segment_pointer.sequence_pointer;
    IFEND;

{ Link the new open log file descriptor in the list.

    new_open_log_file_descriptor_p^.backward := NIL;
    new_open_log_file_descriptor_p^.forward := lgv$open_log_file_descriptor;
    IF lgv$open_log_file_descriptor <> NIL THEN
      lgv$open_log_file_descriptor^.backward := new_open_log_file_descriptor_p;
    IFEND;
    lgv$open_log_file_descriptor := new_open_log_file_descriptor_p;

  PROCEND lgp$open_log_file;
?? OLDTITLE ??
?? NEWTITLE := 'lgp$open_log_file_descriptor', EJECT ??

  FUNCTION [XDCL, #GATE] lgp$open_log_file_descriptor
    (    log_file_identifier: lgt$log_file_identifier): ^lgt$open_log_file_descriptor;

    VAR
      current_log_file_descriptor_p: ^lgt$open_log_file_descriptor;

    current_log_file_descriptor_p := lgv$open_log_file_descriptor;
    WHILE current_log_file_descriptor_p <> NIL DO
      IF current_log_file_descriptor_p^.log_file_identifier = log_file_identifier THEN
        lgp$open_log_file_descriptor := current_log_file_descriptor_p;
        RETURN;
      IFEND;
      current_log_file_descriptor_p := current_log_file_descriptor_p^.forward;
    WHILEND;
    lgp$open_log_file_descriptor := NIL;

  FUNCEND lgp$open_log_file_descriptor;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$rewind_log_file', EJECT ??
*copyc lgh$rewind_log_file

  PROCEDURE [XDCL, #GATE] lgp$rewind_log_file
    (    log_file_identifier: lgt$log_file_identifier;
     VAR status: ost$status);

    VAR
      ending_offset: amt$file_byte_address,
      log_file_descriptor_p: ^lgt$open_log_file_descriptor;

    status.normal := TRUE;

{ Find the open log file descriptor.

    log_file_descriptor_p := lgp$open_log_file_descriptor (log_file_identifier);
    IF log_file_descriptor_p = NIL THEN
      osp$set_status_abnormal ('LG', lge$unknown_log_file_identifier, log_file_identifier, status);
      RETURN;
    IFEND;

{ If this is an active log, get the current information about the log.

    IF log_file_descriptor_p^.active_log THEN
      IF log_file_descriptor_p^.global_log THEN
        lgp$get_global_log_read_info (log_file_descriptor_p^.log, 0, log_file_descriptor_p^.log_cycle,
              log_file_descriptor_p^.log_data, ending_offset, status);
      ELSE
        lgp$get_local_log_read_info (log_file_descriptor_p^.log, 0, log_file_descriptor_p^.log_cycle,
              log_file_descriptor_p^.log_data, ending_offset, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Reset the log data sequence pointer to start at the beginning.

    RESET log_file_descriptor_p^.log_data;

  PROCEND lgp$rewind_log_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$terminate_critical_log', EJECT ??
*copyc lgh$terminate_critical_log

  PROCEDURE [XDCL, #GATE] lgp$terminate_critical_log
    (    termination_file: fst$file_reference;
     VAR status: ost$status);

?? NEWTITLE := 'block_exit_handler', EJECT ??

{ PURPOSE:
{   This block exit condition handler makes sure the termination file is closed if an error occurs.

    PROCEDURE block_exit_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (termination_file_id, ignore_status);

    PROCEND block_exit_handler;
?? OLDTITLE, EJECT ??

    VAR
      caller_identifier: ost$caller_identifier,
      file_attachment_options: ^fst$attachment_options,
      ignore_status: ost$status,
      mandated_creation_attributes: ^fst$file_cycle_attributes,
      termination_file_id: amt$file_identifier;

    status.normal := TRUE;
    #CALLER_ID (caller_identifier);

{ Verify that the user has the authority to terminate the critical window log.

    verify_authority (caller_identifier, pmc$system_log, {critical_window_log = } TRUE, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^block_exit_handler);

{ Set up the file attributes for the termination file.

    PUSH file_attachment_options: [1 .. 1];
    file_attachment_options^ [1].selector := fsc$access_and_share_modes;
    file_attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
    file_attachment_options^ [1].access_modes.value := $fst$file_access_options
          [fsc$append, fsc$modify, fsc$shorten];
    file_attachment_options^ [1].share_modes.selector := fsc$specific_share_modes;
    file_attachment_options^ [1].share_modes.value := $fst$file_access_options [];

    PUSH mandated_creation_attributes: [1 .. 2];
    mandated_creation_attributes^ [1].selector := fsc$file_contents_and_processor;
    mandated_creation_attributes^ [1].file_contents := fsc$legible_data;
    mandated_creation_attributes^ [1].file_processor := fsc$unknown_processor;
    mandated_creation_attributes^ [2].selector := fsc$ring_attributes;
    mandated_creation_attributes^ [2].ring_attributes.r1 := caller_identifier.ring;
    mandated_creation_attributes^ [2].ring_attributes.r2 := caller_identifier.ring;
    mandated_creation_attributes^ [2].ring_attributes.r3 := caller_identifier.ring;

{ Open the termination file.

    fsp$open_file (termination_file, amc$record, file_attachment_options, {default_creation_attributes} NIL,
          mandated_creation_attributes, {attribute_validation} NIL, {attribute_override} NIL,
          termination_file_id, status);
    #SPOIL (termination_file_id);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

{ Copy the log to the termination file and release any unneeded disk space.

    lgp$terminate_critical_log_proc (termination_file_id, status);

{ Close the termination file.

    fsp$close_file (termination_file_id, ignore_status);

    osp$disestablish_cond_handler;

  PROCEND lgp$terminate_critical_log;
?? OLDTITLE ??
?? NEWTITLE := 'lgp$terminate_critical_log_proc', EJECT ??
{ PURPOSE:
{   This request copies the existing log entries from an active log to another file and then releases the
{   unneeded disk space occupied by the active log.

  PROCEDURE lgp$terminate_critical_log_proc
    (    termination_file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      caller_identifier: ost$caller_identifier,
      critical_log_entry: ^pmt$system_log_entry,
      date: ost$date,
      end_of_log: boolean,
      ending_offset: amt$file_byte_address,
      first_log_entry_header_p: ^lgt$log_entry_header,
      global_task_id: ost$global_task_id,
      log_cycle: lgt$log_cycle,
      log_data: ^SEQ ( * ),
      log_entries_processed: integer,
      log_entry_p: ^lgt$log_entry,
      log_entry_size: lgt$log_entry_size,
      log_time: ost$time,
      message_text: ost$string,
      next_log_entry_header_p: ^lgt$log_entry_header,
      previous_log_data: ^SEQ ( * ),
      statistic: ^SEQ ( * ),
      statistic_descriptive_data: ^sft$descriptive_data,
      statistic_header: ^sft$statistic_header,
      termination_id: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??
{ PURPOSE:
{   This condition handler is used to handle interactive pause break and terminate break conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      IF condition.selector = ifc$interactive_condition THEN
        IF condition.interactive_condition = ifc$pause_break THEN
          ifp$invoke_pause_utility (local_status);
        ELSEIF condition.interactive_condition = ifc$terminate_break THEN
          osp$set_status_from_condition ('LG', condition, save_area, status, local_status);
          EXIT lgp$terminate_critical_log_proc;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    #CALLER_ID (caller_identifier);

{ Verify that the user has the authority to terminate the critical window log.

    verify_authority (caller_identifier, pmc$system_log, {critical_window_log = } TRUE, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Get the log data pointer and the current ending offset for the log.

    lgp$get_critical_log_read_info (0, log_cycle, log_data, ending_offset, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Construct the log termination message and place it in the appropriate log.

    pmp$get_unique_name (termination_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_date (osc$month_date, date, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    message_text.value := 'Log continued,  current date is';
    message_text.size := clp$trimmed_string_size (message_text.value);
    message_text.value (message_text.size + 2, * ) := date.month;
    message_text.size := clp$trimmed_string_size (message_text.value);
    message_text.value (message_text.size + 1, * ) := '.  Log termination identifier =';
    message_text.size := clp$trimmed_string_size (message_text.value);
    message_text.value (message_text.size + 2, * ) := termination_id;
    message_text.size := clp$trimmed_string_size (message_text.value);

    lgp$add_entry_to_critical_log (message_text.value (1, message_text.size), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Allocate a log entry and construct pointers to the important information in the log entry.

    PUSH log_entry_p: [[REP lgc$maximum_log_entry_size OF cell]];
    RESET log_entry_p;
    NEXT critical_log_entry: [message_text.size] IN log_entry_p;

{ Copy the log entries from the beginning of the log until the log termination message is found.

    osp$establish_condition_handler (^condition_handler, FALSE);
    log_entries_processed := 0;

    RESET log_data;
    end_of_log := FALSE;

  /copy_log/
    REPEAT

{ Periodically allow signals and flags to be processed.  This allows the user to interupt the display.

      IF (log_entries_processed MOD lgc$signal_flag_process_count) = 0 THEN
        tmp$dispose_of_signals_flags (tmc$long_term_wait);
      IFEND;
      log_entries_processed := log_entries_processed + 1;

{ Save the log data pointer before the read so that it can be used to construct a pointer to the log entry
{ header for the log termination message when it is found.

      previous_log_data := log_data;

{ Get the next log entry.

      lgp$get_entry_from_critical_log (log_cycle, log_data, log_entry_size, log_entry_p^, status);
      IF NOT status.normal THEN
        IF status.condition = lge$end_of_log THEN
          status.normal := TRUE;
          end_of_log := TRUE;
          EXIT /copy_log/;
        ELSE
          osp$disestablish_cond_handler;
          RETURN;
        IFEND;
      IFEND;

{ Check if the log entry contains the log termination message.  If it does, update the message before writing
{ it to the termination file.

      IF i#current_sequence_position (log_data) > ending_offset THEN
        IF critical_log_entry^.text (1, message_text.size) = message_text.value (1, message_text.size) THEN
          critical_log_entry^.text (5, 11) := 'terminated,';
          end_of_log := TRUE;
        IFEND;
      IFEND;

{ Write the log entry to the termination file.

      amp$put_next (termination_file_id, log_entry_p, log_entry_size, byte_address, status);
      IF NOT status.normal THEN
        osp$disestablish_cond_handler;
        RETURN;
      IFEND;
    UNTIL end_of_log {/copy_log/} ;

    osp$disestablish_cond_handler;

{ Get a pointer to the log entry header for the log termination log entry.  This will be the first log entry
{ header when termination has completed.

    NEXT first_log_entry_header_p IN previous_log_data;
    IF first_log_entry_header_p = NIL THEN
      osp$set_status_abnormal ('LG', lge$corrupted_log, lgv$critical_log_name, status);
      RETURN;
    IFEND;

{ Move the log entries that were added since log termination began to the beginning of the log and release the
{ unneeded disk space.

    lgp$release_critical_log_space (log_cycle, first_log_entry_header_p, status);

  PROCEND lgp$terminate_critical_log_proc;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$terminate_log', EJECT ??
*copyc lgh$terminate_log

  PROCEDURE [XDCL, #GATE] lgp$terminate_log
    (    global_log: pmt$global_logs;
         termination_file: fst$file_reference;
     VAR status: ost$status);

?? NEWTITLE := 'block_exit_handler', EJECT ??

{ PURPOSE:
{   This block exit condition handler makes sure the termination file is closed if an error occurs.

    PROCEDURE block_exit_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (termination_file_id, ignore_status);

    PROCEND block_exit_handler;
?? OLDTITLE, EJECT ??

    VAR
      caller_identifier: ost$caller_identifier,
      file_attachment_options: ^fst$attachment_options,
      ignore_status: ost$status,
      mandated_creation_attributes: ^fst$file_cycle_attributes,
      termination_file_id: amt$file_identifier;

    status.normal := TRUE;
    #CALLER_ID (caller_identifier);

{ Verify that a valid log ordinal has been specified.

    IF NOT (global_log IN -$pmt$global_logset []) THEN
      osp$set_status_abnormal ('LG', lge$incorrect_log_ordinal, 'LGP$TERMINATE_LOG', status);
      RETURN;
    IFEND;

{ Verify that the user has the authority to terminate the specified log.

    verify_authority (caller_identifier, global_log, {critical_window_log = } FALSE, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^block_exit_handler);

{ Set up the file attributes for the termination file.

    PUSH file_attachment_options: [1 .. 1];
    file_attachment_options^ [1].selector := fsc$access_and_share_modes;
    file_attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
    file_attachment_options^ [1].access_modes.value := $fst$file_access_options
          [fsc$append, fsc$modify, fsc$shorten];
    file_attachment_options^ [1].share_modes.selector := fsc$specific_share_modes;
    file_attachment_options^ [1].share_modes.value := $fst$file_access_options [];

    PUSH mandated_creation_attributes: [1 .. 2];
    mandated_creation_attributes^ [1].selector := fsc$file_contents_and_processor;
    IF global_log = pmc$system_log THEN
      mandated_creation_attributes^ [1].file_contents := fsc$legible_data;
    ELSE
      mandated_creation_attributes^ [1].file_contents := fsc$binary_log;
    IFEND;
    mandated_creation_attributes^ [1].file_processor := fsc$unknown_processor;
    mandated_creation_attributes^ [2].selector := fsc$ring_attributes;
    mandated_creation_attributes^ [2].ring_attributes.r1 := caller_identifier.ring;
    mandated_creation_attributes^ [2].ring_attributes.r2 := caller_identifier.ring;
    mandated_creation_attributes^ [2].ring_attributes.r3 := caller_identifier.ring;

{ Open the termination file.

    fsp$open_file (termination_file, amc$record, file_attachment_options, {default_creation_attributes} NIL,
          mandated_creation_attributes, {attribute_validation} NIL, {attribute_override} NIL,
          termination_file_id, status);
    #SPOIL (termination_file_id);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

{ Copy the log to the termination file and release any unneeded disk space.

    lgp$terminate_log_processor (global_log, termination_file_id, status);

{ Close the termination file.

    fsp$close_file (termination_file_id, ignore_status);

    osp$disestablish_cond_handler;

  PROCEND lgp$terminate_log;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lgp$terminate_log_processor', EJECT ??
{ PURPOSE:
{   This request copies the existing log entries from an active log to another file and then releases the
{   unneeded disk space occupied by the active log.

  PROCEDURE [XDCL, #GATE] lgp$terminate_log_processor
    (    global_log: pmt$global_logs;
         termination_file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      caller_identifier: ost$caller_identifier,
      date: ost$date,
      end_of_log: boolean,
      ending_offset: amt$file_byte_address,
      first_log_entry_header_p: ^lgt$log_entry_header,
      global_task_id: ost$global_task_id,
      log_cycle: lgt$log_cycle,
      log_data: ^SEQ ( * ),
      log_entries_processed: integer,
      log_entry_p: ^lgt$log_entry,
      log_entry_size: lgt$log_entry_size,
      log_time: ost$time,
      message_text: ost$string,
      next_log_entry_header_p: ^lgt$log_entry_header,
      previous_log_data: ^SEQ ( * ),
      statistic: ^SEQ ( * ),
      statistic_descriptive_data: ^sft$descriptive_data,
      statistic_header: ^sft$statistic_header,
      system_log_entry: ^pmt$system_log_entry,
      termination_id: ost$name;

?? NEWTITLE := 'condition_handler', EJECT ??
{ PURPOSE:
{   This condition handler is used to handle interactive pause break and terminate break conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      IF condition.selector = ifc$interactive_condition THEN
        IF condition.interactive_condition = ifc$pause_break THEN
          ifp$invoke_pause_utility (local_status);
        ELSEIF condition.interactive_condition = ifc$terminate_break THEN
          osp$set_status_from_condition ('LG', condition, save_area, status, local_status);
          EXIT lgp$terminate_log_processor;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    #CALLER_ID (caller_identifier);

{ Verify that a valid log ordinal has been specified.

    IF NOT (global_log IN -$pmt$global_logset []) THEN
      osp$set_status_abnormal ('LG', lge$incorrect_log_ordinal, 'LGP$TERMINATE_LOG_PROCESSOR', status);
      RETURN;
    IFEND;

{ Verify that the user has the authority to terminate the specified log.

    verify_authority (caller_identifier, global_log, {critical_window_log = } FALSE, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Get the log data pointer and the current ending offset for the log.

    lgp$get_global_log_read_info (global_log, 0, log_cycle, log_data, ending_offset, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Construct the log termination message and place it in the appropriate log.

    pmp$get_unique_name (termination_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF global_log = pmc$system_log THEN
      pmp$get_date (osc$month_date, date, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      message_text.value := 'Log continued,  current date is';
      message_text.size := clp$trimmed_string_size (message_text.value);
      message_text.value (message_text.size + 2, * ) := date.month;
      message_text.size := clp$trimmed_string_size (message_text.value);
      message_text.value (message_text.size + 1, * ) := '.  Log termination identifier =';
      message_text.size := clp$trimmed_string_size (message_text.value);
      message_text.value (message_text.size + 2, * ) := termination_id;
      message_text.size := clp$trimmed_string_size (message_text.value);

      lgp$add_entry_to_system_log (pmc$msg_origin_system, message_text.value (1, message_text.size), log_time,
            status);
    ELSE
      message_text.value := 'Log termination identifier = ';
      message_text.size := clp$trimmed_string_size (message_text.value);
      message_text.value (message_text.size + 2, * ) := termination_id;
      message_text.size := clp$trimmed_string_size (message_text.value);

      PUSH statistic: [[REP (#SIZE (sft$statistic_header) + message_text.size) OF cell]];
      RESET statistic;

      pmp$get_executing_task_gtid (global_task_id);

      sfp$build_statistic (lgc$start_of_log, message_text.value (1, message_text.size), NIL, global_task_id,
            statistic, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      lgp$add_entry_global_binary_log (global_log, statistic, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Allocate a log entry and construct pointers to the important information in the log entry.

    PUSH log_entry_p: [[REP lgc$maximum_log_entry_size OF cell]];
    RESET log_entry_p;
    IF global_log = pmc$system_log THEN
      NEXT system_log_entry: [message_text.size] IN log_entry_p;
    ELSE
      NEXT statistic_header IN log_entry_p;
    IFEND;

{ Copy the log entries from the beginning of the log until the log termination message is found.

    osp$establish_condition_handler (^condition_handler, FALSE);
    log_entries_processed := 0;

    RESET log_data;
    end_of_log := FALSE;

  /copy_log/
    REPEAT

{ Periodically allow signals and flags to be processed.  This allows the user to interupt the display.

      IF (log_entries_processed MOD lgc$signal_flag_process_count) = 0 THEN
        tmp$dispose_of_signals_flags (tmc$long_term_wait);
      IFEND;
      log_entries_processed := log_entries_processed + 1;

{ Save the log data pointer before the read so that it can be used to construct a pointer to the log entry
{ header for the log termination message when it is found.

      previous_log_data := log_data;

{ Get the next log entry.

      lgp$get_entry_from_global_log (global_log, log_cycle, log_data, log_entry_size, log_entry_p^, status);
      IF NOT status.normal THEN
        IF status.condition = lge$end_of_log THEN
          status.normal := TRUE;
          end_of_log := TRUE;
          EXIT /copy_log/;
        ELSE
          osp$disestablish_cond_handler;
          RETURN;
        IFEND;
      IFEND;

{ Check if the log entry contains the log termination message.  If it does, update the message before writing
{ it to the termination file.

      IF i#current_sequence_position (log_data) > ending_offset THEN
        IF global_log = pmc$system_log THEN
          IF system_log_entry^.text (1, message_text.size) = message_text.value (1, message_text.size) THEN
            system_log_entry^.text (5, 11) := 'terminated,';
            end_of_log := TRUE;
          IFEND;
        ELSE
          IF ((statistic_header^.statistic_code = lgc$start_of_log) AND
                (statistic_header^.number_of_counters = 0) AND (statistic_header^.descriptive_data_size =
                message_text.size)) THEN
            NEXT statistic_descriptive_data: [statistic_header^.descriptive_data_size] IN log_entry_p;
            IF statistic_descriptive_data^ = message_text.value THEN
              statistic_header^.statistic_code := lgc$end_of_log;
              end_of_log := TRUE;
            ELSE
              RESET log_entry_p TO statistic_descriptive_data;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

{ Write the log entry to the termination file.

      amp$put_next (termination_file_id, log_entry_p, log_entry_size, byte_address, status);
      IF NOT status.normal THEN
        osp$disestablish_cond_handler;
        RETURN;
      IFEND;
    UNTIL end_of_log {/copy_log/} ;

    osp$disestablish_cond_handler;

{ Get a pointer to the log entry header for the log termination log entry.  This will be the first log entry
{ header when termination has completed.

    NEXT first_log_entry_header_p IN previous_log_data;
    IF first_log_entry_header_p = NIL THEN
      osp$set_status_abnormal ('LG', lge$corrupted_log, lgv$log_names [global_log], status);
      RETURN;
    IFEND;

{ Move the log entries that were added since log termination began to the beginning of the log and release the
{ unneeded disk space.

    lgp$release_global_log_space (global_log, log_cycle, first_log_entry_header_p, status);

  PROCEND lgp$terminate_log_processor;
?? OLDTITLE ??
?? NEWTITLE := 'verify_authority', EJECT ??

{ PURPOSE:
{   Verifies that the user has the proper authority to read or terminate the specified log.

  PROCEDURE verify_authority
    (    caller_identifier: ost$caller_identifier;
         global_log: pmt$global_logs;
         critical_window_log: boolean;
     VAR status: ost$status);

    status.normal := TRUE;

{ If called from above ring six, check for proper capabilities.  Otherwise allow the access.

    IF caller_identifier.ring > osc$sj_ring_3 THEN
      IF critical_window_log THEN

{ Access to the critical window log requires system operation.

        IF NOT avp$system_operator () THEN
          osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_operation', status);
          RETURN;
        IFEND;

      ELSE
      CASE global_log OF
      = pmc$account_log =

{ Access to the account log requires accounting administration.

        IF NOT avp$accounting_administrator () THEN
          osp$set_status_abnormal ('OF', ofe$sou_not_active, 'accounting_administration', status);
          RETURN;
        IFEND;

      = pmc$engineering_log =

{ Access to the engineering log requires configuration administration.

        IF NOT avp$configuration_administrator () THEN
          osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
          RETURN;
        IFEND;

      = pmc$system_log, pmc$history_log =

{ Access to the system log or history log requires system operation.

        IF NOT avp$system_operator () THEN
          osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_operation', status);
          RETURN;
        IFEND;

      = pmc$security_log =

{ Access to the security log requires system administration.

        IF NOT avp$system_administrator () THEN
          osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_administration', status);
          RETURN;
        IFEND;

      = pmc$statistic_log =

{ Access to the statistics log requires configuration administration.

        IF NOT avp$configuration_administrator () THEN
          osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
          RETURN;
        IFEND;
      CASEND;
    IFEND;
    IFEND;

  PROCEND verify_authority;
?? OLDTITLE ??
MODEND lgm$logging_interfaces;
*DECK DECK=LGM$MANAGE_PERIODIC_STATS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Logging : Periodic Statistics Management' ??
MODULE lgm$manage_periodic_stats;

{ PURPOSE:
{   Command utility to manage OS periodic statistics emission sets and the
{   statistics assigned to them.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_value
*copyc clt$utility_attributes
*copyc clt$utility_name
*copyc lge$condition_codes
*copyc nac$statistics_codes
*copyc osc$statistics
*copyc ost$data_id
*copyc ost$emission_sets
*copyc ost$name
*copyc sfd$type_declarations
?? POP ??
*copyc amp$close
*copyc amp$open
*copyc amp$put_next
*copyc clp$begin_utility
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_integer
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$get_value_count
*copyc clp$include_file
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc clp$trimmed_string_size
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_message
*copyc osp$read_emission_sets
*copyc osp$release_manps_lock
*copyc osp$reserve_manps_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$status_condition_code
*copyc osp$status_condition_number
*copyc osp$write_emission_sets
*copyc pmp$exit
*copyc sfp$convert_stat_code_to_name
*copyc sfp$convert_stat_name_to_code

?? EJECT ??
?? TITLE := 'Global Variable Declarations' ??

  CONST
    lg_error_ident = 'LG',
    mps_utility_name = 'MPS_UTILITY                    ';

  VAR
    emission_sets_copy: array [ost$emission_set_names] of ost$emission_set := [REP $INTEGER (UPPERVALUE
      (ost$emission_set_names)) + 1 of [FALSE, [0, 0, 0, 23, 59, 59, 0 ],
      (23*3600+59*60+59)*100000,
      osc$max_emit_time, 0, * ]];

  VAR
    emission_set_labels: [READ] array [ost$emission_set_names] of string (20) := ['SET_1', 'SET_2', 'SET_3',
      'SET_4', 'IMMEDIATE_EMISSION'];

  VAR
    cleared_emission_set: [READ] ost$emission_set := [FALSE, [0, 0, 0, 23, 59, 59, 0 ],
      (23*3600+59*60+59)*100000,
      osc$max_emit_time, 0, * ];

  VAR
    emission_set_time_increment: pmt$time_increment;

  VAR
    emission_sets_modified: boolean := FALSE;

  VAR
    write_privilege_reserved: boolean := FALSE;

?? EJECT ??
?? TITLE := 'Secondary procedures' ??
?? NEWTITLE := 'assign_emission_set_id' ??

  PROCEDURE assign_emission_set_id (keyword: ost$name;
     VAR emission_set_id: ost$emission_set_names;
     VAR status: ost$status);

    IF (keyword = 'S1') OR (keyword = 'SET_1') THEN
      emission_set_id := osc$set_1;
    ELSEIF (keyword = 'S2') OR (keyword = 'SET_2') THEN
      emission_set_id := osc$set_2;
    ELSEIF (keyword = 'S3') OR (keyword = 'SET_3') THEN
      emission_set_id := osc$set_3;
    ELSEIF (keyword = 'S4') OR (keyword = 'SET_4') THEN
      emission_set_id := osc$set_4;
    ELSEIF (keyword = 'IE') OR (keyword = 'IMMEDIATE_EMISSION') THEN
      emission_set_id := osc$immediate_emission_set;
    ELSE
      status.normal := FALSE;
    IFEND;

  PROCEND assign_emission_set_id;

?? EJECT ??
?? TITLE := 'convert_to_stat_entry' ??

  PROCEDURE convert_to_stat_entry (stat_name: ost$name;
    VAR stat_entry: ost$stat_entry;
    VAR status: ost$status);

    VAR
      combined_statistic_code: sft$statistic_code,
      dummy_integer: clt$integer,
      error_string: string (132),
      length: integer;


    sfp$convert_stat_name_to_code (stat_name, combined_statistic_code, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT (((combined_statistic_code >= nac$min_statistic) AND
          (combined_statistic_code <= nac$max_statistic)) OR
          ((combined_statistic_code >= osc$min_statistic) AND (combined_statistic_code <= osc$max_statistic)))
          THEN
      osp$set_status_abnormal (lg_error_ident, lge$incorrect_statistic, '', status);
      RETURN;
    IFEND;

    stat_entry.stat := combined_statistic_code;

    CASE stat_entry.stat OF
    = osc$swap_state_stats =
      stat_entry.from_index := jmc$iss_null;
      stat_entry.to_index := jmc$iss_null;
    ELSE
      stat_entry.first_index := osc$all_stats;
      stat_entry.second_index := osc$all_stats;
    CASEND;

  PROCEND convert_to_stat_entry;

  ?? EJECT ??
  ?? TITLE := 'format_emission_set' ??

  PROCEDURE format_emission_set (emission_set_id: ost$emission_set_names,
        output_file_id: amt$file_identifier;
    VAR status: ost$status);

    VAR
      stat: 1 .. osc$max_stats_in_set,
      stat_name: ost$name,
      line: string (80),
      line_loc: ^cell,
      length: integer,
      byte_address: amt$file_byte_address;

    line := '  ';
    line_loc := #LOC (line);
    amp$put_next (output_file_id, line_loc, 2, byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (line, length, '      NAME            : ', emission_set_labels [emission_set_id]);
    amp$put_next (output_file_id, line_loc, length, byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF emission_sets_copy [emission_set_id].enabled THEN
      line := '      STATE           : ENABLED ';
    ELSE
      line := '      STATE           : DISABLED';
    IFEND;
    length := 32;
    amp$put_next (output_file_id, line_loc, length, byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    line := '';
    STRINGREP (line, length, '      PERIOD          : ',
          emission_sets_copy[emission_set_id].period.hour, ':',
          emission_sets_copy[emission_set_id].period.minute, ':',
          emission_sets_copy[emission_set_id].period.second);
    amp$put_next (output_file_id, line_loc, length, byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    line := '      STATISTICS LIST : ';
    IF emission_sets_copy [emission_set_id].stat_count = 0 THEN
      line (25, 22) := 'No statistics assigned';
      length := 46;
    ELSE
      sfp$convert_stat_code_to_name (emission_sets_copy [emission_set_id].stat_list [1].stat, stat_name,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      line (25, *) := stat_name (1, clp$trimmed_string_size (stat_name));
      length := 24 + clp$trimmed_string_size(stat_name);
    IFEND;
    amp$put_next (output_file_id, line_loc, length, byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF emission_sets_copy [emission_set_id].stat_count > 1 THEN
      line (1, 24) := '                        ';
      FOR stat := 2 TO emission_sets_copy [emission_set_id].stat_count DO
        sfp$convert_stat_code_to_name (emission_sets_copy [emission_set_id].stat_list [stat].stat, stat_name,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        line (25, *) := stat_name (1, clp$trimmed_string_size (stat_name));
        length := 24 + clp$trimmed_string_size(stat_name);
        amp$put_next (output_file_id, line_loc, length, byte_address, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;

  PROCEND format_emission_set;
?? EJECT ??
?? OLDTITLE ??
?? TITLE := 'Subcommands' ??
?? EJECT ??
?? NEWTITLE := 'add_statistics' ??

  PROCEDURE add_statistics (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{          pdt add_stat_pdt (
{            emission_set,emission_sets,es: KEY ..
{            set_1,s1,..
{            set_2,s2,..
{            set_3,s3,..
{            set_4,s4,..
{            immediate_emission,ie = $required
{            statistic,statistics,s: LIST 1..osc$max_stats_in_set OF NAME = $required
{            status)

?? PUSH (LISTEXT := ON) ??

  VAR
    add_stat_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^add_stat_pdt_names,
      ^add_stat_pdt_params];

  VAR
    add_stat_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
      clt$parameter_name_descriptor := [['EMISSION_SET', 1], ['EMISSION_SETS', 1], ['ES', 1], ['STATISTIC', 2]
      , ['STATISTICS', 2], ['S', 2], ['STATUS', 3]];

  VAR
    add_stat_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ EMISSION_SET EMISSION_SETS ES }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^add_stat_pdt_kv1, clc$keyword_value]],

{ STATISTIC STATISTICS S }
    [[clc$required], 1, osc$max_stats_in_set, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
      osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    add_stat_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 10] of ost$name := ['SET_1','S1',
      'SET_2','S2','SET_3','S3','SET_4','S4','IMMEDIATE_EMISSION','IE'];

?? POP ??

    VAR
      emission_set_id: ost$emission_set_names,
      emission_set_name: clt$value,
      error_string: string (132),
      index: integer,
      length: integer,
      stat_entry: ost$stat_entry,
      statistic: clt$value,
      statistic_in_emission_set: boolean,
      statistic_set: 0 .. clc$max_value_sets,
      statistic_set_count: 0 .. clc$max_value_sets;

    IF NOT write_privilege_reserved THEN
      osp$set_status_condition (lge$write_privilege_required, status);
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, add_stat_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('emission_set', 1, 1, clc$low, emission_set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    assign_emission_set_id (emission_set_name.name.value, emission_set_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('statistics', statistic_set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR statistic_set := 1 TO statistic_set_count DO
      clp$get_value ('statistics', statistic_set, 1, clc$low, statistic, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      convert_to_stat_entry (statistic.name.value, stat_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      statistic_in_emission_set :=FALSE;
      /check_for_statistic/
      FOR index := 1 to emission_sets_copy[emission_set_id].stat_count DO
        IF emission_sets_copy[emission_set_id].stat_list[index].stat = stat_entry.stat THEN
          statistic_in_emission_set :=TRUE;
          EXIT /check_for_statistic/;
        IFEND;
      FOREND /check_for_statistic/;

      IF NOT statistic_in_emission_set THEN

        IF emission_sets_copy [emission_set_id].stat_count >= osc$max_stats_in_set THEN
          osp$set_status_abnormal (lg_error_ident, lge$emission_set_overflow, '', status);
          RETURN;
        IFEND;

        emission_sets_copy [emission_set_id].stat_count := emission_sets_copy [emission_set_id].stat_count
            + 1;
        emission_sets_copy [emission_set_id].stat_list [emission_sets_copy [emission_set_id].stat_count] :=
            stat_entry;

      IFEND;
    FOREND;
    emission_sets_modified := TRUE;

  PROCEND add_statistics;
?? EJECT ??
?? TITLE := 'delete_statistics' ??

  PROCEDURE delete_statistics (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{         PDT delete_stat_pdt (
{           emission_set,emission_sets,es: KEY ..
{           set_1,s1,..
{           set_2,s2,..
{           set_3,s3,..
{           set_4,s4,..
{           immediate_emission,ie = $required
{           statistic,statistics,s: LIST 1..osc$max_stats_in_set OF NAME OR KEY all = $required
{           status)

?? PUSH (LISTEXT := ON) ??

  VAR
    delete_stat_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^delete_stat_pdt_names,
      ^delete_stat_pdt_params];

  VAR
    delete_stat_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
      clt$parameter_name_descriptor := [['EMISSION_SET', 1], ['EMISSION_SETS', 1], ['ES', 1], ['STATISTIC', 2]
      , ['STATISTICS', 2], ['S', 2], ['STATUS', 3]];

  VAR
    delete_stat_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ EMISSION_SET EMISSION_SETS ES }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^delete_stat_pdt_kv1, clc$keyword_value]],

{ STATISTIC STATISTICS S }
    [[clc$required], 1, osc$max_stats_in_set, 1, 1, clc$value_range_not_allowed, [^delete_stat_pdt_kv2,
      clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    delete_stat_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 10] of ost$name := ['SET_1',
      'S1','SET_2','S2','SET_3','S3','SET_4','S4','IMMEDIATE_EMISSION','IE'];

  VAR
    delete_stat_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['ALL'];

?? POP ??

    VAR
      i: integer,
      statistic: clt$value,
      statistic_set,
      statistic_set_count: 0 .. clc$max_value_sets,
      statistic_set_value,
      statistic_set_value_count: 0 .. clc$max_values_per_set,
      stat_entry: ost$stat_entry,
      stat_line: 1 .. osc$max_stats_in_set,
      emission_set_name: clt$value,
      emission_set_id: ost$emission_set_names;

    IF NOT write_privilege_reserved THEN
      osp$set_status_condition (lge$write_privilege_required, status);
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, delete_stat_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('emission_set', 1, 1, clc$low, emission_set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    assign_emission_set_id (emission_set_name.name.value, emission_set_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('statistics', statistic_set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /delete_stat_for/
    FOR statistic_set := 1 TO statistic_set_count DO
      clp$get_value ('statistics', statistic_set, 1, clc$low, statistic, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF statistic.name.value = 'ALL' THEN
        emission_sets_copy [emission_set_id].stat_count := 0;
      ELSE
        convert_to_stat_entry (statistic.name.value, stat_entry, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        FOR stat_line := 1 TO emission_sets_copy [emission_set_id].stat_count DO
          IF emission_sets_copy [emission_set_id].stat_list [stat_line].stat = stat_entry.stat THEN
            FOR i := stat_line TO emission_sets_copy [emission_set_id].stat_count - 1 DO
              emission_sets_copy [emission_set_id].stat_list [i] := emission_sets_copy [emission_set_id].
                    stat_list [i + 1];
            FOREND;
            emission_sets_copy [emission_set_id].stat_count := emission_sets_copy [emission_set_id].stat_count
                  - 1;
            CYCLE /delete_stat_for/;
          IFEND;
        FOREND;
      IFEND;
    FOREND /delete_stat_for/;
    emission_sets_modified := TRUE;

  PROCEND delete_statistics;
?? EJECT ??
?? TITLE := 'change_period' ??

  PROCEDURE change_period (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{   PROCEDURE change_period, chap (
{     emission_set, emission_sets, es: KEY
{       (set_1,s1)
{       (set_2,s2)
{       (set_3,s3)
{       (set_4,s4)
{     KEYEND = $required
{     period, p: (CHECK) ANY of
{       integer 1..osc$max_emit_time
{       time_increment
{     ANYEND = $required
{     status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 6] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 8] of clt$keyword_specification,
        recend,
        type2: 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$integer_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 17, 15, 47, 47, 288], clc$command, 6, 3, 2, 0, 0, 0, 3, 'CHAP'],
            [['EMISSION_SET                   ', clc$nominal_entry, 1],
            ['EMISSION_SETS                  ', clc$alias_entry, 1],
            ['ES                             ', clc$abbreviation_entry, 1],
            ['P                              ', clc$abbreviation_entry, 2],
            ['PERIOD                         ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3]], [
{ PARAMETER 1
      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 303, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$extended_parameter_checking, 43, clc$required_parameter, 0, 0],
{ PARAMETER 3
      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$keyword_type], [8], [['S1                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['S2                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['S3                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['S4                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['SET_1                          ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['SET_2                          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['SET_3                          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['SET_4                          ', clc$nominal_entry,
            clc$normal_usage_entry, 4]]],
{ PARAMETER 2
      [[1, 0, clc$union_type], [[clc$integer_type, clc$time_increment_type], FALSE, 2], 20,
            [[1, 0, clc$integer_type], [1, osc$max_emit_time, 10]], 3, [[1, 0, clc$time_increment_type]]],
{ PARAMETER 3
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$emission_set = 1,
      p$period = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

?? NEWTITLE := 'check parameters for change_period subcommand', EJECT ??
{
{   This procedure is called by clp$evaluate_parameters.  It validates that
{   a time_increment period specifies only the hour, minute, and seconds
{   fields, and that a non-zero time_increment has been specified.
{

    PROCEDURE check
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      IF which_parameter.specific AND (which_parameter.number = p$period) AND
            (pvt [p$period].value^.kind = clc$time_increment) THEN
        IF (pvt [p$period].value^.time_increment_value^.year <> 0) OR
              (pvt [p$period].value^.time_increment_value^.month <> 0) OR
              (pvt [p$period].value^.time_increment_value^.day <> 0) OR
              (pvt [p$period].value^.time_increment_value^.millisecond <> 0) THEN
          osp$set_status_abnormal (lg_error_ident, lge$incorrect_time_increment, '', status);
          RETURN;
        IFEND;
        IF (pvt [p$period].value^.time_increment_value^.hour = 0) AND
              (pvt [p$period].value^.time_increment_value^.minute = 0) AND
              (pvt [p$period].value^.time_increment_value^.second = 0) THEN
          osp$set_status_abnormal (lg_error_ident, lge$zero_period, '', status);
          RETURN;
        IFEND;
      IFEND;

    PROCEND check;
?? OLDTITLE, EJECT ??

    CONST
      microseconds_per_second = 1000000,
      microseconds_per_minute = microseconds_per_second * 60,
      microseconds_per_hour = microseconds_per_minute * 60;

    VAR
      emission_set_id: ost$emission_set_names;

    IF NOT write_privilege_reserved THEN
      osp$set_status_condition (lge$write_privilege_required, status);
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check, ^pvt, status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    assign_emission_set_id (pvt [p$emission_set].value^.keyword_value, emission_set_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$period].value^.kind = clc$time_increment THEN
      emission_set_time_increment := pvt [p$period].value^.time_increment_value^;
    ELSE
      emission_set_time_increment.year := 0;
      emission_set_time_increment.month := 0;
      emission_set_time_increment.day := 0;
      emission_set_time_increment.hour := 0;
      emission_set_time_increment.minute := pvt [p$period].value^.integer_value.value;
      emission_set_time_increment.second := 0;
      emission_set_time_increment.millisecond := 0;
    IFEND;

    emission_sets_copy [emission_set_id].period := emission_set_time_increment;
    emission_sets_copy [emission_set_id].microsecond_period :=
             emission_sets_copy [emission_set_id].period.hour * microseconds_per_hour +
             emission_sets_copy [emission_set_id].period.minute * microseconds_per_minute +
             emission_sets_copy [emission_set_id].period.second * microseconds_per_second;
    emission_sets_modified := TRUE;

  PROCEND change_period;
?? EJECT ??
?? TITLE := 'change_state' ??

  PROCEDURE change_state (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{         pdt chas_pdt (
{             emission_set,emission_sets,es: KEY ..
{             set_1,s1,..
{             set_2,s2,..
{             set_3,s3,..
{             set_4,s4,..
{             immediate_emission,ie = $required
{             state,s: key enable,enabled,disable,disabled
{             status)

?? PUSH (LISTEXT := ON) ??

    VAR
      chas_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^chas_pdt_names, ^chas_pdt_params];

    VAR
      chas_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
        clt$parameter_name_descriptor := [['EMISSION_SET', 1], ['EMISSION_SETS', 1], ['ES', 1], ['STATE', 2],
        ['S', 2], ['STATUS', 3]];

    VAR
      chas_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ EMISSION_SET EMISSION_SETS ES }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^chas_pdt_kv1, clc$keyword_value]],

{ STATE S }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [^chas_pdt_kv2, clc$keyword_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      chas_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 10] of ost$name := ['SET_1', 'S1',
        'SET_2', 'S2', 'SET_3', 'S3', 'SET_4', 'S4', 'IMMEDIATE_EMISSION', 'IE'];

    VAR
      chas_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := ['ENABLE',
        'ENABLED', 'DISABLE', 'DISABLED'];

?? POP ??

    VAR
      emission_set_name: clt$value,
      emission_set_state: clt$value,
      emission_set_id: ost$emission_set_names;

    IF NOT write_privilege_reserved THEN
      osp$set_status_condition (lge$write_privilege_required, status);
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, chas_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('emission_set', 1, 1, clc$low, emission_set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    assign_emission_set_id (emission_set_name.name.value, emission_set_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('state', 1, 1, clc$low, emission_set_state, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (emission_set_state.name.value = 'ENABLE') OR (emission_set_state.name.value = 'ENABLED') THEN
      emission_sets_copy [emission_set_id].enabled := TRUE;
    ELSE
      emission_sets_copy [emission_set_id].enabled := FALSE;
      emission_sets_copy [emission_set_id].next_emit_time := osc$max_emit_time;
    IFEND;
    emission_sets_modified := TRUE;

  PROCEND change_state;
?? EJECT ??
?? TITLE := 'display_emission_sets' ??

  PROCEDURE display_emission_sets (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{               pdt display_sets_pdt (
{                   emission_set,emission_sets,es: LIST OF KEY ..
{                   set_1,s1,..
{                   set_2,s2,..
{                   set_3,s3,..
{                   set_4,s4,..
{                   immediate_emission,ie,..
{                   all = all
{                   output,o: file = $OUTPUT
{                   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_sets_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^display_sets_pdt_names,
        ^display_sets_pdt_params];

    VAR
      display_sets_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
        clt$parameter_name_descriptor := [['EMISSION_SET', 1], ['EMISSION_SETS', 1], ['ES', 1], ['OUTPUT', 2],
        ['O', 2], ['STATUS', 3]];

    VAR
      display_sets_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor
        := [

{ EMISSION_SET EMISSION_SETS ES }
      [[clc$optional_with_default, ^display_sets_pdt_dv1], 1, clc$max_value_sets, 1, 1,
        clc$value_range_not_allowed, [^display_sets_pdt_kv1, clc$keyword_value]],

{ OUTPUT O }
      [[clc$optional_with_default, ^display_sets_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      display_sets_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 11] of ost$name := [
        'SET_1', 'S1', 'SET_2', 'S2', 'SET_3', 'S3', 'SET_4', 'S4', 'IMMEDIATE_EMISSION', 'IE', 'ALL'];

    VAR
      display_sets_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

    VAR
      display_sets_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??

    VAR
      line: string (80),
      line_loc: ^cell,
      length: integer,
      byte_address: amt$file_byte_address,
      i: 0 .. clc$max_value_sets,
      emission_set_name: clt$value,
      emission_set_id: ost$emission_set_names,
      emission_set_count: 0 .. clc$max_value_sets,
      output_file_id: amt$file_identifier,
      output_file: clt$value;

    clp$scan_parameter_list (parameter_list, display_sets_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('output', 1, 1, clc$low, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (output_file.file.local_file_name, amc$record, NIL, output_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('emission_sets', emission_set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    line := '  ';
    line_loc := #LOC (line);
    amp$put_next (output_file_id, line_loc, 2, byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    line := '  EMISSION SET ATTRIBUTES  ';
    length := 27;
    amp$put_next (output_file_id, line_loc, length, byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO emission_set_count DO
      clp$get_value ('emission_sets', i, 1, clc$low, emission_set_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF emission_set_name.name.value = 'ALL' THEN
        FOR emission_set_id := LOWERVALUE (ost$emission_set_names) TO UPPERVALUE (ost$emission_set_names) DO
          format_emission_set (emission_set_id, output_file_id, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
      ELSE
        assign_emission_set_id (emission_set_name.name.value, emission_set_id, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        format_emission_set (emission_set_id, output_file_id, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    amp$close (output_file_id, status);

  PROCEND display_emission_sets;
?? EJECT ??
?? TITLE := 'read_emission_sets' ??

  PROCEDURE read_emission_sets (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{       pdt read_sets_pdt (
{           emission_set,emission_sets,es: LIST OF KEY ..
{             set_1,s1,..
{             set_2,s2,..
{             set_3,s3,..
{             set_4,s4,..
{             immediate_emission,ie,..
{             all = $required
{             status)

?? PUSH (LISTEXT := ON) ??

    VAR
      read_sets_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^read_sets_pdt_names,
        ^read_sets_pdt_params];

    VAR
      read_sets_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
        clt$parameter_name_descriptor := [['EMISSION_SET', 1], ['EMISSION_SETS', 1], ['ES', 1], ['STATUS',
        2]];

    VAR
      read_sets_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ EMISSION_SET EMISSION_SETS ES }
      [[clc$required], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed, [^read_sets_pdt_kv1,
        clc$keyword_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      read_sets_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 11] of ost$name := ['SET_1',
        'S1', 'SET_2', 'S2', 'SET_3', 'S3', 'SET_4', 'S4', 'IMMEDIATE_EMISSION', 'IE', 'ALL'];

?? POP ??

    VAR
      i: 0 .. clc$max_value_sets,
      emission_set_name: clt$value,
      emission_set_id: ost$emission_set_names,
      emission_set_count: 0 .. clc$max_value_sets,
      local_emission_sets_copy: array [ost$emission_set_names] of ost$emission_set;

    clp$scan_parameter_list (parameter_list, read_sets_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$read_emission_sets (local_emission_sets_copy, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('emission_sets', emission_set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO emission_set_count DO
      clp$get_value ('emission_sets', i, 1, clc$low, emission_set_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF emission_set_name.name.value = 'ALL' THEN
        emission_sets_copy := local_emission_sets_copy;
      ELSE
        assign_emission_set_id (emission_set_name.name.value, emission_set_id, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        emission_sets_copy [emission_set_id] := local_emission_sets_copy [emission_set_id];
      IFEND;
    FOREND;

  PROCEND read_emission_sets;
?? EJECT ??
?? TITLE := 'clear_emission_sets' ??

  PROCEDURE clear_emission_sets (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{       pdt clear_sets_pdt (
{           emission_set,emission_sets,es: LIST OF KEY ..
{             set_1,s1,..
{             set_2,s2,..
{             set_3,s3,..
{             set_4,s4,..
{             immediate_emission,ie,..
{             all = $required
{             status)

?? PUSH (LISTEXT := ON) ??

    VAR
      clear_sets_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^clear_sets_pdt_names,
        ^clear_sets_pdt_params];

    VAR
      clear_sets_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
        clt$parameter_name_descriptor := [['EMISSION_SET', 1], ['EMISSION_SETS', 1], ['ES', 1], ['STATUS',
        2]];

    VAR
      clear_sets_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor :=
        [

{ EMISSION_SET EMISSION_SETS ES }
      [[clc$required], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed, [^clear_sets_pdt_kv1,
        clc$keyword_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      clear_sets_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 11] of ost$name := ['SET_1',
        'S1', 'SET_2', 'S2', 'SET_3', 'S3', 'SET_4', 'S4', 'IMMEDIATE_EMISSION', 'IE', 'ALL'];

?? POP ??

    VAR
      i: 0 .. clc$max_value_sets,
      emission_set_name: clt$value,
      emission_set_id: ost$emission_set_names,
      emission_set_count: 0 .. clc$max_value_sets;

    IF NOT write_privilege_reserved THEN
      osp$set_status_condition (lge$write_privilege_required, status);
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, clear_sets_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('emission_sets', emission_set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO emission_set_count DO
      clp$get_value ('emission_sets', i, 1, clc$low, emission_set_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF emission_set_name.name.value = 'ALL' THEN
        FOR emission_set_id := LOWERVALUE (ost$emission_set_names) TO UPPERVALUE (ost$emission_set_names) DO
          emission_sets_copy [emission_set_id] := cleared_emission_set;
        FOREND;
      ELSE
        assign_emission_set_id (emission_set_name.name.value, emission_set_id, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        emission_sets_copy [emission_set_id] := cleared_emission_set;
      IFEND;
    FOREND;
    emission_sets_modified := TRUE;

  PROCEND clear_emission_sets;
  ?? EJECT ??
  ?? TITLE := 'end_mps' ??

  PROCEDURE end_mps (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{    PROCEDURE quit, qui (
{      write_emission_sets, wes: boolean = $optional
{      status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 22, 15, 28, 7, 528],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['STATUS                         ',clc$nominal_entry, 2],
    ['WES                            ',clc$abbreviation_entry, 1],
    ['WRITE_EMISSION_SETS            ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$write_emission_sets = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      ignore_status: ost$status;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF ((pvt[p$write_emission_sets].specified AND
          (pvt[p$write_emission_sets].value^.boolean_value.value = TRUE)) OR
          ((NOT pvt[p$write_emission_sets].specified) AND emission_sets_modified)) THEN
      osp$write_emission_sets (emission_sets_copy, status);
      IF NOT status.normal THEN
        osp$generate_message (status, ignore_status);
        status.normal := TRUE;
      IFEND;
    IFEND;

    clp$end_include (mps_utility_name, status);
    IF NOT status.normal THEN
      pmp$exit (status);
    IFEND;

  PROCEND end_mps;
  ?? EJECT ??
  ?? OLDTITLE ??
  ?? TITLE := 'Main Program' ??
  ?? NEWTITLE := '[XDCL, #GATE] lgp$manage_periodic_statistics' ??

  PROCEDURE [XDCL, #GATE] lgp$manage_periodic_statistics (parameter_list: clt$parameter_list;
    VAR status: ost$status);
?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   The purpose of this request is to release the osv$manps_user_lock if the
{   task terminates abnormally (i.e. without a QUIT command).

    PROCEDURE abort_handler (condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      osp$release_manps_lock;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??
{            pdt mps_pdt (
{                read_emission_sets,res: boolean = TRUE
{                reserve_write_privilege,rwp: boolean = TRUE
{                status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    mps_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^mps_pdt_names, ^mps_pdt_params];

  VAR
    mps_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of clt$parameter_name_descriptor
  := [['READ_EMISSION_SETS', 1], ['RES', 1], ['RESERVE_WRITE_PRIVILEGE', 2], ['RWP', 2], ['STATUS', 3]];

  VAR
    mps_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ READ_EMISSION_SETS RES }
    [[clc$optional_with_default, ^mps_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ RESERVE_WRITE_PRIVILEGE RWP }
    [[clc$optional_with_default, ^mps_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    mps_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'TRUE';

  VAR
    mps_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'TRUE';

?? FMT (FORMAT := ON) ??
?? POP ??

{ table mps_command_list t=c s=local
{ command (add_statistics,add_statistic,adds) add_statistics
{ command (delete_statistics,delete_statistic,dels) delete_statistics
{ command (change_period,chap) change_period
{ command (change_state,chas) change_state
{ command (display_emission_sets,display_emission_set,dises) display_emission_sets
{ command (read_emission_sets,read_emission_set,reaes) read_emission_sets
{ command (clear_emission_sets,clear_emission_set,clees) clear_emission_sets
{ command (quit,qui) end_mps
{ tablend

?? PUSH (LISTEXT := ON) ??

    VAR
      mps_command_list: [STATIC, READ] ^clt$command_table := ^mps_command_list_entries,

      mps_command_list_entries: [STATIC, READ] array [1 .. 21] of clt$command_table_entry := [
        {} ['ADDS                           ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^add_statistics],
        {} ['ADD_STATISTIC                  ', clc$alias_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^add_statistics],
        {} ['ADD_STATISTICS                 ', clc$nominal_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^add_statistics],
        {} ['CHANGE_PERIOD                  ', clc$nominal_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^change_period],
        {} ['CHANGE_STATE                   ', clc$nominal_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^change_state],
        {} ['CHAP                           ', clc$abbreviation_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^change_period],
        {} ['CHAS                           ', clc$abbreviation_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^change_state],
        {} ['CLEAR_EMISSION_SET             ', clc$alias_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^clear_emission_sets],
        {} ['CLEAR_EMISSION_SETS            ', clc$nominal_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^clear_emission_sets],
        {} ['CLEES                          ', clc$abbreviation_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^clear_emission_sets],
        {} ['DELETE_STATISTIC               ', clc$alias_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^delete_statistics],
        {} ['DELETE_STATISTICS              ', clc$nominal_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^delete_statistics],
        {} ['DELS                           ', clc$abbreviation_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^delete_statistics],
        {} ['DISES                          ', clc$abbreviation_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^display_emission_sets],
        {} ['DISPLAY_EMISSION_SET           ', clc$alias_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^display_emission_sets],
        {} ['DISPLAY_EMISSION_SETS          ', clc$nominal_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^display_emission_sets],
        {} ['QUI                            ', clc$abbreviation_entry, clc$advertised_entry, 9,
        clc$automatically_log, clc$linked_call, ^end_mps],
        {} ['QUIT                           ', clc$nominal_entry, clc$advertised_entry, 9,
        clc$automatically_log, clc$linked_call, ^end_mps],
        {} ['READ_EMISSION_SET              ', clc$alias_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^read_emission_sets],
        {} ['READ_EMISSION_SETS             ', clc$nominal_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^read_emission_sets],
        {} ['REAES                          ', clc$abbreviation_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^read_emission_sets]];

?? POP ??

    VAR
      attributes: array [1 .. 4] of clt$utility_attribute,
      get_emission_sets: clt$value,
      reserve_write_privilege: clt$value;

    clp$scan_parameter_list (parameter_list, mps_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('read_emission_sets', 1, 1, clc$low, get_emission_sets, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('reserve_write_privilege', 1, 1, clc$low, reserve_write_privilege, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF get_emission_sets.bool.value THEN
      osp$read_emission_sets (emission_sets_copy, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF reserve_write_privilege.bool.value THEN
      osp$establish_block_exit_hndlr (^abort_handler);
      osp$reserve_manps_lock (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      write_privilege_reserved := TRUE;
    IFEND;

    attributes [1].key := clc$utility_command_search_mode;
    attributes [1].command_search_mode := clc$global_command_search;
    attributes [2].key := clc$utility_command_table;
    attributes [2].command_table := mps_command_list;
    attributes [3].key := clc$utility_function_table;
    attributes [3].function_table := NIL;
    attributes [4].key := clc$utility_prompt;
    attributes [4].prompt.size := 3;
    attributes [4].prompt.value := 'mps';

    clp$begin_utility (mps_utility_name, attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, '', mps_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (mps_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    osp$release_manps_lock;
    osp$disestablish_cond_handler;

  PROCEND lgp$manage_periodic_statistics;
?? OLDTITLE ??
?? OLDTITLE ??
?? OLDTITLE ??
MODEND lgm$manage_periodic_statistics;
*DECK DECK=LGP$ADD_CRITICAL_LOG_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] lgp$add_critical_log_entry
    (    entry_p: ^lgt$log_entry;
         log_control_descriptor_p: ^lgt$critical_log_control_desc;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lge$log_full
*copyc lgt$critical_log_control_desc
*copyc lgt$log_entry
*copyc ost$status
?? POP ??
*DECK DECK=LGP$ADD_ENTRY_GLOBAL_BINARY_LOG EXPAND=FALSE

  PROCEDURE [XREF] lgp$add_entry_global_binary_log
    (    global_binary_log: pmt$global_binary_logs;
         entry_p: ^lgt$log_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lge$log_full
*copyc lge$log_not_available
*copyc lgt$log_entry
*copyc ost$status
*copyc pmt$global_binary_logs
?? POP ??
*DECK DECK=LGP$ADD_ENTRY_LOCAL_BINARY_LOG EXPAND=FALSE

  PROCEDURE [XREF] lgp$add_entry_local_binary_log
    (    local_binary_log: pmt$local_binary_logs;
         entry_p: ^lgt$log_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lge$log_not_available
*copyc lgt$log_entry
*copyc ost$status
*copyc pmt$local_binary_logs
?? POP ??

*DECK DECK=LGP$ADD_ENTRY_TO_ASCII_LOG EXPAND=FALSE

  PROCEDURE [XREF] lgp$add_entry_to_ascii_log
    (    ascii_logset: pmt$ascii_logset;
         origin: pmt$log_msg_origin;
         text: pmt$log_msg_text;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lge$log_not_available
*copyc ost$status
*copyc pmt$ascii_logset
*copyc pmt$log_msg_origin
*copyc pmt$log_msg_text
?? POP ??
*DECK DECK=LGP$ADD_ENTRY_TO_CRITICAL_LOG EXPAND=FALSE

  PROCEDURE [XREF] lgp$add_entry_to_critical_log
    (    text: pmt$log_msg_text;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$log_msg_text
?? POP ??
*DECK DECK=LGP$ADD_ENTRY_TO_SYSTEM_LOG EXPAND=FALSE

  PROCEDURE [XREF] lgp$add_entry_to_system_log
    (    origin: pmt$log_msg_origin;
         text: pmt$log_msg_text;
     VAR log_time: ost$time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lge$log_full
*copyc lge$log_not_available
*copyc ost$status
*copyc ost$time
*copyc pmt$log_msg_origin
*copyc pmt$log_msg_text
?? POP ??
*DECK DECK=LGP$ADD_LOG_ENTRY EXPAND=FALSE
  PROCEDURE [XREF] lgp$add_log_entry
    (    entry_p: ^lgt$log_entry;
         log_control_descriptor_p: ^lgt$log_control_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lge$log_full
*copyc lgt$log_control_descriptor
*copyc lgt$log_entry
*copyc ost$status
?? POP ??
*DECK DECK=LGP$APPEND_JOB_LOG_TO_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] lgp$append_job_log_to_output
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=LGP$CLOSE_LOG_FILE EXPAND=FALSE

  PROCEDURE [XREF] lgp$close_log_file
    (    log_file_identifier: lgt$log_file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lgt$log_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=LGP$DISPLAY_CRITICAL_LOG_ATTR EXPAND=FALSE

  PROCEDURE [XREF] lgp$display_critical_log_attr
    (    output: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=LGP$DISPLAY_JOB_LOG EXPAND=FALSE

*DECK DECK=LGP$DISPLAY_LOG EXPAND=FALSE

  PROCEDURE [XREF] lgp$display_log
    (    display_log_kind: clt$display_log_kind;
         display_option_selection: lgt$display_option_selection;
         output: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_log_indices
*copyc fst$file_reference
*copyc lgt$display_option_selection
*copyc ost$status
?? POP ??
*DECK DECK=LGP$DISPLAY_LOG_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] lgp$display_log_attributes
    (    log: pmt$logs;
         output: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc pmt$logs
?? POP ??
*DECK DECK=LGP$DISPLAY_SYSTEM_LOG EXPAND=FALSE

  PROCEDURE [XREF] lgp$display_system_log
    (    display_options: lgt$display_options;
         count: integer;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc lgt$display_parameters
*copyc ofe$error_codes
?? POP ??
*DECK DECK=LGP$FIND_START_OF_LOG EXPAND=FALSE

  PROCEDURE [XREF] lgp$find_start_of_log
    (    log: pmt$ascii_logs;
         entry_count_from_end_of_log: ost$segment_length;
     VAR log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lgt$log_cycle
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$ascii_logs
?? POP ??
*DECK DECK=LGP$GET_CRITICAL_LOG_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_critical_log_entry
    (    log_cycle: lgt$log_cycle;
         log_control_descriptor_p: ^lgt$critical_log_control_desc;
     VAR log_data: ^SEQ ( * );
     VAR log_entry_size: lgt$log_entry_size;
     VAR log_entry: lgt$log_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lge$corrupted_log
*copyc lge$end_of_log
*copyc lge$log_cycles_do_not_match
*copyc lge$log_not_available
*copyc lgt$critical_log_control_desc
*copyc lgt$log_cycle
*copyc lgt$log_entry
*copyc lgt$log_entry_size
*copyc ost$status
?? POP ??
*DECK DECK=LGP$GET_CRITICAL_LOG_READ_INFO EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_critical_log_read_info
    (    entry_count_from_end_of_log: ost$segment_length;
     VAR log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR ending_offset: amt$file_byte_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc lgt$log_cycle
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=LGP$GET_CRITICAL_PREVIOUS_SIZE EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_critical_previous_size
    (    log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR previous_size: lgt$log_entry_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lgt$log_cycle
*copyc lgt$log_entry_size
*copyc ost$status
?? POP ??
*DECK DECK=LGP$GET_CRITICAL_READ_INFO EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_critical_read_info
    (    log_control_descriptor_p: ^lgt$critical_log_control_desc;
         entry_count_from_end_of_log: ost$segment_length;
     VAR log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR ending_offset: amt$file_byte_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc lgt$critical_log_control_desc
*copyc lgt$log_cycle
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=LGP$GET_ENTRY_FROM_CRITICAL_LOG EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_entry_from_critical_log
    (    log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR log_entry_size: lgt$log_entry_size;
     VAR log_entry: lgt$log_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lgt$log_cycle
*copyc lgt$log_entry
*copyc lgt$log_entry_size
*copyc ost$status
?? POP ??
*DECK DECK=LGP$GET_ENTRY_FROM_GLOBAL_LOG EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_entry_from_global_log
    (    global_log: pmt$global_logs;
         log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR log_entry_size: lgt$log_entry_size;
     VAR log_entry: lgt$log_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lge$log_cycles_do_not_match
*copyc lge$end_of_log
*copyc lge$log_not_available
*copyc lgt$log_cycle
*copyc lgt$log_entry
*copyc lgt$log_entry_size
*copyc ost$status
*copyc pmt$global_logs
?? POP ??
*DECK DECK=LGP$GET_ENTRY_FROM_LOCAL_LOG EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_entry_from_local_log
    (    local_log: pmt$logs;
         log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR log_entry_size: lgt$log_entry_size;
     VAR log_entry: lgt$log_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lge$log_cycles_do_not_match
*copyc lge$log_not_available
*copyc lge$not_local_log
*copyc lgt$log_cycle
*copyc lgt$log_entry
*copyc lgt$log_entry_size
*copyc ost$status
*copyc pmt$logs
?? POP ??
*DECK DECK=LGP$GET_GLOBAL_LOG_READ_INFO EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_global_log_read_info
    (    global_log: pmt$global_logs;
         entry_count_from_end_of_log: ost$segment_length;
     VAR log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR ending_offset: amt$file_byte_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc lge$log_not_available
*copyc lgt$log_cycle
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$global_logs
?? POP ??
*DECK DECK=LGP$GET_GLOBAL_PREVIOUS_SIZE EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_global_previous_size
    (    global_log: pmt$global_logs;
         log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR previous_size: lgt$log_entry_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lgt$log_cycle
*copyc lgt$log_entry_size
*copyc ost$status
*copyc pmt$global_logs
?? POP ??
*DECK DECK=LGP$GET_LOCAL_LOG_READ_INFO EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_local_log_read_info
    (    local_log: pmt$logs;
         entry_count_from_end_of_log: ost$segment_length;
     VAR log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR ending_offset: amt$file_byte_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc lge$log_not_available
*copyc lgt$log_cycle
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$logs
?? POP ??
*DECK DECK=LGP$GET_LOCAL_PREVIOUS_SIZE EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_local_previous_size
    (    local_log: pmt$logs;
         log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR previous_size: lgt$log_entry_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lgt$log_cycle
*copyc lgt$log_entry_size
*copyc ost$status
*copyc pmt$logs
?? POP ??
*DECK DECK=LGP$GET_LOG_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_log_entry
    (    log_cycle: lgt$log_cycle;
         log_control_descriptor_p: ^lgt$log_control_descriptor;
     VAR log_data: ^SEQ ( * );
     VAR log_entry_size: lgt$log_entry_size;
     VAR log_entry: lgt$log_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lge$end_of_log
*copyc lge$log_cycles_do_not_match
*copyc lgt$log_control_descriptor
*copyc lgt$log_cycle
*copyc lgt$log_entry
*copyc lgt$log_entry_size
*copyc ost$status
?? POP ??
*DECK DECK=LGP$GET_LOG_READ_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_log_read_information
    (    log_control_descriptor_p: ^lgt$log_control_descriptor;
         entry_count_from_end_of_log: ost$segment_length;
     VAR log_cycle: lgt$log_cycle;
     VAR log_data: ^SEQ ( * );
     VAR ending_offset: amt$file_byte_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc lgt$log_control_descriptor
*copyc lgt$log_cycle
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=LGP$GET_NEXT_ENTRY_FROM_LOG EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_next_entry_from_log
    (    log: pmt$ascii_logs;
     VAR log_cycle: lgt$log_cycle;
     VAR log_address: ^SEQ ( * );
     VAR entry: string ( * );
     VAR entry_size: lgt$log_entry_size;
     VAR eof: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lge$log_cycles_do_not_match
*copyc lgt$log_entry_size
*copyc lgt$log_read_activity
*copyc ost$status
*copyc pmt$ascii_logs
?? POP ??
*DECK DECK=LGP$GET_NEXT_LOG_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_next_log_entry
    (    log_file_identifier: lgt$log_file_identifier;
         statistic_buffer_p: ^sft$statistic_buffer;
     VAR log_entry_p: ^lgt$log_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lgt$log_entry
*copyc lgt$log_file_identifier
*copyc ost$status
*copyc sft$statistic_buffer
?? POP ??
*DECK DECK=LGP$GET_NEXT_STATISTIC EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_next_statistic
    (    log_file_identifier: lgt$log_file_identifier;
         statistic_buffer_p: ^sft$statistic_buffer;
     VAR statistic_header_p: ^sft$statistic_header;
     VAR counters_p: sft$counters;
     VAR descriptive_data_p: ^sft$descriptive_data;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lge$end_of_log
*copyc lgt$log_file_identifier
*copyc ost$status
*copyc sft$counters
*copyc sft$descriptive_data
*copyc sft$statistic_buffer
*copyc sft$statistic_header
?? POP ??
*DECK DECK=LGP$GET_PREVIOUS_CRIT_LOG_SIZE EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_previous_crit_log_size
    (    log_cycle: lgt$log_cycle;
         log_control_descriptor_p: ^lgt$critical_log_control_desc;
     VAR log_data: ^SEQ ( * );
     VAR previous_size: lgt$log_entry_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lge$corrupted_log
*copyc lge$log_cycles_do_not_match
*copyc lge$log_not_available
*copyc lgt$critical_log_control_desc
*copyc lgt$log_cycle
*copyc lgt$log_entry_size
*copyc ost$status
?? POP ??
*DECK DECK=LGP$GET_PREVIOUS_LOG_ENTRY_SIZE EXPAND=FALSE

  PROCEDURE [XREF] lgp$get_previous_log_entry_size
    (    log_cycle: lgt$log_cycle;
         log_control_descriptor_p: ^lgt$log_control_descriptor;
     VAR log_data: ^SEQ ( * );
     VAR previous_size: lgt$log_entry_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lgt$log_control_descriptor
*copyc lgt$log_cycle
*copyc lgt$log_entry_size
*copyc ost$status
?? POP ??
*DECK DECK=LGP$INITIALIZE_CRITICAL_LOG_LCD EXPAND=FALSE

  PROCEDURE [XREF] lgp$initialize_critical_log_lcd
    (    log: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=LGP$INITIALIZE_GLOBAL_LOG_LCD EXPAND=FALSE

  PROCEDURE [XREF] lgp$initialize_global_log_lcd
    (    global_log: pmt$global_logs;
         log: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$global_logs
?? POP ??
*DECK DECK=LGP$INSTALL_ENGINEERING_LOG EXPAND=FALSE


  PROCEDURE [XREF] lgp$install_eng_log
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=LGP$INSTALL_GLOBAL_LOGS EXPAND=FALSE

  PROCEDURE [XREF] lgp$install_global_logs
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=LGP$OPEN_LOG_FILE EXPAND=FALSE

  PROCEDURE [XREF] lgp$open_log_file
    (    log_file: fst$file_reference;
     VAR active_log: boolean;
     VAR log_file_identifier: lgt$log_file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc lgt$log_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=LGP$OPEN_LOG_FILE_DESCRIPTOR EXPAND=FALSE

  FUNCTION [XREF] lgp$open_log_file_descriptor
    (    log_file_identifier: lgt$log_file_identifier): ^lgt$open_log_file_descriptor;

?? PUSH (LISTEXT := ON) ??
*copyc lgt$open_log_file_descriptor
?? POP ??
*DECK DECK=LGP$PARSE_STATISTIC EXPAND=FALSE

  PROCEDURE [XREF] lgp$parse_statistic
    (    log_entry_p: ^lgt$log_entry;
     VAR statistic_header_p: ^sft$statistic_header;
     VAR counters_p: sft$counters;
     VAR descriptive_data_p: ^sft$descriptive_data;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lgt$log_entry
*copyc ost$status
*copyc sft$counters
*copyc sft$descriptive_data
*copyc sft$statistic_header
?? POP ??
*DECK DECK=LGP$RECOVER_GLOBAL_LOGS EXPAND=FALSE

  PROCEDURE [XREF] lgp$recover_global_logs
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=LGP$RELEASE_CRITICAL_LOG_SPACE EXPAND=FALSE

  PROCEDURE [XREF] lgp$release_critical_log_space
    (    log_cycle: lgt$log_cycle;
         first_log_entry_header_p: ^lgt$log_entry_header;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lge$corrupted_log
*copyc lge$incorrect_move_length
*copyc lge$log_cycles_do_not_match
*copyc lgt$log_cycle
*copyc lgt$log_entry_header
*copyc ost$status
?? POP ??
*DECK DECK=LGP$RELEASE_GLOBAL_LOG_SPACE EXPAND=FALSE

  PROCEDURE [XREF] lgp$release_global_log_space
    (    global_log: pmt$global_logs;
         log_cycle: lgt$log_cycle;
         first_log_entry_header_p: ^lgt$log_entry_header;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lge$incorrect_move_length
*copyc lge$log_cycles_do_not_match
*copyc lge$log_full
*copyc lgt$log_cycle
*copyc lgt$log_entry_header
*copyc ost$status
*copyc pmt$global_logs
?? POP ??
*DECK DECK=LGP$REWIND_LOG_FILE EXPAND=FALSE

  PROCEDURE [XREF] lgp$rewind_log_file
    (    log_file_identifier: lgt$log_file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lgt$log_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=LGP$SETUP_ACCESS_TO_LOCAL_LOGS EXPAND=FALSE

  PROCEDURE [XREF] lgp$setup_access_to_local_logs
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=LGP$SETUP_RECOVERY_LOGGING EXPAND=FALSE

  PROCEDURE [XREF] lgp$setup_recovery_logging
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=LGP$TERMINATE_CRITICAL_LOG EXPAND=FALSE

  PROCEDURE [XREF] lgp$terminate_critical_log
    (    termination_file: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lge$corrupted_log
*copyc ofe$error_codes
?? POP ??
*DECK DECK=LGP$TERMINATE_LOG EXPAND=FALSE

  PROCEDURE [XREF] lgp$terminate_log
    (    global_log: pmt$global_logs;
         termination_file: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$global_logs
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=LGP$TERMINATE_LOG_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] lgp$terminate_log_processor
    (    global_log: pmt$global_logs;
         file_id: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
*copyc pme$logging_exceptions
*copyc pmt$global_logs
?? POP ??
*DECK DECK=LGT$CRITICAL_LOG_CONTROL_DESC EXPAND=FALSE

  TYPE
    lgt$critical_log_control_desc = record
      lock: ost$signature_lock,
      log_cycle: lgt$log_cycle,
      log_data: ^SEQ ( * ),
      trailing_log_entry_header_p: ^lgt$log_entry_header,
      maximum_size: lgt$log_size,
      preallocation_size: lgt$log_preallocation_size,
      critical_log: boolean,
      lost_message_count: integer,
      log_full: boolean,
    recend;

*copyc lgt$log_cycle
*copyc lgt$log_entry_header
*copyc lgt$log_preallocation_size
*copyc lgt$log_size
*copyc ost$signature_lock
*DECK DECK=LGT$DISPLAY_OPTIONS EXPAND=FALSE

  TYPE
    lgt$display_options = (lgc$count, lgc$all, lgc$last);

*DECK DECK=LGT$DISPLAY_OPTION_SELECTION EXPAND=FALSE

  TYPE
    lgt$display_option_selection = record
      case display_options: lgt$display_options of
      = lgc$count =
        count: amt$file_byte_address,
      casend,
    recend;

*copyc amt$file_byte_address
*copyc lgt$display_options
*DECK DECK=LGT$DISPLAY_PARAMETERS EXPAND=FALSE

  TYPE
    lgt$display_parameters = record
      display_control: clt$display_control,
      file: clt$file,
      refresh_rate: oft$refresh_rate,
      display_option_selection: lgt$display_option_selection,
    recend;

*copyc CLT$DISPLAY_CONTROL
*copyc CLT$FILE
*copyc LGT$DISPLAY_OPTION_SELECTION
*copyc OFT$REFRESH_RATE
*DECK DECK=LGT$ENTRY_INFO EXPAND=FALSE

  TYPE
    lgt$entry_info = record
      entry_offset: amt$file_byte_address,
      log_cycle: lgt$log_cycle,
    recend;

  TYPE
    lgt$logset_entry_info = array [pmt$ascii_logs] of lgt$entry_info;

*copyc AMT$FILE_BYTE_ADDRESS
*copyc LGT$LOG_READ_ACTIVITY
*copyc PMD$SYSTEM_LOG_INTERFACE
*DECK DECK=LGT$LOG_ATTRIBUTE_ENTRY EXPAND=FALSE

  TYPE
    lgt$log_attribute_entry = record
      critical: boolean,
      maximum_size: 0 .. 255 { maximum size in megabytes },
      preallocation_size: ost$non_negative_integers { in bytes },
    recend;

*copyc lgc$maximum_log_size
*copyc lgc$default_preallocation_size
*copyc osd$integer_limits
*DECK DECK=LGT$LOG_CONTROL_DESCRIPTOR EXPAND=FALSE

  TYPE
    lgt$log_control_descriptor = record
      lock: ost$signature_lock,
      log: pmt$logs,
      log_cycle: lgt$log_cycle,
      log_data: ^SEQ ( * ),
      trailing_log_entry_header_p: ^lgt$log_entry_header,
      maximum_size: lgt$log_size,
      preallocation_size: lgt$log_preallocation_size,
      critical_log: boolean,
      lost_message_count: integer,
      log_full: boolean,
    recend;

*copyc lgt$log_cycle
*copyc lgt$log_entry_header
*copyc lgt$log_preallocation_size
*copyc lgt$log_size
*copyc ost$signature_lock
*copyc pmt$logs
*DECK DECK=LGT$LOG_CYCLE EXPAND=FALSE

  TYPE
    lgt$log_cycle = 0 .. lgc$maximum_log_cycle;

*copyc lgc$maximum_log_cycle
*DECK DECK=LGT$LOG_ENTRY EXPAND=FALSE

  TYPE
    lgt$log_entry = SEQ ( * );

*DECK DECK=LGT$LOG_ENTRY_HEADER EXPAND=FALSE

  TYPE
    lgt$log_entry_header = record
      previous_size: lgt$log_entry_size,
      current_size: lgt$log_entry_size,
    recend;

*copyc lgt$log_entry_size
*DECK DECK=LGT$LOG_ENTRY_SIZE EXPAND=FALSE

  TYPE
    lgt$log_entry_size = 0 .. lgc$maximum_log_entry_size;

*copyc lgc$maximum_log_entry_size
*DECK DECK=LGT$LOG_FILE_IDENTIFIER EXPAND=FALSE

  TYPE
    lgt$log_file_identifier = ost$name;

*copyc ost$name
*DECK DECK=LGT$LOG_PREALLOCATION_SIZE EXPAND=FALSE

  TYPE
    lgt$log_preallocation_size = lgt$log_size;

*copyc lgt$log_size

*DECK DECK=LGT$LOG_READ_ACTIVITY EXPAND=FALSE

*copyc lgt$log_control_descriptor
*copyc lgt$log_cycle
*copyc lgt$log_entry
*copyc lgt$log_entry_header
*copyc lgt$log_entry_size

{ Internal logging interface type declarations. }

    CONST
      lgc$log_entry_size_limit = lgc$maximum_log_entry_size,
      lgc$log_termination_bit_pattern = 0;

    TYPE
      lgt$mode_of_log_copy = (lgc$copy_from_boi, lgc$copy_from_last_reference),
      lgt$log_change_type = (lgc$increment_counter, lgc$decrement_counter);


*DECK DECK=LGT$LOG_SIZE EXPAND=FALSE

  TYPE
    lgt$log_size = 0 .. lgc$maximum_log_size;

*copyc lgc$maximum_log_size
*DECK DECK=LGT$LOG_VERSION EXPAND=FALSE

  TYPE
    lgt$log_version = ost$name;

  CONST
    lgc$log_version = 'NOS/VE Logging Version 1.0     ';

*copyc ost$name
*DECK DECK=LGT$OPEN_LOG_FILE_DESCRIPTOR EXPAND=FALSE

  TYPE
    lgt$open_log_file_descriptor = record
      log_file_identifier: lgt$log_file_identifier,
      backward: ^lgt$open_log_file_descriptor,
      forward: ^lgt$open_log_file_descriptor,
      open_ring: ost$valid_ring,
      log_data: ^SEQ ( * ),
      case active_log: boolean of
      = TRUE =
        log: pmt$logs,
        global_log: boolean,
        log_cycle: lgt$log_cycle,
      = FALSE =
        bam_file_identifier: amt$file_identifier,
        file_reference: fst$path,
      casend,
    recend;

*copyc amt$file_identifier
*copyc fst$path
*copyc lgt$log_cycle
*copyc lgt$log_file_identifier
*copyc osd$virtual_address
*copyc pmt$logs

*DECK DECK=LGT$PF_INFO_DESCRIPTOR EXPAND=FALSE

{ Logging structure to save/retrieve global log pf data.

    TYPE
      lgt$pf_info_descriptor = RECORD
        cycle_selector: pft$cycle_selector,
        password: pft$password,
        path_to_pf: pft$path,
      RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
?? POP ??
*DECK DECK=LGV$CONTROL_CODES_TO_QUEST_MARK EXPAND=FALSE
 VAR
    lgv$control_codes_to_quest_mark: [XREF, READ] string (256);

*DECK DECK=LGV$CRITICAL_LOG_ATTRIBUTES EXPAND=FALSE

  VAR
    lgv$critical_log_attributes: [XREF] lgt$log_attribute_entry;

*copyc lgt$log_attribute_entry
*DECK DECK=LGV$CRITICAL_LOG_CTL EXPAND=FALSE

  VAR
    lgv$critical_log_ctl: [XREF] lgt$critical_log_control_desc;

?? PUSH (LISTEXT := ON) ??
*copyc lgt$critical_log_control_desc
?? POP ??
*DECK DECK=LGV$CRITICAL_LOG_NAME EXPAND=FALSE

  VAR
    lgv$critical_log_name: [XREF, READ] ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=LGV$GLOBAL_LOG_ATTRIBUTES EXPAND=FALSE

  VAR
    lgv$global_log_attributes: [XREF] array [pmt$global_logs] of
          lgt$log_attribute_entry;

*copyc lgt$log_attribute_entry
*copyc pmt$global_logs
*DECK DECK=LGV$GLOBAL_LOG_CTL EXPAND=FALSE

  VAR
    lgv$global_log_ctl: [XREF] ARRAY [pmt$global_logs] OF lgt$log_control_descriptor;

?? PUSH (LISTEXT := ON) ??
*copyc PMD$SYSTEM_LOG_INTERFACE
*copyc LGT$LOG_READ_ACTIVITY
?? POP ??
*DECK DECK=LGV$GLOBAL_LOG_PF_INFO_P EXPAND=FALSE

  VAR
    lgv$global_log_pf_info_p: [XREF] ^lgt$pf_info_descriptor;

?? PUSH (LISTEXT := ON) ??
*copyc LGT$PF_INFO_DESCRIPTOR
?? POP ??
*DECK DECK=LGV$LOCAL_LOG_CTL EXPAND=FALSE

  VAR
    lgv$local_log_ctl: [XREF] ARRAY [pmt$logs] OF ^lgt$log_control_descriptor;

?? PUSH (LISTEXT := ON) ??
*copyc PMD$SYSTEM_LOG_INTERFACE
*copyc LGT$LOG_READ_ACTIVITY
?? POP ??
*DECK DECK=LGV$LOG_NAMES EXPAND=FALSE

  VAR
    lgv$log_names: [XREF, READ] array [pmt$logs] of ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc pmd$system_log_interface
*copyc ost$name
?? POP ??
*DECK DECK=LGV$ORIGIN_CODES EXPAND=FALSE
  VAR
    lgv$origin_codes: [XREF] array [pmt$log_msg_origin] of string (2);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$log_msg_origin
?? POP ??
*DECK DECK=LGV$RECOVERY_LOG_SFID EXPAND=FALSE

  VAR
    lgv$recovery_log_sfid: [XREF] dmt$system_file_id;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
?? POP ??
*DECK DECK=LGV$SYSTEM_IDENTIFICATION_LINE EXPAND=FALSE

  VAR
    lgv$system_identification_line: [XREF] STRING(60);
*DECK DECK=LLC$MIN_ECC EXPAND=FALSE

CONST
*IF $true(osv$unix)
  llc$min_ecc = (($INTEGER ('L') * 100(16)) + $INTEGER ('L')) * 10000(16);
*ELSE
  llc$min_ecc = (($INTEGER ('L') * 100(16)) + $INTEGER ('L')) * 1000000(16);
*IFEND

*DECK DECK=LLC$UNLINKED_POINTER_RING EXPAND=FALSE

  CONST
    llc$unlinked_pointer_ring = 0,
    llc$unlinked_pointer_segment = 0;

*DECK DECK=LLD$LOADER_EXECPTIONS EXPAND=FALSE
?? NEWTITLE := 'LLDECC  : Loader                  : ''LL'' 0 .. 9999' ??
*copy LLE$LOADER_STATUS_CONDITIONS
*copy LLE$LOAD_MAP_DIAGNOSTICS
*copy LLE$FIND_EP_DIAGNOSTICS
?? OLDTITLE ??
*DECK DECK=LLE$FIND_EP_DIAGNOSTICS EXPAND=FALSE
?? NEWTITLE := 'lle$find_ep_diagnostics ------ ''LL'' 400 .. 499', EJECT ??
*copyc llc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    llc$find_ep_diagnostics         = llc$min_ecc + 400,

    lle$bad_program_header_ptr      = llc$find_ep_diagnostics + 0,
    {E Erroneous pointer to program header in library.}

    lle$bad_scl_header_ptr          = llc$find_ep_diagnostics + 1,
    {E Erroneous pointer to SCL header in library.}

    lle$bad_library_member_header   = llc$find_ep_diagnostics + 2,
    {E Erroneous +P library member header in library.}

    lle$bad_object_text_description = llc$find_ep_diagnostics + 3,
    {E Erroneous +P object text description in library.}

    lle$bad_ppu_header_ptr          = llc$find_ep_diagnostics + 4,
    {E Erroneous pointer to PPU header in library.}

    lle$bad_load_module_header      = llc$find_ep_diagnostics + 5,
    {E Erroneous +P load module header in library.}

    lle$bad_load_header_ptr         = llc$find_ep_diagnostics + 6,
    {E Erroneous pointer to load header in library.}

    lle$bad_module                  = llc$find_ep_diagnostics + 7,
    {E Erroneous +P bad module in library.}

    lle$file_not_a_load_file        = llc$find_ep_diagnostics + 8,
    {E Erroneous +P file not a load file.}

    llc$max_find_ep_diagnostics     = llc$find_ep_diagnostics + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=LLE$LOADER_STATUS_CONDITIONS EXPAND=FALSE
?? NEWTITLE := 'LLDELSC : loader status conditions : ''LL'' 0 .. 99' ??
?? EJECT ??
?? FMT (FORMAT := OFF) ??
*copyc llc$min_ecc

  CONST
    llc$loader_status_conditions    = llc$min_ecc,

    lle$premature_load_termination  = llc$loader_status_conditions + 0,
    {E +P load prematurely terminated.  Consult load map and/or output.}

    lle$term_error_level_exceeded   = llc$loader_status_conditions + 1,
    {E Load error severity is or exceeds TERMINATION_ERROR_LEVEL.}

    lle$load_map_suspended          = llc$loader_status_conditions + 2,
    {W Load map suspended due to file access error.}

    lle$entry_point_not_found       = llc$loader_status_conditions + 3,
    {E Unable to find entry point (+P).}

    lle$insufficient_memory_to_load = llc$loader_status_conditions + 4,
    {E Maximum segment length exceeded.  Consult load map and/or output.}

    lle$loader_malfunctioned        = llc$loader_status_conditions + 5,
    {E Loader malfunctioned - +P.  Consult load map and/or output.}

    lle$library_not_executable      = llc$loader_status_conditions + 6,
    {E The library parameter referenced a segment whose execute privilege..}
    { is non_executable.}

    llc$max_loader_status_condition = llc$loader_status_conditions + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=LLE$LOAD_MAP_DIAGNOSTICS EXPAND=TRUE
?? NEWTITLE := 'LLDELMD : load map diagnostics   : ''LL'' 100 .. 399', EJECT ??
?? FMT (FORMAT := OFF) ??
*copyc llc$min_ecc

  CONST
    llc$load_map_diagnostics        = llc$min_ecc + 100,

    lle$unsatisfied_external        = llc$load_map_diagnostics + 0,
      {E Unsatisfied reference to external +P.  Referenced by: }

    lle$transfer_symbol_missing     = llc$load_map_diagnostics + 1,
      {F Starting procedure not specified.}

    lle$transfer_symbol_undefined   = llc$load_map_diagnostics + 2,
      {F Starting procedure +P not found.}

    lle$transfer_symbol_unaligned   = llc$load_map_diagnostics + 3,
      {F Program transfer address not aligned on word boundary.}

    lle$no_xrefs_to_report          = llc$load_map_diagnostics + 4,
      {I No entry point cross references detected.}

    lle$module_not_found            = llc$load_map_diagnostics + 5,
      {E Module +P not found.}

    lle$file_not_library            = llc$load_map_diagnostics + 10,
      {E File +F is not a library.}

    lle$library_header_missing      = llc$load_map_diagnostics + 11,
      {F Library header missing from library +F.}

    lle$empty_module_dictionary     = llc$load_map_diagnostics + 12,
      {F Empty module dictionary in library +F.}

    lle$bad_module_dictionary_ptr   = llc$load_map_diagnostics + 13,
      {F Erroneous pointer to module dictionary in library +F.}

    lle$bad_entry_dictionary_ptr    = llc$load_map_diagnostics + 15,
      {F Erroneous pointer to entry point dictionary in library +F.}

    lle$bad_module_header_ptr       = llc$load_map_diagnostics + 16,
      {F Erroneous pointer to module header from +P2 dictionary entry +P3..}
      { in library +F1.}

    lle$bad_allotted_section_ptr    = llc$load_map_diagnostics + 17,
      {F Erroneous pointer to allotted section from module +P1 at offset +P2.}

    lle$bad_interpretive_elem_ptr   = llc$load_map_diagnostics + 18,
      {F Erroneous pointer to interpretive element from module header at..}
      { offset +P2 in library +F1.}

    lle$wrong_library_version       = llc$load_map_diagnostics + 19,
      {F Object library version must be '+P' for library +F.}

    lle$identification_expected     = llc$load_map_diagnostics + 20,
      {F Identification record expected at offset +P2 in file +F1.}

    lle$unknown_record_kind         = llc$load_map_diagnostics + 21,
      {F Unknown record kind encountered at offset +P.}

    lle$bad_fixer_value             = llc$load_map_diagnostics + 22,
      {F Invalid fixer value in record at offset +P.}

    lle$ppu_absolute_encountered    = llc$load_map_diagnostics + 23,
      {E PPU absolute record encountered at offset +P.}

    lle$premature_eof               = llc$load_map_diagnostics + 24,
      {F Premature EOI encountered on file +F1.  Last valid record at..}
      { offset +P2.}

    lle$transfer_record_missing     = llc$load_map_diagnostics + 26,
      {E No transfer symbol record encountered for module +P.}

    lle$unknown_date_format         = llc$load_map_diagnostics + 30,
      {W Unknown date format in identification record at offset +P.}

    lle$wrong_object_text_version   = llc$load_map_diagnostics + 31,
      {F Object text version must be '+P2', but is '+P1'.}

    lle$unknown_generator           = llc$load_map_diagnostics + 32,
      {W Unknown generator specified in identification record at offset +P.}

    lle$module_wrong_kind           = llc$load_map_diagnostics + 33,
      {F Module kind is not virtual state in identification record at..}
      { offset +P.}

    lle$module_nonexecutable        = llc$load_map_diagnostics + 34,
      {F Nonexecutable module specified by identification record at offset +P.}

    lle$model_wrong_kind           = llc$load_map_diagnostics + 35,
      {F Mainframe model is not currently capable of executing vector virtual..}
      { state instructions as specified in identification record at offset +P.}

    lle$duplicate_section_def       = llc$load_map_diagnostics + 40,
      {E Duplicate section definition encountered at offset +P.}

    lle$unknown_section_kind        = llc$load_map_diagnostics + 41,
      {E Unknown section kind in section definition record at offset +P.}

    lle$improper_b_s_attributes     = llc$load_map_diagnostics + 42,
      {W Binding section definition record at offset +P contains access..}
      { attribute other than BINDING.}

    lle$binding_attr_not_allowed    = llc$load_map_diagnostics + 43,
      {W BINDING access attribute ignored in section definition record at..}
      { offset +P.}

    lle$write_execute_section       = llc$load_map_diagnostics + 44,
      {E Both WRITE and EXECUTE access attributes specified in section..}
      { definition record at offset +P.}

    lle$section_alignment_zero      = llc$load_map_diagnostics + 45,
      {E Allocation alignment of zero specified in section definition record..}
      { at offset +P.}

    lle$code_element_missing        = llc$load_map_diagnostics + 46,
      {F Code element missing for section definition record at offset +P.}

    lle$binding_section_unaligned   = llc$load_map_diagnostics + 47,
      {F Binding section definition record at offset +P must cause section..}
      { to be aligned on a word boundary.}

    lle$invalid_text_in_common      = llc$load_map_diagnostics + 49,
      {E Attempt by +P1 at offset +P2 to initialize locations in unallocated..}
      { common.}

    lle$invalid_section_ordinal     = llc$load_map_diagnostics + 50,
      {E Section ordinal in +P1 at offset +P2 exceeds greatest section..}
      { ordinal defined for module.}

    lle$undefined_section           = llc$load_map_diagnostics + 51,
      {E Undefined section referenced by +P1 at offset +P2.}

    lle$invalid_section_offset      = llc$load_map_diagnostics + 52,
      {E Attempt by +P1 at offset +P2 to initialize locations beyond section..}
      { boundary.}

    lle$unknown_address_kind        = llc$load_map_diagnostics + 53,
      {E Unknown linkage kind specified in +P1 at offset +P2.}

    lle$unknown_language            = llc$load_map_diagnostics + 54,
      {W Unknown language specified in +P1 at offset +P2.}

    lle$improper_linkage_alignment  = llc$load_map_diagnostics + 55,
      {F Linkage specified by +P1 at offset +P2 not aligned on word boundary.}

    lle$non_linkage_binding_data    = llc$load_map_diagnostics + 56,
      {F Attempt to generate non-linkage data in binding section by +P1 at..}
      { offset +P2.}

    lle$improper_linkage_item       = llc$load_map_diagnostics + 57,
      {E Destination of external linkage item, +P - offset +P, of module +P ..}
      {is a code or an allotted section.}

    lle$binding_section_overwrite   = llc$load_map_diagnostics + 60,
      {F Binding section overwrite attempted by linkage to entry point +P1..}
      { from module +P2.}

    lle$declaration_mismatch        = llc$load_map_diagnostics + 61,
      {E Declaration mismatch on reference to entry point +P1 from module..}
      { +P2, using source text checking.}

    lle$entry_point_unaligned       = llc$load_map_diagnostics + 62,
      {E Entry point +P1 must be aligned on word boundary for procedure..}
      { reference from module +P2.}

    lle$informative_dec_mismatch    = llc$load_map_diagnostics + 63,
      {I Declaration mismatch on reference to entry point +P1 from module..}
      { +P2.}

    lle$f_declaration_mismatch      = llc$load_map_diagnostics + 64,
      {F Declaration mismatch on reference to entry point +P1 from module..}
      { +P2, using object text checking.}

    lle$duplicate_entry_point       = llc$load_map_diagnostics + 70,
      {E Duplicate definition of entry point +P encountered.  First..}
      { definition holds.}

    lle$duplicate_common_block       = llc$load_map_diagnostics + 71,
      {E Duplicate definition of common block +P encountered.}

    lle$invalid_bit_string          = llc$load_map_diagnostics + 80,
      {E Bit string size > 63 or bit string offset not in range (1..7) in..}
      { bit string insertion record at offset +P.}

    lle$invalid_bit_string_span     = llc$load_map_diagnostics + 81,
      {E Bit string span of more than 8 bytes specified in bit string..}
      { insertion record at offset +P.}

    lle$add_form_b_s_overwrite      = llc$load_map_diagnostics + 90,
      {F Binding section overwrite attempted by address formulation record..}
      { at offset +P.}

    lle$value_address_unaligned     = llc$load_map_diagnostics + 91,
      {E Target of procedure reference generated by address formulation item..}
      { at offset +P not aligned on word boundary.}

    lle$improper_add_form_item      = llc$load_map_diagnostics + 92,
      {E Destination of address formulation item, offset +P, is a code ..}
      {or an allotted section.}

    lle$extensible_truncated        = llc$load_map_diagnostics + 100,
      {W Size of extensible section exceeds program segment size.  Section..}
      { truncated.}

    lle$extensible_common_truncated = llc$load_map_diagnostics + 101,
      {W Size of extensible common block +P greater than program segment..}
      { size.  Common block truncated.}

    lle$common_truncated            = llc$load_map_diagnostics + 102,
      {E Size of common block +P greater than previous definition.  Common..}
      { block truncated.}

    lle$common_size_mismatch        = llc$load_map_diagnostics + 103,
      {W Size of common block +P less than previous definition.}

    lle$common_attr_mismatch        = llc$load_map_diagnostics + 104,
      {E Access attributes for common block +P do not match previous..}
      { definition.}

    lle$cant_call_lop$load_program  = llc$load_map_diagnostics + 105,
      {E The loader is not in a state to allow LOP$LOAD_PROGRAM to be..}
      { called again.}

    lle$empty_load_file             = llc$load_map_diagnostics + 110,
      {W File +F does not exist or you are not permitted for any access.}

    lle$file_not_load_file          = llc$load_map_diagnostics + 111,
      {F File +F does not have proper attributes (file_contents..}
      {/file_structure) must be:+N  (OBJECT/DATA) or (OBJECT/LIBRARY)}

    lle$unable_to_access_load_file  = llc$load_map_diagnostics + 112,
      {F Unable to access load file -- file ignored.}

    lle$file_contains_fap           = llc$load_map_diagnostics + 113,
      {F Unable to load file, +F, containing FAP -- file ignored.}


    lle$def_before_param            = llc$load_map_diagnostics + 114,
      {W entry definition preceeds actual parameters (+P) And (+P).}

    lle$unable_to_load_attributes   = llc$load_map_diagnostics + 115,
      {E unable to load attributes +P.}

    lle$invalid_matching            = llc$load_map_diagnostics + 116,
      {E The number of parameters do not match in the call..}
      { to procedure +P from module +P.}

    lle$access_share_modes_conflict = llc$load_map_diagnostics + 117,
      {F File +F does not have proper access and/or share_mode ..}
      {attributes. +N Must be:  (EXECUTE) or (READ EXECUTE)}

    lle$module_not_previous_loaded  = llc$load_map_diagnostics + 118,
    {F Module +P has not been previously loaded.}

    lle$no_reinit_info_for_module   = llc$load_map_diagnostics + 119,
    {F There is no reinitialization information for module +P.}

    lle$premature_eof_on_module     = llc$load_map_diagnostics + 120,
    {F Premature EOF encountered on module +P, last valid record found
    { at offset +P.}

    lle$bad_integer_length          = llc$load_map_diagnostics + 278,
      {E +P +P has an integer length mismatch. }

    lle$invalid_array_size_matching = llc$load_map_diagnostics + 279,
      {E +P +P has an array size mismatch.}

    lle$program_segment_overflow    = llc$load_map_diagnostics + 280,
      {C Overflow of program segment +P.}


    lle$unable_to_create_prog_seg   = llc$load_map_diagnostics + 281,
      {C Unable to create program segment +P.}

    lle$unable_to_get_prog_seg_size = llc$load_map_diagnostics + 282,
      {C Unable to determine size of program segment +P.}

    lle$unable_to_fix_prog_seg_attr = llc$load_map_diagnostics + 283,
      {C Unable to fix attributes of program segment +P.}

    lle$unable_to_defix_seg_attr    = llc$load_map_diagnostics + 284,
      {C Unable to defix attributes of program segment +P.}

    lle$unable_to_create_table      = llc$load_map_diagnostics + 285,
      {C Unable to create +P container.}

    lle$loader_table_overflow       = llc$load_map_diagnostics + 286,
      {C Overflow of +P container.}

    lle$eof_encountered_on_apd_file = llc$load_map_diagnostics + 288,
      {C End of file encountered on APD file +F.}

    lle$bad_local_block_name        = llc$load_map_diagnostics + 289,
      {C Local block name +P conflicts with existing APD block name map.}

    lle$bad_remote_block_name       = llc$load_map_diagnostics + 290,
      {C Remote block name +P conflicts with APD block name map.}

    lle$unable_to_access_apd_file   = llc$load_map_diagnostics + 291,
      {C Unable to access Analyze Program Dynamics file +F.}

    lle$loader_stopped              = llc$load_map_diagnostics + 292,
      {C System error - Loader stopped - See Site Analyst.}

    lle$absolute_ring_conflict      = llc$load_map_diagnostics + 293,
      {C Ring conflict, +P, on product module +P at offset +P.}

    lle$unable_to_move_text         = llc$load_map_diagnostics + 294,
      {C Unable to move text to byte offset +P.}

    lle$invalid_type_matching       = llc$load_map_diagnostics + 295,
      {E +P +P has a type mismatch.}

    lle$invalid_kind_matching       = llc$load_map_diagnostics + 296,
      {E +P +P has a kind mismatch.}

    lle$invalid_mode_matching       = llc$load_map_diagnostics + 297,
      {E +P +P has a mode mismatch.}

    lle$actual_less_than_formal     = llc$load_map_diagnostics + 298,
      {E +P parameter number +P }

    lle$bad_char_length             = llc$load_map_diagnostics + 299,
      {E +P has character length mismatch on parameter +P. }

    llc$max_load_map_diagnostic     = llc$load_map_diagnostics + 299;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??

*DECK DECK=LLH$OBJECT_MODULE_DESCRIPTION EXPAND=FALSE
{
{
{    The general form of an object module is a file of binary records
{  with the following topology:
{
{          < object text descriptor # 1 >
{            < object text record # 1 >
{          < object text descriptor # 2 >
{            < object text record # 2 >
{                      ...
{          < object text descriptor # n >
{            <object text record # n >
{
{    For the sake of simplicity the record descriptor - record pairs
{  will be referred to as records hereafter.
{
{    For a CPU program, the object text records must be arranged in
{  the following order:
{
{          1). Identification record
{          2.) Library, section definition, text, bit string insertion,
{              address formulation, external linkage, entry definition,
{              relocation, formal parameter specification, actual
{              parameter specification and binding template records in
{              arbitrary order with the one stipulation that a section
{              definition record must precede any other object text
{              records that refer to the section.
{          3). Transfer symbol record.
{
{    For a PPU program or overlay, the object text records must be
{  arranged in the following order:
{
{        1.) Identification record
{        2.) PPU absolute record
{
{
*DECK DECK=LLT$68000_ABSOLUTE EXPAND=FALSE

  TYPE
    llt$68000_absolute = record
      load_address: llt$68000_address,
      transfer_address: llt$68000_address,
      text: SEQ ( * ), { REP n OF byte }
    recend;

*copyc llt$68000_address
*DECK DECK=LLT$68000_ABSOLUTE_OBJECT_TEXT EXPAND=FALSE
*copyc OST$DATE
*copyc OST$TIME
*copyc PMT$PROGRAM_NAME
*copyc AMT$LOCAL_FILE_NAME
*copyc PMD$PPU_CHARACTERISTICS
*copyc llh$object_module_description
*copyc LLT$OBJECT_TEXT_DESCRIPTOR
*copyc LLT$OBJECT_RECORD_KIND
*copyc LLT$IDENTIFICATION
*copyc LLT$MODULE_KIND
*copyc LLT$MODULE_GENERATOR
*copyc LLT$MODULE_ATTRIBUTES
*copyc llt$68000_absolute
*copyc llt$68000_address
*DECK DECK=LLT$68000_ADDRESS EXPAND=FALSE

*IF $true(osv$unix)

  CONST
    llc$maximum_68000_address = 7fffffff(16);

*ELSE

  CONST
    llc$maximum_68000_address = 0ffffffff(16);

*IFEND

  TYPE
    llt$68000_address = 0 .. llc$maximum_68000_address;

*DECK DECK=LLT$ACTUAL_PARAMETERS EXPAND=FALSE


{ Procedure call actual parameters record. }

  TYPE
    llt$actual_parameters = record
      callee_name: pmt$program_name,
      language: llt$module_generator,
      line_number_of_call: llt$source_line_number,
      specification: SEQ ( * ),
    recend;
*copyc PMT$PROGRAM_NAME
*copyc LLT$MODULE_GENERATOR
*copyc LLT$SOURCE_LINE_NUMBER
*DECK DECK=LLT$ADDRESS EXPAND=FALSE

  TYPE
    llt$address = packed record
      ring: ost$ring,
      segment: ost$segment,
      offset: ost$segment_offset,
    recend;

*copyc osd$virtual_address

*DECK DECK=LLT$ADDRESS_FORMULATION EXPAND=FALSE


{ Address formulation record. }

  TYPE
    llt$address_formulation = record
      value_section: llt$section_ordinal,
      dest_section: llt$section_ordinal,
      item: array [1 .. * ] of llt$address_formulation_item,
    recend,

    llt$address_formulation_item = record
      kind: llt$internal_address_kind,
      value_offset: llt$section_address_range,{only llc$address can be negative}
      dest_offset: llt$section_offset,
    recend;

*copyc llt$section_address
*copyc LLT$INTERNAL_ADDRESS_KIND
*DECK DECK=LLT$ADDRESS_KIND EXPAND=FALSE

  TYPE
    llt$address_kind = (llc$address, llc$internal_proc, llc$short_address,
      llc$external_proc, llc$address_addition, llc$address_subtraction);
*DECK DECK=LLT$ADDRESS_TYPE EXPAND=FALSE

  TYPE
    llt$address_type = (llc$byte_positive, llc$two_byte_positive,
      llc$four_byte_positive, llc$eight_byte_positive, llc$byte_signed,
      llc$two_byte_signed, llc$four_byte_signed, llc$eight_byte_signed);
*DECK DECK=LLT$APPLICATION_IDENTIFIER EXPAND=FALSE

{ Application identifier record }

  TYPE
    llt$application_identifier = record
      name: ost$name,
    recend;

*copyc ost$name
*DECK DECK=LLT$ARGUMENT_USAGE EXPAND=FALSE

  TYPE
    llt$argument_usage = (llc$argument_written, llc$argument_not_written);
*DECK DECK=LLT$BINDING_TEMPLATE EXPAND=FALSE


{ Binding template record }

  TYPE
    llt$binding_template = record
      binding_offset: llt$section_offset,
      case kind: llt$binding_template_kind of
      = llc$current_module =
        section_ordinal: llt$section_ordinal,
        offset: llt$section_address_range,
        internal_address: llt$internal_address_kind,
      = llc$external_reference =
        name: pmt$program_name,
        address: llt$address_kind,
      casend,
    recend;

*copyc llt$section_address
*copyc LLT$BINDING_TEMPLATE_KIND
*copyc PMT$PROGRAM_NAME
*copyc LLT$ADDRESS_KIND
*copyc LLT$INTERNAL_ADDRESS_KIND
*DECK DECK=LLT$BINDING_TEMPLATE_KIND EXPAND=FALSE

  TYPE
    llt$binding_template_kind = (llc$current_module, llc$external_reference);
*DECK DECK=LLT$BIT_STRING_INSERTION EXPAND=FALSE


{ Bit insertion record. }

  TYPE
    llt$bit_string_insertion = record
      section_ordinal: llt$section_ordinal,
      offset: llt$section_offset,
      bit_offset: 0 .. 7,
      bit_length: llt$bit_string_length,
      bit_string: packed array [llt$bit_string_length] of 0 .. 1,
    recend,

    llt$bit_string_length = 1 .. llc$max_bit_string_length;

  CONST
    llc$max_bit_string_length = 63;

*copyc llt$section_address
*DECK DECK=LLT$COMMAND_DESCRIPTION EXPAND=FALSE

  TYPE
    llt$command_description = SEQ ( * );

  TYPE
    llt$command_desc_contents = record
      version: 0 .. 255 {allows future changes} ,
      case system_command: boolean of
      = TRUE =
        system_command_name: pmt$program_name,
      = FALSE =
        starting_procedure: pmt$program_name,
        library_path_size: fst$path_size,

{ If the library_path_size field is non-zero, an fst$file_reference
{ of the specified size immediately follows this record in the
{ llt$command_description SEQuence.
{ If the library_path_size field is zero, no library was specified
{ in the description.

      casend,
    recend;

  CONST
    llc$command_desc_version = 1;

*copyc fst$file_reference
*copyc fst$path_size
*copyc pmt$program_name
*DECK DECK=LLT$COMMAND_DICTIONARY EXPAND=FALSE



{ The command dictionary is in alphabetical order.

  TYPE
    llt$command_dictionary = array [1 .. * ] of llt$command_dictionary_item,

    llt$command_dictionary_item = record
      name: clt$command_name,
      class: clt$named_entry_class,
      availability: clt$named_entry_availability,
      ordinal: clt$named_entry_ordinal,
      kind: llt$command_kind,
      log_option: clt$command_log_option,
      case module_kind: llt$library_module_kind of
      = llc$command_procedure =
        command_header: REL (llt$object_library) ^llt$library_member_header,
      = llc$program_description =
        program_header: REL (llt$object_library) ^llt$library_member_header,
      = llc$command_description =
        command_description_header: REL (llt$object_library)
              ^llt$library_member_header,
      = llc$load_module =
        module_header: REL (llt$object_library) ^llt$load_module_header,
      = llc$applic_command_procedure =
        applic_command_header: REL (llt$object_library)
              ^llt$application_member_header,
      = llc$applic_program_description =
        applic_program_header: REL (llt$object_library)
              ^llt$application_member_header,
      = llc$applic_command_description =
        applic_command_description_hdr: REL (llt$object_library)
              ^llt$application_member_header,
      casend,
    recend,

    llt$command_index = 0 .. llc$max_commands_in_library;

  CONST
    llc$max_commands_in_library = 7fffffff(16);

*copyc clt$command_log_option
*copyc clt$command_name
*copyc clt$named_entry_availability
*copyc clt$named_entry_class
*copyc clt$named_entry_ordinal
*copyc llt$command_kind
*copyc llt$library_member_header
*copyc llt$library_module_kind
*copyc llt$load_module_header
*DECK DECK=LLT$COMMAND_KIND EXPAND=FALSE

  TYPE
    llt$command_kind = (llc$entry_point, llc$gate, llc$local_to_library);
*DECK DECK=LLT$DEBUG_OBJECT_TEXT EXPAND=FALSE

*copy llt$object_module
*copyc CYD$DEBUG_SYMBOLS
*copyc LLT$LINE_ADDRESS_TABLE
*copyc DBT$MODULE_ADDRESS_TABLE_ITEM
*copyc DBT$ENTRY_POINT_TABLE
*DECK DECK=LLT$DEBUG_SYMBOL_TABLE EXPAND=FALSE

  TYPE
    llt$debug_symbol_table = record
      original_module_name: pmt$program_name,
      language: llt$module_generator,
      optimization_level: llt$optimization_level,
      version: llt$symbol_table_version,
      first_symbol_for_module: llt$symbol_number,
      number_of_items: llt$symbol_number,
      attributes: llt$symbol_table_attributes,
      item: array [1 .. * ] of llt$symbol_table_item,
    recend,

    llt$symbol_table_item = record
      symbol_name: pmt$program_name,
      symbol_number: llt$symbol_number,
      end_of_chain: boolean,
      case symbol_kind: llt$entry_kind of
      = llc$integer_kind, llc$boolean_kind, llc$char_kind, llc$real_kind,
        llc$longreal_kind, llc$cell_kind, llc$complex_kind,
          llc$ftn_logical_kind, llc$ftn_boolean_kind,
          llc$shortreal_kind, llc$ftn_subprogram_name, llc$ftn_character_kind,
          llc$typeless_kind, llc$filename_kind, llc$bdp_pdu, llc$bdp_pdulsd,
          llc$bdp_pds, llc$bdp_pdslsd, llc$bdp_udu, llc$bdp_udtsch,
          llc$bdp_udtss, llc$bdp_bu, llc$bdp_tpds, llc$bdp_tpdslsd,
          llc$bdp_tbu, llc$bdp_tbs, llc$bdp_a, llc$cobol_justified,
          llc$cobol_index_data_item, llc$cobol_index_name, llc$bdp_udlsch,
          llc$bdp_udlss, llc$cobol_numeric_edited, llc$cobol_a_edited,
          llc$unsigned_integer_kind =
        ,
      = llc$bit_kind =
        bit_offset: llt$bit_offset,
      = llc$var_kind =
        var_type: llt$symbol_number,
        var_length: llt$section_length,
        var_base: llt$base_type,
        var_section_ordinal: llt$section_ordinal,
        var_offset: llt$section_address_range,
        var_attributes: llt$var_attributes,
        var_containing_symbol: llt$symbol_number,
        var_point_location: llt$point_location,
      = llc$cobol_array_kind =
        cobol_array_element_type: llt$entry_kind,
        cobol_subscript_count: llt$subscript_range,
        max_cobol_subscript_value: llt$max_cobol_subscript_value,
        occurrence_length: llt$section_length,
      = llc$constant_kind =
        constant_type: llt$symbol_number,
        constant_length: llt$section_length,
        case constant_kind: llt$constant_kind of
        = llc$short_constant =
          short_constant_value: llt$short_constant_value,
        = llc$medium_constant =
          medium_constant_value: llt$medium_constant_value,
        = llc$long_constant =
          constant_section_ordinal: llt$section_ordinal,
          constant_offset: llt$section_offset,
        casend,
      = llc$label_kind =
        label_attributes: llt$label_attributes,
        label_section_ordinal: llt$section_ordinal,
        label_offset: llt$section_address_range,
        label_scope: llt$section_length,
        label_containing_symbol: llt$symbol_number,
      = llc$ordinal_kind =
        last_constant: llt$symbol_number,
        ordinal_upper_bound: llt$ordinal_upper_bound,
      = llc$subrange_kind =
        subtype: llt$symbol_number,
        low_value_type: llt$length_kind,
        high_value_type: llt$length_kind,
        low_value: integer,
        high_value: integer,
      = llc$proc_kind =
        proc_lexical_level: llt$lexical_level,
        first_symbol_for_proc: llt$symbol_number,
        proc_section_ordinal: llt$section_ordinal,
        proc_offset: llt$section_offset,
        proc_length: llt$section_length,
        proc_parent: llt$symbol_number,
        proc_attributes: llt$proc_attributes,
        proc_return_type: llt$symbol_number,
        proc_return_length: llt$string_length_range,
      = llc$pointer_kind =
        ptr_type: llt$symbol_number,
        ptr_object_length: llt$section_length,
      = llc$set_kind =
        set_element_type: llt$symbol_number,
        set_length: llt$set_length,
      = llc$string_kind =
        string_length_type: llt$length_kind,
        string_length: llt$string_length_range,
      = llc$cybil_array_kind =
        cybil_array_binding: llt$binding_kind,
        cybil_array_packing: llt$packing_attribute,
        cybil_array_attributes: llt$cybil_array_attributes,
        cybil_index_type: llt$symbol_number,
        cybil_array_element_type: llt$symbol_number,
        cybil_array_element_length: llt$section_length_in_bits,
      = llc$record_kind =
        record_binding: llt$binding_kind,
        record_packing: llt$packing_attribute,
        record_attributes: llt$record_attributes,
        record_first_field: llt$symbol_number,
        record_length: llt$section_length_in_bits,
        record_selector: llt$symbol_number,
      = llc$field_kind =
        field_offset: llt$section_length_in_bits,
        field_length: llt$section_length_in_bits,
        field_attributes: llt$field_attributes,
        field_type: llt$symbol_number,
        next_field: llt$symbol_number,
      = llc$selector_kind =
        variation: llt$symbol_number,
        next_selector: llt$symbol_number,
        low_selector: integer,
        high_selector: integer,
      = llc$heap_kind =
        ,
      = llc$seq_kind =
        ,
      = llc$bound_vrec_kind =
        bound_type: llt$symbol_number,
      = llc$rel_ptr_kind =
        parent_type: llt$symbol_number,
        object_type: llt$symbol_number,
        rel_ptr_object_length: llt$section_length,
      = llc$ftn_array_kind =
        ftn_array_element_type: llt$symbol_number,
        ftn_array_element_length: llt$string_length_range,
        ftn_array_base: llt$base_type,
        ftn_array_section_ordinal: llt$section_ordinal,
        ftn_array_offset: llt$section_offset,
        ftn_array_attributes: llt$ftn_array_attributes,
        dimension_info_section_ordinal: llt$section_ordinal,
        dimension_info_offset: llt$section_offset,
      = llc$namelist_group_kind =
        namelist_info_section_ordinal: llt$section_ordinal,
        namelist_info_offset: llt$section_offset,
        namelist_attributes: llt$ftn_namelist_attributes,
      = llc$equated_label =
        first_equated_symbol: llt$symbol_number,
      = llc$external_equate =
        operation: llt$external_arithmetic_oper,
        operand: integer,
      = llc$basic_array_kind =
        basic_array_element_type: llt$symbol_number,
      = llc$pascal_conf_array_kind =
        conf_array_packing: llt$packing_attribute,
        conf_array_attributes: llt$cybil_array_attributes,
        conf_array_lower_bound: llt$symbol_number,
        conf_array_upper_bound: llt$symbol_number,
        conf_array_element_kind: llt$symbol_number,
        conf_array_element_length: llt$section_length_in_bits,
      = llc$pascal_file_kind =
        buffer_type: llt$symbol_number,
      = llc$pascal_with_kind =
        with_first_symbol: llt$symbol_number,
        with_section_ordinal: llt$section_ordinal,
        with_offset: llt$section_offset,
        with_length: llt$section_length,
        with_parent: llt$symbol_number,
      casend
    recend,

    llt$entry_kind = (llc$integer_kind, llc$boolean_kind, llc$char_kind,
      llc$real_kind, llc$longreal_kind, llc$cell_kind, llc$complex_kind,
      llc$ftn_logical_kind, llc$ftn_boolean_kind, llc$bit_kind,
      llc$shortreal_kind, llc$ftn_subprogram_name, llc$ftn_character_kind,
      llc$typeless_kind, llc$filename_kind, llc$var_kind, llc$cobol_array_kind,
      llc$constant_kind, llc$label_kind, llc$ordinal_kind, llc$subrange_kind,
      llc$proc_kind, llc$pointer_kind, llc$set_kind, llc$string_kind,
      llc$cybil_array_kind, llc$record_kind, llc$field_kind, llc$selector_kind,
      llc$heap_kind, llc$seq_kind, llc$bound_vrec_kind, llc$rel_ptr_kind,
      llc$ftn_array_kind, llc$namelist_group_kind, llc$bdp_pdu, llc$bdp_pdulsd,
      llc$bdp_pds, llc$bdp_pdslsd, llc$bdp_udu, llc$bdp_udtsch, llc$bdp_udtss,
      llc$bdp_bu, llc$bdp_tpds, llc$bdp_tpdslsd, llc$bdp_tbu, llc$bdp_tbs,
      llc$bdp_a, llc$cobol_justified, llc$cobol_index_data_item,
      llc$cobol_index_name, llc$bdp_udlsch, llc$bdp_udlss,
      llc$cobol_numeric_edited, llc$cobol_a_edited, llc$equated_label,
      llc$external_equate, llc$basic_array_kind,
      llc$pascal_conf_array_kind, llc$pascal_file_kind, llc$pascal_with_kind,
      llc$unsigned_integer_kind),

    llt$base_type = (llc$null_base, llc$static_base, llc$constant_base,
      llc$stack_frame_base, llc$parm_list_base, llc$xref_base,
      llc$register_base),

    llt$lexical_level = 0 .. llc$max_lexical_level,

    llt$point_location = packed record
      value: - 18 .. 18,
    recend,

    llt$subscript_range = 0 .. 48,

    llt$ordinal_upper_bound = 0 .. llc$max_ordinal,

    llt$var_attribute = (llc$var_qualifier_needed,
      llc$var_indirectly_referenced, llc$var_is_dummy_argument,
      llc$non_source_variable, llc$var_attribute_spare5,
      llc$var_attribute_spare6, llc$var_attribute_spare7,
      llc$var_attribute_spare8),

    llt$var_attributes = set of llt$var_attribute,

    llt$label_attribute = (llc$label_qualifier_needed, llc$cobol_section_name,
      llc$cobol_paragraph_name, llc$no_object_code_for_label,
      llc$non_source_label, llc$label_attribute_spare6,
      llc$label_attribute_spare7, llc$label_attribute_spare8),

    llt$label_attributes = set of llt$label_attribute,

    llt$symbol_number = 0 .. llc$max_symbol_number,


    llt$length_kind = (llc$short_length, llc$long_length,
      llc$variable_length, llc$adaptable_length, llc$dynamic_length,
      llc$indefinite_length, llc$null_terminator_length),

    llt$packing_attribute = (llc$packed, llc$unpacked, llc$not_packed),

    llt$binding_kind = (llc$fixed_binding, llc$variable_spare_binding,
      llc$adaptable_binding, llc$variant_binding),

    llt$string_length_range = 0 .. llc$max_string_length,

    llt$set_length = 0 .. llc$max_set_length,

    llt$symbol_table_version = string (4),

    llt$proc_attribute = (llc$multiple_entry_points,
      llc$proc_uses_outer_level_stack,
      llc$proc_attribute_spare3, llc$proc_attribute_spare4,
      llc$proc_attribute_spare5, llc$proc_attribute_spare6,
      llc$proc_attribute_spare7, llc$proc_attribute_spare8),

    llt$cybil_array_attribute = (llc$cybil_array_is_bits,
      llc$cyb_array_attribute_spare2, llc$cyb_array_attribute_spare3,
      llc$cyb_array_attribute_spare4, llc$cyb_array_attribute_spare5,
      llc$cyb_array_attribute_spare6, llc$cyb_array_attribute_spare7,
      llc$cyb_array_attribute_spare8),

    llt$cybil_array_attributes = set of llt$cybil_array_attribute,

    llt$record_attribute = (llc$record_variation, llc$record_attribute_spare2,
      llc$record_attribute_spare3, llc$record_attribute_spare4,
      llc$record_attribute_spare5, llc$record_attribute_spare6,
      llc$record_attribute_spare7, llc$record_attribute_spare8),

    llt$record_attributes = set of llt$record_attribute,

    llt$field_attribute = (llc$field_is_byte_addressable,
      llc$field_attribute_spare2, llc$field_attribute_spare3,
      llc$field_attribute_spare4, llc$field_attribute_spare5,
      llc$field_attribute_spare6, llc$field_attribute_spare7,
      llc$field_attribute_spare8),

    llt$field_attributes = set of llt$field_attribute,

    llt$ftn_array_attribute = (llc$ftn_array_is_parameter,
      llc$ftn_storage_is_columnwise, llc$ftn_array_adjustable,
      llc$ftn_array_assumed_size, llc$ftn_array_assumed_shape,
      llc$ftn_array_indirect_accessed, llc$cdc_ftn_dimension_desc,
      llc$ftn_array_attribute_spare8),

    llt$ftn_array_attributes = set of llt$ftn_array_attribute,
    llt$proc_attributes = set of llt$proc_attribute,

    llt$constant_kind = (llc$short_constant, llc$medium_constant,
      llc$long_constant),
    llt$short_constant_value = record
      case kind: llt$entry_kind of
      = llc$boolean_kind, llc$ftn_logical_kind =
        boolean_value: boolean,
      = llc$char_kind =
        char_value: char,
      = llc$bit_kind =
        bit_value: 0 .. 1,
      = llc$integer_kind =
        integer_value: - 8000(16) .. 7fff(16),
      casend,
    recend,

    llt$medium_constant_value = record
      case kind: llt$entry_kind of
      = llc$integer_kind, llc$ftn_boolean_kind =
        integer_value: integer,
      = llc$real_kind =
        real_value: real,
      = llc$shortreal_kind =
        shortreal_value: - 7fffffff(16) .. 7fffffff(16),
      casend,
    recend,

    llt$symbol_table_attribute = (llc$symbol_number_is_index,
      llc$language_is_case_sensitive, llc$sym_table_attribute_spare3,
      llc$sym_table_attribute_spare4, llc$sym_table_attribute_spare5,
      llc$sym_table_attribute_spare6, llc$sym_table_attribute_spare7,
      llc$sym_table_attribute_spare8),

    llt$symbol_table_attributes = set of llt$symbol_table_attribute,

    llt$max_cobol_subscript_value = 0 .. llc$max_section_offset,

    llt$external_arithmetic_oper = (llc$external_no_operation,
      llc$external_addition, llc$external_subtraction,
      llc$external_multiplication, llc$external_division),

    llt$bit_offset = 0 .. llc$max_bit_offset,

    llt$ftn_namelist_attribute = (llc$cdc_ftn_namelist_descriptor,
      llc$namelist_descriptor_spare2, llc$namelist_descriptor_spare3,
      llc$namelist_descriptor_spare4, llc$namelist_descriptor_spare5,
      llc$namelist_descriptor_spare6, llc$namelist_descriptor_spare7,
      llc$namelist_descriptor_spare8),

    llt$ftn_namelist_attributes = set of llt$ftn_namelist_attribute;

  CONST
    llc$symbol_table_version = 'V1.1',
    llc$max_lexical_level = 255,
    llc$max_ordinal = 65535,
    llc$max_symbol_number = 65535,
    llc$max_string_length = 65535,
    llc$max_set_length = 65535,
    llc$max_bit_offset = 7;

*copyc PMT$PROGRAM_NAME
*copyc llt$section_address
*copyc LLT$MODULE_GENERATOR
*copyc llt$optimization_level
*DECK DECK=LLT$DECLARATION_MATCHING_VALUE EXPAND=FALSE

  TYPE
    llt$declaration_matching_value = RECORD
      CASE llt$module_generator OF
      = llc$cybil =
        object_encryption: 0 .. 0FFFFFFFF(16),
        source_encryption: 0 .. 0FFFFFFFF(16),
      = llc$algol .. llc$lisp =
        language_dependent_value: integer,
      CASEND,
    RECEND;

*copyc llt$module_generator
*DECK DECK=LLT$DEFERRED_COMMON_BLOCKS EXPAND=FALSE

{ Deferred common block definitions

  TYPE
    llt$deferred_common_blocks = array [1 .. * ] of
          llt$common_block_definition,

    llt$common_block_definition = record
      name: pmt$program_name,
      global_lock: ost$key_lock_value,
      loaded_ring: ost$valid_ring,
      address: llt$address,
      allocation_length: ost$segment_length,
      allocation_alignment: ost$segment_offset,
      allocation_offset: ost$segment_offset,
      access_attributes: llt$section_access_attributes,
      segment_access_control: ost$segment_access_control,
      extensible: boolean,
      unallocated_common: boolean,
      unallocated_common_open: boolean,
      unallocated_common_segment: ost$segment,
      unallocated_common_file_id: amt$file_identifier,
    recend;

*copyc amt$file_identifier
*copyc llt$address
*copyc llt$section_access_attributes
*copyc osd$virtual_address
*copyc ost$segment_access_control
*copyc pmt$program_name

*DECK DECK=LLT$DEFERRED_ENTRY_POINTS EXPAND=FALSE

{ Deferred entry point definitions

  TYPE
    llt$deferred_entry_points = array [1 .. * ] of llt$deferred_entry_point;

  TYPE
    llt$deferred_entry_point = record
      address: llt$address,
      section_ordinal: llt$section_ordinal,
      attributes: llt$entry_point_attributes,
      name: pmt$program_name,
      language: llt$module_generator,
      declaration_matching_required: boolean,
      declaration_matching_value: llt$declaration_matching_value,
      source_type_checking: boolean,
      binding_section_address: llt$address,
    recend;

*copyc llt$address
*copyc llt$declaration_matching_value
*copyc llt$entry_point_attributes
*copyc llt$module_generator
*copyc llt$section_address
*copyc pmt$program_name
*DECK DECK=LLT$ENTRY_DEFINITION EXPAND=FALSE


{ Entry point definition record. }

  TYPE
    llt$entry_definition = record
      section_ordinal: llt$section_ordinal,
      offset: llt$section_offset,
      attributes: llt$entry_point_attributes,
      name: pmt$program_name,
      language: llt$module_generator,
      declaration_matching_required: boolean,
      declaration_matching: llt$declaration_matching_value,
    recend;

*copyc llt$declaration_matching_value
*copyc llt$entry_point_attributes
*copyc llt$module_generator
*copyc llt$section_address
*copyc pmt$program_name
*DECK DECK=LLT$ENTRY_POINT_ATTRIBUTES EXPAND=FALSE

  TYPE
    llt$entry_point_attributes = set of (llc$epa_unused_6, llc$epa_unused_5,
      llc$epa_unused_4, llc$epa_unused_3, llc$epa_unused_2, llc$epa_unused_1,
      llc$retain_entry_point, llc$gated_entry_point);
*DECK DECK=LLT$ENTRY_POINT_DICTIONARY EXPAND=FALSE
 { The entry point dictionary is in alphbetical order. }

  TYPE
    llt$entry_point_dictionary = array [1 .. * ] of
      llt$entry_point_dictionary_item,

    llt$entry_point_dictionary_item = record
      name: pmt$program_name,
      kind: llt$entry_point_kind,
      case module_kind: llt$library_module_kind of
      = llc$load_module =
        module_header: REL (llt$object_library) ^llt$load_module_header,

        { The remaining variants are not used in library versions 1.1 and
        {following}

      = llc$program_description =
        program_header: REL (llt$object_library) ^llt$library_member_header,
      = llc$command_procedure =
        command_header: REL (llt$object_library) ^llt$library_member_header,
      casend,
    recend,

    llt$entry_point_kind = llc$entry_point .. llc$gate,

    llt$entry_point_index = 0 .. llc$max_entry_points_in_library;

  CONST
    llc$max_entry_points_in_library = 0ffffff(16);

*copyc llt$command_kind
*copyc llt$library_member_header
*copyc llt$library_module_kind
*copyc llt$load_module_header
*copyc pmt$program_name
*DECK DECK=LLT$EXTERNAL_LINKAGE EXPAND=FALSE


{ External reference record. }

  TYPE
    llt$external_linkage = record
      name: pmt$program_name,
      language: llt$module_generator,
      declaration_matching_required: boolean,
      declaration_matching: llt$declaration_matching_value,
      item: array [1 .. * ] of llt$external_linkage_item,
    recend,

    llt$external_linkage_item = record
      section_ordinal: llt$section_ordinal,
      offset: llt$section_offset,
      kind: llt$address_kind,
      offset_operand: llt$section_address_range,
    recend;

*copyc llt$address_kind
*copyc llt$declaration_matching_value
*copyc llt$module_generator
*copyc llt$section_address
*copyc pmt$program_name
*DECK DECK=LLT$FORMAL_PARAMETERS EXPAND=FALSE


{ Procedure formal parameter description record. }

  TYPE
    llt$formal_parameters = record
      procedure_name: pmt$program_name,
      language: llt$module_generator,
      specification: SEQ ( * ),
    recend;

*copyc PMT$PROGRAM_NAME
*copyc LLT$MODULE_GENERATOR
*DECK DECK=LLT$FORM_DEFINITION EXPAND=FALSE

TYPE
  llt$form_definition = SEQ (*);
*DECK DECK=LLT$FORTRAN_ARGUMENT_DESC EXPAND=FALSE


{ FORTRAN argument description: used to describe a single actual or
{ formal parameter.

  TYPE
    llt$fortran_argument_desc = record
      argument_type: llt$fortran_argument_type,
      string_length: llt$fortran_string_length,
            { used for types CHAR and INTEGER }
      argument_kind: llt$fortran_argument_kind,
      array_size: llt$fortran_array_size, { only used for kind  ARRAY }
      dummy_argument_ordinal: 0 .. llc$max_fortran_arguments, { only used }

{ for actual argument kind of UNKNOWN. Points back to formal parameter
{ passed on by this call.

      mode: llt$argument_usage,
    recend;

  CONST
    llc$max_fortran_arguments = 500;

*copyc llt$fortran_argument_type
*copyc llt$fortran_string_length
*copyc llt$fortran_argument_kind
*copyc llt$fortran_array_size
*copyc llt$argument_usage
*DECK DECK=LLT$FORTRAN_ARGUMENT_KIND EXPAND=FALSE

  TYPE
    llt$fortran_argument_kind = (llc$fortran_variable,
      llc$fortran_array, llc$fortran_external, llc$fortran_array_element,
      llc$fortran_unknown_arg_kind);
*DECK DECK=LLT$FORTRAN_ARGUMENT_TYPE EXPAND=FALSE

  TYPE
    llt$fortran_argument_type = (llc$fortran_logical, llc$fortran_integer,
      llc$fortran_real, llc$fortran_double_real, llc$fortran_complex,
      llc$fortran_char, llc$fortran_boolean, llc$fortran_null_type,
      llc$fortran_statement_label, llc$fortran_half_real, llc$fortran_bit);
*DECK DECK=LLT$FORTRAN_ARRAY_SIZE EXPAND=FALSE

  TYPE
    llt$fortran_array_size = record
      attributes: llt$fortran_array_attributes,
      rank: llt$fortran_array_rank,
      number_of_elements: llt$section_length,
    recend;

  TYPE
    llt$fortran_array_attributes = set of llt$fortran_array_attribute,

    llt$fortran_array_attribute = (llc$fortran_assumed_len_array,
      llc$fortran_adaptable_array, llc$fortran_assumed_shape_array,
      llc$fortran_array_section,
      llc$faa_reserved_4, llc$faa_reserved_3, llc$faa_reserved_2,
      llc$faa_reserved_1);

  TYPE
    llt$fortran_array_rank = 0 .. llc$max_fortran_array_rank;

  CONST
    llc$max_fortran_array_rank = 7;

*copyc llt$section_address
*DECK DECK=LLT$FORTRAN_STRING_LENGTH EXPAND=FALSE

  TYPE
    llt$fortran_string_length = record
      attributes: llt$fortran_string_attributes,
      number_of_characters: llt$fortran_string_size,
    recend;

  TYPE
    llt$fortran_string_size = 0 .. llc$max_fortran_string_size;

  TYPE
    llt$fortran_string_attributes = set of llt$fortran_string_attribute,

    llt$fortran_string_attribute = (llc$fortran_assumed_len_string,
      llc$fsa_reserved_7, llc$fsa_reserved_6, llc$fsa_reserved_5,
      llc$fsa_reserved_4, llc$fsa_reserved_3, llc$fsa_reserved_2,
      llc$fsa_reserved_1);

  CONST
    llc$max_fortran_string_size = 0ffff(16);
*DECK DECK=LLT$FUNCTION_DESCRIPTION EXPAND=FALSE

  TYPE
    llt$function_description = SEQ ( * );

  TYPE
    llt$function_desc_contents = record
      version: 0 .. 255 {allows future changes} ,
      starting_procedure: pmt$program_name,
      library_path_size: fst$path_size,
      { If the library_path_size field is non-zero, an fst$file_reference
      { of the specified size immediately follows this record in the
      { llt$function_description SEQuence.
      { If the library_path_size field is zero, no library was specified
      { in the description.
    recend;

  CONST
    llc$function_desc_version = 1;

*copyc fst$file_reference
*copyc fst$path_size
*copyc pmt$program_name
*DECK DECK=LLT$FUNCTION_DICTIONARY EXPAND=FALSE


{ The function dictionary is in alphbetical order. }

  TYPE
    llt$function_dictionary = array [1 .. * ] of llt$function_dictionary_item,

    llt$function_dictionary_item = record
      name: clt$function_name,
      class: clt$named_entry_class,
      availability: clt$named_entry_availability,
      ordinal: clt$named_entry_ordinal,
      kind: llt$function_kind,
      case module_kind: llt$library_module_kind of
      = llc$function_procedure =
        function_header: REL (llt$object_library) ^llt$library_member_header,
      = llc$function_description =
        function_description_header: REL (llt$object_library)
              ^llt$library_member_header,
      casend,
    recend,

    llt$function_kind = llt$command_kind,

    llt$function_index = 0 .. llc$max_functions_in_library;

  CONST
    llc$max_functions_in_library = 7fffffff(16);

*copyc clt$function_name
*copyc clt$named_entry_availability
*copyc clt$named_entry_class
*copyc clt$named_entry_ordinal
*copyc llt$command_kind
*copyc llt$library_member_header
*copyc llt$library_module_kind
*DECK DECK=LLT$HELP_MODULE_DICTIONARY EXPAND=FALSE
 { The help module dictionary is in alphbetical order. }

  TYPE
    llt$help_module_dictionary = array [1 .. * ] of
      llt$help_module_dictionary_item,

    llt$help_module_dictionary_item = record
      name: pmt$program_name,
      language: ost$natural_language,
      help_header: REL (llt$object_library) ^llt$library_member_header,
    recend,

    llt$help_module_index = 0 .. llc$max_help_modules_in_library;

  CONST
    llc$max_help_modules_in_library = 7fffffff(16);

*copyc llt$library_member_header
*copyc ost$natural_language
*copyc pmt$program_name
*DECK DECK=LLT$IDENTIFICATION EXPAND=FALSE


{ Identification record. }

  TYPE
    llt$identification = record
      name: pmt$program_name,
      object_text_version: string (4),
      kind: llt$module_kind,
      time_created: ost$time,
      date_created: ost$date,
      attributes: llt$module_attributes,
      greatest_section_ordinal: llt$section_ordinal,
      generator_id: llt$module_generator,
      generator_name_vers: string (40),
      commentary: string (40),
    recend;

  CONST
    llc$object_text_version = 'V1.4';

*copyc PMT$PROGRAM_NAME
*copyc LLT$MODULE_KIND
*copyc OST$TIME
*copyc OST$DATE
*copyc LLT$MODULE_ATTRIBUTES
*copyc llt$section_address
*copyc LLT$MODULE_GENERATOR
*DECK DECK=LLT$INFORMATION_ELEMENT EXPAND=FALSE


  TYPE
    llt$code_element = array [ * ] of 0 .. 255;


  { Original version }

  TYPE
    llt$info_element_hdr = record
      relocation_ptr: REL (llt$object_library) ^llt$relocation,
      number_of_rel_items: 0 .. llc$max_rel_items,
      component_ptr: REL (llt$object_library) ^llt$component_information,
      number_of_components: 0 .. llc$max_components,
      binding_template_ptr: REL (llt$object_library)
        ^llt$binding_section_template,
      number_of_template_items: 0 .. llc$max_binding_items,
    recend;


  CONST
    llc$info_element_version_1_0 = 'V1.0';

  TYPE
    llt$info_element_header_1_0 = record
      version: llt$version,
      relocation_ptr: REL (llt$object_library) ^llt$relocation,
      number_of_rel_items: 0 .. llc$max_rel_items,
      component_ptr: REL (llt$object_library) ^llt$component_information,
      number_of_components: 0 .. llc$max_components,
      binding_template_ptr: REL (llt$object_library)
        ^llt$binding_section_template,
      number_of_template_items: 0 .. llc$max_binding_items,
      section_maps: REL (llt$object_library) ^llt$section_maps,
      number_of_section_maps: llt$number_of_sections,
    recend;


  CONST
    llc$info_element_version = 'V1.1';

  TYPE
    llt$info_element_header = record
      version: llt$version,
      relocation_ptr: REL (llt$object_library) ^llt$relocation,
      number_of_rel_items: llt$number_of_info_elements,
      component_ptr: REL (llt$object_library) ^llt$component_information,
      number_of_components: 0 .. llc$max_components,
      binding_template_ptr: REL (llt$object_library)
        ^llt$binding_section_template,
      number_of_template_items: llt$number_of_info_elements,
      section_maps: REL (llt$object_library) ^llt$section_maps,
      number_of_section_maps: llt$number_of_sections,
    recend;


  CONST
*IF $true(osv$unix)
    llc$max_info_elements = 7fffffff(16),
*ELSE
    llc$max_info_elements = 0ffffffff(16),
*IFEND
    llc$max_components = 0ffff(16),
    llc$max_binding_items = 0ffff(16);

  TYPE
    llt$version = string ( 4 ),
    llt$number_of_info_elements = 0 .. llc$max_info_elements;


  TYPE
    llt$component_information = array [1 .. * ] of llt$component_description,

    llt$component_description = record
      name: pmt$program_name,
      time_created: ost$time,
      date_created: ost$date,
      generator_id: llt$module_generator,
      generator_name_vers: string (40),
      commentary: string (40),
    recend;


  TYPE
    llt$binding_section_template = array [1 .. * ] of llt$binding_template;


  TYPE
    llt$number_of_sections = 0 .. llc$max_section_ordinal + 1;

  TYPE
    llt$section_maps = array [0 .. *] of llt$section_map;

  TYPE
    llt$section_map = record
      number_of_items: llt$number_of_sections,
      map: REL (llt$object_library) ^llt$section_map_items,
    recend;

  TYPE
    llt$section_map_items = array [1 .. *] of llt$section_map_item;

  TYPE
    llt$section_map_item = record
      original_section_ordinal: llt$section_ordinal,
      offset: llt$section_offset,
      length: llt$section_length,
      name: pmt$program_name,
      component: 1 .. llc$max_components,
    recend;


*copyc OSD$VIRTUAL_ADDRESS
*copyc LLT$OBJECT_TEXT_DESCRIPTOR
*copyc llt$object_library
*copyc PMT$PROGRAM_NAME
*copyc OST$TIME
*copyc OST$DATE
*copyc LLT$MODULE_GENERATOR
*copyc LLT$BINDING_TEMPLATE
*copyc llt$relocation
*DECK DECK=LLT$INTERNAL_ADDRESS_KIND EXPAND=FALSE

  TYPE
    llt$internal_address_kind = llc$address .. llc$external_proc;

*copyc LLT$ADDRESS_KIND
*DECK DECK=LLT$LIBRARIES EXPAND=FALSE


{  Library record. }

  TYPE
    llt$libraries = array [1 .. * ] of amt$local_file_name;

*copyc AMT$LOCAL_FILE_NAME
*DECK DECK=LLT$LIBRARY_DICTIONARY_POINTERS EXPAND=FALSE

  TYPE
    llt$library_dictionary_pointers = record
      library_version: string (4),
      module_dictionary: ^llt$module_dictionary,
      entry_point_dictionary: ^llt$entry_point_dictionary,
      command_dictionary: ^llt$command_dictionary,
      function_dictionary: ^llt$function_dictionary,
      help_module_dictionary: ^llt$help_module_dictionary,
      message_module_dictionary: ^llt$message_module_dictionary,
      panel_dictionary: ^llt$panel_dictionary,
    recend;

*copyc llt$command_dictionary
*copyc llt$entry_point_dictionary
*copyc llt$function_dictionary
*copyc llt$help_module_dictionary
*copyc llt$message_module_dictionary
*copyc llt$module_dictionary
*copyc llt$panel_dictionary
*DECK DECK=LLT$LIBRARY_MEMBER_HEADER EXPAND=FALSE
 TYPE
    llt$library_member_header = record
      module_index: llt$module_index,
      name: pmt$program_name,
      kind: llt$library_member_kind,
      time_created: ost$time,
      date_created: ost$date,
      generator_id: llt$module_generator,
      generator_name_vers: string (40),
      commentary: string (40),
      member: REL (llt$object_library) ^SEQ ( * ),
      member_size: llt$section_length, { size of member in cells }
      number_of_aliases: llt$number_of_aliases,
      aliases: REL (llt$object_library) ^pmt$module_list,
      command_function_availability: clt$named_entry_availability,
      command_function_kind: llt$command_kind,
      command_log_option: clt$command_log_option,
    recend,

    llt$application_member_header = record
      library_member_header: llt$library_member_header,
      application_identifier: llt$application_identifier,
    recend,

    llt$number_of_aliases = 0 .. llc$max_number_of_aliases,

    llt$library_member_kind = llc$program_description ..
      llc$max_library_module_kind,

    llt$library_member_kinds = set of llt$library_member_kind;

  CONST
    llc$max_number_of_aliases = 0ff(16);

*copyc clt$command_log_option
*copyc clt$named_entry_availability
*copyc llt$application_identifier
*copyc llt$command_kind
*copyc llt$library_module_kind
*copyc llt$module_dictionary
*copyc llt$module_generator
*copyc llt$section_address
*copyc ost$date
*copyc ost$time
*copyc pmt$program_description
*copyc pmt$program_name
*DECK DECK=LLT$LIBRARY_MODULE_KIND EXPAND=FALSE

  TYPE
    llt$library_module_kind = (llc$load_module, llc$ppu_object_module,
      llc$program_description, llc$command_procedure, llc$function_procedure,
      llc$message_module, llc$panel_module, llc$applic_command_procedure,
      llc$applic_program_description, llc$applic_command_description,
      llc$command_description, llc$function_description);

  CONST
    llc$help_module = llc$message_module;

{ If more module kinds are added, make sure to update the definition of the
{following constant. }

  CONST
    llc$max_library_module_kind = llc$function_description;

*DECK DECK=LLT$LINE_ADDRESS_TABLE EXPAND=FALSE
  TYPE
    llt$line_address_table = record
      original_module_name: pmt$program_name,
      version: llt$line_address_table_version,
      language: llt$module_generator,
      optimization_level: llt$optimization_level,
      number_of_items: llt$line_address_table_size,
      item: array [1 .. * ] of llt$line_address_item,
    recend,

    llt$line_address_item = record
      line_number: llt$source_line_number,
      section_ordinal: llt$section_ordinal,
      offset: llt$section_offset,
      extent: llt$section_length,
      nesting_level: llt$statement_nesting_level,
      line_attributes: llt$line_attributes,
      case llt$module_generator of
      = llc$basic =
        basic_statement_kind: llt$basic_statement_kind,
      = llc$cobol =
        cobol_statement_kind: llt$cobol_statement_kind,
      = llc$fortran =
        fortran_statement_kind: llt$fortran_statement_kind,
      = llc$cybil =
        cybil_statement_kind: llt$cybil_statement_kind,
      = llc$pascal =
        pascal_statement_kind: llt$pascal_statement_kind,
      = llc$the_c_language =
        c_statement_kind: llt$c_statement_kind,
      = llc$algol, llc$apl, llc$assembler, llc$object_library_generator,
            llc$pl_i, llc$unknown_generator, llc$ada, llc$real_memory_builder,
            llc$virtual_environment_linker, llc$malet =
        universal_statement_kind: llt$universal_statement_kind,
      casend,
    recend;

  CONST
    llc$max_statement_nesting_level = 255;

  TYPE
    llt$statement_nesting_level = 0 .. llc$max_statement_nesting_level,

    llt$line_attribute = (llc$line_number_unique, llc$breakpoint_permitted,
          llc$labelled_line, llc$prolog_code, llc$no_object_code_for_line,
          llc$line_attribute_spare6, llc$line_attribute_spare7,
          llc$line_attribute_spare8),

    llt$line_attributes = set of llt$line_attribute;

  TYPE
    llt$line_address_table_version = string (4);


  CONST
    llc$line_address_table_version = 'V1.0';

  TYPE
    llt$basic_statement_kind = (llc$basic_unknown_stmt_type, llc$basic_let,
          llc$basic_swap, llc$basic_call, llc$basic_callx, llc$basic_chain,
          llc$basic_end, llc$basic_error, llc$basic_exit_function,
          llc$basic_exit_sub, llc$basic_gosub, llc$basic_goto,
          llc$basic_on_error, llc$basic_on_gosub, llc$basic_on_goto,
          llc$basic_resume, llc$basic_return, llc$basic_run, llc$basic_stop,
          llc$basic_line_if, llc$basic_for, llc$basic_next, llc$basic_while,
          llc$basic_wend, llc$basic_if, llc$basic_elseif, llc$basic_else,
          llc$basic_endif, llc$basic_internal_function,
          llc$basic_internal_subroutine, llt$basic_external_function,
          llc$basic_external_subroutine, llt$basic_end_function,
          llc$basic_end_sub, llc$basic_close, llc$basic_field, llc$basic_get,
          llc$basic_input, llc$basic_line_input, llc$basic_lprint,
          llc$basic_lprint_using, llc$basic_lset, llc$basic_open,
          llc$basic_print, llc$basic_print_using, llc$basic_put,
          llc$basic_rset, llc$basic_width, llc$basic_write, llc$basic_beep,
          llc$basic_data, llc$basic_read, llc$basic_restore, llc$basic_clear,
          llc$basic_dim, llc$basic_erase, llc$basic_randomize);

  TYPE
    llt$cybil_statement_kind = (llc$cybil_unknown_stmt_kind,
          llc$cybil_procedure, llc$cybil_assignment, llc$cybil_begin,
          llc$cybil_end, llc$cybil_while, llc$cybil_whilend, llc$cybil_repeat,
          llc$cybil_until, llc$cybil_for, llc$cybil_forend,
          llc$cybil_procedure_call, llc$cybil_if, llc$cybil_elseif,
          llc$cybil_else, llc$cybil_ifend, llc$cybil_case,
          llc$cybil_case_selector, llc$cybil_casend, llc$cybil_cycle,
          llc$cybil_exit, llc$cybil_return, llc$cybil_push, llc$cybil_next,
          llc$cybil_reset, llc$cybil_allocate, llc$cybil_free,
          llc$cybil_procend, llc$cybil_pocket_code);

  TYPE
    llt$cobol_statement_kind = (llc$cobol_unknown_stmt_kind, llc$cobol_program,
          llc$cobol_section, llc$cobol_paragraph, llc$cobol_accept,
          llc$cobol_add, llc$cobol_alter, llc$cobol_call, llc$cobol_cancel,
          llc$cobol_close, llc$cobol_compute, llc$cobol_continue,
          llc$cobol_delete, llc$cobol_display, llc$cobol_divide,
          llc$cobol_else, llc$cobol_end_if, llc$cobol_end_perform,
          llc$cobol_enter, llc$cobol_exit, llc$cobol_generate, llc$cobol_goto,
          llc$cobol_if, llc$cobol_initialize, llc$cobol_initiate,
          llc$cobol_inspect, llc$cobol_merge, llc$cobol_move,
          llc$cobol_multiply, llc$cobol_open, llc$cobol_perform,
          llc$cobol_purge, llc$cobol_read, llc$cobol_receive,
          llc$cobol_release, llc$cobol_return, llc$cobol_rewrite,
          llc$cobol_search, llc$cobol_send, llc$cobol_set, llc$cobol_sort,
          llc$cobol_start, llc$cobol_stop, llc$cobol_string,
          llc$cobol_subtract, llc$cobol_suppress, llc$cobol_terminate,
          llc$cobol_unstring, llc$cobol_write);

  TYPE
    llt$fortran_statement_kind = (llc$fortran_unknown_stmt_kind,
          llc$fortran_program, llc$fortran_subroutine, llc$fortran_function,
          llc$fortran_arithmetic_if, llc$fortran_assign,
          llc$fortran_assigned_goto, llc$fortran_assignment,
          llc$fortran_backspace, llc$fortran_block_if, llc$fortran_buffer_in,
          llc$fortran_buffer_out, llc$fortran_call, llc$fortran_close,
          llc$fortran_computed_goto, llc$fortran_continue, llc$fortran_decode,
          llc$fortran_do, llc$fortran_else, llc$fortran_elseif,
          llc$fortran_encode, llc$fortran_end, llc$fortran_endfile,
          llc$fortran_endif, llc$fortran_entry, llc$fortran_inquire,
          llc$fortran_logical_if, llc$fortran_open, llc$fortran_pause,
          llc$fortran_print, llc$fortran_punch, llc$fortran_read,
          llc$fortran_return, llc$fortran_rewind, llc$fortran_stop,
          llc$fortran_write, llc$fortran_unconditional_goto,
          llc$fortran_elsewhere, llc$fortran_endwhere, llc$fortran_allocate,
          llc$fortran_free, llc$fortran_logical_where, llc$fortran_block_where,
          llc$fortran_forall);

  TYPE
    llt$pascal_statement_kind = (llc$pascal_unknown_stmt_kind,
          llc$pascal_assignment, llc$pascal_begin, llc$pascal_call,
          llc$pascal_case, llc$pascal_case_selector, llc$pascal_else,
          llc$pascal_end, llc$pascal_for, llc$pascal_goto, llc$pascal_if,
          llc$pascal_procedure, llc$pascal_repeat, llc$pascal_until,
          llc$pascal_while, llc$pascal_with);

  TYPE
    llt$c_statement_kind = (llc$c_unknown_statement_kind, llc$c_function,
          llc$c_assignment, llc$c_begin, llc$c_end, llc$c_while, llc$c_whilend,
          llc$c_do, llc$c_until, llc$c_for, llc$c_forend, llc$c_function_call,
          llc$c_if, llc$c_elseif, llc$c_else, llc$c_ifend, llc$c_switch,
          llc$c_switch_selector, llc$c_switchend, llc$c_continue, llc$c_break,
          llc$c_return, llc$c_push, llc$c_next, llc$c_reset, llc$c_allocate,
          llc$c_free, llc$c_function_end, llc$c_goto, llc$c_null);

  TYPE
    llt$universal_statement_kind = (llc$universal_unknown_stmt_kind,
          llc$universal_procedure);

*copyc pmt$program_name
*copyc llt$object_text_descriptor
*copyc llt$line_address_table_size
*copyc llt$module_generator
*copyc llt$section_address
*copyc llt$source_line_number
*copyc llt$optimization_level
*DECK DECK=LLT$LINE_ADDRESS_TABLE_SIZE EXPAND=FALSE

  TYPE
    llt$line_address_table_size = 0 .. llc$max_line_adr_table_size;

  CONST
    llc$max_line_adr_table_size = 0ffffff(16);
*DECK DECK=LLT$LOAD_MODULE EXPAND=FALSE
*copyc LLT$OBJECT_LIBRARY_HEADER
*copyc llt$obsolete_line_table
*copyc CYD$DEBUG_SYMBOLS
*copyc LLT$MODULE_DICTIONARY
*copyc LLT$ENTRY_POINT_DICTIONARY
*copyc LLT$LIBRARY_MEMBER_HEADER
*copyc LLT$LOAD_MODULE_HEADER
*copyc llt$object_module
*copyc llt$information_element
*copyc LLT$PROGRAM_DESCRIPTION
*copyc llt$command_description
*copyc llt$function_description
*copyc llt$object_library
*copyc LLT$LINE_ADDRESS_TABLE
*copyc llt$debug_symbol_table
*copyc PMT$PROGRAM_DESCRIPTION
*copyc OST$DATE
*copyc OST$TIME
*copyc PMT$PROGRAM_NAME
*copyc AMT$LOCAL_FILE_NAME
*copyc PMD$PPU_CHARACTERISTICS
*copyc CLT$FILE
*copyc CLT$FILE_REFERENCE
*copyc CLT$SCL_PROCEDURE
*DECK DECK=LLT$LOAD_MODULE_HEADER EXPAND=FALSE


  TYPE
    llt$load_module_header = record
      module_index: llt$module_index,
      elements_defined: llt$load_module_elements,
      interpretive_element: REL (llt$object_library)
        ^llt$object_text_descriptor,
      information_element: REL (llt$object_library) ^cell,
        { ^llt$info_element_hdr or ^llt$info_element_header }
      interpretive_header: record
        elements_defined: llt$interpretive_elements,
        library_list: REL (llt$object_library) ^llt$object_text_descriptor,
        section_definitions: REL (llt$object_library)
          ^llt$object_text_descriptor,
        entry_points: REL (llt$object_library) ^llt$object_text_descriptor,
        external_linkages: REL (llt$object_library)
          ^llt$object_text_descriptor,
        transfer_symbol: REL (llt$object_library) ^llt$object_text_descriptor,
      recend,
    recend,

    llt$load_module_elements = set of (llc$interpretive_element,
      llc$information_element),

    llt$interpretive_elements = set of (llc$library_element,
      llc$section_element, llc$entry_point_element, llc$external_element,
      llc$transfer_symbol_element);

*copyc LLT$MODULE_DICTIONARY
*copyc llt$information_element
*copyc llt$object_library
*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=LLT$MESSAGE_MODULE_DICTIONARY EXPAND=FALSE
 { The message module dictionary is in the same order as the modules are on the
{library. }

  TYPE
    llt$message_module_dictionary = array [1 .. * ] of
      llt$message_module_dict_item,

    llt$message_module_dict_item = record
      name: pmt$program_name,
      language: ost$natural_language,
      lowest_condition_code: ost$status_condition_code,
      highest_condition_code: ost$status_condition_code,
      message_header: REL (llt$object_library) ^llt$library_member_header,
    recend,

    llt$message_module_index = 0 .. llc$max_message_modules_in_lib;

  CONST
    llc$max_message_modules_in_lib = 0ffffff(16);

*copyc llt$library_member_header
*copyc ost$natural_language
*copyc ost$status
*copyc ost$status_condition_code
*copyc pmt$program_name
*DECK DECK=LLT$MODULE_ATTRIBUTES EXPAND=FALSE

  TYPE
    llt$module_attributes = set of (llc$ma_unused_5, llc$ma_unused_4,
          llc$ma_unused_3, llc$ma_unused_2, llc$ma_unused_1,
          llc$object_cybil_checking, llc$nonbindable,
          llc$nonexecutable);
*DECK DECK=LLT$MODULE_DICTIONARY EXPAND=FALSE


{ The module dictionary is in the same order as the modules are on the library.

  TYPE
    llt$module_dictionary = array [1 .. * ] of llt$module_dictionary_item,

    llt$module_dictionary_item = record
      name: pmt$program_name,
      case kind: llt$library_module_kind of
      = llc$load_module =
        module_header: REL (llt$object_library) ^llt$load_module_header,
      = llc$ppu_object_module =
        ppu_header: REL (llt$object_library) ^llt$object_text_descriptor,
      = llc$program_description =
        program_header: REL (llt$object_library) ^llt$library_member_header,
      = llc$command_procedure =
        command_header: REL (llt$object_library) ^llt$library_member_header,
      = llc$command_description =
        command_description_header: REL (llt$object_library)
              ^llt$library_member_header,
      = llc$function_procedure =
        function_header: REL (llt$object_library) ^llt$library_member_header,
      = llc$function_description =
        function_description_header: REL (llt$object_library)
              ^llt$library_member_header,
      = llc$message_module {and llc$help_module} =
        message_header: REL (llt$object_library) ^llt$library_member_header,
      = llc$panel_module =
        panel_header: REL (llt$object_library) ^llt$library_member_header,
      = llc$applic_command_procedure =
        applic_command_header: REL (llt$object_library)
              ^llt$application_member_header,
      = llc$applic_program_description =
        applic_program_header: REL (llt$object_library)
              ^llt$application_member_header,
      = llc$applic_command_description =
        applic_command_description_hdr: REL (llt$object_library)
              ^llt$application_member_header,
      casend,
    recend,

    llt$module_index = 0 .. llc$max_modules_in_library;

  CONST
    llc$max_modules_in_library = 0ffff(16);

*copyc llt$library_member_header
*copyc llt$library_module_kind
*copyc llt$load_module_header
*copyc llt$object_text_descriptor
*copyc pmt$program_name
*DECK DECK=LLT$MODULE_GENERATOR EXPAND=FALSE

  TYPE
    llt$module_generator = (llc$algol, llc$apl, llc$basic, llc$cobol,
      llc$assembler, llc$fortran, llc$object_library_generator, llc$pascal,
      llc$obsolete_cybil, llc$pl_i, llc$unknown_generator, llc$the_c_language,
      llc$ada, llc$real_memory_builder, llc$virtual_environment_linker,
      llc$malet, llc$screen_formatter, llc$lisp, llc$cybil);
*DECK DECK=LLT$MODULE_KIND EXPAND=FALSE

  TYPE
    llt$module_kind = (llc$mi_virtual_state, llc$vector_virtual_state, llc$iou,
          llc$motorola_68000, llc$p_code, llc$motorola_68000_absolute,
          llc$form, llc$vector_extended_state);

*DECK DECK=LLT$OBJECT_LIBRARY EXPAND=FALSE


  TYPE
    llt$object_library = SEQ ( * );

*DECK DECK=LLT$OBJECT_LIBRARY_HEADER EXPAND=FALSE
 { This record is located at the starting byte of the object library. }
{ It is immediately followed by an array of dictionary pointers }
{ (llt$object_library_dictionaries) with header.number_of_dictionaries }
{ elements. }

  TYPE
    llt$object_library_header = record
      version: string (4),
      number_of_dictionaries: 0 .. llc$max_dictionaries_on_library,
    recend,

    llt$object_library_dictionaries = array [1 .. * ] of
      llt$object_library_dictionary,

    llt$object_library_dictionary = record
      case kind: llt$library_dictionary_kind of
      = llc$module_dictionary =
        module_dictionary: REL (llt$object_library) ^llt$module_dictionary,
      = llc$entry_point_dictionary =
        entry_point_dictionary: REL (llt$object_library)
          ^llt$entry_point_dictionary,
      = llc$command_dictionary =
        command_dictionary: REL (llt$object_library) ^llt$command_dictionary,
      = llc$function_dictionary =
        function_dictionary: REL (llt$object_library) ^llt$function_dictionary,
      = llc$help_module_dictionary =
        help_module_dictionary: REL (llt$object_library)
          ^llt$help_module_dictionary,
      = llc$message_module_dictionary =
        message_module_dictionary: REL (llt$object_library)
          ^llt$message_module_dictionary,
      = llc$panel_dictionary =
        panel_dictionary: REL (llt$object_library) ^llt$panel_dictionary,
      casend,
    recend,

    llt$library_dictionary_kind = (llc$module_dictionary,
      llc$entry_point_dictionary, llc$command_dictionary,
      llc$function_dictionary, llc$help_module_dictionary,
      llc$message_module_dictionary, llc$panel_dictionary);

  CONST
    llc$max_dictionaries_on_library = 0ff(16);

  TYPE
    llt$object_library_header_v1_0 = record
      version: string (4),
      module_dictionary: REL (llt$object_library) ^llt$module_dictionary,
      number_of_modules: llt$module_index,
      entry_point_dictionary: REL (llt$object_library)
        ^llt$entry_point_dictionary,
      number_of_entry_points: llt$entry_point_index,
    recend;

  CONST
    llc$object_library_version = 'V1.1';

*copyc llt$command_dictionary
*copyc llt$entry_point_dictionary
*copyc llt$function_dictionary
*copyc llt$help_module_dictionary
*copyc llt$message_module_dictionary
*copyc llt$module_dictionary
*copyc llt$panel_dictionary
*DECK DECK=LLT$OBJECT_MODULE EXPAND=FALSE
*copyc ost$date
*copyc ost$time
*copyc pmt$program_name
*copyc amt$local_file_name
*copyc pmd$ppu_characteristics
*copyc llh$object_module_description
*copyc llt$object_text_descriptor
*copyc llt$object_record_kind
*copyc llt$identification
*copyc llt$module_kind
*copyc llt$module_generator
*copyc llt$module_attributes
*copyc llt$libraries
*copyc llt$section_definition
*copyc llt$segment_definition
*copyc llt$obsolete_segment_definition
*copyc llt$section_address
*copyc llt$section_kind
*copyc llt$section_access_attributes
*copyc llt$text
*copyc llt$replication
*copyc llt$bit_string_insertion
*copyc llt$address_formulation
*copyc llt$address_kind
*copyc llt$internal_address_kind
*copyc llt$external_linkage
*copyc llt$entry_definition
*copyc llt$entry_point_attributes
*copyc llt$deferred_common_blocks
*copyc llt$deferred_entry_points
*copyc llt$relocation
*copyc llt$relocation_container
*copyc llt$address_type
*copyc llt$obsolete_formal_parameters
*copyc llt$formal_parameters
*copyc llt$actual_parameters
*copyc llt$source_line_number
*copyc llt$fortran_argument_desc
*copyc llt$fortran_argument_type
*copyc llt$fortran_string_length
*copyc llt$fortran_argument_kind
*copyc llt$fortran_array_size
*copyc llt$argument_usage
*copyc llt$binding_template
*copyc llt$binding_template_kind
*copyc llt$symbol_table
*copyc llt$temporary_symbol_table
*copyc llt$supplemental_debug_tables
*copyc llt$transfer_symbol
*copyc llt$ppu_absolute
*copyc llt$68000_absolute
*copyc llt$68000_address
*DECK DECK=LLT$OBJECT_RECORD_KIND EXPAND=FALSE

  TYPE
    llt$object_record_kind = (llc$identification, llc$libraries,
          llc$section_definition, llc$text, llc$replication,
          llc$bit_string_insertion, llc$entry_definition, llc$relocation,
          llc$address_formulation, llc$external_linkage,
          llc$obsolete_formal_parameters, llc$actual_parameters,
          llc$binding_template, llc$ppu_absolute, llc$obsolete_line_table,
          llc$cybil_symbol_table_fragment, llc$allotted_section_definition,
          llc$symbol_table, llc$transfer_symbol, llc$ses_reserved_1,
          llc$ses_reserved_2, llc$ses_reserved_3, llc$68000_absolute,
          llc$line_table, llc$line_table_fragment, llc$symbol_table_fragment,
          llc$obsolete_segment_definition, llc$obsolete_allotted_seg_def,
          llc$formal_parameters, llc$unallocated_common_block,
          llc$form_definition, llc$application_identifier,
          llc$segment_definition, llc$allotted_segment_definition,
          llc$supplemental_debug_tables, llc$deferred_entry_points,
          llc$deferred_common_blocks);

*DECK DECK=LLT$OBJECT_TEXT_DESCRIPTOR EXPAND=FALSE

{ Constants that pertain to both the object and load module.

  CONST
    llc$max_adr_items = 0ffff(16),
    llc$max_deferred_common_blocks = 0ffff(16),
    llc$max_deferred_entry_points = 0ffff(16),
    llc$max_ext_items = 0ffff(16),
    llc$max_libraries = 0ffff(16),
    llc$max_rel_items = 0ffff(16);

  TYPE
    llt$object_text_descriptor = record
      case kind: llt$object_record_kind of
      = llc$identification, llc$section_definition, llc$bit_string_insertion,
            llc$entry_definition, llc$binding_template, llc$transfer_symbol,
            llc$obsolete_segment_definition, llc$unallocated_common_block,
            llc$application_identifier, llc$segment_definition =
        unused: llt$section_length, {must be zero}
      = llc$libraries =
        number_of_libraries: 1 .. llc$max_libraries,
      = llc$text, llc$replication =
        number_of_bytes: 1 .. llc$max_section_length,
      = llc$relocation =
        number_of_rel_items: 1 .. llc$max_rel_items,
      = llc$address_formulation =
        number_of_adr_items: 1 .. llc$max_adr_items,
      = llc$external_linkage =
        number_of_ext_items: 1 .. llc$max_ext_items,
      = llc$obsolete_formal_parameters, llc$actual_parameters,
            llc$cybil_symbol_table_fragment, llc$symbol_table,
            llc$line_table_fragment, llc$symbol_table_fragment,
            llc$formal_parameters, llc$form_definition,
            llc$supplemental_debug_tables =
        sequence_length: llt$section_length, {REP sequence_length OF CELL}
      = llc$ppu_absolute =
        number_of_words: llt$ppu_address,
      = llc$allotted_section_definition =
        allotted_section: ost$relative_pointer, { REL ^seq(*) }
      = llc$allotted_segment_definition, llc$obsolete_allotted_seg_def =
        allotted_segment_length: ost$segment_length, { Shadow size }
        allotted_segment: ost$segment_length, { REL ^seq(*) }
      = llc$deferred_entry_points =
        number_of_entry_points: 1 .. llc$max_deferred_entry_points,
      = llc$deferred_common_blocks =
        number_of_common_blocks: 1 .. llc$max_deferred_common_blocks,
      = llc$68000_absolute =
        number_of_68000_bytes: 1 .. llc$maximum_68000_address,
      = llc$line_table, llc$obsolete_line_table =
        number_of_line_items: 1 .. llc$max_line_adr_table_size,
      casend,
    recend;

*copyc llt$68000_address
*copyc llt$line_address_table_size
*copyc llt$object_record_kind
*copyc llt$section_address
*copyc osd$virtual_address
*copyc pmd$ppu_characteristics
*DECK DECK=LLT$OBSOLETE_FORMAL_PARAMETERS EXPAND=FALSE


  TYPE
    llt$obsolete_formal_parameters = record
      procedure_name: pmt$program_name,
      specification: SEQ ( * ),
    recend;

*copyc pmt$program_name
*DECK DECK=LLT$OBSOLETE_LINE_TABLE EXPAND=FALSE

  TYPE
    llt$obsolete_line_address_table = record
      original_name: pmt$program_name,
      optimized_code: boolean,
      language: llt$module_generator,
      number_of_items: llt$line_address_table_size,
      item: array [1 .. * ] of llt$obsolete_line_address_item,
    recend,

    llt$obsolete_line_address_item = record
      line_number: llt$obsolete_source_line_number,
      section_ordinal: llt$section_ordinal,
      offset: llt$section_offset,
      extent: llt$section_offset,
      statement_labeled: boolean,
      breakpoint_permitted: boolean,
      case llt$module_generator of
      = llc$cybil =
        cybil_line_kind: llt$cybil_line_kind,
        { Only support CYBIL currently. }
      casend,
    recend,

    llt$cybil_line_kind = (cyc$cybil_procedure, cyc$cybil_assignment,
      cyc$cybil_begin, cyc$cybil_end, cyc$cybil_while, cyc$cybil_whilend,
      cyc$cybil_repeat, cyc$cybil_until, cyc$cybil_for, cyc$cybil_forend,
      cyc$cybil_procedure_call, cyc$cybil_if, cyc$cybil_elseif, cyc$cybil_else,
      cyc$cybil_ifend, cyc$cybil_case, cyc$cybil_case_selector,
      cyc$cybil_casend, cyc$cybil_cycle, cyc$cybil_exit, cyc$cybil_return,
      cyc$cybil_push, cyc$cybil_next, cyc$cybil_reset, cyc$cybil_allocate,
      cyc$cybil_free),

    llt$obsolete_source_line_number = string (llc$obsolete_source_line_length);

  CONST
    llc$obsolete_source_line_length = 6;

*copyc PMT$PROGRAM_NAME
*copyc LLT$MODULE_GENERATOR
*copyc llt$section_address
*copyc LLT$OBJECT_TEXT_DESCRIPTOR
*copyc LLT$OBJECT_RECORD_KIND
*copyc LLT$LINE_ADDRESS_TABLE_SIZE
*copyc PMD$PPU_CHARACTERISTICS
*copyc OSD$VIRTUAL_ADDRESS
*copyc LLT$SOURCE_LINE_NUMBER
*DECK DECK=LLT$OBSOLETE_SEGMENT_DEFINITION EXPAND=FALSE

  TYPE
    llt$obsolete_segment_definition = record
      segment_number: ost$segment,
      r1: ost$valid_ring,
      r2: ost$valid_ring,
      section_definition: llt$section_definition,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc llt$section_definition
?? POP ??
*DECK DECK=LLT$OPTIMIZATION_LEVEL EXPAND=FALSE

  TYPE
    llt$optimization_level = (llc$debug_optimization_level,
      llc$low_optimization_level, llc$high_optimization_level);
*DECK DECK=LLT$PANEL_DICTIONARY EXPAND=FALSE


{ The panel dictionary is in alphbetical order. }

  TYPE
    llt$panel_dictionary = array [1 .. * ] of llt$panel_dictionary_item,

    llt$panel_dictionary_item = record
      name: pmt$program_name,
      panel_header: REL (llt$object_library) ^llt$library_member_header,
    recend,

    llt$panel_index = 0 .. llc$max_panels_in_library;

  CONST
    llc$max_panels_in_library = 0ffffff(16);

*copyc llt$library_member_header
*copyc pmt$program_name
*DECK DECK=LLT$PPU_ABSOLUTE EXPAND=FALSE


{ PPU absolute record. }

  TYPE
    llt$ppu_absolute = record
      executes_on_any_ppu: boolean,
      ppu_number: 0 .. llc$max_ppu_number,
      load_address: llt$ppu_address,
      entry_address: llt$ppu_address,
      text: array [0 .. * ] of 0 .. 0ffff(16),
    recend;
*copyc PMD$PPU_CHARACTERISTICS
*DECK DECK=LLT$PROGRAM_DESCRIPTION EXPAND=FALSE

  TYPE
    {  An object library program description is a sequence of }
    {  one to five variables: }
    {    1)program_attributes: llt$program_attributes - required; specifys }
    {      presence or absence, and size of remaining four variables, }
    {    2)object_file_list: llt$object_file_list, }
    {    3)module_list: pmt$module_list, }
    {    4)object_library_list: llt$object_library_list, }
    {    5)enable_inhibit_conditions: pmt$enable_inhibit_conditions. }

    llt$program_description = SEQ ( * ),

    llt$program_attributes = record
      contents: pmt$prog_description_contents,
      starting_procedure: pmt$program_name,
      number_of_object_files: pmt$number_of_object_files,
      number_of_modules: pmt$number_of_modules,
      number_of_libraries: pmt$number_of_libraries,
      load_map_file: clt$path_name,
      load_map_options: pmt$load_map_options,
      termination_error_level: pmt$termination_error_level,
      preset: pmt$initialization_value,
      maximum_stack_size: ost$segment_length,
      debug_input: clt$path_name,
      debug_output: clt$path_name,
      abort_file: clt$path_name,
      debug_mode: pmt$debug_mode,
    recend,

    llt$object_file_list = array [1 .. * ] of clt$path_name,

    llt$object_library_list = array [1 .. * ] of clt$path_name;

*copyc PMT$PROGRAM_DESCRIPTION
*copyc CLT$PATH_NAME
*DECK DECK=LLT$RELOCATION EXPAND=FALSE


{ Relocation record. }

  TYPE
    llt$relocation = array [1 .. * ] of llt$relocation_item,

    llt$relocation_item = record
      section_ordinal: llt$section_ordinal,
      offset: llt$section_offset,
      relocating_section: llt$section_ordinal,
      container: llt$relocation_container,
      address: llt$address_type,
    recend;

*copyc llt$section_address
*copyc LLT$RELOCATION_CONTAINER
*copyc LLT$ADDRESS_TYPE
*DECK DECK=LLT$RELOCATION_CONTAINER EXPAND=FALSE

  TYPE
    llt$relocation_container = (llc$two_bytes, llc$three_bytes, llc$four_bytes,
      llc$eight_bytes, llc$180_d_field, llc$180_q_field, llc$180_long_d_field);
*DECK DECK=LLT$REPLICATION EXPAND=FALSE


{ Replication record. }

  TYPE
    llt$replication = record
      section_ordinal: llt$section_ordinal,
      offset: llt$section_offset,
      increment: 1 .. llc$max_section_length,
      count: 1 .. llc$max_section_length,
      byte: array [1 .. * ] of 0 .. 255,
    recend;

*copyc llt$section_address
*DECK DECK=LLT$SECTION_ACCESS_ATTRIBUTES EXPAND=FALSE

  TYPE
    llt$section_access_attributes = set of llt$section_access_attribute,

    llt$section_access_attribute = (llc$read, llc$write, llc$execute,
      llc$binding);
*DECK DECK=LLT$SECTION_ADDRESS EXPAND=FALSE

  TYPE
    llt$section_ordinal = 0 .. llc$max_section_ordinal,
    llt$section_offset = 0 .. llc$max_section_offset,
    llt$section_length = 0 .. llc$max_section_length,
    llt$section_length_in_bits = 0 .. (llc$max_section_length *
      llc$bits_per_byte),
    llt$section_address_range = - (llc$max_section_offset + 1) ..
      llc$max_section_offset;

  CONST
    llc$max_section_ordinal = 0ffff(16),
    llc$max_section_offset = 7fffffff(16),
*IF $true(osv$unix)
    llc$max_section_length = 0fffffff(16),
*ELSE
    llc$max_section_length = llc$max_section_offset + 1,
*IFEND
    llc$bits_per_byte = 8;
*DECK DECK=LLT$SECTION_DEFINITION EXPAND=FALSE


{ Section definition record. }

  TYPE
    llt$section_definition = record
      kind: llt$section_kind,
      access_attributes: llt$section_access_attributes,
      section_ordinal: llt$section_ordinal,
      length: llt$section_length,
      allocation_alignment: llt$section_address_range,
      allocation_offset: llt$section_address_range,
      name: pmt$program_name,
    recend;

*copyc llt$section_address
*copyc LLT$SECTION_ACCESS_ATTRIBUTES
*copyc LLT$SECTION_KIND
*copyc PMT$PROGRAM_NAME
*DECK DECK=LLT$SECTION_KIND EXPAND=FALSE

  TYPE
    llt$section_kind = (llc$code_section, llc$binding_section,
      llc$working_storage_section, llc$common_block,
      llc$extensible_working_storage, llc$extensible_common_block,
      llc$lts_reserved);
*DECK DECK=LLT$SEGMENT_DEFINITION EXPAND=FALSE

  TYPE
    llt$segment_definition = record
      segment_number: ost$segment,
      r1: ost$valid_ring,
      r2: ost$valid_ring,
      section_definition: llt$section_definition,

      binding_section_ordinal: llt$section_ordinal,
      binding_section_offset: llt$section_address_range,
      future_use: integer,  { 8 bytes of zeros }
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc llt$section_definition
*copyc llt$section_address
?? POP ??
*DECK DECK=LLT$SOURCE_LINE_NUMBER EXPAND=FALSE

  TYPE
    llt$source_line_number = 0 .. 999999;
*DECK DECK=LLT$SUPPLEMENTAL_DEBUG_TABLES EXPAND=FALSE
  TYPE
    llt$supplemental_debug_tables = record
      sd_table: SEQ ( * ),
    recend;
*DECK DECK=LLT$SYMBOL_TABLE EXPAND=FALSE

{ Symbol table record }

  TYPE
    llt$symbol_table = record
      language: llt$module_generator,
      text: SEQ ( * ),
    recend;

*copyc LLT$MODULE_GENERATOR
*DECK DECK=LLT$TEMPORARY_SYMBOL_TABLE EXPAND=FALSE


{ Debug table record used for emitting line tables and symbol tables }
{ in fragments rather than all together.  Not used by II compilers and }
{ simply passed over by any object text processors operating on NOS/VE. }
{ Intended for use by compilers producing this loader text on machines }
{ other than 180.  For example CYBIL C/M. }

  TYPE
    llt$debug_table_fragment = record
      offset: llt$section_offset,
      text: SEQ ( * ),
    recend;

*copyc llt$section_address
*DECK DECK=LLT$TEXT EXPAND=FALSE


{ Text record. }

  TYPE
    llt$text = record
      section_ordinal: llt$section_ordinal,
      offset: llt$section_offset,
      byte: array [1 .. * ] of 0 .. 255,
    recend;

*copyc llt$section_address
*DECK DECK=LLT$TRANSFER_SYMBOL EXPAND=FALSE


{ Transfer record. }

  TYPE
    llt$transfer_symbol = record
      name: pmt$program_name,
    recend;

*copyc PMT$PROGRAM_NAME
*DECK DECK=LOC$DEFERRED_ENTRY_PT_LIBRARY EXPAND=FALSE

  CONST
    loc$deferred_entry_pt_library = 'OSF$DEFERRED_ENTRY_PT_LIB_',
    loc$deferred_entry_pt_lib_size = 26;

*DECK DECK=LOC$TASK_SERVICES_LIBRARY_NAME EXPAND=FALSE

  CONST
    loc$task_services_library_name = 'OSF$TASK_SERVICES_LIBRARY';

*DECK DECK=LOE$ABORT_LOAD EXPAND=FALSE

  {Constant declarations for premature loader termination conditions.
  CONST
    loe$abort_load = 'LOE$ABORT_LOAD                 ',
    loe$insufficient_memory = 'LOE$INSUFFICIENT_MEMORY        ',
    loe$loader_malfunction = 'LOE$LOADER_MALFUNCTION         ';

*DECK DECK=LOE$MAP_MALFUNCTION EXPAND=FALSE

  CONST
    loe$map_malfunction = 'LOE$MAP_MALFUNCTION            ';

*DECK DECK=LOH$CLOSE_APD_PROCESSING_FILES EXPAND=FALSE
{
{    The purpose of this request is to close the files used to record
{ processing information about an instrumented APD task.
{
{    LOP$CLOSE_APD_PROCESSING_FILES;
{
*DECK DECK=LOH$DELETE_LINKAGE_TREE EXPAND=FALSE
{ PURPOSE:
{    The purpose of this request is to re-initialize the Loader's
{    linkage tree so that no entry points that have been loaded
{    previous to calling this procedure will be available subsequent
{    to the call.
{ DESIGN:
{    The pointers in the linkage tree are set to NIL.
*DECK DECK=LOH$FIND_COMMAND_IN_PROGRAM EXPAND=FALSE
{
{    The purpose of this request is to search the program library list for a
{ command name and return the command dictionary item and some additional
{ information about the library on which the command was found.
{
{       LOP$FIND_COMMAND_IN_PROGRAM (COMMAND_NAME, COMMAND_DICTIONARY_ITEM,
{             LIBRARY, LIBRARY_NAME, LIBRARY_RINGS, LIBRARY_PRIVILEGE, STATUS)
{
{ COMMAND_NAME: (input)  This parameter specifies the name of the command to be
{       found.
{
{ COMMAND_DICTIONARY_ITEM: (output)  This parameter specifies the command
{       dictionary item from the library for the command.
{
{ LIBRARY: (output)  This parameter specifies the sequence pointer for the
{       library file on which the command was found.
{
{ LIBRARY_NAME: (output)  This parameter specifies the name of the library file
{       on which the command was found.
{
{ LIBRARY_RINGS: (output)  This parameter specifies the ring brackets of the
{       library file on which the command was found.
{
{ LIBRARY_PRIVILEGE: (output)  This parameter specifies the privilege of the
{       library file on which the command was found.  Currently, this is always
{       'OBJECT'.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             lle$entry_point_not_found
{             lle$bad_library_member_header
{             lle$bad_program_header_ptr
{             lle$bad_scl_header_ptr
{             lle$bad_entry_dictionary_ptr
{             lle$library_header_missing
{             lle$wrong_library_version
{
*DECK DECK=LOH$FIND_ENTRY_POINT_RESIDENCE EXPAND=FALSE
{
{    The purpose of this procedure is to find the name of the module and the
{ name of the file from which the specified entry point was loaded into the
{ specified ring.
{
{       LOP$FIND_ENTRY_POINT_RESIDENCE (ENTRY_POINT, LOADED_RING, MODULE_NAME,
{             FILE_REFERENCE, STATUS)
{
{ ENTRY_POINT: (input)  This parameter specifies the entry point whose
{       residence is to be found.
{
{ LOADED_RING: (input,output)  This parameter specifies the ring in which the
{       entry point whose residence is to be found was loaded. If the entry
{       point was loaded in a more privileged ring and gated to the specified
{       ring, then this parameter returns the ring in which the entry point
{       was actually loaded.
{
{ MODULE_NAME: (output)  This parameter specifies the name of the module from
{       which the entry point was loaded.
{
{ FILE_REFERENCE: (output)  This parameter specifies the file from which the
{       entry point was loaded.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             lle$entry_point_not_found
*DECK DECK=LOH$FIND_FUNCTION_IN_PROGRAM EXPAND=FALSE
{
{    The purpose of this request is to search the program library list for a
{ function name and return the function dictionary item and some additional
{ information about the library on which the function was found.
{
{       LOP$FIND_FUNCTION_IN_PROGRAM (FUNCTION_NAME, FUNCTION_DICTIONARY_ITEM,
{             LIBRARY, LIBRARY_NAME, LIBRARY_RINGS, STATUS)
{
{ FUNCTION_NAME: (input)  This parameter specifies the name of the function to
{       be found.
{
{ FUNCTION_DICTIONARY_ITEM: (output)  This parameter specifies the function
{       dictionary item from the library for the function.
{
{ LIBRARY: (output)  This parameter specifies the sequence pointer for the
{       library file on which the function was found.
{
{ LIBRARY_NAME: (output)  This parameter specifies the name of the library file
{       on which the function was found.
{
{ LIBRARY_RINGS: (output)  This parameter specifies the ring brackets of the
{       library file on which the function was found.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             lle$entry_point_not_found
{             lle$bad_library_member_header
{             lle$bad_program_header_ptr
{             lle$bad_scl_header_ptr
{             lle$bad_entry_dictionary_ptr
{
*DECK DECK=LOH$INITIALIZE_LOAD_MAP EXPAND=FALSE

{   The purpose of this request is to initialize the load map.
{
{   NOTE: This request causes the condition 'LOE$MAP_MALFUNCTION' to
{         report system errors occuring during initialization (i.e., the
{         NOS/VE interfaces date, time, version, or generate message yield
{         abnormal status).
{         The condition_descriptor parameter of the called condition handler
{         points to the unexpected abnormal status.
{         The inability to access the map file is reported via STATUS.
{
{       LOP$INITIALIZE_LOAD_MAP (MAP_FILE, MAP_RING_ATTRIBUTES, STATUS)
{
{ MAP_FILE: (input) This parameter specifies the local file name of the map.
{
{ MAP_RING_ATTRIBUTES: (input) This parameter specifies the ring attributes
{       to be associated with the map file.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION: AM exceptions.

*DECK DECK=LOH$LOAD_ENTRY_POINT EXPAND=FALSE

{
{    The purpose of this request is to dynamically satisfy a reference
{  to an entry point from a specified protection environment.  The reference
{  will be satisfied by a previously_loaded entry point if possible;
{  otherwise the library list will be searched for an appropriate
{  module to load.
{
{        LOP$LOAD_ENTRY_POINT (NAME, REFERENCE_RING, REFERENCE_GLOBAL_KEY,
{          KIND, ADDRESS, STATUS)
{
{  NAME: (input) This parameter specifies the name of entry point being
{       referenced.
{
{  REFERENCE_RING: (input) This parameter specifies the ring of the
{       protection environment from which the entry point is being referenced.
{
{  REFERENCE_GLOBAL_KEY: (input) This parameter specifies the global_key
{       of the protection environment from which the entry point is being
{       referenced.
{
{  KIND: (input) This parameter specifies the kind of address to be
{        returned.
{
{  ADDRESS: (output) This parameter specifies the kind of address
{        being returned and the address assigned to 'NAME'.
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=LOH$LOAD_MAP_DATA EXPAND=FALSE

{   The purpose of this request is to append text to the load/link map.
{
{   NOTE: This request causes the condition 'LOE$MAP_MALFUNCTION' to
{         report an abnormal status returned by generate message in
{         attempting to suspend load map generation.  Suspension of
{         load map generation occurs if text cannot be appended to the
{         map.
{         The condition_descriptor parameter of the called condition handler
{         points to the unexpected abnormal status.
{
{       GENERATE_LOAD_MAP_TEXT (LOAD_MAP_DATA)
{
{ LOAD_MAP_DATA: (input) This parameter specifies the type of the text and
{       its value.
{
*DECK DECK=LOH$REINITIALIZE_MODULE EXPAND=FALSE
{}
{   The purpose of this request is to reinitialize the static data
{ of a single, previously loaded module.  All variables and addresses
{ that are local to the module will be reinitialized to the state they
{ were in when the module was loaded the first time.  No other modules
{ are affected.  This request is intended to be used by the COBOL Run
{ Time system in order to support the COBOL verbs CALL and CANCEL.
{}
{      LOP$REINITIALIZE_MODULE (MODULE_NAME, STATUS)
{}
{ MODULE_NAME: (input) This parameter specifies the name of the
{       module to be loaded. If more than one module with this
{       name has been loaded, the one that gets reinitialized
{       is undefined.
{}
{ STATUS: (output) This parameter specifies the request status.
{}
*DECK DECK=LOK$KEYPOINTS EXPAND=FALSE


  {Loader Keypoint Procedure Identifiers}

  CONST
    lok$load_program = lok$base + 0,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'LO_load_program' }
    {X 'LO_load_program' 'status ' I20 }
*ELSE
    {E 'lop$load_program' }
    {X 'lop$load_program' 'status ' I20 }
*IFEND

    lok$load_module_from_library = lok$base + 1,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'LO_load_module_from_library' }
    {X 'LO_load_module_from_library' 'status ' I20 }
*ELSE
    {E 'lop$load_module_from_library' }
    {X 'lop$load_module_from_library' 'status ' I20 }
*IFEND

    lok$load_entry_point = lok$base + 2,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'LO_load_entry_point' }
    {X 'LO_load_entry_point' 'status ' I20 }
*ELSE
    {E 'lop$load_entry_point' }
    {X 'lop$load_entry_point' 'status ' I20 }
*IFEND

    lok$add_program_load_libraries = lok$base + 3,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'LO_add_program_load_libraries' }
    {X 'LO_add_program_load_libraries' 'status ' I20 }
*ELSE
    {E 'lop$add_program_load_libraries' }
    {X 'lop$add_program_load_libraries' 'status ' I20 }
*IFEND

    lok$load_module_list = lok$base + 4,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'LO_load_module_list' }
    {X 'LO_load_module_list' 'status ' I20 }
*ELSE
    {E 'lop$load_module_list' }
    {X 'lop$load_module_list' 'status ' I20 }
*IFEND

    lok$satisfy_externals = lok$base + 5,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'LO_satisfy_external_references' }
    {X 'LO_satisfy_external_references' 'status ' I20 }
*ELSE
    {E 'lop$satisfy_externals' }
    {X 'lop$satisfy_externals' 'status ' I20 }
*IFEND

    lok$load_module = lok$base + 6,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'LO_load_module' }
    {X 'LO_load_module' 'status ' I20 }
*ELSE
    {E 'lop$load_module' }
    {X 'lop$load_module' 'status ' I20 }
*IFEND

    lok$open_library = lok$base + 7,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'LO_open_library' }
    {X 'LO_open_library' 'status ' I20 }
*ELSE
    {E 'lop$open_library' }
    {X 'lop$open_library' 'status ' I20 }
*IFEND

    lok$limit = lok$base + 49;

*copyc amk$base_keypoint_values
*DECK DECK=LOM$ACTUAL_FORMAL_PARM_MATCHING EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE : loader : actual/formal parm matching', EJECT ??
MODULE lom$actual_formal_parm_matching;

{  PURPOSE:
{    This module contains components necessary to match external references to the appropriate entry
{    point definitions.  This matching process consists of comparing protection environment (ring, key/lock)
{    attributes as well as symbolic names.
{  DESIGN:
{    The essential work of this module consists of managing two conceptual lists -- an entry definitions
{    list and an unsatisfied references list.  As 'entry_definition' object text records are received,
{    definitions are added to the entry definitions list and any matching entries in the unsatisfied
{    references list are satisfied.  As 'external_linkage' object text records are received, the
{    entry definitions list is searched for a matching definition.  If one is found, then the external
{    reference is satisfied immediately.  Otherwise an item is added to the unsatisfied references list.
{
{    Each of the two conceptual lists is implemented as a series of sublists.  For each linkage name
{    (entry_point name or external name),  a subordinate procedure maintains pointers to the heads
{    of the entry definitions and unsatisfied references sublists for that linkage name.  For any
{    given object text record, only the sublists of the specified linkage name are processed.
{
{    The actual satisfying of an external reference is not accomplished by this module.  Its purpose
{    is simply to isolate matching pairs of entry definitions and enternal references.  These pairs
{    are then passed on to another module for actual linkage generation.

{  NOTE:
{    Conditions raised: LOE$ABORT_LOAD, LOE$INSUFFICIENT_MEMORY.

?? PUSH (LISTEXT := ON) ??
*copyc cyd$cybil_structure_definitions
*copyc loe$abort_load
*copyc lot$loader_type_definitions
*copyc llt$formal_parameters
*copyc llt$obsolete_formal_parameters
*copyc llt$fortran_argument_desc
*copyc llt$fortran_argument_type
*copyc llt$fortran_argument_kind
*copyc llt$argument_usage
*copyc lot$loader_options
*copyc oss$job_paged_literal
*copyc pmc$default_user_stack_size
?? POP ??
*copyc lop$report_error
*copyc lop$create_unsat_ref_segment
*copyc lop$find_matching_entry_point
*copyc mmp$create_segment
*copyc osp$reset_heap
*copyc pmp$cause_condition
*copyc pmp$exit
*copyc lov$secondary_status
*copyc lov$unsatisfied_ref_container


  TYPE
    valid_languages = set of llt$module_generator;


  VAR
    lov$param_linkage_list: [XDCL] lot$param_matching_list := [NIL, NIL];



  PROCEDURE find_linkage_name_lists
    (    linkage_name: pmt$program_name;
     VAR linkage: ^lot$param_matching_node);

    VAR
      lov$secondary_status: [XREF] ost$status;

    VAR
      segment_pointer: mmt$segment_pointer,
      abort_status: ^ost$status;

{!  Temporary code until RESET works for heaps used by task services.

    VAR
      converter: record
        case dummy: 1 .. 2 of
        = 1 =
          heap_pointer: ^HEAP ( * ),
        = 2 =
          os_heap_ptr: cyt$adaptable_heap_pointer,
        casend,
      recend;

{!  End temporary code.

  /normal_sequence/
    BEGIN
      IF lov$param_linkage_list.container = NIL THEN
        mmp$create_segment (NIL, mmc$heap_pointer, loc$loader_ring, segment_pointer, lov$secondary_status);
        IF NOT lov$secondary_status.normal THEN
          lop$report_error (lle$unable_to_create_table, 'UNSATISFIED REFERENCES', '', 0);
          PUSH abort_status;
          pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
          pmp$exit (abort_status^);
        IFEND;
        lov$param_linkage_list.container := segment_pointer.heap_pointer;
        lov$param_linkage_list.first := NIL;

{!      RESET lov$param_linkage_list.container
{!  Temporary code until RESET works for heaps used by task services.

        converter.heap_pointer := segment_pointer.heap_pointer;
        osp$reset_heap (converter.os_heap_ptr.pva, converter.os_heap_ptr.length, FALSE, 1);

{!  End temporary code.

      IFEND;
    END /normal_sequence/;


    linkage := lov$param_linkage_list.first;
    WHILE linkage <> NIL DO
      IF linkage_name = linkage^.name THEN
        RETURN;
      IFEND;
      linkage := linkage^.nnext;
    WHILEND;

    ALLOCATE linkage IN lov$param_linkage_list.container^;
    linkage^.name := linkage_name;
    linkage^.definitions := NIL;
    linkage^.references := NIL;
    linkage^.nnext := lov$param_linkage_list.first;
    lov$param_linkage_list.first := linkage;

  PROCEND find_linkage_name_lists;
?? TITLE := '     report_mismatch_error', EJECT ??

{ PURPOSE:
{   The purpose of this ungainly code is to squeeze several pieces of information
{   into the parameters passed to lop$report_error.

  PROCEDURE report_mismatch_error
    (    error_condition: ost$status_condition;
         text_1: pmt$program_name;
         text_2: string ( * {<=31} );
         number_1: integer;
         number_2: integer);

    VAR
      status_string_1: string (255),
      status_string_2: string (255),
      status_string_length_1: integer,
      status_string_length_2: integer;

    IF (error_condition = lle$bad_char_length) THEN
      STRINGREP (status_string_1, status_string_length_1, text_1);
      STRINGREP (status_string_2, status_string_length_2, text_2, ', actual length = ', number_1,
            ' and formal length = ', number_2);
    ELSEIF (error_condition = lle$actual_less_than_formal) THEN
      STRINGREP (status_string_1, status_string_length_1, text_1);
      STRINGREP (status_string_2, status_string_length_2, text_2, ' actual length of ', number_1,
            ' less than formal length of ', number_2);
    ELSE
      STRINGREP (status_string_1, status_string_length_1, ' Parameter number', number_1, ' of procedure ',
            text_1);
      STRINGREP (status_string_2, status_string_length_2, 'at line number', number_2, ' of module ', text_2);
    IFEND;
    lop$report_error (error_condition, status_string_1 (1, status_string_length_1),
          status_string_2 (1, status_string_length_2), 0);
  PROCEND report_mismatch_error;



?? TITLE := '     fortran_argument_checking', EJECT ??

  PROCEDURE fortran_argument_checking
    (VAR actual_parameters: ^llt$actual_parameters;
         formal_parameters: ^lot$formal_param_definition;
         module_name: pmt$program_name);

    TYPE
      formal_type_array = array [llt$fortran_argument_type] of boolean,
      actual_type_array = array [llt$fortran_argument_type] of formal_type_array,
      formal_kind_array = array [llt$fortran_argument_kind] of boolean,
      actual_kind_array = array [llc$fortran_variable .. llc$fortran_array_element] of formal_kind_array,
      formal_usage_array = array [llt$argument_usage] of boolean,
      actual_usage_array = array [llt$argument_usage] of formal_usage_array;

?? FMT (FORMAT := OFF) ??

    VAR
      fortran_argument_type_checking: [STATIC, READ, oss$job_paged_literal] actual_type_array := [
                  {  L      I      R      DR    COMP   CHAR    B      NT     SL     HR     BIT  }
      {    L   }  [ TRUE,  FALSE, FALSE, FALSE, FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
      {    I   }  [ FALSE, TRUE,  FALSE, FALSE, FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
      {    R   }  [ FALSE, FALSE, TRUE,  FALSE, FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
      {    DR  }  [ FALSE, FALSE, FALSE, TRUE,  FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
      {   COMP }  [ FALSE, FALSE, FALSE, FALSE, TRUE,  FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
      {   CHAR }  [ FALSE, FALSE, FALSE, FALSE, FALSE, TRUE,  TRUE,  TRUE,  FALSE, FALSE, FALSE ],
      {    B   }  [ TRUE,  TRUE,  TRUE,  FALSE, FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
      {    NT  }  [ TRUE,  TRUE,  TRUE,  TRUE,  TRUE,  TRUE,  TRUE,  TRUE,  FALSE, FALSE, FALSE ],
      {    SL  }  [ FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE,  FALSE, FALSE ],
      {    HR  }  [ FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE,  FALSE ],
      {   BIT  }  [ FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE ]];


    VAR
      fortran_argument_kind_checking: [STATIC, READ, oss$job_paged_literal] actual_kind_array := [
                {  V      A      X      AE     U    }
      {  V  }   [ TRUE,  FALSE, FALSE, FALSE, TRUE  ],
      {  A  }   [ FALSE, TRUE,  FALSE, FALSE, FALSE ],
      {  X  }   [ FALSE, FALSE, TRUE,  FALSE, TRUE  ],
      {  AE }   [ TRUE,  TRUE,  FALSE, FALSE, TRUE ]];


    VAR
      fortran_argument_usage_checking: [STATIC, READ, oss$job_paged_literal] actual_usage_array := [

                {  W      NW  }
      {  W   }  [ TRUE,  TRUE ],
      {  NW  }  [ FALSE, TRUE ]];

?? FMT (FORMAT := ON) ??

    VAR
      actual_seq: ^SEQ ( * ),
      formal_seq: ^SEQ ( * ),
      actual_parameter_descriptor: ^llt$fortran_argument_desc,
      formal_parameter_descriptor: ^llt$fortran_argument_desc,
      type_valid: boolean,
      kind_valid: boolean,
      usage_valid: boolean,
      valid: boolean,
      actual_length: integer,
      formal_length: integer,
      parameter_number: integer,
      parameter_number_size: integer,
      parameter_number_string: string (31);

    actual_seq := ^actual_parameters^.specification;
    formal_seq := ^formal_parameters^.definition.specification;
    RESET actual_seq;
    RESET formal_seq;

    NEXT actual_parameter_descriptor IN actual_seq;
    NEXT formal_parameter_descriptor IN formal_seq;

    parameter_number := 0;

    WHILE (actual_parameter_descriptor <> NIL) AND (formal_parameter_descriptor <> NIL) DO
      type_valid := fortran_argument_type_checking [actual_parameter_descriptor^.argument_type]
            [formal_parameter_descriptor^.argument_type];
      IF NOT type_valid THEN
        report_mismatch_error (lle$invalid_type_matching, actual_parameters^.callee_name, module_name,
              parameter_number, actual_parameters^.line_number_of_call);
      ELSE
        kind_valid := fortran_argument_kind_checking [actual_parameter_descriptor^.argument_kind]
              [formal_parameter_descriptor^.argument_kind];
        IF NOT kind_valid THEN
          report_mismatch_error (lle$invalid_kind_matching, actual_parameters^.callee_name, module_name,
                parameter_number, actual_parameters^.line_number_of_call);
        ELSE
          usage_valid := fortran_argument_usage_checking [actual_parameter_descriptor^.mode]
                [formal_parameter_descriptor^.mode];
          IF NOT usage_valid THEN
            report_mismatch_error (lle$invalid_mode_matching, actual_parameters^.callee_name, module_name,
                  parameter_number, actual_parameters^.line_number_of_call);
          IFEND;
        IFEND;
      IFEND;

      IF (actual_parameter_descriptor^.argument_type = llc$fortran_char) AND
            (formal_parameter_descriptor^.argument_type = llc$fortran_boolean) THEN
        valid := actual_parameter_descriptor^.string_length.number_of_characters >= 8;
        IF NOT valid THEN
          STRINGREP (parameter_number_string, parameter_number_size, parameter_number);
          report_mismatch_error (lle$bad_char_length, module_name,
                parameter_number_string (1, parameter_number_size),
                actual_parameter_descriptor^.string_length.number_of_characters,
                formal_parameter_descriptor^.string_length.number_of_characters);
        IFEND;
      IFEND;

      IF (actual_parameter_descriptor^.argument_type = llc$fortran_char) AND
            (formal_parameter_descriptor^.argument_type = llc$fortran_char) AND
            (NOT (llc$fortran_assumed_len_string IN actual_parameter_descriptor^.string_length.attributes))
            THEN
        valid := actual_parameter_descriptor^.string_length.number_of_characters >=
              formal_parameter_descriptor^.string_length.number_of_characters;
        IF NOT valid THEN
          STRINGREP (parameter_number_string, parameter_number_size, parameter_number);
          report_mismatch_error (lle$bad_char_length, actual_parameters^.callee_name,
                parameter_number_string (1, parameter_number_size),
                actual_parameter_descriptor^.string_length.number_of_characters,
                formal_parameter_descriptor^.string_length.number_of_characters);
        IFEND;
      IFEND;

      IF ((actual_parameter_descriptor^.argument_type = llc$fortran_char) AND
            (formal_parameter_descriptor^.argument_type = llc$fortran_char)) THEN
        IF (((actual_parameter_descriptor^.argument_kind = llc$fortran_array) AND
              (NOT (llc$fortran_adaptable_array IN actual_parameter_descriptor^.array_size.attributes) AND
              NOT (llc$fortran_assumed_len_array IN actual_parameter_descriptor^.array_size.attributes)) OR
              (actual_parameter_descriptor^.argument_kind = llc$fortran_array_element) AND
              (NOT (llc$fortran_assumed_len_string IN actual_parameter_descriptor^.string_length.
              attributes))) AND (formal_parameter_descriptor^.argument_kind = llc$fortran_array) AND
              (NOT (llc$fortran_adaptable_array IN formal_parameter_descriptor^.array_size.attributes) AND
              NOT (llc$fortran_assumed_len_array IN formal_parameter_descriptor^.array_size.attributes))) THEN
          IF actual_parameter_descriptor^.argument_kind = llc$fortran_array THEN
            actual_length := actual_parameter_descriptor^.array_size.number_of_elements *
                  actual_parameter_descriptor^.string_length.number_of_characters;
          ELSE
            actual_length := actual_parameter_descriptor^.string_length.number_of_characters;
          IFEND;

          IF formal_parameter_descriptor^.argument_kind = llc$fortran_array THEN
            formal_length := formal_parameter_descriptor^.array_size.number_of_elements *
                  formal_parameter_descriptor^.string_length.number_of_characters;
          ELSE
            formal_length := formal_parameter_descriptor^.string_length.number_of_characters;
          IFEND;
          valid := actual_length >= formal_length;
          IF NOT valid THEN
            STRINGREP (parameter_number_string, parameter_number_size, parameter_number);
            report_mismatch_error (lle$actual_less_than_formal, actual_parameters^.callee_name,
                  parameter_number_string (1, parameter_number_size), actual_length, formal_length);
          IFEND;
        IFEND;
      IFEND;

      IF (actual_parameter_descriptor^.argument_type = llc$fortran_integer) AND
            (formal_parameter_descriptor^.argument_type = llc$fortran_integer) THEN

{ The purpose of the following code is to maintain compatibility with binary files
{ compiled before INTEGER*N code is available in FORTRAN.

        IF actual_parameter_descriptor^.string_length.number_of_characters = 0 THEN
          actual_length := 8;
        ELSE
          actual_length := actual_parameter_descriptor^.string_length.number_of_characters;
        IFEND;
        IF formal_parameter_descriptor^.string_length.number_of_characters = 0 THEN
          formal_length := 8;
        ELSE
          formal_length := formal_parameter_descriptor^.string_length.number_of_characters;
        IFEND;

{ End of code to maintain compatibility

        valid := actual_length = formal_length;
        IF NOT valid THEN
          report_mismatch_error (lle$bad_integer_length, actual_parameters^.callee_name, module_name,
                parameter_number, actual_parameters^.line_number_of_call);
        IFEND;
      IFEND;

      valid := TRUE;

      IF (formal_parameter_descriptor^.argument_kind = llc$fortran_array) AND
            (llc$fortran_assumed_shape_array IN formal_parameter_descriptor^.array_size.attributes) THEN
        IF (actual_parameter_descriptor^.argument_kind <> llc$fortran_array) OR
              (llc$fortran_assumed_len_array IN actual_parameter_descriptor^.array_size.attributes) OR
              (actual_parameter_descriptor^.array_size.rank <> formal_parameter_descriptor^.array_size.rank)
              THEN
          valid := FALSE;
        IFEND;
      ELSE
        IF formal_parameter_descriptor^.argument_kind = llc$fortran_array THEN
          IF (actual_parameter_descriptor^.argument_kind = llc$fortran_array) AND
                ((llc$fortran_array_section IN actual_parameter_descriptor^.array_size.attributes) OR
                (llc$fortran_assumed_shape_array IN actual_parameter_descriptor^.array_size.attributes)) THEN
            valid := FALSE;
          IFEND;
        IFEND;
      IFEND;

      IF NOT valid THEN
        report_mismatch_error (lle$invalid_array_size_matching, actual_parameters^.callee_name, module_name,
              parameter_number, actual_parameters^.line_number_of_call);
      IFEND;

      NEXT actual_parameter_descriptor IN actual_seq;
      NEXT formal_parameter_descriptor IN formal_seq;

      parameter_number := parameter_number + 1;

    WHILEND;

    IF (actual_parameter_descriptor = NIL) AND (formal_parameter_descriptor <> NIL) THEN
      lop$report_error (lle$invalid_matching, actual_parameters^.callee_name, module_name, 0);
    IFEND;

  PROCEND fortran_argument_checking;

?? TITLE := '  [XDCL] lop$define_formal_parameters', EJECT ??

  PROCEDURE [XDCL] lop$define_formal_parameters
    (    formal_parameters: ^llt$formal_parameters;
         attributes: lot$module_attributes;
         module_descriptor: {input} ^lot$module_descriptor;
         allocated_sections: {input} ^lot$allocated_sections;
         control_options {control} : lot$control_options);

{  PURPOSE:
{    This procedure processes 'entry_definition' object text records.  The new definition is added
{    to the entry definitions sublist for the specified linkage (entry point) name, unless it is a duplicate
{    definition.  Then the sublist of unsatisfied references for the linkage name is searched to
{    determine if any of the references can be satisfied by the new definition.
{  NOTE:
{    Since all of the unsatisfied references in the sublist being searched are for the same linkage
{    name, the matching process becomes one of comparing protection environments to verify
{    accessibility.  Similarly, testing for duplicate entry points becomes a matter of testing for
{    protection environment overlap.

?? NEWTITLE := '    add_definition_to_list', EJECT ??

    PROCEDURE [INLINE] add_definition_to_list
      (    entry_descriptor: ^lot$entry_point_descriptor;
           formal_parameters: ^llt$formal_parameters;
       VAR definition: ^lot$formal_param_definition;
       VAR linkage: ^lot$param_matching_node;
       VAR duplicate_entry_point {control} : boolean);

      VAR
        segment_pointer: mmt$segment_pointer,
        linkage_name: pmt$program_name,
        formal_seq: ^SEQ ( * ),
        abort_status: ^ost$status;

{!  Temporary code until RESET works for heaps used by task services.

      VAR
        converter: record
          case dummy: 1 .. 2 of
          = 1 =
            heap_pointer: ^HEAP ( * ),
          = 2 =
            os_heap_ptr: cyt$adaptable_heap_pointer,
          casend,
        recend;

*copy rhp$initialize
?? PUSH (LISTEXT := ON) ??
*copy ost$heap
?? POP ??

{!  End temporary code.


      find_linkage_name_lists (entry_descriptor^.name, linkage);
      definition := linkage^.definitions;
      WHILE definition <> NIL DO
        IF ((definition^.global_lock = entry_descriptor^.attributes.global_lock) OR
              (definition^.gated AND entry_descriptor^.attributes.gated) OR
              ((definition^.gated OR entry_descriptor^.attributes.gated) AND
              ((definition^.global_lock = loc$no_lock) OR (entry_descriptor^.attributes.global_lock =
              loc$no_lock)))) AND NOT ((definition^.loaded_ring >
              entry_descriptor^.attributes.call_bracket) OR (definition^.call_bracket <
              entry_descriptor^.attributes.loaded_ring)) THEN
          lop$report_error (lle$duplicate_entry_point, entry_descriptor^.name, '', 0);
          duplicate_entry_point := TRUE;
          RETURN;
        IFEND;
        definition := definition^.nnext;
      WHILEND;
      duplicate_entry_point := FALSE;

    /normal_sequence/
      BEGIN
        IF lov$param_linkage_list.container = NIL THEN
          mmp$create_segment (NIL, mmc$heap_pointer, loc$loader_ring, segment_pointer, lov$secondary_status);
          IF NOT lov$secondary_status.normal THEN
            lop$report_error (lle$unable_to_create_table, 'UNSATISFIED REFERENCES', '', 0);
            PUSH abort_status;
            pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
            pmp$exit (abort_status^);
          IFEND;
          lov$param_linkage_list.container := segment_pointer.heap_pointer;

{!      RESET lov$param_linkage_list.containe
{!  Temporary code until RESET works for heaps used by task services.

          converter.heap_pointer := segment_pointer.heap_pointer;
          osp$reset_heap (converter.os_heap_ptr.pva, converter.os_heap_ptr.length, FALSE, 1);

{!  End temporary code.

        IFEND;
      END /normal_sequence/;

      ALLOCATE definition: [[REP #SIZE (formal_parameters^.specification) OF cell]] IN
            lov$param_linkage_list.container^;
      IF definition <> NIL THEN
        definition^.nnext := linkage^.definitions;
        linkage^.definitions := definition;
        definition^.global_lock := entry_descriptor^.attributes.global_lock;
        definition^.loaded_ring := entry_descriptor^.attributes.loaded_ring;
        definition^.call_bracket := entry_descriptor^.attributes.call_bracket;
        definition^.gated := entry_descriptor^.attributes.gated;
        definition^.defining_module := entry_descriptor^.defining_module;
        definition^.definition := formal_parameters^;
      ELSE
        lop$report_error (lle$unable_to_load_attributes, 'ENTRY POINT DEFINITIONS', '', 0);
      IFEND;
    PROCEND add_definition_to_list;




?? TITLE := '    satisfy_entry_point_references', EJECT ??


    PROCEDURE [INLINE] satisfy_entry_point_references
      (    linkage: ^lot$param_matching_node;
           definition {input_output} : ^lot$formal_param_definition);

      VAR
        current_group: ^^lot$actual_param_group,
        temp1: ^lot$actual_param_list_item,
        temp2: ^lot$actual_param_group,
        temp_var: ^lot$actual_param_list_item,
        parm_var: ^llt$actual_parameters,
        module_name: pmt$program_name;

?? OLDTITLE, EJECT ??
      current_group := ^linkage^.references;
      WHILE current_group^ <> NIL DO
        IF ((current_group^^.global_key = definition^.global_lock) OR
              (definition^.gated AND ((definition^.global_lock = loc$no_lock) OR
              (current_group^^.global_key = loc$master_key)))) AND
              ((current_group^^.ring >= definition^.loaded_ring) AND
              (current_group^^.ring <= definition^.call_bracket)) THEN
          WHILE current_group^^.list <> NIL DO
            temp_var := current_group^^.list;
            parm_var := ^temp_var^.definition;
            fortran_argument_checking (parm_var, definition, temp_var^.module_name);
            temp1 := current_group^^.list;
            current_group^^.list := temp1^.nnext;
            FREE temp1 IN lov$unsatisfied_ref_container^;
          WHILEND;
          temp2 := current_group^;
          current_group^ := temp2^.nnext;
          FREE temp2 IN lov$unsatisfied_ref_container^;
        ELSE
          current_group := ^current_group^^.nnext;
        IFEND;
      WHILEND;
    PROCEND satisfy_entry_point_references;
?? OLDTITLE, EJECT ??

    VAR
      definition: ^lot$formal_param_definition,
      linkage_info: ^lot$param_matching_node,
      i: llt$section_ordinal,
      duplicate_entry_point: boolean,
      external_descriptor: lot$external_descriptor,
      entry_point_defined: boolean,
      dummy: ^lot$linkage_name_lists,
      entry_definition: ^lot$entry_definition,
      entry_descriptor: lot$entry_point_descriptor;

    entry_descriptor.name := formal_parameters^.procedure_name;
    entry_descriptor.defining_module := module_descriptor^.name;
    entry_descriptor.attributes.global_lock := module_descriptor^.attributes.global_key_lock;
    entry_descriptor.attributes.loaded_ring := module_descriptor^.attributes.loaded_ring;
    external_descriptor.name := formal_parameters^.procedure_name;
    external_descriptor.global_key := module_descriptor^.attributes.global_key_lock;
    external_descriptor.reference_ring := module_descriptor^.attributes.loaded_ring;
    lop$find_matching_entry_point (external_descriptor, entry_point_defined, dummy, entry_definition);

    IF NOT entry_point_defined THEN
      RETURN; { **** Temporary **** OCU is omitting entry points but not the corresponding actual params.}
      lop$report_error (lle$def_before_param, 'ENTRY_DEFINITION_PRECEEDS_ACTUAL_PARAMETERS', '', 0);
      RETURN;
    IFEND;

    entry_descriptor.attributes.gated := entry_definition^.attributes.gated;
    entry_descriptor.attributes.call_bracket := entry_definition^.attributes.call_bracket;


    IF formal_parameters^.language IN -$valid_languages [] THEN
      entry_descriptor.attributes.language := formal_parameters^.language;
    ELSE
      entry_descriptor.attributes.language := llc$unknown_generator;
      lop$report_error (lle$unknown_language, 'formal_parameters', '', #OFFSET (formal_parameters));
    IFEND;
    add_definition_to_list (^entry_descriptor, formal_parameters, definition, linkage_info,
          duplicate_entry_point);
    IF (NOT duplicate_entry_point) AND (linkage_info^.references <> NIL) THEN
      satisfy_entry_point_references (linkage_info, definition);
    IFEND;
  PROCEND lop$define_formal_parameters;
?? TITLE := '  [XDCL] lop$link_actual_parameters', EJECT ??

  PROCEDURE [XDCL] lop$link_actual_parameters
    (    actual_parameters: ^llt$actual_parameters;
         module_descriptor: {input} ^lot$module_descriptor;
         control_options {control} : lot$control_options);

{  PURPOSE:
{    This procedure processes 'external_linkage' object text records.  The entry definitions sublist
{    for the specified linkage (enternal) name is searched to determine if an existing definition
{    satisfies the reference.  If so, the external reference is satisfied immediately.  If not,
{    the reference is added to the unsatisfied references sublist for the specified linkage name.
{  NOTE:
{    Since all of the entry definitions in the sublist being searched are for the same linkage
{    name, the matching process becomes one of comparing protection environments (ring, key/lock)
{    to verify accessibility.  To minimize search time for the unsatisfied references list,
{    unsatisfied references are clustered into 'groups' such that all members of a group will be
{    satisfied by the same entry definition.

    TYPE
      valid_address_kinds = set of llt$address_kind;

    VAR
      reference_descriptor: lot$reference_descriptor,
      external_descriptor: lot$external_descriptor,
      entry_definition: ^lot$formal_param_definition,
      temp_entry_definition: lot$entry_definition,
      linkage_info: ^lot$param_matching_node,
      linkage_size: 0 .. 16,
      greatest_allocated_section: 0 .. llc$max_section_ordinal,
      entry_point_defined: boolean,
      declaration_mismatch: boolean,
      actual_param: ^llt$actual_parameters,
      entry_point_unaligned: boolean;

    external_descriptor.name := actual_parameters^.callee_name;
    external_descriptor.global_key := module_descriptor^.attributes.global_key_lock;
    external_descriptor.reference_ring := module_descriptor^.attributes.loaded_ring;
    find_matching_formal_param (external_descriptor, entry_point_defined, linkage_info, entry_definition);

    IF NOT entry_point_defined THEN
      reference_descriptor.ring := external_descriptor.reference_ring;
      reference_descriptor.global_key := external_descriptor.global_key;
      reference_descriptor.mmodule := module_descriptor^.name;
    ELSE
      actual_param := actual_parameters;
      fortran_argument_checking (actual_param, entry_definition, module_descriptor^.name);
      RETURN;
    IFEND;

    IF actual_parameters^.language IN -$valid_languages [] THEN
      reference_descriptor.details.language := actual_parameters^.language;
    ELSE
      reference_descriptor.details.language := llc$unknown_generator;
      lop$report_error (lle$unknown_language, 'actual_parameters', '', #OFFSET (actual_parameters));
    IFEND;

    add_unsatisfied_ref_to_list (actual_parameters, reference_descriptor, module_descriptor^.name,
          linkage_info);

  PROCEND lop$link_actual_parameters;
?? TITLE := '  find_matching_entry_point', EJECT ??

  PROCEDURE [INLINE] find_matching_formal_param
    (    external_descriptor: lot$external_descriptor;
     VAR formal_param_defined {control} : boolean;
     VAR linkage: ^lot$param_matching_node;
     VAR entry_definition: ^lot$formal_param_definition);

    VAR
      definition: ^lot$formal_param_definition;

    find_linkage_name_lists (external_descriptor.name, linkage);
    definition := linkage^.definitions;
    WHILE definition <> NIL DO
      IF ((external_descriptor.global_key = definition^.global_lock) OR
            (definition^.gated AND ((definition^.global_lock = loc$no_lock) OR
            (external_descriptor.global_key = loc$master_key)))) AND
            ((external_descriptor.reference_ring >= definition^.loaded_ring) AND
            (external_descriptor.reference_ring <= definition^.call_bracket)) THEN
        formal_param_defined := TRUE;
        entry_definition := definition;
        RETURN
      IFEND;
      definition := definition^.nnext;
    WHILEND;
    formal_param_defined := FALSE;
  PROCEND find_matching_formal_param;
?? TITLE := '  add_unsatisfied_ref_to_list', EJECT ??

  PROCEDURE [INLINE] add_unsatisfied_ref_to_list
    (    actual_parameters: ^llt$actual_parameters;
         reference_descriptor: lot$reference_descriptor;
         module_name: pmt$program_name;
     VAR linkage: ^lot$param_matching_node);

    VAR
      destination_group: ^lot$actual_param_group,
      new_reference: ^lot$actual_param_list_item,
      abort_status: ^ost$status;


  /normal_sequence/
    BEGIN
      IF lov$unsatisfied_ref_container = NIL THEN
        lop$create_unsat_ref_segment;
      IFEND;

      ALLOCATE new_reference: [[REP #SIZE (actual_parameters^.specification) OF cell]] IN
            lov$unsatisfied_ref_container^;
      IF new_reference = NIL THEN
        EXIT /normal_sequence/
      IFEND;
      new_reference^.definition := actual_parameters^;
      new_reference^.module_name := module_name;

    /find_destination_group/
      BEGIN
        destination_group := linkage^.references;
        WHILE destination_group <> NIL DO
          IF (reference_descriptor.global_key = destination_group^.global_key) AND
                (reference_descriptor.ring = destination_group^.ring) THEN
            EXIT /find_destination_group/
          IFEND;
          destination_group := destination_group^.nnext;
        WHILEND;
        ALLOCATE destination_group IN lov$unsatisfied_ref_container^;
        IF destination_group = NIL THEN
          EXIT /normal_sequence/
        IFEND;
        destination_group^.nnext := linkage^.references;
        linkage^.references := destination_group;
        destination_group^.global_key := reference_descriptor.global_key;
        destination_group^.ring := reference_descriptor.ring;
        destination_group^.list := NIL;
      END /find_destination_group/;
      new_reference^.nnext := destination_group^.list;
      destination_group^.list := new_reference;
      RETURN
    END /normal_sequence/;
    lop$report_error (lle$loader_table_overflow, 'UNSATISFIED REFERENCES', '', 0);
    PUSH abort_status;
    pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
    pmp$exit (abort_status^);
  PROCEND add_unsatisfied_ref_to_list;
MODEND lom$actual_formal_parm_matching;
*DECK DECK=LOM$ANALYZE_PROGRAM_DYNAMICS EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE : Loader : Analyze program dynamics' ??
?? NEWTITLE := '  Global declarations' ??
MODULE lom$analyze_program_dynamics;
?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc loe$abort_load
*copyc lle$load_map_diagnostics
*copyc lot$loader_type_definitions
*copyc osd$virtual_address
*copyc pmt$loader_seq_descriptor
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc fsp$close_file
*copyc fsp$open_file
*copyc lop$find_matching_entry_point
*copyc lop$report_error
*copyc lop$reserve_storage
*copyc lop$store_linkage
*copyc osp$generate_log_message
*copyc pmp$cause_condition
*copyc pmp$exit
*copyc pmp$initial_intercept_procedure
*copyc pmp$intercept_call_procedure
*copyc osv$task_private_heap
*copyc lov$secondary_status
?? EJECT ??

  TYPE
    pointer_to_apd_descriptor = record
      case 0 .. 1 of
      = 0 =
        apd_descriptor_ptr: ^pmt$loader_seq_descriptor,

      = 1 =
        apd_descriptor_address: lot$address,
      casend,
    recend;

  VAR
    lov$apd_flags: [oss$task_private, XDCL] record
      apd_load: boolean,
      target_text: boolean,
    recend := [FALSE, FALSE];

  TYPE
    apd_loader_information = record
      apd_files_opened: boolean,
      target_text: ^amt$local_file_name,
      loader_seq_file_name: ^amt$local_file_name,
      loader_seq_descriptor: ^pmt$loader_seq_descriptor,
      apd_descriptor: pointer_to_apd_descriptor,
      intercept_proc_bsp: lot$address,
      initial_intercept_proc_bsp: lot$address,
      pseudo_reference_details: ^lot$reference_details,
      pseudo_entry_definition: ^lot$entry_definition,
      intercept_proc_entry_definition: ^lot$entry_definition,
      intercept_reference_details: ^lot$reference_details,
      init_intercept_proc_entry_def: ^lot$entry_definition,
    recend;

  VAR
    allocation_length: [STATIC] ost$segment_length := 40,
    apd_binding_segment_attributes: [STATIC, READ, oss$job_paged_literal] lot$segment_attributes :=
          [[FALSE, osc$non_executable, osc$binding_segment, osc$non_writable], osc$tsrv_ring, osc$max_ring,
          [FALSE, FALSE, 0], FALSE, FALSE, FALSE, TRUE],
    apd_data: [oss$task_private, STATIC] ^apd_loader_information := NIL;

?? OLDTITLE ??
?? NEWTITLE := 'initialize_loader_seq', EJECT ??

  PROCEDURE initialize_loader_seq
    (    loader_description: ^pmt$loader_description);



    VAR
      segment_pointer: amt$segment_pointer,
      seq_id: amt$file_identifier,
      ignore: boolean,
      interblock_references_hdr: ^pmt$interblock_references_hdr,
      current_attributes: array [1 .. 1] of amt$get_item,
      file_attachment: ^fst$attachment_options,
      attribute_validation: ^fst$file_cycle_attributes,
      status: ost$status,
      abort_status: ^ost$status;


    current_attributes [1].key := amc$ring_attributes;
    amp$get_file_attributes (loader_description^.mpe_loader_seq, current_attributes, ignore, ignore, ignore,
          lov$secondary_status);
    IF NOT lov$secondary_status.normal THEN
      lop$report_error (lle$unable_to_access_apd_file, loader_description^.mpe_loader_seq, '', 0);
      PUSH abort_status;
      pmp$cause_condition (loe$abort_load, NIL, abort_status^);
      pmp$exit (abort_status^);
    IFEND;

    PUSH file_attachment: [1 .. 1];
    file_attachment^ [1].selector := fsc$access_and_share_modes;
    file_attachment^ [1].access_modes.selector := fsc$specific_access_modes;
    file_attachment^ [1].access_modes.value := $fst$file_access_options
          [fsc$read, fsc$append, fsc$modify, fsc$shorten];
    file_attachment^ [1].share_modes.selector := fsc$determine_from_access_modes;

    PUSH attribute_validation: [1 .. 4];
    attribute_validation^ [1].selector := fsc$file_contents_and_processor;
    attribute_validation^ [1].file_contents := fsc$data;
    attribute_validation^ [1].file_processor := fsc$unknown_processor;
    attribute_validation^ [2].selector := fsc$file_organization;
    attribute_validation^ [2].file_organization := amc$sequential;
    attribute_validation^ [3].selector := fsc$record_type;
    attribute_validation^ [3].record_type := amc$undefined;
    attribute_validation^ [4].selector := fsc$ring_attributes;
    attribute_validation^ [4].ring_attributes := current_attributes [1].ring_attributes;

    fsp$open_file (loader_description^.mpe_loader_seq, amc$segment, file_attachment, NIL, NIL,
          attribute_validation, NIL, seq_id, lov$secondary_status);
    IF NOT lov$secondary_status.normal THEN
      lop$report_error (lle$unable_to_access_apd_file, loader_description^.mpe_loader_seq, '', 0);
      PUSH abort_status;
      pmp$cause_condition (loe$abort_load, NIL, abort_status^);
      pmp$exit (abort_status^);
    IFEND;

    amp$get_segment_pointer (seq_id, amc$sequence_pointer, segment_pointer, lov$secondary_status);
    IF NOT lov$secondary_status.normal THEN
      lop$report_error (lle$unable_to_access_apd_file, loader_description^.mpe_loader_seq, '', 0);
      PUSH abort_status;
      pmp$cause_condition (loe$abort_load, NIL, abort_status^);
      pmp$exit (abort_status^);
    IFEND;

    RESET segment_pointer.sequence_pointer;

    NEXT apd_data^.loader_seq_descriptor IN segment_pointer.sequence_pointer;
    IF apd_data^.loader_seq_descriptor = NIL THEN
      lop$report_error (lle$eof_encountered_on_apd_file, loader_description^.mpe_loader_seq, '', 0);
      PUSH abort_status;
      pmp$cause_condition (loe$abort_load, NIL, abort_status^);
      pmp$exit (abort_status^);
    IFEND;

    apd_data^.loader_seq_descriptor^.seq_ptr := segment_pointer.sequence_pointer;
    apd_data^.loader_seq_descriptor^.file_id := seq_id;
    apd_data^.loader_seq_descriptor^.mpe_aborted := FALSE;

    IF apd_data^.loader_seq_descriptor^.block_name_map_exists THEN
      NEXT apd_data^.loader_seq_descriptor^.remote_block_name_map:
            [0 .. apd_data^.loader_seq_descriptor^.remote_block_id] IN
            apd_data^.loader_seq_descriptor^.seq_ptr;
      IF apd_data^.loader_seq_descriptor^.remote_block_name_map = NIL THEN
        lop$report_error (lle$eof_encountered_on_apd_file, loader_description^.mpe_loader_seq, '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$abort_load, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;

      NEXT apd_data^.loader_seq_descriptor^.local_block_name_map:
            [0 .. apd_data^.loader_seq_descriptor^.local_block_id] IN
            apd_data^.loader_seq_descriptor^.seq_ptr;
      IF apd_data^.loader_seq_descriptor^.local_block_name_map = NIL THEN
        lop$report_error (lle$eof_encountered_on_apd_file, loader_description^.mpe_loader_seq, '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$abort_load, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
    ELSE
      NEXT apd_data^.loader_seq_descriptor^.remote_block_name_map: [0 .. 0] IN
            apd_data^.loader_seq_descriptor^.seq_ptr;
      IF apd_data^.loader_seq_descriptor^.remote_block_name_map = NIL THEN
        lop$report_error (lle$eof_encountered_on_apd_file, loader_description^.mpe_loader_seq, '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$abort_load, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;

      NEXT apd_data^.loader_seq_descriptor^.local_block_name_map: [0 .. 0] IN
            apd_data^.loader_seq_descriptor^.seq_ptr;
      IF apd_data^.loader_seq_descriptor^.local_block_name_map = NIL THEN
        lop$report_error (lle$eof_encountered_on_apd_file, loader_description^.mpe_loader_seq, '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$abort_load, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
    IFEND;

    apd_data^.loader_seq_descriptor^.remote_block_id := 0;
    apd_data^.loader_seq_descriptor^.local_block_id := 0;
    apd_data^.loader_seq_descriptor^.number_of_interblock_segments := 1;
    apd_data^.loader_seq_descriptor^.accumulated_intercept_time := 0;
    apd_data^.loader_seq_descriptor^.max_segment_length := osc$maximum_offset;

    ALLOCATE apd_data^.loader_seq_file_name IN osv$task_private_heap^;
    apd_data^.loader_seq_file_name^ := loader_description^.mpe_loader_seq;

    fsp$open_file (apd_data^.loader_seq_descriptor^.first_interblock_segment_name, amc$segment,
          file_attachment, NIL, NIL, attribute_validation, NIL, seq_id, lov$secondary_status);
    IF NOT lov$secondary_status.normal THEN
      lop$report_error (lle$unable_to_access_apd_file, apd_data^.loader_seq_descriptor^.
            first_interblock_segment_name, '', 0);
      PUSH abort_status;
      pmp$cause_condition (loe$abort_load, NIL, abort_status^);
      pmp$exit (abort_status^);
    IFEND;

    amp$get_segment_pointer (seq_id, amc$sequence_pointer, segment_pointer, lov$secondary_status);
    IF NOT lov$secondary_status.normal THEN
      lop$report_error (lle$unable_to_access_apd_file, apd_data^.loader_seq_descriptor^.
            first_interblock_segment_name, '', 0);
      PUSH abort_status;
      pmp$cause_condition (loe$abort_load, NIL, abort_status^);
      pmp$exit (abort_status^);
    IFEND;

    RESET segment_pointer.sequence_pointer;
    apd_data^.loader_seq_descriptor^.last_interblock_segment := segment_pointer.sequence_pointer;
    NEXT interblock_references_hdr IN apd_data^.loader_seq_descriptor^.last_interblock_segment;
    interblock_references_hdr^.file_id := seq_id;
    interblock_references_hdr^.number_of_interblock_references := 0;
    interblock_references_hdr^.next_segment_file_name := osc$null_name;
    apd_data^.apd_files_opened := TRUE;

  PROCEND initialize_loader_seq;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL] lop$initialize_apd_processing' ??
?? EJECT ??

  PROCEDURE [XDCL] lop$initialize_apd_processing
    (    loader_description: ^pmt$loader_description);



    TYPE
      pointer_to_procedure = record
        case 0 .. 1 of
        = 0 =
          intercept_procedure: ^procedure,
        = 1 =
          proc_descriptor: procedure_descriptor
        casend,
      recend,

      procedure_descriptor = record
        binding_entry: ^binding_template,
        static_link: ^cell,
      recend;


    TYPE
      binding_template = record
        cbp: lot$cbp_template,
        filler: 0 .. 0ffff(16),
        bsp: lot$address,
      recend;


    VAR
      record_block_transfer: pointer_to_procedure,
      ptr_to_procedure_descriptor: procedure_descriptor;


    ALLOCATE apd_data IN osv$task_private_heap^;

    apd_data^.apd_files_opened := FALSE;
    lov$apd_flags.apd_load := TRUE;
    ALLOCATE apd_data^.target_text IN osv$task_private_heap^;
    apd_data^.target_text^ := loader_description^.target_text.local_file_name;

    initialize_loader_seq (loader_description);

    ALLOCATE apd_data^.pseudo_reference_details IN osv$task_private_heap^;
    apd_data^.pseudo_reference_details^.binding_section_destination := FALSE;
    apd_data^.pseudo_reference_details^.declaration_matching_required := FALSE;
    apd_data^.pseudo_reference_details^.kind := llc$address;
    ALLOCATE apd_data^.pseudo_entry_definition IN osv$task_private_heap^;
    apd_data^.pseudo_entry_definition^.attributes.declaration_matching_required := FALSE;

{ If declaration_matching_required is set to TRUE, one will need to initialize source_declaration_matching.

    ALLOCATE apd_data^.intercept_reference_details IN osv$task_private_heap^;
    apd_data^.intercept_reference_details^.binding_section_destination := FALSE;
    apd_data^.intercept_reference_details^.kind := llc$external_proc;

    record_block_transfer.intercept_procedure := ^pmp$intercept_call_procedure;
    ptr_to_procedure_descriptor := record_block_transfer.proc_descriptor;

    ALLOCATE apd_data^.intercept_proc_entry_definition IN osv$task_private_heap^;
    apd_data^.intercept_proc_entry_definition^.attributes.vmid :=
          ptr_to_procedure_descriptor.binding_entry^.cbp.vmid;
    apd_data^.intercept_proc_entry_definition^.attributes.call_bracket :=
          ptr_to_procedure_descriptor.binding_entry^.cbp.call_bracket;
    apd_data^.intercept_proc_entry_definition^.attributes.loaded_ring :=
          ptr_to_procedure_descriptor.binding_entry^.cbp.call_bracket;
    apd_data^.intercept_proc_entry_definition^.attributes.address :=
          ptr_to_procedure_descriptor.binding_entry^.cbp.address;
    apd_data^.intercept_proc_entry_definition^.attributes.declaration_matching_required := FALSE;

{ If declaration_matching_required is set to TRUE, one will need to initialize source_declaration_matching.

    apd_data^.intercept_proc_bsp := ptr_to_procedure_descriptor.binding_entry^.bsp;
    apd_data^.apd_descriptor.apd_descriptor_ptr := apd_data^.loader_seq_descriptor;

    record_block_transfer.intercept_procedure := ^pmp$initial_intercept_procedure;
    ptr_to_procedure_descriptor := record_block_transfer.proc_descriptor;

    ALLOCATE apd_data^.init_intercept_proc_entry_def IN osv$task_private_heap^;
    apd_data^.init_intercept_proc_entry_def^.attributes.vmid :=
          ptr_to_procedure_descriptor.binding_entry^.cbp.vmid;
    apd_data^.init_intercept_proc_entry_def^.attributes.call_bracket :=
          ptr_to_procedure_descriptor.binding_entry^.cbp.call_bracket;
    apd_data^.init_intercept_proc_entry_def^.attributes.loaded_ring :=
          ptr_to_procedure_descriptor.binding_entry^.cbp.call_bracket;
    apd_data^.init_intercept_proc_entry_def^.attributes.address :=
          ptr_to_procedure_descriptor.binding_entry^.cbp.address;
    apd_data^.init_intercept_proc_entry_def^.attributes.declaration_matching_required := FALSE;

{ If declaration_matching_required is set to TRUE, one will need to initialize source_declaration_matching.

    apd_data^.initial_intercept_proc_bsp := ptr_to_procedure_descriptor.binding_entry^.bsp;

  PROCEND lop$initialize_apd_processing;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL] lop$check_for_target_text' ??
?? EJECT ??

  PROCEDURE [XDCL] lop$check_for_target_text
    (    file_name: amt$local_file_name);

    IF apd_data <> NIL THEN
      lov$apd_flags.target_text := file_name = apd_data^.target_text^;
    ELSE
      lov$apd_flags.target_text := FALSE;
    IFEND;

  PROCEND lop$check_for_target_text;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$close_apd_processing_files', EJECT ??
*copy loh$close_apd_processing_files

  PROCEDURE [XDCL] lop$close_apd_processing_files;

    VAR
      ignore_status: ost$status,
      interblock_references_hdr: ^pmt$interblock_references_hdr,
      loader_seq_descriptor_p: ^pmt$loader_seq_descriptor;

    IF (apd_data <> NIL) AND apd_data^.apd_files_opened THEN
      loader_seq_descriptor_p := apd_data^.loader_seq_descriptor;
      RESET loader_seq_descriptor_p^.last_interblock_segment;
      NEXT interblock_references_hdr IN apd_data^.loader_seq_descriptor^.last_interblock_segment;
      IF interblock_references_hdr <> NIL THEN
        fsp$close_file (interblock_references_hdr^.file_id, ignore_status);
      IFEND;
      fsp$close_file (loader_seq_descriptor_p^.file_id, ignore_status);
      apd_data^.apd_files_opened := FALSE;
    IFEND;

  PROCEND lop$close_apd_processing_files;
?? EJECT ??
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL] lop$gen_init_intercept_linkage' ??

  PROCEDURE [XDCL] lop$gen_init_intercept_linkage
    (    transfer_descriptor: lot$external_descriptor;
     VAR reference_details: lot$reference_details);



    VAR
      address_value_unaligned: boolean,
      apd_binding_section_address_1: lot$address,
      apd_binding_section_address_2: lot$address,
      binding_section_overwrite: boolean,
      declaration_mismatch: boolean,
      linkage_info: ^lot$linkage_name_lists,
      transfer_symbol_defined: boolean,
      transfer_symbol_definition: ^lot$entry_definition;


    IF transfer_descriptor.name = osc$null_name THEN
      RETURN;
    IFEND;

    lop$find_matching_entry_point (transfer_descriptor, transfer_symbol_defined, linkage_info,
          transfer_symbol_definition);

    IF transfer_symbol_defined THEN
      reference_details.binding_section_destination := FALSE;

      IF (NOT transfer_symbol_definition^.attributes.in_target_text) AND
            (NOT transfer_symbol_definition^.attributes.instrumented) THEN
        lop$add_remote_block_id (transfer_descriptor.name, transfer_symbol_definition^.attributes.block_id);
      IFEND;

      lop$reserve_storage (apd_binding_segment_attributes, 8, 0, FALSE, 0, loc$no_shadow_file, 0,
            allocation_length, apd_binding_section_address_1);
      apd_data^.init_intercept_proc_entry_def^.attributes.binding_section_address :=
            apd_binding_section_address_1;
      apd_data^.init_intercept_proc_entry_def^.attributes.address.ring :=
            transfer_symbol_definition^.attributes.address.ring;
      lop$store_linkage (^reference_details, apd_data^.init_intercept_proc_entry_def,
            binding_section_overwrite, declaration_mismatch, address_value_unaligned);
      apd_data^.intercept_reference_details^.address := apd_binding_section_address_1;

      IF transfer_symbol_definition^.attributes.instrumented THEN
        apd_data^.intercept_proc_entry_definition^.attributes.binding_section_address :=
              transfer_symbol_definition^.attributes.instrumented_callee_address;
      ELSE
        lop$reserve_storage (apd_binding_segment_attributes, 8, 0, FALSE, 0, loc$no_shadow_file, 0,
              allocation_length, apd_binding_section_address_2);
        apd_data^.intercept_proc_entry_definition^.attributes.binding_section_address :=
              apd_binding_section_address_2;
      IFEND;
      apd_data^.intercept_reference_details^.declaration_matching_required := FALSE;
      lop$store_linkage (apd_data^.intercept_reference_details, apd_data^.intercept_proc_entry_definition,
            binding_section_overwrite, declaration_mismatch, address_value_unaligned);
      IF address_value_unaligned THEN
        RETURN;
      IFEND;

      apd_data^.pseudo_entry_definition^.attributes.address := apd_data^.initial_intercept_proc_bsp;
      apd_binding_section_address_1.offset := apd_binding_section_address_1.offset + 18;
      apd_data^.pseudo_reference_details^.address := apd_binding_section_address_1;
      lop$store_linkage (apd_data^.pseudo_reference_details, apd_data^.pseudo_entry_definition,
            binding_section_overwrite, declaration_mismatch, address_value_unaligned);

      apd_data^.pseudo_entry_definition^.attributes.address.ring := 0;
      apd_data^.pseudo_entry_definition^.attributes.address.segment := 0;
      apd_data^.pseudo_entry_definition^.attributes.address.offset := 0;
      apd_binding_section_address_1.offset := apd_binding_section_address_1.offset + 8;
      apd_data^.pseudo_reference_details^.address := apd_binding_section_address_1;
      lop$store_linkage (apd_data^.pseudo_reference_details, apd_data^.pseudo_entry_definition,
            binding_section_overwrite, declaration_mismatch, address_value_unaligned);

      apd_data^.pseudo_entry_definition^.attributes.address :=
            apd_data^.apd_descriptor.apd_descriptor_address;
      apd_binding_section_address_1.offset := apd_binding_section_address_1.offset + 8;
      apd_data^.pseudo_reference_details^.address := apd_binding_section_address_1;
      lop$store_linkage (apd_data^.pseudo_reference_details, apd_data^.pseudo_entry_definition,
            binding_section_overwrite, declaration_mismatch, address_value_unaligned);

      IF NOT transfer_symbol_definition^.attributes.instrumented THEN
        apd_data^.intercept_reference_details^.address := apd_binding_section_address_2;
        apd_data^.intercept_reference_details^.declaration_matching_required :=
              reference_details.declaration_matching_required;
        apd_data^.intercept_reference_details^.declaration_matching := reference_details.declaration_matching;
        apd_data^.intercept_reference_details^.language := reference_details.language;
        lop$store_linkage (apd_data^.intercept_reference_details, transfer_symbol_definition,
              binding_section_overwrite, declaration_mismatch, address_value_unaligned);

        apd_data^.pseudo_entry_definition^.attributes.address := apd_data^.intercept_proc_bsp;
        apd_binding_section_address_2.offset := apd_binding_section_address_2.offset + 18;
        apd_data^.pseudo_reference_details^.address := apd_binding_section_address_2;
        lop$store_linkage (apd_data^.pseudo_reference_details, apd_data^.pseudo_entry_definition,
              binding_section_overwrite, declaration_mismatch, address_value_unaligned);

        apd_data^.pseudo_entry_definition^.attributes.address.ring := 0;
        IF transfer_symbol_definition^.attributes.block_id.local THEN
          apd_data^.pseudo_entry_definition^.attributes.address.segment := 1;
        ELSE
          apd_data^.pseudo_entry_definition^.attributes.address.segment := 0;
        IFEND;
        apd_data^.pseudo_entry_definition^.attributes.address.offset :=
              transfer_symbol_definition^.attributes.block_id.block_number;
        apd_binding_section_address_2.offset := apd_binding_section_address_2.offset + 8;
        apd_data^.pseudo_reference_details^.address := apd_binding_section_address_2;
        lop$store_linkage (apd_data^.pseudo_reference_details, apd_data^.pseudo_entry_definition,
              binding_section_overwrite, declaration_mismatch, address_value_unaligned);

        apd_data^.pseudo_entry_definition^.attributes.address :=
              apd_data^.apd_descriptor.apd_descriptor_address;
        apd_binding_section_address_2.offset := apd_binding_section_address_2.offset + 8;
        apd_data^.pseudo_reference_details^.address := apd_binding_section_address_2;
        lop$store_linkage (apd_data^.pseudo_reference_details, apd_data^.pseudo_entry_definition,
              binding_section_overwrite, declaration_mismatch, address_value_unaligned);
      IFEND;
    IFEND;

  PROCEND lop$gen_init_intercept_linkage;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$get_loader_seq_descriptor', EJECT ??

  PROCEDURE [XDCL] lop$get_loader_seq_descriptor
    (VAR loader_seq_descriptor_p: ^pmt$loader_seq_descriptor);

    IF (apd_data <> NIL) AND apd_data^.apd_files_opened THEN
      loader_seq_descriptor_p := apd_data^.loader_seq_descriptor;
    ELSE
      loader_seq_descriptor_p := NIL;
    IFEND;

  PROCEND lop$get_loader_seq_descriptor;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL] lop$store_intercept_linkage' ??
?? EJECT ??

  PROCEDURE [XDCL] lop$store_intercept_linkage
    (    reference_details: lot$reference_details;
         remote_block_name: pmt$program_name;
     VAR entry_definition: lot$entry_definition;
     VAR binding_section_overwrite: boolean;
     VAR declaration_mismatch: boolean;
     VAR address_value_unaligned: boolean);


    VAR
      apd_binding_section_address: lot$address;


    IF (NOT entry_definition.attributes.in_target_text) AND
          (NOT entry_definition.attributes.instrumented) THEN
      lop$add_remote_block_id (remote_block_name, entry_definition.attributes.block_id);
    IFEND;

    IF entry_definition.attributes.instrumented THEN
      apd_data^.intercept_proc_entry_definition^.attributes.binding_section_address :=
            entry_definition.attributes.instrumented_callee_address;
    ELSE
      lop$reserve_storage (apd_binding_segment_attributes, 8, 0, FALSE, 0, loc$no_shadow_file, 0,
            allocation_length, apd_binding_section_address);
      apd_data^.intercept_proc_entry_definition^.attributes.binding_section_address :=
            apd_binding_section_address;
    IFEND;

    lop$store_linkage (^reference_details, apd_data^.intercept_proc_entry_definition,
          binding_section_overwrite, declaration_mismatch, address_value_unaligned);
    IF binding_section_overwrite OR address_value_unaligned THEN
      RETURN;
    IFEND;

    IF NOT entry_definition.attributes.instrumented THEN
      apd_data^.intercept_reference_details^.address := apd_binding_section_address;
      apd_data^.intercept_reference_details^.declaration_matching_required :=
            reference_details.declaration_matching_required;
      apd_data^.intercept_reference_details^.declaration_matching := reference_details.declaration_matching;
      apd_data^.intercept_reference_details^.language := reference_details.language;
      lop$store_linkage (apd_data^.intercept_reference_details, ^entry_definition, binding_section_overwrite,
            declaration_mismatch, address_value_unaligned);

      entry_definition.attributes.instrumented := TRUE;
      entry_definition.attributes.instrumented_callee_address := apd_binding_section_address;

      apd_data^.pseudo_entry_definition^.attributes.address := apd_data^.intercept_proc_bsp;
      apd_binding_section_address.offset := apd_binding_section_address.offset + 18;
      apd_data^.pseudo_reference_details^.address := apd_binding_section_address;
      lop$store_linkage (apd_data^.pseudo_reference_details, apd_data^.pseudo_entry_definition,
            binding_section_overwrite, declaration_mismatch, address_value_unaligned);

      apd_data^.pseudo_entry_definition^.attributes.address.ring := 0;
      IF entry_definition.attributes.block_id.local THEN
        apd_data^.pseudo_entry_definition^.attributes.address.segment := 1;
      ELSE
        apd_data^.pseudo_entry_definition^.attributes.address.segment := 0;
      IFEND;
      apd_data^.pseudo_entry_definition^.attributes.address.offset :=
            entry_definition.attributes.block_id.block_number;
      apd_binding_section_address.offset := apd_binding_section_address.offset + 8;
      apd_data^.pseudo_reference_details^.address := apd_binding_section_address;
      lop$store_linkage (apd_data^.pseudo_reference_details, apd_data^.pseudo_entry_definition,
            binding_section_overwrite, declaration_mismatch, address_value_unaligned);

      apd_data^.pseudo_entry_definition^.attributes.address :=
            apd_data^.apd_descriptor.apd_descriptor_address;
      apd_binding_section_address.offset := apd_binding_section_address.offset + 8;
      apd_data^.pseudo_reference_details^.address := apd_binding_section_address;
      lop$store_linkage (apd_data^.pseudo_reference_details, apd_data^.pseudo_entry_definition,
            binding_section_overwrite, declaration_mismatch, address_value_unaligned);
    IFEND;

  PROCEND lop$store_intercept_linkage;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL] lop$add_local_block_id' ??
?? EJECT ??

  PROCEDURE [XDCL] lop$add_local_block_id
    (    module_name: pmt$program_name;
         section_ordinal: llt$section_ordinal;
         procedure_name: pmt$program_name;
     VAR block_number: pmt$block_identifier);

    VAR
      abort_status: ^ost$status;


    apd_data^.loader_seq_descriptor^.local_block_id := apd_data^.loader_seq_descriptor^.local_block_id + 1;
    block_number.local := TRUE;

    IF apd_data^.loader_seq_descriptor^.block_name_map_exists THEN
      IF apd_data^.loader_seq_descriptor^.local_block_id <=
            UPPERBOUND (apd_data^.loader_seq_descriptor^.local_block_name_map^) THEN
        IF (apd_data^.loader_seq_descriptor^.local_block_name_map^
              [apd_data^.loader_seq_descriptor^.local_block_id].module_name = module_name) AND
              (apd_data^.loader_seq_descriptor^.local_block_name_map^
              [apd_data^.loader_seq_descriptor^.local_block_id].section_ordinal = section_ordinal) THEN
          block_number.block_number := apd_data^.loader_seq_descriptor^.local_block_id;
          RETURN;
        IFEND;
      IFEND;
      lop$report_error (lle$bad_local_block_name, procedure_name, '', 0);
      PUSH abort_status;
      pmp$cause_condition (loe$abort_load, NIL, abort_status^);
      pmp$exit (abort_status^);
    ELSE
      RESET apd_data^.loader_seq_descriptor^.seq_ptr TO apd_data^.loader_seq_descriptor^.local_block_name_map;

      NEXT apd_data^.loader_seq_descriptor^.local_block_name_map:
            [0 .. apd_data^.loader_seq_descriptor^.local_block_id] IN
            apd_data^.loader_seq_descriptor^.seq_ptr;
      IF apd_data^.loader_seq_descriptor^.local_block_name_map = NIL THEN
        lop$report_error (lle$eof_encountered_on_apd_file, apd_data^.loader_seq_file_name^, '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$abort_load, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;

      apd_data^.loader_seq_descriptor^.local_block_name_map^
            [apd_data^.loader_seq_descriptor^.local_block_id].procedure_name := procedure_name;
      apd_data^.loader_seq_descriptor^.local_block_name_map^
            [apd_data^.loader_seq_descriptor^.local_block_id].module_name := module_name;
      apd_data^.loader_seq_descriptor^.local_block_name_map^
            [apd_data^.loader_seq_descriptor^.local_block_id].section_ordinal := section_ordinal;
      block_number.block_number := apd_data^.loader_seq_descriptor^.local_block_id;
    IFEND;

  PROCEND lop$add_local_block_id;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL] lop$add_remote_block_id' ??
?? NEWTITLE := '    get_remote_block_name_map_entry' ??
?? EJECT ??

  PROCEDURE lop$add_remote_block_id
    (    procedure_name: pmt$program_name;
     VAR block_number: pmt$block_identifier);

    VAR
      local_block_name_map_copy: ^array [ * ] of pmt$block_name_map_entry,
      abort_status: ^ost$status;


    apd_data^.loader_seq_descriptor^.remote_block_id := apd_data^.loader_seq_descriptor^.remote_block_id + 1;
    block_number.local := FALSE;

    IF apd_data^.loader_seq_descriptor^.block_name_map_exists THEN
      IF apd_data^.loader_seq_descriptor^.remote_block_id <=
            UPPERBOUND (apd_data^.loader_seq_descriptor^.remote_block_name_map^) THEN
        IF (apd_data^.loader_seq_descriptor^.remote_block_name_map^
              [apd_data^.loader_seq_descriptor^.remote_block_id].procedure_name = procedure_name) THEN
          block_number.block_number := apd_data^.loader_seq_descriptor^.remote_block_id;
          RETURN;
        IFEND;
      IFEND;
      lop$report_error (lle$bad_remote_block_name, procedure_name, '', 0);
      PUSH abort_status;
      pmp$cause_condition (loe$abort_load, NIL, abort_status^);
      pmp$exit (abort_status^);
    ELSE
      PUSH local_block_name_map_copy: [0 .. apd_data^.loader_seq_descriptor^.local_block_id];
      local_block_name_map_copy^ := apd_data^.loader_seq_descriptor^.local_block_name_map^;
      RESET apd_data^.loader_seq_descriptor^.seq_ptr TO apd_data^.loader_seq_descriptor^.
            remote_block_name_map;

      NEXT apd_data^.loader_seq_descriptor^.remote_block_name_map:
            [0 .. apd_data^.loader_seq_descriptor^.remote_block_id] IN
            apd_data^.loader_seq_descriptor^.seq_ptr;
      IF apd_data^.loader_seq_descriptor^.remote_block_name_map = NIL THEN
        lop$report_error (lle$eof_encountered_on_apd_file, apd_data^.loader_seq_file_name^, '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$abort_load, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;

      IF apd_data^.loader_seq_descriptor^.local_block_name_map <> NIL THEN
        NEXT apd_data^.loader_seq_descriptor^.local_block_name_map:
              [0 .. apd_data^.loader_seq_descriptor^.local_block_id] IN
              apd_data^.loader_seq_descriptor^.seq_ptr;
        IF apd_data^.loader_seq_descriptor^.local_block_name_map = NIL THEN
          lop$report_error (lle$eof_encountered_on_apd_file, apd_data^.loader_seq_file_name^, '', 0);
          PUSH abort_status;
          pmp$cause_condition (loe$abort_load, NIL, abort_status^);
          pmp$exit (abort_status^);
        ELSE
          apd_data^.loader_seq_descriptor^.local_block_name_map^ := local_block_name_map_copy^;
        IFEND;
      IFEND;
      apd_data^.loader_seq_descriptor^.remote_block_name_map^
            [apd_data^.loader_seq_descriptor^.remote_block_id].module_name := mpe_remote_module_name;
      apd_data^.loader_seq_descriptor^.remote_block_name_map^
            [apd_data^.loader_seq_descriptor^.remote_block_id].procedure_name := procedure_name;
      block_number.block_number := apd_data^.loader_seq_descriptor^.remote_block_id;
    IFEND;

  PROCEND lop$add_remote_block_id;

MODEND lom$analyze_program_dynamics;
*DECK DECK=LOM$CROSS_REFERENCE_MANAGEMENT EXPAND=TRUE
?? RIGHT := 110 ??
*copyc OSD$DEFAULT_PRAGMATS
?? TITLE := 'NOS/VE : Loader : Cross reference information management' ??
?? NEWTITLE := '  Global declarations', EJECT ??
MODULE lom$cross_reference_management;

{  PURPOSE:
{    This module contains procedures responsible for storing and retrieving information used in generation
{    of the entry point cross reference portion of the load map.

{  NOTE:
{    Conditions raised: LOE$ABORT_LOAD, LOE$INSUFFICIENT_MEMORY, LOE$LOADER_MALFUNCTION.
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
*copyc LOE$ABORT_LOAD
?? POP ??
*copyc MMP$CREATE_SEGMENT
*copyc MMP$DELETE_SEGMENT
*copyc LOP$PROCESS_ALL_ENTRY_DEFINITNS
*copyc PMP$CAUSE_CONDITION
*copyc PMP$EXIT
*copyc LOP$REPORT_ERROR
*copyc LOP$GENERATE_LOAD_MAP_TEXT
*copyc LOV$SECONDARY_STATUS

  VAR
    cross_reference_container: [STATIC] ^SEQ ( * ) := NIL;

?? TITLE := '  [XDCL] lop$record_cross_reference', EJECT ??

  PROCEDURE [XDCL] lop$record_cross_reference (referencing_module: pmt$program_name;
    VAR entry_definition {input_output} : lot$entry_definition);

{  PURPOSE:
{    This procedure records detected references to an entry point by adding an element to the list
{    of cross references threaded off the entry definition.

    VAR
      segment_pointer: mmt$segment_pointer,
      cross_reference: ^lot$cross_reference,
      abort_status: ^ost$status;

    IF cross_reference_container = NIL THEN
      mmp$create_segment (NIL, mmc$sequence_pointer, loc$loader_ring, segment_pointer, lov$secondary_status);
      IF NOT lov$secondary_status.normal THEN
        lop$report_error (lle$unable_to_create_table, 'CROSS REFERENCES', '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$abort_load, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
      cross_reference_container := segment_pointer.seq_pointer;
    IFEND;
    NEXT cross_reference IN cross_reference_container;
    IF cross_reference <> NIL THEN
      cross_reference^.nnext := entry_definition.xref_list;
      entry_definition.xref_list := cross_reference;
      entry_definition.xref_listed := FALSE;
      entry_definition.xref_list^.mmodule := referencing_module;
    ELSE
      lop$report_error (lle$loader_table_overflow, 'CROSS REFERENCES', '', 0);
      PUSH abort_status;
      pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
      pmp$exit (abort_status^);
    IFEND;
  PROCEND lop$record_cross_reference;
?? TITLE := '  [XDCL] lop$generate_cross_refernce_map', EJECT ??

  PROCEDURE [XDCL] lop$generate_cross_refernce_map;

{  PURPOSE:
{    This procedure directs generation of the cross reference portion of the load map.  For each
{    entry point defined during a program load, all modules which reference the entry point are
{    itemized.

    VAR
      segment_pointer: mmt$segment_pointer,
      load_map_data1: lot$load_map_data,
      abort_status: ^ost$status;

    ?? NEWTITLE := '    itemize_references', EJECT ??

    PROCEDURE itemize_references (entry_point_name: pmt$program_name;
          definitions_list_head: ^^lot$entry_definition);

{  PURPOSE:
{    This procedure directs generation of load map text which itemizes all modules which made reference
{    to a unique entry point name.
{  NOTE:
{    There may be multiple definitions for a single entry point name (if the definitions
{    correspond to different protection environments).  This procedure causes generation of
{    a seperate itemization for each definition.

      VAR
        definition: ^lot$entry_definition,
        load_map_data: lot$load_map_data,
        cross_reference: ^lot$cross_reference;

      definition := definitions_list_head^;
      WHILE definition <> NIL DO
        IF NOT definition^.xref_listed THEN
          load_map_data.code := loc$lm_xref_detail;
          load_map_data.entry_name := entry_point_name;
          load_map_data.loaded_ring_for_xref := definition^.attributes.loaded_ring;
          load_map_data.entry_address := definition^.attributes.address;
          IF definition^.attributes.gated THEN
            load_map_data.entry_attribute := 'GATED';
          ELSE
            load_map_data.entry_attribute := '';
          IFEND;
          load_map_data.defining_module := definition^.defining_module;
          lop$generate_load_map_text (load_map_data);
          load_map_data.code := loc$lm_accumulate_names;
          cross_reference := definition^.xref_list;
          WHILE cross_reference <> NIL DO
            load_map_data.name := cross_reference^.mmodule;
            lop$generate_load_map_text (load_map_data);
            cross_reference := cross_reference^.nnext;
          WHILEND;
          load_map_data.code := loc$lm_flush_accumulated_names;
          lop$generate_load_map_text (load_map_data);
          definition^.xref_list := NIL;
          definition^.xref_listed := TRUE;
        IFEND;
        definition := definition^.nnext;
      WHILEND;
    PROCEND itemize_references;
?? OLDTITLE, EJECT ??
    IF cross_reference_container <> NIL THEN
      load_map_data1.code := loc$lm_xref_header_init;
      lop$generate_load_map_text (load_map_data1);
      lop$process_all_entry_definitns (^itemize_references);
      segment_pointer.kind := mmc$sequence_pointer;
      segment_pointer.seq_pointer := cross_reference_container;
      cross_reference_container := NIL;
      mmp$delete_segment (segment_pointer, loc$loader_ring, lov$secondary_status);
      IF NOT lov$secondary_status.normal THEN
        PUSH abort_status;
        pmp$cause_condition (loe$loader_malfunction, ^lov$secondary_status, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
    ELSE
      lop$report_error (lle$no_xrefs_to_report, '', '', 0);
    IFEND;

  PROCEND lop$generate_cross_refernce_map;
MODEND lom$cross_reference_management;
*DECK DECK=LOM$DYNAMIC_TABLE_MANAGEMENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Loader : Dynamic table management' ??
MODULE lom$dynamic_table_management;

{ PURPOSE:
{   This module contains procedures which increase the size of one of four dynamic tables which
{   coexist in a single segment.  Knowledge of the interaction of these tables (as they grow)
{   is localized in this module.
{
{ NOTES:
{   Conditions raised: LOE$ABORT_LOAD, LOE$INSUFFICIENT_MEMORY, LOE$LOADER_MALFUNCTION.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc lle$loader_status_conditions
*copyc llt$deferred_common_blocks
*copyc loe$abort_load
*copyc lot$library_list
*copyc lot$loaded_entry_point_list
*copyc lot$loader_type_definitions
*copyc oss$job_paged_literal
*copyc oss$task_private
?? POP ??
*copyc lop$report_error
*copyc mmp$create_segment
*copyc osp$set_status_abnormal
*copyc pmp$cause_condition
*copyc pmp$exit
*copyc lov$secondary_status
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    dynamic_tables_container: [STATIC] ^SEQ ( * ) := NIL,
    lov$allocated_segments: [XDCL, #GATE] ^array [ * ] of lot$segment_allocation := NIL,
    lov$common_blocks: [XDCL] ^array [ * ] of lot$common_block_definition := NIL,
    lov$dynamic_loaded_entry_points: [XDCL, oss$task_private] ^lot$loaded_entry_point_list := NIL,

{!  Temporary until PSR CILA170 is answered.

    lov$library_list: [XDCL] lot$library_list := [NIL, NIL, NIL];

{!  lov$library_list: [XDCL] lot$library_list := [NIL, ^lov$library_list.first, NIL];

  VAR
    ring_attributes: [oss$job_paged_literal, READ] array [1 .. 1] of mmt$attribute_descriptor :=
          [[mmc$kw_ring_numbers, loc$loader_ring, osc$user_ring_2]];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$augment_lib_list_container', EJECT ??

  PROCEDURE [XDCL] lop$augment_lib_list_container;

    CONST
      container_size_increment = 4;

    VAR
      abort_status: ^ost$status,
      allocated_segments_copy: ^array [ * ] of lot$segment_allocation,
      common_blocks_copy: ^array [ * ] of lot$common_block_definition,
      dynamic_loaded_ep_copy: ^lot$loaded_entry_point_list,
      existing_libraries: ^SEQ ( * ),
      library: ^lot$library_descriptor,
      nil_pointer: boolean,
      number_of_libraries: pmt$number_of_libraries,
      segment_pointer: mmt$segment_pointer;

  /normal_sequence/
    BEGIN
      IF dynamic_tables_container = NIL THEN
        mmp$create_segment (^ring_attributes, mmc$sequence_pointer, loc$loader_ring, segment_pointer,
              lov$secondary_status);
        IF NOT lov$secondary_status.normal THEN
          lop$report_error (lle$unable_to_create_table, 'DYNAMIC TABLES', '', 0);
          PUSH abort_status;
          pmp$cause_condition (loe$abort_load, NIL, abort_status^);
          pmp$exit (abort_status^);
        IFEND;
        dynamic_tables_container := segment_pointer.seq_pointer;
      ELSE
        IF lov$dynamic_loaded_entry_points <> NIL THEN
          save_dynamic_loaded_eps (dynamic_loaded_ep_copy);
        IFEND;
        IF lov$common_blocks <> NIL THEN
          PUSH common_blocks_copy: [1 .. UPPERBOUND (lov$common_blocks^)];
          common_blocks_copy^ := lov$common_blocks^;
        IFEND;
        IF lov$allocated_segments <> NIL THEN
          PUSH allocated_segments_copy: [1 .. UPPERBOUND (lov$allocated_segments^)];
          allocated_segments_copy^ := lov$allocated_segments^;
        IFEND;
      IFEND;
      number_of_libraries := 0;
      library := lov$library_list.first;
      WHILE library <> NIL DO
        number_of_libraries := number_of_libraries + 1;
        library := library^.nnext;
      WHILEND;
      RESET dynamic_tables_container;
      NEXT lov$library_list.container: [[REP (number_of_libraries + container_size_increment) OF
            lot$library_descriptor]] IN dynamic_tables_container;
      IF lov$library_list.container = NIL THEN
        EXIT /normal_sequence/
      IFEND;
      RESET lov$library_list.container;
      IF number_of_libraries <> 0 THEN

{ Position new library_list container after existing library descriptors.

        NEXT existing_libraries: [[REP number_of_libraries OF lot$library_descriptor]] IN
              lov$library_list.container;
      IFEND;
      IF lov$allocated_segments <> NIL THEN
        NEXT lov$allocated_segments: [1 .. UPPERBOUND (allocated_segments_copy^)] IN dynamic_tables_container;
        IF lov$allocated_segments = NIL THEN
          EXIT /normal_sequence/
        IFEND;
        lov$allocated_segments^ := allocated_segments_copy^;
      IFEND;
      IF lov$common_blocks <> NIL THEN
        NEXT lov$common_blocks: [1 .. UPPERBOUND (common_blocks_copy^)] IN dynamic_tables_container;
        IF lov$common_blocks = NIL THEN
          EXIT /normal_sequence/
        IFEND;
        lov$common_blocks^ := common_blocks_copy^;
      IFEND;
      IF lov$dynamic_loaded_entry_points <> NIL THEN
        restore_dynamic_loaded_eps (dynamic_loaded_ep_copy, nil_pointer);
        IF nil_pointer THEN
          EXIT /normal_sequence/;
        IFEND;
      IFEND;
      RETURN
    END /normal_sequence/;
    lop$report_error (lle$loader_table_overflow, 'DYNAMIC TABLES', '', 0);
    PUSH abort_status;
    pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
    pmp$exit (abort_status^);
  PROCEND lop$augment_lib_list_container;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$augment_allocated_segments', EJECT ??

  PROCEDURE [XDCL] lop$augment_allocated_segments;

    CONST
      allocated_segments_size_incr = 5;

    VAR
      abort_status: ^ost$status,
      allocated_segments_size: lot$allocated_segments_index,
      common_blocks_copy: ^array [ * ] of lot$common_block_definition,
      dynamic_loaded_ep_copy: ^lot$loaded_entry_point_list,
      nil_pointer: boolean,
      segment_pointer: mmt$segment_pointer;

    IF dynamic_tables_container = NIL THEN
      mmp$create_segment (^ring_attributes, mmc$sequence_pointer, loc$loader_ring, segment_pointer,
            lov$secondary_status);
      IF NOT lov$secondary_status.normal THEN
        lop$report_error (lle$unable_to_create_table, 'DYNAMIC TABLES', '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$abort_load, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
      dynamic_tables_container := segment_pointer.seq_pointer;
    ELSE
      IF lov$dynamic_loaded_entry_points <> NIL THEN
        save_dynamic_loaded_eps (dynamic_loaded_ep_copy);
        RESET dynamic_tables_container TO lov$dynamic_loaded_entry_points;
      IFEND;
      IF lov$common_blocks <> NIL THEN
        PUSH common_blocks_copy: [1 .. UPPERBOUND (lov$common_blocks^)];
        common_blocks_copy^ := lov$common_blocks^;
        RESET dynamic_tables_container TO lov$common_blocks;
      IFEND;
      IF lov$allocated_segments <> NIL THEN
        RESET dynamic_tables_container TO lov$allocated_segments;
      IFEND;
    IFEND;
    IF lov$allocated_segments = NIL THEN
      allocated_segments_size := allocated_segments_size_incr;
    ELSE
      allocated_segments_size := allocated_segments_size_incr + UPPERBOUND (lov$allocated_segments^);
    IFEND;
    NEXT lov$allocated_segments: [1 .. allocated_segments_size] IN dynamic_tables_container;
    IF lov$allocated_segments = NIL THEN
      lop$report_error (lle$loader_table_overflow, 'DYNAMIC TABLES', '', 0);
      PUSH abort_status;
      pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
      pmp$exit (abort_status^);
    IFEND;
    IF lov$common_blocks <> NIL THEN
      NEXT lov$common_blocks: [1 .. UPPERBOUND (common_blocks_copy^)] IN dynamic_tables_container;
      IF lov$common_blocks = NIL THEN
        lop$report_error (lle$loader_table_overflow, 'DYNAMIC TABLES', '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
        pmp$exit (abort_status^);
      ELSE
        lov$common_blocks^ := common_blocks_copy^;
      IFEND;
    IFEND;
    IF lov$dynamic_loaded_entry_points <> NIL THEN
      restore_dynamic_loaded_eps (dynamic_loaded_ep_copy, nil_pointer);
      IF nil_pointer THEN
        lop$report_error (lle$loader_table_overflow, 'DYNAMIC TABLES', '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
    IFEND;
  PROCEND lop$augment_allocated_segments;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$augment_dynamic_loaded_eps', EJECT ??

  PROCEDURE [XDCL] lop$augment_dynamic_loaded_eps;

    CONST
      dynamic_loaded_ep_increment = 50;

    VAR
      abort_status: ^ost$status,
      dynamic_loaded_ep_size: ost$non_negative_integers,
      segment_pointer: mmt$segment_pointer;

    IF dynamic_tables_container = NIL THEN
      mmp$create_segment (^ring_attributes, mmc$sequence_pointer, loc$loader_ring, segment_pointer,
            lov$secondary_status);
      IF NOT lov$secondary_status.normal THEN
        lop$report_error (lle$unable_to_create_table, 'DYNAMIC TABLES', '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$abort_load, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
      dynamic_tables_container := segment_pointer.seq_pointer;
    ELSE
      IF lov$dynamic_loaded_entry_points <> NIL THEN
        RESET dynamic_tables_container TO lov$dynamic_loaded_entry_points^.container;
      IFEND;
    IFEND;
    IF lov$dynamic_loaded_entry_points = NIL THEN
      NEXT lov$dynamic_loaded_entry_points IN dynamic_tables_container;
      IF lov$dynamic_loaded_entry_points = NIL THEN
        lop$report_error (lle$loader_table_overflow, 'DYNAMIC TABLES', '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
      lov$dynamic_loaded_entry_points^.number_of_entry_points := 0;
      lov$dynamic_loaded_entry_points^.container := NIL;
    IFEND;

    dynamic_loaded_ep_size := dynamic_loaded_ep_increment;
    IF lov$dynamic_loaded_entry_points^.container <> NIL THEN
      dynamic_loaded_ep_size := dynamic_loaded_ep_size + UPPERBOUND (lov$dynamic_loaded_entry_points^.
            container^);
    IFEND;
    NEXT lov$dynamic_loaded_entry_points^.container: [1 .. dynamic_loaded_ep_size] IN
          dynamic_tables_container;
    IF lov$dynamic_loaded_entry_points^.container = NIL THEN
      lop$report_error (lle$loader_table_overflow, 'DYNAMIC TABLES', '', 0);
      PUSH abort_status;
      pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
      pmp$exit (abort_status^);
    IFEND;
  PROCEND lop$augment_dynamic_loaded_eps;
?? OLDTITLE ??
?? NEWTITLE := 'check_for_duplicate_commmon_blks', EJECT ??

{ PURPOSE:
{   The purpose of this request is to determine if a deferred common block
{   is already defined and if so to report an error to the load map.

  PROCEDURE check_for_duplicate_common_blks
    (    deferred_common_blocks: ^llt$deferred_common_blocks;
     VAR previously_defined: {input - output} array [1 .. * ] of boolean;
     VAR number_to_be_added: {input - output} lot$common_blocks_index);

    VAR
      abort_status: ^ost$status,
      containing_segment: lot$allocated_segments_index,
      current_last: lot$common_blocks_index,
      i: lot$common_blocks_index,
      j: lot$common_blocks_index,
      malfunction_status: ^ost$status,
      new_last: lot$common_blocks_index;


    new_last := UPPERBOUND (deferred_common_blocks^);
    current_last := UPPERBOUND (lov$common_blocks^);
    FOR i := 1 TO new_last DO
      FOR j := 1 TO current_last DO
        IF (lov$common_blocks^ [j].name = deferred_common_blocks^ [i].name) AND
              (lov$common_blocks^ [j].loaded_ring = deferred_common_blocks^ [i].loaded_ring) AND
              (lov$common_blocks^ [j].global_lock = deferred_common_blocks^ [i].global_lock) THEN
          previously_defined [i] := TRUE;
          number_to_be_added := number_to_be_added - 1;
          lop$report_error (lle$duplicate_common_block, deferred_common_blocks^ [i].name, '', 0);

{ If all possible duplicate definitions have been found, return.

          IF (current_last = (new_last - number_to_be_added)) THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    FOREND;

  PROCEND check_for_duplicate_common_blks;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$add_deferred_common_blocks', EJECT ??

{ PURPOSE:
{   The purpose of this request is to add the deferred common block
{   definitions to the dynamic common block table.

  PROCEDURE [XDCL] lop$add_deferred_common_blocks
    (    deferred_common_blocks: ^llt$deferred_common_blocks);

    VAR
      abort_status: ^ost$status,
      dynamic_loaded_ep_copy: ^lot$loaded_entry_point_list,
      i: lot$common_blocks_index,
      new_index: lot$common_blocks_index,
      nil_pointer: boolean,
      number_to_be_added: lot$common_blocks_index,
      previously_defined: ^array [1 .. * ] of boolean,
      segment_pointer: mmt$segment_pointer,
      size: lot$common_blocks_index;


    IF dynamic_tables_container = NIL THEN
      mmp$create_segment (^ring_attributes, mmc$sequence_pointer, loc$loader_ring, segment_pointer,
            lov$secondary_status);
      IF NOT lov$secondary_status.normal THEN
        lop$report_error (lle$unable_to_create_table, 'DYNAMIC TABLES', '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$abort_load, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
      dynamic_tables_container := segment_pointer.seq_pointer;
    ELSE
      IF lov$dynamic_loaded_entry_points <> NIL THEN
        save_dynamic_loaded_eps (dynamic_loaded_ep_copy);
        RESET dynamic_tables_container TO lov$dynamic_loaded_entry_points;
      IFEND;
      IF lov$common_blocks <> NIL THEN
        RESET dynamic_tables_container TO lov$common_blocks;
      IFEND;
    IFEND;

    IF lov$common_blocks = NIL THEN
      NEXT lov$common_blocks: [1 .. UPPERBOUND (deferred_common_blocks^)] IN dynamic_tables_container;
      IF lov$common_blocks <> NIL THEN
        FOR i := 1 TO UPPERBOUND (deferred_common_blocks^) DO
          lov$common_blocks^ [i] := deferred_common_blocks^ [i];
        FOREND;
      ELSE
        lop$report_error (lle$loader_table_overflow, 'DYNAMIC TABLES', '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
    ELSE
      size := UPPERBOUND (lov$common_blocks^);
      number_to_be_added := UPPERBOUND (deferred_common_blocks^);

      PUSH previously_defined: [1 .. number_to_be_added];
      FOR i := 1 TO number_to_be_added DO
        previously_defined^ [i] := FALSE;
      FOREND;

      check_for_duplicate_common_blks (deferred_common_blocks, previously_defined^, number_to_be_added);

      NEXT lov$common_blocks: [1 .. size + number_to_be_added] IN dynamic_tables_container;
      IF lov$common_blocks = NIL THEN
        lop$report_error (lle$loader_table_overflow, 'DYNAMIC TABLES', '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;

      new_index := size;

      FOR i := 1 TO UPPERBOUND (deferred_common_blocks^) DO
        IF NOT previously_defined^ [i] THEN
          new_index := new_index + 1;
          lov$common_blocks^ [new_index] := deferred_common_blocks^ [i];
        IFEND;
      FOREND;
    IFEND;

    IF lov$dynamic_loaded_entry_points <> NIL THEN
      restore_dynamic_loaded_eps (dynamic_loaded_ep_copy, nil_pointer);
      IF nil_pointer THEN
        lop$report_error (lle$loader_table_overflow, 'DYNAMIC TABLES', '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
    IFEND;

  PROCEND lop$add_deferred_common_blocks;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$find_common_block_definiton', EJECT ??

{  PURPOSE:
{    This procedure locates the definition of a specified common block if it has already been loaded.
{    If the common block has not been loaded previously, an entry is reserved in the common block
{    definition table.

  PROCEDURE [XDCL] lop$find_common_block_definiton
    (    section_definition: ^llt$section_definition;
         attributes: lot$module_attributes;
     VAR previously_defined {control} : boolean;
     VAR i: lot$common_blocks_index;
     VAR common_block_length: ost$segment_length);

    VAR
      abort_status: ^ost$status,
      current_last: lot$common_blocks_index,
      containing_segment: lot$allocated_segments_index,
      dynamic_loaded_ep_copy: ^lot$loaded_entry_point_list,
      extensible_common_block: boolean,
      malfunction_status: ^ost$status,
      nil_pointer: boolean,
      segment_pointer: mmt$segment_pointer;

    extensible_common_block := section_definition^.kind = llc$extensible_common_block;
    IF lov$common_blocks = NIL THEN
      current_last := 0;
    ELSE
      current_last := UPPERBOUND (lov$common_blocks^);
      FOR i := 1 TO current_last DO
        IF (lov$common_blocks^ [i].name = section_definition^.name) AND
              (lov$common_blocks^ [i].loaded_ring = attributes.loaded_ring) AND
              (lov$common_blocks^ [i].global_lock = attributes.global_key_lock) THEN
          previously_defined := TRUE;
          IF (lov$common_blocks^ [i].extensible = extensible_common_block) AND
                (lov$common_blocks^ [i].allocation_alignment = section_definition^.allocation_alignment) AND
                (lov$common_blocks^ [i].allocation_offset = section_definition^.allocation_offset) AND
                (lov$common_blocks^ [i].access_attributes = section_definition^.access_attributes) THEN
            IF lov$common_blocks^ [i].allocation_length <> section_definition^.length THEN
              IF extensible_common_block THEN
                IF lov$common_blocks^ [i].allocation_length < section_definition^.length THEN
                  lov$common_blocks^ [i].allocation_length := section_definition^.length;

                  IF NOT lov$common_blocks^ [i].unallocated_common THEN

                  /find_containing_segment/
                    BEGIN
                      FOR containing_segment := 1 TO UPPERBOUND (lov$allocated_segments^) DO
                        IF lov$allocated_segments^ [containing_segment].segment =
                              lov$common_blocks^ [i].address.segment THEN
                          EXIT /find_containing_segment/
                        IFEND;
                      FOREND;
                      PUSH malfunction_status;
                      osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'find common block definition',
                            malfunction_status^);
                      PUSH abort_status;
                      pmp$cause_condition (loe$loader_malfunction, malfunction_status, abort_status^);
                      pmp$exit (abort_status^);
                    END /find_containing_segment/;

                    IF lov$common_blocks^ [i].allocation_length <=
                          lov$allocated_segments^ [containing_segment].maximum_length THEN
                      lov$allocated_segments^ [containing_segment].current_length :=
                            lov$common_blocks^ [i].allocation_length;
                    ELSE
                      common_block_length := lov$allocated_segments^ [containing_segment].maximum_length;
                      lov$common_blocks^ [i].allocation_length := common_block_length;

{!  The following error is reported to load map too early.

                      lop$report_error (lle$extensible_common_truncated, '', '', 0);
                    IFEND;
                  IFEND;
                IFEND;
              ELSE
                IF lov$common_blocks^ [i].allocation_length < section_definition^.length THEN

{!  The following error is reported to load map too early.

                  lop$report_error (lle$common_truncated, section_definition^.name, '', 0);
                ELSE

{!  The following error is reported to load map too early.

                  lop$report_error (lle$common_size_mismatch, section_definition^.name, '', 0);
                IFEND;
              IFEND;
            IFEND;
          ELSE

{!  The following error is reported to load map too early.

            lop$report_error (lle$common_attr_mismatch, section_definition^.name, '', 0);
          IFEND;
          RETURN
        IFEND;
      FOREND;
    IFEND;
    previously_defined := FALSE;
    IF dynamic_tables_container = NIL THEN
      mmp$create_segment (^ring_attributes, mmc$sequence_pointer, loc$loader_ring, segment_pointer,
            lov$secondary_status);
      IF NOT lov$secondary_status.normal THEN
        lop$report_error (lle$unable_to_create_table, 'DYNAMIC TABLES', '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$abort_load, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
      dynamic_tables_container := segment_pointer.seq_pointer;
    ELSE
      IF lov$dynamic_loaded_entry_points <> NIL THEN
        save_dynamic_loaded_eps (dynamic_loaded_ep_copy);
        RESET dynamic_tables_container TO lov$dynamic_loaded_entry_points;
      IFEND;
      IF lov$common_blocks <> NIL THEN
        RESET dynamic_tables_container TO lov$common_blocks;
      IFEND;
    IFEND;
    i := current_last + 1;
    NEXT lov$common_blocks: [1 .. i] IN dynamic_tables_container;
    IF lov$common_blocks <> NIL THEN
      lov$common_blocks^ [i].name := section_definition^.name;
      lov$common_blocks^ [i].global_lock := attributes.global_key_lock;
      lov$common_blocks^ [i].loaded_ring := attributes.loaded_ring;
      lov$common_blocks^ [i].allocation_length := section_definition^.length;
      lov$common_blocks^ [i].allocation_alignment := section_definition^.allocation_alignment;
      lov$common_blocks^ [i].allocation_offset := section_definition^.allocation_offset;
      lov$common_blocks^ [i].access_attributes := section_definition^.access_attributes;
      lov$common_blocks^ [i].extensible := extensible_common_block;
    ELSE
      lop$report_error (lle$loader_table_overflow, 'DYNAMIC TABLES', '', 0);
      PUSH abort_status;
      pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
      pmp$exit (abort_status^);
    IFEND;

    IF lov$dynamic_loaded_entry_points <> NIL THEN
      restore_dynamic_loaded_eps (dynamic_loaded_ep_copy, nil_pointer);
      IF nil_pointer THEN
        lop$report_error (lle$loader_table_overflow, 'DYNAMIC TABLES', '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
    IFEND;

  PROCEND lop$find_common_block_definiton;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] restore_dynamic_loaded_eps', EJECT ??

{ PURPOSE:
{   The purpose of this request is restore the saved copy of the dynamically
{   loaded entry points.

  PROCEDURE [INLINE] restore_dynamic_loaded_eps
    (    dynamic_loaded_ep_copy: ^lot$loaded_entry_point_list;
     VAR nil_pointer: boolean);


    NEXT lov$dynamic_loaded_entry_points IN dynamic_tables_container;
    nil_pointer := (lov$dynamic_loaded_entry_points = NIL);
    IF NOT nil_pointer THEN
      NEXT lov$dynamic_loaded_entry_points^.container: [1 .. UPPERBOUND (dynamic_loaded_ep_copy^.
            container^)] IN dynamic_tables_container;
      nil_pointer := (lov$dynamic_loaded_entry_points^.container = NIL);
      IF NOT nil_pointer THEN
        lov$dynamic_loaded_entry_points^.number_of_entry_points :=
              dynamic_loaded_ep_copy^.number_of_entry_points;
        lov$dynamic_loaded_entry_points^.container^ := dynamic_loaded_ep_copy^.container^;
      IFEND;
    IFEND;

  PROCEND restore_dynamic_loaded_eps;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] save_dynamic_loaded_eps', EJECT ??

{ PURPOSE:
{   The purpose of this request is save a copy of the dynamically loaded entry
{   points so that they may be restored later.

  PROCEDURE [INLINE] save_dynamic_loaded_eps
    (VAR dynamic_loaded_ep_copy: ^lot$loaded_entry_point_list);

    PUSH dynamic_loaded_ep_copy;
    dynamic_loaded_ep_copy^ := lov$dynamic_loaded_entry_points^;
    PUSH dynamic_loaded_ep_copy^.container: [1 .. UPPERBOUND (lov$dynamic_loaded_entry_points^.container^)];
    dynamic_loaded_ep_copy^.container^ := lov$dynamic_loaded_entry_points^.container^;

  PROCEND save_dynamic_loaded_eps;
?? OLDTITLE ??
MODEND lom$dynamic_table_management;
*DECK DECK=LOM$ENTRY_EXTERNAL_MATCHING EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Loader : Entry/external matching' ??
MODULE lom$entry_external_matching;

{  PURPOSE:
{    This module contains components necessary to match external references to the appropriate entry
{    point definitions.  This matching process consists of comparing protection environment (ring, key/lock)
{    attributes as well as symbolic names.
{  DESIGN:
{    The essential work of this module consists of managing two conceptual lists -- an entry definitions
{    list and an unsatisfied references list.  As 'entry_definition' object text records are received,
{    definitions are added to the entry definitions list and any matching entries in the unsatisfied
{    references list are satisfied.  As 'external_linkage' object text records are received, the
{    entry definitions list is searched for a matching definition.  If one is found, then the external
{    reference is satisfied immediately.  Otherwise an item is added to the unsatisfied references list.
{
{    Each of the two conceptual lists is implemented as a series of sublists.  For each linkage name
{    (entry_point name or external name),  a subordinate procedure maintains pointers to the heads
{    of the entry definitions and unsatisfied references sublists for that linkage name.  For any
{    given object text record, only the sublists of the specified linkage name are processed.
{
{    The actual satisfying of an external reference is not accomplished by this module.  Its purpose
{    is simply to isolate matching pairs of entry definitions and enternal references.  These pairs
{    are then passed on to another module for actual linkage generation.

{  NOTE:
{    Conditions raised: LOE$ABORT_LOAD, LOE$INSUFFICIENT_MEMORY.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cyd$cybil_structure_definitions
*copyc loe$abort_load
*copyc lot$loader_options
*copyc lot$loader_type_definitions
?? POP ??
*copyc dbp$define_entry_point_address
*copyc lop$find_linkage_name_lists
*copyc lop$generate_load_map_text
*copyc lop$record_cross_reference
*copyc lop$report_error
*copyc lop$report_secondary_error
*copyc lop$store_intercept_linkage
*copyc lop$store_linkage
*copyc mmp$create_segment
*copyc mmp$delete_segment
*copyc osp$reset_heap
*copyc pmp$cause_condition
*copyc pmp$exit
*copyc lov$apd_load
*copyc lov$loi$nil
*copyc lov$param_linkage_list
*copyc lov$secondary_status
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  ?VAR
    inline_procs: boolean := TRUE?;

  TYPE
    valid_languages = set of llt$module_generator;

  VAR
    entry_definition_container: ^SEQ ( * ) := NIL,
    excluded_entry_points: array [1 .. 2] of pmt$program_name :=
          ['PFP$FIND_CYCLE_ARRAY_VERSION_2', 'PFP$FIND_CYCLE_ENTRY_VERSION_2'],
    lov$unsatisfied_ref_container: [XDCL] ^HEAP ( * ) := NIL,
    lov$head_of_unsat_ref_list: [XDCL] ^lot$unsatisfied_reference_list := NIL,
    lov$unsatisfied_reference: [XDCL] ^lot$unsatisfied_reference_list := NIL,
    lov$free_unsat_reference: ^lot$unsatisfied_reference := NIL,
    lov$free_unsat_ref_group: ^lot$unsatisfied_reference_group := NIL,
    lov$free_unsat_ref_list: ^lot$unsatisfied_reference_list := NIL;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$define_entry_point', EJECT ??

{  PURPOSE:
{    This procedure processes 'entry_definition' object text records.  The new definition is added
{    to the entry definitions sublist for the specified linkage (entry point) name, unless it is a duplicate
{    definition.  Then the sublist of unsatisfied references for the linkage name is searched to
{    determine if any of the references can be satisfied by the new definition.
{  NOTE:
{    Since all of the unsatisfied references in the sublist being searched are for the same linkage
{    name, the matching process becomes one of comparing protection environments to verify
{    accessibility.  Similarly, testing for duplicate entry points becomes a matter of testing for
{    protection environment overlap.

  PROCEDURE [XDCL] lop$define_entry_point
    (    entry_definition: ^llt$entry_definition;
         module_descriptor: {input} ^lot$module_descriptor;
         allocated_sections: {input} ^lot$allocated_sections;
         control_options: {control} lot$control_options;
         load_file_number: lot$load_file_number;
     VAR duplicate_entry_point: boolean);

?? NEWTITLE := 'add_definition_to_list', EJECT ??

    ?IF inline_procs = TRUE THEN

      PROCEDURE [INLINE] add_definition_to_list
        (    entry_descriptor: {input} ^lot$entry_point_descriptor;
    ?ELSE

      PROCEDURE add_definition_to_list
        (    entry_descriptor: {input} ^lot$entry_point_descriptor;
    ?IFEND
         control_options: {control} lot$control_options;
     VAR entry_definition: ^lot$entry_definition;
     VAR linkage: ^lot$linkage_name_lists;
     VAR duplicate_entry_point: {control} boolean);

    VAR
      segment_pointer: mmt$segment_pointer,
      load_map_data: lot$load_map_data,
      debugger_entry_point_descriptor: dbt$entry_point_table_item,
      abort_status: ^ost$status;

    lop$find_linkage_name_lists (entry_descriptor^.name, linkage);
    entry_definition := linkage^.definitions_list;
    WHILE entry_definition <> NIL DO
      IF ((entry_definition^.attributes.global_lock = entry_descriptor^.attributes.global_lock) OR
            (entry_definition^.attributes.gated AND entry_descriptor^.attributes.gated) OR
            ((entry_definition^.attributes.gated OR entry_descriptor^.attributes.gated) AND
            ((entry_definition^.attributes.global_lock = loc$no_lock) OR
            (entry_descriptor^.attributes.global_lock = loc$no_lock)))) AND
            NOT ((entry_definition^.attributes.loaded_ring > entry_descriptor^.attributes.call_bracket) OR
            (entry_definition^.attributes.call_bracket < entry_descriptor^.attributes.loaded_ring)) THEN
        lop$report_error (lle$duplicate_entry_point, entry_descriptor^.name, '', 0);
        duplicate_entry_point := TRUE;
        RETURN;
      IFEND;
      entry_definition := entry_definition^.nnext;
    WHILEND;
    duplicate_entry_point := FALSE;
    IF entry_definition_container = NIL THEN
      mmp$create_segment (NIL, mmc$sequence_pointer, loc$loader_ring, segment_pointer, lov$secondary_status);
      IF NOT lov$secondary_status.normal THEN
        lop$report_error (lle$unable_to_create_table, 'ENTRY POINT DEFINITIONS', '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$abort_load, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
      entry_definition_container := segment_pointer.seq_pointer;
    IFEND;
    NEXT entry_definition IN entry_definition_container;
    IF entry_definition <> NIL THEN
      entry_definition^.nnext := linkage^.definitions_list;
      linkage^.definitions_list := entry_definition;
      entry_definition^.attributes := entry_descriptor^.attributes;
      entry_definition^.defining_module := entry_descriptor^.defining_module;
      entry_definition^.xref_list := NIL;
      entry_definition^.xref_listed := FALSE;
      IF pmc$entry_point_map IN control_options.map THEN
        load_map_data.code := loc$lm_entry_detail;
        load_map_data.entry_name := entry_descriptor^.name;
        load_map_data.entry_address := entry_definition^.attributes.address;
        IF entry_descriptor^.attributes.gated THEN
          load_map_data.entry_attribute := 'GATED';
        ELSE
          load_map_data.entry_attribute := '';
        IFEND;
        lop$generate_load_map_text (load_map_data);
      IFEND;
      debugger_entry_point_descriptor.name := entry_descriptor^.name;
      debugger_entry_point_descriptor.call_bracket := entry_descriptor^.attributes.call_bracket;
      debugger_entry_point_descriptor.loaded_ring := entry_descriptor^.attributes.loaded_ring;
      debugger_entry_point_descriptor.global_lock := entry_descriptor^.attributes.global_lock;
      debugger_entry_point_descriptor.address.ring := entry_descriptor^.attributes.address.ring;
      debugger_entry_point_descriptor.address.seg := entry_descriptor^.attributes.address.segment;
      debugger_entry_point_descriptor.address.offset := entry_descriptor^.attributes.address.offset;
      dbp$define_entry_point_address (debugger_entry_point_descriptor, lov$secondary_status);
      IF NOT lov$secondary_status.normal THEN
        lov$secondary_status.normal := TRUE;
        lop$report_secondary_error (lov$secondary_status);
      IFEND;
    ELSE
      lop$report_error (lle$loader_table_overflow, 'ENTRY POINT DEFINITIONS', '', 0);
      PUSH abort_status;
      pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
      pmp$exit (abort_status^);
    IFEND;
  PROCEND add_definition_to_list;
?? OLDTITLE ??
?? NEWTITLE := 'satisfy_entry_point_references', EJECT ??

  ?IF inline_procs = TRUE THEN

    PROCEDURE [INLINE] satisfy_entry_point_references
      (    control_options: {control} lot$control_options;
  ?ELSE

    PROCEDURE satisfy_entry_point_references
      (    control_options: {control} lot$control_options;
  ?IFEND
   VAR linkage: ^lot$linkage_name_lists;
   VAR entry_definition: {input, output} lot$entry_definition);

  VAR
    next_group: ^lot$unsatisfied_reference_group,
    current_group: ^^lot$unsatisfied_reference_group,
    current_reference: ^lot$unsatisfied_reference,
    next_reference: ^lot$unsatisfied_reference,
    binding_section_overwrite: boolean,
    declaration_mismatch: boolean,
    entry_point_unaligned: boolean;

  current_group := ^linkage^.unsat_references_list^.references;
  WHILE current_group^ <> NIL DO
    IF ((current_group^^.global_key = entry_definition.attributes.global_lock) OR
          (entry_definition.attributes.gated AND ((entry_definition.attributes.global_lock = loc$no_lock) OR
          (current_group^^.global_key = loc$master_key)))) AND
          ((current_group^^.ring >= entry_definition.attributes.loaded_ring) AND
          (current_group^^.ring <= entry_definition.attributes.call_bracket)) THEN
      current_reference := current_group^^.list;
      WHILE current_reference <> NIL DO
        IF lov$apd_flags.apd_load AND (current_reference^.details.kind = llc$external_proc) AND
              (entry_definition.attributes.in_target_text OR current_reference^.details.in_target_text) AND
              (entry_descriptor.name <> 'CYP$NIL') THEN
          lop$store_intercept_linkage (current_reference^.details, entry_descriptor.name, entry_definition,
                binding_section_overwrite, declaration_mismatch, entry_point_unaligned);
        ELSE
          lop$store_linkage (^current_reference^.details, ^entry_definition, binding_section_overwrite,
                declaration_mismatch, entry_point_unaligned);
        IFEND;
        IF binding_section_overwrite THEN
          lop$report_error (lle$binding_section_overwrite, entry_descriptor.name, current_reference^.mmodule,
                0);
        IFEND;
        IF declaration_mismatch AND (NOT exclude_declaration_mismatch (entry_descriptor.name)) THEN
          IF entry_definition.attributes.source_declaration_matching THEN
            lop$report_error (lle$declaration_mismatch, entry_descriptor.name, current_reference^.mmodule, 0);
          ELSE
            lop$report_error (lle$f_declaration_mismatch, entry_descriptor.name, current_reference^.mmodule,
                  0);
          IFEND;
        IFEND;
        IF entry_point_unaligned THEN
          lop$report_error (lle$entry_point_unaligned, entry_descriptor.name, current_reference^.mmodule, 0);
        IFEND;
        IF pmc$entry_point_xref IN control_options.map THEN
          lop$record_cross_reference (current_reference^.mmodule, entry_definition);
        IFEND;
        next_reference := current_reference^.nnext;
        current_reference^.nnext := lov$free_unsat_reference;
        lov$free_unsat_reference := current_reference;
        current_reference := next_reference;
      WHILEND;
      next_group := current_group^^.nnext;
      current_group^^.nnext := lov$free_unsat_ref_group;
      lov$free_unsat_ref_group := current_group^;
      current_group^ := next_group;
    ELSE
      current_group := ^current_group^^.nnext;
    IFEND;
  WHILEND;

  IF linkage^.unsat_references_list^.references = NIL THEN
    IF lov$unsatisfied_reference = linkage^.unsat_references_list THEN
      lov$unsatisfied_reference := linkage^.unsat_references_list^.b_link;
    IFEND;
    linkage^.unsat_references_list^.b_link^.f_link := linkage^.unsat_references_list^.f_link;
    linkage^.unsat_references_list^.f_link^.b_link := linkage^.unsat_references_list^.b_link;
    linkage^.unsat_references_list^.f_link := lov$free_unsat_ref_list;
    lov$free_unsat_ref_list := linkage^.unsat_references_list;
    linkage^.unsat_references_list := NIL;
  IFEND;
PROCEND satisfy_entry_point_references;
?? OLDTITLE, EJECT ??

VAR
  entry_descriptor: lot$entry_point_descriptor,
  definition: ^lot$entry_definition,
  linkage_info: ^lot$linkage_name_lists,
  i: llt$section_ordinal;

IF entry_definition^.section_ordinal > UPPERBOUND (allocated_sections^) THEN
  lop$report_error (lle$invalid_section_ordinal, 'entry definition record', '', #OFFSET (entry_definition));
ELSEIF allocated_sections^ [entry_definition^.section_ordinal].address = loc$nil THEN
  lop$report_error (lle$undefined_section, 'entry definition record', '', #OFFSET (entry_definition));
ELSEIF entry_definition^.offset >= allocated_sections^ [entry_definition^.section_ordinal].length THEN
  lop$report_error (lle$invalid_section_offset, 'entry definition record', '', #OFFSET (entry_definition));
ELSE
  entry_descriptor.name := entry_definition^.name;
  entry_descriptor.defining_module := module_descriptor^.name;
  entry_descriptor.attributes.global_lock := module_descriptor^.attributes.global_key_lock;
  entry_descriptor.attributes.loaded_ring := module_descriptor^.attributes.loaded_ring;
  entry_descriptor.attributes.binding_section_address :=
        module_descriptor^.attributes.binding_section_address;
  entry_descriptor.attributes.binding_section_address.ring := module_descriptor^.attributes.loaded_ring;
  IF (module_descriptor^.attributes.binding_section_address <> loc$nil) THEN
    entry_descriptor.attributes.binding_section_address.offset :=
          entry_descriptor.attributes.binding_section_address.offset +
          allocated_sections^ [entry_definition^.section_ordinal].binding_section_offset;
  IFEND;
  IF llc$gated_entry_point IN entry_definition^.attributes THEN
    entry_descriptor.attributes.gated := TRUE;
    entry_descriptor.attributes.call_bracket := module_descriptor^.attributes.call_bracket;
  ELSE
    entry_descriptor.attributes.gated := FALSE;
    entry_descriptor.attributes.call_bracket := module_descriptor^.attributes.loaded_ring;
  IFEND;
  entry_descriptor.attributes.vmid := module_descriptor^.attributes.vmid;
  entry_descriptor.attributes.address := allocated_sections^ [entry_definition^.section_ordinal].address;
  entry_descriptor.attributes.address.offset := entry_descriptor.attributes.address.offset +
        entry_definition^.offset;
  entry_descriptor.attributes.address.ring := module_descriptor^.attributes.loaded_ring;
  entry_descriptor.attributes.declaration_matching_required :=
        entry_definition^.declaration_matching_required;
  entry_descriptor.attributes.declaration_matching := entry_definition^.declaration_matching;
  entry_descriptor.attributes.source_declaration_matching :=
        module_descriptor^.attributes.source_declaration_matching;
  IF entry_definition^.language IN -$valid_languages [] THEN
    entry_descriptor.attributes.language := entry_definition^.language;
  ELSE
    entry_descriptor.attributes.language := llc$unknown_generator;
    lop$report_error (lle$unknown_language, 'entry definition record', '', #OFFSET (entry_definition));
  IFEND;
  entry_descriptor.attributes.load_file_number := load_file_number;
  IF lov$apd_flags.apd_load THEN
    IF lov$apd_flags.target_text THEN
      entry_descriptor.attributes.in_target_text := TRUE;
      entry_descriptor.attributes.block_id := allocated_sections^ [entry_definition^.section_ordinal].
            local_block_id;
    ELSE
      entry_descriptor.attributes.in_target_text := FALSE;
    IFEND;
    entry_descriptor.attributes.instrumented := FALSE;
  IFEND;
  add_definition_to_list (^entry_descriptor, control_options, definition, linkage_info,
        duplicate_entry_point);
  IF (NOT duplicate_entry_point) AND (linkage_info^.unsat_references_list <> NIL) THEN
    satisfy_entry_point_references (control_options, linkage_info, definition^);
  IFEND;
IFEND;
PROCEND lop$define_entry_point;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$link_external', EJECT ??

{  PURPOSE:
{    This procedure processes 'external_linkage' object text records.  The entry definitions sublist
{    for the specified linkage (enternal) name is searched to determine if an existing definition
{    satisfies the reference.  If so, the external reference is satisfied immediately.  If not,
{    the reference is added to the unsatisfied references sublist for the specified linkage name.
{  NOTE:
{    Since all of the entry definitions in the sublist being searched are for the same linkage
{    name, the matching process becomes one of comparing protection environments (ring, key/lock)
{    to verify accessibility.  To minimize search time for the unsatisfied references list,
{    unsatisfied references are clustered into 'groups' such that all members of a group will be
{    satisfied by the same entry definition.

PROCEDURE [XDCL] lop$link_external
  (    external_linkage: ^llt$external_linkage;
       allocated_sections: {input} ^lot$allocated_sections;
       module_descriptor: {input} ^lot$module_descriptor;
       control_options: {control} lot$control_options);

  TYPE
    valid_address_kinds = set of llt$address_kind;

  VAR
    reference_descriptor: lot$reference_descriptor,
    external_descriptor: lot$external_descriptor,
    entry_definition: ^lot$entry_definition,
    temp_entry_definition: lot$entry_definition,
    linkage_info: ^lot$linkage_name_lists,
    linkage_size: 0 .. 16,
    i: 1 .. llc$max_ext_items,
    greatest_allocated_section: 0 .. llc$max_section_ordinal,
    entry_point_defined: boolean,
    binding_section_overwrite: boolean,
    declaration_mismatch: boolean,
    entry_point_unaligned: boolean;

  external_descriptor.name := external_linkage^.name;
  external_descriptor.global_key := module_descriptor^.attributes.global_key_lock;
  external_descriptor.reference_ring := module_descriptor^.attributes.loaded_ring;
  lop$find_matching_entry_point (external_descriptor, entry_point_defined, linkage_info, entry_definition);

  IF NOT entry_point_defined THEN
    reference_descriptor.ring := external_descriptor.reference_ring;
    reference_descriptor.global_key := external_descriptor.global_key;
    reference_descriptor.mmodule := module_descriptor^.name;
  IFEND;

  reference_descriptor.details.declaration_matching_required :=
        external_linkage^.declaration_matching_required;
  reference_descriptor.details.declaration_matching := external_linkage^.declaration_matching;
  IF external_linkage^.language IN -$valid_languages [] THEN
    reference_descriptor.details.language := external_linkage^.language;
  ELSE
    reference_descriptor.details.language := llc$unknown_generator;
    lop$report_error (lle$unknown_language, 'external linkage item', '', #OFFSET (external_linkage));
  IFEND;
  reference_descriptor.details.in_target_text := lov$apd_flags.apd_load AND lov$apd_flags.target_text;

  greatest_allocated_section := UPPERBOUND (allocated_sections^);

/link_a_reference/
  FOR i := 1 TO UPPERBOUND (external_linkage^.item) DO
    IF external_linkage^.item [i].section_ordinal > greatest_allocated_section THEN
      lop$report_error (lle$invalid_section_ordinal, 'external linkage item', '',
            #OFFSET (#LOC (external_linkage^.item [i])));
    ELSEIF allocated_sections^ [external_linkage^.item [i].section_ordinal].address = loc$nil THEN
      lop$report_error (lle$undefined_section, 'external linkage item', '',
            #OFFSET (#LOC (external_linkage^.item [i])));
    ELSE
      CASE external_linkage^.item [i].kind OF
      = llc$external_proc =
        linkage_size := 16;
      = llc$internal_proc =
        linkage_size := 8;
      ELSE
        IF NOT (external_linkage^.item [i].kind IN -$valid_address_kinds [llc$short_address]) THEN
          lop$report_error (lle$unknown_address_kind, 'external linkage item', '',
                #OFFSET (#LOC (external_linkage^.item [i])));
          CYCLE /link_a_reference/
        IFEND;
        linkage_size := 6;
      CASEND;
      IF external_linkage^.item [i].offset + linkage_size >
            allocated_sections^ [external_linkage^.item [i].section_ordinal].length THEN
        lop$report_error (lle$invalid_section_offset, 'external linkage item', '',
              #OFFSET (#LOC (external_linkage^.item [i])));
      ELSE
        reference_descriptor.details.address := allocated_sections^
              [external_linkage^.item [i].section_ordinal].address;
        reference_descriptor.details.address.offset := reference_descriptor.details.address.offset +
              external_linkage^.item [i].offset;
        IF (allocated_sections^ [external_linkage^.item [i].section_ordinal].kind = llc$binding_section) THEN
          IF external_linkage^.item [i].kind IN $valid_address_kinds
                [llc$internal_proc, llc$external_proc] THEN
            IF (reference_descriptor.details.address.offset MOD 8 <> 0) THEN
              lop$report_error (lle$improper_linkage_alignment, 'external linkage item', '',
                    #OFFSET (#LOC (external_linkage^.item [i])));
              CYCLE /link_a_reference/
            IFEND;
          ELSE
            IF (reference_descriptor.details.address.offset MOD 8 <> 2) THEN
              lop$report_error (lle$improper_linkage_alignment, 'external linkage item', '',
                    #OFFSET (#LOC (external_linkage^.item [i])));
              CYCLE /link_a_reference/
            IFEND;
          IFEND;
          reference_descriptor.details.binding_section_destination := TRUE;
        ELSE
          IF (allocated_sections^ [external_linkage^.item [i].section_ordinal].kind = llc$code_section) OR
                allocated_sections^ [external_linkage^.item [i].section_ordinal].allotted THEN
            lop$report_error (lle$improper_linkage_item, external_linkage^.name, module_descriptor^.
                  name, #OFFSET (#LOC (external_linkage^.item [i])));
            CYCLE /link_a_reference/;
          IFEND;
          reference_descriptor.details.binding_section_destination := FALSE;
        IFEND;
        reference_descriptor.details.kind := external_linkage^.item [i].kind;
        reference_descriptor.details.offset_operand := external_linkage^.item [i].offset_operand;
        IF entry_point_defined THEN
          IF lov$apd_flags.apd_load AND (entry_definition^.attributes.in_target_text OR
                reference_descriptor.details.in_target_text) AND
                (external_linkage^.item [i].kind = llc$external_proc) AND
                (external_linkage^.name <> 'CYP$NIL') THEN
            lop$store_intercept_linkage (reference_descriptor.details, external_linkage^.name,
                  entry_definition^, binding_section_overwrite, declaration_mismatch, entry_point_unaligned);
          ELSE
            lop$store_linkage (^reference_descriptor.details, entry_definition, binding_section_overwrite,
                  declaration_mismatch, entry_point_unaligned);
          IFEND;
          IF binding_section_overwrite THEN
            lop$report_error (lle$binding_section_overwrite, external_linkage^.name, module_descriptor^.name,
                  0);
          IFEND;
          IF declaration_mismatch AND (NOT exclude_declaration_mismatch (external_linkage^.name)) THEN
            IF entry_definition^.attributes.source_declaration_matching THEN
              lop$report_error (lle$declaration_mismatch, external_linkage^.name, module_descriptor^.name, 0);
            ELSE
              lop$report_error (lle$f_declaration_mismatch, external_linkage^.name, module_descriptor^.name,
                    0);
            IFEND;
          IFEND;
          IF entry_point_unaligned THEN
            lop$report_error (lle$entry_point_unaligned, external_linkage^.name, module_descriptor^.name, 0);
          IFEND;
          IF pmc$entry_point_xref IN control_options.map THEN
            lop$record_cross_reference (module_descriptor^.name, entry_definition^);
          IFEND;
        ELSE
          lop$add_unsatisfied_ref_to_list (reference_descriptor, linkage_info);
        IFEND;
      IFEND;
    IFEND;
  FOREND /link_a_reference/;
PROCEND lop$link_external;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$find_matching_entry_point', EJECT ??

PROCEDURE [XDCL] lop$find_matching_entry_point
  (    external_descriptor: lot$external_descriptor;
   VAR entry_point_defined: {control} boolean;
   VAR linkage: ^lot$linkage_name_lists;
   VAR entry_definition: ^lot$entry_definition);

  VAR
    definition: ^lot$entry_definition;

  lop$find_linkage_name_lists (external_descriptor.name, linkage);
  definition := linkage^.definitions_list;
  WHILE definition <> NIL DO
    IF ((external_descriptor.global_key = definition^.attributes.global_lock) OR
          (definition^.attributes.gated AND ((definition^.attributes.global_lock = loc$no_lock) OR
          (external_descriptor.global_key = loc$master_key)))) AND
          ((external_descriptor.reference_ring >= definition^.attributes.loaded_ring) AND
          (external_descriptor.reference_ring <= definition^.attributes.call_bracket)) THEN
      entry_point_defined := TRUE;
      entry_definition := definition;
      RETURN;
    IFEND;
    definition := definition^.nnext;
  WHILEND;
  entry_point_defined := FALSE;
PROCEND lop$find_matching_entry_point;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$add_unsatisfied_ref_to_list', EJECT ??

PROCEDURE [XDCL] lop$add_unsatisfied_ref_to_list
  (    reference_descriptor: lot$reference_descriptor;
   VAR linkage: ^lot$linkage_name_lists);

  VAR
    destination_group: ^lot$unsatisfied_reference_group,
    new_reference: ^lot$unsatisfied_reference,
    new_unsatisfied_ref: ^lot$unsatisfied_reference_list;


  IF lov$unsatisfied_ref_container = NIL THEN
    lop$create_unsat_ref_segment;
  IFEND;

  IF (lov$free_unsat_reference = NIL) THEN
    allocate_free_unsat_references (lov$free_unsat_reference);
  IFEND;

  new_reference := lov$free_unsat_reference;
  lov$free_unsat_reference := lov$free_unsat_reference^.nnext;

  new_reference^.details := reference_descriptor.details;
  new_reference^.mmodule := reference_descriptor.mmodule;

  IF linkage^.unsat_references_list = NIL THEN
    IF (lov$free_unsat_ref_list = NIL) THEN
      allocate_free_unsat_ref_list (lov$free_unsat_ref_list);
    IFEND;

    new_unsatisfied_ref := lov$free_unsat_ref_list;
    lov$free_unsat_ref_list := lov$free_unsat_ref_list^.f_link;

    linkage^.unsat_references_list := new_unsatisfied_ref;
    new_unsatisfied_ref^.linkage_info := linkage;
    new_unsatisfied_ref^.f_link := lov$head_of_unsat_ref_list;
    new_unsatisfied_ref^.b_link := lov$head_of_unsat_ref_list^.b_link;
    new_unsatisfied_ref^.library_searched := 0;
    lov$head_of_unsat_ref_list^.b_link := new_unsatisfied_ref;
    new_unsatisfied_ref^.b_link^.f_link := new_unsatisfied_ref;
    new_unsatisfied_ref^.references := NIL;
  IFEND;
?? EJECT ??

/find_destination_group/
  BEGIN
    destination_group := linkage^.unsat_references_list^.references;
    WHILE destination_group <> NIL DO
      IF (reference_descriptor.global_key = destination_group^.global_key) AND
            (reference_descriptor.ring = destination_group^.ring) THEN
        EXIT /find_destination_group/
      IFEND;
      destination_group := destination_group^.nnext;
    WHILEND;

    IF (lov$free_unsat_ref_group = NIL) THEN
      allocate_free_unsat_ref_groups (lov$free_unsat_ref_group);
    IFEND;

    destination_group := lov$free_unsat_ref_group;
    lov$free_unsat_ref_group := lov$free_unsat_ref_group^.nnext;

    destination_group^.nnext := linkage^.unsat_references_list^.references;
    linkage^.unsat_references_list^.references := destination_group;
    destination_group^.logically_satisfied := FALSE;
    destination_group^.newly_created := TRUE;
    destination_group^.global_key := reference_descriptor.global_key;
    destination_group^.ring := reference_descriptor.ring;
    destination_group^.list := NIL;
  END /find_destination_group/;

  new_reference^.nnext := destination_group^.list;
  destination_group^.list := new_reference;


PROCEND lop$add_unsatisfied_ref_to_list;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$create_unsat_ref_segment', EJECT ??

PROCEDURE [XDCL] lop$create_unsat_ref_segment;


  VAR
    segment_pointer: mmt$segment_pointer,
    new_unsatisfied_ref: ^lot$unsatisfied_reference_list,
    linkage: ^lot$param_matching_node,
    abort_status: ^ost$status;

  VAR
    converter: record
      case dummy: 1 .. 2 of
      = 1 =
        heap_pointer: ^HEAP ( * ),
      = 2 =
        os_heap_ptr: cyt$adaptable_heap_pointer,
      casend,
    recend;


  mmp$create_segment (NIL, mmc$heap_pointer, loc$loader_ring, segment_pointer, lov$secondary_status);
  IF NOT lov$secondary_status.normal THEN
    lop$report_error (lle$unable_to_create_table, 'UNSATISFIED REFERENCES', '', 0);
    PUSH abort_status;
    pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
    pmp$exit (abort_status^);
  IFEND;

  lov$unsatisfied_ref_container := segment_pointer.heap_pointer;

  converter.heap_pointer := segment_pointer.heap_pointer;
  osp$reset_heap (converter.os_heap_ptr.pva, converter.os_heap_ptr.length, FALSE, 1);

  ALLOCATE lov$head_of_unsat_ref_list IN lov$unsatisfied_ref_container^;
  IF lov$head_of_unsat_ref_list = NIL THEN
    lop$report_error (lle$loader_table_overflow, 'UNSATISFIED REFERENCES', '', 0);
    PUSH abort_status;
    pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
    pmp$exit (abort_status^);
  IFEND;

  lov$head_of_unsat_ref_list^.linkage_info := NIL;
  lov$head_of_unsat_ref_list^.references := NIL;
  lov$head_of_unsat_ref_list^.f_link := lov$head_of_unsat_ref_list;
  lov$head_of_unsat_ref_list^.b_link := lov$head_of_unsat_ref_list;

  lov$free_unsat_reference := NIL;
  lov$free_unsat_ref_group := NIL;
  lov$free_unsat_ref_list := NIL;

  IF lov$param_linkage_list.first <> NIL THEN
    linkage := lov$param_linkage_list.first;
    WHILE linkage <> NIL DO
      linkage^.references := NIL;
      linkage := linkage^.nnext;
    WHILEND;
  IFEND;

PROCEND lop$create_unsat_ref_segment;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$release_unsat_ref_segment', EJECT ??

PROCEDURE [XDCL] lop$release_unsat_ref_segment;


  VAR
    segment_pointer: mmt$segment_pointer,
    abort_status: ^ost$status;

  IF lov$unsatisfied_ref_container <> NIL THEN
    lov$head_of_unsat_ref_list := NIL;
    lov$free_unsat_reference := NIL;
    lov$free_unsat_ref_group := NIL;
    lov$free_unsat_ref_list := NIL;

    segment_pointer.heap_pointer := lov$unsatisfied_ref_container;
    lov$unsatisfied_ref_container := NIL;

    segment_pointer.kind := mmc$heap_pointer;

    mmp$delete_segment (segment_pointer, loc$loader_ring, lov$secondary_status);
    IF NOT lov$secondary_status.normal THEN
      PUSH abort_status;
      pmp$cause_condition (loe$loader_malfunction, ^lov$secondary_status, abort_status^);
      pmp$exit (abort_status^);
    IFEND;

  IFEND;


PROCEND lop$release_unsat_ref_segment;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] allocate_free_unsat_references', EJECT ??

PROCEDURE [INLINE] allocate_free_unsat_references
  (VAR free_unsatisfieds: ^lot$unsatisfied_reference);


  CONST
    allocation_size = 25;

  VAR
    unsat_array: ^array [1 .. allocation_size] of lot$unsatisfied_reference,
    i: integer,
    abort_status: ^ost$status;


  ALLOCATE unsat_array IN lov$unsatisfied_ref_container^;
  IF unsat_array = NIL THEN
    lop$report_error (lle$loader_table_overflow, 'UNSATISFIED REFERENCES', '', 0);
    PUSH abort_status;
    pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
    pmp$exit (abort_status^);
  IFEND;

  FOR i := 1 TO (allocation_size - 1) DO
    unsat_array^ [i].nnext := ^unsat_array^ [i + 1];
  FOREND;

  unsat_array^ [allocation_size].nnext := NIL;
  free_unsatisfieds := ^unsat_array^ [1];


PROCEND allocate_free_unsat_references;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] allocate_free_unsat_ref_groups', EJECT ??

PROCEDURE [INLINE] allocate_free_unsat_ref_groups
  (VAR free_unsatisfieds: ^lot$unsatisfied_reference_group);


  CONST
    allocation_size = 10;

  VAR
    unsat_array: ^array [1 .. allocation_size] of lot$unsatisfied_reference_group,
    i: integer,
    abort_status: ^ost$status;


  ALLOCATE unsat_array IN lov$unsatisfied_ref_container^;
  IF unsat_array = NIL THEN
    lop$report_error (lle$loader_table_overflow, 'UNSATISFIED REFERENCE GROUPS', '', 0);
    PUSH abort_status;
    pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
    pmp$exit (abort_status^);
  IFEND;

  FOR i := 1 TO (allocation_size - 1) DO
    unsat_array^ [i].nnext := ^unsat_array^ [i + 1];
  FOREND;

  unsat_array^ [allocation_size].nnext := NIL;
  free_unsatisfieds := ^unsat_array^ [1];


PROCEND allocate_free_unsat_ref_groups;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] allocate_free_unsat_ref_list', EJECT ??

PROCEDURE [INLINE] allocate_free_unsat_ref_list
  (VAR free_unsatisfieds: ^lot$unsatisfied_reference_list);


  CONST
    allocation_size = 10;

  VAR
    unsat_array: ^array [1 .. allocation_size] of lot$unsatisfied_reference_list,
    i: integer,
    abort_status: ^ost$status;


  ALLOCATE unsat_array IN lov$unsatisfied_ref_container^;
  IF unsat_array = NIL THEN
    lop$report_error (lle$loader_table_overflow, 'UNSATISFIED REFERENCE LIST', '', 0);
    PUSH abort_status;
    pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
    pmp$exit (abort_status^);
  IFEND;

  FOR i := 1 TO (allocation_size - 1) DO
    unsat_array^ [i].f_link := ^unsat_array^ [i + 1];
  FOREND;

  unsat_array^ [allocation_size].f_link := NIL;
  free_unsatisfieds := ^unsat_array^ [1];


PROCEND allocate_free_unsat_ref_list;

?? NEWTITLE := '[INLINE] exclude_declaration_mismatch', EJECT ??

  FUNCTION [INLINE] exclude_declaration_mismatch
    (    name: pmt$program_name): boolean;

    VAR
      index: integer;

    exclude_declaration_mismatch := FALSE;
    FOR index := LOWERBOUND(excluded_entry_points) TO UPPERBOUND(excluded_entry_points) DO
      IF name = excluded_entry_points [index] THEN
        exclude_declaration_mismatch := TRUE;
        RETURN;
      IFEND;
    FOREND;

  FUNCEND exclude_declaration_mismatch;

MODEND lom$entry_external_matching;

*DECK DECK=LOM$LIBRARY_ENTITY_LOCATOR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Loader : Load library modules' ??
MODULE lom$library_entity_locator;

{  PURPOSE:
{    This module contains procedures to support the Program Interfaces which find named entities
{    on object libraries.

?? NEWTITLE := '  Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc fst$path_handle_name
*copyc fst$resolved_file_reference
*copyc lle$loader_status_conditions
*copyc lle$load_map_diagnostics
*copyc llt$load_module
*copyc loc$deferred_entry_pt_library
*copyc loc$task_services_library_name
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc ost$caller_identifier
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*copyc clp$convert_string_to_file_path
*copyc dbp$entry_point_table_address
*copyc dbp$module_table_address
*copyc fsp$get_open_information
*copyc lop$find_matching_entry_point
*copyc osp$set_status_abnormal
*copyc pmp$convert_entry_point_to_cmnd
*copyc pmp$log
*copyc pmp$verify_library
*copyc lov$file_descriptors
*copyc lov$library_list
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lop$find_command_in_program', EJECT ??
*copy loh$find_command_in_program

  PROCEDURE [XDCL, #GATE] lop$find_command_in_program
    (    command_name: pmt$program_name;
     VAR command_dictionary_item: llt$command_dictionary_item;
     VAR library: ^SEQ ( * );
     VAR library_name: amt$local_file_name;
     VAR library_rings: amt$ring_attributes;
     VAR library_privilege: ost$name;
     VAR status: ost$status);


    VAR
      caller: ost$caller_identifier,
      command_found: boolean,
      current_library: ^lot$library_descriptor,
      entry_point_dictionary_item: llt$entry_point_dictionary_item,
      entry_point_found: boolean,
      library_file: lot$load_file,
      version: string (4);

    #CALLER_ID (caller);

    status.normal := TRUE;
    IF (lov$library_list.first <> NIL) THEN
      current_library := lov$library_list.first;

    /search_libraries/
      REPEAT
        IF (caller.ring >= osc$tsrv_ring) AND (caller.ring <= current_library^.ring_brackets.r3) THEN
          library_file := current_library^.segment;
          IF library_file <> NIL THEN
            pmp$verify_library (library_file, version, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF version = llc$object_library_version THEN
              find_command_in_library (^command_name, library_file, command_found, command_dictionary_item);
            ELSEIF version = 'V1.0' THEN
              find_entry_point_in_library (^command_name, library_file, entry_point_found,
                    entry_point_dictionary_item, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              IF entry_point_found THEN
                pmp$convert_entry_point_to_cmnd (entry_point_dictionary_item,
                      LOWERVALUE (clt$named_entry_ordinal), command_dictionary_item);
                command_found := TRUE;
              IFEND;
            IFEND;
            IF command_found THEN
              EXIT /search_libraries/;
            IFEND;
          IFEND;
        IFEND;
        current_library := current_library^.nnext;
      UNTIL current_library = NIL;
    IFEND;

    IF command_found THEN
      library := current_library^.segment;
      library_name := current_library^.attributes.name;
      library_rings := current_library^.ring_brackets;
      library_privilege := 'OBJECT';
    ELSE
      osp$set_status_abnormal ('PM', lle$entry_point_not_found, command_name, status);
    IFEND;

  PROCEND lop$find_command_in_program;
?? OLDTITLE ??
?? NEWTITLE := 'find_command_in_library', EJECT ??

{  PURPOSE:
{    This procedure searchs the command dictionary of the specified library for name.
{    If the name is located, the corresponding command dictionary item is returned.

  PROCEDURE find_command_in_library
    (    name: {input} ^pmt$program_name;
         library_file: lot$load_file;
     VAR command_found: boolean;
     VAR command_dictionary_item: llt$command_dictionary_item);

?? NEWTITLE := 'search_command_dictionary', EJECT ??

    PROCEDURE search_command_dictionary
      (    name: {input} ^pmt$program_name;
           command_dictionary: {input} ^llt$command_dictionary;
       VAR command_found: {control} boolean;
       VAR dictionary_index: 1 .. llc$max_commands_in_library);

      VAR
        temp: integer,
        lower: 1 .. llc$max_commands_in_library,
        upper: 0 .. llc$max_commands_in_library;

      lower := LOWERBOUND (command_dictionary^);
      upper := UPPERBOUND (command_dictionary^);
      command_found := FALSE;

    /binary_search/
      WHILE (lower <= upper) AND (NOT command_found) DO
        temp := lower + upper;
        dictionary_index := temp DIV 2;
        IF name^ = command_dictionary^ [dictionary_index].name THEN
          command_found := TRUE;
        ELSEIF name^ > command_dictionary^ [dictionary_index].name THEN
          lower := dictionary_index + 1;
        ELSE
          upper := dictionary_index - 1;
        IFEND;
      WHILEND /binary_search/;
    PROCEND search_command_dictionary;
?? OLDTITLE, EJECT ??

    VAR
      command_dictionary: ^llt$command_dictionary,
      dictionary_index: 1 .. llc$max_commands_in_library,
      i: 0 .. llc$max_dictionaries_on_library,
      library: lot$load_file,
      library_header: ^llt$object_library_header,
      library_dictionary: ^llt$object_library_dictionaries,
      number_of_commands: 0 .. llc$max_commands_in_library;


    library := library_file;
    RESET library;
    NEXT library_header IN library;
    NEXT library_dictionary: [1 .. library_header^.number_of_dictionaries] IN library;

    command_found := FALSE;
    number_of_commands := 0;

  /find_command_dictionary/
    FOR i := LOWERBOUND (library_dictionary^) TO UPPERBOUND (library_dictionary^) DO
      IF library_dictionary^ [i].kind = llc$command_dictionary THEN
        command_dictionary := #PTR (library_dictionary^ [i].command_dictionary, library^);
        number_of_commands := UPPERBOUND (command_dictionary^);
        EXIT /find_command_dictionary/;
      IFEND;
    FOREND /find_command_dictionary/;

    IF number_of_commands > 0 THEN
      search_command_dictionary (name, command_dictionary, command_found, dictionary_index);
      IF command_found THEN
        command_dictionary_item := command_dictionary^ [dictionary_index];
      IFEND;
    IFEND;

  PROCEND find_command_in_library;
?? OLDTITLE ??
?? NEWTITLE := 'find_entry_point_in_library', EJECT ??

{  PURPOSE:
{    This procedure searches the entry_point dictionary of the specified library for name.
{    If the name is located, the corresponding entry_point dictionary item is returned.

  PROCEDURE find_entry_point_in_library
    (    name: {input} ^pmt$program_name;
         library_file: lot$load_file;
     VAR entry_point_found: boolean;
     VAR entry_point_dictionary_item: llt$entry_point_dictionary_item;
     VAR status: ost$status);

?? NEWTITLE := 'search_entry_point_dictionary', EJECT ??

    PROCEDURE search_entry_point_dictionary
      (    name: {input} ^pmt$program_name;
           entry_point_dictionary: {input} ^llt$entry_point_dictionary;
       VAR entry_point_found: {control} boolean;
       VAR dictionary_index: 1 .. llc$max_entry_points_in_library);

      VAR
        temp: integer,
        lower: 1 .. llc$max_entry_points_in_library,
        upper: 0 .. llc$max_entry_points_in_library;

      lower := LOWERBOUND (entry_point_dictionary^);
      upper := UPPERBOUND (entry_point_dictionary^);
      entry_point_found := FALSE;

    /binary_search/
      WHILE (lower <= upper) AND (NOT entry_point_found) DO
        temp := lower + upper;
        dictionary_index := temp DIV 2;
        IF name^ = entry_point_dictionary^ [dictionary_index].name THEN
          entry_point_found := TRUE;
        ELSEIF name^ > entry_point_dictionary^ [dictionary_index].name THEN
          lower := dictionary_index + 1;
        ELSE
          upper := dictionary_index - 1;
        IFEND;
      WHILEND /binary_search/;
    PROCEND search_entry_point_dictionary;
?? OLDTITLE, EJECT ??

    VAR
      dictionary_index: 1 .. llc$max_entry_points_in_library,
      entry_point_dictionary: ^llt$entry_point_dictionary,
      i: 0 .. llc$max_dictionaries_on_library,
      library: lot$load_file,
      library_dictionary: ^llt$object_library_dictionaries,
      library_hdr: ^llt$object_library_header_v1_0,
      library_header: ^llt$object_library_header,
      number_of_entry_points: 0 .. llc$max_entry_points_in_library;

    status.normal := TRUE;
    entry_point_found := FALSE;

    library := library_file;
    RESET library;
    NEXT library_header IN library;

    IF library_header^.version = llc$object_library_version THEN
      NEXT library_dictionary: [1 .. library_header^.number_of_dictionaries] IN library;
      IF library_dictionary = NIL THEN
        osp$set_status_abnormal ('PM', lle$library_header_missing, '', status);
        RETURN;
      IFEND;
      number_of_entry_points := 0;

    /find_entry_point_dictionary/
      FOR i := LOWERBOUND (library_dictionary^) TO UPPERBOUND (library_dictionary^) DO
        IF (library_dictionary^ [i].kind = llc$entry_point_dictionary) THEN
          entry_point_dictionary := #PTR (library_dictionary^ [i].entry_point_dictionary, library^);
          number_of_entry_points := UPPERBOUND (entry_point_dictionary^);
          EXIT /find_entry_point_dictionary/;
        IFEND;
      FOREND /find_entry_point_dictionary/;

    ELSEIF library_header^.version = 'V1.0' THEN
      RESET library;
      NEXT library_hdr IN library;
      number_of_entry_points := library_hdr^.number_of_entry_points;
      entry_point_dictionary := #PTR (library_hdr^.entry_point_dictionary, library^);

    ELSE
      osp$set_status_abnormal ('PM', lle$wrong_library_version, llc$object_library_version, status);
      RETURN;

    IFEND;

    IF number_of_entry_points > 0 THEN
      search_entry_point_dictionary (name, entry_point_dictionary, entry_point_found, dictionary_index);
      IF entry_point_found THEN
        entry_point_dictionary_item := entry_point_dictionary^ [dictionary_index];
      IFEND;
    IFEND;
  PROCEND find_entry_point_in_library;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$find_entry_point_residence', EJECT ??
*copy loh$find_entry_point_residence

  PROCEDURE [XDCL] lop$find_entry_point_residence
    (    entry_point: pmt$program_name;
     VAR loaded_ring: ost$valid_ring;
     VAR module_name: pmt$program_name;
     VAR file_reference: fst$file_reference;
     VAR status: ost$status);

    VAR
      current_library_p: ^lot$library_descriptor,
      entry_definition_p: ^lot$entry_definition,
      entry_point_defined: boolean,
      entry_point_offset: ost$segment_offset,
      entry_point_ring: ost$ring,
      entry_point_segment: ost$segment,
      entry_point_table_address_p: ^dbt$entry_point_table,
      external_descriptor: lot$external_descriptor,
      file_index: ost$non_negative_integers,
      ignore_dictionary_index: integer,
      ignore_linkage_p: ^lot$linkage_name_lists,
      ignore_path_handle_name: fst$path_handle_name,
      item_index: ost$non_negative_integers,
      load_file_found: boolean,
      module_table_address_p: ^dbt$module_address_table_item,
      resolved_file_reference_p: ^fst$resolved_file_reference,
      user_defined_attribute_size: fst$user_defined_attribute_size;

    status.normal := TRUE;
    load_file_found := FALSE;
    IF entry_point = osc$null_name THEN
      osp$set_status_abnormal ('LL', lle$entry_point_not_found, entry_point, status);
    ELSE
      external_descriptor.name := entry_point;
      external_descriptor.global_key := loc$master_key;
      external_descriptor.reference_ring := loaded_ring;
      lop$find_matching_entry_point (external_descriptor, entry_point_defined, ignore_linkage_p,
            entry_definition_p);
      IF NOT entry_point_defined THEN
        osp$set_status_abnormal ('LL', lle$entry_point_not_found, entry_point, status);
      ELSE
        IF entry_definition_p^.attributes.load_file_number = 0 THEN

{ Entry point is in task services.

          module_name := entry_definition_p^.defining_module;
          file_reference := ':$LOCAL.' CAT loc$task_services_library_name CAT '.1';
        ELSE { entry point is not in task services.

          entry_point_table_address_p := dbp$entry_point_table_address ();

{ Search the debug entry point table for the entry point name in the loaded ring.

          item_index := 1;

        /search_entry_point_table/
          WHILE (item_index <= UPPERBOUND (entry_point_table_address_p^.item)) DO
            IF entry_point_table_address_p^.item [item_index].name = entry_point THEN
              IF (entry_point_table_address_p^.item [item_index].loaded_ring <= loaded_ring) AND
                    (entry_point_table_address_p^.item [item_index].call_bracket >= loaded_ring) THEN
                loaded_ring := entry_point_table_address_p^.item [item_index].loaded_ring;
                entry_point_ring := entry_point_table_address_p^.item [item_index].address.ring;
                entry_point_segment := entry_point_table_address_p^.item [item_index].address.seg;
                entry_point_offset := entry_point_table_address_p^.item [item_index].address.offset;
                EXIT /search_entry_point_table/;
              IFEND;
            IFEND;
            item_index := item_index + 1;
          WHILEND /search_entry_point_table/;

          IF (entry_definition_p^.defining_module = 'DEFERRED_ENTRY_POINT') THEN
            module_name := entry_definition_p^.defining_module;
          ELSE

{ Search the debug module table for the module containing the address found in
{ the entry point table search.  Look only at code sections.

            module_table_address_p := dbp$module_table_address ();

          /search_module_table/
            WHILE (module_table_address_p <> NIL) DO
              item_index := 0;
              WHILE (item_index <= UPPERBOUND (module_table_address_p^.section_item)) DO
                IF module_table_address_p^.section_item [item_index].kind = llc$code_section THEN
                  IF (entry_point_ring = module_table_address_p^.section_item [item_index].address.ring) AND
                        (entry_point_segment = module_table_address_p^.section_item [item_index].
                        address.seg) AND ((entry_point_offset >= module_table_address_p^.
                        section_item [item_index].address.offset) AND
                        (entry_point_offset < module_table_address_p^.section_item [item_index].address.
                        offset + module_table_address_p^.section_item [item_index].length)) THEN
                    module_name := module_table_address_p^.name;
                    EXIT /search_module_table/;
                  IFEND;
                IFEND;
                item_index := item_index + 1;
              WHILEND;
              module_table_address_p := module_table_address_p^.next_module;
            WHILEND /search_module_table/;
          IFEND;

{ Find the file or library with the load_file_number matching the one returned by
{ lop$find_matching_entry_point.  Search the file list before the library list
{ since we are most likely looking for a starting procedure which is more likely
{ to be on a load file than a library.

          IF lov$file_descriptors <> NIL THEN

          /search_files/
            FOR file_index := 1 TO UPPERBOUND (lov$file_descriptors^) DO
              IF lov$file_descriptors^ [file_index].attributes.load_file_number =
                    entry_definition_p^.attributes.load_file_number THEN
                load_file_found := TRUE;
                PUSH resolved_file_reference_p;
                fsp$get_open_information (lov$file_descriptors^ [file_index].file_identifier,
                      {attachment_information} NIL, {catalog_information} NIL, {cycle_attribute_sources} NIL,
                      {cycle_attribute_values} NIL, {instance_information} NIL, resolved_file_reference_p,
                      {user_defined_attributes} NIL, {ignore} user_defined_attribute_size, status);
                IF NOT status.normal THEN
                  RETURN;
                ELSE
                  file_reference := resolved_file_reference_p^.path
                        (1, resolved_file_reference_p^.cycle_path_size);
                IFEND;
                EXIT /search_files/;
              IFEND;
            FOREND /search_files/;
          IFEND;
          IF NOT load_file_found THEN
            IF lov$library_list.first <> NIL THEN
              current_library_p := lov$library_list.first;

            /search_libraries/
              REPEAT
                IF (current_library_p^.attributes.load_file_number =
                      entry_definition_p^.attributes.load_file_number) AND
                      (current_library_p^.attributes.name (1, loc$deferred_entry_pt_lib_size) <>
                      loc$deferred_entry_pt_library) THEN
                  PUSH resolved_file_reference_p;
                  clp$convert_string_to_file_path (current_library_p^.attributes.name,
                        { use_$local_as_working_catalog } FALSE, { return_path_handle_name } FALSE,
                        ignore_path_handle_name, resolved_file_reference_p^, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;
                  file_reference := resolved_file_reference_p^.path;
                  EXIT /search_libraries/;
                IFEND;
                current_library_p := current_library_p^.nnext;
              UNTIL current_library_p = NIL;
            IFEND;
          IFEND; { load file not found
        IFEND; { entry_point is in task services
      IFEND; { entry_point not defined
    IFEND; { entry_point = osc$null_name
  PROCEND lop$find_entry_point_residence;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] lop$find_function_in_program', EJECT ??
*copy loh$find_function_in_program

  PROCEDURE [XDCL, #GATE] lop$find_function_in_program
    (    function_name: pmt$program_name;
     VAR function_dictionary_item: llt$function_dictionary_item;
     VAR library: ^SEQ ( * );
     VAR library_name: amt$local_file_name;
     VAR library_rings: amt$ring_attributes;
     VAR status: ost$status);


    VAR
      caller: ost$caller_identifier,
      current_library: ^lot$library_descriptor,
      function_found: boolean,
      library_file: lot$load_file,
      version: string (4);

    #CALLER_ID (caller);

    status.normal := TRUE;

    IF (lov$library_list.first <> NIL) THEN
      current_library := lov$library_list.first;

    /search_libraries/
      REPEAT
        IF (caller.ring >= osc$tsrv_ring) AND (caller.ring <= current_library^.ring_brackets.r3) THEN
          library_file := current_library^.segment;
          pmp$verify_library (library_file, version, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF version = llc$object_library_version THEN
            find_function_in_library (^function_name, library_file, function_found, function_dictionary_item);
          ELSE
            EXIT /search_libraries/;
          IFEND;
          IF function_found THEN
            EXIT /search_libraries/;
          IFEND;
        IFEND;
        current_library := current_library^.nnext;
      UNTIL (current_library = NIL);
    IFEND;

    IF function_found THEN
      library := current_library^.segment;
      library_name := current_library^.attributes.name;
      library_rings := current_library^.ring_brackets;
    ELSE
      osp$set_status_abnormal ('PM', lle$entry_point_not_found, function_name, status);
    IFEND;

  PROCEND lop$find_function_in_program;
?? OLDTITLE ??
?? NEWTITLE := 'find_function_in_library', EJECT ??

{  PURPOSE:
{    This procedure searchs the function dictionary of the specified library for name.
{    If the name is located, the corresponding function dictionary item is returned.

  PROCEDURE find_function_in_library
    (    name: {input} ^pmt$program_name;
         library_file: lot$load_file;
     VAR function_found: boolean;
     VAR function_dictionary_item: llt$function_dictionary_item);

?? NEWTITLE := 'search_function_dictionary', EJECT ??

    PROCEDURE search_function_dictionary
      (    name: {input} ^pmt$program_name;
           function_dictionary: {input} ^llt$function_dictionary;
       VAR function_found: {control} boolean;
       VAR dictionary_index: 1 .. llc$max_functions_in_library);

      VAR
        temp: integer,
        lower: 1 .. llc$max_functions_in_library,
        upper: 0 .. llc$max_functions_in_library;

      lower := LOWERBOUND (function_dictionary^);
      upper := UPPERBOUND (function_dictionary^);
      function_found := FALSE;

    /binary_search/
      WHILE (lower <= upper) AND (NOT function_found) DO
        temp := lower + upper;
        dictionary_index := temp DIV 2;
        IF name^ = function_dictionary^ [dictionary_index].name THEN
          function_found := TRUE;
        ELSEIF name^ > function_dictionary^ [dictionary_index].name THEN
          lower := dictionary_index + 1;
        ELSE
          upper := dictionary_index - 1;
        IFEND;
      WHILEND /binary_search/;
    PROCEND search_function_dictionary;
?? OLDTITLE, EJECT ??

    VAR
      dictionary_index: 1 .. llc$max_functions_in_library,
      function_dictionary: ^llt$function_dictionary,
      i: 0 .. llc$max_dictionaries_on_library,
      library: lot$load_file,
      library_dictionary: ^llt$object_library_dictionaries,
      library_header: ^llt$object_library_header,
      number_of_functions: 0 .. llc$max_functions_in_library;

    library := library_file;
    RESET library;
    NEXT library_header IN library;
    NEXT library_dictionary: [1 .. library_header^.number_of_dictionaries] IN library;

    function_found := FALSE;
    number_of_functions := 0;

  /find_function_dictionary/
    FOR i := LOWERBOUND (library_dictionary^) TO UPPERBOUND (library_dictionary^) DO
      IF (library_dictionary^ [i].kind = llc$function_dictionary) THEN
        function_dictionary := #PTR (library_dictionary^ [i].function_dictionary, library^);
        number_of_functions := UPPERBOUND (function_dictionary^);
        EXIT /find_function_dictionary/;
      IFEND;
    FOREND /find_function_dictionary/;

    IF number_of_functions > 0 THEN
      search_function_dictionary (name, function_dictionary, function_found, dictionary_index);
      IF function_found THEN
        function_dictionary_item := function_dictionary^ [dictionary_index];
      IFEND;
    IFEND;
  PROCEND find_function_in_library;
?? OLDTITLE ??
MODEND lom$library_entity_locator
*DECK DECK=LOM$LIBRARY_LIST_MANAGEMENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Loader : Library list management' ??
MODULE lom$library_list_management;

{  PURPOSE:
{    This module contains procedures which manage the library_list.  The library_list identifies
{    (and contains descriptive information about) all libraries which are to be used to satisfy
{    module and external references.  The order in which libraries appear in the list determines
{    the order in which they will be searched to satisfy module and external references.  Libraries
{    can be included in the list by four means and are classified accordingly:
{        - Execute libraries are specified via the object_library_list on a program load
{          request.
{        - Text_embedded libraries are specified via an interpretive text record encountered
{          by the loader as a module is loaded.
{        - Job libraries are copied from the job_library_list.  (This list is managed via a
{          'change_job_library_list' interface and applies to all program loads in a job.
{        - Debug libraries are copied from the debug_library_list.  (This list is managed via a
{          'change_debug_library_list' interface and applies to all program loads in a job.
{    The library_list is maintained for the duration of a task and is used to satisfy external
{    references arising from dynamic load requests.

{  NOTE:
{    Condition raised: LOE$LOADER_MALFUNCTION.

?? NEWTITLE := '  Global declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cyd$run_time_error_condition
*copyc lle$loader_status_conditions
*copyc llt$entry_point_dictionary
*copyc llt$module_dictionary
*copyc llt$object_library_header
*copyc loc$deferred_entry_pt_library
*copyc loc$task_services_library_name
*copyc loe$abort_load
*copyc lok$keypoints
*copyc lot$deferred_library_list
*copyc lot$loader_type_definitions
*copyc oss$job_paged_literal
*copyc ost$status
*copyc pme$execution_exceptions
?? POP ??
*copyc lop$augment_lib_list_container
*copyc lop$build_file_descriptor
*copyc lop$report_error
*copyc osp$generate_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pmp$cause_condition
*copyc pmp$continue_to_cause
*copyc pmp$establish_condition_handler
*copyc pmp$exit
*copyc lov$file_descriptors
*copyc lov$head_of_unsat_ref_list
*copyc lov$library_list
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    library_counts_type = record
      execute_libs: integer,
      embedded_libs: integer,
      job_libs: integer,
    recend;

  VAR
    library_counts: [STATIC] library_counts_type := [0, 0, 0];

?? OLDTITLE ??
?? NEWTITLE := '  [INLINE] adjust_library_searched ', EJECT ??

  PROCEDURE adjust_library_searched
    (    highest_library_number: integer);

    VAR
      unsatisfied_reference: ^lot$unsatisfied_reference_list;

    IF (lov$head_of_unsat_ref_list = NIL) OR (lov$head_of_unsat_ref_list^.f_link = lov$head_of_unsat_ref_list)
          THEN
      RETURN;
    IFEND;

    unsatisfied_reference := lov$head_of_unsat_ref_list^.f_link;

    WHILE unsatisfied_reference <> lov$head_of_unsat_ref_list DO
      IF unsatisfied_reference^.library_searched >= highest_library_number THEN
        unsatisfied_reference^.library_searched := highest_library_number;
      IFEND;

      unsatisfied_reference := unsatisfied_reference^.f_link;
    WHILEND;

  PROCEND adjust_library_searched;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$activate_library', EJECT ??

  PROCEDURE [XDCL] lop$activate_library
    (    library_name: amt$local_file_name);

{  PURPOSE:
{    This procedure adds a phantom library to the library_list at the head of the list.  The library
{    is set active so that subsequent searches of the library list for entry points will use this
{    library.  The intent is that after a given search the library will be set inactive so that the
{    user is not aware of the library.  This is for use only by the operating system and must be used
{    in conjunction with the procedure LOP$DEACTIVATE_LIBRARY.

    VAR
      library: ^lot$library_descriptor,
      library_in_list: boolean,
      predecessor_forward_link: ^^lot$library_descriptor;

    IF library_name = osc$null_name THEN
      RETURN;
    IFEND;

{!  Temporary until PSR CILA170 is answered.

    IF lov$library_list.link_to_first_job_library = NIL THEN
      lov$library_list.link_to_first_job_library := ^lov$library_list.first;
    IFEND;

{!  End temporary.

    predecessor_forward_link := ^lov$library_list.first;

  /add_library/
    BEGIN
      lop$find_library_descriptor (library_name, library, library_in_list);
      IF library_in_list THEN
        IF library^.phantom_library THEN
          library^.phantom_library_active := TRUE;
        IFEND;
      ELSE;

        add_library_to_list (library_name, {deferred_library_segment} 0, predecessor_forward_link^,
              library_in_list);
        IF NOT library_in_list THEN
          EXIT /add_library/;
        IFEND;

        library_counts.execute_libs := library_counts.execute_libs + 1;

        IF (library_name <> loc$task_services_library_name) AND
              (library_name (1, loc$deferred_entry_pt_lib_size) <> loc$deferred_entry_pt_library) THEN
          predecessor_forward_link^^.segment := NIL;
          predecessor_forward_link^^.attributes.name := library_name;
          predecessor_forward_link^^.library_open := FALSE;
          predecessor_forward_link^^.library_valid := TRUE;
          predecessor_forward_link^^.phantom_library := TRUE;
          predecessor_forward_link^^.phantom_library_active := TRUE;
          predecessor_forward_link^^.text_embedded_library := FALSE;
        IFEND;
        adjust_library_searched (0);
      IFEND;
    END /add_library/;

  PROCEND lop$activate_library;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$deactivate_library', EJECT ??

  PROCEDURE [XDCL] lop$deactivate_library
    (    library_name: amt$local_file_name);


    VAR
      library: ^lot$library_descriptor,
      library_in_list: boolean;

    IF library_name = osc$null_name THEN
      RETURN;
    IFEND;

    lop$find_library_descriptor (library_name, library, library_in_list);
    IF library_in_list THEN
      IF library^.phantom_library THEN
        library^.phantom_library_active := FALSE;
        library_counts.execute_libs := library_counts.execute_libs - 1;
      IFEND;
    IFEND;

    adjust_library_searched (0);

  PROCEND lop$deactivate_library;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$add_program_load_libraries', EJECT ??

  PROCEDURE [XDCL] lop$add_program_load_libraries
    (    execute_libraries: ^pmt$object_library_list;
         job_libraries: ^pmt$object_library_list;
         deferred_libraries: ^lot$deferred_library_list);

{  PURPOSE:
{    This procedure initializes the library_list for a program load.  Execute libraries and
{    job libraries are added to the library_list in the appropriate positions.
{  NOTE:
{    Debug libraries may already be in the list if the debugger is activated prior to initiation
{    of the program load.

    VAR
      i: pmt$number_of_libraries,
      library: ^lot$library_descriptor,
      library_in_list: boolean,
      execute_libs: integer,
      job_libs: integer,
      predecessor_forward_link: ^^lot$library_descriptor;

    #KEYPOINT (osk$entry, 0, lok$add_program_load_libraries);

{!  Temporary until PSR CILA170 is answered.

    IF lov$library_list.link_to_first_job_library = NIL THEN
      lov$library_list.link_to_first_job_library := ^lov$library_list.first;
    IFEND;

{!  End temporary.

    predecessor_forward_link := ^lov$library_list.first;

    IF deferred_libraries <> NIL THEN

      WHILE (predecessor_forward_link^ <> NIL) AND (predecessor_forward_link^^.attributes.
            name (1, loc$deferred_entry_pt_lib_size) = loc$deferred_entry_pt_library) DO
        predecessor_forward_link := ^predecessor_forward_link^^.nnext;
      WHILEND;

    /add_deferred_libraries/
      FOR i := LOWERBOUND (deferred_libraries^) TO UPPERBOUND (deferred_libraries^) DO
        lop$find_library_descriptor (deferred_libraries^ [i].name, library, library_in_list);
        IF library_in_list THEN
          CYCLE /add_deferred_libraries/
        IFEND;

        add_library_to_list (deferred_libraries^ [i].name, deferred_libraries^ [i].segment,
              predecessor_forward_link^, library_in_list);
        IF NOT library_in_list THEN
          CYCLE /add_deferred_libraries/
        IFEND;

        predecessor_forward_link := ^predecessor_forward_link^^.nnext;
      FOREND /add_deferred_libraries/;

      IF lov$library_list.link_to_first_job_library = ^lov$library_list.first THEN
        lov$library_list.link_to_first_job_library := predecessor_forward_link;
      IFEND;

    IFEND;

    IF execute_libraries <> NIL THEN

      execute_libs := library_counts.execute_libs;

      WHILE (predecessor_forward_link^ <> NIL) AND (predecessor_forward_link^^.attributes.
            name (1, loc$deferred_entry_pt_lib_size) = loc$deferred_entry_pt_library) DO
        predecessor_forward_link := ^predecessor_forward_link^^.nnext;
      WHILEND;

    /add_execute_libraries/
      FOR i := LOWERBOUND (execute_libraries^) TO UPPERBOUND (execute_libraries^) DO
        lop$find_library_descriptor (execute_libraries^ [i], library, library_in_list);
        IF library_in_list THEN
          CYCLE /add_execute_libraries/
        IFEND;

        add_library_to_list (execute_libraries^ [i], {deferred_library_segment} 0, predecessor_forward_link^,
              library_in_list);
        IF NOT library_in_list THEN
          CYCLE /add_execute_libraries/
        IFEND;

        library_counts.execute_libs := library_counts.execute_libs + 1;

        IF (execute_libraries^ [i] <> loc$task_services_library_name) AND
              (execute_libraries^ [i] (1, loc$deferred_entry_pt_lib_size) <>
              loc$deferred_entry_pt_library) THEN
          predecessor_forward_link^^.segment := NIL;
          predecessor_forward_link^^.attributes.name := execute_libraries^ [i];
          predecessor_forward_link^^.library_open := FALSE;
          predecessor_forward_link^^.library_valid := TRUE;
          predecessor_forward_link^^.phantom_library := FALSE;
          predecessor_forward_link^^.phantom_library_active := FALSE;
          predecessor_forward_link^^.text_embedded_library := FALSE;
        IFEND;

        predecessor_forward_link := ^predecessor_forward_link^^.nnext;
      FOREND /add_execute_libraries/;

      IF lov$library_list.link_to_first_job_library = ^lov$library_list.first THEN
        lov$library_list.link_to_first_job_library := predecessor_forward_link;
      IFEND;

      IF execute_libs < library_counts.execute_libs THEN
        adjust_library_searched (0);
      IFEND;
    IFEND;

    IF job_libraries <> NIL THEN
      predecessor_forward_link := lov$library_list.link_to_first_job_library;
      job_libs := library_counts.job_libs;

    /add_job_libraries/
      FOR i := LOWERBOUND (job_libraries^) TO UPPERBOUND (job_libraries^) DO
        lop$find_library_descriptor (job_libraries^ [i], library, library_in_list);
        IF library_in_list THEN
          CYCLE /add_job_libraries/
        IFEND;

        add_library_to_list (job_libraries^ [i], {deferred_library_segment} 0, predecessor_forward_link^,
              library_in_list);
        IF NOT library_in_list THEN
          CYCLE /add_job_libraries/
        IFEND;

        library_counts.job_libs := library_counts.job_libs + 1;

        IF (job_libraries^ [i] <> loc$task_services_library_name) AND
              (job_libraries^ [i] (1, loc$deferred_entry_pt_lib_size) <> loc$deferred_entry_pt_library) THEN
          predecessor_forward_link^^.segment := NIL;
          predecessor_forward_link^^.attributes.name := job_libraries^ [i];
          predecessor_forward_link^^.library_open := FALSE;
          predecessor_forward_link^^.library_valid := TRUE;
          predecessor_forward_link^^.phantom_library := FALSE;
          predecessor_forward_link^^.phantom_library_active := FALSE;
          predecessor_forward_link^^.text_embedded_library := FALSE;
        IFEND;

        predecessor_forward_link := ^predecessor_forward_link^^.nnext;
      FOREND /add_job_libraries/;

      IF job_libs < library_counts.job_libs THEN
        adjust_library_searched (library_counts.execute_libs + library_counts.embedded_libs + job_libs);
      IFEND;
    IFEND;
    #KEYPOINT (osk$exit, 0, lok$add_program_load_libraries);
  PROCEND lop$add_program_load_libraries;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$add_text_embedded_libraries', EJECT ??

  PROCEDURE [XDCL] lop$add_text_embedded_libraries
    (    text_embedded_libraries: ^llt$libraries);

{  PURPOSE:
{    This procedure processes 'libraries' object text records.  It adds the text_embedded libraries
{    to the library_list in the order they are encountered, with the first text_embedded library
{    appearing immediately after the last execute library.

    VAR
      i: 1 .. llc$max_libraries,
      library: ^lot$library_descriptor,
      predecessor_forward_link: ^^lot$library_descriptor,
      embedded_libs: integer,
      library_in_list: boolean;

{!  Temporary until PSR CILA170 is answered.

    IF lov$library_list.link_to_first_job_library = NIL THEN
      lov$library_list.link_to_first_job_library := ^lov$library_list.first;
    IFEND;

{!  End temporary.

    predecessor_forward_link := lov$library_list.link_to_first_job_library;
    embedded_libs := library_counts.embedded_libs;

  /add_text_embedded_libraries/
    FOR i := LOWERBOUND (text_embedded_libraries^) TO UPPERBOUND (text_embedded_libraries^) DO
      lop$find_library_descriptor (text_embedded_libraries^ [i], library, library_in_list);
      IF library_in_list THEN
        CYCLE /add_text_embedded_libraries/
      IFEND;

      add_library_to_list (text_embedded_libraries^ [i], {deferred_library_segment} 0,
            predecessor_forward_link^, library_in_list);
      IF NOT library_in_list THEN
        CYCLE /add_text_embedded_libraries/
      IFEND;

      library_counts.embedded_libs := library_counts.embedded_libs + 1;

      IF (text_embedded_libraries^ [i] <> loc$task_services_library_name) AND
            (text_embedded_libraries^ [i] (1, loc$deferred_entry_pt_lib_size) <>
            loc$deferred_entry_pt_library) THEN
        predecessor_forward_link^^.segment := NIL;
        predecessor_forward_link^^.attributes.name := text_embedded_libraries^ [i];
        predecessor_forward_link^^.library_open := FALSE;
        predecessor_forward_link^^.library_valid := TRUE;
        predecessor_forward_link^^.phantom_library := FALSE;
        predecessor_forward_link^^.phantom_library_active := FALSE;
        predecessor_forward_link^^.text_embedded_library := TRUE;
      IFEND;

      predecessor_forward_link := ^predecessor_forward_link^^.nnext;
    FOREND /add_text_embedded_libraries/;

    lov$library_list.link_to_first_job_library := predecessor_forward_link;
    IF embedded_libs < library_counts.embedded_libs THEN
      adjust_library_searched (library_counts.execute_libs + embedded_libs);
    IFEND;

  PROCEND lop$add_text_embedded_libraries;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$add_debug_libraries', EJECT ??

  PROCEDURE [XDCL] lop$add_debug_libraries
    (    debug_library_list: pmt$object_library_list;
     VAR status {control} : ost$status);

{  PURPOSE:
{    This procedure adds debug libraries at the end of the library_list.

?? NEWTITLE := 'terminate_request', EJECT ??

    PROCEDURE terminate_request
      (    condition: pmt$condition;
           malfunction_status: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

{   PURPOSE:
{      Circumstances may arise during the addition of debug libraries which cause
{      the addition to be unsuccessful.  These abnormalities are reported via conditions.
{      This condition handler is responsible for fielding the condition and reporting
{      the abnormality to the caller of lop$add_debug_libraries.
{
{      The conditions and their meanings are:
{      1.  system conditions: the hardware detected a condition which is probably
{          caused by a loader coding error.  The specific condition is reported to
{          the output file and the request is terminated with the loader malfunctioned
{          exception code.  SEE: code for pmc$detected_uncorrected_err processing.
{      2.  segment access conditions:
{          a. mmc$sac_read_beyond_eoi, mmc$sac_segment_access_error,
{             mmc$sac_key_lock_violation, mmc$sac_ring_violation:
{             segment management detected an inconsistency which was probably
{             caused by a loader coding error.  The specific condition is reported
{             to the output file and the request is terminated with the loader
{             malfunctioned exception code.
{          b. mmc$sac_read_write_beyond_msl: user limits prevented the loader from
{             completing the load process.  The request is terminated with the
{             insufficient memory to load exception code.
{          c. mmc$sac_io_read_error: a hardware error was detected attempting to
{             read a page from a device.  The specific condition is reported to
{             the output file and the request is terminated with the premature load
{             termination exception code.
{      3.  user defined conditions:
{          a. cye$run_time_condition: the CYBIL run time checking detected an
{             error which was probably cause by a loader coding error.  The
{             specific condition is reported to the output file and the request is
{             terminated with loader malfunctioned exception code.
{          b. loe$abort_load: several constituent procedures of the loader detect
{             circumstances which prohibit continuation of the load process.  The
{             detecting procedure reports the circumstance to load map and causes
{             the loe$abort_load condition.  This condition handler terminates the
{             request with the premature load termination exception code.
{          c. loe$loader_malfunction: a constituent procedure of the loader
{             detected an inconsistency which probably was caused by a loader
{             coding error.  The detecting procedure causes the condition
{             pointing to a status variable which identifies the inconsistency.
{             This condition handler reports the identified inconsistency to
{             the output file and terminates the request with the loader malfunctioned
{             exception code.
{          d. loe$insufficient_memory: several constituent procedures of the
{             loader detect circumstances where there is not enough virtual memory
{             to complete the load process - this is generally a case of user
{             limit being exceeded.  The detecting procedure reports the shortage
{             to the load map and causes the condition.  This condition handler
{             terminates the request with insufficient memory to load exception code.
{          e. other: other user defined conditions will be continued and
{             otherwise ignored.
{

      VAR
        termination_descriptor: pmt$established_handler,
        cybil_error: ^ost$status,
        malfunction: ^ost$status,
        message: ost$status;

      CASE condition.selector OF
      = pmc$system_conditions =
        osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
        osp$generate_message (message, condition_status);
        IF NOT (pmc$detected_uncorrected_err IN condition.system_conditions) THEN
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'DEBUGGER', status);
        ELSE
          status := message;
        IFEND;
      = mmc$segment_access_condition =
        CASE condition.segment_access_condition.identifier OF
        = mmc$sac_read_beyond_eoi, mmc$sac_segment_access_error, mmc$sac_key_lock_violation,
              mmc$sac_ring_violation =
          osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'DEBUGGER', status);
        = mmc$sac_read_write_beyond_msl =
          osp$set_status_abnormal ('LL', lle$insufficient_memory_to_load, '', status);
        = mmc$sac_io_read_error =
          osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$premature_load_termination, 'Debugger', status);
        ELSE
          osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$premature_load_termination, 'Debugger', status);
        CASEND;
      = pmc$user_defined_condition =
        IF (condition.user_condition_name = cye$run_time_condition) THEN
          cybil_error := malfunction_status;
          osp$generate_message (cybil_error^, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'DEBUGGER', status);
        ELSEIF (condition.user_condition_name = loe$abort_load) THEN
          osp$set_status_abnormal ('LL', lle$premature_load_termination, 'Debugger', status);
        ELSEIF (condition.user_condition_name = loe$loader_malfunction) THEN
          malfunction := malfunction_status;
          osp$generate_message (malfunction^, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'DEBUGGER', status);
        ELSEIF (condition.user_condition_name = loe$insufficient_memory) THEN
          osp$set_status_abnormal ('LL', lle$insufficient_memory_to_load, '', status);
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          RETURN;
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        RETURN;
      CASEND;
      EXIT lop$add_debug_libraries;
    PROCEND terminate_request;
?? OLDTITLE, EJECT ??

    VAR
      predecessor_forward_link: ^^lot$library_descriptor,
      i: pmt$number_of_libraries,
      library: ^lot$library_descriptor,
      library_in_list: boolean,
      termination_descriptor: pmt$established_handler,
      termination_conditions: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
            [pmc$condition_combination, $pmt$condition_combination
            [pmc$system_conditions, mmc$segment_access_condition, pmc$user_defined_condition]];

    pmp$establish_condition_handler (termination_conditions, ^terminate_request, ^termination_descriptor,
          status);
    IF status.normal THEN

{!  Temporary until PSR CILA170 is answered.

      IF lov$library_list.link_to_first_job_library = NIL THEN
        lov$library_list.link_to_first_job_library := ^lov$library_list.first;
      IFEND;

{!  End temporary.

      predecessor_forward_link := ^lov$library_list.first;

      WHILE predecessor_forward_link^ <> NIL DO
        predecessor_forward_link := ^predecessor_forward_link^^.nnext;
      WHILEND;

    /add_debug_libraries/
      FOR i := LOWERBOUND (debug_library_list) TO UPPERBOUND (debug_library_list) DO
        lop$find_library_descriptor (debug_library_list [i], library, library_in_list);
        IF library_in_list THEN
          CYCLE /add_debug_libraries/
        IFEND;

        add_library_to_list (debug_library_list [i], {deferred_library_segment} 0, predecessor_forward_link^,
              library_in_list);
        IF NOT library_in_list THEN
          CYCLE /add_debug_libraries/
        IFEND;

        IF (debug_library_list [i] <> loc$task_services_library_name) AND
              (debug_library_list [i] (1, loc$deferred_entry_pt_lib_size) <>
              loc$deferred_entry_pt_library) THEN
          predecessor_forward_link^^.segment := NIL;
          predecessor_forward_link^^.attributes.name := debug_library_list [i];
          predecessor_forward_link^^.library_open := FALSE;
          predecessor_forward_link^^.library_valid := TRUE;
          predecessor_forward_link^^.phantom_library := FALSE;
          predecessor_forward_link^^.phantom_library_active := FALSE;
          predecessor_forward_link^^.text_embedded_library := FALSE;
        IFEND;

        predecessor_forward_link := ^predecessor_forward_link^^.nnext;
      FOREND /add_debug_libraries/;
    IFEND;
  PROCEND lop$add_debug_libraries;
?? OLDTITLE ??
?? NEWTITLE := 'add_library_to_list', EJECT ??

  PROCEDURE add_library_to_list
    (    library_name: amt$local_file_name;
         deferred_library_segment: ost$segment;
     VAR predecessor_forward_link {input_output} : ^lot$library_descriptor;
     VAR library_added_to_list {control} : boolean);

{  PURPOSE:
{    This procedure is responsible for including files in the library_list as directed.  It verifies
{    that the identified file is indeed a library file, prepares the library for use in the load
{    process, and inserts a descriptor for the library into the library_list at the directed location.


    VAR
      entry_point_index: 1 .. llc$max_deferred_entry_points,
      file_descriptor: lot$file_descriptor,
      file_descriptor_found: boolean,
      ignore_status: ost$status,
      library: ^lot$library_descriptor,
      library_found: boolean;

    library_added_to_list := FALSE;

    lop$find_library_descriptor (library_name, library, library_found);
    IF library_found THEN
      RETURN
    IFEND;

    build_library_descriptor (predecessor_forward_link);
    library_added_to_list := TRUE;
    predecessor_forward_link^.attributes.name := library_name;
    predecessor_forward_link^.segment := NIL;

    IF library_name = loc$task_services_library_name THEN

{ Construct a library descriptor for the conventional task services entry point "library".

      predecessor_forward_link^.ring_brackets.r1 := osc$tmtr_ring;
      predecessor_forward_link^.ring_brackets.r2 := osc$tsrv_ring;
      predecessor_forward_link^.ring_brackets.r3 := osc$user_ring_2;
      predecessor_forward_link^.attributes.library_file := TRUE;
      predecessor_forward_link^.attributes.key_lock.global := FALSE;
      predecessor_forward_link^.attributes.key_lock.local := FALSE;
      predecessor_forward_link^.attributes.key_lock.value := loc$master_key;
      predecessor_forward_link^.attributes.execute_privilege := osc$local_privilege;
      predecessor_forward_link^.attributes.load_file_number := 0;
      predecessor_forward_link^.library_open := TRUE;
      predecessor_forward_link^.library_valid := TRUE;
      predecessor_forward_link^.phantom_library := FALSE;
      predecessor_forward_link^.phantom_library_active := FALSE;
      predecessor_forward_link^.text_embedded_library := FALSE;

    ELSEIF (library_name (1, loc$deferred_entry_pt_lib_size) = loc$deferred_entry_pt_library) THEN

{ Construct a library descriptor for the deferred entry point "library".  The segment number
{ of the object file is used to find either the file or library descriptor for the object
{ file that the deferred entry points are from.

      search_for_file_descriptor (deferred_library_segment, file_descriptor, file_descriptor_found);

      IF file_descriptor_found THEN
        predecessor_forward_link^.ring_brackets := file_descriptor.ring_brackets;
        predecessor_forward_link^.segment := file_descriptor.segment;
        predecessor_forward_link^.attributes.key_lock := file_descriptor.attributes.key_lock;
        predecessor_forward_link^.attributes.execute_privilege :=
              file_descriptor.attributes.execute_privilege;
          predecessor_forward_link^.attributes.load_file_number :=
                file_descriptor.attributes.load_file_number;
      ELSE
        search_for_library_descriptor (deferred_library_segment, library, library_found);
        IF library_found THEN
          predecessor_forward_link^.ring_brackets := library^.ring_brackets;
          predecessor_forward_link^.segment := library^.segment;
          predecessor_forward_link^.attributes.key_lock := library^.attributes.key_lock;
          predecessor_forward_link^.attributes.execute_privilege := library^.attributes.execute_privilege;
            predecessor_forward_link^.attributes.load_file_number := library^.attributes.load_file_number;
        IFEND;
      IFEND;

      predecessor_forward_link^.attributes.library_file := TRUE;
      predecessor_forward_link^.library_open := TRUE;
      predecessor_forward_link^.library_valid := TRUE;
      predecessor_forward_link^.phantom_library := FALSE;
      predecessor_forward_link^.phantom_library_active := FALSE;
      predecessor_forward_link^.text_embedded_library := FALSE;
    IFEND;

  PROCEND add_library_to_list;
?? OLDTITLE ??
?? NEWTITLE := 'build_library_descriptor', EJECT ??

  PROCEDURE build_library_descriptor
    (VAR predecessor_forward_link: ^lot$library_descriptor);

{  PURPOSE:
{    This procedure is responsible for building a library_list entry.
{

    VAR
      library: ^lot$library_descriptor,
      malfunction_status: ^ost$status,
      abort_status: ^ost$status;


    IF lov$library_list.container = NIL THEN
      library := NIL;
    ELSE
      NEXT library IN lov$library_list.container;
    IFEND;

    IF library = NIL THEN
      lop$augment_lib_list_container;
      NEXT library IN lov$library_list.container;
      IF library = NIL THEN
        PUSH malfunction_status;
        osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'add library to list', malfunction_status^);
        PUSH abort_status;
        pmp$cause_condition (loe$loader_malfunction, malfunction_status, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
    IFEND;
    library^.nnext := predecessor_forward_link;
    predecessor_forward_link := library;

  PROCEND build_library_descriptor;
?? OLDTITLE ??
?? NEWTITLE := 'search_for_file_descriptor', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to search through the list of file
{   descriptors for one with a matching segment number.

  PROCEDURE search_for_file_descriptor
    (    segment_number: ost$segment;
     VAR file_descriptor: lot$file_descriptor;
     VAR file_descriptor_found: boolean);

    VAR
      i: pmt$number_of_object_files;

    file_descriptor_found := FALSE;
    IF lov$file_descriptors <> NIL THEN
      FOR i := 1 TO UPPERBOUND (lov$file_descriptors^) DO
        IF segment_number = #SEGMENT (lov$file_descriptors^ [i].segment) THEN
          file_descriptor_found := TRUE;
          file_descriptor := lov$file_descriptors^ [i];
          RETURN;
        IFEND;
      FOREND;
    IFEND;
  PROCEND search_for_file_descriptor;
?? OLDTITLE ??
?? NEWTITLE := 'search_for_library_descriptor', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to search through the library list
{   for an entry with a matching segment number.

  PROCEDURE search_for_library_descriptor
    (    segment_number: ost$segment;
     VAR library: ^lot$library_descriptor;
     VAR library_found: boolean);

    library_found := FALSE;
    library := lov$library_list.first;
    WHILE library <> NIL DO
      IF (library^.attributes.name (1, loc$deferred_entry_pt_lib_size) <> loc$deferred_entry_pt_library) AND
            (segment_number = #SEGMENT (library^.segment)) THEN
        library_found := TRUE;
        RETURN;
      IFEND;
      library := library^.nnext;
    WHILEND;
  PROCEND search_for_library_descriptor;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$open_library ', EJECT ??

  PROCEDURE [XDCL] lop$open_library
    (    library_name: amt$local_file_name;
     VAR file_descriptor {input_output} : lot$file_descriptor;
     VAR library_valid {control} : boolean);

    VAR
      file_loadable: boolean,
      library_header: ^llt$object_library_header,
      library_hdr: ^llt$object_library_header_v1_0,
      entry_dictionary: ^llt$entry_point_dictionary,
      module_dictionary: ^llt$module_dictionary,
      number_of_modules: 0 .. llc$max_modules_in_library,
      number_of_entry_points: 0 .. llc$max_entry_points_in_library,
      library_dictionary: ^llt$object_library_dictionaries,
      i: 0 .. llc$max_dictionaries_on_library;

    #KEYPOINT (osk$entry, 0, lok$open_library);

    library_valid := FALSE;

    lop$build_file_descriptor (library_name, file_loadable, file_descriptor);
    IF NOT file_loadable THEN
      #KEYPOINT (osk$exit, 0, lok$open_library);
      RETURN;
    IFEND;
    IF NOT file_descriptor.attributes.library_file THEN
      lop$report_error (lle$file_not_library, library_name, '', 0);
      #KEYPOINT (osk$exit, 0, lok$open_library);
      RETURN;
    IFEND;

{ Verify that dictionaries are accessible.

    RESET file_descriptor.segment;
    NEXT library_header IN file_descriptor.segment;
    IF library_header = NIL THEN
      lop$report_error (lle$library_header_missing, library_name, '', 0);
      #KEYPOINT (osk$exit, 0, lok$open_library);
      RETURN
    IFEND;

    IF library_header^.version = llc$object_library_version THEN

      NEXT library_dictionary: [1 .. library_header^.number_of_dictionaries] IN file_descriptor.segment;
      IF library_dictionary = NIL THEN
        lop$report_error (lle$library_header_missing, library_name, '', 0);
        #KEYPOINT (osk$exit, 0, lok$open_library);
        RETURN;
      IFEND;

      number_of_modules := 0;
      number_of_entry_points := 0;

      FOR i := LOWERBOUND (library_dictionary^) TO UPPERBOUND (library_dictionary^) DO
        CASE library_dictionary^ [i].kind OF
        = llc$module_dictionary =
          module_dictionary := #PTR (library_dictionary^ [i].module_dictionary, file_descriptor.segment^);
          number_of_modules := UPPERBOUND (module_dictionary^);
        = llc$entry_point_dictionary =
          entry_dictionary := #PTR (library_dictionary^ [i].entry_point_dictionary, file_descriptor.segment^);
          number_of_entry_points := UPPERBOUND (entry_dictionary^);
        ELSE

        CASEND;
      FOREND;

    ELSEIF library_header^.version = 'V1.0' THEN

      RESET file_descriptor.segment;

      NEXT library_hdr IN file_descriptor.segment;
      IF library_hdr = NIL THEN
        lop$report_error (lle$library_header_missing, library_name, '', 0);
        #KEYPOINT (osk$exit, 0, lok$open_library);
        RETURN;
      IFEND;

      number_of_modules := library_hdr^.number_of_modules;
      module_dictionary := #PTR (library_hdr^.module_dictionary, file_descriptor.segment^);
      number_of_entry_points := library_hdr^.number_of_entry_points;
      entry_dictionary := #PTR (library_hdr^.entry_point_dictionary, file_descriptor.segment^);

    ELSE
      lop$report_error (lle$wrong_library_version, llc$object_library_version, library_name, 0);
      #KEYPOINT (osk$exit, 0, lok$open_library);
      RETURN;
    IFEND;

    IF number_of_modules = 0 THEN
      lop$report_error (lle$empty_module_dictionary, library_name, '', 0);
      #KEYPOINT (osk$exit, 0, lok$open_library);
      RETURN
    IFEND;
    IF module_dictionary = NIL THEN
      lop$report_error (lle$bad_module_dictionary_ptr, library_name, '', 0);
      #KEYPOINT (osk$exit, 0, lok$open_library);
      RETURN
    IFEND;
    IF number_of_entry_points <> 0 THEN
      IF entry_dictionary = NIL THEN
        lop$report_error (lle$bad_entry_dictionary_ptr, library_name, '', 0);
        #KEYPOINT (osk$exit, 0, lok$open_library);
        RETURN
      IFEND;
    IFEND;

    library_valid := TRUE;

    #KEYPOINT (osk$exit, 0, lok$open_library);

  PROCEND lop$open_library;
?? OLDTITLE ??
?? NEWTITLE := 'lop$find_library_descriptor', EJECT ??

  PROCEDURE [XDCL] lop$find_library_descriptor
    (    library_name: amt$local_file_name;
     VAR library {input_output} : ^lot$library_descriptor;
     VAR library_found {control} : boolean);

{  PURPOSE:
{    This procedure is returns a pointer to the library_descriptor in the library_list corresponding to
{    the library name.  If the library is not in the library_list then library_found is set to FALSE.
{

    library_found := TRUE;
    library := lov$library_list.first;
    WHILE library <> NIL DO
      IF library_name = library^.attributes.name THEN
        RETURN
      IFEND;
      library := library^.nnext
    WHILEND;
    library_found := FALSE;

  PROCEND lop$find_library_descriptor;
?? OLDTITLE ??
MODEND lom$library_list_management;
*DECK DECK=LOM$LINKAGE_GENERATION EXPAND=TRUE
?? RIGHT := 110 ??
*copyc OSD$DEFAULT_PRAGMATS
?? TITLE := 'NOS/VE : Loader : Linkage generation' ??
?? NEWTITLE := '  Global declarations', EJECT ??
MODULE lom$linkage_generation;

{  PURPOSE:
{    This module is responsible for generation of all linkages (pointers) to program addresses.  Since
{    linkages are the only data that may be stored in the binding segment, this is the only module
{    which needs write access to the binding segment.  It executes in a more privileged
{    environment (ring) than the remainder of the loader -- thereby allowing the binding segment to
{    have more stringent access protection.  Since different types of linkages exist, this module
{    also isolates the knowledge of the formats of the various types of linkages.
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
*copyc LOE$ABORT_LOAD
*copyc LLE$LOADER_STATUS_CONDITIONS
?? POP ??
*copyc i#build_adaptable_array_ptr
*copyc MMP$STORE_SEGMENT_ATTRIBUTES
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$CAUSE_CONDITION
*copyc PMP$EXIT
?? TITLE := '  [XDCL, #GATE] lop$copy_binding_section_text', EJECT ??

  PROCEDURE [XDCL, #GATE] lop$copy_binding_section_text (target_address: lot$address;
        text: ^array [1 .. *] of 0 .. 0ff(16);
    VAR any_code_base_ptrs__initialized: boolean);


    TYPE
      binding_section_word = record
        first_two_bytes: 0 .. 0ffff(16),
        remaining_bytes: 0 .. 0ffffffffffff(16),
      recend;

    VAR
      of_execution: ^cell,
      target_byte: ^array [1 .. *] of 0 .. 255,
      target_word: ^array [1 .. *] of binding_section_word,
      starting_word_address: ost$segment_length,
      number_of_words: ost$segment_length,
      i: integer,
      j: integer,
      abort_status: ^ost$status;


    i#build_adaptable_array_ptr (#RING (^of_execution), target_address.segment, target_address.
          offset, UPPERBOUND (text^), LOWERBOUND (text^), 1, #LOC (target_byte));

    target_byte^ := text^;

    starting_word_address := (target_address.offset DIV 8) * 8;  { Round of to a word boundry. }
    number_of_words := (#SIZE (text^) + 7) DIV 8;

    i#build_adaptable_array_ptr (#RING (^of_execution), target_address.segment, starting_word_address,
          (number_of_words * 8), 1, 8, #LOC (target_word));

    FOR i := 1 TO number_of_words DO
      IF (target_word^ [i].first_two_bytes <> 0) THEN
        any_code_base_ptrs__initialized := TRUE;

        FOR j := 1 TO number_of_words DO
          target_word^ [j].first_two_bytes := 0;
          target_word^ [j].remaining_bytes := 0;
        FOREND;

        RETURN;  {----->
      IFEND;
    FOREND;

    any_code_base_ptrs__initialized := FALSE;


  PROCEND lop$copy_binding_section_text;
?? TITLE := '  [XDCL, #GATE] lop$fix_binding_segment_attr', EJECT ??

  PROCEDURE [XDCL, #GATE] lop$fix_binding_segment_attr (binding_segment: ost$segment;
        current_length: ost$segment_length;
    VAR status: ost$status);

{  PURPOSE:
{    This procedure is responsible for fixing the binding segment's attributes to those required
{    for the loaded program's usage (as opposed to the loader's usage).
*copyc LOV$BINDING_SEGMENT_ATTRIBUTES

    VAR
      attribute_fixer: array [1 .. 2] of mmt$attribute_descriptor,
{!   temporary variable until CYBIL is fixed for intrinsics in procedure call
      temporary_ptr: ^cell;

    attribute_fixer [1].keyword := mmc$kw_segment_access_control;
    attribute_fixer [1].access_control := binding_segment_attributes.access_control;
    attribute_fixer [2].keyword := mmc$kw_max_segment_length;
{ Add eight bytes to current length to prevent a THETA page fault if a one word CBP occurs in the last word
{  of a page.
    attribute_fixer [2].max_length := current_length + 8;
{!  mmp$store_segment_attributes (#address (osc$min_ring, binding_segment, 0), osc$min_ring, attribute_fixer,
{!   temporary code until CYBIL is fixed - intrinsics in procedure call
    temporary_ptr := #address (osc$min_ring, binding_segment, 0);
    mmp$store_segment_attributes (temporary_ptr, osc$min_ring, attribute_fixer,
{!   End of temporary code.
    status);
  PROCEND lop$fix_binding_segment_attr;
?? TITLE := '  [XDCL, #GATE] lop$defix_binding_segment_attr', EJECT ??

  PROCEDURE [XDCL, #GATE] lop$defix_binding_segment_attr (binding_segment: ost$segment;
        maximum_length: ost$segment_length;
    VAR status {control} : ost$status);

{  PURPOSE:
{    This procedure is responsible for restoring the binding segment's attributes to those required
{    for the loader's usage (as opposed to the loaded program's usage).

    VAR
      attribute_defixer: array [1 .. 2] of mmt$attribute_descriptor,
{!   temporary variable until CYBIL is fixed for intrinsics in a procedure call
      temporary_ptr: ^cell;

    attribute_defixer [1].keyword := mmc$kw_segment_access_control;
    attribute_defixer [1].access_control.cache_bypass := FALSE;
    attribute_defixer [1].access_control.execute_privilege := osc$non_executable;
    attribute_defixer [1].access_control.read_privilege := osc$binding_segment;
    attribute_defixer [1].access_control.write_privilege := osc$write_uncontrolled;
    attribute_defixer [2].keyword := mmc$kw_max_segment_length;
    attribute_defixer [2].max_length := maximum_length;
{!  mmp$store_segment_attributes (#address (osc$min_ring, binding_segment, 0), osc$min_ring,
{!   temporary code until CYBIL is fixed - intrinsics in a procedure call
    temporary_ptr := #address (osc$min_ring, binding_segment, 0);
    mmp$store_segment_attributes (temporary_ptr, osc$min_ring,
{!   End of temporary code.
    attribute_defixer, status);
  PROCEND lop$defix_binding_segment_attr;
MODEND lom$linkage_generation;
*DECK DECK=LOM$LINKAGE_NAME_TREE_MGMT EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE : Loader : Linkage_name_tree_mgmt' ??
?? NEWTITLE := '  Global declarations', EJECT ??
MODULE lom$linkage_name_tree_mgmt;

{  PURPOSE:
{    This module is responsible for all processing of the linkage name tree.  All procedures
{    which access the tree reside here in order to limit the scope of the tree.
{  DESIGN:
{    The linkage name tree is a balanced binary tree which is keyed by linkage name (entry_point
{    name or external name).  Each node of the tree contains a pointer to a list of entry
{    definitions for the linkage name and a pointer to a list of unsatisfied references for the
{    linkage name.  The various procedures in this module exist to provide different types of
{    access to the information in the tree.
{
{    The purpose of the linkage name tree is to provide an "index" to the linkage name lists.
{    Since searches of the entry definitions list and unsatisfied references list are frequent, it is
{    desireable to minimize both the search time and the amount of virtual memory traversed by a
{    search.  Using a balanced tree structure reduces the search time.  Having the tree contain only
{    information necessary to perform the search reduces virtual memory usage.

{  NOTE:
{    Conditions raised: LOE$ABORT_LOAD, LOE$LOADER_MALFUNCTION.
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
*copyc LOE$ABORT_LOAD
?? POP ??
*copyc MMP$CREATE_SEGMENT
*copyc MMP$DELETE_SEGMENT
*copyc PMP$CAUSE_CONDITION
*copyc PMP$EXIT
*copyc LOP$REPORT_ERROR

  TYPE
    lot$linkage_tree = record
      root: ^lot$linkage_tree_node,
      container: ^SEQ ( * ),
    recend,

    lot$linkage_tree_node = record
      linkage_info: lot$linkage_name_lists,
      balance: lot$node_balance_factor,
      less,
      greater: ^lot$linkage_tree_node,
    recend,

    lot$node_balance_factor = (loc$balanced, loc$weighted_less, loc$weighted_greater);

  VAR
    linkage_tree: [STATIC] lot$linkage_tree := [NIL, NIL];

?? TITLE := '  [XDCL] lop$find_linkage_name_lists' ??
?? EJECT ??

  PROCEDURE [XDCL] lop$find_linkage_name_lists (linkage_name: pmt$program_name;
    VAR linkage: ^lot$linkage_name_lists);

{  PURPOSE:
{    This procedure is responsible for finding the node of the linkage name tree corresponding to a
{    specified linkage name and returning the list pointers contained in the node.  If no node
{    exists for the specified linkage name, then a new node is created and inserted into the proper
{    position in the tree.
*copyc LOV$SECONDARY_STATUS

    VAR
      node_created: boolean,
      node,
      subtree_root,
      new_subtree_root,
      subtree_changed_branch: ^lot$linkage_tree_node,
      subtree_pointer: ^^lot$linkage_tree_node,
      new_balance,
      opposite_balance: lot$node_balance_factor,
      segment_pointer: mmt$segment_pointer,
      abort_status: ^ost$status;

    IF linkage_tree.container = NIL THEN
      mmp$create_segment (NIL, mmc$sequence_pointer, loc$loader_ring, segment_pointer, lov$secondary_status);
      IF NOT lov$secondary_status.normal THEN
        lop$report_error (lle$unable_to_create_table, 'LINKAGE NAME TREE', '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
      linkage_tree.container := segment_pointer.seq_pointer;
      NEXT linkage_tree.root IN linkage_tree.container;
      IF linkage_tree.root = NIL THEN
        lop$report_error (lle$loader_table_overflow, 'LINKAGE NAME TREE', '', 0);
        PUSH abort_status;
        pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
      node := linkage_tree.root;
      node^.linkage_info.name := linkage_name;
      node^.balance := loc$balanced;
      node^.less := NIL;
      node^.greater := NIL;
      node^.linkage_info.definitions_list := NIL;
      node^.linkage_info.unsat_references_list := NIL;
      linkage := ^node^.linkage_info;
      RETURN
    IFEND;
    subtree_pointer := ^linkage_tree.root;
    node := subtree_pointer^;
    subtree_root := subtree_pointer^;
    node_created := FALSE;

    REPEAT
      IF linkage_name = node^.linkage_info.name THEN
        linkage := ^node^.linkage_info;
        RETURN
      ELSE
        IF linkage_name < node^.linkage_info.name THEN
          IF node^.less = NIL THEN
            NEXT node^.less IN linkage_tree.container;
            IF node^.less = NIL THEN
              lop$report_error (lle$loader_table_overflow, 'LINKAGE NAME TREE', '', 0);
              PUSH abort_status;
              pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
              pmp$exit (abort_status^);
            IFEND;
            node_created := TRUE;
          ELSE
            IF node^.less^.balance <> loc$balanced THEN
              subtree_pointer := ^node^.less;
              subtree_root := subtree_pointer^;
            IFEND;
          IFEND;
          node := node^.less;
        ELSE
          IF node^.greater = NIL THEN
            NEXT node^.greater IN linkage_tree.container;
            IF node^.greater = NIL THEN
              lop$report_error (lle$loader_table_overflow, 'LINKAGE NAME TREE', '', 0);
              PUSH abort_status;
              pmp$cause_condition (loe$insufficient_memory, NIL, abort_status^);
              pmp$exit (abort_status^);
            IFEND;
            node_created := TRUE;
          ELSE
            IF node^.greater^.balance <> loc$balanced THEN
              subtree_pointer := ^node^.greater;
              subtree_root := subtree_pointer^;
            IFEND;
          IFEND;
          node := node^.greater;
        IFEND;
      IFEND;
    UNTIL node_created;

    node^.linkage_info.name := linkage_name;
    node^.balance := loc$balanced;
    node^.less := NIL;
    node^.greater := NIL;
    node^.linkage_info.definitions_list := NIL;
    node^.linkage_info.unsat_references_list := NIL;
    linkage := ^node^.linkage_info;

    IF linkage_name < subtree_root^.linkage_info.name THEN
      node := subtree_root^.less;
      new_balance := loc$weighted_less;
    ELSE
      node := subtree_root^.greater;
      new_balance := loc$weighted_greater;
    IFEND;
    subtree_changed_branch := node;
    WHILE linkage_name <> node^.linkage_info.name DO
      IF linkage_name < node^.linkage_info.name THEN
        node^.balance := loc$weighted_less;
        node := node^.less;
      ELSE
        node^.balance := loc$weighted_greater;
        node := node^.greater;
      IFEND;
    WHILEND;

    IF subtree_root^.balance = loc$balanced THEN
      subtree_root^.balance := new_balance;
    ELSE
      IF subtree_root^.balance = new_balance THEN {tree is out of balance}
        IF subtree_changed_branch^.balance = new_balance THEN {perform single rotation}
          new_subtree_root := subtree_changed_branch;
          IF new_balance = loc$weighted_less THEN
            subtree_root^.less := subtree_changed_branch^.greater;
            subtree_changed_branch^.greater := subtree_root;
          ELSE
            subtree_root^.greater := subtree_changed_branch^.less;
            subtree_changed_branch^.less := subtree_root;
          IFEND;
          subtree_root^.balance := loc$balanced;
          subtree_changed_branch^.balance := loc$balanced;
        ELSE {perform double rotation}
          IF new_balance = loc$weighted_less THEN
            new_subtree_root := subtree_changed_branch^.greater;
            subtree_changed_branch^.greater := new_subtree_root^.less;
            new_subtree_root^.less := subtree_changed_branch;
            subtree_root^.less := new_subtree_root^.greater;
            new_subtree_root^.greater := subtree_root;
            opposite_balance := loc$weighted_greater;
          ELSE
            new_subtree_root := subtree_changed_branch^.less;
            subtree_changed_branch^.less := new_subtree_root^.greater;
            new_subtree_root^.greater := subtree_changed_branch;
            subtree_root^.greater := new_subtree_root^.less;
            new_subtree_root^.less := subtree_root;
            opposite_balance := loc$weighted_less;
          IFEND;
          IF new_subtree_root^.balance = loc$balanced THEN
            subtree_root^.balance := loc$balanced;
            subtree_changed_branch^.balance := loc$balanced;
          ELSE
            IF new_subtree_root^.balance = new_balance THEN
              subtree_root^.balance := opposite_balance;
              subtree_changed_branch^.balance := loc$balanced;
            ELSE
              subtree_root^.balance := loc$balanced;
              subtree_changed_branch^.balance := new_balance;
            IFEND;
          IFEND;
          new_subtree_root^.balance := loc$balanced;
        IFEND;
        subtree_pointer^ := new_subtree_root;
      ELSE {tree has gotten more balanced}
        subtree_root^.balance := loc$balanced;
      IFEND;
    IFEND;
  PROCEND lop$find_linkage_name_lists;

?? TITLE := '  [XDCL] lop$process_all_entry_definitns', EJECT ??

  PROCEDURE [XDCL] lop$process_all_entry_definitns (processor: ^procedure (name: pmt$program_name;
        ptr: ^^lot$entry_definition));

{  PURPOSE:
{    This procedure scans the linkage name tree (in lexical order) for nodes which have non_NIL
{    entry definition list pointers.  For each such node, a procedure (which has been supplied
{    as a parameter) is called to process the list of entry definitions.

    IF linkage_tree.root <> NIL THEN
      process_nodes_in_lexical_order (processor, linkage_tree.root);
    IFEND;
  PROCEND lop$process_all_entry_definitns;
?? TITLE := '  process_nodes_in_lexical_order', EJECT ??

  PROCEDURE process_nodes_in_lexical_order (processor: ^procedure (name: pmt$program_name;
        ptr: ^^lot$entry_definition);
        node: ^lot$linkage_tree_node);

{  PURPOSE:
{    This procedure performs a lexical order scan of the linkage name tree.  It examines each node
{    to determine if the node has a non_NIL list pointer of appropriate type (entry definition or
{    unsatisfied reference, depending on an input parameter) and, if so, calls a procedure to process
{    the list.
{  NOTE:
{    This procedure could be implemented as an inline loop with its own stacking mechanism if the
{    cost of recursion proves excessive.

    IF node^.less <> NIL THEN
      process_nodes_in_lexical_order (processor, node^.less);
    IFEND;
    IF node^.linkage_info.definitions_list <> NIL THEN
      processor^ (node^.linkage_info.name, ^node^.linkage_info.definitions_list);
    IFEND;
    IF node^.greater <> NIL THEN
      process_nodes_in_lexical_order (processor, node^.greater);
    IFEND;

  PROCEND process_nodes_in_lexical_order;
?? TITLE := '[XDCL] lop$delete_linkage_tree', EJECT ??

*copyc loh$delete_linkage_tree

  PROCEDURE [XDCL] lop$delete_linkage_tree;

    linkage_tree.container := NIL;
    linkage_tree.root := NIL;

  PROCEND lop$delete_linkage_tree;
MODEND lom$linkage_name_tree_mgmt;
*DECK DECK=LOM$LOADER_EXECUTIVE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Loader : Executive' ??
MODULE lom$loader_executive;

{  PURPOSE:
{    This module contains executive components which exercise high level control and coordination for
{    loader processes.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amd$open_declarations
*copyc amt$file_byte_address
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc amt$segment_pointer
*copyc amt$term_option
*copyc cyd$cybil_structure_definitions
*copyc cyd$run_time_error_condition
*copyc fst$file_reference
*copyc lle$load_map_diagnostics
*copyc lle$loader_status_conditions
*copyc loc$deferred_entry_pt_library
*copyc loc$task_services_library_name
*copyc loe$abort_load
*copyc loe$map_malfunction
*copyc lok$keypoints
*copyc lot$deferred_library_list
*copyc lot$loader_options
*copyc lot$loader_type_definitions
*copyc osd$code_base_pointer
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc ost$status
*copyc pmc$default_user_stack_size
*copyc pme$execution_exceptions
*copyc pme$insufficient_privilege
*copyc pme$program_services_exceptions
*copyc pmk$keypoints
*copyc pmt$loaded_address
*copyc pmt$loader_seq_descriptor
*copyc sft$audit_information
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$put_next
*copyc avp$ring_nominal
*copyc avp$security_option_active
*copyc clp$convert_integer_to_string
*copyc clp$convert_str_to_path_handle
*copyc fsp$change_segment_number
*copyc fsp$close_file
*copyc fsp$open_file
*copyc lop$activate_library
*copyc lop$add_deferred_common_blocks
*copyc lop$add_program_load_libraries
*copyc lop$add_unsatisfied_ref_to_list
*copyc lop$augment_dynamic_loaded_eps
*copyc lop$deactivate_library
*copyc lop$defix_program_segment_attr
*copyc lop$determine_initial_ring
*copyc lop$establish_transfer_symbol
*copyc lop$find_entry_point_residence
*copyc lop$find_linkage_name_lists
*copyc lop$find_matching_entry_point
*copyc lop$finish_load_map
*copyc lop$fix_program_segment_attr
*copyc lop$gen_init_intercept_linkage
*copyc lop$generate_cross_refernce_map
*copyc lop$generate_load_map_text
*copyc lop$generate_segment_map
*copyc lop$initialize_apd_processing
*copyc lop$initialize_load_map
*copyc lop$load_module
*copyc lop$load_module_list
*copyc lop$load_object_files
*copyc lop$reinitialize_module
*copyc lop$release_transient_segments
*copyc lop$reserve_storage
*copyc lop$satisfy_externals
*copyc lop$search_entry_pt_dictionary
*copyc lop$store_intercept_linkage
*copyc lop$store_linkage
*copyc mmp$fetch_segment_attributes
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$format_message
*copyc osp$generate_message
*copyc osp$get_status_severity
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$exit
*copyc pmp$find_prog_options_and_libs
*copyc pmp$get_entry_point_dictionary
*copyc pmp$intercept_call_procedure
*copyc pmp$log
*copyc sfp$emit_audit_statistic
*copyc lov$apd_load
*copyc lov$common_blocks
*copyc lov$deferred_common_blocks
*copyc lov$deferred_entry_points
*copyc lov$dynamic_loaded_entry_points
*copyc lov$head_of_unsat_ref_list
*copyc osv$task_private_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR

{!  Use the following when CYBIL supports UPPERVALUE in initialization expressions:
{!    lov$diagnostic_count: [XDCL] array [ost$status_severity] of 0 .. 0ffff(16) := [REP (ORD
{(UPPERVALUE
{!      (ost$status_severity)) + 1) of 0];

    lov$diagnostic_count: [XDCL] array [ost$status_severity] of 0 .. 0ffff(16) := [REP 5 of 0];

  VAR
    lov$secondary_status: [XDCL] ost$status := [TRUE];

  VAR
    lov$file_descriptors: [XDCL] ^array [1 .. * ] of lot$file_descriptor := NIL,
    lov$loader_options: [XDCL] lot$loader_options := ['loadmap', $pmt$load_map_options [pmc$no_load_map],
          pmc$warning_load_errors, 0, pmc$default_user_stack_size, * ];

  VAR
    map_malfunction: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
          [pmc$user_defined_condition, loe$map_malfunction],
    termination_conditions: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
          [pmc$condition_combination, $pmt$condition_combination
          [pmc$system_conditions, mmc$segment_access_condition, pmc$user_defined_condition]];

  VAR
    access_selections: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 2] of fst$attachment_option := [[fsc$access_and_share_modes,
          [fsc$specific_access_modes, [fsc$shorten, fsc$append]], [fsc$required_share_modes]],
          [fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$append]],
          [fsc$required_share_modes]]],
    error_file_id: [STATIC] amt$file_identifier,
    error_file_name: [STATIC, READ, oss$job_paged_literal] amt$local_file_name := '$ERRORS',
    error_file_opened: [STATIC] boolean := FALSE,
    list_modules: [STATIC] boolean := FALSE,
    first_severity_to_check: [STATIC] ost$status_severity,
    lop$load_program_can_be_called: [STATIC] boolean := TRUE,
    loader_running: [STATIC] boolean := TRUE;

  CONST
    loc$referenced_by_dynamic_load = '***** DYNAMIC LOAD *****       ';

  VAR

{   The following variable controls the fixing and defixing of program segment
{   attributes during dynamic load (pmp$load and lop$load_entry_point):
{     TRUE: program load is active - do not fix or defix program segment attributes
{           during dynamic load;
{     FALSE: program load is not active - fix and defix program segment attributes
{            during dynamic load.

    lov$program_load: [STATIC] boolean := FALSE;

?? OLDTITLE ??
?? NEWTITLE := 'find_dynamic_loaded_ep', EJECT ??

{ PURPOSE:
{   The purpose of this request is to find the address of a previously
{   dynamically loaded entry point.

  PROCEDURE find_dynamic_loaded_ep
    (    name: pmt$program_name;
         reference_ring: ost$valid_ring;
     VAR entry_point_found: boolean;
     VAR address: pmt$loaded_address);

    VAR
      temp: integer,
      hi: ost$non_negative_integers,
      lo: ost$non_negative_integers,
      mid: ost$non_negative_integers;


    entry_point_found := FALSE;

    IF lov$dynamic_loaded_entry_points = NIL THEN
      RETURN;
    IFEND;

    hi := lov$dynamic_loaded_entry_points^.number_of_entry_points;
    lo := 1;

    WHILE (lo <= hi) AND NOT entry_point_found DO
      temp := lo + hi;
      mid := temp DIV 2;
      IF name = lov$dynamic_loaded_entry_points^.container^ [mid].program_name THEN
        IF reference_ring = lov$dynamic_loaded_entry_points^.container^ [mid].reference_ring THEN
          entry_point_found := TRUE;
        ELSEIF reference_ring < lov$dynamic_loaded_entry_points^.container^ [mid].reference_ring THEN
          hi := mid - 1;
        ELSE
          lo := mid + 1;
        IFEND;

      ELSEIF name < lov$dynamic_loaded_entry_points^.container^ [mid].program_name THEN
        hi := mid - 1;
      ELSE
        lo := mid + 1;
      IFEND;
    WHILEND;

    IF entry_point_found THEN
      address := lov$dynamic_loaded_entry_points^.container^ [mid].loaded_address;
    IFEND;

  PROCEND find_dynamic_loaded_ep;
?? OLDTITLE ??
?? NEWTITLE := 'record_dynamic_loaded_ep', EJECT ??

{ PURPOSE:
{   The purpose of this request is to save the address of a dynamically loaded
{   entry point.  The saved reference may then be used again later if needed.

  PROCEDURE record_dynamic_loaded_ep
    (    name: pmt$program_name;
         reference_ring: ost$valid_ring;
         address: pmt$loaded_address);

    VAR
      temp: integer,
      entry_point: ost$non_negative_integers,
      hi: ost$non_negative_integers,
      lo: ost$non_negative_integers,
      mid: ost$non_negative_integers;


    IF lov$dynamic_loaded_entry_points = NIL THEN
      lop$augment_dynamic_loaded_eps;
    ELSE
      IF lov$dynamic_loaded_entry_points^.number_of_entry_points =
            UPPERBOUND (lov$dynamic_loaded_entry_points^.container^) THEN
        lop$augment_dynamic_loaded_eps;
      IFEND;
    IFEND;

    hi := lov$dynamic_loaded_entry_points^.number_of_entry_points;
    lo := 1;

    WHILE (lo <= hi) DO
      temp := lo + hi;
      mid := temp DIV 2;
      IF name = lov$dynamic_loaded_entry_points^.container^ [mid].program_name THEN
        IF reference_ring = lov$dynamic_loaded_entry_points^.container^ [mid].reference_ring THEN

{ Should never get here.

        ELSEIF reference_ring < lov$dynamic_loaded_entry_points^.container^ [mid].reference_ring THEN
          hi := mid - 1;
        ELSE
          lo := mid + 1;
        IFEND;

      ELSEIF name < lov$dynamic_loaded_entry_points^.container^ [mid].program_name THEN
        hi := mid - 1;
      ELSE
        lo := mid + 1;
      IFEND;
    WHILEND;

    FOR entry_point := lov$dynamic_loaded_entry_points^.number_of_entry_points DOWNTO lo DO
      lov$dynamic_loaded_entry_points^.container^ [entry_point + 1] := lov$dynamic_loaded_entry_points^.
            container^ [entry_point];
    FOREND;
    lov$dynamic_loaded_entry_points^.number_of_entry_points :=
          lov$dynamic_loaded_entry_points^.number_of_entry_points + 1;

    lov$dynamic_loaded_entry_points^.container^ [lo].program_name := name;
    lov$dynamic_loaded_entry_points^.container^ [lo].reference_ring := reference_ring;
    lov$dynamic_loaded_entry_points^.container^ [lo].loaded_address := address;

  PROCEND record_dynamic_loaded_ep;
?? OLDTITLE ??
?? NEWTITLE := 'remove_dynamic_loaded_ep', EJECT ??

{ PURPOSE:
{   The purpose of this request is to find the specified entry in the dynamically
{   loaded entry point list, and remove it.

  PROCEDURE remove_dynamic_loaded_ep
    (    name: pmt$program_name;
         loaded_ring: ost$valid_ring;
         call_bracket: ost$valid_ring);

    VAR
      temp: integer,
      entry_point: ost$non_negative_integers,
      entry_point_found: boolean,
      hi: ost$non_negative_integers,
      lo: ost$non_negative_integers,
      mid: ost$non_negative_integers;


    entry_point_found := FALSE;

    IF lov$dynamic_loaded_entry_points = NIL THEN
      RETURN;
    IFEND;

    hi := lov$dynamic_loaded_entry_points^.number_of_entry_points;
    lo := 1;

    WHILE (lo <= hi) AND NOT entry_point_found DO
      temp := lo + hi;
      mid := temp DIV 2;
      IF name = lov$dynamic_loaded_entry_points^.container^ [mid].program_name THEN
        entry_point_found := TRUE;
      ELSEIF name < lov$dynamic_loaded_entry_points^.container^ [mid].program_name THEN
        hi := mid - 1;
      ELSE
        lo := mid + 1;
      IFEND;
    WHILEND;

    IF entry_point_found THEN

{ Find the entry point whose reference ring fits the call bracket.

      WHILE (mid >= 1) AND (mid <= lov$dynamic_loaded_entry_points^.number_of_entry_points) AND
            (lov$dynamic_loaded_entry_points^.container^ [mid].program_name = name) DO
        IF (lov$dynamic_loaded_entry_points^.container^ [mid].reference_ring >= loaded_ring) THEN
          IF (lov$dynamic_loaded_entry_points^.container^ [mid].reference_ring <= call_bracket) THEN

            FOR entry_point := (mid + 1) TO lov$dynamic_loaded_entry_points^.number_of_entry_points DO
              lov$dynamic_loaded_entry_points^.container^ [entry_point - 1] :=
                    lov$dynamic_loaded_entry_points^.container^ [entry_point];
            FOREND;
            lov$dynamic_loaded_entry_points^.number_of_entry_points :=
                  lov$dynamic_loaded_entry_points^.number_of_entry_points - 1;
            RETURN;
          ELSE
            mid := mid - 1;
          IFEND;
        ELSE
          mid := mid + 1;
        IFEND;
      WHILEND;
    IFEND;

  PROCEND remove_dynamic_loaded_ep;
?? OLDTITLE ??


?? NEWTITLE := '[XDCL] lop$reset_loader_for_2nd_load', EJECT ??

  PROCEDURE [XDCL] lop$reset_loader_for_2nd_load
    (VAR status: ost$status);

    VAR
      i: ost$status_severity;

    status.normal := TRUE;

    IF NOT loader_running THEN
      osp$set_status_abnormal ('LL', lle$loader_stopped, '', status);
      RETURN;
    IFEND;

    FOR i := LOWERVALUE (ost$status_severity) TO UPPERVALUE (ost$status_severity) DO
      lov$diagnostic_count [i] := 0;
    FOREND;

    lop$load_program_can_be_called := TRUE;

  PROCEND lop$reset_loader_for_2nd_load;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$load_program' ??

{  PURPOSE:
{    This procedure is the executive component of the program load process.  It is responsible for
{    controlling and coordinating the loading of a program in response to an execute request.

  PROCEDURE [XDCL] lop$load_program
    (    object_file_list: ^pmt$object_file_list;
         module_list: ^pmt$module_list;
         execute_library_list: ^pmt$object_library_list;
         job_library_list: ^pmt$object_library_list;
         starting_procedure: pmt$program_name;
         target_ring: ost$ring;
         loader_options_value: lot$loader_options;
         mpe_description: ^pmt$loader_description;
     VAR loaded_program_cbp: ^ost$external_code_base_pointer;
     VAR status {control} : ost$status);

    VAR
      finish_load_map: boolean;

    CONST
      normal_termination = TRUE,
      premature_termination = FALSE;

?? NEWTITLE := 'load_map_malfunction', EJECT ??

{  PURPOSE:
{     The purpose of this condition handler is to terminate the task if
{     initialize or generate load map detects an unexpected abnormal status
{     from a NOS/VE request - the task exits with the unexpected status.

    PROCEDURE load_map_malfunction
      (    condition: pmt$condition;
           system_status: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        malfunction: ^ost$status;

      malfunction := system_status;
      #KEYPOINT (osk$exit, 0, lok$load_program);
      pmp$exit (malfunction^);
    PROCEND load_map_malfunction;
?? OLDTITLE ??
?? NEWTITLE := 'terminate_prematurely', EJECT ??

{   PURPOSE:
{      Circumstances may arise within the loader which cause premature termination
{      of the load process.  These circumstances are reported within the loader via
{      conditions.  This condition handler is responsible for fielding the condition;
{      reporting the abnormality; and prematurely terminating the load process.
{
{      The conditions and their meanings are:
{      1.  system conditions: the hardware detected a condition which is probably
{          caused by a loader coding error.  The specific condition is reported to
{          the output file and the task is terminated with the loader malfunctioned
{          exception code.  SEE: code for pmc$detected_uncorrected_err processing.
{      2.  segment access conditions:
{          a. mmc$sac_read_beyond_eoi, mmc$sac_segment_access_error,
{             mmc$sac_key_lock_violation, mmc$sac_ring_violation:
{             segment management detected an inconsistency which was probably
{             caused by a loader coding error.  The specific condition is reported
{             to the output file and the task is terminated with the loader
{             malfunctioned exception code.
{          b. mmc$sac_read_write_beyond_msl: user limits prevented the loader from
{             completing the load process.  The task is terminated with the
{             insufficient memory to load exception code.
{          c. mmc$sac_io_read_error: a hardware error was detected attempting to
{             read a page from a device.  The specific condition is reported to
{             the output file and the task is terminated with the premature load
{             termination exception code.
{      3.  user defined conditions:
{          a. cye$run_time_condition: the CYBIL run time checking detected an
{             error which was probably cause by a loader coding error.  The
{             specific condition is reported to the output file and the task is
{             terminated with loader malfunctioned exception code.
{          b. loe$abort_load: several constituent procedures of the loader detect
{             circumstances which prohibit continuation of the load process.  The
{             detecting procedure reports the circumstance to load map and causes
{             the loe$abort_load condition.  This condition handler terminates the
{             task with the premature load termination exception code.
{          c. loe$loader_malfunction: a constituent procedure of the loader
{             detected an inconsistency which probably was caused by a loader
{             coding error.  The detecting procedure causes the condition
{             pointing to a status variable which identifies the inconsistency.
{             This condition handler reports the identified inconsistency to
{             the output file and terminates the task with the loader malfunctioned
{             exception code.
{          d. loe$insufficient_memory: several constituent procedures of the
{             loader detect circumstances where there is not enough virtual memory
{             to complete the load process - this is generally a case of user
{             limit being exceeded.  The detecting procedure reports the shortage
{             to the load map and causes the condition.  This condition handler
{             terminates the task with insufficient memory to load exception code.
{          e. other: other user defined conditions will be continued and
{             otherwise ignored.
{

    PROCEDURE terminate_prematurely
      (    condition: pmt$condition;
           malfunction_status: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        termination_descriptor: pmt$established_handler,
        cybil_error: ^ost$status,
        malfunction: ^ost$status,
        message: ost$status;

      CASE condition.selector OF
      = pmc$system_conditions =
        osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
        IF NOT (pmc$detected_uncorrected_err IN condition.system_conditions) THEN
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'PROGRAM', status);
        ELSE
          status := message;
        IFEND;
      = mmc$segment_access_condition =
        CASE condition.segment_access_condition.identifier OF
        = mmc$sac_read_beyond_eoi, mmc$sac_segment_access_error, mmc$sac_key_lock_violation,
              mmc$sac_ring_violation =
          osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'PROGRAM', status);
        = mmc$sac_read_write_beyond_msl =
          osp$set_status_abnormal ('LL', lle$insufficient_memory_to_load, '', status);
        = mmc$sac_io_read_error =
          osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$premature_load_termination, 'Program', status);
        ELSE
          osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$premature_load_termination, 'Program', status);
        CASEND;
      = pmc$user_defined_condition =
        IF (condition.user_condition_name = cye$run_time_condition) THEN
          cybil_error := malfunction_status;
          osp$generate_message (cybil_error^, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'PROGRAM', status);
        ELSEIF (condition.user_condition_name = loe$abort_load) THEN
          osp$set_status_abnormal ('LL', lle$premature_load_termination, 'Program', status);
        ELSEIF (condition.user_condition_name = loe$loader_malfunction) THEN
          malfunction := malfunction_status;
          osp$generate_message (malfunction^, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'PROGRAM', status);
        ELSEIF (condition.user_condition_name = loe$insufficient_memory) THEN
          osp$set_status_abnormal ('LL', lle$insufficient_memory_to_load, '', status);
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          RETURN;
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        RETURN;
      CASEND;
      IF finish_load_map THEN
        finish_load_map := FALSE;
        pmp$establish_condition_handler (termination_conditions, ^terminate_prematurely,
              ^termination_descriptor, condition_status);
        lop$finish_load_map (control_options.map, transfer_descriptor, premature_termination);
      IFEND;
      #KEYPOINT (osk$exit, 0, lok$load_program);
      EXIT lop$load_program;
    PROCEND terminate_prematurely;
?? OLDTITLE, EJECT ??

    VAR
      control_options: lot$control_options,
      execute_libraries: ^pmt$object_library_list,
      existing_file: boolean,
      file_reference_p: ^fst$file_reference,
      i: integer,
      ignore_attributes: array [1 .. 1] of amt$get_item,
      ignore_contains_data: boolean,
      ignore_local_file: boolean,
      initial_ring: ost$valid_ring,
      malfunction_descriptor: pmt$established_handler,
      map_ring_attributes: amt$ring_attributes,
      module_name: pmt$program_name,
      nominal_ring: ost$ring,
      num_of_execute_libraries: pmt$number_of_libraries,
      operation_information_p: ^sft$audit_information,
      operation_status_p: ^ost$status,
      reference_descriptor: lot$reference_descriptor,
      starting_procedure_ring: ost$valid_ring,
      termination_descriptor: pmt$established_handler,
      transfer_descriptor: lot$external_descriptor,
      transfer_symbol_defined: boolean;

    CONST
      loc$run_time_library_name = 'cyf$run_time_library';

    #KEYPOINT (osk$entry, 0, lok$load_program);

    IF NOT lop$load_program_can_be_called THEN
      osp$set_status_abnormal ('LL', lle$cant_call_lop$load_program, '', status);
      #KEYPOINT (osk$exit, 0, lok$load_program);
      RETURN;
    IFEND;
    lop$load_program_can_be_called := FALSE;

    CASE loader_options_value.termination_error_level OF
    = pmc$warning_load_errors =
      first_severity_to_check := osc$warning_status;
    = pmc$error_load_errors =
      first_severity_to_check := osc$error_status;
    = pmc$fatal_load_errors =
      first_severity_to_check := osc$fatal_status;
    CASEND;



    lov$secondary_status.normal := TRUE;
    finish_load_map := FALSE;

    pmp$establish_condition_handler (termination_conditions, ^terminate_prematurely, ^termination_descriptor,
          status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, lok$load_program);
      RETURN;
    IFEND;
    IF ((loader_options_value.map <> $pmt$load_map_options [pmc$no_load_map]) AND
          (loader_options_value.map <> $pmt$load_map_options [])) THEN
      pmp$establish_condition_handler (map_malfunction, ^load_map_malfunction, ^malfunction_descriptor,
            status);
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, lok$load_program);
        RETURN;
      IFEND;
      ignore_attributes [1].key := amc$null_attribute;
      amp$get_file_attributes (loader_options_value.map_file, ignore_attributes, ignore_local_file,
            existing_file, ignore_contains_data, status);
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, lok$load_program);
        RETURN;
      IFEND;
      nominal_ring := avp$ring_nominal ();
      IF (existing_file OR (nominal_ring > target_ring)) THEN
        map_ring_attributes.r1 := nominal_ring;
        map_ring_attributes.r2 := nominal_ring;
        map_ring_attributes.r3 := nominal_ring;
      ELSE
        map_ring_attributes.r1 := target_ring;
        map_ring_attributes.r2 := target_ring;
        map_ring_attributes.r3 := target_ring;
      IFEND;
      lop$initialize_load_map (loader_options_value.map_file, map_ring_attributes, status);
      lov$loader_options := loader_options_value;
      IF status.normal THEN
        finish_load_map := TRUE;
      ELSE

{turn off load map generation - the load map is inaccessible.

        lov$loader_options.map := $pmt$load_map_options [pmc$no_load_map];
        status.normal := TRUE;
      IFEND;
    ELSE
      lov$loader_options := loader_options_value;
    IFEND;
    control_options.map := lov$loader_options.map;
    control_options.debug_ring := lov$loader_options.debug_ring;
    transfer_descriptor.name := osc$null_name;
    transfer_descriptor.global_key := loc$master_key;
    transfer_descriptor.reference_ring := osc$max_ring;
    IF object_file_list <> NIL THEN
      ALLOCATE lov$file_descriptors: [1 .. UPPERBOUND (object_file_list^)] IN osv$task_private_heap^;
    IFEND;
    IF execute_library_list = NIL THEN
      num_of_execute_libraries := 1;
    ELSE
      num_of_execute_libraries := UPPERBOUND (execute_library_list^) + 1;
    IFEND;
    PUSH execute_libraries: [1 .. num_of_execute_libraries];
    execute_libraries^ [num_of_execute_libraries] := loc$task_services_library_name;
    IF execute_library_list <> NIL THEN
      FOR i := 1 TO UPPERBOUND (execute_library_list^) DO
        execute_libraries^ [i] := execute_library_list^ [i];
      FOREND;
    IFEND;
    lop$add_program_load_libraries (execute_libraries, job_library_list, {deferred_libraries} NIL);
    lop$determine_initial_ring (object_file_list, execute_library_list, target_ring, initial_ring,
          starting_procedure_ring, lov$file_descriptors);
    lop$defix_program_segment_attr;
    IF (mpe_description <> NIL) AND (mpe_description^.apd_load) THEN
      lop$initialize_apd_processing (mpe_description);
    IFEND;
    lov$program_load := TRUE;
    IF object_file_list <> NIL THEN
      lop$load_object_files (lov$file_descriptors, initial_ring, control_options, transfer_descriptor);
    IFEND;
    IF module_list <> NIL THEN
      lop$load_module_list (module_list, initial_ring, control_options, transfer_descriptor);
    IFEND;
    loaded_program_cbp := NIL;
    lop$establish_transfer_symbol (starting_procedure, starting_procedure_ring, transfer_descriptor,
          reference_descriptor, loaded_program_cbp);
    lop$satisfy_externals (control_options);
    IF (mpe_description <> NIL) AND (mpe_description^.apd_load) THEN
      lop$gen_init_intercept_linkage (transfer_descriptor, reference_descriptor.details);
    IFEND;
    lop$release_transient_segments (control_options);
    lop$fix_program_segment_attr;
    lov$program_load := FALSE;
    finish_load_map := FALSE;
    lop$finish_load_map (control_options.map, transfer_descriptor, normal_termination);
    IF avp$security_option_active (avc$vso_security_audit) THEN
      PUSH file_reference_p: [fsc$max_path_size];
      lop$find_entry_point_residence (transfer_descriptor.name, starting_procedure_ring, module_name,
            file_reference_p^, status);
      PUSH operation_information_p;
      operation_information_p^.audited_operation := sfc$ao_job_execute_program;
      operation_information_p^.execute_program.program_name_p := ^transfer_descriptor.name;
      PUSH operation_status_p;
      IF status.normal THEN
        operation_status_p^.normal := TRUE;
        operation_information_p^.execute_program.module_name_p := ^module_name;
        operation_information_p^.execute_program.library_name_p := file_reference_p;
        operation_information_p^.execute_program.loaded_ring := starting_procedure_ring;
      ELSE

{ Lop$find_entry_point_residence returned an abnormal status; most likely this was caused
{ by a load error involving the starting procedure.  Try to be as specific about the
{ error condition as possible.

        operation_status_p^.normal := FALSE;
        IF transfer_descriptor.name = osc$null_name THEN
          operation_status_p^.condition := lle$transfer_symbol_missing;
        ELSE
          operation_status_p^.condition := lle$transfer_symbol_undefined;
        IFEND;
        operation_information_p^.execute_program.module_name_p := NIL;
        operation_information_p^.execute_program.library_name_p := NIL;
        operation_information_p^.execute_program.loaded_ring := osc$invalid_ring;
      IFEND;
      check_diagnostic_severity (status);
      IF (NOT status.normal) AND operation_status_p^.normal THEN

{ There was a load error but the starting procedure was found.

        operation_status_p^.normal := FALSE;
        operation_status_p^.condition := status.condition;
      IFEND;
      sfp$emit_audit_statistic (operation_information_p^, operation_status_p^);
    ELSE
      check_diagnostic_severity (status);
    IFEND;
    #KEYPOINT (osk$exit, 0, lok$load_program);
  PROCEND lop$load_program;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$establish_segment_access', EJECT ??
*copy pmh$establish_segment_access

  PROCEDURE [XDCL, #GATE] pmp$establish_segment_access
    (    file_identifier: amt$file_identifier,
         common_block: pmt$program_name;
     VAR segment_pointer: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      index: lot$common_blocks_index,
      kind: amt$pointer_kind,
      caller_id: ost$caller_identifier,
      found: boolean;

    #KEYPOINT (osk$entry, 0, pmk$establish_segment_access);
    status.normal := TRUE;
    #CALLER_ID (caller_id);
    found := FALSE;

    IF lov$common_blocks <> NIL THEN

    /find_common_block/
      FOR index := 1 TO UPPERBOUND (lov$common_blocks^) DO
        IF lov$common_blocks^ [index].name = common_block THEN
          found := TRUE;
          EXIT /find_common_block/;
        IFEND;
      FOREND /find_common_block/;
    IFEND;

    IF (NOT found) OR (NOT lov$common_blocks^ [index].unallocated_common) THEN
      osp$set_status_abnormal ('PM', pme$common_not_unallocated, common_block, status);
      #KEYPOINT (osk$exit, 0, pmk$establish_segment_access);
      RETURN;
    IFEND;

    IF lov$common_blocks^ [index].unallocated_common_open THEN
      osp$set_status_abnormal ('PM', pme$common_file_open, common_block, status);
      #KEYPOINT (osk$exit, 0, pmk$establish_segment_access);
      RETURN;
    IFEND;

    kind := amc$cell_pointer;
    fsp$change_segment_number (file_identifier, lov$common_blocks^ [index].unallocated_common_segment,
          caller_id.ring, kind, segment_pointer, status);

    IF status.normal THEN
      lov$common_blocks^ [index].unallocated_common_open := TRUE;
      lov$common_blocks^ [index].unallocated_common_file_id := file_identifier;
    IFEND;

    #KEYPOINT (osk$exit, 0, pmk$establish_segment_access);

  PROCEND pmp$establish_segment_access;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$disestablish_segment_access', EJECT ??
*copy pmh$disestablish_segment_access

  PROCEDURE [XDCL, #GATE] pmp$disestablish_segment_access
    (    common_block: pmt$program_name;
     VAR status: ost$status);

    VAR
      found: boolean,
      index: lot$common_blocks_index;

    #KEYPOINT (osk$entry, 0, pmk$disestablish_segment_access);
    status.normal := TRUE;
    found := FALSE;
    IF lov$common_blocks <> NIL THEN

    /find_common_block/
      FOR index := 1 TO UPPERBOUND (lov$common_blocks^) DO
        IF lov$common_blocks^ [index].name = common_block THEN
          found := TRUE;
          EXIT /find_common_block/;
        IFEND;
      FOREND /find_common_block/;
    IFEND;

    IF (NOT found) OR (NOT lov$common_blocks^ [index].unallocated_common) THEN
      osp$set_status_abnormal ('PM', pme$common_not_unallocated, common_block, status);
      #KEYPOINT (osk$exit, 0, pmk$disestablish_segment_access);
      RETURN;
    IFEND;

    IF NOT lov$common_blocks^ [index].unallocated_common_open THEN
      osp$set_status_abnormal ('PM', pme$common_file_not_open, common_block, status);
      #KEYPOINT (osk$exit, 0, pmk$disestablish_segment_access);
      RETURN;
    IFEND;

    lov$common_blocks^ [index].unallocated_common_open := FALSE;

    #KEYPOINT (osk$exit, 0, pmk$disestablish_segment_access);

  PROCEND pmp$disestablish_segment_access;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$close_common_block_file', EJECT ??
*copy pmh$close_common_block_file

  PROCEDURE [XDCL, #GATE] pmp$close_common_block_file
    (    common_block: pmt$program_name;
     VAR status: ost$status);

    VAR
      found: boolean,
      ignore_status: ost$status,
      index: lot$common_blocks_index;

    #KEYPOINT (osk$entry, 0, pmk$close_common_block_file);
    status.normal := TRUE;
    found := FALSE;
    IF lov$common_blocks <> NIL THEN

    /find_common_block/
      FOR index := 1 TO UPPERBOUND (lov$common_blocks^) DO
        IF lov$common_blocks^ [index].name = common_block THEN
          found := TRUE;
          EXIT /find_common_block/;
        IFEND;
      FOREND /find_common_block/;
    IFEND;

    IF (NOT found) OR (NOT lov$common_blocks^ [index].unallocated_common) THEN
      osp$set_status_abnormal ('PM', pme$common_not_unallocated, common_block, status);
      #KEYPOINT (osk$exit, 0, pmk$close_common_block_file);
      RETURN;
    IFEND;

    IF NOT lov$common_blocks^ [index].unallocated_common_open THEN
      osp$set_status_abnormal ('PM', pme$common_file_not_open, common_block, status);
      #KEYPOINT (osk$exit, 0, pmk$close_common_block_file);
      RETURN;
    IFEND;

    fsp$close_file (lov$common_blocks^ [index].unallocated_common_file_id, status);

    pmp$disestablish_segment_access (common_block, ignore_status);

    #KEYPOINT (osk$exit, 0, pmk$close_common_block_file);

  PROCEND pmp$close_common_block_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$remove_entry_point', EJECT ??
*copy pmh$remove_entry_point

  PROCEDURE [XDCL, #GATE] pmp$remove_entry_point
    (    name: pmt$program_name;
     VAR status {control} : ost$status);

    VAR
      entry_point_defined: boolean,
      definition: ^lot$entry_definition,
      prior_definition: ^lot$entry_definition,
      linkage: ^lot$linkage_name_lists,
      caller_id: ost$caller_identifier;


    #KEYPOINT (osk$entry, 0, pmk$remove_entry_point);

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    entry_point_defined := FALSE;

    lop$find_linkage_name_lists (name, linkage);

    prior_definition := NIL;
    definition := linkage^.definitions_list;

  /find_entry_point/
    WHILE definition <> NIL DO
      IF ((caller_id.global_key = definition^.attributes.global_lock) OR
            (definition^.attributes.gated AND ((definition^.attributes.global_lock = loc$no_lock) OR
            (caller_id.global_key = loc$master_key)))) AND ((caller_id.ring >=
            definition^.attributes.loaded_ring) AND (caller_id.ring <= definition^.attributes.call_bracket))
            THEN
        entry_point_defined := TRUE;
        EXIT /find_entry_point/;
      IFEND;
      prior_definition := definition;
      definition := definition^.nnext;
    WHILEND /find_entry_point/;

    IF entry_point_defined THEN
      remove_dynamic_loaded_ep (name, definition^.attributes.loaded_ring,
            definition^.attributes.call_bracket);
      IF prior_definition <> NIL THEN
        prior_definition^.nnext := definition^.nnext;
      ELSE
        linkage^.definitions_list := NIL;
      IFEND;
    ELSE
      osp$set_status_abnormal ('PM', pme$unknown_entry_point, name, status);
    IFEND;

    #KEYPOINT (osk$exit, 0, pmk$remove_entry_point);

  PROCEND pmp$remove_entry_point;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$load', EJECT ??
*copy pmh$load

  PROCEDURE [XDCL, #GATE] pmp$load
    (    name: pmt$program_name;
         kind: pmt$loaded_address_kind;
     VAR address: pmt$loaded_address;
     VAR status {control} : ost$status);

    VAR
      caller_id: ost$caller_identifier;


    #CALLER_ID (caller_id);

    #KEYPOINT (osk$entry, 0, pmk$load);

    status.normal := TRUE;
    address.kind := kind; { do minimal parameter access checking }

    lop$load_entry_point (name, caller_id.ring, 0, kind, address, status);

    #KEYPOINT (osk$exit, ((1 - $INTEGER (status.normal)) * 0), pmk$load);


  PROCEND pmp$load;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$load_entry_point', EJECT ??
*copy pmh$load_entry_point

  PROCEDURE [XDCL, #GATE] pmp$load_entry_point
    (    name: pmt$program_name;
         reference_ring: ost$valid_ring;
         reference_global_key: ost$key_lock_value;
         kind: pmt$loaded_address_kind;
     VAR address: pmt$loaded_address;
     VAR status {control} : ost$status);


    #KEYPOINT (osk$entry, 0, pmk$load_entry_point);

    status.normal := TRUE;
    address.kind := kind; { do minimal parameter access checking }

    lop$load_entry_point (name, reference_ring, reference_global_key, kind, address, status);


    #KEYPOINT (osk$exit, 0, pmk$load_entry_point);
  PROCEND pmp$load_entry_point;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$load_entry_point', EJECT ??
*copy loh$load_entry_point

  PROCEDURE [XDCL] lop$load_entry_point
    (    name: pmt$program_name;
         reference_ring: ost$valid_ring;
         reference_global_key: ost$key_lock_value;
         kind: pmt$loaded_address_kind;
     VAR address: pmt$loaded_address;
     VAR status {control} : ost$status);

    VAR
      fix_segment_attributes: boolean;

?? NEWTITLE := 'load_map_malfunction', EJECT ??

{  PURPOSE:
{     The purpose of this condition handler is to terminate the task if
{     generate load map detects an unexpected abnormal status from a
{     NOS/VE request - the task exits with the unexpected status.

    PROCEDURE load_map_malfunction
      (    condition: pmt$condition;
           system_status: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        malfunction: ^ost$status;

      malfunction := system_status;
      pmp$exit (malfunction^);
    PROCEND load_map_malfunction;
?? OLDTITLE ??
?? NEWTITLE := 'terminate_prematurely', EJECT ??

{   PURPOSE:
{      Circumstances may arise within the loader which cause premature termination
{      of the load process.  These circumstances are reported within the loader via
{      conditions.  This condition handler is responsible for fielding the condition;
{      reporting the abnormality; and prematurely terminating the load process.
{
{      The conditions and their meanings are:
{      1.  system conditions: the hardware detected a condition which is probably
{          caused by a loader coding error.  The specific condition is reported to
{          the output file and the task is terminated with the loader malfunctioned
{          exception code.  SEE: code for pmc$detected_uncorrected_err processing.
{      2.  segment access conditions:
{          a. mmc$sac_read_beyond_eoi, mmc$sac_segment_access_error,
{             mmc$sac_key_lock_violation, mmc$sac_ring_violation:
{             segment management detected an inconsistency which was probably
{             caused by a loader coding error.  The specific condition is reported
{             to the output file and the task is terminated with the loader
{             malfunctioned exception code.
{          b. mmc$sac_read_write_beyond_msl: user limits prevented the loader from
{             completing the load process.  The task is terminated with the
{             insufficient memory to load exception code.
{          c. mmc$sac_io_read_error: a hardware error was detected attempting to
{             read a page from a device.  The specific condition is reported to
{             the output file and the task is terminated with the premature load
{             termination exception code.
{      3.  user defined conditions:
{          a. cye$run_time_condition: the CYBIL run time checking detected an
{             error which was probably cause by a loader coding error.  The
{             specific condition is reported to the output file and the task is
{             terminated with loader malfunctioned exception code.
{          b. loe$abort_load: several constituent procedures of the loader detect
{             circumstances which prohibit continuation of the load process.  The
{             detecting procedure reports the circumstance to load map and causes
{             the loe$abort_load condition.  This condition handler terminates the
{             task with the premature load termination exception code.
{          c. loe$loader_malfunction: a constituent procedure of the loader
{             detected an inconsistency which probably was caused by a loader
{             coding error.  The detecting procedure causes the condition
{             pointing to a status variable which identifies the inconsistency.
{             This condition handler reports the identified inconsistency to
{             the output file and terminates the task with the loader malfunctioned
{             exception code.
{          d. loe$insufficient_memory: several constituent procedures of the
{             loader detect circumstances where there is not enough virtual memory
{             to complete the load process - this is generally a case of user
{             limit being exceeded.  The detecting procedure reports the shortage
{             to the load map and causes the condition.  This condition handler
{             terminates the task with insufficient memory to load exception code.
{          e. other: other user defined conditions will be continued and
{             otherwise ignored.
{

    PROCEDURE terminate_prematurely
      (    condition: pmt$condition;
           malfunction_status: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        termination_descriptor: pmt$established_handler,
        cybil_error: ^ost$status,
        malfunction: ^ost$status,
        message: ost$status;

      CASE condition.selector OF
      = pmc$system_conditions =
        osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
        IF NOT (pmc$detected_uncorrected_err IN condition.system_conditions) THEN
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'ENTRY POINT', local_status);
        ELSE
          local_status := message;
        IFEND;
      = mmc$segment_access_condition =
        CASE condition.segment_access_condition.identifier OF
        = mmc$sac_read_beyond_eoi, mmc$sac_segment_access_error, mmc$sac_key_lock_violation,
              mmc$sac_ring_violation =
          osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'ENTRY POINT', local_status);
        = mmc$sac_read_write_beyond_msl =
          osp$set_status_abnormal ('LL', lle$insufficient_memory_to_load, '', local_status);
        = mmc$sac_io_read_error =
          osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$premature_load_termination, 'Entry Point', local_status);
        ELSE
          osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$premature_load_termination, 'Entry Point', local_status);
        CASEND;
      = pmc$user_defined_condition =
        IF (condition.user_condition_name = cye$run_time_condition) THEN
          cybil_error := malfunction_status;
          osp$generate_message (cybil_error^, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'ENTRY POINT', local_status);
        ELSEIF (condition.user_condition_name = loe$abort_load) THEN
          osp$set_status_abnormal ('LL', lle$premature_load_termination, 'Entry Point', local_status);
        ELSEIF (condition.user_condition_name = loe$loader_malfunction) THEN
          malfunction := malfunction_status;
          osp$generate_message (malfunction^, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'ENTRY POINT', local_status);
        ELSEIF (condition.user_condition_name = loe$insufficient_memory) THEN
          osp$set_status_abnormal ('LL', lle$insufficient_memory_to_load, '', local_status);
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          RETURN;
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        RETURN;
      CASEND;
      IF fix_segment_attributes THEN
        pmp$establish_condition_handler (termination_conditions, ^terminate_prematurely,
              ^termination_descriptor, condition_status);
        fix_segment_attributes := FALSE;
        lop$fix_program_segment_attr;

{disestablish terminate_prematurely's condition handler

        pmp$disestablish_cond_handler (termination_conditions, condition_status);
      IFEND;

{disestablish lop$load_entry_point's condition handler

      pmp$disestablish_cond_handler (termination_conditions, condition_status);
      #KEYPOINT (osk$exit, 0, lok$load_entry_point);
      pmp$exit (local_status);
    PROCEND terminate_prematurely;
?? OLDTITLE ??

*copy lov$binding_segment_attributes

    VAR
      cbp_size: ost$segment_length,
      common_blocks: ^lot$deferred_common_blocks,
      control_options: lot$control_options,
      converter: record
        case 0 .. 1 of
        = 0 =
          local_ptr_to_proc: ^procedure,
        = 1 =
          ptr_to_proc: cyt$pointer_to_procedure,
        casend,
      recend,
      deferred_entry_point_index: 0 .. 0ff(16),
      deferred_libraries: ^lot$deferred_library_list,
      entry_point_definition: ^lot$entry_definition,
      entry_point_found: boolean,
      entry_point_unaligned: boolean,
      entry_points: ^lot$deferred_entry_points,
      external_descriptor: lot$external_descriptor,
      i: ost$status_severity,
      ignored: boolean,
      j: integer,
      linkage_info: ^lot$linkage_name_lists,
      local_address: pmt$loaded_address,
      local_status: ost$status, { use local variables to protect against storing values to defixed segments }
      job_libraries: ^pmt$object_library_list,
      job_library_list: ^pmt$object_library_list,
      malfunction_descriptor: pmt$established_handler,
      match_found: boolean,
      num_of_deferred_ep_libraries: pmt$number_of_libraries,
      num_of_job_libraries: pmt$number_of_libraries,
      proc_pointer: cyt$pointer_to_procedure,
      prog_options_and_libraries: ^pmt$prog_options_and_libraries,
      reference_descriptor: lot$reference_descriptor,
      str: ost$string,
      termination_descriptor: pmt$established_handler;


    #KEYPOINT (osk$entry, 0, lok$load_entry_point);
     status.normal := TRUE;

    IF NOT loader_running THEN
      osp$set_status_abnormal ('LL', lle$loader_stopped, '', status);
      #KEYPOINT (osk$exit, 0, lok$load_entry_point);
      RETURN;
    IFEND;

    find_dynamic_loaded_ep (name, reference_ring, entry_point_found, address);
    IF entry_point_found THEN
      #KEYPOINT (osk$exit, 0, lok$load_entry_point);
      RETURN;
    IFEND;

    local_status.normal := TRUE;
    fix_segment_attributes := FALSE;
    pmp$establish_condition_handler (termination_conditions, ^terminate_prematurely, ^termination_descriptor,
          local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      #KEYPOINT (osk$exit, 0, lok$load_entry_point);
      RETURN;
    IFEND;
    IF (lov$loader_options.map <> $pmt$load_map_options [pmc$no_load_map]) THEN
      pmp$establish_condition_handler (map_malfunction, ^load_map_malfunction, ^malfunction_descriptor,
            local_status);
      IF NOT local_status.normal THEN
        status := local_status;
        #KEYPOINT (osk$exit, 0, lok$load_entry_point);
        RETURN;
      IFEND;
    IFEND;
    local_address.kind := kind;
    FOR i := LOWERVALUE (ost$status_severity) TO UPPERVALUE (ost$status_severity) DO
      lov$diagnostic_count [i] := 0;
    FOREND;
    control_options.map := lov$loader_options.map;
    control_options.debug_ring := lov$loader_options.debug_ring;
    IF NOT lov$program_load THEN
      lop$defix_program_segment_attr;
      fix_segment_attributes := TRUE;
    IFEND;

    reference_descriptor.mmodule := loc$referenced_by_dynamic_load;

    IF kind = pmc$data_address THEN
      reference_descriptor.details.address.ring := #RING (^local_address.pointer_to_data);
      reference_descriptor.details.address.segment := #SEGMENT (^local_address.pointer_to_data);
      reference_descriptor.details.address.offset := #OFFSET (^local_address.pointer_to_data);
      reference_descriptor.details.kind := llc$address;
      reference_descriptor.details.binding_section_destination := FALSE;
      reference_descriptor.details.declaration_matching_required := FALSE;
    ELSE
      cbp_size := #SIZE (ost$external_code_base_pointer);
      lop$reserve_storage (binding_segment_attributes, 8, 0, FALSE, 0, loc$no_shadow_file, 0, cbp_size,
            reference_descriptor.details.address);
      reference_descriptor.details.kind := llc$external_proc;
      reference_descriptor.details.binding_section_destination := TRUE;
      reference_descriptor.details.declaration_matching_required := FALSE;
      reference_descriptor.details.in_target_text := FALSE;
      proc_pointer.code_base_pointer_p := #ADDRESS (reference_descriptor.details.address.ring,
            reference_descriptor.details.address.segment, reference_descriptor.details.address.offset);
      proc_pointer.static_link := NIL;
      converter.ptr_to_proc := proc_pointer;
      local_address.pointer_to_procedure := converter.local_ptr_to_proc;
    IFEND;
    external_descriptor.name := name;
    external_descriptor.reference_ring := reference_ring;
    external_descriptor.global_key := 0;
    IF lov$deferred_common_blocks <> NIL THEN

{ All deferred common blocks will be added to the common block table whether the entry point
{ has already been loaded or not since the entry point may reference a deferred common block.

      common_blocks := lov$deferred_common_blocks;
      WHILE common_blocks <> NIL DO
        lop$add_deferred_common_blocks (common_blocks^.deferred_common_blocks);
        common_blocks := common_blocks^.link;
      WHILEND;
      lov$deferred_common_blocks := NIL;
    IFEND;
    lop$find_matching_entry_point (external_descriptor, match_found, linkage_info, entry_point_definition);
    IF match_found THEN
      IF lov$apd_flags.apd_load AND entry_point_definition^.attributes.in_target_text AND
            (kind = pmc$procedure_address) AND (linkage_info^.name <> 'CYP$NIL') THEN
        lop$store_intercept_linkage (reference_descriptor.details, linkage_info^.name,
              entry_point_definition^, ignored, ignored, entry_point_unaligned);
      ELSE
        lop$store_linkage (^reference_descriptor.details, entry_point_definition, ignored, ignored,
              entry_point_unaligned);
      IFEND;
      IF entry_point_unaligned THEN
        lop$report_error (lle$entry_point_unaligned, name, entry_point_definition^.defining_module, 0);
        check_diagnostic_severity (local_status);
        IF NOT local_status.normal THEN
          #KEYPOINT (osk$exit, 0, lok$load_entry_point);
          pmp$exit (local_status);
        IFEND;
      IFEND;
    ELSE
      pmp$find_prog_options_and_libs (prog_options_and_libraries);
      job_library_list := prog_options_and_libraries^.job_library_list;
      num_of_job_libraries := 1;
      deferred_libraries := NIL;
      num_of_deferred_ep_libraries := 0;
      IF lov$deferred_entry_points <> NIL THEN

{ Each record in the list of deferred entry points represents all of the deferred
{ entry points from one prelinked module.  There must be a separate deferred
{ entry point "library" set up for each one.  Since the "library" names must be
{ unique, an index is concatenated to a constant to define the deferred entry
{ point library name.

        entry_points := lov$deferred_entry_points;
        WHILE entry_points <> NIL DO
          num_of_deferred_ep_libraries := num_of_deferred_ep_libraries + 1;
          entry_points := entry_points^.link;
        WHILEND;

        deferred_entry_point_index := 0;
        PUSH deferred_libraries: [1 .. num_of_deferred_ep_libraries];
        entry_points := lov$deferred_entry_points;
        FOR j := 1 TO num_of_deferred_ep_libraries DO
          deferred_entry_point_index := deferred_entry_point_index + 1;
          clp$convert_integer_to_string (deferred_entry_point_index, 10, FALSE, str, {ignore} local_status);
          deferred_libraries^ [j].name := loc$deferred_entry_pt_library;
          deferred_libraries^ [j].name (loc$deferred_entry_pt_lib_size + 1, str.size) :=
                str.value (1, str.size);
          deferred_libraries^ [j].segment := #SEGMENT (entry_points^.deferred_entry_points);
          entry_points := entry_points^.link;
        FOREND;

      IFEND;
      IF job_library_list <> NIL THEN
        num_of_job_libraries := num_of_job_libraries + UPPERBOUND (job_library_list^);
      IFEND;
      PUSH job_libraries: [1 .. num_of_job_libraries];
      job_libraries^ [1] := loc$task_services_library_name;
      IF job_library_list <> NIL THEN
        FOR j := 1 TO UPPERBOUND (job_library_list^) DO
          job_libraries^ [j + 1] := job_library_list^ [j];
        FOREND;
      IFEND;
      lop$add_program_load_libraries ({execute_libraries} NIL, job_libraries, deferred_libraries);
      reference_descriptor.ring := reference_ring;
      reference_descriptor.global_key := 0;
      lop$add_unsatisfied_ref_to_list (reference_descriptor, linkage_info);
      lop$satisfy_externals (control_options);
      lop$release_transient_segments (control_options);
      lop$find_matching_entry_point (external_descriptor, match_found, linkage_info, entry_point_definition);
      IF match_found THEN
        check_diagnostic_severity (local_status);
      ELSE
        osp$set_status_abnormal ('LL', lle$entry_point_not_found, external_descriptor.name, local_status);
      IFEND;
    IFEND;
    IF NOT lov$program_load THEN
      fix_segment_attributes := FALSE;
      lop$fix_program_segment_attr;
    IFEND;
    IF local_status.normal AND match_found THEN
      address := local_address;
      record_dynamic_loaded_ep (name, reference_ring, address);
      IF pmc$entry_point_xref IN lov$loader_options.map THEN
        lop$generate_cross_refernce_map;
      IFEND;
      IF pmc$segment_map IN lov$loader_options.map THEN
        lop$generate_segment_map;
      IFEND;
    IFEND;
    status := local_status;
    #KEYPOINT (osk$exit, 0, lok$load_entry_point);
  PROCEND lop$load_entry_point;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$load_from_library', EJECT ??
*copy pmh$load_from_library

  PROCEDURE [XDCL, #GATE] pmp$load_from_library
    (    name: pmt$program_name;
         ring: ost$ring;
         global_key: ost$key_lock_value;
         kind: pmt$loaded_address_kind;
         library: ^SEQ ( * );
         library_name: amt$local_file_name;
     VAR address: pmt$loaded_address;
     VAR status {control} : ost$status);


    #KEYPOINT (osk$entry, 0, pmk$load_from_library);

    status.normal := TRUE;
    address.kind := kind; { do minimal parameter access checking }

    lop$load_module_from_library (name, ring, 0, library, library_name, kind, address, status);

    #KEYPOINT (osk$exit, 0, pmk$load_from_library);

  PROCEND pmp$load_from_library;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$load_module_from_library', EJECT ??
*copy pmh$load_module_from_library

  PROCEDURE [XDCL, #GATE] pmp$load_module_from_library
    (    name: pmt$program_name;
         reference_ring: ost$valid_ring;
         kind: pmt$loaded_address_kind;
         library: fst$file_reference;
     VAR loaded_ring: ost$valid_ring;
     VAR call_bracket_ring: ost$valid_ring;
     VAR address: pmt$loaded_address;
     VAR status {control} : ost$status);

?? EJECT ??

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      intercept_pointer: record
        case boolean of
        = TRUE =
          procedure_pointer: ^procedure,
        = FALSE =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend,

      first_conversion: record
        case boolean of
        = TRUE =
          procedure_pointer: ^procedure,
        = FALSE =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend,

      second_conversion: record
        case boolean of
        = TRUE =
          code_base_pva: ^cell,
        = FALSE =
          pva_record: ^ost$pva,
        casend,
      recend,
      path_handle_name: fst$path_handle_name;

    status.normal := TRUE;
    address.kind := kind;
    intercept_pointer.procedure_pointer := ^pmp$intercept_call_procedure;

    clp$convert_str_to_path_handle (library, {delete_allowed} TRUE, {resolve_path} FALSE,
          {include_open_pos_in_handle} FALSE, path_handle_name, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    lop$activate_library (path_handle_name);
    lop$load_entry_point (name, reference_ring, 0, kind, address, status);
    lop$deactivate_library (path_handle_name);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    first_conversion.procedure_pointer := address.pointer_to_procedure;
    call_bracket_ring := first_conversion.code_base_pointer^.r3;

{ This is to get the loaded ring of the procedure, not the apd intercept
{ procedure.

    IF (#SEGMENT (first_conversion.code_base_pointer^.code_pva) =
          #SEGMENT (intercept_pointer.code_base_pointer^.code_pva)) AND
          (#OFFSET (first_conversion.code_base_pointer^.code_pva) =
          #OFFSET (intercept_pointer.code_base_pointer^.code_pva)) THEN
      first_conversion.code_base_pointer := first_conversion.code_base_pointer^.binding_pva;
    IFEND;

    second_conversion.code_base_pva := ^first_conversion.code_base_pointer^.code_pva;
    loaded_ring := second_conversion.pva_record^.ring;

  PROCEND pmp$load_module_from_library;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$load_module_from_library', EJECT ??

  PROCEDURE [XDCL] lop$load_module_from_library
    (    name: pmt$program_name;
         ring: ost$valid_ring;
         global_key: ost$key_lock_value;
         library: ^SEQ ( * );
         library_name: amt$local_file_name;
         kind: pmt$loaded_address_kind;
     VAR address: pmt$loaded_address;
     VAR status {control} : ost$status);


    VAR
      fix_segment_attributes: boolean;

?? NEWTITLE := 'load_map_malfunction', EJECT ??

{  PURPOSE:
{     The purpose of this condition handler is to terminate the task if
{     generate load map detects an unexpected abnormal status from a
{     NOS/VE request - the task exits with the unexpected status.

    PROCEDURE load_map_malfunction
      (    condition: pmt$condition;
           system_status: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        malfunction: ^ost$status;

      malfunction := system_status;
      #KEYPOINT (osk$exit, 0, lok$load_module_from_library);
      pmp$exit (malfunction^);
    PROCEND load_map_malfunction;
?? OLDTITLE ??
?? NEWTITLE := 'terminate_prematurely', EJECT ??

{   PURPOSE:
{      Circumstances may arise within the loader which cause premature termination
{      of the load process.  These circumstances are reported within the loader via
{      conditions.  This condition handler is responsible for fielding the condition;
{      reporting the abnormality; and prematurely terminating the load process.
{
{      The conditions and their meanings are:
{      1.  system conditions: the hardware detected a condition which is probably
{          caused by a loader coding error.  The specific condition is reported to
{          the output file and the task is terminated with the loader malfunctioned
{          exception code.  SEE: code for pmc$detected_uncorrected_err processing.
{      2.  segment access conditions:
{          a. mmc$sac_read_beyond_eoi, mmc$sac_segment_access_error,
{             mmc$sac_key_lock_violation, mmc$sac_ring_violation:
{             segment management detected an inconsistency which was probably
{             caused by a loader coding error.  The specific condition is reported
{             to the output file and the task is terminated with the loader
{             malfunctioned exception code.
{          b. mmc$sac_read_write_beyond_msl: user limits prevented the loader from
{             completing the load process.  The task is terminated with the
{             insufficient memory to load exception code.
{          c. mmc$sac_io_read_error: a hardware error was detected attempting to
{             read a page from a device.  The specific condition is reported to
{             the output file and the task is terminated with the premature load
{             termination exception code.
{      3.  user defined conditions:
{          a. cye$run_time_condition: the CYBIL run time checking detected an
{             error which was probably cause by a loader coding error.  The
{             specific condition is reported to the output file and the task is
{             terminated with loader malfunctioned exception code.
{          b. loe$abort_load: several constituent procedures of the loader detect
{             circumstances which prohibit continuation of the load process.  The
{             detecting procedure reports the circumstance to load map and causes
{             the loe$abort_load condition.  This condition handler terminates the
{             task with the premature load termination exception code.
{          c. loe$loader_malfunction: a constituent procedure of the loader
{             detected an inconsistency which probably was caused by a loader
{             coding error.  The detecting procedure causes the condition
{             pointing to a status variable which identifies the inconsistency.
{             This condition handler reports the identified inconsistency to
{             the output file and terminates the task with the loader malfunctioned
{             exception code.
{          d. loe$insufficient_memory: several constituent procedures of the
{             loader detect circumstances where there is not enough virtual memory
{             to complete the load process - this is generally a case of user
{             limit being exceeded.  The detecting procedure reports the shortage
{             to the load map and causes the condition.  This condition handler
{             terminates the task with insufficient memory to load exception code.
{          e. other: other user defined conditions will be continued and
{             otherwise ignored.
{

    PROCEDURE terminate_prematurely
      (    condition: pmt$condition;
           malfunction_status: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        termination_descriptor: pmt$established_handler,
        cybil_error: ^ost$status,
        malfunction: ^ost$status,
        message: ost$status;

      CASE condition.selector OF
      = pmc$system_conditions =
        osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
        IF NOT (pmc$detected_uncorrected_err IN condition.system_conditions) THEN
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'ENTRY POINT', local_status);
        ELSE
          local_status := message;
        IFEND;
      = mmc$segment_access_condition =
        CASE condition.segment_access_condition.identifier OF
        = mmc$sac_read_beyond_eoi, mmc$sac_segment_access_error, mmc$sac_key_lock_violation,
              mmc$sac_ring_violation =
          osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'ENTRY POINT', local_status);
        = mmc$sac_read_write_beyond_msl =
          osp$set_status_abnormal ('LL', lle$insufficient_memory_to_load, '', local_status);
        = mmc$sac_io_read_error =
          osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$premature_load_termination, 'Entry Point', local_status);
        ELSE
          osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$premature_load_termination, 'Entry Point', local_status);
        CASEND;
      = pmc$user_defined_condition =
        IF (condition.user_condition_name = cye$run_time_condition) THEN
          cybil_error := malfunction_status;
          osp$generate_message (cybil_error^, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'ENTRY POINT', local_status);
        ELSEIF (condition.user_condition_name = loe$abort_load) THEN
          osp$set_status_abnormal ('LL', lle$premature_load_termination, 'Entry Point', local_status);
        ELSEIF (condition.user_condition_name = loe$loader_malfunction) THEN
          malfunction := malfunction_status;
          osp$generate_message (malfunction^, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'ENTRY POINT', local_status);
        ELSEIF (condition.user_condition_name = loe$insufficient_memory) THEN
          osp$set_status_abnormal ('LL', lle$insufficient_memory_to_load, '', local_status);
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          RETURN;
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        RETURN;
      CASEND;
      IF fix_segment_attributes THEN
        pmp$establish_condition_handler (termination_conditions, ^terminate_prematurely,
              ^termination_descriptor, condition_status);
        fix_segment_attributes := FALSE;
        lop$fix_program_segment_attr;

{disestablish terminate_prematurely's condition handler

        pmp$disestablish_cond_handler (termination_conditions, condition_status);
      IFEND;

{disestablish lop$load_module_from_library's condition handler

      pmp$disestablish_cond_handler (termination_conditions, condition_status);
      #KEYPOINT (osk$exit, 0, lok$load_module_from_library);
      pmp$exit (local_status);
    PROCEND terminate_prematurely;
?? OLDTITLE, EJECT ??

*copy lov$binding_segment_attributes

    VAR
      cbp_size: ost$segment_length,
      cell_pointer: ^cell,
      control_options: lot$control_options,
      converter: record
        case 0 .. 1 of
        = 0 =
          local_ptr_to_proc: ^procedure,
        = 1 =
          ptr_to_proc: cyt$pointer_to_procedure,
        casend,
      recend,
      entry_point_definition: ^lot$entry_definition,
      entry_point_dictionary: ^llt$entry_point_dictionary,
      entry_point_found: boolean,
      entry_point_gated: boolean,
      entry_point_unaligned: boolean,
      entry_pt_dictionary_index: 1 .. llc$max_entry_points_in_library,
      external_descriptor: lot$external_descriptor,
      i: ost$status_severity,
      ignored: boolean,
      ignore_symbol_table_present: boolean,
      job_library_list_p: ^pmt$object_library_list,
      job_libraries_p: ^pmt$object_library_list,
      library_file: ^SEQ ( * ),
      library_file_attributes: lot$load_file_attributes,
      library_index: pmt$number_of_libraries,
      linkage_info: ^lot$linkage_name_lists,
      local_address: pmt$loaded_address,
      local_status: ost$status, { use local variables to protect against storing values to defixed segments }
      malfunction_descriptor: pmt$established_handler,
      match_found: boolean,
      module_header: ^llt$load_module_header,
      module_ring_attributes: lot$module_ring_attributes,
      module_structure_error: boolean,
      number_of_job_libraries: pmt$number_of_libraries,
      object_text_descriptor: ^llt$object_text_descriptor,
      proc_pointer: cyt$pointer_to_procedure,
      prog_options_and_libraries_p: ^pmt$prog_options_and_libraries,
      pseudo_transfer_descriptor: lot$external_descriptor,
      reference_descriptor: lot$reference_descriptor,
      segment_attributes: array [1 .. 1] of mmt$attribute_descriptor,
      termination_descriptor: pmt$established_handler;

?? EJECT ??

    #KEYPOINT (osk$entry, 0, lok$load_module_from_library);
    status.normal := TRUE;

    IF NOT loader_running THEN
      osp$set_status_abnormal ('LL', lle$loader_stopped, '', status);
      #KEYPOINT (osk$exit, 0, lok$load_module_from_library);
      RETURN;
    IFEND;

    segment_attributes [1].keyword := mmc$kw_segment_access_control;
    cell_pointer := library;
    mmp$fetch_segment_attributes (cell_pointer, segment_attributes, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, lok$load_module_from_library);
      RETURN;
    IFEND;

    IF segment_attributes [1].access_control.execute_privilege = osc$non_executable THEN
      osp$set_status_abnormal ('LL', lle$library_not_executable, '', status);
      #KEYPOINT (osk$exit, 0, lok$load_module_from_library);
      RETURN;
    IFEND;

    find_dynamic_loaded_ep (name, ring, entry_point_found, address);
    IF entry_point_found THEN
      #KEYPOINT (osk$exit, 0, lok$load_module_from_library);
      RETURN;
    IFEND;

    local_status.normal := TRUE;
    fix_segment_attributes := FALSE;
    pmp$establish_condition_handler (termination_conditions, ^terminate_prematurely, ^termination_descriptor,
          local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      #KEYPOINT (osk$exit, 0, lok$load_module_from_library);
      RETURN;
    IFEND;
    IF (lov$loader_options.map <> $pmt$load_map_options [pmc$no_load_map]) THEN
      pmp$establish_condition_handler (map_malfunction, ^load_map_malfunction, ^malfunction_descriptor,
            local_status);
      IF NOT local_status.normal THEN
        status := local_status;
        #KEYPOINT (osk$exit, 0, lok$load_module_from_library);
        RETURN;
      IFEND;
    IFEND;
    local_address.kind := kind;
    FOR i := LOWERVALUE (ost$status_severity) TO UPPERVALUE (ost$status_severity) DO
      lov$diagnostic_count [i] := 0;
    FOREND;
    control_options.map := lov$loader_options.map;
    control_options.debug_ring := lov$loader_options.debug_ring;
    IF NOT lov$program_load THEN
      lop$defix_program_segment_attr;
      fix_segment_attributes := TRUE;
    IFEND;

    reference_descriptor.mmodule := loc$referenced_by_dynamic_load;

    IF kind = pmc$data_address THEN
      reference_descriptor.details.address.ring := #RING (^local_address.pointer_to_data);
      reference_descriptor.details.address.segment := #SEGMENT (^local_address.pointer_to_data);
      reference_descriptor.details.address.offset := #OFFSET (^local_address.pointer_to_data);
      reference_descriptor.details.kind := llc$address;
      reference_descriptor.details.binding_section_destination := FALSE;
      reference_descriptor.details.declaration_matching_required := FALSE;
    ELSE
      cbp_size := #SIZE (ost$external_code_base_pointer);
      lop$reserve_storage (binding_segment_attributes, 8, 0, FALSE, 0, loc$no_shadow_file, 0, cbp_size,
            reference_descriptor.details.address);
      reference_descriptor.details.kind := llc$external_proc;
      reference_descriptor.details.binding_section_destination := TRUE;
      reference_descriptor.details.declaration_matching_required := FALSE;
      reference_descriptor.details.in_target_text := FALSE;
      proc_pointer.code_base_pointer_p := #ADDRESS (reference_descriptor.details.address.ring,
            reference_descriptor.details.address.segment, reference_descriptor.details.address.offset);
      proc_pointer.static_link := NIL;
      converter.ptr_to_proc := proc_pointer;
      local_address.pointer_to_procedure := converter.local_ptr_to_proc;
    IFEND;
    external_descriptor.name := name;
    external_descriptor.reference_ring := ring;
    external_descriptor.global_key := 0;
    lop$find_matching_entry_point (external_descriptor, match_found, linkage_info, entry_point_definition);
    IF match_found THEN
      IF lov$apd_flags.apd_load AND entry_point_definition^.attributes.in_target_text AND
            (kind = pmc$procedure_address) AND (linkage_info^.name <> 'CYP$NIL') THEN
        lop$store_intercept_linkage (reference_descriptor.details, linkage_info^.name,
              entry_point_definition^, ignored, ignored, entry_point_unaligned);
      ELSE
        lop$store_linkage (^reference_descriptor.details, entry_point_definition, ignored, ignored,
              entry_point_unaligned);
      IFEND;
      IF entry_point_unaligned THEN
        lop$report_error (lle$entry_point_unaligned, name, entry_point_definition^.defining_module, 0);
        check_diagnostic_severity (local_status);
        IF NOT local_status.normal THEN
          #KEYPOINT (osk$exit, 0, lok$load_module_from_library);
          pmp$exit (local_status);
        IFEND;
      IFEND;
    ELSE
      reference_descriptor.ring := ring;
      reference_descriptor.global_key := 0;

    /satisfy_entry_pt_from_library/
      BEGIN
        library_file := library;
        pmp$get_entry_point_dictionary (library_file, entry_point_dictionary, local_status);
        IF NOT local_status.normal THEN
          EXIT /satisfy_entry_pt_from_library/
        IFEND;
        IF entry_point_dictionary = NIL THEN
          osp$set_status_abnormal ('LL', lle$entry_point_not_found, name, local_status);
          EXIT /satisfy_entry_pt_from_library/
        IFEND;
        lop$search_entry_pt_dictionary (^name, entry_point_dictionary, entry_point_found, entry_point_gated,
              entry_pt_dictionary_index);
        IF NOT entry_point_found THEN
          osp$set_status_abnormal ('LL', lle$entry_point_not_found, name, local_status);
          EXIT /satisfy_entry_pt_from_library/
        IFEND;
        module_header := #PTR (entry_point_dictionary^ [entry_pt_dictionary_index].module_header,
              library_file^);
        IF module_header = NIL THEN
          lop$report_error (lle$bad_module_header_ptr, name, 'module', entry_pt_dictionary_index);
          check_diagnostic_severity (local_status);
          EXIT /satisfy_entry_pt_from_library/
        IFEND;
        object_text_descriptor := #PTR (module_header^.interpretive_element, library_file^);
        IF object_text_descriptor = NIL THEN
          lop$report_error (lle$bad_interpretive_elem_ptr, name, '', #OFFSET (module_header));
          check_diagnostic_severity (local_status);
          EXIT /satisfy_entry_pt_from_library/
        IFEND;

        RESET library_file TO object_text_descriptor;

        module_ring_attributes.loaded_ring := ring;
        module_ring_attributes.call_bracket := ring;

        library_file_attributes.name := library_name;
        library_file_attributes.library_file := TRUE;
        library_file_attributes.debug_file := FALSE;
        library_file_attributes.key_lock.global := FALSE;
        library_file_attributes.key_lock.local := FALSE;
        library_file_attributes.key_lock.value := 0;
        library_file_attributes.execute_privilege := osc$non_privileged;

        lop$add_unsatisfied_ref_to_list (reference_descriptor, linkage_info);

        lop$load_module (module_ring_attributes, library_file_attributes, control_options, library_file,
              pseudo_transfer_descriptor, ignore_symbol_table_present, module_structure_error);

        pmp$find_prog_options_and_libs (prog_options_and_libraries_p);
        job_library_list_p := prog_options_and_libraries_p^.job_library_list;
        IF job_library_list_p = NIL THEN
          number_of_job_libraries := 1;
        ELSE
          number_of_job_libraries := UPPERBOUND (job_library_list_p^) + 1;
        IFEND;
        PUSH job_libraries_p: [1 .. number_of_job_libraries];
        job_libraries_p^ [1] := loc$task_services_library_name;
        IF job_library_list_p <> NIL THEN
          FOR library_index := 1 TO UPPERBOUND (job_library_list_p^) DO
            job_libraries_p^ [library_index + 1] := job_library_list_p^ [library_index];
          FOREND;
        IFEND;
        lop$add_program_load_libraries ({execute_libraries} NIL, job_libraries_p, {deferred_libraries} NIL);
        lop$satisfy_externals (control_options);
        lop$release_transient_segments (control_options);
        lop$find_matching_entry_point (external_descriptor, match_found, linkage_info,
              entry_point_definition);
        IF match_found THEN
          check_diagnostic_severity (local_status);
        ELSE
          osp$set_status_abnormal ('LL', lle$entry_point_not_found, external_descriptor.name, local_status);
        IFEND;
      END /satisfy_entry_pt_from_library/;
    IFEND;
    IF NOT lov$program_load THEN
      fix_segment_attributes := FALSE;
      lop$fix_program_segment_attr;
    IFEND;
    IF local_status.normal AND match_found THEN
      address := local_address;
      record_dynamic_loaded_ep (name, ring, address);
      IF pmc$entry_point_xref IN lov$loader_options.map THEN
        lop$generate_cross_refernce_map;
      IFEND;
      IF pmc$segment_map IN lov$loader_options.map THEN
        lop$generate_segment_map;
      IFEND;
    IFEND;
    status := local_status;
    #KEYPOINT (osk$exit, 0, lok$load_module_from_library);
  PROCEND lop$load_module_from_library;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$terminate_loader', EJECT ??

  PROCEDURE [XDCL] lop$terminate_loader;


    loader_running := FALSE;


  PROCEND lop$terminate_loader;
?? OLDTITLE ??
?? NEWTITLE := 'check_diagnostic_severity', EJECT ??

  PROCEDURE check_diagnostic_severity
    (VAR status {control} : ost$status);

    VAR
      severity: ost$status_severity;

  /check_diagnostic_counts/
    FOR severity := first_severity_to_check TO osc$catastrophic_status DO
      IF lov$diagnostic_count [severity] <> 0 THEN
        osp$set_status_abnormal ('LL', lle$term_error_level_exceeded, '', status);
        EXIT /check_diagnostic_counts/
      IFEND;
    FOREND /check_diagnostic_counts/;
  PROCEND check_diagnostic_severity;
  ?VAR
    messages_to_job_log: boolean := FALSE?;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$report_error', EJECT ??

  PROCEDURE [XDCL] lop$report_error
    (    error_condition: ost$status_condition;
         text_1: string ( * );
         text_2: string ( * );
         number: integer);

{!  Should radix for number be passed as an argument??

    VAR
      ignore_status: ost$status,
      lov$ignore_param_verification: [XREF] integer,
      local_condition: ost$status_condition,
      load_map_data: lot$load_map_data,
      severity: ost$status_severity;

    list_modules := FALSE;
    IF error_condition = lle$declaration_mismatch THEN
      CASE lov$ignore_param_verification OF
      = 0 =
        local_condition := error_condition;
      = 1 =
        local_condition := lle$informative_dec_mismatch;
      ELSE
        RETURN;
      CASEND;
    ELSE
      local_condition := error_condition;
    IFEND;
    osp$set_status_abnormal ('LL', local_condition, text_1, load_map_data.diagnostic_status);
    IF text_2 <> '' THEN
      osp$append_status_parameter (osc$status_parameter_delimiter, text_2, load_map_data.diagnostic_status);
    IFEND;
    osp$append_status_integer (osc$status_parameter_delimiter, number, 10, FALSE,
          load_map_data.diagnostic_status);
    load_map_data.code := loc$lm_issue_diagnostic;
    ?IF messages_to_job_log = TRUE THEN
      log_loader_error (load_map_data.diagnostic_status);
    ?IFEND
    IF lov$loader_options.map <> $pmt$load_map_options [pmc$no_load_map] THEN
      lop$generate_load_map_text (load_map_data);
      IF error_condition = lle$unsatisfied_external THEN
        list_modules := TRUE;
      IFEND;
    IFEND;

    osp$get_status_severity (local_condition, severity, ignore_status);
    lov$diagnostic_count [severity] := lov$diagnostic_count [severity] + 1;
    IF severity >= first_severity_to_check THEN
      generate_message (load_map_data.diagnostic_status, ignore_status);
    IFEND;
  PROCEND lop$report_error;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$report_secondary_error', EJECT ??

  PROCEDURE [XDCL] lop$report_secondary_error
    (    status: ost$status);

    VAR
      load_map_data: lot$load_map_data,
      local_status: ost$status,
      ignore_status: ost$status,
      severity: ost$status_severity;

    local_status.condition := status.condition;
    local_status.text := status.text;
    load_map_data.code := loc$lm_issue_diagnostic;
    load_map_data.diagnostic_status := local_status;
    ?IF messages_to_job_log = TRUE THEN
      log_loader_error (local_status);
    ?IFEND
    IF lov$loader_options.map <> $pmt$load_map_options [pmc$no_load_map] THEN
      lop$generate_load_map_text (load_map_data);
    IFEND;
    osp$get_status_severity (local_status.condition, severity, ignore_status);
    lov$diagnostic_count [severity] := lov$diagnostic_count [severity] + 1;
    IF severity >= first_severity_to_check THEN
      generate_message (load_map_data.diagnostic_status, ignore_status);
    IFEND;
  PROCEND lop$report_secondary_error;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$list_referencing_module', EJECT ??

  PROCEDURE [XDCL] lop$list_referencing_module
    (    module_name: pmt$program_name);

    VAR
      byte_address: amt$file_byte_address,
      status: ost$status,
      message: string (32),
      message1: [STATIC, READ, oss$job_paged_literal] string (32) := '                                ';

    IF NOT error_file_opened THEN
      RETURN;
    IFEND;

    IF NOT list_modules THEN
      RETURN;
    IFEND;

    message := message1;
    message (2, * ) := module_name (1, * );
    amp$put_next (error_file_id, ^message, 32, byte_address, status);

  PROCEND lop$list_referencing_module;
?? OLDTITLE ??
?? NEWTITLE := 'generate_message', EJECT ??

  PROCEDURE generate_message
    (    message_status: ost$status;
     VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      ignore_status: ost$status,
      length_pointer: ^ost$status_message_line_size,
      line_count_pointer: ^ost$status_message_line_count,
      line_index: ost$status_message_line_count,
      message: ost$status_message,
      message_sequence: ^ost$status_message,
      text_pointer: ^ost$status_message_line;

    osp$format_message (message_status, osc$full_message_level, osc$max_status_message_line, message, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    message_sequence := ^message;
    RESET message_sequence;
    NEXT line_count_pointer IN message_sequence;

    IF NOT error_file_opened THEN
      fsp$open_file (error_file_name, amc$record, ^access_selections, {Default_creation=} NIL,
            {Mandated_creation=} NIL, {Attribute_validation=} NIL, {Attribute_override=} NIL, error_file_id,
            status);
      IF NOT status.normal THEN
        FOR line_index := 1 TO line_count_pointer^ DO
          NEXT length_pointer IN message_sequence;
          NEXT text_pointer: [length_pointer^] IN message_sequence;
          pmp$log (text_pointer^, ignore_status);
        FOREND;
        RETURN;
      IFEND;
      error_file_opened := TRUE;
    IFEND;

    FOR line_index := 1 TO line_count_pointer^ DO
      NEXT length_pointer IN message_sequence;
      NEXT text_pointer: [length_pointer^] IN message_sequence;
      amp$put_next (error_file_id, text_pointer, length_pointer^, byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND generate_message;
  ?IF messages_to_job_log = TRUE THEN

?? OLDTITLE ??
?? NEWTITLE := 'log_loader_error', EJECT ??

    PROCEDURE log_loader_error
      (    status: ost$status);

      VAR
        message_content: ost$status_message,
        message: ^ost$status_message,
        message_line_count: ^ost$status_message_line_count,
        message_line_size: ^ost$status_message_line_size,
        message_line_text: ^string ( * ),
        i: 1 .. osc$max_status_message_lines,
        local_status: ost$status;

      osp$format_message (status, osc$full_message_level, 100, message_content, local_status);
      message := ^message_content;
      RESET message;
      NEXT message_line_count IN message;
      FOR i := 1 TO message_line_count^ DO
        NEXT message_line_size IN message;
        NEXT message_line_text: [message_line_size^] IN message;
        pmp$log (message_line_text^, local_status);
      FOREND;
    PROCEND log_loader_error;
  ?IFEND

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$reinitialize_module', EJECT ??
*copy pmh$reinitialize_module

  PROCEDURE [XDCL, #GATE] pmp$reinitialize_module
    (    module_name: pmt$program_name;
     VAR status: ost$status);


    #KEYPOINT (osk$entry, 0, pmk$reinitialize_module);
    status.normal := TRUE;

    lop$reinitialize_module (module_name, status);

    #KEYPOINT (osk$exit, 0, pmk$reinitialize_module);

  PROCEND pmp$reinitialize_module;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$change_term_error_level', EJECT ??
*copyc pmh$change_term_error_level

  PROCEDURE [XDCL, #GATE] pmp$change_term_error_level
    (    new_termination_error_level: ost$status_severity;
     VAR old_termination_error_level: ost$status_severity;
     VAR status: ost$status);


    status.normal := TRUE;

    old_termination_error_level := first_severity_to_check;

    first_severity_to_check := new_termination_error_level;

  PROCEND pmp$change_term_error_level;
?? OLDTITLE ??
MODEND lom$loader_executive;
*DECK DECK=LOM$LOADER_FRONT_END EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'LOM$LOADER_FRONT_END', EJECT ??
MODULE lom$loader_front_end;

{ PURPOSE:  This module contains the front end and utility routines for
{           running the loader in standalone mode.



?? PUSH (LIST := OFF) ??
*copyc clp$convert_string_to_file
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc clp$convert_integer_to_rjstring

*copyc amp$file
*copyc amp$open
*copyc fsp$open_file
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc amp$close

*copyc mmp$create_scratch_segment

*copyc pmp$load
*copyc pmp$load_module_from_library
*copyc pmp$generate_unique_name
*copyc pmp$get_task_jobmode_statistics
*copyc pmp$get_binary_mainframe_id

*copyc osp$set_status_abnormal
*copyc osp$generate_message

*copyc lop$load_program
*copyc lov$task_services_entry_points
*copyc lot$loader_type_definitions
*copyc mmt$page_map_offsets
*copyc pmt$initialization_value
*copyc pmt$loader_seq_descriptor
*copyc pmt$program_description
*copyc pmt$prog_options_and_libraries
*copyc loc$task_services_library_name
*copyc clc$standard_file_names

*copyc dmt$chapter_number
*copyc mmt$attribute_keyword
*copyc osd$virtual_address
*copyc ost$heap
*copyc ost$processor_model_definitions
*copyc pmt$loadable_rings
*copyc pmt$task_control_block
*copyc oce$library_generator_errors
?? POP ??
?? NEWTITLE := '  STATIC VARIABLES ', EJECT ??

?? FMT (FORMAT := OFF) ??
  VAR
    tcb_proto: pmt$task_control_block :=
      [0,                       { task_id }
       NIL,                     { parent }
       NIL,                     { first_child }
       NIL,                     { next_sibling }
       0,                       { target_ring }
       NIL,                     { condition_environment_stack }
       [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], { flag_execution_ring }
       [0, 0, 0, 0],            { signal_execution_ring }
       [NIL, NIL],              { task_local_signal_list }
       0,                       { task_kill_count }
       pmc$task_executing,      { task_kill_phase }
       osc$tk_nosve_task,       { task_kind }
       [NIL,                    { program_description }
       NIL,                     { mpe_description }
       NIL,                     { program_parameters }
       NIL,                     { termination_status }
       NIL,                     { parent_task_status_variable }
       NIL,                     { debug_table }
       clc$null_file,           { debug_input }
       clc$null_file,           { debug_output }
       clc$null_file,           { abort_file }
       pmc$debug_mode_off,      { initial_debug_mode }
       FALSE,                   { cl_task }
       [mmc$cell_pointer, NIL], { ada_shared_stack_pointer }
       NIL,                     { ada_critical_frame }
       NIL,                     { ada_starting_procedure }
       NIL,                     { ada_task_table }
       0,                       { task_condition_count }
       0,                       { task_handler_count }
       TRUE]];                  { task_io_enabled }
?? FMT (FORMAT := ON) ??

  VAR
    debug_table_proto: pmt$debug_table_info :=
      [[mmc$sequence_pointer, NIL], [mmc$sequence_pointer, NIL], NIL, NIL, NIL, NIL, 0];

  VAR
    lov$enable_source_type_checking: [XDCL] boolean := FALSE,
    lov$ignore_param_verification: [XDCL] integer := 0,
    mmv$preset_conversion_table: [XDCL, READ] array [pmt$initialization_value]
        of integer := [1, 2, 3, 4],
    mmv$page_map_offsets: [XDCL] mmt$page_map_offsets := [0, 0, 0, 0, 0],
    osv$global_processor_model_info: [XDCL] ost$processor_model_definition,
    pmv$prog_options_and_libraries: [XDCL] ^pmt$prog_options_and_libraries,
    pmv$task_tcb_p: [XDCL] ^pmt$task_control_block,
    processor_model_definition1: ost$processor_model_definition :=
        [osc$cyber_180_model_855, osc$cyber_180_model_855, pmc$cyber_180_model_855,
         pmc$cyber_180_model_855_class, pmc$cyber_180_model_855_class,
         30000, 50000, TRUE, TRUE, pmc$no_vectors],
    processor_model_definition2: ost$processor_model_definition :=
        [osc$cyber_180_model_990, osc$cyber_180_model_990, pmc$cyber_180_model_990,
         pmc$cyber_180_model_990_class, pmc$cyber_180_model_995_class,
         30000, 50000, TRUE, TRUE, pmc$standard_vectors],
    prog_options_and_libraries: pmt$prog_options_and_libraries,
    osv$page_size: [XDCL] ost$page_size := 1000(16),
    osv$task_private_heap: [XDCL] ^ost$heap;
?? OLDTITLE ??
?? NEWTITLE := '  TASK_SERVICES_ENTRY_POINTS', EJECT ??
?? FMT (FORMAT := OFF) ??
  CONST
    max_tsep = 1651;

  VAR
    task_services_entry_point: [STATIC] lot$task_services_entry_point :=
      [*,[1,1d(16),0f0f0f0(16)],[1,1b(16),0f0f0f0(16)],TRUE,*,1,3,15,osc$cyber_180_mode,FALSE,*,llc$cybil],
    task_services_entry_points: ^array [1 .. max_tsep] of lot$task_services_entry_point,
    task_services_entry_point_names: [static] array [1 .. max_tsep] of pmt$program_name := [
?? PUSH (LIST := OFF) ??
    'ADJUST_AGE_INTERVAL              ',
    'AMP$ACCESS_METHOD                ',
    'AMP$ADD_TO_FILE_DESCRIPTION      ',
    'AMP$CHECK_RECORD                 ',
    'AMP$CLOSE                        ',
    'AMP$COPY_FILE                    ',
    'AMP$DELETE_KEY                   ',
    'AMP$FETCH                        ',
    'AMP$FETCH_ACCESS_INFORMATION     ',
    'AMP$FETCH_FAP_POINTER            ',
    'AMP$FILE                         ',
    'AMP$FLUSH                        ',
    'AMP$GET_DIRECT                   ',
    'AMP$GET_FILE_ATTRIBUTES          ',
    'AMP$GET_KEY                      ',
    'AMP$GET_NEXT                     ',
    'AMP$GET_NEXT_KEY                 ',
    'AMP$GET_PARTIAL                  ',
    'AMP$GET_SEGMENT_POINTER          ',
    'AMP$OPEN                         ',
    'AMP$OVERRIDE_FILE_ATTRIBUTES     ',
    'AMP$PUTREP                       ',
    'AMP$PUT_DIRECT                   ',
    'AMP$PUT_KEY                      ',
    'AMP$PUT_NEXT                     ',
    'AMP$PUT_PARTIAL                  ',
    'AMP$RENAME                       ',
    'AMP$REPLACE_KEY                  ',
    'AMP$RETURN                       ',
    'AMP$REWIND                       ',
    'AMP$SEEK_DIRECT                  ',
    'AMP$SET_FILE_INSTANCE_ABNORMAL   ',
    'AMP$SET_LOCAL_NAME_ABNORMAL      ',
    'AMP$SET_SEGMENT_EOI              ',
    'AMP$SET_SEGMENT_POSITION         ',
    'AMP$SKIP                         ',
    'AMP$SKIP_TAPE_MARKS              ',
    'AMP$START                        ',
    'AMP$STORE                        ',
    'AMP$STORE_FAP_POINTER            ',
    'AMP$VALIDATE_CALLER_PRIVILEGE    ',
    'AMP$WRITE_END_PARTITION          ',
    'AMP$WRITE_TAPE_MARK              ',
    'AVP$BEGIN_ACCOUNT                ',
    'AVP$CHANGE_PASSWORD              ',
    'AVP$CHANGE_USER                  ',
    'AVP$CONSTRAIN                    ',
    'AVP$CONSTRAIN_INTERFACE          ',
    'AVP$CREATE_FAMILY                ',
    'AVP$CREATE_FAMILY_INTERFACE      ',
    'AVP$CREATE_USER                  ',
    'AVP$DEFINE_FAMILY                ',
    'AVP$DELETE                       ',
    'AVP$DELETE_USER                  ',
    'AVP$END_ACCOUNT                  ',
    'AVP$GET_ADMINISTRATOR_STATUS     ',
    'AVP$GET_EPILOGS                  ',
    'AVP$GET_FAMILY_ADMINISTRATOR     ',
    'AVP$GET_JOB_LIMITS               ',
    'AVP$GET_NEXT_USER                ',
    'AVP$GET_PROLOGS                  ',
    'AVP$GET_SCRATCH_SETS             ',
    'AVP$GET_SRU_INTERFACE            ',
    'AVP$GET_USER_SET                 ',
    'AVP$INITIALIZE                   ',
    'AVP$INITIALIZE_SEGMENT           ',
    'AVP$INSERT                       ',
    'AVP$LOGIN_USER                   ',
    'AVP$MAXIMUM_WORKING_SET          ',
    'AVP$MONITOR_STATISTICS_HANDLER   ',
    'AVP$PREVALIDATE_USER             ',
    'AVP$READ_USER                    ',
    'AVP$REGISTER_FAMILY              ',
    'AVP$REGISTER_SYSTEM_FAMILIES     ',
    'AVP$REMOVE_FAMILY                ',
    'AVP$RING_MIN                     ',
    'AVP$RING_NOMINAL                 ',
    'AVP$SEARCH                       ',
    'AVP$SEQUENTIAL_SEARCH            ',
    'AVP$SET_JOB_LIMITS               ',
    'AVV$JOB_LIMITS_BLOCK             ',
    'AVV$REGISTERED_FAMILY_LIST       ',
    'BAP$ADD_TO_FILE_DESCRIPTION      ',
    'BAP$BYTE_MOVE                    ',
    'BAP$CHANGE_FILE_ATTRIBUTES       ',
    'BAP$DATA_PROFILE                 ',
    'BAP$END_OPEN_NEW_PROCESSING      ',
    'BAP$FAP_CONTROL                  ',
    'BAP$FETCH_ART_TABLE_POINTER      ',
    'BAP$FILE_COMMAND                 ',
    'BAP$GET_DATA_PROFILE             ',
    'BAP$GET_DEVICE_CLASS             ',
    'BAP$GET_FILE_ATTRIBUTES          ',
    'BAP$GET_OPEN_INFORMATION         ',
    'BAP$MARK_FAP_LAYER_CLOSED        ',
    'BAP$MARK_FAP_LAYER_OPEN          ',
    'BAP$MAX_SEGMENT_LENGTH           ',
    'BAP$NULL_DEVICE                  ',
    'BAP$OPEN                         ',
    'BAP$RELEASE_RESOURCE_COMMAND     ',
    'BAP$RENAME                       ',
    'BAP$REQUEST_NULL_DEVICE_COMMAND  ',
    'BAP$REQUEST_TAPE_COMMAND         ',
    'BAP$REQUEST_TERMINAL_COMMAND     ',
    'BAP$RESERVE_RESOURCE_COMMAND     ',
    'BAP$RETURN                       ',
    'BAP$SKIP_TAPE_MARKS              ',
    'BAP$STORE_ART_TABLE_POINTER      ',
    'BAP$SYS_BLK_VARIABLE_REC_FAP     ',
    'BAP$TAPE_FAP                     ',
    'BAV$ENTRY_ASSIGNED_SELECT        ',
    'BAV$ENTRY_FREE_SELECT            ',
    'BAV$TASK_FILE_TABLE              ',
    'BAV$TFT_ENTRY_ASSIGNMENT         ',
    'BRING_UP_JOB_TASKS               ',
    'CDEULER                          ',
    'CITOII                           ',
    'CLP$ADD_TO_JOB_COMMAND_LIST      ',
    'CLP$ASSIGN_VARIABLE_VALUE        ',
    'CLP$ASSOCIATE_PATH_DESC_ENTRIES  ',
    'CLP$BUILD_PATH_SUBTITLE          ',
    'CLP$BUILD_STANDARD_TITLE         ',
    'CLP$CHANGE_PF_NAME_IN_PATH_DESC  ',
    'CLP$CHECK_LIST_FOR_VARIABLE      ',
    'CLP$CLOSE_COMMAND_FILE           ',
    'CLP$CLOSE_CONNECTED_FILE         ',
    'CLP$CLOSE_DISPLAY                ',
    'CLP$CLOSE_OPENED_TARGET_FILE     ',
    'CLP$CLOSE_UNOPENED_TARGET_FILE   ',
    'CLP$COLLECT_COMMANDS             ',
    'CLP$CONNECTED_FILE_FAP           ',
    'CLP$CONSOLE_FAP                  ',
    'CLP$CONTINUE                     ',
    'CLP$CONVERT_CHAR_TO_GRAPHIC      ',
    'CLP$CONVERT_CONSOLE_TO_ASCII     ',
    'CLP$CONVERT_INTEGER_TO_RJSTRING  ',
    'CLP$CONVERT_INTEGER_TO_STRING    ',
    'CLP$CONVERT_STRING_TO_FILE       ',
    'CLP$CONVERT_STRING_TO_INTEGER    ',
    'CLP$CONVERT_STRING_TO_NAME       ',
    'CLP$CONVERT_VALUE_TO_STRING      ',
    'CLP$CREATE_FILE_CONNECTION       ',
    'CLP$CREATE_VARIABLE              ',
    'CLP$CYCLE_BLOCK                  ',
    'CLP$DELETE_ALL_JOB_COMMAND_LIST  ',
    'CLP$DELETE_FILE_CONNECTION       ',
    'CLP$DELETE_FROM_JOB_CMND_LIST    ',
    'CLP$DELETE_IF_ONLY_PATH_REF      ',
    'CLP$DELETE_NAMED_TASK_ENTRY      ',
    'CLP$DELETE_VARIABLE              ',
    'CLP$DETERMINE_LINE_LAYOUT        ',
    'CLP$DISCARD_ACCUMULATED_DISPLAY  ',
    'CLP$DISESTABLISH_COND_HANDLER    ',
    'CLP$DISPLAY_ALL_INPUT_COMMAND    ',
    'CLP$DISPLAY_ALL_OUTPUT_COMMAND   ',
    'CLP$END_SCAN_COMMAND_FILE        ',
    'CLP$ESTABLISH_CONDITION_HANDLER  ',
    'CLP$ESTABLISH_SYS_COMMAND_LIB    ',
    'CLP$EXECUTE_NAMED_TASK           ',
    'CLP$EXIT_BLOCK                   ',
    'CLP$EXIT_PROC                    ',
    'CLP$FETCH_CONSOLE_FAP_DATA       ',
    'CLP$FETCH_DISPLAY_LOG_INDICES    ',
    'CLP$FETCH_NAMED_TASK_ENTRY       ',
    'CLP$FETCH_SYSTEM_FILE_ID         ',
    'CLP$FIND_CMND_LIB_ENTRY_POINTS   ',
    'CLP$FIND_CURRENT_BLOCK           ',
    'CLP$FIND_CYCLE_BLOCK             ',
    'CLP$FIND_INPUT_BLOCK             ',
    'CLP$FIND_NEXT_VAR_BLOCK          ',
    'CLP$FIND_OPEN_CONNECTED_FILE     ',
    'CLP$FIND_PATH_DESC_VIA_LFN       ',
    'CLP$FIND_PF_PATH_DESC_VIA_LFN    ',
    'CLP$FIND_TASK_BLOCK              ',
    'CLP$FIND_VARIABLE_ACCESS         ',
    'CLP$FIND_VAR_BLOCK               ',
    'CLP$GET_CMND_LIB_ENTRY_POINTS    ',
    'CLP$GET_COMMAND_FILE_DEVICE      ',
    'CLP$GET_COMMAND_LINE             ',
    'CLP$GET_COMMAND_MODE             ',
    'CLP$GET_COMMAND_ORIGIN           ',
    'CLP$GET_COMMAND_SEARCH_MODE      ',
    'CLP$GET_DATA_LINE                ',
    'CLP$GET_DATA_RECORD              ',
    'CLP$GET_INTERPRETER_MODE         ',
    'CLP$GET_LIB_PROGRAM_DESCRIPTION  ',
    'CLP$GET_LINE_FROM_COMMAND_FILE   ',
    'CLP$GET_LINE_FROM_CONSOLE        ',
    'CLP$GET_LIST_OF_$LOCAL_FILES     ',
    'CLP$GET_PARAMETER                ',
    'CLP$GET_PARAMETER_LIST           ',
    'CLP$GET_PATH_DESCRIPTION         ',
    'CLP$GET_PATH_NAME                ',
    'CLP$GET_QUEUE_ID                 ',
    'CLP$GET_SET_COUNT                ',
    'CLP$GET_VALUE                    ',
    'CLP$GET_VALUE_COUNT              ',
    'CLP$GET_WORKING_CATALOG          ',
    'CLP$HORIZONTAL_TAB_DISPLAY       ',
    'CLP$IGNORE_REST_OF_FILE          ',
    'CLP$INITIALIZE_FILE_RING_ATTR    ',
    'CLP$INITIALIZE_PVT               ',
    'CLP$INITIALIZE_VARIABLE          ',
    'CLP$INIT_COMMAND_LIST_DISPLAY    ',
    'CLP$INIT_COMMAND_LIST_SEARCH     ',
    'CLP$INIT_FUNCTION_LIST_SEARCH    ',
    'CLP$INIT_MESSAGE_LIST_SEARCH     ',
    'CLP$INTERNAL_CREATE_VARIABLE     ',
    'CLP$ISOLATE_COMMAND              ',
    'CLP$KEYPOINT                     ',
    'CLP$K_DISPLAY_FAP                ',
    'CLP$LOAD_SYSTEM_COMMAND          ',
    'CLP$LOCAL_QUEUE_FAP              ',
    'CLP$LOCK_CONNECTED_FILE_LIST     ',
    'CLP$LOG_COMMAND_LINE             ',
    'CLP$LOG_COMMENT                  ',
    'CLP$LOG_EDITED_LOGIN_COMMAND     ',
    'CLP$MAKE_PATH_DESC_GLOBAL        ',
    'CLP$NEW_DISPLAY_LINE             ',
    'CLP$NEW_DISPLAY_PAGE             ',
    'CLP$NOTIFY_BEFORE_COMMAND_READ   ',
    'CLP$OPEN_COMMAND_FILE            ',
    'CLP$OPEN_CONNECTED_FILE          ',
    'CLP$OPEN_CONNECTED_FILE_TARGET   ',
    'CLP$OPEN_DISPLAY                 ',
    'CLP$PARSE_COMMAND                ',
    'CLP$PASS_VARIABLE_PARAMETER      ',
    'CLP$POP_BLOCK_STACK              ',
    'CLP$POP_INPUT_STACK              ',
    'CLP$POP_PARAMETERS               ',
    'CLP$POP_TASK_COMMAND_LIST        ',
    'CLP$POP_TERMINATED_BLOCKS        ',
    'CLP$POP_UTILITY                  ',
    'CLP$PUSH_BLOCK_STACK             ',
    'CLP$PUSH_INPUT_STACK             ',
    'CLP$PUSH_PARAMETERS              ',
    'CLP$PUSH_TASK_COMMAND_LIST       ',
    'CLP$PUSH_UTILITY                 ',
    'CLP$PUSH_WHEN_BLOCK              ',
    'CLP$PUT_COMMAND_PARAMETERS       ',
    'CLP$PUT_DISPLAY                  ',
    'CLP$PUT_ERROR_OUTPUT             ',
    'CLP$PUT_JOB_COMMAND_RESPONSE     ',
    'CLP$PUT_JOB_OUTPUT               ',
    'CLP$PUT_PARTIAL_DISPLAY          ',
    'CLP$READ_INPUT_FILE              ',
    'CLP$READ_VARIABLE                ',
    'CLP$REBUILD_INPUT_QUEUE          ',
    'CLP$REBUILD_OUTPUT_QUEUE         ',
    'CLP$RECORD_PATH_REFERENCE        ',
    'CLP$REFERENCE_VARIABLE           ',
    'CLP$RESET_FOR_NEXT_DISPLAY_PAGE  ',
    'CLP$RESET_INPUT_POSITION         ',
    'CLP$RESOLVE_CYCLE_SELECTOR       ',
    'CLP$RETURN_LOCAL_FILE            ',
    'CLP$REWRITE_VARIABLE             ',
    'CLP$SAVE_PVT                     ',
    'CLP$SCAN_ARGUMENT_LIST           ',
    'CLP$SCAN_COMMAND_FILE            ',
    'CLP$SCAN_COMMAND_LINE            ',
    'CLP$SCAN_EXPRESSION              ',
    'CLP$SCAN_PARAMETER_LIST          ',
    'CLP$SCAN_PROC_DECLARATION        ',
    'CLP$SCAN_TOKEN                   ',
    'CLP$SEARCH_COMMAND_LIBRARY       ',
    'CLP$SEARCH_MESSAGE_LIBRARY       ',
    'CLP$SET_COMMAND_ATTRIBUTES       ',
    'CLP$SET_CURRENT_PROMPT_STRING    ',
    'CLP$SET_EXIT_POSITION            ',
    'CLP$SET_FOR_BLOCK                ',
    'CLP$SET_FOR_VALUE                ',
    'CLP$SET_IF_BLOCK                 ',
    'CLP$SET_INPUT_LINE               ',
    'CLP$SET_INPUT_LINE_INDEX         ',
    'CLP$SET_JOB_COMMAND_SEARCH_MODE  ',
    'CLP$SET_JSN_COMMAND              ',
    'CLP$SET_PREV_CMND_NAME_AND_STAT  ',
    'CLP$SET_PRIMARY_TASK             ',
    'CLP$SET_PROC_NAME                ',
    'CLP$SET_REPEAT_WHILE_BLOCK       ',
    'CLP$SET_SYSTEM_LOGGING_ACTIVE    ',
    'CLP$SET_TASK_STATEMENT_TASK      ',
    'CLP$SET_WORKING_CATALOG          ',
    'CLP$SET_WORKING_CATALOG_PATH     ',
    'CLP$SIMULATOR_FAP                ',
    'CLP$SKIP_BLOCK                   ',
    'CLP$STORE_CONSOLE_FAP_DATA       ',
    'CLP$STORE_DISPLAY_LOG_INDICES    ',
    'CLP$STORE_SYSTEM_FILE_ID         ',
    'CLP$SUPPRESS_COMMAND_LOGGING     ',
    'CLP$TASK_TASKEND                 ',
    'CLP$TEST_PARAMETER               ',
    'CLP$TEST_RANGE                   ',
    'CLP$TRIMMED_STRING_SIZE          ',
    'CLP$TURN_KEYPOINT_OFF            ',
    'CLP$UNLOCK_CONNECTED_FILE_LIST   ',
    'CLP$UNRESOLVE_CYCLE_SELECTOR     ',
    'CLP$UPDATE_CONNECTED_FILE        ',
    'CLP$VERTICAL_TAB_DISPLAY         ',
    'CLP$WRITE_VARIABLE               ',
    'CLV$CHARACTER_CLASS              ',
    'CLV$COMMENT_DELIMITER            ',
    'CLV$CONNECTED_FILE_LIST          ',
    'CLV$ISOLATE_COMMAND              ',
    'CLV$NON_ALPHANUMERIC             ',
    'CLV$STRING_DELIMITER             ',
    'CLV$SYSTEM_LOGGING_ACTIVATED     ',
    'CMP$ACQUIRE_170_RESOURCES        ',
    'CMP$ACTIVATE_VOLUME              ',
    'CMP$ASSIGN_UNIT                  ',
    'CMP$BEGIN_TRANSITION             ',
    'CMP$BUILD_INTERFACE_TABLES       ',
    'CMP$BUILD_LCT                    ',
    'CMP$BUILD_LOGICAL_CONF           ',
    'CMP$BUILD_PCT                    ',
    'CMP$BUILD_REQUEST_ENTRY          ',
    'CMP$BUILD_STND_INTERFACE_TABLES  ',
    'CMP$CHECK_FOR_UNIQUE_ELEMENT     ',
    'CMP$CONFIGURE_INSTALLED_SYSTEM   ',
    'CMP$CONFIGURE_SYSTEM_DEVICE      ',
    'CMP$DEADSTART_PHASE              ',
    'CMP$DISPLAY_NAMED_ELEMENT        ',
    'CMP$DISPLAY_TYPE_ELEMENTS        ',
    'CMP$FIND_ELEMENT                 ',
    'CMP$GENERATE_INTERFACE_TABLES    ',
    'CMP$GET_CONFIGURATION_FILE       ',
    'CMP$GET_CONTROLLER_TYPE          ',
    'CMP$GET_CONTROLLER_TYPE_R3       ',
    'CMP$GET_DEVICE_FILE              ',
    'CMP$GET_ELEMENT_NAME             ',
    'CMP$GET_ELEMENT_R3               ',
    'CMP$GET_LOGICAL_ATTRIBUTES       ',
    'CMP$GET_LOGICAL_CONF_TABLE       ',
    'CMP$GET_LOGICAL_UNIT_NUMBER      ',
    'CMP$GET_LOGICAL_UNIT_NUMBER_R3   ',
    'CMP$GET_MAINFRAME_ELEMENT        ',
    'CMP$GET_PHYSICAL_ATTRIBUTES      ',
    'CMP$GET_PHYSICAL_CONF_TABLE      ',
    'CMP$GET_SYS_DEV_REC_VSN          ',
    'CMP$GET_UNIT_NUMBER_VIA_VSN      ',
    'CMP$INITIALIZE_ADTT              ',
    'CMP$INITIALIZE_MS_VOLUME         ',
    'CMP$PC_GET_ELEMENT               ',
    'CMP$PC_GET_LOGICAL_UNIT          ',
    'CMP$PC_GET_NEXT_CHANNEL          ',
    'CMP$RELEASE_UNIT                 ',
    'CMP$SAVE_DEVICE_FILE             ',
    'CMP$VOLUME_ONLINE                ',
    'CMV$ASSIGNABLE_DEVICE            ',
    'CMV$LOGICAL_CONFIGURATION        ',
    'CMV$LOGICAL_CONF_DEV_FILE_NAME   ',
    'CMV$LOGICAL_PP_TABLE             ',
    'CMV$LOGICAL_UNIT_TABLE           ',
    'CMV$NEW_LOGICAL_PP_TABLE         ',
    'CMV$NEW_LOGICAL_UNIT_TABLE       ',
    'CMV$PHYSICAL_CONFIGURATION       ',
    'CMV$PHYSICAL_CONF_DEV_FILE_NAME  ',
    'CMV$PRODUCT_ID_PTR               ',
    'CMV$SYSTEM_CORE_COMMANDS         ',
    'CMV$SYSTEM_DEVICE_ADDRESS_TYPE   ',
    'CONSTRUCT_AJL_ENTRY              ',
    'CYP$ALLOCATE                     ',
    'CYP$ERROR                        ',
    'CYP$FREE                         ',
    'CYP$NIL                          ',
    'CYP$OUTPUT_FLOATING_NUMBER       ',
    'CYP$ROUND_FLOATING_NUMBER        ',
    'CYP$SCALE_FLOATING_NUMBER        ',
    'CYP$STRINGREP                    ',
    'CYP$VALOG                        ',
    'CYP$VALOG10                      ',
    'CYP$VDEXP                        ',
    'CYP$VDLOG                        ',
    'CYP$VDLOG10                      ',
    'CYV$DOUBLE_POWERS_OF_TEN         ',
    'DBP$ENTRY_POINT_TABLE_ADDRESS    ',
    'DBP$MODULE_TABLE_ADDRESS         ',
    'DMP$ACQUIRE_TAPE_RESOURCE        ',
    'DMP$ACTION_OPERATOR              ',
    'DMP$ACTIVATE_VOLUME              ',
    'DMP$ADMINISTER_ALLOCATION_LOG    ',
    'DMP$ADMINISTER_DEVICE_LOG        ',
    'DMP$ASSIGN_TAPE                  ',
    'DMP$ATTACH_DEVICE_FILE           ',
    'DMP$ATTACH_FILE                  ',
    'DMP$CLOSE_DAT_R3                 ',
    'DMP$CLOSE_DEVICE_FILE_R3         ',
    'DMP$CLOSE_DIRECTORY_R3           ',
    'DMP$CLOSE_LABEL_R3               ',
    'DMP$CLOSE_SEGMENT_ACCESS_FILE    ',
    'DMP$CONVERT_SFID_TO_LUN          ',
    'DMP$CRACK_ASSIGN_REPLY           ',
    'DMP$CREATE_DEVICE_FILE           ',
    'DMP$CREATE_FILE_ENTRY            ',
    'DMP$CREATE_TAPE_MESSAGE          ',
    'DMP$CREATE_TAPE_WINDOW           ',
    'DMP$CREATE_TIR                   ',
    'DMP$CREATE_TMD                   ',
    'DMP$DEACTIVATE_VOLUME            ',
    'DMP$DELETE_FILE_DESCRIPTOR       ',
    'DMP$DESELECT_TAPE_SUBFILE        ',
    'DMP$DESTROY_DEVICE_FILE          ',
    'DMP$DESTROY_FILE                 ',
    'DMP$DESTROY_PERMANENT_FILE       ',
    'DMP$DESTROY_SUB_FILE             ',
    'DMP$DESTROY_TAPE_WINDOW          ',
    'DMP$DESTROY_TMD                  ',
    'DMP$DETACH_DEVICE_FILE           ',
    'DMP$DETACH_FILE                  ',
    'DMP$DEV_MGMT_TABLE_UPDATE        ',
    'DMP$DISPLAY_DAT                  ',
    'DMP$DISPLAY_DEVICE_FILE          ',
    'DMP$DISPLAY_DEVICE_LOG           ',
    'DMP$DISPLAY_DEVICE_SPACE         ',
    'DMP$DISPLAY_DIRECTORY            ',
    'DMP$DISPLAY_LABEL                ',
    'DMP$DISPLAY_LOGIN_TABLE          ',
    'DMP$ENABLE_UPDATE                ',
    'DMP$EVACUATE_ACTIVE_DEVICE_LOG   ',
    'DMP$EVACUATE_OLD_DEVICE_LOG      ',
    'DMP$FETCH_EOI                    ',
    'DMP$FETCH_SEGMENT_FILE_INFO      ',
    'DMP$FIXUP_FILE_ALLOCATION_UNIT   ',
    'DMP$FIXUP_FILE_EOF               ',
    'DMP$FIXUP_FILE_EOI               ',
    'DMP$FIXUP_SUBF_ALLOCATED_LENGTH  ',
    'DMP$FIXUP_SUBF_LOGICAL_LENGTH    ',
    'DMP$FREE_BACKING_STORE           ',
    'DMP$FREE_FILE_TABLES             ',
    'DMP$GET_ALLOCATION_SIZE          ',
    'DMP$GET_LOGICAL_ATTRIBUTES       ',
    'DMP$GET_LOGICAL_UNIT_NUMBER      ',
    'DMP$GET_PHYSICAL_ATTRIBUTES      ',
    'DMP$GET_STORED_FMD               ',
    'DMP$GET_STORED_FMD_HEADER        ',
    'DMP$GET_STORED_FMD_SIZE          ',
    'DMP$GET_STORED_FMD_SUBFILES      ',
    'DMP$GET_TAPE_MEDIUM_DESCRIPTOR   ',
    'DMP$GET_TMD_FIELD                ',
    'DMP$GET_VOLUMES_ACTIVE           ',
    'DMP$INCREASE_FAT_SIZE            ',
    'DMP$INHIBIT_UPDATE               ',
    'DMP$INITIALIZE_MS_VOLUME         ',
    'DMP$LOCK_DAT                     ',
    'DMP$LOCK_DFLT                    ',
    'DMP$LOCK_DIRECTORY               ',
    'DMP$LOCK_FILE                    ',
    'DMP$LOCK_FILE_DESCRIPTOR_ENTRY   ',
    'DMP$LOCK_LOGIN_TABLE             ',
    'DMP$LOGOUT_RECOVERED_MAINFRAME   ',
    'DMP$OPEN_DAT_FOR_SEGMENT_ACCES   ',
    'DMP$OPEN_DAT_R3                  ',
    'DMP$OPEN_DEVICE_FILE_R3          ',
    'DMP$OPEN_DFLT_FOR_SEGMENT_ACCES  ',
    'DMP$OPEN_DIRECTORY_R3            ',
    'DMP$OPEN_DIR_FOR_SEG_ACCESS      ',
    'DMP$OPEN_FILE_FOR_SEGMENT_ACCES  ',
    'DMP$OPEN_FILE_SEGMENT            ',
    'DMP$OPEN_LABEL_R3                ',
    'DMP$OPEN_LAB_FOR_SEGMENT_ACCES   ',
    'DMP$OPEN_LGIN_FOR_SEGMENT_ACCES  ',
    'DMP$PROCESS_DEVICE_LOG_ENTRY     ',
    'DMP$RECOVER_FILE                 ',
    'DMP$RECOVER_MAINFRAME            ',
    'DMP$RETURN_DAT_ENTRIES           ',
    'DMP$RETURN_DFL_ENTRIES           ',
    'DMP$RETURN_TAPE_RESOURCE         ',
    'DMP$SEARCH_LOGIN_TABLE           ',
    'DMP$SEARCH_VOL_DIRECTORY_NAME    ',
    'DMP$SELECT_TAPE_SUBFILE          ',
    'DMP$SET_EOI                      ',
    'DMP$SET_FILE_LIMIT               ',
    'DMP$SET_LOWER_PRIORITY           ',
    'DMP$SET_TRANSFER_SIZE            ',
    'DMP$SPLIT_ALLOCATION_LOG         ',
    'DMP$SWAP_TAPE                    ',
    'DMP$UNLOCK_DAT                   ',
    'DMP$UNLOCK_DFLT                  ',
    'DMP$UNLOCK_DIRECTORY             ',
    'DMP$UNLOCK_FILE                  ',
    'DMP$UNLOCK_LOGIN_TABLE           ',
    'DMP$UPDATE_VOLUME_TABLES         ',
    'DMP$VALIDATE_ASSIGN_REPLY        ',
    'DMP$VALIDATE_EXTERNAL_VSN        ',
    'DMP$VOLUME_ONLINE                ',
    'DMV$ACTIVE_VOLUME_TABLE          ',
    'DMV$ADMINISTER_LOG_INITIATED     ',
    'DMV$ALLOCATION_LOG               ',
    'DMV$DEBUG_OPTIONS                ',
    'DMV$EXTERNAL_INTERRUPT_SELECTOR  ',
    'DMV$FREE_POSITION_CHAIN          ',
    'DMV$FREE_POSITION_CHAIN_LOCKED   ',
    'DMV$MAXIMUM_MAT_FILE_SPACE       ',
    'DMV$MAX_MAT_ALLOCATION_STYLES    ',
    'DMV$MINIMUM_MAT_FILE_SPACE       ',
    'DMV$MIN_MAT_ALLOCATION_STYLES    ',
    'DMV$MS_DEFAULT_FAT_ENTRY         ',
    'DMV$MS_DEFAULT_FAT_HEADER        ',
    'DMV$NOM_MAT_ALLOCATION_STYLES    ',
    'DMV$NULL_SFID                    ',
    'DMV$NULL_VSN                     ',
    'DMV$N_MAT_ENTRIES_IN_FREE_CHAIN  ',
    'DMV$P_JOB_FILE_TABLE_ROOT        ',
    'DMV$P_JOB_TAPE_TABLE             ',
    'DMV$SIZE_OF_FDT_ALLOCATION       ',
    'DMV$SPLIT_AL_INITIATED           ',
    'DMV$SYSTEM_DEVICE_LUN            ',
    'DMV$SYSTEM_DEVICE_PRODUCT_ID     ',
    'DMV$SYSTEM_DEVICE_RECORDED_VSN   ',
    'DMV$SYSTEM_FILE_TABLE_ROOT       ',
    'DMV$TAPE_REQUEST_LIST            ',
    'DMV$VOLUME_WEIGHTING_FACTORS     ',
    'DMV$WIDTH_OF_SFT                 ',
    'DPP$6_12_TO_ASCII                ',
    'DPP$DISPLAY_TO_ASCII             ',
    'DPP$OPEN                         ',
    'DPP$PUT                          ',
    'DPP$PUT_DIRECT                   ',
    'DPP$SCROLL                       ',
    'DPV$DISPLAY_DELAY                ',
    'DSOPT                            ',
    'DSP$ADVANCE_RECOVERY_SEQUENCE    ',
    'DSP$CLEAR_SFT_LOCK               ',
    'DSP$DISABLE_DEADSTART_INPUT      ',
    'DSP$FETCH_COMMAND_BLOCK          ',
    'DSP$FETCH_LIST_BLOCK             ',
    'DSP$FETCH_PVAS_OF_IMAGE_PAGES    ',
    'DSP$GET_DEADSTART_INPUT          ',
    'DSP$GET_FILE_ALLOCATION_TABLE    ',
    'DSP$GET_FILE_MEDIUM_DESCRIPTOR   ',
    'DSP$GET_FMD_SUBFILE              ',
    'DSP$GET_JOB_SEQUENCE_NUMBER      ',
    'DSP$GET_LAST_DSTAPE_RECORD_TYPE  ',
    'DSP$GET_LOCKED_SFT_ENTRY         ',
    'DSP$GET_NVE_IMAGE_DESCRIPTION    ',
    'DSP$GET_STANDALONE_FLAG          ',
    'DSP$HANDLE_ERROR_JOURNAL_FLAG    ',
    'DSP$LOAD_FILES                   ',
    'DSP$MAKE_IMAGE_FILE              ',
    'DSP$MAKE_SSR_SEGMENT             ',
    'DSP$POSITION_DEADSTART_TAPE      ',
    'DSP$R3GET_DEADSTART_INPUT        ',
    'DSP$R3GET_STANDALONE_FLAG        ',
    'DSP$R3POSITION_DEADSTART_TAPE    ',
    'DSP$R3SET_GLOBAL_POINTER         ',
    'DSP$R3SKIP_DEADSTART_INPUT       ',
    'DSP$R3TERMINATE_DEADSTART_INPUT  ',
    'DSP$RECEIVE_DATA_VIA_SSR         ',
    'DSP$RECOVER_COMMANDS             ',
    'DSP$RECOVER_LIST                 ',
    'DSP$RESET_IMAGE_FILE             ',
    'DSP$SEARCH_ACTIVE_VOLUME_TABLE   ',
    'DSP$SEND_DATA_VIA_SSR            ',
    'DSP$SETUP_DEADSTART              ',
    'DSP$SET_JOB_SEQUENCE_NUMBER      ',
    'DSP$SKIP_DEADSTART_INPUT         ',
    'DSP$STORE_COMMANDS               ',
    'DSP$STORE_COMMAND_BLOCK          ',
    'DSP$STORE_LIST                   ',
    'DSP$STORE_LIST_BLOCK             ',
    'DSP$SYSTEM_COMMITTED             ',
    'DSP$TERMINATE_DEADSTART_INPUT    ',
    'DSP$TEST_DEADSTART_INPUT         ',
    'DSP$TEST_IMAGE                   ',
    'DSP$TEST_SSR_ENVIRON             ',
    'DSV$CONSOLE_MODE                 ',
    'DSV$DEADSTART_MODE               ',
    'DSV$IMAGE_SEGMENT                ',
    'DSV$INSTALL_TPXXXK               ',
    'DSV$JOURNAL_CONTROL_RECORD       ',
    'DSV$LOAD_FILES                   ',
    'DSV$MEMORY_IMAGE                 ',
    'DSV$MTR_SSR_SEGMENT_P            ',
    'DSV$MULTI_TAPE_DEADSTART         ',
    'DSV$NO_SSR_USAGE                 ',
    'DSV$NVE_IMAGE_STATUS             ',
    'DSV$PGLOBAL                      ',
    'DSV$RCV_MAINFRAME_WIRED_ASID     ',
    'DSV$RCV_MAINFRAME_WIRED_PVA      ',
    'DSV$RCV_MAINFRAME_WIRED_SEGMENT  ',
    'DSV$RCV_SSR_DESCRIPTOR_P         ',
    'DSV$RECORD_ERRORS                ',
    'DSV$REC_ATTEMPT_NO_IMAGE         ',
    'DSV$REC_ATTEMPT_WITH_IMAGE       ',
    'DSV$SSR_DESCRIPTOR_P             ',
    'DSV$SSR_ENVIRONMENT_READY        ',
    'DSV$SSR_SEGMENT_P                ',
    'DSV$SSR_SHAPE_MTR                ',
    'ENTRY_INDEX                      ',
    'FMP$ADD_TO_FILE_DESCRIPTION      ',
    'FMP$CHANGE_FILE_ATTRIBUTES       ',
    'FMP$CLOSE_CHAPTER                ',
    'FMP$CLOSE_TAPE_FILE              ',
    'FMP$END_OPEN_PROCESSING          ',
    'FMP$FETCH_SYSTEM_LABEL           ',
    'FMP$FETCH_SYSTEM_LABEL_SIZE      ',
    'FMP$FILE_COMMAND                 ',
    'FMP$FILE_IS_LOCAL                ',
    'FMP$GET_DEVICE_CLASS             ',
    'FMP$GET_JL_POINTER               ',
    'FMP$GET_LNT_INFO                 ',
    'FMP$IMPLICIT_RETURN_FILE         ',
    'FMP$LN_ATTACH                    ',
    'FMP$LN_CREATE                    ',
    'FMP$LN_GET_JFID_SFID             ',
    'FMP$LN_JOB_EXIT                  ',
    'FMP$LN_OPEN_CHAPTER              ',
    'FMP$LN_RENAME                    ',
    'FMP$LN_RETURN                    ',
    'FMP$LOGICALLY_POSITION_TAPE      ',
    'FMP$OPEN_CHAPTER                 ',
    'FMP$OPEN_LOCAL_NAME_TABLE        ',
    'FMP$PUT_JL_POINTER               ',
    'FMP$RELEASE_RESOURCE             ',
    'FMP$REQUEST_MASS_STORAGE         ',
    'FMP$REQUEST_NULL_DEVICE          ',
    'FMP$REQUEST_TAPE                 ',
    'FMP$REQUEST_TERMINAL             ',
    'FMP$RESERVE_RESOURCE             ',
    'FMP$REWIND_TAPE                  ',
    'FMP$SKIP_TAPE_MARKS              ',
    'FMP$STORE_BAM_EOI                ',
    'FMP$STORE_SYSTEM_LABEL           ',
    'FMP$TAPE_PAGE_FAULT_MONITOR      ',
    'FMP$VALIDATE_PF_ACCESS           ',
    'FMP$WRITE_TAPE_MARK              ',
    'FMV$ENTRY_ASSIGNED_SELECTOR      ',
    'FMV$ENTRY_FREE_SELECTOR          ',
    'FMV$FILE_DESCRIPTION_TABLE       ',
    'FMV$FILE_DESCRIPTION_TABLE_LOCK  ',
    'FMV$JFT_ENTRY_ASSIGNMENT         ',
    'FMV$JOB_FILE_TABLE               ',
    'FMV$JOB_FILE_TABLE_LOCK          ',
    'FMV$LOCAL_NAME_TABLE             ',
    'FMV$LOCAL_NAME_TABLE_LOCK        ',
    'FMV$LOCAL_NAME_TREES             ',
    'FMV$NULL_JFID                    ',
    'FSP$CLOSE_FILE                   ',
    'FSP$OPEN_FILE                    ',
    'GENERATE_SWAP_REQ                ',
    'GET_AJL_STATISTICS               ',
    'GET_SWAPPED_JOB_COUNT            ',
    'HPP$INITIALIZE                   ',
    'ICP$FAP_CONTROL                  ',
    'IFP$ADVANCE                      ',
    'IFP$BEGIN_HANDLER                ',
    'IFP$DEFAULT_INTERACTIVE_HANDLER  ',
    'IFP$DISCARD_SUSPENDED_OUTPUT     ',
    'IFP$END_HANDLER                  ',
    'IFP$FAP_CONTROL                  ',
    'IFP$FAP_CONTROL_RING_3           ',
    'IFP$FETCH_CONTEXT                ',
    'IFP$FETCH_TERMINAL               ',
    'IFP$FETCH_TERM_CONN_ATTRIBUTES   ',
    'IFP$GET_DEFLT_TERM_ATTRIBUTES    ',
    'IFP$GET_GTID                     ',
    'IFP$GET_TERMINAL_ATTRIBUTES      ',
    'IFP$JOB_INITIALIZE               ',
    'IFP$MARK_ATTRIBUTES_CHANGE       ',
    'IFP$REJECT_CONNECTION            ',
    'IFP$SEND_ATTRIBUTE_KLUDGE        ',
    'IFP$START_PAUSE_UTILITY          ',
    'IFP$STOP_INTERACTIVE             ',
    'IFP$STORE_CONTEXT                ',
    'IFP$STORE_TERMINAL               ',
    'IFP$STORE_TERM_CONN_ATTRIBUTES   ',
    'IFP$TERMINAL                     ',
    'IFP$TERMINAL_COMMAND             ',
    'IIP$ADD_SENDER                   ',
    'IIP$ALLOCATE_QUEUE_ENTRY         ',
    'IIP$BEGIN_HANDLER                ',
    'IIP$CHECK_FOR_CONDITION          ',
    'IIP$CLEAR_JOB_LOCKS              ',
    'IIP$CLEAR_LOCK                   ',
    'IIP$CLOSE                        ',
    'IIP$CONFIRM_SEND                 ',
    'IIP$DISCARD_SUSPENDED_OUTPUT     ',
    'IIP$DISCARD_TYPED_AHEAD_INPUT    ',
    'IIP$END_HANDLER                  ',
    'IIP$FETCH_ACCESS_INFORMATION     ',
    'IIP$FETCH_TERMINAL               ',
    'IIP$FLUSH                        ',
    'IIP$FREE_QUEUE_ENTRY             ',
    'IIP$GET                          ',
    'IIP$GET_DEFLT_TERM_ATTRIBUTES    ',
    'IIP$GET_TERMINAL_ATTRIBUTES      ',
    'IIP$OPEN                         ',
    'IIP$PAUSE_UTILITY                ',
    'IIP$PUT                          ',
    'IIP$RECEIVE_FROM_PASS_ON         ',
    'IIP$REGISTER_HANDLER             ',
    'IIP$REPORT_STATUS_ERROR          ',
    'IIP$ROUTE                        ',
    'IIP$SEND_TO_PASS_ON              ',
    'IIP$SET_LOCK                     ',
    'IIP$SIGN_OFF                     ',
    'IIP$SIGN_ON                      ',
    'IIP$STORE_TERMINAL               ',
    'IIP$TERMINAL                     ',
    'IIP$TERMINAL_COMMAND             ',
    'IIP$UPDATE_OPEN_DESC_ATTRIBUTES  ',
    'IIV$BREAK_REASON                 ',
    'IIV$BREAK_STACK                  ',
    'IIV$INTERACTIVE_WAIT_TIME        ',
    'IIV$JOB_BREAK_LEVEL              ',
    'IIV$JOB_CONNECTION               ',
    'IIV$JOB_MONITOR_TASK_ID          ',
    'IIV$SEND_OUTPUT_LOCK             ',
    'IIV$TASK_BREAK_LEVEL             ',
    'INCR_SWAP_JOB_COUNT              ',
    'INITIALIZE_SWAP_ENTRY            ',
    'INITIATE_JOB_FROM_SCHEDULER      ',
    'IOP$ALLOCATE_IMAGE_REQUESTS      ',
    'IOP$BACKSPACE_TAPE               ',
    'IOP$DATA_SECURITY_ERASE_TAPE     ',
    'IOP$ERASE_TAPE                   ',
    'IOP$FORMAT_TAPE_UNIT             ',
    'IOP$FORSPACE_TAPE                ',
    'IOP$INITIALIZE_TAPE_UNIT         ',
    'IOP$MASS_STORAGE_IO              ',
    'IOP$QUEUE_IMAGE_REQUEST          ',
    'IOP$READ_TAPE                    ',
    'IOP$REWIND_TAPE                  ',
    'IOP$SKIP_TAPEMARK_BACKWARD       ',
    'IOP$SKIP_TAPEMARK_FORWARD        ',
    'IOP$TAPE_BUILD_PP_REQ_HEADER     ',
    'IOP$TAPE_INITIALIZATION          ',
    'IOP$TAPE_INITIALIZE_UNIT         ',
    'IOP$TAPE_INTERNAL_REQUEST_STAT   ',
    'IOP$TAPE_QUEUE_REQUEST           ',
    'IOP$TAPE_QUEUE_REQUEST_SETUP     ',
    'IOP$TAPE_REQUEST_STATUS          ',
    'IOP$TAPE_RETURN_WIRED_REQUEST    ',
    'IOP$UNLOAD_TAPE                  ',
    'IOP$WRITE_TAPE                   ',
    'IOP$WRITE_TAPEMARK               ',
    'IOV$67X_COMMAND_TABLE            ',
    'IOV$DISK_TYPE_TABLE              ',
    'IOV$TAPE_COMPLETION_Q_TABLE      ',
    'IOV$TAPE_UD_P_TABLE              ',
    'IOV$TAPE_UD_TABLES               ',
    'JMP$ACQUIRE_ALL                  ',
    'JMP$ACQUIRE_COMPLETE             ',
    'JMP$ACQUIRE_TERMINAL_FAMILIES    ',
    'JMP$ADJUST_JOB_PRIORITY          ',
    'JMP$ADJUST_PRIORITY_OF_NEW_JOB   ',
    'JMP$AGE_SWAPPED_JOBS             ',
    'JMP$ALTER_JOB_PRIORITY           ',
    'JMP$ALTER_QFILE                  ',
    'JMP$ASSIGN_JSN                   ',
    'JMP$AUTO_INIT_SET                ',
    'JMP$CHANGE_CLASS_ATTR            ',
    'JMP$CHANGE_JOB_PRIORITY          ',
    'JMP$CHANGE_SCH_TBL               ',
    'JMP$CHANGE_SWAP_JOB              ',
    'JMP$CLEAR_OPERATOR_ACTION        ',
    'JMP$COMPARE_QUEUES_VIA_PRIORITY  ',
    'JMP$CONVERT_JOB_TEMPLATE_FILE    ',
    'JMP$DISPLAY_ALL_INPUT_COMMAND    ',
    'JMP$DISPLAY_ALL_OUTPUT_COMMAND   ',
    'JMP$DIVERT_FAMILY                ',
    'JMP$DIVERT_OWNED                 ',
    'JMP$DIVERT_QFILE                 ',
    'JMP$DROP_QFILE                   ',
    'JMP$DSTAPE_FORMAT                ',
    'JMP$EXECUTE_JOB_TEMPL_TASK       ',
    'JMP$EXIT_JOB                     ',
    'JMP$GET_CLASS_ATTR               ',
    'JMP$GET_JOB_INTERNAL_INFO        ',
    'JMP$GET_JOB_PARAMETERS           ',
    'JMP$GET_KEYBOARD_INPUT           ',
    'JMP$GET_MAX_SWAPPED_JOBS         ',
    'JMP$GET_NEXT_ENTRY               ',
    'JMP$GET_SCH_ATTR                 ',
    'JMP$GET_SWAPPED_JOBS_ATTR        ',
    'JMP$INITIALIZE_JOB_ENVIRONMENT   ',
    'JMP$INITIALIZE_JOB_LOCAL_TABLES  ',
    'JMP$INITIALIZE_JOB_SEQ_NUMBER    ',
    'JMP$INITIALIZE_JSN               ',
    'JMP$INITIALIZE_SCHED_RING_2      ',
    'JMP$INITIAL_JOB_BEGIN            ',
    'JMP$INSTALL_SYS_JOB_TEMPLATE     ',
    'JMP$INTERNAL_ROUTE               ',
    'JMP$JOB_BEGIN                    ',
    'JMP$JOB_END                      ',
    'JMP$JOB_FILE_FAP                 ',
    'JMP$JOB_SCHEDULER_ENTRY_POINT    ',
    'JMP$JOB_SCHED_ASYNC_ENTRY_PT     ',
    'JMP$JSN                          ',
    'JMP$KJL_RETHREAD                 ',
    'JMP$LIST_JOBS_VIA_MODE           ',
    'JMP$LOAD_JOB_TEMPLATE            ',
    'JMP$LOGOUT                       ',
    'JMP$MANAGE_AJL_KJL_LOCKS         ',
    'JMP$MANAGE_SENSE_SWITCHES        ',
    'JMP$MANAGE_SWAP_LIST_LOCK        ',
    'JMP$PRIORITY                     ',
    'JMP$PROCESS_JOB_REQUESTED_SWAP   ',
    'JMP$PROCESS_TERMINAL_WAIT        ',
    'JMP$PURGE_JOB_TEMPLATE_FILE      ',
    'JMP$QCOUNT_ALL                   ',
    'JMP$QCOUNT_FAMILY                ',
    'JMP$QCOUNT_OWNED                 ',
    'JMP$QSTATUS_ALL_FULL             ',
    'JMP$QSTATUS_FAMILY_FULL          ',
    'JMP$QSTATUS_FILE_FULL            ',
    'JMP$QSTATUS_OWNED_FULL           ',
    'JMP$QSTATUS_USER_FULL            ',
    'JMP$REBUILD_INPUT_QUEUE          ',
    'JMP$REBUILD_OUTPUT_QUEUE         ',
    'JMP$RECORD_TERMINAL_WAIT         ',
    'JMP$ROUTE                        ',
    'JMP$SAVE_JP_TS_TP_TEMPL          ',
    'JMP$SAVE_SCHEDULER_TASKID        ',
    'JMP$SAVE_SCHED_ASYNC_TASKID      ',
    'JMP$SAVE_SFID_OF_SWAP_FILE       ',
    'JMP$SAVE_TERMINATOR_TASKID       ',
    'JMP$SCHEDULER_TABLE_INITIALIZE   ',
    'JMP$SCHED_SWAPIN_JOB             ',
    'JMP$SCHED_SWAPOUT_JOB            ',
    'JMP$SCH_CHANGE_CAT               ',
    'JMP$SCH_CHANGE_JST               ',
    'JMP$SCH_CHANGE_SWAP_JOB          ',
    'JMP$SEND_SENSE_SWITCH_SIGNAL     ',
    'JMP$SET_ACCOUNT_PROJECT          ',
    'JMP$SET_JOB_MODE                 ',
    'JMP$SET_JOB_TEMPLATE_P           ',
    'JMP$SET_MAX_ACT_IN_CLASS_ATT     ',
    'JMP$SET_MAX_ACT_JOB_LIMITS       ',
    'JMP$SET_OPERATOR_ACTION          ',
    'JMP$SET_OPERATOR_INFO_POINTER    ',
    'JMP$SET_SCHED_FLAG               ',
    'JMP$SET_SWAPPING_CONTROL         ',
    'JMP$SET_SWAP_CONTROL_VARIABLE    ',
    'JMP$STATUS_OPERATOR_ACTION       ',
    'JMP$SWAPIN_BY_PRIORITY           ',
    'JMP$SWAPIN_JOB                   ',
    'JMP$SWAPOUT_JOB                  ',
    'JMP$SYSTEM_ERROR                 ',
    'JMP$SYSTEM_JOB                   ',
    'JMP$WORKING_SET_LOCALITY_SEARCH  ',
    'JMP$WRITE_ROUTE_LABEL            ',
    'JMV$AJL_P                        ',
    'JMV$AUTOMATIC_JOB_INIT           ',
    'JMV$CLASS_LIST                   ',
    'JMV$DEBUG_STATUS                 ',
    'JMV$EXECUTING_WITHIN_SYSTEM_JOB  ',
    'JMV$JCB                          ',
    'JMV$JMTR_XCB                     ',
    'JMV$JOB_CLASS_COUNTS             ',
    'JMV$JOB_SCHEDULER_TABLE          ',
    'JMV$JOB_SEQUENCE_NUMBER          ',
    'JMV$KEYBOARD_BUFFER              ',
    'JMV$KEYBOARD_BUFFER_LOCK         ',
    'JMV$KJL_P                        ',
    'JMV$MEMORY_QUEUE_UPDATE_BY_SWAP  ',
    'JMV$MX_JOBS                      ',
    'JMV$PERFORM_SYSTEM_DEADSTART     ',
    'JMV$SCHEDULER_FLAG               ',
    'JMV$SDT                          ',
    'JMV$SDTX                         ',
    'JMV$SSN_MASK                     ',
    'JMV$SWAPOUT_LIST_HEADER          ',
    'JMV$SYSTEM_CORE_TEMPLATE         ',
    'JMV$SYSTEM_JOB_TEMPLATE_P        ',
    'JMV$TASK_PRIVATE_TEMPL_P         ',
    'JMV$TEMPL_DESC                   ',
    'JMV$TOTAL_SWAPPED_JOBS           ',
    'JOBROOT                          ',
    'JOB_XCB_LIST                     ',
    'JSP$SWAP_JOB_IN                  ',
    'JSP$SWAP_JOB_OUT                 ',
    'JSV$ASIDS_REASSIGNED_ON_SWAPIN   ',
    'JSV$ASID_REASSIGNED_COUNT        ',
    'JSV$JOB_SWAPPING_CONTROL_BLOCK   ',
    'LGP$ADD_ENTRY_TO_ASCII_LOG       ',
    'LGP$ADD_ENTRY_TO_SYSTEM_LOG      ',
    'LGP$DISPLAY_LOG                  ',
    'LGP$DISPLAY_LOG_COMMAND          ',
    'LGP$DISPLAY_SYSTEM_LOG           ',
    'LGP$DISPLAY_SYSTEM_LOG_COMMAND   ',
    'LGP$GET_ENTRY_FROM_GLOBAL_LOG    ',
    'LGP$GET_ENTRY_FROM_LOCAL_LOG     ',
    'LGP$GET_GLOBAL_DESCRIPTOR        ',
    'LGP$INITIALIZE_GLOBAL_LOG_LCD    ',
    'LGP$INSTALL_GLOBAL_LOGS          ',
    'LGP$INTERCEPT_LOG_IO_REQUEST     ',
    'LGP$RECOVER_GLOBAL_LOGS          ',
    'LGP$SETUP_ACCESS_TO_LOCAL_LOGS   ',
    'LGP$SETUP_RECOVERY_LOGGING       ',
    'LGP$TERMINATE_LOG                ',
    'LGP$TERMINATE_LOG_COMMAND        ',
    'LGP$TERMINATE_LOG_PROCESSOR      ',
    'LGV$EXTERNAL_LOG_NAMES_ARRAY     ',
    'LGV$GLOBAL_LOG_CTL               ',
    'LGV$INTERNAL_LOG_NAMES_ARRAY     ',
    'LGV$LOCAL_LOG_CNTL_P             ',
    'LGV$LOCAL_LOG_CTL                ',
    'LOP$DEFIX_BINDING_SEGMENT_ATTR   ',
    'LOP$FIX_BINDING_SEGMENT_ATTR     ',
    'LOP$STORE_LINKAGE                ',
    'MANAGE_LOGICAL_CONFIGURATION     ',
    'MANAGE_PHYSICAL_CONFIGURATION    ',
    'MANLC                            ',
    'MANPC                            ',
    'MLP$ADD_SENDER                   ',
    'MLP$ADD_SENDER_OS                ',
    'MLP$CONFIRM_SEND                 ',
    'MLP$CONFIRM_SEND_OS              ',
    'MLP$DELETE_SENDER                ',
    'MLP$DELETE_SENDER_OS             ',
    'MLP$FETCH_LINK_PARTNER_INFO      ',
    'MLP$FETCH_LINK_PARTNER_INFO_OS   ',
    'MLP$FETCH_RECEIVE_LIST           ',
    'MLP$FETCH_RECEIVE_LIST_OS        ',
    'MLP$GET_HANDLER_INFO             ',
    'MLP$GET_HANDLER_INFO_OS          ',
    'MLP$HANDLE_SIGNAL                ',
    'MLP$HELP_C170                    ',
    'MLP$INITIALIZE                   ',
    'MLP$INITIALIZE_HELPER            ',
    'MLP$INVOKE_MLI_HELPER            ',
    'MLP$RECEIVE_MESSAGE              ',
    'MLP$RECEIVE_MESSAGE_OS           ',
    'MLP$REGISTER_SIGNAL_HANDLER      ',
    'MLP$REGISTER_SIGNAL_HANDLER_OS   ',
    'MLP$SEND_MESSAGE                 ',
    'MLP$SEND_MESSAGE_OS              ',
    'MLP$SIGN_OFF                     ',
    'MLP$SIGN_OFF_OS                  ',
    'MLP$SIGN_ON                      ',
    'MLP$SIGN_ON_OS                   ',
    'MLP$TASK_TERMINATION_CLEANUP     ',
    'MLV$170_COUNT                    ',
    'MLV$170_TIME                     ',
    'MLV$C170_RQST_BLK                ',
    'MLV$DEBUG                        ',
    'MLV$ENABLED                      ',
    'MLV$RB_READY_TASK                ',
    'MMP$ADD_SDT_SDTX_ENTRY           ',
    'MMP$ADVISE_IN                    ',
    'MMP$ADVISE_OUT                   ',
    'MMP$ADVISE_OUT_IN                ',
    'MMP$ASSIGN_DEVICE_TO_SEGMENT     ',
    'MMP$ASSIGN_STACK_TO_DISK         ',
    'MMP$CLOSE_SEGMENT                ',
    'MMP$CREATE_INHERITED_SDT         ',
    'MMP$CREATE_SCRATCH_SEGMENT       ',
    'MMP$CREATE_SEGMENT               ',
    'MMP$DELETE_SCRATCH_SEGMENT       ',
    'MMP$DELETE_SEGMENT               ',
    'MMP$DESELECT_SIGNAL_ON_PAGE_FLT  ',
    'MMP$FETCH_MAX_WS_SIZE            ',
    'MMP$FETCH_PVAS_OF_IMAGE_PAGES    ',
    'MMP$FETCH_PVA_UNWRITTEN_PAGES    ',
    'MMP$FETCH_SEGMENT_ATTRIBUTES     ',
    'MMP$FREE_PAGES                   ',
    'MMP$GET_DIS_HEADER_LINE          ',
    'MMP$GET_SEGMENT_LENGTH           ',
    'MMP$INT_SEGMENT_FAULT_HANDLER    ',
    'MMP$INVALIDATE_SEGMENT           ',
    'MMP$JOB_DELETE_INHERITED_SDT     ',
    'MMP$LOCK_PAGES                   ',
    'MMP$LOCK_SEGMENT                 ',
    'MMP$OPEN_FILE_SEGMENT            ',
    'MMP$OPEN_SEGMENT                 ',
    'MMP$PROCESS_DM_CALLS_FOR_SM      ',
    'MMP$RETRIEVE_RECOVERY_INFO       ',
    'MMP$SAVE_RECOVERY_INFORMATION    ',
    'MMP$SELECT_SIGNAL_ON_PAGE_FAULT  ',
    'MMP$SET_ACCESS_MODE              ',
    'MMP$SET_ACCESS_SELECTIONS        ',
    'MMP$SET_SEGMENT_LENGTH           ',
    'MMP$STORE_MAX_WS_SIZE            ',
    'MMP$STORE_SEGMENT_ATTRIBUTES     ',
    'MMP$TASK_DELETE_INHERITED_SDT    ',
    'MMP$UNLOCK_PAGES                 ',
    'MMP$UNLOCK_SEGMENT               ',
    'MMP$UPDATE_SDT_SDTX_ENTRY        ',
    'MMP$VALIDATE_SEGMENT_NUMBER      ',
    'MMP$VERIFY_ACCESS                ',
    'MMP$WRITE_ALL_SEGMENTS_TO_DISK   ',
    'MMP$WRITE_MODIFIED_PAGES         ',
    'MMV$AGGRESSIVE_AGING_LEVEL       ',
    'MMV$AGING_ALGORITHM              ',
    'MMV$AGING_STATISTICS             ',
    'MMV$ALLOCATION_SIZE              ',
    'MMV$AST_P                        ',
    'MMV$A_DIVISOR                    ',
    'MMV$A_MULT                       ',
    'MMV$BIG_SEGMENT                  ',
    'MMV$DEFAULT_SDTX_ENTRY           ',
    'MMV$FREE_QUEUE_THRESHOLD         ',
    'MMV$JWS_QUEUE_AGE_INTERVAL       ',
    'MMV$MAX_PAGES_NO_FILE            ',
    'MMV$MAX_WORKING_SET_SIZE         ',
    'MMV$MIN_PAGEABLE_PAGE_FRAMES     ',
    'MMV$MULTI_PAGE_WRITE             ',
    'MMV$NO_MEMORY_BUFFERING          ',
    'MMV$NUMBER_FREE_ASTES            ',
    'MMV$PAGEABLE_PAGE_FRAMES         ',
    'MMV$PERIODIC_CALL_INTERVAL       ',
    'MMV$PFT_P                        ',
    'MMV$PF_STATISTICS                ',
    'MMV$PF_SVA_ARRAY                 ',
    'MMV$PQL_P                        ',
    'MMV$PT_FULL                      ',
    'MMV$PT_LENGTH                    ',
    'MMV$PT_P                         ',
    'MMV$SHARED_QUEUE_AGE_INTERVAL    ',
    'MMV$TABLES_INITIALIZED           ',
    'MMV$TICK_TIME                    ',
    'MMV$TIME_TO_CALL_MEM_MGR         ',
    'MMV$TRANSFER_SIZE                ',
    'MMV$UNUSED_AGE_TABLE             ',
    'MMV$WRITE_AGED_OUT_PAGES         ',
    'MTV$CST1                         ',
    'MTV$CST2                         ',
    'MTV$DEADSTART_PANEL_SETTING      ',
    'MTV$DUE_LOG                      ',
    'MTV$HALT_CPU_RING_NUMBER         ',
    'MTV$HALT_ON_PROC_MALF            ',
    'MTV$MONITOR_EXCHANGE_PACKAGE     ',
    'MTV$MX_AJL_ENTRIES               ',
    'MTV$NOS_JPS                      ',
    'MTV$NOS_SEG_P                    ',
    'MTV$NST_P                        ',
    'MTV$NS_XP_P                      ',
    'MTV$PP_TABLE_P                   ',
    'MTV$REQUEST_TABLE                ',
    'MTV$SCB                          ',
    'MTV$SYS_CORE_INIT_COMPLETE       ',
    'MTV$TIME_TO_CHECK_SCB_STATUS     ',
    'MTV$TOTAL_NOS_CPU_TIME           ',
    'MTV$TRACE_BUFFER                 ',
    'MTV$XP_INITIAL_VALUE             ',
    'OFP$ACTION_MESSAGE_DISPLAY       ',
    'OFP$ALTER_DISPLAY                ',
    'OFP$CLEAR_DISPLAY_MESSAGE        ',
    'OFP$CLEAR_HEADER_MESSAGE         ',
    'OFP$CP_DISPLAY                   ',
    'OFP$DISPLAY_STATUS_MESSAGE       ',
    'OFP$DISPLAY_STATUS_MSG_HELPER    ',
    'OFP$EXECUTE_DISPLAY_TASK         ',
    'OFP$GET_DISPLAY_MESSAGE_HELPER   ',
    'OFP$GET_DISPLAY_STATUS_MESSAGE   ',
    'OFP$GET_FIRST_ACTION_MESSAGE     ',
    'OFP$GET_NEXT_ACTION_MESSAGE      ',
    'OFP$HANDLE_SIGNAL_PROCESSOR      ',
    'OFP$INITIALIZE_OPERATOR_FILES    ',
    'OFP$INTERNAL_K_FAP_CONTROL       ',
    'OFP$JOB_BEGIN                    ',
    'OFP$JOB_END                      ',
    'OFP$JOB_FILE_FAP                 ',
    'OFP$JOB_MONITOR_TASK             ',
    'OFP$K_FAP_CONTROL                ',
    'OFP$LOG_DISPLAY                  ',
    'OFP$RECEIVE_FROM_OPERATOR        ',
    'OFP$RECEIVE_FROM_OPERATOR_HELP   ',
    'OFP$REPLY_ACTION_SIGNAL_HELPER   ',
    'OFP$REPLY_TO_ACTION              ',
    'OFP$REPLY_TO_ACTION_HELPER       ',
    'OFP$REPORT_STATUS_ERROR          ',
    'OFP$SCREEN_MANAGER               ',
    'OFP$SEND_TO_OPERATOR             ',
    'OFP$SEND_TO_OPERATOR_HELPER      ',
    'OFP$SET_DISPLAY_MESSAGE          ',
    'OFP$SYSTEM_DISPLAY_MANAGER       ',
    'OFP$SYSTEM_HEADER_DISPLAY        ',
    'OFP$TASK_END                     ',
    'OFP$TASK_END_HELPER              ',
    'OFV$DISPLAY_MESSAGE_UPDATE       ',
    'OFV$HEADER_MESSAGE_UPDATE        ',
    'OFV$MESSAGE_STRUCTURE_HEAP       ',
    'OSP$APPEND_STATUS_INTEGER        ',
    'OSP$APPEND_STATUS_PARAMETER      ',
    'OSP$AWAIT_ACTIVITY               ',
    'OSP$AWAIT_ACTIVITY_COMPLETION    ',
    'OSP$BEGIN_SYSTEM_ACTIVITY        ',
    'OSP$BEGIN_TEXT_DUMP              ',
    'OSP$BROKEN_JOB_DUMP_TASK         ',
    'OSP$CHECK_SYSTEM_DEBUG           ',
    'OSP$CLEAR_SIGNATURE_LOCK         ',
    'OSP$DUMP_BROKEN_TASK             ',
    'OSP$DUMP_TASK                    ',
    'OSP$END_SYSTEM_ACTIVITY          ',
    'OSP$END_TEXT_DUMP                ',
    'OSP$FETCH_STATISTICAL_DATA       ',
    'OSP$FETCH_SYSTEM_CONSTANT        ',
    'OSP$FORMAT_MESSAGE               ',
    'OSP$GENERATE_ERROR_MESSAGE       ',
    'OSP$GENERATE_LOG_MESSAGE         ',
    'OSP$GENERATE_MESSAGE             ',
    'OSP$GET_MESSAGE_LEVEL            ',
    'OSP$GET_STATUS_CONDITION_STRING  ',
    'OSP$GET_STATUS_MESSAGE_BY_CODE   ',
    'OSP$GET_STATUS_SEVERITY          ',
    'OSP$INITIALIZE_SIGNATURE_LOCK    ',
    'OSP$JOB_TEMPLATE_INIT_PH1        ',
    'OSP$JOB_TEMPLATE_INIT_PH2        ',
    'OSP$JOB_TEMPLATE_INIT_PH3        ',
    'OSP$NOS_TRAP_HANDLER             ',
    'OSP$OUTPUT_DEBUG_TEXT            ',
    'OSP$PROCESS_INIT_ERROR           ',
    'OSP$PROCESS_SYSTEM_DEBUG         ',
    'OSP$RECOVERABLE_SYSTEM_ERROR     ',
    'OSP$RESET_HEAP                   ',
    'OSP$SET_MESSAGE_LEVEL            ',
    'OSP$SET_SIGNATURE_LOCK           ',
    'OSP$SET_STATUS_ABNORMAL          ',
    'OSP$SET_STATUS_FROM_CONDITION    ',
    'OSP$STORE_SYSTEM_CONSTANT        ',
    'OSP$SYSTEM_ERROR                 ',
    'OSP$TERMINATE_SYSTEM             ',
    'OSP$TERMINATE_SYSTEM_JOB         ',
    'OSP$TEST_SIGNATURE_LOCK          ',
    'OSV$180_MEMORY_LIMITS            ',
    'OSV$ADTT_PTR                     ',
    'OSV$BASE_SYSTEM_TIME             ',
    'OSV$BROKEN_JOB_BUFFER            ',
    'OSV$BROKEN_JOB_DUMPER_GTID       ',
    'OSV$BROKEN_JOB_DUMP_LOCK         ',
    'OSV$BROKEN_JOB_GTID              ',
    'OSV$BROKEN_JOB_SEGMENT_ARRAY     ',
    'OSV$CONFIGURATION_PROLOG_NAME    ',
    'OSV$CTI_PARAMETERS               ',
    'OSV$DEADSTART_PHASE              ',
    'OSV$DEFAULT_SIT_VALUE            ',
    'OSV$DEFAULT_SYSTEM_DATE_FORMAT   ',
    'OSV$DEFAULT_SYSTEM_TIME_FORMAT   ',
    'OSV$EQUAL_PRIORITY_SUBPRIORITY   ',
    'OSV$ERROR_IDLE_HALT              ',
    'OSV$IMAGE_FILE_ADTT_PTR          ',
    'OSV$INITIALIZATION_PROLOG_NAME   ',
    'OSV$JOB_FIXED_HEAP               ',
    'OSV$LEFT_BUFFER                  ',
    'OSV$LOWER_TO_UPPER               ',
    'OSV$MAINFRAME_PAGEABLE_HEAP      ',
    'OSV$MAINFRAME_WIRED_HEAP         ',
    'OSV$OPERATING_MODE               ',
    'OSV$OPERATOR_INTERVENTION        ',
    'OSV$PAGE_SIZE                    ',
    'OSV$PP_ADDRESS_ARRAY             ',
    'OSV$PP_CONSOLE_INPUT             ',
    'OSV$RIGHT_BUFFER                 ',
    'OSV$SPAA                         ',
    'OSV$TASK_PRIVATE_HEAP            ',
    'OSV$TASK_SHARED_HEAP             ',
    'OSV$TEMPLATE_ARRAY_160000_P      ',
    'OSV$TEMPLATE_ARRAY_170000_P      ',
    'OSV$TEMPLATE_ARRAY_180000_P      ',
    'OSV$TEMPLATE_ARRAY_190000_P      ',
    'OSV$TEMPLATE_ARRAY_200000_P      ',
    'OSV$TEMPLATE_ARRAY_210000_P      ',
    'OSV$TEMPLATE_ARRAY_220000_P      ',
    'OSV$TEMPLATE_ARRAY_230000_P      ',
    'OSV$TEMPLATE_ARRAY_240000_P      ',
    'OSV$TEMPLATE_ARRAY_250000_P      ',
    'OSV$TEMPLATE_ARRAY_260000_P      ',
    'OSV$TEMPLATE_ARRAY_270000_P      ',
    'OSV$TEMPLATE_ARRAY_280000_P      ',
    'OSV$TEMPLATE_ARRAY_290000_P      ',
    'OSV$TEMPLATE_ARRAY_320000_P      ',
    'OSV$TEMPLATE_ARRAY_340000_P      ',
    'OSV$TEMPLATE_ARRAY_570000_P      ',
    'OSV$TPH_LENGTH                   ',
    'OSV$TSH_LENGTH                   ',
    'OSV$UPPER_TO_LOWER               ',
    'PERFORM_PHYSICAL_SWAPOUT         ',
    'PERFORM_STATE_TRANSITIONS        ',
    'PFP$ATTACH                       ',
    'PFP$CHANGE                       ',
    'PFP$DEFINE                       ',
    'PFP$DEFINE_CATALOG               ',
    'PFP$DEFINE_DATA                  ',
    'PFP$DEFINE_MASTER_CATALOG        ',
    'PFP$DELETE_CATALOG_PERMIT        ',
    'PFP$DELETE_PERMIT                ',
    'PFP$FIND_CATALOG_DESCRIPTION     ',
    'PFP$FIND_CYCLE_ARRAY             ',
    'PFP$FIND_CYCLE_ENTRY             ',
    'PFP$FIND_DIRECTORY_ARRAY         ',
    'PFP$FIND_DIRECT_INFO_RECORD      ',
    'PFP$FIND_FILE_DESCRIPTION        ',
    'PFP$FIND_LOG_ARRAY               ',
    'PFP$FIND_NEXT_INFO_RECORD        ',
    'PFP$FIND_PERMIT_ARRAY            ',
    'PFP$GET_FAMILY_INFO              ',
    'PFP$GET_ITEM_INFO                ',
    'PFP$GET_MASTER_CATALOG_INFO      ',
    'PFP$GET_MULTI_ITEM_INFO          ',
    'PFP$PERMIT                       ',
    'PFP$PERMIT_CATALOG               ',
    'PFP$PROCESS_UNEXPECTED_STATUS    ',
    'PFP$PURGE                        ',
    'PFP$PURGE_CATALOG                ',
    'PFP$PURGE_MASTER_CATALOG         ',
    'PFP$PUT_CYCLE_INFO               ',
    'PFP$PUT_FAMILY_INFO              ',
    'PFP$PUT_ITEM_INFO                ',
    'PFP$PUT_MASTER_CATALOG_INFO      ',
    'PFP$R2_ATTACH                    ',
    'PFP$R2_CHANGE                    ',
    'PFP$R2_DEFINE                    ',
    'PFP$R2_DEFINE_CATALOG            ',
    'PFP$R2_DEFINE_DATA               ',
    'PFP$R2_DEFINE_MASTER_CATALOG     ',
    'PFP$R2_DELETE_CATALOG_PERMIT     ',
    'PFP$R2_DELETE_PERMIT             ',
    'PFP$R2_GET_FAMILY_INFO           ',
    'PFP$R2_GET_ITEM_INFO             ',
    'PFP$R2_GET_MASTER_CATALOG_INFO   ',
    'PFP$R2_GET_MULTI_ITEM_INFO       ',
    'PFP$R2_PERMIT                    ',
    'PFP$R2_PERMIT_CATALOG            ',
    'PFP$R2_PURGE                     ',
    'PFP$R2_PURGE_CATALOG             ',
    'PFP$R2_PURGE_MASTER_CATALOG      ',
    'PFP$R2_PUT_CYCLE_INFO            ',
    'PFP$R2_PUT_FAMILY_INFO           ',
    'PFP$R2_PUT_ITEM_INFO             ',
    'PFP$R2_PUT_MASTER_CATALOG_INFO   ',
    'PFP$R2_RECOVER_SET               ',
    'PFP$R2_REORGANIZE_CATALOG        ',
    'PFP$R2_REORGANIZE_SET_CATALOGS   ',
    'PFP$R2_SPECIAL_ATTACH            ',
    'PFP$R2_VALIDATE_CATALOG          ',
    'PFP$R2_VALIDATE_SET_CATALOGS     ',
    'PFP$R3_ATTACH                    ',
    'PFP$R3_SPECIAL_ATTACH            ',
    'PFP$RECOVER_SET                  ',
    'PFP$REORGANIZE_CATALOG           ',
    'PFP$REORGANIZE_SET_CATALOGS      ',
    'PFP$SPECIAL_ATTACH               ',
    'PFP$VALIDATE_CATALOG             ',
    'PFP$VALIDATE_SET_CATALOGS        ',
    'PMP$ABORT                        ',
    'PMP$ACQUIRE_RAW_TASK_STATISTICS  ',
    'PMP$ACTIVATE_RING_ALARM          ',
    'PMP$AWAIT_TASK                   ',
    'PMP$AWAIT_TASK_TERMINATION       ',
    'PMP$BINARY_TO_ASCII              ',
    'PMP$CAUSE_CONDITION              ',
    'PMP$CHANGE_BINARY_TO_ALPHA_DATE  ',
    'PMP$CHANGE_BINARY_TO_ALPHA_TIME  ',
    'PMP$CHANGE_DEBUG_LIBRARY_LIST    ',
    'PMP$CHANGE_DEFAULT_PROG_OPTIONS  ',
    'PMP$CHANGE_JOB_LIBRARY_LIST      ',
    'PMP$CLEANUP_LOADED_RINGS         ',
    'PMP$CLOSE_COMMON_BLOCK_FILE      ',
    'PMP$COLLECT_RAW_TASK_STATISTICS  ',
    'PMP$COMPUTE_DATE_TIME            ',
    'PMP$CONNECT_QUEUE                ',
    'PMP$CONTINUE_TO_CAUSE            ',
    'PMP$CREATE_CHILD_XCB             ',
    'PMP$CREATE_TASK_ENVIRONMENT      ',
    'PMP$CYCLE                        ',
    'PMP$DEBUG_ABORT_FILE_SPECIFIED   ',
    'PMP$DEBUG_CRITICAL_FRAME         ',
    'PMP$DEFINE_DEBUG_ENTRY           ',
    'PMP$DEFINE_QUEUE                 ',
    'PMP$DEFINE_SIGNAL_HANDLER        ',
    'PMP$DEFINE_SYSTEM_FLAG_HANDLER   ',
    'PMP$DELAY                        ',
    'PMP$DELETE_CURRENT_ENVIRONMENT   ',
    'PMP$DELETE_ENVIRONMENT           ',
    'PMP$DELETE_NON_INHERITED_SEGS    ',
    'PMP$DETERMINE_PIT_SET            ',
    'PMP$DISCONNECT_QUEUE             ',
    'PMP$DISESTABLISH_COND_HANDLER    ',
    'PMP$DISESTABLISH_END_HANDLER    ',
    'PMP$ENABLE_JOB_FREE_FLAG         ',
    'PMP$ENABLE_SYSTEM_CONDITIONS     ',
    'PMP$ESTABLISH_CH_IN_BLOCK        ',
    'PMP$ESTABLISH_CONDITION_HANDLER  ',
    'PMP$ESTABLISH_DEBUG_CFF          ',
    'PMP$ESTABLISH_END_HANDLER        ',
    'PMP$EXECUTE                      ',
    'PMP$EXECUTE_TASK                 ',
    'PMP$EXECUTE_WITH_APD             ',
    'PMP$EXECUTE_WITH_LESS_PRIVILEGE  ',
    'PMP$EXIT                         ',
    'PMP$FIND_BEGIN_DEBUG             ',
    'PMP$FIND_DEBUG                   ',
    'PMP$FIND_END_DEBUG               ',
    'PMP$FIND_ENTRY_POINT_ADDRESS     ',
    'PMP$FIND_ENTRY_POINT_IN_LIBRARY  ',
    'PMP$FIND_EXECUTING_TASK_TCB      ',
    'PMP$FIND_EXECUTING_TASK_XCB      ',
    'PMP$FIND_STACK_SEGMENT           ',
    'PMP$FIND_TASK_TCB                ',
    'PMP$FIND_TASK_XCB                ',
    'PMP$FIX_INITIAL_DEBUG            ',
    'PMP$FORMAT_COMPACT_DATE          ',
    'PMP$FORMAT_COMPACT_TIME          ',
    'PMP$GENERATE_UNIQUE_NAME         ',
    'PMP$GET_ACCOUNT_PROJECT          ',
    'PMP$GET_BINARY_DATE_AND_TIME     ',
    'PMP$GET_COMMON_BLOCK_INFO        ',
    'PMP$GET_COMPACT_DATE_TIME        ',
    'PMP$GET_CURRENT_ENVIRONMENT      ',
    'PMP$GET_DATE                     ',
    'PMP$GET_DEBUG_ABORT_FILE         ',
    'PMP$GET_DEBUG_ENTRY              ',
    'PMP$GET_DEBUG_ENVIRONMENT        ',
    'PMP$GET_DEBUG_ID                 ',
    'PMP$GET_DEBUG_INPUT_FILE         ',
    'PMP$GET_DEBUG_LIBRARY_LIST       ',
    'PMP$GET_DEBUG_OUTPUT_FILE        ',
    'PMP$GET_DEFAULT_PROGRAM_OPTIONS  ',
    'PMP$GET_DELAYED_CONDITION        ',
    'PMP$GET_ENTRY_POINT_DICTIONARY   ',
    'PMP$GET_EXECUTING_TASK_GTID      ',
    'PMP$GET_JOB_LIBRARY_LIST         ',
    'PMP$GET_JOB_MODE                 ',
    'PMP$GET_JOB_NAMES                ',
    'PMP$GET_LAST_PATH_NAME           ',
    'PMP$GET_LEGIBLE_DATE_TIME        ',
    'PMP$GET_MICROSECOND_CLOCK        ',
    'PMP$GET_NUMBER_OF_DEBUG_LIBS     ',
    'PMP$GET_NUMBER_OF_JOB_LIBRARIES  ',
    'PMP$GET_OS_VERSION               ',
    'PMP$GET_PROCESSOR_ATTRIBUTES     ',
    'PMP$GET_PROGRAM_DESCRIPTION      ',
    'PMP$GET_PROGRAM_SIZE             ',
    'PMP$GET_QUEUE_LIMITS             ',
    'PMP$GET_SRUS                     ',
    'PMP$GET_SYSTEM_TIME              ',
    'PMP$GET_TASK_CP_TIME             ',
    'PMP$GET_TASK_ID                  ',
    'PMP$GET_TASK_JOBMODE_STATISTICS  ',
    'PMP$GET_TERMINATION_STATUS       ',
    'PMP$GET_TIME                     ',
    'PMP$GET_USER_IDENTIFICATION      ',
    'PMP$INHIBIT_SYSTEM_CONDITIONS    ',
    'PMP$INITIALIZE_JOB_XCB_LIST      ',
    'PMP$INITIALIZE_TASKING_TABLES    ',
    'PMP$INITIAL_DEBUG_MODE_ON        ',
    'PMP$INITIATE_CHILD_TASK          ',
    'PMP$JOB_DEBUG_RING               ',
    'PMP$LOAD                         ',
    'PMP$LOAD_DEBUG_PROCEDURES        ',
    'PMP$LOAD_ENTRY_POINT             ',
    'PMP$LOAD_MODULE_FROM_LIBRARY     ',
    'PMP$LOG                          ',
    'PMP$LOG_ASCII                    ',
    'PMP$LONG_TERM_WAIT               ',
    'PMP$MANAGE_SENSE_SWITCHES        ',
    'PMP$MODIFY_DEBUG_ENTRY           ',
    'PMP$OPEN_COMMON_BLOCK_FILE      ',
    'PMP$POP_TASK_DEBUG_MODE          ',
    'PMP$POSITION_OBJECT_LIBRARY      ',
    'PMP$POST_CURRENT_ENVIRONMENT     ',
    'PMP$POST_DEBUG_ENVIRONMENT       ',
    'PMP$POST_DELAYED_CONDITION       ',
    'PMP$PUSH_TASK_DEBUG_MODE         ',
    'PMP$READY_TASK                   ',
    'PMP$RECEIVE_FROM_QUEUE           ',
    'PMP$RECEIVE_QUEUE_MESSAGE        ',
    'PMP$RECORD_PROGRAM_TERMINATION   ',
    'PMP$RECORD_TASK_NAME             ',
    'PMP$RELEASE_CHILD_XCB            ',
    'PMP$RELEASE_TASK_ENVIRONMENT     ',
    'PMP$REMOVE_DEBUG_ENTRY           ',
    'PMP$REMOVE_QUEUE                 ',
    'PMP$RESET_DEBUG_SCAN             ',
    'PMP$REVOKE_PROGRAM_TERMINATION   ',
    'PMP$SEND_SIGNAL                  ',
    'PMP$SEND_TO_QUEUE                ',
    'PMP$SET_DEBUG_ENDING             ',
    'PMP$SET_JOB_DEBUG_RING           ',
    'PMP$SET_PROCESS_INTERVAL_TIMER   ',
    'PMP$SET_SPY_IDENTIFIER           ',
    'PMP$SET_SYSTEM_FLAG              ',
    'PMP$SET_TASK_DEBUG_MODE          ',
    'PMP$SET_TASK_DEBUG_RING          ',
    'PMP$STATUS_QUEUE                 ',
    'PMP$STATUS_QUEUES_DEFINED        ',
    'PMP$TASK_DEBUG_MODE_ON           ',
    'PMP$TASK_DEBUG_RING              ',
    'PMP$TASK_END                     ',
    'PMP$TASK_STATE                   ',
    'PMP$TERMINATE                    ',
    'PMP$TEST_CONDITION_HANDLER       ',
    'PMP$THIS_IS_A_LEAP_YEAR          ',
    'PMP$UPDATE_TOS_RING_1            ',
    'PMP$UPDATE_TOS_RING_3            ',
    'PMP$VALIDATE_PREVIOUS_SAVE_AREA  ',
    'PMP$VERIFY_COMPACT_DATE          ',
    'PMP$VERIFY_COMPACT_TIME          ',
    'PMP$WAIT                         ',
    'PMP$ZERO_OUT_TABLE               ',
    'PMV$JOB_INITIALIZATION_COMPLETE  ',
    'PMV$OS_NAME                      ',
    'PMV$QUANTUM                      ',
    'PMV$TASK_TEMPLATE                ',
    'PPCOMM                           ',
    'PPDISVEC                         ',
    'P_FDE                            ',
    'P_OLD_FDE                        ',
    'QFP$ACQUIRE                      ',
    'QFP$ACQUIRE_ALL                  ',
    'QFP$ACQUIRE_COMPLETE             ',
    'QFP$ALTER_QFILE                  ',
    'QFP$ALTER_QJOB                   ',
    'QFP$COUNT_ALL_FILES              ',
    'QFP$COUNT_ALL_JOBS               ',
    'QFP$COUNT_FAMILY_FILES           ',
    'QFP$COUNT_FAMILY_JOBS            ',
    'QFP$COUNT_OWNED_FILES            ',
    'QFP$COUNT_OWNED_JOBS             ',
    'QFP$DIVERT_FAMILY_JOBS           ',
    'QFP$DIVERT_FAMILY_OUTPUTS        ',
    'QFP$DIVERT_OWNED_JOBS            ',
    'QFP$DIVERT_OWNED_OUTPUTS         ',
    'QFP$DIVERT_QFILE                 ',
    'QFP$DIVERT_QJOB                  ',
    'QFP$DROP_QFILE                   ',
    'QFP$DROP_QJOB                    ',
    'QFP$FILENAME_TO_SSN              ',
    'QFP$GET_JOB_INTERNAL_INFO        ',
    'QFP$INPUT_ROUTE                  ',
    'QFP$INTERNAL_INPUT_ROUTE         ',
    'QFP$JOBNAME_TO_SSN               ',
    'QFP$KJL_MASTER_SEARCH            ',
    'QFP$KJL_RETHREAD                 ',
    'QFP$LIST_JOBS_VIA_MODE           ',
    'QFP$OUTPUT_ROUTE                 ',
    'QFP$READ_MY_ROUTE_DESCRIPTOR     ',
    'QFP$REBUILD_INPUT_QUEUE          ',
    'QFP$REBUILD_OUTPUT_QUEUE         ',
    'QFP$SET_AJL_STATUS               ',
    'QFP$STATUS_ALL_JOBS              ',
    'QFP$STATUS_ALL_OUTPUTS           ',
    'QFP$STATUS_FAMILY_JOBS           ',
    'QFP$STATUS_FAMILY_OUTPUTS        ',
    'QFP$STATUS_FILES                 ',
    'QFP$STATUS_JOBS                  ',
    'QFP$STATUS_OWNED_JOBS            ',
    'QFP$STATUS_OWNED_OUTPUTS         ',
    'QFP$UNLINK_AJL_KJL               ',
    'RESTORE_JOB_ENVIRONMENT          ',
    'RHP$LINK_USER_DESCRIPTOR_SAVED   ',
    'RHP$MLI_GET_PERMANENT_FILE       ',
    'RHP$MLI_REPLACE_PERMANENT_FILE   ',
    'RHP$OVERRIDE_FILE_ATTRIBUTES     ',
    'RHP$SAVE_LINK_USER_DESCRIPTION   ',
    'RHV$LINK_USER_CURRENT_FAMILY     ',
    'RHV$LINK_USER_DESCRIPTOR_P       ',
    'RHV$SIGNAL                       ',
    'RMP$GET_DEVICE_CLASS             ',
    'RMP$REQUEST_MASS_STORAGE         ',
    'RMP$REQUEST_NULL_DEVICE          ',
    'RMP$REQUEST_TAPE                 ',
    'RMP$REQUEST_TERMINAL             ',
    'SCAN_AJL_FOR_SWAP_CONDITIONS     ',
    'SCITOII                          ',
    'SET_AJL_SWAP_STATUS              ',
    'SFP$CHANGE_ROUTING_CONTROL       ',
    'SFP$CREATE_ROUTING_CONTROL       ',
    'SFP$DELETE_ROUTING_CONTROL       ',
    'SFP$DISABLE_GLOBAL_STATISTIC     ',
    'SFP$DISABLE_LOCAL_STATISTIC      ',
    'SFP$DISABLE_STATISTIC            ',
    'SFP$DISABLE_SYSTEM_STATISTIC     ',
    'SFP$DISESTABLISH_GLOBAL_STAT     ',
    'SFP$DISESTABLISH_LOCAL_STAT      ',
    'SFP$DISESTABLISH_STATISTIC       ',
    'SFP$DISESTABLISH_SYSTEM_STAT     ',
    'SFP$EMIT_GLOBAL_STATISTIC        ',
    'SFP$EMIT_LOCAL_STATISTIC         ',
    'SFP$EMIT_STATISTIC               ',
    'SFP$EMIT_SYSTEM_STATISTIC        ',
    'SFP$ENABLE_GLOBAL_STATISTIC      ',
    'SFP$ENABLE_LOCAL_STATISTIC       ',
    'SFP$ENABLE_ROUTING_CONTROLS      ',
    'SFP$ENABLE_STATISTIC             ',
    'SFP$ENABLE_SYSTEM_STATISTIC      ',
    'SFP$ESTABLISH_GLOBAL_STATISTIC   ',
    'SFP$ESTABLISH_LOCAL_STATISTIC    ',
    'SFP$ESTABLISH_STATISTIC          ',
    'SFP$ESTABLISH_SYSTEM_STATISTIC   ',
    'SFP$GET_ROUTING_CONTROLS         ',
    'SFP$INITIALIZE_GLOBAL_STATS      ',
    'SFP$INITIALIZE_ROUTING_CONTROL   ',
    'SFP$SAVE_LRCT_POINTER            ',
    'SFP$SETUP_ACCESS_TO_LOCAL_STATS  ',
    'SFV$LOCAL_ROUTING_CONTROL_TABLE  ',
    'SRP$CONVERSION_SERVICE_MANAGER   ',
    'SRP$FETCH_SYSTEM_LABEL           ',
    'SRP$FETCH_SYSTEM_LABEL_SIZE      ',
    'SRP$RECORD_CONVERSION_MANAGER    ',
    'SRP$STORE_SYSTEM_LABEL           ',
    'SSR_SHAPE                        ',
    'STP$ADD_MEMBER_IN_AST            ',
    'STP$ADD_MEMBER_IN_MASTER_VST     ',
    'STP$ADD_MEMBER_VOL_TO_SET        ',
    'STP$ATTACH_VST                   ',
    'STP$BUILD_MEMBER_LIST_LOCATOR    ',
    'STP$BUILD_MEMBER_LIST_POINTER    ',
    'STP$BUILD_MEMBER_VST             ',
    'STP$BUILD_PF_ROOT_LOCATOR        ',
    'STP$BUILD_PF_ROOT_POINTER        ',
    'STP$CHANGE_ACCESS_TO_SET         ',
    'STP$CHANGE_AST_ACCESS_STATUS     ',
    'STP$CLEAR_AST_PF_LOCK            ',
    'STP$CLEAR_EXCLUSIVE_ACCESS       ',
    'STP$CLEAR_PF_LOCK                ',
    'STP$CLEAR_READ_ACCESS            ',
    'STP$CREATE_AST_ENTRY             ',
    'STP$CREATE_SET                   ',
    'STP$CREATE_VST                   ',
    'STP$DEALLOCATE_AST_ENTRY         ',
    'STP$DECREMENT_JOB_USE_IN_AST     ',
    'STP$DESTROY_VST                  ',
    'STP$DETACH_VST                   ',
    'STP$DISK_VOLUME_ACTIVE           ',
    'STP$DISK_VOLUME_INACTIVE         ',
    'STP$DM_CHECK_IF_FILES_ON_VOL     ',
    'STP$DM_MOUNT_VOLUME              ',
    'STP$DM_STORE_SET_ORDINAL         ',
    'STP$FILL_MASTER_VST              ',
    'STP$GET_ACTIVE_SET_LIST          ',
    'STP$GET_JOBS_SCRATCH_VOLUMES     ',
    'STP$GET_PF_ACTIVE_SET_ENTRY      ',
    'STP$GET_PF_ROOT                  ',
    'STP$GET_PF_ROOT_SIZE             ',
    'STP$GET_SET_OWNER                ',
    'STP$GET_UNUSED_ENTRY_IN_AST      ',
    'STP$GET_UNUSED_MEL_ENTRY         ',
    'STP$GET_VOLUMES_BY_AST_INDEX     ',
    'STP$GET_VOLUMES_BY_SET_ORDINAL   ',
    'STP$GET_VOLUMES_IN_SET           ',
    'STP$GET_VOLUMES_SET_NAME         ',
    'STP$INACTIVATE_MASTER            ',
    'STP$INACTIVATE_MEMBER            ',
    'STP$INCREMENT_JOB_COUNT_IN_AST   ',
    'STP$INITIALIZE_SETS              ',
    'STP$INSERT_MEMBER_INTO_MEL       ',
    'STP$IS_VOLUME_IN_SET             ',
    'STP$MEMBERS_ACTIVE_ON_SET        ',
    'STP$MEMBERS_INACTIVE_ON_SET      ',
    'STP$MEMBERS_ON_SET               ',
    'STP$OBTAIN_AST_ENTRY             ',
    'STP$OBTAIN_AST_MEMBER_LIST       ',
    'STP$OBTAIN_AST_PF_ROOT           ',
    'STP$OBTAIN_AST_SIZE              ',
    'STP$OBTAIN_MASTER_VST_INFO       ',
    'STP$OBTAIN_MEMBER_VST_INFO       ',
    'STP$OBTAIN_VST_HEADER            ',
    'STP$OBTAIN_VST_PF_ROOT           ',
    'STP$OPEN_ATTACHED_VST            ',
    'STP$OPEN_VST                     ',
    'STP$PURGE_AST_PF_ROOT            ',
    'STP$PURGE_PF_ROOT                ',
    'STP$PURGE_SET                    ',
    'STP$PURGE_VST_PF_ROOT            ',
    'STP$REMOVE_MEMBER_FROM_MASTER    ',
    'STP$REMOVE_MEMBER_FROM_MEL       ',
    'STP$REMOVE_MEMBER_VOL_FROM_SET   ',
    'STP$REMOVE_SET_FROM_AST          ',
    'STP$REMOVE_SET_FROM_VST          ',
    'STP$REQUEST_DM_VOLUME_INFO       ',
    'STP$RETURN_OPENED_VST            ',
    'STP$RING2_ADD_MEMBER             ',
    'STP$RING2_CREATE_SET             ',
    'STP$RING2_PURGE_SET              ',
    'STP$RING2_REMOVE_MEMBER          ',
    'STP$SEARCH_AST_BY_SET            ',
    'STP$SEARCH_AST_BY_UNIQUE_SET     ',
    'STP$SEARCH_AST_BY_VOLUME         ',
    'STP$SEARCH_JAST_FOR_SET          ',
    'STP$SEARCH_MEL_FOR_VOL           ',
    'STP$SEARCH_MEMBER_LIST           ',
    'STP$SEARCH_MVL_FOR_UNUSED_ENTRY  ',
    'STP$SET_AST_PF_LOCK              ',
    'STP$SET_END_JOB                  ',
    'STP$SET_EXCLUSIVE_ACCESS         ',
    'STP$SET_PF_LOCK                  ',
    'STP$SET_READ_ACCESS              ',
    'STP$STORE_AST_MASTER_HEADER      ',
    'STP$STORE_AST_PF_ROOT            ',
    'STP$STORE_DM_PACKET_IN_MASTER    ',
    'STP$STORE_DM_PACKET_IN_MEL       ',
    'STP$STORE_DM_PACKET_IN_MVL       ',
    'STP$STORE_INACTIVE_MASTER        ',
    'STP$STORE_MASTER_DM_PACKET       ',
    'STP$STORE_MEMBER_DM_PACKET       ',
    'STP$STORE_PF_ROOT                ',
    'STP$STORE_VST_BEING_MODIFIED     ',
    'STP$STORE_VST_PF_ROOT            ',
    'SYP$ADVISED_MOVE_BYTES           ',
    'SYP$CHECK_FOR_KEYPOINT_CLASS     ',
    'SYP$CLEANUP_KEYPOINT_PROCESSING  ',
    'SYP$COLLECT_SOFTWARE_KEYPOINTS   ',
    'SYP$CONVERSION_SERVICES          ',
    'SYP$ENABLE_JOB_FREE_FLAG         ',
    'SYP$END_KEYPOINT_COLLECTING      ',
    'SYP$FETCH_SYSTEM_CONSTANT        ',
    'SYP$INITIALIZE_JT_PTR_ARRAY      ',
    'SYP$INITIALIZE_KEYPOINT          ',
    'SYP$INITIATE_PMF_ACTIVITY        ',
    'SYP$INVOKE_SYSTEM_DEBUGGER       ',
    'SYP$PUT_ASCII                    ',
    'SYP$RETURN_JOBS_R1_RESOURCES     ',
    'SYP$SET_PROCESS_INTERVAL_TIMER   ',
    'SYP$STORE_SYSTEM_CONSTANT        ',
    'SYP$TERMINATE_SYSTEM_CORE        ',
    'SYP$TURN_KEYPOINT_ON             ',
    'SYP$UPDATE_DEADSTART_STATUS      ',
    'SYV$ACTIVE_KEYPOINT_COUNT        ',
    'SYV$ASCII_CONSOLE_BUFFER         ',
    'SYV$DEBUG_CONTROL                ',
    'SYV$DEBUG_DISPLAY_ID             ',
    'SYV$DEFAULT_KEYPOINT_MASK        ',
    'SYV$HARDWARE_KEYPOINT_COUNT      ',
    'SYV$INHIBIT_KEYBOARD_INPUT       ',
    'SYV$JOB_KCB_P_OFFSET             ',
    'SYV$NOS_SYSTEM_TIME              ',
    'SYV$PMF_CB_RM_WORD_ADDRESS       ',
    'SYV$SYSTEM_KCB_P                 ',
    'SYV$USEIP_DEFINED_FROM_FILE      ',
    'TMP$ALLOCATE_EXECUTION_RINGS     ',
    'TMP$CLEAR_SYSTEM_FLAG            ',
    'TMP$CLEAR_WAIT_INHIBITED         ',
    'TMP$DISABLE_SIGNALS_FLAGS        ',
    'TMP$DISPOSE_OF_RING2_FLAGS       ',
    'TMP$DISPOSE_OF_RING2_SIGNALS     ',
    'TMP$DISPOSE_PREEMPTIVE_COMMO     ',
    'TMP$ENABLE_PREEMPTIVE            ',
    'TMP$ENABLE_PREEMPTIVE_COMMO      ',
    'TMP$FETCH_JOB_STATISTICS         ',
    'TMP$FIND_FLAG_TO_PROCESS         ',
    'TMP$FIND_MAINFRAME_SIGNAL        ',
    'TMP$FIND_MONITOR_FAULT           ',
    'TMP$FIND_SIGNAL                  ',
    'TMP$GET_MONITOR_FAULT            ',
    'TMP$GET_SIGNAL                   ',
    'TMP$POST_MAINFRAME_SIGNAL        ',
    'TMP$POST_MONITOR_FAULT_SFSA      ',
    'TMP$READY_SYSTEM_TASK            ',
    'TMP$SAVE_SYSTEM_TASK_ID          ',
    'TMP$SET_FLAG_INTERVAL            ',
    'TMP$WAIT                         ',
    'TMV$DCT                          ',
    'TMV$HALT_ON_HUNG_TASK            ',
    'TMV$PTL_P                        ',
    'TMV$SCHEDULER_GLOBAL_TASK_ID     ',
    'TMV$SYSTEM_DEBUG_RING            ',
    'TMV$SYSTEM_ERROR_HANG_COUNT      ',
    'UUTL                             '];
?? POP ??


?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
?? NEWTITLE := '  INITIALIZE_LOADER_ENVIRONMENT', EJECT ??

  PROCEDURE initialize_loader_environment;


    VAR
      mainframe_id: pmt$binary_mainframe_id,
      task_private_heap: ^HEAP (REP 10000 of cell),
      from_pointer: ^^cell,
      to_pointer: ^^cell,
      ignore_status: ost$status,
      i: integer;


    { initialize osv$task_private_heap to a manageable size }

    ALLOCATE task_private_heap;

    from_pointer := #LOC (task_private_heap);
    to_pointer := #LOC (osv$task_private_heap);
    to_pointer^ := from_pointer^;

    RESET osv$task_private_heap^;


    { initialize lov$task_services_entry_points }

    ALLOCATE lov$task_services_entry_points: [1 .. max_tsep];

    FOR i := 1 TO UPPERBOUND (task_services_entry_point_names) DO
      lov$task_services_entry_points^ [i] := task_services_entry_point;
      lov$task_services_entry_points^ [i].name := task_services_entry_point_names [i];
    FOREND;

    prog_options_and_libraries.job_library_list := NIL;
    pmv$prog_options_and_libraries := ^prog_options_and_libraries;

    ALLOCATE pmv$task_tcb_p;
    pmv$task_tcb_p^ := tcb_proto;
    ALLOCATE pmv$task_tcb_p^.nosve.debug_table;
    pmv$task_tcb_p^.nosve.debug_table^ := debug_table_proto;
    pmv$task_tcb_p^.parent := ^tcb_proto;
    pmp$get_binary_mainframe_id (mainframe_id, ignore_status);
    IF (mainframe_id.model_number <> osc$cyber_180_model_990) OR
         (mainframe_id.model_number <> osc$cyber_180_model_990e) THEN
      osv$global_processor_model_info := processor_model_definition1;
    ELSE
      osv$global_processor_model_info := processor_model_definition2;
    IFEND;

  PROCEND initialize_loader_environment;
?? OLDTITLE ??
?? NEWTITLE := '  INITIALIZE_MPE_LOADER_SEQ', EJECT ??

  PROCEDURE initialize_mpe_loader_seq (VAR seq_name: amt$local_file_name;
    VAR status: ost$status);


    VAR
      file_attributes: [STATIC] array [1 .. 5] of amt$access_selection := [[amc$return_option,
        amc$return_at_task_exit], [amc$file_structure, amc$data], [amc$file_contents, amc$unknown_contents],
        [amc$file_processor, amc$unknown_processor], [amc$record_type, amc$undefined]],

      unique_name: ost$unique_name,
      file_identifier: amt$file_identifier,
      interblock_file_identifier: amt$file_identifier,
      interblock_references_hdr: ^pmt$interblock_references_hdr,
      interblock_segment_pointer: amt$segment_pointer,
      segment_pointer: amt$segment_pointer,
      descriptor: ^pmt$loader_seq_descriptor;


    pmp$generate_unique_name (unique_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    seq_name := unique_name.value;


    amp$open (seq_name, amc$segment, ^file_attributes, file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_identifier, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    RESET segment_pointer.sequence_pointer;

    NEXT descriptor IN segment_pointer.sequence_pointer;

    descriptor^.block_name_map_exists := FALSE;
    descriptor^.local_block_id := 0;
    descriptor^.remote_block_id := 0;
    descriptor^.local_block_name_map := NIL;
    descriptor^.remote_block_name_map := NIL;
    descriptor^.max_segment_length := 150000000;

    pmp$generate_unique_name (unique_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    descriptor^.first_interblock_segment_name := unique_name.value;

    amp$open (unique_name.value, amc$segment, ^file_attributes, interblock_file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (interblock_file_identifier, amc$sequence_pointer, interblock_segment_pointer,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET interblock_segment_pointer.sequence_pointer;
    descriptor^.last_interblock_segment := interblock_segment_pointer.sequence_pointer;
    descriptor^.number_of_interblock_segments := 1;

    NEXT interblock_references_hdr IN interblock_segment_pointer.sequence_pointer;

    interblock_references_hdr^.file_id := interblock_file_identifier;
    interblock_references_hdr^.number_of_interblock_references := 0;
    interblock_references_hdr^.next_segment_file_name := osc$null_name;



    amp$set_segment_eoi (file_identifier, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$close (file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$set_segment_eoi (interblock_file_identifier, interblock_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$close (interblock_file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


  PROCEND initialize_mpe_loader_seq;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_RESULTS', EJECT ??

  PROCEDURE display_results (loader_entry_point: string ( * );
        load_status: ost$status;
        starting: pmt$task_jobmode_statistics;
        ending: pmt$task_jobmode_statistics);


    VAR
      cp_time: integer,
      page_faults: integer,
      strng: string (100),
      length: integer,
      cp_string: string (25),
      cp_length: integer,
      output_status: ost$status,
      ignore_status: ost$status;


    STRINGREP (strng, length, loader_entry_point, ' returned the following status: ');
    osp$set_status_abnormal ('LO', oce$misc_exception, strng (1, length), output_status);
    osp$generate_message (output_status, ignore_status);

    IF load_status.normal THEN
      osp$set_status_abnormal ('LO', oce$misc_exception, 'NORMAL STATUS  --', output_status);
      osp$generate_message (output_status, ignore_status);

    ELSE
      osp$generate_message (load_status, ignore_status);
    IFEND;


    cp_time := (ending.jobmode_cptime - starting.jobmode_cptime);

    page_faults := ending.paging_statistics.page_in_count + ending.paging_statistics.
          pages_reclaimed_from_queue + ending.paging_statistics.new_pages_assigned;
    page_faults := page_faults - starting.paging_statistics.page_in_count - starting.paging_statistics.
          pages_reclaimed_from_queue - starting.paging_statistics.new_pages_assigned;

    STRINGREP (cp_string, cp_length, (cp_time DIV 1000000), '.');
    clp$convert_integer_to_rjstring ((cp_time MOD 1000000), 10, FALSE, '0', cp_string (cp_length + 1, 6),
          ignore_status);
    STRINGREP (strng, length, 'Job cp time =', cp_string (1, cp_length + 6),
          '   page faults =', page_faults, '.');

    osp$set_status_abnormal ('LO', oce$misc_exception, strng (1,length), output_status);
    osp$generate_message (output_status, ignore_status);

    osp$set_status_abnormal ('LO', oce$misc_exception, ' ', output_status);
    osp$generate_message (output_status, ignore_status);


  PROCEND display_results;
?? OLDTITLE ??
?? NEWTITLE := '  LOP$STANDALONE_LOADER_FRONT_END', EJECT ??

  PROCEDURE [XDCL, #GATE] lop$standalone_loader_front_end (parameter_list: clt$parameter_list;
    VAR status: ost$status);




{ *** WARNING - change 'LOC$TASK_SERVICES_ENTRY_POINTS' *** }


{ PROCEDURE load_program (
{   file, files, f: list of file = $optional
{   library, libraries, l: list of any of
{       file
{       key
{         loc$task_services_library_name
{       keyend
{     anyend = $optional
{   module, modules, m: list of program_name = $optional
{   starting_procedure, sp: program_name = $optional
{   load_map, lm: file = :$local.loadmap
{   load_map_option, load_map_options, lmo: any of
{       key
{         all, none
{       keyend
{       list of key
{         (segment, s)
{         (block, b)
{         (entry_point, ep)
{         (cross_reference, cr)
{       keyend
{     anyend = all
{   termination_error_level, tel: key
{       (warning, w)
{       (error, e)
{       (fatal, f)
{     keyend = error
{   preset_value, pv: key
{       (zero, z)
{       (floating_point_indefinite, fpi)
{       (infinity, i)
{       (alternate_ones, ao)
{     keyend = zero
{   stack_size, ss: integer 0..osc$max_segment_length = 33554432
{   job_library_list, jll: list of file = $optional
{   target_ring, tr: integer osc$min_ring..osc$max_ring = 11
{   debug_ring, dr: integer osc$min_ring..osc$max_ring = 11
{   target_text, tt: file = $optional
{   dynamic_load, dl: key
{       none
{       (load, l)
{       (module, m)
{     keyend = none
{   dynamic_load_proc, dlp: program_name = $optional
{   load_module_library_name, lmln: file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 37] of clt$pdt_parameter_name,
      parameters: array [1 .. 17] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 1] of clt$keyword_specification,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
      type5: record
        header: clt$type_specification_header,
        default_value: string (15),
      recend,
      type6: 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 .. 2] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 8] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (8),
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (2),
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (2),
      recend,
      type13: record
        header: clt$type_specification_header,
      recend,
      type14: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type15: record
        header: clt$type_specification_header,
      recend,
      type16: record
        header: clt$type_specification_header,
      recend,
      type17: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 10, 5, 10, 36, 32, 386],
    clc$command, 37, 17, 0, 0, 0, 0, 17, ''], [
    ['DEBUG_RING                     ',clc$nominal_entry, 12],
    ['DL                             ',clc$abbreviation_entry, 14],
    ['DLP                            ',clc$abbreviation_entry, 15],
    ['DR                             ',clc$abbreviation_entry, 12],
    ['DYNAMIC_LOAD                   ',clc$nominal_entry, 14],
    ['DYNAMIC_LOAD_PROC              ',clc$nominal_entry, 15],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['FILES                          ',clc$alias_entry, 1],
    ['JLL                            ',clc$abbreviation_entry, 10],
    ['JOB_LIBRARY_LIST               ',clc$nominal_entry, 10],
    ['L                              ',clc$abbreviation_entry, 2],
    ['LIBRARIES                      ',clc$alias_entry, 2],
    ['LIBRARY                        ',clc$nominal_entry, 2],
    ['LM                             ',clc$abbreviation_entry, 5],
    ['LMLN                           ',clc$abbreviation_entry, 16],
    ['LMO                            ',clc$abbreviation_entry, 6],
    ['LOAD_MAP                       ',clc$nominal_entry, 5],
    ['LOAD_MAP_OPTION                ',clc$nominal_entry, 6],
    ['LOAD_MAP_OPTIONS               ',clc$alias_entry, 6],
    ['LOAD_MODULE_LIBRARY_NAME       ',clc$nominal_entry, 16],
    ['M                              ',clc$abbreviation_entry, 3],
    ['MODULE                         ',clc$nominal_entry, 3],
    ['MODULES                        ',clc$alias_entry, 3],
    ['PRESET_VALUE                   ',clc$nominal_entry, 8],
    ['PV                             ',clc$abbreviation_entry, 8],
    ['SP                             ',clc$abbreviation_entry, 4],
    ['SS                             ',clc$abbreviation_entry, 9],
    ['STACK_SIZE                     ',clc$nominal_entry, 9],
    ['STARTING_PROCEDURE             ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 17],
    ['TARGET_RING                    ',clc$nominal_entry, 11],
    ['TARGET_TEXT                    ',clc$nominal_entry, 13],
    ['TEL                            ',clc$abbreviation_entry, 7],
    ['TERMINATION_ERROR_LEVEL        ',clc$nominal_entry, 7],
    ['TR                             ',clc$abbreviation_entry, 11],
    ['TT                             ',clc$abbreviation_entry, 13]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 19, clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 83, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 19, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [30, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 15],
{ PARAMETER 6
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 420, clc$optional_default_parameter, 0, 3],
{ PARAMETER 7
    [35, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_default_parameter, 0, 5],
{ PARAMETER 8
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 303, clc$optional_default_parameter, 0, 4],
{ PARAMETER 9
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 8],
{ PARAMETER 10
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 19, clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [32, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 2],
{ PARAMETER 12
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 2],
{ PARAMETER 13
    [33, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 14
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 192, clc$optional_default_parameter, 0, 4],
{ PARAMETER 15
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 16
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [31, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [67, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$file_type,
      clc$keyword_type],
      FALSE, 2],
      3, [[1, 0, clc$file_type]],
      44, [[1, 0, clc$keyword_type], [1], [
        [LOC$TASK_SERVICES_LIBRARY_NAME, clc$nominal_entry,
  clc$normal_usage_entry, 1]]
        ]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$program_name_type]]
    ],
{ PARAMETER 4
    [[1, 0, clc$program_name_type]],
{ PARAMETER 5
    [[1, 0, clc$file_type],
    ':$local.loadmap'],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    319, [[1, 0, clc$list_type], [303, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [8], [
        ['B                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['BLOCK                          ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['CR                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['CROSS_REFERENCE                ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['ENTRY_POINT                    ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['EP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['SEGMENT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 7
    [[1, 0, clc$keyword_type], [6], [
    ['E                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['ERROR                          ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['F                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['FATAL                          ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['W                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['WARNING                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ,
    'error'],
{ PARAMETER 8
    [[1, 0, clc$keyword_type], [8], [
    ['ALTERNATE_ONES                 ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['AO                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
    ['FLOATING_POINT_INDEFINITE      ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['FPI                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['I                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['INFINITY                       ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['Z                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['ZERO                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ,
    'zero'],
{ PARAMETER 9
    [[1, 0, clc$integer_type], [0, osc$max_segment_length, 10],
    '33554432'],
{ PARAMETER 10
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 11
    [[1, 0, clc$integer_type], [osc$min_ring, osc$max_ring, 10],
    '11'],
{ PARAMETER 12
    [[1, 0, clc$integer_type], [osc$min_ring, osc$max_ring, 10],
    '11'],
{ PARAMETER 13
    [[1, 0, clc$file_type]],
{ PARAMETER 14
    [[1, 0, clc$keyword_type], [5], [
    ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['LOAD                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['M                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['MODULE                         ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ,
    'none'],
{ PARAMETER 15
    [[1, 0, clc$program_name_type]],
{ PARAMETER 16
    [[1, 0, clc$file_type]],
{ PARAMETER 17
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$library = 2,
      p$module = 3,
      p$starting_procedure = 4,
      p$load_map = 5,
      p$load_map_option = 6,
      p$termination_error_level = 7,
      p$preset_value = 8,
      p$stack_size = 9,
      p$job_library_list = 10,
      p$target_ring = 11,
      p$debug_ring = 12,
      p$target_text = 13,
      p$dynamic_load = 14,
      p$dynamic_load_proc = 15,
      p$load_module_library_name = 16,
      p$status = 17;

    VAR
      pvt: array [1 .. 17] of clt$parameter_value;

    VAR
      object_file_list: ^pmt$object_file_list,
      module_list: ^pmt$module_list,
      execute_library_list: ^pmt$object_library_list,
      job_library_list: ^pmt$object_library_list,
      starting_procedure: pmt$program_name,
      target_ring: ost$ring,
      loaded_ring: ost$valid_ring,
      call_bracket_ring: ost$valid_ring,
      loader_options: lot$loader_options,
      mpe_description: pmt$loader_description,
      loaded_program_cbp: ^ost$external_code_base_pointer,
      dynamic_load: 0 .. 2,
      dynamic_load_proc: pmt$program_name,
      load_module_library_name: amt$local_file_name,
      load_module_segment_pointer: amt$segment_pointer,
      file_identifier: amt$file_identifier,
      usage_attributes: array [1 .. 3] of fst$attachment_option,
      local_status: ost$status;


    VAR
      set_count: clt$list_size,
      i: clt$list_size,
      loaded_address: pmt$loaded_address,
      load_status: ost$status,
      node: ^clt$data_value,
      starting_statistics: pmt$task_jobmode_statistics,
      ending_statistics: pmt$task_jobmode_statistics;

    status.normal := TRUE;

    initialize_loader_environment;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ FILE

    IF NOT pvt [p$file].specified THEN
      object_file_list := NIL;
    ELSE
      set_count := clp$count_list_elements (pvt [p$file].value);
      PUSH object_file_list: [1 .. set_count];
      node := pvt [p$file].value;
      FOR i := 1 TO set_count DO
        object_file_list^ [i] := node^.element_value^.file_value^;
        node := node^.link;
      FOREND;
    IFEND;

{ LIBRARY

    IF NOT pvt [p$library].specified THEN
      execute_library_list := NIL;
    ELSE
      set_count := clp$count_list_elements (pvt [p$library].value);
      PUSH execute_library_list: [1 .. set_count];
      node := pvt [p$library].value;
      FOR i := 1 TO set_count DO
        IF node^.element_value^.kind = clc$keyword THEN
          execute_library_list^ [i] := node^.element_value^.keyword_value;
        ELSE
          execute_library_list^ [i] := node^.element_value^.file_value^;
        IFEND;
        node := node^.link;
      FOREND;
    IFEND;

{ MODULE

    IF NOT pvt [p$module].specified THEN
      module_list := NIL;
    ELSE
      set_count := clp$count_list_elements (pvt [p$module].value);
      PUSH module_list: [1 .. set_count];
      node := pvt [p$module].value;
      FOR i := 1 TO set_count DO
        module_list^ [i] := node^.element_value^.program_name_value;
        node := node^.link;
      FOREND;
    IFEND;

{ STARTING_PROCEDURE

    IF NOT pvt [p$starting_procedure].specified THEN
      starting_procedure := osc$null_name;
    ELSE
      starting_procedure := pvt [p$starting_procedure].value^.program_name_value;
    IFEND;

{ LOAD_MAP

    loader_options.map_file := pvt [p$load_map].value^.file_value^;

{ LOAD_MAP_OPTION

    loader_options.map := $pmt$load_map_options [];
    IF pvt [p$load_map_option].value^.kind = clc$keyword THEN
      IF pvt [p$load_map_option].value^.keyword_value = 'ALL' THEN
        loader_options.map := $pmt$load_map_options [pmc$segment_map, pmc$block_map, pmc$entry_point_map];
      ELSE
        loader_options.map := $pmt$load_map_options [pmc$no_load_map];
      IFEND;
    ELSE
      node := pvt [p$load_map_option].value;
      WHILE (node <>  NIL) AND (node^.element_value <> NIL) DO
        CASE node^.element_value^.keyword_value (1) OF
        = 'S' =
          loader_options.map := loader_options.map + $pmt$load_map_options [pmc$segment_map];
        = 'B' =
          loader_options.map := loader_options.map + $pmt$load_map_options [pmc$block_map];
        = 'E' =
          loader_options.map := loader_options.map + $pmt$load_map_options [pmc$entry_point_map];
        = 'C' =
          loader_options.map := loader_options.map + $pmt$load_map_options [pmc$entry_point_xref];
        CASEND;
      WHILEND;
    IFEND;

{ TERMINATION_ERROR_LEVEL

    CASE pvt [p$termination_error_level].value^.keyword_value (1) OF
    = 'W' =
      loader_options.termination_error_level := pmc$warning_load_errors;
    = 'E' =
      loader_options.termination_error_level := pmc$error_load_errors;
    = 'F' =
      loader_options.termination_error_level := pmc$fatal_load_errors;
    CASEND;

{ PRESET_VALUE

    CASE pvt [p$preset_value].value^.keyword_value (1) OF
    = 'Z' =
      loader_options.preset := 0;
    = 'I' =
      loader_options.preset := 050000000(16);
    = 'F' =
      loader_options.preset := 070000000(16);
    = 'A' =
      loader_options.preset := 0aaaaaaaa(16);
    CASEND;

{ STACK_SIZE

    loader_options.maximum_stack_size := pvt [p$stack_size].value^.integer_value.value;

{ JOB_LIBRARY_LIST

    IF NOT pvt [p$job_library_list].specified THEN
      job_library_list := NIL;
    ELSE
      set_count := clp$count_list_elements (pvt [p$job_library_list].value);
      PUSH job_library_list: [1 .. set_count];
      node := pvt [p$job_library_list].value;
      FOR i := 1 TO set_count DO
        job_library_list^ [i] := node^.element_value^.file_value^;
        node := node^.link;
      FOREND;
    IFEND;

    pmv$prog_options_and_libraries^.job_library_list := job_library_list;

{ TARGET_RING

    target_ring := pvt [p$target_ring].value^.integer_value.value;

    pmv$task_tcb_p^.parent^.target_ring := target_ring;
    pmv$task_tcb_p^.target_ring := target_ring;

{ DEBUG_RING

    loader_options.debug_ring := pvt [p$debug_ring].value^.integer_value.value;

{ TARGET_TEXT

    IF NOT pvt [p$target_text].specified THEN
      mpe_description.apd_load := FALSE;
    ELSE
      mpe_description.apd_load := TRUE;
      clp$convert_string_to_file (pvt [p$target_text].value^.file_value^, mpe_description.
             target_text, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      initialize_mpe_loader_seq (mpe_description.mpe_loader_seq, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ DYNAMIC_LOAD

    CASE pvt [p$dynamic_load].value^.keyword_value (1) OF
    = 'N' =
      dynamic_load := 0;
    = 'L' =
      dynamic_load := 1;
    = 'M' =
      dynamic_load := 2;
    CASEND;

{ DYNAMIC_LOAD_PROC

    IF dynamic_load <> 0 THEN
      IF NOT pvt [p$dynamic_load_proc].specified THEN
        dynamic_load_proc := osc$null_name;
      ELSE
        dynamic_load_proc := pvt [p$dynamic_load_proc].value^.program_name_value;
      IFEND;
    IFEND;

{ LOAD_MODULE_LIBRARY_NAME

    IF NOT pvt [p$load_module_library_name].specified THEN
      load_module_library_name := osc$null_name;
    ELSE
      load_module_library_name := pvt [p$load_module_library_name].value^.file_value^;
    IFEND;

{ LOP$LOAD_PROGRAM

    pmp$get_task_jobmode_statistics (starting_statistics, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    lop$load_program (object_file_list, module_list, execute_library_list, job_library_list,
          starting_procedure, target_ring, loader_options, ^mpe_description, loaded_program_cbp,
          load_status);

    pmp$get_task_jobmode_statistics (ending_statistics, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_results ('LOP$LOAD_PROGRAM', load_status, starting_statistics, ending_statistics);

    IF dynamic_load = 0 THEN
      RETURN;

{ PMP$LOAD }

    ELSEIF dynamic_load = 1 THEN
      pmp$get_task_jobmode_statistics (starting_statistics, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pmp$load (dynamic_load_proc, pmc$procedure_address, loaded_address, load_status);

      pmp$get_task_jobmode_statistics (ending_statistics, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_results ('PMP$LOAD', load_status, starting_statistics, ending_statistics);
      RETURN;

    ELSEIF dynamic_load = 2 THEN

{ PMP$LOAD_MODULE_FROM_LIBRARY }

      pmp$get_task_jobmode_statistics (starting_statistics, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      usage_attributes [1].selector := fsc$access_and_share_modes;
      usage_attributes [1].access_modes.selector := fsc$specific_access_modes;
      usage_attributes [1].access_modes.value  := $fst$file_access_options [fsc$read,fsc$execute];
      usage_attributes [1].share_modes.selector := fsc$determine_from_access_modes;
      usage_attributes [2].selector := fsc$access_and_share_modes;
      usage_attributes [2].access_modes.selector := fsc$specific_access_modes;
      usage_attributes [2].access_modes.value  := $fst$file_access_options [fsc$execute];
      usage_attributes [2].share_modes.selector := fsc$determine_from_access_modes;
      usage_attributes [3].selector := fsc$create_file;
      usage_attributes [3].create_file := FALSE;

      fsp$open_file (load_module_library_name, amc$segment, ^usage_attributes, NIL, NIL, NIL, NIL,
              file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$get_segment_pointer (file_identifier, amc$sequence_pointer, load_module_segment_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pmp$load_module_from_library (dynamic_load_proc, target_ring,
            pmc$procedure_address, load_module_library_name, loaded_ring, call_bracket_ring,
                  loaded_address, load_status);

      pmp$get_task_jobmode_statistics (ending_statistics, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_results ('PMP$LOAD_MODULE_FROM_LIBRARY', load_status, starting_statistics, ending_statistics);
    IFEND;

  PROCEND lop$standalone_loader_front_end;
?? OLDTITLE ??
?? NEWTITLE := '  FMP$LN_OPEN_CHAPTER', EJECT ??

  PROCEDURE [XDCL] fmp$ln_open_chapter (local_file_name: amt$local_file_name;
        chapter_number: dmt$chapter_number;
        validation_ring: ost$valid_ring;
        segment_attributes: ^array [ * ] of mmt$attribute_descriptor;
        pointer_kind: mmt$segment_pointer_kind;
    VAR segment_pointer: mmt$segment_pointer;
    VAR status: ost$status);


    status.normal := TRUE;


  PROCEND fmp$ln_open_chapter;
?? OLDTITLE ??
?? NEWTITLE := '  MMP$CREATE_SEGMENT', EJECT ??

  PROCEDURE [XDCL] mmp$create_segment (seg_attributes_p: ^array [ * ] OF mmt$attribute_descriptor;
        pointer_kind: mmt$segment_pointer_kind;
        validation_ring_number: ost$valid_ring;
    VAR pointer: mmt$segment_pointer;
    VAR status: ost$status);


    VAR
      return_option: [STATIC] array [1 .. 1] of amt$access_selection := [[amc$return_option,
        amc$return_at_task_exit]],
      unique_name: ost$unique_name,
      id: amt$file_identifier,
      segment: amt$segment_pointer;


    status.normal := TRUE;


    CASE pointer_kind OF
    = mmc$heap_pointer =
      mmp$create_scratch_segment (amc$heap_pointer, mmc$as_random, segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      pointer.heap_pointer := segment.heap_pointer;
      RESET pointer.heap_pointer^;

    = mmc$sequence_pointer, mmc$cell_pointer =
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET segment.sequence_pointer;
      IF pointer_kind = mmc$sequence_pointer THEN
        pointer.seq_pointer := segment.sequence_pointer;
      ELSE
        NEXT pointer.cell_pointer IN segment.sequence_pointer;
      IFEND;
    CASEND;


  PROCEND mmp$create_segment;
?? OLDTITLE ??
?? NEWTITLE := '  MMP$DELETE_SEGMENT', EJECT ??

  PROCEDURE [XDCL] mmp$delete_segment (VAR pointer: mmt$segment_pointer;
        validation_ring_number: ost$valid_ring;
    VAR status: ost$status);


    status.normal := TRUE;


  PROCEND mmp$delete_segment;
?? OLDTITLE ??
?? NEWTITLE := '  MMP$STORE_SEGMENT_ATTRIBUTES', EJECT ??

  PROCEDURE [XDCL] mmp$store_segment_attributes (pva: ^cell;
        validation_ring_number: ost$valid_ring;
        seg_attributes: array [ * ] OF mmt$attribute_descriptor;
    VAR status: ost$status);


    status.normal := TRUE;


  PROCEND mmp$store_segment_attributes;
?? OLDTITLE ??
?? NEWTITLE := '  MMP$FETCH_SEGMENT_ATTRIBUTES', EJECT ??

  PROCEDURE [XDCL] mmp$fetch_segment_attributes (pva: ^cell;
    VAR seg_attributes: array [ * ] OF mmt$attribute_descriptor;
    VAR status: ost$status);


    VAR
      i: integer;


    FOR i := 1 TO UPPERBOUND (seg_attributes) DO
      CASE seg_attributes [i].keyword OF
        = mmc$kw_max_segment_length =
          seg_attributes [i].max_length := 7fffffff(16);
        ELSE
      CASEND;
    FOREND;


  PROCEND mmp$fetch_segment_attributes;
?? OLDTITLE ??
?? NEWTITLE := '  HPP$INITIALIZE', EJECT ??

  PROCEDURE [XDCL] osp$reset_heap (heap_p: ^ost$heap;
        l: integer;
        wait_option: boolean;
        algorithm: 0 .. 255);



  PROCEND osp$reset_heap;
?? OLDTITLE ??
?? NEWTITLE := '  PMP$RECORD_TASK_NAME', EJECT ??

  PROCEDURE [XDCL] pmp$record_task_name (task_name: ost$name;
        override_old_name {control} : boolean);




  PROCEND pmp$record_task_name;
?? OLDTITLE ??
?? NEWTITLE := '  PMP$GET_LOADED_RINGS', EJECT ??

  PROCEDURE [XDCL] pmp$get_loaded_rings (VAR loaded_rings: pmt$loadable_rings);


    loaded_rings := $pmt$loadable_rings [1, 2, 3];


  PROCEND pmp$get_loaded_rings;
?? OLDTITLE ??
?? NEWTITLE := '  FSP$CHANGE_SEGMENT_NUMBER', EJECT ??

  PROCEDURE [XDCL] fsp$change_segment_number
    (    file_identifier: amt$file_identifier;
         new_segment_number: ost$segment;
         validation_ring: ost$valid_ring;
         pointer_kind: amt$pointer_kind;
     VAR segment_pointer: amt$segment_pointer;
     VAR status: ost$status);

  PROCEND fsp$change_segment_number;
?? OLDTITLE ??
?? NEWTITLE := '  PMP$FIND_OPTNS_LIBS_FIRST_TIME', EJECT ??

  PROCEDURE [XDCL] pmp$find_optns_libs_first_time (VAR tcb: ^pmt$prog_options_and_libraries);



  PROCEND pmp$find_optns_libs_first_time;
?? OLDTITLE ??
?? NEWTITLE := 'SYP$FETCH_SYSTEM_CONSTANT', EJECT ??

  PROCEDURE [XDCL] syp$fetch_system_constant (VAR name: string (*);
    VAR index: integer;
    VAR value: integer;
    VAR status: ost$status);


    value := 150000000;


  PROCEND syp$fetch_system_constant;
?? OLDTITLE ??
?? NEWTITLE := 'BAP$INHIBIT_IMPLICIT_DETACH', EJECT ??

  PROCEDURE [XDCL] bap$inhibit_implicit_detach
    (    file_identifier: amt$file_identifier);

  PROCEND bap$inhibit_implicit_detach;
?? OLDTITLE ??
MODEND lom$loader_front_end;
*DECK DECK=LOM$LOAD_FILE_PREPARATION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Loader : Load file preparation' ??
MODULE lom$load_file_preparation;

{  PURPOSE:
{    This module is responsible for preparing object text files for use in the load process.  This
{    consists of determining file attributes, verifying basic load file criteria, and opening
{    the file for segment access.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc llt$load_module
*copyc lot$loader_type_definitions
*copyc lot$load_file_number
*copyc osd$integer_limits
*copyc oss$task_private
?? POP ??
*copyc amp$fetch
*copyc amp$get_segment_pointer
*copyc fsp$open_file
*copyc lop$report_error
*copyc lop$report_secondary_error
*copyc mmp$store_segment_attributes
*copyc osp$system_error
*copyc pmp$task_debug_ring

*copyc lov$secondary_status
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    load_file_number: [STATIC, oss$task_private] lot$load_file_number := 0;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$build_file_descriptor', EJECT ??

  PROCEDURE [XDCL] lop$build_file_descriptor
    (    file_name: amt$local_file_name;
     VAR file_loadable: {control} boolean;
     VAR file_descriptor: lot$file_descriptor);

    VAR
      current_attributes: array [1 .. 6] of amt$fetch_item,
      local_file: boolean,
      existing_file: boolean,
      contains_data: boolean,
      debug_ring: ost$ring,
      usage_attributes: array [1 .. 3] of fst$attachment_option,
      change_attributes: array [1 .. 1] of mmt$attribute_descriptor,
      segment_pointer: amt$segment_pointer,
      object_library_header: ^llt$object_library_header;

  /normal_sequence/
    BEGIN
      usage_attributes [1].selector := fsc$access_and_share_modes;
      usage_attributes [1].access_modes.selector := fsc$specific_access_modes;
      usage_attributes [1].access_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
      usage_attributes [1].share_modes.selector := fsc$determine_from_access_modes;
      usage_attributes [2].selector := fsc$access_and_share_modes;
      usage_attributes [2].access_modes.selector := fsc$specific_access_modes;
      usage_attributes [2].access_modes.value := $fst$file_access_options [fsc$execute];
      usage_attributes [2].share_modes.selector := fsc$determine_from_access_modes;
      usage_attributes [3].selector := fsc$create_file;
      usage_attributes [3].create_file := FALSE;
      fsp$open_file (file_name, amc$segment, ^usage_attributes, NIL, NIL, NIL, NIL,
            file_descriptor.file_identifier, lov$secondary_status);
      IF NOT lov$secondary_status.normal THEN
        IF (lov$secondary_status.condition = ame$file_not_known) THEN
          lov$secondary_status.normal := TRUE;
          lop$report_error (lle$empty_load_file, file_name, '', 0);
          file_loadable := FALSE;
          file_descriptor.file_open := FALSE;
          RETURN;
        IFEND;
        IF (lov$secondary_status.condition = fse$redundant_attach_conflict) OR
              (lov$secondary_status.condition = pfe$cycle_busy) THEN
          lov$secondary_status.normal := TRUE;
          lop$report_error (lle$access_share_modes_conflict, file_name, '', 0);
          file_loadable := FALSE;
          file_descriptor.file_open := FALSE;
          RETURN;
        IFEND;
        lop$report_secondary_error (lov$secondary_status);
        EXIT /normal_sequence/
      IFEND;
      file_descriptor.file_open := TRUE;

      current_attributes [1].key := amc$ring_attributes;
      current_attributes [2].key := amc$file_contents;
      current_attributes [3].key := amc$file_structure;
      current_attributes [4].key := amc$file_access_procedure;
      current_attributes [5].key := amc$file_processor;
      current_attributes [6].key := amc$global_access_mode;

      amp$fetch (file_descriptor.file_identifier, current_attributes, lov$secondary_status);
      IF NOT (lov$secondary_status.normal AND (pfc$execute IN current_attributes [6].global_access_mode)) THEN
        IF NOT lov$secondary_status.normal THEN
          lop$report_secondary_error (lov$secondary_status);
        IFEND;
        EXIT /normal_sequence/
      IFEND;

      IF (current_attributes [2].file_contents <> amc$object) OR
            ((current_attributes [3].file_structure <> amc$data) AND
            (current_attributes [3].file_structure <> amc$library)) THEN
        lop$report_error (lle$file_not_load_file, file_name, '', 0);
        file_loadable := FALSE;
        file_descriptor.file_open := FALSE;
      ELSEIF (current_attributes [4].file_access_procedure <> osc$null_name) THEN
        lop$report_error (lle$file_contains_fap, file_name, '', 0);
        file_loadable := FALSE;
        file_descriptor.file_open := FALSE;
      ELSE
        file_descriptor.ring_brackets.r1 := current_attributes [1].ring_attributes.r1;
        file_descriptor.ring_brackets.r2 := current_attributes [1].ring_attributes.r2;
        file_descriptor.ring_brackets.r3 := current_attributes [1].ring_attributes.r3;
        file_descriptor.attributes.name := file_name;
        file_descriptor.attributes.library_file := (current_attributes [3].file_structure = amc$library);
        file_descriptor.attributes.key_lock.global := FALSE;
        file_descriptor.attributes.key_lock.local := FALSE;
        file_descriptor.attributes.key_lock.value := 0;
        file_descriptor.attributes.execute_privilege := osc$non_privileged;
        file_descriptor.attributes.debug_file := (current_attributes [5].file_processor = amc$debugger);
        load_file_number := load_file_number + 1;
        file_descriptor.attributes.load_file_number := load_file_number;

        amp$get_segment_pointer (file_descriptor.file_identifier, amc$sequence_pointer, segment_pointer,
              lov$secondary_status);
        IF NOT lov$secondary_status.normal THEN
          lop$report_secondary_error (lov$secondary_status);
          EXIT /normal_sequence/
        IFEND;

        IF file_descriptor.attributes.debug_file THEN
          debug_ring := pmp$task_debug_ring ();
          IF (file_descriptor.ring_brackets.r1 <= debug_ring) AND
                (debug_ring <= file_descriptor.ring_brackets.r2) THEN
            file_descriptor.ring_brackets.r1 := debug_ring;
            file_descriptor.ring_brackets.r2 := debug_ring;

{ change ring attributes in the segment_table_descriptor such that the debugger can access
{ it's own data;

            change_attributes [1].keyword := mmc$kw_ring_numbers;
            change_attributes [1].r1 := debug_ring;
            change_attributes [1].r2 := debug_ring;
            mmp$store_segment_attributes (segment_pointer.sequence_pointer, loc$loader_ring,
                  change_attributes, lov$secondary_status);
            IF NOT lov$secondary_status.normal THEN
              lop$report_secondary_error (lov$secondary_status);
              EXIT /normal_sequence/
            IFEND;
          IFEND;
        IFEND;

        file_descriptor.segment := segment_pointer.sequence_pointer;
        RESET file_descriptor.segment;

        IF file_descriptor.attributes.library_file THEN
          NEXT object_library_header IN file_descriptor.segment;
          IF object_library_header = NIL THEN
            lop$report_error (lle$library_header_missing, file_name, '', 0);
            file_loadable := FALSE;
            file_descriptor.file_open := FALSE;
            RETURN;
          IFEND;

          IF (object_library_header^.version <> llc$object_library_version) AND
                (object_library_header^.version <> 'V1.0') THEN
            lop$report_error (lle$wrong_library_version, llc$object_library_version, file_name, 0);
            file_loadable := FALSE;
            file_descriptor.file_open := FALSE;
            RETURN;
          IFEND;

          RESET file_descriptor.segment;
        IFEND;

        file_loadable := TRUE;
      IFEND;
      RETURN
    END /normal_sequence/;
    file_loadable := FALSE;
    file_descriptor.file_open := FALSE;
    lop$report_error (lle$unable_to_access_load_file, file_name, '', 0);
  PROCEND lop$build_file_descriptor;
MODEND lom$load_file_preparation;
*DECK DECK=LOM$LOAD_LIBRARY_MODULES EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE : Loader : Load library modules' ??
MODULE lom$load_library_modules;

{  PURPOSE:
{    This module contains procedures responsible for loading of modules from object_library files.
{    Knowledge of the structure of object_library files is localized in this module.

  ?VAR
    inline_procs: boolean := TRUE?;

?? NEWTITLE := '  Global declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc llt$deferred_entry_points
*copyc llt$entry_point_dictionary
*copyc llt$load_module_header
*copyc llt$module_dictionary
*copyc llt$object_library_header
*copyc loc$deferred_entry_pt_library
*copyc loc$task_services_library_name
*copyc lok$keypoints
*copyc lot$loader_options
*copyc lot$loader_type_definitions
?? POP ??
*copyc bap$inhibit_implicit_detach
*copyc lop$define_entry_point
*copyc lop$load_module
*copyc lop$open_library
*copyc lop$report_error
*copyc lop$satisfy_task_services_refs
*copyc lov$deferred_entry_points
*copyc lov$head_of_unsat_ref_list
*copyc lov$library_list
*copyc lov$unsatisfied_reference
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$load_library_file', EJECT ??

  PROCEDURE [XDCL] lop$load_library_file
    (    file_descriptor: lot$file_descriptor;
         module_ring_attributes: lot$module_ring_attributes;
         control_options {control} : lot$control_options;
     VAR transfer_descriptor: lot$external_descriptor);

{  PURPOSE:
{    This procedure initiates the loading of every load_module contained on a library file.

    VAR
      library_file: lot$load_file,
      object_text_descriptor: ^llt$object_text_descriptor,
      library_header: ^llt$object_library_header,
      library_hdr: ^llt$object_library_header_v1_0,
      module_dictionary: ^llt$module_dictionary,
      number_of_modules: 0 .. llc$max_modules_in_library,
      library_dictionary: ^llt$object_library_dictionaries,
      j: 0 .. llc$max_dictionaries_on_library,
      i: 0 .. llc$max_modules_in_library,
      module_header: ^llt$load_module_header,
      valid_file_position: boolean,
      module_structure_error: boolean,
      ignore_symbol_table_present: boolean;

    library_file := file_descriptor.segment;
    RESET library_file;
    NEXT library_header IN library_file;
    IF library_header = NIL THEN
      lop$report_error (lle$library_header_missing, file_descriptor.attributes.name, '', 0);
      RETURN
    IFEND;

    IF library_header^.version = llc$object_library_version THEN

      NEXT library_dictionary: [1 .. library_header^.number_of_dictionaries] IN library_file;
      IF library_dictionary = NIL THEN
        lop$report_error (lle$library_header_missing, file_descriptor.attributes.name, '', 0);
        RETURN;
      IFEND;

      number_of_modules := 0;

      FOR j := LOWERBOUND (library_dictionary^) TO UPPERBOUND (library_dictionary^) DO
        CASE library_dictionary^ [j].kind OF
        = llc$module_dictionary =
          module_dictionary := #PTR (library_dictionary^ [j].module_dictionary, library_file^);
          number_of_modules := UPPERBOUND (module_dictionary^);
        ELSE
        CASEND;
      FOREND;

    ELSEIF library_header^.version = 'V1.0' THEN

      RESET library_file;

      NEXT library_hdr IN library_file;
      IF library_hdr = NIL THEN
        lop$report_error (lle$library_header_missing, file_descriptor.attributes.name, '', 0);
        RETURN;
      IFEND;

      number_of_modules := library_hdr^.number_of_modules;
      module_dictionary := #PTR (library_hdr^.module_dictionary, library_file^);

    ELSE
      lop$report_error (lle$wrong_library_version, file_descriptor.attributes.name, '', 0);
      RETURN;
    IFEND;

    IF number_of_modules <> 0 THEN
      IF module_dictionary = NIL THEN
        lop$report_error (lle$bad_module_dictionary_ptr, file_descriptor.attributes.name, '', 0);
        RETURN;
      IFEND;
    ELSE
      lop$report_error (lle$empty_module_dictionary, file_descriptor.attributes.name, '', 0);
      RETURN;
    IFEND;

    FOR i := 1 TO number_of_modules DO
      IF module_dictionary^ [i].kind = llc$load_module THEN
        module_header := #PTR (module_dictionary^ [i].module_header, library_file^);
        IF module_header = NIL THEN
          lop$report_error (lle$bad_module_header_ptr, file_descriptor.attributes.name, 'module', i);
          RETURN
        IFEND;
        object_text_descriptor := #PTR (module_header^.interpretive_element, library_file^);
        IF object_text_descriptor = NIL THEN
          lop$report_error (lle$bad_interpretive_elem_ptr, file_descriptor.attributes.name, '',
                #OFFSET (module_header));
          RETURN
        IFEND;

        RESET library_file TO object_text_descriptor;
        lop$load_module (module_ring_attributes, file_descriptor.attributes, control_options, library_file,
              transfer_descriptor, ignore_symbol_table_present, module_structure_error);
      IFEND;
    FOREND;
  PROCEND lop$load_library_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$load_module_list', EJECT ??

  PROCEDURE [XDCL] lop$load_module_list
    (    module_list: {input} ^pmt$module_list;
         initial_ring: ost$ring;
         control_options {control} : lot$control_options;
     VAR transfer_descriptor: lot$external_descriptor);

{  PURPOSE:
{    This procedure initiates loading of every module specified in the module_list of a program
{    load request.  Modules are loaded in the order they appear in the module_list.  For each
{    module, the library_list is scanned in an attempt to locate a library containing the
{    module.  This procedure determines the ring into which module will be loaded.

    VAR
      i: pmt$number_of_modules,
      j: 1 .. llc$max_modules_in_library,
      file_descriptor: lot$file_descriptor,
      library_valid: boolean,
      current_library: ^lot$library_descriptor,
      library_file: lot$load_file,
      library_header: ^llt$object_library_header,
      library_hdr: ^llt$object_library_header_v1_0,
      object_text_descriptor: ^llt$object_text_descriptor,
      module_dictionary: ^llt$module_dictionary,
      number_of_modules: 0 .. llc$max_modules_in_library,
      library_dictionary: ^llt$object_library_dictionaries,
      k: 0 .. llc$max_dictionaries_on_library,
      module_found: boolean,
      module_ring_attributes: lot$module_ring_attributes,
      module_header: ^llt$load_module_header,
      valid_file_position: boolean,
      module_structure_error: boolean,
      ignore_symbol_table_present: boolean;

    #KEYPOINT (osk$entry, 0, lok$load_module_list);

  /load_a_module/
    FOR i := 1 TO UPPERBOUND (module_list^) DO
      current_library := lov$library_list.first;

    /search_library_list/
      WHILE current_library <> NIL DO
        IF (NOT current_library^.library_valid) OR (current_library^.phantom_library AND
              (NOT current_library^.phantom_library_active)) THEN
          current_library := current_library^.nnext;
          CYCLE /search_library_list/;
        IFEND;

        IF (current_library^.attributes.name <> loc$task_services_library_name) AND
              (current_library^.attributes.name (1, loc$deferred_entry_pt_lib_size) <>
              loc$deferred_entry_pt_library) THEN
          IF NOT current_library^.library_open THEN
            lop$open_library (current_library^.attributes.name, file_descriptor, library_valid);
            IF NOT library_valid THEN
              current_library^.library_valid := FALSE;
              current_library := current_library^.nnext;
              CYCLE /search_library_list/
            ELSE
              IF current_library^.text_embedded_library THEN
                bap$inhibit_implicit_detach (file_descriptor.file_identifier);
              IFEND;
              current_library^.library_open := TRUE;
              current_library^.segment := file_descriptor.segment;
              current_library^.ring_brackets := file_descriptor.ring_brackets;
              current_library^.attributes := file_descriptor.attributes;
            IFEND;
          IFEND;

          IF (initial_ring >= current_library^.ring_brackets.r1) AND
                (initial_ring <= current_library^.ring_brackets.r3) THEN
            library_file := current_library^.segment;
            RESET library_file;
            NEXT library_header IN library_file;

            IF library_header^.version = llc$object_library_version THEN

              NEXT library_dictionary: [1 .. library_header^.number_of_dictionaries] IN library_file;

            /find_module_dictionary/
              FOR k := LOWERBOUND (library_dictionary^) TO UPPERBOUND (library_dictionary^) DO
                CASE library_dictionary^ [k].kind OF
                = llc$module_dictionary =
                  module_dictionary := #PTR (library_dictionary^ [k].module_dictionary, library_file^);
                  number_of_modules := UPPERBOUND (module_dictionary^);
                  EXIT /find_module_dictionary/;
                ELSE
                CASEND;
              FOREND /find_module_dictionary/;

            ELSEIF library_header^.version = 'V1.0' THEN

              RESET library_file;
              NEXT library_hdr IN library_file;
              module_dictionary := #PTR (library_hdr^.module_dictionary, library_file^);
            ELSE
            IFEND;

            module_found := FALSE;

          /search_module_dictionary/
            FOR j := LOWERBOUND (module_dictionary^) TO UPPERBOUND (module_dictionary^) DO
              IF (module_list^ [i] = module_dictionary^ [j].name) AND
                    (module_dictionary^ [j].kind = llc$load_module) THEN
                module_found := TRUE;
                EXIT /search_module_dictionary/
              IFEND;
            FOREND /search_module_dictionary/;
            IF module_found THEN
              IF initial_ring >= current_library^.ring_brackets.r2 THEN
                module_ring_attributes.loaded_ring := current_library^.ring_brackets.r2;
                module_ring_attributes.call_bracket := current_library^.ring_brackets.r3;
              ELSE
                module_ring_attributes.loaded_ring := initial_ring;
                module_ring_attributes.call_bracket := initial_ring;
              IFEND;
              module_header := #PTR (module_dictionary^ [j].module_header, library_file^);
              IF module_header = NIL THEN
                lop$report_error (lle$bad_module_header_ptr, current_library^.attributes.name, 'module', j);
                CYCLE /load_a_module/
              IFEND;
              object_text_descriptor := #PTR (module_header^.interpretive_element, library_file^);
              IF object_text_descriptor = NIL THEN
                lop$report_error (lle$bad_interpretive_elem_ptr, current_library^.attributes.name, '',
                      #OFFSET (module_header));
                CYCLE /load_a_module/
              IFEND;

              RESET library_file TO object_text_descriptor;

              lop$load_module (module_ring_attributes, current_library^.attributes, control_options,
                    library_file, transfer_descriptor, ignore_symbol_table_present, module_structure_error);
              CYCLE /load_a_module/
            IFEND;
          IFEND;
        IFEND;
        current_library := current_library^.nnext;
      WHILEND /search_library_list/;
      lop$report_error (lle$module_not_found, module_list^ [i], '', 0);
    FOREND /load_a_module/;
    #KEYPOINT (osk$exit, 0, lok$load_module_list);
  PROCEND lop$load_module_list;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$search_entry_pt_dictionary', EJECT ??

  PROCEDURE [XDCL] lop$search_entry_pt_dictionary
    (    external_name: {input} ^pmt$program_name;
         entry_point_dictionary: {input} ^llt$entry_point_dictionary;
     VAR entry_point_found {control} : boolean;
     VAR entry_point_gated {control} : boolean;
     VAR dictionary_index: 1 .. llc$max_entry_points_in_library);

{!  A search which took advantage of the fact that external names are received in lexical order
{!  might prove faster.  Also, selecting either a binary search or an ordered search, depending on
{!  the number of entries to be scanned, looks promising.  Remembering the value of lower between
{!  successive calls (for the same library) would improve performance.  Note that successive
{!  calls may be for the same external name.

    VAR
      temp: integer,
      lower: 1 .. llc$max_entry_points_in_library,
      upper: 0 .. llc$max_entry_points_in_library;

    IF entry_point_dictionary <> NIL THEN
      lower := 1;
      upper := UPPERBOUND (entry_point_dictionary^);

    /binary_search/
      WHILE lower <= upper DO
        temp  := lower + upper;
        dictionary_index := temp DIV 2;
        IF external_name^ = entry_point_dictionary^ [dictionary_index].name THEN
          IF entry_point_dictionary^ [dictionary_index].module_kind = llc$load_module THEN
            entry_point_found := TRUE;
            entry_point_gated := (entry_point_dictionary^ [dictionary_index].kind = llc$gate);
            RETURN
          ELSE
            EXIT /binary_search/
          IFEND;
        ELSE
          IF external_name^ > entry_point_dictionary^ [dictionary_index].name THEN
            lower := dictionary_index + 1;
          ELSE
            upper := dictionary_index - 1;
          IFEND;
        IFEND;
      WHILEND /binary_search/;
    IFEND;

    entry_point_found := FALSE;

  PROCEND lop$search_entry_pt_dictionary;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$satisfy_externals', EJECT ??

  PROCEDURE [XDCL] lop$satisfy_externals
    (    control_options {control} : lot$control_options);

{  PURPOSE:
{    This procedure initiates loading of modules (from libraries) in order to satisfy outstanding
{    external references.  As modules are loaded, new libraries may be added to the library_list
{    and unsatisfied external references may be created, so the list of unsatisfied references is scanned
{    repetitively until no more references can be satisfied.  This procedure determines the ring into
{    which each module will be loaded.
{  NOTE:
{    Due to locality considerations, the outermost loop of this procedure scans the library_list
{    rather than the unsatisfied references list.  For each library in the list, each unsatisfied
{    reference is examined to determine if it can be satisfied by loading a module from the library.
{    The procedure terminates when a scan of the entire library_list is completed without loading
{    any modules.
{    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.
{    When this procedure initiates the loading of a module which should satisfy an external
{    reference, the reference is marked as 'logically_satisfied' and will be ignored on subsequent
{    passes.  This prevents a loop in the case where the external reference is not satisfied
{    (and thereby removed from the unsatisfied list) due to some recoverable error in loading
{    the module.

?? NEWTITLE := 'satisfy_deferred_references', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to determine if any unsatisfied
{   external references can be satisfied by deferred entry points.  If a
{   deferred entry point can satisfy some external reference, then the
{   deferred entry point will be defined in the tasks current symbol table.

    PROCEDURE satisfy_deferred_references
      (    control_options: lot$control_options;
       VAR unsatisfied_reference: ^lot$unsatisfied_reference_list;
       VAR another_scan_required: boolean);

?? NEWTITLE := '[INLINE] find_deferred_entry_point', EJECT ??

{ PURPOSE:
{   This procedure does a binary search looking for an entry point name in
{   a list of deferred entry points.

      PROCEDURE [INLINE] find_deferred_entry_point
        (    deferred_entry_points: {input} ^llt$deferred_entry_points;
             linkage_name: {input} ^pmt$program_name;
         VAR entry_point_found {control} : boolean;
         VAR entry_point_index: 0 .. llc$max_deferred_entry_points);

        VAR
          temp: integer,
          lower: integer,
          upper: integer;

        entry_point_found := FALSE;
        lower := LOWERBOUND (deferred_entry_points^);
        upper := UPPERBOUND (deferred_entry_points^);

        WHILE (NOT entry_point_found) AND (lower <= upper) DO
          temp  := lower + upper;
          entry_point_index := temp  DIV 2;
          IF linkage_name^ = deferred_entry_points^ [entry_point_index].name THEN
            entry_point_found := TRUE;
          ELSEIF linkage_name^ > deferred_entry_points^ [entry_point_index].name THEN
            lower := entry_point_index + 1;
          ELSE
            upper := entry_point_index - 1;
          IFEND;
        WHILEND;
      PROCEND find_deferred_entry_point;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] search_deferred_entry_defs', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to satisfy any unsatisfied references from a
{   deferred entry point library.

      PROCEDURE [INLINE] search_deferred_entry_defs
        (    deferred_entry_points: ^llt$deferred_entry_points);

        VAR
          duplicate_entry_point: boolean,
          entry_point_found: boolean,
          entry_point_index: 0 .. llc$max_deferred_entry_points,
          library_lock: ost$key_lock_value,
          linkage: ^lot$linkage_name_lists,
          reference_group: ^lot$unsatisfied_reference_group,
          reference_group_chain: ^lot$unsatisfied_reference_group,
          references_list_head: ^^lot$unsatisfied_reference_group,
          pseudo_allocated_sections: array [0 .. 1] of lot$section_allocation,
          pseudo_control_options: lot$control_options,
          pseudo_entry_definition: llt$entry_definition,
          pseudo_module_descriptor: lot$module_descriptor;

        linkage := unsatisfied_reference^.linkage_info;

        references_list_head := ^linkage^.unsat_references_list^.references;
        reference_group := references_list_head^;

        IF current_library^.attributes.key_lock.global THEN
          library_lock := current_library^.attributes.key_lock.value;
        ELSE
          library_lock := loc$no_lock;
        IFEND;

        find_deferred_entry_point (deferred_entry_points, ^linkage^.name, entry_point_found,
              entry_point_index);

        IF entry_point_found THEN
          pseudo_entry_definition.section_ordinal := 0;
          pseudo_entry_definition.offset := 0;
          pseudo_entry_definition.attributes := deferred_entry_points^ [entry_point_index].attributes;
          pseudo_entry_definition.name := deferred_entry_points^ [entry_point_index].name;
          pseudo_entry_definition.language := deferred_entry_points^ [entry_point_index].language;
          pseudo_entry_definition.declaration_matching_required :=
                deferred_entry_points^ [entry_point_index].declaration_matching_required;
          pseudo_entry_definition.declaration_matching := deferred_entry_points^ [entry_point_index].
                declaration_matching_value;

          pseudo_module_descriptor.name := 'DEFERRED_ENTRY_POINT';
          pseudo_module_descriptor.attributes.global_key_lock := current_library^.attributes.key_lock.value;
          pseudo_module_descriptor.attributes.binding_section_address.ring :=
                deferred_entry_points^ [entry_point_index].binding_section_address.ring;
          pseudo_module_descriptor.attributes.binding_section_address.segment :=
                deferred_entry_points^ [entry_point_index].binding_section_address.segment;
          pseudo_module_descriptor.attributes.binding_section_address.offset :=
                deferred_entry_points^ [entry_point_index].binding_section_address.offset;
          pseudo_module_descriptor.attributes.vmid := osc$cyber_180_mode;
          pseudo_module_descriptor.attributes.source_declaration_matching :=
                deferred_entry_points^ [entry_point_index].source_type_checking;

          pseudo_allocated_sections [0].kind := llc$code_section;
          pseudo_allocated_sections [0].address.ring := deferred_entry_points^ [entry_point_index].address.
                ring;
          pseudo_allocated_sections [0].address.segment := deferred_entry_points^ [entry_point_index].address.
                segment;
          pseudo_allocated_sections [0].address.offset := deferred_entry_points^ [entry_point_index].address.
                offset;
          pseudo_allocated_sections [0].binding_section_offset := 0;
          pseudo_allocated_sections [0].length := osc$maximum_offset;
          pseudo_allocated_sections [1].length := osc$maximum_offset;

          pseudo_control_options.map := control_options.map * $pmt$load_map_options [pmc$entry_point_xref];
          pseudo_control_options.debug_ring := control_options.debug_ring;
        IFEND;

      /scan_reference_group_list/
        WHILE reference_group <> NIL DO
          IF reference_group^.logically_satisfied THEN
            reference_group := reference_group^.nnext;
            CYCLE /scan_reference_group_list/
          IFEND;
          IF reference_group^.newly_created THEN
            reference_group^.newly_created := FALSE;
            reference_group_chain := reference_group^.nnext;
            WHILE reference_group_chain <> NIL DO
              reference_group_chain^.newly_created := FALSE;
              reference_group_chain := reference_group_chain^.nnext;
            WHILEND;
            reference_group := reference_group^.nnext;
            unsatisfied_reference^.library_searched := 0;
            another_scan_required := TRUE;
            CYCLE /scan_reference_group_list/
          IFEND;
          IF NOT entry_point_found THEN
            reference_group := reference_group^.nnext;
            CYCLE /scan_reference_group_list/
          IFEND;
          IF (reference_group^.ring >= current_library^.ring_brackets.r1) AND
                (reference_group^.ring <= current_library^.ring_brackets.r3) AND
                ((reference_group^.global_key = library_lock) OR (library_lock = loc$no_lock) OR
                (reference_group^.global_key = loc$master_key)) AND
                ((llc$gated_entry_point IN deferred_entry_points^ [entry_point_index].attributes) OR
                (reference_group^.ring <= current_library^.ring_brackets.r2)) THEN
            IF reference_group^.ring >= current_library^.ring_brackets.r2 THEN
              pseudo_module_descriptor.attributes.loaded_ring := current_library^.ring_brackets.r2;
              pseudo_module_descriptor.attributes.call_bracket := current_library^.ring_brackets.r3;
            ELSE
              pseudo_module_descriptor.attributes.loaded_ring := reference_group^.ring;
              pseudo_module_descriptor.attributes.call_bracket := reference_group^.ring;
            IFEND;

            unsatisfied_reference := unsatisfied_reference^.b_link;

            lop$define_entry_point (^pseudo_entry_definition, ^pseudo_module_descriptor,
                  ^pseudo_allocated_sections, pseudo_control_options,
                  current_library^.attributes.load_file_number, duplicate_entry_point);

            IF linkage^.unsat_references_list = NIL THEN
              RETURN;
            ELSEIF duplicate_entry_point THEN
              unsatisfied_reference := unsatisfied_reference^.f_link;
              RETURN;
            ELSE
              unsatisfied_reference := unsatisfied_reference^.f_link;
              reference_group := linkage^.unsat_references_list^.references;
            IFEND;

          ELSE
            reference_group := reference_group^.nnext;
          IFEND;
        WHILEND /scan_reference_group_list/;
      PROCEND search_deferred_entry_defs;
?? OLDTITLE, EJECT ??

      VAR
        deferred_entry_points: ^lot$deferred_entry_points,
        entry_found: boolean;

      entry_found := FALSE;
      deferred_entry_points := lov$deferred_entry_points;
      WHILE (NOT entry_found) AND (deferred_entry_points <> NIL) DO
        IF #SEGMENT (deferred_entry_points^.deferred_entry_points) = #SEGMENT (current_library^.segment) THEN
          entry_found := TRUE;
        ELSE
          deferred_entry_points := deferred_entry_points^.link;
        IFEND;
      WHILEND;

      IF entry_found THEN
        WHILE unsatisfied_reference <> lov$head_of_unsat_ref_list DO
          search_deferred_entry_defs (deferred_entry_points^.deferred_entry_points);
          unsatisfied_reference := unsatisfied_reference^.f_link;
        WHILEND;
      IFEND;
    PROCEND satisfy_deferred_references;
?? OLDTITLE ??
?? NEWTITLE := 'satisfy_from_current_library', EJECT ??

    ?IF inline_procs = TRUE THEN

      PROCEDURE [INLINE] satisfy_from_current_library;

    ?ELSE

      PROCEDURE satisfy_from_current_library;

    ?IFEND

{  PURPOSE:
{    For a particular (library, external name) pair, this procedure determines if any unsatisfied
{    references to the external name can be satisfied by loading a module from the library.  If so,
{    then loading of the module is initiated.
{  NOTE:
{    The identity of the library to be examined is communicated thru the static chain.

    VAR
      references_list_head: ^^lot$unsatisfied_reference_group,
      reference_group: ^lot$unsatisfied_reference_group,
      reference_group_chain: ^lot$unsatisfied_reference_group,
      library_lock: ost$key_lock_value,
      library_file: lot$load_file,
      library_header: ^llt$object_library_header,
      library_hdr: ^llt$object_library_header_v1_0,
      linkage: ^lot$linkage_name_lists,
      object_text_descriptor: ^llt$object_text_descriptor,
      entry_point_dictionary: ^llt$entry_point_dictionary,
      number_of_entry_points: 0 .. llc$max_entry_points_in_library,
      library_dictionary: ^llt$object_library_dictionaries,
      i: 0 .. llc$max_dictionaries_on_library,
      entry_point_found: boolean,
      entry_point_gated: boolean,
      dictionary_index: 1 .. llc$max_entry_points_in_library,
      module_ring_attributes: lot$module_ring_attributes,
      module_header: ^llt$load_module_header,
      pseudo_transfer_descriptor: lot$external_descriptor,
      valid_file_position: boolean,
      module_structure_error: boolean,
      ignore_symbol_table_present: boolean;

    linkage := lov$unsatisfied_reference^.linkage_info;
    IF current_library^.attributes.key_lock.global THEN
      library_lock := current_library^.attributes.key_lock.value;
    ELSE
      library_lock := loc$no_lock;
    IFEND;
    library_file := current_library^.segment;
    RESET library_file;
    NEXT library_header IN library_file;

    IF library_header^.version = llc$object_library_version THEN
      NEXT library_dictionary: [1 .. library_header^.number_of_dictionaries] IN library_file;
      number_of_entry_points := 0;

    /find_entry_point_dictionary/
      FOR i := LOWERBOUND (library_dictionary^) TO UPPERBOUND (library_dictionary^) DO
        CASE library_dictionary^ [i].kind OF
        = llc$entry_point_dictionary =
          entry_point_dictionary := #PTR (library_dictionary^ [i].entry_point_dictionary, library_file^);
          number_of_entry_points := UPPERBOUND (entry_point_dictionary^);
          EXIT /find_entry_point_dictionary/;
        ELSE
        CASEND;
      FOREND /find_entry_point_dictionary/;

    ELSEIF library_header^.version = 'V1.0' THEN

      RESET library_file;
      NEXT library_hdr IN library_file;
      entry_point_dictionary := #PTR (library_hdr^.entry_point_dictionary, library_file^);
      number_of_entry_points := library_hdr^.number_of_entry_points;

    ELSE
    IFEND;

    IF number_of_entry_points = 0 THEN
      entry_point_dictionary := NIL;
    IFEND;

    references_list_head := ^linkage^.unsat_references_list^.references;
    reference_group := references_list_head^;

  /satisfy_each_reference_group/
    WHILE reference_group <> NIL DO
      IF reference_group^.logically_satisfied THEN
        reference_group := reference_group^.nnext;
        CYCLE /satisfy_each_reference_group/
      IFEND;
      IF reference_group^.newly_created THEN
        reference_group^.newly_created := FALSE;

{ Make sure there are no more newly created references on this reference group chain.

        reference_group_chain := reference_group^.nnext;
        WHILE reference_group_chain <> NIL DO
          reference_group_chain^.newly_created := FALSE;
          reference_group_chain := reference_group_chain^.nnext;
        WHILEND;
        reference_group := reference_group^.nnext;
        lov$unsatisfied_reference^.library_searched := 0;
        another_scan_required := TRUE;
        CYCLE /satisfy_each_reference_group/
      IFEND;
      IF (reference_group^.ring >= current_library^.ring_brackets.r1) AND
            (reference_group^.ring <= current_library^.ring_brackets.r3) AND
            ((reference_group^.global_key = library_lock) OR (library_lock = loc$no_lock) OR
            (reference_group^.global_key = loc$master_key)) THEN
        lop$search_entry_pt_dictionary (^linkage^.name, entry_point_dictionary, entry_point_found,
              entry_point_gated, dictionary_index);
        IF NOT entry_point_found THEN
          RETURN
        IFEND;
        IF entry_point_gated OR (reference_group^.ring <= current_library^.ring_brackets.r2) THEN
          reference_group^.logically_satisfied := TRUE;
          IF reference_group^.ring >= current_library^.ring_brackets.r2 THEN
            module_ring_attributes.loaded_ring := current_library^.ring_brackets.r2;
            module_ring_attributes.call_bracket := current_library^.ring_brackets.r3;
          ELSE
            module_ring_attributes.loaded_ring := reference_group^.ring;
            module_ring_attributes.call_bracket := reference_group^.ring;
          IFEND;
          module_header := #PTR (entry_point_dictionary^ [dictionary_index].module_header, library_file^);
          IF module_header = NIL THEN
            lop$report_error (lle$bad_module_header_ptr, current_library^.attributes.name, 'entry',
                  dictionary_index);
            reference_group := reference_group^.nnext;
            CYCLE /satisfy_each_reference_group/
          IFEND;
          object_text_descriptor := #PTR (module_header^.interpretive_element, library_file^);
          IF object_text_descriptor = NIL THEN
            lop$report_error (lle$bad_interpretive_elem_ptr, current_library^.attributes.name, '',
                  #OFFSET (module_header));
            reference_group := reference_group^.nnext;
            CYCLE /satisfy_each_reference_group/
          IFEND;

          RESET library_file TO object_text_descriptor;

          lov$unsatisfied_reference := lov$unsatisfied_reference^.b_link;

          lop$load_module (module_ring_attributes, current_library^.attributes, control_options, library_file,
                pseudo_transfer_descriptor, ignore_symbol_table_present, module_structure_error);

          IF linkage^.unsat_references_list = NIL THEN
            RETURN;
          ELSE
            lov$unsatisfied_reference := lov$unsatisfied_reference^.f_link;

            reference_group := linkage^.unsat_references_list^.references;
          IFEND;

          CYCLE /satisfy_each_reference_group/;
        IFEND;
      IFEND;
      reference_group := reference_group^.nnext;
    WHILEND /satisfy_each_reference_group/;
  PROCEND satisfy_from_current_library;
?? OLDTITLE, EJECT ??

  VAR
    another_scan_required: boolean,
    current_library: ^lot$library_descriptor,
    file_descriptor: lot$file_descriptor,
    first_library_on_list: boolean,
    library_number: integer,
    library_valid: boolean;

  #KEYPOINT (osk$entry, 0, lok$satisfy_externals);

  IF lov$head_of_unsat_ref_list = NIL THEN
    #KEYPOINT (osk$exit, 0, lok$satisfy_externals);
    RETURN;
  IFEND;

  IF lov$head_of_unsat_ref_list^.f_link <> lov$head_of_unsat_ref_list THEN
    REPEAT
      another_scan_required := FALSE;
      IF lov$library_list.first = NIL THEN
        lov$unsatisfied_reference := lov$head_of_unsat_ref_list^.f_link;
        lop$satisfy_task_services_refs (control_options, lov$unsatisfied_reference, another_scan_required);
      ELSE;

        current_library := lov$library_list.first;
        first_library_on_list := TRUE;
        library_number := 1;

      /library_scan/
        WHILE current_library <> NIL DO
          IF NOT current_library^.library_valid THEN
            current_library := current_library^.nnext;
            CYCLE /library_scan/;
          IFEND;

          lov$unsatisfied_reference := lov$head_of_unsat_ref_list^.f_link;

        /reference_scan/
          WHILE lov$unsatisfied_reference <> lov$head_of_unsat_ref_list DO
            IF NOT current_library^.library_open THEN
              lop$open_library (current_library^.attributes.name, file_descriptor, library_valid);
              IF NOT library_valid THEN
                current_library^.library_valid := FALSE;
                current_library := current_library^.nnext;
                CYCLE /library_scan/;
              ELSE
                IF current_library^.text_embedded_library THEN
                  bap$inhibit_implicit_detach (file_descriptor.file_identifier);
                IFEND;
                current_library^.library_open := TRUE;
                current_library^.segment := file_descriptor.segment;
                current_library^.ring_brackets := file_descriptor.ring_brackets;
                current_library^.attributes := file_descriptor.attributes;
              IFEND;
            IFEND;

            IF library_number <= lov$unsatisfied_reference^.library_searched THEN
              lov$unsatisfied_reference := lov$unsatisfied_reference^.f_link;
              CYCLE /reference_scan/;
            IFEND;

            lov$unsatisfied_reference^.library_searched := library_number;

            IF current_library^.attributes.name = loc$task_services_library_name THEN
              lop$satisfy_task_services_refs (control_options, lov$unsatisfied_reference,
                    another_scan_required);
            ELSEIF (current_library^.attributes.name (1, loc$deferred_entry_pt_lib_size) =
                  loc$deferred_entry_pt_library) THEN
              satisfy_deferred_references (control_options, lov$unsatisfied_reference, another_scan_required);
            ELSE
              satisfy_from_current_library;
              lov$unsatisfied_reference := lov$unsatisfied_reference^.f_link;
            IFEND;
          WHILEND /reference_scan/;

          IF another_scan_required THEN
            EXIT /library_scan/
          IFEND;

          current_library := current_library^.nnext;
          library_number := library_number + 1;
          first_library_on_list := FALSE;
        WHILEND /library_scan/;
      IFEND;

    UNTIL (NOT another_scan_required) OR (lov$head_of_unsat_ref_list^.f_link = lov$head_of_unsat_ref_list);
  IFEND;
  #KEYPOINT (osk$exit, 0, lok$satisfy_externals);
PROCEND lop$satisfy_externals;
?? OLDTITLE ??
MODEND lom$load_library_modules;
*DECK DECK=LOM$LOAD_MAP_GENERATION EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE : Loader : Load map generation' ??
?? NEWTITLE := '  Global declarations', EJECT ??
MODULE lom$load_map_generation;

{  PURPOSE:
{    This module is responsible for all aspects of managing and creating the load map file
{    during a program load.
?? PUSH (LISTEXT := ON) ??
*copyc amd$page_format_declarations
*copyc amt$file_identifier
*copyc clc$page_widths
*copyc fsc$file_contents
*copyc lle$loader_status_conditions
*copyc loe$map_malfunction
*copyc lot$loader_options
*copyc lot$loader_type_definitions
*copyc lot$load_map_data
*copyc oss$job_paged_literal
?? POP ??
*copyc amp$file
*copyc amp$store
*copyc clp$convert_integer_to_rjstring
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$open_display_file
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc lov$secondary_status
*copyc osp$format_message
*copyc osp$generate_message
*copyc osp$set_status_abnormal
*copyc osv$task_private_heap
*copyc pmp$cause_condition
*copyc pmp$exit
*copyc pmp$get_last_path_name
*copyc pmp$get_legible_date_time
*copyc pmp$get_os_version
?? EJECT ??

  TYPE
    lot$lm_header = (loc$lm_section_header, loc$lm_entry_header, loc$lm_xref_header, loc$lm_segment_header),
    lot$lines_per_header_text = array [lot$lm_header] of 0 .. 15,
    lot$lines_per_detail_text = array [lot$lm_code] of 0 .. 15;

*copyc LOV$LOI$NIL

  VAR
    generate_initialized: [STATIC] boolean := TRUE,
    load_map: [STATIC] clt$display_control,
    map_file_suspended: [STATIC] boolean := TRUE,
    continuous_form: [STATIC] boolean,
    narrow_format: [STATIC] boolean,
    lines_per_header_text: [STATIC] ^lot$lines_per_header_text,
    lines_per_detail_text: [STATIC] ^lot$lines_per_detail_text,
    page_header_p: [STATIC] ^string (72) := NIL,
    wide_page_header_p: [STATIC] ^string (clc$wide_page_width) := NIL,
    skeleton_module_detail_1_p: [STATIC] ^string (193) := NIL,
    skeleton_module_detail_2_p: [STATIC] ^string (126) := NIL,
    skeleton_section_detail_p: [STATIC] ^string (122) := NIL,
    skeleton_entry_detail_p: [STATIC] ^string (100) := NIL,
    skeleton_segment_detail_p: [STATIC] ^string (70) := NIL,
    skeleton_transfer_detail_p: [STATIC] ^string (83) := NIL,
    skeleton_accumulate_names_p: [STATIC] ^string (134) := NIL,
    skeleton_asis_text_p: [STATIC] ^string (72) := NIL;

  VAR
{    The following 3 arrays contain the values used to increment line_number
{    when outputing detail_text -- depending on load map format.

    continuous_increments: [READ, oss$job_paged_literal] lot$lines_per_detail_text := [0, 0, 0, 0, 0, 0, 0, 0,
      0, 0, 0, 0, 0, 0, 0],
    non_cont_wide_increments: [READ, oss$job_paged_literal] lot$lines_per_detail_text := [4, 1, 2, 1, 2, 2, 4,
      1, 1, 1, 1, 8, 0, 0, 0],
    non_cont_narrow_increments: [READ, oss$job_paged_literal] lot$lines_per_detail_text := [5, 2, 3, 1, 3, 2,
      4, 1, 1, 1, 1, 8, 0, 0, 0];

  VAR
{    The following 3 arrays contain the values used to increment line_number
{    when outputing header_text -- depending on load map format.

    continuous_header_increments: [READ, oss$job_paged_literal] lot$lines_per_header_text := [0, 0, 0, 0],
    non_cont_wide_header_increments: [READ, oss$job_paged_literal] lot$lines_per_header_text := [4, 5, 6, 6],
    non_cont_narrow_header_incremts: [READ, oss$job_paged_literal] lot$lines_per_header_text := [5, 5, 7, 6];

  VAR
{    The following is the skeleton for the page header. Carriage control is initialized during
{    load map initialization.
    page_header: [READ, oss$job_paged_literal] string (72) :=
      '                          LOAD MAP.                            PAGE',
    wide_page_header: [READ, oss$job_paged_literal] string (clc$wide_page_width) := '                       '
      CAT '                                    LOAD MAP.'
      CAT '                                                      PAGE      ';

    VAR
{    The following skeleton images define the constant portion of each type of detail text destined
{    for the load map.  Each skeleton contains the appropriate carriage control character.

      skeleton_module_detail_1: [READ, oss$job_paged_literal] string (193) := 'MODULE:                       '
        CAT '             FROM    '
        CAT '    :                                    LOADED RING:       CALL BRACKET:       GLOBAL KEY/LOCK:'
        CAT '       LOCAL KEY/LOCK:       PRIVILEGE:       ',
      skeleton_module_detail_2: [READ, oss$job_paged_literal] string (126) := '   DATE:             GENERATOR'
        CAT ':                    '
        CAT '                         COMMENTS:                                         ',
      section_detail_header: [READ, oss$job_paged_literal] string (103) := '   SECTION TYPE                  '
        CAT '  ACCESS ATTRIBUTES   LOADED ADDRESS    (16) LENGTH (10) SECTION NAME',
      skeleton_section_detail: [READ, oss$job_paged_literal] string (122) :=
        '                                                    '
        CAT '                                                                    ',
      entry_detail_header: [READ, oss$job_paged_literal] string (47) :=
        '   ENTRY POINT NAME                     ADDRESS',
      skeleton_entry_detail: [READ, oss$job_paged_literal] string (100) :=
        '                                                                                                   ',
      xref_header: [READ, oss$job_paged_literal] string (145) := 'ENTRY POINT CROSS REFERENCE MAP    ENTRY PO'
        CAT 'INT NAME                     ADDRESS                      DEFINING MODULE        REFERENCING MOD'
        CAT 'ULE(S)',
      segment_detail_header: [READ, oss$job_paged_literal] string (137) := 'ALLOCATED SEGMENT MAP    SEGMENT '
        CAT '                           GLOBAL&LOCAL    NUMBER       (16) LENGTH (10)    R1/R2     ACCESS ATT'
        CAT 'RIBUTES',
      skeleton_segment_detail: [READ, oss$job_paged_literal] string (70) :=
        '                                   (  ,  )                            ',
      skeleton_transfer_detail: [READ, oss$job_paged_literal] string (83) :=
        'TRANSFER SYMBOL :                                 TRANSFER ADDRESS:               ',
      skeleton_accumulate_names: [READ, oss$job_paged_literal] string (134) :=
        '                                                  '
        CAT '                                                                                         ',
      skeleton_asis_text: [READ, oss$job_paged_literal] string (72) := ' ',
      diagnostic_summary_header: [READ, oss$job_paged_literal] string (20) := 'DIAGNOSTIC SUMMARY: ',
      header_data_divider: [READ, oss$job_paged_literal] string (122) := '   --------------------------------'
        CAT '---------------------------------------------------------------------------------------';

?? TITLE := '  output_page_header', EJECT ??

  PROCEDURE output_page_header (VAR load_map: clt$display_control;
        new_page_number: integer;
    VAR status: ost$status);

    VAR
      length: integer;

    clp$reset_for_next_display_page (load_map, status);
    IF narrow_format THEN
      page_header_p^ (68, 5) := '     ';
      STRINGREP (page_header_p^ (68, * ), length, load_map.page_number);
      clp$put_display (load_map, page_header_p^, clc$trim, status);
    ELSE
      wide_page_header_p^ (128, 5) := '     ';
      STRINGREP (wide_page_header_p^ (128, * ), length, load_map.page_number);
      clp$put_display (load_map, wide_page_header_p^, clc$trim, status);
    IFEND;
    clp$new_display_line (load_map, 2, status);
  PROCEND output_page_header;
?? TITLE := '  [XDCL] lop$initialize_load_map', EJECT ??

  PROCEDURE [XDCL] lop$initialize_load_map (map_file: amt$local_file_name;
        map_ring_attributes: amt$ring_attributes;
    VAR status: ost$status);

*copyc LOH$INITIALIZE_LOAD_MAP

{   NOTE:
{     The load map is suspendend (map_file_suspended := TRUE) if the load map
{     is inaccessible.

    CONST
      wide_format_threshold = 126 {minimum width for wide_format} ;

    VAR
      file: clt$file,
      date: ost$date,
      time: ost$time,
      local_status: ost$status,
      suspended_message: ost$status,
      abort_status: ^ost$status;

    status.normal := TRUE;

  /loader_malfunction_shell/
    BEGIN

    /file_access_shell/
      BEGIN
        file.local_file_name := map_file;
        clp$open_display_file (file, ^output_page_header, fsc$list, map_ring_attributes,
          load_map, status);
        IF NOT status.normal THEN
          EXIT /file_access_shell/
        IFEND;
        IF (load_map.page_width > 132) THEN
          load_map.page_width := 132;
        IFEND;
        narrow_format := load_map.page_width < wide_format_threshold;
        IF load_map.page_format = amc$continuous_form THEN
          continuous_form := TRUE;
          lines_per_detail_text := ^continuous_increments;
          lines_per_header_text := ^continuous_header_increments;
          load_map.new_page_procedure := NIL;
        ELSE
          continuous_form := FALSE;
          IF narrow_format THEN
            lines_per_detail_text := ^non_cont_narrow_increments;
            lines_per_header_text := ^non_cont_narrow_header_incremts;
          ELSE
            lines_per_detail_text := ^non_cont_wide_increments;
            lines_per_header_text := ^non_cont_wide_header_increments;
          IFEND;
        IFEND;

        IF narrow_format THEN
          ALLOCATE page_header_p in osv$task_private_heap^;
          page_header_p^ := page_header;
          pmp$get_os_version (page_header_p^ (1, 22), {ignore} local_status);
        ELSE
          ALLOCATE wide_page_header_p in osv$task_private_heap^;
          wide_page_header_p^ := wide_page_header;
          pmp$get_os_version (wide_page_header_p^ (1, 22), {ignore} local_status);
        IFEND;
        pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, {ignore} local_status);
        IF narrow_format THEN
          page_header_p^ (40, 8) := date.mdy;
          page_header_p^ (50, 8) := time.hms;
        ELSE
          wide_page_header_p^ (91, 8) := date.mdy;
          wide_page_header_p^ (110, 8) := time.hms;
        IFEND;
        generate_initialized := FALSE;
        map_file_suspended := FALSE;
        IF continuous_form THEN

{ No 'PAGE #' in header.

          IF narrow_format THEN
            page_header_p^ (64, 4) := '    ';
            clp$put_display (load_map, page_header_p^, clc$trim, status);
          ELSE
            wide_page_header_p^ (123, 4) := '    ';
            clp$put_display (load_map, wide_page_header_p^, clc$trim, status);
          IFEND;
          IF NOT status.normal THEN
            EXIT /file_access_shell/;
          IFEND;
        IFEND;
        RETURN
      END /file_access_shell/;
      map_file_suspended := TRUE;
      osp$generate_message (status, local_status);
      IF local_status.normal THEN
        osp$set_status_abnormal ('LL', lle$load_map_suspended, '', suspended_message);
        osp$generate_message (suspended_message, local_status);
      IFEND;
      IF local_status.normal THEN
        RETURN
      IFEND;
    END /loader_malfunction_shell/;
    PUSH abort_status;
    pmp$cause_condition (loe$map_malfunction, ^local_status, abort_status^);
    pmp$exit (abort_status^);
  PROCEND lop$initialize_load_map;
?? TITLE := '  [XDCL] lop$generate_load_map_text', EJECT ??

  PROCEDURE [XDCL] lop$generate_load_map_text (load_map_data: lot$load_map_data);

*copyc LOH$LOAD_MAP_DATA

{  PURPOSE:
{    This procedure is responsible for the actual creation of the load map file.  Each time it
{    is called, some portion of the text which constitutes the load map is appended to the file.
{    This procedure is also responsible for conversion from loader_specific data representations
{    to textual formats.
{  NOTE:
{    The procedures nested within this procedure use the static chain to access data.

    CONST
      start_of_accumulation_line = 8;

    VAR {automatic variables}
      status: ost$status,
      error_exit_procedure: array [1 .. 1] of amt$store_item,
      window_position: 35 .. 61,
      name_length: 1 .. 32,
      listable_name: amt$local_file_name,
      message_content: ost$status_message,
      message: ^ost$status_message,
      diagnostic_line_count: ^ost$status_message_line_count,
      diagnostic_line_index: ost$status_message_line_count,
      diagnostic_line_size: ^ost$status_message_line_size,
      diagnostic_line: ^ost$status_message_line,
      severity: ost$status_severity,
      diagnostic_header_generated: boolean,
      diagnostic_summary_detail: string (38),
      converted_number: string (7),
      conversion_length: integer,
      last_character: 0 .. 41;

    VAR {STATIC variables}
      section_detail_header_listed: [STATIC] boolean,
      entry_detail_header_listed: [STATIC] boolean,
      xref_header_listed: [STATIC] boolean := FALSE,
      segment_header_listed: [STATIC] boolean := FALSE,
      accumulation_line_position: [STATIC] start_of_accumulation_line .. 135 := start_of_accumulation_line;

    VAR {ordinal to text conversions}
      privilege_table: [READ, oss$job_paged_literal] array [ost$execute_privilege] of string (6) := ['      ',
        '      ', 'LOCAL ', 'GLOBAL '],
      section_kind_table: [READ, oss$job_paged_literal] array [llt$section_kind] of string (26) := [
        'CODE                      ', 'BINDING                   ', 'WORKING_STORAGE           ',
        'COMMON_BLOCK              ', 'EXTENSIBLE_WORKING_STORAGE', 'EXTENSIBLE_COMMON_BLOCK   ',
        'LINE_TABLE_SECTION        '];


?? TITLE := '    load_map_error_exit_procedure', EJECT ??

    PROCEDURE load_map_error_exit_procedure (file_identifier: amt$file_identifier;
      VAR status {input} : ost$status);

      VAR
        local_status: ost$status,
        suspended_message: ost$status,
        abort_status: ^ost$status;

      map_file_suspended := TRUE;
      osp$generate_message (status, local_status);
      IF local_status.normal THEN
        osp$set_status_abnormal ('LL', lle$load_map_suspended, '', suspended_message);
        osp$generate_message (suspended_message, local_status);
      IFEND;
      IF local_status.normal THEN
       {EXIT lop$generate_load_map_text;
        status.normal := TRUE;
        RETURN;
      ELSE
        PUSH abort_status;
        pmp$cause_condition (loe$map_malfunction, ^local_status, abort_status^);
        pmp$exit (abort_status^);
      IFEND;
    PROCEND load_map_error_exit_procedure;
?? OLDTITLE, EJECT ??

    IF map_file_suspended THEN
      RETURN
    IFEND;
    IF NOT generate_initialized THEN
      error_exit_procedure [1].key := amc$error_exit_procedure;
      error_exit_procedure [1].error_exit_procedure := ^load_map_error_exit_procedure;
      amp$store (load_map.file_id, error_exit_procedure, status);
      IF NOT status.normal THEN
        load_map_error_exit_procedure (load_map.file_id, status);
      IFEND;
      generate_initialized := TRUE;
    IFEND;


    CASE load_map_data.code OF
    = loc$lm_module_detail_1 =
      IF skeleton_module_detail_1_p = NIL THEN
        ALLOCATE skeleton_module_detail_1_p IN osv$task_private_heap^;
        skeleton_module_detail_1_p^ := skeleton_module_detail_1;
      IFEND;
      skeleton_module_detail_1_p^ (9, 31) := load_map_data.module_name;
      skeleton_module_detail_1_p^ (49, 7) := load_map_data.file_type;
      pmp$get_last_path_name (load_map_data.file_name, listable_name, status);
      IF NOT status.normal THEN
        load_map_error_exit_procedure (load_map.file_id, status);
      IFEND;
      skeleton_module_detail_1_p^ (58, 31) := listable_name;
      clp$convert_integer_to_rjstring (load_map_data.loaded_ring, 16, FALSE, ' ', skeleton_module_detail_1_p^
            (106, 2), status);
      clp$convert_integer_to_rjstring (load_map_data.call_bracket, 16, FALSE, ' ', skeleton_module_detail_1_p^
            (126, 2), status);
      clp$convert_integer_to_rjstring (load_map_data.module_global_key_lock, 16, FALSE, ' ',
            skeleton_module_detail_1_p^ (149, 2), status);
      clp$convert_integer_to_rjstring (load_map_data.module_local_key_lock, 16, FALSE, ' ',
            skeleton_module_detail_1_p^ (171, 2), status);
      skeleton_module_detail_1_p^ (188, 6) := privilege_table [load_map_data.execute_privilege];

      IF ((load_map.line_number + lines_per_detail_text^ [loc$lm_module_detail_1]) > load_map.page_length)
            THEN
        clp$new_display_page (load_map, status);
      IFEND;
      clp$new_display_line (load_map, 2, status);
      IF narrow_format THEN
        clp$put_display (load_map, skeleton_module_detail_1_p^ (1, 39), clc$trim, status);
        clp$put_display (load_map, skeleton_module_detail_1_p^ (41, 49), clc$trim, status);
      ELSE
        clp$put_display (load_map, skeleton_module_detail_1_p^ (1, 88), clc$trim, status);
      IFEND;
      clp$put_display (load_map, skeleton_module_detail_1_p^ (90, 39), clc$trim, status);
      clp$put_display (load_map, skeleton_module_detail_1_p^ (129, 65), clc$trim, status);
      section_detail_header_listed := FALSE;
      entry_detail_header_listed := FALSE;

    = loc$lm_module_detail_2 =
      IF skeleton_module_detail_2_p = NIL THEN
        ALLOCATE skeleton_module_detail_2_p IN osv$task_private_heap^;
        skeleton_module_detail_2_p^ := skeleton_module_detail_2;
      IFEND;
      skeleton_module_detail_2_p^ (10, 10) := load_map_data.date;
      skeleton_module_detail_2_p^ (33, 40) := load_map_data.generator;
      skeleton_module_detail_2_p^ (87, 40) := load_map_data.commentary;
      IF ((load_map.line_number + lines_per_detail_text^ [loc$lm_module_detail_2]) > load_map.page_length)
            THEN
        clp$new_display_page (load_map, status);
      IFEND;
      IF narrow_format THEN
        clp$put_display (load_map, skeleton_module_detail_2_p^ (1, 72), clc$trim, status);
        clp$put_display (load_map, skeleton_module_detail_2_p^ (74, 53), clc$trim, status);
      ELSE
        clp$put_display (load_map, skeleton_module_detail_2_p^, clc$trim, status);
      IFEND;


    = loc$lm_section_detail =
      IF NOT section_detail_header_listed THEN
        section_detail_header_listed := TRUE;
        IF ((load_map.line_number + lines_per_header_text^ [loc$lm_section_header] + lines_per_detail_text^
              [loc$lm_section_detail]) > load_map.page_length) THEN
          clp$new_display_page (load_map, status);
        IFEND;
        clp$new_display_line (load_map, 2, status);
        IF narrow_format THEN
          clp$put_display (load_map, section_detail_header (1, 53), clc$trim, status);
          clp$put_display (load_map, section_detail_header (55, 49), clc$trim, status);
          clp$put_display (load_map, header_data_divider (1, 68), clc$trim, status);
        ELSE
          clp$put_display (load_map, section_detail_header, clc$trim, status);
          clp$put_display (load_map, header_data_divider, clc$trim, status);
        IFEND;
      IFEND;

      IF skeleton_section_detail_p = NIL THEN
        ALLOCATE skeleton_section_detail_p IN osv$task_private_heap^;
        skeleton_section_detail_p^:= skeleton_section_detail;
      IFEND;
      skeleton_section_detail_p^ (4, 26) := section_kind_table [load_map_data.section_kind];
      window_position := 36;
      skeleton_section_detail_p^ (window_position, 18) := '';
      IF llc$binding IN load_map_data.section_access_attributes THEN
        skeleton_section_detail_p^ (window_position, 7) := 'BINDING';
      ELSE
        IF llc$execute IN load_map_data.section_access_attributes THEN
          skeleton_section_detail_p^ (window_position, 7) := 'EXECUTE';
          window_position := window_position + 8;
        IFEND;
        IF llc$read IN load_map_data.section_access_attributes THEN
          skeleton_section_detail_p^ (window_position, 4) := 'READ';
          window_position := window_position + 5;
        IFEND;
        IF llc$write IN load_map_data.section_access_attributes THEN
          skeleton_section_detail_p^ (window_position, 5) := 'WRITE';
        IFEND;
      IFEND;
      clp$convert_integer_to_rjstring (load_map_data.section_address.segment, 16, FALSE, ' ',
            skeleton_section_detail_p^ (58, 3), status);
      clp$convert_integer_to_rjstring (load_map_data.section_address.offset, 16, FALSE, ' ',
            skeleton_section_detail_p^ (62, 8), status);
      clp$convert_integer_to_rjstring (load_map_data.section_length, 16, FALSE, ' ',
           skeleton_section_detail_p^ (71, 8), status);
      clp$convert_integer_to_rjstring (load_map_data.section_length, 10, FALSE, ' ',
           skeleton_section_detail_p^ (80, 10), status);
      skeleton_section_detail_p^ (92, 31) := load_map_data.section_name;

      IF ((load_map.line_number + lines_per_detail_text^ [loc$lm_section_detail]) > load_map.page_length) THEN
        clp$new_display_page (load_map, status);
      IFEND;
      clp$new_display_line (load_map, 1, status);
      IF narrow_format THEN
        clp$put_display (load_map, skeleton_section_detail_p^ (1, 53), clc$trim, status);
        clp$put_display (load_map, skeleton_section_detail_p^ (55, 66), clc$trim, status);
      ELSE
        clp$put_display (load_map, skeleton_section_detail_p^, clc$trim, status);
      IFEND;

    = loc$lm_entry_detail =
      IF skeleton_entry_detail_p = NIL THEN
        ALLOCATE skeleton_entry_detail_p IN osv$task_private_heap^;
        skeleton_entry_detail_p^ := skeleton_entry_detail;
      IFEND;
      IF NOT entry_detail_header_listed THEN
        entry_detail_header_listed := TRUE;
        IF ((load_map.line_number + lines_per_header_text^ [loc$lm_entry_header] + lines_per_detail_text^
              [loc$lm_entry_detail]) > load_map.page_length) THEN
          clp$new_display_page (load_map, status);
        IFEND;
        clp$new_display_line (load_map, 2, status);
        clp$put_display (load_map, entry_detail_header, clc$trim, status);
        clp$put_display (load_map, header_data_divider (1, 66), clc$trim, status);
        clp$put_display (load_map, ' ', clc$trim, status);
      IFEND;

      skeleton_entry_detail_p^ (4, 31) := load_map_data.entry_name;
      skeleton_entry_detail_p^ (35, 3) := '   ';
      clp$convert_integer_to_rjstring (load_map_data.entry_address.segment, 16, FALSE, ' ',
            skeleton_entry_detail_p^ (41, 3), status);
      clp$convert_integer_to_rjstring (load_map_data.entry_address.offset, 16, FALSE, ' ',
            skeleton_entry_detail_p^ (45, 8), status);
      skeleton_entry_detail_p^ (59, 5) := load_map_data.entry_attribute;

      IF ((load_map.line_number + lines_per_detail_text^ [loc$lm_entry_detail]) > load_map.page_length) THEN
        clp$new_display_page (load_map, status);
      IFEND;
      clp$put_display (load_map, skeleton_entry_detail_p^ (1, 63), clc$trim, status);

    = loc$lm_xref_detail =
      IF skeleton_entry_detail_p = NIL THEN
        ALLOCATE skeleton_entry_detail_p IN osv$task_private_heap^;
        skeleton_entry_detail_p^ := skeleton_entry_detail;
      IFEND;
      IF NOT xref_header_listed THEN
        xref_header_listed := TRUE;
        clp$new_display_page (load_map, status);
        clp$new_display_line (load_map, 2, status);
        IF narrow_format THEN
          clp$put_display (load_map, xref_header (1, 31), clc$trim, status);
          clp$put_display (load_map, xref_header (33, 64), clc$trim, status);
          clp$put_display (load_map, xref_header (97, 21), clc$trim, status);
          clp$put_display (load_map, xref_header (118, 28), clc$trim, status);
          clp$put_display (load_map, header_data_divider (1, 66), clc$trim, status);
        ELSE
          clp$put_display (load_map, xref_header (1, 31), clc$trim, status);
          clp$put_display (load_map, xref_header (33, 85), clc$trim, status);
          clp$put_display (load_map, xref_header (118, 28), clc$trim, status);
          clp$put_display (load_map, header_data_divider (1, 120), clc$trim, status);
        IFEND;
      IFEND;

      skeleton_entry_detail_p^ (4, 31) := load_map_data.entry_name;
      clp$convert_integer_to_rjstring (load_map_data.loaded_ring_for_xref, 16, FALSE, ' ',
            skeleton_entry_detail_p^ (35, 3), status);
      clp$convert_integer_to_rjstring (load_map_data.entry_address.segment, 16, FALSE, ' ',
            skeleton_entry_detail_p^ (41, 3), status);
      clp$convert_integer_to_rjstring (load_map_data.entry_address.offset, 16, FALSE, ' ',
            skeleton_entry_detail_p^ (45, 8), status);
      skeleton_entry_detail_p^ (59, 5) := load_map_data.entry_attribute;
      skeleton_entry_detail_p^ (70, 31) := load_map_data.defining_module;

      IF ((load_map.line_number + lines_per_detail_text^ [loc$lm_xref_detail]) > load_map.page_length) THEN
        clp$new_display_page (load_map, status);
      IFEND;
      IF narrow_format THEN
        clp$put_display (load_map, skeleton_entry_detail_p^ (1, 63), clc$trim, status);
        clp$put_display (load_map, skeleton_entry_detail_p^ (65, 36), clc$trim, status);
      ELSE
        clp$put_display (load_map, skeleton_entry_detail_p^, clc$trim, status);
      IFEND;

    = loc$lm_segment_detail =
      IF skeleton_segment_detail_p = NIL THEN
        ALLOCATE skeleton_segment_detail_p IN osv$task_private_heap^;
        skeleton_segment_detail_p^ := skeleton_segment_detail;
      IFEND;
      IF NOT segment_header_listed THEN
        segment_header_listed := TRUE;
        clp$new_display_page (load_map, status);
        clp$new_display_line (load_map, 2, status);
        clp$put_display (load_map, segment_detail_header (1, 21), clc$trim, status);
        clp$put_display (load_map, segment_detail_header (23, 11), clc$trim, status);
        clp$put_display (load_map, segment_detail_header (74, 64), clc$trim, status);
        clp$put_display (load_map, header_data_divider (1, 71), clc$trim, status);
      IFEND;

      clp$convert_integer_to_rjstring (load_map_data.segment, 16, FALSE, ' ',
           skeleton_segment_detail_p^ (4, 3), status);
      clp$convert_integer_to_rjstring (load_map_data.segment_length, 16, FALSE, ' ',
           skeleton_segment_detail_p^ (13, 8), status);
      clp$convert_integer_to_rjstring (load_map_data.segment_length, 10, FALSE, ' ',
           skeleton_segment_detail_p^ (23, 10), status);
      clp$convert_integer_to_rjstring (load_map_data.r1, 16, FALSE, ' ', skeleton_segment_detail_p^ (37, 2),
            status);
      clp$convert_integer_to_rjstring (load_map_data.r2, 16, FALSE, ' ', skeleton_segment_detail_p^ (40, 2),
            status);
      clp$convert_integer_to_rjstring (load_map_data.segment_global_key_lock, 16, FALSE, ' ',
            skeleton_segment_detail_p^ (49, 2), status);
      clp$convert_integer_to_rjstring (load_map_data.segment_local_key_lock, 16, FALSE, ' ',
            skeleton_segment_detail_p^ (52, 2), status);
      window_position := 47;
      skeleton_segment_detail_p^ (window_position, 24) := '';
      IF load_map_data.stack_segment THEN
        skeleton_segment_detail_p^ (window_position, 16) := 'STACK READ WRITE';
      ELSE
        IF load_map_data.segment_access_attributes.read_privilege = osc$binding_segment THEN
          skeleton_segment_detail_p^ (window_position, 7) := 'BINDING';
        ELSE
          IF load_map_data.segment_access_attributes.execute_privilege <> osc$non_executable THEN
            skeleton_segment_detail_p^ (window_position, 7) := 'EXECUTE';
            window_position := window_position + 8;
          IFEND;
          CASE load_map_data.segment_access_attributes.read_privilege OF
          = osc$read_key_lock_controlled =
            skeleton_segment_detail_p^ (window_position, 7) := 'READ_KL';
            window_position := window_position + 8;
          = osc$read_uncontrolled =
            skeleton_segment_detail_p^ (window_position, 4) := 'READ';
            window_position := window_position + 5;
          ELSE
          CASEND;
          CASE load_map_data.segment_access_attributes.write_privilege OF
          = osc$write_key_lock_controlled =
            skeleton_segment_detail_p^ (window_position, 8) := 'WRITE_KL';
          = osc$write_uncontrolled =
            skeleton_segment_detail_p^ (window_position, 5) := 'WRITE';
          ELSE
          CASEND;
        IFEND;
      IFEND;

      clp$put_display (load_map, skeleton_segment_detail_p^, clc$trim, status);

    = loc$lm_transfer_detail =
      IF skeleton_transfer_detail_p = NIL THEN
        ALLOCATE skeleton_transfer_detail_p IN osv$task_private_heap^;
        skeleton_transfer_detail_p^ := skeleton_transfer_detail;
      IFEND;
      IF ((load_map.line_number + lines_per_detail_text^ [loc$lm_transfer_detail]) > load_map.page_length)
            THEN
        clp$new_display_page (load_map, status);
      IFEND;

      IF load_map_data.transfer_address = loc$nil THEN
        skeleton_transfer_detail_p^ (51, 32) := '                                ';
      ELSE
        clp$convert_integer_to_rjstring (load_map_data.transfer_address.ring, 16, FALSE, ' ',
              skeleton_transfer_detail_p^ (69, 1), status);
        clp$convert_integer_to_rjstring (load_map_data.transfer_address.segment, 16, FALSE, ' ',
              skeleton_transfer_detail_p^ (71, 3), status);
        clp$convert_integer_to_rjstring (load_map_data.transfer_address.offset, 16, FALSE, ' ',
              skeleton_transfer_detail_p^ (75, 8), status);
      IFEND;
      skeleton_transfer_detail_p^ (19, 31) := load_map_data.transfer_symbol;

      clp$new_display_line (load_map, 2, status);
      clp$put_display (load_map, skeleton_transfer_detail_p^ (1, 49), clc$trim, status);
      clp$put_display (load_map, skeleton_transfer_detail_p^ (51, 33), clc$trim, status);


    = loc$lm_accumulate_names =
      IF skeleton_accumulate_names_p = NIL THEN
        ALLOCATE skeleton_accumulate_names_p IN osv$task_private_heap^;
        skeleton_accumulate_names_p^ := skeleton_accumulate_names;
      IFEND;
      name_length := 31;
      WHILE load_map_data.name (name_length) = ' ' DO
        name_length := name_length - 1;
      WHILEND;
      IF accumulation_line_position + name_length > load_map.page_width THEN
        IF ((load_map.line_number + lines_per_detail_text^ [loc$lm_accumulate_names]) > load_map.page_length)
              THEN
          clp$new_display_page (load_map, status);
        IFEND;
        clp$put_display (load_map, skeleton_accumulate_names_p^ (1, accumulation_line_position - 2), clc$trim,
              status);
        accumulation_line_position := start_of_accumulation_line;
      IFEND;

      skeleton_accumulate_names_p^ (accumulation_line_position, name_length + 2) := load_map_data.name (1,
            name_length);
      accumulation_line_position := accumulation_line_position + name_length + 2;

    = loc$lm_flush_accumulated_names =
      IF skeleton_accumulate_names_p <> NIL THEN
        IF ((load_map.line_number + lines_per_detail_text^ [loc$lm_flush_accumulated_names]) > load_map.
              page_length) THEN
          clp$new_display_page (load_map, status);
        IFEND;
        clp$put_display (load_map, skeleton_accumulate_names_p^ (1, accumulation_line_position - 2), clc$trim,
              status);
      IFEND;
      accumulation_line_position := start_of_accumulation_line;

    = loc$lm_asis_text =
      IF skeleton_asis_text_p = NIL THEN
        ALLOCATE skeleton_asis_text_p IN osv$task_private_heap^;
        skeleton_asis_text_p^ := skeleton_asis_text;
      IFEND;
      IF ((load_map.line_number + (diagnostic_line_count^ * lines_per_detail_text^ [loc$lm_asis_text])) >
            load_map.page_length) THEN
        clp$new_display_page (load_map, status);
      IFEND;
      skeleton_asis_text_p^ (1, 72) := load_map_data.text;
      clp$put_display (load_map, skeleton_asis_text_p^, clc$trim, status);

    = loc$lm_issue_diagnostic =
      message := ^message_content;
      osp$format_message (load_map_data.diagnostic_status, osc$full_message_level, load_map.page_width,
            message_content, status);
      RESET message;
      NEXT diagnostic_line_count IN message;
      IF ((load_map.line_number + (diagnostic_line_count^ * lines_per_detail_text^ [loc$lm_issue_diagnostic]))
            > load_map.page_length) THEN
        clp$new_display_page (load_map, status);
      IFEND;
      FOR diagnostic_line_index := 1 TO diagnostic_line_count^ DO
        NEXT diagnostic_line_size IN message;
        NEXT diagnostic_line: [diagnostic_line_size^] IN message;
        clp$put_display (load_map, diagnostic_line^ (1, diagnostic_line_size^), clc$trim, status);
      FOREND;
      IF NOT lov$secondary_status.normal THEN
        osp$format_message (lov$secondary_status, osc$full_message_level, load_map.page_width,
              message_content, status);
        RESET message;
        NEXT diagnostic_line_count IN message;
        IF ((load_map.line_number + (diagnostic_line_count^ * lines_per_detail_text^
              [loc$lm_issue_diagnostic])) > load_map.page_length) THEN
          clp$new_display_page (load_map, status);
        IFEND;
        FOR diagnostic_line_index := 1 TO diagnostic_line_count^ DO
          NEXT diagnostic_line_size IN message;
          NEXT diagnostic_line: [diagnostic_line_size^] IN message;
          clp$put_display (load_map, diagnostic_line^ (1, diagnostic_line_size^), clc$trim, status);
        FOREND;
      IFEND;

    = loc$lm_diagnostic_summary =
      diagnostic_header_generated := FALSE;
      FOR severity := LOWERVALUE (ost$status_severity) TO UPPERVALUE (ost$status_severity) DO
        IF load_map_data.diagnostic_count [severity] <> 0 THEN
          IF NOT diagnostic_header_generated THEN
            diagnostic_header_generated := TRUE;
            IF ((load_map.line_number + lines_per_detail_text^ [loc$lm_diagnostic_summary]) > load_map.
                  page_length) THEN
              clp$new_display_page (load_map, status);
            IFEND;
            clp$new_display_line (load_map, 2, status);
            clp$put_display (load_map, diagnostic_summary_header, clc$trim, status);
          IFEND;
          STRINGREP (converted_number, conversion_length, load_map_data.diagnostic_count [severity]);
          diagnostic_summary_detail := ' ****';
          diagnostic_summary_detail (12 - conversion_length, conversion_length) := converted_number (1,
                conversion_length);
          CASE severity OF
          = osc$informative_status =
            diagnostic_summary_detail (13, 11) := 'INFORMATIVE';
            last_character := 23;
          = osc$warning_status =
            diagnostic_summary_detail (13, 7) := 'WARNING';
            last_character := 19;
          = osc$error_status =
            diagnostic_summary_detail (13, 5) := 'ERROR';
            last_character := 17;
          = osc$fatal_status =
            diagnostic_summary_detail (13, 5) := 'FATAL';
            last_character := 17;
          = osc$catastrophic_status =
            diagnostic_summary_detail (13, 12) := 'CATASTROPHIC';
            last_character := 24;
          CASEND;
          IF load_map_data.diagnostic_count [severity] = 1 THEN
            diagnostic_summary_detail (last_character + 1, 11) := ' diagnostic';
            last_character := last_character + 11;
          ELSE
            diagnostic_summary_detail (last_character + 1, 12) := ' diagnostics';
            last_character := last_character + 12;
          IFEND;
          clp$put_display (load_map, diagnostic_summary_detail (1, last_character), clc$trim, status);
        IFEND;
      FOREND;

    = loc$lm_page_header =
      IF (NOT continuous_form) AND (load_map.line_number <= 3) THEN
        clp$new_display_page (load_map, status);
      IFEND;

    = loc$lm_segment_header_init =
      segment_header_listed := FALSE;

    = loc$lm_xref_header_init =
      xref_header_listed := FALSE;

    ELSE
    CASEND;
  PROCEND lop$generate_load_map_text;
MODEND lom$load_map_generation;
*DECK DECK=LOM$MODULE_LOADER EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE : Loader : Module loader executive' ??
MODULE lom$module_loader;

{  PURPOSE:
{    This module contains the executive for controlling and coordinating the loading of a single
{    module.  It also contains components which process object text records which define the
{    structure (but not content) of the module being loaded.

{  NOTE:
{    Condition raised: LOE$ABORT_LOAD.

  ?VAR
    inline_procs: boolean := TRUE?;

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cyd$run_time_error_condition
*copyc lle$load_map_diagnostics
*copyc lle$loader_status_conditions
*copyc llt$actual_parameters
*copyc llt$formal_parameters
*copyc llt$obsolete_formal_parameters
*copyc loe$abort_load
*copyc loe$map_malfunction
*copyc llt$deferred_common_blocks
*copyc llt$deferred_entry_points
*copyc lok$keypoints
*copyc lot$deferred_common_blocks
*copyc lot$deferred_entry_points
*copyc lot$loader_options
*copyc lot$loader_type_definitions
*copyc oss$task_shared
*copyc oss$task_private
*copyc pmt$loadable_rings
?? POP ??
*copyc dbp$define_applic_identifier
*copyc dbp$define_debug_symbol_tables
*copyc dbp$define_line_address_table
*copyc dbp$define_module
*copyc dbp$define_section
*copyc dbp$define_supplemental_dtables
*copyc dbp$module_table_address
*copyc dbp$terminate_module
*copyc i#build_adaptable_array_ptr
*copyc i#build_adaptable_seq_pointer
*copyc lop$add_local_block_id
*copyc lop$add_text_embedded_libraries
*copyc lop$copy_binding_section_text
*copyc lop$define_entry_point
*copyc lop$define_formal_parameters
*copyc lop$find_common_block_definiton
*copyc lop$generate_load_map_text
*copyc lop$link_actual_parameters
*copyc lop$link_external
*copyc lop$open_library_as_predefined
*copyc lop$report_error
*copyc lop$report_secondary_error
*copyc lop$reserve_storage
*copyc lop$store_intercept_linkage
*copyc lop$store_linkage
*copyc mmp$advise_out
*copyc mmp$reserve_segment_number
*copyc mmp$set_access_selections
*copyc osp$generate_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pmp$cause_condition
*copyc pmp$continue_to_cause
*copyc pmp$establish_condition_handler
*copyc pmp$exit
*copyc pmp$get_loaded_rings
*copyc pmp$get_mainframe_attributes
*copyc pmp$position_object_library
*copyc pmp$zero_out_table
*copyc syp$advised_move_bytes

*copyc lov$apd_load
*copyc lov$loader_options
*copyc lov$loi$nil
*copyc lov$secondary_status
*copyc osv$page_size
*copyc osv$task_private_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    lov$deferred_common_blocks: [oss$task_private, XDCL] ^lot$deferred_common_blocks := NIL,
    lov$deferred_entry_points: [oss$task_private, XDCL] ^lot$deferred_entry_points := NIL,
    lov$read_write_cache_bypass: [oss$task_shared, XDCL, #GATE] boolean := FALSE,
    lov$stack_cache_bypass: [oss$task_shared, XDCL, #GATE] boolean := FALSE,
    stack_segment_attributes: [STATIC] lot$segment_attributes :=
          [[ * , osc$non_executable, osc$read_uncontrolled, osc$write_uncontrolled], * , * ,
          [FALSE, FALSE, 0], TRUE, FALSE, FALSE, FALSE],
    vector_attributes: [STATIC] array [1 .. 2] of pmt$mainframe_attribute :=
          [[pmc$mak_unknown_attribute], [pmc$mak_unknown_attribute]];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$load_module', EJECT ??

  PROCEDURE [XDCL] lop$load_module
    (    module_ring_attributes: lot$module_ring_attributes;
         file_attributes: lot$load_file_attributes;
         control_options {control} : lot$control_options;
     VAR load_file {input_output} : lot$load_file;
     VAR transfer_descriptor: lot$external_descriptor;
     VAR debug_symbol_table_present {control} : boolean;
     VAR module_structure_error {control} : boolean);

{  PURPOSE:
{    This procedure is a transaction center which obtains object text records from the load
{    file and routes each record to an appropriate procedure for processing.  It is responsible for
{    enforcing conventions on the order of object text records and the structure (but not content)
{    of each object text record.

    VAR {record templates}
      record_descriptor: ^llt$object_text_descriptor,
      identification: ^llt$identification,
      text_embedded_libraries: ^llt$libraries,
      section_definition: ^llt$section_definition,
      text: ^llt$text,
      replication: ^llt$replication,
      bit_string_insertion: ^llt$bit_string_insertion,
      entry_definition: ^llt$entry_definition,
      deferred_entry_points: ^llt$deferred_entry_points,
      deferred_common_blocks: ^llt$deferred_common_blocks,
      application_identifier: ^llt$application_identifier,
      external_linkage: ^llt$external_linkage,
      address_formulation: ^llt$address_formulation,
      transfer_symbol: ^llt$transfer_symbol,
      obsolete_formal_parameters: ^llt$obsolete_formal_parameters,
      formal_parameters: ^llt$formal_parameters,
      actual_parameters: ^llt$actual_parameters,
      binding_template: ^llt$binding_template,
      relocation: ^llt$relocation,
      ppu_absolute: ^llt$ppu_absolute,
      obsolete_line_address_table: ^llt$obsolete_line_address_table,
      line_address_table: ^llt$line_address_table,
      cybil_debug_symbol_table: ^llt$debug_table_fragment,
      debug_symbol_table: ^llt$symbol_table,
      supplemental_debug_tables: ^llt$supplemental_debug_tables,
      obs_segment_definition: ^llt$obsolete_segment_definition,
      segment_definition: ^llt$segment_definition;

    VAR
      duplicate_entry_point: boolean,
      i: llt$section_ordinal,
      greatest_section_ordinal: llt$section_ordinal,
      allocated_sections: ^lot$allocated_sections,
      attributes: lot$module_attributes,
      module_descriptor: lot$module_descriptor,
      allotted_section_address: ^cell,
      reset_value: ^SEQ ( * ),
      valid_file_position: boolean,
      initial_ptr: ^cell,
      abort_status: ^ost$status,
      strng: string (30),
      lngth: integer;


    CONST
      c$segment_predefined = TRUE;

?? EJECT ??

    #KEYPOINT (osk$entry, 0, lok$load_module);

    module_descriptor.attributes.loaded_ring := module_ring_attributes.loaded_ring;
    module_descriptor.attributes.call_bracket := module_ring_attributes.call_bracket;
    module_descriptor.attributes.binding_section_address := loc$nil;
    IF file_attributes.key_lock.global THEN
      module_descriptor.attributes.global_key_lock := file_attributes.key_lock.value;
    ELSE
      module_descriptor.attributes.global_key_lock := loc$master_key_no_lock;
    IFEND;
    module_structure_error := FALSE;
    debug_symbol_table_present := FALSE;
    mmp$set_access_selections (load_file, mmc$as_sequential, lov$secondary_status);
    IF NOT lov$secondary_status.normal THEN
      lov$secondary_status.normal := TRUE;
      lop$report_error (lov$secondary_status.condition, '', '', 0);
    IFEND;

  /eof_shell/
    BEGIN
      NEXT record_descriptor IN load_file;
      IF (record_descriptor = NIL) OR (record_descriptor^.kind <> llc$identification) THEN
        lop$report_error (lle$identification_expected, file_attributes.name, '', #OFFSET (record_descriptor));
        module_structure_error := TRUE;
        #KEYPOINT (osk$exit, 0, lok$load_module);
        RETURN
      IFEND;
      NEXT identification IN load_file;
      IF identification = NIL THEN
        EXIT /eof_shell/
      IFEND;
      save_ptr_for_advise_out (identification, initial_ptr);
      identify_module (identification, control_options, ^file_attributes, module_descriptor,
            greatest_section_ordinal, module_structure_error);
      IF module_structure_error THEN
        #KEYPOINT (osk$exit, 0, lok$load_module);
        RETURN
      IFEND;
      PUSH allocated_sections: [0 .. greatest_section_ordinal];
      FOR i := 0 TO greatest_section_ordinal DO
        allocated_sections^ [i].address := loc$nil;
      FOREND;

    /fixer_value_shell/
      BEGIN

      /interpretive_record_processing/
        WHILE TRUE DO
          NEXT record_descriptor IN load_file;
          IF record_descriptor = NIL THEN
            EXIT /eof_shell/
          IFEND;
          CASE record_descriptor^.kind OF
          = llc$libraries =
            IF (record_descriptor^.number_of_libraries = 0) OR
                  (record_descriptor^.number_of_libraries > llc$max_libraries) THEN
              EXIT /fixer_value_shell/
            IFEND;
            NEXT text_embedded_libraries: [1 .. record_descriptor^.number_of_libraries] IN load_file;
            IF text_embedded_libraries = NIL THEN
              EXIT /eof_shell/
            IFEND;
            lop$add_text_embedded_libraries (text_embedded_libraries);

          = llc$section_definition, llc$unallocated_common_block =
            NEXT section_definition IN load_file;
            IF section_definition = NIL THEN
              EXIT /eof_shell/
            IFEND;
            define_section (section_definition, ^module_descriptor, ^file_attributes, FALSE, NIL,
                  control_options, (NOT c$segment_predefined), 0, loc$no_shadow, 0,
                  (record_descriptor^.kind = llc$unallocated_common_block), allocated_sections^);

            IF section_definition^.kind = llc$binding_section THEN
              module_descriptor.attributes.binding_section_address :=
                    allocated_sections^ [section_definition^.section_ordinal].address;
            IFEND;

          = llc$allotted_section_definition =
            NEXT section_definition IN load_file;
            IF section_definition = NIL THEN
              EXIT /eof_shell/;
            IFEND;
            reset_value := load_file;
            pmp$position_object_library (load_file, record_descriptor^.allotted_section, valid_file_position);
            IF valid_file_position THEN
              NEXT allotted_section_address IN load_file;
              load_file := reset_value;
            IFEND;
            IF NOT valid_file_position OR (allotted_section_address = NIL) THEN
              lop$report_error (lle$bad_allotted_section_ptr, identification^.name, '',
                    #OFFSET (record_descriptor));
              #KEYPOINT (osk$exit, 0, lok$load_module);
              RETURN;
            IFEND;
            define_section (section_definition, ^module_descriptor, ^file_attributes, TRUE,
                  allotted_section_address, control_options, (NOT c$segment_predefined), 0, loc$no_shadow, 0,
                  FALSE, allocated_sections^);

          = llc$segment_definition =
            NEXT segment_definition IN load_file;
            IF segment_definition = NIL THEN
              EXIT /eof_shell/
            IFEND;

            define_section (^segment_definition^.section_definition, ^module_descriptor, ^file_attributes,
                  FALSE, NIL, control_options, c$segment_predefined, segment_definition^.segment_number,
                  loc$no_shadow, segment_definition^.binding_section_offset, FALSE, allocated_sections^);

            IF segment_definition^.section_definition.kind = llc$binding_section THEN
              module_descriptor.attributes.binding_section_address :=
                    allocated_sections^ [segment_definition^.section_definition.section_ordinal].address;
            IFEND;

          = llc$allotted_segment_definition =
            NEXT segment_definition IN load_file;
            IF segment_definition = NIL THEN
              EXIT /eof_shell/;
            IFEND;

            reset_value := load_file;
            pmp$position_object_library (load_file, record_descriptor^.allotted_segment, valid_file_position);
            IF valid_file_position THEN
              NEXT allotted_section_address IN load_file;
              load_file := reset_value;
            IFEND;
            IF NOT valid_file_position OR (allotted_section_address = NIL) THEN
              lop$report_error (lle$bad_allotted_section_ptr, identification^.name, '',
                    #OFFSET (record_descriptor));
              #KEYPOINT (osk$exit, 0, lok$load_module);
              RETURN;
            IFEND;

            define_section (^segment_definition^.section_definition, ^module_descriptor, ^file_attributes,
                  TRUE, allotted_section_address, control_options, c$segment_predefined,
                  segment_definition^.segment_number, record_descriptor^.allotted_segment_length,
                  segment_definition^.binding_section_offset, FALSE, allocated_sections^);

          = llc$obsolete_segment_definition =
            NEXT obs_segment_definition IN load_file;
            IF obs_segment_definition = NIL THEN
              EXIT /eof_shell/
            IFEND;

            define_section (^obs_segment_definition^.section_definition, ^module_descriptor, ^file_attributes,
                  FALSE, NIL, control_options, c$segment_predefined, obs_segment_definition^.segment_number,
                  loc$no_shadow, 0, FALSE, allocated_sections^);

            IF obs_segment_definition^.section_definition.kind = llc$binding_section THEN
              module_descriptor.attributes.binding_section_address :=
                    allocated_sections^ [obs_segment_definition^.section_definition.section_ordinal].address;
            IFEND;

          = llc$obsolete_allotted_seg_def =
            NEXT obs_segment_definition IN load_file;
            IF obs_segment_definition = NIL THEN
              EXIT /eof_shell/;
            IFEND;

            reset_value := load_file;
            pmp$position_object_library (load_file, record_descriptor^.allotted_segment, valid_file_position);
            IF valid_file_position THEN
              NEXT allotted_section_address IN load_file;
              load_file := reset_value;
            IFEND;
            IF NOT valid_file_position OR (allotted_section_address = NIL) THEN
              lop$report_error (lle$bad_allotted_section_ptr, identification^.name, '',
                    #OFFSET (record_descriptor));
              #KEYPOINT (osk$exit, 0, lok$load_module);
              RETURN;
            IFEND;

            define_section (^obs_segment_definition^.section_definition, ^module_descriptor, ^file_attributes,
                  TRUE, allotted_section_address, control_options, c$segment_predefined,
                  obs_segment_definition^.segment_number, record_descriptor^.allotted_segment_length, 0,
                  FALSE, allocated_sections^);

          = llc$application_identifier =
            NEXT application_identifier IN load_file;
            IF application_identifier = NIL THEN
              EXIT /eof_shell/
            IFEND;
            dbp$define_applic_identifier (application_identifier, lov$secondary_status);
            IF NOT lov$secondary_status.normal THEN
              lov$secondary_status.normal := TRUE;
              lop$report_secondary_error (lov$secondary_status);
            IFEND;

          = llc$transfer_symbol =
            NEXT transfer_symbol IN load_file;
            IF transfer_symbol = NIL THEN
              EXIT /eof_shell/
            IFEND;
            save_transfer_symbol (transfer_symbol, module_descriptor.attributes, control_options,
                  transfer_descriptor);
            mmp$set_access_selections (load_file, mmc$as_random, lov$secondary_status);
            IF NOT lov$secondary_status.normal THEN
              lov$secondary_status.normal := TRUE;
              lop$report_error (lov$secondary_status.condition, '', '', 0);
            IFEND;
            advise_out_load_module (transfer_symbol, initial_ptr);
            EXIT /interpretive_record_processing/;
          = llc$entry_definition =
            NEXT entry_definition IN load_file;
            IF entry_definition = NIL THEN
              EXIT /eof_shell/
            IFEND;
            lop$define_entry_point (entry_definition, ^module_descriptor, allocated_sections, control_options,
                  file_attributes.load_file_number, duplicate_entry_point);
          = llc$external_linkage =
            IF (record_descriptor^.number_of_ext_items = 0) OR
                  (record_descriptor^.number_of_ext_items > llc$max_ext_items) THEN
              EXIT /fixer_value_shell/
            IFEND;
            NEXT external_linkage: [1 .. record_descriptor^.number_of_ext_items] IN load_file;
            IF external_linkage = NIL THEN
              EXIT /eof_shell/
            IFEND;
            lop$link_external (external_linkage, allocated_sections, ^module_descriptor, control_options);
          = llc$address_formulation =
            IF (record_descriptor^.number_of_adr_items = 0) OR
                  (record_descriptor^.number_of_adr_items > llc$max_adr_items) THEN
              EXIT /fixer_value_shell/
            IFEND;
            NEXT address_formulation: [1 .. record_descriptor^.number_of_adr_items] IN load_file;
            IF address_formulation = NIL THEN
              EXIT /eof_shell/
            IFEND;
            form_addresses (address_formulation, module_descriptor.attributes, allocated_sections);
          = llc$text =
            IF (record_descriptor^.number_of_bytes = 0) OR (record_descriptor^.number_of_bytes >
                  osc$max_segment_length) THEN
              EXIT /fixer_value_shell/
            IFEND;
            NEXT text: [1 .. record_descriptor^.number_of_bytes] IN load_file;
            IF text = NIL THEN
              EXIT /eof_shell/
            IFEND;
            copy_text (text, allocated_sections);
          = llc$replication =
            IF (record_descriptor^.number_of_bytes = 0) OR (record_descriptor^.number_of_bytes >
                  osc$max_segment_length) THEN
              EXIT /fixer_value_shell/
            IFEND;
            NEXT replication: [1 .. record_descriptor^.number_of_bytes] IN load_file;
            IF replication = NIL THEN
              EXIT /eof_shell/
            IFEND;
            copy_replicated_text (replication, allocated_sections);
          = llc$bit_string_insertion =
            NEXT bit_string_insertion IN load_file;
            IF bit_string_insertion = NIL THEN
              EXIT /eof_shell/
            IFEND;
            insert_bit_string (bit_string_insertion, allocated_sections);
          = llc$obsolete_formal_parameters =
            IF (record_descriptor^.sequence_length = 0) OR (record_descriptor^.sequence_length >
                  osc$max_segment_length) THEN
              EXIT /fixer_value_shell/
            IFEND;
            NEXT obsolete_formal_parameters: [[REP record_descriptor^.sequence_length OF cell]] IN load_file;
            IF obsolete_formal_parameters = NIL THEN
              EXIT /eof_shell/
            IFEND;
          = llc$formal_parameters =
            IF (record_descriptor^.sequence_length = 0) OR (record_descriptor^.sequence_length >
                  osc$max_segment_length) THEN
              EXIT /fixer_value_shell/
            IFEND;
            NEXT formal_parameters: [[REP record_descriptor^.sequence_length OF cell]] IN load_file;
            IF formal_parameters = NIL THEN
              EXIT /eof_shell/
            IFEND;
            lop$define_formal_parameters (formal_parameters, attributes, ^module_descriptor,
                  allocated_sections, control_options);
          = llc$actual_parameters =
            IF (record_descriptor^.sequence_length = 0) OR (record_descriptor^.sequence_length >
                  osc$max_segment_length) THEN
              EXIT /fixer_value_shell/
            IFEND;
            NEXT actual_parameters: [[REP record_descriptor^.sequence_length OF cell]] IN load_file;
            IF actual_parameters = NIL THEN
              EXIT /eof_shell/
            IFEND;
            lop$link_actual_parameters (actual_parameters, ^module_descriptor, control_options);
          = llc$relocation =

{ This type of object text record contains information used only by the object library
{ generator and is simply ignored by the loader.

            IF (record_descriptor^.number_of_rel_items = 0) OR
                  (record_descriptor^.number_of_rel_items > llc$max_rel_items) THEN
              EXIT /fixer_value_shell/
            IFEND;
            NEXT relocation: [1 .. record_descriptor^.number_of_rel_items] IN load_file;
            IF relocation = NIL THEN
              EXIT /eof_shell/
            IFEND;
          = llc$binding_template =

{ This type of object text record contains information used only by the object library
{ generator and is simply ignored by the loader.

            NEXT binding_template IN load_file;
            IF binding_template = NIL THEN
              EXIT /eof_shell/
            IFEND;
          = llc$ppu_absolute =
            lop$report_error (lle$ppu_absolute_encountered, '', '', #OFFSET (record_descriptor));
            IF record_descriptor^.number_of_words > llc$max_ppu_size THEN
              EXIT /fixer_value_shell/
            IFEND;
            NEXT ppu_absolute: [0 .. record_descriptor^.number_of_words] IN load_file;
            IF ppu_absolute = NIL THEN
              EXIT /eof_shell/
            IFEND;
          = llc$identification =
            lop$report_error (lle$transfer_record_missing, module_descriptor.name, '', 0);
            RESET load_file TO record_descriptor;
            EXIT /interpretive_record_processing/;
          = llc$obsolete_line_table =
            IF (record_descriptor^.number_of_line_items = 0) THEN
              EXIT /fixer_value_shell/;
            IFEND;
            NEXT obsolete_line_address_table: [1 .. record_descriptor^.number_of_line_items] IN load_file;
            IF obsolete_line_address_table = NIL THEN
              EXIT /eof_shell/;
            IFEND;

          = llc$line_table =
            IF (record_descriptor^.number_of_line_items = 0) THEN
              EXIT /fixer_value_shell/;
            IFEND;

            NEXT line_address_table: [1 .. record_descriptor^.number_of_line_items] IN load_file;
            IF line_address_table = NIL THEN
              EXIT /eof_shell/;
            IFEND;

            IF (module_descriptor.attributes.loaded_ring >= control_options.debug_ring) THEN
              dbp$define_line_address_table (line_address_table, module_descriptor.attributes.loaded_ring,
                    lov$secondary_status);
              IF NOT lov$secondary_status.normal THEN
                lov$secondary_status.normal := TRUE;
                lop$report_secondary_error (lov$secondary_status);
              IFEND;

              debug_symbol_table_present := TRUE;
            IFEND;

          = llc$cybil_symbol_table_fragment =
            NEXT cybil_debug_symbol_table: [[REP record_descriptor^.sequence_length OF cell]] IN load_file;
            IF cybil_debug_symbol_table = NIL THEN
              EXIT /eof_shell/
            IFEND;

          = llc$symbol_table =
            NEXT debug_symbol_table: [[REP record_descriptor^.sequence_length OF cell]] IN load_file;
            IF debug_symbol_table = NIL THEN
              EXIT /eof_shell/;
            IFEND;
            IF (module_descriptor.attributes.loaded_ring >= control_options.debug_ring) THEN
              dbp$define_debug_symbol_tables (debug_symbol_table, module_descriptor.attributes.loaded_ring,
                    lov$secondary_status);
              IF NOT lov$secondary_status.normal THEN
                lov$secondary_status.normal := TRUE;
                lop$report_secondary_error (lov$secondary_status);
              IFEND;
              debug_symbol_table_present := TRUE;
            IFEND;

          = llc$supplemental_debug_tables =
            NEXT supplemental_debug_tables: [[REP record_descriptor^.sequence_length OF cell]] IN load_file;
            IF supplemental_debug_tables = NIL THEN
              EXIT /eof_shell/;
            IFEND;
            IF (module_descriptor.attributes.loaded_ring >= control_options.debug_ring) THEN
              dbp$define_supplemental_dtables (supplemental_debug_tables,
                    module_descriptor.attributes.loaded_ring, lov$secondary_status);
              IF NOT lov$secondary_status.normal THEN
                lov$secondary_status.normal := TRUE;
                lop$report_secondary_error (lov$secondary_status);
              IFEND;
              debug_symbol_table_present := TRUE;
            IFEND;

          = llc$deferred_entry_points =
            NEXT deferred_entry_points: [1 .. record_descriptor^.number_of_entry_points] IN load_file;
            IF deferred_entry_points = NIL THEN
              EXIT /eof_shell/
            IFEND;

            define_deferred_entry_points (deferred_entry_points);

          = llc$deferred_common_blocks =
            NEXT deferred_common_blocks: [1 .. record_descriptor^.number_of_common_blocks] IN load_file;
            IF deferred_common_blocks = NIL THEN
              EXIT /eof_shell/
            IFEND;

            define_deferred_common_blocks (deferred_common_blocks);

          ELSE
            lop$report_error (lle$unknown_record_kind, '', '', #OFFSET (record_descriptor));
            module_structure_error := TRUE;
            #KEYPOINT (osk$exit, 0, lok$load_module);
            RETURN
          CASEND;
        WHILEND /interpretive_record_processing/;
        #KEYPOINT (osk$exit, 0, lok$load_module);
        RETURN;
      END /fixer_value_shell/;
      lop$report_error (lle$bad_fixer_value, '', '', #OFFSET (record_descriptor));
      module_structure_error := TRUE;
      #KEYPOINT (osk$exit, 0, lok$load_module);
      RETURN
    END /eof_shell/;
    lop$report_error (lle$premature_eof, file_attributes.name, '', #OFFSET (record_descriptor));
    #KEYPOINT (osk$exit, 0, lok$load_module);
  PROCEND lop$load_module;
?? TITLE := '  [INLINE] copy_text', EJECT ??

  ?IF inline_procs = TRUE THEN

    PROCEDURE [INLINE] copy_text
  ?ELSE

    PROCEDURE copy_text
  ?IFEND
    (    text: ^llt$text;
         allocated_sections: ^lot$allocated_sections);

{  PURPOSE:
{    This procedure processes 'text' object text records. An array of bytes is copied to a specified
{    location in the loaded module.

    VAR
      target_address: lot$address,
      target_byte: ^array [1 .. * ] of 0 .. 255,
      any_code_base_ptrs_initialized: boolean,
      abort_status: ^ost$status;

    IF allocated_sections^ [text^.section_ordinal].kind = llc$binding_section THEN
      target_address := allocated_sections^ [text^.section_ordinal].address;
      target_address.offset := target_address.offset + text^.offset;
      lop$copy_binding_section_text (target_address, ^text^.byte, any_code_base_ptrs_initialized);
      IF (any_code_base_ptrs_initialized) THEN
        lop$report_error (lle$non_linkage_binding_data, 'text record', '', #OFFSET (text));
      IFEND;
    ELSE
      target_address := allocated_sections^ [text^.section_ordinal].address;
      target_address.offset := target_address.offset + text^.offset;
      i#build_adaptable_array_ptr (loc$loader_ring, target_address.segment, target_address.offset,
            UPPERBOUND (text^.byte), LOWERBOUND (text^.byte), 1, #LOC (target_byte));
      IF #SIZE (text^.byte) <= (2 * osv$page_size) THEN
        target_byte^ := text^.byte;
      ELSE
        syp$advised_move_bytes (#LOC (text^.byte), #LOC (target_byte^), #SIZE (text^.byte),
              lov$secondary_status);
        IF NOT lov$secondary_status.normal THEN
          lop$report_error (lle$unable_to_move_text, '', '', #OFFSET (target_byte));
          PUSH abort_status;
          pmp$cause_condition (loe$abort_load, NIL, abort_status^);
          pmp$exit (abort_status^);
        IFEND;
      IFEND;
    IFEND;
  PROCEND copy_text;
?? TITLE := '  [INLINE] copy_replicated_text', EJECT ??

  ?IF inline_procs = TRUE THEN

    PROCEDURE [INLINE] copy_replicated_text
  ?ELSE

    PROCEDURE copy_replicated_text
  ?IFEND
    (    replication: ^llt$replication;
         allocated_sections: ^lot$allocated_sections);

{  PURPOSE:
{    This procedure processes 'replication' object text records.  An array of bytes is copied
{    repetitively to specified locations in the loaded module.

    VAR
      i: 1 .. osc$max_segment_length,
      lower_limit: integer,
      target_address: lot$address,
      target_byte: ^array [1 .. * ] of 0 .. 255,
      upper_limit: integer,
      abort_status: ^ost$status;


    target_address := allocated_sections^ [replication^.section_ordinal].address;
    target_address.offset := target_address.offset + replication^.offset;
    lower_limit := LOWERBOUND (replication^.byte);
    upper_limit := UPPERBOUND (replication^.byte);
    FOR i := 1 TO replication^.count DO
      i#build_adaptable_array_ptr (loc$loader_ring, target_address.segment, target_address.offset,
            upper_limit, lower_limit, 1, #LOC (target_byte));
      IF #SIZE (replication^.byte) <= (2 * osv$page_size) THEN
        target_byte^ := replication^.byte;
      ELSE
        syp$advised_move_bytes (#LOC (replication^.byte), #LOC (target_byte^), #SIZE (replication^.byte),
              lov$secondary_status);
        IF NOT lov$secondary_status.normal THEN
          lop$report_error (lle$unable_to_move_text, '', '', #OFFSET (target_byte));
          PUSH abort_status;
          pmp$cause_condition (loe$abort_load, NIL, abort_status^);
          pmp$exit (abort_status^);
        IFEND;
      IFEND;
      target_address.offset := target_address.offset + replication^.increment;
    FOREND;
  PROCEND copy_replicated_text;
?? TITLE := '  [INLINE] insert_bit_string', EJECT ??

  ?IF inline_procs = TRUE THEN

    PROCEDURE [INLINE] insert_bit_string
  ?ELSE

    PROCEDURE insert_bit_string
  ?IFEND
    (    bit_string_insertion: ^llt$bit_string_insertion;
         allocated_sections: ^lot$allocated_sections);

{  PURPOSE:
{    This module processes 'bit_string_insertion' object text records.  An array of bits is copied
{    to a specified location in the loaded module.

    VAR
      target: ^packed array [0 .. 63] of 0 .. 1,
      i: 1 .. 63,
      target_address: lot$address,
      bytes_spanned: ost$segment_offset;

    target_address := allocated_sections^ [bit_string_insertion^.section_ordinal].address;
    target_address.offset := target_address.offset + bit_string_insertion^.offset;
    bytes_spanned := (bit_string_insertion^.bit_offset + bit_string_insertion^.bit_length + 7) DIV 8;
    target := #ADDRESS (loc$loader_ring, target_address.segment, target_address.offset);
    FOR i := 1 TO bit_string_insertion^.bit_length DO
      target^ [bit_string_insertion^.bit_offset + i - 1] := bit_string_insertion^.bit_string [i];
    FOREND;
  PROCEND insert_bit_string;
?? TITLE := '  [INLINE] form_addresses', EJECT ??

  ?IF inline_procs = TRUE THEN

    PROCEDURE [INLINE] form_addresses
  ?ELSE

    PROCEDURE form_addresses
  ?IFEND
    (    address_formulation: ^llt$address_formulation;
         attributes: lot$module_attributes;
         allocated_sections: ^lot$allocated_sections);

{  PURPOSE:
{    This procedure processes 'address_formulation' object text records.  A linkage (pointer) to some
{    address within the loaded module is generated at a specified location in the loaded module.

    TYPE
      valid_address_kinds = set of llt$internal_address_kind;

    VAR
      pseudo_entry_definition: lot$entry_definition,
      reference_details: lot$reference_details,
      destination_size: 0 .. 16,
      i: 1 .. llc$max_adr_items,
      j: llt$section_ordinal,
      binding_section_overwrite: boolean,
      declaration_mismatch: boolean,
      value_address_unaligned: boolean;


    reference_details.declaration_matching_required := FALSE;
    pseudo_entry_definition.attributes.global_lock := attributes.global_key_lock;
    pseudo_entry_definition.attributes.loaded_ring := attributes.loaded_ring;
    pseudo_entry_definition.attributes.call_bracket := attributes.loaded_ring;
    pseudo_entry_definition.attributes.binding_section_address := attributes.binding_section_address;
    pseudo_entry_definition.attributes.binding_section_address.ring := attributes.loaded_ring;
    IF (attributes.binding_section_address <> loc$nil) THEN
      pseudo_entry_definition.attributes.binding_section_address.offset :=
            pseudo_entry_definition.attributes.binding_section_address.offset +
            allocated_sections^ [address_formulation^.value_section].binding_section_offset;
    IFEND;
    pseudo_entry_definition.attributes.vmid := attributes.vmid;
    pseudo_entry_definition.attributes.address.ring := attributes.loaded_ring;
    pseudo_entry_definition.attributes.declaration_matching_required := FALSE;

  /form_one_address/
    FOR i := 1 TO UPPERBOUND (address_formulation^.item) DO
      CASE address_formulation^.item [i].kind OF
      = llc$external_proc =
        destination_size := 16;
      = llc$internal_proc =
        destination_size := 8;
      ELSE
        destination_size := 6;
      CASEND;
      reference_details.address := allocated_sections^ [address_formulation^.dest_section].address;
      reference_details.address.offset := reference_details.address.offset +
            address_formulation^.item [i].dest_offset;
      IF (allocated_sections^ [address_formulation^.dest_section].kind = llc$binding_section) THEN
        reference_details.binding_section_destination := TRUE;
      ELSE
        reference_details.binding_section_destination := FALSE;
      IFEND;
      reference_details.kind := address_formulation^.item [i].kind;
      pseudo_entry_definition.attributes.address := allocated_sections^ [address_formulation^.value_section].
            address;
      pseudo_entry_definition.attributes.address.offset :=
            pseudo_entry_definition.attributes.address.offset + address_formulation^.item [i].value_offset;
      IF lov$apd_flags.apd_load AND lov$apd_flags.target_text AND
            (reference_details.kind = llc$external_proc) THEN
        reference_details.in_target_text := TRUE;
        pseudo_entry_definition.attributes.in_target_text := TRUE;
        pseudo_entry_definition.attributes.block_id := allocated_sections^
              [address_formulation^.value_section].local_block_id;
        pseudo_entry_definition.attributes.instrumented := FALSE;
        lop$store_intercept_linkage (reference_details, osc$null_name, pseudo_entry_definition,
              binding_section_overwrite, declaration_mismatch, value_address_unaligned);
      ELSE
        lop$store_linkage (^reference_details, ^pseudo_entry_definition, binding_section_overwrite,
              declaration_mismatch, value_address_unaligned);
      IFEND;
      IF binding_section_overwrite THEN
        lop$report_error (lle$add_form_b_s_overwrite, '', '', #OFFSET (#LOC (address_formulation^.item [i])));
      IFEND;
      IF value_address_unaligned THEN
        lop$report_error (lle$value_address_unaligned, '', '',
              #OFFSET (#LOC (address_formulation^.item [i])));
      IFEND;
    FOREND /form_one_address/;
  PROCEND form_addresses;

?? TITLE := '  Advise out procedure', EJECT ??

  PROCEDURE [INLINE] save_ptr_for_advise_out
    (    id_ptr: ^llt$identification;
     VAR initial_ptr: ^cell);

    initial_ptr := id_ptr;

  PROCEND save_ptr_for_advise_out;




  PROCEDURE [INLINE] advise_out_load_module
    (    tra_ptr: ^llt$transfer_symbol;
         initial_ptr: ^cell);

    VAR
      first_value: 0 .. 0ffffffff(16),
      final_value: 0 .. 0ffffffff(16),
      difference: 0 .. 0ffffffff(16),
      local_status: ost$status;

    final_value := #OFFSET (tra_ptr);
    first_value := #OFFSET (initial_ptr);
    difference := final_value - first_value;

    IF difference >= (2 * osv$page_size) THEN
      mmp$advise_out (initial_ptr, difference, local_status);
      IF NOT local_status.normal THEN
        lop$report_error (local_status.condition, '', '', 0);
      IFEND;
    IFEND;

  PROCEND advise_out_load_module;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] identify_module', EJECT ??

{  PURPOSE:
{    This procedure processes the 'identification' object text record.  It extracts module
{    identification information from the object text record and causes generation of load map
{    output to identify the module being loaded and its protection environment.

  ?IF inline_procs = TRUE THEN

    PROCEDURE [INLINE] identify_module
  ?ELSE

    PROCEDURE identify_module
  ?IFEND
    (    identification: ^llt$identification;
         control_options {control} : lot$control_options;
         file_attributes: {input} ^lot$load_file_attributes;
     VAR module_descriptor {input_output} : lot$module_descriptor;
     VAR greatest_section_ordinal: llt$section_ordinal;
     VAR module_structure_error {control} : boolean);

    TYPE
      valid_languages = set of llt$module_generator;

    VAR
      abort_status: ^ost$status,
      generator_id: llt$module_generator,
      ignore_status: ost$status,
      load_map_data: lot$load_map_data;

    IF (pmc$block_map IN control_options.map) OR (pmc$entry_point_map IN control_options.map) THEN
      load_map_data.code := loc$lm_module_detail_1;
      load_map_data.module_name := identification^.name;
      IF file_attributes^.library_file THEN
        load_map_data.file_type := 'LIBRARY';
      ELSE
        load_map_data.file_type := '   FILE';
      IFEND;
      load_map_data.file_name := file_attributes^.name;
      load_map_data.loaded_ring := module_descriptor.attributes.loaded_ring;
      load_map_data.call_bracket := module_descriptor.attributes.call_bracket;
      load_map_data.module_global_key_lock := module_descriptor.attributes.global_key_lock;
      IF file_attributes^.key_lock.local THEN
        load_map_data.module_local_key_lock := file_attributes^.key_lock.value;
      ELSE
        load_map_data.module_local_key_lock := 0;
      IFEND;
      load_map_data.execute_privilege := file_attributes^.execute_privilege;
      lop$generate_load_map_text (load_map_data);
      IF pmc$block_map IN control_options.map THEN
        load_map_data.code := loc$lm_module_detail_2;
        CASE identification^.date_created.date_format OF
        = osc$mdy_date =
          load_map_data.date := identification^.date_created.mdy;
        = osc$iso_date =
          load_map_data.date := identification^.date_created.iso;
        = osc$ordinal_date =
          load_map_data.date := identification^.date_created.ordinal;
        = osc$dmy_date =
          load_map_data.date := identification^.date_created.dmy;
        ELSE
          load_map_data.date := '';
        CASEND;
        load_map_data.generator := identification^.generator_name_vers;
        load_map_data.commentary := identification^.commentary;
        lop$generate_load_map_text (load_map_data);
        IF (load_map_data.date = '') AND (identification^.date_created.date_format <> osc$month_date) THEN
          lop$report_error (lle$unknown_date_format, 'identification record', '', #OFFSET (identification));
        IFEND;
      IFEND
    IFEND;
    IF (identification^.object_text_version <> llc$object_text_version) THEN
      lop$report_error (lle$wrong_object_text_version, identification^.object_text_version,
            llc$object_text_version, 0);
      module_structure_error := TRUE;
    ELSEIF (identification^.kind <> llc$vector_virtual_state) AND
          (identification^.kind <> llc$vector_extended_state) AND
          (identification^.kind <> llc$mi_virtual_state) THEN
      lop$report_error (lle$module_wrong_kind, 'identification record', '', #OFFSET (identification));
      module_structure_error := TRUE;
    ELSEIF llc$nonexecutable IN identification^.attributes THEN
      lop$report_error (lle$module_nonexecutable, 'identification record', '', #OFFSET (identification));
      module_structure_error := TRUE;
    ELSE
      IF (identification^.kind = llc$vector_virtual_state) OR
            (identification^.kind = llc$vector_extended_state) THEN
        IF vector_attributes [1].key <> pmc$mak_vector_capability THEN
          vector_attributes [1].key := pmc$mak_vector_capability;
          vector_attributes [2].key := pmc$mak_vector_simulation;
          pmp$get_mainframe_attributes (vector_attributes, ignore_status);
        IFEND;
        IF (vector_attributes [1].vector_capability = pmc$no_vectors) AND
              (vector_attributes [2].vector_simulation = pmc$vectors_aborted) THEN
          lop$report_error (lle$model_wrong_kind, 'identification record', '', #OFFSET (identification));
          module_structure_error := TRUE;
          RETURN;
        IFEND;
      IFEND;
      module_descriptor.name := identification^.name;
      module_descriptor.attributes.vmid := osc$cyber_180_mode;
      module_descriptor.attributes.source_declaration_matching :=
            NOT (llc$object_cybil_checking IN identification^.attributes);
      greatest_section_ordinal := identification^.greatest_section_ordinal;
      IF identification^.generator_id IN -$valid_languages [] THEN
        generator_id := identification^.generator_id;
      ELSE
        generator_id := llc$unknown_generator;
        lop$report_error (lle$unknown_generator, '', '', #OFFSET (identification));
      IFEND;
      dbp$define_module (identification, generator_id, lov$secondary_status);
      IF NOT lov$secondary_status.normal THEN
        lov$secondary_status.normal := TRUE;
        lop$report_secondary_error (lov$secondary_status);
      IFEND;
    IFEND;
  PROCEND identify_module;
?? TITLE := '  define_section', EJECT ??

  PROCEDURE define_section
    (    section_definition: ^llt$section_definition;
         module_descriptor: {input} ^lot$module_descriptor;
         file_attributes: {input} ^lot$load_file_attributes;
         allotted: boolean;
         allotted_section_address: ^cell;
         control_options {control} : lot$control_options;
         segment_predefined: boolean;
         predefined_segment_number: ost$segment;
         shadow_length: ost$segment_length;
         binding_section_offset: llt$section_address_range;
         unallocated_common: boolean;
     VAR allocated_sections {input_output} : lot$allocated_sections);

{  PURPOSE:
{    This procedure processes the 'section_definition' object text record.  It is responsible
{    for allocating storage for the section within a segment which possesses appropriate
{    protection attributes.  It is also responsible for generating load map output identifying
{    the section and where it has been loaded.
{  NOTE:
{    Whenever a code section is defined, a stack segment is created if one does not already
{    exist for the ring into which the code section is loaded.

*copyc cyc$default_heap_name

*copyc lov$common_blocks
*copyc lov$apd_load
*copyc lov$binding_segment_attributes

    VAR
      previously_defined: boolean,
      inconsistent_definition: boolean,
      common_blocks_index: lot$common_blocks_index,
      shared_flag: boolean,
      segment_number: ^array [ * ] of ost$segment,
      segment_attributes: lot$segment_attributes,
      load_map_data: lot$load_map_data,
      debugger_section_descriptor: dbt$section_item,
      cybil_default_heap_size: ^ost$segment_length,
      existing_stack_segments: [STATIC] pmt$loadable_rings := $pmt$loadable_rings [],
      abort_status: ^ost$status;

?? NEWTITLE := '    [INLINE] verify_section_definition', EJECT ??

    ?IF inline_procs = TRUE THEN

      PROCEDURE [INLINE] verify_section_definition
    ?ELSE

      PROCEDURE verify_section_definition
    ?IFEND
      (    section_definition: ^llt$section_definition;
           allocated_sections: ^lot$allocated_sections;
       VAR inconsistent_definition {control} : boolean);

      TYPE
        valid_section_kinds = set of llt$section_kind;

      inconsistent_definition := FALSE;
      IF section_definition^.section_ordinal > UPPERBOUND (allocated_sections^) THEN
        lop$report_error (lle$invalid_section_ordinal, 'section definition record', '',
              #OFFSET (section_definition));
        inconsistent_definition := TRUE
      ELSE
        IF allocated_sections^ [section_definition^.section_ordinal].address <> loc$nil THEN
          lop$report_error (lle$duplicate_section_def, '', '', #OFFSET (section_definition));
          inconsistent_definition := TRUE;
        IFEND;
      IFEND;
      IF NOT (section_definition^.kind IN -$valid_section_kinds []) THEN
        lop$report_error (lle$unknown_section_kind, '', '', #OFFSET (section_definition));
        inconsistent_definition := TRUE;
      ELSE
        IF (section_definition^.kind = llc$binding_section) AND
              ((llc$write IN section_definition^.access_attributes) OR
              (llc$execute IN section_definition^.access_attributes)) THEN

{!  The following error is reported to load map too early.

          lop$report_error (lle$improper_b_s_attributes, '', '', #OFFSET (section_definition));
        IFEND;
        IF (llc$binding IN section_definition^.access_attributes) AND
              (section_definition^.kind <> llc$binding_section) THEN

{!  The following error is reported to load map too early.

          lop$report_error (lle$binding_attr_not_allowed, '', '', #OFFSET (section_definition));
        IFEND;
      IFEND;
      IF (llc$write IN section_definition^.access_attributes) AND
            (llc$execute IN section_definition^.access_attributes) THEN
        IF NOT (section_definition^.kind = llc$working_storage_section) OR
              (section_definition^.kind = llc$extensible_working_storage) THEN
          lop$report_error (lle$write_execute_section, '', '', #OFFSET (section_definition));
          inconsistent_definition := TRUE;
        IFEND;
      IFEND;
      IF section_definition^.allocation_alignment = 0 THEN
        lop$report_error (lle$section_alignment_zero, '', '', #OFFSET (section_definition));
        inconsistent_definition := TRUE;
      ELSEIF (section_definition^.kind = llc$binding_section) AND
            ((section_definition^.allocation_alignment MOD 8 + section_definition^.allocation_offset MOD 8) <>
            0) THEN
        lop$report_error (lle$binding_section_unaligned, '', '', #OFFSET (section_definition));
        inconsistent_definition := TRUE;
      IFEND;
    PROCEND verify_section_definition;
?? TITLE := '    [INLINE] create_stack_segment', EJECT ??

    ?IF inline_procs = TRUE THEN

      PROCEDURE [INLINE] create_stack_segment
    ?ELSE

      PROCEDURE create_stack_segment
    ?IFEND
      (    ring: ost$ring;
       VAR existing_stack_segments: pmt$loadable_rings);

*copyc lov$loader_options

      CONST
        stack_segment_alignment = 1,
        stack_segment_offset = 0,
        segment_not_predefined = FALSE;

      VAR
        unused_parameter: lot$address;

      IF existing_stack_segments = $pmt$loadable_rings [] THEN
        pmp$get_loaded_rings (existing_stack_segments);
        IF ring IN existing_stack_segments THEN
          RETURN
        IFEND;
      IFEND;
      existing_stack_segments := existing_stack_segments + $pmt$loadable_rings
            [module_descriptor^.attributes.loaded_ring];
      stack_segment_attributes.access_control.cache_bypass := lov$stack_cache_bypass;
      stack_segment_attributes.r1 := ring;
      stack_segment_attributes.r2 := ring;
      lop$reserve_storage (stack_segment_attributes, stack_segment_alignment, stack_segment_offset,
            segment_not_predefined, 0, loc$no_shadow_file, 0, lov$loader_options.maximum_stack_size,
            unused_parameter);
    PROCEND create_stack_segment;
?? OLDTITLE, EJECT ??

  /allocate_a_section/
    BEGIN
      verify_section_definition (section_definition, ^allocated_sections, inconsistent_definition);
      IF inconsistent_definition THEN
        RETURN
      IFEND;
      allocated_sections [section_definition^.section_ordinal].kind := section_definition^.kind;
      allocated_sections [section_definition^.section_ordinal].length := section_definition^.length;
      allocated_sections [section_definition^.section_ordinal].allotted := allotted;
      allocated_sections [section_definition^.section_ordinal].unallocated_common := FALSE;
      allocated_sections [section_definition^.section_ordinal].binding_section_offset :=
            binding_section_offset;
      allocated_sections [section_definition^.section_ordinal].segment_predefined := segment_predefined;
      IF (section_definition^.kind = llc$common_block) OR (section_definition^.kind =
            llc$extensible_common_block) THEN
        lop$find_common_block_definiton (section_definition, module_descriptor^.attributes,
              previously_defined, common_blocks_index, allocated_sections
              [section_definition^.section_ordinal].length);
        IF previously_defined THEN
          IF unallocated_common AND NOT lov$common_blocks^ [common_blocks_index].unallocated_common THEN
            lop$report_error (lle$common_attr_mismatch, section_definition^.name, '', 0);
          IFEND;

          allocated_sections [section_definition^.section_ordinal].
                address := lov$common_blocks^ [common_blocks_index].address;
          EXIT /allocate_a_section/
        IFEND;
      IFEND;
      IF section_definition^.kind = llc$binding_section THEN
        segment_attributes := binding_segment_attributes;
      ELSE
        segment_attributes.access_control.cache_bypass := FALSE;
        IF llc$execute IN section_definition^.access_attributes THEN
          segment_attributes.access_control.execute_privilege := file_attributes^.execute_privilege;
        ELSE
          segment_attributes.access_control.execute_privilege := osc$non_executable;
        IFEND;
        IF llc$read IN section_definition^.access_attributes THEN
          IF file_attributes^.key_lock.global OR file_attributes^.key_lock.local THEN
            segment_attributes.access_control.read_privilege := osc$read_key_lock_controlled;
          ELSE
            segment_attributes.access_control.read_privilege := osc$read_uncontrolled;
          IFEND;
        ELSE
          segment_attributes.access_control.read_privilege := osc$non_readable;
        IFEND;
        IF llc$write IN section_definition^.access_attributes THEN
          segment_attributes.access_control.cache_bypass := lov$read_write_cache_bypass;
          IF file_attributes^.key_lock.global OR file_attributes^.key_lock.local THEN
            segment_attributes.access_control.write_privilege := osc$write_key_lock_controlled;
          ELSE
            segment_attributes.access_control.write_privilege := osc$write_uncontrolled;
          IFEND;
        ELSE
          segment_attributes.access_control.write_privilege := osc$non_writable;
        IFEND;
        segment_attributes.r1 := module_descriptor^.attributes.loaded_ring;
        segment_attributes.r2 := module_descriptor^.attributes.loaded_ring;
        segment_attributes.key_lock := file_attributes^.key_lock;
        segment_attributes.stack := FALSE;
        segment_attributes.debug_segment := file_attributes^.debug_file;
        segment_attributes.apd_binding_segment := FALSE;
        segment_attributes.extensible := (section_definition^.kind = llc$extensible_working_storage) OR
              (section_definition^.kind = llc$extensible_common_block);
      IFEND;
      IF (allotted_section_address <> NIL) AND file_attributes^.library_file THEN
        IF NOT segment_predefined THEN
          allocated_sections [section_definition^.section_ordinal].address.ring :=
                module_descriptor^.attributes.loaded_ring;
          allocated_sections [section_definition^.section_ordinal].
                address.segment := #SEGMENT (allotted_section_address);
          allocated_sections [section_definition^.section_ordinal].
                address.offset := #OFFSET (allotted_section_address);
        ELSEIF (shadow_length = loc$no_shadow) THEN
          lop$open_library_as_predefined (file_attributes^.name, segment_attributes,
                predefined_segment_number);
          allocated_sections [section_definition^.section_ordinal].address.ring :=
                module_descriptor^.attributes.loaded_ring;
          allocated_sections [section_definition^.section_ordinal].address.segment :=
                predefined_segment_number;
          allocated_sections [section_definition^.section_ordinal].
                address.offset := #OFFSET (allotted_section_address);
        ELSE { allotted_segment with a shadow }
          lop$reserve_storage (segment_attributes, section_definition^.allocation_alignment,
                section_definition^.allocation_offset, segment_predefined, predefined_segment_number,
                allotted_section_address, shadow_length, allocated_sections
                [section_definition^.section_ordinal].length, allocated_sections
                [section_definition^.section_ordinal].address);

{ Turn off allotted for R/W so errors are not produced by addresses built in this section.

          allocated_sections [section_definition^.section_ordinal].allotted := FALSE;
        IFEND;
      ELSE
        IF NOT unallocated_common THEN
          lop$reserve_storage (segment_attributes, section_definition^.allocation_alignment,
                section_definition^.allocation_offset, segment_predefined, predefined_segment_number,
                loc$no_shadow_file, 0, allocated_sections [section_definition^.section_ordinal].length,
                allocated_sections [section_definition^.section_ordinal].address);
        ELSE
          shared_flag := FALSE;
          PUSH segment_number: [1 .. 1];
          mmp$reserve_segment_number (shared_flag, segment_number, lov$secondary_status);
          allocated_sections [section_definition^.section_ordinal].unallocated_common := TRUE;
          allocated_sections [section_definition^.section_ordinal].address.ring := segment_attributes.r1;
          allocated_sections [section_definition^.section_ordinal].address.segment := segment_number^ [1];
          allocated_sections [section_definition^.section_ordinal].address.offset := 0;
          lov$common_blocks^ [common_blocks_index].unallocated_common := TRUE;
          lov$common_blocks^ [common_blocks_index].unallocated_common_open := FALSE;
          lov$common_blocks^ [common_blocks_index].unallocated_common_segment := segment_number^ [1];
        IFEND;

        IF (section_definition^.kind = llc$common_block) OR
              (section_definition^.kind = llc$extensible_common_block) THEN
          IF NOT unallocated_common THEN
            lov$common_blocks^ [common_blocks_index].unallocated_common := FALSE;
          IFEND;
          lov$common_blocks^ [common_blocks_index].address :=
                allocated_sections [section_definition^.section_ordinal].address;
          lov$common_blocks^ [common_blocks_index].segment_access_control :=
                segment_attributes.access_control;
          IF ((section_definition^.kind = llc$extensible_common_block) AND
                (section_definition^.name = cyc$default_heap_name)) THEN
            cybil_default_heap_size := #ADDRESS (allocated_sections [section_definition^.section_ordinal].
                  address.ring, allocated_sections [section_definition^.section_ordinal].address.segment, 0);
            cybil_default_heap_size^ := allocated_sections [section_definition^.section_ordinal].length;
          IFEND;
        IFEND;
      IFEND;
      IF lov$apd_flags.apd_load AND lov$apd_flags.target_text AND
            (section_definition^.kind = llc$code_section) THEN
        lop$add_local_block_id (module_descriptor^.name, section_definition^.section_ordinal,
              section_definition^.name, allocated_sections [section_definition^.section_ordinal].
              local_block_id);
      IFEND;
      IF (section_definition^.kind = llc$code_section) AND
            NOT (module_descriptor^.attributes.loaded_ring IN existing_stack_segments) THEN
        create_stack_segment (module_descriptor^.attributes.loaded_ring, existing_stack_segments);
      IFEND;
    END /allocate_a_section/;
    IF pmc$block_map IN control_options.map THEN
      load_map_data.code := loc$lm_section_detail;
      load_map_data.section_kind := section_definition^.kind;
      load_map_data.section_address := allocated_sections [section_definition^.section_ordinal].address;
      load_map_data.section_access_attributes := section_definition^.access_attributes;
      load_map_data.section_length := section_definition^.length;
      load_map_data.section_name := section_definition^.name;
      lop$generate_load_map_text (load_map_data);
    IFEND;
    debugger_section_descriptor.kind := section_definition^.kind;
    debugger_section_descriptor.section_ordinal := section_definition^.section_ordinal;
    debugger_section_descriptor.address.ring := module_descriptor^.attributes.loaded_ring;
    debugger_section_descriptor.address.seg := allocated_sections [section_definition^.section_ordinal].
          address.segment;
    debugger_section_descriptor.address.offset := allocated_sections [section_definition^.section_ordinal].
          address.offset;
    debugger_section_descriptor.length := section_definition^.length;
    IF (section_definition^.kind = llc$code_section) AND file_attributes^.library_file THEN
      debugger_section_descriptor.segment_access_control.cache_bypass := FALSE;
      debugger_section_descriptor.segment_access_control.execute_privilege :=
            file_attributes^.execute_privilege;
      debugger_section_descriptor.segment_access_control.read_privilege := osc$read_uncontrolled;
      debugger_section_descriptor.segment_access_control.write_privilege := osc$non_writable;
    ELSEIF (section_definition^.kind = llc$common_block) OR
          (section_definition^.kind = llc$extensible_common_block) THEN
      debugger_section_descriptor.segment_access_control :=
            lov$common_blocks^ [common_blocks_index].segment_access_control;
    ELSE
      debugger_section_descriptor.segment_access_control := segment_attributes.access_control;
    IFEND;
    debugger_section_descriptor.ring.r1 := module_descriptor^.attributes.loaded_ring;
    debugger_section_descriptor.ring.r2 := module_descriptor^.attributes.loaded_ring;
    debugger_section_descriptor.ring.r3 := module_descriptor^.attributes.call_bracket;
    debugger_section_descriptor.key_lock := file_attributes^.key_lock;
    debugger_section_descriptor.name := section_definition^.name;
    dbp$define_section (debugger_section_descriptor, lov$secondary_status);
    IF NOT lov$secondary_status.normal THEN
      lov$secondary_status.normal := TRUE;
      lop$report_secondary_error (lov$secondary_status);
    IFEND;
  PROCEND define_section;
?? OLDTITLE ??
?? NEWTITLE := 'define_deferred_entry_points', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to add the deferred entry points
{   to a global table so they may be referenced if necessary during a
{   dynamic load.

  PROCEDURE define_deferred_entry_points
    (    deferred_entry_points: ^llt$deferred_entry_points);

    VAR
      entry_points: ^lot$deferred_entry_points,
      last_entry_points: ^lot$deferred_entry_points;


    ALLOCATE entry_points IN osv$task_private_heap^;
    entry_points^.deferred_entry_points := deferred_entry_points;
    entry_points^.link := NIL;

    IF lov$deferred_entry_points = NIL THEN
      lov$deferred_entry_points := entry_points;
    ELSE
      last_entry_points := lov$deferred_entry_points;
      WHILE last_entry_points^.link <> NIL DO
        last_entry_points := last_entry_points^.link;
      WHILEND;

      last_entry_points^.link := entry_points;
    IFEND;

  PROCEND define_deferred_entry_points;
?? OLDTITLE ??
?? NEWTITLE := 'define_deferred_common_blocks', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to add the deferred common blocks
{   to a global table so they may be referenced if necessary during a
{   dynamic load.

  PROCEDURE define_deferred_common_blocks
    (    deferred_common_blocks: ^llt$deferred_common_blocks);

    VAR
      common_blocks: ^lot$deferred_common_blocks,
      last_common_blocks: ^lot$deferred_common_blocks;


    ALLOCATE common_blocks IN osv$task_private_heap^;
    common_blocks^.deferred_common_blocks := deferred_common_blocks;
    common_blocks^.link := NIL;

    IF lov$deferred_common_blocks = NIL THEN
      lov$deferred_common_blocks := common_blocks;
    ELSE
      last_common_blocks := lov$deferred_common_blocks;
      WHILE last_common_blocks^.link <> NIL DO
        last_common_blocks := last_common_blocks^.link;
      WHILEND;

      last_common_blocks^.link := common_blocks;
    IFEND;

  PROCEND define_deferred_common_blocks;

?? TITLE := '  [INLINE] save_transfer_symbol', EJECT ??

  ?IF inline_procs = TRUE THEN

    PROCEDURE [INLINE] save_transfer_symbol
  ?ELSE

    PROCEDURE save_transfer_symbol
  ?IFEND
    (    transfer_symbol_record: ^llt$transfer_symbol;
         attributes: lot$module_attributes;
         control_options {control} : lot$control_options;
     VAR transfer_descriptor: lot$external_descriptor);

{  PURPOSE:
{    This procedure processes the 'transfer_symbol' object text record.  It simply records the
{    specified symbol, if any, as the most recently encountered transfer symbol.

    VAR
      abort_status: ^ost$status;

    IF transfer_symbol_record^.name <> osc$null_name THEN
      transfer_descriptor.name := transfer_symbol_record^.name;
      transfer_descriptor.reference_ring := attributes.loaded_ring;
      transfer_descriptor.global_key := attributes.global_key_lock;
    IFEND;
    dbp$terminate_module (lov$secondary_status);
    IF NOT lov$secondary_status.normal THEN
      lov$secondary_status.normal := TRUE;
      lop$report_secondary_error (lov$secondary_status);
    IFEND;
  PROCEND save_transfer_symbol;


?? TITLE := '  [XDCL] lop$reinitialize_module', EJECT ??

  PROCEDURE [XDCL] lop$reinitialize_module
    (    module_name: pmt$program_name;
     VAR status: ost$status);

*copyc loh$reinitialize_module

?? NEWTITLE := '    load_map_malfunction', EJECT ??

    PROCEDURE load_map_malfunction
      (    condition: pmt$condition;
           system_status: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

{  PURPOSE:
{     The purpose of this condition handler is to terminate the task if
{     initialize or generate load map detects an unexpected abnormal status
{     from a NOS/VE request - the task exits with the unexpected status.

      VAR
        malfunction: ^ost$status;

      malfunction := system_status;
      pmp$exit (malfunction^);
    PROCEND load_map_malfunction;
?? TITLE := '    terminate_prematurely', EJECT ??

    PROCEDURE terminate_prematurely
      (    condition: pmt$condition;
           malfunction_status: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

{   PURPOSE:
{      Circumstances may arise within the loader which cause premature termination
{      of the load process.  These circumstances are reported within the loader via
{      conditions.  This condition handler is responsible for fielding the condition;
{      reporting the abnormality; and prematurely terminating the load process.
{
{      The conditions and their meanings are:
{      1.  system conditions: the hardware detected a condition which is probably
{          caused by a loader coding error.  The specific condition is reported to
{          the output file and the task is terminated with the loader malfunctioned
{          exception code.  SEE: code for pmc$detected_uncorrected_err processing.
{      2.  segment access conditions:
{          a. mmc$sac_read_beyond_eoi, mmc$sac_segment_access_error,
{             mmc$sac_key_lock_violation, mmc$sac_ring_violation:
{             segment management detected an inconsistency which was probably
{             caused by a loader coding error.  The specific condition is reported
{             to the output file and the task is terminated with the loader
{             malfunctioned exception code.
{          b. mmc$sac_read_write_beyond_msl: user limits prevented the loader from
{             completing the load process.  The task is terminated with the
{             insufficient memory to load exception code.
{          c. mmc$sac_io_read_error: a hardware error was detected attempting to
{             read a page from a device.  The specific condition is reported to
{             the output file and the task is terminated with the premature load
{             termination exception code.
{      3.  user defined conditions:
{          a. cye$run_time_condition: the CYBIL run time checking detected an
{             error which was probably cause by a loader coding error.  The
{             specific condition is reported to the output file and the task is
{             terminated with loader malfunctioned exception code.
{          b. loe$abort_load: several constituent procedures of the loader detect
{             circumstances which prohibit continuation of the load process.  The
{             detecting procedure reports the circumstance to load map and causes
{             the loe$abort_load condition.  This condition handler terminates the
{             task with the premature load termination exception code.
{          c. loe$loader_malfunction: a constituent procedure of the loader
{             detected an inconsistency which probably was caused by a loader
{             coding error.  The detecting procedure causes the condition
{             pointing to a status variable which identifies the inconsistency.
{             This condition handler reports the identified inconsistency to
{             the output file and terminates the task with the loader malfunctioned
{             exception code.
{          d. loe$insufficient_memory: several constituent procedures of the
{             loader detect circumstances where there is not enough virtual memory
{             to complete the load process - this is generally a case of user
{             limit being exceeded.  The detecting procedure reports the shortage
{             to the load map and causes the condition.  This condition handler
{             terminates the task with insufficient memory to load exception code.
{          e. other: other user defined conditions will be continued and
{             otherwise ignored.
{          NOTE:  condition_status is used as ignore_status.
{

      VAR
        termination_descriptor: pmt$established_handler,
        cybil_error: ^ost$status,
        malfunction: ^ost$status,
        message: ost$status;

      CASE condition.selector OF
      = pmc$system_conditions =
        osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
        IF NOT (pmc$detected_uncorrected_err IN condition.system_conditions) THEN
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'PROGRAM', status);
        ELSE
          status := message;
        IFEND;
      = mmc$segment_access_condition =
        CASE condition.segment_access_condition.identifier OF
        = mmc$sac_read_beyond_eoi, mmc$sac_segment_access_error, mmc$sac_key_lock_violation,
              mmc$sac_ring_violation =
          osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'PROGRAM', status);
        = mmc$sac_read_write_beyond_msl =
          osp$set_status_abnormal ('LL', lle$insufficient_memory_to_load, '', status);
        = mmc$sac_io_read_error =
          osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$premature_load_termination, 'Program', status);
        ELSE
          osp$set_status_from_condition ('LL', condition, save_area, message, condition_status);
          osp$generate_message (message, condition_status);
          osp$set_status_abnormal ('LL', lle$premature_load_termination, 'Program', status);
        CASEND;
      = pmc$user_defined_condition =
        IF (condition.user_condition_name = cye$run_time_condition) THEN
          cybil_error := malfunction_status;
          osp$generate_message (cybil_error^, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'PROGRAM', status);
        ELSEIF (condition.user_condition_name = loe$abort_load) THEN
          osp$set_status_abnormal ('LL', lle$premature_load_termination, 'Program', status);
        ELSEIF (condition.user_condition_name = loe$loader_malfunction) THEN
          malfunction := malfunction_status;
          osp$generate_message (malfunction^, condition_status);
          osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'PROGRAM', status);
        ELSEIF (condition.user_condition_name = loe$insufficient_memory) THEN
          osp$set_status_abnormal ('LL', lle$insufficient_memory_to_load, '', status);
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          RETURN;
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        RETURN;
      CASEND;
      EXIT lop$reinitialize_module;
    PROCEND terminate_prematurely;

?? OLDTITLE, EJECT ??

    CONST
      c$segment_predefined = TRUE;

    VAR
      map_malfunction: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
            [pmc$user_defined_condition, loe$map_malfunction],
      termination_conditions: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
            [pmc$condition_combination, $pmt$condition_combination
            [pmc$system_conditions, mmc$segment_access_condition, pmc$user_defined_condition]];

    VAR {record templates}
      actual_parameters: ^llt$actual_parameters,
      address_formulation: ^llt$address_formulation,
      application_identifier: ^llt$application_identifier,
      binding_template: ^llt$binding_template,
      bit_string_insertion: ^llt$bit_string_insertion,
      cybil_debug_symbol_table: ^llt$debug_table_fragment,
      debug_symbol_table: ^llt$symbol_table,
      entry_definition: ^llt$entry_definition,
      external_linkage: ^llt$external_linkage,
      formal_parameters: ^llt$formal_parameters,
      identification: ^llt$identification,
      line_address_table: ^llt$line_address_table,
      object_text_descriptor: ^llt$object_text_descriptor,
      obsolete_formal_parameters: ^llt$obsolete_formal_parameters,
      obsolete_line_address_table: ^llt$obsolete_line_address_table,
      obsolete_segment_definition: ^llt$obsolete_segment_definition,
      relocation: ^llt$relocation,
      replication: ^llt$replication,
      section_definition: ^llt$section_definition,
      segment_definition: ^llt$segment_definition,
      supplemental_debug_tables: ^llt$supplemental_debug_tables,
      text: ^llt$text,
      text_embedded_libraries: ^llt$libraries,
      transfer_symbol: ^llt$transfer_symbol;

    VAR
      allocated_sections: ^lot$allocated_sections,
      control_options: lot$control_options,
      i: llt$section_ordinal,
      idr: ^llt$identification,
      load_file: ^SEQ ( * ),
      malfunction_descriptor: pmt$established_handler,
      module_address_table_item: ^dbt$module_address_table_item,
      module_descriptor: lot$module_descriptor,
      premature_eof: boolean,
      termination_descriptor: pmt$established_handler,
      transfer_symbol_encountered: boolean;


?? EJECT ??


    status.normal := TRUE;

    pmp$establish_condition_handler (termination_conditions, ^terminate_prematurely, ^termination_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (lov$loader_options.map <> $pmt$load_map_options [pmc$no_load_map]) THEN
      pmp$establish_condition_handler (map_malfunction, ^load_map_malfunction, ^malfunction_descriptor,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    control_options.map := lov$loader_options.map;
    module_descriptor.name := module_name;
    module_descriptor.attributes.vmid := osc$cyber_180_mode;

    module_address_table_item := dbp$module_table_address ();

    WHILE (module_address_table_item <> NIL) AND (module_name <> module_address_table_item^.name) DO
      module_address_table_item := module_address_table_item^.next_module;
    WHILEND;

    IF module_address_table_item = NIL THEN
      lop$report_error (lle$module_not_previous_loaded, module_name, '', 0);
      RETURN;
    IFEND;

    IF module_address_table_item^.reinitialization_information <> NIL THEN
      idr := module_address_table_item^.reinitialization_information;
      i#build_adaptable_seq_pointer (#RING (idr), #SEGMENT (idr), #OFFSET (idr), (osc$max_segment_length - 1),
            0, load_file);
    ELSE
      lop$report_error (lle$no_reinit_info_for_module, module_name, '', 0);
      RETURN;
    IFEND;

    RESET load_file;
    NEXT identification IN load_file;
    IF identification = NIL THEN
      lop$report_error (lle$premature_eof_on_module, module_name, '', 0);
      RETURN;
    IFEND;

    PUSH allocated_sections: [0 .. identification^.greatest_section_ordinal];
    FOR i := 0 TO identification^.greatest_section_ordinal DO
      allocated_sections^ [i].address := loc$nil;
    FOREND;

    transfer_symbol_encountered := FALSE;

    WHILE NOT transfer_symbol_encountered DO
      NEXT object_text_descriptor IN load_file;
      CASE object_text_descriptor^.kind OF
      = llc$libraries =
        NEXT text_embedded_libraries: [1 .. object_text_descriptor^.number_of_libraries] IN load_file;
        premature_eof := text_embedded_libraries = NIL;

      = llc$section_definition, llc$unallocated_common_block =
        NEXT section_definition IN load_file;
        premature_eof := section_definition = NIL;

        IF NOT premature_eof THEN
          redefine_section (module_address_table_item, section_definition, ^module_descriptor, FALSE,
                (NOT c$segment_predefined), loc$no_shadow, 0, (object_text_descriptor^.kind =
                llc$unallocated_common_block), allocated_sections^);

          IF section_definition^.kind = llc$binding_section THEN
            module_descriptor.attributes.binding_section_address :=
                  allocated_sections^ [section_definition^.section_ordinal].address;
          IFEND;
        IFEND;

      = llc$allotted_section_definition =
        NEXT section_definition IN load_file;
        premature_eof := section_definition = NIL;

        IF NOT premature_eof THEN
          redefine_section (module_address_table_item, section_definition, ^module_descriptor, TRUE,
                (NOT c$segment_predefined), loc$no_shadow, 0, FALSE, allocated_sections^);
        IFEND;

      = llc$segment_definition =
        NEXT segment_definition IN load_file;
        premature_eof := segment_definition = NIL;

        IF NOT premature_eof THEN
          redefine_section (module_address_table_item, ^segment_definition^.section_definition,
                ^module_descriptor, FALSE, c$segment_predefined, loc$no_shadow,
                segment_definition^.binding_section_offset, FALSE, allocated_sections^);

          IF segment_definition^.section_definition.kind = llc$binding_section THEN
            module_descriptor.attributes.binding_section_address :=
                  allocated_sections^ [segment_definition^.section_definition.section_ordinal].address;
          IFEND;
        IFEND;

      = llc$allotted_segment_definition =
        NEXT segment_definition IN load_file;
        premature_eof := segment_definition = NIL;

        IF NOT premature_eof THEN
          redefine_section (module_address_table_item, ^segment_definition^.section_definition,
                ^module_descriptor, TRUE, c$segment_predefined,
                object_text_descriptor^.allotted_segment_length, segment_definition^.binding_section_offset,
                FALSE, allocated_sections^);
        IFEND;

      = llc$obsolete_segment_definition =
        NEXT obsolete_segment_definition IN load_file;
        premature_eof := obsolete_segment_definition = NIL;

        IF NOT premature_eof THEN
          redefine_section (module_address_table_item, ^obsolete_segment_definition^.section_definition,
                ^module_descriptor, FALSE, c$segment_predefined, loc$no_shadow, 0, FALSE,
                allocated_sections^);

          IF obsolete_segment_definition^.section_definition.kind = llc$binding_section THEN
            module_descriptor.attributes.binding_section_address :=
                  allocated_sections^ [obsolete_segment_definition^.section_definition.section_ordinal].
                  address;
          IFEND;
        IFEND;

      = llc$obsolete_allotted_seg_def =
        NEXT obsolete_segment_definition IN load_file;
        premature_eof := obsolete_segment_definition = NIL;

        IF NOT premature_eof THEN
          redefine_section (module_address_table_item, ^obsolete_segment_definition^.section_definition,
                ^module_descriptor, TRUE, c$segment_predefined,
                object_text_descriptor^.allotted_segment_length, 0, FALSE, allocated_sections^);
        IFEND;

      = llc$application_identifier =
        NEXT application_identifier IN load_file;
        premature_eof := application_identifier = NIL;

      = llc$transfer_symbol =
        NEXT transfer_symbol IN load_file;
        transfer_symbol_encountered := TRUE;
        mmp$advise_out (module_address_table_item^.reinitialization_information,
              (#OFFSET (load_file) - #OFFSET (module_address_table_item^.reinitialization_information)),
              status);

      = llc$entry_definition =
        NEXT entry_definition IN load_file;
        premature_eof := entry_definition = NIL;

      = llc$external_linkage =
        NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN load_file;
        premature_eof := external_linkage = NIL;
        IF NOT premature_eof THEN
          link_external (external_linkage, module_address_table_item, allocated_sections, ^module_descriptor,
                control_options);
        IFEND;

      = llc$address_formulation =
        NEXT address_formulation: [1 .. object_text_descriptor^.number_of_adr_items] IN load_file;
        premature_eof := address_formulation = NIL;

        IF NOT premature_eof THEN

{ Reinitialize only writable sections that are not common blocks.

          IF (module_address_table_item^.section_item [address_formulation^.dest_section].
                segment_access_control.write_privilege <> osc$non_writable) AND
                (allocated_sections^ [address_formulation^.dest_section].kind <> llc$common_block) AND
                (allocated_sections^ [address_formulation^.dest_section].kind <>
                llc$extensible_common_block) THEN
            form_addresses (address_formulation, module_descriptor.attributes, allocated_sections);
          IFEND;
        IFEND;

      = llc$text =
        NEXT text: [1 .. object_text_descriptor^.number_of_bytes] IN load_file;
        premature_eof := text = NIL;

        IF NOT premature_eof THEN

{ Reinitialize only writable sections that are not common blocks.

          IF (module_address_table_item^.section_item [text^.section_ordinal].segment_access_control.
                write_privilege <> osc$non_writable) AND (allocated_sections^ [text^.section_ordinal].kind <>
                llc$common_block) AND (allocated_sections^ [text^.section_ordinal].kind <>
                llc$extensible_common_block) THEN
            copy_text (text, allocated_sections);
          IFEND;
        IFEND;

      = llc$replication =
        NEXT replication: [1 .. object_text_descriptor^.number_of_bytes] IN load_file;
        premature_eof := replication = NIL;

        IF NOT premature_eof THEN

{ Reinitialize only writable sections that are not common blocks.

          IF (module_address_table_item^.section_item [replication^.section_ordinal].segment_access_control.
                write_privilege <> osc$non_writable) AND (allocated_sections^ [replication^.section_ordinal].
                kind <> llc$common_block) AND (allocated_sections^ [replication^.section_ordinal].kind <>
                llc$extensible_common_block) THEN
            copy_replicated_text (replication, allocated_sections);
          IFEND;
        IFEND;

      = llc$bit_string_insertion =
        NEXT bit_string_insertion IN load_file;
        premature_eof := bit_string_insertion = NIL;

        IF NOT premature_eof THEN

{ Reinitialize only writable sections that are not common blocks.

          IF (module_address_table_item^.section_item [bit_string_insertion^.section_ordinal].
                segment_access_control.write_privilege <> osc$non_writable) AND
                (allocated_sections^ [bit_string_insertion^.section_ordinal].kind <> llc$common_block) AND
                (allocated_sections^ [bit_string_insertion^.section_ordinal].kind <>
                llc$extensible_common_block) THEN
            insert_bit_string (bit_string_insertion, allocated_sections);
          IFEND;
        IFEND;

      = llc$obsolete_formal_parameters =
        NEXT obsolete_formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN load_file;
        premature_eof := obsolete_formal_parameters = NIL;

      = llc$formal_parameters =
        NEXT formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN load_file;
        premature_eof := formal_parameters = NIL;

      = llc$actual_parameters =
        NEXT actual_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN load_file;
        premature_eof := actual_parameters = NIL;

      = llc$relocation =

{ This type of object text record contains information used only by the object library
{ generator and is simply ignored by the loader.

        NEXT relocation: [1 .. object_text_descriptor^.number_of_rel_items] IN load_file;
        premature_eof := relocation = NIL;

      = llc$binding_template =

{ This type of object text record contains information used only by the object library
{ generator and is simply ignored by the loader.

        NEXT binding_template IN load_file;
        premature_eof := binding_template = NIL;

      = llc$obsolete_line_table =
        NEXT obsolete_line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN load_file;
        premature_eof := obsolete_line_address_table = NIL;

      = llc$line_table =
        NEXT line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN load_file;
        premature_eof := line_address_table = NIL;

      = llc$cybil_symbol_table_fragment =
        NEXT cybil_debug_symbol_table: [[REP object_text_descriptor^.sequence_length OF cell]] IN load_file;
        premature_eof := cybil_debug_symbol_table = NIL;

      = llc$symbol_table =
        NEXT debug_symbol_table: [[REP object_text_descriptor^.sequence_length OF cell]] IN load_file;
        premature_eof := debug_symbol_table = NIL;

      = llc$supplemental_debug_tables =
        NEXT supplemental_debug_tables: [[REP object_text_descriptor^.sequence_length OF cell]] IN load_file;
        premature_eof := supplemental_debug_tables = NIL;

      ELSE
        lop$report_error (lle$unknown_record_kind, '', '', #OFFSET (object_text_descriptor));
        RETURN;

      CASEND;

      IF premature_eof THEN
        lop$report_error (lle$premature_eof_on_module, module_name, '', #OFFSET (object_text_descriptor));
        RETURN;

      IFEND;
    WHILEND;

  PROCEND lop$reinitialize_module;

?? TITLE := '  link_external', EJECT ??

  PROCEDURE link_external
    (    external_linkage: ^llt$external_linkage;
         module_address_table_item: ^dbt$module_address_table_item;
         allocated_sections: ^lot$allocated_sections;
         module_descriptor: ^lot$module_descriptor;
         control_options: lot$control_options);

{  PURPOSE:
{    This procedure calls LOP$LINK_EXTERNAL with any external
{    linkage items whose addresses are in a writable section.
{    IF the external linkage has more than one item, a new
{    external linkage record is built with only those items
{    that reference a writable section.

    VAR
      ext_linkage: ^llt$external_linkage,
      i: 1 .. llc$max_ext_items,
      link_index: ^array [1 .. * ] of 1 .. llc$max_ext_items,
      number_of_items: 1 .. llc$max_ext_items,
      number_of_items_to_link: 0 .. llc$max_ext_items;


    number_of_items := UPPERBOUND (external_linkage^.item);

    IF number_of_items = 1 THEN

{ Reinitialize only writable sections that are not common blocks.

      IF (module_address_table_item^.section_item [external_linkage^.item [1].section_ordinal].
            segment_access_control.write_privilege <> osc$non_writable) AND
            (allocated_sections^ [external_linkage^.item [1].section_ordinal].kind <> llc$common_block) AND
            (allocated_sections^ [external_linkage^.item [1].section_ordinal].kind <>
            llc$extensible_common_block) THEN
        lop$link_external (external_linkage, allocated_sections, module_descriptor, control_options);
      IFEND;
    ELSEIF number_of_items > 1 THEN
      number_of_items_to_link := 0;
      PUSH link_index: [1 .. number_of_items];
      FOR i := 1 TO number_of_items DO

{ Reinitialize only writable sections that are not common blocks.

        IF (module_address_table_item^.section_item [external_linkage^.item [i].section_ordinal].
              segment_access_control.write_privilege <> osc$non_writable) AND
              (allocated_sections^ [external_linkage^.item [i].section_ordinal].kind <> llc$common_block) AND
              (allocated_sections^ [external_linkage^.item [i].section_ordinal].kind <>
              llc$extensible_common_block) THEN
          number_of_items_to_link := number_of_items_to_link + 1;
          link_index^ [number_of_items_to_link] := i;
        IFEND;
      FOREND;
      IF number_of_items_to_link > 0 THEN
        PUSH ext_linkage: [1 .. number_of_items_to_link];
        ext_linkage^.name := external_linkage^.name;
        ext_linkage^.language := external_linkage^.language;
        ext_linkage^.declaration_matching_required := external_linkage^.declaration_matching_required;
        ext_linkage^.declaration_matching := external_linkage^.declaration_matching;
        FOR i := 1 TO number_of_items_to_link DO
          ext_linkage^.item [i] := external_linkage^.item [link_index^ [i]];
        FOREND;

        lop$link_external (ext_linkage, allocated_sections, module_descriptor, control_options);
      IFEND;
    IFEND;
  PROCEND link_external;

?? TITLE := '  redefine_section', EJECT ??

  PROCEDURE redefine_section
    (    module_address_table_item: ^dbt$module_address_table_item;
         section_definition: ^llt$section_definition;
         module_descriptor: ^lot$module_descriptor,
         allotted: boolean;
         segment_predefined: boolean;
         shadow_length: ost$segment_length;
         binding_section_offset: llt$section_address_range;
         unallocated_common: boolean;
     VAR allocated_sections {input_output} : lot$allocated_sections);

{  PURPOSE:
{    This procedure defines a section.  The address of the section, which
{    has already been loaded is obtained from the module address debug table.
{    If the section is writable, the space in the segment for the section is
{    initialized to the preset value.

    VAR
      space: ^cell;


    module_descriptor^.attributes.loaded_ring := module_address_table_item^.
          section_item [section_definition^.section_ordinal].address.ring;
    IF module_address_table_item^.section_item [section_definition^.section_ordinal].key_lock.global THEN
      module_descriptor^.attributes.global_key_lock := module_address_table_item^.
            section_item [section_definition^.section_ordinal].key_lock.value;
    ELSE
      module_descriptor^.attributes.global_key_lock := loc$master_key_no_lock;
    IFEND;

    allocated_sections [section_definition^.section_ordinal].kind := section_definition^.kind;
    allocated_sections [section_definition^.section_ordinal].length := section_definition^.length;
    allocated_sections [section_definition^.section_ordinal].allotted := allotted;
    allocated_sections [section_definition^.section_ordinal].unallocated_common := unallocated_common;
    allocated_sections [section_definition^.section_ordinal].binding_section_offset := binding_section_offset;
    allocated_sections [section_definition^.section_ordinal].segment_predefined := segment_predefined;

    allocated_sections [section_definition^.section_ordinal].address.ring :=
          module_address_table_item^.section_item [section_definition^.section_ordinal].address.ring;
    allocated_sections [section_definition^.section_ordinal].address.segment :=
          module_address_table_item^.section_item [section_definition^.section_ordinal].address.seg;
    allocated_sections [section_definition^.section_ordinal].address.offset :=
          module_address_table_item^.section_item [section_definition^.section_ordinal].address.offset;
    IF segment_predefined AND (shadow_length <> loc$no_shadow) THEN

{ Turn off allotted for R/W so errors are not produced by addresses built in this section.

      allocated_sections [section_definition^.section_ordinal].allotted := FALSE;
    IFEND;

{ Reinitialize only writable sections that are not common blocks.

    IF (section_definition^.kind <> llc$common_block) AND
          (section_definition^.kind <> llc$extensible_common_block) AND
          (llc$write IN section_definition^.access_attributes) THEN
      space := #ADDRESS (allocated_sections [section_definition^.section_ordinal].address.ring,
            allocated_sections [section_definition^.section_ordinal].
            address.segment, allocated_sections [section_definition^.section_ordinal].address.offset);
      reset_preset (space, allocated_sections [section_definition^.section_ordinal].length);
    IFEND;

  PROCEND redefine_section;

?? TITLE := '  reset_preset', EJECT ??


  PROCEDURE reset_preset
    (    space: ^cell;
         total_bytes: integer);

{  PURPOSE:
{    This procedure initializes an area specified by the parameters SPACE and
{    TOTAL_BYTES to the preset value.

    CONST
      word_size = 8;

    TYPE
      preset_converter = record
        case boolean of
        = TRUE =
          value: integer,
        = FALSE =
          bytes: array [1 .. word_size] of 0 .. 0ff(16),
        casend,
      recend;

    VAR
      byte: ^0 .. 0ff(16),
      fill: ^array [1 .. * ] of integer,
      i: ost$segment_length,
      leading_bytes: 0 .. word_size - 1,
      length: integer,
      number_of_words: ost$segment_length,
      preset: preset_converter,
      sequence_pointer: ^SEQ ( * ),
      trailing_bytes: 0 .. word_size;


    IF lov$loader_options.preset = 0 THEN
      pmp$zero_out_table (space, total_bytes);

    ELSE
      preset.value := lov$loader_options.preset;
      leading_bytes := #OFFSET (space) MOD word_size;
      length := total_bytes;
      i#build_adaptable_seq_pointer (#RING (space), #SEGMENT (space), #OFFSET (space),
            total_bytes, 0, sequence_pointer);

      RESET sequence_pointer;
      IF leading_bytes <> 0 THEN
        FOR i := leading_bytes + 1 TO word_size DO
          NEXT byte IN sequence_pointer;
          byte^ := preset.bytes [i];
        FOREND;
        length := length - word_size + leading_bytes;
      IFEND;

      number_of_words := length DIV word_size;
      trailing_bytes := length MOD word_size;

      NEXT fill: [1 .. number_of_words] IN sequence_pointer;
      FOR i := 1 TO number_of_words DO
        fill^ [i] := preset.value;
      FOREND;

      FOR i := 1 TO trailing_bytes DO
        NEXT byte IN sequence_pointer;
        byte^ := preset.bytes [i];
      FOREND;
    IFEND;
  PROCEND reset_preset;
MODEND lom$module_loader;
*DECK DECK=LOM$PROGRAM_LOAD_LIEUTENANTS EXPAND=TRUE
?? 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;
*DECK DECK=LOM$PROGRAM_SEGMENT_MANAGEMENT EXPAND=TRUE
?? 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;
*DECK DECK=LOM$TASK_SERVICES_DEF_MATCHING EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Loader : Task services definition matching' ??
MODULE lom$task_services_def_matching;

{  PURPOSE:
{    This module is responsible for satisfying externals from the TASK_SERVICES "library".  This module
{    must interface with System Generation components to obtain the definition of this library.
{    Satisfying externals from the TASK_SERVICES library is different from object library processing
{    in that no actual loading need be performed -- the pre-loaded task services entry points are
{    simply made known to the loaded program as needed.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc lot$loader_options
*copyc lot$loader_type_definitions
*copyc lot$task_services_entry_point
?? POP ??
*copyc lop$define_entry_point
*copyc lov$head_of_unsat_ref_list
*copyc lov$enable_source_type_checking
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  ?VAR
    inline_procs: boolean := TRUE?;

  VAR
    lov$task_services_entry_points: [XDCL] ^array [ * ] of lot$task_services_entry_point;

?? OLDTITLE ??
?? NEWTITLE := 'find_task_services_entry_point', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to find an entry point with the given name in the
{   array of task services entry points.

  PROCEDURE find_task_services_entry_point
    (    linkage_name: {input} ^pmt$program_name;
     VAR entry_point_found {control} : boolean;
     VAR dictionary_index: integer);

    VAR
      temp: integer,
      lower: integer,
      upper: integer;

    lower := LOWERBOUND (lov$task_services_entry_points^);
    upper := UPPERBOUND (lov$task_services_entry_points^);

  /binary_search/
    WHILE lower <= upper DO
      temp := lower + upper;
      dictionary_index := temp DIV 2;
      IF linkage_name^ = lov$task_services_entry_points^ [dictionary_index].name THEN
        entry_point_found := TRUE;
        RETURN
      ELSE
        IF linkage_name^ > lov$task_services_entry_points^ [dictionary_index].name THEN
          lower := dictionary_index + 1;
        ELSE
          upper := dictionary_index - 1;
        IFEND;
      IFEND;
    WHILEND /binary_search/;
    entry_point_found := FALSE;
  PROCEND find_task_services_entry_point;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] lop$satisfy_task_services_refs', EJECT ??

{  PURPOSE:
{    This procedure is responsible for determining if any unsatisfied external references can be
{    satisfied by task services entry points.  If a task service entry point can satisfy some
{    unsatisfied external reference, then the task service entry point is "defined" within the context
{    of the loaded program.
{  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.

  PROCEDURE [XDCL] lop$satisfy_task_services_refs
    (    control_options {control} : lot$control_options;
     VAR unsatisfied_reference: ^lot$unsatisfied_reference_list;
     VAR another_scan_required: boolean);

?? NEWTITLE := '    [INLINE] search_task_services_defs' ??

    ?IF inline_procs = TRUE THEN

      PROCEDURE [INLINE] search_task_services_defs;

    ?ELSE

      PROCEDURE search_task_services_defs;

    ?IFEND

    VAR
      duplicate_entry_point: boolean,
      linkage: ^lot$linkage_name_lists,
      references_list_head: ^^lot$unsatisfied_reference_group,
      reference_group: ^lot$unsatisfied_reference_group,
      reference_group_chain: ^lot$unsatisfied_reference_group,
      pseudo_entry_definition: llt$entry_definition,
      pseudo_module_descriptor: lot$module_descriptor,
      pseudo_allocated_sections: array [0 .. 1] of lot$section_allocation,
      pseudo_control_options: lot$control_options,
      i: integer,
      debug_entry_point: boolean,
      entry_point_found: boolean;

    linkage := unsatisfied_reference^.linkage_info;

    debug_entry_point := FALSE;
    find_task_services_entry_point (^linkage^.name, entry_point_found, i);
    references_list_head := ^linkage^.unsat_references_list^.references;
    reference_group := references_list_head^;

    IF entry_point_found THEN
      pseudo_entry_definition.section_ordinal := 0;
      pseudo_entry_definition.offset := 0;
      IF lov$task_services_entry_points^ [i].gated THEN
        pseudo_entry_definition.attributes := $llt$entry_point_attributes [llc$gated_entry_point];
      ELSE
        pseudo_entry_definition.attributes := $llt$entry_point_attributes [];
      IFEND;
      pseudo_entry_definition.name := lov$task_services_entry_points^ [i].name;
      pseudo_entry_definition.language := lov$task_services_entry_points^ [i].language;
      pseudo_entry_definition.declaration_matching_required :=
            lov$task_services_entry_points^ [i].declaration_matching_required;
      pseudo_entry_definition.declaration_matching := lov$task_services_entry_points^ [i].
            declaration_matching;
      pseudo_module_descriptor.name := 'TASK_SERVICES';

{!  When SYSTEM GENERATOR supports debug_procedure field.
{!          IF lov$task_services_entry_points^ [i].debug_procedure THEN

      IF (pseudo_entry_definition.name = 'DBP$BEGIN_DEBUG') OR (pseudo_entry_definition.name = 'DBP$DEBUG') OR
            (pseudo_entry_definition.name = 'DBP$END_DEBUG') THEN
        pseudo_module_descriptor.attributes.loaded_ring := lov$task_services_entry_points^ [i].r1;
        IF lov$task_services_entry_points^ [i].gated THEN
          pseudo_module_descriptor.attributes.call_bracket := lov$task_services_entry_points^ [i].r3;
        ELSE
          pseudo_module_descriptor.attributes.call_bracket := lov$task_services_entry_points^ [i].r2;
        IFEND;
        debug_entry_point := TRUE;
      IFEND;
      pseudo_module_descriptor.attributes.global_key_lock := lov$task_services_entry_points^ [i].global_lock;
      pseudo_module_descriptor.attributes.binding_section_address :=
            lov$task_services_entry_points^ [i].binding_section_address;
      pseudo_module_descriptor.attributes.vmid := lov$task_services_entry_points^ [i].vmid;
      pseudo_module_descriptor.attributes.source_declaration_matching := lov$enable_source_type_checking;
      pseudo_allocated_sections [0].kind := llc$code_section;
      pseudo_allocated_sections [0].address := lov$task_services_entry_points^ [i].address;
      pseudo_allocated_sections [0].binding_section_offset := 0;
      pseudo_allocated_sections [0].length := osc$maximum_offset;
      pseudo_allocated_sections [1].length := osc$maximum_offset;
      pseudo_control_options.map := control_options.map * $pmt$load_map_options [pmc$entry_point_xref];
      pseudo_control_options.debug_ring := control_options.debug_ring;
    IFEND;

  /scan_reference_group_list/
    WHILE reference_group <> NIL DO
      IF reference_group^.logically_satisfied THEN
        reference_group := reference_group^.nnext;
        CYCLE /scan_reference_group_list/
      IFEND;
      IF reference_group^.newly_created THEN
        reference_group^.newly_created := FALSE;
        reference_group_chain := reference_group^.nnext;
        WHILE reference_group_chain <> NIL DO
          reference_group_chain^.newly_created := FALSE;
          reference_group_chain := reference_group_chain^.nnext;
        WHILEND;
        reference_group := reference_group^.nnext;
        unsatisfied_reference^.library_searched := 0;
        another_scan_required := TRUE;
        CYCLE /scan_reference_group_list/
      IFEND;
      IF NOT entry_point_found THEN
        reference_group := reference_group^.nnext;
        CYCLE /scan_reference_group_list/
      IFEND;
      IF ((reference_group^.global_key = lov$task_services_entry_points^ [i].global_lock) OR
            (lov$task_services_entry_points^ [i].gated AND ((reference_group^.global_key = loc$master_key) OR
            (lov$task_services_entry_points^ [i].global_lock = loc$no_lock)))) AND
            ((reference_group^.ring >= lov$task_services_entry_points^ [i].r1) AND
            ((reference_group^.ring <= lov$task_services_entry_points^ [i].r2) OR
            (lov$task_services_entry_points^ [i].gated AND (reference_group^.ring <=
            lov$task_services_entry_points^ [i].r3)))) THEN
        IF NOT debug_entry_point THEN
          IF reference_group^.ring >= lov$task_services_entry_points^ [i].r2 THEN
            pseudo_module_descriptor.attributes.loaded_ring := lov$task_services_entry_points^ [i].r2;
            pseudo_module_descriptor.attributes.call_bracket := lov$task_services_entry_points^ [i].r3;
          ELSE
            pseudo_module_descriptor.attributes.loaded_ring := reference_group^.ring;
            pseudo_module_descriptor.attributes.call_bracket := reference_group^.ring;
          IFEND;
        IFEND;

        unsatisfied_reference := unsatisfied_reference^.b_link;

        lop$define_entry_point (^pseudo_entry_definition, ^pseudo_module_descriptor,
              ^pseudo_allocated_sections, pseudo_control_options, {load_file_number} 0,
              duplicate_entry_point);

        IF linkage^.unsat_references_list = NIL THEN
          RETURN;
        ELSEIF duplicate_entry_point THEN
          unsatisfied_reference := unsatisfied_reference^.f_link;
          RETURN;
        ELSE

          unsatisfied_reference := unsatisfied_reference^.f_link;

          reference_group := linkage^.unsat_references_list^.references;
        IFEND;

      ELSE
        reference_group := reference_group^.nnext;
      IFEND;
    WHILEND /scan_reference_group_list/;
  PROCEND search_task_services_defs;
?? OLDTITLE, EJECT ??


  WHILE unsatisfied_reference <> lov$head_of_unsat_ref_list DO
    search_task_services_defs;
    unsatisfied_reference := unsatisfied_reference^.f_link;
  WHILEND;
PROCEND lop$satisfy_task_services_refs;
?? OLDTITLE ??
MODEND lom$task_services_def_matching;
*DECK DECK=LOP$ACTIVATE_LIBRARY EXPAND=FALSE

  PROCEDURE [XREF] lop$activate_library (library_name: amt$local_file_name);

*copyc amt$local_file_name
*DECK DECK=LOP$ADD_DEBUG_LIBRARIES EXPAND=FALSE

  PROCEDURE [XREF] lop$add_debug_libraries (debug_library_list: pmt$object_library_list;
    VAR status {control} : ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=LOP$ADD_DEFERRED_COMMON_BLOCKS EXPAND=FALSE

  PROCEDURE [XREF] lop$add_deferred_common_blocks
    (    deferred_common_blocks: ^llt$deferred_common_blocks);

?? PUSH (LISTEXT := ON) ??
*copyc llt$deferred_common_blocks
?? POP ??
*DECK DECK=LOP$ADD_LOCAL_BLOCK_ID EXPAND=FALSE

  PROCEDURE [XREF] lop$add_local_block_id (module_name: pmt$program_name;
        section_ordinal: llt$section_ordinal;
        procedure_name: pmt$program_name;
    VAR block_id: pmt$block_identifier);
?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
?? POP ??
*DECK DECK=LOP$ADD_PROGRAM_LOAD_LIBRARIES EXPAND=FALSE

  PROCEDURE [XREF] lop$add_program_load_libraries
    (    execute_libraries: ^pmt$object_library_list;
         global_libraries: ^pmt$object_library_list;
         deferred_libraries: ^lot$deferred_library_list);

?? PUSH (LISTEXT := ON) ??
*copyc lot$deferred_library_list
*copyc lot$loader_type_definitions
?? POP ??
*DECK DECK=LOP$ADD_TEXT_EMBEDDED_LIBRARIES EXPAND=FALSE

  PROCEDURE [XREF] lop$add_text_embedded_libraries (text_embedded_libraries: ^llt$libraries);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
?? POP ??
*DECK DECK=LOP$ADD_UNSATISFIED_REF_TO_LIST EXPAND=FALSE

  PROCEDURE [XREF] lop$add_unsatisfied_ref_to_list (reference_descriptor:
    lot$reference_descriptor;
    VAR linkage_info: ^lot$linkage_name_lists);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
?? POP ??
*DECK DECK=LOP$AUGMENT_ALLOCATED_SEGMENTS EXPAND=FALSE

  PROCEDURE [XREF] lop$augment_allocated_segments;
*DECK DECK=LOP$AUGMENT_DYNAMIC_LOADED_EPS EXPAND=FALSE

  PROCEDURE [XREF] lop$augment_dynamic_loaded_eps;

*DECK DECK=LOP$AUGMENT_LIB_LIST_CONTAINER EXPAND=FALSE

  PROCEDURE [XREF] lop$augment_lib_list_container;
*DECK DECK=LOP$BUILD_FILE_DESCRIPTOR EXPAND=FALSE

  PROCEDURE [XREF] lop$build_file_descriptor (file_name: amt$local_file_name;
    VAR file_loadable {control} : boolean;
    VAR file_descriptor: lot$file_descriptor);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
?? POP ??
*DECK DECK=LOP$CHECK_FOR_TARGET_TEXT EXPAND=FALSE

  PROCEDURE [XREF] lop$check_for_target_text (file_name: amt$local_file_name);
?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
?? POP ??
*DECK DECK=LOP$CLOSE_APD_PROCESSING_FILES EXPAND=FALSE

  PROCEDURE [XREF] lop$close_apd_processing_files;

*DECK DECK=LOP$COPY_BINDING_SECTION_TEXT EXPAND=FALSE

  PROCEDURE [XREF] lop$copy_binding_section_text (target_address: lot$address;
        text: ^array [1 .. *] of 0 .. 0ff(16);
    VAR any_code_base_ptrs_initialized: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc lot$loader_type_definitions
?? POP ??
*DECK DECK=LOP$CREATE_UNSAT_REF_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] lop$create_unsat_ref_segment;
*DECK DECK=LOP$DEACTIVATE_LIBRARY EXPAND=FALSE

  PROCEDURE [XREF] lop$deactivate_library (library_name: amt$local_file_name);

*copyc amt$local_file_name
*DECK DECK=LOP$DEFINE_ENTRY_POINT EXPAND=FALSE

  PROCEDURE [XREF] lop$define_entry_point
    (    entry_definition: ^llt$entry_definition;
         module_descriptor: {input} ^lot$module_descriptor;
         allocated_sections: ^lot$allocated_sections;
         control_options {control} : lot$control_options;
         load_file_number: lot$load_file_number;
     VAR duplicate_entry_point: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc llt$entry_definition
*copyc lot$load_file_number
*copyc lot$loader_options
*copyc lot$loader_type_definitions
?? POP ??
*DECK DECK=LOP$DEFINE_FORMAL_PARAMETERS EXPAND=FALSE

    PROCEDURE [XREF] lop$define_formal_parameters (formal_parameters: ^llt$formal_parameters;
          attributes: lot$module_attributes;
          module_descriptor: {input} ^lot$module_descriptor;
          allocated_sections: {input} ^lot$allocated_sections;
          control_options {control} : lot$control_options);

?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
*copyc llt$formal_parameters
?? POP ??

*DECK DECK=LOP$DEFIX_BINDING_SEGMENT_ATTR EXPAND=FALSE

  PROCEDURE [XREF] lop$defix_binding_segment_attr (binding_segment: ost$segment;
        maximum_length: ost$segment_length;
    VAR status {control} : ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??
*DECK DECK=LOP$DEFIX_PROGRAM_SEGMENT_ATTR EXPAND=FALSE

  PROCEDURE [XREF] lop$defix_program_segment_attr;
*DECK DECK=LOP$DELETE_LINKAGE_TREE EXPAND=FALSE
  PROCEDURE [XREF] lop$delete_linkage_tree;
*DECK DECK=LOP$DELETE_LOADER_LIBRARY_LIST EXPAND=FALSE

  PROCEDURE [INLINE] lop$delete_loader_library_list;

?? PUSH (LISTEXT := ON) ??

{
{  PURPOSE:
{    The purpose of this request is to delete all Loader library list entries
{    in the task.  Any subsequent calls to the Loader to dynamically load
{    entry points will not have available any previously defined libraries.
{
{        LOP$DELETE_LOADER_LIBRARY_LIST
{

    lov$library_list.first := NIL;
    lov$library_list.link_to_first_job_library := NIL;
    lov$library_list.container := NIL;

  PROCEND lop$delete_loader_library_list;
*copyc lov$library_list
?? POP ??
*DECK DECK=LOP$DETERMINE_INITIAL_RING EXPAND=FALSE

  PROCEDURE [XREF] 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);
?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_DESCRIPTION
*copyc PMT$LOADABLE_RINGS
?? POP ??
*DECK DECK=LOP$ESTABLISH_TRANSFER_SYMBOL EXPAND=FALSE

  PROCEDURE [XREF] 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);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
?? POP ??
*DECK DECK=LOP$FIND_COMMAND_IN_PROGRAM EXPAND=FALSE

  PROCEDURE [XREF] lop$find_command_in_program
    (    command_name: pmt$program_name;
     VAR command_dictionary_item: llt$command_dictionary_item;
     VAR library: ^SEQ ( * );
     VAR library_name: amt$local_file_name;
     VAR library_rings: amt$ring_attributes;
     VAR library_privilege: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc amt$ring_attributes
*copyc lle$loader_status_conditions
*copyc llt$command_dictionary
*copyc ost$name
*copyc ost$status
*copyc pmt$program_name
?? POP ??

*DECK DECK=LOP$FIND_COMMON_BLOCK_DEFINITON EXPAND=FALSE

  PROCEDURE [XREF] lop$find_common_block_definiton (section_definition: ^llt$section_definition;
        attributes: lot$module_attributes;
    VAR previously_defined: boolean;
    VAR common_blocks_index: lot$common_blocks_index;
    VAR common_block_length: ost$segment_length);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
?? POP ??
*DECK DECK=LOP$FIND_ENTRY_POINT_RESIDENCE EXPAND=FALSE

  PROCEDURE [XREF] lop$find_entry_point_residence
    (    entry_point: pmt$program_name;
     VAR loaded_ring: ost$valid_ring;
     VAR module_name: pmt$program_name;
     VAR file_reference: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc lle$loader_status_conditions
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=LOP$FIND_FUNCTION_IN_PROGRAM EXPAND=FALSE

  PROCEDURE [XREF] lop$find_function_in_program
    (    function_name: pmt$program_name;
     VAR function_dictionary_item: llt$function_dictionary_item;
     VAR library: ^SEQ ( * );
     VAR library_name: amt$local_file_name;
     VAR library_rings: amt$ring_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc amt$ring_attributes
*copyc lle$loader_status_conditions
*copyc llt$function_dictionary
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=LOP$FIND_LIBRARY_DESCRIPTOR EXPAND=FALSE

  PROCEDURE [XREF] lop$find_library_descriptor (library_name: amt$local_file_name;
    VAR library {input_output} : ^lot$library_descriptor;
    VAR library_found {control} : boolean);

*copyc LOT$LIBRARY_LIST
*copyc AMT$LOCAL_FILE_NAME
*DECK DECK=LOP$FIND_LINKAGE_NAME_LISTS EXPAND=FALSE

  PROCEDURE [XREF] lop$find_linkage_name_lists (linkage_name: pmt$program_name;
    VAR linkage: ^lot$linkage_name_lists);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
?? POP ??
*DECK DECK=LOP$FIND_MATCHING_ENTRY_POINT EXPAND=FALSE

  PROCEDURE [XREF] lop$find_matching_entry_point (external_descriptor:
    lot$external_descriptor;
    VAR entry_point_defined {control} : boolean;
    VAR linkage_info: ^lot$linkage_name_lists;
    VAR entry_definition: ^lot$entry_definition);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
?? POP ??
*DECK DECK=LOP$FIND_TASK_SERV_ENTRY_POINT EXPAND=FALSE

*DECK DECK=LOP$FINISH_LOAD_MAP EXPAND=FALSE

  PROCEDURE [XREF] lop$finish_load_map (load_map_options {control} : pmt$load_map_options;
        transfer_descriptor: lot$external_descriptor;
        normal_termination {control} : boolean);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
?? POP ??
*DECK DECK=LOP$FIX_BINDING_SEGMENT_ATTR EXPAND=FALSE

  PROCEDURE [XREF] lop$fix_binding_segment_attr (binding_segment: ost$segment;
        current_length: ost$segment_length;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??
*DECK DECK=LOP$FIX_PROGRAM_SEGMENT_ATTR EXPAND=FALSE

  PROCEDURE [XREF] lop$fix_program_segment_attr;
*DECK DECK=LOP$GENERATE_CROSS_REFERNCE_MAP EXPAND=FALSE

  PROCEDURE [XREF] lop$generate_cross_refernce_map;
*DECK DECK=LOP$GENERATE_LOAD_MAP_TEXT EXPAND=FALSE

  PROCEDURE [XREF] lop$generate_load_map_text (load_map_data: lot$load_map_data);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOAD_MAP_DATA
?? POP ??
*DECK DECK=LOP$GENERATE_SEGMENT_MAP EXPAND=FALSE

  PROCEDURE [XREF] lop$generate_segment_map;
*DECK DECK=LOP$GEN_INIT_INTERCEPT_LINKAGE EXPAND=FALSE

  PROCEDURE [XREF] lop$gen_init_intercept_linkage (transfer_descriptor:
    lot$external_descriptor;
    VAR reference_details: lot$reference_details);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
?? POP ??
*DECK DECK=LOP$GET_LOADER_SEQ_DESCRIPTOR EXPAND=FALSE

  PROCEDURE [XREF] lop$get_loader_seq_descriptor
   (VAR loader_seq_descriptor_p: ^pmt$loader_seq_descriptor);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$loader_seq_descriptor
?? POP ??
*DECK DECK=LOP$INITIALIZE_APD_PROCESSING EXPAND=FALSE

  PROCEDURE [XREF] lop$initialize_apd_processing (mpe_description:
    ^pmt$loader_description);
?? PUSH (LISTEXT := ON) ??
*copyc PMT$LOADER_SEQ_DESCRIPTOR
*copyc AMT$FILE_ATTRIBUTES
?? POP ??
*DECK DECK=LOP$INITIALIZE_LOAD_MAP EXPAND=FALSE

  PROCEDURE [XREF] lop$initialize_load_map (map_file: amt$local_file_name;
        map_ring_attributes: amt$ring_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc AMT$RING_ATTRIBUTES
*copyc OST$STATUS
?? POP ??
*DECK DECK=LOP$LINK_ACTUAL_PARAMETERS EXPAND=FALSE


   PROCEDURE [XREF] lop$link_actual_parameters (actual_parameters: ^llt$actual_parameters;
     module_descriptor: {input} ^lot$module_descriptor;
     control_options {control}: lot$control_options);

?? PUSH (LISTEXT := ON) ??
*copyc llt$actual_parameters
*copyc lot$loader_type_definitions
?? POP ??
*DECK DECK=LOP$LINK_EXTERNAL EXPAND=FALSE

  PROCEDURE [XREF] lop$link_external (external_linkage: ^llt$external_linkage;
        allocated_sections: {input} ^lot$allocated_sections;
        module_descriptor: {input} ^lot$module_descriptor;
        control_options {control} : lot$control_options);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
*copyc LOT$LOADER_OPTIONS
?? POP ??
*DECK DECK=LOP$LIST_REFERENCING_MODULE EXPAND=FALSE

  PROCEDURE [XREF] lop$list_referencing_module (module_name: pmt$program_name);
?? PUSH (LISTEXT := ON) ??
*copyc pmt$program_name
?? POP ??
*DECK DECK=LOP$LOAD_ENTRY_POINT EXPAND=FALSE

  PROCEDURE [XREF] lop$load_entry_point (name: pmt$program_name;
        reference_ring: ost$valid_ring;
        reference_global_key: ost$key_lock_value;
        kind: pmt$loaded_address_kind;
    VAR address: pmt$loaded_address;
    VAR status {control} : ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_NAME
*copyc OSD$VIRTUAL_ADDRESS
*copyc PMT$LOADED_ADDRESS
*copyc OST$STATUS
?? POP ??
*DECK DECK=LOP$LOAD_LIBRARY_FILE EXPAND=FALSE

  PROCEDURE [XREF] lop$load_library_file (file_descriptor: lot$file_descriptor;
        module_ring_attributes: lot$module_ring_attributes;
        control_options {control} : lot$control_options;
    VAR transfer_descriptor: lot$external_descriptor);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
*copyc LOT$LOADER_OPTIONS
?? POP ??
*DECK DECK=LOP$LOAD_MODULE EXPAND=FALSE

  PROCEDURE [XREF] lop$load_module (module_ring_attributes: lot$module_ring_attributes;
        file_attributes: lot$load_file_attributes;
        control_options {control} : lot$control_options;
    VAR load_file {input_output} : lot$load_file;
    VAR transfer_descriptor: lot$external_descriptor;
    VAR debug_symbol_table_present {control} : boolean;
    VAR module_structure_error {control} : boolean);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
*copyc LOT$LOADER_OPTIONS
?? POP ??
*DECK DECK=LOP$LOAD_MODULE_LIST EXPAND=FALSE

  PROCEDURE [XREF] lop$load_module_list (module_list: {input} ^pmt$module_list;
        initial_ring: ost$ring;
        control_options {control} : lot$control_options;
    VAR transfer_descriptor: lot$external_descriptor);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
*copyc LOT$LOADER_OPTIONS
?? POP ??
*DECK DECK=LOP$LOAD_OBJECT_FILES EXPAND=FALSE

  PROCEDURE [XREF] 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);
*DECK DECK=LOP$LOAD_PROGRAM EXPAND=FALSE

  PROCEDURE [XREF] lop$load_program (object_file_list: ^pmt$object_file_list;
        module_list: ^pmt$module_list;
        execute_library_list: ^pmt$object_library_list;
        job_library_list: ^pmt$object_library_list;
        starting_procedure: pmt$program_name;
        target_ring: ost$ring;
        loader_options_value: lot$loader_options;
        mpe_description: ^pmt$loader_description;
    VAR loaded_program_cbp: ^ost$external_code_base_pointer;
    VAR status {control} : ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_DESCRIPTION
*copyc PMT$LOADER_SEQ_DESCRIPTOR
*copyc OSD$VIRTUAL_ADDRESS
*copyc LOT$LOADER_OPTIONS
*copyc OSD$CODE_BASE_POINTER
*copyc OST$STATUS
?? POP ??
*DECK DECK=LOP$OPEN_LIBRARY EXPAND=FALSE

  PROCEDURE [XREF] lop$open_library (library_name: amt$local_file_name;
    VAR file_descriptor: lot$file_descriptor;
    VAR library_valid: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc lot$loader_type_definitions
*copyc lle$load_map_diagnostics
?? POP ??
*DECK DECK=LOP$OPEN_LIBRARY_AS_PREDEFINED EXPAND=FALSE

  PROCEDURE [XREF] lop$open_library_as_predefined (name: amt$local_file_name;
         segment_atributes: lot$segment_attributes;
         segment_number: ost$segment);
?? PUSH (LISTEXT := OFF)  ??
*copyc lot$loader_type_definitions
?? POP ??
*DECK DECK=LOP$PROCESS_ALL_ENTRY_DEFINITNS EXPAND=FALSE

  PROCEDURE [XREF] lop$process_all_entry_definitns (processor: ^procedure
    (name: pmt$program_name;
        ptr: ^^lot$entry_definition));
?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_NAME
*copyc LOT$LOADER_TYPE_DEFINITIONS
?? POP ??
*DECK DECK=LOP$RECORD_CROSS_REFERENCE EXPAND=FALSE

  PROCEDURE [XREF] lop$record_cross_reference (referencing_module: pmt$program_name;
    VAR entry_definition {input_output} : lot$entry_definition);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
?? POP ??
*DECK DECK=LOP$REINITIALIZE_MODULE EXPAND=FALSE
  PROCEDURE [XREF] lop$reinitialize_module (module_name: pmt$program_name;
      VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc pmt$program_name
*copyc ost$status
?? POP ??
*DECK DECK=LOP$RELEASE_TRANSIENT_SEGMENTS EXPAND=FALSE

  PROCEDURE [XREF] lop$release_transient_segments (control_options {control} :
    lot$control_options);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_OPTIONS
?? POP ??
*DECK DECK=LOP$RELEASE_UNSAT_REF_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] lop$release_unsat_ref_segment;
*DECK DECK=LOP$REPORT_ERROR EXPAND=FALSE

  PROCEDURE [XREF] lop$report_error (error_condition: ost$status_condition;
        text_1: string ( * );
        text_2: string ( * );
        number: integer);
?? PUSH (LISTEXT := ON) ??
*copyc LLE$LOAD_MAP_DIAGNOSTICS
*copyc OST$STATUS
?? POP ??
*DECK DECK=LOP$REPORT_SECONDARY_ERROR EXPAND=FALSE
 PROCEDURE [XREF] lop$report_secondary_error (status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=LOP$RESERVE_STORAGE EXPAND=FALSE

  PROCEDURE [XREF] lop$reserve_storage (attributes: lot$segment_attributes;
        allocation_alignment: ost$segment_offset;
        allocation_offset: ost$segment_offset;
        predefined_segment: boolean;
        predefined_segment_number: ost$segment;
        shadow_pointer: ^cell;
        shadow_length: ost$segment_length;
    VAR allocation_length: ost$segment_length;
    VAR section_address: lot$address);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
?? POP ??
*DECK DECK=LOP$RESET_LOADER_FOR_2ND_LOAD EXPAND=FALSE

  PROCEDURE [XREF] lop$reset_loader_for_2nd_load (
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=LOP$SATISFY_EXTERNALS EXPAND=FALSE

  PROCEDURE [XREF] lop$satisfy_externals (control_options {control} :
    lot$control_options);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
*copyc LOT$LOADER_OPTIONS
?? POP ??
*DECK DECK=LOP$SATISFY_TASK_SERVICES_REFS EXPAND=FALSE

  PROCEDURE [XREF] lop$satisfy_task_services_refs (control_options {control} :
    lot$control_options;
    VAR unsatisfied_reference: ^lot$unsatisfied_reference_list;
    VAR another_scan_required: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_OPTIONS
?? POP ??
*DECK DECK=LOP$SEARCH_ENTRY_PT_DICTIONARY EXPAND=FALSE

  PROCEDURE [XREF] lop$search_entry_pt_dictionary (external_name: {input}
    ^pmt$program_name;
        entry_point_dictionary: {input} ^llt$entry_point_dictionary;
    VAR entry_point_found: {control} boolean;
    VAR entry_point_gated: {control} boolean;
    VAR dictionary_index: 1 .. llc$max_entry_points_in_library);

*copyc PMT$PROGRAM_NAME
*copyc LLT$ENTRY_POINT_DICTIONARY
*DECK DECK=LOP$STORE_INTERCEPT_LINKAGE EXPAND=FALSE

  PROCEDURE [XREF] lop$store_intercept_linkage (reference_details:
    lot$reference_details;
        remote_block_name: pmt$program_name;
    VAR entry_definition: lot$entry_definition;
    VAR binding_section_overwrite {control} : boolean;
    VAR declaration_mismatch {control} : boolean;
    VAR address_value_unaligned {control} : boolean);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
?? POP ??
*DECK DECK=LOP$STORE_LINKAGE EXPAND=FALSE

  PROCEDURE [INLINE] lop$store_linkage (
        reference_details: {input} ^lot$reference_details;
        entry_definition: {input} ^lot$entry_definition;
    VAR binding_section_overwrite {control} : boolean;
    VAR declaration_mismatch {control} : boolean;
    VAR address_value_unaligned {control} : boolean);
?? PUSH (LISTEXT := ON) ??

    TYPE
      binding_section_address = record
        case 1 .. 4 of
        = 1 =
          word1: integer,
          word2: integer,
        = 2 =
          pva_target: lot$address,
        = 3 =
          cbp_target: lot$cbp_template,
        = 4 =
          external_proc_cbp: lot$cbp_template,
          filler: 0 .. 0ffff(16),
          external_proc_pva: lot$address,
        casend,
      recend;


    VAR
      address_ptr: ^binding_section_address,
      of_execution: ^cell,
      malfunction_status: ^ost$status,
      abort_status: ^ost$status;

    binding_section_overwrite := FALSE;
    declaration_mismatch := FALSE;
    IF (entry_definition^.attributes.declaration_matching_required AND
          reference_details^.declaration_matching_required) AND (entry_definition^.attributes.language =
          reference_details^.language) THEN
      IF (entry_definition^.attributes.language = llc$cybil) THEN
        IF (entry_definition^.attributes.source_declaration_matching) THEN
          IF (entry_definition^.attributes.declaration_matching.source_encryption <>
                reference_details^.declaration_matching.source_encryption) THEN
            declaration_mismatch := TRUE;
          IFEND;
        ELSE
          IF (entry_definition^.attributes.declaration_matching.object_encryption <>
                reference_details^.declaration_matching.object_encryption) THEN
            declaration_mismatch := TRUE;
          IFEND;
        IFEND;
      ELSE
        IF (entry_definition^.attributes.declaration_matching.language_dependent_value <>
              reference_details^.declaration_matching.language_dependent_value) THEN
          declaration_mismatch := TRUE;
        IFEND;
      IFEND;
    IFEND;
    IF reference_details^.binding_section_destination THEN
      { This code assumes that the target address is aligned properly for the type of
      { linkage to be generated.
      address_ptr := #address (#ring (^of_execution), reference_details^.address.segment, reference_details^.
            address.offset - (reference_details^.address.offset MOD 8));
      IF address_ptr^.word1 <> 0 THEN
        binding_section_overwrite := TRUE;
        RETURN
      IFEND;
      IF reference_details^.kind = llc$external_proc THEN
        IF address_ptr^.word2 <> 0 THEN
          binding_section_overwrite := TRUE;
          RETURN
        IFEND;
      IFEND;
    IFEND;
    address_ptr := #address (#ring (^of_execution), reference_details^.address.segment, reference_details^.
          address.offset);
    CASE reference_details^.kind OF
    = llc$address, llc$address_addition, llc$address_subtraction =
      address_ptr^.pva_target := entry_definition^.attributes.address;
      IF reference_details^.kind = llc$address_addition THEN
        address_ptr^.pva_target.offset := address_ptr^.pva_target.offset + reference_details^.offset_operand;
      ELSEIF reference_details^.kind = llc$address_subtraction THEN
        address_ptr^.pva_target.offset := address_ptr^.pva_target.offset - reference_details^.offset_operand;
      IFEND;
      address_value_unaligned := FALSE;
    = llc$internal_proc =
      address_ptr^.cbp_target.vmid := entry_definition^.attributes.vmid;
      address_ptr^.cbp_target.external_proc_flag := FALSE;
      address_ptr^.cbp_target.call_bracket := entry_definition^.attributes.loaded_ring;
      address_ptr^.cbp_target.address := entry_definition^.attributes.address;
      address_value_unaligned := (entry_definition^.attributes.address.offset MOD 8) <> 0;
    = llc$external_proc =
      address_ptr^.cbp_target.vmid := entry_definition^.attributes.vmid;
      address_ptr^.cbp_target.external_proc_flag := TRUE;
      address_ptr^.cbp_target.call_bracket := entry_definition^.attributes.call_bracket;
      address_ptr^.cbp_target.address := entry_definition^.attributes.address;
      address_value_unaligned := (entry_definition^.attributes.address.offset MOD 8) <> 0;
      address_ptr^.external_proc_pva := entry_definition^.attributes.binding_section_address;
    ELSE
{!  address_kind should have been verified prior to arrival here.
      PUSH malfunction_status;
      osp$set_status_abnormal ('LL', lle$loader_malfunctioned, 'store_linkage', malfunction_status^);
      PUSH abort_status;
      pmp$cause_condition (loe$loader_malfunction, malfunction_status, abort_status^);
      pmp$exit (abort_status^);
    CASEND;
  PROCEND lop$store_linkage;

*copyc pmp$cause_condition
*copyc osp$set_status_abnormal
*copyc pmp$exit
*copyc LOT$LOADER_TYPE_DEFINITIONS
*copyc LOE$ABORT_LOAD
*copyc LLE$LOADER_STATUS_CONDITIONS
?? POP ??
*DECK DECK=LOP$TERMINATE_LOADER EXPAND=FALSE

  PROCEDURE [XREF] lop$terminate_loader;
*DECK DECK=LOT$DEFERRED_COMMON_BLOCKS EXPAND=FALSE

  TYPE
    lot$deferred_common_blocks = record
      deferred_common_blocks: ^llt$deferred_common_blocks,
      link: ^lot$deferred_common_blocks,
    recend;

*copyc llt$deferred_common_blocks

*DECK DECK=LOT$DEFERRED_ENTRY_POINTS EXPAND=FALSE

  TYPE
    lot$deferred_entry_points = record
      deferred_entry_points: ^llt$deferred_entry_points,
      link: ^lot$deferred_entry_points,
    recend;

*copyc llt$deferred_entry_points
*DECK DECK=LOT$DEFERRED_LIBRARY_LIST EXPAND=FALSE

  TYPE
    lot$deferred_library_list = array [1 .. * ] of lot$deferred_library,

    lot$deferred_library = record
      name: pmt$program_name,
      segment: ost$segment,
    recend;

*copyc osd$virtual_address
*copyc pmt$program_name
*DECK DECK=LOT$LIBRARY_LIST EXPAND=FALSE

  TYPE
    lot$library_list = record
      first: ^lot$library_descriptor,
      link_to_first_job_library: ^^lot$library_descriptor,
      container: ^SEQ ( * ),
    recend,

    lot$library_descriptor = record
      nnext: ^lot$library_descriptor,
      segment: lot$load_file,
      ring_brackets: amt$ring_attributes,
      attributes: lot$load_file_attributes,
      library_open: boolean,
      library_valid: boolean,
      phantom_library: boolean,
      phantom_library_active: boolean,
      text_embedded_library: boolean,
    recend;

*copyc amt$ring_attributes
*copyc lot$loader_type_definitions
*DECK DECK=LOT$LINKAGE_TREE EXPAND=FALSE
   TYPE
     lot$linkage_tree = record
       root: ^lot$linkage_tree_node,
       container: ^SEQ (*),
     recend,

     lot$linkage_tree_node = record
       linkage_info: lot$linkage_name_lists,
       balance: lot$node_balance_factor,
       less,
       greater: ^lot$linkage_tree_node,
     recend,

     lot$node_balance_factor = (loc$balanced, loc$weighted_less, loc$weighted_greater);


*DECK DECK=LOT$LOADED_ENTRY_POINT_LIST EXPAND=FALSE

  TYPE
    lot$loaded_entry_point_list = record
      number_of_entry_points: ost$non_negative_integers,
      container: ^array [ * ] of lot$loaded_entry_point,
    recend,

    lot$loaded_entry_point = record
      program_name: pmt$program_name,
      reference_ring: ost$valid_ring,
      loaded_address: pmt$loaded_address,
    recend;

*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc pmt$loaded_address
*copyc pmt$program_name
*DECK DECK=LOT$LOADER_OPTIONS EXPAND=FALSE

  TYPE
    lot$loader_options = record
      map_file: amt$local_file_name,
      map: pmt$load_map_options,
      termination_error_level: pmt$termination_error_level,
      preset: integer,
      maximum_stack_size: ost$segment_length,
      debug_ring: ost$ring,
    recend,

    lot$control_options = record
      map: pmt$load_map_options,
      debug_ring: ost$ring,
    recend;

*copyc amt$local_file_name
*copyc osd$virtual_address
*copyc pmt$loadable_rings
*copyc pmt$program_description
*DECK DECK=LOT$LOADER_TYPE_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'LOADER TYPE DEFINITIONS' ??
?? TITLE := '  general_definitions', EJECT ??

  CONST
    loc$master_key_no_lock = 0,
    loc$master_key = 0,
    loc$no_lock = 0;

  CONST
    loc$loader_ring = osc$tsrv_ring;

  CONST
    loc$no_shadow = 0,
    loc$no_shadow_file = NIL;

  TYPE
    lot$address = packed record
      ring: ost$ring,
      segment: ost$segment,
      offset: ost$segment_offset,
    recend,

    lot$module_ring_attributes = record
      loaded_ring,
      call_bracket: ost$valid_ring,
    recend,

    lot$load_file = ^SEQ ( * ),

    lot$load_file_attributes = record
      name: amt$local_file_name,
      library_file: boolean,
      debug_file: boolean,
      key_lock: ost$key_lock,
      execute_privilege: ost$execute_privilege,
      load_file_number: lot$load_file_number,
    recend;

?? TITLE := '  data structure definitions', EJECT ??

  TYPE

    lot$allocated_segments = ^array [ * ] of lot$segment_allocation,

    lot$allocated_segments_index = 1 .. osc$maximum_segment + 1,

    lot$segment_allocation = record
      attributes: lot$segment_attributes,
      segment: ost$segment,
      current_length: ost$segment_length,
      maximum_length: ost$segment_length,
    recend,

    lot$segment_attributes = record
      access_control: ost$segment_access_control,
      r1,
      r2: ost$valid_ring,
      key_lock: ost$key_lock,
      stack: boolean,
      extensible: boolean,
      debug_segment: boolean,
      apd_binding_segment: boolean,
    recend,

    lot$cbp_template = packed record
      unused_bits_1: 0 .. 0f(16),
      vmid: ost$virtual_machine_identifier,
      external_proc_flag: boolean,
      unused_bits_2: 0 .. 7,
      call_bracket: ost$ring,
      address: lot$address,
    recend,

    lot$entry_definition = record
      nnext: ^lot$entry_definition,
      attributes: lot$entry_attributes,
{!  Consider making this record a bound variant record with the following
{fields optional.
{!  How could definitions for task services entry points be established at
{!  task initiation; i.e., which variant would be used?
      defining_module: pmt$program_name,
      xref_list: ^lot$cross_reference,
      xref_listed: boolean,
    recend,

    lot$entry_attributes = record
      gated: boolean,
      global_lock: ost$key_lock_value,
{!  The following field is redundant.
      loaded_ring,
      call_bracket: ost$valid_ring,
      vmid: ost$virtual_machine_identifier,
      address,
      binding_section_address: lot$address,
      declaration_matching_required: boolean,
      declaration_matching: llt$declaration_matching_value,
      source_declaration_matching: boolean,
      language: llt$module_generator,
      in_target_text: boolean,
      block_id: pmt$block_identifier,
      instrumented_callee_address: lot$address,
      instrumented: boolean,
      load_file_number: lot$load_file_number,
    recend,

    lot$cross_reference = record
      nnext: ^lot$cross_reference,
      mmodule: pmt$program_name,
    recend,

    lot$unsatisfied_reference_group = record
      nnext: ^lot$unsatisfied_reference_group,
      logically_satisfied: boolean,
      newly_created: boolean,
      global_key: ost$key_lock_value,
      ring: ost$valid_ring,
      list: ^lot$unsatisfied_reference,
    recend,

    lot$unsatisfied_reference = record
      nnext: ^lot$unsatisfied_reference,
      details: lot$reference_details,
      mmodule: pmt$program_name,
    recend,

    lot$unsatisfied_reference_list = record
      linkage_info: ^lot$linkage_name_lists,
      f_link: ^lot$unsatisfied_reference_list,
      b_link: ^lot$unsatisfied_reference_list,
      library_searched: integer,
      references: ^lot$unsatisfied_reference_group,
    recend,

    lot$linkage_name_lists = record
      name: pmt$program_name,
      definitions_list: ^lot$entry_definition,
      unsat_references_list: ^lot$unsatisfied_reference_list,
    recend,

    lot$reference_details = record
      address: lot$address,
      kind: llt$address_kind,
      offset_operand: ost$segment_offset,
      binding_section_destination: boolean,
      declaration_matching_required: boolean,
      declaration_matching: llt$declaration_matching_value,
      language: llt$module_generator,
      in_target_text: boolean,
    recend,

    lot$param_matching_list = record
      first: ^lot$param_matching_node,
      container: ^HEAP ( * ),
    recend,

    lot$param_matching_node = record
      nnext: ^lot$param_matching_node,
      name: pmt$program_name,
      definitions: ^lot$formal_param_definition,
      references: ^lot$actual_param_group,
    recend,

    lot$formal_param_definition = record
      nnext: ^lot$formal_param_definition,
      global_lock: ost$key_lock_value,
      loaded_ring,
      call_bracket: ost$valid_ring,
      defining_module: pmt$program_name,
      gated: boolean,
      definition: llt$formal_parameters,
    recend,

    lot$actual_param_group = record
      nnext: ^lot$actual_param_group,
      global_key: ost$key_lock_value,
      ring: ost$valid_ring,
      list: ^lot$actual_param_list_item,
    recend,

    lot$actual_param_list_item = record
      nnext: ^lot$actual_param_list_item,
      module_name: pmt$program_name,
      definition: llt$actual_parameters,
    recend,

    lot$common_blocks_index = integer,

    lot$common_block_definition = record
      name: pmt$program_name,
      global_lock: ost$key_lock_value,
      loaded_ring: ost$valid_ring,
      address: lot$address,
      allocation_length: ost$segment_length,
      allocation_alignment,
      allocation_offset: ost$segment_offset,
      access_attributes: llt$section_access_attributes,
      segment_access_control: ost$segment_access_control,
      extensible: boolean,
      unallocated_common: boolean,
      unallocated_common_open: boolean,
      unallocated_common_segment: ost$segment,
      unallocated_common_file_id: amt$file_identifier,
    recend;

?? TITLE := '  parameter_definitions', EJECT ??

  TYPE

    lot$file_descriptor = record
      file_open:boolean,
      file_identifier: amt$file_identifier,
      segment: lot$load_file,
      ring_brackets: amt$ring_attributes,
      attributes: lot$load_file_attributes,
    recend,

    lot$module_descriptor = record
      name: pmt$program_name,
      attributes: lot$module_attributes,
    recend,

    lot$module_attributes = record
      loaded_ring,
      call_bracket: ost$valid_ring,
      global_key_lock: ost$key_lock_value,
      vmid: ost$virtual_machine_identifier,
      binding_section_address: lot$address,
      source_declaration_matching: boolean,
    recend,

    lot$entry_point_descriptor = record
      name: pmt$program_name,
      attributes: lot$entry_attributes,
      defining_module: pmt$program_name,
    recend,

    lot$external_descriptor = record
      name: pmt$program_name,
      global_key: ost$key_lock_value,
      reference_ring: ost$valid_ring,
    recend,

    lot$reference_descriptor = record
{!  The following field is redundant.
      ring: ost$valid_ring,
      global_key: ost$key_lock_value,
      mmodule: pmt$program_name,
      details: lot$reference_details,
    recend,

    lot$section_allocation = record
      kind: llt$section_kind,
      allotted: boolean,
      unallocated_common: boolean,
      address: lot$address,
      length: ost$segment_length,
      local_block_id: pmt$block_identifier,
      segment_predefined: boolean,
      binding_section_offset: llt$section_address_range,
    recend,

    lot$allocated_sections = array [0 .. * ] of lot$section_allocation;

*copyc lot$load_file_number
?? TITLE := '  object_text_definitions', EJECT ??
*copyc llt$object_module

*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc amt$ring_attributes
*copyc mmt$attribute_keyword
*copyc osd$virtual_address
*copyc ost$segment_access_control
*copyc ost$status
*copyc ost$virtual_machine_identifier
*copyc pmt$loadable_rings
*copyc pmt$loader_seq_descriptor
*copyc pmt$program_description
*copyc pmt$program_name
?? OLDTITLE ??
*DECK DECK=LOT$LOAD_FILE_NUMBER EXPAND=FALSE
  CONST
    loc$maximum_load_files = 0ffff(16);

{ The load_file_number keeps track of the object file or library an
{ entry point was loaded from. Zero implies osf$task_services_library.

  TYPE
    lot$load_file_number = 0 .. loc$maximum_load_files;
*DECK DECK=LOT$LOAD_MAP_DATA EXPAND=FALSE

  TYPE
    lot$lm_code = (loc$lm_module_detail_1, loc$lm_module_detail_2,
          loc$lm_section_detail, loc$lm_entry_detail, loc$lm_xref_detail,
          loc$lm_segment_detail, loc$lm_transfer_detail, loc$lm_asis_text,
          loc$lm_accumulate_names, loc$lm_flush_accumulated_names,
          loc$lm_issue_diagnostic, loc$lm_diagnostic_summary,
          loc$lm_page_header, loc$lm_segment_header_init,
          loc$lm_xref_header_init),

    lot$load_map_data = record
      case code: lot$lm_code of
      = loc$lm_module_detail_1 =
        module_name: pmt$program_name,
        file_type: string (7),
        file_name: amt$local_file_name,
        loaded_ring,
        call_bracket,
        module_global_key_lock,
        module_local_key_lock: 0 .. 3f(16),
        execute_privilege: ost$execute_privilege,
      = loc$lm_module_detail_2 =
        date: string (10),
        generator,
        commentary: string (40),
      = loc$lm_section_detail =
        section_kind: llt$section_kind,
        section_access_attributes: llt$section_access_attributes,
        section_address: lot$address,
        section_length: ost$segment_length,
        section_name: pmt$program_name,
      = loc$lm_entry_detail, loc$lm_xref_detail =
        entry_name: pmt$program_name,
        loaded_ring_for_xref: ost$ring,
        entry_address: lot$address,
        entry_attribute: string (5),
        deferred: string (8),
        defining_module: pmt$program_name,
      = loc$lm_segment_detail =
        segment_name: amt$local_file_name,
        segment: ost$segment,
        segment_length: ost$segment_length,
        r1,
        r2,
        segment_global_key_lock,
        segment_local_key_lock: 0 .. 3f(16),
        segment_access_attributes: ost$segment_access_control,
        stack_segment: boolean,
      = loc$lm_transfer_detail =
        transfer_address: lot$address,
        transfer_symbol: pmt$program_name,
      = loc$lm_asis_text =
        text: string (132),
      = loc$lm_accumulate_names =
        name: pmt$program_name,
      = loc$lm_issue_diagnostic =
        diagnostic_status: ost$status,
      = loc$lm_diagnostic_summary =
        diagnostic_count: array [ost$status_severity] of 0 .. 0ffff(16),
      = loc$lm_page_header =
        ,
      = loc$lm_segment_header_init =
        ,
      = loc$lm_xref_header_init =
        ,
      casend,
    recend;

*copyc ost$status_severity
*DECK DECK=LOT$TASK_SERVICES_ENTRY_POINT EXPAND=FALSE
*copyc llt$declaration_matching_value
*copyc llt$object_module
*copyc lot$loader_type_definitions
*copyc osd$virtual_address
*copyc ost$virtual_machine_identifier
*copyc pmt$program_name

  TYPE
    lot$task_services_entry_point = record
      name: ALIGNED [0 MOD 8] pmt$program_name,
      address: lot$address,
      binding_section_address: lot$address,
      gated: boolean,
      global_lock: ost$key_lock_value,
      r1: ost$valid_ring,
      r2: ost$valid_ring,
      r3: ost$valid_ring,
      vmid: ost$virtual_machine_identifier,
      declaration_matching_required: boolean,
      declaration_matching: llt$declaration_matching_value,
      language: llt$module_generator,
    recend;
*DECK DECK=LOV$ALLOCATED_SEGMENTS EXPAND=FALSE

  VAR
    lov$allocated_segments: [XREF] ^array [ * ] of lot$segment_allocation;

?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
?? POP ??
*DECK DECK=LOV$APD_LOAD EXPAND=FALSE

  VAR
    lov$apd_flags: [XREF] record
      apd_load: boolean,
      target_text: boolean,
    recend;

*DECK DECK=LOV$BINDING_SEGMENT_ATTRIBUTES EXPAND=FALSE

  VAR
    binding_segment_attributes: [READ, oss$job_paged_literal]
      lot$segment_attributes := [[FALSE, osc$non_executable,
      osc$binding_segment, osc$non_writable], osc$tsrv_ring, osc$max_ring,
      [FALSE, FALSE, 0], FALSE, FALSE, FALSE, FALSE];

?? PUSH (LISTEXT := ON) ??
*copyc OSS$JOB_PAGED_LITERAL
?? POP ??
*DECK DECK=LOV$COMMON_BLOCKS EXPAND=FALSE

  VAR
    lov$common_blocks: [XREF] ^array [ * ] of lot$common_block_definition;

?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_TYPE_DEFINITIONS
?? POP ??
*DECK DECK=LOV$DEFERRED_COMMON_BLOCKS EXPAND=FALSE

  VAR
    lov$deferred_common_blocks: [XREF] ^lot$deferred_common_blocks;

*copyc lot$deferred_common_blocks

*DECK DECK=LOV$DEFERRED_ENTRY_POINTS EXPAND=FALSE

  VAR
    lov$deferred_entry_points: [XREF] ^lot$deferred_entry_points;

*copyc lot$deferred_entry_points

*DECK DECK=LOV$DYNAMIC_LOADED_ENTRY_POINTS EXPAND=FALSE

  VAR
    lov$dynamic_loaded_entry_points: [XREF] ^lot$loaded_entry_point_list;

?? PUSH (LISTEXT := ON) ??
*copyc lot$loaded_entry_point_list
?? POP ??
*DECK DECK=LOV$ENABLE_SOURCE_TYPE_CHECKING EXPAND=FALSE

  VAR
    lov$enable_source_type_checking: [XREF, READ] boolean;
*DECK DECK=LOV$FILE_DESCRIPTORS EXPAND=FALSE

  VAR
    lov$file_descriptors: [XREF] ^ARRAY [1 .. *] OF lot$file_descriptor;
*DECK DECK=LOV$HEAD_OF_UNSAT_REF_LIST EXPAND=FALSE

  VAR
    lov$head_of_unsat_ref_list: [XREF] ^lot$unsatisfied_reference_list;

*copyc LOT$LOADER_TYPE_DEFINITIONS
*DECK DECK=LOV$HIGHEST_SEGMENT_INDEX EXPAND=FALSE
 VAR
    lov$highest_segment_index: [XREF] lot$allocated_segments_index;

?? PUSH (LISTEXT := ON) ??
*copyc lot$loader_type_definitions
?? POP ??
*DECK DECK=LOV$LIBRARY_LIST EXPAND=FALSE

  VAR
    lov$library_list: [XREF] lot$library_list;

?? PUSH (LISTEXT := ON) ??
*copyc LOT$LIBRARY_LIST
?? POP ??
*DECK DECK=LOV$LOADER_OPTIONS EXPAND=FALSE

  VAR
    lov$loader_options: [XREF] lot$loader_options;

?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOADER_OPTIONS
?? POP ??
*DECK DECK=LOV$LOI$NIL EXPAND=FALSE

  VAR
{!  This variable should be replaced by a constant when CYBIL supports
{     definite_value_constructors.
    loc$nil: [STATIC, READ, oss$job_paged_literal] lot$address :=
      [osc$max_ring, 0fff(16), - (osc$maximum_offset + 1)];

?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc OSS$JOB_PAGED_LITERAL
?? POP ??
*DECK DECK=LOV$PARAM_LINKAGE_LIST EXPAND=FALSE

   VAR
     lov$param_linkage_list: [XREF] lot$param_matching_list;


?? PUSH (LISTEXT := ON) ??
*copyc lot$loader_type_definitions
?? POP ??

*DECK DECK=LOV$SECONDARY_STATUS EXPAND=FALSE

  VAR
    lov$secondary_status: [XREF] ost$status;

*copyc OST$STATUS
*DECK DECK=LOV$TASK_SERVICES_ENTRY_POINTS EXPAND=FALSE

  VAR
    lov$task_services_entry_points: [XREF] ^array [ * ] of lot$task_services_entry_point;

?? PUSH (LISTEXT := ON) ??
*copyc LOT$TASK_SERVICES_ENTRY_POINT
?? POP ??
*DECK DECK=LOV$UNSATISFIED_REFERENCE EXPAND=FALSE


  VAR
    lov$unsatisfied_reference: [XREF] ^lot$unsatisfied_reference_list;

*copyc LOT$LOADER_TYPE_DEFINITIONS
*DECK DECK=LOV$UNSATISFIED_REF_CONTAINER EXPAND=FALSE

  VAR
    lov$unsatisfied_ref_container: [XREF] ^HEAP ( * );
*DECK DECK=LUP$PROCESS_LINK_USER_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] lup$process_link_user_command ALIAS 'rhxpluc' (
        parameter_list: string(*);
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=LUP$SAVE_LINK_USER_DESCRIPTOR EXPAND=FALSE

  PROCEDURE [XREF] lup$save_link_user_descriptor ALIAS 'luxslud' (
        link_user_descriptor: lut$link_user_descriptor;
        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc LUDLUDT
*copyc OST$STATUS
?? POP ??
*DECK DECK=MANAGE_FORM EXPAND=TRUE
crepd name=(manage_form, manage_forms, manf) ..
  starting_procedure=fdp$_manage_forms,..
  library=('$system.tdu.terminal_definitions', 'fdf$library') ..
  tel=warning pv=z ..
  load_map_options = none ..
  debug_mode = off
*DECK DECK=MF_CONFIG_EPILOG EXPAND=TRUE
" All MF_CONFIG_FILES have been loaded to the $LOCAL catalog with file names
" which match their tape file identifiers.  The ring attributes of each file
" is (3, 13, 13).  If a file's BLOCK_TYPE=SYSTEM_SPECIFIED and RECORD_TYPE=
" UNKNOWN, the file was assumed to be an object library and the load process
" set the FILE_CONTENT to OBJECT and FILE_STRUCTURE to LIBRARY.
*DECK DECK=MLA$C170_MEMORY_LINK_INTERFACE EXPAND=FALSE
          CTEXT  COMCMLI - PROCESS MEMORY LINK INTERFACE REQUEST.
MLI       SPACE  4
          IF     -DEF,QUAL$,1
          QUAL   COMCMLI
          IF     -DEF,RA.ORG,1
          ENTRY  MLV$MLI
          BASE   D
*         COMMENT            COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
MLI       SPACE  4
***       COMCMLI - PROCESS MEMORY LINK INTERFACE REQUEST.
*         D. A. HENSELER. 79/04/24.
MLI       SPACE  4
***       COMCMLI CONTAINS ROUTINES FOR PROCESSING REQUESTS FOR THE
*         NOS/VE MEMORY LINK INTERFACE.
MLI       SPACE  4
***       MLI - PROCESS MEMORY LINK INTERFACE REQUEST.
*
*         ENTRY  MLIPAR BLOCK SET UP WITH FUNCTION CODE AND ALL
*                PARAMETERS REQUIRED BY THAT FUNCTION.
*
*         EXIT   REQUEST PROCESSED.
*                STATUS RETURNED TO MLIPAR BLOCK STATUS WORD.
*
*         USES   X - 1, 2, 6.
*                B - NONE.
*                A - 1, 6.
*
*         CALLS  ITB, ITA.
*
*         MACROS CALLVS, RECALL, MESSAGE, ABORT, SUBR.
          SPACE  2
          SKIP   RA.MTR
          ERR    CALLING DECK SHOULD CALL -SYSCOM-
          IF     -DEF,RA.ORG,1
 OPL      XTEXT  COMSSSD

          IF     -DEF,MLIFTN,1
 MLIFTN   EQU    CVSMLIU     SET TO UNPRIVIGED MEMORY LINK FUNCTION
MLI=      SUBR               ENTRY/EXIT
          IF     -DEF,MLI=X,1
MLI=X     EQU    MLI=
          IF     -DEF,NVSI,1
NVSI      EQU    SS.NVE
          SA4    NTHSR
          R=     X2,2
          IX3    X4+X2
          NZ     X3,MLI11    IF TO RESUME WAITING
          SA1    MLIPAR+MLPFN CHECK FOR VALID FUNCTION
          NG     X1,MLI4     IF ILLEGAL FUNCTION
          IF     DEF,RA.ORG,2      SWAPOUT FUNCTION IS NOS/BE ONLY
          SX6    X1-MLFSW
          ZR     X6,MLI7           PROCESS VIA SUBSYSTEM
          SX6    MLFCO+1
          IX6    X1-X6
          PL     X6,MLI4     IF ILLEGAL FUNCTION
          MX6    0
          SA6    MLIB        RESET RETRY COUNT

* IF THE FUNCTION IS SIGNON OR SIGNOFF THEN PASS THE REQUEST TO THE
* MLI SUBSYSTEM TO BE PROCESSED.

          IFLT   MLFON+MLFOF,2,4
          AX1    1           GETS RID OF A 1
          NZ     X1,MLI0     IF NOT SIGNON AND NOT SIGNOFF
          EQ     MLI7        JSN PROCESSING
          SKIP   6           LEAVE CODE IN JUST IN CASE....
          R=     X2,MLFON
          BX3    X1-X2
          ZR     X3,MLI7     IF SIGNON
          R=     X2,MLFOF
          BX3    X1-X2
          ZR     X3,MLI7     IF SIGNOFF
MLI0      BSS    0
          SA1    MLIA
          ZR     X1,MLI1     IF NOT TO ISSUE DAYFILE TRACE MESSAGE
          RJ     ITB
          SPACE  1
* ENTRY:
*  X1 = NTH REQUEST CODE (CVSMLI).
*  X2 = ADDRESS OF MLI REQUEST BLOCK.
*  X3 = MLI SUB-FUNCTION CODE (MLFSIN, MLFSPL).
*
* EXIT:
*  X0 = 0 IF REQUEST ACCEPTED AND COMPLETED.
*       1 IF QUEUE FULL.
*       2 IF REQUEST ACCEPTED BUT NOT COMPLETE.
*  X1 = 0 IF NOS/VE NOT UP, OTHERWISE UNCHANGED.
*  X4 = NTH SAVE REGISTER.  MUST NOTE BE DESTROYED.
          SPACE  1
 MLI1     SX4    0           CLEAR MLI INDEX
          MX6    0
          SA6    WCNT        ZERO CURRENT WAIT COUNT
          SX2    MLIPAR      PARAMETER BLOCK ADDRESS
          CALLVS X2,X4,MLIFTN,0
          ZR     X0,MLI12    IF REQUEST COMPLETE
          BX1    X0
          AX1    30
          NZ     X1,MLI5     IF NOS/VE DOWN
          SX0    X0-1
          NZ     X0,MLI11    IF REQUEST NOT COMPLETE.
          SPACE  1
* RECALL AND RE-ISSUE THE REQUEST
          SPACE  1
          IF     -DEF,RA.ORG
          SA5    MLV$MLI
          WAIT   X5           USER TIMED RECALL FOR NOS
          ELSE   1
          RECALL              PERIODIC RECALL FOR NOS/BE
          EQ     MLI1
          SPACE  1
* WAIT FOR THE REQUEST TO COMPLETE.  MUST USE PERIODIC RECALL BECAUSE
* AUTO RECALL WORKS ONLY WITH A PP.
          SPACE  1
MLI11     BSS    0
          SX6    -2
          SA6    NTHSR       SET NO WAIT
          IF     -DEF,RA.ORG
          SA5    MLV$MLI
          WAIT   X5          USER DEFINED RECALL PERIOD FOR NOS
          ELSE   1
          RECALL             SYSTEM DEFINED PERIODIC RECALL FOR NOS/BE
          SX1    MLIPAR      PARAMETER BLOCK ADDRESS
          CALLVS X1,X4,MLIFTN,0
          ZR     X0,MLI12    IF REQUEST COMPLETE
          AX0    30
          NZ     X0,MLI5     IF NOS/VE DOWN

* KLUDGE FOR GIM REQUESTS - TIMEOUT WAITING FOR REQUEST TO COMPLETE.

          SA1    WCNT
          SA2    MAXWAIT
          SX6    X1+1        WARNING: 18 BIT ADD
          SA6    A1
          IX6    X2-X6
          NZ     X6,MLI11    CHECK AGAIN

* SAVE WAITING ENVIRONMENT FOR LATER RESTART

          BX6    X4
          SA6    NTHSR
          MX6    0
          SA6    WCNT
          EQ     MLI5
          SPACE  1
MLI12     BSS    0
          SPACE  1
* END OF SPECIAL EIE CODE
          SPACE  1
          SA1    MLIPAR+MLPSV GET STATUS RETURNED
          SX2    X1-MLSBI    CHECK FOR BUSY INTERLOCK STATUS
          NZ     X2,MLI3     IF NOT BUSY INTERLOCK

* PROCESS BUSY STATUS.  RETRY SAME OPERATION A MAXIMUM OF MLEMXR TIMES.

          SA1    MLIRTC
          SX2    1
          IX6    X1+X2       INCREASE MLIRTC BY ONE
          SA6    A1
          SA1    MLIB
          SX6    X1+1
          SX2    X6-MLEMXR
          PL     X2,MLI2     IF TOO MANY RETRYS
          SA6    A1          UPDATE RETRY COUNT
          IF     -DEF,RA.ORG
          SA5    MLV$MLI
          WAIT   X5          USER DEFINED RECALL TIME FOR NOS
          ELSE   1
          RECALL             SYSTEM DEFINED RECALL TIME FOR NOS/BE
          EQ     MLI1

* RETRY LIMIT EXCEEDED.

MLI2      SA1    MLIA
          ZR     X1,MLI=X    IF NOT TO ISSUE DAYFILE TRACE MESSAGE.
          MESSAGE (=C* MLI RETRY LIMIT EXCEEDED. *),MLETDF,R

* RETURN TO CALLER.

MLI3      SA1    MLIA
          ZR     X1,MLI=X    IF NOT TO ISSUE DAYFILE TRACE MESSAGE
          RJ     ITA
          EQ     MLI=X

* PROCESS ILLEGAL MLI FUNCTION.

MLI4      BSS    0
          SX6    MLSIF
          SA6    MLIPAR+MLPSV  RETURN ILLEGAL FUNCTION STATUS
          SA1    MLIA
          ZR     X1,MLI=X    IF NOT TO ISSUE DAYFILE TRACE MESSAGE
          MESSAGE (=C* MLI ILLEGAL FUNCTION.*),MLETDF,R
          EQ     MLI=X
          SPACE  1
* EI RETURNED WITH X1=0 WHICH MEANS THAT NOS/VE IS NOT RUNNING.
          SPACE  1
MLI5      BSS    0
          SX6    MLSND
          SA6    MLIPAR+MLPSV  RETURN NOS/VE DOWN STATUS
          SA1    MLIA
          ZR     X1,MLI=X    IF NOT TO ISSUE DAYFILE TRACE MESSAGE
          MESSAGE (=C* NOS/VE DOWN.*),3,R
          EQ     MLI=X

* PROCESS SIGNON/SIGNOFF VIA MLI SUBSYSTEM

 MLI7     BSS    0
          SA1    MLID
          MX0    48
          BX6    X0*X1
          SA6    A1
          MX0    11
          CALLSS NVSI,MLID,R
          SA1    MLID
          LX0    12
          BX3    X1*X0
          ZR     X3,MLI3     IF NO ERROR
          SX0    12B         BIT 1 AND BIT 3
          BX3    X0*X1
          NZ     X3,MLI5     SUBSYSTEM NOT PRESENT OR NOT SCP

* PROCESS ERROR ON CALLSS REQUEST

          LX1    30
          RJ     CTO
          SA6    MLIF
          RJ     CTO
          SA6    MLIF+1
          MESSAGE MLIE,0,R
          ABORT
MLIE      DATA   20H MLI SUBSYS ERR =
MLIF      BSS    1
          BSS    1
          DATA   0

MLV$MLI   VFD    60/30B
MLIA      VFD    60/MLEITM   DAYFILE TRACE MESSAGE FLAG
MLIB      BSS    1           RETRY COUNT
MLID      VFD    24/0,12/0,6/MLEPBS,4/0,1/1,1/0,11/0,1/0
MLIPAR    BSS    MLEPBS      MLI PARAMETER BLOCK
MLIRTC    DATA   0           BUSY RETRY COUNT CUMULATIVE TOTAL
WCNT      DATA   0
MAXWAIT   DATA   -2
NTHSR     DATA   -2
ITB    SPACE  4
***       ITB - ISSUE DAYFILE TRACE MESSAGE BEFORE MLI REQUEST.
*
*         ENTRY  VALID FUNCTION SET IN THE MLIPAR BLOCK.
*
*         EXIT   DAYFILE MESSAGE OF THE FORMAT-
*                   MLI REQ XXXXX NNNNNN
*                ISSUED.  XXXXX IS A FUNCTION NAME - SIGNON, SIGNOFF,
*                ADDSPL, DELSPL, SEND, RECEIVE, FETCHRL, CONFIRM.
*                NNNNNN IS THE APPLICATION NAME MAKING THE REQUEST
*                DISPLAYED AS 20 OCTAL DIGITS.IF STO OPTION 2 IS ACTIVE,
*                THE MLI PARAMETER BLOCK IS WRITTEN TO FILE MLIDUMP.
*
*         USES   X - 0, 1, 2, 6.
*                B - NONE.
*                A - 1, 2, 6.
*
*         MACROS MESSAGE, SUBR, WRITEW.
*
*         CALLS  CTO.
          SPACE  2
ITB       SUBR               ENTRY/EXIT
          SA1    MLIPAR+MLPFN GET FUNCTION NUMBER
          SA2    X1+ITBA     GET FUNCTION NAME
          BX6    X2
          SA1    MLIPAR+MLPAN GET APPLICATION NAME
          LX1    30
          SA6    ITBC
          RJ     CTO         CONVERT LEFT HALF
          SA6    ITBC+1
          RJ     CTO         CONVERT RIGHT HALF
          SA6    ITBC+2
          MESSAGE ITBB,MLETDF,R
DUMP      IF     DEF,DUMPMLI

* OUTPUT PARAMETER BLOCK IF REQUESTED.

          SA1    MLIA        GET TRACE OPTION
          SX0    2
          BX2    X0-X1
          NZ     X2,ITBX     IF NOT TO DUMP MLIPAR BLOCK
          WRITEW MLIDUMP,MLIPAR,MLEPBS
          WRITER MLIDUMP,R
DUMP      ENDIF
          EQ     ITBX        RETURN

ITBA      BSS    0           FUNCTION NAME TABLE
          DATA   10HSIGNON
          DATA   10HSIGNOFF
          DATA   10HADDSPL
          DATA   10HDELSPL
          DATA   10HSEND
          DATA   10HRECEIVE
          DATA   10HFETCHRL
          DATA   10HCONFIRM
ITBB      DATA   10H MLI REQ
ITBC      BSS    3
          DATA   0
DUMP      IF     DEF,DUMPMLI
MLIDUMP   FILEB  DUMPB,501B
DUMPB     BSS    501B
DUMP      ENDIF
ITA    SPACE  4
***       ITA - ISSUE DAYFILE TRACE MESSAGE AFTER MLI REQUEST.
*
*         ENTRY  STATUS SET IN MLIPAR BLOCK.
*
*         EXIT   DAYFILE MESSAGE OF THE FORMAT-
*                   MLI STS DDDDDD
*                ISSUED.  DDDDDD IS A 20 DIGIT OCTAL NUMBER REPRESENTING
*                STATUS RETURNED BY MLI.
*
*         USES   X - 1, 6.
*                B - NONE.
*                A - 1, 6.
*
*         MACROS MESSAGE, SUBR.
*
*         CALLS  CTO.
          SPACE  2
ITA       SUBR               ENTRY/EXIT
          SA1    MLIPAR+MLPSV GET STATUS
          LX1    30          GET UPPER 30 BITS FOR CONVERSION
          RJ     CTO
          SA6    ITAB
          RJ     CTO
          SA6    ITAB+1
          MESSAGE ITAA,MLETDF,R
          EQ     ITAX        RETURN

ITAA      DATA   10H MLI STS
ITAB      BSS    2
          DATA   0
STO    SPACE  4
***       STO - SET TRACE OPTION.
*
*         ENTRY  (X6) = OPTION VALUE.  ZERO MEANS DO NOT ISSUE ANY TRACE
*                       MESSAGES. ONE MEANS ISSUE TRACE MESSAGES TO THE
*                       DAYFILE SPECIFIED BY THE SYMBOL MLETDF.
*                       TWO MEANS ISSUE TRACE MESSAGES (SAME AS ONE)
*                       AND WRITE THE MLIPAR BLOCK TO LOCAL FILE
*                       MLIDUMP. IF THE OLD VALUE IS TWO AND IT IS BEING
*                       CHANGED, A WRITER IS ISSUED TO THE MLIDUMP FILE.
*                       THE DUMP CAPABILITY IS ONLY ASSEMBLED INTO MLI=
*                       IF THE SYMBOL DUMPMLI IS DEFINED.
*
*         USES   X - 0, 1.
*                B - NONE.
*                A - 1, 6.
*
*         MACROS SUBR, MESSAGE, WRITER.
          SPACE  2
STO       SUBR               ENTRY/EXIT
          SA1    MLIA        GET CURRENT VALUE
          R=     X0,2
          BX0    X0-X1
          SA6    A1          STORE NEW OPTION VALUE
DUMP      IF     DEF,DUMPMLI
          NZ     X0,STO1     IF OLD VALUE WAS NOT TWO
          SX0    2
          BX0    X0-X6
          ZR     X0,STO1     IF NEW VALUE IS TWO

* FLUSH MLIDUMP BUFFER

          WRITER MLIDUMP,R
          SA1    MLIA        RESTORE OPTION VALUE
          BX6    X1
STO1      BSS    0
DUMP      ENDIF
          ZR     X6,STOX     IF TURNING OFF (NO MESSAGE)
          MESSAGE (=C* MLI TRACE ON. *),MLETDF,R
          EQ     STOX

          SKIP   2
STO2      MESSAGE (=C* MLI TRACE OFF. *),MLETDF,R
          EQ     STOX
CTO       SPACE  4
***       CTO - CONVERT THE RIGHTMOST 30 BITS FROM X1 TO 10 DISPLAY CODE
*               OCTAL DIGITS IN X6.
*
*         ENTRY  (X1) = VALUE TO CONVERT.
*
*         EXIT   (X6) = 10 DISPLAY CODE DIGITS.  NO ZERO SUPPRESSION.
*
*         USES   X - 1, 2, 3, 6, 7.
*                B - 2.
*                A - NONE.
*
*         MACROS SUBR.
          SPACE  2
CTO       SUBR               ENTRY/EXIT
          MX6    0           INITIALIZE ASSEMBLY
          MX2    -3          DIGIT MASK
          SB2    10          DIGIT COUNTER
CTO1      BX7    -X2*X1      GET DIGIT
          SB2    B2-1        DECREMENT DIGIT COUNT
          SX3    X7+1R0      CONVERT DIGIT TO CHARACTER
          LX6    54          POSITION ASSEMBLY
          AX1    3           SHIFT OFF DIGIT
          BX6    X6+X3       ADD CHARACTER TO ASSEMBLY
          NZ     B2,CTO1     IF MORE DIGITS
          LX6    54
          EQ     CTOX        RETURN
          SPACE  4
          BASE   *
QUAL$     IF     -DEF,QUAL$
          QUAL   *
MLV$MLI   EQU    /COMCMLI/MLV$MLI
MLI=      EQU    /COMCMLI/MLI=
STO       EQU    /COMCMLI/STO
MLIPAR    EQU    /COMCMLI/MLIPAR
MLIRTC    EQU    /COMCMLI/MLIRTC
MAXWAIT   EQU    /COMCMLI/MAXWAIT
QUAL$     ENDIF
          ENDX
*DECK DECK=MLA$MLASUS EXPAND=TRUE
          IDENT  MLASUS
          ENTRY  MLPSUS
MLPSUS     BSS    0
          JP     =XSW=MAIN
          END
*DECK DECK=MLAEI0 EXPAND=FALSE
EIEMOD    EQU        0                  .SET TO ZERO FOR BLDNG EI CODE
*DECK DECK=MLAEI1 EXPAND=FALSE
EIEMOD    EQU        1                  .SET TO ONE FOR BLDNG EIE CODE
*DECK DECK=MLD$ERROR_CODES EXPAND=FALSE

?? NEWTITLE := 'MLDECC  : Memory Link             : ''OS'' 5000 .. 5999' ??

?? OLDTITLE ??
*DECK DECK=MLD$JSN EXPAND=FALSE

  VAR
    mlv$jsn: [XREF] integer;
*DECK DECK=MLD$MEMORY_LINK_DECLARATIONS EXPAND=FALSE

?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc OST$STATUS
?? POP ??
  { External constant and type declarations for the NOS/VE memory link
  {interface. }

  CONST

    mlc$max_message_length = ((512*6)+2)*8,
    mlc$max_in_transit = 3,
    mlc$max_permits = 10,
    mlc$unique_name = 0,
    mlc$null_name = mlc$unique_name,
    mlc$max_signons_per_system_name = 6,
    mlc$max_queued_messages = 15;



  CONST

    mlc$error = 0,
{
    mlc$ant_full = mlc$error + 23,
{
{        This status value indicates that the maximum number of applications
{        are currently signed on to MLI.  The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$bad_c170_parameter = mlc$error + 27,
{
{        This status value indicates that a c170 parameter passed to mli by a
{        c170 job was invalid.  This can be due to a parameter value out of
{        range or because of an address beyond the c170 field length.
{
{        --------------------------------------------------------------
{
    mlc$busy_interlock = mlc$error + 5,
{
{        This status value indicates that one of the following interlocks was
{        found busy, and the request could not be completed:
{         - global interlock
{         - specific application interlock
{         - table space interlock
{         - pool space interlock
{
{        --------------------------------------------------------------
{
    mlc$c170_c170_illegal = mlc$error + 9,
{
{        This status value indicates that a SEND_MESSAGE is being attempted
{        between two applications, both of which are C170 applications.
{        The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$dup_permits_ignored = mlc$error + 6,
{
{        This status value indicates that an ADD_SENDER is being attempted for
{        the same application from the same receiver more than once.
{        The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$illegal_function = mlc$error + 26,
{
{        This status value indicates that a C170 mli request has specified an
{        illegal MLI function.  The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$max_msgs_too_large = mlc$error + 22,
{
{        This status value indicates that the max_messages parameter on a
{        SIGN_ON request is larger than mlc$max_queued_messages.
{        The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$max_signons_this_appl = mlc$error + 21,
{
{        This status value indicates that the application has tried to SIGN_ON
{        more than mlc$max_signons_per_appl times.  The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$max_signons_this_task = mlc$error + 24,
{
{        This status value indicates that a SIGN_ON request was attempted, but
{        the task making the request has already signed on
{        (mlc$max_signons_per_system_name) unique applications.
{        The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$message_too_long = mlc$error + 17,
{
{        This status value indicates that the length of the message specified
{        in a SEND_MESSAGE request is greater than mlc$max_message_length.
{        The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$message_truncated = mlc$error + 15,
{
{        This status value indicates that a RECEIVE_MESSAGE request was made,
{        but the buffer that is to receive the message text is smaller than
{        the actual message.  The request is completed normally, but only as
{        much of the message is transferred as will fit in the buffer.
{
{        --------------------------------------------------------------
{
    mlc$mli_internal_error = mlc$error + 25,
{
{        This status value indicates that some sort of internal error has
{        occurred within MLI.  The request may be retried, but the results
{        are unpredictable.
{
{        --------------------------------------------------------------
{
    mlc$msgs_from_sender_queued = mlc$error + 13,
{
{        This status value indicates that a DELETE_SENDER request is being
{        performed while there are messages queued from this sender.  The
{        request is completed normally, and the messages remain queued.
{
{        --------------------------------------------------------------
{
    mlc$nosve_not_up = mlc$error + 28,
{
{        This status value indicates that a memory link request was performed
{        by a c170 job and that the nos/ve system was not running at the time.
{        The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$ok = mlc$error + 0,
{
{        This status value indicates that the request completed without error.
{
{        --------------------------------------------------------------
{
    mlc$permit_list_full = mlc$error + 7,
{
{        This status value indicates that an ADD_SENDER request is being
{        performed, but the permit list of the receiver is full.
{        The maximum number of permits is specified by mlc$max_permits.
{        The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$pool_buffer_not_avail = mlc$error + 18,
{
{        This status value indicates that space for either a table (SIGN_ON
{        request) or a message (SEND_MESSAGE request) could not be obtained.
{        The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$prior_msg_not_received = mlc$error + 11,
{
{        This status value indicates that a SEND_MESSAGE was attempted between
{        two applications, but the number of unreceived messages from the sender
{        to the receiver equals mlc$max_in_transit.  The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$queued_msgs_lost = mlc$error + 20,
{
{        This status value indicates that messages were lost (thrown away)
{        because the application did a SIGN_OFF request while there were
{        messages still queued to it.  The request is completed normally but
{        all messages that were queued to the application are lost.
{
{        --------------------------------------------------------------
{
    mlc$receiver_name_syntax_error = mlc$error + 1,
{
{        This status value indicates that the application name of the receiver
{        is not valid.  Currently, the only invalid value is -1.
{        The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$receiver_not_signed_on = mlc$error + 3,
{
{        This status value indicates that the receiver application is not
{        currently signed on to MLI.  The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$receive_list_full = mlc$error + 12,
{
{        This status value indicates that maximum number of messages are queued
{        for the receiver application, so no more may be sent to it.
{        The maximum number of queued messages is specified by the receiver
{        application, but is never larger than mlc$max_queued_messages.
{        The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$receive_list_index_invalid = mlc$error + 14,
{
{        This status value indicates that a RECEIVE_MESSAGE request was made,
{        but the receive index specified pointed to a receive entry that does
{        not contain a message ready to be received.  This includes the case
{        where the index is greater than mlc$max_queued_messages.
{        The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$sender_name_syntax_error = mlc$error + 2,
{
{        This status value indicates that the application name of the sender is
{        not valid.  Currently, the only invalid value is -1.
{        The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$sender_not_permitted = mlc$error + 10,
{
{        This status value indicates that the sender application has not been
{        granted permission by the receiver application to send messages to it
{        (CONFIRM_MESSAGE or SEND_MESSAGE request) or that a DELETE_SENDER
{        request is being performed for an application not currently permitted.
{        The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$sender_not_signed_on = mlc$error + 8,
{
{        This status value indicates that the sender application being
{        referenced is not currently signed on to MLI.  The request is ignored.
{
{        --------------------------------------------------------------
{
    mlc$signal_failed_ignored = mlc$error + 19,
{
{        This status value indicates that for some reason, a PMP$SEND_SIGNAL
{        request failed (SEND_MESSAGE and RECEIVE_MESSAGE requests).
{        The request is completed normally.
{
{        --------------------------------------------------------------
{
    mlc$signal_to_c170_ignored = mlc$error + 16,
{
{        This status value indicates that a SEND_MESSAGE or RECEIVE_MESSAGE
{        request with the signal option specified as TRUE was performed, but
{        the application to receive the signal was a C170 application.
{        The request is completed normally, but no signal is sent.
{
{        --------------------------------------------------------------
{
    mlc$max_job_signons = mlc$error + 29,
{
{ The maximum number of signons for all tasks in this job has been exceeded
{
    mlc$system_name_no_match = mlc$error + 4;
{
{        This status value indicates that the application name specified is
{        signed on to MLI, but by a different task than the one making the
{        request, i.e. the requesting task is not the owner of the application.
{        The request is ignored.
{
{        --------------------------------------------------------------
{

  TYPE

{
{ An application name is defined as follows:
{   C170 default = the jsn used as a 24 bit integer.
{   C170 predefined = 5 display code characters used as a 30 bit integer.
{   C180 default = the task_id of the executing task, used as a 16 bit
{                  integer as follows:  (index * 2 ** 8) + seqno.
{   C180 predefined = 5 ascii characters used as a 40 bit integer.
{   Note that all application names must contain zeros in the upper nine bits.

    mlt$application_name = integer,
    mlt$arbitrary_info = integer,
    mlt$max_messages = 0 .. mlc$max_queued_messages,
    mlt$message_length = 0 .. mlc$max_message_length,
    mlt$receive_index = 0 .. mlc$max_queued_messages,
    mlt$receive_count = 0 .. mlc$max_queued_messages,
    mlt$receive_list = array [1 .. mlc$max_queued_messages] of
      mlt$receive_entry,
    mlt$receive_entry = packed record
{  this record is defined so that the fields and values will be aligned
{  the same for both c170 and c180 users.  using full word integers is
{  the simplest way to do this.  note that some range checking is avoided.
      sender_name: ALIGNED [0 MOD 8] integer,
      arbitrary_info: integer,
      message_length: integer,
      receive_index: integer,
    recend,
    mlt$signal = ^mlt$signal_record,
    mlt$message_ptr = ^cell,
    mlt$direction = (mlc$send, mlc$receive),
    mlt$signal_record = packed record
      pad: 0 .. 0f(16),
      data: packed array [1 .. 7] of 0 .. 0ff(16),
      direction: mlt$direction,
    recend,
    mlt$signaler_application_info = record
      application_name: mlt$application_name,
      global_task_id: ost$global_task_id,
    recend,
    mlt$handler = ^procedure (signalee: mlt$application_name;
      signaler: mlt$signaler_application_info;
      signal: mlt$signal;
      VAR status: ost$status),
    mlt$status = mlc$ok .. mlc$nosve_not_up;

  CONST

    mlc$sign_on_req = 1,
    mlc$sign_off_req = 2,
    mlc$add_sender_req = 3,
    mlc$delete_sender_req = 4,
    mlc$confirm_send_req = 5,
    mlc$send_message_req = 6,
    mlc$fetch_receive_list_req = 7,
    mlc$receive_message_req = 8,
    mlc$fetch_link_partner_info_req = 9;

  TYPE
    mlt$operation = record
      req: mlc$sign_on_req .. mlc$fetch_link_partner_info_req,
      stat_condition: ost$status_condition,
    recend;
*DECK DECK=MLH$ADD_SENDER EXPAND=FALSE
{
{   The purpose of this request is to provide a means for an application
{ to permit another application to send messages to it.  MLI adds the
{ sender application's name to the list of applications which are
{ permitted to send messages to it.
{
{        MLP$ADD_SENDER (APPLICATION_NAME, SENDER_NAME, STATUS)
{
{ APPLICATION_NAME: (input) This parameter specifies the application
{        name by which the calling program identifies itself to MLI and
{        other applications.
{
{ SENDER_NAME: (input) This parameter specifies the name of the application
{        which the calling application is allowing to send messages to it.
{        If a NULL value is given for this parameter, public permission
{        to send messages to the calling application will be granted (i.e.,
{        any application will be allowed to send messages to it).
{
{ STATUS: (output) This parameter specifies the request status.
{        The following status values may be returned by this request:
{           mlc$busy_interlock
{           mlc$dup_permits_ignored
{           mlc$ok
{           mlc$permit_list_full
{           mlc$receiver_name_syntax_error
{           mlc$receiver_not_signed_on
{           mlc$sender_name_syntax_error
{           mlc$system_name_no_match
{

*DECK DECK=MLH$CONFIRM_SEND EXPAND=FALSE
{
{   The purpose of this request is to provide a means for an application
{ to determine whether or not a message can be sent to a specified
{ destination application.  MLI determines whether or not a message can
{ be sent to the specified application and returns a status value. It can
{ be used before sending a message to determine whether a MLP$SEND_MESSAGE
{ request may be issued or it can be used after a MLP$SEND_MESSAGE to
{ determine whether or not the message has been received.  It can be used
{ for the latter purpose since only one unreceived message can be queued
{ up for the destination application at a time.
{
{        MLP$CONFIRM_SEND (APPLICATION_NAME, DESTINATION_NAME, STATUS)
{
{ APPLICATION_NAME: (input) This parameter specifies the application
{        name by which the calling application identifies itself to MLI
{        and other applications.
{
{ DESTINATION_NAME: (input) This parameter specifies the name of the
{        destination application for which it is to be determined
{        whether or not a message can be sent.
{
{ STATUS: (output) This parameter specifies the request status. A normal
{        status value will be returned to indicate that a message can be
{        sent. An abnormal status which includes the reason ( receiver
{        not signed on, sender not permitted to send, previous message
{        not received etc. ) will be returned to indicate that a message
{        cannot be sent.
{        The following status values may be returned by this request:
{           mlc$busy_interlock
{           mlc$c170_c170_illegal
{           mlc$mli_internal_error
{           mlc$ok
{           mlc$prior_msg_not_received
{           mlc$receiver_name_syntax_error
{           mlc$receiver_not_signed_on
{           mlc$receive_list_full
{           mlc$sender_name_syntax_error
{           mlc$sender_not_permitted
{           mlc$sender_not_signed_on
{           mlc$system_name_no_match
{

*DECK DECK=MLH$DELETE_SENDER EXPAND=FALSE
{
{   The purpose of this request is to provide a means for an application
{ to cancel permission for an application to send messages to it.  MLI
{ deletes the sender application name from the list of applications which
{ are permitted to send messages to it.  If messages from the sender are
{ queued for the calling application, they will not be discarded
{ although an error status will be returned and permission to send
{ additional messages will be cancelled. If the receiving application does
{ not issue an MLP$RECEIVE_MESSAGE request to obtain them, they will be
{ deleted when the receiving application signs off.
{
{        MLP$DELETE_SENDER (APPLICATION_NAME, SENDER_NAME, STATUS)
{
{ APPLICATION_NAME: (input) This parameter specifies the application
{        name by which the calling application program identifies itself
{        to MLI and other applications.
{
{ SENDER_NAME: (input) This parameter specifies the name of the application
{        for which permission to send messages to the calling
{        application is to be cancelled.  If a NULL value is given for
{        this parameter, public permission to send messages to this
{        application will be cancelled but specific applications which
{        have been granted permission to send messages to this
{        application will not be cancelled.  An error status will be
{        returned if the sender is not currently granted permission to
{        send messages to the calling application.
{
{ STATUS: (output) This parameter specifies the request status.
{        The following status values may be returned by this request:
{           mlc$busy_interlock
{           mlc$msgs_from_sender_queued
{           mlc$ok
{           mlc$receiver_name_syntax_error
{           mlc$receiver_not_signed_on
{           mlc$sender_name_syntax_error
{           mlc$sender_not_permitted
{           mlc$system_name_no_match
{

*DECK DECK=MLH$FETCH_LINK_PARTNER_INFO EXPAND=FALSE
{
{   The purpose of this request is to allow an application to determine
{ whether a partner application is still signed on and if so, what its
{ last memory_link operation was.
{
{        MLP$FETCH_LINK_PARTNER_INFO (APPLICATION_NAME, PARTNER_NAME
{            LAST_OP,STATUS)
{
{ APPLICATION_NAME: (input) This parameter specifies the application
{        name by which the calling application identifies itself to MLI
{        and other applications.
{
{ PARTNER_NAME: (input) This parameter specifies the name of the partner
{        application whose last operation is to be determined.
{
{ LAST_OP: (output) This parameter specifies the last memory link
{        operation requested by the partner application. One of the
{        following values will be returned by this request:
{           mlc$sign_on_req
{           mlc$sign_off_req
{           mlc$add_sender_req
{           mlc$delete_sender_req
{           mlc$confirm_send_req
{           mlc$send_message_req
{           mlc$fetch_receive_list_req
{           mlc$receive_message_req
{           mlc$fetch_link_partner_info_req
{
{ STATUS: (output) This parameter specifies the request status. A normal
{        status value will be returned to indicate that the partner
{        application is still signed on. An abnormal status will be
{        returned to indicate that the partner application is not
{        signed on.
{        The following status values may be returned by this request:
{           mlc$busy_interlock
{           mlc$c170_c170_illegal
{           mlc$mli_internal_error
{           mlc$ok
{           mlc$receiver_name_syntax_error
{           mlc$receiver_not_signed_on
{           mlc$sender_name_syntax_error
{           mlc$sender_not_permitted
{           mlc$sender_not_signed_on
{           mlc$system_name_no_match
{

*DECK DECK=MLH$FETCH_RECEIVE_LIST EXPAND=FALSE
{
{   The purpose of this request is to obtain a list of messages which
{ have been sent to the application and are waiting to be received.
{ Information for all queued messages or only those sent by a
{ particular application can be requested.
{
{        MLP$FETCH_RECEIVE_LIST (APPLICATION_NAME, SENDER_NAME,
{            RECEIVE_LIST, RECEIVE_COUNT, STATUS)
{
{ APPLICATION_NAME: (input) This parameter specifies the application
{        name by which the calling application identifies itself to MLI
{        and other applications.
{
{ SENDER_NAME: (input) This parameter specifies the name of the sending
{        application for which information is requested about messages
{        that it has sent to the calling application.  If a NULL value
{        is given for this parameter, information about messages from
{        all sending applications will be returned.
{
{ RECEIVE_LIST: (output) This parameter specifies an array in the
{        calling program's address space into which records containing
{        information about waiting messages are to be placed.  If the
{        array is not large enough to hold all of the receive list
{        entries, the number of entries returned will be truncated and
{        an error status will be returned.
{
{ RECEIVE_COUNT: (output) This parameter contains a count of the number
{        of waiting messages for which information has been put into
{        records in the receive list array.
{
{ STATUS: (output) This parameter specifies the request status.
{        The following status values may be returned by this request:
{           mlc$busy_interlock
{           mlc$ok
{           mlc$receiver_name_syntax_error
{           mlc$receiver_not_signed_on
{           mlc$sender_name_syntax_error
{           mlc$system_name_no_match
{

*DECK DECK=MLH$HANDLE_SIGNAL EXPAND=FALSE
{   The purpose of this request is to process signals sent from one task
{ to another via the memory link interface.  Memory link signals are
{ taken by this routine and mapped to a 'sub-signal handler'.  This
{ handler is associated with a given memory link application via the
{ mlp$register_signal_handler request.
{
{        MLP$HANDLE_SIGNAL (ORIGINATOR, SIGNAL)
{
{ ORIGINATOR: (input) This parameter specifies the sender of the signal.
{
{ SIGNAL: (input) This parameter specifies the received signal.
{
*DECK DECK=MLH$RECEIVE_MESSAGE EXPAND=FALSE
{
{   The purpose of this request is to receive a specified message which
{ has been sent to the application.
{
{        MLP$RECEIVE_MESSAGE (APPLICATION_NAME, ARBITRARY_INFO,
{            SIGNAL, MESSAGE_AREA, MESSAGE_LENGTH, MESSAGE_AREA_LENGTH,
{            RECEIVE_INDEX, SENDER_NAME, STATUS)
{
{ APPLICATION_NAME: (input) This parameter specifies the application name
{        by which the calling application identifies itself to MLI and
{        other applications.
{
{ ARBITRARY_INFO: (output) This parameter contains the piece of arbitrary
{        information which is associated with but not a part of the
{        message itself.  The arbitrary information is also contained
{        in the entry for the message which is returned by the
{        MLP$FETCH_RECEIVE_LIST request.
{
{ SIGNAL: (input) This parameter specifies whether or not the sending
{        application should be signaled to notify it that the message has
{        been received.  The option to signal the sending application is not
{        available if the sending application is a C170 application.
{
{ MESSAGE_AREA: (input) This parameter specifies the location in the
{        calling program's address space into which the message is to
{        be transferred.  If the message was sent by a C170 application,
{        only the rightmost 60 bits of each string of 64 bits will contain
{        valid data with the leftmost 4 bits set to zero.
{
{ MESSAGE_LENGTH: (output) This parameter contains the number of 8 bit
{        bytes of message data which were transferred.
{
{ MESSAGE_AREA_LENGTH: (input) This parameter specifies the size in 8
{        bit bytes of the MESSAGE_AREA.  If the length of the message
{        exceeds this value, the message will be truncated and an error
{        status returned.
{
{ RECEIVE_INDEX: (input) This parameter is contained in the receive list
{        records returned by MLP$FETCH_RECEIVE_LIST and identifies the
{        particular message that is to be received.  If the value is zero then
{        the "oldest" message will be returned.  If no messages are queued
{        then the status mlc$receive_list_index_invalid is returned.
{
{ SENDER_NAME: (output) This parameter contains the application name of
{        the application that sent the message being received.
{
{ STATUS: (output) This parameter specifies the request status.
{        The following status values may be returned by this request:
{           mlc$busy_interlock
{           mlc$message_truncated
{           mlc$ok
{           mlc$receiver_name_syntax_error
{           mlc$receiver_not_signed_on
{           mlc$receive_list_index_invalid
{           mlc$signal_failed_ignored
{           mlc$signal_to_c170_ignored
{           mlc$system_name_no_match
{

*DECK DECK=MLH$REGISTER_SIGNAL_HANDLER EXPAND=FALSE
{
{   The purpose of this request is to allow an application to register a
{ procedure with MLI which will be invoked whenever another application
{ performs an mlp$send_message or mlp$receive_message request specifying
{ that a signal is to be sent.
{
{        MLP$REGISTER_SIGNAL_HANDLER (APPLICATION_NAME, HANDLER, STATUS)
{
{ APPLICATION_NAME: (input) This parameter specifies the application
{        name by which the calling program identifies itself to MLI and
{        other applications.
{
{ HANDLER: (input) This parameter specifies a pointer to procedure which
{        will be invoked (called) whenever an mlp$send_message or
{        mlp$receive_message request causes a signal to be sent to this
{        application.
{
{ STATUS: (output) This parameter specifies the request status.
{        The following status values may be returned by this request:
{           mlc$busy_interlock
{           mlc$receiver_name_syntax_error
{           mlc$receiver_not_signed_on
{           mlc$system_name_no_match
{
*DECK DECK=MLH$SEND_MESSAGE EXPAND=FALSE
{
{   The purpose of this request is to send a message to a specified
{ destination application.
{
{        MLP$SEND_MESSAGE (APPLICATION_NAME, ARBITRARY_INFO,
{            SIGNAL, MESSAGE_ADDRESS, MESSAGE_LENGTH,
{            DESTINATION_NAME, STATUS)
{
{ APPLICATION_NAME: (input) This parameter specifies the application
{        name by which the calling application identifies itself to
{        MLI and other applications.
{
{ ARBITRARY_INFO: (input) This parameter specifies a piece of arbitrary
{        information which is associated with the message but is not
{        part of the message itself.  It is up to the sending and
{        receiving application to define the meaning of this information.
{
{ SIGNAL: (input) This parameter specifies whether or not the destination
{        application should be signaled to notify it that a message is
{        available.  The option to signal the destination application is not
{        available if the destination application is a C170 application.
{
{ MESSAGE_AREA: (input) This parameter specifies the location which
{        contains the message to be transferred.  If the message is
{        sent to a C170 application, only the rightmost 60 bits of each
{        string of 64 bits will be moved to C170 memory.
{
{ MESSAGE_LENGTH: (input) This parameter specifies the size in 8 bit
{       bytes of the message to be sent.
{
{ DESTINATION_NAME: (input) This parameter specifies the name of the
{        destination application to which the message is to be sent.
{
{ STATUS: (output) This parameter specifies the request status.
{        The following status values may be returned by this request:
{           mlc$busy_interlock
{           mlc$c170_c170_illegal
{           mlc$message_too_long
{           mlc$mli_internal_error
{           mlc$ok
{           mlc$pool_buffer_not_avail
{           mlc$prior_msg_not_received
{           mlc$receiver_name_syntax_error
{           mlc$receiver_not_signed_on
{           mlc$receive_list_full
{           mlc$sender_name_syntax_error
{           mlc$sender_not_permitted
{           mlc$sender_not_signed_on
{           mlc$signal_failed_ignored
{           mlc$signal_to_c170_ignored
{           mlc$system_name_no_match
{

*DECK DECK=MLH$SIGN_OFF EXPAND=FALSE
{
{   The purpose of this request is to allow an application to sever its
{ association with MLI so that other applications can no longer send
{ messages to it.
{
{        MLP$SIGN_OFF (APPLICATION_NAME, STATUS)
{
{ APPLICATION_NAME: (input) This parameter specifies the application
{        name by which the calling program identifies itself to MLI and
{        other applications.
{
{ STATUS: (output) This parameter specifies the request status.
{        The following status values may be returned by this request:
{           mlc$busy_interlock
{           mlc$mli_internal_error
{           mlc$ok
{           mlc$queued_msgs_lost
{           mlc$receiver_name_syntax_error
{           mlc$receiver_not_signed_on
{           mlc$system_name_no_match
{

*DECK DECK=MLH$SIGN_ON EXPAND=FALSE
{   The purpose of this request is to allow an application to identify
{ itself to MLI so that other applications can send messages to it.
{ MLI records the name of the application and initializes internal
{ tables which are used for MLI communication.
{
{        MLP$SIGN_ON (APPLICATION_NAME, MAX_MESSAGES, UNIQUE_APPLICATION_NAME,
{          STATUS)
{
{ APPLICATION_NAME: (input) This parameter specifies the application
{        name by which the calling program wishes to be identified to
{        MLI and other applications.  If a NULL value is given for this
{        parameter, a unique name will be generated by MLI and returned
{        in the unique_application_name parameter.
{
{ MAX_MESSAGES: (input) This parameter specifies the maximum number of
{        messages that can be sent to the application at one time (i.e.,
{        the maximum number of unreceived messages that can be queued
{        for the application). If the value of this parameter is zero then
{        a maximum of mlc$max_in_transit messages will be queued from the
{        same or different senders.  This is the only condition where a
{        sender can have more than one message outstanding to the same
{        receiver.  The maximum value for this parameter is mlc$max_queued_messages.
{
{ UNIQUE_APPLICATION_NAME: (output) If the value of the application_name parameter
{        is mlc$unique_name then this parameter will contain a unique application
{        name which must be used on all other mlp$ requests when referencing this
{        "instance" of sign on.  If the value of the application_name parameter
{        is not mlc$unique_name then this parameter will contain a copy of the
{        application_name parameter.
{
{ STATUS: (output) This parameter specifies the request status.
{        The following status values may be returned by this request:
{           mlc$ant_full
{           mlc$busy_interlock
{           mlc$max_msgs_too_large
{           mlc$max_signons_this_appl
{           mlc$max_signons_this_task
{           mlc$mli_internal_error
{           mlc$ok
{           mlc$pool_buffer_not_avail
{           mlc$receiver_name_syntax_error
{           mlc$system_name_no_match
{

*DECK DECK=MLH$TASK_TERMINATION_CLEANUP EXPAND=FALSE
{   The purpose of this request is to force a sign_off of all applications
{ signed_on by the calling task.  It is meant to be used at task termination
{ time to make sure that the memory link environment is cleaned up.  This
{ request will wait until the entire clean up is complete.
{
{        MLP$TASK_TERMINATION_CLEANUP
{
*DECK DECK=MLK$KEYPOINTS EXPAND=FALSE

{  Purpose:
{    This deck contains all of the memory link keypoint constants.
{

  CONST

    mlk$add_sender = mlk$base + 1,
    {E 'mlp$add_sender'}
    {X 'mlp$add_sender' 'status' I20}


    mlk$confirm_send = mlk$base + 2,
    {E 'mlp$confirm_sender'}
    {X 'mlp$confirm_sender' 'status' I20}


    mlk$delete_sender = mlk$base + 3,
    {E 'mlp$delete_sender'}
    {X 'mlp$delete_sender' 'status' I20}


    mlk$fetch_receive_list = mlk$base + 4,
    {E 'mlp$fetch_receive_list'}
    {X 'mlp$fetch_receive_list' 'status' I20}


    mlk$get_handler_info = mlk$base + 5,
    {E 'mlp$get_handler_info_os'}
    {X 'mlp$get_handler_info_os' 'status' I20}


    mlk$receive_message = mlk$base + 6,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'ML_get_response_from_ds_network'}
    {X 'ML_get_response_from_ds_network' 'status' I20}
*ELSE
    {E 'mlp$receive_message'}
    {X 'mlp$receive_message' 'status' I20}
*IFEND

    mlk$register_signal_handler = mlk$base + 7,
    {E 'mlp$register_signal_handler'}
    {X 'mlp$register_signal_handler' 'status' I20}


    mlk$send_message = mlk$base + 8,
    {E 'mlp$send_massage'}
    {X 'mlp$send_message' 'status' I20}


    mlk$sign_off = mlk$base + 9,
    {E 'mlp$sign_off'}
    {X 'mlp$sign_off' 'status' I20}


    mlk$sign_on = mlk$base + 10,
    {E 'mlp$sign_on'}
    {X 'mlp$sign_on' 'status' I20}


    mlk$fetch_link_partner_info = mlk$base + 11,
    {E 'mlp$fetch_link_partner_info'}
    {X 'mlp${fetch_link_partner_info' 'status' I20}



    mlk$memory_link_error_code = mlk$base + 21,
    {D 'memory link error code' 'error' I20}


    mlk$send_msg_send_signal = mlk$base + 22,
    {D 'sending message send signal'}


    mlk$send_message_signal_error = mlk$base + 23,
    {D 'send message signal error' 'status' I20}


    mlk$rec_message_send_signal = mlk$base + 24,
    {D 'receive message sending signal'}


    mlk$rec_message_signal_error = mlk$base + 25;

  {D 'receive message signal error' 'status' I20}

?? PUSH (LISTEXT := ON) ??
*copyc AMK$BASE_KEYPOINT_VALUES
?? POP ??
*DECK DECK=MLM$C170_HELPER EXPAND=TRUE

MODULE mlm$c170_helper;
*copyc OSD$DEFAULT_PRAGMATS
?? SET (LIST := OFF) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc MLT$ANT_ENTRY
*copyc MTXMS
*copyc OST$STATUS
*copyc TMT$RB_READY_TASK
*copyc mmp$free_pages
*copyc tmp$set_task_priority
*copyc SYC$MONITOR_REQUEST_CODES
*copyc I#CALL_MONITOR
*copyc osp$set_mainframe_sig_lock
*copyc osp$clear_mainframe_sig_lock
*copyc jmc$special_dispatch_priorities
*copyc osp$free_heap_pages
*copyc PMP$GET_EXECUTING_TASK_GTID
*copyc PMP$ZERO_OUT_TABLE
?? SET (LIST := ON) ??

*copyc osp$fetch_locked_variable
*copyc osp$set_locked_variable
*copyc MLT$C170_RQST_BLK

  VAR
    mlv$debug: [XREF] boolean,
    mlv$170_count: [XREF] integer,
    mlv$170_time: [XREF] integer,
    mlv$wire_mli_tables: [XDCL] boolean := FALSE,
    mlv$lock: [XREF] ost$signature_lock,
    mlv$rb_ready_task: [XREF] tmt$rb_ready_task,
    mlv$polling_delay: [XREF] integer,
{    str: string (46) := '                     ',
{    str_p: integer := 1,
    status: ost$status,
    mlv$c170_rqst_blk: [XREF] mlt$c170_rqst_blk,
    sn: mlt$system_name,
    current_request: integer,
    mlv$enabled: [XREF] boolean,
    onoff: boolean,
    mlv$count: integer := 0,
    mlv$stream: integer := 0,
    mlv$last_available: [XDCL, #GATE] integer := initial_buffer_count - 1,
    mlv$expand_count: [XDCL, #GATE] integer := 200,
    mlv$shrink_count: [XDCL, #GATE] integer := 20,
    check_count,
    check_time: integer := 0,
    mlv$s,
    mlv$e: [XDCL, #GATE] integer := 0,
    mlv$shared_segment: [XREF] mlt$shared_segment;

  PROCEDURE [XREF] mlp$kill (sn: mlt$system_name;
    VAR status: ost$status);
*copyc I#PROGRAM_ERROR
{*callc pmxlogj
{*callc rpmbina

{  PROCEDURE pt (s: string ( * );
{    done: boolean);
{
{    VAR
{      i: integer,
{      st: ost$status;
{
{    i := STRLENGTH (s);
{    str (str_p, i) := s (1, * );
{    str_p := str_p + i;
{    IF done THEN
{      { pmp$log (str, st);
{      str (1, * ) := '          ';
{      str_p := 1;
{    IFEND;
{  PROCEND pt;
{
{  PROCEDURE pi (val: integer;
{    done: boolean);
{
{    VAR
{      st: ost$status;
{
{    pmp$binary_to_ascii (val, str, 8, str_p + 21);
{    str_p := str_p + 21;
{    IF done THEN
{      { pmp$log (str, st);
{      str (1, * ) := '         ';
{      str_p := 1;
{    IFEND;
{  PROCEND pi;

?? EJECT ??

  PROCEDURE [XDCL, #GATE] mlp$initialize_helper;

    VAR
      status: ost$status;

    IF NOT mlv$enabled THEN
      RETURN;
    IFEND;
{
{ save helper taskid for use by eie
{ raise helper task priority
{
    pmp$get_executing_task_gtid (mlv$rb_ready_task.task_id);
    mlv$shared_segment.dust_id := mlv$rb_ready_task.task_id;
    tmp$set_task_priority (jmc$priority_mli_helper, 0, status);
    mlv$rb_ready_task.reqcode := syc$rc_ready_task;
    mlv$c170_rqst_blk.req := ^mlv$rb_ready_task;
    check_time := #free_running_clock (0);
  PROCEND mlp$initialize_helper;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] mlp$help_c170;

    VAR
      time: integer,
      status: ost$status,
      actual,
      result,
      num: integer,
      op_status_value: integer,
      actual_op_status: integer,
      op_status_locked: boolean,
      none: boolean;

    num := 0;
    mtv$mli_status.wait_inhibit := FALSE;
    REPEAT
      none := TRUE;
      FOR current_request := 0 TO mlimi - 1 DO
        osp$fetch_locked_variable(mlv$c170_rqst_blk.arr [current_request].op_status,
             op_status_value);
        IF op_status_value = wait180 THEN
{
{ process the mli request
{
          mlp$front_end;
          mlv$count := mlv$count + 1;
          num := num + 1;
          time := #free_running_clock (0);
          mlv$c170_rqst_blk.arr [current_request].time := time;

{ set the current entry op_status to wait for 170

          osp$set_locked_variable (mlv$c170_rqst_blk.arr [current_request].op_status,
                wait180, wait170, actual_op_status, op_status_locked);
          IF NOT op_status_locked THEN
            osp$set_locked_variable (mlv$c170_rqst_blk.arr [current_request].op_status,
                  actual_op_status, wait170, actual_op_status, op_status_locked);
          IFEND;
        IFEND;
      FOREND;
    UNTIL none;
    IF num > 1 THEN
      mlv$stream := mlv$stream + num;
    IFEND;

{ check for expand/shrink every 2 minutes

    IF #free_running_clock (0) - check_time > 120000000 THEN
      IF mlv$wire_mli_tables THEN
        osp$set_mainframe_sig_lock (mlv$lock);
        osp$free_heap_pages (#LOC (mlv$shared_segment.pspace));
        osp$clear_mainframe_sig_lock (mlv$lock);
      IFEND;
      check_time := #free_running_clock (0);
      IF mlv$c170_rqst_blk.arr [mlv$last_available].used - check_count <
            mlv$shrink_count THEN
        IF mlv$last_available > (initial_buffer_count - 1) THEN
          #compare_swap (mlv$c170_rqst_blk.arr [mlv$last_available].op_status,
                idle, not_available, actual, result);
          IF result = 0 THEN
            mlv$s := mlv$s + 1;
            mlv$last_available := mlv$last_available - 1;
            mmp$free_pages (#LOC (mlv$c170_rqst_blk.buffers^
                  [mlv$last_available + 1]), (mlimi - (mlv$last_available + 1))
                  * (mlc$max_message_length + 1), osc$nowait, status);
            check_count := mlv$c170_rqst_blk.arr [mlv$last_available].used;
          IFEND;
        IFEND;
      IFEND;
      IF mlv$c170_rqst_blk.arr [mlv$last_available].used - check_count >
            mlv$expand_count THEN
        IF mlv$last_available < (mlimi - 1) THEN
          mlv$last_available := mlv$last_available + 1;
          mlv$e := mlv$e + 1;
          pmp$zero_out_table (#LOC (mlv$c170_rqst_blk.buffers^
                [mlv$last_available]), mlc$max_message_length + 1);
          mlv$c170_rqst_blk.arr [mlv$last_available].used := 0;
          mlv$c170_rqst_blk.arr [mlv$last_available].op_status := idle;
        IFEND;
      IFEND;
      check_count := mlv$c170_rqst_blk.arr [mlv$last_available].used;
    IFEND;

  PROCEND mlp$help_c170;

?? EJECT ??

  PROCEDURE mlp$front_end;
?? SET (LIST := OFF) ??
*copyc MLP$SIGN_ON_OS
?? SET (LIST := ON) ??

    VAR
      i: integer,
      time: integer,
      rl: ^mlt$receive_list,
      unique: ^mlt$application_name,
      psig: mlt$signal,
      rc: mlt$receive_count,
      pc: ^cell,
      ml: mlt$message_length,
      cond: ost$status_condition,
      ost: ost$status;

  /mli/
    BEGIN
      mlv$c170_rqst_blk.arr [current_request].copy_length := 0;
      onoff := FALSE;
      CASE mlv$c170_rqst_blk.arr [current_request].mli_packet [funct] OF
      = signon =
        onoff := TRUE;
        IF mlv$c170_rqst_blk.arr [current_request].jsn MOD 100(16) = 7 THEN
          mlp$sign_on_os (mlv$c170_rqst_blk.arr [current_request].mli_packet
                [aname], mlv$c170_rqst_blk.arr [current_request].mli_packet
                [maxmsg], mlv$c170_rqst_blk.arr [current_request].mli_packet
                [mlpv1], ost);
        ELSE
          ost.condition := mlc$illegal_function;
          EXIT /mli/;
        IFEND;
      = signoff =
        onoff := TRUE;
        IF mlv$c170_rqst_blk.arr [current_request].jsn MOD 100(16) = 7 THEN
          mlp$sign_off_os (mlv$c170_rqst_blk.arr [current_request].mli_packet
                [aname], ost);
        ELSE
          ost.condition := mlc$illegal_function;
          EXIT /mli/;
        IFEND;
      = addspl =
        mlp$add_sender_os (mlv$c170_rqst_blk.arr [current_request].mli_packet
              [aname], mlv$c170_rqst_blk.arr [current_request].mli_packet
              [sname], ost);
      = delspl =
        mlp$delete_sender_os (mlv$c170_rqst_blk.arr [current_request].
              mli_packet [aname], mlv$c170_rqst_blk.arr [current_request].
              mli_packet [sname], ost);
      = confirm =
        mlp$confirm_send_os (mlv$c170_rqst_blk.arr [current_request].mli_packet
              [aname], mlv$c170_rqst_blk.arr [current_request].mli_packet
              [sname], ost);
      = send =
        IF mlv$c170_rqst_blk.arr [current_request].mli_packet [signal] <>
              1ffff(16) THEN
          psig := #LOC (mlv$c170_rqst_blk.arr [current_request].mli_packet
                [mlpsv]);
        ELSE
          psig := NIL;
        IFEND;
        pc := #LOC (mlv$c170_rqst_blk.buffers^ [current_request]);
        mlp$send_message_os (mlv$c170_rqst_blk.arr [current_request].mli_packet
              [aname], mlv$c170_rqst_blk.arr [current_request].mli_packet
              [arbinfo], psig, pc, mlv$c170_rqst_blk.arr [current_request].
              mli_packet [buflen] * 8, mlv$c170_rqst_blk.arr [current_request].
              mli_packet [sname], ost);
        time := #free_running_clock (0);
        mlv$170_count := mlv$170_count + 1;
        mlv$170_time := mlv$170_time + (time - mlv$c170_rqst_blk.arr
              [current_request].time);
      = fetchrl =
        rl := #LOC (mlv$c170_rqst_blk.buffers^ [current_request]);
        rc := 0;
        mlp$fetch_receive_list_os (mlv$c170_rqst_blk.arr [current_request].
              mli_packet [aname], mlv$c170_rqst_blk.arr [current_request].
              mli_packet [sname], rl^, rc, ost);
        mlv$c170_rqst_blk.arr [current_request].mli_packet [mlpv1] := rc;
        mlv$c170_rqst_blk.arr [current_request].copy_length := (rc * #SIZE
              (mlt$receive_entry)) DIV 8;
        FOR i := 1 TO rc DO
          IF (rl^ [i].message_length MOD 8) = 0 THEN
            rl^ [i].message_length := rl^ [i].message_length DIV 8;
          ELSE
            rl^ [i].message_length := (rl^ [i].message_length DIV 8) + 1;
          IFEND;
        FOREND;
        IF rc > 0 THEN
          time := #free_running_clock (0);
          mlv$170_count := mlv$170_count + 1;
          mlv$170_time := mlv$170_time + (time - mlv$c170_rqst_blk.arr
                [current_request].time);
        IFEND;
      = receive =
        pc := #LOC (mlv$c170_rqst_blk.buffers^ [current_request]);
        IF mlv$c170_rqst_blk.arr [current_request].mli_packet [signal] <>
              1ffff(16) THEN
          psig := #LOC (mlv$c170_rqst_blk.arr [current_request].mli_packet
                [mlpsv]);
        ELSE
          psig := NIL;
        IFEND;
        ml := 0;
        mlp$receive_message_os (mlv$c170_rqst_blk.arr [current_request].
              mli_packet [aname], mlv$c170_rqst_blk.arr [current_request].
              mli_packet [mlpv2], psig, pc, ml, mlv$c170_rqst_blk.arr
              [current_request].mli_packet [buflen] * 8, mlv$c170_rqst_blk.arr
              [current_request].mli_packet [rindex], mlv$c170_rqst_blk.arr
              [current_request].mli_packet [mlpv3], ost);
        IF (ml MOD 8) = 0 THEN
          ml := ml DIV 8;
        ELSE
          ml := (ml DIV 8) + 1;
        IFEND;
        mlv$c170_rqst_blk.arr [current_request].copy_length := ml;
        IF (ost.normal) OR ((NOT ost.normal) AND (ost.condition =
              mlc$message_truncated)) THEN
          mlv$c170_rqst_blk.arr [current_request].mli_packet [mlpv1] := ml;
        IFEND;
        IF ml > 0 THEN
          time := #free_running_clock (0);
          mlv$170_count := mlv$170_count + 1;
          mlv$170_time := mlv$170_time + (time - mlv$c170_rqst_blk.arr
                [current_request].time);
        IFEND;
      = kill =
        IF mlv$c170_rqst_blk.arr [current_request].jsn MOD 100(16) = 7 THEN
          sn.c170_c180_flag := c170;
          sn.name_170 := mlv$c170_rqst_blk.arr [current_request].mli_packet
                [jsn] * 40(16);
          mlp$kill (sn, ost);
          FOR i := 0 TO mlimi - 1 DO
            IF mlv$c170_rqst_blk.arr [i].jsn DIV 100000(16) =
                  mlv$c170_rqst_blk.arr [current_request].mli_packet [jsn] THEN
              mlv$c170_rqst_blk.arr [i].op_status := idle;
            IFEND;
          FOREND;
        ELSE
          ost.condition := mlc$illegal_function;
          EXIT /mli/;
        IFEND;
      = kill_all =
        IF mlv$c170_rqst_blk.arr [current_request].jsn MOD 100(16) = 7 THEN
          sn.c170_c180_flag := c170;
          sn.name_170 := 0;
          mlp$kill (sn, ost);
          FOR i := 0 TO mlimi - 1 DO
            IF i <> current_request THEN
              mlv$c170_rqst_blk.arr [i].op_status := idle;
            IFEND;
          FOREND;
{          pt (' mlihelp - kill all a170', TRUE);
        ELSE
          ost.condition := mlc$illegal_function;
          EXIT /mli/;
        IFEND;
      ELSE
{
{ illegal mli function call
{
        ost.condition := mlc$illegal_function;
      CASEND;
    END /mli/;
    mlv$c170_rqst_blk.arr [current_request].mli_packet [mlpsv] := ost.
          condition;
  PROCEND mlp$front_end;
?? EJECT ??

  PROCEDURE [XDCL] mlp$get_c170_jobname (VAR jn: integer);

    jn := mlv$c170_rqst_blk.arr [current_request].jsn DIV 100000(16);
    IF onoff THEN
      IF mlv$c170_rqst_blk.arr [current_request].mli_packet [jsn] <> 0 THEN
        jn := mlv$c170_rqst_blk.arr [current_request].mli_packet [jsn];
      IFEND;
    IFEND;
    jn := jn * 40(16);

  PROCEND mlp$get_c170_jobname;
MODEND mlm$c170_helper
*DECK DECK=MLM$DEADSTART_INTERFACE EXPAND=TRUE
MODULE mlm$deadstart_interface;
MODEND mlm$deadstart_interface;
*DECK DECK=MLM$HANDLE_SIGNAL EXPAND=TRUE

MODULE mlm$handle_signal;
*copyc OSD$DEFAULT_PRAGMATS
?? PUSH (LISTEXT := ON) ??
*copyc MLT$ANT_ENTRY
*copyc MLP$SIGN_ON_OS
*copyc OST$GLOBAL_TASK_ID
*copyc PMT$SIGNAL
*copyc OST$STATUS
?? POP ??
?? EJECT ??
*copyc MLH$HANDLE_SIGNAL
?? EJECT ??

  PROCEDURE [XDCL, #GATE] mlp$handle_signal (originator: ost$global_task_id;
    signal: pmt$signal);

    VAR
      handler: mlt$handler,
      info: mlt$signaler_application_info,
      ps: ^mlt$pmt_signal,
      ost,
      status: ost$status,
      sig: mlt$signal;

{
{ get handler for this application
{
    ps := #LOC (signal.contents);
    mlp$get_handler_info_os (ps^.dest, handler, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF handler = NIL THEN
{
{ no signal handler - ignore signal
{
      RETURN;
    IFEND;
    info.application_name := ps^.from;
    PUSH sig;
    info.global_task_id := originator;
    sig^.data := ps^.data;
    sig^.direction := ps^.direction;
{    #INLINE ('keypoint', mlc$keypoint_class, 256 * 0, ORD
{(mlc$kp_invoke_handler));
    handler^ (ps^.dest, info, sig, status);
  PROCEND mlp$handle_signal;
MODEND mlm$handle_signal
*DECK DECK=MLM$INITIALIZE_MEMORY_LINK EXPAND=TRUE

?? RIGHT := 110, LEFT := 1 ??
??
FMT (FORMAT := ON, keyw = upper, ident := lower) ??
MODULE mlm$initialize_memory_link;
*copyc OSD$DEFAULT_PRAGMATS
{---------------------------------------------------------------------------
{ This module contains the routine which is called during startup of the
{ job monitor task of the system job to initialize the memory link.
{
{ This routine will create a file and open it for segment access.  This
{ segment will then become part of every task's address space so that
{ the memory link can access it by the same segment number in every task.
{ A pointer to the memory link segment is placed in the variable
{ MLV$SHARED_SEGMENT.
{
{ The memory link initialization routine must reside in ring 1 so that
{ the variable MLV$SHARED_SEGMENT is defined in the mainframe wired
{ table segment.  The memory link segment has read and write access from
{ ring 2 and below.  The memory link will (probably) run in ring 2.
{---------------------------------------------------------------------------
?? PUSH (LISTEXT := ON) ??
*copyc OSV$MAINFRAME_WIRED_HEAP
*copyc MLT$C170_RQST_BLK
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc MLT$ANT_ENTRY
*copyc OSP$RESET_HEAP
*copyc osv$170_os_type
*copyc PMP$ZERO_OUT_TABLE
*copyc MMP$FREE_PAGES
?? POP ??

  SECTION
    mls$mem_link: WRITE;

  VAR
    mlv$enabled: [XREF] boolean,
    mlv$c170_rqst_blk: [XREF] mlt$c170_rqst_blk,
    mlv$shared_segment: [XDCL, mls$mem_link] mlt$shared_segment;

?? EJECT ??
{--------------------------------------------------------------}
{name:}
{  mlp$initialize}
{Purpose:}
{  This routine sets up the memory link shared segment.
{  The segment is present in the address space of every task, and
{  is created in shared, wired mode.
{Input:}
{  none. }
{Output:}
{  none.}
{Error Codes:}
{None.}
{---------------------------------------------------------------}

  PROCEDURE [XDCL, #GATE] mlp$initialize (VAR status: ost$status);



    VAR
      ae: 1 .. mlc$max_ant_entries,
      i: integer,
      hp: ^ost$heap;

    IF osv$170_os_type = osc$ot7_none THEN
      status.normal := TRUE;
      RETURN;
    IFEND;
    mlv$enabled := TRUE;
{
{ reset all heaps and initialize all data tables in the memory link segment.
{
    hp := #LOC (mlv$shared_segment.pspace);
    osp$reset_heap (hp, 20000000, FALSE, 1);
    mlv$shared_segment.tlock := mlc$not_ilk;
    mlv$shared_segment.plock := mlc$not_ilk;
    mlv$shared_segment.dust_id.index := 0;
    mlv$shared_segment.dust_id.seqno := 0;
    mlv$shared_segment.next_free_ant_entry := mlc$max_primary_entry + 1;
    FOR ae := 1 TO mlc$max_ant_entries DO
      mlv$shared_segment.ant [ae].application_name := mlc$empty_entry;
      mlv$shared_segment.ant [ae].reservation := mlc$not_ilk;
      mlv$shared_segment.ant [ae].max_messages := 0;
      mlv$shared_segment.ant [ae].unique := - 1;
      mlv$shared_segment.ant [ae].receive_list := NIL;
      mlv$shared_segment.ant [ae].permit_list := NIL;
      mlv$shared_segment.ant [ae].sn_fwd_p := mlc$end_of_chain;
      mlv$shared_segment.ant [ae].sn_bkwd_p := mlc$end_of_chain;
      mlv$shared_segment.ant [ae].system_name.c170_c180_flag := mlc$none;
      mlv$shared_segment.ant [ae].handler := NIL;
      IF ae <= mlc$max_primary_entry THEN
        mlv$shared_segment.ant [ae].forward_p := mlc$end_of_chain;
        mlv$shared_segment.ant [ae].backward_p := mlc$end_of_chain;
      ELSEIF ae < mlc$max_ant_entries THEN
        mlv$shared_segment.ant [ae].forward_p := ae + 1;
        mlv$shared_segment.ant [ae].backward_p := ae - 1;
      ELSE
        mlv$shared_segment.ant [ae].forward_p := mlc$end_of_chain;
        mlv$shared_segment.ant [ae].backward_p := ae - 1;
      IFEND;
    FOREND;
    FOR ae := 1 TO mlc$max_sn_entry DO
      mlv$shared_segment.sn_chain_table [ae] := mlc$end_of_chain;
    FOREND;

{ allocate all buffers, but only enable the first few

    ALLOCATE mlv$c170_rqst_blk.buffers IN osv$mainframe_wired_heap^;
    pmp$zero_out_table (mlv$c170_rqst_blk.buffers, initial_buffer_count * (mlc$max_message_length + 1));
    FOR i := initial_buffer_count TO mlimi - 1 DO
      mlv$c170_rqst_blk.arr [i].op_status := not_available;
    { NOTE: op_status is referenced by #compare_swap after being initialized and
    {       cannot be referenced by this procedure again.
    FOREND;
    mmp$free_pages (#LOC (mlv$c170_rqst_blk.buffers^ [initial_buffer_count]), (mlimi - initial_buffer_count) *
          (mlc$max_message_length + 1), osc$nowait, status);
    status.normal := TRUE;
    mlv$c170_rqst_blk.reject_calls := accept_all_calls;
  PROCEND mlp$initialize;
MODEND mlm$initialize_memory_link
*DECK DECK=MLM$INVOKE_MLI_HELPER EXPAND=TRUE
MODULE mlm$invoke_mli_helper;
*copyc OSD$DEFAULT_PRAGMATS

{  The purpose of this request is to call the mli helper routine (which must
{  run in ring 1) from ring 3.

?? PUSH (LISTEXT := ON) ??
*copyc I#CALL_MONITOR
*copyc OSD$VIRTUAL_ADDRESS
*copyc osv$170_os_type
*copyc TMC$WAIT_TIMES
*copyc ost$caller_identifier
*copyc TMT$RB_DELAY

  PROCEDURE [XREF] mlp$initialize_helper;

  VAR
    mlv$enabled: [XREF] boolean;

  PROCEDURE [XREF] mlp$help_c170;
?? POP ??

  PROCEDURE [XDCL, #GATE] mlp$invoke_mli_helper;

  VAR
    delay: tmt$rb_delay,
    id: ost$caller_identifier;

  IF osv$170_os_type = osc$ot7_none THEN
    RETURN;
  IFEND;
  #caller_id (id);
  IF id.ring > osc$tsrv_ring THEN
    RETURN;
  ELSE
      IF NOT mlv$enabled THEN
        RETURN;
      IFEND;

      mlp$initialize_helper;

      WHILE TRUE DO
        mlp$help_c170;
        delay.reqcode := syc$rc_delay;
        delay.requested_wait_time := tmc$infinite_wait;
        delay.expected_wait_time := #free_running_clock (0) + 20000000;
        i#call_monitor (#LOC (delay), #SIZE (delay));
      WHILEND;
  IFEND;

PROCEND mlp$invoke_mli_helper;
MODEND mlm$invoke_mli_helper
*DECK DECK=MLM$MEMORY_LINK_INTERFACE EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE: MEMORY LINK INTERFACE' ??
{
{ PURPOSE:
{     The NOS/VE MLI (Memory Link Interface) is a general message
{  transfer mechanism which allows priviledged C180 code to communicate
{  with one or more C170 jobs or system applications.  By nature of
{  its symmetry, MLI also allows a C180 task to communicate with a C180
{  task which is part of a different C180 job.  Transfer of messages
{  between a sender and a receiver is controlled by only allowing app-
{  lications that have been granted permission by the receiver to send
{  messages to the receiver.
{
MODULE mlm$memory_link_interface;
?? SET (LIST := ON) ??
*copyc ost$signature_lock
*copyc OSS$MAINFRAME_PAGED_LITERAL
*copyc OSS$JOB_PAGED_LITERAL
?? SET (LIST := ON) ??
?? NEWTITLE := 'EXTERNAL CONSTANT AND TYPE DECLARATIONS ' ??
?? EJECT ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? OLDTITLE ??
?? NEWTITLE := 'INTERNAL CONSTANT AND TYPE DECLARATIONS ' ??
?? EJECT ??
*copyc MLT$ANT_ENTRY
*copyc MLK$KEYPOINTS
?? OLDTITLE ??
?? NEWTITLE := 'EXTERNAL PROCEDURE REFERENCE DECLARATIONS ' ??
?? EJECT ??
*copyc PMP$CYCLE
*copyc PMP$READY_TASK
*copyc PMP$GET_EXECUTING_TASK_GTID
*copyc I#MOVE
*copyc osp$set_mainframe_sig_lock
*copyc osp$clear_mainframe_sig_lock
*copyc osp$clear_mainframe_sig_lock
*copyc osp$set_locked_variable
*copyc osp$fetch_locked_variable
*copyc osp$system_error
*copyc PMP$SEND_SIGNAL
*copyc jmv$jcb
*copyc oss$job_fixed
*copyc osv$170_os_type
*copyc osv$job_fixed_heap
*copyc osp$set_status_abnormal
*copyc ose$job_recovery_exceptions
?? OLDTITLE ??
?? NEWTITLE := 'INTERNAL MODULE VARIABLE DECLARATIONS ' ??
?? EJECT ??


  VAR
    mlv$ilk: [READ, OSS$MAINFRAME_PAGED_LITERAL] ost$compare_swap_lock := mlc$ilk, { value for set
      {interlock }
    mlv$not_ilk: [READ, OSS$MAINFRAME_PAGED_LITERAL] ost$compare_swap_lock := mlc$not_ilk, { value for
      {clear interlock }
    mlv$shared_segment: [XREF] mlt$shared_segment,
    mlv$lock: [XDCL, #GATE] ost$signature_lock := [0],
    mlv$enabled: [XREF] boolean,
    callers_ant_index: mlt$ant_index := mlc$not_found,
    mlv$add_chain,
    mlv$remove_chain,
    mlv$send_message,
    mlv$send_bytes: [XDCL] integer := 0,
    system_name: mlt$system_name;




?? OLDTITLE ??
?? EJECT ??
?? NEWTITLE := 'search_ant ' ??
?? EJECT ??
{
{  PROCEDURE search_ant
{
{    PURPOSE:
{      To search the application name table for one of the following
{      conditions:
{      1) match with just application name.
{      2) match with application name and system name.
{      3) match with empty entry.
{
{    PARAMETERS:
{      application_name: (input) name of the application to search for.
{      system_name: (input) system_name to match with if application_name
{                   is found.  If null then no system_name check is performed.
{      ant_entry: (output) index of the ANT entry if found, otherwise zero.
{      status: (output) status of the search.
{
{    NOTE:
{      . The ANT currently consists of an array of ant_entries which is
{      searched sequentially.  An index into the array is returned.

  PROCEDURE [INLINE] search_ant (application_name: mlt$application_name;
    system_name: mlt$system_name;
    VAR ant_entry: mlt$ant_index;
    VAR status: mlt$search_status);

    VAR
      stat: mlt$status, { local status }
      res_value: integer,
      empty, { index into the ANT }
      i, j: mlt$ant_index; { index into the ANT }

  /pre_search/
    BEGIN
      IF callers_ant_index <> mlc$not_found THEN
{
{ check to see if pointing to correct entry already
{
        IF mlv$shared_segment.ant [callers_ant_index].application_name DIV
          mlc$shift = application_name THEN
{
{ found match - check (maybe) system name }
{
          IF system_name.c170_c180_flag <> mlc$none THEN
{
{ check for system name match }
{
            check_sn (mlv$shared_segment.ant [callers_ant_index].system_name,
                  stat);
            IF stat <> mlc$ok THEN
{
{ system name conflict }
{
              EXIT /pre_search/;
            IFEND;
          IFEND;
{
{ entry was found and either system names matched or no system name
{ check was performed
{
          ant_entry := callers_ant_index;
          status := found;
          RETURN;
        IFEND;
      IFEND;
    END /pre_search/;
    empty := mlc$not_found;

{  create table index using hashing function

     i  := (((application_name DIV 10000(16)) MOD 1000000(16)) MOD 127) + 1;

{  remember if primary entry is empty

     osp$fetch_locked_variable(mlv$shared_segment.ant[i].reservation, res_value);
     IF res_value = mlc$not_ilk THEN
          empty := i;
        IFEND;

  /search_loop/
    WHILE i<>mlc$end_of_chain DO
      IF mlv$shared_segment.ant [i].application_name DIV mlc$shift =
        application_name THEN
{
{ found match - check (maybe) system name }
{
        IF system_name.c170_c180_flag <> mlc$none THEN
{
{ check for system name match }
{
          check_sn (mlv$shared_segment.ant [i].system_name, stat);
          IF stat <> mlc$ok THEN
{
{ system name conflict }
{
            ant_entry := mlc$not_found;
            status := no_match;
            RETURN;
          IFEND;
        IFEND;
{
{ entry was found and either system names matched or no system name
{ check was performed
{
        ant_entry := i;
        status := found;
        RETURN;
      ELSE
{
{  proceed to next entry on chain, keeping track of previous one
{
        j := i;
        i := mlv$shared_segment.ant[i].forward_p;
      IFEND;
    WHILEND /search_loop/;
{
{ no match found }
{
    IF (empty = mlc$not_found) AND (mlv$shared_segment.next_free_ant_entry
      <>mlc$end_of_chain) THEN
      empty := j;
    IFEND;
    ant_entry := empty;
    status := not_found;
    RETURN;
  PROCEND search_ant;

?? OLDTITLE ??

?? NEWTITLE := 'search_permit_list ' ??
?? EJECT ??
{
{  PROCEDURE search_permit_list
{
{    PURPOSE:
{      To search the permit list of a given application and find either
{      a match on sender names or an empty entry.
{
{    PARAMETERS:
{      application_name: (input) the name of the sender to search for.
{                        If null then search for empty entry.
{      ant_entry: (input) index into the ANT of the application whose
{                 permit list is to be searched.
{      permit_entry: (output) index of the entry if found, otherwise zero.
{
{    NOTE:
{      . A permit list currently consists of an array that is searched
{      sequentially.  An index into the array is retunred.

  PROCEDURE search_permit_list (application_name: mlt$application_name;
    ant_entry: mlt$ant_index;
    VAR permit_entry: mlt$permit_index);

    VAR
      permit_list: ^mlt$permit_list, { pointer to the applications permit list}
      i: mlt$permit_index;

{
{ note that the same code is used to search for both empty and non-empty
{ cases because all empty entries have the name field set to mlc$unique_name
{ which is the value of the application name parameter when called to find
{ an empty entry.
{
    permit_list := mlv$shared_segment.ant [ant_entry].permit_list;

  /search_loop/
    FOR i := 1 TO mlc$max_permits DO
      IF permit_list^ [i].sender = application_name THEN
{
{ found match
{
        permit_entry := i;
        RETURN;
      IFEND;
    FOREND /search_loop/;
{
{ no match was found }
{
    permit_entry := mlc$not_found;
    RETURN;
  PROCEND search_permit_list;

?? OLDTITLE ??

?? NEWTITLE := 'search_receive_list ' ??
?? EJECT ??
{
{  PROCEDURE search_receive_list
{
{    PURPOSE:
{      To search the receive list of a given application and find either
{      a match on sender names or an empty entry.
{
{    PARAMETERS:
{      application_name: (input) the name of the sender to search for.
{                        If null then search for an empty entry.
{      ant_entry: (input) index of the ant entry upon which the search
{               is being performed.
{      receive_entry: (output) index of the entry if found, otherwise zero.
{
{    NOTE:
{      . A receive list currently consists of an array that is searched
{      sequentially.  An index into the array is returned.
{
{      . The maximum number of receive entries looked at is determined by the
{      max_messages value for this application.

  PROCEDURE search_receive_list (application_name: mlt$application_name;
    ant_entry: mlt$ant_index;
    VAR receive_entry: mlt$receive_index);

    VAR
      i: mlt$receive_index, { index into the receive list }
      crlp: ^mlt$int_receive_list_entry,
      receive_list: ^mlt$int_receive_list, { pointer to the current receive
      {list }
      max_msgs: mlt$max_messages; { max messages for the current application }

    IF application_name = mlc$empty_entry THEN
      max_msgs := mlv$shared_segment.ant [ant_entry].max_messages;
    ELSE
      max_msgs := mlv$shared_segment.ant [ant_entry].highest_rl_entry;
    IFEND;

    receive_list := mlv$shared_segment.ant [ant_entry].receive_list;
{
{ note that the same code is used to search for both empty and non-empty
{ cases because all empty entries have the name field set to mlc$unique_name
{ which is the value of the application name parameter when called to find
{ an empty entry.
{

  /search_loop/
    FOR i := 1 TO max_msgs DO
      IF receive_list^ [i].sender_name = application_name THEN
        receive_entry := i;
        RETURN;
      IFEND;
      IF (receive_list^ [i].sender_name <> mlc$empty_entry) THEN
        crlp := ^receive_list^ [i];
        {Search ssn chain for name match
        WHILE crlp <> NIL DO
          IF crlp^.sender_name = application_name THEN
            receive_entry := i;
            RETURN;
          IFEND;
          crlp := crlp^.chained_entry;
        WHILEND;
      IFEND;
    FOREND /search_loop/;
{
{ no match was found }
{
    receive_entry := mlc$not_found;
    RETURN;
  PROCEND search_receive_list;

?? OLDTITLE ??

?? NEWTITLE := 'mli_error' ??
?? EJECT ??
{
{  PROCEDURE mli_error
{
{    PURPOSE:
{      To process internal MLI errors.  These errors should never occur,
{      but if they do it would indicate a bug somewhere in MLI or the
{      system.  mli_error will take appropriate action depending on
{      the exact error encountered.
{
{    PARAMETERS:
{      code: (input) type of internal error detected.
{
{    NOTES:
{      **** note **** this routine is for NOSVE ( c180 )

  PROCEDURE mli_error (code: mlt$internal_error);

    VAR
      nnn: integer,
      status: ost$status,
      ts: string (20);


    ts := '  mli abort ';
    #INLINE ('keypoint', osk$debug, osk$m * ORD (code),
          mlk$memory_link_error_code);
    STRINGREP (ts (13, 8), nnn, ORD (code));
    osp$system_error (ts, NIL);

  PROCEND mli_error;

?? NEWTITLE := 'obtain_system_name ' ??
?? EJECT ??
{
{  PROCEDURE obtain_system_name
{
{    PURPOSE:
{      To return the system name and c170_c180_flag of the task (which is
{      currently calling MLI) to the caller.
{
{    PARAMETERS:
{      system_name: (output) the system name (and c170_c180_flag) of *this*
{                   task.
{
{    NOTES:
{      . If the global task_id of this task equals the dual state tasks
{      global task_id then the system name is obtained from the c170
{      operating system memory segment, otherwise the system name is the
{      current tasks global task_id.
{
{      . The task_id of the dual state task has previously been stored
{      into the MLI shared segment.

    PROCEDURE [INLINE] obtain_system_name (VAR system_name: mlt$system_name);

      PROCEDURE [XREF] mlp$get_c170_jobname (VAR jn: integer);

      VAR
        task: ost$global_task_id;

      pmp$get_executing_task_gtid (task);
      IF task = mlv$shared_segment.dust_id THEN
{
{ get C170 name
{
        system_name.c170_c180_flag := c170;
        mlp$get_c170_jobname (system_name.name_170);
      ELSE
{
{ get C180 name
{
        system_name.c170_c180_flag := mlc$c180;
        system_name.name_180 := task;
      IFEND;

    PROCEND obtain_system_name;

?? OLDTITLE ??

?? NEWTITLE := 'mli_init ' ??
?? EJECT ??
{
{  PROCEDURE mli_init
{
{    PURPOSE
{      To initialize the local copy of mlv$shared_segment - the pointer to
{      the shared data segment, and to initialize the local copy of this
{      tasks system name.  This action should only be performed for the
{      first call to any mli entry point.  All mli main routines (signon,
{      signoff, add, delete, confirm, fetchrl, send, receive) call this
{      routine as soon as they are called.
{
{     PARAMETERS:
{       status: (output) status of the operation.
{
{    NOTES:
{      This routine is currently modified to aid in HSS/HCS testing.

  PROCEDURE [INLINE] mli_init (VAR status: mlt$status);

{
{   MLI_INIT
{

    VAR
      stat: mlt$status,
      ost: ost$status;

{
{ This routine is currently modified to force serial execution of MLI.
{

    IF NOT mlv$enabled THEN
      status := mlc$mli_internal_error;
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (mlv$lock);
    obtain_system_name (system_name);
    callers_ant_index := mlc$not_found; {** for serialization only **}
    status := mlc$ok;
    RETURN;
  PROCEND mli_init;
?? OLDTITLE ??


?? NEWTITLE := 'validate_name ' ??
?? EJECT ??
{
{  PROCEDURE validate_name
{
{    PURPOSE:
{      To validate an application name (type mlt$application_name).
{
{    PARAMETERS:
{      name: (input) the application name to be validated.
{      status: (output) status of the operation.
{
{    NOTES:
{      . The following conditions must be satisfied:
{        1) application name <> mlc$empty_entry, <> mlc$unique_name
{        2) upper 9 bits of application name must be zero.

  PROCEDURE [INLINE] validate_name (name: mlt$application_name;
    VAR status: mlt$status);

    VAR
      i: integer,
    chk: record
        case typ: 1 .. 2 of
        = 1 =
        an: mlt$application_name,
        = 2 =
        vfy: packed record
          u9: 0 .. 1ff(16),
          l1: 0 .. 7ffffff(16),
          l2: 0 .. 0fffffff(16),
        recend,
      casend,
    recend;

    status := mlc$receiver_name_syntax_error;
    IF (name = mlc$empty_entry) OR (name = mlc$unique_name) THEN
      RETURN;
    IFEND;
    chk.an := name;
    IF chk.vfy.u9 <> 0 THEN
      RETURN;
    IFEND;
    status := mlc$ok;
  PROCEND validate_name;
?? OLDTITLE ??

?? NEWTITLE := 'lock ' ??
?? EJECT ??
{
{  PROCEDURE lock
{
{    PURPOSE:
{      To interlock a given word in memory.
{
{    PARAMETERS:
{      ptr: (input-output) the word to lock in memory.
{      status: (output) status of the operation.
{
{    NOTES:
{      . Compare/Swap is currently used to interlock a word.
{
{      . May want to implement some limited waiting for busy interlock
{      capability for C180 tasks.
{
{      . This routine could also stack a list of all locks that it sets (i.e.,
{      save the PVA's).  The routine unlock would unstack these when it was
{      called.  This list could then be used by a condition handler to
{      selectivly clear interlocks set by the aborted task.

  PROCEDURE [INLINE] lock (VAR ptr: ost$compare_swap_lock;
    VAR status: mlt$status);

    VAR
      actual_val: ost$compare_swap_lock,
      succeeded: boolean;

    osp$set_locked_variable (ptr, mlv$not_ilk, mlv$ilk, actual_val, succeeded);
    IF succeeded THEN
      status := mlc$ok;
    ELSE
      status := mlc$busy_interlock;
    IFEND;
  PROCEND lock;

?? OLDTITLE ??

?? NEWTITLE := 'unlock ' ??
?? EJECT ??
{
{  PROCEDURE unlock
{
{    PURPOSE:
{      To unlock a word in memory that had previously been set by lock.
{
{    PARAMETERS:
{      ptr: (input-output) the word in memory to be unlocked.
{      status: (output) the status of the operation.
{
{    NOTES:
{      . Compare/Swap is currently used to interlock a word.
{
{      . This routine should never fail as the caller should be the only
{      one manipulating the lock.  If it does fail then there is a bug
{      in MLI.

  PROCEDURE [INLINE] unlock (VAR ptr: ost$compare_swap_lock;
    VAR status: mlt$status);

    VAR
      actual_val: ost$compare_swap_lock,
      succeeded: boolean;

    osp$set_locked_variable (ptr, mlv$ilk, mlv$not_ilk, actual_val, succeeded);
    IF succeeded THEN
      status := mlc$ok;
    ELSE
      status := mlc$mli_internal_error;
      mli_error (unlock_err);
    IFEND;
  PROCEND unlock;

?? OLDTITLE ??

?? NEWTITLE := 'confirm_sender_allowed_to_send ' ??
?? EJECT ??
{
{  PROCEDURE confirm_sender_allowed_to_send
{
{    PURPOSE:
{      To check if the sender has been permitted to send to the specified
{      receiver.
{
{    PARAMETERS:
{      application_name: (input) application name of the sender.
{      ant_entry: (input) ANT index of the receiver application.
{      status: (output) status of the operation.

  PROCEDURE confirm_sender_allowed_to_send (application_name:
    mlt$application_name;
    ant_entry: mlt$ant_index;
    VAR status: mlt$status);

    VAR
      permit_entry: mlt$permit_index; { index into the permit list }

{ this routine was no-op'd to make job recovery simpler

status:=mlc$ok;
return;
{
{ search for global permission
{
    search_permit_list (mlc$unique_name, ant_entry, permit_entry);
    IF permit_entry = mlc$not_found THEN
{
{ search for specific permission
{
      search_permit_list (application_name, ant_entry, permit_entry);
      IF permit_entry = mlc$not_found THEN
        status := mlc$sender_not_permitted;
      ELSE
        status := mlc$ok;
      IFEND;
    ELSE
{
{ global permission found
{
      status := mlc$ok;
      RETURN;
    IFEND;
  PROCEND confirm_sender_allowed_to_send;
?? OLDTITLE ??

?? NEWTITLE := 'confrim_receiver_ready ' ??
?? EJECT ??
{
{  PROCEDURE confrim_receiver_ready
{
{    PURPOSE:
{      To check if:
{         1) a message from sender to receiver is currently in the receiver
{            queue, and,
{         2) an empty receive list entry exists for the receiver.
{
{    PARAMETERS:
{      application_name: (input) application name of the sender.
{      ant_entry: (input) ANT index of the receiver application.
{      status: (output) status of the operation.

  PROCEDURE confirm_receiver_ready (application_name: mlt$application_name;
    ant_entry: mlt$ant_index;
    force_send: boolean;
    VAR status: mlt$status);

    VAR
      cnt: integer, { count of queued msgs }
      crlp: ^mlt$int_receive_list_entry,
      rlp: ^mlt$int_receive_list, { pointer to the applications receive list }
      receive_entry: mlt$receive_index; { index into the receive list }
{
{ search for message(s) not yet received
{
    cnt := 0;
    rlp := mlv$shared_segment.ant [ant_entry].receive_list;
    IF NOT force_send THEN
  /floop/
    FOR receive_entry := 1 TO mlv$shared_segment.ant [ant_entry].highest_rl_entry
          DO
      IF (rlp^ [receive_entry].sender_name <> mlc$empty_entry) AND
          (rlp^ [receive_entry].ssn = jmv$jcb.system_name) THEN
        crlp := ^rlp^ [receive_entry];
        {Search ssn chain for name match
        WHILE crlp <> NIL DO
          IF crlp^.sender_name = application_name THEN
            cnt := cnt + 1;
          IFEND;
          crlp := crlp^.chained_entry;
        WHILEND;
        EXIT /floop/;
      IFEND;
    FOREND /floop/;
    IFEND; {force_send}
    IF cnt = 0 THEN
{
{ search for empty entry
{
      search_receive_list (mlc$empty_entry, ant_entry, receive_entry);
      IF receive_entry = mlc$not_found THEN
        status := mlc$receive_list_full;
      ELSE
        status := mlc$ok;
      IFEND;
    ELSEIF (cnt >= mlc$max_in_transit) OR
        (cnt >= mlv$shared_segment.ant [ant_entry].max_messages) THEN
      status := mlc$prior_msg_not_received;
    ELSE
      status := mlc$ok;
    IFEND;
  PROCEND confirm_receiver_ready;
?? OLDTITLE ??


?? NEWTITLE := 'check_sn ' ??
?? EJECT ??
{
{  PROCEDURE check_sn
{
{    PURPOSE:
{      To determine if the system name passed is the same as the system name
{      of the current task.
{
{    PARAMETERS:
{      sn: (input) the system name to compare with the current task system
{                  name.
{      status: (output) status of the operation.
{
{    NOTES:
{      This routine is needed because a variant record cannot be used in
{      a relational expression.

  PROCEDURE [INLINE] check_sn (sn: mlt$system_name;
    VAR status: mlt$status);

    status := mlc$system_name_no_match;
    IF sn.c170_c180_flag <> system_name.c170_c180_flag THEN
      RETURN;
    IFEND;
    CASE sn.c170_c180_flag OF
    = c170 =
      IF sn.name_170 <> system_name.name_170 THEN
        RETURN;
      IFEND;
    = mlc$c180 =
      IF sn.name_180.index <> system_name.name_180.index THEN
        RETURN;
      IFEND;
      IF sn.name_180.seqno <> system_name.name_180.seqno THEN
        RETURN;
      IFEND;
    = mlc$none =
      RETURN;
    CASEND;
    status := mlc$ok;
  PROCEND check_sn;
?? OLDTITLE ??

?? NEWTITLE := 'release_ant_entry_resources' ??
?? EJECT ??
{
{  PROCEDURE release_ant_entry_resources
{
{    PURPOSE:
{      1) To return all message buffer space pointed to by active receive list
{         entries to the buffer pool, and,
{      2) To return all permit and receive list space to the table pool.
{
{    PARAMETERS:
{      ant_entry: (input) ANT index to the application being signed off.
{      status: (output) the status of the operation.

  PROCEDURE release_ant_entry_resources (ant_entry: mlt$ant_index;
    VAR status: mlt$status);

    VAR
      ncrl, crl: ^mlt$int_receive_list_entry,
      cae: ^mlt$ant_entry, { pointer to the current ant entry }
      i: mlt$receive_index, { index into the receive list }
      stat: mlt$status; { local status }

    cae := ^mlv$shared_segment.ant [ant_entry];
{
{ must obtain all interlocks before attempting any free operations
{
    lock (mlv$shared_segment.tlock, status);
    IF status <> mlc$ok THEN
      RETURN;
    IFEND;
{
    lock (mlv$shared_segment.plock, status);
    IF status <> mlc$ok THEN
      unlock (mlv$shared_segment.tlock, stat);
      RETURN;
    IFEND;
    status := mlc$ok;
{
{return permit list space }
{
    FREE cae^.permit_list IN mlv$shared_segment.pspace;
{
{ return all queued messages }
{
    FOR i := 1 TO cae^.max_messages DO
      IF cae^.receive_list^ [i].message_location <> NIL THEN
        FREE cae^.receive_list^ [i].message_location IN mlv$shared_segment.
          pspace;
        status := mlc$queued_msgs_lost;
      IFEND;
      IF cae^.receive_list^ [i].chained_entry <> NIL THEN
        crl := cae^.receive_list^ [i].chained_entry;
        WHILE crl <> NIL DO
          IF crl^.message_location <> NIL THEN
            FREE crl^.message_location IN mlv$shared_segment.
              pspace;
            status := mlc$queued_msgs_lost;
          IFEND;
          ncrl := crl^.chained_entry;
          FREE crl IN mlv$shared_segment.pspace;
          crl := ncrl;
        WHILEND;
      IFEND;
    FOREND;
{
{ free receive list space }
{
    FREE cae^.receive_list IN mlv$shared_segment.pspace;
{
{ release interlocks }
{
    unlock (mlv$shared_segment.plock, stat);
    unlock (mlv$shared_segment.tlock, stat);
IF cae^.job_recovery_index <> 0 THEN
    mlv$job_recovery_info^[cae^.job_recovery_index].status :=
      mlc$invalid;
    mlv$job_signon_count := mlv$job_signon_count - 1;
IFEND;
  PROCEND release_ant_entry_resources;

?? OLDTITLE ??

?? NEWTITLE := 'mlp$kill' ??
?? EJECT ??
{   The purpose of this request is to force a sign_off for all applications
{ signed_on by a specified task.  This request should only be issued
{ by mlp$task_termination_cleanup or mlp$front_end.
{
{        MLP$KILL (SYSTEM_NAME, STATUS)
{
{ SYSTEM_NAME: (input) This parameter specifies the task for which all
{        signed_on applications are to be signed_off.
{
{ STATUS: (output) This parameter specifies the request status.
{

  PROCEDURE [XDCL] mlp$kill (sn: mlt$system_name;
    VAR status: ost$status);

    VAR
      entry: mlt$ant_index, {current ant entry being signed off}
      stat: mlt$status,
      sn_table_seed: integer,
      sn_hash: mlt$sn_table_index,
      ost: ost$status,
      cae: ^mlt$ant_entry, {pointer to current ant entry}
      msm: mlt$system_name;

    status.normal := FALSE;
    status.condition := mlc$ok;
    IF NOT mlv$enabled THEN
      status.condition := mlc$mli_internal_error;
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (mlv$lock);
{
{  derive seed for creating hash into sn table from system name
{
    CASE sn.c170_c180_flag OF
      = mlc$c180 =
        sn_table_seed := sn.name_180.index;
      = c170 =
        sn_table_seed := ((sn.name_170) DIV 100(16))
          MOD 1000000(16);
    CASEND;
{
{  create index to bottom of chain for this system name
{  using hashing function.
{
    sn_hash := (sn_table_seed MOD (mlc$max_sn_entry - 1)) + 1;
{
{  check all ant entries in chain for system name match
{
    entry := mlv$shared_segment.sn_chain_table [sn_hash];
  /signoff/
    WHILE entry <> mlc$end_of_chain DO
      cae := ^mlv$shared_segment.ant [entry];
{
{  signoff if system name match
{
      msm := cae^.system_name;
      IF (msm.c170_c180_flag = mlc$none) OR (msm.c170_c180_flag <> sn.
        c170_c180_flag) THEN
        entry := cae^.sn_bkwd_p;
        CYCLE /signoff/;
      IFEND;
      IF (msm.c170_c180_flag = mlc$c180) AND (msm.name_180 <> sn.name_180) THEN
        entry := cae^.sn_bkwd_p;
        CYCLE /signoff/;
      IFEND;
      IF (msm.c170_c180_flag = c170) AND (msm.name_170 <> sn.name_170) THEN
        entry := cae^.sn_bkwd_p;
        CYCLE /signoff/;
      IFEND;
      REPEAT
        release_ant_entry_resources (entry, stat);
      UNTIL stat <> mlc$busy_interlock;
{
{ if application was signed_off then complete the signoff by clearing
{ the rest of the entry.
{
      cae^.application_name := mlc$empty_entry;
      cae^.system_name.c170_c180_flag := mlc$none;
      cae^.max_messages := 0;
      cae^.unique := - 1;
      status.condition := stat;
{
{  remove entry from system name chain
{
      IF entry = mlv$shared_segment.sn_chain_table [sn_hash] THEN
        mlv$shared_segment.sn_chain_table [sn_hash]
          := cae^.sn_bkwd_p;
      ELSE
        mlv$shared_segment.ant [cae^.sn_fwd_p].sn_bkwd_p
          := cae^.sn_bkwd_p;
      IFEND;
      IF cae^.sn_bkwd_p <> 0 THEN
        mlv$shared_segment.ant [cae^.sn_bkwd_p].sn_fwd_p
          := cae^.sn_fwd_p;
      IFEND;
{
{  if entry is chained, return to free pool.
{
      IF cae^.backward_p <> mlc$end_of_chain THEN
        IF cae^.forward_p <> mlc$end_of_chain THEN
          mlv$shared_segment.ant[cae^.forward_p].backward_p
            := cae^.backward_p;
        IFEND;
        mlv$shared_segment.ant[cae^.backward_p].forward_p
          := cae^.forward_p;
        cae^.forward_p := mlv$shared_segment.next_free_ant_entry;
        mlv$shared_segment.next_free_ant_entry := entry;
      IFEND;
      entry := cae^.sn_bkwd_p;
      cae^.sn_fwd_p := mlc$end_of_chain;
      cae^.sn_bkwd_p := mlc$end_of_chain;
      unlock (cae^.reservation, stat);
    WHILEND /signoff/;
    osp$clear_mainframe_sig_lock (mlv$lock);
    IF status.condition = mlc$ok THEN
      status.normal := TRUE;
    IFEND;
  PROCEND mlp$kill;
?? OLDTITLE ??
?? NEWTITLE := 'mlp$task_termination_cleanup' ??
?? EJECT ??
*copyc MLH$TASK_TERMINATION_CLEANUP

  PROCEDURE [XDCL, #GATE] mlp$task_termination_cleanup;

    VAR
      task: ost$global_task_id,
      status: ost$status,
      sn: mlt$system_name;

    IF NOT mlv$enabled THEN
      RETURN;
    IFEND;
    pmp$get_executing_task_gtid (task);
    IF task = mlv$shared_segment.dust_id THEN

{ helper task being terminated - should not happen.

{  i#program_error;

    ELSE
      sn.c170_c180_flag := mlc$c180;
      sn.name_180 := task;
      mlp$kill (sn, status);
    IFEND;
  PROCEND mlp$task_termination_cleanup;
?? OLDTITLE ??
?? NEWTITLE := 'mlp$sign_on ' ??
?? EJECT ??
*copyc MLH$SIGN_ON

  PROCEDURE [XDCL, #GATE {TS_gate} ] mlp$sign_on_os (application_name:
    mlt$application_name;
    max_messages: mlt$max_messages;
    VAR unique_application_name: mlt$application_name;
    VAR status: ost$status);

?? NEWTITLE := 'build_ant_entry ' ??
?? EJECT ??
{
{  PROCEDURE build_ant_entry
{
{    PURPOSE:
{      To obtain table space for the permit and receive lists and
{      initialize the fields of a new ANT entry.
{
{    PARAMETERS:
{      application_name: (input) the name of the application being created.
{      ant_entry: (input) index of the entry being created.
{      max_msgs: (input) maximum number of queued messages for this
{                application.
{      status: (output) status of the operation.
{
{    NOTES:
{      . The signon count is initialized to one.
{
{      . The system name is obtained from the global variable containing it.

    PROCEDURE build_ant_entry (application_name: mlt$application_name;
      ant_entry: mlt$ant_index;
      max_msgs: mlt$max_messages;
      VAR status: mlt$status);

      VAR
        ip: mlt$permit_index, { permit list index }
        ir: mlt$receive_index, { receive list index }
        cae: ^mlt$ant_entry; { pointer to the current ANT entry }

      cae := ^mlv$shared_segment.ant [ant_entry];
{
{ obtain table interlock }
{
      lock (mlv$shared_segment.tlock, status);
      IF status <> mlc$ok THEN
        RETURN;
      IFEND;
{
{ obtain permit list space }
{
      ALLOCATE cae^.permit_list IN mlv$shared_segment.pspace;
      IF cae^.permit_list = NIL THEN
        unlock (mlv$shared_segment.tlock, status);
        status := mlc$pool_buffer_not_avail;
        RETURN;
      IFEND;
{
{ obtain receive list space }
{
      ALLOCATE cae^.receive_list IN mlv$shared_segment.pspace;
{
{ if not available then free permit space and return
{
      IF cae^.receive_list = NIL THEN
        FREE cae^.permit_list IN mlv$shared_segment.pspace;
        unlock (mlv$shared_segment.tlock, status);
        status := mlc$pool_buffer_not_avail;
        RETURN;
      IFEND;
{
{ space was obtained for both tables }
{
      unlock (mlv$shared_segment.tlock, status);
{
{ initialize new entry fields
{
      cae^.application_name := application_name * mlc$shift + mlc$ilk;
      cae^.system_name := system_name;
cae^.job_recovery_index:=0;
      IF max_msgs = 0 THEN

{ allow multiple messages from same sender

        cae^.max_messages := mlc$max_in_transit;
        cae^.multiple := TRUE;
      ELSE
      cae^.max_messages := max_msgs;
        cae^.multiple := FALSE;
      IFEND;
      cae^.unique := - 1;
      cae^.handler := NIL;
      cae^.highest_rl_entry := 0;
      cae^.active_rl_count := 0;
{
{ initialize new lists
{
      FOR ip := 1 TO mlc$max_permits DO
        cae^.permit_list^ [ip].sender := mlc$empty_entry;
      FOREND;
      FOR ir := 1 TO mlc$max_queued_messages DO
        cae^.receive_list^ [ir].sender_name := mlc$empty_entry;
        cae^.receive_list^ [ir].chained_entry := NIL;
        cae^.receive_list^ [ir].message_location := NIL;
      FOREND;
      status := mlc$ok;
    PROCEND build_ant_entry;

?? OLDTITLE ??


?? EJECT ??
{
{  MLP$SIGN_ON
{

    VAR
      success: boolean, { status from reserve_ant_entry }
      i: mlt$ant_index, { ANT search index }
      j: integer, { loop vrbl }
      sn_hash: mlt$sn_table_index,
      sn_table_seed: integer,
      unique_set: mlt$unique, { in use / free unique name }
      ant_entry: mlt$ant_index, { index into the ANT }
      sstat: mlt$search_status, { search_ant status }
      sn: mlt$system_name, { dummy system name }
      cae: ^mlt$ant_entry, { pointer to the current ANT entry }
      stat: mlt$status, { local status }
      res_value: integer,
      last_chained_entry: mlt$ant_index,
      ost: ost$status,
      cnt: mlt$ant_index; { count of the number of signons from this task }

    #INLINE ('keypoint', osk$entry, 0, mlk$sign_on);
    mli_init (stat);
    status.normal := FALSE;
    IF stat <> mlc$ok THEN
      status.condition := stat;
      #INLINE ('keypoint', osk$exit, 0, mlk$sign_on);
      RETURN;
    IFEND;
    status.condition := mlc$ok;

  /locked/
    BEGIN
{
{ process application name
{
      IF application_name <> mlc$unique_name THEN
        validate_name (application_name, stat);
        IF stat <> mlc$ok THEN
          status.condition := mlc$receiver_name_syntax_error;
          EXIT /locked/;
        IFEND;
      IFEND;
      IF max_messages > mlc$max_queued_messages THEN
        status.condition := mlc$max_msgs_too_large;
        EXIT /locked/;
      IFEND;
{
{ search the ant and count all signons from this system name
{ also count all free / in use unique names
{
      cnt := 0;
      unique_set := $mlt$unique [];
      CASE system_name.c170_c180_flag OF
        = mlc$c180 =
          sn_table_seed := system_name.name_180.index;
        = c170 =
          sn_table_seed := ((system_name.name_170) DIV 100(16))
            MOD 1000000(16);
      CASEND;
{
{  create hash index into sn table to find end of chain
{
      sn_hash := (sn_table_seed MOD (mlc$max_sn_entry - 1)) + 1;
      i := mlv$shared_segment.sn_chain_table [sn_hash];
      WHILE i <> mlc$end_of_chain DO
        check_sn (mlv$shared_segment.ant [i].system_name, stat);
        IF stat = mlc$ok THEN
          cnt := cnt + 1;
          j := mlv$shared_segment.ant [i].unique;
          IF j <> - 1 THEN
            unique_set := unique_set + $mlt$unique [j];
          IFEND;
        IFEND;
        i := mlv$shared_segment.ant[i].sn_bkwd_p;
      WHILEND;
      IF cnt = mlc$max_signons_per_system_name THEN
        status.condition := mlc$max_signons_this_task;
        EXIT /locked/;
      IFEND;
      IF application_name = mlc$unique_name THEN
{
{ signon with mlc$unique_name - generate unique application name
{
{
{ search task unique set
{

      /search/
        BEGIN
          FOR j := 1 TO mlc$max_signons_per_system_name DO
            IF NOT (j IN unique_set) THEN
              EXIT /search/;
            IFEND;
          FOREND;
{
{ this case must never happen
{
          status.condition := mlc$mli_internal_error;
          mli_error (unique_error);
          EXIT /locked/;
        END /search/;
      CASE system_name.c170_c180_flag OF
        = mlc$none =
          status.condition := mlc$mli_internal_error;
        mli_error (bad_system_name);
          EXIT /locked/;
        = mlc$c180 =
          unique_application_name := (system_name.name_180.index * 256 +
            system_name.name_180.seqno) * 256 + (j - 1);
        = c170 =
          unique_application_name := system_name.name_170 * 256 + (j - 1);
        CASEND;
      ELSE
        unique_application_name := application_name;
      IFEND;
      sn.c170_c180_flag := mlc$none;
      search_ant (unique_application_name, sn, ant_entry, sstat);
      IF ant_entry <> 0 THEN
        cae := ^mlv$shared_segment.ant [ant_entry];
      ELSE
        cae := NIL;
      IFEND;
IF system_name.c170_c180_flag = mlc$c180 THEN
  IF mlv$job_signon_count = mlc$max_signons_per_job THEN
    status.condition := mlc$max_job_signons;
    EXIT /locked/;
  IFEND;
IFEND;
      CASE sstat OF
      = found =
{
{ check system name match }
{
      check_sn (cae^.system_name, stat);
      IF stat <> mlc$ok THEN
        status.condition := mlc$system_name_no_match;
          EXIT /locked/;
        IFEND;
{
{ multiple sign_ons are not allowed
{
        status.condition := mlc$max_signons_this_appl;
        EXIT /locked/;
      = not_found =
      IF cae = NIL THEN
        status.condition := mlc$ant_full;
          EXIT /locked/;
      IFEND;
{
{  interpret ant_entry. may point to empty entry in primary table but
{  points to last entry in chain if primary entry was in use.
{
      last_chained_entry := mlc$end_of_chain;
      osp$fetch_locked_variable(mlv$shared_segment.ant[ant_entry].reservation, res_value);
      IF res_value = mlc$ilk THEN
        last_chained_entry := ant_entry;
        ant_entry := mlv$shared_segment.next_free_ant_entry;
        cae := ^mlv$shared_segment.ant[ant_entry];
      IFEND;
{
{ attempt to reserve the free ant entry }
{
      lock (cae^.reservation, stat);
      IF stat <> mlc$ok THEN
        status.condition := mlc$busy_interlock;
          EXIT /locked/;
      IFEND;
{
{ create the new entry }
{
        build_ant_entry (unique_application_name, ant_entry, max_messages,
          stat);
      IF stat <> mlc$ok THEN
{
{ destroy entry }
{
        cae^.application_name := mlc$empty_entry;
        cae^.system_name.c170_c180_flag := mlc$none;
        status.condition := stat;
        unlock (cae^.reservation, stat);
          EXIT /locked/;
        IFEND;
        IF application_name = mlc$unique_name THEN
          cae^.unique := j;
      IFEND;
{
{  link new chained entry into ant table
{
      IF last_chained_entry <> mlc$end_of_chain THEN
        mlv$shared_segment.ant [last_chained_entry].forward_p
          := ant_entry;
        cae^.backward_p := last_chained_entry;
        mlv$shared_segment.next_free_ant_entry :=
          cae^.forward_p;
        cae^.forward_p := mlc$end_of_chain;
      IFEND;
{
{  link new entry into sn chain to limit sn search time
{
      IF mlv$shared_segment.sn_chain_table [sn_hash] <> 0 THEN
        mlv$shared_segment.ant [mlv$shared_segment.
          sn_chain_table [sn_hash] ].sn_fwd_p := ant_entry;
        cae^.sn_bkwd_p := mlv$shared_segment.sn_chain_table [sn_hash];
      IFEND;
      mlv$shared_segment.sn_chain_table [sn_hash] := ant_entry;
{
{ set value of callers_ant_index to point to ant entry for this application.
{ *** note *** this will only work when task private data is avail.
{
      callers_ant_index := ant_entry;
        cae^.last_operation.req := mlc$sign_on_req;
        cae^.last_operation.stat_condition := status.condition;
        EXIT /locked/;
    ELSE
{
{ this case should never occur }
{
      status.condition := mlc$mli_internal_error;
      mli_error (case_err);
        EXIT /locked/;
      CASEND;
    END /locked/;
{
{ signon complete - status return is set
{
  IF status.condition = mlc$ok THEN
    status.normal := TRUE;
IF system_name.c170_c180_flag = mlc$c180 THEN
  IF mlv$job_recovery_info = NIL THEN
    ALLOCATE mlv$job_recovery_info IN osv$job_fixed_heap^;
    FOR j := 1 TO mlc$max_signons_per_job DO
      mlv$job_recovery_info^ [j].status := mlc$invalid;
    FOREND;
  IFEND;

/store_job_recovery/
  FOR j := 1 TO mlc$max_signons_per_job DO
    IF mlv$job_recovery_info^ [j].status = mlc$invalid THEN
      mlv$job_recovery_info^ [j].an := unique_application_name;
      mlv$job_recovery_info^ [j].mm := cae^.max_messages;
      mlv$job_recovery_info^ [j].sn := cae^.system_name;
      mlv$job_recovery_info^ [j].u := cae^.unique;
      mlv$job_recovery_info^ [j].h := cae^.handler;
      mlv$job_recovery_info^ [j].m := cae^.multiple;
      cae^.job_recovery_index := j;
      mlv$job_recovery_info^ [j].status := mlc$valid;
      mlv$job_signon_count := mlv$job_signon_count + 1;
      EXIT /store_job_recovery/;
    IFEND;
  FOREND /store_job_recovery/;
IFEND;
  IFEND;
  osp$clear_mainframe_sig_lock (mlv$lock);
    #INLINE ('keypoint', osk$exit, 0, mlk$sign_on);

PROCEND mlp$sign_on_os;
?? OLDTITLE ??
?? NEWTITLE := 'mlp$sign_off' ??
?? EJECT ??
*copyc MLH$SIGN_OFF

  PROCEDURE [XDCL, #GATE {TS_gate} ] mlp$sign_off_os (application_name:
    mlt$application_name;
    VAR status: ost$status);

?? NEWTITLE := 'release_ant_entry' ??
?? EJECT ??
{
{  PROCEDURE release_ant_entry
{
{    PURPOSE:
{      To release (sign off) the application from MLI.
{
{    PARAMETERS:
{      ant_entry: (input) ANT index of the application being signed off.
{      status: (output) status of the operation.
{
{    NOTES:
{      . It is important that the fields of the entry be destroyed before
{      the interlock and reservation are released.  The release of the
{      reservation *must* be the last operation performed because that is the
{      field that decides if an entry is in use or not.  Once it is clear,
{      the entry must be available for use.

PROCEDURE release_ant_entry (ant_entry: mlt$ant_index;
  VAR status: mlt$status);

  VAR
    stat: mlt$status, { local status }
        j: integer, { loop vrbl }
        sn_table_seed: integer,
        sn_hash: mlt$sn_table_index,
        cae: ^mlt$ant_entry; { pointer to the current ANT entry }

      cae := ^mlv$shared_segment.ant [ant_entry];
    release_ant_entry_resources (ant_entry, status);
    IF status = mlc$busy_interlock THEN
      RETURN;
    IFEND;
{
{ destroy fields - note that the interlock is cleared by the setting
{ of the application name field (kind of)
{
    cae^.application_name := mlc$empty_entry;
    cae^.system_name.c170_c180_flag := mlc$none;
    cae^.max_messages := 0;
      cae^.unique := - 1;
    CASE system_name.c170_c180_flag OF
      = mlc$c180 =
        sn_table_seed := system_name.name_180.index;
      = c170 =
        sn_table_seed := ((system_name.name_170) DIV 100(16))
          MOD 1000000(16);
    CASEND;
{
{  create index to bottom of chain for this system name
{
    sn_hash := (sn_table_seed MOD (mlc$max_sn_entry - 1)) + 1;
{
{  remove entry from system name chain
{
    IF ant_entry = mlv$shared_segment.sn_chain_table [sn_hash] THEN
      mlv$shared_segment.sn_chain_table [sn_hash]
        := cae^.sn_bkwd_p;
    ELSE
      mlv$shared_segment.ant [cae^.sn_fwd_p].sn_bkwd_p
        := cae^.sn_bkwd_p;
    IFEND;
    IF cae^.sn_bkwd_p <> 0 THEN
      mlv$shared_segment.ant [cae^.sn_bkwd_p].sn_fwd_p
        := cae^.sn_fwd_p;
    IFEND;
    cae^.sn_fwd_p := mlc$end_of_chain;
    cae^.sn_bkwd_p := mlc$end_of_chain;
{
{  destroy handler info
{
    cae^.handler := NIL;
{
{  if entry is chained, return to free pool.
{
    IF cae^.backward_p <> mlc$end_of_chain THEN
      IF cae^.forward_p <> mlc$end_of_chain THEN
        mlv$shared_segment.ant[cae^.forward_p].backward_p
          := cae^.backward_p;
      IFEND;
      mlv$shared_segment.ant[cae^.backward_p].forward_p
        := cae^.forward_p;
      cae^.forward_p := mlv$shared_segment.next_free_ant_entry;
      mlv$shared_segment.next_free_ant_entry := ant_entry;
    IFEND;
{
{ release entry reservation
{
    unlock (cae^.reservation, stat);
PROCEND release_ant_entry;

?? OLDTITLE ??


?? EJECT ??
{
{  MLP$SIGN_OFF
{

VAR
  cae: ^mlt$ant_entry, { pointer to the current ANT entry }
  ant_entry: mlt$ant_index, { index into the ANT }
  stat: mlt$status, { local status }
      ost: ost$status,
  sstat: mlt$search_status; { search_ant status }

    #INLINE ('keypoint', osk$entry, 0, mlk$sign_off);
    mli_init (stat);
    status.normal := FALSE;
    IF stat <> mlc$ok THEN
      status.condition := stat;
      #INLINE ('keypoint', osk$exit, 0, mlk$sign_off);
      RETURN;
    IFEND;
    status.condition := mlc$ok;

  /locked/
    BEGIN
{
{ validate  names
{
      validate_name (application_name, stat);
      IF stat <> mlc$ok THEN
        status.condition := mlc$receiver_name_syntax_error;
        EXIT /locked/;
      IFEND;
{
{ process request
{
      search_ant (application_name, system_name, ant_entry, sstat);
      IF ant_entry <> 0 THEN
        cae := ^mlv$shared_segment.ant [ant_entry];
      ELSE
        cae := NIL;
      IFEND;
      CASE sstat OF
      = not_found =
        status.condition := mlc$receiver_not_signed_on;
        EXIT /locked/;
      = no_match =
        status.condition := mlc$system_name_no_match;
        EXIT /locked/;
      = found =
        release_ant_entry (ant_entry, stat);
        status.condition := stat;
{
{ note that release_ant_entry has unlocked both the entry and reservation
{ interlocks.
{
      CASEND;
    END /locked/;
    IF status.condition = mlc$ok THEN
      status.normal := TRUE;
    IFEND;
    osp$clear_mainframe_sig_lock (mlv$lock);
    #INLINE ('keypoint', osk$exit, 0, mlk$sign_off);


PROCEND mlp$sign_off_os;
?? OLDTITLE ??
?? NEWTITLE := 'mlp$add_sender ' ??
?? EJECT ??
*copyc MLH$ADD_SENDER

  PROCEDURE [XDCL, #GATE {TS_gate} ] mlp$add_sender_os (application_name:
    mlt$application_name;
    sender_name: mlt$application_name;
    VAR status: ost$status);

?? NEWTITLE := 'build_permit_list_entry ' ??
?? EJECT ??
{
{  PROCEDURE build_permit_list_entry
{
{    PURPOSE:
{      To add a new sender to the application's permit list, if possible.
{      If the sender is already in the permit list, the operation is ignored.
{      If the sender is not in the permit list, then a new permit list entry
{      is reserved and initialized with the sender name, if possible.
{
{    PARAMETERS:
{      application_name: (input) the application name of the sender to be
{                        added to the permit list.
{      ant_entry: (input) ANT index of the application performing the permit.
{      status: (output) status of the operation.

PROCEDURE build_permit_list_entry (application_name: mlt$application_name;
  ant_entry: mlt$ant_index;
  VAR status: mlt$status);

  VAR
    permit_entry: mlt$permit_index; { index of current permit entry }
{
{ check for duplicate permits
{
  search_permit_list (application_name, ant_entry, permit_entry);
  IF permit_entry <> mlc$not_found THEN
    status := mlc$dup_permits_ignored;
    RETURN;
  IFEND;
{
{ check for empty entry
  search_permit_list (mlc$empty_entry, ant_entry, permit_entry);
  IF permit_entry = mlc$not_found THEN
    status := mlc$permit_list_full;
    RETURN;
  IFEND;
{
{ create new entry
{
      mlv$shared_segment.ant [ant_entry].permit_list^ [permit_entry].sender :=
            application_name;
  status := mlc$ok;
PROCEND build_permit_list_entry;
?? OLDTITLE ??

?? EJECT ??
{
{ MLP$ADD_SENDER
{

VAR
  ant_entry: mlt$ant_index, { index into ANT of current entry }
  stat: mlt$status, { local status }
  sstat: mlt$search_status, { local search_ant status }
      ost: ost$status,
  cae: ^mlt$ant_entry; { pointer to current ANT entry }

    #INLINE ('keypoint', osk$entry, 0, mlk$add_sender);
    mli_init (stat);
    status.normal := FALSE;
    IF stat <> mlc$ok THEN
      status.condition := stat;
      #INLINE ('keypoint', osk$exit, 0, mlk$add_sender);
      RETURN;
    IFEND;
    status.condition := mlc$ok;

  /locked/
    BEGIN
{
{ validate  names
{
      validate_name (application_name, stat);
      IF stat <> mlc$ok THEN
        status.condition := mlc$receiver_name_syntax_error;
        EXIT /locked/;
      IFEND;
      IF sender_name <> mlc$unique_name THEN
        validate_name (sender_name, stat);
        IF stat <> mlc$ok THEN
          status.condition := mlc$sender_name_syntax_error;
          EXIT /locked/;
        IFEND;
      IFEND;
{
{ process request
{
      search_ant (application_name, system_name, ant_entry, sstat);
      CASE sstat OF
      = not_found =
        status.condition := mlc$receiver_not_signed_on;
        EXIT /locked/;
      = no_match =
        status.condition := mlc$system_name_no_match;
        EXIT /locked/;
      = found =
        cae := ^mlv$shared_segment.ant [ant_entry];
        build_permit_list_entry (sender_name, ant_entry, stat);
        status.condition := stat;
        cae^.last_operation.req := mlc$add_sender_req;
        cae^.last_operation.stat_condition := status.condition;
      CASEND;
    END /locked/;
    IF stat = mlc$ok THEN
      status.normal := TRUE;
    IFEND;
    osp$clear_mainframe_sig_lock (mlv$lock);
    #INLINE ('keypoint', osk$exit, 0, mlk$add_sender);

PROCEND mlp$add_sender_os;
?? OLDTITLE ??
?? NEWTITLE := 'mlp$delete_sender' ??
?? EJECT ??
*copyc MLH$DELETE_SENDER

  PROCEDURE [XDCL, #GATE {TS_gate} ] mlp$delete_sender_os (application_name:
    mlt$application_name;
    sender_name: mlt$application_name;
    VAR status: ost$status);

?? NEWTITLE := 'release_permit_list_entry ' ??
?? EJECT ??
{
{  PROCEDURE release_permit_list_entry
{
{    PURPOSE:
{      To remove a sender from the permit list.  The sender must have been
{      previously added to the permit list.  An error status is returned if
{      there are any messages from the sender being deleted still waiting
{      to be received.
{
{    PARAMETERS:
{      ant_entry: (input) ANT index of the application the sender is being
{                 deleted from.
{      sender_name: (input) the name of the application whose permission
{                    to send is being removed.
{      status: (output) status of the operation.

PROCEDURE release_permit_list_entry (ant_entry: mlt$ant_index;
  sender_name: mlt$application_name;
  VAR status: mlt$status);

  VAR
        receive_entry: mlt$receive_index, { index of current receive list entry
        {}
    permit_entry: mlt$permit_index; { index of current permit list entry }

{{ check if name in list
{
  search_permit_list (sender_name, ant_entry, permit_entry);
  IF permit_entry = mlc$not_found THEN
    status := mlc$sender_not_permitted;
    RETURN;
  IFEND;
{
{ destroy the entry
{
      mlv$shared_segment.ant [ant_entry].permit_list^ [permit_entry].sender :=
            mlc$empty_entry;
{
{ check for messages queued from the deleted sender
{
  search_receive_list (sender_name, ant_entry, receive_entry);
  IF receive_entry = mlc$not_found THEN
{
{ no queued messages
{
    status := mlc$ok;
  ELSE
{
{ message were (are) queued
{
    status := mlc$msgs_from_sender_queued;
  IFEND;
PROCEND release_permit_list_entry;
?? OLDTITLE ??

?? EJECT ??
{
{ MLP$DELETE_SENDER
{

VAR
  sstat: mlt$search_status, { local search_ant status }
  cae: ^mlt$ant_entry, { pointer to the current ANT entry }
  ant_entry: mlt$ant_index, { index of the current ANT entry }
      ost: ost$status,
  stat: mlt$status; { local status }

    #INLINE ('keypoint', osk$entry, 0, mlk$delete_sender);
    mli_init (stat);
    status.normal := FALSE;
    IF stat <> mlc$ok THEN
      status.condition := stat;
      #INLINE ('keypoint', osk$exit, 0,
            mlk$delete_sender);
      RETURN;
    IFEND;
    status.condition := mlc$ok;

  /locked/
    BEGIN
{
{ validate  names
{
      validate_name (application_name, stat);
      IF stat <> mlc$ok THEN
        status.condition := mlc$receiver_name_syntax_error;
        EXIT /locked/;
      IFEND;
      IF sender_name <> mlc$unique_name THEN
        validate_name (sender_name, stat);
        IF stat <> mlc$ok THEN
          status.condition := mlc$sender_name_syntax_error;
          EXIT /locked/;
        IFEND;
      IFEND;
{
{ process request
{
      search_ant (application_name, system_name, ant_entry, sstat);
      CASE sstat OF
      = not_found =
        status.condition := mlc$receiver_not_signed_on;
        EXIT /locked/;
      = no_match =
        status.condition := mlc$system_name_no_match;
        EXIT /locked/;
      = found =
        cae := ^mlv$shared_segment.ant [ant_entry];
        release_permit_list_entry (ant_entry, sender_name, stat);
        status.condition := stat;
        cae^.last_operation.req := mlc$delete_sender_req;
        cae^.last_operation.stat_condition := status.condition;
      CASEND;
    END /locked/;
    IF stat = mlc$ok THEN
      status.normal := TRUE;
    IFEND;
    osp$clear_mainframe_sig_lock (mlv$lock);
    #INLINE ('keypoint', osk$exit, 0,
          mlk$delete_sender);

PROCEND mlp$delete_sender_os;
?? OLDTITLE ??
?? NEWTITLE := 'mlp$confirm_send ' ??
?? EJECT ??
*copyc MLH$CONFIRM_SEND

  PROCEDURE [XDCL, #GATE {TS_gate} ] mlp$confirm_send_os (application_name:
    mlt$application_name;
    destination_name: mlt$application_name;
    VAR status: ost$status);

?? EJECT ??
{
{ MLP$CONFIRM_SEND
{

VAR
  s_ant_entry: mlt$ant_index, { index into the ANT of the the sender }
  r_ant_entry: mlt$ant_index, { index into the ANT of the receiver }
  sstat: mlt$search_status, { local search_ant status }
  stat: mlt$status, { local status }
  sn: mlt$system_name, { dummy system name }
      ost: ost$status,
  cae: ^mlt$ant_entry; { pointer to the current ANT entry }

    #INLINE ('keypoint', osk$entry, 0, mlk$confirm_send);
    mli_init (stat);
    status.normal := FALSE;
    IF stat <> mlc$ok THEN
      status.condition := stat;
      #INLINE ('keypoint', osk$exit, 0,
            mlk$confirm_send);
      RETURN;
    IFEND;
    status.condition := mlc$ok;

  /locked/
    BEGIN
{
{ validate  names
{
      validate_name (application_name, stat);
      IF stat <> mlc$ok THEN
        status.condition := mlc$sender_name_syntax_error;
        EXIT /locked/;
      IFEND;
      search_ant (application_name, system_name, s_ant_entry, sstat);
      CASE sstat OF
      = not_found =
        status.condition := mlc$sender_not_signed_on;
        EXIT /locked/;
      = no_match =
        status.condition := mlc$system_name_no_match;
        EXIT /locked/;
      = found =
        validate_name (destination_name, stat);
        IF stat <> mlc$ok THEN
          status.condition := mlc$receiver_name_syntax_error;
          EXIT /locked/;
        IFEND;
{
{ process request
{
  sn.c170_c180_flag := mlc$none;
  search_ant (destination_name, sn, r_ant_entry, sstat);

      /confirm/
        BEGIN
          CASE sstat OF
          = not_found =
            status.condition := mlc$receiver_not_signed_on;
            EXIT /locked/;
          = no_match =
{
{ this case must never occur
{
            mli_error (case_err);
            status.condition := mlc$mli_internal_error;
            EXIT /locked/;
          = found =
            cae := ^mlv$shared_segment.ant [r_ant_entry];
{
{ check for c170 to c170 request
{
            IF (cae^.system_name.c170_c180_flag = c170) AND (system_name.
              c170_c180_flag = c170) THEN
              status.condition := mlc$c170_c170_illegal;
              EXIT /confirm/;
            IFEND;
{
{ check sender allowed to send to the receiver
{
            confirm_sender_allowed_to_send (application_name, r_ant_entry,
              stat);
            IF stat <> mlc$ok THEN
              status.condition := stat;
              EXIT /confirm/;
            IFEND;
{
{ check receiver ready to receive
{
            confirm_receiver_ready (application_name, r_ant_entry, FALSE, stat);
            IF stat <> mlc$ok THEN
              status.condition := stat;
              EXIT /confirm/;
            IFEND;
          CASEND;
        END /confirm/;
        mlv$shared_segment.ant[s_ant_entry].last_operation.req := mlc$confirm_send_req;
        mlv$shared_segment.ant[s_ant_entry].last_operation.stat_condition := status.condition;
      CASEND;
    END /locked/;
    IF status.condition = mlc$ok THEN
      status.normal := TRUE;
    IFEND;
    osp$clear_mainframe_sig_lock (mlv$lock);
    #INLINE ('keypoint', osk$exit, 0, mlk$confirm_send);

PROCEND mlp$confirm_send_os;
?? OLDTITLE ??
?? NEWTITLE := 'mlp$fetch_receive_list' ??
?? EJECT ??
*copyc MLH$FETCH_RECEIVE_LIST

  PROCEDURE [XDCL, #GATE {TS_gate} ] mlp$fetch_receive_list_os
    (application_name: mlt$application_name;
    sender_name: mlt$application_name;
    VAR receive_list: mlt$receive_list;
    VAR receive_count: mlt$receive_count;
    VAR status: ost$status);

?? NEWTITLE := 'scan_receive_list ' ??
?? EJECT ??
{
{  PROCEDURE scan_receive_list
{
{    PURPOSE:
{      To find every valid receive list entry in an applications receive list
{      and copy the fields that make up a receive list entry to the user area.
{{    PARAMETERS:
{      ant_entry: (input) ANT index of the receiver application.
{      sender_name: (input) application name to return information for.
{      receive_count: (output) the number of entries found and returned to
{                     the user.
{      fetchrl_list: (output) the fetchrl list provided by the caller in
{                    which to put the receive list information.
{
{    NOTES:
{      . A valid entry is either:
{         1) any active entry if the sender name is null, or,
{         2) any active entry whose sender name field matches the requested
{            sender name.
{

PROCEDURE scan_receive_list (ant_entry: mlt$ant_index;
  sender_name: mlt$application_name;
  VAR receive_count: mlt$receive_count;
  VAR fetchrl_list: mlt$receive_list);

  VAR
        rl: ^mlt$int_receive_list, { pointer to the receive list being scanned
        {}
    i: mlt$receive_index, { receive list search index }
    mmts: mlt$receive_index; { max messages to search from this list }

  receive_count := 0;
      rl := mlv$shared_segment.ant [ant_entry].receive_list;
      mmts := mlv$shared_segment.ant [ant_entry].highest_rl_entry;
  FOR i := 1 TO mmts DO
{
{ check for valid entry
{
        IF rl^ [i].sender_name <> mlc$empty_entry THEN
{
{ check for name match
{
          IF (sender_name = mlc$unique_name) OR (sender_name = rl^ [i].
            sender_name) THEN
{
{ found entry to copy
{
        receive_count := receive_count + 1;
            copy_fetchrl_info (rl^ [i], fetchrl_list [receive_count]);
            fetchrl_list [receive_count].receive_index := i;
      IFEND;
    IFEND;
  FOREND;
PROCEND scan_receive_list;
?? OLDTITLE ??

?? NEWTITLE := 'copy_fetchrl_info' ??
?? EJECT ??
{
{  PROCEDURE copy_fetchrl_info
{
{    PURPOSE:
{      To copy the following fields from an active receive list entry to the
{      user area -
{        1) sender application name
{        2) sender arbitrary information
{        3) receive table index
{        4) message length
{
{    PARAMETERS:
{      receive_entry: (input) the receive list entry from which information
{                     is to be copied.
{      fetchrl_entry: (output) the user area where the information is to
{                    be placed.

PROCEDURE copy_fetchrl_info (receive_entry: mlt$int_receive_list_entry;
  VAR fetchrl_entry: mlt$receive_entry);

  fetchrl_entry.sender_name := receive_entry.sender_name;
  fetchrl_entry.arbitrary_info := receive_entry.arbitrary_info;
  fetchrl_entry.message_length := receive_entry.message_length;
PROCEND copy_fetchrl_info;
?? OLDTITLE ??

?? EJECT ??
{
{ MLP$FETCH_RECEIVE_LIST
{

VAR
  sstat: mlt$search_status, { local search_ant status }
  ant_entry: mlt$ant_index, { index into the ANT of the application }
  cae: ^mlt$ant_entry, { pointer to the ANT entry of the application }
      ost: ost$status,
  stat: mlt$status; { local status }

    #INLINE ('keypoint', osk$entry, 0, mlk$fetch_receive_list);
    mli_init (stat);
    status.normal := FALSE;
    IF stat <> mlc$ok THEN
      status.condition := stat;
      #INLINE ('keypoint', osk$exit, 0,
            mlk$fetch_receive_list);
      RETURN;
    IFEND;
    status.condition := mlc$ok;

  /locked/
    BEGIN
{
{ validate  names
{
      validate_name (application_name, stat);
      IF stat <> mlc$ok THEN
        status.condition := mlc$receiver_name_syntax_error;
        EXIT /locked/;
      IFEND;
      IF sender_name <> mlc$unique_name THEN
        validate_name (sender_name, stat);
          IF stat <> mlc$ok THEN
            status.condition := mlc$sender_name_syntax_error;
          IFEND;
      IFEND;
{
{ process request
{
      search_ant (application_name, system_name, ant_entry, sstat);
      CASE sstat OF
      = not_found =
        status.condition := mlc$receiver_not_signed_on;
        EXIT /locked/;
      = no_match =
        status.condition := mlc$system_name_no_match;
        EXIT /locked/;
      = found =
{
{ interlock the application
{
        cae := ^mlv$shared_segment.ant [ant_entry];
        scan_receive_list (ant_entry, sender_name, receive_count,
          receive_list);
        cae^.last_operation.req := mlc$fetch_receive_list_req;
        cae^.last_operation.stat_condition := status.condition;
      CASEND;
    END /locked/;
    IF status.condition = mlc$ok THEN
      status.normal := TRUE;
    IFEND;
    osp$clear_mainframe_sig_lock (mlv$lock);
    #INLINE ('keypoint', osk$exit, 0,
          mlk$fetch_receive_list);

PROCEND mlp$fetch_receive_list_os;
?? OLDTITLE ??
?? NEWTITLE := 'confirm_send_and_lock ' ??
?? EJECT ??
{
{  PROCEDURE confirm_send_and_lock
{
{    PURPOSE:
{      To confirm that a send operation is allowed between two applications.
{
{    PARAMETERS:
{      sender_name: (input-output) sender application name.
{      receiver_name: (input-output) receiver application name.
{      ant_entry: (output) ANT index to receiver application ant_entry.
{      send_ant_entry: (output) ant index of sender application ant_entry.
{      status: (output) status of the operation.
{
{    NOTES:
{      . This procedure is identical to mlp$confirm_send except that it leaves
{      the ant_entry of the receiver application interlocked and returns
{      a pointer to that ant_entry when it returns.
{
{      . The ant_entry is left interlocked only if the confrim check is
{      successful.

    PROCEDURE confirm_send_and_lock (sender_name: mlt$application_name;
      receiver_name: mlt$application_name;
      force_send: boolean;
  VAR ant_entry: mlt$ant_index;
  VAR send_ant_entry: mlt$ant_index;
  VAR status: ost$status);

  VAR
    s_ant_entry: mlt$ant_index, { index into the ANT of the sender appl }
    r_ant_entry: mlt$ant_index, { index into the ANT of the receiver appl }
    sstat: mlt$search_status, { local search_ant status }
        stat: mlt$status, { local status }
        sn: mlt$system_name, { dummy system name }
        cae: ^mlt$ant_entry; { pointer to the current ANT entry }
{
      status.condition := mlc$ok;
      status.normal := FALSE;
send_ant_entry := 0;
{
{ process sender name
{
      validate_name (sender_name, stat);
  IF stat <> mlc$ok THEN
    status.condition := mlc$sender_name_syntax_error;
    RETURN;
  IFEND;
  search_ant (sender_name, system_name, s_ant_entry, sstat);
  CASE sstat OF
      = not_found =
        status.condition := mlc$sender_not_signed_on;
        RETURN;
      = no_match =
        status.condition := mlc$system_name_no_match;
        RETURN;
      = found =
send_ant_entry := s_ant_entry;
{
{ process receiver name
{
        validate_name (receiver_name, stat);
    IF stat <> mlc$ok THEN
      status.condition := mlc$receiver_name_syntax_error;
      RETURN;
    IFEND;
    sn.c170_c180_flag := mlc$none;
    search_ant (receiver_name, sn, r_ant_entry, sstat);

      /confirm/
        BEGIN
          CASE sstat OF
          = not_found =
            status.condition := mlc$receiver_not_signed_on;
            RETURN;
          = no_match =
{
{ this case must never occur
{
            mli_error (case_err);
            status.condition := mlc$mli_internal_error;
            RETURN;
          = found =
            cae := ^mlv$shared_segment.ant [r_ant_entry];
{
{ check for c170 to c170 request
{
            IF (cae^.system_name.c170_c180_flag = c170) AND (system_name.
              c170_c180_flag = c170) THEN
              status.condition := mlc$c170_c170_illegal;
              EXIT /confirm/;
        IFEND;
{
{ check sender allowed to send to the receiver
{
        confirm_sender_allowed_to_send (sender_name, r_ant_entry, stat);
        IF stat <> mlc$ok THEN
          status.condition := stat;
              EXIT /confirm/;
        IFEND;
{
{ check receiver ready to receiver
{
        confirm_receiver_ready (sender_name, r_ant_entry, force_send, stat);
        IF stat <> mlc$ok THEN
          status.condition := stat;
              EXIT /confirm/;
            IFEND;
          CASEND;
        END /confirm/;
    IF status.condition = mlc$ok THEN
      ant_entry := r_ant_entry;
    ELSE
      ant_entry := mlc$not_found;
    IFEND;
  CASEND;
  IF status.condition = mlc$ok THEN
    status.normal := TRUE;
  IFEND;
PROCEND confirm_send_and_lock;
?? OLDTITLE ??

?? NEWTITLE := 'build_rl_entry ' ??
?? EJECT ??
{
{  PROCEDURE build_rl_entry
{
{    PURPOSE:
{      1) To obtain space for the message from the buffer pool.
{      2) Move the message text from the user area to the MLI buffer.
{      3) Initialize the fields of a new receive list entry.
{      4) Send signal if required.
{
{    PARAMETERS:
{      sender_name: (input) application name of the sender.
{      arb_info: (input) arbitrary information provided by the sender.
{      length: (input) length in bytes of the message.
{      location: (input) pointer to the user message area.
{      ant_entry: (input) ANT index of the receiver application.
{      signal_option: (input) specifies if receiver is to be signaled.
{      destination_name: (input) application name of message receiver.
{      status: (output) status of the operation.

PROCEDURE build_rl_entry (sender_name: mlt$application_name;
  arb_info: mlt$arbitrary_info;
  length: mlt$message_length;
  ant_entry: mlt$ant_index;
  signal_option: mlt$signal;
  location: mlt$message_ptr;
      destination_name: mlt$application_name;
      force_send: boolean;
      VAR status: mlt$status);

      VAR
        stat: mlt$status, { local status }
        sig: pmt$signal,
        ps: ^mlt$pmt_signal,
        i: integer,
        ost: ost$status, { send_signal status }
        mptr: ^array [ * ] of cell, { pointer to MLI message buffer }
        receive_entry: mlt$receive_index, { index into receiver's receive list
        crl,
        orelp,
        relp: ^mlt$int_receive_list_entry; { pointer to rl entry being created
{
{ attempt to obtain the pool interlock
{
  lock (mlv$shared_segment.plock, status);
  IF status <> mlc$ok THEN
    RETURN;
  IFEND;

  /find_rl_entry/
    BEGIN
      IF NOT force_send THEN
      {Search for jsn match
      FOR i := 1 TO mlv$shared_segment.ant [ant_entry].highest_rl_entry DO
        IF (mlv$shared_segment.ant [ant_entry].receive_list^ [i].sender_name <>
            mlc$empty_entry) AND (mlv$shared_segment.ant [ant_entry].receive_list^ [i].ssn =
            jmv$jcb.system_name) THEN
          receive_entry := i;
          ALLOCATE crl IN mlv$shared_segment.pspace;
          IF crl = NIL THEN
            status := mlc$pool_buffer_not_avail;
            unlock (mlv$shared_segment.plock, stat);
            RETURN;
          IFEND;
          mlv$add_chain := mlv$add_chain + 1;
          {Find end of chain
          relp := ^mlv$shared_segment.ant [ant_entry].receive_list^ [i];
          WHILE relp^.chained_entry <> NIL DO
            relp := relp^.chained_entry;
          WHILEND;
          orelp := relp;
          relp^.chained_entry := crl;
          relp := crl;
          EXIT /find_rl_entry/;
        IFEND;
      FOREND;
      IFEND; {Force send}

{ chaining not required -
{ obtain an empty receive list entry

  search_receive_list (mlc$empty_entry, ant_entry, receive_entry);
  IF receive_entry = mlc$not_found THEN
{
{ this must never happen
{
    status := mlc$mli_internal_error;
    unlock (mlv$shared_segment.plock, stat);
    mli_error (send_rl_conflict);
    RETURN;
  IFEND;
  relp := ^mlv$shared_segment.ant [ant_entry].receive_list^
    [receive_entry];
  crl := NIL;
  END /find_rl_entry/;

    /locked/
  BEGIN
{
{ attempt to allocate space for the message
{
   IF length > 0 THEN
    ALLOCATE mptr: [1 .. length] IN mlv$shared_segment.pspace;
    IF mptr = NIL THEN
      status := mlc$pool_buffer_not_avail;
      IF crl <> NIL THEN
        mlv$add_chain := mlv$add_chain - 1;
        orelp^.chained_entry := NIL;
        FREE crl IN mlv$shared_segment.pspace;
      IFEND;
      unlock (mlv$shared_segment.plock, stat);
      RETURN;
    IFEND;
   ELSE
    mptr := NIL;
   IFEND;
      END /locked/;
  unlock (mlv$shared_segment.plock, stat);
{
{ build new receive list entry
{
  relp^.sender_name := sender_name;
  relp^.arbitrary_info := arb_info;
  relp^.message_location := mptr;
  relp^.message_length := length;
  relp^.chained_entry := NIL;
  relp^.ssn := jmv$jcb.system_name;
  mlv$shared_segment.ant [ant_entry].active_rl_count :=
    mlv$shared_segment.ant [ant_entry].active_rl_count + 1;
  IF mlv$shared_segment.ant [ant_entry].highest_rl_entry < receive_entry THEN
    mlv$shared_segment.ant [ant_entry].highest_rl_entry := receive_entry;
  IFEND;


{
{ send the message
{
  mlv$send_message := mlv$send_message + 1;
  mlv$send_bytes := mlv$send_bytes + length;
  status := mlc$ok;
  IF length > 0 THEN
    i#move (location, #LOC (mptr^), length);
  IFEND;
{
{ send signal if required
{
      IF signal_option <> NIL THEN
        IF mlv$shared_segment.ant [ant_entry].system_name.c170_c180_flag = c170
              THEN
          status := mlc$signal_to_c170_ignored;
        ELSE
          IF mlv$shared_segment.ant [ant_entry].handler = NIL THEN

{ ready task instead of signal

            pmp$ready_task (mlv$shared_segment.ant [ant_entry].system_name.
                  name_180, ost);
            IF NOT ost.normal THEN
              status := mlc$signal_failed_ignored;
            IFEND;
        ELSE
          sig.identifier := mlc$signal_id;
          ps := #LOC (sig.contents);
          ps^.data := signal_option^.data;
          ps^.from := sender_name;
          ps^.dest := destination_name;
          ps^.direction := mlc$send;
          pmp$send_signal (mlv$shared_segment.ant [ant_entry].system_name.
            name_180, sig, ost);
          #INLINE ('keypoint', osk$debug, 0, mlk$send_msg_send_signal);
          IF NOT ost.normal THEN
            status := mlc$signal_failed_ignored;
            #INLINE ('keypoint', osk$debug, 0,
                  mlk$send_message_signal_error);
      IFEND;
    IFEND;
  IFEND;
      IFEND;
PROCEND build_rl_entry;
?? OLDTITLE ??

?? NEWTITLE := 'mlp$send_message ' ??
?? EJECT ??
*copyc MLH$SEND_MESSAGE

  PROCEDURE [XDCL, #GATE {TS_gate} ] mlp$send_message_os (application_name:
    mlt$application_name;
    arbitrary_info: mlt$arbitrary_info;
    signal: mlt$signal;
    message_area: mlt$message_ptr;
    message_length: mlt$message_length;
    destination_name: mlt$application_name;
    VAR status: ost$status);

?? EJECT ??
{
{ MLP$SEND_MESSAGE
{

VAR
  ant_entry: mlt$ant_index, { index into the ANT for the receiver }
send_ant_entry: mlt$ant_index, {index into the ANT for the sender. }
  stat: mlt$status, { local status }
      ost: ost$status,
  cae: ^mlt$ant_entry; { pointer to sender ANT entry }

    #INLINE ('keypoint', osk$entry, 0, mlk$send_message);
    mli_init (stat);
    status.normal := FALSE;
    IF stat <> mlc$ok THEN
      status.condition := stat;
      #INLINE ('keypoint', osk$exit, 0,
            mlk$send_message);
      RETURN;
    IFEND;

  /locked/
    BEGIN
{
{ use modified version of MLP$CONFIRM_SEND to do most of the checking.
{ note that this routine will leave the entry interlocked if it returns mlc$ok.
{
      confirm_send_and_lock (application_name, destination_name, FALSE, ant_entry,
       send_ant_entry, status);
IF NOT status.normal THEN
{
{ note that confirm_send_and_lock has set status.condition
{
        EXIT /locked/;
      IFEND;
      status.condition := mlc$ok;
      status.normal := FALSE;
      cae := ^mlv$shared_segment.ant [ant_entry];

    /send/
BEGIN
{
{ check for message too long
{
  IF message_length > mlc$max_message_length THEN
    status.condition := mlc$message_too_long;
          EXIT /send/;
  IFEND;
{
{ successful validation - send message
{
        build_rl_entry (application_name, arbitrary_info, message_length,
          ant_entry, signal, message_area, destination_name, FALSE, stat);
        IF stat <> mlc$ok THEN
          status.condition := stat;
          EXIT /send/;
        IFEND;
      END /send/;
    END /locked/;
if send_ant_entry <> 0 then
mlv$shared_segment.ant[send_ant_entry].last_operation.req := mlc$send_message_req;
mlv$shared_segment.ant[send_ant_entry].last_operation.stat_condition :=
status.condition;
ifend;
    IF status.condition = mlc$ok THEN
      status.normal := TRUE;
    IFEND;
    osp$clear_mainframe_sig_lock (mlv$lock);
    #INLINE ('keypoint', osk$exit, 0, mlk$send_message);

PROCEND mlp$send_message_os;
?? NEWTITLE := 'mlp$force_send_message ' ??
?? EJECT ??
*copyc MLH$SEND_MESSAGE

  PROCEDURE [XDCL, #GATE {TS_gate} ] mlp$force_send_message (application_name:
    mlt$application_name;
    arbitrary_info: mlt$arbitrary_info;
    signal: mlt$signal;
    message_area: mlt$message_ptr;
    message_length: mlt$message_length;
    destination_name: mlt$application_name;
    VAR status: ost$status);

?? EJECT ??
{
{ MLP$SEND_MESSAGE
{

VAR
  ant_entry: mlt$ant_index, { index into the ANT for the receiver }
send_ant_entry: mlt$ant_index, {index into the ANT for the sender. }
  stat: mlt$status, { local status }
      ost: ost$status,
  cae: ^mlt$ant_entry; { pointer to sender ANT entry }

    #INLINE ('keypoint', osk$entry, 0, mlk$send_message);
    mli_init (stat);
    status.normal := FALSE;
    IF stat <> mlc$ok THEN
      status.condition := stat;
      #INLINE ('keypoint', osk$exit, 0,
            mlk$send_message);
      RETURN;
    IFEND;

  /locked/
    BEGIN
{
{ use modified version of MLP$CONFIRM_SEND to do most of the checking.
{ note that this routine will leave the entry interlocked if it returns mlc$ok.
{
      confirm_send_and_lock (application_name, destination_name, TRUE, ant_entry,
       send_ant_entry, status);
IF NOT status.normal THEN
{
{ note that confirm_send_and_lock has set status.condition
{
        EXIT /locked/;
      IFEND;
      status.condition := mlc$ok;
      status.normal := FALSE;
      cae := ^mlv$shared_segment.ant [ant_entry];

    /send/
BEGIN
{
{ check for message too long
{
  IF message_length > mlc$max_message_length THEN
    status.condition := mlc$message_too_long;
          EXIT /send/;
  IFEND;
{
{ successful validation - send message
{
        build_rl_entry (application_name, arbitrary_info, message_length,
          ant_entry, signal, message_area, destination_name, TRUE, stat);
        IF stat <> mlc$ok THEN
          status.condition := stat;
          EXIT /send/;
        IFEND;
      END /send/;
    END /locked/;
if send_ant_entry <> 0 then
mlv$shared_segment.ant[send_ant_entry].last_operation.req := mlc$send_message_req;
mlv$shared_segment.ant[send_ant_entry].last_operation.stat_condition :=
status.condition;
ifend;
    IF status.condition = mlc$ok THEN
      status.normal := TRUE;
    IFEND;
    osp$clear_mainframe_sig_lock (mlv$lock);
    #INLINE ('keypoint', osk$exit, 0, mlk$send_message);

PROCEND mlp$force_send_message;
?? OLDTITLE ??
?? NEWTITLE := 'mlp$receive_message ' ??
?? EJECT ??
*copyc MLH$RECEIVE_MESSAGE

  PROCEDURE [XDCL, #GATE {TS_gate} ] mlp$receive_message_os (application_name:
    mlt$application_name;
    VAR arbitrary_info: mlt$arbitrary_info;
    signal: mlt$signal;
    message_area: mlt$message_ptr;
    VAR message_length: mlt$message_length;
    message_area_length: mlt$message_length;
    receive_index: mlt$receive_index;
    VAR sender_name: mlt$application_name;
    VAR status: ost$status);

?? NEWTITLE := 'receive_message ' ??
?? EJECT ??
{
{  PROCEDURE receive_message
{
{    PURPOSE:
{      1) To move the message from a MLI buffer to the user area.
{      2) Send a signal to the sender if required.
{      3) Release all resources associated with the message.
{
{    PARAMETERS:
{      length: (input) actual length to move, in bytes.  It is the smaller of
{              the actual message length and the length of the user area.
{      signal_option: (input) specifies if receiver is to be signaled.
{      user_loc: (input) location of the user area to move message to.
{      application_name: (input) application name of the receiver.
{      receive_entry: (input-output) the receive list entry whose message is
{                     being received.
{      status: (output) status of the operation.

PROCEDURE receive_message (signal_option: mlt$signal;
  user_loc: mlt$message_ptr;
  length: mlt$message_length;
      application_name: mlt$application_name;
  VAR receive_entry: mlt$int_receive_list_entry;
  VAR status: mlt$status);

  VAR
    ost: ost$status, { send_signal status }
        sig: pmt$signal,
        stat: mlt$status,
        ps: ^mlt$pmt_signal,
        i: integer,
    temp_rl: mlt$int_receive_list_entry,
    sn: mlt$system_name, { dummy system name for ANT search }
    ant_entry: mlt$ant_index, { ANT index of sender }
        buf_loc: ^array [ * ] of cell; { pointer to the MLI message buffer }
{
{ interlock the message pool here so that the message is not copied
{ if the pool is busy, since the space could not be returned to the pool.
{
  lock (mlv$shared_segment.plock, status);
  IF status <> mlc$ok THEN
    RETURN;
  IFEND;
{
{ copy message text from MLI to user area
{
  buf_loc := receive_entry.message_location;
  IF length > 0 THEN
    i#move (#LOC (buf_loc^), user_loc, length);
  IFEND;
{
{ send signal to sender if required
{
      IF signal_option <> NIL THEN
    status := mlc$ok;
{
{ find sender application in the ANT
{
    sn.c170_c180_flag := mlc$none;
    search_ant (receive_entry.sender_name, sn, ant_entry, sstat);
    CASE sstat OF
        = not_found, no_match =
          status := mlc$signal_failed_ignored;
        = found =
          IF mlv$shared_segment.ant [ant_entry].system_name.c170_c180_flag =
            c170 THEN
            status := mlc$signal_to_c170_ignored;
          ELSE
            IF mlv$shared_segment.ant [ant_entry].handler = NIL THEN

{ ready task instead of signal

              pmp$ready_task (mlv$shared_segment.ant [ant_entry].system_name.
                    name_180, ost);
              IF NOT ost.normal THEN
                status := mlc$signal_failed_ignored;
              IFEND;
            ELSE
            sig.identifier := mlc$signal_id;
            ps := #LOC (sig.contents);
            ps^.data := signal_option^.data;
            ps^.from := application_name;
            ps^.dest := receive_entry.sender_name;
            ps^.direction := mlc$receive;
            pmp$send_signal (mlv$shared_segment.ant [ant_entry].system_name.
              name_180, sig, ost);
            #INLINE ('keypoint', osk$debug, 0, mlk$rec_message_send_signal);
            IF NOT ost.normal THEN
              status := mlc$signal_failed_ignored;
              #INLINE ('keypoint', osk$debug, 0,
                    mlk$rec_message_signal_error);
        IFEND;
      IFEND;
          IFEND;
    CASEND;
  IFEND;
  IF receive_entry.message_location <> NIL THEN
    FREE receive_entry.message_location IN mlv$shared_segment.pspace;
  IFEND;
  IF receive_entry.chained_entry = NIL THEN
    receive_entry.sender_name := mlc$empty_entry;
  ELSE
    temp_rl := receive_entry.chained_entry^;
    FREE receive_entry.chained_entry IN mlv$shared_segment.pspace;
    mlv$remove_chain := mlv$remove_chain + 1;
    receive_entry := temp_rl;
  IFEND;
  unlock (mlv$shared_segment.plock, stat);
PROCEND receive_message;
?? OLDTITLE ??

?? EJECT ??
{
{ MLP$RECEIVE_MESSAGE
{

VAR
  ant_entry: mlt$ant_index, { index into the ANT of the receiver }
  cae: ^mlt$ant_entry, { pointer to the receiver ANT entry }
  stat: mlt$status, { local status }
  sstat: mlt$search_status, { local search_ant status }
  rec_index: mlt$receive_index, { index of message being received }
      ost: ost$status,
  c: cell,
  aml: mlt$message_length; { actual message length }
{
    #INLINE ('keypoint', osk$entry, 0, mlk$receive_message);

    IF message_area <> NIL THEN
      {Force page fault BEFORE mli_init
      c := message_area^;
    IFEND;

    mli_init (stat);
    status.normal := FALSE;
    IF stat <> mlc$ok THEN
      status.condition := stat;
      #INLINE ('keypoint', osk$exit, 0,
            mlk$receive_message);
      RETURN;
    IFEND;
    status.condition := mlc$ok;

  /locked/
    BEGIN
{
{ process receiver name
{
      validate_name (application_name, stat);
      IF stat <> mlc$ok THEN
        status.condition := mlc$receiver_name_syntax_error;
        EXIT /locked/;
      IFEND;
      search_ant (application_name, system_name, ant_entry, sstat);
      CASE sstat OF
      = not_found =
        status.condition := mlc$receiver_not_signed_on;
        EXIT /locked/;
      = no_match =
        status.condition := mlc$system_name_no_match;
        EXIT /locked/;
      = found =
        cae := ^mlv$shared_segment.ant [ant_entry];
      /receive/
  BEGIN
    rec_index := receive_index;
{
{ check for valid receive index
{
    IF rec_index > cae^.max_messages THEN
      status.condition := mlc$receive_list_index_invalid;
            EXIT /receive/;
    IFEND;
{
{ if the receive index is zero then return any (the oldest) valid message
{
    IF rec_index = 0 THEN

          /find_any_entry/
      BEGIN
        FOR rec_index := 1 TO cae^.highest_rl_entry DO
                IF cae^.receive_list^ [rec_index].sender_name <>
                  mlc$empty_entry THEN
                  EXIT /find_any_entry/;
                IFEND;
              FOREND;
{
{ no valid entry was found
{
        status.condition := mlc$receive_list_index_invalid;
              EXIT /receive/;
            END /find_any_entry/;
    ELSE
{
{ a specific receive index was used - check that it points to a valid
{ message
{
            IF cae^.receive_list^ [rec_index].sender_name = mlc$empty_entry
              THEN
              status.condition := mlc$receive_list_index_invalid;
              EXIT /receive/;
      IFEND;
    IFEND;
{
{ return message info to caller
{
          message_length := cae^.receive_list^ [rec_index].message_length;
          arbitrary_info := cae^.receive_list^ [rec_index].arbitrary_info;
          sender_name := cae^.receive_list^ [rec_index].sender_name;
{
{ use smaller of message and user buffer lengths
{
    aml := message_length;
    IF aml > message_area_length THEN
      aml := message_area_length;
    IFEND;
          receive_message (signal, message_area, aml, application_name, cae^.
            receive_list^ [rec_index], stat);
          cae^.active_rl_count := cae^.active_rl_count - 1;
          IF cae^.active_rl_count = 0 THEN
            cae^.highest_rl_entry := 0;
          IFEND;

    IF stat <> mlc$ok THEN
      status.condition := stat;
    ELSE
      IF message_length > message_area_length THEN
        status.condition := mlc$message_truncated;
      IFEND;
    IFEND;
    message_length := aml;
        END /receive/;
        cae^.last_operation.req := mlc$receive_message_req;
        cae^.last_operation.stat_condition := status.condition;
      CASEND;
    END /locked/;
    IF status.condition = mlc$ok THEN
      status.normal := TRUE;
    IFEND;
    osp$clear_mainframe_sig_lock (mlv$lock);
    #INLINE ('keypoint', osk$exit, 0,
          mlk$receive_message);

PROCEND mlp$receive_message_os;
?? OLDTITLE ??
?? NEWTITLE := ' mlp$register_signal_handler ' ??
?? EJECT ??
*copyc MLH$REGISTER_SIGNAL_HANDLER

  PROCEDURE [XDCL, #GATE { TS_gate } ] mlp$register_signal_handler_os
    (application_name: mlt$application_name;
    handler: mlt$handler;
    VAR status: ost$status);

    VAR
      sstat: mlt$search_status, { search_ant status }
      stat: mlt$status, {local status}
      ant_entry: mlt$ant_index,
      i: integer, { loop vrbl }
      ost: ost$status,
      cae: ^mlt$ant_entry;

    #INLINE ('keypoint', osk$entry, 0, mlk$register_signal_handler);
    mli_init (stat);
    status.normal := FALSE;
    IF stat <> mlc$ok THEN
      status.condition := stat;
      #INLINE ('keypoint', osk$exit, 0,
            mlk$register_signal_handler);
      RETURN;
    IFEND;
    status.condition := mlc$ok;

  /locked/
    BEGIN
      validate_name (application_name, stat);
      IF stat <> mlc$ok THEN
        status.condition := mlc$receiver_name_syntax_error;
        EXIT /locked/;
      IFEND;
      search_ant (application_name, system_name, ant_entry, sstat);
      IF ant_entry <> 0 THEN
        cae := ^mlv$shared_segment.ant [ant_entry];
      ELSE
        cae := NIL;
      IFEND;
      CASE sstat OF
      = not_found =
        status.condition := mlc$receiver_not_signed_on;
        EXIT /locked/;
      = no_match =
        status.condition := mlc$system_name_no_match;
        EXIT /locked/;
      = found =
        status.condition := mlc$ok;
      CASEND;
      cae^.handler := handler;
    END /locked/;
    IF status.condition = mlc$ok THEN
      status.normal := TRUE;
IF cae^.job_recovery_index <> 0 THEN
mlv$job_recovery_info^[cae^.job_recovery_index].h := handler;
IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (mlv$lock);
    #INLINE ('keypoint', osk$exit, 0,
          mlk$register_signal_handler);
  PROCEND mlp$register_signal_handler_os;
?? OLDTITLE ??
?? NEWTITLE := ' mlp$get_handler_info' ??
?? EJECT ??
{   The purpose of this request is to obtain signal handler info from mli
{ for a given application.  The request is used only by the memory link
{ signal handler.
{
{        MLP$GET_HANDLER_INFO (RECEIVER, HANDLER, STATUS)
{
{ RECEIVER: (input) This parameter specifies the name of the application
{        for whom a handler is to be located.
{
{ HANDLER: (output) This parameter specifies the handler to be invoked by
{        the signal handler.
{
{ STATUS: (output) This parameter specifies the request status.
{
?? EJECT ??

  PROCEDURE [XDCL, #GATE {TS_gate} ] mlp$get_handler_info_os (application_name:
    mlt$application_name;
    VAR handler: mlt$handler;
    VAR status: ost$status);

    VAR
      stat: mlt$status,
      sstat: mlt$search_status,
      ant_entry: mlt$ant_index,
      ost: ost$status,
      cae: ^mlt$ant_entry;

    #INLINE ('keypoint', osk$entry, 0, mlk$get_handler_info);
    mli_init (stat);
    status.normal := FALSE;
    IF stat <> mlc$ok THEN
      status.condition := stat;
      #INLINE ('keypoint', osk$exit, 0,
            mlk$get_handler_info);
      RETURN;
    IFEND;
    status.condition := mlc$ok;

  /locked/
    BEGIN
      validate_name (application_name, stat);
      IF stat <> mlc$ok THEN
        status.condition := mlc$receiver_name_syntax_error;
        EXIT /locked/;
      IFEND;
      search_ant (application_name, system_name, ant_entry, sstat);
      IF ant_entry <> 0 THEN
        cae := ^mlv$shared_segment.ant [ant_entry];
      ELSE
        cae := NIL;
      IFEND;
      CASE sstat OF
      = not_found =
        status.condition := mlc$receiver_not_signed_on;
        EXIT /locked/;
      = no_match =
        status.condition := mlc$system_name_no_match;
        EXIT /locked/;
      = found =
      CASEND;
      handler := cae^.handler;
    END /locked/;
    IF status.condition = mlc$ok THEN
      status.normal := TRUE;
    IFEND;
    osp$clear_mainframe_sig_lock (mlv$lock);
    #INLINE ('keypoint', osk$exit, 0,
          mlk$get_handler_info);
  PROCEND mlp$get_handler_info_os;
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE mlp$fetch_link_partner_info' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] mlp$fetch_link_partner_info_os (application_name:
    mlt$application_name;
        partner_name: mlt$application_name;
    VAR last_op: mlt$operation;
    VAR status: ost$status);


    VAR
      ant_entry: mlt$ant_index, {index to the ANT of the receiver}
      caep: ^mlt$ant_entry, {pointer to the partner ANT entry}
      cae: ^mlt$ant_entry, {pointer to requester ANT entry}
      sstat: mlt$search_status, {local search ant status}
      sn: mlt$system_name, {dummy system name}
      ost: ost$status,
      stat: mlt$status;


    #INLINE ('keypoint', osk$entry, 0, mlk$fetch_link_partner_info);
    mli_init (stat);
    status.normal := FALSE;
    IF stat <> mlc$ok THEN
      status.condition := stat;
      #INLINE ('keypoint', osk$exit, 0,
            mlk$fetch_link_partner_info);
      RETURN;
    IFEND;
    status.condition := mlc$ok;

  /locked/
    BEGIN

{validate requester name;
{
      validate_name (application_name, stat);

      IF stat <> mlc$ok THEN
        status.condition := mlc$receiver_name_syntax_error;
        EXIT /locked/;
      IFEND;
      search_ant (application_name, system_name, ant_entry, sstat);
      CASE sstat OF
      = not_found =
        status.condition := mlc$receiver_not_signed_on;
        EXIT /locked/;
      = no_match =
        status.condition := mlc$system_name_no_match;
        EXIT /locked/;
      = found =
        cae := ^mlv$shared_segment.ant [ant_entry];
{
{ find the partner job's ANT entry and validate name;
{

      /find_partner/
        BEGIN
          validate_name (partner_name, stat);
          IF stat <> mlc$ok THEN
            status.condition := mlc$sender_name_syntax_error;
            EXIT /find_partner/;
          IFEND;
          sn.c170_c180_flag := mlc$none;
          search_ant (partner_name, sn, ant_entry, sstat);
          CASE sstat OF
          = not_found =
            status.condition := mlc$receiver_not_signed_on;
            EXIT /find_partner/;
          = no_match =
{
{
{ This condition should not occure.
{
{
            mli_error (case_err);
            status.condition := mlc$mli_internal_error;
            EXIT /locked/;
          = found =
            caep := ^mlv$shared_segment.ant [ant_entry];
{
{ check for c170 to c170 request
{
            IF (caep^.system_name.c170_c180_flag = c170) AND (system_name.
                  c170_c180_flag = c170) THEN
              status.condition := mlc$c170_c170_illegal;
              EXIT /find_partner/;
            IFEND;
            last_op.req := caep^.last_operation.req;
            last_op.stat_condition := caep^.last_operation.stat_condition;
          CASEND;
        END /find_partner/;
        cae^.last_operation.req := mlc$fetch_link_partner_info_req;
        cae^.last_operation.stat_condition := status.condition;
      CASEND;
    END /locked/;
    IF status.condition = mlc$ok THEN
      status.normal := TRUE;
    IFEND;
    osp$clear_mainframe_sig_lock (mlv$lock);
    #INLINE ('keypoint', osk$exit, 0,
          mlk$fetch_link_partner_info);

  PROCEND mlp$fetch_link_partner_info_os;
?? OLDTITLE ??
?? EJECT ??
 PROCEDURE mlp$update_unique_an (an: mlt$application_name;
        unique: integer;
        sn: mlt$system_name;
    VAR status: ost$status);

    VAR
      stat: mlt$status,
      sstat: mlt$search_status,
      ae: mlt$ant_index,
      ost: ost$status;

    status.normal := TRUE;
    mli_init (stat);
    IF NOT status.normal THEN
      status.normal := FALSE;
      status.condition := stat;
      RETURN;
    IFEND;

    search_ant (an, sn, ae, sstat);
    CASE sstat OF
    = found =
      mlv$shared_segment.ant [ae].unique := unique;
IF mlv$shared_segment.ant [ae].job_recovery_index <> 0 THEN
  mlv$job_recovery_info^ [mlv$shared_segment.ant [ae].job_recovery_index].u := unique;
IFEND;
    ELSE
      status.normal := FALSE;
      status.condition := mlc$receiver_not_signed_on;
    CASEND;

    osp$clear_mainframe_sig_lock (mlv$lock);
  PROCEND mlp$update_unique_an;
?? EJECT ??
  VAR
    mlv$job_signon_count: [XDCL, #GATE, oss$job_fixed] integer :=0,
    mlv$job_recovery_info: [XDCL, #GATE, oss$job_fixed] ^mlt$job_recovery_info
      := NIL;

  TYPE
    mlt$job_recovery_info = array [1 .. mlc$max_signons_per_job] of record
      status: (mlc$invalid, mlc$valid),
      an: mlt$application_name,
      mm: mlt$max_messages,
      sn: mlt$system_name,
      u: integer,
      h: mlt$handler,
      m: boolean,
    recend;

  PROCEDURE [XDCL, #GATE] mlp$recover_job_environment (VAR status: ost$status);

    VAR
      i: integer,
      jri_copy: mlt$job_recovery_info,
      unique: mlt$application_name,
      mm: mlt$max_messages,
      gtid: ost$global_task_id;

    status.normal := TRUE;
    IF mlv$job_recovery_info = NIL THEN
      RETURN;
    IFEND;
    IF osv$170_os_type = osc$ot7_none THEN
      osp$set_status_abnormal ('OS', ose$mem_link_not_available, '', status);
      RETURN;
    IFEND;
    pmp$get_executing_task_gtid (gtid);
    jri_copy := mlv$job_recovery_info^;

    FOR i := 1 TO mlc$max_signons_per_job DO
      IF jri_copy [i].status = mlc$valid THEN
        IF jri_copy [i].sn.name_180 = gtid THEN
          IF jri_copy [i].m THEN
            mm := 0;
          ELSE
            mm := jri_copy [i].mm;
          IFEND;
          mlp$sign_on_os (jri_copy [i].an, mm, unique, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
IF jri_copy [i].u <> -1 THEN
  mlp$update_unique_an (jri_copy [i].an,
    jri_copy [i].u, jri_copy [i].sn, status);
  IF NOT status.normal THEN
    RETURN;
  IFEND;
IFEND;
          IF jri_copy [i].h <> NIL THEN
            mlp$register_signal_handler_os (unique, jri_copy [i].h,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
          mlv$job_recovery_info^ [i].status := mlc$invalid;
IFEND; IFEND;
        FOREND;
      PROCEND mlp$recover_job_environment;
MODEND mlm$memory_link_interface
*DECK DECK=MLM$MEMORY_LINK_MONITOR_MODE EXPAND=TRUE

MODULE mlm$memory_link_monitor_mode;
*copyc OSD$DEFAULT_PRAGMATS
{
{ the purpose of this module is to define memory link
{ structures in the mainframe wired segment.
{
?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc MLT$ANT_ENTRY
*copyc TMT$RB_READY_TASK
?? POP ??
*copyc MLT$C170_RQST_BLK

  VAR
    mlv$c170_rqst_blk: [XDCL, #GATE] mlt$c170_rqst_blk := [[REP mlimi of [idle,
      0, 0, 0, 0, 0, [REP 14 of 0]]], NIL, NIL, mlc$max_message_length + 1,
      reject_all_calls],
    mlv$enabled: [XDCL, #GATE] boolean := FALSE,
    mlv$enable_hot_key: [XDCL, #GATE] boolean := FALSE,
    mlv$debug: [XDCL, #GATE] boolean := FALSE,
    mlv$170_count: [XDCL, #GATE] integer := 0,
    mlv$170_time: [XDCL, #GATE] integer := 0,
    mlv$rb_ready_task: [XDCL, #GATE] tmt$rb_ready_task := [0, [TRUE, 0], [0, 0]];

MODEND mlm$memory_link_monitor_mode
*DECK DECK=MLM$MLMACU EXPAND=TRUE
          IDENT  MLMACU
          ENTRY  MLPACU
          TITLE  MLMACU - MLI SUBSYSTEM ABORT CLEANUP.
*
* ISSUE MLI FUNCTION MLFKA TO KILL ALL 170 SIGNONS IN THE NOS/VE MLI.
*
MLPACU    BSS    0
          SB1    1
          MESSAGE (=C*$MLI SUBSYSTEM ABORTED*),0,R
          RJ     =XMLPKILA
          ENDRUN
          END    MLPACU
*DECK DECK=MLM$MLMASM EXPAND=TRUE
          IDENT  MLMASM
          TITLE  MLM$MLMASM - INTERFACE A170 MLI SUBSYSTEM TO COMPASS.
          ENTRY  MAKSCP,MAKSCPB
          ENTRY  ML$WAIT
          ENTRY  SFCALL
          ENTRY  SNAP
          EXT    PXSAVE
          EXT    ZSMRRET
          LIST   F,G
          SYSCOM
 LEAVE    EQU    ZSMRRET
          IF     -DEF,RA.ORG,2
 OPL      XTEXT  COMSSSD
          SKIP   1
 OPL      XTEXT  SSYS
*copy COMSMLI
*copyc dsa$cybil_if_macros
*
* PROCEDURE [XREF] MAKE_ME_A_SYSTEM_CP ALIAS 'MAKSCP';
*
MAKSCP    BSS    0
          RJ     PXSAVE
MAKSCP1   BSS    0
          SA1    BECSCB
          BX6    X1
          SA6    50B
          CALLSS ,BECSCA,R
          EQ     LEAVE

MAKSCPB   BSS    0           MAKE ME A BUSY SYSTEM CONTROLPOINT
          IF     -DEF,RA.ORG,1
          SHORTEX
 NBESYS   IF     DEF,RA.ORG
          RJ     PXSAVE
          SA1    WORD51
          BX6    X1
          SA6    RA.SSC
          EQ     MAKSCP1
 WORD51   VFD    1/1,24/0,17/1,18/53B
 NVSI     EQU    SS.NVE
 NBESYS   ENDIF

 BECSCA   CON    0
 BECSCB   CON    3LNVE+NVSI
*
*  PROCEDURE [XREF] ML$WAIT (MILISECOND: INTEGER;
*  ML$WAIT - GOES INTO RECALL FOR A GIVEN LENGTH OF TIME
*
ML$WAIT  BSS    0
         RJ     PXSAVE
          IF     -DEF,RA.ORG,2
         WAIT   X1
          SKIP   2
          LX1    2
          SYSTEM RCL,,X1
         EQ     LEAVE
*
* PROCEDURE [XREF] SFCALL (P: ^CELL);
* SFCALL - EXECUTE THE SFCALL MACRO.
*
SFCALL    BSS    0
          IF     DEF,RA.ORG,2
          SA2    X1          GET FUNCTION WORD IN X2
          MX3    54          FUNCTION MASK
          RJ     PXSAVE
          IF     DEF,RA.ORG,3
          BX2    -X3*X2      FUNCTION CODE PROPER
          LX2    54
          MI     X2,LEAVE    -NOOP- ON SF.CPID
          BX0    X1
          SFCALL X1,R
NBESYS    IF     DEF,RA.ORG
          SA1    X0
          LX2    60-54
          SX6    X2-SF.STAT
          NZ     X6,LEAVE
          MX6    1
          LX6    47D         SET BIT 46 (PRIVILEGED USER)
          BX6    X6+X1
          SA6    A1
NBESYS    ENDIF
          EQ     LEAVE
*
* PROCEDURE [XREF] SNAP (P: ^CELL; L: LENGTH);
* SNAP - DUMP MEMORY TO A LOCAL FILE
*
SNAP      BSS    0
          RJ     PXSAVE
          SKIP               BRANCH AROUND SWITCH 3 CODE
          BX0    X1
          BX5    X2
          BX6    X1
          WRITEO FET
          WRITEW FET,X0,X5
          WRITER FET,R
          ENDIF
          EQ     LEAVE
FET       BSS    0
          END
*DECK DECK=MLM$MLMSMI EXPAND=TRUE
          IDENT  MLMSMI
          TITLE  MLM$MLMSMI - CYBIL INTERFACE TO MLI (MLI SUBSYS ONLY)
          LIST   F
          SYSCOM B1
          ENTRY  MLPSION
          ENTRY  MLPSIOF
          ENTRY  MLPKILL
          ENTRY  MLPKILA
          ENTRY  MLPFERL
          ENTRY  MLPREME
          ENTRY  MLPSEME
          ENTRY  MLPADSE
          ENTRY  MLPDESE
          ENTRY  MLPCOSE
          ENTRY  INITMLI
          EXT    PXSAVE,ZSMRRET,PARSV
LEAVE     EQU    ZSMRRET
          SKIP   RA.MTR
          ERR    SYSCOM NOT CALLED
          IF     -DEF,RA.ORG,1
OPL XTEXT COMCMAC
          LIST   X
*copy COMSMLI
*copy COMSCVS
*copy COMMMLI
*copy COMMCVS
*copyc dsa$cybil_if_macros
          TITLE  MLI= - INTERFACE TO NOS/VE
MLI=      SUBR               ENTRY/EXIT
          IF     -DEF,MLI=X,1
MLI=X     EQU    MLI=
          SA1    MLIPAR+MLPFN CHECK FOR VALID FUNCTION
          NG     X1,MLI4     IF ILLEGAL FUNCTION
          SX2    X1-MLFKA-1
          PL     X2,MLI4     IF ILLEGAL FUNCTION
          MX6    0
          SA6    MLIB        RESET RETRY COUNT

* IF THE FUNCTION IS SIGNON OR SIGNOFF THEN MOVE THE JSN INTO THE
* PARAMETER BLOCK. (SPECIAL FOR SUBSYSTEM ONLY)

          IFLT   MLFON+MLFOF,2,4
          AX1    1           GETS RID OF A 1
          NZ     X1,MLI0     IF NOT SIGNON AND NOT SIGNOFF
          EQ     MLI7        JSN PROCESSING
          SKIP   6           LEAVE CODE IN JUST IN CASE....
          R=     X2,MLFON
          BX3    X1-X2
          ZR     X3,MLI7     IF SIGNON
          R=     X2,MLFOF
          BX3    X1-X2
          ZR     X3,MLI7     IF SIGNOFF
MLI0      BSS    0
          SA1    MLIA
          ZR     X1,MLI1     IF NOT TO ISSUE DAYFILE TRACE MESSAGE
          RJ     ITB
          SPACE  1
* ENTRY:
*  X1 = NTH REQUEST CODE (CVSMLI).
*  X2 = ADDRESS OF MLI REQUEST BLOCK.
*  X3 = MLI SUB-FUNCTION CODE (MLFSIN, MLFSPL).
*
* EXIT:
*  X0 = 0 IF REQUEST ACCEPTED AND COMPLETED.
*       1 IF QUEUE FULL.
*       2 IF REQUEST ACCEPTED BUT NOT COMPLETE.
*  X1 = 0 IF NOS/VE NOT UP, OTHERWISE UNCHANGED.
*  X4 = NTH SAVE REGISTER.  MUST NOTE BE DESTROYED.
          SPACE  1
MLI1      SX4    0           CLEAR MLI INDEX
MLI11     SX2    MLIPAR
          CALLVS X2,X4,CVSMLIU,0
          ZR     X0,MLI12    IF REQUEST COMPLETE
          LX0    59-30
          NG     X0,MLI5     IF NOS/VE DOWN
          AX0    30
MLI13     RECALL
          ZR     X0,MLI1     IF QUEUE FULL
          EQ     MLI11       IF REQUEST NOT COMPLETE
MLI12     BSS    0
          SPACE  1
* END OF SPECIAL EIE CODE
          SPACE  1
          SA1    MLIPAR+MLPSV GET STATUS RETURNED
          SX2    X1-MLSBI    CHECK FOR BUSY INTERLOCK STATUS
          NZ     X2,MLI3     IF NOT BUSY INTERLOCK

* PROCESS BUSY STATUS.  RETRY SAME OPERATION A MAXIMUM OF MLEMXR TIMES.

          SA1    MLIRTC
          SX2    B1
          SX0    B0
          IX6    X1+X2       INCREASE MLIRTC BY ONE
          SA6    A1
          SA1    MLIB
          SX6    X1+B1
          SA6    A1          UPDATE RETRY COUNT
          SX2    X6-MLEMXR
          MI     X2,MLI13    GO PAUSE AND RETRY

* RETRY LIMIT EXCEEDED.

MLI2      SA1    MLIA
          ZR     X1,MLI=X    IF NOT TO ISSUE DAYFILE TRACE MESSAGE.
          MESSAGE (=C* MLI RETRY LIMIT EXCEEDED. *),MLETDF,R

* RETURN TO CALLER.

MLI3      SA1    MLIA
          ZR     X1,MLI=X    IF NOT TO ISSUE DAYFILE TRACE MESSAGE
          RJ     ITA
          EQ     MLI=X

* PROCESS ILLEGAL MLI FUNCTION.

MLI4      BSS    0
          SX6    MLSIF
          SA6    MLIPAR+MLPSV  RETURN ILLEGAL FUNCTION STATUS
          SA1    MLIA
          ZR     X1,MLI=X    IF NOT TO ISSUE DAYFILE TRACE MESSAGE
          MESSAGE (=C* MLI ILLEGAL FUNCTION.*),MLETDF,R
          EQ     MLI=X
          SPACE  1
* EI RETURNED WITH X1=0 WHICH MEANS THAT NOS/VE IS NOT RUNNING.
          SPACE  1
MLI5      BSS    0
          SX6    MLSND
          SA6    MLIPAR+MLPSV  RETURN NOS/VE DOWN STATUS
          SA1    MLIA
          ZR     X1,MLI=X    IF NOT TO ISSUE DAYFILE TRACE MESSAGE
          MESSAGE (=C* NOS/VE DOWN.*),3,R
          EQ     MLI=X

* ADD JSN TO PARAMETER BLOCK FOR SIGNON/SIGNOFF ONLY.

MLI7      BSS    0
          SA1    =XMLV$JSN
          BX6    X1
          SA6    MLIPAR+MLPJS
          EQ     MLI0

MLIA      VFD    60/MLEITM   DAYFILE TRACE MESSAGE FLAG
MLIB      BSS    1           RETRY COUNT
MLIPAR    BSS    MLEPBS      MLI PARAMETER BLOCK
MLIRTC    DATA   0           BUSY RETRY COUNT CUMULATIVE TOTAL
ITB    SPACE  4
***       ITB - ISSUE DAYFILE TRACE MESSAGE BEFORE MLI REQUEST.
*
*         ENTRY  VALID FUNCTION SET IN THE MLIPAR BLOCK.
*
*         EXIT   DAYFILE MESSAGE OF THE FORMAT-
*                   MLI REQ XXXXX NNNNNN
*                ISSUED.  XXXXX IS A FUNCTION NAME - SIGNON, SIGNOFF,
*                ADDSPL, DELSPL, SEND, RECEIVE, FETCHRL, CONFIRM.
*                NNNNNN IS THE APPLICATION NAME MAKING THE REQUEST
*                DISPLAYED AS 20 OCTAL DIGITS.IF STO OPTION 2 IS ACTIVE,
*                THE MLI PARAMETER BLOCK IS WRITTEN TO FILE MLIDUMP.
*
*         USES   X - 0, 1, 2, 6.
*                B - NONE.
*                A - 1, 2, 6.
*
*         MACROS MESSAGE, SUBR, WRITEW.
*
*         CALLS  CTO.
          SPACE  2
ITB       SUBR               ENTRY/EXIT
          SA1    MLIPAR+MLPFN GET FUNCTION NUMBER
          SA2    X1+ITBA     GET FUNCTION NAME
          BX6    X2
          SA1    MLIPAR+MLPAN GET APPLICATION NAME
          LX1    30
          SA6    ITBC
          RJ     CTO         CONVERT LEFT HALF
          SA6    ITBC+1
          RJ     CTO         CONVERT RIGHT HALF
          SA6    ITBC+2
          MESSAGE ITBB,MLETDF,R
DUMP      IF     DEF,DUMPMLI

* OUTPUT PARAMETER BLOCK IF REQUESTED.

          SA1    MLIA        GET TRACE OPTION
          SX0    2
          BX2    X0-X1
          NZ     X2,ITBX     IF NOT TO DUMP MLIPAR BLOCK
DUMP      ENDIF
          EQ     ITBX        RETURN

ITBA      BSS    0           FUNCTION NAME TABLE
          DATA   10HSIGNON
          DATA   10HSIGNOFF
          DATA   10HADDSPL
          DATA   10HDELSPL
          DATA   10HSEND
          DATA   10HRECEIVE
          DATA   10HFETCHRL
          DATA   10HCONFIRM
          DATA   10HKILL
          DATA   10HKILL ALL
ITBB      DATA   10H MLI REQ
ITBC      BSS    3
          DATA   0
DUMP      IF     DEF,DUMPMLI
DUMP      ENDIF
ITA    SPACE  4
***       ITA - ISSUE DAYFILE TRACE MESSAGE AFTER MLI REQUEST.
*
*         ENTRY  STATUS SET IN MLIPAR BLOCK.
*
*         EXIT   DAYFILE MESSAGE OF THE FORMAT-
*                   MLI STS DDDDDD
*                ISSUED.  DDDDDD IS A 20 DIGIT OCTAL NUMBER REPRESENTING
*                THE STATUS RETURNED BY MLI.
*
*         USES   X - 1, 6.
*                B - NONE.
*                A - 1, 6.
*
*         MACROS MESSAGE, SUBR.
*
*         CALLS  CTO.
          SPACE  2
ITA       SUBR               ENTRY/EXIT
          SA1    MLIPAR+MLPSV GET STATUS
          SA1    X1
          LX1    30          GET UPPER 30 BITS FOR CONVERSION
          RJ     CTO
          SA6    ITAB
          RJ     CTO
          SA6    ITAB+1
          MESSAGE ITAA,MLETDF,R
          EQ     ITAX        RETURN

ITAA      DATA   10H MLI STS
ITAB      BSS    2
          DATA   0
STO    SPACE  4
***       STO - SET TRACE OPTION.
*
*         ENTRY  (X6) = OPTION VALUE.  ZERO MEANS DO NOT ISSUE ANY TRACE
*                       MESSAGES. ONE MEANS ISSUE TRACE MESSAGES TO THE
*                       DAYFILE SPECIFIED BY THE SYMBOL MLETDF.
*                       TWO MEANS ISSUE TRACE MESSAGES (SAME AS ONE)
*                       AND WRITE THE MLIPAR BLOCK TO LOCAL FILE
*                       MLIDUMP. IF THE OLD VALUE IS TWO AND IT IS BEING
*                       CHANGED, A WRITER IS ISSUED TO THE MLIDUMP FILE.
*                       THE DUMP CAPABILITY IS ONLY ASSEMBLED INTO MLI=
*                       IF THE SYMBOL DUMPMLI IS DEFINED.
*
*         USES   X - 0, 1.
*                B - NONE.
*                A - 1, 6.
*
*         MACROS SUBR, MESSAGE, WRITER.
          SPACE  2
STO       SUBR               ENTRY/EXIT
          SA1    MLIA        GET CURRENT VALUE
          R=     X0,2
          BX0    X0-X1
          SA6    A1          STORE NEW OPTION VALUE
DUMP      IF     DEF,DUMPMLI
          NZ     X0,STO1     IF OLD VALUE WAS NOT TWO
          SX0    2
          BX0    X0-X6
          ZR     X0,STO1     IF NEW VALUE IS TWO

* FLUSH MLIDUMP BUFFER

          SA1    MLIA        RESTORE OPTION VALUE
          BX6    X1
STO1      BSS    0
DUMP      ENDIF
          ZR     X6,STOX     IF TURNING OFF (NO MESSAGE)
          MESSAGE (=C* MLI TRACE ON. *),MLETDF,R
          EQ     STOX

          SKIP   2
STO2      MESSAGE (=C* MLI TRACE OFF. *),MLETDF,R
          EQ     STOX
CTO       SPACE  4
***       CTO - CONVERT THE RIGHTMOST 30 BITS FROM X1 TO 10 DISPLAY CODE
*               OCTAL DIGITS IN X6.
*
*         ENTRY  (X1) = VALUE TO CONVERT.
*
*         EXIT   (X6) = 10 DISPLAY CODE DIGITS.  NO ZERO SUPPRESSION.
*
*         USES   X - 1, 2, 3, 6, 7.
*                B - 2.
*                A - NONE.
*
*         MACROS SUBR.
          SPACE  2
CTO       SUBR               ENTRY/EXIT
          MX6    0           INITIALIZE ASSEMBLY
          MX2    -3          DIGIT MASK
          SB2    10          DIGIT COUNTER
CTO1      BX7    -X2*X1      GET DIGIT
          SB2    B2-1        DECREMENT DIGIT COUNT
          SX3    X7+1R0      CONVERT DIGIT TO CHARACTER
          LX6    54          POSITION ASSEMBLY
          AX1    3           SHIFT OFF DIGIT
          BX6    X6+X3       ADD CHARACTER TO ASSEMBLY
          NZ     B2,CTO1     IF MORE DIGITS
          LX6    54
          EQ     CTOX        RETURN
          TITLE  THE MAIN STUFF
*
* D. A. HENSELER  10/25/79.
*
*
* PROCEDURE [XREF] MLPKILL (JSN: INTEGER; VAR STATUS: OST$STATUS);
* MLPKILL - ISSUE MLI FUNCTION 8 - KILL 170 JOB - TO MLI.
*
MLPKILL   BSS    0
          RJ     PXSAVE
          BX6    X1
          BX7    X2
          SA6    MLIPAR+MLPJS JSN
          SA7    MLIPAR+MLPST STATUS
          SX6    MLFKI
          SA6    MLIPAR+MLPFN FUNCTION
          RJ     MLI=
          TRANSFR MLPSV,MLPST
          EQ     LEAVE
*
INITMLI   BSS    0
          RJ     PXSAVE
          BX6    X1
          RJ     STO
          EQ     LEAVE
*
MLPSION   BSS    0
          RJ     PXSAVE
          SIGNON PARSV,PARSV+1,X3,X4
          EQ     LEAVE
*
MLPSIOF   BSS    0
          RJ     PXSAVE
          SIGNOFF PARSV,X2
          EQ     LEAVE
*
MLPADSE   BSS    0
          RJ     PXSAVE
          ADDSPL PARSV,PARSV+1,X3
          EQ     LEAVE
*
MLPDESE   BSS    0
          RJ     PXSAVE
          DELSPL PARSV,PARSV+1,X3
          EQ     LEAVE
*
MLPSEME   BSS    0
          RJ     PXSAVE
          BX3    X1          BECAUSE X1 GETS WRECKED BY MACRO
          SEND   B5,B5+1,X3,X2,PARSV+2,PARSV+3,X5
          EQ     LEAVE
*
MLPREME   BSS    0
          RJ     PXSAVE
          SA3    B5+B1
          SA2    A3+B1       SIGNAL
          SB6    X2
          SA2    A2+B1
          SB4    X2
          BX2    X1          BECAUSE X1 GETS WRECKED BY MACRO
          RECEIVE B5,X3,B6,B4,X2,PARSV+1,PARSV+2,X4,X5
          EQ     LEAVE
*
MLPFERL   BSS    0
          RJ     PXSAVE
          FETCHRL PARSV,PARSV+1,X3,X4,X5
          EQ     LEAVE
*
MLPCOSE   BSS    0
          RJ     PXSAVE
          CONFIRM PARSV,PARSV+1,X3
          EQ     LEAVE
*
MLPKILA   BSS    0
*  RJ TO THIS ROUTINE, NOT EQ (I.E. CYBIL)
          DATA   0
          SX6    MLFKA
          SA6    MLIPAR+MLPFN
          RJ     MLI=
          EQ     MLPKILA
          END
*DECK DECK=MLM$R3_INTERFACES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE mlm$r3_interfaces;
?? PUSH (LISTEXT := ON) ??
*copyc MLP$SIGN_ON_OS
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc OST$STATUS
?? POP ??

  PROCEDURE [XDCL, #GATE] mlp$sign_on ALIAS 'mlpsion' (application_name:
    mlt$application_name;
    max_messages: mlt$max_messages;
    VAR unique_application_name: mlt$application_name;
    VAR status: ost$status);

    mlp$sign_on_os (application_name, max_messages, unique_application_name,
      status);

  PROCEND mlp$sign_on;

  PROCEDURE [XDCL, #GATE] mlp$sign_off ALIAS 'mlpsiof' (application_name:
    mlt$application_name;
    VAR status: ost$status);

    mlp$sign_off_os (application_name, status);

  PROCEND mlp$sign_off;

  PROCEDURE [XDCL, #GATE] mlp$receive_message ALIAS 'mlpreme'
    (application_name: mlt$application_name;
    VAR arbitrary_info: mlt$arbitrary_info;
    signal: mlt$signal;
    message_area: mlt$message_ptr;
    VAR message_length: mlt$message_length;
    message_area_length: mlt$message_length;
    receive_index: mlt$receive_index;
    VAR sender_name: mlt$application_name;
    VAR status: ost$status);

    mlp$receive_message_os (application_name, arbitrary_info, signal,
      message_area, message_length, message_area_length, receive_index,
      sender_name, status);

  PROCEND mlp$receive_message;

  PROCEDURE [XDCL, #GATE] mlp$send_message ALIAS 'mlpseme' (application_name:
    mlt$application_name;
    arbitrary_info: mlt$arbitrary_info;
    signal: mlt$signal;
    message_area: mlt$message_ptr;
    message_length: mlt$message_length;
    destination_name: mlt$application_name;
    VAR status: ost$status);

    mlp$send_message_os (application_name, arbitrary_info, signal,
      message_area, message_length, destination_name, status);

  PROCEND mlp$send_message;

  PROCEDURE [XDCL, #GATE] mlp$add_sender ALIAS 'mlpadse' (application_name:
    mlt$application_name;
    sender_name: mlt$application_name;
    VAR status: ost$status);

    mlp$add_sender_os (application_name, sender_name, status);

  PROCEND mlp$add_sender;

  PROCEDURE [XDCL, #GATE] mlp$delete_sender ALIAS 'mlpdese' (application_name:
    mlt$application_name;
    sender_name: mlt$application_name;
    VAR status: ost$status);

    mlp$delete_sender_os (application_name, sender_name, status);

  PROCEND mlp$delete_sender;

  PROCEDURE [XDCL, #GATE] mlp$confirm_send ALIAS 'mlpcose' (application_name:
    mlt$application_name;
    destination_name: mlt$application_name;
    VAR status: ost$status);

    mlp$confirm_send_os (application_name, destination_name, status);

  PROCEND mlp$confirm_send;

  PROCEDURE [XDCL, #GATE] mlp$fetch_receive_list ALIAS 'mlpferl'
    (application_name: mlt$application_name;
    sender_name: mlt$application_name;
    VAR receive_list: mlt$receive_list;
    VAR receive_count: mlt$receive_count;
    VAR status: ost$status);

    mlp$fetch_receive_list_os (application_name, sender_name, receive_list,
      receive_count, status);

  PROCEND mlp$fetch_receive_list;

  PROCEDURE [XDCL, #GATE] mlp$register_signal_handler (application_name:
    mlt$application_name;
    handler: mlt$handler;
    VAR status: ost$status);

    mlp$register_signal_handler_os (application_name, handler, status);

  PROCEND mlp$register_signal_handler;

  PROCEDURE [XDCL, #GATE] mlp$fetch_link_partner_info (application_name:
    mlt$application_name;
        partner_name: mlt$application_name;
    VAR last_op: mlt$operation;
    VAR status: ost$status);

    mlp$fetch_link_partner_info_os (application_name, partner_name, last_op,
          status);

  PROCEND mlp$fetch_link_partner_info;

MODEND mlm$r3_interfaces
*DECK DECK=MLP$ADD_SENDER EXPAND=FALSE

  PROCEDURE [XREF {TS_gate} ] mlp$add_sender ALIAS 'mlpadse' (application_name:
    mlt$application_name;
    sender_name: mlt$application_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=MLP$COMPARE_FLOATING EXPAND=FALSE
*copyc MLT$COMPARE
*copyc MLT$ERROR
*copyc MLT$FLOATING_LENGTH
  ?? SKIP := 2 ??
  ?? PUSH (LIST := ON) ??
  { MLD$CF - Declare mlp$compare_floating }
  ?? POP ??

  PROCEDURE [XREF] mlp$compare_floating (source: ^cell;
        source_length: mlt$floating_length;
        target: ^cell;
        target_length: mlt$floating_length;
    VAR result: mlt$compare;
    VAR status: mlt$error);

  { FUNCTION: Compare the values of two floating point numbers.
  {
  { STATUS MLE$INDEFINITE is returned whenever the source or target is
  {indefinite or whenever both source and target are infinite with the
  {same sign. The result is then MLC$UNORDERED.
*DECK DECK=MLP$CONFIRM_SEND EXPAND=FALSE

  PROCEDURE [XREF {TS_gate} ] mlp$confirm_send ALIAS 'mlpcose'
    (application_name: mlt$application_name;
    destination_name: mlt$application_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=MLP$CONVERT_FLOAT_TO_INTEGE EXPAND=FALSE
*copyc MLT$ERROR
*copyc MLT$FLOATING_LENGTH
*copyc MLT$INTEGER_LENGTH
*copyc MLT$INTEGER_TYPE
  ?? SKIP := 2 ??
  ?? PUSH (LIST := ON) ??
  { MLD$CFI - Declare mlp$convert_float_to_integer }
  ?? POP ??

  PROCEDURE [XREF] mlp$convert_float_to_integer (source: ^cell;
        source_length: mlt$floating_length;
        target: ^cell;
        target_length: mlt$integer_length;
        target_type: mlt$integer_type;
    VAR status: mlt$error);

  { FUNCTION: Convert a floating point number into an integer.
  {
  { STATUS MLE$LOSS_OF_SIGNIFICANCE is returned whenever the floating
  {point number cannot be represented as an integer of the specified
  {length. The integer value returned will contain the rightmost
  {significant bits of the correct result. For infinite or indefinite
  {floating point numbers, the integer value returned is 0.
*DECK DECK=MLP$CONVERT_INTEGER_TO_FLOAT EXPAND=FALSE
*copyc MLT$ERROR
*copyc MLT$FLOATING_LENGTH
*copyc MLT$INTEGER_LENGTH
*copyc MLT$INTEGER_TYPE
  ?? SKIP := 2 ??
  ?? PUSH (LIST := ON) ??
  { MLD$CIF - Declare mlp$convert_integer_to_float }
  ?? POP ??

  PROCEDURE [XREF] mlp$convert_integer_to_float (source: ^cell;
        source_length: mlt$integer_length;
        source_type: mlt$integer_type;
        target: ^cell;
        target_length: mlt$floating_length;
    VAR status: mlt$error);

  { FUNCTION: Convert an integer into a floating point number.
  {
  { STATUS MLE$NO_ERROR is returned.
*DECK DECK=MLP$CREATE_JOB_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] mlp$create_job_entry alias 'mlpcje' (job_unique_id:
    mlt$partner_job_unique_id;
    VAR create_status: mlt$create_status;
    remote_host_job: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc MLT$PARTNER_JOB_UNIQUE_ID
?? POP ??
*DECK DECK=MLP$DELETE_JOB_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] mlp$delete_job_entry alias 'mlpdje' (job_unique_id:
    mlt$partner_job_unique_id;
    VAR delete_status: mlt$delete_status);

?? PUSH (LISTEXT := ON) ??
*copyc MLT$PARTNER_JOB_UNIQUE_ID
?? POP ??
*DECK DECK=MLP$DELETE_SENDER EXPAND=FALSE

  PROCEDURE [XREF {TS_gate} ] mlp$delete_sender ALIAS 'mlpdese'
    (application_name: mlt$application_name;
    sender_name: mlt$application_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=MLP$FETCH_LINK_PARTNER_INFO EXPAND=FALSE

  PROCEDURE [XREF {TS_gate} ] mlp$fetch_link_partner_info ALIAS 'mlpflpi'
    (application_name: mlt$application_name;
    partner_name: mlt$application_name;
    VAR last_op: mlt$operation;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=MLP$FETCH_RECEIVE_LIST EXPAND=FALSE

  PROCEDURE [XREF {TS_gate} ] mlp$fetch_receive_list ALIAS 'mlpferl'
    (application_name: mlt$application_name;
    sender_name: mlt$application_name;
    VAR receive_list: mlt$receive_list;
    VAR receive_count: mlt$receive_count;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=MLP$FIND_SIGNED_ON_JOB EXPAND=FALSE

  PROCEDURE [XREF] mlp$find_signed_on_job ALIAS 'mlpfsoj' (
    partner_job_unique_id: mlt$partner_job_unique_id;
    VAR find_status: mlt$find_status);

?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc MLT$PARTNER_JOB_UNIQUE_ID
?? POP ??
*DECK DECK=MLP$FORCE_JOB_SIGN_OFF EXPAND=FALSE

  PROCEDURE [XREF] mlp$force_job_sign_off ALIAS 'mlpfjso' (
    partner_job_unique_id: mlt$partner_job_unique_id;
    VAR forced_sign_off_status: mlt$forced_sign_off_status);

?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc MLT$PARTNER_JOB_UNIQUE_ID
?? POP ??
*DECK DECK=MLP$FORCE_SEND_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF {TS_gate} ] mlp$force_send_message
    (application_name: mlt$application_name;
    arbitrary_info: mlt$arbitrary_info;
    signal: mlt$signal;
    message_area: mlt$message_ptr;
    message_length: mlt$message_length;
    destination_name: mlt$application_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=MLP$HANDLE_SIGNAL EXPAND=FALSE


  PROCEDURE [XREF] mlp$handle_signal (originator: ost$global_task_id;
    signal: pmt$signal);
?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc PMT$SIGNAL
?? POP ??
*DECK DECK=MLP$INITIALIZE EXPAND=FALSE

  PROCEDURE [XREF] mlp$initialize (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=MLP$INPUT_FLOATING_NUMBER EXPAND=FALSE
*copyc MLT$ERROR
*copyc MLT$FLOATING_LENGTH
*copyc MLT$HANDLE_BLANKS
*copyc MLT$STRING_LENGTH
  ?? SKIP := 2 ??
  ?? PUSH (LIST := ON) ??
  { MLD$IFN - Declare mlp$input_floating_number }
  ?? POP ??

  PROCEDURE [XREF] mlp$input_floating_number (source: ^cell;
        source_length: mlt$string_length;
        target: ^cell;
        target_length: mlt$floating_length;
        handle_blanks: mlt$handle_blanks;
    VAR actual_source_length: mlt$string_length;
    VAR status: mlt$error);

  { FUNCTION: Convert an ASCII representation of a floating point
  {number (with an optional exponent field) into the internal
  {(binary) floating point representation.
  {
  { RESTRICTIONS: The exponent field must begin with "E", "D", "e",
  {or "d". Arithmetic overflow during exponent computation is ignored.
  {
  { The only valid values for the HANDLE_BLANKS parameter are
  {MLC$IGNORE_BLANKS and MLC$STOP_ON_BLANK.
  {
  { STATUS MLE$INVALID_BDP_DATA is returned whenever an illegal
  {character is detected in the source field. A terminating blank or
  {comma is NOT considered illegal.
  { STATUS MLE$OVERFLOW will be returned whenever the floating point
  {number is infinite or indefinite AND status is otherwise no error.
  { STATUS MLE$NO_DIGITS is returned if no digits were found in the
  {source.
*DECK DECK=MLP$INVOKE_MLI_HELPER EXPAND=FALSE
  PROCEDURE [XREF] mlp$invoke_mli_helper;
*DECK DECK=MLP$LOCATE_FREE_JOB_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] mlp$locate_free_job_entry alias 'mlplfje' (
    VAR entry_located: boolean);

?? PUSH (LISTEXT := ON) ??
?? POP ??
*DECK DECK=MLP$MLI_SUBSYSTEM EXPAND=TRUE
MODULE mlp$mli_subsystem;
*copyc OSD$DEFAULT_PRAGMATS


{ The purpose of this module is to control all A170 jobs using the NOS/VE
{ memory link.  Only the MLISS can issue signon and signoff requests.
{ All A170 jobs that are signed on to the memory link have a long term
{ connection with the MLISS so that their termination will be
{ detected and the MLI will be cleaned up properly.  If the MLISS
{ terminates, then all A170 jobs using the MLI will be terminated and
{ the MLI environment will be cleaned up.
{
{ MLISS sense switch usage:
{
{ ONSW2 - enables the MLISS dayfile diagnostics.
{
{ ONSW3 - enables the MLISS snap file stuff.
{


?? PUSH (LISTEXT := ON) ??
*copyc ifd$machine_definition

  ?IF ifv$module_for_c180 = TRUE THEN
*copy OST$STATUS
  ?ELSE
*copy OST$STRING

    TYPE
      ost$status = record
        condition: mlt$status,
      recend,

      ost$status_condition = record
        condition: mlt$status,
      recend;

  ?IFEND
*copyc dsp$check_if_ve_running
*copyc MLP$SIGN_ON
*copyc MLP$SIGN_OFF
*copyc MLT$C170_RQST_BLK
*copyc MLT$ANT_ENTRY
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc MLT$PARTNER_JOB_UNIQUE_ID
*copyc ICP$PARTNER_JOB_EXEC_REAL

PROCEDURE [XREF] rhp$partner_job_exec;
*copyc ZUTPS2D
*copyc ZN7PMSG
?? POP ??

?? OLDTITLE, NEWTITLE := 'TYPE DECLARATIONS', EJECT ??

  TYPE

{ UCP/SCP communication definitions.

    t#ucp_param_word = packed record
      rss: 0 .. 0ffffff(16),
      rin: 0 .. 0fff(16),
      wc: 0 .. 3f(16),
      rcdc: 0 .. 0f(16),
      b13: boolean,
      b12: boolean,
      ec: 0 .. 3f(16),
      rsv: 0 .. 3(16),
      es3: boolean,
      es2: boolean,
      es1: boolean,
      c: boolean,
    recend,

{ Note: This record definition differs slightly from the actual SCP
{definition.

    t#job_id_word = packed record
      jsn: 0 .. 0ffffff(16),
      jsn2: 0 .. 0fff(16), { jsn is left justified }
      zero1: 0 .. 0fff(16),
      fst: 0 .. 0fff(16),
    recend,

    t#ssf_param_block = packed record
      rc: 0 .. 3f(16),
      fp: 0 .. 0fff(16),
      ucpa: 0 .. 3ffff(16),
      scpa: 0 .. 3ffff(16),
      fc: 0 .. 3f(16),
      jid: t#job_id_word,
      u: boolean,
      s: boolean,
      rsv1: 0 .. 3ff(16),
      eucpa: 0 .. 0ffffff(16),
      escpa: 0 .. 0ffffff(16),
    recend,

    t#ssf_stat_response = packed record
      rc: 0 .. 3f(16),
      zero: 0 .. 3f(16),
      priv_program: boolean,
      priv_user: boolean,
      long_term_connect: boolean,
      request_count: 0 .. 7,
      ucpa: 0 .. 3ffff(16),
      scpa: 0 .. 3ffff(16),
      fc: 0 .. 3f(16),
    recend,

    t#ucp_param_block = record
      ctrl: t#ucp_param_word,
      data: array [1 .. c#data_block_length] of integer,
    recend,

    t#sscr_word = packed record
      i: boolean,
      p: boolean,
      zero: 0 .. 0f(16),
      xp: 0 .. 3ffff(16),
      v: boolean,
      lp: 0 .. 1ffff(16),
      ap: 0 .. 3ffff(16),
    recend,

    t#scp_ap0_word = packed record
      resv1: 0 .. 0fff(16),
      resv2: 0 .. 0ffffff(16),
      status: 0 .. 3f(16),
      addr: 0 .. 3ffff(16),
    recend,

    t#scp_param_block = record
      ap0: t#scp_ap0_word,
      ap1: t#job_id_word,
      data: array [1 .. c#data_block_length] of integer,
    recend,

    t#ssiw_word = packed record
      name: 0 .. 3ffffffffff(16),
      qp: 0 .. 3ffff(16),
    recend,

{ Note:  This record defines the response block for an sf.cpid request.

    cpid_response = packed record
      family_name: string (5),
      user_name: string (5),
      filler1: string (4),
      filler2: 0 .. 7ff(16),
      validated: boolean,
    recend,

{ Subsystem type declarations.

    t#jsn_entry = record
      jsn: integer,
      count: integer,
      job_id_word: t#job_id_word,
    recend,

{ Kludge for RH batch origin jobs.
    t#partner_job_entry = record
      job_unique_id: mlt$partner_job_unique_id,
      sign_on_state: mlt$job_sign_on_state,
      remote_host_job: boolean,
    recend;

?? OLDTITLE, NEWTITLE := 'CONSTANT DECLARATIONS', EJECT ??

  CONST

{ SSF function codes.

    c#sf_regr = 2,
    c#sf_endt = 6,
    c#sf_read = 8,
    c#sf_stat = 10,
    c#sf_writ = 12,
    c#sf_exit = 14,
    c#sf_swpo = 20,
    c#sf_swpi = 22,
    c#sf_sltc = 24,
    c#sf_cltc = 26,
    c#sf_list = 28,
    c#sf_xred = 32,
    c#sf_xlst = 34,
    c#sf_xwrt = 36,
    c#sf_cpid = 38,

{ System to SCP status codes.

    c#normal_msg = 0,
    c#ucp_ended = 1,
    c#ucp_aborted = 2,
    c#forcibly_broken = 3,
    c#scp_aborted = 4,

{ Regrets function error codes.

    c#normal_error = 1,
    c#hostile_user_error = 2,

{ Low core constants.

    c#ssiw = 40,
    c#sscr = 41,

{ Miscellaneous constants.

    c#data_block_length = 100,
    c#user_dayfile = 3,
    c#b_dayfile = 2,
    c#swapout_max = 60,

{ Parameter positions in the MLI parameter block.

    c#aname = aname + 2,
    c#sname = sname + 2,
    c#status = pstatus + 2,
    c#funct = funct + 2,
    c#rindex = rindex + 2,
    c#fwa = fwa + 2,
    c#buflen = buflen + 2,
    c#signal = signal + 2,
    c#arbinfo = arbinfo + 2,
    c#msglen = msglen + 2,
    c#mlpsv = mlpsv + 2,
    c#mlpv1 = mlpv1 + 2,
    c#mlpv2 = mlpv2 + 2,
    c#mlpv3 = mlpv3 + 2,
    c#maxmsg = c#rindex,
    c#count = c#rindex,
    c#jsn = c#fwa,

{ MLI request function codes.

    c#signon = signon,
    c#signoff = signoff,
    c#addspl = addspl,
    c#delspl = delspl,
    c#send = send,
    c#receive = receive,
    c#fetchrl = fetchrl,
    c#confirm = confirm,
    c#kill = kill,
    c#kill_all = kill_all,
    c#swapout_ucp = swapout_ucp,

{ SSF error codes.

    e#ucp_address_error = 35,
    e#job_swapped_out = 36;

?? OLDTITLE, NEWTITLE := 'PROCEDURE call_snap', EJECT ??

  PROCEDURE call_snap (p: ^cell;
        l: integer);

    IF snap_debug THEN
      snap (p, l);
    ELSE
      RETURN;
    IFEND;

  PROCEND call_snap;

?? OLDTITLE, NEWTITLE := 'PROCEDURE expunge', EJECT ??

  PROCEDURE expunge;

{ Terminate the SCP.

    IF nosbe THEN
      RETURN; { compass subroutine *endprgr* does sf.exit processing }
    IFEND;

    ssf_req.jid.jsn := 0;
    ssf_req.jid.jsn2 := 0;
    ssf_req.jid.fst := 0;
    ssf_req.fc := c#sf_exit;
    ssf_req.rc := 0;
    ssf_req.fp := 0;
    sfcall (^ssf_req);

{ This code should never execute - the c#sf_exit will abort the job step.


  PROCEND expunge;

?? OLDTITLE, NEWTITLE := 'PROCEDURE hang', EJECT ??

  PROCEDURE hang;

    snap_debug := TRUE;
    mliss_debug := TRUE;
    log (save_dayfile, c#user_dayfile);
    call_snap (^ssf_req, #SIZE (ssf_req));
    call_snap (^request, 15);
    call_snap (^jsn_list, #SIZE (jsn_list));
    call_snap (^mlv$jsn, 1);
    call_snap (^status, 1);
    log ('$subsystem failure', c#b_dayfile);
    WHILE TRUE DO
      pause (1);
    WHILEND;

  PROCEND hang;

?? OLDTITLE, NEWTITLE := 'PROCEDURE log', EJECT ??

  PROCEDURE log (s: string ( * );
        dayfile: 0 .. 7);

    VAR
      dcm: array [1 .. 8] of packed array [0 .. 9] of 0 .. 3f(16),
      dcwi: integer,
      dcci: 0 .. 9,
      si: ost$string_index,
      eol: boolean;

    IF (NOT mliss_debug) AND (dayfile = c#user_dayfile) THEN
      save_dayfile := s;
      RETURN;
    IFEND;
    si := 1;
    dcwi := 1;
    dcci := 0;
    eol := TRUE;
    utp$convert_string_to_dc_string (utc$ascii64, dcm, dcwi, dcci, s, si, eol);
    n7p$issue_dayfile_message (#LOC (dcm), dayfile);
    IF dayfile = c#b_dayfile THEN
      n7p$issue_dayfile_message (#LOC (dcm), c#user_dayfile);
    IFEND;

  PROCEND log;

?? OLDTITLE, NEWTITLE := 'PROCEDURE log_vrbl', EJECT ??

  PROCEDURE log_vrbl (s: string ( * );
        value: integer;
        dayfile: 0 .. 7);

    VAR
      new_s: ^string ( * ),
      n,
      l: integer;

    l := STRLENGTH (s);
    PUSH new_s: [l + 10];
    new_s^ (1, l) := s (1, l);
    new_s^ (l + 1, 10) := '          ';
    STRINGREP (new_s^ (l + 1, 10), n, value);
    log (new_s^, dayfile);

  PROCEND log_vrbl;

?? OLDTITLE, NEWTITLE := 'PROCEDURE search_for_jsn', EJECT ??

  PROCEDURE search_for_jsn (jsn: integer;
    VAR index: integer);

    VAR
      i: integer;

    index := 0;
    FOR i := 1 TO mlc$max_ant_entries DO
      IF jsn_list [i].jsn = jsn THEN
        index := i;
        RETURN;
      ELSEIF jsn_list [i].jsn = 0 THEN
        IF index = 0 THEN
          index := - i;
        IFEND;
      IFEND;
    FOREND;

  PROCEND search_for_jsn;

?? OLDTITLE, NEWTITLE := 'PROCEDURE write_to_ucp', EJECT ??

  PROCEDURE write_to_ucp (ucpa: integer;
        pscpa: ^cell;
        length: integer);

    VAR
      scpa: integer;

    pointer_to_integer (pscpa, scpa);

  /writ_loop/
    WHILE TRUE DO
    ssf_req.jid := request.ap1;
    ssf_req.fc := c#sf_writ;
    ssf_req.rc := 0;
    ssf_req.ucpa := ucpa;
    ssf_req.scpa := scpa;
    ssf_req.fp := length;
    sfcall (^ssf_req);
    IF ssf_req.rc <> 0 THEN
      log_vrbl ('write ucp err', ssf_req.rc, c#user_dayfile);
      IF ssf_req.rc = e#ucp_address_error THEN

{ Abort the UCP.
          EXIT /writ_loop/;

      ELSEIF ssf_req.rc = e#job_swapped_out THEN

{ Issue swapin and retry the writ.

          ssf_req.fc := c#sf_swpi;
          ssf_req.rc := 0;
          sfcall (^ssf_req);
          pause (1);
          CYCLE /writ_loop/;

        ELSE
          hang;
        IFEND;
      ELSE
        EXIT /writ_loop/;
      IFEND;
    WHILEND /writ_loop/;

  PROCEND write_to_ucp;

?? OLDTITLE, NEWTITLE := 'PROCEDURE integer_to_pointer', EJECT ??

  PROCEDURE integer_to_pointer (i: integer;
    VAR p: ^cell);

    VAR
      pi: ^integer;

    pi := #LOC (p);
    pi^ := i;

  PROCEND integer_to_pointer;

?? OLDTITLE, NEWTITLE := 'PROCEDURE pointer_to_integer', EJECT ??

  PROCEDURE pointer_to_integer (p: ^cell;
    VAR i: integer);

    VAR
      pi: ^integer;

    pi := #LOC (p);
    i := pi^;

  PROCEND pointer_to_integer;

?? OLDTITLE, NEWTITLE := 'PROCEDURE mlp$find_signed_on_job', EJECT ??

  PROCEDURE [XDCL] mlp$find_signed_on_job ALIAS 'mlpfsoj'
    (partner_job_unique_id: mlt$partner_job_unique_id;
    VAR find_status: mlt$find_status);

    VAR
      i: integer;

    find_status := mlc$job_not_signed_on;
    FOR i := 1 TO mlc$max_ant_entries DO
      IF jsn_list [i].jsn = partner_job_unique_id THEN
        find_status := mlc$job_signed_on;
        RETURN;
      IFEND;
    FOREND;

  PROCEND mlp$find_signed_on_job;

?? OLDTITLE, NEWTITLE := 'PROCEDURE mlp$terminate_signed_on_job', EJECT ??

  PROCEDURE [XDCL] mlp$terminate_signed_on_job ALIAS 'mlptsoj'
    (partner_job_unique_id: mlt$partner_job_unique_id;
    VAR terminate_status: mlt$terminate_status);

    VAR
      i: integer,
      status: ost$status;

    terminate_status := mlc$no_term_not_signed_on;
    FOR i := 1 TO mlc$max_ant_entries DO
      IF jsn_list [i].jsn = partner_job_unique_id THEN
        mlpkill (jsn_list [i].jsn, status);
        log_vrbl ('mlpkill status ', status.condition, c#user_dayfile);
        log ('jsn killed ', c#user_dayfile);
        change_job_sign_on_state (jsn_list [i].jsn, mlc$signed_off);

      /terminate_job/
        WHILE TRUE DO
          ssf_req.jid := jsn_list [i].job_id_word;
          ssf_req.fc := c#sf_regr;
          ssf_req.rc := 0;
          ssf_req.scpa := 0;
          ssf_req.ucpa := c#normal_error;
          sfcall (^ssf_req);
          IF ssf_req.rc <> 0 THEN
            log_vrbl ('regr err', ssf_req.rc, c#user_dayfile);
            IF ssf_req.rc = e#job_swapped_out THEN
{ Issue swapin and retry.

              ssf_req.fc := c#sf_swpi;
              ssf_req.rc := 0;
              sfcall (^ssf_req);

              pause (1);
              CYCLE /terminate_job/;
            ELSE
              hang;
            IFEND;
          ELSE
            EXIT /terminate_job/;
          IFEND;
        WHILEND /terminate_job/;

        jsn_list [i].jsn := 0;
        jsn_list [i].count := 0;
        jsn_list [i].job_id_word := initial_job_id_word_entry;
        signon_count := signon_count - 1;
        terminate_status := mlc$job_terminated;
        RETURN;
      IFEND;
    FOREND;

  PROCEND mlp$terminate_signed_on_job;


?? OLDTITLE, NEWTITLE := 'PROCEDURE mlp$force_job_sign_off', EJECT ??

  PROCEDURE [XDCL] mlp$force_job_sign_off ALIAS 'mlpfjso'
    (partner_job_unique_id: mlt$partner_job_unique_id;
    VAR forced_sign_off_status: mlt$forced_sign_off_status);

    VAR
      i: integer,
      status: ost$status;

    forced_sign_off_status := mlc$forced_sign_off_failed;
    FOR i := 1 TO mlc$max_ant_entries DO
      IF jsn_list [i].jsn = partner_job_unique_id THEN
        mlpkill (jsn_list [i].jsn, status);
        log_vrbl ('mlpkill status ', status.condition, c#user_dayfile);
        log ('jsn killed ', c#user_dayfile);
        change_job_sign_on_state (jsn_list [i].jsn, mlc$signed_off);
        forced_sign_off_status := mlc$forced_sign_off_ok;
        RETURN;
      IFEND;
    FOREND;

  PROCEND mlp$force_job_sign_off;

?? OLDTITLE, NEWTITLE := 'PROCEDURE mlp$locate_free_job_entry', EJECT ??

  PROCEDURE [XDCL] mlp$locate_free_job_entry ALIAS 'mlplfje' (VAR
      entry_located: boolean);

    VAR
      i: integer;

    entry_located := FALSE;
    FOR i := 1 TO mlc$max_partner_jobs DO
      IF pj_list [i].job_unique_id = 0 THEN
        entry_located := TRUE;
        RETURN;
      IFEND;
    FOREND;

  PROCEND mlp$locate_free_job_entry;

?? OLDTITLE, NEWTITLE := 'PROCEDURE mlp$create_job_entry', EJECT ??

  PROCEDURE [XDCL] mlp$create_job_entry ALIAS 'mlpcje' (job_unique_id:
    mlt$partner_job_unique_id;
    VAR create_status: mlt$create_status;
    remote_host_job: boolean);

    VAR
      i: integer;

    create_status := mlc$job_entry_create_failed;
    FOR i := 1 TO mlc$max_partner_jobs DO
      IF pj_list [i].job_unique_id = 0 THEN
        pj_list [i].job_unique_id := job_unique_id;
        pj_list [i].sign_on_state := mlc$not_signed_on;
        pj_list [i].remote_host_job := remote_host_job;
        create_status := mlc$job_entry_created_ok;
        RETURN;
      IFEND;
    FOREND;

  PROCEND mlp$create_job_entry;

?? OLDTITLE, NEWTITLE := 'PROCEDURE mlp$delete_job_entry', EJECT ??

  PROCEDURE [XDCL] mlp$delete_job_entry ALIAS 'mlpdje' (job_unique_id:
    mlt$partner_job_unique_id;
    VAR delete_status: mlt$delete_status);

    VAR
      i: integer;

    delete_status := mlc$job_entry_delete_failed;
    FOR i := 1 TO mlc$max_partner_jobs DO
      IF pj_list [i].job_unique_id = job_unique_id THEN
        pj_list [i].job_unique_id := 0;
        pj_list [i].sign_on_state := mlc$not_signed_on;
        pj_list [i].remote_host_job := false;
        delete_status := mlc$job_entry_deleted_ok;
        RETURN;
      IFEND;
    FOREND;

  PROCEND mlp$delete_job_entry;


?? OLDTITLE, NEWTITLE := 'PROCEDURE locate_job_entry', EJECT ??

  PROCEDURE locate_job_entry (job_unique_id: mlt$partner_job_unique_id;
    VAR job_located: boolean);

    VAR
      i: integer;

    job_located := FALSE;
    FOR i := 1 TO mlc$max_partner_jobs DO
      IF pj_list [i].job_unique_id = job_unique_id THEN
        job_located := TRUE;
        RETURN;
      IFEND;
    FOREND;

  PROCEND locate_job_entry;

?? OLDTITLE, NEWTITLE := 'PROCEDURE change_job_sign_on_state', EJECT ??

  PROCEDURE change_job_sign_on_state (job_unique_id: mlt$partner_job_unique_id;
        job_sign_on_state: mlt$job_sign_on_state);

    VAR
      ml_status: mlt$delete_status,
      i: integer;

    FOR i := 1 TO mlc$max_partner_jobs DO
      IF pj_list [i].job_unique_id = job_unique_id THEN
        IF (job_sign_on_state = mlc$signed_off) AND
          (pj_list [i].remote_host_job) THEN
          mlp$delete_job_entry (job_unique_id, ml_status);
        IFEND;
        pj_list [i].sign_on_state := job_sign_on_state;
        RETURN;
      IFEND;
    FOREND;

  PROCEND change_job_sign_on_state;

?? OLDTITLE, NEWTITLE := 'PROCEDURE fetch_job_sign_on_state', EJECT ??

  PROCEDURE fetch_job_sign_on_state (job_unique_id: mlt$partner_job_unique_id;
    VAR job_sign_on_state: mlt$job_sign_on_state);

    VAR
      i: integer;

    FOR i := 1 TO mlc$max_partner_jobs DO
      IF pj_list [i].job_unique_id = job_unique_id THEN
        job_sign_on_state := pj_list [i].sign_on_state;
        RETURN;
      IFEND;
    FOREND;

  PROCEND fetch_job_sign_on_state;

?? OLDTITLE, NEWTITLE := 'STATIC VARIABLES', EJECT ??

  VAR
    ssiw: t#ssiw_word := [14046000000(16), * ],
    request: t#scp_param_block := [ * , * , [REP c#data_block_length of 3]],
    index: integer,
    ssf_req: t#ssf_param_block,
    resp: cpid_response,
    jsn_list: array [1 .. mlc$max_ant_entries] of t#jsn_entry,
    pj_list: array [1 .. mlc$max_partner_jobs] of t#partner_job_entry,
    mlv$jsn: [XDCL] integer,
    initial_job_id_word_entry: t#job_id_word := [0, 0, 0, 0],
    status: ost$status,
    sscr: t#sscr_word := [FALSE, FALSE, 0, 0, FALSE, 12, * ],
    p_sscr: ^t#sscr_word,
    stat_response_ptr: ^t#ssf_stat_response,
    privileged_caller: boolean,
    nosbe: boolean := FALSE,
    swapoutjob: t#job_id_word := [0, 0, 0, 0],
    saved_ucpa: integer,
    swap_loop_count: integer := 0,
    irhf_not_swapped: boolean := TRUE,
    job_entry_found: boolean,
    job_sign_on_state: mlt$job_sign_on_state,
    qp: integer,
    unique: mlt$application_name,
    signon_count: integer := 0,
    mliss_debug: boolean,
    snap_debug: boolean,
    ra_word_0: packed record
      fill1: 0 .. 0ffffffffff(16),
      fill2: 0 .. 01f(16),
      cfo,
      idledown,
      pause,
      sw6,
      sw5,
      sw4,
      sw3,
      sw2,
      sw1: boolean,
      fill3: 0 .. 03f(16),
    recend,
    i: integer,
    special_endt_ucpa: boolean := FALSE,
    save_dayfile: string (60),
    mlv$terminate: [XDCL] boolean := FALSE,
    mlv$fatal_error: [XDCL] boolean := FALSE,
    pjexec_count: integer := 0;

?? OLDTITLE, NEWTITLE := 'EXTERNAL REFERENCES', EJECT ??

  PROCEDURE [XREF] make_me_a_system_cp ALIAS 'makscp';

  PROCEDURE [XREF] getword (address: integer;
        word: ^cell);

  PROCEDURE [XREF] initmli (i: integer);

  PROCEDURE [XREF] snap (p: ^cell;
        l: integer);

  PROCEDURE [XREF] pause (count: integer);

  PROCEDURE [XREF] ml$wait (milisecond: integer);

  PROCEDURE [XREF] sfcall (p: ^cell);

  PROCEDURE [XREF] mlpkill (jsn: integer;
    VAR status: ost$status);

  PROCEDURE [XREF] testnbe (VAR nosbe: boolean);
*copy DSP$NVE_RESOURCE_INTERFACE


?? OLDTITLE, NEWTITLE := 'PROGRAM main', EJECT ??

  PROGRAM main;

{ Initialize the subsystem and SCP environment.

    make_me_a_system_cp;
    dsp$check_if_ve_running;
    initmli (0);
    getword (0, #LOC (ra_word_0));
    mliss_debug := ra_word_0.sw2;
    snap_debug := ra_word_0.sw3;
    integer_to_pointer (c#sscr, p_sscr);
    pointer_to_integer (#LOC (request), i);
    sscr.ap := i;
    p_sscr^ := sscr;
    log (' nos/ve mli subsystem ', c#user_dayfile);
    call_snap (p_sscr, 1);
    testnbe (nosbe);

{ Begin the main loop.

  /main_loop/

    WHILE TRUE DO

{ Check for a request from a UCP.

      IF p_sscr^.i THEN
        getword (0, #LOC (ra_word_0));
        mliss_debug := ra_word_0.sw2;
        snap_debug := ra_word_0.sw3;
        call_snap (p_sscr, 1);
        call_snap (^request, 15);
        mlv$jsn := request.ap1.jsn;
        log_vrbl ('request received', request.ap0.status, c#user_dayfile);

      /process_ucp/
        BEGIN

{ Determine whether or not the UCP is privileged.

          IF request.ap0.status = c#normal_msg THEN
            ssf_req.jid := request.ap1;
            ssf_req.fc := c#sf_stat;
            ssf_req.rc := 0;
            sfcall (^ssf_req);
            IF ssf_req.rc <> 0 THEN
              log_vrbl ('stat err', ssf_req.rc, c#user_dayfile);
              IF ssf_req.rc = e#job_swapped_out THEN
{ Issue swapin and retry .

               ssf_req.fc := c#sf_swpi;
               ssf_req.rc := 0;
               sfcall (^ssf_req);

                pause (1);
                CYCLE /main_loop/;
              ELSE
                hang;
              IFEND;
            IFEND;

            stat_response_ptr := #LOC (ssf_req);
            IF (stat_response_ptr^.priv_program OR stat_response_ptr^.
                  priv_user) THEN
              privileged_caller := TRUE;
            ELSE
              privileged_caller := FALSE;

{ Determine if validated to sign on.

              ssf_req.fc := c#sf_cpid;
              ssf_req.rc := 0;
              ssf_req.fp := 0;
              ssf_req.jid := request.ap1;
              pointer_to_integer (^resp, i);
              ssf_req.scpa := i;
              sfcall (^ssf_req);
              IF ssf_req.rc = e#job_swapped_out THEN
                pause (1);
                CYCLE /main_loop/;
              IFEND;
              IF ssf_req.rc <> 0 THEN
                log_vrbl ('stat err', ssf_req.rc, c#user_dayfile);
                hang;
              IFEND;
              IF NOT resp.validated THEN
                log ('signon attempt by nonvalidated user', c#user_dayfile);
                ssf_req.jid := request.ap1;
                ssf_req.fc := c#sf_regr;
                ssf_req.rc := 0;
                ssf_req.scpa := 0;
                ssf_req.ucpa := c#hostile_user_error;
                sfcall (^ssf_req);
                IF ssf_req.rc <> 0 THEN
                  log_vrbl ('regr err', ssf_req.rc, c#user_dayfile);
                  IF ssf_req.rc = e#job_swapped_out THEN
                    pause (1);
                    CYCLE /main_loop/;
                  ELSE
                    hang;
                  IFEND;
                IFEND;
                EXIT /process_ucp/;
              IFEND;
            IFEND;
          IFEND;

          CASE request.ap0.status OF

          = c#normal_msg =

            CASE request.data [c#funct] OF

            = c#signon =

              IF NOT privileged_caller THEN

                locate_job_entry (mlv$jsn, job_entry_found);

                IF NOT job_entry_found THEN
                  log ('signon attempt by user job not started by ss',
                        c#user_dayfile);
                  ssf_req.jid := request.ap1;
                  ssf_req.fc := c#sf_regr;
                  ssf_req.rc := 0;
                  ssf_req.scpa := 0;
                  ssf_req.ucpa := c#hostile_user_error;
                  sfcall (^ssf_req);
                  IF ssf_req.rc <> 0 THEN
                    log_vrbl ('regr err', ssf_req.rc, c#user_dayfile);
                    IF ssf_req.rc = e#job_swapped_out THEN

{ Ignore UCP swapped out condition.

                      pause (1);
                      CYCLE /main_loop/;

                    ELSE
                      hang;
                    IFEND;
                  IFEND;
                  special_endt_ucpa := TRUE;
                  EXIT /process_ucp/;
                ELSE
                  fetch_job_sign_on_state (mlv$jsn, job_sign_on_state);

                  IF job_sign_on_state = mlc$signed_on THEN
                    log ('signon attempt by user job currently signed on',
                          c#user_dayfile);
                    ssf_req.jid := request.ap1;
                    ssf_req.fc := c#sf_regr;
                    ssf_req.rc := 0;
                    ssf_req.scpa := 0;
                    ssf_req.ucpa := c#normal_error;
                    sfcall (^ssf_req);
                    IF ssf_req.rc <> 0 THEN
                      log_vrbl ('regr err', ssf_req.rc, c#user_dayfile);
                      IF ssf_req.rc = e#job_swapped_out THEN

{ Ignore UCP swapped out condition.

                        pause (1);
                        CYCLE /main_loop/;

                      ELSE
                        hang;
                      IFEND;
                    IFEND;
                    EXIT /process_ucp/;
                  IFEND;
                IFEND;
              IFEND;

              mlp$sign_on (request.data [c#aname], request.data [c#maxmsg],
                    unique, status);
              log_vrbl ('signon status ', status.condition, c#user_dayfile);
              IF (status.condition = mlc$nosve_not_up) AND (signon_count > 0)
                    THEN
                expunge;
                dsp$nve_down_condition;
              IFEND;

{ Return status and unique application name to the UCP.

              write_to_ucp (request.ap0.addr + c#mlpv1 - 1, ^unique, 1);
              write_to_ucp (request.ap0.addr + c#mlpsv - 1, ^status, 1);
              IF status.condition = mlc$ok THEN

{ Add new entry to jsn list or increment an existing entry.

                search_for_jsn (mlv$jsn, index);
                IF index < 0 THEN

{ Set long term connection.

                /sltc_loop/
                  WHILE TRUE DO

                  ssf_req.jid := request.ap1;
                  ssf_req.fc := c#sf_sltc;
                  ssf_req.rc := 0;
                  ssf_req.fp := 0;
                  sfcall (^ssf_req);
                  IF ssf_req.rc <> 0 THEN
                    log_vrbl ('sltc err', ssf_req.rc, c#user_dayfile);
                    IF ssf_req.rc = e#job_swapped_out THEN

{ Issue swapin and retry the sltc.

                        ssf_req.fc := c#sf_swpi;
                        ssf_req.rc := 0;
                        sfcall (^ssf_req);
                        pause (1);
                        CYCLE /sltc_loop/;
                      ELSE
                        hang;
                      IFEND;
                    ELSE
                      EXIT /sltc_loop/;
                    IFEND;
                  WHILEND /sltc_loop/;

{ Add new entry to jsn list.

                  index := - index;
                  jsn_list [index].jsn := mlv$jsn;
                  jsn_list [index].count := 1;
                  jsn_list [index].job_id_word := request.ap1;
                  signon_count := signon_count + 1;
                ELSEIF index = 0 THEN

{ Full jsn list - should never happen.

                  log ('jsn list full ', c#user_dayfile);
                  hang;
                ELSE { index > 0 }

{ Increment count for an existing jsn.

                  jsn_list [index].count := jsn_list [index].count + 1;
                IFEND;
              IFEND;

              IF NOT privileged_caller THEN
                change_job_sign_on_state (mlv$jsn, mlc$signed_on);
              IFEND;

            = c#signoff =

              mlp$sign_off (request.data [c#aname], status);
              log_vrbl ('signoff status ', status.condition, c#user_dayfile);
              IF (status.condition = mlc$nosve_not_up) AND (signon_count > 0)
                    THEN
                expunge;
                dsp$nve_down_condition;
              IFEND;

{ Return status to the UCP.

              write_to_ucp (request.ap0.addr + c#mlpsv - 1, ^status, 1);
              IF (status.condition = mlc$ok) OR (status.condition =
                    mlc$queued_msgs_lost) THEN

{ Decrement jsn count.

                search_for_jsn (mlv$jsn, index);
                IF index <= 0 THEN
                  log ('jsn not found (signoff) ', c#user_dayfile);
                  hang;
                ELSE
                  IF jsn_list [index].count = 1 THEN

{ End the long term connection with the UCP.

                  /cltc_loop/
                    WHILE TRUE DO

                      ssf_req.jid := request.ap1;
                      ssf_req.fc := c#sf_cltc;
                      ssf_req.fp := 0;
                      ssf_req.rc := 0;
                      sfcall (^ssf_req);
                      IF ssf_req.rc <> 0 THEN
                        log_vrbl ('cltc err', ssf_req.rc, c#user_dayfile);
                        IF ssf_req.rc = e#job_swapped_out THEN

{ Issue swapin and retry the cltc.

                          ssf_req.fc := c#sf_swpi;
                          ssf_req.rc := 0;
                          sfcall (^ssf_req);
                          pause (1);
                          CYCLE /cltc_loop/;
                        ELSE
                          hang;
                        IFEND;
                      ELSE
                        EXIT /cltc_loop/;
                      IFEND;
                    WHILEND /cltc_loop/;


                    jsn_list [index].jsn := 0;
                    signon_count := signon_count - 1;
                  IFEND;
                  jsn_list [index].count := jsn_list [index].count - 1;
                IFEND;
              IFEND;

                change_job_sign_on_state (mlv$jsn, mlc$signed_off);

            = c#swapout_ucp =

            search_for_jsn (mlv$jsn, index);
              IF NOT nosbe OR (swapoutjob <> initial_job_id_word_entry) OR
                 (index < 1) OR (jsn_list[index].count < 2) THEN
                status.condition := mlc$illegal_function;
                log_vrbl ('illegal ucp req', request.data [c#funct],
                      c#user_dayfile);
                write_to_ucp (request.ap0.addr + c#mlpsv - 1, ^status, 1);
              ELSE
                swapoutjob := request.ap1;
                ssf_req.jid := request.ap1;
                ssf_req.fc := c#sf_swpo;
                ssf_req.rc := 0;
                ssf_req.fp := 0;
                sfcall (^ssf_req);
                irhf_not_swapped := FALSE;
                swap_loop_count := 0;
                saved_ucpa := request.ap0.addr;
              IFEND;

            ELSE

{ Signon and signoff are the only MLI functions supported by the subsystem.
{ An illegal MLI function status is returned for all others.

              status.condition := mlc$illegal_function;
              log_vrbl ('illegal ucp req', request.data [c#funct],
                    c#user_dayfile);
              write_to_ucp (request.ap0.addr + c#mlpsv - 1, ^status, 1);

            CASEND;

          = c#ucp_ended, c#ucp_aborted, c#forcibly_broken =
            special_endt_ucpa := TRUE;

{ Sign the UCP off of the MLI.

            search_for_jsn (mlv$jsn, index);
            IF index <= 0 THEN

{ Ignore this condition

              log ('jsn not found (ucp end/abt/fb)', c#user_dayfile);
            ELSE
                mlpkill (mlv$jsn, status);
                log_vrbl ('mlpkill status ', status.condition, c#user_dayfile);
                log ('jsn killed ', c#user_dayfile);
                jsn_list [index].jsn := 0;
                jsn_list [index].count := 0;
                jsn_list [index].job_id_word := initial_job_id_word_entry;
                signon_count := signon_count - 1;
                IF nosbe OR NOT privileged_caller THEN
                  change_job_sign_on_state (mlv$jsn, mlc$signed_off);
                IFEND;
            IFEND;
          ELSE

{ Illegal SCP request.

            log_vrbl ('bad scp req ', request.ap0.status, c#user_dayfile);
            hang;

          CASEND;

        END /process_ucp/;

       IF irhf_not_swapped AND (request.ap0.status <> c#forcibly_broken) THEN
{ Respond to the UCP request

      /endt_loop/
        WHILE TRUE DO

          ssf_req.jid := request.ap1;
          ssf_req.fc := c#sf_endt;
          ssf_req.scpa := 0;
          ssf_req.rc := 0;
          ssf_req.fp := 0;
          IF special_endt_ucpa THEN
            log ('endt for hostile user', c#user_dayfile);
            ssf_req.ucpa := 3fffe(16); { -1}
          ELSE
            ssf_req.ucpa := request.ap0.addr;
          IFEND;
          sfcall (^ssf_req);
          IF ssf_req.rc <> 0 THEN
            log_vrbl ('endt err', ssf_req.rc, c#user_dayfile);
            IF ssf_req.rc = e#job_swapped_out THEN

{ Issue swapin and retry the endt.

              ssf_req.fc := c#sf_swpi;
              ssf_req.rc := 0;
              sfcall (^ssf_req);
              pause (1);
              CYCLE /endt_loop/;
            ELSE
{ Ignore all other errors.
              EXIT /endt_loop/;
            IFEND;
          ELSE
            EXIT /endt_loop/;
          IFEND;
        WHILEND /endt_loop/;
      IFEND;

        special_endt_ucpa := FALSE;
        p_sscr^.i := FALSE;
        irhf_not_swapped := TRUE;

      ELSE
        mlv$jsn := 0;
        icp$partner_job_exec_real;
        rhp$partner_job_exec;

        IF nosbe AND (swapoutjob <> initial_job_id_word_entry) THEN
          swap_loop_count := swap_loop_count + 1;
        IFEND;
        IF nosbe AND (swap_loop_count = c#swapout_max) THEN
          ssf_req.jid := swapoutjob;
          ssf_req.fc := c#sf_swpi;
          ssf_req.fp := 0;
          swap_loop_count := 0;
          swapoutjob := initial_job_id_word_entry;
          ssf_req.rc := 0;
          sfcall (^ssf_req);
          pause (1);

          /endt_loop2/
          WHILE TRUE DO
            ssf_req.fc := c#sf_endt;
            ssf_req.scpa := 0;
            ssf_req.ucpa := saved_ucpa;
            ssf_req.rc := 0;
            ssf_req.fp := 0;
            sfcall (^ssf_req);
            IF (ssf_req.rc <> 0) THEN
              log_vrbl ('ENDT ERR 2', ssf_req.rc, c#user_dayfile);
              IF (ssf_req.rc = e#job_swapped_out) THEN
                ssf_req.fc := c#sf_swpi;
                ssf_req.rc := 0;
                sfcall (^ssf_req);
                pause (1);
                CYCLE /endt_loop2/;
              ELSE
                EXIT /endt_loop2/;
              IFEND;
            ELSE
              EXIT /endt_loop2/;
            IFEND;
          WHILEND /endt_loop2/;

        IFEND;

        ml$wait (250);

      IFEND;

      dsp$nve_resource_interface;
      IF mlv$terminate OR mlv$fatal_error THEN
        expunge;
        dsp$nve_down_condition;
      IFEND;

    WHILEND /main_loop/;

  PROCEND main;

MODEND mlp$mli_subsystem;
*DECK DECK=MLP$OUTPUT_FLOATING_NUMBER EXPAND=FALSE
*copyc MLT$ERROR
*copyc MLT$FLOATING_LENGTH
*copyc MLT$OUTPUT_FORMAT
*copyc MLT$STRING_LENGTH
  ?? SKIP := 2 ??
  ?? PUSH (LIST := ON) ??
  { MLD$OFN - Declare mlp$output_floating_number }
  ?? POP ??

  PROCEDURE [XREF] mlp$output_floating_number (source: ^cell;
        source_length: mlt$floating_length;
        target: ^cell;
        format: mlt$output_format;
    VAR actual_target_length: mlt$string_length;
    VAR status: mlt$error);

  { FUNCTION: Convert a floating point number into an ASCII
  {representation.
  {
  { FORMAT describes the format of the result string. The names of the
  {ordinals for the FORMAT field (of the same-named parameter) are
  {derived from FORTRAN-style format descriptors.
  { When the FORMAT field contains MLC$LIST_DIRECTED, the number is
  {output in either a modified E or modified F format. If the absolute
  {value of the number is greater than or equal to 10**-6 and less
  {than 10**9, the modified F format is used; otherwise the modified E
  {format is used. The DIGITS field gives the number of digits to
  {which the number is rounded. Trailing zeroes after the decimal
  {point are always removed. The SCALE_FACTOR field is ignored;
  {rather, a scale_factor of 0 is used for the modified F style, and 1
  {is used for the modified E format. The EXPONENT_STYLE field is also
  {ignored. No exponent occurs for F style, and, for E style, the
  {width of the field will be the minimum needed. If the WIDTH field
  {is insufficient to hold the representation with all DIGITS
  {significant digits, then digits will be truncated from the right of
  {the mantissa in order to fit the representation into WIDTH
  {characters.
  { When the FORMAT field does not contain MLC$LIST_DIRECTED, the
  {EXPONENT_STYLE field contains either 0 or the number of digits in
  {the exponent. When 0 is provided, the normal FORTRAN style of four
  {characters for the exponent is used. When the JUSTIFICATION field
  {indicates right justification, blank fill will occur on the left.
  {Otherwise there is no fill.
  {
  { ACTUAL_TARGET_LENGTH will contain the number of characters written
  {to the target area, excluding any padding.
  {
  { STATUS MLE$BAD_PARAMETERS is returned when FORMAT.WIDTH is
  {inconsistent with the other fields of FORMAT OR when there is a
  {negative # of digits specified in the output format
  {(independent of the value of the floating point number).
  { STATUS MLE$INFINITE is returned whenever the source floating point
  {number is infinite.
  { STATUS MLE$INDEFINITE is returned whenever the source floating
  {point number is indefinite.
  { STATUS MLE$LOSS_OF_SIGNIFICANCE is returned whenever the
  {particular value of the floating point number is not representable
  {in the format specified.
*DECK DECK=MLP$RECEIVE_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF {TS_gate} ] mlp$receive_message ALIAS 'mlpreme'
    (application_name: mlt$application_name;
    VAR arbitrary_info: mlt$arbitrary_info;
    signal: mlt$signal;
    message_area: mlt$message_ptr;
    VAR message_length: mlt$message_length;
    message_area_length: mlt$message_length;
    receive_index: mlt$receive_index;
    VAR sender_name: mlt$application_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=MLP$REGISTER_SIGNAL_HANDLER EXPAND=FALSE


  PROCEDURE [XREF] mlp$register_signal_handler (application_name:
    mlt$application_name;
    handler: mlt$handler;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=MLP$SEND_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF {TS_gate} ] mlp$send_message ALIAS 'mlpseme'
    (application_name: mlt$application_name;
    arbitrary_info: mlt$arbitrary_info;
    signal: mlt$signal;
    message_area: mlt$message_ptr;
    message_length: mlt$message_length;
    destination_name: mlt$application_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=MLP$SIGN_OFF EXPAND=FALSE

  PROCEDURE [XREF {TS_gate} ] mlp$sign_off ALIAS 'mlpsiof' (application_name:
    mlt$application_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=MLP$SIGN_ON EXPAND=FALSE

  PROCEDURE [XREF {TS_gate} ] mlp$sign_on ALIAS 'mlpsion' (application_name:
    mlt$application_name;
    max_messages: mlt$max_messages;
    VAR unique_application_name: mlt$application_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=MLP$SIGN_ON_OS EXPAND=FALSE

  PROCEDURE [XREF {TS_gate} ] mlp$sign_on_os ALIAS 'mlpsion' (application_name:
    mlt$application_name;
    max_messages: mlt$max_messages;
    VAR unique_application_name: mlt$application_name;
    VAR status: ost$status);

  PROCEDURE [XREF {TS_gate} ] mlp$sign_off_os ALIAS 'mlpsiof'
    (application_name: mlt$application_name;
    VAR status: ost$status);

  PROCEDURE [XREF {TS_gate} ] mlp$receive_message_os ALIAS 'mlpreme'
    (application_name: mlt$application_name;
    VAR arbitrary_info: mlt$arbitrary_info;
    signal: mlt$signal;
    message_area: mlt$message_ptr;
    VAR message_length: mlt$message_length;
    message_area_length: mlt$message_length;
    receive_index: mlt$receive_index;
    VAR sender_name: mlt$application_name;
    VAR status: ost$status);

  PROCEDURE [XREF {TS_gate} ] mlp$send_message_os ALIAS 'mlpseme'
    (application_name: mlt$application_name;
    arbitrary_info: mlt$arbitrary_info;
    signal: mlt$signal;
    message_area: mlt$message_ptr;
    message_length: mlt$message_length;
    destination_name: mlt$application_name;
    VAR status: ost$status);

  PROCEDURE [XREF {TS_gate} ] mlp$add_sender_os ALIAS 'mlpadse'
    (application_name: mlt$application_name;
    sender_name: mlt$application_name;
    VAR status: ost$status);

  PROCEDURE [XREF {TS_gate} ] mlp$delete_sender_os ALIAS 'mlpdese'
    (application_name: mlt$application_name;
    sender_name: mlt$application_name;
    VAR status: ost$status);

  PROCEDURE [XREF {TS_gate} ] mlp$confirm_send_os ALIAS 'mlpcose'
    (application_name: mlt$application_name;
    destination_name: mlt$application_name;
    VAR status: ost$status);

  PROCEDURE [XREF {TS_gate} ] mlp$fetch_receive_list_os ALIAS 'mlpferl'
    (application_name: mlt$application_name;
    sender_name: mlt$application_name;
    VAR receive_list: mlt$receive_list;
    VAR receive_count: mlt$receive_count;
    VAR status: ost$status);

  PROCEDURE [XREF] mlp$register_signal_handler_os (application_name:
    mlt$application_name;
    handler: mlt$handler;
    VAR status: ost$status);

  PROCEDURE [XREF] mlp$get_handler_info_os (application_name:
    mlt$application_name;
    VAR handler: mlt$handler;
    VAR status: ost$status);

  PROCEDURE [XREF] mlp$fetch_link_partner_info_os (application_name:
    mlt$application_name;
        partner_name: mlt$application_name;
    VAR last_op: mlt$operation;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=MLP$TASK_TERMINATION_CLEANUP EXPAND=FALSE


  PROCEDURE [XREF {TS_gate} ] mlp$task_termination_cleanup;

*DECK DECK=MLP$TERMINATE_SIGNED_ON_JOB EXPAND=FALSE

  PROCEDURE [XREF] mlp$terminate_signed_on_job ALIAS 'mlptsoj' (
    partner_job_unique_id: mlt$partner_job_unique_id;
    VAR terminate_status: mlt$terminate_status);

?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc MLT$PARTNER_JOB_UNIQUE_ID
?? POP ??
*DECK DECK=MLP$UPDATE_JOB_STATE_TO_SIGN_ON EXPAND=TRUE
*DECK DECK=MLT$ANT_ENTRY EXPAND=FALSE

{ Internal constants and type declarations for the NOS/VE memory link
{interface. }
?? PUSH (LISTEXT := ON) ??
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc ost$signature_lock
*copyc jmt$system_supplied_name
?? POP ??
*copyc tmc$signal_identifiers

  CONST
    mlc$message_queue_size = 30,
    mlc$keypoint_class = 15, {**** subject to change ****}
    mlc$ilk = 1,
    mlc$not_ilk = 0,
    mlc$shift = 256,
    mlc$empty_entry = - 1,
    mlc$signal_handler_ring = 3,
    mlc$not_found = 0,
    mlc$end_of_chain = 0,
    mlc$max_sn_entry = 128,
    mlc$max_primary_entry = 128,
    mlc$max_signons_per_job = 25,
    mlc$max_ant_entries = 2048;

  TYPE
    mlt$ant_entry = record
{  note that order of fields is vital for alignment of cs_lock words }
      reservation: ALIGNED [0 MOD 8] ost$cs_lock,
      application_name: mlt$application_name,
      forward_p: mlt$ant_index,
      backward_p: mlt$ant_index,
      sn_fwd_p: mlt$ant_index,
      sn_bkwd_p: mlt$ant_index,
      max_messages: mlt$max_messages,
      receive_list: ^mlt$int_receive_list,
      permit_list: ^mlt$permit_list,
      system_name: mlt$system_name,
      highest_rl_entry,
      active_rl_count,
      unique: integer,
      handler: mlt$handler,
      last_operation: mlt$operation,
      multiple: boolean,
      job_recovery_index: 0 .. mlc$max_signons_per_job,
    recend,
    mlt$keypoint_id = (mlc$kp_signon, mlc$kp_signoff, mlc$kp_addspl,
      mlc$kp_delspl, mlc$kp_fetchrl, mlc$kp_confirm, mlc$kp_send,
      mlc$kp_receive, mlc$kp_mlierr, mlc$kp_status, mlc$kp_register_sh,
      mlc$kp_handle_signal, mlc$kp_invoke_handler, mlc$kp_send_signal),
    mlt$internal_error = (unlock_err, signon_res_conflict, case_err,
      send_rl_conflict, need_c170_name, bad_system_name, unique_error,
      register_handler),
{
{ A system_name is defined as follows:
{   C170 = C170 flag and C170 jsn.
{   C180 = C180 flag and C180 task id.
{
    mlt$system_name = record
      case c170_c180_flag: mlt$c170_c180_flag of
      = c170 =
        name_170: integer,
      = mlc$c180 =
        name_180: ost$global_task_id,
      casend,
    recend,
    mlt$permit_index = 0 .. mlc$max_permits,
    mlt$search_status = (found, not_found, no_match),
    mlt$c170_c180_flag = (c170,mlc$c180, mlc$none),
    mlt$ant_index = 0 .. mlc$max_ant_entries,
    mlt$sn_table_index = 0..mlc$max_sn_entry,
    mlt$int_receive_list_entry = record
      sender_name: mlt$application_name,
      arbitrary_info: mlt$arbitrary_info,
      message_location: ^array [ * ] of cell,
      message_length: mlt$message_length,
      chained_entry: ^mlt$int_receive_list_entry,
      ssn: jmt$system_supplied_name,
    recend,
    mlt$unique = set of 1 .. mlc$max_signons_per_system_name,
    mlt$pmt_signal = record
      data: packed array [1 .. 7] of 0 .. 0ff(16),
      from: mlt$application_name,
      dest: mlt$application_name,
      direction: mlt$direction,
      pad: array [1 .. 8] of 0 .. 0ff(16),
    recend,
    mlt$permit_list_entry = record
      sender: mlt$application_name,
    recend,
    mlt$int_receive_list = array [1 .. mlc$max_queued_messages] of
      mlt$int_receive_list_entry,
    mlt$permit_list = array [1 .. mlc$max_permits] of mlt$permit_list_entry,
    mlt$shared_segment = record
{  note that order of fields is vital for alignment of cs_lock words }
      tlock: ALIGNED [0 MOD 8] ost$cs_lock,
      plock: ost$cs_lock,
      sn_chain_table: array [1..mlc$max_sn_entry] of mlt$ant_index,
      next_free_ant_entry: mlt$ant_index,
      ant: array [1 .. mlc$max_ant_entries] of mlt$ant_entry,
      dust_id: ost$global_task_id,
      pspace: ALIGNED [0 MOD 32] HEAP (REP 5 of cell),
    recend;
*DECK DECK=MLT$C170_RQST_BLK EXPAND=FALSE

{     * * * warning * * * }
{     any changes made to mlc$c170_rqst_blk must also be reflected
{     in EIE.

  CONST

{ mli function values

    signon = 0,
    signoff = 1,
    addspl = 2,
    delspl = 3,
    send = 4,
    receive = 5,
    fetchrl = 6,
    confirm = 7,
    kill = 8,
    kill_all = 9,
    swapout_ucp = 10,  { used for nos/be only }

{ word offsets into mli parameter block

    aname = 0,
    sname = 1,
    pstatus = 2,
    funct = 3,
    rindex = 4,
    fwa = 5,
    buflen = 6,
    signal = 7,
    arbinfo = 8,
    msglen = 9,
    mlpsv = 10,
    mlpv1 = 11,
    mlpv2 = 12,
    mlpv3 = 13,
    jsn = fwa,
    maxmsg = rindex,
    count = rindex;

  CONST
{  values for the opstatus field
    idle = 0,
    wait180 = 1,
    wait170 = 2,
    smip = 3,
    rmip = 4,
    not_available = 5,
{ values for the reject_calls field
    reject_all_calls = 0,
    accept_dsc_calls = 1,
    accept_all_calls = 2,
    initial_buffer_count = 2,
    mlimi = 10;

  TYPE
    mlt$c170_rqst_blk = packed record
      arr: packed array [0 .. mlimi - 1] of packed record
        op_status: ALIGNED [0 MOD 8] integer,
        copy_length: integer,
        time: integer,
        jsn: integer,
        restart: integer,
        used: integer,
        mli_packet: array [0 .. 13] of integer,
      recend,
      req: ^tmt$rb_ready_task,
      buffers: ^array [0 .. mlimi - 1] of array [0 .. mlc$max_message_length]
        of cell,
      max_length: integer,
      reject_calls: integer,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc TMT$RB_READY_TASK
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=MLT$COMPARE EXPAND=FALSE
  ?? SKIP := 2 ??
  ?? PUSH (LIST := ON) ??
  { MLTCOMP -- Declaration of mlt$compare }
  ?? POP ??

  TYPE
    mlt$compare = (mlc$equal, mlc$source_is_greater, mlc$unordered,
      mlc$target_is_greater);
*DECK DECK=MLT$ERROR EXPAND=FALSE
  ?? SKIP := 2 ??
  ?? PUSH (LIST := ON) ??
  { MLTERR -- Declaration of mlt$error }
  ?? POP ??

  TYPE
    mlt$error = (mle$no_error, mle$invalid_bdp_data,
      mle$loss_of_significance, mle$overflow, mle$underflow,
      mle$indefinite, mle$infinite, mle$bad_parameters,
      mle$no_digits);
*DECK DECK=MLT$EXPONENT_STYLE EXPAND=FALSE
  ?? SKIP := 2 ??
  ?? PUSH (LIST := ON) ??
  { MLTES -- Declaration of mlt$exponent_style }
  ?? POP ??

  CONST
    mlc$min_exponent_style = 0,
    mlc$max_exponent_style = 6;

  TYPE
    mlt$exponent_style = mlc$min_exponent_style ..
      mlc$max_exponent_style;
*DECK DECK=MLT$FLOATING_LENGTH EXPAND=FALSE
  ?? SKIP := 2 ??
  ?? PUSH (LIST := ON) ??
  { MLTFL -- Declaration of mlt$floating_length }
  ?? POP ??

  TYPE
    mlt$floating_length = (mlc$single_precision,
      mlc$double_precision);
*DECK DECK=MLT$FORMAT EXPAND=FALSE
  ?? SKIP := 2 ??
  ?? PUSH (LIST := ON) ??
  { MLTFORM -- Declaration of mlt$format }
  ?? POP ??

  TYPE
    mlt$format = (mlc$f_style, mlc$e_style, mlc$g_style,
      mlc$list_directed, mlc$namelist);
*DECK DECK=MLT$HANDLE_BLANKS EXPAND=FALSE
  ?? SKIP := 2 ??
  ?? PUSH (LIST := ON) ??
  { MLTHB -- Declaration of mlt$handle_blanks }
  ?? POP ??

  TYPE
    mlt$handle_blanks = (mlc$ignore_blanks, mlc$stop_on_blank,
      mlc$blanks_equal_zero);
*DECK DECK=MLT$INTEGER_LENGTH EXPAND=TRUE
  ?? SKIP := 2 ??
  ?? PUSH (LIST := ON) ??
  { MLTIL -- Declaration of mlt$integer_length }
  ?? POP ??

  CONST
    mlc$min_integer_length = 1,
    mlc$max_integer_length = 8;

  TYPE
    mlt$integer_length = mlc$min_integer_length ..
      mlc$max_integer_length;
*DECK DECK=MLT$INTEGER_TYPE EXPAND=TRUE
  ?? SKIP := 2 ??
  ?? PUSH (LIST := ON) ??
  { MLTIT -- Declaration of mlt$integer_type }
  ?? POP ??

  TYPE
    mlt$integer_type = (mlc$signed_integer, mlc$unsigned_integer);
*DECK DECK=MLT$JUSTIFY EXPAND=FALSE
  ?? SKIP := 2 ??
  ?? PUSH (LIST := ON) ??
  { MLTJUST -- Declaration of mlt$justify }
  ?? POP ??

  TYPE
    mlt$justify = (mlc$left_justify, mlc$right_justify);
*DECK DECK=MLT$OUTPUT_FORMAT EXPAND=FALSE
*copyc MLT$EXPONENT_STYLE
*copyc MLT$FORMAT
*copyc MLT$JUSTIFY
*copyc MLT$STRING_LENGTH
*copyc MLT$SIGN_TREATMENT
  ?? SKIP := 2 ??
  ?? PUSH (LIST := ON) ??
  { MLTOF -- Declaration of mlt$output_format }
  ?? POP ??

  TYPE
    mlt$output_format = record
      justification: mlt$justify,
      sign: mlt$sign_treatment,
      format: mlt$format,
      scale_factor: integer,
      width: mlt$string_length,
      digits: mlt$string_length,
      exponent_character: char,
      exponent_style: mlt$exponent_style,
    recend;
*DECK DECK=MLT$PARTNER_JOB_UNIQUE_ID EXPAND=FALSE

?? PUSH (LISTEXT := ON) ??
?? POP ??

  CONST

    mlc$pj_exec_frequency = 10,
    mlc$max_partner_jobs = 50;

  TYPE

    mlt$partner_job_unique_id = integer,

    mlt$find_status = (mlc$job_signed_on, mlc$job_not_signed_on),

    mlt$terminate_status = (mlc$job_terminated, mlc$no_term_not_signed_on),

    mlt$create_status = (mlc$job_entry_created_ok,
      mlc$job_entry_create_failed),

    mlt$delete_status = (mlc$job_entry_deleted_ok,
      mlc$job_entry_delete_failed),

    mlt$job_sign_on_state = (mlc$not_signed_on, mlc$signed_on, mlc$signed_off),

    mlt$forced_sign_off_status = (mlc$forced_sign_off_ok,
      mlc$forced_sign_off_failed);
*DECK DECK=MLT$SIGN_TREATMENT EXPAND=FALSE
  ?? SKIP := 2 ??
  ?? PUSH (LIST := ON) ??
  { MLTST -- Declaration of mlt$sign_treatment }
  ?? POP ??

  TYPE
    mlt$sign_treatment = (mlc$minus_if_negative, mlc$always_signed);
*DECK DECK=MLT$STRING_LENGTH EXPAND=FALSE
  ?? SKIP := 2 ??
  ?? PUSH (LIST := ON) ??
  { MLTSL -- Declaration of mlt$string_length }
  ?? POP ??

  CONST
    mlc$min_string_length = 0,
    mlc$max_string_length = 7fffffff(16);

  TYPE
    mlt$string_length = mlc$min_string_length ..
      mlc$max_string_length;
*DECK DECK=MMC$DEBUG_CONSTANTS EXPAND=FALSE
{ This decks defines compile-time constants to control conditional compilation
{ of debug code in memory manager modules in monitor mode. All constants should
{ be set to FALSE for the transmitted version of this deck.

  CONST
    mmc$debug = FALSE;


  ?VAR
     mmc$debug_check_queues: boolean := FALSE, {Check PQL linkage}
     mmc$debug_relink_swapping_job: boolean := FALSE , {Stop if relink page of swapping job}
     mmc$debug_pt: boolean := FALSE, {check PT - AST linkage}
     mmc$debug_free_asid: boolean := FALSE, {Verify no attempt is made to free an AST
                                            { entry with pages not in AVAIL queue.
     mmc$debug_aste_p_from_pfti: boolean := FALSE, {Verify aste_p in pfti is correct}
     mmc$debug_rma_list: boolean := FALSE, {Verify RMA list on lock/unlock rma list}
     mmc$debug_esc_alloc: boolean := FALSE, {check for escaped allocation}
     mmc$debug_ast_pft: boolean := FALSE?; {check pft.aste_p on reference to AST}

*DECK DECK=MMC$DEFAULT_SDT_LENGTH EXPAND=FALSE
{  *copyc mmc$default_sdt_length
{  This common deck defines constants used by memory manager in job mode.
{  Also used as length of bit map ( osv$system_privilege_map ) set by
{  system core segment manager.

  CONST
    mmc$default_sdt_length = 100;
*DECK DECK=MMC$FAILED_FILE_ALLOC_FLAG EXPAND=FALSE
*DECK DECK=MMC$FILE_SERVER_SEGMENT_NUMBER EXPAND=FALSE
{ Xref deck - mmc$file_server_segment_number.

  CONST
    mmc$file_server_segment_number = 19(16);
*DECK DECK=MMC$FIRST_TRANSIENT_SEGMENT EXPAND=FALSE

  CONST
    mmc$first_loader_predefined_seg = 24(16),
    mmc$num_loader_predefined_segs = 1c(16),
    mmc$first_transient_segment = mmc$first_loader_predefined_seg + mmc$num_loader_predefined_segs;

*DECK DECK=MMC$IOCB_TABLE_SIZE EXPAND=FALSE

{ This constant is the upperbound of an I/O control block table, which
{ is used for asynchronous I/O.

  CONST
    mmc$iocb_table_size = 50;

*DECK DECK=MMC$MANAGE_MEMORY_UTILITY EXPAND=FALSE

{  PURPOSE: This deck (mmc$manage_memory_utility) primarily contains default values for the mmv$ variables
{    and the Global Page Queue List all of which are managed by the Manage Memory Utility which
{    is in the module mmm$manage_memory.

    CONST
      mmc$mmu_age_interval_ceiling   =      10,   { pages }
      mmc$mmu_age_interval_floor     =       3,   { pages }
      mmc$mmu_aggressive_aging_one   =      10,   { pages }
      mmc$mmu_aggressive_aging_two   =      18,   { pages }
      mmc$mmu_aging_algorithm        =       4,   { flag to select algorithm}
      mmc$mmu_jws_age_interval       = 8000000,   { microseconds }
      mmc$mmu_min_avail_pages        =     800,   { pages }
      mmc$mmu_ps_prestream           =       4,   { page faults}
      mmc$mmu_ps_transfer_size       =       0,   { bytes}{when non-zero, overrides transfer size from DM
      mmc$mmu_ps_threshold           =   65536,   { bytes}
      mmc$mmu_ps_reads               =       3,   { transfer units
      mmc$mmu_ps_random_limit        =       3,   { random page faults
      mmc$mmu_periodic_call_interval = 1000000,   { microseconds }
      mmc$mmu_shared_age_interval    = 8000000,   { microseconds }
      mmc$mmu_swapping_aic           =       1,   { limit on number of times an unused page is swapped out}
      mmc$mmu_tick_time              =  100000,   { microseconds,  Real default is determined in deadstart.
      mmc$mmu_queue_age_task_service =       3,   { number of shared_age_intervals}
      mmc$mmu_queue_age_pf_execute   =       1,   { number of shared_age_intervals}
      mmc$mmu_queue_age_pf_non_exec  =       1,   { number of shared_age_intervals}
      mmc$mmu_queue_age_device_file  =       1,   { number of shared_age_intervals}
      mmc$mmu_queue_age_file_server  =       1,   { number of shared_age_intervals}
      mmc$mmu_queue_age_other        =       1,   { number of shared_age_intervals}
      mmc$mmu_queue_age_site_queues  =       1,   { number of shared_age_intervals}
      mmc$mmu_queue_maximum          =       osc$max_page_frames,  {default maximum pages for all queues}
      mmc$mmu_queue_minimum          =       0;     {default minimum pages for all queues}

*copyc ost$page_table


*DECK DECK=MMC$MOVE_PAGES_MAX_REQ_LENGTH EXPAND=FALSE

  CONST
    mmc$move_pages_max_req_length = 65536;

*DECK DECK=MMC$NULL_SHARED_QUEUE EXPAND=FALSE

  CONST
    mmc$null_shared_queue = 0;
*DECK DECK=MMC$SEGMENT_MANAGER_DEFAULTS EXPAND=FALSE


{  Define constants that are global to the segment manager.

  CONST
    mmc$default_preset_value = 0,
    mmc$default_current_seg_length = 0,
    mmc$default_maximum_seg_length = 7fffffff(16),
    mmc$default_clear_space = FALSE;
*DECK DECK=MMC$SHADOW_ALLOCATION_SIZE EXPAND=FALSE

{ Defines allocation size of shadow files which must be <= allocation size of the shadowed(passive) file.
{ Note: If changed, messages in mmm$segment_manager_job_temp which have text of "16384" should be changed.

  CONST
    mmc$shadow_allocation_size = 4000(16);  {16384}
*DECK DECK=MMD$PDT_MM_PATH_TEST EXPAND=FALSE
{
{  PROCEDURE mm_path_test (name: list of key all,
{    (advise_in ai),
{    (advise_out ao),
{    (advise_out_in aoi),
{    (assign_contiguous_memory, acm)
{    (assign_pages ap),
{    (change_stack_aattribute, csa)
{    (check_io_status cios),
{    (conditional_free cf),
{    (copy_pages cp),
{    (create_scratch_segment css),
{    (create_segment cs),
{    (create_shadow_segment cshs),
{    (create_user_segment cus),
{    (delete_segment, ds)
{    (fetch_pva_unwritten_pages fpup)
{    (fetch_segment_attributes fsa),
{    (get_segment_length gsl),
{    (initiate_debug_shadowing ids),
{    (initiate_shadowing is),
{    (lock_pages lp),
{    (lock_segment ls),
{    (move_pages mp),
{    (null_monitor_request nmr),
{    (pf_disk pfd),
{    (pf_new_file_alloc pfnfa),
{    (pf_new_file_no_alloc pfnfna),
{    (pf_new_no_file pfnnf),
{    (pf_reclaim pfr),
{    (preallocate_file_space, pfs)
{    (process_io_completion pioc),
{    (read r),
{    (set_access_selections sas),
{    (set_segment_length ssl),
{    (store_segment_attributes ssa),
{    (task_switch ts),
{    (verify_access va),
{    (wait_io_completion wic),
{    (write w),
{    (write_modified_pages wmp),
{    (write_modified_pages_no_file wmpnf),
{    keyend
{    scale, s: integer 1 .. 1000 = 1
{    file_type, ft: key (transient t) (permanent, p) keyend = TRANSIENT
{    skip_shadow_tests, sst: boolean = FALSE
{    output, o: file = output)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 81] of clt$keyword_specification,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (9),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type5: record
        header: clt$type_specification_header,
        default_value: string (6),
      recend,
    recend := [
    [1,
    [89, 7, 5, 12, 8, 50, 376],
    clc$command, 9, 5, 0, 0, 0, 0, 0, ''], [
    ['FILE_TYPE                      ',clc$nominal_entry, 3],
    ['FT                             ',clc$abbreviation_entry, 3],
    ['NAME                           ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 5],
    ['OUTPUT                         ',clc$nominal_entry, 5],
    ['S                              ',clc$abbreviation_entry, 2],
    ['SCALE                          ',clc$nominal_entry, 2],
    ['SKIP_SHADOW_TESTS              ',clc$nominal_entry, 4],
    ['SST                            ',clc$abbreviation_entry, 4]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3020,
  clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 9],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 5
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 6]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3004, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [81], [
      ['ACM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['ADVISE_IN                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['ADVISE_OUT                     ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['ADVISE_OUT_IN                  ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['AI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['AO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['AOI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['AP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['ASSIGN_CONTIGUOUS_MEMORY       ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['ASSIGN_PAGES                   ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['CF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
      ['CHANGE_STACK_AATTRIBUTE        ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['CHECK_IO_STATUS                ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['CIOS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
      ['CONDITIONAL_FREE               ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['COPY_PAGES                     ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['CP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
      ['CREATE_SCRATCH_SEGMENT         ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['CREATE_SEGMENT                 ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['CREATE_SHADOW_SEGMENT          ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['CREATE_USER_SEGMENT            ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['CS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
      ['CSA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['CSHS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
      ['CSS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
      ['CUS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
      ['DELETE_SEGMENT                 ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['DS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
      ['FETCH_PVA_UNWRITTEN_PAGES      ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['FETCH_SEGMENT_ATTRIBUTES       ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['FPUP                           ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
      ['FSA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
      ['GET_SEGMENT_LENGTH             ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['GSL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
      ['IDS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
      ['INITIATE_DEBUG_SHADOWING       ', clc$nominal_entry, clc$normal_usage_entry, 19],
      ['INITIATE_SHADOWING             ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['IS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 20],
      ['LOCK_PAGES                     ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['LOCK_SEGMENT                   ', clc$nominal_entry, clc$normal_usage_entry, 22],
      ['LP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 21],
      ['LS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 22],
      ['MOVE_PAGES                     ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['MP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 23],
      ['NMR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 24],
      ['NULL_MONITOR_REQUEST           ', clc$nominal_entry, clc$normal_usage_entry, 24],
      ['PFD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 25],
      ['PFNFA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 26],
      ['PFNFNA                         ', clc$abbreviation_entry, clc$normal_usage_entry, 27],
      ['PFNNF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 28],
      ['PFR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 29],
      ['PFS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 30],
      ['PF_DISK                        ', clc$nominal_entry, clc$normal_usage_entry, 25],
      ['PF_NEW_FILE_ALLOC              ', clc$nominal_entry, clc$normal_usage_entry, 26],
      ['PF_NEW_FILE_NO_ALLOC           ', clc$nominal_entry, clc$normal_usage_entry, 27],
      ['PF_NEW_NO_FILE                 ', clc$nominal_entry, clc$normal_usage_entry, 28],
      ['PF_RECLAIM                     ', clc$nominal_entry, clc$normal_usage_entry, 29],
      ['PIOC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 31],
      ['PREALLOCATE_FILE_SPACE         ', clc$nominal_entry, clc$normal_usage_entry, 30],
      ['PROCESS_IO_COMPLETION          ', clc$nominal_entry, clc$normal_usage_entry, 31],
      ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 32],
      ['READ                           ', clc$nominal_entry, clc$normal_usage_entry, 32],
      ['SAS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 33],
      ['SET_ACCESS_SELECTIONS          ', clc$nominal_entry, clc$normal_usage_entry, 33],
      ['SET_SEGMENT_LENGTH             ', clc$nominal_entry, clc$normal_usage_entry, 34],
      ['SSA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 35],
      ['SSL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 34],
      ['STORE_SEGMENT_ATTRIBUTES       ', clc$nominal_entry, clc$normal_usage_entry, 35],
      ['TASK_SWITCH                    ', clc$nominal_entry, clc$normal_usage_entry, 36],
      ['TS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 36],
      ['VA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 37],
      ['VERIFY_ACCESS                  ', clc$nominal_entry, clc$normal_usage_entry, 37],
      ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 39],
      ['WAIT_IO_COMPLETION             ', clc$nominal_entry, clc$normal_usage_entry, 38],
      ['WIC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 38],
      ['WMP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 40],
      ['WMPNF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 41],
      ['WRITE                          ', clc$nominal_entry, clc$normal_usage_entry, 39],
      ['WRITE_MODIFIED_PAGES           ', clc$nominal_entry, clc$normal_usage_entry, 40],
      ['WRITE_MODIFIED_PAGES_NO_FILE   ', clc$nominal_entry, clc$normal_usage_entry, 41]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, 1000, 10],
    '1'],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['PERMANENT                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['TRANSIENT                      ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'TRANSIENT'],
{ PARAMETER 4
    [[1, 0, clc$boolean_type],
    'FALSE'],
{ PARAMETER 5
    [[1, 0, clc$file_type],
    'output']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$scale = 2,
      p$file_type = 3,
      p$skip_shadow_tests = 4,
      p$output = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;
*DECK DECK=MMD$SEGMENT_ACCESS_CONDITION EXPAND=FALSE
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  CONST
    mmc$sac_read_beyond_eoi  = 1,
    mmc$sac_read_write_beyond_msl  = 2,
    mmc$sac_segment_access_error = 3,
    mmc$sac_key_lock_violation = 4,
    mmc$sac_ring_violation = 5,
    mmc$sac_io_read_error  = 6,
    mmc$sac_no_append_permission = 7,
    mmc$sac_tape_system_failure = 8,
    mmc$sac_file_server_terminated = 9,
    mmc$sac_pf_space_limit_exceeded = 10,
    mmc$sac_tf_space_limit_exceeded = 11,
    mmc$sac_runaway_write = 12;


  TYPE
    mmt$segment_access_condition = record
      identifier: pmt$condition_identifier,
      segment: ^cell,
    recend;

*copyc PMT$CONDITION_IDENTIFIER
*DECK DECK=MMDECC EXPAND=FALSE
?? NEWTITLE := 'MMDECC : MEMORY MANAGER : ''MM'' 0 .. 9999', EJECT ??
*copyc MME$CONDITION_CODES
?? OLDTITLE ??
*DECK DECK=MME$CONDITION_CODES EXPAND=FALSE

  CONST
*IF $true(osv$unix)
    mmc$ = (($INTEGER ('M') * 100(16)) + $INTEGER ('M')) * 10000(16);
*ELSE
    mmc$ = (($INTEGER ('M') * 100(16)) + $INTEGER ('M')) * 1000000(16);
*IFEND

?? NEWTITLE := 'MMDERR : ERROR CODES FOR MEM MGR  0 .. 5999', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    mme$invalid_sfid = mmc$ + 1,
    {F The specified SFID is invalid.}

    mme$page_table_full = mmc$ + 2,
    {F Page table is full.}

    mme$no_free_pages = mmc$ + 3,
    {F There are no free pages.}

    mme$job_file_tables_full = mmc$ + 4,
    {F There are not any free entries in the job file table.}

    mme$page_not_in_page_table = mmc$ + 5,
    {F Page was not found in the page table.}

    mme$invalid_pva = mmc$ + 6,
    {F Invalid PVA specified on the request.}

    mme$unable_to_get_fde_fomp = mmc$ + 7,
    {F Unable to get the file descriptor entry during the
    {   FETCH_OFFSET_MODIFIED_PAGES request.}

    mme$page_frame_not_assigned = mmc$ + 8,
    {F Page frame was not assigned to a page being locked.}

    mme$read_beyond_eoi = mmc$ + 9,
    {F Tried to read beyond EOI on read only segment - PVA = +P, P = +P.}

    mme$io_read_error = mmc$ + 10,
    {F Uncorrected IO error - PVA = +P, P = +P.}

    mme$read_write_beyond_msl = mmc$ + 11,
    {F Tried to read/write beyond maximum segment length - PVA = +P, P = +P.}

    mme$segment_access_error  = mmc$ + 12,
    {F Attempt to access segment with access not granted - PVA = +P, P = +P.}

    mme$computed_asti_out_of_range = mmc$ + 13,
    {F The computed ASTI was out of the range of the image AST; procedure = +P}

    mme$ring_violation = mmc$ + 14,
    {F Not validated to access a segment from the present ring,
    { PVA = +P, P = +P.}

    mme$invalid_ring_brackets = mmc$ + 15,
    {F Invalid ring brackets in the SDTE.}

    mme$binding_attribute_invalid = mmc$ + 16,
    {F Attempt to set the binding attribute from above ring 3.}

    mme$execute_global_invalid = mmc$ + 17,
    {F Execute_global attribute can not be specified.}

    mme$software_attribute_invalid = mmc$ + 18,
    {F Attempt to specify software attribute from beyond ring 3.}

    mme$site_shared_queues_active = mmc$ + 19,
    {E The number of active site shared queues cannot be reduced because
    { at least one site shared queue with an ordinal greater than the
    { specified value has pages assigned.

    mme$invalid_close_segment_req = mmc$ + 20,
    {F Attempt to close/delete segment that is not in callers write bracket
    {  or segment that is not a user segment.}

    mme$caller_not_in_read_bracket = mmc$ + 21,
    {F Caller not in read bracket of segment specified.}

    mme$caller_not_in_write_bracket = mmc$ + 22,
    {F Caller not in write bracket of segment specified.}

    mme$execute_local_invalid = mmc$ + 23,
    {F Attempt to set EXECUTE_LOCAL attribute from above ring 3.}

    mme$set_unmodifiable_attribute = mmc$ + 24,
    {F Attempt to change segment attribute that can not be modified.}

    mme$segment_table_is_full = mmc$ + 25,
    {F Segment table is full.}

    mme$segment_number_is_in_use = mmc$ + 26,
    {F Segment number specified is already in use.}

    mme$segment_number_not_in_use = mmc$ + 27,
    {F Segment number specified is not in use.}

    mme$segment_number_too_big = mmc$ + 28,
    {F Segment number is beyond the range of the segment table.}

    mme$unsupported_keyword = mmc$ + 29,
    {F Keyword specified for the segment attributes is invalid.}

    mme$sdt_or_sdtx_exist = mmc$ + 30,
    {F Attempt to create inherited SDT and SDT or SDTX already exists.}

    mme$no_pages_found_for_move = mmc$ + 31,
    {F No pages which could be moved were found. }

    mme$asid_specified = mmc$ + 32,
    {F ASID specified as attribute and segment manager not called from ring 1.}

    mme$invalid_asid_specified = mmc$ + 33,
    {F The specified ASID is not one of the reserved ASID's.}

    mme$write_uncontrolled_invalid = mmc$ + 34,
    {F Attempt to set WRITE_UNCONTROLLED attribute not allowed.}

    mme$page_already_locked = mmc$ + 35,
    {F Attempt to lock a page that is already locked.}

    mme$segment_not_assigned_device = mmc$ + 36,
    {F Attempt to do IO on a segment with no backing file.}

    mme$unused_error_condition_37 = mmc$ + 37,
    {F Unused}

    mme$not_valid_in_page_table = mmc$ +38,
    {F Page in memory but valid bit not set in page table.}

    mme$stack_overflow_on_push = mmc$ + 39,
    {F Stack overflow on PUSH.}

    mme$invalid_task_id = mmc$ + 40,
    {F The taskid specified on the call is invalid.}

    mme$no_matching_offset = mmc$ + 41,
    {F On subsequent MMP$FETCH_UNWRITTEN_PAGES request, the matching
    {  offset could not be found in the page frame table.}

    mme$invalid_request = mmc$ + 42,
    {F Invalid request code.}

    mme$io_write_error = mmc$ + 43,
    {F Io error on trying to write a page to disk.}

    mme$segment_not_pageable = mmc$ + 44,
    {F Attempt to age out a page in a non pageable segment.}

    mme$segment_origin_invalid = mmc$ + 45,
    {F Attempt to set segment origin from above ring 1.}

    mme$segment_origin_change = mmc$ + 46,
    {F Attempt to modify segment origin.}

    mme$lock_unlock_invalid_length = mmc$ + 47,
    {F Lock/unlock request and length + offset > maximum segment length.}

    mme$unused_error_condition_48 = mmc$ + 48,
    {F Unused}

    mme$page_not_locked = mmc$ + 49,
    {F Request to clear lock and page not locked.}

    mme$exceeds_max_lock_page_count = mmc$ + 50,
    {F Lock page request will exceed maximum locked pages allowed.}

    mme$no_write_access = mmc$ + 51,
    {F Set segment length on segment without write access.}

    mme$lock_ring_1_stack_from_r1 = mmc$ + 52,
    {F Monitor request to lock ring 1 stack issued from ring 1.}

    mme$write_beyond_eoi_no_append = mmc$ + 53,
    {F Write beyond segment eoi with no append permission - PVA = +P, P = +P.}

    mme$unused_error_condition_54 = mmc$ + 54,
    {F Unused}

    mme$segment_locked_by_task = mmc$ + 55,
    {F Segment already locked by current task}

    mme$segment_locked_another_task = mmc$ + 56,
    {F Segment locked by another task}

    mme$segment_not_locked = mmc$ + 57,
    {F Segment not locked by current task}

    mme$temporary_reject = mmc$ + 58,
    {F Resources required to process request are temporarily unavailable}

    mme$nil_io_control_block = mmc$ + 59,
    {F The io control block has not been allocated.}

    mme$full_io_control_block = mmc$ + 60,
    {F The io control block is full.}

    mme$page_found_in_memory = mmc$ + 61,
    {F Page found in memory.}

    mme$pf_space_limit_exceeded = mmc$ + 62,
    {F The maximum permanent file space limit has been exceeded -
    { PVA = +P, P = +P.}

    mme$tf_space_limit_exceeded = mmc$ + 63,
    {F The maximum temporary file space limit has been exceeded -
    { PVA = +P, P = +P.}

    mme$disk_flaws = mmc$ + 64,
    {F Page could not be written to disk because of disk flaws.}

    mme$invalid_io_status_ptrs = mmc$ + 65,
    {F Attempt to check status of io with pointers for which no io
    { has been requested.}

    mme$write_status_complete = mmc$ + 66,
    {F Status of the write request is complete.}

    mme$stack_overflow = mmc$ + 67,
    {F Stack overflow - PVA = +P, P = +P.}

    mme$request_length_too_long = mmc$ + 68,
    {F Length on read/write request exceeds 65536 bytes.}

    mme$invalid_pva_formed = mmc$ + 69,
    {F Offset plus length created an invalid pva.}

    mme$ref_to_unrecovered_file = mmc$ + 70,
    {F The file backing the segment being referenced has not been recovered.}

    mme$length_not_0_mod_16384 = mmc$ + 71,
    {F The length of the shadow file must be a multiple of 16384.}

    mme$address_not_0_mod_16384 = mmc$ + 72,
    {F The starting address of the shadow file must be a multiple of 16384.}

    mme$invalid_shadow_segment = mmc$ + 73,
    {F The specified shadow file is not valid.}

    mme$init_shadow_improper_seg = mmc$ + 74,
    {F The segment specified is not appropriate for shadowing.}

    mme$unused_error_condition_75 = mmc$ + 75,
    {F Unused}

    mme$wired_or_fixed_segs_illegal = mmc$ + 76,
    {F The use of wired or fixed segments prohibited with this request.}

    mme$unused_error_condition_77 = mmc$ + 77,
    {F Unused}

    mme$memory_not_avail_for_assign = mmc$ + 78,
    {F Memory is not currently available for assign_pages request.}

    mme$dm_assign_active = mmc$ + 79,
    {F Backing file is being assigned for the segment.}

    mme$assign_length_too_long = mmc$ + 80,
    {F The length requested would cause the working set to get too large.}

    mme$length_must_be_positive = mmc$ + 81,
    {F The requested length must be positive.}

    mme$wait_so_other_tasks_can_run = mmc$ + 82,
    {F Cause task to wait so other tasks can execute.}

    mme$cannot_wait_for_memory = mmc$ + 83,
    {F Job is non swappable -- cannot wait to assign memory. }

    mme$illegal_segment_origin_chg = mmc$ + 84,
    {F An illegal attempt was made to change the segment origin.}

    mme$invalid_shared_taskid = mmc$ + 85,
    {F An illegal taskid was found either opening or closing a
    { shared stack segment.}

    mme$volume_unavailable = mmc$ + 86,
    {F A reference has been made to a segment on a volume that is
    { not available.}

    mme$unused_error_condition_87 = mmc$ + 87,
    {F Unused}

    mme$wired_seg_length_too_large = mmc$ + 88,
    {F The requested length of the wired segment exceeds 65536 bytes.}

    mme$length_not_page_size_mult = mmc$ + 90,
    {F The requested length on mmp$move_pages must be a page size multiple.}

    mme$pva_not_on_page_boundary = mmc$ + 91,
    {F The specified pvas on mmp$move_pages must be on a page boundary.}

    mme$unused_error_condition_92 = mmc$ + 92,
    {F Unused}

    mme$modified_source_page_reject = mmc$ + 93,
    {F Source page was modified on mmp$move_pages_request.}

    mme$source_page_not_in_memory = mmc$ + 94,
    {F Source page not in memory on mmp$move_pages request.}

    mme$invalid_length_requested = mmc$ + 95,
    {F Length is greater than maximum allowed or less than minimum allowed.}

    mme$io_active_on_move_page = mmc$ + 96,
    {F Source page had io active om mmp$move_pages request.}

    mme$unsupported_segment_kind = mmc$ + 97,
    {F Interface does not support segments of this kind--must be mmc$sk_file.}

    mme$unused_error_condition_98 = mmc$ + 98,
    {F Unused}

    mme$invalid_seg_for_prealloc = mmc$ + 99,
    {F The segment must be assigned a file for preallocation to occur.}

    mme$contig_mem_seg_violation = mmc$ + 100,
    {F Segment must be either wired or job_fixed to assign contiguous memory.}

    mme$unable_to_assign_contig_mem = mmc$ + 101,
    {F Unable to allocate the requested amount of contiguous memory.}

    mme$pages_already_assigned = mmc$ + 102,
    {F Pages within the range (PVA-->PVA+length) are already assigned.}

    mme$update_req_write_permission = mmc$ + 103,
    {F Updating the passive segment requires write permission.}

    mme$unused_error_condition_104 = mmc$ + 104,
    {F Unused}

    mme$cant_shadow_transient_segs = mmc$ + 105,
    {F Transient segments can not be shadowed.}

    mme$file_server_terminated = mmc$ + 106,
    {F The segment is located on a terminated file_server and therefore it..
    {  cannot be accessed - PVA = +P, P = +P.}

    mme$preallocate_failed = mmc$ + 107,
    {F The mmp$preallocate_file_space request could not be completed normally.

    mme$unable_to_assign_fde = mmc$ + 108,
    {F A file descriptor entry could not be assigned for this segment.

    mme$no_io_active = mmc$ + 109,
    {F The task has no asynchronous io active.

    mme$last_error_code = mmc$ + 5998;
    {F Dummy error code to eliminate feature conflicts. }
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=MMH$ADD_SDT_SDTX_ENTRY EXPAND=FALSE

{
{   The purpose of this procedure is to add the SDT and SDTX entries to the
{ SDT and the SDTX tables respectively.  The caller can specify a segment
{ number to use or this procedure will use the first available one.
{
{        MMP$ADD_SDT_SDTX_ENTRY (SDT_ENTRY, SDTX_ENTRY, FDE_ENTRY,
{          SHARED_TASKID_ARRAY, SEGMENT_NUMBER, STATUS)
{
{ SDT_ENTRY: (input) This parameter is the SDT entry to be added to the
{        SDT table.
{
{ SDTX_ENTRY: (input) This parameter is the SDTX entry to be added to the
{        SDTX table.
{
{ FDE_ENTRY: (input) This parameter is the FDE entry for the segment being
{        added.
{
{ SHARED_TASKID_ARRAY: (input) This parameter specifies the list of task-ids
{        in which this segment should be added. Currently, the only user of
{        this capability is ADA-TASKING. All other callers should pass a NIL
{        pointer for this parameter.
{
{ SEGMENT_NUMBER: (input) This parameter specifies the segment number which
{        the user passed or the system assigned for this instance of open.
{
{ STATUS: (output) This parameter is where the request status is returned
{        to the caller.
{              dme$unable_to_locate_fde
{              dme$unable_to_get_fd_lock
{              mme$contig_mem_seg_violation
{              mme$invalid_length_requested
{              mme$invalid_pva
{              mme$invalid_ring_brackets
{              mme$invalid_shared_taskid
{              mme$pages_already_assigned
{              mme$ref_to_unrecovered_file
{              mme$ring_violation
{              mme$segment_number_is_in_use
{              mme$segment_number_not_in_use
{              mme$segment_number_too_big
{              mme$segment_origin_invalid
{              mme$segment_table_is_full
{              mme$unable_to_assign_contig_mem
{




*DECK DECK=MMH$ADVISE_IN EXPAND=FALSE
{
{   The purpose of this request is to advise the OS of intended
{ access to a portion of a segment.  This request is intended to
{ allow a user to assist memory manager in managing memory.  If the
{ system load is high, memory manager may ignore this request.
{
{   This request is equivalent to a "buffered page fault" for the
{ portion of a segment defined by <pointer> to <pointer> + <length>.
{ For each page containing addresses in the above range, memory
{ manager does the following:
{ - if the page is already in the Job Working Set (JWS), the page
{   age is reset to zero.
{ - if the page is in memory but has been aged out of the JWS,
{   the page is moved back to JWS and the page age is set to zero.
{ - if the page is on disk, an IO request is issued to read the
{   page into memory and add it to the JWS.
{ - if the page is not on disk (never referenced or above eoi),
{   then an available page frame is assigned, initialized, and
{   added to the JWS.
{
{   Although not stated above, memory manager will attempt to issue
{ IO requests in units of 1 transfer unit.  It should be noted
{ that the above algorithm is subject to change as a result of
{ system performance studies.
{
{       MMP$ADVISE_IN (PVA, LENGTH, STATUS)
{
{ PVA: (input) This parameter specifies the start of the range
{       of memory to be advised in.
{
{ LENGTH: (input) This parameter specifies the number of bytes to
{       be advised in.
{
{ STATUS: (output) This parameter specifies the request status.
{       The possible error codes are:
{             mme$file_server_terminated
{             mme$invalid_pva
{             mme$read_beyond_eoi
{             mme$read_write_beyond_msl
{             mme$ref_to_unrecovered_file
{             mme$write_beyond_eoi_no_append
{
*DECK DECK=MMH$ADVISE_OUT EXPAND=FALSE
{
{   The purpose of this request is to advise the OS that access
{ to a portion of memory is finished (for a while).  This request
{ is intended to allow a task to assist memory manager in managing
{ the working set.  If the system load is high, memory manager
{ may ignore this request.
{
{   For each page totally or partially contained within the portion of the
{ segment defined by <pointer> to <pointer> + <length>, memory
{ manager does the following:
{ -If the page is in the JWS and has not been modified,
{  the page is removed from the JWS and placed in the 'available'
{  page queue.
{ -If the page is in the JWS and has been modified, the page
{  is removed from the JWS and placed in the 'available-modified'
{  queue.
{
{   It should be noted that the above algorithm is subject to change
{ as a result of system performance studies.
{
{       MMP$ADVISE_OUT (PVA, LENGTH, STATUS)
{
{ PVA: (input) This parameter specifies the start of the range
{       memory to be advised out.
{
{ LENGTH: (input) This parameter specifies the number of bytes
{       to be advised out.
{
{ STATUS: (output) This parameter specifies the request status.
{       The possible error codes are:
{             mme$invalid_pva
{             mme$ref_to_unrecovered_file
{             mme$segment_not_pageable
{
*DECK DECK=MMH$ADVISE_OUT_IN EXPAND=FALSE
{
{   The purpose of this request is to advise the OS that
{ access to a portion of memory is finished (for a while) and
{ that access to a different portion of memory is intended.
{ This request is functionally equivalent to MMP$ADVISE_OUT
{ followed by a MMP$ADVISE_IN, both which has less overhead.
{
{       MMP$ADVISE_OUT_IN (OUT_PVA, OUT_LENGTH, IN_PVA,
{         IN_LENGTH, STATUS)
{
{ OUT_PVA: (input) This parameter specifies the start
{       of memory to be advised out.
{
{ OUT_LENGTH: (input) This parameter specifies the number of
{       of bytes to be advised out.
{
{ IN_PVA: (input) This parameter specifies the start of
{       the range of memory to be advised in.
{
{ IN_LENGTH: (input) This parameter specifies the number of
{       bytes to be advised in.
{
{ STATUS: (output) This parameter specifies the request status.
{       The possible error codes are:
{             mme$file_server_terminated
{             mme$invalid_pva
{             mme$read_beyond_eoi
{             mme$read_write_beyond_msl
{             mme$ref_to_unrecovered_file
{             mme$segment_not_pageable
{             mme$write_beyond_eoi_no_append
{
*DECK DECK=MMH$ASSIGN_CONTIGUOUS_MEMORY EXPAND=FALSE
{
{   The purpose of this request is to allocate contiguous pages
{ for a specified segment. Contiguous pages will only be provided
{ for wired or fixed (job_fixed ONLY) segments. A maximum of 65536
{ contiguous bytes can be assigned to a segment.
{
{     MMP$ASSIGN_CONTIGUOUS_MEMORY (process_virtual_address,
{            contiguous_mem_length, status)
{
{  PROCESS_VIRTUAL_ADDRESS: (input) This parameter specifies the
{      address of the segment to which the contiguous memory is
{      to be assigned to.
{
{  CONTIGUOUS_MEMORY_LENGTH: (input) This parameter is the amount
{      of contiguous memory the user is requesting. A maximum
{      of 65536 bytes is allowed.
{
{  STATUS: (output) This parameter specifies the request status.
{
{
*DECK DECK=MMH$ASSIGN_DEVICE_SHARED_SEGS EXPAND=FALSE
{
{   The purpose of this request is to assign a device to all segments
{ with the 'mmc$sa_shared' software attribute.
{
{       MMP$ASSIGN_DEVICE_SHARED_SEGS (STATUS)
{
{ STATUS: (output) This parameter is where the request status is returned.
{
*DECK DECK=MMH$ASSIGN_DEVICE_TO_SEGMENT EXPAND=FALSE
{
{   The purpose of this request is to assign a device to a segment.
{ This procedure must be called by procedures that issue explicit
{ memory manager requests.   This procedure provides an interface
{ to segment manager when the caller is running beyond ring 3.
{
{       MMP$ASSIGN_DEVICE_TO_SEGMENT (PVA, STATUS)
{
{ PVA: (input) This parameter specifies the segment to which a
{       device should be assigned.
{
{ STATUS: (output) The request status is returned in this parameter.
{
*DECK DECK=MMH$ASSIGN_MASS_STORAGE EXPAND=FALSE
{
{   The purpose of this procedure is to assign mass storage to
{ the segment specified. If this is the initial mass storage
{ assignment for this segment, device management will assign
{ a disk_file_descriptor to this segment, and the media field
{ of the file_descriptor_entry for this segment will be modified
{ from gfc$fm_transient_segment to gfc$fm_mass_storage_file.
{
{   MMP$ASSIGN_MASS_STORAGE (segment_number, minimum_allocation_length, status)
{
{ SEGMENT_NUMBER: (input) This parameter specifies the segment number of
{        the segment which requires disk space allocation.
{
{ MINIMUM_ALLOCATION_LENGTH: (input) This parameter specifies the minimum
{        amount of space which needs to be allocated.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=MMH$ASSIGN_PAGES EXPAND=FALSE

{ The purpose of this request is to to insure that a specified
{ portion of a segment exists in real memory.  When the request completes,
{ all pages totally or partially contained by the range of addresses
{ specified by <pva> to <pva>+<length>-<1> will be assigned real memory.
{ The pages will be marked as recently used to reduce the odds of
{ having them removed from memory via aging; however, there is no
{ guarantee that the pages will still be in memory when the user
{ references them.  Pages totally contained within the range of memory
{ will not be read in from disk, but partially contained pages will be.
{ If the caller sets preset_pages to true, all bytes within the range
{ will be preset to the preset value for the segment (note cautions below).
{ The caller has the option of waiting for the request to complete; if the
{ caller waits, but the memory required to honor the request is not
{ available, the job may be swapped out until the memory becomes available.
{
{      MMP$ASSIGN_PAGES (PVA, LENGTH, PRESET_PAGES, STATUS)
{
{ PVA: (input) This parameter specifies the beginning address of the
{      portion of the segment the caller wants assigned.
{
{ LENGTH: (input) This parameter specifies the number of bytes the caller
{      wants assigned real memory.  If the length is enough to cause
{      a request to span a segment boundary, then the condition
{      mme$invalid_pva_formed will be returned.  If the number of
{      pages needed to be assigned to satisfy the request plus the
{      number of pages already in the job's working set will
{      be greater than the maximum working set allowed for the job, the
{      request will be rejected with the error mme$assign_length_too_long.
{
{ PRESET_PAGES: (input) This parameter specifies whether the caller wants
{      the pages of the segment to be preset to the preset value for the
{      segment.
{      *******
{      NOTE -- (PRESET_PAGES = TRUE) MAY DEGRADE PERFORMANCE
{      If TRUE is specified all bytes within the range specified will
{      be initialized to the preset value for the segment.  Specifying
{      TRUE may have a negative performance impact.  A page that is
{      preset because the caller specified to do so will be marked
{      as modified; if the page ages out of the working set it
{      will be written to disk.
{      *******
{      If FALSE is specified and the request is issued at or below ring 3
{      but the segment cannot be read from above ring 3, new pages
{      assigned will be initialized to the preset value, but the pages
{      will not be written to disk if they age out of memory.
{
{ WAIT: (input) This parameter specifies whether to wait for completion
{      of the request or to return to the user immediately if the
{      memory needed to assign the pages is not readily available.
{      If the caller wants to wait for the request to complete
{      and memory is not available right away, the job will be swapped
{      out until the required memory becomes available.  If the caller
{      does not want to wait, and memory is not available, the error
{      mme$memory_not_available will be returned.  If wait is true
{      and memory is not available, but the job is non-swappable,
{      the error mme$cannot_wait_for_memory will be returned.
{
{ STATUS: (output) This parameter specifies the request status.
{      Possible error codes are:
{        mme$length_must_be_positive
{        mme$invalid_pva_formed
{        mme$memory_not_avail_for_assign
{        mme$cannot_wait_for_memory
{        mme$assign_length_too_long
{
{
{  PROCEDURE [XREF] mmp$assign_pages (pva: ^cell;
{        length: ost$segment_length;
{        preset_pages: boolean;
{        wait: ost$wait;
{    VAR status: ost$status);
*DECK DECK=MMH$ASSIGN_PAGE_TO_MONITOR EXPAND=FALSE
{
{ The purpose of this request is to assign pages of real memory to the
{ address space of monitor. If the page frames cannot be assigned because
{ no memory is available or because of a 'page table full' condition,
{ the request will be rejected. If the PVA is
{ invalid or a page is already assigned, a system error halt will occur.
{ Pages are NOT preset.
{
{      MMP$ASSIGN_PAGE_TO_MONITOR (P, PAGE_COUNT, PRESET, STATUS)
{
{   P: (INPUT) This parameter specifies the page to be assigned
{
{   PAGE_COUNT: (INPUT) This parameter specifies the number of pages to assign.
{
{   PRESET: (INPUT) This parameter is a boolean value specifying whether or
{                     not the pages should be preset.
{
{   STATUS: (OUTPUT) This parameter specifies request status
{
*DECK DECK=MMH$BUILD_LOCK_RMA_LIST EXPAND=FALSE
{ This request is used by physical IO to lock one or more page frames
{ before doing IO to the page frames. Page frames being accessed by
{ the IOU must be locked to prevent memory manager from reassigning the
{ page frame while IO is active. If page frames are not assigned to
{ the entire range of addresses specified in the request, no frames
{ will be locked and an error code will be returned.
{ The 'active_io_page_count' for the job owning the page frames is incremented.
{ The 'inhibit_swap_count' is incremented if the IO is not a write to a
{ local file.  The counts are decremented when the page frames are unlocked.
{
{   NOTE:  ALL pages locked MUST belong to the same segment.
{          THE LIST THAT IS LOCKED MUST BE THE SAME LIST THAT IS UNLOCKED.
{          64K byte page size is not currently supported.
{
{     MMP$BUILD_LOCK_RMA_LIST (BUFFER_DESCRIPTOR, LENGTH, IO_TYPE, LIST_P,
{               LIST_LENGTH, STATUS);
{
{  BUFFER_DESCRIPTOR: (input) This parameter specifies the pages of memory
{         to be locked.  All pages must belong to the same segment.
{  LENGTH: (input) This parameter specifies the number of bytes to be
{         locked.
{  IO_TYPE: (input) This parameter specifies the type of IO that will
{         take place into the page frames.
{  LIST_P: (input) This parameter points to an array into which this
{         procedure returns a list of the real memory addresses (RMA) of
{         the pages locked. One entry is required in this list for
{         each page frame containing portions of the area being
{         locked.  The list that is locked by mmp$build_lock_rma_list
{         must be the same list that is unlocked by mmp$unlock_rma_list.
{         Several locked lists CANNOT be grouped together to be unlocked
{         by mmp$unlock_rma_list.
{  LIST_LENGTH: (input) This parameter specifies the number of entries
{         in the RMA list. If the length of the RMA list exceeds the
{         length required, the 'length' field in the unused RMA list
{         entries will be set to zero. If the rma list is not large enough, a
{         fatal monitor abort will occur.
{  STATUS: (output) This parameter specifies the request status.
{         The only error code returned is mme$page_frame_not_assigned.
{         All other errors will result in a call to mtp$error_stop.
{

*DECK DECK=MMH$BUILD_SEGMENT EXPAND=FALSE
{
{    The purpose of this request is to build an SDT, SDTX, and FDE entry
{ for this segment. If the segment already is assigned an FDE entry, a new
{ one is not assigned. A new SDT and SDTX entry is built for every instance
{ of OPEN of a segment.
{
{    MMP$BUILD_SEGMENT (attrib_p, shared_taskid_array, segment_pointer, status)
{
{ ATTRIB_P: (input) This parameter specifies the user-selected segment attributes,
{      the open_validating_ring, the file_limits_to_enforce, and the pointer_kind
{      to be used in the creation of this segment.
{
{ SHARED_TASKID_ARRAY: (input) This parameter specifies a pointer to the list
{      of taskids of tasks in which the segment should be opened.
{
{ SEGMENT_POINTER: (output) This parameter returns the segment pointer to the newly
{      opened segment. A NIL pointer is returned if the request was unsuccessful.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=MMH$CHANGE_SEGMENT_INHERITANCE EXPAND=FALSE
{
{   The purpose of this request is to change the segment inheritance of the
{ specified segment. Only segments of inheritance mmc$si_none can be modified
{ with this request.
{
{    MMP$CHANGE_SEGMENT_INHERITANCE (segment_pointer, segment_inheritance, status)
{
{ SEGMENT_POINTER: (input) This parameter specifies the process_virtual_address of
{          the segment which is to be changed.
{
{ SEGMENT_INHERITANCE: (input) This parameter specifies the new segment inheritance.
{          The only valid inheritances for this request are mmc$si_share_segment and
{          mmc$si_transfer_segment.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=MMH$CHANGE_SEGMENT_NUMBER EXPAND=FALSE
{
{  The purpose of this request is to associate a previously opened
{ file with a different segment number. The old segment is deleted
{ when the new segment number has been assigned.
{
{     MMP$CHANGE_SEGMENT_NUMBER (segment_pointer, segment_number,
{       validation_ring_number, new_segment_pointer, status);
{
{ Segment_pointer: (INPUT) This parameter specifies the process virtual
{    address of the segment.
{
{ Segment_number: (INPUT) This parameter is the new segment number
{    to be associated with the file.
{
{ Validation_ring_number: (INPUT) This parameter specifies the ring
{    of execution for whom the segment is being modified. The ring
{    number used for validation is the maximum of the caller ring
{    number and the 'validation_ring_number'.
{
{ New_segment_pointer: (OUTPUT) This parameter specifies the process
{    virtual address of the file with the new segment number.
{
{ Status: (OUTPUT) This parameter specifies the request status.
{    CONDITIONS:
{         mme$ring_violation
{         mme$unsupported_segment_kind
{    IDENTIFIER: 'MM'
{

*DECK DECK=MMH$CHANGE_STACK_ATTRIBUTE EXPAND=FALSE

{  The purpose of this request is to modify the stack attribute
{  which determines whether or not the pages beyond the current
{  top-of-stack pointer are freed. Only the stack of the caller ring
{  can be modified by this request.
{
{  MMP$CHANGE_STACK_ATTRIBUTE (stack_pages_to_be_freed, status);
{
{   STACK_PAGES_TO_BE_FREED: (INPUT, BOOLEAN) This parameter specifies
{      whether or not the pages beyond the current top-of-stack are freed.
{
{   STATUS: (OUTPUT, OST$STATUS) The request status is returned in this
{   parameter.
{
*DECK DECK=MMH$CHECK_IF_PAGES_IN_MEMORY EXPAND=FALSE
{
{ The purpose of this procedure is to verify that a portion of a segment
{ specified by <pva> to <pva>+<length> exists in real memory.
{
{      MMP$CHECK_IF_PAGES_IN_MEMORY (PVA, LENGTH, IN_MEMORY)
{
{ PVA: (input) This parameter specifies the beginning address of the
{      pages the caller wishes to check.
{
{ LENGTH: (input) This parameter specifies the number of bytes to be checked.
{
{ IN_MEMORY: (output) This parameter specifies whether the pages exist in
{      real memory (TRUE), or do not exist in real memory (FALSE).
{
*DECK DECK=MMH$CHECK_IO_COMPLETIONS EXPAND=FALSE
{------------------------------------------------------------------------------}
{   The purpose of this request is to update the status of all previously
{ initiated MMP$READ and MMP$WRITE requests that have completed but have not
{ yet had the user I/O status block updated with the completion information.
{ This request will be substantially faster than MMP$CHECK_IO_STATUS from both
{ the system and user perspective, because of the use of timestamps to control
{ whether to scan active I/O requests for completions and because the user does
{ not need to specify certain I/O status variables to be checked.
{   The user may specify that the calling task wait a specified amount of time
{ if no I/O requests have completed.
{   This procedure can only be called from ring 6 or below.
{
{   MMP$CHECK_IO_COMPLETIONS (TIMESTAMP, WAIT_TIME, STATUS)
{
{   TIMESTAMP: (input)  This parameter specifies a 'FREE RUNNING CLOCK'
{     value.  If the request specifies a WAIT_TIME and any I/O request has
{     completed since the value of the TIMESTAMP, the wait will be inhibited
{     and control will be returned to the user.
{
{   WAIT_TIME: (input)  This parameter specifies the maximum amount of time the
{     task should wait for an I/O completion.  If the value of this parameter
{     is zero, control will be returned to the user immediately.
{     The wait time is specified in milliseconds.
{
{   STATUS: (output)  This parameter specifies the request status.  Possible
{     error codes are:
{       mme$no_io_active (attempt to wait for I/O, but no I/O active).
{------------------------------------------------------------------------------}
*DECK DECK=MMH$CHECK_IO_STATUS EXPAND=FALSE
{
{ The purpose of this request is to update an array of iostatus variables of
{ previously initiated MMP$READ AND MMP$WRITE requests.  The
{ MMP$CHECK_IO_STATUS updates all iostatus variables that were not
{ previously updated as complete.  The user may specify that the calling
{ task wait a specified amount of time if no input or output requests
{ have completed.  A call to this procedure cannot come from above ring 6.
{
{      MMP$CHECK_IO_STATUS (STATUS_POINTER_ARRAY, WAIT_TIME, INDEX,
{         STATUS)
{
{
{  STATUS_POINTER_ARRAY: (input) This parameter specifies an array of
{      pointers to iostatus variables to be checked. NIL pointers in
{      this array are acceptable and indicate an empty position in
{      the array.
{
{  WAIT_TIME: (input) This parameter specifies the maximum amount of
{      time to wait for an IO completion if no iostatus variables have
{      io-complete status set.  If the value of this parameter is zero
{      then no wait will be done and control will be returned
{      immediately. The wait_time is specified in milliseconds.
{
{  INDEX: (output) This parameter specifies the index of the first
{      iostatus in the status_pointer_array that has io complete.
{      The value of this parameter is set to zero if no io has
{      completed.
{
{  STATUS: (output) This parameter specifies the request status.
{       Possible error codes are:
{         mme$nil_io_control_block (attempt to check the status of a
{           request when no asynchronous requests have been issued)
{         mme$invalid_io_status_ptrs (attempt to check the status of a
{           request and wait for completion using a pointer to a status
{           variable that has not been used for an asynchronous request)
{         error codes for mmp$read
{         error codes for mmp$write
{
*DECK DECK=MMH$CLOSE_ASID_BASED_SEGMENT EXPAND=FALSE
{
{    This procedure is designed to be used to remove a segment from a segment table when
{ the segment accessability is based upon the ASID of the segment. This is specifically
{ relevant to the SSR segment when adding it to a user job as in the case of MALET/VE.
{
{    MMP$CLOSE_ASID_BASED_SEGMENT (segment_number, status)
{
{ SEGMENT_NUMBER: (input) This parameter specifies the segment number of the segment
{         which is to be closed.
{
{ STATUS: (output) This parameter is the request status.
{
*DECK DECK=MMH$CLOSE_DEVICE_FILE EXPAND=FALSE
{
{    The purpose of this request is to close a device file.
{ The SDT entry is invalidated. There is no attempt to free the
{ memory associated with the segment or to destroy the file (if
{ a file exists).
{
{   MMP$CLOSE_DEVICE_FILE (segment_number, status)
{
{ SEGMENT_NUMBER: (input) This parameter specifies the segment number
{         of the segment to be closed.
{
{ STATUS: (output) This parameter specifies the status of the request.
{
*DECK DECK=MMH$CLOSE_SEGMENT EXPAND=FALSE
{
{   The purpose of this request is to close/delete a segment.  If the
{ caller is not within the read bracket of the segment being closed the
{ call is rejected.
{
{       MMP$CLOSE_SEGMENT (POINTER, VALIDATION_RING_NUMBER, STATUS)
{
{ POINTER: (input_output) This parameter specifies the segment
{       to be deleted.  This pointer will be set to NIL when the
{       request completes.
{
{ VALIDATION_RING_NUMBER: (input) This parameter specifies the ring of
{       execution for whom the segment is being closed.  The ring
{       number used for validation is the max of the caller ring number
{       and 'validation_ring_number'.
{
{ STATUS: (output) This parameter specifies the request status.
{       The possible error codes are:
{             dme$file_descriptor_not_deleted
{             mme$invalid_close_segment_req
{             mme$invalid_shared_taskid
{             mme$segment_number_not_in_use
{             mme$segment_number_too_big
{
*DECK DECK=MMH$CLOSE_SHARED_STACK EXPAND=FALSE
{
{     The purpose of this request is to close/delete a stack segment
{ being used by ADA tasks.
{
{ MMP$CLOSE_SHARED_STACK (POINTER, SHARED_TASKID_ARRAY, STATUS)
{
{ POINTER: (INPUT/OUTPUT) This parameter specifes the segment to
{                         be deleted. This pointer will be set to
{                         NIL when the request completes.
{
{ SHARED_TASKID_ARRAY: (INPUT) This paramter specifies the array
{                              of taskids for the tasks in which
{                              this segment is being closed/deleted.
{
{ STATUS: (OUTPUT) This parameter specifies the request status.
{
*DECK DECK=MMH$COMMIT_MEMORY EXPAND=FALSE
{
{   This procedure is called immediately after closing
{and detaching the image file.  It initializes the request
{block and makes the call to monitor.  In monitor, the page table
{is scanned from the deadstart upper bound to the upperbound, and
{page frame table entries are linked onto the free page queue.
{
*DECK DECK=MMH$CONDITIONAL_FREE EXPAND=FALSE

{   The purpose of this request is to conditionally free pages assigned
{ to a segment.  All pages which are fully contained within the portion
{ of the segment defined by <pva> to <pva>+<length-1> will have the modified
{ bit cleared to prevent writing the pages to disk.  The pages will remain
{ in the job's working set though, in case they are needed again right
{ away.  The pages will be moved from the job working set to the free
{ queue via aging when they are no longer being used.  The user must have
{ write access to the segment.
{
{   NOTE:  This request is intended to be used to prevent modified pages
{ from being written to disk, but to leave the pages in the job working
{ set so they can be used again.  If the caller knows the pages are no
{ longer needed, the interface MMP$FREE_PAGES should be used.
{
{      MMP$CONDITIONAL_FREE (PVA, LENGTH, STATUS)
{
{ PVA: (input) This parameter specifies the beginning address of the
{      portion of the segment the caller wants freed.
{
{ LENGTH: (input) This parameter specifies the number of bytes the caller
{      wants freed.  If the length is enough to cause a request to
{      span a segment boundary, then the condition
{      mme$invalid_pva_formed will be returned.
{
{ STATUS: (output) This parameter specifies the request status.
{      Possible error codes are:
{        mme$length_must_be_positive
{        mme$invalid_pva_formed
{
{
{  PROCEDURE [XREF] mmp$conditional_free (pva: ^cell;
{        length: ost$segment_length;
{    VAR status: ost$status);
{

*DECK DECK=MMH$CREATE_INHERITED_SDT EXPAND=FALSE
{
{   The purpose of this request is to create the SDT and SDTX for a
{ new task. All valid segments with an SDTX.INHERITANCE of mmc$si_share_segment
{ in the parent's SDTX are inherited by the new task. For segments in the parent's
{ SDTX with an inheritance of mmc$si_new_segment, a new segment is created in the
{ new task (these are primarily the task template segments). All segments in the
{ parent's SDTX with a segment reservation of mmc$srs_reserved_shared_stack
{ are inherited, regardless, of whether or not the segment is valid.
{
{   The ASID and ASTI of inherited segments are zeroed out. These values
{ may be copied into the child's segment table during a later phase of
{ task initiation, in the procedure MMP$CREATE_TASK.
{
{       MMP$CREATE_INHERITED_SDT (TASK_ID, STATUS)
{
{ TASK_ID: (input) This parameter identifies the task being created.
{
{ STATUS: (output) The request status is returned in this parameter.
{       The possible error codes are:
{             mme$invalid_task_id
{             mme$sdt_or_sdtx_exists
{
*DECK DECK=MMH$CREATE_SCRATCH_SEGMENT EXPAND=FALSE
{
{   The purpose of this request is to create a scratch segment.
{   Scratch segments are temporary segments that have no name and
{   exist only until deleted via the mmp$delete_scratch_segment request,
{   or until the creating task terminates.
{
{      MMP$CREATE_SCRATCH_SEGMENT (POINTER_KIND, ACCESS_SELECTIONS,
{            POINTER, STATUS)
{
{ POINTER_KIND: (input) This parameter specifies the type of pointer
{       to be constructed for the segment.
{
{ ACCESS_SELECTIONS: (input) This parameter specifies the mode of
{       access to the segment (sequential or random).
{
{ POINTER: (output) This parameter specifies the process virtual
{       address assigned to the segment.  The byte offset in the PVA
{       is set to zero.
{
{ STATUS: (output) This parameter specifies the request status.
{       The possible error codes are:
{             dme$unable_to_locate_fde
{             dme$unable_to_get_fd_lock
{             mme$address_not_0_mod_16384
{             mme$asid_specified
{             mme$binding_attribute_invalid
{             mme$contig_mem_seg_violation
{             mme$execute_global_invalid
{             mme$invalid_asid_specified
{             mme$invalid_length_requested
{             mme$invalid_pva
{             mme$invalid_ring_brackets
{             mme$invalid_shadow_segment
{             mme$invalid_shared_taskid
{             mme$length_not_0_mod_16384
{             mme$pages_already_assigned
{             mme$ref_to_unrecovered_file
{             mme$ring_violation
{             mme$segment_number_is_in_use
{             mme$segment_number_not_in_use
{             mme$segment_number_too_big
{             mme$segment_origin_change
{             mme$segment_origin_invalid
{             mme$segment_table_is_full
{             mme$software_attribute_invalid
{             mme$unable_to_assign_contig_mem
{             mme$unsupported_keyword
{

*DECK DECK=MMH$CREATE_SEGMENT EXPAND=FALSE
{
{   The purpose of this request is to create a transient segment.
{
{       MMP$CREATE_SEGMENT (SEG_ATTRIBUTES_P, POINTER_KIND,
{         VALIDATION_RING_NUMBER, POINTER, STATUS)
{
{ SEG_ATTRIBUTES_P: (input) This parameter is a pointer to the array of segment
{       attributes to be assigned to the segment.
{
{ POINTER_KIND: (input) This parameter specifies the type of pointer
{       to be constructed for the segment.
{
{ VALIDATION_RING_NUMBER: (input) This parameter specifies the ring of
{       execution for whom the segment is being created.  The ring
{       number used for validation is the max of caller ring number
{       and 'validation_ring_number'.
{
{ POINTER: (output) This parameter specifies the process virtual
{       address assigned to the segment.  The byte offset in the PVA
{       is set to zero
{
{ STATUS: (output) This parameter specifies the request status.
{       The possible error codes are:
{             dme$unable_to_locate_fde
{             dme$unable_to_get_fd_lock
{             mme$address_not_0_mod_16384
{             mme$asid_specified
{             mme$binding_attribute_invalid
{             mme$contig_mem_seg_violation
{             mme$execute_global_invalid
{             mme$invalid_asid_specified
{             mme$invalid_length_requested
{             mme$invalid_pva
{             mme$invalid_ring_brackets
{             mme$invalid_shadow_segment
{             mme$invalid_shared_taskid
{             mme$length_not_0_mod_16384
{             mme$pages_already_assigned
{             mme$ref_to_unrecovered_file
{             mme$ring_violation
{             mme$segment_number_is_in_use
{             mme$segment_number_not_in_use
{             mme$segment_number_too_big
{             mme$segment_origin_invalid
{             mme$segment_table_is_full
{             mme$software_attribute_invalid
{             mme$unable_to_assign_contig_mem
{             mme$unsupported_keyword
{

*DECK DECK=MMH$CREATE_SHADOW_SEGMENT EXPAND=FALSE
{
{   The purpose of this request is to create a transient segment that uses the
{ ACTIVE file of an existing segment as a PASSIVE file.
{
{    MMP$CREATE_SHADOW_SEGMENT (shadow_pva, shadow_offset, shadow_length,
{           pointer_kind, pva, status);
{
{ SHADOW_PVA :(input) This parameter specifies the segment pointer of the
{      segment to be shadowed.
{
{ SHADOW_OFFSET: (input) This parameter specifies the byte offset within the
{      segment from which to start shadowing.
{
{ SHADOW_LENGTH: (input) This parameter specifies the length of portion in
{      segment to be shadowed.
{
{ POINTER_KIND: (input) This parameter specifies the type of pointer to be
{      constructed for the segment.
{
{ PVA: (output) This parameter returns the process virtual address of the
{      transient segment.
{
{ STATUS: (output) This parameter specifies the request status returned.
{


*DECK DECK=MMH$CREATE_SHARED_STACK EXPAND=FALSE
{
{    The purpose of this request is to create a stack segment to be
{ used by ADA tasks.
{
{ MMP$CREATE_SHARED_STACK (SEG_ATTRIBUTES_P, POINTER_KIND,
{   SHARED_TASKID_ARRAY, POINTER, STATUS)
{
{ SEG_ATTRIBUTES_P: (INPUT) This parameter is a pointer to the array of segment
{                           attributes to be assigned to the segment.
{
{ POINTER_KIND: (INPUT) This parameter specifies the type of pointer to
{                       be constructed for the segment.
{
{ SHARED_TASKID_ARRAY: (INPUT) This parameter specifies the array of taskids
{                              for the tasks in which this segment is being opened.
{
{ POINTER: (OUTPUT) This parameter specifies the process virtual address assigned
{                   to the segment. The byte offset in the PVA is set to zero.
{
{ STATUS: (OUTPUT) This parameter specifies the request status.
{
*DECK DECK=MMH$CREATE_USER_SEGMENT EXPAND=FALSE

{ The purpose of this request is to create a transient segment.
{
{  MMP$CREATE_USER_SEGMENT (segment_attributes_p, pointer_kind, access_selections,
{          pointer, status)
{
{   SEGMENT_ATTRIBUTES_P: (INPUT) This parameter is a pointer to an array
{          of segment_attributes to be assigned to the segment.
{
{   POINTER_KIND: (INPUT) This parameter specifies the type of pointer
{          to be constructed for the segment.
{
{   ACCESS_SELECTIONS: (INPUT) This parameter specifies  the mode of access
{          to the segment (sequential or random).
{
{   POINTER: (OUTPUT) This parameter specifies the process virtual address
{          assigned to the segment. The byte offset in the PVA is set to zero.
{
{   STATUS: (OUTPUT) This parameter specifies the request status.
{          The possible error codes are:
{                dme$unable_to_locate_fde
{                dme$unable_to_get_fd_lock
{                mme$address_not_0_mod_16384
{                mme$asid_specified
{                mme$binding_attribute_invalid
{                mme$contig_mem_seg_violation
{                mme$execute_global_invalid
{                mme$invalid_asid_specified
{                mme$invalid_length_requested
{                mme$invalid_pva
{                mme$invalid_ring_brackets
{                mme$invalid_shadow_segment
{                mme$invalid_shared_taskid
{                mme$length_not_0_mod_16384
{                mme$pages_already_assigned
{                mme$ref_to_unrecovered_file
{                mme$ring_violation
{                mme$segment_number_is_in_use
{                mme$segment_number_not_in_use
{                mme$segment_number_too_big
{                mme$segment_origin_change
{                mme$segment_origin_invalid
{                mme$segment_table_is_full
{                mme$software_attribute_invalid
{                mme$unable_to_assign_contig_mem
{                mme$unsupported_keyword
{                mme$wired_seg_length_too_large
{

*DECK DECK=MMH$DEFINE_IMAGE_FILE EXPAND=FALSE
{
{    This procedure is called during deadstart when the image file is
{attached and opened.  It initializes the fields in mmv$image_file.
{
{Parameters:
{  SFID: (dmt$system_file_id) This is the system file id of the image file.
{
{  LENGTH: This is the length of the information immediately
{          preceding the actual memory image on the image
{          file segment.
{
*DECK DECK=MMH$DELETE_NON_INHERITED_SEGS EXPAND=FALSE
{
{   The purpose of this request is to close all segments in the task's SDT
{ that do not have the inherited attribute. Segments which have a reservation
{ state of mmc$srs_reserved_shared_stack are not closed.
{
{       MMP$DELETE_NON_INHERITED_SEGS (STATUS)
{
{ STATUS: (output) The request status is returned in this parameter.
{        The possible error codes are:
{              mme$invalid_close_segment_req
{              mme$invalid_shared_taskid
{              mme$segment_number_not_in_use
{              mme$segment_number_too_big
{
*DECK DECK=MMH$DELETE_PAGE_FROM_MONITOR EXPAND=FALSE
{
{ This purpose of this procedure is to delete one or more pages from the address space of
{ monitor. The deleted pages are returned to the free queue and are not updated on disk.
{
{     MMP$DELETE_PAGES_FROM_MONITOR (P, PAGE_COUNT, STATUS)
{
{  P: (INPUT) This parameter specifies the address of the first page to delete. The page must be
{     addressible in monitors address space.
{  PAGE_COUNT: (INPUT) This parameter specifies the number of pages to delete.
{  STATUS: (OUTPUT) This parameter is the request status.
{
*DECK DECK=MMH$DELETE_SCRATCH_SEGMENT EXPAND=FALSE
{
{   The purpose of this request is to delete a scratch segment.
{
{       MMP$DELETE_SCRATCH_SEGMENT (POINTER, STATUS)
{
{ POINTER: (input_output) This parameter specifies the segment
{       to be deleted.  This pointer will be set to NIL when the request
{       completes.
{
{ STATUS: (output) This parameter specifies the request status.
{       The possible error codes are:
{             dme$file_descriptor_not_deleted
{             mme$invalid_close_segment_req
{             mme$invalid_shared_taskid
{             mme$segment_number_not_in_use
{             mme$segment_number_too_big
{
*DECK DECK=MMH$DELETE_SEGMENT EXPAND=FALSE
{
{   The purpose of this request is to delete/close a segment.  If the
{ caller is not within the read bracket of the segment being deleted the
{ call is rejected.
{
{       MMP$DELETE_SEGMENT (POINTER, VALIDATION_RING_NUMBER, STATUS)
{
{ POINTER: (input_output) This parameter specifies the segment
{       to be deleted.  This pointer will be set to NIL when the request
{       completes.
{
{ VALIDATION_RING_NUMBER: (input) This parameter specifies the ring of
{       execution for whom the segment is being deleted.  The ring
{       number used for validation is the max of caller ring number
{       and 'validation_ring_number'.
{
{ STATUS: (output) This parameter specifies the request status.
{       The possible error codes are:
{             dme$file_descriptor_not_deleted
{             mme$invalid_close_segment_req
{             mme$invalid_shared_taskid
{             mme$segment_number_not_in_use
{             mme$segment_number_too_big
{


*DECK DECK=MMH$DELETE_USER_SEGMENT EXPAND=FALSE

{
{ The purpose of this request is to close/delete a segment.
{
{  MMP$DELETE_USER_SEGMENT (pointer, status)
{
{  POINTER: (INPUT/OUTPUT) This parameter specifies the segment
{         to be deleted. This pointer will be set to NIL when the
{         request completes.
{
{  STATUS: (OUTPUT) This parameter specifies the request status.
{         The possible error codes are:
{               dme$file_descriptor_not_deleted
{               mme$invalid_close_segment_req
{               mme$invalid_shared_taskid
{               mme$segment_number_not_in_use
{               mme$segment_number_too_big
{

*DECK DECK=MMH$FAILED_ALLOCATION_FLAG_HDL EXPAND=FALSE

{  The purpose of the procedure is to attempt to complete file
{allocation on a file which has previously failed in an
{attempt to allocate file space. It only handles cases
{where the failure was dme$unable_to_alloc_all_space.
{  The ring 1 segment manager sets a system flag if
{such a failure occurs.
{  The procedure make a single attempt to perform
{file allocation. If allocation is not possible then
{the procedure will wait a short time and then return
{to the code which caused the allocation to be required.
{If any events such as terminate_job or interactive break have
{arisen during the wait, they will be processed on the return
{if possible.  If nothing preempts the original code, it will cause
{the same allocation requirement and the process is repeated.
*DECK DECK=MMH$FETCH_IMAGE_PAGE_COUNT EXPAND=FALSE
{
{   This request is used in the RECOVERY job to fetch a count of pages that are
{ in the image page_frame_table.  It also initializes the environment for
{ additional processing of the image file.
{
{       MMP$FETCH_IMAGE_PAGE_COUNT (IMAGE_PAGE_COUNT)
{
{ IMAGE_PAGE_COUNT: (OUTPUT) This parameter specifies the number of pages in
{                   the image page_frame_table.
{
*DECK DECK=MMH$FETCH_OFFSET_MODIFIED_PAGES EXPAND=FALSE
{
{   The purpose of this request is to fetch a list of offsets for all modified
{   pages for the ACTIVE (shadow) segment.
{
{       MMP$FETCH_OFFSET_MODIFIED_PAGES (SEGMENT_POINTER, OFFSET_LIST,
{                  OFFSETS_RETURNED, STATUS);
{
{ SEGMENT_POINTER: (input) This parameter specifies the PVA for the ACTIVE
{       segment.
{
{ RETURN_UNALLOCATED_OFFSETS: (input) This parameter specifies whether or not the
{       user wants offsets of assigned, but not allocated pages returned.
{
{ OFFSET_LIST: (output) This parameter contains the array of offsets for all
{       modified pages for this segment. If the size of the array is not large
{       enough to hold all the offsets, the offsets_returned value should then
{       be used to re_allocated the array.
{
{ OFFSETS_RETURNED: (output) On return this parameter will hold the not of
{       offsets for modified pages. This value can be used to re-allocate
{       the array if it is not large enough to hold all the offsets.
{
{ STATUS: (output) This parameter specifies the request status returned.
{

*DECK DECK=MMH$FETCH_PVAS_OF_IMAGE_PAGES EXPAND=FALSE
{
{   This request is used in the RECOVERY job to fetch a description of pages
{ that are on the IMAGE file.
{
{       MMP$FETCH_PVAS_OF_IMAGE_PAGES (OLD_FDE_P, DESC, STATUS)
{
{ OLD_FDE_P: (INPUT) This parameter specifies the FDE entry of the segment located
{       in the image file.
{
{ DESC: (OUTPUT/dereferenced) This parameter is the list of descriptions of
{       pages in the image file for the specified ASID.
{
{ STATUS: (OUTPUT) This parameter is where the request status is returned to
{       the caller.  The possible error codes are:
{             mme$computed_asti_out_of_range
{
*DECK DECK=MMH$FETCH_PVA_UNWRITTEN_PAGES EXPAND=FALSE
{ The purpose of this request is to fetch PVAs of pages that could not be
{ written to disk because of disk parity errors or device malfunctions.
{
{   MMP$FETCH_PVA_UNWRITTEN_PAGES (SEGMENT_P, STARTING_PVA, PVA_LIST,
{               LIST_OVERFLOW, STATUS);
{
{
{   SEGMENT_P: (input) This parameter is used to identify the segment. The
{           segment is specified by the segment number of this parameter.
{   STARTING_PVA: (input) This parameter is used to specify the starting
{           address for scanning for unwritten pages. If the value of
{           this parameter is NIL the scan starts with the beginning of
{           the segment. If the value is not NIL the scan starts with the
{           first page following the page specified by this parameter.
{   PVA_LIST: (output) This parameter contains the array of PVAs that could
{           not be written to disk. If the size of the array is larger than
{           the number of unwritten PVAs, the unused entries will be set
{           to NIL. If the size of the array is less than the number of
{           unwritten pages, the array will contain PVAs of unwritten pages
{           starting with the first unwritten page following the page
{           specified by the <starting_pva> and continuing with as many
{           consecutive unwritten pages as will fit in the array.
{    LIST_OVERFLOW: (output) This parameter specifies a boolean variable
{           which indicates if more unwritten pages exist than could
{           be returned in the <pva_list>.
{    STATUS: (status) This parameter specifies request status.
{           The possible error codes are:
{                 mme$invalid_pva
{                 mme$ref_to_unrecovered_file
{                 mme$no_matching_offset
{                 mme$stack_overflow_on_push
{

*DECK DECK=MMH$FETCH_SDT_SDTX_LOCKED_FDE EXPAND=FALSE
{
{    The purpose of this request is to return the SDT, SDTX, and locked
{ FDE entry for the segment number specified.
{
{   MMP$FETCH_SDT_SDTX_LOCKED_FDE (segment_number, sdt_entry_p, sdtx_entry_p,
{          fde_entry_p, status)
{
{ SEGMENT_NUMBER: (input) This parameter is the segment number for which the
{            SDT, SDTX, and FDE entries are to be returned.
{
{ SDT_ENTRY_P: (output) This parameter is the pointer to the SDT entry for the
{            segment number specified.
{ SDTX_ENTRY_P: (output) This parameter is the pointer to the SDTX entry for the
{            segment number specified.
{
{ FDE_ENTRY_P: (output) This parameter is the pointer to the locked FDE entry for the
{            segment number specified. The requestor is responsible for unlocking
{            the FDE entry.
{
{ STATUS: (output) This parameter is the request status.
{
*DECK DECK=MMH$FETCH_SEGMENT_ATTRIBUTES EXPAND=FALSE
{
{   The purpose of this request is to fetch one or more attributes
{ of a segment.
{
{       MMP$FETCH_SEGMENT_ATTRIBUTES (PVA, SEG_ATTRIBUTES, STATUS)
{
{ PVA: (input) This parameter specifies the segment number.
{
{ SEG_ATTRIBUTES: (input_output) This parameter is an adaptable
{       array of segment attribute descriptors.  Prior to issuing this
{       request, the caller stores into this array the attribute keywords
{       of the attributes to be fetched.
{
{ STATUS: (output) This parameter specifies the request status.
{       The possible error codes are:
{             mme$caller_not_in_read_bracket
{             mme$segment_number_not_in_use
{             mme$segment_number_too_big
{             mme$unsupported_keyword
{
*DECK DECK=MMH$FETCH_STACK_SEGMENT_INFO EXPAND=FALSE
{ This request returns the segment number and maximum segment length of the
{ stack segment for the ring number specified by the caller.  It sets the
{ stack segment length to zero if requested.  This request is available in
{ Monitor Mode only.
{
{    MMP$FETCH_STACK_SEGMENT_INFO (XCB_P, RING, SET_LENGTH, SEGNUM,
{          LENGTH, FOUND);
{
{ XCB_P: (input) This parameter specifies a pointer to the execution control
{       block of the task.  The task must be swapped in.
{
{ RING: (input) This parameter specifies the ring number of the stack.
{
{ SET_LENGTH: (input) This parameter specifies whether or not to set the
{       length of the stack to zero.
{
{ SEGNUM: (output) This parameter returns the segment number for the stack
{       segment of the specified ring.
{
{ LENGTH: (output) This parameter returns the maximum size allowed for the
{       stack.
{
{ FOUND: (output) This parameter returns whether or not the stack was
{       found.
{

*DECK DECK=MMH$FREE_IMAGE_PAGES EXPAND=FALSE
{
{    This procedure is called prior to closing and detaching the
{image file.  It initializes the request block and makes a call to
{monitor.  From monitor, a procedure is called which scans the
{entire page table.  Valid page table entries greater than the
{deadstart upper bound are deleted.
{
*DECK DECK=MMH$FREE_PAGES EXPAND=FALSE
{
{   The purpose of this request is free pages assigned to a segment.
{ All pages which are fully contained within the portion of
{ the segment specified are deleted from the segment and returned to
{ the free page queue. Modified pages are NOT updated on disk.
{ Use of this request requires write access to the segment.
{
{       MMP$FREE_PAGES (PVA, LENGTH, WAIT, STATUS)
{
{ PVA: (input) This parameter specifies the start of the
{       range of memory to be updated on disk.
{
{ LENGTH: (input) This parameter specifies the number of bytes
{       to be updated on disk.
{
{ WAIT: (input) This parameter specifies whether the task
{       should wait if active IO operations prevent freeing pages.
{
{ STATUS: (output) This parameter specifies the request status.
{       The possible error codes are:
{             mme$invalid_pva
{             mme$ref_to_unrecovered_file
{

*DECK DECK=MMH$GET_ACCESS_SELECTIONS EXPAND=FALSE
{
{  The purpose of this request is to get the segment access selections
{  associated with a segment. Three access selections are currently supported
{  for access to a segment: sequential, random, and read_tu.
{
{    GET_ACCESS_SELECTIONS (PVA, ACCESS_SELECTIONS, STATUS)
{
{    PVA: (input) This parameter specifies the segment.
{
{    ACCESS_SELECTIONS: (output) This parameter specifies the access
{         selections for the segment.
{
{    STATUS: (output) This parameter specifies the request status.

*DECK DECK=MMH$GET_SDT_FOR_JOB_TEMPLATE EXPAND=FALSE
{
{   The purpose of this request is to retrieve the SDT and SDTX entry
{ for specified PVA to be placed in the job template.  If the specified segment
{ is not suitable for this purpose an abnormal status is returned.
{
{       MMP$GET_SDT_FOR_JOB_TEMPLATE (PVA, SDT_ENTRY, SDTX_ENTRY, STATUS)
{
{ PVA: (input) This parameter is the PVA of the SDT and SDTX to be retrieved.
{
{ SDT_ENTRY: (output) This paramerer is where the SDT entry is returned.
{
{ SDTX_ENTRY: (output) This parameter is where the SDTX entry is returned.
{
{ STATUS: (output) This parameter is where the request status is returned.
{       The possible error codes are:
{             mme$segment_number_not_in_use
{             mme$segment_number_too_big
{

*DECK DECK=MMH$GET_SEGMENT_LENGTH EXPAND=FALSE
{
{   The purpose of this procedure is to return the current segment length
{ to the caller.
{
{        MMP$GET_SEGMENT_LENGTH (PVA, VALIDATION_RING_NUMBER, SEGMENT_LENGTH,
{          STATUS)
{
{ PVA: (input) This parameter specifies the segment for which the current
{        segment length is returned.
{
{ VALIDATION_RING_NUMBER: (input) This parameter specifies the ring number
{        used for validation if it is greater than the caller ring number.
{
{ SEGMENT_LENGTH: (output) This parameter is where the current segment
{        length is returned.
{
{ STATUS: (output) This parameter is where the request status is returned
{        to the caller.  The possible error codes are:
{              mme$caller_not_in_read_bracket
{              mme$invalid_pva
{              mme$ref_to_unrecovered_file
{              mme$segment_number_not_in_use
{              mme$segment_number_too_big
{

*DECK DECK=MMH$GET_SEGMENT_SFID EXPAND=FALSE
{
{   The purpose of this procedure is to return the 'sfid' for the specified
{ segment.
{
{        MMP$GET_SEGMENT_SFID (PVA, SFID, STATUS)
{
{ PVA: (input) This paramter specifies the segment for which the 'sfid' is
{        to be returned.
{
{ SFID: (output) This parameter is where the 'sfid' is returned to the caller.
{
{ STATUS: (output) This parameter is where the request status is returned to
{        the caller.   The possible error codes are:
{              mme$segment_not_assigned_device
{              mme$segment_number_not_in_use
{              mme$segment_number_too_big
{
*DECK DECK=MMH$INITIATE_DEBUG_SHADOWING EXPAND=FALSE

 { The purpose of this request is to initiate shadowing on segments for the
 { Interactive Debugger.
 {
 {  MMP$INITIATE_DEBUG_SHADOWING (segment_pointer, status)
 {
 { SEGMENT_POINTER: (INPUT) This parameter specifies the process virtual
 {        address assigned to the segment.
 {
 { STATUS: (OUTPUT) This parameter specifies the request status.
 {
*DECK DECK=MMH$INITIATE_SHADOWING EXPAND=FALSE
{
{   The purpose of this request is to initiate shadowing of files.
{   Modified pages of the file to be shadowed are written to disk
{   and the segment for the file to be shadowed is transformed into
{   an ACTIVE segment to allow continuation of access to files during
{   an online dump.
{
{       MMP$INITIATE_SHADOWING (POINTER, STATUS)
{
{ POINTER: (input) This parameter specifies the process virtual
{       address assigned to the segment.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=MMH$INITIATE_SHADOWING_R1 EXPAND=FALSE
{
{   The purpose of this request is to execute ring 1 code for MMP$INITIATE_SHADOWING.
{   Segment attributes are updated to transform that segment into an ACTIVE (shadow)
{   segment.
{
{       MMP$INITIATE_SHADOWING_R1 (SEGMENT_POINTER, SEGMENT_LENGTH, STATUS);
{
{ SEGMENT_POINTER: (input) This parameter specifies the process virtual
{       address assigned to the segment.
{
{ SEGMENT_LENGTH: (input) This parameter specifies the segment length
{       for the segment that is to be shadowed.
{
{ STATUS: (output) This parameter specifies the request status.
{

*DECK DECK=MMH$INIT_SYSTEM_PRIVILEGE_MAP EXPAND=FALSE
{
{   This procedure initializes the system privilege bit map.  It first
{ clears the map, located in the mainframe pageable segment, then decides
{ which segments have system privilege, and sets the corresponding bits
{ in the map.  Before this procedure is called, the bit map must have
{ been moved from the task private segment static area into mainframe
{ pageable.  After this procedure is called, each new task will pick up
{ the initialized map from mainframe pageable into its task private segment.
{
{    MMP$INIT_SYSTEM_PRIVILEGE_MAP (offset);
{
{ OFFSET: (input) This parameter specifies the offset of the privilege map.
{
*DECK DECK=MMH$INVALIDATE_SEGMENT EXPAND=FALSE

{
{   The purpose of this procedure is to invalidate the specified segment
{ in the SDT table.  The backing store file is returned if one is assigned,
{ and the open_count in the FDE is zero.
{
{        MMP$INVALIDATE_SEGMENT (SEGMENT_NUMBER, VALIDATING_RING_NUMBER,
{              SHARED_TASKID_ARRAY, STATUS)
{
{ SEGMENT_NUMBER: (input) This parameter specifies the segment number to
{        be invalidated.
{
{ VALIDATING_RING_NUMBER: (input) This parameter specifies the validating
{        ring_number of the request.
{
{ SHARED_TASKID_ARRAY: (input) This parameter is a pointer to the list of
{        taskids of tasks in which this segment is to be invalidated.
{
{ STATUS: (output) This parameter is where the request status is returned
{        to the caller.  The possible error codes are:
{             dme$file_descriptor_not_deleted
{             mme$invalid_close_segment_req
{             mme$invalid_shared_taskid
{             mme$segment_number_not_in_use
{             mme$segment_number_too_big
{
*DECK DECK=MMH$IO_CONTROL_BLOCK EXPAND=FALSE
?? EJECT ??
{  The following represents the information kept in the IO Control Block.
{  An IOCB entry is used only if the read/write request was issued with the NO WAIT option.
{  If WAIT was specified on the request, information about the request is returned in the
{  request block.
{
{ ___________________________________________________________________________________________________________
{ | LATEST_COMPLETION_TIME:  updated by mmp$mtr_process_io_completions when a request completes             |
{ |---------------------------------------------------------------------------------------------------------|
{ | MAXIMUM_IOCB_INDEX_IN_USE:  updated by mmp$find_iocb_entry and mmp$update_iocb_completions; used to     |
{ |       control scans of the iocb table                                                                   |
{ |---------------------------------------------------------------------------------------------------------|
{ | WAIT_FOR_ANY_COMPLETION: set to TRUE if mmp$check_io_status found no requests complete and the          |
{ |       task is going to wait for a completion                                                            |
{ |---------------------------------------------------------------------------------------------------------|
{ | IOCB_TABLE:                                                                                             |
{ |  PVA ! LENGTH ! SUB_REQCODE ! IOSTATUS_P !  ACTIVE_IO_ !  CONDITION !     USED_FOR_     !  IO_ALREADY_  |
{ |      !        !             !            !    COUNT    !            !  ASYNCHRONOUS_IO  !    ACTIVE     |
{ |- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -|
{ |      !        !  READ or    !            ! A value     ! Mmp$mtr_   ! TRUE indicates    ! Set TRUE if   |
{ |      !        !  WRITE      !            ! >0 indicates! process_io_! mmp$check_io_     ! io is already |
{ |      !        !             !            ! that the io ! completions! status should     ! active for    |
{ | Used if mmp$check_io_status !            ! request is  ! sets       ! report the request! another task. |
{ | will need to reissue a      !            ! active.     ! condition  ! complete and      ! Indicates that|
{ | request because io was      !            ! Mmp$mtr_    ! when io    ! return the        ! mmp$check_io_ |
{ | already active.             !            ! process_io_ ! completes. ! condition when    ! status should |
{ |      !        !             !            ! completions !            ! active_io_count   ! reissue the   |
{ |      !        !             !            ! will decrement           ! goes to 0.        ! request so    |
{ |      !        !             !            ! when io     !            !                   ! that condition|
{ |      !        !             !            ! completes.  !            ! FALSE and active_ ! can be        |
{ |      !        !             !            !             !            ! io_count > 0      ! determined    |
{ |      !        !             !            !             !            ! indicates the     ! and reported. |
{ |      !        !             !            !             !            ! request hit a     !               |
{ |      !        !             !            !             !            ! temporary problem !               |
{ |      !        !             !            !             !            ! (pt_full, etc.).  !               |
{ |      !        !             !            !             !            ! The task has been !               |
{ |      !        !             !            !             !            ! put into a wait   !               |
{ |      !        !             !            !             !            ! until the io      !               |
{ |      !        !             !            !             !            ! completes.  Mmp$  !               |
{ |      !        !             !            !             !            ! mtr_process_io_   !               |
{ |      !        !             !            !             !            ! completions will  !               |
{ |      !        !             !            !             !            ! ready the task    !               |
{ |      !        !             !            !             !            ! when active_io_   !               |
{ |      !        !             !            !             !            ! count goes to 0.  !               |
{ |      !        !             !            !             !            !                   !               |
{ |---------------------------------------------------------------------------------------------------------|
?? EJECT ??

*DECK DECK=MMH$JOB_DELETE_INHERITED_SDT EXPAND=FALSE
{
{   The purpose of this request is to delete all segments unique to this
{ job.  The ring 1 and 2 stack segments and the job fixed segment are
{ not deleted.  These will be deleted in another phase of job termination.
{
{ NOTE: This procedure can not be called from above ring 2.
{
{       MMP$JOB_DELETE_INHERITED_SDT (STATUS)
{
{ STATUS: (output) This parameter is where the request status is returned.
{       No error codes are returned.  Osp$system_error is called if segments
{       cannot be deleted.
{

*DECK DECK=MMH$JOB_MULTIPROCESSING_CONTROL EXPAND=FALSE
{
{    The purpose of this request is to enable or disable job multiprocessing.
{ The segment table of the task is scanned. If job multiprocessing is being
{ enabled, all inheritable segments are turned into cache bypass segments.
{ If job multiprocessing is being disabled, all inheritable segments are
{ modified from cache bypass segments to regular segments.
{
{    MMP$JOB_MULTIPROCESSING_CONTROL (enable, status)
{
{ ENABLE: (input) This parameter specifies whether the request is to enable
{      or disable job multiprocessing.
{
{ STATUS: (output) This parameter is the request status.
{
*DECK DECK=MMH$LOCK_CATALOG_SEGMENT EXPAND=FALSE
{
{ The purpose of this request is to lock a catalog segment. This allows
{ multiple tasks to coordinate access to a shared read/write catalog segment.
{ A catalog segment may be locked for either read or write access. Multiple
{ readers or one writer may have a catalog segment locked. The request supports
{ a 'wait' option to allow the task to either reject or queue for a segment if
{ the lock cannot be immediately set. Queuing is done in a FIFO manner
{ according to the following algorithm:
{     - task requesting READ access
{          - IF segment not locked for write AND
{                  no tasks are queued for WRITE access THEN
{              lock segment for user
{            ELSEIF WAIT selected THEN
{              queue task for segment
{            ELSE reject request with error code
{
{     - task requesting WRITE access
{            IF segment not locked THEN
{              lock segment for task
{            ELSEIF WAIT selected THEN
{              queue task for segment
{            ELSE reject request with error code
{
{ NOTES:
{   . All queuing is done via table structures. No 'polling' or 'cycling' is
{     done for a task that is waiting for a lock. If a task is queued for a
{     lock, and the task is readied by another task, the task is removed from
{     the queue. It does NOT have the segment locked.
{   . Queuing is guaranteed to be done in a FIFO manner. This reduces the
{     maximum time required to set a lock.
{   . Although multiple readers may have a lock set concurrently, once a writer
{     has been queued for a segment, additional readers will be queued/rejected
{     until the writer has been granted access to the segment.
{   . Pages of a segment that are locked for WRITE will not be aged to disk
{     by memory manager nor will they be recovered if the system crashes.
{     Mmp$write_modified_pages may be used to cause pages to be written to
{     disk.
{     In addition the task may cause IO when the segment is unlocked. See the
{     mmp$unlock_segment request for additional details.
{   . Automatic unlocking of a segment will be done when the segment is
{     closed. All modified pages will be discarded.
{   . Jobs with tasks queued for segments are swappable. The swapin process
{     will be initiated (subject to resource availability) when interlock
{     contention no longer exists.
{   . The mmp$lock_catalog_segment differs from the mmp$lock_segment request
{     only in the type of lock that is set.  In mmp$lock_segment if the ring
{     of the caller is less than or equal to 3 a major lock will be set.  The
{     mmp$lock_catalog_segment was created for use by the permanent file code
{     to create a minor system lock even though the interface is called from
{     ring 2.  By setting a minor lock the permanent file code may keep a segment
{     locked longer without causing problems associated with having a higher CPU
{     dispacthing priority and escaped allocation.
{
{ ->IMPORTANT NOTE: This request is intended to be used by permanent file code
{     for locking catalog segments only.
{
{
{        MMP$LOCK_CATALOG_SEGMENT (PVA, ACCESS, WAIT, STATUS)
{
{ PVA: (input) This parameter specifies the segment to be locked
{
{ ACCESS: (input) This parameter specifies whether the task requires READ or
{          WRITE access to the segment.
{
{ WAIT: (input) This parameter specifies whether to queue or reject if the lock
{        cannot be set.
{
{ STATUS: (output) This parameter specifies the request status.
{        The possible error codes are:
{              dfe$server_has_terminated
{              mme$invalid_pva
{              mme$ref_to_unrecovered_file
{              mme$segment_locked_by_task
{              mme$volume_unavailable
{
*DECK DECK=MMH$LOCK_PAGES EXPAND=FALSE
{   The purpose of this request is to lock one or more pages to prevent
{ the pages from being removed from the working set or written to backing
{ storage without an explicit request from the program. All pages that
{ are totally or partially contained within the specified portion of
{ the segment are locked.
{   If any of the pages in the specified portion of the segment are already
{ locked or are not in memory, this request will be rejected and no pages
{ are locked.
{
{       MMP$LOCK_PAGES (PVA, LENGTH, STATUS)
{
{ PVA: (input) This parameter specifies the start of the
{       range of memory to be locked.
{
{ LENGTH: (input) This parameter specifies the number of bytes
{       to be locked.
{
{ STATUS: (output) This parameter specifies the request status.
{       The possible error codes are:
{             mme$invalid_pva
{             mme$invalid_request
{             mme$lock_unlock_invalid_length
{             mme$not_valid_in_page_table
{             mme$page_already_locked
{             mme$page_not_in_page_table
{             mme$ref_to_unrecovered_file
{
*DECK DECK=MMH$LOCK_SEGMENT EXPAND=FALSE
{
{ The purpose of this request is to lock a segment. This allows multiple tasks
{ to coordinate access to a shared read/write segment. A segment
{ may be locked for either read or write access. Multiple readers or one
{ writer may have a segment locked. The request supports a 'wait' option to
{ allow the task to either reject or queue for a segment if the lock cannot
{ be immediately set. Queuing is done in a FIFO manner according to the
{ following algorithm:
{     - task requesting READ access
{          - IF segment not locked for write AND
{                  no tasks are queued for WRITE access THEN
{              lock segment for user
{            ELSEIF WAIT selected THEN
{              queue task for segment
{            ELSE reject request with error code
{
{     - task requesting WRITE access
{            IF segment not locked THEN
{              lock segment for task
{            ELSEIF WAIT selected THEN
{              queue task for segment
{            ELSE reject request with error code
{
{ NOTES:
{   . All queuing is done via table structures. No 'polling' or 'cycling' is
{     done for a task that is waiting for a lock. If a task is queued for a
{     lock, and the task is readied by another task, the task is removed from
{     the queue. It does NOT have the segment locked.
{   . Queuing is guaranteed to be done in a FIFO manner. This reduces the
{     maximum time required to set a lock.
{   . Although multiple readers may have a lock set concurrently, once a writer
{     has been queued for a segment, additional readers will be queued/rejected
{     until the writer has been granted access to the segment.
{   . Pages of a segment that are locked for WRITE will not be aged to disk
{     by memory manager nor will they be recovered if the system crashes.
{     Mmp$write_modified_pages may be used to cause pages to be written to
{     disk.
{     In addition the task may cause IO when the segment is unlocked. See the
{     mmp$unlock_segment request for additional details.
{   . Automatic unlocking of a segment will be done when the segment is
{     closed. All modified pages will be discarded.
{   . Jobs with tasks queued for segments are swappable. The swapin process
{     will be initiated (subject to resource availability) when interlock
{     contention no longer exists.
{
{ ->IMPORTANT NOTE: This request is intended to be used carefully by privileged
{     subsystem writers ONLY. Jobs with segments locked run at a higher CPU
{     dispatching priority and are NOT good candidates to be swapped. Incorrect
{     usage of this request could result in hung jobs or system.
{
{
{        MMP$LOCK_SEGMENT (PVA, ACCESS, WAIT, STATUS)
{
{ PVA: (input) This parameter specifies the segment to be locked
{
{ ACCESS: (input) This parameter specifies whether the task requires READ or
{          WRITE access to the segment.
{
{ WAIT: (input) This parameter specifies whether to queue or reject if the lock
{        cannot be set.
{
{ STATUS: (output) This parameter specifies the request status.
{        The possible error codes are:
{              dfe$server_has_terminated
{              mme$invalid_pva
{              mme$ref_to_unrecovered_file
{              mme$segment_locked_by_task
{              mme$volume_unavailable
{
*DECK DECK=MMH$MFH_FOR_SEGMENT_MANAGER EXPAND=FALSE

{
{   The purpose of this procedure is to assign a device to a segment
{ if memory manager needs it done.  This procedure is called by the ring 1
{ trap handler when a specified system flag is set.
{
{        MMP$MFH_FOR_SEGMENT_MANAGER
{
*DECK DECK=MMH$MM_MOVE_MOD_SERVER_PAGE EXPAND=FALSE
{
{ NAME:
{   MMP$MM_MOVE_MOD_SERVER_PAGE
{
{ PURPOSE:
{   This procedure makes a request to move a single modified page from a source
{ file to a destination file.  Only modified pages of the server file are moved;
{ non-modified pages are discarded.  It is used to update the server image file
{ on the client in the case of a server crash.  The procedure executes in job
{ mode in a system task which writes the server image file with pages from all
{ of the currently attached server files.
{
{ ASSUMPTIONS:
{   The following assumptions are made in designing this interface:
{        . The state of the server will not change while this request is
{          removing pages
{        . The destination file (as specified by "destination_pva") is not on
{          the server
{        . All space for the destination file must be preallocated
{        . A page has not already been assigned to the destination pva
{        . Access to the server file whose page is being moved has been
{          inhibited by the SDTX access state
{        . The "destination_pva" is on a page boundry
{        . All server IO on the file has been dequeued and pages associated with
{          server IO have been unlocked
{        . This procedure is called only in the system job
{        . The File Descriptor for the file is expected to be locked and will
{          remain so during the monitor call
{
{         PROCEDURE [XDCL] mmp$mm_move_mod_server_page
{           (    sfid: gft$system_file_identifier;
{                destination_pva: ^cell;
{            VAR byte_offset: ost$segment_offset;
{            VAR status: ost$status);
{
{   SFID: (INPUT) Specifies the System File ID of the file whose pages must be
{     moved to the destination file.
{   DESTINATION_PVA: (INPUT) Specifies the location within the server image file
{     to which a located modified page will be written.
{   BYTE_OFFSET: (OUTPUT) Specifies the beginning offset of the located page
{     which has been moved.
{   STATUS: (OUTPUT) Status processing.  Conditions which can be returned are:
{     mme$io_active_on_move_page      (retry)
{     mme$no_pages_found_for_move     (normal exit condition)
{     mme$page_table_full             (retry)
{
*DECK DECK=MMH$MOVE_PAGES EXPAND=FALSE
{
{  MMP$MOVE_PAGES (PVA_SOURCE, PVA_DESTINATION, LENGTH, MODIFIED_BIT_OPTION,
{        REJECT_MOVE_IF_SOURCE_MODIFIED, MOVED_MODIFIED_PAGE_COUNT, STATUS)
{
{  The purpose of this request is to move a page frame from one PVA (process_
{  virtual_address) to another.  When the request completes all pages in the
{  range from <pva_source> to <pva_source>+<length-1> will have been moved
{  to the range of addresses specified by <pva_destination> to
{  <pva_destination>+<length-1>.  The caller must have write access to both
{  the source and destination segments.  This procedure can be called
{  through ring six.
{
{  PVA_SOURCE:  (input)  This parameter specifies the beginning address of
{        pages the calles wants moved.  The pva must be a page boundary.
{
{  PVA_DESTINATION:  (input)  This parameter specifies the beginning
{        address of where the caller wants the pages moved to.  The pva
{        must be a page boundary.
{
{  LENGTH:  (inpu)  This parameter specifies the number of bytes the caller
{        wants moved.  The length nust be a multiple of page size.  The
{        maximum request length is 64K bytes.
{
{  MODIFIED_BIT_OPTION: (input)  This parameter specifies what the caller
{        wants done with the modified bit on the destination page.  Valid
{        options are:
{          mmc$mp_set_modified:  Set the modified bit on the destination page.
{          mmc$mp_clear_modified:  Clear the modified bit on the destination
{          page.
{          mmc$mp_no_change_to_modified:  Leave the modified bit on the
{                destination page as it was on the source page.
{
{  REJECT_MOVE_IF_SOURCE_MODIFIED:  (input)  This boolean parameter specifies
{        whether or not the caller wants the move request to be rejected if
{        a source page is modified.  If this parameter is TRUE and any page
{        in the range from <pva_source> to <pva_source>+<length-1> is
{        modified, the error mme$modified_source_page_reject will be returned.
{        No pages will have been moved.
{
{  MOVED_MODIFIED_PAGE_COUNT:  (output)  This parameter specifies the number
{        of modified source pages that were moved.  If the parameter
{        REJECT_MOVE_IF_SOURCE_MODIFIED is TRUE, this count is meaningless
{        and zero will be returned.
{
{  STATUS  (output)  This parameter specifies the request status.
{        Errors returned:
{          mme$pva_not_on_page_boundary
{          mme$length_not_page_size_mult
{          mme$invalid_length_requested
{          mme$invalid_pva
{          mme$modified_source_page_reject
{
{
{  NOTES and CAUTIONS:
{    1.  MMP$MOVE_PAGES in NOT intended to be used for manipulating pages of
{        shared permanent files.
{
{        1a.  File has one writer, shared for read:  The writer can take
{             away or overwite pages a reader is accessing.  If a modified
{             page was "moved" away, the reader would page fault from disk
{             and get stale data.
{
{        1b.  File shared for write:  Use of MMP$MOVE_PAGES can take away
{             pages before another user has completed modifications or written
{             the modified pages to disk.  If there are multiple writers of
{             the file, MMP$MOVE_PAGES will produce UNDEFINED RESULTS.
{
{    2.  Memory manager will rely on the caller of MMP$MOVE_PAGES to "know
{        what it's doing."
{
{        2a.  If the destination page already exists in memory, that page
{             will be discarded.
{
{    3.  When a page ages out of memory, the page is written to disk only if
{        the modified bit for the page is set.  The caller can use the
{        MODIFIED_BIT_OPTION parameter to control and ensure whether or not
{        pages get written to disk when they age out of memory.  The
{        implications of the use of this parameter must be understood.
{
{        3a.  Use of the mmc$mp_set_modified option guarantees that the
{             destination page will be written to disk if the page ages out
{             of memory, even if no further modifications have yet been
{             made to the destination page.  A subsequent page fault for the
{             page will restore the page.
{
{             For example, consider using MMP$MOVE_PAGES for transfers between
{             a database and buffer segment.  If the mmc$mp_set_modified
{             option is used when a page is moved to the buffer segment (the
{             backing file for the buffer segment has undefined data on it),
{             and
{             the page ages out of memory, it will be written to disk.  A
{             subsequent page fault will restore the page, modifications can be
{             made to it, and the page can eventually be moved back to the
{             database segment.  However, if the mmc$mp_clear_modified option
{             is used when a page is moved to the buffer segment and the page
{             ages out of memory before it is modified, the page will NOT be
{             written to disk.  A page fault will read in whatever undefined
{             data is out on disk; a subsequent move of the page back to the
{             database segment and a write request to the permanent file will
{             trash the database.  Use of the mmc$mp_no_change_to_modified
{             option could have the same effect as the mmc$mp_clear_modified
{             option.
{
{        3b.  Use of the mmc$mp_clear_modified or mmc$mp_no_change_to_modified
{             option makes sense only if the caller knows that the source
{             page matches what is already on disk for the destination page.
{
{        3c.  Even if the caller knows that the source page has been
{             modified, the mmc$mp_set_modified option should be used
{             rather that the mmc$mp_no_change_to_modified option.
{
{             For example, if a modified page in the buffer segment ages out of
{             memory before it is moved back to the database segment, it will
{             be written to the backing file associated with the buffer segment
{             and the modified bit for the page will be cleared.  A move back
{             to
{             the database segment using the mmc$mp_no_change_to_modified
{             option will not set the modified bit for that page.  If the page
{             ages out of memory it will NOT be written to disk and the
{             modifications will be lost.
{
*DECK DECK=MMH$MTR_CHANGE_SEGMENT_TABLE EXPAND=FALSE

{
{   The purpose of this procedure is to process the monitor request to
{ change (move) the segment table.
{
{        MMP$MTR_CHANGE_SEGMENT_TABLE (REQUEST_BLOCK)
{
{ REQUEST_BLOCK: (input, output) This parameter contains the change segment
{        table monitor request block.  The request status is returned to the
{        caller in this request block.  The new SDT and SDTX pointers are
{        passed to this procedure in this request block.
{
*DECK DECK=MMH$MTR_FETCH_OFFSET_MOD_PAGES EXPAND=FALSE
{
{   The purpose of this request is to process the  monitor request
{  'syc$rc_fetch_offset_mod_pages'.  This monitor request returns to
{  job mode a list of segment offsets for all modified pages for a
{  given segment.
{   If the array is not large enough to hold all offsets for the modified
{  pages for the given segment, monitor will update the offsets_returned
{  field in the request block and the caller then should check and see
{  if he should re-allocate the array using the offsets_returned value.
{
{       MMP$MTR_FETCH_OFFSET_MOD_PAGES (RB)
{
{ RB: (input, output): This parameter is a record which contains the
{       information specifying whats offsets to return.  The offsets
{       and control information are returned in this parameter.
{
*DECK DECK=MMH$MTR_FETCH_PVA_UNWRITTEN_PGS EXPAND=FALSE

{
{   The purpose of this request is to process the
{ 'syc$rc_fetch_pva_unwritten_pgs' monitor function.  This monitor
{ function returns to job mode the segment offsets of pages that could
{ not be written to mass storage for a specified PVA.
{   The following assumptions are made when processing this request:
{ . Any new pages added to the queue are added at the forward link.
{ . The order of entries in the queue does not change.
{
{       MMP$MTR_FETCH_PVA_UNWRITTEN_PGS (RB)
{
{ RB: (input, output): This parameter is a record which contains the
{       information specifying whats offsets to return.  The offsets
{       and control information are returned in this parameter.
{
*DECK DECK=MMH$MTR_LOCK_RING_1_STACK EXPAND=FALSE

*DECK DECK=MMH$MTR_LOCK_UNLOCK_PAGES EXPAND=FALSE

{
{   The purpose of this request is to process the 'syc$rc_lock_pages' and
{ 'syc$rc_unlock_pages' monitor requests.  Locking pages prevents implicit
{ IO being done on a page, unlocking a page removes this restriction.
{
{       MMP$MTR_LOCK_UNLOCK_PAGES (RB)
{
{ RB: (input, output) This parameter is a record that specifies pages to
{       lock or unlock.  Request status is returned in this parameter.
{
*DECK DECK=MMH$MTR_SET_GET_SEGMENT_LENGTH EXPAND=FALSE
{
{   The purpose of this procedure is to process the monitor request to set
{ or get current segment length.  If the segment is shortened, pages beyond
{ new segment length are freed.
{
{        MMP$MTR_SET_GET_SEGMENT_LENGTH (REQUEST_BLOCK)
{
{ REQUEST_BLOCK: (input,output) This parameter contains the monitor function
{        request block for the set or get segment length monitor function.
{
*DECK DECK=MMH$OPEN_ASID_BASED_SEGMENT EXPAND=FALSE
{
{    This procedure is designed to be used to add a segment to a callers segment table when
{ the segment accessability is based upon the ASID of the segment. This is specifically
{ relevant to the SSR segment. The purpose of the procedure is to return to the caller
{ the segment number to be used in a pva to access the segment.
{
{     MMP$OPEN_ASID_BASED_SEGMENT (sdt_entry, sdtx_entry, segment_number, status)
{
{ SDT_ENTRY: (input) This parameter specifies the SDT entry for the segment. This SDT
{      entry will be added to the requestor's segment table.
{
{ SDTX_ENTRY: (input) This parameter specifies the SDTX entry for the segment. This
{      SDTX entry will be added to the requestor's segment table extended.
{
{ SEGMENT_NUMBER: (output) This parameter returns the segment number of the new segment.
{      It is relative only to the requestor's address space.
{
{ STATUS: (output) The parameter is the request status.
{
*DECK DECK=MMH$OPEN_DEVICE_FILE EXPAND=FALSE
{
{    The purpose of this request is to open a device file.
{
{       MMP$OPEN_DEVICE_FILE (sfid, asid, r1, r2, sequential_random_selection,
{            read_write_access_selection, file_kind, segment_number, status)
{
{ SFID: (input) This parameter specifies the SFID of the segment.
{
{ ASID: (input) This parameter specifies the ASID of the segment.
{
{ R1: (input) This parameter specifies the ring 1 value to be used in
{       creating the SDT entry for the new segment.
{
{ R2: (input) This parameter specifies the ring 2 value to be used in
{       creating the SDT entry for the new segment.
{
{ SEQUENTIAL_RANDOM_SELECTION: (input) This parameter specifies the access
{       selections for the segment. If a sequential access is specified,
{       read_transfer_unit and free_behind are added to the SDTX software
{       attribute selections for the segment.
{
{ READ_WRITE_ACCESS_SELECTION: (input) This parameter specifies the
{       read or write permissions in the SDT entry.
{
{ FILE_KIND: (input) This parameter specifies what type of file this segment
{       is to be.
{
{ SEGMENT_NUMBER: (output) This parameter returns the segment number of the segment
{       to the requestor. This segment number is only valid within the callers
{       address space.
{
{ STATUS: (output) This parameter returns the request status.
{

*DECK DECK=MMH$OPEN_FILE_SEGMENT EXPAND=FALSE
{
{   The purpose of this request is to open a file for segment
{ level access.
{
{       MMP$OPEN_FILE_SEGMENT (SFID, SEG_ATTRIBUTES_P, POINTER_KIND,
{         VALIDATION_RING_NUMBER, CHAPTER_NUMBER, POINTER, STATUS)
{
{ SFID: (input) This parameter specifies the system file identifier of the file
{       to be opened as a segment.
{
{ SEG_ATTRIBUTES_P: (input) This parameter is a pointer to an array
{       of segment attributes to be assigned to the segment.
{
{ POINTER_KIND: (input) This parameter specifies the type of
{       pointer to be constructed for the segment.
{
{ VALIDATION_RING_NUMBER: (input) This parameter specifies the ring of
{       execution for whom the segment is being opened.  The ring
{       number used for validation is the max of caller ring number
{       and 'validation_ring_number'.
{
{ POINTER: (output) This parameter is where the segment pointer
{       is returned.  The byte offset in the PVA is set to zero.
{
{ STATUS: (output) This parameter specifies the request status.
{       The possible error codes are:
{             dme$unable_to_locate_fde
{             dme$unable_to_get_fd_lock
{             mme$address_not_0_mod_16384
{             mme$asid_specified
{             mme$binding_attribute_invalid
{             mme$contig_mem_seg_violation
{             mme$execute_global_invalid
{             mme$invalid_asid_specified
{             mme$invalid_length_requested
{             mme$invalid_pva
{             mme$invalid_ring_brackets
{             mme$invalid_shadow_segment
{             mme$invalid_shared_taskid
{             mme$length_not_0_mod_16384
{             mme$pages_already_assigned
{             mme$ref_to_unrecovered_file
{             mme$ring_violation
{             mme$segment_number_is_in_use
{             mme$segment_number_not_in_use
{             mme$segment_number_too_big
{             mme$segment_origin_invalid
{             mme$segment_table_is_full
{             mme$software_attribute_invalid
{             mme$unable_to_assign_contig_mem
{             mme$unsupported_keyword
*DECK DECK=MMH$OS_PREALLOCATE_FILE_SPACE EXPAND=FALSE
{
{ The purpose of this procedure is to preallocate file space. The request will
{  attempt to allocate the number of bytes up to the length which is input by the user.
{
{       MMP$OS_PREALLOCATE_FILE_SPACE (PROCESS_VIRTUAL_ADDRESS, LENGTH, STATUS)
{
{  PROCESS_VIRTUAL_ADDRESS: (input) This parameter specifies the address of
{      the segment to which space is to be preallocated.
{
{  LENGTH: (input) This parameter specifies the desired length of the segment
{      after preallocation. This request will allocate (length - segment.eoi)
{      number of bytes.
{
{  WAIT_TIME_SECONDS: (input) This parameter specifies the maximum number of
{      seconds to wait when the requested space is not available.
{
{  STATUS: (output) This parameter will return the request status to the user.
{
*DECK DECK=MMH$PREALLOCATE_FILE_SPACE EXPAND=FALSE
{
{ The purpose of this request is to:
{   1) Ensure that a specified address range is assigned to disk
{   2) Ensure that data written to the disk in this address range
{      can be recovered from the disk without regard to a system
{      failure that occurs after the data has been written.
{
{ The steps performed by this request are:
{   1) Allocate the disk space if required
{   2) Iinitialize the disk space in the specified address range
{   3) Wait for all writes to complete
{   4) Flush the NOS/VE disk log transactions that reflect the
{      allocation and initialization to disk.
{
{ This procedure can be called from ring 6 and below.
{
{ This procedure should be used sparingly as it causes SIGNIFICANT OVERHEAD.
{
{  MMP$PREALLOCATE_FILE_SPACE (PVA, LENGTH, WAIT_FOR_ALLOCATION, STATUS);
{
{ PVA - (Input) This parameter specifies the starting virtual address
{       for this operation.
{
{ LENGTH - (Input) This parameter specifies the number of bytes that
{       are allocated and initialized by this request.  All bytes
{       contained in the PVA - LENGTH range will be initialized.
{
{ WAIT_FOR_ALLOCATION - (Input) This parameter specifies whether the
{       request should wait if disk space is not immediately available.
{       If this parameter is FALSE and file space is not available
{       an abnormal status will be returned.
{
{ STATUS - (Output) This parameter specifies the result of the request.
{
*DECK DECK=MMH$PRESET_REAL_MEMORY EXPAND=FALSE
{ This procedure is used in monitor to preset a range of REAL MEMORY
{ ADDRESSES to a specified value. WARNING: no checks are made on the
{ validity of the address range except to verify that the SVA
{ exists in the page table with the 'valid' bit clear. The range of words
{ to be preset must not cross a page boundary.
{
{     MMP$PRESET_REAL_MEMORY (SVA, LENGTH, PRESET_VALUE);
{
{   SVA: (input) This parameter specifies the SVA of the memory to be
{        preset. The memory must not cross a page boundary and must
{        start on a word boundary.
{   LENGTH: (input) This parameter specifies the number of words to
{        be preset.
{   PRESET_VALUE: (input) This parameter specifies the bit pattern
{        to be used to do the preset function.
{    NOTES:
{       - routine will halt if SVA is not 0 MOD 8.
{       - routine will halt if SVA is not in the page table with the
{         'valid' bit CLEAR.
{       - length is rounded down to a multiple of eight bytes.
*DECK DECK=MMH$PROCESS_DM_CALLS_FOR_SM EXPAND=FALSE

{
{   The purpose of this procedure is to interface with device manager on
{ the behalf of a specified segment.  Currently the only reason device
{ manager is called is to assign a device to a segment.
{
{        MMP$PROCESS_DM_CALLS_FOR_SM (SEGMENT_NUMBER, STATUS)
{
{ SEGMENT_NUMBER: (input) This parameter specifies which segment is to
{        acted on with respect to the device manager.
{
{ STATUS: (output) This parameter is where the request status is returned
{        to the caller.
{
*DECK DECK=MMH$PROCESS_FILE_ALLOC EXPAND=FALSE

{   The purpose of this procedure is to process file allocation
{ if memory management has set the assign active flag in the SDTX.
{ This procedure is either called as a result of a trap by the
{ ring 1 trap handler or because a previous attempt to expand
{ a file failed.
{   In the case of a previous failure, this procedure is called periodically
{ from the ring 3 segment manager until it successfully expands the
{ file, or the user terminates the task.
{
{    MMP$PROCESS_FILE_ALLOC (allocation_length, status)
{
{ ALLOCATION_LENGTH: (output) This parameter returns the total amount of space
{       that was allocated by this request.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=MMH$READ EXPAND=FALSE
{ The purpose of this procedure is to insure that a specified
{ portion of a segment exists in real memory.  When the request completes,
{ all pages totally or partially contained by the
{ range of addresses specified by <pva> to <pva>+<length> will be
{ in real memory.  The pages will be marked as recently used to reduce
{ the odds of having them removed from memory via aging. If the pages
{ already exist in real memory, no input request will be issued to
{ obtain them.  A call to this procedure cannot come from above ring 6.
{
{      MMP$READ (PVA, LENGTH, IOSTATUS_P, WAIT, STATUS)
{
{ PVA: (input) This parameter specifies the beginning address of data
{      the caller wants in real memory.
{
{ LENGTH: (input) This parameter specifies the number of bytes the caller
{      wants in real memory.  The maximum request length is 65536 bytes;
{      if the length is longer, the condition mme$request_length_too_long
{      will be returned in the status variable.  If the length is enough
{      to cause a request to span a segment boundary, then the condition
{      mme$invalid_pva_formed will be returned.
{
{ IOSTATUS_P: (input) This parameter specifies the address of
{      the IO status variable.  Possible values for the request_status field
{      are:
{        mmc$irs_active
{        mmc$irs_complete
{        mmc$irs_none
{      If iostatus_p^.request_status is set to mmc$irs_complete,
{      then possible values for the condition field are:
{        0--indicates i/o completed without error
{        ioc$unrecovered_disk_error
{        ioc$disk_media_error
{
{ WAIT: (input) This parameter specifies whether to wait for
{      completion of the request or to return to the user immediately
{      after initiating the required IO. If the user does not wait,
{      the user may later issue a MMP$CHECK_IO_STATUS request
{      to determine the status of the MMP$READ request.
{
{ STATUS: (output) This parameter specifies the request status.
{      Possible error codes are:
{        mme$request_length_too_long
{        mme$invalid_pva_formed
{        mme$invalid_pva
{        mme$read_beyond_eoi
{        mme$read_write_beyond_msl
{        mme$write_beyond_eoi_no_append
{        mme$ref_to_unrecovered_file
{        dfe$server_has_terminated
{     If status.normal is FALSE, then iostatus_p^.request_status is set to
{     mmc$irs_none.
{
*DECK DECK=MMH$RESERVE_SEGMENT_NUMBER EXPAND=FALSE
{
{   The purpose of this request is to reserve a segment number within the
{   requesting task's
{ address space for subsequent explicit assignment.  The reserved segment does
{ not have any
{ file or segment associated with it as a result of this request; the segment
{ number is simply
{ not chosen by memory management on any subsequent requests for an empty
{ segment.
{   The segment can be used in subsequent requests that explicitly pass
{   segment management the
{ segment number to be used.
{
{       MMP$RESERVE_SEGMENT_NUMBER (SEGMENT_NUMBER, STATUS)
{
{ SEGMENT_NUMBER: (output) This parameter specifies the segment number that
{ has been reserved.
{
{ STATUS: (output) This parameter specifies the request status.
{

*DECK DECK=MMH$REVERIFY_ACCESS EXPAND=FALSE

{
{   This request can be used to determine whether a PVA
{ can be accessed by a program without causing an access
{ violation or segment fault.
{
{   This request is similar to MMP$VERIFY_ACCESS but runs
{ faster. The speed improvement is at a cost of less checking.
{ The request simply verifies that the requested segment is still
{ valid in the segment table. Checking of access rights and
{ read-beyond-eoi is NOT done.
{
{       MMP$REVERIFY_ACCESS (PVA_P): BOOLEAN
{
{ PVA_P: (input) This parameter is a pointer to the PVA to be
{       tested.
{
{ BOOLEAN: (output) The boolean result of this function specifies
{       whether access is valid.
{
*DECK DECK=MMH$SDTX_INITIALIZATION EXPAND=FALSE
{
{   The purpose of this request is to initialize the SDTX at system
{ initialization time.
{
{       MMP$SDTX_INITIALIZATION (status)
{
{ STATUS (output) This parameter specifies the request status.
{
*DECK DECK=MMH$SEGMENT_FAULT_HANDLER EXPAND=FALSE
{
{   The purpose of this procedure is to process segment access faults in job
{ mode that were detected by memory manager in monitor mode.  This procedure
{ calls either a user specified error exit procedure or a procedure to invoke
{ a condition handler.
{
{       MMP$SEGMENT_FAULT_HANDLER (SEGMENT_ACCESS_FAULT, FAULT_SAVE_AREA_P)
{
{ SEGMENT_ACCESS_FAULT: (input) This parameter is the monitor fault used to pass
{       segment fault information to job mode.
{
{ FAULT_SAVE_AREA_P: (input) This parameter points to the save area where the
{       fault occurred.
{
*DECK DECK=MMH$SET_ACCESS_MODE EXPAND=FALSE

{
{   The purpose of this procedure is to set the access mode of a segment
{ based on its hardware attributes.
{
{        MMP$SET_ACCESS_MODE (SEGMENT_DESCRIPTOR, ACCESS_MODE)
{
{ SEGMENT_DESCRIPTOR: (input) This parameter is the segment descriptor
{        from the segment table.
{
{ ACCESS_MODE: (output) This parameter is where the access mode for the
{        specified segment descriptor is returned.
{
*DECK DECK=MMH$SET_ACCESS_SELECTIONS EXPAND=FALSE
{
{  The purpose of this request is to change the segment access selections
{  associated with a segment. Three access selections are currently supported
{  for access to a segment: sequential, random, and read_tu. Sequential access
{  should be selected if access to the segment is sequential and more than 4
{  pages will be accessed sequentially. Sequential access should NOT be selected
{  for segments that are managed via ADVISE requests. Read_tu access should be
{  selected if the task is randomly accessing large blocks of data in the
{  segment, or if the task is sequentially accessing multiple parts of the
{  segment.  Random access should be selected otherwise.
{
{  An access selection of sequential causes memory manager to read an entire
{  transfer unit when a page fault occurs for a page on disk. In addition
{  pages assigned to the segment may be automatically removed when new
{  pages are added as a result of a page fault.
{
{  An access selection of read_tu causes memory manager to read multiple pages,
{  one or more transfer units, when a page fault occurs for a page on disk.  In
{  addition pages assigned to the segment are not automatically removed when new
{  pages are added as a result of a page fault.
{
{  An access selection of random causes memory manager to read one page for each
{  page fault for a page on disk.  No pages pages are removed as a result of the
{  page fault.
{
{          MMP$SET_ACCESS_SELECTIONS (PVA, ACCESS_SELECTIONS, STATUS)
{
{    PVA: (input) This parameter specifies the segment.
{
{    ACCESS_SELECTIONS: (input) This parameter specifies the access
{         selections for the segment.
{
{    STATUS: (output) This parameter specifies the request status.
{         The possible error codes are:
{              dme$unable_lo_locate_fde
{              dme$unable_to_get_fd_lock
{              mme$invalid_ring_brackets
{              mme$ring_violation
{              mme$segment_number_not_in_use
{              mme$segment_number_too_big
{              mme$segment_origin_change
{
*DECK DECK=MMH$SET_SEGMENT_ACCESS_RIGHTS EXPAND=FALSE
{
{    The purpose of this request is to set the segment access
{ rights of a segment. The access rights are stored in the SDTX
{ of each segment.
{
{     MMP$SET_SEGMENT_ACCESS_RIGHTS (sdt_entry, sdtx_entry)
{
{ SDT_ENTRY: (input) This parameter is the segment descriptor entry for
{      the segment whose access rights are being set.
{
{ SDTX_ENTRY: (output) This parameter returns the segment descriptor extended
{      entry for the segment. The access rights for the segment have been set in
{      this entry.
{
*DECK DECK=MMH$SET_SEGMENT_LENGTH EXPAND=FALSE
{
{   The purpose of this procedure is to explicitly set the segment length.
{ Segment length is defined as the last byte in the segment that can be
{ referenced, references beyond segment length are treated the same as a
{ read beyond EOI.
{
{        MMP$SET_SEGMENT_LENGTH (PVA, VALIDATION_RING_NUMBER, SEGMENT_LENGTH,
{          STATUS)
{
{ PVA: (input) This parameter specifies the segment for which segment length
{        is being set.
{
{ VALIDATION_RING_NUMBER: (input) This parameter specifies the ring number
{        used for validation if it is greater than the caller ring number.
{
{ SEGMENT_LENGTH: (input) This parameter specifies the new segment length.
{
{ STATUS: (output) This parameter is where the request status is returned
{        to the caller.  The possible error codes are:
{              mme$caller_not_in_write_bracket
{              mme$invalid_pva
{              mme$no_write_access
{              mme$ref_to_unrecovered_file
{              mme$segment_number_not_in_use
{              mme$segment_number_too_big
{
*DECK DECK=MMH$STORE_SEGMENT_ATTRIBUTES EXPAND=FALSE
{
{   The purpose of this request is to allow a user to change
{ attributes of a segment.  Some attribute changes (such as
{ changing a segment attribute to BINDING) are rejected unless
{ the calling procedure is running within a certain ring bracket.
{
{       MMP$STORE_SEGMENT_ATTRIBUTES (PVA, VALIDATION_RING_NUMBER,
{         SEG_ATTRIBUTES, STATUS)
{
{ PVA: (input) This parameter specifies the segment to be changed.
{
{ VALIDATION_RING_NUMBER: (input) This parameter specifies the ring
{       of execution for whom the change is being made.  The
{       ring number used for validation is the max of caller ring
{       number and 'validation_ring_number'.
{
{ SEG_ATTRIBUTES: (input) This parameter is an adaptable array of
{       segment attribute descriptors.  Each attribute descriptor specifies
{       a new value for a segment attribute.
{
{ STATUS: (output) This parameter specifies the request status.
{       The possible error codes are:
{             dme$unable_to_get_fd_lock
{             dme$unable_to_locate_fde
{             mme$address_not_0_mod_16384
{             mme$asid_specified
{             mme$binding_attribute_invalid
{             mme$execute_global_invalid
{             mme$execute_local_invalid
{             mme$invalid_asid_specified
{             mme$invalid_ring_brackets
{             mme$invalid_shadow_segment
{             mme$length_not_0_mod_16384
{             mme$ring_violation
{             mme$segment_number_is_in_use
{             mme$segment_number_not_in_use
{             mme$segment_number_too_big
{             mme$segment_origin_change
{             mme$segment_orgin_invalid
{             mme$set_unmodifiable_attribute
{             mme$software_attribute_invalid
{             mme$unsupported_keyword
{

*DECK DECK=MMH$TASK_DELETE_INHERITED_SDT EXPAND=FALSE
{
{   The purpose of this request is to delete all segments with the
{ inheritance attribute of mmc$si_new_segment. These segments are primarily
{ the task template segments.  The SDT and SDTX tables are deallocated.
{ This request is used during task termination.
{
{       MMP$TASK_DELETE_INHERITED_SDT (TASK_ID, STATUS)
{
{ TASK_ID: (input) This parameter identifies the task being terminated.
{
{ STATUS: (output) This parameter is where the request status is returned.
{         The possible error codes are:
{               mme$invalid_pva
{               mme$invalid_task_id
{               mme$ref_to_unrecovered_file
*DECK DECK=MMH$TERMINATE_SHADOWING EXPAND=FALSE
{
{   The purpose of this request is to terminate shadowing of files.
{   o If required (UPDATE parameter set to true), a request will be issued to
{   update
{     the PASSIVE file with the ACTIVE .
{   o A request to mmp$terminate_shadowing_r1 will be issued to destroy the
{   ACTIVE
{     file and to activate the PASSIVE file again.
{
{       MMP$TERMINATE_SHADOWING (POINTER, UPDATE, STATUS)
{
{ POINTER: (input) This parameter specifies the process virtual
{       address assigned to the ACTIVE segment.
{
{ UPDATE: (input) This boolean parameter specifies if an update
{       (PASSIVE with ACTIVE)  is required or not.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=MMH$TERMINATE_SHADOWING_R1 EXPAND=FALSE
{
{   The purpose of this request is to invalidate an ACTIVE segment in the SDT.
{   The backing store file is destroyed and returned if one is assigned.
{
{       MMP$TERMINATE_SHADOWING_R1 (SEGMENT_NUMBER, STATUS);
{
{ SEGMENT_NUMBER: (input) This parameter specifies the SEGMENT NUMBER
{       to be invalidated.
{
{ STATUS: (output) This parameter specifies the request status returned.
{

*DECK DECK=MMH$UNLOCK_PAGES EXPAND=FALSE
{ The purpose of this request is to unlock pages which were previously locked
{ via the mmp$lock_pages request. All pages that are totally or partially
{ contained within the specified portion of the segment are unlocked.
{   If any pages in the specified portion of the segment are not locked
{ or are not in memory, the page is ignored and unlocking continues.
{
{       MMP$UNLOCK_PAGES (PVA, LENGTH, STATUS)
{
{ PVA: (input) This parameter specifies the start of the
{       range of memory to be unlocked.
{
{ LENGTH: (input) This parameter specifies the number of bytes
{       to be unlocked.
{
{ STATUS: (output) This parameter specifies the request status.
{       The possible error codes are:
{             mme$invalid_pva
{             mme$invalid_request
{             mme$lock_unlock_invalid_length
{             mme$not_valid_in_page_table
{             mme$page_not_in_page_table
{             mme$ref_to_unrecovered_file
{
*DECK DECK=MMH$UNLOCK_RMA_LIST EXPAND=FALSE
{ This request is used to unlock page frames which were previously
{ locked via a MMP$BUILD_LOCK_RMA_LIST request. The 'used' and 'modified' bits
{ in the page table entry for each page frame are updated according to the
{ type of IO done into the page frames. All tasks queued waiting for the
{ page frames because of page faults are made ready when the page frames are
{ unlocked.
{ The 'active_io_page_count' of the job owning the pages is decremented.  The
{ 'inhibit_swap_count' of the job is also decremented unless the IO was a
{ write to a local file.  If the 'inhibit_swap_count' goes to zero for the
{ job and the job is being swapped out, the job swapping task is made ready.
{ If the job is swapped and a write error occurs on a local file, the page is put
{ into the io error while swapped queue.  A call is made to ready the task so the
{ job can swap in and reclaim the page.
{
{ NOTE:  THE LIST THAT IS UNLOCKED MUST BE EXACTLY THE SAME LIST THAT WAS
{        LOCKED BY MMP$BUILD_LOCK_RMA_LIST
{
{
{     MMP$UNLOCK_RMA_LIST (IO_TYPE, LIST_P, LIST_LENGTH, IO_ID, MF_JOB_FILE,
{         IO_ERROR, STATUS);
{
{  IO_TYPE: (input) This parameter specifies the type of IO that has
{         taken place into the page frames. The value of this
{         parameter should agree with the <io_type> passed on the
{         MMP$BUILD_LOCK_RMA_LIST request.
{  LIST_P: (input) This parameter points to an array which
{         defines the page frames to be unlocked. This MUST be the same
{         list returned on the MMP$BUILD_LOCK_RMA_LIST request.
{         Several locked lists CANNOT be grouped together to be unlocked
{         by mmp$unlock_rma_list.
{  LIST_LENGTH: (input) This parameter specifies the number of entries
{         in the RMA list. An RMA list entry that contains a 'length' of zero
{         will terminate the list even though more entries remain.
{  IO_ID: (input) This parameter is used to specify an io identifier that MM
{         uses during request processing.
{  MF_JOB_FILE: (input) This specifies whether or not the file is a local
{         file.
{  IO_ERROR: (input,output) This specifies how the IO to/from the pages
{         terminated.  Page manager uses this parameter
{         together with <io_type> to determine how to update the
{         'used' and 'modified' bits in the page table.
{         For local file writes, ioc$no_error is returned if the error is
{         processed.
{  STATUS: (output) This parameter specifies the request status.
{         No error codes are returned.  All error will result in a call to
{         mtp$error_stop.
{

*DECK DECK=MMH$UNLOCK_SEGMENT EXPAND=FALSE
{
{  The purpose of this request is to unlock a segment that was previously
{ locked via the mmp$lock_segment request. Any tasks that are queued waiting
{ for access to the segment are made 'ready' if no usage conflicts exist with
{ other concurrent users of the segment.
{
{  If the task unlocking the segment had the segment locked for write, the task
{ may cause any of the following operations to be done on each 'modified' page
{ in the segment:
{      . free -  The contents of the page are discarded and not written to disk.
{      . remove_from_working_set - Remove the pages from the working set.
{                Pages are placed in the available queue and may be reclaimed
{                later without having to do IO if the pages have not been reused.
{                (IO MAY be initiated if modified pages are removed.)
{      . write - All modified pages are written to disk.
{      . protected_write - All modified pages are written to disk. In addition,
{                no task will be allowed to modify the pages until the write is
{                completed.
{      . none -  No action is taken with the pages, ie. left in the working set.
{
{  The segment is unlocked immediately as a result of this request without
{ regard to any IO initiated as a result of the <write_option>.  If other tasks
{ attempt to lock the segment while the IO is active, the lock request is
{ accepted unless it conflicts with other concurrent users. If a task attempts
{ to access a page for which IO is still active as a result of a previous
{ 'protected_write', the task is queued until the IO is completed.
{
{        MMP$UNLOCK_SEGMENT (PVA, WRITE_OPTION, WAIT, STATUS)
{
{ PVA: (input) This parameter specifies the segment to be locked.
{
{ WRITE_OPTION: (input) This parameter specifies the disposition of modified
{               pages.  (see above for additional information)
{
{ WAIT: (input) This parameter specifies whether or not to wait for IO
{               completion on any IO requests initiated as a result of the
{               <write_option>.
{
{ STATUS: (output) This parameter specifies the request status.
{               The possible error codes are:
{                     dfe$server_has_terminated
{                     mme$invalid_pva
{                     mme$invalid_request
{                     mme$io_write_error
{                     mme$ref_to_unrecovered_file
{                     mme$segment_not_locked
{                     mme$volume_unavailable
{

*DECK DECK=MMH$UPDATE_SDT_SDTX_ENTRY EXPAND=FALSE

*DECK DECK=MMH$VALIDATE_SEGMENT_NUMBER EXPAND=FALSE

{
{   The purpose of this procedure is to validate a segment.  Pointers to the
{ segment's SDT and SDTX entries are returned.  The segment number is
{ checked to see if it is within the bounds of the segment table and whether the
{ valid bit is set.
{
{        MMP$VALIDATE_SEGMENT_NUMBER (SEGMENT_NUMBER, SDT_ENTRY_P,
{          SDTX_ENTRY_P, STATUS)
{
{ SEGMENT_NUMBER: (input) This parameter specifies the segment to be
{        validated.
{
{ SDT_ENTRY_P: (output) This parameter is where a pointer to the SDT entry
{        is returned.
{
{ SDTX_ENTRY_P: (output) This parameter is where a pointer to the SDTX entry
{        is returned.
{
{ STATUS: (output) This parameter is where the request status is returned
{        to the caller.  The possible error codes are:
{              mme$segment_number_not_in_use
{              mme$segment_number_too_big
{

*DECK DECK=MMH$VERIFY_ACCESS EXPAND=FALSE
{
{   This request can be used to determine whether a PVA
{ can be accessed by a program without causing an access
{ violation or segment fault.
{
{       MMP$VERIFY_ACCESS (PVA_P, ACCESS_MODE): BOOLEAN
{
{ PVA_P: (input) This parameter is a pointer to the PVA to be
{       tested.
{
{ ACCESS_MODE: (input) This parameter specifies the type of
{       access to be tested.
{
{ BOOLEAN: (output) The boolean result of this function specifies
{       whether access is valid.
{
*DECK DECK=MMH$VERIFY_NO_SPACE_AVAILABLE EXPAND=FALSE
{
{   The purpose of this procedure is to verify that no space is available for a
{ segment after a DME$UNABLE_TO_ALLOC_ALL_SPACE condition is returned on an
{ attempt to allocate additional disk space (MMP$OS_PREALLOCATE_FILE_SPACE for
{ example).  This is necessary because DME$UNABLE_TO_ALLOC_ALL_SPACE is
{ returned when the MAT runs out of space even though space is available in the
{ DAT.
{
{       MMP$VERIFY_NO_SPACE_AVAILABLE (PROCESS_VIRTUAL_ADDRESS,
{         NO_SPACE_AVAILABLE, STATUS)
{
{  PROCESS_VIRTUAL_ADDRESS: (input)  This parameter specifies the address of
{        the segment for which the out of space condition is to be checked.
{
{  NO_SPACE_AVAILABLE: (output)  This parameter returns a boolean which
{        indicates whether or not additional space is available for the
{        segment.
{
{  STATUS: (output) This parameter will return the request status to the user.
{
*DECK DECK=MMH$VOLUME_UNAVAILABLE_FLAG_HDL EXPAND=FALSE

{ PROCEDURE [XREF] mmp$volume_unavailable_flag_hdl (
{    flag_id: ost$system_flag);
{
{  The purpose of this procedure is to process the volume unavailable
{  event within the job template or user code.  It will raise the
{  user defined condition osc$volume_unavailable.
*DECK DECK=MMH$WAIT_IO_COMPLETION EXPAND=FALSE
{
{  The purpose of this request is to suspend execution of the requesting
{ task if IO is active for the specified page. If IO is not active
{ or if the page is not in memory, this request completes immediately and a
{ normal status is returned. If IO is active, execution of the task
{ is suspended until all IO to the page is completed.
{
{    MMP$WAIT_IO_COMPLETION (P, STATUS)
{
{  P: (INPUT) This parameter specifies the address of the page.
{
{  STATUS: (OUTPUT) This parameter specifies request status.
{
*DECK DECK=MMH$WRITE EXPAND=FALSE
{
{ The purpose of this procedure is insure that modified portions of
{ real memory are written to backing storage.  All modified pages
{ totally or partially contained within the range of addresses
{ specified by <pva> to <pva>+<length> will be written to disk.
{ A call to this procedure cannot come from above ring 6.
{
{
{      MMP$WRITE (PVA, LENGTH, REMOVE, IOSTATUS_P, WAIT, STATUS)
{
{ PVA: (input) This parameter specifies the beginning address of the
{      data to examine for modified pages.  Modified pages will be
{      written to backing storage.
{
{ LENGTH: (input) This parameter specifies the number of bytes to be
{      examined for modified pages.  The maximum request length is
{      65536 bytes; if the length is longer, the condition
{      mme$request_length_too_long
{      will be returned in the status variable.  If the length is enough to
{      cause a request to span a segment boundary, then the condition
{      mme$invalid_pva_formed will be returned.
{
{ REMOVE: (input) This parameter specifies whether to remove the pages
{      from the working set when the request completes.
{
{ IOSTATUS_P: (input) This parameter specifies the address of
{      the IO status variable.  Possible values for the request_status are:
{        mmc$irs_active
{        mmc$irs_complete
{        mmc$irs_none
{      If iostatus_p^.request_status is set to mmc$irs_complete,
{      then possible values for the condition field are:
{        0--indicates i/o completed without error
{        ioc$unrecovered_disk_error
{        ioc$disk_media_error
{
{ WAIT: (input) This parameter specifies whether to wait for
{      completion of the request or to return to the user immediately
{      after initiating the required IO. If the user does not wish to
{      wait, the user may later issue a MMP$CHECK_IO_STATUS request
{      to determine the status of the MMP$WRITE request.
{
{ STATUS: (output) This parameter specifies the request status.
{      Possible error codes are:
{        mme$request_length_too_long
{        mme$invalid_pva_formed
{        mme$invalid_pva
{        mme$ref_to_unrecovered_file
{        mme$segment_not_pageable
{        mme$segment_not_assigned_device
{        dfe$server_has_terminated
{      If status.normal is FALSE, then iostatus_p^.request_status will be
{      set to mmc$irs_none.
{
*DECK DECK=MMH$WRITE_MODIFIED_PAGES EXPAND=FALSE
{
{   The purpose of this request is write modified pages to
{ disk.  All pages which are all or partially contained within
{ the portion of the segment specified and which have been
{ modified are written to disk.
{
{       MMP$WRITE_MODIFIED_PAGES (PVA, LENGTH, WAIT, STATUS)
{
{ PVA: (input) This parameter specifies the start of the
{       range of memory to be updated on disk.
{
{ LENGTH: (input) This parameter specifies the number of bytes
{       to be updated on disk.
{
{ WAIT: (input) This parameter specifies whether the task
{       should wait until all write operations for the specified
{       addresses have completed.
{
{ STATUS: (output) This parameter specifies the request status.
{       The possible error codes are:
{             dfe$server_has_terminated
{             mme$io_write_error
{             mme$segment_not_assigned_device
{             mme$segment_not_pageable
{             mme$volume_unavailable
{

*DECK DECK=MMH$XTASK_PVA_TO_SVA EXPAND=FALSE
{  This request is used in monitor to translate a PVA relative to the
{  CURRENTLY EXECUTING TASK to an SVA. No test is made to see if pages
{  are currently assigned to the PVA.
{
{       MMP$XTASK_PVA_TO_SVA (PVA, SVA, STATUS)
{
{    PVA: (input) This parameter specifies the PVA to be converted.
{    SVA: (output) This parameter specifies the SVA corresponding to
{          PVA.
{    STATUS: (output) This parameter specifies request status.
{          The possible error codes are:
{                mme$invalid_pva
{                mme$ref_to_unrecovered_file
{

*DECK DECK=MMK$JOB_MODE_KEYPOINTS EXPAND=FALSE
{ Define keypoint codes for Memory Manager in job mode.}

  CONST

    mmk$advise_in = mmk$job_base + 1,
      {E  'Advise In' 'segnum  ' H16 }
      {X  'Advise In' }

    mmk$advise_out = mmk$job_base + 2,
      {E  'Advise Out' 'segnum  ' H16 }
      {X  'Advise Out' }

    mmk$advise_out_in = mmk$job_base + 3,
      {E  'Advise Out - In' 'segnum  ' H16 }
      {X  'Advise Out - In' }

    mmk$job_lock_pages = mmk$job_base + 4,
      {E  'Lock Pages' 'segnum  ' H16 }
      {X  'Lock Pages' }

    mmk$job_unlock_pages = mmk$job_base + 5,
      {E  'Unlock Pages' 'segnum  ' H16 }
      {X  'Unlock Pages' }

    mmk$fetch_pva_unwritten_pages = mmk$job_base + 6,
      {E  'Fetch PVA Unwritten Pages' 'segnum  ' H16 }
      {X  'Fetch PVA Unwritten Pages' }

    mmk$write_modified_pages = mmk$job_base + 7,
      {E  'Write modified pages' 'segnum  ' H16 }
      {X  'Write modified pages' }

    mmk$free_pages = mmk$job_base + 8,
      {E  'Free Pages' 'segnum  ' H16 }
      {X  'Free Pages' }

    mmk$assign_device_to_segment = mmk$job_base + 9,
      {D  'Assign device to transient segment' 'segnum  ' H16 }

    mmk$close = mmk$job_base + 11,
      {E  'Close segment' 'segnum  ' H16 }
      {X  'Close segment' }

    mmk$open_file_segment = mmk$job_base + 12,
      {E  'Open file segment' }
      {X  'Open file segment' 'segnum  ' H16 }

    mmk$create_inherited_sdt = mmk$job_base + 13,
      {D  'Create inherited SDT' }

    mmk$fetch_seg_attributes = mmk$job_base + 14,
      {E  'Fetch segment attributes' 'segnum  ' H16 }
      {X  'Fetch segment attributes' }

    mmk$get_sdt_for_job_template = mmk$job_base + 15,
      {D  'Get SDT for job template' 'segnum  ' H16 }

    mmk$delete_inherited_sdt = mmk$job_base + 16,
      {D  'Delete inherited SDT' }

    mmk$store_segment_attributes = mmk$job_base + 17,
      {E  'Store segment attributes' 'segnum  ' H16 }
      {X  'Store segment attributes' }

    mmk$verify_access = mmk$job_base + 18,
      {E  'Verify access' 'segnum  ' H16 }
      {X  'Verify access' }

    mmk$delete_segment = mmk$job_base + 19,
      {E  'Delete segment' 'segnum  ' H16 }
      {X  'Delete segment' }

    mmk$create_segment = mmk$job_base + 20,
      {E  'Create segment' }
      {X  'Create segment' 'segnum  ' H16 }

    mmk$expand_segment_table = mmk$job_base + 22,
      {D  'Expand segment table' 'old_stl ' H32 }

    mmk$add_sdt_sdtx_entry = mmk$job_base + 23,
      {D  'Add SDT and SDTX entry' 'segnum  ' H16 }

    mmk$get_segment_sfid = mmk$job_base + 25,
      {D  'Get segment sfid' 'segnum  ' H16 }

    mmk$invalidate_segment = mmk$job_base + 26,
      {D  'Invalidate segment' 'segnum  ' H16 }

    mmk$mfh_for_segment_manager = mmk$job_base + 27,
      {D  'Segment manager monitor fault' }

    mmk$update_sdt_sdtx_entry = mmk$job_base + 28,
      {D  'Update sdt and sdtx entry' 'segnum  ' H16 }

    mmk$validate_segment_number = mmk$job_base + 29,
      {D  'Validate segment' 'segnum  ' H16 }

    mmk$job_lock_segment = mmk$job_base + 30,
      {E  'Lock segment' 'segnum  ' H16 }
      {X  'Lock segment' }

    mmk$job_unlock_segment = mmk$job_base + 31,
      {E  'Unlock segment' 'segnum  ' H16 }
      {X  'Unlock segment' }

    mmk$get_segment_length = mmk$job_base + 32,
      {E  'Get segment length' 'segnum  ' H16 }
      {X  'Get segment length' }

    mmk$set_segment_length = mmk$job_base + 33,
      {E 'Set segment length' }
      {X 'Set segment length' 'segnum  ' H16 }

    mmk$set_access_selections = mmk$job_base + 34,
      {E  'Set access selections' 'segnum  ' H16 }
      {X  'Set access selections' }

    mmk$create_scratch_segment = mmk$job_base + 35,
      {E  'Create scratch segment' }
      {X  'Create scratch segment' }

    mmk$delete_scratch_segment = mmk$job_base + 36,
      {E  'Delete scratch segment' 'segnum  ' H16 }
      {X  'Delete scratch segment' }

    mmk$read = mmk$job_base + 37,
      {E  'Read' 'segnum  ' H16 }
      {X  'Read' }

    mmk$write = mmk$job_base + 38,
      {E  'Write' 'segnum  ' H16 }
      {X  'Write' }

    mmk$check_io_status = mmk$job_base + 39,
      {E  'Check io status' }
      {X  'Check io status' }

    mmk$initiate_shadowing = mmk$job_base + 40,
      {E  'Initiate shadowing' 'segnum' H16 }
      {X  'Initiate shadowing' }

    mmk$terminate_shadowing = mmk$job_base + 42,
      {E  'Terminate shadowing ' 'segnum' H16 }
      {X  'Terminate shadowing' }

    mmk$shadow_file_reference = mmk$job_base + 43,
      {E  'Shadow file reference' }
      {X  'Shadow file reference ' 'segnum' H16 }

    mmk$update_passive_with_active = mmk$job_base + 44,
      {E  'Update PASSIVE with ACTIVE' 'segnum' H16 }
      {X  'Update PASSIVE with ACTIVE' }

    mmk$fetch_offset_modified_pages = mmk$job_base + 45,
      {E  'Fetch offset modified pages' 'segnum' H16 }
      {X  'Fetch offset modified pages' }

    mmk$get_access_selections = mmk$job_base + 46,
      {E  'Get access selections' 'segnum' H16 }
      {X  'Get access selections' }

    mmk$create_shadow_segment = mmk$job_base + 47,
      {E  'Create shadow segment' 'segnum' H16 }
      {X  'Create shadow segment' }

    mmk$assign_pages = mmk$job_base + 48,
      {E  'Assign pages' 'segnum' H16 }
      {X  'Assign pages' }

    mmk$conditional_free = mmk$job_base + 49,
      {E  'Conditional free' 'segnum' H16 }
      {X  'Conditional free' }

    mmk$move_pages = mmk$job_base + 50,
      {E  'Move pages' 'segnum' H16 }
      {X  'Move pages' }

    mmk$check_io_completions = mmk$job_base + 51;
      {E  'Check io completions' }
      {X  'Check io completions' }

*copyc AMK$BASE_KEYPOINT_VALUES
*DECK DECK=MMK$MONITOR_MODE_KEYPOINTS EXPAND=FALSE
{Define keypoint codes for Memory Manager in monitor mode.}

  CONST

    mmk$advise_request_processor = mmk$monitor_base + 3,
      {X  'Exit Advise processor' }
{ The entry values are syc$monitor_request_codes.
      {E 4.5  'Advise In' }
      {E 4.6  'Advise Out' }
      {E 4.7  'Advise Out-In' }

    mmk$free_flush = mmk$monitor_base + 4,
      {X  'Exit Free-WMP processor' }
{ The entry values are syc$monitor_request_codes.
      {E 8.12 'Free Pages' }
      {E 8.13 'Write Modified Pages' }
      {E 8.70 'Conditional Free' }

    mmk$ring1_segment_request = mmk$monitor_base + 5,
{ The entry/exit values are the request ordinals in mmt$rb_ring1_segment_request.
      {E 4.0  'Delete segment by segment number' }
      {E 4.1  'Delete segment by SFID' }
      {E 4.2  'Flush segment by SFID' }
      {E 4.3  'Commit memory' }
      {E 4.4  'Detach file' }
      {E 4.5  'Flush and Delete segment by SFID' }
      {E 4.6  'Flush segment by segment number' }
      {E 4.7  'Replace SFID' }
      {E 4.8  'End job recovery' }
      {E 4.9  'Make MFW cache' }
      {E 4.10 'Copy STE from MTR to job' }
      {X 4.0  'Delete segment by segment number' }
      {X 4.1  'Delete segment by SFID' }
      {X 4.2  'Flush segment by SFID' }
      {X 4.3  'Commit memory' }
      {X 4.4  'Detach file' }
      {X 4.5  'Flush and Delete segment by SFID' }
      {X 4.6  'Flush segment by segment number' }
      {X 4.7  'Replace SFID' }
      {X 4.8  'End job recovery' }
      {X 4.9  'Make MFW cache' }
      {X 4.10 'Copy STE from MTR to job' }

    mmk$page_fault = mmk$monitor_base + 6,
      {E  'Page fault processor' 'segnum  ' H16}
{ The exit values are defined in mmt$page_pull_status.
      {X 5.1  'Page found in avail queue' }
      {X 5.2  'Page found in avail modified queue' }
      {X 5.3  'Page valid in page table' }
      {X 5.4  'No memory' }
      {X 5.5  'Low on memory' }
      {X 5.6  'Page locked' }
      {X 5.7  'Page found on disk' }
      {X 5.8  'Page table full' }
      {X 5.9  'Page found with io active' }
      {X 5.10 'Assign new page to segment' }
      {X 5.11 'Beyond file limit' }
      {X 5.12 'Beyond EOI' }
      {X 5.13 'No extend permission' }
      {X 5.14 'Page found on disk - driver reject' }
      {X 5.15 'Page found on server' }
      {X 5.16 'Allocate required on server' }
      {X 5.17 'Server terminated' }

    mmk$segment_request = mmk$monitor_base + 7,
{ The debug values are defined by mmt$monitor_segment_request in mmt$rb_segment_request.
      {D 4.1  'Segment Req - assign SFID' }
      {D 4.2  'Segment Req - fetch max working set' }
      {D 4.3  'Segment Req - store max working set' }
      {D 4.4  'Segment Req - get ASID from SFT/open seg' }
      {D 4.5  'Segment Req - complete seg sft entry' }
      {D 4.6  'Segment Req - fetch min ws size' }
      {D 4.7  'Segment Req - store min ws size' }
      {D 4.8  'Segment Req - fetch page aging int' }
      {D 4.9  'Segment Req - store page aging int' }
      {D 4.10 'Segment Req - fetch cyclic aging int' }
      {D 4.11 'Segment Req - store cyclic aging int' }

    mmk$page_pull = mmk$monitor_base + 10,
      {D  'Page pull' 'SVA     ' H48 }

    mmk$create_task = mmk$monitor_base + 11,
      {D 'Create task' }

    mmk$create_job = mmk$monitor_base + 12,
      {D 'Create job' }

    mmk$exit_task = mmk$monitor_base + 13,
      {D 'Exit task' }

    mmk$exit_job = mmk$monitor_base + 14,
      {D 'Exit job' 'AJLO' H16 }

    mmk$mtr_lock_ring_1_stack = mmk$monitor_base + 15,
      {D 'Lock job's ring 1 stack' 'AJLO' H16 }

    mmk$reassign_asid = mmk$monitor_base + 24,
      {D  'Reassign ASID' 'asid    ' H16 }

    mmk$assign_asid = mmk$monitor_base + 34,
      {D  'Assign ASID' 'ASID    ' H16 }

    mmk$free_asid = mmk$monitor_base + 35,
      {D  'Free ASID' 'ASID    ' H16 }

    mmk$periodic_call = mmk$monitor_base + 36,
      {E  'Periodic call' }
      {X  'Periodic call' }

    mmk$build_lock_rmal = mmk$monitor_base + 38,
      {D  'Lock page for IO' 'pfti    ' H16 }

    mmk$unlock_rmal = mmk$monitor_base + 39,
      {D  'Unlock page for IO' 'pfti    ' H16 }

    mmk$mtr_read_write_io = mmk$monitor_base + 41,
      {X  'Exit IO request processor' }
{ The entry values are defined in mmt$rb_memory_manager_io by mmt$sub_reqcodes.
      {E 4.0  'Read Pages' }
      {E 4.1  'Write Pages' }
      {E 4.2  'Wait For IO Completion' }

    mmk$process_page_table_full = mmk$monitor_base + 46,
      {E  'Page Table full processor' 'pti     ' H16 }
      {X  'Page table full processor' 'pass    ' I16 }

    mmk$write_page_to_disk = mmk$monitor_base + 47,
      {D  'Write page to disk' 'pfti    ' H16 }

    mmk$mtr_assign_pages = mmk$monitor_base + 50,
      {X  'Assign pages' }
{ The entry values are defined in mmt$rb_assign_pages by mmt$assign_sub_reqcodes.
      {E 4.0  'Assign pages' }
      {E 4.1  'Cancel reserve' }

    mmk$mtr_move_pages = mmk$monitor_base + 51;
      {E  'Move pages' }
      {X  'Move pages' }

*copyc AMK$BASE_KEYPOINT_VALUES
*DECK DECK=MMM$ASID_PAGE_TABLE_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Memory Management: Manage Page Table and ASIDs' ??
MODULE mmm$asid_page_table_manager;

{ PURPOSE
{   This module contains the memory modules for managing the page table and ASIDs.
{   There are three functional groups of procedures in this module. The modules are grouped
{   here since they are related:
{
{        ASID MANAGEMENT         - mmp$assign_asid
{                                  mmp$assign_specific_asid
{                                  mmp$free_asid
{                                  mmp$change_asid
{                                  mmp$reclaim_ast_entries
{
{        PAGE TABLE MANAGEMENT   - mmp$make_pt_entry
{                                  mmp$delete_pt_entry
{                                  clear_continue_bits
{                                  free_pt_entry_in_avail_queue
{
{        PAGE TABLE FULL MANAGER - mmp$process_page_table_full
{                                  build_asid_list
{                                  reassign_asid
{
{
?? TITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$null_ajl_ordinal
*copyc mmc$debug_constants
*copyc mmc$first_transient_segment
*copyc mmk$monitor_mode_keypoints
*copyc mmt$active_segment_table
*copyc mmt$continue_bit_count
*copyc mmt$image_file
*copyc mmt$mainframe_wired_asid
*copyc mmt$make_pt_entry_status
*copyc mmt$page_frame_queue_id
*copyc mmt$page_frame_index
*copyc mmt$page_queue_list
*copyc mmt$pfti_array
*copyc mmt$pt_full_status
*copyc mmt$write_modified_pages_status
*copyc mtc$job_fixed_segment
*copyc osc$processor_defined_registers
*copyc osc$purge_map_and_cache
*copyc ost$heap
*copyc syt$monitor_status
?? POP ??
*copyc gfp$mtr_get_locked_fde_p
*copyc jmp$get_ijle_p
*copyc jmp$ijl_block_valid
*copyc jmp$unlock_ajl
*copyc jsp$recalculate_swapped_pages
*copyc mmp$asid
*copyc mmp$asti
*copyc mmp$aste_pointer
*copyc mmp$asti
*copyc mmp$delete_last_pfti_from_array
*copyc mmp$find_next_pfti
*copyc mmp$free_image_pages_mtr
*copyc mmp$get_inhibit_io_status
*copyc mmp$get_max_sdt_pointer
*copyc mmp$get_sdt_entry_p
*copyc mmp$initialize_find_next_pfti
*copyc mmp$nudge_periodic_call
*copyc mmp$relink_page_frame
*copyc mmp$remove_page_from_jws
*copyc mmp$reset_find_next_pfti
*copyc mtp$error_stop
*copyc tmp$find_next_xcb


*copyc dsv$ssr_sdte
*copyc mtv$monitor_segment_table
?? SKIP := 2 ??
*copyc mtv$nos_segment_table_p
?? SKIP := 2 ??
*copyc jmv$max_ajl_ordinal_in_use
*copyc jmv$ijl_p
*copyc jmv$null_ijl_ordinal
*copyc jmv$system_ijl_ordinal
?? SKIP := 2 ??
*copyc mmv$async_work
?? SKIP := 2 ??
*copyc mmv$ast_p
?? SKIP := 2 ??
*copyc mmv$image_file
?? SKIP := 2 ??
*copyc mmv$multiple_caches
?? SKIP := 2 ??
*copyc mmv$multiple_page_maps
?? SKIP := 2 ??
*copyc mmv$pfti_array_p
?? SKIP := 2 ??
*copyc mmv$pft_p
?? SKIP := 2 ??
*copyc mmv$pt_length
?? SKIP := 2 ??
*copyc mmv$pt_p
?? SKIP := 2 ??
*copyc mmv$test_reassign_asid
?? SKIP := 2 ??
*copyc osv$page_size
?? TITLE := 'Global Statistics Kept By Module', EJECT ??
{ the following is used for debugging trace information:

  PROCEDURE [INLINE] trace
    (    id: integer;
         inc: integer);

    mmv$aptm_trace [id] := mmv$aptm_trace [id] + inc;
  PROCEND trace;

  CONST
    mmc$ap_low_asids = 1,
    mmc$ap_no_asids = 2,
    mmc$ap_ast_reset = 3,
    mmc$ap_free_aste = 4,
    mmc$ap_assign = 5,
    mmc$ap_assign_specific = 6,
    mmc$ap_casid_swapped_job = 7,
    mmc$ap_casid_monitor = 8,
    mmc$ap_casid_recovery = 9,
    mmc$ap_casid_template = 10,
    mmc$ap_casid_global = 11,
    mmc$ap_casid_job = 12,
    mmc$ap_reclaim_asids = 13,
    mmc$ap_mpte_full = 14,
    mmc$ap_mpte_recovered = 15,
    mmc$ap_mpte_rec1 = 16,
    mmc$ap_mpte_rec2 = 17,
    mmc$ap_ptf_called = 18,
    mmc$ap_ptf_tried = 19,
    mmc$ap_ptf_failed = 20,
    mmc$ap_ptf_remove = 21,
    mmc$ap_rea_called = 22,
    mmc$ap_rea_in_free = 23,
    mmc$ap_rea_mpte_fail = 24,
    mmc$ap_rea_ok = 25,
    mmc$ap_rea_ok1 = 26,
    mmc$ap_rea_ok2 = 27,
    mmc$ap_rea_ok3 = 28,
    mmc$ap_rea_ok4 = 29,
    mmc$ap_rea_fail = 30,
    mmc$ap_rea_fail1 = 31,
    mmc$ap_rea_fail2 = 32,
    mmc$ap_rea_quit = 33,
    mmc$ap_unused_34 = 34,
    mmc$ap_unused_35 = 35,
    mmc$ap_rea_make_pt_entry = 36,
    mmc$ap_ba_freed_terj = 37;

{ The following table keeps statistics on page table full procesing.

  TYPE
    mmt$pt_full_trace_info = record
      timestamp: integer,
      changed_asid: 0 .. 0ffffffff(16),
      failed: 0 .. 0ffffffff(16),
      pass: array [reassign_pass] of 0 .. 0ffffffff(16),
      last_sva: ost$system_virtual_address,
      index: 0 .. 65535,
      asid: array [0 .. 127] of record
        old: ost$asid,
        new: ost$asid,
      recend,
    recend;

  VAR
    mmv$pt_full_trace: [XDCL] mmt$pt_full_trace_info,
    mmv$aptm_trace: [XDCL] array [0 .. 50] of 0 .. 0ffffffff(16);

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    changing_asid: ost$asid := 0,
    changing_aste_p: ^mmt$active_segment_table_entry := NIL,
    mmv$continue_bit_count_p: [XDCL, #GATE] ^mmt$continue_bit_count,
    mmv$max_template_segment_number: [XDCL, #GATE] integer := mmc$first_loader_predefined_seg,
    mmv$mf_wired_asid: [XDCL, #GATE] mmt$mainframe_wired_asid := [0, 0],
    mmv$number_free_astes: [XDCL, #GATE] integer,
    mmv$pages_to_dump_p: [XDCL, #GATE] ^packed array [0 .. * ] of boolean := NIL,
    mmv$pt_search: integer {4 .. 32} := 32,
    mmv$time_changed_global_asid: [XDCL] ost$free_running_clock := 0ffffffffffff(16),
    mmv$time_changed_template_asid: [XDCL] ost$free_running_clock := 0ffffffffffff(16);

?? TITLE := 'Inline Procedures From Common Decks', EJECT ??
?? SKIP := 2 ??
*copyc mmp$purge_all_cache_map
?? SKIP := 2 ??
*copyc mmp$purge_all_page_seg_map
?? TITLE := 'ASID MANAGEMENT' ??
?? NEWTITLE := '[XDCL] mmp$assign_asid', EJECT ??
{ PURPOSE:
{   This procedure is called to find an available entry in the AST table, assign the entry and
{   return an ASID for the entry. If no AST entry is available, the routine HALTS. This should never
{   happen since there are more ASIDs than page frames, and ASIDs not currently being used by any
{   page frames can be reassigned.
{
{ DESIGN
{   This procedure searches the AST for an entry that is free and has been free since before
{   the last time CACHE and MAP were purged. If necessary, this routine will reclaim AST entries
{   assigned to segments/files if no pages are currently assigned to the segment

  VAR
    last_purge_time: [STATIC] integer := 1,
    next_asti: [STATIC] mmt$ast_index := 1;


  PROCEDURE [XDCL] mmp$assign_asid
    (VAR asid: ost$asid;
     VAR asti: mmt$ast_index;
     VAR aste_p: ^mmt$active_segment_table_entry);

    VAR
      zaste_p: ^mmt$active_segment_table_entry;


{ If there are NO free entries, call reclaim unused entries right now since an entry MUST be
{ assigned. If the number of free entries is too small, force a call to MM periodic to do
{ the reclaiming as soon as possible.

    IF mmv$number_free_astes < 30 THEN {30 is arbitrary number}
      IF mmv$number_free_astes = 0 THEN
        trace (mmc$ap_no_asids, 1);
        mmp$reclaim_ast_entries (0);
        IF mmv$number_free_astes = 0 THEN
          mtp$error_stop ('MM26 - AST full');
        IFEND;
      ELSE
        trace (mmc$ap_low_asids, 1);
        mmv$async_work.reclaim_astes := TRUE;
        mmp$nudge_periodic_call;
      IFEND;
    IFEND;

    mmv$number_free_astes := mmv$number_free_astes - 1;

{ Find and assign a free AST entry. CACHE and MAP must be purged when the AST assignment algorithm wraps
{ around and reassigns entries that may still be in cache or map. Note that free entries cannot be reused
{ until a purge occurs.

    REPEAT
      next_asti := next_asti - 1;
      IF next_asti = 0 THEN
        next_asti := UPPERBOUND (mmv$ast_p^);
        last_purge_time := #FREE_RUNNING_CLOCK (0);
        mmp$purge_all_cache_map;
        trace (mmc$ap_ast_reset, 1);
      IFEND;
    UNTIL NOT mmv$ast_p^ [next_asti].in_use AND (mmv$ast_p^ [next_asti].time_freed < last_purge_time);

    asti := next_asti;
    aste_p := ^mmv$ast_p^ [next_asti];
    asid := aste_p^.asid;
    aste_p^.in_use := TRUE;
    trace (mmc$ap_assign, 1);

    IF mmc$debug THEN
      mmp$aste_pointer (asid, zaste_p);
      IF zaste_p <> aste_p THEN
        mtp$error_stop ('MM - bad ASID in assign  ASID');
      IFEND;
    IFEND;


  PROCEND mmp$assign_asid;
?? TITLE := '[XDCL] mmp$assign_specific_asid', EJECT ??
{ PURPOSE:
{   This procedure is used by the Job Swapper to reclaim a specific ASID for swapin. No cache/map
{   purging is required since the ASID will be reclaimed ONLY if it is currently free AND has not
{   been used by another job while the reclaiming job was swapped out. It is important
{   that the ASID not have been used by another job because cache/map is not purged
{   as part of swapin.
{
{ DESIGN:
{   To reclaim an ASID, simply reset the in_use field. Counts of AST entries in
{   use are adjusted as required.
{
{ NOTE:
{   The caller is responsible for verifying that the ASID can correctly be reclaimed.

  PROCEDURE [XDCL] mmp$assign_specific_asid
    (    aste_p: ^mmt$active_segment_table_entry);

    VAR
      asti: mmt$ast_index,
      zaste_p: ^mmt$active_segment_table_entry;

    mmv$number_free_astes := mmv$number_free_astes - 1;
    trace (mmc$ap_assign_specific, 1);

    IF mmc$debug THEN
      mmp$asti (aste_p^.asid, asti);
      zaste_p := ^mmv$ast_p^ [asti];
      IF zaste_p <> aste_p THEN
        mtp$error_stop ('MM - bad ASID in assign specific ASID');
      IFEND;
      IF aste_p^.in_use THEN
        mtp$error_stop ('MM - assign specific of already in use');
      IFEND;
    IFEND;

    aste_p^.in_use := TRUE;

  PROCEND mmp$assign_specific_asid;
?? TITLE := '[XDCL] mmp$free_asid', EJECT ??
{ PURPOSE:
{   This procedure is called to free an ASID. The AST entry corresponding to the ASID is marked as free.
{
{ DESIGN:
{   To free an ASID, the AST entry is marked as not in use and the ASID is saved. The
{   time the entry was freed is saved in the AST. The timestamp is used by mmp$assign to
{   correctly manage cache and map purges. An ASID cannot be assigned to a different segment
{   until cache and map are purged. Failing to purge the cache or map will cause failures since
{   stale data may be used.


  PROCEDURE [XDCL] mmp$free_asid
    (    asid: ost$asid;
         aste_p: ^mmt$active_segment_table_entry);

    VAR
      zaste_p: ^mmt$active_segment_table_entry;

    IF NOT aste_p^.in_use OR (aste_p^.pages_in_memory <> 0) THEN
      mtp$error_stop ('MM42 - error in free ast entry');
    IFEND;

    IF mmc$debug THEN
      mmp$aste_pointer (asid, zaste_p);
      IF zaste_p <> aste_p THEN
        mtp$error_stop ('MM - bad ASID in free ASID');
      IFEND;
    IFEND;

    mmv$number_free_astes := mmv$number_free_astes + 1;

    aste_p^.in_use := FALSE;
    aste_p^.asid := asid;
    aste_p^.time_freed := #FREE_RUNNING_CLOCK (0);

    IF mmc$debug AND mmv$test_reassign_asid THEN
      aste_p^.sfid.file_hash := 255;
    IFEND;

    trace (mmc$ap_free_aste, 1);

  PROCEND mmp$free_asid;
?? TITLE := '[XDCL] mmp$change_asid', EJECT ??
{ PURPOSE:
{   This procedure will change an ASID from an old value to a new value.
{   All affected Segment tables, FDEs, and system tables are updated as required.
{
{ DESIGN:
{   This procedure searches all segment tables of all tasks that could be using the ASID.
{   The number of tasks and jobs to search depends on the attributes of the segment/file that is using
{   the ASID. If a job that should be searched is swapped out, a flag is set in the IJL
{   to notify the swapper that ASIDs must be fixed on swap-in.
{
{   The following table shows all the types of ASIDs that can be in SDTs and the way these
{   ASIDs are located when they change (ie., what is searched). Note that the table is
{   ordered from easiest-to-change to hardest-to-change - the number at the beginning of the line
{   indicates preferred order for reassignment.
{
{       ASID                      NOT SWAPPED                   SWAPPED
{ 1   local file/transient   search all XCBs in AST.IJLO   dsw_job_asid_changed
{
{ 2   perm file in JWS       search all XCBs in AST.IJLO   dsw_job_asid_changed
{
{ 3   perm file in shared Q  search all XCBs               mmv$time_changed_global_asid > timestamp
{
{ 3   template asid          search all XCBs               mmv$time_changed_template_asid  > timestamp
{


  PROCEDURE [XDCL] mmp$change_asid
    (    aste_p: ^mmt$active_segment_table_entry;
         old_asid: ost$asid;
         new_asid: ost$asid;
         new_asti: mmt$ast_index);

    VAR
      cell_p: ^cell,
      fde_p: gft$file_desc_entry_p,
      ijle_p: ^jmt$initiated_job_list_entry,
      max_segnum: ost$segment,
      recovery: boolean,
      segnum: integer, {allow negative numbers}
      sdt_p: mmt$max_sdt_p,
      ste_p: ^mmt$segment_descriptor,
      xcb_p: ^ost$execution_control_block,
      xcb_state: tmt$find_next_xcb_state;



{ Get a pointer to the XCB of the first task whose segment table is to be scanned. If the job that
{ owns the file is swapped, this pointer will be NIL. If the job is partially swapped, this
{ request will assign an AJL ordinal. Note that the actual XCBs scanned will be either all XCBs in
{ the system or just XCBs in a specific job.

    jmp$get_ijle_p (aste_p^.ijl_ordinal, ijle_p);
    IF (aste_p^.ijl_ordinal = jmv$system_ijl_ordinal) AND
          (aste_p^.queue_id < mmc$pq_job_base) AND
          (aste_p^.sfid.residence = gfc$tr_system) THEN
      tmp$find_next_xcb (tmc$fnx_system, NIL, jmv$null_ijl_ordinal, xcb_state, xcb_p);
    ELSE
      tmp$find_next_xcb (tmc$fnx_job, ijle_p, aste_p^.ijl_ordinal, xcb_state, xcb_p);
    IFEND;

    recovery := aste_p^.sfid.residence = gfc$tr_system_wait_recovery;
    IF recovery THEN
      trace (mmc$ap_casid_recovery, 1);
    IFEND;

{ If the FDE is accessible (job not swapped and file recovered OR tables in mainframe wired),
{ get a pointer to the FDE and update the ASTI. (If the job is swapped, the FDE will be updated
{ on the next swap-in). If the ASID belongs to a job fixed segment, fix the ASID in the
{ monitor segment table.

    IF ((xcb_p <> NIL) AND (NOT recovery)) OR
          (aste_p^.sfid.residence = gfc$tr_system) THEN
      gfp$mtr_get_locked_fde_p (aste_p^.sfid, ijle_p, fde_p);
      fde_p^.asti := new_asti;
    IFEND;

    IF old_asid = ijle_p^.job_fixed_asid THEN
      ijle_p^.job_fixed_asid := new_asid;
      IF ijle_p^.ajl_ordinal <> jmc$null_ajl_ordinal THEN
        mtv$monitor_segment_table.st [ijle_p^.ajl_ordinal + mtc$job_fixed_segment].ste.asid := new_asid;
      IFEND;
    IFEND;

{ If the job is swapped, then set the delayed swapin flag and fix the ASIDs when the
{ job next swaps in.

    IF xcb_p = NIL THEN
      trace (mmc$ap_casid_swapped_job, 1);
      ijle_p^.delayed_swapin_work := ijle_p^.delayed_swapin_work +
            $jmt$delayed_swapin_work [jmc$dsw_job_asid_changed];


{ If the segment exists in monitor's address space ONLY, nothing needs to be done here. Code
{ further down will fix monitor's segment table. Unlock the ajl set by find_next_xcb.

    ELSEIF (NOT recovery) AND (fde_p^.file_kind = gfc$fk_monitor_only_unnamed) THEN
      trace (mmc$ap_casid_monitor, 1);
      jmp$unlock_ajl (ijle_p);

{ The segment may be in segment tables in one or more jobs in memory. Fix the ASID in all jobs
{ that could be referencing the file.

    ELSE
      IF (NOT recovery) AND (fde_p^.flags.global_template_file) THEN
        mmv$time_changed_template_asid := #FREE_RUNNING_CLOCK (0);
        max_segnum := mmv$max_template_segment_number;
        trace (mmc$ap_casid_template, 1);

      ELSE
        max_segnum := 4095;
        IF (aste_p^.sfid.residence = gfc$tr_system) OR recovery THEN
          IF aste_p^.queue_id >= mmc$pq_job_base THEN
            trace (mmc$ap_casid_job, 1);
          ELSE
            mmv$time_changed_global_asid := #FREE_RUNNING_CLOCK (0);
            trace (mmc$ap_casid_global, 1);
          IFEND;
        IFEND;
      IFEND;


    /fix_ste_loop/
      WHILE xcb_p <> NIL DO
        mmp$get_max_sdt_pointer (xcb_p, sdt_p);
        segnum := xcb_p^.xp.segment_table_length;
        IF segnum > max_segnum THEN
          segnum := max_segnum;
        IFEND;
        WHILE segnum >= 0 DO
          IF sdt_p^.st [segnum].ste.asid = old_asid THEN
            sdt_p^.st [segnum].ste.asid := new_asid;
            sdt_p^.st [segnum].asti := new_asti;
          IFEND;
          segnum := segnum - 1;
        WHILEND;
        tmp$find_next_xcb (tmc$fnx_continue, NIL, jmv$null_ijl_ordinal, xcb_state, xcb_p);
      WHILEND /fix_ste_loop/;

    IFEND;


{ Change the ASID in monitor's segment table and NOS segment table if segment is not pageable.

    IF (aste_p^.queue_id = mmc$pq_wired) THEN
      cell_p := ^mtv$monitor_segment_table;
      #PURGE_BUFFER (osc$pva_purge_segment_cache, cell_p);
      FOR segnum := 0 TO mtc$job_fixed_segment - 1 DO
        IF mtv$monitor_segment_table.st [segnum].ste.asid = old_asid THEN
          mtv$monitor_segment_table.st [segnum].ste.asid := new_asid;
        IFEND;
      FOREND;
      FOR segnum := 0 TO UPPERBOUND (mtv$nos_segment_table_p^.st) DO
        IF mtv$nos_segment_table_p^.st [segnum].ste.asid = old_asid THEN
          mtv$nos_segment_table_p^.st [segnum].ste.asid := new_asid;
        IFEND;
      FOREND;
    IFEND;


{ Purge the segment file and page file to remove any entries that have the old ASID.

    mmp$purge_all_page_seg_map;


  PROCEND mmp$change_asid;
?? TITLE := '[XDCL] mmp$reclaim_ast_entries', EJECT ??
{ PURPOSE
{   This routine is called to search through the AST and free entries that
{   have no pages in memory. The routine is normally called by mmp$periodic_call
{   with accounting being charged to the system.
{   If an AST full condition is imminent, this routine is called by mmp$assign_asid - a user will incur
{   the overhead necessary to try to keep the system from hanging.
{
{ DESIGN:
{   An ASID can be reclaimed if there are no pages in memory using the ASID.  Since there
{   are more ASID than page frames, it should always be possible to reclaim enough ASIDs.
{   When an ASID is reclaimed, the ASID in all segment tables that contain the ASID is
{   zeroed out. Device manager is also notified to update its value of the ASID. Note
{   that ASIDs belonging to swapped out jobs may be reclaimed while the job is swapped out.
{   In this case, the job swapper is responsible for fixing the segment tables
{   at swap-in time.
{

  PROCEDURE [XDCL] mmp$reclaim_ast_entries
    (    asti_that_cannot_be_freed: mmt$ast_index);

    VAR
      asid: ost$asid,
      end_of_table_seen: boolean,
      next_aste_index: mmt$ast_index,
      number_astes_reclaimed: integer;

    next_aste_index := next_asti;
    end_of_table_seen := FALSE;
    number_astes_reclaimed := 0;
    trace (mmc$ap_reclaim_asids, 1);

  /reclaim_loop/

    WHILE number_astes_reclaimed < 30 DO {30 is arbitrary number}
      next_aste_index := next_aste_index - 1;
      IF next_aste_index = 0 THEN
        IF end_of_table_seen THEN
          RETURN;
        IFEND;
        end_of_table_seen := TRUE;
        next_aste_index := UPPERBOUND (mmv$ast_p^);
      IFEND;
      IF mmv$ast_p^ [next_aste_index].in_use AND (mmv$ast_p^ [next_aste_index].pages_in_memory = 0) AND
            (asti_that_cannot_be_freed <> next_aste_index) THEN
        mmp$asid (next_aste_index, asid);
        IF (jmp$ijl_block_valid (mmv$ast_p^ [next_aste_index].ijl_ordinal)) AND
              (jmv$ijl_p.block_p^[mmv$ast_p^ [next_aste_index].ijl_ordinal.block_number].index_p^
              [mmv$ast_p^ [next_aste_index].ijl_ordinal.block_index].entry_status <> jmc$ies_entry_free) THEN
          mmp$change_asid (^mmv$ast_p^ [next_aste_index], asid, 0, 0);
        IFEND;
        mmp$free_asid (asid, ^mmv$ast_p^ [next_aste_index]);
        number_astes_reclaimed := number_astes_reclaimed + 1;
      IFEND;

    WHILEND /reclaim_loop/;

    mmp$purge_all_cache_map;
    last_purge_time := #FREE_RUNNING_CLOCK (0);

  PROCEND mmp$reclaim_ast_entries;
?? OLDTITLE ??
?? TITLE := 'PAGE TABLE MANAGEMENT' ??
?? NEWTITLE := '[XDCL] mmp$make_pt_entry', EJECT ??
{ Purpose:
{   This routine makes an entry in the system page table after
{   checking to make sure a page table entry for the page does
{   not already exist.
{ Input:
{   sva - SVA of any byte in the page
{   pfti - index of page frame to assign to the page
{   aste_p - pointer to AST entry for page
{   pfte_p - pointer to PFT entry for page. ONLY THE PTI ENTRY IS USED. IMPORTANT
{            because REASSIGN_ASID passes a dummy pfte_p.
{ Output:
{   pti - page_table_index of PT entry assigned to the page is stored into the PFT
{         entry located via the PFTE_P input parameter.
{ Error Codes:
{   status - The following errors may be detected by this proc
{      page table full
{      page table entry exists

  VAR
    mmv$page_table_miss_count: [XDCL] array [1 .. 34] of integer;


  PROCEDURE [XDCL] mmp$make_pt_entry
    (    sva: ost$system_virtual_address;
         pfti: mmt$page_frame_index;
         aste_p: ^mmt$active_segment_table_entry;
         pfte_p: ^mmt$page_frame_table_entry;
     VAR mpt_status: mmt$make_pt_entry_status);

    VAR
      cbc_p: ^mmt$continue_bit_count,
      count: 0 .. 33,
      fcount: 0 .. 31,
      found: boolean,
      hcount: 1 .. 32,
      pt_p: ^ost$page_table,
      pte: ost$page_table_entry,
      pti: integer,
      save_pti: integer,
      starting_pti: integer;



{ Calculate the hash index for the page table entry and determine if the page already exists. Return an error
{ code if an entry already exists.

    #HASH_SVA (sva, starting_pti, hcount, found);
    IF found THEN
      mpt_status := mmc$mpt_page_already_exists;
      RETURN;
    IFEND;
    starting_pti := starting_pti - hcount + 1;
    IF starting_pti < 0 THEN
      starting_pti := starting_pti + mmv$pt_length;
    IFEND;



{ Find an available slot for the new page table entry. Set 'continue' bits as required.  Return error if no
{ space is found within 32 entries. Note that early in deadstart, the continue bit array is not allocated.
{ During this time the page table is completely filled with entries with 'C' set.

    count := 1;
    pt_p := mmv$pt_p;
    cbc_p := mmv$continue_bit_count_p;
    pti := starting_pti;
    WHILE (pt_p^ [pti].pageid.asid <> 0) AND (count < mmv$pt_search + 1) DO
      cbc_p^ [pti] := cbc_p^ [pti] + 1;
      IF cbc_p^ [pti] = 1 THEN
        pt_p^ [pti].c := TRUE;
      IFEND;
      count := count + 1;
      pti := pti + 1;
      IF pti = mmv$pt_length THEN
        pti := 0;
      IFEND;
    WHILEND;
    mmv$page_table_miss_count [count] := mmv$page_table_miss_count [count] + 1;


{ If no entry was found within the required 32 entries,try to free some entries in the page table
{ in the area searched. Clear unnecessary continue bits that were set in the above loop.
{ Exit if not possible to make entry in the page table.

    IF count = (mmv$pt_search + 1) THEN
      trace (mmc$ap_mpte_full, 1);
      save_pti := pti;
      free_pt_entry_in_avail_queue (starting_pti, pfti, pti, fcount, found);
      clear_continue_bits (save_pti, (mmv$pt_search + 1) - fcount);
      IF NOT found THEN
        mpt_status := mmc$mpt_page_table_full;
        RETURN;
      IFEND;
      mmv$page_table_miss_count [34] := mmv$page_table_miss_count [34] + 1;
      trace (mmc$ap_mpte_recovered, 1);
    IFEND;


{ Make the new page table entry, preserving the 'continue' bit in the old page table entry.

    pte.v := FALSE;
    pte.c := pt_p^ [pti].c;
    pte.u := TRUE;
    pte.m := FALSE;
    pte.pageid.asid := sva.asid;
    pte.pageid.pagenum :=
    #SHIFT (sva.offset, -9);
    pte.rma :=
    #SHIFT (pfti * osv$page_size, -9);
    pt_p^ [pti] := pte;
    pfte_p^.pti := pti;
    IF NOT aste_p^.in_use THEN
      mtp$error_stop ('MM--MAKE_PT_ENTRY--AST NOT IN USE');
    IFEND;

{ A non-zero changing_asid indicates this procedure was called by page table full processing.  The page is a
{ new page and should be linked to the segment only if the call to this procedure was NOT made for page table
{ full processing.

    IF changing_asid = 0 THEN
      mmp$link_page_to_segment (pfti, pfte_p, aste_p);
    IFEND;
    aste_p^.pages_in_memory := aste_p^.pages_in_memory + 1;
    mmv$pages_to_dump_p^ [pfti] := aste_p^.include_pages_in_dump;
    mpt_status := mmc$mpt_done;

  PROCEND mmp$make_pt_entry;
?? TITLE := '[XDCL] mmp$delete_pt_entry', EJECT ??
{ Purpose:
{   This routine deletes a page table entry for a page.
{
{ Input:
{   pfti - page frame table index of frame assigned to the page
{
{ Output:
{   none
{
{ NOTE !!! Caller must either clear the 'v' bit & purge map in the page table or otherwise ensure
{   that the entry being deleted is NOT being referenced by another CPU in a multi-CPU
{   configuration.
{   The unlink_page_from_segment parameter is used to indicate whether the page should be unlinked
{   from the segment.  This parameter should be FALSE only from a few calls in page table full
{   processing.  Because page table full processing creates two page table entries for one page frame
{   for a short time, the duplicate page table entry must be deleted without unlinking the page frame
{   from the segment.


  PROCEDURE [XDCL] mmp$delete_pt_entry
    (    pfti: mmt$page_frame_index;
         unlink_page_from_segment: boolean);

    VAR
      aste_p: ^mmt$active_segment_table_entry,
      count: integer,
      found: boolean,
      pfte_p: ^mmt$page_frame_table_entry,
      pte_p: ^ost$page_table_entry,
      pti: integer;


{ Entry has been found.  Delete the entry by clearing the valid bit and setting ASID to zero.

    pfte_p := ^mmv$pft_p^ [pfti];
    #HASH_SVA (pfte_p^.sva, pti, count, found);
    pti := pfte_p^.pti;
    pte_p := ^mmv$pt_p^ [pti];

    IF mmc$debug THEN
      IF (pti <> pfte_p^.pti) OR NOT found THEN
        mtp$error_stop ('MM - bad PFT.pti on delete pte');
      IFEND;
      IF (pte_p^.pageid.asid <> pfte_p^.sva.asid) OR (pte_p^.pageid.pagenum * 512 <> pfte_p^.sva.offset) OR
            (pte_p^.rma * 512 <> (pfti * osv$page_size)) THEN
        mtp$error_stop ('MM - illegal delete pte');
      IFEND;
    IFEND;

    pte_p^.v := FALSE;
    pte_p^.pageid.asid := 0;

{ Clear continue bits if necessary.

    IF (count > 1) THEN
      clear_continue_bits (pti, count);
    IFEND;


{ Decrement the 'pages in memory' field of the AST.

    aste_p := pfte_p^.aste_p;
    IF aste_p^.pages_in_memory = 0 THEN
      mtp$error_stop ('MM - delete pte, no pages in memory');
    IFEND;
    aste_p^.pages_in_memory := aste_p^.pages_in_memory - 1;

{ Unlink page from segment is true from all callers except a few specific calls from process page table full.

    IF unlink_page_from_segment THEN
      mmp$unlink_page_from_segment (pfte_p, aste_p);
    IFEND;

  PROCEND mmp$delete_pt_entry;

?? TITLE := 'clear_continue_bits', EJECT ??

  PROCEDURE [INLINE] clear_continue_bits
    (    xpti: ost$page_table_index;
         count: integer);

    VAR
      i: integer,
      pti: integer;


{ Clear 'continue' bits as required.  Decrement the count of the number of times the
{ bit is 'set'. When the count goes to zero, clear the continue bit in the page table.

    pti := xpti;
    FOR i := 2 TO count DO
      pti := pti - 1;
      IF pti < 0 THEN
        pti := mmv$pt_length - 1;
      IFEND;
      mmv$continue_bit_count_p^ [pti] := mmv$continue_bit_count_p^ [pti] - 1;
      IF mmv$continue_bit_count_p^ [pti] = 0 THEN
        mmv$pt_p^ [pti].c := FALSE;
      IFEND;
    FOREND;

  PROCEND clear_continue_bits;

?? TITLE := 'mmp$link_page_to_segment', EJECT ??
{ Purpose:
{   This procedure is called from mmp$make_pt_entry to insert the page frame into the
{   thread which links all pages of a segment that are in memory.  There must be NO OTHER CALLERS
{   of this procedure, or the integrity of the links will be destroyed.

  PROCEDURE [XDCL, INLINE] mmp$link_page_to_segment
    (    pfti: mmt$page_frame_index;
         pfte_p: ^mmt$page_frame_table_entry;
         aste_p: ^mmt$active_segment_table_entry);

{ Debug code

    IF (pfte_p^.segment_link.fwd <> 0) OR (pfte_p^.segment_link.bkw <> 0) THEN
      mtp$error_stop ('LINK PAGE TO SEGMENT ERROR');
    IFEND;

    IF (aste_p^.pages_in_memory = 0) AND ((aste_p^.pft_link.bkw <> 0) OR (aste_p^.pft_link.fwd <> 0)) THEN
      mtp$error_stop ('LINK PAGE TO SEGMENT ERROR--AST');
    IFEND;

{ End debug code

    IF aste_p^.pft_link.fwd = 0 THEN
      aste_p^.pft_link.fwd := pfti;
      aste_p^.pft_link.bkw := pfti;
    ELSE
      mmv$pft_p^ [aste_p^.pft_link.bkw].segment_link.fwd := pfti;
      pfte_p^.segment_link.bkw := aste_p^.pft_link.bkw;
      aste_p^.pft_link.bkw := pfti;
    IFEND;

  PROCEND mmp$link_page_to_segment;

?? TITLE := 'mmp$unlink_page_from_segment', EJECT ??
{ Purpose:
{   This procedure is called from mmp$delete_pt_entry to remove the page frame from the
{   thread which links all pages of a segment that are in memory.  There must be NO OTHER CALLERS
{   of this procedure, or the integrity of the links will be destroyed.

  PROCEDURE [XDCL, INLINE] mmp$unlink_page_from_segment
    (    pfte_p: ^mmt$page_frame_table_entry;
         aste_p: ^mmt$active_segment_table_entry);


    IF pfte_p^.segment_link.fwd = 0 THEN
      aste_p^.pft_link.bkw := pfte_p^.segment_link.bkw;
    ELSE
      mmv$pft_p^ [pfte_p^.segment_link.fwd].segment_link.bkw := pfte_p^.segment_link.bkw;
    IFEND;

    IF pfte_p^.segment_link.bkw = 0 THEN
      aste_p^.pft_link.fwd := pfte_p^.segment_link.fwd;
    ELSE
      mmv$pft_p^ [pfte_p^.segment_link.bkw].segment_link.fwd := pfte_p^.segment_link.fwd;
    IFEND;

    pfte_p^.segment_link.fwd := 0;
    pfte_p^.segment_link.bkw := 0;

{ Debug code

    IF (changing_asid = 0) AND (aste_p^.pages_in_memory = 0) AND
          ((aste_p^.pft_link.bkw <> 0) OR (aste_p^.pft_link.fwd <> 0)) THEN
      mtp$error_stop ('LINK PAGE TO SEGMENT ERROR--AST');
    IFEND;

{ End deubg

  PROCEND mmp$unlink_page_from_segment;

?? TITLE := ' free_pt_entry_in_avail_queue ', EJECT ??
{ PURPOSE
{   This procedure is used in page table full processing. It scans the 32 page table entries starting
{   at the specified hash index.If an entry in the AVAIL queue is found, it is freed.
{
{ INPUT:
{    initial_pti: starting hash index
{    initial_pfti: PFT index of page frame that is being entered into page table
{            A PT entry belonging to this page will NOT be deleted. (required for page table
{            full processing - see REASSIGN_ASID.
{ OUTPUT:
{    pti : index to freed entry (undefined if no entry freed)
{    count: number of entries searched (- 1) before finding entry to free (0 = none found)
{    freed: boolean to indicate if entry freed

  PROCEDURE free_pt_entry_in_avail_queue
    (    initial_pti: integer;
         initial_pfti: mmt$page_frame_index;
     VAR xpti: integer;
     VAR xcount: 0 .. 31;
     VAR freed: boolean);

    VAR
      count: 0 .. 31,
      pfte: mmt$page_frame_table_entry,
      pfti: mmt$page_frame_index,
      pte_p: ^ost$page_table_entry,
      pti: integer;

{ Scan the 32 entries and free the first entry found that is in the AVAIL queue. NOTE:
{ link the page frame to the FREE queue only if the PFT.PTI field is correct. If its not
{ correct, then the entry must belong to segment that is having its ASID reassigned as
{ a result of a PAGE_TABLE_FULL condition. Also, an entry using the SAME page frame as the one
{ for which a new page table entry is being made cannot be deleted. This case arises during page
{ table full processing - both entries must exist at the same time in order for the
{ page table full algorithms to work.

    pti := initial_pti;
    FOR count := 0 TO mmv$pt_search - 1 DO
      pte_p := ^mmv$pt_p^ [pti];
      IF NOT pte_p^.m THEN
        pfti := (pte_p^.rma * 512) DIV osv$page_size;
        IF (pfti >= LOWERBOUND (mmv$pft_p^)) AND (pfti <= UPPERBOUND (mmv$pft_p^)) AND
              (mmv$pft_p^ [pfti].queue_id = mmc$pq_avail) AND (pfti <> initial_pfti) THEN
          trace (mmc$ap_mpte_rec1, 1);
          IF mmv$pft_p^ [pfti].pti = pti THEN
            trace (mmc$ap_mpte_rec2, 1);
            mmp$delete_pt_entry (pfti, TRUE);
            mmp$relink_page_frame (pfti, mmc$pq_free);
          ELSEIF (pte_p^.pageid.asid = changing_asid) THEN
            pfte := mmv$pft_p^ [pfti];
            mmv$pft_p^ [pfti].sva.asid := pte_p^.pageid.asid;
            mmv$pft_p^ [pfti].pti := pti;
            mmv$pft_p^ [pfti].aste_p := changing_aste_p;
            mmp$delete_pt_entry (pfti, FALSE);
            mmv$pft_p^ [pfti] := pfte;
          ELSE
            mtp$error_stop ('MM - PT/PFT mismatch');
          IFEND;
          xcount := count;
          xpti := pti;
          freed := TRUE;
          RETURN;
        IFEND;
      IFEND;
      pti := pti + 1;
      IF pti = mmv$pt_length THEN
        pti := 0;
      IFEND;
    FOREND;

    xcount := 0;
    freed := FALSE;

  PROCEND free_pt_entry_in_avail_queue;
?? OLDTITLE ??
?? TITLE := 'PAGE TABLE FULL MANAGER' ??
?? NEWTITLE := '[XDCL] mmp$process_pt_full', EJECT ??
{ PURPOSE:
{   This procedure is called to try to recover from a 'page table full' condition.
{   The procedure does the following:
{     . try to reassign an ASID in the portion of the PT that is full.
{     . try to free or write to disk all pages in the part of the PT that
{       is full. (this step is attempted only if the previous step failed).
{
{ INPUT:
{     sva: SVA that caused PT full.
{
{ OUTPUT:
{     new_asid: new asid assigned
{     new_asti: asti of reassigned ASID
{     new_aste_p: aste_p of reassigned ASID
{     pt_full_status: indicates status of reassignment


  PROCEDURE [XDCL] mmp$process_page_table_full
    (    sva: ost$system_virtual_address;
     VAR new_asid: ost$asid;
     VAR new_asti: mmt$ast_index;
     VAR new_aste_p: ^mmt$active_segment_table_entry;
     VAR pt_full_status: mmt$pt_full_status);

    VAR
      asidl: asid_list_index_type,
      asidlmax: asid_list_index_type,
      asidt: [XDCL, STATIC] asid_list, {xdcled for debug only}
      asti_that_cannot_be_freed: mmt$ast_index,
      count: 1 .. 32,
      found: boolean,
      ijle_p: ^jmt$initiated_job_list_entry,
      inhibit_io: boolean,
      mcount: integer,
      pass: reassign_pass,
      pfte_p: ^mmt$page_frame_table_entry,
      pfti: mmt$page_frame_index,
      pte_p: ^ost$page_table_entry,
      pti: integer,
      pti_offset: 0 .. 32,
      rcount: integer,
      sort_index: asid_list_index_type;


{ Reclaim unused ast entries.

    IF mmv$async_work.reclaim_astes THEN
      mmv$async_work.reclaim_astes := FALSE;
      mmp$asti (sva.asid, asti_that_cannot_be_freed);
      mmp$reclaim_ast_entries (asti_that_cannot_be_freed);
    IFEND;

{ Find the page table index that caused the page table full condition.

    #HASH_SVA (sva, pti, count, found);
    pti := pti - count + 1;
    IF pti < 0 THEN
      pti := pti + mmv$pt_length;
    IFEND;

    mmv$pt_full_trace.last_sva := sva;
    mmv$pt_full_trace.timestamp := #FREE_RUNNING_CLOCK (0);


{ Generate the list of ASIDs that can be changed to eliminate the page table full
{ condition. The list is sorted in order of 'easiest to change'.

    build_asid_list (sva.asid, pti, ^asidt, asidlmax);


{ Try to reassign an ASID until sucessful or reached end of list.

    trace (mmc$ap_ptf_called, 1);
    FOR sort_index := 1 TO asidlmax DO
      trace (mmc$ap_ptf_tried, 1);
      asidl := asidt [sort_index].index;
      reassign_asid (asidt [asidl].asid, asidt [asidl].aste_p, new_asid, new_asti, new_aste_p,
            pt_full_status);
      IF pt_full_status = mmc$pfs_asid_reassigned THEN
        IF asidt [asidl].asid = sva.asid THEN
          pt_full_status := mmc$pfs_input_asid_reassigned;
        IFEND;
        mmv$pt_full_trace.index := mmv$pt_full_trace.index + 1;
        IF mmv$pt_full_trace.index > 127 THEN
          mmv$pt_full_trace.index := 0;
        IFEND;
        mmv$pt_full_trace.asid [mmv$pt_full_trace.index].old := asidt [asidl].asid;
        mmv$pt_full_trace.asid [mmv$pt_full_trace.index].new := new_asid;
        mmv$pt_full_trace.changed_asid := mmv$pt_full_trace.changed_asid + 1;
        pass := asidt [asidl].sort_key DIV osc$max_page_frames;
        mmv$pt_full_trace.pass [pass] := mmv$pt_full_trace.pass [pass] + 1;
        RETURN; {<------}
      IFEND;
    FOREND;


{ Reassigning an ASID failed. Try to free pages in the part of the PT that has
{ the PT full condition by removing pages from job working sets of jobs that
{ are in the part of the page table that is full. This may write the page to disk.

    trace (mmc$ap_ptf_failed, 1);
    FOR pti_offset := 0 TO mmv$pt_search - 1 DO
      pte_p := ^mmv$pt_p^ [(pti)];
      pfti := (pte_p^.rma * 512) DIV osv$page_size;
      IF (pte_p^.pageid.asid <> 0) AND (pfti >= LOWERBOUND (mmv$pft_p^)) AND (pfti <= UPPERBOUND (mmv$pft_p^))
            THEN
        pfte_p := ^mmv$pft_p^ [pfti];
        IF ((pfte_p^.queue_id >= mmc$pq_shared_first) AND (pfte_p^.queue_id <= mmc$pq_shared_last)) OR
              (pfte_p^.queue_id = mmc$pq_job_working_set) THEN
          mmp$get_inhibit_io_status (pfte_p^.ijl_ordinal, TRUE {lock ajl} , inhibit_io, ijle_p);
          IF NOT inhibit_io THEN
            trace (mmc$ap_ptf_remove, 1);
            mmp$remove_page_from_jws (pfti, ijle_p, mcount, rcount);
            jmp$unlock_ajl (ijle_p);
          IFEND;
        IFEND;
      IFEND;
      pti := pti + 1;
      IF pti = mmv$pt_length THEN
        pti := 0;
      IFEND;
    FOREND;

    pt_full_status := mmc$pfs_failed;
    mmv$pt_full_trace.failed := mmv$pt_full_trace.failed + 1;


  PROCEND mmp$process_page_table_full;
?? TITLE := 'build_asid_list', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to examine the 32 entries in the page
{   table where the page table full occured.  A list of the unique ASIDs is
{   generated and sorted in order of easiest to reassign to hardest to reassign.
{
{ INPUT:
{   pt_full_asid: This parameter specifies the ASID that
{        hashed into the page table full area.
{   pt_full_index: This parameter is the index of the first
{        entry in the page table of the full area.
{   asid_list_p: This parameter points to the array for the
{        ASID list in the page table full area.
{
{ OUTPUT:
{   asid_list: (built in array pointed to by asid_list_p) List of ASID for potential
{        reassignment. List is sorted in order of least overhead of reassignment.
{   max_asid_list_index: index of the last entry in the ASID list.


{  Define type definition for the list of ASIDs returned by BUILD_ASID_LIST.

  TYPE
    asid_list_entry = record
      index: asid_list_index_type,
      sort_key: asid_list_key,
      asid: ost$asid,
      aste_p: ^mmt$active_segment_table_entry,
    recend,
    asid_list_index_type = 0 .. 33,
    asid_list_key = 0 .. osc$max_page_frames * 16,
    asid_list = array [1 .. 33] of asid_list_entry,
    reassign_pass = 1 .. 3;


  PROCEDURE build_asid_list
    (    pt_full_asid: ost$asid;
         pt_full_index: ost$page_table_index;
         asid_list_p: ^asid_list;
     VAR max_asid_list_index: asid_list_index_type);

    VAR
      asid: ost$asid,
      asid_list_index: asid_list_index_type,
      asid_list_index_max: asid_list_index_type,
      aste_p: ^mmt$active_segment_table_entry,
      done: boolean,
      ijle_p: ^jmt$initiated_job_list_entry,
      inhibit_reassign: boolean,
      pass: reassign_pass,
      pfti: mmt$page_frame_index,
      pti: integer,
      pti_offset: 0 .. 31,
      save_index: 0 .. 32;


{ If the image file is still being processed, discard all image pages. Pages that are still needed
{ will be faulted for again and new page table entries will be made.

    IF mmv$image_file.active THEN
      mmp$free_image_pages_mtr;
    IFEND;


{ Build an array of the ASIDs in the part of the PT that are involved in the
{ PT full condition. Ignore special ASIDs used by NOS or SSR. Skip free entries in the page table. If free
{ entries are encountered then either 1) PT full condition has cleared, or 2) more than one entry
{ is required in the page table. There is (currently) no way to distinguish between the cases. Since the
{ PT full condition may have been caused by a request that requires MULTIPLE entries to be made in the
{ page table, this routine cannot quit when a free entry is found.
{!NOTE: current algorithm does NOT force out pages in the AVAIL MODIFIED queue. This is ok until we start
{ to keep large numbers of pages in this queue. Then we should write pages unless IO in inhibited.
{ Note that FFFF cannot be reassigned (special significance to hardware) and the ASID of the page table
{ cannot be reassigned (requires mods to preset_memory routine.)

    asid_list_index_max := 0;
    pti := pt_full_index;

    FOR pti_offset := 0 TO mmv$pt_search - 1 DO

      IF pti_offset <> (mmv$pt_search - 1) THEN
        asid := mmv$pt_p^ [pti].pageid.asid;
        pfti := (mmv$pt_p^ [pti].rma * 512) DIV osv$page_size;
        IF (asid <> 0) AND (pfti >= LOWERBOUND (mmv$pft_p^)) AND (pfti <= UPPERBOUND (mmv$pft_p^)) THEN
          aste_p := mmv$pft_p^ [pfti].aste_p;
        ELSE
          asid := 0;
        IFEND;
      ELSE
        asid := pt_full_asid;
        mmp$aste_pointer (asid, aste_p);
        pfti := 0;
      IFEND;

      IF (asid = 0) OR (asid = 0ffff(16)) OR (asid = dsv$ssr_sdte.ste.asid) OR
            (asid = mtv$monitor_segment_table.st [0].ste.asid) OR (aste_p = NIL) THEN
        {Do nothing - cant change asid}
      ELSEIF (NOT jmp$ijl_block_valid (aste_p^.ijl_ordinal)) OR
            (jmv$ijl_p.block_p^ [aste_p^.ijl_ordinal.block_number].index_p^ [aste_p^.ijl_ordinal.block_index].
            entry_status = jmc$ies_entry_free) THEN
        IF pfti <> 0 THEN
          trace (mmc$ap_ba_freed_terj, 1);
          mmp$delete_pt_entry (pfti, TRUE);
          mmp$relink_page_frame (pfti, mmc$pq_free);
        IFEND;
      ELSE
        IF (aste_p^.sfid.residence = gfc$tr_system) AND (aste_p^.queue_id < mmc$pq_job_base) OR
              (pti_offset = (mmv$pt_search - 1)) THEN
          inhibit_reassign := FALSE;
        ELSE
          mmp$get_inhibit_io_status (aste_p^.ijl_ordinal, FALSE {lock ajl} , inhibit_reassign, ijle_p);
        IFEND;

        IF NOT inhibit_reassign THEN
          asid_list_index := 1;
          asid_list_p^ [asid_list_index_max + 1].asid := asid;
          WHILE (asid <> asid_list_p^ [asid_list_index].asid) DO
            asid_list_index := asid_list_index + 1;
          WHILEND;

          IF asid_list_index > asid_list_index_max THEN

            IF aste_p^.sfid.residence = gfc$tr_job THEN
              pass := 1;
            ELSEIF aste_p^.queue_id >= mmc$pq_job_base THEN
              pass := 2;
            ELSE
              pass := 3;
            IFEND;


            asid_list_index_max := asid_list_index_max + 1;
            asid_list_p^ [asid_list_index_max].sort_key := aste_p^.pages_in_memory + pass *
                  osc$max_page_frames;
            asid_list_p^ [asid_list_index_max].aste_p := aste_p;
            asid_list_p^ [asid_list_index_max].index := asid_list_index_max;
          IFEND;
        IFEND;
      IFEND;

      pti := pti + 1;
      IF pti = mmv$pt_length THEN
        pti := 0;
      IFEND;

    FOREND;


{ Sort the ASID list. List is sorted in the order of 'easiest to reassign'. See procedure
{ mmp$change_asid for more details on 'easy to reassign'.

    done := asid_list_index_max <= 1;
    WHILE NOT done DO
      done := TRUE;
      FOR asid_list_index := 1 TO asid_list_index_max - 1 DO
        IF asid_list_p^ [asid_list_p^ [asid_list_index].index].
              sort_key > asid_list_p^ [asid_list_p^ [asid_list_index + 1].index].sort_key THEN
          save_index := asid_list_p^ [asid_list_index].index;
          asid_list_p^ [asid_list_index].index := asid_list_p^ [asid_list_index + 1].index;
          asid_list_p^ [asid_list_index + 1].index := save_index;
          done := FALSE;
        IFEND;
      FOREND;
    WHILEND;

    max_asid_list_index := asid_list_index_max;

  PROCEND build_asid_list;
?? TITLE := 'reassign_asid - Used with page_table_full_handler', EJECT ??
{ PURPOSE:
{   This procedure is called by the PAGE_TABLE_FULL_HANDLER to reassign an ASID
{   That appears in the part of the page table that is full.
{
{ INPUT:
{    old_asid:    ASID to be reassigned
{    old_aste_p:  pointer to the AST table entry for the segment
{
{ OUTPUT:
{    new_asid:    newly assigned ASID
{    new_asti:    newly assigned AST index
{    new_aste_p:  newly assigned AST pointer
{    pt_full_status: status of reassign request
{       mmc$pfs_asid_reassigned
{       mmc$pfs_failed
{


  PROCEDURE reassign_asid
    (    old_asid: ost$asid;
         old_aste_p: ^mmt$active_segment_table_entry;
     VAR new_asid: ost$asid;
     VAR new_asti: mmt$ast_index;
     VAR new_aste_p: ^mmt$active_segment_table_entry;
     VAR pt_full_status: mmt$pt_full_status);

    VAR
      count: 1 .. 32,
      found: boolean,
      pti: integer,
      mpt_status: mmt$make_pt_entry_status,
      new_pte_p: ^ost$page_table_entry,
      new_sva: ost$system_virtual_address,
      temp_sva: ost$system_virtual_address,
      old_pte_p: ^ost$page_table_entry,
      old_sva: ost$system_virtual_address,
      pfte: mmt$page_frame_table_entry,
      pfte_p: ^mmt$page_frame_table_entry,
      pfti: mmt$page_frame_index,
      stop_pfti: mmt$page_frame_index,
      try_count: 0 .. 4;


{ Build the list of PFTIs for the segment being changed.

    old_sva.asid := old_asid;
    old_sva.offset := 0;
    mmp$initialize_find_next_pfti (old_sva, 7ffffff0(16), include_partial_pages, psc_all, old_aste_p, pfti);


{ Try several times to assign a new ASID for the segment.

    FOR try_count := 1 TO UPPERVALUE (try_count) DO
      mmp$assign_asid (new_asid, new_asti, new_aste_p);
      new_sva.asid := new_asid;
      new_aste_p^ := old_aste_p^;
      new_aste_p^.pages_in_memory := 0;
      mmp$reset_find_next_pfti (pfti);


{ Make page table entries using the new ASID for each page of the segment
{ that is currently in memory. Note that for a short time both the old and new PT entries
{ will exist. CAUTIONS:
{     - If PT full conditions occur during mmp$make_pt_entry, PT entries that are in the AVAIL
{       queue may be freed.
{     - Since mmp$make_pt_entry may freed PT entries, some of the PFTI in the pfti array
{       may already have been freed before this routine trys to change the ASID.
{ If a page table entry cannot be made and the page is in the AVAIL queue, the entry can be skipped.
{ Later in this procedure, the page will be deleted and linked to the FREE queue.
{ Note that the ^PFT entry passed to mmp$make_pt_entry is a dummy entry.
{
{ When this loop exits (either normally or abnormally, each page frame in the PFTI list  will
{ have 0, 1 or 2 page table entries for the page frame:
{    - both old and new (this is the state for ALL page frames except those in the AVAIL queue)
{    - old only. New was not made because PT full occurred.
{    - old only. New was made but was subsequently deleted by mmp$make_pt_entry due to PT full.
{    - new only. Old was deleted by PT full processing in mmp$make_pt_entry after new entry was made.
{    - no entries. Combination of previous 2 entries.

      trace (mmc$ap_rea_called, 1);

    /reassign_loop/
      BEGIN
        changing_asid := new_asid;
        changing_aste_p := new_aste_p;
        WHILE pfti <> 0 DO
          pfte_p := ^mmv$pft_p^ [pfti];
          IF pfte_p^.queue_id = mmc$pq_free THEN
            trace (mmc$ap_rea_in_free, 1);
            mmp$delete_last_pfti_from_array;
          ELSE
            trace (mmc$ap_rea_make_pt_entry, 1);
            new_sva.offset := pfte_p^.sva.offset;
            mmp$make_pt_entry (new_sva, pfti, new_aste_p, ^pfte, mpt_status);
            IF (mpt_status <> mmc$mpt_done) THEN
              IF (pfte_p^.queue_id <> mmc$pq_avail) THEN
                EXIT /reassign_loop/;
              IFEND;
              trace (mmc$ap_rea_mpte_fail, 1);
            ELSE
              old_pte_p := ^mmv$pt_p^ [pfte_p^.pti];
              new_pte_p := ^mmv$pt_p^ [pfte.pti];
              new_pte_p^.u := FALSE;
              new_pte_p^.v := old_pte_p^.v;
            IFEND;
          IFEND;
          mmp$find_next_pfti (pfti);
        WHILEND;
        changing_asid := 0;




{ Page table entries have been made for all pages of the segment. Now locate
{ all segment table entries that have the ASID and change it to the new ASID.

        mmp$change_asid (old_aste_p, old_asid, new_asid, new_asti);


{ If the ASID being changed belongs to mainframe wired, save the new ASID. This is required in case
{ the system crashes while the next couple of blocks of CYBIL statements are being executed. System
{ recovery
{ must be able to locate PT entries that belong to mainframe wired.

        IF old_asid = mmv$mf_wired_asid.current THEN
          mmv$mf_wired_asid.new := new_asid;
        IFEND;


{ Now delete the PT entries that have the old ASID and update the PFT with the
{ new segment info. The correct value of the 'used' and 'modified' bits are captured
{ here from the old entries and copied to the new PT entries.

        trace (mmc$ap_rea_ok, 1);
        mmp$reset_find_next_pfti (pfti);
        WHILE pfti <> 0 DO
          pfte_p := ^mmv$pft_p^ [pfti];
          IF pfte_p^.queue_id <> mmc$pq_free THEN
            temp_sva.offset := pfte_p^.sva.offset;
            temp_sva.asid := new_asid;
            #HASH_SVA (temp_sva, pti, count, found);
            IF NOT found THEN

{ Set changing_asid to a non-zero value to indicate that page table full processing is occurring.
{ This page frame is in the available queue and a new page table entry could not be made, so
{ delete_pt_entry will unlink the page from the segment.  Because page frames that had a new page
{ table entry made for them will not be unlinked from the segment, the debug code in unlink page
{ from segment must not be executed.  (If this is the last page in the segment, the ast.pages_in_memory
{ will be zero, but the ast.pft_link will still have the links to be copied to the new ast entry later.)

              changing_asid := 1;
              mmp$delete_pt_entry (pfti, TRUE);
              changing_asid := 0;
              pfte_p^.sva.asid := new_asid;
              trace (mmc$ap_rea_ok1, 1);
              mmp$relink_page_frame (pfti, mmc$pq_free);
            ELSE
              mmp$delete_pt_entry (pfti, FALSE);
              pfte_p^.sva.asid := new_asid;
              trace (mmc$ap_rea_ok2, 1);
              IF mmv$pt_p^ [pfte_p^.pti].m THEN
                mmv$pt_p^ [pti].m := TRUE;
              IFEND;
              IF mmv$pt_p^ [pfte_p^.pti].u THEN
                mmv$pt_p^ [pti].u := TRUE;
              IFEND;
              pfte_p^.pti := pti;
              pfte_p^.aste_p := new_aste_p;
            IFEND;
          ELSE
            trace (mmc$ap_rea_ok3, 1);
            pfte := pfte_p^;
            pfte_p^.sva.asid := new_asid;
            #HASH_SVA (pfte_p^.sva, pti, count, found);
            IF found THEN
              trace (mmc$ap_rea_ok4, 1);
              pfte_p^.pti := pti;
              pfte_p^.aste_p := new_aste_p;
              mmp$delete_pt_entry (pfti, FALSE);
            IFEND;
            pfte_p^ := pfte;
          IFEND;
          mmp$find_next_pfti (pfti);
        WHILEND;

{ Copy the ast.pft_link information again; delete_pt_entry may have changed the links.

        new_aste_p^.pft_link := old_aste_p^.pft_link;
        old_aste_p^.pft_link.fwd := 0;
        old_aste_p^.pft_link.bkw := 0;

        mmp$free_asid (old_asid, old_aste_p);


{ If the ASID that was changed belonged to mainframe wired, update the
{ mainframe-wired-asid record.

        IF old_asid = mmv$mf_wired_asid.current THEN
          mmv$mf_wired_asid.current := mmv$mf_wired_asid.new;
          mmv$mf_wired_asid.new := 0;
        IFEND;

        pt_full_status := mmc$pfs_asid_reassigned;
        RETURN; { <-------}

      END /reassign_loop/;
      changing_asid := 0;


{ Control gets here only if a page table entry could not be made for the new ASID.
{ Delete all PT entries made with the new ASID and try again. NOTE: If an entry cannot be found,
{ then it must have been in the AVAIL queue and was deleted by mmp$make_pt_entry as a
{ result of page table full processing.

      stop_pfti := pfti;
      mmp$reset_find_next_pfti (pfti);
      trace (mmc$ap_rea_fail, 1);
      WHILE pfti <> stop_pfti DO
        trace (mmc$ap_rea_fail1, 1);
        pfte_p := ^mmv$pft_p^ [pfti];
        new_sva.offset := pfte_p^.sva.offset;
        #HASH_SVA (new_sva, pti, count, found);
        IF found THEN
          trace (mmc$ap_rea_fail2, 1);
          pfte := pfte_p^;
          pfte_p^.pti := pti;
          pfte_p^.sva.asid := new_asid;
          pfte_p^.aste_p := new_aste_p;
          mmp$delete_pt_entry (pfti, FALSE);
          pfte_p^ := pfte;
        IFEND;
        mmp$find_next_pfti (pfti);
      WHILEND;
      new_aste_p^.pft_link.fwd := 0;
      new_aste_p^.pft_link.bkw := 0;
      mmp$free_asid (new_asid, new_aste_p);
    FOREND;


{ Control gets here only if all attempts to reassign the ASID fail. Return
{ bad status and exit.

    trace (mmc$ap_rea_quit, 1);
    pt_full_status := mmc$pfs_failed;

  PROCEND reassign_asid;

MODEND mmm$asid_page_table_manager
*DECK DECK=MMM$BOOT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Memory Manager : Boot' ??
MODULE mmm$boot;

{ PURPOSE:
{   This module contains the boot procedures for memory manager.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc mmc$first_transient_segment
*copyc mme$condition_codes
*copyc mmt$page_frame_table
*copyc mmt$segment_descriptor_table
*copyc mmt$segment_descriptor_table_ex
*copyc pmt$task_id
*copyc osc$purge_map_and_cache
*copyc osd$cybil_structure_definitions
*copyc ost$hardware_subranges
?? POP ??
*copyc dsp$get_data_from_ssr
*copyc mmp$get_max_sdt_pointer
*copyc mmp$get_max_sdt_sdtx_pointer
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$find_executing_task_xcb
?? EJECT ??
*copyc jmv$jmtr_xcb
*copyc jmv$sdt
*copyc jmv$sdtx
*copyc mmv$free_pages
*copyc mmv$next_free_page
*copyc mmv$pt_length
*copyc mmv$pt_p
*copyc osv$180_memory_limits
*copyc osv$mainframe_wired_heap
*copyc osv$page_size
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    mmv$default_sdtx_entry: [XDCL] mmt$segment_descriptor_extended,
    mmv$first_transient_seg_index: [XDCL] ost$segment := mmc$first_transient_segment,
    mmv$pft_p: [XDCL, #GATE] ^mmt$page_frame_table := NIL;
?? TITLE := 'mmp$boot_add_sdt_sdtx_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$boot_add_sdt_sdtx_entry
    (    xsdt_entry: mmt$segment_descriptor;
         xsdtx_entry: mmt$segment_descriptor_extended;
     VAR segment_number {input, output} : ost$segment);

    VAR
      buffer_p: ^cell,
      sdt_entry: mmt$segment_descriptor,
      sdt_p: mmt$max_sdt_p,
      segment_table_length: integer,
      temp_segment_number: ost$segment,
      xcb_p: ^ost$execution_control_block;

    sdt_entry := xsdt_entry;

    pmp$find_executing_task_xcb (xcb_p);
    temp_segment_number := segment_number;

    { Find an available segment number if the caller did not supply one.

    mmp$get_max_sdt_pointer (xcb_p, sdt_p);
    IF segment_number = 0 THEN
      temp_segment_number := mmv$first_transient_seg_index - 1;
      segment_table_length := xcb_p^.xp.segment_table_length;
      REPEAT
        temp_segment_number := temp_segment_number + 1;
        IF temp_segment_number > segment_table_length THEN
          osp$system_error ('Segment table too small', NIL);
        IFEND;
      UNTIL sdt_p^.st [temp_segment_number].ste.vl = osc$vl_invalid_entry;
    IFEND;

    { NOTE:  SINGLE PROCESSOR - CACHE BYPASS IS NOT A PROBLEM.

    sdt_p^.st [temp_segment_number] := sdt_entry;
    buffer_p := NIL;
    #PURGE_BUFFER (osc$purge_all_page_seg_map, buffer_p);
    segment_number := temp_segment_number;

  PROCEND mmp$boot_add_sdt_sdtx_entry;
?? TITLE := 'mmp$create_sdtx_entry', EJECT ??

  PROCEDURE [XDCL] mmp$create_ssr_sdtx
    (VAR sdt_entry: mmt$segment_descriptor;
     VAR sdtx_entry: mmt$segment_descriptor_extended);

  PROCEND mmp$create_ssr_sdtx;

?? TITLE := 'mmp$fetch_boot_memory_bounds', EJECT ??

  PROCEDURE [XDCL] mmp$fetch_boot_memory_bounds
    (VAR first_byte_address: integer;
     VAR length: integer);

    VAR
      memory_bounds: dst$ssr_boot_memory_bounds,
      memory_bounds_seq_p: ^SEQ ( * );

    memory_bounds_seq_p := #SEQ (memory_bounds);
    dsp$get_data_from_ssr (dsc$ssr_boot_memory_bounds, memory_bounds_seq_p);

    first_byte_address := (memory_bounds.start_address.r_upper * 10000(8) +
          memory_bounds.start_address.r_lower) * 1000(8);

    length := (memory_bounds.length.r_upper * 10000(8) + memory_bounds.length.r_lower) * 1000(8);

  PROCEND mmp$fetch_boot_memory_bounds;
?? TITLE := 'mmp$initialize', EJECT ??

  PROCEDURE [XDCL] mmp$initialize;

    VAR
      ptl_register: integer,
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      xcb_p: ^ost$execution_control_block;

    { Set up static data constants.

    ptl_register := #READ_REGISTER (osc$pr_page_table_length);
    mmv$pt_p := #ADDRESS (1, 0, 0);
    mmv$pt_length := (ptl_register + 1) * 512;
    osv$page_size := 512 * (128 - #read_register (osc$pr_page_size_mask));

    osv$180_memory_limits.lower := ((osv$180_memory_limits.lower + osv$page_size - 1) DIV osv$page_size)
          * osv$page_size;
    osv$180_memory_limits.upper := (osv$180_memory_limits.upper DIV osv$page_size) * osv$page_size;

{ Set offsets of the sdt and sdtx in the XCB.

    xcb_p := ^jmv$jmtr_xcb;

    sdt_p := #LOC (jmv$sdt);
    xcb_p^.sdt_offset := #OFFSET (sdt_p);

    sdtx_p := #LOC (jmv$sdtx);
    xcb_p^.sdtx_offset := #OFFSET (sdtx_p);

  PROCEND mmp$initialize;
?? TITLE := 'mmp$initialize_boot_pages', EJECT ??

  PROCEDURE [XDCL] mmp$initialize_boot_pages
    (VAR lower_bound: integer;
     VAR upper_bound: integer);

    VAR
      first_byte_address: integer,
      index: integer,
      length: integer,
      lower_memory_limits: integer,
      page_frame_list_p: ^ARRAY [ * ] OF 0 .. osc$max_page_frames,
      pft_rma: integer,
      upper_memory_limits: integer,
      touch_pages: 1 .. 2;

    mmp$fetch_boot_memory_bounds (first_byte_address, length);

    lower_memory_limits := osv$180_memory_limits.lower DIV osv$page_size;
    upper_memory_limits := osv$180_memory_limits.upper DIV osv$page_size;
    ALLOCATE page_frame_list_p: [lower_memory_limits .. upper_memory_limits] IN osv$mainframe_wired_heap^;
    first_byte_address := #READ_REGISTER (osc$pr_page_table_address) + (mmv$pt_length * 8);
    lower_bound := first_byte_address DIV osv$page_size;
    IF length = 0 THEN
      upper_bound := upper_memory_limits;
    ELSE
      upper_bound := (first_byte_address + length) DIV osv$page_size;
    IFEND;

    FOR index := lower_memory_limits TO upper_memory_limits DO
      page_frame_list_p^ [index] := 0;
    FOREND;

    { The following code is executed twice - once to flush out any page faults generated by the code
    { itself, and a second time to actually initialize the page list.

    FOR touch_pages := 1 TO 2 DO

      FOR index := lower_bound TO upper_bound - 1 DO
        page_frame_list_p^ [index] := 1;
      FOREND;

      { Remove in use pages.

      FOR index := 0 TO (mmv$pt_length - 1) DO
        IF mmv$pt_p^ [index].pageid.asid <> 0 THEN
          pft_rma := mmv$pt_p^ [index].rma * 512 DIV osv$page_size;
          IF (pft_rma >= lower_memory_limits) AND (pft_rma <= upper_memory_limits) AND
                (page_frame_list_p^ [pft_rma] <> 0) THEN
            page_frame_list_p^ [pft_rma] := 0;
          IFEND;
        IFEND;
      FOREND;

      { Link free pages together.

      pft_rma := 0;
      FOR index := upper_bound - 1 DOWNTO lower_bound DO
        IF page_frame_list_p^ [index] <> 0 THEN
          page_frame_list_p^ [index] := pft_rma;
          pft_rma := index;
        IFEND;
      FOREND;

    FOREND;

    mmv$next_free_page := pft_rma;
    mmv$free_pages := page_frame_list_p;

  PROCEND mmp$initialize_boot_pages;
?? TITLE := 'mmp$validate_segment_number', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$validate_segment_number
    (    segment_number: ost$segment;
     VAR sdt_entry_p: ^mmt$segment_descriptor;
     VAR sdtx_entry_p: ^mmt$segment_descriptor_extended;
     VAR status: ost$status);

    VAR
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_xcb (xcb_p);

    IF segment_number > xcb_p^.xp.segment_table_length THEN
      osp$set_status_abnormal ('MM', mme$segment_number_too_big, '', status);
      RETURN;
    IFEND;

    mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);
    sdt_entry_p := ^sdt_p^.st [segment_number];
    sdtx_entry_p := ^sdtx_p^.sdtx_table [segment_number];
    IF sdt_entry_p^.ste.vl = osc$vl_invalid_entry THEN
      osp$set_status_abnormal ('MM', mme$segment_number_not_in_use, '', status);
      RETURN;
    IFEND;

  PROCEND mmp$validate_segment_number;
MODEND mmm$boot;
*DECK DECK=MMM$CACHE_MANAGEMENT_ROUTINES EXPAND=TRUE
mmaasm   ident
mmaasm   ALIAS   MMM$CACHE_MANAGEMENT_ROUTINES
*copyc dsa$cpu_pp_communication_block
*copyc mta$boot_control_table
*copyc mta$cpu_state_table
*copyc osa$basic_register_equates
*copyc sya$xp_and_sf_constants
*copyc sya$cybil_interface_procedures
         page
..........................................................................
.   Define A and X register usage
.
.
acst0    areg    5                     .Pointer to CST for processor 0.
acst     areg    6                     .Pointer to CST.
ascr     areg    7                     .Scratch register.
xindex   xreg    6                     .X register used for indexing thru CST
xcstcnt  xreg    7                     .Number of CST entries in use.
xfrc     xreg    8                     .Free running clock.
         page
         USE     CODE
...........................................................................
.  This procedure is called in a multiprocessor environment to purge the
.  map in all active processors in the mainframe.
...........................................................................
.
pmap     ALIAS   MMP$PURGE_ALL_MAP_PROC
pmap     procedur
*IF $variable(mmv$test_forced_use_cache_maps, declared) <> 'UNKNOWN'
.
         ente    x0,40(16)
         callseg bs_log,a3,a0
*ELSE
.
. -------- Code for forcing the use of cache and maps omitted at compile time --------
*IFEND
.
         la      acst0,a_bindin,bs_cst0 .Get pointer to CST0.
.
         la      ascr,a_bindin,bs_work
         lx      x1,ascr,8             .Increment count of map purges.
         incx    x1,1
         sx      x1,ascr,8
         la      ascr,a_bindin,bs_cstct .Get number of CST entries present.
         lbyts,1 xcstcnt,ascr,x0,0
         cpyax   x1,acst0              .Get pointer to current CST.
         entl    x0,47(16)             .Read the base constant register.
         cpysx   x2,x0
         insb    x1,x2,x0,4037(8)
         cpyxa   acst,x1
.
         entl    x0,r_td               .Disable traps for this sequence.
         cpysx   x1,x0
         cpyxs   x0,x0
         cpytx   xfrc,x0               .Purge map for current processor
         purge   x0,15                 .  and update timestamp in CST.
         sx      xfrc,acst,maptim
         cpyxs   x1,x0                 .Re-enable traps.
.
         cpyaa   acst,acst0            .Set loop scanning registers.
         entp    xindex,1
         entp    x0,pur_map
         entp    x2,1
pm2      lx      x1,acst,maptim        .Get time map last purged.
         brxge   x1,xfrc,pm4           .Jump if no purge necessary.
         sbit    x2,acst,ext_int,x0    .Set request bit for map purge.
         lbyts,1 x1,acst,x0,memport    .Send interrupt to processor.
         intrupt x1
pm4      addaq   acst,acst,cstsize     .Set pointer to next CST entry.
         brinc   xcstcnt,xindex,pm2    .Jump if more CST entries to check.
.
         ente    x3,2FAF(16)           .Generate 50 seconds (in microseconds).
         shfx    x3,x3,x0,12
         cpyaa   acst,acst0            .Reset loop scanning registers.
         entp    xindex,1
.
pm6      lx      x2,acst,cpwell        .Get the value of the cpu_alive flag.
         addx    x2,x3                 .Check if CPU has been alive recently.
         entl    x0,0                  .Get the current FRC.
         cpytx   x4,x0
         brxge   x2,x4,pm8             .Jump if CPU has been alive recently.
.
                                       .Begin code to process ill CPU case.
         la      ascr,a_bindin,bs_bct  .Fetch pointer to Boot Control Table.
         lbyts,6 x1,ascr,x0,0
         cpyxa   ascr,x1
         lx      x1,ascr,bctflags      .Get the flags word.
         shfx    x1,x1,x0,5            .Check the CPU error processing in
                                       .  progress field.
         brxge   x1,x0,pm10            .Jump if not set.
         shfx    x1,x1,x0,1            .Check the CPU error fatal after
                                       .  having been processed field.
         brxgt   x0,x1,pm10            .Jump if set.
         sx      x4,acst,cpwell        .Update cpu_alive flag to allow for
                                       .  longer CPU error processing.
                                       .End code to process ill CPU case.
.
pm8      la      ascr,a_bindin,bs_cpcb .Get ptr to CPU_PP_communications_block.
         sx      x4,ascr,mon_time      .Update timestamp for DFT handshaking.
         lx      x1,acst,maptim        .Get time map last purged.
         brxgt   xfrc,x1,pm6           .Jump if map not yet purged.
         brxeq   x0,x0,pm12
pm10     ente    x2,-2153(16)          .Flag noting dead CPU (DEAD):
         isob    x2,x2,x0,0176(8)      .  looks like 7FFFFFFFFFFFDEAD.
         sx      x2,acst,maptim        .Store it in the Dead CPU's CST.
         sx      x2,acst,cachtim       .Store it in the Dead CPU's CST.
pm12     addaq   acst,acst,cstsize     .Set pointer to next CST entry.
         brinc   xcstcnt,xindex,pm6    .Jump if more CST entries to check.
         la      ascr,a_bindin,bs_mapt
         entp    x0,0
         cpytx   x0,x0
         sx      x0,ascr,0
.
         return
         page
         USE     CODE
...........................................................................
.  This procedure is called in a multiprocessor environment to purge the
.  cache in all active processors in the mainframe.
...........................................................................
.
pcache   ALIAS   MMP$PURGE_ALL_CACHE_PROC
pcache   procedur
.
*IF $variable(mmv$test_forced_use_cache_maps, declared) <> 'UNKNOWN'
         ente    x0,40(16)
         callseg bs_log,a3,a0
*ELSE
. -------- Code for forcing the use of cache and maps omitted at compile time --------
*IFEND
.
         la      acst0,a_bindin,bs_cst0 .Get pointer to CST0.
.
         la      ascr,a_bindin,bs_work
         lx      x1,ascr,0             .Increment count of cache purges
         incx    x1,1
         sx      x1,ascr,0
         la      ascr,a_bindin,bs_cstct .Get number of CST entries present.
         lbyts,1 xcstcnt,ascr,x0,0
         cpyax   x1,acst0              .Get pointer to current CST.
         entl    x0,47(16)             .Read the base constant register.
         cpysx   x2,x0
         insb    x1,x2,x0,4037(8)
         cpyxa   acst,x1
.
         entl    x0,r_td               .Disable traps for this sequence.
         cpysx   x1,x0
         cpyxs   x0,x0
         cpytx   xfrc,x0               .Purge cache for current processor
         purge   x0,2                  .  and update timestamp in CST.
         sx      xfrc,acst,cachtim
         cpyxs   x1,x0                 .Re-enable traps.
.
         cpyaa   acst,acst0            .Set loop scanning registers.
         entp    xindex,1
         entp    x0,pur_ca
         entp    x2,1
pc2      lx      x1,acst,cachtim       .Get time cache last purged.
         brxge   x1,xfrc,pc4           .Jump if no purge necessary.
         sbit    x2,acst,ext_int,x0    .Set request bit for cache purge.
         lbyts,1 x1,acst,x0,memport    .Send interrupt to processor.
         intrupt x1
pc4      addaq   acst,acst,cstsize     .Set pointer to next CST entry.
         brinc   xcstcnt,xindex,pc2    .Jump if more CST entries to check.
.
         ente    x3,2FAF(16)           .Generate 50 seconds (in microseconds).
         shfx    x3,x3,x0,12
         cpyaa   acst,acst0            .Reset loop scanning registers.
         entp    xindex,1
.
pc6      lx      x2,acst,cpwell        .Get the value of the cpu_alive flag.
         addx    x2,x3                 .Check if CPU has been alive recently.
         entl    x0,0                  .Get the current FRC.
         cpytx   x4,x0
         brxge   x2,x4,pc8             .Jump if CPU has been alive recently.
.
                                       .Begin code to process ill CPU case.
         la      ascr,a_bindin,bs_bct  .Fetch pointer to Boot Control Table.
         lbyts,6 x1,ascr,x0,0
         cpyxa   ascr,x1
         lx      x1,ascr,bctflags      .Get the flags word.
         shfx    x1,x1,x0,5            .Check the CPU error processing in
                                       .  progress field.
         brxge   x1,x0,pc10            .Jump if not set.
         shfx    x1,x1,x0,1            .Check the CPU error fatal after
                                       .  having been processed field.
         brxgt   x0,x1,pc10            .Jump if set.
         sx      x4,acst,cpwell        .Update cpu_alive flag to allow for
                                       .  longer CPU error processing.
                                       .End code to process ill CPU case.
.
pc8      la      ascr,a_bindin,bs_cpcb .Get ptr to CPU_PP_communications_block.
         sx      x4,ascr,mon_time      .Update timestamp for DFT handshaking.
         lx      x1,acst,cachtim       .Get time cache last purged.
         brxgt   xfrc,x1,pc6           .Jump if cache not yet purged.
         brxeq   x0,x0,pc12
pc10     ente    x2,-2153(16)          .Flag noting dead CPU (DEAD):
         isob    x2,x2,x0,0176(8)      .  looks like 7FFFFFFFFFFFDEAD.
         sx      x2,acst,maptim        .Store it in the Dead CPU's CST.
         sx      x2,acst,cachtim       .Store it in the Dead CPU's CST.
pc12     addaq   acst,acst,cstsize     .Set pointer to next CST entry.
         brinc   xcstcnt,xindex,pc6    .Jump if more CST entries to check.
.
         return
         page
         USE     CODE
...........................................................................
.  This procedure is called in a multiprocessor environment to purge the
.  cache and map in all active processors in the mainframe.
...........................................................................
.
pall     ALIAS   MMP$PURGE_ALL_CACHE_MAP_PROC
pall     procedur
.
*IF $variable(mmv$test_forced_use_cache_maps, declared) <> 'UNKNOWN'
         ente    x0,40(16)
         callseg bs_log,a3,a0
*ELSE
. -------- Code for forcing the use of cache and maps omitted at compile time --------
*IFEND
.
         la      acst0,a_bindin,bs_cst0 .Get pointer to CST0.
.
         la      ascr,a_bindin,bs_work
         lx      x1,ascr,0             .Increment count of cache purges.
         incx    x1,1
         sx      x1,ascr,0
         lx      x1,ascr,8             .Increment count of map purges.
         incx    x1,1
         sx      x1,ascr,8
         la      ascr,a_bindin,bs_cstct .Get number of CST entries present.
         lbyts,1 xcstcnt,ascr,x0,0
         cpyax   x1,acst0              .Get pointer to current CST.
         entl    x0,47(16)             .Read the base constant register.
         cpysx   x2,x0
         insb    x1,x2,x0,4037(8)
         cpyxa   acst,x1
.
         entl    x0,r_td               .Disable traps for this sequence.
         cpysx   x1,x0
         cpyxs   x0,x0
         cpytx   xfrc,x0               .Purge cache/maps for current processor
         purge   x0,2                  .  and update timestamp in CST.
         purge   x0,15
         sx      xfrc,acst,cachtim
         sx      xfrc,acst,maptim
         cpyxs   x1,x0                 .Re-enable traps.
.
         cpyaa   acst,acst0            .Set loop scanning registers.
         entp    xindex,1
         entp    x2,1
pa2      lx      x1,acst,cachtim       .Get time cache last purged.
         brxgt   xfrc,x1,pa4           .Jump if purge is necessary.
         lx      x1,acst,maptim        .Get time map last purged.
         brxge   x1,xfrc,pa6           .Jump if no purge necessary.
pa4      entp    x0,pur_ca
         sbit    x2,acst,ext_int,x0    .Set request bit for cache purge.
         entp    x0,pur_map
         sbit    x2,acst,ext_int,x0    .Set request bit for map purge.
         lbyts,1 x1,acst,x0,memport    .Send interrupt to processor.
         intrupt x1
pa6      addaq   acst,acst,cstsize     .Set pointer to next CST entry.
         brinc   xcstcnt,xindex,pa2    .Jump if more CST entries to check.
.
         ente    x3,2FAF(16)           .Generate 50 seconds (in microseconds).
         shfx    x3,x3,x0,12
         cpyaa   acst,acst0            .Reset loop scanning registers.
         entp    xindex,1
.
pa8      lx      x2,acst,cpwell        .Get the value of the cpu_alive flag.
         addx    x2,x3                 .Check if CPU has been alive recently.
         entl    x0,0                  .Get the current FRC.
         cpytx   x4,x0
         brxge   x2,x4,pa10            .Jump if CPU has been alive recently.
.
                                       .Begin code to process ill CPU case.
         la      ascr,a_bindin,bs_bct  .Fetch pointer to Boot Control Table.
         lbyts,6 x1,ascr,x0,0
         cpyxa   ascr,x1
         lx      x1,ascr,bctflags      .Get the flags word.
         shfx    x1,x1,x0,5            .Check the CPU error processing in
                                       .  progress field.
         brxge   x1,x0,pa16            .Jump if not set.
         shfx    x1,x1,x0,1            .Check the CPU error fatal after
                                       .  having been processed field.
         brxgt   x0,x1,pa16            .Jump if set.
         sx      x4,acst,cpwell        .Update cpu_alive flag to allow for
                                       .  longer CPU error processing.
                                       .End code to process ill CPU case.
.
pa10     la      ascr,a_bindin,bs_cpcb .Get ptr to CPU_PP_communications_block.
         sx      x4,ascr,mon_time      .Update timestamp for DFT handshaking.
         lx      x1,acst,cachtim       .Get time cache last purged.
         brxgt   xfrc,x1,pa8           .Jump if cache not yet purged.
.
pa12     lx      x2,acst,cpwell        .Get the value of the cpu_alive flag.
         addx    x2,x3                 .Check if CPU has been alive recently.
         entl    x0,0                  .Get the current FRC.
         cpytx   x4,x0
         brxge   x2,x4,pa14            .Jump if CPU has been alive recently.
.
                                       .Begin code to process ill CPU case.
         la      ascr,a_bindin,bs_bct  .Fetch pointer to Boot Control Table.
         lbyts,6 x1,ascr,x0,0
         cpyxa   ascr,x1
         lx      x1,ascr,bctflags      .Get the flags word.
         shfx    x1,x1,x0,5            .Check the CPU error processing in
                                       .  progress field.
         brxge   x1,x0,pa16            .Jump if not set.
         shfx    x1,x1,x0,1            .Check the CPU error fatal after
                                       .  having been processed field.
         brxgt   x0,x1,pa16            .Jump if set.
         sx      x4,acst,cpwell        .Update cpu_alive flag to allow for
                                       .  longer CPU error processing.
                                       .End code to process ill CPU case.
.
pa14     la      ascr,a_bindin,bs_cpcb .Get ptr to CPU_PP_communications_block.
         sx      x4,ascr,mon_time      .Update timestamp for DFT handshaking.
         lx      x1,acst,maptim        .Get time map last purged.
         brxgt   xfrc,x1,pa12          .Jump if map not yet purged.
         brxeq   x0,x0,pa18
pa16     ente    x2,-2153(16)          .Flag noting dead CPU (DEAD):
         isob    x2,x2,x0,0176(8)      .  looks like 7FFFFFFFFFFFDEAD.
         sx      x2,acst,maptim        .Store it in the Dead CPU's CST.
         sx      x2,acst,cachtim       .Store it in the Dead CPU's CST.
pa18     addaq   acst,acst,cstsize     .Set pointer to next CST entry.
         brinc   xcstcnt,xindex,pa8    .Jump if more CST entries to check.
         la      ascr,a_bindin,bs_mapt
         entp    x0,0
         cpytx   x0,x0
         sx      x0,ascr,0
.
         return
         page
...........................................................................
.  Define binding section
.
         USE     BINDING
         ref     pr_cstct,pr_cst0,pr_cpcb,pr_bct
pr_bct   ALIAS   dsv$boot_control_table_p
pr_cstct ALIAS   osv$cpus_physically_configured
bs_bct   address p,pr_bct
bs_cstct address p,pr_cstct
pr_cst0  ALIAS   mtv$cst0
pr_cpcb  ALIAS   dsv$cpu_pp_communication_block
bs_cst0  address p,pr_cst0
bs_work  address p,pcount
bs_cpcb  address p,pr_cpcb
bs_mapt  address p,mapt
*IF $variable(mmv$test_forced_use_cache_maps, declared) <> 'UNKNOWN'
.
. Binding declarations for logging callers of procedures above.
.        ref     MMP$LOG_CALLER_MONITOR
.bs_log   address ce,mmp$log_caller_monitor
*ELSE
.
. -------- Binding declarations for forcing the use of cache and maps omitted at compile time --------
*IFEND
.
         USE     WORKING
         def     pcount,mapt
         align   0,8
pcount   ALIAS   mmv$purge_counts
mapt     ALIAS   mmv$time_map_last_purged
pcount   bssz    24
mapt     bssz    8
         end
*DECK DECK=MMM$DEADSTART_INITIALIZATION EXPAND=TRUE
?? RIGHT := 110, LEFT := 1 ??
MODULE mmm$deadstart_initialization;

?? SKIP := 3 ??
{
{  PURPOSE:
{     This module contains procedures used during deadstart to initialize
{     memory manager tables.
{

?? PUSH (LISTEXT := ON) ??
*copyc gfv$null_sfid
*copyc dst$rb_system_deadstart_status
*copyc jst$swap_file_descriptor
*copyc mlt$ant_entry
*copyc osd$cybil_structure_definitions
*copyc osv$170_os_type
*copyc osv$mainframe_wired_heap
*copyc osv$mainframe_wired_cb_heap
*copyc osv$mainframe_pageable_heap
*copyc jmv$ijl_p
*copyc jmv$system_ijl_ordinal
*copyc jmv$jcb
*copyc mmt$attribute_keyword
*copyc mmv$mf_wired_asid
*copyc mmv$pages_to_dump_p
*copyc mmt$mainframe_wired_asid
*copyc mmt$manage_memory_utility
*copyc mmc$first_transient_segment
*copyc mmt$rb_segment_request
*copyc mmt$segment_descriptor_table
*copyc mmt$segment_descriptor_table_ex
*copyc osd$virtual_address
*copyc ost$page_table
*copyc osv$enable_hyperchannel
*copyc ost$segment_descriptor
*copyc osc$processor_defined_registers
*copyc ost$execution_control_block
?? POP ??
?? SKIP := 3 ??
{External procedures used by this module.

*copyc osp$reset_heap
*copyc dsp$allocate_continuous_memory
*copyc dsp$fetch_boot_data
*copyc dsp$get_flaw_map
*copyc gfp$assign_fde
*copyc gfp$get_fde_p
*copyc i#call_monitor
*copyc jmp$get_ijle_p
*copyc mmp$assign_mass_storage
*copyc mmp$convert_ps_transfer_size
*copyc mmp$free_pages
*copyc mmp$get_max_sdt_pointer
*copyc mmp$get_max_sdt_sdtx_pointer
*copyc mmp$get_sdt_entry_p
*copyc mmp$get_sdtx_entry_p
*copyc mmp$issue_ring1_segment_request
*copyc mmp$set_include_pages_in_dump
*copyc mmp$set_segment_access_rights
*copyc osp$fatal_system_error
*copyc osp$system_error
*copyc pmp$find_executing_task_xcb
*copyc pmp$zero_out_table
?? SKIP := 3 ??
*copyc dsv$ssr_size
*copyc jmv$sdt
*copyc jmv$sdtx
*copyc jmv$jmtr_xcb
*copyc jsv$swapped_page_entry_size
*copyc mmv$big_segment
*copyc mmv$maximum_180_memory
*copyc mmv$tables_initialized
*copyc mmv$total_page_frames
*copyc mmv$pt_length
*copyc mmv$time_to_call_mem_mgr
*copyc mmv$pfti_array_p
*copyc mmv$reassignable_page_frames
*copyc mmv$image_file
*copyc mmv$ast_p
*copyc mmv$continue_bit_count_p
*copyc mmv$gpql
*copyc mmv$manage_memory_utility
*copyc mmv$pages_per_new_page_fault
*copyc mmv$periodic_call_interval
*copyc mmv$shared_queue_age_interval
*copyc mmv$pft_p
*copyc mmv$pt_p
*copyc mmv$default_sdtx_entry
*copyc mtv$mx_segments
*copyc osv$cpus_physically_configured
*copyc osv$180_memory_limits
*copyc osv$page_size
*copyc dfv$server_wired_heap
*copyc nav$network_wired_heap
*copyc nav$network_paged_heap

{  Define variable that will contain the SDT index for the first transient segment.

  VAR
    mmv$first_transient_seg_index: [XDCL] ost$segment := mmc$first_transient_segment;

  VAR
    mlv$shared_segment: [XREF] mlt$shared_segment;

?? TITLE := 'ASID CONVERSION FUNCTIONS' ??
?? EJECT ??
*copyc mmp$asid_functions
?? TITLE := 'MMP$ADD_GLOBAL_TEMPLATE_SEGMENT', EJECT ??
{
{ This procedure is used during deadstart to add job template segments to the address space
{ of the system job monitor.
{


  PROCEDURE [XDCL] mmp$add_global_template_segment
    (    sdt_entry: mmt$segment_descriptor;
         sdtx_entry: mmt$segment_descriptor_extended;
         segnum: ost$segment;
     VAR status: ost$status);

    VAR
      fde_p: gft$file_desc_entry_p,
      page_streaming_transfer_size: 0 .. 15,
      ste_p: ^mmt$segment_descriptor,
      stxe_p: ^mmt$segment_descriptor_extended,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;

    pmp$find_executing_task_xcb (xcb_p);
    IF xcb_p <> ^jmv$jmtr_xcb THEN
      osp$system_error ('MM - incorrect call to mmp$add_global_template_segment', NIL);
    IFEND;

    mmp$convert_ps_transfer_size (16384, page_streaming_transfer_size); {convert TS to pages in a power of 2
    ste_p := mmp$get_sdt_entry_p (xcb_p, segnum);
    stxe_p := mmp$get_sdtx_entry_p (xcb_p, segnum);

    ste_p^ := sdt_entry;
    stxe_p^ := sdtx_entry;
    stxe_p^.stream.transfer_size := page_streaming_transfer_size;

    IF stxe_p^.sfid.residence = gfc$tr_null_residence THEN
      assign_fde (gfc$tr_job, 0, segnum, stxe_p^.sfid, fde_p);
    IFEND;

    gfp$get_fde_p (stxe_p^.sfid, fde_p);
    fde_p^.flags.global_template_file := TRUE;

  PROCEND mmp$add_global_template_segment;
?? TITLE := 'MMP$WRITE_ALL_SEGMENTS_TO_DISK', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$write_all_segments_to_disk
    (VAR status: ost$status);


    VAR
      xcb_p: ^ost$execution_control_block,
      rb: mmt$rb_ring1_segment_request,
      segnum: ost$segment,
      st_p: mmt$max_sdt_p;

    rb.reqcode := syc$rc_ring1_segment_request;
    rb.request := mmc$sr1_flush_seg_segnum;
    rb.wait_for_io_complete := FALSE;
    pmp$find_executing_task_xcb (xcb_p);
    mmp$get_max_sdt_pointer (xcb_p, st_p);
    FOR segnum := 1 TO #READ_REGISTER (osc$pr_segment_table_length) DO
      IF (st_p^.st [segnum].ste.vl <> osc$vl_invalid_entry) THEN
        mmp$assign_mass_storage (segnum, gfv$null_sfid, 0, status);
        IF status.normal AND (segnum <> xcb_p^.xp.tos_registers [1].pva.seg) THEN
          rb.segnum := segnum;
          mmp$issue_ring1_segment_request (rb);
        IFEND;
      IFEND;
    FOREND;
    status.normal := TRUE;

  PROCEND mmp$write_all_segments_to_disk;
?? TITLE := 'MMP$INITIALIZE', EJECT ??

{-------------------------------------------------------------------------------------------------------
{Name:
{  mmp$initialize
{Purpose:
{    This routine is the first procedure in the module mmm$deadstart_initialization to be called during
{    deadstart.  Later deadstart will make separate calls to mmp$assign_device_shared_segs,
{    mmp$pft_initialize, and to mmp$write_all_segments_to_disk.
{Input:
{    none
{Output:
{    The static data constants are initialized and the SDTX will be initialized via
{    a call to the procedure mmp$sdtx_initialization.
{Error Codes:
{    none
{Notes:
{    - The system heap must be initialized before calling this routine
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$initialize;

    VAR
      pti: integer,
      i: integer,
      index_ma: mmt$mmu_memory_attributes;

{Set up static data constants.

    i := #READ_REGISTER (osc$pr_page_table_length);
    mmv$pt_length := (i + 1) * 512;
    i := i MOD 100(16);
    mmv$a_divisor := 256 DIV (i + 1);
    mmv$a_mult := 10000(16) DIV mmv$a_divisor;
    mmv$pt_p := #ADDRESS (1, 0, 0);

{ Set all continue bits in the page table. Continue bits are not managed by the page
{ fault processor used before AST/PFT initialization is complete. The continue bits will
{ be cleaned up during PFT initialization.

    FOR pti := 0 TO mmv$pt_length - 1 DO
      mmv$pt_p^ [pti].c := TRUE;
    FOREND;


{  Copy the current values of mmv$gpql and other mmv$ variables managed by the Manage Memory Utility into
{  the default copies so that the MMU will have available the original values when it is requested to
{  reset values to their default.

    FOR index_ma := LOWERBOUND (mmv$manage_memory_utility.ma) TO UPPERBOUND (mmv$manage_memory_utility.ma) DO
      IF mmv$manage_memory_utility.ma [index_ma].value_type = mmc$mmu_mvt_integer THEN
        mmv$manage_memory_utility.ma [index_ma].default := mmv$manage_memory_utility.ma [index_ma].integer_p^;
      ELSE { mmc$mmu_mvt_byte }
        mmv$manage_memory_utility.ma [index_ma].default := mmv$manage_memory_utility.ma [index_ma].byte_p^;
      IFEND;
    FOREND;

    mmv$manage_memory_utility.gpql := mmv$gpql;


{ Initialize fields in the SDTX.

    mmp$sdtx_initialization;

  PROCEND mmp$initialize;
?? TITLE := 'MMP$PFT_INITIALIZE' ??
?? EJECT ??

{--------------------------------------------------------------------------------------------------------
{Name:
{  mmp$pft_initialize
{Purpose:
{  By the time this procedure is called the other procedures in mmm$deadstart_initialization have
{  already been executed.  This routine initializes the PFT, PQL and the defaults for Manage_Memory
{Input:
{Output:
{  none
{Error Code:
{  none
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$pft_initialize;

    TYPE
      asidq_type = record
        asid: ost$asid,
        queue_id: mmt$page_frame_queue_id,
        qcb_p: ^mmt$page_queue_list_entry,
        aste_p: ^mmt$active_segment_table_entry,
        fde_p: gft$file_desc_entry_p,
      recend;

    VAR
      asid: ost$asid,
      asid1: ost$asid,
      asid2: ost$asid,
      asid3: ost$asid,
      asid_seq_p: ^SEQ ( * ),
      asid_size: integer,
      asidq: array [0 .. 40] of asidq_type,
      asidq_p: ^asidq_type,
      aste_p: ^mmt$active_segment_table_entry,
      asti: mmt$ast_index,
      boot_asids: dst$boot_asids,
      boot_asids_seq_p: ^SEQ ( * ),
      cbc_seq_p: ^SEQ ( * ),
      count: 1 .. 32,
      dummy_p: ^cell,
      dummy_reference: cell,
      fde_p: gft$file_desc_entry_p,
      first_image_pfti: 0 .. 0ffffffff(16),
      flaw_map_p: ^array [1 .. *] of mmt$page_frame_index_32,
      found: boolean,
      fwd_link: integer,
      i: integer,
      ijle_p: ^jmt$initiated_job_list_entry,
      ipti: integer,
      j: integer,
      last_asid: ost$asid,
      last_link_p: ^mmt$link,
      mf_wired_asid_p: ^mmt$mainframe_wired_asid,
      next_asidq_index: integer,
      pft_p: ^mmt$page_frame_table_entry,
      pft_seq_p: ^SEQ ( * ),
      pft_size: integer,
      pfti: mmt$page_frame_index,
      pftimax: integer,
      pftimin: integer,
      pt_p: ^ost$page_table,
      ptd_seq_p: ^SEQ ( * ),
      ptd_size: integer,
      pte_p: ^ost$page_table_entry,
      pti: ost$page_table_index,
      qcb_p: ^mmt$page_queue_list_entry,
      queue_id: mmt$page_frame_queue_id,
      rb: mmt$rb_ring1_segment_request,
      rb_sds: dst$rb_system_deadstart_status,
      residence: gft$table_residence,
      ssr_size: integer,
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      sva: ost$system_virtual_address,
      sdt_entry: mmt$segment_descriptor,
      sdte: [STATIC] mmt$segment_descriptor := [[osc$vl_cache_bypass, osc$non_executable,
            osc$read_uncontrolled, osc$write_uncontrolled, 1, 1, 0, * ], 0, 0],
      sdtx_entry: mmt$segment_descriptor_extended,
      status: ost$status;


{ Set up maximum amount of memory that 180 will use. This is for DEBUG purposes only and so
{ Display_System_Attribute can be used to verify the amount of memory being used.

    mmv$maximum_180_memory := (mmv$maximum_180_memory DIV osv$page_size) * osv$page_size;
    IF (osv$180_memory_limits.upper - osv$180_memory_limits.lower) > mmv$maximum_180_memory THEN
      osv$180_memory_limits.upper := osv$180_memory_limits.lower + mmv$maximum_180_memory;
    IFEND;
    mmv$maximum_180_memory := osv$180_memory_limits.upper - osv$180_memory_limits.lower;

{ Set maximum number of ASIDs based on memory size and allocate the AST.

    IF mtv$mx_segments = 0 THEN
      mtv$mx_segments := ((osv$180_memory_limits.upper - osv$180_memory_limits.lower) DIV osv$page_size) +
            300;
      IF mtv$mx_segments > 0FFFE(16) THEN
        mtv$mx_segments := 0FFFE(16);
      IFEND;
    IFEND;
    mmv$number_free_astes := mtv$mx_segments;
    ALLOCATE mmv$ast_p: [0 .. (mtv$mx_segments)] IN osv$mainframe_wired_heap^;

{ Allocate the PFT.

    i := osv$180_memory_limits.lower DIV osv$page_size;
    IF i = 0 THEN
      i := 1;
    IFEND;
    pft_size := (osv$180_memory_limits.upper DIV osv$page_size - i) * (#SIZE (mmt$page_frame_table_entry));
    dsp$allocate_continuous_memory (osv$mainframe_wired_heap, pft_size, pft_seq_p);
    RESET pft_seq_p;
    NEXT mmv$pft_p: [i .. (osv$180_memory_limits.upper DIV osv$page_size) - 1] IN pft_seq_p;

    pftimin := LOWERBOUND (mmv$pft_p^);
    pftimax := UPPERBOUND (mmv$pft_p^);
    mmv$total_page_frames := pftimax - pftimin;

{ Get the flaw map now before the pft is built so that it will be accounted for.

    dsp$get_flaw_map (flaw_map_p);

{ Allocate the critical dump page bit table.

    ssr_size := ((dsv$ssr_size + osv$page_size - 1) DIV osv$page_size) * osv$page_size;
    ptd_size := (((osv$180_memory_limits.upper + ssr_size) DIV osv$page_size) + 64) DIV 8;
    dsp$allocate_continuous_memory (osv$mainframe_wired_heap, ptd_size, ptd_seq_p);
    RESET ptd_seq_p;
    NEXT mmv$pages_to_dump_p: [0 .. (ptd_size * 8) - 1] IN ptd_seq_p;

    dsp$allocate_continuous_memory (osv$mainframe_wired_heap, mmv$pt_length, cbc_seq_p);
    RESET cbc_seq_p;
    NEXT mmv$continue_bit_count_p: [0 .. mmv$pt_length - 1] IN cbc_seq_p;

    ALLOCATE mmv$pfti_array_p: [0 .. (osv$180_memory_limits.upper DIV osv$page_size) - i] IN
          osv$mainframe_wired_heap^;

{Zero out the tables allocated.}

    pmp$zero_out_table (#LOC (mmv$ast_p^), #SIZE (mmv$ast_p^));
    pmp$zero_out_table (#LOC (mmv$pft_p^), #SIZE (mmv$pft_p^));
    pmp$zero_out_table (#LOC (mmv$pages_to_dump_p^), #SIZE (mmv$pages_to_dump_p^));
    pmp$zero_out_table (#LOC (mmv$continue_bit_count_p^), #SIZE (mmv$continue_bit_count_p^));
    pmp$zero_out_table (#LOC (mmv$pfti_array_p^), #SIZE (mmv$pfti_array_p^));

{  Set cache bypass if multiprocessing enabled.

    mmp$get_max_sdt_sdtx_pointer (^jmv$jmtr_xcb, sdt_p, sdtx_p);

    IF osv$cpus_physically_configured > 1 THEN
      sdt_p^.st [osc$segnum_mainframe_paged].ste.vl := osc$vl_cache_bypass;
      sdt_p^.st [#SEGMENT (#LOC (nav$network_paged_heap^))].ste.vl := osc$vl_cache_bypass;
      sdt_p^.st [#SEGMENT (^mlv$shared_segment)].ste.vl := osc$vl_cache_bypass;
    ELSE

{  Make mainframe wired a cache segment

      rb.reqcode := syc$rc_ring1_segment_request;
      rb.request := mmc$sr1_make_mfw_cache;
      rb.wait_for_io_complete := FALSE;
      sdt_p^.st [#SEGMENT (osv$mainframe_wired_heap)].ste.vl := osc$vl_regular_segment;
      mmp$issue_ring1_segment_request (rb);
    IFEND;


    jmp$get_ijle_p (jmv$system_ijl_ordinal, ijle_p);
    ijle_p^.job_fixed_asid := sdt_p^.st [osc$segnum_job_fixed_heap].ste.asid;


{ Set up the table used to locate mainframe wired if the system crashes while ASID
{ reassignment on mainframe wired is active. If the system crashes while this is
{ happening, both old and new ASIDs must be located in the page table.

    asid_size := #SIZE (mmt$mainframe_wired_asid);
    dsp$allocate_continuous_memory (osv$mainframe_wired_heap, asid_size, asid_seq_p);
    RESET asid_seq_p;
    NEXT mf_wired_asid_p IN asid_seq_p;
    mmv$mf_wired_asid := mf_wired_asid_p^;
    mmv$mf_wired_asid.current := sdt_p^.st [osc$segnum_mainframe_wired].ste.asid;
    mmv$mf_wired_asid.new := 0;


{ Free the pages used by the boot. The easiest way to do this at this point in deadstart
{ is to delete the page table entries used by the boot.

    boot_asids_seq_p := #SEQ (boot_asids);
    dsp$fetch_boot_data (dsc$boot_asids, boot_asids_seq_p);
    sdt_p^.st [osc$segnum_job_pageable_heap].ste.vl := osc$vl_invalid_entry;

    pt_p := mmv$pt_p;
    asid1 := boot_asids.code_data;
    asid2 := boot_asids.job_stack;
    asid3 := boot_asids.mtr_stack;
    FOR pti := 0 TO mmv$pt_length - 1 DO
      asid := pt_p^ [pti].pageid.asid;
      IF (asid = asid1) OR (asid = asid2) OR (asid = asid3) THEN
        pt_p^ [pti].v := FALSE;
        pt_p^ [pti].pageid.asid := 0;
      IFEND;
    FOREND;


{ Search the segment table of the job monitor. For each valid entry, create an AST
{ and FDE entry that describes the segment.

    next_asidq_index := 0;

  /scan_sdt/
    FOR i := 0 TO jmv$jmtr_xcb.xp.segment_table_length DO
      IF sdt_p^.st [i].ste.vl = osc$vl_invalid_entry THEN
        CYCLE /scan_sdt/
      IFEND;

      asidq_p := ^asidq [next_asidq_index];

      IF mmc$sa_wired IN sdtx_p^.sdtx_table [i].software_attribute_set THEN
        queue_id := mmc$pq_wired;
      ELSEIF mmc$sa_fixed IN sdtx_p^.sdtx_table [i].software_attribute_set THEN
        queue_id := mmc$pq_job_fixed;
      ELSEIF sdtx_p^.sdtx_table [i].open_validating_ring_number = 0 THEN
        queue_id := mmc$pq_shared_task_service;
      ELSE
        queue_id := mmc$pq_job_working_set;
      IFEND;

      asidq_p^.asid := sdt_p^.st [i].ste.asid;
      asidq_p^.queue_id := queue_id;
      mmp$asti (asidq_p^.asid, asti);
      sdt_p^.st [i].asti := asti;

      IF asti <= UPPERBOUND (mmv$ast_p^) THEN
        asidq_p^.aste_p := ^mmv$ast_p^ [asti];
        IF NOT asidq_p^.aste_p^.in_use THEN
          asidq_p^.aste_p^.in_use := TRUE;
          IF queue_id < mmc$pq_job_base THEN
            residence := gfc$tr_system;
          ELSE
            residence := gfc$tr_job;
          IFEND;
          assign_fde (residence, asti, i, asidq_p^.aste_p^.sfid, asidq_p^.fde_p);
          sdtx_p^.sdtx_table [i].sfid := asidq_p^.aste_p^.sfid;
          IF (queue_id = mmc$pq_job_working_set) OR (queue_id = mmc$pq_shared_task_service) THEN
            sdtx_p^.sdtx_table [i].assign_active := mmc$assign_active_escaped;
          IFEND;
          asidq_p^.aste_p^.queue_id := asidq_p^.queue_id;
          asidq_p^.aste_p^.ijl_ordinal := jmv$system_ijl_ordinal;
          IF mmc$sa_stack IN sdtx_p^.sdtx_table [i].software_attribute_set THEN
            asidq_p^.fde_p^.stack_for_ring := sdt_p^.st [i].ste.r1;
          IFEND;

          mmp$set_include_pages_in_dump (i, asidq_p^.fde_p, ^sdt_p^.st [i],
                asidq_p^.aste_p^.include_pages_in_dump);
          mmv$number_free_astes := mmv$number_free_astes - 1;

        IFEND;

      ELSE
        asidq_p^.aste_p := NIL;
        asidq_p^.fde_p := NIL;
      IFEND;

      IF queue_id < mmc$pq_job_base THEN
        asidq_p^.qcb_p := ^mmv$gpql [queue_id].pqle;
      ELSE
        asidq_p^.qcb_p := ^ijle_p^.job_page_queue_list [queue_id];
      IFEND;
      next_asidq_index := next_asidq_index + 1;

    FOREND /scan_sdt/;


{ Search thru the page table. Initialize the PFT entry for each page found and
{ link the page to the correct page queue.

    last_asid := 0;

  /scan_page_table/
    FOR pti := mmv$pt_length - 1 DOWNTO 0 DO
      asid := mmv$pt_p^ [pti].pageid.asid;
      IF asid = 0 THEN
        CYCLE /scan_page_table/
      IFEND;
      pte_p := ^mmv$pt_p^ [pti];

{ Find the ASIDQ table entry for the segment. Usually page table entries for the same segment
{ are clustered together - skip the ASIDQ search if new entry is the same as the previous
{ entry. If the entry is not found, the ASID must belong to a segment that is accessible in
{ monitor mode ONLY.

      IF asid <> last_asid THEN
        j := 0;

        WHILE (j < next_asidq_index) AND (asidq [j].asid <> asid) DO
          j := j + 1;
        WHILEND;

        IF j = next_asidq_index THEN
          asidq_p := ^asidq [j];
          mmp$asti (asid, asti);
          IF asti <= UPPERBOUND (mmv$ast_p^) THEN
            asidq_p^.aste_p := ^mmv$ast_p^ [asti];
            IF NOT asidq_p^.aste_p^.in_use THEN
              assign_fde (gfc$tr_system, asti, 0, asidq_p^.aste_p^.sfid, asidq_p^.fde_p);
              asidq_p^.fde_p^.file_kind := gfc$fk_monitor_only_unnamed;
              asidq_p^.aste_p^.in_use := TRUE;
              asidq_p^.aste_p^.queue_id := mmc$pq_wired;
              asidq_p^.aste_p^.ijl_ordinal := jmv$system_ijl_ordinal;
              IF asid <> 0ffff(16) THEN
                asidq_p^.aste_p^.include_pages_in_dump := TRUE;
              IFEND;
              mmv$number_free_astes := mmv$number_free_astes - 1;
            IFEND;
          ELSE
            asidq_p^.aste_p := NIL;
            asidq_p^.fde_p := NIL;
          IFEND;
          asidq_p^.asid := asid;
          asidq_p^.qcb_p := ^mmv$gpql [mmc$pq_wired].pqle;
          asidq_p^.queue_id := mmc$pq_wired;
          next_asidq_index := next_asidq_index + 1;
        IFEND;

        asidq_p := ^asidq [j];
        aste_p := asidq_p^.aste_p;
        queue_id := asidq_p^.queue_id;
        qcb_p := asidq_p^.qcb_p;
        last_asid := asid;
        fde_p := asidq_p^.fde_p;
      IFEND;

      sva.asid := asid;
      sva.offset := pte_p^.pageid.pagenum * 512;
      #HASH_SVA (sva, ipti, count, found);
      FOR i := 2 TO count DO
        ipti := ipti - 1;
        IF ipti < 0 THEN
          ipti := mmv$pt_length - 1;
        IFEND;
        mmv$continue_bit_count_p^ [ipti] := mmv$continue_bit_count_p^ [ipti] + 1;
      FOREND;

      IF aste_p <> NIL THEN
        aste_p^.pages_in_memory := aste_p^.pages_in_memory + 1;
      IFEND;

      pfti := (pte_p^.rma * 512) DIV osv$page_size;

      IF (pfti < pftimin) OR (pfti > pftimax) OR (pfti = pftimin) AND (asid = 0FFFF(16)) THEN
        IF (pfti >= pftimin) AND (pfti <= UPPERBOUND (mmv$pages_to_dump_p^)) THEN
          IF asid <> 0FFFF(16) THEN     { NOT NOS }
            mmv$pages_to_dump_p^ [pfti] := TRUE;
          IFEND;
        IFEND;
        CYCLE /scan_page_table/
      IFEND;

      pft_p := ^mmv$pft_p^ [pfti];
      pft_p^.pti := pti;
      pft_p^.sva := sva;
      pft_p^.queue_id := queue_id;
      pft_p^.aste_p := aste_p;
      pft_p^.age := 1;
      pft_p^.ijl_ordinal := jmv$system_ijl_ordinal;
      pft_p^.locked_page := mmc$lp_not_locked;
      pft_p^.link.fwd := qcb_p^.link.fwd;
      IF (fde_p <> NIL) AND (fde_p^.eoi_byte_address < sva.offset + osv$page_size) THEN
        fde_p^.eoi_byte_address := sva.offset + osv$page_size;
      IFEND;
      IF pft_p^.aste_p <> NIL THEN
        link_page_to_segment_ds (pfti, pft_p, aste_p);
        mmv$pages_to_dump_p^ [pfti] := aste_p^.include_pages_in_dump
      ELSE
        mmv$pages_to_dump_p^ [pfti] := TRUE;
      IFEND;
      fwd_link := qcb_p^.link.fwd;
      IF fwd_link <> 0 THEN
        mmv$pft_p^ [fwd_link].link.bkw := pfti;
      IFEND;
      qcb_p^.link.fwd := pfti;
      qcb_p^.count := qcb_p^.count + 1;
      IF qcb_p^.link.bkw = 0 THEN
        qcb_p^.link.bkw := pfti;
      IFEND;

    FOREND /scan_page_table/;

{ Mark any flawed pages.  Pages that are already in use will be moved to the flaw queue
{ when they are linked to the free or avail queue.  Link the flawed pages into the flaw
{ queue.  Pages are only flawed on the CY2000 machines.

    IF flaw_map_p <> NIL THEN

    /flaw_pages/
      FOR i := LOWERBOUND (flaw_map_p^) TO UPPERBOUND (flaw_map_p^) DO
        IF flaw_map_p^ [i] = 0 THEN
          EXIT /flaw_pages/;
        ELSEIF (flaw_map_p^ [i] < LOWERBOUND (mmv$pft_p^)) OR
              (flaw_map_p^ [i] > UPPERBOUND (mmv$pft_p^)) THEN
          CYCLE /flaw_pages/;
        IFEND;
        pft_p := ^mmv$pft_p^ [flaw_map_p^ [i]];
        pft_p^.flawed := TRUE;
      FOREND /flaw_pages/;

      FREE flaw_map_p IN osv$mainframe_wired_heap^;
    IFEND;


    first_image_pfti := osv$180_memory_limits.deadstart_upper DIV osv$page_size;
    qcb_p := ^mmv$gpql [mmc$pq_free].pqle;
    last_link_p := ^qcb_p^.link;

  /scan_pft/
    FOR pfti := pftimin TO pftimax DO
      IF pfti >= first_image_pfti THEN
        IF mmv$pft_p^ [pfti].age <> 0 THEN
          osp$fatal_system_error (' Not enough memory to deadstart- PFT INIT', NIL);
        IFEND;

{ These pages will be linked to the free queue when memory is committed.

        mmv$pft_p^ [pfti].link.fwd := 0;
        mmv$pft_p^ [pfti].link.bkw := 0;
        mmv$pft_p^ [pfti].queue_id := mmc$pq_free;

      ELSEIF mmv$pft_p^ [pfti].age <> 0 THEN
        CYCLE /scan_pft/

      ELSEIF mmv$pft_p^ [pfti].flawed THEN
        mmv$pft_p^ [pfti].link.fwd := mmv$gpql [mmc$pq_flawed].pqle.link.fwd;
        mmv$pft_p^ [pfti].link.bkw := 0;
        mmv$pft_p^ [pfti].queue_id := mmc$pq_flawed;
        IF mmv$gpql [mmc$pq_flawed].pqle.link.fwd = 0 THEN
          mmv$gpql [mmc$pq_flawed].pqle.link.bkw := pfti;
        ELSE
          mmv$pft_p^ [mmv$gpql [mmc$pq_flawed].pqle.link.fwd].link.bkw := pfti;
        IFEND;
        mmv$gpql [mmc$pq_flawed].pqle.link.fwd := pfti;
        mmv$gpql [mmc$pq_flawed].pqle.count := mmv$gpql [mmc$pq_flawed].pqle.count + 1;

      ELSE
        last_link_p^.bkw := pfti;
        last_link_p := ^mmv$pft_p^ [pfti].link;
        last_link_p^.fwd := qcb_p^.link.fwd;
        qcb_p^.link.fwd := pfti;
        qcb_p^.count := qcb_p^.count + 1;
        mmv$pft_p^ [pfti].queue_id := mmc$pq_free;

      IFEND;
      mmv$pft_p^ [pfti].aste_p := NIL;
      mmv$pft_p^ [pfti].segment_link.fwd := 0;
      mmv$pft_p^ [pfti].segment_link.bkw := 0;
    FOREND /scan_pft/;

{ Set the count of the number of reassignable page frames.

    mmv$reassignable_page_frames.now := qcb_p^.count;

{ Store ASID in all unused AST entries.

    FOR i := 1 TO mtv$mx_segments DO
      IF NOT mmv$ast_p^ [i].in_use THEN
        mmp$asid (i, mmv$ast_p^ [i].asid);
      IFEND;
    FOREND;

    FOR pti := 0 TO mmv$pt_length - 1 DO
      mmv$pt_p^ [pti].c := mmv$continue_bit_count_p^ [pti] > 0;
    FOREND;

    mmv$time_to_call_mem_mgr := #FREE_RUNNING_CLOCK (0) + 5000000;

    jsv$swapped_page_entry_size := #SIZE (jst$swapped_page_descriptor);

{ The number 16384 is arbitrary and only must be less than or equal to the
{ minimum allocation unit size.

    mmv$pages_per_new_page_fault := 16384 DIV osv$page_size;
    IF mmv$pages_per_new_page_fault > 4 THEN
      mmv$pages_per_new_page_fault := 4;
    IFEND;

    mmv$tables_initialized := TRUE;

{ Set the bit in the critical page map so that physical page zero will
{ get dumped.  This is where the boot control tables for cy2000 lives
{ and where sometimes hardware erroneous deposits an exchange package.
{ Do this only if standalone! In dual state, NOS has access to physical
{ page zero.  *RUN can't dump any pages that are referenced by NOS.

    IF osv$170_os_type = osc$ot7_none THEN
      mmv$pages_to_dump_p^ [0] := TRUE;
    IFEND;

{ Set up pointer to flag SCI that a critical page dump is now available.

    rb_sds.reqcode := syc$rc_system_deadstart_status;
    rb_sds.action := dsc$rb_sds_set_cpt_pointer;
    rb_sds.data_p := NIL;
    i#call_monitor (#LOC (rb_sds), #SIZE (rb_sds));

{ The following code is to support the hyperchannel project.

    IF osv$enable_hyperchannel THEN
      sdt_entry := sdte;
      sdt_entry.ste.r1 := 6;
      sdt_entry.ste.r2 := 6;
      sdt_entry.ste.asid := 0;
      sdt_entry.ste.vl := osc$vl_cache_bypass;
      sdtx_entry := mmv$default_sdtx_entry;
      sdtx_entry.software_attribute_set := sdtx_entry.software_attribute_set +
            $mmt$software_attribute_set [mmc$sa_wired];
      sdtx_entry.open_validating_ring_number := 0;
      sdtx_entry.inheritance := mmc$si_share_segment;
      assign_fde (gfc$tr_system, 0, osc$segment_for_hyperchannel, sdtx_entry.sfid, fde_p);
      fde_p^.file_limit := 989680(16);
      fde_p^.last_segment_number := osc$segment_for_hyperchannel;
      sdt_p^.st [osc$segment_for_hyperchannel] := sdt_entry;
      sdtx_p^.sdtx_table [osc$segment_for_hyperchannel] := sdtx_entry;

{ Force an  ASID to be assigned so aste will contain jmv$system_ijl_ordinal.
       dummy_p := #ADDRESS (1, osc$segment_for_hyperchannel, 10);
       dummy_reference := dummy_p^;
    IFEND;

  PROCEND mmp$pft_initialize;

?? TITLE := 'assign_fde', EJECT ??
{ Purpose:
{   This procedure is called from mmp$pft_initialize to assign and initialize an FDE
{   entry for a segment.

  PROCEDURE assign_fde
    (    residence: gft$table_residence;
         asti: mmt$ast_index;
         segnum: ost$segment;
     VAR sfid: gft$system_file_identifier;
     VAR fde_p: gft$file_desc_entry_p);

    gfp$assign_fde (residence, 0, sfid, fde_p);
    IF sfid.residence <> gfc$tr_system THEN
      fde_p^.file_kind := gfc$fk_unnamed_file;
      fde_p^.open_count := 1;
      fde_p^.attach_count := 1;
    ELSE
      fde_p^.flags.global_template_file := TRUE;
      fde_p^.queue_status := gfc$qs_global_shared;
      fde_p^.attach_count := 0fff(16);
      fde_p^.open_count := 0fff(16);
    IFEND;
    fde_p^.asti := asti;
    fde_p^.last_segment_number := segnum;
    fde_p^.global_task_id := jmv$jmtr_xcb.global_task_id;
    fde_p^.global_task_id := jmv$jmtr_xcb.global_task_id;
    fde_p^.file_hash := segnum;
    sfid.file_hash := segnum;

  PROCEND assign_fde;
?? TITLE := 'mmp$create_ssr_sdtx', EJECT ??
{ Purpose:
{   This procedure is called during deadstart to create a SDTX entry for the SSR.
{

  PROCEDURE [XDCL] mmp$create_ssr_sdtx
    (VAR sdt_entry: mmt$segment_descriptor;
     VAR sdtx_entry: mmt$segment_descriptor_extended);

    VAR
      fde_p: gft$file_desc_entry_p,
      sfid: gft$system_file_identifier;

    sdtx_entry := mmv$default_sdtx_entry;
    sdtx_entry.software_attribute_set := $mmt$software_attribute_set [mmc$sa_wired];
    sdtx_entry.inheritance := mmc$si_none;

    gfp$assign_fde (gfc$tr_system, 0, sfid, fde_p);
    fde_p^.file_kind := gfc$fk_monitor_only_unnamed;
    fde_p^.queue_status := gfc$qs_global_shared;
    fde_p^.attach_count := 0fff(16);
    fde_p^.open_count := 0fff(16);

    mmp$asti (sdt_entry.ste.asid, fde_p^.asti);
    sdt_entry.asti := fde_p^.asti;
    fde_p^.global_task_id := jmv$jmtr_xcb.global_task_id;
    fde_p^.global_task_id := jmv$jmtr_xcb.global_task_id;
    fde_p^.file_hash := 0;

  PROCEND mmp$create_ssr_sdtx;

?? TITLE := 'link_page_to_segment_ds', EJECT ??
{ Purpose:
{   This procedure is called from mmp$pft_initialize to insert a page frame into the
{   thread which links all pages of a segment that are in memory.  There must be NO OTHER CALLERS
{   of this procedure, or the integrity of the links will be destroyed.

  PROCEDURE [INLINE] link_page_to_segment_ds
    (    pfti: mmt$page_frame_index;
         pfte_p: ^mmt$page_frame_table_entry;
         aste_p: ^mmt$active_segment_table_entry);

{ Debug code

    IF (pfte_p^.segment_link.fwd <> 0) AND (pfte_p^.segment_link.bkw <> 0) THEN
      osp$system_error ('LINK PAGE TO SEGMENT ERROR.', NIL);
    IFEND;

{ End debug code

    IF aste_p^.pft_link.fwd = 0 THEN
      aste_p^.pft_link.fwd := pfti;
      aste_p^.pft_link.bkw := pfti;
    ELSE
      mmv$pft_p^ [aste_p^.pft_link.bkw].segment_link.fwd := pfti;
      pfte_p^.segment_link.bkw := aste_p^.pft_link.bkw;
      aste_p^.pft_link.bkw := pfti;
    IFEND;

  PROCEND link_page_to_segment_ds;

?? TITLE := 'mmp$sdtx_initialization', EJECT ??

  PROCEDURE [XDCL] mmp$sdtx_initialization;

*copyc mmh$sdtx_initialization

    VAR
      sdt_p: mmt$max_sdt_p,
      sdtx_entry: mmt$segment_descriptor_extended,
      sdtx_p: mmt$max_sdtx_p,
      xcb_p: ^ost$execution_control_block,
      segnum: ost$segment,
      tos_array_index: ost$ring,
      rb: mmt$rb_ring1_segment_request;


{  Set pointer to SDTX in XCB.

    xcb_p := ^jmv$jmtr_xcb;
    xcb_p^.sdt_offset := #OFFSET (^jmv$sdt);
    xcb_p^.sdtx_offset := #OFFSET (^jmv$sdtx);

    mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);


{ Initialize the SDTX entry for each valid SDT entry. By default each segment is assumed
{ to be pageable shared system template segments. Exceptions to this rule must be accounted for
{ by specifically changing attributes later in this proc.

    sdtx_entry := mmv$default_sdtx_entry;
    sdtx_entry.inheritance := mmc$si_share_segment;
    sdtx_entry.open_validating_ring_number := 0;

    FOR segnum := xcb_p^.xp.segment_table_length DOWNTO 0 DO
      IF sdt_p^.st [segnum].ste.vl <> osc$vl_invalid_entry THEN
        sdtx_p^.sdtx_table [segnum] := sdtx_entry;
        mmp$set_segment_access_rights (sdt_p^.st [segnum], sdtx_p^.sdtx_table [segnum]);
      IFEND;
    FOREND;

{ Set the page table to be read only.

    sdtx_p^.sdtx_table [osc$segnum_page_table].access_rights := mmc$sar_read;


{ Set software attributes for special segments.

    sdtx_p^.sdtx_table [osc$segnum_page_table].software_attribute_set :=
          $mmt$software_attribute_set [mmc$sa_wired];
    sdtx_p^.sdtx_table [#SEGMENT (#LOC (osv$mainframe_wired_heap^))].software_attribute_set :=
          $mmt$software_attribute_set [mmc$sa_wired];
    sdtx_p^.sdtx_table [#SEGMENT (#LOC (osv$mainframe_wired_cb_heap^))].
          software_attribute_set := $mmt$software_attribute_set [mmc$sa_wired];
    sdtx_p^.sdtx_table [#SEGMENT (#LOC (nav$network_wired_heap^))].software_attribute_set :=
          $mmt$software_attribute_set [mmc$sa_wired];
    sdtx_p^.sdtx_table [osc$segnum_job_fixed_heap].software_attribute_set :=
          $mmt$software_attribute_set [mmc$sa_fixed];

    sdtx_p^.sdtx_table [osc$segnum_job_fixed_heap].open_validating_ring_number := 1;


{ The file server wired heap is shared with the network wired heap.
{ The file server is the ending portion of this heap.

    dfv$server_wired_heap := #ADDRESS (#RING (nav$network_wired_heap), #SEGMENT (nav$network_wired_heap),
          nac$network_heap_size);
    osp$reset_heap (dfv$server_wired_heap, 3fffffff(16) - nac$network_heap_size, TRUE, 2);
    osp$reset_heap (nav$network_wired_heap, nac$network_heap_size, TRUE, nac$heap_algorithm);
    osp$reset_heap (nav$network_paged_heap, nac$network_heap_size, TRUE, nac$heap_algorithm);


{  For ring 1, 2, and 3 stack segments, set software attributes.

    FOR tos_array_index := 1 TO 3 DO
      segnum := xcb_p^.xp.tos_registers [tos_array_index].pva.seg;
      IF sdt_p^.st [segnum].ste.vl <> osc$vl_invalid_entry THEN
        sdtx_p^.sdtx_table [segnum].software_attribute_set := $mmt$software_attribute_set [mmc$sa_stack];
        sdtx_p^.sdtx_table [segnum].open_validating_ring_number := 1;
        sdtx_p^.sdtx_table [segnum].inheritance := mmc$si_new_segment;
      IFEND;
    FOREND;

  PROCEND mmp$sdtx_initialization;

?? TITLE := 'MMP$COMMIT_MEMORY' ??
?? EJECT ??

  PROCEDURE [XDCL] mmp$commit_memory;

    VAR
      rb: mmt$rb_ring1_segment_request;

*copyc mmh$commit_memory

    rb.reqcode := syc$rc_ring1_segment_request;
    rb.request := mmc$sr1_commit_memory;

    mmp$issue_ring1_segment_request (rb);

  PROCEND mmp$commit_memory;
?? TITLE := 'MMP$FREE_IMAGE_PAGES' ??
?? EJECT ??

  PROCEDURE [XDCL] mmp$free_image_pages;

    VAR
      rb: mmt$rb_ring1_segment_request;

*copyc mmh$free_image_pages

    rb.reqcode := syc$rc_ring1_segment_request;
    rb.request := mmc$sr1_free_image_pages;

    mmp$issue_ring1_segment_request (rb);

  PROCEND mmp$free_image_pages;
?? TITLE := 'MMP$DEFINE_IMAGE_FILE' ??
?? EJECT ??

  PROCEDURE [XDCL] mmp$define_image_file
    (    sfid: dmt$system_file_id;
         length: 0 .. 0ffffffff(16));

*copyc mmh$define_image_file

    mmv$image_file.active := TRUE;
    mmv$image_file.sfid := sfid;
    mmv$image_file.file_offset := length;

  PROCEND mmp$define_image_file;
MODEND mmm$deadstart_initialization;
*DECK DECK=MMM$FILE_SERVER_PROCESSOR EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'MMM$FILE_SERVER_PROCESSOR - monitor file_server request handlers, i/o processors, helpers, etc.'
      ??
MODULE mmm$file_server_processor;

?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dfk$keypoints
*copyc dft$procedure_address_ordinal
*copyc dft$queue_entry_location
*copyc dft$remote_request
*copyc dft$server_iocb_error_condition
*copyc dfv$monitor_io_start_time
*copyc dmt$mass_storage_error_codes
*copyc dmt$segment_file_information
*copyc dfv$trace_count
*copyc gfc$constants
*copyc gft$file_desc_entry_p
*copyc gft$locked_file_desc_entry_p
*copyc gft$system_file_identifier
*copyc ioe$st_errors
*copyc iot$io_function
*copyc jmt$active_job_list
*copyc jmt$initiated_job_list_entry
*copyc jmv$null_ijl_ordinal
*copyc jmv$system_ijl_ordinal
*copyc mmc$file_server_segment_number
*copyc mme$condition_codes
*copyc mmt$active_segment_table
*copyc mmt$buffer_descriptor
*copyc mmt$file_server_io_status
*copyc mmt$io_identifier
*copyc mmt$page_frame_index
*copyc mmt$page_pull_status
*copyc mmt$read_ahead_iocb_table
*copyc mmt$segment_descriptor_table
*copyc mmt$segment_descriptor_table_ex
*copyc mmt$server_io_control_block
*copyc mmt$write_modified_pages_status
*copyc mmv$aggressive_aging_level
*copyc mmv$ast_p
*copyc mmv$last_active_shared_queue
*copyc mmv$multiple_page_maps
*copyc mmv$pft_p
*copyc mmv$pt_p
*copyc mmv$reassignable_page_frames
*copyc mtv$monitor_segment_table
*copyc ost$cpu_state_table
*copyc ost$hardware_subranges
*copyc osv$mainframe_wired_heap
*copyc osv$page_size
*copyc osv$simulated_disk_fault
*copyc sft$file_space_limit_kind
*copyc tmv$null_global_task_id
?? POP ??
?? NEWTITLE := '  External Procedures' ??

{ External procedures used by this module.

*copyc dfp$client_io
*copyc dfp$fetch_server_iocb
*copyc dfp$free_queue_entry
*copyc dfp$incr_monitor_io_stats
*copyc dfp$init_monitor_io_stats
*copyc dfp$send_allocate_response
*copyc dfp$send_write_response
*copyc dfp$set_monitor_entry_alert
*copyc dfp$term_monitor_io_stats
*copyc dmp$fetch_page_status
*copyc gfp$mtr_get_fde_p
*copyc gfp$mtr_get_locked_fde_p
*copyc i#mtr_disable_traps
*copyc i#program_error
*copyc mmp$asid
*copyc mmp$assign_asid
*copyc mmp$assign_page_frame
*copyc mmp$delete_pt_entry
*copyc mmp$mm_write_modified_pages
*copyc mmp$page_pull
*copyc mmp$page_pull_hash_sva
*copyc mmp$relink_page_frame
*copyc mmp$remove_pages_working_set
*copyc mmp$get_verify_asti_in_fde
*copyc mtp$error_stop
?? OLDTITLE, NEWTITLE := '  Global variables for file_server statistics', EJECT ??

  CONST
    number_of_file_server_pf_recs = 256;

  TYPE
    mmt$pstatus_and_sva_info = packed record
      pstatus_time: 0 .. 0ffff(16),
      sva: ost$system_virtual_address,
    recend;

*copyc mmt$pf_statistics
*copyc mmt$df_client_io_pf_stats
*copyc mmt$df_write_server_pf_stats

  TYPE
    mmt$df_server_sva_array = record
      next_i: integer,
      file_server_pf_recs: array [0 .. number_of_file_server_pf_recs - 1] of mmt$pstatus_and_sva_info
    recend;

*if $variable(mmc$df_debug_for_read_ahead declared) <> 'UNKNOWN'

  TYPE
    mmt$df_server_iocb_trace_record = record
      server_iocb: mmt$server_iocb_entry,
      read_ahead: boolean,
      timestamp: integer,
    recend,

    mmt$df_server_iocb_trace = record
      next_i: integer,
      server_iocb_trace_records: array [0 .. number_of_file_server_pf_recs - 1] of
            mmt$df_server_iocb_trace_record,
    recend;

  VAR
    mmv$df_server_iocb_trace: [XDCL, #GATE] mmt$df_server_iocb_trace :=
          [0, [REP number_of_file_server_pf_recs of [ * , FALSE, 0]]];

*else

{ ---------- Debug statistics declarations were omitted at compilation time ---------- }

*ifend

  VAR
{   Statistics maintained by the procedure PROCESS_READ_FOR_SERVER:
    mmv$df_read_server_pf_stats: [XDCL, #GATE] mmt$pf_statistics := [REP 19 of 0],
    mmv$df_read_server_sva_array: [XDCL] mmt$df_server_sva_array :=
          [0, [REP number_of_file_server_pf_recs of [0, * ]]];

  VAR
{   Statistics maintained by the procedure PROCESS_WRITE_FOR_SERVER:
    mmv$df_write_server_pf_stats: [XDCL] mmt$df_write_server_pf_stats := [REP 6 of 0],
    mmv$df_write_server_sva_array: [XDCL] record
      next_i: integer,
      file_server_pf_recs: array [0 .. number_of_file_server_pf_recs - 1] of mmt$pstatus_and_sva_info,
    recend := [0, [REP number_of_file_server_pf_recs of [0, * ]]];

  VAR
{   Statistics maintained by the procedure PROCESS_READ_FROM_CLIENT:
    mmv$df_read_client_sva_array: [XDCL] record
      next_i: integer,
      file_server_pf_recs: array [0 .. number_of_file_server_pf_recs - 1] of mmt$pstatus_and_sva_info,
    recend := [0, [REP number_of_file_server_pf_recs of [0, * ]]];

  VAR
{   Statistics maintained by the procedure PROCESS_WRITE_TO_CLIENT:
    mmv$df_write_client_sva_array: [XDCL] record
      next_i: integer,
      file_server_pf_recs: array [0 .. number_of_file_server_pf_recs - 1] of mmt$pstatus_and_sva_info,
    recend := [0, [REP number_of_file_server_pf_recs of [0, * ]]];

  VAR
{   Statistics maintained by the procedures PROCESS_WRITE_TO_CLIENT and PROCESS_READ_FROM_CLIENT:
    mmv$df_client_io_pf_stats: [XDCL] mmt$df_client_io_pf_stats := [REP 13 of 0];

?? OLDTITLE, NEWTITLE := '  Global variables for file_server', EJECT ??

{ This is the system attribute which enables the Set_Mass_Storage_Fault command.
{ The condition "LOCKED PAGE" on read for client may be simulated via SETMSF.
  VAR
    osv$disk_fault_simulation: [XREF] boolean;

  VAR
    mmv$read_ahead_enabled: [XDCL] boolean := FALSE,

    mmv$read_ahead_iocb_table: [XDCL] mmt$read_ahead_iocb_table := [REP (mmc$iocb_table_size + 1) of [FALSE]],
    mmv$read_ahead_iocb_table_p: [XDCL] ^mmt$read_ahead_iocb_table := NIL;

{ NOTE: The template declared here has the field IN_USE set to TRUE in order to blank out the rest
{ of the variant.  BE SURE to set this field to FALSE when using this template to initialize a
{ read_ahead_iocb_entry.

  VAR
    mmv$null_read_ahead_iocb_entry: [XDCL, STATIC, READ] mmt$read_ahead_iocb_entry :=
          [TRUE, [[0, *, 0], 0, 0], 0, dfc$null_server_condition,
          [FALSE, ioc$read_page, [0, 0], 0]];

{ These statistics contain the number of read_ahead requests which were attempted and completed.

  VAR
    mmv$ra_rq_attempted: [XDCL] integer := 0,
    mmv$ra_rq_rejected: [XDCL] integer := 0,
    mmv$ra_rq_completed_needed: [XDCL] integer := 0,
    mmv$ra_rq_completed_not_needed: [XDCL] integer := 0;

  VAR
    mmv$read_ahead_trap_enabled: [XDCL] boolean := FALSE,
    mmv$halt_if_server_page_locked: [XDCL] boolean := FALSE;

?? OLDTITLE, NEWTITLE := '  File Server procedures:' ??
?? NEWTITLE := '    ALLOCATE_SERVER_SPACE', EJECT ??

  PROCEDURE allocate_server_space
    (    server_iocb_p: ^mmt$server_iocb_entry);

    VAR
      fde_p: gft$file_desc_entry_p,
      page_status: gft$page_status;

{ Check if the file is allocated.  Only check the last page; if the last page is allocated, all pages
{ up to the last are allocated because sparse allocation is not supported for served permanent files.
{ NOTE: Although this is a File Server procedure and executes on the Server side of a File_Server
{ configuration, it is really working on normal permanent files; i.e. there is a Disk_File_Descriptor_P
{ in the File_Desciptor_Entry for the file, not a Served_File_Descriptor_P.  Therefore, page_status must
{ be fetched with DMP$FETCH_PAGE_STATUS, not DFP$FETCH_PAGE_STATUS.

    gfp$mtr_get_fde_p (server_iocb_p^.sfid, NIL, fde_p);
    dmp$fetch_page_status (fde_p, (server_iocb_p^.length - 1), sfc$no_limit, TRUE, page_status);

    CASE page_status OF
    = gfc$ps_page_doesnt_exist, gfc$ps_page_on_disk =
{     Do nothing.  This is expected.

    = gfc$ps_volume_unavailable =
      server_iocb_p^.condition := dfc$volume_unavailable;

    ELSE
      server_iocb_p^.condition := dfc$reissued_rq_io_temp_reject;
    CASEND;

  PROCEND allocate_server_space;
?? OLDTITLE, NEWTITLE := '    CONVERT_SFID_OFFSET', EJECT ??

  PROCEDURE convert_sfid_offset
    (    server_iocb_p: ^mmt$server_iocb_entry;
     VAR sva: ost$system_virtual_address;
     VAR fde_p: gft$locked_file_desc_entry_p;
     VAR aste_p: ^mmt$active_segment_table_entry;
     VAR bad_sfid: boolean);

{ This routine is used on the server side.  It is modeled after mmp$convert_pva.
{ The purpose of this routine is to avoid having the server "task" have a
{ segment descriptor table for each file on the server. I/O for these
{ files must be performed using SFID as a base rather than PVA, like a regular
{ segment access file.


    VAR
      asid: ost$asid,
      asti: mmt$ast_index,
      count: 1 .. 32,
      fde_p_sva: ost$system_virtual_address,
      found: boolean,
      ipti: integer;


    bad_sfid := FALSE;
    sva.offset := server_iocb_p^.offset;
    sva.asid := 0;

{   Instead of calling gfp$mtr_get_locked_fde_p, do the following in case the sfid received
{   from the client is bad.

    IF server_iocb_p^.sfid.residence <> gfc$tr_system THEN
      bad_sfid := TRUE;
      RETURN;
    IFEND;

    fde_p_sva.asid := mtv$monitor_segment_table.st [1].ste.asid;
    fde_p_sva.offset := gfc$fde_table_base + gfc$fde_size * server_iocb_p^.sfid.file_entry_index;
    #HASH_SVA (fde_p_sva, ipti, count, found);
    IF NOT found THEN
      bad_sfid := TRUE;
      RETURN;
    IFEND;

    fde_p := #ADDRESS (1, 1, fde_p_sva.offset);
    IF server_iocb_p^.sfid.file_hash <> fde_p^.file_hash THEN
      bad_sfid := TRUE;
      RETURN;
    IFEND;

    IF fde_p^.global_file_name <> server_iocb_p^.global_file_name THEN
      bad_sfid := TRUE;
      RETURN;
    IFEND;

{   Check for the active segment table entry existence.

    mmp$get_verify_asti_in_fde (fde_p, server_iocb_p^.sfid, jmv$null_ijl_ordinal, asti);
    IF asti = 0 THEN

{   The active segment table entry does not exist.  Create one for the segment
{   and let Device Manager know about it.

      initialize_server_ast_entry (fde_p, server_iocb_p^.sfid, asid, aste_p);
      sva.asid := asid;

    ELSE

{     The AST exists.  Set fields based on DM information.  Set the queue_id to be shared.

      aste_p := ^mmv$ast_p^ [asti];
      IF (fde_p^.queue_ordinal <> 0) AND
            (fde_p^.queue_ordinal <= mmv$last_active_shared_queue) THEN
        aste_p^.queue_id := fde_p^.queue_ordinal;
      ELSE
        aste_p^.queue_id := mmc$pq_shared_file_server;
      IFEND;
      aste_p^.ijl_ordinal := jmv$system_ijl_ordinal;

{     Set the ASID in the sva to the current asid.

      mmp$asid (asti, asid);
      sva.asid := asid;
    IFEND;

  PROCEND convert_sfid_offset;
?? OLDTITLE, NEWTITLE := '    CREATE_PAGES_NEEDED ', EJECT ??

  PROCEDURE create_pages_needed
    (    pages_needed: mmt$page_frame_index;
         sva: ost$system_virtual_address;
         aste_p: ^mmt$active_segment_table_entry;
     VAR read_status: mmt$file_server_io_status);

{ This procedure creates pages in central memory for use by incoming pages of
{ data, from the client via ESM.  It is modeled after MMP$PROCESS_ASSIGN_PAGES.

    VAR
      assigned_page_count: mmt$page_frame_index,
      first_new_pfti: mmt$page_frame_index,
      found: boolean,
      hash_count: 1 .. 32,
      local_sva: ost$system_virtual_address,
      next_pfti: mmt$page_frame_index,
      pfte_p: ^mmt$page_frame_table_entry,
      pfti: mmt$page_frame_index,
      pstatus: mmt$page_pull_status,
      pte_p: ^ost$page_table_entry,
      pti: integer,
      requested_page_count: mmt$page_frame_index;


{   Check for low on memory.

    IF (mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon - pages_needed) <=
          mmv$aggressive_aging_level_2 THEN
      read_status := mmc$df_low_on_memory;
      RETURN;
    IFEND;

{ Any pages in the requested range that are already in memory need to be marked as valid
{ and used; pages that are not in memory need to be assigned.

    first_new_pfti := 0;
    local_sva := sva;
    requested_page_count := pages_needed;

  /get_pages/
    WHILE requested_page_count > 0 DO

{ Find the page table index from the SVA.

      #HASH_SVA (local_sva, pti, hash_count, found);

      IF found THEN

{ Find the page table entry from the PTI.

        pfti := (mmv$pt_p^ [pti].rma * 512) DIV osv$page_size;
        pfte_p := ^mmv$pft_p^ [pfti];
        pte_p := ^mmv$pt_p^ [pti];
        IF NOT pte_p^.v THEN

{ Check the lock in the page frame table entry.

          IF (pfte_p^.locked_page = mmc$lp_page_in_lock) OR (pfte_p^.locked_page =
                mmc$lp_write_protected_lock) THEN
            read_status := mmc$df_locked_page;
            EXIT /get_pages/;

          ELSEIF (pfte_p^.locked_page = mmc$lp_aging_lock) THEN
            mtp$error_stop ('MM - server page fault for locked page');
          IFEND;
        IFEND;

{ If the page frame is in the available or available_modified queue, relink it and make it valid.
{ There is data in the page, so it is okay to be read.  If it is in a working set and not valid,
{ there must be a read from disk on the server active; the page cannot be made valid because
{ there isn't good data in the page.

        IF pfte_p^.queue_id <= mmc$pq_first_valid_in_pt THEN
          pfte_p^.ijl_ordinal := jmv$system_ijl_ordinal;
          mmp$relink_page_frame (pfti, aste_p^.queue_id);
          pte_p^.v := TRUE;
        IFEND;

        requested_page_count := requested_page_count - 1;
        local_sva.offset := local_sva.offset + osv$page_size;
      ELSE

{ The page is not already in memory; assign a new page to memory.  MMP$ASSIGN_PAGE_FRAME
{ will start at the sva passed to it and assign pages until the requested count is reached or
{ until one of the pages in the requested range is found already in memory.  The procedure
{ returns the number of pages that were assigned.

        mmp$assign_page_frame (local_sva, aste_p, requested_page_count, 0, assigned_page_count, pfti,
              pstatus);

        IF first_new_pfti = 0 THEN
          first_new_pfti := pfti;
        IFEND;

        requested_page_count := requested_page_count - assigned_page_count;

        IF pstatus = ps_no_memory THEN
          read_status := mmc$df_no_memory;
          EXIT /get_pages/;
        ELSEIF pstatus = ps_pt_full THEN
          read_status := mmc$df_pt_full;
          EXIT /get_pages/;
        ELSEIF (pstatus <> ps_done) AND (pstatus <> ps_valid_in_pt) THEN
          mtp$error_stop ('DF - unexpected pstatus, CREATE_PAGES_NEEDED');
        IFEND;

        local_sva.offset := local_sva.offset + (assigned_page_count * osv$page_size);
      IFEND;
    WHILEND /get_pages/;

    IF requested_page_count <> 0 THEN

{ We were not able to obtain all the pages that were needed.
{ All new pages that were assigned must be freed.  Any pages with the page-in lock
{ set must be left alone so that the task that is waiting for the page will be
{ readied when the disk I/O on it completes. (No locked pages should be encountered
{ in this scan, but double check anyway.)

      pfti := first_new_pfti;
      WHILE pfti <> 0 DO
        pte_p := ^mmv$pt_p^ [mmv$pft_p^ [pfti].pti];
        pfte_p := ^mmv$pft_p^ [pfti];
        next_pfti := pfte_p^.link.bkw;
        IF NOT pte_p^.v AND (pfte_p^.locked_page = mmc$lp_not_locked) THEN
          mmp$delete_pt_entry (pfti, TRUE);
          mmp$relink_page_frame (pfti, mmc$pq_free);
        IFEND;
        pfti := next_pfti;
      WHILEND;
    ELSE
      read_status := mmc$df_page_in_esm;
    IFEND;

  PROCEND create_pages_needed;
?? OLDTITLE, NEWTITLE := '    INITIALIZE_SERVER_AST_ENTRY', EJECT ??

  PROCEDURE initialize_server_ast_entry
    (    fde_p: gft$locked_file_desc_entry_p;
         sfid: gft$system_file_identifier;
     VAR asid: ost$asid;
     VAR aste_p: ^mmt$active_segment_table_entry);

{ This procedure initializes an active segment table entry for a server
{ file segment.  This is a server-side procedure.

    VAR
      asti: mmt$ast_index;


{   Assign an ASID for this segment.

    mmp$assign_asid (asid, asti, aste_p);

    fde_p^.asti := asti;
    IF (fde_p^.queue_ordinal <> 0) AND
          (fde_p^.queue_ordinal <= mmv$last_active_shared_queue) THEN
      aste_p^.queue_id := fde_p^.queue_ordinal;
    ELSE
      aste_p^.queue_id := mmc$pq_shared_file_server;
    IFEND;
    aste_p^.ijl_ordinal := jmv$system_ijl_ordinal;
    aste_p^.sfid := sfid;
    aste_p^.include_pages_in_dump := FALSE;

  PROCEND initialize_server_ast_entry;
?? OLDTITLE, NEWTITLE := '    PROCESS_READ_AHEAD', EJECT ??

  PROCEDURE process_read_ahead
    (    server_iocb_p: ^mmt$server_iocb_entry;
         sva: ost$system_virtual_address;
         fde_p: gft$locked_file_desc_entry_p;
         aste_p: ^mmt$active_segment_table_entry;
         io_id: mmt$io_identifier);

{ This is a server procedure.  Its function is to set up a SEQUENTIAL read from the
{ (server) disk once a regular read from server has been issued.  The procedure is called
{ after the client reads pages from the server and we anticipate another read by the client.

    CONST
      four_k_transfer_unit = 4000(16);

    VAR
      found: boolean,
{     i: integer,
      index: 0 .. mmc$iocb_table_size,
      local_aste_p: ^mmt$active_segment_table_entry,
      local_sva: ost$system_virtual_address,
      page_count: integer,
      page_in_count: mmt$page_frame_index,
      pfti: mmt$page_frame_index,
      pstatus: mmt$page_pull_status,
      read_ahead_io_id: mmt$io_identifier;


{   Adjust the SVA offset to read the NEXT four pages for which we anticipate
{   a need.  If the number of pages we need puts us beyond the EOI of the file,
{   return without issuing the read_ahead.

{!  Eventually the transfer_size in device_manager will be equal to the allocation_unit size of the
{!  file in question.  Currently, we cannot use this size; so, until we can determine what the AU size is,
{!  the following statement will have to do.

    local_sva := sva;
    local_sva.offset := local_sva.offset + four_k_transfer_unit;
    IF (local_sva.offset + server_iocb_p^.length) >= server_iocb_p^.eoi THEN
      RETURN;
    IFEND;

{   Locate an unused entry in the read_ahead_iocb_table.  If one is found,
{   set up the fields which will be used for the page-in process.

    found := FALSE;
    index := 0;

  /locate_unused/
    REPEAT
      IF NOT mmv$read_ahead_iocb_table_p^ [index].in_use THEN
        found := TRUE;
      ELSEIF index = mmc$iocb_table_size THEN
        EXIT /locate_unused/;
      ELSE
        index := index + 1;
      IFEND;
    UNTIL found;

    IF NOT found THEN
      RETURN;
    IFEND;

{   An unused entry was found. Set it up for the read_ahead.

    mmv$read_ahead_iocb_table_p^ [index] := mmv$null_read_ahead_iocb_entry;
    mmv$read_ahead_iocb_table_p^ [index].read_ahead_request_info.sfid := server_iocb_p^.sfid;
    mmv$read_ahead_iocb_table_p^ [index].read_ahead_request_info.offset := local_sva.offset;
    mmv$read_ahead_iocb_table_p^ [index].read_ahead_request_info.length := server_iocb_p^.length;
    mmv$read_ahead_iocb_table_p^ [index].condition := dfc$null_server_condition;
    mmv$read_ahead_iocb_table_p^ [index].active_io_count := 0;

{   Set up a read_ahead io_id.

    read_ahead_io_id.specified := TRUE;
    read_ahead_io_id.io_function := ioc$read_ahead_on_server;
    read_ahead_io_id.read_ahead_iocb_index := index;

{   Compute the page count from the server IOCB.
{   This is actually pretty easy if we assume that the client has insured the following:
{      length =  number_of_pages *  number_of_bytes_per_page

    page_count := server_iocb_p^.length DIV osv$page_size;

{   Call mmp$page_pull to bring the pages in from disk.

  /read_ahead_pages_in/
    WHILE TRUE DO

{   Pass the NIL pointers to mmp$page_pull - no CST or STXE pointers are used.

      local_aste_p := aste_p;
      mmp$page_pull_hash_sva (local_sva, local_aste_p, page_in_count, pstatus, pfti);
      IF page_in_count = 0 THEN
        mmp$page_pull (local_sva, fde_p, NIL, local_aste_p, NIL, read_ahead_io_id, page_count,
              ioc$read_ahead_on_server, TRUE, page_in_count, pstatus, pfti);
      IFEND;
      mmv$ra_rq_attempted := mmv$ra_rq_attempted + 1;

      CASE pstatus OF
      = ps_found_in_avail, ps_found_in_avail_modified, ps_valid_in_pt, ps_new_page_assigned =
        ;

      = ps_found_on_disk =

{       Set fields in the server iocb.

        mmv$read_ahead_iocb_table_p^ [index].active_io_count :=
              mmv$read_ahead_iocb_table_p^ [index].active_io_count + 1;

      = ps_no_memory =
        mmv$read_ahead_iocb_table_p^ [index].condition := dfc$reissued_rq_no_memory;
        EXIT /read_ahead_pages_in/;

      = ps_low_on_memory =
        mmv$read_ahead_iocb_table_p^ [index].condition := dfc$reissued_rq_low_on_memory;
        EXIT /read_ahead_pages_in/;

      = ps_pt_full =
        mmv$read_ahead_iocb_table_p^ [index].condition := dfc$reissued_rq_pt_full;
        EXIT /read_ahead_pages_in/;

      = ps_io_temp_reject =
        mmv$read_ahead_iocb_table_p^ [index].condition := dfc$reissued_rq_io_temp_reject;
        EXIT /read_ahead_pages_in/;

      = ps_locked =
        mmv$read_ahead_iocb_table_p^ [index].condition := dfc$server_page_locked;
        EXIT /read_ahead_pages_in/;

      = ps_read_beyond_eoi =
        mmv$read_ahead_iocb_table_p^ [index].condition := dfc$server_read_beyond_eoi;
        EXIT /read_ahead_pages_in/;

      = ps_beyond_file_limit =
        mmv$read_ahead_iocb_table_p^ [index].condition := dfc$server_beyond_file_limit;
        EXIT /read_ahead_pages_in/;

      = ps_no_extend_permission =
        mmv$read_ahead_iocb_table_p^ [index].condition := dfc$server_no_extend_permission;
        EXIT /read_ahead_pages_in/;

      = ps_volume_unavailable =
        mmv$read_ahead_iocb_table_p^ [index].condition := dfc$volume_unavailable;
        EXIT /read_ahead_pages_in/;

      ELSE
        mtp$error_stop ('MM - internal error in PROCESS_READ_AHEAD');

      CASEND;

{     Account for the pages read in.

      page_count := page_count - page_in_count;

      IF page_count > 0 THEN
        local_sva.offset := local_sva.offset + (page_in_count * osv$page_size);
      ELSE
        EXIT /read_ahead_pages_in/;
      IFEND;

    WHILEND /read_ahead_pages_in/;

{   If the active io count is still zero, delete the entry.

    IF mmv$read_ahead_iocb_table_p^ [index].active_io_count = 0 THEN
      mmv$read_ahead_iocb_table_p^ [index] := mmv$null_read_ahead_iocb_entry;
      mmv$read_ahead_iocb_table_p^ [index].in_use := FALSE;
      mmv$ra_rq_rejected := mmv$ra_rq_rejected + 1;
    IFEND;

  PROCEND process_read_ahead;
?? OLDTITLE, NEWTITLE := '    PROCESS_READ_FOR_SERVER', EJECT ??

  PROCEDURE process_read_for_server
    (    server_iocb_p: ^mmt$server_iocb_entry;
         io_id: mmt$io_identifier);

{ This is a server procedure.  Its function is to read pages from the
{ read pages from the (server) disk.  The procedure is called when the
{ client reads pages from the server.  It is modeled after mmp$mtr_read.

    CONST
      four_k_transfer_unit = 4000(16);

    VAR
      aste_p: ^mmt$active_segment_table_entry,
      bad_sfid: boolean,
      fde_p: gft$locked_file_desc_entry_p,
      fake_locked_page: boolean,
      found: boolean,
      i: integer,
      index: 0 .. mmc$iocb_table_size,
      old_te: 0 .. 3,
      page_count: integer,
      page_in_count: mmt$page_frame_index,
      pfti: mmt$page_frame_index,
      pstatus: mmt$page_pull_status,
      read_ahead_request_info: mmt$read_ahead_request_info,
      read_ahead_sva: ost$system_virtual_address,
      sva: ost$system_virtual_address;


*if $variable(mmc$df_debug_for_read_ahead declared) <> 'UNKNOWN'
    i := mmv$df_server_iocb_trace.next_i;
    mmv$df_server_iocb_trace.next_i := (i + 1) MOD number_of_file_server_pf_recs;
    mmv$df_server_iocb_trace.server_iocb_trace_records [i].server_iocb := server_iocb_p^;
    mmv$df_server_iocb_trace.server_iocb_trace_records [i].timestamp := #FREE_RUNNING_CLOCK (0);
*else
{   ---------- Debug statistics code was omitted at compilation time ---------- }
*ifend

{   If the read_ahead iocb table has not been allocated yet, do so now.

    IF mmv$read_ahead_iocb_table_p = NIL THEN
      mmv$read_ahead_iocb_table_p := ^mmv$read_ahead_iocb_table;
    IFEND;

    found := FALSE;
    IF mmv$read_ahead_enabled THEN
      IF server_iocb_p^.length > osv$page_size THEN

{       Look for a previously-issued read-ahead request which could match this new request for pages.

        index := 0;
        read_ahead_request_info.sfid := server_iocb_p^.sfid;
        read_ahead_request_info.length := server_iocb_p^.length;
        read_ahead_request_info.offset := server_iocb_p^.offset;

{       If the request is wholly contained in, or is equal to, a request which has already been issued,
{       then we've found what we're looking for.

      /locate_used/
        REPEAT
          IF (mmv$read_ahead_iocb_table_p^ [index].in_use) THEN
            IF (mmv$read_ahead_iocb_table_p^ [index].read_ahead_request_info = read_ahead_request_info) THEN

{             We have found a match for this request immediately.

              found := TRUE;
            ELSEIF read_ahead_request_info.length = four_k_transfer_unit THEN

{             Skip to the next entry.

              IF index = mmc$iocb_table_size THEN
                EXIT /locate_used/;
              ELSE
                index := index + 1;
              IFEND;
            ELSEIF mmv$read_ahead_iocb_table_p^ [index].read_ahead_request_info.sfid =
                  read_ahead_request_info.sfid THEN

{             We have found an SFID match for this request.  Test whether or not the request is contained in
{             the table_entry.

              IF ((mmv$read_ahead_iocb_table_p^ [index].read_ahead_request_info.offset +
                    mmv$read_ahead_iocb_table_p^ [index].read_ahead_request_info.length) <=
                    read_ahead_request_info.offset) THEN

{               The start of the request is not contained in the table entry.

                IF index = mmc$iocb_table_size THEN
                  EXIT /locate_used/;
                ELSE
                  index := index + 1;
                IFEND;
              ELSEIF ((read_ahead_request_info.offset + read_ahead_request_info.length) <=
                    (mmv$read_ahead_iocb_table_p^ [index].read_ahead_request_info.offset +
                    mmv$read_ahead_iocb_table_p^ [index].read_ahead_request_info.length)) AND
                    (read_ahead_request_info.offset >= mmv$read_ahead_iocb_table_p^ [index].
                    read_ahead_request_info.offset) THEN

{               The request is wholly contained within the table entry.

                found := TRUE;
              ELSE

{               The request was not entirely within the table entry.  Execution of this portion of code
{               may indicate a problem with transfer requests spanning transfer units (problem with
{               DMP$FETCH_CHAPTER_INFO), but we won't worry about this now.

                IF index = mmc$iocb_table_size THEN
                  EXIT /locate_used/;
                ELSE
                  index := index + 1;
                IFEND;
              IFEND; { contained in }

            ELSE { non-matching SFIDs }
              IF index = mmc$iocb_table_size THEN
                EXIT /locate_used/;
              ELSE
                index := index + 1;
              IFEND;
            IFEND; { immediate_match }

          ELSE { NOT in_use }
            IF index = mmc$iocb_table_size THEN
              EXIT /locate_used/;
            ELSE
              index := index + 1;
            IFEND;
          IFEND; { in_use }

        UNTIL found;

        IF found THEN

{         IF this is the FIRST request for these pages, queue the sequential read request.  Otherwise
{         ignore it because we are already processing the request asynchronously.

          IF NOT mmv$read_ahead_iocb_table_p^ [index].io_id.specified THEN
            mmv$read_ahead_iocb_table_p^ [index].io_id := io_id;
            mmv$read_ahead_iocb_table_p^ [index].io_id.specified := TRUE;
            server_iocb_p^.server_state := mmc$ss_reading_pages_ahead;
*if $variable(mmc$df_debug_for_read_ahead declared) <> 'UNKNOWN'
            mmv$df_server_iocb_trace.server_iocb_trace_records [i].read_ahead := TRUE;
*else

{ --------- Debug statistics code was omitted at compilation time --------- }

*ifend
          ELSE
            found := FALSE;
          IFEND; { not already specified }

{         This server state change will force this particular request to wait until the
{         previously-issued read_ahead request for pages - the same pages that this request will need -
{         completes.  This request will be restarted at the point where the pages can be written to ESM.


        IFEND; { found }
      IFEND; { length > page_size }
    IFEND; { read_ahead enabled }

{   Convert the sfid (input) into an SVA.

    convert_sfid_offset (server_iocb_p, sva, fde_p, aste_p, bad_sfid);
    IF bad_sfid THEN
      server_iocb_p^.condition := dfc$bad_sfid;
      RETURN;
    IFEND;

{   Save the original value of the sva in case we want to perform a read_ahead operation.
{   Making page_count = 0 will force another read_ahead even if we have found one earlier.

    read_ahead_sva := sva;
    page_count := 0;

    IF NOT found THEN
{     Compute the page count from the server IOCB.
{     This is actually pretty easy if we assume that the client has insured the following:
{        length =  number_of_pages *  number_of_bytes_per_page

      page_count := server_iocb_p^.length DIV osv$page_size;

{     Call mmp$page_pull to bring the pages in from disk.

    /server_pages_in/
      WHILE TRUE DO
        IF osv$disk_fault_simulation THEN
          simulate_locked_page (server_iocb_p^.sfid, fake_locked_page);
          IF fake_locked_page THEN
            server_iocb_p^.condition := dfc$server_page_locked;
            EXIT /server_pages_in/;
          IFEND;
        IFEND;

{       Pass the NIL pointer to mmp$page_pull - no CST or STXE pointer is used.

        mmp$page_pull_hash_sva (sva, aste_p, page_in_count, pstatus, pfti);
        IF page_in_count = 0 THEN
          mmp$page_pull (sva, fde_p, NIL, aste_p, NIL, io_id, page_count, ioc$read_for_server, TRUE,
                page_in_count, pstatus, pfti);
        IFEND;

{       Update the file_server statistics.

        mmv$df_read_server_pf_stats [$INTEGER (pstatus)] :=
              mmv$df_read_server_pf_stats [$INTEGER (pstatus)] + 1;
        i := mmv$df_read_server_sva_array.next_i;
        mmv$df_read_server_sva_array.next_i := (i + 1) MOD number_of_file_server_pf_recs;
        mmv$df_read_server_sva_array.file_server_pf_recs [i].sva := sva;
        mmv$df_read_server_sva_array.file_server_pf_recs [i].pstatus_time :=
              (#FREE_RUNNING_CLOCK (0) DIV 131072) MOD 100(16) + $INTEGER (pstatus) * 100(16);

        CASE pstatus OF
        = ps_found_in_avail, ps_found_in_avail_modified, ps_valid_in_pt, ps_new_page_assigned =
          ;

        = ps_found_on_disk =

{         Set fields in the server iocb.

          server_iocb_p^.active_io_count := server_iocb_p^.active_io_count + 1;

        = ps_no_memory =
{         The request was not honored.  Setup for reissue.

          server_iocb_p^.condition := dfc$reissued_rq_no_memory;
          EXIT /server_pages_in/;

        = ps_low_on_memory =
{         The request was not honored.  Setup for reissue.

          server_iocb_p^.condition := dfc$reissued_rq_low_on_memory;
          EXIT /server_pages_in/;

        = ps_pt_full =
{         The request was not honored.  Setup for reissue.

          server_iocb_p^.condition := dfc$reissued_rq_pt_full;
          EXIT /server_pages_in/;

        = ps_io_temp_reject =
{         The request was not honored.  Setup for reissue.

          server_iocb_p^.condition := dfc$reissued_rq_io_temp_reject;
          EXIT /server_pages_in/;

        = ps_locked =
{!        NOTE: In the future, we may need a method to reissue a request to read this page into CM.  In the
{!        meantime, we will not deal with this condition.

          server_iocb_p^.condition := dfc$server_page_locked;
*if $variable(mmc$df_debug_for_read_ahead declared) <> 'UNKNOWN'
          IF mmv$halt_if_server_page_locked THEN
            i#mtr_disable_traps (old_te);
            i#program_error;
{           mtp$error_stop ('Halt in MMMFSP: locked_server_page condition');
          IFEND;
*else

{ --------- Debug halt code was omitted at compilation time --------- }

*ifend
          EXIT /server_pages_in/;

        = ps_read_beyond_eoi =
          server_iocb_p^.condition := dfc$server_read_beyond_eoi;
          EXIT /server_pages_in/;

        = ps_beyond_file_limit =
          server_iocb_p^.condition := dfc$server_beyond_file_limit;
          EXIT /server_pages_in/;

        = ps_no_extend_permission =
          server_iocb_p^.condition := dfc$server_no_extend_permission;
          EXIT /server_pages_in/;

        = ps_volume_unavailable =
          server_iocb_p^.condition := dfc$volume_unavailable;
          EXIT /server_pages_in/;

        ELSE
          mtp$error_stop ('MM - internal error in PROCESS_READ_FOR_SERVER');

        CASEND;

{       Account for the pages read in.

        page_count := page_count - page_in_count;

        IF page_count > 0 THEN
          sva.offset := sva.offset + (page_in_count * osv$page_size);
        ELSE
          EXIT /server_pages_in/;
        IFEND;

      WHILEND /server_pages_in/;

    IFEND; { read_ahead_entry not found }

    IF mmv$read_ahead_enabled THEN
      IF server_iocb_p^.length = four_k_transfer_unit THEN
        IF page_count = 0 THEN

          IF mmv$read_ahead_trap_enabled THEN
            IF (server_iocb_p^.length < (4 * osv$page_size)) THEN
              mtp$error_stop ('MMMFSP: length less than four pages');
            IFEND;
            IF (server_iocb_p^.length > (4 * osv$page_size)) THEN
              mtp$error_stop ('MMMFSP: length greater than four pages');
            IFEND;
            IF (server_iocb_p^.offset MOD 4000(16)) <> 0 THEN
              mtp$error_stop ('MMMFSP: offset not on TU boundary');
            IFEND;
          IFEND;

          process_read_ahead (server_iocb_p, read_ahead_sva, fde_p, aste_p, io_id);
        IFEND;
      IFEND;
    IFEND;

  PROCEND process_read_for_server;
?? OLDTITLE, NEWTITLE := '    PROCESS_READ_FROM_CLIENT', EJECT ??

  PROCEDURE process_read_from_client
    (    server_iocb_p: ^mmt$server_iocb_entry;
         io_id: mmt$io_identifier);

{ This is a server procedure.  Its function is to read pages from the
{ client (via the link device).  The procedure is called when the
{ client writes pages to the server.  It is modeled after mmp$mtr_read.

    VAR
      aste_p: ^mmt$active_segment_table_entry,
      bad_sfid: boolean,
      fde_p: gft$locked_file_desc_entry_p,
      i: integer,
      rpfc_status: mmt$file_server_io_status,
      sva: ost$system_virtual_address;


    convert_sfid_offset (server_iocb_p, sva, fde_p, aste_p, bad_sfid);
    IF bad_sfid THEN
      server_iocb_p^.condition := dfc$bad_sfid;
      RETURN;
    IFEND;

{   Call read_pages_from_client to bring the pages in from ESM.

    read_pages_from_client (server_iocb_p, aste_p, sva, io_id, rpfc_status);

{   Update the file_server statistics.

    mmv$df_client_io_pf_stats [rpfc_status] := mmv$df_client_io_pf_stats [rpfc_status] + 1;
    i := mmv$df_read_client_sva_array.next_i;
    mmv$df_read_client_sva_array.next_i := (i + 1) MOD number_of_file_server_pf_recs;
    mmv$df_read_client_sva_array.file_server_pf_recs [i].sva := sva;
    mmv$df_read_client_sva_array.file_server_pf_recs [i].pstatus_time := (#FREE_RUNNING_CLOCK (0) DIV
          131072) MOD 1000(16) + $INTEGER (rpfc_status) * 1000(16);

    CASE rpfc_status OF

    = mmc$df_locked_page =

      server_iocb_p^.condition := dfc$reissue_rq_client_locked_pg;

    = mmc$df_no_memory =

      server_iocb_p^.condition := dfc$reissued_rq_no_memory;

    = mmc$df_low_on_memory =

      server_iocb_p^.condition := dfc$reissued_rq_low_on_memory;

    = mmc$df_pt_full =

      server_iocb_p^.condition := dfc$reissued_rq_pt_full;

    = mmc$df_temp_reject_fde_locked =

      server_iocb_p^.condition := dfc$reissu_rq_temp_rej_fde_lock;

    = mmc$df_temp_reject_queue_full =

      server_iocb_p^.condition := dfc$reissued_rq_temp_rej_q_full;

    = mmc$df_page_in_esm =

      server_iocb_p^.active_io_count := server_iocb_p^.active_io_count + 1;

    = mmc$df_pages_not_available =

      server_iocb_p^.condition := dfc$reissued_rq_io_temp_reject;

    = mmc$df_server_terminated =

      server_iocb_p^.condition := dfc$server_terminated;

    ELSE
      mtp$error_stop ('MM - internal error in PROCESS_READ_FROM_CLIENT');

    CASEND;

  PROCEND process_read_from_client;
?? OLDTITLE, NEWTITLE := '    PROCESS_SERVER_REQUEST', EJECT ??

  PROCEDURE process_server_request
    (    remote_request: dft$remote_request;
         io_id: mmt$io_identifier;
         server_iocb_p: ^mmt$server_iocb_entry);

{ This procedure is called when a step of a server process has
{ completed successfully, and it is ready to advance to the next step.

    VAR
      cpio_status: mmt$file_server_io_status;


    REPEAT

      #KEYPOINT (osk$debug, osk$m * $INTEGER (server_iocb_p^.server_state), dfk$server_state);
      CASE server_iocb_p^.server_state OF

      = mmc$ss_waiting =

        CASE remote_request OF

        = dfc$read_for_client =

          server_iocb_p^.server_state := mmc$ss_reading_from_disk;

{         Read the pages from the server disk.

          dfp$init_monitor_io_stats (io_id.queue_entry_location, dfc$monitor_io);
          process_read_for_server (server_iocb_p, io_id);

        = dfc$write_for_client =

          server_iocb_p^.server_state := mmc$ss_reading_from_esm;

{         Read the pages from esm.

          dfp$init_monitor_io_stats (io_id.queue_entry_location, dfc$monitor_io);
          process_read_from_client (server_iocb_p, io_id);

        = dfc$allocate_space_for_client =

          server_iocb_p^.server_state := mmc$ss_allocating_space;

{         Allocate the pages on the server disk.

          dfp$init_monitor_io_stats (io_id.queue_entry_location, dfc$monitor_allocate);
          allocate_server_space (server_iocb_p);

        ELSE { = dfc$completing_previous_request = }
          mtp$error_stop ('MM - illegal server request; PROCESS_SERVER_REQUEST');

        CASEND;

      = mmc$ss_allocating_space =
        server_iocb_p^.server_state := mmc$ss_send_allocate_response;

{       Send the response from the server disk allocate.

        send_allocate_response (server_iocb_p, io_id, cpio_status);
        CASE cpio_status OF
        = mmc$df_io_active =
          { Normal case. No change in condition.
        = mmc$df_server_terminated =
          server_iocb_p^.condition := dfc$server_terminated;
        = mmc$df_temp_reject_fde_locked =
          server_iocb_p^.condition := dfc$reissu_rq_temp_rej_fde_lock;
        = mmc$df_temp_reject_queue_full =
          server_iocb_p^.condition := dfc$reissued_rq_temp_rej_q_full;
        ELSE
          mtp$error_stop (' UNEXPECTED STATUS FROM DFP$SEND_ALLOCATE_RESPONSE');
        CASEND;

      = mmc$ss_reading_from_disk =
        server_iocb_p^.server_state := mmc$ss_writing_to_esm;

{       Write the pages into ESM.

        process_write_to_client (server_iocb_p, io_id);

      = mmc$ss_reading_from_esm =
        server_iocb_p^.server_state := mmc$ss_writing_to_disk;

{       Write the pages to the server disk.

        process_write_for_server (server_iocb_p, io_id);

      = mmc$ss_send_allocate_response =
        server_iocb_p^.server_state := mmc$ss_waiting;
        dfp$incr_monitor_io_stats (io_id.queue_entry_location);
        dfp$term_monitor_io_stats (io_id.queue_entry_location);
        RETURN;

      = mmc$ss_writing_to_esm =
        server_iocb_p^.server_state := mmc$ss_waiting;
        dfp$incr_monitor_io_stats (io_id.queue_entry_location); {Is this twice ?
        dfp$term_monitor_io_stats (io_id.queue_entry_location);
        dfp$free_queue_entry (io_id.queue_entry_location);
        RETURN;

      = mmc$ss_writing_to_disk =

{       Send the response from the server (disk) write.

        server_iocb_p^.server_state := mmc$ss_sending_write_response;
        send_write_response (server_iocb_p, io_id);
        IF server_iocb_p^.condition = dfc$null_server_condition THEN
          dfp$incr_monitor_io_stats (io_id.queue_entry_location);
          dfp$term_monitor_io_stats (io_id.queue_entry_location);
          server_iocb_p^.server_state := mmc$ss_waiting;
          RETURN;
        IFEND;

      = mmc$ss_reading_pages_ahead =

{       If the server is in this state, it has queued up a request for a read_ahead which was
{       already in progress.  The procedure PROCESS_READ_FOR_SERVER has advanced the server to
{       this state.  When the read_ahead request completes we will restart this request at the
{       point where it can begin writing pages to ESM in a normal fashion, using the original
{       queued request from the client.

        server_iocb_p^.server_state := mmc$ss_waiting;
        RETURN;

      ELSE
        mtp$error_stop ('MM - illegal server state; PROCESS_SERVER_REQUEST');

      CASEND;
    UNTIL (server_iocb_p^.condition <> dfc$null_server_condition) OR (server_iocb_p^.active_io_count <> 0);
    dfp$incr_monitor_io_stats (io_id.queue_entry_location);
    IF server_iocb_p^.server_state = mmc$ss_waiting THEN
      dfp$term_monitor_io_stats (io_id.queue_entry_location);
    IFEND;

  PROCEND process_server_request;
?? OLDTITLE, NEWTITLE := '    PROCESS_WRITE_FOR_SERVER', EJECT ??

  PROCEDURE process_write_for_server
    (    server_iocb_p: ^mmt$server_iocb_entry;
         io_id: mmt$io_identifier);

{ This procedure supports the processing of a client write request (write
{ to server) by writing the pages received from the client to the server disk.
{ The process is similar to mmp$mtr_write.  The server iocb is used to
{ pass parameters, and no CST or request block (RB) is used.

    VAR
      bad_sfid: boolean,
      fde_p: gft$locked_file_desc_entry_p,
      i: integer,
      page_count: integer,
      aste_p: ^mmt$active_segment_table_entry,
      write_status: mmt$write_modified_pages_status,
      last_written_pfti: mmt$page_frame_index,
      sva: ost$system_virtual_address,
      active_io_count: mmt$active_io_count,
      io_already_active: boolean;


    active_io_count := 0;
    io_already_active := FALSE;

{   Convert the address using sfid instead of pva (like mmp$convert_pva).

    convert_sfid_offset (server_iocb_p, sva, fde_p, aste_p, bad_sfid);
    IF bad_sfid THEN
      server_iocb_p^.condition := dfc$bad_sfid;
      RETURN;
    IFEND;

{   Write the pages out to disk.

    mmp$mm_write_modified_pages (sva, server_iocb_p^.length, fde_p, aste_p, ioc$write_for_server, TRUE, FALSE,
          io_id, active_io_count, io_already_active, last_written_pfti, write_status);
    server_iocb_p^.active_io_count := server_iocb_p^.active_io_count + active_io_count;

{   Update the file_server statistics.

    mmv$df_write_server_pf_stats [write_status] := mmv$df_write_server_pf_stats [write_status] + 1;
    i := mmv$df_write_server_sva_array.next_i;
    mmv$df_write_server_sva_array.next_i := (i + 1) MOD number_of_file_server_pf_recs;
    mmv$df_write_server_sva_array.file_server_pf_recs [i].sva := sva;
    mmv$df_write_server_sva_array.file_server_pf_recs [i].pstatus_time := (#FREE_RUNNING_CLOCK (0) DIV
          131072) MOD 1000(16) + $INTEGER (write_status) * 1000(16);

{   Check the status of the disk write.

    CASE write_status OF

    = mmc$wmp_io_complete =
{     We are processing requests from someone else, but NOT from ourselves.
      IF io_already_active THEN
        server_iocb_p^.condition := dfc$server_io_already_active;
      IFEND;

    = mmc$wmp_io_active =
{     We are processing requests from someone else AND from ourselves.
      IF io_already_active THEN
        server_iocb_p^.condition := dfc$reissued_rq_io_still_active;
      IFEND;

    = mmc$wmp_io_initiation_reject =
{     Reissue the request to check the condition of the io that was already active.
      server_iocb_p^.condition := dfc$reissued_rq_task_queued;

    = mmc$wmp_io_errors =
{     The IO request didn't work last time, and we're catching it now.  This is really bad.
      server_iocb_p^.condition := dfc$disk_media_error;

    = mmc$wmp_server_terminated =
{     Theoretically, this status should never be returned here.
      mtp$error_stop ('MM - write_status = server_terminated, PROCESS_WRITE_FOR_SERVER');

    = mmc$wmp_volume_unavailable =
      server_iocb_p^.condition := dfc$volume_unavailable;

    ELSE
      mtp$error_stop ('MM - internal error: write_status > 6, PROCESS_WRITE_FOR_SERVER');

    CASEND;

  PROCEND process_write_for_server;
?? OLDTITLE, NEWTITLE := '    PROCESS_WRITE_TO_CLIENT', EJECT ??

  PROCEDURE process_write_to_client
    (    server_iocb_p: ^mmt$server_iocb_entry;
         io_id: mmt$io_identifier);

{ This procedure supports the processing of a client read request (read
{ from server) by writing the pages (from the server disk) to the link device (ESM).
{ The process is similar to mmp$mtr_write.  The server iocb is used to
{ pass parameters, and no CST or request block (RB) is used.


    VAR
      aste_p: ^mmt$active_segment_table_entry,
      bad_sfid: boolean,
      fde_p: gft$locked_file_desc_entry_p,
      i: integer,
      page_count: integer,
      sva: ost$system_virtual_address,
      write_status: mmt$file_server_io_status;


{   Convert the address using sfid instead of pva (like mmp$convert_pva).

    convert_sfid_offset (server_iocb_p, sva, fde_p, aste_p, bad_sfid);
    IF bad_sfid THEN
      server_iocb_p^.condition := dfc$bad_sfid;
      RETURN;
    IFEND;

{   Write the pages out to the link device (ESM).

    write_pages_to_client (server_iocb_p, sva, io_id, write_status);

{   Update the file_server statistics.

    mmv$df_client_io_pf_stats [write_status] := mmv$df_client_io_pf_stats [write_status] + 1;
    i := mmv$df_write_client_sva_array.next_i;
    mmv$df_write_client_sva_array.next_i := (i + 1) MOD number_of_file_server_pf_recs;
    mmv$df_write_client_sva_array.file_server_pf_recs [i].sva := sva;
    mmv$df_write_client_sva_array.file_server_pf_recs [i].pstatus_time := (#FREE_RUNNING_CLOCK (0) DIV
          131072) MOD 1000(16) + $INTEGER (write_status) * 1000(16);

    CASE write_status OF
    = mmc$df_pages_not_available =
      server_iocb_p^.condition := dfc$server_pages_not_available;

    = mmc$df_io_active =
      server_iocb_p^.active_io_count := server_iocb_p^.active_io_count + 1;

    = mmc$df_task_queued =
      server_iocb_p^.condition := dfc$reissued_rq_task_queued;

    = mmc$df_io_error =
      server_iocb_p^.condition := dfc$server_write_client_error;

    = mmc$df_temp_reject_fde_locked =
      server_iocb_p^.condition := dfc$reissu_rq_temp_rej_fde_lock;

    = mmc$df_temp_reject_queue_full =
      server_iocb_p^.condition := dfc$reissued_rq_temp_rej_q_full;

    = mmc$df_server_terminated =
      server_iocb_p^.condition := dfc$server_terminated;

    ELSE
      mtp$error_stop (' Unexpected STATUS from WRITE_PAGES_TO_CLIENT');

    CASEND;

{   Remove the pages from the working set (of the server task).

{   mmp$remove_pages_working_set (sva, server_iocb_p^.length, aste_p, page_count);

  PROCEND process_write_to_client;
?? OLDTITLE, NEWTITLE := '    READ_PAGES_FROM_CLIENT', EJECT ??

  PROCEDURE read_pages_from_client
    (    server_iocb_p: ^mmt$server_iocb_entry;
         aste_p: ^mmt$active_segment_table_entry;
         sva: ost$system_virtual_address;
         io_id: mmt$io_identifier;
     VAR read_status: mmt$file_server_io_status);

{ This procedure reads pages within a specified SVA range
{ from the link device (from the client).

    VAR
      buffer_descriptor: mmt$buffer_descriptor,
      local_sva: ost$system_virtual_address,
      page_count,
      page_count_index: mmt$page_frame_index;


{   Calculate the page count from the server iocb.
{   This is actually pretty easy if we assume that the client has insured the following:
{      length =  number_of_pages *  number_of_bytes_per_page

    page_count := server_iocb_p^.length DIV osv$page_size;

{   Create the pages needed for the read (from ESM into CM).

    local_sva := sva;
    create_pages_needed (page_count, local_sva, aste_p, read_status);

{   If the pages were not found in ESM, just return.

    IF read_status <> mmc$df_page_in_esm THEN
      RETURN;
    IFEND;

{   Initialize the buffer descriptor.

    buffer_descriptor.buffer_descriptor_type := mmc$bd_explicit_io;
    buffer_descriptor.sva := sva;
    buffer_descriptor.page_count := page_count;

{   Perform the input (from the client).

    dfp$client_io (server_iocb_p, ioc$read_from_client, io_id, buffer_descriptor, read_status);

  PROCEND read_pages_from_client;
?? OLDTITLE, NEWTITLE := '    [INLINE] SEND_ALLOCATE_RESPONSE', EJECT ??

  PROCEDURE [INLINE] send_allocate_response
    (    server_iocb_p: ^mmt$server_iocb_entry;
         io_id: mmt$io_identifier;
     VAR cpio_status: mmt$file_server_io_status);

    dfp$send_allocate_response (server_iocb_p, io_id, cpio_status);

  PROCEND send_allocate_response;
?? OLDTITLE, NEWTITLE := '    [INLINE] SEND_WRITE_RESPONSE', EJECT ??
   {INLINE}
  PROCEDURE send_write_response
    (    server_iocb_p: ^mmt$server_iocb_entry;
         io_id: mmt$io_identifier);

    VAR
      cpio_status: mmt$file_server_io_status;

    dfp$send_write_response (server_iocb_p, io_id, cpio_status);
    CASE cpio_status OF
    = mmc$df_io_active =
      { Normal case. No change in condition.
    = mmc$df_server_terminated =
      server_iocb_p^.condition := dfc$server_terminated;
    = mmc$df_temp_reject_fde_locked =
      server_iocb_p^.condition := dfc$reissu_rq_temp_rej_fde_lock;
    = mmc$df_temp_reject_queue_full =
      server_iocb_p^.condition := dfc$reissued_rq_temp_rej_q_full;
    ELSE
      mtp$error_stop (' UNEXPECTED STATUS FROM DFP$SEND_WRITE_RESPONSE');
    CASEND;

  PROCEND send_write_response;
?? OLDTITLE, NEWTITLE := '    WRITE_PAGES_TO_CLIENT', EJECT ??

  PROCEDURE write_pages_to_client
    (    server_iocb_p: ^mmt$server_iocb_entry;
         sva: ost$system_virtual_address;
         io_id: mmt$io_identifier;
     VAR write_status: mmt$file_server_io_status);

{ This procedure writes pages within a specified SVA range
{ to the link device (to the client).

    VAR
      buffer_descriptor: mmt$buffer_descriptor;


{   Initialize the buffer descriptor.

    buffer_descriptor.buffer_descriptor_type := mmc$bd_explicit_io;
    buffer_descriptor.sva := sva;
    buffer_descriptor.page_count := server_iocb_p^.length DIV osv$page_size;

{   Perform the output (to the client).

    dfp$client_io (server_iocb_p, ioc$write_to_client, io_id, buffer_descriptor, write_status);

  PROCEND write_pages_to_client;
?? OLDTITLE, NEWTITLE := '    [XDCL] MMP$MTR_PROCESS_SERVER_COMPLETE.', EJECT ??

  PROCEDURE [XDCL] mmp$mtr_process_server_complete
    (    remote_request: dft$remote_request;
         io_id: mmt$io_identifier;
         server_iocb_p: ^mmt$server_iocb_entry;
         io_status: syt$monitor_status);

{ This procedure executes on the server.  It performs similarly to
{ mmp$mtr_process_io_completions for a disk i/o completion.  The differences
{ lie in the fact that this procedure handles esm i/o completions as well.

{ The following TYPE is used to convert an IO_status.condition of type OST$STATUS_CONDITION
{ (length = 5 bytes), into a server_iocb.condition of type DFT$SERVER_IOCB_ERROR_CONDITION
{ (length = 1 byte).

    TYPE
      condition_converter = record
        case 0 .. 2 of
        = 0 =
          intermediate: integer, { 8 bytes }
        = 1 =
          fill_1: 0 .. 0ffffff(16), { 3 bytes }
          io_condition: 0 .. 0ffffffffff(16), { 5 bytes }
        = 2 =
          fill_2: 0 .. 0ffffffffffffff(16), { 7 bytes }
          server_condition: dft$server_iocb_error_condition, { 1 byte }
        casend,
      recend;

    VAR
      converter: condition_converter,
      cpio_status: mmt$file_server_io_status;


{   Check the condition in the server iocb entry.

    #KEYPOINT (osk$entry, osk$m * server_iocb_p^.sfid.file_entry_index, mmk$mtr_process_server_complete);
    #KEYPOINT (osk$debug, osk$m * $INTEGER (remote_request), dfk$remote_request);
    IF server_iocb_p^.condition = dfc$null_server_condition THEN
      IF NOT io_status.normal THEN
        IF io_status.condition = mme$volume_unavailable THEN
          server_iocb_p^.condition := dfc$volume_unavailable;
        ELSEIF io_status.condition = dfe$server_has_terminated THEN
          server_iocb_p^.condition := dfc$server_terminated;
        ELSE

{         Convert IO_STATUS.CONDITION into SERVER_IOCB_P^.CONDITION. See TYPE declared above.

          converter.intermediate := 0;
          converter.io_condition := io_status.condition;
          converter.intermediate := converter.intermediate - $INTEGER (ioc$st_errors) +
                $INTEGER (dfc$io_to_df_error_converter) - 1;
          server_iocb_p^.condition := converter.server_condition;
        IFEND;
      IFEND;
    IFEND;

    CASE remote_request OF
    = dfc$completing_previous_request =
      IF server_iocb_p^.server_state = mmc$ss_waiting THEN
        mtp$error_stop ('MM - NOT (completion_state => server_state): MMP$MPSR');
      IFEND;

{     Decrement the active i/o count.

      server_iocb_p^.active_io_count := server_iocb_p^.active_io_count - 1;

    ELSE { = dfc$read_for_client, dfc$write_for_client, dfc$allocate_space_for_client = }

      IF server_iocb_p^.server_state <> mmc$ss_waiting THEN
        mtp$error_stop ('MM - NOT (completion_state => server_state): MMP$MPSR');
      IFEND;

    CASEND; {remote_request}

{   Process the server request.

    IF (server_iocb_p^.active_io_count = 0) AND (server_iocb_p^.condition = dfc$null_server_condition) THEN
      process_server_request (remote_request, io_id, server_iocb_p);
    IFEND;

    IF (server_iocb_p^.active_io_count = 0) AND (server_iocb_p^.condition <> dfc$null_server_condition) THEN

{     The condition of the server_iocb is not equal to 0; check the state of the server iocb.

      CASE server_iocb_p^.server_state OF

      = mmc$ss_reading_from_disk =
        server_iocb_p^.server_state := mmc$ss_read_disk_error;

      = mmc$ss_reading_from_esm =
        server_iocb_p^.server_state := mmc$ss_read_esm_error;

      = mmc$ss_writing_to_disk =
        server_iocb_p^.server_state := mmc$ss_write_disk_error;

      = mmc$ss_writing_to_esm =
        server_iocb_p^.server_state := mmc$ss_write_esm_error;

      = mmc$ss_sending_write_response =
        server_iocb_p^.server_state := mmc$ss_sending_write_resp_error;

      = mmc$ss_allocating_space =
        server_iocb_p^.server_state := mmc$ss_allocate_space_error;

      = mmc$ss_allocate_space_error =
        server_iocb_p^.server_state := mmc$ss_waiting;
        send_allocate_response (server_iocb_p, io_id, cpio_status);
        IF cpio_status = mmc$df_io_active THEN
          #KEYPOINT (osk$exit, osk$m * $INTEGER (server_iocb_p^.server_state),
                mmk$mtr_process_server_complete);
          RETURN;
        ELSE
          server_iocb_p^.server_state := mmc$ss_send_allocate_resp_error;
        IFEND;

      = mmc$ss_send_allocate_response =
        server_iocb_p^.server_state := mmc$ss_send_allocate_resp_error;

      ELSE
        mtp$error_stop ('MM - internal error in MMP$MTR_PROCESS_SERVER_COMPLETE');

      CASEND;

{     Set the server job ready.
      #KEYPOINT (osk$debug, osk$m * $INTEGER (server_iocb_p^.server_state), dfk$server_state);
      #KEYPOINT (osk$debug, osk$m * $INTEGER (server_iocb_p^.condition), dfk$iocb_condition);

      dfp$set_monitor_entry_alert (io_id.queue_entry_location);

    IFEND;
    #KEYPOINT (osk$exit, osk$m * $INTEGER (server_iocb_p^.server_state), mmk$mtr_process_server_complete);

  PROCEND mmp$mtr_process_server_complete;
?? OLDTITLE, NEWTITLE := '    [XDCL] MMP$PROCESS_READ_AHEAD_COMPLETE', EJECT ??

  PROCEDURE [XDCL] mmp$process_read_ahead_complete
    (    io_id: mmt$io_identifier;
     VAR io_status: syt$monitor_status);

{ This procedure restarts a client's request for pages which will be obtained on the server.  In the recent
{ past the client has attempted to read more than four (4) pages and the server has responded by delivering
{ those pages AND starting up a sequential read with the assumption that the client will want more pages than
{ its initial request indicated.  If the client actually wants the read-ahead pages AND the server is not
{ done obtaining those pages the client will have generated another request which will have been queued in
{ the read_ahead_iocb_table, and the request remains quiet until the IO actually completes.  When the request
{ for pages is completed, this procedure is called and the server picks up this request and restarts it at the
{ point where the pages can be written to ESM.
{
{ If the server is done obtaining the pages BEFORE the next request arrives from the client the pages will
{ remain in memory until they are needed by the client or they are aged out, whichever comes first.
{
{ The following TYPE is used to convert an IO_status.condition of type OST$STATUS_CONDITION
{ (length = 5 bytes), into a server_iocb.condition of type DFT$SERVER_IOCB_ERROR_CONDITION
{ (length = 1 byte).

    TYPE
      condition_converter = record
        case 0 .. 2 of
        = 0 =
          intermediate: integer, { 8 bytes }
        = 1 =
          fill_1: 0 .. 0ffffff(16), { 3 bytes }
          io_condition: 0 .. 0ffffffffff(16), { 5 bytes }
        = 2 =
          fill_2: 0 .. 0ffffffffffffff(16), { 7 bytes }
          server_condition: dft$server_iocb_error_condition, { 1 byte }
        casend,
      recend;

    VAR
      converter: condition_converter,
      read_ahead_iocb_p: ^mmt$read_ahead_iocb_entry,
      server_iocb_p: ^mmt$server_iocb_entry;


    read_ahead_iocb_p := ^mmv$read_ahead_iocb_table_p^ [io_id.read_ahead_iocb_index];
    IF NOT read_ahead_iocb_p^.in_use THEN
      mtp$error_stop ('MM- Bad IO_ID --> read_ahead: MMP$PROCESS_READ_AHEAD_COMPLETE');
    IFEND;

{   Check the condition in the read_ahead iocb entry.

    IF read_ahead_iocb_p^.condition = dfc$null_server_condition THEN
      IF NOT io_status.normal THEN
        IF io_status.condition = mme$volume_unavailable THEN
          read_ahead_iocb_p^.condition := dfc$volume_unavailable;
        ELSE

{         Convert IO_STATUS.CONDITION into READ_AHEAD_IOCB_P^.CONDITION. See TYPE declared above.

          converter.intermediate := 0;
          converter.io_condition := io_status.condition;
          converter.intermediate := converter.intermediate - $INTEGER (ioc$st_errors) +
                $INTEGER (dfc$io_to_df_error_converter) - 1;
          read_ahead_iocb_p^.condition := converter.server_condition;
        IFEND;
      IFEND;
    IFEND;

    read_ahead_iocb_p^.active_io_count := read_ahead_iocb_p^.active_io_count - 1;
    IF read_ahead_iocb_p^.active_io_count = 0 THEN
      IF read_ahead_iocb_p^.io_id.specified THEN

{       There has been an actual client request for the pages that the server just finished reading in.
{       Set up an "advanced-state" server_iocb so these pages can be written into ESM (to the client).
{       Active_io_count will be decremented by the callee's callee.

        mmv$ra_rq_completed_needed := mmv$ra_rq_completed_needed + 1;
        dfp$fetch_server_iocb (read_ahead_iocb_p^.io_id.queue_entry_location, server_iocb_p);
        server_iocb_p^.server_state := mmc$ss_reading_from_disk;
        server_iocb_p^.active_io_count := 1;
        server_iocb_p^.condition := read_ahead_iocb_p^.condition;
        mmp$mtr_process_server_complete (dfc$completing_previous_request, read_ahead_iocb_p^.io_id,
              server_iocb_p, io_status);

      ELSE
        mmv$ra_rq_completed_not_needed := mmv$ra_rq_completed_not_needed + 1;
      IFEND; { specified }

{     Zero out and delete the read_ahead_iocb_entry.  We do this here because we either have processed it
{     because we needed it ("IF ....specified THEN") or we didn't need it after all because the client did
{     not make a request for the associated pages.

      read_ahead_iocb_p^ := mmv$null_read_ahead_iocb_entry;
      read_ahead_iocb_p^.in_use := FALSE;

    IFEND; { io_count = 0 }

  PROCEND mmp$process_read_ahead_complete;
?? OLDTITLE, NEWTITLE := '    [XDCL] MMP$RESTART_SERVER_REQUEST', EJECT ??

  PROCEDURE [XDCL] mmp$restart_server_request
    (    p_cpu_queue_entry: ^dft$cpu_queue_entry;
         remote_request: dft$remote_request);

    VAR
      io_status: syt$monitor_status;

    io_status.normal := TRUE;
    dfv$trace_count := dfv$trace_count + 1;
    dfv$monitor_io_start_time := #FREE_RUNNING_CLOCK (0);
    mmp$mtr_process_server_complete (remote_request, p_cpu_queue_entry^.io_id,
          p_cpu_queue_entry^.p_server_iocb, io_status);

  PROCEND mmp$restart_server_request;

?? OLDTITLE, NEWTITLE := '    SIMULATE_LOCKED_PAGE', EJECT ??
  PROCEDURE simulate_locked_page
    (    sfid: gft$system_file_identifier;
     VAR fake_locked_page: boolean);

{ This procedure detects the "Locked_Page' faults specified in the
{ Set_Mass_Storage_Fault command.

    VAR
      disk_fault: integer;

    fake_locked_page := FALSE;

    FOR disk_fault := LOWERBOUND (osv$simulated_disk_fault)
          TO UPPERBOUND (osv$simulated_disk_fault) DO
      IF osv$simulated_disk_fault [disk_fault].in_use THEN
        IF osv$simulated_disk_fault [disk_fault].sfid = sfid THEN
          IF osv$simulated_disk_fault [disk_fault].locked_page THEN
            IF osv$simulated_disk_fault [disk_fault].skip_count > 0 THEN
              osv$simulated_disk_fault [disk_fault].skip_count :=
                    osv$simulated_disk_fault [disk_fault].skip_count - 1;
            ELSE
              IF osv$simulated_disk_fault [disk_fault].count > 0 THEN
                osv$simulated_disk_fault [disk_fault].count :=
                      osv$simulated_disk_fault [disk_fault].count - 1;
                fake_locked_page := TRUE;
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    FOREND;
  PROCEND simulate_locked_page;
?? OLDTITLE, OLDTITLE, OLDTITLE ??
MODEND mmm$file_server_processor;



*DECK DECK=MMM$IO_REQUEST_PROCESSOR EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'MMM$IO_REQUEST_PROCESSOR - monitor i/o request handler.' ??
MODULE mmm$io_request_processor;

?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dmt$chapter_info
*copyc gft$locked_file_desc_entry_p
*copyc ioe$st_errors
*copyc jmt$initiated_job_list_entry
*copyc mme$condition_codes
*copyc mmk$job_mode_keypoints
*copyc mmk$monitor_mode_keypoints
*copyc mmt$active_segment_table
*copyc mmt$io_control_block
*copyc mmt$io_identifier
*copyc mmt$iocb_index
*copyc mmt$page_frame_index
*copyc mmt$rb_memory_manager_io
*copyc mmt$segment_descriptor_table
*copyc mmt$segment_descriptor_table_ex
*copyc ost$execution_control_block
*copyc ost$cpu_state_table
*copyc osv$page_size
*copyc tmv$ptl_lock
?? POP ??
?? NEWTITLE := '  External procedures' ??

{ External procedures used by this module.

*copyc gfp$mtr_get_fde_p
*copyc jmp$get_ijle_p
*copyc jmp$unlock_ajl
*copyc jsp$io_complete
*copyc mmp$convert_pva
*copyc mmp$mm_write_modified_pages
*copyc mmp$page_pull
*copyc mmp$page_pull_hash_sva
*copyc mmp$relink_page_frame
*copyc mmp$remove_pages_working_set
*copyc mmp$verify_pva
*copyc mtp$error_stop
*copyc mtp$set_status_abnormal
*copyc tmp$cause_task_switch
*copyc tmp$get_xcb_p
*copyc tmp$queue_task
*copyc tmp$reissue_monitor_request
*copyc tmp$set_task_ready_uncond
*copyc tmp$set_task_wait
*copyc jmv$ijl_p
*copyc mmv$pft_p
*copyc mmv$pt_p
*copyc mmt$page_pull_status
*copyc mmt$write_modified_pages_status
*copyc mmh$io_control_block

  VAR
    mmv$disable_write_for_perf_meas: [XDCL, #GATE] boolean := FALSE;

?? OLDTITLE, NEWTITLE := '  MMP$MTR_READ_WRITE_IO', EJECT ??

  PROCEDURE [XDCL] mmp$mtr_read_write_io
    (VAR rb: mmt$rb_memory_manager_io;
         cst_p: ^ost$cpu_state_table);

    VAR
      io_id: mmt$io_identifier;

    #KEYPOINT (osk$entry, $INTEGER (rb.sub_reqcode) * osk$m, mmk$mtr_read_write_io);

  /request_proc/
    BEGIN

      CASE rb.sub_reqcode OF
      = mmc$iorc_read_pages =
        IF rb.waitopt = osc$wait THEN
          io_id.specified := TRUE;
          io_id.io_function := ioc$read_page;
          io_id.iocb_index := 0;
          io_id.taskid := cst_p^.xcb_p^.global_task_id;
        ELSE
          io_id.io_function := ioc$read_page;
          mmp$find_iocb_entry (cst_p, io_id, rb.status);
          IF NOT rb.status.normal THEN
            EXIT /request_proc/;
          IFEND;
        IFEND;

        mmp$mtr_read (rb, cst_p, io_id);

      = mmc$iorc_write_pages =

        { MMV$DISABLE_WRITE_FOR_PERF_MEAS will only be set to TRUE for
        { performance measurements. It eliminates the WRITE overhead.

        IF mmv$disable_write_for_perf_meas THEN
          rb.status.normal := FALSE;
          rb.status.condition := mme$write_status_complete;
          RETURN;
        IFEND;

        IF rb.waitopt = osc$wait THEN
          io_id.specified := TRUE;
          io_id.io_function := ioc$write_page;
          io_id.iocb_index := 0;
          io_id.taskid := cst_p^.xcb_p^.global_task_id;
        ELSE
          io_id.io_function := ioc$write_page;
          mmp$find_iocb_entry (cst_p, io_id, rb.status);
          IF NOT rb.status.normal THEN
            EXIT /request_proc/;
          IFEND;
        IFEND;

        mmp$mtr_write (rb, cst_p, io_id);

      = mmc$iorc_await_io_completion =
        mmp$wait_for_any_completion (rb, cst_p);

      CASEND;

    END /request_proc/;

    #KEYPOINT (osk$exit, 0, mmk$mtr_read_write_io);

  PROCEND mmp$mtr_read_write_io;
?? OLDTITLE, NEWTITLE := '  MMP$FIND_IOCB_ENTRY', EJECT ??

{ The purpose of this procedure is to find an available entry in the
{ iocb or return a nil-table or full-table condition.

  PROCEDURE mmp$find_iocb_entry
    (    cst_p: ^ost$cpu_state_table;
     VAR io_id: mmt$io_identifier;
     VAR status: syt$monitor_status);

    VAR
      iocb_index: mmt$iocb_index,
      iocb_ptr: ^mmt$io_control_block;

    status.normal := TRUE;

    iocb_ptr := #ADDRESS (1, #SEGMENT (cst_p^.xcb_p), #OFFSET (cst_p^.xcb_p^.iocb_p));

    IF cst_p^.xcb_p^.iocb_p = NIL THEN
      mtp$set_status_abnormal ('MM', mme$nil_io_control_block, status);
      RETURN;
    IFEND;

{ Check if the table is full--return index of open entry in the io_id.

    FOR iocb_index := LOWERBOUND (iocb_ptr^.iocb_table) TO UPPERBOUND (iocb_ptr^.iocb_table) DO
      IF (NOT iocb_ptr^.iocb_table [iocb_index].used_for_asynchronous_io) AND
            (iocb_ptr^.iocb_table [iocb_index].active_io_count = 0) THEN
        io_id.specified := TRUE;
        io_id.iocb_index := iocb_index;
        io_id.taskid := cst_p^.xcb_p^.global_task_id;
        IF iocb_index > iocb_ptr^.maximum_iocb_index_in_use THEN
          iocb_ptr^.maximum_iocb_index_in_use := iocb_index;
        IFEND;
        RETURN;
      IFEND;
    FOREND;

{ If an index was not RETURNED above, then the table is full.

    mtp$set_status_abnormal ('MM', mme$full_io_control_block, status);

  PROCEND mmp$find_iocb_entry;
?? OLDTITLE, NEWTITLE := '  MMP$MTR_READ', EJECT ??

  PROCEDURE mmp$mtr_read
    (VAR rb: mmt$rb_memory_manager_io;
         cst_p: ^ost$cpu_state_table;
         io_id: mmt$io_identifier);


    VAR
      all_pages_in_memory: boolean,
      aste_p: ^mmt$active_segment_table_entry,
      chapter_info: dmt$chapter_info,
      fde_p: gft$locked_file_desc_entry_p,
      ijle_p: ^jmt$initiated_job_list_entry,
      iocb_ptr: ^mmt$io_control_block,
      locked_page_encountered: boolean,
      locked_page_pfti: mmt$page_frame_index,
      page_count: integer,
      page_in_count: mmt$page_frame_index,
      pfti: mmt$page_frame_index,
      pstatus: mmt$page_pull_status,
      ste_p: ^mmt$segment_descriptor,
      stxe_p: ^mmt$segment_descriptor_extended,
      sva: ost$system_virtual_address;

    rb.status.normal := TRUE;

    all_pages_in_memory := TRUE;
    locked_page_encountered := FALSE;

    ijle_p := cst_p^.ijle_p;
    iocb_ptr := #ADDRESS (1, #SEGMENT (cst_p^.xcb_p), #OFFSET (cst_p^.xcb_p^.iocb_p));

    mmp$verify_pva (^rb.pva, mmc$sat_read_or_write, rb.status);
    IF NOT rb.status.normal THEN
      RETURN;
    IFEND;
    mmp$convert_pva (rb.pva, cst_p, sva, fde_p, aste_p, ste_p, stxe_p);
    IF stxe_p^.access_state <> mmc$sas_allow_access THEN
      IF stxe_p^.access_state = mmc$sas_inhibit_access THEN
        mtp$set_status_abnormal ('MM', mme$volume_unavailable, rb.status);
        RETURN;
      ELSEIF stxe_p^.access_state = mmc$sas_terminate_access THEN
        mtp$set_status_abnormal ('DF', dfe$server_has_terminated, rb.status);
        RETURN;
      IFEND;
    IFEND;

    page_count := (#OFFSET (rb.pva) + rb.length - 1) DIV osv$page_size - (#OFFSET (rb.pva) DIV
          osv$page_size) + 1;

  /pages_in/
    WHILE TRUE DO
      mmp$page_pull_hash_sva (sva, aste_p, page_in_count, pstatus, pfti);
      IF page_in_count = 0 THEN {if not in the page table, call page_pull
        mmp$page_pull (sva, fde_p, cst_p, aste_p, stxe_p, io_id, page_count, ioc$read_page, TRUE,
              page_in_count, pstatus, pfti);
      IFEND;
      CASE pstatus OF
      = ps_found_in_avail, ps_found_in_avail_modified, ps_valid_in_pt, ps_new_page_assigned =
        ;

      = ps_found_on_disk, ps_found_on_server, ps_allocate_required_on_server =
        IF all_pages_in_memory THEN
          all_pages_in_memory := FALSE;
          IF io_id.iocb_index <> 0 THEN
            iocb_ptr^.iocb_table [io_id.iocb_index].iostatus_p := rb.stat_p;
            iocb_ptr^.iocb_table [io_id.iocb_index].used_for_asynchronous_io := TRUE;
            iocb_ptr^.iocb_table [io_id.iocb_index].pva := rb.pva;
            iocb_ptr^.iocb_table [io_id.iocb_index].length := rb.length;
            iocb_ptr^.iocb_table [io_id.iocb_index].sub_reqcode := rb.sub_reqcode;
          IFEND;
        IFEND;
        IF io_id.iocb_index = 0 THEN
          rb.active_io_count := rb.active_io_count + 1;
          ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count + 1;
        ELSE
          iocb_ptr^.iocb_table [io_id.iocb_index].active_io_count :=
                iocb_ptr^.iocb_table [io_id.iocb_index].active_io_count + 1;
          ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count + 1;
        IFEND;

      = ps_no_memory, ps_low_on_memory, ps_pt_full, ps_io_temp_reject, ps_job_work_required =
        cst_p^.dispatch_control.asynchronous_interrupts_pending := TRUE;
        tmp$reissue_monitor_request;
        IF rb.waitopt = osc$nowait THEN
          iocb_ptr^.iocb_table [io_id.iocb_index].used_for_asynchronous_io := FALSE;
          IF iocb_ptr^.iocb_table [io_id.iocb_index].active_io_count > 0 THEN
            tmp$set_task_wait (tmc$ts_io_wait_not_queued);
          ELSE
            tmp$cause_task_switch;
          IFEND;
        ELSE {wait was specified}
          IF rb.active_io_count > 0 THEN
            tmp$set_task_wait (tmc$ts_io_wait_not_queued);
          ELSE
            tmp$cause_task_switch;
          IFEND;
        IFEND;
        RETURN;

      = ps_locked =
        locked_page_encountered := TRUE;
        locked_page_pfti := pfti;

      = ps_read_beyond_eoi =
        mtp$set_status_abnormal ('MM', mme$read_beyond_eoi, rb.status);
        RETURN;

      = ps_beyond_file_limit =
        mtp$set_status_abnormal ('MM', mme$read_write_beyond_msl, rb.status);
        RETURN;

      = ps_no_extend_permission =
        mtp$set_status_abnormal ('MM', mme$write_beyond_eoi_no_append, rb.status);
        RETURN;

      = ps_done =
        mtp$error_stop ('mm - internal error');
        RETURN;

      = ps_volume_unavailable =
        mtp$set_status_abnormal ('MM', mme$volume_unavailable, rb.status);
        RETURN;

      = ps_server_terminated =
        mtp$set_status_abnormal ('DF', dfe$server_has_terminated, rb.status);
        RETURN;

      ELSE
      CASEND;
      page_count := page_count - page_in_count;
      IF page_count > 0 THEN
        sva.offset := sva.offset + (page_in_count * osv$page_size);
      ELSE
        EXIT /pages_in/;
      IFEND;
    WHILEND /pages_in/;

    IF locked_page_encountered THEN
      IF rb.waitopt = osc$wait THEN
        tmp$reissue_monitor_request;
        IF rb.active_io_count > 0 THEN
          tmp$set_task_wait (tmc$ts_io_wait_not_queued);
        ELSE
          tmp$queue_task (cst_p^.taskid, tmc$ts_io_wait_queued, mmv$pft_p^ [locked_page_pfti].task_queue);
          cst_p^.xcb_p^.page_wait_info.pva := NIL;
        IFEND;
      ELSE {nowait}
        iocb_ptr^.iocb_table [io_id.iocb_index].io_already_active := TRUE;
        IF iocb_ptr^.iocb_table [io_id.iocb_index].active_io_count = 0 THEN
{Make an iocb entry; check will find io_already_active and will repeat the request to get the condition.
          iocb_ptr^.iocb_table [io_id.iocb_index].condition := 0;
          iocb_ptr^.iocb_table [io_id.iocb_index].iostatus_p := rb.stat_p;
          iocb_ptr^.iocb_table [io_id.iocb_index].used_for_asynchronous_io := TRUE;
          iocb_ptr^.iocb_table [io_id.iocb_index].pva := rb.pva;
          iocb_ptr^.iocb_table [io_id.iocb_index].length := rb.length;
          iocb_ptr^.iocb_table [io_id.iocb_index].sub_reqcode := mmc$iorc_read_pages;
        IFEND;
      IFEND;
    ELSEIF all_pages_in_memory THEN
      mtp$set_status_abnormal ('MM', mme$page_found_in_memory, rb.status);
    ELSEIF rb.waitopt = osc$wait THEN
{There are pages on disk, so wait for the io request to complete.
      tmp$set_task_wait (tmc$ts_io_wait_not_queued);
    IFEND;
  PROCEND mmp$mtr_read;
?? OLDTITLE, NEWTITLE := '  MMP$MTR_WRITE', EJECT ??

  PROCEDURE mmp$mtr_write
    (VAR rb: mmt$rb_memory_manager_io;
         cst_p: ^ost$cpu_state_table;
         io_id: mmt$io_identifier);


    VAR
      active_io_count: mmt$active_io_count,
      aste_p: ^mmt$active_segment_table_entry,
      fde_p: gft$locked_file_desc_entry_p,
      ijle_p: ^jmt$initiated_job_list_entry,
      io_already_active: boolean,
      iocb_ptr: ^mmt$io_control_block,
      last_written_pfti: mmt$page_frame_index,
      page_count: integer,
      status: syt$monitor_status,
      ste_p: ^mmt$segment_descriptor,
      stxe_p: ^mmt$segment_descriptor_extended,
      sva: ost$system_virtual_address,
      write_status: mmt$write_modified_pages_status;

    rb.status.normal := TRUE;
    active_io_count := 0;
    io_already_active := FALSE;

    ijle_p := cst_p^.ijle_p;
    iocb_ptr := #ADDRESS (1, #SEGMENT (cst_p^.xcb_p), #OFFSET (cst_p^.xcb_p^.iocb_p));

    mmp$verify_pva (^rb.pva, mmc$sat_read_or_write, rb.status);
    IF NOT rb.status.normal THEN
      RETURN;
    IFEND;
    mmp$convert_pva (rb.pva, cst_p, sva, fde_p, aste_p, ste_p, stxe_p);

    IF (aste_p^.queue_id <> mmc$pq_job_working_set) AND ((aste_p^.queue_id < mmc$pq_shared_first) OR
          (aste_p^.queue_id > mmc$pq_shared_last)) THEN
      mtp$set_status_abnormal ('MM', mme$segment_not_pageable, rb.status);
      RETURN;
    IFEND;

    IF fde_p^.media = gfc$fm_transient_segment THEN
      mtp$set_status_abnormal ('MM', mme$segment_not_assigned_device, rb.status);
      RETURN;
    IFEND;

    mmp$mm_write_modified_pages (sva, rb.length, fde_p, aste_p, ioc$write_page, rb.init_new_io, FALSE, io_id,
          active_io_count, io_already_active, last_written_pfti, write_status);

    CASE write_status OF
    = mmc$wmp_io_complete =
      IF io_already_active THEN
        IF io_id.iocb_index = 0 THEN
          IF mmv$pft_p^ [last_written_pfti].active_io_count = 0 THEN
            mtp$error_stop ('MM - WMP tried to queue and no IO');
          IFEND;
          tmp$queue_task (cst_p^.taskid, tmc$ts_page_wait, mmv$pft_p^ [last_written_pfti].task_queue);
          rb.init_new_io := FALSE;
          tmp$reissue_monitor_request;
        ELSE {nowait--make IOCB entry that looks complete, but set io_already_active
          iocb_ptr^.iocb_table [io_id.iocb_index].pva := rb.pva;
          iocb_ptr^.iocb_table [io_id.iocb_index].length := rb.length;
          iocb_ptr^.iocb_table [io_id.iocb_index].iostatus_p := rb.stat_p;
          iocb_ptr^.iocb_table [io_id.iocb_index].sub_reqcode := mmc$iorc_write_pages;
          iocb_ptr^.iocb_table [io_id.iocb_index].used_for_asynchronous_io := TRUE;
          iocb_ptr^.iocb_table [io_id.iocb_index].active_io_count := 0;
          iocb_ptr^.iocb_table [io_id.iocb_index].io_already_active := TRUE;
        IFEND;
      ELSE
        mtp$set_status_abnormal ('MM', mme$write_status_complete, rb.status);
      IFEND;

    = mmc$wmp_io_active =
      IF io_id.iocb_index = 0 THEN
        IF io_already_active THEN
{ Reissue the request to check the condition of the io that was already active.
          rb.init_new_io := FALSE;
          tmp$reissue_monitor_request;
        IFEND;
        rb.active_io_count := active_io_count;
        ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count + active_io_count;
        tmp$set_task_wait (tmc$ts_io_wait_not_queued);
      ELSE
{ Make a full iocb entry because the write may have to be called again via R3--mmp$process_io_completions.
        iocb_ptr^.iocb_table [io_id.iocb_index].pva := rb.pva;
        iocb_ptr^.iocb_table [io_id.iocb_index].length := rb.length;
        iocb_ptr^.iocb_table [io_id.iocb_index].iostatus_p := rb.stat_p;
        iocb_ptr^.iocb_table [io_id.iocb_index].sub_reqcode := mmc$iorc_write_pages;
        iocb_ptr^.iocb_table [io_id.iocb_index].used_for_asynchronous_io := TRUE;
        iocb_ptr^.iocb_table [io_id.iocb_index].io_already_active := io_already_active;
        iocb_ptr^.iocb_table [io_id.iocb_index].active_io_count := active_io_count;
        ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count + active_io_count;
      IFEND;

    = mmc$wmp_io_initiation_reject =
      tmp$reissue_monitor_request;
      IF active_io_count > 0 THEN
        IF io_id.iocb_index = 0 THEN
          rb.active_io_count := active_io_count;
          ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count + active_io_count;
        ELSE
{ Only need .used_for_asynchronous_io and .active_io_count in the iocb, because those are the fields used
{ by mmp$mtr_process_io_completions to set the task ready.  The request has been reissued.
          iocb_ptr^.iocb_table [io_id.iocb_index].used_for_asynchronous_io := FALSE;
          iocb_ptr^.iocb_table [io_id.iocb_index].active_io_count := active_io_count;
          ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count + active_io_count;
        IFEND;
        tmp$set_task_wait (tmc$ts_io_wait_not_queued);
      ELSE
        tmp$cause_task_switch;
      IFEND;

    = mmc$wmp_io_errors =
      IF active_io_count = 0 THEN
        mtp$set_status_abnormal ('MM', ioc$disk_media_error, rb.status);
      ELSE
        IF io_id.iocb_index = 0 THEN
          rb.condition := ioc$disk_media_error;
          rb.active_io_count := active_io_count;
          ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count + active_io_count;
          tmp$set_task_wait (tmc$ts_io_wait_not_queued);
        ELSE
{ Need a full iocb entry; the write may be called again after file space reallocation.
          iocb_ptr^.iocb_table [io_id.iocb_index].pva := rb.pva;
          iocb_ptr^.iocb_table [io_id.iocb_index].length := rb.length;
          iocb_ptr^.iocb_table [io_id.iocb_index].iostatus_p := rb.stat_p;
          iocb_ptr^.iocb_table [io_id.iocb_index].io_already_active := io_already_active;
          iocb_ptr^.iocb_table [io_id.iocb_index].sub_reqcode := mmc$iorc_write_pages;
          iocb_ptr^.iocb_table [io_id.iocb_index].used_for_asynchronous_io := TRUE;
          iocb_ptr^.iocb_table [io_id.iocb_index].condition := ioc$disk_media_error;
          iocb_ptr^.iocb_table [io_id.iocb_index].active_io_count := active_io_count;
          ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count + active_io_count;
        IFEND;
      IFEND;
    = mmc$wmp_volume_unavailable =
      mtp$set_status_abnormal ('MM', mme$volume_unavailable, rb.status);
    = mmc$wmp_server_terminated =
      mtp$set_status_abnormal ('DF', dfe$server_has_terminated, rb.status);
    CASEND;

    IF rb.remove_pages THEN
      mmp$remove_pages_working_set (sva, rb.length, aste_p, page_count);
    IFEND;

  PROCEND mmp$mtr_write;
?? OLDTITLE, NEWTITLE := '  MMP$MTR_PROCESS_IO_COMPLETION', EJECT ??

  PROCEDURE [XDCL] mmp$mtr_process_io_completion
    (    io_id: mmt$io_identifier;
         io_function: iot$io_function;
         io_status: syt$monitor_status);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      iocb_ptr: ^mmt$io_control_block,
      need_to_ready_task: boolean,
      reset_completion_time: boolean,
      rb_p: ^mmt$rb_memory_manager_io,
      xcb_p: ^ost$execution_control_block;


    need_to_ready_task := FALSE;
    reset_completion_time := FALSE;

    tmp$get_xcb_p (io_id.taskid, xcb_p, ijle_p);
    IF xcb_p = NIL THEN
      mtp$error_stop ('MM - IO complete on swapped job');
    IFEND;

    IF io_id.iocb_index = 0 THEN
      rb_p := #LOC (xcb_p^.xp.x_registers [0]);
      IF rb_p^.condition = 0 THEN
        rb_p^.condition := io_status.condition;
      IFEND;
      rb_p^.active_io_count := rb_p^.active_io_count - 1;
      ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count - 1;
      IF rb_p^.active_io_count = 0 THEN
        need_to_ready_task := TRUE;
      IFEND;
    ELSE
      iocb_ptr := #ADDRESS (1, #SEGMENT (xcb_p), #OFFSET (xcb_p^.iocb_p));
      IF iocb_ptr^.iocb_table [io_id.iocb_index].condition = 0 THEN
        iocb_ptr^.iocb_table [io_id.iocb_index].condition := io_status.condition;
      IFEND;
      IF iocb_ptr^.iocb_table [io_id.iocb_index].active_io_count = 1 THEN
        { If the active io count is 1, then all io for this request is completed.  We check for a count
        { of 1 rather than 0 because we don't decrement the count until the end of this procedure.  We
        { don't decrement the count until we are done checking and changing the table here in order to
        { prevent a dual cpu timing problem in which a task running on the other cpu checks the table,
        { sees an active_io_count of 0 (which indicates all io for the request has finished), and then
        { changes the table before we are done processing here.  (This can happen if the proceesor
        { executing this code exchanges to NOS.)

        IF NOT iocb_ptr^.iocb_table [io_id.iocb_index].used_for_asynchronous_io THEN
          iocb_ptr^.iocb_table [io_id.iocb_index].iostatus_p := NIL;
          iocb_ptr^.iocb_table [io_id.iocb_index].condition := 0;
          iocb_ptr^.iocb_table [io_id.iocb_index].io_already_active := FALSE;
          need_to_ready_task := TRUE;
        ELSEIF iocb_ptr^.wait_for_any_completion THEN
          iocb_ptr^.wait_for_any_completion := FALSE;
          need_to_ready_task := TRUE;
        IFEND;
        reset_completion_time := TRUE;
      IFEND;
      iocb_ptr^.iocb_table [io_id.iocb_index].active_io_count :=
            iocb_ptr^.iocb_table [io_id.iocb_index].active_io_count - 1;
      ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count - 1;
      IF reset_completion_time THEN
        iocb_ptr^.latest_completion_time := #FREE_RUNNING_CLOCK (0);
      IFEND;
    IFEND;

    jmp$unlock_ajl (ijle_p);

    IF need_to_ready_task THEN
      tmp$set_task_ready_uncond (io_id.taskid, tmc$ts_io_wait_not_queued);
    IFEND;

    IF (ijle_p^.inhibit_swap_count = 0) AND (ijle_p^.notify_swapper_when_io_complete) THEN
      jsp$io_complete (ijle_p);
    IFEND;

  PROCEND mmp$mtr_process_io_completion;
?? OLDTITLE, NEWTITLE := '  MMP$WAIT_FOR_ANY_COMPLETION', EJECT ??

  PROCEDURE mmp$wait_for_any_completion
    (    rb: mmt$rb_memory_manager_io;
         cst_p: ^ost$cpu_state_table);

    VAR
      iocb_ptr: ^mmt$io_control_block;

    iocb_ptr := #ADDRESS (1, #SEGMENT (cst_p^.xcb_p), #OFFSET (cst_p^.xcb_p^.iocb_p));
    IF rb.latest_completion_time = iocb_ptr^.latest_completion_time THEN
      iocb_ptr^.wait_for_any_completion := TRUE;
      tmp$set_task_wait (tmc$ts_io_wait_not_queued);
    IFEND;

  PROCEND mmp$wait_for_any_completion;
?? OLDTITLE, OLDTITLE ??
MODEND mmm$io_request_processor;
*DECK DECK=MMM$LOG_CALLER EXPAND=TRUE
?? RIGHT := 110 ??
MODULE mmm$log_caller;

  TYPE
    sfsa_type = record
      fill1: 0 .. 0ffff(16),
      p: ^cell,
    a0, a1: integer, fill2: 0 .. 0ffff(16), a2: ^sfsa_type,
  recend;

  TYPE
    proc_id_type = record
      p0,p1,p2,p3:          0 .. 0ffffffff(16),
    recend,
    proc_info_type = record
      id: proc_id_type,
      count: array [boolean] of integer,
    recend;

  CONST
    pid_size = 300;


  VAR
    mmv$log_enable: [XDCL] integer,
    start_time: integer,
    last_time: integer,
    count: integer,
    pid: array [0 .. pid_size] of proc_info_type,
    max_pid: integer;

?? EJECT ??

  PROCEDURE[XDCL] mmp$log_caller_proc (b: boolean);

    VAR
      offset,
      i: integer,
      id: proc_id_type,
      sfsa_p: ^sfsa_type,
      zid: [STATIC] proc_id_type := [0,0,0,0];

    IF mmv$log_enable = 0 THEN
      RETURN;
    ELSEIF mmv$log_enable = 1 THEN
      count := 0;
      start_time := #free_running_clock (0);
      mmv$log_enable := 2;
      FOR i := 0 TO pid_size DO
        pid [i].id := zid;
        pid [i].count [FALSE] := 0;
        pid [i].count [TRUE] := 0;
      FOREND;
      max_pid := 0;
    IFEND;

    count := count + 1;
    last_time := #free_running_clock (0);
    sfsa_p := #previous_save_area ();
    id := zid;
    i := 0;
    WHILE (sfsa_p <> NIL) AND (i < 4) DO
      offset   := #offset (sfsa_p^.p);
      CASE i of
       =0= id.p0:=offset;
       =1= id.p1:=offset;
       =2= id.p2:=offset;
       =3= id.p3:=offset;
      casend;
      sfsa_p := sfsa_p^.a2;
      i := i + 1;
    WHILEND;

    i := 0;
    WHILE pid [i].id  <> id DO
      IF i = max_pid THEN
        IF i = pid_size THEN
          RETURN;
        IFEND;
        pid [i].id := id;
        max_pid := i + 1;
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;

    pid [i].count [b] := pid [i].count [b] + 1;

  PROCEND mmp$log_caller_proc;
MODEND
*DECK DECK=MMM$LOG_CALLER_MONITOR EXPAND=TRUE
?? RIGHT := 110 ??
MODULE mmm$log_caller_monitor;

{ This module should be compiled to OSF$MONITOR and, if necessary, OSF$BOOT_MONITOR.

*copyc mmv$benchmark_run

{ The following TYPE is a version of the minimum save area.  It defines only the fields which will be
{ useful in the procedure MMP$LOG_CALLER_MONITOR.

  TYPE
    sfsa_type = record
      fillp: 0 .. 0ffff(16),
      p: ^cell,
      a0: integer,
      a1: integer,
      fill2: 0 .. 0ffff(16),
      a2: ^sfsa_type,
  recend;

  TYPE
    proc_id_type = RECORD
      fill0: 0..0ffff(16),
      p0: ^cell,
      fill1: 0..0ffff(16),
      p1: ^cell,
      fill2: 0..0ffff(16),
      p2: ^cell,
      fill3: 0..0ffff(16),
      p3: ^cell,
    RECEND,

    proc_info_type = RECORD
      id: proc_id_type,
      count: integer,
    RECEND;

  CONST
    pid_size = 300;

  VAR
    count_monitor: integer,
    mmv$log_enable_monitor: [XDCL, #GATE] integer := 0,
    max_pid_monitor: [XDCL] integer,
    pid_monitor: [XDCL] array [0 .. pid_size] of proc_info_type,
    start_time_monitor: integer,
    last_time_monitor: integer,
    mmv$log_enable_r1: [XDCL, #GATE] integer := 0,
    max_pid_r1: [XDCL, #GATE] integer,
    pid_r1: [XDCL, #GATE] array [0 .. pid_size] of proc_info_type;

?? EJECT ??

  PROCEDURE [XDCL] mmp$log_caller_monitor;

    VAR
      offset,
      i: integer,
      id: proc_id_type,
      sfsa_p: ^sfsa_type,
      null_id: [STATIC] proc_id_type := [0, NIL, 0, NIL, 0, NIL, 0, NIL];


{ If we are not specifically collecting this data at this time, return without processing.

    IF mmv$benchmark_run = 0 THEN
      RETURN;
    ELSEIF mmv$log_enable_monitor <= 1 THEN

{ Initialize the data array.

      count_monitor := 0;
      start_time_monitor := #free_running_clock (0);
      mmv$log_enable_monitor := 2;
      FOR i := 0 TO pid_size DO
        pid_monitor [i].id := null_id;
        pid_monitor [i].count := 0;
      FOREND;
      max_pid_monitor := 0;
    IFEND;

    count_monitor := count_monitor + 1;
    last_time_monitor := #free_running_clock (0);
    sfsa_p := #previous_save_area ();
    id := null_id;
    i := 0;
    WHILE (sfsa_p <> NIL) AND (i < 4) DO
      CASE i OF
      =0=
        id.p0 := sfsa_p^.p;
      =1=
        id.p1 := sfsa_p^.p;
      =2=
        id.p2 := sfsa_p^.p;
      =3=
        id.p3 := sfsa_p^.p;
      CASEND;
      sfsa_p := sfsa_p^.a2;
      i := i + 1;
    WHILEND;

    i := 0;
    WHILE pid_monitor [i].id  <> id DO
      IF i = max_pid_monitor THEN
        IF i = pid_size THEN
          RETURN;
        IFEND;
        pid_monitor [i].id := id;
        max_pid_monitor := i + 1;
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;

    pid_monitor [i].count := pid_monitor [i].count + 1;

  PROCEND mmp$log_caller_monitor;
MODEND mmm$log_caller_monitor;
*DECK DECK=MMM$LOG_CALLER_R1 EXPAND=TRUE
?? RIGHT := 110 ??
MODULE mmm$log_caller_r1;

{ This module should be compiled to OSF$SYSTEM_CORE_113 and, if necessary, OSF$BOOT_JOB.

*copyc mmv$benchmark_run

{ The following TYPE is a version of the minimum save area.  It defines only the fields which will be
{ useful in the procedure MMP$LOG_CALLER_R1.

*copyc oss$mainframe_wired

  TYPE
    sfsa_type = RECORD
      fill1: 0 .. 0ffff(16),
      p: ^cell,
      a0: integer,
      a1: integer,
      fill2: 0 .. 0ffff(16),
      a2: ^sfsa_type,
    RECEND;

  TYPE
    proc_id_type = RECORD
      fill0: 0..0ffff(16),
      p0: ^cell,
      fill1: 0..0ffff(16),
      p1: ^cell,
      fill2: 0..0ffff(16),
      p2: ^cell,
      fill3: 0..0ffff(16),
      p3: ^cell,
    RECEND,

    proc_info_type = RECORD
      id: proc_id_type,
      count: integer,
    RECEND;

  CONST
    pid_size = 300;


  VAR
    count: integer,
    start_time: integer,
    last_time: integer,
    mmv$log_enable_r1: [XREF] integer,
    max_pid_r1: [XREF] integer,
    pid_r1: [XREF] array [0 .. pid_size] of proc_info_type;

?? EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$log_caller_r1;

    VAR
      offset,
      i: integer,
      id: proc_id_type,
      sfsa_p: ^sfsa_type,
      null_id: [STATIC] proc_id_type := [0, NIL, 0, NIL, 0, NIL, 0, NIL];


{ If we are not specifically collecting this data at this time, return without processing.

    IF mmv$benchmark_run = 0 THEN
      RETURN;
    ELSEIF mmv$log_enable_r1 <= 1 THEN

{ Initialize the data array.

      count := 0;
      start_time := #free_running_clock (0);
      mmv$log_enable_r1 := 2;
      FOR i := 0 TO pid_size DO
        pid_r1 [i].id := null_id;
        pid_r1 [i].count := 0;
      FOREND;
      max_pid_r1 := 0;
    IFEND;

    count := count + 1;
    last_time := #free_running_clock (0);
    sfsa_p := #previous_save_area ();
    id := null_id;
    i := 0;
    WHILE (sfsa_p <> NIL) AND (i < 4) DO
      CASE i OF
       = 0 =
         id.p0:=sfsa_p^.p;
       = 1 =
         id.p1:=sfsa_p^.p;
       = 2 =
         id.p2:=sfsa_p^.p;
       = 3 =
         id.p3:=sfsa_p^.p;
      CASEND;
      sfsa_p := sfsa_p^.a2;
      i := i + 1;
    WHILEND;

    i := 0;
    WHILE pid_r1 [i].id  <> id DO
      IF i = max_pid_r1 THEN
        IF i = pid_size THEN
          RETURN;
        IFEND;
        pid_r1 [i].id := id;
        max_pid_r1 := i + 1;
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;

    pid_r1 [i].count := pid_r1 [i].count + 1;

  PROCEND mmp$log_caller_r1;
MODEND mmm$log_caller_r1;
*DECK DECK=MMM$LOG_CALLER_R3 EXPAND=TRUE
MODULE mmm$log_caller_r3;

{ This module should be compiled to OSF$SYSTEM_CORE_13D.

*copyc mmp$log_caller_r1
*copyc mmp$log_caller_r1_enabled
*copyc mmv$benchmark_run

  PROCEDURE [XDCL, #GATE] mmp$log_caller_r3;


    IF mmv$benchmark_run = 0 THEN
      RETURN;
    IFEND;

    IF mmp$log_caller_r1_enabled() THEN
      mmp$log_caller_r1;
    IFEND;

  PROCEND mmp$log_caller_r3;

MODEND mmm$log_caller_r3
*DECK DECK=MMM$MANAGE_MEMORY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE MANAGE_MEMORY - a command utility' ??
MODULE mmm$manage_memory;

{ PURPOSE:
{   This module contains the processors of the Manage Memory Utility.  The main program mmp$manage_memory
{   is called by SCL to process the system command MANAGE_MEMORY.  The only result of the MANAGE_MEMORY
{   command is to establish the Manage_Memory Command Utility which activates the following commands:
{
{                  CHANGE_MEMORY_ATTRIBUTE
{                  CHANGE_SHARED_QUEUE_ATTRIBUTE
{                  DISPLAY_MEMORY_ATTRIBUTE
{                  DISPLAY_SHARED_QUEUE_ATTRIBUTE
{                  QUIT
{                  SET_TO_DEFAULT
{
{ DESIGN:
{   The base premise of this design is that the Manage_Memory Utility will execute infrequently.  All of the
{   code in this module is in procedures.  There is one procedure for each of the commands plus one procedure
{   for the initiation of the utility which is the Manage_Memory command.  Ring 3 and Ring 1 helper routines
{   are used to read and write the variables that are displayed and/or changed by the Manage_Memory utility.
{
{ NOTES:
{   SECURITY - The ring3 helper routines that store data do enforce security by rejecting with appropriate
{     status any request that is not from the system job.  Any user is allowed to display the data.
{   TESTBED - It is easy to check the MMU commands from a terminal.  Construct a testbed module to duplicate
{     the XDCL declarations needed by the MMU (the MMV$ variables plus MMV$GPQL) as they are found in
{     mmm$page_fault_processor and mmm$monitor_request_processor.  Also add a dummy system job function.  Then
{     compile mmm$manage_memory, mmm$manage_memory_helper_r3, and mmm$ring1_helper plus the testbed module.
{     Execute via execute_task with mmp$manage_memory as the entry point.
{   ADDITIONAL ENTRIES:  Adding a new queue will required minor code changes.  A new memory attribute
{     variable can be added by:
{       1. Add a new "mmc$mmu_ma_xxx" ordinal to mmt$mmu_memory_attributes in deck mmt$manage_memory_utility.
{       2. In mmm$ring1_helper add a pointer entry to the array mmt$mmu_ma_data which is one of the
{          fields in the record mmv$mmu_manage_memory_utility.
{       3. In mmm$manage_memory add an entry to the array v$mmu_info_ma.
{       4. Change the PDT of the commands chama and disma to add the new parameter name.
{       5. If appropriate, add a constant definition to deck mmc$manage_memory_utility.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$path_display_chunks
*copyc mmc$manage_memory_utility
*copyc mmt$manage_memory_utility
*copyc mmt$page_frame_queue_id
*copyc mmt$page_queue_list
*copyc oss$job_paged_literal
*copyc ost$date
*copyc ost$time
*copyc pmt$os_name
?? POP ??
*copyc clp$begin_utility
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc clp$right_justify_string
*copyc mmp$fetch_manage_memory_data_r3
*copyc mmp$fetch_site_active_q_cnt_r3
*copyc mmp$store_manage_memory_data_r3
*copyc ofp$display_status_message
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
?? EJECT ??
*copyc clv$nil_display_control
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by this Module', EJECT ??

  CONST
    c$max_line_size = 79,
    c$utility_name = 'MANAGE_MEMORY                  ';

  TYPE
    t$memory_attribute_info = RECORD
      index: mmt$mmu_memory_attributes,
      name: string (osc$max_name_size),
      units_name: string (13),
    RECEND,

    t$memory_attributes = SET OF mmt$mmu_memory_attributes,
    t$shared_queues = SET OF mmc$pq_shared_first .. mmc$pq_shared_last;

?? EJECT ??

  VAR
    v$dissqa_data: [STATIC, READ, oss$job_paged_literal]
          ARRAY [mmc$pq_shared_first .. mmc$pq_shared_first_site] OF string (20) :=
          ['TASK_SERVICE        ', 'EXECUTABLE_FILE     ', 'NON_EXECUTABLE_FILE ', 'DEVICE_FILE         ',
           'FILE_SERVER         ', 'OTHER               ', 'SITE_XX             '],

    { When the command DISPLAY_MEMORY_ATTRIBUTE is executed, the memory attributes will be displayed in the
    { order that they are listed in the array below.  The order currently used groups the attributes according
    { to their units.

    v$mmu_info_ma: [STATIC, READ, oss$job_paged_literal]
          ARRAY [mmt$mmu_memory_attributes] OF t$memory_attribute_info := [
          [mmc$mmu_ma_aic,   'AGE_INTERVAL_CEILING',            'age_intervals'],
          [mmc$mmu_ma_aif,   'AGE_INTERVAL_FLOOR',              'age_intervals'],
          [mmc$mmu_ma_aal,   'AGGRESSIVE_AGING_LEVEL',          '  pages'],
          [mmc$mmu_ma_aal2,  'AGGRESSIVE_AGING_LEVEL_2',        '  pages'],
          [mmc$mmu_ma_aa,    'AGING_ALGORITHM',                 '        '],
          [mmc$mmu_ma_amqm,  'AVAILABLE_MODIFIED_QUEUE_MAX',    '  pages'],
          [mmc$mmu_ma_jwsai, 'JOB_WORKING_SET_AGE_INTERVAL',    'microseconds'],
          [mmc$mmu_ma_minap, 'MINIMUM_AVAILABLE_PAGES',         '  pages'],
          [mmc$mmu_ma_psp,   'PAGE_STREAMING_PRESTREAM',        'page faults '],
          [mmc$mmu_ma_psrl,  'PAGE_STREAMING_RANDOM_LIMIT',     'page faults '],
          [mmc$mmu_ma_psr,   'PAGE_STREAMING_READS',            'transfer unit'],
          [mmc$mmu_ma_pst,   'PAGE_STREAMING_THRESHOLD   ',     '  bytes     '],
          [mmc$mmu_ma_psts,  'PAGE_STREAMING_TRANSFER_SIZE',    '  bytes     '],
          [mmc$mmu_ma_pci,   'PERIODIC_CALL_INTERVAL',          'microseconds'],
          [mmc$mmu_ma_swsai, 'SHARED_WORKING_SET_AGE_INTERVAL', 'microseconds'],
          [mmc$mmu_ma_sa,    'SWAPPING_AIC',                    'swapout(s)'],
          [mmc$mmu_ma_tt,    'TICK_TIME',                       'microseconds']],

    v$shared_system_queues: [STATIC, READ, oss$job_paged_literal] t$shared_queues :=
          [mmc$pq_shared_task_service, mmc$pq_shared_pf_execute, mmc$pq_shared_pf_non_execute,
          mmc$pq_shared_device_file, mmc$pq_shared_file_server, mmc$pq_shared_other];
?? OLDTITLE ??
?? NEWTITLE := 'change_memory_attribute', EJECT ??

{ PURPOSE:
{   This procedure processes the CHANGE_MEMORY_ATTRIBUTE Command.  The command provides the capability to
{   change various memory attributes.  These are various variables defined in mainframe wired modules of
{   EXEC's memory management.

  PROCEDURE change_memory_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE change_memory_attribute, change_memory_attributes, chama (
{   age_interval_ceiling, aic: any of
{       key
{         (default, d)
{       keyend
{       integer 1..255
{     anyend = $optional
{   age_interval_floor, aif: any of
{       key
{         (default, d)
{       keyend
{       integer 1..255
{     anyend = $optional
{   aggressive_aging_level, aal: any of
{       key
{         (default, d)
{       keyend
{       integer 0..osc$max_page_frames
{     anyend = $optional
{   aggressive_aging_level_2, aal2: any of
{       key
{         (default, d)
{       keyend
{       integer 0..osc$max_page_frames
{     anyend = $optional
{   aging_algorithm, aa: any of
{       key
{         (default, d)
{       keyend
{       integer 0..100
{     anyend = $optional
{   available_modified_queue_max, amqm: any of
{       key
{         (default, d)
{       keyend
{       integer 0..65535
{     anyend = $optional
{   job_working_set_age_interval, jwsai: any of
{       key
{         (default, d)
{       keyend
{       integer 1000000..999999999
{     anyend = $optional
{   minimum_available_pages, minap: any of
{       key
{         (default, d)
{       keyend
{       integer 0..osc$max_page_frames
{     anyend = $optional
{   page_streaming_random_limit, psrl: any of
{       key
{         (default, d)
{       keyend
{       integer 1..255
{     anyend = $optional
{   page_streaming_reads, psr: any of
{       key
{         (default, d)
{       keyend
{       integer 1..5
{     anyend = $optional
{   page_streaming_prestream, psp: any of
{       key
{         (default, d)
{       keyend
{       integer 1..255
{     anyend = $optional
{   page_streaming_threshold, pst: any of
{       key
{         (default, d)
{       keyend
{       integer 0..99999999
{     anyend = $optional
{   page_streaming_transfer_size, psts: any of
{       key
{         (default, d)
{       keyend
{       integer 0..4194304
{     anyend = $optional
{   periodic_call_interval, pci: any of
{       key
{         (default, d)
{       keyend
{       integer 100000..10000000
{     anyend = $optional
{   shared_working_set_age_interval, swsai: any of
{       key
{         (default, d)
{       keyend
{       integer 100000..999999999
{     anyend = $optional
{   swapping_aic, sa: any of
{       key
{         (default, d)
{       keyend
{       integer 0..10000
{     anyend = $optional
{   tick_time, tt: any of
{       key
{         (default, d)
{       keyend
{       integer 10000..999999999
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 35] of clt$pdt_parameter_name,
      parameters: array [1 .. 18] 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type2: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type3: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type4: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type5: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type6: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type7: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type8: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type9: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type10: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type11: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type12: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type13: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type14: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type15: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type16: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type17: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type18: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [95, 11, 2, 14, 23, 37, 718],
    clc$command, 35, 18, 0, 0, 0, 0, 18, ''], [
    ['AA                             ',clc$abbreviation_entry, 5],
    ['AAL                            ',clc$abbreviation_entry, 3],
    ['AAL2                           ',clc$abbreviation_entry, 4],
    ['AGE_INTERVAL_CEILING           ',clc$nominal_entry, 1],
    ['AGE_INTERVAL_FLOOR             ',clc$nominal_entry, 2],
    ['AGGRESSIVE_AGING_LEVEL         ',clc$nominal_entry, 3],
    ['AGGRESSIVE_AGING_LEVEL_2       ',clc$nominal_entry, 4],
    ['AGING_ALGORITHM                ',clc$nominal_entry, 5],
    ['AIC                            ',clc$abbreviation_entry, 1],
    ['AIF                            ',clc$abbreviation_entry, 2],
    ['AMQM                           ',clc$abbreviation_entry, 6],
    ['AVAILABLE_MODIFIED_QUEUE_MAX   ',clc$nominal_entry, 6],
    ['JOB_WORKING_SET_AGE_INTERVAL   ',clc$nominal_entry, 7],
    ['JWSAI                          ',clc$abbreviation_entry, 7],
    ['MINAP                          ',clc$abbreviation_entry, 8],
    ['MINIMUM_AVAILABLE_PAGES        ',clc$nominal_entry, 8],
    ['PAGE_STREAMING_PRESTREAM       ',clc$nominal_entry, 11],
    ['PAGE_STREAMING_RANDOM_LIMIT    ',clc$nominal_entry, 9],
    ['PAGE_STREAMING_READS           ',clc$nominal_entry, 10],
    ['PAGE_STREAMING_THRESHOLD       ',clc$nominal_entry, 12],
    ['PAGE_STREAMING_TRANSFER_SIZE   ',clc$nominal_entry, 13],
    ['PCI                            ',clc$abbreviation_entry, 14],
    ['PERIODIC_CALL_INTERVAL         ',clc$nominal_entry, 14],
    ['PSP                            ',clc$abbreviation_entry, 11],
    ['PSR                            ',clc$abbreviation_entry, 10],
    ['PSRL                           ',clc$abbreviation_entry, 9],
    ['PST                            ',clc$abbreviation_entry, 12],
    ['PSTS                           ',clc$abbreviation_entry, 13],
    ['SA                             ',clc$abbreviation_entry, 16],
    ['SHARED_WORKING_SET_AGE_INTERVAL',clc$nominal_entry, 15],
    ['STATUS                         ',clc$nominal_entry, 18],
    ['SWAPPING_AIC                   ',clc$nominal_entry, 16],
    ['SWSAI                          ',clc$abbreviation_entry, 15],
    ['TICK_TIME                      ',clc$nominal_entry, 17],
    ['TT                             ',clc$abbreviation_entry, 17]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 13
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 14
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 15
    [30, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 16
    [32, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [34, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 18
    [31, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, 255, 10]]
    ],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, 255, 10]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, osc$max_page_frames, 10]]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, osc$max_page_frames, 10]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, 100, 10]]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, 65535, 10]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1000000, 999999999, 10]]
    ],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, osc$max_page_frames, 10]]
    ],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, 255, 10]]
    ],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, 5, 10]]
    ],
{ PARAMETER 11
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, 255, 10]]
    ],
{ PARAMETER 12
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, 99999999, 10]]
    ],
{ PARAMETER 13
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, 4194304, 10]]
    ],
{ PARAMETER 14
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [100000, 10000000, 10]]
    ],
{ PARAMETER 15
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [100000, 999999999, 10]]
    ],
{ PARAMETER 16
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, 10000, 10]]
    ],
{ PARAMETER 17
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [10000, 999999999, 10]]
    ],
{ PARAMETER 18
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$age_interval_ceiling = 1,
      p$age_interval_floor = 2,
      p$aggressive_aging_level = 3,
      p$aggressive_aging_level_2 = 4,
      p$aging_algorithm = 5,
      p$available_modified_queue_max = 6,
      p$job_working_set_age_interval = 7,
      p$minimum_available_pages = 8,
      p$page_streaming_random_limit = 9,
      p$page_streaming_reads = 10,
      p$page_streaming_prestream = 11,
      p$page_streaming_threshold = 12,
      p$page_streaming_transfer_size = 13,
      p$periodic_call_interval = 14,
      p$shared_working_set_age_interv = 15 {SHARED_WORKING_SET_AGE_INTERVAL} ,
      p$swapping_aic = 16,
      p$tick_time = 17,
      p$status = 18;

    VAR
      pvt: array [1 .. 18] of clt$parameter_value;

    VAR
      gpql_default: mmt$mmu_gpql_default,
      ma_default: mmt$mmu_ma_default,
      ma_index: mmt$mmu_memory_attributes,
      ma_values: mmt$mmu_ma_values,
      queues: mmt$global_page_queue_list;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$fetch_manage_memory_data_r3 (queues, ma_values, gpql_default, ma_default);

    IF pvt [p$age_interval_ceiling].specified THEN
      IF pvt [p$age_interval_ceiling].value^.kind = clc$integer THEN
        ma_values [mmc$mmu_ma_aic] := pvt [p$age_interval_ceiling].value^.integer_value.value;
      ELSE
        ma_values [mmc$mmu_ma_aic] := ma_default [mmc$mmu_ma_aic];
      IFEND;
    IFEND;

    IF pvt [p$age_interval_floor].specified THEN
      IF pvt [p$age_interval_floor].value^.kind = clc$integer THEN
        ma_values [mmc$mmu_ma_aif] := pvt [p$age_interval_floor].value^.integer_value.value;
      ELSE
        ma_values [mmc$mmu_ma_aif] := ma_default [mmc$mmu_ma_aif];
      IFEND;
    IFEND;

    IF pvt [p$aggressive_aging_level].specified THEN
      IF pvt [p$aggressive_aging_level].value^.kind = clc$integer THEN
        ma_values [mmc$mmu_ma_aal] := pvt [p$aggressive_aging_level].value^.integer_value.value;
      ELSE
        ma_values [mmc$mmu_ma_aal] := ma_default [mmc$mmu_ma_aal];
      IFEND;
    IFEND;

    IF pvt [p$aggressive_aging_level_2].specified THEN
      IF pvt [p$aggressive_aging_level_2].value^.kind = clc$integer THEN
        ma_values [mmc$mmu_ma_aal2] := pvt [p$aggressive_aging_level_2].value^.integer_value.value;
      ELSE
        ma_values [mmc$mmu_ma_aal2] := ma_default [mmc$mmu_ma_aal2];
      IFEND;
    IFEND;

    IF pvt [p$aging_algorithm].specified THEN
      IF pvt [p$aging_algorithm].value^.kind = clc$integer THEN
        ma_values [mmc$mmu_ma_aa] := pvt [p$aging_algorithm].value^.integer_value.value;
      ELSE
        ma_values [mmc$mmu_ma_aa] := ma_default [mmc$mmu_ma_aa];
      IFEND;
    IFEND;

    IF pvt [p$available_modified_queue_max].specified THEN
      IF pvt [p$available_modified_queue_max].value^.kind = clc$integer THEN
        ma_values [mmc$mmu_ma_amqm] := pvt [p$available_modified_queue_max].value^.integer_value.value;
      ELSE
        ma_values [mmc$mmu_ma_amqm] := ma_default [mmc$mmu_ma_amqm];
      IFEND;
    IFEND;

    IF pvt [p$job_working_set_age_interval].specified THEN
      IF pvt [p$job_working_set_age_interval].value^.kind = clc$integer THEN
        ma_values [mmc$mmu_ma_jwsai] := pvt [p$job_working_set_age_interval].value^.integer_value.value;
      ELSE
        ma_values [mmc$mmu_ma_jwsai] := ma_default [mmc$mmu_ma_jwsai];
      IFEND;
    IFEND;

    IF pvt [p$minimum_available_pages].specified THEN
      IF pvt [p$minimum_available_pages].value^.kind = clc$integer THEN
        ma_values [mmc$mmu_ma_minap] := pvt [p$minimum_available_pages].value^.integer_value.value;
      ELSE
        ma_values [mmc$mmu_ma_minap] := ma_default [mmc$mmu_ma_minap];
      IFEND;
    IFEND;

    IF pvt [p$page_streaming_random_limit].specified THEN
      IF pvt [p$page_streaming_random_limit].value^.kind = clc$integer THEN
        ma_values [mmc$mmu_ma_psrl] := pvt [p$page_streaming_random_limit].value^.integer_value.value;
      ELSE
        ma_values [mmc$mmu_ma_psrl] := ma_default [mmc$mmu_ma_psrl];
      IFEND;
    IFEND;

    IF pvt [p$page_streaming_reads].specified THEN
      IF pvt [p$page_streaming_reads].value^.kind = clc$integer THEN
        ma_values [mmc$mmu_ma_psr] := pvt [p$page_streaming_reads].value^.integer_value.value;
      ELSE
        ma_values [mmc$mmu_ma_psr] := ma_default [mmc$mmu_ma_psr];
      IFEND;
    IFEND;

    IF pvt [p$page_streaming_prestream].specified THEN
      IF pvt [p$page_streaming_prestream].value^.kind = clc$integer THEN
        ma_values [mmc$mmu_ma_psp] := pvt [p$page_streaming_prestream].value^.integer_value.value;
      ELSE
        ma_values [mmc$mmu_ma_psp] := ma_default [mmc$mmu_ma_psp];
      IFEND;
    IFEND;

    IF pvt [p$page_streaming_threshold].specified THEN
      IF pvt [p$page_streaming_threshold].value^.kind = clc$integer THEN
        ma_values [mmc$mmu_ma_pst] := pvt [p$page_streaming_threshold].value^.integer_value.value;
      ELSE
        ma_values [mmc$mmu_ma_pst] := ma_default [mmc$mmu_ma_pst];
      IFEND;
    IFEND;

    IF pvt [p$page_streaming_transfer_size].specified THEN
      IF pvt [p$page_streaming_transfer_size].value^.kind = clc$integer THEN
        ma_values [mmc$mmu_ma_psts] := pvt [p$page_streaming_transfer_size].value^.integer_value.value;
      ELSE
        ma_values [mmc$mmu_ma_psts] := ma_default [mmc$mmu_ma_psts];
      IFEND;
    IFEND;

    IF pvt [p$periodic_call_interval].specified THEN
      IF pvt [p$periodic_call_interval].value^.kind = clc$integer THEN
        ma_values [mmc$mmu_ma_pci] := pvt [p$periodic_call_interval].value^.integer_value.value;
      ELSE
        ma_values [mmc$mmu_ma_pci] := ma_default [mmc$mmu_ma_pci];
      IFEND;
    IFEND;

    IF pvt [p$shared_working_set_age_interv].specified THEN
      IF pvt [p$shared_working_set_age_interv].value^.kind = clc$integer THEN
        ma_values [mmc$mmu_ma_swsai] := pvt [p$shared_working_set_age_interv].value^.integer_value.value;
      ELSE
        ma_values [mmc$mmu_ma_swsai] := ma_default [mmc$mmu_ma_swsai];
      IFEND;
    IFEND;

    IF pvt [p$swapping_aic].specified THEN
      IF pvt [p$swapping_aic].value^.kind = clc$integer THEN
        ma_values [mmc$mmu_ma_sa] := pvt [p$swapping_aic].value^.integer_value.value;
      ELSE
        ma_values [mmc$mmu_ma_sa] := ma_default [mmc$mmu_ma_sa];
      IFEND;
    IFEND;

    IF pvt [p$tick_time].specified THEN
      IF pvt [p$tick_time].value^.kind = clc$integer THEN
        ma_values [mmc$mmu_ma_tt] := pvt [p$tick_time].value^.integer_value.value;
      ELSE
        ma_values [mmc$mmu_ma_tt] := ma_default [mmc$mmu_ma_tt];
      IFEND;
    IFEND;

    mmp$store_manage_memory_data_r3 (queues, ma_values, status);

  PROCEND change_memory_attribute;
?? OLDTITLE ??
?? NEWTITLE := 'change_shared_queue_attribute', EJECT ??

{ PURPOSE:
{   This procedure processes the CHANGE_SHARED_QUEUE_ATTRIBUTE Command.  The command provides the capability
{   to change the attributes of the shared queues which affect the rate of aging and the number of pages in
{   each of the shared queues.  The attributes are in the global page queue list headers which are found in
{   mainframe wired modules of EXEC's memory management.

  PROCEDURE change_shared_queue_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE change_shared_queue_attribute, change_shared_queue_attributes, chasqa (
{   queue, q, shared_queue, sq: list of key
{       all
{       (device_file, df)
{       (executable_file, ef)
{       (file_server, fs)
{       (non_executable_file, nef)
{       (other, o)
{       (site_defined, sd)
{       (system, s)
{       (task_service, ts)
{       site_01, site_02, site_03, site_04, site_05, site_06, site_07, site_08, site_09, site_10, site_11
{       site_12, site_13, site_14, site_15, site_16, site_17, site_18, site_19, site_20, site_21, site_22
{       site_23, site_24, site_25
{     keyend = $required
{   age_interval_ceiling, aic: any of
{       key
{         (default, d)
{       keyend
{       integer 1..255
{     anyend = $optional
{   minimum_size, mins: any of
{       key
{         (default, d)
{       keyend
{       integer 0..osc$max_page_frames
{     anyend = $optional
{   maximum_size, maxs: any of
{       key
{         (default, d)
{       keyend
{       integer 0..osc$max_page_frames
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: 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 .. 42] of clt$keyword_specification,
        recend,
      recend,
      type2: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type3: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type4: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [95, 11, 2, 15, 43, 37, 982],
    clc$command, 11, 5, 1, 0, 0, 0, 5, ''], [
    ['AGE_INTERVAL_CEILING           ',clc$nominal_entry, 2],
    ['AIC                            ',clc$abbreviation_entry, 2],
    ['MAXIMUM_SIZE                   ',clc$nominal_entry, 4],
    ['MAXS                           ',clc$abbreviation_entry, 4],
    ['MINIMUM_SIZE                   ',clc$nominal_entry, 3],
    ['MINS                           ',clc$abbreviation_entry, 3],
    ['Q                              ',clc$alias_entry, 1],
    ['QUEUE                          ',clc$nominal_entry, 1],
    ['SHARED_QUEUE                   ',clc$alias_entry, 1],
    ['SQ                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1577,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [1561, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [42], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['DEVICE_FILE                    ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['DF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['EF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['EXECUTABLE_FILE                ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['FILE_SERVER                    ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['FS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['NEF                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['NON_EXECUTABLE_FILE            ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['O                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['OTHER                          ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
      ['SD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['SITE_01                        ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['SITE_02                        ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['SITE_03                        ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['SITE_04                        ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['SITE_05                        ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['SITE_06                        ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['SITE_07                        ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['SITE_08                        ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['SITE_09                        ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['SITE_10                        ', clc$nominal_entry, clc$normal_usage_entry, 19],
      ['SITE_11                        ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['SITE_12                        ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['SITE_13                        ', clc$nominal_entry, clc$normal_usage_entry, 22],
      ['SITE_14                        ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['SITE_15                        ', clc$nominal_entry, clc$normal_usage_entry, 24],
      ['SITE_16                        ', clc$nominal_entry, clc$normal_usage_entry, 25],
      ['SITE_17                        ', clc$nominal_entry, clc$normal_usage_entry, 26],
      ['SITE_18                        ', clc$nominal_entry, clc$normal_usage_entry, 27],
      ['SITE_19                        ', clc$nominal_entry, clc$normal_usage_entry, 28],
      ['SITE_20                        ', clc$nominal_entry, clc$normal_usage_entry, 29],
      ['SITE_21                        ', clc$nominal_entry, clc$normal_usage_entry, 30],
      ['SITE_22                        ', clc$nominal_entry, clc$normal_usage_entry, 31],
      ['SITE_23                        ', clc$nominal_entry, clc$normal_usage_entry, 32],
      ['SITE_24                        ', clc$nominal_entry, clc$normal_usage_entry, 33],
      ['SITE_25                        ', clc$nominal_entry, clc$normal_usage_entry, 34],
      ['SITE_DEFINED                   ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['TASK_SERVICE                   ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['TS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 9]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, 255, 10]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, osc$max_page_frames, 10]]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, osc$max_page_frames, 10]]
    ],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$queue = 1,
      p$age_interval_ceiling = 2,
      p$minimum_size = 3,
      p$maximum_size = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      gpql_default: mmt$global_page_queue_list,
      list_p: ^clt$data_value,
      ma_default: mmt$mmu_ma_default,
      ma_values: mmt$mmu_ma_values,
      option_p: ^clt$data_value,
      queue_id: mmt$page_frame_queue_id,
      queues: mmt$global_page_queue_list,
      queues_selected: t$shared_queues,
      shared_site_queues: t$shared_queues;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$fetch_manage_memory_data_r3 (queues, ma_values, gpql_default, ma_default);

    queues_selected := $t$shared_queues [];
    shared_site_queues := -v$shared_system_queues;

    list_p := pvt [p$queue].value;

   /determine_requested_queues/
    WHILE list_p <> NIL DO
      option_p := list_p^.element_value;
      list_p := list_p^.link;

      IF option_p^.keyword_value = 'ALL' THEN
        queues_selected := -$t$shared_queues [];
        EXIT /determine_requested_queues/;
      ELSEIF option_p^.keyword_value = 'DEVICE_FILE' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_device_file];
      ELSEIF option_p^.keyword_value = 'EXECUTABLE_FILE' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_pf_execute];
      ELSEIF option_p^.keyword_value = 'FILE_SERVER' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_file_server];
      ELSEIF option_p^.keyword_value = 'NON_EXECUTABLE_FILE' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_pf_non_execute];
      ELSEIF option_p^.keyword_value = 'OTHER' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_other];
      ELSEIF option_p^.keyword_value = 'SITE_DEFINED' THEN
        queues_selected := queues_selected + shared_site_queues;
      ELSEIF option_p^.keyword_value = 'SYSTEM' THEN
        queues_selected := queues_selected + v$shared_system_queues;
      ELSEIF option_p^.keyword_value = 'TASK_SERVICE' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_task_service];
      ELSEIF option_p^.keyword_value = 'SITE_01' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_01];
      ELSEIF option_p^.keyword_value = 'SITE_02' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_02];
      ELSEIF option_p^.keyword_value = 'SITE_03' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_03];
      ELSEIF option_p^.keyword_value = 'SITE_04' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_04];
      ELSEIF option_p^.keyword_value = 'SITE_05' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_05];
      ELSEIF option_p^.keyword_value = 'SITE_06' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_06];
      ELSEIF option_p^.keyword_value = 'SITE_07' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_07];
      ELSEIF option_p^.keyword_value = 'SITE_08' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_08];
      ELSEIF option_p^.keyword_value = 'SITE_09' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_09];
      ELSEIF option_p^.keyword_value = 'SITE_10' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_10];
      ELSEIF option_p^.keyword_value = 'SITE_11' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_11];
      ELSEIF option_p^.keyword_value = 'SITE_12' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_12];
      ELSEIF option_p^.keyword_value = 'SITE_13' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_13];
      ELSEIF option_p^.keyword_value = 'SITE_14' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_14];
      ELSEIF option_p^.keyword_value = 'SITE_15' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_15];
      ELSEIF option_p^.keyword_value = 'SITE_16' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_16];
      ELSEIF option_p^.keyword_value = 'SITE_17' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_17];
      ELSEIF option_p^.keyword_value = 'SITE_18' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_18];
      ELSEIF option_p^.keyword_value = 'SITE_19' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_19];
      ELSEIF option_p^.keyword_value = 'SITE_20' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_20];
      ELSEIF option_p^.keyword_value = 'SITE_21' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_21];
      ELSEIF option_p^.keyword_value = 'SITE_22' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_22];
      ELSEIF option_p^.keyword_value = 'SITE_23' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_23];
      ELSEIF option_p^.keyword_value = 'SITE_24' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_24];
      ELSEIF option_p^.keyword_value = 'SITE_25' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_25];
      IFEND;
    WHILEND /determine_requested_queues/;

    FOR queue_id := mmc$pq_shared_first TO mmc$pq_shared_last DO
      IF queue_id IN queues_selected THEN
        IF pvt [p$age_interval_ceiling].specified THEN
          IF pvt [p$age_interval_ceiling].value^.kind = clc$integer THEN
            queues [queue_id].age_interval := pvt [p$age_interval_ceiling].value^.integer_value.value;
          ELSE
            queues [queue_id].age_interval := gpql_default [queue_id].age_interval;
          IFEND;
        IFEND;
        IF pvt [p$maximum_size].specified THEN
          IF pvt [p$maximum_size].value^.kind = clc$integer THEN
            queues [queue_id].maximum := pvt [p$maximum_size].value^.integer_value.value;
          ELSE
            queues [queue_id].maximum := gpql_default [queue_id].maximum;
          IFEND;
        IFEND;
        IF pvt [p$minimum_size].specified THEN
          IF pvt [p$minimum_size].value^.kind = clc$integer THEN
            queues [queue_id].minimum := pvt [p$minimum_size].value^.integer_value.value;
          ELSE
            queues [queue_id].minimum := gpql_default [queue_id].minimum;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

    mmp$store_manage_memory_data_r3 (queues, ma_values, status);

  PROCEND change_shared_queue_attribute;
?? OLDTITLE ??
?? NEWTITLE := 'display_memory_attribute', EJECT ??

{ PURPOSE:
{   This procedure processes the DISPLAY_MEMORY_ATTRIBUTE Command.  The command provides the capability to
{   display various memory attributes.  These are various variables defined in mainframe wired modules of
{   EXEC's memory management.  A Ring 3 helper routine is called to fetch all of the data that can be
{   displayed.  The command is then cracked and a display is built to display the requested data.

  PROCEDURE display_memory_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_memory_attribute, display_memory_attributes, disma (
{   display_option, display_options, do: list of key
{       all
{       (age_interval_ceiling, aic)
{       (age_interval_floor, aif)
{       (aggressive_aging_level, aal)
{       (aggressive_aging_level_2, aal2)
{       (aging_algorithm, aa)
{       (available_modified_queue_max, amqm)
{       (job_working_set_age_interval, jwsai)
{       (minimum_available_pages, minap)
{       (page_streaming_prestream, psp)
{       (page_streaming_random_limit, psrl)
{       (page_streaming_reads, psr)
{       (page_streaming_threshold, pst)
{       (page_streaming_transfer_size, psts)
{       (periodic_call_interval, pci)
{       (shared_working_set_age_interval, swsai)
{       (swapping_aic, sa)
{       (tick_time, tt)
{     keyend = all
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: 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 .. 35] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [95, 10, 31, 16, 24, 58, 873],
    clc$command, 6, 3, 0, 0, 0, 0, 3, ''], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 1],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 1],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1318,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [1302, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [35], [
      ['AA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['AAL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['AAL2                           ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['AGE_INTERVAL_CEILING           ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['AGE_INTERVAL_FLOOR             ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['AGGRESSIVE_AGING_LEVEL         ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['AGGRESSIVE_AGING_LEVEL_2       ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['AGING_ALGORITHM                ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['AIC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['AIF                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['AMQM                           ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['AVAILABLE_MODIFIED_QUEUE_MAX   ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['JOB_WORKING_SET_AGE_INTERVAL   ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['JWSAI                          ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
      ['MINAP                          ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
      ['MINIMUM_AVAILABLE_PAGES        ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['PAGE_STREAMING_PRESTREAM       ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['PAGE_STREAMING_RANDOM_LIMIT    ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['PAGE_STREAMING_READS           ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['PAGE_STREAMING_THRESHOLD       ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['PAGE_STREAMING_TRANSFER_SIZE   ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['PCI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
      ['PERIODIC_CALL_INTERVAL         ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['PSP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
      ['PSR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
      ['PSRL                           ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
      ['PST                            ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
      ['PSTS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
      ['SA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
      ['SHARED_WORKING_SET_AGE_INTERVAL', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['SWAPPING_AIC                   ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['SWSAI                          ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
      ['TICK_TIME                      ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['TT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 18]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$display_option = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;
?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle', EJECT ??

{  PURPOSE:
{    The procedure clp$new_page_procedure which is copied via *copyc from a common deck expects to call a
{    local procedure to put out subtitles. Since we do not need subtitles this proc is a dummy.

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

    PROCEND put_subtitle;

?? PUSH (LISTEXT := ON) ??
*copy clp$new_page_procedure
*copy clv$display_variables
?? POP ??
?? OLDTITLE, EJECT ??

    TYPE
      t$line = RECORD
        CASE 0 .. 2 OF
        = 0 =
          data: string (c$max_line_size),
        = 1 =
          space_a_1: string (7),
          name_part: string (4),
          space_a_2: string (28),
          value_part: string (5),
          space_a_3: string (6),
          units_part: string (5),
        = 2 =
          space_b_1: string (1),
          mmu_name_part: string (31),
          space_b_2: string (2),
          mmu_value_part: string (10),
          space_b_3: string (3),
          mmu_units_part: string (13),
        CASEND,
      RECEND;

    VAR
      display_control: clt$display_control,
      gpql_default: mmt$mmu_gpql_default,
      ignore_status: ost$status,
      line: t$line,
      list_p: ^clt$data_value,
      ma_default: mmt$mmu_ma_default,
      ma_index: mmt$mmu_memory_attributes,
      ma_values: mmt$mmu_ma_values,
      option_p: ^clt$data_value,
      queues: mmt$global_page_queue_list,
      ring_attributes: amt$ring_attributes,
      selected_attributes: t$memory_attributes;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$fetch_manage_memory_data_r3 (queues, ma_values, gpql_default, ma_default);

    display_control := clv$nil_display_control;
    clv$titles_built := FALSE;
    clv$command_name := 'display_memory_attribute';
    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    osp$establish_block_exit_hndlr (^abort_handler);

    IF (display_control.page_format = amc$burstable_form) OR
          (display_control.page_format = amc$non_burstable_form) THEN
      clp$new_display_page (display_control, ignore_status);
      clp$new_display_line (display_control, 2, ignore_status);
    IFEND;

    selected_attributes := $t$memory_attributes [];
    list_p := pvt [p$display_option].value;

   /flag_selected_attributes/
    WHILE list_p <> NIL DO
      option_p := list_p^.element_value;
      list_p := list_p^.link;

      IF option_p^.keyword_value = 'ALL' THEN
        selected_attributes := -$t$memory_attributes [];
        EXIT /flag_selected_attributes/
      IFEND;
      FOR ma_index := LOWERBOUND (v$mmu_info_ma) TO UPPERBOUND (v$mmu_info_ma) DO
        IF option_p^.keyword_value = v$mmu_info_ma [ma_index].name THEN
          selected_attributes := selected_attributes + $t$memory_attributes [v$mmu_info_ma [ma_index].index];
          CYCLE /flag_selected_attributes/;
        IFEND;
      FOREND;
    WHILEND /flag_selected_attributes/;

    { Print a Header line.

    line.data := ' ';
    line.name_part := 'NAME';
    line.value_part := 'VALUE';
    line.units_part := 'UNITS';
    clp$put_display (display_control, line.data, clc$no_trim, ignore_status);

    { Examine each entry in v$mmu_info_ma which contains the name, units, and index which are used to
    { build a line of display.  If the indexed entry is included in the selected_attributes set, then
    { the line of display is issued.

    FOR ma_index := LOWERBOUND (v$mmu_info_ma) TO UPPERBOUND (v$mmu_info_ma) DO
      IF v$mmu_info_ma [ma_index].index IN selected_attributes THEN
        line.data := ' ';
        line.mmu_name_part := v$mmu_info_ma [ma_index].name;
        clp$convert_integer_to_rjstring (ma_values [v$mmu_info_ma [ma_index].index], 10, FALSE, ' ',
              line.mmu_value_part, ignore_status);
        line.mmu_units_part := v$mmu_info_ma [ma_index].units_name;
        clp$put_display (display_control, line.data, clc$no_trim, ignore_status);
      IFEND;
    FOREND;

    clp$close_display (display_control, ignore_status);
    osp$disestablish_cond_handler;

  PROCEND display_memory_attribute;
?? OLDTITLE ??
?? NEWTITLE := 'display_shared_queue_attribute', EJECT ??

{ PURPOSE:
{   This procedure processes the DISPLAY_SHARED_QUEUE_ATTRIBUTE Command.  The command provides the capability
{   to display the attributes of the shared queues which affect the rate of aging and the number of pages in
{   each of the shared queues.  The attributes are in the global page queue list headers which are found in
{   the mainframe wired modules of EXEC's memory management.  A Ring 3 helper routine is called to fetch all
{   of the data that can be displayed.  The command is then cracked and a display is built to display the
{   requested data.

  PROCEDURE display_shared_queue_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_shared_queue_attribute, display_shared_queue_attributes, dissqa (
{   queue, q, shared_queue, sq: any of
{       key
{         all
{       keyend
{       list of key
{         (active_site_defined, asd)
{         (system, s)
{       keyend
{     anyend = (active_site_defined, system)
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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 .. 4] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (29),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 3, 15, 12, 27, 4, 135],
    clc$command, 7, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['Q                              ',clc$alias_entry, 1],
    ['QUEUE                          ',clc$nominal_entry, 1],
    ['SHARED_QUEUE                   ',clc$alias_entry, 1],
    ['SQ                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 235,
  clc$optional_default_parameter, 0, 29],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    171, [[1, 0, clc$list_type], [155, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [4], [
        ['ACTIVE_SITE_DEFINED            ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['ASD                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
        ]
      ]
    ,
    '(active_site_defined, system)'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$queue = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;
?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle', EJECT ??

{  PURPOSE:
{    The procedure clp$new_page_procedure which is copied via *copyc from a common deck expects to call a
{    local procedure to put out subtitles. Since we do not need subtitles this proc is a dummy.

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

    PROCEND put_subtitle;

?? PUSH (LISTEXT := ON) ??
*copy clp$new_page_procedure
*copy clv$display_variables
?? POP ??
?? OLDTITLE, EJECT ??

    TYPE
      t$line = RECORD
        CASE 0 .. 3 OF
        = 0 =
          data: string (c$max_line_size),
        = 1 =
          space_a_1: string (28),
          age_interval_name: string (12),
          space_a_2: string (3),
          nominal_range_name: string (20),
        = 2 =
          space_b_1: string (5),
          queue_name: string (5),
          space_b_2: string (21),
          ceiling_name: string (7),
          space_b_3: string (6),
          min_max_name: string (16),
        = 3 =
          space_c_1: string (1),
          queue_part: t$queue_part,
          space_c_2: string (9),
          aic_part: string (6),
          space_c_3: string (4),
          min_part: string (9),
          max_part: string (9),
        CASEND,
      RECEND,

      t$queue_part = RECORD
        CASE 0 .. 1 OF
        = 0 =
          data: string (20),
        = 1 =
          site_name: string (5),
          site_number: string (2),
        CASEND,
      RECEND;

    VAR
      display_control: clt$display_control,
      first_queue_id: mmt$page_frame_queue_id,
      gpql_default: mmt$mmu_gpql_default,
      ignore_status: ost$status,
      last_queue_id: mmt$page_frame_queue_id,
      line: t$line,
      ma_default: mmt$mmu_ma_default,
      ma_values: mmt$mmu_ma_values,
      queue_id: mmt$page_frame_queue_id,
      queue_list: ^clt$data_value,
      queues: mmt$global_page_queue_list,
      ring_attributes: amt$ring_attributes,
      site_active_queue_count: 0 .. mmc$pq_shared_num_sites;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$fetch_manage_memory_data_r3 (queues, ma_values, gpql_default, ma_default);
    mmp$fetch_site_active_q_cnt_r3 (site_active_queue_count);

    display_control := clv$nil_display_control;
    clv$titles_built := FALSE;
    clv$command_name := 'display_shared_queue_attribute';
    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    osp$establish_block_exit_hndlr (^abort_handler);

    IF (display_control.page_format = amc$burstable_form) OR
          (display_control.page_format = amc$non_burstable_form) THEN
      clp$new_display_page (display_control, ignore_status);
      clp$new_display_line (display_control, 2, ignore_status);
    IFEND;

    IF pvt [p$queue].value^.kind = clc$keyword THEN { ALL is the only keyword allowed. }
      first_queue_id := mmc$pq_shared_first;
      last_queue_id :=  mmc$pq_shared_last_site;
    ELSE
      first_queue_id := mmc$pq_shared_first_site;
      last_queue_id :=  mmc$pq_shared_last_sys;
      queue_list := pvt [p$queue].value;
      WHILE queue_list <> NIL DO
        IF queue_list^.element_value^.keyword_value = 'SYSTEM' THEN
          first_queue_id := mmc$pq_shared_first;
        ELSEIF queue_list^.element_value^.keyword_value = 'ACTIVE_SITE_DEFINED' THEN
          last_queue_id :=  mmc$pq_shared_first_site + site_active_queue_count - 1;
        IFEND;
        queue_list := queue_list^.link;
      WHILEND;
    IFEND;

    IF (first_queue_id = mmc$pq_shared_first_site) AND (site_active_queue_count = 0) THEN
      line.data := ' No site defined shared queues are active.';
      clp$put_display (display_control, line.data, clc$no_trim, ignore_status);
    ELSE
      line.data := ' ';
      line.age_interval_name := 'AGE INTERVAL';
      line.nominal_range_name := 'NOMINAL RANGE(pages)';
      clp$put_display (display_control, line.data, clc$no_trim, ignore_status);
      line.data := ' ';
      line.queue_name := 'QUEUE';
      line.ceiling_name := 'CEILING';
      line.min_max_name := 'MINIMUM..MAXIMUM';
      clp$put_display (display_control, line.data, clc$no_trim, ignore_status);

      FOR queue_id := first_queue_id TO last_queue_id DO
        line.data := ' ';
        IF queue_id < mmc$pq_shared_first_site THEN
          line.queue_part.data := v$dissqa_data [queue_id];
        ELSE
          line.queue_part.data := v$dissqa_data [mmc$pq_shared_first_site];
          clp$convert_integer_to_rjstring ((queue_id - mmc$pq_shared_last_sys), 10, FALSE, '0',
                line.queue_part.site_number, ignore_status);
        IFEND;
        clp$convert_integer_to_rjstring (queues [queue_id].age_interval, 10, FALSE, ' ', line.aic_part,
              ignore_status);
        clp$convert_integer_to_rjstring (queues [queue_id].minimum, 10, FALSE, ' ', line.min_part,
              ignore_status);
        clp$convert_integer_to_rjstring (queues [queue_id].maximum, 10, FALSE, ' ', line.max_part,
              ignore_status);
        clp$put_display (display_control, line.data, clc$no_trim, ignore_status);
      FOREND;
    IFEND;

    clp$close_display (display_control, ignore_status);
    osp$disestablish_cond_handler;

  PROCEND display_shared_queue_attribute;
?? OLDTITLE ??
?? NEWTITLE := 'quit', EJECT ??

{ PURPOSE:
{   This procedure processes the QUIT Command which is the command to terminate the Manage Memory Utility.
{   It terminates the utility by ending the include file.  This will cause control to return to the
{   initiation procedure which is mmp$manage_memory where the utility is ended.

  PROCEDURE quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE quit, qui (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [92, 1, 14, 9, 47, 55, 114],
    clc$command, 1, 1, 0, 0, 0, 0, 1, ''], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_include (c$utility_name, status);

  PROCEND quit;

?? OLDTITLE ??
?? NEWTITLE := 'set_to_default', EJECT ??

{ PURPOSE:
{   This procedure processes the SET_TO_DEFAULT Command.  The command provides the capability to set the data
{   that can be changed by the Manage Memory Utility to their default values.  A Ring 3 helper routine is
{   called to fetch all of the data that can be changed.  The command is then cracked and the data is set to
{   defaults as directed by the command.  Then another helper routine is called to store all of the data back
{   into their normal locations.

  PROCEDURE set_to_default
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE set_to_default, settd (
{   set: list of key
{       all
{       (device_file, df)
{       (executable_file, ef)
{       (file_server, fs)
{       (memory_attribute, ma)
{       (non_executable_file, nef)
{       (other, o)
{       (shared_queue_attribute, sqa)
{       (site_defined, sd)
{       (system, s)
{       (task_service, ts)
{       site_01, site_02, site_03, site_04, site_05, site_06, site_07, site_08, site_09, site_10, site_11
{       site_12, site_13, site_14, site_15, site_16, site_17, site_18, site_19, site_20, site_21, site_22
{       site_23, site_24, site_25
{     keyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: 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 .. 46] of clt$keyword_specification,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [95, 11, 2, 15, 44, 47, 835],
    clc$command, 2, 2, 1, 0, 0, 0, 2, ''], [
    ['SET                            ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1725,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [1709, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [46], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['DEVICE_FILE                    ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['DF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['EF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['EXECUTABLE_FILE                ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['FILE_SERVER                    ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['FS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['MA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['MEMORY_ATTRIBUTE               ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['NEF                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['NON_EXECUTABLE_FILE            ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['O                              ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['OTHER                          ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
      ['SD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
      ['SHARED_QUEUE_ATTRIBUTE         ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['SITE_01                        ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['SITE_02                        ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['SITE_03                        ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['SITE_04                        ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['SITE_05                        ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['SITE_06                        ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['SITE_07                        ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['SITE_08                        ', clc$nominal_entry, clc$normal_usage_entry, 19],
      ['SITE_09                        ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['SITE_10                        ', clc$nominal_entry, clc$normal_usage_entry, 21],
      ['SITE_11                        ', clc$nominal_entry, clc$normal_usage_entry, 22],
      ['SITE_12                        ', clc$nominal_entry, clc$normal_usage_entry, 23],
      ['SITE_13                        ', clc$nominal_entry, clc$normal_usage_entry, 24],
      ['SITE_14                        ', clc$nominal_entry, clc$normal_usage_entry, 25],
      ['SITE_15                        ', clc$nominal_entry, clc$normal_usage_entry, 26],
      ['SITE_16                        ', clc$nominal_entry, clc$normal_usage_entry, 27],
      ['SITE_17                        ', clc$nominal_entry, clc$normal_usage_entry, 28],
      ['SITE_18                        ', clc$nominal_entry, clc$normal_usage_entry, 29],
      ['SITE_19                        ', clc$nominal_entry, clc$normal_usage_entry, 30],
      ['SITE_20                        ', clc$nominal_entry, clc$normal_usage_entry, 31],
      ['SITE_21                        ', clc$nominal_entry, clc$normal_usage_entry, 32],
      ['SITE_22                        ', clc$nominal_entry, clc$normal_usage_entry, 33],
      ['SITE_23                        ', clc$nominal_entry, clc$normal_usage_entry, 34],
      ['SITE_24                        ', clc$nominal_entry, clc$normal_usage_entry, 35],
      ['SITE_25                        ', clc$nominal_entry, clc$normal_usage_entry, 36],
      ['SITE_DEFINED                   ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['SQA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
      ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['TASK_SERVICE                   ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['TS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 11]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$set = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      gpql_default: mmt$mmu_gpql_default,
      list_p: ^clt$data_value,
      ma_default: mmt$mmu_ma_default,
      ma_index: mmt$mmu_memory_attributes,
      ma_values: mmt$mmu_ma_values,
      option_p: ^clt$data_value,
      queue_id: mmt$page_frame_queue_id,
      queues: mmt$global_page_queue_list,
      queues_selected: t$shared_queues,
      shared_site_queues: t$shared_queues;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$fetch_manage_memory_data_r3 (queues, ma_values, gpql_default, ma_default);

    queues_selected := $t$shared_queues [];
    shared_site_queues := -v$shared_system_queues;

    list_p := pvt [p$set].value;
    WHILE list_p <> NIL DO
      option_p := list_p^.element_value;
      list_p := list_p^.link;

      IF (option_p^.keyword_value = 'ALL') OR (option_p^.keyword_value = 'MEMORY_ATTRIBUTE') THEN
        FOR ma_index := LOWERBOUND (v$mmu_info_ma) TO UPPERBOUND (v$mmu_info_ma) DO
          ma_values [v$mmu_info_ma [ma_index].index] := ma_default [v$mmu_info_ma [ma_index].index];
        FOREND;
      IFEND;

      IF option_p^.keyword_value = 'ALL' THEN
        queues_selected := -$t$shared_queues [];
      ELSEIF option_p^.keyword_value = 'DEVICE_FILE' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_device_file];
      ELSEIF option_p^.keyword_value = 'EXECUTABLE_FILE' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_pf_execute];
      ELSEIF option_p^.keyword_value = 'FILE_SERVER' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_file_server];
      ELSEIF option_p^.keyword_value = 'NON_EXECUTABLE_FILE' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_pf_non_execute];
      ELSEIF option_p^.keyword_value = 'OTHER' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_other];
      ELSEIF option_p^.keyword_value = 'SHARED_QUEUE_ATTRIBUTE' THEN
        queues_selected := -$t$shared_queues [];
      ELSEIF option_p^.keyword_value = 'SYSTEM' THEN
        queues_selected := queues_selected + v$shared_system_queues;
      ELSEIF option_p^.keyword_value = 'SITE_DEFINED' THEN
        queues_selected := queues_selected + shared_site_queues;
      ELSEIF option_p^.keyword_value = 'TASK_SERVICE' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_task_service];
      ELSEIF option_p^.keyword_value = 'SITE_01' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_01];
      ELSEIF option_p^.keyword_value = 'SITE_02' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_02];
      ELSEIF option_p^.keyword_value = 'SITE_03' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_03];
      ELSEIF option_p^.keyword_value = 'SITE_04' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_04];
      ELSEIF option_p^.keyword_value = 'SITE_05' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_05];
      ELSEIF option_p^.keyword_value = 'SITE_06' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_06];
      ELSEIF option_p^.keyword_value = 'SITE_07' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_07];
      ELSEIF option_p^.keyword_value = 'SITE_08' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_08];
      ELSEIF option_p^.keyword_value = 'SITE_09' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_09];
      ELSEIF option_p^.keyword_value = 'SITE_10' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_10];
      ELSEIF option_p^.keyword_value = 'SITE_11' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_11];
      ELSEIF option_p^.keyword_value = 'SITE_12' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_12];
      ELSEIF option_p^.keyword_value = 'SITE_13' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_13];
      ELSEIF option_p^.keyword_value = 'SITE_14' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_14];
      ELSEIF option_p^.keyword_value = 'SITE_15' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_15];
      ELSEIF option_p^.keyword_value = 'SITE_16' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_16];
      ELSEIF option_p^.keyword_value = 'SITE_17' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_17];
      ELSEIF option_p^.keyword_value = 'SITE_18' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_18];
      ELSEIF option_p^.keyword_value = 'SITE_19' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_19];
      ELSEIF option_p^.keyword_value = 'SITE_20' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_20];
      ELSEIF option_p^.keyword_value = 'SITE_21' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_21];
      ELSEIF option_p^.keyword_value = 'SITE_22' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_22];
      ELSEIF option_p^.keyword_value = 'SITE_23' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_23];
      ELSEIF option_p^.keyword_value = 'SITE_24' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_24];
      ELSEIF option_p^.keyword_value = 'SITE_25' THEN
        queues_selected := queues_selected + $t$shared_queues [mmc$pq_shared_site_25];
      IFEND;
    WHILEND;

    FOR queue_id := mmc$pq_shared_first TO mmc$pq_shared_last DO
      IF queue_id IN queues_selected THEN
        queues [queue_id].age_interval := gpql_default [queue_id].age_interval;
        queues [queue_id].maximum := gpql_default [queue_id].maximum;
        queues [queue_id].minimum := gpql_default [queue_id].minimum;
      IFEND;
    FOREND;

    mmp$store_manage_memory_data_r3 (queues, ma_values, status);

  PROCEND set_to_default;
?? OLDTITLE ??
?? NEWTITLE := 'mmp$manage_memory', EJECT ??

{ PURPOSE:
{   This is the initial procedure which is called via system command MANAGE_MEMORY.  It initiates the Manage
{   Memory Command Utility and thus activates the commands of the utility.  When the QUIT command is
{   executed, the utility is terminated.
{
{ DESIGN:
{   Initiates the utility.  Defines the utility commands via a command table.  All of the commands
{   defined are processed by different procedures which are all within this same module (MMM$MANAGE_MEMORY).
{
{ NOTES:
{   Any user may activate the utility.  When the commands are then executed, the ring3 helper routines
{   will enforce appropriate security.

  PROCEDURE [XDCL] mmp$manage_memory
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE manage_memory, manm (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [92, 1, 14, 9, 31, 0, 173],
    clc$command, 1, 1, 0, 0, 0, 0, 1, ''], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];
?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

{ table n=v$command_table t=command sn=oss$job_paged_literal s=local
{ command n=(change_memory_attribute, change_memory_attributes, chama) ..
{   p=change_memory_attribute cm=local
{ command n=(change_shared_queue_attribute, change_shared_queue_attributes,..
{    chasqa)         p=change_shared_queue_attribute cm=local
{ command n=(display_memory_attribute, display_memory_attributes, disma) ..
{   p=display_memory_attribute cm=local
{ command n=(display_shared_queue_attribute, ..
{   display_shared_queue_attributes, display_shared_q_attribute,     ..
{       dissqa) p=display_shared_queue_attribute cm=local
{ command n=(quit, qui) p=quit cm=local
{ command n=(set_to_default, settd) p=set_to_default cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  v$command_table: [STATIC, READ, oss$job_paged_literal]
      ^clt$command_table := ^v$command_table_entries,

  v$command_table_entries: [STATIC, READ, oss$job_paged_literal] array
      [1 .. 17] of clt$command_table_entry := [
  {} ['CHAMA                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^change_memory_attribute],
  {} ['CHANGE_MEMORY_ATTRIBUTE        ', clc$nominal_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^change_memory_attribute],
  {} ['CHANGE_MEMORY_ATTRIBUTES       ', clc$alias_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^change_memory_attribute],
  {} ['CHANGE_SHARED_QUEUE_ATTRIBUTE  ', clc$nominal_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^change_shared_queue_attribute],
  {} ['CHANGE_SHARED_QUEUE_ATTRIBUTES ', clc$alias_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^change_shared_queue_attribute],
  {} ['CHASQA                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^change_shared_queue_attribute],
  {} ['DISMA                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^display_memory_attribute],
  {} ['DISPLAY_MEMORY_ATTRIBUTE       ', clc$nominal_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^display_memory_attribute],
  {} ['DISPLAY_MEMORY_ATTRIBUTES      ', clc$alias_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^display_memory_attribute],
  {} ['DISPLAY_SHARED_QUEUE_ATTRIBUTE ', clc$nominal_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^display_shared_queue_attribute],
  {} ['DISPLAY_SHARED_QUEUE_ATTRIBUTES', clc$alias_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^display_shared_queue_attribute],
  {} ['DISPLAY_SHARED_Q_ATTRIBUTE     ', clc$alias_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^display_shared_queue_attribute],
  {} ['DISSQA                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^display_shared_queue_attribute],
  {} ['QUI                            ', clc$abbreviation_entry,
        clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
        ^quit],
  {} ['QUIT                           ', clc$nominal_entry,
        clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
        ^quit],
  {} ['SETTD                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
        ^set_to_default],
  {} ['SET_TO_DEFAULT                 ', clc$nominal_entry,
        clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
        ^set_to_default]];

?? POP ??

?? NEWTITLE := 'exit_condition_handler', EJECT ??

    PROCEDURE exit_condition_handler
      (    exit_condition: pmt$condition;
           exit_condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        exit_status: ost$status;

      condition_status.normal := TRUE;
      CASE exit_condition.selector OF
      = pmc$block_exit_processing =
        clp$end_utility (c$utility_name, exit_status);
        ofp$display_status_message (' ', exit_status);
      ELSE
      CASEND;

    PROCEND exit_condition_handler;
?? OLDTITLE, EJECT ??

    VAR
      input_file: amt$local_file_name,
      local_status: ost$status,
      utility_attributes: ARRAY [1 .. 4] OF clt$utility_attribute;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^exit_condition_handler);

  /manage_memory/
    BEGIN
      utility_attributes [1].key := clc$utility_command_search_mode;
      utility_attributes [1].command_search_mode := clc$global_command_search;
      utility_attributes [2].key := clc$utility_command_table;
      utility_attributes [2].command_table := v$command_table;
      utility_attributes [3].key := clc$utility_termination_command;
      utility_attributes [3].termination_command := 'quit';
      utility_attributes [4].key := clc$utility_prompt;
      utility_attributes [4].prompt.value := 'MMU';
      utility_attributes [4].prompt.size := 3;

      clp$begin_utility (c$utility_name, utility_attributes, status);
      IF NOT status.normal THEN
        EXIT /manage_memory/;
      IFEND;

      clp$include_file (clc$current_command_input, '', c$utility_name, status);
      IF NOT status.normal THEN
        EXIT /manage_memory/;
      IFEND;

      clp$end_utility (c$utility_name, status);
      IF NOT status.normal THEN
        EXIT /manage_memory/;
      IFEND;

    END /manage_memory/;

    osp$disestablish_cond_handler;

  PROCEND mmp$manage_memory;
?? OLDTITLE ??
MODEND mmm$manage_memory;
*DECK DECK=MMM$MANAGE_MEMORY_HELPER_R3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE MANAGE MEMORY UTILITY - Ring3 helper routines' ??
MODULE mmm$manage_memory_helper_r3;

{ PURPOSE:
{   This module contains the fetch and store helper routines which act as an interface between the
{   Manage_Memory Utility which executes in 2dd and the ring1 fetch and store routines.
{
{ DESIGN:
{   The store procedure ensures that the store function is only performed from the system job.  Both procs
{   simply call the corresponding ring1 routine to actually fetch/store the data.  Per standard ring crossing
{   coding, these procs use local variables for the calls to the Ring 1 procedures.  Thus Ring 1 is insulated
{   from possible access violations if the input parameters to Ring3 are incorrect.

?? NEWTITLE := 'Glocal Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc mmt$manage_memory_utility
*copyc mmt$page_queue_list
*copyc ofe$error_codes
*copyc ost$status
?? POP ??
*copyc avp$configuration_administrator
*copyc avp$system_administrator
*copyc mmp$fetch_manage_memory_data_r1
*copyc mmp$fetch_site_active_q_cnt_r1
*copyc mmp$store_manage_memory_data_r1
*copyc osp$set_status_abnormal
*copyc osp$verify_system_privilege
?? OLDTITLE ??
?? NEWTITLE := 'mmp$fetch_manage_memory_data_r3', EJECT ??

{ PURPOSE:
{   This procedure retrieves the data for the Manage Memory Utility from ring1.

  PROCEDURE [XDCL, #GATE] mmp$fetch_manage_memory_data_r3
    (VAR queues: mmt$global_page_queue_list;
     VAR ma_values: mmt$mmu_ma_values;
     VAR gpql_default: mmt$mmu_gpql_default;
     VAR ma_default: mmt$mmu_ma_default);

    VAR
      local_gpql_default: mmt$mmu_gpql_default,
      local_ma_default: mmt$mmu_ma_default,
      local_ma_values: mmt$mmu_ma_values,
      local_queues: mmt$global_page_queue_list;

    osp$verify_system_privilege;

    mmp$fetch_manage_memory_data_r1 (local_queues, local_ma_values, local_gpql_default, local_ma_default);

    gpql_default := local_gpql_default;
    ma_default := local_ma_default;
    queues := local_queues;
    ma_values := local_ma_values;

  PROCEND mmp$fetch_manage_memory_data_r3;
?? OLDTITLE ??
?? NEWTITLE := 'mmp$fetch_site_active_q_cnt_r3', EJECT ??

{ PURPOSE:
{   This procedure retrieves the site active queue count for the Manage Memory Utility from ring1.

  PROCEDURE [XDCL, #GATE] mmp$fetch_site_active_q_cnt_r3
    (VAR site_active_queue_count: 0 .. mmc$pq_shared_num_sites);

    VAR
      local_site_active_queue_count: 0 .. mmc$pq_shared_num_sites;

    osp$verify_system_privilege;

    mmp$fetch_site_active_q_cnt_r1 (local_site_active_queue_count);

    site_active_queue_count := local_site_active_queue_count;

  PROCEND mmp$fetch_site_active_q_cnt_r3;

?? OLDTITLE ??
?? NEWTITLE := 'mmp$store_manage_memory_data_r3', EJECT ??

{ PURPOSE:
{   This procedure stores the data for the Manage Memory Utility.  A check is made to ensure that the user is
{   authorized to store the data.  The input parameters are transferred to local variables before the call to
{   the Ring 1 procedure.

  PROCEDURE [XDCL, #GATE] mmp$store_manage_memory_data_r3
    (VAR queues: mmt$global_page_queue_list;
     VAR ma_values: mmt$mmu_ma_values;
     VAR status: ost$status);

    VAR
      local_ma_values: mmt$mmu_ma_values,
      local_queues: mmt$global_page_queue_list;

    IF NOT (avp$system_administrator() OR avp$configuration_administrator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active,
      'system_administration or configuration_administration', status);
      RETURN;
    IFEND;

    local_queues := queues;
    local_ma_values := ma_values;

    mmp$store_manage_memory_data_r1 (local_queues, local_ma_values);

  PROCEND mmp$store_manage_memory_data_r3;

MODEND mmm$manage_memory_helper_r3;
*DECK DECK=MMM$MEMORY_MANAGER_HELPER EXPAND=TRUE
mmm$memory_manager_helper   ident

.        ojc     1
...............................................................................
.
.           This assembly language module contains memory manager
.           procedures which for reasons of efficiency are written
.           in assembly language. This module contains the following:
.               mmp$preset_real_memory
.
...............................................................................
.
.
.  common decks used (not listed here)
.     sya$constants, sya$cybil_interface_procedures, osa$basic_register_equates,
.     sya$xp_and_sf_constants
         list,0  0,0,0
*copyc osc$keypoint_buffer_pva_offseta
*copy SYA$CONSTANTS
*copy SYA$CYBIL_INTERFACE_PROCEDURES
*copy OSA$BASIC_REGISTER_EQUATES
*copyc sya$xp_and_sf_constants
         list,0  1,2,1
.
.
...............................................................................
.  Define A and X registers. WARNING - some of the registers are loaded via
.  LMULT and SMULT instructions. Be careful if you change register numbers.
...............................................................................
.
amacscr  areg    9                     .Scratch register for macros.
a_work   areg    10                    .Pointer to working storage.
a_segtbl areg    11                    .Pointer to Monitor's segment table.
x_sva    xreg    7                     .SVA  of area to be preset.
x_rma    xreg    8                     .Rma of area to be preset.
x_pagmsk xreg    9                     .Mask for isolating page number.
.
.
. The following registers are loaded by a LMULT instruction. Make sure
. that 'regsel' agrees with the register numbers and that working storage
. data at 'regblk' are in the correct sequence.
.
a_ptbgn  areg    13                    .Pointer to the system page table.
a_pagtbl areg    14                    .Pointer to preset PTE.
a_data   areg    15                    .Pointer to area to be preset.
x_pte    xreg    12                    .Contains initial copy of PT entry.
x_length xreg    13                    .Page size in words - decremented in
.                                         SMULT loop.
.
. The following X-registers are the ONLY x-registers that can be referenced
. in the SMULT loops.
.
.  (x_length used but loaded by LMULT)
x_regsto xreg    14                    .Register for SMULT in major preset loop.
x_loop   xreg    15                    .Number of words preset per major loop.
.
         page
...............................................................................
.
.  Define constants
...............................................................................
.
regcnt   equ     13                    .Number of words of memory preset per SMULT
                                       .instruction in memory preset.  This must be
                                       .the same as the number of X-registers that
                                       .contain a copy of the preset value. For
                                       .maximum efficiency, this equate should be
                                       .equal to the number of the lowest register
                                       .used for other purposes in the SMULT loops.
.
.
...............................................................................
.  Define Binding Section..
...............................................................................
.
         use     binding
         ref     msegtbl
         ref     errstop
         def     work
msegtbl  alias   MTV$MONITOR_SEGMENT_TABLE
work     alias   MMC$MMMASM_WORKING
errstop  alias   MTP$ERROR_STOP
bs_work  address p,work
bs_segtb address p,msegtbl             .Pointer to Monitor segment table.
bs_err   address ce,errstop
.
.
...............................................................................
.  Define Working Storage.
...............................................................................
.
         use     working
work     bss     0
.
.
.  The following words are referenced only thru LMULT and SMULT instructions
.  If any changes are made, check the corresponding register equates
.  and the 'regsel' value used to load the words.
.
         align   0,8
regsel   equ     0dcfd(16)             .Register selector for LMULT.
regblk   bss     0                     .Beginning of LMULT/SMULT block.
         vfd,16,4,12,32 0,1,snptmtr,0  .Pointer to begin of Page table.
         vfd,16,4,12,32 0,1,snptmtr,0  .Pointer to preset page table entry.
         vfd,16,4,12,32 0,1,snptmtr,0  .Preset PVA.
         vfd,4,16,22,22 0c(16),0,0,0   .Template for PTE word.
         vfd,64  0                     .Page size in words. Zero
                                       . implies initialzation required.
kbpo     vfd,32  keybpo                .Page table PVA offset of keypoint collection
                                       . buffer.
err1     vfd,152 c'MM - Preset failure'

         align   0,8
mmvpct   bss     0
zero     vfd,64  0
altone   vfd,64  0aaaaaaaaaaaaaaaa(16)
indef    vfd,64  07000000000000000(16)
inf      vfd,64  05000000000000000(16)
.
         defg    mmvpct
mmvpct   alias   MMV$PRESET_CONVERSION_TABLE
         page
...............................................................................
.
.  This procedure is used in monitor to preset a range of REAL MEMORY
.  ADDRESSES to a specified value. WARNING: no checks are made on the
.  validity of the address range except to verify that the SVA
.  exists in the page table with the 'valid' bit clear. The range of words to be
.  preset must not cross a page boundary.
.
.      MMP$PRESET_REAL_MEMORY (SVA, PRESET_VALUE);
.
.    SVA: (input) This parameter specifies the SVA
.         the beginning of the area to be preset.
.    PRESET_IDENTIFIER: (input) This parameter is passed as LLT$PRESET_VALUE and
.         is used as andindex into pmv$preset_conversion_table.
.
.
.      PROCEDURE [XREF] mmp$preset_real_memory (sva: ost$system_virtual_address;
.        preset_identifier: llt$preset_value);
.
.
.
.     NOTES:
.        - routine will halt if SVA is not 0 MOD 8.
.        - routine will halt if SVA is not in the page table with the
.          'valid' bit CLEAR.
.        - length is rounded down to a multiple of eight bytes.
.
.
...............................................................................
.
         use     code
         def     preset
preset   alias   MMP$PRESET_REAL_MEMORY
preset   procedur
sva      param   val,subrange,6
value    param   val,subrange,8
.
         la      a_work,a_bindin,bs_work  .Get pointer to working storage
         ente    x0,regsel             .Load working registers from memory.
         lmult   x0,a_work,regblk*8
         brxeq   x_length,x0,init      .Jump if routine not yet initialized.
.
         ploadx  x_sva,sva             .Get SVA and verify that a
         lpage   x_rma,x_sva,x1        . PT entry for the page exists
         brrge   x1,x0,preserr         . with the 'valid' bit clear.
         lbyts,8 x_rma,a_ptbgn,x_rma,0  .Page table entry of SVA presetting
         brxgt   x0,x_rma,preserr      .If valid bit set
         insb    x_pte,x_rma,x0,5225(8) .Store page frame address into presets
         sbyts,3 x_pte,a_pagtbl,x0,5   .  PTE.
.
         ploadx  x1,value              .Get bit pattern to be stored.
         lxi     x0,a_work,x1,mmvpct
         cpyax   x1,a_data             .Purge the page file - we changed the PT.
         purge   x1,10
         cpyxx   x1,x0                 .Propagate bit pattern to rest of
                                       . X-registers.
         cpyxx   x2,x0
         cpyxx   x3,x0
         cpyxx   x4,x0
         cpyxx   x5,x0
         cpyxx   x6,x0
         cpyxx   x7,x0
         cpyxx   x8,x0
         cpyxx   x9,x0
         cpyxx   xa,x0
         cpyxx   xb,x0
         cpyxx   xc,x0
.
         ente    x_regsto,regcnt+0fff(16)  .Register descriptor for SMULT.
         ente    x_loop,regcnt*4       .Number of words stored per SMULT.
preset3  smult   x_regsto,a_data,0     .Store  'regcnt'*4 words at a time
         smult   x_regsto,a_data,regcnt*8
         smult   x_regsto,a_data,regcnt*8*2
         smult   x_regsto,a_data,regcnt*8*3
         addxq   x_length,x_length,-regcnt*4
         addaq   a_data,a_data,regcnt*8*4
         brxge   x_length,x_loop,preset3  .Jump if not done with big store loop
.
preset5  entp    x_loop,regcnt         .Update number of words stored per loop.
         brxgt   x_loop,x_length,preset8  .Jump if not much to preset.
.
preset6  smult   x_regsto,a_data,0     .Preset some more data.
         addaq   a_data,a_data,regcnt*8
         decx    x_length,regcnt
         brxge   x_length,x_loop,preset6  .Jump if more than 'regcnt' words remain.
.
preset8  brxeq   x_length,x0,presetx   .Exit if all done.
         addxq   x_length,x_length,0fff(16)  .Calculate new descriptor.
         smult   x_length,a_data,0     .Finish presetting odd length at end
                                       . of area.
.
presetx  ente    x0,0                  .Reset page number of PTE to zero.
         sbyts,3 x0,a_pagtbl,x0,5
         return
.
.
preserr  addaq   a0,a0,16              .Push space for plist.
         entl    x0,19                 .Message length.
         addaq   af,a_work,err1        .Address of message.
         sa      af,a1,0
         sbyts,2 x0,a1,x0,6
         cpyaa   af,a1                 .parameter list address.
         enta    x0,100ff(16)
         callseg bs_err,a_bindin,af
         page
...............................................................................
.
.  INIT - This procedure initializes constants used by the MMP$PRESET_REAL_MEMORY
.         routine. These constants are stored in "regblk', a page table entry
.         is also created in page table to use to access memory using the PVA
.         created for this purpose.
.
.        ENTRY:
.                a_work = Pointer to working storage of this module.
.                a_bindin = Pointer to binding section of this module.
.                a_ptbgn = Pointer to the system page table.
.                x_pte   = Page table entry template.
.
.        CALLS:  preserr.
.
.        EXIT:
.                'REGBLK' in working storage is initialized for presetting memory.
.                Exit is to 'preset'.
.
.        USES:   a_data, a_pagtbl, a_segtbl,  x0, x2 - x6, x_pte, x_pagmsk
...............................................................................


         align   0,2
init     bss     0
         la      a_segtbl,a_bindin,bs_segtb  .Get the ASID of the page table segment.
         entl    x0,r_ptl
         lbyts,2 x2,a_segtbl,x0,snptmtr*8+2  .Page table ASID
         cpysx   x5,x0                 .Page table length
         entl    x0,r_psm
         incx    x5,1
         cpysx   x3,x0                 .Page size mask
         ente    x4,128
         insb    x_pte,x2,x0,(4*64)+15 .Insert ASID into PTE word.
         shfx    x6,x5,x0,12+1         .Page table length in bytes * 2
         subx    x4,x3                 .Page size DIV 200(16)
         shfx    x2,x2,x0,32
         shfx    x3,x3,x0,9
         isom    x_pagmsk,x0,(48*64)+15  .Maximum page size mask
         shfx    x4,x4,x0,9            .Page size in bytes
         shfx    x_length,x4,x0,-3
         addr    x2,x6                 .Initial SVA of preset PVA
         ente    x5,32
         inhx    x_pagmsk,x3           .Mask for isolating page number and offset
                                       . from an SVA
         lbyts,4 x3,a_work,x0,kbpo     .Page table PVA offset used for keypoint
                                       . collection

.        Find an offset for preset PVA greater than the length of the page table
.        to use for presetting memory.  Use the page table PVA as the basis of
.        the preset PVA.  Start offset at twice the page table length, keypoint
.        collection uses a PVA based on the page table for buffers with a large
.        offset.  The offset used by keypoint collection will be used as the
.        upper bound.

init5    bss     0
         lpage   x6,x2,x1
         brrgt   x5,x1,init10          .If avilable slot in page table
         addr    x2,x4                 .Increment SVA offset
         brrgt   x3,x2,init5           .If maximum offset not exceeded

.  Did not find available slot in page table for memory preset, fatal error.

         brxeq   x0,x0,preserr         .Fatal error, system initialization failed

init10   bss     0
         cpyxx   x5,x2
         inhx    x2,x_pagmsk           .Page number of preset PVA
         addax   a_pagtbl,x6           .PVA of preset page table entry
         insb    x_pte,x2,x0,(20*64)+30  .Insert page number into preset PTE
         addax   a_data,x5             .Preset PVA
         sbyts,8 x_pte,a_pagtbl,x0,0   .Store preset page table entry

         ente    x0,regsel
         smult   x0,a_work,regblk*8    .Store working registers.

         brxeq   x0,x0,preset          .Initialization complete, continue preset

         end
*DECK DECK=MMM$MEMORY_MGR_REQUEST_PROCS EXPAND=TRUE
?? RIGHT := 110, LEFT := 1 ??
MODULE mmm$memory_mgr_request_procs {MMREQS} ;

?? SKIP := 3 ??

{
{  PURPOSE:
{     This module contains request processors for job mode mem mgr requests.
{

?? PUSH (LISTEXT := ON) ??
*copyc mmt$rb_advise
*copyc mmt$rb_wait_io_completion
*copyc mmt$rb_lock_unlock_segment
*copyc osd$virtual_address
*copyc osc$purge_map_and_cache
*copyc ost$caller_identifier
*copyc mmt$rb_segment_request
*copyc mme$condition_codes
*copyc mmt$rb_fetch_pva_unwritten_pgs
*copyc mmt$rb_free_flush
*copyc mmk$job_mode_keypoints
*copyc mmt$rb_lock_unlock_pages
*copyc ost$status
*copyc ost$hardware_subranges
*copyc ost$wait
?? POP ??


{External procedures used by this module.

*copyc i#call_monitor
*copyc i#real_memory_address
*copyc mmp$assign_device_to_segment
*copyc mmp$get_page_size
*copyc osp$set_status_abnormal
*copyc syp$set_status_from_mtr_status
*copyc mmp$reallocate_file_space
  ?? SKIP := 3 ??
{  Define global type definitions for offset arrays used in 'mmp$fetch_pva_unwritten pages'.  If
{  'sort_offset_arrays' was a nested procedure would not be necessary.

  TYPE
    offset_array_control_record = record
      offset_array_p: ^offset_array,
      next_offset_control_record_p: ^offset_array_control_record,
      offset_count: integer,
    recend,

    offset_array = array [1 .. * ] of ost$byte_count;

{  Internal procedures used by this module.

?? TITLE := 'LOCK_UNLOCK_PAGES' ??
?? EJECT ??

  PROCEDURE lock_unlock_pages (lock_page_type: mmt$locked_page;
        pva: ^cell;
        length: ost$byte_count;
        request_code: syt$monitor_request_code;
    VAR status: ost$status);


{
{   The purpose of this procedure is to issue the monitor function to lock or unlock pages.
{ Monitor status is also returned in the status variable.
{


    VAR
      rb: mmt$rb_lock_unlock_pages;


    rb.reqcode := request_code;
    rb.lock_page_type := lock_page_type;
    rb.pva := pva;
    rb.length := length;
    i#call_monitor (#LOC (rb), #SIZE (rb));
    syp$set_status_from_mtr_status (rb.status, status);

  PROCEND lock_unlock_pages;
?? TITLE := 'SORT_OFFSET_ARRAYS' ??
?? EJECT ??

  PROCEDURE sort_offset_arrays (first_oacr_p: ^offset_array_control_record);

{
{   The purpose of this procedure is to sort the offsets in the offset arrays in ascending order.
{  This procedure should be nested within 'mmp$fetch_pva_unwritten_pva' but because of
{  a CYBIL bug with 'PUSH' statement and then a call to a nested procedure it is
{  done this way.
{

    VAR
      i: integer,
      next_oa_p: ^offset_array,
      oa_p: ^offset_array,
      oacr_p: ^offset_array_control_record,
      offset: ost$byte_count,
      offsets_swapped: boolean;


    offsets_swapped := TRUE;

  /sort_offsets/
    WHILE offsets_swapped = TRUE DO
      oacr_p := first_oacr_p;
      oa_p := oacr_p^.offset_array_p;
      offsets_swapped := FALSE;

      REPEAT
        FOR i := 1 TO (oacr_p^.offset_count - 1) DO
          IF oa_p^ [i] > oa_p^ [i + 1] THEN
            offset := oa_p^ [i];
            oa_p^ [i] := oa_p^ [i + 1];
            oa_p^ [i + 1] := offset;
            offsets_swapped := TRUE;
          IFEND;
        FOREND;


{  Check if have to swap offsets between two arrays.

        oacr_p := oacr_p^.next_offset_control_record_p;
        IF oacr_p <> NIL THEN
          next_oa_p := oacr_p^.offset_array_p;
          IF oa_p^ [i + 1] > next_oa_p^ [LOWERBOUND (next_oa_p^)] THEN
            offset := oa_p^ [i + 1];
            oa_p^ [i + 1] := next_oa_p^ [LOWERBOUND (next_oa_p^)];
            next_oa_p^ [LOWERBOUND (next_oa_p^)] := offset;
            offsets_swapped := TRUE;
          IFEND;
          oa_p := next_oa_p;
        IFEND;
      UNTIL oacr_p = NIL;
    WHILEND /sort_offsets/;

  PROCEND sort_offset_arrays;
?? TITLE := 'MMP$ADVISE_IN' ??
?? EJECT ??
*copyc mmh$advise_in

  PROCEDURE [XDCL, #GATE] mmp$advise_in (pva: ^cell;
        length: ost$byte_count;
    VAR status: ost$status);

    VAR
      rb: mmt$rb_advise;

    #keypoint (osk$entry, #segment (pva) * osk$m, mmk$advise_in);
    status.normal := TRUE;


    rb.reqcode := syc$rc_advise_in;
    rb.in_pva := pva;
    rb.in_length := length;
    i#call_monitor (#LOC (rb), #SIZE (rb));
    syp$set_status_from_mtr_status (rb.status, status);

    #keypoint (osk$exit, 0, mmk$advise_in);

  PROCEND mmp$advise_in;
?? TITLE := 'MMP$ADVISE_OUT' ??
?? EJECT ??
*copyc mmh$advise_out

  PROCEDURE [XDCL, #GATE] mmp$advise_out (pva: ^cell;
        length: ost$byte_count;
    VAR status: ost$status);

    VAR
      rb: mmt$rb_advise;

    #keypoint (osk$entry, #segment (pva) * osk$m, mmk$advise_out);
    status.normal := TRUE;


    rb.reqcode := syc$rc_advise_out;
    rb.out_pva := pva;
    rb.out_length := length;
    i#call_monitor (#LOC (rb), #SIZE (rb));
    syp$set_status_from_mtr_status (rb.status, status);
    IF NOT status.normal AND (status.condition = mme$segment_not_assigned_device) THEN
      status.normal := TRUE;
    IFEND;

    #keypoint (osk$exit, 0, mmk$advise_out);

  PROCEND mmp$advise_out;
?? TITLE := 'MMP$ADVISE_OUT_IN' ??
?? EJECT ??
*copyc mmh$advise_out_in

  PROCEDURE [XDCL, #GATE] mmp$advise_out_in (out_pva: ^cell;
        out_length: ost$byte_count;
        in_pva: ^cell;
        in_length: ost$byte_count;
    VAR status: ost$status);

    VAR
      rb: mmt$rb_advise;

    #keypoint (osk$entry, #segment (out_pva) * osk$m, mmk$advise_out_in);
    status.normal := TRUE;


    rb.reqcode := syc$rc_advise_out_in;
    rb.in_pva := in_pva;
    rb.in_length := in_length;
    rb.out_pva := out_pva;
    rb.out_length := out_length;
    i#call_monitor (#LOC (rb), #SIZE (rb));
    syp$set_status_from_mtr_status (rb.status, status);
    IF NOT status.normal AND (status.condition = mme$segment_not_assigned_device) THEN
      status.normal := TRUE;
    IFEND;

    #keypoint (osk$exit, 0, mmk$advise_out_in);

  PROCEND mmp$advise_out_in;
?? TITLE := 'MMP$FETCH_PVA_UNWRITTEN_PAGES' ??
?? EJECT ??
{--------------------------------------------------------------------------------------------------------
*copyc mmh$fetch_pva_unwritten_pages
{--------------------------------------------------------------------------------------------------------


  PROCEDURE [XDCL, #GATE] mmp$fetch_pva_unwritten_pages (segment_p: ^cell;
        starting_pva: ^cell;
    VAR pva_list: array [ * ] OF ^cell;
    VAR list_overflow: boolean;
    VAR status: ost$status);


    TYPE
      offset_array_control_record = record
        offset_array_p: ^offset_array,
        next_offset_control_record_p: ^offset_array_control_record,
        offset_count: integer,
      recend,

      offset_array = array [1 .. * ] of ost$byte_count;

    VAR
      first_oacr_p: ^offset_array_control_record,
      i: integer,
      oa_p: ^offset_array,
      oacr_p: ^offset_array_control_record,
      offset_array_index: integer,
      offset_count: integer,
      previous_oacr_p: ^offset_array_control_record,
      request_block: mmt$rb_fetch_pva_unwritten_pgs;


    #keypoint (osk$entry, #segment (segment_p) * osk$m, mmk$fetch_pva_unwritten_pages);
    status.normal := TRUE;
    request_block.reqcode := syc$rc_fetch_pva_unwritten_pgs;
    request_block.subsequent_request_for_same_pva := FALSE;
    request_block.offset_list_overflow := TRUE;
    IF starting_pva = NIL THEN
      request_block.pva := #address (#ring (segment_p), #segment (segment_p), 0);
      request_block.starting_with_first_page := TRUE;
    ELSE
      request_block.pva := starting_pva;
      request_block.starting_with_first_page := FALSE;
    IFEND;


{  Issue monitor function to return unwritten PVAs and save these pva lists on the stack.

    first_oacr_p := NIL;
    oacr_p := NIL;
    oa_p := NIL;

  /fetch_unwritten_pva/
    WHILE request_block.offset_list_overflow = TRUE DO
      i#call_monitor (#LOC (request_block), #SIZE (request_block));
      syp$set_status_from_mtr_status (request_block.status, status);
      IF NOT status.normal THEN
        #keypoint (osk$exit, 0, mmk$fetch_pva_unwritten_pages);
        RETURN;
      IFEND;

      IF request_block.offsets_returned <> 0 THEN
        previous_oacr_p := oacr_p;
        PUSH oacr_p;

        IF first_oacr_p = NIL THEN
          first_oacr_p := oacr_p;
        IFEND;

        IF previous_oacr_p <> NIL THEN
          previous_oacr_p^.next_offset_control_record_p := oacr_p;
        IFEND;

        oacr_p^.offset_count := request_block.offsets_returned;
        oacr_p^.next_offset_control_record_p := NIL;

        PUSH oa_p: [1 .. request_block.offsets_returned];
        IF oa_p = NIL THEN
          osp$set_status_abnormal ('MM', mme$stack_overflow_on_push, '', status);
          #keypoint (osk$exit, 0, mmk$fetch_pva_unwritten_pages);
          RETURN;
        IFEND;

        oacr_p^.offset_array_p := oa_p;

        FOR i := 1 TO request_block.offsets_returned DO
          oa_p^ [i] := request_block.offset_list [i];
        FOREND;

        request_block.subsequent_request_for_same_pva := TRUE;
      IFEND;
    WHILEND /fetch_unwritten_pva/;

    list_overflow := FALSE;
    IF first_oacr_p <> NIL THEN
      sort_offset_arrays (first_oacr_p);


{  Form PVAs from offsets in linked offset arrays and move to caller's pva list.  If caller's
{  pva list not filled up the remaining pva list entries are set to NIL.  If all
{  PVAs do not fit in the pva list the list overflow is set to TRUE.

      oacr_p := first_oacr_p;
      offset_count := oacr_p^.offset_count;
      oa_p := oacr_p^.offset_array_p;
      offset_array_index := LOWERBOUND (oa_p^);

    /return_pva_to_caller/
      FOR i := LOWERBOUND (pva_list) TO UPPERBOUND (pva_list) DO
        IF offset_array_index > offset_count THEN
          oacr_p := oacr_p^.next_offset_control_record_p;
          IF oacr_p <> NIL THEN
            offset_count := oacr_p^.offset_count;
            oa_p := oacr_p^.offset_array_p;
            offset_array_index := LOWERBOUND (oa_p^);
          ELSE
            offset_array_index := LOWERBOUND (oa_p^);
            offset_count := offset_array_index;
          IFEND;
        IFEND;

        IF oacr_p <> NIL THEN
          pva_list [i] := #address (#ring (segment_p), #segment (segment_p), oa_p^ [offset_array_index]);
          offset_array_index := offset_array_index + 1;
        ELSE
          pva_list [i] := NIL;
        IFEND;
      FOREND /return_pva_to_caller/;

      IF (oacr_p <> NIL) OR ((offset_array_index > offset_count) AND (oacr_p^.next_offset_control_record_p <>
            NIL)) THEN
        list_overflow := TRUE;
      IFEND;
    ELSE
      FOR i := LOWERBOUND (pva_list) TO UPPERBOUND (pva_list) DO
        pva_list [i] := NIL;
      FOREND;
    IFEND;

    #keypoint (osk$exit, 0, mmk$fetch_pva_unwritten_pages);

  PROCEND mmp$fetch_pva_unwritten_pages;
?? TITLE := 'MMP$FREE_PAGES' ??
?? EJECT ??
*copyc mmh$free_pages

  PROCEDURE [XDCL, #GATE] mmp$free_pages (pva: ^cell;
        length: ost$byte_count;
        waitopt: ost$wait;
    VAR status: ost$status);

    VAR
      rb: mmt$rb_free_flush;

    #keypoint (osk$entry, #segment (pva) * osk$m, mmk$free_pages);
    status.normal := TRUE;


    rb.reqcode := syc$rc_free_pages;
    rb.pva := pva;
    rb.length := length;
    rb.waitopt := waitopt;
    i#call_monitor (#LOC (rb), #SIZE (rb));
    syp$set_status_from_mtr_status (rb.status, status);

    #keypoint (osk$exit, 0, mmk$free_pages);

  PROCEND mmp$free_pages;
?? TITLE := 'MMP$LOCK_PAGES' ??
?? EJECT ??
{--------------------------------------------------------------------------------------------------------
*copyc mmh$lock_pages
{--------------------------------------------------------------------------------------------------------


  PROCEDURE [XDCL, #GATE] mmp$lock_pages (pva: ^cell;
        length: ost$byte_count;
    VAR status: ost$status);

    #keypoint (osk$entry, #segment (pva) * osk$m, mmk$job_lock_pages);
    status.normal := TRUE;

    lock_unlock_pages (mmc$lp_aging_lock, pva, length, syc$rc_lock_pages, status);
    WHILE (status.normal = FALSE) AND ((status.condition = mme$page_not_in_page_table) OR (status.condition =
          mme$not_valid_in_page_table)) DO
      mmp$advise_in (pva, length, status);
      IF status.normal THEN
        lock_unlock_pages (mmc$lp_aging_lock, pva, length, syc$rc_lock_pages, status);
      IFEND;
    WHILEND;

    #keypoint (osk$exit, 0, mmk$job_lock_pages);

  PROCEND mmp$lock_pages;
?? TITLE := 'MMP$UNLOCK_PAGES' ??
?? EJECT ??
{--------------------------------------------------------------------------------------------------------
*copy mmh$unlock_pages
{--------------------------------------------------------------------------------------------------------


  PROCEDURE [XDCL, #GATE] mmp$unlock_pages (pva: ^cell;
        length: ost$byte_count;
    VAR status: ost$status);

    #keypoint (osk$entry, #segment (pva) * osk$m, mmk$job_unlock_pages);
    status.normal := TRUE;

    lock_unlock_pages (mmc$lp_aging_lock, pva, length, syc$rc_unlock_pages, status);

    #keypoint (osk$exit, 0, mmk$job_unlock_pages);

  PROCEND mmp$unlock_pages;
?? TITLE := 'MMP$WRITE_MODIFIED_PAGES' ??
?? EJECT ??
*copyc mmh$write_modified_pages

  PROCEDURE [XDCL, #GATE] mmp$write_modified_pages (pva: ^cell;
        length: ost$byte_count;
        waitopt: ost$wait;
    VAR status: ost$status);

    VAR
      local_status: ost$status,
      count: integer,
      rb: mmt$rb_free_flush;

    #keypoint (osk$entry, #segment (pva) * osk$m, mmk$write_modified_pages);
    status.normal := TRUE;


    rb.reqcode := syc$rc_write_modified_pages;
    rb.pva := pva;
    rb.length := length;
    rb.waitopt := waitopt;

{   Mmp$process_wmp_status (mtr) will set init_new_io to FALSE if the call is reissued for the wait option.

    rb.init_new_io := TRUE;
    FOR count := 1 TO 4 DO
    i#call_monitor (#LOC (rb), #SIZE (rb));
    syp$set_status_from_mtr_status (rb.status, status);
    IF NOT status.normal THEN
      IF status.condition = mme$segment_not_assigned_device THEN
        mmp$assign_device_to_segment (pva, local_status);
        IF NOT local_status.normal THEN
          #keypoint (osk$exit, 0, mmk$write_modified_pages);
          RETURN;
        IFEND;
      ELSEIF status.condition = mme$io_write_error THEN
        IF count = 4 THEN
          #keypoint (osk$exit, 0, mmk$write_modified_pages);
          RETURN;
        IFEND;
        mmp$reallocate_file_space (pva, local_status);
        IF NOT local_status.normal THEN
          #keypoint (osk$exit, 0, mmk$write_modified_pages);
          RETURN;
        IFEND;
        rb.init_new_io := TRUE;
      ELSE
        #keypoint (osk$exit, 0, mmk$write_modified_pages);
        RETURN;
      IFEND;
    ELSE
      #keypoint (osk$exit, 0, mmk$write_modified_pages);
      RETURN;
    IFEND;
    FOREND;

    #keypoint (osk$exit, 0, mmk$write_modified_pages);

  PROCEND mmp$write_modified_pages;
?? TITLE := 'mmp$check_if_pages_in_memory' ??
?? EJECT ??
*copyc mmh$check_if_pages_in_memory

  PROCEDURE [XDCL, #GATE] mmp$check_if_pages_in_memory (pva: ^cell;
        length: ost$segment_length;
    VAR in_memory: boolean);

    VAR
      page_count: integer,
      page_size: integer,
      i: integer,
      rma: integer;

    in_memory := TRUE;

    mmp$get_page_size (page_size);

    page_count := (#offset (pva) + length - 1) DIV page_size - (#offset (pva) DIV page_size) + 1;

    FOR i := 0 TO page_count - 1 DO
      i#real_memory_address (#address (1, #segment (pva), #offset (pva) + i * page_size), rma);
      IF rma < 0 THEN
        in_memory := FALSE;
        RETURN;
      IFEND;
    FOREND;

  PROCEND mmp$check_if_pages_in_memory;
?? TITLE := 'mmp$lock_catalog_segment' ??
?? EJECT ??
*copyc mmh$lock_catalog_segment

  PROCEDURE [XDCL, #GATE] mmp$lock_catalog_segment (p: ^cell;
        access: mmt$lus_lock_type;
        wait: ost$wait;
    VAR status: ost$status);

    VAR
      rb: mmt$rb_lock_unlock_segment;

    #keypoint (osk$entry, #segment (p) * osk$m, mmk$job_lock_segment);
    status.normal := TRUE;
    rb.reqcode := syc$rc_lock_unlock_segment;
    rb.request := mmc$lus_lock_segment;
    rb.access := access;
    {
    { Until a method of preventing jobs with catalog segment locks from
    { being swapped this interface will behave exactly like mmp$lock_segment.
    { rb.catalog_segment := TRUE;
    {
    rb.catalog_segment := FALSE;
    rb.wait := wait;
    rb.pva := p;
    REPEAT
      i#call_monitor (#LOC (rb), #SIZE (rb));
    UNTIL rb.status.normal OR (wait = osc$nowait) OR (rb.status.condition <> mme$segment_locked_another_task);
    #purge_buffer (osc$pva_purge_segment_cache, p);
    syp$set_status_from_mtr_status (rb.status, status);
    #keypoint (osk$exit, 0, mmk$job_lock_segment);
  PROCEND mmp$lock_catalog_segment;
?? TITLE := 'mmp$lock_segment' ??
?? EJECT ??
*copyc mmh$lock_segment

  PROCEDURE [XDCL, #GATE] mmp$lock_segment (p: ^cell;
        access: mmt$lus_lock_type;
        wait: ost$wait;
    VAR status: ost$status);

    VAR
      rb: mmt$rb_lock_unlock_segment;

    #keypoint (osk$entry, #segment (p) * osk$m, mmk$job_lock_segment);
    status.normal := TRUE;
    rb.reqcode := syc$rc_lock_unlock_segment;
    rb.request := mmc$lus_lock_segment;
    rb.access := access;
    rb.catalog_segment := FALSE;
    rb.wait := wait;
    rb.pva := p;
    REPEAT
      i#call_monitor (#LOC (rb), #SIZE (rb));
    UNTIL rb.status.normal OR (wait = osc$nowait) OR (rb.status.condition <> mme$segment_locked_another_task);
    #purge_buffer (osc$pva_purge_segment_cache, p);
    syp$set_status_from_mtr_status (rb.status, status);
    #keypoint (osk$exit, 0, mmk$job_lock_segment);
  PROCEND mmp$lock_segment;
?? TITLE := 'mmp$unlock_segment' ??
?? EJECT ??
*copyc mmh$unlock_segment

  PROCEDURE [XDCL, #GATE] mmp$unlock_segment (p: ^cell;
        page_disposition: mmt$lus_page_disposition;
        wait: ost$wait;
    VAR status: ost$status);

    VAR
      local_status: ost$status,
      count: integer,
      rb: mmt$rb_lock_unlock_segment;

    #keypoint (osk$entry, #segment (p) * osk$m, mmk$job_unlock_segment);
    status.normal := TRUE;
    rb.reqcode := syc$rc_lock_unlock_segment;
    rb.request := mmc$lus_unlock_segment;
    rb.page_disposition := page_disposition;
    rb.wait := wait;

{   Mmp$process_wmp_status (mtr) will set init_new_io to FALSE if the call is reissued for the wait option.

    rb.init_new_io := TRUE;
    rb.pva := p;
    FOR count := 1 TO 4 DO
    i#call_monitor (#LOC (rb), #SIZE (rb));
    syp$set_status_from_mtr_status (rb.status, status);
    IF NOT status.normal THEN
      IF status.condition = mme$io_write_error THEN
        IF count = 4 THEN
          #keypoint (osk$exit, 0, mmk$job_unlock_segment);
          RETURN;
        IFEND;
        mmp$reallocate_file_space (p, local_status);
        IF NOT local_status.normal THEN
          #keypoint (osk$exit, 0, mmk$job_unlock_segment);
          RETURN;
        IFEND;
        rb.init_new_io := TRUE;
      ELSE
        #keypoint (osk$exit, 0, mmk$job_unlock_segment);
        RETURN;
      IFEND;
    ELSE
      #keypoint (osk$exit, 0, mmk$job_unlock_segment);
      RETURN;
    IFEND;
    FOREND;
    #keypoint (osk$exit, 0, mmk$job_unlock_segment);
  PROCEND mmp$unlock_segment;
  ?? TITLE := 'MMP$WAIT_IO_COMPLETION', EJECT ??
*copyc mmh$wait_io_completion


  PROCEDURE [XDCL, #GATE] mmp$wait_io_completion (pva: ^cell;
    VAR status: ost$status);

    VAR
      rb: mmt$rb_wait_io_completion;

    status.normal := TRUE;
    rb.reqcode := syc$rc_wait_io_completion;
    rb.pva := pva;
    i#call_monitor (#LOC (rb), #SIZE (rb));
    syp$set_status_from_mtr_status (rb.status, status);

  PROCEND mmp$wait_io_completion;



MODEND mmm$memory_mgr_request_procs;

*DECK DECK=MMM$MM_PATH_TEST EXPAND=TRUE
?? RIGHT := 110 ??
MODULE mmm$mm_path_test;

{ This test measures the page fault overheads under various conditions.
{ The tests were run in a normal closed shop environment BUT with
{ job priority set to P8.
{
{   to run,
{      GETS PTM$PF_TEST s=s e=true pn=performance_tools
{      CYBIL i=s l=l opt=high
{      SETMO p=p1
{      LGO


?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc osc$processor_defined_registers
*copyc pmt$program_parameters
*copyc tmt$rb_ready_task
?? POP ??
*copyc amp$close
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$put_next
*copyc clp$evaluate_parameters
*copyc i#call_monitor
*copyc i#move
*copyc i#real_memory_address
*copyc clp$put_job_command_response
*copyc fsp$open_file
*copyc mmp$advise_in
*copyc mmp$advise_out
*copyc mmp$advise_out_in
*copyc mmp$assign_pages
*copyc mmp$assign_contiguous_memory
*copyc mmp$change_stack_attribute
*copyc mmp$check_if_pages_in_memory
*copyc mmp$check_io_status
*copyc mmp$conditional_free
*copyc mmp$create_scratch_segment
*copyc mmp$create_segment
*copyc mmp$create_shadow_segment
*copyc mmp$create_user_segment
*copyc mmp$delete_scratch_segment
*copyc mmp$delete_segment
*copyc mmp$delete_user_segment
*copyc mmp$fetch_pva_unwritten_pages
*copyc mmp$fetch_segment_attributes
*copyc mmp$free_pages
*copyc mmp$get_segment_length
*copyc mmp$initiate_debug_shadowing
*copyc mmp$initiate_shadowing
*copyc mmp$lock_pages
*copyc mmp$lock_segment
*copyc mmp$move_pages
*copyc mmp$preallocate_file_space
*copyc mmp$read
*copyc mmp$reserve_segment_number
*copyc mmp$set_access_selections
*copyc mmp$set_segment_length
*copyc mmp$store_segment_attributes
*copyc mmp$terminate_shadowing
*copyc mmp$unlock_pages
*copyc mmp$unlock_segment
*copyc mmp$verify_access
*copyc mmp$wait_io_completion
*copyc mmp$write
*copyc mmp$write_modified_pages
*copyc osp$set_status_abnormal
*copyc pfp$purge
*copyc pmp$cycle
*copyc pmp$execute
*copyc pmp$exit
*copyc pmp$get_program_description
*copyc pmp$get_program_size
*copyc pmp$wait


  TYPE
    statistic = record
      tmin,
      tsum,
      tcount,
      taver: integer,
    recend,
    task2_function = (idle, run, quit),
    shared_info = record
      func: ALIGNED [0 MOD 16384] task2_function,
      t1: integer,
      t2: integer,
      t1_last: integer,
      t1_changed: integer,
      page: ALIGNED [0 MOD 16384] integer,
    recend;

{ Global variables - used by Task 1 (primary task) ONLY.

  VAR
    pa: ^array [0 .. 1000000] of 0 .. 255 := NIL,
    p: ^integer := NIL,
    p2a: ^array [0 .. 1000000] of 0 .. 255 := NIL,
    p2: ^integer := NIL,
    data_p: ^shared_info,
    page_size: integer,
    scale: integer,
    task_switch_time: integer,
    ofid: amt$file_identifier,
    skip_shadow_tests: boolean,
    status: ost$status,
    file_id1,
    file_id2: amt$file_identifier,
    scratch_files: boolean,
    cyc: pft$cycle_selector := [pfc$lowest_cycle],
    ba: amt$file_byte_address,
    pfn1: [STATIC] array [1 .. 3] of pft$name := [' ', ' ', 'ZZZSCR1'],
    pfn2: [STATIC] array [1 .. 3] of pft$name := [' ', ' ', 'ZZZSCR2'],
    password: ost$name := '                               ',
    s,
    ss: string (100),
    sl: integer,
    s1,
    s2,
    s3: statistic;

?? EJECT ??
{-----------------------------------------------------------------------

  PROCEDURE set_task2_function
    (    func: task2_function);

    VAR
      t2f: integer;

    t2f := data_p^.t2;
    data_p^.func := func;
    REPEAT
      pmp$cycle (status);
    UNTIL (data_p^.t2 <> t2f) OR (func <> run);
  PROCEND set_task2_function;

  PROCEDURE check_status
    (VAR status: ost$status);

    IF NOT status.normal THEN
      pmp$exit (status);
    IFEND;
  PROCEND check_status;

  PROCEDURE reset_statistic
    (VAR s: statistic);

    s.tmin := 999999999999;
    s.tsum := 0;
    s.tcount := 0;
    s.taver := 0;
  PROCEND reset_statistic;

  PROCEDURE record_statistic
    (    t1,
         t2: integer;
     VAR s: statistic);

    VAR
      t: integer;

    t := t2 - t1;
    IF t < s.tmin THEN
      s.tmin := t;
    IFEND;
    s.tsum := s.tsum + t;
    s.tcount := s.tcount + 1;
  PROCEND record_statistic;

  PROCEDURE display_statistic
    (    str: string ( * <= 50);
         sub: integer;
     VAR stat: statistic);

    IF stat.tcount > 0 THEN
      stat.taver := (stat.tsum DIV stat.tcount) - sub;
    ELSE
      stat.tmin := 0;
    IFEND;
    STRINGREP (s, sl, ' ', str: 50, stat.tmin: 10, stat.taver: 10);
    writeout;
  PROCEND display_statistic;

  PROCEDURE writeout;

    amp$put_next (ofid, ^s, sl, ba, status);
    check_status (status);
  PROCEND writeout;

{-------------------------------------------------------------------

  PROCEDURE create_new_segment;

    VAR
      pva: amt$segment_pointer;

    IF p <> NIL THEN
      pva.cell_pointer := p;
      IF scratch_files THEN
        mmp$delete_scratch_segment (pva, status);
      ELSE
        amp$close (file_id1, status);
        check_status (status);
        pfp$purge (pfn1, cyc, password, status);
      IFEND;
      check_status (status);
    IFEND;

    IF scratch_files THEN
      mmp$create_scratch_segment (amc$cell_pointer, mmc$as_random, pva, status);
    ELSE
      fsp$open_file ('$user.zzzscr1', amc$segment, NIL, NIL, NIL, NIL, NIL, file_id1, status);
      check_status (status);
      amp$get_segment_pointer (file_id1, amc$cell_pointer, pva, status);
    IFEND;

    check_status (status);
    pa := pva.cell_pointer;
    p := pva.cell_pointer;

  PROCEND create_new_segment;

  PROCEDURE create_new_segment2;

    VAR
      pva: amt$segment_pointer;

    IF p2 <> NIL THEN
      pva.cell_pointer := p2;
      IF scratch_files THEN
        mmp$delete_scratch_segment (pva, status);
      ELSE
        amp$close (file_id2, status);
        check_status (status);
        pfp$purge (pfn2, cyc, password, status);
      IFEND;
      check_status (status);
    IFEND;

    IF scratch_files THEN
      mmp$create_scratch_segment (amc$cell_pointer, mmc$as_random, pva, status);
    ELSE
      fsp$open_file ('$user.zzzscr2', amc$segment, NIL, NIL, NIL, NIL, NIL, file_id2, status);
      check_status (status);
      amp$get_segment_pointer (file_id2, amc$cell_pointer, pva, status);
    IFEND;

    check_status (status);
    p2a := pva.cell_pointer;
    p2 := pva.cell_pointer;

  PROCEND create_new_segment2;

{-----------------------------------------------------------------------

?? EJECT ??

  PROCEDURE [XDCL] mm_path_test2
    (    parameters: pmt$program_parameters);


    VAR
      ba: amt$file_byte_address,
      second_task_parameters: ^pmt$program_parameters, { Pointer to the parameter list passed to the task
      shared_segment_name: ^amt$local_file_name, { File name of the segment to be shared
      shared_segment_id: amt$file_identifier,
      shared_segment_pointer: amt$segment_pointer;

    second_task_parameters := ^parameters;

    RESET second_task_parameters;

{ Open and get a pointer to the segment that is to be shared by the two asynchronous tasks.

    NEXT shared_segment_name IN second_task_parameters;
    amp$open (shared_segment_name^, amc$segment, NIL, shared_segment_id, status);
    check_status (status);

    amp$get_segment_pointer (shared_segment_id, amc$cell_pointer, shared_segment_pointer, status);
    check_status (status);

    data_p := shared_segment_pointer.cell_pointer;
    data_p^.t2 := #FREE_RUNNING_CLOCK (0);

    REPEAT
      WHILE data_p^.func = run DO
        IF data_p^.t1 <> data_p^.t1_last THEN
          data_p^.t1_last := data_p^.t1;
          data_p^.t1_changed := #FREE_RUNNING_CLOCK (0);
        IFEND;
        data_p^.t2 := #FREE_RUNNING_CLOCK (0);
      WHILEND;
      pmp$wait (100, 100);
    UNTIL data_p^.func = quit;

    amp$close (shared_segment_id, status);

  PROCEND mm_path_test2;
?? EJECT ??

{-------------------------------------------------------------------

  PROCEDURE test_advisein
    (    op: (ai_new, ai_reclaim, ai_disk, ai_null));

    VAR
      t1,
      t2: integer,
      i,
      j,
      k: integer;

    reset_statistic (s1);
    FOR j := 1 TO 2 * scale DO
      create_new_segment;
      p^ := 1;
      mmp$advise_out (p, page_size, status);
      check_status (status);
      FOR i := 1 TO 50 DO
        mmp$write_modified_pages (p, page_size, osc$wait, status);
        mmp$advise_out (p, page_size, status);
        check_status (status);
        IF op = ai_new THEN
          mmp$set_segment_length (p, 1, 0, status);
        ELSEIF op = ai_disk THEN
          mmp$free_pages (p, page_size, osc$wait, status);
          check_status (status);
        ELSEIF op = ai_null THEN
          p^ := 6;
        IFEND;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$advise_in (p, page_size, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
        p^ := 6;
      FOREND
    FOREND;
    IF op = ai_new THEN
      display_statistic ('Advise In - new', 0, s1);
    ELSEIF op = ai_reclaim THEN
      display_statistic ('Advise In - reclaim', 0, s1);
    ELSEIF op = ai_disk THEN
      display_statistic ('Advise In - disk', 0, s1);
    ELSE
      display_statistic ('Advise In - null', 0, s1);
    IFEND;
  PROCEND test_advisein;

{-------------------------------------------------------------------

  PROCEDURE test_adviseout
    (    modified: boolean);

    VAR
      t1,
      t2: integer,
      i,
      j,
      k: integer;

    reset_statistic (s1);
    FOR j := 1 TO 2 * scale DO
      create_new_segment;
      p^ := 1;
      mmp$write_modified_pages (p, 1, osc$wait, status);
      check_status (status);
      FOR i := 1 TO 25 DO
        IF modified THEN
          p^ := 1;
        ELSE
          k := p^;
        IFEND;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$advise_out (p, 1, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND
    FOREND;
    IF modified THEN
      display_statistic ('Advise Out modified page', 0, s1);
    ELSE
      display_statistic ('Advise Out unmodified page', 0, s1);
    IFEND;
  PROCEND test_adviseout;

{-------------------------------------------------------------------

  PROCEDURE test_adviseoutin
    (    ondisk: boolean;
         modified: boolean);

    VAR
      t1,
      t2: integer,
      i,
      j,
      k: integer;

    reset_statistic (s1);
    FOR j := 1 TO 2 * scale DO
      create_new_segment;
      create_new_segment2;
      p^ := 1;
      mmp$write_modified_pages (p, page_size, osc$wait, status);
      check_status (status);
      FOR i := 1 TO 20 DO
        p2^ := 8;
        mmp$write_modified_pages (p2, page_size, osc$wait, status);
        mmp$advise_out (p2, page_size, status);
        check_status (status);
        IF ondisk THEN
          mmp$free_pages (p2, page_size, osc$wait, status);
          check_status (status);
        IFEND;
        #PURGE_BUFFER (4, p);
        k := p^;
        IF modified THEN
          p^ := 9;
        IFEND;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$advise_out_in (p, page_size, p2, page_size, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
        mmp$wait_io_completion (p, status);
      FOREND
    FOREND;
    IF ondisk THEN
      IF modified THEN
        display_statistic ('Advise Out In - mod/disk', 0, s1);
      ELSE
        display_statistic ('Advise Out In  - not mod/disk', 0, s1);
      IFEND;
    ELSE
      IF modified THEN
        display_statistic ('Advise Out In - mod/reclaim', 0, s1);
      ELSE
        display_statistic ('Advise Out In  - not mod/reclaim', 0, s1);
      IFEND;
    IFEND;
  PROCEND test_adviseoutin;

{-------------------------------------------------------------------

  PROCEDURE test_assign
    (    n: integer);

    VAR
      t1,
      t2: integer,
      i,
      j: integer;

    reset_statistic (s1);
    reset_statistic (s2);
    FOR j := 1 TO 2 * scale DO
      create_new_segment;
      p^ := 5;
      mmp$write_modified_pages (p, page_size, osc$wait, status);
      check_status (status);
      mmp$free_pages (p, page_size, osc$wait, status);
      check_status (status);
      FOR i := 1 TO 25 DO
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$assign_pages (p, page_size * n, TRUE, osc$wait, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$free_pages (p, page_size * n, osc$wait, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s2);
        IFEND;
      FOREND
    FOREND;
    STRINGREP (s, sl, 'Assign Pages ', n: 3, ' pages ');
    display_statistic (s (1, sl), 0, s1);
    STRINGREP (s, sl, ' Free Pages ', n: 3, ' pages ');
    display_statistic (s (1, sl), 0, s2);
  PROCEND test_assign;

{-------------------------------------------------------------------

  PROCEDURE test_assign_contiguous_memory
    (    n: integer);

    VAR
      attr: [STATIC] array [1 .. 1] of mmt$attribute_descriptor := [[mmc$kw_wired_segment, 1000000, FALSE]],
      pva: mmt$segment_pointer,
      t1,
      t2: integer,
      i,
      j,
      k: integer;

    reset_statistic (s1);
    FOR j := 1 TO 20 * scale DO
      mmp$create_segment (^attr, mmc$cell_pointer, 11, pva, status);
      check_status (status);
      FOR i := 1 TO 50 DO
        mmp$free_pages (pva.cell_pointer, n, osc$wait, status);
        check_status (status);
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$assign_contiguous_memory (pva.cell_pointer, n, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND;
      mmp$delete_segment (pva, 11, status);
      check_status (status);
    FOREND;

    STRINGREP (s, sl, 'Assign contiguous memory - ', n, ' bytes');
    display_statistic (s (1, sl), 0, s1);

  PROCEND test_assign_contiguous_memory;

{-------------------------------------------------------------------

  PROCEDURE test_change_stack_attribute;

    VAR

      t1,
      t2: integer,
      i,
      j: integer;

    reset_statistic (s1);
    FOR j := 1 TO 4 * scale DO
      create_new_segment;
      FOR i := 1 TO 200 DO
        p^ := 1;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$change_stack_attribute (TRUE, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND;
    FOREND;
    display_statistic ('Change stack attributes', 0, s1);
  PROCEND test_change_stack_attribute;

{-------------------------------------------------------------------

  PROCEDURE test_check_io_status
    (    active: boolean);

    VAR
      iostatus: mmt$io_status,
      iostatus_p: array [1 .. 1] of ^mmt$io_status,
      t1,
      t2: integer,
      index: integer,
      i,
      j: integer;

    reset_statistic (s1);
    iostatus_p [1] := ^iostatus;
    FOR j := 1 TO 2 * scale DO
      create_new_segment;
      p^ := 1;
      mmp$write_modified_pages (p, 1, osc$wait, status);
      check_status (status);
      FOR i := 1 TO 30 DO
        p^ := 1;
        mmp$write (p, 1, FALSE, ^iostatus, osc$nowait, status);
        check_status (status);
        IF NOT active THEN
          mmp$wait_io_completion (p, status);
          check_status (status);
        IFEND;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$check_io_status (iostatus_p, 0, index, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND;
    FOREND;
    IF active THEN
      display_statistic ('Check IO status - active', 0, s1);
    ELSE
      display_statistic ('Check IO status - not active', 0, s1);
    IFEND;
  PROCEND test_check_io_status;

{-------------------------------------------------------------------

  PROCEDURE test_conditional_free
    (    assigned: boolean);

    VAR
      t1,
      t2: integer,
      i,
      j,
      k: integer;

    reset_statistic (s1);
    FOR j := 1 TO 5 * scale DO
      create_new_segment;
      p^ := 1;
      mmp$write_modified_pages (p, 1, osc$wait, status);
      check_status (status);
      mmp$free_pages (p, page_size, osc$wait, status);
      check_status (status);
      FOR i := 1 TO 500 DO
        IF assigned THEN
          p^ := 6;
        IFEND;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$conditional_free (p, page_size, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND
    FOREND;
    IF assigned THEN
      display_statistic ('Conditional Free - page', 0, s1);
    ELSE
      display_statistic ('Conditional Free - no page', 0, s1);
    IFEND;
  PROCEND test_conditional_free;

{-------------------------------------------------------------------

  PROCEDURE test_copy
    (    pages: 1 .. 10;
         reclaim: boolean);

    VAR

      t1,
      t2: integer,
      i,
      j,
      k: integer;

    reset_statistic (s1);
    FOR j := 1 TO 4 * scale DO
      create_new_segment;
      create_new_segment2;
      p^ := 1;
      p2^ := 1;
      mmp$write_modified_pages (p, 1, osc$wait, status);
      check_status (status);
      mmp$write_modified_pages (p2, 1, osc$wait, status);
      check_status (status);
      FOR i := 1 TO 20 DO
        FOR k := 0 TO pages - 1 DO
          pa^ [k * page_size] := 1;
          p2a^ [k * page_size] := 1;
        FOREND;
        IF reclaim THEN
          mmp$write_modified_pages (p2, 10000000, osc$wait, status);
          check_status (status);
          mmp$advise_out (p2, 10000000, status);
          check_status (status);
        IFEND;
        t1 := #FREE_RUNNING_CLOCK (0);
        i#move (p, p2, pages * page_size);
        t2 := #FREE_RUNNING_CLOCK (0);
        IF i > 2 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND;
    FOREND;
    IF reclaim THEN
      ss := 'reclaim dest';
    ELSE
      ss := 'no dest pf';
    IFEND;
    STRINGREP (s, sl, 'Copy ', pages: 3, ' pages - ', ss (1, 12));
    display_statistic (s (1, sl), 0, s1);
  PROCEND test_copy;

{-------------------------------------------------------------------

  PROCEDURE test_create_scratch_segment;

    VAR

      t1,
      t2: integer,
      pva: amt$segment_pointer,
      p: ^integer,
      i: integer;

    reset_statistic (s1);
    reset_statistic (s2);
    FOR i := 1 TO 100 * scale DO
      t1 := #FREE_RUNNING_CLOCK (0);
      mmp$create_scratch_segment (amc$cell_pointer, mmc$as_random, pva, status);
      t2 := #FREE_RUNNING_CLOCK (0);
      check_status (status);
      IF i > 4 THEN
        record_statistic (t1, t2, s1);
      IFEND;
      p := pva.cell_pointer;
      p^ := 6;
      t1 := #FREE_RUNNING_CLOCK (0);
      mmp$delete_scratch_segment (pva, status);
      t2 := #FREE_RUNNING_CLOCK (0);
      check_status (status);
      IF i > 4 THEN
        record_statistic (t1, t2, s2);
      IFEND;
    FOREND;
    display_statistic ('Create scratch segment', 0, s1);
    display_statistic (' Delete scratch segment', 0, s2);
  PROCEND test_create_scratch_segment;

{-------------------------------------------------------------------

  PROCEDURE test_create_segment;

    VAR
      attr: [STATIC] array [1 .. 3] of mmt$attribute_descriptor :=
            [[mmc$kw_ring_numbers, 11, 11], [mmc$kw_preset_value, pmc$initialize_to_zero],
            [mmc$kw_max_segment_length, 1000000]],
      t1,
      t2: integer,
      p: ^integer,
      pva: mmt$segment_pointer,
      i: integer;

    reset_statistic (s1);
    reset_statistic (s2);
    FOR i := 1 TO 100 * scale DO
      t1 := #FREE_RUNNING_CLOCK (0);
      mmp$create_segment (^attr, mmc$cell_pointer, 11, pva, status);
      t2 := #FREE_RUNNING_CLOCK (0);
      check_status (status);
      IF i > 4 THEN
        record_statistic (t1, t2, s1);
      IFEND;
      p := pva.cell_pointer;
      p^ := 6;
      t1 := #FREE_RUNNING_CLOCK (0);
      mmp$delete_segment (pva, 1, status);
      t2 := #FREE_RUNNING_CLOCK (0);
      check_status (status);
      IF i > 4 THEN
        record_statistic (t1, t2, s2);
      IFEND;
    FOREND;
    display_statistic ('Create segment', 0, s1);
    display_statistic (' Delete segment', 0, s2);
  PROCEND test_create_segment;

{-------------------------------------------------------------------

  PROCEDURE test_create_shadow_segment;

    VAR
      ch_p: ^char,
      t1,
      t2: integer,
      pva: amt$segment_pointer,
      pva2: amt$segment_pointer,
      pva3: mmt$segment_pointer,
      i: integer;

    reset_statistic (s1);
    reset_statistic (s2);
    mmp$create_scratch_segment (amc$cell_pointer, mmc$as_random, pva, status);
    check_status (status);
    ch_p := pva.cell_pointer;
    ch_p^ := 'k';
    mmp$write_modified_pages (ch_p, 1, osc$wait, status);
    check_status (status);
    IF NOT skip_shadow_tests THEN
      FOR i := 1 TO 100 * scale DO
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$create_shadow_segment (pva.cell_pointer, 0, 1638400, amc$cell_pointer, pva2, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
        ch_p := pva2.cell_pointer;
        ch_p^ := 'k';
        pva3.cell_pointer := pva2.cell_pointer;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$delete_segment (pva3, 1, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s2);
        IFEND;
      FOREND;
    IFEND;
    display_statistic ('Create shadow segment', 0, s1);
    display_statistic (' Delete shadow segment', 0, s2);
  PROCEND test_create_shadow_segment;

{-------------------------------------------------------------------

  PROCEDURE test_create_user_segment;

    VAR

      t1,
      t2: integer,
      attr: [STATIC] array [1 .. 2] of mmt$user_attribute_descriptor :=
            [[mmc$ua_ring_numbers, 11, 11], [mmc$ua_max_segment_length, 1000000]],
      p: ^integer,
      pva: amt$segment_pointer,
      i: integer;

    reset_statistic (s1);
    reset_statistic (s2);
    FOR i := 1 TO 100 * scale DO
      t1 := #FREE_RUNNING_CLOCK (0);
      mmp$create_user_segment (^attr, amc$cell_pointer, mmc$as_random, pva, status);
      t2 := #FREE_RUNNING_CLOCK (0);
      check_status (status);
      IF i > 4 THEN
        record_statistic (t1, t2, s1);
      IFEND;
      p := pva.cell_pointer;
      p^ := 6;
      t1 := #FREE_RUNNING_CLOCK (0);
      mmp$delete_user_segment (pva, status);
      t2 := #FREE_RUNNING_CLOCK (0);
      check_status (status);
      IF i > 4 THEN
        record_statistic (t1, t2, s2);
      IFEND;
    FOREND;
    display_statistic ('Create user segment', 0, s1);
    display_statistic (' Delete user segment', 0, s2);
  PROCEND test_create_user_segment;

{-------------------------------------------------------------------

  PROCEDURE test_delete_scratch_segment
    (    op: (noasid, nopages, pages, diskfile));

    VAR

      t1,
      t2: integer,
      pva: amt$segment_pointer,
      p: ^integer,
      i: integer;

    reset_statistic (s1);
    FOR i := 1 TO 100 * scale DO
      mmp$create_scratch_segment (amc$cell_pointer, mmc$as_random, pva, status);
      IF op <> noasid THEN
        p := pva.cell_pointer;
        p^ := 6;
      IFEND;
      IF op = nopages THEN
        mmp$free_pages (p, 1000000, osc$wait, status);
        check_status (status);
      ELSEIF op = diskfile THEN
        mmp$write_modified_pages (p, 1000000, osc$wait, status);
        check_status (status);
      IFEND;
      t1 := #FREE_RUNNING_CLOCK (0);
      mmp$delete_scratch_segment (pva, status);
      t2 := #FREE_RUNNING_CLOCK (0);
      check_status (status);
      IF i > 4 THEN
        record_statistic (t1, t2, s1);
      IFEND;
    FOREND;
    IF op = noasid THEN
      display_statistic ('Delete segment - never referenced', 0, s1);
    ELSEIF op = nopages THEN
      display_statistic ('Delete segment - no pages', 0, s1);
    ELSEIF op = pages THEN
      display_statistic ('Delete segment - 1 page, no disk file', 0, s1);
    ELSE
      display_statistic ('Delete segment - 1 page, disk file', 0, s1);
    IFEND;
  PROCEND test_delete_scratch_segment;

{-------------------------------------------------------------------

  PROCEDURE test_fetch_pva_unwritten_pages;

    VAR
      arr: array [1 .. 100] of ^cell,
      overflow: boolean,
      t1,
      t2: integer,
      i,
      j: integer;

    reset_statistic (s1);
    FOR j := 1 TO 4 * scale DO
      create_new_segment;
      FOR i := 1 TO 200 DO
        p^ := 1;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$fetch_pva_unwritten_pages (p, p, arr, overflow, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND;
    FOREND;
    display_statistic ('Fetch PVA unwritten pages', 0, s1);
  PROCEND test_fetch_pva_unwritten_pages;

{-------------------------------------------------------------------

  PROCEDURE test_fetch_segment_attributes;

    VAR
      attr: [STATIC] array [1 .. 1] of mmt$attribute_descriptor := [[mmc$kw_max_segment_length, 1000000]],
      t1,
      t2: integer,
      i,
      j,
      k: integer;

    reset_statistic (s1);
    FOR j := 1 TO 2 * scale DO
      create_new_segment;
      FOR i := 1 TO 250 DO
        p^ := 1;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$fetch_segment_attributes (p, attr, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND
    FOREND;
    display_statistic ('Store segment attributes', 0, s1);
  PROCEND test_fetch_segment_attributes;

{-------------------------------------------------------------------

  PROCEDURE test_get_segment_length
    (    fuzzy: boolean);

    VAR
      t1,
      t2: integer,
      length: ost$segment_length,
      i,
      k: integer;

    reset_statistic (s1);
    FOR i := 1 TO 20 * scale DO
      create_new_segment;
      mmp$set_access_selections (p, mmc$as_sequential, status);
      check_status (status);
      IF fuzzy THEN
        FOR k := 0 TO 10 DO
          pa^ [k * page_size] := 6;
        FOREND;
      IFEND;
      t1 := #FREE_RUNNING_CLOCK (0);
      mmp$get_segment_length (p, 1, length, status);
      t2 := #FREE_RUNNING_CLOCK (0);
      check_status (status);
      IF i > 4 THEN
        record_statistic (t1, t2, s1);
      IFEND;
    FOREND;
    IF fuzzy THEN
      display_statistic ('Get segment length - fuzzy EOI', 0, s1);
    ELSE
      display_statistic ('Get segment length - exact EOI', 0, s1);
    IFEND;
  PROCEND test_get_segment_length;

{-------------------------------------------------------------------

  PROCEDURE test_initiate_debug_shadowing;

    VAR
      attr: [STATIC] array [1 .. 1] of mmt$attribute_descriptor :=
            [[mmc$kw_segment_access_control, [FALSE, osc$non_privileged, osc$read_uncontrolled,
            osc$non_writable]]],
      pva: amt$segment_pointer,
      t1,
      t2: integer,
      i,
      k: integer;

    reset_statistic (s1);
    reset_statistic (s2);
    FOR i := 1 TO 20 * scale DO
      create_new_segment;
      p^ := 1;
      mmp$store_segment_attributes (p, 1, attr, status);
      check_status (status);
      t1 := #FREE_RUNNING_CLOCK (0);
      mmp$initiate_debug_shadowing (p, status);
      t2 := #FREE_RUNNING_CLOCK (0);
      check_status (status);
      IF i > 4 THEN
        record_statistic (t1, t2, s1);
      IFEND;
      pva.cell_pointer := p;
      p := NIL;
      t1 := #FREE_RUNNING_CLOCK (0);
      IF scratch_files THEN
        mmp$delete_scratch_segment (pva, status);
      ELSE
        amp$close (file_id1, status);
        check_status (status);
        pfp$purge (pfn1, cyc, password, status);
      IFEND;
      t2 := #FREE_RUNNING_CLOCK (0);
      check_status (status);
      IF i > 4 THEN
        record_statistic (t1, t2, s2);
      IFEND;
    FOREND;
    display_statistic ('Initiate debug shadowing', 0, s1);
    display_statistic ('  Delete segment', 0, s2);
  PROCEND test_initiate_debug_shadowing;

{-------------------------------------------------------------------

  PROCEDURE test_initiate_shadowing;

    VAR
      t1,
      t2: integer,
      i,
      j,
      k: integer;

    reset_statistic (s1);
    reset_statistic (s2);
    IF NOT skip_shadow_tests THEN
      FOR j := 1 TO 2 * scale DO
        create_new_segment;
        FOR i := 1 TO 100 DO
          p^ := 1;
          mmp$write_modified_pages (p, page_size, osc$wait, status);
          check_status (status);
          t1 := #FREE_RUNNING_CLOCK (0);
          mmp$initiate_shadowing (p, status);
          t2 := #FREE_RUNNING_CLOCK (0);
          check_status (status);
          IF i > 4 THEN
            record_statistic (t1, t2, s1);
          IFEND;
          p^ := 1;
          mmp$write_modified_pages (p, page_size, osc$wait, status);
          check_status (status);
          t1 := #FREE_RUNNING_CLOCK (0);
          mmp$terminate_shadowing (p, TRUE, status);
          t2 := #FREE_RUNNING_CLOCK (0);
          check_status (status);
          IF i > 4 THEN
            record_statistic (t1, t2, s2);
          IFEND;
        FOREND;
      FOREND;
    IFEND;
    display_statistic ('Initiate shadowing', 0, s1);
    display_statistic (' Terminate shadowing', 0, s2);
  PROCEND test_initiate_shadowing;

{-------------------------------------------------------------------

  PROCEDURE test_lock_pages;

    VAR

      t1,
      t2: integer,
      i,
      j: integer;

    reset_statistic (s1);
    reset_statistic (s2);
    FOR j := 1 TO 4 * scale DO
      create_new_segment;
      FOR i := 1 TO 50 DO
        p^ := 1;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$lock_pages (p, page_size, status);
        ;
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$unlock_pages (p, page_size, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s2);
        IFEND;
      FOREND;
    FOREND;
    display_statistic ('Lock pages', 0, s1);
    display_statistic (' Unock pages', 0, s2);
  PROCEND test_lock_pages;

{-------------------------------------------------------------------

  PROCEDURE test_lock_segment;

    VAR

      t1,
      t2: integer,
      i,
      j: integer;

    reset_statistic (s1);
    reset_statistic (s2);
    FOR j := 1 TO 4 * scale DO
      create_new_segment;
      FOR i := 1 TO 50 DO
        p^ := 1;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$lock_segment (p, mmc$lus_lock_for_read, osc$wait, status);
        ;
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$unlock_segment (p, mmc$lus_none, osc$wait, status);
        ;
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s2);
        IFEND;
      FOREND;
    FOREND;
    display_statistic ('Lock_segment', 0, s1);
    display_statistic (' Unlock_segment', 0, s2);
  PROCEND test_lock_segment;

{-------------------------------------------------------------------

  PROCEDURE test_move
    (    pages: 1 .. 10);

    VAR

      t1,
      t2: integer,
      i,
      j,
      k: integer,
      move_count: mmt$move_pages_page_count;

    reset_statistic (s1);
    FOR j := 1 TO 2 * scale DO
      create_new_segment;
      create_new_segment2;
      p^ := 1;
      p2^ := 1;
      mmp$write_modified_pages (p, 1, osc$wait, status);
      check_status (status);
      mmp$write_modified_pages (p2, 1, osc$wait, status);
      check_status (status);
      FOR i := 1 TO 15 DO
        FOR k := 0 TO pages - 1 DO
          pa^ [k * page_size] := 1;
        FOREND;
        mmp$free_pages (p2, 1000000, osc$wait, status);
        check_status (status);
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$move_pages (p, p2, pages * page_size, mmc$mp_set_modified, FALSE, move_count, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 2 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND;
    FOREND;
    STRINGREP (s, sl, 'Move ', pages: 3, 'pages');
    display_statistic (s (1, sl), 0, s1);
  PROCEND test_move;

{-------------------------------------------------------------------

  PROCEDURE test_null;

    VAR
      t1,
      t2: integer,
      rb: tmt$rb_ready_task,
      i: integer;

    reset_statistic (s1);
    rb.reqcode := syc$rc_ready_task;
    rb.task_id.index := 0;
    FOR i := 1 TO 800 * scale DO
      t1 := #FREE_RUNNING_CLOCK (0);
      i#call_monitor (#LOC (rb), #SIZE (rb));
      t2 := #FREE_RUNNING_CLOCK (0);
      IF i > 4 THEN
        record_statistic (t1, t2, s1);
      IFEND;
    FOREND;
    display_statistic ('Null monitor request', 0, s1);
  PROCEND test_null;

{-------------------------------------------------------------------

  PROCEDURE test_pf_disk;

    VAR
      i: integer;

    reset_statistic (s1);
    set_task2_function (run);
    FOR i := 1 TO 50 * scale DO
      create_new_segment;
      data_p^.page := 1;
      mmp$write_modified_pages (^data_p^.page, 1, osc$wait, status);
      check_status (status);
      mmp$free_pages (^data_p^.page, page_size, osc$wait, status);
      check_status (status);
      data_p^.t1 := #FREE_RUNNING_CLOCK (0);
      data_p^.page := 4;
      check_status (status);
      IF i > 4 THEN
        record_statistic (data_p^.t1_last, data_p^.t1_changed, s1);
      IFEND;
    FOREND;
    set_task2_function (idle);
    display_statistic ('Page fault for page on disk + taskswitch', 0, s1);
  PROCEND test_pf_disk;


{-------------------------------------------------------------------

  PROCEDURE test_pf_new_file_alloc;

    VAR

      t1,
      t2: integer,
      i,
      j: integer;

    reset_statistic (s1);
    FOR i := 1 TO 40 * scale DO
      create_new_segment;
      pa^ [0] := 1;
      mmp$write_modified_pages (p, 1, osc$wait, status);
      check_status (status);
      t1 := #FREE_RUNNING_CLOCK (0);
      j := pa^ [16384];
      t2 := #FREE_RUNNING_CLOCK (0);
      IF i > 4 THEN
        record_statistic (t1, t2, s1);
      IFEND;
    FOREND;
    display_statistic ('Page fault new page, file, space not allocated', 0, s1);
  PROCEND test_pf_new_file_alloc;

{-------------------------------------------------------------------

  PROCEDURE test_pf_new_file_no_alloc;

    VAR

      t1,
      t2: integer,
      i,
      k: integer;

    reset_statistic (s1);
    FOR i := 1 TO 40 * scale DO
      create_new_segment;
      pa^ [0] := 1;
      mmp$write_modified_pages (p, 1, osc$wait, status);
      check_status (status);
      t1 := #FREE_RUNNING_CLOCK (0);
      k := pa^ [8192];
      t2 := #FREE_RUNNING_CLOCK (0);
      IF i > 4 THEN
        record_statistic (t1, t2, s1);
      IFEND;
    FOREND;
    display_statistic ('Page fault new page, file, space already allocated', 0, s1);
  PROCEND test_pf_new_file_no_alloc;

{-------------------------------------------------------------------

  PROCEDURE test_pf_new_no_file;

    VAR

      t1,
      t2: integer,
      i,
      j,
      k: integer;

    reset_statistic (s1);
    FOR j := 1 TO 10 * scale DO
      create_new_segment;
      FOR i := 1 TO 50 DO
        t1 := #FREE_RUNNING_CLOCK (0);
        k := p^;
        t2 := #FREE_RUNNING_CLOCK (0);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
        mmp$free_pages (p, page_size, osc$wait, status);
      FOREND;
    FOREND;
    display_statistic ('Page fault new page, no file', 0, s1);
  PROCEND test_pf_new_no_file;

{-------------------------------------------------------------------

  PROCEDURE test_pf_reclaim;

    VAR

      t1,
      t2: integer,
      i,
      j: integer;

    reset_statistic (s1);
    FOR j := 1 TO 4 * scale DO
      create_new_segment;
      FOR i := 1 TO 50 DO
        p^ := 1;
        mmp$write_modified_pages (p, 1, osc$wait, status);
        check_status (status);
        mmp$advise_out (p, 16384, status);
        check_status (status);
        t1 := #FREE_RUNNING_CLOCK (0);
        p^ := 4;
        t2 := #FREE_RUNNING_CLOCK (0);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND;
    FOREND;
    display_statistic ('Page fault, reclaim page from available queue', 0, s1);
  PROCEND test_pf_reclaim;

{-------------------------------------------------------------------

  PROCEDURE test_preallocate_file_space
    (    n: integer);

    VAR
      pva: amt$segment_pointer,
      t1,
      t2: integer,
      i,
      k: integer;

    reset_statistic (s1);
    FOR i := 1 TO 2 DO {!!! no scale because its too slow}
      create_new_segment;
      pa^ [0] := 1;
      pva.kind := amc$cell_pointer;
      pva.cell_pointer := p;
      mmp$write_modified_pages (p, 1, osc$wait, status);
      check_status (status);
      t1 := #FREE_RUNNING_CLOCK (0);
      mmp$preallocate_file_space (pva, n + 16384, TRUE, status);
      t2 := #FREE_RUNNING_CLOCK (0);
      check_status (status);
      IF i > 1 THEN
        record_statistic (t1, t2, s1);
      IFEND;
    FOREND;
    STRINGREP (s, sl, 'Preallocate file space - ', n, ' bytes');
    display_statistic (s (1, sl), 0, s1);
  PROCEND test_preallocate_file_space;

{-------------------------------------------------------------------

  PROCEDURE test_pioc;

    VAR
      t0,
      t1,
      t2,
      t3: integer,
      i,
      j,
      k,
      rma: integer;

    create_new_segment;
    reset_statistic (s1);
    p^ := 1;
    mmp$write_modified_pages (p, 1, osc$wait, status);
    check_status (status);
    i := 0;
    WHILE i < 20 * scale DO
      mmp$free_pages (p, page_size, osc$wait, status);
      check_status (status);
      t0 := #FREE_RUNNING_CLOCK (0);
      mmp$advise_in (p, 1, status);
      check_status (status);
      REPEAT
        t3 := #FREE_RUNNING_CLOCK (0);
        i#real_memory_address (p, rma);
        IF rma < 0 THEN
          t1 := t3;
        IFEND;
      UNTIL (rma > 0) OR ((t1 - t0) > 5000000);
      t2 := #FREE_RUNNING_CLOCK (0);
      IF (t2 - t1 > 60) THEN
        IF i > 5 THEN
          record_statistic (t1, t2, s1);
        IFEND;
        i := i + 1;
      IFEND;
    WHILEND;

    display_statistic ('Process disk IO completion', 0, s1);

  PROCEND test_pioc;

{-------------------------------------------------------------------

  PROCEDURE test_read;

    VAR
      iostatus: mmt$io_status,
      t1,
      t2: integer,
      i,
      j: integer;

    reset_statistic (s1);
    FOR j := 1 TO 2 * scale DO
      create_new_segment;
      p^ := 1;
      mmp$write_modified_pages (p, 1, osc$wait, status);
      check_status (status);
      FOR i := 1 TO 100 DO
        mmp$free_pages (p, page_size, osc$wait, status);
        check_status (status);
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$read (p, 1, ^iostatus, osc$nowait, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        mmp$wait_io_completion (p, status);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND;
    FOREND;
    display_statistic ('Read', 0, s1);
  PROCEND test_read;

{-------------------------------------------------------------------

  PROCEDURE test_set_access_selections;

    VAR
      arr: array [1 .. 100] of ^cell,
      overflow: boolean,
      t1,
      t2: integer,
      i,
      j: integer;

    reset_statistic (s1);
    FOR j := 1 TO 8 * scale DO
      create_new_segment;
      FOR i := 1 TO 200 DO
        p^ := 1;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$set_access_selections (p, mmc$as_random, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND;
    FOREND;
    display_statistic ('Set access selections', 0, s1);
  PROCEND test_set_access_selections;

{-------------------------------------------------------------------

  PROCEDURE test_set_segment_length;

    VAR
      t1,
      t2: integer,
      i,
      j,
      k: integer;

    reset_statistic (s1);
    FOR j := 1 TO 2 * scale DO
      create_new_segment;
      FOR i := 1 TO 25 DO
        p^ := 1;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$set_segment_length (p, 1, 1600, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        mmp$free_pages (p, page_size, osc$wait, status);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND
    FOREND;
    display_statistic ('Set segment length', 0, s1);
  PROCEND test_set_segment_length;

{-------------------------------------------------------------------

  PROCEDURE test_store_segment_attributes;

    VAR
      attr: [STATIC] array [1 .. 1] of mmt$attribute_descriptor := [[mmc$kw_max_segment_length, 1000000]],
      t1,
      t2: integer,
      i,
      j,
      k: integer;

    reset_statistic (s1);
    FOR j := 1 TO 2 * scale DO
      create_new_segment;
      FOR i := 1 TO 250 DO
        p^ := 1;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$store_segment_attributes (p, 1, attr, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND
    FOREND;
    display_statistic ('Store segment attributes', 0, s1);
  PROCEND test_store_segment_attributes;

{-------------------------------------------------------------------

  PROCEDURE test_task_switch;

    VAR

      last_t1_changed: integer,
      i: integer;

    reset_statistic (s1);
    set_task2_function (run);
    FOR i := 1 TO 20 * scale DO
      last_t1_changed := data_p^.t1_changed;
      WHILE data_p^.t1_changed = last_t1_changed DO
        #SPOIL (data_p^);
        data_p^.t1 := #FREE_RUNNING_CLOCK (0);
      WHILEND;
      IF i > 10 THEN
        record_statistic (data_p^.t1_last, data_p^.t1_changed, s1);
      IFEND;
    FOREND;
    set_task2_function (idle);
    display_statistic ('Task switch (caused by SIT) ', 0, s1);
    task_switch_time := s1.taver
  PROCEND test_task_switch;


{-------------------------------------------------------------------

  PROCEDURE test_verify_access;

    VAR
      bool: boolean,
      cp: ^cell,
      t1,
      t2: integer,
      i,
      j: integer;

    reset_statistic (s1);
    FOR j := 1 TO 4 * scale DO
      create_new_segment;
      FOR i := 1 TO 200 DO
        p^ := 1;
        cp := p;
        t1 := #FREE_RUNNING_CLOCK (0);
        bool := mmp$verify_access (^cp, mmc$va_read);
        t2 := #FREE_RUNNING_CLOCK (0);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND;
    FOREND;
    display_statistic ('Verify access', 0, s1);
  PROCEND test_verify_access;


{-------------------------------------------------------------------

  PROCEDURE test_wait_io_completion;

    VAR
      t1,
      t2: integer,
      i,
      j,
      k: integer;

    reset_statistic (s1);
    FOR j := 1 TO 2 * scale DO
      create_new_segment;
      p^ := 1;
      mmp$write_modified_pages (p, 1, osc$wait, status);
      check_status (status);
      FOR i := 1 TO 25 DO
        p^ := 1;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$wait_io_completion (p, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND
    FOREND;
    display_statistic ('Wait IO completion - no IO active', 0, s1);
  PROCEND test_wait_io_completion;

{-------------------------------------------------------------------

  PROCEDURE test_write
    (    remove: boolean);

    VAR
      iostatus: mmt$io_status,
      t1,
      t2: integer,
      i,
      j: integer;

    reset_statistic (s1);
    FOR j := 1 TO 2 * scale DO
      create_new_segment;
      p^ := 1;
      mmp$write_modified_pages (p, 1, osc$wait, status);
      check_status (status);
      FOR i := 1 TO 100 DO
        p^ := 1;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$write (p, 1, remove, ^iostatus, osc$nowait, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        mmp$wait_io_completion (p, status);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND;
    FOREND;
    IF remove THEN
      display_statistic ('Write - remove page', 0, s1);
    ELSE
      display_statistic ('Write - dont remove page', 0, s1);
    IFEND;
  PROCEND test_write;

{-------------------------------------------------------------------

  PROCEDURE test_write_mod_pages
    (    nwrite,
         nmod: integer);

    VAR
      len: integer,
      t1,
      t2: integer,
      i,
      j,
      k: integer,
      id: string (50);

    reset_statistic (s1);
    len := page_size * nwrite;
    FOR j := 1 TO 2 * scale DO
      create_new_segment;
      FOR i := 1 TO 30 DO
        FOR k := 0 TO nmod - 1 DO
          pa^ [k * page_size] := 1;
        FOREND;
        t1 := #FREE_RUNNING_CLOCK (0);
        mmp$write_modified_pages (p, len, osc$nowait, status);
        t2 := #FREE_RUNNING_CLOCK (0);
        check_status (status);
        mmp$write_modified_pages (p, len, osc$wait, status);
        check_status (status);
        IF i > 4 THEN
          record_statistic (t1, t2, s1);
        IFEND;
      FOREND;
    FOREND;
    STRINGREP (id, sl, 'Write mod pages ', nwrite, ' pages, ', nmod, ' actually modified');
    display_statistic (id (1, sl), 0, s1);
  PROCEND test_write_mod_pages;

{-------------------------------------------------------------------

  PROCEDURE test_write_mod_pages_no_file;

    VAR
      t1,
      t2: integer,
      i,
      k: integer;

    reset_statistic (s1);
    FOR i := 1 TO 40 * scale DO
      create_new_segment;
      pa^ [0] := 1;
      t1 := #FREE_RUNNING_CLOCK (0);
      mmp$write_modified_pages (p, 1, osc$nowait, status);
      t2 := #FREE_RUNNING_CLOCK (0);
      mmp$write_modified_pages (p, 1, osc$wait, status);
      check_status (status);
      IF i > 4 THEN
        record_statistic (t1, t2, s1);
      IFEND;
    FOREND;
    display_statistic ('Write mod pages, assign file to trans seg', 0, s1);
  PROCEND test_write_mod_pages_no_file;

?? EJECT ??

  PROGRAM [XDCL, #GATE] mm_path_test
    (    parameters: pmt$program_parameters);

*copyc mmd$pdt_mm_path_test

    VAR
      output_a_segment: [STATIC] amt$local_file_name := 'OUT',
      key_p: ^clt$data_value,
      key: ost$name,
      shared_segment_id: amt$file_identifier,
      shared_segment_pointer: amt$segment_pointer,
      shared_segment_name: [STATIC] amt$local_file_name := 'READY_SEGMENT',
      second_task_id: pmt$task_id,
      second_task_status: pmt$task_status,
      i: integer;

    clp$evaluate_parameters (parameters, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;



{ Create a segment used to store information on each task's access.

    amp$open (shared_segment_name, amc$segment, NIL, shared_segment_id, status);
    check_status (status);


    amp$get_segment_pointer (shared_segment_id, amc$cell_pointer, shared_segment_pointer, status);
    check_status (status);

    fsp$open_file (pvt [p$output].value^.file_value^, amc$record, NIL, NIL, NIL, NIL, NIL, ofid, status);
    check_status (status);
    data_p := shared_segment_pointer.cell_pointer;

    data_p^.func := idle;
    execute_task_2 (shared_segment_name, second_task_id, second_task_status, status);
    check_status (status);

    page_size := 512 * (128 - #READ_REGISTER (osc$pr_page_size_mask));
    STRINGREP (s, sl, ' Page Size = ', page_size);
    writeout;
    s := ' TEST                                                  Min us   Aver us';
    sl := 71;
    writeout;

    key_p := pvt [p$name].value;
    scale := pvt [p$scale].value^.integer_value.value;
    skip_shadow_tests := pvt [p$skip_shadow_tests].value^.boolean_value.value;
    scratch_files := pvt [p$file_type].value^.keyword_value = 'TRANSIENT';
    WHILE key_p <> NIL DO
      key := key_p^.element_value^.keyword_value;
      IF (key = 'ALL') OR (key = 'ADVISE_IN') THEN
        test_advisein (ai_null);
        test_advisein (ai_reclaim);
        test_advisein (ai_new);
        test_advisein (ai_disk);
      IFEND;
      IF (key = 'ALL') OR (key = 'ADVISE_OUT') THEN
        test_adviseout (FALSE);
        test_adviseout (TRUE);
      IFEND;
      IF (key = 'ALL') OR (key = 'ADVISE_OUT_IN') THEN
        test_adviseoutin (FALSE, FALSE);
        test_adviseoutin (TRUE, FALSE);
        test_adviseoutin (FALSE, TRUE);
        test_adviseoutin (TRUE, TRUE);
      IFEND;
      IF (key = 'ALL') OR (key = 'ASSIGN_CONTIGUOUS_MEMORY') THEN
        test_assign_contiguous_memory (16384);
        test_assign_contiguous_memory (65536);
      IFEND;
      IF (key = 'ALL') OR (key = 'ASSIGN_PAGES') THEN
        test_assign (1);
        test_assign (2);
        test_assign (4);
        test_assign (8);
      IFEND;
      IF (key = 'ALL') OR (key = 'CHANGE_STACK_ATTRIBUTE') THEN
        test_change_stack_attribute;
      IFEND;
      IF (key = 'ALL') OR (key = 'CHECK_IO_STATUS') THEN
        test_check_io_status (FALSE);
        test_check_io_status (TRUE);
      IFEND;
      IF (key = 'ALL') OR (key = 'CONDITIONAL_FREE') THEN
        test_conditional_free (FALSE);
        test_conditional_free (TRUE);
      IFEND;
      IF (key = 'ALL') OR (key = 'COPY_PAGES') THEN
        test_copy (1, FALSE);
        test_copy (2, FALSE);
        test_copy (4, FALSE);
        test_copy (1, TRUE);
        test_copy (2, TRUE);
        test_copy (4, TRUE);
      IFEND;
      IF (key = 'ALL') OR (key = 'CREATE_SCRATCH_SEGMENT') THEN
        test_create_scratch_segment;
      IFEND;
      IF (key = 'ALL') OR (key = 'CREATE_SEGMENT') THEN
        test_create_segment;
      IFEND;
      IF (key = 'ALL') OR (key = 'CREATE_SHADOW_SEGMENT') THEN
        test_create_shadow_segment;
      IFEND;
      IF (key = 'ALL') OR (key = 'CREATE_USER_SEGMENT') THEN
        test_create_user_segment;
      IFEND;
      IF (key = 'ALL') OR (key = 'DELETE_SEGMENT') THEN
        test_delete_scratch_segment (noasid);
        test_delete_scratch_segment (nopages);
        test_delete_scratch_segment (pages);
        test_delete_scratch_segment (diskfile);
      IFEND;
      IF (key = 'ALL') OR (key = 'FETCH_PVA_UNWRITTEN_PAGES') THEN
        test_fetch_pva_unwritten_pages;
      IFEND;
      IF (key = 'ALL') OR (key = 'FETCH_SEGMENT_ATTRIBUTES') THEN
        test_fetch_segment_attributes;
      IFEND;
      IF (key = 'ALL') OR (key = 'GET_SEGMENT_LENGTH') THEN
        test_get_segment_length (FALSE);
        test_get_segment_length (TRUE);
      IFEND;
      IF (key = 'ALL') OR (key = 'INITIATE_DEBUG_SHADOWING') THEN
        test_initiate_debug_shadowing;
      IFEND;
      IF (key = 'ALL') OR (key = 'INITIATE_SHADOWING') THEN
        test_initiate_shadowing;
      IFEND;
      IF (key = 'ALL') OR (key = 'LOCK_PAGES') THEN
        test_lock_pages;
      IFEND;
      IF (key = 'ALL') OR (key = 'LOCK_SEGMENT') THEN
        test_lock_segment;
      IFEND;
      IF (key = 'ALL') OR (key = 'MOVE_PAGES') THEN
        test_move (1);
        test_move (2);
        test_move (4);
      IFEND;
      IF (key = 'ALL') OR (key = 'NULL_MONITOR_REQUEST') THEN
        test_null;
      IFEND;
      IF (key = 'ALL') OR (key = 'PF_DISK') THEN
        test_pf_disk;
      IFEND;
      IF (key = 'ALL') OR (key = 'PF_NEW_FILE_ALLOC') THEN
        test_pf_new_file_alloc;
      IFEND;
      IF (key = 'ALL') OR (key = 'PF_NEW_FILE_NO_ALLOC') THEN
        test_pf_new_file_no_alloc;
      IFEND;
      IF (key = 'ALL') OR (key = 'PF_NEW_NO_FILE') THEN
        test_pf_new_no_file;
      IFEND;
      IF (key = 'ALL') OR (key = 'PF_RECLAIM') THEN
        test_pf_reclaim;
      IFEND;
      IF (key = 'ALL') OR (key = 'PREALLOCATE_FILE_SPACE') THEN
        test_preallocate_file_space (16384);
        test_preallocate_file_space (16384 * 100);
        test_preallocate_file_space (16384 * 1000);
      IFEND;
      IF (key = 'ALL') OR (key = 'PROCESS_IO_COMPLETION') THEN
        test_pioc;
      IFEND;
      IF (key = 'ALL') OR (key = 'READ') THEN
        test_read;
      IFEND;
      IF (key = 'ALL') OR (key = 'SET_ACCESS_SELECTIONS') THEN
        test_set_access_selections;
      IFEND;
      IF (key = 'ALL') OR (key = 'SET_SEGMENT_LENGTH') THEN
        test_set_segment_length;
      IFEND;
      IF (key = 'ALL') OR (key = 'STORE_SEGMENT_ATTRIBUTES') THEN
        test_store_segment_attributes;
      IFEND;
      IF (key = 'ALL') OR (key = 'TASK_SWITCH') THEN
        test_task_switch;
      IFEND;
      IF (key = 'ALL') OR (key = 'VERIFY_ACCESS') THEN
        test_verify_access;
      IFEND;
      IF (key = 'ALL') OR (key = 'WAIT_IO_COMPLETION') THEN
        test_wait_io_completion;
      IFEND;
      IF (key = 'ALL') OR (key = 'WRITE') THEN
        test_write (FALSE);
        test_write (TRUE);
      IFEND;
      IF (key = 'ALL') OR (key = 'WRITE_MODIFIED_PAGES') THEN
        test_write_mod_pages (1, 0);
        test_write_mod_pages (1, 1);
        test_write_mod_pages (1, 2);
        test_write_mod_pages (1, 4);
        test_write_mod_pages (2, 2);
        test_write_mod_pages (2, 4);
        test_write_mod_pages (4, 4);
        test_write_mod_pages (8, 8);
        test_write_mod_pages (16, 16);
      IFEND;
      IF (key = 'ALL') OR (key = 'WRITE_MODIFIED_PAGES_NO_FILE') THEN
        test_write_mod_pages_no_file;
      IFEND;
      key_p := key_p^.link;
    WHILEND;

    set_task2_function (quit);
    amp$close (shared_segment_id, status);
    amp$close (ofid, status);

  PROCEND mm_path_test;
?? EJECT ??

  PROCEDURE execute_task_2
    (    shared_segment_name: amt$local_file_name;
     VAR task_id: pmt$task_id;
     VAR task_status: pmt$task_status;
     VAR status: ost$status);

    VAR
      number_of_object_files: pmt$number_of_object_files,
      number_of_modules: pmt$number_of_modules,
      number_of_libraries: pmt$number_of_libraries,
      second_task: ^pmt$program_description,
      second_task_attributes: ^pmt$program_attributes,
      second_task_parameters: ^pmt$program_parameters,
      shared_segment_name_param: ^amt$local_file_name;

{ Build the program description of the second task using the program
{ description of the first task as a base.

    pmp$get_program_size (number_of_object_files, number_of_modules, number_of_libraries, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Allocate a sequence long enough for the program attributes variable,
{ the object file list, the module list, and the object library list.

    PUSH second_task: [[REP (#SIZE (pmt$program_attributes) +
          (number_of_object_files * #SIZE (amt$local_file_name)) +
          (number_of_modules * #SIZE (pmt$program_name)) + (number_of_libraries *
          #SIZE (amt$local_file_name))) OF cell]];

{ Get the program description of the first task.

    pmp$get_program_description (second_task^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET second_task;
    NEXT second_task_attributes IN second_task;
    second_task_attributes^.contents := second_task_attributes^.contents +
          $pmt$prog_description_contents [pmc$starting_proc_specified];

    second_task_attributes^.starting_procedure := 'MM_PATH_TEST2';

{ Build the second task parameter list:
{   Shared segment local file name

    PUSH second_task_parameters: [[REP 1 OF amt$local_file_name, REP 1 OF integer]];
    RESET second_task_parameters;
    NEXT shared_segment_name_param IN second_task_parameters;
    shared_segment_name_param^ := shared_segment_name;

{ Start the second task.  The osc$nowait parameter indicates that both tasks
{ are to execute at the same time.

    pmp$execute (second_task^, second_task_parameters^, osc$nowait, task_id, task_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
  PROCEND execute_task_2;

MODEND mmm$mm_path_test
*DECK DECK=MMM$MONITOR_REQUEST_PROCESSOR EXPAND=TRUE
?? RIGHT := 110 ??
MODULE mmm$monitor_request_processor;

{
{  PURPOSE: Memory_Manager
{     This module contains the monitor routines that are used to
{     manage physical memory and the page table.
{
?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dmt$transfer_size
*copyc gft$file_desc_entry_p
*copyc gft$locked_file_desc_entry_p
*copyc jmt$dispatching_priority
*copyc jmt$job_scheduler_event
*copyc jmv$null_ijl_ordinal
*copyc tmc$signal_identifiers
*copyc mmp$xcheck_queues
*copyc mmt$pt_full_status
*copyc mmt$buffer_descriptor
*copyc iot$io_function
*copyc iot$io_error
*copyc iot$tape_collected_pp_response
*copyc mmt$page_selection_criteria
*copyc mmt$pfti_array
*copyc mmt$write_modified_pages_status
*copyc mmt$asid_list_page_table_full
*copyc ost$heap
*copyc mmt$selected_page_fault_signal
*copyc mmt$rb_lock_ring_1_stack
*copyc mmt$rb_segment_request
*copyc mmt$update_eoi_reason
*copyc syt$monitor_flag
*copyc mmt$make_pt_entry_status
*copyc ost$segment_access_control
*copyc ost$cpu_state_table
*copyc tme$monitor_mode_exceptions
*copyc mmt$int_segment_access_fault
*copyc dmt$chapter_info
*copyc dmt$mass_storage_error_codes
*copyc osc$processor_defined_registers
*copyc mmk$monitor_mode_keypoints
*copyc ptk$performance_keypoints
*copyc mtc$job_fixed_segment
*copyc mmt$page_frame_index
*copyc mmt$active_segment_table
*copyc mmt$page_queue_list
*copyc mme$condition_codes
*copyc mmt$page_frame_queue_id
*copyc mmt$segment_access_rights
*copyc mmd$segment_access_condition
*copyc osc$purge_map_and_cache
*copyc mmt$rma_list
*copyc mmt$rb_ring1_segment_request
*copyc mmt$rb_ring1_server_seg_request
*copyc jmt$initiated_job_list_entry
*copyc mmt$rb_advise
*copyc mmt$rb_free_flush
*copyc mmt$pf_statistics
*copyc syv$perf_keypoints_enabled
*copyc osv$mainframe_wired_heap
*copyc osv$mainframe_wired_cb_heap
*copyc mmt$io_identifier
*copyc mmt$mainframe_wired_asid
*copyc mmt$rcv_memory_mgr
*copyc mmt$image_file
*copyc mmt$rb_memory_manager_io
*copyc mmv$total_contig_pages_assigned
*copyc mmp$xcheck_queues
*copyc sft$file_space_limit_kind
?? POP ??
*copyc mmc$debug_constants
?? SKIP := 2 ??
*copyc mmc$manage_memory_utility
?? SKIP := 2 ??
{External procedures used by this module.
{ Try to keep them in alphabetical order.
*copyc dfi$monitor_display
*copyc dfv$file_server_debug_enabled
*copyc dmp$deallocate_file_space
*copyc gfp$mtr_get_fde_p
*copyc gfp$mtr_get_locked_fde_p
*copyc i#real_memory_address
*copyc jmp$check_scheduler_memory_wait
*copyc jmp$get_ijle_p
*copyc jmp$ijl_block_valid
*copyc jmp$lock_ajl
*copyc jmp$unlock_ajl
*copyc jmp$set_scheduler_event
*copyc jsp$adv_expired_swapped_jobs
*copyc jsp$initiate_swapout_io
*copyc jsp$io_complete
*copyc jsp$recalculate_swapped_pages
*copyc mmp$age_job_working_set
*copyc mmp$asid
*copyc mmp$aste_pointer
*copyc mmp$asti
*copyc mmp$change_asid
*copyc mmp$check_queues
*copyc mmp$convert_pva
*copyc mmp$delete_last_pfti_from_array
*copyc mmp$delete_pt_entry
*copyc mmp$determine_shared_queue_id
*copyc mmp$fetch_pfti_array_size
*copyc mmp$find_next_pfti
*copyc mmp$free_asid
*copyc mmp$free_memory_in_job_queues
*copyc mmp$get_inhibit_io_status
*copyc mmp$get_max_sdt_pointer
*copyc mmp$get_max_sdt_sdtx_pointer
*copyc mmp$initialize_find_next_pfti
*copyc mmp$maintain_memory_thresholds
*copyc mmp$make_pt_entry
*copyc mmp$get_sdtx_entry_p
*copyc mmp$get_sdt_entry_p
*copyc mmp$mtr_set_get_segment_length
*copyc mmp$process_page_table_full
*copyc mmp$process_volume_unavailable
*copyc mmp$reclaim_ast_entries
*copyc mmp$relink_page_frame
*copyc mmp$remove_page_from_jws
*copyc mmp$remove_pages_from_jws
*copyc mmp$remove_page_from_job
*copyc mmp$remove_stale_pages
*copyc mmp$reset_find_next_pfti
*copyc mmp$reset_store_next_pfti
*copyc mmp$set_include_pages_in_dump
*copyc mmp$store_next_pfti
*copyc mmp$get_verify_asti_in_fde
*copyc mmp$verify_pva
*copyc mmp$write_page_to_disk
*copyc mmp$xcheck_queues
*copyc mmp$xtask_pva_to_sva
*copyc mtp$cst_p
*copyc mtp$error_stop
*copyc mtp$set_status_abnormal
*copyc osp$process_keypoint_io_error
*copyc osp$process_keypoint_periodic
*copyc tmp$cause_task_switch
*copyc tmp$check_for_swapout_candidate
*copyc tmp$check_timed_wait_not_queued
*copyc tmp$dequeue_task
*copyc tmp$find_next_queued_task
*copyc tmp$get_taskid_from_task_queue
*copyc tmp$get_xcb_p
*copyc tmp$idle_non_dispatchable_job
*copyc tmp$obtain_ijl_ordinal_from_ptl
*copyc tmp$queue_task
*copyc tmp$reissue_monitor_request
*copyc tmp$send_monitor_fault
*copyc tmp$set_monitor_flag
*copyc tmp$set_task_ready
?? TITLE := 'Global Variable Declarations - XREF and XDCL', EJECT ??
{--------------------------------------------------------------------------------------------------------

  TYPE
    ptr_type = record
      case b: 0 .. 3 of
      = 0 =
        st_p: ^mmt$segment_descriptor_table,
      = 1 =
        pva: ost$pva,
      = 2 =
        p: ^cell,
      = 3 =
        sdtx_p: ^mmt$segment_descriptor_table_ex,
      casend,
    recend;

*copyc dmv$null_sfid
?? SKIP := 2 ??
*copyc jmv$ajl_p
?? SKIP := 2 ??
*copyc jmv$idle_dispatching_controls
?? SKIP := 2 ??
*copyc jmv$ijl_p
?? SKIP := 2 ??
*copyc jmv$job_scheduler_table
?? SKIP := 2 ??
*copyc jmv$max_ajl_ordinal_in_use
?? SKIP := 2 ??
*copyc jmv$max_class_working_set
?? SKIP := 2 ??
*copyc jmv$scan_idle_dispatch_interval
?? SKIP := 2 ??
*copyc jmv$system_ijl_ordinal
?? SKIP := 2 ??
*copyc jsv$pages_needed_for_sfd
?? SKIP := 2 ??
*copyc jsv$swapped_page_entry_size
?? SKIP := 2 ??
*copyc mmv$aggressive_aging_level
?? SKIP := 2 ??
*copyc mmv$aging_statistics
?? SKIP := 2 ??
*copyc mmv$ast_p
?? SKIP := 2 ??
*copyc mmv$async_work
?? SKIP := 2 ??
*copyc mmv$gpql
?? SKIP := 2 ??
*copyc mmv$last_active_shared_queue
?? SKIP := 2 ??
*copyc mmv$max_working_set_size
?? SKIP := 2 ??
*copyc mmv$max_template_segment_number
?? SKIP := 2 ??
*copyc mmv$memory_wait_queue
?? SKIP := 2 ??
*copyc mmv$multiple_caches
?? SKIP := 2 ??
*copyc mmv$multiple_page_maps
?? SKIP := 2 ??
*copyc mmv$multi_page_write
?? SKIP := 2 ??
*copyc mmv$no_memory_buffering
?? SKIP := 2 ??
*copyc mmv$pft_p
?? SKIP := 2 ??
*copyc mmv$pfti_array_p
?? SKIP := 2 ??
*copyc mmv$pt_length
?? SKIP := 2 ??
*copyc mmv$pt_p
?? SKIP := 2 ??
*copyc mmv$reassignable_page_frames
?? SKIP := 2 ??
*copyc mmv$resident_job_target
?? SKIP := 2 ??
*copyc mmv$shared_pages_in_jws
?? SKIP := 2 ??
*copyc mmv$tables_initialized
?? SKIP := 2 ??
*copyc mmv$test_reassign_asid
?? SKIP := 2 ??
*copyc mmv$time_to_call_mem_mgr
?? SKIP := 2 ??
*copyc mmv$time_to_call_quick_sweep
?? SKIP := 2 ??
*copyc mmv$write_aged_out_pages
?? SKIP := 2 ??
*copyc mtv$monitor_segment_table
?? SKIP := 2 ??
*copyc mtv$nos_segment_table_p
?? SKIP := 2 ??
*copyc osv$cpus_physically_configured
?? SKIP := 2 ??
*copyc osv$keypoint_control
?? SKIP := 2 ??
*copyc osv$page_size
?? SKIP := 2 ??
*copyc osv$time_to_check_asyn
?? SKIP := 2 ??
*copyc osv$180_memory_limits
?? SKIP := 2 ??
*copyc tmv$cpu_execution_statistics
?? SKIP := 2 ??
*copyc tmv$dedicate_a_cpu_to_nos
?? SKIP := 2 ??
*copyc tmv$dispatching_controls
?? SKIP := 2 ??
*copyc tmv$dispatching_control_sets
?? SKIP := 2 ??
*copyc tmv$long_wait_force_swap_time
?? SKIP := 2 ??
*copyc tmv$null_global_task_id
?? SKIP := 2 ??
*copyc tmv$ptl_p
?? SKIP := 2 ??
*copyc tmv$timed_wait_not_queued
?? SKIP := 2 ??
  VAR
    mmv$ring1_request_trace: [XDCL, #GATE] ARRAY [0 .. 20] of integer,
    mmv$free_file_server_pages: [XDCL] boolean := FALSE,
    mmv$io_error_q_age_interval: [XDCL, #GATE] integer := 300000000, {300 seconds}
    mmv$jws_queue_age_interval: [XDCL, #GATE] integer := mmc$mmu_jws_age_interval,
    mmv$reduce_jws_for_thrashing: [XDCL] boolean := FALSE,
    mmv$shared_queue_age_interval: [XDCL, #GATE] integer := mmc$mmu_shared_age_interval,
    mmv$quick_sweep_interval: [XDCL, #GATE] integer := 20000000, {20 seconds}
    mmv$periodic_call_interval: [XDCL, #GATE] integer := mmc$mmu_periodic_call_interval,
    mmv$searched_entire_pft: integer := 0,
    mmv$test_pt_full: [XDCL] integer := 0,
    mmv$total_page_frames: [XDCL, #GATE] mmt$page_frame_index := 1500, {deadstart init resets exactly}
    mmv$trap_m: [XDCL] 0..255 := 0,
    mmv$image_file: [XDCL, #GATE] mmt$image_file := [FALSE, * , * ],
    mmv$aging_algorithm: [XDCL, #GATE] integer := mmc$mmu_aging_algorithm,
    mmv$sq_mcount: [XDCL, #GATE, oss$mainframe_wired] integer := 0,
    mmv$sq_rcount: [XDCL, #GATE, oss$mainframe_wired] integer := 0,
    mmv$jws_mcount: [XDCL, #GATE,oss$mainframe_wired] integer := 0,
    mmv$jws_rcount: [XDCL,#GATE,oss$mainframe_wired] integer := 0,
    iov$post_deadstart: [XREF] boolean,
    syv$user_templates: [XDCL, #GATE] boolean := FALSE;

?? TITLE := 'INLINE PROCEDURES FROM COMMON DECKS', EJECT ??
*copyc mmp$aste_pointer_from_pfti
?? SKIP := 2 ??
*copyc mmp$purge_all_cache
?? SKIP := 2 ??
*copyc mmp$purge_all_cache_map
?? SKIP := 2 ??
*copyc mmp$purge_all_page_map
?? SKIP := 2 ??
*copyc mmp$sva_purge_all_page_map
?? SKIP := 2 ??
*copyc mmp$sva_purge_one_page_map
?? EJECT ??
*copyc mmp$link_page_frame_to_queue

?? TITLE := 'GET_SYSTEM_JOBS_WORKING_SET' ??
?? EJECT ??
  PROCEDURE [INLINE] get_system_jobs_working_set
    (VAR working_set: mmt$page_frame_index);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry;

    jmp$get_ijle_p (jmv$system_ijl_ordinal, ijle_p);
    working_set := ijle_p^.job_page_queue_list [mmc$pq_job_fixed].count + ijle_p^.job_page_queue_list
           [mmc$pq_job_io_error].count + ijle_p^.job_page_queue_list [mmc$pq_job_working_set].count;

  PROCEND get_system_jobs_working_set;

?? TITLE := 'MMP$UNLOCK_RMA_LIST - Unlock pages defined by rma list' ??
?? EJECT ??
{--------------------------------------------------------------------------------------------------------
*copyc mmh$unlock_rma_list
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$unlock_rma_list
    (    iotype: iot$io_function;
         list_p: ^mmt$rma_list;
         list_length: mmt$rma_list_length;
         io_identifier: mmt$io_identifier;
         mf_job_file: boolean;
     VAR io_error: iot$io_error;
     VAR status: syt$monitor_status);


    PROCEDURE process_write_failure;

      pte_p^.v := TRUE;
      pfte_p^.io_error := init_io_error;
      IF pfte_p^.aste_p^.queue_id = mmc$pq_job_working_set THEN
        IF pfte_p^.aste_p^.sfid.residence = gfc$tr_system THEN
          {Note link to shared error q - required by job exit to
          {leave pages in memory correctly.
          mmp$relink_page_frame (pfti, mmc$pq_shared_io_error);
        ELSE
          ijl_ordinal := pfte_p^.ijl_ordinal;
          jmp$get_ijle_p (ijl_ordinal, ijle_p);

{  If this page is already in the swapped error queue then it has already been
{  put there as part of a transfer unit on an initial write.  If the job is
{  swapped pass the wait io complete state (JW) and the page is part of the job
{  working set leave it there and just set the modified bit.  We are OK unless
{  memory gets freed.  But since there is a page in the avail modified queue
{  that belongs to the same transfer unit in this write request that will be
{  put into the swapped error queue, when we swap in and reclaim it we can
{  reset the modified bit for all pages in this transfer unit.

          IF (pfte_p^.queue_id <> mmc$pq_swapped_io_error) THEN
            IF ijle_p^.swap_status <= jmc$iss_wait_job_io_complete THEN
              mmp$relink_page_frame (pfti, mmc$pq_job_io_error);
            ELSEIF (pfte_p^.queue_id = mmc$pq_avail_modified) THEN
              mmp$relink_page_frame (pfti, mmc$pq_swapped_io_error);
              ijle_p^.delayed_swapin_work := ijle_p^.delayed_swapin_work +
                    $jmt$delayed_swapin_work [jmc$dsw_io_error_while_swapped];
            IFEND;
          IFEND;

{  If this is an initial write that failed we must remove any other pages in the
{  transfer unit that might have been queued for IO after this request was made.

          IF(io_error = ioc$error_on_init) OR (io_error = ioc$unit_down_on_init) THEN
            remove_pages_in_tu (ijle_p, pfte_p);
          IFEND;
          io_error := ioc$no_error;

        IFEND;
      ELSE
        mmp$relink_page_frame (pfti, mmc$pq_shared_io_error);
      IFEND;
      pte_p^.m := TRUE; {Must be after RELINK}

    PROCEND process_write_failure;

    PROCEDURE process_rewrite_success;

      IF pfte_p^.active_io_count = 0 THEN
        WHILE pfte_p^.task_queue.head <> 0 DO
          tmp$dequeue_task (pfte_p^.task_queue, taskid);
        WHILEND;
        {Page that was in error queue has been written correctly !!
        pfte_p^.io_error := ioc$no_error;
        mmv$successful_error_retry := mmv$successful_error_retry + 1;

{ If page is in available modified, move it to the correct queue.  If the page
{ is part of the working set and the job is not swapped pass the wait_io_complete
{ state, move it to the correct queue.  Else leave it were it is.  Otherwise
{ mmv$reassignable_page_frames.soon will not be decremented correctly.

        IF NOT mmv$pt_p^ [pfte_p^.pti].m THEN
          ijl_ordinal := pfte_p^.ijl_ordinal;
          jmp$get_ijle_p (ijl_ordinal, ijle_p);
          IF (ijle_p^.swap_status <= jmc$iss_wait_job_io_complete) OR
                (pfte_p^.queue_id = mmc$pq_avail_modified) THEN
            pte_p^.v := FALSE;
            mmp$sva_purge_one_page_map (pfte_p^.sva); {Essential for dual CPU}
            IF mmv$no_memory_buffering THEN
              mmp$delete_pt_entry (pfti, TRUE);
              mmp$relink_page_frame (pfti, mmc$pq_free);
            ELSE
              mmp$relink_page_frame (pfti, mmc$pq_avail);
            IFEND;
          IFEND;
        IFEND;
      IFEND;

    PROCEND process_rewrite_success;

    PROCEDURE remove_pages_in_tu
      (    ijle_p: ^jmt$initiated_job_list_entry;
           init_pfte_p: ^mmt$page_frame_table_entry);

      CONST
        allow_allocation = TRUE;
      VAR
        ajlo: jmt$ajl_ordinal,
        boffset: integer,
        eoffset: integer,
        fde_p: gft$file_desc_entry_p,
        info: dmt$chapter_info,
        pfte_p: ^mmt$page_frame_table_entry,
        pfti: mmt$page_frame_index,
        pte_p: ^ost$page_table_entry;

      IF ijle_p^.swap_status >= jmc$iss_free_swapped_memory THEN
        IF (init_pfte_p^.sva.offset - dmc$max_transfer_size) < 0 THEN
          boffset := 0;
        ELSE
          boffset := init_pfte_p^.sva.offset - dmc$max_transfer_size;
        IFEND;
        IF ((init_pfte_p^.sva.offset - dmc$max_transfer_size) <= osc$max_segment_length) THEN
          eoffset := init_pfte_p^.sva.offset + dmc$max_transfer_size;
        ELSE
          eoffset := osc$max_segment_length;
        IFEND;
      ELSE
        jmp$lock_ajl (ijle_p, init_pfte_p^.aste_p^.ijl_ordinal, ajlo);

        gfp$mtr_get_fde_p (init_pfte_p^.aste_p^.sfid, ijle_p, fde_p);
        boffset := init_pfte_p^.sva.offset DIV fde_p^.allocation_unit_size *fde_p^.allocation_unit_size;
        eoffset := boffset + fde_p^.allocation_unit_size;

        jmp$unlock_ajl (ijle_p);
      IFEND;

      pfti := init_pfte_p^.aste_p^.pft_link.fwd;

      WHILE pfti <> 0 DO
        pfte_p := ^mmv$pft_p^ [pfti];
        IF (pfte_p^.sva.offset >= boffset) AND (pfte_p^.sva.offset < eoffset) AND
              (pfte_p^.active_io_count <> 0) THEN
          IF pfte_p^.locked_page = mmc$lp_page_in_lock THEN
            mmp$delete_pt_entry (pfti, TRUE);
            mmp$relink_page_frame (pfti, mmc$pq_free);
          ELSE

{  Assume write - other iotypes are not used with local files.
{  If this page is already in the swapped error queue then it was put there as part
{  of a transfer unit on another initial write.  The job is swapped and memory has
{  been freed so the maximum transfer size was used.
{  If the job is swapped pass the wait job io complete state and the page is part of
{  the job working set leave the page where it is and just set the modified bit.
{  If memory gets freed, all pages in the transfer unit will get their modified bit
{  reset when we swap in and reclaim io error pages.

            IF (pfte_p^.queue_id <> mmc$pq_swapped_io_error) THEN
              pte_p := ^mmv$pt_p^ [pfte_p^.pti];
              pte_p^.v := TRUE;
              IF ijle_p^.swap_status < jmc$iss_job_io_complete THEN
                mmp$relink_page_frame (pfti, mmc$pq_job_io_error);
              ELSEIF (pfte_p^.queue_id = mmc$pq_avail_modified) THEN
                mmp$relink_page_frame (pfti, mmc$pq_swapped_io_error);
              IFEND;
              pte_p^.m := TRUE;
            IFEND;
          IFEND;
        IFEND;
        pfti := mmv$pft_p^ [pfti].segment_link.fwd;
      WHILEND;

    PROCEND remove_pages_in_tu;

?? EJECT ??

    VAR
      count: integer,
      decrement_inhibit_swap: 0 .. mmc$max_rma_list_length,
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      initial_reassignable_now: integer,
      list_i: mmt$rma_list_index,
      mmv$successful_error_retry: [XDCL] integer := 0,
      pfte_p: ^mmt$page_frame_table_entry,
      pte_p: ^ost$page_table_entry,
      pfti: mmt$page_frame_index,
      taskid: ost$global_task_id,
      init_io_error: iot$io_error;

    status.normal := TRUE;

    init_io_error := io_error;
    initial_reassignable_now := mmv$reassignable_page_frames.now;

    decrement_inhibit_swap := list_length;
    IF (iotype = ioc$swap_out) OR (iotype = ioc$swap_in) THEN
      ijl_ordinal := io_identifier.ijl_ordinal;
      jmp$get_ijle_p (ijl_ordinal, ijle_p);
      IF io_error <> ioc$no_error THEN
        ijle_p^.swap_data.swapping_io_error := io_error;
      IFEND;

    ELSE { Not swap io }

    /unlock_pages/
      FOR list_i := 1 TO list_length DO
        IF list_p^ [list_i].length = 0 THEN
          EXIT /unlock_pages/;
        IFEND;
        pfti := list_p^ [list_i].rma DIV osv$page_size;
        #KEYPOINT (osk$debug, pfti * osk$m, mmk$unlock_rmal);

        pfte_p := ^mmv$pft_p^ [pfti];
        IF pfte_p^.active_io_count = 0 THEN
          mtp$error_stop ('mm - unlock rma list error');
        IFEND;
        pfte_p^.active_io_count := pfte_p^.active_io_count - 1;

        IF pfte_p^.queue_id = mmc$pq_free THEN
          IF pfte_p^.active_io_count = 0 THEN
            IF (io_error <> ioc$no_error) AND (iotype = ioc$keypoint_io) THEN
              osp$process_keypoint_io_error;
            IFEND;
            mmp$link_page_frame_to_queue (pfti, pfte_p);
          IFEND;
        ELSE
          pte_p := ^mmv$pt_p^ [pfte_p^.pti];

          IF (iotype = ioc$write_locked_page) AND (pfte_p^.queue_id < mmc$pq_first_valid_in_pt) THEN
            mtp$error_stop ('MM - unlock rmal, bad queue');
          IFEND;

          CASE iotype OF
          = ioc$no_io =
          = ioc$explicit_write, ioc$write_mass_storage, ioc$initialize_sectors
             , ioc$write_to_client  =
          = ioc$explicit_read, ioc$read_uft, ioc$read_mass_storage, ioc$explicit_read_no_purge =
            IF (list_i = 1) AND (iotype <> ioc$explicit_read_no_purge) THEN
              mmp$purge_all_cache;
            IFEND;
            IF (pfte_p^.queue_id = mmc$pq_avail_modified) AND NOT pte_p^.m THEN
              mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon - 1;
            IFEND;
            pte_p^.m := TRUE;
          = ioc$read_from_client =
{!          We will decide whether or not to do this when we support active readers on the server with
{!          writers on (multiple) clients.
{!          IF list_i = 1 THEN
{!            mmp$purge_all_cache;
{!          IFEND;
            pfte_p^.locked_page := mmc$lp_not_locked;
            IF io_error = ioc$no_error THEN
              IF pfte_p^.queue_id >= mmc$pq_first_valid_in_pt THEN
                pte_p^.v := TRUE;
              ELSEIF NOT pte_p^.m THEN
                mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon - 1;
              IFEND;
              pte_p^.u := TRUE;
              pte_p^.m := TRUE;
            ELSE
              mmp$unlock_rma_list_error (pfti, pfte_p, io_error);
            IFEND;
          = ioc$read_page, ioc$read_for_server, ioc$read_ahead_on_server =
            ?IF mmc$debug_rma_list THEN
              IF pte_p^.v THEN
                mtp$error_stop ('MM - unlock rmal, read to valid page');
              IFEND;
            ?IFEND;
            pfte_p^.locked_page := mmc$lp_not_locked;
            IF io_error = ioc$no_error THEN
              IF pfte_p^.queue_id >= mmc$pq_first_valid_in_pt THEN
                pte_p^.v := TRUE;
                pte_p^.u := TRUE;
              IFEND;
            ELSE
              mmp$unlock_rma_list_error (pfti, pfte_p, io_error);
            IFEND;
          = ioc$allocate =
            pfte_p^.locked_page := mmc$lp_not_locked;
            IF io_error = ioc$no_error THEN
              IF pfte_p^.queue_id >= mmc$pq_first_valid_in_pt THEN
                pte_p^.v := TRUE;
              IFEND;
            ELSE
              mmp$unlock_rma_list_error (pfti, pfte_p, io_error);
            IFEND;
          = ioc$write_page, ioc$write_locked_page, ioc$write_for_server =
            IF iotype = ioc$write_locked_page THEN
              IF pfte_p^.queue_id >= mmc$pq_first_valid_in_pt THEN
                pte_p^.v := TRUE;
              IFEND;
              pfte_p^.locked_page := mmc$lp_not_locked;
            IFEND;
            IF init_io_error <> ioc$no_error THEN
              process_write_failure;
            ELSEIF pfte_p^.io_error <> ioc$no_error THEN
              process_rewrite_success;
            IFEND;
          ELSE
            mtp$error_stop ('MM - bad IO type unlock_rma_list');
          CASEND;
        IFEND;

{ If the page is no longer locked (all IO complete), there is some more processing to be done:
{ Dequeue all tasks waiting for the IO to complete.

        IF pfte_p^.active_io_count = 0 THEN
          WHILE pfte_p^.task_queue.head <> 0 DO
            tmp$dequeue_task (pfte_p^.task_queue, taskid);
          WHILEND;

{  If the page is in the available modified queue and has been sucessfully written to disk,
{  the page should be moved to the available queue. (Debugging option allows for available
{  queue to be disabled).

          IF (pfte_p^.queue_id = mmc$pq_avail_modified) THEN
            IF NOT mmv$pt_p^ [pfte_p^.pti].m THEN
              IF mmv$no_memory_buffering THEN
                mmp$delete_pt_entry (pfti, TRUE);
                mmp$relink_page_frame (pfti, mmc$pq_free);
              ELSE
                mmp$relink_page_frame (pfti, mmc$pq_avail);
              IFEND;
            IFEND;

 {  If the page was being used by file server on the SERVER and and has been sucessfully
 {  written to disk/client, remove the page from the shared queue if possible. NOTE that
 { the page cannot be removed if it is modified. Also note that since the page is VALID
 { the MODIFIED BIT in the page table cannot be examined until the VALID BIT
 { is cleared and the page maps purged.

          ELSEIF (pfte_p^.queue_id >= mmc$pq_shared_first) AND (pfte_p^.queue_id <= mmc$pq_shared_last) AND
               ((iotype = ioc$write_to_client) OR (iotype = ioc$write_for_server)) THEN
            pte_p^.v := FALSE;
            mmp$sva_purge_one_page_map (pfte_p^.sva); {Essential for dual CPU}
            IF pte_p^.m THEN
              pte_p^.v := TRUE;
            ELSEIF mmv$free_file_server_pages THEN
              mmp$delete_pt_entry (pfti, TRUE);
              mmp$relink_page_frame (pfti, mmc$pq_free);
            ELSE
              mmp$relink_page_frame (pfti, mmc$pq_avail);
            IFEND;
          IFEND;
        IFEND;

      FOREND /unlock_pages/;

      ijl_ordinal := pfte_p^.ijl_ordinal;
      jmp$get_ijle_p (ijl_ordinal, ijle_p);

{  If the IJL entry has been freed get the heck out of here before we crash.
      IF ijle_p^.entry_status = jmc$ies_entry_free THEN
       RETURN;
      IFEND;

{  If IO was a "write" of a local file, dont decrement inhibit swap.
{  If an IO error occurred on a swapped job, set the task ready so it can swap in and reclaim
{  its error pages.

      IF (mf_job_file) AND ((iotype = ioc$write_page) OR (iotype = ioc$write_locked_page)) THEN
        decrement_inhibit_swap := 0;
        IF (init_io_error <> ioc$no_error) AND
              (ijle_p^.entry_status <> jmc$ies_entry_free) AND
              (ijle_p^.swap_status >= jmc$iss_job_io_complete) THEN
          tmp$set_task_ready (ijle_p^.job_monitor_taskid, 0 {readying_task_priority},
                tmc$rc_ready_conditional_wi);
        IFEND;
      IFEND;


    IFEND; { Not swap io }

{ The active_io_page_count must always be accurate but the number of active_io_requests can sometimes
{ be incorrect.  If pages are moved from a JWS to the shared working set, the active_io_page_count is
{ modified to reflect the move but the active_io_requests count can not be modified because it is not
{ known how many IO requests were made.  Therefore, the code here must ensure active_io_requests does
{ not become negative and if the active_io_active count becomes zero then zero active_io_requests.  If
{ active_io_count is non-zero then we know there must be at least one IO request outstanding therefore
{ do not decrement active_io_requests if it is not greater than one.
{ This will correct the active_io_requests count if it was incorrect.  The only use of the requests
{ count is to slowdown the task if it initiates too many IO requests while at MAXWS.

    IF ijle_p^.active_io_page_count < list_length THEN
      mtp$error_stop ('MM-NEGATIVE IO COUNT IN UNLOCK RMA');
    IFEND;

    ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count - decrement_inhibit_swap;
    ijle_p^.active_io_page_count := ijle_p^.active_io_page_count - list_length;
    IF ijle_p^.active_io_page_count = 0 THEN
      ijle_p^.active_io_requests := 0;
    ELSEIF ijle_p^.active_io_requests > 1 THEN
      ijle_p^.active_io_requests := ijle_p^.active_io_requests - 1;
    IFEND;
    IF (ijle_p^.inhibit_swap_count = 0) AND (ijle_p^.notify_swapper_when_io_complete) THEN
      jsp$io_complete (ijle_p);
    IFEND;

    count := mmv$reassignable_page_frames.now - initial_reassignable_now;
    WHILE (count > 0) AND (mmv$memory_wait_queue.head <> 0) DO
      tmp$dequeue_task (mmv$memory_wait_queue, taskid);
      count := count - 1;
    WHILEND;

    mmp$check_queues;

  PROCEND mmp$unlock_rma_list;
?? SKIP := 3 ??

{This procedure is called to process an IO error on a page-in request.

  PROCEDURE mmp$unlock_rma_list_error
    (    pfti: mmt$page_frame_index;
         pfte_p: ^mmt$page_frame_table_entry;
         io_error: iot$io_error);

    VAR
      delete_pt_entry_ok: boolean,
      ijle_p: ^jmt$initiated_job_list_entry,
      monitor_fault: ost$monitor_fault,
      sac_p: ^mmt$segment_access_condition,
      sdte_segment_number: ost$segment,
      sdtxe_p: ^mmt$segment_descriptor_extended,
      status: syt$monitor_status,
      taskid: ost$global_task_id,
      xcb_p: ^ost$execution_control_block;

    monitor_fault.identifier := mmc$segment_fault_processor_id;
    sac_p := #LOC (monitor_fault.contents);
    sac_p^.identifier := mmc$sac_io_read_error;
    delete_pt_entry_ok := TRUE;

    tmp$get_taskid_from_task_queue (pfte_p^.task_queue, taskid);
    WHILE taskid <> tmv$null_global_task_id DO
      tmp$get_xcb_p (taskid, xcb_p, ijle_p);
      IF xcb_p <> NIL THEN
        IF io_error = ioc$unrecovered_error_unit_down THEN
          mmp$process_volume_unavailable (xcb_p, FALSE);
        ELSEIF io_error = ioc$server_allocation_error THEN
          sdte_segment_number := #SEGMENT (xcb_p^.page_wait_info.pva);
          sdtxe_p := mmp$get_sdtx_entry_p (xcb_p, sdte_segment_number);
          sdtxe_p^.assign_active := 0;
          tmp$set_monitor_flag (taskid, mmc$mf_segment_mgr_flag, status);
          IF (xcb_p^.xp.trap_enable <> osc$traps_enabled) OR (xcb_p^.xp.p_register.pva.ring = 1) THEN
            delete_pt_entry_ok := FALSE;
            mmv$pt_p^ [pfte_p^.pti].v := TRUE;
          IFEND;
        ELSEIF io_error = ioc$server_has_terminated THEN
          sac_p^.identifier := mmc$sac_file_server_terminated;
          IF xcb_p^.page_wait_info.pva <> NIL THEN
            sac_p^.segment := xcb_p^.page_wait_info.pva;
            tmp$send_monitor_fault (taskid, #LOC (monitor_fault), TRUE);
          IFEND;
        ELSE {io_error <> ioc$unrecovered_error_unit_down, io_error <> ioc$server_allocation_error}
          IF xcb_p^.page_wait_info.pva <> NIL THEN
            sac_p^.segment := xcb_p^.page_wait_info.pva;
            tmp$send_monitor_fault (taskid, #LOC (monitor_fault), TRUE);
          IFEND;
        IFEND;

        jmp$unlock_ajl (ijle_p);
      IFEND;

      tmp$find_next_queued_task (taskid);
    WHILEND;

    IF NOT delete_pt_entry_ok THEN
      RETURN;
    IFEND;

    mmp$delete_pt_entry (pfti, TRUE);
    mmp$relink_page_frame (pfti, mmc$pq_free);

  PROCEND mmp$unlock_rma_list_error;

?? TITLE := 'MMP$BUILD_LOCK_RMA_LIST - Build and lock pages defined by rma list' ??
?? EJECT ??

{--------------------------------------------------------------------------------------------------------
*copyc mmh$build_lock_rma_list
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$build_lock_rma_list
    (    buffer_descriptor: mmt$buffer_descriptor;
         length: ost$byte_count;
         iotype: iot$io_function;
         list_p: ^mmt$rma_list;
         list_length: mmt$rma_list_length;
     VAR status: syt$monitor_status);

    VAR
      found: boolean,
      hash_count: 1 .. 32,
      ijle_p: ^jmt$initiated_job_list_entry,
      ijl_ordinal: jmt$ijl_ordinal,
      index: integer,
      io_error: iot$io_error,
      ioid: mmt$io_identifier,
      jf_asid: ost$asid,
      purge_map: boolean,
      list_i: mmt$rma_list_index,
      mf_job_file: boolean,
      osv$keypoint_periodic_lpid: [XREF] integer,
      page_count: integer,
      page_offset: 0 .. 65535,
      pfte_p: ^mmt$page_frame_table_entry,
      pfti: mmt$page_frame_index,
      pti: integer,
      spde_p: ^jst$swapped_page_descriptor,
      sva: ost$system_virtual_address;


    status.normal := TRUE;
    list_i := 1;


{  Lock the pages depending on format of the buffer descriptor.

    CASE buffer_descriptor.buffer_descriptor_type OF

    = mmc$bd_paging_io, mmc$bd_explicit_io =
      sva := buffer_descriptor.sva;
      page_offset := sva.offset MOD osv$page_size;
      page_count := ((page_offset + length - 1) DIV osv$page_size) + 1;
      IF (list_length < page_count) OR (list_length = 0) THEN
        mtp$error_stop ('MM - lock rmal, list too small');
      IFEND;
      purge_map := FALSE;

    /lp/
      WHILE TRUE DO
        IF iotype <> ioc$keypoint_io THEN
          #HASH_SVA (sva, pti, hash_count, found);
          IF NOT found THEN
            EXIT /lp/
          IFEND;
          pfti := (mmv$pt_p^ [pti].rma * 512) DIV osv$page_size;
        ELSE
          pfti := osv$keypoint_control.cpus [osv$keypoint_periodic_lpid].io_pfti [list_i];
        IFEND;
        #KEYPOINT (osk$debug, pfti * osk$m, mmk$build_lock_rmal);
        pfte_p := ^mmv$pft_p^ [pfti];
        pfte_p^.active_io_count := pfte_p^.active_io_count + 1;
        ?IF mmc$debug_rma_list THEN
          IF list_i = 1 THEN
            ijl_ordinal := pfte_p^.ijl_ordinal;
          ELSEIF ijl_ordinal <> pfte_p^.ijl_ordinal THEN
            mtp$error_stop ('MM - lock rmal, mixed ijl ordinal in lock');
          IFEND;
          IF ((iotype = ioc$write_page) OR (iotype = ioc$write_locked_page)) AND NOT mmv$pt_p^ [pti].m THEN
            mtp$error_stop ('MM - lock rmal, write page error');
          IFEND;
          IF (iotype = ioc$read_page) AND ((pfte_p^.queue_id < mmc$pq_first_valid_in_pt) OR mmv$pt_p^ [pti].
                v) THEN
            mtp$error_stop ('MM - lock rmal, read page error');
          IFEND;
        ?IFEND;

        CASE iotype OF
        = ioc$explicit_read, ioc$read_uft, ioc$read_mass_storage, ioc$explicit_write, ioc$write_mass_storage,
              ioc$initialize_sectors, ioc$explicit_read_no_purge =
          IF pfte_p^.queue_id = mmc$pq_avail THEN
            mmp$relink_page_frame (pfti, pfte_p^.aste_p^.queue_id);
            mmv$pt_p^ [pti].v := TRUE;
          IFEND;
        = ioc$write_to_client =
          IF pfte_p^.locked_page = mmc$lp_page_in_lock THEN
            pfte_p^.active_io_count := pfte_p^.active_io_count - 1;
            EXIT /lp/;
          IFEND;
          IF pfte_p^.queue_id = mmc$pq_avail THEN
            mmp$relink_page_frame (pfti, pfte_p^.aste_p^.queue_id);
            mmv$pt_p^ [pti].v := TRUE;
          IFEND;
        = ioc$read_from_client =
          IF NOT mmv$pt_p^ [pti].v THEN
            pfte_p^.locked_page := mmc$lp_page_in_lock;
          IFEND;
        = ioc$no_io =
        = ioc$read_page, ioc$read_for_server, ioc$read_ahead_on_server =
          pfte_p^.locked_page := mmc$lp_page_in_lock;
        = ioc$allocate =
          pfte_p^.locked_page := mmc$lp_server_allocate_lock;
        = ioc$write_page, ioc$write_for_server =
          mmv$pt_p^ [pti].m := FALSE;
          IF pfte_p^.queue_id = mmc$pq_avail_modified THEN
            mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon + 1;
          ELSEIF mmv$pt_p^ [pti].v THEN
            purge_map := TRUE;
          IFEND;
        = ioc$write_locked_page =
          pfte_p^.locked_page := mmc$lp_write_protected_lock;
          IF pfte_p^.queue_id = mmc$pq_avail_modified THEN
            mmp$relink_page_frame (pfti, pfte_p^.aste_p^.queue_id);
          ELSEIF mmv$pt_p^ [pti].v THEN
            mmv$pt_p^ [pti].v := FALSE;
            purge_map := TRUE;
          IFEND;
          mmv$pt_p^ [pti].m := FALSE;
        = ioc$keypoint_io =
          mmp$relink_page_frame (pfti, mmc$pq_free);
        ELSE
          mtp$error_stop ('MM - bad IO type lock_rma_list');
        CASEND;
        IF (pfte_p^.queue_id <= mmc$pq_last_reassignable) AND (iotype <> ioc$keypoint_io) THEN
          mtp$error_stop ('MM - Tried to ioc$write_page in AVAIL');
        IFEND;

        list_p^ [list_i].rma := pfti * osv$page_size + page_offset;
        page_count := page_count - 1;
        IF page_count <= 0 THEN
          list_p^ [list_i].length := ((buffer_descriptor.sva.offset + length - 1) MOD osv$page_size) -
                page_offset + 1;
          jmp$get_ijle_p (pfte_p^.ijl_ordinal, ijle_p);
          ijle_p^.active_io_page_count := ijle_p^.active_io_page_count + list_length;
          ijle_p^.active_io_requests := ijle_p^.active_io_requests + 1;
          IF (pfte_p^.aste_p^.sfid.residence <> gfc$tr_job) OR
                ((iotype <> ioc$write_page) AND (iotype <> ioc$write_locked_page)) THEN
            ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count + list_length;
          IFEND;
          IF list_i < list_length THEN
            list_p^ [list_i + 1].length := 0;
          IFEND;
          IF purge_map THEN
            mmp$purge_all_page_map;
          IFEND;
          RETURN; {<-----}
        IFEND;
        list_p^ [list_i].length := osv$page_size - page_offset;
        sva.offset := sva.offset + osv$page_size;
        page_offset := 0;
        list_i := list_i + 1;
      WHILEND /lp/;


{Control gets here only if a page frame is not assigned to a page that is being locked.  Unlock the pages (if
{any) that have already been locked.

      IF list_i > 1 THEN
        jmp$get_ijle_p (pfte_p^.ijl_ordinal, ijle_p);
        ijle_p^.active_io_page_count := ijle_p^.active_io_page_count + list_i - 1;
        ijle_p^.active_io_requests := ijle_p^.active_io_requests + 1;
        IF (pfte_p^.aste_p^.sfid.residence <> gfc$tr_job) OR
              ((iotype <> ioc$write_page) AND (iotype <> ioc$write_locked_page)) THEN
          ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count + list_i - 1;
          mf_job_file := FALSE;
        ELSE
          mf_job_file := TRUE;
        IFEND;
        io_error := ioc$no_error;
        ioid.specified := FALSE;
        mmp$unlock_rma_list (ioc$no_io, list_p, list_i - 1, ioid, mf_job_file, io_error, status);
      IFEND;
      mtp$set_status_abnormal ('MM', mme$page_frame_not_assigned, status);


    = mmc$bd_job_swapping_io =


{  Lock pages for job swapping io.

      ijl_ordinal := buffer_descriptor.ijl_ordinal;
      jmp$get_ijle_p (ijl_ordinal, ijle_p);
      page_count := list_length;
      ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count + page_count;
      ijle_p^.active_io_page_count := ijle_p^.active_io_page_count + page_count;
      ijle_p^.active_io_requests := ijle_p^.active_io_requests + 1;

      IF ijle_p^.swap_io_control.spd_index = 0 THEN
        ijle_p^.swap_io_control.next_queue_id := SUCC (mmc$pq_job_fixed);
        ijle_p^.swap_io_control.next_pfti := ijle_p^.job_page_queue_list [mmc$pq_job_fixed].link.bkw;
        ijle_p^.swap_io_control.stop_pfti := ijle_p^.swap_io_control.swap_file_descriptor_pfti;
        ijle_p^.swap_data.swapping_io_error := ioc$no_error;
      IFEND;

      jf_asid := ijle_p^.job_fixed_asid;

      WHILE TRUE DO
        IF ijle_p^.swap_io_control.next_pfti = ijle_p^.swap_io_control.stop_pfti THEN
          IF ijle_p^.swap_io_control.next_queue_id = mmc$pq_job_fixed THEN
            ijle_p^.swap_io_control.next_pfti := ijle_p^.swap_io_control.swap_file_descriptor_pfti;
          ELSEIF (ijle_p^.swap_io_control.next_queue_id = SUCC (mmc$pq_job_fixed)) AND
                (ijle_p^.swap_io_control.stop_pfti = 0) THEN
            mtp$error_stop ('MM - error in locking swap file pages');
          ELSE
            ijle_p^.swap_io_control.stop_pfti := 0;
            ijle_p^.swap_io_control.next_pfti := ijle_p^.job_page_queue_list
                  [ijle_p^.swap_io_control.next_queue_id].link.bkw;
          IFEND;
          IF ijle_p^.swap_io_control.next_queue_id = UPPERVALUE (mmt$job_page_queue_index) THEN
            ijle_p^.swap_io_control.next_queue_id := mmc$pq_job_fixed;
          ELSE
            ijle_p^.swap_io_control.next_queue_id := SUCC (ijle_p^.swap_io_control.next_queue_id);
          IFEND;
        IFEND;

        WHILE ijle_p^.swap_io_control.next_pfti <> ijle_p^.swap_io_control.stop_pfti DO
          pfte_p := ^mmv$pft_p^ [ijle_p^.swap_io_control.next_pfti];
          ?IF mmc$debug_rma_list THEN
            IF ijl_ordinal <> pfte_p^.ijl_ordinal THEN
              mtp$error_stop ('MM - mixed ijl ordinal in swap');
            IFEND;
          ?IFEND;
          IF iotype = ioc$swap_out THEN
            spde_p := ^ijle_p^.sfd_p^.swapped_page_descriptors [ijle_p^.swap_io_control.spd_index];
            spde_p^.pft_entry := pfte_p^;
            spde_p^.page_table_entry := mmv$pt_p^ [pfte_p^.pti];
            spde_p^.ast_entry := pfte_p^.aste_p^;

{ The entry_updated field in the swapped page descriptor is set to TRUE for job fixed pages, FALSE for
{ all other pages.  Setting the field helps reset_swapped_job_mm_tables in swapper to differentiate
{ between job fixed pages and other fixed pages when checking/changing ASIDs.

            spde_p^.entry_updated := (spde_p^.pft_entry.sva.asid = jf_asid);

            IF syv$perf_keypoints_enabled.memory_keypoints THEN
              #KEYPOINT (osk$performance, osk$m * ijle_p^.swap_io_control.next_pfti,
                    ptk$pfti_for_swapout);
            IFEND;
          IFEND;

          list_p^ [list_i].rma := ijle_p^.swap_io_control.next_pfti * osv$page_size;
          list_p^ [list_i].length := osv$page_size;

          ijle_p^.swap_io_control.spd_index := ijle_p^.swap_io_control.spd_index + 1;
          ijle_p^.swap_io_control.next_pfti := pfte_p^.link.bkw;

          page_count := page_count - 1;
          IF page_count = 0 THEN
            RETURN;
          IFEND;
          list_i := list_i + 1;
        WHILEND;

      WHILEND;
    ELSE
      mtp$error_stop ('MM - bad bufr desc in lock_rma_list');
    CASEND;

    mmp$check_queues;

  PROCEND mmp$build_lock_rma_list;

?? TITLE := 'MMP$BUILD_LOCK_RMA_LIST_TAPE - Build and lock pages defined by tape request' ??
?? EJECT ??

{--------------------------------------------------------------------------------------------------------
{ Purpose:
{   This procedure is a build_lock_rma_list routine that is customized for NOS/VE tape I/O.
{   This allows all the pages associated with a tape request to be locked in one call from
{   iom$tape_queue_manager_mtr.  This replaces the use of mmp$build_lock_rma_list, which
{   required up to 30 calls for write requests and 60 calls for read requests.
{
{ Notes:
{   Although buffer_descriptor is not a parameter to this routine, the buffer_descriptor_type
{   is assumed to be mmc$bd_explicit_io.  Tape I/O does not use anything else.  If any changes
{   are made to mmp$build_lock_rma_list relating to mmc$bd_explicit_io, those changes may
{   also be needed here.
{
{   The only io_type values ever used for locking pages are ioc$explicit_read and
{   ioc$explicit_write.  When the pages are unlocked, io_type can be ioc$explicit_read_no_purge
{   if cache purge is not required.
{
{   The parameter tape_request_p points to the wired tape request for which pages need to
{   be locked and rma lists built.  The request is both an input and output parameter.
{   For writes and reads, the data buffers for the request are locked.  For reads the
{   first store transfer count buffer is also locked.  Since all transfer count buffers must
{   be on the same memory page, it is not necessary to lock more than one.
{
{   If page frames are not assigned to the entire range of addresses specified in the
{   request, no frames are locked and an error code will be returned.
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$build_lock_rma_list_tape (
         tape_request_p: ^iot$wired_tape_request;   {input/output
     VAR status: syt$monitor_status);

    VAR
      command_index: iot$tape_command_index,
      found: boolean,
      hash_count: 1 .. 32,
      ignore_status: syt$monitor_status,
      ijle_p: ^jmt$initiated_job_list_entry,
      ijl_ordinal: jmt$ijl_ordinal,
      io_error: iot$io_error,
      ioid: mmt$io_identifier,
      length: ost$byte_count,
      list_i: mmt$rma_list_index,
      list_p: ^mmt$rma_list,
      loop_count: 1 .. 2,
      loop_count_index: 1 .. 2,
      page_count: integer,
      page_offset: 0 .. 65535,
      pfte_p: ^mmt$page_frame_table_entry,
      pfti: mmt$page_frame_index,
      pti: integer,
      pva: ^cell,
      rma: integer,
      sva: ost$system_virtual_address,
      total_list_entries: mmt$rma_list_index;

    status.normal := TRUE;
    total_list_entries := 1;
    list_p := #LOC (tape_request_p^.wired_command_heap_p^.rma_list [1]);
    loop_count := 1;
    IF tape_request_p^.io_type = ioc$explicit_read THEN
      loop_count := 2;  { must lock data buffer(s) and store transfer count buffer
    IFEND;

    FOR loop_count_index := 1 TO loop_count DO

    /lock_loop/
      FOR command_index := 1 TO tape_request_p^.no_of_data_commands DO
        list_i := 1;
        IF tape_request_p^.io_type = ioc$explicit_read THEN
          IF loop_count_index = 1 THEN {data buffer
            length := tape_request_p^.max_input_count;
            pva := tape_request_p^.wired_read_description_p^ [command_index].buffer_area;
          ELSE {store transfer count buffer
            length := 8;
            pva := tape_request_p^.wired_read_description_p^ [command_index].block_transfer_length;
          IFEND;
        ELSE {ioc$explicit_write
          length := tape_request_p^.wired_write_description_p^ [command_index].transfer_length;
          pva := tape_request_p^.wired_write_description_p^ [command_index].buffer_area;
        IFEND;
        mmp$xtask_pva_to_sva (pva, sva, status);
        IF NOT status.normal THEN
          IF total_list_entries > 1 THEN
            jmp$get_ijle_p (pfte_p^.ijl_ordinal, ijle_p);
            ijle_p^.active_io_requests := ijle_p^.active_io_requests + 1;
            io_error := ioc$no_error;
            ioid.specified := FALSE;
            mmp$unlock_rma_list (ioc$no_io, list_p, total_list_entries - 1, ioid,
                  {MF_JOB_FILE} FALSE, io_error, ignore_status);
          IFEND;
          RETURN;
        IFEND;

        page_offset := sva.offset MOD osv$page_size;
        page_count := ((page_offset + length - 1) DIV osv$page_size) + 1;
        IF page_count + total_list_entries - 1 > tape_request_p^.allocated_address_pair_count THEN
          mtp$error_stop ('MM - tape lock rma list, list too small');
        IFEND;

        REPEAT
          #HASH_SVA (sva, pti, hash_count, found);
          IF NOT found THEN

{ A page frame is not assigned to a page that is being locked.
{ Unlock the pages (if any) that have already been locked and return the error
{ mme$page_frame_not_assigned to iom$tape_queue_manager_mtr, who will in turn return to job mode
{ where all the pages will be touched and the monitor request reissued.

            IF total_list_entries > 1 THEN
              jmp$get_ijle_p (pfte_p^.ijl_ordinal, ijle_p);
              ijle_p^.active_io_requests := ijle_p^.active_io_requests + 1;
              IF list_i > 1 THEN
                ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count + list_i - 1;
                ijle_p^.active_io_page_count := ijle_p^.active_io_page_count + list_i - 1;
              IFEND;
              io_error := ioc$no_error;
              mmp$unlock_rma_list (ioc$no_io, list_p, total_list_entries - 1, ioid,
                    {MF_JOB_FILE} FALSE, io_error, status);
              IF NOT status.normal THEN
                mtp$error_stop ('MM - lock tape rma list, unlock error');
              IFEND;
            IFEND;
            mtp$set_status_abnormal ('MM', mme$page_frame_not_assigned, status);
            RETURN; {<-----}
          IFEND;

          pfti := (mmv$pt_p^ [pti].rma * 512) DIV osv$page_size;
          pfte_p := ^mmv$pft_p^ [pfti];
          pfte_p^.active_io_count := pfte_p^.active_io_count + 1;
          IF (pfte_p^.queue_id = mmc$pq_avail) THEN
            mmp$relink_page_frame (pfti, pfte_p^.aste_p^.queue_id);
            mmv$pt_p^ [pti].v := TRUE;
          IFEND;

          ?IF mmc$debug_rma_list THEN
            IF loop_count_index = 1 THEN
              IF total_list_entries = 1 THEN
                ijl_ordinal := pfte_p^.ijl_ordinal;
              ELSEIF ijl_ordinal <> pfte_p^.ijl_ordinal THEN
                mtp$error_stop ('MM - tape lock rma list, mixed ijl ordinal in lock');
              IFEND;
            IFEND;
          ?IFEND;

          list_p^ [total_list_entries].rma := pfti * osv$page_size + page_offset;
          page_count := page_count - 1;
          IF page_count > 0 THEN
            ?IF mmc$debug_rma_list THEN
              IF loop_count_index = 2 THEN
                mtp$error_stop ('MM - tape lock rma list, transfer count buffer more than 1 page');
              IFEND;
            ?IFEND;
            list_p^ [total_list_entries].length := osv$page_size - page_offset;
            sva.offset := sva.offset + osv$page_size;
            page_offset := 0;
            list_i := list_i + 1;
          ELSE
            list_p^ [total_list_entries].length := ((sva.offset + length - 1) MOD osv$page_size) -
                  page_offset + 1;
            jmp$get_ijle_p (pfte_p^.ijl_ordinal, ijle_p);
            ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count + list_i;
            ijle_p^.active_io_page_count := ijle_p^.active_io_page_count + list_i;
          IFEND;
          total_list_entries := total_list_entries + 1;
        UNTIL page_count <= 0;

        i#real_memory_address (^list_p^ [total_list_entries - list_i], rma);
        IF tape_request_p^.io_type = ioc$explicit_read THEN
          IF loop_count_index = 1 THEN
            tape_request_p^.request.tape_command [command_index * 2].address := rma;
            tape_request_p^.request.tape_command [command_index * 2].length := list_i * 8;
          ELSE
            tape_request_p^.request.tape_command [command_index * 2 + 1].address :=
                  list_p^ [total_list_entries - 1].rma;
            EXIT /lock_loop/;
          IFEND;
        ELSE { ioc$explicit_write
          tape_request_p^.request.tape_command [command_index * 2 + 1].address := rma;
          tape_request_p^.request.tape_command [command_index * 2 + 1].length := list_i * 8;
        IFEND;
      FOREND /lock_loop/;

{ Increment active_io_requests in the ijle entry that was used in the preceding trip thru
{ the above FOR loop.  Since all pages must be in the same segment, the ijle pointer is
{ the correct one.
{ The ijle pointer is saved in the wired tape request for use by iom$tape_queue_manager_mtr
{ to increment/decrement the active_cart_tape_write field of the ijl entry.

      ijle_p^.active_io_requests := ijle_p^.active_io_requests + 1;
      tape_request_p^.ijle_p := ijle_p;
    FOREND;

{ The following check is necessary in the case of error recovery.  In that situation,
{ the number of blocks being retried may be less than the original and therefore, the
{ total_list_entries will be less than the amount allocated.  For performance reasons,
{ a new allocated_address_pair_count is not re-calculated before retrying the IO.

    IF total_list_entries - 1 < tape_request_p^.allocated_address_pair_count THEN
      list_p^ [total_list_entries].length := 0;
    IFEND;

    tape_request_p^.list_p := list_p;
    tape_request_p^.address_pair_count := total_list_entries - 1;

  PROCEND mmp$build_lock_rma_list_tape;

?? TITLE := 'MMP$REMOVE_JWS_TO_SHARED_PAGES' ??
?? EJECT ??
{-----------------------------------------------------------------------------
{ If pages of a segment were being kept in a jws, but are now going to be kept
{ in the global queue, it is necessary to remove all pages of the segment from
{ the jws.  This procedure is called to remove the pages when a job shared file
{ segment is opened and more than one user has the file attached.
{ The swap state of the job the pages are being removed from (which is not the
{ job that issued the monitor request) must be considered.
{ If the job is executing or in a "safe" swap status, page will be removed.  If
{ swapout I/O is active, the monitor request will be reissued and a task switch
{ forced (the request will have to wait until the I/O has completed).  If the
{ job is swapped completely out, a delayed swapin bit will be set so that the
{ pages will be removed when the job swaps back in.
{ NOTE:  This request is usually issued because a second user has attached a
{ read only file and the file is now being shared.  The request is also used
{ to remove pages from the JWS when the flush_pages request for a detach_file
{ fails.  When that happens the FDE for the file is turned into a global_shared
{ file.  The AST entry and all pages must reflect that the file is shared.
{ ALSO NOTE:  In the flush-detach fail case, the job which has the pages in
{ its working set cannot be swapped out, because it is issuing the monitor
{ request.
{-----------------------------------------------------------------------------

  PROCEDURE mmp$remove_jws_to_shared_pages
    (    fde_p: gft$locked_file_desc_entry_p;
         cst_p: ^ost$cpu_state_table;
     VAR rb: mmt$rb_ring1_segment_request);

    VAR
      asid: ost$asid,
      aste_p: ^mmt$active_segment_table_entry,
      count_removed: integer,
      dsw_job_shared_asid_changed: [STATIC] jmt$delayed_swapin_work := [jmc$dsw_job_shared_asid_changed],
      ijle_p: ^jmt$initiated_job_list_entry,
      i: integer,
      inhibit_io: boolean,
      jws_ijl_ordinal: jmt$ijl_ordinal,
      next_pfti: mmt$page_frame_index,
      pfti: mmt$page_frame_index,
      pfte_p: ^mmt$page_frame_table_entry,
      queue_id: mmt$page_frame_queue_id,
      sdte_p: ^mmt$segment_descriptor,
      system_ijle_p: ^jmt$initiated_job_list_entry;

    rb.status.normal := TRUE;
    aste_p := ^mmv$ast_p^ [fde_p^.asti];

{ The file may already be shared.  In that case nothing needs to be done.

    IF (aste_p^.queue_id > mmc$pq_shared_last)  THEN
      jws_ijl_ordinal := aste_p^.ijl_ordinal;
      IF NOT (jmp$ijl_block_valid (jws_ijl_ordinal)) THEN
        RETURN;
      IFEND;

      jmp$get_ijle_p (jws_ijl_ordinal, ijle_p);

{ If swapout I/O is active, cause the task to cycle until the swapout I/O has completed.
{ Do not change any AST fields now if the request has to be reissued.

      IF (ijle_p^.swap_status >= jmc$iss_initiate_swapout_io) AND (ijle_p^.swap_status <=
            jmc$iss_swapout_io_complete) THEN

        tmp$reissue_monitor_request;
        tmp$cause_task_switch;

      ELSE

{ The pages of this segment were being kept in a JWS queue but are now going to be kept in
{ one of the shared queues, all pages must be removed from the JWS.  The procedure called
{ will remove the pages immediately if the job is addressable; if the job is swapped out,
{ a delayed swapin bit will be set in the job's ijl entry and the pages will be removed
{ when the job swaps in.  The segment must be changed to reflect that it is now being
{ shared before the call to the remove procedure; the ijlo passed into the remove procedure
{ must be the ijlo of the job that we need to remove the pages from.
{ First, determine which Shared Queue will be used.  NOTE:  A segment number of zero indicates
{ that this request was issued because a flush pages on detach_file failed.  In that case, do
{ not store the asid/asti in the segment table; use shared_other queue.

        IF rb.server_file THEN
          IF (fde_p^.queue_ordinal <> 0 ) AND
                (fde_p^.queue_ordinal <= mmv$last_active_shared_queue) THEN
            aste_p^.queue_id := fde_p^.queue_ordinal;
          ELSE
            aste_p^.queue_id := mmc$pq_shared_file_server;
          IFEND;
        ELSEIF rb.segment_number <> 0 THEN
          sdte_p := mmp$get_sdt_entry_p (cst_p^.xcb_p, rb.segment_number);
          sdte_p^.asti := fde_p^.asti;
          mmp$asid (fde_p^.asti, asid);
          sdte_p^.ste.asid := asid;
          aste_p^.queue_id := mmp$determine_shared_queue_id (fde_p, sdte_p);
        ELSE
          aste_p^.queue_id := mmc$pq_shared_other;
        IFEND;

        aste_p^.ijl_ordinal := jmv$system_ijl_ordinal;
        jmp$get_ijle_p (jmv$system_ijl_ordinal, system_ijle_p);

{ Scan the pages in memory belonging to the segment.  Store pfti's of working set pages so they
{ can be removed.  Adjust I/O counts for pages in the available modified queue.

        count_removed := 0;
        mmp$reset_store_pfti;
        pfti := aste_p^.pft_link.fwd;
        WHILE pfti <> 0 DO
          pfte_p := ^mmv$pft_p^ [pfti];
          IF pfte_p^.queue_id = mmc$pq_job_working_set THEN
            mmp$store_pfti (pfti);
          ELSEIF (pfte_p^.queue_id = mmc$pq_avail_modified) OR
                (pfte_p^.queue_id = mmc$pq_shared_io_error) THEN
            ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count - pfte_p^.active_io_count;
            ijle_p^.active_io_page_count := ijle_p^.active_io_page_count - pfte_p^.active_io_count;
            system_ijle_p^.inhibit_swap_count := system_ijle_p^.inhibit_swap_count + pfte_p^.
                  active_io_count;
            system_ijle_p^.active_io_page_count := system_ijle_p^.active_io_page_count + pfte_p^.
                  active_io_count;
            pfte_p^.ijl_ordinal := jmv$system_ijl_ordinal;
          IFEND;
          pfti := mmv$pft_p^ [pfti].segment_link.fwd;
        WHILEND;

        IF (ijle_p^.swap_status <= jmc$iss_swapped_io_cannot_init) OR (ijle_p^.swap_status =
              jmc$iss_swapped_io_complete) THEN

          mmp$fetch_pfti_array_size (count_removed);
          IF count_removed > 0 THEN
            mmp$reset_find_next_pfti (pfti);
            WHILE pfti <> 0 DO
              pfte_p := ^mmv$pft_p^ [pfti];
              mmp$relink_page_frame (pfti, pfte_p^.aste_p^.queue_id);
              ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count - pfte_p^.active_io_count;
              ijle_p^.active_io_page_count := ijle_p^.active_io_page_count - pfte_p^.active_io_count;
              system_ijle_p^.inhibit_swap_count := system_ijle_p^.inhibit_swap_count + pfte_p^.
                    active_io_count;
              system_ijle_p^.active_io_page_count := system_ijle_p^.active_io_page_count + pfte_p^.
                    active_io_count;
              pfte_p^.ijl_ordinal := jmv$system_ijl_ordinal;
              mmp$find_next_pfti (pfti);
            WHILEND;

            IF ((ijle_p^.swap_status >= jmc$iss_job_idle_tasks_complete) AND (ijle_p^.swap_status <=
                  jmc$iss_swapped_io_cannot_init)) OR (ijle_p^.swap_status = jmc$iss_swapped_io_complete) THEN
              jsp$recalculate_swapped_pages (ijle_p, count_removed);
            IFEND;
          IFEND;
        ELSE
          ijle_p^.delayed_swapin_work := ijle_p^.delayed_swapin_work + dsw_job_shared_asid_changed;
        IFEND;
      IFEND;
    IFEND;

  PROCEND mmp$remove_jws_to_shared_pages;


?? TITLE := '[XDCL] mmp$remove_swapped_shared_pages', EJECT ??
{-----------------------------------------------------------------------------
{ This procedure is called on swapin to remove job shared pages from the working
{ set of a job that is swapping in.  The job was swapped out when the when a job
{ shared file was attached by a second job, causing a working-set-to-shared
{ transition.  At the time of the transition a delayed_swapin_work indicator
{ was set for the job.  The job's entire working set must be scanned for pages
{ that should no be in the shared queue.
{-----------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$remove_swapped_shared_pages
    (    ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      next_pfti: mmt$page_frame_index,
      pfti: mmt$page_frame_index,
      pfte_p: ^mmt$page_frame_table_entry,
      system_ijle_p: ^jmt$initiated_job_list_entry;

      { Scan the job_working_set queue; any pages for which the ast.queue_id is the global
      { queue need to be removed and put in the available queue.

    jmp$get_ijle_p (jmv$system_ijl_ordinal, system_ijle_p);

    pfti := ijle_p^.job_page_queue_list [mmc$pq_job_working_set].link.bkw;
    WHILE pfti <> 0 DO
      pfte_p := ^mmv$pft_p^ [pfti];
      next_pfti := pfte_p^.link.bkw;
      IF (pfte_p^.aste_p^.queue_id >= mmc$pq_shared_first) AND
            (pfte_p^.aste_p^.queue_id <= mmc$pq_shared_last)  THEN
        mmp$relink_page_frame (pfti, pfte_p^.aste_p^.queue_id);
        ijle_p^.inhibit_swap_count := ijle_p^.inhibit_swap_count - pfte_p^.active_io_count;
        ijle_p^.active_io_page_count := ijle_p^.active_io_page_count - pfte_p^.active_io_count;
        system_ijle_p^.inhibit_swap_count := system_ijle_p^.inhibit_swap_count + pfte_p^.
              active_io_count;
        system_ijle_p^.active_io_page_count := system_ijle_p^.active_io_page_count + pfte_p^.
              active_io_count;
        pfte_p^.ijl_ordinal := jmv$system_ijl_ordinal;
      IFEND;
      pfti := next_pfti;
    WHILEND;

  PROCEND mmp$remove_swapped_shared_pages;

?? TITLE := 'MMP$REMOVE_DETACHED_PAGES', EJECT ??
{---------------------------------------------------------------------
{ This procedure removes job working set pages of a file being detached
{ from the working set of the job doing the detach.
{---------------------------------------------------------------------

  PROCEDURE mmp$remove_detached_pages
    (    sva: ost$system_virtual_address;
         aste_p: ^mmt$active_segment_table_entry;
         ijl_ordinal: jmt$ijl_ordinal);

    VAR
      pfti: mmt$page_frame_index;

    mmp$initialize_find_next_pfti (sva, 7ffffff0(16), include_partial_pages, psc_nominal_queue, aste_p,
          pfti);
    WHILE pfti <> 0 DO
      IF (mmv$pft_p^ [pfti].queue_id > mmc$pq_first_valid_in_pt) THEN
        IF mmv$pft_p^ [pfti].locked_page = mmc$lp_page_in_lock THEN
          mmp$delete_pt_entry (pfti, TRUE);
          mmp$relink_page_frame (pfti, mmc$pq_free);
        ELSE
          mmp$remove_page_from_job (pfti);
        IFEND;
        mmv$pft_p^ [pfti].locked_page := mmc$lp_not_locked;
      IFEND;
      mmp$find_next_pfti (pfti);
    WHILEND;

  PROCEND mmp$remove_detached_pages;

?? TITLE := 'MMP$REMOVE_PAGES_WORKING_SET' ??
?? EJECT ??
{---------------------------------------------------------------------
{This procedure removes pages from a job working set or shared working set
{All pages totally or partially contained between SVA to SVA + LENGTH are
{moved to the AVAILABLE or AVAILABLE-MODIFIED queue.
{---------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$remove_pages_working_set
    (    sva: ost$system_virtual_address;
         length: ost$segment_length;
         aste_p: ^mmt$active_segment_table_entry;
     VAR rcount: integer);

    VAR
      cst_p: ^ost$cpu_state_table,
      mcount: integer,
      pfti: mmt$page_frame_index;

{ #### CHECK THIS ALGORITHM CAREFULLY.  Consider restricted attach/detach, job shared files, restricted
{ #### attach/detach of global shared files.

    mtp$cst_p (cst_p);

{ Do not remove pages from the shared queue, nor from another job's working set.

    IF (aste_p^.queue_id <> mmc$pq_job_working_set) OR (aste_p^.ijl_ordinal <> cst_p^.ijl_ordinal) THEN
      RETURN;
    IFEND;

    mmp$initialize_find_next_pfti (sva, length, include_partial_pages, psc_nominal_queue, aste_p, pfti);
    IF pfti = 0 THEN
      rcount := 0;
      RETURN
    IFEND;

{ Delete locked pages from the array of pages to be removed.
{ ### There should be a better way of doing this than scanning the whole array.

    WHILE pfti <> 0 DO

      IF mmv$pft_p^ [pfti].locked_page <> mmc$lp_not_locked THEN
          mmp$delete_last_pfti_from_array;
      IFEND;
      mmp$find_next_pfti (pfti);
    WHILEND;

    mmp$remove_pages_from_jws (mmc$pq_avail_modified, cst_p^.ijle_p, mcount, rcount);

  PROCEND mmp$remove_pages_working_set;

?? TITLE := 'MMP$MM_FREE_PAGES' ??
?? EJECT ??
{---------------------------------------------------------------------
{This procedure frees (moves the page frames to the free page queue) all
{pages TOTALLY contained in the range SVA to SVA + LENGTH.
{NOTE that modified pages are NOT written to disk.
{If ASID is to be freed, map is not purged prior to deleting page frames.
{---------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$mm_free_pages
    (    sva: ost$system_virtual_address;
         length: ost$segment_length;
         aste_p: ^mmt$active_segment_table_entry;
         free_asid: boolean;
     VAR count: integer);

    VAR
      contiguous_pages: integer,
      first_pfti: mmt$page_frame_index,
      ijl_p: ^jmt$initiated_job_list_entry,
      pfti: mmt$page_frame_index;

    count := 0;

    mmp$initialize_find_next_pfti (sva, length, exclude_partial_pages, psc_all, aste_p, pfti);

    IF NOT free_asid THEN
      WHILE pfti <> 0 DO
        mmv$pt_p^ [mmv$pft_p^ [pfti].pti].v := FALSE;
        mmp$find_next_pfti (pfti);
      WHILEND;
      mmp$purge_all_cache_map;
      mmp$reset_find_next_pfti (pfti);
    IFEND;

    WHILE pfti <> 0 DO
      mmp$delete_pt_entry (pfti, TRUE);
      mmp$relink_page_frame (pfti, mmc$pq_free);
      count := count + 1;
      mmp$find_next_pfti (pfti);
    WHILEND;

    IF aste_p^.queue_id = mmc$pq_job_fixed THEN
      jmp$get_ijle_p (aste_p^.ijl_ordinal, ijl_p);
      contiguous_pages := 0;
      first_pfti := ijl_p^.job_page_queue_list [mmc$pq_job_fixed].link.bkw;
      IF (mmv$pft_p^ [first_pfti].sva.offset <> 0) THEN
        WHILE mmv$pft_p^ [first_pfti].sva.offset <> 0 DO
          contiguous_pages := contiguous_pages + 1;
          first_pfti := mmv$pft_p^ [first_pfti].link.bkw;
        WHILEND;
      IFEND;
      ijl_p^.job_fixed_contiguous_pages := contiguous_pages;
      mmv$total_contig_pages_assigned := mmv$total_contig_pages_assigned - contiguous_pages;
    IFEND;
    IF free_asid THEN
      mmp$free_asid (sva.asid, aste_p);
    IFEND;

  PROCEND mmp$mm_free_pages;

?? TITLE := 'MMP$MM_WRITE_MODIFIED_PAGES' ??
?? EJECT ??
{---------------------------------------------------------------------
{Name:
{  mmp$mm_write_modified_pages
{Purpose:
{  This procedure writes all modified pages within a specified SVA range
{  to the backing file for the segment.  All pages totally or partially
{  contained in the range of SVA to SVA + LENGTH are written.
{
{  If init_new_io is FALSE then the monitor request has been reissued
{  and only status will be returned.   Job mode sets init_new_io to TRUE
{  in the RB and mmp$process_wmp_status or mmp$mtr_write will set it
{  to FALSE if the wait option is selected.
{---------------------------------------------------------------------


  PROCEDURE [XDCL] mmp$mm_write_modified_pages
    (    sva: ost$system_virtual_address;
         length: ost$segment_length;
         fde_p: gft$locked_file_desc_entry_p;
         aste_p: ^mmt$active_segment_table_entry;
         iotype: iot$io_function;
         init_new_io: boolean;
         remove_page: boolean;
         io_id: mmt$io_identifier;
     VAR io_count: mmt$active_io_count;
     VAR io_already_active: boolean;
     VAR last_written_pfti: mmt$page_frame_index;
     VAR wmp_status: mmt$write_modified_pages_status);

    VAR
      cst_p: ^ost$cpu_state_table,
      write_status: mmt$write_page_to_disk_status,
      pfti: mmt$page_frame_index;

    io_count := 0;
    io_already_active := FALSE;
    wmp_status := mmc$wmp_io_complete;
    last_written_pfti := 0;

    mtp$cst_p (cst_p);
    mmp$initialize_find_next_pfti (sva, length, include_partial_pages, psc_all_except_avail, aste_p, pfti);

    IF init_new_io THEN
    /write_loop/
      WHILE pfti <> 0 DO
        IF mmv$pt_p^ [mmv$pft_p^ [pfti].pti].m THEN
        /write_to_disk/
          BEGIN
          mmp$write_page_to_disk (fde_p, pfti, iotype, io_id, mmv$multi_page_write, write_status);
          IF write_status = ws_ok THEN
            last_written_pfti := pfti;

            IF io_id.specified THEN
              io_count := io_count + 1;
            IFEND;

          ELSEIF write_status = ws_disk_flaws THEN
            wmp_status := mmc$wmp_io_errors;
          ELSEIF write_status = ws_volume_unavailable THEN
            wmp_status := mmc$wmp_volume_unavailable;
          ELSEIF write_status = ws_server_terminated THEN
            wmp_status := mmc$wmp_server_terminated;
          ELSE
            wmp_status := mmc$wmp_io_initiation_reject;
            EXIT /write_loop/;
          IFEND;

          END /write_to_disk/;
        ELSEIF (mmv$pft_p^ [pfti].active_io_count <> 0) AND (last_written_pfti = 0) THEN
          last_written_pfti := pfti;
          IF io_id.specified THEN
            io_already_active := TRUE;
          IFEND;
        IFEND;

        { REMOVE_PAGE is true only if the request code is mmc$sr1_detach_file.
        { When a permanent file is detached, if the pages are being kept in a job's working set
        { all those pages must be removed.
{ ###!!   The ijl ordinal check is needed to prevent a "restricted" attach/detach (access mode = none)
        { from removing pages from the working set of the job that really has the file attached.
        { (There is a timing problem--if the real detach and a new shared attach occurrs before the
        { restricted detach, the queue status will incorrectly remain working set for a shared file.)
        { When perm files cleans up the restricted attach, the ijl ordinal check can probably be removed.

        IF (remove_page) AND (mmv$pft_p^ [pfti].queue_id > mmc$pq_first_valid_in_pt) AND
              NOT (mmv$pt_p^ [mmv$pft_p^ [pfti].pti].m) AND (mmv$shared_pages_in_jws) AND
              (aste_p^.queue_id = mmc$pq_job_working_set) AND (mmv$pft_p^ [pfti].ijl_ordinal =
              cst_p^.ijl_ordinal) THEN
          IF (mmv$pft_p^ [pfti].locked_page = mmc$lp_page_in_lock) OR
                (mmv$pft_p^ [pfti].locked_page = mmc$lp_server_allocate_lock) THEN
            mmp$delete_pt_entry (pfti, TRUE);
            mmp$relink_page_frame (pfti, mmc$pq_free);
          ELSE
            mmp$remove_page_from_job (pfti);
          IFEND;
          mmv$pft_p^ [pfti].locked_page := mmc$lp_not_locked;
        IFEND;
        mmp$find_next_pfti (pfti);
      WHILEND /write_loop/;
    ELSE
    /status_loop/
      WHILE pfti <> 0 DO
        IF mmv$pt_p^ [mmv$pft_p^ [pfti].pti].m THEN
          IF (mmv$pft_p^ [pfti].queue_id = mmc$pq_job_io_error) OR
                (mmv$pft_p^ [pfti].queue_id = mmc$pq_shared_io_error) THEN
            IF (mmv$pft_p^ [pfti].io_error <> ioc$unrecovered_error_unit_down) AND
                  (mmv$pft_p^ [pfti].io_error <> ioc$unit_down_on_init) THEN
              wmp_status := mmc$wmp_io_errors;
            ELSE
              wmp_status := mmc$wmp_volume_unavailable;
            IFEND;
          IFEND;

        ELSEIF (mmv$pft_p^ [pfti].active_io_count <> 0)  THEN
          last_written_pfti := pfti;
          IF io_id.specified THEN
            io_already_active := TRUE;
          IFEND;
        IFEND;

        mmp$find_next_pfti (pfti);
      WHILEND /status_loop/;
    IFEND;

    IF io_id.specified THEN
      IF (io_count > 0) AND (wmp_status = mmc$wmp_io_complete) THEN
        wmp_status := mmc$wmp_io_active;
      IFEND;
    ELSE
      IF (last_written_pfti <> 0) AND (wmp_status <> mmc$wmp_volume_unavailable) AND
           (wmp_status <> mmc$wmp_io_initiation_reject) THEN
        wmp_status := mmc$wmp_io_active;
      IFEND;
    IFEND;

  PROCEND mmp$mm_write_modified_pages;

?? TITLE := 'MMP$PROCESS_WMP_STATUS' ??
?? EJECT ??

{----------------------------------------------------------------------------------------
{Name:
{  mmp$process_wmp_status
{Purpose:
{  This procedure processes the status returned by mmp$mm_write_modified_pages.  If
{  IO inititation was not completed the monitor request will be reissued.  If the
{  wait option was selected, init_new_io in the RB will be set to FALSE and the
{  monitor request reissued.
{
{  Rb_init_new_io and rb_status are input/output parameters and should not be initialized.
{
{----------------------------------------------------------------------------------------


  PROCEDURE [XDCL] mmp$process_wmp_status (wmp_status: mmt$write_modified_pages_status;
        last_written_pfti: mmt$page_frame_index;
        rb_wait: ost$wait;
        VAR rb_init_new_io: boolean;
        VAR rb_status: syt$monitor_status);

    VAR cst_p: ^ost$cpu_state_table;

    mtp$cst_p (cst_p);

    CASE wmp_status OF
    = mmc$wmp_io_initiation_reject =
      IF last_written_pfti <> 0 THEN
        IF mmv$pft_p^[last_written_pfti].active_io_count = 0 THEN
          mtp$error_stop('MM - WMP tried to queue and no IO');
        IFEND;
        tmp$queue_task(cst_p^.taskid, tmc$ts_page_wait, mmv$pft_p^[last_written_pfti].task_queue);
        tmp$reissue_monitor_request;
      ELSE
        tmp$reissue_monitor_request;
        tmp$cause_task_switch;
      IFEND;

    = mmc$wmp_io_complete =

    = mmc$wmp_io_active =
      IF rb_wait = osc$wait THEN
        IF mmv$pft_p^[last_written_pfti].active_io_count = 0 THEN
          mtp$error_stop('MM - WMP tried to queue and no IO');
        IFEND;
        tmp$queue_task(cst_p^.taskid, tmc$ts_page_wait, mmv$pft_p^[last_written_pfti].task_queue);
        rb_init_new_io := FALSE;
        tmp$reissue_monitor_request;
      IFEND;

    = mmc$wmp_volume_unavailable =
      mtp$set_status_abnormal ('MM', mme$volume_unavailable, rb_status);

    = mmc$wmp_io_errors =
      mtp$set_status_abnormal ('MM', mme$io_write_error, rb_status);

    = mmc$wmp_server_terminated =
      mtp$set_status_abnormal ('DF', dfe$server_has_terminated, rb_status);

    CASEND;

  PROCEND mmp$process_wmp_status;


?? TITLE := 'MMP$MM_CONDITIONAL_FREE' ??
?? EJECT ??

{ Purpose:
{   This procedure conditionally frees pages of a segment in the address range of SVA to
{   SVA + LENGTH - 1.  The modified bits are cleared to prevent writing the pages to disk.
{   The pages will remain in the job's working set though in case they are referenced again
{   soon.  Normal aging will move the pages to the free queue when they are no longer being
{   referenced.

  PROCEDURE mmp$mm_conditional_free (sva: ost$system_virtual_address;
        length: ost$segment_length;
        aste_p: ^mmt$active_segment_table_entry);

    VAR
      pfte_p: ^mmt$page_frame_table_entry,
      pfti: mmt$page_frame_index,
      pte_p: ^ost$page_table_entry,
      purge_all_page_maps: boolean;

    purge_all_page_maps := FALSE;

    mmp$initialize_find_next_pfti (sva, length, exclude_partial_pages, psc_all_except_avail, aste_p, pfti);
    WHILE pfti <> 0 DO
      pfte_p := ^mmv$pft_p^ [pfti];
      pte_p := ^mmv$pt_p^ [pfte_p^.pti];
      IF (pfte_p^.queue_id = mmc$pq_avail_modified) AND (pfte_p^.active_io_count = 0) THEN
        pte_p^.m := FALSE;

{ Whenever the modified bit is cleared on a page in the available_modified queue that does not have
{ I/O active, the SOON count must be incremented.  When relink_page_frame takes an UNMODIFIED page out
{ of the available_modified queue, it assumes I/O has been done and will decrement the soon count.

        mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon + 1;
        mmp$relink_page_frame (pfti, mmc$pq_avail);
      ELSEIF pte_p^.v THEN

{ Pages must be removed from the io error queues before the modified bit is cleared.

        IF (pfte_p^.queue_id = mmc$pq_shared_io_error) OR (pfte_p^.queue_id = mmc$pq_job_io_error) THEN
          mmp$relink_page_frame (pfti, pfte_p^.aste_p^.queue_id);
        IFEND;
        pte_p^.m := FALSE;
        IF pte_p^.u THEN
          pte_p^.u := FALSE;
          pfte_p^.age := 0;
          pfte_p^.cyclic_age := 0;
        IFEND;
        purge_all_page_maps := TRUE;
      IFEND;
      mmp$find_next_pfti (pfti);
    WHILEND;

    IF purge_all_page_maps THEN
      mmp$sva_purge_all_page_map (sva);
    IFEND;

  PROCEND mmp$mm_conditional_free;

?? TITLE := 'MMP$FREE_FLUSH' ??
?? EJECT ??
{--------------------------------------------------------------------------------------------------------
{Name:
{  mmp$free_flush
{Purpose:
{  This routine processes the 'FREE' , 'WRITE MODIFIED PAGES', and
{  'CONDITIONAL FREE' requests
{Input:
{  rb - request block
{Output:
{  none
{Error Codes:
{  invalid PVA
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$free_flush
    (VAR rb: mmt$rb_free_flush;
         cst_p: ^ost$cpu_state_table);

    VAR
      fde_p: gft$locked_file_desc_entry_p,
      wmp_status: mmt$write_modified_pages_status,
      last_written_pfti: mmt$page_frame_index,
      ste_p: ^mmt$segment_descriptor,
      stxe_p: ^mmt$segment_descriptor_extended,
      aste_p: ^mmt$active_segment_table_entry,
      page_count: integer,
      io_id: mmt$io_identifier,
      io_count: mmt$active_io_count,
      io_already_active: boolean,
      sva: ost$system_virtual_address;


    io_id.specified := FALSE;

    IF NOT mmv$tables_initialized THEN
      RETURN
    IFEND;
    #KEYPOINT (osk$entry, rb.reqcode * osk$m, mmk$free_flush);
    rb.status.normal := TRUE;


{Free pages.
    IF cst_p^.xcb_p^.xp.p_register.pva.ring > 3 THEN
      mmp$verify_pva (^rb.pva, mmc$sat_write, rb.status);
    ELSE
      mmp$verify_pva (^rb.pva, mmc$sat_read_or_write, rb.status);
    IFEND;
    IF rb.status.normal THEN
      mmp$convert_pva (rb.pva, cst_p, sva, fde_p, aste_p, ste_p, stxe_p);
      CASE rb.reqcode OF
      = syc$rc_write_modified_pages =
        IF (aste_p^.queue_id <> mmc$pq_job_working_set) AND ((aste_p^.queue_id < mmc$pq_shared_first) OR
               (aste_p^.queue_id > mmc$pq_shared_last)) THEN     {Queue_id is neither JWS nor a shared queue}
          mtp$set_status_abnormal ('MM', mme$segment_not_pageable, rb.status);
        ELSEIF (fde_p^.media = gfc$fm_transient_segment) OR
            (stxe_p^.assign_active <> mmc$assign_active_null) THEN
          mtp$set_status_abnormal ('MM', mme$segment_not_assigned_device, rb.status);
        ELSE
          mmp$mm_write_modified_pages (sva, rb.length, fde_p, aste_p, ioc$write_page, rb.init_new_io, FALSE,
                io_id, io_count, io_already_active, last_written_pfti, wmp_status);
          mmp$process_wmp_status (wmp_status, last_written_pfti, rb.waitopt, rb.init_new_io, rb.status);
        IFEND;
      = syc$rc_free_pages =
        mmp$mm_free_pages (sva, rb.length, aste_p, FALSE, page_count);
      = syc$rc_conditional_free =
        mmp$mm_conditional_free (sva, rb.length, aste_p);
      ELSE
        mtp$set_status_abnormal ('MM', mme$invalid_request, rb.status);
      CASEND;
    IFEND;


    #KEYPOINT (osk$exit, 0, mmk$free_flush);
  PROCEND mmp$free_flush;
?? TITLE := 'MMP$MOVE_MODIFIED_SERVER_PAGE', EJECT ??
{-------------------------------------------------------------------------------------------------------------
{ NAME:
{   MMP$MOVE_MODIFIED_SERVER_PAGE
{ PURPOSE:
{   This monitor request will move a page frame from a source file , specified by a system_file_id, to a
{ destination file.  It is used to update the server image file on the client in the case of a server crash.
{ When the request completes, the page in the range from <rb.byte_offset> to <rb.byte_offset>+ <osv$page_size>
{ will have been moved to the range of addresses specified by <rb.destination_pva> to <rb.destination_pva>+
{ <osv$page_size>.  This procedure assumes that <rb.destination_pva> is on a page boundary.  The procedure
{ executes in monitor mode on behalf of a system task which writes the server image file with pages from all
{ of the currently attached server files.
{
{ CAUTION:  Be sure to fully understand how the 'move' is accomplished before changing this
{           procedure.  Because mmp$delete_pt_entry USES information and mmp$make_pt_entry
{           CHANGES information in the page frame table entry, it is necessary to 'move' the
{           page in the following order:
{             1.  Delete the source page table entry.
{             2.  Change the page frame table entry to reflect destination page information.
{             3.  Make the page table entry for the destination page.
{             4.  If necessary, relink the page frame to the queue for the destination segment.
{             5.  Set the valid bit on the destination page.
{
{ PROCEDURE [XDCL] mmp$move_modified_server_page
{   (VAR rb: mmt$rb_ring1_server_seg_request;
{        cst_p: ^ost$cpu_state_table);
{
{   RB: (INPUT/OUTPUT) Specifies the request block containing the information
{       which will be used by the procedure to move (if possible) a single page
{       to the destination (server image) file.
{         RB.SFID: Specifies the System File ID of the file whose pages must be
{            moved to the destination file
{         RB.GLOBAL_FILE_NAME: Specifies the global file name of the file whose
{            pages must be moved to the destination file
{         RB.DESTINATION_PVA: Specifies the location within the server image
{            file to which a located modified page will be written
{         RB.BYTE_OFFSET: Specifies the beginning offset of the located page
{            which has been moved.  This is an output value.
{         RB.STATUS: Specifies the completion status of the request.  Conditions
{            which can be returned are:
{              mme$io_active_on_move_page
{              mme$no_pages_found_for_move
{              mme$page_table_full
{   CST_P: (INPUT) Specifies the pointer to the CPU state table which is
{       executing this process.
{-------------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$move_modified_server_page
    (VAR rb: mmt$rb_ring1_server_seg_request;
         cst_p: ^ost$cpu_state_table);

?? NEWTITLE := '  DETERMINE_MOVE_PAGE_STATUS', EJECT ??

    PROCEDURE [INLINE] determine_move_page_status
      (    pfti: mmt$page_frame_index;
           fde_p: gft$locked_file_desc_entry_p;
       VAR move_page: boolean;
       VAR lock_encountered: boolean);

      VAR
        pft_entry_p: ^mmt$page_frame_table_entry;

      move_page := FALSE;
      pft_entry_p := ^mmv$pft_p^ [pfti];

      IF NOT mmv$pt_p^ [pft_entry_p^.pti].m THEN
        RETURN;
      IFEND;

{ The page is not valid for the move to the image if the page lock indicates the page doesn't contain data
{ (page is being read from disk or server allocation is occurring) or the user has locked the page to prevent
{ IO.

      IF (pft_entry_p^.locked_page = mmc$lp_aging_lock) OR
            (pft_entry_p^.locked_page = mmc$lp_server_allocate_lock) OR
            (pft_entry_p^.locked_page = mmc$lp_page_in_lock) THEN
        lock_encountered := TRUE;
        RETURN;
      IFEND;

{ The page is not valid for the move to the image if the segment is locked (MMP$LOCK_SEGMENT) UNLESS the page
{ is still being written from a previous MMP$UNLOCK_SEGMENT with write_protection.

      IF fde_p^.segment_lock.locked_for_write AND
            (pft_entry_p^.locked_page <> mmc$lp_write_protected_lock) THEN
        lock_encountered := TRUE;
        RETURN;
      IFEND;

      move_page := TRUE;

    PROCEND determine_move_page_status;
?? OLDTITLE, EJECT ??

    VAR
      asid: ost$asid,
      aste_p: ^mmt$active_segment_table_entry,
      asti: mmt$ast_index,
      count: 1 .. 32,
      destination_aste_p: ^mmt$active_segment_table_entry,
      destination_pfte_p: ^mmt$page_frame_table_entry,
      destination_pfti: mmt$page_frame_index,
      destination_pti: integer,
      destination_ste_p: ^mmt$segment_descriptor,
      destination_stxe_p: ^mmt$segment_descriptor_extended,
      destination_sva: ost$system_virtual_address,
      fde_p: gft$locked_file_desc_entry_p,
      found: boolean,
      lock_encountered: boolean,
      move_page: boolean,
      mpt_status: mmt$make_pt_entry_status,
      pfti: mmt$page_frame_index,
      save_valid: boolean,
      source_aste_p: ^mmt$active_segment_table_entry,
      source_sva: ost$system_virtual_address;


    rb.status.normal := TRUE;

{ Set up variables for the search through the ASTE for pages associated with the RB.SFID.

    gfp$mtr_get_locked_fde_p (rb.sfid, cst_p^.ijle_p, fde_p);
    mmp$get_verify_asti_in_fde (fde_p, rb.sfid, cst_p^.ijl_ordinal, asti);
    IF asti = 0 THEN
      mtp$set_status_abnormal ('MM', mme$no_pages_found_for_move, rb.status);
      RETURN;
    IFEND;

    mmp$asid (asti, asid);
    source_sva.asid := asid;

    mmp$verify_pva (^rb.destination_pva, mmc$sat_write, rb.status);
    IF NOT rb.status.normal THEN
      RETURN;
    IFEND;

    mmp$convert_pva (rb.destination_pva, cst_p, destination_sva, fde_p, destination_aste_p, destination_ste_p,
          destination_stxe_p);

    source_aste_p := ^mmv$ast_p^ [asti];

{ Start looking through the aste_p^.pft_link for modified pages.  Free those pages which are not modified
{ and have no IO active on them.

    pfti := source_aste_p^.pft_link.fwd;
    lock_encountered := FALSE;

    /locate_a_modified_page/
    WHILE (pfti <> 0) AND (mmv$pft_p^ [pfti].active_io_count = 0) DO
      save_valid := mmv$pt_p^ [mmv$pft_p^ [pfti].pti].v;
      mmv$pt_p^ [mmv$pft_p^ [pfti].pti].v := FALSE;
      mmp$purge_all_map_proc;
      determine_move_page_status (pfti, fde_p, move_page, lock_encountered);
      IF NOT move_page THEN
        IF dfv$file_server_debug_enabled AND lock_encountered THEN
          display_integer_monitor (' Lock encountered ', pfti);
        IFEND;
        mmp$delete_pt_entry (pfti, TRUE);
        mmp$relink_page_frame (pfti, mmc$pq_free);
        pfti := source_aste_p^.pft_link.fwd;
      ELSE
        mmv$pt_p^ [mmv$pft_p^ [pfti].pti].v := save_valid;
        EXIT /locate_a_modified_page/;
      IFEND;
    WHILEND /locate_a_modified_page/;

    IF pfti = 0 THEN
      mtp$set_status_abnormal ('MM', mme$no_pages_found_for_move, rb.status);
      mmp$purge_all_map_proc;
      IF lock_encountered THEN
        mmp$purge_all_cache_proc;
      IFEND;
      RETURN;
    ELSEIF (mmv$pft_p^ [pfti].active_io_count > 0) THEN
      mtp$set_status_abnormal ('MM', mme$io_active_on_move_page, rb.status);
      mmp$purge_all_map_proc;
      IF lock_encountered THEN
        mmp$purge_all_cache_proc;
      IFEND;
      RETURN;
    IFEND;

{ We have located a modified page of the file which now can be moved.
{ Delete the source page, but save the valid bit in case we need to restore the page table.
{ (The valid bit was saved as part of the operation to locate a page above.)

    source_sva.offset := mmv$pft_p^ [pfti].sva.offset;
    mmp$delete_pt_entry (pfti, TRUE);
    mmp$purge_all_cache_map_proc;

{ The destination page should not be in the page table; if it is, delete it.

    #hash_sva (destination_sva, destination_pti, count, found);
    IF found THEN
      destination_pfti := (mmv$pt_p^ [destination_pti].rma *512) DIV osv$page_size;
      mmp$delete_pt_entry (destination_pfti, TRUE);
      mmp$relink_page_frame (destination_pfti, mmc$pq_free);
    IFEND;

{ Change the page frame table entry to the destination page information.

    destination_pfte_p := ^mmv$pft_p^ [pfti];
    destination_pfte_p^.aste_p := destination_aste_p;
    destination_pfte_p^.sva := destination_sva;

{ Make the page table entry for the destination page.  If the page table is full, replace the source page to
{ the page table and return an abnormal status; job mode will reissue the request.

    mmp$make_pt_entry (destination_sva, pfti, destination_aste_p, destination_pfte_p, mpt_status);
    IF mpt_status = mmc$mpt_page_table_full THEN
      mmv$async_work.pt_full_aste_p := destination_aste_p;
      mmv$async_work.pt_full_sva := destination_sva;
      mmv$async_work.pt_full := TRUE;
      mmv$time_to_call_mem_mgr := 0;
      osv$time_to_check_asyn := 0;
      destination_pfte_p^.aste_p := source_aste_p;
      destination_pfte_p^.sva := source_sva;
      mmp$make_pt_entry (source_sva, pfti, source_aste_p, destination_pfte_p, mpt_status);
      IF mpt_status <> mmc$mpt_done THEN
        mtp$error_stop ('MOVE_MODIFIED_SERVER_PAGE -- COULD NOT REMAKE PAGE TABLE ENTRY');
      IFEND;
      mmv$pt_p^ [destination_pfte_p^.pti].m := TRUE;
      mmv$pt_p^ [destination_pfte_p^.pti].v := save_valid;
      mtp$set_status_abnormal ('MM', mme$page_table_full, rb.status);
      IF lock_encountered THEN
        mmp$purge_all_cache_proc;
      IFEND;
      RETURN;
    IFEND;

{ Relink the page into the destination's queue.

    mmv$pt_p^ [destination_pfte_p^.pti].v := TRUE;
    mmv$pt_p^ [destination_pfte_p^.pti].m := TRUE;

    mmp$relink_page_frame (pfti, mmc$pq_wired);
    mmv$pft_p^ [pfti].ijl_ordinal:= cst_p^.ijl_ordinal;
    mmp$relink_page_frame (pfti, destination_aste_p^.queue_id);

    IF lock_encountered THEN
      mmp$purge_all_cache_proc;
    IFEND;

    rb.byte_offset := source_sva.offset;

  PROCEND mmp$move_modified_server_page;
?? TITLE := 'MMP$MTR_R1_SERVER_SEG_REQUEST', EJECT ??
{--------------------------------------------------------------------------------------------------------
{ NAME:
{   MMP$MTR_R1_SERVER_SEG_REQUEST
{ PURPOSE:
{   This procedure processes some ring 1 requests for server segments.
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$mtr_r1_server_seg_request
    (VAR rb: mmt$rb_ring1_server_seg_request;
         cst_p: ^ost$cpu_state_table);

    VAR
      able: boolean,
      asid: ost$asid,
      aste_p: ^mmt$active_segment_table_entry,
      asti: mmt$ast_index,
      fde_p: gft$locked_file_desc_entry_p,
      ijle_p: ^jmt$initiated_job_list_entry,
      inhibit_io: boolean,
      mcount: integer,
      pfti: mmt$page_frame_index,
      rcount: integer,
      save_v: boolean,
      xsva: ost$system_virtual_address;


    CASE rb.request OF
    = mmc$ssr1_flush_delete_seg_sfid, mmc$ssr1_free_delete_seg_sfid =
      rb.pages_not_deleted := 0;
{ Do nothing. This is normal.
      ;
    = mmc$ssr1_move_modified_df_page =
      mmp$move_modified_server_page (rb, cst_p);
      RETURN;
    ELSE
      mtp$error_stop ('MM - Unknown request - mmp$mtr_r1_server_seg_request');
    CASEND;

{ Note: job mode has the FDE locked when making this request. This is required to
{ keep the FDE from being deleted by another job while this request is being processed.

    gfp$mtr_get_locked_fde_p (rb.sfid, cst_p^.ijle_p, fde_p);
    mmp$get_verify_asti_in_fde (fde_p, rb.sfid, cst_p^.ijl_ordinal, asti);
    IF (asti = 0) OR (fde_p^.attach_count = 0 ) THEN
      RETURN;
    IFEND;

    mmp$asid (asti, asid);
    xsva.asid := asid;
    xsva.offset := 0;
    aste_p := ^mmv$ast_p^ [asti];
    mmp$initialize_find_next_pfti (xsva, 7fffffff(16), include_partial_pages, psc_all, aste_p, pfti);

    WHILE pfti <> 0 DO
      IF (mmv$pft_p^ [pfti].aste_p <> NIL) AND (mmv$pft_p^ [pfti].aste_p^.sfid = rb.sfid) THEN
        mmp$get_inhibit_io_status (mmv$pft_p^ [pfti].ijl_ordinal, TRUE {lock ajl}, inhibit_io, ijle_p);
        IF NOT inhibit_io THEN
          save_v := mmv$pt_p^ [mmv$pft_p^ [pfti].pti].v;
          mmv$pt_p^ [mmv$pft_p^ [pfti].pti].v := FALSE;
          mmp$sva_purge_all_page_map (mmv$pft_p^ [pfti].sva);
          IF (NOT mmv$pt_p^ [mmv$pft_p^ [pfti].pti].m) AND (mmv$pft_p^ [pfti].locked_page = mmc$lp_not_locked)
                AND (mmv$pft_p^ [pfti].active_io_count = 0) THEN
            mmp$delete_pt_entry (pfti, TRUE);
            mmp$relink_page_frame (pfti, mmc$pq_free);
          ELSEIF mmv$pt_p^ [mmv$pft_p^ [pfti].pti].m AND (mmv$pft_p^ [pfti].locked_page = mmc$lp_not_locked)
                AND (mmv$pft_p^ [pfti].queue_id > mmc$pq_first_valid_in_pt) THEN
            IF rb.request = mmc$ssr1_flush_delete_seg_sfid THEN

{             MMP$REMOVE_PAGE_FROM_JWS does not neccessarily write the page to disk.  If it doesn't we may
{             have a problem in the future when we really want the page to go out to disk.

              mmv$pt_p^ [mmv$pft_p^ [pfti].pti].v := save_v;
              mmp$remove_page_from_jws (pfti, cst_p^.ijle_p, mcount, rcount);
              rb.pages_not_deleted := rb.pages_not_deleted + 1;
            ELSE {rb.request = mmc$ssr1_free_delete_seg_sfid }
              mmp$delete_pt_entry (pfti, TRUE);
              mmp$relink_page_frame (pfti, mmc$pq_free);
            IFEND;
          ELSEIF rb.request = mmc$ssr1_flush_delete_seg_sfid THEN
            mmv$pt_p^ [mmv$pft_p^ [pfti].pti].v := save_v;
            rb.pages_not_deleted := rb.pages_not_deleted + 1;
          IFEND;
          jmp$unlock_ajl (ijle_p);
        ELSE    { inhibit_io
          IF rb.request = mmc$ssr1_flush_delete_seg_sfid THEN
            rb.pages_not_deleted := rb.pages_not_deleted + 1;
          IFEND;
        IFEND;
      IFEND;
      mmp$find_next_pfti (pfti);
    WHILEND;

    IF aste_p <> NIL THEN
      IF aste_p^.pages_in_memory = 0 THEN
        IF jmp$ijl_block_valid (aste_p^.ijl_ordinal) AND
              (jmv$ijl_p.block_p^ [aste_p^.ijl_ordinal.block_number].index_p^
              [aste_p^.ijl_ordinal.block_index].entry_status <> jmc$ies_entry_free) THEN
          mmp$change_asid (aste_p, asid, 0, 0);
        ELSE
          fde_p^.asti := 0;
        IFEND;
        mmp$free_asid (asid, aste_p);
      IFEND;
    IFEND;

  PROCEND mmp$mtr_r1_server_seg_request;
?? TITLE := 'MMP$MTR_RING1_SEGMENT_REQUEST' ??
?? EJECT ??

{--------------------------------------------------------------------------------------------------------
{name:
{  mmp$mtr_ring1_segment_request
{purpose:
{ This procedure some ring 1 requests for segments.
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$mtr_ring1_segment_request
    (VAR rb: mmt$rb_ring1_segment_request;
         cst_p: ^ost$cpu_state_table);


    VAR
      asid: ost$asid,
      asid_can_be_deleted: boolean,
      aste_p: ^mmt$active_segment_table_entry,
      asti: mmt$ast_index,
      fde_p: gft$locked_file_desc_entry_p,
      first_image_pfti: 0 .. 0ffffffff(16),
      i: integer,
      ijle_p: ^jmt$initiated_job_list_entry,
      io_already_active: boolean,
      io_count: mmt$active_io_count,
      io_id: mmt$io_identifier,
      j: integer,
      last_written_pfti: mmt$page_frame_index,
      nowait_wait: [STATIC] array [boolean] of ost$wait := [osc$nowait, osc$wait],
      old_sfid: gft$system_file_identifier,
      page_count: integer,
      pfti: mmt$page_frame_index,
      sdte_p: ^mmt$segment_descriptor,
      sdtxe_p: ^mmt$segment_descriptor_extended,
      sva: ost$system_virtual_address,
      wmp_status: mmt$write_modified_pages_status,
      unrecovered_files: [STATIC] integer := 0,
      unrecovered_pages: [STATIC] integer := 0;


    #KEYPOINT (osk$entry, osk$m * $INTEGER (rb.request), mmk$ring1_segment_request);

    io_id.specified := FALSE;

    mmv$ring1_request_trace [$INTEGER (rb.request)] := mmv$ring1_request_trace [$INTEGER (rb.request)] + 1;

    rb.status.normal := TRUE;
    sva.asid := 0;

  /request/
    BEGIN
    CASE rb.request OF
    = mmc$sr1_detach_file =
      gfp$mtr_get_locked_fde_p (rb.sfid, cst_p^.ijle_p, fde_p);
      mmp$get_verify_asti_in_fde (fde_p, rb.sfid, cst_p^.ijl_ordinal, asti);
      IF asti <> 0 THEN
        aste_p := ^mmv$ast_p^ [asti];
        IF (fde_p^.queue_status = gfc$qs_job_shared) AND (aste_p^.queue_id <= mmc$pq_shared_last) THEN

{ The file is job-shared so there can be no modified pages; the pages are already in the shared queue so
{ they do not need to be removed from a job working set.  Therefore, nothing needs to be done.

          EXIT /request/;
        IFEND;
        mmp$asid (asti, asid);
        sva.asid := asid;
      ELSE
        EXIT /request/;
      IFEND;

    = mmc$sr1_delete_seg_sfid, mmc$sr1_flush_delete_seg_sfid =
      gfp$mtr_get_locked_fde_p (rb.sfid, cst_p^.ijle_p, fde_p);
      mmp$get_verify_asti_in_fde (fde_p, rb.sfid, cst_p^.ijl_ordinal, asti);
      IF asti <> 0 THEN
        mmp$asid (asti, asid);
        sva.asid := asid;
        aste_p := ^mmv$ast_p^ [asti];
      ELSE
        EXIT /request/;
      IFEND;

    = mmc$sr1_delete_job_seg_by_sfid =
      gfp$mtr_get_locked_fde_p (rb.sfid, cst_p^.ijle_p, fde_p);
      mmp$get_verify_asti_in_fde (fde_p, rb.sfid, cst_p^.ijl_ordinal, asti);
      IF (asti = 0) OR (mmv$ast_p^ [asti].ijl_ordinal <> cst_p^.ijl_ordinal) THEN
        EXIT /request/;
      IFEND;
      mmp$asid (asti, asid);
      sva.asid := asid;
      aste_p := ^mmv$ast_p^ [asti];

    = mmc$sr1_flush_avail_modified =
      gfp$mtr_get_fde_p (rb.sfid, cst_p^.ijle_p, fde_p);
      mmp$get_verify_asti_in_fde (fde_p, rb.sfid, cst_p^.ijl_ordinal, asti);
      IF asti <> 0 THEN
        mmp$asid (asti, asid);
        mmp$replenish_free_queues (asid);
      IFEND;
      EXIT /request/;

    = mmc$sr1_get_highest_offset =
      rb.highest_offset := 0;
      gfp$mtr_get_locked_fde_p (rb.file_sfid, cst_p^.ijle_p, fde_p);
      mmp$get_verify_asti_in_fde (fde_p, rb.file_sfid, cst_p^.ijl_ordinal, asti);
      IF asti = 0 THEN
        EXIT /request/;
      IFEND;
      aste_p := ^mmv$ast_p^ [asti];
      pfti := aste_p^.pft_link.fwd;

     /locate_highest_offset/
      WHILE pfti <> 0 DO
       IF mmv$pft_p^ [pfti].sva.offset > rb.highest_offset THEN
          rb.highest_offset := mmv$pft_p^ [pfti].sva.offset;
       IFEND;
        pfti := mmv$pft_p^ [pfti].segment_link.fwd;
      WHILEND /locate_highest_offset/;

      EXIT /request/;

    = mmc$sr1_delete_seg_segnum, mmc$sr1_flush_seg_segnum =
      sdtxe_p := mmp$get_sdtx_entry_p (cst_p^.xcb_p, rb.segnum);
      gfp$mtr_get_locked_fde_p (sdtxe_p^.sfid, cst_p^.ijle_p, fde_p);
      mmp$get_verify_asti_in_fde (fde_p, sdtxe_p^.sfid, cst_p^.ijl_ordinal, asti);
      IF asti <> 0 THEN
        mmp$asid (asti, asid);
        sva.asid := asid;
        aste_p := ^mmv$ast_p^ [asti];
      ELSE
        EXIT /request/;
      IFEND;

    = mmc$sr1_commit_memory =
      first_image_pfti := osv$180_memory_limits.deadstart_upper DIV osv$page_size;
      FOR pfti := first_image_pfti TO UPPERBOUND (mmv$pft_p^) DO
        IF mmv$pft_p^ [pfti].queue_id = mmc$pq_free THEN
          mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon + 1;
          mmp$link_page_frame_to_queue (pfti, ^mmv$pft_p^ [pfti]);
        IFEND;
      FOREND;
      mmv$image_file.active := FALSE;
      EXIT /request/;

    = mmc$sr1_free_image_pages =
      mmp$free_image_pages_mtr;
      EXIT /request/;

    = mmc$sr1_replace_sfid =

{ The SFID of a permanent file which is awaiting recovery is updated in the ast entry with the new SFID.
{ (The new SFID residence is also gft$tr_system_wait_recovery.)
{ If the ast index passed in is not correct, the AST must be searched.
{ IJL ordinals do NOT have to be checked because these can only be perm files.

      aste_p := NIL;
      IF (rb.asti <> 0) AND (rb.asti <= UPPERBOUND (mmv$ast_p^)) THEN
        IF mmv$ast_p^ [rb.asti].in_use THEN
          IF mmv$ast_p^ [rb.asti].sfid = rb.new_sfid THEN {sfid already replaced
            EXIT /request/;
          ELSEIF mmv$ast_p^ [rb.asti].sfid = rb.old_sfid THEN
            aste_p := ^mmv$ast_p^ [rb.asti];
          IFEND;
        IFEND;
      IFEND;

      /ast_search/
      BEGIN
        IF aste_p = NIL THEN
          old_sfid := rb.old_sfid;
          FOR asti := LOWERBOUND (mmv$ast_p^) TO UPPERBOUND (mmv$ast_p^) DO
            IF mmv$ast_p^ [asti].in_use AND (mmv$ast_p^ [asti].sfid = old_sfid) THEN
              rb.asti := asti;
              aste_p := ^mmv$ast_p^ [asti];
              EXIT /ast_search/;
            IFEND;
          FOREND;
        IFEND;
      END /ast_search/;

      IF aste_p = NIL THEN
        EXIT /request/;
      IFEND;

      aste_p^.sfid := rb.new_sfid;
      gfp$mtr_get_locked_fde_p (rb.new_sfid, cst_p^.ijle_p, fde_p);
      fde_p^.asti := rb.asti;
      EXIT /request/;

    = mmc$sr1_end_job_recovery =

      FOR pfti := LOWERBOUND (mmv$pft_p^) TO UPPERBOUND (mmv$pft_p^) DO
        IF (mmv$pft_p^ [pfti].aste_p <> NIL) AND
              (mmv$pft_p^ [pfti].aste_p^.sfid.residence = gfc$tr_system_wait_recovery) AND
              (mmv$pft_p^ [pfti].queue_id <> mmc$pq_free) THEN
          asid := mmv$pft_p^ [pfti].sva.asid;
          aste_p := mmv$pft_p^ [pfti].aste_p;
          jmp$get_ijle_p (mmv$pft_p^ [pfti].ijl_ordinal, ijle_p);
          IF (ijle_p^.swap_status >= jmc$iss_initiate_swapout_io) AND (ijle_p^.swap_status <=
            jmc$iss_swapout_io_complete) THEN
            tmp$reissue_monitor_request;
            tmp$cause_task_switch;
          IFEND;
          mmp$delete_pt_entry (pfti, TRUE);
          mmp$relink_page_frame (pfti, mmc$pq_free);
          IF aste_p^.pages_in_memory = 0 THEN
            mmp$free_asid (asid, aste_p);
            unrecovered_files := unrecovered_files + 1;
          IFEND;
          unrecovered_pages := unrecovered_pages + 1;
          IF ((ijle_p^.swap_status >= jmc$iss_job_idle_tasks_complete) AND
              (ijle_p^.swap_status <= jmc$iss_swapped_io_cannot_init)) OR
              (ijle_p^.swap_status = jmc$iss_swapped_io_complete) THEN
             jsp$recalculate_swapped_pages (ijle_p, 1);
          IFEND;
        IFEND;
      FOREND;

      rb.unrecovered_files := unrecovered_files;
      rb.unrecovered_pages := unrecovered_pages;
      EXIT /request/;

    = mmc$sr1_make_mfw_cache =
      mtv$monitor_segment_table.st [#segment (osv$mainframe_wired_heap)].ste.vl :=
        osc$vl_regular_segment;
      mtv$nos_segment_table_p^.st [#segment (osv$mainframe_wired_heap)].ste.vl :=
        osc$vl_regular_segment;
      #PURGE_BUFFER (osc$purge_all_page_seg_map, sva);
      EXIT /request/;

    = mmc$sr1_remove_job_shared_pages =
      gfp$mtr_get_locked_fde_p (rb.sfid, cst_p^.ijle_p, fde_p);
      IF fde_p^.asti <> 0 THEN
        mmp$remove_jws_to_shared_pages (fde_p, cst_p, rb);
      IFEND;
      EXIT /request/;

    = mmc$sr1_remove_detached_pages =
      gfp$mtr_get_locked_fde_p (rb.sfid, cst_p^.ijle_p, fde_p);
      mmp$get_verify_asti_in_fde (fde_p, rb.sfid, cst_p^.ijl_ordinal, asti);
      IF (asti <> 0) AND (mmv$ast_p^ [asti].queue_id = mmc$pq_job_working_set) AND
            (mmv$ast_p^ [asti].ijl_ordinal = cst_p^.ijl_ordinal) THEN
        mmp$asid (asti, asid);
        sva.asid := asid;
        sva.offset := 0;
        aste_p := ^mmv$ast_p^ [asti];
        mmp$remove_detached_pages (sva, aste_p, cst_p^.ijl_ordinal);
      IFEND;
      EXIT /request/;

    = mmc$sr1_change_swap_file_queue =
      gfp$mtr_get_locked_fde_p (rb.sfid, cst_p^.ijle_p, fde_p);
      mmp$get_verify_asti_in_fde (fde_p, rb.sfid, cst_p^.ijl_ordinal, asti);
      IF asti <> 0 THEN
        mmv$ast_p^ [asti].ijl_ordinal := jmv$system_ijl_ordinal;
        mmv$ast_p^ [asti].queue_id := mmc$pq_shared_pf_non_execute;
      IFEND;
      fde_p^.queue_status := gfc$qs_global_shared;
      EXIT /request/;

    = mmc$sr1_share_global_logs =
      gfp$mtr_get_locked_fde_p (rb.sfid, cst_p^.ijle_p, fde_p);
      fde_p^.queue_status := gfc$qs_global_shared;
      IF fde_p^.asti <> 0 THEN
        mmp$remove_jws_to_shared_pages (fde_p, cst_p, rb);
      IFEND;
      EXIT /request/;

    ELSE
      mtp$set_status_abnormal ('MM', mme$invalid_request, rb.status);
      EXIT /request/;
    CASEND;

      sva.offset := 0;
      asid_can_be_deleted := NOT ((rb.request = mmc$sr1_detach_file) OR
            (rb.request = mmc$sr1_flush_seg_segnum));
      IF asid_can_be_deleted AND fde_p^.flags.global_template_file THEN

{!!!!!!This check is required in order to run multiple job templates. It may be worth
{ some time to look into the file kinds of multiple job template segments. There appear to
{ some strange uses of file kind.

        IF NOT syv$user_templates THEN
          mtp$error_stop ('MM - tried to delete template segment');
        IFEND;
      IFEND;
      IF (rb.request = mmc$sr1_detach_file) OR (rb.request = mmc$sr1_flush_delete_seg_sfid) OR
            (rb.request = mmc$sr1_flush_seg_segnum) THEN
        mmp$mm_write_modified_pages (sva, 7ffffff0(16), fde_p, aste_p, ioc$write_page, rb.init_new_io,
              (rb.request = mmc$sr1_detach_file),
              io_id, io_count, io_already_active, last_written_pfti, wmp_status);
        mmp$process_wmp_status (wmp_status, last_written_pfti, nowait_wait [rb.wait_for_io_complete],
              rb.init_new_io, rb.status);
        IF ((wmp_status <> mmc$wmp_io_complete) AND (wmp_status <> mmc$wmp_io_active)) OR
           ((wmp_status = mmc$wmp_io_active) AND rb.wait_for_io_complete) THEN
          asid_can_be_deleted := FALSE;
        IFEND;
      IFEND;

      IF asid_can_be_deleted THEN
        fde_p^.asti := 0;
        mmp$mm_free_pages (sva, 7fffffff(16), aste_p, TRUE, page_count);
      IFEND;

    END /request/;

    #KEYPOINT (osk$exit, osk$m * $INTEGER (rb.request), mmk$ring1_segment_request);

  PROCEND mmp$mtr_ring1_segment_request;

?? TITLE := 'MMP$FETCH_STACK_SEGMENT_INFO' ??
?? EJECT ??
{-------------------------------------------------------------
*copyc mmh$fetch_stack_segment_info
{-------------------------------------------------------------


  PROCEDURE [XDCL] mmp$fetch_stack_segment_info
    (    xcb_p: ^ost$execution_control_block;
         ring: ost$valid_ring;
         set_length_to_zero: boolean;
     VAR stack_segment_number: ost$segment;
     VAR maximum_segment_length: ost$segment_length;
     VAR found: boolean);

    VAR
      fde_p: gft$locked_file_desc_entry_p,
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      limit: amt$file_limit,
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      segnum: ost$segment,
      status: syt$monitor_status;

    tmp$obtain_ijl_ordinal_from_ptl (xcb_p^.global_task_id, ijl_ordinal);
    jmp$get_ijle_p (ijl_ordinal, ijle_p);
    mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);

    FOR segnum := 0 TO xcb_p^.xp.segment_table_length DO
      IF (mmc$sa_stack IN sdtx_p^.sdtx_table [segnum].software_attribute_set) AND
            (sdt_p^.st [segnum].ste.r1 = ring) THEN
        found := TRUE;
        stack_segment_number := segnum;
        gfp$mtr_get_locked_fde_p (sdtx_p^.sdtx_table [segnum].sfid, ijle_p, fde_p);
        maximum_segment_length := fde_p^.file_limit;
        IF set_length_to_zero THEN
          fde_p^.eoi_byte_address := 0;
          fde_p^.eoi_state := mmc$eoi_actual;
          fde_p^.flags.eoi_modified := TRUE;
        IFEND;
        RETURN;
      IFEND;
    FOREND;

    found := FALSE;

  PROCEND mmp$fetch_stack_segment_info;
?? TITLE := 'MMP$PERIODIC_CALL' ??
?? EJECT ??
{------------------------------------------------------------------
{This procedure is called periodically to age the Shared Page Queues.
{
{   MMP$PERIODIC_CALL
{
{-----------------------------------------------------------------------


  PROCEDURE [XDCL] mmp$periodic_call;


    VAR
      fde_p: gft$locked_file_desc_entry_p,
      aste_p: ^mmt$active_segment_table_entry,
      jcb_p: ^jmt$job_control_block,
      ajlo: jmt$ajl_ordinal,
      inhibit_io: boolean,
      clock: ost$free_running_clock,
      cptime: integer,
      last_pfti: mmt$page_frame_index,
      new_asid: ost$asid,
      new_asti: mmt$ast_index,
      new_aste_p: ^mmt$active_segment_table_entry,
      pfte_p: ^mmt$page_frame_table_entry,
      pfti: mmt$page_frame_index,
      ijle_p: ^jmt$initiated_job_list_entry,
      pt_full_status: mmt$pt_full_status,
      taskid: ost$global_task_id,
      mcount: integer,
      rcount: integer,
      aggressive_aging: boolean,
      maxws_left_for_user_jobs: mmt$page_frame_index,
      max_idle_candidate: jmt$dispatching_priority,
      blocked_dp_set: jmt$dispatching_priority_set,
      block_lower_prios: boolean,
      dp: jmt$dispatching_priority,
      i: integer,
      idle_candidates: jmt$dispatching_priority_set,
      total_idle: ost$free_running_clock,
      user_dp_set: [STATIC] jmt$dispatching_priority_set := $jmt$dispatching_priority_set
            [7,8,9,10,11,12,13,14],
      queue: mmt$page_frame_queue_id,
      temp_max_working_set_size: mmt$page_frame_index,
      temp_target: mmt$page_frame_index,
      time_last_idle_dispatching_scan: [STATIC] integer := 5000000,
      time_last_io_error_q_scan: [STATIC] integer := 5000000,
      time_last_shared_queue_scan: [STATIC] integer := 5000000,
      time_last_full_jws_scan: [STATIC] integer := 5000000,
      time_next_free_astes: [STATIC] integer := 0,
      time_next_scan_wait_not_queued: [STATIC] integer := 600000000,
      pass: integer,
      pti: ost$page_table_index,
      asid: ost$asid,
      asti: mmt$ast_index,
      system_jws: mmt$page_frame_index;




    #KEYPOINT (osk$entry, 0, mmk$periodic_call);

{Age the shared and job working set queues if necessary:
{    shared - aged every few seconds
{    job (algorithm 0) - aged every few seconds and all pages not referenced since last time
{                        are removed
{    job (algorithm 1) - every few seconds a scan is made of each job. If job has used a TICKTIME of
{                        cp time, the working set is aged same as though a page fault occurred.
{***NOTE - if system is real low on free/avail pages, aging is forced even if not necessary.

{ Set the global maximum working set to the number of pages available to user jobs.
{ The size of a job's working set will be constrained to the lesser of the global maximum working set
{ and the maximum working set size value in the job control block, which is determined by the class attribute.
{ The value for the global maximum working set is the largest working set the system can accommodate.  Since
{ the System Job is also limited by the global maximum working set (mmv$max_working_set_size) the System Job
{ is effectively limited to 50% of the available space.  If the System Job is the only job, the maximum is
{ calculated as the maximum space available to the system job (although it is unlikely to grow that large).

    IF jmv$max_class_working_set = 0  THEN  { =0 when system job is the only job.}
      system_jws := 0;
    ELSE
      get_system_jobs_working_set (system_jws);
    IFEND;
    maxws_left_for_user_jobs := mmv$total_page_frames - mmv$gpql [mmc$pq_wired].pqle.count -
          mmv$gpql [mmc$pq_shared_io_error].pqle.count - mmv$gpql [mmc$pq_flawed].pqle.count -
          system_jws;
    FOR queue := mmc$pq_shared_first TO mmv$last_active_shared_queue  DO
      maxws_left_for_user_jobs := maxws_left_for_user_jobs - mmv$gpql [queue].pqle.count;
    FOREND;
    IF jmv$max_class_working_set < maxws_left_for_user_jobs THEN
      temp_max_working_set_size := jmv$max_class_working_set;
    ELSE
      temp_max_working_set_size := maxws_left_for_user_jobs;
    IFEND;
    temp_target := (temp_max_working_set_size * jsv$swapped_page_entry_size DIV
          osv$page_size + 1) + mmv$aggressive_aging_level;
    IF temp_target > jmv$job_scheduler_table.scheduling_memory_levels.target THEN
      mmv$resident_job_target := temp_target;
    ELSE
      mmv$resident_job_target := jmv$job_scheduler_table.scheduling_memory_levels.target;
    IFEND;
    mmv$max_working_set_size := maxws_left_for_user_jobs - mmv$resident_job_target;
    IF mmv$max_working_set_size < 10 THEN
      mmv$max_working_set_size := 10;
    IFEND;

{ Check for "idle dispatching".  The basic algorithm is that if there are high priority CPU bound
{ jobs, mark the lower dispatching priorities as blocked in the idle dispatching controls.
{ Jobs with blocked dispatching priorities will be swapped out; the memory freed by swapping the
{ jobs will increase the size of the available queue.
{ Because cpu dispatching allocation circumvents the highest-dispatching-priority-first selection
{ algorithm, deciding which dispatching priority is "lower" gets a little tricky.  Cpu dispatching
{ allocation is not intended to reorder dispatching priorities though, so the idle dispatching
{ algorithm will not block a priority if a lower priority cannot be blocked because of dispatching
{ allocation.  Dispatching priorities which have been allocated a minimum percent of the CPU will
{ not be blocked.
{ Whenever there is any idle CPU time, all blocked priorities will be cleared.
{ NOTE:  A dispatching priority in a SET is converted so that the highest dispatching
{ priority in the SET corresponds to the leftmost bit in the SET. (See jmt$dispatching_priority.)

    clock := #free_running_clock (0);
    IF (clock - time_last_idle_dispatching_scan) > jmv$scan_idle_dispatch_interval THEN
      total_idle := 0;
      FOR i := 0 TO (osv$cpus_physically_configured - 1) DO
        IF (mtv$cst0 [i].processor_state = cmc$on) AND ((NOT tmv$dedicate_a_cpu_to_nos) OR (i <> 0)) THEN
          total_idle := total_idle + mtv$cst0 [i].cpu_idle_statistics.idle_no_io_active +
                        mtv$cst0 [i].cpu_idle_statistics.idle_io_active;
        IFEND;
      FOREND;
      IF (total_idle > jmv$idle_dispatching_controls.controls [0].last_cp_time) OR
            ((jmv$idle_dispatching_controls.unblocked_priorities * tmv$dispatching_control_sets.ready_tasks) -
            jmv$idle_dispatching_controls.maximums_exceeded = $jmt$dispatching_priority_set []) THEN

{ Unblock all idled dispatching priorities.

        jmv$idle_dispatching_controls.unblocked_priorities := user_dp_set;
        FOR dp := jmc$priority_p1 TO jmc$priority_p8 DO
          jmv$idle_dispatching_controls.controls [dp].blocked := FALSE;
          jmv$idle_dispatching_controls.controls [dp].idle_noticed_once := FALSE;
          jmv$idle_dispatching_controls.controls [dp].timestamp := clock;
          jmv$idle_dispatching_controls.controls [dp].last_cp_time := tmv$cpu_execution_statistics [dp].
                time_spent_in_job_mode + tmv$cpu_execution_statistics [dp].time_spent_in_mtr_mode;
        FOREND;
        jmp$set_scheduler_event (jmc$examine_swapin_queue);
        jmp$set_scheduler_event (jmc$examine_input_queue);
      ELSE

{ Checked for blocked priorities.  NOTE: P1 = 2 = minimum_dispatching_priority.
{ Idle candidates are priorities BELOW the lowest minimum-to-satisify priority.
{ If any CPU time has been used by the priority, update the time used and the timestamp.
{ If no CPU time has been used since a previous check, idle the priority if the
{ idle_dispatching_queue_time has been exceeded.

        idle_candidates := (user_dp_set - tmv$dispatching_controls.minimums_to_satisfy);

        max_idle_candidate := jmc$priority_p1;
        WHILE ((jmc$dp_conversion - max_idle_candidate) IN idle_candidates) DO
          max_idle_candidate := max_idle_candidate + 1;
        WHILEND;

        block_lower_prios := FALSE;
        FOR dp := (max_idle_candidate - 1) DOWNTO jmc$priority_p1 DO
          IF (jmv$idle_dispatching_controls.controls [dp].last_cp_time <> (tmv$cpu_execution_statistics [dp].
                time_spent_in_job_mode + tmv$cpu_execution_statistics [dp].time_spent_in_mtr_mode)) AND
                (NOT block_lower_prios) THEN

            jmv$idle_dispatching_controls.controls [dp].last_cp_time := tmv$cpu_execution_statistics
                [dp].time_spent_in_job_mode + tmv$cpu_execution_statistics [dp].
                time_spent_in_mtr_mode;
            jmv$idle_dispatching_controls.controls [dp].timestamp := clock;
            jmv$idle_dispatching_controls.controls [dp].idle_noticed_once := FALSE;

          ELSE
            IF (((jmc$dp_conversion - dp) IN tmv$dispatching_control_sets.ready_tasks) AND
                  ((jmv$idle_dispatching_controls.controls [dp].timestamp + jmv$job_scheduler_table.
                  idle_dispatching_queue_time) < clock)) OR (block_lower_prios) THEN

              IF jmv$idle_dispatching_controls.controls [dp].idle_noticed_once THEN
                jmv$idle_dispatching_controls.controls [dp].blocked := TRUE;
                jmv$idle_dispatching_controls.unblocked_priorities := jmv$idle_dispatching_controls.
                      unblocked_priorities - $jmt$dispatching_priority_set [jmc$dp_conversion - dp];
              ELSE
                jmv$idle_dispatching_controls.controls [dp].idle_noticed_once := TRUE;
              IFEND;
              block_lower_prios := TRUE;
            ELSE
              jmv$idle_dispatching_controls.controls [dp].idle_noticed_once := FALSE;
            IFEND;
          IFEND;
        FOREND;

      IFEND;
      jmv$idle_dispatching_controls.maximums_exceeded := $jmt$dispatching_priority_set [];
      jmv$idle_dispatching_controls.controls [0].last_cp_time := total_idle;
      jmv$idle_dispatching_controls.controls [0].timestamp := clock;
      time_last_idle_dispatching_scan := clock;
    IFEND; {time to scan idle dispatching}

{ Insert timed_wait_not_queued tasks into the timed wait queue if it is nearly time for them to be readied.

    clock := #free_running_clock (0);
    IF clock >= time_next_scan_wait_not_queued THEN
      time_next_scan_wait_not_queued := clock + tmv$timed_wait_not_queued;
      tmp$check_timed_wait_not_queued (time_next_scan_wait_not_queued);
    IFEND;


    mmp$maintain_memory_thresholds;

    aggressive_aging := mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon <=
          mmv$aggressive_aging_level + jsv$pages_needed_for_sfd;
    IF aggressive_aging THEN
      mmv$aging_statistics.aggressive_age_shared_queue := mmv$aging_statistics.aggressive_age_shared_queue +1;
    IFEND;

    IF aggressive_aging OR ((#FREE_RUNNING_CLOCK (0) - time_last_shared_queue_scan) >
          mmv$shared_queue_age_interval) THEN
      jsp$adv_expired_swapped_jobs (jsc$isqi_swapped_io_not_init);
      jsp$adv_expired_swapped_jobs (jsc$isqi_swapped_io_completed);
      FOR queue := mmc$pq_shared_first TO mmv$last_active_shared_queue  DO
        IF aggressive_aging THEN
          mmp$remove_stale_pages (mmv$gpql [queue].pqle, mmv$gpql [queue].age_interval, NIL, NIL,
              mmc$pq_avail_modified, 0, mcount, rcount);
        ELSE
          mmp$remove_stale_pages (mmv$gpql [queue].pqle, mmv$gpql [queue].age_interval, NIL, NIL,
              mmc$pq_avail_modified, mmv$gpql [queue].minimum, mcount, rcount);
        IFEND;

{ Trim the shared queue down to maximum size; page faulting for a shared page does not automatically trim the
{ shared queue.  A NIL ijl pointer is passed to the remove procedure; the ijl pointer is used only if the file
{ is a job file.  Pages in the shared queues cannot belong to a job file (the shared io error queue is an
{ exception).

        pfti := mmv$gpql [queue].pqle.link.bkw;
        WHILE (mmv$gpql [queue].pqle.count > mmv$gpql [queue].maximum) AND (pfti <> 0) DO
          pfte_p := ^mmv$pft_p^ [pfti];
          last_pfti := pfti;
          pfti := pfte_p^.link.bkw;
          mmp$remove_page_from_jws (last_pfti, NIL {ijle_p}, mcount, rcount);
        WHILEND;

        mmv$aging_statistics.age_unused_page_in_shared_queue := mmv$aging_statistics.
              age_unused_page_in_shared_queue + rcount;
        IF queue <= mmc$pq_shared_last_sys THEN
          mmv$aging_statistics.age_sys_shared_queue [queue]:=
                mmv$aging_statistics.age_sys_shared_queue[queue] + rcount;
        IFEND;
      FOREND;
      time_last_shared_queue_scan := #FREE_RUNNING_CLOCK (0);
    IFEND;

    IF ((#FREE_RUNNING_CLOCK (0) - time_last_io_error_q_scan) >
          mmv$io_error_q_age_interval) THEN
      mmp$remove_stale_pages (mmv$gpql [mmc$pq_shared_io_error].pqle, mmv$gpql [mmc$pq_shared_io_error].
            age_interval, NIL, NIL, mmc$pq_avail_modified, 0, mcount, rcount);  {enforces "0" as minimum size
      time_last_io_error_q_scan := #FREE_RUNNING_CLOCK (0);
    IFEND;

    aggressive_aging := mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon <=
          mmv$aggressive_aging_level + jsv$pages_needed_for_sfd;
    IF aggressive_aging THEN
      mmv$aging_statistics.aggressive_age_job_queues := mmv$aging_statistics.aggressive_age_job_queues + 1;
    IFEND;
    IF aggressive_aging OR mmv$reduce_jws_for_thrashing OR
          ((#FREE_RUNNING_CLOCK (0) - time_last_full_jws_scan) > mmv$jws_queue_age_interval) THEN

      FOR ajlo := LOWERBOUND (jmv$ajl_p^) TO jmv$max_ajl_ordinal_in_use DO
        tmp$set_lock (tmv$ptl_lock);
        IF (jmv$ajl_p^ [ajlo].in_use <> 0) AND (jmv$ajl_p^ [ajlo].ijle_p^.swap_status =
                jmc$iss_executing) THEN
          jmv$ajl_p^ [ajlo].in_use := jmv$ajl_p^ [ajlo].in_use + jmc$lock_ajl;
          tmp$clear_lock (tmv$ptl_lock);
          ijle_p := jmv$ajl_p^ [ajlo].ijle_p;
          IF ijle_p^.maxws_aio_slowdown_display > 0 THEN
             ijle_p^.maxws_aio_slowdown_display := ijle_p^.maxws_aio_slowdown_display - 1;
          IFEND;
          IF mmv$aging_algorithm >= 4 THEN
            cptime := ijle_p^.statistics.cp_time.time_spent_in_job_mode;
          ELSE
            cptime := ijle_p^.statistics.cp_time.time_spent_in_job_mode + ijle_p^.statistics.cp_time.
                  time_spent_in_mtr_mode;
          IFEND;
          jcb_p := #ADDRESS (1, mtc$job_fixed_segment + ajlo, 0);
          IF jcb_p^.next_cyclic_aging_time < #FREE_RUNNING_CLOCK (0) THEN
            mmp$remove_stale_pages (ijle_p^.job_page_queue_list [mmc$pq_job_working_set], 1, jcb_p, ijle_p,
                  mmc$pq_avail_modified, jcb_p^.min_working_set_size, mcount, rcount);
            mmp$remove_stale_pages (ijle_p^.job_page_queue_list [mmc$pq_job_io_error], 30, jcb_p, ijle_p,
                  mmc$pq_avail_modified, 0, mcount, rcount);
          IFEND;
          IF (ijle_p^.swap_status = jmc$iss_executing) AND (ijle_p^.entry_status = jmc$ies_job_in_memory) AND
                (NOT jmv$ajl_p^ [ajlo].job_is_good_swap_candidate) THEN
            IF ((#FREE_RUNNING_CLOCK (0) - jcb_p^.last_execution_time) > tmv$long_wait_force_swap_time) AND
                  (ijle_p^.statistics.ready_task_count = 0) THEN
              tmp$check_for_swapout_candidate (ajlo);
            ELSEIF jmv$idle_dispatching_controls.controls [ijle_p^.scheduling_dispatching_priority].blocked
                  THEN
              tmp$idle_non_dispatchable_job (ajlo);
            IFEND;
          IFEND;
          IF aggressive_aging THEN
            mmp$age_job_working_set (ijle_p, jcb_p);
          ELSEIF cptime > (jcb_p^.cptime_next_age_working_set + 2 * jcb_p^.page_aging_interval) THEN
            mmv$aging_statistics.age_cp_bound_job := mmv$aging_statistics.age_cp_bound_job + 1;
            mmp$age_job_working_set (ijle_p, jcb_p);
          IFEND;
          jmp$unlock_ajl (ijle_p);
        ELSE
          tmp$clear_lock (tmv$ptl_lock);
        IFEND;
      FOREND;
      time_last_full_jws_scan := #FREE_RUNNING_CLOCK (0);
    IFEND;


{Call replenish free queue.

    mmp$replenish_free_queues (0);

{Reclaim unused ast entries

    IF mmv$async_work.reclaim_astes THEN
      mmv$async_work.reclaim_astes := FALSE;
      mmp$reclaim_ast_entries (0);
    IFEND;

{Process outstanding page table full conditions.

    IF mmv$async_work.pt_full THEN
      IF mmv$async_work.pt_full_aste_p^.in_use THEN

        IF jmp$ijl_block_valid (mmv$async_work.pt_full_aste_p^.ijl_ordinal) THEN
          mmp$get_inhibit_io_status (mmv$async_work.pt_full_aste_p^.ijl_ordinal, FALSE {lock ajl},
                inhibit_io, ijle_p);
        ELSE
          inhibit_io := FALSE;
        IFEND;

        IF NOT inhibit_io THEN
          mmp$process_page_table_full (mmv$async_work.pt_full_sva, new_asid, new_asti,
                new_aste_p, pt_full_status);
        IFEND;
      IFEND;
      mmv$async_work.pt_full := FALSE;
    IFEND;


{If tasks are in the memory wait queue, ready one task. This mechanism is NOT the normal mechanism
{for waking tasks in memory wait. Normally this is done as soon as the memory becomes available. This
{mechanism is a FAIL-SAFE mechanism in case 1) the task waiting for memory doesnt request it again
{when it is readied from the memory-wait queue, or 2) give critical tasks memory when sever thrashing occurs.

    IF (mmv$memory_wait_queue.head <> 0) AND (mmv$reassignable_page_frames.now > 0) THEN
      tmp$dequeue_task (mmv$memory_wait_queue, taskid);
    IFEND;

    IF osv$keypoint_control.periodic_requested THEN
      osp$process_keypoint_periodic;
    IFEND;

{Update statistics.

    IF mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon <= mmv$aggressive_aging_level THEN
      mmv$aging_statistics.aggressive_aging_failed := mmv$aging_statistics.aggressive_aging_failed + 1;
    IFEND;


{** Debug code - allow for testing of ASID REASSIGNMENT.

    IF mmv$test_reassign_asid AND (#FREE_RUNNING_CLOCK (0) > time_next_free_astes) THEN
      FOR asti := 1 TO UPPERBOUND (mmv$ast_p^) DO
        aste_p := ^mmv$ast_p^ [asti];
        IF (aste_p^.pages_in_memory = 0) AND aste_p^.in_use THEN
          mmp$asid (asti, asid);
          IF (jmp$ijl_block_valid (mmv$ast_p^ [asti].ijl_ordinal)) AND
                (jmv$ijl_p.block_p^[mmv$ast_p^ [asti].ijl_ordinal.block_number].index_p^
                [mmv$ast_p^ [asti].ijl_ordinal.block_index].entry_status <> jmc$ies_entry_free) THEN
            mmp$change_asid (^mmv$ast_p^ [asti], asid, 0, 0);
          IFEND;
          mmp$free_asid (asid, ^mmv$ast_p^ [asti]);
        IFEND;
        IF aste_p^.in_use THEN
          IF aste_p^.sfid.residence = gfc$tr_system THEN
            gfp$mtr_get_locked_fde_p (aste_p^.sfid, NIL, fde_p);
            IF fde_p^.asti <> asti THEN
              mtp$error_stop ('MM - dangling AST entry found');
            IFEND;
          IFEND;
        IFEND;
      FOREND;
      time_next_free_astes := #FREE_RUNNING_CLOCK (0) + 1000000;
    IFEND;


{** DEBUG code - allow for testing PAGE TABLE full.

    FOR pass := 1 TO mmv$test_pt_full DO
      pti := #FREE_RUNNING_CLOCK (0) MOD mmv$pt_length;
      pfti := (mmv$pt_p^ [pti].rma * 512) DIV osv$page_size;
      WHILE (mmv$pt_p^ [pti].pageid.asid = 0) OR (pfti < LOWERBOUND (mmv$pft_p^)) OR
            (pfti > UPPERBOUND (mmv$pft_p^)) OR (mmv$pft_p^ [pfti].aste_p = NIL) OR
            (mmv$pft_p^ [pfti].aste_p^.in_use = FALSE) DO
        pti := pti + 1;
        IF pti = mmv$pt_length THEN
          pti := 0;
        IFEND;
        pfti := (mmv$pt_p^ [pti].rma * 512) DIV osv$page_size;
      WHILEND;
      IF jmp$ijl_block_valid (mmv$pft_p^ [pfti].ijl_ordinal) THEN
        mmp$get_inhibit_io_status (mmv$pft_p^ [pfti].ijl_ordinal, FALSE {lock ajl}, inhibit_io, ijle_p);
      ELSE
        inhibit_io := FALSE;
      IFEND;
      IF NOT inhibit_io THEN
        mmp$process_page_table_full (mmv$pft_p^ [pfti].sva, new_asid, new_asti, new_aste_p,
              pt_full_status);
      IFEND;
    FOREND;


{Reset the time that CP Monitor should next call this procedure.

    mmv$time_to_call_mem_mgr := mmv$periodic_call_interval + #FREE_RUNNING_CLOCK (0);

    #KEYPOINT (osk$exit, 0, mmk$periodic_call);


  PROCEND mmp$periodic_call;
?? TITLE := 'REPLENISH_FREE_QUEUES' ??
?? EJECT ??

{--------------------------------------------------------------------------------------------------------
{Name:
{  replenish_free_queues
{Purpose:
{  This routine is called to determine if the number of FREE + AVAILABLE
{  is getting too low.
{
{    asid: (input) If only pages belonging to a specific ASID should be written then this parameter
{        specifies the ASID. If ALL ASIDs should be written then a 0 (zero) is passed.
{
{
{--------------------------------------------------------------------------------------------------------


  PROCEDURE [XDCL] mmp$replenish_free_queues
    (    asid: ost$asid);

    CONST
      max_dm_rejects = 32;

    VAR
      fde_p: gft$locked_file_desc_entry_p,
      write_status: mmt$write_page_to_disk_status,
      pfti: mmt$page_frame_index,
      next_pfti: mmt$page_frame_index,
      ijle_p: ^jmt$initiated_job_list_entry,
      io_id: mmt$io_identifier,
      dm_reject_table: array [1 .. max_dm_rejects] of ost$asid,
      i,
      j: integer,
      write_ok: boolean,
      inhibit_io: boolean;

    i := 0;
    io_id.specified := FALSE;

{Move pages from the AVAIL_MODIFIED queue to the AVAIL queue until free pages exceeds the threshold.

    pfti := mmv$gpql [mmc$pq_avail_modified].pqle.link.bkw;

    WHILE (pfti <> 0) AND ((mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon) <
          mmv$write_aged_out_pages) DO
      IF mmv$pft_p^ [pfti].aste_p^.in_use = FALSE THEN
        mtp$error_stop ('MM - replenish found page in AM q with AST free');
      IFEND;
      IF mmv$pft_p^ [pfti].aste_p^.sfid.residence = gfc$tr_system_wait_recovery THEN
        RETURN;
      IFEND;
      next_pfti := mmv$pft_p^ [pfti].link.bkw;
      IF (mmv$pt_p^ [mmv$pft_p^ [pfti].pti].m) AND ((asid = 0) OR (mmv$pft_p^ [pfti].sva.asid = asid)) THEN
        IF jmp$ijl_block_valid (mmv$pft_p^ [pfti].ijl_ordinal) THEN
          mmp$get_inhibit_io_status (mmv$pft_p^ [pfti].ijl_ordinal, TRUE {lock ajl}, inhibit_io, ijle_p);
        ELSE
          inhibit_io := TRUE;
        IFEND;
        IF NOT inhibit_io THEN
          write_ok := TRUE;

        /asid_check/
          FOR j := 1 TO i DO
            IF mmv$pft_p^ [pfti].sva.asid = dm_reject_table [j] THEN
              write_ok := FALSE;
              jmp$unlock_ajl (ijle_p);
              EXIT /asid_check/;
            IFEND;
          FOREND /asid_check/;
          IF write_ok THEN
            gfp$mtr_get_locked_fde_p (mmv$pft_p^ [pfti].aste_p^.sfid, ijle_p, fde_p);
            mmp$write_page_to_disk (fde_p, pfti, ioc$write_page, io_id, mmv$multi_page_write, write_status);
            jmp$unlock_ajl (ijle_p);
            IF write_status = ws_physical_io_reject THEN
              RETURN;
            ELSEIF write_status <> ws_ok THEN
              i := i + 1;
              dm_reject_table [i] := mmv$pft_p^ [pfti].sva.asid;
              IF i >= max_dm_rejects THEN
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
      pfti := next_pfti;
    WHILEND;

  PROCEND mmp$replenish_free_queues;
?? TITLE := 'FREE_IMAGE_PAGES' ??
?? EJECT ??

  PROCEDURE [XDCL] mmp$free_image_pages_mtr;

    VAR
      i: integer,
      pte_p: ^ost$page_table_entry,
      pfti: mmt$page_frame_index;

    FOR i := 0 TO (mmv$pt_length - 1) DO
      pte_p := ^mmv$pt_p^ [i];
      IF (pte_p^.v) AND ((pte_p^.rma * 512) >= osv$180_memory_limits.deadstart_upper) AND
            ((pte_p^.rma * 512) < osv$180_memory_limits.upper) THEN
        pfti := (pte_p^.rma * 512) DIV osv$page_size;
        mmp$delete_pt_entry (pfti, TRUE);
        mmv$pft_p^ [pfti].queue_id := mmc$pq_free;
        mmv$pft_p^ [pfti].sva.asid := 0;
      IFEND;
    FOREND;

  PROCEND mmp$free_image_pages_mtr;
?? TITLE := 'MMP$CREATE_TASK' ??
?? EJECT ??
{----------------------------------------------------------------------------------------------------
{This procedure is called by the Dispatcher when a new task is created to initialize the SDT of the
{new task. Initialization consists if copying the ASID's of shared segments from the SDT of the parent
{task into the SDT of the new task.  Update the real memory address of the task's SDT in the task's
{exchange package.
{
{    MMP$CREATE_TASK (PARENT_XCB_P, XCB_P)
{
{----------------------------------------------------------------------------------------------------


  PROCEDURE [XDCL] mmp$create_task
    (    parent_xcb_p: ^ost$execution_control_block;
         xcb_p: ^ost$execution_control_block;
         ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      fde_p: gft$file_desc_entry_p,
      max_segnum: ost$segment,
      parent_sdt_p: mmt$max_sdt_p,
      parent_sdtx_p: mmt$max_sdtx_p,
      sdte: mmt$segment_descriptor,
      sdt_p: mmt$max_sdt_p,
      st_rma: integer,
      sdtx_p: mmt$max_sdtx_p,
      segnum: ost$segment,
      taskid: ost$global_task_id;

    #KEYPOINT (osk$debug, 0, mmk$create_task);

    mmp$get_max_sdt_sdtx_pointer (parent_xcb_p, parent_sdt_p, parent_sdtx_p);
    mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);

{  Update the RMA of the task's segment table in the task's exchange package.

    i#real_memory_address (sdt_p, st_rma);
    xcb_p^.xp.segment_table_address_1 := st_rma DIV 10000(16);
    xcb_p^.xp.segment_table_address_2 := st_rma MOD 10000(16);

    IF parent_xcb_p^.xp.segment_table_length > xcb_p^.xp.segment_table_length THEN
      max_segnum := xcb_p^.xp.segment_table_length;
    ELSE
      max_segnum := parent_xcb_p^.xp.segment_table_length;
    IFEND;

{ For performance, try to propagate the ASID/ASTI from the segment table entry of the parent (copy the
{ entire st entry) if the parent and child are both using corresponding segments for the same file
{ (compare sfids).  If the segments are not being used for the same file, the ASID/ASTI in the child's
{ segment table entry will remain zero.  When the child task first page faults for a page of the segment,
{ an ASID will be assigned.

    taskid := xcb_p^.global_task_id;
    FOR segnum := 0 TO max_segnum DO
      IF sdt_p^.st [segnum].ste.vl <> osc$vl_invalid_entry THEN
        IF (parent_sdt_p^.st [segnum].ste.vl <> osc$vl_invalid_entry) AND
            (sdtx_p^.sdtx_table [segnum].sfid = parent_sdtx_p^.sdtx_table [segnum].sfid) THEN
          sdt_p^.st [segnum] := parent_sdt_p^.st [segnum];
        ELSEIF sdtx_p^.sdtx_table [segnum].inheritance = mmc$si_new_segment THEN
          gfp$mtr_get_fde_p (sdtx_p^.sdtx_table [segnum].sfid, ijle_p, fde_p);   {No need to lock}
          fde_p^.global_task_id := taskid;
        IFEND;
      IFEND;
    FOREND;

  PROCEND mmp$create_task;

?? TITLE := 'MMP$EXIT_TASK' ??
?? EJECT ??
{----------------------------------------------------------------------------------------------------
{This procedure is called by the dispatcher when a task exits to  free pages and ASIDs assigned
{to task template segments.
{
{    MMP$EXIT_TASK (PARENT_XCB_P, XCB_P)
{
{----------------------------------------------------------------------------------------------------


  PROCEDURE [XDCL] mmp$exit_task
    (    xcb_p: ^ost$execution_control_block);

    VAR
      fde_p: gft$locked_file_desc_entry_p,
      sdt_p: mmt$max_sdt_p,
      cst_p: ^ost$cpu_state_table,
      sdtx_p: mmt$max_sdtx_p,
      page_count: integer,
      aste_p: ^mmt$active_segment_table_entry,
      sva: ost$system_virtual_address,
      segnum: ost$segment;


    #KEYPOINT (osk$debug, 0, mmk$exit_task);

    mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);
    mtp$cst_p (cst_p);

    sva.offset := 0;
    FOR segnum := 0 TO xcb_p^.xp.segment_table_length DO
      IF sdt_p^.st [segnum].ste.vl <> osc$vl_invalid_entry THEN
        IF sdtx_p^.sdtx_table [segnum].inheritance = mmc$si_new_segment THEN
          sva.asid := sdt_p^.st [segnum].ste.asid;
          IF sva.asid <> 0 THEN
            sdt_p^.st [segnum].ste.asid := 0;
            aste_p := ^mmv$ast_p^ [sdt_p^.st [segnum].asti];
            IF NOT aste_p^.in_use THEN
              mtp$error_stop ('MM - ast not in use');
            IFEND;
            gfp$mtr_get_locked_fde_p (aste_p^.sfid, cst_p^.ijle_p, fde_p);
            fde_p^.asti := 0;
            mmp$mm_free_pages (sva, 7fffffff(16), aste_p, TRUE, page_count);
          IFEND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND mmp$exit_task;

?? TITLE := 'MMP$CREATE_JOB' ??
?? EJECT ??
{----------------------------------------------------------------------------------------------------
{This procedure is called by the Dispatcher when a new job is created to initialize the SDT of the
{new job.
{
{    MMP$CREATE_JOB (PARENT_XCB, XCB_P)
{
{! * * * MUST CHANGE WHEN MULTIPLE JOB TEMPLATES ARE SUPPORTED.
{----------------------------------------------------------------------------------------------------


  PROCEDURE [XDCL] mmp$create_job
    (    new_job_ajl_ordinal: jmt$ajl_ordinal;
         xcb_segnum_relative_jobs_as: ost$segment;
         parent_xcb_p: ^ost$execution_control_block;
         xcb_p: ^ost$execution_control_block);

    VAR
      aste_p: ^mmt$active_segment_table_entry,
      cst_p: ^ost$cpu_state_table,
      fde_p: gft$file_desc_entry_p,
      ijle_p: ^jmt$initiated_job_list_entry,
      jcb_p: ^jmt$job_control_block,
      jf_fde_p: gft$locked_file_desc_entry_p,
      new_job_ijl_ordinal: jmt$ijl_ordinal,
      parent_fde_p: gft$locked_file_desc_entry_p,
      parent_sdt_p: mmt$max_sdt_p,
      parent_sdtx_p: mmt$max_sdtx_p,
      pfti: mmt$page_frame_index,
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      segnum: ost$segment,
      sva: ost$system_virtual_address,
      taskid: ost$global_task_id;


    #KEYPOINT (osk$debug, 0, mmk$create_job);

    mtp$cst_p (cst_p);
    mmp$get_max_sdt_sdtx_pointer (parent_xcb_p, parent_sdt_p, parent_sdtx_p);
    mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);

{ Copy the segment table entry of the segment used for the new job fixed in the parent to the new job's
{ job fixed segment table entry.  Fix the ring and cache bypass values; they are not correct in the
{ parent's ste.
{ Invalidate the segment used by the parent.

    sdt_p^.st [osc$segnum_job_fixed_heap] := parent_sdt_p^.st [xcb_segnum_relative_jobs_as];
    sdt_p^.st [osc$segnum_job_fixed_heap].ste.vl := osc$vl_cache_bypass;
    sdt_p^.st [osc$segnum_job_fixed_heap].ste.r2 := 3;
    parent_sdt_p^.st [xcb_segnum_relative_jobs_as].ste.vl := osc$vl_invalid_entry;
    parent_sdt_p^.st [xcb_segnum_relative_jobs_as].ste.asid := 0;
    gfp$mtr_get_locked_fde_p (parent_sdtx_p^.sdtx_table [xcb_segnum_relative_jobs_as].sfid,
          cst_p^.ijle_p, parent_fde_p);
    parent_fde_p^.asti := 0;
    sva.asid := sdt_p^.st [osc$segnum_job_fixed_heap].ste.asid;
    sva.offset := 0;
    #PURGE_BUFFER (osc$purge_all_page_seg_map, sva);
    new_job_ijl_ordinal := jmv$ajl_p^ [new_job_ajl_ordinal].ijl_ordinal;
    jmp$get_ijle_p (new_job_ijl_ordinal, ijle_p);

{ Copy template segments from the parent (system job task) to the new job's job monitor task.

    taskid := xcb_p^.global_task_id;
    FOR segnum := 0 TO mmv$max_template_segment_number DO
      IF (sdt_p^.st [segnum].ste.vl <> osc$vl_invalid_entry) THEN

{ The second clause of the following IF statement is to prevent the copying of
{ "shared" segments when executing within a multiple job template.

        IF (sdtx_p^.sdtx_table [segnum].open_validating_ring_number = 0) AND
            (sdtx_p^.sdtx_table [segnum].sfid = parent_sdtx_p^.sdtx_table [segnum].sfid) THEN
          sdt_p^.st [segnum] := parent_sdt_p^.st [segnum];
        ELSE
          gfp$mtr_get_fde_p (sdtx_p^.sdtx_table [segnum].sfid, ijle_p, fde_p);   {No need to lock}
          fde_p^.global_task_id := taskid;
        IFEND;
      IFEND;
    FOREND;

{  Move the job fixed segment of the new job to the job queue of that job.

    aste_p := ^mmv$ast_p^ [sdt_p^.st [osc$segnum_job_fixed_heap].asti];
    aste_p^.sfid := sdtx_p^.sdtx_table [osc$segnum_job_fixed_heap].sfid;
    aste_p^.queue_id := mmc$pq_job_fixed;
    aste_p^.ijl_ordinal := new_job_ijl_ordinal;
    gfp$mtr_get_locked_fde_p (aste_p^.sfid, ijle_p, jf_fde_p);
    jf_fde_p^.last_segment_number := osc$segnum_job_fixed_heap;
    jf_fde_p^.global_task_id := xcb_p^.global_task_id;
    jf_fde_p^.asti := sdt_p^.st [osc$segnum_job_fixed_heap].asti;
    jf_fde_p^.eoi_byte_address := gfc$fde_table_base + osv$page_size;
    jcb_p := #ADDRESS (1, mtc$job_fixed_segment + ijle_p^.ajl_ordinal, 0);
    jcb_p^.next_cyclic_aging_time := #FREE_RUNNING_CLOCK (0) + jcb_p^.cyclic_aging_interval;
    ijle_p^.job_fixed_asid := sva.asid;

    mmp$initialize_find_next_pfti (sva, 7ffffff0(16), include_partial_pages, psc_all, aste_p, pfti);

  /relink_job_fixed_in_new_queue/
    WHILE pfti <> 0 DO
      mmp$relink_page_frame (pfti, mmc$pq_wired);
      mmv$pft_p^ [pfti].ijl_ordinal := new_job_ijl_ordinal;
      mmp$relink_page_frame (pfti, mmc$pq_job_fixed);
      mmp$find_next_pfti (pfti);
    WHILEND /relink_job_fixed_in_new_queue/;

  PROCEND mmp$create_job;
?? TITLE := 'MMP$EXIT_JOB' ??
?? EJECT ??
{----------------------------------------------------------------------------------------------------
{This procedure is called by the dispatcher when a job exits to  free pages and ASIDs assigned
{to non-inherited segments.
{
{        MMP$EXIT_JOB (XCB_P)
{
{ XCB_P: (input) This parameter is a pointer to the execution control block
{        of the job exiting.
{
{----------------------------------------------------------------------------------------------------


  PROCEDURE [XDCL] mmp$exit_job
    (    xcb_p: ^ost$execution_control_block);

    VAR
      cst_p: ^ost$cpu_state_table;


    mtp$cst_p (cst_p);
    #KEYPOINT (osk$debug, cst_p^.ajlo * osk$m, mmk$exit_job);
    mmp$free_memory_in_job_queues (cst_p^.ijle_p^.job_page_queue_list, TRUE, FALSE, TRUE);

  PROCEND mmp$exit_job;

?? TITLE := 'MMP$MTR_LOCK_RING_1_STACK' ??
?? EJECT ??

{ PURPOSE:
{   This procedure is the monitor part of the process necessary to free a job's ring one stack at termination.
{ DESIGN:
{   This procedure changes the ring one stack to a transient file, and returns the disk file descriptor offset
{   (if there is one) to job mode.  Job mode will then free the disk space associated with the ring one stack.


  PROCEDURE [XDCL] mmp$mtr_lock_ring_1_stack
    (VAR request_block: mmt$rb_lock_ring_1_stack;
        cst_p: ^ost$cpu_state_table);

    VAR
      aste_p: ^mmt$active_segment_table_entry,
      count: 1..32,
      fde_p: gft$locked_file_desc_entry_p,
      found: boolean,
      ipti: integer,
      page_count_freed: integer,
      pointer {CYBIL trick} : ptr_type,
      ste_p: ^mmt$segment_descriptor,
      stxe_p: ^mmt$segment_descriptor_extended,
      sva: ost$system_virtual_address;

    request_block.status.normal := TRUE;
    #KEYPOINT (osk$debug, cst_p^.ajlo * osk$m, mmk$mtr_lock_ring_1_stack);

{ Verify that the ring 1 stack page (an assumption is made that the stack is on one page) is valid in memory.
{ The only way it is not in memory is that it was freed just after the monitor request was issued from ring 1.
{ That is unlikely to happen, so if it has simply reissue the request.  This will cause the job to return to
{ ring 1, reference and get back its ring 1 stack page, and call monitor again.
{ The ring 1 stack must be valid in memory when the file is changed to transient.  If the stack has been
{ written to disk and freed, the job will not be able to page fault and get the page back from disk when it
{ returns.  Instead a new (zeroed out) page would be assigned, which the job cannot return to.

    pointer.pva := cst_p^.xcb_p^.xp.tos_registers [1].pva;

    mmp$convert_pva (pointer.p, cst_p, sva, fde_p, aste_p, ste_p, stxe_p);
    #hash_sva (sva, ipti, count, found);
    IF NOT found OR NOT mmv$pt_p^ [ipti].v THEN
      request_block.status.normal := FALSE;
      RETURN;
    IFEND;

{ Free any pages of the ring 1 stack beyond top of stack that may still be around.  The pages
{ of concern are the pages in the available modified queue.  They got there thru aging while
{ they were still a valid part of the stack.  For some reason they haven't been written out
{ yet (i.e. assign active set) and they were never referenced again.

    IF aste_p^.pages_in_memory > 1 THEN
      mmp$mm_free_pages (sva, 7fffffff(16), aste_p, FALSE, page_count_freed);
      fde_p^.eoi_byte_address := sva.offset;
    IFEND;

    IF fde_p^.media = gfc$fm_mass_storage_file THEN
      request_block.disk_file_descriptor_offset := fde_p^.disk_file_descriptor_p;
      dmp$deallocate_file_space (fde_p, 0, amc$file_byte_limit);
      fde_p^.media := gfc$fm_transient_segment;
    ELSE
      request_block.disk_file_descriptor_offset := 0;
    IFEND;

  PROCEND mmp$mtr_lock_ring_1_stack;

?? TITLE := 'MMP$DETERMINE_ERROR_STATE' ??
?? EJECT ??
  PROCEDURE [XDCL] mmp$determine_error_state (
         list_p: ^mmt$rma_list;
         list_length: mmt$rma_list_length;
     VAR io_error: boolean);

    VAR
      pfte_p: ^mmt$page_frame_table_entry,
      pfti: mmt$page_frame_index,
      list_i: mmt$rma_list_index;

    io_error := FALSE;

    /check_pages/
      FOR list_i := 1 TO list_length DO
        IF list_p^ [list_i].length = 0 THEN
          EXIT /check_pages/;
        IFEND;
        pfti := list_p^ [list_i].rma DIV osv$page_size;
        pfte_p := ^mmv$pft_p^ [pfti];
        IF (pfte_p^.io_error = ioc$media_error) OR
              (pfte_p^.io_error = ioc$unrecovered_error) OR
              (pfte_p^.io_error = ioc$error_on_init) THEN
          io_error := TRUE;
          RETURN;
        IFEND;
      FOREND /check_pages/;

  PROCEND mmp$determine_error_state;
?? TITLE := 'MMP$QUICK_SWEEP' ??

?? EJECT ??
{------------------------------------------------------------------
{This procedure is a special call  to age the Shared Page Queues.
{
{   MMP$QUICK_SWEEP
{
{-----------------------------------------------------------------------

  PROCEDURE [XDCL,#GATE] mmp$quick_sweep;

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      last_pfti: mmt$page_frame_index,
      mcount: integer,
      pfte_p: ^mmt$page_frame_table_entry,
      pfti: mmt$page_frame_index,
      queue: mmt$page_frame_queue_id,
      rcount: integer,
      time_last_quick_sweep: [STATIC] integer := 200000;

{ Age the shared queues if necessary:

    IF  ((#FREE_RUNNING_CLOCK (0) - time_last_quick_sweep) >
          mmv$quick_sweep_interval) THEN

      FOR queue := mmc$pq_shared_first TO mmc$pq_shared_site_06  DO
          mmp$remove_stale_pages (mmv$gpql [queue].pqle, mmv$gpql [queue].age_interval, NIL, NIL,
              mmc$pq_avail_modified, mmv$gpql [queue].minimum, mcount, rcount);
                mmv$sq_mcount := mcount;
                mmv$sq_rcount := rcount;

{ Trim the shared queue down to maximum size; page faulting for a shared page does not automatically trim the
{ shared queue.  A NIL ijl pointer is passed to the remove procedure; the ijl pointer is used only if the file
{ is a job file.  Pages in the shared queues cannot belong to a job file (the shared io error queue is an
{ exception).

        pfti := mmv$gpql [queue].pqle.link.bkw;
        WHILE (mmv$gpql [queue].pqle.count > mmv$gpql [queue].maximum) AND (pfti <> 0) DO
          pfte_p := ^mmv$pft_p^ [pfti];
          last_pfti := pfti;
          pfti := pfte_p^.link.bkw;
          mmp$remove_page_from_jws (last_pfti, NIL {ijle_p}, mcount, rcount);
        WHILEND;
           mmv$jws_mcount := mcount;
           mmv$jws_rcount := rcount;

        mmv$aging_statistics.age_unused_page_in_shared_queue := mmv$aging_statistics.
              age_unused_page_in_shared_queue + rcount;
        IF queue <= mmc$pq_shared_last_sys THEN
          mmv$aging_statistics.age_sys_shared_queue [queue]:=
                mmv$aging_statistics.age_sys_shared_queue[queue] + rcount;
        IFEND;
      FOREND;
      time_last_quick_sweep := #FREE_RUNNING_CLOCK (0);
    IFEND;

{ Call replenish free queue.

    mmp$replenish_free_queues (0);

{ Reclaim unused ast entries

    IF mmv$async_work.reclaim_astes THEN
      mmv$async_work.reclaim_astes := FALSE;
      mmp$reclaim_ast_entries (0);
    IFEND;

{ Reset the time that CP Monitor should next call this procedure.

    mmv$time_to_call_quick_sweep := mmv$quick_sweep_interval + #FREE_RUNNING_CLOCK (0);
  PROCEND mmp$quick_sweep;
?? OLDTITLE ??
MODEND mmm$monitor_request_processor;
*DECK DECK=MMM$MTR_USER_REQUEST_PROCESSOR EXPAND=TRUE
?? NEWTITLE := 'MMM$MTR_USER_REQUEST_PROCESSOR' ??
?? RIGHT := 110, LEFT := 1 ??
MODULE mmm$mtr_user_request_processor {MMMMUR} ;


{
{  PURPOSE:
{     This module contains request processors that deal with interfacing
{     job mode mem mgr requests to mem mgr in mtr mode, locking and unlocking
{     pages, locking and unlocking segments, and setting segment lengths.
{


?? PUSH (LISTEXT := ON) ??
*copyc osc$table_lock_activity
*copyc dfe$error_condition_codes
*copyc dmt$disk_file_descriptor
*copyc gft$file_desc_entry_p
*copyc gft$locked_file_desc_entry_p
*copyc mmt$active_segment_table
*copyc mmt$rb_wait_io_completion
*copyc mmt$rb_lock_unlock_segment
*copyc mmt$lus_declarations
*copyc mmt$rb_change_segment_table
*copyc mme$condition_codes
*copyc mmt$rb_fetch_offset_mod_pages
*copyc mmt$rb_fetch_pva_unwritten_pgs
*copyc mmt$rb_lock_unlock_pages
*copyc mmt$page_frame_index
*copyc mmt$page_frame_queue_id
*copyc mmt$page_selection_criteria
*copyc mmt$rb_free_flush
*copyc mmt$segment_descriptor_table
*copyc mmt$segment_descriptor_table_ex
*copyc mmt$segment_access_rights
*copyc mmt$rb_set_get_segment_length
*copyc mtc$job_fixed_segment
*copyc osd$virtual_address
*copyc ost$cpu_state_table
*copyc ost$heap
*copyc ost$hardware_subranges
*copyc ost$page_table
*copyc ost$execution_control_block
*copyc sft$file_space_limit_kind
*copyc syc$monitor_request_codes
*copyc syt$monitor_request_code
*copyc mmt$io_identifier
*copyc mmt$rb_memory_manager_io
?? POP ??


{  External procedures referenced by this module.

*copyc dfp$fetch_page_status
*copyc dmp$fetch_page_status
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_fau_entry
*copyc gfp$mtr_convert_job_mode_fde_p
*copyc gfp$mtr_get_fde_p
*copyc gfp$mtr_get_locked_fde_p
*copyc gfp$mtr_get_sfid_from_fde_p
*copyc gfp$mtr_unlock_fde_p
*copyc i#move
*copyc i$real_memory_address
*copyc jmp$unlock_ajl
*copyc mmp$asid
*copyc mmp$aste_pointer
*copyc mmp$convert_pva
*copyc mmp$delete_pt_entry
*copyc mmp$fetch_pfti_array_size
*copyc mmp$find_next_pfti
*copyc mmp$get_max_sdt_sdtx_pointer
*copyc mmp$get_verify_asti_in_fde
*copyc mmp$initialize_find_next_pfti
*copyc mmp$mm_free_pages
*copyc mmp$mm_write_modified_pages
*copyc mmp$purge_all_cache_map
*copyc mmp$process_wmp_status
*copyc mmp$relink_page_frame
*copyc mmp$remove_pages_working_set
*copyc mmp$xtask_pva_to_sva
*copyc mmp$verify_pva
*copyc mtp$cst_p
*copyc mtp$error_stop
*copyc mtp$set_status_abnormal
*copyc tmp$clear_lock
*copyc tmp$dequeue_task
*copyc tmp$get_taskid_from_task_queue
*copyc tmp$mtr_begin_lock_activity
*copyc tmp$mtr_end_lock_activity
*copyc tmp$get_xcb_p
*copyc tmp$queue_task
*copyc tmp$set_lock

{  External variables referenced by this module.

*copyc mmv$ast_p
*copyc mmv$multiple_caches
*copyc mmv$multiple_page_maps
*copyc mmv$pfti_array_p
*copyc mmv$pft_p
*copyc mmv$pfti_array_p
*copyc mmv$gpql
*copyc mmv$pt_p
*copyc tmv$ptl_lock
*copyc tmv$ptl_p
*copyc osv$page_size


{  Procedures local to this module.

?? TITLE := 'CONVERT_SVA_TO_PFTE_P' ??
?? EJECT ??

  PROCEDURE convert_sva_to_pfte_p
    (    sva: ost$system_virtual_address;
     VAR pfte_p: ^mmt$page_frame_table_entry;
     VAR status: syt$monitor_status);


{
{  This procedure returns a pointer to the page frame table entry for a specified pva.
{

    VAR
      count: 1 .. 32,
      hash_sva_param2: integer, {Kludge for compiler bug
      pfti: mmt$page_frame_index,
      pti: ost$page_table_index;


    #HASH_SVA (sva, hash_sva_param2, count, status.normal);
    pti := hash_sva_param2; {Kludge for compiler bug
    IF status.normal = FALSE THEN
      status.condition := mme$page_not_in_page_table;
      RETURN;
    IFEND;

    pfti := (mmv$pt_p^ [pti].rma * 512) DIV osv$page_size;
    status.normal := mmv$pt_p^ [pti].v;
    IF status.normal = FALSE THEN
      status.condition := mme$not_valid_in_page_table;
    IFEND;

    pfte_p := ^mmv$pft_p^ [pfti];

  PROCEND convert_sva_to_pfte_p;
?? TITLE := 'LOCK_PAGES' ??
?? EJECT ??

  PROCEDURE lock_pages
    (    sva: ost$system_virtual_address;
         length: ost$byte_count;
     VAR status: syt$monitor_status);


{
{  This procedure processes the lock pages monitor function.
{

    VAR
      initial_lock_offset: ost$segment_offset,
      lock_length: integer,
      lock_sva: ost$system_virtual_address,
      pfte_p: ^mmt$page_frame_table_entry,
      unlock_status: syt$monitor_status;


    status.normal := TRUE;
    IF length = 0 THEN
      RETURN;
    IFEND;

    IF ((length + sva.offset) > UPPERVALUE (ost$segment_offset)) THEN
      mtp$set_status_abnormal ('MM', mme$lock_unlock_invalid_length, status);
      RETURN;
    IFEND;

    lock_length := length + (sva.offset MOD osv$page_size);
    lock_sva := sva;
    lock_sva.offset := lock_sva.offset - (lock_sva.offset MOD osv$page_size);
    initial_lock_offset := lock_sva.offset;


{  Lock page frame table entries until all specified entries locked or encounter a page frame
{  table entry that is already locked.  If this happens unlock all pages locked so far and
{  return error status.

  /lock_pages_loop/
    WHILE TRUE DO
      convert_sva_to_pfte_p (lock_sva, pfte_p, status);
      IF status.normal = FALSE THEN
        unlock_pages (sva, lock_sva.offset - initial_lock_offset, unlock_status);
        RETURN;
      IFEND;

      IF pfte_p^.locked_page <> mmc$lp_not_locked THEN
        unlock_pages (sva, lock_sva.offset - initial_lock_offset, status);
        mtp$set_status_abnormal ('MM', mme$page_already_locked, status);
        RETURN;
      IFEND;

      pfte_p^.locked_page := mmc$lp_aging_lock;
      lock_length := lock_length - osv$page_size;
      IF lock_length <= 0 THEN
        EXIT /lock_pages_loop/;
      IFEND;

      lock_sva.offset := lock_sva.offset + osv$page_size;
    WHILEND /lock_pages_loop/;

  PROCEND lock_pages;
?? TITLE := 'UNLOCK_PAGES' ??
?? EJECT ??

  PROCEDURE unlock_pages
    (    sva: ost$system_virtual_address;
         length: ost$byte_count;
     VAR status: syt$monitor_status);


{
{  This procedure processes the unlock pages monitor function.
{

    VAR
      unlock_length: integer,
      unlock_sva: ost$system_virtual_address,
      pfte_p: ^mmt$page_frame_table_entry;


    status.normal := TRUE;
    IF length = 0 THEN
      RETURN;
    IFEND;

    IF ((sva.offset + length) > UPPERVALUE (ost$segment_offset)) THEN
      mtp$set_status_abnormal ('MM', mme$lock_unlock_invalid_length, status);
      RETURN;
    IFEND;

    unlock_sva := sva;
    unlock_sva.offset := unlock_sva.offset - (unlock_sva.offset MOD osv$page_size);
    unlock_length := length + (sva.offset MOD osv$page_size);


{  Unlock page frame table entries specified by pva and length.

  /unlock_page_frames/
    WHILE TRUE DO
      convert_sva_to_pfte_p (unlock_sva, pfte_p, status);
      IF (status.normal = TRUE) AND (pfte_p^.locked_page = mmc$lp_aging_lock) THEN
        pfte_p^.locked_page := mmc$lp_not_locked;
      IFEND;

      unlock_length := unlock_length - osv$page_size;
      IF unlock_length <= 0 THEN
        EXIT /unlock_page_frames/;
      IFEND;

      unlock_sva.offset := unlock_sva.offset + osv$page_size;
    WHILEND /unlock_page_frames/;

    status.normal := TRUE;

  PROCEND unlock_pages;
?? TITLE := 'MMP$MTR_CHANGE_SEGMENT_TABLE' ??
?? EJECT ??
*copy mmh$mtr_change_segment_table

  PROCEDURE [XDCL] mmp$mtr_change_segment_table
    (VAR request_block: mmt$rb_change_segment_table;
         cst_p: ^ost$cpu_state_table);

    VAR
      new_sdt_p: ^cell,
      new_sdtx_p: ^cell,
      old_sdt_p: mmt$max_sdt_p,
      old_sdtx_p: mmt$max_sdtx_p,
      sdt_rma: integer,
      sdt_entries: integer,
      xcb_p: ^ost$execution_control_block;

    request_block.status.normal := TRUE;
    xcb_p := cst_p^.xcb_p;

{  Convert SDT and SDTX pointer from pointers relative to job's address space to pointers
{  relative to monitor's address space.

    new_sdt_p := #ADDRESS (1, #SEGMENT (xcb_p), request_block.new_sdt_offset);
    mmp$get_max_sdt_sdtx_pointer (xcb_p, old_sdt_p, old_sdtx_p);
    sdt_entries := xcb_p^.xp.segment_table_length +1;
    i#move (old_sdt_p, new_sdt_p, sdt_entries * 8);

{ The only time the new_sdtx_offset should equal zero is when this request
{ is called during job recovery.

    IF request_block.new_sdtx_offset <> 0 THEN
      new_sdtx_p := #ADDRESS (1, #SEGMENT (xcb_p), request_block.new_sdtx_offset);
      i#move (old_sdtx_p, new_sdtx_p, sdt_entries * #SIZE (mmt$segment_descriptor_extended));
      xcb_p^.sdtx_offset := request_block.new_sdtx_offset;
    IFEND;

{  Update the segment table address and length in the job's exchange package.

    i#real_memory_address (new_sdt_p, sdt_rma);
    xcb_p^.xp.segment_table_address_1 := sdt_rma DIV 10000(16);
    xcb_p^.xp.segment_table_address_2 := sdt_rma MOD 10000(16);
    xcb_p^.sdt_offset := request_block.new_sdt_offset;
    xcb_p^.xp.segment_table_length := request_block.new_sdt_length;

  PROCEND mmp$mtr_change_segment_table;
?? TITLE := 'MMP$MTR_FETCH_OFFSET_MOD_PAGES' ??
?? EJECT ??

  PROCEDURE [XDCL] mmp$mtr_fetch_offset_mod_pages
    (VAR rb: mmt$rb_fetch_offset_mod_pages;
         cst_p: ^ost$cpu_state_table);

*copy mmh$mtr_fetch_offset_mod_pages

    TYPE
      array_ptr_type = record
        case b: 0 .. 1 of
        = 0 =
          array_p: ^array [1 .. * ] of ost$segment_offset,
        = 1 =
          array_pva: ost$pva,
        casend,
      recend;

    VAR
      asid: ost$asid,
      aste_p: ^mmt$active_segment_table_entry,
      asti: mmt$ast_index,
      change_array_ptr: array_ptr_type,
      converted_array_p: ^array [1 .. * ] of ost$segment_offset,
      dfd_p: ^dmt$disk_file_descriptor,
      offset_list_index: integer,
      fde_p: gft$file_desc_entry_p,
      p_fau: ^dmt$file_allocation_unit,
      pfti_array_size: integer,
      pft_index: mmt$page_frame_index,
      sva: ost$system_virtual_address;

{  Initialize status.

    rb.status.normal := TRUE;

{  Convert PVA to SVA and get AST pointer.

    gfp$mtr_get_locked_fde_p (rb.sfid, cst_p^.ijle_p, fde_p);
    mmp$get_verify_asti_in_fde (fde_p, rb.sfid, cst_p^.ijl_ordinal, asti);
    IF asti <> 0 THEN
      mmp$asid (asti, asid);
      sva.asid := asid;
      aste_p := ^mmv$ast_p^ [asti];
    ELSE
      rb.offsets_returned := 0;
      RETURN;
    IFEND;

   sva.offset := 0;
{  Locate all possibly MODIFIED pages for segment and get first pfti.

    mmp$initialize_find_next_pfti (sva, 7ffffff0(16), include_partial_pages, psc_all_except_avail, aste_p,
          pft_index);

{  Ensure that caller's array is large enough to hold all the offsets.

    mmp$fetch_pfti_array_size (pfti_array_size);

    IF pfti_array_size > rb.offsets_returned THEN
      rb.offsets_returned := pfti_array_size;
      RETURN;
    IFEND;

    change_array_ptr.array_p := rb.offset_list;
    change_array_ptr.array_pva.seg := #SEGMENT (^rb);
    converted_array_p := change_array_ptr.array_p;

{  Move all offsets to array supplied by caller.

    offset_list_index := 0;

    IF fde_p^.media = gfc$fm_mass_storage_file THEN
      dmp$get_disk_file_descriptor_p (fde_p, dfd_p);
    IFEND;

    WHILE (pft_index <> 0) AND (offset_list_index < rb.offsets_returned) DO
      IF mmv$pt_p^ [mmv$pft_p^ [pft_index].pti].m THEN
        offset_list_index := offset_list_index + 1;
        converted_array_p^ [offset_list_index] := mmv$pft_p^ [pft_index].sva.offset;
      ELSEIF (rb.return_unallocated_offsets) AND
        (fde_p^.media = gfc$fm_transient_segment) THEN
        offset_list_index := offset_list_index + 1;
        converted_array_p^ [offset_list_index] := mmv$pft_p^ [pft_index].sva.offset;
      ELSEIF (rb.return_unallocated_offsets) AND
        (fde_p^.media = gfc$fm_mass_storage_file) THEN
        dmp$get_fau_entry (dfd_p, mmv$pft_p^ [pft_index].sva.offset, p_fau);
        IF (p_fau = NIL) OR (p_fau^.state = dmc$fau_free) THEN
          offset_list_index := offset_list_index + 1;
          converted_array_p^ [offset_list_index] := mmv$pft_p^ [pft_index].sva.offset;
        IFEND;
      IFEND;
      mmp$find_next_pfti (pft_index);
    WHILEND;

    rb.offsets_returned := offset_list_index;

  PROCEND mmp$mtr_fetch_offset_mod_pages;
?? TITLE := 'MMP$MTR_FETCH_PVA_UNWRITTEN_PGS' ??
?? EJECT ??

  PROCEDURE [XDCL] mmp$mtr_fetch_pva_unwritten_pgs
    (VAR rb: mmt$rb_fetch_pva_unwritten_pgs;
         cst_p: ^ost$cpu_state_table);

*copy mmh$mtr_fetch_pva_unwritten_pgs

    VAR
      offset_list_index: 0 .. 6,
      pft_entry: mmt$page_frame_table_entry,
      pft_index: mmt$page_frame_index,
      sva: ost$system_virtual_address;


    mmp$xtask_pva_to_sva (rb.pva, sva, rb.status);
    IF rb.status.normal = FALSE THEN
      RETURN;
    IFEND;

    pft_index := mmv$gpql [mmc$pq_wired].pqle.link.bkw;
    IF rb.subsequent_request_for_same_pva = TRUE THEN

    /search_pft_for_offset/
      BEGIN

      /find_starting_pft_entry/
        WHILE pft_index <> 0 DO
          pft_entry := mmv$pft_p^ [pft_index];
          IF (sva.asid = pft_entry.sva.asid) AND (rb.next_offset_to_return = pft_entry.sva.offset) THEN
            EXIT /search_pft_for_offset/;
          IFEND;

          pft_index := mmv$pft_p^ [pft_index].link.bkw;
        WHILEND /find_starting_pft_entry/;
        mtp$set_status_abnormal ('MM', mme$no_matching_offset, rb.status);
        RETURN;
      END /search_pft_for_offset/;
    IFEND;

    rb.offset_list_overflow := FALSE;

    IF rb.starting_with_first_page = TRUE THEN
      sva.offset := 0;
    ELSE
      sva.offset := ((sva.offset DIV osv$page_size) + 1) * osv$page_size;
    IFEND;

    offset_list_index := 0;


{  Search wired queue of page frame table entries for entry with matching ASID and an
{  offset that is >=  starting offset.

  /search_pft/
    WHILE pft_index <> 0 DO
      pft_entry := mmv$pft_p^ [pft_index];
      IF (sva.asid = pft_entry.sva.asid) AND (sva.offset <= pft_entry.sva.offset) THEN
        IF offset_list_index >= 6 THEN
          rb.offset_list_overflow := TRUE;
          rb.next_offset_to_return := pft_entry.sva.offset;
          rb.offsets_returned := 6;
          RETURN;
        ELSE
          offset_list_index := offset_list_index + 1;
          rb.offset_list [offset_list_index] := pft_entry.sva.offset;
        IFEND;
      IFEND;
      pft_index := pft_entry.link.bkw;
    WHILEND /search_pft/;

    rb.offsets_returned := offset_list_index;

  PROCEND mmp$mtr_fetch_pva_unwritten_pgs;
?? TITLE := 'MMP$MTR_LOCK_UNLOCK_PAGES' ??
?? EJECT ??

  PROCEDURE [XDCL] mmp$mtr_lock_unlock_pages
    (VAR rb: mmt$rb_lock_unlock_pages;
         cst_p: ^ost$cpu_state_table);

*copy mmh$mtr_lock_unlock_pages

    VAR
      sva: ost$system_virtual_address;


    mmp$xtask_pva_to_sva (rb.pva, sva, rb.status);
    IF rb.status.normal = FALSE THEN
      RETURN;
    IFEND;

    CASE rb.reqcode OF
    = syc$rc_lock_pages =
      CASE rb.lock_page_type OF
      = mmc$lp_aging_lock =
        lock_pages (sva, rb.length, rb.status);
      ELSE
        mtp$set_status_abnormal ('MM', mme$invalid_request, rb.status);
      CASEND;
    = syc$rc_unlock_pages =
      CASE rb.lock_page_type OF
      = mmc$lp_aging_lock =
        unlock_pages (sva, rb.length, rb.status);
      ELSE
        mtp$set_status_abnormal ('MM', mme$invalid_request, rb.status);
      CASEND;
    ELSE
      mtp$set_status_abnormal ('MM', mme$invalid_request, rb.status);
    CASEND;

  PROCEND mmp$mtr_lock_unlock_pages;
?? TITLE := 'MMP$MTR_SET_GET_SEGMENT_LENGTH' ??
?? EJECT ??

  PROCEDURE [XDCL] mmp$mtr_set_get_segment_length
    (VAR request_block: mmt$rb_set_get_segment_length;
         cst_p: ^ost$cpu_state_table);

*copy mmh$mtr_set_get_segment_length

    VAR
      asid: ost$asid,
      asti: mmt$ast_index,
      aste_p: ^mmt$active_segment_table_entry,
      fde_p: gft$locked_file_desc_entry_p,
      ijl_ordinal: jmt$ijl_ordinal,
      new_segment_length: integer,
      old_eoi_state: mmt$eoi_state,
      old_segment_length: integer,
      page_count_freed: integer,
      sfid: gft$system_file_identifier,
      sva: ost$system_virtual_address;


    fde_p := gfp$mtr_convert_job_mode_fde_p (request_block.fde_p, cst_p);

    CASE request_block.subfunction_code OF
    = mmc$sf_get_segment_length_fde_p =
      IF fde_p^.stack_for_ring <> 0 THEN
        IF cst_p^.xcb_p^.xp.p_register.pva.ring > fde_p^.stack_for_ring THEN
          request_block.segment_length := 0;
        ELSEIF cst_p^.xcb_p^.xp.p_register.pva.ring = fde_p^.stack_for_ring THEN
          request_block.segment_length := #OFFSET (cst_p^.xcb_p^.xp.a0_dynamic_space_pointer);
        ELSE
          request_block.segment_length :=
             cst_p^.xcb_p^.xp.tos_registers [fde_p^.stack_for_ring].pva.offset;
        IFEND;
      ELSE
        IF fde_p^.eoi_state = mmc$eoi_uncertain THEN
          fixup_chapter_length (fde_p);
        IFEND;
        request_block.segment_length := fde_p^.eoi_byte_address;
      IFEND;

    = mmc$sf_set_segment_length_fde_p =
      old_segment_length := fde_p^.eoi_byte_address;
      old_eoi_state := fde_p^.eoi_state;
      new_segment_length := request_block.segment_length;

      fde_p^.eoi_byte_address := new_segment_length;
      fde_p^.eoi_state := mmc$eoi_actual;
      fde_p^.flags.eoi_modified := TRUE;

      IF (old_eoi_state = mmc$eoi_uncertain) OR
            ((old_segment_length DIV osv$page_size) > (new_segment_length DIV osv$page_size)) THEN
        gfp$mtr_get_sfid_from_fde_p (fde_p, sfid, ijl_ordinal);
        mmp$get_verify_asti_in_fde (fde_p, sfid, ijl_ordinal, asti);
        IF asti <> 0 THEN
          aste_p := ^mmv$ast_p^ [asti];
          IF aste_p^.pages_in_memory > 0 THEN
            mmp$asid (fde_p^.asti, asid);
            sva.asid := asid;
            sva.offset :=  new_segment_length;
            mmp$mm_free_pages (sva, 7fffffff(16), aste_p, FALSE, page_count_freed);
          IFEND;
        IFEND;
      IFEND;

    ELSE
      mtp$error_stop ('MM - Bad option on get_segment length');
    CASEND;

  PROCEND mmp$mtr_set_get_segment_length;

?? TITLE := '  fixup_chapter_length', EJECT ??

{ This procedure will find the unused pages assigned by mmp$page_pull when the
{ task page faulted for a "new page", release them, and set eoi to the end of the
{ last used page.

  PROCEDURE [INLINE] fixup_chapter_length
    (    fde_p: gft$locked_file_desc_entry_p);

    VAR
      asid: ost$asid,
      aste_p: ^mmt$active_segment_table_entry,
      asti: mmt$ast_index,
      count: 1 .. 32,
      eoi: ost$segment_length,
      found: boolean,
      i: 1 .. 10,
      ijl_ordinal: jmt$ijl_ordinal,
      max_eoi: ost$segment_length,
      offset: integer,
      page_count_freed: integer,
      pages_freed: integer,
      pfti_array: array [1 .. 10] OF mmt$page_frame_index,
      pti: integer,
      sfid: gft$system_file_identifier,
      sva: ost$system_virtual_address;


{ Check if the asid in the fde is still valid.  If not then there are no pages
{ of the file in memory and EOI will be assumed correct.

    gfp$mtr_get_sfid_from_fde_p (fde_p, sfid, ijl_ordinal);
    mmp$get_verify_asti_in_fde (fde_p, sfid, ijl_ordinal, asti);
    IF asti = 0 THEN
      RETURN;
    IFEND;
    mmp$asid (asti, asid);

{ Start searching for unused pages at the highest page assigned and work backwards,
{ stopping at the first modified page.  Eoi is currently set at the end of the page
{ that faulted.  The number 16384 is an arbitrary number that only must be less than
{ or equal to the minimum allocation unit size.  It was used to determine the number
{ of extra pages to assign.

    eoi := fde_p^.eoi_byte_address;
    sva.asid := asid;

    offset := eoi + 16384 - osv$page_size;
    max_eoi := offset;
    pages_freed := 0;

  /find_eoi/
    WHILE offset > eoi DO
      offset := offset - osv$page_size;
      IF offset < osc$maximum_offset THEN
        sva.offset := offset;
        #HASH_SVA (sva, pti, count, found);
        IF found THEN
          IF mmv$pt_p^ [pti].m THEN
            offset := offset + osv$page_size;
            EXIT /find_eoi/;
          IFEND;
          pages_freed := pages_freed + 1;
          mmv$pt_p^ [pti].v := FALSE;
          pfti_array [pages_freed] := (mmv$pt_p^ [pti].rma * 512) DIV osv$page_size;
        IFEND;
      IFEND;
    WHILEND /find_eoi/;

    fde_p^.eoi_byte_address := offset;
    fde_p^.eoi_state := mmc$eoi_rounded;

    IF pages_freed > 0 THEN
      mmp$purge_all_cache_map;
      FOR i := 1 to pages_freed DO
        mmp$delete_pt_entry (pfti_array [i], TRUE);
        mmp$relink_page_frame (pfti_array [i], mmc$pq_free)
      FOREND;
    IFEND;

  PROCEND fixup_chapter_length;

?? TITLE := 'MMP$MTR_LOCK_UNLOCK_SEGMENT', EJECT ??
{------------------------------------------------------------------------------------------}
{This procedure processes the following requests:
{   mmp$lock_segment
{   mmp$unlock_segment
{------------------------------------------------------------------------------------------}


  PROCEDURE [XDCL] mmp$mtr_lock_unlock_segment
    (VAR rb: mmt$rb_lock_unlock_segment;
         cst_p: ^ost$cpu_state_table);

    VAR
      aste_p: ^mmt$active_segment_table_entry,
      ste_p: ^mmt$segment_descriptor,
      stxe_p: ^mmt$segment_descriptor_extended,
      taskid: ost$global_task_id,
      xcb_p: ^ost$execution_control_block,
      page_status: gft$page_status,
      qrb_p: ^mmt$rb_lock_unlock_segment,
      fde_entry_p: gft$locked_file_desc_entry_p,
      dequeue_tasks: boolean,
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      count: integer,
      iotype: [READ, STATIC] array [mmc$lus_protected_write .. mmc$lus_write] of
            iot$io_function := [ioc$write_locked_page, ioc$write_page],
      sva: ost$system_virtual_address,
      ijle_p: ^jmt$initiated_job_list_entry,
      io_id: mmt$io_identifier,
      io_count: mmt$active_io_count,
      io_already_active: boolean,
      last_written_pfti: mmt$page_frame_index,
      wmp_status: mmt$write_modified_pages_status;


    mmp$verify_pva (^rb.pva, mmc$sat_read_or_write, rb.status);

    IF rb.status.normal THEN
      mmp$convert_pva (rb.pva, cst_p, sva, fde_entry_p, aste_p, ste_p, stxe_p);
      CASE rb.request OF
      = mmc$lus_lock_segment =

{ Determine the status/location of the page.

        CASE fde_entry_p^.media OF
        = gfc$fm_transient_segment =
          page_status := gfc$ps_page_doesnt_exist;
        = gfc$fm_mass_storage_file =
          dmp$fetch_page_status (fde_entry_p, sva.offset, stxe_p^.file_limits_enforced,
                 FALSE {allocate_if_new}, page_status);
        = gfc$fm_served_file =
          dfp$fetch_page_status (fde_entry_p, sva.offset, page_status);
        ELSE
          mtp$error_stop ('MM - bad FDE.MEDIA');
        CASEND;

        IF page_status = gfc$ps_volume_unavailable THEN
          mtp$set_status_abnormal ('MM', mme$volume_unavailable, rb.status);
          RETURN;
        ELSEIF page_status = gfc$ps_server_terminated THEN
          mtp$set_status_abnormal ('DF', dfe$server_has_terminated, rb.status);
          RETURN;
        IFEND;
        IF (stxe_p^.segment_lock <> mmc$lss_none) AND
          (stxe_p^.segment_lock <> mmc$lss_queued_for_lock_r3) AND
          (stxe_p^.segment_lock <> mmc$lss_queued_for_lock_user) THEN
          mtp$set_status_abnormal ('MM', mme$segment_locked_by_task, rb.status);
        ELSEIF (rb.access = mmc$lus_lock_for_read) AND NOT
          (fde_entry_p^.segment_lock.locked_for_write) AND (fde_entry_p^.segment_lock.task_queue.head = 0) AND
             (fde_entry_p^.segment_lock.locked_for_read <
                  UPPERVALUE (fde_entry_p^.segment_lock.locked_for_read)) THEN
          fde_entry_p^.segment_lock.locked_for_read := fde_entry_p^.segment_lock.locked_for_read + 1;
          IF rb.catalog_segment OR (cst_p^.xcb_p^.xp.p_register.pva.ring > 3) THEN
            tmp$mtr_begin_lock_activity (cst_p^.xcb_p, osc$subsystem_lock_activity);
            stxe_p^.segment_lock := mmc$lss_lock_for_read_user;
          ELSE
            tmp$mtr_begin_lock_activity (cst_p^.xcb_p, osc$system_lock_activity);
            stxe_p^.segment_lock := mmc$lss_lock_for_read_r3;
          IFEND;
        ELSEIF (rb.access = mmc$lus_lock_for_write) AND (fde_entry_p^.segment_lock.locked_for_read = 0) AND
              NOT fde_entry_p^.segment_lock.locked_for_write THEN
          fde_entry_p^.segment_lock.locked_for_write := TRUE;
          cst_p^.ijle_p^.override_job_working_set_max := TRUE;
          cst_p^.ijle_p^.segment_lock_count := cst_p^.ijle_p^.segment_lock_count + 1;
          IF rb.catalog_segment OR (cst_p^.xcb_p^.xp.p_register.pva.ring > 3) THEN
            tmp$mtr_begin_lock_activity (cst_p^.xcb_p, osc$subsystem_lock_activity);
            stxe_p^.segment_lock := mmc$lss_lock_for_write_user;
          ELSE
            tmp$mtr_begin_lock_activity (cst_p^.xcb_p, osc$system_lock_activity);
            stxe_p^.segment_lock := mmc$lss_lock_for_write_r3;
          IFEND;
        ELSE
          mtp$set_status_abnormal ('MM', mme$segment_locked_another_task, rb.status);
          IF rb.wait = osc$wait THEN
            IF rb.catalog_segment OR (cst_p^.xcb_p^.xp.p_register.pva.ring > 3) THEN
              stxe_p^.segment_lock := mmc$lss_queued_for_lock_user;
            ELSE
              stxe_p^.segment_lock := mmc$lss_queued_for_lock_r3;
            IFEND;
            tmp$queue_task (cst_p^.taskid, tmc$ts_segment_lock_wait, fde_entry_p^.segment_lock.task_queue);
          IFEND;
        IFEND;

      = mmc$lus_unlock_segment =
        IF stxe_p^.segment_lock = mmc$lss_none THEN
          mtp$set_status_abnormal ('MM', mme$segment_not_locked, rb.status);
        ELSEIF fde_entry_p^.segment_lock.locked_for_write THEN
          sva.offset := 0;
          CASE rb.page_disposition OF
          = mmc$lus_write, mmc$lus_protected_write =
            io_id.specified := FALSE;
            io_id.io_function := iotype [rb.page_disposition];
            mmp$mm_write_modified_pages (sva, 7ffffff0(16), fde_entry_p, aste_p, iotype [rb.page_disposition],
                  rb.init_new_io, FALSE, io_id, io_count, io_already_active, last_written_pfti, wmp_status);
            mmp$process_wmp_status (wmp_status, last_written_pfti, rb.wait, rb.init_new_io, rb.status);
            IF ((wmp_status <> mmc$wmp_io_complete) AND (wmp_status <> mmc$wmp_io_active)) OR
               ((wmp_status = mmc$wmp_io_active) AND (rb.wait = osc$wait)) THEN
              RETURN;
            IFEND;
          = mmc$lus_remove_from_working_set =
            mmp$remove_pages_working_set (sva, 7ffffff0(16), aste_p, count);
          = mmc$lus_free =
            mmp$mm_free_pages (sva, 7ffffff0(16), aste_p, FALSE, count);
          = mmc$lus_none =
          ELSE
            mtp$set_status_abnormal ('MM', mme$invalid_request, rb.status);
            RETURN;
          CASEND;
          IF stxe_p^.segment_lock = mmc$lss_lock_for_write_r3 THEN
            tmp$mtr_end_lock_activity (cst_p, osc$system_lock_activity, cst_p^.xcb_p);
          ELSE
            tmp$mtr_end_lock_activity (cst_p, osc$subsystem_lock_activity, cst_p^.xcb_p);
          IFEND;
          fde_entry_p^.segment_lock.locked_for_write := FALSE;
          cst_p^.ijle_p^.override_job_working_set_max := FALSE;
           IF cst_p^.ijle_p^.segment_lock_count > 0 THEN
             cst_p^.ijle_p^.segment_lock_count := cst_p^.ijle_p^.segment_lock_count - 1;
           IFEND;
        ELSE
          IF stxe_p^.segment_lock = mmc$lss_lock_for_read_r3 THEN
            tmp$mtr_end_lock_activity (cst_p, osc$system_lock_activity, cst_p^.xcb_p);
          ELSE
            tmp$mtr_end_lock_activity (cst_p, osc$subsystem_lock_activity, cst_p^.xcb_p);
          IFEND;
          fde_entry_p^.segment_lock.locked_for_read := fde_entry_p^.segment_lock.locked_for_read - 1;
        IFEND;
        stxe_p^.segment_lock := mmc$lss_none;

        dequeue_tasks := NOT fde_entry_p^.segment_lock.locked_for_write AND
          ((fde_entry_p^.segment_lock.locked_for_read = 0) OR
          (fde_entry_p^.segment_lock.locked_for_read =
            UPPERVALUE (fde_entry_p^.segment_lock.locked_for_read) - 1));

{ Set the PTL lock while scanning the segment_lock task_queue.  Tmp$set_task_ready, which runs
{ asynchronously--NOT under the master monitor interlock, can be removing tasks from the queue
{ on the other processor.

        tmp$set_lock (tmv$ptl_lock);
        WHILE dequeue_tasks AND (fde_entry_p^.segment_lock.task_queue.head <> 0) DO
          tmp$get_taskid_from_task_queue (fde_entry_p^.segment_lock.task_queue, taskid);
          tmp$get_xcb_p (taskid, xcb_p, ijle_p);
          IF xcb_p <> NIL THEN
            qrb_p := #LOC (xcb_p^.xp.x_registers [0]);
            mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);
            stxe_p := ^sdtx_p^.sdtx_table [#SEGMENT (qrb_p^.pva)];
            IF qrb_p^.access = mmc$lus_lock_for_read THEN
              fde_entry_p^.segment_lock.locked_for_read := fde_entry_p^.segment_lock.locked_for_read + 1;
              IF stxe_p^.segment_lock = mmc$lss_queued_for_lock_r3 THEN
                tmp$mtr_begin_lock_activity (xcb_p, osc$system_lock_activity);
                stxe_p^.segment_lock := mmc$lss_lock_for_read_r3;
              ELSE
                tmp$mtr_begin_lock_activity (xcb_p, osc$subsystem_lock_activity);
                stxe_p^.segment_lock := mmc$lss_lock_for_read_user;
              IFEND;
              IF fde_entry_p^.segment_lock.locked_for_read =
                 UPPERVALUE (fde_entry_p^.segment_lock.locked_for_read) THEN
                dequeue_tasks := FALSE;
              IFEND;
            ELSEIF fde_entry_p^.segment_lock.locked_for_read = 0 THEN
              fde_entry_p^.segment_lock.locked_for_write := TRUE;
              IF stxe_p^.segment_lock = mmc$lss_queued_for_lock_r3 THEN
                tmp$mtr_begin_lock_activity (xcb_p, osc$system_lock_activity);
                stxe_p^.segment_lock := mmc$lss_lock_for_write_r3;
              ELSE
                tmp$mtr_begin_lock_activity (xcb_p, osc$subsystem_lock_activity);
                stxe_p^.segment_lock := mmc$lss_lock_for_write_user;
              IFEND;
              dequeue_tasks := FALSE;
            ELSE
              jmp$unlock_ajl (ijle_p);
              tmp$clear_lock (tmv$ptl_lock);
              RETURN;
            IFEND;
            qrb_p^.status.normal := TRUE;
            jmp$unlock_ajl (ijle_p);
          IFEND;
          tmp$dequeue_task (fde_entry_p^.segment_lock.task_queue, taskid);
        WHILEND;
        tmp$clear_lock (tmv$ptl_lock);
      ELSE
        mtp$set_status_abnormal ('MM', mme$invalid_request, rb.status);
      CASEND;
    IFEND;

  PROCEND mmp$mtr_lock_unlock_segment;
?? TITLE := 'mmp$mtr_wait_io_completion', EJECT ??
*copyc mmh$wait_io_completion


  PROCEDURE [XDCL] mmp$mtr_wait_io_completion
    (VAR rb: mmt$rb_wait_io_completion;
         cst_p: ^ost$cpu_state_table);

    VAR
      count: 1 .. 32,
      found: boolean,
      pti: integer,
      pfti: mmt$page_frame_index,
      sva: ost$system_virtual_address;

    mmp$verify_pva (^rb.pva, mmc$sat_read_or_write, rb.status);
    IF rb.status.normal THEN
      mmp$xtask_pva_to_sva (rb.pva, sva, rb.status);
      IF rb.status.normal THEN
        #HASH_SVA (sva, pti, count, found);
        IF found THEN
          pfti := (mmv$pt_p^ [pti].rma * 512) DIV osv$page_size;
          IF mmv$pft_p^ [pfti].active_io_count <> 0 THEN
            cst_p^.xcb_p^.page_wait_info.pva := NIL;
            tmp$queue_task (cst_p^.taskid, tmc$ts_io_wait_queued, mmv$pft_p^ [pfti].task_queue);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND mmp$mtr_wait_io_completion;
?? TITLE := 'MMP$MODIFY_PAGES' ??
?? EJECT ??

  PROCEDURE [XDCL] mmp$modify_pages
    (    fde_p: gft$locked_file_desc_entry_p;
         offset: ost$segment_offset;
         length: ost$byte_count;
         set_modified_bit: boolean;
     VAR status: syt$monitor_status);


{  This procedure verifies that all pages of a given sva range
{  are in memory and optionally sets the modified bits.

{  This request is used only by dmp$reallocate_file_space to verify
{  that all the pages of an allocation unit being reallocated are in memory
{  and to cause them to be modified and therefore written to the new allocation
{  unit.

    VAR
      asid: ost$asid,
      asti: mmt$ast_index,
      ijlo: jmt$ijl_ordinal,
      lock_length: integer,
      sfid: gft$system_file_identifier,
      sva: ost$system_virtual_address,
      pfte_p: ^mmt$page_frame_table_entry,
      pfti: mmt$page_frame_index;


    status.normal := TRUE;

    gfp$mtr_get_sfid_from_fde_p (fde_p, sfid, ijlo);
    mmp$get_verify_asti_in_fde (fde_p, sfid, ijlo, asti);
    IF asti = 0 THEN
      mtp$set_status_abnormal ('MM', mme$page_not_in_page_table, status);
      RETURN;
    IFEND;
    mmp$asid (asti, asid);

    lock_length := length + (offset MOD osv$page_size);
    sva.asid := asid;
    sva.offset := offset;

  /modify_pages_loop/
    WHILE TRUE DO
      convert_sva_to_pfte_p (sva, pfte_p, status);
      IF NOT status.normal THEN
        mtp$set_status_abnormal ('MM', mme$page_not_in_page_table, status);
        RETURN;
      IFEND;

      IF NOT mmv$pt_p^ [pfte_p^.pti].v THEN
        {Return if page is not modify-able
        mtp$set_status_abnormal ('MM', mme$page_not_in_page_table, status);
        RETURN;
      IFEND;

      IF set_modified_bit THEN
        mmv$pt_p^ [pfte_p^.pti].m := TRUE;
        {Allow retry of write operations
        pfte_p^.io_error := ioc$no_error;
        pfti := (mmv$pt_p^ [pfte_p^.pti].rma * 512) DIV osv$page_size;
        mmp$relink_page_frame (pfti, pfte_p^.aste_p^.queue_id);
      ELSEIF pfte_p^.active_io_count > 0 THEN
        {Return if page is not idle
        mtp$set_status_abnormal ('MM', mme$page_not_in_page_table, status);
        RETURN;
      IFEND;

      lock_length := lock_length - osv$page_size;
      IF lock_length <= 0 THEN
        EXIT /modify_pages_loop/;
      IFEND;

      sva.offset := sva.offset + osv$page_size;
    WHILEND /modify_pages_loop/;

  PROCEND mmp$modify_pages;
MODEND mmm$mtr_user_request_processor;
*DECK DECK=MMM$PAGE_FAULT_PROCESSOR EXPAND=TRUE
?? RIGHT := 110 ??
MODULE mmm$page_fault_processor;
{
{  PURPOSE: Memory_Manager
{     This module contains the monitor routines that are used to
{     manage physical memory and the page table.
{
{

?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dft$server_descriptor
*copyc dmt$mass_storage_error_codes
*copyc ioe$st_errors
*copyc iot$io_error
*copyc jmt$delayed_swapin_work
*copyc jmt$ijl_swap_status
*copyc jmt$job_scheduler_event
*copyc mmc$first_transient_segment
*copyc mmc$move_pages_max_req_length
*copyc mmc$shadow_allocation_size
*copyc mmd$segment_access_condition
*copyc mme$condition_codes
*copyc mmk$monitor_mode_keypoints
*copyc mmt$active_segment_table
*copyc mmt$age_reason
*copyc mmt$aging_statistics
*copyc mmt$asid_list_page_table_full
*copyc mmt$assign_contig_passes
*copyc mmt$async_work_list
*copyc mmt$buffer_descriptor
*copyc mmt$continue_bit_count
*copyc mmt$int_segment_access_fault
*copyc mmt$io_identifier
*copyc mmt$keypoint_page_fault_status
*copyc mmt$make_pt_entry_status
*copyc mmt$move_pages_page_count
*copyc mmt$page_frame_index
*copyc mmt$page_frame_queue_id
*copyc mmt$page_frame_table
*copyc mmt$page_pull_status
*copyc mmt$page_queue_list
*copyc mmt$page_streaming_statistics
*copyc mmt$paging_statistics
*copyc mmt$pf_statistics
*copyc mmt$rb_advise
*copyc mmt$rb_assign_contig_memory
*copyc mmt$rb_assign_pages
*copyc mmt$rb_move_pages
*copyc mmt$reassignable_page_frames
*copyc mmt$rma_list
*copyc mmt$segment_access_rights
*copyc mmt$segment_access_type
*copyc mmt$update_eoi_reason
*copyc mtc$job_fixed_segment
*copyc osc$processor_defined_registers
*copyc osc$purge_map_and_cache
*copyc ost$cpu_state_table
*copyc ost$heap
*copyc ost$keypoint_control
*copyc ost$page_size
*copyc ost$segment_access_control
*copyc ptk$performance_keypoints
*copyc sft$file_space_limit_kind
*copyc syt$monitor_flag
*copyc syt$perf_keypoints_enabled
*copyc tmc$signal_identifiers
*copyc tmt$fnx_search_type
?? POP ??

*copyc mmc$debug_constants
?? SKIP := 2 ??
*copyc mmc$manage_memory_utility
?? SKIP := 2 ??

{External procedures used by this module.

*copyc dfi$monitor_display
*copyc dfp$fetch_multi_page_status
*copyc dfp$fetch_page_status
*copyc dfp$file_server_allocation
*copyc dfp$get_served_file_desc_p
*copyc dfp$server_io
*copyc dmp$fetch_multi_page_status
*copyc dmp$fetch_page_status
*copyc dpp$display_error
*copyc gfp$mtr_get_sfid_from_fde_p
*copyc gfp$mtr_get_fde_p
*copyc gfp$mtr_get_locked_fde_p
*copyc gfp$mtr_unlock_fde_p
*copyc i#real_memory_address
*copyc iop$enable_all_disk_units
*copyc iop$pager_io
*copyc jmp$check_scheduler_memory_wait
*copyc jmp$get_ijle_p
*copyc jmp$recognize_thrashing
*copyc jmp$set_scheduler_event
*copyc jmp$unlock_ajl
*copyc jsp$free_swapped_jobs_memory
*copyc mmp$assign_asid
*copyc mmp$check_queues
*copyc mmp$delete_pt_entry
*copyc mmp$fetch_pfti_array_size
*copyc mmp$find_next_pfti
*copyc mmp$find_next_pfti
*copyc mmp$free_asid
*copyc mmp$get_inhibit_io_status
*copyc mmp$initialize_find_next_pfti
*copyc mmp$make_pt_entry
*copyc mmp$get_sdt_entry_p
*copyc mmp$get_sdtx_entry_p
*copyc mmp$get_verify_asti_in_fde
*copyc mmp$page_pull_hash_sva
*copyc mmp$preset_real_memory
*copyc mmp$purge_all_cache_map
*copyc mmp$purge_all_cache_proc
*copyc mmp$purge_all_map_proc
*copyc mmp$remove_pages_working_set
*copyc mmp$reset_find_next_pfti
{      mmp$reset_store_next_pfti contains inline proc named mmp$reset_store_pfti
*copyc mmp$reset_store_next_pfti
*copyc mmp$reset_store_pfti_reverse
*copyc mmp$set_include_pages_in_dump
{      mmp$store_next_pfti contains  inline proc named mmp$store_pfti
*copyc mmp$store_next_pfti
*copyc mmp$store_pfti_reverse
*copyc mmp$sva_purge_all_cache
*copyc mtp$cst_p
*copyc mtp$error_stop
*copyc mtp$set_status_abnormal
*copyc mtp$step_unstep_system
*copyc mtp$store_informative_message
*copyc osp$process_keypoint_page_fault
*copyc tmp$cause_task_switch
*copyc tmp$dequeue_task
*copyc tmp$find_next_xcb
*copyc tmp$get_top_of_stack
*copyc tmp$get_xcb_p
*copyc tmp$monitor_flag_job_tasks
*copyc tmp$queue_task
*copyc tmp$reissue_monitor_request
*copyc tmp$send_monitor_fault
*copyc tmp$set_monitor_flag
*copyc tmp$test_get_xcb_p
?? TITLE := 'Global Variable Declarations - XREF and XDCL' ??
?? EJECT ??

{--------------------------------------------------------------------------------------------------------

?? SKIP := 2 ??
*copyc dfv$file_server_debug_enabled
?? SKIP := 2 ??
*copyc gfv$null_sfid
?? SKIP := 2 ??
*copyc jmv$ajl_p
?? SKIP := 2 ??
*copyc jmv$ijl_p
?? SKIP := 2 ??
*copyc jmv$null_ijl_ordinal
?? SKIP := 2 ??
*copyc jmv$service_classes
?? SKIP := 2 ??
*copyc jmv$system_ijl_ordinal
?? SKIP := 2 ??
*copyc jsv$free_working_set_on_swapout
?? SKIP := 2 ??
*copyc jsv$ijl_swap_queue_list
?? SKIP := 2 ??
*copyc jsv$max_pages_first_swap_task
?? SKIP := 2 ??
*copyc jsv$maximum_pages_to_swap
?? SKIP := 2 ??
*copyc mmv$aging_algorithm
?? SKIP := 2 ??
*copyc mmv$image_file
?? SKIP := 2 ??
*copyc mmv$jws_queue_age_interval
?? SKIP := 2 ??
*copyc mmv$pages_to_dump_p
?? SKIP := 2 ??
*copyc mmv$pfti_array_p
?? SKIP := 2 ??
*copyc mmv$pfti_array_p
?? SKIP := 2 ??
*copyc mmv$preset_conversion_table
?? SKIP := 2 ??
*copyc mmv$time_to_call_mem_mgr
?? SKIP := 2 ??
*copyc mtv$monitor_segment_table
?? SKIP := 2 ??
*copyc mtv$sys_core_init_complete
?? SKIP := 2 ??
*copyc osv$180_memory_limits
?? SKIP := 2 ??
*copyc osv$time_to_check_asyn
?? SKIP := 2 ??
*copyc tmv$null_global_task_id
?? SKIP := 2 ??
*copyc tmv$ptl_p
?? SKIP := 2 ??

{Define AST template for job swapper to use to create a new entry for a Job Fixed segment.

  VAR
    mmv$initial_job_fixed_ast_entry: [XDCL, READ] mmt$active_segment_table_entry :=
          [[0, 0], 0, [0, 0], TRUE, mmc$pq_job_fixed, * , TRUE];

{ Define array for keeping statistics on status values returned from MMP$WRITE_PAGE_TO_DISK.

  VAR
    mmv$write_page_statistics: [XDCL] array [mmt$write_page_to_disk_status] of integer :=
          [0, 0, 0, 0, 0, 0, 0];

?? SKIP := 2 ??

{  The following variables + the Global Page Queue List below are all managed by the Manage Memory Utility.
{      mmv$age_interval_ceiling
{      mmv$age_interval_floor
{      mmv$aggressive_aging_level
{      mmv$aggressive_aging_level_2
{      mmv$aging_algorithm
{      mmv$jws_queue_age_interval
{      mmv$last_active_shared_queue
{      mmv$min_avail_pages
{      mmv$page_streaming_prestream
{      mmv$page_streaming_threshold
{      mmv$page_streaming_reads
{      mmv$page_streaming_random_limit
{      mmv$periodic_call_interval
{      mmv$tick_time
{      mmv$shared_queue_age_interval
{      mmv$swapping_aic
{
{  Define array for the Global Page Queue List and initialize it to the default values as defined in the
{  common deck mmc$manage_memory_utility.
{


?? FMT (FORMAT := OFF) ??
  VAR
    mmv$gpql: [XDCL, #GATE] mmt$global_page_queue_list :=
          [ [[[0,0],0],0,0,0],               {free }
            [[[0,0],0],0,0,0],               {available}
            [[[0,0],0],0,0,0],               {available modified}
            [[[0,0],0],0,0,0],               {wired}
            [[[0,0],0],mmc$mmu_queue_age_task_service,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum],
            [[[0,0],0],mmc$mmu_queue_age_pf_execute,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum],
            [[[0,0],0],mmc$mmu_queue_age_pf_non_exec,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum],
            [[[0,0],0],mmc$mmu_queue_age_device_file,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum],
            [[[0,0],0],mmc$mmu_queue_age_file_server,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum],
            [[[0,0],0],mmc$mmu_queue_age_other,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum],
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_01}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_02}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_03}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_04}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_05}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_06}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_07}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_08}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_09}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_10}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_11}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_12}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_13}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_14}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_15}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_16}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_17}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_18}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_19}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_20}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_21}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_22}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_23}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_24}
            [[[0,0],0],mmc$mmu_queue_age_site_queues,mmc$mmu_queue_minimum,mmc$mmu_queue_maximum], {site_25}
            [[[0,0],0],1,0,0],               {shared_io_error}
            [[[0,0],0],1,0,0],               {swapped_io_error}
            [[[0,0],0],0,0,0]   ];           {flawed}
?? FMT (FORMAT := ON) ??

?? SKIP := 2 ??

  VAR
    null_pva: 0 .. 0ffffffffffff(16),
    null_sva: [STATIC] ost$system_virtual_address := [0, 0],
    total_contig_pages_assigned: integer := 0,

    mmv$advise_in_aio_limit: [XDCL, #GATE] integer := 24,
    mmv$age_interval_ceiling: [XDCL, #GATE] 0 .. 255 := mmc$mmu_age_interval_ceiling,
    mmv$age_interval_floor: [XDCL, #GATE] 0 .. 255 := mmc$mmu_age_interval_floor,
    mmv$aggressive_aging_level: [XDCL, #GATE] integer := mmc$mmu_aggressive_aging_one,
    mmv$aggressive_aging_level_2: [XDCL, #GATE] integer := mmc$mmu_aggressive_aging_two,
    mmv$aging_statistics: [XDCL, #GATE] mmt$aging_statistics,
    mmv$aio_limit_count: [XDCL, #GATE] integer := 0,
    mmv$assign_contiguous_pass_cnt: mmt$assign_contig_passes := [0, 0, 0],
    mmv$assign_contig_reject: integer,
    mmv$assign_multiple_pages: [XDCL, #GATE] integer := 50,
    mmv$assign_pages_purge_count: integer := 0,
    mmv$ast_p: [XDCL, #GATE] ^mmt$active_segment_table := NIL,
    mmv$async_work: [XDCL] mmt$async_work_list := [FALSE, FALSE, [0, 0], NIL],
    mmv$avail_modified_queue_max: [XDCL, #GATE] integer := 65535,
    mmv$contiguous_mem_length_max: [XDCL, #GATE] ost$segment_length := 65536,
    mmv$dm_flag_on_write: [XDCL] 0 .. 0ffffffff(16) := 1,
    mmv$file_allocation_interval: [XDCL, #GATE] integer := 20000,
    mmv$jmtr_escaped_allocate: [XDCL, #GATE] integer := 0,
    mmv$last_active_shared_queue: [XDCL, #GATE] mmt$global_page_queue_index := mmc$pq_shared_last_sys,
    mmv$last_segment_accessed: [XDCL, #GATE] ost$segment,
    mmv$lost_escaped_allocate: [XDCL, #GATE] integer := 0,
    mmv$max_pages_no_file: [XDCL, #GATE] integer := 15, {This constant is forced negative during deadstart
    { to disable transient segments til Space Mgr runs.
    mmv$max_working_set_size: [XDCL, #GATE] integer := 1000,
    mmv$maxws_aio_count: [XDCL] integer := 0,
    mmv$maxws_aio_slowdown: [XDCL] integer := 60000000,
    mmv$maxws_aio_threshold: [XDCL, #GATE] integer := 10,
    mmv$maximum_write_span: [XDCL, #GATE] integer := 4000000(16),
    mmv$memory_wait_queue: [XDCL] tmt$task_queue_link := [0, 0],
    mmv$min_avail_pages: [XDCL, #GATE] integer := mmc$mmu_min_avail_pages,
    mmv$multiple_caches: [XDCL, #GATE] boolean := FALSE,
    mmv$multiple_page_maps: [XDCL, #GATE] boolean := FALSE,
    mmv$multi_page_write: [XDCL, #GATE] boolean := TRUE,
    mmv$no_memory_buffering: [XDCL, #GATE] boolean := FALSE,
    mmv$pages_per_new_page_fault: [XDCL, #GATE] 1 .. 8 := 1,
    mmv$page_skip_count: [XDCL, #GATE]  integer := 16,
    mmv$page_streaming_prestream: [XDCL, #GATE] 0 .. 255 := mmc$mmu_ps_prestream,
    mmv$page_streaming_threshold: [XDCL, #GATE] integer := mmc$mmu_ps_threshold,
    mmv$page_streaming_transfer: [XDCL, #GATE] integer := mmc$mmu_ps_transfer_size,
    mmv$page_streaming_reads: [XDCL, #GATE] 0 .. 255 := mmc$mmu_ps_reads,
    mmv$page_streaming_random_limit: [XDCL, #GATE] 0 .. 255 := mmc$mmu_ps_random_limit,
    mmv$pages_for_overallocation: [XDCL, #GATE] integer := 16,
    mmv$paging_statistics: [XDCL, #GATE] mmt$paging_statistics,
    mmv$pf_statistics: [XDCL, #GATE] mmt$pf_statistics,
    mmv$pf_sva_array: [XDCL] record
      next_i: integer,
      pf_recs: array [0 .. num_pf_recs - 1] of packed record
        pstatus_time: 0 .. 0ffff(16),
        sva: ost$system_virtual_address,
      recend,
    recend,
    mmv$pft_p: [XDCL, #GATE] ^mmt$page_frame_table := NIL,
    mmv$post_deadstart: [XDCL, #GATE] boolean := FALSE,
    mmv$pt_length: [XDCL, #GATE] integer,
    mmv$pt_p: [XDCL, #GATE] ^ost$page_table,
    mmv$reassignable_page_frames: [XDCL, #GATE] mmt$reassignable_page_frames,
    mmv$read_tu_execute: [XDCL, #GATE] 0 .. 0ffffffff(16) := 1,
    mmv$read_tu_read_write: [XDCL, #GATE] 0 .. 0ffffffff(16) := 1,
    mmv$refs_to_unrec_df_file_inhib: [XDCL, #GATE] integer := 0,
    mmv$refs_to_unrec_df_file_term: [XDCL, #GATE] integer := 0,
    mmv$reserved_page_count: [XDCL, #GATE] integer := 0,


{  Define the number of free and available pages that job scheduler tries to keep
{  available for all active jobs.

    mmv$resident_job_target: [XDCL, #GATE] integer := 60,

{! Define the number of pages that memory manager and job swapper will try to
{  keep available in 'now' + 'soon' reassignable memory.  If 'now' + 'soon'
{  is less than or equal to this value IO is initiated on jobs in the long
{  wait queue until this value is exceeded.

    mmv$sdtx_entry_size: [XDCL, #GATE] integer := #SIZE (mmt$segment_descriptor_extended),
    mmv$shared_pages_in_jws: [XDCL, #GATE] boolean := TRUE,
    mmv$swapping_aic: [XDCL, #GATE] integer := mmc$mmu_swapping_aic,
    mmv$tables_initialized: [XDCL, #GATE] boolean := FALSE,
    mmv$test_reassign_asid: [XDCL] boolean := FALSE,
    mmv$tick_time: [XDCL, #GATE] integer := mmc$mmu_tick_time,
    mmv$trap_page_fault: [XDCL, #GATE] boolean := FALSE,
    mmv$volume_wait_queue: [XDCL] tmt$task_queue_link := [0, 0],
    mmv$write_aged_out_pages: [XDCL, #GATE] integer := 100000,
    osv$page_size: [XDCL, #GATE] ost$page_size,
    syv$perf_keypoints_enabled: [XDCL, #GATE] syt$perf_keypoints_enabled :=
          [FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE],
    syv$recovering_job_count: [XDCL, #GATE] integer := 0,
    syv$refs_to_unrecovered_seg: [XDCL] integer := 0;


  CONST
    num_pf_recs = 256;

?? TITLE := 'MMP$PURGE_ALL_CACHE, MMP$PURGE_ALL_MAP - CACHE/MAP MANAGEMENT' ??
?? EJECT ??
*copyc mmp$aste_pointer_from_pfti
?? SKIP := 2 ??
*copyc mmp$purge_all_page_map
?? SKIP := 2 ??
*copyc mmp$sva_purge_one_page_map
?? SKIP := 2 ??
*copyc mmp$sva_purge_all_page_map
?? TITLE := 'mmp$update_eoi', EJECT ??

{
{ This procedure is called to update EOI (if necessary) after adding a page to a segment
{ or writing a page to disk.
{ If the beginning of the new page is beyond the current FDE EOI, then
{ the file EOI is set to the beginning of the next page.
{ NOTE:  This procedure does NOT set EOI back.  Any process which is going to shorten the
{ file must explicitly change EOI itself.
{ NOTE:  Currently there are no callers of this procedure with REASON = MMC$UER_EXACT_EOI.
{ If a caller uses that reason in the future, this procedure will need to be carefully
{ examined and changed.
{ NOTE:  All processes which change eoi_state to mmc$eoi_actual MUST free all pages beyond
{ beyond the page containing EOI.  (Currently mmp$mtr_set_get_segment_lenght is the only process
{ which sets state to actual.)  Failure to do so will result in EOI being messed up by this
{ procedure if a page beyond the actual EOI gets written out.
{
{      OFFSET - must be the FIRST byte of the page assigned/written. If multiple pages
{               are assigned, offset should the beginning of the page faulted for.
{


  PROCEDURE [INLINE, XDCL] mmp$update_eoi
    (    fde_p: gft$locked_file_desc_entry_p;
         offset: ost$segment_offset;
         reason: mmt$update_eoi_reason);

    IF offset >= fde_p^.eoi_byte_address THEN
      fde_p^.eoi_byte_address := offset + osv$page_size;
      fde_p^.flags.eoi_modified := TRUE;
      IF reason = mmc$uer_multiple_pages_assigned THEN
        fde_p^.eoi_state := mmc$eoi_uncertain;
      ELSEIF reason = mmc$uer_page_assigned THEN
        fde_p^.eoi_state := mmc$eoi_rounded;

{     ELSE reason = mmc$uer_page_written (mmc$uer_exact_eoi is not passed to this procedure)
{       The only way a page being written could have an offset greater than EOI is if the state is uncertain.
{       Additional pages were assigned on a page fault; eoi_byte_address was set to the page faulted for.
{       Now one of those additional pages is being written.  The eoi_byte_address has been updated (a few
{       lines above) but the state MUST remain uncertain, because there may still be other addtional pages
{       assigned that are beyond EOI.
{       If the state were actual and the page was being written, the state could not be changed either, nor
{       should the eoi_byte_address be changed.  Because set_segment_length is the only process that sets
{       state to actual and it FREES all pages beyond the page containing EOI, there cannot be a page being
{       written whose offset is greater than the eoi_byte_address.

      IFEND;
    ELSEIF reason = mmc$uer_page_written THEN

{ This code fixes EOI for files which had EOI set during a previous deadstart, which had a different page
{ size.  Running previously with a smaller page size could have left the eoi_address set to what is now the
{ middle of the current page size.  NOTE however:  The EOI cannot be changed if the state is actual; the
{ user set the  EOI and it must be left alone.

      IF (offset + osv$page_size) > fde_p^.eoi_byte_address THEN
        IF fde_p^.eoi_state <> mmc$eoi_actual THEN
          fde_p^.flags.eoi_modified := TRUE;
          fde_p^.eoi_byte_address := offset + osv$page_size;
          fde_p^.eoi_state := mmc$eoi_rounded;
        IFEND;
      IFEND;
    IFEND;

  PROCEND mmp$update_eoi;
?? TITLE := 'MMP$ASID, MMP$AST_INDEX - Convert between ASID and AST INDEX' ??
?? EJECT ??

{--------------------------------------------------------------------------------------------------------
{Name:
{    mmf$asid
{    mmp$aste_pointer
{Purpose:
{  These functions convert AST indexes into an ASID and vise-versa.
{Input:
{    pfl_index or ASID
{Output:
{    asid or pfl_index
{Error Codes:
{    none
{--------------------------------------------------------------------------------------------------------

  VAR
    mmv$a_mult: [XDCL, #GATE] 0 .. 10000(16),
    mmv$a_divisor: [XDCL, #GATE] 0 .. 10000(16),
    bits: array [0 .. 15] of 0 .. 15 := [0, 8, 4, 12, 2, 10, 6, 14, 1, 9, 5, 13, 3, 11, 7, 15];


  PROCEDURE [XDCL, INLINE] mmp$asid
    (    xasti: mmt$ast_index;
     VAR x_asid: ost$asid);

    VAR
      asti: mmt$ast_index,
      asid: integer;


    asti := xasti;
    asid := (bits [asti MOD 16] * 4096) + (bits [(asti DIV 16) MOD 16] * 256) +
          (bits [(asti DIV 256) MOD 16] * 16) + bits [(asti DIV 4096) MOD 16];
    asid := asid DIV mmv$a_divisor + (asid MOD mmv$a_divisor) * mmv$a_mult;
    x_asid := asid;

  PROCEND mmp$asid;


  PROCEDURE [XDCL, INLINE] mmp$aste_pointer
    (    xasid: ost$asid;
     VAR aste_p: ^mmt$active_segment_table_entry);


    VAR
      asid: ost$asid,
      asti: integer;


    asid := xasid;
    asid := asid DIV mmv$a_mult + (asid MOD mmv$a_mult) * mmv$a_divisor;
    asti := (bits [asid MOD 16] * 4096) + (bits [(asid DIV 16) MOD 16] * 256) +
          (bits [(asid DIV 256) MOD 16] * 16) + bits [(asid DIV 4096) MOD 16];
    aste_p := ^mmv$ast_p^ [asti];
    IF NOT aste_p^.in_use THEN
      aste_p := NIL;
    IFEND;

  PROCEND mmp$aste_pointer;
?? SKIP := 2 ??

  PROCEDURE [XDCL, INLINE] mmp$asti
    (    xasid: ost$asid;
     VAR asti: mmt$ast_index);

    VAR
      asid: ost$asid;

    asid := xasid;
    asid := asid DIV mmv$a_mult + (asid MOD mmv$a_mult) * mmv$a_divisor;
    asti := (bits [asid MOD 16] * 4096) + (bits [(asid DIV 16) MOD 16] * 256) +
          (bits [(asid DIV 256) MOD 16] * 16) + bits [(asid DIV 4096) MOD 16];

  PROCEND mmp$asti;
?? TITLE := 'MMP$DETERMINE_SHARED_QUEUE_ID', EJECT ??

{
{ This function determines the shared queue id for a file whose pages are going
{ to be kept in one of the shared queues.
{

  FUNCTION [XDCL, INLINE] mmp$determine_shared_queue_id
    (    fde_p: gft$locked_file_desc_entry_p;
         ste_p: ^mmt$segment_descriptor): mmt$page_frame_queue_id;

    IF fde_p^.file_kind = gfc$fk_job_permanent_file THEN
      IF (fde_p^.queue_ordinal <> 0) AND
            (fde_p^.queue_ordinal <= mmv$last_active_shared_queue) THEN
        mmp$determine_shared_queue_id := fde_p^.queue_ordinal;
      ELSEIF fde_p^.media = gfc$fm_served_file THEN
        mmp$determine_shared_queue_id := mmc$pq_shared_file_server;
      ELSEIF (ste_p^.ste.xp = osc$non_executable) OR (ste_p^.ste.wp <> osc$non_writable) THEN
        mmp$determine_shared_queue_id := mmc$pq_shared_pf_non_execute;
      ELSE
        mmp$determine_shared_queue_id := mmc$pq_shared_pf_execute;
      IFEND;
    ELSEIF fde_p^.file_kind = gfc$fk_catalog THEN
      mmp$determine_shared_queue_id := mmc$pq_shared_pf_non_execute;
    ELSEIF fde_p^.flags.global_template_file THEN
      mmp$determine_shared_queue_id := mmc$pq_shared_task_service;
    ELSEIF fde_p^.file_kind = gfc$fk_device_file THEN
      mmp$determine_shared_queue_id := mmc$pq_shared_device_file;
    ELSE
      mmp$determine_shared_queue_id := mmc$pq_shared_other;
    IFEND;

  FUNCEND mmp$determine_shared_queue_id;
?? TITLE := 'INITIALIZE_NEW_AST_ENTRY', EJECT ??

{--------------------------------------------------------------------------------------------
{This routine is called to assign and initialize a new AST entry for a segment.
{
{-------------------------------------------------------------------------------------------

  PROCEDURE [INLINE] initialize_new_ast_entry
    (    fde_p: gft$locked_file_desc_entry_p;
         segnum: ost$segment;
         ste_p: ^mmt$segment_descriptor;
         stxe_p: ^mmt$segment_descriptor_extended;
         cst_p: ^ost$cpu_state_table;
         force_to_global: boolean;
     VAR asid: ost$asid;
     VAR aste_p: ^mmt$active_segment_table_entry);

    VAR
      asti: mmt$ast_index,
      queue_id: mmt$page_frame_queue_id;

    mmp$assign_asid (asid, asti, aste_p);

    fde_p^.asti := asti;

    IF fde_p^.stack_for_ring = 0 THEN
      fde_p^.last_segment_number := segnum;
      fde_p^.global_task_id := cst_p^.taskid;
    IFEND;

    aste_p^.ijl_ordinal := cst_p^.ijl_ordinal;

    IF mmc$sa_wired IN stxe_p^.software_attribute_set THEN
      queue_id := mmc$pq_wired;
    ELSEIF mmc$sa_fixed IN stxe_p^.software_attribute_set THEN
      queue_id := mmc$pq_job_fixed;
    ELSEIF force_to_global OR (stxe_p^.access_state = mmc$sas_terminate_access) THEN
      aste_p^.ijl_ordinal := jmv$system_ijl_ordinal;
      queue_id := mmp$determine_shared_queue_id (fde_p, ste_p);
    ELSE
      queue_id := mmc$pq_job_working_set;
    IFEND;

    aste_p^.queue_id := queue_id;
    aste_p^.sfid := stxe_p^.sfid;

    mmp$set_include_pages_in_dump (segnum, fde_p, ste_p, aste_p^.include_pages_in_dump);

    ste_p^.ste.asid := asid;
    ste_p^.asti := asti;

  PROCEND initialize_new_ast_entry;

?? TITLE := 'OK_TO_RELINK_TO_AVAIL_MODIFIED', EJECT ??

{
{ This function determines whether or not pages can be relinked to the
{ available modified queue.  Pages cannot be relinked to the available
{ modified queue if the number of pages in the available modified queue
{ exceeds the system attribute AVAIL_MODIFIED_QUEUE_MAX.  The size of the
{ available modified queue is limited because system performance degrades
{ severely when the number of pages in the free and available queues goes
{ too low as a result of flooding of the available modified queue.
{

  FUNCTION ok_to_relink_to_avail_modified : boolean;

    ok_to_relink_to_avail_modified := (NOT mmv$post_deadstart) OR
          (mmv$gpql [mmc$pq_avail_modified].pqle.count <= mmv$avail_modified_queue_max);

  FUNCEND ok_to_relink_to_avail_modified;

?? TITLE := 'SET_ASSIGN_ACTIVE', EJECT ??

{--------------------------------------------------------------------------------------------
{This routine is used to set the SDTX flags for a request that requires job mode work.
{      SDTX.ASSIGN_ACTIVE  has the following values
{            mmc$assign_active_null     - Null value
{            mmc$assign_active_escaped  - Implies escaped allocation
{             otherwise                 - Address that requires job mode work
{-------------------------------------------------------------------------------------------

  PROCEDURE [INLINE] set_assign_active
    (    stxe_p: ^mmt$segment_descriptor_extended;
         offset: ost$segment_offset);

    IF stxe_p^.assign_active = mmc$assign_active_null THEN
      stxe_p^.assign_active := offset;
    ELSE
      stxe_p^.assign_active := mmc$assign_active_escaped;
    IFEND;

  PROCEND set_assign_active;
?? TITLE := 'MMP$CONVERT_PVA - Convert job mode PVA to SVA' ??
?? EJECT ??

{--------------------------------------------------------------------------------------------------------
{Name:
{  mmp$convert_pva
{Purpose:
{  This routine converts a PVA relative to the CURRENT USER TASK
{  to an SVA and returns pointers to the SDTX, AST entries for the segment.
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$convert_pva
    (    p: ^cell;
         cst_p: ^ost$cpu_state_table;
     VAR xsva: ost$system_virtual_address;
     VAR fde_p: gft$locked_file_desc_entry_p;
     VAR aste_p: ^mmt$active_segment_table_entry;
     VAR ste_p: ^mmt$segment_descriptor;
     VAR stxe_p: ^mmt$segment_descriptor_extended);


    VAR
      asid: ost$asid,
      asti: mmt$ast_index,
      segnum: ost$segment,
      sva: ost$system_virtual_address, {use local var for performance
      force_to_global: boolean; {TRUE if determined page goes in global queue.}


    segnum := #SEGMENT (p);

    ste_p := mmp$get_sdt_entry_p (cst_p^.xcb_p, segnum);
    stxe_p := mmp$get_sdtx_entry_p (cst_p^.xcb_p, segnum);

    IF (segnum > cst_p^.xcb_p^.xp.segment_table_length) OR (ste_p^.ste.vl = osc$vl_invalid_entry) THEN
      mtp$error_stop ('MM - invalid PVA');
    IFEND;


{ The following trap code is used periodically to trap escaped allocation. Please do not delete this code.

{  IF mmc$debug THEN
{    IF (stxe_p^.assign_active <> mmc$assign_active_null) AND (cst_p^.xcb_p^.xp.p_register.pva.ring > 1) AND
{      (cst_p^.xcb_p^.xp.trap_enable = osc$traps_enabled) AND
{      NOT cst_p^.xcb_p^.stlc_allocation AND
{      (osc$page_fault IN cst_p^.xcb_p^.xp.monitor_condition_register) AND
{      NOT (osc$trap_exception IN cst_p^.xcb_p^.xp.monitor_condition_register) THEN
{      mtp$error_stop ('PFP-CONVERT--Escaped Allocation.');
{    IFEND;
{  IFEND;

{! Does this really happen}
    IF stxe_p^.sfid.residence = gfc$tr_system_wait_recovery THEN
      syv$refs_to_unrecovered_seg := syv$refs_to_unrecovered_seg + 1;
      aste_p := NIL;
      RETURN;
    IFEND;

    sva.asid := ste_p^.ste.asid;
    sva.offset := #OFFSET (p);

    gfp$mtr_get_locked_fde_p (stxe_p^.sfid, cst_p^.ijle_p, fde_p);

    IF sva.asid <> 0 THEN
      aste_p := ^mmv$ast_p^ [fde_p^.asti];
      IF mmc$debug AND ((fde_p^.asti <> ste_p^.asti) OR (aste_p^.sfid <> stxe_p^.sfid)) THEN
        mtp$error_stop ('MM - bad tables in CONVERT_PVA');
      IFEND;
    ELSE
      #PURGE_BUFFER (osc$purge_all_page_seg_map, null_pva); { only job mode segment map purge is required}
      force_to_global := (fde_p^.queue_status = gfc$qs_global_shared) OR (fde_p^.attach_count > 1);

      mmp$get_verify_asti_in_fde (fde_p, stxe_p^.sfid, cst_p^.ijl_ordinal, asti);

      IF (asti = 0) THEN
        initialize_new_ast_entry (fde_p, segnum, ste_p, stxe_p, cst_p, force_to_global, asid, aste_p);
      ELSE
        mmp$asid (asti, asid);
        ste_p^.ste.asid := asid;
        ste_p^.asti := asti;

{ Determine which queue (JWS or Shared) this file should be in by looking at FORCE_TO_GLOBAL but
{ with two important exception.  (1) If there are currently pages in memory and the current queue is not JWS,
{ then the file was recently global and there are still pages in memory--maybe in the global queue, maybe
{ in the available queue.  In this case we must leave the pages in the global queue, or we may end up with
{ modified pages in both the jws and global queues-this is a problem when it is time to write modified pages.
{ If the file belongs in a JWS queue but has pages in memory it's queue must not be changed.
{ Also, if it is currently in the JWS queue, the ijl_ordinal must be reset because it may point
{ to an old ijl.  (2) If this file is a shared file server file that has been terminated, the
{ fde_p^.attach_count has been decrement and no longer reflects the actual attached count.  Also the
{ ste.asid has been zeroed and there will be no pages in memory.  If pages are in the shared file queue,
{ leave the aste alone.

        aste_p := ^mmv$ast_p^ [asti];
        IF NOT force_to_global AND
              ((fde_p^.media <> gfc$fm_served_file) OR (aste_p^.queue_id = mmc$pq_job_working_set)) THEN
          IF (aste_p^.pages_in_memory = 0) OR (aste_p^.queue_id = mmc$pq_job_working_set) THEN
            aste_p^.queue_id := mmc$pq_job_working_set;
            aste_p^.ijl_ordinal := cst_p^.ijl_ordinal;
          IFEND;
        ELSEIF aste_p^.queue_id > mmc$pq_shared_last THEN

{ The file belongs in the shared queue.  Make sure the AST entry is correct.

          aste_p^.ijl_ordinal := jmv$system_ijl_ordinal;
          aste_p^.queue_id := mmp$determine_shared_queue_id (fde_p, ste_p);
        IFEND; {not force_to_global}

      IFEND; {asti = 0}
      sva.asid := asid;
    IFEND; {asid <> 0}

    IF mmc$debug AND ((aste_p^.ijl_ordinal <> cst_p^.ijl_ordinal) AND
          (aste_p^.ijl_ordinal <> jmv$system_ijl_ordinal)) THEN
      mtp$error_stop ('MM - Bad IJLO in CONVERT_PVA');
    IFEND;

    xsva := sva;

  PROCEND mmp$convert_pva;
?? TITLE := 'MMP$VERIFY_PVA - Test job mode PVA to see if its valid' ??
?? EJECT ??
{
{ Purpose:
{    This routine verifies a PVA relative to the CURRENT USER TASK
{    and returns an error code if its not valid.
{

  PROCEDURE [XDCL] mmp$verify_pva
    (    p: ^cell;
         segment_access: mmt$segment_access_type;
     VAR status: syt$monitor_status);

    VAR
      cst_p: ^ost$cpu_state_table,
      ring: 0 .. 15,
      pva_p: ^ost$pva,
      ste_p: ^mmt$segment_descriptor,
      stxe_p: ^mmt$segment_descriptor_extended,
      segnum: ost$segment;

    status.normal := TRUE;
    mtp$cst_p (cst_p);

    pva_p := p;
    ring := pva_p^.ring;

    IF (ring = 0) OR (pva_p^.offset < 0) THEN
      mtp$set_status_abnormal ('MM', mme$invalid_pva, status);
      RETURN;
    IFEND;

    IF ring < cst_p^.xcb_p^.xp.p_register.pva.ring THEN
      ring := cst_p^.xcb_p^.xp.p_register.pva.ring;
    IFEND;

    segnum := pva_p^.seg;
    ste_p := mmp$get_sdt_entry_p (cst_p^.xcb_p, segnum);
    stxe_p := mmp$get_sdtx_entry_p (cst_p^.xcb_p, segnum);


    IF (segnum > cst_p^.xcb_p^.xp.segment_table_length) OR (ste_p^.ste.vl = osc$vl_invalid_entry) THEN
      mtp$set_status_abnormal ('MM', mme$invalid_pva, status);
    ELSEIF mtv$sys_core_init_complete THEN
      IF (segment_access = mmc$sat_read) AND ((ring > ste_p^.ste.r2) OR (ste_p^.ste.rp = osc$non_readable))
            THEN
        mtp$set_status_abnormal ('MM', mme$invalid_pva, status);
      ELSEIF (segment_access = mmc$sat_write) AND ((ring > ste_p^.ste.r1) OR
            (ste_p^.ste.wp = osc$non_writable)) THEN
        mtp$set_status_abnormal ('MM', mme$invalid_pva, status);
      ELSEIF (segment_access = mmc$sat_read_or_write) AND (ring > ste_p^.ste.r2) THEN
        mtp$set_status_abnormal ('MM', mme$invalid_pva, status);
      ELSEIF (stxe_p^.sfid.residence = gfc$tr_system_wait_recovery) THEN
        syv$refs_to_unrecovered_seg := syv$refs_to_unrecovered_seg + 1;
        mtp$set_status_abnormal ('MM', mme$ref_to_unrecovered_file, status);
      IFEND;
    IFEND;

  PROCEND mmp$verify_pva;
?? TITLE := 'MMP$XTASK_PVA_TO_SVA - Convert job mode PVA to SVA' ??
?? EJECT ??
*copyc mmh$xtask_pva_to_sva

  PROCEDURE [XDCL] mmp$xtask_pva_to_sva
    (    p: ^cell;
     VAR sva: ost$system_virtual_address;
     VAR status: syt$monitor_status);

    VAR
      cst_p: ^ost$cpu_state_table,
      fde_p: gft$locked_file_desc_entry_p,
      ste_p: ^mmt$segment_descriptor,
      stxe_p: ^mmt$segment_descriptor_extended,
      aste_p: ^mmt$active_segment_table_entry;

    mmp$verify_pva (^p, mmc$sat_read_or_write, status);
    IF status.normal THEN
      mtp$cst_p (cst_p);
      mmp$convert_pva (p, cst_p, sva, fde_p, aste_p, ste_p, stxe_p);
    IFEND;

  PROCEND mmp$xtask_pva_to_sva;
?? TITLE := 'GET_AVAILABLE_PAGE_FRAME' ??
?? EJECT ??

{--------------------------------------------------------------------------------------------------------
{Name:
{    mmp$get_avail_page_frame
{Purpose:
{   This routine is called to find a free or available page frame.
{   No assignment of the page frame is made by this procedure.
{Input:
{   none
{Output:
{   pfti - Page Frame Table index of an available page frame. A value
{         of zero indicates no page frame was available.
{Error Codes:
{  none
{--------------------------------------------------------------------------------------------------------


  PROCEDURE [XDCL, INLINE] mmp$get_avail_page_frame
    (VAR pfti: mmt$page_frame_index);

    VAR
      job_found: boolean;

    pfti := mmv$gpql [mmc$pq_free].pqle.link.bkw;
    IF pfti = 0 THEN

      IF (mmv$gpql [mmc$pq_avail].pqle.count <= mmv$min_avail_pages) AND
            mmv$post_deadstart AND
            (mmv$gpql [mmc$pq_free].pqle.count + mmv$gpql [mmc$pq_avail].pqle.count <
            mmv$reassignable_page_frames.now) THEN
        jsp$free_swapped_jobs_memory (jmv$null_ijl_ordinal, {S2_QUEUE_ONLY} FALSE, job_found);
        pfti := mmv$gpql [mmc$pq_free].pqle.link.bkw;
      IFEND;
      IF pfti = 0 THEN
        pfti := mmv$gpql [mmc$pq_avail].pqle.link.bkw;
        IF pfti <> 0 THEN
          mmp$delete_pt_entry (pfti, TRUE);
        IFEND;
      IFEND;
    IFEND;

  PROCEND mmp$get_avail_page_frame;
?? TITLE := 'MMP$RELINK_PAGE_FRAME' ??
?? EJECT ??

{--------------------------------------------------------------------------------------------------------
{  This procedure moves a page frame from its current position
{  in a page queue to the head of a new queue identified by
{  the caller.
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$relink_page_frame
    (    pfti: mmt$page_frame_index;
         new_queue_id: mmt$page_frame_queue_id);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      qcb_p: ^mmt$page_queue_list_entry,
      queue_id: mmt$page_frame_queue_id,
      pfte_p: ^mmt$page_frame_table_entry,
      taskid: ost$global_task_id;

    pfte_p := ^mmv$pft_p^ [pfti];
    queue_id := new_queue_id;

    IF syv$perf_keypoints_enabled.memory_keypoints THEN
      #KEYPOINT (osk$performance, osk$m * pfti, ptk$page_assigned_pfti);
      #KEYPOINT (osk$performance, osk$m * $INTEGER (queue_id), ptk$page_assigned_queue);
      #KEYPOINT (osk$performance, osk$m * (pfte_p^.ijl_ordinal.block_number *
            32 + pfte_p^.ijl_ordinal.block_index), ptk$page_assigned_ijl);
    IFEND;

    IF pfte_p^.queue_id < mmc$pq_job_base THEN
      IF pfte_p^.queue_id <= mmc$pq_last_reassignable THEN
        mmv$reassignable_page_frames.now := mmv$reassignable_page_frames.now - 1;
      ELSEIF (pfte_p^.queue_id = mmc$pq_avail_modified) AND NOT mmv$pt_p^ [pfte_p^.pti].m THEN
        mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon - 1;
      IFEND;
      qcb_p := ^mmv$gpql [pfte_p^.queue_id].pqle;
    ELSE
      jmp$get_ijle_p (pfte_p^.ijl_ordinal, ijle_p);
      qcb_p := ^ijle_p^.job_page_queue_list [pfte_p^.queue_id];
    IFEND;
    IF pfte_p^.link.fwd = 0 THEN
      qcb_p^.link.bkw := pfte_p^.link.bkw;
    ELSE
      mmv$pft_p^ [pfte_p^.link.fwd].link.bkw := pfte_p^.link.bkw;
    IFEND;
    IF pfte_p^.link.bkw = 0 THEN
      qcb_p^.link.fwd := pfte_p^.link.fwd;
    ELSE
      mmv$pft_p^ [pfte_p^.link.bkw].link.fwd := pfte_p^.link.fwd;
    IFEND;
    qcb_p^.count := qcb_p^.count - 1;

    pfte_p^.link.bkw := 0;
    IF (queue_id <= mmc$pq_last_reassignable) AND (pfte_p^.active_io_count > 0) THEN
      IF mmc$debug AND (queue_id <> mmc$pq_free) THEN
        mtp$error_stop ('MM - relink 234');
      IFEND;
      mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon + 1;
      pfte_p^.link.fwd := 0;
    ELSE
      IF queue_id < mmc$pq_job_base THEN
        IF (queue_id <= mmc$pq_last_reassignable) THEN
          IF mmc$debug AND ((queue_id = mmc$pq_avail) AND ((mmv$pt_p^ [pfte_p^.pti].m) OR
                (mmv$pt_p^ [pfte_p^.pti].v))) THEN
            mtp$error_stop ('MM - relink - trapped modified/valid page in avail');
          IFEND;
          IF pfte_p^.flawed THEN
            IF (queue_id = mmc$pq_avail) THEN
              mmp$delete_pt_entry (pfti, TRUE);
            IFEND;
            queue_id := mmc$pq_flawed;
          ELSE
            mmv$reassignable_page_frames.now := mmv$reassignable_page_frames.now + 1;

{ Check if scheduler is waiting for memory and ready scheduler if necessary.

            jmp$check_scheduler_memory_wait;
          IFEND;

          IF (queue_id = mmc$pq_free) THEN
            mmv$pages_to_dump_p^ [pfti] := FALSE;
          IFEND;

        ELSEIF (queue_id = mmc$pq_avail_modified) AND NOT mmv$pt_p^ [pfte_p^.pti].m THEN
          IF mmc$debug AND (pfte_p^.active_io_count = 0) THEN
            mtp$error_stop ('MM - no IO');
          IFEND;
          mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon + 1;
        IFEND;
        qcb_p := ^mmv$gpql [queue_id].pqle;
      ELSE
        jmp$get_ijle_p (pfte_p^.ijl_ordinal, ijle_p);
        qcb_p := ^ijle_p^.job_page_queue_list [queue_id];
      IFEND;
      IF qcb_p^.link.fwd = 0 THEN
        qcb_p^.link.bkw := pfti;
      ELSE
        mmv$pft_p^ [qcb_p^.link.fwd].link.bkw := pfti;
      IFEND;
      pfte_p^.link.fwd := qcb_p^.link.fwd;
      qcb_p^.link.fwd := pfti;
      qcb_p^.count := qcb_p^.count + 1;
    IFEND;

    pfte_p^.queue_id := queue_id;
    IF (queue_id = mmc$pq_free) OR (queue_id = mmc$pq_flawed) THEN
      pfte_p^.sva.asid := 0; { DONT clear offset - required by mmp$change_asid}

{! delete until DM deletes active IO count - this code causes a timing problem swapping
{! out a job that has recently deleted a segment that had pages being written to disk.
{ IF pfte_p^.active_io_count <> 0 THEN
{ jmp$get_ijle_p (pfte_p^.ijl_ordinal, ijle_p);
{ jmv$ajl_p^ [ijle_p^.ajl_ordinal].active_io_page_count := jmv$ajl_p^ [ijle_p^.ajl_ordinal].
{ active_io_page_count - pfte_p^.active_io_count;
{ IFEND;

    IFEND;

    IF (mmv$memory_wait_queue.head <> 0) THEN
      IF (queue_id <= mmc$pq_last_reassignable) AND (pfte_p^.active_io_count = 0) THEN
        tmp$dequeue_task (mmv$memory_wait_queue, taskid);
      IFEND;
    IFEND;

    mmp$check_queues;

  PROCEND mmp$relink_page_frame;
?? SKIP := 2 ??
*copyc mmp$link_page_frame_to_queue
?? TITLE := 'MMP$MARK_PAGE_FLAWED' ??
?? EJECT ??

{--------------------------------------------------------------------------------------------------------
{  This procedure marks a page as flawed.  If the page is in the available
{  queue or the free queue move it to the flawed queue so that it will no
{  longer be available for use.  If the page is in use it will be removed
{  when it is released.  Flawed pages are only on the CY2000.  The Service
{  Processor has notified the OS via a NRSB entry.
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$mark_page_flawed
    (    pfti: mmt$page_frame_index_32);

    VAR
      pfte_p: ^mmt$page_frame_table_entry;

    IF NOT mmv$tables_initialized THEN
      RETURN;
    IFEND;

    IF (pfti < LOWERBOUND (mmv$pft_p^)) OR (pfti > UPPERBOUND (mmv$pft_p^)) THEN
      RETURN;
    IFEND;

    pfte_p := ^mmv$pft_p^ [pfti];
    pfte_p^.flawed := TRUE;

    IF (pfte_p^.queue_id <= mmc$pq_last_reassignable) THEN
      IF (pfte_p^.queue_id = mmc$pq_avail) THEN
        mmp$delete_pt_entry (pfti, TRUE);
      IFEND;
      mmp$relink_page_frame (pfti, mmc$pq_flawed);
    IFEND;

  PROCEND mmp$mark_page_flawed;
?? TITLE := 'MMP$CLAIM_PAGES_FOR_SWAPIN', EJECT ??

{---------------------------------------------------------------------------------------------------
{  This procedure is used by the job swapper to claim a large number of pages on swapin.
{---------------------------------------------------------------------------------------------------


  PROCEDURE [XDCL] mmp$claim_pages_for_swapin
    (    swapped_job_entry: jmt$swapped_job_entry;
         aste_p: ^mmt$active_segment_table_entry;
         ijl_ordinal: jmt$ijl_ordinal;
     VAR job_page_queue_list: mmt$job_page_queue_list;
     VAR status: syt$monitor_status);

    VAR
      count: integer,
      first_pfti: mmt$page_frame_index,
      ijl_p: ^jmt$initiated_job_list_entry,
      job_found: boolean,
      pfte_p: ^mmt$page_frame_table_entry,
      pfti: mmt$page_frame_index,
      queue_count: integer,
      queue_id: mmt$page_frame_queue_id,
      source_queue_id: mmt$page_frame_queue_id;

    status.normal := TRUE;

    count := 0;
    jmp$get_ijle_p (ijl_ordinal, ijl_p);
    FOR queue_id := LOWERVALUE (mmt$job_page_queue_index) TO UPPERVALUE (mmt$job_page_queue_index) DO
      count := swapped_job_entry.job_page_queue_count [queue_id] + count;
      IF (queue_id = mmc$pq_job_fixed) AND NOT (jmc$dsw_job_recovery IN ijl_p^.delayed_swapin_work) THEN
        count := count - ijl_p^.job_fixed_contiguous_pages;
      IFEND;
    FOREND;

    WHILE (mmv$gpql [mmc$pq_free].pqle.count < count) AND
          mmv$post_deadstart AND
          (mmv$gpql [mmc$pq_free].pqle.count + mmv$gpql [mmc$pq_avail].pqle.count - count <=
          mmv$min_avail_pages) AND (mmv$gpql [mmc$pq_free].pqle.count + mmv$gpql [mmc$pq_avail].pqle.count <
          mmv$reassignable_page_frames.now) DO
      jsp$free_swapped_jobs_memory (jmv$null_ijl_ordinal, {S2_QUEUE_ONLY} TRUE, job_found);
      IF NOT job_found THEN
        mtp$set_status_abnormal ('MM', mme$no_free_pages, status);
        RETURN;
      IFEND;
    WHILEND;

    source_queue_id := mmc$pq_free;

  /claim_pages/
    FOR queue_id := LOWERVALUE (mmt$job_page_queue_index) TO UPPERVALUE (mmt$job_page_queue_index) DO
      count := swapped_job_entry.job_page_queue_count [queue_id];
      IF count = 0 THEN
        CYCLE /claim_pages/;
      IFEND;
      job_page_queue_list [queue_id].count := count;
      IF (queue_id = mmc$pq_job_fixed) AND NOT (jmc$dsw_job_recovery IN ijl_p^.delayed_swapin_work) THEN
        count := count - ijl_p^.job_fixed_contiguous_pages;
      IFEND;
      mmv$reassignable_page_frames.now := mmv$reassignable_page_frames.now - count;
      REPEAT
        queue_count := count;
        pfti := mmv$gpql [source_queue_id].pqle.link.bkw;
        IF pfti = 0 THEN
          IF source_queue_id = mmc$pq_avail THEN
            mtp$error_stop ('MM - no memory for claim pages');
          IFEND;
          source_queue_id := mmc$pq_avail;
          pfti := mmv$gpql [mmc$pq_avail].pqle.link.bkw;
        IFEND;
        first_pfti := pfti;
        WHILE (count > 0) AND (pfti <> 0) DO
          IF syv$perf_keypoints_enabled.memory_keypoints THEN
            #KEYPOINT (osk$performance, osk$m * pfti, ptk$pfti_for_swapin);
          IFEND;
          pfte_p := ^mmv$pft_p^ [pfti];
          IF source_queue_id = mmc$pq_avail THEN
            mmp$delete_pt_entry (pfti, TRUE);
            pfte_p^.sva := null_sva;
          IFEND;
          pfte_p^.ijl_ordinal := ijl_ordinal;
          pfte_p^.aste_p := aste_p;
          pfte_p^.queue_id := queue_id;
          count := count - 1;
          pfti := pfte_p^.link.bkw;
        WHILEND;

        mmv$gpql [source_queue_id].pqle.count := mmv$gpql [source_queue_id].pqle.count - queue_count + count;
        IF job_page_queue_list [queue_id].link.bkw = 0 THEN
          job_page_queue_list [queue_id].link.bkw := first_pfti;
        ELSE
          mmv$pft_p^ [job_page_queue_list [queue_id].link.fwd].link.bkw := first_pfti;
          mmv$pft_p^ [first_pfti].link.fwd := job_page_queue_list [queue_id].link.fwd;
        IFEND;
        IF pfti = 0 THEN
          job_page_queue_list [queue_id].link.fwd := mmv$gpql [source_queue_id].pqle.link.fwd;
          mmv$gpql [source_queue_id].pqle.link.bkw := 0;
          mmv$gpql [source_queue_id].pqle.link.fwd := 0;
        ELSE
          job_page_queue_list [queue_id].link.fwd := mmv$pft_p^ [pfti].link.fwd;
          mmv$pft_p^ [mmv$pft_p^ [pfti].link.fwd].link.bkw := 0;
          mmv$gpql [source_queue_id].pqle.link.bkw := pfti;
          mmv$pft_p^ [pfti].link.fwd := 0;
        IFEND;
      UNTIL count = 0;
    FOREND /claim_pages/;

    mmp$check_queues;

  PROCEND mmp$claim_pages_for_swapin;

?? TITLE := 'MMP$FREE_MEMORY_IN_JOB_QUEUES' ??
?? EJECT ??

{---------------------------------------------------------------------------------------------------
{
{ The purpose of this procedure is to efficiently relink ALL the pages in a jobs page queue list
{ to the free queue.
{
{---------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$free_memory_in_job_queues
    (VAR job_page_queue_list: mmt$job_page_queue_list;
         increment_now: boolean;
         decrement_soon: boolean;
         job_termination: boolean);

    VAR
      asid: ost$asid,
      aste_p: ^mmt$active_segment_table_entry,
      count: integer,
      found: boolean,
      ijl_p: ^jmt$initiated_job_list_entry,
      index: integer,
      ipti: integer,
      last_contiguous_pfti: mmt$page_frame_index,
      hcount: 1 .. 32,
      next_pfti: mmt$page_frame_index,
      original_bkw_link: mmt$page_frame_index,
      pfte_p: ^mmt$page_frame_table_entry,
      pfti: mmt$page_frame_index,
      queue_id: mmt$job_page_queue_index,
      taskid: ost$global_task_id,
      total_pages_freed: integer;

    total_pages_freed := 0;

    FOR queue_id := UPPERVALUE (mmt$job_page_queue_index) DOWNTO LOWERVALUE (mmt$job_page_queue_index) DO
      pfti := job_page_queue_list [queue_id].link.bkw;
      original_bkw_link := job_page_queue_list [queue_id].link.bkw;

{ If we are freeing the job-fixed queue, we must verify that there are not any
{ contiguous pages assigned. If there are contiguous pages assigned, it is
{ necessary to determine where in the queue the non-contiguous pages begin.
{ The contiguous pages are ALWAYS at the very beginning of the job-fixed
{ page queue. Contiguous pages are not freed.
{ NOTE: If pages have ASID = 0, then frames are being freed after aborted swapin.

      IF pfti <> 0 THEN
        IF (queue_id = mmc$pq_job_fixed) THEN
          jmp$get_ijle_p (mmv$pft_p^ [pfti].ijl_ordinal, ijl_p);
          IF (ijl_p^.job_fixed_contiguous_pages <> 0) AND NOT job_termination AND
                NOT (jmc$dsw_job_recovery IN ijl_p^.delayed_swapin_work) THEN
            FOR index := 1 TO ijl_p^.job_fixed_contiguous_pages DO
              last_contiguous_pfti := pfti;
              #HASH_SVA (mmv$pft_p^ [pfti].sva, ipti, hcount, found);
              IF found THEN
                mmp$delete_pt_entry (pfti, TRUE);
              IFEND;
              pfti := mmv$pft_p^ [pfti].link.bkw;
            FOREND;
          IFEND;
        IFEND;

        WHILE pfti <> 0 DO
          pfte_p := ^mmv$pft_p^ [pfti];
          asid := pfte_p^.sva.asid;
          next_pfti := pfte_p^.link.bkw;
          IF syv$perf_keypoints_enabled.memory_keypoints THEN
            #KEYPOINT (osk$performance, osk$m * pfti, ptk$page_assigned_pfti);
            #KEYPOINT (osk$performance, osk$m * $INTEGER (mmc$pq_free), ptk$page_assigned_queue);
          IFEND;

          IF asid <> 0 THEN
            IF pfte_p^.active_io_count = 0 THEN
              mmp$delete_pt_entry (pfti, TRUE);
              mmp$aste_pointer_from_pfti (pfti, aste_p);
              IF aste_p^.pages_in_memory = 0 THEN
                IF aste_p^.sfid.residence = gfc$tr_job THEN
                  mmp$free_asid (asid, aste_p);
                IFEND;
              IFEND;
              pfte_p^.sva := null_sva;
              IF pfte_p^.flawed THEN
                mmp$relink_page_frame (pfti, mmc$pq_flawed);
                IF decrement_soon THEN
                  mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon - 1;
                IFEND;
                IF NOT increment_now THEN
                  mmv$reassignable_page_frames.now := mmv$reassignable_page_frames.now - 1;
                IFEND;
              ELSE
                pfte_p^.queue_id := mmc$pq_free;
                mmv$pages_to_dump_p^ [pfti] := FALSE;
              IFEND;
            ELSE

{  IO is still active on a local file or a shared file.

              IF (pfte_p^.aste_p^.sfid.residence = gfc$tr_job) AND (job_termination) THEN
                mmv$pt_p^ [pfte_p^.pti].v := FALSE;
                mmp$delete_pt_entry (pfti, TRUE);
                mmp$relink_page_frame (pfti, mmc$pq_free);
                IF decrement_soon THEN
                  mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon - 1;
                IFEND;
              ELSE
                IF ok_to_relink_to_avail_modified () THEN
                  mmv$pt_p^ [pfte_p^.pti].v := FALSE;
                  mmp$relink_page_frame (pfti, mmc$pq_avail_modified);
                  IF decrement_soon THEN
                    mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon - 1;
                  IFEND;

{ If NOW was already incremented, OC to S2, then decrement NOW since IO is active.
{ NOW will be incremented when IO completes.  This applies to local files only.
{ NOW count is updated for shared files when movement from JWS to shared queues takes place.

                  IF (NOT increment_now) AND (pfte_p^.aste_p^.sfid.residence = gfc$tr_job) THEN
                    mmv$reassignable_page_frames.now := mmv$reassignable_page_frames.now - 1;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          ELSE

            IF pfte_p^.flawed THEN
              mmp$relink_page_frame (pfti, mmc$pq_flawed);
              IF decrement_soon THEN
                mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon - 1;
              IFEND;
              IF NOT increment_now THEN
                mmv$reassignable_page_frames.now := mmv$reassignable_page_frames.now - 1;
              IFEND;
            ELSE
              pfte_p^.queue_id := mmc$pq_free;
              mmv$pages_to_dump_p^ [pfti] := FALSE;
            IFEND;
          IFEND;
          pfti := next_pfti;
        WHILEND;

{ The contiguous pages assigned to the job-fixed segment must not be counted
{ when freeing pages in the queues.

        IF (queue_id = mmc$pq_job_fixed) AND (ijl_p^.job_fixed_contiguous_pages <> 0) AND
              NOT (jmc$dsw_job_recovery IN ijl_p^.delayed_swapin_work) AND NOT job_termination THEN
          count := job_page_queue_list [queue_id].count - ijl_p^.job_fixed_contiguous_pages;
          job_page_queue_list [queue_id].link.bkw := mmv$pft_p^ [last_contiguous_pfti].link.bkw;
        ELSE
          count := job_page_queue_list [queue_id].count;
        IFEND;
        IF count > 0 THEN
          IF mmv$gpql [mmc$pq_free].pqle.link.bkw = 0 THEN
            mmv$gpql [mmc$pq_free].pqle.link.bkw := job_page_queue_list [queue_id].link.bkw;
          ELSE
            mmv$pft_p^ [mmv$gpql [mmc$pq_free].pqle.link.fwd].link.bkw := job_page_queue_list [queue_id].
                  link.bkw;
            mmv$pft_p^ [job_page_queue_list [queue_id].link.bkw].link.fwd := mmv$gpql [mmc$pq_free].
                  pqle.link.fwd;
          IFEND;
          mmv$gpql [mmc$pq_free].pqle.link.fwd := job_page_queue_list [queue_id].link.fwd;
          IF (queue_id = mmc$pq_job_fixed) AND (ijl_p^.job_fixed_contiguous_pages <> 0) AND
                NOT (jmc$dsw_job_recovery IN ijl_p^.delayed_swapin_work) AND NOT job_termination THEN
            job_page_queue_list [queue_id].link.fwd := last_contiguous_pfti;
            job_page_queue_list [queue_id].link.bkw := original_bkw_link;
            job_page_queue_list [queue_id].count := ijl_p^.job_fixed_contiguous_pages;
          ELSE
            job_page_queue_list [queue_id].link.fwd := 0;
            job_page_queue_list [queue_id].link.bkw := 0;
            job_page_queue_list [queue_id].count := 0;
          IFEND;
          mmv$gpql [mmc$pq_free].pqle.count := mmv$gpql [mmc$pq_free].pqle.count + count;
          IF increment_now THEN
            mmv$reassignable_page_frames.now := mmv$reassignable_page_frames.now + count;
          IFEND;
          IF decrement_soon THEN
            mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon - count;
          IFEND;
          total_pages_freed := total_pages_freed + count;
        IFEND;
      IFEND;
    FOREND;

    IF increment_now THEN

{ Check if scheduler is waiting for memory and ready scheduler if necessary; this check is
{ necessary anytime page_frames.now is incremented, but don't do it inside a loop.

      jmp$check_scheduler_memory_wait;

    IFEND;

    WHILE (mmv$memory_wait_queue.head <> 0) AND (total_pages_freed > 0) DO
      total_pages_freed := total_pages_freed - 1;
      tmp$dequeue_task (mmv$memory_wait_queue, taskid);
    WHILEND;

    mmp$check_queues;

  PROCEND mmp$free_memory_in_job_queues;
?? TITLE := 'PF_PROC_TABLES_NOT_INITIALIZED' ??
?? EJECT ??

{--------------------------------------------------------------------------------------------------------
{Name:
{  pf_proc_tables_not_initialized
{Purpose:
{  This routine is called to process page faults which occur before
{  the PQL, PFT, and AST have been initialized. The routine assigns
{  an available page frame and makes the page table entry for the
{  page.
{--------------------------------------------------------------------------------------------------------


  PROCEDURE pf_proc_tables_not_initialized
    (    xcb_p: ^ost$execution_control_block);

    VAR
      sva: ost$system_virtual_address,
      ste_p: ^mmt$segment_descriptor,
      static_next_rma: [STATIC] integer := 7fffffff(16),
      static_stop_rma: [STATIC] integer := 7fffffff(16),
      next_rma: integer,
      stop_rma: integer,
      pte: ost$page_table_entry,
      count: 1 .. 32,
      found: boolean,
      full_scan_has_been_done: boolean,
      pt_length: integer,
      pt_p: ^ost$page_table,
      pti: integer;


    pt_p := mmv$pt_p;
    pt_length := mmv$pt_length;
    ste_p := mmp$get_sdt_entry_p (xcb_p, xcb_p^.xp.untranslatable_pointer.seg);
    sva.asid := ste_p^.ste.asid;
    sva.offset := xcb_p^.xp.untranslatable_pointer.offset;
    sva.offset := (sva.offset DIV osv$page_size) * osv$page_size;


{The following loop is somewhat obscure but is structured for best performance during deadstart.
{The loop sets <NEXT_RMA> .. <STOP_RMA> to point to the next block of free pages that can be assigned.
{The block is determined by scanning the page table. The FIRST time thru the loop, it locates the
{large block at the end of memory. (Deadstart loads most of the OS at the beginning of memory.)
{Subsequent passes thru the loop locate the next block following the block that was just assigned.
{   (The loop has been optimized by looking at the object code generated and adjusting
{    the source to get good object code).

?? PUSH (CHKALL := OFF) ??
    IF static_next_rma = static_stop_rma THEN

{  Locate the starting point of the next block.

      next_rma := static_next_rma;
      stop_rma := static_stop_rma;
      IF next_rma = 7fffffff(16) THEN
        next_rma := osv$180_memory_limits.lower DIV 512;
        stop_rma := (osv$180_memory_limits.deadstart_upper DIV 512);
        pti := pt_length;
        REPEAT
          pti := pti - 1;
          pte := pt_p^ [pti];
          IF pte.v AND (pte.rma > next_rma) AND (pte.rma < stop_rma) THEN
            next_rma := pte.rma;
          IFEND;
        UNTIL pti = 0;
        next_rma := next_rma + osv$page_size DIV 512;
      IFEND;
      IF next_rma = stop_rma THEN
        full_scan_has_been_done := FALSE;
        REPEAT
          next_rma := next_rma + (osv$page_size DIV 512);
          IF next_rma >= (osv$180_memory_limits.deadstart_upper DIV 512) THEN
            IF full_scan_has_been_done THEN
              mtp$error_stop ('MM - not enough mem to deadstart');
            IFEND;
            next_rma := osv$180_memory_limits.lower DIV 512;
            full_scan_has_been_done := TRUE;
          IFEND;
          pti := pt_length - 1;
          pte := pt_p^ [pti];
          WHILE (pti > 0) AND (NOT pte.v OR (pte.rma <> next_rma)) DO
            pti := pti - 1;
            pte := pt_p^ [pti];
          WHILEND;
        UNTIL NOT pte.v OR (pte.rma <> next_rma);
      IFEND;

{  Locate the end of the block just selected.

      stop_rma := (osv$180_memory_limits.deadstart_upper DIV 512);
      pti := pt_length;
      REPEAT
        pti := pti - 1;
        pte := pt_p^ [pti];
        IF pte.v AND (pte.rma > next_rma) AND (pte.rma < stop_rma) THEN
          stop_rma := pte.rma;
        IFEND;
      UNTIL pti = 0;
      static_next_rma := next_rma;
      static_stop_rma := stop_rma;
    IFEND;

?? POP ??

    #HASH_SVA (sva, pti, count, found);
    IF found THEN
      mtp$error_stop ('MM - PTE exists');
    IFEND;
    pti := pti - count + 1;
    IF pti < 0 THEN
      pti := pti + mmv$pt_length;
    IFEND;
    count := 1;
    WHILE (mmv$pt_p^ [pti].pageid.asid <> 0) AND (count < 33) DO
      count := count + 1;
      pti := pti + 1;
      IF pti = mmv$pt_length THEN
        pti := 0;
      IFEND;
    WHILEND;

    IF count = 33 THEN
      mtp$error_stop ('MM - PT full in deadstart');
    IFEND;

    pte.v := FALSE;
    pte.c := TRUE;
    pte.u := TRUE;
    pte.m := FALSE;
    pte.pageid.asid := sva.asid;
    pte.pageid.pagenum := sva.offset DIV 512;
    pte.rma := static_next_rma;
    static_next_rma := static_next_rma + (osv$page_size DIV 512);
    mmv$pt_p^ [pti] := pte;
    mmp$preset_real_memory (sva, pmc$initialize_to_zero);
    mmv$pt_p^ [pti].v := TRUE;

  PROCEND pf_proc_tables_not_initialized;
?? TITLE := 'MMP$SEND_ESCAPED_ALLOC_FLAG', EJECT ??

{ Purpose:
{   This procedure is called when a WRITE_PAGE_TO_DISK request discovers escaped
{   allocation. This procedure sends a flag to a task to assign the backing storage.
{


  PROCEDURE mmp$send_escaped_alloc_flag
    (    fde_p: gft$locked_file_desc_entry_p;
         pfte_p: ^mmt$page_frame_table_entry);

    VAR
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      old_assign_active: integer,
      pfte_ijle_p: ^jmt$initiated_job_list_entry,
      sfid: gft$system_file_identifier,
      status: syt$monitor_status,
      ste_p: ^mmt$segment_descriptor,
      stxe_p: ^mmt$segment_descriptor_extended,
      xcb_p: ^ost$execution_control_block;


{ Try to get a pointer the the XCB of the last task using the segment. The GTID will
{ be invalid if the task has terminated.  NOTE:  If get_xcb_p is successful (a non-NIL
{ xcb_p is returned, the ajl must be unlocked when processing is done.

    xcb_p := NIL;
    tmp$test_get_xcb_p (fde_p^.global_task_id, xcb_p, ijle_p);
    jmp$get_ijle_p (pfte_p^.ijl_ordinal, pfte_ijle_p);
    gfp$mtr_get_sfid_from_fde_p (fde_p, sfid, ijl_ordinal);


{ If the GTID is still valid, notify the task to assign space. If the segment is still valid AND the
{ same SFID, use the SDTX.ASSIGN_ACTIVE mechanism to notify the task to allocate space. If the segment
{ is NOT the same SFID, use field in the XCB to pass the SFID.

    IF (xcb_p <> NIL) AND (ijle_p = pfte_ijle_p) THEN
      ste_p := mmp$get_sdt_entry_p (xcb_p, fde_p^.last_segment_number);
      stxe_p := mmp$get_sdtx_entry_p (xcb_p, fde_p^.last_segment_number);
      IF (ste_p^.ste.vl <> osc$vl_invalid_entry) AND (sfid = stxe_p^.sfid) THEN
        old_assign_active := stxe_p^.assign_active;
        set_assign_active (stxe_p, pfte_p^.sva.offset);
        IF old_assign_active = mmc$assign_active_null THEN
          tmp$set_monitor_flag (fde_p^.global_task_id, mmc$mf_segment_mgr_flag, status);
        IFEND;
      ELSEIF xcb_p^.assign_active_sfid = gfv$null_sfid THEN
        xcb_p^.assign_active_sfid := sfid;
        tmp$set_monitor_flag (fde_p^.global_task_id, mmc$mf_segment_mgr_flag, status);
      IFEND;
      jmp$unlock_ajl (ijle_p);


{ If the GTID is no longer valid, let the job monitor of the job take care of allocation.

    ELSE

{ Unlock the ajl set by tmp$test_get_set_xcb_p if necessary.  We may be in this section of
{ code because the ijl pointers do not match.

      IF xcb_p <> NIL THEN
        jmp$unlock_ajl (ijle_p);
      IFEND;

      tmp$get_xcb_p (pfte_ijle_p^.job_monitor_taskid, xcb_p, ijle_p);
      IF xcb_p <> NIL THEN
        IF xcb_p^.assign_active_sfid = gfv$null_sfid THEN
          xcb_p^.assign_active_sfid := sfid;
          tmp$set_monitor_flag (ijle_p^.job_monitor_taskid, mmc$mf_segment_mgr_flag, status);
        IFEND;
        mmv$jmtr_escaped_allocate := mmv$jmtr_escaped_allocate + 1;
        jmp$unlock_ajl (ijle_p);
      ELSE
        mtp$error_stop ('MM - lost segment owner');  {!! can we get here??
        mmv$lost_escaped_allocate := mmv$lost_escaped_allocate + 1;
      IFEND;
    IFEND;

  PROCEND mmp$send_escaped_alloc_flag;

?? TITLE := 'MMP$WRITE_PAGE_TO_DISK' ??
?? EJECT ??

{-------------------------------------------------------------------------
{ This procedure is used to write a page to disk. All pages in the transfer unit will be
{ written unless they are locked.
{
{----------------------------------------------------------------------------


*copyc mmt$write_page_to_disk_status

  PROCEDURE [XDCL] mmp$write_page_to_disk
    (    fde_p: gft$locked_file_desc_entry_p;
         pfti: mmt$page_frame_index;
         iotype: iot$io_function;
         io_id: mmt$io_identifier;
         multiple_page_req: boolean;
     VAR write_status: mmt$write_page_to_disk_status);

    VAR
      aste_p: ^mmt$active_segment_table_entry,
      boffset: integer,
      buffer_descriptor: mmt$buffer_descriptor,
      count: 1 .. 32,
      eoffset: integer,
      found: boolean,
      ijle_p: ^jmt$initiated_job_list_entry,
      ijl_ordinal: jmt$ijl_ordinal,
      length: integer,
      lsva: ost$system_virtual_address,
      max_bytes_to_write: integer,
      offset: integer, {dont make this a subrange}
      pfte_p: ^mmt$page_frame_table_entry,
      pte_p: ^ost$page_table_entry,
      pti: integer,
      served_file: boolean,
      status: syt$monitor_status,
      stxe_p: ^mmt$segment_descriptor_extended,
      sva: ost$system_virtual_address,
      tu_start: integer,
      tu_end: integer,
      write_multiple_pages: boolean,
      xcb_p: ^ost$execution_control_block,
      xpfti: mmt$page_frame_index;



{ If the segment is not assigned to a file, reject the request and send a signal to the
{ owner of the segment to assign a backing file.

    pfte_p := ^mmv$pft_p^ [pfti];
    IF fde_p^.media = gfc$fm_transient_segment THEN
      mmp$send_escaped_alloc_flag (fde_p, pfte_p);
      write_status := ws_no_file_assigned;
      mmv$write_page_statistics [write_status] := mmv$write_page_statistics [write_status] + 1;
      RETURN;
    IFEND;


{ Reject the write if the page belongs to a file that has not yet been recovered.
{ The write must be delayed for a while.

    aste_p := pfte_p^.aste_p;
    IF aste_p^.sfid.residence = gfc$tr_system_wait_recovery THEN
      write_status := ws_physical_io_reject;
      mmv$write_page_statistics [write_status] := mmv$write_page_statistics [write_status] + 1;
      RETURN;
    IFEND;


{ Determine the maximum number of bytes that can be written. For mass storage files, it is
{ an allocation unit. For served files, the size is the smaller of the files allocation unit size
{ and a constant that is dependent on the buffer size in STORENET.
{ Note also that served files do not allow multiple outstanding write requests on a
{ page because writes can be processed out of order.

    max_bytes_to_write := fde_p^.allocation_unit_size;

    served_file := (fde_p^.media = gfc$fm_served_file);
    IF served_file THEN
      IF mmv$pft_p^ [pfti].active_io_count <> 0 THEN
        write_status := ws_physical_io_reject;
        mmv$write_page_statistics [write_status] := mmv$write_page_statistics [write_status] + 1;
        RETURN;
      IFEND;
{!??} mmv$pft_p^ [pfti].io_error := ioc$no_error;
    IFEND;


{Calculate the SVA and LENGTH of the data to write to disk. The algorithm is to
{start with the page specified by <pfti> and search contiguous pages
{in both directions in the segment until 1) the ends of the transfer unit are passed, 2) a locked page is
{found (PFT.LOCKED_PAGE), 3) a page not in memory is found , 4) a non-modified page is found, OR
{5) a page is found that already has active IO (server only).
{The amount of data to write to disk is bounded by the outermost modified pages found by the search.

{Pages in the available modified queue will always be written.  Multiple pages not in the available
{modified queue will not be written if the page belongs to a swapped job.

    sva := pfte_p^.sva;
    tu_start := (sva.offset DIV max_bytes_to_write) * max_bytes_to_write;
    tu_end := tu_start + max_bytes_to_write;
    IF (tu_end > osc$max_segment_length) THEN
      tu_end := osc$max_segment_length;
    IFEND;
    jmp$get_ijle_p (aste_p^.ijl_ordinal, ijle_p);
    write_multiple_pages := multiple_page_req AND (ijle_p^.swap_status = jmc$iss_executing);
    lsva := sva;
    offset := sva.offset;
    boffset := offset;

  /find_starting_page/
    WHILE boffset > tu_start DO
      boffset := boffset - osv$page_size;
      lsva.offset := boffset;
      #HASH_SVA (lsva, pti, count, found);
      IF NOT found OR NOT mmv$pt_p^ [pti].m THEN
        EXIT /find_starting_page/;
      IFEND;
      xpfti := (mmv$pt_p^ [pti].rma * 512) DIV osv$page_size;
      IF (mmv$pft_p^ [xpfti].locked_page <> mmc$lp_not_locked) OR
            ((mmv$pft_p^ [xpfti].queue_id <> mmc$pq_avail_modified) AND
            (NOT write_multiple_pages)) OR (served_file AND (mmv$pft_p^ [xpfti].active_io_count <> 0)) THEN
        EXIT /find_starting_page/;
      IFEND;
      offset := boffset;
    WHILEND /find_starting_page/;

    eoffset := sva.offset + osv$page_size;
    sva.offset := offset;

  /find_ending_page/
    WHILE (eoffset < tu_end) DO
      lsva.offset := eoffset;
      #HASH_SVA (lsva, pti, count, found);
      IF NOT found OR NOT mmv$pt_p^ [pti].m THEN
        EXIT /find_ending_page/;
      IFEND;
      xpfti := (mmv$pt_p^ [pti].rma * 512) DIV osv$page_size;
      IF (mmv$pft_p^ [xpfti].locked_page <> mmc$lp_not_locked) OR
            ((mmv$pft_p^ [xpfti].queue_id <> mmc$pq_avail_modified) AND
            (NOT write_multiple_pages)) OR (served_file AND (mmv$pft_p^ [xpfti].active_io_count <> 0)) THEN
        EXIT /find_ending_page/;
      IFEND;
      eoffset := eoffset + osv$page_size;
    WHILEND /find_ending_page/;
    length := eoffset - sva.offset;


{Issue the write request to device manager. NOTE that the process of locking the page frames
{will clear the 'modified' bit in the page table.

    buffer_descriptor.buffer_descriptor_type := mmc$bd_paging_io;
    buffer_descriptor.sva := sva;
    buffer_descriptor.page_count := length DIV osv$page_size;

{ Issue the i/o.  Case includes pages on/not on server.
{ Note: EOI update must be done first since it is used by file server.

    mmp$update_eoi (fde_p, eoffset - osv$page_size, mmc$uer_page_written);
    IF NOT served_file THEN
      iop$pager_io (fde_p, sva.offset, buffer_descriptor, length, iotype, io_id, status);
    ELSE
      dfp$server_io (fde_p, iotype, sva.offset, length, io_id, buffer_descriptor, status);
    IFEND;

    IF status.normal THEN
      fde_p^.time_last_modified := #free_running_clock (0);
      write_status := ws_ok;
    ELSEIF status.condition = dme$transient_error THEN
      write_status := ws_device_manager_reject;
    ELSEIF status.condition = ioe$requests_full THEN
      write_status := ws_physical_io_reject;
    ELSEIF (status.condition = ioe$unit_disabled) OR (status.condition = dme$volume_unavailable) THEN
      write_status := ws_volume_unavailable;
    ELSEIF status.condition = dfe$server_has_terminated THEN
      write_status := ws_server_terminated;
    ELSEIF status.condition = dme$job_mode_allocate_required THEN
      mmp$send_escaped_alloc_flag (fde_p, pfte_p);
      write_status := ws_device_manager_reject;
    ELSE
      mtp$error_stop ('MM - unexpected phy io error');
    IFEND;

{Update statistics.

    mmv$write_page_statistics [write_status] := mmv$write_page_statistics [write_status] + 1;
    IF length <> osv$page_size THEN  {!This stat should be moved to IF STATUS.NORMAL
      mmv$aging_statistics.multiple_pages_written_to_disk :=
            mmv$aging_statistics.multiple_pages_written_to_disk + 1;
    ELSE
      mmv$aging_statistics.page_written_to_disk := mmv$aging_statistics.page_written_to_disk + 1;
    IFEND;

  PROCEND mmp$write_page_to_disk;

?? TITLE := 'MMP$REMOVE_PAGES_FROM_JWS', EJECT ??

{--------------------------------------------------------------------------------------------------------
{Name:
{  mmp$remove_pages_from_JWS
{Purpose:
{  This procedure is called to remove a page from the working set of a job.
{Notes:
{  - this routine will take care of page map purges if the page goes to the AVAIL_MODIFIED queue.
{    No purging is done if the page goes to the JWS queue. This queue is used for swapping only and no
{    purging is necessary.
{--------------------------------------------------------------------------------------------------------


  PROCEDURE [XDCL] mmp$remove_pages_from_jws
    (    modified_queue_id: mmt$page_frame_queue_id;
         ijle_p: ^jmt$initiated_job_list_entry;
     VAR xmcount: integer;
     VAR xrcount: integer);

    VAR
      fde_p: gft$locked_file_desc_entry_p,
      tos: integer,
      pfte_p: ^mmt$page_frame_table_entry,
      pfti: mmt$page_frame_index,
      aste_p: ^mmt$active_segment_table_entry,
      write_status: mmt$write_page_to_disk_status,
      io_id: mmt$io_identifier,
      mcount: integer,
      rcount: integer,
      pte_p: ^ost$page_table_entry;


    mcount := 0;
    rcount := 0;
    io_id.specified := FALSE;

{ Scan the PFTI array and eliminate any entries that cannot be removed. Clear the
{ 'valid' and 'used' bits for the entries that may be removed. Note: this step is unnecessary if
{ the pages are going to the JWS queue - this is done ONLY for job swapout. The map purge is not
{ required until the job starts running again. The job swapper insures that the purge occurs.


    IF modified_queue_id <> mmc$pq_job_working_set THEN
      mmp$reset_find_next_pfti (pfti);
      WHILE pfti <> 0 DO
        mmv$pt_p^ [mmv$pft_p^ [pfti].pti].v := FALSE;
        mmv$pt_p^ [mmv$pft_p^ [pfti].pti].u := FALSE;
        mmp$find_next_pfti (pfti);
      WHILEND;


{ Now that all used and valid bits have been cleared, purge that page map. It is important on a dual
{ CPU system to purge the page maps before deleting the page table entry. Also, it is not
{ possible to reliably determine the state of the 'modified' bit without clearing the 'valid'
{ bit and purging the page map.

      mmp$purge_all_page_map;
    IFEND;

    mmp$reset_find_next_pfti (pfti);

    WHILE pfti <> 0 DO
      pfte_p := ^mmv$pft_p^ [pfti];
      aste_p := pfte_p^.aste_p;
      pfte_p^.age := 0;
      pfte_p^.cyclic_age := 0;
      pte_p := ^mmv$pt_p^ [pfte_p^.pti];
      IF modified_queue_id = mmc$pq_job_working_set THEN
        pte_p^.v := FALSE;
        pte_p^.u := FALSE;
      IFEND;


{ If the segment is locked and (potentially) modified, the pages cannot be removed.
{ Reset PTE.V because it was cleared above.

      IF aste_p^.sfid.residence = gfc$tr_system_wait_recovery THEN
        pfti := 0;
        pte_p^.v := TRUE;
      ELSE
        gfp$mtr_get_locked_fde_p (aste_p^.sfid, ijle_p, fde_p);
        IF fde_p^.segment_lock.locked_for_write AND (pte_p^.m OR (pfte_p^.active_io_count > 0)) THEN
          pfti := 0;
          pte_p^.v := TRUE;


{ If the page belongs to a device file that has the WIRE_EOI attribute, dont remove it if
{ it is the last page of the segment. Set the USED bit so it wont be aged out again
{ for a while. Reset PTE.V because it was cleared above.

        ELSEIF fde_p^.flags.wire_eoi_page THEN
          IF (fde_p^.eoi_byte_address - mmv$pft_p^ [pfti].sva.offset) <= osv$page_size THEN
            pte_p^.v := TRUE;
            pte_p^.u := TRUE;
            pfti := 0;
          IFEND;


{ If the page belongs to a stack segment and is no longer needed, delete the page
{ and relink the page frame to the free queue.

        ELSEIF fde_p^.stack_for_ring <> 0 THEN
          tmp$get_top_of_stack (fde_p^.global_task_id, fde_p^.stack_for_ring, tos);
          IF pfte_p^.sva.offset >= tos THEN
            mmp$delete_pt_entry (pfti, TRUE);
            mmp$relink_page_frame (pfti, mmc$pq_free);
            fde_p^.eoi_byte_address := tos;
            pfti := 0;
            rcount := rcount + 1;
          IFEND;
        IFEND;
      IFEND;

{ Remove the page from the JWS and put it in the new queue.  New queue is determined by the state of the 'UM'
{ bits in the page table entry. New queue may also be specified by caller - modified pages must
{ be put in JWS queue if job is being swapped out.

      IF pfti <> 0 THEN
        rcount := rcount + 1;
        IF NOT pte_p^.m THEN
          IF pfte_p^.active_io_count <> 0 THEN
            IF ok_to_relink_to_avail_modified () THEN
              mmp$relink_page_frame (pfti, mmc$pq_avail_modified);
            ELSE
              pte_p^.v := TRUE;
            IFEND;
          ELSEIF mmv$no_memory_buffering THEN
            mmp$delete_pt_entry (pfti, TRUE);
            mmp$relink_page_frame (pfti, mmc$pq_free);
          ELSE
            mmp$relink_page_frame (pfti, mmc$pq_avail);
          IFEND;
        ELSE
          IF modified_queue_id = mmc$pq_avail_modified THEN
            IF ok_to_relink_to_avail_modified () THEN
              mmp$relink_page_frame (pfti, modified_queue_id);
              IF ((mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon) <
                    mmv$write_aged_out_pages) AND (modified_queue_id = mmc$pq_avail_modified) THEN
                io_id.specified := FALSE;
                mmp$write_page_to_disk (fde_p, pfti, ioc$write_page, io_id, mmv$multi_page_write,
                      write_status);
              IFEND;
              mcount := mcount + 1;
            ELSE
              pte_p^.v := TRUE;
            IFEND;
          ELSE
            mmp$relink_page_frame (pfti, modified_queue_id);
            IF ((mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon) <
                  mmv$write_aged_out_pages) AND (modified_queue_id = mmc$pq_avail_modified) THEN
              io_id.specified := FALSE;
              mmp$write_page_to_disk (fde_p, pfti, ioc$write_page, io_id, mmv$multi_page_write, write_status);
            IFEND;
            mcount := mcount + 1;
          IFEND;
        IFEND;
      IFEND;

      mmp$find_next_pfti (pfti);
    WHILEND;

    mmv$aging_statistics.remove_unmodified_page_from_ws :=
          mmv$aging_statistics.remove_unmodified_page_from_ws + rcount - mcount;
    mmv$aging_statistics.remove_modified_page_from_ws := mmv$aging_statistics.remove_modified_page_from_ws +
          mcount;
    xrcount := rcount;
    xmcount := mcount;

  PROCEND mmp$remove_pages_from_jws;

?? TITLE := 'MMP$REMOVE_PAGE_FROM_JWS', EJECT ??

{--------------------------------------------------------------------------------------------------------
{Name:
{  mmp$remove_page_from_JWS
{Purpose:
{  This procedure is called to remove a page from the working set of a job.
{Notes:
{  - this routine will take care of page map purges.
{  - this routine does not neccessarily write the page to disk.
{--------------------------------------------------------------------------------------------------------


  PROCEDURE [XDCL] mmp$remove_page_from_jws
    (    pfti: mmt$page_frame_index;
         ijle_p: ^jmt$initiated_job_list_entry;
     VAR mcount: integer;
     VAR rcount: integer);

    VAR
      fde_p: gft$locked_file_desc_entry_p,
      tos: integer,
      pfte_p: ^mmt$page_frame_table_entry,
      aste_p: ^mmt$active_segment_table_entry,
      write_status: mmt$write_page_to_disk_status,
      io_id: mmt$io_identifier,
      pte_p: ^ost$page_table_entry;



{Reject the request if the page is locked.

    mcount := 0;
    pfte_p := ^mmv$pft_p^ [pfti];
    aste_p := pfte_p^.aste_p;
    IF (pfte_p^.locked_page <> mmc$lp_not_locked) OR (aste_p^.sfid.residence =
          gfc$tr_system_wait_recovery) THEN
      rcount := 0;
      RETURN; {<----}
    IFEND;


{Clear the valid bit in the page table entry for the page.
{Valid bit MUST be cleared and map purged (in dual CPU) before examining modified bit.

    pte_p := ^mmv$pt_p^ [pfte_p^.pti];
    pte_p^.v := FALSE;
    pte_p^.u := FALSE;
    mmp$sva_purge_one_page_map (pfte_p^.sva);


{If page belongs to a locked segment and is modified, leave it alone. NOTE: valid bit must
{be set again because it was cleared in a previous step.

    gfp$mtr_get_locked_fde_p (aste_p^.sfid, ijle_p, fde_p);

    IF fde_p^.segment_lock.locked_for_write AND (pte_p^.m OR (pfte_p^.active_io_count > 0)) THEN
      pte_p^.v := TRUE;
      rcount := 0;
      RETURN; {<----}
    ELSEIF fde_p^.flags.wire_eoi_page THEN

{ If the page belongs to a device file that has the WIRE_EOI attribute, dont remove it if
{ it is the last page of the segment. Set the USED bit so it we won't try to age it
{ for a while. Reset PTE.V because it was cleared above.

      IF (fde_p^.eoi_byte_address - pfte_p^.sva.offset) <= osv$page_size THEN
        pte_p^.v := TRUE;
        pte_p^.u := TRUE;
        rcount := 0;
        RETURN; {<----}
      IFEND;
    IFEND;

{Reset page ages.

    pfte_p^.age := 0;
    pfte_p^.cyclic_age := 0;
    rcount := 1;


{If the page belongs to a stack segment and is no longer needed, delete the page
{and relink the page frame to the free queue.

    IF fde_p^.stack_for_ring <> 0 THEN
      tmp$get_top_of_stack (fde_p^.global_task_id, fde_p^.stack_for_ring, tos);
      IF pfte_p^.sva.offset >= tos THEN
        mmp$delete_pt_entry (pfti, TRUE);
        mmp$relink_page_frame (pfti, mmc$pq_free);
        fde_p^.eoi_byte_address := tos;
        RETURN; {<----}
      IFEND;
    IFEND;


{Remove the page from the JWS and put it in the new queue.  New queue is determined by the state of the 'UM'
{bits in the page table entry. New queue may also be specified by caller - modified pages must
{be put in JWS queue if job is being swapped out.

    IF NOT pte_p^.m THEN
      IF pfte_p^.active_io_count <> 0 THEN
        IF ok_to_relink_to_avail_modified () THEN
          mmp$relink_page_frame (pfti, mmc$pq_avail_modified);
          mmv$aging_statistics.remove_unmodified_page_from_ws :=
                mmv$aging_statistics.remove_unmodified_page_from_ws + 1;
        ELSE
          pte_p^.v := TRUE;
        IFEND;
      ELSEIF mmv$no_memory_buffering THEN
        mmp$delete_pt_entry (pfti, TRUE);
        mmp$relink_page_frame (pfti, mmc$pq_free);
        mmv$aging_statistics.remove_unmodified_page_from_ws :=
              mmv$aging_statistics.remove_unmodified_page_from_ws + 1;
      ELSE
        mmp$relink_page_frame (pfti, mmc$pq_avail);
        mmv$aging_statistics.remove_unmodified_page_from_ws :=
              mmv$aging_statistics.remove_unmodified_page_from_ws + 1;
      IFEND;
    ELSE
      IF ok_to_relink_to_avail_modified () THEN
        mmp$relink_page_frame (pfti, mmc$pq_avail_modified);
        IF ((mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon) <
              mmv$write_aged_out_pages) THEN
          io_id.specified := FALSE;
          mmp$write_page_to_disk (fde_p, pfti, ioc$write_page, io_id, mmv$multi_page_write, write_status);
        IFEND;
        mmv$aging_statistics.remove_modified_page_from_ws :=
              mmv$aging_statistics.remove_modified_page_from_ws + 1;
        mcount := 1;
      ELSE
        pte_p^.v := TRUE;
      IFEND;
    IFEND;

  PROCEND mmp$remove_page_from_jws;
?? TITLE := 'MMP$REMOVE_PAGE_FROM_JOB' ??
?? EJECT ??

{------------------------------------------------------------------------------------
{
{ This procedure is called to remove pages from a job's working set. It is called
{ from mmp$mm_write_modified_pages (if the request is coming from detach file) to
{ relink unmodified jws pages to the available or free queues.
{
{------------------------------------------------------------------------------------

  VAR
    mmv$remove_page_model_number: [XDCL, #GATE] 0..0ff(16) := 16(16);

  PROCEDURE [XDCL] mmp$remove_page_from_job
    (    pfti: mmt$page_frame_index);

    VAR
      cst_p: ^ost$cpu_state_table,
      pte_p: ^ost$page_table_entry;

    pte_p := ^mmv$pt_p^ [mmv$pft_p^ [pfti].pti];

{Clear the valid bit in the page table entry for the page.

    pte_p^.v := FALSE;
    pte_p^.u := FALSE;
    mmp$sva_purge_one_page_map (mmv$pft_p^ [pfti].sva);
    mmv$pft_p^ [pfti].age := 0;
    mmv$pft_p^ [pfti].cyclic_age := 0;

{Remove the page from the JWS and put it in the new queue.

    IF NOT pte_p^.m THEN
      IF mmv$pft_p^ [pfti].active_io_count <> 0 THEN
        IF ok_to_relink_to_avail_modified () THEN
          mmp$relink_page_frame (pfti, mmc$pq_avail_modified);
        ELSE
          pte_p^.v := TRUE;
        IFEND;
      ELSEIF mmv$no_memory_buffering THEN
        mmp$delete_pt_entry (pfti, TRUE);
        mmp$relink_page_frame (pfti, mmc$pq_free);
      ELSE
        mmp$relink_page_frame (pfti, mmc$pq_avail);
      IFEND;
    ELSE

{ The following is a workaround to prevent 830s and 825s from crashing.  Somehow they can end up with
{ the modified bit set on a page that was attached in read mode only.  Engineers are looking into
{ the problem.

      mtp$cst_p (cst_p);
      IF cst_p^.element_id.model_number <= mmv$remove_page_model_number THEN
        pte_p^.m := FALSE;
        IF mmv$pft_p^ [pfti].active_io_count <> 0 THEN
          IF ok_to_relink_to_avail_modified () THEN
            mmp$relink_page_frame (pfti, mmc$pq_avail_modified);
          ELSE
            pte_p^.v := TRUE;
          IFEND;
        ELSEIF mmv$no_memory_buffering THEN
          mmp$delete_pt_entry (pfti, TRUE);
          mmp$relink_page_frame (pfti, mmc$pq_free);
        ELSE
          mmp$relink_page_frame (pfti, mmc$pq_avail);
        IFEND;
        dpp$display_error ('INFORMATIVE: PAGE FOUND MODIFIED ON REMOVE');
        mtp$store_informative_message ('PAGE FOUND MODIFIED ON REMOVE');
      ELSE
        mtp$error_stop ('PAGE FOUND MODIFIED ON REMOVE');
      IFEND;
    IFEND;
  PROCEND mmp$remove_page_from_job;

?? TITLE := 'CHECK_FREE_QUEUES' ??
?? EJECT ??

{----------------------------------------------------------------------
{
{This procedure is called after processing a request to determine if
{the free queues need to be replenished. If so, a flag is set to cause
{CP Monitor to call Memory Manager.
{
{---------------------------------------------------------------------

  PROCEDURE [INLINE] check_free_queues
    (    cst_p: ^ost$cpu_state_table);

    VAR
      count: integer;

    count := mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon;
    IF count < mmv$aggressive_aging_level_2 THEN
      jmp$recognize_thrashing;
    IFEND;
    IF count <= mmv$aggressive_aging_level THEN
      IF count < mmv$aggressive_aging_level THEN
        cst_p^.dispatch_control.asynchronous_interrupts_pending := TRUE;
      IFEND;
      mmv$time_to_call_mem_mgr := 0;
      osv$time_to_check_asyn := 0;
      mmv$aging_statistics.force_aggressive_aging := mmv$aging_statistics.force_aggressive_aging + 1;
    IFEND;

  PROCEND check_free_queues;

?? TITLE := 'MMP$AGE_JOB_WORKING_SET', EJECT ??

{--------------------------------------------------------------------------------------------------------
{  This routine scan the page frames in the working set of a
{  job and updates the page ages, clears the page table 'USED' bits,
{  and removes unused pages from the working set of the job.
{--------------------------------------------------------------------------------------------------------


  PROCEDURE [XDCL] mmp$age_job_working_set
    (    ijle_p: ^jmt$initiated_job_list_entry;
         jcb_p: ^jmt$job_control_block);


    VAR
      fde_p: gft$file_desc_entry_p,
      pqle_p: ^mmt$page_queue_list_entry,
      i: integer,
      cptime: integer,
      pfti: mmt$page_frame_index,
      perf,
      link,
      lu_link: mmt$link,
      pfte_p,
      lu_pfte_p: ^mmt$page_frame_table_entry,
      mcount: integer,
      rcount: integer,
      aii,
      aic,
      aif: integer;

    IF mmv$aging_algorithm >= 4 THEN
      cptime := ijle_p^.statistics.cp_time.time_spent_in_job_mode;
    ELSE
      cptime := ijle_p^.statistics.cp_time.time_spent_in_mtr_mode +
            ijle_p^.statistics.cp_time.time_spent_in_job_mode;
    IFEND;
    aii := (cptime - jcb_p^.cptime_next_age_working_set + jcb_p^.page_aging_interval) DIV
          jcb_p^.page_aging_interval;
    mmv$aging_statistics.calls_to_age_jws := mmv$aging_statistics.calls_to_age_jws + 1;
    IF (aii < 1) THEN
      aii := 1;
    IFEND;
    jcb_p^.cptime_next_age_working_set := cptime + jcb_p^.page_aging_interval;
    pqle_p := ^ijle_p^.job_page_queue_list [mmc$pq_job_working_set];


{ Calculate the values of  AIC, and AIF to be used in processing this request.

    aic := mmv$age_interval_ceiling;
    aif := mmv$age_interval_floor;


{ Age the job working set and relink the page frames into LRU order.

    mmp$reset_store_pfti;
    lu_link.bkw := 0;
    link.bkw := pqle_p^.link.bkw;
    rcount := ijle_p^.job_page_queue_list [mmc$pq_job_working_set].count - jcb_p^.min_working_set_size;

    IF syv$perf_keypoints_enabled.aging_keypoints THEN
      perf := link;
      WHILE perf.bkw <> 0 DO
        pfte_p := ^mmv$pft_p^ [perf.bkw];
        perf := pfte_p^.link;
        gfp$mtr_get_fde_p (pfte_p^.aste_p^.sfid, ijle_p, fde_p);
        #KEYPOINT (osk$performance, osk$m * fde_p^.last_segment_number, ptk$aging_segment);
        #KEYPOINT (osk$performance, osk$m * (pfte_p^.sva.offset DIV osv$page_size), ptk$aging_page_number);
      WHILEND;
      #KEYPOINT (osk$performance, osk$m * (ijle_p^.job_page_queue_list [mmc$pq_job_fixed].count),
            ptk$aging_job_fixed);
      #KEYPOINT (osk$performance, osk$m * (pfte_p^.ijl_ordinal.block_number *
            32 + pfte_p^.ijl_ordinal.block_index), ptk$aging_ijl_ordinal);
    IFEND;
    IF syv$perf_keypoints_enabled.aging_stack_trace THEN
      tmp$monitor_flag_job_tasks (syc$mf_for_keypoint_traceback, ijle_p);
    IFEND;

    WHILE (link.bkw <> 0) AND (rcount > 0) DO
      pfte_p := ^mmv$pft_p^ [link.bkw];
      pfti := link.bkw;
      link := pfte_p^.link;
      IF mmv$pt_p^ [pfte_p^.pti].u THEN
        mmv$pt_p^ [pfte_p^.pti].u := FALSE;
        pfte_p^.age := 0;
        pfte_p^.cyclic_age := 0;
        IF lu_link.bkw = 0 THEN
          lu_pfte_p := pfte_p;
          lu_link.fwd := link.fwd;
          lu_link.bkw := pfti;
        IFEND;
      ELSEIF pfte_p^.locked_page <> mmc$lp_not_locked THEN

{ Do nothing

      ELSEIF ((pfte_p^.age + aii) > aic) THEN
        mmp$store_pfti (pfti);
        rcount := rcount - 1;
      ELSEIF ((pfte_p^.age + aii) > aif) THEN
        mmp$store_pfti (pfti);
        rcount := rcount - 1;
        mmv$aging_statistics.age_exceeds_aif := mmv$aging_statistics.age_exceeds_aif + 1;
        aif := 65536; {Only remove one page for age > AIF}
      ELSE
        pfte_p^.age := pfte_p^.age + aii;
        IF (lu_link.bkw <> 0) THEN
          IF link.bkw = 0 THEN
            pqle_p^.link.fwd := link.fwd;
          ELSE
            mmv$pft_p^ [link.bkw].link.fwd := link.fwd;
          IFEND;
          mmv$pft_p^ [link.fwd].link.bkw := link.bkw;
          pfte_p^.link := lu_link;
          IF lu_link.fwd = 0 THEN
            pqle_p^.link.bkw := pfti;
          ELSE
            mmv$pft_p^ [lu_link.fwd].link.bkw := pfti;
          IFEND;
          lu_pfte_p^.link.fwd := pfti;
          lu_link.fwd := pfti;
        IFEND;
      IFEND;
    WHILEND;


{ If any pages have been selected for removal, remove the pages from the working set.

    mmp$fetch_pfti_array_size (rcount);
    mcount := 0;
    IF rcount > 0 THEN
      mmp$remove_pages_from_jws (mmc$pq_avail_modified, ijle_p, mcount, rcount);
      mmv$aging_statistics.age_exceeds_aic := mmv$aging_statistics.age_exceeds_aic + rcount;
    ELSE
      mmp$purge_all_page_map;
    IFEND;
    IF syv$perf_keypoints_enabled.aging_keypoints THEN
      #KEYPOINT (osk$performance, osk$m * mcount, ptk$aging_modified_pages);
      #KEYPOINT (osk$performance, osk$m * rcount, ptk$aging_pages_removed);
    IFEND;

  PROCEND mmp$age_job_working_set;
?? TITLE := 'MMP$REMOVE_STALE_PAGES', EJECT ??

{--------------------------------------------------------------------------------------------------------
{
{ This procedure is called to remove stale pages from a page queue. A stale page is defined as a page
{ that has a 'SWAP_COUNT' (field should be renamed) greater or equal to the value specified by the caller.
{
{ This procedure does the following:
{    . Scan each page in the page queue
{    . If the 'u' bit in the page table is set
{         clear it if aging the shared queue (if aging because of swapping,dont clear it - this would defeat
{              the page aging algorithms.
{    . ELSE if the swap count < stale count, increment swap count
{    . ELSE remove the page from the page queue (queue_id is passed from the caller to indicate if page goes
{         to AM or JWS queue (used for swap aging))
{
{ This procedure is intended to be used to:
{    . age the shared queue
{    . provide SWAPPING_AIC aging of job working sets prior to swap.
{
{ This procedure does NOT keep the page queue in a LRU order.
{
{--------------------------------------------------------------------------------------------------------


  PROCEDURE [XDCL] mmp$remove_stale_pages
    (VAR pqle: mmt$page_queue_list_entry;
         limit: integer;
         jcb_p: ^jmt$job_control_block;
         ijle_p: ^jmt$initiated_job_list_entry;
         queue_id: mmt$page_frame_queue_id;
         minimum_working_set: 0 .. 0ffff(16);
     VAR modified_pages_removed: integer;
     VAR total_pages_removed: integer);

    VAR
      cptime: integer,
      eoi: ost$segment_length,
      lstatus: syt$monitor_status,
      rcount: integer,
      pfti: mmt$page_frame_index,
      next_pfti: mmt$page_frame_index,
      mmv$age_not_pageable: [XDCL] integer := 0,
      pfte_p: ^mmt$page_frame_table_entry;

    IF jcb_p <> NIL THEN
      jcb_p^.next_cyclic_aging_time := #FREE_RUNNING_CLOCK (0) + jcb_p^.cyclic_aging_interval;
      IF mmv$aging_algorithm >= 4 THEN
        cptime := ijle_p^.statistics.cp_time.time_spent_in_job_mode;
      ELSE
        cptime := ijle_p^.statistics.cp_time.time_spent_in_mtr_mode +
              ijle_p^.statistics.cp_time.time_spent_in_job_mode;
      IFEND;
      jcb_p^.cptime_next_age_working_set := cptime + jcb_p^.page_aging_interval;
    IFEND;

    mmp$reset_store_pfti;
    pfti := pqle.link.bkw;
    rcount := pqle.count - minimum_working_set;

    WHILE (pfti <> 0) AND (rcount > 0) DO
      pfte_p := ^mmv$pft_p^ [pfti];
      next_pfti := pfte_p^.link.bkw;
      IF mmv$pt_p^ [pfte_p^.pti].u AND NOT jsv$free_working_set_on_swapout THEN
        mmv$pt_p^ [pfte_p^.pti].u := FALSE;
        pfte_p^.cyclic_age := 0;
        pfte_p^.age := 0;
      ELSEIF pfte_p^.cyclic_age < limit THEN
        pfte_p^.cyclic_age := pfte_p^.cyclic_age + 1;
      ELSEIF pfte_p^.locked_page <> mmc$lp_not_locked THEN

{ Do nothing

      ELSE
        mmp$store_pfti (pfti);
        rcount := rcount - 1;
      IFEND;

      pfti := next_pfti;
    WHILEND;


{ If any pages have been selected for removal, remove the pages from the working set.

    mmp$fetch_pfti_array_size (rcount);
    IF rcount > 0 THEN
      mmp$remove_pages_from_jws (queue_id, ijle_p, modified_pages_removed, total_pages_removed);
    ELSE
      total_pages_removed := 0;
      modified_pages_removed := 0;
      IF queue_id = mmc$pq_avail_modified THEN
        mmp$purge_all_page_map;
      IFEND;
    IFEND;


  PROCEND mmp$remove_stale_pages;
?? TITLE := 'MMP$TRIM_JOB_WORKING_SET', EJECT ??

{--------------------------------------------------------------------------------------------------
{ This procedure is called to trim a job working set.
{ If the size of the working set exceeds the max allowed, pages are removed until the size is ok.
{--------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$trim_job_working_set
    (    ijle_p: ^jmt$initiated_job_list_entry;
         jcb_p: ^jmt$job_control_block;
         trim_to_swap_size: boolean);

    VAR
      pfti: mmt$page_frame_index,
      last_pfti: mmt$page_frame_index,
      pte_p: ^ost$page_table_entry,
      maximum_pages_to_swap: integer,
      mcount: integer,
      rcount: integer,
      skip_count: integer,
      smallest_maximum_working_set: integer,
      page_skip: boolean,
      pfte_p: ^mmt$page_frame_table_entry;

    IF syv$recovering_job_count <> 0 THEN
      RETURN;
    IFEND;

 {    Skip working set adjustment if a segment lock is outstanding.
    IF ijle_p^.override_job_working_set_max THEN
      RETURN;
    IFEND;


    IF (jcb_p^.max_working_set_size < mmv$max_working_set_size) THEN
      smallest_maximum_working_set := jcb_p^.max_working_set_size;
    ELSE
      smallest_maximum_working_set := mmv$max_working_set_size;
    IFEND;

    IF trim_to_swap_size THEN
      IF ijle_p^.task_created_after_last_swap THEN
        maximum_pages_to_swap := jsv$max_pages_first_swap_task;
      ELSE
        maximum_pages_to_swap := jsv$maximum_pages_to_swap;
      IFEND;

      IF smallest_maximum_working_set > maximum_pages_to_swap THEN
        smallest_maximum_working_set := maximum_pages_to_swap;
      IFEND;
    IFEND;

    IF NOT trim_to_swap_size THEN
      IF ijle_p^.job_page_queue_list [mmc$pq_job_working_set].count <
        (smallest_maximum_working_set + 1) THEN
        RETURN;
      IFEND;
    IFEND;

    pfti := ijle_p^.job_page_queue_list [mmc$pq_job_working_set].link.bkw;


    WHILE (ijle_p^.job_page_queue_list [mmc$pq_job_working_set].count > smallest_maximum_working_set) AND
          (pfti <> 0) DO
      pfte_p := ^mmv$pft_p^ [pfti];
      last_pfti := pfti;
      pfti := pfte_p^.link.bkw;
      mmp$remove_page_from_jws (last_pfti, ijle_p, mcount, rcount);

    WHILEND;

  PROCEND mmp$trim_job_working_set;
?? TITLE := 'MMP$DUMP_SHARED_QUEUE' ??
?? EJECT ??

{--------------------------------------------------------------------------------------------------------
{ This procedure is called to take pages out of the shared queue.  Pages will be removed until
{ mmv$reassignable_page_frames.now minus mmv$aggressive_aging_level_2 is greater than
{ the number of pages requested.
{
{ The removal of pages from the shared queues will be done in two passes.  On the first pass a number of
{ pages will be removed from each shared queue as determined by the minimum size attribute of the queue.
{ If the minimum is zero, then all of the pages in that queue will be removed during the first pass.
{ If the first pass does not remove enough pages, then another pass will be made during which all pages
{ can be removed if necessary.  The passes are terminated early whenever enough pages have been removed.
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$dump_shared_queue
    (    total_pages_needed: mmt$page_frame_index);

    VAR
      modified_pages_removed: integer,
      next_pfti: mmt$page_frame_index,
      pages_from_queue: integer,
      pages_removed: integer,
      pfti: mmt$page_frame_index,
      reduce_queue_below_minimum: boolean,
      queue_id: mmt$page_frame_queue_id;

    reduce_queue_below_minimum := FALSE;

  /two_passes/
    WHILE 1 = 1 DO
      FOR queue_id := mmv$last_active_shared_queue DOWNTO mmc$pq_shared_first DO
        pfti := mmv$gpql [queue_id].pqle.link.bkw;
        IF reduce_queue_below_minimum THEN
          pages_from_queue := mmv$gpql [queue_id].pqle.count;
        ELSE
          pages_from_queue := mmv$gpql [queue_id].pqle.count - mmv$gpql [queue_id].minimum;
        IFEND;

{ If the count of pages in the queue is less than or equal to the minimum, one of the pages will be
{ removed on the first pass.  If there are no pages in the queue, pfti will be zero.

      /dump_a_queue/
        WHILE pfti <> 0 DO
          next_pfti := mmv$pft_p^ [pfti].link.bkw;
          mmp$remove_page_from_jws (pfti, NIL, modified_pages_removed, pages_removed);
          pfti := next_pfti;
          pages_from_queue := pages_from_queue - 1;
          IF pages_from_queue <= 0 THEN
            EXIT /dump_a_queue/
          IFEND;
          IF (mmv$reassignable_page_frames.now - mmv$aggressive_aging_level_2) >= total_pages_needed THEN
            EXIT /two_passes/ {Terminate both passes since the pages needed are available.
          IFEND;
        WHILEND /dump_a_queue/;
      FOREND;

      IF reduce_queue_below_minimum THEN
        EXIT /two_passes/; { exit, All the shared queues have been dumped including the minimums.
      IFEND;
      reduce_queue_below_minimum := TRUE; {Allow queues to be reduced below the minimum size on pass 2.
    WHILEND /two_passes/;


  PROCEND mmp$dump_shared_queue;

?? TITLE := 'MMP$ASSIGN_PAGE_FRAME' ??
?? EJECT ??

{--------------------------------------------------------------------------------------------------------
{ This procedure is called to assign a new page frame to a segment.
{ The routine performs the following steps:
{    . obtain a free page frame.
{    . delete the PT entry using the page frame (if necessary).
{    . make a new PT entry for the page.
{    . update the PFT entry for the page frame and the AST entry for the seg.
{
{      MMP$ASSIGN_PAGE_FRAME (SVA, ASTE_P, NUMBER_OF_PAGES_TO_ASSIGN, STARTING_PFTI,
{         ASSIGNED_PAGE_COUNT, PFTI, PSTATUS);
{
{  SVA: (INPUT) SVA that identifies page
{  ASTE_P: (INPUT) Pointer to AST table entry for the segment
{  NUMBER_OF_PAGES_TO_ASSIGN: (INPUT) This parameter specifies how many pages
{       the caller wants assigned.
{  STARTING_PFTI: (INPUT) This parameter specifies the pfti where page assignment is to begin.
{       This parameter will be non-zero only if the request for page assignment is coming
{       from the ASSIGN_CONTIGUOUS_MEMORY request.
{  ASSIGNED_PAGE_COUNT: (OUTPUT) Number of pages actually assigned. May be less than requested if a
{       page already exists in the specified range.
{  FIRST_PFTI: (OUTPUT) Page Frame Table index of first page frame assigned.  If more
{       than one page assigned the other pages are linked through the
{       backward link in the page frame table entry.
{  PSTATUS: (OUTPUT) Status
{           ps_done - if all pages were assigned
{           ps_no_memory - if insufficient memory is available to assign ALL requested
{           ps_pt_full - if page table full. Some pages may have been assigned before page table full
{              occurred; ASSIGNED_PAGE_COUNT will indicate how many pages were assigned.
{           ps_valid_in_pt - if a page is in PT. Some pages may have been assigned before valid in page
{              table occurred; ASSIGNED_PAGE_COUNT will inicate how many pages were assigned.
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$assign_page_frame
    (    sva: ost$system_virtual_address;
         aste_p: ^mmt$active_segment_table_entry;
         number_of_pages_to_assign: mmt$page_frame_index;
         starting_pfti: mmt$page_frame_index;
     VAR assigned_page_count: mmt$page_frame_index;
     VAR first_pfti: mmt$page_frame_index;
     VAR pstatus: mmt$page_pull_status);

    VAR
      assign_page_loop_count: mmt$page_frame_index,
      mpt_status: mmt$make_pt_entry_status,
      page_sva: ost$system_virtual_address,
      pfti: mmt$page_frame_index,
      pfte_p: ^mmt$page_frame_table_entry,
      temp_offset: integer;


    assigned_page_count := 0;
    first_pfti := starting_pfti;
    IF first_pfti <> 0 THEN
      pfti := starting_pfti - 1;
    IFEND;
    IF number_of_pages_to_assign > mmv$reassignable_page_frames.now THEN
      pstatus := ps_no_memory;
      RETURN;
    IFEND;

    pstatus := ps_done;
    page_sva := sva;
    assign_page_loop_count := number_of_pages_to_assign;

    WHILE assign_page_loop_count > 0 DO

{Get an available page frame to use for the new page.  Return an error code if no memory is available.

      IF starting_pfti = 0 THEN
        mmp$get_avail_page_frame (pfti);
        IF pfti = 0 THEN
          pstatus := ps_no_memory;
          RETURN;
        IFEND;
      ELSE

{The non-zero starting_pfti indicates that the request to assign page frames is
{coming from an ASSIGN_CONTIGUOUS_MEMORY request. That request has verified
{that the page frames from (starting_pfti-->number_pages_to_assign) are available.

        pfti := pfti + 1;
      IFEND;
      pfte_p := ^mmv$pft_p^ [pfti];


{Make a PT entry for the new page. If page table was full, link the page frame back to the free queue.

      mmp$make_pt_entry (page_sva, pfti, aste_p, pfte_p, mpt_status);
      IF mpt_status <> mmc$mpt_done THEN
        mmp$relink_page_frame (pfti, mmc$pq_free);
        IF mpt_status = mmc$mpt_page_table_full THEN
          mmv$async_work.pt_full_aste_p := aste_p;
          mmv$async_work.pt_full_sva := page_sva;
          mmv$async_work.pt_full := TRUE;
          mmv$time_to_call_mem_mgr := 0;
          osv$time_to_check_asyn := 0;
          pstatus := ps_pt_full;
        ELSE {must be valid in PT - make sure no other statuses}
          pstatus := ps_valid_in_pt;
        IFEND;
        RETURN;
      IFEND;


{Update the page frame table entry for the new entry.

      IF pfte_p^.task_queue.head <> 0 THEN
        mtp$error_stop ('MM - reassigned PF with task queue');
      IFEND;
      pfte_p^.age := 0;
      pfte_p^.cyclic_age := 0;
      pfte_p^.io_error := ioc$no_error;
      pfte_p^.sva := page_sva;
      pfte_p^.aste_p := aste_p;
      pfte_p^.locked_page := mmc$lp_not_locked;
      pfte_p^.ijl_ordinal := aste_p^.ijl_ordinal;


{Link the page frame into the new queue.

      mmp$relink_page_frame (pfti, aste_p^.queue_id);

      IF first_pfti = 0 THEN
        first_pfti := pfti;
      IFEND;

      assigned_page_count := assigned_page_count + 1;
      assign_page_loop_count := assign_page_loop_count - 1;
      IF assign_page_loop_count > 0 THEN
        temp_offset := page_sva.offset + osv$page_size;
        IF temp_offset > osc$maximum_offset THEN
          assign_page_loop_count := 0;
        ELSE
          page_sva.offset := temp_offset;
        IFEND;
      IFEND;
    WHILEND;


  PROCEND mmp$assign_page_frame;
?? TITLE := 'MMP$PAGE_PULL' ??
?? EJECT ??

{--------------------------------------------------------------------------------------------------------
{ This procedure is called to add a page of a segment to the address space of the current user task.
{ Mmp$page_pull_hash_sva MUST have been called before calling this procedure to verify that the page
{ is not already im memory (in the page table).
{ If this is a multiple page request, it is only known that the first page is not in memory.  Read_pages
{ from_disk_or_server or mmp$assign_page_frame will stop assigning new pages when an existing page is
{ encountered.  Both procedures return the actual number of new pages that were assigned.
{
{ When mmp$page_pull is called by the file server procedure, process_read_for_server, both the
{ cst_p and the stxe_p will be NIL.
{
{  All possible page pull status values MUST be in the CASE statement in the calling procedure, pr_pf.
{  The page pull status type is listed here aid readability of the page fault path.
{     mmt$page_pull_status = (ps_done, ps_found_in_avail, ps_found_in_avail_modified, ps_valid_in_pt,
{     ps_no_memory, ps_low_on_memory, ps_locked, ps_found_on_disk, ps_pt_full, ps_io_temp_reject,
{     ps_new_page_assigned, ps_beyond_file_limit, ps_read_beyond_eoi, ps_no_extend_permission,
{     ps_volume_unavailable, ps_found_on_server, ps_allocate_required_on_server, ps_server_terminated,
{     ps_job_work_required, ps_runaway_write);
{--------------------------------------------------------------------------------------------------------



  PROCEDURE [XDCL] mmp$page_pull
    (    xsva: ost$system_virtual_address;
         fde_p: gft$locked_file_desc_entry_p;
         cst_p: ^ost$cpu_state_table;
         aste_p: ^mmt$active_segment_table_entry;
         stxe_p: ^mmt$segment_descriptor_extended;
         io_id: mmt$io_identifier;
         pages_to_read: integer;
         io_function: iot$io_function;
         allocate_if_new: boolean;
     VAR page_count: mmt$page_frame_index;
     VAR pstatus: mmt$page_pull_status;
     VAR pfti: mmt$page_frame_index);

    VAR
      active_au_offset: integer,
      assigned_page_count: mmt$page_frame_index,
      bytes_to_read: integer,
      buffer_descriptor: mmt$buffer_descriptor,
      sva: ost$system_virtual_address,
      file_limits_enforced: sft$file_space_limit_kind,
      file_kind: gft$file_kind,
      low_on_page_frames: boolean,
      next_pfti: mmt$page_frame_index,
      shadow_au_offset: integer,
      page_status: gft$page_status,
      pages_to_allocate: integer,
      passive_fde_p: gft$locked_file_desc_entry_p,
      ijlo: jmt$ijl_ordinal,
      status: syt$monitor_status,
      update_eoi_reason: mmt$update_eoi_reason;

    page_count := 0;
    pfti := 0;
    sva := xsva;
    sva.offset := (sva.offset DIV osv$page_size) * osv$page_size;


{A new page frame is required. If the system is running low on memory and the requesting task is not a
{system task, reject the request. This will cause the user to be put in a WAIT state.
{For a served file fault, just check low on memory.

    low_on_page_frames := mmv$reassignable_page_frames.now < mmv$aggressive_aging_level_2;
    IF low_on_page_frames AND ((cst_p = NIL) OR (cst_p^.xcb_p^.system_table_lock_count < 256) AND
          NOT cst_p^.xcb_p^.critical_task) THEN
      pstatus := ps_low_on_memory;
      RETURN;
    IFEND;


{ Check for reference beyond EOI if user does not have EXTEND permission.

    IF (sva.offset >= fde_p^.eoi_byte_address) AND (cst_p <> NIL) AND
          ((stxe_p^.access_rights <> mmc$sar_write_extend) OR NOT allocate_if_new) THEN
      IF stxe_p^.access_rights = mmc$sar_modify THEN
        pstatus := ps_no_extend_permission;
      ELSE
        pstatus := ps_read_beyond_eoi;
      IFEND;
      RETURN;
    IFEND;

{ Check for a write that goes beyond eoi by an unreasonable amount.

   IF (sva.offset > fde_p^.eoi_byte_address + mmv$maximum_write_span) THEN
    IF (cst_p <> NIL) AND (stxe_p^.access_rights = mmc$sar_write_extend) THEN
     IF ((stxe_p^.software_attribute_set = $mmt$software_attribute_set
      [mmc$sa_free_behind]) OR (stxe_p^.software_attribute_set =
      $mmt$software_attribute_set [mmc$sa_no_append]) OR
      (stxe_p^.software_attribute_set = $mmt$software_attribute_set
      [mmc$sa_job_shared]) OR (stxe_p^.software_attribute_set =
      $mmt$software_attribute_set [mmc$sa_read_transfer_unit])) THEN
        pstatus := ps_runaway_write;
        RETURN;
    IFEND;
   IFEND;
  IFEND;
{ Check for reference beyond file limit. Note: during deadstart, a reference beyond
{ EOI may be for the memory resident portion of the old image file.

    IF sva.offset >= fde_p^.file_limit THEN
      IF (mmv$image_file.active) AND (aste_p^.sfid = mmv$image_file.sfid) THEN
        process_memory_image_pf (sva, aste_p, pfti, pstatus);
        page_count := 1;
      ELSE
        pstatus := ps_beyond_file_limit;
      IFEND;
      RETURN;
    IFEND;


{ Determine limits options. Served files always have a NIL cst_p and require no
{ limits checking.

    IF cst_p = NIL THEN
      ijlo := jmv$null_ijl_ordinal;
      file_limits_enforced := sfc$no_limit;
    ELSE
      ijlo := cst_p^.ijl_ordinal;
      file_limits_enforced := stxe_p^.file_limits_enforced;
    IFEND;


{ Determine the status/location of the page.

    CASE fde_p^.media OF
    = gfc$fm_transient_segment =
      IF (aste_p^.pages_in_memory > mmv$max_pages_no_file) AND NOT
           ((aste_p^.queue_id = mmc$pq_wired) OR (aste_p^.queue_id = mmc$pq_job_fixed)) THEN
        set_assign_active (stxe_p, sva.offset);
        tmp$set_monitor_flag (cst_p^.taskid, mmc$mf_segment_mgr_flag, status);
      IFEND;
      page_status := gfc$ps_page_doesnt_exist;
    = gfc$fm_mass_storage_file =
      IF cst_p <> NIL THEN
        mmv$last_segment_accessed := (#OFFSET (#LOC (stxe_p^)) - cst_p^.xcb_p^.sdtx_offset) DIV
              #SIZE (mmt$segment_descriptor_extended);
      IFEND;
      dmp$fetch_page_status (fde_p, sva.offset, file_limits_enforced, allocate_if_new, page_status);
    = gfc$fm_served_file =
      dfp$fetch_page_status (fde_p, sva.offset, page_status);
    ELSE
      mtp$error_stop ('MM - bad FDE.MEDIA');
    CASEND;


{ If job mode work is required but the task is in some state where it is not advisable
{ to interrupt it, allow escaped allocation to occur. Otherwise reject the page fault
{ and let the task fix the problem in job mode before assigning the page.

    IF (page_status = gfc$ps_job_mode_work_required) AND (cst_p <> NIL) THEN
      set_assign_active (stxe_p, sva.offset);
      IF (cst_p^.xcb_p^.system_table_lock_count > 255) AND (cst_p^.xcb_p^.xp.p_register.pva.ring > 1) THEN
        cst_p^.xcb_p^.stlc_allocation := TRUE;
      ELSE
        tmp$set_monitor_flag (cst_p^.taskid, mmc$mf_segment_mgr_flag, status);
      IFEND;
      IF (cst_p^.xcb_p^.xp.trap_enable <> osc$traps_enabled) OR (cst_p^.xcb_p^.xp.p_register.pva.ring = 1) OR
            (osc$trap_exception IN cst_p^.xcb_p^.xp.monitor_condition_register) OR
            (fde_p^.stack_for_ring <> 0) OR (cst_p^.xcb_p^.system_table_lock_count > 255) THEN
        page_status := gfc$ps_page_doesnt_exist;
      IFEND;
    IFEND;

{ If temp reject is indicated for one of the Device Manager tasks, allow
{ escaped allocation since blocking them might cause a system deadlock.

    IF (page_status = gfc$ps_temp_reject) AND (cst_p <> NIL) AND
          ((cst_p^.xcb_p^.system_task_id = tmc$stid_administer_log) OR
           (cst_p^.xcb_p^.system_task_id = tmc$stid_dm_split_al) OR
           (cst_p^.xcb_p^.system_task_id = tmc$stid_volume_space_managemnt)) THEN
      page_status := gfc$ps_page_doesnt_exist;
    IFEND;


{Process page fault depending on the location of the page.

    CASE page_status OF
    = gfc$ps_page_on_disk, gfc$ps_page_on_server =
      IF NOT low_on_page_frames THEN
        bytes_to_read := (fde_p^.allocation_unit_size - (sva.offset MOD fde_p^.allocation_unit_size));
        IF sva.offset + bytes_to_read > fde_p^.eoi_byte_address THEN
          bytes_to_read := fde_p^.eoi_byte_address - sva.offset + osv$page_size - 1;
        IFEND;
        page_count := bytes_to_read DIV osv$page_size;
        IF page_count > pages_to_read THEN
          page_count := pages_to_read;
        IFEND;
      ELSE
        page_count := 1;
      IFEND;

      read_pages_from_disk_or_server (io_function, fde_p, sva, page_count, aste_p, sva.offset, io_id, FALSE,
            assigned_page_count, pstatus, pfti);
      page_count := assigned_page_count;

    = gfc$ps_job_mode_work_required =
      mmp$update_eoi (fde_p, sva.offset, mmc$uer_page_assigned);  {Needed so job mode knows adr to allocate}
      pstatus := ps_job_work_required;

    = gfc$ps_volume_unavailable =
      IF fde_p^.flags.wire_eoi_page AND (sva.offset >= fde_p^.eoi_byte_address) THEN
        mmp$assign_page_frame (sva, aste_p, 1, 0, page_count, pfti, pstatus);
        IF pstatus = ps_done THEN
          mmp$preset_real_memory (sva, fde_p^.preset_value);
          mmv$pt_p^ [mmv$pft_p^ [pfti].pti].v := TRUE;
          pstatus := ps_new_page_assigned;
          mmp$update_eoi (fde_p, sva.offset, mmc$uer_page_assigned);
        IFEND;
      ELSE
        pstatus := ps_volume_unavailable;
      IFEND;

    = gfc$ps_server_allocate_required =

      mmp$assign_page_frame (sva, aste_p, 1, 0, page_count, pfti, pstatus);
      IF pstatus = ps_done THEN
        mmp$preset_real_memory (sva, fde_p^.preset_value);
        pstatus := ps_allocate_required_on_server;
        IF pages_to_read < mmv$pages_for_overallocation THEN
          pages_to_allocate := mmv$pages_for_overallocation;
        ELSE
          pages_to_allocate := pages_to_read;
        IFEND;
        buffer_descriptor.buffer_descriptor_type := mmc$bd_paging_io;
        buffer_descriptor.sva := sva;
        buffer_descriptor.page_count := page_count;
        dfp$file_server_allocation (aste_p^.sfid, sva.offset, (pages_to_allocate * osv$page_size) +
              sva.offset, io_id, buffer_descriptor, stxe_p^.file_limits_enforced, status);
        IF status.normal THEN
          mmp$update_eoi (fde_p, sva.offset, mmc$uer_page_assigned);
          RETURN; {<----}
        ELSEIF (status.condition = dme$transient_error) OR (status.condition = ioe$requests_full) THEN
          pstatus := ps_io_temp_reject;
        ELSEIF status.condition = ioe$unit_disabled THEN
          pstatus := ps_volume_unavailable;
        ELSEIF status.condition = dfe$server_has_terminated THEN
          pstatus := ps_server_terminated;
        ELSE
          mtp$error_stop ('MM - unexpected phy io error');
        IFEND;
        mmp$delete_pt_entry (pfti, TRUE);
        mmp$relink_page_frame (pfti, mmc$pq_free);
      IFEND;

    = gfc$ps_temp_reject, gfc$ps_account_limit_exceeded =
      pstatus := ps_io_temp_reject;

    = gfc$ps_server_terminated =
      pstatus := ps_server_terminated;

    = gfc$ps_page_doesnt_exist =

{ For page not on server, the file cannot be shadowed.  This applies where
{ the active file is on the server.
{ The pointer to the CPU_STATE_TABLE will always be non-nil on the client side of file_server.

      IF (stxe_p = NIL) OR (stxe_p^.shadow_info.shadow_segment_kind = mmc$ssk_none) OR
            (sva.offset >= (stxe_p^.shadow_info.shadow_length_page_count * osv$page_size)) THEN

{ Determine if multiple pages should be assigned for this "new page" page fault.
{ The numbers 32768 and 16384 are arbitrary.  Files less then 32768 are not as likely
{ to use the extra assigned pages.  Offset MOD 16384 is because most allocation units
{ are 16384.  This fault would then probably be for the first page in the AU.

        pages_to_allocate := 1;

        IF (sva.offset >= 32768) AND ((sva.offset MOD 16384) = 0) AND
              (fde_p^.media <> gfc$fm_transient_segment) AND
              (fde_p^.file_kind <> gfc$fk_device_file) AND
              (mmv$reassignable_page_frames.now > mmv$assign_multiple_pages) AND
              (mmv$pages_per_new_page_fault > 1) AND

{ Check if assignment of extra pages will fit into allocated space.

        (fde_p^.allocation_unit_size - (sva.offset MOD fde_p^.allocation_unit_size) >=
              mmv$pages_per_new_page_fault * osv$page_size) THEN
          pages_to_allocate := mmv$pages_per_new_page_fault;
        IFEND;

        mmp$assign_page_frame (sva, aste_p, pages_to_allocate, 0, page_count, pfti, pstatus);

        IF page_count > 0 THEN
          pstatus := ps_new_page_assigned;

{ Update EOI for the 1st page assigned (the page faulted for).  Don't change EOI if this is a
{ read for server.  If the client is running with a larger page size, updating the EOI would be
{ wrong.  If the page is written on, EOI will be updated when the client sends it back.

          IF io_function <> ioc$read_for_server THEN
            IF page_count > 1 THEN
              update_eoi_reason := mmc$uer_multiple_pages_assigned;
            ELSE
              update_eoi_reason := mmc$uer_page_assigned;
            IFEND;
            mmp$update_eoi (fde_p, sva.offset, update_eoi_reason);
          ELSE
            fde_p^.eoi_state := mmc$eoi_uncertain;
          IFEND;

{ Preset memory if necessary.

          next_pfti := pfti;
          WHILE next_pfti <> 0 DO
            IF (fde_p^.stack_for_ring = 0) OR (fde_p^.stack_for_ring > 3) THEN
              mmp$preset_real_memory (sva, fde_p^.preset_value);
            IFEND;
            mmv$pt_p^ [mmv$pft_p^ [next_pfti].pti].v := TRUE;
            next_pfti := mmv$pft_p^ [next_pfti].link.bkw;
            IF next_pfti <> 0 THEN
              sva.offset := sva.offset + osv$page_size;
            IFEND;
          WHILEND;
        IFEND;

      ELSE

{ The page is shadowed by another file and the page resides on the shadow file.
{ If shadow is by segment number then assign pages for the transfer unit and set the 'm'
{ bit in the page table.  Put the source and destination pva into the xcb along with the
{ page count for the transfer.  Set the monitor flag, mmc$mf_shadow_file_reference, so that
{ mmp$mfh_shadow_file_reference will be called to copy the data.  Otherwise initiate I/O to
{ read the transfer unit containing the page from the shadow file and set the 'm' bit in the
{ page table entry for each page.

        active_au_offset := (sva.offset DIV fde_p^.allocation_unit_size) * fde_p^.allocation_unit_size;
        shadow_au_offset := (stxe_p^.shadow_info.shadow_start_page_number * osv$page_size) + active_au_offset;

        gfp$mtr_get_locked_fde_p (stxe_p^.shadow_info.shadow_sfid, cst_p^.ijle_p, passive_fde_p);
        sva.offset := active_au_offset;

        bytes_to_read := stxe_p^.shadow_info.shadow_length_page_count * osv$page_size - active_au_offset;
        IF bytes_to_read > fde_p^.allocation_unit_size THEN
          bytes_to_read := fde_p^.allocation_unit_size;
        IFEND;

        page_count := bytes_to_read DIV osv$page_size;

{ If the job is able to take a trap and copy the pages from the passive segment, send a
{ flag to the job to do this.

        IF (cst_p^.xcb_p^.xp.trap_enable = osc$traps_enabled) AND
              (cst_p^.xcb_p^.xp.p_register.pva.ring > 1) AND (stxe_p^.shadow_info.shadow_segment_kind =
              mmc$ssk_segment_number) THEN
          mmp$assign_page_frame (sva, aste_p, page_count, 0, assigned_page_count, pfti, pstatus);

          IF (assigned_page_count = page_count) THEN
            pstatus := ps_new_page_assigned;

            next_pfti := pfti;
            WHILE next_pfti <> 0 DO
              mmv$pt_p^ [mmv$pft_p^ [next_pfti].pti].v := TRUE;
              mmv$pt_p^ [mmv$pft_p^ [next_pfti].pti].m := TRUE;
              next_pfti := mmv$pft_p^ [next_pfti].link.bkw;
            WHILEND;

            mmp$update_eoi (fde_p, sva.offset + bytes_to_read - osv$page_size, mmc$uer_page_assigned);
            cst_p^.xcb_p^.shadow_reference_info.source_pva :=
                  #ADDRESS (1, stxe_p^.shadow_info.shadow_segment_number, shadow_au_offset);
            cst_p^.xcb_p^.shadow_reference_info.destination_pva :=
                  #ADDRESS (1, fde_p^.last_segment_number, sva.offset);
            cst_p^.xcb_p^.shadow_reference_info.page_count := page_count;
            tmp$set_monitor_flag (cst_p^.taskid, mmc$mf_shadow_file_reference, status);
          ELSE

{ Not all pages assigned.  Release those that were.

            WHILE pfti <> 0 DO
              mmp$delete_pt_entry (pfti, TRUE);
              next_pfti := mmv$pft_p^ [pfti].link.bkw;
              mmp$relink_page_frame (pfti, mmc$pq_free);
              pfti := next_pfti;
            WHILEND;

          IFEND;

{ If the job cannot trap or if the file is not shadowed by segment number, issue
{ the IO requests to read the pages.

        ELSE
          read_pages_from_disk_or_server (io_function, passive_fde_p, sva, page_count, aste_p,
                shadow_au_offset, io_id, TRUE, assigned_page_count, pstatus, pfti);
          page_count := assigned_page_count;

          IF (pstatus = ps_found_on_disk) OR (pstatus = ps_found_on_server) THEN
            next_pfti := pfti;
            WHILE next_pfti <> 0 DO
              mmv$pt_p^ [mmv$pft_p^ [next_pfti].pti].m := TRUE;
              next_pfti := mmv$pft_p^ [next_pfti].link.bkw;
            WHILEND;
            mmp$update_eoi (fde_p, sva.offset + bytes_to_read - osv$page_size, mmc$uer_page_assigned);
          IFEND;
        IFEND;
      IFEND;

    ELSE
      mtp$error_stop ('mm - unexpected DM error');
    CASEND;

  PROCEND mmp$page_pull;

?? OLDTITLE, NEWTITLE := 'READ_PAGES_FROM_DISK_OR_SERVER', EJECT ??

  PROCEDURE read_pages_from_disk_or_server
    (    io_function: iot$io_function;
         fde_p: gft$locked_file_desc_entry_p;
         sva: ost$system_virtual_address;
         page_count: mmt$page_frame_index;
         aste_p: ^mmt$active_segment_table_entry;
         file_offset: integer;
         io_id: mmt$io_identifier;
         all_requested_needed: boolean;
     VAR assigned_page_count: mmt$page_frame_index;
     VAR pstatus: mmt$page_pull_status;
     VAR pfti: mmt$page_frame_index);

    VAR
      buffer_descriptor: mmt$buffer_descriptor,
      next_pfti: mmt$page_frame_index,
      status: syt$monitor_status;


{   Assign the page frame for the incoming page.  The variable, assigned_page_count is initialized
{   in mmp$assign_page_frame.

    mmp$assign_page_frame (sva, aste_p, page_count, 0, assigned_page_count, pfti, pstatus);

    IF (assigned_page_count > 0) AND ((assigned_page_count = page_count) OR NOT all_requested_needed) THEN
      buffer_descriptor.buffer_descriptor_type := mmc$bd_paging_io;
      buffer_descriptor.sva := sva;
      buffer_descriptor.page_count := assigned_page_count;
      IF fde_p^.media = gfc$fm_mass_storage_file THEN
        iop$pager_io (fde_p, file_offset, buffer_descriptor, assigned_page_count * osv$page_size, io_function,
              io_id, status);
        pstatus := ps_found_on_disk;

      ELSE
        dfp$server_io (fde_p, ioc$read_page, file_offset, assigned_page_count * osv$page_size, io_id,
              buffer_descriptor, status);
        pstatus := ps_found_on_server;
      IFEND;
      IF status.normal THEN
        RETURN;
      ELSEIF (status.condition = dme$transient_error) OR (status.condition = ioe$requests_full) THEN
        pstatus := ps_io_temp_reject;
      ELSEIF status.condition = ioe$unit_disabled THEN
        pstatus := ps_volume_unavailable;
      ELSEIF status.condition = dfe$server_has_terminated THEN
        pstatus := ps_server_terminated;
      ELSE
        mtp$error_stop ('MM - unexpected phy io error');
      IFEND;
    IFEND;

{ Not enough frames.  Delete the page table entries for the ones just found.

    WHILE pfti <> 0 DO
      mmp$delete_pt_entry (pfti, TRUE);
      next_pfti := mmv$pft_p^ [pfti].link.bkw;
      mmp$relink_page_frame (pfti, mmc$pq_free);
      pfti := next_pfti;
    WHILEND;

  PROCEND read_pages_from_disk_or_server;
?? TITLE := 'PROCESS_MEMORY_IMAGE_PF' ??
?? EJECT ??

  PROCEDURE process_memory_image_pf
    (    sva: ost$system_virtual_address;
         aste_p: ^mmt$active_segment_table_entry;
     VAR pfti: mmt$page_frame_index;
     VAR pstatus: mmt$page_pull_status);

    VAR
      mpt_status: mmt$make_pt_entry_status,
      pfte_p: ^mmt$page_frame_table_entry;

    IF (((sva.offset - mmv$image_file.file_offset) + osv$180_memory_limits.lower) DIV osv$page_size) >
          UPPERVALUE (pfti) THEN
      pstatus := ps_beyond_file_limit;
      pfti := 0;
      RETURN; {<----}
    IFEND;

    pfti := ((sva.offset - mmv$image_file.file_offset) + osv$180_memory_limits.lower) DIV osv$page_size;
    pfte_p := ^mmv$pft_p^ [pfti];
    pfte_p^.age := 0;
    pfte_p^.cyclic_age := 0;
    pfte_p^.sva := sva;
    pfte_p^.aste_p := aste_p;
    pfte_p^.locked_page := mmc$lp_aging_lock;
    pfte_p^.ijl_ordinal := jmv$system_ijl_ordinal;

    mmp$make_pt_entry (sva, pfti, aste_p, pfte_p, mpt_status);

    IF mpt_status = mmc$mpt_done THEN
      mmv$pt_p^ [mmv$pft_p^ [pfti].pti].v := TRUE;
      pstatus := ps_found_in_avail;
    ELSEIF mpt_status = mmc$mpt_page_table_full THEN
      pstatus := ps_pt_full;
      mmv$async_work.pt_full_aste_p := aste_p;
      mmv$async_work.pt_full_sva := sva;
      mmv$async_work.pt_full := TRUE;
      mmv$time_to_call_mem_mgr := 0;
      osv$time_to_check_asyn := 0;
    ELSE
      mtp$error_stop ('MM - error in processing memory image pf');
    IFEND;

  PROCEND process_memory_image_pf;

?? TITLE := 'PR_PF - Primary entry point for PF processing' ??
?? EJECT ??

{--------------------------------------------------------------------------------------------------------
{Name:
{  pr_pf
{Purpose:
{  This routine is called by monitor to process a page fault.
{Input:
{  none
{Output:
{  none
{Error Codes:
{  none
{--------------------------------------------------------------------------------------------------------



  PROCEDURE [XDCL] pr_pf
    (    dummy: ^cell;
         cst_p: ^ost$cpu_state_table);


    TYPE
      trick_ptr = record
        case boolean of
        = TRUE =
          pva: ost$pva,
        = FALSE =
          p: ^cell,
        casend,
      recend;

    VAR
      aste_p: ^mmt$active_segment_table_entry,
      check_aio_slowdown: boolean,
      count: 1 .. 32,
      cptime: ost$cp_time_value,
      faulted_tu: integer,
      fde_p: gft$locked_file_desc_entry_p,
      file_limit: integer, {must be integer}
      found: boolean,
      gtid: ^0 .. 0ffffff(16),
      i: integer,
      ipti: integer,
      ijle_p: ^jmt$initiated_job_list_entry,
      io_id: mmt$io_identifier,
      keypoint_page_fault_status: mmt$keypoint_page_fault_status,
      last_faulted_tu: integer,
      last_page_fault: ost$segment_offset,
      mcount: integer,
      monitor_fault: ost$monitor_fault,
      mws: integer,
      nominal_page_fault: boolean,
      null_utp: [STATIC, READ] ost$pva := [1, 0fff(16), 7fffffff(16)],
      OFF: integer,
      page_count: mmt$page_frame_index,
      page_streaming_available_page: boolean,
      pages_pulled: integer,
      pages_to_be_pulled: integer,
      pages_to_read: integer,
      pfti: mmt$page_frame_index,
      pfti_of_faulted_page: mmt$page_frame_index,
      pstatus: mmt$page_pull_status,
      pstatus_of_faulted_page: mmt$page_pull_status,
      pva: trick_ptr,
      rcount: integer,
      relative_transfer_unit: integer,
      sac_p: ^mmt$segment_access_condition,
      seg: integer,
      ste_p: ^mmt$segment_descriptor,
      streaming_transfer_pages: integer,
      streaming_transfer_unit: integer,
      stxe_p: ^mmt$segment_descriptor_extended,
      sva: ost$system_virtual_address,
      sva_current: ost$system_virtual_address,
      sva_start: ost$segment_offset,
      temp_offset: integer,
      transfer_unit_count: integer,
      tu_to_stream: integer,
      xsva: ost$system_virtual_address,
      xpfti: mmt$page_frame_index;


    io_id.specified := FALSE;

{Use a special routine for page faults which occur during deadstart.

    IF NOT mmv$tables_initialized THEN
      pf_proc_tables_not_initialized (cst_p^.xcb_p);
      RETURN;
    IFEND;

{ Process page fault on keypoint segment separate from other page faults

    IF (cst_p^.xcb_p^.xp.untranslatable_pointer.seg = osc$kpt_pva_segment) THEN
      osp$process_keypoint_page_fault (cst_p^.xcb_p^.xp.untranslatable_pointer.offset,
            keypoint_page_fault_status);
      CASE keypoint_page_fault_status OF

      = mmc$kpfs_normal =
        RETURN;

      = mmc$kpfs_disable_keypoints =
        cst_p^.xcb_p^.xp.p_register.pva.offset := cst_p^.xcb_p^.xp.p_register.pva.offset + 4;
        RETURN;

      = mmc$kpfs_invalid_keypoint =

{ Do nothing; subsequent page fault processing will reject with an access violation.

      ELSE
      CASEND;
    IFEND;

{Get the PVA that caused the page fault from the exchange package of the current user task and convert it to
{an SVA.

    pva.pva := cst_p^.xcb_p^.xp.untranslatable_pointer;
    #KEYPOINT (osk$mtr, osk$monitor_multiplier * pva.pva.seg, mmk$page_fault);
    IF syv$perf_keypoints_enabled.memory_keypoints THEN
      #KEYPOINT (osk$performance, osk$m * pva.pva.seg, ptk$page_fault_segment);
      seg := cst_p^.xcb_p^.xp.p_register.pva.seg;
      #KEYPOINT (osk$performance, osk$m * seg, ptk$page_fault_p_segment);
      OFF := cst_p^.xcb_p^.xp.p_register.pva.offset MOD 100000(16);
      #KEYPOINT (osk$performance, osk$m * OFF, ptk$page_fault_p_lower_offset);
      OFF := cst_p^.xcb_p^.xp.p_register.pva.offset DIV 100000(16);
      #KEYPOINT (osk$performance, osk$m * OFF, ptk$page_fault_p_upper_offset);
      gtid := #LOC (cst_p^.xcb_p^.global_task_id);
      #KEYPOINT (osk$performance, osk$m * gtid^, ptk$page_fault_gtid);
      OFF := pva.pva.offset MOD 100000(16);
      #KEYPOINT (osk$performance, osk$m * OFF, ptk$page_fault_lower_offset);
      OFF := pva.pva.offset DIV 100000(16);
      #KEYPOINT (osk$performance, osk$m * OFF, ptk$page_fault_upper_offset);
    IFEND;

    mmp$convert_pva (pva.p, cst_p, sva, fde_p, aste_p, ste_p, stxe_p);

    ijle_p := cst_p^.ijle_p;
    IF aste_p = NIL THEN
      faulted_tu := 0;
      page_count := 0;
      pstatus := ps_read_beyond_eoi;
    ELSEIF stxe_p^.access_state <> mmc$sas_allow_access THEN
      IF stxe_p^.access_state = mmc$sas_inhibit_access THEN
        mmv$refs_to_unrec_df_file_inhib := mmv$refs_to_unrec_df_file_inhib + 1;
        pstatus := ps_volume_unavailable;
      ELSEIF stxe_p^.access_state = mmc$sas_terminate_access THEN
        mmv$refs_to_unrec_df_file_term := mmv$refs_to_unrec_df_file_term + 1;
        pstatus := ps_server_terminated;
      IFEND;
      faulted_tu := 0;
      page_count := 0;
    ELSE

      streaming_transfer_pages :=
      #SHIFT (1, stxe_p^.stream.transfer_size);
      streaming_transfer_unit := streaming_transfer_pages * osv$page_size;
      faulted_tu := sva.offset DIV streaming_transfer_unit;
      last_page_fault := stxe_p^.stream.last_page_fault;
      stxe_p^.stream.last_page_fault := sva.offset;
      last_faulted_tu := last_page_fault DIV streaming_transfer_unit;
      relative_transfer_unit := faulted_tu - last_faulted_tu;

    /find_the_page/
      BEGIN

        mmp$page_pull_hash_sva (sva, aste_p, page_count, pstatus, pfti);

{ If the page was found, the code below will exit /find_the_page/ quickly if the segment is not in prestream
{ or stream mode.  If the page is not found or if the segment is in a stream mode, page_count, pstatus, and
{ pfti will be used later to determine if a call to mmp$page_pull is necessary.  Segments in a stream mode do
{ not attempt the quick exit because:   A) If an available page is found, the stream code will pull another
{ page.   B) If a locked/valid page is found, a segment in stream mode may need to read another transfer unit.


        nominal_page_fault := TRUE;

{ To detect sequential processing of a segment, the segment is logically divided into page streaming transfer
{ units.  If a page fault is either in the same transfer unit or in the next transfer unit then it is
{ considered to be sequential processing.   Prestream mode is entered when the number of consecutive page
{ faults that appear to be sequential exceeds the mmv$page_streaming_prestream.  In prestream mode the
{ pages from the current page fault to the end of the transfer unit will be pulled.  Once we get to
{ page streaming mode the process will keep IO requests outstanding to read the pages from the current
{ transfer unit plus read ahead one or more TU (total number of TU read = mmv$page_streaming_reads)
{ The code below checks the prestream threshold, counts sequential accesses, determines if the current page
{ fault is to be considered sequential, and either continues or terminates the sequential process.

        IF stxe_p^.stream.sequential_accesses < mmv$page_streaming_prestream THEN
          IF (relative_transfer_unit < 0) OR (relative_transfer_unit > 1) THEN
            stxe_p^.stream.sequential_accesses := 1; {Reset counter, count current fault as first fault
          ELSE
            stxe_p^.stream.sequential_accesses := stxe_p^.stream.sequential_accesses + 1;
          IFEND;
          IF page_count = 1 THEN
            EXIT /find_the_page/;
          IFEND;

        ELSE {prestream mode or stream mode}

{ The segment is in prestream or stream.  If it is very well behaved the relative transfer unit will be
{ equal to zero or one.  If zero, do not increment the sequential accesses count since a fault has already
{ occurred in this TU. (The algorithm to switch to page streaming mode assumes each fault after prestream
{ mode is entered is equal to a transfer_unit of data)  If one, increment the sequential accesses count.
{ For the special cases listed below, continue but don't increment the sequential count, wait for
{ confirming sequential faults before going to page streaming mode.  the special cases:
{ a) Faulted_tu = 0; A fault in the first transfer unit.  Since the last fault was in a higher TU, a fault
{                    in TU=0 may indicate a rewind of the file.
{ b) Relative_Transfer_Unit greater than one but less than mmv$page_streaming_reads+1;  If in prestream mode
{                    the task has skipped at least one transfer unit, In stream mode we are not sure if it is
{                    normal or if a tranfer unit has been skipped.
{ c) Preset_Streaming;  A special case to immediately enter page streaming mode.
{
{ Note that nominal_page_fault  = TRUE

          IF relative_transfer_unit = 1 THEN
            nominal_page_fault := FALSE;
            IF stxe_p^.stream.random_faults > 0 THEN
              stxe_p^.stream.random_faults := 0;
              mmv$paging_statistics.page_streaming.random_faults :=
                    mmv$paging_statistics.page_streaming.random_faults + 1;
            IFEND;
            IF (stxe_p^.stream.sequential_accesses < UPPERVALUE (stxe_p^.stream.sequential_accesses)) THEN
              stxe_p^.stream.sequential_accesses := stxe_p^.stream.sequential_accesses + 1;
            IFEND;

          ELSEIF (((relative_transfer_unit >= 0) AND (relative_transfer_unit <=
                (mmv$page_streaming_reads + 1))) OR (faulted_tu = 0) OR (stxe_p^.stream.preset_streaming))
                THEN
            nominal_page_fault := FALSE;

{ This fault is considered random because it is either prior to the transfer unit of the last fault or it is
{ in a TU that is more than mmv$page_streaming_reads past the TU of the last fault.  If in prestream mode
{ terminate prestream.  If in page streaming mode, allow up to mmv$page_streaming_random_limit random faults.

          ELSEIF NOT stxe_p^.stream.streaming THEN

{terminate prestream mode,  count current fault as first fault

            mmv$paging_statistics.page_streaming.prestream_only :=
                  mmv$paging_statistics.page_streaming.prestream_only + 1;
            stxe_p^.stream.sequential_accesses := 1;

          ELSE {Page fault is in a transfer unit that is considered random, terminate if appropriate
            stxe_p^.stream.random_faults := stxe_p^.stream.random_faults + 1;
            IF stxe_p^.stream.random_faults < mmv$page_streaming_random_limit THEN

{ Doing nothing will suspend streaming for this fault

            ELSE { Terminate Streaming
              mmv$paging_statistics.page_streaming.terminated :=
                    mmv$paging_statistics.page_streaming.terminated + 1;
              stxe_p^.stream.sequential_accesses := 1;
              stxe_p^.stream.random_faults := 0;
              stxe_p^.stream.streaming := FALSE;
            IFEND;
          IFEND;
        IFEND; {prestream mode or stream mode}


{ If this page fault is to be processed via normal page fault processing nominal_page_fault will be TRUE.
{ Otherwise this fault will be processed as a page streaming fault in which one or more transfer units will
{ be read.  If page streaming, the first call to page pull is for the actual page that faulted.  The status
{ from that call must be saved so that the processing at the end can be determined by the page that faulted.
{ All page streaming calls that are reading ahead must not cause the allocation of a new page (we will wait
{ to allocate until the task actually faults for the page) and if an error occurs it is just to terminate
{ this instant of read ahead without being processed as an error (again, if the task actually faults for the
{ page that got an error, the error will be processed at that time)
{ Note that if the earlier call to mmp$page_pull_hash_sva found a page, page_count = 1 and pstatus
{ and pfti refer to that page.

        IF nominal_page_fault THEN
          IF page_count = 0 THEN {call mmp$page_pull if the page was not found by mmp$page_pull_hash_sva
            IF mmc$sa_read_transfer_unit IN stxe_p^.software_attribute_set THEN
              pages_to_read := streaming_transfer_pages;
              IF stxe_p^.stream.sequential_accesses < mmv$page_streaming_prestream THEN
                stxe_p^.stream.sequential_accesses := stxe_p^.stream.sequential_accesses + 1;
              IFEND;
            ELSEIF (ste_p^.ste.xp = osc$non_executable) OR (ste_p^.ste.wp <> osc$non_writable) THEN
              pages_to_read := mmv$read_tu_read_write;
            ELSE
              pages_to_read := mmv$read_tu_execute;
            IFEND;

            IF mmv$trap_page_fault THEN
              IF (pva.pva.seg = 20(16)) AND (pva.pva.offset >= 20200000(16)) THEN
                mtp$step_unstep_system (syc$ic_software_breakpoint, 'MM-TRAP SEG 20 LARGE OFFSET');
              IFEND;
            IFEND;

            mmp$page_pull (sva, fde_p, cst_p, aste_p, stxe_p, io_id, pages_to_read, ioc$read_page, TRUE,
                  page_count, pstatus, pfti);

            IF pstatus = ps_done THEN
              mtp$error_stop ('MM - internal error-ps_done status from MMP$PAGE_PULL');
            IFEND;
          IFEND;

        ELSE {not a nominal page fault... read one or more transfer units
          transfer_unit_count := 1;
          IF stxe_p^.stream.preset_streaming THEN {segment has been preset to stream immediately
            stxe_p^.stream.preset_streaming := FALSE;
            IF NOT stxe_p^.stream.streaming THEN
              mmv$paging_statistics.page_streaming.initiated :=
                    mmv$paging_statistics.page_streaming.initiated + 1;
            IFEND;
            stxe_p^.stream.streaming := TRUE;
            transfer_unit_count := mmv$page_streaming_reads;

          ELSEIF relative_transfer_unit <= 0 THEN

{ Note, more than likely this fault is awaiting the disk completion of the second allocation unit within this
{ transfer unit.  The relative transfer unit would only be negative if this a fault in TU=0 of the file while
{ the file is in page streaming mode.

            IF (sva.offset < last_page_fault) AND (relative_transfer_unit = 0) THEN
              mmv$paging_statistics.page_streaming.page_faults_tu :=
                    mmv$paging_statistics.page_streaming.page_faults_tu + 1;
            IFEND;
          ELSE
            IF stxe_p^.stream.streaming THEN
              IF (relative_transfer_unit <= mmv$page_streaming_reads) THEN
                transfer_unit_count := mmv$page_streaming_reads; {normal streaming, read ahead
              IFEND;
              IF (relative_transfer_unit = mmv$page_streaming_reads) THEN
                mmv$paging_statistics.page_streaming.task_slow :=
                      mmv$paging_statistics.page_streaming.task_slow + 1;
              IFEND;
            ELSE {not yet streaming
              tu_to_stream := (mmv$page_streaming_threshold DIV
                    streaming_transfer_unit) + mmv$page_streaming_prestream;
              IF stxe_p^.stream.sequential_accesses > tu_to_stream THEN {Initiate streaming
                transfer_unit_count := mmv$page_streaming_reads;
                stxe_p^.stream.streaming := TRUE;
                mmv$paging_statistics.page_streaming.initiated :=
                      mmv$paging_statistics.page_streaming.initiated + 1;
              IFEND; {Initiate streaming
            IFEND; { streaming boolean
          IFEND;

{ Prepare to read pages from the current page fault to the end of one or more transfer units.  The counters
{ for the pages are setup so that we can skip to the end of a transfer unit in some case (locked page).
{   pages_to_read -  number of pages to be read from the current transfer unit
{   pages_to_be_pulled - total number of pages in all of the TU being pulled (includes pages before fault)
{   pages_pulled - number of pages already pulled including pages in the faulted TU prior to fault.
{   sva_start - the sva offset of the beginning of the faulted transfer unit

          sva_start := faulted_tu * streaming_transfer_unit;
          sva_current := sva;
          pages_to_read := streaming_transfer_pages - ((sva.offset - sva_start) DIV osv$page_size);
          pages_pulled := streaming_transfer_pages - pages_to_read;
          pages_to_be_pulled := streaming_transfer_pages * transfer_unit_count;

{ The total number of pages that may actually be pulled equals the total number of pages in the TUs under
{ consideration minus the pages before the faulted page (pages_to_be_pulled - pages_pulled).  That total is
{ to be restricted to 25% of the working set.  WARNING: If at some time in the future the page pulls begin
{ at the start of the TU, the check will be more complicated to handle a large TU > 25% of MAXWS

          IF (pages_to_be_pulled - pages_pulled) > (cst_p^.jcb_p^.max_working_set_size DIV 4) THEN
            pages_to_be_pulled := pages_pulled + (cst_p^.jcb_p^.max_working_set_size DIV 4);
            IF pages_to_read > (cst_p^.jcb_p^.max_working_set_size DIV 4) THEN
              pages_to_read := (cst_p^.jcb_p^.max_working_set_size DIV 4);
            IFEND;
          IFEND;

{ Note that page_count and pstatus are still set from the initial call to mmp$page_pull_hash_sva which
{ was done early in pr_pf.  page_count = 1 if the page was found.  The quick exit from /find_the_page/
{ was not taken because the segment was in a stream mode.

          IF page_count = 0 THEN
            mmp$page_pull (sva, fde_p, cst_p, aste_p, stxe_p, io_id, pages_to_read, ioc$read_page, TRUE,
                  page_count, pstatus, pfti);
          IFEND;

          pfti_of_faulted_page := pfti;
          pstatus_of_faulted_page := pstatus;
          page_streaming_available_page := FALSE;

        /exit_and_continue_stream/
          BEGIN

          /pull_pages_page_streaming/
            WHILE TRUE DO
              pages_pulled := pages_pulled + page_count;
              pages_to_read := pages_to_read - page_count; {number of pages left in the current TU
              IF (pstatus <> ps_locked) AND (pstatus <> ps_valid_in_pt) THEN
                IF stxe_p^.stream.streaming THEN
                  mmv$paging_statistics.page_streaming.pages_streaming :=
                        mmv$paging_statistics.page_streaming.pages_streaming + page_count;
                ELSE
                  mmv$paging_statistics.page_streaming.pages_prestream :=
                        mmv$paging_statistics.page_streaming.pages_prestream + page_count;
                IFEND;
              IFEND;

              CASE pstatus OF
              = ps_locked, ps_valid_in_pt = {these pages are not counted, they were counted when initiated
                pages_pulled := pages_pulled + pages_to_read;
                pages_to_read := 0; {skip to the next transfer unit}
              = ps_found_on_disk =
                ijle_p^.statistics.paging_statistics.page_in_count :=
                      ijle_p^.statistics.paging_statistics.page_in_count + page_count;
                cst_p^.xcb_p^.paging_statistics.page_in_count :=
                      cst_p^.xcb_p^.paging_statistics.page_in_count + page_count;
                mmv$paging_statistics.ps_pages.disk := mmv$paging_statistics.ps_pages.disk + page_count;
              = ps_found_in_avail, ps_found_in_avail_modified =
                ijle_p^.statistics.paging_statistics.pages_reclaimed_from_queue :=
                      ijle_p^.statistics.paging_statistics.pages_reclaimed_from_queue + page_count;
                cst_p^.xcb_p^.paging_statistics.pages_reclaimed_from_queue :=
                      cst_p^.xcb_p^.paging_statistics.pages_reclaimed_from_queue + page_count;
                mmv$paging_statistics.ps_pages.reclaim := mmv$paging_statistics.ps_pages.reclaim + page_count;

{ Pages from the available queues probably indicate the file is being referenced again.  It is
{ likely that the next pages are also in one of available queues and therefore the potential
{ performance gain of reading pages ahead is reduced from saving disk accesses to saving only
{ page faults.  Allow up to two pages to come from the available queues and then exit.  Thus
{ if the pages are in the available queues, we will get two pages per page fault when streaming.

                IF page_streaming_available_page THEN
                  EXIT /exit_and_continue_stream/;
                IFEND;
                page_streaming_available_page := TRUE; {indicate one page has been found in available queues
              = ps_new_page_assigned, ps_allocate_required_on_server =
                ijle_p^.statistics.paging_statistics.new_pages_assigned :=
                      ijle_p^.statistics.paging_statistics.new_pages_assigned + page_count;
                cst_p^.xcb_p^.paging_statistics.new_pages_assigned :=
                      cst_p^.xcb_p^.paging_statistics.new_pages_assigned + page_count;
                mmv$paging_statistics.ps_pages.new := mmv$paging_statistics.ps_pages.new + page_count;

{ Allocation of new pages occurs one at a time, terminate page streaming to avoid overhead

                EXIT /pull_pages_page_streaming/; { terminate page streaming
              = ps_found_on_server =
                ijle_p^.statistics.paging_statistics.pages_from_server :=
                      ijle_p^.statistics.paging_statistics.pages_from_server + page_count;
                cst_p^.xcb_p^.paging_statistics.pages_from_server :=
                      cst_p^.xcb_p^.paging_statistics.pages_from_server + page_count;
                mmv$paging_statistics.ps_pages.server := mmv$paging_statistics.ps_pages.server + page_count;
              = ps_done =
                mtp$error_stop ('MM - internal error-ps_done status from MMP$PAGE_PULL');
              ELSE

{ ps_read_beyond_eoi, ps_no_extend_permission, ps_beyond_file_limit
{ ps_server_terminated,  ps_io_temp_reject,  ps_pt_full, ps_volume_unavailable
{ ps_no_memory, ps_low_on_memory, ps_job_work_required, ps_runaway_write

                EXIT /pull_pages_page_streaming/; { terminate page streaming
              CASEND;

              IF pages_pulled >= pages_to_be_pulled THEN
                EXIT /exit_and_continue_stream/;
              IFEND;
              IF pages_to_read <= 0 THEN
                pages_to_read := streaming_transfer_pages;
              IFEND;
              temp_offset := sva_start + pages_pulled * osv$page_size;
              IF (temp_offset > osc$maximum_offset) THEN
                EXIT /pull_pages_page_streaming/; { terminate page streaming
              IFEND;
              sva_current.offset := temp_offset;
              mmp$page_pull_hash_sva (sva_current, aste_p, page_count, pstatus, pfti);
              IF page_count = 0 THEN
                mmp$page_pull (sva_current, fde_p, cst_p, aste_p, stxe_p, io_id, pages_to_read, ioc$read_page,
                      FALSE, page_count, pstatus, pfti);
              IFEND;
            WHILEND /pull_pages_page_streaming/;

{ Terminate page streaming if exit here, usual exit is to skip this code

            stxe_p^.stream.sequential_accesses := 0;
            stxe_p^.stream.random_faults := 0;
            stxe_p^.stream.streaming := FALSE;

          END /exit_and_continue_stream/;

          page_count := 0;
          pstatus := pstatus_of_faulted_page;
          pfti := pfti_of_faulted_page;

        IFEND; {nominal_page_fault}


      END /find_the_page/;

      IF syv$perf_keypoints_enabled.memory_keypoints THEN
        #KEYPOINT (osk$performance, osk$m * pfti, ptk$page_fault_pfti);
        #KEYPOINT (osk$performance, osk$m * $INTEGER (pstatus), ptk$page_fault_status);
        #KEYPOINT (osk$performance, osk$m * (aste_p^.ijl_ordinal.block_number *
              32 + aste_p^.ijl_ordinal.block_index), ptk$page_fault_ijl);
      IFEND;


    IFEND; { aste_p <> NIL


{ We have gotten here in one of four ways in which pstatus may have been set:
{    1. aste_p = NIL  (not likely to happen)
{    2. The page was found by the proc mmp$page_pull_hash_sva and then the quick exit was taken.  At this
{       point this case is exactly the same as a nominal page fault (case 3).
{    3. Nominal page fault (PSTATUS and PAGE_COUNT reflect the call to pull the faulted page)
{    4. Page streaming mode pulled the faulted page and saved PSTATUS.  Additional page pulls may have been
{       performed after the faulted page was pulled.  PSTATUS has been restored to the value returned with
{       the faulted page but PAGE_COUNT = 0 because the page counters were updated by the page streaming code.

    cst_p^.xcb_p^.paging_statistics.page_fault_count := cst_p^.xcb_p^.paging_statistics.page_fault_count + 1;
    ijle_p^.statistics.paging_statistics.page_fault_count :=
          ijle_p^.statistics.paging_statistics.page_fault_count + 1;


    CASE pstatus OF

    = ps_found_in_avail, ps_found_in_avail_modified =
      ijle_p^.statistics.paging_statistics.pages_reclaimed_from_queue :=
            ijle_p^.statistics.paging_statistics.pages_reclaimed_from_queue + page_count;
      cst_p^.xcb_p^.paging_statistics.pages_reclaimed_from_queue :=
            cst_p^.xcb_p^.paging_statistics.pages_reclaimed_from_queue + page_count;
      mmv$paging_statistics.pf_pages.reclaim := mmv$paging_statistics.pf_pages.reclaim + page_count;

    = ps_new_page_assigned =
      ijle_p^.statistics.paging_statistics.new_pages_assigned :=
            ijle_p^.statistics.paging_statistics.new_pages_assigned + page_count;
      cst_p^.xcb_p^.paging_statistics.new_pages_assigned :=
            cst_p^.xcb_p^.paging_statistics.new_pages_assigned + page_count;
      mmv$paging_statistics.pf_pages.new := mmv$paging_statistics.pf_pages.new + page_count;
      stxe_p^.stream.sequential_accesses := 0; { zero count to prevent prestream mode on next PF


{ Since new pages are being allocated, force the transfer unit size to be at least an allocation unit
{ so that if free behind is performed it will go back at least an allocation size to free pages.
{ relative_transfer_unit is not recalculated, it will just cause free behind to be attempted early.

      IF fde_p^.allocation_unit_size > streaming_transfer_unit THEN
        streaming_transfer_unit := fde_p^.allocation_unit_size;
        faulted_tu := sva.offset DIV streaming_transfer_unit;
      IFEND;

    = ps_valid_in_pt, ps_job_work_required =
    = ps_read_beyond_eoi, ps_no_extend_permission =
      monitor_fault.identifier := mmc$segment_fault_processor_id;
      sac_p := #LOC (monitor_fault.contents);
      IF pstatus = ps_read_beyond_eoi THEN
        sac_p^.identifier := mmc$sac_read_beyond_eoi;
      ELSE
        sac_p^.identifier := mmc$sac_no_append_permission;
      IFEND;
      sac_p^.segment := pva.p;
      tmp$send_monitor_fault (cst_p^.taskid, #LOC (monitor_fault), TRUE);

    = ps_beyond_file_limit =
      monitor_fault.identifier := mmc$segment_fault_processor_id;
      sac_p := #LOC (monitor_fault.contents);
      sac_p^.identifier := mmc$sac_read_write_beyond_msl;
      sac_p^.segment := pva.p;
      IF fde_p^.stack_for_ring > 0 THEN
        file_limit := fde_p^.file_limit + 500000;
        IF file_limit > 07fffffff(16) THEN
          file_limit := 7fffffff(16);
        IFEND;
        fde_p^.file_limit := file_limit;
      IFEND;
      tmp$send_monitor_fault (cst_p^.taskid, #LOC (monitor_fault), FALSE);

    = ps_server_terminated =
      monitor_fault.identifier := mmc$segment_fault_processor_id;
      sac_p := #LOC (monitor_fault.contents);
      sac_p^.identifier := mmc$sac_file_server_terminated;
      sac_p^.segment := pva.p;
      tmp$send_monitor_fault (cst_p^.taskid, #LOC (monitor_fault), FALSE);

    = ps_found_on_disk =
      ijle_p^.statistics.paging_statistics.page_in_count :=
            ijle_p^.statistics.paging_statistics.page_in_count + page_count;
      cst_p^.xcb_p^.paging_statistics.page_in_count := cst_p^.xcb_p^.paging_statistics.page_in_count +
            page_count;
      mmv$paging_statistics.pf_pages.disk := mmv$paging_statistics.pf_pages.disk + page_count;

{NOTE
{Job recovery uses active io count to determine the status of a page after a crash ...
{DONT MESS WITH ACTIVE IO COUNT UNLESS YOU UNDERSTAND IT'S USE IN JOB RECOVERY. Thank You.

      IF mmv$pft_p^ [pfti].active_io_count = 0 THEN
        mtp$error_stop ('MM - page fault queue no IO');
      IFEND;
      tmp$queue_task (cst_p^.taskid, tmc$ts_page_wait, mmv$pft_p^ [pfti].task_queue);
      cst_p^.xcb_p^.page_wait_info.pva := pva.p;

    = ps_locked =

{NOTE
{Job recovery uses active io count to determine the status of a page after a crash ...
{DONT MESS WITH ACTIVE IO COUNT UNLESS YOU UNDERSTAND IT'S USE IN JOB RECOVERY. Thank You.

      IF mmv$pft_p^ [pfti].active_io_count = 0 THEN
        mtp$error_stop ('MM - page fault queue no IO');
      IFEND;
      tmp$queue_task (cst_p^.taskid, tmc$ts_page_wait, mmv$pft_p^ [pfti].task_queue);
      cst_p^.xcb_p^.page_wait_info.pva := pva.p;

    = ps_io_temp_reject =
      tmp$cause_task_switch;

    = ps_pt_full =
      cst_p^.dispatch_control.asynchronous_interrupts_pending := TRUE;
      tmp$cause_task_switch;

    = ps_no_memory, ps_low_on_memory =
      tmp$queue_task (cst_p^.taskid, tmc$ts_memory_wait, mmv$memory_wait_queue);

{  Process the case of the page found on the server mainframe.

    = ps_found_on_server =
      ijle_p^.statistics.paging_statistics.pages_from_server :=
            ijle_p^.statistics.paging_statistics.pages_from_server + page_count;
      cst_p^.xcb_p^.paging_statistics.pages_from_server :=
            cst_p^.xcb_p^.paging_statistics.pages_from_server + page_count;
      mmv$paging_statistics.pf_pages.server := mmv$paging_statistics.pf_pages.server + page_count;

{ Check active_io_count to insure activity exists.  No activity is fatal.

      IF mmv$pft_p^ [pfti].active_io_count = 0 THEN
        mtp$error_stop ('MM - page fault queue no IO, ps_found_on_server');
      IFEND;

{ Queue the task in page wait.

      tmp$queue_task (cst_p^.taskid, tmc$ts_page_wait, mmv$pft_p^ [pfti].task_queue);
      cst_p^.xcb_p^.page_wait_info.pva := pva.p;

    = ps_allocate_required_on_server =

      ijle_p^.statistics.paging_statistics.new_pages_assigned :=
            ijle_p^.statistics.paging_statistics.new_pages_assigned + page_count;
      cst_p^.xcb_p^.paging_statistics.new_pages_assigned :=
            cst_p^.xcb_p^.paging_statistics.new_pages_assigned + page_count;
      mmv$paging_statistics.pf_pages.new := mmv$paging_statistics.pf_pages.new + page_count;
      stxe_p^.stream.sequential_accesses := 0; { zero  count to prevent prestream mode on next PF


{ Since new pages are being allocated, force the transfer unit size to be at least an allocation unit
{ so that if free behind is performed it will go back at least an allocation size to free pages.
{ relative_transfer_unit is not recalculated, it will just cause free behind to be attempted early.

      IF fde_p^.allocation_unit_size > streaming_transfer_unit THEN
        streaming_transfer_unit := fde_p^.allocation_unit_size;
        faulted_tu := sva.offset DIV streaming_transfer_unit;
      IFEND;

{ Check active_io_count to insure activity exists.  No activity is fatal.

      IF mmv$pft_p^ [pfti].active_io_count = 0 THEN
        mtp$error_stop ('MM - page fault queue no IO, ps_found_on_server');
      IFEND;

{ Queue the task in page wait.

      tmp$queue_task (cst_p^.taskid, tmc$ts_page_wait, mmv$pft_p^ [pfti].task_queue);
      cst_p^.xcb_p^.page_wait_info.pva := pva.p;

    = ps_volume_unavailable =
      cst_p^.xcb_p^.page_wait_info.pva := pva.p;
      mmp$process_volume_unavailable (cst_p^.xcb_p, FALSE);
    = ps_done =
      mtp$error_stop ('MM - internal error-ps_done status from MMP$PAGE_PULL');

    = ps_runaway_write =
      monitor_fault.identifier := mmc$segment_fault_processor_id;
      sac_p := #LOC (monitor_fault.contents);
        sac_p^.identifier := mmc$sac_runaway_write;
      sac_p^.segment := pva.p;
      tmp$send_monitor_fault (cst_p^.taskid, #LOC (monitor_fault), TRUE);





    CASEND;



{ If appropriate do free behind.  Free pages that are in the transfer units prior to the transfer unit
{ immediately before the current page fault transfer unit.  (i.e.  faulted_tu -2, -3, -4 ... etc.)
{ Stop freeing pages at the first page that is not freed because it is locked or it is not found.
{ Note that if a new page was assigned, a check was made to force transfer size >= allocation size.
{ Since this code looks at the pages in reverse order, the PFTI procs mmp$reset_store_pfti_reverse
{ and mmp$store_pfti_reverse are used so that  mmp$remove_pages_from_jws will free the pages in
{ sva ascending order  ... this is helpful if the pages are modified

    IF (mmc$sa_free_behind IN stxe_p^.software_attribute_set) AND
          (fde_p^.media <> gfc$fm_transient_segment) THEN
      xsva := sva;
      IF ((relative_transfer_unit > 0)) AND (faulted_tu > 1) THEN
        xsva.offset := ((faulted_tu - 1) * streaming_transfer_unit);
        mmp$reset_store_pfti_reverse;

      /free_behind/
        WHILE xsva.offset > 0 DO {since xsva is page boundary, if >0 it will be at least = 1 page.
          xsva.offset := xsva.offset - osv$page_size;
          #HASH_SVA (xsva, ipti, count, found);
          IF NOT found THEN
            EXIT /free_behind/; { Exit if the page was not found
          ELSE
            xpfti := (mmv$pt_p^ [ipti].rma * 512) DIV osv$page_size;
            IF (mmv$pft_p^ [xpfti].queue_id >= mmc$pq_first_valid_in_pt) AND
                  (mmv$pft_p^ [xpfti].locked_page = mmc$lp_not_locked) THEN
              mmp$store_pfti_reverse (xpfti);
            ELSE
              EXIT /free_behind/; {Exit if the page is locked
            IFEND;
          IFEND;
        WHILEND /free_behind/;

        mmp$fetch_pfti_array_size (rcount);
        IF rcount > 0 THEN
          mmp$remove_pages_from_jws (mmc$pq_avail_modified, ijle_p, mcount, rcount);
          mmv$paging_statistics.page_streaming.pages_freed_behind :=
                mmv$paging_statistics.page_streaming.pages_freed_behind + rcount;
        IFEND;
      IFEND; {faulted tu GT 1
    IFEND; {free behind



{Update page fault statistics.

    mmv$pf_statistics [$INTEGER (pstatus)] := mmv$pf_statistics [$INTEGER (pstatus)] + 1;
    i := mmv$pf_sva_array.next_i;
    mmv$pf_sva_array.next_i := (i + 1) MOD num_pf_recs;
    mmv$pf_sva_array.pf_recs [i].sva := sva;
    mmv$pf_sva_array.pf_recs [i].pstatus_time := (#FREE_RUNNING_CLOCK (0) DIV 131072) MOD
          100(16) + $INTEGER (pstatus) * 100(16);


{Scan the JWS if the job cp time exceeds the aging threshold.

    IF mmv$aging_algorithm >= 4 THEN
      cptime := ijle_p^.statistics.cp_time.time_spent_in_job_mode;
    ELSE
      cptime := ijle_p^.statistics.cp_time.time_spent_in_mtr_mode +
            ijle_p^.statistics.cp_time.time_spent_in_job_mode;
    IFEND;
    IF cptime > cst_p^.jcb_p^.cptime_next_age_working_set THEN
      mmp$age_job_working_set (ijle_p, cst_p^.jcb_p);
    IFEND;
    mws := cst_p^.jcb_p^.max_working_set_size;
    mws := mws DIV 16;
    IF mws < 16 THEN
       mws := 16;
    IFEND;


    check_aio_slowdown := (ijle_p^.job_page_queue_list [mmc$pq_job_working_set].count  >
          (cst_p^.jcb_p^.max_working_set_size + mws));

    IF check_aio_slowdown OR (ijle_p^.job_page_queue_list [mmc$pq_job_working_set].count >
          mmv$max_working_set_size) THEN
      mmp$trim_job_working_set (ijle_p, cst_p^.jcb_p, FALSE {trim_to_swap_size=false} );
      IF check_aio_slowdown THEN
        CASE pstatus OF
        = ps_found_in_avail, ps_found_in_avail_modified, ps_new_page_assigned, ps_valid_in_pt =
          IF ijle_p^.active_io_requests > mmv$maxws_aio_threshold THEN
            mmv$maxws_aio_count := mmv$maxws_aio_count + 1;
            cst_p^.xcb_p^.maxws_aio_slowdown := cst_p^.xcb_p^.maxws_aio_slowdown + 1;
            ijle_p^.maxws_aio_slowdown_display := ((mmv$maxws_aio_slowdown DIV
                  mmv$jws_queue_age_interval) + 1) MOD 256;
            tmp$cause_task_switch;
          IFEND;
        ELSE
        CASEND;
      IFEND;
    ELSEIF ijle_p^.active_io_requests >
          jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.attributes.aio_limit
          THEN
      CASE pstatus OF
      = ps_found_in_avail, ps_found_in_avail_modified, ps_new_page_assigned, ps_valid_in_pt =
        tmp$cause_task_switch;
        mmv$aio_limit_count := mmv$aio_limit_count + 1;
      ELSE
      CASEND;
    IFEND;

    IF ijle_p^.statistics.paging_statistics.incremental_max_ws < ijle_p^.
          job_page_queue_list [mmc$pq_job_working_set].count THEN
      ijle_p^.statistics.paging_statistics.incremental_max_ws := ijle_p^.
            job_page_queue_list [mmc$pq_job_working_set].count;
      IF ijle_p^.statistics.paging_statistics.working_set_max_used < ijle_p^.
            job_page_queue_list [mmc$pq_job_working_set].count THEN
        ijle_p^.statistics.paging_statistics.working_set_max_used := ijle_p^.
              job_page_queue_list [mmc$pq_job_working_set].count;
      IFEND;
    IFEND;
    IF cst_p^.xcb_p^.paging_statistics.working_set_max_used < ijle_p^.
          job_page_queue_list [mmc$pq_job_working_set].count THEN
      cst_p^.xcb_p^.paging_statistics.working_set_max_used := ijle_p^.
            job_page_queue_list [mmc$pq_job_working_set].count;
    IFEND;


{Free queue must be replenished if the number of free+avail pages is below the threshold.

    check_free_queues (cst_p);


{Reset UTP in the Exchange Package.

    cst_p^.xcb_p^.xp.untranslatable_pointer := null_utp;

    #KEYPOINT (osk$mtr, $INTEGER (pstatus) * osk$monitor_multiplier, mmk$page_fault + osk$m);

  PROCEND pr_pf;

?? TITLE := 'MMP$PROCESS_ASSIGN_PAGES_REQ', EJECT ??

  PROCEDURE [XDCL] mmp$process_assign_pages_req
    (VAR rb: mmt$rb_assign_pages;
         cst_p: ^ost$cpu_state_table);

    CASE rb.sub_reqcode OF
    = mmc$aprc_assign =
      mmp$process_assign_pages (rb, cst_p);

    = mmc$aprc_cancel_reserve =
      mmp$process_cancel_reserve (rb, cst_p);

    ELSE
      mtp$error_stop ('MM--ASSIGN PAGES--UNKNOWN REQUEST');
    CASEND;

  PROCEND mmp$process_assign_pages_req;

?? TITLE := 'MMP$PROCESS_ASSIGN_PAGES', EJECT ??

  PROCEDURE mmp$process_assign_pages
    (VAR rb: mmt$rb_assign_pages;
         cst_p: ^ost$cpu_state_table);

    CONST
      mmc$ap_ignore_maxws_and_trim = 131072;

    VAR
      assigned_pages_count: mmt$page_frame_index,
      aste_p: ^mmt$active_segment_table_entry,
      count: 1 .. 32,
      fde_p: gft$locked_file_desc_entry_p,
      first_pfti: mmt$page_frame_index,
      found: boolean,
      i: integer,
      ijle_p: ^jmt$initiated_job_list_entry,
      ipti: integer,
      memory_available: boolean,
      next_pfti: mmt$page_frame_index,
      page_status: gft$page_status,
      pfte_p: ^mmt$page_frame_table_entry,
      pfti: mmt$page_frame_index,
      pstatus: mmt$page_pull_status,
      psva: ost$system_virtual_address,
      pte_p: ^ost$page_table_entry,
      reject_offset: ost$segment_offset,
      requested_page_count: mmt$page_frame_index,
      remaining_pages_to_assign: mmt$page_frame_index,
      ste_p: ^mmt$segment_descriptor,
      stxe_p: ^mmt$segment_descriptor_extended,
      sva: ost$system_virtual_address,
      trim_pages: boolean,
      xsva: ost$system_virtual_address,
      valid_pages_in_memory: mmt$page_frame_index,
      pages_not_in_memory: mmt$page_frame_index,
      am_pages_in_memory: mmt$page_frame_index,
      avail_pages_in_memory: mmt$page_frame_index;

    rb.status.normal := TRUE;

    IF NOT mmv$tables_initialized THEN
      RETURN;
    IFEND;

    mmp$verify_pva (^rb.pva, mmc$sat_write, rb.status);
    IF NOT rb.status.normal THEN
      RETURN;
    IFEND;

    mmp$convert_pva (rb.pva, cst_p, sva, fde_p, aste_p, ste_p, stxe_p);
    IF stxe_p^.access_state <> mmc$sas_allow_access THEN
      IF stxe_p^.access_state = mmc$sas_inhibit_access THEN
        mtp$set_status_abnormal ('MM', mme$volume_unavailable, rb.status);
        RETURN;
      ELSEIF stxe_p^.access_state = mmc$sas_terminate_access THEN
        mtp$set_status_abnormal ('DF', dfe$server_has_terminated, rb.status);
        RETURN;
      IFEND;
    IFEND;

    IF aste_p = NIL THEN
      mtp$set_status_abnormal ('MM', mme$invalid_pva, rb.status);
      RETURN;
    IFEND;

    requested_page_count := (#OFFSET (rb.pva) + rb.length - 1) DIV osv$page_size -
          (#OFFSET (rb.pva) DIV osv$page_size) + 1;

    IF (sva.offset + requested_page_count * osv$page_size) > fde_p^.file_limit THEN
      mtp$set_status_abnormal ('MM', mme$assign_length_too_long, rb.status);
      RETURN;
    IFEND;

    IF (aste_p^.queue_id = mmc$pq_wired) OR (aste_p^.queue_id = mmc$pq_job_fixed) THEN
      mtp$set_status_abnormal ('MM', mme$wired_or_fixed_segs_illegal, rb.status);
      RETURN;
    IFEND;

{ Round off the sva to a page boundary.

    sva.offset := (sva.offset DIV osv$page_size) * osv$page_size;
    xsva := sva;

    CASE fde_p^.media OF
    = gfc$fm_transient_segment =
      IF (aste_p^.pages_in_memory + requested_page_count > mmv$max_pages_no_file) THEN
        page_status := gfc$ps_job_mode_work_required;
        reject_offset := sva.offset + (requested_page_count * osv$page_size);
      ELSE
        page_status := gfc$ps_page_doesnt_exist;
      IFEND;
    = gfc$fm_mass_storage_file =
      mmv$last_segment_accessed := #SEGMENT (rb.pva);
      dmp$fetch_multi_page_status (fde_p, sva.offset, requested_page_count * osv$page_size,
            stxe_p^.file_limits_enforced, reject_offset, page_status);
    = gfc$fm_served_file =
      dfp$fetch_multi_page_status (fde_p, sva.offset, requested_page_count * osv$page_size, page_status);
      reject_offset := sva.offset + (requested_page_count - 1) * osv$page_size;
    CASEND;


    CASE page_status OF
    = gfc$ps_page_on_disk, gfc$ps_page_on_server, gfc$ps_page_doesnt_exist =

{ These are ok; do nothing

    = gfc$ps_temp_reject, gfc$ps_account_limit_exceeded =
      mtp$set_status_abnormal ('MM', mme$temporary_reject, rb.status);
      tmp$cause_task_switch;
      RETURN;

    = gfc$ps_volume_unavailable =
      mtp$set_status_abnormal ('MM', mme$volume_unavailable, rb.status);
      RETURN;

    = gfc$ps_server_terminated =
      mtp$set_status_abnormal ('DF', dfe$server_has_terminated, rb.status);
      RETURN;

    = gfc$ps_server_allocate_required, gfc$ps_job_mode_work_required =
      set_assign_active (stxe_p, reject_offset);
      mmp$update_eoi (fde_p, reject_offset, mmc$uer_page_assigned);
      tmp$set_monitor_flag (cst_p^.taskid, mmc$mf_segment_mgr_flag, rb.status);
      mtp$set_status_abnormal ('MM', mme$dm_assign_active, rb.status);
      RETURN;

    ELSE
      mtp$error_stop ('mm - unexpected DM error in assign pages');
    CASEND;


{ Calculate how many pages are needed; some may already be in the jws.

    valid_pages_in_memory := 0;
    pages_not_in_memory := 0;
    am_pages_in_memory := 0;
    avail_pages_in_memory := 0;

    FOR i := 1 TO requested_page_count DO
      #HASH_SVA (xsva, ipti, count, found);
      IF found THEN
        pte_p := ^mmv$pt_p^ [ipti];
        IF pte_p^.v THEN
          valid_pages_in_memory := valid_pages_in_memory + 1;
        ELSE
          pfti := pte_p^.rma * 512 DIV osv$page_size;
          pfte_p := ^mmv$pft_p^ [pfti];
          IF pfte_p^.queue_id = mmc$pq_avail THEN
            avail_pages_in_memory := avail_pages_in_memory + 1;
          ELSE
            am_pages_in_memory := am_pages_in_memory + 1;
          IFEND;
        IFEND;
      ELSE
        pages_not_in_memory := pages_not_in_memory + 1;
      IFEND;
      xsva.offset := xsva.offset + osv$page_size;
    FOREND;

    ijle_p := cst_p^.ijle_p;

{ Determine if the limit on the job's working set will allow the addition of the new pages
{ to be assigned (if pages go in the working set), and if there is memory available to assign.


    IF aste_p^.queue_id = mmc$pq_job_working_set THEN
      trim_pages := FALSE;
      IF rb.length <= mmc$ap_ignore_maxws_and_trim THEN
        trim_pages := TRUE;
      ELSEIF (((pages_not_in_memory + avail_pages_in_memory + am_pages_in_memory) +
            ijle_p^.job_page_queue_list [mmc$pq_job_working_set].count) >
            cst_p^.jcb_p^.max_working_set_size) OR ((pages_not_in_memory + ijle_p^.
            job_page_queue_list [mmc$pq_job_working_set].count) > mmv$max_working_set_size) THEN
        mtp$set_status_abnormal ('MM', mme$assign_length_too_long, rb.status);
        RETURN;
      IFEND;
    IFEND;

{ Pages that are reassignable NOW (free + available) will be decremented by new pages assigned
{ (pages_not_in_memory) and available pages reassigned (avail_pages_in_memory).  Make sure
{ assigning that many pages for this job will not drive memory too low.

    memory_available := ((mmv$gpql [mmc$pq_free].pqle.count + mmv$gpql [mmc$pq_avail].pqle.count +
          ijle_p^.memory_reserve_request.reserved_page_count - mmv$reserved_page_count - pages_not_in_memory -
          avail_pages_in_memory) > mmv$aggressive_aging_level_2);

    IF memory_available THEN

{ Any pages in the requested range that are already in memory need to be marked as valid
{ and used; pages that are not in memory need to be assigned.  If specified, preset pages.

      xsva := sva;
      WHILE requested_page_count > 0 DO
        #HASH_SVA (xsva, ipti, count, found);
        IF found THEN
          pte_p := ^mmv$pt_p^ [ipti];
          IF NOT pte_p^.v THEN
            pfti := (pte_p^.rma * 512) DIV osv$page_size;
            pfte_p := ^mmv$pft_p^ [pfti];

            IF (pfte_p^.locked_page = mmc$lp_page_in_lock) OR
               (pfte_p^.locked_page = mmc$lp_write_protected_lock) OR
               (pfte_p^.locked_page = mmc$lp_server_allocate_lock) THEN
              IF (pfte_p^.active_io_count = 0) THEN
                mtp$error_stop ('MM - assign pages - queue no IO');
              IFEND;
              tmp$queue_task (cst_p^.taskid, tmc$ts_page_wait, pfte_p^.task_queue);
              tmp$reissue_monitor_request;
              RETURN;
            IFEND;

            IF aste_p^.queue_id >= mmc$pq_job_base THEN
              pfte_p^.ijl_ordinal := cst_p^.ijl_ordinal;
            ELSE
              pfte_p^.ijl_ordinal := jmv$system_ijl_ordinal;
            IFEND;
            mmp$relink_page_frame (pfti, aste_p^.queue_id);
          ELSEIF rb.preset_pages THEN

{ Valid pages cannnot be preset; clear the valid bit, preset the page, and reset the valid bit.

            pte_p^.v := FALSE;
          IFEND;
          IF rb.preset_pages THEN
            mmp$preset_real_memory (xsva, fde_p^.preset_value);
            pte_p^.m := TRUE;
          IFEND;
          pte_p^.u := TRUE;
          pte_p^.v := TRUE;
          requested_page_count := requested_page_count - 1;
          xsva.offset := xsva.offset + osv$page_size;
        ELSE

{ The page is not already in memory; assign a new page to memory.  MMP$ASSIGN_PAGE_FRAME
{ will start at the sva passed to it and assign pages until the requested count is reached or
{ until one of the pages in the requested range is found already in memory.  The procedure
{ returns the number of pages that were assigned.  "Request" the lesser of remaining_pages_to_assign
{ and reassignable.now from mmp$assign_page_frame.  This is done so that assign_page_frame will not
{ reject for no_memory.  Checks were made above to be sure that there is enough memory for the request.
{ The number of new pages that needs to be assigned can change if make_pt_entry is freeing some of the
{ pages in the total requested range to prevent a page table full condition, so pages_not_in_memory
{ cannot be used as the number to assign.  The total requested_page_count can include pages that are
{ already in the working set (they do not need to be assigned), so requested_page_count cannot be
{ passed to mmp$assign_page_frame.  (If there are pages already in the job working set, requested_page_
{ count is too large and may cause a no_memory reject.)

          IF requested_page_count > mmv$reassignable_page_frames.now THEN
            remaining_pages_to_assign := mmv$reassignable_page_frames.now;
          ELSE
            remaining_pages_to_assign := requested_page_count;
          IFEND;

          mmp$assign_page_frame (xsva, aste_p, remaining_pages_to_assign, 0, assigned_pages_count, first_pfti,
                pstatus);

          IF assigned_pages_count > 0 THEN
            next_pfti := first_pfti;
            psva := xsva;
            WHILE next_pfti <> 0 DO

{ Preset pages if necessary; presetting can only be done one page at a time.  If the caller specified
{ preset, then mark the page modified so that it will be writen to disk if it ages out of the working
{ set.  Then if it is referenced the user will get the preset page.  If the preset is being done for
{ security on the assignment of new pages to memory (to prevent a user from being able to see what had
{ previously been on the page), then the modified bit does not need to be set.  If the page ages out
{ of memory, it will not be written to disk.  NOTE:  Some pages may have been assigned even if a
{ page table full condition was encountered.

              IF (rb.preset_pages) OR (ste_p^.ste.r2 > 3) OR (fde_p^.stack_for_ring > 3) THEN
                mmp$preset_real_memory (psva, fde_p^.preset_value);
                IF rb.preset_pages THEN
                  mmv$pt_p^ [mmv$pft_p^ [next_pfti].pti].m := TRUE;
                IFEND;
                psva.offset := psva.offset + osv$page_size;
              IFEND;

              mmv$pt_p^ [mmv$pft_p^ [next_pfti].pti].v := TRUE;
              next_pfti := mmv$pft_p^ [next_pfti].link.bkw;
            WHILEND;
            requested_page_count := requested_page_count - assigned_pages_count;
          IFEND;

          IF pstatus = ps_no_memory THEN
            mtp$error_stop ('MM - NO MEMORY IN ASSIGN PAGES');
          ELSEIF pstatus = ps_pt_full THEN
            mtp$set_status_abnormal ('MM', mme$page_table_full, rb.status);
            RETURN;
          IFEND;

          xsva.offset := xsva.offset + (assigned_pages_count * osv$page_size);
        IFEND;
      WHILEND;
    ELSEIF ijle_p^.statistics.tasks_not_in_long_wait = 1 THEN

{ Memory is not available and no other tasks are ready, so cause the job to swap out.
{ Free the pages the job already has and request the total the job wants.  The requested
{ memory will be 'reserved' for the job when it swaps back in.

      mmp$initialize_find_next_pfti (sva, rb.length, exclude_partial_pages, psc_nominal_queue, aste_p, pfti);

      WHILE pfti <> 0 DO
        mmv$pt_p^ [mmv$pft_p^ [pfti].pti].v := FALSE;
        mmp$delete_pt_entry (pfti, TRUE);
        mmp$relink_page_frame (pfti, mmc$pq_free);
        mmp$find_next_pfti (pfti);
      WHILEND;
      mmp$sva_purge_all_page_map (sva);

      mtp$set_status_abnormal ('MM', mme$memory_not_avail_for_assign, rb.status);
      IF rb.waitopt = osc$wait THEN
        IF ijle_p^.entry_status <> jmc$ies_job_in_memory_non_swap THEN
          ijle_p^.memory_reserve_request.requested_page_count := requested_page_count;
          ijle_p^.memory_reserve_request.swapout_job := TRUE;
          jmp$set_scheduler_event (jmc$swap_job_for_memory_reserve);
          cst_p^.dispatch_control.call_dispatcher := TRUE;
        ELSE
          mtp$set_status_abnormal ('MM', mme$cannot_wait_for_memory, rb.status);
        IFEND;
      IFEND;
    ELSE

{ Memory is not available but other tasks are ready; set status so that this task will do
{ a short wait before reissuing the assign_pages request.  This will let the other tasks go
{ idle before causing the job to swap out until memory can be found to honor the assign request.

      mtp$set_status_abnormal ('MM', mme$wait_so_other_tasks_can_run, rb.status);
    IFEND;

{ If the job had been forced to swap out and wait for memory to be reserved for it, adjust
{ the reserved counts now.

    IF ijle_p^.memory_reserve_request.reserved_page_count > 0 THEN
      mmv$reserved_page_count := mmv$reserved_page_count - ijle_p^.memory_reserve_request.reserved_page_count;
      ijle_p^.memory_reserve_request.reserved_page_count := 0;
    IFEND;

  PROCEND mmp$process_assign_pages;

?? TITLE := 'MMP$PROCESS_CANCEL_RESERVE', EJECT ??

  PROCEDURE mmp$process_cancel_reserve
    (    rb: mmt$rb_assign_pages;
         cst_p: ^ost$cpu_state_table);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry;


    ijle_p := cst_p^.ijle_p;

    ijle_p^.memory_reserve_request.swapout_job := FALSE;
    ijle_p^.memory_reserve_request.requested_page_count := 0;
    mmv$reserved_page_count := mmv$reserved_page_count - ijle_p^.memory_reserve_request.reserved_page_count;
    ijle_p^.memory_reserve_request.reserved_page_count := 0;

  PROCEND mmp$process_cancel_reserve;

?? TITLE := 'MMP$PROCESS_MOVE_PAGES_REQUEST', EJECT ??

{ The purpose of this monitor request is to move a page frame from one PVA to another.
{ When the request completes, all pages in the range from <pva_source> to <pva_source>+
{ <length-1> will have been moved to the range of addresses specified by <pva_destination>
{ to <pva_destination>+<length-1>.
{
{ CAUTION:  Be sure to fully understand how the 'move' is accomplished before changing this
{           procedure.  Because mmp$delete_pt_entry USES information and mmp$make_pt_entry
{           CHANGES information in the page frame table entry, it is necessary to 'move' the
{           page in the following order:
{             1.  Delete the source page table entry.
{             2.  Change the page frame table entry to reflect destination page information.
{             3.  Make the page table entry for the destination page.
{             4.  If necessary, relink the page frame to the queue for the destination segment.
{             5.  Set the valid bit on the destination page.

  PROCEDURE [XDCL] mmp$process_move_pages_request
    (VAR rb: mmt$rb_move_pages;
         cst_p: ^ost$cpu_state_table);

    VAR
      count: 1 .. 32,
      destination_aste_p: ^mmt$active_segment_table_entry,
      destination_fde_p: gft$locked_file_desc_entry_p,
      destination_pfti: mmt$page_frame_index,
      destination_pti: integer,
      destination_ste_p: ^mmt$segment_descriptor,
      destination_stxe_p: ^mmt$segment_descriptor_extended,
      destination_sva: ost$system_virtual_address,
      found: boolean,
      i: integer,
      job_ijle_p: ^jmt$initiated_job_list_entry,
      mpt_status: mmt$make_pt_entry_status,
      modified: boolean,
      number_of_pages_to_move: mmt$move_pages_page_count,
      page_status: gft$page_status,
      pfte_p: ^mmt$page_frame_table_entry,
      pfti: mmt$page_frame_index,
      pte_p: ^ost$page_table_entry,
      reject_offset: ost$segment_offset,
      source_aste_p: ^mmt$active_segment_table_entry,
      source_fde_p: gft$locked_file_desc_entry_p,
      source_pti: integer,
      source_ste_p: ^mmt$segment_descriptor,
      source_stxe_p: ^mmt$segment_descriptor_extended,
      source_sva: ost$system_virtual_address,
      status: syt$monitor_status,
      sva_of_last_page: ost$system_virtual_address,
      system_ijle_p: ^jmt$initiated_job_list_entry;


    rb.status.normal := TRUE;

    mmp$verify_pva (^rb.pva_source, mmc$sat_read_or_write, rb.status);
    IF NOT rb.status.normal THEN
      RETURN;
    IFEND;

    mmp$convert_pva (rb.pva_source, cst_p, source_sva, source_fde_p, source_aste_p, source_ste_p,
          source_stxe_p);
    IF source_aste_p = NIL THEN
      mtp$set_status_abnormal ('MM', mme$invalid_pva, rb.status);
      RETURN;
    IFEND;

    mmp$verify_pva (^rb.pva_destination, mmc$sat_write, rb.status);
    IF NOT rb.status.normal THEN
      RETURN;
    IFEND;

    mmp$convert_pva (rb.pva_destination, cst_p, destination_sva, destination_fde_p, destination_aste_p,
          destination_ste_p, destination_stxe_p);
    IF destination_aste_p = NIL THEN
      mtp$set_status_abnormal ('MM', mme$invalid_pva, rb.status);
      RETURN;
    IFEND;

    IF (rb.length <= 0) OR (rb.length > mmc$move_pages_max_req_length) THEN
      mtp$set_status_abnormal ('MM', mme$invalid_length_requested, rb.status);
      RETURN;
    IFEND;

    IF (rb.length MOD osv$page_size <> 0) THEN
      mtp$set_status_abnormal ('MM', mme$length_not_page_size_mult, rb.status);
      RETURN;
    IFEND;

    IF (source_sva.offset MOD osv$page_size <> 0) OR (destination_sva.offset MOD osv$page_size <> 0) THEN
      mtp$set_status_abnormal ('MM', mme$pva_not_on_page_boundary, rb.status);
      RETURN;
    IFEND;

    IF (source_sva.offset + rb.length > osc$max_segment_length) OR
          (destination_sva.offset + rb.length > osc$max_segment_length) THEN
      mtp$set_status_abnormal ('MM', mme$invalid_pva_formed, rb.status);
      RETURN;
    IFEND;

    jmp$get_ijle_p (cst_p^.ijl_ordinal, job_ijle_p);
    jmp$get_ijle_p (jmv$system_ijl_ordinal, system_ijle_p);

    rb.moved_modified_page_count := 0;
    rb.number_of_pages_moved := 0;

    number_of_pages_to_move := rb.length DIV osv$page_size;

    sva_of_last_page.offset := destination_sva.offset + rb.length;

    IF (destination_sva.offset + number_of_pages_to_move * osv$page_size) > destination_fde_p^.file_limit THEN
      mtp$set_status_abnormal ('MM', mme$read_write_beyond_msl, rb.status);
      RETURN;
    IFEND;

    IF (destination_aste_p^.queue_id = mmc$pq_wired) OR (destination_aste_p^.queue_id = mmc$pq_job_fixed) THEN
      mtp$set_status_abnormal ('MM', mme$wired_or_fixed_segs_illegal, rb.status);
      RETURN;
    IFEND;

    CASE destination_fde_p^.media OF
    = gfc$fm_transient_segment =
      IF (destination_aste_p^.pages_in_memory + number_of_pages_to_move > mmv$max_pages_no_file) THEN
        page_status := gfc$ps_job_mode_work_required;
        reject_offset := destination_sva.offset + (number_of_pages_to_move * osv$page_size);
      ELSE
        page_status := gfc$ps_page_doesnt_exist;
      IFEND;
    = gfc$fm_mass_storage_file =
      mmv$last_segment_accessed := #SEGMENT (rb.pva_destination);
      dmp$fetch_multi_page_status (destination_fde_p, destination_sva.offset,
            number_of_pages_to_move * osv$page_size, destination_stxe_p^.file_limits_enforced,
            reject_offset, page_status);
    = gfc$fm_served_file =
      dfp$fetch_multi_page_status (destination_fde_p, destination_sva.offset,
            number_of_pages_to_move * osv$page_size, page_status);
      reject_offset := destination_sva.offset + (number_of_pages_to_move - 1) * osv$page_size;
    CASEND;


    CASE page_status OF
    = gfc$ps_page_on_disk, gfc$ps_page_on_server, gfc$ps_page_doesnt_exist =

{ These are ok; do nothing

    = gfc$ps_temp_reject, gfc$ps_account_limit_exceeded =
      mtp$set_status_abnormal ('MM', mme$temporary_reject, rb.status);
      tmp$cause_task_switch;
      RETURN;

    = gfc$ps_volume_unavailable =
      mtp$set_status_abnormal ('MM', mme$volume_unavailable, rb.status);
      RETURN;

    = gfc$ps_server_terminated =
      mtp$set_status_abnormal ('DF', dfe$server_has_terminated, rb.status);
      RETURN;

    = gfc$ps_server_allocate_required, gfc$ps_job_mode_work_required =
      set_assign_active (destination_stxe_p, reject_offset);
      mmp$update_eoi (destination_fde_p, reject_offset, mmc$uer_page_assigned);
      tmp$set_monitor_flag (cst_p^.taskid, mmc$mf_segment_mgr_flag, rb.status);
      mtp$set_status_abnormal ('MM', mme$dm_assign_active, rb.status);
      RETURN;

    ELSE
      mtp$error_stop ('mm - unexpected DM error in assign pages');
    CASEND;


  /move_page/

    FOR i := 1 TO number_of_pages_to_move DO
      #HASH_SVA (source_sva, source_pti, count, found);
      IF NOT found THEN
        mtp$set_status_abnormal ('MM', mme$source_page_not_in_memory, rb.status);
        RETURN;
      IFEND;

      pte_p := ^mmv$pt_p^ [source_pti];
      pfti := (pte_p^.rma * 512) DIV osv$page_size;
      pfte_p := ^mmv$pft_p^ [pfti];

      IF ((pfte_p^.active_io_count > 0) AND (pfte_p^.locked_page <> mmc$lp_page_in_lock)) THEN
        mtp$set_status_abnormal ('MM', mme$io_active_on_move_page, rb.status);
        RETURN;

      ELSEIF (pte_p^.m) THEN
        IF (rb.reject_move_if_source_modified) THEN
          mtp$set_status_abnormal ('MM', mme$modified_source_page_reject, rb.status);
          RETURN;
        ELSE
          rb.moved_modified_page_count := rb.moved_modified_page_count + 1;
        IFEND;
      IFEND;

{ Determine the value for modified_bit_option here; if no_change, the status of the modified bit
{ on the source page must be captured before the page table entry is deleted.

      IF rb.modified_bit_option = mmc$mp_set_modified THEN
        modified := TRUE;
      ELSEIF rb.modified_bit_option = mmc$mp_clear_modified THEN
        modified := FALSE;
      ELSE
        modified := pte_p^.m;
      IFEND;

{ Delete the source page

      mmp$delete_pt_entry (pfti, TRUE);

{ The destination page should not be in the page table; if it is, delete it.

      #HASH_SVA (destination_sva, destination_pti, count, found);
      IF found THEN
        destination_pfti := (mmv$pt_p^ [destination_pti].rma * 512) DIV osv$page_size;
        mmp$delete_pt_entry (destination_pfti, TRUE);
        mmp$relink_page_frame (destination_pfti, mmc$pq_free);
      IFEND;

{ Change the page frame table entry to the destination page information.

      pfte_p^.aste_p := destination_aste_p;
      pfte_p^.sva := destination_sva;

{ Make the page table entry for the destination page.  If the page table is full, restore the source page
{ (that cannot fail) and return.  Job mode will reissue the request, starting after the last page that
{ was moved.
{ NOTE:  make_pt_entry sets the USED bit and stores the ASID and RMA in the page table entry; it
{        also stores the PTI in the page frame table entry and increments the PAGES_IN_MEMORY count
{        in the active segment table entry.  Make_pt_entry does NOT set the valid bit in the
{        page table entry.


      mmp$make_pt_entry (destination_sva, pfti, destination_aste_p, pfte_p, mpt_status);
      IF mpt_status = mmc$mpt_page_table_full THEN
        mmv$async_work.pt_full_aste_p := destination_aste_p;
        mmv$async_work.pt_full_sva := destination_sva;
        mmv$async_work.pt_full := TRUE;
        mmv$time_to_call_mem_mgr := 0;
        osv$time_to_check_asyn := 0;
        pfte_p^.aste_p := source_aste_p;
        pfte_p^.sva := source_sva;
        mmp$make_pt_entry (source_sva, pfti, source_aste_p, pfte_p, mpt_status);
        IF mpt_status <> mmc$mpt_done THEN
          mtp$error_stop ('MOVE_PAGES -- COULD NOT REMAKE PAGE TABLE ENTRY');
        IFEND;
        mmv$pt_p^ [pfte_p^.pti].v := TRUE;
        mtp$set_status_abnormal ('MM', mme$page_table_full, rb.status);
        RETURN;
      IFEND;

{ Store the correct ijl ordinal in the page frame table entry.  If the queue the source
{ page was in is not the same as the queue for the destination segment, relink the page.
{ If the page is going from the shared queue to a job working set, the pft.ijl_ordinal
{ must be changed and then the page relinked.  If the page is going from a job working
{ set to the shared queue, the page must be relinked and then the pft.ijl_ordinal
{ changed.  Adjust active_io_counts if the page changes queues.

      IF destination_aste_p^.queue_id >= mmc$pq_job_base THEN
        IF pfte_p^.queue_id >= mmc$pq_job_base THEN { MUST be the same JWS }
          IF pfte_p^.ijl_ordinal <> destination_aste_p^.ijl_ordinal THEN
            mtp$error_stop ('MM - MOVE PAGES - jws to jws move');
          IFEND;
        ELSE { shared queue to job working set }
          pfte_p^.ijl_ordinal := cst_p^.ijl_ordinal;
          mmp$relink_page_frame (pfti, destination_aste_p^.queue_id);
          job_ijle_p^.inhibit_swap_count := job_ijle_p^.inhibit_swap_count + pfte_p^.active_io_count;
          job_ijle_p^.active_io_page_count := job_ijle_p^.active_io_page_count + pfte_p^.active_io_count;
          system_ijle_p^.active_io_page_count := system_ijle_p^.active_io_page_count -
                pfte_p^.active_io_count;
        IFEND;
      ELSE { destination is the shared queue }
        IF pfte_p^.queue_id >= mmc$pq_job_base THEN { job working set to shared queue }
          mmp$relink_page_frame (pfti, destination_aste_p^.queue_id);
          pfte_p^.ijl_ordinal := jmv$system_ijl_ordinal;
          job_ijle_p^.inhibit_swap_count := job_ijle_p^.inhibit_swap_count - pfte_p^.active_io_count;
          job_ijle_p^.active_io_page_count := job_ijle_p^.active_io_page_count - pfte_p^.active_io_count;
          system_ijle_p^.active_io_page_count := system_ijle_p^.active_io_page_count +
                pfte_p^.active_io_count;
        IFEND;
      IFEND;

      mmv$pt_p^ [pfte_p^.pti].v := TRUE;
      mmv$pt_p^ [pfte_p^.pti].m := modified;

      rb.number_of_pages_moved := rb.number_of_pages_moved + 1;

      IF (rb.number_of_pages_moved < number_of_pages_to_move) THEN
        source_sva.offset := source_sva.offset + osv$page_size;
        destination_sva.offset := destination_sva.offset + osv$page_size;
      IFEND;

    FOREND /move_page/;

    IF mmv$multiple_caches OR mmv$multiple_page_maps THEN
      mmp$purge_all_cache_map_proc;
    ELSE
      mmp$sva_purge_all_cache (destination_sva);
      mmp$purge_all_map_proc;
    IFEND;

  PROCEND mmp$process_move_pages_request;


?? TITLE := 'MMP$PROCESS_ASSIGN_CONTIG_MEM' ??
?? EJECT ??

  PROCEDURE [XDCL] mmp$process_assign_contig_mem
    (VAR rb: mmt$rb_assign_contig_memory;
         cst_p: ^ost$cpu_state_table);

    VAR
      assign_contiguous: boolean,
      assigned_pages: mmt$page_frame_index,
      aste_p: ^mmt$active_segment_table_entry,
      count: 1 .. 32,
      fde_p: gft$locked_file_desc_entry_p,
      first_pfti: mmt$page_frame_index,
      found: boolean,
      ijl_p: ^jmt$initiated_job_list_entry,
      index: integer,
      inhibit_io: boolean,
      io_id: mmt$io_identifier,
      ipti: integer,
      mcount: integer,
      pages_requested: 0 .. 0ffff(16),
      pfti: integer,
      pstatus: mmt$page_pull_status,
      qcb_p: ^mmt$page_queue_list_entry,
      rcount: integer,
      save_pfti: integer,
      starting_pfti: integer,
      ste_p: ^mmt$segment_descriptor,
      stxe_p: ^mmt$segment_descriptor_extended,
      sva: ost$system_virtual_address,
      test_sva: ost$system_virtual_address,
      write_status: mmt$write_page_to_disk_status;

    rb.status.normal := TRUE;
    mmp$verify_pva (^rb.process_virtual_address, mmc$sat_write, rb.status);
    IF NOT rb.status.normal THEN
      RETURN;
    IFEND;

    mmp$convert_pva (rb.process_virtual_address, cst_p, sva, fde_p, aste_p, ste_p, stxe_p);
    pages_requested := (#OFFSET (rb.process_virtual_address) + rb.requested_length - 1) DIV
          osv$page_size - (#OFFSET (rb.process_virtual_address) DIV osv$page_size) + 1;
    test_sva.asid := sva.asid;
    test_sva.offset := ((sva.offset DIV osv$page_size) * osv$page_size);

{Verify that none of the pages are currently assigned.

    FOR index := 1 TO pages_requested DO
      #HASH_SVA (test_sva, ipti, count, found);
      IF found THEN
        mtp$set_status_abnormal ('MM', mme$pages_already_assigned, rb.status);
        RETURN;
      IFEND;
      test_sva.offset := test_sva.offset + osv$page_size;
    FOREND;


    CASE rb.pass_count OF
    = mmc$scan_pft_for_free_or_avail, mmc$scan_pft_free_avail_notmod =
      IF rb.pass_count = mmc$scan_pft_for_free_or_avail THEN
        mmv$assign_contiguous_pass_cnt.pass_one_count := mmv$assign_contiguous_pass_cnt.pass_one_count + 1;
      ELSE
        mmv$assign_contiguous_pass_cnt.pass_two_count := mmv$assign_contiguous_pass_cnt.pass_two_count + 1;
      IFEND;
      starting_pfti := 0;
      scan_pft_for_pages (rb.pass_count, pages_requested, starting_pfti);

      IF (starting_pfti = 0) THEN
        mtp$set_status_abnormal ('MM', mme$unable_to_assign_contig_mem, rb.status);
        RETURN;
      ELSEIF rb.pass_count = mmc$scan_pft_free_avail_notmod THEN

{ We have successfully found the requested pages. A second scan
{ of these pages is required, if a page is still usable, we go
{ ahead and remove it from the job working set.

      /loop/
        WHILE starting_pfti <> 0 DO
          pfti := starting_pfti;
          assign_contiguous := TRUE;

        /verify_pages_removable/
          FOR index := 1 TO pages_requested DO
            IF (mmv$pft_p^ [pfti].queue_id = mmc$pq_avail) OR
                  ((mmv$pft_p^ [pfti].queue_id = mmc$pq_free) AND (mmv$pft_p^ [pfti].active_io_count = 0))
                  THEN
              pfti := pfti + 1;
              CYCLE /verify_pages_removable/;
            ELSE
              IF ((mmv$pft_p^ [pfti].queue_id >= mmc$pq_shared_first) AND
                    (mmv$pft_p^ [pfti].queue_id <= mmc$pq_shared_last)) OR
                    (mmv$pft_p^ [pfti].queue_id = mmc$pq_job_working_set) THEN
                IF mmv$pft_p^ [pfti].locked_page = mmc$lp_not_locked THEN
                  IF (NOT mmv$pt_p^ [mmv$pft_p^ [pfti].pti].m) AND (mmv$pft_p^ [pfti].active_io_count =
                        0) THEN
                    mmp$get_inhibit_io_status (mmv$pft_p^ [pfti].ijl_ordinal, TRUE {lock ajl} , inhibit_io,
                          ijl_p);
                    IF NOT inhibit_io THEN
                      mmp$remove_page_from_jws (pfti, ijl_p, mcount, rcount);
                      pfti := pfti + 1;
                      jmp$unlock_ajl (ijl_p);
                      CYCLE /verify_pages_removable/;
                    IFEND;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
            assign_contiguous := FALSE;
            EXIT /verify_pages_removable/;
          FOREND /verify_pages_removable/;

          IF assign_contiguous THEN
            EXIT /loop/;
          ELSE
            starting_pfti := pfti;
            scan_pft_for_pages (rb.pass_count, pages_requested, starting_pfti);
          IFEND;
        WHILEND /loop/;
      IFEND;

      IF starting_pfti = 0 THEN
        mtp$set_status_abnormal ('MM', mme$unable_to_assign_contig_mem, rb.status);
        RETURN;
      IFEND;

      pfti := starting_pfti;
      FOR index := 1 TO pages_requested DO
        IF mmv$pft_p^ [pfti].queue_id = mmc$pq_avail THEN
          mmp$delete_pt_entry (pfti, TRUE);
          mmp$relink_page_frame (pfti, mmc$pq_free);
        IFEND;
        pfti := pfti + 1;
      FOREND;

      mmp$assign_page_frame (sva, aste_p, pages_requested, starting_pfti, assigned_pages, first_pfti,
            pstatus);

{ If pages assigned was not equal to pages requested, (usually means page-table-full), free
{ any pages assigned and cause the request to be reissued.

      IF pages_requested <> assigned_pages THEN
        pfti := first_pfti;
        IF assigned_pages > 0 THEN
          WHILE pfti <> 0 DO
            mmp$delete_pt_entry (pfti, TRUE);
            save_pfti := mmv$pft_p^ [pfti].link.bkw;
            mmp$relink_page_frame (pfti, mmc$pq_free);
            pfti := save_pfti;
          WHILEND;
        IFEND;
        cst_p^.dispatch_control.asynchronous_interrupts_pending := TRUE;
        tmp$cause_task_switch;
        tmp$reissue_monitor_request;
        mmv$assign_contig_reject := mmv$assign_contig_reject + 1;
        RETURN;
      IFEND;

{ Each of the pages assigned must be preset. After the page is preset,
{ the valid bit in the page table is set.

      WHILE starting_pfti <> 0 DO
        mmp$preset_real_memory (mmv$pft_p^ [starting_pfti].sva, fde_p^.preset_value);
        mmv$pt_p^ [mmv$pft_p^ [starting_pfti].pti].v := TRUE;
        starting_pfti := mmv$pft_p^ [starting_pfti].link.bkw;
      WHILEND;

{ If the pages were assigned to a job-fixed segment, the pages
{ must be moved from the end of the job-fixed page queue to the
{ beginning of the job-fixed page queue. Moving the pages will
{ make swapping and job recovery of jobs with contiguous pages
{ assigned possible. A count of the job-fixed contiguous pages
{ is maintained in the IJL entry of the job.

      IF mmv$pft_p^ [first_pfti].queue_id = mmc$pq_job_fixed THEN
        jmp$get_ijle_p (mmv$pft_p^ [first_pfti].ijl_ordinal, ijl_p);
        qcb_p := ^ijl_p^.job_page_queue_list [mmc$pq_job_fixed];
        mmv$pft_p^ [qcb_p^.link.bkw].link.fwd := qcb_p^.link.fwd;
        save_pfti := qcb_p^.link.fwd;
        qcb_p^.link.fwd := mmv$pft_p^ [first_pfti].link.fwd;
        mmv$pft_p^ [first_pfti].link.fwd := 0;
        mmv$pft_p^ [qcb_p^.link.fwd].link.bkw := 0;
        mmv$pft_p^ [save_pfti].link.bkw := qcb_p^.link.bkw;
        qcb_p^.link.bkw := first_pfti;
        ijl_p^.job_fixed_contiguous_pages := ijl_p^.job_fixed_contiguous_pages + pages_requested;
      IFEND;

{ The following global variable maintains a count of all of the contiguous
{ pages currently assigned in the system. This count includes both wired and
{ job-fixed contiguous pages assigned.

      total_contig_pages_assigned := total_contig_pages_assigned + pages_requested;

    = mmc$scan_pft_write_mod_pages =

{ Pass three will simply scan through the page frame table
{ and write any pages in a job working set or the shared
{ queue which are not locked and the swap status of the
{ job does not prohibit us from writing the page to disk.

      io_id.specified := FALSE;

{write pages to disk

      FOR pfti := UPPERBOUND (mmv$pft_p^) TO LOWERBOUND (mmv$pft_p^) DO
        IF ((mmv$pft_p^ [pfti].queue_id >= mmc$pq_shared_first) AND
              (mmv$pft_p^ [pfti].queue_id <= mmc$pq_shared_last)) OR
              (mmv$pft_p^ [pfti].queue_id = mmc$pq_job_working_set) THEN
          IF mmv$pft_p^ [pfti].locked_page = mmc$lp_not_locked THEN
            mmp$get_inhibit_io_status (mmv$pft_p^ [pfti].ijl_ordinal, TRUE {lock ajl} , inhibit_io, ijl_p);
            IF NOT inhibit_io THEN
              gfp$mtr_get_locked_fde_p (mmv$pft_p^ [pfti].aste_p^.sfid, ijl_p, fde_p);
              mmp$write_page_to_disk (fde_p, pfti, ioc$write_page, io_id, mmv$multi_page_write, write_status);
              jmp$unlock_ajl (ijl_p);
            IFEND;
          IFEND;
        IFEND;
      FOREND;
      mmv$assign_contiguous_pass_cnt.pass_three_count := mmv$assign_contiguous_pass_cnt.pass_three_count + 1;
    ELSE
      mtp$set_status_abnormal ('MM', mme$invalid_request, rb.status);
    CASEND;

  PROCEND mmp$process_assign_contig_mem;
?? EJECT ??

  PROCEDURE scan_pft_for_pages
    (    pass_count: mmt$assign_contig_pass_ident;
         pages_requested: 0 .. 0ffff(16);
     VAR starting_pfti: integer);

    VAR
      ijl_p: ^jmt$initiated_job_list_entry,
      job_found: boolean,
      inhibit_io: boolean,
      page_count,
      pfti: integer;

    IF starting_pfti = 0 THEN
      IF mmv$image_file.active THEN
        pfti := (osv$180_memory_limits.deadstart_upper DIV osv$page_size) - 1;
      ELSE
        pfti := UPPERBOUND (mmv$pft_p^) + 1;
      IFEND;
    ELSE
      pfti := starting_pfti;
    IFEND;
    page_count := 0;

{ Pass one and two will check for free or available pages.
{ In addition to searching for free or available pages, pass two
{ will search for pages it can remove from a job working set.
{ Pages are not removed from a job working set until we are
{ reasonably sure we can assign the requested number of
{ contiguous pages.

  /search_loop/
    WHILE (pfti > LOWERBOUND (mmv$pft_p^)) AND (page_count < pages_requested) DO
      pfti := pfti - 1;

{Pass one will check for free or available pages.

      IF (mmv$pft_p^ [pfti].queue_id = mmc$pq_avail) OR ((mmv$pft_p^ [pfti].queue_id = mmc$pq_free) AND
            (mmv$pft_p^ [pfti].active_io_count = 0)) THEN
        page_count := page_count + 1;
        CYCLE /search_loop/;
      ELSE
        IF pass_count = mmc$scan_pft_free_avail_notmod THEN
          IF ((mmv$pft_p^ [pfti].queue_id >= mmc$pq_shared_first) AND
                (mmv$pft_p^ [pfti].queue_id <= mmc$pq_shared_last)) OR
                (mmv$pft_p^ [pfti].queue_id = mmc$pq_job_working_set) THEN
            IF mmv$pft_p^ [pfti].locked_page = mmc$lp_not_locked THEN
              IF (NOT mmv$pt_p^ [mmv$pft_p^ [pfti].pti].m) AND (mmv$pft_p^ [pfti].active_io_count = 0) THEN
                mmp$get_inhibit_io_status (mmv$pft_p^ [pfti].ijl_ordinal, FALSE {lock ajl} , inhibit_io,
                      ijl_p);
                IF NOT inhibit_io THEN
                  page_count := page_count + 1;
                  CYCLE /search_loop/;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        ELSE

{ If the swap status of the job is swap resident, the jobs resources can be freed.
{ The page must be in the job working set--pages in other queues are not necessarily freed (e.g. wired).

          jmp$get_ijle_p (mmv$pft_p^ [pfti].ijl_ordinal, ijl_p);
          IF (ijl_p^.swap_status = jmc$iss_swapped_io_complete) AND
                (mmv$pft_p^ [pfti].queue_id = mmc$pq_job_working_set) THEN

{swap status is swap resident

            jsp$free_swapped_jobs_memory (mmv$pft_p^ [pfti].ijl_ordinal, {S2_QUEUE_ONLY} TRUE, job_found);
            page_count := page_count + 1;
            CYCLE /search_loop/;
          IFEND;
        IFEND;
      IFEND;
      page_count := 0;
    WHILEND /search_loop/;

    IF page_count < pages_requested THEN
      starting_pfti := 0;
    ELSE
      starting_pfti := pfti;
    IFEND;

  PROCEND scan_pft_for_pages;

?? TITLE := 'MMP$ADVISE_REQUEST_PROCESSOR' ??
?? EJECT ??

{--------------------------------------------------------------------------------------------------------
{Name:
{  mmp$advise_request_processor
{Purpose:
{  This procedure processes ADVISE requests from job mode.
{Input:
{  rb - request block from job mode
{Output:
{  none
{Error Codes:
{  none
{notes:
{  - No error is generated if some (or all) of the pages are
{    already assigned.
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$advise_request_processor
    (VAR rb: mmt$rb_advise;
         cst_p: ^ost$cpu_state_table);

    VAR
      fde_p: gft$locked_file_desc_entry_p,
      ijle_p: ^jmt$initiated_job_list_entry,
      ste_p: ^mmt$segment_descriptor,
      stxe_p: ^mmt$segment_descriptor_extended,
      io_id: mmt$io_identifier,
      check_aio_slowdown: boolean,
      cptime: ost$cp_time_value,
      page_count: integer,
      page_in_count: mmt$page_frame_index,
      pfti: mmt$page_frame_index,
      aste_p: ^mmt$active_segment_table_entry,
      pstatus: mmt$page_pull_status,
      sva: ost$system_virtual_address;


    rb.status.normal := TRUE;

    IF NOT mmv$tables_initialized THEN
      RETURN
    IFEND;

    io_id.specified := FALSE;


{Process the ADVISE OUT part of the request.

  /adv_request/
    BEGIN
      IF ((rb.reqcode = syc$rc_advise_out) OR (rb.reqcode = syc$rc_advise_out_in)) AND
            (rb.out_length > 0) THEN
        mmp$verify_pva (^rb.out_pva, mmc$sat_read_or_write, rb.status);
        IF NOT rb.status.normal THEN
          EXIT /adv_request/;
        IFEND;
        mmp$convert_pva (rb.out_pva, cst_p, sva, fde_p, aste_p, ste_p, stxe_p);
        IF stxe_p^.access_state <> mmc$sas_allow_access THEN
          EXIT /adv_request/;
        IFEND;
        IF (aste_p^.queue_id <> mmc$pq_job_working_set) AND (aste_p^.queue_id < mmc$pq_shared_first) AND
              (aste_p^.queue_id > mmc$pq_shared_last) THEN
          mtp$set_status_abnormal ('MM', mme$segment_not_pageable, rb.status);
          EXIT /adv_request/;
        IFEND;

        IF fde_p^.media = gfc$fm_transient_segment THEN {!Should this be ignored??}
          mtp$set_status_abnormal ('MM', mme$segment_not_assigned_device, rb.status);
          EXIT /adv_request/;
        IFEND;
        mmp$remove_pages_working_set (sva, rb.out_length + #OFFSET (rb.out_pva) - sva.offset, aste_p,
              page_count);
      IFEND;


{Process the ADVISE IN part of the request.

      ijle_p := cst_p^.ijle_p;
      IF ((rb.reqcode = syc$rc_advise_in) OR (rb.reqcode = syc$rc_advise_out_in)) AND (rb.in_length > 0) THEN
        mmp$verify_pva (^rb.in_pva, mmc$sat_read_or_write, rb.status);
        IF NOT rb.status.normal THEN
          EXIT /adv_request/;
        IFEND;
        mmp$convert_pva (rb.in_pva, cst_p, sva, fde_p, aste_p, ste_p, stxe_p);
        IF stxe_p^.access_state <> mmc$sas_allow_access THEN
          EXIT /adv_request/;
        IFEND;
        page_count := (#OFFSET (rb.in_pva) + rb.in_length - 1) DIV osv$page_size -
              (#OFFSET (rb.in_pva) DIV osv$page_size) + 1;

      /advise_in/
        WHILE mmv$reassignable_page_frames.now >= mmv$aggressive_aging_level_2 DO
          mmp$page_pull_hash_sva (sva, aste_p, page_in_count, pstatus, pfti);
          IF page_in_count = 0 THEN
            mmp$page_pull (sva, fde_p, cst_p, aste_p, stxe_p, io_id, page_count, ioc$read_page, TRUE,
                  page_in_count, pstatus, pfti);
          IFEND;
          page_count := page_count - page_in_count;
          CASE pstatus OF
          = ps_no_memory, ps_low_on_memory =
            tmp$cause_task_switch;
            EXIT /advise_in/;
          = ps_io_temp_reject =
            tmp$cause_task_switch;
            EXIT /advise_in/;
          = ps_pt_full =
            cst_p^.dispatch_control.asynchronous_interrupts_pending := TRUE;
            tmp$cause_task_switch;
            EXIT /advise_in/;
          = ps_read_beyond_eoi =
            mtp$set_status_abnormal ('MM', mme$read_beyond_eoi, rb.status);
            EXIT /advise_in/;
          = ps_beyond_file_limit =
            mtp$set_status_abnormal ('MM', mme$read_write_beyond_msl, rb.status);
            EXIT /advise_in/;
          = ps_no_extend_permission =
            mtp$set_status_abnormal ('MM', mme$write_beyond_eoi_no_append, rb.status);
            EXIT /advise_in/;
          = ps_volume_unavailable, ps_server_terminated, ps_job_work_required =
            EXIT /advise_in/;
          = ps_allocate_required_on_server, ps_new_page_assigned =
            ijle_p^.statistics.paging_statistics.new_pages_assigned :=
                  ijle_p^.statistics.paging_statistics.new_pages_assigned + page_in_count;
            cst_p^.xcb_p^.paging_statistics.new_pages_assigned :=
                  cst_p^.xcb_p^.paging_statistics.new_pages_assigned + page_in_count;
            mmv$paging_statistics.ai_pages.new := mmv$paging_statistics.ai_pages.new + page_in_count;
            IF pstatus = ps_allocate_required_on_server THEN
              EXIT /advise_in/;
            IFEND;
          = ps_found_on_server =
            ijle_p^.statistics.paging_statistics.pages_from_server :=
                  ijle_p^.statistics.paging_statistics.pages_from_server + page_in_count;
            cst_p^.xcb_p^.paging_statistics.pages_from_server :=
                  cst_p^.xcb_p^.paging_statistics.pages_from_server + page_in_count;
            mmv$paging_statistics.ai_pages.server := mmv$paging_statistics.ai_pages.server + page_in_count;

          = ps_found_in_avail, ps_found_in_avail_modified =
            ijle_p^.statistics.paging_statistics.pages_reclaimed_from_queue :=
                  ijle_p^.statistics.paging_statistics.pages_reclaimed_from_queue + page_in_count;
            cst_p^.xcb_p^.paging_statistics.pages_reclaimed_from_queue :=
                  cst_p^.xcb_p^.paging_statistics.pages_reclaimed_from_queue + page_in_count;
            mmv$paging_statistics.ai_pages.reclaim := mmv$paging_statistics.ai_pages.reclaim + page_in_count;

          = ps_found_on_disk =
            ijle_p^.statistics.paging_statistics.page_in_count :=
                  ijle_p^.statistics.paging_statistics.page_in_count + page_in_count;
            cst_p^.xcb_p^.paging_statistics.page_in_count := cst_p^.xcb_p^.paging_statistics.page_in_count +
                  page_in_count;
            mmv$paging_statistics.ai_pages.disk := mmv$paging_statistics.ai_pages.disk + page_in_count;
            IF ijle_p^.active_io_requests > mmv$advise_in_aio_limit THEN
              EXIT /advise_in/;
            IFEND;
          ELSE
          CASEND;
          IF page_count <= 0 THEN
            EXIT /advise_in/;
          IFEND;
          sva.offset := sva.offset + (page_in_count * osv$page_size);
        WHILEND /advise_in/;


{Scan the JWS if the job cp time exceeds the aging threshold.

        IF mmv$aging_algorithm >= 4 THEN
          cptime := ijle_p^.statistics.cp_time.time_spent_in_job_mode;
        ELSE
          cptime := ijle_p^.statistics.cp_time.time_spent_in_mtr_mode +
                ijle_p^.statistics.cp_time.time_spent_in_job_mode;
        IFEND;
        IF cptime > cst_p^.jcb_p^.cptime_next_age_working_set THEN
          mmp$age_job_working_set (ijle_p, cst_p^.jcb_p);
        IFEND;
        check_aio_slowdown := (ijle_p^.job_page_queue_list [mmc$pq_job_working_set].count >
              cst_p^.jcb_p^.max_working_set_size);
        IF check_aio_slowdown OR (ijle_p^.job_page_queue_list [mmc$pq_job_working_set].count >
              mmv$max_working_set_size) THEN
          mmp$trim_job_working_set (ijle_p, cst_p^.jcb_p, FALSE {trim_to_swap_size=false} );
          IF check_aio_slowdown AND (ijle_p^.active_io_requests > mmv$maxws_aio_threshold) THEN
            mmv$maxws_aio_count := mmv$maxws_aio_count + 1;
            cst_p^.xcb_p^.maxws_aio_slowdown := cst_p^.xcb_p^.maxws_aio_slowdown + 1;
            ijle_p^.maxws_aio_slowdown_display := ((mmv$maxws_aio_slowdown DIV
                  mmv$jws_queue_age_interval) + 1) MOD 256;
            tmp$cause_task_switch;
          IFEND;
        ELSEIF ijle_p^.active_io_requests >
              jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.attributes.aio_limit
              THEN
          tmp$cause_task_switch;
          mmv$aio_limit_count := mmv$aio_limit_count + 1;
        IFEND;

        IF ijle_p^.statistics.paging_statistics.incremental_max_ws < ijle_p^.
              job_page_queue_list [mmc$pq_job_working_set].count THEN
          ijle_p^.statistics.paging_statistics.incremental_max_ws := ijle_p^.
                job_page_queue_list [mmc$pq_job_working_set].count;
          IF ijle_p^.statistics.paging_statistics.working_set_max_used < ijle_p^.
                job_page_queue_list [mmc$pq_job_working_set].count THEN
            ijle_p^.statistics.paging_statistics.working_set_max_used := ijle_p^.
                  job_page_queue_list [mmc$pq_job_working_set].count;
          IFEND;
        IFEND;
        IF cst_p^.xcb_p^.paging_statistics.working_set_max_used < ijle_p^.
              job_page_queue_list [mmc$pq_job_working_set].count THEN
          cst_p^.xcb_p^.paging_statistics.working_set_max_used := ijle_p^.
                job_page_queue_list [mmc$pq_job_working_set].count;
        IFEND;

{Free queue must be replenished if the number of free+avail pages is below the threshold.

        check_free_queues (cst_p);

      IFEND; {advise-in processing}

    END /adv_request/;



  PROCEND mmp$advise_request_processor;
?? TITLE := 'MMP$ASSIGN_PAGE_TO_MONITOR', EJECT ??

{-------------------------------------------------------------------------

*copyc mmh$assign_page_to_monitor

{-------------------------------------------------------------------------


  PROCEDURE [XDCL] mmp$assign_page_to_monitor
    (    p: ^cell;
         page_count: integer;
         preset: boolean;
     VAR status: syt$monitor_status);

    VAR
      i: integer,
      aste_p: ^mmt$active_segment_table_entry,
      pstatus: mmt$page_pull_status,
      sva: ost$system_virtual_address,
      cell_p: ^cell,
      count: mmt$page_frame_index,
      pfti: mmt$page_frame_index;

    status.normal := TRUE;
    sva.offset := (#OFFSET (p) DIV osv$page_size) * osv$page_size;
    cell_p := ^mtv$monitor_segment_table;
    #PURGE_BUFFER (osc$pva_purge_segment_cache, cell_p);
    sva.asid := mtv$monitor_segment_table.st [#SEGMENT (p)].ste.asid;

    mmp$aste_pointer (sva.asid, aste_p);
    FOR i := 1 TO page_count DO
      mmp$assign_page_frame (sva, aste_p, 1, 0, count, pfti, pstatus);
      IF pstatus = ps_done THEN
        IF preset THEN
          mmp$preset_real_memory (sva, pmc$initialize_to_zero);
        IFEND;
        mmv$pt_p^ [mmv$pft_p^ [pfti].pti].v := TRUE;
      ELSE
        mmp$delete_page_from_monitor (p, i - 1, status);
        IF (pstatus = ps_pt_full) THEN
          mtp$set_status_abnormal ('MM', mme$page_table_full, status);
        ELSEIF (pstatus = ps_no_memory) THEN
          mtp$set_status_abnormal ('MM', mme$no_free_pages, status);
        ELSE
          mtp$error_stop ('MM - unexpected reject on assign_page_to_monitor');
        IFEND;
        RETURN;
      IFEND;
      sva.offset := sva.offset + osv$page_size;
    FOREND;

  PROCEND mmp$assign_page_to_monitor;
?? TITLE := 'MMP$DELETE_PAGE_FROM_MONITOR', EJECT ??

{-------------------------------------------------------------------------

*copyc mmh$delete_page_from_monitor

{-------------------------------------------------------------------------


  PROCEDURE [XDCL] mmp$delete_page_from_monitor
    (    p: ^cell;
         page_count: integer;
     VAR status: syt$monitor_status);

    VAR
      pva: ^cell,
      rma: integer,
      i: integer,
      pfti: mmt$page_frame_index;

    status.normal := TRUE;
    pva := p;

    FOR i := 1 TO page_count DO
      i#real_memory_address (pva, rma);
      IF rma < 0 THEN
        mtp$error_stop ('MM - bad pva on delete_page_from_monitor');
      IFEND;
      pfti := rma DIV osv$page_size;
      mmp$delete_pt_entry (pfti, TRUE);
      mmp$relink_page_frame (pfti, mmc$pq_free);
      pva := #ADDRESS (1, #SEGMENT (p), #OFFSET (pva) + osv$page_size);
    FOREND;

    #PURGE_BUFFER (osc$pva_purge_all_page_seg_map, pva);

  PROCEND mmp$delete_page_from_monitor;
?? TITLE := 'MMP$XCHECK_QUEUES', EJECT ??

  VAR
    mmv$check_queues: [XDCL, #GATE] integer := 0;

  PROCEDURE [XDCL] mmp$xcheck_queues;

    PROCEDURE check_queue
      (    qcb: mmt$page_queue_list_entry;
           qid: integer);

      VAR
        i: integer,
        pfti,
        prev_pfti: integer;

      pfti := qcb.link.bkw;
      prev_pfti := 0;
      FOR i := 1 TO qcb.count DO
        IF pfti = 0 THEN
          mtp$error_stop ('MM - check queue, qcb count');
        IFEND;
        IF mmv$pft_p^ [pfti].link.fwd <> prev_pfti THEN
          mtp$error_stop ('MM - check queue, bad fwd');
        IFEND;
        IF mmv$pft_p^ [pfti].queue_id <> qid THEN
          mtp$error_stop ('MM - check queue, bad qid');
        IFEND;
        prev_pfti := pfti;
        pfti := mmv$pft_p^ [pfti].link.bkw;
      FOREND;
      IF pfti <> 0 THEN
        mtp$error_stop ('MM - check queue, bad count2');
      IFEND;
    PROCEND check_queue;

    VAR
      cst_p: ^ost$cpu_state_table,
      pit: integer,
      last_check_time: [STATIC] integer := 0,
      i: integer;

    IF (mmv$check_queues > 0) AND mmv$tables_initialized THEN
      pit := #READ_REGISTER (osc$pr_process_interval_timer);
      IF (mmv$check_queues > 1) OR (last_check_time - #FREE_RUNNING_CLOCK (0) > 1000000) THEN
        FOR i := 0 TO 1 DO
          check_queue (mmv$gpql [i].pqle, i);
        FOREND;
      IFEND;
      mtp$cst_p (cst_p);
      IF cst_p^.xcb_p <> NIL THEN
        FOR i := mmc$pq_job_fixed TO mmc$pq_job_working_set DO
          check_queue (cst_p^.ijle_p^.job_page_queue_list [i], i);
        FOREND;
      IFEND;
      #WRITE_REGISTER (osc$pr_process_interval_timer, pit);
      last_check_time := #FREE_RUNNING_CLOCK (0);
    IFEND;
  PROCEND mmp$xcheck_queues;

?? TITLE := 'MMP$PROCESS_VOLUME_UNAVAILABLE', EJECT ??

  PROCEDURE [XDCL] mmp$process_volume_unavailable
    (    xcb_p: ^ost$execution_control_block;
         reset_p_register: boolean);

    VAR
      fde_p: gft$file_desc_entry_p,
      ijle_p: ^jmt$initiated_job_list_entry,
      sfd_p: dft$server_descriptor_p,
      stxe_p: ^mmt$segment_descriptor_extended,
      segnum: ost$segment,
      mmv$volume_unavail_queued: [XDCL] integer := 0,
      status: syt$monitor_status;

    segnum := #SEGMENT (xcb_p^.page_wait_info.pva);
    stxe_p := mmp$get_sdtx_entry_p (xcb_p, segnum);

    jmp$get_ijle_p (tmv$ptl_p^ [xcb_p^.global_task_id.index].ijl_ordinal, ijle_p);
    gfp$mtr_get_fde_p (stxe_p^.sfid, ijle_p, fde_p);
    IF fde_p^.media = gfc$fm_served_file THEN
      dfp$get_served_file_desc_p (fde_p, sfd_p);
      IF (sfd_p^.header.file_state = dfc$awaiting_recovery) AND (xcb_p^.xp.trap_enable =
            osc$traps_enabled_delay) THEN
        xcb_p^.xp.trap_enable := osc$traps_enabled;
        tmp$set_monitor_flag (xcb_p^.global_task_id, mmc$mf_volume_unavailable, status);
        RETURN;
      IFEND;
    IFEND;

    IF (xcb_p^.xp.trap_enable <> osc$traps_enabled) OR

{ Could have used p_register.ring <= 3, but that has problems too

    (segnum < mmc$first_loader_predefined_seg) OR (mmc$sa_stack IN stxe_p^.software_attribute_set) THEN
      IF (tmv$ptl_p^ [xcb_p^.global_task_id.index].status < tmc$ts_first_external_queue) AND
            (tmv$ptl_p^ [xcb_p^.global_task_id.index].new_task_status < tmc$ts_first_external_queue) THEN
        tmp$queue_task (xcb_p^.global_task_id, tmc$ts_volume_unavailable, mmv$volume_wait_queue);
        mmv$volume_unavail_queued := mmv$volume_unavail_queued + 1;
        IF (xcb_p^.system_table_lock_count > 255) OR (xcb_p^.critical_task) OR
              (tmv$ptl_p^ [xcb_p^.global_task_id.index].ijl_ordinal = jmv$system_ijl_ordinal) THEN
          mtp$step_unstep_system (syc$ic_disk_error,
                'ERR=VEOS9301- A critical system task has encountered an unavailable volume');
          iop$enable_all_disk_units (status);
        IFEND;
      IFEND;
    ELSE
      tmp$set_monitor_flag (xcb_p^.global_task_id, mmc$mf_volume_unavailable, status);
    IFEND;

    IF reset_p_register THEN
      tmp$reissue_monitor_request;
    IFEND;

  PROCEND mmp$process_volume_unavailable;
?? TITLE := 'MMP$PROCESS_VOLUME_AVAILABLE', EJECT ??

  PROCEDURE [XDCL] mmp$volume_available;

    VAR
      mmv$volume_unavail_dequeued: [XDCL] integer := 0,
      taskid: ost$global_task_id;

    WHILE (mmv$volume_wait_queue.head <> 0) DO
      tmp$dequeue_task (mmv$volume_wait_queue, taskid);
      mmv$volume_unavail_dequeued := mmv$volume_unavail_dequeued + 1;
    WHILEND;

  PROCEND mmp$volume_available;

?? TITLE := 'MMP$INCLUDE_P_REG_IN_DUMP', EJECT ??

  PROCEDURE [XDCL] mmp$include_p_reg_in_dump;

    PROCEDURE set_page
      (    ste_p: ^mmt$segment_descriptor;
           offset: integer);

      IF (ste_p^.ste.asid <> 0) and (offset >= 0) AND (offset <= 7fffffff(16)) THEN
        sva.asid := ste_p^.ste.asid;
        sva.offset := offset;
        #HASH_SVA (sva, pti, count, found);
        IF found THEN
          pfti := (mmv$pt_p^ [pti].rma * 512) DIV osv$page_size;
          mmv$pages_to_dump_p^ [pfti] := TRUE;
        IFEND;
      IFEND;

    PROCEND set_page;

    VAR
      found: boolean,
      sva: ost$system_virtual_address,
      pti: integer,
      count: integer,
      cst_index: integer,
      rma: integer,
      ste_p: ^mmt$segment_descriptor,
      pfti: mmt$page_frame_index,
      xcb_p: ^ost$execution_control_block;


    IF mmv$pages_to_dump_p <> NIL THEN
      FOR cst_index := LOWERBOUND (mtv$cst0) TO UPPERBOUND (mtv$cst0) DO
        IF mtv$cst0 [cst_index].xcb_p <> NIL THEN
          xcb_p := mtv$cst0 [cst_index].xcb_p;
          i#real_memory_address (xcb_p, rma);
          IF rma >= 0 THEN
            ste_p := mmp$get_sdt_entry_p (xcb_p, xcb_p^.xp.p_register.pva.seg);
            set_page (ste_p, xcb_p^.xp.p_register.pva.offset);
            set_page (ste_p, xcb_p^.xp.p_register.pva.offset + osv$page_size);
            set_page (ste_p, xcb_p^.xp.p_register.pva.offset - osv$page_size);
          IFEND;
        IFEND;
      FOREND;

    IFEND;

  PROCEND mmp$include_p_reg_in_dump;

?? OLDTITLE ??
MODEND mmm$page_fault_processor;
*DECK DECK=MMM$PFTI_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
MODULE mmm$pfti_manager;

{
{  PURPOSE: Memory_Manager
{     This module contains the monitor routines that are used to
{     locate all page frames bedlonging to a specified range of an SVA.
{

?? PUSH (LISTEXT := ON) ??
*copyc mmt$pfti_array
*copyc mmt$page_queue_set
*copyc mmt$page_selection_criteria
*copyc mmt$page_frame_index
*copyc mmt$active_segment_table
*copyc mmt$page_frame_queue_id
?? POP ??
*copyc mmc$debug_constants
?? SKIP := 2 ??
{External procedures used by this module.
{ Try to keep them in alphabetical order.
*copyc jmp$get_ijle_p
*copyc mtp$error_stop
?? TITLE := 'Global Variable Declarations - XREF and XDCL', EJECT ??
*copyc jmv$ijl_p
*copyc mmv$pft_p
?? SKIP := 2 ??
*copyc mmv$pt_length
?? SKIP := 2 ??
*copyc mmv$pt_p
*copyc osv$page_size

  VAR
    mmv$pfti_array_p: [XDCL, #GATE] ^mmt$pfti_array;

?? TITLE := '[XDCL] mmp$initialize_find_next_pfti', EJECT ??
{----------------------------------------------------------------------------------------------------------
{
{ The following procedures are used for locating pages belonging to a specified SVA to SVA+LENGTH range.
{ The procedures use an array (MMV$PFTI_ARRAY) allocated at deadstart time to contain the list of PFTIs.
{       mmp$initialize_find_next_pfti   - fills the array with the list of PFTIs and returns the first one.
{       mmp$find_next_pfti              - returns the next PFTI from the array. (0 = end of array)
{       mmp$delete_last_pfti_from_array - deletes the most recently returned PFTI from the array. If the
{                                         PFTI array is rescanned the entry will not be returned again;
{       mmp$reset_find_next_pfti        - resets the array index so that subsequent calls to
{                                         mmp$find_next_pfti will rescan the array and return all PFTIs.
{
{ Depending on initialization options the PFTIs selected by theses routines are be restricted as follows:
{       psc_nominal_queue   - only PFTIs of pages that are 'valid' will be returned (eg. working_set, wired,
{                             fixed, shared, io_error)
{       psc_all_except_avail- PFTI's of all pages in memory EXCEPT for pages in the AVAIL queue are returned.
{                             PROCEDURES THAT CALL THESES ROUTINES MUST BE PREPARED TO HANDLE NOT FINDING
{                             PAGES THAT ARE IN THE AVAIL QUEUE.
{       psc_all             - the PFTI's of all pages within the range that are in memory are returned.  To
{                             ensure that all pages of the segment are found, THE CALLER MUST SPECIFY THAT
{                             THE ENTIRE SEGMENT BE SEARCHED.
{----------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mmp$initialize_find_next_pfti
    (    xsva: ost$system_virtual_address;
         length: ost$segment_length;
         end_point_option: (include_partial_pages, exclude_partial_pages);
         page_selection_criteria: mmt$page_selection_criteria;
         aste_p: ^mmt$active_segment_table_entry;
     VAR xpfti: mmt$page_frame_index);

    VAR
      found: boolean,
      hcount: 1 .. 32,
      high_offset: integer,
      ipti: integer,
      low_offset: integer,
      offset: integer,
      page_count: integer,
      pages_in_memory: integer,
      pfti: mmt$page_frame_index,
      pfti_index: integer,
      selection_page_queues: mmt$page_queue_set,
      sva: ost$system_virtual_address;

    mmv$pfti_array_p^.pftis [0] := 0;
    pfti_index := 0;
    pages_in_memory := aste_p^.pages_in_memory;


{ Set up the parameters used to control the search. This includes the starting offset.
{ Determine the set of page queues a page can be linked to based on the page_selection_criteria.

    IF (pages_in_memory > 0) AND (length > 0) THEN
      sva := xsva;
      offset := sva.offset;
      IF end_point_option = include_partial_pages THEN
        page_count := (offset + length - 1) DIV osv$page_size - (offset DIV osv$page_size) + 1;
      ELSE
        page_count := (offset + length) DIV osv$page_size;
        offset := ((offset + osv$page_size - 1) DIV osv$page_size) * osv$page_size;
        page_count := page_count - offset DIV osv$page_size;
      IFEND;
      low_offset := offset - offset MOD osv$page_size;
      high_offset := low_offset + page_count * osv$page_size - 1;

      selection_page_queues := $mmt$page_queue_set [];
      IF page_selection_criteria = psc_all THEN
        selection_page_queues := -$mmt$page_queue_set [];
      ELSEIF page_selection_criteria = psc_all_except_avail THEN
        selection_page_queues := -$mmt$page_queue_set [mmc$pq_avail];
      ELSE  {page_selection_criteria = psc_nominal_queue}
        IF aste_p^.queue_id = mmc$pq_job_working_set THEN
          selection_page_queues := $mmt$page_queue_set [mmc$pq_shared_io_error, mmc$pq_job_io_error,
                mmc$pq_job_working_set]; { Unwritable permanent file pages go to the shared_io_error q. }
        ELSEIF ((aste_p^.queue_id >= mmc$pq_shared_first) AND (aste_p^.queue_id <= mmc$pq_shared_last)) THEN
          selection_page_queues := -$mmt$page_queue_set [mmc$pq_free, mmc$pq_avail, mmc$pq_avail_modified,
                mmc$pq_wired, mmc$pq_job_fixed, mmc$pq_job_working_set, mmc$pq_job_io_error];
        ELSEIF aste_p^.queue_id = mmc$pq_wired THEN
          selection_page_queues := $mmt$page_queue_set [mmc$pq_wired];
        ELSEIF aste_p^.queue_id = mmc$pq_job_fixed THEN
          selection_page_queues := $mmt$page_queue_set [mmc$pq_job_fixed];
        ELSE
          mtp$error_stop ('FIND NEXT PFTI -- BAD QUEUE ID');
        IFEND;
      IFEND;

{ Search for pages.

      IF (low_offset = 0) AND (length > 7ffffe00(16)) THEN
        pfti := aste_p^.pft_link.fwd;
        IF (page_selection_criteria = psc_all) THEN

{ The request is for all the pages of a segment that are in memory, so use the search algorithm that uses
{ the segment/page frame link to find all pages of the segment.

          WHILE pfti <> 0 DO
            mmv$pfti_array_p^.pftis [pfti_index] := pfti;
            pfti_index := pfti_index + 1;
            pfti := mmv$pft_p^ [pfti].segment_link.fwd;
          WHILEND;
        ELSE

{ The request length is for the entire segment, but not all queues should be searched.  Use the
{ the segment/page frame link to find all pages of the segment and check if each page fits the
{ page_selection_criteria.

          WHILE (pfti <> 0) DO
            IF mmv$pft_p^ [pfti].queue_id IN selection_page_queues THEN
              mmv$pfti_array_p^.pftis [pfti_index] := pfti;
              pfti_index := pfti_index + 1;
            IFEND;
            pfti := mmv$pft_p^ [pfti].segment_link.fwd;
          WHILEND;
        IFEND;

      ELSEIF (page_count < pages_in_memory DIV 4) THEN

{ If the request is for a small percentage of the pages in memory, use the search algorith that uses
{ the #HASH instruction to locate pages. This algorithm is NOT efficient for searches that look for
{ a large number of pages, because it does a HASH on each page in the range.  If the page is found,
{ it is put in the pfti array only if the page satisfies the page selection criteria.

        WHILE page_count > 0 DO
          sva.offset := offset;
          #HASH_SVA (sva, ipti, hcount, found);
          page_count := page_count - 1;
          offset := offset + osv$page_size; {Must be integer to prevent end case at end of segment (2**31)}
          IF found THEN
            pfti := (mmv$pt_p^ [ipti].rma * 512) DIV osv$page_size;
            IF mmv$pft_p^ [pfti].queue_id IN selection_page_queues THEN
              mmv$pfti_array_p^.pftis [pfti_index] := pfti;
              pfti_index := pfti_index + 1;
            IFEND;
            pages_in_memory := pages_in_memory - 1;
            IF pages_in_memory = 0 THEN
              page_count := 0;
            IFEND;
          IFEND;
        WHILEND;

      ELSE

{ The request is for a majority of the pages in memory.  Again, use the search algorithm that uses the
{ segment/page frame link to find all pages of the segment.  We need to check if the page offset is within
{ the range requested and decide if the page satisfies the selection criteria.

        pfti := aste_p^.pft_link.fwd;
        WHILE (pfti <> 0) AND (page_count > 0) DO
          IF (mmv$pft_p^ [pfti].sva.offset >= low_offset) AND
                (mmv$pft_p^ [pfti].sva.offset <= high_offset) THEN
            page_count := page_count - 1;
            IF mmv$pft_p^ [pfti].queue_id IN selection_page_queues THEN
              mmv$pfti_array_p^.pftis [pfti_index] := pfti;
              pfti_index := pfti_index + 1;
            IFEND;
          IFEND;
          pfti := mmv$pft_p^ [pfti].segment_link.fwd;
        WHILEND;

      IFEND;
    IFEND;  { pages_in_memory > 0 }

    mmv$pfti_array_p^.pfti_first := 0;
    mmv$pfti_array_p^.pfti_index := 0;
    mmv$pfti_array_p^.last_pfti_index := pfti_index;
    mmv$pfti_array_p^.pftis [pfti_index] := 0;
    xpfti := mmv$pfti_array_p^.pftis [0];

  PROCEND mmp$initialize_find_next_pfti;



?? TITLE := 'INLINE Procedures used in other modules', EJECT ??
?? SET (LISTALL := ON) ??
*copyc mmp$delete_last_pfti_from_array
?? SKIP := 2 ??
*copyc mmp$fetch_pfti_array_size
?? SKIP := 2 ??
*copyc mmp$find_next_pfti
?? SKIP := 2 ??
*copyc mmp$reset_find_next_pfti
?? SKIP := 2 ??
*copyc mmp$reset_store_next_pfti
?? SKIP := 2 ??
*copyc mmp$store_next_pfti
?? SKIP := 2 ??
*copyc mmp$reset_store_pfti_reverse
?? SKIP := 2 ??
*copyc mmp$store_pfti_reverse
?? POP ??
?? OLDTITLE ??
MODEND mmm$pfti_manager
*DECK DECK=MMM$PREALLOCATE_FILE_SPACE EXPAND=TRUE
MODULE mmm$preallocate_file_space;
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc mmp$advise_out
*copyc mmp$assign_pages
*copyc mmp$write_modified_pages
*copyc osp$flush_allocation_info
*copyc dmp$allocate_file_space_r1
*copyc gfp$get_segment_sfid
*copyc mmp$validate_segment_number
*copyc syp$push_inhibit_job_recovery
*copyc syp$pop_inhibit_job_recovery
*copyc amt$segment_pointer
*copyc ost$wait
*copyc osd$virtual_address
*copyc ost$caller_identifier
*copyc osv$page_size
*copyc osp$set_status_abnormal
*copyc mme$condition_codes
?? POP ??
*copyc mmh$preallocate_file_space
?? TITLE := 'PROCEDURE mmp$preallocate_file_space', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$preallocate_file_space
    (    pva: amt$segment_pointer;
         length: ost$segment_length;
         wait_for_allocation: boolean;
     VAR status: ost$status);

    VAR
      sfid: dmt$system_file_id,
      p_chunk: ^cell,
      p_segment: ^cell,
      remainder: ost$segment_length,
      sdt_p: ^mmt$segment_descriptor,
      sdtx_p: ^mmt$segment_descriptor_extended,
      caller_id: ost$caller_identifier,
      wait: ost$wait,
      chunk_length: ost$segment_length;

    status.normal := TRUE;

    CASE pva.kind OF
    = amc$cell_pointer =
      p_segment := pva.cell_pointer;
    = amc$heap_pointer =
      p_segment := #LOC (pva.heap_pointer^);
    = amc$sequence_pointer =
      p_segment := #LOC (pva.sequence_pointer^);
    ELSE
      osp$set_status_abnormal ('MM', mme$invalid_pva, '', status);
      RETURN
    CASEND;

    mmp$validate_segment_number (#SEGMENT (p_segment), sdt_p, sdtx_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    #CALLER_ID (caller_id);
    IF #RING (p_segment) = 0 THEN
      osp$set_status_abnormal ('MM', mme$invalid_pva, '', status);
      RETURN;
    IFEND;

    IF (caller_id.ring > sdt_p^.ste.r1) OR (sdt_p^.ste.wp = osc$non_writable) THEN
      osp$set_status_abnormal ('MM', mme$invalid_pva, '', status);
      RETURN;
    IFEND;

    syp$push_inhibit_job_recovery;
    gfp$get_segment_sfid (p_segment, sfid, status);
    IF NOT status.normal THEN
      syp$pop_inhibit_job_recovery;
      RETURN;
    IFEND;

    IF wait_for_allocation THEN
      wait := osc$wait;
    ELSE
      wait := osc$nowait;
    IFEND;

    dmp$allocate_file_space_r1 (sfid, #OFFSET (p_segment), length, 0, wait,
        sdtx_p^.file_limits_enforced, status);
    syp$pop_inhibit_job_recovery;
    IF NOT status.normal THEN
      osp$set_status_abnormal ('MM', mme$preallocate_failed, '', status);
      RETURN;
    IFEND;

    IF length > (osv$page_size * 100) THEN
      chunk_length := osv$page_size * 100;
    ELSE
      chunk_length := length;
    IFEND;
    remainder := length;
    p_chunk := p_segment;

    WHILE remainder > 0 DO
      mmp$assign_pages (p_chunk, chunk_length, {preset_pages=} TRUE, osc$wait, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      mmp$advise_out (p_chunk, chunk_length, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      p_chunk := #ADDRESS (#ring (p_chunk), #segment (p_chunk), #offset (p_chunk) + chunk_length);
      remainder := remainder - chunk_length;
      IF remainder < chunk_length THEN
        chunk_length := remainder;
      IFEND
    WHILEND;

    mmp$write_modified_pages (p_segment, length, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$flush_allocation_info (status);
    IF NOT status.normal THEN
      osp$set_status_abnormal ('MM', mme$preallocate_failed, '', status);
      RETURN;
    IFEND;

  PROCEND mmp$preallocate_file_space;
MODEND
*DECK DECK=MMM$READ_WRITE_IO_RING_1 EXPAND=TRUE
?? RIGHT := 110 ??
MODULE mmm$read_write_io_ring_1;

{ This module contains the ring 1 procedures for processing
{ user read/write requests.

?? PUSH (LISTEXT := ON) ??
*copyc mmt$io_control_block
*copyc mmt$iocb_index
*copyc ost$status
*copyc ost$execution_control_block
*copyc osv$job_fixed_heap
?? POP ??

{External procedures used by this module.

*copyc osp$system_error
*copyc pmp$find_executing_task_xcb

?? TITLE := 'mmp$allocate_iocb_r1' ??
?? EJECT ??

{ The purpose of this procedure is to allocate and I/O control block for
{ a task doing asynchronous I/O.

  PROCEDURE [XDCL, #GATE] mmp$allocate_iocb_r1;

    VAR
      iocb_index: mmt$iocb_index,
      iocb_p: ^mmt$io_control_block,
      xcb_p: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb_p);

{ Allocate space for the iocb using a local variable, then move the
{ pointer to the xcb (the iocb_p field in the xcb is declared as ^cell).

    IF xcb_p^.iocb_p = NIL THEN
      ALLOCATE iocb_p in osv$job_fixed_heap^;
      IF iocb_p <> NIL THEN
        xcb_p^.iocb_p := iocb_p;

{ Initialize table.

        iocb_p^.latest_completion_time := 0;
        iocb_p^.maximum_iocb_index_in_use := 0;
        iocb_p^.wait_for_any_completion := FALSE;
        FOR iocb_index := LOWERBOUND (iocb_p^.iocb_table) TO UPPERBOUND (iocb_p^.iocb_table) DO
          iocb_p^.iocb_table [iocb_index].iostatus_p := NIL;
          iocb_p^.iocb_table [iocb_index].active_io_count := 0;
          iocb_p^.iocb_table [iocb_index].condition := 0;
          iocb_p^.iocb_table [iocb_index].used_for_asynchronous_io := FALSE;
          iocb_p^.iocb_table [iocb_index].io_already_active := FALSE;
        FOREND;
      ELSE
        osp$system_error ('job fixed is full', NIL);
      IFEND;
    IFEND;
  PROCEND mmp$allocate_iocb_r1;

?? TITLE := 'mmp$update_iocb_completions' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$update_iocb_completions (completion_table:
    mmt$iocb_table_array);

    VAR
      iocb_index: mmt$iocb_index,
      iocb_ptr: ^mmt$io_control_block,
      new_maximum_iocb_index: mmt$iocb_index,
      xcb_p: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb_p);
    iocb_ptr := xcb_p^.iocb_p;
    new_maximum_iocb_index := 0;

    FOR iocb_index := LOWERBOUND (completion_table) TO iocb_ptr^.maximum_iocb_index_in_use DO
      IF (completion_table [iocb_index].active_io_count = 0) AND
            (completion_table[iocb_index].used_for_asynchronous_io) THEN
        iocb_ptr^.iocb_table [iocb_index].iostatus_p := NIL;
        iocb_ptr^.iocb_table [iocb_index].used_for_asynchronous_io := FALSE;
        iocb_ptr^.iocb_table [iocb_index].condition := 0;
        iocb_ptr^.iocb_table [iocb_index].io_already_active := FALSE;
      ELSEIF completion_table[iocb_index].used_for_asynchronous_io THEN
        new_maximum_iocb_index := iocb_index;
      IFEND;
    FOREND;
    iocb_ptr^.maximum_iocb_index_in_use := new_maximum_iocb_index;

  PROCEND mmp$update_iocb_completions;
MODEND mmm$read_write_io_ring1;
*DECK DECK=MMM$READ_WRITE_IO_RING_3 EXPAND=TRUE
?? RIGHT := 110 ??
MODULE mmm$read_write_io_ring_3;

{ This module contains the ring 3 procedures for processing
{ user read/write requests.

?? PUSH (LISTEXT := ON) ??
*copyc ioe$st_errors
*copyc mme$condition_codes
*copyc mmk$job_mode_keypoints
*copyc mmt$io_control_block
*copyc mmt$io_status
*copyc mmt$iocb_index
*copyc mmt$rb_memory_manager_io
*copyc osd$virtual_address
*copyc ost$execution_control_block
*copyc osk$keypoints
*copyc ost$status
*copyc syc$monitor_request_codes
?? POP ??

{External procedures used by this module.

*copyc i#call_monitor
*copyc i#move
*copyc mmp$allocate_iocb_r1
*copyc mmp$read
*copyc mmp$reallocate_file_space
*copyc mmp$update_iocb_completions
*copyc mmp$write
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_mtr_status
*copyc osp$verify_system_privilege
*copyc pmp$find_executing_task_xcb
*copyc pmp$wait

  VAR
    last_update_time: [STATIC] ost$free_running_clock := 0;

?? TITLE := '[XDCL, #GATE] mmp$check_io_completions' ??
?? EJECT ??
*copyc mmh$check_io_completions

  PROCEDURE [XDCL, #GATE] mmp$check_io_completions
    (    timestamp: ost$free_running_clock;
         wait_time: integer;
     VAR status: ost$status);

    VAR
      completion_table: mmt$iocb_table_array,
      i: integer,
      io_active: boolean,
      iocb_ptr: ^mmt$io_control_block,
      iocb_table: mmt$iocb_table_array,
      latest_completion_time: integer,
      rb: mmt$rb_memory_manager_io,
      wait_opt: ost$wait,
      xcb_p: ^ost$execution_control_block;

    #keypoint (osk$entry, 0, mmk$check_io_completions);

    status.normal := TRUE;

    pmp$find_executing_task_xcb (xcb_p);
    iocb_ptr := xcb_p^.iocb_p;
    IF iocb_ptr = NIL THEN
      osp$set_status_abnormal ('MM', mme$no_io_active, ' ', status);
      #keypoint (osk$exit, 0, mmk$check_io_completions);
      RETURN;
    IFEND;

    latest_completion_time := iocb_ptr^.latest_completion_time;
    IF latest_completion_time = last_update_time THEN
      IF (wait_time = 0) OR (latest_completion_time > timestamp) THEN
        #keypoint (osk$exit, 0, mmk$check_io_completions);
        RETURN;
      ELSE

{ Verify there is io active

        io_active := FALSE;
        i#move (#LOC (iocb_ptr^.iocb_table), ^completion_table, #SIZE (mmt$iocb_table_entry) *
              iocb_ptr^.maximum_iocb_index_in_use);
        /check_io_active/
        FOR i := LOWERBOUND (completion_table) TO iocb_ptr^.maximum_iocb_index_in_use DO
          IF (completion_table [i].active_io_count > 0) AND
                (completion_table [i].used_for_asynchronous_io) THEN
            io_active := TRUE;
            EXIT /check_io_active/;
          IFEND;
        FOREND /check_io_active/;

{ Issue to request to wait for io, if io is active.

        IF io_active THEN
          rb.reqcode := syc$rc_memory_manager_io;
          rb.status.normal := TRUE;
          rb.sub_reqcode := mmc$iorc_await_io_completion;
          rb.latest_completion_time := latest_completion_time;
          rb.wait_time := wait_time;
          i#call_monitor (#LOC (rb), #SIZE (rb));

        ELSEIF latest_completion_time = iocb_ptr^.latest_completion_time THEN

{ If the timestamps no longer match, io completed since the local copy of latest_completion_time was
{ read; process completions.  If the timestamps match, the caller is confused; there are no active io
{ requests.

          osp$set_status_abnormal ('MM', mme$no_io_active, ' ', status);
          #keypoint (osk$exit, 0, mmk$check_io_completions);
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    IF wait_time > 0 THEN
      wait_opt := osc$wait;
    ELSE
      wait_opt := osc$nowait;
    IFEND;

    mmp$process_io_completions (iocb_ptr, wait_opt, latest_completion_time, status);

    #keypoint (osk$exit, 0, mmk$check_io_completions);

  PROCEND mmp$check_io_completions;


?? TITLE := 'mmp$check_io_status' ??
?? EJECT ??
{--------------------------------------------------------------------------------------------------------
*copyc mmh$check_io_status
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL, #GATE] mmp$check_io_status (status_pointer_array: mmt$io_status_pointer_array;
        wait_time: integer;
    VAR index: integer;
    VAR status: ost$status);

    VAR
      rb: mmt$rb_memory_manager_io,
      first_check: boolean,
      i: integer,
      j: integer,
      end_timeout: integer,
      valid_ptr_found: boolean,
      wait_opt: ost$wait,
      xcb_p: ^ost$execution_control_block,
      iocb_ptr: ^mmt$io_control_block,
      iocb_table: mmt$iocb_table_array,
      latest_completion_time: integer;

    #keypoint (osk$entry, 0, mmk$check_io_status);

    status.normal := TRUE;

    index := 0;

    valid_ptr_found := FALSE;

    first_check := TRUE;

    end_timeout := (wait_time * 1000) + #free_running_clock (0);

    IF wait_time > 0 THEN
      wait_opt := osc$wait;
    ELSE
      wait_opt := osc$nowait;
    IFEND;

  /process_check_wait/
    WHILE (first_check) OR (end_timeout > #free_running_clock (0)) DO
      IF NOT first_check THEN { Have the task wait. }

{ Make sure the first non_nil pointer is in the IOCB before having the task wait.

        IF NOT valid_ptr_found THEN

          iocb_table := iocb_ptr^.iocb_table;

        /check_for_valid_ptr/
          FOR i := LOWERBOUND (status_pointer_array) TO UPPERBOUND (status_pointer_array) DO
            IF status_pointer_array [i] <> NIL THEN
              FOR j := LOWERBOUND (iocb_table) TO iocb_ptr^.maximum_iocb_index_in_use DO
                IF status_pointer_array [i] = iocb_table [j].iostatus_p THEN
                  valid_ptr_found := TRUE;
                  EXIT /check_for_valid_ptr/;
                IFEND;
              FOREND;
              EXIT /check_for_valid_ptr/;
            IFEND;
          FOREND /check_for_valid_ptr/;
          IF NOT valid_ptr_found THEN
            osp$set_status_abnormal ('MM', mme$invalid_io_status_ptrs, ' ', status);
            EXIT /process_check_wait/;
          IFEND;
        IFEND;

        rb.reqcode := syc$rc_memory_manager_io;
        rb.status.normal := TRUE;
        rb.sub_reqcode := mmc$iorc_await_io_completion;
        rb.latest_completion_time := latest_completion_time;
        rb.wait_time := wait_time;
        i#call_monitor (#LOC (rb), #SIZE (rb));
      IFEND;

      pmp$find_executing_task_xcb (xcb_p);
      iocb_ptr := xcb_p^.iocb_p;
      IF iocb_ptr = NIL THEN
        osp$set_status_abnormal ('MM', mme$nil_io_control_block, ' ', status);
        RETURN;
      IFEND;

      mmp$process_io_completions (iocb_ptr, wait_opt, latest_completion_time, status);
      IF NOT status.normal THEN
        EXIT /process_check_wait/;
      IFEND;

      FOR i := LOWERBOUND (status_pointer_array) TO UPPERBOUND (status_pointer_array) DO
        IF status_pointer_array [i] <> NIL THEN
          IF status_pointer_array [i]^.request_status = mmc$irs_complete THEN
            index := i;
            EXIT /process_check_wait/;
          IFEND;
        IFEND;
      FOREND;
      first_check := FALSE;
    WHILEND /process_check_wait/;

    #keypoint (osk$exit, 0, mmk$check_io_status);

  PROCEND mmp$check_io_status;

?? TITLE := 'mmp$process_io_completions' ??
?? EJECT ??

  PROCEDURE mmp$process_io_completions
    (    iocb_ptr: ^mmt$io_control_block;
         wait_opt: ost$wait;
     VAR latest_completion_time: integer;
     VAR status: ost$status);

    VAR
      completion_table: mmt$iocb_table_array,
      i: mmt$iocb_index,
      re_request: array [mmt$iocb_index] of mmt$iocb_index,
      re_request_index: mmt$iocb_index,
      wait: ost$wait;

    status.normal := TRUE;

    re_request_index := 0;

    latest_completion_time := iocb_ptr^.latest_completion_time;
    last_update_time := latest_completion_time;

    i#move (#LOC (iocb_ptr^.iocb_table), ^completion_table, #SIZE (mmt$iocb_table_entry) *
          iocb_ptr^.maximum_iocb_index_in_use);
    FOR i := LOWERBOUND (completion_table) TO iocb_ptr^.maximum_iocb_index_in_use DO

{ If a request has been marked already active and needs to be reissued, then save the table
{ indices of those requests in an array (re_request) so that the requests
{ can be reissued, and do not report those requests as complete.

      IF (completion_table [i].active_io_count = 0) AND (completion_table [i].used_for_asynchronous_io) THEN
        IF (completion_table [i].sub_reqcode = mmc$iorc_read_pages) AND (completion_table [i].condition = 0)
              AND (completion_table [i].io_already_active) THEN
          re_request [re_request_index] := i;
          re_request_index := re_request_index + 1;
        ELSEIF (completion_table [i].sub_reqcode = mmc$iorc_write_pages) AND (completion_table [i].condition =
              0) AND (completion_table [i].io_already_active) THEN
          re_request [re_request_index] := i;
          re_request_index := re_request_index + 1;
        ELSEIF completion_table [i].condition = ioc$disk_media_error THEN
          mmp$reallocate_file_space (completion_table [i].pva, status);
          IF status.normal THEN
            re_request [re_request_index] := i;
            re_request_index := re_request_index + 1;
          ELSE
            completion_table [i].iostatus_p^.request_status := mmc$irs_complete;
            completion_table [i].iostatus_p^.condition := completion_table [i].condition;
          IFEND;
        ELSE
          completion_table [i].iostatus_p^.request_status := mmc$irs_complete;
          completion_table [i].iostatus_p^.condition := completion_table [i].condition;
        IFEND;
      IFEND;
    FOREND;

    mmp$update_iocb_completions (completion_table);

    FOR i := 0 TO re_request_index - 1 DO
      IF completion_table [re_request [i]].sub_reqcode = mmc$iorc_read_pages THEN
        mmp$read (completion_table [re_request [i]].pva, completion_table [re_request [i]].length,
              completion_table [re_request [i]].iostatus_p, wait_opt, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        IF completion_table [re_request [i]].condition = ioc$disk_media_error THEN
          wait := osc$wait;
        ELSE
          wait := wait_opt;
        IFEND;
        mmp$write (completion_table [re_request [i]].pva, completion_table [re_request [i]].length, FALSE,
              completion_table [re_request [i]].iostatus_p, wait, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND mmp$process_io_completions;

?? TITLE := 'mmp$allocate_iocb_r3' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$allocate_iocb_r3;

    osp$verify_system_privilege;

    mmp$allocate_iocb_r1;
  PROCEND mmp$allocate_iocb_r3;

?? TITLE := 'mmp$wait_for_iocb_entry' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$wait_for_iocb_entry (VAR status: ost$status);

    VAR
      xcb_p: ^ost$execution_control_block,
      iocb_ptr: ^mmt$io_control_block,
      latest_completion_time: integer,
      i: integer;

    status.normal := TRUE;

    osp$verify_system_privilege;

    pmp$find_executing_task_xcb (xcb_p);
    iocb_ptr := xcb_p^.iocb_p;
    IF iocb_ptr = NIL THEN
      osp$set_status_abnormal ('MM', mme$nil_io_control_block, ' ', status);
      RETURN;
    IFEND;
    WHILE TRUE DO
      mmp$process_io_completions (iocb_ptr, osc$nowait, latest_completion_time, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      FOR i := LOWERBOUND (iocb_ptr^.iocb_table) TO UPPERBOUND (iocb_ptr^.iocb_table) DO
        IF (NOT iocb_ptr^.iocb_table [i].used_for_asynchronous_io) AND
              (iocb_ptr^.iocb_table [i].active_io_count = 0) THEN
          RETURN;
        IFEND;
      FOREND;
      pmp$wait (100, 100);
    WHILEND;
  PROCEND mmp$wait_for_iocb_entry;
MODEND mmm$read_write_io_ring_3;
*DECK DECK=MMM$READ_WRITE_IO_RING_ANY EXPAND=TRUE
?? RIGHT := 110 ??
MODULE mmm$read_write_io_ring_any;

{ This module contains request processors for user read/write requests.

?? PUSH (LISTEXT := ON) ??
*copyc ioe$st_errors
*copyc mmc$move_pages_max_req_length
*copyc mme$condition_codes
*copyc mmk$job_mode_keypoints
*copyc mmt$attribute_keyword
*copyc mmt$io_control_block
*copyc mmt$move_pages_page_count
*copyc mmt$rb_assign_pages
*copyc mmt$rb_free_flush
*copyc mmt$rb_memory_manager_io
*copyc mmt$rb_move_pages
*copyc osc$processor_defined_registers
*copyc osd$conditions
*copyc osd$virtual_address
*copyc osk$keypoints
*copyc ost$caller_identifier
*copyc ost$execution_control_block
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc pmt$condition
*copyc pmt$condition_information
*copyc syt$monitor_request_code
*copyc syc$monitor_request_codes
?? POP ??

{External procedures used by this module.

*copyc i#call_monitor
*copyc i#disable_traps
*copyc i#move
*copyc i#restore_traps
*copyc ifp$invoke_pause_utility
*copyc mmp$allocate_iocb_r3
*copyc mmp$check_if_pages_in_memory
*copyc mmp$fetch_segment_attributes
*copyc mmp$get_page_size
*copyc mmp$reallocate_file_space
*copyc mmp$verify_access
*copyc mmp$wait_for_iocb_entry
*copyc ofp$display_status_message
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_from_condition
*copyc osp$set_status_from_mtr_status
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osp$wait_on_condition
*copyc pmp$continue_to_cause
*copyc pmp$cycle
*copyc pmp$delay
*copyc pmp$log
*copyc pmp$long_term_wait
*copyc pmp$wait

  CONST
    max_length = 65536;


?? TITLE := 'MMP$MOVE_PAGES' ??
?? EJECT ??
{--------------------------------------------------------------------------------------------------------
*copyc mmh$move_pages
{--------------------------------------------------------------------------------------------------------
?? EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$move_pages
    (    pva_source: ^cell;
         pva_destination: ^cell;
         length: ost$segment_length;
         modified_bit_option: mmt$modified_bit_option;
         reject_move_if_source_modified: boolean;
     VAR moved_modified_page_count: mmt$move_pages_page_count;
     VAR status: ost$status);

    VAR
      dummy_modified_count: mmt$move_pages_page_count,
      dummy: integer,
      i: integer,
      ignore_status: ost$status,
      number_of_bytes_moved: ost$segment_length,
      number_of_pages_moved: mmt$move_pages_page_count,
      number_of_pages_to_move: mmt$move_pages_page_count,
      offset_pva_destination: integer,
      offset_pva_source: integer,
      page_size: integer,
      rb: mmt$rb_move_pages,
      reference_page: ^array [1..512] of integer,
      xpva_destination: ^cell,
      xlength: ost$segment_length,
      xpva_source: ^cell;


    #keypoint (osk$entry, #segment (pva_source) * osk$m, mmk$move_pages);

    status.normal := TRUE;

    mmp$get_page_size (page_size);
    offset_pva_source := #offset (pva_source);
    offset_pva_destination := #offset (pva_destination);

{ Verify the length parameter.  Verification of the pva's will be done in monitor
{ mode to prevent duplication of checks.

    IF (length <= 0) OR (length > mmc$move_pages_max_req_length) THEN
      osp$set_status_abnormal ('MM', mme$invalid_length_requested, '', status);
      #keypoint (osk$exit, 0, mmk$move_pages);
      RETURN;
    IFEND;

    IF (length MOD page_size <> 0) THEN
      osp$set_status_abnormal ('MM', mme$length_not_page_size_mult, '', status);
      #keypoint (osk$exit, 0, mmk$move_pages);
      RETURN;
    IFEND;

{ Determine the number of pages to move.

    number_of_pages_to_move := length DIV page_size;

    number_of_pages_moved := 0;
    moved_modified_page_count := 0;

{ Issue a monitor request to move the pages.

  /move_pages/

    WHILE (number_of_pages_moved < number_of_pages_to_move) DO
      number_of_bytes_moved := page_size * number_of_pages_moved;
      xpva_source := #address (1, #segment (pva_source), (offset_pva_source + number_of_bytes_moved));
      xpva_destination := #address (1, #segment (pva_destination),
            (offset_pva_destination + number_of_bytes_moved));
      xlength := length - number_of_bytes_moved;

{ Reference each source page so that it is in memory.

      reference_page := xpva_source;
      FOR i := (number_of_pages_moved + 1) TO number_of_pages_to_move  DO
        dummy := reference_page^ [1];
        reference_page := #address (1, #segment (xpva_source), (#offset (xpva_source) + page_size));
      FOREND;

      rb.reqcode := syc$rc_move_pages;
      rb.pva_source := xpva_source;
      rb.pva_destination := xpva_destination;
      rb.length := xlength;
      rb.modified_bit_option := modified_bit_option;
      rb.reject_move_if_source_modified := reject_move_if_source_modified;

      i#call_monitor (#LOC (rb), #SIZE (rb));

      number_of_pages_moved := number_of_pages_moved + rb.number_of_pages_moved;
      moved_modified_page_count := moved_modified_page_count + rb.moved_modified_page_count;

      IF NOT rb.status.normal THEN
        IF (rb.status.condition = mme$source_page_not_in_memory) THEN
          { do nothing, at the beginning of the loop each page is referenced to get it in memory

        ELSEIF (rb.status.condition = mme$dm_assign_active) THEN

{ Do nothing.  In monitor, a flag was set which should have gotten the job to trap to process the extension
{ for the destination page's segment.  By the time the job gets here, the allocation should have been done.

        ELSEIF (rb.status.condition = mme$io_active_on_move_page) THEN
          pmp$delay (20, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        ELSEIF (rb.status.condition = mme$page_table_full) THEN
          { give up the CPU so memory manager can rectify the condition
          pmp$cycle (ignore_status);

        ELSEIF (rb.status.condition = mme$modified_source_page_reject) THEN
          { put any pages that have been moved back where they were
          IF number_of_pages_moved > 0 THEN
            mmp$move_pages (pva_destination, pva_source, (number_of_pages_moved * page_size),
                  mmc$mp_clear_modified, FALSE, dummy_modified_count, status);
            IF NOT status.normal THEN
              osp$system_error ('Unable to back out of mmp$move_pages upon modified reject', ^status);
            IFEND;
          IFEND;
          moved_modified_page_count := 0;
          osp$set_status_abnormal ('MM', mme$modified_source_page_reject, '', status);
          #keypoint (osk$exit, 0, mmk$move_pages);
          RETURN;

        ELSE
          osp$set_status_from_mtr_status (rb.status, status);
          #keypoint (osk$exit, 0, mmk$move_pages);
          RETURN;
        IFEND;
      IFEND;
    WHILEND /move_pages/;

  PROCEND mmp$move_pages;

?? TITLE := 'mmp$read' ??
?? EJECT ??
{--------------------------------------------------------------------------------------------------------
*copyc mmh$read
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL, #GATE] mmp$read (pva: ^cell;
        length: ost$segment_length;
        iostatus_p: ^mmt$io_status;
        wait: ost$wait;
    VAR status: ost$status);

    VAR
      pages_in_memory: boolean,
      done: boolean,
      rb: mmt$rb_memory_manager_io;

    #keypoint (osk$entry, #segment (pva) * osk$m, mmk$read);

    IF length > max_length THEN
      osp$set_status_abnormal ('MM', mme$request_length_too_long, ' ', status);
      #keypoint (osk$exit, 0, mmk$read);
      RETURN;
    IFEND;

    IF #offset (pva) + length > osc$max_segment_length THEN
      osp$set_status_abnormal ('MM', mme$invalid_pva_formed, ' ', status);
      #keypoint (osk$exit, 0, mmk$read);
      RETURN;
    IFEND;

    REPEAT
{Set up the request block and call monitor.

      status.normal := TRUE;

      done := TRUE;

      rb.reqcode := syc$rc_memory_manager_io;
      rb.status.normal := TRUE;
      rb.condition := 0;
      rb.active_io_count := 0;
      rb.pva := pva;
      rb.length := length;
      rb.stat_p := iostatus_p;
      rb.waitopt := wait;
      rb.sub_reqcode := mmc$iorc_read_pages;
      i#call_monitor (#LOC (rb), #SIZE (rb));
      osp$set_status_from_mtr_status (rb.status, status);

      IF NOT rb.status.normal THEN
        IF rb.status.condition = mme$nil_io_control_block THEN
          mmp$allocate_iocb_r3;
          done := FALSE;
        ELSEIF rb.status.condition = mme$full_io_control_block THEN
          mmp$wait_for_iocb_entry (status);
          IF status.normal THEN
            done := FALSE;
          IFEND;
        ELSEIF rb.status.condition = mme$page_found_in_memory THEN
          status.normal := TRUE;
          mmp$check_if_pages_in_memory (rb.pva, rb.length, pages_in_memory);
          IF pages_in_memory THEN
            iostatus_p^.request_status := mmc$irs_complete;
            iostatus_p^.condition := 0;
          ELSE
            done := FALSE;
          IFEND;
        ELSEIF rb.status.condition = mme$volume_unavailable THEN
          done := FALSE;
          osp$wait_on_condition (rb.status.condition);
        ELSE
          iostatus_p^.request_status := mmc$irs_none;
        IFEND;
      ELSE
        IF wait = osc$wait THEN
          iostatus_p^.request_status := mmc$irs_complete;
          iostatus_p^.condition := rb.condition;
          IF rb.condition = 0 THEN
            mmp$check_if_pages_in_memory (rb.pva, rb.length, pages_in_memory);
            IF NOT pages_in_memory THEN
              done := FALSE;
            IFEND;
          IFEND;
        ELSE
          iostatus_p^.request_status := mmc$irs_active;
        IFEND;
      IFEND;
    UNTIL done;

    #keypoint (osk$exit, 0, mmk$read);

  PROCEND mmp$read;

?? TITLE := 'mmp$write' ??
?? EJECT ??
{--------------------------------------------------------------------------------------------------------
*copyc mmh$write
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL, #GATE] mmp$write (pva: ^cell;
        length: ost$segment_length;
        remove_pages: boolean;
        iostatus_p: ^mmt$io_status;
        wait: ost$wait;
    VAR status: ost$status);

    VAR
      reallocate_count: integer,
      rb: mmt$rb_memory_manager_io;

    #keypoint (osk$entry, #segment (pva) * osk$m, mmk$write);

    IF length > max_length THEN
      osp$set_status_abnormal ('MM', mme$request_length_too_long, ' ', status);
      #keypoint (osk$exit, 0, mmk$write);
      RETURN;
    IFEND;

    IF #offset (pva) + length > osc$max_segment_length THEN
      osp$set_status_abnormal ('MM', mme$invalid_pva_formed, ' ', status);
      #keypoint (osk$exit, 0, mmk$write);
      RETURN;
    IFEND;

{Set up the request block and call monitor.

    status.normal := TRUE;

    reallocate_count := 0;
  /reallocate/
    WHILE TRUE DO

    rb.reqcode := syc$rc_memory_manager_io;
    rb.status.normal := TRUE;
    rb.condition := 0;
    rb.active_io_count := 0;
    rb.pva := pva;
    rb.length := length;
    rb.stat_p := iostatus_p;
    rb.waitopt := wait;

{   Mmp$mtr_write will modify rb.init_new_io to FALSE if call is reissued for the wait option.

    rb.init_new_io := TRUE;
    rb.sub_reqcode := mmc$iorc_write_pages;
    rb.remove_pages := remove_pages;
    i#call_monitor (#LOC (rb), #SIZE (rb));
    osp$set_status_from_mtr_status (rb.status, status);

    IF NOT rb.status.normal THEN
      IF rb.status.condition = mme$nil_io_control_block THEN
        mmp$allocate_iocb_r3;
        mmp$write (pva, length, remove_pages, iostatus_p, wait, status);
      ELSEIF rb.status.condition = mme$full_io_control_block THEN
        mmp$wait_for_iocb_entry (status);
        IF status.normal THEN
          mmp$write (pva, length, remove_pages, iostatus_p, wait, status);
        IFEND;
      ELSEIF rb.status.condition = ioc$disk_media_error THEN
        iostatus_p^.request_status := mmc$irs_complete;
        iostatus_p^.condition := rb.status.condition;
        status.normal := TRUE;
      ELSEIF rb.status.condition = mme$volume_unavailable THEN
        iostatus_p^.request_status := mmc$irs_complete;
        iostatus_p^.condition := rb.status.condition;
        status.normal := TRUE;
      ELSEIF rb.status.condition = mme$write_status_complete THEN
        iostatus_p^.request_status := mmc$irs_complete;
        iostatus_p^.condition := 0;
        status.normal := TRUE;
      ELSE
        iostatus_p^.request_status := mmc$irs_none;
      IFEND;
    ELSE
      IF wait = osc$wait THEN
        iostatus_p^.request_status := mmc$irs_complete;
        iostatus_p^.condition := rb.condition;
      ELSE
        iostatus_p^.request_status := mmc$irs_active;
      IFEND;
    IFEND;

    IF iostatus_p^.request_status = mmc$irs_complete THEN
      IF iostatus_p^.condition = ioc$disk_media_error THEN
        reallocate_count := reallocate_count + 1;
        IF reallocate_count < 4 THEN
          mmp$reallocate_file_space (pva, status);
          IF status.normal THEN
            CYCLE /reallocate/;
          ELSE
            status.normal := TRUE;
          IFEND;
        ELSE
          status.normal := TRUE;
        IFEND;
      ELSEIF iostatus_p^.condition = mme$volume_unavailable THEN
        osp$wait_on_condition (iostatus_p^.condition);
        CYCLE /reallocate/;
      IFEND;
    IFEND;

    EXIT /reallocate/;
    WHILEND /reallocate/;

    #keypoint (osk$exit, 0, mmk$write);

  PROCEND mmp$write;

?? TITLE := 'MMP$ASSIGN_PAGES' ??
?? EJECT ??

*copyc mmh$assign_pages

  PROCEDURE [XDCL, #GATE] mmp$assign_pages (pva: ^cell;
        length: ost$segment_length;
        preset_pages: boolean;
        wait: ost$wait;
    VAR status: ost$status);

    CONST
      word_size = 8;

    VAR
      caller_id: ost$caller_identifier,
      dummy: pmt$initialization_value,
      full_page_between: boolean,
      i: integer,
      offset_pva: integer,
      p_first_partial_page: ^array [1 .. 2048] of pmt$initialization_value,
      p_last_partial_page: ^array [1 .. 2048] of pmt$initialization_value,
      p_last_word: ^array [1 .. 1] of integer,
      p_preset: ^array [1 .. 1] of pmt$initialization_value,
      page_size: integer,
      partial_first_page: boolean,
      partial_first_page_bytes: integer,
      partial_first_word_bytes: 0..7fffffff(16),
      partial_first_page_word_count: integer,
      partial_first_word: boolean,
      partial_last_page: boolean,
      partial_last_page_bytes: integer,
      partial_last_word_bytes: 0..7fffffff(16),
      partial_last_page_word_count: integer,
      partial_last_word: boolean,
      part_last_word_in_1st_page: boolean,
      preset_value: pmt$initialization_value,
      rb: mmt$rb_assign_pages,
      rb_c: mmt$rb_assign_pages,
      segment_pva: 0..0ffff(16),
      seg_attributes: array [1..1] of mmt$attribute_descriptor,
      te: 0..3,
      try: boolean,
      xlength: ost$segment_length,
      xpva: ^cell,
      ucr: record
        case 0..1 of
        = 0 =
          register: integer,
        = 1 =
          fill: 0 .. 0ffffffffffff(16),
          user_mask: ost$user_conditions,
        casend,
        recend;

    PROCEDURE ch (condition: pmt$condition;
          condition_info: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      handler_status.normal := TRUE;
      local_status.normal := TRUE;
      CASE condition.selector OF
      = ifc$interactive_condition =
        IF condition.interactive_condition <> ifc$terminate_break THEN
          IF condition.interactive_condition = ifc$pause_break THEN
            ifp$invoke_pause_utility (local_status);
            RETURN;
          ELSE
            pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
            RETURN;
          IFEND;
        IFEND;
        ofp$display_status_message (' Terminate break received while requesting to assign memory.',
              local_status);
        pmp$log (' Terminate break received while requesting to assign memory.', local_status);
        pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
        osp$set_status_from_condition ('MM', condition, save_area, status, local_status);
        IF NOT local_status.normal THEN
          status := local_status;
        IFEND;
        EXIT mmp$assign_pages;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
      CASEND;
    PROCEND ch;


    #keypoint (osk$entry, #segment (pva) * osk$m, mmk$assign_pages);

    status.normal := TRUE;
    rb.status.normal := TRUE;

    offset_pva := #offset (pva);
    segment_pva := #segment (pva);

    IF offset_pva + length > osc$max_segment_length THEN
      osp$set_status_abnormal ('MM', mme$invalid_pva_formed, ' ', status);
      #keypoint (osk$exit, 0, mmk$assign_pages);
      RETURN;
    IFEND;

    IF length <= 0 THEN
      osp$set_status_abnormal ('MM', mme$length_must_be_positive, ' ', status);
      #keypoint (osk$exit, 0, mmk$assign_pages);
      RETURN;
    IFEND;

    osp$establish_condition_handler(^ch, TRUE);

    partial_first_page := FALSE;
    partial_first_word := FALSE;
    partial_last_page := FALSE;
    partial_last_word := FALSE;
    part_last_word_in_1st_page := FALSE;
    full_page_between := FALSE;

    mmp$get_page_size (page_size);

{ Round up and down so that the monitor request is for full pages only.  The variables XPVA
{ and XLENGTH are used for the rounding calculations and issued to the monitor request.
{ Partial pages are referenced to read them into memory.  In order to preset partial pages, it is
{ necessary to determine where the request begins and ends with respect to partial first
{ and last pages and words and whether the request is wholly contained within one page.

    xpva := pva;

{ Determine where the request begins

    IF ((offset_pva MOD page_size) <> 0) OR (length < page_size) THEN

{ The request does not begin on a page boundary or is for less than one full page.

      xpva := #address (1, segment_pva, (((offset_pva DIV page_size)
             * page_size) + page_size));
      partial_first_page := TRUE;
      partial_first_page_bytes := (page_size - (offset_pva MOD page_size));
      IF length > partial_first_page_bytes THEN
        xlength := length - partial_first_page_bytes;
      ELSE   { The request is for less than one page }
        xlength := 0;
        partial_first_page_bytes := length;
      IFEND;
      partial_first_word_bytes := word_size - (offset_pva MOD word_size);
      IF partial_first_word_bytes <> word_size THEN
        partial_first_word := TRUE;
        IF (offset_pva + partial_first_word_bytes) <> page_size THEN
          { The new address will be in the same page.
          p_first_partial_page := #address (1, segment_pva, (offset_pva + partial_first_word_bytes));
        ELSE
          p_first_partial_page := pva;
        IFEND;
        IF (offset_pva + length) <= word_size THEN
          {The request is contained in one word.
          p_first_partial_page := pva;
          partial_first_word_bytes := length;
        IFEND;
        partial_first_page_word_count := (partial_first_page_bytes - partial_first_word_bytes) DIV
              word_size;
      ELSE
        partial_first_word_bytes := 0;
        p_first_partial_page := pva;
        partial_first_page_word_count := partial_first_page_bytes DIV word_size;
      IFEND;

{ IF xlength is 0 then the request is contained in one page; determine if there is a partial last word.

      IF xlength = 0 THEN
        partial_last_word_bytes := (partial_first_page_bytes - partial_first_word_bytes) MOD word_size;
        IF partial_last_word_bytes <> 0 THEN
          part_last_word_in_1st_page := TRUE;
          p_last_word := #address (1, segment_pva, (#offset (p_first_partial_page) +
                (partial_first_page_word_count * word_size)));
        IFEND;
      IFEND;
    ELSE

{ The request begins on a page boundary and is for at least one complete page.

      xlength := length;
    IFEND;

{ Determine where the request ends

    partial_last_page_bytes := (xlength MOD page_size);
    IF partial_last_page_bytes  <> 0 THEN
      partial_last_page := TRUE;
      xlength := xlength - partial_last_page_bytes;
      partial_last_word_bytes := partial_last_page_bytes MOD word_size;
      partial_last_page_word_count := (partial_last_page_bytes - partial_last_word_bytes) DIV word_size;
      p_last_partial_page := #address (1, #segment (xpva), (#offset (xpva) + xlength));
      IF partial_last_word_bytes <> 0 THEN
        partial_last_word := TRUE;
        p_last_word := #address (1, segment_pva, (offset_pva + length - partial_last_word_bytes));
      IFEND;
    IFEND;

    IF xlength > 0 THEN
      full_page_between := TRUE;
      p_preset := xpva;
    IFEND;
      try := false;
    REPEAT
      i#disable_traps (te);

       /get_page/
      REPEAT
        status.normal := TRUE;

        { Reference partial pages (if there are any) so they will be read into memory.
        IF partial_first_page THEN
          dummy := p_first_partial_page^ [1];
        IFEND;

        IF partial_last_page THEN
          dummy := p_last_partial_page^ [1];
        IFEND;

        { Issue a monitor request to assign full pages.
        IF full_page_between THEN
          rb.reqcode := syc$rc_assign_pages;
          rb.status.normal := TRUE;
          rb.sub_reqcode := mmc$aprc_assign;
          rb.pva := xpva;
          rb.length := xlength;
          rb.preset_pages := preset_pages;
          rb.waitopt := wait;
          i#call_monitor (#LOC (rb), #SIZE (rb));
        IFEND;
        ucr.register := #read_register (osc$pr_user_condition_reg);

        IF NOT rb.status.normal THEN

          IF rb.status.condition = mme$memory_not_avail_for_assign THEN
             IF NOT try THEN
                try := true;
                 pmp$wait (1000, 1000);
                   CYCLE /get_page/;
             IFEND;
          ELSEIF rb.status.condition = mme$wait_so_other_tasks_can_run THEN
            pmp$wait (1000, 1000);
          ELSEIF (rb.status.condition <> mme$dm_assign_active) AND
                (rb.status.condition <> mme$temporary_reject) AND
                (rb.status.condition <> mme$page_table_full) AND
                (((rb.status.condition = mme$memory_not_avail_for_assign) AND
                (rb.waitopt = osc$nowait)) OR
                (rb.status.condition <> mme$memory_not_avail_for_assign)) THEN
            osp$set_status_from_mtr_status (rb.status, status);
            rb.status.normal := TRUE;
          IFEND;
        IFEND;

      UNTIL (rb.status.normal) OR (osc$free_flag IN ucr.user_mask);

      IF (osc$free_flag IN ucr.user_mask) THEN

{ Before handling interrupts, cancel any reserve requests the job has so that memory is
{ not reserved indefinitely.

        rb_c.reqcode := syc$rc_assign_pages;
        rb_c.status.normal := TRUE;
        rb_c.sub_reqcode := mmc$aprc_cancel_reserve;
        i#call_monitor (#LOC (rb_c), #SIZE (rb_c));
      IFEND;

      i#restore_traps (te);

{ Call long term wait to force a task switch, which causes signals to be processed, if the free flag was set.
      IF (osc$free_flag IN ucr.user_mask) THEN
        #CALLER_ID (caller_id);
        IF caller_id.ring <= osc$tsrv_ring THEN
          pmp$long_term_wait (0,0);
        IFEND;
      IFEND;

    UNTIL rb.status.normal;

    IF status.normal AND preset_pages AND (partial_first_page OR partial_last_page) THEN

{ Preset partial pages.  If a full page was assigned, then that page can be read to determine
{ the preset value; otherwise the preset value must be determined from the segment attributes.
{ NOTE:  The fastest way to preset the a partial page is to treat the page as an array of words.
{ The starting address and number of words have been determined earlier.

      IF NOT full_page_between THEN
        seg_attributes [1].keyword := mmc$kw_preset_value;
        mmp$fetch_segment_attributes (pva, seg_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        preset_value := seg_attributes [1].preset_value;
      ELSE
        preset_value := p_preset^ [1];
      IFEND;

{ Preset partial first page.

      IF partial_first_page THEN
        FOR i := 1 TO partial_first_page_word_count DO
          p_first_partial_page^ [i] := preset_value;
        FOREND;
        IF partial_first_word THEN
          i#move (^preset_value, pva, partial_first_word_bytes);
        IFEND;
        IF part_last_word_in_1st_page THEN
          i#move (^preset_value, p_last_word, partial_last_word_bytes);
        IFEND;
      IFEND;

{ Preset partial last page.

      IF partial_last_page THEN
        FOR i := 1 TO partial_last_page_word_count DO
          p_last_partial_page^ [i] := preset_value;
        FOREND;
        IF partial_last_word THEN
          i#move (^preset_value, p_last_word, partial_last_word_bytes);
        IFEND;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;
    #keypoint (osk$exit, 0, mmk$assign_pages);

  PROCEND mmp$assign_pages;

?? TITLE := 'MMP$CONDITIONAL_FREE' ??
?? EJECT ??

*copyc mmh$conditional_free

  PROCEDURE [XDCL, #GATE] mmp$conditional_free ( pva: ^cell;
        length: ost$segment_length;
    VAR status: ost$status);

    VAR
      page_size: integer,
      rb: mmt$rb_free_flush,
      xlength: ost$segment_length,
      xpva: ^cell;

    #keypoint (osk$entry, #segment (pva) * osk$m, mmk$conditional_free);
    status.normal := TRUE;

    IF #offset (pva) + length > osc$max_segment_length THEN
      osp$set_status_abnormal ('MM', mme$invalid_pva_formed, ' ', status);
      #keypoint (osk$exit, 0, mmk$conditional_free);
      RETURN;
    IFEND;

    IF length <= 0 THEN
      osp$set_status_abnormal ('MM', mme$length_must_be_positive, ' ', status);
      #keypoint (osk$exit, 0, mmk$conditional_free);
      RETURN;
    IFEND;

    mmp$get_page_size (page_size);

    { Round up and down so that the monitor request is for full pages only.
    xpva := pva;
    IF (#offset (pva) MOD page_size) <> 0 THEN
      xpva := #address (#ring (pva), #segment (pva), (((#offset (pva) DIV page_size)
            * page_size) + page_size));
      xlength := length - (page_size - (#offset (pva) MOD page_size));
    ELSE
      xlength := length;
    IFEND;
    IF ((#offset (xpva) + xlength) MOD page_size) <> 0 THEN
      xlength := xlength - (xlength MOD page_size);
    IFEND;

    rb.reqcode := syc$rc_conditional_free;
    rb.pva := xpva;
    rb.length := xlength;
    rb.waitopt := osc$nowait;
    i#call_monitor (#LOC (rb), #SIZE(rb));
    osp$set_status_from_mtr_status (rb.status, status);

    #keypoint (osk$exit, 0, mmk$conditional_free);

  PROCEND mmp$conditional_free;

MODEND mmm$read_write_io_ring_any;
*DECK DECK=MMM$RING1_HELPER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE MEMORY MANAGEMENT - RING1 HELPER ROUTINES' ??
MODULE mmm$ring1_helper;

{ PURPOSE:
{   This module contains memory manager procedures that run in ring 1 task services.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc mme$condition_codes
*copyc mmt$manage_memory_utility
*copyc mmt$page_frame_queue_id
*copyc mmt$page_q_counts
*copyc oss$mainframe_paged_literal
?? POP ??
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc jmv$ijl_p
*copyc mmv$age_interval_ceiling
*copyc mmv$age_interval_floor
*copyc mmv$aggressive_aging_level
*copyc mmv$aging_algorithm
*copyc mmv$avail_modified_queue_max
*copyc mmv$gpql
*copyc mmv$jws_queue_age_interval
*copyc mmv$last_active_shared_queue
*copyc mmv$max_pages_no_file
*copyc mmv$min_avail_pages
*copyc mmv$page_streaming_prestream
*copyc mmv$page_streaming_threshold
*copyc mmv$page_streaming_transfer
*copyc mmv$page_streaming_reads
*copyc mmv$page_streaming_random_limit
*copyc mmv$periodic_call_interval
*copyc mmv$shared_queue_age_interval
*copyc mmv$swapping_aic
*copyc mmv$tick_time
?? OLDTITLE ??
?? NEWTITLE := 'Glocal Declarations Delcared by This Module', EJECT ??
  VAR
    mmv$manage_memory_utility: [XDCL] mmt$manage_memory_utility:=  [
      [ [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],  [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],
        [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],  [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],
        [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],  [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],
        [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],  [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],
        [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],  [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],
        [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],  [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],
        [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],  [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],
        [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],  [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],
        [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],  [[[0,0],0],0,0,0], [[[0,0],0],0,0,0],
        [[[0,0],0],0,0,0], [[[0,0],0],0,0,0]],

{ Note: The following entries must be in the same order as defined in the ordinal mmt$mmu_memory_attributes

     [  [ 0, mmc$mmu_mvt_byte, ^mmv$age_interval_ceiling],                     {mmc$mmu_ma_aic
        [ 0, mmc$mmu_mvt_byte, ^mmv$age_interval_floor],                       {mmc$mmu_ma_aif
        [ 0, mmc$mmu_mvt_integer, ^mmv$aggressive_aging_level],                {mmc$mmu_ma_aal
        [ 0, mmc$mmu_mvt_integer, ^mmv$aggressive_aging_level_2],              {mmc$mmu_ma_aal2
        [ 0, mmc$mmu_mvt_integer, ^mmv$aging_algorithm],                       {mmc$mmu_ma_aa
        [ 0, mmc$mmu_mvt_integer, ^mmv$avail_modified_queue_max],              {mmc$mmu_ma_amqm
        [ 0, mmc$mmu_mvt_integer, ^mmv$jws_queue_age_interval],                {mmc$mmu_ma_jwsai
        [ 0, mmc$mmu_mvt_integer, ^mmv$min_avail_pages],                       {mmc$mmu_ma_minap
        [ 0, mmc$mmu_mvt_byte,    ^mmv$page_streaming_random_limit],           {mmc$mmu_ma_psrl
        [ 0, mmc$mmu_mvt_byte,    ^mmv$page_streaming_reads],                  {mmc$mmu_ma_psr
        [ 0, mmc$mmu_mvt_byte,    ^mmv$page_streaming_prestream],              {mmc$mmu_ma_psp
        [ 0, mmc$mmu_mvt_integer, ^mmv$page_streaming_threshold],              {mmc$mmu_ma_pst
        [ 0, mmc$mmu_mvt_integer, ^mmv$page_streaming_transfer],               {mmc$mmu_ma_psts
        [ 0, mmc$mmu_mvt_integer, ^mmv$periodic_call_interval],                {mmc$mmu_ma_pci
        [ 0, mmc$mmu_mvt_integer, ^mmv$shared_queue_age_interval],             {mmc$mmu_ma_swsai
        [ 0, mmc$mmu_mvt_integer, ^mmv$swapping_aic],                          {mmc$mmu_ma_sa
        [ 0, mmc$mmu_mvt_integer, ^mmv$tick_time] ]];                          {mmc$mmu_ma_tt
?? OLDTITLE ??
?? NEWTITLE := 'mmp$disable_transient_segments', EJECT ??

{ PURPOSE:
{   Thiss procedure is used at deadstart time to temporarily disable transient segments. This is required
{   until Device Manager SPACE MANAGER is running. Otherwise, Space manager may get transient segments in
{   its address space. If the signal to allocate the backing file occurs when MAT space is low, space
{   manager may hang.

  PROCEDURE [XDCL] mmp$disable_transient_segments;

    mmv$max_pages_no_file := -mmv$max_pages_no_file - 1;

  PROCEND mmp$disable_transient_segments;
?? OLDTITLE ??
?? NEWTITLE := 'mmp$enable_transient_segments', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$enable_transient_segments;

    IF mmv$max_pages_no_file < 0 THEN
      mmv$max_pages_no_file := -mmv$max_pages_no_file - 1;
    IFEND;

  PROCEND mmp$enable_transient_segments;
?? OLDTITLE ??
?? NEWTITLE := 'mmp$fetch_manage_memory_data_r1', EJECT ??

{ PURPOSE:
{   This procedure retrieves the data that can be changed by the Manage Memory Utility.  Although only part
{   of the data is usually needed, the interface between ring1 and the Manage_Memory Utility is kept simple
{   by passing all of the possible data required.

  PROCEDURE [XDCL, #GATE] mmp$fetch_manage_memory_data_r1
    (VAR queues: mmt$global_page_queue_list;
     VAR ma_values: mmt$mmu_ma_values;
     VAR gpql_default: mmt$mmu_gpql_default;
     VAR ma_default: mmt$mmu_ma_default);

    VAR
      ma_index: mmt$mmu_memory_attributes,
      queue_id: mmt$page_frame_queue_id;

    FOR ma_index := LOWERBOUND (mmv$manage_memory_utility.ma) TO UPPERBOUND (mmv$manage_memory_utility.ma) DO
      ma_default [ma_index] := mmv$manage_memory_utility.ma [ma_index].default;
      IF mmv$manage_memory_utility.ma [ma_index].value_type = mmc$mmu_mvt_integer THEN
        ma_values [ma_index] := mmv$manage_memory_utility.ma [ma_index].integer_p^;
      ELSE { mmc$mmu_mvt_byte }
        ma_values [ma_index] := mmv$manage_memory_utility.ma [ma_index].byte_p^;
      IFEND;
    FOREND;

    FOR queue_id := mmc$pq_shared_first TO mmc$pq_shared_last DO
      queues [queue_id].age_interval := mmv$gpql [queue_id].age_interval;
      queues [queue_id].minimum := mmv$gpql [queue_id].minimum;
      queues [queue_id].maximum := mmv$gpql [queue_id].maximum;
    FOREND;

    gpql_default := mmv$manage_memory_utility.gpql;

  PROCEND  mmp$fetch_manage_memory_data_r1;
?? OLDTITLE ??
?? NEWTITLE := 'mmp$fetch_site_active_q_cnt_r1', EJECT ??

{ PURPOSE:
{   This procedure retrieves the site active queue count.

  PROCEDURE [XDCL, #GATE] mmp$fetch_site_active_q_cnt_r1
    (VAR site_active_queue_count: 0 .. mmc$pq_shared_num_sites);

    site_active_queue_count := mmv$last_active_shared_queue - mmc$pq_shared_last_sys;

 PROCEND mmp$fetch_site_active_q_cnt_r1;
?? OLDTITLE ??
?? NEWTITLE := 'mmp$get_page_q_counts', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$get_page_q_counts
    (VAR counts: mmt$page_q_counts);

    VAR
      i: integer,
      ijle_p: ^jmt$initiated_job_list_entry,
      index: integer,
      j: integer;

    FOR index := LOWERVALUE (mmt$global_page_queue_index) TO UPPERVALUE (mmt$global_page_queue_index) DO
      counts.q_counts [index] := mmv$gpql [index].pqle.count;
    FOREND;
    counts.site_defined_queues_active := mmv$last_active_shared_queue - mmc$pq_shared_last_sys;

    { Now add up pages associated with each job.

    counts.long_wait_count := 0;
    counts.swap_resident_count := 0;
    counts.q_counts [mmc$pq_job_fixed] := 0;
    counts.q_counts [mmc$pq_job_io_error] := 0;
    counts.q_counts [mmc$pq_job_working_set] := 0;

  /scan_ijl/
    FOR i := LOWERBOUND (jmv$ijl_p.block_p^) TO jmv$ijl_p.max_block_in_use DO
      IF jmv$ijl_p.block_p^[i].index_p <> NIL THEN

     /inner_loop/
        FOR j := LOWERVALUE (jmt$ijl_block_index) TO UPPERVALUE (jmt$ijl_block_index) DO
          ijle_p := ^jmv$ijl_p.block_p^ [i].index_p^ [j];

          IF ijle_p^.swap_status = jmc$iss_executing THEN
            counts.q_counts [mmc$pq_job_fixed] := counts.q_counts [mmc$pq_job_fixed] +
                  ijle_p^.job_page_queue_list [mmc$pq_job_fixed].count;
            counts.q_counts [mmc$pq_job_io_error] := counts.q_counts [mmc$pq_job_io_error] +
                  ijle_p^.job_page_queue_list [mmc$pq_job_io_error].count;
            counts.q_counts [mmc$pq_job_working_set] := counts.q_counts [mmc$pq_job_working_set] +
                  ijle_p^.job_page_queue_list [mmc$pq_job_working_set].count;

          ELSEIF (ijle_p^.swap_status >= jmc$iss_idle_tasks_initiated) AND
                (ijle_p^.swap_status <= jmc$iss_swapped_io_cannot_init) THEN
            counts.long_wait_count := counts.long_wait_count + ijle_p^.job_page_queue_list
                  [mmc$pq_job_fixed].count + ijle_p^.job_page_queue_list [mmc$pq_job_io_error].count +
                  ijle_p^.job_page_queue_list [mmc$pq_job_working_set].count;

          ELSEIF (ijle_p^.swap_status >= jmc$iss_initiate_swapout_io) AND
                (ijle_p^.swap_status <= jmc$iss_swapped_io_complete) THEN
            counts.swap_resident_count := counts.swap_resident_count + ijle_p^.job_page_queue_list
                  [mmc$pq_job_fixed].count + ijle_p^.job_page_queue_list [mmc$pq_job_io_error].count +
                  ijle_p^.job_page_queue_list [mmc$pq_job_working_set].count;
          IFEND;
        FOREND /inner_loop/;
      IFEND;
    FOREND /scan_ijl/;

  PROCEND mmp$get_page_q_counts;
?? OLDTITLE ??
?? NEWTITLE := 'mmp$store_manage_memory_data_r1', EJECT ??

{ PURPOSE:
{   This procedure stores the data that can be changed by the Manage Memory Utility.  Although only part of
{   the data is usually needed, the interface between ring1 and the Manage_Memory Utility is kept simple by
{   passing all of the possible data required.

  PROCEDURE [XDCL, #GATE] mmp$store_manage_memory_data_r1
    (VAR queues: mmt$global_page_queue_list;
     VAR ma_values: mmt$mmu_ma_values);

    VAR
      ma_index: mmt$mmu_memory_attributes,
      queue_id: mmt$page_frame_queue_id;

    { Store the values contained in the input into the memory attributes and into the queue header.  Be sure
    { that the link headers in the queue headers are not changed.

    FOR ma_index := LOWERBOUND (mmv$manage_memory_utility.ma) TO UPPERBOUND (mmv$manage_memory_utility.ma) DO
      IF mmv$manage_memory_utility.ma [ma_index].value_type = mmc$mmu_mvt_integer THEN
        mmv$manage_memory_utility.ma [ma_index].integer_p^ := ma_values [ma_index];
      ELSE { mmc$mmu_mvt_byte }
        mmv$manage_memory_utility.ma [ma_index].byte_p^ := ma_values [ma_index];
      IFEND;
    FOREND;

    FOR queue_id := mmc$pq_shared_first TO mmc$pq_shared_last DO
      mmv$gpql [queue_id].age_interval := queues [queue_id].age_interval;
      mmv$gpql [queue_id].minimum := queues [queue_id].minimum;
      mmv$gpql [queue_id].maximum := queues [queue_id].maximum;
    FOREND;

  PROCEND  mmp$store_manage_memory_data_r1;
?? OLDTITLE ??
?? NEWTITLE := 'mmp$store_site_active_q_cnt_r1', EJECT ??

{ PURPOSE:
{   This procedure changes the site active queue count value.

  PROCEDURE [XDCL, #GATE] mmp$store_site_active_q_cnt_r1
    (    new_site_active_queue_count: 0 .. mmc$pq_shared_num_sites;
     VAR status: ost$status);

    VAR
      index: mmt$page_frame_queue_id,
      pages: integer;

    status.normal := TRUE;

    IF (mmc$pq_shared_last_sys + new_site_active_queue_count) < mmv$last_active_shared_queue THEN
      pages := 0;
      FOR index := (mmc$pq_shared_last_sys + new_site_active_queue_count + 1) TO
            mmv$last_active_shared_queue DO
        pages := pages + mmv$gpql [index].pqle.count;
      FOREND;
      IF pages <> 0 THEN
        osp$set_status_abnormal ('MM', mme$site_shared_queues_active, '', status);
        RETURN;
      IFEND;
    IFEND;

    mmv$last_active_shared_queue := mmc$pq_shared_last_sys + new_site_active_queue_count;

 PROCEND mmp$store_site_active_q_cnt_r1;
?? OLDTITLE ??
MODEND mmm$ring1_helper;
*DECK DECK=MMM$SEGMENT_FAULT_HANDLER EXPAND=TRUE
?? RIGHT := 110, LEFT := 1 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
?? NEWTITLE := 'mmm$segemnt_fault_handler' ??
MODULE mmm$segment_fault_handler;

{
{  PURPOSE:
{    This module processes segment access monitor faults in job mode.
{
{


?? PUSH (LISTEXT := ON) ??
*copyc MMD$SEGMENT_ACCESS_CONDITION
*copyc OST$MONITOR_FAULT
*copyc OST$STACK_FRAME_SAVE_AREA
?? POP ??


{  External procedures called:

*copyc PMP$DISPOSE_SEGMENT_ACCESS_COND

?? TITLE := 'mmp$segment_fault_handler' ??
?? EJECT ??

  PROCEDURE [XDCL] mmp$segment_fault_handler (segment_access_fault {input} : ost$monitor_fault;
        fault_save_area_p {input} : ^ost$stack_frame_save_area);

*copy MMH$SEGMENT_FAULT_HANDLER

    VAR
      segment_access_fault_p: ^mmt$segment_access_condition;

    segment_access_fault_p := #LOC (segment_access_fault.contents);

{  Check for user defined error exit procedure and call it if it exists.
{  *** Have to wait until SDTX implemented.***

    pmp$dispose_segment_access_cond (segment_access_fault_p^, fault_save_area_p);
    RETURN;

  PROCEND mmp$segment_fault_handler;
MODEND mmm$segment_fault_handler;
*DECK DECK=MMM$SEGMENT_MANAGER_JOB_TEMP EXPAND=TRUE
?? RIGHT := 110, LEFT := 1 ??
?? NEWTITLE := 'MMM$SEGMENT_MANAGER_JOB_TEMP' ??
MODULE mmm$segment_manager_job_temp;

?? PUSH (LISTEXT := ON) ??
*copyc amt$segment_pointer
*copyc dfe$error_condition_codes
*copyc dmt$addr_length_pair
*copyc dmt$error_condition_codes
*copyc gft$locked_file_desc_entry_p
*copyc gft$file_descriptor_entry
*copyc gft$system_file_identifier
*copyc mme$condition_codes
*copyc mmk$job_mode_keypoints
*copyc mmt$access_selections
*copyc mmt$attribute_keyword
*copyc mmt$lock_segment_status
*copyc mmt$segment_attrib_descriptor
*copyc mmt$user_attribute_descriptor
*copyc mmt$va_access_mode
*copyc osk$keypoints
*copyc oss$task_private
*copyc ost$caller_identifier
*copyc ost$execution_control_block
*copyc ost$system_flag
*copyc ost$system_privilege_map
*copyc sft$file_space_limit_kind
?? POP ??
?? EJECT ??
*copyc bap$exit_fap_on_condition
*copyc dfp$set_server_eoi
*copyc dpp$put_critical_message
*copyc dmp$get_initialized_addresses
*copyc dsp$system_committed
*copyc fmp$ln_open_chapter
*copyc gfp$get_fde_p
*copyc gfv$null_sfid
*copyc i#move
*copyc mmp$advise_out
*copyc mmp$assign_contiguous_memory
*copyc mmp$build_segment
*copyc mmp$change_seg_inheritance_r1
*copyc mmp$change_segment_number_r1
*copyc mmp$change_stack_attribute_r1
*copyc mmp$convert_ps_transfer_size
*copyc mmp$fetch_sdt_sdtx_locked_fde
*copyc mmp$fetch_offset_mod_pages_r1
*copyc mmp$fetch_segment_attributes_r1
*copyc mmp$get_allocated_addresses_r1
*copyc mmp$get_page_size
*copyc mmp$get_segment_length_r1
*copyc mmp$get_sdt_entry_p
*copyc mmp$get_sdtx_entry_p
*copyc mmp$initiate_shadowing_r1
*copyc mmp$invalidate_segment
*copyc mmp$preset_page_streaming_r1
*copyc mmp$process_file_alloc
*copyc mmp$reserve_segment_number_r1
*copyc mmp$set_access_selections_r1
*copyc mmp$set_segment_length_r1
*copyc mmp$store_segment_attributes_r1
*copyc mmp$terminate_shadowing_r1
*copyc mmp$validate_segment_number
*copyc mmp$write_modified_pages
*copyc mmv$file_allocation_interval
*copyc mmv$shadow_by_segnum
*copyc mmv$temp_file_space_guard
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$verify_system_privilege
*copyc osv$initial_exception_context
*copyc osv$page_size
*copyc osv$task_private_heap
*copyc pmp$exit
*copyc pmp$find_executing_task_xcb
*copyc pmp$log
*copyc pmp$task_state

{  Define variables that are global to this module.

  VAR
    osv$system_privilege_map: [XDCL, #GATE, oss$task_private] ost$system_privilege_map :=
          [REP (mmc$default_sdt_length + 1) of TRUE];

?? TITLE := 'DETERMINE_VALIDATING_RING_NUM' ??
?? EJECT ??

  PROCEDURE [INLINE] determine_validating_ring_num
    (    caller_ring: ost$ring;
         validation_ring_number: ost$valid_ring;
     VAR validating_ring_num: ost$valid_ring);

    IF validation_ring_number < caller_ring THEN
      validating_ring_num := caller_ring;
    ELSE
      validating_ring_num := validation_ring_number;
    IFEND;

  PROCEND determine_validating_ring_num;

?? TITLE := 'UPDATE_PASSIVE_WITH_ACTIVE', EJECT ??

  PROCEDURE update_passive_with_active
    (    segment_p: ^cell;
     VAR status: ost$status);

    TYPE
      offset_list = array [1 .. * ] of ost$segment_offset;

    VAR
      access_selections: mmt$access_selections,
      address_list: array [1 .. 100] of dmt$addr_length_pair,
      addr_returned: integer,
      dest_p: mmt$segment_pointer,
      dest: ^cell,
      dm_element_length: ost$segment_length,
      dm_element_offset: ost$segment_offset,
      fde_p: gft$file_desc_entry_p,
      file_limits_to_enforce: sft$file_space_limit_kind,
      i: integer,
      in_memory: boolean,
      list_overflow: boolean,
      list_p: ^offset_list,
      local_status: ost$status,
      memory_list_index: integer,
      offsets_returned: integer,
      sdt_p: ^mmt$segment_descriptor,
      sdtx_p: ^mmt$segment_descriptor_extended,
      segnum: ost$segment,
      source: ^cell,
      starting_addr: ost$segment_offset;

{  Get access selection before change to restore at end of proc.

    mmp$validate_segment_number (#SEGMENT (segment_p), sdt_p, sdtx_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF sdtx_p^.software_attribute_set = $mmt$software_attribute_set
          [mmc$sa_read_transfer_unit, mmc$sa_free_behind] THEN
      access_selections := mmc$as_sequential;
    ELSEIF sdtx_p^.software_attribute_set = $mmt$software_attribute_set [mmc$sa_read_transfer_unit] THEN
      access_selections := mmc$as_read_tu;
    ELSE
      access_selections := mmc$as_random;
    IFEND;

{  Set read_transfer_unit attribute in ACTIVE segment.

    mmp$set_access_selections (segment_p, mmc$as_sequential, status);

{  Obtain access to PASSIVE segment.

    mmp$open_file_segment (sdtx_p^.shadow_info.shadow_sfid, NIL, mmc$cell_pointer, 1, sfc$no_limit, dest_p,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    offsets_returned := 100;
    REPEAT
      ALLOCATE list_p: [1 .. offsets_returned] IN osv$task_private_heap^;
      mmp$fetch_offset_modified_pages (segment_p, FALSE {return_unallocated_offsets} , list_p^,
            offsets_returned, status);
      IF NOT status.normal THEN
        FREE list_p IN osv$task_private_heap^;
        RETURN;
      IFEND;
      IF offsets_returned > UPPERBOUND (list_p^) THEN
        FREE list_p IN osv$task_private_heap^;
      IFEND;
    UNTIL offsets_returned <= UPPERBOUND (list_p^);

    IF offsets_returned <> 0 THEN
{  Convert offsets to PVAs and move all modified pages from the ACTIVE segment
      FOR i := 1 TO offsets_returned DO
        source := #ADDRESS (1, #SEGMENT (segment_p), list_p^ [i]);
        dest := #ADDRESS (1, #SEGMENT (dest_p.cell_pointer), list_p^ [i]);
        i#move (source, dest, osv$page_size);
        mmp$advise_out (dest, osv$page_size, status);
      FOREND;
    IFEND;


{  Determine whether the segment is assigned to a device.
{  Get and move all initialized addresses from ACTIVE file.
{  If the segment is not assigned, no further action is then required.


    starting_addr := 0;
    gfp$get_fde_p (sdtx_p^.sfid, fde_p);
    list_overflow := (fde_p^.media = gfc$fm_mass_storage_file);

  /get_list_of_addresses/
    WHILE list_overflow DO
      dmp$get_initialized_addresses (sdtx_p^.sfid, starting_addr, address_list, addr_returned, list_overflow,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF addr_returned <> 0 THEN
        FOR i := 1 TO addr_returned DO

{ Look for offsets which may have already been written. Specifically, we are looking for pages which are on
{ disk and are not modified in real memory at the same time.

          dm_element_length := address_list [i].length;
          dm_element_offset := address_list [i].addr;
          memory_list_index := 1;
          WHILE (dm_element_length > 0) AND (memory_list_index > 0) DO
            memory_list_index := offsets_returned;

{ Search the list (of offsets of all modified pages for the ACTIVE segment) for the equivalent offset returned
{ from Device Management.  If ANY of the pages in <addr + length> are not found, move the disk pages, starting
{ at <address_list [i].addr> and continuing through <address_list [i].addr + address_list [i].length.>.  In
{ this case we MAY overwrite some addresses which were processed in the previous update above, but this is OK.

            WHILE (memory_list_index > 0) AND (list_p^ [memory_list_index] <> dm_element_offset) DO
              memory_list_index := memory_list_index - 1;
            WHILEND;
            dm_element_offset := dm_element_offset + osv$page_size;
            dm_element_length := dm_element_length - osv$page_size;
          WHILEND;

          IF memory_list_index = 0 THEN

{ The address offset returned from DM was not written (either partially or completely) in the previous
{ process; write it now.

            source := #ADDRESS (1, #SEGMENT (segment_p), address_list [i].addr);
            dest := #ADDRESS (1, #SEGMENT (dest_p.cell_pointer), address_list [i].addr);
            i#move (source, dest, address_list [i].length);
            mmp$advise_out (source, address_list [i].length, status);
            mmp$advise_out (dest, address_list [i].length, status);
          IFEND;
        FOREND;
        starting_addr := address_list [addr_returned].addr + address_list [addr_returned].length;
      IFEND;
    WHILEND /get_list_of_addresses/;

    mmp$set_access_selections (segment_p, access_selections, status);
    mmp$close_segment (dest_p, 1, local_status);
    FREE list_p IN osv$task_private_heap^;

  PROCEND update_passive_with_active;
?? TITLE := 'MMP$CHANGE_SEGMENT_INHERITANCE' ??
?? EJECT ??
*copyc mmh$change_segment_inheritance

  PROCEDURE [XDCL] mmp$change_segment_inheritance
    (    pva: ^cell;
         segment_inheritance: mmt$segment_inheritance;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_status: ost$status,
      validating_ring_number: ost$valid_ring;

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    determine_validating_ring_num (caller_id.ring, #RING (pva), validating_ring_number);
    mmp$change_seg_inheritance_r1 (#SEGMENT (pva), validating_ring_number, segment_inheritance, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$change_segment_inheritance;

?? TITLE := 'MMP$CHANGE_SEGMENT_NUMBER' ??
?? EJECT ??
*copyc mmh$change_segment_number

  PROCEDURE [XDCL] mmp$change_segment_number
    (    segment_pointer: amt$segment_pointer;
         segment_number: ost$segment;
         validation_ring_number: ost$valid_ring;
     VAR new_segment_pointer: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_segment_pointer: amt$segment_pointer,
      r1_status: ost$status,
      validating_ring_number: ost$valid_ring;

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    determine_validating_ring_num (caller_id.ring, validation_ring_number, validating_ring_number);
    mmp$change_segment_number_r1 (#SEGMENT (segment_pointer.cell_pointer), segment_number,
          validating_ring_number, r1_status);
    IF r1_status.normal THEN
      new_segment_pointer := segment_pointer;
      new_segment_pointer.cell_pointer := #ADDRESS (#RING (segment_pointer.cell_pointer),
            segment_number, #OFFSET (segment_pointer.cell_pointer));
    ELSE
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$change_segment_number;

?? TITLE := 'MMP$CHANGE_STACK_ATTRIBUTE', EJECT ??
*copyc mmh$change_stack_attribute

  PROCEDURE [XDCL, #GATE] mmp$change_stack_attribute
    (    stack_pages_to_be_freed: boolean;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_status: ost$status;

    status.normal := TRUE;
    #CALLER_ID (caller_id);

    mmp$change_stack_attribute_r1 (stack_pages_to_be_freed, caller_id.ring, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$change_stack_attribute;

?? TITLE := 'MMP$CLOSE_SEGMENT', EJECT ??
*copyc mmh$close_segment

  PROCEDURE [XDCL, #GATE] mmp$close_segment
    (VAR pointer: mmt$segment_pointer;
         validation_ring_number: ost$valid_ring;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_status: ost$status,
      validating_ring_number: ost$valid_ring;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * #SEGMENT (pointer.cell_pointer), mmk$close);
    status.normal := TRUE;
    determine_validating_ring_num (caller_id.ring, validation_ring_number, validating_ring_number);
    mmp$invalidate_segment (#SEGMENT (pointer.cell_pointer), validating_ring_number,
          NIL {shared_taskid_array}, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      pointer.cell_pointer := NIL;
    IFEND;
    #KEYPOINT (osk$exit, 0, mmk$close);

  PROCEND mmp$close_segment;
?? TITLE := 'MMP$CLOSE_SHARED_STACK', EJECT ??
*copyc mmh$close_shared_stack

  PROCEDURE [XDCL] mmp$close_shared_stack
    (VAR pointer: mmt$segment_pointer;
         shared_taskid_array: ^array [1 .. * ] of pmt$task_id;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_status: ost$status;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    mmp$invalidate_segment (#SEGMENT (pointer.cell_pointer), caller_id.ring, shared_taskid_array, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      pointer.cell_pointer := NIL;
    IFEND;

  PROCEND mmp$close_shared_stack;
?? TITLE := 'MMP$CREATE_SCRATCH_SEGMENT', EJECT ??
*copyc mmh$create_scratch_segment

  PROCEDURE [XDCL, #GATE] mmp$create_scratch_segment
    (    pointer_kind: amt$pointer_kind;
         access_selections: mmt$access_selections;
     VAR pointer: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      kind: mmt$segment_pointer_kind,
      p: mmt$segment_pointer,
      r1_status: ost$status,
      segment_attributes: mmt$segment_attrib_descriptor;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, 0, mmk$create_scratch_segment);
    status.normal := TRUE;
    IF pointer_kind = amc$cell_pointer THEN
      kind := mmc$cell_pointer;
    ELSEIF pointer_kind = amc$sequence_pointer THEN
      kind := mmc$sequence_pointer;
    ELSE
      kind := mmc$heap_pointer;
    IFEND;
    segment_attributes.validating_ring_number := caller_id.ring;
    segment_attributes.file_limits_to_enforce := sfc$temp_file_space_limit;
    segment_attributes.pointer_kind := kind;
    segment_attributes.user_attributes := NIL;
    segment_attributes.sfid := gfv$null_sfid;
    mmp$build_segment (segment_attributes, NIL {shared_taskid_array} , p, r1_status);

    IF r1_status.normal THEN
      IF access_selections = mmc$as_sequential THEN
        mmp$set_access_selections (p.cell_pointer, mmc$as_sequential, status);
      IFEND;
      pointer.kind := pointer_kind;
      IF pointer_kind = amc$cell_pointer THEN
        pointer.cell_pointer := p.cell_pointer;
      ELSEIF pointer_kind = amc$sequence_pointer THEN
        pointer.sequence_pointer := p.seq_pointer;
      ELSE
        pointer.heap_pointer := p.heap_pointer;
      IFEND;
    ELSE
      osp$set_status_condition (r1_status.condition, status);
    IFEND;
    #KEYPOINT (osk$exit, 0, mmk$create_scratch_segment);

  PROCEND mmp$create_scratch_segment;

?? TITLE := 'MMP$CREATE_SEGMENT', EJECT ??
*copyc mmh$create_segment

  PROCEDURE [XDCL, #GATE] mmp$create_segment
    (    seg_attributes_p: ^array [ * ] of mmt$attribute_descriptor;
         pointer_kind: mmt$segment_pointer_kind;
         validation_ring_number: ost$valid_ring;
     VAR pointer: mmt$segment_pointer;
     VAR status: ost$status);


    VAR
      caller_id: ost$caller_identifier,
      r1_pointer: mmt$segment_pointer,
      r1_status: ost$status,
      segment_attributes: mmt$segment_attrib_descriptor,
      validating_ring_number: ost$valid_ring;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, 0, mmk$create_segment);
    status.normal := TRUE;
    determine_validating_ring_num (caller_id.ring, validation_ring_number, validating_ring_number);
    segment_attributes.validating_ring_number := validating_ring_number;
    IF mmv$temp_file_space_guard THEN
    segment_attributes.file_limits_to_enforce := sfc$temp_file_space_limit;
    ELSE
    segment_attributes.file_limits_to_enforce := sfc$no_limit;
    IFEND;
    segment_attributes.pointer_kind := pointer_kind;
    segment_attributes.user_attributes := seg_attributes_p;
    segment_attributes.sfid := gfv$null_sfid;
    IF segment_attributes.user_attributes <> NIL THEN
      PUSH segment_attributes.user_attributes: [LOWERBOUND (seg_attributes_p^
            ) .. UPPERBOUND (seg_attributes_p^)];
      segment_attributes.user_attributes^ := seg_attributes_p^;
    IFEND;
    mmp$build_segment (segment_attributes, NIL {shared_taskid_array} , r1_pointer, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      pointer := r1_pointer;
    IFEND;
    #KEYPOINT (osk$exit, 0, mmk$create_segment);

  PROCEND mmp$create_segment;
?? TITLE := 'MMP$CREATE_SHADOW_SEGMENT', EJECT ??
*copyc mmh$create_shadow_segment

  PROCEDURE [XDCL, #GATE] mmp$create_shadow_segment
    (    segment_p: ^cell;
         shadow_offset: ost$segment_offset;
         shadow_length: ost$segment_length;
         pointer_kind: mmt$segment_pointer_kind;
     VAR pva: mmt$segment_pointer;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      conv_ptr: ^cell,
      i: pmt$initialization_value,
      preset_value: pmt$initialization_value,
      r1_pointer: mmt$segment_pointer,
      r1_status: ost$status,
      segment_attributes: mmt$segment_attrib_descriptor,
      segnum: ost$segment;

    #KEYPOINT (osk$entry, #SEGMENT (segment_p) * osk$m, mmk$create_shadow_segment);
    status.normal := TRUE;

    conv_ptr := #ADDRESS (#RING (segment_p), #SEGMENT (segment_p), shadow_offset);

{  Issue request to create ACTIVE segment.
    #CALLER_ID (caller_id);
    segment_attributes.validating_ring_number := caller_id.ring;
    segment_attributes.file_limits_to_enforce := sfc$no_limit;
    segment_attributes.pointer_kind := pointer_kind;
    PUSH segment_attributes.user_attributes: [1 .. 1];
    segment_attributes.user_attributes^ [1].keyword := mmc$kw_shadow_segment;
    segment_attributes.user_attributes^ [1].shadow_p := conv_ptr;
    segment_attributes.user_attributes^ [1].shadow_length := shadow_length;
    segment_attributes.sfid := gfv$null_sfid;
    mmp$build_segment (segment_attributes, NIL {shared_taskid_array} , r1_pointer, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      pva := r1_pointer;
    IFEND;
    #KEYPOINT (osk$exit, 0, mmk$create_shadow_segment);

  PROCEND mmp$create_shadow_segment;

?? TITLE := 'MMP$CREATE_SHARED_STACK', EJECT ??
*copyc mmh$create_shared_stack

  PROCEDURE [XDCL] mmp$create_shared_stack
    (    seg_attributes_p: ^array [ * ] of mmt$attribute_descriptor;
         pointer_kind: mmt$segment_pointer_kind;
         shared_taskid_array: ^array [1 .. * ] of pmt$task_id;
     VAR pointer: mmt$segment_pointer;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_pointer: mmt$segment_pointer,
      r1_status: ost$status,
      segment_attributes: mmt$segment_attrib_descriptor;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    segment_attributes.validating_ring_number := caller_id.ring;
    segment_attributes.file_limits_to_enforce := sfc$no_limit;
    segment_attributes.pointer_kind := pointer_kind;
    segment_attributes.user_attributes := seg_attributes_p;
    IF segment_attributes.user_attributes <> NIL THEN
      PUSH segment_attributes.user_attributes: [LOWERBOUND (seg_attributes_p^
            ) .. UPPERBOUND (seg_attributes_p^)];
      segment_attributes.user_attributes^ := seg_attributes_p^;
    IFEND;
    segment_attributes.sfid := gfv$null_sfid;
    mmp$build_segment (segment_attributes, shared_taskid_array, r1_pointer, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      pointer := r1_pointer;
    IFEND;

  PROCEND mmp$create_shared_stack;
?? TITLE := 'MMP$CREATE_USER_SEGMENT' ??
?? EJECT ??
*copyc mmh$create_user_segment

  PROCEDURE [XDCL, #GATE] mmp$create_user_segment
    (    user_attributes_p: ^array [ * ] of mmt$user_attribute_descriptor;
         pointer_kind: amt$pointer_kind;
         access_selections: mmt$access_selections;
     VAR pointer: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      byte: 0 .. 255,
      caller_id: ost$caller_identifier,
      contiguous_flag: boolean,
      contiguous_page_count: integer,
      file_limits_to_enforce: sft$file_space_limit_kind,
      i: integer,
      increment: integer,
      kind: mmt$segment_pointer_kind,
      local_status: ost$status,
      max_length_index: integer,
      max_length_specified: boolean,
      page_size: integer,
      preset_pointer: ^array [ * ] of 0 .. 255,
      r1_status: ost$status,
      save_index: integer,
      seg_attrib_p: ^array [ * ] of mmt$attribute_descriptor,
      segment_attributes: mmt$segment_attrib_descriptor,
      segment_pointer: mmt$segment_pointer,
      seq_p: ^SEQ ( * ),
      wired_flag: boolean,
      wired_index: integer;

    contiguous_flag := FALSE;
    status.normal := TRUE;
    max_length_specified := FALSE;
    wired_flag := FALSE;

    IF user_attributes_p <> NIL THEN
      PUSH seg_attrib_p: [LOWERBOUND (user_attributes_p^) .. UPPERBOUND (user_attributes_p^)];

      FOR i := LOWERBOUND (user_attributes_p^) TO UPPERBOUND (user_attributes_p^) DO
        CASE user_attributes_p^ [i].keyword OF
        = mmc$ua_ring_numbers =
          seg_attrib_p^ [i].keyword := mmc$kw_ring_numbers;
          seg_attrib_p^ [i].r1 := user_attributes_p^ [i].r1;
          seg_attrib_p^ [i].r2 := user_attributes_p^ [i].r2;
        = mmc$ua_segment_number =
          seg_attrib_p^ [i].keyword := mmc$kw_segment_number;
          seg_attrib_p^ [i].segnum := user_attributes_p^ [i].segnum;
        = mmc$ua_max_segment_length =
          seg_attrib_p^ [i].keyword := mmc$kw_max_segment_length;
          seg_attrib_p^ [i].max_length := user_attributes_p^ [i].max_length;
          max_length_specified := TRUE;
          max_length_index := i;
        = mmc$ua_preset_value =
          seg_attrib_p^ [i].keyword := mmc$kw_preset_value;
          seg_attrib_p^ [i].preset_value := user_attributes_p^ [i].preset_value;
        = mmc$ua_segment_access_control =
          seg_attrib_p^ [i].keyword := mmc$kw_segment_access_control;
          seg_attrib_p^ [i].access_control := user_attributes_p^ [i].access_control;
        = mmc$ua_wired_segment =
          seg_attrib_p^ [i].keyword := mmc$kw_wired_segment;
          IF user_attributes_p^ [i].wired_segment_length > 65536 THEN
            osp$set_status_abnormal ('MM', mme$wired_seg_length_too_large, '', status);
            RETURN;
          IFEND;
          seg_attrib_p^ [i].wired_segment_length := user_attributes_p^ [i].wired_segment_length;
          IF user_attributes_p^ [i].contiguous_real_memory THEN
            contiguous_flag := TRUE;
          IFEND;
          wired_flag := TRUE;
          wired_index := i;
        = mmc$ua_null_keyword =
          seg_attrib_p^ [i].keyword := mmc$kw_null_keyword;
        ELSE
        CASEND;
      FOREND;
    ELSE
      seg_attrib_p := NIL;
    IFEND;

    IF max_length_specified AND wired_flag THEN
      seg_attrib_p^ [max_length_index].max_length := seg_attrib_p^ [wired_index].wired_segment_length;
    IFEND;

    IF pointer_kind = amc$cell_pointer THEN
      kind := mmc$cell_pointer;
    ELSEIF pointer_kind = amc$sequence_pointer THEN
      kind := mmc$sequence_pointer;
    ELSE
      kind := mmc$heap_pointer;
    IFEND;
    #CALLER_ID (caller_id);

    segment_attributes.validating_ring_number := caller_id.ring;
    segment_attributes.file_limits_to_enforce := sfc$temp_file_space_limit;
    segment_attributes.pointer_kind := kind;
    segment_attributes.user_attributes := seg_attrib_p;
    segment_attributes.sfid := gfv$null_sfid;
    mmp$build_segment (segment_attributes, NIL {shared_taskid_array} , segment_pointer, r1_status);

    IF r1_status.normal THEN
      IF access_selections = mmc$as_sequential THEN
        mmp$set_access_selections (segment_pointer.cell_pointer, mmc$as_sequential, status);
      IFEND;
      pointer.kind := pointer_kind;
      IF pointer_kind = amc$cell_pointer THEN
        seq_p := #SEQ (segment_pointer.cell_pointer^);
        RESET seq_p;
        NEXT preset_pointer: [1 .. #SIZE (segment_pointer.cell_pointer^)] IN seq_p;
        pointer.cell_pointer := segment_pointer.cell_pointer;
      ELSEIF pointer_kind = amc$sequence_pointer THEN
        seq_p := #SEQ (segment_pointer.seq_pointer^);
        RESET seq_p;
        NEXT preset_pointer: [1 .. #SIZE (segment_pointer.seq_pointer^)] IN seq_p;
        pointer.sequence_pointer := segment_pointer.seq_pointer;
      ELSE
        seq_p := #SEQ (segment_pointer.heap_pointer^);
        RESET seq_p;
        NEXT preset_pointer: [1 .. #SIZE (segment_pointer.heap_pointer^)] IN seq_p;
        pointer.heap_pointer := segment_pointer.heap_pointer;
      IFEND;

      IF contiguous_flag THEN
        mmp$assign_contiguous_memory (pointer.cell_pointer, seg_attrib_p^ [wired_index].wired_segment_length,
              status);

        { MMP$ASSIGN_CONTIGUOUS_MEMORY will PRESET the pages it assigns to the segment--
        { if it was able to assign contiguous pages.

        IF NOT status.normal THEN
          mmp$delete_user_segment (pointer, local_status);
          RETURN;
        IFEND;
      ELSEIF wired_flag AND NOT contiguous_flag THEN

        { PRESET the pages of a wired segment-this is accomplished by touching every page in the segment.}

        mmp$get_page_size (page_size);
        increment := 1;
        WHILE increment < UPPERBOUND (preset_pointer^) DO
          byte := preset_pointer^ [increment];
          increment := increment + page_size;
        WHILEND;
      IFEND;
    ELSE
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$create_user_segment;
?? TITLE := 'MMP$DELETE_SCRATCH_SEGMENT', EJECT ??
*copyc mmh$delete_scratch_segment

  PROCEDURE [XDCL, #GATE] mmp$delete_scratch_segment
    (VAR pointer: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      p: mmt$segment_pointer,
      r1_status: ost$status;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, #SEGMENT (pointer.cell_pointer) * osk$m, mmk$delete_scratch_segment);
    status.normal := TRUE;
    p.kind := mmc$cell_pointer;
    p.cell_pointer := pointer.cell_pointer;

    mmp$invalidate_segment (#SEGMENT (pointer.cell_pointer), caller_id.ring, NIL {shared_taskid_array} ,
          r1_status);
    IF r1_status.normal THEN
      pointer.cell_pointer := NIL;
    ELSE
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

    #KEYPOINT (osk$exit, 0, mmk$delete_scratch_segment);

  PROCEND mmp$delete_scratch_segment;

?? TITLE := 'MMP$DELETE_SEGMENT' ??
?? EJECT ??
*copyc mmh$delete_segment

  PROCEDURE [XDCL, #GATE] mmp$delete_segment
    (VAR pointer: mmt$segment_pointer;
         validation_ring_number: ost$valid_ring;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_status: ost$status,
      validating_ring_number: ost$valid_ring;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, #SEGMENT (pointer.cell_pointer) * osk$m, mmk$delete_segment);
    status.normal := TRUE;
    determine_validating_ring_num (caller_id.ring, validation_ring_number, validating_ring_number);
    mmp$invalidate_segment (#SEGMENT (pointer.cell_pointer), validating_ring_number,
          NIL {shared_taskid_array}, r1_status);
    IF r1_status.normal THEN
      pointer.cell_pointer := NIL;
    ELSE
      osp$set_status_condition (r1_status.condition, status);
    IFEND;
    #KEYPOINT (osk$exit, 0, mmk$delete_segment);

  PROCEND mmp$delete_segment;
?? TITLE := 'MMP$DELETE_USER_SEGMENT' ??
?? EJECT ??
*copyc mmh$delete_user_segment

  PROCEDURE [XDCL, #GATE] mmp$delete_user_segment
    (VAR pointer: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_status: ost$status;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    mmp$invalidate_segment (#SEGMENT (pointer.cell_pointer), caller_id.ring, NIL {shared_taskid_array} ,
          r1_status);
    IF r1_status.normal THEN
      pointer.cell_pointer := NIL;
    ELSE
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$delete_user_segment;
?? TITLE := 'MMP$FAILED_ALLOCATION_FLAG_HDL' ??
?? EJECT ??
*copyc mmh$failed_allocation_flag_hdl

  PROCEDURE [XDCL] mmp$failed_allocation_flag_hdl
    (    flag_id: ost$system_flag);

    VAR
      i: integer,
      new_allocated_length: amt$file_byte_address,
      segnum: ost$segment,
      status: ost$status,
      xcb_p: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb_p);

    WHILE TRUE DO
      mmp$process_file_alloc (new_allocated_length, status);
      IF status.normal THEN
        RETURN;
      IFEND;

{ Any abnormal status which is actually returned to this procedure is an 'OK' status, which
{ will cause the system to keep attempting to allocate file_space for this task.
{ In the case of the File_Server, however, we don't want to wait forever because the server
{ may not EVER come back.  Just return; the next time the user references the page the correct
{ condition will be raised.

      IF (status.condition = dfe$family_not_served) OR (status.condition = dfe$server_not_active) OR
            (status.condition = dfe$server_has_terminated) THEN
        RETURN;
      IFEND;

      IF (xcb_p^.system_flags * $tmt$system_flags [jmc$kill_job_flag, pmc$kill_task_flag] <>
            $tmt$system_flags []) AND (xcb_p^.system_table_lock_count <= 0) THEN
        pmp$log (' Job KILLED while waiting for file allocation.', status);
        pmp$exit (status);
      IFEND;

      IF (xcb_p^.system_flags = $tmt$system_flags []) THEN
        FOR i := 1 TO tmc$maximum_signals DO
          IF xcb_p^.signals.present [i] THEN
            RETURN;
          IFEND;
        FOREND;
      ELSE
        RETURN;
      IFEND;

{ If the task is terminating, let it go on and attempt to continue termination.

      IF pmp$task_state () = pmc$task_terminating THEN
        RETURN;
      IFEND;

      IF status.condition = dme$unable_to_alloc_all_space THEN
        IF dsp$system_committed () THEN
          bap$exit_fap_on_condition (dme$unable_to_alloc_all_space);
          RETURN;
        ELSE
          {
          { System disk full in early deadstart.
          {
          dpp$put_critical_message ('The system disk is full - redeadstart without job recovery', status);
        IFEND;
      IFEND;

    WHILEND;

  PROCEND mmp$failed_allocation_flag_hdl;
?? TITLE := 'MMP$FETCH_OFFSET_MODIFIED_PAGES', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$fetch_offset_modified_pages
    (    segment_p: ^cell;
         return_unallocated_offsets: boolean;
     VAR offset_list: array [ * ] of ost$segment_offset;
     VAR offsets_returned: integer;
     VAR status: ost$status);

    VAR
      i: integer,
      r1_offset_list_p: ^array [ * ] of ost$segment_offset,
      r1_offsets_returned: integer,
      r1_status: ost$status;

    status.normal := TRUE;
    PUSH r1_offset_list_p: [1 .. UPPERBOUND (offset_list)];
    mmp$fetch_offset_mod_pages_r1 (#SEGMENT (segment_p), gfv$null_sfid, return_unallocated_offsets,
        r1_offset_list_p, r1_offsets_returned, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      offset_list := r1_offset_list_p^;
      offsets_returned := r1_offsets_returned;
    IFEND;

  PROCEND mmp$fetch_offset_modified_pages;

?? TITLE := 'MMP$FETCH_SEGMENT_ATTRIBUTES' ??
?? EJECT ??
*copyc mmh$fetch_segment_attributes

  PROCEDURE [XDCL, #GATE] mmp$fetch_segment_attributes
    (    pva: ^cell;
     VAR seg_attributes: array [ * ] of mmt$attribute_descriptor;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      i: integer,
      r1_status: ost$status,
      r1_segment_attributes_p: ^array [ * ] of mmt$attribute_descriptor;

    #KEYPOINT (osk$entry, osk$m * #SEGMENT (pva), mmk$fetch_seg_attributes);

    IF pva = NIL THEN
      osp$set_status_abnormal ('MM', mme$invalid_pva, '', status);
      #KEYPOINT (osk$exit, 0, mmk$fetch_seg_attributes);
      RETURN;
    IFEND;

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    PUSH r1_segment_attributes_p: [LOWERBOUND (seg_attributes) .. UPPERBOUND (seg_attributes)];
    r1_segment_attributes_p^ := seg_attributes;
    mmp$fetch_segment_attributes_r1 (#SEGMENT (pva), caller_id.ring, r1_segment_attributes_p, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      seg_attributes := r1_segment_attributes_p^;
    IFEND;

    #KEYPOINT (osk$exit, 0, mmk$fetch_seg_attributes);
  PROCEND mmp$fetch_segment_attributes;
?? TITLE := 'MMP$GET_ALLOCATED_ADDRESSES', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$get_allocated_addresses
    (    file: ^cell;
         starting_byte_address: ost$segment_offset;
     VAR addr_list: array [ * ] of dmt$addr_length_pair;
     VAR addr_returned: integer;
     VAR list_overflow: boolean;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      i: integer,
      r1_addr_list_p: ^array [ * ] of dmt$addr_length_pair,
      r1_addr_returned: integer,
      r1_list_overflow: boolean,
      r1_status: ost$status;

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    PUSH r1_addr_list_p: [LOWERBOUND (addr_list) .. UPPERBOUND (addr_list)];
    mmp$get_allocated_addresses_r1 (#SEGMENT (file), caller_id.ring, starting_byte_address, r1_addr_list_p,
          r1_addr_returned, r1_list_overflow, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      addr_list := r1_addr_list_p^;
      list_overflow := r1_list_overflow;
      addr_returned := r1_addr_returned;
    IFEND;
  PROCEND mmp$get_allocated_addresses;

?? TITLE := 'MMP$GET_SEGMENT_LENGTH' ??
?? EJECT ??
*copy mmh$get_segment_length

  PROCEDURE [XDCL, #GATE] mmp$get_segment_length
    (    pva: ^cell;
         validation_ring_number: ost$valid_ring;
     VAR segment_length: ost$segment_length;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_segment_length: ost$segment_length,
      r1_status: ost$status,
      validating_ring_number: ost$valid_ring;

    #KEYPOINT (osk$entry, osk$m * #SEGMENT (pva), mmk$get_segment_length);
    status.normal := TRUE;
    segment_length := 0;
    #CALLER_ID (caller_id);
    determine_validating_ring_num (caller_id.ring, validation_ring_number, validating_ring_number);
    mmp$get_segment_length_r1 (#SEGMENT (pva), validating_ring_number, r1_segment_length, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      segment_length := r1_segment_length;
    IFEND;
    #KEYPOINT (osk$exit, 0, mmk$get_segment_length);

  PROCEND mmp$get_segment_length;

?? TITLE := 'MMP$INITIATE_DEBUG_SHADOWING' ??
?? EJECT ??
*copyc mmh$initiate_debug_shadowing

  PROCEDURE [XDCL, #GATE] mmp$initiate_debug_shadowing
    (    segment_pointer: ^cell;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_pointer: ^cell,
      r1_status: ost$status,
      validating_ring: ost$valid_ring;

    status.normal := TRUE;
    #CALLER_ID (caller_id);

{ Change the segment attributes to WRITE and flush the pages to disk.

    mmp$write_modified_pages (segment_pointer, osc$maximum_offset, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  Issue ring_1 call to establish ACTIVE segment.

    r1_pointer := segment_pointer;
    mmp$initiate_shadowing_r1 (r1_pointer, caller_id.ring, mmc$ssk_read_only_file, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

  PROCEND mmp$initiate_debug_shadowing;
?? TITLE := 'MMP$INITIATE_SHADOWING' ??
?? EJECT ??
*copyc mmh$initiate_shadowing

  PROCEDURE [XDCL, #GATE] mmp$initiate_shadowing
    (    segment_p: ^cell;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_pointer: ^cell,
      r1_status: ost$status;

    #KEYPOINT (osk$entry, #SEGMENT (segment_p) * osk$m, mmk$initiate_shadowing);
    status.normal := TRUE;
    #CALLER_ID (caller_id);

{ Change the segment attributes to WRITE and flush the pages to disk.

    mmp$write_modified_pages (segment_p, osc$maximum_offset, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


{  Issue ring_1 call to establish ACTIVE segment.

    r1_pointer := segment_p;
    mmp$initiate_shadowing_r1 (r1_pointer, #RING (segment_p), mmc$ssk_read_write_file, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    IFEND;
    #KEYPOINT (osk$exit, 0, mmk$initiate_shadowing);

  PROCEND mmp$initiate_shadowing;
?? TITLE := 'MMP$OPEN_FILE_SEGMENT' ??
?? EJECT ??
*copyc mmh$open_file_segment

  PROCEDURE [XDCL] mmp$open_file_segment
    (    sfid: gft$system_file_identifier,
         attr_p: ^array [ * ] of mmt$attribute_descriptor;
         pointer_kind: mmt$segment_pointer_kind;
         validation_ring_number: ost$valid_ring;
         file_limits_to_enforce: sft$file_space_limit_kind;
     VAR pointer: mmt$segment_pointer;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_pointer: mmt$segment_pointer,
      r1_status: ost$status,
      segment_attributes: mmt$segment_attrib_descriptor,
      validating_ring_number: ost$valid_ring;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, 0, mmk$open_file_segment);
    status.normal := TRUE;
    determine_validating_ring_num (caller_id.ring, validation_ring_number, validating_ring_number);
    segment_attributes.validating_ring_number := validating_ring_number;
    segment_attributes.file_limits_to_enforce := file_limits_to_enforce;
    segment_attributes.pointer_kind := pointer_kind;
    segment_attributes.user_attributes := attr_p;
    IF segment_attributes.user_attributes <> NIL THEN
      PUSH segment_attributes.user_attributes: [LOWERBOUND (attr_p^) .. UPPERBOUND (attr_p^)];
      segment_attributes.user_attributes^ := attr_p^;
    IFEND;
    segment_attributes.sfid := sfid;
    mmp$build_segment (segment_attributes, NIL {shared_taskid_array} , r1_pointer, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
      #KEYPOINT (osk$exit, 0, mmk$open_file_segment);
    ELSE
      pointer := r1_pointer;
      #KEYPOINT (osk$exit, osk$m * #SEGMENT (pointer.cell_pointer), mmk$open_file_segment);
    IFEND;

  PROCEND mmp$open_file_segment;
?? TITLE := ' mmp$open_segment', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$open_segment
    (    file_name: ost$name;
         seg_attributes: ^array [ * ] of mmt$attribute_descriptor;
         pointer_kind: mmt$segment_pointer_kind;
     VAR pointer: mmt$segment_pointer;
     VAR status: ost$status);


    VAR
      caller_id: ost$caller_identifier;

    #CALLER_ID (caller_id);
    fmp$ln_open_chapter (file_name, 0, caller_id.ring, seg_attributes, pointer_kind, pointer, status);

  PROCEND mmp$open_segment;
?? TITLE := 'MMP$PRESET_PAGE_STREAMING', EJECT ??
{--------------------------------------------------------------------------------------------------------
{ PURPOSE:
{ Procedure mmp$preset_page_streaming provides the capability of presetting the SDTX of a segment so that
{ it is already in page streaming mode, with free behind TRUE and the transfer size as specified.  It returns
{ the original values of free behind and transfer size so that the caller can call again later and restore
{ the original values.
{
{ DESIGN:
{ There is nothing fancy,  The boolean "preset_and_save_ts_fb" indicates the purpose of a call,  a value
{ of TRUE indicates preset and save the original values, a value of FALSE indicates a restore.  Nothing is
{ done to ensure calls are in order or completed.  In preset mode, the transfer size is changed if the
{ specified transfer size is > sdtx.stream.transfer_size.   IF sdtx.stream.streaming = TRUE the segment is
{ already in page streaming mode and nothing else need be done.  If sdtx.stream.streaming = FALSE then
{ the boolean sdtx.stream.preset_streaming is set to indicate that the next fault should stream.  To ensure
{ the next fault enters the page streaming code, the value of sdtx.stream.sequential_accesses is forced
{ to be  >= mmv$page_streaming_prestream.
{ When restoring the original values, the streaming boolean in the SDTX is left TRUE.  The page
{ fault process will terminate streaming if that is appropriate.  If the restore call is not made, the only
{ result is that free behind is TRUE and Transfer size =>64K which may or may not have been original values.
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL, #GATE] mmp$preset_page_streaming
    (    preset_and_save_ts_fb: boolean;
         pva: ^cell;
         temp_transfer_size: integer;
     VAR saved_transfer_size: 0 .. 15;
     VAR saved_free_behind: boolean;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_free_behind: boolean,
      r1_transfer_size: 0 .. 15,
      r1_status: ost$status;

{  Validate the pva and get a pointer to the segment descriptor.

    IF pva = NIL THEN
      osp$set_status_abnormal ('MM', mme$invalid_pva, '', status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    mmp$preset_page_streaming_r1 (#SEGMENT (pva), caller_id.ring, preset_and_save_ts_fb, temp_transfer_size,
          r1_transfer_size, r1_free_behind, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      saved_transfer_size := r1_transfer_size;
      saved_free_behind := r1_free_behind;
    IFEND;

  PROCEND mmp$preset_page_streaming;
?? TITLE := 'MMP$RESERVE_SEGMENT_NUMBER', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$reserve_segment_number
    (    shared_stack_flag: boolean;
     VAR segment_num_array: ^array [ * ] of ost$segment;
     VAR status: ost$status);

    VAR
      i: integer,
      r1_num_array_p: ^array [ * ] of ost$segment,
      r1_status: ost$status;

{ This procedure is the user interface to reserve segments for subsequent explicit assignment.

    status.normal := TRUE;
    PUSH r1_num_array_p: [LOWERBOUND (segment_num_array^) .. UPPERBOUND (segment_num_array^)];
    FOR i := LOWERBOUND (segment_num_array^) TO UPPERBOUND (segment_num_array^) DO
      r1_num_array_p^ [i] := 0;
    FOREND;

    mmp$reserve_segment_number_r1 (shared_stack_flag, r1_num_array_p, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    ELSE
      FOR i := LOWERBOUND (segment_num_array^) TO UPPERBOUND (segment_num_array^) DO
        segment_num_array^ [i] := r1_num_array_p^ [i];
      FOREND;
    IFEND;

  PROCEND mmp$reserve_segment_number;
?? TITLE := 'MMP$REVERIFY_ACCESS' ??
?? EJECT ??
*copyc mmh$reverify_access

  FUNCTION [XDCL] mmp$reverify_access
    (    pva_p: ^^cell): boolean;

    VAR
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segnum: ost$segment,
      xcb_p: ^ost$execution_control_block;

    segnum := #SEGMENT (pva_p^);

    xcb_p := #ADDRESS (1, osc$segnum_job_fixed_heap, #READ_REGISTER (osc$pr_base_constant));
    sdt_entry_p := mmp$get_sdt_entry_p (xcb_p, segnum);
    sdtx_entry_p := mmp$get_sdtx_entry_p (xcb_p, segnum);
    mmp$reverify_access := (segnum <= xcb_p^.xp.segment_table_length) AND
          (sdt_entry_p^.ste.vl <> osc$vl_invalid_entry) AND (sdtx_entry_p^.access_state <>
          mmc$sas_terminate_access);
  FUNCEND mmp$reverify_access;

?? TITLE := 'MMP$SET_ACCESS_SELECTIONS', EJECT ??
*copyc mmh$set_access_selections

  PROCEDURE [XDCL, #GATE] mmp$set_access_selections
    (    pva: ^cell;
         access_selections: mmt$access_selections;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_status: ost$status,
      validating_ring_number: ost$valid_ring;

    #KEYPOINT (osk$entry, osk$m * #SEGMENT (pva), mmk$set_access_selections);

    IF pva = NIL THEN
      osp$set_status_abnormal ('MM', mme$invalid_pva, '', status);
      #KEYPOINT (osk$exit, 0, mmk$set_access_selections);
      RETURN;
    IFEND;

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    determine_validating_ring_num (caller_id.ring, #RING (pva), validating_ring_number);
    mmp$set_access_selections_r1 (#SEGMENT (pva), validating_ring_number, access_selections, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

    #KEYPOINT (osk$exit, 0, mmk$set_access_selections);

  PROCEND mmp$set_access_selections;
?? TITLE := 'MMP$SET_SEGMENT_LENGTH' ??
?? EJECT ??
*copy mmh$set_segment_length

  PROCEDURE [XDCL, #GATE] mmp$set_segment_length
    (    pva: ^cell;
         validation_ring_number: ost$valid_ring;
         segment_length: ost$segment_length;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      fde_p: gft$file_desc_entry_p,
      context: ^ost$ecp_exception_context,
      local_status: ost$status,
      r1_status: ost$status,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segment_pointer: ^cell,
      validating_ring_number: ost$valid_ring,
      xcb_p: ^ost$execution_control_block;

    #KEYPOINT (osk$entry, 0, mmk$set_segment_length);
    #CALLER_ID (caller_id);
    status.normal := TRUE;
    context := NIL;
    determine_validating_ring_num (caller_id.ring, validation_ring_number, validating_ring_number);
    segment_pointer := pva;
    mmp$set_segment_length_r1 (#SEGMENT (segment_pointer), validating_ring_number, segment_length, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

{ If this is a served segment/file, update the EOI on the server mainframe using a remote procedure call.

    xcb_p := #ADDRESS (1, osc$segnum_job_fixed_heap, #READ_REGISTER (osc$pr_base_constant));
    sdtx_entry_p := mmp$get_sdtx_entry_p (xcb_p, #SEGMENT (segment_pointer));
    gfp$get_fde_p (sdtx_entry_p^.sfid, fde_p);
    IF fde_p^.media = gfc$fm_served_file THEN
      REPEAT
        dfp$set_server_eoi (sdtx_entry_p^.sfid, segment_length, local_status);
        IF NOT local_status.normal THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_file_segment;
            context^.file.file_segment := pva;
          IFEND;
          context^.condition_status := local_status;
          osp$enforce_exception_policies (context^);
          local_status := context^.condition_status;
        IFEND;
      UNTIL local_status.normal OR (NOT osp$file_access_condition (local_status)) OR (NOT context^.wait);
    IFEND;
    #KEYPOINT (osk$exit, osk$m * #SEGMENT (pva), mmk$set_segment_length);

  PROCEND mmp$set_segment_length;
?? TITLE := 'MMP$STORE_SEGMENT_ATTRIBUTES' ??
?? EJECT ??
*copyc mmh$store_segment_attributes

  PROCEDURE [XDCL, #GATE] mmp$store_segment_attributes
    (    pva: ^cell;
         validation_ring_number: ost$valid_ring;
         attr: array [ * ] of mmt$attribute_descriptor;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      r1_status: ost$status,
      r1_segment_attributes_p: ^array [ * ] of mmt$attribute_descriptor;

    #KEYPOINT (osk$exit, 0, mmk$store_segment_attributes);

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    PUSH r1_segment_attributes_p: [LOWERBOUND (attr) .. UPPERBOUND (attr)];
    r1_segment_attributes_p^ := attr;
    mmp$store_segment_attributes_r1 (#SEGMENT (pva), caller_id.ring,
          osv$system_privilege_map[caller_id.segnum], r1_segment_attributes_p, r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    IFEND;

    #KEYPOINT (osk$exit, 0, mmk$store_segment_attributes);

  PROCEND mmp$store_segment_attributes;
?? TITLE := 'MMP$TERMINATE_SHADOWING' ??
?? EJECT ??
*copyc mmh$terminate_shadowing

  PROCEDURE [XDCL, #GATE] mmp$terminate_shadowing
    (    segment_p: ^cell;
         update: boolean;
     VAR status: ost$status);

    VAR
      access_selections: mmt$access_selections,
      dest_p: mmt$segment_pointer,
      r1_status: ost$status;

    #KEYPOINT (osk$entry, #SEGMENT (segment_p) * osk$m, mmk$terminate_shadowing);
    status.normal := TRUE;

{  Determine if update (PASSIVE with ACTIVE)is required.

    IF update THEN
      update_passive_with_active (segment_p, status);
    IFEND;

    mmp$terminate_shadowing_r1 (#SEGMENT (segment_p), r1_status);
    IF NOT r1_status.normal THEN
      osp$set_status_condition (r1_status.condition, status);
    IFEND;
    #KEYPOINT (osk$exit, 0, mmk$terminate_shadowing);

  PROCEND mmp$terminate_shadowing;
?? TITLE := 'MMP$VERIFY_ACCESS' ??
?? EJECT ??
*copyc mmh$verify_access

  FUNCTION [XDCL, #GATE] mmp$verify_access
    (    pva_p: ^^cell;
         access_mode: mmt$va_access_mode): boolean;

    TYPE
      external_code_base_pointer = packed record
        fill: 0 .. 0f(16),
        vmid: 0 .. 0f(16),
        xp: boolean,
        fill2: 0 .. 7,
        r3: 0 .. 15,
        code_pva: ost$pva,
        fill3: 0 .. 0ffff(16),
        binding_pva: ost$pva,
      recend;

    VAR
      caller_id: ost$caller_identifier,
      code_pva: ost$pva,
      pointer: record
        case (pva, code_pointer, str) of
        = pva =
          pva: ost$pva,
        = code_pointer =
          cbp_p: ^external_code_base_pointer,
          static_link: ost$pva,
        = str =
          s: string (12),
        casend,
      recend,
      ptr: record
        case 0 .. 1 of
        = 0 =
          pva_p: ^^cell,
        = 1 =
          s_p: ^string (12),
        casend,
      recend,
      ref_r: ost$ring,
      sd_p: ^mmt$segment_descriptor,
      sdtx_p: ^mmt$segment_descriptor_extended,
      segnum: ost$segment,
      status: ost$status,
      xcb_p: ^ost$execution_control_block;

    mmp$verify_access := TRUE;
    ptr.pva_p := pva_p;
    pointer.s := ptr.s_p^;
    segnum := pointer.pva.seg;
    #KEYPOINT (osk$entry, segnum * osk$m, mmk$verify_access);

  /verify_access/
    BEGIN
      xcb_p := #ADDRESS (1, osc$segnum_job_fixed_heap, #READ_REGISTER (osc$pr_base_constant));
      IF segnum > xcb_p^.xp.segment_table_length THEN
        mmp$verify_access := FALSE;
        EXIT /verify_access/;
      IFEND;
      sd_p := mmp$get_sdt_entry_p (xcb_p, segnum);
      sdtx_p := mmp$get_sdtx_entry_p (xcb_p, segnum);
      IF sd_p^.ste.vl = osc$vl_invalid_entry THEN
        mmp$verify_access := FALSE;
        EXIT /verify_access/;
      IFEND;
      IF (sdtx_p^.access_state = mmc$sas_terminate_access) THEN
        mmp$verify_access := FALSE;
        EXIT /verify_access/;
      IFEND;


      #CALLER_ID (caller_id);
      ref_r := pointer.pva.ring;
      IF ref_r = 0 THEN
        mmp$verify_access := FALSE;
        EXIT /verify_access/;
      IFEND;


{  Move pointer being verified to a local variable so that ring number checking will be
{  valid on recursive calls.


      IF caller_id.ring > ref_r THEN
        ref_r := caller_id.ring;
        pointer.pva.ring := caller_id.ring;
      IFEND;

      CASE access_mode OF
      = mmc$va_read =
        mmp$verify_access := (ref_r <= sd_p^.ste.r2) AND (sd_p^.ste.rp <> osc$non_readable);
      = mmc$va_write =
        mmp$verify_access := (ref_r <= sd_p^.ste.r1) AND (sd_p^.ste.wp <> osc$non_writable);
      = mmc$va_read_write =
        mmp$verify_access := (ref_r <= sd_p^.ste.r1) AND (sd_p^.ste.wp <> osc$non_writable) AND
              (sd_p^.ste.rp <> osc$non_readable);
      = mmc$va_execute =
        mmp$verify_access := (ref_r >= sd_p^.ste.r1) AND (ref_r <= sd_p^.ste.r2) AND
              (sd_p^.ste.xp <> osc$non_executable);
      = mmc$va_read_execute =
        mmp$verify_access := mmp$verify_access (#LOC (pointer.pva), mmc$va_execute) AND
              mmp$verify_access (#LOC (pointer.pva), mmc$va_read);
      = mmc$va_binding =
        mmp$verify_access := sd_p^.ste.rp = osc$binding_segment;
      = mmc$va_pointer_to_procedure =

{  To verify a pointer to procedure the following must be checked:
{    . The procedure pointer must be in a segment with read access.
{    . The static link pointer, code base pointer, code PVA, or binding PVA must not have a ring number
{      equal to zero.
{    . The code base pointer must be in a segment with the "binding" attribute and be in a ring
{      readable segment.
{    . The caller must be within the call bracket.
{    . The code PVA in the code base pointer must be in a segment with "execute" privilege.
{    . The binding PVA in the code base pointer must be in a segment with the "binding" attribute
{      if this is a two word external code base pointer.

        IF mmp$verify_access (#LOC (pointer.pva), mmc$va_read) = FALSE THEN
          mmp$verify_access := FALSE;
          EXIT /verify_access/;
        IFEND;

        IF pointer.static_link.ring = 0 THEN
          mmp$verify_access := FALSE;
          EXIT /verify_access/;
        IFEND;

        IF pointer.cbp_p^.code_pva.ring = 0 THEN
          mmp$verify_access := FALSE;
          EXIT /verify_access/;
        IFEND;

        pointer.pva.ring := ref_r;
        IF (mmp$verify_access (#LOC (pointer.pva), mmc$va_binding) AND mmp$verify_access (#LOC (pointer.pva),
              mmc$va_read)) = FALSE THEN
          mmp$verify_access := FALSE;
          EXIT /verify_access/;
        IFEND;

        IF ref_r > pointer.cbp_p^.r3 THEN
          mmp$verify_access := FALSE;
          EXIT /verify_access/;
        IFEND;

{  The caller is within the call bracket so the call is possible.  The ring of execution will be r2 from
{  the code pva segment descriptor if it is greater than the caller's ring number, if not the caller's
{  ring number is the ring of execution.  The ring of execution is used as the ring number in
{  validating the code pva and the new binding pva if there is one.

        code_pva := pointer.cbp_p^.code_pva;
        IF ref_r > sd_p^.ste.r2 THEN
          code_pva.ring := sd_p^.ste.r2;
          ref_r := sd_p^.ste.r2;
        ELSE
          code_pva.ring := ref_r;
        IFEND;

        IF mmp$verify_access (#LOC (code_pva), mmc$va_execute) = FALSE THEN
          mmp$verify_access := FALSE;
          EXIT /verify_access/;
        IFEND;

        IF pointer.cbp_p^.xp = TRUE THEN
          IF pointer.cbp_p^.binding_pva.ring = 0 THEN
            mmp$verify_access := FALSE;
            EXIT /verify_access/;
          IFEND;
        IFEND;
      ELSE
        mmp$verify_access := FALSE;
      CASEND;
    END /verify_access/;

    #KEYPOINT (osk$exit, 0, mmk$verify_access);

  FUNCEND mmp$verify_access;
?? TITLE := 'MMP$VOLUME_UNAVAILABLE_FLAG_HDL' ??
?? EJECT ??

  PROCEDURE [XDCL] mmp$volume_unavailable_flag_hdl
    (    flag_id: ost$system_flag);

    bap$exit_fap_on_condition (mme$volume_unavailable);

  PROCEND mmp$volume_unavailable_flag_hdl;
?? OLDTITLE ??
MODEND mmm$segment_manager_job_temp;
*DECK DECK=MMM$SEGMENT_MANAGER_SYSTEM_CORE EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE - MMM$SEGMENT_MANAGER_SYSTEM_CORE' ??
MODULE mmm$segment_manager_system_core;
?? NEWTITLE := '  TYPE Declarations required for this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc amt$segment_pointer
*copyc dfe$error_condition_codes
*copyc dmt$disk_file_descriptor
*copyc dmt$error_condition_codes
*copyc dmt$new_file_attribute
*copyc dmt$system_file_id
*copyc gft$file_desc_entry_p
*copyc gft$locked_file_desc_entry_p
*copyc mmc$shadow_allocation_size
*copyc mme$condition_codes
*copyc mmk$job_mode_keypoints
*copyc mmt$access_selections
*copyc mmt$rb_change_segment_table
*copyc mmt$rb_fetch_offset_mod_pages
*copyc mmt$rb_ring1_segment_request
*copyc mmt$rb_ring1_server_seg_request
*copyc mmt$rb_set_get_segment_length
*copyc mmt$segment_attrib_descriptor
*copyc osc$asid_ei
*copyc osc$purge_map_and_cache
*copyc osd$virtual_address
*copyc osk$keypoints
*copyc oss$mainframe_paged_literal
*copyc ost$caller_identifier
*copyc ost$execution_control_block
*copyc ost$heap
*copyc ost$monitor_fault
*copyc ost$status
*copyc ost$system_privilege_map
*copyc rmc$mass_storage_class
*copyc sft$file_space_limit_kind
*copyc syt$user_defined_condition
?? POP ??
?? TITLE := '  External Procedures referenced in this module', EJECT ??
*copyc dfp$set_server_eoi
*copyc dmp$allocate_file_space_r1
*copyc dmp$create_disk_file
*copyc dmp$destroy_file
*copyc dmp$fetch_eoi
*copyc dmp$free_server_file_tables
*copyc dmp$get_disk_file_descriptor_p
*copyc dmp$get_initialized_addresses
*copyc dmp$get_total_allocated_length
*copyc dmp$mm_log_sft_delete
*copyc dpp$put_critical_message
*copyc dmp$reallocate_file_space
*copyc dmp$sparse_allocate
*copyc dmv$active_volume_table
*copyc gfp$assign_fde
*copyc gfp$free_fde
*copyc gfp$get_eoi_from_fde
*copyc gfp$get_fde_p
*copyc gfp$lock_fde
*copyc gfp$unlock_fde_p
*copyc gfp$get_locked_fde_p
*copyc i#build_adaptable_heap_pointer
*copyc i#build_adaptable_seq_pointer
*copyc i#call_monitor
*copyc i#enable_traps
*copyc i#move
*copyc i#real_memory_address
*copyc i#restore_traps
*copyc mmp$advise_in
*copyc mmp$advise_out
*copyc mmp$assign_contiguous_memory
*copyc mmp$convert_ps_transfer_size
*copyc mmp$free_pages
*copyc mmp$get_max_sdt_sdtx_pointer
*copyc mmp$get_sdt_entry_p
*copyc mmp$get_sdtx_entry_p
*copyc mmp$touch_all_pages
*copyc mmp$unlock_segment
*copyc mmp$write_modified_pages
*copyc osp$begin_system_activity
*copyc osp$end_system_activity
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$cycle
*copyc pmp$delay
*copyc pmp$find_executing_task_xcb
*copyc pmp$find_task_xcb
*copyc pmp$get_executing_task_gtid
*copyc pmp$set_system_flag
*copyc pmp$zero_out_table
*copyc syp$cause_condition
*copyc syp$establish_condition_handler
*copyc syp$mfh_for_hang_task
*copyc syp$set_status_from_mtr_status
*copyc syp$return_jobs_r1_resources
*copyc syp$terminate_task
?? TITLE := '  External Variables referenced in this module', EJECT ??
*copyc dmv$idle_system
*copyc gfv$null_sfid
*copyc jmv$executing_within_system_job
*copyc jmv$jcb
*copyc jmv$system_ijl_ordinal
*copyc jmv$task_private_templ_p
*copyc mmv$ast_p
*copyc mmv$big_segment
*copyc mmv$first_transient_seg_index
*copyc mmv$max_pages_no_file
*copyc mmv$page_map_offsets
*copyc mmv$page_streaming_prestream
*copyc mmv$page_streaming_transfer
*copyc mmv$preset_conversion_table
*copyc mmv$shadow_by_segnum
*copyc osv$job_fixed_heap
*copyc osv$cpus_logically_on
*copyc osv$cpus_physically_configured
*copyc osv$page_size
*copyc syv$job_initialization_complete
?? TITLE := '  Global Declarations defined and used in this module', EJECT ??

  CONST
    max_specified_transfer_size = 1048576; { Limit user specified transfer size to 1MB (1,048,576)

{  Define global variables used by this module.

  VAR
    mmv$sfid_match: [XDCL] integer,
    mmv$sfid_mismatch: [XDCL] integer,
    mmv$sparse_threshold: [XDCL] integer := 30 * 4096,  {Arbitrary number}

    mmv$default_sdt_entry: [READ, oss$mainframe_paged_literal] mmt$segment_descriptor :=
          [[osc$vl_regular_segment, osc$non_executable, osc$read_uncontrolled, osc$write_uncontrolled, 1, 1,
          0, [FALSE, FALSE, 0]], 0, 0],
    mmv$default_sdtx_entry: [XDCL, #GATE, READ, oss$mainframe_paged_literal]
          mmt$segment_descriptor_extended := [1, mmc$sas_allow_access, * , mmc$si_none,
          mmc$srs_not_reserved, [], mmc$sar_write_extend, mmc$lss_none, [0, 0, *, mmc$ssk_none, FALSE],
          sfc$no_limit, [0, 0, 2, 0, FALSE, FALSE, FALSE], osc$max_segment_length];

?? TITLE := '  ASID FUNCTIONS - (from common decks)', EJECT ??
*copyc mmp$asid_functions
?? TITLE := '  DESTROY_SEGMENT', EJECT ??
  PROCEDURE destroy_segment
    (    xsfid: gft$system_file_identifier;
         fde_entry_p: gft$file_desc_entry_p;
         file_limits_enforced: sft$file_space_limit_kind;
     VAR status: ost$status);

    VAR
      rb: mmt$rb_ring1_segment_request,
      sfid: gft$system_file_identifier;

    sfid := xsfid;
    IF fde_entry_p^.media = gfc$fm_transient_segment THEN
      IF fde_entry_p^.asti <> 0 THEN
        rb.reqcode := syc$rc_ring1_segment_request;
        rb.request := mmc$sr1_delete_seg_sfid;
        rb.sfid := sfid;
        i#call_monitor (#LOC (rb), #SIZE (rb));
      IFEND;
      gfp$free_fde (fde_entry_p, sfid);
    ELSE
      dmp$destroy_file (sfid, file_limits_enforced, status);
    IFEND;

  PROCEND destroy_segment;
?? TITLE := '  EXPAND_SEGMENT_TABLE', EJECT ??

  PROCEDURE expand_segment_table
    (    xcb_p: ^ost$execution_control_block;
     VAR status: ost$status);

{
{   The purpose of this procedure is to expand the SDT and SDTX when a segment table full
{ situation is encountered when adding a new segment.  Currently, the maximum number of
{ segments a task can have open/attached is 4095.
{

    CONST
      segment_table_size_increase = 32;

    VAR
      new_sdt_length: integer, {must be an integer variable}
      new_table_size: ost$segment_length,
      old_sdt_length: ost$segment,
      old_sdt_offset: 0 .. 0ffffffff(16),
      old_sdtx_offset: 0 .. 0ffffffff(16),
      old_sdt_p: ^cell,
      old_sdtx_p: ^cell,
      new_sdt_p: ^mmt$segment_descriptor_table,
      new_sdtx_p: ^mmt$segment_descriptor_table_ex,
      request_block: mmt$rb_change_segment_table;

    status.normal := TRUE;

{ Save the following values, so that the old SDT and SDTX can be freed after
{ the new ones are successsfully allocated.

    old_sdt_offset := xcb_p^.sdt_offset;
    old_sdtx_offset := xcb_p^.sdtx_offset;
    old_sdt_length := xcb_p^.xp.segment_table_length;

    new_sdt_length := xcb_p^.xp.segment_table_length + segment_table_size_increase;

    IF ((new_sdt_length + 1) * 8) > osv$page_size THEN
      new_sdt_length := ((((new_sdt_length + 1) * 8) + osv$page_size) DIV osv$page_size);
      new_table_size := new_sdt_length * osv$page_size;
      new_sdt_length := ((new_sdt_length * osv$page_size) DIV 8) - 1;
    IFEND;

    IF new_sdt_length >= 4096 THEN
      new_sdt_length := 4095;
    IFEND;

    IF new_sdt_length = xcb_p^.xp.segment_table_length THEN
      osp$set_status_abnormal ('MM', mme$segment_table_is_full, '', status);
      RETURN;
    IFEND;

    ALLOCATE new_sdt_p: [0 .. new_sdt_length] IN osv$job_fixed_heap^;

    IF ((new_sdt_length + 1) * 8) > osv$page_size THEN
      mmp$free_pages (new_sdt_p, new_table_size, osc$nowait, status);
      mmp$assign_contiguous_memory (new_sdt_p, new_table_size, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      pmp$zero_out_table (#LOC (new_sdt_p^), #SIZE (new_sdt_p^));
    IFEND;

{  Allocate and zero out the SDTX.

    ALLOCATE new_sdtx_p: [0 .. new_sdt_length] IN osv$job_fixed_heap^;

    pmp$zero_out_table (#LOC (new_sdtx_p^), #SIZE (new_sdtx_p^));

{  Issue monitor request to move old segment table to new segment table, update segment table
{  address and segment table length in task's exchange package.

    request_block.request_code := syc$rc_change_segment_table;
    request_block.new_sdt_offset := #OFFSET (new_sdt_p);
    request_block.new_sdtx_offset := #OFFSET (new_sdtx_p);
    request_block.new_sdt_length := new_sdt_length;
    i#call_monitor (#LOC (request_block), #SIZE (request_block));
    syp$set_status_from_mtr_status (request_block.status, status);
    IF NOT status.normal THEN
      osp$system_error ('Error in change segment table monitor request.', ^status);
      RETURN;
    IFEND;

{  Free the old SDT and SDTX tables.
{  NOTE: Job monitor's SDT and SDTX are not allocated, hence they can not be freed unless they
{        have been expanded once.

    IF (old_sdt_length * 8) > osv$page_size THEN
      mmp$free_pages (#ADDRESS (1, osc$segnum_job_fixed_heap, old_sdtx_offset),
            (old_sdt_length * #SIZE (mmt$segment_descriptor_extended)), osc$wait, status);
    IFEND;
    IF old_sdt_offset >= #OFFSET (osv$job_fixed_heap) THEN
      old_sdt_p := #ADDRESS (1, osc$segnum_job_fixed_heap, old_sdt_offset);
      old_sdtx_p := #ADDRESS (1, osc$segnum_job_fixed_heap, old_sdtx_offset);
      FREE old_sdt_p IN osv$job_fixed_heap^;
      FREE old_sdtx_p IN osv$job_fixed_heap^;
    IFEND;

  PROCEND expand_segment_table;

?? TITLE := '  FIND_AVAILABLE_SEGMENT_NUMBER', EJECT ??

  PROCEDURE find_available_segment_number
    (    xcb_p: ^ost$execution_control_block;
         segment_res_state: mmt$segment_reservation_state;
     VAR segnum: ost$segment;
     VAR status: ost$status);

    VAR
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      segment_table_length: integer;


    {  Find an available segment number.

    status.normal := TRUE;
    segnum := mmv$first_transient_seg_index - 1;
    segment_table_length := xcb_p^.xp.segment_table_length;
    mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);

    REPEAT
      IF segnum < 0FFF(16) THEN
        segnum := segnum + 1;
      ELSE
        osp$set_status_abnormal ('MM', mme$segment_table_is_full, '', status);
        RETURN;
      IFEND;
      IF segnum > segment_table_length THEN
        expand_segment_table (xcb_p, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        segment_table_length := xcb_p^.xp.segment_table_length;
      IFEND;
    UNTIL (sdt_p^.st [segnum].ste.vl = osc$vl_invalid_entry) AND
          (sdtx_p^.sdtx_table [segnum].segment_reservation_state = segment_res_state);

  PROCEND find_available_segment_number;

?? TITLE := '  STORE_STE_IN_SEGMENT_TABLE', EJECT ??

  PROCEDURE store_ste_in_segment_table
    (    xsdt_entry: mmt$segment_descriptor;
         sfid: gft$system_file_identifier;
         ste_p: ^mmt$segment_descriptor;
         fde_entry_p: gft$locked_file_desc_entry_p;
         segnum: ost$segment);

{ This routine is tricky so make sure you understand it before changing it!!!!!!!!!!!
{ This routine stores a STE entry into the segment table. If the ASID in the new ste
{ entry is zero then the procedure is straightforward.
{ If, however, the STE already has an ASID then things get more complicated since monitor may be
{ changing the ASID asynchronously while this routine is running.
{       . NEVER let a STE entry get into the segment table if the ASID/ASTI dont match
{       . after putting an entry in with a non-zero ASID, check the AST to see if the AST.SFID
{         agrees with the SDTX.SFID. IF they agree all is well. Otherwise, clear the ASID/ASTI to zero;
{         the assumption is that Memory Manager changed the ASID. The correct ASID will be fetched
{         on the first page fault. (this should not happen very much.)

    VAR
      aste_p: ^mmt$active_segment_table_entry,
      asid: ost$asid,
      asti: mmt$ast_index,
      rb: mmt$rb_ring1_segment_request,
      sdt_entry: mmt$segment_descriptor;

    sdt_entry := xsdt_entry;
    asti := fde_entry_p^.asti;
    IF (asti = 0) OR (sdt_entry.ste.asid = 0FFFF(16)) OR (mmv$ast_p = NIL) THEN
      ste_p^ := sdt_entry;
    ELSE
      sdt_entry.asti := asti;
      mmp$asid (asti, asid);
      sdt_entry.ste.asid := asid;
      ste_p^ := sdt_entry;
      aste_p := ^mmv$ast_p^ [sdt_entry.asti];

      IF (aste_p^.in_use) AND (aste_p^.sfid = sfid) AND

            (((sfid.residence = gfc$tr_job) AND (aste_p^.ijl_ordinal = jmv$jcb.ijl_ordinal)) OR

            ((sfid.residence = gfc$tr_system) AND

            (((aste_p^.queue_id = mmc$pq_job_working_set) AND
              (aste_p^.ijl_ordinal = jmv$jcb.ijl_ordinal) AND
              ((fde_entry_p^.queue_status = gfc$qs_job_working_set) OR
              ((fde_entry_p^.queue_status = gfc$qs_job_shared) AND (fde_entry_p^.attach_count = 1)))) OR

            (((aste_p^.queue_id >= mmc$pq_shared_first) AND (aste_p^.queue_id <= mmc$pq_shared_last)) AND
              (aste_p^.ijl_ordinal = jmv$system_ijl_ordinal) AND
              ((fde_entry_p^.queue_status = gfc$qs_global_shared) OR
              ((fde_entry_p^.queue_status = gfc$qs_job_shared) AND (fde_entry_p^.attach_count > 1))))))) THEN

        mmv$sfid_match := mmv$sfid_match + 1;
      ELSE
        mmv$sfid_mismatch := mmv$sfid_mismatch + 1;
        ste_p^ := xsdt_entry;

{ If the file is job shared and there is more that one user (attach) of the file, the above tests which
{ would have allowed the asid to be stored may have failed because pages of the file are being kept in
{ the working set and should now be kept in the shared queue.  (Or they may have failed because the
{ asid changed--we can't be sure by looking at the ast.queue_id.)  Issue a monitor request to straighten
{ out job shared files.  If there is more than one user, pages of job shared files must be removed
{ from the jws of the original job and moved to the shared queue before a second user can reference
{ any of the pages.

        IF (fde_entry_p^.queue_status = gfc$qs_job_shared) AND (fde_entry_p^.attach_count > 1) THEN
          rb.reqcode := syc$rc_ring1_segment_request;
          rb.request := mmc$sr1_remove_job_shared_pages;
          rb.system_file_id := sfid;
          rb.segment_number := segnum;
          rb.server_file := FALSE;
          i#call_monitor (#LOC (rb), #SIZE (rb));
        IFEND;
      IFEND;
    IFEND;
  PROCEND store_ste_in_segment_table;

?? TITLE := '  ADD_SDT_SDTX_ENTRY', EJECT ??
*copy mmh$add_sdt_sdtx_entry

  PROCEDURE add_sdt_sdtx_entry
    (    sdt_entry: mmt$segment_descriptor;
         sdtx_entry: mmt$segment_descriptor_extended;
         fde_entry_p: gft$locked_file_desc_entry_p;
         shared_taskid_array: ^array [1 .. * ] of pmt$task_id;
         segment_number: ost$segment);

    VAR
      cache_bypass: boolean,
      cell_p: ^cell,
      i: integer,
      local_sdt: mmt$segment_descriptor,
      local_sdtx: mmt$segment_descriptor_extended,
      pva_p: ^ost$pva,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      shadow_fde_p: gft$locked_file_desc_entry_p,
      task_sdt_p: ^mmt$segment_descriptor,
      task_sdtx_p: ^mmt$segment_descriptor_extended,
      task_xcb: ^ost$execution_control_block,
      xcb_p: ^ost$execution_control_block;

    local_sdt := sdt_entry;
    local_sdtx := sdtx_entry;

    pmp$find_executing_task_xcb (xcb_p);

{ Set cache bypass if required for multiprocessing.

    cache_bypass := FALSE;
    IF osv$cpus_physically_configured > 1 THEN
      IF (local_sdt.ste.xp = osc$non_executable) OR ((local_sdt.ste.xp <> osc$non_executable) AND
            (local_sdt.ste.wp <> osc$non_writable)) THEN

{ I dont think we need a clause for global_unnamed files because it appears
{ that they would drop out anyway.

        IF (fde_entry_p^.file_kind <> gfc$fk_unnamed_file) THEN
          IF (fde_entry_p^.queue_status = gfc$qs_job_working_set) THEN
            IF (jmv$jcb.ijle_p^.multiprocessing_allowed) THEN
              cache_bypass := TRUE;
              local_sdt.ste.vl := osc$vl_cache_bypass;
            IFEND;
          ELSE
            IF (fde_entry_p^.queue_status = gfc$qs_global_shared) THEN
              cache_bypass := TRUE;
              local_sdt.ste.vl := osc$vl_cache_bypass;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;


{  Add sdt_entry to the task's segment descriptor table (SDT) and the sdtx_entry to the
{  segment descriptor table extended (SDTX).

    sdt_entry_p := mmp$get_sdt_entry_p (xcb_p, segment_number);
    sdtx_entry_p := mmp$get_sdtx_entry_p (xcb_p, segment_number);
    local_sdtx.segment_reservation_state := sdtx_entry_p^.segment_reservation_state;
    mmp$set_segment_access_rights (local_sdt, local_sdtx);

    sdtx_entry_p^ := local_sdtx;
    store_ste_in_segment_table (local_sdt, local_sdtx.sfid, sdt_entry_p, fde_entry_p, segment_number);
    fde_entry_p^.open_count := fde_entry_p^.open_count + 1;

    IF local_sdtx.shadow_info.shadow_segment_kind <> mmc$ssk_none THEN
      gfp$get_locked_fde_p (local_sdtx.shadow_info.shadow_sfid, shadow_fde_p);
      shadow_fde_p^.open_count := shadow_fde_p^.open_count + 1;
      gfp$unlock_fde_p (shadow_fde_p);
    IFEND;

{If a stack segment was just created, update the TOS pointer.

    IF mmc$sa_stack IN sdtx_entry.software_attribute_set THEN
      cell_p := #ADDRESS (local_sdt.ste.r1, segment_number,
            (mmv$page_map_offsets [mmc$pmo_user_stack] * osv$page_size) + mmc$ring_crossing_offset);
      pva_p := #LOC (cell_p);
      xcb_p^.xp.tos_registers [local_sdt.ste.r1].pva := pva_p^;
      fde_entry_p^.stack_for_ring := local_sdt.ste.r1;
      IF local_sdt.ste.r1 > 3 THEN
        sdtx_entry_p^.file_limits_enforced := sfc$temp_file_space_limit;
      IFEND;
    IFEND;

    IF shared_taskid_array <> NIL THEN

      { Mmc$sa_stack is removed from the software attribute set before the sdtx entry of the segment
      { is propagated to all of the other tasks. The task which opens the stack segment will be
      { the only task with mmc$sa_stack in its sdtx entry.

      local_sdtx.software_attribute_set := local_sdtx.software_attribute_set -
            $mmt$software_attribute_set [mmc$sa_stack];
      FOR i := LOWERBOUND (shared_taskid_array^) TO UPPERBOUND (shared_taskid_array^) DO
        pmp$find_task_xcb (shared_taskid_array^ [i], task_xcb);
        IF task_xcb <> xcb_p THEN
          task_sdt_p := mmp$get_sdt_entry_p (task_xcb, segment_number);
          task_sdtx_p := mmp$get_sdtx_entry_p (task_xcb, segment_number);
          task_sdtx_p^ := local_sdtx;
          mmp$set_segment_access_rights (local_sdt, task_sdtx_p^);
          store_ste_in_segment_table (local_sdt, local_sdtx.sfid, task_sdt_p, fde_entry_p, segment_number);
          fde_entry_p^.open_count := fde_entry_p^.open_count + 1;
        IFEND;
      FOREND;
    IFEND;

    IF (osv$cpus_logically_on > 1) AND (NOT cache_bypass) THEN
      cell_p := #ADDRESS (1, segment_number, 0);
      #PURGE_BUFFER (osc$pva_purge_segment_cache, cell_p);
    IFEND;

  PROCEND add_sdt_sdtx_entry;

?? TITLE := '  MMP$ASSIGN_MASS_STORAGE', EJECT ??
{
{ Purpose:
{    This procedure assigns disk space for all pages currently assigned to a segment/file.
{    If necessary, it converts a transient file into a disk file.
{
{  segment_number: If non zero, this specifies the segment number
{  sfid: If segment number is zero, this is the SFID of the file
{  min_allocation_length: Normally zero. If zero disk space is assigned to all
{     pages that exist in the file. If non-zero, contiguous disk space is assign for
{     offset zero thru this offset. NOTE if
{
{


  PROCEDURE [XDCL, #GATE] mmp$assign_mass_storage
    (    segment_number: ost$segment;
         xsfid: gft$system_file_identifier;
         min_allocation_length: ost$segment_length;
     VAR status: ost$status);

    VAR
      assign_active: amt$file_byte_address,
      fde_p: gft$locked_file_desc_entry_p,
      file_attributes_p: ^array [1 .. * ] of dmt$file_attribute,
      file_limits: sft$file_space_limit_kind,
      length_to_allocate: ost$segment_length,
      max_pages_no_file: integer,
      page_streaming_ts_shift: 0 .. 15,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      sfid: gft$system_file_identifier,
      xcb_p: ^ost$execution_control_block;


    status.normal := TRUE;

    pmp$find_executing_task_xcb (xcb_p);
    IF segment_number <> 0 THEN
      sdtx_entry_p := mmp$get_sdtx_entry_p (xcb_p, segment_number);
      file_limits := sdtx_entry_p^.file_limits_enforced;
      assign_active := sdtx_entry_p^.assign_active;
      sfid := sdtx_entry_p^.sfid;
      IF (mmc$sa_wired IN sdtx_entry_p^.software_attribute_set) OR
            (mmc$sa_fixed IN sdtx_entry_p^.software_attribute_set) THEN
        osp$set_status_abnormal ('MM', mme$segment_not_pageable, '', status);
        RETURN;
      IFEND;
    ELSE
      file_limits := sfc$no_limit;
      assign_active := mmc$assign_active_escaped;
      sfid := xsfid;
    IFEND;


    gfp$get_locked_fde_p (sfid, fde_p);

    IF NOT dmv$idle_system THEN
      IF fde_p^.media = gfc$fm_transient_segment THEN
        IF fde_p^.flags.active_shadow_file  THEN
          PUSH file_attributes_p: [1 .. 3];
          file_attributes_p^ [2].keyword := dmc$requested_allocation_size;
          file_attributes_p^ [2].requested_allocation_size := mmc$shadow_allocation_size;
          file_attributes_p^ [3].keyword := dmc$requested_transfer_size;
          file_attributes_p^ [3].requested_transfer_size := mmc$shadow_allocation_size;
        ELSE
          PUSH file_attributes_p: [1 .. 1];
        IFEND;
        file_attributes_p^ [1].keyword := dmc$class;
        IF jmv$executing_within_system_job THEN
          file_attributes_p^ [1].class := rmc$msc_system_critical_files;
        ELSE
          file_attributes_p^ [1].class := rmc$msc_user_temporary_files;
        IFEND;
        dmp$create_disk_file (fde_p, file_attributes_p, 0, sfid, status);
        IF (segment_number <> 0) AND NOT sdtx_entry_p^.stream.transfer_size_specified THEN
          mmp$convert_ps_transfer_size (fde_p^.transfer_unit_size, page_streaming_ts_shift);
          sdtx_entry_p^.stream.transfer_size := page_streaming_ts_shift;
        IFEND;
      IFEND;

      IF status.normal THEN
        length_to_allocate := fde_p^.eoi_byte_address;
        IF (min_allocation_length > 0) OR (length_to_allocate < mmv$sparse_threshold) OR
              (fde_p^.media = gfc$fm_served_file) THEN
          IF length_to_allocate < min_allocation_length THEN
            length_to_allocate := min_allocation_length;
          IFEND;
          dmp$allocate_file_space_r1 (sfid, 0, length_to_allocate, 0, osc$nowait, file_limits, status);
        ELSE
          dmp$sparse_allocate (sfid, assign_active, file_limits, status);
        IFEND;
      IFEND;
    IFEND;

    gfp$unlock_fde_p (fde_p);

{ If everything worked OK, clear the assign active flag in the SDTX or XCB since there cannot
{ be any more escaped allocation or allocation required.

    IF status.normal THEN
      IF segment_number <> 0 THEN
        sdtx_entry_p^.assign_active := mmc$assign_active_null;
      ELSE
        xcb_p^.assign_active_sfid := gfv$null_sfid;
      IFEND;
    IFEND

  PROCEND mmp$assign_mass_storage;

?? TITLE := '  MMP$BUILD_SEGMENT', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$build_segment
    (    attrib: mmt$segment_attrib_descriptor;
         shared_taskid_array: ^array [1 .. * ] of pmt$task_id;
     VAR segment_pointer: mmt$segment_pointer;
     VAR status: ost$status);

    VAR
      i: integer,
      fde_entry_p: gft$file_desc_entry_p,
      file_hash: 0 .. 255,
      locked_fde_entry_p: gft$locked_file_desc_entry_p,
      page_streaming_ts_shift: 0 .. 15,
      page_streaming_transfer_size: integer,
      sdt_entry: mmt$segment_descriptor,
      sdtx_entry: mmt$segment_descriptor_extended,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segment_length: ost$segment_length,
      segment_number: ost$segment,
      segment_res_state: mmt$segment_reservation_state,
      sfid: gft$system_file_identifier,
      shadow_fde_p: gft$file_desc_entry_p,
      shadow_sdt_p: ^mmt$segment_descriptor,
      shadow_sdtx_p: ^mmt$segment_descriptor_extended,
      task_xcb: ^ost$execution_control_block,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    sdt_entry := mmv$default_sdt_entry;
    sdtx_entry := mmv$default_sdtx_entry;
    sdt_entry.ste.r1 := attrib.validating_ring_number;
    sdt_entry.ste.r2 := attrib.validating_ring_number;
    sdtx_entry.open_validating_ring_number := attrib.validating_ring_number;
    sdtx_entry.file_limits_enforced := attrib.file_limits_to_enforce;
    segment_number := 0;
    IF shared_taskid_array <> NIL THEN
      FOR i := LOWERBOUND (shared_taskid_array^) TO UPPERBOUND (shared_taskid_array^) DO
        pmp$find_task_xcb (shared_taskid_array^ [i], task_xcb);
        IF task_xcb = NIL THEN
          osp$set_status_abnormal ('MM', mme$invalid_shared_taskid, '', status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;
    IF attrib.sfid = gfv$null_sfid THEN
      gfp$assign_fde (gfc$tr_job, segment_number, sfid, fde_entry_p);
      IF fde_entry_p = NIL THEN
        osp$set_status_abnormal ('MM', mme$unable_to_assign_fde, '', status);
        RETURN;
      IFEND;
      gfp$get_locked_fde_p (sfid, locked_fde_entry_p);
      locked_fde_entry_p^.queue_status := gfc$qs_job_working_set;
      locked_fde_entry_p^.file_kind := gfc$fk_unnamed_file;
    ELSE
      sfid := attrib.sfid;
      gfp$get_locked_fde_p (sfid, locked_fde_entry_p);
      IF locked_fde_entry_p = NIL THEN
        osp$set_status_abnormal ('MM', mme$invalid_sfid, '', status);
        RETURN;
      IFEND;
    IFEND;

    sdtx_entry.sfid := sfid;

  /user_attributes/
    BEGIN
      IF attrib.user_attributes <> NIL THEN
        FOR i := LOWERBOUND (attrib.user_attributes^) TO UPPERBOUND (attrib.user_attributes^) DO
          CASE attrib.user_attributes^ [i].keyword OF
          = mmc$kw_null_keyword =
          = mmc$kw_ring_numbers =
            IF (attrib.user_attributes^ [i].r1 > attrib.user_attributes^ [i].r2) OR
                  (attrib.user_attributes^ [i].r2 = 0) THEN
              osp$set_status_abnormal ('MM', mme$invalid_ring_brackets, '', status);
              EXIT /user_attributes/;
            IFEND;
            sdt_entry.ste.r1 := attrib.user_attributes^ [i].r1;
            sdt_entry.ste.r2 := attrib.user_attributes^ [i].r2;
          = mmc$kw_segment_number =
            segment_number := attrib.user_attributes^ [i].segnum;
          = mmc$kw_hardware_attributes =
            IF mmc$ha_read IN attrib.user_attributes^ [i].hardware_attri_set THEN
              sdt_entry.ste.rp := osc$read_uncontrolled;
            ELSE
              sdt_entry.ste.rp := osc$non_readable;
            IFEND;
            IF mmc$ha_binding IN attrib.user_attributes^ [i].hardware_attri_set THEN
              IF attrib.validating_ring_number <= 3 THEN
                sdt_entry.ste.rp := osc$binding_segment;
              ELSE
                osp$set_status_abnormal ('MM', mme$binding_attribute_invalid, '', status);
                EXIT /user_attributes/;
              IFEND;
            IFEND;
            IF mmc$ha_write IN attrib.user_attributes^ [i].hardware_attri_set THEN
              sdt_entry.ste.wp := osc$write_uncontrolled;
            ELSE
              sdt_entry.ste.wp := osc$non_writable;
            IFEND;
            IF mmc$ha_cache_bypass IN attrib.user_attributes^ [i].hardware_attri_set THEN
              sdt_entry.ste.vl := osc$vl_cache_bypass;
            ELSE
              sdt_entry.ste.vl := osc$vl_regular_segment;
            IFEND;
            IF mmc$ha_execute IN attrib.user_attributes^ [i].hardware_attri_set THEN
              sdt_entry.ste.xp := osc$non_privileged;
            ELSE
              IF mmc$ha_execute_local IN attrib.user_attributes^ [i].hardware_attri_set THEN
                sdt_entry.ste.xp := osc$local_privilege;
              ELSE
                IF (mmc$ha_execute_global IN attrib.user_attributes^ [i].hardware_attri_set) AND
                      (attrib.validating_ring_number > 1) THEN
                  osp$set_status_abnormal ('MM', mme$execute_global_invalid, '', status);
                  EXIT /user_attributes/;
                ELSE
                  sdt_entry.ste.xp := osc$non_executable;
                IFEND;
              IFEND;
            IFEND;
          = mmc$kw_software_attributes =
            IF attrib.validating_ring_number <= 3 THEN
              sdtx_entry.software_attribute_set := attrib.user_attributes^ [i].software_attri_set;
            ELSEIF ((attrib.validating_ring_number <= 6) AND (($mmt$software_attribute_set [mmc$sa_stack] *
                  attrib.user_attributes^ [i].software_attri_set) <> $mmt$software_attribute_set [])) OR
                  ((attrib.validating_ring_number > 6) AND (($mmt$software_attribute_set
                  [mmc$sa_wired, mmc$sa_fixed, mmc$sa_stack] * attrib.user_attributes^ [i].
                  software_attri_set) <> $mmt$software_attribute_set [])) THEN
              osp$set_status_abnormal ('MM', mme$software_attribute_invalid, '', status);
              EXIT /user_attributes/;
            ELSE
              sdtx_entry.software_attribute_set := attrib.user_attributes^ [i].software_attri_set;
            IFEND;
          = mmc$kw_error_exit_procedure =
            osp$set_status_abnormal ('MM', mme$unsupported_keyword, '', status);
            EXIT /user_attributes/;
          = mmc$kw_max_segment_length =
            locked_fde_entry_p^.file_limit := attrib.user_attributes^ [i].max_length;
          = mmc$kw_gl_key =
            sdt_entry.ste.key_lock := attrib.user_attributes^ [i].gl_key;
          = mmc$kw_clear_space =
          = mmc$kw_preset_value =
            locked_fde_entry_p^.preset_value := attrib.user_attributes^ [i].preset_value;
          = mmc$kw_segment_access_control =
            IF attrib.user_attributes^ [i].access_control.cache_bypass = TRUE THEN
              sdt_entry.ste.vl := osc$vl_cache_bypass;
            ELSE
              sdt_entry.ste.vl := osc$vl_regular_segment;
            IFEND;

            IF (attrib.user_attributes^ [i].access_control.execute_privilege = osc$global_privilege) AND
                  (attrib.validating_ring_number > 1) THEN
              osp$set_status_abnormal ('MM', mme$execute_global_invalid, '', status);
              EXIT /user_attributes/;
            ELSE
              sdt_entry.ste.xp := attrib.user_attributes^ [i].access_control.execute_privilege;
            IFEND;

            IF (attrib.user_attributes^ [i].access_control.read_privilege = osc$binding_segment) AND
                  (attrib.validating_ring_number > 3) THEN
              osp$set_status_abnormal ('MM', mme$binding_attribute_invalid, '', status);
              EXIT /user_attributes/;
            IFEND;
            sdt_entry.ste.rp := attrib.user_attributes^ [i].access_control.read_privilege;
            sdt_entry.ste.wp := attrib.user_attributes^ [i].access_control.write_privilege;
          = mmc$kw_asid =
            IF attrib.validating_ring_number <> 1 THEN
              osp$set_status_abnormal ('MM', mme$asid_specified, '', status);
              EXIT /user_attributes/;
            IFEND;

            IF (attrib.user_attributes^ [i].asid = osc$asid_ei) OR
                  (attrib.user_attributes^ [i].asid = osc$asid_eie) OR
                  (attrib.user_attributes^ [i].asid = osc$asid_nos) THEN
              sdt_entry.ste.asid := attrib.user_attributes^ [i].asid;
            ELSE
              osp$set_status_abnormal ('MM', mme$invalid_asid_specified, '', status);
              EXIT /user_attributes/;
            IFEND;
          = mmc$kw_wired_segment =
            sdtx_entry.software_attribute_set := sdtx_entry.software_attribute_set +
                  $mmt$software_attribute_set [mmc$sa_wired];
            locked_fde_entry_p^.file_limit := attrib.user_attributes^ [i].wired_segment_length;
          = mmc$kw_inheritance =
            sdtx_entry.inheritance := attrib.user_attributes^ [i].inheritance;
          = mmc$kw_shadow_segment =
            IF ((attrib.user_attributes^ [i].shadow_length MOD mmc$shadow_allocation_size) <> 0) THEN
              osp$set_status_abnormal ('MM', mme$length_not_0_mod_16384, '', status);
              EXIT /user_attributes/;
            IFEND;
            IF ((#OFFSET (attrib.user_attributes^ [i].shadow_p) MOD mmc$shadow_allocation_size) <> 0) THEN
              osp$set_status_abnormal ('MM', mme$address_not_0_mod_16384, '', status);
              EXIT /user_attributes/;
            IFEND;
            sdtx_entry.shadow_info.shadow_length_page_count :=
                  attrib.user_attributes^ [i].shadow_length DIV osv$page_size;
            sdtx_entry.shadow_info.shadow_start_page_number := #OFFSET (attrib.user_attributes^ [i].
                  shadow_p) DIV osv$page_size;
            mmp$validate_segment_number (#SEGMENT (attrib.user_attributes^ [i].shadow_p),
                  shadow_sdt_p, shadow_sdtx_p, status);
            IF NOT status.normal THEN
              EXIT /user_attributes/;
            IFEND;
            IF shadow_sdtx_p^.shadow_info.shadow_segment_kind <> mmc$ssk_none THEN
              osp$set_status_abnormal ('MM', mme$invalid_shadow_segment, '', status);
              EXIT /user_attributes/;
            IFEND;
            sdtx_entry.shadow_info.shadow_segment_kind := mmc$ssk_segment_number;
            sdtx_entry.shadow_info.shadow_segment_number := #SEGMENT (attrib.user_attributes^ [i].shadow_p);
            sdtx_entry.shadow_info.shadow_sfid := shadow_sdtx_p^.sfid;
            locked_fde_entry_p^.flags.active_shadow_file := TRUE;
            shadow_sdtx_p^.shadow_info.passive_for_shadow_by_segnum := TRUE;
          = mmc$kw_ps_transfer_size =
            page_streaming_transfer_size := attrib.user_attributes^ [i].ps_transfer_size;
            IF page_streaming_transfer_size > max_specified_transfer_size THEN
              page_streaming_transfer_size := max_specified_transfer_size;
            IFEND;
            mmp$convert_ps_transfer_size (page_streaming_transfer_size, page_streaming_ts_shift);
            sdtx_entry.stream.transfer_size := page_streaming_ts_shift;
            sdtx_entry.stream.transfer_size_specified := TRUE;
          ELSE
            EXIT /user_attributes/;
          CASEND;
        FOREND;
      IFEND;

{  Find an available segment number if the caller did not supply one.

      pmp$find_executing_task_xcb (xcb_p);

      IF segment_number = 0 THEN
        IF shared_taskid_array = NIL THEN
          segment_res_state := mmc$srs_not_reserved;
        ELSE
          segment_res_state := mmc$srs_reserved_shared_stack;
        IFEND;
        find_available_segment_number (xcb_p, segment_res_state, segment_number, status);
      ELSE
        mmp$validate_segment_number (segment_number, sdt_entry_p, sdtx_entry_p, status);
        IF NOT status.normal AND (status.condition = mme$segment_number_not_in_use) THEN
          status.normal := TRUE;
          WHILE (segment_number > xcb_p^.xp.segment_table_length) DO
            expand_segment_table (xcb_p, status);
            IF NOT status.normal THEN
              EXIT /user_attributes/;
            IFEND;
          WHILEND;
        ELSEIF status.normal THEN
          osp$set_status_abnormal ('MM', mme$segment_number_is_in_use, '', status);
        IFEND;
      IFEND;
    END /user_attributes/;

    IF NOT status.normal THEN
      gfp$unlock_fde_p (locked_fde_entry_p);
      IF attrib.sfid = gfv$null_sfid THEN
        gfp$free_fde (fde_entry_p, sfid);
      IFEND;
      RETURN;
    IFEND;

    locked_fde_entry_p^.last_segment_number := segment_number;
    locked_fde_entry_p^.global_task_id := xcb_p^.global_task_id;

    IF (mmc$sa_read_transfer_unit IN sdtx_entry.software_attribute_set) THEN
      sdtx_entry.stream.sequential_accesses := mmv$page_streaming_prestream;
    IFEND;

    IF NOT sdtx_entry.stream.transfer_size_specified THEN
      mmp$convert_ps_transfer_size (locked_fde_entry_p^.transfer_unit_size, page_streaming_ts_shift);
      IF mmv$page_streaming_transfer > 0 THEN {override transfer size with mmv$page_streaming_transfer
        mmp$convert_ps_transfer_size (mmv$page_streaming_transfer, page_streaming_ts_shift);
      IFEND;
      sdtx_entry.stream.transfer_size := page_streaming_ts_shift;
    IFEND;

    add_sdt_sdtx_entry (sdt_entry, sdtx_entry, locked_fde_entry_p, shared_taskid_array, segment_number);

    IF locked_fde_entry_p^.file_limit < osc$maximum_offset THEN
      segment_length := locked_fde_entry_p^.file_limit;
    ELSE
      segment_length := osc$maximum_offset;
    IFEND;

    CASE attrib.pointer_kind OF
    = mmc$sequence_pointer =
      i#build_adaptable_seq_pointer (sdt_entry.ste.r1, segment_number, 0 {offset} , segment_length, 0,
            segment_pointer.seq_pointer);
    = mmc$heap_pointer =
      i#build_adaptable_heap_pointer (sdt_entry.ste.r1, segment_number, 0 {offset} , segment_length,
            segment_pointer.heap_pointer);
    ELSE
      segment_pointer.cell_pointer := #ADDRESS (sdt_entry.ste.r1, segment_number, 0 {offset} );
    CASEND;

    gfp$unlock_fde_p (locked_fde_entry_p);

  PROCEND mmp$build_segment;
?? TITLE := '  MMP$CHANGE_SEG_INHERITANCE_R1', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$change_seg_inheritance_r1
    (    segment_number: ost$segment;
         validating_ring: ost$valid_ring;
         segment_inheritance: mmt$segment_inheritance;
     VAR status: ost$status);

    VAR
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended;

    mmp$validate_segment_number (segment_number, sdt_entry_p, sdtx_entry_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (validating_ring > sdt_entry_p^.ste.r2) THEN
      osp$set_status_abnormal ('MM', mme$ring_violation, '', status);
      RETURN;
    IFEND;

    IF (segment_inheritance = mmc$si_transfer_segment) AND (sdtx_entry_p^.inheritance = mmc$si_none) THEN
      sdtx_entry_p^.inheritance := mmc$si_transfer_segment;
    ELSEIF (segment_inheritance = mmc$si_share_segment) AND (sdtx_entry_p^.inheritance = mmc$si_none) THEN
      sdtx_entry_p^.inheritance := mmc$si_share_segment;
    ELSE
      osp$set_status_abnormal ('MM', mme$illegal_segment_origin_chg, '', status);
    IFEND;

  PROCEND mmp$change_seg_inheritance_r1;

?? TITLE := '  MMP$CHANGE_SEGMENT_NUMBER_R1', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$change_segment_number_r1
    (    old_segment_number: ost$segment;
         new_segment_number: ost$segment;
         validating_ring_number: ost$valid_ring;
     VAR status: ost$status);

    VAR
      dummy_sdte_p: ^mmt$segment_descriptor,
      dummy_sdtxe_p: ^mmt$segment_descriptor_extended,
      fde_entry_p: gft$locked_file_desc_entry_p,
      new_sdt_entry: mmt$segment_descriptor,
      new_sdtx_entry: mmt$segment_descriptor_extended,
      old_sdt_p: ^mmt$segment_descriptor,
      old_sdtx_p: ^mmt$segment_descriptor_extended,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_xcb (xcb_p);

    mmp$fetch_sdt_sdtx_locked_fde (old_segment_number, old_sdt_p, old_sdtx_p, fde_entry_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (validating_ring_number > old_sdtx_p^.open_validating_ring_number) THEN
      gfp$unlock_fde_p (fde_entry_p);
      osp$set_status_abnormal ('MM', mme$ring_violation, '', status);
      RETURN;
    IFEND;

    mmp$validate_segment_number (new_segment_number, dummy_sdte_p, dummy_sdtxe_p, status);
    IF NOT status.normal AND (status.condition = mme$segment_number_not_in_use) THEN
      status.normal := TRUE;
      WHILE (new_segment_number > xcb_p^.xp.segment_table_length) DO
        expand_segment_table (xcb_p, status);
        IF NOT status.normal THEN
          gfp$unlock_fde_p (fde_entry_p);
          RETURN;
        IFEND;
      WHILEND;
    ELSEIF status.normal THEN
      gfp$unlock_fde_p (fde_entry_p);
      osp$set_status_abnormal ('MM', mme$segment_number_is_in_use, '', status);
      RETURN;
    IFEND;

    new_sdt_entry := old_sdt_p^;
    new_sdtx_entry := old_sdtx_p^;

    add_sdt_sdtx_entry (new_sdt_entry, new_sdtx_entry, fde_entry_p, NIL, new_segment_number);

    mmp$invalidate_segment (old_segment_number, 1, NIL {shared_taskid} , status);

    gfp$unlock_fde_p (fde_entry_p);

  PROCEND mmp$change_segment_number_r1;
?? TITLE := '  MMP$CHANGE_STACK_ATTRIBUTE_R1', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$change_stack_attribute_r1
    (    stack_pages_to_be_freed: boolean;
         caller_ring: ost$valid_ring;
     VAR status: ost$status);

    VAR
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_xcb (xcb_p);
    xcb_p^.stack_pages_saved [caller_ring] := NOT (stack_pages_to_be_freed);

  PROCEND mmp$change_stack_attribute_r1;
?? TITLE := '  MMP$CLOSE_ASID_BASED_SEGMENT', EJECT ??

  PROCEDURE [XDCL] mmp$close_asid_based_segment
    (    segment_number: ost$segment;
     VAR status: ost$status);

    VAR
      pva: ^cell,
      sdt_entry_p: ^mmt$segment_descriptor,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_xcb (xcb_p);

    IF segment_number > xcb_p^.xp.segment_table_length THEN
      osp$set_status_abnormal ('MM', mme$segment_number_too_big, '', status);
      RETURN;
    IFEND;

    sdt_entry_p := mmp$get_sdt_entry_p (xcb_p, segment_number);
    IF sdt_entry_p^.ste.vl = osc$vl_invalid_entry THEN
      osp$set_status_abnormal ('MM', mme$segment_number_not_in_use, '', status);
      RETURN;
    IFEND;

{  Delete the Segment table entry.

    pva := #ADDRESS (1, segment_number, 0);
    #PURGE_BUFFER (osc$pva_purge_all_page_seg_map, pva);
    sdt_entry_p^.ste.vl := osc$vl_invalid_entry;

  PROCEND mmp$close_asid_based_segment;
?? TITLE := '  MMP$CLOSE_DEVICE_FILE', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$close_device_file
    (    segment_number: ost$segment;
     VAR status: ost$status);

    VAR
      fde_entry_p: gft$locked_file_desc_entry_p,
      pva: ^cell,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended;

    status.normal := TRUE;

    mmp$fetch_sdt_sdtx_locked_fde (segment_number, sdt_entry_p, sdtx_entry_p, fde_entry_p, status);

{  Delete the Segment table entry.

    pva := #ADDRESS (1, segment_number, 0);
    #PURGE_BUFFER (osc$pva_purge_all_page_seg_map, pva);
    sdt_entry_p^.ste.vl := osc$vl_invalid_entry;
    fde_entry_p^.open_count := fde_entry_p^.open_count - 1;
    gfp$unlock_fde_p (fde_entry_p);

  PROCEND mmp$close_device_file;
?? TITLE := '  MMP$CREATE_INHERITED_SDT', EJECT ??
*copy mmh$create_inherited_sdt

  PROCEDURE [XDCL, #GATE] mmp$create_inherited_sdt
    (    task_id: pmt$task_id;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      child_sdt_entry_p: ^mmt$segment_descriptor,
      child_sdtx_entry_p: ^mmt$segment_descriptor_extended,
      child_xcb_p {new task xcb pointer} : ^ost$execution_control_block,
      fde_entry_p: gft$locked_file_desc_entry_p,
      local_sdtp: ^mmt$segment_descriptor_table,
      local_sdtxp: ^mmt$segment_descriptor_table_ex,
      local_status: ost$status,
      new_sdt_length: integer,
      new_table_size: ost$segment_length,
      parent_sdt_p: mmt$max_sdt_p,
      parent_sdtx_p: mmt$max_sdtx_p,
      parent_xcb_p {current task xcb pointer} : ^ost$execution_control_block,
      pva: ^cell,
      rma: integer,
      sdt_entry: mmt$segment_descriptor,
      sdtx_entry: mmt$segment_descriptor_extended,
      segnum: ost$segment,
      sfid: gft$system_file_identifier,
      software_attribute_set: mmt$software_attribute_set,
      stl {segment table length} : ost$segment;

    status.normal := TRUE;

    pmp$find_task_xcb (task_id, child_xcb_p);
    IF child_xcb_p = NIL THEN
      osp$set_status_abnormal ('MM', mme$invalid_task_id, '', status);
      RETURN;
    IFEND;

    pmp$find_executing_task_xcb (parent_xcb_p);

    stl := parent_xcb_p^.xp.segment_table_length;
    mmp$get_max_sdt_sdtx_pointer (parent_xcb_p, parent_sdt_p, parent_sdtx_p);
    WHILE ((parent_sdtx_p^.sdtx_table [stl].inheritance = mmc$si_none) OR
        (parent_sdt_p^.st [stl].ste.vl = osc$vl_invalid_entry)) AND
        (parent_sdtx_p^.sdtx_table [stl].segment_reservation_state <> mmc$srs_reserved_shared_stack) AND
        (stl > mmc$default_sdt_length) DO
      stl := stl - 1;
    WHILEND;

    ALLOCATE local_sdtp: [0 .. stl] IN osv$job_fixed_heap^;

    IF ((stl + 1) * 8) > osv$page_size THEN
      new_sdt_length := ((((stl + 1) * 8) + osv$page_size) DIV osv$page_size);
      new_table_size := new_sdt_length * osv$page_size;
    IFEND;

{  Allocate and initialize the SDT.
    IF ((stl + 1) * 8) > osv$page_size THEN
      mmp$free_pages (local_sdtp, new_table_size, osc$nowait, status);
      mmp$assign_contiguous_memory (local_sdtp, new_table_size, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      pmp$zero_out_table (#LOC (local_sdtp^), #SIZE (local_sdtp^));
    IFEND;


{  Allocate and zero out the SDTX.

    ALLOCATE local_sdtxp: [0 .. stl] IN osv$job_fixed_heap^;
    pmp$zero_out_table (#LOC (local_sdtxp^), #SIZE (local_sdtxp^));
    i#real_memory_address (local_sdtp, rma);
    child_xcb_p^.xp.segment_table_address_1 := rma DIV 10000(16);
    child_xcb_p^.xp.segment_table_address_2 := rma MOD 10000(16);
    child_xcb_p^.xp.segment_table_length := stl;
    child_xcb_p^.sdt_offset := #OFFSET (local_sdtp);
    child_xcb_p^.sdtx_offset := #OFFSET (local_sdtxp);

{  Create the SDT and SDTX in the new task.

  /create_sdt_and_sdtx/
    FOR segnum := 0 TO stl DO
      IF (parent_sdt_p^.st [segnum].ste.vl <> osc$vl_invalid_entry) AND
            ((parent_sdtx_p^.sdtx_table [segnum].inheritance <> mmc$si_none) OR
            (parent_sdtx_p^.sdtx_table [segnum].segment_reservation_state =
           mmc$srs_reserved_shared_stack)) THEN
        sdt_entry := parent_sdt_p^.st [segnum];
        sdt_entry.ste.asid := 0;
        sdt_entry.asti := 0;
        sdtx_entry := parent_sdtx_p^.sdtx_table [segnum];
        IF (sdtx_entry.shadow_info.shadow_segment_kind <> mmc$ssk_none) AND
              (sdtx_entry.shadow_info.shadow_segment_kind <> mmc$ssk_segment_number) THEN
          sdtx_entry.shadow_info.shadow_segment_kind := mmc$ssk_none;
          sdtx_entry.shadow_info.passive_for_shadow_by_segnum := FALSE;
          sdtx_entry.sfid := sdtx_entry.shadow_info.shadow_sfid;
        IFEND;

        sdtx_entry.assign_active := mmc$assign_active_null;

{ New FDE entries must be created for the task template segments.

        IF sdtx_entry.inheritance = mmc$si_new_segment THEN
          gfp$assign_fde (gfc$tr_job, 0 {segment_number} , sfid, fde_entry_p);
          IF fde_entry_p <> NIL THEN
            sfid.file_hash := segnum;
            fde_entry_p^.open_count := 1;
            fde_entry_p^.attach_count := 1;
            fde_entry_p^.file_kind := gfc$fk_unnamed_file;
            fde_entry_p^.file_hash := segnum;
            fde_entry_p^.last_segment_number := segnum;
            IF mmc$sa_stack IN sdtx_entry.software_attribute_set THEN
              fde_entry_p^.stack_for_ring := sdt_entry.ste.r1;
            IFEND;
            IF sdtx_entry.shadow_info.shadow_segment_kind = mmc$ssk_segment_number THEN
              fde_entry_p^.flags.active_shadow_file := TRUE;
            IFEND;
            sdtx_entry.sfid := sfid;
          ELSE
            osp$set_status_abnormal ('MM', mme$unable_to_assign_fde, '', status);
            RETURN;
          IFEND;
        ELSEIF parent_sdtx_p^.sdtx_table [segnum].inheritance = mmc$si_transfer_segment THEN
          sdtx_entry.inheritance := mmc$si_none;
          pva := #ADDRESS (1, segnum, 0);
          #PURGE_BUFFER (osc$pva_purge_all_page_seg_map, pva);
          parent_sdt_p^.st [segnum].ste.vl := osc$vl_invalid_entry;
        ELSEIF sdtx_entry.open_validating_ring_number > 1 THEN
          gfp$get_locked_fde_p (sdtx_entry.sfid, fde_entry_p);
          fde_entry_p^.open_count := fde_entry_p^.open_count + 1;
          gfp$unlock_fde_p (fde_entry_p);
          sdtx_entry.software_attribute_set := sdtx_entry.software_attribute_set -
                $mmt$software_attribute_set [mmc$sa_stack];
        IFEND;
        child_sdt_entry_p := mmp$get_sdt_entry_p (child_xcb_p, segnum);
        child_sdtx_entry_p := mmp$get_sdtx_entry_p (child_xcb_p, segnum);
        child_sdt_entry_p^ := sdt_entry;
        child_sdtx_entry_p^ := sdtx_entry;

      ELSEIF (parent_sdtx_p^.sdtx_table [segnum].segment_reservation_state =
            mmc$srs_reserved_shared_stack) AND
            (parent_sdt_p^.st [segnum].ste.vl = osc$vl_invalid_entry) THEN
        sdtx_entry := parent_sdtx_p^.sdtx_table [segnum];
        sdtx_entry.segment_reservation_state := mmc$srs_reserved_shared_stack;
        child_sdtx_entry_p := mmp$get_sdtx_entry_p (child_xcb_p, segnum);
        child_sdtx_entry_p^ := sdtx_entry;
      IFEND;
    FOREND /create_sdt_and_sdtx/;

  PROCEND mmp$create_inherited_sdt;
?? TITLE := '  MMP$DELETE_INHERITED_SDT', EJECT ??
{
{   The purpose of this request is to clean up any segments and decrement any
{ fde.open_counts that mmp$create_inherited_sdt modified.  This is called ONLY
{ for cases where mmp$create_inherited_sdt completed successfully but for
{ some other reason (i.e. create_ada_enviroment failed) the task is not fully
{ initiated and therefore will not go thru normal task termination to clean
{ things up.
{
{        MMP$DELETE_INHERITED_SDT (TASK_ID, STATUS)
{
{ TASKID: (input) This parameter specifies the task being cleaned up.
{
{ STATUS: (output) This parameter is where the request status is returned.
{
  PROCEDURE [XDCL, #GATE] mmp$delete_inherited_sdt
    (    task_id: pmt$task_id;
     VAR status: ost$status);

    VAR
      fde_entry_p: gft$file_desc_entry_p,
      local_sdt_p: ^cell,
      local_sdtx_p: ^cell,
      open_count: integer,
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      sfid: gft$system_file_identifier,
      segnum: ost$segment,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$find_task_xcb (task_id, xcb_p);
    IF xcb_p = NIL THEN
      osp$set_status_abnormal ('MM', mme$invalid_task_id, '', status);
      RETURN;
    IFEND;

    mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);

  /scan_sdt_for_inherited_segs/
    FOR segnum := 0 TO xcb_p^.xp.segment_table_length DO
      IF (sdt_p^.st [segnum].ste.vl <> osc$vl_invalid_entry) THEN
        IF (sdtx_p^.sdtx_table [segnum].inheritance = mmc$si_new_segment) THEN
          sfid := sdtx_p^.sdtx_table [segnum].sfid;
          gfp$get_fde_p (sfid, fde_entry_p);
          IF fde_entry_p^.open_count <> 1 THEN
            osp$system_error (' FDE.OPEN_COUNT incorrect', NIL);
          IFEND;
          fde_entry_p^.open_count := fde_entry_p^.open_count - 1;
          gfp$free_fde (fde_entry_p, sfid);
        ELSEIF (sdtx_p^.sdtx_table [segnum].open_validating_ring_number > 1) THEN
          gfp$get_locked_fde_p (sdtx_p^.sdtx_table [segnum].sfid, fde_entry_p);
          open_count := fde_entry_p^.open_count - 1;
          fde_entry_p^.open_count := open_count;
          gfp$unlock_fde_p (fde_entry_p);
          IF open_count < 0 THEN
            osp$system_error ( 'FDE.OPEN_COUNT incorrect', NIL);
          IFEND;
          IF (open_count = 0) AND ((fde_entry_p^.file_kind = gfc$fk_unnamed_file) OR
                (fde_entry_p^.file_kind = gfc$fk_global_unnamed)) THEN
            destroy_segment (sdtx_p^.sdtx_table [segnum].sfid, fde_entry_p,
                  sdtx_p^.sdtx_table [segnum].file_limits_enforced, status);
          IFEND;
        IFEND;
      IFEND;
    FOREND /scan_sdt_for_inherited_segs/;

{  Release the SDT and SDTX table space.

    local_sdt_p := #ADDRESS (1, osc$segnum_job_fixed_heap, xcb_p^.sdt_offset);
    local_sdtx_p := #ADDRESS (1, osc$segnum_job_fixed_heap, xcb_p^.sdtx_offset);
    IF #SIZE (local_sdt_p^) > osv$page_size THEN
      mmp$free_pages (#ADDRESS (1, #SEGMENT (local_sdt_p), #OFFSET (local_sdt_p)), #SIZE (local_sdt_p^),
            osc$wait, status);
    IFEND;
    FREE local_sdtx_p IN osv$job_fixed_heap^;
    FREE local_sdt_p IN osv$job_fixed_heap^;

  PROCEND mmp$delete_inherited_sdt;
?? TITLE := '  MMP$DELETE_NON_INHERITED_SEGS', EJECT ??
*copy mmh$delete_non_inherited_segs

  PROCEDURE [XDCL, #GATE] mmp$delete_non_inherited_segs
    (VAR status: ost$status);

    VAR
      pointer: mmt$segment_pointer,
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      segnum: ost$segment,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_xcb (xcb_p);

{  Close all user segments.

    mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);
    FOR segnum := 0 TO xcb_p^.xp.segment_table_length DO
      IF ((sdt_p^.st [segnum].ste.vl <> osc$vl_invalid_entry) AND
            (sdtx_p^.sdtx_table [segnum].open_validating_ring_number > 1)) THEN
        mmp$invalidate_segment (segnum, 1, NIL {shared_taskid_array} , status);
      IFEND;
    FOREND;

  PROCEND mmp$delete_non_inherited_segs;
?? TITLE := '  MMP$FETCH_OFFSET_MOD_PAGES_R1', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$fetch_offset_mod_pages_r1
    (    segment_number: ost$segment;
         xsfid: gft$system_file_identifier;
         return_unallocated_offsets: boolean;
     VAR offset_list: ^array [ * ] of ost$segment_offset;
     VAR offsets_returned: integer;
     VAR status: ost$status);

    TYPE
      offset_array = array [1 .. * ] of ost$segment_offset;

    VAR
      i: integer,
      offset_array_index: integer,
      offset_count: integer,
      offset_p: ^offset_array,
      request_block: mmt$rb_fetch_offset_mod_pages,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      sfid: gft$system_file_identifier;

    status.normal := TRUE;

{  Allocate array to hold all the offsets for the modified pages.

    ALLOCATE offset_p: [1 .. UPPERBOUND (offset_list^)] IN osv$job_fixed_heap^;

{  Touch all of the pages allocated so that referencing them in
{  monitor will not cause a page fault.

    mmp$touch_all_pages (offset_p, #SIZE (offset_p^));

{  Issue monitor function to return offsets for modified pages.

{ If the segment number is non-zero, then the sfid passed into the request
{ is invalid. The correct sfid must be set from the segment's SDTX entry.

    IF segment_number <> 0 THEN
      mmp$validate_segment_number (segment_number, sdt_entry_p, sdtx_entry_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      sfid := sdtx_entry_p^.sfid;
    ELSE
      sfid := xsfid;
    IFEND;

    request_block.reqcode := syc$rc_fetch_offset_mod_pages;
    request_block.sfid := sfid;
    request_block.offsets_returned := UPPERBOUND (offset_list^);
    request_block.offset_list := offset_p;
    request_block.return_unallocated_offsets := return_unallocated_offsets;

    i#call_monitor (#LOC (request_block), #SIZE (request_block));
    syp$set_status_from_mtr_status (request_block.status, status);
    IF NOT status.normal THEN
      FREE offset_p IN osv$job_fixed_heap^;
      RETURN;
    IFEND;

{  If array not large enough to hold all offsets, create list_overflow condition.

    IF (request_block.offsets_returned > UPPERBOUND (offset_list^)) OR
          (request_block.offsets_returned = 0) THEN
      FREE offset_p IN osv$job_fixed_heap^;
      offsets_returned := request_block.offsets_returned;
      RETURN;
    IFEND;

{  Move offsets to caller's offset list.

    FOR i := 1 TO request_block.offsets_returned DO
      offset_list^ [i] := offset_p^ [i];
    FOREND;

    offsets_returned := request_block.offsets_returned;
    FREE offset_p IN osv$job_fixed_heap^;

  PROCEND mmp$fetch_offset_mod_pages_r1;

?? TITLE := '  MMP$FETCH_SDT_SDTX_LOCKED_FDE', EJECT ??

  PROCEDURE [XDCL] mmp$fetch_sdt_sdtx_locked_fde
    (    segment_number: ost$segment;
     VAR sdt_entry_p: ^mmt$segment_descriptor;
     VAR sdtx_entry_p: ^mmt$segment_descriptor_extended;
     VAR locked_fde_p: gft$locked_file_desc_entry_p;
     VAR status: ost$status);

    VAR
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_xcb (xcb_p);

    IF segment_number > xcb_p^.xp.segment_table_length THEN
      IF segment_number > 4095 THEN
        osp$set_status_abnormal ('MM', mme$segment_number_too_big, '', status);
      ELSE
        osp$set_status_abnormal ('MM', mme$segment_number_not_in_use, '', status);
      IFEND;
      RETURN;
    IFEND;

    sdt_entry_p := mmp$get_sdt_entry_p (xcb_p, segment_number);
    sdtx_entry_p := mmp$get_sdtx_entry_p (xcb_p, segment_number);
    IF sdt_entry_p^.ste.vl = osc$vl_invalid_entry THEN
      osp$set_status_abnormal ('MM', mme$segment_number_not_in_use, '', status);
    ELSE
      gfp$get_locked_fde_p (sdtx_entry_p^.sfid, locked_fde_p);
    IFEND;

  PROCEND mmp$fetch_sdt_sdtx_locked_fde;

?? TITLE := '  MMP$FETCH_SEGMENT_ATTRIBUTES_R1', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$fetch_segment_attributes_r1
    (    segment_number: ost$segment;
         validating_ring: ost$valid_ring;
     VAR seg_attributes: ^array [ * ] of mmt$attribute_descriptor;
     VAR status: ost$status);

    VAR
      fde_entry_p: gft$locked_file_desc_entry_p,
      i: integer,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended;

    status.normal := TRUE;
    mmp$fetch_sdt_sdtx_locked_fde (segment_number, sdt_entry_p, sdtx_entry_p, fde_entry_p, status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := LOWERBOUND (seg_attributes^) TO UPPERBOUND (seg_attributes^) DO
      CASE seg_attributes^ [i].keyword OF
      = mmc$kw_ring_numbers =
        seg_attributes^ [i].r1 := sdt_entry_p^.ste.r1;
        seg_attributes^ [i].r2 := sdt_entry_p^.ste.r2;
      = mmc$kw_segment_number =
        seg_attributes^ [i].segnum := segment_number;
      = mmc$kw_current_segment_length =
        seg_attributes^ [i].current_length := gfp$get_eoi_from_fde (fde_entry_p);
      = mmc$kw_max_segment_length =
        IF fde_entry_p^.file_limit < UPPERVALUE (seg_attributes^ [i].max_length) THEN
          seg_attributes^ [i].max_length := fde_entry_p^.file_limit;
        ELSE
          seg_attributes^ [i].max_length := UPPERVALUE (seg_attributes^ [i].max_length);
        IFEND;
      = mmc$kw_gl_key =
        seg_attributes^ [i].gl_key := sdt_entry_p^.ste.key_lock;
      = mmc$kw_hardware_attributes =
        seg_attributes^ [i].hardware_attri_set := $mmt$hardware_attribute_set [];
        CASE sdt_entry_p^.ste.rp OF
        = osc$read_uncontrolled =
          seg_attributes^ [i].hardware_attri_set := seg_attributes^ [i].hardware_attri_set +
                $mmt$hardware_attribute_set [mmc$ha_read];
        = osc$read_key_lock_controlled =
          seg_attributes^ [i].hardware_attri_set := seg_attributes^ [i].hardware_attri_set +
                $mmt$hardware_attribute_set [mmc$ha_read_key_lock];
        = osc$binding_segment =
          seg_attributes^ [i].hardware_attri_set := seg_attributes^ [i].hardware_attri_set +
                $mmt$hardware_attribute_set [mmc$ha_binding]
        ELSE
        CASEND;
        CASE sdt_entry_p^.ste.wp OF
        = osc$write_uncontrolled =
          seg_attributes^ [i].hardware_attri_set := seg_attributes^ [i].hardware_attri_set +
                $mmt$hardware_attribute_set [mmc$ha_write];
        = osc$write_key_lock_controlled =
          seg_attributes^ [i].hardware_attri_set := seg_attributes^ [i].hardware_attri_set +
                $mmt$hardware_attribute_set [mmc$ha_write_key_lock];
        ELSE
        CASEND;
        CASE sdt_entry_p^.ste.xp OF
        = osc$non_privileged =
          seg_attributes^ [i].hardware_attri_set := seg_attributes^ [i].hardware_attri_set +
                $mmt$hardware_attribute_set [mmc$ha_execute];
        = osc$local_privilege =
          seg_attributes^ [i].hardware_attri_set := seg_attributes^ [i].hardware_attri_set +
                $mmt$hardware_attribute_set [mmc$ha_execute_local];
        = osc$global_privilege =
          seg_attributes^ [i].hardware_attri_set := seg_attributes^ [i].hardware_attri_set +
                $mmt$hardware_attribute_set [mmc$ha_execute_global];
        ELSE
        CASEND;
        CASE sdt_entry_p^.ste.vl OF
        = osc$vl_cache_bypass =
          seg_attributes^ [i].hardware_attri_set := seg_attributes^ [i].hardware_attri_set +
                $mmt$hardware_attribute_set [mmc$ha_cache_bypass];
        ELSE
        CASEND;
      = mmc$kw_software_attributes =
        seg_attributes^ [i].software_attri_set := sdtx_entry_p^.software_attribute_set;
      = mmc$kw_error_exit_procedure =
        seg_attributes^ [i].err_exit_proc := NIL;
      = mmc$kw_preset_value =
        seg_attributes^ [i].preset_value := fde_entry_p^.preset_value;
      = mmc$kw_inheritance =
        seg_attributes^ [i].inheritance := sdtx_entry_p^.inheritance;
      = mmc$kw_clear_space =
        seg_attributes^ [i].clear_space := FALSE;
      = mmc$kw_segment_access_control =
        IF sdt_entry_p^.ste.vl = osc$vl_cache_bypass THEN
          seg_attributes^ [i].access_control.cache_bypass := TRUE;
        ELSE
          seg_attributes^ [i].access_control.cache_bypass := FALSE;
        IFEND;
        seg_attributes^ [i].access_control.execute_privilege := sdt_entry_p^.ste.xp;
        seg_attributes^ [i].access_control.read_privilege := sdt_entry_p^.ste.rp;
        seg_attributes^ [i].access_control.write_privilege := sdt_entry_p^.ste.wp;
      ELSE
        osp$set_status_abnormal ('MM', mme$unsupported_keyword, '', status);
      CASEND;
    FOREND;

    gfp$unlock_fde_p (fde_entry_p);

  PROCEND mmp$fetch_segment_attributes_r1;

?? TITLE := '  MMP$GET_ALLOCATED_ADDRESSES_R1', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$get_allocated_addresses_r1
    (    segment_number: ost$segment;
         validating_ring: ost$valid_ring;
         starting_byte_address: ost$segment_offset;
     VAR addr_list: ^array [ * ] of dmt$addr_length_pair;
     VAR addr_returned: integer;
     VAR list_overflow: boolean;
     VAR status: ost$status);

    VAR
      allocated_length: amt$file_byte_address,
      dfd_p: ^dmt$disk_file_descriptor,
      fde_entry_p: gft$locked_file_desc_entry_p,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended;

    mmp$validate_segment_number (segment_number, sdt_entry_p, sdtx_entry_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (sdt_entry_p^.ste.rp = osc$non_readable) OR (validating_ring > sdt_entry_p^.ste.r2) THEN
      osp$set_status_abnormal ('MM', mme$ring_violation, '', status);
      RETURN;
    IFEND;

    IF starting_byte_address = 0 THEN
      gfp$get_locked_fde_p (sdtx_entry_p^.sfid, fde_entry_p);
      dmp$get_disk_file_descriptor_p (fde_entry_p, dfd_p);
      dmp$get_total_allocated_length (fde_entry_p, allocated_length);
      gfp$unlock_fde_p (fde_entry_p);
      IF allocated_length = dfd_p^.highest_offset_allocated THEN
        {Return 1 address pair if not sparsely allocated
        addr_returned := 1;
        list_overflow := FALSE;
        addr_list^ [LOWERBOUND (addr_list^)].addr := 0;
        addr_list^ [LOWERBOUND (addr_list^)].length := fde_entry_p^.eoi_byte_address;
        RETURN;
      IFEND;
    IFEND;

    dmp$get_initialized_addresses (sdtx_entry_p^.sfid, starting_byte_address, addr_list^, addr_returned,
          list_overflow, status);

  PROCEND mmp$get_allocated_addresses_r1;

?? TITLE := '  MMP$GET_SDT_FOR_JOB_TEMPLATE', EJECT ??

  PROCEDURE [XDCL] mmp$get_sdt_for_job_template
    (    pva: ^cell;
     VAR sdt_entry: mmt$segment_descriptor;
     VAR sdtx_entry: mmt$segment_descriptor_extended;
     VAR status: ost$status);


    VAR
      fde_entry_p: gft$locked_file_desc_entry_p,
      rb: mmt$rb_ring1_segment_request,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segnum: ost$segment;

    segnum := #SEGMENT (pva);
    mmp$fetch_sdt_sdtx_locked_fde (segnum, sdt_entry_p, sdtx_entry_p, fde_entry_p, status);
    IF status.normal = FALSE THEN
      RETURN;
    IFEND;

    fde_entry_p^.flags.global_template_file := TRUE;
    sdtx_entry_p^.inheritance := mmc$si_share_segment;
    sdtx_entry_p^.open_validating_ring_number := 0;
    sdtx_entry_p^.file_limits_enforced := sfc$no_limit;
    sdtx_entry := sdtx_entry_p^;
    sdt_entry := sdt_entry_p^;
    sdt_entry.ste.asid := 0;
    gfp$unlock_fde_p (fde_entry_p);

{ Issue a monitor request to make the global logs shared.

    rb.reqcode := syc$rc_ring1_segment_request;
    rb.request := mmc$sr1_share_global_logs;
    rb.system_file_id := sdtx_entry_p^.sfid;
    rb.segment_number := segnum;
    rb.server_file := FALSE;
    i#call_monitor (#LOC (rb), #SIZE(rb));

  PROCEND mmp$get_sdt_for_job_template;
?? TITLE := '  MMP$GET_SEGMENT_LENGTH_R1', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$get_segment_length_r1
    (    segment_number: ost$segment;
         validating_ring_number: ost$valid_ring;
     VAR segment_length: ost$segment_length;
     VAR status: ost$status);

    VAR
      fde_p: gft$file_desc_entry_p,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended;

    mmp$validate_segment_number (segment_number, sdt_entry_p, sdtx_entry_p, status);
    IF status.normal = FALSE THEN
      RETURN;
    IFEND;

{  Verify that caller is within read bracket of the segment.

    IF validating_ring_number > sdt_entry_p^.ste.r2 THEN
      osp$set_status_abnormal ('MM', mme$caller_not_in_read_bracket, '', status);
      RETURN;
    IFEND;

    gfp$get_fde_p (sdtx_entry_p^.sfid, fde_p);
    segment_length := gfp$get_eoi_from_fde (fde_p);

  PROCEND mmp$get_segment_length_r1;
?? TITLE := '  MMP$INITIATE_SHADOWING_R1', EJECT ??
*copyc mmh$initiate_shadowing_r1

  PROCEDURE [XDCL, #GATE] mmp$initiate_shadowing_r1
    (    segment_pointer: ^cell;
         validating_ring_number: ost$valid_ring;
         shadow_segment_kind: mmt$shadow_segment_kind;
     VAR status: ost$status);

    VAR
      fde_p: gft$locked_file_desc_entry_p,
      new_fde_p: gft$file_desc_entry_p,
      new_sfid: gft$system_file_identifier,
      segment_length: ost$segment_length,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended;


    mmp$fetch_sdt_sdtx_locked_fde (#SEGMENT (segment_pointer), sdt_entry_p, sdtx_entry_p, fde_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


  /fde_locked/
    BEGIN
      IF (sdt_entry_p^.ste.r1 < validating_ring_number) OR
            (sdtx_entry_p^.open_validating_ring_number <= 1) OR
            (sdtx_entry_p^.shadow_info.shadow_segment_kind <> mmc$ssk_none) OR
            (mmc$sa_stack IN sdtx_entry_p^.software_attribute_set) THEN
        osp$set_status_abnormal ('MM', mme$init_shadow_improper_seg, '', status);
        EXIT /fde_locked/;
      IFEND;

      gfp$assign_fde (gfc$tr_job, 0, new_sfid, new_fde_p);
      IF new_fde_p = NIL THEN
        osp$set_status_abnormal ('MM', mme$unable_to_assign_fde, '', status);
        EXIT /fde_locked/;
      IFEND;
      new_fde_p^.allocation_unit_size := mmc$shadow_allocation_size;
      new_fde_p^.open_count := 1;
      new_fde_p^.attach_count := 1;
      new_fde_p^.flags.active_shadow_file := TRUE;

      IF shadow_segment_kind = mmc$ssk_read_only_file THEN
        sdt_entry_p^.ste.wp := osc$write_uncontrolled;
        sdtx_entry_p^.access_rights := mmc$sar_write_extend;
      IFEND;

      mmp$get_segment_length_r1 (#SEGMENT (segment_pointer), 1, segment_length, status);

      sdtx_entry_p^.shadow_info.shadow_segment_kind := shadow_segment_kind;
      sdtx_entry_p^.shadow_info.shadow_sfid := sdtx_entry_p^.sfid;
      sdtx_entry_p^.shadow_info.shadow_start_page_number := 0;
      sdtx_entry_p^.shadow_info.shadow_length_page_count := (((segment_length + 16384 - 1) DIV 16384) *
            16384) DIV osv$page_size;
      new_fde_p^.file_limit := fde_p^.file_limit;
      sdtx_entry_p^.sfid := new_sfid;

      {  Purge buffer space for PASSIVE segment and set ASID to zero.

      sdt_entry_p^.ste.asid := 0;
      #PURGE_BUFFER (osc$pva_purge_all_page_seg_map, segment_pointer);

    END /fde_locked/;

    gfp$unlock_fde_p (fde_p);

  PROCEND mmp$initiate_shadowing_r1;
?? TITLE := '  MMP$INIT_SYSTEM_PRIVILEGE_MAP', EJECT ??
*copyc mmh$init_system_privilege_map

  PROCEDURE [XDCL, #GATE] mmp$init_system_privilege_map
    (    offset: ost$segment_offset);

    VAR
      i: ost$segment,
      leftover: boolean,
      mapend: ost$segment,
      mp_p: ^ost$system_privilege_map,
      sdt_entry_p: ^mmt$segment_descriptor,
      ste: ost$segment_descriptor,
      xcb_p: ^ost$execution_control_block;

{ Calculate where the map is in mainframe pageable.
{ Note - hard-coded [1] must be changed if multiple task private segments exist.

    mp_p := #ADDRESS (1, #SEGMENT (jmv$task_private_templ_p^.segment [1].content),
          #OFFSET (jmv$task_private_templ_p^.segment [1].content) + offset);

{ Find the system job XCB.

    pmp$find_executing_task_xcb (xcb_p);

{ Capture the system privilege segments.
{ Insure no array bounds errors.

    IF xcb_p^.xp.segment_table_length < UPPERBOUND (ost$system_privilege_map) THEN
      leftover := TRUE;
      mapend := xcb_p^.xp.segment_table_length;
    ELSE
      leftover := FALSE;
      mapend := UPPERBOUND (ost$system_privilege_map);
    IFEND;

{ Compute the bits for which both segment table entries and map entries exist.

    FOR i := 0 TO mapend DO
      sdt_entry_p := mmp$get_sdt_entry_p (xcb_p, i);
      ste := sdt_entry_p^.ste;
      mp_p^ [i] := (ste.vl <> osc$vl_invalid_entry) AND (ste.xp <> osc$non_executable);
    FOREND;

{ Clear any leftover bits.

    IF leftover THEN
      FOR i := mapend + 1 TO UPPERBOUND (ost$system_privilege_map) DO
        mp_p^ [i] := FALSE;
      FOREND;
    IFEND;

  PROCEND mmp$init_system_privilege_map;
?? TITLE := '  MMP$ISSUE_RING1_SEGMENT_REQUEST', EJECT ??

  PROCEDURE [XDCL] mmp$issue_ring1_segment_request
    (VAR rb: mmt$rb_ring1_segment_request);

    VAR
      count: integer,
      status: ost$status,
      sfid: gft$system_file_identifier;

{   Mmp$process_wmp_status (mtr) will set init_new_io to FALSE if the call is reissued for the wait option.

    rb.init_new_io := TRUE;
    FOR count := 1 TO 4 DO
      i#call_monitor (#LOC (rb), #SIZE (rb));
      IF NOT rb.status.normal THEN
        IF rb.status.condition = mme$io_write_error THEN
          CASE rb.request OF
          = mmc$sr1_detach_file, mmc$sr1_flush_delete_seg_sfid, mmc$sr1_flush_seg_segnum =
            {Only attempt reallocate for these requests
            sfid := rb.sfid;
          ELSE
            RETURN;
          CASEND;
        ELSE
          RETURN;
        IFEND;
      ELSE
        RETURN;
      IFEND;
      IF count = 4 THEN
        RETURN;
      IFEND;
      dmp$reallocate_file_space (sfid, TRUE, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      rb.init_new_io := TRUE;
    FOREND;

  PROCEND mmp$issue_ring1_segment_request;

?? TITLE := '  MMP$INVALIDATE_SEGMENT', EJECT ??
*copy mmh$invalidate_segment

  PROCEDURE [XDCL, #GATE] mmp$invalidate_segment
    (    segment_number: ost$segment;
         validating_ring_number: ost$valid_ring;
         shared_taskid_array: ^array [1 .. * ] of pmt$task_id;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      fde_entry_p: gft$locked_file_desc_entry_p,
      i: integer,
      open_count: integer, {must be integer}
      pva: ^cell,
      rb: mmt$rb_ring1_segment_request,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      segnum: ost$segment,
      shadow_fde_p: gft$locked_file_desc_entry_p,
      shadow_open_count: gft$open_count,
      shadow_sfid: gft$system_file_identifier,
      task_xcb: ^ost$execution_control_block,
      task_sdt_entry_p: ^mmt$segment_descriptor,
      xcb_p: ^ost$execution_control_block;

    IF shared_taskid_array <> NIL THEN
      FOR i := LOWERBOUND (shared_taskid_array^) TO UPPERBOUND (shared_taskid_array^) DO
        pmp$find_task_xcb (shared_taskid_array^ [i], task_xcb);
        IF task_xcb = NIL THEN
          osp$set_status_abnormal ('MM', mme$invalid_shared_taskid, '', status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    #CALLER_ID (caller_id);
    mmp$fetch_sdt_sdtx_locked_fde (segment_number, sdt_entry_p, sdtx_entry_p, fde_entry_p, status);
    IF status.normal = FALSE THEN
      RETURN;
    IFEND;

    pva := #ADDRESS (caller_id.ring, segment_number, 0);

{***KLUDGE- the first conditional is necessary to delete task private in
{           job termination.
    IF (caller_id.ring > 2) AND
          (validating_ring_number > sdtx_entry_p^.open_validating_ring_number) THEN
      gfp$unlock_fde_p (fde_entry_p);
      osp$set_status_abnormal ('MM', mme$invalid_close_segment_req, '', status);
      RETURN;
    IFEND; {***KLUDGE***}

{  Clear any segment locks left by the user.

    IF sdtx_entry_p^.segment_lock >= mmc$lss_lock_for_read_user THEN
      mmp$unlock_segment (pva, mmc$lus_free, osc$nowait, status);
      IF NOT status.normal THEN
        gfp$unlock_fde_p (fde_entry_p);
        osp$system_error ('Unexpected mmp$unlock_segment error', ^status);
      IFEND;
    IFEND;

    pmp$find_executing_task_xcb (xcb_p);
    IF shared_taskid_array <> NIL THEN
      FOR i := LOWERBOUND (shared_taskid_array^) TO UPPERBOUND (shared_taskid_array^) DO
        pmp$find_task_xcb (shared_taskid_array^ [i], task_xcb);
        IF xcb_p <> task_xcb THEN
          task_sdt_entry_p := mmp$get_sdt_entry_p (task_xcb, segment_number);
          task_sdt_entry_p^.ste.vl := osc$vl_invalid_entry;
          fde_entry_p^.open_count := fde_entry_p^.open_count - 1;
        IFEND;
      FOREND;
    IFEND;

    open_count := 1;
    IF sdtx_entry_p^.shadow_info.shadow_segment_kind <> mmc$ssk_none THEN
      gfp$get_locked_fde_p (sdtx_entry_p^.shadow_info.shadow_sfid, shadow_fde_p);
      shadow_fde_p^.open_count := shadow_fde_p^.open_count - 1;
      shadow_open_count := shadow_fde_p^.open_count;
      gfp$unlock_fde_p (shadow_fde_p);
      IF (shadow_open_count = 0) AND
          ((shadow_fde_p^.file_kind = gfc$fk_unnamed_file) OR
           (shadow_fde_p^.file_kind = gfc$fk_global_unnamed)) THEN
        destroy_segment (sdtx_entry_p^.shadow_info.shadow_sfid, shadow_fde_p,
              sfc$temp_file_space_limit, status);  {Can only destroy temp files}
      IFEND;
    ELSEIF sdtx_entry_p^.shadow_info.passive_for_shadow_by_segnum THEN
      mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);
      FOR segnum := 0 TO xcb_p^.xp.segment_table_length DO
        IF (sdt_p^.st [segnum].ste.vl <> osc$vl_invalid_entry) AND
              (sdtx_p^.sdtx_table [segnum].shadow_info.shadow_segment_number = segment_number) AND
              (sdtx_p^.sdtx_table [segnum].shadow_info.shadow_segment_kind = mmc$ssk_segment_number) THEN
          sdtx_p^.sdtx_table [segnum].shadow_info.shadow_segment_kind := mmc$ssk_none;
          sdtx_p^.sdtx_table [segnum].shadow_info.passive_for_shadow_by_segnum := FALSE;
          open_count := open_count + 1;
        IFEND;
      FOREND;
    IFEND;

    open_count  := fde_entry_p^.open_count - open_count;
    fde_entry_p^.open_count := open_count;
    gfp$unlock_fde_p (fde_entry_p);
    IF open_count < 0 THEN
      osp$system_error ('MM - neg open count in invalidate', NIL);
    IFEND;

{ The asid must be zeroed out before calling destroy_segment.  Destroy_segment will free
{ the ast entry and the file descriptor entry for local files.  The segment must not be valid
{ with a non-zero asid after file tables are freed, or swapin (reset_sdt_xcb_tables) will
{ process a segment for which file tables no longer exist.

    sdt_entry_p^.ste.asid := 0;
    #PURGE_BUFFER (osc$pva_purge_all_page_seg_map, pva);
    sdt_entry_p^.ste.vl := osc$vl_invalid_entry;

    IF (open_count = 0) THEN
      IF ((fde_entry_p^.file_kind = gfc$fk_unnamed_file) OR
             (fde_entry_p^.file_kind = gfc$fk_global_unnamed)) THEN
        destroy_segment (sdtx_entry_p^.sfid, fde_entry_p, sdtx_entry_p^.file_limits_enforced, status);
      ELSEIF (fde_entry_p^.attach_count = 0) THEN
        IF (fde_entry_p^.media = gfc$fm_served_file) THEN
          dmp$free_server_file_tables (sdtx_entry_p^.sfid, status);
        ELSEIF (fde_entry_p^.file_kind <= gfc$fk_last_permanent_file) THEN
          dmp$mm_log_sft_delete (sdtx_entry_p^.sfid, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND mmp$invalidate_segment;
?? TITLE := '  MMP$JOB_DELETE_INHERITED_SDT', EJECT ??
*copy mmh$job_delete_inherited_sdt

  PROCEDURE [XDCL, #GATE] mmp$job_delete_inherited_sdt;

    VAR
      fde_entry_p: gft$locked_file_desc_entry_p,
      rb: mmt$rb_ring1_segment_request,
      ring_1_stack_segnum: ost$segment,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segnum: ost$segment,
      status: ost$status,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;

    pmp$find_executing_task_xcb (xcb_p);
    ring_1_stack_segnum := xcb_p^.xp.tos_registers [1].pva.seg;

  /scan_sdt_for_inherited_segs/
    FOR segnum := 0 TO xcb_p^.xp.segment_table_length DO
      sdt_entry_p := mmp$get_sdt_entry_p (xcb_p, segnum);
      IF (sdt_entry_p^.ste.vl <> osc$vl_invalid_entry) THEN
        sdtx_entry_p := mmp$get_sdtx_entry_p (xcb_p, segnum);
        IF (sdtx_entry_p^.open_validating_ring_number > 0) AND (segnum <> osc$segnum_job_fixed_heap) AND
              (segnum <> ring_1_stack_segnum) THEN
          gfp$get_fde_p (sdtx_entry_p^.sfid, fde_entry_p);

{  Close segment (free memory and ASID and return backing store if it exists), have to call device
{  manager to return backing store during job termination.

          IF (fde_entry_p^.media = gfc$fm_transient_segment) THEN
            IF fde_entry_p^.asti <> 0 THEN
              rb.reqcode := syc$rc_ring1_segment_request;
              rb.request := mmc$sr1_delete_seg_segnum;
              rb.segnum := segnum;
              i#call_monitor (#LOC (rb), #SIZE (rb));
            IFEND;
          ELSE
            IF (fde_entry_p^.open_count = 1) AND (fde_entry_p^.file_kind > gfc$fk_last_permanent_file) THEN
              fde_entry_p^.open_count := 0;
              dmp$destroy_file (sdtx_entry_p^.sfid, sdtx_entry_p^.file_limits_enforced, status);
              sdt_entry_p^.ste.vl := osc$vl_invalid_entry; {Must be after call to destroy for job recovery}
            ELSE
              mmp$invalidate_segment (segnum, 1, NIL {shared_taskid_array}, status);
            IFEND;
          IFEND;

        IFEND;
      IFEND;
    FOREND /scan_sdt_for_inherited_segs/;

    syp$return_jobs_r1_resources;

  PROCEND mmp$job_delete_inherited_sdt;
?? TITLE := '  MMP$JOB_MULTIPROCESSING_CONTROL', EJECT ??

  PROCEDURE [XDCL] mmp$job_multiprocessing_control
    (    enable: boolean;
     VAR status: ost$status);

    VAR
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      segnum: ost$segment,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_xcb (xcb_p);

    mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);
    FOR segnum := 0 TO xcb_p^.xp.segment_table_length DO
      IF (sdt_p^.st [segnum].ste.vl <> osc$vl_invalid_entry) AND (segnum <> osc$segnum_job_fixed_heap) THEN
        IF (sdtx_p^.sdtx_table [segnum].inheritance = mmc$si_share_segment) AND
              (sdtx_p^.sdtx_table [segnum].open_validating_ring_number <> 0) THEN
          IF enable THEN
            sdt_p^.st [segnum].ste.vl := osc$vl_cache_bypass;
          ELSE
            sdt_p^.st [segnum].ste.vl := osc$vl_regular_segment;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND mmp$job_multiprocessing_control;

?? TITLE := '  MMP$MFH_FOR_SEGMENT_MANAGER', EJECT ??
*copy mmh$mfh_for_segment_manager

  PROCEDURE [XDCL, #GATE] mmp$mfh_for_segment_manager;

    VAR
      allocated_length: amt$file_byte_address,
      ctime: 0 .. 0ffffffffffff(16),
      gtid: ost$global_task_id,
      status: ost$status,
      xcb_p: ^ost$execution_control_block;

{ Allow escaped allocation if the task has system tables locked.

    pmp$find_executing_task_xcb (xcb_p);
    IF xcb_p^.system_table_lock_count > 255 THEN
      xcb_p^.stlc_allocation := TRUE;
      RETURN;
    IFEND;

    mmp$process_file_alloc (allocated_length, status);
    IF NOT status.normal THEN
      IF (status.condition <> dfe$family_not_served) AND (status.condition <> dfe$server_not_active) AND
            (status.condition <> dfe$server_has_terminated) THEN
        ctime := #FREE_RUNNING_CLOCK (0);
        REPEAT
          pmp$delay (1000, status);
          mmp$process_file_alloc (allocated_length, status);
        UNTIL (status.normal) OR ((#FREE_RUNNING_CLOCK (0) - ctime) > 10000000);
        IF NOT status.normal THEN
          pmp$get_executing_task_gtid (gtid);
          pmp$set_system_flag (mmc$failed_file_alloc_flag, gtid, status);
          IF NOT status.normal THEN
            osp$system_error ('Error setting system flag-MMSMSC', NIL);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND mmp$mfh_for_segment_manager;
?? TITLE := '  MMP$MFH_SHADOW_FILE_REFERENCE', EJECT ??

  PROCEDURE [XDCL] mmp$mfh_shadow_file_reference;

{ The purpose of this procedure is to move data from the shadowed file to the active
{ file.  A page fault had occurred and the page was found to reside on the shadowed
{ file.  Mmp$page_pull filled in the necessary information in the XCB and set the
{ monitor flag, mmc$mf_shadow_file_reference.  The ring 1 trap handler called this
{ procedure.

    VAR
      i: integer,
      in_memory: boolean,
      rma: integer,
      status: ost$status,
      traps: 0 .. 3,
      xcb_p: ^ost$execution_control_block;

  PROCEDURE condition_handler
    (    monitor_fault: ost$monitor_fault;
         save_area: ^ost$minimum_save_area;
     VAR continue: syt$continue_option);

    VAR
      handler_status: ost$status,
      system_core_condition_p: ^syt$system_core_condition;

    IF monitor_fault.identifier = syc$system_core_condition THEN
      system_core_condition_p := #LOC (monitor_fault.system_core_condition);
      IF system_core_condition_p^.condition = syc$user_defined_condition THEN
        IF system_core_condition_p^.user_defined_condition = syc$udc_volume_unavailable THEN
          pmp$set_system_flag (mmc$volume_unavailable_flag, xcb_p^.global_task_id, handler_status);
          IF NOT handler_status.normal THEN
            osp$system_error ('Error setting system flag--mfh shadow', NIL);
          IFEND;
          mmp$free_pages (xcb_p^.shadow_reference_info.destination_pva,
                xcb_p^.shadow_reference_info.page_count * osv$page_size, osc$wait, handler_status);
          i#restore_traps (traps);
          EXIT mmp$mfh_shadow_file_reference;
        IFEND;
      IFEND;

{ Other conditions could possibly be handled, if necessary.

    IFEND;

  PROCEND condition_handler;

    pmp$find_executing_task_xcb (xcb_p);
    in_memory := TRUE;

  /memory_check/
    FOR i := 0 TO xcb_p^.shadow_reference_info.page_count - 1 DO
      i#real_memory_address (#ADDRESS (1, #SEGMENT (xcb_p^.shadow_reference_info.source_pva),
            #OFFSET (xcb_p^.shadow_reference_info.source_pva) + i * osv$page_size), rma);
      IF rma < 0 THEN
        in_memory := FALSE;
        EXIT /memory_check/;
      IFEND;
    FOREND /memory_check/;

    IF NOT in_memory THEN
      mmp$advise_in (xcb_p^.shadow_reference_info.source_pva,
            xcb_p^.shadow_reference_info.page_count * osv$page_size, status);
    IFEND;

{ Establish a condition handler and enable traps.  If the source page is on a unavailable volume,
{ the task needs to be able to trap and go wait on an unavailable volume, not hang in ring 1.

    #SPOIL (xcb_p);
    syp$establish_condition_handler (^condition_handler);
    i#enable_traps (traps);
    #SPOIL (traps);

    i#move (xcb_p^.shadow_reference_info.source_pva, xcb_p^.shadow_reference_info.destination_pva,
          xcb_p^.shadow_reference_info.page_count * osv$page_size);

    i#restore_traps (traps);

  PROCEND mmp$mfh_shadow_file_reference;
?? TITLE := '  MMP$MFH_VOLUME_UNAVAILABLE', EJECT ??

  PROCEDURE [XDCL] mmp$mfh_volume_unavailable;

    VAR
      gtid: ost$global_task_id,
      ignore_status: ost$status,
      mmv$vol_unavailable_timer: [XDCL] integer :=0,
      mmv$pf_system_core,
      mmv$pf_job_template: [XDCL] integer := 0,
      msg: string(80),
      psa: ^ost$minimum_save_area,
      status: ost$status,
      strl: integer,
      str: string (80),
      timer: integer,
      xcb: ^ost$execution_control_block;

    psa := #PREVIOUS_SAVE_AREA ();
    {This code assumes:
    { Page fault for bad disk; trap to TH; TH calls this procedure
    IF #RING (psa^.a2_previous_save_area) = 1 THEN

      mmv$pf_system_core := mmv$pf_system_core + 1;
      {We have interrupted the system core
      {Allow rollback - then check for system tables locked
      syp$cause_condition (syc$udc_volume_unavailable);

      {We still have control, so we must wait
      {If there are system resources tied up, we will be in trouble
      pmp$delay (30000, status);
      mmv$vol_unavailable_timer := mmv$vol_unavailable_timer + 1;
       IF mmv$vol_unavailable_timer > 4 THEN
        { send message}
         msg := 'Jobs are waiting on unavailable volume/s.';
         dpp$put_critical_message(msg, ignore_status);

        mmv$vol_unavailable_timer := 0;
       IFEND;

      {Return and attempt page fault again
    ELSE

      mmv$pf_job_template := mmv$pf_job_template + 1;
      {We have interrupted the job template
      pmp$get_executing_task_gtid (gtid);
      pmp$set_system_flag (mmc$volume_unavailable_flag, gtid, status);
      IF NOT status.normal THEN
        osp$system_error ('Error setting system flag-MMSMSC', NIL);
      IFEND;
    IFEND;

  PROCEND mmp$mfh_volume_unavailable;

?? TITLE := '  MMP$MM_MOVE_MOD_SERVER_PAGE', EJECT ??

*copyc mmh$mm_move_mod_server_page

  PROCEDURE [XDCL] mmp$mm_move_mod_server_page
    (    system_file_id: gft$system_file_identifier;
         destination_pva: ^cell;
     VAR byte_offset: ost$segment_offset;
     VAR status: ost$status);

    VAR
      rb_ring1_server_seg_request: mmt$rb_ring1_server_seg_request;

    status.normal := TRUE;

    rb_ring1_server_seg_request.reqcode := syc$rc_ring1_server_seg_request;
    rb_ring1_server_seg_request.sfid := system_file_id;
    rb_ring1_server_seg_request.request := mmc$ssr1_move_modified_df_page;
    rb_ring1_server_seg_request.destination_pva := destination_pva;
    rb_ring1_server_seg_request.byte_offset := 07fffffff(16); {dummy initialization}

    i#call_monitor (#LOC (rb_ring1_server_seg_request), #SIZE (rb_ring1_server_seg_request));

    byte_offset := rb_ring1_server_seg_request.byte_offset;
    syp$set_status_from_mtr_status (rb_ring1_server_seg_request.status, status);

  PROCEND mmp$mm_move_mod_server_page;
?? TITLE := '  MMP$OPEN_ASID_BASED_SEGMENT', EJECT ??

  PROCEDURE [XDCL] mmp$open_asid_based_segment
    (    sdt_entry: mmt$segment_descriptor;
         sdtx_entry: mmt$segment_descriptor_extended;
     VAR segment_number: ost$segment;
     VAR status: ost$status);

    VAR
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segnum: ost$segment,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_xcb (xcb_p);

    find_available_segment_number (xcb_p, mmc$srs_not_reserved, segnum, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  Add sdt_entry to the task's segment descriptor table (SDT)
    sdt_entry_p := mmp$get_sdt_entry_p (xcb_p, segnum);
    sdt_entry_p^ := sdt_entry;
    sdtx_entry_p := mmp$get_sdtx_entry_p (xcb_p, segnum);
    sdtx_entry_p^ := sdtx_entry;

    segment_number := segnum;

  PROCEND mmp$open_asid_based_segment;

?? TITLE := '  MMP$OPEN_FILE_BY_SFID', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$open_file_by_sfid
    (    sfid: gft$system_file_identifier;
         r1: ost$valid_ring;
         r2: ost$valid_ring;
         sequential_random_selection: mmt$access_selections;
         read_write_access_selection: mmt$segment_access_rights;
     VAR segment_number: ost$segment;
     VAR status: ost$status);

    VAR
      fde_entry_p: gft$locked_file_desc_entry_p,
      page_streaming_ts_shift: 0 .. 15,
      sdt_entry: mmt$segment_descriptor,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segment_res_state: mmt$segment_reservation_state,
      segnum: ost$segment,
      ste: mmt$segment_descriptor,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_xcb (xcb_p);

{  Find an available segment number if the caller did not supply one.

    segment_res_state := mmc$srs_not_reserved;
    find_available_segment_number (xcb_p, segment_res_state, segnum, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  Add sdt_entry to the task's segment descriptor table (SDT) and the sdtx_entry to the
{  segment descriptor table extended (SDTX).

    sdt_entry_p := mmp$get_sdt_entry_p (xcb_p, segnum);
    sdtx_entry_p := mmp$get_sdtx_entry_p (xcb_p, segnum);
{ THIS SDTX ENTRY SHOULD BE THE DEV FILE

    sdtx_entry_p^ := mmv$default_sdtx_entry;
    sdtx_entry_p^.sfid := sfid;
    sdt_entry := mmv$default_sdt_entry;
    sdt_entry.ste.r1 := r1;
    sdt_entry.ste.r2 := r2;
    gfp$get_locked_fde_p (sfid, fde_entry_p);
    fde_entry_p^.open_count := fde_entry_p^.open_count + 1;
    gfp$unlock_fde_p (fde_entry_p);
    IF osv$cpus_physically_configured > 1 THEN
      sdt_entry.ste.vl := osc$vl_cache_bypass;
    IFEND;
    IF read_write_access_selection = mmc$sar_read THEN
      sdt_entry.ste.wp := osc$non_writable;
    IFEND;
    IF sequential_random_selection = mmc$as_sequential THEN
      sdtx_entry_p^.software_attribute_set := $mmt$software_attribute_set
            [mmc$sa_read_transfer_unit, mmc$sa_free_behind];
      sdtx_entry_p^.stream.sequential_accesses := mmv$page_streaming_prestream;
    IFEND;
    mmp$convert_ps_transfer_size (16384, page_streaming_ts_shift); {force transfer size of 16384
    sdtx_entry_p^.stream.transfer_size := page_streaming_ts_shift;
    mmp$set_segment_access_rights (sdt_entry, sdtx_entry_p^);

    store_ste_in_segment_table (sdt_entry, sfid, sdt_entry_p, fde_entry_p, segnum);

    segment_number := segnum;

  PROCEND mmp$open_file_by_sfid;
?? TITLE := '  MMP$OS_PREALLOCATE_FILE_SPACE', EJECT ??
*copyc mmh$os_preallocate_file_space

  PROCEDURE [XDCL, #GATE] mmp$os_preallocate_file_space
    (    process_virtual_address: ^cell;
         length: ost$segment_length;
         maximum_wait_seconds: integer;
     VAR status: ost$status);

    VAR
      bytes_to_allocate: integer,
      current_time: 0 .. 0ffffffffffff(16),
      delay_status: ost$status,
      dfd_p: ^dmt$disk_file_descriptor,
      eoi: amt$file_byte_address,
      segment_number: ost$segment,
      sd_p: ^mmt$segment_descriptor,
      sdtx_p: ^mmt$segment_descriptor_extended;

    segment_number := #SEGMENT (process_virtual_address);
    mmp$validate_segment_number (segment_number, sd_p, sdtx_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$fetch_eoi (sdtx_p^.sfid, eoi, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    bytes_to_allocate := length - eoi;
    IF bytes_to_allocate <= 0 THEN
      RETURN;
    IFEND;

    current_time := #FREE_RUNNING_CLOCK (0);
    REPEAT
      mmp$assign_mass_storage (segment_number, sdtx_p^.sfid, length, status);
      IF NOT status.normal AND (status.condition = dme$unable_to_alloc_all_space) THEN
        pmp$delay (1000, delay_status);
      IFEND;
    UNTIL status.normal OR ((#FREE_RUNNING_CLOCK (0) - current_time) > (maximum_wait_seconds * 1000000));

  PROCEND mmp$os_preallocate_file_space;
?? TITLE := '  MMP$PRESET_PAGE_STREAMING', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$preset_page_streaming_r1
    (    segment_number: ost$segment;
         validating_ring_number: ost$valid_ring;
         preset_and_save_fb_and_ts: boolean;
         temp_transfer_size: integer;
     VAR saved_transfer_size: 0 .. 15;
     VAR saved_free_behind: boolean;
     VAR status: ost$status);

{  Validate the pva and get a pointer to the segment descriptor.

    VAR
      page_streaming_ts_shift: 0 .. 15,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended;

    status.normal := TRUE;
    mmp$validate_segment_number (segment_number, sdt_entry_p, sdtx_entry_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  Verify that the pointer is in the read bracket of the segment.

    IF (validating_ring_number > sdt_entry_p^.ste.r2) OR (validating_ring_number > sdt_entry_p^.ste.r2) THEN
      osp$set_status_abnormal ('MM', mme$ring_violation, '', status);
      RETURN;
    IFEND;

    IF preset_and_save_fb_and_ts THEN

{  Save the current setting of transfer size and free behind.  Then set transfer size as specified,
{  and if the streaming boolean is false, set the preset_streaming boolean = TRUE.

      saved_free_behind := (mmc$sa_free_behind IN sdtx_entry_p^.software_attribute_set);
      IF NOT saved_free_behind THEN
        sdtx_entry_p^.software_attribute_set := sdtx_entry_p^.software_attribute_set +
              $mmt$software_attribute_set [mmc$sa_free_behind];
      IFEND;
      saved_transfer_size := sdtx_entry_p^.stream.transfer_size;
      mmp$convert_ps_transfer_size (temp_transfer_size, page_streaming_ts_shift);

      IF sdtx_entry_p^.stream.transfer_size < page_streaming_ts_shift THEN
        sdtx_entry_p^.stream.transfer_size := page_streaming_ts_shift;
      IFEND;
      IF NOT sdtx_entry_p^.stream.streaming THEN
        sdtx_entry_p^.stream.preset_streaming := TRUE;
        IF sdtx_entry_p^.stream.sequential_accesses < mmv$page_streaming_prestream THEN
          sdtx_entry_p^.stream.sequential_accesses := mmv$page_streaming_prestream;
        IFEND;
      IFEND;

    ELSE

{ reset SDTX with the saved transfer size and free behind from a previous call to mmp$preset_page_streaming

      sdtx_entry_p^.stream.preset_streaming := FALSE;
      IF NOT saved_free_behind THEN
        sdtx_entry_p^.software_attribute_set := sdtx_entry_p^.software_attribute_set *
              (-$mmt$software_attribute_set [mmc$sa_free_behind]);
      IFEND;
      IF sdtx_entry_p^.stream.transfer_size > saved_transfer_size THEN
        sdtx_entry_p^.stream.transfer_size := saved_transfer_size;
      IFEND;
    IFEND;

  PROCEND mmp$preset_page_streaming_r1;

?? TITLE := '  MMP$PROCESS_FILE_ALLOC', EJECT ??
*copyc mmh$process_file_alloc

  PROCEDURE [XDCL, #GATE] mmp$process_file_alloc
    (VAR allocated_length: amt$file_byte_address;
     VAR status: ost$status);

    VAR
      accumulated_allocated_length: amt$file_byte_address,
      fde_p: gft$locked_file_desc_entry_p,
      flush_pages: boolean,
      rb: mmt$rb_ring1_segment_request,
      segnum: integer,
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      tstatus: ost$status,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    osp$begin_system_activity;
    accumulated_allocated_length := 0;
    rb.reqcode := syc$rc_ring1_segment_request;
    rb.request := mmc$sr1_flush_avail_modified;
    pmp$find_executing_task_xcb (xcb_p);
    mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);

  /allocate_loop/
    FOR segnum := 0 TO xcb_p^.xp.segment_table_length DO

      IF segnum = 0 THEN
        IF xcb_p^.assign_active_sfid <> gfv$null_sfid THEN
          gfp$get_locked_fde_p (xcb_p^.assign_active_sfid, fde_p);
          IF fde_p <> NIL THEN
            mmp$assign_mass_storage (0, xcb_p^.assign_active_sfid, 0, tstatus);
            gfp$unlock_fde_p (fde_p);
          IFEND;
        IFEND;

      ELSEIF (sdt_p^.st [segnum].ste.vl <> osc$vl_invalid_entry) AND
            (sdtx_p^.sdtx_table [segnum].assign_active <> mmc$assign_active_null) THEN
        rb.sfid := sdtx_p^.sdtx_table [segnum].sfid;
        gfp$get_fde_p (rb.sfid, fde_p);
        flush_pages := (fde_p^.media = gfc$fm_transient_segment);
        mmp$assign_mass_storage (segnum, gfv$null_sfid, 0, tstatus);
        IF tstatus.normal THEN
          IF flush_pages THEN
            i#call_monitor (#LOC (rb), #SIZE (rb));
          IFEND;
        ELSEIF (tstatus.condition = dme$unable_to_alloc_all_space) OR
              (tstatus.condition = dme$unable_to_get_fd_lock) OR
              (tstatus.condition = dfe$family_not_served) OR (tstatus.condition = dfe$server_not_active) OR
              (tstatus.condition = dfe$server_has_terminated) THEN
          IF (tstatus.condition = dme$unable_to_alloc_all_space) THEN
            gfp$get_fde_p (rb.sfid, fde_p);
            dmp$get_total_allocated_length (fde_p, allocated_length);
            accumulated_allocated_length := accumulated_allocated_length + allocated_length;
          IFEND;
          status := tstatus;
        ELSEIF tstatus.condition = dme$unable_to_create_fdt_entry THEN
          syp$terminate_task (osc$rtr_sft_full);
          EXIT /allocate_loop/;
        ELSE
          osp$end_system_activity;
          syp$mfh_for_hang_task;
        IFEND;
      IFEND;
    FOREND /allocate_loop/;

    allocated_length := accumulated_allocated_length;

    osp$end_system_activity;
  PROCEND mmp$process_file_alloc;

?? TITLE := '  MMP$RESERVE_SEGMENT_NUMBER', EJECT ??
*copyc mmh$reserve_segment_number

  PROCEDURE [XDCL, #GATE] mmp$reserve_segment_number_r1
    (    ada_stack_flag: boolean;
     VAR segment_num_list: ^array [ * ] of ost$segment;
     VAR status: ost$status);

    VAR
      segment_table_length: integer,
      i: integer,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      xcb_p: ^ost$execution_control_block,
      segnum: ost$segment;

    pmp$find_executing_task_xcb (xcb_p);

    status.normal := TRUE;
    segnum := mmv$first_transient_seg_index - 1;
    segment_table_length := xcb_p^.xp.segment_table_length;

    FOR i := LOWERBOUND (segment_num_list^) TO UPPERBOUND (segment_num_list^) DO
      REPEAT
        segnum := segnum + 1;
        IF segnum > segment_table_length THEN
          expand_segment_table (xcb_p, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          segment_table_length := xcb_p^.xp.segment_table_length;
        IFEND;
        sdt_entry_p := mmp$get_sdt_entry_p (xcb_p, segnum);
        sdtx_entry_p := mmp$get_sdtx_entry_p (xcb_p, segnum);
      UNTIL (sdt_entry_p^.ste.vl = osc$vl_invalid_entry) AND
            (sdtx_entry_p^.segment_reservation_state = mmc$srs_not_reserved);
      IF ada_stack_flag THEN
        sdtx_entry_p^.segment_reservation_state := mmc$srs_reserved_shared_stack;
      ELSE
        sdtx_entry_p^.segment_reservation_state := mmc$srs_reserved;
      IFEND;
      segment_num_list^ [i] := segnum;
    FOREND;

  PROCEND mmp$reserve_segment_number_r1;
?? TITLE := '  MMP$SET_ACCESS_MODE', EJECT ??
*copy mmh$set_access_mode

  PROCEDURE [INLINE] mmp$set_access_mode
    (    segment_descriptor: ost$segment_descriptor;
     VAR access_mode: pft$usage_selections);

    access_mode := $pft$usage_selections [];

    IF segment_descriptor.xp <> osc$non_executable THEN
      access_mode := access_mode + $pft$usage_selections [pfc$execute];
    IFEND;

    IF segment_descriptor.rp <> osc$non_readable THEN
      access_mode := access_mode + $pft$usage_selections [pfc$read];
    IFEND;

    IF segment_descriptor.wp <> osc$non_writable THEN
      access_mode := access_mode + $pft$usage_selections [pfc$shorten] + $pft$usage_selections [pfc$append] +
            $pft$usage_selections [pfc$modify];
    IFEND;

  PROCEND mmp$set_access_mode;
?? TITLE := '  MMP$SET_ACCESS_SELECTIONS_R1', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$set_access_selections_r1
    (    segment_number: ost$segment;
         validating_ring_number: ost$valid_ring;
         access_selections: mmt$access_selections;
     VAR status: ost$status);

    VAR
      sd_p: ^mmt$segment_descriptor,
      sdtx_p: ^mmt$segment_descriptor_extended;

{  Validate the pva and get a pointer to the segment descriptor.

    mmp$validate_segment_number (segment_number, sd_p, sdtx_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  Verify that the pointer is in the read bracket of the segment.

    IF (validating_ring_number > sd_p^.ste.r2) THEN
      osp$set_status_abnormal ('MM', mme$ring_violation, '', status);
      RETURN;
    IFEND;
    IF access_selections = mmc$as_sequential THEN
      sdtx_p^.software_attribute_set := sdtx_p^.software_attribute_set +
            $mmt$software_attribute_set [mmc$sa_read_transfer_unit, mmc$sa_free_behind];
    ELSEIF access_selections = mmc$as_random THEN
      sdtx_p^.software_attribute_set := sdtx_p^.software_attribute_set -
            $mmt$software_attribute_set [mmc$sa_read_transfer_unit, mmc$sa_free_behind];
    ELSEIF access_selections = mmc$as_read_tu THEN
      sdtx_p^.software_attribute_set := sdtx_p^.software_attribute_set +
            $mmt$software_attribute_set [mmc$sa_read_transfer_unit] -
            $mmt$software_attribute_set [mmc$sa_free_behind];
    IFEND;

    IF (mmc$sa_read_transfer_unit IN sdtx_p^.software_attribute_set) THEN
      IF sdtx_p^.stream.sequential_accesses < mmv$page_streaming_prestream THEN
        sdtx_p^.stream.sequential_accesses := mmv$page_streaming_prestream;
      IFEND;
    IFEND;
  PROCEND mmp$set_access_selections_r1;

?? TITLE := '  MMP$SET_SEGMENT_ACCESS_RIGHTS', EJECT ??

  PROCEDURE [XDCL, INLINE] mmp$set_segment_access_rights
    (    sd: mmt$segment_descriptor;
     VAR sdtx: mmt$segment_descriptor_extended);

    IF sd.ste.wp = osc$non_writable THEN
      sdtx.access_rights := mmc$sar_read;
    ELSEIF mmc$sa_no_append IN sdtx.software_attribute_set THEN
      sdtx.access_rights := mmc$sar_modify;
    ELSE
      sdtx.access_rights := mmc$sar_write_extend;
    IFEND;

  PROCEND mmp$set_segment_access_rights;
?? TITLE := '  MMP$SET_SEGMENT_LENGTH_R1', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$set_segment_length_r1
    (    segment_number: ost$segment;
         validating_ring_number: ost$valid_ring;
         segment_length: ost$segment_length;
     VAR status: ost$status);

{
{   The purpose of this procedure is to set or get the segment length for the
{ specified segment.  Whether to set or get segment length is based on the
{ 'set_or_get_segment_length' parameter.
{

    VAR
      request_block: mmt$rb_set_get_segment_length,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended;

    mmp$validate_segment_number (segment_number, sdt_entry_p, sdtx_entry_p, status);
    IF status.normal = FALSE THEN
      RETURN;
    IFEND;

{  Verify that caller is within write bracket and has write access.

    IF validating_ring_number > sdt_entry_p^.ste.r1 THEN
      osp$set_status_abnormal ('MM', mme$caller_not_in_write_bracket, '', status);
      RETURN;
    ELSEIF sdt_entry_p^.ste.wp = osc$non_writable THEN
      osp$set_status_abnormal ('MM', mme$no_write_access, '', status);
      RETURN;
    IFEND;

    gfp$get_fde_p (sdtx_entry_p^.sfid, request_block.fde_p);
    request_block.request_code := syc$rc_set_get_segment_length;
    request_block.subfunction_code := mmc$sf_set_segment_length_fde_p;
    request_block.segment_length := segment_length;

    i#call_monitor (#LOC (request_block), #SIZE (request_block));

  PROCEND mmp$set_segment_length_r1;

?? TITLE := '  MMP$STORE_SEGMENT_ATTRIBUTES_R1', EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$store_segment_attributes_r1
    (    segment_number: ost$segment;
         validating_ring: ost$valid_ring;
         system_privilege: boolean;
         segment_attributes: ^array [ * ] of mmt$attribute_descriptor;
     VAR status: ost$status);

    VAR
      access_mode: pft$usage_selections,
      scratch_segment_number: ost$segment,
      fde_entry_p: gft$locked_file_desc_entry_p,
      i: integer,
      pva: ^cell,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended;

{  Validate the pva and get a pointer to the segment descriptor.

    mmp$validate_segment_number (segment_number, sdt_entry_p, sdtx_entry_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (validating_ring > sdtx_entry_p^.open_validating_ring_number) OR
          (validating_ring > 6) THEN
      osp$set_status_abnormal ('MM', mme$ring_violation, '', status);
      RETURN;
    IFEND;

{  Validate that attributes can be modified.

    FOR i := LOWERBOUND (segment_attributes^) TO UPPERBOUND (segment_attributes^) DO
      CASE segment_attributes^ [i].keyword OF
      = mmc$kw_null_keyword =
      = mmc$kw_ring_numbers =
      = mmc$kw_max_segment_length =
      = mmc$kw_error_exit_procedure =
        osp$set_status_abnormal ('MM', mme$unsupported_keyword, '', status);
        RETURN;
      = mmc$kw_hardware_attributes =
        IF (mmc$ha_execute_local IN segment_attributes^ [i].hardware_attri_set) AND (validating_ring > 3) THEN
          osp$set_status_abnormal ('MM', mme$execute_local_invalid, '', status);
          RETURN;
        IFEND;

        IF (mmc$ha_binding IN segment_attributes^ [i].hardware_attri_set) AND (validating_ring > 3) THEN
          osp$set_status_abnormal ('MM', mme$binding_attribute_invalid, '', status);
          RETURN;
        IFEND;

        IF (NOT (mmc$ha_execute IN segment_attributes^ [i].hardware_attri_set)) AND
              (NOT (mmc$ha_execute_local IN segment_attributes^ [i].hardware_attri_set)) AND
              (mmc$ha_execute_global IN segment_attributes^ [i].hardware_attri_set) AND
              (validating_ring > 1) THEN
          osp$set_status_abnormal ('MM', mme$execute_global_invalid, '', status);
          RETURN;
        IFEND;

        IF (mmc$ha_write IN segment_attributes^ [i].hardware_attri_set) AND
              (sdt_entry_p^.ste.wp = osc$non_writable) THEN
          IF (validating_ring > 3) OR ((validating_ring <= 3) AND (NOT system_privilege)) THEN
            osp$set_status_abnormal ('MM', mme$write_uncontrolled_invalid, '', status);
            RETURN;
          IFEND;
        IFEND;

      = mmc$kw_segment_access_control =
        IF segment_attributes^ [i].access_control.execute_privilege = osc$local_privilege THEN
          osp$set_status_abnormal ('MM', mme$execute_local_invalid, '', status);
        IFEND;

        IF (segment_attributes^ [i].access_control.execute_privilege = osc$global_privilege) AND
              (validating_ring > 1) THEN
          osp$set_status_abnormal ('MM', mme$execute_global_invalid, '', status);
          RETURN;
        IFEND;

        IF (segment_attributes^ [i].access_control.read_privilege = osc$binding_segment) AND
              (validating_ring > 3) THEN
          osp$set_status_abnormal ('MM', mme$binding_attribute_invalid, '', status);
          RETURN;
        IFEND;

        IF (segment_attributes^ [i].access_control.write_privilege = osc$write_uncontrolled) AND
              (sdt_entry_p^.ste.wp = osc$non_writable) THEN
          IF (validating_ring > 3) OR ((validating_ring <= 3) AND (NOT system_privilege)) THEN
            osp$set_status_abnormal ('MM', mme$write_uncontrolled_invalid, '', status);
            RETURN;
          IFEND;
        IFEND;
      ELSE
        osp$set_status_abnormal ('MM', mme$set_unmodifiable_attribute, '', status);
        RETURN;
      CASEND;
    FOREND;

{  Change the attributes.

    FOR i := LOWERBOUND (segment_attributes^) TO UPPERBOUND (segment_attributes^) DO
      CASE segment_attributes^ [i].keyword OF
      = mmc$kw_null_keyword =
      = mmc$kw_ring_numbers =
        sdt_entry_p^.ste.r1 := segment_attributes^ [i].r1;
        sdt_entry_p^.ste.r2 := segment_attributes^ [i].r2;
      = mmc$kw_max_segment_length =
        gfp$get_locked_fde_p (sdtx_entry_p^.sfid, fde_entry_p);
        fde_entry_p^.file_limit := segment_attributes^ [i].max_length;
        gfp$unlock_fde_p (fde_entry_p);
      = mmc$kw_error_exit_procedure =
      = mmc$kw_hardware_attributes =
        IF mmc$ha_read IN segment_attributes^ [i].hardware_attri_set THEN
          sdt_entry_p^.ste.rp := osc$read_uncontrolled;
        ELSE
          sdt_entry_p^.ste.rp := osc$non_readable;
        IFEND;

        IF mmc$ha_binding IN segment_attributes^ [i].hardware_attri_set THEN
          sdt_entry_p^.ste.rp := osc$binding_segment;
        IFEND;

        IF mmc$ha_write IN segment_attributes^ [i].hardware_attri_set THEN
          sdt_entry_p^.ste.wp := osc$write_uncontrolled;
        ELSE
          sdt_entry_p^.ste.wp := osc$non_writable;
        IFEND;

        IF mmc$ha_cache_bypass IN segment_attributes^ [i].hardware_attri_set THEN
          sdt_entry_p^.ste.vl := osc$vl_cache_bypass;
        ELSE
          sdt_entry_p^.ste.vl := osc$vl_regular_segment;
        IFEND;

        IF mmc$ha_execute IN segment_attributes^ [i].hardware_attri_set THEN
          sdt_entry_p^.ste.xp := osc$non_privileged;
        ELSEIF mmc$ha_execute_local IN segment_attributes^ [i].hardware_attri_set THEN
          sdt_entry_p^.ste.xp := osc$local_privilege;
        ELSE
          sdt_entry_p^.ste.xp := osc$non_executable;
        IFEND;

      = mmc$kw_segment_access_control =
        IF segment_attributes^ [i].access_control.cache_bypass = TRUE THEN
          sdt_entry_p^.ste.vl := osc$vl_cache_bypass;
        ELSE
          sdt_entry_p^.ste.vl := osc$vl_regular_segment;
        IFEND;

        sdt_entry_p^.ste.xp := segment_attributes^ [i].access_control.execute_privilege;
        sdt_entry_p^.ste.rp := segment_attributes^ [i].access_control.read_privilege;
        sdt_entry_p^.ste.wp := segment_attributes^ [i].access_control.write_privilege;
      ELSE
      CASEND;
    FOREND;

    pva := #ADDRESS (1, segment_number, 0);
    #PURGE_BUFFER (osc$pva_purge_all_page_seg_map, pva);

  PROCEND mmp$store_segment_attributes_r1;
?? TITLE := '  MMP$TASK_DELETE_INHERITED_SDT', EJECT ??
*copy mmh$task_delete_inherited_sdt

  PROCEDURE [XDCL, #GATE] mmp$task_delete_inherited_sdt
    (    task_id: pmt$task_id;
     VAR status: ost$status);

    VAR
      fde_entry_p: gft$file_desc_entry_p,
      local_sdt_p: ^cell,
      local_sdtx_p: ^cell,
      rb: mmt$rb_ring1_segment_request,
      sdt_p: mmt$max_sdt_p,
      sdtx_p: mmt$max_sdtx_p,
      segnum: ost$segment,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$find_task_xcb (task_id, xcb_p);
    IF xcb_p = NIL THEN
      osp$set_status_abnormal ('MM', mme$invalid_task_id, '', status);
      RETURN;
    IFEND;

    mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);

  /scan_sdt_for_inherited_segs/
    FOR segnum := 0 TO xcb_p^.xp.segment_table_length DO
      IF (sdt_p^.st [segnum].ste.vl <> osc$vl_invalid_entry) AND
            (sdtx_p^.sdtx_table [segnum].inheritance = mmc$si_new_segment) THEN

{  Close or delete the segment based on whether it is assigned to a file or not.
        gfp$get_fde_p (sdtx_p^.sdtx_table [segnum].sfid, fde_entry_p);
        IF fde_entry_p^.open_count <> 1 THEN
          osp$system_error (' FDE.OPEN_COUNT incorrect', NIL);
        IFEND;
        fde_entry_p^.open_count := fde_entry_p^.open_count - 1;
        destroy_segment (sdtx_p^.sdtx_table [segnum].sfid, fde_entry_p,
              sdtx_p^.sdtx_table [segnum].file_limits_enforced, status);
      IFEND;
    FOREND /scan_sdt_for_inherited_segs/;

{  Release the SDT and SDTX table space.

    local_sdt_p := #ADDRESS (1, osc$segnum_job_fixed_heap, xcb_p^.sdt_offset);
    local_sdtx_p := #ADDRESS (1, osc$segnum_job_fixed_heap, xcb_p^.sdtx_offset);
    IF #SIZE (local_sdt_p^) > osv$page_size THEN
      mmp$free_pages (#ADDRESS (1, #SEGMENT (local_sdt_p), #OFFSET (local_sdt_p)), #SIZE (local_sdt_p^),
            osc$wait, status);
    IFEND;
    FREE local_sdtx_p IN osv$job_fixed_heap^;
    FREE local_sdt_p IN osv$job_fixed_heap^;

  PROCEND mmp$task_delete_inherited_sdt;
?? TITLE := '  MMP$TERMINATE_SHADOWING_R1', EJECT ??
*copy mmh$terminate_shadowing_r1

  PROCEDURE [XDCL, #GATE] mmp$terminate_shadowing_r1
    (    segment_number: ost$segment;
     VAR status: ost$status);

    VAR
      fde_entry_p: gft$locked_file_desc_entry_p,
      open_count: gft$open_count,
      pva: ^cell,
      rb: mmt$rb_ring1_segment_request,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended;


    pva := #ADDRESS (1, segment_number, 0);
    mmp$fetch_sdt_sdtx_locked_fde (segment_number, sdt_entry_p, sdtx_entry_p, fde_entry_p, status);
    IF status.normal = FALSE THEN
      RETURN;
    IFEND;


{  Verify if shadow active. Only READ_WRITE shadowed segments can be terminated

    IF sdtx_entry_p^.shadow_info.shadow_segment_kind <> mmc$ssk_read_write_file THEN
      osp$set_status_abnormal ('MM', mme$invalid_shadow_segment, '', status);
      gfp$unlock_fde_p (fde_entry_p);
      RETURN;
    IFEND;


{  Clear any segment locks left by the user.

    IF sdtx_entry_p^.segment_lock >= mmc$lss_lock_for_read_user THEN
      mmp$unlock_segment (pva, mmc$lus_free, osc$nowait, status);
      IF NOT status.normal THEN
        gfp$unlock_fde_p (fde_entry_p);
        osp$system_error ('Unexpected mmp$unlock_segment error', ^status);
      IFEND;
    IFEND;

{ Decrement active file open count. Delete the active FDE if open count is now zero.

    fde_entry_p^.open_count := fde_entry_p^.open_count - 1;
    open_count := fde_entry_p^.open_count;
    gfp$unlock_fde_p (fde_entry_p);

    IF open_count = 0 THEN
      destroy_segment (sdtx_entry_p^.sfid, fde_entry_p, sdtx_entry_p^.file_limits_enforced, status);
    IFEND;

{  Change segment table entry to be unshadowed.

    sdt_entry_p^.ste.asid := 0;
    sdtx_entry_p^.sfid := sdtx_entry_p^.shadow_info.shadow_sfid;
    sdtx_entry_p^.shadow_info.shadow_segment_kind := mmc$ssk_none;
    sdtx_entry_p^.shadow_info.passive_for_shadow_by_segnum := FALSE;

    #PURGE_BUFFER (osc$pva_purge_all_page_seg_map, pva);

  PROCEND mmp$terminate_shadowing_r1;
?? TITLE := '  MMP$VALIDATE_SEGMENT_NUMBER', EJECT ??
*copy mmh$validate_segment_number

  PROCEDURE [XDCL, #GATE] mmp$validate_segment_number
    (    segment_number: ost$segment;
     VAR sdt_entry_p: ^mmt$segment_descriptor;
     VAR sdtx_entry_p: ^mmt$segment_descriptor_extended;
     VAR status: ost$status);

    VAR
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_xcb (xcb_p);

    IF segment_number > xcb_p^.xp.segment_table_length THEN
      IF segment_number > 4095 THEN
        osp$set_status_abnormal ('MM', mme$segment_number_too_big, '', status);
      ELSE
        osp$set_status_abnormal ('MM', mme$segment_number_not_in_use, '', status);
      IFEND;
      RETURN;
    IFEND;

    sdt_entry_p := mmp$get_sdt_entry_p (xcb_p, segment_number);
    sdtx_entry_p := mmp$get_sdtx_entry_p (xcb_p, segment_number);
    IF sdt_entry_p^.ste.vl = osc$vl_invalid_entry THEN
      osp$set_status_abnormal ('MM', mme$segment_number_not_in_use, '', status);
    IFEND;

  PROCEND mmp$validate_segment_number;

?? TITLE := '  MMP$VERIFY_NO_SPACE_AVAILABLE', EJECT ??
*copyc mmh$verify_no_space_available

  PROCEDURE [XDCL, #GATE] mmp$verify_no_space_available
    (    process_virtual_address: ^cell;
     VAR no_space_available: boolean;
     VAR status: ost$status);

    VAR
      dfd_p: ^dmt$disk_file_descriptor,
      fde_entry_p: gft$file_desc_entry_p,
      fmd_p: ^dmt$file_medium_descriptor,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segment_number: ost$segment;

    no_space_available := FALSE;

    segment_number := #SEGMENT (process_virtual_address);
    mmp$validate_segment_number (segment_number, sdt_entry_p, sdtx_entry_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    gfp$get_locked_fde_p (sdtx_entry_p^.sfid, fde_entry_p);
    dmp$get_disk_file_descriptor_p (fde_entry_p, dfd_p);
    IF dfd_p <> NIL THEN
      fmd_p := dfd_p^.p_fmd;
      IF fmd_p <> NIL THEN
        WHILE fmd_p <> NIL DO
          {
          { Insure the segment number in fmd_p is the same as the segment number in dfd_p.
          {
          fmd_p := #address (#ring (dfd_p), #segment (dfd_p), #offset (fmd_p));
          IF fmd_p^.volume_assigned THEN
            no_space_available := (dmv$p_active_volume_table^ [fmd_p^.avt_index].mass_storage.space_gone)
                   OR (NOT dmv$p_active_volume_table^ [fmd_p^.avt_index].mass_storage.allocation_allowed);
          IFEND;
          fmd_p := fmd_p^.p_next_fmd;
        WHILEND;
      IFEND;
    IFEND;
    gfp$unlock_fde_p (fde_entry_p);

  PROCEND mmp$verify_no_space_available;

?? OLDTITLE, OLDTITLE ??
MODEND mmm$segment_manager_system_core;

*DECK DECK=MMM$SM_USER_INTERFACE EXPAND=TRUE
?? RIGHT := 110, LEFT := 1 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
?? NEWTITLE := 'MMM$SM_USER_INTERFACE' ??
MODULE mmm$sm_user_interface {MMMSMUI} ;


{
{  PURPOSE:
{     This module is used as an interface between run-anywhere
{     routines and ring 1 and monitor mem mgmnt routines.
{

?? PUSH (LISTEXT := ON) ??
*copyc GFV$NULL_SFID
*copyc MMV$CONTIGUOUS_MEM_LENGTH_MAX
*copyc MME$CONDITION_CODES
*copyc MMT$ASSIGN_CONTIG_PASS_IDENT
*copyc MMT$RB_ASSIGN_CONTIG_MEMORY
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE_EX
*copyc OST$HEAP
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$CALLER_IDENTIFIER
*copyc OST$STATUS
*copyc OST$EXECUTION_CONTROL_BLOCK
?? POP ??


{  External procedures referenced by this module.

*copyc I#CALL_MONITOR
*copyc JSP$ADVANCE_LONG_WAIT_JOBS
*copyc MMP$VALIDATE_SEGMENT_NUMBER
*copyc MMP$ASSIGN_MASS_STORAGE
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$DELAY
*copyc SYP$SET_STATUS_FROM_MTR_STATUS
*copyc dmp$reallocate_file_space
*copyc mmp$validate_segment_number
*copyc syp$push_inhibit_job_recovery
*copyc syp$pop_inhibit_job_recovery
?? TITLE := 'MMP$ASSIGN_DEVICE_TO_SEGMENT' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] mmp$assign_device_to_segment (pva: ^cell;
    VAR status: ost$status);

*copy MMH$ASSIGN_DEVICE_TO_SEGMENT

    status.normal := TRUE;
    mmp$assign_mass_storage (#segment (pva), gfv$null_sfid, 0, status);

  PROCEND mmp$assign_device_to_segment;

?? TITLE := 'MMP$ASSIGN_CONTIGUOUS_MEMORY' ??
?? EJECT ??
*copyc mmh$assign_contiguous_memory

  PROCEDURE [XDCL, #GATE] mmp$assign_contiguous_memory
    (    process_virtual_address: ^cell;
         contiguous_memory_length: ost$segment_length;
     VAR status: ost$status);

     VAR
        caller_id: ost$caller_identifier,
        dummy_pages_flushed: mmt$page_frame_index,
        loop_count: 1 .. 4,
        pass_count: mmt$assign_contig_pass_ident,
        request_block: mmt$rb_assign_contig_memory,
        segment_number: ost$segment,
        sd_p: ^mmt$segment_descriptor,
        sdtx_p: ^mmt$segment_descriptor_extended;

     #CALLER_ID (caller_id);
     IF caller_id.ring > 6 THEN
       osp$set_status_abnormal ('MM', mme$ring_violation, '', status);
       RETURN;
     IFEND;

     segment_number := #SEGMENT (process_virtual_address);
     mmp$validate_segment_number (segment_number, sd_p, sdtx_p, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

     IF (mmc$sa_wired IN sdtx_p^.software_attribute_set) OR ((mmc$sa_fixed IN
        sdtx_p^.software_attribute_set) AND (segment_number = osc$segnum_job_fixed_heap)) THEN

 {Only wired or job fixed segments are allowed.

     ELSE
       osp$set_status_abnormal ('MM', mme$contig_mem_seg_violation, '', status);
       RETURN;
     IFEND;

     IF contiguous_memory_length > mmv$contiguous_mem_length_max THEN
       osp$set_status_abnormal ('MM', mme$invalid_length_requested, '', status);
       RETURN;
     IFEND;

     request_block.request_code := syc$rc_assign_contig_memory;
     request_block.requested_length := contiguous_memory_length;
     request_block.process_virtual_address := process_virtual_address;

     FOR loop_count := 1 TO 4 DO
       pass_count := mmc$null_pass;
       REPEAT
         pass_count := SUCC (pass_count);
         CASE pass_count OF
         = mmc$scan_pft_for_free_or_avail =
           request_block.pass_count := pass_count;
         = mmc$scan_pft_free_avail_notmod =
           request_block.pass_count := pass_count;
         = mmc$scan_pft_write_mod_pages =
           request_block.pass_count := pass_count;
           i#call_monitor (#LOC (request_block), #SIZE (request_block));
           syp$set_status_from_mtr_status (request_block.status, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;
           pmp$delay (1000, status);
           request_block.pass_count := mmc$scan_pft_for_free_or_avail;
         = mmc$assign_contig_adv_long_wait =
           jsp$advance_long_wait_jobs (TRUE {flush_all_jobs}, dummy_pages_flushed);
           pmp$delay (1000, status);
           request_block.pass_count := mmc$scan_pft_for_free_or_avail;
         ELSE
         CASEND;

         i#call_monitor (#LOC (request_block), #SIZE (request_block));
         syp$set_status_from_mtr_status (request_block.status, status);
         IF ((NOT status.normal) AND (status.condition <> mme$unable_to_assign_contig_mem)) OR
             (status.normal) THEN
           RETURN;
         IFEND;
       UNTIL (pass_count = mmc$assign_contig_adv_long_wait);
       pmp$delay (1000, status);
     FOREND;

  PROCEND mmp$assign_contiguous_memory;
?? TITLE := 'MMP$REALLOCATE_FILE_SPACE' ??
?? EJECT ??
  PROCEDURE [XDCL, #GATE] mmp$reallocate_file_space
    (    pva: ^cell;
     VAR status: ost$status);

    VAR
      sd_p: ^mmt$segment_descriptor,
      sdtx_p: ^mmt$segment_descriptor_extended;

    IF pva = NIL THEN
      osp$set_status_abnormal ('MM', mme$invalid_pva, '', status);
      RETURN;
    IFEND;

    syp$push_inhibit_job_recovery;
    mmp$validate_segment_number (#segment(pva), sd_p, sdtx_p, status);
    IF NOT status.normal THEN
      syp$pop_inhibit_job_recovery;
      RETURN;
    IFEND;
    dmp$reallocate_file_space (sdtx_p^.sfid, TRUE, status);
    syp$pop_inhibit_job_recovery;

  PROCEND mmp$reallocate_file_space;
MODEND mmm$sm_user_interface
*DECK DECK=MMM$SYSTEM_IMAGE_RECOVERY EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'MMM$SYSTEM_IMAGE_RECOVERY' ??
MODULE mmm$system_image_recovery;

{ PURPOSE:
{   This module contains the memory manager routines for system recovery.

?? NEWTITLE := '  External Declarations Referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc gfc$constants
*copyc gft$file_desc_entry_p
*copyc gft$system_file_identifier
*copyc mme$condition_codes
*copyc mmt$ast_index
*copyc mmt$image_page_description
*copyc mmt$old_modified_bits
*copyc mmt$page_frame_index
*copyc osc$asid_ei
*copyc osd$cybil_structure_definitions
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc ost$page_size
*copyc ost$page_table
*copyc ost$status
?? EJECT ??
?? POP ??
*copyc dsp$get_nve_image_description
*copyc i#build_adaptable_array_ptr
*copyc osp$set_status_abnormal
*copyc mmv$ast_p
?? OLDTITLE ??
?? NEWTITLE := '  Global Declarations Referenced by this module', EJECT ??

  TYPE
    asid_asti_operand = 0 .. 10000(16),
    page_validations = (page_null_validation, page_doesnt_need_to_be_written, page_needs_to_be_written);

  VAR
    a_divisor: 0 .. 10000(16),
    a_mult: 0 .. 10000(16),
    bits: [READ, STATIC, oss$job_paged_literal] array [0 .. 15] of 0 .. 15 := [0, 8, 4, 12, 2, 10, 6, 14, 1,
          9, 5, 13, 3, 11, 7, 15],
    image_ast_p: ^mmt$active_segment_table := NIL,
    image_iht_p: ^mmt$old_modified_bits := NIL,
    image_offset: ost$segment_offset,
    image_page_size: ost$page_size,
    image_pft_p: ^mmt$page_frame_table := NIL,
    image_segment_number: ost$segment,
    mmv$a_divisor: [XREF] 0 .. 10000(16),
    mmv$a_mult: [XREF] 0 .. 10000(16),
    rcv_mfw_segment: ost$segment,
    recovery_load_offset: ost$segment_offset;

?? OLDTITLE ??
?? NEWTITLE := '  [INLINE] image_asid_to_image_asti', EJECT ??

  FUNCTION [INLINE] image_asid_to_image_asti
    (    xasid: ost$asid): mmt$ast_index;

    VAR
      asid: ost$asid;

    asid := xasid;
    asid := (asid DIV a_mult) + ((asid MOD a_mult) * a_divisor);
    image_asid_to_image_asti := (bits [asid MOD 16] * 4096) + (bits [(asid DIV 16) MOD 16] * 256) +
          (bits [(asid DIV 256) MOD 16] * 16) + bits [(asid DIV 4096) MOD 16];

  FUNCEND image_asid_to_image_asti;

?? OLDTITLE ??
?? NEWTITLE := '  [INLINE] image_asti_to_image_asid', EJECT ??

  FUNCTION [INLINE] image_asti_to_image_asid
    (    xasti: mmt$ast_index): ost$asid;

    VAR
      asti: mmt$ast_index,
      asid: ost$asid;

    asti := xasti;
    asid := (bits [asti MOD 16] * 4096) + (bits [(asti DIV 16) MOD 16] * 256) +
          (bits [(asti DIV 256) MOD 16] * 16) + bits [(asti DIV 4096) MOD 16];
    image_asti_to_image_asid := (asid DIV a_divisor) + ((asid MOD a_divisor) * a_mult);

  FUNCEND image_asti_to_image_asid;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL, #GATE] mmp$fetch_image_page_count', EJECT ??

*copy mmh$fetch_image_page_count

  PROCEDURE [XDCL, #GATE] mmp$fetch_image_page_count
    (VAR image_page_count: 0 .. osc$max_page_frames);

    VAR
      image_ast_pp: ^^mmt$active_segment_table,
      image_description: dst$nve_image_descriptor,
      operand_p: ^asid_asti_operand,
      ptr_to_adaptable_array: ^^cell;


    IF image_pft_p = NIL THEN
      dsp$get_nve_image_description (image_description);
      IF (image_description.nve_image = NIL) OR (image_description.rcv_mainframe_wired_segment = NIL) THEN
        image_page_count := 0;
        RETURN;
      IFEND;

      image_segment_number := #SEGMENT (image_description.nve_image);
      image_page_size := image_description.rcv_page_size;
      recovery_load_offset := image_description.rcv_load_offset;
      image_offset := #OFFSET (image_description.nve_image);
      image_pft_p := image_description.rcv_page_frame_tbl_p;
      image_iht_p := image_description.rcv_hash_tbl_p;
      rcv_mfw_segment := #SEGMENT (image_description.rcv_mainframe_wired_segment);

      image_ast_pp := #ADDRESS (1, rcv_mfw_segment, #OFFSET (^mmv$ast_p));
      image_ast_p := image_ast_pp^;
      ptr_to_adaptable_array := #LOC (image_ast_p);
      i#build_adaptable_array_ptr (1, rcv_mfw_segment, #OFFSET (image_ast_p), #SIZE (image_ast_p^), LOWERBOUND
            (image_ast_p^), #SIZE (image_ast_p^ [LOWERBOUND (image_ast_p^)]), #LOC (ptr_to_adaptable_array^));

      operand_p := #ADDRESS (1, rcv_mfw_segment, #OFFSET (^mmv$a_mult));
      a_mult := operand_p^;
      operand_p := #ADDRESS (1, rcv_mfw_segment, #OFFSET (^mmv$a_divisor));
      a_divisor := operand_p^;
    IFEND;

    image_page_count := (UPPERBOUND (image_pft_p^) - LOWERBOUND (image_pft_p^)) + 1;

  PROCEND mmp$fetch_image_page_count;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL, #GATE] mmp$fetch_pvas_of_image_pages', EJECT ??

*copy mmh$fetch_pvas_of_image_pages

  PROCEDURE [XDCL, #GATE] mmp$fetch_pvas_of_image_pages
    (    old_fde_p: gft$file_desc_entry_p;
         desc_p: {OUTPUT/dereferenced} ^mmt$image_page_description;
     VAR status: ost$status);

?? NEWTITLE := '    determine_page_status', EJECT ??

    PROCEDURE [INLINE] determine_page_status
      (    image_pft_entry_p: ^mmt$page_frame_table_entry;
           image_aste_p: ^mmt$active_segment_table_entry;
           old_fde_p: gft$file_desc_entry_p;
       VAR page_status: page_validations);


      page_status := page_doesnt_need_to_be_written;

{ The page is not valid for a write from the image to disk if it is not modified and it is not locked for IO.

      IF NOT image_iht_p^ [image_pft_entry_p^.pti] AND (image_pft_entry_p^.active_io_count = 0) THEN
        RETURN;
      IFEND;

{ The page is not valid for a write from the image to disk if the page lock indicates the page doesn't contain
{ data (page is being read from disk or server allocation is occurring) or the user has locked the page to
{ prevent IO.

      IF (image_pft_entry_p^.locked_page = mmc$lp_aging_lock) OR
            (image_pft_entry_p^.locked_page = mmc$lp_server_allocate_lock) OR
            (image_pft_entry_p^.locked_page = mmc$lp_page_in_lock) THEN
        RETURN;
      IFEND;

{ The page is not valid for a write from the image to disk if the segment is locked (MMP$LOCK_SEGMENT)
{ UNLESS the page is still being written from a previous MMP$UNLOCK_SEGMENT with write_protection.

      IF old_fde_p^.segment_lock.locked_for_write AND (image_pft_entry_p^.locked_page <>
            mmc$lp_write_protected_lock) THEN
        RETURN;
      IFEND;

      page_status := page_needs_to_be_written;

    PROCEND determine_page_status;
?? OLDTITLE, EJECT ??

    VAR
      asid: ost$asid,
      asti: mmt$ast_index,
      fast_search_mode: boolean,
      image_aste_p: ^mmt$active_segment_table_entry,
      image_pft_entry_p: ^mmt$page_frame_table_entry,
      image_pva: ^cell,
      image_sfid: gft$system_file_identifier,
      page_descriptor_array_index: mmt$page_frame_index,
      page_status: page_validations,
      pft_page_count: 0 .. osc$max_page_frames,
      pfti: integer;


    status.normal := TRUE;

    page_descriptor_array_index := LOWERBOUND (desc_p^.page_desc);
    desc_p^.pagesize := image_page_size;

    asti := old_fde_p^.asti;
    IF asti > UPPERBOUND (image_ast_p^) THEN
      osp$set_status_abnormal ('MM', mme$computed_asti_out_of_range, 'MMP$FETCH_PVAS_OF_IMAGE_PAGES', status);
      RETURN;
    IFEND;

    image_aste_p := ^image_ast_p^ [asti];
    image_sfid.file_entry_index := ((#OFFSET (old_fde_p)) - gfc$fde_table_base) DIV gfc$fde_size;
    IF NOT image_aste_p^.in_use OR (image_aste_p^.sfid.file_entry_index <>
        image_sfid.file_entry_index) THEN
      desc_p^.valid_desc_count := 0;
      RETURN;
    IFEND;

    asid := image_asti_to_image_asid (asti);
    pfti := image_aste_p^.pft_link.fwd;
    fast_search_mode := TRUE;

    WHILE TRUE DO
      pft_page_count := 0;

      WHILE pfti <> 0 DO
        page_status := page_null_validation;
        IF (pfti >= LOWERBOUND (image_pft_p^)) AND (pfti <= UPPERBOUND (image_pft_p^)) AND
              (#OFFSET (image_pft_p^ [pfti].aste_p) = #OFFSET (image_aste_p)) AND
              (image_pft_p^ [pfti].sva.asid = asid) AND (pft_page_count <= UPPERBOUND (desc_p^.page_desc))
              THEN

{ Check if the page is really valid.  It is not valid if it is in the process of being read from mass storage.
{ Therefore, the following code should return only valid pages.

          pft_page_count := pft_page_count + 1;
          image_pva := #ADDRESS (1, image_segment_number, (pfti * image_page_size - recovery_load_offset) +
                image_offset);
          image_pft_entry_p := ^image_pft_p^ [pfti];
          determine_page_status (image_pft_entry_p, image_aste_p, old_fde_p, page_status);
          IF page_status = page_needs_to_be_written THEN
            desc_p^.page_desc [page_descriptor_array_index].image_pva := image_pva;
            desc_p^.page_desc [page_descriptor_array_index].file_offset := image_pft_entry_p^.sva.offset;
            page_descriptor_array_index := page_descriptor_array_index + 1;
          IFEND;
        ELSE
          fast_search_mode := FALSE;
        IFEND;

        IF fast_search_mode THEN
          pfti := image_pft_entry_p^.segment_link.fwd;
          IF page_status = page_null_validation THEN
            pfti := 0;
          IFEND;
        ELSE {NOT fast_search_mode; doesn't matter what the page validation was}
          pfti := pfti + 1;
          IF pfti > UPPERBOUND (image_pft_p^) THEN
            pfti := 0;
          IFEND;
        IFEND;
      WHILEND;

      IF NOT fast_search_mode OR (pft_page_count = image_aste_p^.pages_in_memory) THEN
        desc_p^.valid_desc_count := page_descriptor_array_index - LOWERBOUND (desc_p^.page_desc);
        RETURN;
      IFEND;

{ If the recovery reaches this point, the assumption is that the image Active Segment Table is not intact for
{ the ASID in question.  Unfortunately (for performance' sake), we must go through the entire page frame table
{ to obtain the appropriate pages in this manner.

      page_descriptor_array_index := LOWERBOUND (desc_p^.page_desc);
      pfti := LOWERBOUND (image_pft_p^);
      fast_search_mode := FALSE;
    WHILEND;

  PROCEND mmp$fetch_pvas_of_image_pages;
?? OLDTITLE, OLDTITLE ??
MODEND mmm$system_image_recovery;
*DECK DECK=MMP$ACCESS_REAL_MEMORY EXPAND=FALSE
 PROCEDURE [XREF] mmp$access_real_memory (rmas: array [1 .. * ] OF integer;
    VAR pva: ^cell;
    VAR length: integer);
*DECK DECK=MMP$ADD_GLOBAL_TEMPLATE_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] mmp$add_global_template_segment (sdt_entry: mmt$segment_descriptor;
        sdtx_entry: mmt$segment_descriptor_extended;
        segment_number: ost$segment;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE_EX
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$ADD_SDT_SDTX_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] mmp$add_sdt_sdtx_entry
    (    sdt_entry: mmt$segment_descriptor;
         sdtx_entry: mmt$segment_descriptor_extended;
         fde_entry_p: gft$file_desc_entry_p;
         ada_taskid_array: ^array [1 .. *] of pmt$task_id;
         segment_number: ost$segment);

?? PUSH (LISTEXT := ON) ??
*copyc GFT$FILE_DESC_ENTRY_P
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE_EX
*copyc OSD$VIRTUAL_ADDRESS
*copyc PMT$TASK_ID
?? POP ??
*DECK DECK=MMP$ADVISE_IN EXPAND=FALSE

  PROCEDURE [XREF] mmp$advise_in (pva: ^cell;
        length: ost$byte_count;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$HARDWARE_SUBRANGES
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$ADVISE_OUT EXPAND=FALSE

  PROCEDURE [XREF] mmp$advise_out (pva: ^cell;
        length: ost$byte_count;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$HARDWARE_SUBRANGES
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$ADVISE_OUT_IN EXPAND=FALSE

  PROCEDURE [XREF] mmp$advise_out_in (out_pva: ^cell;
        out_length: ost$byte_count;
        in_pva: ^cell;
        in_length: ost$byte_count;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$HARDWARE_SUBRANGES
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$AGE_JOB_WORKING_SET EXPAND=FALSE

  PROCEDURE [XREF] mmp$age_job_working_set (ijle_p: ^jmt$initiated_job_list_entry;
        jcb_p: ^jmt$job_control_block);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
*copyc jmt$job_control_block
?? POP ??
*DECK DECK=MMP$ALLOCATE_IOCB_R1 EXPAND=FALSE
  PROCEDURE [XREF] mmp$allocate_iocb_r1;

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=MMP$ALLOCATE_IOCB_R3 EXPAND=FALSE
  PROCEDURE [XREF] mmp$allocate_iocb_r3;

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=MMP$ASID EXPAND=FALSE

  PROCEDURE [XREF] mmp$asid (asti: mmt$ast_index;
    VAR asid: ost$asid);

?? PUSH (LISTEXT := ON) ??
?? POP ??
*DECK DECK=MMP$ASID_FUNCTIONS EXPAND=FALSE

{--------------------------------------------------------------------------------------------------------
{Name:
{    mmp$ast_index
{Purpose:
{These functions convert AST indexes into an ASID and vise-versa.
{Input:
{    AST_index or ASID
{Output:
{    asid or ast_index
{--------------------------------------------------------------------------------------------------------

  VAR
    bits: array [0 .. 15] of 0 .. 255 := [0, 8, 4, 12, 2, 10, 6, 14, 1, 9, 5, 13, 3, 11, 7, 15];

  PROCEDURE [INLINE] mmp$asti (xasid: ost$asid;
    VAR xasti: mmt$ast_index);

    VAR
      asid: ost$asid,
      i: integer,
      asti: integer;


    asid := xasid DIV mmv$a_mult + (xasid MOD mmv$a_mult) * mmv$a_divisor;
    asti := 0;
    FOR i := 1 TO 4 DO
      asti := asti * 16 + bits [asid MOD 16];
      asid := asid DIV 16;
    FOREND;
    xasti := asti;
  PROCEND mmp$asti;


  PROCEDURE [INLINE] mmp$asid (xasti: mmt$ast_index;
    VAR asid: ost$asid);

    VAR
      asti: mmt$ast_index;

    asti := xasti;
    asid := (bits [asti MOD 16] * 4096) + (bits [(asti DIV 16) MOD 16] * 256) + (bits [(asti DIV 256) MOD 16]
          * 16) + bits [(asti DIV 4096) MOD 16];
    asid := asid DIV mmv$a_divisor + (asid MOD mmv$a_divisor) * mmv$a_mult;

  PROCEND mmp$asid;
*DECK DECK=MMP$ASSIGN_ASID EXPAND=FALSE

  PROCEDURE [XREF] mmp$assign_asid (VAR asid: ost$asid;
    VAR asti: mmt$ast_index;
    VAR aste_p: ^mmt$active_segment_table_entry);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$AST_INDEX
*copyc MMT$ACTIVE_SEGMENT_TABLE
*copyc OST$HARDWARE_SUBRANGES
?? POP ??
*DECK DECK=MMP$ASSIGN_CONTIGUOUS_MEMORY EXPAND=FALSE

  PROCEDURE [XREF] mmp$assign_contiguous_memory
    (    process_virtual_address: ^cell;
         contiguous_mem_length: ost$segment_length;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$ASSIGN_DEVICE_SHARED_SEGS EXPAND=FALSE

  PROCEDURE [XREF] mmp$assign_device_shared_segs (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$ASSIGN_DEVICE_TO_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] mmp$assign_device_to_segment (pva: ^cell;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$ASSIGN_MASS_STORAGE EXPAND=FALSE

   PROCEDURE [XREF] mmp$assign_mass_storage
     (    segment_number: ost$segment;
          sfid: gft$system_file_identifier;
          min_allocation_length: ost$segment_length;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$ASSIGN_PAGES EXPAND=FALSE

  PROCEDURE [XREF] mmp$assign_pages (pva: ^cell;
        length: ost$segment_length;
        preset_pages: boolean;
        wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mme$condition_codes
*copyc osd$virtual_address
*copyc ost$wait
*copyc ost$status
?? POP ??
*DECK DECK=MMP$ASSIGN_PAGE_FRAME EXPAND=FALSE
{ Xref deck - mmp$assign_page_frame.

  PROCEDURE [XREF] mmp$assign_page_frame
    (    sva: ost$system_virtual_address;
         aste_p: ^mmt$active_segment_table_entry;
         number_of_pages_to_assign: mmt$page_frame_index;
         starting_pfti: mmt$page_frame_index;
     VAR assigned_page_count: mmt$page_frame_index;
     VAR first_pfti: mmt$page_frame_index;
     VAR pstatus: mmt$page_pull_status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc mmt$active_segment_table
*copyc mmt$page_frame_index
*copyc mmt$page_pull_status
?? POP ??
*DECK DECK=MMP$ASSIGN_PAGE_TO_MONITOR EXPAND=FALSE
  PROCEDURE [XREF] mmp$assign_page_to_monitor (p: ^cell;
        page_count: integer;
        preset: boolean;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc SYT$MONITOR_STATUS
?? POP ??
*DECK DECK=MMP$ASSIGN_SEGMENT_TO_DISK EXPAND=FALSE

  PROCEDURE [XREF] mmp$assign_segment_to_disk (segnum: ost$segment;
        length: ost$segment_length;
    VAR status: ost$status);
?? PUSH (LISTEXT := OFF) ??
*copyc ost$status
*copyc osd$virtual_address
?? POP ??
*DECK DECK=MMP$ASSIGN_SPECIFIC_ASID EXPAND=FALSE
  PROCEDURE [XREF] mmp$assign_specific_asid (aste_p: ^mmt$active_segment_table_entry);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$active_segment_table
?? POP ??
*DECK DECK=MMP$ASTE_POINTER EXPAND=FALSE

  PROCEDURE [XREF] mmp$aste_pointer (asid: ost$asid;
    VAR aste_p: ^mmt$active_segment_table_entry);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$ACTIVE_SEGMENT_TABLE
*copyc OST$HARDWARE_SUBRANGES
?? POP ??
*DECK DECK=MMP$ASTE_POINTER_FROM_PFTI EXPAND=FALSE
  PROCEDURE [INLINE] mmp$aste_pointer_from_pfti (pfti: mmt$page_frame_index;
    VAR aste_p: ^mmt$active_segment_table_entry);

    ? IF mmc$debug_aste_p_from_pfti THEN
        mmp$aste_pointer (mmv$pft_p^ [pfti].sva.asid, aste_p);
        IF aste_p <> mmv$pft_p^ [pfti].aste_p THEN
          mtp$error_stop ('MM - ERROR IN ASTE_POINTER_FROM_PFTI');
        IFEND;
    ? ELSE
        aste_p := mmv$pft_p^ [pfti].aste_p;
    ? IFEND;

  PROCEND mmp$aste_pointer_from_pfti;
*DECK DECK=MMP$ASTI EXPAND=FALSE
  PROCEDURE [XREF] mmp$asti (asid: ost$asid;
    VAR asti: mmt$ast_index);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$AST_INDEX
?? POP ??
*DECK DECK=MMP$BOOT_ADD_SDT_SDTX_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] mmp$boot_add_sdt_sdtx_entry
    (    sdt_entry: mmt$segment_descriptor;
         sdtx_entry: mmt$segment_descriptor_extended;
     VAR segment_number: ost$segment);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE_EX
*copyc OSD$VIRTUAL_ADDRESS
?? POP ??
*DECK DECK=MMP$BUILD_LOCK_RMA_LIST EXPAND=FALSE

  PROCEDURE [XREF] mmp$build_lock_rma_list (buffer_descriptor: mmt$buffer_descriptor;
        length: ost$byte_count;
        io_type: iot$io_function;
        list_p: ^mmt$rma_list;
        list_length: mmt$rma_list_length;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$IO_FUNCTION
*copyc MMT$BUFFER_DESCRIPTOR
*copyc MMT$RMA_LIST
*copyc OST$HARDWARE_SUBRANGES
*copyc SYT$MONITOR_REQUEST_CODE
?? POP ??
*DECK DECK=MMP$BUILD_LOCK_RMA_LIST_TAPE EXPAND=FALSE

  PROCEDURE [XREF] mmp$build_lock_rma_list_tape (
        tape_request_p: ^iot$wired_tape_request;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$tape_collected_pp_response
*copyc syt$monitor_status
?? POP ??
*DECK DECK=MMP$BUILD_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] mmp$build_segment
    (    segment_attributes: mmt$segment_attrib_descriptor;
         shared_taskid_array: ^array [1 .. *] of pmt$task_id;
     VAR segment_pointer: mmt$segment_pointer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$segment_attrib_descriptor
*copyc mmt$attribute_keyword
*copyc ost$status
?? POP ??
*DECK DECK=MMP$CHANGE_ASID EXPAND=FALSE

  PROCEDURE [XREF] mmp$change_asid (aste_p: ^mmt$active_segment_table_entry;
        old_asid: ost$asid;
        new_asid: ost$asid;
        new_asti: mmt$ast_index);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$ACTIVE_SEGMENT_TABLE
*copyc OST$HARDWARE_SUBRANGES
*copyc MMT$AST_INDEX
?? POP ??
*DECK DECK=MMP$CHANGE_SEGMENT_INHERITANCE EXPAND=FALSE

  PROCEDURE [XREF] mmp$change_segment_inheritance
    (    pva: ^cell;
         segment_inheritance: mmt$segment_inheritance;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$segment_inheritance
*copyc ost$status
?? POP ??
*DECK DECK=MMP$CHANGE_SEGMENT_NUMBER EXPAND=FALSE

  PROCEDURE [XREF] mmp$change_segment_number
    (    segment_pointer: amt$segment_pointer;
         segment_number: ost$segment;
         validation_ring_number: ost$valid_ring;
     VAR new_segment_pointer: amt$segment_pointer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$segment_pointer
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$CHANGE_SEGMENT_NUMBER_R1 EXPAND=FALSE

  PROCEDURE [XREF] mmp$change_segment_number_r1
    (    old_segment_number: ost$segment;
         new_segment_number: ost$segment;
         validating_ring_number: ost$valid_ring;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$CHANGE_SEG_INHERITANCE_R1 EXPAND=FALSE

   PROCEDURE [XREF] mmp$change_seg_inheritance_r1
     (    segment_number: ost$segment;
          validating_ring_number: ost$valid_ring;
          segment_inheritance: mmt$segment_inheritance;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$segment_inheritance
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$CHANGE_STACK_ATTRIBUTE EXPAND=FALSE


  PROCEDURE [XREF] mmp$change_stack_attribute
    (    stack_pages_to_be_freed: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=MMP$CHANGE_STACK_ATTRIBUTE_R1 EXPAND=FALSE


    PROCEDURE [XREF] mmp$change_stack_attribute_r1
      (    stack_pages_to_be_freed: boolean;
           caller_ring: ost$valid_ring;
       VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$CHECK_IF_PAGES_IN_MEMORY EXPAND=FALSE

  PROCEDURE [XREF] mmp$check_if_pages_in_memory (pva: ^cell;
        length: ost$segment_length;
    VAR in_memory: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
?? POP ??
*DECK DECK=MMP$CHECK_IO_COMPLETIONS EXPAND=FALSE

  PROCEDURE [XREF] mmp$check_io_completions
    (    timestamp: ost$free_running_clock;
         wait_time: integer;
     VAR status: ost$status);

?? PUSCH (LISTEXT := ON) ??
*copyc mme$condition_codes
*copyc ost$free_running_clock
*copyc ost$status
?? POP ??

*DECK DECK=MMP$CHECK_IO_STATUS EXPAND=FALSE
  PROCEDURE [XREF] mmp$check_io_status
    (    status_pointer_array: mmt$io_status_pointer_array;
         wait_time: integer;
     VAR index: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc mmt$io_status
?? POP ??
*DECK DECK=MMP$CHECK_QUEUES EXPAND=FALSE

  PROCEDURE [INLINE] mmp$check_queues;

    ?IF mmc$debug_check_queues THEN
      IF mmv$check_queues > 0 THEN
        mmp$xcheck_queues;
      IFEND;
    ?IFEND;

  PROCEND;

*DECK DECK=MMP$CLAIM_PAGES_FOR_SWAPIN EXPAND=FALSE

  PROCEDURE [XREF] mmp$claim_pages_for_swapin
    (    swapped_job_entry: jmt$swapped_job_entry;
         aste_p: ^mmt$active_segment_table_entry;
         ijl_ordinal: jmt$ijl_ordinal;
     VAR job_page_queue_list: mmt$job_page_queue_list;
     VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc jmt$swapped_job_entry
*copyc mmt$active_segment_table
*copyc mmt$page_queue_list
*copyc syt$monitor_status
?? POP ??
*DECK DECK=MMP$CLOSE_ASID_BASED_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] mmp$close_asid_based_segment(segment_number: ost$segment;
    VAR status: ost$status);
*DECK DECK=MMP$CLOSE_DEVICE_FILE EXPAND=FALSE

  PROCEDURE [XREF] mmp$close_device_file
    (    segnum: ost$segment;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$CLOSE_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] mmp$close_segment (VAR pointer: mmt$segment_pointer;
        validation_ring_number: ost$valid_ring;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$ATTRIBUTE_KEYWORD
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$CLOSE_SHARED_STACK EXPAND=FALSE

 PROCEDURE [XREF] mmp$close_shared_stack
   (VAR pointer: mmt$segment_pointer;
        shared_taskid_array: ^array [1 .. *] of pmt$task_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$attribute_keyword
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$task_id
?? POP ??
*DECK DECK=MMP$COMMIT_MEMORY EXPAND=FALSE

PROCEDURE [XREF] mmp$commit_memory;
*DECK DECK=MMP$CONDITIONAL_FREE EXPAND=FALSE

  PROCEDURE [XREF] mmp$conditional_free (pva: ^cell;
        length: ost$segment_length;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mme$condition_codes
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$CONDITIONAL_PURGE_ALL_MAP EXPAND=FALSE

  PROCEDURE [INLINE] mmp$conditional_purge_all_map (time: integer);

    VAR
      null_sva: 0 .. 0ffffffffffff(16);

    IF mmv$multiple_page_maps THEN
      IF time > mmv$time_map_last_purged THEN
        mmp$purge_all_map_proc;
      IFEND;
    ELSE
      null_sva := 0;
      #purge_buffer (osc$purge_all_page_seg_map, null_sva);
    IFEND;

  PROCEND;
?? PUSH (LISTEXT := ON) ??
*copyc mmv$time_map_last_purged
*copyc MMP$PURGE_ALL_MAP_PROC
*copyc OSC$PURGE_MAP_AND_CACHE
?? POP ??
*DECK DECK=MMP$CONDITIONAL_PURGE_ALL_S_MAP EXPAND=FALSE

  PROCEDURE [INLINE] mmp$conditional_purge_all_s_map (time: integer);

    VAR
      null_sva: 0 .. 0ffffffffffff(16);

    IF osv$cpus_logically_on > 1 THEN
      IF (time > mmv$time_map_last_purged) OR (mtv$reset_all_cache_now) THEN
        mmp$purge_all_map_proc;
      IFEND;
    ELSE
      #purge_buffer (osc$purge_all_page_seg_map, null_sva);
    IFEND;

  PROCEND;
?? PUSH (LISTEXT := ON) ??
*copyc mmv$time_map_last_purged
*copyc mmp$purge_all_map_proc
*copyc mtv$reset_all_cache_now
*copyc osc$purge_map_and_cache
*copyc osv$cpus_logically_on
?? POP ??
*DECK DECK=MMP$CONVERT_PS_TRANSFER_SIZE EXPAND=FALSE

{ Convert page streaming transfer size from bytes number of pages expressed as a power of 2

  PROCEDURE [INLINE] mmp$convert_ps_transfer_size (ps_transfer_size: integer;
        VAR ps_transfer_size_power: 0..15);
?? PUSH (LISTEXT := ON) ??

    VAR
      power: integer,
      ts: integer;

{ Calculate the lowest power of 2 that is greater than the number of pages required for the
{ page streaming transfer size.   Thus if the page  streaming transfer size = page size than it
{ will be converted to zero.  If ps_transfer_size = two pages it will be converted to 1,  if
{ ps_transfer_size = 4 pages it will be converted to 2, ...etc.

        ts := (ps_transfer_size + osv$page_size - 1)  DIV  osv$page_size;
        power := 0;
        WHILE ts > 1  DO
          power := power + 1;
          ts := (ts + 1)  DIV  2;
        WHILEND;
        IF power > UPPERVALUE (ps_transfer_size_power)  THEN
          ps_transfer_size_power := UPPERVALUE (ps_transfer_size_power);
        ELSE
          ps_transfer_size_power := power;
        IFEND;

  PROCEND mmp$convert_ps_transfer_size;
?? POP ??
*DECK DECK=MMP$CONVERT_PVA EXPAND=FALSE

  PROCEDURE [XREF] mmp$convert_pva (p: ^cell;
        cst_p: ^ost$cpu_state_table;
    VAR sva: ost$system_virtual_address;
    VAR fde_p: gft$locked_file_desc_entry_p;
    VAR aste_p: ^mmt$active_segment_table_entry;
    VAR ste_p: ^mmt$segment_descriptor;
    VAR stxe_p: ^mmt$segment_descriptor_extended);

?? PUSH (LISTEXT := ON) ??
*copyc gft$locked_file_desc_entry_p
*copyc MMT$ACTIVE_SEGMENT_TABLE
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE_EX
*copyc OST$CPU_STATE_TABLE
*copyc OST$HARDWARE_SUBRANGES
?? POP ??
*DECK DECK=MMP$CREATE_INHERITED_SDT EXPAND=FALSE

  PROCEDURE [XREF] mmp$create_inherited_sdt
    (    task_id: pmt$task_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$task_id
?? POP ??
*DECK DECK=MMP$CREATE_JOB EXPAND=FALSE

  PROCEDURE [XREF] mmp$create_job (new_job_ajl_ordinal: jmt$ajl_ordinal;
        xcb_segnum_relative_jobs_as: ost$segment;
        parent_xcb_p: ^ost$execution_control_block;
        xcb_p: ^ost$execution_control_block);

?? PUSH (LISTEXT := ON) ??
*copyc JMT$AJL_STATUS
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$EXECUTION_CONTROL_BLOCK
?? POP ??
*DECK DECK=MMP$CREATE_SCRATCH_SEGMENT EXPAND=FALSE
  PROCEDURE [XREF] mmp$create_scratch_segment (pointer_kind: amt$pointer_kind;
        access_selections: mmt$access_selections;
    VAR pointer: amt$segment_pointer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$segment_pointer
*copyc mmt$access_selections
*copyc ost$status
?? POP ??
*DECK DECK=MMP$CREATE_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] mmp$create_segment (seg_attributes_p: ^array [ * ] OF
    mmt$attribute_descriptor;
        pointer_kind: mmt$segment_pointer_kind;
        validation_ring_number: ost$valid_ring;
    VAR pointer: mmt$segment_pointer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$ATTRIBUTE_KEYWORD
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$CREATE_SHADOW_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] mmp$create_shadow_segment (segment_p: ^cell;
        shadow_offset: ost$segment_offset;
        shadow_length: ost$segment_length;
        pointer_kind: amt$pointer_kind;
    VAR pva: amt$segment_pointer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc amt$segment_pointer
*copyc ost$status
?? POP ??
*DECK DECK=MMP$CREATE_SHARED_STACK EXPAND=FALSE


  PROCEDURE [XREF] mmp$create_shared_stack
    (    seg_attributes_p: ^array [ * ] OF mmt$attribute_descriptor;
         pointer_kind: mmt$segment_pointer_kind;
         ada_taskid_array: ^array [1 .. *] of pmt$task_id;
     VAR pointer: mmt$segment_pointer;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc MMT$ATTRIBUTE_KEYWORD
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
*copyc PMT$TASK_ID
?? POP ??
*DECK DECK=MMP$CREATE_SSR_SDTX EXPAND=FALSE

  PROCEDURE [XREF] mmp$create_ssr_sdtx
    (VAR sdt_entry: mmt$segment_descriptor;
     VAR sdtx_entry: mmt$segment_descriptor_extended);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$segment_descriptor_table
*copyc mmt$segment_descriptor_table_ex
?? POP ??
*DECK DECK=MMP$CREATE_TASK EXPAND=FALSE

  PROCEDURE [XREF] mmp$create_task (parent_xcb_p: ^ost$execution_control_block;
        xcb_p: ^ost$execution_control_block;
        ijle_p: ^jmt$initiated_job_list_entry);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
*copyc OST$EXECUTION_CONTROL_BLOCK
?? POP ??
*DECK DECK=MMP$CREATE_USER_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] mmp$create_user_segment
    (    segment_attributes_p: ^array [ * ] of mmt$user_attribute_descriptor;
         pointer_kind: amt$pointer_kind;
         access_selections: mmt$access_selections;
     VAR pointer: amt$segment_pointer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$segment_pointer
*copyc mmt$access_selections
*copyc mmt$user_attribute_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=MMP$DEFINE_IMAGE_FILE EXPAND=FALSE

  PROCEDURE [XREF] mmp$define_image_file (sfid: dmt$system_file_id;
     ssr_length: 0 .. 0ffffffff(16));

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
?? POP ??
*DECK DECK=MMP$DELETE_INHERITED_SDT EXPAND=FALSE

  PROCEDURE [XREF] mmp$delete_inherited_sdt
    (    task_id: pmt$task_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$task_id
*copyc ost$status
?? POP ??
*DECK DECK=MMP$DELETE_LAST_PFTI_FROM_ARRAY EXPAND=FALSE

  PROCEDURE [INLINE] mmp$delete_last_pfti_from_array;
?? PUSH (LISTEXT := ON) ??
    mmv$pfti_array_p^.pftis [mmv$pfti_array_p^.pfti_index] := 0;

  PROCEND mmp$delete_last_pfti_from_array;
?? POP ??
*DECK DECK=MMP$DELETE_NON_INHERITED_SEGS EXPAND=FALSE

  PROCEDURE [XREF] mmp$delete_non_inherited_segs
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$DELETE_PAGE_FROM_MONITOR EXPAND=FALSE
  PROCEDURE [XREF] mmp$delete_page_from_monitor (p: ^cell;
        page_count: integer;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc syt$monitor_status
?? POP ??
*DECK DECK=MMP$DELETE_PT_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] mmp$delete_pt_entry
    (    pfti: mmt$page_frame_index;
         unlink_page_from_segment: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_index
?? POP ??
*DECK DECK=MMP$DELETE_SCRATCH_SEGMENT EXPAND=FALSE
  PROCEDURE [XREF] mmp$delete_scratch_segment
    (VAR pointer: amt$segment_pointer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$segment_pointer
*copyc ost$status
?? POP ??
*DECK DECK=MMP$DELETE_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] mmp$delete_segment (VAR pointer: mmt$segment_pointer;
        validation_ring_number: ost$valid_ring;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$ATTRIBUTE_KEYWORD
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$DELETE_USER_SEGMENT EXPAND=FALSE


   PROCEDURE [XREF] mmp$delete_user_segment
     (     VAR pointer: amt$segment_pointer;
            VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$segment_pointer
*copyc ost$status
?? POP ??
*DECK DECK=MMP$DETERMINE_ERROR_STATE EXPAND=FALSE
  PROCEDURE [XREF] mmp$determine_error_state (
         list_p: ^mmt$rma_list;
         list_length: mmt$rma_list_length;
     VAR io_error: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc mmt$rma_list
?? POP ??
*DECK DECK=MMP$DETERMINE_SHARED_QUEUE_ID EXPAND=FALSE


  FUNCTION [XREF] mmp$determine_shared_queue_id
    (    fde_p: gft$locked_file_desc_entry_p;
         ste_p: ^mmt$segment_descriptor): mmt$page_frame_queue_id;

?? PUSH (LISTEXT := ON) ??
*copyc gft$locked_file_desc_entry_p
*copyc mmt$page_frame_queue_id
*copyc mmt$segment_descriptor_table
?? POP ??
*DECK DECK=MMP$DISABLE_TRANSIENT_SEGMENTS EXPAND=FALSE

  PROCEDURE [XREF] mmp$disable_transient_segments;
*DECK DECK=MMP$DUMP_SHARED_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] mmp$dump_shared_queue
    (    total_pages_needed: mmt$page_frame_index);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_index
?? POP ??
*DECK DECK=MMP$ENABLE_TRANSIENT_SEGMENTS EXPAND=FALSE

  PROCEDURE [XREF] mmp$enable_transient_segments;
*DECK DECK=MMP$EXIT_JOB EXPAND=FALSE

  PROCEDURE [XREF] mmp$exit_job (xcb_p: ^ost$execution_control_block);

?? PUSH (LISTEXT := ON) ??
*copyc OST$EXECUTION_CONTROL_BLOCK
?? POP ??
*DECK DECK=MMP$EXIT_TASK EXPAND=FALSE

  PROCEDURE [XREF] mmp$exit_task (xcb_p: ^ost$execution_control_block);

?? PUSH (LISTEXT := ON) ??
*copyc OST$EXECUTION_CONTROL_BLOCK
?? POP ??
*DECK DECK=MMP$FAILED_ALLOCATION_FLAG_HDL EXPAND=FALSE

 PROCEDURE [XREF] mmp$failed_allocation_flag_hdl (
    flag_id: ost$system_flag);

?? PUSH (LISTEXT := ON) ??
*copyc ost$system_flag
?? POP ??
*DECK DECK=MMP$FETCH_BOOT_MEMORY_BOUNDS EXPAND=FALSE

  PROCEDURE [XREF] mmp$fetch_boot_memory_bounds
    (VAR first_byte_address: integer;
     VAR length: integer);
*DECK DECK=MMP$FETCH_IMAGE_PAGE_COUNT EXPAND=FALSE

  PROCEDURE [XREF] mmp$fetch_image_page_count
    (VAR image_page_count: 0 .. osc$max_page_frames);

?? PUSH (LISTEXT := ON) ??
*copyc ost$page_table
?? POP ??
*DECK DECK=MMP$FETCH_MANAGE_MEMORY_DATA_R1 EXPAND=FALSE

  PROCEDURE [XREF] mmp$fetch_manage_memory_data_r1
    (VAR queues: mmt$global_page_queue_list;
     VAR ma_values: mmt$mmu_ma_values;
     VAR gpql_default: mmt$mmu_gpql_default;
     VAR ma_default: mmt$mmu_ma_default);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$manage_memory_utility
*copyc mmt$page_queue_list
?? POP ??
*DECK DECK=MMP$FETCH_MANAGE_MEMORY_DATA_R3 EXPAND=FALSE

  PROCEDURE [XREF] mmp$fetch_manage_memory_data_r3
    (VAR queues: mmt$global_page_queue_list;
     VAR ma_values: mmt$mmu_ma_values;
     VAR gpql_default: mmt$mmu_gpql_default;
     VAR ma_default: mmt$mmu_ma_default);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$manage_memory_utility
*copyc mmt$page_queue_list
?? POP ??
*DECK DECK=MMP$FETCH_OFFSET_MODIFIED_PAGES EXPAND=FALSE

 PROCEDURE [XREF] mmp$fetch_offset_modified_pages (segment_p: ^cell;
       return_unallocated_offsets: boolean;
   VAR offset_list: array [ * ] OF ost$segment_offset;
   VAR offsets_returned: integer;
   VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$FETCH_OFFSET_MOD_PAGES_R1 EXPAND=FALSE

  PROCEDURE [XREF] mmp$fetch_offset_mod_pages_r1
    (    segment_number: ost$segment;
         sfid: gft$system_file_identifier;
         return_unallocated_offsets: boolean;
     VAR offset_list: ^array [ * ] OF ost$segment_offset;
     VAR offsets_returned: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$FETCH_PFTI_ARRAY_SIZE EXPAND=FALSE

  PROCEDURE [INLINE] mmp$fetch_pfti_array_size
    (VAR pfti_size: integer);

?? PUSH (LISTEXT := ON) ??
    pfti_size :=  mmv$pfti_array_p^.last_pfti_index - mmv$pfti_array_p^.pfti_first;

  PROCEND mmp$fetch_pfti_array_size;
?? POP ??
*DECK DECK=MMP$FETCH_PVAS_OF_IMAGE_PAGES EXPAND=FALSE

  PROCEDURE [XREF] mmp$fetch_pvas_of_image_pages
    (    old_fde_p: gft$file_desc_entry_p;
         desc_p: {OUTPUT/dereferenced} ^mmt$image_page_description;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$file_desc_entry_p
*copyc mmt$image_page_description
*copyc ost$status
?? POP ??
*DECK DECK=MMP$FETCH_PVA_UNWRITTEN_PAGES EXPAND=FALSE

  PROCEDURE [XREF] mmp$fetch_pva_unwritten_pages (segment_p: ^cell;
        starting_pva: ^cell;
    VAR pva_list: array [ * ] OF ^cell;
    VAR list_overflow: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$FETCH_SDT_SDTX_LOCKED_FDE EXPAND=FALSE

  PROCEDURE [XREF] mmp$fetch_sdt_sdtx_locked_fde (segment_number: ost$segment;
    VAR sdt_entry_p: ^mmt$segment_descriptor;
    VAR sdtx_entry_p: ^mmt$segment_descriptor_extended;
    VAR locked_fde_p: gft$locked_file_desc_entry_p;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$locked_file_desc_entry_p
*copyc mmt$segment_descriptor_table
*copyc mmt$segment_descriptor_table_ex
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$FETCH_SEGMENT_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] mmp$fetch_segment_attributes (pva: ^cell;
    VAR seg_attributes: array [ * ] OF mmt$attribute_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$ATTRIBUTE_KEYWORD
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$FETCH_SEGMENT_ATTRIBUTES_R1 EXPAND=FALSE

  PROCEDURE [XREF] mmp$fetch_segment_attributes_r1
    (    segment_number: ost$segment;
         validating_ring_number: ost$valid_ring;
     VAR segment_attributes: ^array [ * ] of mmt$attribute_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$attribute_keyword
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$FETCH_SITE_ACTIVE_Q_CNT_R1 EXPAND=FALSE

  PROCEDURE [XREF] mmp$fetch_site_active_q_cnt_r1
    (VAR site_active_queue_count: 0 .. mmc$pq_shared_num_sites);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_queue_id
?? POP ??
*DECK DECK=MMP$FETCH_SITE_ACTIVE_Q_CNT_R3 EXPAND=FALSE

  PROCEDURE [XREF] mmp$fetch_site_active_q_cnt_r3
    (VAR site_active_queue_count: 0 .. mmc$pq_shared_num_sites);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_queue_id
?? POP ??
*DECK DECK=MMP$FETCH_STACK_SEGMENT_INFO EXPAND=FALSE
  PROCEDURE [XREF] mmp$fetch_stack_segment_info (xcb_p: ^ost$execution_control_block;
        ring: ost$valid_ring;
        set_length_to_zero: boolean;
    VAR stack_segment_number: ost$segment;
    VAR maximum_segment_length: ost$segment_length;
    VAR found: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$EXECUTION_CONTROL_BLOCK
?? POP ??
*DECK DECK=MMP$FIND_NEXT_PFTI EXPAND=FALSE

  PROCEDURE [INLINE] mmp$find_next_pfti
    (VAR xpfti: mmt$page_frame_index);

?? PUSH (LISTEXT := ON) ??
    VAR
      pfti: mmt$page_frame_index;

    pfti := 0;
    WHILE (pfti = 0) AND
          (mmv$pfti_array_p^.pfti_index < mmv$pfti_array_p^.last_pfti_index) DO
      mmv$pfti_array_p^.pfti_index := mmv$pfti_array_p^.pfti_index + 1;
      pfti := mmv$pfti_array_p^.pftis [mmv$pfti_array_p^.pfti_index];
    WHILEND;
    IF mmv$pfti_array_p^.pfti_index >= mmv$pfti_array_p^.last_pfti_index THEN
      pfti := 0;
    IFEND;
    xpfti := pfti;

  PROCEND mmp$find_next_pfti;
?? POP ??
*DECK DECK=MMP$FREE_ASID EXPAND=FALSE

  PROCEDURE [XREF] mmp$free_asid (asid: ost$asid;
        aste_p: ^mmt$active_segment_table_entry);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$ACTIVE_SEGMENT_TABLE
*copyc OST$HARDWARE_SUBRANGES
?? POP ??
*DECK DECK=MMP$FREE_FLUSH EXPAND=FALSE

  PROCEDURE [XREF] mmp$free_flush (VAR rb: mmt$rb_free_flush;
        cst_p: ^ost$cpu_state_table);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$RB_FREE_FLUSH
*copyc OST$CPU_STATE_TABLE
?? POP ??
*DECK DECK=MMP$FREE_IMAGE_PAGES EXPAND=FALSE

PROCEDURE [XREF] mmp$free_image_pages;
*DECK DECK=MMP$FREE_IMAGE_PAGES_MTR EXPAND=FALSE


  PROCEDURE [XREF] mmp$free_image_pages_mtr;
*DECK DECK=MMP$FREE_MEMORY_IN_JOB_QUEUES EXPAND=FALSE

  PROCEDURE [XREF] mmp$free_memory_in_job_queues (VAR job_page_queue_list: mmt$job_page_queue_list;
        increment_now: boolean;
        decrement_soon: boolean;
        job_termination: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_queue_list
?? POP ??
*DECK DECK=MMP$FREE_PAGES EXPAND=FALSE

  PROCEDURE [XREF] mmp$free_pages (pva: ^cell;
        length: ost$byte_count;
        waitopt: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$HARDWARE_SUBRANGES
*copyc OST$STATUS
*copyc OST$WAIT
?? POP ??
*DECK DECK=MMP$GET_ALLOCATED_ADDRESSES EXPAND=FALSE
 PROCEDURE [XREF] mmp$get_allocated_addresses (file: ^cell;
       starting_byte_address: ost$segment_offset;
   VAR addr_list: array [ * ] of dmt$addr_length_pair;
   VAR addr_returned: integer;
   VAR list_overflow: boolean;
   VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc dmt$addr_length_pair
?? POP ??
*DECK DECK=MMP$GET_ALLOCATED_ADDRESSES_R1 EXPAND=FALSE

  PROCEDURE [XREF] mmp$get_allocated_addresses_r1
    (    segment_number: ost$segment;
         validating_ring_number: ost$valid_ring;
         starting_byte_address: ost$segment_offset;
     VAR addr_list: ^array [ * ] of dmt$addr_length_pair;
     VAR addr_returned: integer;
     VAR list_overflow: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$addr_length_pair
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$GET_AVAIL_PAGE_FRAME EXPAND=FALSE

  PROCEDURE [XREF] mmp$get_avail_page_frame (VAR pfti: mmt$page_frame_index);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_index
?? POP ??
*DECK DECK=MMP$GET_INHIBIT_IO_STATUS EXPAND=TRUE


   PROCEDURE [INLINE] mmp$get_inhibit_io_status
     (    ijl_ordinal: jmt$ijl_ordinal;
          lock: boolean;
      VAR inhibit_io: boolean;
      VAR ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      ajlo: jmt$ajl_ordinal;

     jmp$get_ijle_p (ijl_ordinal, ijle_p);
     inhibit_io := (ijle_p^.swap_status > jmc$inhibit_memory_manager_io);
     IF NOT inhibit_io THEN
       IF lock THEN
         tmp$set_lock (tmv$ptl_lock);
         jmp$lock_ajl_with_lock (ijle_p, ijl_ordinal, ajlo);
         tmp$clear_lock (tmv$ptl_lock);
       IFEND;
     IFEND;

   PROCEND mmp$get_inhibit_io_status;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc jmp$get_ijle_p
*copyc jmp$lock_ajl_with_lock
*copyc tmp$clear_lock
*copyc tmp$set_lock
*copyc tmv$ptl_lock
?? POP ??
*DECK DECK=MMP$GET_MAX_SDTX_POINTER EXPAND=FALSE

  PROCEDURE [INLINE] mmp$get_max_sdtx_pointer
    (    xcb_p: ^ost$execution_control_block;
     VAR sdtx_p: mmt$max_sdtx_p);

?? PUSH (LISTEXT := ON) ??

    sdtx_p := #ADDRESS(1, #SEGMENT (xcb_p), xcb_p^.sdtx_offset);

  PROCEND mmp$get_max_sdtx_pointer;

*copyc mmt$segment_descriptor_table_ex
*copyc ost$execution_control_block
?? POP ??
*DECK DECK=MMP$GET_MAX_SDT_POINTER EXPAND=FALSE

  PROCEDURE [INLINE] mmp$get_max_sdt_pointer
    (    xcb_p: ^ost$execution_control_block;
     VAR sdt_p: mmt$max_sdt_p);

?? PUSH (LISTEXT := ON) ??

    sdt_p := #ADDRESS(1, #SEGMENT (xcb_p), xcb_p^.sdt_offset);

  PROCEND mmp$get_max_sdt_pointer;

*copyc mmt$segment_descriptor_table
*copyc ost$execution_control_block
?? POP ??
*DECK DECK=MMP$GET_MAX_SDT_SDTX_POINTER EXPAND=FALSE

  PROCEDURE [INLINE] mmp$get_max_sdt_sdtx_pointer
    (    xcb_p: ^ost$execution_control_block;
     VAR sdt_p: mmt$max_sdt_p;
     VAR sdtx_p: mmt$max_sdtx_p);

?? PUSH (LISTEXT := ON) ??

    sdt_p := #ADDRESS(1, #SEGMENT (xcb_p), xcb_p^.sdt_offset);
    sdtx_p := #ADDRESS(1, #SEGMENT (xcb_p), xcb_p^.sdtx_offset);

  PROCEND mmp$get_max_sdt_sdtx_pointer;

*copyc mmt$segment_descriptor_table
*copyc mmt$segment_descriptor_table_ex
*copyc ost$execution_control_block
?? POP ??
*DECK DECK=MMP$GET_PAGE_Q_COUNTS EXPAND=FALSE
 PROCEDURE [XREF] mmp$get_page_q_counts (VAR counts: mmt$page_q_counts);

*copyc mmt$page_q_counts
*DECK DECK=MMP$GET_PAGE_SIZE EXPAND=FALSE
  PROCEDURE [inline] mmp$get_page_size (VAR page_size: integer);

?? PUSH (LISTEXT := ON) ??
    page_size := 512 * (128 - #read_register (osc$pr_page_size_mask));

  PROCEND mmp$get_page_size;

*copyc osc$processor_defined_registers
?? POP ??
*DECK DECK=MMP$GET_SDTX_ENTRY_P EXPAND=FALSE

   FUNCTION [INLINE] mmp$get_sdtx_entry_p
     (    xcb_p: ^ost$execution_control_block;
          segnum: ost$segment): ^mmt$segment_descriptor_extended;

     mmp$get_sdtx_entry_p := #address (1, #segment (xcb_p),
       #SIZE (mmt$segment_descriptor_extended) * segnum + xcb_p^.sdtx_offset);

   FUNCEND;

?? PUSH (LISTEXT := ON) ??
*copyc mmt$segment_descriptor_table_ex
*copyc ost$execution_control_block
*copyc ost$heap
?? POP ??

*DECK DECK=MMP$GET_SDT_ENTRY_P EXPAND=FALSE

   FUNCTION [INLINE] mmp$get_sdt_entry_p
     (    xcb_p: ^ost$execution_control_block;
          segnum: ost$segment): ^mmt$segment_descriptor;

     mmp$get_sdt_entry_p := #address (1, #segment (xcb_p),
       8 * segnum + xcb_p^.sdt_offset);

   FUNCEND;

?? PUSH (LISTEXT := ON) ??
*copyc mmt$segment_descriptor_table
*copyc ost$execution_control_block
*copyc ost$heap
?? POP ??
*DECK DECK=MMP$GET_SDT_FOR_JOB_TEMPLATE EXPAND=FALSE

  PROCEDURE [XREF] mmp$get_sdt_for_job_template
    (    pva: ^cell;
     VAR sdt_entry: mmt$segment_descriptor;
     VAR sdtx_entry: mmt$segment_descriptor_extended;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE_EX
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$GET_SEGMENT_LENGTH EXPAND=FALSE

  PROCEDURE [XREF] mmp$get_segment_length (pva: ^cell;
        validation_ring_number: ost$valid_ring;
    VAR segment_length: ost$segment_length;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$GET_SEGMENT_LENGTH_R1 EXPAND=FALSE

  PROCEDURE [XREF] mmp$get_segment_length_r1
    (    segment_number: ost$segment;
         validating_ring_number: ost$valid_ring;
     VAR segment_length: ost$segment_length;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$GET_SEGMENT_SFID EXPAND=FALSE

  PROCEDURE [XREF] mmp$get_segment_sfid (pva: ^cell;
    VAR sfid: dmt$system_file_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$GET_VERIFY_ASTI_IN_FDE EXPAND=FALSE

{ This procedure verifies that the asti stored in the file descriptor entry is still being used by
{ the same job for the same file.  If the asti is ok, it is returned; otherwise 0 is returned.

  PROCEDURE [INLINE] mmp$get_verify_asti_in_fde
    (    fde_p: gft$locked_file_desc_entry_p;
         sfid: gft$system_file_identifier;
         ijlo: jmt$ijl_ordinal;
     VAR asti: mmt$ast_index);

 ?? PUSH (LISTEXT := ON) ??
    asti := fde_p^.asti;
    IF (NOT mmv$ast_p^ [asti].in_use) OR (mmv$ast_p^ [asti].sfid <> sfid) OR
          ((sfid.residence = gfc$tr_job) AND (mmv$ast_p^ [asti].ijl_ordinal <> ijlo)) THEN
      asti := 0;
      fde_p^.asti := 0;
    IFEND;

  PROCEND mmp$get_verify_asti_in_fde;

?? POP ??

*DECK DECK=MMP$INCLUDE_P_REG_IN_DUMP EXPAND=FALSE

  PROCEDURE [XREF] mmp$include_p_reg_in_dump;
*DECK DECK=MMP$INITIALIZE EXPAND=FALSE

  PROCEDURE [XREF] mmp$initialize;
*DECK DECK=MMP$INITIALIZE_BOOT_PAGES EXPAND=FALSE

  PROCEDURE [XREF] mmp$initialize_boot_pages
    (VAR lower_bound: integer;
     VAR upper_bound: integer);
*DECK DECK=MMP$INITIALIZE_FIND_NEXT_PFTI EXPAND=FALSE
 PROCEDURE [XREF] mmp$initialize_find_next_pfti (xsva: ost$system_virtual_address;
       length: ost$segment_length;
       end_point_option: (include_partial_pages, exclude_partial_pages);
       page_selection_criteria: mmt$page_selection_criteria;
       aste_p: ^mmt$active_segment_table_entry;
   VAR xpfti: mmt$page_frame_index);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$hardware_subranges
*copyc mmt$page_selection_criteria
*copyc mmt$active_segment_table
*copyc mmt$page_frame_index
?? POP ??
*DECK DECK=MMP$INITIATE_DEBUG_SHADOWING EXPAND=FALSE


   PROCEDURE [XREF] mmp$initiate_debug_shadowing
     (    segment_pointer: ^cell;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=MMP$INITIATE_SHADOWING EXPAND=FALSE

  PROCEDURE [XREF] mmp$initiate_shadowing (pointer: ^cell;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$INITIATE_SHADOWING_R1 EXPAND=FALSE

  PROCEDURE [XREF] mmp$initiate_shadowing_r1
    (   segment_pointer: ^cell;
        validating_ring_number: ost$valid_ring;
        shadow_segment_kind: mmt$shadow_segment_kind;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$SHADOW_SEGMENT_KIND
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$INIT_SYSTEM_PRIVILEGE_MAP EXPAND=FALSE

  PROCEDURE [XREF] mmp$init_system_privilege_map
    (    offset: ost$segment_offset);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
?? POP ??
*DECK DECK=MMP$INVALIDATE_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] mmp$invalidate_segment
    (    segment_number: ost$segment;
         validating_ring_number: ost$valid_ring;
         shared_taskid_array: ^array [1 .. *] of pmt$task_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
*copyc PMT$TASK_ID
?? POP ??
*DECK DECK=MMP$ISSUE_RING1_SEGMENT_REQUEST EXPAND=FALSE
PROCEDURE [XREF] mmp$issue_ring1_segment_request (
    VAR rb: mmt$rb_ring1_segment_request);
?? PUSH (LISTEXT := ON) ??
*copyc mmt$rb_ring1_segment_request
?? POP ??
*DECK DECK=MMP$JOB_DELETE_INHERITED_SDT EXPAND=FALSE

  PROCEDURE [XREF] mmp$job_delete_inherited_sdt;

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$JOB_MULTIPROCESSING_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] mmp$job_multiprocessing_control
    (    enable: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=MMP$LINK_PAGE_FRAME_TO_QUEUE EXPAND=FALSE

{ This procedure will link a page into either the free queue or the
{ flawed queue.  The page is currently unlinked with a queue id of
{ mmc$pq_free.  Mmv$reassignable_page_frames.soon must be decremented
{ for this page.  The page was released while it still had I/O active
{ or this is an image page about to be committed.

  PROCEDURE [INLINE] mmp$link_page_frame_to_queue (pfti: mmt$page_frame_index;
        pfte_p: ^mmt$page_frame_table_entry);

*copyc mmv$pages_to_dump_p

    VAR
      queue_id: mmt$page_frame_queue_id;


    IF pfte_p^.flawed THEN
      pfte_p^.queue_id := mmc$pq_flawed;
      queue_id := mmc$pq_flawed;
    ELSE
      queue_id := mmc$pq_free;
      mmv$pages_to_dump_p^ [pfti] := FALSE;
    IFEND;

    pfte_p^.link.fwd := mmv$gpql [queue_id].pqle.link.fwd;
    IF mmv$gpql [queue_id].pqle.link.fwd = 0 THEN
      mmv$gpql [queue_id].pqle.link.bkw := pfti;
    ELSE
      mmv$pft_p^[mmv$gpql [queue_id].pqle.link.fwd].link.bkw := pfti;
    IFEND;
    mmv$gpql [queue_id].pqle.link.fwd := pfti;
    mmv$gpql [queue_id].pqle.count := mmv$gpql [queue_id].pqle.count + 1;
    mmv$reassignable_page_frames.soon := mmv$reassignable_page_frames.soon - 1;

    IF NOT pfte_p^.flawed THEN
      mmv$reassignable_page_frames.now := mmv$reassignable_page_frames.now + 1;
      jmp$check_scheduler_memory_wait;
    IFEND;

  PROCEND mmp$link_page_frame_to_queue;
*DECK DECK=MMP$LINK_PAGE_TO_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] mmp$link_page_to_segment
    (    pfti: mmt$page_frame_index;
         pfte_p: ^mmt$page_frame_table_entry;
         aste_p: ^mmt$active_segment_table_entry);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$active_segment_table
*copyc mmt$page_frame_index
*copyc mmt$page_frame_table
?? POP ??
*DECK DECK=MMP$LOCK_CATALOG_SEGMENT EXPAND=FALSE
  PROCEDURE [XREF] mmp$lock_catalog_segment
    (    p: ^cell;
         access: mmt$lus_lock_type;
         wait: ost$wait;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mme$condition_codes
*copyc mmt$lus_declarations
*copyc ost$status
*copyc ost$wait
?? POP ??
*DECK DECK=MMP$LOCK_PAGES EXPAND=FALSE

  PROCEDURE [XREF] mmp$lock_pages (pva: ^cell;
        length: ost$byte_count;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$HARDWARE_SUBRANGES
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$LOCK_SEGMENT EXPAND=FALSE
  PROCEDURE [XREF] mmp$lock_segment (p: ^cell;
        access: mmt$lus_lock_type;
        wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$WAIT
*copyc OST$STATUS
*copyc MME$CONDITION_CODES
*copyc MMT$LUS_DECLARATIONS
?? POP ??
*DECK DECK=MMP$LOG_CALLER EXPAND=FALSE
  PROCEDURE [INLINE] mmp$log_caller (b:boolean);
    IF mmv$log_enable >0 THEN
      mmp$log_caller_proc (b);
    IFEND;
  PROCEND;

  PROCEDURE [XREF] mmp$log_caller_proc (b: boolean);
  VAR
    mmv$log_enable: [XREF] integer;
*DECK DECK=MMP$LOG_CALLER_MONITOR EXPAND=FALSE
  PROCEDURE [XREF] mmp$log_caller_monitor;

*DECK DECK=MMP$LOG_CALLER_MONITOR_ENABLED EXPAND=FALSE

  FUNCTION [INLINE] mmp$log_caller_monitor_enabled: boolean;

?? PUSH (LISTEXT := ON) ??
    mmp$log_caller_monitor_enabled := mmv$benchmark_run > 0;

  FUNCEND mmp$log_caller_monitor_enabled;
*copyc mmv$benchmark_run
?? POP ??
*DECK DECK=MMP$LOG_CALLER_R1 EXPAND=FALSE
  PROCEDURE [XREF] mmp$log_caller_r1;

*DECK DECK=MMP$LOG_CALLER_R1_ENABLED EXPAND=FALSE

  FUNCTION [INLINE] mmp$log_caller_r1_enabled: boolean;

?? PUSH (LISTEXT := ON) ??

    mmp$log_caller_r1_enabled := mmv$benchmark_run > 0;

  FUNCEND mmp$log_caller_r1_enabled;
*copyc mmv$benchmark_run
?? POP ??
*DECK DECK=MMP$LOG_CALLER_R3 EXPAND=FALSE

  PROCEDURE [XREF] mmp$log_caller_r3;

*DECK DECK=MMP$MAINTAIN_MEMORY_THRESHOLDS EXPAND=FALSE

 PROCEDURE [INLINE] mmp$maintain_memory_thresholds;

{     The purpose of this procedure is to check the memory thresholds
{  concerning the status of jobs being swapped.  If memory is needed
{  swapped jobs that have not had swapout IO initiated are advanced.

    VAR
      available_memory: mmt$page_frame_index,
      pages_flushed: mmt$page_frame_index;

    available_memory := mmv$reassignable_page_frames.now + mmv$reassignable_page_frames.soon;

    IF (available_memory <= jmv$long_wait_swap_threshold [jmc$lowest_dispatching_priority]) AND
          (mmv$reassignable_page_frames.swapout_io_not_initiated <> 0) THEN
      jsp$initiate_swapout_io (pages_flushed);
    IFEND;

  PROCEND mmp$maintain_memory_thresholds;

?? PUSH (LISTEXT := ON) ??
*copyc jsp$initiate_swapout_io
*copyc jmv$long_wait_swap_threshold
?? POP ??
*DECK DECK=MMP$MAKE_PT_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] mmp$make_pt_entry (sva: ost$system_virtual_address;
        pfti: mmt$page_frame_index;
        aste_p: ^mmt$active_segment_table_entry;
        pfte_p: ^mmt$page_frame_table_entry;
    VAR mpt_status: mmt$make_pt_entry_status);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$PAGE_FRAME_INDEX
*copyc MMT$ACTIVE_SEGMENT_TABLE
*copyc MMT$MAKE_PT_ENTRY_STATUS
*copyc OST$HARDWARE_SUBRANGES
*copyc OST$PAGE_TABLE
?? POP ??
*DECK DECK=MMP$MARK_PAGE_FLAWED EXPAND=FALSE

  PROCEDURE [XREF] mmp$mark_page_flawed
    (    pfti: mmt$page_frame_index_32);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_index
?? POP ??
*DECK DECK=MMP$MFH_FOR_SEGMENT_MANAGER EXPAND=FALSE
PROCEDURE [XREF] mmp$mfh_for_segment_manager;
*DECK DECK=MMP$MM_FREE_PAGES EXPAND=FALSE
  PROCEDURE [XREF] mmp$mm_free_pages (sva: ost$system_virtual_address;
        length: ost$segment_length;
        aste_p: ^mmt$active_segment_table_entry;
        free_asid: boolean;
    VAR count: integer);


?? PUSH (LISTEXT := ON) ??
*copyc MMT$ACTIVE_SEGMENT_TABLE
*copyc OST$HARDWARE_SUBRANGES
*copyc OSD$VIRTUAL_ADDRESS
??POP??
*DECK DECK=MMP$MM_MOVE_MOD_SERVER_PAGE EXPAND=FALSE

  PROCEDURE [XREF] mmp$mm_move_mod_server_page
    (    system_file_id: gft$system_file_identifier;
         destination_pva: ^cell;
     VAR byte_offset: ost$segment_offset;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$MM_WRITE_MODIFIED_PAGES EXPAND=FALSE
  PROCEDURE [XREF] mmp$mm_write_modified_pages
    (    sva: ost$system_virtual_address;
         length: ost$segment_length;
         fde_p: gft$locked_file_desc_entry_p;
         aste_p: ^mmt$active_segment_table_entry;
         iotype: iot$io_function;
         init_new_io: boolean;
         remove_page: boolean;
         io_id: mmt$io_identifier;
     VAR io_count: mmt$active_io_count;
     VAR io_already_active: boolean;
     VAR last_written_pfti: mmt$page_frame_index;
     VAR wmp_status: mmt$write_modified_pages_status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$locked_file_desc_entry_p
*copyc iot$io_function
*copyc mmt$active_segment_table
*copyc mmt$io_identifier
*copyc mmt$page_frame_index
*copyc mmt$write_modified_pages_status
*copyc mmt$rb_memory_manager_io
*copyc osd$virtual_address
*copyc ost$hardware_subranges
?? POP ??

*DECK DECK=MMP$MODIFY_PAGES EXPAND=FALSE
  PROCEDURE [XREF] mmp$modify_pages
    (    fde_p: gft$locked_file_desc_entry_p;
         offset: ost$segment_offset;
         length: ost$byte_count;
         set_modified_bit: boolean;
     VAR status: syt$monitor_status);
?? PUSH (LISTEXT := ON) ??
*copyc gft$locked_file_desc_entry_p
*copyc syt$monitor_status
*copyc ost$hardware_subranges
*copyc osd$virtual_address
?? POP ??
*DECK DECK=MMP$MOVE_PAGES EXPAND=FALSE

  PROCEDURE [XREF] mmp$move_pages (
        pva_source: ^cell;
        pva_destination: ^cell;
        length: ost$segment_length;
        modified_bit_option: mmt$modified_bit_option;
        reject_move_if_source_modified: boolean;
    VAR moved_modified_page_count: mmt$move_pages_page_count;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$modified_bit_option
*copyc mmt$move_pages_page_count
*copyc osd$virtual_address
*copyc ost$status
?? POP ??

*DECK DECK=MMP$MTR_ALLOCATE_SPACE EXPAND=FALSE
{ Xref deck - mmp$mtr_allocate_space.

  PROCEDURE [XREF] mmp$mtr_allocate_space (
    server_iocb_p: ^mmt$server_iocb_entry;
    io_id: mmt$io_identifier );

?? PUSH (LISTEXT := ON) ??
*copyc mmt$server_io_control_block
*copyc mmt$io_identifier
?? POP ??
*DECK DECK=MMP$MTR_PROCESS_IO_COMPLETION EXPAND=FALSE

  PROCEDURE [XREF] mmp$mtr_process_io_completion (io_id: mmt$io_identifier;
    io_function: iot$io_function;
    io_status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$io_identifier
*copyc iot$io_function
*copyc syt$monitor_status
?? POP ??
*DECK DECK=MMP$MTR_PROCESS_SERVER_COMPLETE EXPAND=FALSE
{ Xref deck - mmp$mtr_process_server_complete.

  PROCEDURE [XREF] mmp$mtr_process_server_complete (
        remote_request: dft$remote_request;
        io_id: mmt$io_identifier;
        server_iocb_p: ^mmt$server_iocb_entry;
        io_status: syt$monitor_status );

?? PUSH (LISTEXT:=ON) ??
*copyc dft$remote_request
*copyc mmt$io_identifier
*copyc mmt$server_io_control_block
*copyc syt$monitor_status
?? POP ??
*DECK DECK=MMP$MTR_SET_GET_SEGMENT_LENGTH EXPAND=FALSE

  PROCEDURE [XREF] mmp$mtr_set_get_segment_length (VAR request_block:
    mmt$rb_set_get_segment_length;
        cst_p: ^ost$cpu_state_table);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$RB_SET_GET_SEGMENT_LENGTH
*copyc OST$CPU_STATE_TABLE
?? POP ??
*DECK DECK=MMP$NUDGE_PERIODIC_CALL EXPAND=FALSE

  PROCEDURE [INLINE] mmp$nudge_periodic_call;

    mmv$time_to_call_mem_mgr := 0;
    osv$time_to_check_asyn := 0;

  PROCEND mmp$nudge_periodic_call;

?? PUSH (LISTEXT := ON) ??
*copyc mmv$time_to_call_mem_mgr
*copyc osv$time_to_check_asyn
?? POP ??
*DECK DECK=MMP$OPEN_ASID_BASED_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] mmp$open_asid_based_segment
    (    sdt_entry: mmt$segment_descriptor;
         sdtx_entry: mmt$segment_descriptor_extended;
     VAR segment_number: ost$segment;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$segment_descriptor_table
*copyc mmt$segment_descriptor_table_ex
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$OPEN_FILE_BY_SFID EXPAND=FALSE

   PROCEDURE [XREF] mmp$open_file_by_sfid
     (    sfid: gft$system_file_identifier;
          r1: ost$valid_ring;
          r2: ost$valid_ring;
          sequential_random_selection: mmt$access_selections;
          read_write_access_selection: mmt$segment_access_rights;
      VAR segment_number: ost$segment;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$file_kind
*copyc gft$system_file_identifier
*copyc mmt$access_selections
*copyc mmt$segment_access_rights
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$OPEN_FILE_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] mmp$open_file_segment
    (    sfid: gft$system_file_identifier;
         seg_attributes_p: ^array [ * ] OF mmt$attribute_descriptor;
         pointer_kind: mmt$segment_pointer_kind;
         validation_ring_number: ost$valid_ring;
         file_limits_to_enforce: sft$file_space_limit_kind;
     VAR pointer: mmt$segment_pointer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc GFT$SYSTEM_FILE_IDENTIFIER
*copyc MMT$ATTRIBUTE_KEYWORD
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
*copyc SFT$FILE_SPACE_LIMIT_KIND
?? POP ??
*DECK DECK=MMP$OPEN_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] mmp$open_segment (file_name: ost$name;
        seg_attributes: ^array [ * ] OF mmt$attribute_descriptor;
        pointer_kind: mmt$segment_pointer_kind;
    VAR pointer: mmt$segment_pointer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$ATTRIBUTE_KEYWORD
*copyc OST$NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$OS_PREALLOCATE_FILE_SPACE EXPAND=FALSE
  PROCEDURE [XREF] mmp$os_preallocate_file_space
    (    process_virtual_address: ^cell;
         segment_length: ost$segment_length;
         maximum_wait_seconds: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$PAGE_PULL EXPAND=FALSE

  PROCEDURE [XREF] mmp$page_pull
    (   xsva: ost$system_virtual_address;
        fde_p: gft$locked_file_desc_entry_p;
        cst_p: ^ost$cpu_state_table;
        aste_p: ^mmt$active_segment_table_entry;
        stxe_p: ^mmt$segment_descriptor_extended;
        io_id: mmt$io_identifier;
        pages_to_read: integer;
        io_function: iot$io_function;
        allocate_if_new: boolean;
    VAR page_count: mmt$page_frame_index;
    VAR pstatus: mmt$page_pull_status;
    VAR pfti: mmt$page_frame_index);

?? PUSH (LISTEXT := ON) ??
*copyc gft$locked_file_desc_entry_p
*copyc iot$io_function
*copyc ost$cpu_state_table
*copyc mmt$active_segment_table
*copyc mmt$segment_descriptor_table_ex
*copyc mmt$io_identifier
*copyc mmt$page_frame_index
*copyc ost$hardware_subranges
*copyc mmt$page_pull_status
?? POP ??
*DECK DECK=MMP$PAGE_PULL_HASH_SVA EXPAND=FALSE
{--------------------------------------------------------------------------------------------------------
{  The procedure mmp$page_pull_hash_sva is called to hash for a page in the page table.  If the page is in
{  one of the available queues, OR if it is locked for IO, OR if it is a valid page in the page table,
{  page_count will be set to 1, pstatus will be set, and pfti will be set.  If it is an available page, the
{  page will also be relinked into the appropriate queue.
{  If the page is not found, page_count will be set to zero and pstatus will be set to ps_done.
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [inline] mmp$page_pull_hash_sva
    (    sva: ost$system_virtual_address;
         aste_p: ^mmt$active_segment_table_entry;
     VAR page_count: mmt$page_frame_index;
     VAR pstatus: mmt$page_pull_status;
     VAR pfti: mmt$page_frame_index);

    VAR
      count: 1 .. 32,
      found: boolean,
      ipti: integer,
      pfte_p: ^mmt$page_frame_table_entry,
      pte_p: ^ost$page_table_entry;


    #HASH_SVA (sva, ipti, count, found);
    pfti := 0;
    IF NOT found THEN
      page_count := 0;
      pstatus := ps_done;
    ELSE
      page_count := 1;
      pte_p := ^mmv$pt_p^ [ipti];
      IF pte_p^.v THEN
        pstatus := ps_valid_in_pt;
      ELSE
        pfti := (pte_p^.rma * 512) DIV osv$page_size;
        pfte_p := ^mmv$pft_p^ [pfti];
        IF (pfte_p^.locked_page = mmc$lp_page_in_lock) OR (pfte_p^.locked_page = mmc$lp_write_protected_lock)
              OR (pfte_p^.locked_page = mmc$lp_server_allocate_lock) THEN
          pstatus := ps_locked;
        ELSEIF pfte_p^.locked_page = mmc$lp_aging_lock THEN
          mtp$error_stop ('MM - page fault for locked page');
        ELSEIF pfte_p^.queue_id < mmc$pq_first_valid_in_pt THEN
          IF pfte_p^.queue_id = mmc$pq_avail THEN
            pstatus := ps_found_in_avail;
          ELSE
            pstatus := ps_found_in_avail_modified;
          IFEND;
          pfte_p^.ijl_ordinal := aste_p^.ijl_ordinal;
          mmp$relink_page_frame (pfti, aste_p^.queue_id);
          pte_p^.v := TRUE;
        ELSE
          mtp$error_stop ('MM - bad page status on PF');
        IFEND;
      IFEND;
    IFEND;
  PROCEND mmp$page_pull_hash_sva;

?? PUSH (LISTEXT := ON)??
*copyc mmt$active_segment_table
*copyc mmt$page_frame_index
*copyc ost$hardware_subranges
*copyc mmt$page_pull_status
?? POP ??
*DECK DECK=MMP$PFT_INITIALIZE EXPAND=FALSE

  PROCEDURE [XREF] mmp$pft_initialize;
*DECK DECK=MMP$PREALLOCATE_FILE_SPACE EXPAND=FALSE
  PROCEDURE [XREF] mmp$preallocate_file_space
    (    pva: amt$segment_pointer;
         length: ost$segment_length;
         wait: boolean;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$segment_pointer
*copyc osd$virtual_address
*copyc ost$wait
*copyc ost$status
?? POP ??
*DECK DECK=MMP$PRESET_CONVERSION EXPAND=FALSE

  PROCEDURE [INLINE] mmp$preset_conversion (
         preset_value_int: integer;
    VAR  preset_value_ord: pmt$initialization_value);

?? PUSH (LISTEXT := ON) ??

   VAR
     i: pmt$initialization_value;

   preset_value_ord := pmc$initialize_to_zero;
   /preset_loop/
   FOR i := LOWERBOUND (mmv$preset_conversion_table) TO UPPERBOUND (mmv$preset_conversion_table) DO
     IF (preset_value_int = mmv$preset_conversion_table [i]) THEN
      preset_value_ord := i;
      EXIT /preset_loop/;
    IFEND;
  FOREND /preset_loop/;

 PROCEND mmp$preset_conversion;

*copyc mmv$preset_conversion_table
*copyc pmt$initialization_value
?? POP ??
*DECK DECK=MMP$PRESET_PAGE_STREAMING EXPAND=FALSE

  PROCEDURE [XREF] mmp$preset_page_streaming
    (    preset_and_save_ts_fb:  boolean;
         pva: ^cell;
         temp_transfer_size: integer;
     VAR transfer_size: 0..15;
     VAR free_behind:  boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$segment_descriptor_table_ex
?? POP ??
*DECK DECK=MMP$PRESET_PAGE_STREAMING_R1 EXPAND=FALSE

   PROCEDURE [XREF] mmp$preset_page_streaming_r1
     (    segment_number: ost$segment;
          validating_ring_number: ost$valid_ring;
          preset_and_save_fb_and_ts: boolean;
          temp_transfer_size: integer;
      VAR saved_transfer_size: 0 .. 15;
      VAR saved_free_behind: boolean;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$PRESET_REAL_MEMORY EXPAND=FALSE

  PROCEDURE [XREF] mmp$preset_real_memory (sva: ost$system_virtual_address;
        preset_value: pmt$initialization_value);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$initialization_value
?? POP ??
*DECK DECK=MMP$PROCESS_FILE_ALLOC EXPAND=FALSE

  PROCEDURE [XREF] mmp$process_file_alloc (
    VAR allocated_length: amt$file_byte_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$PROCESS_PAGE_TABLE_FULL EXPAND=FALSE
  PROCEDURE [XREF] mmp$process_page_table_full (sva: ost$system_virtual_address;
    VAR new_asid: ost$asid;
    VAR new_asti: mmt$ast_index;
    VAR new_aste_p: ^mmt$active_segment_table_entry;
    VAR pt_full_status: mmt$pt_full_status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$active_segment_table
*copyc mmt$pt_full_status
*copyc ost$hardware_subranges
?? POP ??
*DECK DECK=MMP$PROCESS_READ_AHEAD_COMPLETE EXPAND=FALSE

  PROCEDURE [XREF] mmp$process_read_ahead_complete
    (    io_id: mmt$io_identifier;
     VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$io_identifier
*copyc syt$monitor_status
?? POP ??
*DECK DECK=MMP$PROCESS_VOLUME_UNAVAILABLE EXPAND=FALSE
  PROCEDURE [XREF] mmp$process_volume_unavailable (xcb_p: ^ost$execution_control_block;
    reset_p_register: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc ost$execution_control_block
?? POP ??
*DECK DECK=MMP$PROCESS_WMP_STATUS EXPAND=FALSE

  PROCEDURE [XREF] mmp$process_wmp_status (wmp_status: mmt$write_modified_pages_status;
        last_written_pfti: mmt$page_frame_index;
        rb_wait: ost$wait;
        VAR rb_init_new_io: boolean;
        VAR rb_status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$write_modified_pages_status
*copyc mmt$page_frame_index
*copyc ost$wait
*copyc syt$monitor_status
?? POP ??
*DECK DECK=MMP$PURGE_ALL_CACHE EXPAND=FALSE
  PROCEDURE [INLINE] mmp$purge_all_cache;

    VAR
      null_sva: 0 .. 0ffffffffffff(16);

    IF mmv$multiple_caches THEN
      mmp$purge_all_cache_proc;
    ELSE
      null_sva := 0;
      #purge_buffer (osc$purge_all_cache, null_sva);
    IFEND;

  PROCEND;
?? PUSH (LISTEXT := ON) ??
*copyc MMP$PURGE_ALL_CACHE_PROC
*copyc OSC$PURGE_MAP_AND_CACHE
?? POP ??
*DECK DECK=MMP$PURGE_ALL_CACHE_MAP EXPAND=FALSE

  PROCEDURE [INLINE] mmp$purge_all_cache_map;

    VAR
      null_sva: 0 .. 0ffffffffffff(16);

    IF mmv$multiple_caches OR mmv$multiple_page_maps THEN
      mmp$purge_all_cache_map_proc;
    ELSE
      null_sva := 0;
      #purge_buffer (osc$purge_all_cache, null_sva);
      #purge_buffer (osc$purge_all_page_seg_map, null_sva);
    IFEND;

  PROCEND;
?? PUSH (LISTEXT := ON) ??
*copyc MMP$PURGE_ALL_CACHE_MAP_PROC
*copyc OSC$PURGE_MAP_AND_CACHE
?? POP ??
*DECK DECK=MMP$PURGE_ALL_CACHE_MAP_PROC EXPAND=FALSE

  PROCEDURE [XREF] mmp$purge_all_cache_map_proc;
*DECK DECK=MMP$PURGE_ALL_CACHE_PROC EXPAND=FALSE
  PROCEDURE [XREF] mmp$purge_all_cache_proc;

*DECK DECK=MMP$PURGE_ALL_MAP_PROC EXPAND=FALSE
  PROCEDURE [XREF] mmp$purge_all_map_proc;

*DECK DECK=MMP$PURGE_ALL_PAGE_MAP EXPAND=FALSE

  PROCEDURE [INLINE] mmp$purge_all_page_map;

    VAR
      null_sva: 0 .. 0ffffffffffff(16);

    IF mmv$multiple_page_maps THEN
      mmp$purge_all_map_proc;
    ELSE
      null_sva := 0;
      #purge_buffer (osc$purge_all_page_seg_map, null_sva);
    IFEND;

  PROCEND;
?? PUSH (LISTEXT := ON) ??
*copyc MMP$PURGE_ALL_MAP_PROC
*copyc OSC$PURGE_MAP_AND_CACHE
?? POP ??
*DECK DECK=MMP$PURGE_ALL_PAGE_SEG_MAP EXPAND=FALSE
  PROCEDURE [INLINE] mmp$purge_all_page_seg_map;

    VAR
      null_sva: 0 .. 0ffffffffffff(16);

    IF osv$cpus_logically_on > 1 THEN
      mmp$purge_all_map_proc;
    ELSE
      #purge_buffer (osc$purge_all_page_seg_map, null_sva);
    IFEND;

  PROCEND;
?? PUSH (LISTEXT := ON) ??
*copyc osv$cpus_logically_on
*copyc MMP$PURGE_ALL_MAP_PROC
*copyc OSC$PURGE_MAP_AND_CACHE
?? POP ??
*DECK DECK=MMP$PVA_PURGE_ONE_PAGE_MAP EXPAND=FALSE
  PROCEDURE [INLINE] mmp$pva_purge_one_page_map (pva: ^cell);

    IF mmv$multiple_page_maps THEN
      mmp$purge_all_map_proc;
    ELSE
      #purge_buffer (osc$pva_purge_one_page_map, pva);
    IFEND;

  PROCEND;
?? PUSH (LISTEXT := ON) ??
*copyc MMP$PURGE_ALL_MAP_PROC
*copyc OSC$PURGE_MAP_AND_CACHE
?? POP ??
*DECK DECK=MMP$READ EXPAND=FALSE
  PROCEDURE [XREF] mmp$read (pva: ^cell;
        length: ost$segment_length;
        iostatus_p: ^mmt$io_status;
        wait: ost$wait;
   VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc mmt$io_status
*copyc ost$wait
*copyc osd$virtual_address
?? POP ??
*DECK DECK=MMP$REALLOCATE_FILE_SPACE EXPAND=FALSE
PROCEDURE [XREF] mmp$reallocate_file_space (pva: ^cell;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=MMP$RECLAIM_AST_ENTRIES EXPAND=FALSE

  PROCEDURE [XREF] mmp$reclaim_ast_entries
    (    asti_that_cannot_be_freed: mmt$ast_index);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$ast_index
?? POP ??

*DECK DECK=MMP$RELINK_PAGE_FRAME EXPAND=FALSE

  PROCEDURE [XREF] mmp$relink_page_frame (pfti: mmt$page_frame_index;
        queue_id: mmt$page_frame_queue_id);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$PAGE_FRAME_INDEX
*copyc MMT$PAGE_FRAME_QUEUE_ID
?? POP ??
*DECK DECK=MMP$REMOVE_PAGES_FROM_JWS EXPAND=FALSE

  PROCEDURE [XREF] mmp$remove_pages_from_jws
    (    modified_queue_id: mmt$page_frame_queue_id;
         ijle_p: ^jmt$initiated_job_list_entry;
     VAR modified_page_count: integer;
     VAR total_page_count: integer);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
*copyc mmt$page_frame_queue_id
?? POP ??
*DECK DECK=MMP$REMOVE_PAGES_WORKING_SET EXPAND=FALSE
  PROCEDURE [XREF] mmp$remove_pages_working_set (sva: ost$system_virtual_address;
        length: ost$segment_length;
        aste_p: ^mmt$active_segment_table_entry;
    VAR count: integer);

?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$HARDWARE_SUBRANGES
?? POP ??
*DECK DECK=MMP$REMOVE_PAGE_FROM_JOB EXPAND=FALSE

  PROCEDURE [XREF] mmp$remove_page_from_job (pfti: mmt$page_frame_index);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_index
?? POP ??
*DECK DECK=MMP$REMOVE_PAGE_FROM_JWS EXPAND=FALSE

  PROCEDURE [XREF] mmp$remove_page_from_jws (pfti: mmt$page_frame_index;
        ijle_p: ^jmt$initiated_job_list_entry;
    VAR mcount: integer;
    VAR rcount: integer);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
*copyc MMT$PAGE_FRAME_INDEX
?? POP ??
*DECK DECK=MMP$REMOVE_STALE_PAGES EXPAND=FALSE
  PROCEDURE [XREF] mmp$remove_stale_pages (VAR pqle: mmt$page_queue_list_entry;
        age_limit: integer;
        jcb_p: ^jmt$job_control_block;
        ijle_p: ^jmt$initiated_job_list_entry;
        queue_id: mmt$page_frame_queue_id;
        minimum_working_set: 0 .. 0ffff(16);
    VAR modified_pages_removed: integer;
    VAR total_pages_removed: integer);

?? PUSH (LISTEXT := ON)??
*copyc jmt$job_control_block
*copyc mmt$page_queue_list
*copyc mmt$page_frame_queue_id
?? POP ??
*DECK DECK=MMP$REMOVE_SWAPPED_SHARED_PAGES EXPAND=FALSE

  PROCEDURE [XREF] mmp$remove_swapped_shared_pages
    (    ijle_p: ^jmt$initiated_job_list_entry);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=MMP$REPLENISH_FREE_QUEUES EXPAND=FALSE

  PROCEDURE [XREF] mmp$replenish_free_queues (asid: ost$asid);


*DECK DECK=MMP$RESERVE_SEGMENT_NUMBER EXPAND=FALSE

  PROCEDURE [XREF] mmp$reserve_segment_number (
        shared_stack_flag: boolean;
    VAR seg_num_array: ^array [ * ] of ost$segment;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$RESERVE_SEGMENT_NUMBER_R1 EXPAND=FALSE

  PROCEDURE [XREF] mmp$reserve_segment_number_r1 (
        shared_stack_flag: boolean;
    VAR segment_num_array: ^array [ * ] of ost$segment;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$RESET_FIND_NEXT_PFTI EXPAND=FALSE

  PROCEDURE [INLINE] mmp$reset_find_next_pfti
    (VAR xpfti: mmt$page_frame_index);

?? PUSH (LISTEXT := ON) ??
    VAR
      pfti: mmt$page_frame_index;


    mmv$pfti_array_p^.pfti_index :=  mmv$pfti_array_p^.pfti_first;
    pfti := mmv$pfti_array_p^.pftis [mmv$pfti_array_p^.pfti_first];

    WHILE (pfti = 0) AND
          (mmv$pfti_array_p^.pfti_index < mmv$pfti_array_p^.last_pfti_index) DO
      mmv$pfti_array_p^.pfti_index := mmv$pfti_array_p^.pfti_index + 1;
      pfti := mmv$pfti_array_p^.pftis [mmv$pfti_array_p^.pfti_index];
    WHILEND;

    IF mmv$pfti_array_p^.pfti_index >= mmv$pfti_array_p^.last_pfti_index THEN
      pfti := 0;
    IFEND;
    xpfti := pfti;


  PROCEND mmp$reset_find_next_pfti;
?? POP ??
*DECK DECK=MMP$RESET_STORE_NEXT_PFTI EXPAND=FALSE

  PROCEDURE [INLINE] mmp$reset_store_pfti;

?? PUSH (LISTEXT := ON) ??
    mmv$pfti_array_p^.last_pfti_index := 0;
    mmv$pfti_array_p^.pfti_index := 0;
    mmv$pfti_array_p^.pfti_first := 0;
  PROCEND;
?? POP ??
*DECK DECK=MMP$RESET_STORE_PFTI_REVERSE EXPAND=FALSE

  PROCEDURE [INLINE] mmp$reset_store_pfti_reverse;

?? PUSH (LISTEXT := ON) ??
    mmv$pfti_array_p^.last_pfti_index := UPPERBOUND(mmv$pfti_array_p^.pftis) - 1;
    mmv$pfti_array_p^.pfti_index :=  UPPERBOUND(mmv$pfti_array_p^.pftis) - 1;
    mmv$pfti_array_p^.pfti_first :=  UPPERBOUND(mmv$pfti_array_p^.pftis) - 1;
  PROCEND;
?? POP ??
*DECK DECK=MMP$RESTART_SERVER_REQUEST EXPAND=TRUE
   PROCEDURE [XREF] MMP$RESTART_SERVER_REQUEST (p_cpu_queue_entry: ^dft$cpu_queue_entry;
        remote_request: dft$remote_request);

*copyc dft$remote_request
*copyc dft$cpu_queue

*DECK DECK=MMP$REVERIFY_ACCESS EXPAND=FALSE

  FUNCTION [XREF] mmp$reverify_access (pva: ^^cell): boolean;

*DECK DECK=MMP$SEGMENT_FAULT_HANDLER EXPAND=FALSE


  PROCEDURE [XREF] mmp$segment_fault_handler (segment_access_fault {input} :
    ost$monitor_fault;
        fault_save_area_p {input} : ^ost$stack_frame_save_area);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc OST$MONITOR_FAULT
?? POP ??
*DECK DECK=MMP$SET_ACCESS_MODE EXPAND=FALSE

  PROCEDURE [XREF] mmp$set_access_mode (segment_descriptor: ost$segment_descriptor;
    VAR access_mode: pft$usage_selections);

?? PUSH (LISTEXT := ON) ??
*copyc OST$SEGMENT_DESCRIPTOR
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
?? POP ??
*DECK DECK=MMP$SET_ACCESS_SELECTIONS EXPAND=FALSE
  PROCEDURE [XREF] mmp$set_access_selections (pva: ^cell;
        access_selection: mmt$access_selections;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$access_selections
*copyc ost$status
?? POP ??
*DECK DECK=MMP$SET_ACCESS_SELECTIONS_R1 EXPAND=FALSE


   PROCEDURE [XREF] mmp$set_access_selections_r1
     (    segment_number: ost$segment;
          validating_ring_number: ost$valid_ring;
          access_selections: mmt$access_selections;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$access_selections
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$SET_INCLUDE_PAGES_IN_DUMP EXPAND=FALSE

  PROCEDURE [INLINE] mmp$set_include_pages_in_dump
    (    segment_number: ost$segment;
         fde_p: gft$locked_file_desc_entry_p;
         sdt_p: ^mmt$segment_descriptor;
     VAR include_pages_in_dump: boolean);

    IF (sdt_p^.ste.wp <> osc$non_writable) THEN
      IF (segment_number < mmc$first_loader_predefined_seg) OR
            (fde_p^.stack_for_ring <> 0) OR
            (fde_p^.flags.global_template_file) OR
            (sdt_p^.ste.r1 <= 2) THEN
        include_pages_in_dump := TRUE;
      ELSE
        include_pages_in_dump := FALSE;
      IFEND;
    ELSE
      include_pages_in_dump := FALSE;
    IFEND;

  PROCEND mmp$set_include_pages_in_dump;

?? PUSH (LISTEXT := ON) ??
*copyc gft$locked_file_desc_entry_p
*copyc mmc$first_transient_segment
*copyc mmt$segment_descriptor_table
*copyc mmt$segment_descriptor_table_ex
*copyc osd$virtual_address
?? POP ??
*DECK DECK=MMP$SET_SEGMENT_ACCESS_RIGHTS EXPAND=FALSE
  PROCEDURE [XREF] mmp$set_segment_access_rights (sd: mmt$segment_descriptor;
    VAR stxe: mmt$segment_descriptor_extended);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE_EX
?? POP ??
*DECK DECK=MMP$SET_SEGMENT_LENGTH EXPAND=FALSE

  PROCEDURE [XREF] mmp$set_segment_length (pva: ^cell;
        validation_ring_number: ost$valid_ring;
        segment_length: ost$segment_length;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$SET_SEGMENT_LENGTH_R1 EXPAND=FALSE

  PROCEDURE [XREF] mmp$set_segment_length_r1
    (    segment_number: ost$segment;
         validating_ring_number: ost$valid_ring;
         segment_length: ost$segment_length;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$STORE_MANAGE_MEMORY_DATA_R1 EXPAND=FALSE

  PROCEDURE [XREF] mmp$store_manage_memory_data_r1
    (VAR queues: mmt$global_page_queue_list;
     VAR  ma_values: mmt$mmu_ma_values);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$manage_memory_utility
*copyc mmt$page_queue_list
?? POP ??
*DECK DECK=MMP$STORE_MANAGE_MEMORY_DATA_R3 EXPAND=FALSE

  PROCEDURE [XREF] mmp$store_manage_memory_data_r3
    (VAR queues: mmt$global_page_queue_list;
     VAR ma_values: mmt$mmu_ma_values;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$manage_memory_utility
*copyc mmt$page_queue_list
*copyc ost$status
?? POP ??
*DECK DECK=MMP$STORE_NEXT_PFTI EXPAND=FALSE

  PROCEDURE [INLINE] mmp$store_pfti (pfti: mmt$page_frame_index);

?? PUSH (LISTEXT := ON) ??
    mmv$pfti_array_p^.pftis [mmv$pfti_array_p^.last_pfti_index] := pfti;
    mmv$pfti_array_p^.last_pfti_index := mmv$pfti_array_p^.last_pfti_index + 1;
  PROCEND;

?? POP ??
*DECK DECK=MMP$STORE_PFTI_REVERSE EXPAND=FALSE

  PROCEDURE [INLINE] mmp$store_pfti_reverse (pfti: mmt$page_frame_index);

?? PUSH (LISTEXT := ON) ??
    mmv$pfti_array_p^.pfti_index := mmv$pfti_array_p^.pfti_first - 1;
    mmv$pfti_array_p^.pfti_first := mmv$pfti_array_p^.pfti_first - 1;
    mmv$pfti_array_p^.pftis [mmv$pfti_array_p^.pfti_first] := pfti;
  PROCEND;
?? POP ??
*DECK DECK=MMP$STORE_SEGMENT_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] mmp$store_segment_attributes (pva: ^cell;
        validation_ring_number: ost$valid_ring;
        seg_attributes: array [ * ] OF mmt$attribute_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$ATTRIBUTE_KEYWORD
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$STORE_SEGMENT_ATTRIBUTES_R1 EXPAND=FALSE

  PROCEDURE [XREF] mmp$store_segment_attributes_r1
    (    segment_number: ost$segment;
         validating_ring: ost$valid_ring;
         system_privilege: boolean;
         segment_attributes: ^array [ * ] of mmt$attribute_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$attribute_keyword
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$STORE_SITE_ACTIVE_Q_CNT_R1 EXPAND=FALSE

  PROCEDURE [XREF] mmp$store_site_active_q_cnt_r1
    (    new_site_active_queue_count: 0 .. mmc$pq_shared_num_sites;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_queue_id
*copyc ost$status
?? POP ??
*DECK DECK=MMP$STX_POINTER EXPAND=FALSE

  PROCEDURE [XREF] mmp$stx_pointer (xcb_p: ^ost$execution_control_block;
    VAR stx_p: ^mmt$segment_descriptor_table_ex);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE_EX
*copyc OST$EXECUTION_CONTROL_BLOCK
?? POP ??
*DECK DECK=MMP$SVA_PURGE_ALL_CACHE EXPAND=FALSE
  PROCEDURE [INLINE] mmp$sva_purge_all_cache (sva: ost$system_virtual_address);

    IF mmv$multiple_caches THEN
      mmp$purge_all_cache_proc;
    ELSE
      #purge_buffer (osc$sva_purge_all_cache, sva);
    IFEND;

  PROCEND;
?? PUSH (LISTEXT := ON) ??
*copyc OSC$PURGE_MAP_AND_CACHE
?? POP ??
*DECK DECK=MMP$SVA_PURGE_ALL_PAGE_MAP EXPAND=FALSE
  PROCEDURE [INLINE] mmp$sva_purge_all_page_map (sva: ost$system_virtual_address);

    IF mmv$multiple_page_maps THEN
      mmp$purge_all_map_proc;
    ELSE
      #purge_buffer (osc$sva_purge_all_page_map, sva);
    IFEND;

  PROCEND;
?? PUSH (LISTEXT := ON) ??
*copyc MMP$PURGE_ALL_MAP_PROC
*copyc OSC$PURGE_MAP_AND_CACHE
?? POP ??
*DECK DECK=MMP$SVA_PURGE_ONE_PAGE_MAP EXPAND=FALSE
  PROCEDURE [INLINE] mmp$sva_purge_one_page_map (sva: ost$system_virtual_address);

    IF mmv$multiple_page_maps THEN
      mmp$purge_all_map_proc;
    ELSE
      #purge_buffer (osc$sva_purge_one_page_map, sva);
    IFEND;

  PROCEND;
?? PUSH (LISTEXT := ON) ??
*copyc MMP$PURGE_ALL_MAP_PROC
*copyc OSC$PURGE_MAP_AND_CACHE
?? POP ??
*DECK DECK=MMP$TASK_DELETE_INHERITED_SDT EXPAND=FALSE

  PROCEDURE [XREF] mmp$task_delete_inherited_sdt
    (    task_id: pmt$task_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$TERMINATE_SHADOWING EXPAND=FALSE

  PROCEDURE [XREF] mmp$terminate_shadowing (pointer: ^cell;
         update: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??


*DECK DECK=MMP$TERMINATE_SHADOWING_R1 EXPAND=FALSE

  PROCEDURE [XREF] mmp$terminate_shadowing_r1 (segment_num: ost$segment;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??


*DECK DECK=MMP$TEST_FOR_CACHE_BYPASS EXPAND=FALSE

  PROCEDURE [INLINE] mmp$test_for_cache_bypass (p: ^cell;
    VAR cache_bypass: boolean;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
    VAR
      sdt_p: ^mmt$segment_descriptor,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_xcb (xcb_p);
    sdt_p := mmp$get_sdt_entry_p (xcb_p, #segment(p));
    cache_bypass := sdt_p^.ste.vl = osc$vl_cache_bypass;

  PROCEND mmp$test_for_cache_bypass;
*copyc mmp$get_sdt_entry_p
*copyc pmp$find_executing_task_xcb
?? POP ??
*DECK DECK=MMP$TOUCH_ALL_PAGES EXPAND=TRUE

  PROCEDURE [INLINE] mmp$touch_all_pages
    (    pages_to_touch: ^cell;
         length: ost$segment_length);

    VAR
      temp_pages_to_touch: ^array [1 .. 7fffffff(16)] of 0 .. 0ff(16),
      page_size: ost$page_size,
      referenced_byte: 0 .. 0ff(16),
      size_offset: integer;

    page_size := 512 * (128 - #READ_REGISTER (osc$pr_page_size_mask));
    temp_pages_to_touch := pages_to_touch;
    size_offset := 1;

    WHILE size_offset < length DO
      referenced_byte := temp_pages_to_touch^ [size_offset];
      size_offset := size_offset + page_size;
    WHILEND;

    referenced_byte := temp_pages_to_touch^ [length];

 PROCEND mmp$touch_all_pages;

*copyc ost$page_size
*copyc osd$virtual_address
*copyc osc$processor_defined_registers
*DECK DECK=MMP$TRIM_JOB_WORKING_SET EXPAND=FALSE

  PROCEDURE [XREF] mmp$trim_job_working_set
    (    ijle_p: ^jmt$initiated_job_list_entry;
         jcb_p: ^jmt$job_control_block;
         trim_to_swap_size: boolean );


?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
*copyc jmt$job_control_block
?? POP ??
*DECK DECK=MMP$UNLINK_PAGE_FROM_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] mmp$unlink_page_from_segment
    (    pfte_p: ^mmt$page_frame_table_entry;
         aste_p: ^mmt$active_segment_table_entry);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$active_segment_table
*copyc mmt$page_frame_table
?? POP ??
*DECK DECK=MMP$UNLOCK_PAGES EXPAND=FALSE

  PROCEDURE [XREF] mmp$unlock_pages (pva: ^cell;
        length: ost$byte_count;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$HARDWARE_SUBRANGES
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$UNLOCK_RMA_LIST EXPAND=FALSE

  PROCEDURE [XREF] mmp$unlock_rma_list (io_type: iot$io_function;
        list_p: ^mmt$rma_list;
        list_length: mmt$rma_list_length;
        io_identifier: mmt$io_identifier;
        mf_job_file: boolean;
    VAR error: iot$io_error;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc IOT$IO_FUNCTION
*copyc iot$io_error
*copyc mmt$io_identifier
*copyc MMT$RMA_LIST
*copyc SYT$MONITOR_REQUEST_CODE
?? POP ??
*DECK DECK=MMP$UNLOCK_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] mmp$unlock_segment (p: ^cell;
        page_disposition: mmt$lus_page_disposition;
        wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc MME$CONDITION_CODES
*copyc MMT$LUS_DECLARATIONS
*copyc OST$WAIT
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$UPDATE_EOI EXPAND=FALSE

  PROCEDURE [XREF] mmp$update_eoi
    (    fde_p: gft$locked_file_desc_entry_p;
         offset: ost$segment_offset;
         reason: mmt$update_eoi_reason);

?? PUSH (LISTEXT := ON) ??
*copyc gft$locked_file_desc_entry_p
*copyc mmt$update_eoi_reason
*copyc osd$virtual_address
?? POP ??
*DECK DECK=MMP$UPDATE_IOCB_COMPLETIONS EXPAND=FALSE
  PROCEDURE [XREF] mmp$update_iocb_completions (completion_table: mmt$iocb_table_array);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$io_control_block
*copyc ost$status
?? POP ??
*DECK DECK=MMP$VALIDATE_SEGMENT_NUMBER EXPAND=FALSE

  PROCEDURE [XREF] mmp$validate_segment_number
    (    segment_number: ost$segment;
     VAR sdt_entry_p: ^mmt$segment_descriptor;
     VAR sdtx_entry_p: ^mmt$segment_descriptor_extended;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE_EX
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$VERIFY_ACCESS EXPAND=FALSE

  FUNCTION [XREF] mmp$verify_access (pva: ^^cell;
        access_mode: mmt$va_access_mode): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc MMT$VA_ACCESS_MODE
?? POP ??
*DECK DECK=MMP$VERIFY_NO_SPACE_AVAILABLE EXPAND=FALSE

  PROCEDURE [XREF] mmp$verify_no_space_available
    (    process_virtual_address: ^cell;
     VAR no_space_available: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MMP$VERIFY_PVA EXPAND=FALSE
  PROCEDURE [XREF] mmp$verify_pva (pointer_to_pva: ^cell;
        access: mmt$segment_access_type;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc MMT$SEGMENT_ACCESS_TYPE
*copyc SYT$MONITOR_REQUEST_CODE
?? POP ??
*DECK DECK=MMP$VOLUME_AVAILABLE EXPAND=FALSE
PROCEDURE [XREF] mmp$volume_available;
*DECK DECK=MMP$VOLUME_UNAVAILABLE_FLAG_HDL EXPAND=FALSE
 PROCEDURE [XREF] mmp$volume_unavailable_flag_hdl (
    flag_id: ost$system_flag);

?? PUSH (LISTEXT := ON) ??
*copyc ost$system_flag
?? POP ??
*DECK DECK=MMP$WAIT_FOR_IOCB_ENTRY EXPAND=FALSE
  PROCEDURE [XREF] mmp$wait_for_iocb_entry (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=MMP$WAIT_IO_COMPLETION EXPAND=FALSE
 PROCEDURE [XREF] mmp$wait_io_completion (p: ^cell;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=MMP$WRITE EXPAND=FALSE
  PROCEDURE [XREF] mmp$write (pva: ^cell;
        length: ost$segment_length;
        remove_pages: boolean;
        iostatus_p: ^mmt$io_status;
        wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$wait
*copyc mmt$io_status
*copyc ost$status
*copyc osd$virtual_address
?? POP ??
*DECK DECK=MMP$WRITE_ALL_SEGMENTS_TO_DISK EXPAND=FALSE
  PROCEDURE [XREF] mmp$write_all_segments_to_disk (VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=MMP$WRITE_MODIFIED_PAGES EXPAND=FALSE

  PROCEDURE [XREF] mmp$write_modified_pages (pva: ^cell;
        length: ost$byte_count;
        waitopt: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$HARDWARE_SUBRANGES
*copyc OST$STATUS
*copyc OST$WAIT
?? POP ??
*DECK DECK=MMP$WRITE_PAGE_TO_DISK EXPAND=FALSE
  PROCEDURE [XREF] mmp$write_page_to_disk
    (   fde_p: gft$locked_file_desc_entry_p;
        pfti: mmt$page_frame_index;
        iotype: iot$io_function;
        io_id: mmt$io_identifier;
        multiple_page_req: boolean;
    VAR write_status: mmt$write_page_to_disk_status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$locked_file_desc_entry_p
*copyc MMT$PAGE_FRAME_INDEX
*copyc IOT$IO_FUNCTION
*copyc MMT$WRITE_PAGE_TO_DISK_STATUS
*copyc MMT$IO_IDENTIFIER
?? POP ??
*DECK DECK=MMP$XCHECK_QUEUES EXPAND=FALSE

  PROCEDURE [XREF] mmp$xcheck_queues;
  VAR
    mmv$check_queues: [XREF] integer;



*DECK DECK=MMP$XTASK_PVA_TO_SVA EXPAND=FALSE

  PROCEDURE [XREF] mmp$xtask_pva_to_sva (pva: ^cell;
    VAR sva: ost$system_virtual_address;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$HARDWARE_SUBRANGES
*copyc SYT$MONITOR_REQUEST_CODE
?? POP ??
*DECK DECK=MMT$ACCESS_SELECTIONS EXPAND=FALSE
{Define types for specifying segment access selections.

  TYPE
    mmt$access_selections = (mmc$as_none, mmc$as_sequential, mmc$as_random,
          mmc$as_read_tu);
*DECK DECK=MMT$ACTIVE_SEGMENT_TABLE EXPAND=FALSE

{ Define Active Segment Table - (AST)}

  TYPE
    mmt$active_segment_table_entry = record
      pft_link: mmt$link,
      pages_in_memory: 0 .. osc$max_page_frames,
      ijl_ordinal: jmt$ijl_ordinal,
      case in_use: boolean of
      = FALSE =
        time_freed: ost$free_running_clock,
        asid: ost$asid,        {???}
      = TRUE =
        queue_id: mmt$page_frame_queue_id,
        sfid: gft$system_file_identifier,
        include_pages_in_dump: boolean,
      casend,
    recend,

    mmt$active_segment_table = array [0 .. * ] of
      mmt$active_segment_table_entry;

*copyc gft$system_file_identifier
*copyc jmt$ijl_ordinal
*copyc mmt$link
*copyc mmt$page_frame_queue_id
*copyc ost$free_running_clock

*DECK DECK=MMT$AGE_REASON EXPAND=FALSE
{Define reasons for calling the routine that ages job working sets.

  TYPE
    mmt$age_reason = (mmc$ar_aging, mmc$ar_thrashing, mmc$ar_swapping);

*DECK DECK=MMT$AGING_STATISTICS EXPAND=FALSE
{This deck defines the record used for keeping memory manager AGING statistics.

  TYPE
    mmt$aging_statistics = record
      force_aggressive_aging: integer,
      aggressive_age_shared_queue: integer,
      aggressive_age_job_queues: integer,
      aggressive_aging_failed: integer,
      age_cp_bound_job: integer,
      remove_unmodified_page_from_ws: integer,
      remove_modified_page_from_ws: integer,
      page_written_to_disk: integer,
      multiple_pages_written_to_disk: integer,
      calls_to_age_jws: integer,
      age_exceeds_aif: integer,
      age_exceeds_aic: integer,
      age_unused_page_in_shared_queue: integer,
      age_sys_shared_queue: ARRAY [mmc$pq_shared_first .. mmc$pq_shared_last_sys] of integer,
      write_aged_out_page: integer,
      write_forced_out_page: integer,
      write_pt_full_page: integer,
      write_avail_mod_page: integer,
      write_page_failed: integer,
    recend;

*copyc mmt$page_frame_queue_id
*DECK DECK=MMT$ASID_LIST_PAGE_TABLE_FULL EXPAND=FALSE

{  Define type definition for the list of ASIDs that have caused a page table
{  full situation.

  TYPE
    mmt$asid_list_page_table_full = array [mmt$asid_list_ptf_index] of record
      asid: ost$asid,
      aste_p: ^mmt$active_segment_table_entry,
    recend,

    mmt$asid_list_ptf_index = 1 .. 33,
    mmt$max_asid_list_ptf_index = 0 .. 32;

?? PUSH (LISTEXT := ON) ??
*copyc MMT$ACTIVE_SEGMENT_TABLE
*copyc OST$HARDWARE_SUBRANGES
?? POP ??
*DECK DECK=MMT$ASSIGN_CONTIG_PASSES EXPAND=FALSE

 TYPE
   mmt$assign_contig_passes = record
     pass_one_count: integer,
     pass_two_count: integer,
     pass_three_count: integer,
   recend;
*DECK DECK=MMT$ASSIGN_CONTIG_PASS_IDENT EXPAND=FALSE

    TYPE
        mmt$assign_contig_pass_ident = (mmc$null_pass, mmc$scan_pft_for_free_or_avail,
          mmc$scan_pft_free_avail_notmod, mmc$scan_pft_write_mod_pages,
          mmc$assign_contig_adv_long_wait);
*DECK DECK=MMT$AST_INDEX EXPAND=FALSE
{Define index to AST - table used for managing ASIDs.

  TYPE
    mmt$ast_index = 0 .. 0ffff(16);
*DECK DECK=MMT$ASYNC_WORK_LIST EXPAND=FALSE
{Define record used to pass requests to the Memory Manager periodic routine

  TYPE
    mmt$async_work_list = RECORD
      reclaim_astes: boolean,
      pt_full: boolean,
      pt_full_sva: ost$system_virtual_address,
      pt_full_aste_p: ^mmt$active_segment_table_entry,
    RECEND;
*copyc OST$HARDWARE_SUBRANGES
*copyc MMT$ACTIVE_SEGMENT_TABLE
*DECK DECK=MMT$ATTRIBUTE_KEYWORD EXPAND=FALSE

{
{    Type definitions for memory management.
{
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
    mmt$attribute_keyword = (mmc$kw_null_keyword, mmc$kw_ring_numbers,
      mmc$kw_segment_number, mmc$kw_current_segment_length,
      mmc$kw_max_segment_length, mmc$kw_clear_space,
      mmc$kw_error_exit_procedure, mmc$kw_software_attributes, mmc$kw_gl_key,
      mmc$kw_preset_value, mmc$kw_segment_access_control, mmc$kw_asid,
      mmc$kw_inheritance, mmc$kw_hardware_attributes,
      mmc$kw_shadow_segment, mmc$kw_wired_segment, mmc$kw_ps_transfer_size ),

{ * * *  WARNING - mmc$kw_hardware_attributes and mmc$kw_ring_numbers
{ * * *           will be deleted. Replace with mmc$kw_access_control.


{Define the record used to describe an attribute of a segment.}

    mmt$attribute_descriptor = record
      case keyword: mmt$attribute_keyword of
      = mmc$kw_ring_numbers =
        r1: ost$ring,
        r2: ost$ring,
      = mmc$kw_segment_number =
        segnum: ost$segment,
      = mmc$kw_current_segment_length =
        current_length: ost$segment_length,
      = mmc$kw_max_segment_length =
        max_length: ost$segment_length,
      = mmc$kw_gl_key =
        gl_key: ost$key_lock,
      = mmc$kw_clear_space =
        clear_space: boolean,
      = mmc$kw_preset_value =
        preset_value: pmt$initialization_value,
      = mmc$kw_error_exit_procedure = {? ? may use conditions ? ?}
        err_exit_proc: ^procedure (pva: ^cell;
          VAR status: ost$status),
      = mmc$kw_hardware_attributes =
        hardware_attri_set: mmt$hardware_attribute_set,
      = mmc$kw_software_attributes =
        software_attri_set: mmt$software_attribute_set,
      = mmc$kw_segment_access_control =
        access_control: ost$segment_access_control,
      = mmc$kw_asid =
        asid: ost$asid,
      = mmc$kw_inheritance =
        inheritance: mmt$segment_inheritance,
      = mmc$kw_shadow_segment =
        shadow_p: ^cell,
        shadow_length: ost$segment_length,
      = mmc$kw_wired_segment =
        wired_segment_length: ost$segment_length,
        contiguous_real_memory: boolean,          {NOT SUPPORTED FOR 1.2.2}
      = mmc$kw_ps_transfer_size =
        ps_transfer_size: ost$segment_length,
      casend,
    recend;


  TYPE
    mmt$hardware_attributes = (mmc$ha_read, mmc$ha_read_key_lock,
      mmc$ha_binding, mmc$ha_write, mmc$ha_write_key_lock, mmc$ha_execute,
      mmc$ha_execute_local, mmc$ha_execute_global, mmc$ha_cache_bypass),


{  The software attributes from mmc$sa_wired to mmc$sa_stack can not be set
{  from above ring 3.

    mmt$software_attributes = (mmc$sa_wired, mmc$sa_fixed,
      mmc$sa_stack, mmc$sa_read_transfer_unit, mmc$sa_free_behind,
      mmc$sa_no_append, mmc$sa_job_shared),

    mmt$hardware_attribute_set = set of mmt$hardware_attributes,

    mmt$software_attribute_set = set of mmt$software_attributes;



{Define type declarations for specifying  pointers.}

  TYPE
    mmt$segment_pointer_kind = (mmc$cell_pointer, mmc$sequence_pointer,
      mmc$heap_pointer),

    mmt$segment_pointer = record
      case kind: mmt$segment_pointer_kind of
      = mmc$cell_pointer =
        cell_pointer: ^cell,
      = mmc$sequence_pointer =
        seq_pointer: ^SEQ ( * ),
      = mmc$heap_pointer =
        heap_pointer: ^HEAP ( * ),
      casend,
    recend;


*copyc MMT$SEGMENT_INHERITANCE
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$HARDWARE_SUBRANGES
*copyc OST$SEGMENT_ACCESS_CONTROL
*copyc OST$STATUS
*copyc PMT$INITIALIZATION_VALUE
*DECK DECK=MMT$BUFFER_DESCRIPTOR EXPAND=FALSE
{  Define the type definitions of the buffer descriptor for locking and
{  unlocking pages when doing physical io.

  TYPE
    mmt$buffer_descriptor = record
      page_count: mmt$rma_list_length,
      case buffer_descriptor_type: mmt$buffer_descriptor_type of
      = mmc$bd_paging_io, mmc$bd_explicit_io =
        sva: ost$system_virtual_address,
      = mmc$bd_job_swapping_io =
        ijl_ordinal: jmt$ijl_ordinal,
      casend,
    recend,

    mmt$buffer_descriptor_type = (mmc$bd_paging_io, mmc$bd_job_swapping_io,
      mmc$bd_explicit_io);

*copyc jmt$ijl_ordinal
*copyc MMT$RMA_LIST
*copyc OST$HARDWARE_SUBRANGES
*DECK DECK=MMT$CONTINUE_BIT_COUNT EXPAND=FALSE
  TYPE
    mmt$continue_bit_count = ARRAY [0 .. *] of 0 .. 255;
*DECK DECK=MMT$DF_CLIENT_IO_PF_STATS EXPAND=FALSE
{*copyc mmt$df_client_io_pf_stats

  TYPE
    mmt$df_client_io_pf_stats = ARRAY [mmt$file_server_io_status] OF integer;

?? PUSH (LISTEXT := ON) ??
*copyc mmt$file_server_io_status
?? POP ??
*DECK DECK=MMT$DF_CLIENT_OR_SERVER_BASED EXPAND=FALSE
{*copyc mmt$df_client_or_server_based

  TYPE
    mmt$df_client_or_server_based = (mmc$df_on_client, mmc$df_on_server);

*DECK DECK=MMT$DF_WRITE_SERVER_PF_STATS EXPAND=FALSE
{*copyc mmt$df_write_server_pf_stats

  TYPE
    mmt$df_write_server_pf_stats = ARRAY [mmt$write_modified_pages_status] OF integer;

?? PUSH (LISTEXT := ON) ??
*copyc mmt$write_modified_pages_status
?? POP ??
*DECK DECK=MMT$EOI_STATE EXPAND=FALSE

{ mmc$eoi_actual - User has made a set segment length request.
{ mmc$eoi_rounded - This is the default.  Eoi is at a page boundary.
{ mmc$eoi_uncertain - Page fault processor has assigned extra pages that
{                     may or may not have been used.  Eoi is still at the
{                     end of the page that faulted.

  TYPE
    mmt$eoi_state = (mmc$eoi_actual, mmc$eoi_rounded, mmc$eoi_uncertain);
*DECK DECK=MMT$FILE_SERVER_IO_STATUS EXPAND=FALSE
{*copyc mmt$file_server_io_status

  TYPE
    mmt$file_server_io_status = (

{ Write_Page_To_Client statuses:
{ These are the possible statuses which can be returned as
{ a result of a WRITE-to-client (ESM) by the File_Server.

          mmc$df_io_active, mmc$df_io_error, mmc$df_task_queued, mmc$df_transient_io_error,

{ Common Read, Write statuses:

          mmc$df_temp_reject_fde_locked, mmc$df_pages_not_available, mmc$df_temp_reject_queue_full,
          mmc$df_server_terminated,

{ Read_Page_From_Client statuses:
{ These are the possible statuses which can be returned as
{ a result of a READ-from-client (ESM) by the File_Server.

          mmc$df_page_in_esm, mmc$df_locked_page, mmc$df_no_memory, mmc$df_low_on_memory, mmc$df_pt_full);




*DECK DECK=MMT$IMAGE_FILE EXPAND=FALSE

TYPE

   mmt$image_file = record

     active: boolean,
     sfid: dmt$system_file_id,
     file_offset: 0 .. 0ffffffff(16),
   recend;

*copyc DMT$SYSTEM_FILE_ID
*DECK DECK=MMT$IMAGE_PAGE_DESCRIPTION EXPAND=FALSE


{ This deck defines the record that describes pages recovered from the image
{ file.

  TYPE
    mmt$image_page_description = record
      valid_desc_count: 0 .. 7ffffffff(16),
      pagesize: ost$page_size,
      page_desc: array [ * ] of mmt$page_descriptor,
    recend,

    mmt$page_descriptor = record
      image_pva: ^cell,
      file_offset: ost$segment_offset,
    recend;

*copyc osd$virtual_address
*copyc ost$hardware_subranges
*copyc ost$page_size
*DECK DECK=MMT$INT_SEGMENT_ACCESS_FAULT EXPAND=FALSE


{  Define signal content identifiers for internal segment access faults
{  detected by memory manager in monitor mode and are processed in job mode.

  CONST
    mmc$isac_fat_full = 1,
    mmc$isac_not_assigned_to_device = 2,
    mmc$isac_device_full = 3,
    mmc$isac_file_interlocked = 4,
    mmc$isac_allocate_file_space = 5;


{  Define format of signal contents for internal segment access faults detected
{  by memory manager.

  TYPE
    mmt$int_segment_access_fault = record
      identifier: pmt$signal_id,
      segment_number: ost$segment,
      offset: ost$segment_offset,
      task_id: ost$global_task_id,
      sfid: dmt$system_file_id,
      chapter: dmt$chapter_number,
    recend;

*copyc MMD$SEGMENT_ACCESS_CONDITION
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$GLOBAL_TASK_ID
*copyc PMT$SIGNAL
*copyc DMT$SYSTEM_FILE_ID
*copyc DMT$CHAPTER_NUMBER
*DECK DECK=MMT$IOCB_INDEX EXPAND=FALSE

{ This type defines the indices for the I/O control block table used for
{ asynchronous I/O.  NOTE: an index of 0 indicates the I/O is synchronous.
{ For synchronous I/O, the I/O request status is returned in the request
{ block, rather than the iocb table.

  TYPE
    mmt$iocb_index = 0 .. mmc$iocb_table_size;

*copyc mmc$iocb_table_size
*DECK DECK=MMT$IO_CONTROL_BLOCK EXPAND=FALSE

  TYPE
    mmt$io_control_block = record
      latest_completion_time: integer,
      maximum_iocb_index_in_use: mmt$iocb_index,
      wait_for_any_completion: boolean,
      iocb_table: mmt$iocb_table_array,
    recend,

{ The iocb_table array starts at 1 rather than 0.  An iocb_index of 0 indicates synchronous
{ io, so the iocb table would not be used.

    mmt$iocb_table_array= array [1 .. mmc$iocb_table_size] of mmt$iocb_table_entry,

    mmt$iocb_table_entry = record
      pva: ^cell,
      length: ost$segment_length,
      sub_reqcode: mmt$sub_reqcodes,
      iostatus_p: ^mmt$io_status,
      active_io_count: mmt$active_io_count,
      condition: ost$status_condition,
      used_for_asynchronous_io: boolean,
      io_already_active: boolean,
    recend;

*copyc mmt$io_status
*copyc mmt$io_identifier
*copyc mmt$iocb_index
*copyc mmt$rb_memory_manager_io
*copyc osd$virtual_address
*DECK DECK=MMT$IO_IDENTIFIER EXPAND=FALSE
{ Xref deck - mmt$io_identifier.

  TYPE
    mmt$io_identifier = RECORD
      specified: boolean,
      CASE io_function: iot$io_function OF
      = ioc$swap_in, ioc$swap_out =
        ijl_ordinal: jmt$ijl_ordinal,
      = ioc$read_page, ioc$write_page =
        taskid: ost$global_task_id,
        iocb_index: mmt$iocb_index,
      = ioc$read_for_server, ioc$write_for_server,
        ioc$read_from_client, ioc$write_to_client,
        ioc$allocate =
        queue_entry_location: dft$queue_entry_location,
      = ioc$read_ahead_on_server =
        read_ahead_iocb_index: mmt$iocb_index,
      CASEND,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc dft$queue_entry_location
*copyc iot$io_function
*copyc jmt$ijl_ordinal
*copyc mmt$iocb_index
*copyc ost$global_task_id
?? POP ??
*DECK DECK=MMT$IO_STATUS EXPAND=FALSE
  TYPE
    mmt$io_status = RECORD
      case request_status: mmt$io_request_status of
      =mmc$irs_none,mmc$irs_active=,
      =mmc$irs_complete=
      condition: ost$status_condition,
      casend,
    RECEND,

    mmt$io_request_status = (mmc$irs_none, mmc$irs_active, mmc$irs_complete),

    mmt$io_status_pointer_array = ARRAY [1 .. *] of ^mmt$io_status;

*copyc ost$status
*DECK DECK=MMT$IO_TYPE EXPAND=FALSE
{Define the ordinal list that defines the type of IO taking place into
{a page frame.

  TYPE
    mmt$io_type = (mmc$it_none, mmc$it_explicit_input, mmc$it_explicit_output,
      mmc$it_implicit_input, mmc$it_implicit_output, mmc$it_swap_out, mmc$it_swap_in);
*DECK DECK=MMT$KEYPOINT_PAGE_FAULT_STATUS EXPAND=FALSE

  TYPE
    mmt$keypoint_page_fault_status = (mmc$kpfs_normal,
          mmc$kpfs_disable_keypoints, mmc$kpfs_invalid_keypoint);

*DECK DECK=MMT$LINK EXPAND=FALSE

{Define types for managing the circular lists that link PFT entries}
{together.}

  TYPE
    mmt$link = record
      bkw,
      fwd: mmt$page_frame_index,
    recend;

*copyc MMT$PAGE_FRAME_INDEX
*DECK DECK=MMT$LOCKED_PAGE EXPAND=FALSE


{  Type definition for locked page types.

  TYPE
    mmt$locked_page = (mmc$lp_not_locked, mmc$lp_aging_lock,
      mmc$lp_write_protected_lock, mmc$lp_page_in_lock,
      mmc$lp_server_allocate_lock);
*DECK DECK=MMT$LOCK_SEGMENT_STATUS EXPAND=FALSE

    TYPE
      mmt$lock_segment_status = (mmc$lss_none, mmc$lss_queued_for_lock_user, mmc$lss_queued_for_lock_r3,
              mmc$lss_lock_for_read_user, mmc$lss_lock_for_read_r3, mmc$lss_lock_for_write_user,
              mmc$lss_lock_for_write_r3);
*DECK DECK=MMT$LUS_DECLARATIONS EXPAND=FALSE

{ This decks defines type for the mmp$lock_segment and  mmp$unlock_segment
{ requests.
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
    mmt$lus_lock_type = (mmc$lus_no_lock, mmc$lus_lock_for_read,
          mmc$lus_lock_for_write),
    mmt$lus_page_disposition = (mmc$lus_none, mmc$lus_protected_write,
          mmc$lus_write, mmc$lus_remove_from_working_set, mmc$lus_free);

*DECK DECK=MMT$MAINFRAME_WIRED_ASID EXPAND=FALSE

  TYPE
    mmt$mainframe_wired_asid = record
      current: ost$asid,
      new: ost$asid,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ost$hardware_subranges
?? POP ??
*DECK DECK=MMT$MAKE_PT_ENTRY_STATUS EXPAND=FALSE
{Define status values for mmp$make_pt_entry.

  TYPE
    mmt$make_pt_entry_status = (mmc$mpt_done, mmc$mpt_page_table_full,
      mmc$mpt_page_already_exists);
*DECK DECK=MMT$MANAGE_MEMORY_UTILITY EXPAND=FALSE

{  This deck mmt$manage_memory_utility contains types defined for the Manage Memory Utility.

  TYPE
    mmt$manage_memory_utility = RECORD
      gpql: mmt$mmu_gpql_default,
      ma: mmt$mmu_ma_data,
    RECEND,

    mmt$mmu_gpql_default = mmt$global_page_queue_list,

    mmt$mmu_ma_data = ARRAY [mmt$mmu_memory_attributes] of mmt$mmu_ma_info,

    mmt$mmu_ma_default = ARRAY [mmt$mmu_memory_attributes] OF integer,

    mmt$mmu_ma_info = RECORD
      default: integer,
      CASE value_type: mmt$mmu_value_types OF
      = mmc$mmu_mvt_integer =
        integer_p: ^integer,
      = mmc$mmu_mvt_byte =
        byte_p: ^0 .. 255,
      CASEND,
    RECEND,

    mmt$mmu_ma_values  = ARRAY [mmt$mmu_memory_attributes] OF integer,

    mmt$mmu_memory_attributes = (mmc$mmu_ma_aic, mmc$mmu_ma_aif, mmc$mmu_ma_aal, mmc$mmu_ma_aal2,
          mmc$mmu_ma_aa, mmc$mmu_ma_amqm, mmc$mmu_ma_jwsai, mmc$mmu_ma_minap, mmc$mmu_ma_psrl, mmc$mmu_ma_psr,
          mmc$mmu_ma_psp, mmc$mmu_ma_pst, mmc$mmu_ma_psts, mmc$mmu_ma_pci, mmc$mmu_ma_swsai, mmc$mmu_ma_sa,
          mmc$mmu_ma_tt),

    mmt$mmu_value_types = (mmc$mmu_mvt_integer, mmc$mmu_mvt_byte);

*copyc mmt$page_queue_list
*DECK DECK=MMT$MEMORY_RESERVE_REQUEST EXPAND=FALSE

  TYPE
    mmt$memory_reserve_request = RECORD
      swapout_job: boolean,
      requested_page_count: mmt$page_frame_index,
      reserved_page_count: mmt$page_frame_index,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_index
?? POP ??
*DECK DECK=MMT$MODIFIED_BIT_OPTION EXPAND=FALSE

  TYPE
    mmt$modified_bit_option = (mmc$mp_set_modified, mmc$mp_clear_modified,
          mmc$mp_no_change_to_modified);

*DECK DECK=MMT$MOVE_PAGES_PAGE_COUNT EXPAND=FALSE

  TYPE
    mmt$move_pages_page_count = 0..32;

*DECK DECK=MMT$OLD_MODIFIED_BITS EXPAND=FALSE

  TYPE
    mmt$old_modified_bits = packed  array [0 .. *] of boolean;

*DECK DECK=MMT$PAGE_FRAME_INDEX EXPAND=FALSE

  { osc$max_page_frames_32 and mmt$page_frame_index_32 have been created to allow for
  { a 32 bit index.  When the code is added to move all indices to 32 bits change the
  { references to the _32 type declarations.

  CONST
    osc$max_page_frames_32 = 0ffffffff(16);

  TYPE
    mmt$page_frame_index = 0 .. osc$max_page_frames - 1,

    mmt$page_frame_index_32 = 0 .. osc$max_page_frames_32 - 1;

*copyc ost$page_table
*DECK DECK=MMT$PAGE_FRAME_QUEUE_ID EXPAND=FALSE

{ Define queue ids for the threads that run thru the Page Frame Table.}
{ NOTE:  There are places in memory manager--mmp$process_assign_pages for one--
{ that assumes that if a page table entry is NOT VALID, the page is in either
{ the available or available modified queue ONLY.  If there are other queues
{ added that can have non-valid pages, memory manager must be changed.


  CONST
    mmc$pq_free = 0,
    mmc$pq_avail = 1,
    mmc$pq_avail_modified = 2,
    mmc$pq_wired = 3,

    mmc$pq_shared_task_service   = 4,
    mmc$pq_shared_pf_execute     = 5,
    mmc$pq_shared_pf_non_execute = 6,
    mmc$pq_shared_device_file    = 7,
    mmc$pq_shared_file_server    = 8,
    mmc$pq_shared_other          = 9,

    mmc$pq_shared_site_01        = 10,
    mmc$pq_shared_site_02        = 11,
    mmc$pq_shared_site_03        = 12,
    mmc$pq_shared_site_04        = 13,
    mmc$pq_shared_site_05        = 14,
    mmc$pq_shared_site_06        = 15,
    mmc$pq_shared_site_07        = 16,
    mmc$pq_shared_site_08        = 17,
    mmc$pq_shared_site_09        = 18,
    mmc$pq_shared_site_10        = 19,
    mmc$pq_shared_site_11        = 20,
    mmc$pq_shared_site_12        = 21,
    mmc$pq_shared_site_13        = 22,
    mmc$pq_shared_site_14        = 23,
    mmc$pq_shared_site_15        = 24,
    mmc$pq_shared_site_16        = 25,
    mmc$pq_shared_site_17        = 26,
    mmc$pq_shared_site_18        = 27,
    mmc$pq_shared_site_19        = 28,
    mmc$pq_shared_site_20        = 29,
    mmc$pq_shared_site_21        = 30,
    mmc$pq_shared_site_22        = 31,
    mmc$pq_shared_site_23        = 32,
    mmc$pq_shared_site_24        = 33,
    mmc$pq_shared_site_25        = 34,

    mmc$pq_shared_io_error       = 35,
    mmc$pq_swapped_io_error      = 36,
    mmc$pq_flawed                = 37,

    mmc$pq_job_fixed             = 38,
    mmc$pq_job_io_error          = 39,
    mmc$pq_job_working_set       = 40,


    mmc$pq_first_valid_in_pt = mmc$pq_wired,
    mmc$pq_last_reassignable = mmc$pq_avail,
    mmc$pq_job_base = mmc$pq_job_fixed,
    mmc$pq_shared_first     = mmc$pq_shared_task_service,
    mmc$pq_shared_last_sys  = mmc$pq_shared_other,
    mmc$pq_shared_first_site= mmc$pq_shared_site_01,
    mmc$pq_shared_num_sites = 25,
                {Warning, coding assumes that there is at least one site queue}
    mmc$pq_shared_last_site = mmc$pq_shared_first_site
      + mmc$pq_shared_num_sites -1,
    mmc$pq_shared_last      = mmc$pq_shared_site_25;

  TYPE
    mmt$global_page_queue_index = mmc$pq_free .. mmc$pq_flawed,
    mmt$job_page_queue_index = mmc$pq_job_fixed .. mmc$pq_job_working_set,
    mmt$page_frame_queue_id = 0 .. mmc$pq_job_working_set;

*DECK DECK=MMT$PAGE_FRAME_TABLE EXPAND=FALSE
{Page Frame Table. This table is used to:}
{      . manage assignment of free pages}
{      . maintain threads for page aging}

  TYPE
    mmt$page_frame_table_entry = record
      link:  mmt$link,
      segment_link: mmt$link,
      cyclic_age: 0 .. 255,
      ijl_ordinal: jmt$ijl_ordinal,
      queue_id: mmt$page_frame_queue_id,
      active_io_count: 0 .. 0ff(16),
      locked_page: mmt$locked_page,
      pti: ost$page_table_index,
      task_queue: tmt$task_queue_link,
      age: 0 .. 255,
      flawed: boolean,
      aste_p: ^mmt$active_segment_table_entry,
      io_error: iot$io_error,
      sva:  ost$system_virtual_address,
    recend,

    mmt$page_frame_table = array [ * ] of mmt$page_frame_table_entry;

*copyc MMT$LINK
*copyc MMT$LOCKED_PAGE
*copyc OST$PAGE_TABLE
*copyc OST$HARDWARE_SUBRANGES
*copyc MMT$ACTIVE_SEGMENT_TABLE
*copyc TMT$TASK_QUEUE_LINK
*copyc MMT$PAGE_FRAME_QUEUE_ID
*copyc jmt$ijl_ordinal
*copyc iot$io_error

*DECK DECK=MMT$PAGE_MAP_OFFSETS EXPAND=FALSE
{ Define ordinal type for indexing into the segment offset array.  This array
{ defines byte offsets for beginning of some special segments. These segments do NOT start at
{ offset zero. This is an attempt to reduce thrashing in the page map.

  TYPE
    mmt$page_map_offsets_ord = (mmc$pmo_binding_segment, mmc$pmo_user_stack,
         mmc$pmo_r3_stack, mmc$pmo_r2_stack, mmc$pmo_r1_stack),

    mmt$page_map_offsets =  array [mmt$page_map_offsets_ord] of 0 .. 255;

{ The following constant defines the byte offset in a stack segment for the space reserved
{ for the stack frame save area used by pmp$call_ring_crossing_proc.

{ NOTE: Any changes to the value of this constant must be reflected in the following assembly
{       language decks:
{            SYM$CORE_TRAP_HANDLER
{            SYM$JOB_FIXED_TEMPLATE
{            PMM$TASKING_HELPER_PROCEDURES

  CONST
    mmc$ring_crossing_offset = 28(16);
*DECK DECK=MMT$PAGE_PULL_STATUS EXPAND=FALSE

{ Do not change ordinal values 0 thru 10.  They are checked by DVS.  Put in a filler if they are no
{ longer used; add new status to the end.  Modify mmk$monitor_mode_keypoints and the comment at
{ the beginning of mmp$page_pull in mmm$page_fault processor if any changes are made.

  TYPE
    mmt$page_pull_status = (ps_done, ps_found_in_avail, ps_found_in_avail_modified, ps_valid_in_pt,
      ps_no_memory, ps_low_on_memory, ps_locked, ps_found_on_disk, ps_pt_full, ps_io_temp_reject,
      ps_new_page_assigned, ps_beyond_file_limit, ps_read_beyond_eoi, ps_no_extend_permission,
      ps_volume_unavailable, ps_found_on_server, ps_allocate_required_on_server, ps_server_terminated,
      ps_job_work_required, ps_runaway_write);
*DECK DECK=MMT$PAGE_QUEUE_LIST EXPAND=FALSE

{  This deck (mmt$page_queue_list) defines the page queue list entry that
{  contains the heads of the chains that run thru the Page Frame Table.}
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
    mmt$page_queue_list_entry = record
      link: mmt$link,
      count: 0 .. osc$max_page_frames,
    recend,
    mmt$global_page_queue_list_ent = record
      pqle : mmt$page_queue_list_entry,
      age_interval: 0 .. 255,
      minimum : 0 .. 7fffffff(16),  {temporary definition so that SETSA can set this value
      maximum : 0 .. osc$max_page_frames,
    recend,


{Define the global and local page queue lists.

    mmt$global_page_queue_list = array [mmt$global_page_queue_index] of mmt$global_page_queue_list_ent,
    mmt$job_page_queue_list = array [mmt$job_page_queue_index] of mmt$page_queue_list_entry;

*copyc OST$HARDWARE_SUBRANGES
*copyc MMT$LINK
*copyc OST$PAGE_TABLE
*copyc mmt$page_frame_queue_id
*DECK DECK=MMT$PAGE_QUEUE_SET EXPAND=FALSE

  TYPE
    mmt$page_queue_set = SET OF mmt$page_frame_queue_id;

*copyc mmt$page_frame_queue_id
*DECK DECK=MMT$PAGE_Q_COUNTS EXPAND=FALSE

{ If the following type must be expanded, make sure the ARRAY is the last field in the record.

  TYPE
    mmt$page_q_counts = RECORD
      long_wait_count: 0 .. 0ffffffff(16),
      swap_resident_count: 0 .. 0ffffffff(16),
      site_defined_queues_active: 0..255,
      q_counts: ARRAY [mmt$page_frame_queue_id] OF 0 .. 0ffffffff(16),
    RECEND;
?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_queue_id
?? POP ??
*DECK DECK=MMT$PAGE_SELECTION_CRITERIA EXPAND=FALSE
{Define ordinal type used in MMP$INITIALIZE_FIND_NEXT_PFTI.

  TYPE
    mmt$page_selection_criteria = (psc_nominal_queue, psc_all_except_avail, psc_all);

*DECK DECK=MMT$PAGE_STREAMING_STATISTICS EXPAND=FALSE

{ Deck mmt$page_streaming_statistics defines stats for page streaming process within the page fault process.
{ When displayed or placed in a statistic, the number of counters is increased by one by creating an
{ additional value "prestream mode initiated" which equals the sum of initiated + prestream_only.

  TYPE
    mmt$page_streaming_statistics =  RECORD
        initiated: integer,
        prestream_only: integer,
        terminated: integer,
        pages_prestream: integer,
        pages_streaming: integer,
        task_slow: integer,
        page_faults_tu: integer,
        pages_freed_behind: integer,
        random_faults: integer,
      RECEND;

{ This constant is the number of integers in the record.  It is used by clm$display_system_data.
{ and in mmt$paging_statistics.

  CONST   mmc$page_streaming_counters = 9;

*DECK DECK=MMT$PAGING_STATISTICS EXPAND=FALSE

{ Deck mmt$paging_statistics defines stats for the source of pages acquired via normal page faults,
{ page streaming, and advise_in requests.  Additional stats track the page streaming processes.

  TYPE
    mmt$paging_statistics =  RECORD
      pf_pages: mmt$paging_statistics_source,  {source of pages initiated via nominal page faults
      ps_pages: mmt$paging_statistics_source,  {source of pages initiated via page streaming
      ai_pages: mmt$paging_statistics_source,  {source of pages initiated via advise_in
      page_streaming: mmt$page_streaming_statistics,
    RECEND,

    mmt$paging_statistics_source = RECORD
      disk: integer,
      reclaim: integer,
      new: integer,
      server: integer,
    RECEND;

{ Constant below is used in osm$emit_os_statistics to determine length of OS9014 statistic.

  CONST   mmc$paging_statistics_counters = (4 * 3) + mmc$page_streaming_counters;
?? PUSH (LISTEXT := ON) ??
*copyc MMT$PAGE_STREAMING_STATISTICS
?? POP ??

*DECK DECK=MMT$PFTI_ARRAY EXPAND=FALSE


  TYPE
    mmt$pfti_array = RECORD
      pfti_first: 0 .. osc$max_page_frames,
      pfti_index: 0 .. osc$max_page_frames,
      last_pfti_index: 0 .. osc$max_page_frames,
      pftis: ARRAY [0 .. *] of mmt$page_frame_index,
    RECEND;
*copyc mmt$page_frame_index
*DECK DECK=MMT$PF_STATISTICS EXPAND=FALSE

  TYPE
    mmt$pf_statistics = array [0 .. 18] of integer;
*DECK DECK=MMT$PT_FULL_STATUS EXPAND=FALSE
{Define status values for MMP$PROCESS_PAGE_TABLE_FULL.

  TYPE
    mmt$pt_full_status = (mmc$pfs_failed, mmc$pfs_entries_freed,
        mmc$pfs_asid_reassigned, mmc$pfs_input_asid_reassigned);

*DECK DECK=MMT$RB_ADVISE EXPAND=FALSE

  TYPE
    mmt$rb_advise = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      out_pva: ^cell,
      out_length: ost$segment_length,
      in_pva: ^cell,
      in_length: ost$segment_length,
    recend;

*copyc OSD$VIRTUAL_ADDRESS
*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*DECK DECK=MMT$RB_ASSIGN_CONTIG_MEMORY EXPAND=FALSE

 TYPE
   mmt$rb_assign_contig_memory = record
     request_code: ALIGNED [0 MOD 8] syt$monitor_request_code,
     status: syt$monitor_status,
     process_virtual_address: ^cell,
     pass_count: mmt$assign_contig_pass_ident,
     requested_length: ost$segment_length,
   recend;

*copyc mmt$assign_contig_pass_ident
*copyc osd$virtual_address
*copyc syt$monitor_status
*copyc syt$monitor_request_code
*copyc syc$monitor_request_codes
*DECK DECK=MMT$RB_ASSIGN_FLAWED_MEMORY EXPAND=FALSE

  TYPE
    mmt$rb_assign_flawed_memory = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      pva: ^cell,
    recend;

*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*DECK DECK=MMT$RB_ASSIGN_PAGES EXPAND=FALSE

  TYPE
    mmt$rb_assign_pages = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      case sub_reqcode: mmt$assign_sub_reqcodes of
      = mmc$aprc_assign =
        pva: ^cell,
        length: ost$segment_length,
        preset_pages: boolean,
        waitopt: ost$wait,
      = mmc$aprc_cancel_reserve =
        ,
      casend,
    recend,

    mmt$assign_sub_reqcodes = (mmc$aprc_assign, mmc$aprc_cancel_reserve);


*copyc syt$monitor_request_code
*copyc syc$monitor_request_codes
*copyc syt$monitor_status
*copyc osd$virtual_address
*copyc ost$wait

*DECK DECK=MMT$RB_ASSIGN_REAL_PAGE EXPAND=FALSE

  TYPE
    mmt$rb_assign_real_page = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      pva: ^cell,
      rma: ost$real_memory_address,
    recend;

*copyc OST$HARDWARE_SUBRANGES
*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*DECK DECK=MMT$RB_CHANGE_SEGMENT_TABLE EXPAND=FALSE


{  Define type definition for change segment table monitor request block.

  TYPE
    mmt$rb_change_segment_table = record
      request_code: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      new_sdt_offset: 0 .. 0ffffffff(16),
      new_sdtx_offset: 0 .. 0ffffffff(16),
      new_sdt_length: ost$segment,
    recend;

*copyc SYT$MONITOR_REQUEST_CODE
*DECK DECK=MMT$RB_FETCH_OFFSET_MOD_PAGES EXPAND=FALSE

{  Defines type definition for 'mmp$mtr_fetch_offset_mod_pages' request block.
{    The fields that should be initialized by the caller are:
{  'reqcode', 'status'and  'pva'. Offsets_returned should be the size of the
{  callers array to receive the offsets list.
{    Monitor will check the number of offsets against the allocated size of
{  the callers array. If the array is not large enough the offsets_returned
{  field is updated and returned.
{    On completion the offset_list will hold all the offsets for the modified
{  pages for the given segment and the offsets_returned filed will hold the
{  number of offsets returned in the list.
{    The offset list returned has no particular order.

  TYPE
    mmt$rb_fetch_offset_mod_pages = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      sfid: gft$system_file_identifier,
      offsets_returned: integer,
      offset_list: ^array [ 1 .. * ] of ost$segment_offset,
      return_unallocated_offsets: boolean,
    recend;

*copyc GFT$SYSTEM_FILE_IDENTIFIER
*copyc OST$HARDWARE_SUBRANGES
*copyc SYC$MONITOR_REQUEST_CODES
*copyc SYT$MONITOR_REQUEST_CODE


*DECK DECK=MMT$RB_FETCH_PVA_UNWRITTEN_PGS EXPAND=FALSE


{  Define type definition for 'mmp$mtr_fetch_pva_unwritten_pgs' request block.
{  Because this request may not be completed in one call (offset_list filled)
{  it is necessary for monitor to store information in request block of
{  position in returning entries for subsequent calls.  The fields that should
{  be initialized by the caller are: 'reqcode', 'status', 'pva',
{  'starting_with_first_page' and 'subsequent_request_for_same_pva'.  The
{  'next_offset_to_return' and 'offset_list_overflow' fields should not be
{  set by caller, expecially on a subsequent call.  Monitor sets
{  'subsequent_request_for_same_pva' to TRUE if it is set FALSE, none of the
{  other input fields are modified by monitor.  The offset list returned has
{  no particular order.

  TYPE
    mmt$rb_fetch_pva_unwritten_pgs = record
      reqcode {input} : ALIGNED [0 MOD 8] syt$monitor_request_code,
      status {output} : syt$monitor_status,
      pva {input} : ^cell,
      starting_with_first_page {input} : boolean,
      subsequent_request_for_same_pva {input, output, input} : boolean,
      next_offset_to_return {output, input} : ost$byte_count,
      offset_list_overflow {output} : boolean,
      offsets_returned {output} : 0 .. 6,
      offset_list {output} : array [1 .. 6] of ost$byte_count,
    recend;

*copyc OST$HARDWARE_SUBRANGES
*copyc SYC$MONITOR_REQUEST_CODES
*copyc SYT$MONITOR_REQUEST_CODE
*DECK DECK=MMT$RB_FLAW_PAGE EXPAND=FALSE

  TYPE
    mmt$rb_flaw_page = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      rma: ost$real_memory_address,
    recend;

*copyc OST$HARDWARE_SUBRANGES
*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*DECK DECK=MMT$RB_FREE_FLUSH EXPAND=FALSE

{Init_new_io is set to true in job mode and cleared in monitor before
{a reissue of the monitor request if wait is true.  This is to prevent
{mmp$mm_write_modified_pages from initiating new writes.

  TYPE
    mmt$rb_free_flush = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      pva: ^cell,
      length: ost$segment_length,
      waitopt: ost$wait,
      init_new_io: boolean,               {Used only for write_modified_pages processing.}
    recend;

*copyc SYT$MONITOR_REQUEST_CODE
*copyc OST$WAIT
*copyc SYC$MONITOR_REQUEST_CODES
*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=MMT$RB_IDLE_SYSTEM EXPAND=FALSE

  TYPE
    mmt$rb_idle_system = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      idle_code: syt$180_idle_code,
      error_message: dpt$top_line_message,
    recend;

*copyc dpt$top_line_message
*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYT$180_IDLE_CODE
*copyc SYC$MONITOR_REQUEST_CODES

*DECK DECK=MMT$RB_LOCK_RING_1_STACK EXPAND=FALSE

{ Define the type definition for the monitor request to change the calling job's
{ ring 1 stack to a transient segment during job termination.

  TYPE
    mmt$rb_lock_ring_1_stack = record
      request_code: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      disk_file_descriptor_offset: ost$valid_relative_pointer,
    recend;

*copyc osd$virtual_address
*copyc syc$monitor_request_codes
*copyc syt$monitor_request_code
*DECK DECK=MMT$RB_LOCK_UNLOCK_PAGES EXPAND=FALSE


{  Define type definition for lock/unlock pages request block.

  TYPE
    mmt$rb_lock_unlock_pages = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      lock_page_type: mmt$locked_page,
      pva: ^cell,
      length: ost$byte_count,
    recend;

*copyc MMT$LOCKED_PAGE
*copyc OST$HARDWARE_SUBRANGES
*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*DECK DECK=MMT$RB_LOCK_UNLOCK_SEGMENT EXPAND=FALSE

{The following defines the request block for issuing lock/unlock segment
{requests to memory manager.

{Init_new_io is set to true in job mode and cleared in monitor before
{a reissue of the monitor request if wait is true.  This is to prevent
{mmp$mm_write_modified_pages from initiating new writes.

  TYPE
    mmt$rb_lock_unlock_segment = RECORD
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      pva: ^cell,
      wait: ost$wait,
      init_new_io: boolean,                   {Used only for write_modified_pages processing.}
      CASE request: (mmc$lus_lock_segment, mmc$lus_unlock_segment) OF
      = mmc$lus_lock_segment =
        access: mmt$lus_lock_type,
        catalog_segment: boolean,
      = mmc$lus_unlock_segment =
        page_disposition: mmt$lus_page_disposition,
      CASEND,
    RECEND;

*copyc MMT$LUS_DECLARATIONS
*copyc OST$WAIT
*copyc SYC$MONITOR_REQUEST_CODES
*copyc SYT$MONITOR_REQUEST_CODE
*DECK DECK=MMT$RB_MEMORY_MANAGER_IO EXPAND=FALSE

{Init_new_io is set to true in job mode and cleared in monitor before
{a reissue of the monitor request if wait is true.  This is to prevent
{mmp$mm_write_modified_pages from initiating new writes.

  TYPE
    mmt$rb_memory_manager_io = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      pva: ^cell,
      length: ost$segment_length,
      stat_p: ^mmt$io_status,
      waitopt: ost$wait,
      condition: ost$status_condition,
      active_io_count: mmt$active_io_count,
      init_new_io: boolean,                          {Used only for write_modified_pages processing.}
      case sub_reqcode: mmt$sub_reqcodes of
      = mmc$iorc_write_pages =
        remove_pages: boolean,
      = mmc$iorc_await_io_completion =
        latest_completion_time: integer,
        wait_time: integer,
      casend,
    recend,

    mmt$active_io_count = 0 .. 32,
    mmt$sub_reqcodes = (mmc$iorc_read_pages, mmc$iorc_write_pages, mmc$iorc_await_io_completion);

*copyc syt$monitor_request_code
*copyc syc$monitor_request_codes
*copyc syt$monitor_status
*copyc osd$virtual_address
*copyc ost$wait
*copyc mmt$io_status
*copyc ost$status

*DECK DECK=MMT$RB_MOVE_PAGES EXPAND=FALSE

  TYPE
     mmt$rb_move_pages = record
       reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
       status: syt$monitor_status,
       pva_source: ^cell,
       pva_destination: ^cell,
       length: ost$segment_length,
       modified_bit_option: mmt$modified_bit_option,
       reject_move_if_source_modified: boolean,
       moved_modified_page_count: mmt$move_pages_page_count,
       number_of_pages_moved: mmt$move_pages_page_count,
     recend;

*copyc mmt$modified_bit_option
*copyc mmt$move_pages_page_count
*copyc osd$virtual_address
*copyc ost$status
*copyc syc$monitor_request_codes
*copyc syt$monitor_status

*DECK DECK=MMT$RB_RING1_SEGMENT_REQUEST EXPAND=FALSE

{Init_new_io is set to true in job mode and cleared in monitor before
{a reissue of the monitor request if wait is true.  This is to prevent
{mmp$mm_write_modified_pages from initiating new writes.

  TYPE
    mmt$rb_ring1_segment_request = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      wait_for_io_complete: boolean, {Used only on FLUSH requests.}
      io_active: boolean,            {OUTPUT parameter - returned only on FLUSH requests.}
      init_new_io: boolean,          {Used only for write_modified_pages processing.}
      case request: (mmc$sr1_delete_seg_segnum,
                     mmc$sr1_delete_seg_sfid,
                     mmc$sr1_free_image_pages,
                     mmc$sr1_commit_memory,
                     mmc$sr1_detach_file,
                     mmc$sr1_flush_delete_seg_sfid,
                     mmc$sr1_flush_seg_segnum,
                     mmc$sr1_replace_sfid,
                     mmc$sr1_end_job_recovery,
                     mmc$sr1_make_mfw_cache,
                     mmc$sr1_remove_job_shared_pages,
                     mmc$sr1_change_swap_file_queue,
                     mmc$sr1_get_highest_offset,
                     mmc$sr1_delete_job_seg_by_sfid,
                     mmc$sr1_remove_detached_pages,
                     mmc$sr1_flush_avail_modified,
                     mmc$sr1_share_global_logs) OF

      = mmc$sr1_delete_seg_sfid, mmc$sr1_detach_file, mmc$sr1_flush_delete_seg_sfid,
            mmc$sr1_flush_seg_segnum, mmc$sr1_change_swap_file_queue,
            mmc$sr1_delete_job_seg_by_sfid, mmc$sr1_remove_detached_pages,
            mmc$sr1_flush_avail_modified =
        sfid: dmt$system_file_id,
      = mmc$sr1_delete_seg_segnum =
        segnum: ost$segment,
      = mmc$sr1_replace_sfid =
        old_sfid: dmt$system_file_id,
        new_sfid: dmt$system_file_id,
        asti: mmt$ast_index,
      = mmc$sr1_end_job_recovery =
        unrecovered_pages: integer,
        unrecovered_files: integer,
      = mmc$sr1_make_mfw_cache =
        ,
      = mmc$sr1_remove_job_shared_pages, mmc$sr1_share_global_logs =
        system_file_id: dmt$system_file_id,
        segment_number: ost$segment,
        server_file: boolean,
      = mmc$sr1_get_highest_offset =
        file_sfid: dmt$system_file_id,
        highest_offset: amt$file_byte_address,
      casend,
    recend;

*copyc amt$file_byte_address
*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*copyc DMT$SYSTEM_FILE_ID
*copyc mmt$ast_index
*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=MMT$RB_RING1_SERVER_SEG_REQUEST EXPAND=FALSE

  TYPE
    mmt$rb_ring1_server_seg_request = RECORD
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      sfid: gft$system_file_identifier,
      CASE request: mmt$server_segment_request OF
      = mmc$ssr1_free_delete_seg_sfid, mmc$ssr1_flush_delete_seg_sfid =
        pages_not_deleted: integer,
      = mmc$ssr1_move_modified_df_page =
        destination_pva: ^cell,                  {input}
        byte_offset: ost$segment_offset,         {output}
        status: syt$monitor_status,              {output}
      CASEND,
    RECEND;

  TYPE
    mmt$server_segment_request = (mmc$ssr1_free_delete_seg_sfid, mmc$ssr1_flush_delete_seg_sfid,
          mmc$ssr1_move_modified_df_page);

*copyc gft$system_file_identifier
*copyc osd$virtual_address
*copyc syc$monitor_request_codes
*copyc syt$monitor_status
*DECK DECK=MMT$RB_SEGMENT_REQUEST EXPAND=FALSE
{Request block for issuing miscellaneous segment/memory manager requests
{for a segment.

  TYPE
    mmt$monitor_segment_request = (mmc$sr_null, mmc$sr_assign_file_to_disk,
      mmc$sr_fetch_max_ws_size, mmc$sr_store_max_ws_size,
      mmc$sr_complete_seg_sft_entry,
      mmc$sr_fetch_min_ws_size, mmc$sr_store_min_ws_size,
      mmc$sr_fetch_page_aging_int, mmc$sr_store_page_aging_int,
      mmc$sr_fetch_cyclic_aging_int, mmc$sr_store_cyclic_aging_int),

    mmt$rb_segment_request = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      case request: mmt$monitor_segment_request of
      = mmc$sr_assign_file_to_disk, mmc$sr_complete_seg_sft_entry =
        segnum: ost$segment,
      = mmc$sr_fetch_max_ws_size, mmc$sr_store_max_ws_size =
        max_working_set_size: 0 .. 0ffff(16),
      = mmc$sr_fetch_min_ws_size, mmc$sr_store_min_ws_size =
        min_working_set_size: 0 .. 0ffff(16),
      = mmc$sr_fetch_page_aging_int, mmc$sr_store_page_aging_int =
        page_aging_interval: 0 .. 0ffffffff(16),
      = mmc$sr_fetch_cyclic_aging_int, mmc$sr_store_cyclic_aging_int =
        cyclic_aging_interval: 0 .. 0ffffffff(16),
      casend,
    recend;

*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=MMT$RB_SET_GET_SEGMENT_LENGTH EXPAND=FALSE

{  Define type definition for monitor request to set or get the current
{  segment length.
{  NOTE: this request is available in ring 1 ONLY. It assumes the FDE_P is valid.
{        no status is returned from this request.

  TYPE
    mmt$rb_set_get_segment_length = RECORD
      request_code: syt$monitor_request_code,
      fde_p: gft$file_desc_entry_p,
      segment_length {input, output} : ost$segment_length,
      subfunction_code: mmt$set_get_subfunction_codes,
    RECEND,

    mmt$set_get_subfunction_codes = (mmc$sf_get_segment_length_fde_p,
      mmc$sf_set_segment_length_fde_p);

*copyc gft$file_desc_entry_p
*copyc gft$system_file_identifier
*copyc syc$monitor_request_codes
*copyc syt$monitor_request_code
*DECK DECK=MMT$RB_UNFLAW_PAGE EXPAND=FALSE

  TYPE
    mmt$rb_unflaw_page = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      rma: ost$real_memory_address,
    recend;

*copyc OST$HARDWARE_SUBRANGES
*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*DECK DECK=MMT$RB_WAIT_IO_COMPLETION EXPAND=FALSE
{Define request block for monitor request to wait for IO completions.

  TYPE
    mmt$rb_wait_io_completion = RECORD
      reqcode: syt$monitor_request_code,
      status: syt$monitor_status,
      pva: ^cell,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc syt$monitor_request_code
*copyc syt$monitor_status
?? POP ??
*DECK DECK=MMT$RCV_MEMORY_MGR EXPAND=FALSE

 TYPE
   mmt$rcv_memory_mgr = record
     pft_p: ^mmt$page_frame_table,
     iht_p: ^mmt$old_modified_bits,
     mfw_asid_p: ^mmt$mainframe_wired_asid,
     pft_p_rma: integer,
     iht_p_rma: integer,
     mfw_asid_p_rma: integer,
   recend;

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_table
*copyc mmt$old_modified_bits
*copyc mmt$mainframe_wired_asid
?? POP ??
*DECK DECK=MMT$READ_AHEAD_IOCB_TABLE EXPAND=FALSE

  TYPE
    mmt$read_ahead_iocb_table = ARRAY [0 .. mmc$iocb_table_size] OF
          mmt$read_ahead_iocb_entry,

    mmt$read_ahead_iocb_entry = RECORD
      CASE in_use: boolean OF
      = FALSE =
        ,
      = TRUE =
        read_ahead_request_info: mmt$read_ahead_request_info,
        active_io_count: mmt$active_io_count,
        condition: dft$server_iocb_error_condition,
        io_id: mmt$io_identifier,
      CASEND,
    RECEND,

    mmt$read_ahead_request_info = RECORD
      sfid: dmt$system_file_id,
      offset: ost$segment_offset,
      length: ost$segment_length,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dft$server_iocb_error_condition
*copyc dmt$system_file_id
*copyc mmt$io_identifier
*copyc mmt$rb_memory_manager_io
*copyc osd$virtual_address
?? POP ??
*DECK DECK=MMT$REASSIGNABLE_PAGE_FRAMES EXPAND=FALSE
  TYPE
    mmt$reassignable_page_frames = RECORD
      now: 0 .. osc$max_page_frames - 1,
      soon {waiting for io to complete}: 0 .. osc$max_page_frames - 1,
      swapout_io_not_initiated: 0 .. osc$max_page_frames - 1,
      swapout_io_cannot_initiate: 0 .. osc$max_page_frames - 1,
    RECEND;
*DECK DECK=MMT$RMA_LIST EXPAND=FALSE
{Define the RMA LIST used by memory manager.

  CONST
    mmc$max_rma_list_length = 2048;

  TYPE
    mmt$rma_list = array [mmt$rma_list_index] of mmt$rma_list_entry,

    mmt$rma_list_index = 1 .. mmc$max_rma_list_length,
    mmt$rma_list_length = 1 .. mmc$max_rma_list_length,

    mmt$rma_list_entry = record
      fill: ALIGNED [0 MOD 8] 0 .. 0ffff(16),
      length: 0 .. 0ffff(16),
      rma: 0 .. 0ffffffff(16),
    recend;
*DECK DECK=MMT$SEGMENT_ACCESS_RIGHTS EXPAND=FALSE
{Define types for specifying ACCESS RIGHTS of a user to a segment.}
{  *** note - used only in monitor mode. ***}
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
    mmt$segment_access_rights = (mmc$sar_none, mmc$sar_read, mmc$sar_modify,
      mmc$sar_write_extend);
*DECK DECK=MMT$SEGMENT_ACCESS_STATE EXPAND=FALSE
{ Define how access may proceed to the segment.

  TYPE
    mmt$segment_access_state = (
      mmc$sas_allow_access,     { - The normal state. All access is allowed.
      mmc$sas_inhibit_access,   { - Indicates that any access
                                { to this segment from the task should wait.
                                { This happens because the job needs to perform
                                { recovery for this file.
      mmc$sas_terminate_access);{ - Indicates that a segment access condition
                                { should be raised On any access to the segment.

*DECK DECK=MMT$SEGMENT_ACCESS_TYPE EXPAND=FALSE
{Define ordinal type used in MMP$VERIFY_PVA request.

  TYPE
    mmt$segment_access_type = (mmc$sat_none, mmc$sat_read, mmc$sat_write, mmc$sat_read_or_write);
*DECK DECK=MMT$SEGMENT_ATTRIB_DESCRIPTOR EXPAND=FALSE

  TYPE
    mmt$segment_attrib_descriptor = record
      validating_ring_number: ost$valid_ring,
      file_limits_to_enforce: sft$file_space_limit_kind,
      pointer_kind: mmt$segment_pointer_kind,
      sfid: gft$system_file_identifier,
      user_attributes: ^array [ * ] of mmt$attribute_descriptor,
    recend;

*copyc gft$system_file_identifier
*copyc mmt$attribute_keyword
*copyc osd$virtual_address
*copyc sft$file_space_limit_kind
*DECK DECK=MMT$SEGMENT_DESCRIPTOR_TABLE EXPAND=FALSE

{ This common deck contains system constants and type declarations
{ for tables defined for SEGMENT MANAGEMENT routines.
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{



{ Segment Descriptor Table - SDT. This table is the hardware defined
{ Segment Descriptor Table.}

  TYPE
    mmt$segment_descriptor = record
      ste: ost$segment_descriptor,
      fill1: 0 .. 0ff(16),
      asti: mmt$ast_index,
    recend,

{ For performance, the adaptable size segment table will be used only for allocation.
{ All other references to the segment table will use the pointer to the fixed size array.

    mmt$segment_descriptor_table = record
      st: ALIGNED [0 MOD 32768] array [0 .. * ] of mmt$segment_descriptor,
    recend,

    mmt$max_sdt = record
      st: ALIGNED [0 MOD 32768] array [0 .. 4095] of mmt$segment_descriptor,
    recend,

    mmt$max_sdt_p = ^mmt$max_sdt;

*copyc OST$SEGMENT_DESCRIPTOR
*copyc MMT$AST_INDEX
*DECK DECK=MMT$SEGMENT_DESCRIPTOR_TABLE_EX EXPAND=FALSE

{  This deck defines the SDTX used by Segment Manager.
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{


  TYPE
    mmt$segment_descriptor_extended = record
      open_validating_ring_number: ost$ring,
      access_state: mmt$segment_access_state,
      sfid: gft$system_file_identifier,
      inheritance: mmt$segment_inheritance,
      segment_reservation_state: mmt$segment_reservation_state,
      software_attribute_set: mmt$software_attribute_set,
      access_rights: mmt$segment_access_rights,
      segment_lock: mmt$lock_segment_status,
      shadow_info: mmt$shadow_info,
      file_limits_enforced: sft$file_space_limit_kind,
      stream: mmt$sdtx_stream_data,
*IF $true(osv$unix)
      assign_active: 0 .. osc$max_segment_length,
*ELSE
      assign_active: 0 .. osc$max_segment_length + 1,
*IFEND
    recend,

    mmt$sdtx_stream_data = PACKED RECORD
      last_page_fault: ost$segment_offset,
      sequential_accesses: 0..255,
      transfer_size: 0..15, {size= (2**(transfer_size)) * osv$page_size)
      random_faults: 0..15,
      streaming: boolean,
      transfer_size_specified: boolean,
      preset_streaming: boolean,
    RECEND,

{ For performance, the adaptable size table will be used only for allocation.
{ All other references to the sdtx will use the fixed size array.

    mmt$segment_descriptor_table_ex = record
      sdtx_table: array [0 .. * ] of mmt$segment_descriptor_extended,
    recend,

    mmt$max_sdtx = record
      sdtx_table: array [0 .. 4095] of mmt$segment_descriptor_extended,
    recend,

    mmt$max_sdtx_p = ^mmt$max_sdtx;


{ Constants for referencing SDTX.ASSIGN_ACTIVE. Note a value < mmc$assign_active_null is a valid
{ assign for the offset specified by <assign_sctive>.

  CONST
*IF $true(osv$unix)
    mmc$assign_active_null = osc$max_segment_length - 1,
*ELSE
    mmc$assign_active_null = osc$max_segment_length,
*IFEND
    mmc$assign_active_escaped = mmc$assign_active_null + 1;


*copyc gft$system_file_identifier
*copyc mmt$segment_inheritance
*copyc mmt$attribute_keyword
*copyc MMT$LUS_DECLARATIONS
*copyc MMT$SEGMENT_ACCESS_RIGHTS
*copyc MMT$SEGMENT_ACCESS_STATE
*copyc mmt$shadow_info
*copyc MMT$LOCK_SEGMENT_STATUS
*copyc mmt$segment_access_state
*copyc mmt$segment_reservation_state
*copyc MMT$SHADOW_SEGMENT_KIND
*copyc OSD$VIRTUAL_ADDRESS
*copyc SFT$FILE_SPACE_LIMIT_KIND
*DECK DECK=MMT$SEGMENT_INHERITANCE EXPAND=FALSE

  TYPE

    mmt$segment_inheritance = (mmc$si_none, mmc$si_share_segment,
         mmc$si_transfer_segment, mmc$si_new_segment,
         mmc$si_copy_on_write);
*DECK DECK=MMT$SEGMENT_KIND EXPAND=FALSE

  TYPE
    mmt$segment_kind = (
            mmc$sk_monitor_only,         {Segment exists in monitor ONLY.

            mmc$sk_global_templ_not_page,{No file tables exist. Pages kept in
                                         {  wired queue. Segment part of
                                         {  mainframe template.

            mmc$sk_job_not_pageable,     {No file tables exist. Pages kept in
            mmc$sk_transient_no_file,    {  job fixed or JWS queue.

            mmc$sk_transient_file,       {File tables exist in Job Fixed.
            mmc$sk_job_local_file,       {  Pages kept in JWS queue.

            mmc$sk_job_permanent_file,   {File tables exist in mainframe wired.
                                         {  Pages kept in JWS or shared queue
                                         {  depending on file usage.

            mmc$sk_global_template_file, {File tables exist in mainframe wired.
                                         {  Pages kept in shared queue.
            mmc$sk_file_wire_eoi_page,   {Used for Device Mgr LOGS only.
            mmc$sk_device_file);


  CONST
    mmc$sk_first_no_file = mmc$sk_monitor_only,
    mmc$sk_last_no_file = mmc$sk_transient_no_file,
    mmc$sk_first_pageable = mmc$sk_transient_no_file,     {Could be pageable}
    mmc$sk_first_file = mmc$sk_transient_file,
    mmc$sk_first_global_fde = mmc$sk_job_permanent_file,
    mmc$sk_last_file = mmc$sk_device_file;
*DECK DECK=MMT$SEGMENT_RESERVATION_STATE EXPAND=FALSE
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
    mmt$segment_reservation_state = (mmc$srs_not_reserved, mmc$srs_reserved,
         mmc$srs_reserved_shared_stack);
*DECK DECK=MMT$SELECTED_PAGE_FAULT_SIGNAL EXPAND=FALSE

{  This deck defines the content of the signal that is sent to a task that
{  page faults for a page that has requested a signal upon occurrence of
{  page faults for a page that is currently locked via the
{  mmp$select_signal_on_page_fault request.

  TYPE
    mmt$selected_page_fault_signal = RECORD
      pva: ^cell,
      sfid: dmt$system_file_id,
    RECEND;

*copyc DMT$SYSTEM_FILE_ID
*DECK DECK=MMT$SERVER_IO_CONTROL_BLOCK EXPAND=FALSE

{ Xref deck - mmt$server_io_control_block.

  CONST
    mmc$server_iocb_table_size = 50;

  TYPE
    mmt$server_io_control_block = ARRAY [1..mmc$server_iocb_table_size] OF
      mmt$server_iocb_entry;

  TYPE
    mmt$server_iocb_entry = RECORD
      global_file_name: ALIGNED [0 MOD 8] dmt$global_file_name,
      server_state: mmt$server_state,
      sfid: dmt$system_file_id,
      offset: ost$segment_offset,
      length: ost$segment_length,
      eoi: amt$file_byte_address,
      sub_reqcode: mmt$sub_reqcodes,
      condition: dft$server_iocb_error_condition,
      io_already_active: boolean,
      active_io_count: mmt$active_io_count,
      reissue_request: boolean,
      restart_count: integer,
      RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dft$server_iocb_error_condition
*copyc dmt$global_file_name
*copyc dmt$system_file_id
*copyc mmt$io_status
*copyc mmt$io_identifier
*copyc mmt$rb_memory_manager_io
*copyc mmt$server_state
*copyc osd$virtual_address
?? POP ??

*DECK DECK=MMT$SERVER_STATE EXPAND=FALSE
{ Xref deck = mmt$server_state.

  TYPE
    mmt$server_state = (mmc$ss_queue_initialized, mmc$ss_waiting, mmc$ss_reading_from_disk,
          mmc$ss_read_disk_error, mmc$ss_writing_to_esm, mmc$ss_write_esm_error, mmc$ss_reading_from_esm,
          mmc$ss_read_esm_error, mmc$ss_writing_to_disk, mmc$ss_write_disk_error,
          mmc$ss_sending_write_response, mmc$ss_sending_write_resp_error, mmc$ss_allocating_space,
          mmc$ss_allocate_space_error, mmc$ss_send_allocate_response, mmc$ss_send_allocate_resp_error,
          mmc$ss_reading_pages_ahead);
*DECK DECK=MMT$SHADOW_INFO EXPAND=FALSE
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
    mmt$shadow_info = RECORD
      shadow_start_page_number: 0 .. 0ffffff(16),
      shadow_length_page_count: 0 .. 0ffffff(16),
      shadow_sfid: gft$system_file_identifier,
      CASE shadow_segment_kind: mmt$shadow_segment_kind OF
      = mmc$ssk_segment_number =
        shadow_segment_number: ost$segment,
      = mmc$ssk_none =
        passive_for_shadow_by_segnum: boolean,
      CASEND,
    RECEND;


*copyc gft$system_file_identifier
*copyc osd$virtual_address
*DECK DECK=MMT$SHADOW_REFERENCE_INFO EXPAND=FALSE

  TYPE
    mmt$shadow_reference_info = RECORD
      source_pva: ^cell,
      destination_pva: ^cell,
      page_count: 0 .. 255,
    RECEND;

*DECK DECK=MMT$SHADOW_SEGMENT_KIND EXPAND=FALSE
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{


    TYPE
      mmt$shadow_segment_kind = (mmc$ssk_none, mmc$ssk_read_write_file, mmc$ssk_read_only_file,
         mmc$ssk_read_only_trans_file, mmc$ssk_segment_number);
*DECK DECK=MMT$SHARED_QUEUE EXPAND=FALSE

  TYPE
    mmt$shared_queue = mmt$page_frame_queue_id;

*copyc mmc$null_shared_queue
*copyc mmt$page_frame_queue_id
*DECK DECK=MMT$UNUSED_AGE_TABLE_ENTRY EXPAND=FALSE
*DECK DECK=MMT$UPDATE_EOI_REASON EXPAND=FALSE

{ The following constants are used in the call to MMP$UPDATE_EOI to indicate
{ the reason for the EOI update.

  TYPE
    mmt$update_eoi_reason = (mmc$uer_set_exact_eoi, mmc$uer_page_assigned,
        mmc$uer_multiple_pages_assigned, mmc$uer_page_written);
*DECK DECK=MMT$USER_ATTRIBUTE_DESCRIPTOR EXPAND=FALSE


  TYPE
    mmt$user_attribute_keyword = (mmc$ua_segment_number,
          mmc$ua_max_segment_length, mmc$ua_preset_value,
          mmc$ua_segment_access_control, mmc$ua_wired_segment,
          mmc$ua_ring_numbers, mmc$ua_null_keyword),

    mmt$user_attribute_descriptor = record
      case keyword: mmt$user_attribute_keyword of
      = mmc$ua_segment_number =
        segnum: ost$segment,
      = mmc$ua_max_segment_length =
        max_length: ost$segment_length,
      = mmc$ua_preset_value =
        preset_value: pmt$initialization_value,
      = mmc$ua_segment_access_control =
        access_control: ost$segment_access_control,
      = mmc$ua_wired_segment =
        wired_segment_length: ost$segment_length,
        contiguous_real_memory: boolean, {NOT IMPLEMENTED YET}
      = mmc$ua_ring_numbers =
        r1: ost$ring,
        r2: ost$ring,
      casend,
    recend;

*copyc osd$virtual_address
*copyc ost$segment_access_control
*copyc pmt$initialization_value
*DECK DECK=MMT$VA_ACCESS_MODE EXPAND=FALSE
{Definitions for interface to segment manager requests.

  TYPE
    mmt$va_access_mode = (mmc$va_read, mmc$va_write, mmc$va_read_write,
          mmc$va_execute, mmc$va_pointer_to_procedure, mmc$va_read_execute,
          mmc$va_binding);

*DECK DECK=MMT$WRITE_MODIFIED_PAGES_STATUS EXPAND=FALSE
{Error codes from mmp$mm_write_modified_pages.

  TYPE
    mmt$write_modified_pages_status = (mmc$wmp_io_initiation_reject, mmc$wmp_io_complete, mmc$wmp_io_active,
           mmc$wmp_volume_unavailable, mmc$wmp_io_errors, mmc$wmp_server_terminated);
*DECK DECK=MMT$WRITE_PAGE_TO_DISK_STATUS EXPAND=FALSE
  TYPE
    mmt$write_page_to_disk_status = (ws_ok, ws_physical_io_reject, ws_no_file_assigned, ws_disk_flaws,
    ws_device_manager_reject, ws_volume_unavailable, ws_server_terminated);

*DECK DECK=MMT$XCB_PAGE_WAIT_INFO EXPAND=FALSE

{This deck defines the information kept in the XCB for a task that is in
{'page_wait' status.

  TYPE
    mmt$xcb_page_wait_info = RECORD
      pva: ^cell,
    recend;


*DECK DECK=MMV$AGE_INTERVAL_CEILING EXPAND=FALSE

{  This variable defines the age at which a page will be removed from the JWS.

    VAR
      mmv$age_interval_ceiling : [XREF]  0..255 ;

*DECK DECK=MMV$AGE_INTERVAL_FLOOR EXPAND=FALSE

{  This variable defines the age at which a page can be a candidate for removal from the JWS.

    VAR
      mmv$age_interval_floor   : [XREF]  0..255 ;

*DECK DECK=MMV$AGGRESSIVE_AGING_LEVEL EXPAND=FALSE

{Define minimum number of pages that must be kept in the free + available page
{queues. If the actual number drops below this value, memory manager begins
{an aggressive aging policy. If the number of page frames drops below mmv$aggressive_aging_level_2
{then only critical system tasks are assigned memory. User tasks are put into a memory wait queue.

  VAR
    mmv$aggressive_aging_level: [XREF] integer,
    mmv$aggressive_aging_level_2: [XREF] integer;

*DECK DECK=MMV$AGING_ALGORITHM EXPAND=FALSE
{The following variable defines the agining algorithm that is used by memory manager.
{    0 - no swapping active
{    1 - swapping active
{  > 1 - to be defined
  VAR
    mmv$aging_algorithm: [XREF] integer;
*DECK DECK=MMV$AGING_STATISTICS EXPAND=FALSE

  VAR
    mmv$aging_statistics: [XREF] mmt$aging_statistics;

?? PUSH (LISTEXT := ON) ??
*copyc MMT$AGING_STATISTICS
?? POP ??
*DECK DECK=MMV$AIO_LIMIT EXPAND=FALSE
*DECK DECK=MMV$ASSIGN_MULTIPLE_PAGES EXPAND=FALSE

{ Define variable used to activate/deactivate assign_multiple_pages. When activated
{ mmp$page_pull will assign more than one page to a task that has faulted for a new page
{ and it is determined that extra pages will highly likely be used.  Multiple pages will
{ be assigned if mmv$reassignable_page_frames.now is greater or equal to this value.

  VAR
    mmv$assign_multiple_pages: [XREF] integer;
*DECK DECK=MMV$AST_P EXPAND=FALSE
{Pointer to the Active Segment Table - (AST).}

  VAR
    mmv$ast_p: [XREF] ^mmt$active_segment_table;

?? PUSH (LISTEXT := ON) ??
*copyc MMT$ACTIVE_SEGMENT_TABLE
?? POP ??
*DECK DECK=MMV$ASYNC_WORK EXPAND=FALSE
{Define async worklist for processing periodic activities.

  VAR
    mmv$async_work: [XREF] mmt$async_work_list;

?? PUSH (LISTEXT := ON) ??
*copyc MMT$ASYNC_WORK_LIST
?? POP ??
*DECK DECK=MMV$AVAIL_MODIFIED_QUEUE_MAX EXPAND=FALSE

  VAR
    mmv$avail_modified_queue_max: [XREF] integer;
*DECK DECK=MMV$BENCHMARK_RUN EXPAND=FALSE

  VAR
    mmv$benchmark_run: [XREF] integer;
*DECK DECK=MMV$BIG_SEGMENT EXPAND=FALSE
{This deck contains XREFs to variables used by Memory Manager in
{monitor mode. The variables are initialized by a job mode routine
{during system deadstart.

  VAR
    mmv$a_divisor: [XREF] 0 .. 10000(16),
    mmv$a_mult: [XREF] 0 .. 10000(16),
    mmv$number_free_astes: [XREF] integer;

*DECK DECK=MMV$CONTIGUOUS_MEM_LENGTH_MAX EXPAND=FALSE

 VAR
   mmv$contiguous_mem_length_max: [XREF] ost$segment_length;

*copyc osd$virtual_address
*DECK DECK=MMV$CONTINUE_BIT_COUNT_P EXPAND=FALSE
{
{CONTINUE BIT COUNT - This array is used to manage the continue bits in the page table.
{    Each entry in the array contains a count of the number of 'times' the continue bit in
{    the corresponding page table entry is 'set'. If the count is non-zero, the continue bit
{    is set.

  VAR
    mmv$continue_bit_count_p: [XREF] ^mmt$continue_bit_count;

?? PUSH (LISTEXT := ON) ??
*copyc mmt$continue_bit_count
?? POP ??
*DECK DECK=MMV$DEFAULT_SDTX_ENTRY EXPAND=FALSE


{  Define XREF variable for default SDTX entry.

  VAR
    mmv$default_sdtx_entry: [XREF, READ, oss$mainframe_paged_literal]
      mmt$segment_descriptor_extended;

?? PUSH (LISTEXT := ON) ??
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE_EX
*copyc OSS$MAINFRAME_PAGED_LITERAL
?? POP ??
*DECK DECK=MMV$DEFERRED_ASSIGN EXPAND=FALSE
VAR
  mmv$deferred_assign: [XREF] boolean;
*DECK DECK=MMV$DF_READ_SERVER_PF_STATS EXPAND=FALSE

  VAR
    mmv$df_read_server_pf_stats: [XREF] mmt$pf_statistics;

?? PUSH (LISTEXT := ON) ??
*copyc mmt$pf_statistics
?? POP ??

*DECK DECK=MMV$DISABLE_WRITE_FOR_PERF_MEAS EXPAND=FALSE


  VAR
    mmv$disable_write_for_perf_meas: [XREF] boolean;
*DECK DECK=MMV$FILE_ALLOCATION_INTERVAL EXPAND=FALSE

 VAR
   mmv$file_allocation_interval: [XREF] integer;
*DECK DECK=MMV$FIRST_TRANSIENT_SEG_INDEX EXPAND=FALSE


{  Define variable that contains the SDT index for the first transient segment.

  VAR
    mmv$first_transient_seg_index: [XREF] ost$segment;

?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
?? POP ??
*DECK DECK=MMV$FORCE_USE_OF_CACHE_AND_MAPS EXPAND=FALSE

  VAR
    mmv$force_use_of_cache_and_maps: [XREF] boolean;
*DECK DECK=MMV$FREE_BEHIND_WINDOW EXPAND=FALSE
{Define size of 'free behind window'. Used for testing.

  VAR
    mmv$free_behind_window: [XREF] integer;

*DECK DECK=MMV$FREE_PAGES EXPAND=FALSE

  VAR
    mmv$free_pages: [XREF] ^ARRAY [ * ] OF 0 .. osc$max_page_frames;

?? PUSH (LISTEXT := ON) ??
*copyc ost$page_table
?? POP ??
*DECK DECK=MMV$FREE_QUEUE_THRESHOLD EXPAND=FALSE
{Define number of page frames that memory manager should attempt to
{keep in the available + free queues.

  VAR
    mmv$free_queue_threshold: [XREF] integer;
*DECK DECK=MMV$GPQL EXPAND=FALSE

{ Global Page Queue List array.

  VAR
    mmv$gpql: [XREF] mmt$global_page_queue_list;
?? PUSH (LISTEXT := ON) ??
*copyc MMT$PAGE_QUEUE_LIST
?? POP ??

*DECK DECK=MMV$IMAGE_FILE EXPAND=FALSE

  VAR
    mmv$image_file: [XREF] mmt$image_file;

?? PUSH (LISTEXT := ON) ??
*copyc mmt$image_file
?? POP ??
*DECK DECK=MMV$INITIAL_JOB_FIXED_AST_ENTRY EXPAND=FALSE
{Define template for an AST entry for a job fixed segment. This is used by the job swapper to
{create an AST entry for job fixed of a job being swapped in.

  VAR
    mmv$initial_job_fixed_ast_entry: [XREF] mmt$active_segment_table_entry;

?? PUSH (LISTEXT := ON) ??
*copyc mmt$active_segment_table
?? POP ??
*DECK DECK=MMV$JWS_QUEUE_AGE_INTERVAL EXPAND=FALSE
{This variable defines the rate at which memory manager scans all jobs and
{ages the working sets of any CP bound job that is found.

  VAR
    mmv$jws_queue_age_interval: [XREF] integer;

*DECK DECK=MMV$LAST_ACTIVE_SHARED_QUEUE EXPAND=FALSE

{  Define a variable to contain the index of the last shared site queue that is actually being used.

  VAR
    mmv$last_active_shared_queue: [XREF] mmt$global_page_queue_index;
?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_queue_id
?? POP ??

*DECK DECK=MMV$LAST_SEGMENT_ACCESSED EXPAND=FALSE

  VAR
    mmv$last_segment_accessed: [XREF] ost$segment;

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
?? POP ??
*DECK DECK=MMV$MANAGE_MEMORY_UTILITY EXPAND=FALSE

{ The data consists of pointers to the various mmv$ variables managed by MMU and also the default value
{ for each of the variables and the default value of the Global Page Queue List.  The default values
{ are saved by mmm$deadstart_initialization.

  VAR
    mmv$manage_memory_utility: [XREF] mmt$manage_memory_utility;

?? PUSH (LISTEXT := ON) ??
*copyc mmt$manage_memory_utility
?? POP ??
*DECK DECK=MMV$MAXIMUM_180_MEMORY EXPAND=FALSE
{Define maximum amount of memory that 180 will use. This is for debug ONLY.

  VAR
    mmv$maximum_180_memory: [XREF] integer;

*DECK DECK=MMV$MAX_PAGES_NO_FILE EXPAND=FALSE
{Maximum number of pages that will be assigned to a segment that does not
{have a backing file. A signal is sent to the task to assign a file when
{the number of assigned pages exceeds this value.

  VAR
    mmv$max_pages_no_file: [XREF] integer;
*DECK DECK=MMV$MAX_SEGMENT_LENGTH EXPAND=FALSE


{
{   Define XREF for 'mmv$max_segment_length', maximum segment length allowed
{ by memory manager.
{

  VAR
    mmv$max_segment_length: [XREF] integer;
*DECK DECK=MMV$MAX_TEMPLATE_SEGMENT_NUMBER EXPAND=FALSE

{ The following variable contains the maximum segment number of a global template segment.

  VAR
    mmv$max_template_segment_number: [XREF] integer;
*DECK DECK=MMV$MAX_WORKING_SET_SIZE EXPAND=FALSE

  VAR
    mmv$max_working_set_size: [XREF] integer;
*DECK DECK=MMV$MEMORY_WAIT_QUEUE EXPAND=FALSE

{Define variable used as the head of the linked list of tasks waiting for
{memory.

  VAR
    mmv$memory_wait_queue: [XREF] tmt$task_queue_link;

?? PUSH (LISTEXT := ON) ??
*copyc TMT$TASK_QUEUE_LINK
?? POP ??
*DECK DECK=MMV$MF_WIRED_ASID EXPAND=FALSE

  VAR
    mmv$mf_wired_asid: [XREF] mmt$mainframe_wired_asid;

*copyc mmt$mainframe_wired_asid
*DECK DECK=MMV$MIN_AVAIL_PAGES EXPAND=FALSE

  VAR
    mmv$min_avail_pages: [XREF] integer;

*DECK DECK=MMV$MULTIPLE_CACHES EXPAND=FALSE
{The following variable indicates if the configuration consists of multiple
{caches that are not hardware connected for unified cache purging - ie, if a cache
{purge is required each processor must purge its own cache.

  VAR
    mmv$multiple_caches: [XREF] boolean;

*DECK DECK=MMV$MULTIPLE_PAGE_MAPS EXPAND=FALSE
{The following variable indicates if the configuration consists of multiple
{page MAPS that are not hardware connected for unified map purging - ie,
{if a page map purge is required each processor must purge its own map.

  VAR
    mmv$multiple_page_maps: [XREF] boolean;

*DECK DECK=MMV$MULTI_PAGE_WRITE EXPAND=FALSE
{Define variable used to activate/deactivate multi-page write. Multi-page write activated
{means that memory manager attempts to write all modified pages in a transfer unit whenever
{any page in the transfer unit is written.

  VAR
    mmv$multi_page_write: [XREF] boolean;
*DECK DECK=MMV$NEXT_FREE_PAGE EXPAND=FALSE

  VAR
    mmv$next_free_page: [XREF] integer;
*DECK DECK=MMV$NO_MEMORY_BUFFERING EXPAND=FALSE

{Define option used to disable buffering of aged out pages in memory, i.e. when a page
{is aged out, it is written to disk (if necessary) and placed in the free queue.

  VAR
    mmv$no_memory_buffering: [XREF] boolean;

*DECK DECK=MMV$PAGES_PER_NEW_PAGE_FAULT EXPAND=FALSE

  VAR
    mmv$pages_per_new_page_fault: [XREF] 1 .. 8;
*DECK DECK=MMV$PAGES_TO_DUMP_P EXPAND=FALSE

  VAR
    mmv$pages_to_dump_p: [XREF] ^packed array [0 .. *] of boolean;
*DECK DECK=MMV$PAGE_MAP_OFFSETS EXPAND=FALSE
VAR
  mmv$page_map_offsets: [XREF] mmt$page_map_offsets;

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_map_offsets
?? POP ??
*DECK DECK=MMV$PAGE_STREAMING_PRESTREAM EXPAND=FALSE

{ Define the number of page faults that trigger prestreaming mode

  VAR
    mmv$page_streaming_prestream: [XREF] 0 .. 255;
*DECK DECK=MMV$PAGE_STREAMING_RANDOM_LIMIT EXPAND=FALSE

{ Define the limit of random page faults.  Page streaming terminates if the number of consecutive page
{ faults exceeds the limit. (random really means at an address less than the current streaming position)

  VAR
    mmv$page_streaming_random_limit: [XREF] 0 .. 255;

*DECK DECK=MMV$PAGE_STREAMING_READS EXPAND=FALSE

{ Define the number of transfer units that the page fault processor will initiate when in page streaming mode
{ This count includes the transfer unit in which the page fault occurred.

  VAR
    mmv$page_streaming_reads: [XREF] 0 .. 255;
*DECK DECK=MMV$PAGE_STREAMING_THRESHOLD EXPAND=FALSE

{ Define  the number of bytes of data that page faults must span sequentially to trigger page streaming

  VAR
    mmv$page_streaming_threshold: [XREF] integer;
*DECK DECK=MMV$PAGE_STREAMING_TRANSFER EXPAND=FALSE

{ Define the number of bytes used to override the transfer size

  VAR
    mmv$page_streaming_transfer: [XREF] integer;
*DECK DECK=MMV$PAGING_STATISTICS EXPAND=FALSE

{ Deck mmv$paging_statistics XREF a record of stats about paging.  Where pages come from, which process
{ (page fault, page streaming, advise_in) acquired the pages and other data about page streaming.

  VAR
    mmv$paging_statistics: [XREF] mmt$paging_statistics;
?? PUSH (LISTEXT := ON) ??
*copyc MMT$PAGING_STATISTICS
?? POP ??
*DECK DECK=MMV$PERIODIC_CALL_INTERVAL EXPAND=FALSE
{This variable the time interval between calls from CP Monitor to
{memory manager MMP$PERIODIC_CALL procedure.

  VAR
    mmv$periodic_call_interval: [XREF] integer;
*DECK DECK=MMV$PFTI_ARRAY_P EXPAND=FALSE
{Define pointer to array for holding PFTI lists. This array is used in monitor for holding lists
{PFTIs of pages belonging to a segment.

  VAR
    mmv$pfti_array_p: [XREF] ^mmt$pfti_array;

?? PUSH (LISTEXT := OFF) ??
*copyc mmt$pfti_array
?? POP ??
*DECK DECK=MMV$PFT_P EXPAND=FALSE
{Pointer to the 'PAGE FRAME TABLE' (PFT)

  VAR
    mmv$pft_p: [XREF] ^mmt$page_frame_table;

?? PUSH (LISTEXT := ON) ??
*copyc MMT$PAGE_FRAME_TABLE
?? POP ??
*DECK DECK=MMV$PF_STATISTICS EXPAND=FALSE

  VAR
    mmv$pf_statistics: [XREF] mmt$pf_statistics;

?? PUSH (LISTEXT := ON) ??
*copyc MMT$PF_STATISTICS
??pop??
*DECK DECK=MMV$PRESET_CONVERSION_TABLE EXPAND=FALSE

  VAR
    mmv$preset_conversion_table: [XREF, READ] array [pmt$initialization_value]
        of integer;

*copyc pmt$initialization_value
*DECK DECK=MMV$PT_LENGTH EXPAND=FALSE
{Define page table length in words.

  VAR
    mmv$pt_length: [XREF] integer;

*DECK DECK=MMV$PT_P EXPAND=FALSE
{Pointer to the system PAGE TABLE (PT).

  VAR
    mmv$pt_p: [XREF] ^ost$page_table;

?? PUSH (LISTEXT := ON) ??
*copyc OST$PAGE_TABLE
?? POP ??
*DECK DECK=MMV$READ_TU_OPTIONS EXPAND=FALSE
  VAR
    mmv$read_tu_read_write: [XREF] 0 .. 0ffffffff(16),
    mmv$read_tu_execute: [XREF] 0 .. 0ffffffff(16);

*DECK DECK=MMV$REASSIGNABLE_PAGE_FRAMES EXPAND=FALSE
{The following variable contains a count of the number of page frames that can be reassigned to be
{used for another purpose. The count represents the number of pages that are in the free + available
{queues. The count is broken into two parts - pages with no IO active, and pages with IO active.

  VAR
    mmv$reassignable_page_frames: [XREF] mmt$reassignable_page_frames;
?? PUSH (LISTEXT := ON) ??
*copyc mmt$reassignable_page_frames
?? POP ??
*DECK DECK=MMV$REDUCE_JWS_FOR_THRASHING EXPAND=FALSE

{ This variable is set to TRUE by monitor mode scheduler when it is notified of thrashing
{ (low memory) and there is only one job active.  Setting the variable will cause the
{ job's working set to be reduced.  This is done instead of swapping out the job.

  VAR
    mmv$reduce_jws_for_thrashing: [XREF] boolean;

*DECK DECK=MMV$RESERVED_PAGE_COUNT EXPAND=FALSE

  VAR
    mmv$reserved_page_count: [XREF] integer;

*DECK DECK=MMV$RESIDENT_JOB_TARGET EXPAND=FALSE

{  Define the number of free and available pages that job scheduler tries to
{  keep avilable for all active jobs.

  VAR
    mmv$resident_job_target: [XREF] integer;
*DECK DECK=MMV$SHADOW_BY_SEGNUM EXPAND=FALSE

  VAR
    mmv$shadow_by_segnum: [XREF] boolean;
*DECK DECK=MMV$SHARED_PAGES_IN_JWS EXPAND=FALSE

    VAR
      mmv$shared_pages_in_jws: [XREF] boolean;

*DECK DECK=MMV$SHARED_QUEUE_AGE_INTERVAL EXPAND=FALSE
{This variable the rate at which Memory Manager ages out all pages of all
{working sets that have not been referenced since the last time the
{aging was done.

  VAR
    mmv$shared_queue_age_interval: [XREF] integer;
*DECK DECK=MMV$SWAPPING_AIC EXPAND=FALSE

  VAR
    mmv$swapping_aic: [XREF] integer;

*DECK DECK=MMV$TABLES_INITIALIZED EXPAND=FALSE
{Define variable used to  indicate if memory manager tables have been initialized.

  VAR
    mmv$tables_initialized: [XREF] boolean;

*DECK DECK=MMV$TEMP_FILE_SPACE_GUARD EXPAND=FALSE
  VAR
    mmv$temp_file_space_guard: [XREF] boolean;
*DECK DECK=MMV$TEST_REASSIGN_ASID EXPAND=FALSE

  VAR
    mmv$test_reassign_asid: [XREF] boolean;

*DECK DECK=MMV$TICK_TIME EXPAND=FALSE
{Define the fundemental page aging constant.

  VAR
    mmv$tick_time: [XREF] integer;

*DECK DECK=MMV$TIME_CHANGED_GLOBAL_ASID EXPAND=FALSE
{ Timestamp that contains the free-running-clock value when a global ASID was last changed.

  VAR
    mmv$time_changed_global_asid: [XREF] ost$free_running_clock;

?? PUSH (LISTEXT := ON) ??
*copyc ost$free_running_clock
?? POP ??
*DECK DECK=MMV$TIME_CHANGED_TEMPLATE_ASID EXPAND=FALSE

{ Timestamp that contains the free-running-clock value when a global ASID was last changed.

  VAR
    mmv$time_changed_template_asid: [XREF] ost$free_running_clock;

?? PUSH (LISTEXT := ON) ??
*copyc ost$free_running_clock
?? POP ??

*DECK DECK=MMV$TIME_MAP_LAST_PURGED EXPAND=FALSE
{Time map was last purged in all processors.

  VAR
    mmv$time_map_last_purged: [XREF] integer;

*DECK DECK=MMV$TIME_TO_CALL_MEM_MGR EXPAND=FALSE
{Time for next periodic call to Memory Manager from CP Monitor.

  VAR
    mmv$time_to_call_mem_mgr: [XREF] integer;
*DECK DECK=MMV$TIME_TO_CALL_QUICK_SWEEP EXPAND=FALSE

{Time for next periodic call to Quick Sweep from CP Monitor.

  VAR
    mmv$time_to_call_quick_sweep: [XREF] integer;
*DECK DECK=MMV$TOTAL_CONTIG_PAGES_ASSIGNED EXPAND=FALSE

    VAR
      mmv$total_contig_pages_assigned: integer;
*DECK DECK=MMV$TOTAL_PAGE_FRAMES EXPAND=FALSE

  VAR
    mmv$total_page_frames: [XREF] mmt$page_frame_index;

*copyc mmt$page_frame_index
*DECK DECK=MMV$WRITE_AGED_OUT_PAGES EXPAND=FALSE

{Define option used to force aged out pages to be written to disk
{immediately when it is aged out of a job working set.
{Page are written if SOON + NOW < mmv$write_aged_out_pages.

  VAR
    mmv$write_aged_out_pages: [XREF] integer;

*DECK DECK=MSC$CONDITION_LIMITS EXPAND=TRUE

  CONST
    msc$min_ecc = (($INTEGER ('M') * 100(16)) + $INTEGER ('S')) * 1000000(16),
    msc$max_ecc = msc$min_ecc + 9999;

  CONST
    msc$maintenance_services_id = 'MS';
*DECK DECK=MSE$REQUEST_MAINTENANCE_ACCESS EXPAND=FALSE

?? FMT (FORMAT := OFF) ??
*copyc MSC$CONDITION_LIMITS

  CONST
    msc$min_ma_err = msc$min_ecc + 100,

    mse$maintenance_job_class_req = msc$min_ma_err + 0,
       {E Maintenance job class required to access elements. }

    mse$dedicated_access_granted = msc$min_ma_err + 2,
       {E +P1 is already object of dedicated maintenance access by job : +P2.}

    mse$system_critical_element = msc$min_ma_err + 4,
       {E +P1 is a system critical element.}

    mse$element_not_requested = msc$min_ma_err + 6,
       {E +P1 is not requested by this job. }

    mse$concurrent_access_granted = msc$min_ma_err + 8,
       {E +P1 is already object of concurrent maintenance access by job : +P2.}

    mse$element_state_not_proper = msc$min_ma_err + 10,
       {E +P1 must be ON or DOWN for concurrent access and DOWN for dedicated access. }

    mse$element_already_assigned = msc$min_ma_err + 12,
       {E +P1 already assigned to job : +P2.}

    mse$device_has_no_media = msc$min_ma_err + 14,
       {E Storage device +P1 has no media mounted on it.}

    mse$media_is_member_of_set = msc$min_ma_err + 16,
       {E Storage device +P1 has media (+P2) which is a member of an active ..
       {NOS/VE mass storage set (+P3).}

    mse$mass_device_required = msc$min_ma_err + 18,
       {E +P1 must be a mass storage device for ..
       {MSP$VALIDATE_MEDIA_ACCESS. }

    mse$volume_is_not_online = msc$min_ma_err + 19,
       {E Volume +P1 is not online. }

    mse$req_maint_access_required = msc$min_ma_err + 20,
       {E +P1 must be the object of either CONCURRENT or DEDICATED ..
       {maintenance access. }

    mse$maintenance_access_denied = msc$min_ma_err + 21,
       {E Maintenance access to +P1 is denied : +P2}

    mse$non_active_path = msc$min_ma_err + 22;
       {E +P1 is currently a non active channel, user must request maintenance ..
       {on an active channel or DOWN a controller in the path. }

?? FMT (FORMAT := ON) ??
*DECK DECK=MSH$ASSIGN_FLAWED_MEMORY EXPAND=FALSE

{    The purpose of this request is to assign flawed memory pages to an
{  empty, non-pageable segment.  The assignment order, which determines
{  the PVA to RMA mapping, is unspecified but may be determined through
{  the use of the test page and set Xk right instruction (reference no.
{  126 in MIGDS).  Segment length is also determined in this manner by
{  detection of a non translated PVA.  References to flawed memory can
{  generate hardware interrupts for which condition handling can be pro-
{  vided by the maintenance software.
{
{        MSP$ASSIGN_FLAWED_MEMORY(ELEMENT,PVA,STATUS)
{
{  ELEMENT: (input) This parameter specifies the identity of the system
{        memory whose flawed pages are to be included into the requesting
{        task's address space.
{
{  PVA: (input) This parameter specifies the segment with which to assoc-
{        iate the flawed pages.  The segment must have been created by the
{        mmp$create_segment procedure as a non-pageable segment and it must
{        have no pages currently allocated to the segment.
{
{  STATUS: (output) This parameter specifies the  request status.
{}
*DECK DECK=MSH$ASSIGN_REAL_PAGE EXPAND=FALSE
{}

{    The purpose of this request is to cause a specific page frame to
{  be assigned to a maintenance user non_pageable segment at a specified
{  offset.  The assignment is possible if the requested page meets the
{  following cirteria:
{    -the page does not belong to the system
{    -the page is not flawed (flawed pages are accessible only through
{      the msp$assign_flawed_memory request)
{    -the page is not in a non-pageable segment
{
{        MSP$ASSIGN_REAL_PAGE(ELEMENT,PVA,RMA,PAGE_STATUS,STATUS)
{
{  ELEMENT: (input) This parameter specifies the identity of the system
{        memory from which the page is to be assigned.
{
{  PVA: (input) This parameter specifies the virtual address at which the
{        page requested may be referenced.  The PVA parameter must have
{        a byte offset which is 0 modulo page size.  The segment which
{        was created by mmp$create_segment must be non-pageable.
{
{  RMA: (input) This parameter specifies the byte address of the beginning
{        of the page frame to be assigned to the specified segment.  RMA
{        must be 0 modulo page size.
{
{  PAGE_STATUS: (output) This parameter specifies the system status of the
{        requested page.
{
{  STATUS: (output) This parameter specifies the request status.
*DECK DECK=MSH$EXECUTE_DIAGNOSTICS EXPAND=FALSE
{
{     The purpose of this request is to execute diagnostics which are
{ capable of execution by a host command to the element and which do
{ not require additional host mainframe resources to initiate.
{     Each system element or subsystem will have its own constraints
{ concerning the conditions under which its diagnostics may be used
{ and the dependencies, if any, upon other elements for delivery of
{ the diagnostic capability.
{
{        MSP$EXECUTE_DIAGNOSTICS (DIAGNOSTIC_PATH, RESULTS, STATUS)
{
{ DIAGNOSTIC_PATH: (input) This parameter specifies the identity of the
{        target element, component or subsystem as well as a description
{        of which intermediate elements to use, if any, to initiate the
{        diagnostic execution.   If both a controller and a storage-device
{        are unnecessary for channel or channel-adapter diagnostic execution,
{        then set the name of the unnecessary element to osc$null_name.
{        Similarly void any unnecessary element for controller or storage-
{        device diagnostic execution.
{
{ RESULTS: (output) This parameter specifies the hardware-dependent
{        results of the diagnostic execution.
{
{ STATUS: (output) This parameter specifies the request status.
{

*DECK DECK=MSH$FLAW_PAGE EXPAND=FALSE

{    The purpose of this request is to cause a page frame to be marked
{  as flawed.  If the page is currently in use (assigned), an attempt
{  will be made to free it.  In any case, a flawed page frame will never
{  be transformed from an unassigned to an assigned state.
{
{        MSP$FLAW_PAGE(ELEMENT,RMA,PAGE_STATUS,STATUS)
{
{  ELEMENT: (input) This parameter specifies the identity of the system
{        element in which the page to be flawed resides.
{
{  RMA: (input) This parameter specifies the real memory byte address of
{        the beginning of the page frame which is to be flawed.  (RMA
{        must be 0 modulo page size).
{
{  PAGE_STATUS: (output) This parameter specifies the system state of the
{        page which is the object of this request.
{
{  STATUS: (output) This parameter specifies the request status.
{}
*DECK DECK=MSH$GET_CORRECTED_ERROR_LOG EXPAND=FALSE

{    The purpose of this request is to provide the caller with the con-
{  tents of one of the system maintained corrected error log buffers.
{  The caller may optionally cause the error log buffer to be reset to
{  empty state, but if this is requested, the burden of placing current
{  buffer content in the Engineering Log is placed on the caller.
{  If the buffer is not reset, the system will cause it to be flushed to
{  the Engineering Log when one of the following conditions has arisen:
{    -buffer full
{    -timer expired
{    -an error count field is exceeded
{
{        MSP$GET_CORRECTED_ERROR_LOG(ELEMENT,RESET_BUFFER,BUFFER,STATUS)
{
{ ELEMENT: (input) This parameter specifies the identity of the system
{        element whose corrected error log buffer is to be retrieved.
{        Elements for which the corrected error log buffer will be
{        maintained include cpu and memory.
{
{ RESET_BUFFER: (input) This parameter specifies whether to reset the cor-
{        rected error log buffer to its initial (empty) state after passing
{        a copy to the caller.
{
{ BUFFER: (output) This parameter specifies the area which will receive
{        the corrected error log buffer data.
{
{ STATUS: (output) This parameter specifies the request status.
{}
*DECK DECK=MSH$LOAD_STANDARD_MICROCODE EXPAND=FALSE

{
{   The purpose of this request is to down-load the microcode normally
{ used by the NOS/VE system into a peripheral controller. The controller
{ must have been previously placed in the DOWN state and also must
{ have been requested for DEDICATED maintenance access by the requesting
{ job.
{   The intent for provision of this request is to have maintenace soft-
{ ware use the controller in a 'standard' way before it returns to
{ system use (i.e., returns to the ON state).
{
{       MSP$LOAD_STANDARD_MICROCODE (PATH, STATUS)
{
{ PATH: (input) This parameter specifies the names of the channel and}
{        controller elements which are involved.}
{}
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=MSH$RELEASE_MAINTENANCE_ACCESS EXPAND=FALSE
{
{   The purpose of this request is to release maintenance access to an
{ element.  The type of access being released is determined by information
{ maintained by the system on the preceding msp$request_maintenance_access
{ request.
{
{   Maintenance access reservations not explicitly released by this request
{ are released when the task which requested the access terminates.
{
{   If a storage device was requested for CONCURRENT maintenance and was the
{ object of a CMP$MOUNT_STORAGE_MEDIUM request, the storage device will be
{ "detached" (unassigned) from the job; the medium will not be physically
{ unloaded by this request.
{
{   If a mass storage device was requested for DEDICATED access and was the
{ object of a CMP$MOUNT_STORAGE_MEDIUM request, the operator will be asked to
{ dismount the medium mounted by the latter request and then will be asked to
{ remount the original medium, if there had been one previously mounted.  The
{ system does not validate that the original medium has been mounted.
{ Subsequently, the storage device will be "detached" (unassigned) from the
{ job.
{
{   NOS/VE automatically DOWNs an element which had an intolerable failure
{ occur during system use of the element.  NOS/VE mandates that a repair
{ action be performed on a mainframe element before the state of the element
{ can be changed to ON.  If DEDICATED access is terminated by this request,
{ NOS/VE considers that a repair action has been attempted and will allow the
{ state of the element to subsequently be changed to ON subject to all other
{ requirements having been met.
{
{       MSP$RELEASE_MAINTENANCE_ACCESS (ELEMENT, STATUS)
{
{ ELEMENT: (input)  This parameter specifies the identity of the system
{       element for which an instance of maintenance access has ended.  The
{       identity of the system element may be specified using either the name
{       of the element or its hardware address, if applicable.  In a
{       multiple-IOU configuration, the identity of the IOU must be supplied
{       to uniquely identify a PP, data channel or channel-adapter.
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS:
{                     cme$lcm_element_not_found
{                     mse$ma_element_not_requested
{                     mse$maintenance_job_class_req
{
{         IDENTIFIER:  'MS'
{
*DECK DECK=MSH$REQUEST_MAINTENANCE_ACCESS EXPAND=FALSE
{
{   The purpose of this request is to validate and establish maintenance
{ access to an element in NOS/VE's active configuration.  The reason for
{ requesting maintenance access to an element is to ensure that the
{ installation management or operator have authorized online maintenance to be
{ performed before it is attempted.  Maintenance access must be requested and
{ obtained before the element can be used by a maintenance job.  Once
{ maintenance access has been granted to an element, the element cannot be
{ reserved to a job until maintenance access has been terminated.  The term
{ "reserved" implies that the use of the cmp$reserve_element request by a job
{ to acquire sole use of an element; the system cannot permit maintenance
{ access to a reserved element because the system does not control access to
{ an element once it has been reserved to a job.  Elements scheduled to a job
{ using the RESERVE_RESOURCE command may be the object of maintenance access.
{ The term "assigned" refers to the action taken by an operator using the
{ ASSIGN_DEVICE command.
{
{   For CONCURRENT access to be granted:
{
{       1.  The element must be in the active configuration.
{
{       2.  The element must not be reserved nor assigned to any job.
{
{       3.  The element must not currently be the object of DEDICATED
{           maintenance access.
{
{       4.  The element must be in the ON or DOWN state.
{
{       5.  If the element is a disk controller which has more than one
{           channel connected to it and the channels cannot be used
{           concurrently and independently, then the channel to be used
{           for concurrent maintenance must be the channel that is
{           currently being used by NOS/VE.
{
{   For DEDICATED access to be granted:
{
{       1.  The element must be in the active configuration.
{
{       2.  The element must not be reserved nor assigned to any job.
{
{       3.  The element must not currently be the object of CONCURRENT
{           maintenance access.
{
{       4.  The element must not currently be the object of DEDICATED
{           maintenance access.
{
{       5.  The element must be in the DOWN state.
{
{       6.  The element must not be system-critical (i.e.  required for
{           continued system execution).
{
{       7.  If the element has channel(s) on its upline connection then :
{
{          a.  If the element is described in the active configuration as
{              being connected to another mainframe, the operator will be
{              asked to validate that the element is either DOWN, OFF or
{              unconfigured with respect to other mainframes.
{
{          b.  In a dual-state system, if the element is described in the
{              active configuration as being connected to the mainframe making
{              this request, then this request will attempt to acquire all
{              channels from the real-state system which are described in the
{              active configuration for the element.  Failure to acquire
{              all the necessary channels from the real-state system will
{              prevent the reservation of the element.  If the channels are
{              acquired, they will be returned to the real-state system when
{              the NOS/VE DEDICATED access to the element is released.
{
{       MSP$REQUEST_MAINTENANCE_ACCESS (ELEMENT, ACCESS, STATUS)
{
{ ELEMENT: (input)  This parameter specifies the identity of the system
{       element to which maintenance access is desired.  The identity of the
{       system element may be specified using either the name of the element
{       or its hardware address, if applicable.  In a multiple-IOU
{       configuration, the identity of the IOU must be supplied to uniquely
{       identify a data channel or channel-adapter.
{
{ ACCESS: (input)  This parameter specifies the kind of access which will be
{       performed by maintenance software.
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS:
{                     cme$element_already_reserved
{                     cme$lcm_element_not_found
{                     cme$element_state_not_proper
{                     mse$ma_concurrent_access_granted
{                     mse$ma_system_critical_element
{                     mse$maintenance_job_class_req
{
{         IDENTIFIER:  'MS'
{
*DECK DECK=MSH$UNFLAW_PAGE EXPAND=FALSE

{    The purpose of this request is to clear the flaw status indicator
{  for a specified page frame.  The page is immediately made available
{  for assignment (assuming it was in an unassigned state).
{
{        MSP$UNFLAW_PAGE(ELEMENT,RMA,STATUS)
{
{  ELEMENT: (input) This parameter specifies the identity of the system
{        element in whch the page frame resides.
{
{  RMA: (input) This parameter specifies the real byte address of the be-
{        ginning of the page frame to 'unflaw'.  RMA must be 0 modulo the
{        page size.
{
{  STATUS: (output) This parameter specifies the request status.
{}
*DECK DECK=MSH$VALIDATE_MEDIA_ACCESS EXPAND=FALSE
{
{   The purpose of this request is to validate maintenance access to the media
{ mounted on a mass storage device which is in the active configuration.
{
{   Two types of access are permitted to media:  CONCURRENT and DEDICATED.
{ CONCURRENT access implies that customer or system data recorded on the media
{ will not be erased, overwritten nor otherwise invalidated.  DEDICATED access
{ implies that any data recorded on the media is at risk:  therefore,
{ DEDICATED access will only be granted to media which does not have valid
{ customer or system data recorded on it.
{
{   In addition to the validation performed below, the NOS/VE operator, if
{ present, will be asked to confirm maintenance access to the media.
{
{   For CONCURRENT access to be granted, the storage device must:
{
{        1.  Be in either the ON or the DOWN state.
{
{        2.  Not be reserved (e.g.  cmp$reserve_element) nor assigned (e.g.
{            cmp$mount_storage_medium or ASSIGN_DEVICE command) to any job.
{
{        3.  Have been the object of an msp$request_maintenance_access request
{            for either CONCURRENT or DEDICATED maintenance.
{
{        4.  Have media mounted and online.
{
{   Successful attempts to obtain CONCURRENT maintenance access to media which
{ is a member of a NOS/VE mass storage set will be logged in the Engineering
{ Log (and potentially other log(s) at the discretion of the site.
{
{   For DEDICATED access to be granted, the storage device must:
{
{        1.  Be in the DOWN state.
{
{        2.  Not be reserved (e.g.  cmp$reserve_element) nor assigned (e.g.
{            cmp$mount_storage_medium or ASSIGN_DEVICE command) to any job.
{
{        3.  Have been the object of an msp$request_maintenance_access request
{            for DEDICATED maintenance.
{
{        4.  Not have media mounted which is a member of an active NOS/VE mass
{            storage set.
{
{       MSP$VALIDATE_MEDIA_ACCESS (STORAGE_DEVICE, ACCESS, STATUS)
{
{ STORAGE_DEVICE: (input)  This parameter specifies the identity of the
{       storage device whose media is the object of the access validation.
{
{ ACCESS: (input)  This parameter specifies the kind of access which will be
{       required by maintenance software.
{
{ STATUS: (output) This parameter specifies the request status.
{
{         CONDITIONS:
{                     cme$lcm_element_not_found,
{                     cme$privileged_job_required.
{
{         IDENTIFIER : 'CM'
{
{
*DECK DECK=MSM$MAINTENANCE_SERVICES_UTL EXPAND=TRUE
*copyc osd$default_pragmats
MODULE msm$maintenance_services_utl;
?? TITLE := '   Maintenance Services utility.' ??
?? NEWTITLE := '   Testing maintenance services interfaces ' ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$push_utility
*copyc clp$pop_utility
*copyc clp$scan_parameter_list
*copyc clp$get_value
*copyc clp$get_set_count
*copyc clp$get_value_count
*copyc clp$scan_command_file
*copyc clp$end_scan_command_file
*copyc clp$test_parameter
*copyc clp$put_display
*copyc clp$close_display
*copyc fsp$open_file
*copyc fsp$close_file
*copyc amp$put_next
*copyc amp$open
*copyc amp$close
*copyc clp$convert_integer_to_string
*copyc clp$open_display
*copyc clp$close_display
*copyc clp$put_partial_display
*copyc clp$new_display_line
*copyc cmp$convert_iou_number
*copyc cmp$convert_channel_number
*copyc cmp$get_pp_definition
*copyc cmp$convert_iou_name
*copyc msp$request_maintenance_access
*copyc msp$release_maintenance_access
*copyc msp$validate_media_access
*copyc pmp$open_object_library
*copyc pmp$find_module_in_library
*copyc pmp$close_object_library
*copyc cmp$get_channel_definition
*copyc cmp$get_element_definition
*copyc cmp$convert_pp_number
*copyc cmp$get_iou_definition
*copyc cmp$return_desc_data_by_lun_lpn
*copyc cmp$return_descriptor_data
*copyc cmp$return_logical_pp_number
*copyc cme$logical_configuration_mgr
*copyc msp$mount_storage_medium
*copyc msp$reserve_element
*copyc msp$release_element
*copyc msp$execute_pp_program
*copyc msp$get_pp_registers
*copyc msp$idle_pp
*copyc msp$resume_pp
?? POP ??
*copyc iot$pp_number
*copyc iot$logical_unit
*copyc dst$iou_resource
*copyc cmt$pp_registers
*copyc ost$caller_identifier
*copyc oss$job_paged_literal
*copyc osp$set_status_abnormal
*copyc cmc$condition_limits

  VAR
    msv$utility_name : [STATIC, READ, oss$job_paged_literal] ost$name :=
        'MAINTENANCE_SERVICES_UTILITY';


?? TITLE := '   MSP$MAINTENANCE_SERVICES_UTL', EJECT ??

  PROCEDURE [XDCL, #GATE] maintenance_services_utility (parameter_list :
             clt$parameter_list;
        VAR status : ost$status);

{ PDT msu_pdt (
{    status)

?? PUSH (LISTEXT := ON) ??

  VAR
    msu_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^msu_pdt_names, ^msu_pdt_params];

  VAR
    msu_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of clt$parameter_name_descriptor
      := [['STATUS', 1]];

  VAR
    msu_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

{ table msu_command_list t=c s=local sn=oss$job_paged_literal
{ command (display_channel_definition     ,discd) msp$display_channel_command cm=local
{ command (display_iou_definition         ,disid) msp$display_iou_command cm=local
{ command (display_pp_definition          ,dispd) msp$display_ppd_command cm=local
{ command (display_pp_registers           ,dispr) msp$display_ppr_command cm=local
{ command (execute_pp_program             ,exepp) msp$execute_pp_command cm=local
{ command (idle_pp                        ,idlp) msp$idle_pp_command cm=local
{ command (mount_storage_medium           ,mousm) msp$mount_storage_command cm=local
{ command (release_element                ,rele) msp$release_element_command cm=local
{ command (release_maintenance_access     ,relma) msp$release_access_command cm=local
{ command (request_maintenance_access     ,reqma) msp$request_access_command cm=local
{ command (reserve_element                ,rese) msp$reserve_element_command cm=local
{ command (resume_pp                      ,resp) msp$resume_pp_command cm=local
{ command (quit                           ,qui) msp$quit_command cm=local
{ command (test_return_descriptor_data    ,tesrdd) msp$test_return_descriptor_data cm=local
{ command (validate_media_access          ,valma) msp$validate_media_command cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??
VAR
  msu_command_list: [STATIC, READ, oss$job_paged_literal] ^clt$command_table := ^msu_command_list_entries,

  msu_command_list_entries: [STATIC, READ, oss$job_paged_literal] array [1 .. 30] of
      clt$command_table_entry := [
  {} ['DISCD                          ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^msp$display_channel_command],
  {} ['DISID                          ', clc$abbreviation_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^msp$display_iou_command],
  {} ['DISPD                          ', clc$abbreviation_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^msp$display_ppd_command],
  {} ['DISPLAY_CHANNEL_DEFINITION     ', clc$nominal_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^msp$display_channel_command],
  {} ['DISPLAY_IOU_DEFINITION         ', clc$nominal_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^msp$display_iou_command],
  {} ['DISPLAY_PP_DEFINITION          ', clc$nominal_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^msp$display_ppd_command],
  {} ['DISPLAY_PP_REGISTERS           ', clc$nominal_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^msp$display_ppr_command],
  {} ['DISPR                          ', clc$abbreviation_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^msp$display_ppr_command],
  {} ['EXECUTE_PP_PROGRAM             ', clc$nominal_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^msp$execute_pp_command],
  {} ['EXEPP                          ', clc$abbreviation_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^msp$execute_pp_command],
  {} ['IDLE_PP                        ', clc$nominal_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^msp$idle_pp_command],
  {} ['IDLP                           ', clc$abbreviation_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^msp$idle_pp_command],
  {} ['MOUNT_STORAGE_MEDIUM           ', clc$nominal_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^msp$mount_storage_command],
  {} ['MOUSM                          ', clc$abbreviation_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^msp$mount_storage_command],
  {} ['QUI                            ', clc$abbreviation_entry, clc$advertised_entry, 13,
        clc$automatically_log, clc$linked_call, ^msp$quit_command],
  {} ['QUIT                           ', clc$nominal_entry, clc$advertised_entry, 13,
        clc$automatically_log, clc$linked_call, ^msp$quit_command],
  {} ['RELE                           ', clc$abbreviation_entry, clc$advertised_entry, 8,
        clc$automatically_log, clc$linked_call, ^msp$release_element_command],
  {} ['RELEASE_ELEMENT                ', clc$nominal_entry, clc$advertised_entry, 8,
        clc$automatically_log, clc$linked_call, ^msp$release_element_command],
  {} ['RELEASE_MAINTENANCE_ACCESS     ', clc$nominal_entry, clc$advertised_entry, 9,
        clc$automatically_log, clc$linked_call, ^msp$release_access_command],
  {} ['RELMA                          ', clc$abbreviation_entry, clc$advertised_entry, 9,
        clc$automatically_log, clc$linked_call, ^msp$release_access_command],
  {} ['REQMA                          ', clc$abbreviation_entry, clc$advertised_entry, 10,
        clc$automatically_log, clc$linked_call, ^msp$request_access_command],
  {} ['REQUEST_MAINTENANCE_ACCESS     ', clc$nominal_entry, clc$advertised_entry, 10,
        clc$automatically_log, clc$linked_call, ^msp$request_access_command],
  {} ['RESE                           ', clc$abbreviation_entry, clc$advertised_entry, 11,
        clc$automatically_log, clc$linked_call, ^msp$reserve_element_command],
  {} ['RESERVE_ELEMENT                ', clc$nominal_entry, clc$advertised_entry, 11,
        clc$automatically_log, clc$linked_call, ^msp$reserve_element_command],
  {} ['RESP                           ', clc$abbreviation_entry, clc$advertised_entry, 12,
        clc$automatically_log, clc$linked_call, ^msp$resume_pp_command],
  {} ['RESUME_PP                      ', clc$nominal_entry, clc$advertised_entry, 12,
        clc$automatically_log, clc$linked_call, ^msp$resume_pp_command],
  {} ['TESRDD                         ', clc$abbreviation_entry, clc$advertised_entry, 14,
        clc$automatically_log, clc$linked_call, ^msp$test_return_descriptor_data],
  {} ['TEST_RETURN_DESCRIPTOR_DATA    ', clc$nominal_entry, clc$advertised_entry, 14,
        clc$automatically_log, clc$linked_call, ^msp$test_return_descriptor_data],
  {} ['VALIDATE_MEDIA_ACCESS          ', clc$nominal_entry, clc$advertised_entry, 15,
        clc$automatically_log, clc$linked_call, ^msp$validate_media_command],
  {} ['VALMA                          ', clc$abbreviation_entry, clc$advertised_entry, 15,
        clc$automatically_log, clc$linked_call, ^msp$validate_media_command]];

?? POP ??


  VAR
    caller_id: ost$caller_identifier;

    #caller_id(caller_id);
    IF caller_id.ring > 6 THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_ring_validation_error,
            'MSU', status);
      RETURN;
    IFEND;
    status.normal := TRUE;
  /main_program/
    BEGIN
      clp$scan_parameter_list (parameter_list, msu_pdt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$push_utility (msv$utility_name, clc$global_command_search, msu_command_list,
                  NIL, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$scan_command_file (clc$current_command_input, msv$utility_name,
          'MSU', status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$pop_utility (status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    END /main_program/;

  PROCEND maintenance_services_utility;

?? TITLE := '  Alias MSU ', EJECT ??
  PROCEDURE [XDCL, #GATE] msu (parameter_list : clt$parameter_list;
         VAR status : ost$status);

     maintenance_services_utility (parameter_list, status);

  PROCEND msu;

?? TITLE := '  msp$reserve_element_command', EJECT ??
  PROCEDURE msp$reserve_element_command (parameter_list : clt$parameter_list;
       VAR status : ost$status);


{  PDT reserve_element_pdt (
{     element_type, et : LIST of name = $required
{     element_name, n : LIST of name = $optional
{     channel, c : LIST of name = $optional
{     equipment_number, en : LIST OF integer 0 .. 7 = $optional
{     unit_number , un : LIST  OF integer 0 .. 63 = $optional
{     pp : list of name = $optional
{     iou : LIST OF name = $optional
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    reserve_element_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^reserve_element_pdt_names
      , ^reserve_element_pdt_params];

  VAR
    reserve_element_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 13] of
      clt$parameter_name_descriptor := [['ELEMENT_TYPE', 1], ['ET', 1], ['ELEMENT_NAME', 2], ['N', 2], [
      'CHANNEL', 3], ['C', 3], ['EQUIPMENT_NUMBER', 4], ['EN', 4], ['UNIT_NUMBER', 5], ['UN', 5], ['PP', 6], [
      'IOU', 7], ['STATUS', 8]];

  VAR
    reserve_element_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 8] of clt$parameter_descriptor
      := [

{ ELEMENT_TYPE ET }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
      osc$max_name_size]],

{ ELEMENT_NAME N }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
      osc$max_name_size]],

{ CHANNEL C }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
      osc$max_name_size]],

{ EQUIPMENT_NUMBER EN }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 7]],

{ UNIT_NUMBER UN }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 63
      ]],

{ PP }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
      osc$max_name_size]],

{ IOU }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
      osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

  VAR
    element : ^ARRAY [1 .. *] OF cmt$element_reservation,
    set_count : 0 .. clc$max_value_sets;

    status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, reserve_element_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('ELEMENT_TYPE', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    PUSH element : [1 .. set_count];
    crack_reserve_param (element, {Reserve=}TRUE, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    msp$reserve_element (element^, status);

  PROCEND msp$reserve_element_command;

?? TITLE := '  crack_reserve_param', EJECT ??

  PROCEDURE crack_reserve_param (
         element : ^ARRAY [1 .. *] of cmt$element_reservation;
         reserve_element : boolean;
     VAR status : ost$status);

  VAR
    channel_descriptor : cmt$channel_descriptor,
    channel_definition : cmt$data_channel_definition,
    pp_specified,
    name_specified,
    channel_specified,
    equipment_specified,
    iou_specified,
    unit_specified : boolean,
    value : clt$value,
    i,
    name_index,
    channel_index,
    controller_index,
    channel_adapter_index,
    communications_index,
    iou_index,
    pp_index,
    storage_device_index : integer,
    pp_descriptor : cmt$pp_descriptor,
    pp_definition : cmt$pp_definition,
    pp : dst$iou_resource,
    iou_name : cmt$element_name,
    set_count : 0 .. clc$max_value_sets;

    status.normal := TRUE;
  /main_program/
    BEGIN

      clp$test_parameter ('ELEMENT_NAME', name_specified, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$test_parameter ('CHANNEL', channel_specified, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$test_parameter ('EQUIPMENT_NUMBER', equipment_specified, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$test_parameter ('UNIT_NUMBER', unit_specified, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF name_specified THEN
        IF (channel_specified) OR (equipment_specified) OR (unit_specified) THEN
          osp$set_status_abnormal (cmc$configuration_management_id, 0,
            'Either NAME or HARDWARE ADDRESS entered.', status);
          EXIT /main_program/;
        IFEND;
      IFEND;

      clp$test_parameter ('PP', pp_specified, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$test_parameter ('IOU', iou_specified, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$get_set_count ('ELEMENT_TYPE', set_count, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      name_index := 1;
      channel_index := 1;
      controller_index := 1;
      channel_adapter_index := 1;
      communications_index := 1;
      iou_index := 1;
      pp_index := 1;
      storage_device_index := 1;

      FOR i := 1 TO set_count DO

        clp$get_value ('ELEMENT_TYPE', i, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        IF value.kind <> clc$name_value THEN
          osp$set_status_abnormal (cmc$configuration_management_id, 0,
            'Invalid ELEMENT_TYPE in RESERVE_ELEMENT command.', status);
          EXIT /main_program/;
        IFEND;

        IF value.name.value = '$PP' THEN
          IF NOT reserve_element AND NOT pp_specified THEN
            osp$set_status_abnormal (cmc$configuration_management_id, 0,
               'PP_NUMBER is required in RELEASE_ELEMENT command.', status);
            EXIT /main_program/;
          IFEND;

          element^ [i].element_type := cmc$pp_element;
          element^ [i].pp_reservation.selector := cmc$choose_any_pp;

          IF channel_specified OR pp_specified THEN
            IF iou_specified THEN
              clp$get_value ('IOU', iou_index, 1, clc$low, value, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              iou_index := iou_index + 1;
              iou_name := value.name.value;
            ELSE
              iou_name := 'IOU0';
            IFEND;
            IF pp_specified THEN
              clp$get_value ('PP', pp_index, 1, clc$low, value, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              pp_index := pp_index + 1;
              pp_descriptor.iou := iou_name;
              pp_descriptor.use_logical_identification := TRUE;
              pp_descriptor.pp_name := value.name.value;
              cmp$get_pp_definition (pp_descriptor, pp_definition, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              pp.number := pp_definition.number;
              IF pp_definition.concurrent THEN
                pp.channel_protocol := dsc$cpt_cio;
              ELSE
                pp.channel_protocol := dsc$cpt_nio;
              IFEND;
              cmp$convert_iou_name (iou_name, pp.iou_number, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;

              element^ [i].pp_reservation.selector := cmc$choose_specific_pp;
              IF reserve_element THEN
              cmp$convert_pp_number (pp, element^ [i].pp_reservation.desired_pp.ordinal);
              ELSE
                cmp$convert_pp_number (pp, element^ [i].pp_reservation.acquired_pp_identification.ordinal);
                element^ [i].pp_reservation.acquired_pp_identification.iou := iou_name;
              IFEND;
              element^ [i].pp_reservation.desired_pp.iou := iou_name;

            ELSE {use channel}

              clp$get_value ('CHANNEL', channel_index, 1, clc$low, value, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              channel_index := channel_index + 1;
              channel_descriptor.iou := iou_name;
              channel_descriptor.use_logical_identification := TRUE;
              channel_descriptor.name := value.name.value;
              cmp$get_channel_definition (channel_descriptor, channel_definition, status);
              IF NOT status.normal THEN
                IF status.condition = cme$lcm_element_not_found THEN
                  status.normal := TRUE;
                ELSE
                  EXIT /main_program/;
                IFEND;
              IFEND;
              element^ [i].pp_reservation.selector := cmc$choose_pp_by_channel;
              element^ [i].pp_reservation.channel.ordinal := channel_definition.ordinal;
              element^ [i].pp_reservation.channel.iou := iou_name;
            IFEND;
          IFEND;

        ELSEIF value.name.value = '$CHANNEL' THEN
          element^ [i].element_type := cmc$data_channel_element;
          IF iou_specified THEN
            clp$get_value ('IOU', iou_index, 1, clc$low, value, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            iou_index := iou_index + 1;
            iou_name := value.name.value;
          ELSE
            iou_name := 'IOU0';
          IFEND;
          element^ [i].channel_descriptor.iou := iou_name;

          IF name_specified THEN
            element^ [i].channel_descriptor.use_logical_identification := TRUE;
            clp$get_value ('ELEMENT_NAME', name_index, 1, clc$low, value, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            IF value.kind <> clc$name_value THEN
              osp$set_status_abnormal (cmc$configuration_management_id, 0,
                'Invalid ELEMENT_NAME in RESERVE_ELEMENT command.', status);
              EXIT /main_program/;
            IFEND;
            element^ [i].channel_descriptor.name := value.name.value;
            name_index := name_index + 1;
          ELSE
            clp$get_value ('CHANNEL', channel_index, 1, clc$low, value, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            channel_descriptor.iou := iou_name;
            channel_descriptor.use_logical_identification := TRUE;
            channel_descriptor.name := value.name.value;
            cmp$get_channel_definition (channel_descriptor, channel_definition, status);
            IF NOT status.normal THEN
              IF status.condition = cme$lcm_element_not_found THEN
                status.normal := TRUE;
              ELSE
                EXIT /main_program/;
              IFEND;
            IFEND;
            element^ [i].channel_descriptor.use_logical_identification := FALSE;
            element^ [i].channel_descriptor.channel_ordinal := channel_definition.ordinal;
            element^ [i].channel_descriptor.number := channel_definition.number;
            element^ [i].channel_descriptor.concurrent := channel_definition.concurrent;
            channel_index := channel_index + 1;
          IFEND;

        ELSEIF value.name.value = '$CONTROLLER' THEN
          element^ [i].element_type := cmc$controller_element;
          IF name_specified THEN
            element^ [i].peripheral_descriptor.use_logical_identification := TRUE;
            clp$get_value ('ELEMENT_NAME', name_index, 1, clc$low, value, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            IF value.kind <> clc$name_value THEN
              osp$set_status_abnormal (cmc$configuration_management_id, 0,
                'Invalid ELEMENT_NAME in RESERVE_ELEMENT command.', status);
              EXIT /main_program/;
            IFEND;
            element^ [i].peripheral_descriptor.element_name := value.name.value;
            name_index := name_index + 1;
          ELSE
            element^ [i].peripheral_descriptor.use_logical_identification := FALSE;
            element^ [i].peripheral_descriptor.hardware_address.physical_address_specifier :=
              $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address];

            clp$get_value ('CHANNEL', channel_index, 1, clc$low, value, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            channel_descriptor.iou := iou_name;
            channel_descriptor.use_logical_identification := TRUE;
            channel_descriptor.name := value.name.value;
            cmp$get_channel_definition (channel_descriptor, channel_definition, status);
            IF NOT status.normal THEN
              IF status.condition = cme$lcm_element_not_found THEN
                status.normal := TRUE;
              ELSE
                EXIT /main_program/;
              IFEND;
            IFEND;
            element^ [i].peripheral_descriptor.hardware_address.channel.ordinal :=
                 channel_definition.ordinal;
            channel_index := channel_index + 1;

            clp$get_value ('EQUIPMENT_NUMBER', controller_index, 1, clc$low, value, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            IF value.kind <> clc$integer_value THEN
              osp$set_status_abnormal (cmc$configuration_management_id, 0,
                'Invalid EQUIPMENT_NUMBER in RESERVE_ELEMENT command.', status);
              EXIT /main_program/;
            IFEND;
            element^ [i].peripheral_descriptor.hardware_address.channel_address := value.int.value;
            controller_index := controller_index + 1;

            IF iou_specified THEN
              clp$get_value ('IOU', iou_index, 1, clc$low, value, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              iou_name := value.name.value;
              iou_index := iou_index + 1;
            ELSE
              iou_name := 'IOU0'
            IFEND;
            element^ [i].peripheral_descriptor.hardware_address.iou := iou_name;
          IFEND;

        ELSEIF value.name.value = '$CA' THEN
          element^ [i].element_type := cmc$channel_adapter_element;
          IF name_specified THEN
            element^ [i].peripheral_descriptor.use_logical_identification := TRUE;
            clp$get_value ('ELEMENT_NAME', name_index, 1, clc$low, value, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            IF value.kind <> clc$name_value THEN
              osp$set_status_abnormal (cmc$configuration_management_id, 0,
                'Invalid ELEMENT_NAME in RESERVE_ELEMENT command.', status);
              EXIT /main_program/;
            IFEND;
            element^ [i].peripheral_descriptor.element_name := value.name.value;
            name_index := name_index + 1;
          ELSE
            element^ [i].peripheral_descriptor.use_logical_identification := FALSE;
            element^ [i].peripheral_descriptor.hardware_address.physical_address_specifier :=
              $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address];
            IF iou_specified THEN
              clp$get_value ('IOU', iou_index, 1, clc$low, value, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              iou_name := value.name.value;
              iou_index := iou_index + 1;
            ELSE
              iou_name := 'IOU0'
            IFEND;
            element^ [i].peripheral_descriptor.hardware_address.iou := iou_name;

            clp$get_value ('CHANNEL', channel_index, 1, clc$low, value, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            channel_descriptor.iou := iou_name;
            channel_descriptor.use_logical_identification := TRUE;
            channel_descriptor.name := value.name.value;
            cmp$get_channel_definition (channel_descriptor, channel_definition, status);
            IF NOT status.normal THEN
              IF status.condition = cme$lcm_element_not_found THEN
                status.normal := TRUE;
              ELSE
                EXIT /main_program/;
              IFEND;
            IFEND;
            element^ [i].peripheral_descriptor.hardware_address.channel.ordinal :=
                  channel_definition.ordinal;
            channel_index := channel_index + 1;

            clp$get_value ('EQUIPMENT_NUMBER', channel_adapter_index, 1, clc$low, value, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            IF value.kind <> clc$integer_value THEN
              osp$set_status_abnormal (cmc$configuration_management_id, 0,
                'Invalid EQUIPMENT_NUMBER in RESERVE_ELEMENT command.', status);
              EXIT /main_program/;
            IFEND;
            element^ [i].peripheral_descriptor.hardware_address.channel_address := value.int.value;
            channel_adapter_index := channel_adapter_index + 1;
          IFEND;
        ELSEIF value.name.value = '$COMMUNICATIONS' THEN
          element^ [i].element_type := cmc$communications_element;
          IF name_specified THEN
            element^ [i].peripheral_descriptor.use_logical_identification := TRUE;
            clp$get_value ('ELEMENT_NAME', name_index, 1, clc$low, value, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            IF value.kind <> clc$name_value THEN
              osp$set_status_abnormal (cmc$configuration_management_id, 0,
                'Invalid ELEMENT_NAME in RESERVE_ELEMENT command.', status);
              EXIT /main_program/;
            IFEND;
            element^ [i].peripheral_descriptor.element_name := value.name.value;
            name_index := name_index + 1;
          ELSE
            element^ [i].peripheral_descriptor.use_logical_identification := FALSE;
            element^ [i].peripheral_descriptor.hardware_address.physical_address_specifier :=
              $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address];

            IF iou_specified THEN
              clp$get_value ('IOU', iou_index, 1, clc$low, value, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              iou_name := value.name.value;
              iou_index := iou_index + 1;
            ELSE
              iou_name := 'IOU0'
            IFEND;
            element^ [i].peripheral_descriptor.hardware_address.iou := iou_name;

            clp$get_value ('CHANNEL', channel_index, 1, clc$low, value, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            channel_descriptor.iou := iou_name;
            channel_descriptor.use_logical_identification := TRUE;
            channel_descriptor.name := value.name.value;
            cmp$get_channel_definition (channel_descriptor, channel_definition, status);
            IF NOT status.normal THEN
              IF status.condition = cme$lcm_element_not_found THEN
                status.normal := TRUE;
              ELSE
                EXIT /main_program/;
              IFEND;
            IFEND;

            element^ [i].peripheral_descriptor.hardware_address.channel.ordinal :=
                   channel_definition.ordinal;
            channel_index := channel_index + 1;

            clp$get_value ('EQUIPMENT_NUMBER', channel_adapter_index, 1, clc$low, value, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            IF value.kind <> clc$integer_value THEN
              osp$set_status_abnormal (cmc$configuration_management_id, 0,
                'Invalid EQUIPMENT_NUMBER in RESERVE_ELEMENT command.', status);
              EXIT /main_program/;
            IFEND;
            element^ [i].peripheral_descriptor.hardware_address.channel_address := value.int.value;
            communications_index := communications_index + 1;
          IFEND;

        ELSEIF value.name.value = '$STORAGE_DEVICE' THEN
          element^ [i].element_type := cmc$storage_device_element;
          IF name_specified THEN
            element^ [i].peripheral_descriptor.use_logical_identification := TRUE;
            clp$get_value ('ELEMENT_NAME', name_index, 1, clc$low, value, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            IF value.kind <> clc$name_value THEN
              osp$set_status_abnormal (cmc$configuration_management_id, 0,
                'Invalid ELEMENT_NAME in RESERVE_ELEMENT command.', status);
              EXIT /main_program/;
            IFEND;
            element^ [i].peripheral_descriptor.element_name := value.name.value;
            name_index := name_index + 1;
          ELSE
            element^ [i].peripheral_descriptor.use_logical_identification := FALSE;
            element^ [i].peripheral_descriptor.hardware_address.physical_address_specifier :=
              $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address, cmc$unit_address];

            IF iou_specified THEN
              clp$get_value ('IOU', iou_index, 1, clc$low, value, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              iou_name := value.name.value;
              iou_index := iou_index + 1;
            ELSE
              iou_name := 'IOU0'
            IFEND;
            element^ [i].peripheral_descriptor.hardware_address.iou := iou_name;

            clp$get_value ('CHANNEL', channel_index, 1, clc$low, value, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
            channel_descriptor.iou := iou_name;
            channel_descriptor.use_logical_identification := TRUE;
            channel_descriptor.name := value.name.value;
            cmp$get_channel_definition (channel_descriptor, channel_definition, status);
            IF NOT status.normal THEN
              IF status.condition = cme$lcm_element_not_found THEN
                status.normal := TRUE;
              ELSE
                EXIT /main_program/;
              IFEND;
            IFEND;

            element^ [i].peripheral_descriptor.hardware_address.channel.ordinal :=
                  channel_definition.ordinal;
            channel_index := channel_index + 1;

            clp$get_value ('EQUIPMENT_NUMBER', controller_index, 1, clc$low, value, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            IF value.kind <> clc$integer_value THEN
              osp$set_status_abnormal (cmc$configuration_management_id, 0,
                'Invalid EQUIPMENT_NUMBER in RESERVE_ELEMENT command.', status);
              EXIT /main_program/;
            IFEND;
            element^ [i].peripheral_descriptor.hardware_address.channel_address := value.int.value;
            controller_index := controller_index + 1;

            clp$get_value ('UNIT_NUMBER', storage_device_index, 1, clc$low, value, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;

            IF value.kind <> clc$integer_value THEN
              osp$set_status_abnormal (cmc$configuration_management_id, 0,
                'Invalid UNIT_NUMBER in RESERVE_ELEMENT command.', status);
              EXIT /main_program/;
            IFEND;
            element^ [i].peripheral_descriptor.hardware_address.unit_address := value.int.value;
            storage_device_index := storage_device_index + 1;
          IFEND;
        ELSE
          osp$set_status_abnormal (cmc$configuration_management_id, 0,
            'Invalid ELEMENT_TYPE in RESERVE_ELEMENT command.', status);
          EXIT /main_program/;
        IFEND;

      FOREND;

    END /main_program/;

  PROCEND crack_reserve_param;

?? TITLE := '  msp$release_element_command',EJECT ??
  PROCEDURE msp$release_element_command (parameter_list : clt$parameter_list;
       VAR status : ost$status);


{  PDT release_element_pdt (
{     element_type, et : LIST of name = $required
{     element_name, n : LIST of name = $optional
{     channel, c : LIST of name = $optional
{     equipment_number, en : LIST OF integer 0 .. 7 = $optional
{     unit_number , un : LIST  OF integer 0 .. 63 = $optional
{     pp : list of name = $optional
{     iou : LIST OF name = $optional
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    release_element_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^release_element_pdt_names
      , ^release_element_pdt_params];

  VAR
    release_element_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 13] of
      clt$parameter_name_descriptor := [['ELEMENT_TYPE', 1], ['ET', 1], ['ELEMENT_NAME', 2], ['N', 2], [
      'CHANNEL', 3], ['C', 3], ['EQUIPMENT_NUMBER', 4], ['EN', 4], ['UNIT_NUMBER', 5], ['UN', 5], ['PP', 6], [
      'IOU', 7], ['STATUS', 8]];

  VAR
    release_element_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 8] of clt$parameter_descriptor
      := [

{ ELEMENT_TYPE ET }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
      osc$max_name_size]],

{ ELEMENT_NAME N }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
      osc$max_name_size]],

{ CHANNEL C }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
      osc$max_name_size]],

{ EQUIPMENT_NUMBER EN }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 7]],

{ UNIT_NUMBER UN }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 63
      ]],

{ PP }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
      osc$max_name_size]],

{ IOU }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
      osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

  VAR
    element : ^ARRAY [1 .. *] OF cmt$element_reservation,
    set_count : 0 .. clc$max_value_sets;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, release_element_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('ELEMENT_TYPE', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH element : [1 .. set_count];
    crack_reserve_param (element, {Reserve=} FALSE, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    msp$release_element (element^, status);

  PROCEND msp$release_element_command;

?? TITLE := '  msp$request_access_command', EJECT ??
  PROCEDURE msp$request_access_command (parameter_list : clt$parameter_list;
        VAR status : ost$status);

{  PDT request_access_pdt (
{     element_type, et : name = $required
{     access_type , at : name = $required
{     element_name, n : name = $optional
{     channel, c : name = $optional
{     equipment_number, en : integer 0 .. 7 = $optional
{     unit_number , un : integer 0 .. 63 = $optional
{     iou : name = IOU0
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    request_access_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^request_access_pdt_names,
      ^request_access_pdt_params];

  VAR
    request_access_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 14] of
      clt$parameter_name_descriptor := [['ELEMENT_TYPE', 1], ['ET', 1], ['ACCESS_TYPE', 2], ['AT', 2], [
      'ELEMENT_NAME', 3], ['N', 3], ['CHANNEL', 4], ['C', 4], ['EQUIPMENT_NUMBER', 5], ['EN', 5], [
      'UNIT_NUMBER', 6], ['UN', 6], ['IOU', 7], ['STATUS', 8]];

  VAR
    request_access_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 8] of clt$parameter_descriptor
      := [

{ ELEMENT_TYPE ET }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ ACCESS_TYPE AT }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ ELEMENT_NAME N }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ CHANNEL C }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ EQUIPMENT_NUMBER EN }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 7]],

{ UNIT_NUMBER UN }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 63]],

{ IOU }
    [[clc$optional_with_default, ^request_access_pdt_dv7], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    request_access_pdt_dv7: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'IOU0';

?? POP ??

  VAR
    access : mst$access_type,
    element_descriptor : cmt$element_descriptor;

   status.normal := TRUE;
   clp$scan_parameter_list (parameter_list, request_access_pdt, status);
   IF NOT status.normal THEN
     RETURN;
   IFEND;
   crack_request_param (TRUE, access, element_descriptor, status);
   IF NOT status.normal THEN
     RETURN;
   IFEND;
   msp$request_maintenance_access (element_descriptor, access, status);

  PROCEND msp$request_access_command;

?? TITLE := '   crack_request_param', EJECT ??

  PROCEDURE crack_request_param (request_maintenance : boolean;
      VAR access_type : mst$access_type;
      VAR element_descriptor : cmt$element_descriptor;
      VAR status : ost$status);


  VAR
    channel_name : cmt$element_name,
    channel_descriptor : cmt$channel_descriptor,
    channel_definition : cmt$data_channel_definition,
    channel_specified,
    equipment_specified,
    unit_specified,
    name_specified : boolean,
    value : clt$value,
    equipment_number,
    unit_number : integer,
    iou_name,
    element_name : cmt$element_name;

    status.normal := TRUE;
  /main_program/
    BEGIN

      clp$test_parameter ('ELEMENT_NAME', name_specified, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF name_specified THEN
        clp$get_value ('ELEMENT_NAME', 1, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        IF value.kind <> clc$name_value THEN
          osp$set_status_abnormal (cmc$configuration_management_id, 0,
            'Invalid ELEMENT_NAME in REQUEST_MAINTENANCE_ACCESS command.', status);
          EXIT /main_program/;
        ELSE
          element_name := value.name.value;
        IFEND;
      IFEND;
      clp$get_value ('IOU', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      iou_name := value.name.value;

      clp$test_parameter ('CHANNEL', channel_specified, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF channel_specified THEN
        clp$get_value ('CHANNEL', 1, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        channel_name := value.name.value;
        channel_descriptor.iou := iou_name;
        channel_descriptor.use_logical_identification := TRUE;
        channel_descriptor.name := value.name.value;
        cmp$get_channel_definition (channel_descriptor, channel_definition, status);
        IF NOT status.normal THEN
          IF status.condition = cme$lcm_element_not_found THEN
            status.normal := TRUE;
          ELSE
            EXIT /main_program/;
          IFEND;
        IFEND;
      IFEND;

      clp$test_parameter ('EQUIPMENT_NUMBER', equipment_specified, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF equipment_specified THEN
        clp$get_value ('EQUIPMENT_NUMBER', 1, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        IF value.kind <> clc$integer_value THEN
          osp$set_status_abnormal (cmc$configuration_management_id, 0,
            'Invalid EQUIPMENT_NUMBER in REQUEST_MAINTENANCE_ACCESS command.', status);
          EXIT /main_program/;
        ELSE
          equipment_number := value.int.value;
        IFEND;
      IFEND;

      clp$test_parameter ('UNIT_NUMBER', unit_specified, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF unit_specified THEN
        clp$get_value ('UNIT_NUMBER', 1, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        IF value.kind <> clc$integer_value THEN
          osp$set_status_abnormal (cmc$configuration_management_id, 0,
            'Invalid UNIT_NUMBER in REQUEST_MAINTENANCE_ACCESS command.', status);
          EXIT /main_program/;
        ELSE
          unit_number := value.int.value;
        IFEND;
      IFEND;


      IF name_specified THEN
        IF (channel_specified) OR (equipment_specified) OR (unit_specified) THEN
          osp$set_status_abnormal (cmc$configuration_management_id, 0,
            'Either NAME or HARDWARE ADDRESS entered.', status);
          EXIT /main_program/;
        IFEND;
      IFEND;

      IF request_maintenance THEN

        clp$get_value ('ACCESS_TYPE', 1, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        IF value.kind <> clc$name_value THEN
          osp$set_status_abnormal (cmc$configuration_management_id, 0,
            'Invalid ACCESS_TYPE in REQUEST_MAINTENANCE_ACCESS command.', status);
          EXIT /main_program/;
        IFEND;

        IF (value.name.value <> 'C') AND
            (value.name.value <> 'D') THEN
          osp$set_status_abnormal (cmc$configuration_management_id, 0,
            'Invalid ACCESS_TYPE in REQUEST_MAINTENANCE_ACCESS command.', status);
          EXIT /main_program/;
        ELSE
          IF value.name.value = 'C' THEN
            access_type := msc$concurrent_access;
          ELSE
            access_type := msc$dedicated_access;
          IFEND;
        IFEND;
      IFEND;
      clp$get_value ('ELEMENT_TYPE', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF value.kind <> clc$name_value THEN
        osp$set_status_abnormal (cmc$configuration_management_id, 0,
          'Invalid ELEMENT_TYPE in REQUEST_MAINTENANCE_ACCESS command.', status);
        EXIT /main_program/;
      IFEND;

      IF value.name.value = '$CHANNEL' THEN
        element_descriptor.element_type := cmc$data_channel_element;
        element_descriptor.channel_descriptor.iou := iou_name;
        IF name_specified THEN
          element_descriptor.channel_descriptor.use_logical_identification := TRUE;
          element_descriptor.channel_descriptor.name := element_name;
        ELSE
          element_descriptor.channel_descriptor.use_logical_identification := FALSE;
          element_descriptor.channel_descriptor.channel_ordinal := channel_definition.ordinal;
          element_descriptor.channel_descriptor.number := channel_definition.number;
          element_descriptor.channel_descriptor.concurrent := channel_definition.concurrent;
        IFEND;

      ELSEIF value.name.value = '$CONTROLLER' THEN
        element_descriptor.element_type := cmc$controller_element;
        IF name_specified THEN
          element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
          element_descriptor.peripheral_descriptor.element_name := element_name;
        ELSE
          element_descriptor.peripheral_descriptor.use_logical_identification := FALSE;
          element_descriptor.peripheral_descriptor.hardware_address.physical_address_specifier :=
            $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address];
          element_descriptor.peripheral_descriptor.hardware_address.iou := iou_name;
          element_descriptor.peripheral_descriptor.hardware_address.channel.ordinal :=
                  channel_definition.ordinal;
          element_descriptor.peripheral_descriptor.
            hardware_address.channel_address := equipment_number;
        IFEND;

      ELSEIF value.name.value = '$STORAGE_DEVICE' THEN
        element_descriptor.element_type := cmc$storage_device_element;
        IF name_specified THEN
          element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
          element_descriptor.peripheral_descriptor.element_name := element_name;
        ELSE
          element_descriptor.peripheral_descriptor.use_logical_identification := FALSE;
          element_descriptor.peripheral_descriptor.hardware_address.physical_address_specifier :=
            $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address, cmc$unit_address];
          element_descriptor.peripheral_descriptor.hardware_address.iou := iou_name;
          element_descriptor.peripheral_descriptor.hardware_address.channel.ordinal :=
                  channel_definition.ordinal;
          element_descriptor.peripheral_descriptor.
            hardware_address.channel_address := equipment_number;
          element_descriptor.peripheral_descriptor.
            hardware_address.unit_address := unit_number;
        IFEND;
      ELSEIF value.name.value = '$COMMUNICATIONS' THEN
        element_descriptor.element_type := cmc$communications_element;
        IF name_specified THEN
          element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
          element_descriptor.peripheral_descriptor.element_name := element_name;
        ELSE
          element_descriptor.peripheral_descriptor.use_logical_identification := FALSE;
          element_descriptor.peripheral_descriptor.hardware_address.physical_address_specifier :=
            $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address];
          element_descriptor.peripheral_descriptor.hardware_address.iou := iou_name;
          element_descriptor.peripheral_descriptor.hardware_address.channel.ordinal :=
                  channel_definition.ordinal;
          element_descriptor.peripheral_descriptor.
            hardware_address.channel_address := equipment_number;
        IFEND;

      ELSE
        osp$set_status_abnormal (cmc$configuration_management_id, 0,
          'Invalid ELEMENT_TYPE in REQUEST_MAINTENANCE_ACCESS command.', status);
        EXIT /main_program/;
      IFEND;
   END /main_program/;

  PROCEND crack_request_param;


?? TITLE := '  msp$release_access_command', EJECT ??
  PROCEDURE msp$release_access_command (parameter_list : clt$parameter_list;
        VAR status : ost$status);

{  PDT release_access_pdt (
{     element_type, et : name = $required
{     element_name, n : name = $optional
{     channel, c : name = $optional
{     equipment_number, en : integer 0 .. 7 = $optional
{     unit_number , un : integer 0 .. 63 = $optional
{     iou : name = IOU0
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    release_access_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^release_access_pdt_names,
      ^release_access_pdt_params];

  VAR
    release_access_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 12] of
      clt$parameter_name_descriptor := [['ELEMENT_TYPE', 1], ['ET', 1], ['ELEMENT_NAME', 2], ['N', 2], [
      'CHANNEL', 3], ['C', 3], ['EQUIPMENT_NUMBER', 4], ['EN', 4], ['UNIT_NUMBER', 5], ['UN', 5], ['IOU', 6],
      ['STATUS', 7]];

  VAR
    release_access_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 7] of clt$parameter_descriptor
      := [

{ ELEMENT_TYPE ET }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ ELEMENT_NAME N }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ CHANNEL C }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ EQUIPMENT_NUMBER EN }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 7]],

{ UNIT_NUMBER UN }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 63]],

{ IOU }
    [[clc$optional_with_default, ^release_access_pdt_dv6], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    release_access_pdt_dv6: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'IOU0';

?? POP ??

  VAR
    access_type : mst$access_type,
    element_descriptor : cmt$element_descriptor;

    status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, release_access_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_request_param (FALSE, access_type, element_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    msp$release_maintenance_access (element_descriptor, status);

  PROCEND msp$release_access_command;

?? TITLE := '  msp$mount_storage_command', EJECT ??
  PROCEDURE msp$mount_storage_command (parameter_list : clt$parameter_list;
        VAR status : ost$status);

{  PDT mount_storage_pdt (
{     medium, m : name = $required
{     write_access, wa : name = $required
{     wait_for_attachment, wfa : name = $required
{     element_name, n : name = $optional
{     channel, c : name = $optional
{     equipment_number, en : integer 0 .. 7 = $optional
{     unit_number , un : integer 0 .. 63 = $optional
{     iou : name = IOU0
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    mount_storage_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^mount_storage_pdt_names,
      ^mount_storage_pdt_params];

  VAR
    mount_storage_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 16] of
      clt$parameter_name_descriptor := [['MEDIUM', 1], ['M', 1], ['WRITE_ACCESS', 2], ['WA', 2], [
      'WAIT_FOR_ATTACHMENT', 3], ['WFA', 3], ['ELEMENT_NAME', 4], ['N', 4], ['CHANNEL', 5], ['C', 5], [
      'EQUIPMENT_NUMBER', 6], ['EN', 6], ['UNIT_NUMBER', 7], ['UN', 7], ['IOU', 8], ['STATUS', 9]];

  VAR
    mount_storage_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 9] of clt$parameter_descriptor
      := [

{ MEDIUM M }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ WRITE_ACCESS WA }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ WAIT_FOR_ATTACHMENT WFA }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ ELEMENT_NAME N }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ CHANNEL C }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ EQUIPMENT_NUMBER EN }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 7]],

{ UNIT_NUMBER UN }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 63]],

{ IOU }
    [[clc$optional_with_default, ^mount_storage_pdt_dv8], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    mount_storage_pdt_dv8: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'IOU0';

?? POP ??

  VAR
    channel_descriptor: cmt$channel_descriptor,
    channel_definition : cmt$data_channel_definition,
    channel_specified,
    equipment_specified,
    unit_specified,
    name_specified : boolean,
    value : clt$value,
    equipment_number,
    unit_number : integer,
    iou_name,
    element_name : cmt$element_name,
    medium : rmt$external_vsn,
    write_access : BOOLEAN,
    wait_for_attachment : fst$wait_for_attachment,
    storage_device : cmt$peripheral_descriptor;

    status.normal := TRUE;
  /main_program/
    BEGIN
      clp$scan_parameter_list (parameter_list, mount_storage_pdt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$test_parameter ('ELEMENT_NAME', name_specified, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF name_specified THEN
        clp$get_value ('ELEMENT_NAME', 1, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        IF value.kind <> clc$name_value THEN
          osp$set_status_abnormal (cmc$configuration_management_id, 0,
            'Invalid ELEMENT_NAME in MOUNT_STORAGE_MEDIUM command.', status);
          EXIT /main_program/;
        ELSE
          element_name := value.name.value;
        IFEND;
      IFEND;

      clp$get_value ('IOU', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      iou_name := value.name.value;
      clp$test_parameter ('CHANNEL', channel_specified, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF channel_specified THEN
        clp$get_value ('CHANNEL', 1, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        channel_descriptor.iou := iou_name;
        channel_descriptor.use_logical_identification := TRUE;
        channel_descriptor.name := value.name.value;
        cmp$get_channel_definition (channel_descriptor, channel_definition, status);
        IF NOT status.normal THEN
          IF status.condition = cme$lcm_element_not_found THEN
            status.normal := TRUE;
          ELSE
            EXIT /main_program/;
          IFEND;
        IFEND;

      IFEND;

      clp$test_parameter ('EQUIPMENT_NUMBER', equipment_specified, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF equipment_specified THEN
        clp$get_value ('EQUIPMENT_NUMBER', 1, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        IF value.kind <> clc$integer_value THEN
          osp$set_status_abnormal (cmc$configuration_management_id, 0,
            'Invalid EQUIPMENT_NUMBER in MOUNT_STORAGE_MEDIUM command.', status);
          EXIT /main_program/;
        ELSE
          equipment_number := value.int.value;
        IFEND;
      IFEND;

      clp$test_parameter ('UNIT_NUMBER', unit_specified, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF unit_specified THEN
        clp$get_value ('UNIT_NUMBER', 1, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        IF value.kind <> clc$integer_value THEN
          osp$set_status_abnormal (cmc$configuration_management_id, 0,
            'Invalid UNIT_NUMBER in MOUNT_STORAGE_MEDIUM command.', status);
          EXIT /main_program/;
        ELSE
          unit_number := value.int.value;
        IFEND;
      IFEND;


      IF name_specified THEN
        IF (channel_specified) OR (equipment_specified) OR (unit_specified) THEN
          osp$set_status_abnormal (cmc$configuration_management_id, 0,
            'Either NAME or HARDWARE ADDRESS entered.', status);
          EXIT /main_program/;
        ELSE
          storage_device.use_logical_identification := TRUE;
          storage_device.element_name := element_name;
        IFEND;
      ELSE
        storage_device.use_logical_identification := FALSE;
        storage_device.hardware_address.physical_address_specifier :=
          $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address, cmc$unit_address];
        storage_device.hardware_address.iou := iou_name;
        storage_device.hardware_address.channel.ordinal := channel_definition.ordinal;
        storage_device.hardware_address.channel_address := equipment_number;
        storage_device.hardware_address.unit_address := unit_number;
      IFEND;

      clp$get_value ('MEDIUM', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF value.kind <> clc$name_value THEN
        osp$set_status_abnormal (cmc$configuration_management_id, 0,
          'Invalid MEDIUM in MOUNT_STORAGE_MEDIUM command.', status);
        EXIT /main_program/;
      ELSE
        medium := value.name.value;
      IFEND;

      clp$get_value ('WRITE_ACCESS', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF value.kind <> clc$name_value THEN
        osp$set_status_abnormal (cmc$configuration_management_id, 0,
          'Invalid WRITE_ACCESS in MOUNT_STORAGE_MEDIUM command.', status);
        EXIT /main_program/;
      ELSE
        IF (value.name.value <> 'T') AND
            (value.name.value <> 'F') THEN
          osp$set_status_abnormal (cmc$configuration_management_id, 0,
            'Invalid WRITE_ACCESS in MOUNT_STORAGE_MEDIUM command.', status);
          EXIT /main_program/;
        ELSE
          IF value.name.value = 'T' THEN
            write_access := TRUE;
          ELSE
            write_access := FALSE;
          IFEND;
        IFEND;
      IFEND;

      clp$get_value ('WAIT_FOR_ATTACHMENT', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF value.kind <> clc$name_value THEN
        osp$set_status_abnormal (cmc$configuration_management_id, 0,
          'Invalid WAIT_FOR_ATTACHMENT in MOUNT_STORAGE_MEDIUM command.', status);
        EXIT /main_program/;
      ELSE
        IF (value.name.value <> 'T') AND
            (value.name.value <> 'F') THEN
          osp$set_status_abnormal (cmc$configuration_management_id, 0,
            'Invalid WAIT_FOR_ATTACHMENT in MOUNT_STORAGE_MEDIUM command.', status);
          EXIT /main_program/;
        ELSE
          IF value.name.value = 'T' THEN
            wait_for_attachment.wait := osc$wait;
          ELSE
            wait_for_attachment.wait := osc$nowait;
          IFEND;
        IFEND;
      IFEND;

      msp$mount_storage_medium (
        storage_device, medium, write_access, wait_for_attachment, status);

    END /main_program/;

  PROCEND msp$mount_storage_command;

?? TITLE := '  msp$validate_media_command', EJECT ??
  PROCEDURE msp$validate_media_command (parameter_list : clt$parameter_list;
        VAR status : ost$status);

{ PDT validate_media_pdt (
{    element_name, n : name = $required
{    access, a : name = $required
{    status)

  VAR
    validate_media_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^validate_media_pdt_names,
      ^validate_media_pdt_params];

  VAR
    validate_media_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['ELEMENT_NAME', 1], ['N', 1], [
      'ACCESS', 2], ['A', 2], ['STATUS', 3]];

  VAR
    validate_media_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor
      := [

{ ELEMENT_NAME N }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ ACCESS A }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    value : clt$value,
    access : mst$access_type,
    storage_device : cmt$element_name;

    status.normal := TRUE;
  /main_program/
    BEGIN
      clp$scan_parameter_list (parameter_list, validate_media_pdt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$get_value ('ELEMENT_NAME', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF value.kind <> clc$name_value THEN
        osp$set_status_abnormal (cmc$configuration_management_id, 0,
          'Invalid ELEMENT_NAME in VALIDATE_MEDIA_ACCESS command.', status);
        EXIT /main_program/;
      ELSE
        storage_device := value.name.value;
      IFEND;

      clp$get_value ('ACCESS', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF value.kind <> clc$name_value THEN
        osp$set_status_abnormal (cmc$configuration_management_id, 0,
          'Invalid ACCESS in VALIDATE_MEDIA_ACCESS command.', status);
        EXIT /main_program/;
      ELSE
        IF (value.name.value <> 'D') AND
            (value.name.value <> 'C') THEN
          osp$set_status_abnormal (cmc$configuration_management_id, 0,
            'Invalid WRITE_ACCESS in VALIDATE_MEDIA_ACCESS command.', status);
          EXIT /main_program/;
        ELSE
          IF value.name.value = 'D' THEN
            access := msc$dedicated_access;
          ELSE
            access := msc$concurrent_access;
          IFEND;
        IFEND;
      IFEND;

      msp$validate_media_access (storage_device, access, status);

    END /main_program/;

  PROCEND msp$validate_media_command;

?? TITLE := '  msp$execute_pp_command', EJECT ??
  PROCEDURE msp$execute_pp_command (parameter_list : clt$parameter_list;
        VAR status : ost$status);

{      PDT execute_pp_pdt (
{        pp : LIST 1 .. 2 OF name = $required
{        iou : LIST 1 .. 2 OF name = IOU0
{        channel, c : LIST 1 .. 2 OF name = $optional
{        equipment_number, en : LIST 1 .. 2 OF integer 0 .. 7 = $optional
{        unit_number , un : LIST 1 .. 2 OF integer 0 .. 63 = $optional
{        object_library, ol : file
{        iou_program_name, ioupn, ipn : LIST 1 .. 2 OF name = $required
{        status)

?? PUSH (LISTEXT := ON) ??

  VAR
    execute_pp_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^execute_pp_pdt_names,
      ^execute_pp_pdt_params];

  VAR
    execute_pp_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 14] of
      clt$parameter_name_descriptor := [['PP', 1], ['IOU', 2], ['CHANNEL', 3], ['C', 3], ['EQUIPMENT_NUMBER',
      4], ['EN', 4], ['UNIT_NUMBER', 5], ['UN', 5], ['OBJECT_LIBRARY', 6], ['OL', 6], ['IOU_PROGRAM_NAME', 7]
      , ['IOUPN', 7], ['IPN', 7], ['STATUS', 8]];

  VAR
    execute_pp_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 8] of clt$parameter_descriptor := [

{ PP }
    [[clc$required], 1, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ IOU }
    [[clc$optional_with_default, ^execute_pp_pdt_dv2], 1, 2, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$name_value, 1, osc$max_name_size]],

{ CHANNEL C }
    [[clc$optional], 1, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ EQUIPMENT_NUMBER EN }
    [[clc$optional], 1, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 7]],

{ UNIT_NUMBER UN }
    [[clc$optional], 1, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 63]],

{ OBJECT_LIBRARY OL }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ IOU_PROGRAM_NAME IOUPN IPN }
    [[clc$required], 1, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    execute_pp_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'IOU0';

?? POP ??

   CONST
     default_page_size = 4096;

   VAR
     channel_descriptor : cmt$channel_descriptor,
     channel_definition : cmt$data_channel_definition,
     local_status : ost$status,
     specified,
     unit_specified : boolean,
     i,
     j,
     pp_count,
     element_access_count : 0 .. clc$max_value_sets,
     pp_descriptor : cmt$pp_descriptor,
     pp_definition : cmt$pp_definition,
     pp : dst$iou_resource,
     value : clt$value,
     object_library_file  : amt$local_file_name,
     object_library : ^SEQ (*),
     address : pmt$object_library_address,
     program_name : pmt$program_name,
     pp_program_description : ^array [1 .. *] of cmt$pp_program_description,
     ioun : array [1 .. 2] of cmt$element_name,
     object_library_fid : amt$file_identifier;

     status.normal := TRUE;

   /main_program/
     BEGIN

       clp$scan_parameter_list (parameter_list, execute_pp_pdt, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       clp$test_parameter ('OBJECT_LIBRARY', specified, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       IF specified THEN
         clp$get_value ('OBJECT_LIBRARY', 1, 1, clc$low, value, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;
         object_library_file := value.file.local_file_name;
         IF object_library_file <> '$NULL' THEN
           pmp$open_object_library (object_library_file, object_library_fid, object_library, status);
           IF NOT status.normal THEN
             EXIT /main_program/;
           IFEND;
         IFEND;
       IFEND;

       clp$get_set_count ('PP', pp_count, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       PUSH pp_program_description : [1 .. pp_count];

       FOR i := 1 TO pp_count DO
         clp$get_value ('IOU', i, 1, clc$low, value, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;
         ioun [i] := value.name.value;
       FOREND;

       FOR i := 1 TO pp_count DO
         clp$get_value ('PP', i, 1, clc$low, value, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;
         pp_descriptor.iou := ioun [i];
         pp_descriptor.use_logical_identification := TRUE;
         pp_descriptor.pp_name := value.name.value;
         cmp$get_pp_definition (pp_descriptor, pp_definition, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;
         pp.number := pp_definition.number;
         IF pp_definition.concurrent THEN
           pp.channel_protocol := dsc$cpt_cio;
         ELSE
           pp.channel_protocol := dsc$cpt_nio;
         IFEND;
         cmp$convert_iou_name (ioun [i], pp.iou_number, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;
         pp_program_description ^[i].pp_identification.iou := ioun [i];
         cmp$convert_pp_number (pp, pp_program_description ^[i].pp_identification.ordinal);
         clp$get_value ('IOU_PROGRAM_NAME', i, 1, clc$low, value, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;

         pp_program_description ^[i].iou_program_name := value.name.value;
         IF specified AND (object_library_file <> '$NULL') THEN
           program_name := value.name.value;
           pmp$find_module_in_library (program_name, object_library, address, status);
           IF NOT status.normal THEN
             EXIT /main_program/;
           IFEND;
           IF address.kind <> llc$ppu_object_module THEN
             osp$set_status_abnormal (cmc$configuration_management_id,
               0, 'Illegal PP program in object library.', status);
             EXIT /main_program/;
           IFEND;
           pp_program_description ^[i].pp_program := address.ppu_object_module;
         ELSE
           pp_program_description ^[i].pp_program := NIL;
         IFEND;
         pp_program_description ^[i].master_pp := (i = 1);
         pp_program_description ^[i].element_access := NIL;
         pp_program_description ^[i].communication_buffer_length := default_page_size;

       FOREND;

       clp$test_parameter ('UNIT_NUMBER', unit_specified, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       clp$test_parameter ('CHANNEL', specified, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       IF specified THEN
         clp$get_set_count ('CHANNEL', element_access_count, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;

         FOR i := 1 TO pp_count DO
           PUSH pp_program_description ^[i].element_access: [1 .. element_access_count];
           FOR j := 1 TO element_access_count DO
             pp_program_description ^[i].element_access ^[j].iou := ioun[i];

             clp$get_value ('CHANNEL', j,  1, clc$low, value, status);
             IF NOT status.normal THEN
               EXIT /main_program/;
             IFEND;
             channel_descriptor.iou := ioun [i];
             channel_descriptor.use_logical_identification := TRUE;
             channel_descriptor.name := value.name.value;
             cmp$get_channel_definition (channel_descriptor, channel_definition, status);
             IF NOT status.normal THEN
              IF status.condition = cme$lcm_element_not_found THEN
                status.normal := TRUE;
              ELSE
                EXIT /main_program/;
              IFEND;
             IFEND;
             pp_program_description ^[i].element_access ^[j].
                  channel.ordinal := channel_definition.ordinal;
             clp$get_value ('EQUIPMENT_NUMBER', j, 1, clc$low, value, status);
             IF NOT status.normal THEN
               EXIT /main_program/;
             IFEND;
             pp_program_description ^[i].element_access ^[j].channel_address := value.int.value;

             IF unit_specified THEN
               clp$get_value ('UNIT_NUMBER', j, 1, clc$low, value, status);
               IF NOT status.normal THEN
                 EXIT /main_program/;
               IFEND;
               pp_program_description ^[i].element_access ^[j].physical_address_specifier :=
                 - $cmt$physical_address_specifier [ ];
               pp_program_description ^[i].element_access ^[j].unit_address := value.int.value;
             ELSE
               pp_program_description ^[i].element_access ^[j].physical_address_specifier :=
                 $cmt$physical_address_specifier [cmc$iou, cmc$channel, cmc$channel_address];
             IFEND;
           FOREND;
         FOREND;
       IFEND;

       msp$execute_pp_program (pp_program_description^, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

     END /main_program/;

     pmp$close_object_library (object_library_fid, local_status);

  PROCEND msp$execute_pp_command;

?? TITLE := '  msp$idle_pp_command', EJECT ??

  PROCEDURE msp$idle_pp_command (parameter_list : clt$parameter_list;
        VAR status : ost$status);


{  PDT idle_pp_pdt (
{     pp : name = $required
{     break_interlocks, bi : boolean
{     hardware_idle_pp, hip : boolean
{     iou : name = IOU0
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    idle_pp_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^idle_pp_pdt_names,
      ^idle_pp_pdt_params];

  VAR
    idle_pp_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
      clt$parameter_name_descriptor := [['PP', 1], ['BREAK_INTERLOCKS', 2], ['BI', 2], ['HARDWARE_IDLE_PP', 3]
      , ['HIP', 3], ['IOU', 4], ['STATUS', 5]];

  VAR
    idle_pp_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of clt$parameter_descriptor := [

{ PP }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ BREAK_INTERLOCKS BI }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ HARDWARE_IDLE_PP HIP }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ IOU }
    [[clc$optional_with_default, ^idle_pp_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    idle_pp_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'IOU0';

?? POP ??
  VAR
    value : clt$value,
    pp : dst$iou_resource,
    pp_descriptor : cmt$pp_descriptor,
    pp_definition : cmt$pp_definition,
    parameter_specified,
    pp_software_idled,
    hardware_idle_pp,
    break_interlocks: boolean,
    i : cmt$pp_Ordinal,
    ppn : cmt$pp_identification,
    actual_pp_memory_size : cmt$pp_memory_length,
    pp_registers : cmt$pp_registers,
    pp_memory_area : ^SEQ ( * );

    status.normal := TRUE;
  /main_program/
    BEGIN

      clp$scan_parameter_list (parameter_list, idle_pp_pdt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$get_value ('IOU', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      ppn.iou := value.name.value;

      clp$get_value ('PP', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      pp_descriptor.iou := ppn.iou;
      pp_descriptor.use_logical_identification := TRUE;
      pp_descriptor.pp_name := value.name.value;
      cmp$get_pp_definition (pp_descriptor, pp_definition, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      pp.number := pp_definition.number;
      IF pp_definition.concurrent THEN
        pp.channel_protocol := dsc$cpt_cio;
      ELSE
        pp.channel_protocol := dsc$cpt_nio;
      IFEND;
      cmp$convert_iou_name (ppn.iou, pp.iou_number, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      cmp$convert_pp_number (pp, ppn.ordinal);

      break_interlocks := FALSE;

      clp$test_parameter ('BREAK_INTERLOCKS', parameter_specified, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      IF parameter_specified THEN
        clp$get_value ('BREAK_INTERLOCKS', 1, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        break_interlocks := value.bool.value;
      IFEND;

      hardware_idle_pp := FALSE;
      clp$test_parameter ('HARDWARE_IDLE_PP', parameter_specified, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      IF parameter_specified THEN
        clp$get_value ('HARDWARE_IDLE_PP', 1, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        hardware_idle_pp := value.bool.value;
      IFEND;

      msp$idle_pp (ppn, break_interlocks, hardware_idle_pp, NIL,
        actual_pp_memory_size, pp_registers, pp_software_idled, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF NOT pp_software_idled THEN
        osp$set_status_abnormal ('CM', 0, 'Unable to soft idle PP.', status);
      IFEND;
    END /main_program/;

  PROCEND msp$idle_pp_command;

?? TITLE := '  msp$resume_pp_command', EJECT ??
  PROCEDURE msp$resume_pp_command (parameter_list : clt$parameter_list;
        VAR status : ost$status);


{  PDT resume_pp_pdt (
{    pp : name = $required
{    hardware_resume_pp,hrp : boolean
{    start_address, sa : integer = $required
{    iou : name = IOU0
{    status)

?? PUSH (LISTEXT := ON) ??

  VAR
    resume_pp_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^resume_pp_pdt_names,
      ^resume_pp_pdt_params];

  VAR
    resume_pp_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
      clt$parameter_name_descriptor := [['PP', 1], ['HARDWARE_RESUME_PP', 2], ['HRP', 2], ['START_ADDRESS', 3]
      , ['SA', 3], ['IOU', 4], ['STATUS', 5]];

  VAR
    resume_pp_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of clt$parameter_descriptor := [

{ PP }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ HARDWARE_RESUME_PP HRP }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ START_ADDRESS SA }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, clc$min_integer,
      clc$max_integer]],

{ IOU }
    [[clc$optional_with_default, ^resume_pp_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    resume_pp_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'IOU0';

?? POP ??

  VAR
    ppn : cmt$pp_identification,
    i : cmt$pp_ordinal,
    parameter_specified,
    pp_software_resumed,
    hardware_resume_pp : boolean,
    pp :dst$iou_resource,
    pp_definition : cmt$pp_definition,
    pp_descriptor : cmt$pp_descriptor,
    pp_identification : cmt$pp_identification,
    value : clt$value,
    start_address : cmt$pp_memory_length;

    status.normal := TRUE;
  /main_program/
    BEGIN
      clp$scan_parameter_list (parameter_list, resume_pp_pdt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$get_value ('IOU', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      ppn.iou := value.name.value;

      clp$get_value ('PP', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      pp_descriptor.iou := ppn.iou;
      pp_descriptor.use_logical_identification := TRUE;
      pp_descriptor.pp_name := value.name.value;
      cmp$get_pp_definition (pp_descriptor, pp_definition, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      pp.number := pp_definition.number;
      IF pp_definition.concurrent THEN
        pp.channel_protocol := dsc$cpt_cio;
      ELSE
        pp.channel_protocol := dsc$cpt_nio;
      IFEND;
      cmp$convert_iou_name (ppn.iou, pp.iou_number, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      cmp$convert_pp_number (pp, ppn.ordinal);

      clp$get_value ('START_ADDRESS', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      start_address := value.int.value;
      clp$test_parameter ('HARDWARE_RESUME_PP', parameter_specified, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      IF parameter_specified THEN
        clp$get_value ('HARDWARE_RESUME_PP', 1, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        hardware_resume_pp := value.bool.value;
      ELSE
        hardware_resume_pp := FALSE;
      IFEND;
      msp$resume_pp (ppn, hardware_resume_pp, start_address,
             pp_software_resumed, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    { IF NOT pp_software_resumed THEN
    {   osp$set_status_abnormal ('CM', 0, 'Unable to software resume PP.',
    {      status);
    { IFEND;


    END /main_program/;



  PROCEND msp$resume_pp_command;

?? TITLE := '  msp$display_ppr_command', EJECT ??
  PROCEDURE msp$display_ppr_command (parameter_list : clt$parameter_list;
        VAR status : ost$status);

{      PDT display_pp_pdt (
{         pp : name = $required
{         display_options, display_option, do : key A K P Q ALL = ALL
{         iou : name = IOU0
{         output, o : file = $output
{         status)

?? PUSH (LISTEXT := ON) ??

  VAR
    display_pp_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^display_pp_pdt_names,
      ^display_pp_pdt_params];

  VAR
    display_pp_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 8] of
      clt$parameter_name_descriptor := [['PP', 1], ['DISPLAY_OPTIONS', 2], ['DISPLAY_OPTION', 2], ['DO', 2], [
      'IOU', 3], ['OUTPUT', 4], ['O', 4], ['STATUS', 5]];

  VAR
    display_pp_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of clt$parameter_descriptor := [

{ PP }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ DISPLAY_OPTIONS DISPLAY_OPTION DO }
    [[clc$optional_with_default, ^display_pp_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [^
      display_pp_pdt_kv2, clc$keyword_value]],

{ IOU }
    [[clc$optional_with_default, ^display_pp_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$name_value, 1, osc$max_name_size]],

{ OUTPUT O }
    [[clc$optional_with_default, ^display_pp_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    display_pp_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of ost$name := ['A','K','P',
      'Q','ALL'];

  VAR
    display_pp_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'ALL';

  VAR
    display_pp_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'IOU0';

  VAR
    display_pp_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$output';

?? POP ??

  VAR
    a_register,
    k_register,
    p_register,
    q_register : ost$string,
    fid : amt$file_identifier,
    byte_address : amt$file_byte_address,
    len : integer,
    pp : dst$iou_resource,
    pp_descriptor : cmt$pp_descriptor,
    pp_definition : cmt$pp_definition,
    pp_identification : cmt$pp_identification,
    pp_registers : cmt$pp_registers,
    str : string (80),
    value : clt$value;

    status.normal := TRUE;
  /main_program/
    BEGIN
      clp$scan_parameter_list (parameter_list, display_pp_pdt, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      fsp$open_file (value.file.local_file_name,
        amc$record, NIL, NIL, NIL, NIL, NIL, fid, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      clp$get_value ('IOU', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      pp_identification.iou := value.name.value;

      clp$get_value ('PP', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      pp_descriptor.iou := pp_identification.iou;
      pp_descriptor.use_logical_identification := TRUE;
      pp_descriptor.pp_name := value.name.value;
      cmp$get_pp_definition (pp_descriptor, pp_definition, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      pp.number := pp_definition.number;
      IF pp_definition.concurrent THEN
        pp.channel_protocol := dsc$cpt_cio;
      ELSE
        pp.channel_protocol := dsc$cpt_nio;
      IFEND;
      cmp$convert_iou_name (pp_descriptor.iou, pp.iou_number, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      cmp$convert_pp_number (pp, pp_identification.ordinal);


      msp$get_pp_registers (pp_identification, pp_registers, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$convert_integer_to_string (pp_registers.a_register, 8, true, a_register, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_string (pp_registers.k_register, 8, true, k_register, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_string (pp_registers.p_register, 8, true, p_register, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_string (pp_registers.q_register, 8, true, q_register, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      str := ' ';
      str (1, 14) := ' A Register : ';
      str (16, *) := a_register.value (1, a_register.size);
      amp$put_next (fid, ^str, 80, byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      str := ' ';
      str (1, 14) := ' K Register : ';
      str (16, *) := k_register.value (1, k_register.size);
      amp$put_next (fid, ^str, 80, byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      str := ' ';
      str (1, 14) := ' P Register : ';
      str (16, *) := p_register.value (1, p_register.size);
      amp$put_next (fid, ^str, 80, byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      str := ' ';
      str (1, 14) := ' Q Register : ';
      str (16, *) := q_register.value (1, q_register.size);
      amp$put_next (fid, ^str, 80, byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fsp$close_file (fid, status);

    END /main_program/;

  PROCEND msp$display_ppr_command;

?? TITLE := '  msp$quit_command', EJECT ??
  PROCEDURE msp$quit_command (parameter_list : clt$parameter_list;
        VAR status : ost$status);


{ PDT quit_pdt (  )

?? PUSH (LISTEXT := ON) ??

  VAR
    quit_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??

    clp$end_scan_command_file (msv$utility_name, status);


  PROCEND msp$quit_command;

?? TITLE :=' msp$display_channel_command', EJECT ??

  PROCEDURE msp$display_channel_command (
          parameter_list : clt$parameter_list;
      VAR status : ost$status);


{     PDT dis_channel_info (
{       channel_name, n : name = $optional
{       channel_number, cn : INTEGER = $optional
{       concurrent, c : BOOLEAN = FALSE
{       port, p : key A B = $optional
{       iou_name, iou : name = IOU0
{       output, o : file = $output
{       status)

?? PUSH (LISTEXT := ON) ??

  VAR
    dis_channel_info: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^dis_channel_info_names,
      ^dis_channel_info_params];

  VAR
    dis_channel_info_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 13] of
      clt$parameter_name_descriptor := [['CHANNEL_NAME', 1], ['N', 1], ['CHANNEL_NUMBER', 2], ['CN', 2], [
      'CONCURRENT', 3], ['C', 3], ['PORT', 4], ['P', 4], ['IOU_NAME', 5], ['IOU', 5], ['OUTPUT', 6], ['O', 6]
      , ['STATUS', 7]];

  VAR
    dis_channel_info_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 7] of clt$parameter_descriptor
      := [

{ CHANNEL_NAME N }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ CHANNEL_NUMBER CN }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, clc$min_integer,
      clc$max_integer]],

{ CONCURRENT C }
    [[clc$optional_with_default, ^dis_channel_info_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$boolean_value]],

{ PORT P }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [^dis_channel_info_kv4, clc$keyword_value]],

{ IOU_NAME IOU }
    [[clc$optional_with_default, ^dis_channel_info_dv5], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$name_value, 1, osc$max_name_size]],

{ OUTPUT O }
    [[clc$optional_with_default, ^dis_channel_info_dv6], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    dis_channel_info_kv4: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := ['A','B'];

  VAR
    dis_channel_info_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'FALSE';

  VAR
    dis_channel_info_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'IOU0';

  VAR
    dis_channel_info_dv6: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$output';

?? POP ??
   VAR
     pen : cmt$physical_equipment_number,
     ppn : ost$physical_pp_number,
     output_file_val : clt$value,
     output : amt$local_file_name,
     fid : amt$file_identifier,
     channel_name : cmt$element_name,
     channel_port : cmt$channel_port,
     ba : amt$file_byte_address,
     valid : boolean,
     value : clt$value,
     len : integer,
     str : string (50),
     specified : boolean,
     local_status :ost$status,
     element_descriptor : cmt$element_descriptor,
     element_definition : cmt$element_definition,
     channel_definition : cmt$data_channel_definition,
     channel_descriptor : cmt$channel_descriptor;

   status.normal := TRUE;

     /main_program/
     BEGIN
       clp$scan_parameter_list (parameter_list, dis_channel_info, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       clp$test_parameter ('CHANNEL_NAME', specified, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       IF specified THEN
         clp$get_value ('CHANNEL_NAME', 1, 1, clc$low, value, status);
         channel_descriptor.use_logical_identification := TRUE;
         channel_descriptor.name := value.name.value;
       ELSE
         clp$get_value ('CHANNEL_NUMBER', 1, 1, clc$low, value, status);
         channel_descriptor.use_logical_identification := FALSE;
         IF (value.int.value < 0) OR (value.int.value >= 27) THEN
           osp$set_status_abnormal (cmc$configuration_management_id,
              cme$invalid_channel_number, 'Channel number is out of range',
              status);
           EXIT /main_program/;
         IFEND;
         channel_descriptor.number := value.int.value;
         clp$get_value ('CONCURRENT', 1, 1, clc$low, value, status);
         channel_descriptor.concurrent := value.bool.value;
         clp$test_parameter ('PORT', specified, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;
         IF specified THEN
           clp$get_value ('PORT', 1, 1, clc$low, value, status);
           IF value.name.value = 'A' THEN
             channel_port := cmc$port_a;
           ELSE
             channel_port := cmc$port_b;
           IFEND;
         ELSE
           channel_port := cmc$unspecified_port;
         IFEND;
         cmp$convert_channel_number (channel_descriptor.number,
              channel_descriptor.concurrent, channel_port,
              channel_descriptor.channel_ordinal, channel_name, valid);
       IFEND;

       clp$get_value ('IOU_NAME', 1, 1, clc$low, value, status);
       channel_descriptor.iou := value.name.value;

       clp$get_value ('OUTPUT' , 1, 1, clc$low, output_file_val, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       amp$open (output_file_val.file.local_file_name, amc$record, nil, fid, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

        element_descriptor.element_type := cmc$data_channel_element;
        element_descriptor.channel_descriptor := channel_descriptor;
        cmp$get_element_definition (element_descriptor, element_definition, status);
        IF NOT status.normal THEN
         IF status.condition = cme$lcm_element_not_found THEN
           status.normal := TRUE;
           cmp$get_channel_definition (channel_descriptor, channel_definition, status);
           IF NOT status.normal THEN
             IF status.condition = cme$lcm_element_not_found THEN
               status.normal := TRUE;
             ELSE
               EXIT /main_program/;
             IFEND;
           IFEND;
         ELSE
           EXIT /main_program/;
         IFEND;
       ELSE
         IF element_definition.element_type = cmc$data_channel_element THEN
           channel_definition := element_definition.data_channel;
         ELSE
           str (1, 50) := ' ';
           STRINGREP (str, len, ' WRONG ELEMENT_TYPE FOR: ', element_definition.element_name);
           amp$put_next (fid, #LOC (str), len, ba, status);
           EXIT /main_program/;
         IFEND;
       IFEND;

       str (1, 50) := ' ';
       STRINGREP (str, len, ' CHANNEL_NUMBER : ', channel_definition.number);
       amp$put_next (fid, #LOC (str), len, ba, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       str (1, 50) := ' ';
       IF channel_definition.concurrent THEN
         STRINGREP (str, len, ' CONCURRENT : TRUE');
       ELSE
         STRINGREP (str, len, ' CONCURRENT : FALSE');
       IFEND;
       amp$put_next (fid, #LOC (str), len, ba, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       str (1, 50) := ' ';
       IF channel_definition.direct_memory_access THEN
         STRINGREP (str, len, ' DMA : TRUE');
       ELSE
         STRINGREP (str, len, ' DMA : FALSE');
       IFEND;
       amp$put_next (fid, #LOC (str), len, ba, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       str (1, 50) := ' ';
       STRINGREP (str, len, ' IOU_NAME : ', channel_definition.iou);
       amp$put_next (fid, #LOC (str), len, ba, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       str (1, 50) := ' ';
       STRINGREP (str, len, ' CHANNEL_KIND : ', channel_definition.kind);
       amp$put_next (fid, #LOC (str), len, ba, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       str (1, 50) := ' ';
       STRINGREP (str, len, ' CHANNEL_ORDINAL : ', channel_definition.ordinal);
       amp$put_next (fid, #LOC (str), len, ba, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       str (1, 50) := ' ';
       STRINGREP (str, len, ' CHANNEL_PORT : ', channel_definition.port);
       amp$put_next (fid, #LOC (str), len, ba, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       FOR pen := LOWERVALUE (cmt$physical_equipment_number) TO
                    UPPERVALUE (cmt$physical_equipment_number) DO
         IF channel_definition.connection.equipment [pen].configured THEN
           str (1, 50) := ' ';
           STRINGREP (str, len, ' EQUIPMENT_', pen, ' : ',
             channel_definition.connection.equipment [pen].element_name);
           amp$put_next (fid, #LOC (str), len, ba, status);
           IF NOT status.normal THEN
             EXIT /main_program/;
           IFEND;
         IFEND;
       FOREND;

       FOR ppn := LOWERVALUE (ost$physical_pp_number) TO
                    UPPERVALUE (ost$physical_pp_number) DO
         str (1, 50) := ' ';
         STRINGREP (str, len, ' PP_ACCESS_', ppn, ' : ',
           channel_definition.pps_capable_of_access [ppn]);
         amp$put_next (fid, #LOC (str), len, ba, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;
       FOREND;

     END /main_program/;

     amp$close (fid, local_status);

  PROCEND msp$display_channel_command;

  PROCEDURE msp$display_iou_command (
          parameter_list : clt$parameter_list;
      VAR status : ost$status);

{  PDT dis_iou_info (
{        iou : name = IOU0
{        output, o : file = OUTPUT
{        status)

?? PUSH (LISTEXT := ON) ??

  VAR
    dis_iou_info: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^dis_iou_info_names,
      ^dis_iou_info_params];

  VAR
    dis_iou_info_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
      clt$parameter_name_descriptor := [['IOU', 1], ['OUTPUT', 2], ['O', 2], ['STATUS', 3]];

  VAR
    dis_iou_info_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ IOU }
    [[clc$optional_with_default, ^dis_iou_info_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$name_value, 1, osc$max_name_size]],

{ OUTPUT O }
    [[clc$optional_with_default, ^dis_iou_info_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    dis_iou_info_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'IOU0';

  VAR
    dis_iou_info_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (6) := 'OUTPUT';

?? POP ??

   VAR
     iou_name : cmt$element_name,
     output_file_val : clt$value,
     output : amt$local_file_name,
     fid : amt$file_identifier,
     ba : amt$file_byte_address,
     value : clt$value,
     len : integer,
     str : string (50),
     local_status :ost$status,
     iou_definition : cmt$iou_definition;

   status.normal := TRUE;

     /main_program/
     BEGIN
       clp$scan_parameter_list (parameter_list, dis_iou_info, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       clp$get_value ('OUTPUT' , 1, 1, clc$low, output_file_val, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       clp$get_value ('IOU', 1, 1, clc$low, value, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;
       iou_name := value.name.value;
       amp$open (output_file_val.file.local_file_name, amc$record, nil, fid, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       cmp$get_iou_definition (iou_name, iou_definition, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       str (1, 50) := ' ';
       STRINGREP (str, len, ' IOU_KIND : ', iou_definition.kind);
       amp$put_next (fid, #LOC (str), len, ba, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

     END /main_program/;

     amp$close (fid, local_status);

  PROCEND msp$display_iou_command;

  PROCEDURE msp$display_ppd_command (
          parameter_list : clt$parameter_list;
      VAR status : ost$status);

{     PDT dis_pp_info (
{       pp_name, n : name = $optional
{       pp_number, ppn : INTEGER = $optional
{       concurrent, c : BOOLEAN = FALSE
{       iou_name, iou : name = IOU0
{       output, o : file = $output
{       status)

?? PUSH (LISTEXT := ON) ??

  VAR
    dis_pp_info: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^dis_pp_info_names,
      ^dis_pp_info_params];

  VAR
    dis_pp_info_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 11] of
      clt$parameter_name_descriptor := [['PP_NAME', 1], ['N', 1], ['PP_NUMBER', 2], ['PPN', 2], ['CONCURRENT'
      , 3], ['C', 3], ['IOU_NAME', 4], ['IOU', 4], ['OUTPUT', 5], ['O', 5], ['STATUS', 6]];

  VAR
    dis_pp_info_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 6] of clt$parameter_descriptor := [

{ PP_NAME N }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ PP_NUMBER PPN }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, -9223372036854775806,
      9223372036854775807]],

{ CONCURRENT C }
    [[clc$optional_with_default, ^dis_pp_info_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$boolean_value]],

{ IOU_NAME IOU }
    [[clc$optional_with_default, ^dis_pp_info_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$name_value, 1, osc$max_name_size]],

{ OUTPUT O }
    [[clc$optional_with_default, ^dis_pp_info_dv5], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    dis_pp_info_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'FALSE';

  VAR
    dis_pp_info_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'IOU0';

  VAR
    dis_pp_info_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$output';

?? POP ??
   VAR
     chn : ost$physical_channel_number,
     output_file_val : clt$value,
     output : amt$local_file_name,
     fid : amt$file_identifier,
     ba : amt$file_byte_address,
     value : clt$value,
     len : integer,
     str : string (50),
     specified : boolean,
     local_status :ost$status,
     pp_definition : cmt$pp_definition,
     pp_descriptor : cmt$pp_descriptor;

   status.normal := TRUE;

     /main_program/
     BEGIN
       clp$scan_parameter_list (parameter_list, dis_pp_info, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       clp$test_parameter ('PP_NAME', specified, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       IF specified THEN
         clp$get_value ('PP_NAME', 1, 1, clc$low, value, status);
         pp_descriptor.use_logical_identification := TRUE;
         pp_descriptor.pp_name := value.name.value;
       ELSE
         clp$get_value ('PP_NUMBER', 1, 1, clc$low, value, status);
         pp_descriptor.use_logical_identification := FALSE;
         pp_descriptor.pp_number := value.int.value;

         clp$get_value ('CONCURRENT', 1, 1, clc$low, value, status);
         pp_descriptor.concurrent := value.bool.value;
       IFEND;

       clp$get_value ('IOU_NAME', 1, 1, clc$low, value, status);
       pp_descriptor.iou := value.name.value;

       clp$get_value ('OUTPUT' , 1, 1, clc$low, output_file_val, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       amp$open (output_file_val.file.local_file_name, amc$record, nil, fid, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       cmp$get_pp_definition (pp_descriptor, pp_definition, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       str (1, 50) := ' ';
       STRINGREP (str, len, ' PP_NUMBER : ', pp_definition.number);
       amp$put_next (fid, #LOC (str), len, ba, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       str (1, 50) := ' ';
       IF pp_definition.concurrent THEN
         STRINGREP (str, len, ' CONCURRENT : TRUE');
       ELSE
         STRINGREP (str, len, ' CONCURRENT : FALSE');
       IFEND;
       amp$put_next (fid, #LOC (str), len, ba, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       str (1, 50) := ' ';
       IF pp_definition.direct_memory_access THEN
         STRINGREP (str, len, ' DMA : TRUE');
       ELSE
         STRINGREP (str, len, ' DMA : FALSE');
       IFEND;
       amp$put_next (fid, #LOC (str), len, ba, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       str (1, 50) := ' ';
       STRINGREP (str, len, ' IOU_NAME : ', pp_definition.iou);
       amp$put_next (fid, #LOC (str), len, ba, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       str (1, 50) := ' ';
       STRINGREP (str, len, ' SIZE : ', pp_definition.size);
       amp$put_next (fid, #LOC (str), len, ba, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       FOR chn := LOWERVALUE (ost$physical_channel_number) TO
                    UPPERVALUE (ost$physical_channel_number) DO
         str (1, 50) := ' ';
         STRINGREP (str, len, ' CHANNEL_ACCESS_', chn, ' : ', pp_definition.accessible_channels [chn]);
         amp$put_next (fid, #LOC (str), len, ba, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;
       FOREND;

     END /main_program/;

     amp$close (fid, local_status);

  PROCEND msp$display_ppd_command;

?? TITLE := '    msp$test_return_descriptor_data', EJECT ??

  PROCEDURE msp$test_return_descriptor_data (parameter_list:
    clt$parameter_list;
    VAR status: ost$status);


{  PDT test_rdd (
{       logical_unit_number, lun : integer 2 .. 0ffff(16) = $required
{       channel, c : name = $required
{       iou : name = IOU0
{       system_element, se : boolean = TRUE
{       equipment_number, en : integer 0 .. 7 = 0
{       status)

?? PUSH (LISTEXT := ON) ??

  VAR
    test_rdd: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^test_rdd_names, ^test_rdd_params];

  VAR
    test_rdd_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 10] of
      clt$parameter_name_descriptor := [['LOGICAL_UNIT_NUMBER', 1], ['LUN', 1], ['CHANNEL', 2], ['C', 2], [
      'IOU', 3], ['SYSTEM_ELEMENT', 4], ['SE', 4], ['EQUIPMENT_NUMBER', 5], ['EN', 5], ['STATUS', 6]];

  VAR
    test_rdd_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 6] of clt$parameter_descriptor := [

{ LOGICAL_UNIT_NUMBER LUN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 2, 0ffff(16)]],

{ CHANNEL C }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ IOU }
    [[clc$optional_with_default, ^test_rdd_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$name_value, 1, osc$max_name_size]],

{ SYSTEM_ELEMENT SE }
    [[clc$optional_with_default, ^test_rdd_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$boolean_value]],

{ EQUIPMENT_NUMBER EN }
    [[clc$optional_with_default, ^test_rdd_dv5], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 7]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    test_rdd_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'IOU0';

  VAR
    test_rdd_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'TRUE';

  VAR
    test_rdd_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

?? POP ??

    VAR
      ch : cmt$element_name,
      channel_descriptor : cmt$channel_descriptor,
      channel_definition : cmt$data_channel_definition,
      descriptor_data: ost$string,
      dummy_ppn : 0 .. 0ff(16),
      en: cmt$physical_equipment_number,
      iou : cmt$element_name,
      iou_number : dst$iou_number,
      lpp : iot$pp_number,
      lun: iot$logical_unit,
      physical_channel : cmt$physical_channel,
      physical_pp : 0 .. 31,
      value: clt$value,
      file: clt$file,
      display_control: clt$display_control;

  /main_program/
    BEGIN

      clp$scan_parameter_list (parameter_list, test_rdd, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      clp$get_value ('IOU', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      iou := value.name.value;
      cmp$convert_iou_name (iou, iou_number, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      clp$get_value ('CHANNEL', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      channel_descriptor.iou := iou;
      channel_descriptor.use_logical_identification := TRUE;
      channel_descriptor.name := value.name.value;
      cmp$get_channel_definition (channel_descriptor, channel_definition, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      ch := value.name.value;
      physical_channel.number := channel_definition.number;
      physical_channel.port := channel_definition.port;
      physical_channel.concurrent := channel_definition.concurrent;
      clp$get_value ('EQUIPMENT_NUMBER', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      IF value.kind <> clc$unknown_value THEN
        en := value.int.value;
      ELSE
        en := 0;
      IFEND;
      clp$get_value ('LOGICAL_UNIT_NUMBER', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      lun := value.int.value;

      clp$get_value ('SYSTEM_ELEMENT', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      IF value.bool.value THEN
        cmp$return_descriptor_data (physical_channel, iou_number, en, lun, descriptor_data,
               dummy_ppn);
      ELSE
        cmp$return_logical_pp_number (ch, iou, lpp, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        cmp$return_desc_data_by_lun_lpn (lun, lpp, iou_number,
               descriptor_data, physical_pp);
      IFEND;
      file.local_file_name := clc$standard_output;
      clp$open_display (file, NIL, display_control, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      clp$put_display (display_control, descriptor_data.value (1,
            descriptor_data.size), clc$no_trim, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      clp$close_display (display_control, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

    END /main_program/;

  PROCEND msp$test_return_descriptor_data;

MODEND msm$maintenance_services_utl;
*DECK DECK=MSM$REQUEST_MAINTENANCE_ACCESS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE msm$request_maintenance_access;
?? TITLE := ' Maintenance services module' ??
?? PUSH (LISTEXT := ON) ??
*copyc mse$request_maintenance_access
*copyc cme$reserve_element
*copyc cmt$element_definition
*copyc cmt$element_status
*copyc cmt$element_descriptor
*copyc cmv$physical_configuration
*copyc ost$caller_identifier
*copyc cmv$peripheral_element_table
*copyc mst$access_type
*copyc oss$job_paged_literal
*copyc rmc$dedicated_maintenance
*copyc rmd$volume_declarations
*copyc cme$logical_configuration_mgr
*copyc dme$tape_errors
?? POP ??
?? NEWTITLE := '  Xref procedures ', EJECT ??
*copyc avp$get_capability
*copyc cmp$validate_unused_channel
*copyc cmp$acquire_resources
*copyc cmp$convert_iou_name
*copyc cmp$convert_iou_number
*copyc cmp$execute_pp_program
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_mainframe_id
*copyc pmp$get_job_names
*copyc cmp$get_unit_type
*copyc cmp$get_element_information
*copyc cmp$idle_pp
*copyc cmp$mount_storage_medium
*copyc cmp$resume_pp
*copyc cmp$request_channels
*copyc cmp$reserve_element
*copyc cmp$release_element
*copyc cmp$get_element_definition
*copyc cmp$get_mainframe_element
*copyc cmp$get_logical_unit_number
*copyc cmp$get_pp_registers
*copyc cmp$search_peripheral_table
*copyc ofp$format_operator_menu
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
*copyc cmp$format_error_message
*copyc cmv$logical_unit_table
*copyc dmv$null_sfid
*copyc msv$con_access_gtid_list
*copyc osv$task_shared_heap
*copyc msp$mark_element_requested
*copyc msp$unmark_element_requested
*copyc msp$search_con_access_job
*copyc msp$add_con_access_job
*copyc msp$delete_con_access_job
*copyc cmp$set_unit_shared
*copyc cmp$clear_unit_shared
*copyc cmp$search_active_volume_table
*copyc rmp$release_tape_unit
*copyc stp$get_volumes_set_name
*copyc stp$is_volume_in_set
*copyc ost$caller_identifier
*copyc dsp$retrieve_iou_information

?? OLDTITLE ??
?? TITLE := '  msp$request_maintenance_access',EJECT ??

*copyc msh$request_maintenance_access

  PROCEDURE [XDCL, #GATE] msp$request_maintenance_access (
        element : cmt$element_descriptor;
        access : mst$access_type;
    VAR status : ost$status);


    PROCEDURE menu_for_maintenance_request (
         VAR status : ost$status);

      CONST
        default_terminate_reason = 'Request terminated by operator.',
        number_of_choices = 2,
        parameter_max = 5;

      VAR
        column : 1 .. 80,
        i : integer,
        list_string: string (80),
        menu_parameters: array [1 .. parameter_max] of ^ost$message_parameter,
        parameter_index : 1 .. parameter_max,
        parameter_names: ^ost$parameter_help_names,
        response: oft$number_of_choices,
        response_string: ost$string,
        string_index: 1 .. 80,
        string_size: ost$name_size;

      status.normal := TRUE;

      menu_parameters [1] := ^definition.element_name;
      list_string := ' ';
      string_index := 1;
      column := 14;
      parameter_index := 2;
      FOR i := LOWERBOUND(mainframe_list_p^) TO UPPERBOUND(mainframe_list_p^) DO
        IF mainframe_list_p^ [i] <> ' ' THEN
          IF column > 70 THEN
            menu_parameters [parameter_index] := ^list_string;
            string_index := 1;
            column := 14;
            list_string := ' ';
            IF parameter_index < parameter_max THEN
              parameter_index := parameter_index + 1;
            IFEND;
          IFEND;
          list_string (string_index, 9) := mainframe_list_p^ [i] (9, *);
          string_index := string_index + 10;
          column := column + 10;
        IFEND;
      FOREND;
      menu_parameters [parameter_index] := ^list_string;
      IF parameter_index < parameter_max THEN
        FOR i:= parameter_index + 1 TO parameter_max DO
          menu_parameters [i] := NIL;
        FOREND;
      IFEND;

      PUSH parameter_names: [1 .. number_of_choices];
      parameter_names^ [1] := 'TERMINATE_REQUEST';
      parameter_names^ [2] := 'ALLOW_MAINTENANCE';

      ofp$format_operator_menu (rmc$dedicated_maintenance, parameter_names, ^menu_parameters,
            number_of_choices, ofc$removable_media_operator, response, response_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE response OF
        = 1 =
        IF response_string.size > 0 THEN
          terminate_reason := response_string.value (1, response_string.size);
        ELSE
          terminate_reason := default_terminate_reason;
        IFEND;
        osp$set_status_abnormal (rmc$resource_management_id, dme$operator_stop, terminate_reason, status);
        = 2 =
        ;
      ELSE
      CASEND;
    PROCEND menu_for_maintenance_request;

    VAR
      caller_id : ost$caller_identifier,
      capability: boolean,
      channel_index: integer,
      channel_ordinal : cmt$channel_ordinal,
      dedicated_element_info : array [1 .. 1] of cmt$element_info_item,
      definition : cmt$element_definition,
      element_descriptor,
      element_description : cmt$element_descriptor,
      element_reservation : cmt$element_reservation,
      found: boolean,
      gtid_found: boolean,
      gtid : ost$global_task_id,
      host_mainframe : pmt$mainframe_id,
      i: integer,
      iou : dst$iou_number,
      iou_information_table : dst$iou_information_table,
      job_name : jmt$system_supplied_name,
      job_name_found: boolean,
      lun: integer,
      mainframe_list_p : ^array [ * ] OF pmt$mainframe_id,
      maintenance_allowed: boolean,
      need_to_warn_operator: boolean,
      number_of_ious : dst$number_of_ious,
      pc_index_1: integer,
      pc_index_2: integer,
      privileged_job: boolean,
      peripheral_index : integer,
      physical_id : cmt$physical_identification,
      physical_pp : dst$iou_resource,
      request_type : dst$resource_request_types,
      terminate_reason: string(osc$max_string_size),
      upline_port: integer,
      user_job_name: jmt$user_supplied_name;

   #caller_id (caller_id);
   mainframe_list_p := NIL;
   privileged_job := caller_id.ring <= 6;
   status.normal := TRUE;
   /main_program/
     BEGIN
       pmp$get_mainframe_id (host_mainframe, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       avp$get_capability (avc$engineering_operation, avc$user, capability, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       IF (NOT capability) THEN
         IF caller_id.ring > 6 THEN
           osp$set_status_abnormal (cmc$configuration_management_id,
             cme$privileged_job_required, 'MSP$REQUEST_MAINTENANCE_ACCESS', status);
           EXIT /main_program/;
         IFEND;
       IFEND;
       pmp$get_job_names (user_job_name, job_name, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;
       dsp$retrieve_iou_information (number_of_ious, iou_information_table);

       element_descriptor.element_type := element.element_type;
       CASE element_descriptor.element_type OF
       = cmc$data_channel_element =
         element_descriptor.channel_descriptor := element.channel_descriptor;
         IF number_of_ious = 1 THEN
           cmp$convert_iou_number (iou_information_table [1].physical_iou_number,
                 element_descriptor.channel_descriptor.iou, status);
           IF NOT status.normal THEN
              EXIT /main_program/;
           IFEND;
         ELSE { validate IOU passed in is a valid name}
           cmp$convert_iou_name (element_descriptor.channel_descriptor.iou, iou, status);
           IF NOT status.normal THEN
             EXIT /main_program/;
           IFEND;
         IFEND;

       = cmc$channel_adapter_element, cmc$controller_element, cmc$storage_device_element ,
                cmc$communications_element, cmc$external_processor_element =
         element_descriptor.peripheral_descriptor := element.peripheral_descriptor;
         IF NOT element_descriptor.peripheral_descriptor.use_logical_identification THEN
           IF number_of_ious = 1 THEN
             cmp$convert_iou_number (iou_information_table [1].physical_iou_number,
                   element_descriptor.peripheral_descriptor.
                   hardware_address.iou, status);
             IF NOT status.normal THEN
                EXIT /main_program/;
             IFEND;
           ELSE { validate IOU passed in is a valid name}
             cmp$convert_iou_name (element_descriptor.peripheral_descriptor.hardware_address.iou,
                   iou, status);
             IF NOT status.normal THEN
               EXIT /main_program/;
             IFEND;
           IFEND;
         IFEND;

       ELSE
       CASEND;

       pmp$get_executing_task_gtid (gtid);

       cmp$get_element_definition (element_descriptor, definition, status);
       IF NOT status.normal THEN
         cmp$format_error_message (element_descriptor, {not used} physical_id, FALSE,
               cme$lcm_element_not_found, status);
         EXIT /main_program/;
       IFEND;

       IF element_descriptor.element_type <> definition.element_type THEN
         osp$set_status_abnormal (cmc$configuration_management_id, cme$incorrect_element_type,
               definition.element_name, status);
         EXIT /main_program/;
       IFEND;

       CASE element_descriptor.element_type OF
       = cmc$data_channel_element =
         IF NOT element_descriptor.channel_descriptor.use_logical_identification THEN
           element_descriptor.channel_descriptor.use_logical_identification := TRUE;
           element_descriptor.channel_descriptor.name := definition.element_name;
           element_descriptor.channel_descriptor.iou := definition.data_channel.iou;
         IFEND;

       = cmc$channel_adapter_element,cmc$controller_element, cmc$storage_device_element ,
               cmc$communications_element,  cmc$external_processor_element =
         IF NOT element_descriptor.peripheral_descriptor.use_logical_identification THEN
           element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
           element_descriptor.peripheral_descriptor.element_name := definition.element_name;
         IFEND;

       ELSE
       CASEND;

       cmp$search_peripheral_table (element_descriptor,
         element_reservation, FALSE, peripheral_index, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       IF element_descriptor.element_type = cmc$data_channel_element THEN
         cmp$validate_unused_channel (cmv$peripheral_element_table.pointer^
               [peripheral_index].element_name, element_descriptor.channel_descriptor.iou,
               maintenance_allowed, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;
         IF NOT maintenance_allowed THEN
           osp$set_status_abnormal (msc$maintenance_services_id, mse$non_active_path,
               cmv$peripheral_element_table.pointer^[peripheral_index].element_name, status);
           EXIT /main_program/;
         IFEND;
       IFEND;
       { Check if element is in DEDICATED maintenance access }

       IF cmv$peripheral_element_table.pointer^ [peripheral_index].
           maintenance_activity.access = msc$dedicated_access THEN
         osp$set_status_abnormal (msc$maintenance_services_id, mse$dedicated_access_granted,
           cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
         osp$append_status_parameter (osc$status_parameter_delimiter,
           cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.
             dedicated_accessor.job_identification, status);
         EXIT /main_program/;
       IFEND;

       { Check if element already RESERVED or ASSIGNED to any job }

       IF element.element_type = cmc$storage_device_element THEN
         lun := cmv$peripheral_element_table.
           pointer^ [peripheral_index].logical_unit_number;
         IF lun <> 0 THEN
           IF cmv$logical_unit_table^ [lun].status.assignable_device THEN
             IF cmv$logical_unit_table^ [lun].status.assigned THEN
               osp$set_status_abnormal (msc$maintenance_services_id, mse$element_already_assigned,
                 cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
               osp$append_status_parameter (osc$status_parameter_delimiter,
                 cmv$logical_unit_table^ [lun].status.assigned_jsn, status);
               EXIT /main_program/;
             IFEND;
           IFEND;
         IFEND;
       IFEND;

       IF cmv$peripheral_element_table.pointer^ [peripheral_index].entry_interlock THEN
         IF cmv$peripheral_element_table.pointer^ [peripheral_index].reserved_status THEN
           osp$set_status_abnormal (msc$maintenance_services_id, cme$element_already_reserved,
             cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
           osp$append_status_parameter (osc$status_parameter_delimiter,
             cmv$peripheral_element_table.pointer^ [peripheral_index].reserved_job, status);
           EXIT /main_program/;
         IFEND;
       IFEND;

       CASE access OF
       = msc$concurrent_access =

         { Check if element is not in ON or DOWN state }

         IF cmv$peripheral_element_table.pointer^ [peripheral_index].element_status.state = cmc$off THEN
           osp$set_status_abnormal (msc$maintenance_services_id, mse$element_state_not_proper,
             cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
           EXIT /main_program/;
         IFEND;

         msp$search_con_access_job (peripheral_index, job_name, job_name_found, status);
         IF job_name_found THEN
           msp$search_con_access_gtid (gtid, peripheral_index, gtid_found, status);
           IF gtid_found THEN
             osp$set_status_abnormal (msc$maintenance_services_id, mse$concurrent_access_granted,
               cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
             osp$append_status_parameter (
               osc$status_parameter_delimiter, 'the same TASK of this job', status);
             EXIT /main_program/;
           ELSE
             msp$add_con_access_gtid (gtid, peripheral_index, status);
           IFEND;
         ELSE
           msp$add_con_access_job (peripheral_index, job_name, status);
           msp$add_con_access_gtid (gtid, peripheral_index, status);
         IFEND;
         IF element.element_type = cmc$storage_device_element THEN
           IF lun <> 0 THEN
             cmp$set_unit_shared (lun, TRUE);
           IFEND;
         IFEND;

       = msc$dedicated_access =

         dedicated_element_info [1].selector := cmc$system_critical_element;

         cmp$get_element_information (element_descriptor, dedicated_element_info, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;

         { Check if element is SYSTEM-CRITICAL }

         IF dedicated_element_info [1].item_returned THEN
           IF dedicated_element_info [1].system_critical_element THEN
             CASE element_descriptor.element_type OF
             = cmc$data_channel_element =
               osp$set_status_abnormal (msc$maintenance_services_id,
                 mse$system_critical_element, element_descriptor.channel_descriptor.name, status);
             = cmc$controller_element, cmc$storage_device_element ,
                cmc$communications_element, cmc$channel_adapter_element, cmc$external_processor_element =
               osp$set_status_abnormal (msc$maintenance_services_id,
                 mse$system_critical_element, element_descriptor.peripheral_descriptor.element_name, status);
             CASEND;
             EXIT /main_program/;
           IFEND;
         IFEND;

         { Check if element is not in DOWN state }

         IF cmv$peripheral_element_table.pointer^ [peripheral_index].element_status.state <> cmc$down THEN
           osp$set_status_abnormal (msc$maintenance_services_id, mse$element_state_not_proper,
             cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
           EXIT /main_program/;
         IFEND;

         { Check if element in CONCURRENT maintenance access }

         IF cmv$peripheral_element_table.pointer^ [peripheral_index].
             maintenance_activity.access = msc$concurrent_access THEN
           IF cmv$peripheral_element_table.pointer^ [peripheral_index].
               maintenance_activity.con_access_job_list <> NIL THEN
             osp$set_status_abnormal (msc$maintenance_services_id, mse$concurrent_access_granted,
               cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
             osp$append_status_parameter (osc$status_parameter_delimiter,
               cmv$peripheral_element_table.pointer^ [peripheral_index].maintenance_activity.
                 con_access_job_list^.job_name, status);
             EXIT /main_program/;
           IFEND;
         IFEND;

         { Check if element is CONTROLLER and in active physical }
         { configuration connected to another mainframe }

         need_to_warn_operator := FALSE;
         CASE element.element_type OF
         = cmc$controller_element =
           FOR upline_port := LOWERVALUE(cmt$controller_port_number) TO
                 UPPERVALUE(cmt$controller_port_number) DO
             IF definition.controller.connection.port [upline_port].configured THEN
               IF definition.controller.connection.port [upline_port].upline_connection_type
                        = cmc$data_channel_element THEN
                 IF definition.controller.connection.port [upline_port].mainframe_ownership
                        <> host_mainframe THEN
                   need_to_warn_operator := TRUE;
                   IF mainframe_list_p = NIL THEN
                     PUSH mainframe_list_p : [0 .. UPPERVALUE(cmt$controller_port_number)];
                     FOR i := LOWERBOUND(mainframe_list_p^) TO UPPERBOUND(mainframe_list_p^) DO
                       mainframe_list_p^ [i] := ' ';
                     FOREND;
                   IFEND;
                   mainframe_list_p^ [upline_port] := definition.controller.connection.port
                            [upline_port].mainframe_ownership;
                 IFEND;
               IFEND;
             IFEND;
           FOREND;

         = cmc$communications_element =
           FOR upline_port := LOWERVALUE(cmt$communications_port_number) TO
                 UPPERVALUE(cmt$communications_port_number) DO
             IF definition.communications_element.connection.port [upline_port].configured THEN
               IF definition.communications_element.connection.port [upline_port].upline_connection_type
                        = cmc$data_channel_element THEN
                 IF definition.communications_element.connection.port [upline_port].mainframe_ownership
                        <> host_mainframe THEN
                   need_to_warn_operator := TRUE;
                   IF mainframe_list_p = NIL THEN
                     PUSH mainframe_list_p : [0 .. UPPERVALUE(cmt$communications_port_number)];
                     FOR i := LOWERBOUND(mainframe_list_p^) TO UPPERBOUND(mainframe_list_p^) DO
                       mainframe_list_p^ [i] := ' ';
                     FOREND;
                   IFEND;
                   mainframe_list_p^ [upline_port] := definition.communications_element.connection.port
                            [upline_port].mainframe_ownership;
                 IFEND;
               IFEND;
             IFEND;
           FOREND;

         = cmc$storage_device_element =
           FOR upline_port := LOWERVALUE(cmt$data_storage_port_number) TO
                 UPPERVALUE(cmt$data_storage_port_number) DO
             IF definition.storage_device.connection.port [upline_port].configured THEN
               IF definition.storage_device.connection.port [upline_port].upline_connection_type
                        = cmc$data_channel_element THEN
                 IF definition.storage_device.connection.port [upline_port].mainframe_ownership
                        <> host_mainframe THEN
                   need_to_warn_operator := TRUE;
                   IF mainframe_list_p = NIL THEN
                     PUSH mainframe_list_p : [0 .. UPPERVALUE(cmt$data_storage_port_number)];
                     FOR i := LOWERBOUND(mainframe_list_p^) TO UPPERBOUND(mainframe_list_p^) DO
                       mainframe_list_p^ [i] := ' ';
                     FOREND;
                   IFEND;
                   mainframe_list_p^ [upline_port] := definition.storage_device.connection.port
                            [upline_port].mainframe_ownership;
                 IFEND;
               IFEND;
             IFEND;
           FOREND;
         ELSE
          { Other type of elements do not have multiple mainframe connections }
            ;
         CASEND;
         IF need_to_warn_operator THEN
           maintenance_allowed := FALSE;
          /operator_menu/
           BEGIN
             menu_for_maintenance_request (status);
             IF NOT status.normal THEN
               IF ((status.condition = dme$termination_condition) OR
                       (status.condition = dme$operator_stop)) THEN
                 EXIT /operator_menu/;
               IFEND;
             IFEND;
             maintenance_allowed := TRUE;
           END /operator_menu/;
           IF NOT maintenance_allowed THEN
             osp$set_status_abnormal (msc$maintenance_services_id, mse$maintenance_access_denied,
               definition.element_name, status);
             osp$append_status_parameter (osc$status_parameter_delimiter, terminate_reason, status);
             EXIT /main_program/;
           IFEND;
         IFEND;

         { Check to see if the element in the active physical }
         { configuration shows there being more channels connected to the }
         { controller than have been configured in active logical configuration }
         { If so, acquire all additional channels from the real state system }

         cmp$request_channels (dsc$rrt_get_channel, definition, host_mainframe, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;
         msp$mark_element_requested (element_descriptor, access, job_name, gtid, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;

       CASEND;

     END /main_program/;

  PROCEND msp$request_maintenance_access;

?? OLDTITLE ??
?? TITLE := '  msp$release_maintenance_access',EJECT ??

*copyc msh$release_maintenance_access

  PROCEDURE [XDCL, #GATE] msp$release_maintenance_access (
        element : cmt$element_descriptor;
    VAR status : ost$status);

    VAR
      caller_id : ost$caller_identifier,
      capability: boolean,
      concurrent_access: boolean,
      element_descriptor : cmt$element_descriptor,
      element_name : cmt$element_name,
      element_found: boolean,
      element_reservation : cmt$element_reservation,
      definition : cmt$element_definition,
      gtid : ost$global_task_id,
      gtid_found: boolean,
      iou : dst$iou_number,
      iou_information_table : dst$iou_information_table,
      job_name : jmt$system_supplied_name,
      job_name_found: boolean,
      lun: iot$logical_unit,
      lun_entry_locked: boolean,
      lun_entry_unlocked: boolean,
      local_status : ost$status,
      mainframe_id : pmt$mainframe_id,
      number_of_ious : dst$number_of_ious,
      physical_id : cmt$physical_identification,
      peripheral_index : integer,
      privileged_job: boolean,
      user_job_name: jmt$user_supplied_name;

   #caller_id (caller_id);
   privileged_job := caller_id.ring <= 6;
   status.normal := TRUE;
   /main_program/
     BEGIN
       avp$get_capability (avc$engineering_operation, avc$user, capability, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;

       IF NOT capability THEN
         IF caller_id.ring > 6 THEN
           osp$set_status_abnormal (cmc$configuration_management_id,
             cme$privileged_job_required, 'MSP$RELEASE_MAINTENANCE_ACCESS', status);
           EXIT /main_program/;
         IFEND;
       IFEND;
       pmp$get_job_names (user_job_name, job_name, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;
       dsp$retrieve_iou_information (number_of_ious, iou_information_table);

       element_descriptor.element_type := element.element_type;
       CASE element_descriptor.element_type OF
       = cmc$data_channel_element =
         element_descriptor.channel_descriptor := element.channel_descriptor;
         IF number_of_ious = 1 THEN
           cmp$convert_iou_number (iou_information_table [1].physical_iou_number,
                  element_descriptor.channel_descriptor.iou, status);
           IF NOT status.normal THEN
              EXIT /main_program/;
           IFEND;
         ELSE { validate IOU passed in is a valid name}
           cmp$convert_iou_name (element_descriptor.channel_descriptor.iou, iou, status);
           IF NOT status.normal THEN
             EXIT /main_program/;
           IFEND;
         IFEND;

       = cmc$channel_adapter_element, cmc$controller_element, cmc$storage_device_element ,
             cmc$communications_element,  cmc$external_processor_element =
         element_descriptor.peripheral_descriptor := element.peripheral_descriptor;
         IF NOT element_descriptor.peripheral_descriptor.use_logical_identification THEN
           IF number_of_ious = 1 THEN
             cmp$convert_iou_number (iou_information_table [1].physical_iou_number,
                   element_descriptor.peripheral_descriptor.
                   hardware_address.iou, status);
             IF NOT status.normal THEN
                EXIT /main_program/;
             IFEND;
           ELSE { validate IOU passed in is a valid name}
             cmp$convert_iou_name (element_descriptor.peripheral_descriptor.hardware_address.iou,
                   iou, status);
             IF NOT status.normal THEN
               EXIT /main_program/;
             IFEND;
           IFEND;
         IFEND;

       ELSE
       CASEND;

       pmp$get_executing_task_gtid (gtid);
       cmp$get_element_definition (element_descriptor, definition, status);
       IF NOT status.normal THEN
         cmp$format_error_message (element_descriptor, {not_used} physical_id, FALSE,
               cme$lcm_element_not_found, status);
         EXIT /main_program/;
       IFEND;

       IF element_descriptor.element_type <> definition.element_type THEN
         osp$set_status_abnormal (cmc$configuration_management_id, cme$incorrect_element_type,
               definition.element_name, status);
         EXIT /main_program/;
       IFEND;

       CASE element_descriptor.element_type OF

       = cmc$data_channel_element =
         IF NOT element_descriptor.channel_descriptor.use_logical_identification THEN
           element_descriptor.channel_descriptor.use_logical_identification := TRUE;
           element_descriptor.channel_descriptor.name := definition.element_name;
           element_descriptor.channel_descriptor.iou := definition.data_channel.iou;
         IFEND;

       = cmc$controller_element, cmc$storage_device_element , cmc$communications_element,
            cmc$channel_adapter_element, cmc$external_processor_element =
         IF NOT element_descriptor.peripheral_descriptor.use_logical_identification THEN
           element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
           element_descriptor.peripheral_descriptor.element_name := definition.element_name;
         IFEND;

       ELSE
       CASEND;

       cmp$search_peripheral_table (element_descriptor,
         element_reservation, FALSE, peripheral_index, status);
       IF NOT status.normal THEN
         EXIT /main_program/;
       IFEND;
       lun := cmv$peripheral_element_table.pointer^[peripheral_index].logical_unit_number;

       IF cmv$peripheral_element_table.
           pointer^ [peripheral_index].maintenance_activity.access = msc$dedicated_access THEN
         pmp$get_mainframe_id (mainframe_id, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;
         msp$unmark_element_requested (job_name, gtid, peripheral_index, mainframe_id, status);
         IF NOT status.normal THEN
           EXIT /main_program/;
         IFEND;
       ELSE
         IF cmv$peripheral_element_table.pointer^[peripheral_index].physical_descriptor.
               element_type = cmc$storage_device_element THEN
           IF lun <> 0 THEN
             cmp$clear_unit_shared (lun, TRUE);
           IFEND;
         IFEND;

         concurrent_access := TRUE;
         msp$search_con_access_job (peripheral_index, job_name, job_name_found, status);
         IF NOT job_name_found THEN
           osp$set_status_abnormal (msc$maintenance_services_id, mse$element_not_requested,
             cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
           EXIT /main_program/;
         ELSE
           msp$search_con_access_gtid (gtid, peripheral_index, gtid_found, status);
           IF NOT gtid_found THEN
             osp$set_status_abnormal (msc$maintenance_services_id, mse$element_not_requested,
               cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
             EXIT /main_program/;
           ELSE
             msp$delete_con_access_gtid (gtid, peripheral_index, status);
             msp$search_element_con_accessed (peripheral_index, element_found, status);
             IF NOT element_found THEN
               msp$delete_con_access_job (peripheral_index, job_name, status);
             IFEND;
           IFEND;
         IFEND;

       IFEND;

       IF cmv$peripheral_element_table.pointer^ [peripheral_index].
           physical_descriptor.element_type = cmc$storage_device_element THEN
         IF lun <> 0 THEN
           IF cmv$logical_unit_table^ [lun].status.assignable_device THEN
             rmp$release_tape_unit (dmv$null_sfid, lun, {delete_request_from_vsn_queue} FALSE, local_status);
           IFEND;
         IFEND;
       IFEND;

     END /main_program/;

 PROCEND msp$release_maintenance_access;

?? OLDTITLE ??
?? TITLE := '  msp$search_con_access_gtid', EJECT ??

{ PURPOSE:
{   This procedure determines whether or not the given global
{   task id is part of the concurrent access task id list.

  PROCEDURE msp$search_con_access_gtid (
        gtid : ost$global_task_id;
        peripheral_index : integer;
    VAR found : BOOLEAN;
    VAR status : ost$status );

    VAR
      con_access_gtid_list : mst$con_access_gtid_list;

    status.normal := TRUE;
    found := FALSE;

    /main_program/
    BEGIN
      con_access_gtid_list := msv$con_access_gtid_list;

      WHILE (con_access_gtid_list <> NIL) AND (NOT found) DO
        IF (con_access_gtid_list^.gtid = gtid) AND
            (con_access_gtid_list^.element_index = peripheral_index) THEN
          found := TRUE;
        ELSE
          con_access_gtid_list := con_access_gtid_list^.forward_link;
        IFEND;
      WHILEND;

    END /main_program/;

  PROCEND msp$search_con_access_gtid;

?? OLDTITLE ??
?? TITLE := '  msp$search_element_con_accessed', EJECT ??

{ PURPOSE:
{   This procedure determines whether or not the given index to
{   the element is in the concurrent access list.


  PROCEDURE [XDCL, #GATE] msp$search_element_con_accessed (
        element_index : integer;
    VAR found : BOOLEAN;
    VAR status : ost$status );

    VAR
      con_access_gtid_list : mst$con_access_gtid_list;

    status.normal := TRUE;
    found := FALSE;

    /main_program/
    BEGIN
      con_access_gtid_list := msv$con_access_gtid_list;

      WHILE (con_access_gtid_list <> NIL) AND (NOT found) DO
        IF con_access_gtid_list^.element_index = element_index THEN
          found := TRUE;
        ELSE
          con_access_gtid_list := con_access_gtid_list^.forward_link;
        IFEND;
      WHILEND;

    END /main_program/;

  PROCEND msp$search_element_con_accessed;

?? OLDTITLE ??
?? TITLE := '  msp$add_con_access_gtid', EJECT ??

{ PURPOSE:
{   This procedure adds a task id to the concurrent access list.

  PROCEDURE msp$add_con_access_gtid (
        gtid : ost$global_task_id;
        element_index : integer;
    VAR status : ost$status );

    VAR
      node : mst$con_access_gtid_list;

    status.normal := TRUE;

    /main_program/
    BEGIN

      ALLOCATE node IN osv$task_shared_heap^;
      node^.gtid := gtid;
      node^.element_index := element_index;
      node^.forward_link := NIL;

      IF msv$con_access_gtid_list =  NIL THEN
        msv$con_access_gtid_list := node;
      ELSE
        node^.forward_link := msv$con_access_gtid_list;
        msv$con_access_gtid_list := node;
      IFEND;

    END /main_program/;

  PROCEND msp$add_con_access_gtid;

?? OLDTITLE ??
?? TITLE := '  msp$delete_con_access_gtid', EJECT ??

{ PURPOSE:
{   This procedure deletes a task id from the concurrent access list.

  PROCEDURE [XDCL, #GATE] msp$delete_con_access_gtid (
        gtid : ost$global_task_id;
        element_index : integer;
    VAR status : ost$status );

    VAR
      found : BOOLEAN,
      deleted_node,
      before_deleted_node : mst$con_access_gtid_list;

    status.normal := TRUE;
    found := FALSE;

    /main_program/
    BEGIN

      deleted_node := msv$con_access_gtid_list;
      before_deleted_node := NIL;

      WHILE (deleted_node <> NIL) AND (NOT found) DO
        IF (deleted_node^.gtid = gtid) AND
            (deleted_node^.element_index = element_index) THEN
          found := TRUE;
        ELSE
          before_deleted_node := deleted_node;
          deleted_node := deleted_node^.forward_link;
        IFEND;
      WHILEND;

      IF found THEN
        IF msv$con_access_gtid_list^.forward_link = NIL THEN
          FREE msv$con_access_gtid_list IN osv$task_shared_heap^;
        ELSEIF before_deleted_node = NIL THEN
          msv$con_access_gtid_list := msv$con_access_gtid_list^.forward_link;
          FREE deleted_node in osv$task_shared_heap^;
        ELSE
          before_deleted_node^.forward_link := deleted_node^.forward_link;
          FREE deleted_node in osv$task_shared_heap^;
        IFEND;
      IFEND;

    END /main_program/;

  PROCEND msp$delete_con_access_gtid;

?? OLDTITLE ??
?? TITLE := '  msp$validate_media_access', EJECT ??

*copyc msh$validate_media_access

  PROCEDURE [XDCL, #GATE] msp$validate_media_access (
      storage_device : cmt$element_name;
      access : mst$access_type;
   VAR status : ost$status);

    VAR
      avt_entry_not_found: boolean,
      caller_id : ost$caller_identifier,
      capability: boolean,
      cm_unit_type : cmt$unit_type,
      definition : cmt$element_definition,
      element_descriptor : cmt$element_descriptor,
      element_info : array [1 .. 1] of cmt$element_info_item,
      element_reservation : cmt$element_reservation,
      found : boolean,
      io_unit_type : iot$unit_type,
      job_name : jmt$system_supplied_name,
      job_found: boolean,
      lun: iot$logical_unit,
      privileged_job : BOOLEAN,
      peripheral_index: integer,
      recorded_vsn : rmt$recorded_vsn,
      set_name : stt$set_name,
      search_key : dmt$avt_search_key,
      unit_class : cmt$unit_class,
      user_job_name: jmt$user_supplied_name,
      volume_info : stt$volume_info;

    #caller_id (caller_id);
    status.normal := TRUE;

    /main_program/
    BEGIN

      avp$get_capability (avc$engineering_operation, avc$user, capability, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF NOT capability THEN
        IF caller_id.ring > 6 THEN
          osp$set_status_abnormal (cmc$configuration_management_id,
            cme$privileged_job_required, 'MSP$VALIDATE_MEDIA_ACCESS', status);
          EXIT /main_program/;
        IFEND;
      IFEND;
      pmp$get_job_names (user_job_name, job_name, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      element_descriptor.element_type := cmc$storage_device_element;
      element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
      element_descriptor.peripheral_descriptor.element_name := storage_device;

      cmp$get_element_definition (element_descriptor, definition, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF element_descriptor.element_type <> definition.element_type THEN
        osp$set_status_abnormal (cmc$configuration_management_id, cme$element_not_storage_device,
              'MSP$VALIDATE_MEDIA_ACCESS', status);
        EXIT /main_program/;
      IFEND;

      element_info [1].selector := cmc$device_class;
      cmp$get_element_information (element_descriptor, element_info, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;
      IF element_info [1].item_returned THEN
        IF element_info [1].device_class <> rmc$mass_storage_device THEN
          osp$set_status_abnormal (msc$maintenance_services_id,
            mse$mass_device_required, storage_device, status);
          EXIT /main_program/;
        IFEND;
      IFEND;
      cmp$search_peripheral_table (element_descriptor,
        element_reservation, FALSE, peripheral_index, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      lun := cmv$peripheral_element_table.
         pointer^ [peripheral_index].logical_unit_number;

   { Check if element already RESERVED to any job }

      IF cmv$peripheral_element_table.pointer^ [peripheral_index].entry_interlock THEN
        IF cmv$peripheral_element_table.pointer^ [peripheral_index].reserved_status THEN
          osp$set_status_abnormal (msc$maintenance_services_id, cme$element_already_reserved,
            cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
          EXIT /main_program/;
        IFEND;
      IFEND;

      { Check if element already ASSIGNED to any job. Mass storage device can not assigned ??? }
      IF lun <> 0 THEN
        IF cmv$logical_unit_table^ [lun].status.assignable_device THEN
          IF cmv$logical_unit_table^ [lun].status.assigned THEN
            osp$set_status_abnormal (msc$maintenance_services_id, mse$element_already_assigned,
              cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
              cmv$logical_unit_table^ [lun].status.assigned_jsn, status);
            EXIT /main_program/;
          IFEND;
        IFEND;
      IFEND;


      CASE access OF
      = msc$concurrent_access =

        { Check if element is not in ON or DOWN state }

        IF cmv$peripheral_element_table.pointer^ [peripheral_index].element_status.state = cmc$off THEN
          osp$set_status_abnormal (msc$maintenance_services_id, mse$element_state_not_proper,
            cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
          EXIT /main_program/;
        IFEND;

        { Check to see if MASS storage device is the object of either CONCURRENT or DEDICATED maintenance. }

        /validate_job_name_1/
        BEGIN

          CASE cmv$peripheral_element_table.
            pointer^ [peripheral_index].maintenance_activity.access OF
          = msc$dedicated_access =
            IF cmv$peripheral_element_table.pointer^
                [peripheral_index].maintenance_activity.dedicated_accessor.active THEN
              IF cmv$peripheral_element_table.pointer^ [peripheral_index].
                  maintenance_activity.dedicated_accessor.job_identification <> job_name THEN
                osp$set_status_abnormal (cmc$configuration_management_id,
                  mse$dedicated_access_granted, cmv$peripheral_element_table.
                    pointer^ [peripheral_index].element_name, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                  cmv$peripheral_element_table.pointer^ [peripheral_index].
                    maintenance_activity.dedicated_accessor.job_identification, status);
                EXIT /main_program/;
              IFEND;
            IFEND;

          = msc$concurrent_access =

            msp$search_con_access_job (peripheral_index, job_name, job_found, status);
            IF NOT job_found THEN
              osp$set_status_abnormal (cmc$configuration_management_id,
                mse$req_maint_access_required, cmv$peripheral_element_table.
                  pointer^ [peripheral_index].element_name, status);
              EXIT /main_program/;
            IFEND;

          CASEND;

        END /validate_job_name_1/;


      = msc$dedicated_access =

        { NOTE : DEDICATED access will only GRANTED to media which does NOT }
        { have valid CUSTOMER or SYSTEM data recorded on it. }


        { Check if element is not in DOWN state }

        IF cmv$peripheral_element_table.pointer^ [peripheral_index].element_status.state <> cmc$down THEN
          osp$set_status_abnormal (msc$maintenance_services_id, mse$element_state_not_proper,
            cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
          EXIT /main_program/;
        IFEND;

        { Check to see if MASS storage device is the object of DEDICATED maintenance. }

        /validate_job_name_2/
        BEGIN

          IF cmv$peripheral_element_table.pointer^ [peripheral_index].
              maintenance_activity.access = msc$dedicated_access THEN
            IF cmv$peripheral_element_table.pointer^
                [peripheral_index].maintenance_activity.dedicated_accessor.active THEN
              IF cmv$peripheral_element_table.pointer^ [peripheral_index].
                  maintenance_activity.dedicated_accessor.job_identification <> job_name THEN
                osp$set_status_abnormal (cmc$configuration_management_id,
                  mse$dedicated_access_granted, cmv$peripheral_element_table.
                    pointer^ [peripheral_index].element_name, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                  cmv$peripheral_element_table.pointer^ [peripheral_index].
                    maintenance_activity.dedicated_accessor.job_identification, status);
                EXIT /main_program/;
              IFEND;
            IFEND;
          ELSE
            osp$set_status_abnormal (cmc$configuration_management_id,
              mse$req_maint_access_required, cmv$peripheral_element_table.
                pointer^ [peripheral_index].element_name, status);
            EXIT /main_program/;
          IFEND;
        END /validate_job_name_2/;

        { Check if media MOUNTED which is NOT a member of an active NOS/VE mass storage set. }
        { If it is a member, media access is DENIED. However, CE may ask OPERATOR to delete }
        { member from the set to allow DEDICATED access to the media. }

        search_key.value := dmc$search_avt_by_lun;
        search_key.logical_unit_number := lun;
        cmp$search_active_volume_table (search_key, recorded_vsn, avt_entry_not_found);
        IF NOT avt_entry_not_found THEN
          stp$get_volumes_set_name (recorded_vsn, set_name, status);
          IF NOT status.normal THEN
            { This is a normal status }
            status.normal := TRUE;
            EXIT /main_program/;
          IFEND;

          stp$is_volume_in_set (recorded_vsn, set_name, volume_info, status);
          IF status.normal THEN
            osp$set_status_abnormal (msc$maintenance_services_id, mse$media_is_member_of_set,
              cmv$peripheral_element_table.pointer^ [peripheral_index].element_name, status);
            osp$append_status_parameter (
              osc$status_parameter_delimiter, recorded_vsn, status);
            osp$append_status_parameter (
              osc$status_parameter_delimiter, set_name, status);
            EXIT /main_program/;
          ELSE
            status.normal := TRUE;
          IFEND;
        IFEND;
      CASEND;

      { SUCCESSFUL attempts to obtain maintenance access to media which has }
      { CUSTOMER data on it will be logged in the ENGINEERING log. }

    END /main_program/;

  PROCEND msp$validate_media_access;

?? OLDTITLE ??
?? TITLE := '  Ring 3 helper for MAINTENANCE_SERVICES_UTILITY', ??

  PROCEDURE [XDCL, #GATE] msp$mount_storage_medium
    (    storage_device: cmt$peripheral_descriptor;
         medium: rmt$external_vsn;
         write_access: boolean;
         wait_for_attachment: fst$wait_for_attachment;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

    #caller_id (caller_id);
    IF caller_id.ring > 6 THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$privileged_job_required,
              'MSP$MOUNT_STORAGE_MEDIUM',status);
      RETURN;
    IFEND;
    status.normal := TRUE;
    cmp$mount_storage_medium (storage_device, medium, write_access, wait_for_attachment,
        status);
  PROCEND msp$mount_storage_medium;

  PROCEDURE [XDCL, #GATE] msp$reserve_element
    (VAR {input,output} element: array [ * ] of cmt$element_reservation;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

    #caller_id (caller_id);
    IF caller_id.ring > 6 THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$privileged_job_required,
              'MSP$RESERVE_ELEMENT',status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    cmp$reserve_element (element, status);

  PROCEND msp$reserve_element;

  PROCEDURE [XDCL, #GATE] msp$release_element
    (    element: array [ * ] of cmt$element_reservation;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

    #caller_id (caller_id);
    IF caller_id.ring > 6 THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$privileged_job_required,
              'MSP$RELEASE_ELEMENT',status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    cmp$release_element (element, status);

  PROCEND msp$release_element;

  PROCEDURE [XDCL, #GATE] msp$execute_pp_program
    (VAR program_description: array [1 .. * ] of cmt$pp_program_description;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

    #caller_id (caller_id);
    IF caller_id.ring > 6 THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$privileged_job_required,
              'MSP$EXECUTE_PP_PROGRAM',status);
      RETURN;
    IFEND;
    status.normal := TRUE;
    cmp$execute_pp_program (program_description, status);

  PROCEND msp$execute_pp_program;

  PROCEDURE [XDCL, #GATE] msp$idle_pp
    (    pp_identification: cmt$pp_identification;
         break_interlocks: boolean;
         hardware_idle_pp: boolean;
         pp_memory_area: ^SEQ ( * );
     VAR actual_pp_memory_size: cmt$pp_memory_length;
     VAR pp_registers: cmt$pp_registers;
     VAR pp_software_idled: boolean;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

    #caller_id (caller_id);
    IF caller_id.ring > 6 THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$privileged_job_required,
              'MSP$EXECUTE_PP_PROGRAM',status);
      RETURN;
    IFEND;
    status.normal := TRUE;
    cmp$idle_pp (pp_identification, break_interlocks, hardware_idle_pp, pp_memory_area,
         actual_pp_memory_size, pp_registers, pp_software_idled, status);

  PROCEND msp$idle_pp;


  PROCEDURE [XDCL, #GATE] msp$resume_pp
    (    pp_identification: cmt$pp_identification;
         hardware_resume_pp: boolean;
         start_address: cmt$pp_memory_length;
     VAR pp_software_resumed: boolean;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

    #caller_id (caller_id);
    IF caller_id.ring > 6 THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$privileged_job_required,
              'MSP$RESUME_PP',status);
      RETURN;
    IFEND;
    status.normal := TRUE;
    cmp$resume_pp (pp_identification, hardware_resume_pp, start_address, pp_software_resumed,
        status);

  PROCEND msp$resume_pp;

  PROCEDURE [XDCL, #GATE] msp$get_pp_registers
    (    pp_identification: cmt$pp_identification;
     VAR pp_registers: cmt$pp_registers;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

    #caller_id (caller_id);
    IF caller_id.ring > 6 THEN
      osp$set_status_abnormal (cmc$configuration_management_id, cme$privileged_job_required,
              'MSP$GET_PP_REGISTERS',status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    cmp$get_pp_registers (pp_identification, pp_registers, status);

  PROCEND msp$get_pp_registers;
MODEND msm$request_maintenance_access;


*DECK DECK=MSP$ADD_CON_ACCESS_JOB EXPAND=FALSE

   PROCEDURE [XREF] msp$add_con_access_job (
          peripheral_index : integer;
          job_name : jmt$system_supplied_name;
      VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=MSP$ASSIGN_FLAWED_MEMORY EXPAND=FALSE

  PROCEDURE [XREF] msp$assign_flawed_memory (element: cmt$element_name;
    pva: ost$pva;
    VAR status: ost$status);
?? PUSH (LISTEXT:=ON ) ??
*copyc cmt$element_name
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=MSP$ASSIGN_REAL_PAGE EXPAND=FALSE

  PROCEDURE [XREF] msp$assign_real_page (element: cmt$element_name;
    pva: ost$pva;
    rma: mst$real_memory_address;
    VAR page_status: mst$page_status;
    VAR status: ost$status);
?? PUSH (LISTEXT:=ON ) ??
*copyc cmt$element_name
*copyc osd$virtual_address
*copyc mst$real_memory_address
*copyc mst$page_status
*copyc ost$status
?? POP ??
*DECK DECK=MSP$DELETE_CON_ACCESS_GTID EXPAND=FALSE

   PROCEDURE [XREF] msp$delete_con_access_gtid (
          gtid : ost$global_task_id;
          element_index : integer;
      VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc ost$status
?? POP ??
*DECK DECK=MSP$DELETE_CON_ACCESS_JOB EXPAND=FALSE

   PROCEDURE [XREF] msp$delete_con_access_job (
          peripheral_index : integer;
          job_name : jmt$system_supplied_name;
      VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=MSP$EXECUTE_DIAGNOSTICS EXPAND=FALSE

 PROCEDURE [XREF] msp$execute_diagnostics (diagnostic_path:
  cmt$diagnostic_path;
    VAR results: SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$diagnostic_path
*copyc ost$status
?? POP ??
*DECK DECK=MSP$EXECUTE_PP_PROGRAM EXPAND=FALSE

  PROCEDURE [XREF] msp$execute_pp_program
    (VAR program_description: array [1 .. * ] of cmt$pp_program_description;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pp_program_description
*copyc ost$status
?? POP ??
*DECK DECK=MSP$FLAW_PAGE EXPAND=FALSE

  PROCEDURE [XREF] msp$flaw_page (element: cmt$element_name;
    rma: mst$real_memory_address;
    VAR page_status: mst$page_status;
    VAR status: ost$status);
?? PUSH (LISTEXT:=ON ) ??
*copyc cmt$element_name
*copyc mst$real_memory_address
*copyc mst$page_status
*copyc ost$status
?? POP ??
*DECK DECK=MSP$GET_CORRECTED_ERROR_LOG EXPAND=FALSE

  PROCEDURE [XREF] msp$get_corrected_error_log (element: cmt$element_name;
    reset_buffer: boolean;
    VAR buffer: mst$corrected_error_log_buffer;
    VAR status: ost$status);
?? PUSH (LISTEXT:=ON ) ??
*copyc cmt$element_name
*copyc mst$corrected_error_log
*copyc ost$status
?? POP ??
*DECK DECK=MSP$GET_PP_REGISTERS EXPAND=FALSE

  PROCEDURE [XREF] msp$get_pp_registers
    (    pp_identification: cmt$pp_identification;
     VAR pp_registers: cmt$pp_registers;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc cmt$pp_identification
*copyc cmt$pp_registers
*copyc ost$status
?? POP ??
*DECK DECK=MSP$IDLE_PP EXPAND=FALSE

  PROCEDURE [XREF] msp$idle_pp
    (    pp_identification: cmt$pp_identification;
         break_interlocks: boolean;
         hardware_idle_pp: boolean;
         pp_memory_area: ^SEQ ( * );
     VAR actual_pp_memory_size: cmt$pp_memory_length;
     VAR pp_registers: cmt$pp_registers;
     VAR pp_software_idled: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pp_identification
*copyc cmt$pp_memory_length
*copyc cmt$pp_registers
*copyc ost$status
?? POP ??
*DECK DECK=MSP$LOAD_STANDARD_MICROCODE EXPAND=FALSE
 PROCEDURE [XREF] msp$load_standard_microcode (path: cmt$diagnostic_path;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$diagnostic_path
*copyc ost$status
?? POP ??
*DECK DECK=MSP$MARK_ELEMENT_REQUESTED EXPAND=FALSE

   PROCEDURE [XREF] msp$mark_element_requested (
          element : cmt$element_descriptor;
          access_type : mst$access_type;
          job_name : jmt$system_supplied_name;
          gtid : ost$global_task_id;
          VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_descriptor
*copyc jmt$system_supplied_name
*copyc ost$global_task_id
*copyc mst$access_type
*copyc ost$status
?? POP ??

*DECK DECK=MSP$MOUNT_STORAGE_MEDIUM EXPAND=FALSE

  PROCEDURE [XREF] msp$mount_storage_medium
    (    storage_device: cmt$peripheral_descriptor;
         medium: rmt$external_vsn;
         write_access: boolean;
         wait_for_attachment: fst$wait_for_attachment;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$peripheral_descriptor
*copyc rmd$volume_declarations
*copyc fst$wait_for_attachment
*copyc ost$status
?? POP ??
*DECK DECK=MSP$RELEASE_ELEMENT EXPAND=FALSE

  PROCEDURE [XREF] msp$release_element
    (    element: array [ * ] of cmt$element_reservation;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_reservation
*copyc ost$status
?? POP ??
*DECK DECK=MSP$RELEASE_MAINTENANCE_ACCESS EXPAND=FALSE


 PROCEDURE [XREF] msp$release_maintenance_access (element:
  cmt$element_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=MSP$REQUEST_MAINTENANCE_ACCESS EXPAND=FALSE


 PROCEDURE [XREF] msp$request_maintenance_access (element:
  cmt$element_descriptor;
        access: mst$access_type;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_descriptor
*copyc mst$access_type
*copyc ost$status
?? POP ??
*DECK DECK=MSP$RESERVE_ELEMENT EXPAND=FALSE

  PROCEDURE [XREF] msp$reserve_element
    (VAR {input,output} element: array [ * ] of cmt$element_reservation;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_reservation
*copyc ost$status
?? POP ??
*DECK DECK=MSP$RESUME_PP EXPAND=FALSE


  PROCEDURE [XREF] msp$resume_pp
    (    pp_identification: cmt$pp_identification;
         hardware_resume_pp: boolean;
         start_address: cmt$pp_memory_length;
     VAR pp_software_resumed: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$pp_identification
*copyc cmt$pp_memory_length
*copyc ost$status
?? POP ??
*DECK DECK=MSP$SEARCH_CON_ACCESS_JOB EXPAND=TRUE

   PROCEDURE [XREF] msp$search_con_access_job (
          peripheral_index : integer;
          job_name : jmt$system_supplied_name;
      VAR found : BOOLEAN;
      VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??

*DECK DECK=MSP$SEARCH_ELEMENT_CON_ACCESSED EXPAND=TRUE

   PROCEDURE [XREF] msp$search_element_con_accessed (
          element_index : integer;
      VAR found : BOOLEAN;
      VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=MSP$UNFLAW_PAGE EXPAND=FALSE

  PROCEDURE [XREF] msp$unflaw_page (element: cmt$element_name;
    rma: mst$real_memory_address;
    VAR status: ost$status);
?? PUSH (LISTEXT:=ON ) ??
*copyc cmt$element_name
*copyc mst$real_memory_address
*copyc ost$status
?? POP ??
*DECK DECK=MSP$UNMARK_ELEMENT_REQUESTED EXPAND=FALSE

   PROCEDURE [XREF] msp$unmark_element_requested (
          job_name : jmt$system_supplied_name;
          gtid : ost$global_task_id;
          peripheral_index : integer;
          mainframe_id : pmt$mainframe_id;
          VAR status : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$mainframe_id
*copyc jmt$system_supplied_name
*copyc ost$global_task_id
*copyc ost$status
?? POP ??
*DECK DECK=MSP$VALIDATE_MEDIA_ACCESS EXPAND=FALSE


 PROCEDURE [XREF] msp$validate_media_access (storage_device: cmt$element_name;
        access: mst$access_type;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc mst$access_type
*copyc ost$status
?? POP ??
*DECK DECK=MST$ACCESS_TYPE EXPAND=FALSE
 TYPE
    mst$access_type = (msc$concurrent_access, msc$dedicated_access);
*DECK DECK=MST$CON_ACCESS_GTID_LIST EXPAND=TRUE

TYPE
  mst$concurrent_access_gtid = RECORD
    gtid : ost$global_task_id,
    element_index : integer,
    forward_link : mst$con_access_gtid_list,
  RECEND;

TYPE
  mst$con_access_gtid_list = ^mst$concurrent_access_gtid;

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
?? POP ??
*DECK DECK=MST$CON_ACCESS_JOB_LIST EXPAND=TRUE

TYPE
  mst$con_access_job_list = ^mst$concurrent_access_job,

  mst$concurrent_access_job = RECORD
    job_name : jmt$system_supplied_name,
    forward_link : mst$con_access_job_list,
  RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
?? POP ??

*DECK DECK=MST$CORRECTED_ERROR_LOG EXPAND=FALSE

  CONST
    msc$maximum_memory_error_count = 1000,
    msc$memory_cel_entry_count = 10;

  TYPE
    mst$cel_type = (msc$m1_cel, msc$m2_cel, msc$m3_cel, msc$mtheta_cel,
      msc$p1_cel, msc$p2_cel, msc$p3_cel, msc$ptheta_cel),

    mst$memory_cel = record
      unlogged_entries: boolean,
      port_number: 0 .. 0f(16),
      syndrome_code: 0 .. 0ff(16),
      address_and_parity: 0 .. 7ffffff(16),
      count: 0 .. msc$maximum_memory_error_count,
    recend,

    mst$corrected_error_log_buffer = record
      case log_type: mst$cel_type of
      = msc$m1_cel .. msc$mtheta_cel =
        memory_cel: array [1 .. msc$memory_cel_entry_count] of mst$memory_cel,
      = msc$p1_cel .. msc$ptheta_cel =
{To be defined jointly by AHPD and CDED}
        processor_cel: array [0 .. 0ff(16)] of cell,
      casend,
    recend;
*DECK DECK=MST$PAGE_STATUS EXPAND=FALSE

  TYPE
    mst$page_status = record
      page_not_available: boolean,
      owner: {to be supplied} 0 .. 1,
      state_of_page: set of (msc$system_owned, msc$user_non_pageable, msc$free,
        msc$flawed, msc$used, msc$modified),
    recend;
*DECK DECK=MST$REAL_MEMORY_ADDRESS EXPAND=FALSE

  TYPE
    mst$real_memory_address = 0 .. 0ffffffff(16);
*DECK DECK=MSV$CON_ACCESS_GTID_LIST EXPAND=TRUE

  VAR
    msv$con_access_gtid_list : [XREF] mst$con_access_gtid_list;

?? PUSH (LISTEXT := ON) ??
*copyc mst$con_access_gtid_list
?? POP ??
*DECK DECK=MTA$BOOT_CONTROL_TABLE EXPAND=FALSE
.
.  Define equates used to reference fields in the boot control table.
.  Note - only fields referenced from assembly language are defined.
.
bctflags   equ     1*8          .Boot Control Table flags
.
*DECK DECK=MTA$CPU_STATE_TABLE EXPAND=FALSE
.................begin common deck MTA$CPU_STATE_TABLE................
. WARNING! WARNING! WARNING! WARNING! WARNING! WARNING! WARNING!
.     If this type is changed the type OST$CPU_STATE_TABLE must reflect a
.     corresponding change!
.
maxcst    equ    2           .maximum cst entries.
cstsize   equ    34*8        .Size of CST
.
.. Define offsets for the various fields in CST.
.
fill      equ    0
prior180  equ    1           .CPU priority (180)
dsprior   equ    2           .dual-state priority and subpriority
memport   equ    4           .processor memory port.
lpid      equ    5           .logical processor id
cpu_stat  equ    6           .cpu state (on/off/down)
nextstat  equ    7           .next cpu state (on/off/down)
cpwell    equ    1*8         .Changing value = CPU alive.
taskid    equ    2*8         .Taskid of current task.
ajlo      equ    2*8+3       .AJLO of current task,
cp_state  equ    3*8+6       .current/requested processor states: (2 bytes)
dualstat  equ    2*8+4       .NOS JPS if dual state, 0 if not dual state.
jcbp      equ    3*8         .JCB_P to current task's JCB.
xcbp      equ    4*8         .Pointer to XCB of current task.
xcbrma    equ    5*8         .RMA of current task XP.
discntl   equ    6*8         .Dispatch control info.
cptime    equ    7*8         .Max cptime for current task.
jtime     equ    8*8         .Time in job mode for current task.
mtime     equ    9*8         .Time in monitor mode for current task.
ext_int   equ    10*8        .type of external interrupt request
idlecode  equ    10*8+1      .system idle code
lpid8     equ    10*8+2      .LPID times 8.
cachtim   equ    11*8        .time cache purged
maptim    equ    12*8        .time map purged
mps       equ    13*8        .Monitor MPS.
elem_id   equ    14*8        .processor element id
ijlo      equ    15*8        .IJL ordinal of current task.
ijlep     equ    15*8+2      .Pointer to IJL entry.
idlstats  equ    16*8        .cpu idle statistics
tracectl  equ    20*8        .trace control
termmess  equ    21*8        .termination message record
cpstreas  equ    31*8        .reason for current state of CPU
cpprepro  equ    31*8+1      .CPU preprocessing state
unused    equ    31*8+2      .
prevstat  equ    31*8+3      .previous CPU state
log_stat  equ    31*8+4      .TRUE = Log CPU state change
dpint     equ    32*8        .integer value of the dispatching priority
return    equ    33*8        .return address after processing SIT interrupt.
.
caldisp   equ    discntl     .This byte can be set to '1' to force a call to
                             . the CPU dispatcher.
asyncp   equ     discntl+4   .this byte is set true when async events
.                            or external interrupts are pending.
.  define offsets into ext_int
tsk_sw    equ    0           .switch task
pur_ca    equ    1           .purge_cache
pur_map   equ    2           .purge_map
step_pr   equ    3           .step processor
.
.  define offsets into idlstats
idl_noio  equ    0           .cumulative idle time with no IO active
idl_w_io  equ    1*8         .cumulative idle time with IO active
idlstart  equ    2*8         .starting time for current idle
idletype  equ    3*8         .type of cpu idle: with or without IO active
idle_cnt  equ    3*8+1       .number of times the cpu goes idle
.
.  define offsets into termmess
tm_size   equ    0           .size of termination message
tm_un_id  equ    0*8+1       .unique identifier
tm_text   equ    0*8+2       .text of termination message
.
.  value assigned cpu state and next cpu state (cp_stat, nextstat)
.  also known as CYBIL ordinal type CMT$ELEMENT_STATE
on        equ    0
off       equ    1
down      equ    2
.
.  define offsets into cpu_state
cp_curst  equ    0*8         .current cpu state
cp_nxtst  equ    0*8+1       .next cpu state
.
.  value assigned current, next cpu_state
running   equ    0
stepped   equ    1
.................end common deck MTA$CPU_STATE_TABLE.....................
*DECK DECK=MTA$DFT_BLOCK EXPAND=FALSE
.
.  MTA$DFT_BLOCK - This deck defines used by assembly language decks to reference fields in the
.                  DFT. Only fields that are referenced are defined.
.
dftcw     equ      0                      .DFT control word.
.
*DECK DECK=MTA$SMU_COMMUNICATION_BLOCK EXPAND=FALSE
.
.  Define equates used to reference fields in the SMU Communications Block (SCB)
.  Note - only fields referenced from assembly language are defined.
.
scbsize    equ     50*8         .Length of SCB.
scbvecsim  equ     1*8+1        .Vector simulation control (3 bytes)
scbidler   equ     2*8          .Non-zero if IDLE is requested.
scbstepr   equ     2*8+2        .Non-zero if STEP is requested.
scbnsrv    equ     3*8          .Flag to indicate 180 is alive and well.
.
*DECK DECK=MTAMS EXPAND=FALSE
.......................begin common deck MTAMS.............................
.
.   defines the offset into MTV$MLI_STATUS.
.
.
mlirdy   equ       0                   .memory link ready
mliwt    equ       1                   .memory link wait inhibited
.
...........................end common deck MTAMS..........................
*DECK DECK=MTC$DEBUG_CONSTANTS EXPAND=FALSE

{ This deck defines debug constants that may be turned on at compile time to
{ assist in debugging monitor code. All constants should be set to
{ FALSE for the transmitted version of this deck.

  ?VAR
    mtc$debug_interlocks: boolean := FALSE,       {Verify interlocks

    mtc$zzz_end: boolean := FALSE?;               {Dummy for end-of-list
*DECK DECK=MTC$JOB_FIXED_SEGMENT EXPAND=FALSE

{ MTDCON - contains the various constants used by the MONITOR.

  CONST
    mtc$job_fixed_segment = 20;
*DECK DECK=MTC$SCB_MAX_HARDWARE_STATUS EXPAND=FALSE

{ CONST deck MTC$SCB_MAX_HARDWARE_STATUS

  CONST
    mtc$scb_max_hardware_status = 0ff(16);

*DECK DECK=MTH$PROCESS_DUE EXPAND=FALSE
{
{ PURPOSE:
{  The purpose of this procedure is to process a detected/uncorrected
{  error (DUE) caught by the hardware and the monitor interrupt processor.
{  The DUE is logged in a circular central memory buffer (only for debugging
{  purposes) and the task is handled as detailed in Figure 9.1-1 of the MIGDS
{  and 180 Operating System action section 4.2.9 of the DFT/OS Interface
{  specification. If certain conditions are met, the CPU which has encountered
{  the DUE will be deconfigured out of the system.
{
{  MTP$PROCESS_DUE (DUE_STATE,CST_P,XP_P)
{
{  DUE_STATE: (INPUT) This parameter specifies where the DUE occurred; i.e. in
{                     the 170 state, or the 180 states of job or monitor mode.
{  CST_P:     (INPUT) Pointer to the CPU state table of the CPU with the DUE.
{  XP_P:      (INPUT) Pointer to the exchange package which was executing when
{                     the DUE was encountered
{

*DECK DECK=MTK$KEYPOINTS EXPAND=FALSE

  CONST

    mtk$job_entry_exit = mtk$assembly_language_base + 1,
      {EM 'ENTER 180 MONITOR MODE' 'MCR' H16 }
      {XM 'EXIT  180 MONITOR MODE'   }

    mtk$170_entry_exit = mtk$assembly_language_base + 2,
      {EC 'ENTER NOS 170' }
      {XC 'EXIT  NOS 170' 'MCR' H16 }

    mtk$monitor_mode_trap = mtk$assembly_language_base + 3,
      {ET 'ENTER MONITOR TRAP HANDLER' 'MCR' H16 }
      {XT 'EXIT  MONITOR TRAP HANDLER'  }

    mtk$job_mode_trap = mtk$assembly_language_base + 4;
      {ET 'ENTER JOB TRAP HANDLER' 'MCR' H16 }
      {XT 'EXIT  JOB TRAP HANDLER'  }
*DECK DECK=MTM$170_TRAP_HANDLER EXPAND=TRUE
mtm$170_trap_handler ident
         list      1,1,0
         space     4
*copy ASMREGS
*copy OSA$DUAL_STATE_CONTROL_BLOCK
*copy OSA$EI_INTERFACE_CONSTANTS
*copy osa$dual_state_170_os_stack
*copy MTAMS
*copyc osa$dft_constants
*copy OSA$EI_CONSTANT_DEFINITIONS
*copy SYA$XP_AND_SF_CONSTANTS
         PAGE
.
.        EIE        - EI EXTENSIONS FOR DUAL STATE OPERATION
.
.        ENTRY POINT INTO THE A170 ENVIRONMENT AFTER C180 STATE IS
.        DEADSTARTED FROM WITHIN THE A170 ENVIROMENT. THIS ROUTINE
.        REINITIALIZES THE C170 REGISTERS, PLACES THE CORRECT PVA'S
.        INTO THE STACK FRAME SAVE AREA AND RETURNS CONTROL TO THE
.        C170 ENVIRONMENT. EIE IS INITIATED AS A SPECIAL NOS/VE
.        TASK BY C180 STATE.
.
.        entry     - A3 = PVA of C170 stack and SSR segment.
.
.        exit      Trap handler initialized for dual state operation.
.
         DEFG      mtp$170_trap_handler
.
.        ****ENTER HERE FROM NVE VIA AN EXCHANGE JUMP TO START DUAL STATE***
.
oss$nos_trap_handler section working,read+execute,,0,8
         use       oss$nos_trap_handler
mtp$170_trap_handler bss 0
         ENTL      X0,0c0(16)          .DISABLE TRAPS
         CPYXS     X0,X0
         ADDAQ     a_psa,a_static,sf_job_stack
         ADDAQ     a_dsp,a_psa,33*8
         CPYAA     a_csf,a_dsp
         addpxq    a_wrk,x0,mtp$170_trap_handler
         la        a_dscb,a_wrk,dscb_pva
         la        a_dscb,a_dscb,0     .fetch dscb pointer
.
.        CLEAR EI WORKING STORAGE MEMORY.
.
         entp      x1,0
         tpage     x1,a_psa            .translate stack frame address
         lbyts,4   x2,a_dscb,x0,ve_sfsa
         brxeq     x1,x2,nth2          .if clear not required
         ENTE      X2,ssrdir/8-1
         entp      x1,0
         ENTP      X0,0
nth1     SXI       X0,a_static,X1,0    .CLEAR EI WORKING STORAGE
         brinc     X2,X1,nth1          .LOOP TO END OF EI WORKING STORAGE
nth2     addaq     a8,a_static,ssrdir
         sa        a8,a_static,pva_2
.
         la        a_nos,a_wrk,nos_pva
         la        a_jps,a_wrk,nos_xp
         la        a_nos,a_nos,0       .fetch pva of nos segment
         la        a_jps,a_jps,0       .fetch pva of nos exchange package
         sa        a_dscb,a_static,pva_of_dscb
         sa        a_nos,a_static,pva_of_os
         sa        a_static,a_wrk,tcbp+10 .store pointer to working storage
.
         lbyts,2   x1,a_wrk,x0,mliptr  .create ptr to mf wired
         shfx      x1,x1,x0,32
         sbyts,6   x1,a_static,x0,pva_3
.
.        NOTIFY HELPER PP TO MOVE STACK-FRAME-SAVE AREA OF THE
.        OLD 'IDLED' ENVIRONMENT INTO THE NEW EI WORKING STORAGE
.        SAVE AREA.
.
         entp      x1,0
         tpage     x1,a_psa            .translate stack frame address
         lbyts,4   x2,a_dscb,x0,ve_sfsa
         subr      x2,x1               .calculate offset to sfsa
         cpyaa     a8,a_psa
         addax     a8,x2               .move stack from save area to stack frame
         brreq     x0,x2,nth3          .if move from boot
         movb,a8,x0  a_psa,x1  0,0,17*8,0     0,0,17*8,0
         movb,a8,x0  a_psa,x1  0,0,16*8,17*8  0,0,16*8,17*8
         sbyts,4   x1,a_dscb,x0,ve_sfsa
.
nth3     la        a9,a_wrk,nos_st
         la        a9,a9,0             .fetch pointer to segment table
         la        a8,a_wrk,boot_sdte
         lbyts,8   x3,a8,x0,0
         brxeq     x3,x0,nth5          .if no boot segment
         sx        x3,a9,8*2           .save boot sdte in segment 2
         ente      x3,1002(16)         .build pointer to boot segment
         sbyts,2   x3,a_static,x0,pva_3+8
         la        a8,a_static,pva_3+8 .form pointer to 170 xp in boot
         lbyts,1   x2,a8,x0,xp_vmid
         brreq     x0,x2,nth5          .if nothing to move
         ente      x6,xp_x0
         entp      x5,0
nth4     lbyts,6   x3,a8,x5,2
         sbyts,6   x3,a_psa,x5,2
         incr      x5,8
         brrne     x5,x6,nth4          .if more a registers to move
         movb,a8,x0  a_psa,x1  0,0,16*8,17*8  0,0,16*8,17*8
nth5     entp      x2,0
         sx        x2,a9,8*2           .clear segment 2 entry
         sa        a_jps,a_static,pva_3+8 .save offset to JPS
.
         lbyts,2   x2,a_psa,x0,xp_pit  .upper 32 bits of pit
         lbyts,2   x3,a_psa,x0,xp_pit+8
         insb      x3,x2,x0,4017(8)
         entl      x0,0c9(16)
         cpyxs     x3,x0               .update PIT
         tpage     x6,a_jps
         sbyts,4   x6,a_dscb,x0,ve_jps
.
.        SET TRAP POINTER TO EIE VALUE.
.
         ENTE      X1,0C4(16)          .TRAP POINTER REGISTER
         addpxq    a8,x0,tcbp
         cpyax     x2,a8
         CPYXS     X2,X1               .SET EI TRAP POINTER
.
.        ADJUST PVA'S FOR NOS/VE TRAP 017 TASK JOB MODE
.        NEED TO FIX-
.        P, A0, A1, A2 at sf_job_stack
.
         SA        a_psa,a_psa,xp_a0   .A0 TO sf_job_stack
         SA        a_psa,a_psa,xp_a0+8 .A1 TO sf_job_stack
.
.        RETURN TO C170 ENVIRONMENT.
.
         entp      x2,REST170          .SET RESTART C170 STATUS
         ENTP      X1,1
         INSB      X2,X1,X0,B180DST    .SET C180 DEADSTARTED BIT
         SBYTS,4   X2,a_dscb,X0,ds_stat
         BRREQ     X0,X0,trap5
         PAGE
.
.        TRAP CODE BASE POINTER PAIR.
.
         ALIGN     0,8
tcbp     address   ce,trap
.
.        READ ONLY VARIABLES.
.
         ref       mtv$mli_status,mtv$nst_p,mtv$nos_seg_p,mtv$ns_xp_p
         ref       mlv$c170_rqst_blk,osv$boot_sdte,mtv$nos_segment_table_p
         ref       mlv$enable_hot_key
mlistat  ADDRESS   R,mtv$mli_status
dscb_pva address   r,mtv$nst_p
hotkey   address   r,mlv$enable_hot_key
nos_pva  address   r,mtv$nos_seg_p
nos_xp   address   r,mtv$ns_xp_p
nos_st   address   r,mtv$nos_segment_table_p
boot_sdte address  r,osv$boot_sdte
mliptr   address   r,mlv$c170_rqst_blk
.
.        MEMORY LINK STATUS
.
         ALIGN     0,2
         PAGE
...
.        trap       - TRAP 017 INTERFACE ROUTINES ENTRY.
.
.        ENTRY POINT FOR TRAP PROCESSING FROM C170 STATE.
.        THE C170 ENVIRONMENT IS SAVED IN sf_job_stack STACK FRAME SAVE AREA
.        AND CONTROL IS TRANSFERRED TO THE RESPECTIVE TRAP CONDITION
.        HANDLERS. THE TRAP HANDLERS ALWAYS RETURN CONTROL TO trap5
.        ON COMPLETION.
.        THE TRAP HANDLERS ARE OF TWO CATEGORIES:
.
.        1. CMU INSTRUCTION SIMULATION ROUTINES, CALLED WHEN THE
.                  UNIMPLEMENTED INSTRUCTION TRAP BIT IS SET AND THE TRAP
.                  CONDITION IS NOT DUE TO A TRAP170 INSTRUCTION.
.
.        2. T017 REQUEST CALL, TRAP IS CAUSED BY an 017 INSTRUCTION.
.
.        ENTRY      - (A0) = sf_job_stack + 33*8
.                      (A1) = sf_job_stack + 33*8
.                      (A2) = sf_job_stack
.                      (A3) = BTH017
.                      ALL OTHER REGISTERS AS DEFINED BY C170 STATE.
.
.        EXIT       TRAP CONDITIONS SERVICED, RETURN TO A170 ENVIRONMENT
.                  OR GIVE CONTROL TO NOS/VE WHEN HIGHER PRIORITY.
.
.        REGISTER USAGE
.                  (A0) = sf_job_stack + 33*8
.                  (A1) = sf_job_stack + 33*8
.                  (a_psa) = sf_job_stack
.                  (a_static) = EI WORKING STORAGE
.                  (a_wrk) = Trap handler pva.
.
.
.        ***ENTER HERE FROM C170 STATE VIA A TRAP***
.
         ALIGN     0,8                 .MUST BE ON WORD BOUNDARY
trap     BSS       0
         ENTL      X0,0
         SBYTS,3   X0,a_psa,X0,xp_cb0     .CLEAR C170 B0 REGISTER
         LA        a_nos,a_static,pva_of_os  .NOS POINTER
         la        a_dscb,a_static,pva_of_dscb  .dscb pointer
         addpxq    a_wrk,x0,mtp$170_trap_handler
         lbyts,3   x_flc,a_psa,x0,xp_flc  .provide x_flc
         lbyts,3   xb,a_psa,x0,xp_rac     .create a_rac
         cpyaa     a_rac,a_nos
         shfx      xb,xb,x0,3
         addax     a_rac,xb
.
         lbyts,2   x1,a2,x0,xp_ucr
         shfc      x2,x1,x0,48         .UCR bit 48
         brxgt     x0,x2,pif           .If privilaged instruction fault
         shfc      x2,x1,x0,49         .UCR bit 49
         brxgt     x0,x2,cis           .If unimplemented instruction
         shfc      x2,x1,x0,51         .UCR bit 51
         brxgt     x0,x2,trap5         .IF process interval timer
.
.        Illegal TRAP CONDITION, EI MTR WILL PROCESS IT.
.
         EIMTRCAL  EIRQC,GENCODE       .CALL EI MTR TO PROCESS ERROR
.
.        trap exit entrys.
.
trap2    lx        x1,a_static,ve_down    .bit 2**30 set if ve down
         iorx      x0,x1
trap3    SX        X0,a_psa,xp_cx0        .STORE USER XO REGISTER
trap4    LA        a8,a_psa,xp_p
         ADDAQ     a8,a8,8             .INCREMENT P REGISTER
         SA        a8,a_psa,xp_p
trap5    BSS       0                   .RETURN TO C170 STATE
.
.        EXIT POINT FOR C170 CPUMTR T017 REQUESTS(E.G. PURGE BUFFER),
.        SINCE RETURN IS ALWAYS TO THE C170 ENVIRONMENT.
.
         ENTL      X0,0c3(16)
         CPYXS     X0,X0               .SET TEF AND TED
         RETURN
*copy OSI$C170_CMU_EMULATION
*copy OSI$PRIVILAGED_170_INSTRUCTIONS
.
.        request table.
.
         fn017     rspt,read_set_pit   .read and set pit
         fn017     mliu,mlirqup        .unpriv memory link
         fn017     cpcm,minilink       .mini-link request
         fn017     cinv,bmi            .cache invalidate
         fn017     rpva,fetch_pva      .return pva value
         fn017     3,downc180          .return to stand-alone
         fn017     2002(8),status_ve   .get the ve status
         fn017     end
.
         brreq     x0,x0,pif4          .illegal function
.
.
         ALIGN     0,2
CONSOLE  BSS       0
         entp      x0,0
         sxi       x0,a_psa,x_reg2,xp_cx0 .set terminator found in return param
         entp      x0,0
         BRREQ     X0,X0,trap2
         PAGE
.        DOWNC180   - TERMINATE NOSVE ENVIRONMENT.
.
DOWNC180 BSS       0
         lbyts,4   x1,a_dscb,x0,ds_flag  .check if VE going down
         brxne     x1,x0,down0         .ve already going down
         entp      x1,1                .Set VE down flag, this informs SCI to
                                       . start VE termination.
         sbyts,4   x1,a_dscb,x0,ds_flag
         eimtrcal  mtrr#std,0,nohlt
DOWN0    BSS       0
         entp      x0,0
         brreq     x0,x0,trap3         .exit with ve up status
         space      4
.        status_ve - get the current running status of ve.
.
status_ve bss      0
         lx        x2,a_static,ve_down  .fetch the ve down flag
         sxi       x2,a_psa,x_reg1,xp_cx0
         entp      x0                  .return ve up in x0
         brreq     x0,x0,trap3         .store x0 and return
         PAGE
.        MLIRQST - PROCESS A NOS/VE MLI REQUEST FROM A C170 JOB.
.
.        THIS ROUTINE WILL ATTEMPT TO ADD THE MEMORY LINK REQUEST FROM THE C170
.        JOB TO A QUEUE OF REQUESTS THAT ARE PROCESSED BY THE NOS/VE
.        MLI HELPER TASK.  IF THE QUEUE IS FULL, THE REQUEST IS REJECTED.  IF
.        THE QUEUE IS NOT FULL THEN THE REQUEST IS ADDED TO THE QUEUE.
.
.        ENTRY:
.        x_reg1    pointer to the mli parameter block.
.        x_reg2    if 0, then this is an initial request.
.                  else it is the request queue index of the polling request.
.
.        EXIT:
.        C170-X0    0 IF REQUEST WAS ACCEPTED
.                  1 IF REQUEST REJECTED BECAUSE QUEUE FULL
.                  2 IF REQUEST REJECTED BECAUSE REQUEST NOT COMPLETE
.        x_reg2    request queue index if initial request.
.
.        NOTE:
.        WARNING - THIS ROUTINE MAY BE INTERRUPTED BY A SIT, AND CONTROL
.                  MAY BE GIVEN TO ANOTHER 180 TASK.
.
MLIMI    EQU       10                  . NUMBER OF ENTRIES IN THE REQUEST TABLE
MLIEL    EQU       160                 . LENGTH OF SINGLE QUEUE ENTRY
IDLE     EQU       0                   . IDLE OPSTATUS
WAIT180  EQU       1                   . WAIT FOR 180 OPSTATUS
WAIT170  EQU       2                   . WAIT FOR 170 OPSTATUS
SMIP     EQU       3                   . SEND MOVE IN PROGRESS
RMIP     EQU       4                   . RECEIVE MOVE IN PROGRESS
.
.        OFFSETS INTO A GIVEN QUEUE ENTRY
.
OPSTATUS EQU       0
COPYLENG EQU       OPSTATUS+8
TIME     EQU       COPYLENG+8
JSN      EQU       TIME+8
INTRPT   EQU       JSN+8
USED     EQU       INTRPT+8
MLIPKT   EQU       USED+8
RTPTR    EQU       MLIMI*MLIEL
BFPTR    EQU       RTPTR+6
MXSIZE   EQU       BFPTR+6
REJECT   EQU       MXSIZE+8
.
PKTLEN   EQU       14*8
MLPFA    EQU       5                   . WORD OFFSET OF BUFFER
MLPBL    EQU       6                   . WORD OFFSET OF BUFFER LEN
MLPFN    EQU       3                   . WORD OFFSET OF FUNCTION
MLFSE    EQU       4                   . SEND FUNCTION
.
ACCPTALL EQU       2
RJCTALL  EQU       0
ACCPTDSC EQU       1
.
.        A-register usage within the memory link.
a_npkt   areg      4                   .pointer to nos packet address
a_vpkt   areg      5                   .pointer to nos/ve packet address.
a_vbuf   areg      6                   .pointer to nos/ve data buffer.
a_mli    areg      7                   .pointer to mli area.
.
.
mlirqup  bss       0                   .unprivilaged memory link
         LA        a_mli,a_wrk,mliptr
         LBYTS,8   X2,a_mli,X0,REJECT  . GET DEADSTART STATUS
         ENTP      X3,ACCPTALL
         entl      x0,1                .pretend request queue full
         brrne     x2,x3,trap2         .return and store x0
.
.        CHECK FOR TYPE OF REQUEST (SUB-FUNCTION)
.
         lxi       x_reg1,a_psa,x_reg1,xp_cx0
         isob      x_reg1,x_reg1,x0,0473(8)  .strip off upper 4 bits
.
.        validate the c170 packet and form pva.
.
         addxq     x8,x_reg1,pktlen/8  .compute lwa for packet
         brrge     x8,x_flc,mliabort   .if address error
         brrgt     x0,x_reg1,mliabort  .if negative
         shfx      x1,x_reg1,x0,3
         cpyaa     a_npkt,a_rac
         addax     a_npkt,x1
.
         lxi       x4,a_psa,x_reg2,xp_cx0 .fetch request index
         isob      x4,x4,x0,0473(8)    .strip off upper 4 bits
         BRXNE     x4,X0,MLIPOLL       . IF POLLING REQUEST
.
.        FIND FREE ENTRY
.
         entp      X2,0
         entp      X4,MLIMI
         entp      X5,IDLE
         cpyaa     a_vpkt,a_mli
.
MLI1     BSS       0
         BRXGE     X2,X4,MLIFULL       . IF FULL
         ENTP      X0,SMIP
         ENTP      XA,IDLE
         ADDAQ     A9,a_vpkt,OPSTATUS
CS2      CMPXA     XA,A9,X0,CS2
         BRREQ     X1,X0,MLI2          . IF AVAILABLE
         INCX      X2,1
         ADDAQ     a_vpkt,a_vpkt,MLIEL
         BRXEQ     X0,X0,MLI1
.
.        FOUND FREE ENTRY AT a_vpkt/X2.
.
MLI2     BSS       0
         SBYTS,1   X2,a_static,X0,ENTRY   . SAVE ENTRY INDEX
         lbyts,8   x8,a_mli,x0,mxsize
         mulx      x8,x2
         la        a_vbuf,a_mli,bfptr
         addax     a_vbuf,x8           .a_vbuf = ^mli data buffer
         incx      x2,1
         sxi       x2,a_psa,x_reg2,xp_cx0 .save buffer index
.
         ENTP      XA,0
         CPYTX     XB,XA
         SBYTS,8   XB,a_vpkt,X0,TIME   . SET REQ START TIME
         LBYTS,8   XA,a_vpkt,X0,USED
         INCX      XA,1
         SBYTS,8   XA,a_vpkt,X0,USED
         ENTP      XA,0                . CLEAR INTRPT WORD
         SBYTS,8   XA,a_vpkt,X0,INTRPT
.
.        move parameter list from 170 to 180.
.
         entp      x5,13               .stop
         entp      x6,0                .index
movepl   bss       0
         lxi       x7,a_npkt,x6,0
         isob      x7,x7,x0,0473(8)    .strip off upper 4 bits
         sxi       x7,a_vpkt,x6,mlipkt
         brinc     x5,x6,movepl        .branch if more to move
.
.        IF SEND THEN VERIFY PARAMS AND MOVE DATA
.
         LBYTS,8   X5,a_vpkt,X0,(MLPFN*8)+MLIPKT
         entp      X6,MLFSE
         BRXNE     X5,X6,INITDONE      . IF NOT SEND
.
CSM      BSS       0
         LBYTS,8   X5,a_vpkt,X0,(MLPFA*8)+MLIPKT . GET BUFFER ADDRESS
         LBYTS,8   X6,a_vpkt,X0,(MLPBL*8)+MLIPKT . GET BUFFER LENGTH
         CPYXX     X7,X6
         SHFX      X6,X6,X0,3
         LBYTS,8   X8,a_mli,X0,MXSIZE
         BRXGT     X6,X8,MLIABORT      . IF TOO BIG
         ADDX      X7,X5
         BRXGE     X7,x_flc,MLIABORT   . IF BUFFER>FL
         BRXGT     X0,X5,MLIABORT      . IF BUFFER<0
         lbyts,4   xa,a_vpkt,x0,intrpt+4 . get intrpt offset
         subx      x6,xa
.
.        MOVE X6 BYTES FROM RAC+X5 TO C180 BUFFER
.
         cpyaa     a8,a_rac
         SHFX      X5,X5,X0,3          . TO BYTES
         ADDAX     a8,X5               . a8=^ C170 BUFFER
         cpyax     xf,a8               . save buffer address
.
         ENTE      X9,256
         CPYXX     X0,X9
         CPYXX     X1,X9
         cpyaa     ab,a_vbuf
.
. add intrpt restart address
.
         addax     a8,xa
         addax     ab,xa
.
SMVE1    BSS       0
         BRXEQ     X6,X0,INITDONE      . IF MOVE COMPLETE
         BRXGT     X6,X9,SMVE2         . IF > 256 BYTES TO MOVE
         CPYXX     X9,X6
         CPYXX     X0,X9
         CPYXX     X1,X9
.
SMVE2    BSS       0
         SUBX      X6,X9
         MOVB,a8,X0  ab,X1  1,9,0,0  1,9,0,0
         ADDAX     a8,X9
         ADDAX     ab,X9
         brcr      5,3,smve1           . if no xr
         brxeq     x6,x0,initdone      . if move complete
.
         cpyax     xa,a8
         subr      xa,xf         . curpos - buffer start
         sbyts,4   xa,a_vpkt,x0,intrpt+4 . save intrpt offset
         entp      x0,smip                 .set entry for restart
         entp      xa,smip
         addaq     a9,a_vpkt,OPSTATUS
cs4      cmpxa     xa,a9,x0,cs4
         brrne     x1,x0,cs4
         lbyts,8   xa,a_dscb,x0,d7jp
         isob      xa,xa,x0,0453(8)
         sx        xa,a_vpkt,jsn
         brxeq     x0,x0,trap5
.
.        MOVE COMPLETE - STORE JSN, OPSTATUS
.
INITDONE BSS       0
         lbyts,8   xa,a_dscb,x0,d7jp
         isob      xa,xa,x0,0453(8)
         SX        XA,a_vpkt,JSN
.
         entp      x0,wait180
         entp      xa,smip
         addaq     a9,a_vpkt,OPSTATUS
cs6      cmpxa     xa,a9,x0,cs6
         brrne     x1,x0,cs6
.
.        HAVE NOSVE MONITOR READY THE HELPER TASK
.
         LBYTS,6   XB,a_mli,X0,RTPTR
         LBYTP,6   XC,NIL
         BRXEQ     XB,XC,MLT23         . IF HELPER NOT READY
         LA        AA,a_wrk,mlistat
         entp      X1,1
         SBYTS,1   X1,AA,X0,MLIWT      .INHIBIT WAIT FOR HELPER.
         la        aa,a_wrk,hotkey
         lbyts,1   x1,aa,x0,0
         brxeq     x1,x0,mlt23         . If memory link hot key not enabled
.
.        Force the dispatcher to run immediately
.
         eimtrcal  donthing,0,nohlt    .Do nothing (but check dispatcher)
.
MLT23    BSS       0
.
.        RETURN - SET C170 X0 TO 2
.
         entp      x0,2
         brreq     x0,x0,trap2         .exit
.
.        RETURN - SET C170 X0 TO 1 FOR REQUEST REJECTED
.
mlifull  entp      x0,1
         brreq     x0,x0,trap2         .exit
.
.        PROCESS MLI POLLING REQUEST-
.        VERIFY THAT X4 IS VALID
.
         ALIGN     0,8
MLIPOLL  BSS       0
         LBYTS,8   XA,a_static,X0,PC
         INCX      XA,1
         SBYTS,8   XA,a_static,X0,PC
         BRXGE     X0,X4,MLIABORT      . IF < 0
         entp      X3,MLIMI
         BRXGT     X4,X3,MLIABORT      . IF > MLIMI-1
         decx      x4,1
         CPYXX     XA,XA               . *** HDW BUG ***
         MULXQ     XA,X4,MLIEL
         cpyaa     a_vpkt,a_mli
         ADDAX     a_vpkt,XA
         la        a_vbuf,a_mli,BFPTR
         lbyts,8   x8,a_mli,x0,mxsize
         mulx      x8,x4
         addax     a_vbuf,x8
.
.        IF STATUS IS WAIT180 THEN RETURN TO 170
.
         entp      x0,0
         entp      xa,0
         entp      xb,wait180
         addaq     a9,a_vpkt,OPSTATUS
cs8      cmpxa     xa,a9,x0,cs8
         BRXNE     XA,XB,MPOLL1        . IF NOT WAIT180
         entp      x0,2
         brreq     x0,x0,trap2         .return c170_x0 = 2
.
.        VERIFY ENTRY IS NOT IDLE/JSN
.
MPOLL1   BSS       0
. WARNING --- The following code depends on XA remaining set from cs8 above.
         entp      XB,IDLE
         BRXEQ     XA,XB,MLIABORT      . IF IDLE
         lbyts,8   xc,a_dscb,x0,d7jp
         LX        XB,a_vpkt,JSN
         isob      xc,xc,x0,0453(8)
         BRXNE     XC,XB,MLIABORT      . IF JSNS <>
         entp      xb,smip
         brxeq     xa,xb,csm           . continue send move
         entp      xb,rmip
         brxeq     xa,xb,crm           . continue receive move
.
.        REQUEST IS COMPLETE.  MOVE LAST 4 WORDS OF PARAM BLOCK BACK TO C170.
.
MPOLL2   BSS       0
         MOVB,a_vpkt,X0 a_npkt,X1 0,9,4*8,MLIPKT+80  0,9,4*8,80
         entp      xb,0
         sbyts,8   xb,a_vpkt,x0,intrpt . initialize intrpt
.
.        CHECK IF COPYLENG <> 0 THEN MOVE DATA TO 170
.
crm      bss       0
         LBYTS,8   X6,a_vpkt,X0,COPYLENG
         BRXEQ     X6,X0,POLLDONE      . IF NO DATA TO MOVE
         LBYTS,8   X5,a_vpkt,X0,(MLPFA*8)+MLIPKT . GET BUFFER ADDRESS
         cpyxx     x7,x6
         shfx      x6,x6,x0,3          .to bytes
         addx      x7,x5
         brxge     x7,x_flc,mliabort   .if buffer > FL
         brxgt     x0,x5,mliabort      .if buffer < 0
         lbyts,4    xa,a_vpkt,x0,intrpt+4 . get intrpt offset
         subx      x6,xa
.
.        MOVE X6 BYTES FROM C180 BUFFER TO RAC+X5
.
         CPYAA     a8,a_rac
         SHFX      X5,X5,X0,3          . TO BYTES
         ADDAX     a8,X5               . a8=^ TO C170 BUFFER
         cpyax     xf,a8               . save buffer start
         addax     a8,xa     . add intrpt offset
         addax     a_vbuf,xa
.
         ENTE      X9,256
         CPYXX     X0,X9
         CPYXX     X1,X9
.
RMVE1    BSS       0
         BRXEQ     X6,X0,POLLDONE      . IF MOVE COMPLETE
         BRXGT     X6,X9,RMVE2         . IF > 256 BYTES TO MOVE
         CPYXX     X9,X6
         CPYXX     X0,X9
         CPYXX     X1,X9
.
RMVE2    BSS       0
         SUBX      X6,X9
         MOVB,a_vbuf,X0   a8,X1 1,9,0,0  1,9,0,0
         ADDAX     a8,X9
         ADDAX     a_vbuf,X9
         brcr      5,3,rmve1           . if no xr
         brxeq     x6,x0,polldone      . if complete
.
         cpyax     xa,a8
         subr      xa,xf             . curpos - buffer start
         sbyts,4   xa,a_vpkt,x0,intrpt+4 . save intrpt offset
         lbyts,8   xa,a_static,x0,xrc
         incx      xa,1
         sbyts,8   xa,a_static,x0,xrc
         entp      x0,rmip             . set receive restart
         entp      xa,smip
         addaq     a9,a_vpkt,OPSTATUS
cs12     cmpxa     xa,a9,x0,cs12
         brrne     x1,x0,cs12
         brxeq     x0,x0,trap5
.
.        POLLING REQUEST DONE - RESET QUEUE ENTRY
.
POLLDONE BSS       0
         entp      x0,0
         SX        x0,a_vpkt,JSN
         entp      x0,idle
         entp      xa,rmip
         addaq     a9,a_vpkt,OPSTATUS
cs14     cmpxa     xa,a9,x0,cs14
         brrne     x1,x0,cs14
         entp      x0,0
         brreq     x0,x0,trap2         .return c170_x0 = 0
.
.        SOME SORT OF 170 ADDRESS ERROR HAS OCCURRED
.
MLIABORT BSS       0
         LBYTS,8   XA,a_static,X0,ERC
         INCX      XA,1
         SBYTS,8   XA,a_static,X0,ERC
         brreq     x0,x0,aor1          .abort c170 job
NIL      VFD,48    0FFFF80000000(16)   . NIL PVA
.
.
.
ENDTH017 EQU       $
.
         END
*DECK DECK=MTM$MONITOR_INTERRUPT_HANDLER EXPAND=TRUE
mtm$monitor_interrupt_handler IDENT

..............................................................................
.                  MONITOR INTERRUPT HANDLER
.  This module is the top-level control module in NOSVE monitor. It contains
.  the procedures that do the following:
.      - EXCHANGE to job mode
.      - decode the job mode MCR when it exchanges back to monitor and
.        call the CYBIL procedures to process the request or condition.
.      - Process EXCHANGE (170 PP) requests by giving control to the 170
.        partner
.      - Process TRAPS that occur in monitor mode.
.      - Call the CPU dispatcher to change the current task
.      - Handle (most) dual CPU interlocking.
.      - This module is the first OS module to begin executing at deadstart. It
.        performs some basic system initialization functions before exchanging
.        to job mode to continue deadstart.
.      - The monitor stack and exchange packages are defined in this module.
.      - The monitor request table is defined in this module.
.
.
.  NOTE: This module must be the first module on the OSF$MONITOR library and
.        must be the first module loaded into the monitor address space.
..............................................................................
.
.
         page
.
*COPY     SYA$CONSTANTS
.
.  Deck SYA$CYBIL_INTERFACE_PROCEDURES follows but is not listed.
         list,1  0,0,0
*COPY   SYA$CYBIL_INTERFACE_PROCEDURES
         list,1  1,2,0
         page
*COPY   MTA$CPU_STATE_TABLE
*COPY   MTA$SMU_COMMUNICATION_BLOCK
*COPY   OSA$DUAL_STATE_CONTROL_BLOCK
*COPY   OSA$BASIC_REGISTER_EQUATES
*copyc  mta$dft_block
*COPY OSA$KEYPOINT_CLASSES
*copyc sya$xp_and_sf_constants
.
donthing equ     3      .Define symbol from osa$ei_constant_definitions
issuekpt equ     8      .Debug issue keypoint request for 170 trap handler
osktrap  equ  4005      .Trap handler keypoint request
dscb_tef equ  d8st      .Offset into Dual State Control Block to tell DFT
                        .  that this is a THETA with special trap code.
         page
...............................................................................
. XTRACE - This macro is used to keep trace information about what happens.
.    The TRACE buffer is a circular buffer containing a list of the last
.    256 items of interest. Items currently maintained are:
.       0. exchange to job mode. (timestamp)
.       1. exchange from job mode. (timestamp, MCR)
.       2. trap in monitor mode. (timestamp, MCR)
.       3. EXCHANGE to NOS for EXCHREQ trap. (timestamp)
.       4. EXCHANGE back from NOS for EXCHREQ trap. (timestamp, MCR)
.       5. Taskswitch. (timestamp, new task XP RMA)
.    An entry in the trace buffer is 1 word long and contains:
.       bit 0 - 3,  trace id. Same as item number in above list
.       bit 4-31, data dependant on id. Usually MCR or XP RMA.
.       bit 32-63, lower 32 bits of FREE RUNNING CLOCK.
.
.    calling sequence to macro....
.        xtrace  p0,p1,p2,p3
.           p0 - contains trace id (0 .. 5)
.           p1 - contains data to be saved
.           p2, p3 - 2 X-registers that can be used for scratch
.              WARNING - X0 cannot be used for p2.
.           p4 - scratch A register
.
.    NOTE: While system is stepped, it uses a different trace buffer to prevent
.          destroying the primary buffer that may contain useful info.
..............................................................................
.
         PROC
xtrace   pname
f:(0)    bss     0
         local   t1,t2
         la      f:(2,4),a_cst,tracectl+2
         entp    f:(2,3),0
         cpytx   f:(2,3),f:(2,3)
         sx      f:(2,3),f:(2,4),0
         entz    f:(2,3)
         entp    f:(2,2),f:(2,0)
         do      sn:(f:(2,1))=sn:(0)
           shfx  f:(2,2),f:(2,2),x0,60
           iorx  f:(2,3),f:(2,2)
         dend
         do      sn:(f:(2,1))/=sn:(0)
           shfx  f:(2,2),f:(2,2),x0,28
           iorx  f:(2,2),f:(2,1)
           shfx  f:(2,2),f:(2,2),x0,32
           iorx  f:(2,3),f:(2,2)
         dend
         lx      f:(2,2),f:(2,4),8
         isob    f:(2,2),f:(2,2),x0,7007(8)   .WARNING - <tracesiz> dependent.
         incx    f:(2,2),1
         sx      f:(2,2),f:(2,4),8
         sxi     f:(2,3),f:(2,4),f:(2,2),8
t2       bss    0
         pend
         page
..............................................................................
. ERRSTOP - This macro generates a call to the error stop routine to
.           terminate 180 operation after an unrecoverable error has
.           occurred.
.
.         errstop p1
.              where p1 = label on a string that defines the error halt message
..............................................................................
.
         PROC
errstop  pname
f:(0)    addaq   a0,a0,16
         sa      af,a0,-16
         addaq   af,a_root,f:(2,0)
         cpyax   x0,af
         shfx    x0,x0,x0,16
         addxq   x0,x0,31
         sx      x0,a0,-8
         ente    x0,00ff(16)
         addaq   af,a0,-8
         callseg bs_errst,a_bindin,af
         la      af,a0,-16
         addaq   a0,a0,-16
         PEND
         page
..............................................................................
.  Define A and X register usage
.   Note...
.        1. X0, X1, X2, XD, XE and XF are scratch registers
.        2. AE and AF are scratch registers
.        3. AF contains a pointer to 'xpinitv' at deadstart time. It's
.           used only for system initialization
..............................................................................
.
a_root   areg    4                     .Pointer to beginning of mainframe wired.
.                                          (If not A4, MXP must be changed.)
a_cst    areg    5                     .Pointer to CST.
a_xcb    areg    6                     .Pointer to XCB of current task. NIL if idle.
a_dscb   areg    7                     .NOS170 DSCB.
.
x_mcr    xreg    3                     .Scratch reg for MCR
x_clock  xreg    4                     .Contains PIT/FRC values.
x_kef    xreg    5                     .Contains KEF while processing traps and RUNNOS.
x_resume xreg    8                     .Contains RESUME flag while in IDLE 180.
.
.
.  Equates for RUNNOS routine.
.
a_innosx areg    8                     .Pointer to NOS XCB.
a_inret  areg    9                     .Return address.
.
x_inmcr  xreg    6                     .NOS170 MCR.
x_infrc  xreg    7                     .Save for free running clock.
.
.
.  Equates for RQPROC routine.
.
a_rqtbl  areg    10                    .Contains the pointer to REQTBL entry
.
a_rq_ret areg    11                    .Return from RQPROC routine.
a_extret areg    12                    .Return from EXTINT routine.
a_sitret areg    13                    .Return address for PRSIT routine.
.
..
.  Equates for REGISTER SAVE values (X0 for CALLSEG instructions)
.
x_envir1 equ     00c7(16)              .Environment for CALL.
         page
...............................................................................
.  DEFCST  - This PROC is used to define and initialize the CST.
.            (See deck that defines equates to see definition of fields).
...............................................................................
.
         PROC
defcst   pname
f:(0,0)  bss     0
lpidz    set     0
         while   lpidz<f:(2,0)
         local   cst1
cst1     bssz    cstsize

         org     cst1+memport               .Best guess for memory port mask.
         vfd,8   1**(lpidz*2)               .  (may be changed in BEGIN).
         org     cst1+lpid
         vfd,8   lpidz
         org     cst1+lpid8
         vfd,8   lpidz*8
         org     cst1+cpu_stat
         vfd,8   2
         org     cst1+tracectl
         vfd,16  0
         address r,trace+lpidz*(tracesiz+2)*8
         org     cst1+taskid
         vfd,16,8 1,1
         org     cst1+prior180       .Initial 180 priority and 170 equivalent).
         vfd,24  070308(16)
         org     cst1+jcbp
         vfd,4,12,32 1,mstlen,0
         org     cst1+cp_state+cp_curst
         vfd,8   running
         org     cst1+cp_state+cp_nxtst
         vfd,8   running
         org     cst1+xcbp
         vfd,48  0ffff80000000(16)
         org     cst1+cptime
         vfd,64  0ffffffffffff(16)
         org     cst1+jtime
         vfd,64  07fffffff(16)
         org     cst1+cachtim
         vfd,64  07fffffffffffffff(16)
         org     cst1+maptim
         vfd,64  07fffffffffffffff(16)
         org     cst1+ijlep
         vfd,48  0ffff80000000(16)
         org     cst1+dpint
         vfd,64  07fffffffffffffff(16)
         org     cst1+idlstats+idle_cnt
         vfd,56  1                       . initialize the cpu idle count
         org     cst1+cstsize
lpidz    set     lpidz+1
         dend
         pend
         page
..............................................................................
.               MAINFRAME WIRED
.   Define oss$mainframe_wired data.
.   This data must be at the beginning of the Mainframe-wired segment.
.       !!!! THIS DATA MUST START AT BYTE 0 OF SEGMENT 1 !!!!
.
..............................................................................
oss$mainframe_wired   SECTION working,read+write
         USE     oss$mainframe_wired
         def     root
root     vfd,64  0
         vfd,64  0
.
...................................................................
.
.        NOS/VE memory limits.  Defines the upper and lower bounds of NOS/VE
.        memory, the bounds are RMAs.  During deadstart the memory upper bound
.        is determined by the size of the memory image.
.
.        NOTE:  The memlimit variable is referenced from Cybil, definition is
.        defined by the variable 'osv$180_memory_limits'.
.
...................................................................
memlimit vfd,32  0                     .Lower bound.
         vfd,32  0                     .Upper bound during deadstart.
         vfd,32  0                     .Upper bound after system initialized.
         vfd,32  0                     .?????
.
scb      bss     scbsize               .SCB communication area.
scbvec   equ     scb+scbvecsim         .Vector simulation option.
.
mtv$idle_message_line bss 0            .Message written to line 1 of console
         vfd,8,8 0,1                   .  y position on console
         vfd,8,8 0,0                   .  length
         vfd,32  0                     .  rma field
         bss     80                    .  text of message
         bss     6                     .  space for pointer
.
         align   0,32
cst0     defcst  maxcst                .Define CPU STATE TABLE (CST).
.
os_type  vfd,8   0                     .Operating mode (standalone, NOS, or NOSBE)
os_terms vfd,8   0                     .170 termination status (0=running,
         vfd,48  0                     .  1=mode error, 2=fatal due)
kcb_rma  vfd,64  0                     .RMA pointer to keypoint buffer
manddlst vfd,8   1                     .TRUE if dualstate is mandatory at this site.
         align   0,8
multpro  vfd,64  0                     .Non-zero if more than one cpu is running.
nosjps   vfd,64  0                     .JPS of NOS170 if Dual State active.
nosexit  vfd,64  0                     .Time of last exit from NOS170.
bct_pva  vfd,48  01003000001a8(16)     .PVA of the Boot Control Table.
nostab   vfd,48  0100300000000(16)     .If dual state, contains PVA of
.                                        NOS table containing priorities, etc.
eicbadr  vfd,64  71(8)                 .Pointer to EI control block
eicb     vfd,48  01003000001c8(16)     .PVA of EICB pointer word
nosxp    address r,a170_xp             .If dual state, contains PVA of NOS XP
nossegt  address r,a170_st             .Pointer to NOS segment table ..
         vfd,32,32,32  a170_stl*8,0,8  .  ... rest of adaptable pointer to seg table.
.
frc_p    address p,xfrc_p              .Pointer to free running clock time for
.                                       dispatcher to run.
.                                         180 idle routine too early)
mlist    vfd,16  00100(16)             .Memory_link_status.
         align   0,8
ve_vrsn  vfd,32,14,6,6,6  ost$psr,0,ost$nve,if_versn,if_level  .PSR lvl, OS type,
                                       .   i/f version and level. This field is set
                                       .  by LINOS but may be changed by the CHAOSV
                                       .  command.
eiflag   vfd,64  0fffffffffffff(16)    .EXTERNAL INTERRUPT flag. Contains FRC value
                                       .  of when to poll for next IO completion.
                                       .  If a IOU sends an external interrupt, the
                                       .  value of this word is set to one.
eiinc    vfd,64  1000000               .Rate to poll for lost external interrupts.
                                       .  Polling is immediate if EXT INT received
                                       .  and EIFLAG <> 0.
                                       .  NOTE: because of the algorithm used,
                                       .  asyninc must not be larger than this number.
asyntime vfd,64  0                     .FRC time to next check async activities.
asyninc  vfd,64  200000                .Rate at which asyn activities are checked.
sitvalue vfd,64  50000                 .Default SIT value.
mstacklx vfd,64  mstackl               .Length of monitor stack.
num_cst  vfd,64  maxcst                .Number of cst tables.
lockwait vfd,64,64 0,0                 .Total time/count waiting for dual CPU
                                       .  interlock.
cmax     vfd,64  2147483000            .Maximum number of requests before
                                       .statistic counts must be reset.
         align  0,64
p_mode   vfd,64,64 0,0                 .Processor mode - current processor mode,
.                                       either 0 (system) or an ajl ordinal (job)
cpu1nos  vfd,8     0                   .CPU 1 is dedicated to NOS
sprior   vfd,8,8,8 7,3,8               .Special dedicated priority values.
         align  0,64
xajl     vfd,64,64 0,0                 .Used during recovery, a copy of p_mode.
retsave  vfd,64    0                   .SIT interrupt return address save

sjmtrxcb vfd,4,12,32 1,mstlen,jrootsiz .Pointer to system job monitor execution
.                                         control block.

.        Define interrupt ports for IOU external interrupts.  This is a mask with bit
.        7 being port 0, bit 6 being port 1, bit 5 being port 2, etc.  Currently all
.        non S0 machines interrupt on port 1 (value of 1) and the S0 interrupts on
.        port 2 (value of 4).  The value of this variable is set early in
.        initialization, it is set to the same value as memport.

intport  vfd,8   1                     .Interrupt port mask for IOU external
                                       . interrupts.
num_proc vfd,8   0                     .Number of processors physically configured.
mtrprior vfd,16  708(16)               .Priority of 180 if control is
                                       . given to 170 via trap in 180 monitor.
cpus_on  vfd,8   0                     .Number of cpus logically on.
         align   0,8
osv_bl   bssz    32                    .osv$build_level
nostime  vfd,64,64 0,0                 .Total time spent in NOS(total, ve_idle).
qstime   vfd,64  0ffffffffffff(16)     .FRC time to make quick sweep call.
mmtime   vfd,64  0ffffffffffff(16)     .FRC time to next call Memory Manager.
swaptime vfd,64  0ffffffffffff(16)     .FRC time to next call job swapper.
scbtime  vfd,64  0                     .FRC time to next check SCB status.
alltime  vfd,64  0ffffffffffff(16)     .FRC time of max async lock wait.
stampt   vfd,64  0                     .Hourly time stamp for trace base.
haltring vfd,8   0                     .Halt CP on MCR fault <= this number.
systemhr vfd,8   0                     .Same as above but for system job only.
asylock  vfd,8   0                     .Asynchronous interrupt lock.
asylocki vfd,8   0                     .Asynchronous interrupt lock for idle loop.
heap_tr  vfd,8   0                     .Enable_heap_trace system attribute.
heap_ver vfd,8   0                     .Verify_heap_linkage system attribute.
fltinj   vfd,8   0                     .Enable fault injection utility.
ve_int   vfd,8   0                     .NOSVE_INTERNAL_OPERATIONS system attribute.
mtvdftb  vfd,48  0ffff80000000(16)     .Pointer to DFT block control word
nossegp  vfd,4,12,32 1,snnosmtr,0      .Pointer to NOS segment
mtrstp   address r,mst                 .Pointer to MTR SEG TABLE
mtrxpp   address r,mxp                 .pointer to mtr xp
mtrstk_p address r,mtrstak             .Pointer to first CPU MTR Stack
dpv$scd_block_p address r,asciiblk
pextiou  address r,extiou
pdpv$scd_time address r,dpv$scd_time
hnsk_p   address p,xhsk_p
endtbls  vfd,16,32    0ffff(16),080000000(16)   .Pointer to mainframe wired heap.
         align   0,8
debug0   bssz    16*8                  .Array of debug values.
.
.
.         The following is a cybil record.  Immediately after deadstart
.         the NOS system time and date and the free running clock value
.         are saved in this record.  During deadstart initialization these
.         values are converted to NOS/VE base system time.
.
         align   0,8
nos_tod  vfd,64  55333357333357333357(8) .NOS time of day (60 bits of display code)
nos_date vfd,64  55433450334350343657(8) .NOS date (60 bits of display code)
cor_frc  vfd,48  0                     .Free running clock corresponding to 'nos_tod'
nosve_bt vfd,8,8,8,8,8,16,48 0,0,0,0,0,0,0    .NOS/VE base time (sec,min,hr,d,m,y,FRC)
.
.         Define symbols to reference NOS date and time in NOS's field length.
.
nostod   equ     3421(8)               .NOS time of day address mask
nosdate  equ     1221(8)               .NOS date address mask
.
.        End of base system time record.
*IF $variable(mtv$test_due_pnd declared) <> 'UNKNOWN'
.
         align   0,8
fk_due   vfd,48  0                     .Time of last "fake" DUE
         def           fk_due
*ELSE
.
. ---------- Declaration code was omitted at compilation time ----------
*IFEND
.
.  Standalone deadstart data
.
nossf    vfd,4,12,32   1,snsfmtr,0     .PVA of nos stack frame in mtr mode
         defg          osv$boot_sdte
         defg          dsv$ssr_sdte
         defg          osv$boot
         defg          osv$boot_is_executing
         align         7,8
osv$boot      vfd,8     0
osv$boot_sdte vfd,64    0
dsv$ssr_sdte  vfd,64    0
osv$boot_is_executing vfd,8 0
.
         align   0,8
tracesiz equ     256                   .Number of trace entries per processor
                                       . (must be power of 2.
                                       . WARNING - TRACE macro must be changed
                                       . if TRACESIZ is changed.
trace    bssz    8*maxcst*(2+tracesiz) .Array to keep trace information
                                       .  of what happens in monitor. See
                                       .  the XTRACE macro.
dtrace   bssz    8*(tracesiz+2)        .Array for recording trace info while system
                                       .  is stepped or idle.
xpinitv  bss     xpsize                .Initial value for all job mode
.                                         exchange packages.
initmxp  bss     xpsize                .initial value of mtr xp.
.
.
.   Error mesasages displayed on error stop.
.
csthalt   vfd,248   c'HALTED VIA CST REQUEST         '
stepmes   vfd,248   c'STEPPED VIA CST REQUEST        '
cpudown   vfd,248   c'CPU FAILED WITH INTERLOCK SET  '
thetadue  vfd,248   c'FATAL: MTR DUE & TRAPS DISABLED'
masksync  vfd,248   c'MTR MASK OUT OF SYNC WITH TRAPS'
          page
.............................................................................
.  MONREQ  -  This proc is used to call a monitor request processor.
.                   monreq   rc, ring, returnadr
.                        rc         - request code, either constant or x-register
.                        ring       - ring number for request validation. Zero implies
.                                       no checking. (rc must be constant if ring = 0)
.                        returnadr  - label to return to. If not supplied, returns
.                                      to next instruction.
.             A pointer to the beginning of the stack frame is passed as the parameter
.             list pointer. NOTE: most procedures called with this macro expect the
.             second parameter to be a pointer to the current CST.
.
..............................................................................
.
         PROC
monreq   pname
         local    ex
f:(0)    bss     0
         do      sn:(f:(2,2))=0
           addpxq  a_rq_ret,x0,ex
         dend
         do      sn:(f:(2,2))/=0
           addpxq  a_rq_ret,x0,f:(2,2)
         dend
         do      sn:(f:(2,1))=sn:(0)
           addaq   a_rqtbl,a_root,reqtbl+rqtbles*f:(2,0)
           addaq   ae,a_bindin,16*f:(2,0)
         dend
         do      sn:(f:(2,1))/=sn:(0)
           shfx    f:(2,0),f:(2,0),x0,4
           cpyaa   ae,a_bindin
           addax   ae,f:(2,0)
           addaq   a_rqtbl,a_root,reqtbl
           addax   a_rqtbl,f:(2,0)
           shfx    f:(2,0),f:(2,0),x0,-1
           addax   a_rqtbl,f:(2,0)
           lbyts,1 f:(2,0),a_rqtbl,x0,rn
           brxge   f:(2,0),f:(2,1),rqproc
           addaq   a_rqtbl,a_root,reqtbl
           addaq   ae,a_bindin,16*rqunim
         dend
         brxeq   x0,x0,rqproc
ex      bss     0
         pend
         page
. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
. TRAKTEF - This macro enables/disables the MCR mask bit 49
.           (normally unused) to indicate to THETA models 40 - 44
.           what the current state of the trap register is.  This
.           is used as a software workaround for 'stop on error'
.           hardware found only on the THETA processor models
.           listed above.  On other models this information is
.           not used, even though the flag is tracked.
. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
         proc
traktef  pname
f:(0)    bss     0
         local   tf1,tf2
         ente    x2,m_mcrtef
         entl    x0,r_mm               .Get live register for mtr mask
         cpysx   x1,x0
         do      f:(2,0)=1             .Enable or Disable?
         iorx    x1,x2                 .Set the Traps_Enabled bit in the live
         else                          .  mtr mask
         inhx    x1,x2                 .Clear the Traps_Enabled bit in the live
         dend                          .  mtr mask
         cpyxs   x1,x0
         bss     0
         pend
.............................................................................
.  RQTABLE -  This macro generates monitor request table entries,
.             and binding section pointers. it also increments *MTRQMAX*
.             to indicate the maximum number of requests.
.               (see next page for definition of fields in macro)
..............................................................................
.
.      Define offsets into a request table entry.
.
rqtbles  equ     3*8                   .Size of request table entry.
rn       equ     0                     .Highest RN for the request
il       equ     1                     .Interlock ordinal
rc       equ     2                     .Request code
totalt   equ     1*8                   .Total time for the request
rqcntmax equ     2*8                   .Word with both max and count.
.                                         (max time = left, count = right)
         proc
rqtable  pname
         org     reqtbl+rqtbles*f:(2,0)
         vfd,8   f:(2,1)         .Highest ring number for the call
         vfd,8   f:(2,2)         .Interlock ordinal
         vfd,8   f:(2,0)         .Request code
         vfd,40  0
         bssz    24
.
         do      f:(2,0)>mtrqmax
mtrqmax  set     f:(2,0)
         dend
         org     reqtbl+mtrqmax*rqtbles+rqtbles
         use     binding
         do      sc:(f:(2,3))/=7
         ref     f:(2,3)
         dend
         address ce,f:(2,3)
         use     #lastsec
         pend
.
.   Initialize maximum requests to 0.
.
mtrqmax  set     0
.
.   Define fwa of binding section and reqtable pointers.
.
         use     binding
         def     bindsec
bindsec  bss     0
bs_rqtbl bss     0
         use     #lastsec
.
         page
..............................................................................
.                  MONITOR REQUEST TABLE
.
.    Each monitor request requires an entry in the following table
.    Each entry is specified as follows:
.         RQTABLE    NUM, HIGHRING, INTERLOCK_ORD, PROC
.              NUM - Request code number
.              HIGHRING - Highest ring number that can issue the request.
.                      (0 = request restricted to monitor only).
.              INTERLOCK_ORD - Specifies which interlock to use to serialize
.                     monitor requests on a dual CPU machine.
.                       (0 = no interlock)
.              PROC - Name of procedure to call to process the request.
.
.    NOTE: When making an entry in this table, the following changes also
.       have to be made:
.           1) Define the request code in the deck SYC$MONITOR_REQUEST_CODES
.           2) Add the request name to the table in CLM$DISPLAY_SYSTEM_DATA.
.           3) If no interlock is required to serialize monitor requests and
.              the called procedure sets some other serialization lock (for
.              example, TMV$PTL_LOCK), that OTHER serialization lock MUST BE
.              CHECKED in the procedure MTP$CHECK_FOR_FATAL_ERRORS in the
.              module MTM$PROCESSOR_CONFIGURATION_MGR.
.
..............................................................................
         align   0,32
reqtbl   bssz    0
         rqtable 0,15,1,tmp$process_unknown_req_fault
         rqtable 1,13,0,tmp$cycle
         rqtable 2,13,0,tmp$delay
         rqtable 3,0,0,tmp$process_unknown_req_fault
         rqtable 4,1,1,iop$io_processor
         rqtable 5,13,1,mmp$advise_request_processor
         rqtable 6,13,1,mmp$advise_request_processor
         rqtable 7,13,1,mmp$advise_request_processor
         rqtable 8,2,1,tmp$create_task
         rqtable 9,0,1,pr_pf
         rqtable 10,2,1,tmp$create_job
         rqtable 11,2,1,tmp$exit_job
         rqtable 12,13,1,mmp$free_flush
         rqtable 13,13,1,mmp$free_flush
         rqtable 14,1,1,mmp$mtr_change_segment_table
         rqtable 15,0,0,iop$check_active_pps
         rqtable 16,0,0,tmp$process_unknown_req_fault  .FREE
         rqtable 17,0,0,tmp$process_unknown_req_fault  .FREE
         rqtable 18,3,1,jsp$mtr_job_swapping_requests
         rqtable 19,3,0,mtp$mtr_step_unstep_system
         rqtable 20,0,1,tmp$process_task_mcr_fault
         rqtable 21,15,1,tmp$mtr_process_system_error
         rqtable 22,3,0,tmp$fetch_task_statistics
         rqtable 23,0,0,tmp$process_unknown_req_fault  .FREE
         rqtable 24,0,0,tmp$process_unknown_req_fault  .FREE
         rqtable 25,13,0,tmp$mtr_ready_task
         rqtable 26,3,0,tmp$mtr_set_system_flag
         rqtable 27,15,1,tmp$mtr_wait
         rqtable 28,1,1,mmp$mtr_lock_ring_1_stack
         rqtable 29,3,1,tmp$mtr_send_signal
         rqtable 30,1,1,mmp$mtr_set_get_segment_length
         rqtable 31,6,1,mmp$mtr_read_write_io
         rqtable 32,3,1,tmp$job_recovery_requests
         rqtable 33,1,1,mmp$mtr_ring1_segment_request
         rqtable 34,2,1,tmp$task_exit
         rqtable 35,0,0,tmp$process_unknown_req_fault  .FREE
         rqtable 36,3,1,tmp$mtr_update_job_task_enviro
         rqtable 37,0,0,tmp$process_unknown_req_fault  .FREE
         rqtable 38,13,1,mmp$mtr_lock_unlock_pages
         rqtable 39,13,1,mmp$mtr_lock_unlock_pages
         rqtable 40,13,1,mmp$mtr_fetch_pva_unwritten_pgs
         rqtable 41,1,1,dmp$mtr_allocate_front_end
         rqtable 42,1,1,dmp$mtr_deallocate_front_end
         rqtable 43,1,1,dmp$apply_mat_changes
         rqtable 44,1,1,iop$tape_queue_request
         rqtable 45,1,1,iop$translate_byte_address
         rqtable 46,3,1,cmp$monitor_routines
         rqtable 47,3,1,tmp$mtr_ready_system_task
         rqtable 48,13,1,mmp$mtr_lock_unlock_segment
         rqtable 49,3,1,dsp$issue_dft_request
         rqtable 50,13,1,mmp$mtr_wait_io_completion
         rqtable 51,0,0,tmp$switch_task
         rqtable 52,0,0,mtp$process_short_warning
         rqtable 53,0,0,mtp$monitor_system_status
         rqtable 54,0,1,iop$process_io_completions
         rqtable 55,3,0,dpp$display_request
         rqtable 56,0,0,dpp$process_scd_block
         rqtable 57,3,1,osp$process_job_keypoint_req
         rqtable 58,0,1,mmp$periodic_call
         rqtable 59,0,0,mtp$process_due
         rqtable 60,0,0,tmp$process_unknown_req_fault  .FREE
         rqtable 61,0,1,jsp$swap_polling
         rqtable 62,0,0,mtp$process_170_mtr_requests
         rqtable 63,0,0,tmp$process_unknown_req_fault  .FREE
         rqtable 64,1,1,iop$request_processor
         rqtable 65,3,0,dsp$access_logging_data
         rqtable 66,0,0,dsp$process_dft_entry
         rqtable 67,3,1,jmp$mtr_job_scheduler_requests
         rqtable 68,1,1,mmp$mtr_fetch_offset_mod_pages
         rqtable 69,13,1,mmp$process_assign_pages_req
         rqtable 70,13,1,mmp$free_flush
         rqtable 71,1,1,rfp$queue_data_fragments
         rqtable 72,0,0,tmp$process_unknown_req_fault  .FREE
         rqtable 73,3,1,dfp$mtr_file_server_request
         rqtable 74,6,1,mmp$process_move_pages_request
         rqtable 75,3,1,mmp$process_assign_contig_mem
         rqtable 76,1,1,dmp$mtr_reallocate_front_end
         rqtable 77,1,1,mmp$mtr_r1_server_seg_request
         rqtable 78,1,1,mtp$process_cpu_state_change
         rqtable 79,3,1,sfp$mtr_stats_facility_requests
         rqtable 80,3,1,dsp$mtr_manage_system_ds_status
         rqtable 81,3,1,jmp$update_serv_class_stats_req
         rqtable 82,0,0,tmp$process_unknown_req_fault  .FREE
         rqtable 83,0,0,tmp$process_unknown_req_fault  .FREE
         rqtable 84,0,0,tmp$process_unknown_req_fault  .FREE
         rqtable 85,13,0,syp$mtr_inject_hardware_fault
         rqtable 86,1,1,mmp$quick_sweep
         page
..............................................................................
.  Define the interlock array.  Initially only one lock word
.  is used by the various request processors.
.      One word per entry, word 0 not used.
.            bit 0     0 = lock clear, 1 = lock set
.            bit 32 - 63 = CST offset of CPU that has lock set.
.
. NOTE: If this record changes, be sure to make corresponding changes to the
. CYBIL record declaration MTT$REQUEST_INTERLOCK_TABLE.
..............................................................................
.
.      Define offsets into interlock table.
.
maxilo   equ     6                     .Array size is 0..5
ilsize   equ     8                     .Size of interlock table entry.
ilflag   equ     0                     .Interlock flag
lockcp   equ     2                     .^CST of locking cpu
.
.
.
         align   0,8
il_tbl   bssz    maxilo*ilsize         .Interlock array.
         page
..............................................................................
.      Define  request codes for requests issued internally by monitor.
.          These request codes must match the values defined in
.          SYC$MONITOR_REQUEST_CODES.
.        NOTE: only requests actually used by monitor are defined here.
..............................................................................
.
rqunim   equ     0                     .Unimplemented request code
rqpf     equ     9                     .Code for PAGE FAULT.
check_pp equ     15                    .iop$check_active_pps
rqfault  equ     20                    .Code for MCR/UCR faults.
tsksw    equ     51                    .task switch
pswarn   equ     52                    .process short warning
mon_smu  equ     53                    .monitor_smu_status
proc_io  equ     54                    .process_io_completions
ascii_kb equ     56                    .process ascii keyboard
per_call equ     58                    .periodic_call
proc_due equ     59                    .process_due
swap_job equ     61                    .poll job swapping
mm_ei    equ     62                    .process_170_mtr_requests
proc_dft equ     66                    .process DFT block
proc_cpu equ     78                    .process_cpu_state_change
qs_call  equ     86                    .quick_sweep
         page
..............................................................................
. Define entry points into this module and the External names
. of the entry points
..............................................................................
         defg    haltring,systemhr
         defg    mmtime,nostime
         defg    qstime
         defg    alltime
         def     swaptime,scbtime
         defg    sitvalue,fltinj
         defg    dpv$scd_block_p
         def     mtv$idle_message_line
         def     dpv$scd_time
         defg    extiou
         def     mtrprior
         def     nosxp
         def     nosjps
         defg    nostab
         defg    bct_pva
         def     trace,dtrace
         def     nossegp
         defg    kcb_rma
         defg    nosve_bt,nos_tod,mlist
         defg    endtbls,memlimit,cst0
         defg    xpinitv,os_type,scb,scbvec
         def     os_terms
         defg    reqtbl
         def     il_tbl
         defg    multpro
         defg    manddlst
         def     eiflag
         defg    lockwait
         def     sjmtrxcb
         defg    debug0
         defg    intport
         def     asyntime,asyntime
         defg    num_proc
         defg    initmxp
         def     mtrstk_p
         defg    osv_bl
         def     idle,async,exchloop,rqproc,run_nos,extrq,traprtn
         def     int,nossegt
         defg    cpus_on
         defg    num_cst
         defg    mstacklx
         def     mtvdftb
         defg    heap_tr
         defg    heap_ver
         defg    ve_int
         defg    p_mode
         defg    nosve_bt
         defg    xajl
         defg    cpu1nos
heap_tr  ALIAS   syv$enable_heap_trace
heap_ver ALIAS   syv$verify_heap_linkage
ve_int   ALIAS   syv$nosve_internal_operations
p_mode   ALIAS   mtv$processor_mode
cpu1nos  ALIAS   MTV$CPU1_DEDICATED_TO_NOS
xajl     ALIAS   mtv$executing_ajl_at_failure
initmxp  ALIAS   OSV$INITIAL_MONITOR_XP
mtrstk_p ALIAS   mtv$first_cpu_monitor_stack_p
fltinj   ALIAS   syv$enable_fault_injection
mstacklx ALIAS   osv$monitor_stack_length
num_cst  ALIAS   osv$maximum_cst_tables
num_proc ALIAS   osv$cpus_physically_configured
cpus_on  ALIAS   osv$cpus_logically_on
lockwait ALIAS   osv$monitor_interlock_wait_time
sjmtrxcb ALIAS   mtv$system_job_monitor_xcb_p
eiflag   ALIAS   osv$external_interrupt_time
intport  ALIAS   osv$external_interrupt_selector
asyntime ALIAS   OSV$TIME_TO_CHECK_ASYN
asyninc  ALIAS   OSV$RATE_TO_CHECK_ASYN
manddlst ALIAS   syv$mandatory_dualstate
multpro  ALIAS   OSV$MULTIPROCESSOR_RUNNING
debug0   ALIAS   osv$debug
mtrprior ALIAS   OSV$MONITOR_PRIORITY
reqtbl   ALIAS   MTV$REQUEST_TABLE
il_tbl   ALIAS   mtv$request_interlock_table
xfrc_p   ALIAS   TMV$TIME_TO_CALL_DISPATCHER
         ref     xfrc_p
xhsk_p   ALIAS   DSV$CPU_PP_COMMUNICATION_BLOCK
         ref     xhsk_p
nosjps   ALIAS   MTV$NOS_JPS
sitvalue ALIAS   OSV$DEFAULT_SIT_VALUE
os_type  ALIAS   OSV$170_OS_TYPE
os_terms ALIAS   OSV$170_OS_TERMINATION_STATUS
nossegp  ALIAS   MTV$NOS_SEG_P
nostime  ALIAS   MTV$TOTAL_NOS_CPU_TIME
haltring ALIAS   MTV$HALT_CPU_RING_NUMBER
systemhr ALIAS   MTV$SYSTEM_HALTRING
extiou   ALIAS   OSV$IOU_EXTERNAL_INTERRUPT
mtvdftb  ALIAS   mtv$dft_block_p
scb      ALIAS   MTV$SCB
scbvec   ALIAS   MTV$SCB_VECTOR_SIM_ATTRIBUTE
nosxp    ALIAS   MTV$NS_XP_P
nostab   ALIAS   MTV$NST_P
bct_pva  ALIAS   DSV$BOOT_CONTROL_TABLE_P
nossegt  ALIAS   MTV$NOS_SEGMENT_TABLE_P
dtrace   ALIAS   MTV$DUMMY_TRACE_BUFFER
trace    ALIAS   MTV$TRACE_BUFFER
osv_bl   ALIAS   osv$build_level
ENDTBLS  ALIAS   OSV$MAINFRAME_WIRED_HEAP
memlimit ALIAS   OSV$180_MEMORY_LIMITS
MMTIME   ALIAS   MMV$TIME_TO_CALL_MEM_MGR
QSTIME   ALIAS   MMV$TIME_TO_CALL_QUICK_SWEEP
scbtime  ALIAS   MTV$TIME_TO_CHECK_SCB_STATUS
alltime  ALIAS   MTV$MAX_ASYNC_LOCK_TIME
CST0     ALIAS   MTV$CST0
XPINITV  ALIAS   MTV$XP_INITIAL_VALUE
kcb_rma  ALIAS   syv$pmf_cb_rm_word_address
ROOT     ALIAS   MTV$ROOT
BEGIN    ALIAS   MTP$BEGIN
BINDSEC  ALIAS   MTV$BINDING_SECTION
NOSVE_BT ALIAS   OSV$BASE_SYSTEM_TIME
NOS_TOD  ALIAS   SYV$NOS_SYSTEM_TIME
MLIST    ALIAS   MTV$MLI_STATUS
SWAPTIME ALIAS   JSV$TIME_TO_CALL_JOB_SWAPPER
.
.  The following are XDCLed so that the KEYPOINT analyzer can determine which
.  part of this module is executing when analyzing KEYPOINT files. If any changes
.  are made to these names or to the RELATIVE positions of the routines, the
.  KEYPOINT analyzer must be changed.
.
ASYNC    ALIAS   MTP$CHECK_ASYNC_ACTIVITY
IDLE     ALIAS   MTP$MONITOR_IDLE_LOOP
EXCHLOOP ALIAS   MTP$PROCESS_JOB_EXCH_REQ
TRAPRTN  ALIAS   MTP$TRAP_HANDLER
RQPROC   ALIAS   MTP$CALL_MONITOR_REQUEST
RUN_NOS  ALIAS   MTP$RUN_NOS_170_MODE
EXTRQ    ALIAS   MTP$PROCESS_EXTERNAL_INTERRUPT
         page
..............................................................................
.
.   Define Stack Segment and exchange packages for monitor mode.
.   The monitor exchange packages and segment table are located at
.   the beginning of the monitor stack.
.
..............................................................................
mstackl  equ     xpsize+(mstlen+ajllen+1)*8+mstksize
mts$monitor_stack SECTION extwork,read+write,,0,8,mstackl
         use     mts$monitor_stack
         def     mtrstak,mst
         defg    mxp
bgnstak  bss     0
mxp      bssz    xpsize
mst      bssz    mstlen*8+ajllen*8+8
mtrstak  bss     mstksize
mtrstake bss     0
         xpa     mxp,2,begin
         xpa     mxp,xptos,mtrstak,0
         xpareg  mxp,a_tos,mtrstak,mstkfram
         xpareg  mxp,a_csf,mtrstak,0
         xpareg  mxp,a_psa,nil
         xpareg  mxp,a_bindin,bindsec
         xpareg  mxp,a_root,root,0
         xpareg  mxp,5,nil
         xpareg  mxp,6,nil
         xpareg  mxp,7,nil
         xpareg  mxp,8,nil
         xpareg  mxp,9,nil
         xpareg  mxp,10,nil
         xpareg  mxp,11,nil
         xpareg  mxp,12,nil
         xpareg  mxp,13,nil
         xpareg  mxp,14,nil
         xpareg  mxp,15,nil
         xpv     mxp,xpstal,mst-bgnstak,16 .Segment table address
         xpv     mxp,xpstl,mstlen+ajllen,16 .Segment table length
         xpv     mxp,xpmm,m_mtrmsk,16  .Monitor mask
         xpv     mxp,xpum,m_usrmsk,16  .User mask
         xpv     mxp,xpkm,0,16
         xpv     mxp,xppit,0ffff(16),16  .Monitor PIT
         xpv     mxp,xppit+8,0ffff(16),16
         xpv     mxp,xplrn,1,16
         xpa     mxp,xptp,bs_trap,0
         xpv     mxp,xpflgte,00000(16),16
         xpv     mxp,xpbc2,cst0,16
         xpv     mxp,248,cst0,32  .Set offset and length of CST0 into XE
         xpv     mxp,252,cstsize,32
         org     mtrstake
mxp      alias   MTV$MONITOR_EXCHANGE_PACKAGE
mst      alias   MTV$MONITOR_SEGMENT_TABLE
         page
..............................................................................
.
.   Define Binding Section
.       (note - the RQTABLE macro puts entries here also)
..............................................................................
         USE     BINDING
.
         def     bs_trap
BS_TRAP  ALIAS   MTV$TRAP_CBP
bs_trap  address ce,traprtn                 .Used for monitor XP trap ptr.
bs_root  address p,root
.
         ref     MTP$ERROR_STOP
         ref     MTP$MTR_ERROR_STOP
         ref     OSP$PROCESS_MTR_PAGE_FAULT
         ref     TMV$PTL_LOCK
.
bs_errst address c,MTP$ERROR_STOP
bs_merrs address c,MTP$MTR_ERROR_STOP
bs_pgflt address ce,OSP$PROCESS_MTR_PAGE_FAULT
bs_ptlok address p,TMV$PTL_LOCK
         page
..............................................................................
.
.   BOOT - Execution at deadstart starts here. Save a copy of the job
.          XP, reset the clock, and jump to the location that exchanges
.          to job mode.
..............................................................................
.
         USE     CODE
         def     begin
begin    bss     0                     .This is where execution begins
         ente    x0,63(16)             .Initialize KBP register
         isom    x1,x0,2020(8),x0      .NOT CORRECT FOR MULTIPROCESSOR
         cpyxs   x1,x0                 .Need to do in every processor
         ente    x0,r_bc
         cpysx   x1,x0                 .Get  base constant.
         cpyax   x2,a_root
         addx    x1,x2                 .Form pointer to cst
         cpyxa   a_cst,x1
         sa      a_cst,a_csf,10        .Save CST_P for p-list.
         entl    x0,r_eid              .Save EID in CST.
         cpysx   x0,x0
         sx      x0,a_cst,elem_id
         entp    x0,0                  .Start cache and map purging
         sx      x0,a_cst,cachtim
         sx      x0,a_cst,maptim
         traktef 0                     .Clear the Traps_Enabled bit in MCR mask
         lx      x1,a_root,nosexit     .Check if this is first CPU.
         brxne   x1,x0,begin5          .Jump if not first CPU.
.
.   The following is initialization code executed ONLY on the first CPU to start.
.
         entl    x0,r_eid              .Check element id to turn off DUE
         cpysx   x1,x0                 .  mask bit on CYBER 2000
         isob    x1,x1,x0,(40*64+7)    .High order 7 bits of model number
                                       .  from element id
         ente    x2,46(16)             .CYBER 2000 Model 46
         brreq   x1,x2,begin1_a
         incx    x2,2                  .CYBER 2000 Model 48
         brreq   x1,x2,begin1_a
         brreq   x0,x0,begin1_b
.
begin1_a entl    x0,r_mm               .Get live register for mtr mask
         cpysx   x1,x0                 .Clear the due bit in the live
         ente    x2,m_mcrdue           .mtr mask for CYBER 2000
         inhx    x1,x2
         cpyxs   x1,x0
.
begin1_b sx      xd,a_root,osv$boot_sdte
         ente    x1,1000(16)+mstlen    .Set up pointer to system jobmonitor
         shfx    x1,x1,x0,32           .  XCB.
         addxq   x1,x1,jr_mxcb
         cpyxa   a_xcb,x1
         entp    x1,1
         sbyts,1 x1,a_root,x0,osv$boot
.
         la      a_dscb,a_root,nostab  . Build pointer to the dscb
         addax   a_dscb,xf

         lbyts,1 x1,a_dscb,x0,dscb_tef . Get the first byte of the D8ST
                                       . field of dual state control block
         ente    x2,2                  . Set bit to let DFT know about
         iorx    x1,x2                 .   THETA Trap code version
         sbyts,1 x1,a_dscb,x0,dscb_tef . Replace the first byte of the D8ST
.
         la      ae,a_root,mtrstp      . Update NOS st from mtr st
         la      af,a_root,nossegt
         lbyts,8 x1,ae,x0,snnthmtr*8
         sbyts,8 x1,af,x0,snnth170*8
         lbyts,8 x1,ae,x0,snsfmtr*8
         sbyts,8 x1,af,x0,snsf170*8
         sbyts,8 x1,a_root,x0,dsv$ssr_sdte  . Tell job mode the STE of SSR
         lbyts,8 x1,ae,x0,12(16)*8
         sbyts,8 x1,af,x0,12(16)*8
.
         sa      a_xcb,a_cst,xcbp      .Store xcb pointer in CST.
         tpage   x1,a_xcb              .Save RMA of XCB in CST.
         sx      x1,a_cst,xcbrma
         entl    x0,r_jps              .Update JPS.
         cpyxs   x1,x0
         tpage   x1,a7
         la      ad,a_root,nostab      .FWA of NOS field length.
         sa      a_dscb,a_root,nostab  .Save dscb pointer
         cpytx   x1,x1                 .Reset time task began execution.
         sx      x1,a_root,scb+scbnsrv
         entl    x0,r_eid
         sx      x1,a_root,nosexit     .Set time when last exited NOS
         cpysx   xe,x0                 .Save element id.
         entp    x6,5                  .High order 4 bits of S0 model number.
         isob    xe,xe,x0,(40*64+3)    .High order 4 bits of model number from
                                       . element id.

.  Set up memory and interrupt port mask based on processor.

         lbyts,1 x1,a_cst,x0,memport   .Memory and interrupt port mask for non S0
         brrne   xe,x6,begin2_5        .Jump if not an S0.
         incr    x1,3                  .If S0, change port 0 (int sel = 1) to a 4,
         entp    x2,4                  .  port 1 (int sel = 4) to an 8.
         brxeq   x1,x2,begin2_5        .If cpu 0, then 4 is the right answer,
         entp    x1,8                  .  otherwise 8 is the answer.
begin2_5 bss     0
         sbyts,1 x1,a_cst,x0,memport   .Set up port number mask for ext interrupts.
         sbyts,1 x1,a_root,x0,intport
         lx      xe,a_root,ve_vrsn     .ve os type, dscb version/level
         sx      xe,a_dscb,d8ty        .Save in block
.
.    Set the NOS/VE memory limits.  Both upper bounds are set to the RMA of
.    the SSR.  The deadstart upper bound may be reset before first page fault
.    based on the image size.
.
         lx      x1,a_dscb,d7cm+8      .Fetch memory limits
         isob    xe,x1,x0,(64-48)*100(8)+24-1  .Isolate ve fwa DIV 10000(8)
         shfx    xe,xe,x0,12
         sbyts,4 xe,a_root,x0,memlimit
         la      ae,a_root,nossf               .Set upper bounds to the SSR RMA
         tpage   xe,ae
         sbyts,4 xe,a_root,x0,memlimit+8       .Upperbound.
         sbyts,4 xe,a_root,x0,memlimit+4       .Upperbound during deadstart.
.
.   Fetch and store pointer to the DFT block
.     r_pointer: offset, r_upper, r_lower, size
.     rma of r_pointer = r_upper*10000000(8) + r_lower*1000(8) + offset*10(8)
.
         lbyts,2 x6,a_dscb,x0,dscm+3*8+2 .Load r_upper into x6
         shfx    x6,x6,x0,7*3            .Shift: r_upper * 10000000(8)
         lbyts,2 xb,a_dscb,x0,dscm+3*8+4 .Load r_lower into xb
         shfx    xb,xb,x0,3*3            .Shift: r_lower * 1000(8)
         addx    x6,xb                   .Add r_lower to r_upper
         lbyts,2 xb,a_dscb,x0,dscm+3*8+0 .Load offset into xb
         shfx    xb,xb,x0,1*3            .Shift: offset * 10(8)
         addx    x6,xb                   .Add offset to (r_upper + r_lower)
         entp    xb,sn170mcb
         sa      a_dscb,a_root,mtvdftb   .Save base ptr: ring and segment
         sbyts,1 xb,a_root,x0,mtvdftb+1  .Set cache bypass segment number for
                                         . DFT buffer.
         sbyts,4 x6,a_root,x0,mtvdftb+2  .Store dft offset in ptr
.
         entp    x0,0
         lx      xe,a_dscb,d7ty        .Determine STATE
         isob    x1,xe,x0,5605(8)
         sbyts,1 x1,a_root,x0,os_type
         brreq   x1,x0,begin4          .If not dualstate jump

.   Determine if this is a cpu 1 dedicated to NOS system. If it is,
.   (bit 5 set indicates this is true) set bit 8 to indicate to microcode
.   that interrupts should be handled differently.

         la      ae,a_root,eicb        .Load EICB pointer
         ente    x0,5                  .Setup bit position
         lbit    xe,ae,0,x0            .Fetch bit 5 of EICB ptr.
         brreq   xe,x0,begin41         .Branch if not selected
         ente    xf,1
         sbyts,1 xf,a_root,x0,cpu1nos  .Set flag indicating cpu dedicated.
         lbyts,3 xf,a_root,x0,sprior    Fetch dedicated dispatch priority
         sbyts,3 xf,a_cst,x0,prior180   values and initialize cst.


begin41  bss     0
.
.  Save NOS base system time and the corresponding value of the free running clock.
.
         isob    x2,xe,x0,nostod       .Isolate time of day pointer
         isob    xe,xe,x0,nosdate      .Isolate date pointer
         lxi     x2,ad,x2,0            .Time of day (display code)
         lxi     xe,ad,xe,0            .Date (display code)
         cpytx   x1,x0                 .Free running clock
         sx      x2,a_root,nos_tod
         sx      xe,a_root,nos_date
         sbyts,6 x1,a_root,x0,cor_frc
         la      af,a_root,nosxp
         entp    x2,0                  .Clear left half of nosjps
         tpage   x2,af
         sx      x2,a_root,nosjps
         sbyts,4 x2,a_cst,x0,dualstat
         la      ae,a_root,nossegt     .Store upper bits of nos seg table adr.
         tpage   x2,ae
         sbyts,2 x2,af,x0,xpstal
         shfx    x2,x2,x0,-16
         sbyts,2 x2,af,x0,xpstau
         la      af,a_root,mtrstp      .Set entry for MNFR WIRED SEG in NOS ST
         cpyax   x1,a_root             .a_root is mnfr wired segment
         isob    x1,x1,x0,2413(8)      .Isolate segment number
         shfx    x1,x1,x0,3            .make sdt number
         lbyts,8 x2,af,x1,0            .get sdt entry
         sbyts,8 x2,ae,x1,0            .set sdt entry in nos st
         lx      x1,a_dscb,d7ty        .determine STATE
         isob    x1,x1,x0,5605(8)
         sbyts,1 x1,a_root,x0,os_type
         brcr    5,1,begin4            .Force EXCH bit
.
.        IF THIS IS CYBER 2000,
.        Clear the monitor mode monitor mask bit 48 of the monitor
.        exchange package and bit 48 in the monitor mask register, and
.        clear the monitor mode monitor mask bit 48 of the job mode monitor
.        mask bit 48 of the job exchange package.
.
begin4   ente    x6,0                  .Init register to 0 to use for due bit
                                       .If CYBER 2000 use reg to clear mtr mask
         entl    x0,r_eid              .Check element id to turn off due
         cpysx   x1,x0                 .mask on CYBER 2000
         isob    x1,x1,x0,(40*64+7)    .High order 7 bits of model number
                                       .from element id
         ente    x2,46(16)             .CYBER 2000 Model 46
         brreq   x1,x2,begin4_a
         incx    x2,2                  .CYBER 2000 Model 48
         brreq   x1,x2,begin4_a
         brreq   x0,x0,begin4_b
begin4_a ente    x6,m_mcrdue           .Save the due bit for CYBER 2000
.
begin4_b addaq   af,a_root,xpinitv     .Save the job exchange package
         lbyts,2 x1,a_xcb,x0,xpmm      .Get the mtr mask in the job xp
         inhx    x1,x6                 .Inhibit due bit if CYBER 2000
         sbyts,2 x1,a_xcb,x0,xpmm      .Store mtr mask in the job xp
         movb,a_xcb,x0 af,x1 0,9,255,0 0,9,255,0
         movb,a_xcb,x0 af,x1 0,9,xpsize-255,255 0,9,xpsize-255,255
.
.        Clear the monitor mode monitor mask bit 49 of the monitor
.        exchange package and bit 49 in the monitor mask register.
.
         traktef 0                     .NO-OP; trap bit already disabled
         iorx    x6,x2                 .  X2 = m_mcrtef; "OR" with DUE bit
                                       .  (if there is one) in X6
         la      ae,a_root,mtrxpp      .move original xp to
         addaq   af,a_root,initmxp     .mainframe wired.
         lbyts,2 x1,ae,x0,xpmm         .Get the mtr mask in the mtr xp
         inhx    x1,x6                 .Inhibit TEF bit on all models,
                                       .  inhibit due bit if CYBER 2000
         sbyts,2 x1,ae,x0,xpmm         .Store mtr mask in the mtr xp
         movb,ae,x0 af,x1 0,9,255,0 0,9,255,0
         movb,ae,x0 af,x1 0,9,xpsize-255,255 0,9,xpsize-255,255
         entl    x0,r_jps              .Save current JPS in CST.
         cpysx   x0,x0
         sx      x0,a_cst,xcbrma
         brxeq   x0,x0,begin22
.
.    The following code is initialization code for all cpus EXCEPT the first.
.
begin5   bss     0
         la      a_dscb,a_root,nostab  .Pointer to interface block
         entp    x1,1
         sbyts,1 x1,a_cst,x0,caldisp   .Call dispatcher.
.
.    Complete processor initialization for ALL processors.
.
begin22  lx      x1,a_root,sitvalue    .Reset SIT.
         entl    x0,r_sit
         cpyxs   x1,x0
         entp    x0,0
         sbyts,1 x0,a_cst,x0,cpu_stat  .Set cpu status running
         entl    x0,0                  .Get the current free running clock.
         cpytx   x2,x0                 .
         sx      x2,a_cst,cpwell       .Update cpu alive flag.
         entp    x0,1
         sbyts,1 x0,a_root,x0,multpro  .Set osv$multiprocessor_running to TRUE.
         traktef 1                     .Enable TEF mask bit
         entl    x0,r_te               .Enable traps
         cpyxs   x0,x0
         page
..............................................................................
.  Check Interrupt/Dispatch Flags - (TOP OF MAIN LOOP)
.     Control comes here when the 'dispflag' in the CST is set. This code processes
.     asynchronous conditions (such as IO completions and periodic conditions).
.     The task switch routine is called if the 'call dispatcher' flag in the CST is set.
..............................................................................
.
intdislp bss     0                     .Begin of interrupt-dispatch-loop.
         entl    x0,r_pit              .Save monitor clock.
         cpysx   x_clock,x0
.
.  Process asynchronous interrupts (EXT INT, Console input, Memory manager,
.            Job swapper, etc.)
.
async    entl    x0,0                  .Check if time to check async
         cpytx   x2,x0                 .  activities.
         lx      x1,a_root,asyntime    .Get time of next async activity.
         sbyts,1 x0,a_cst,x0,asyncp
         sx      x2,a_cst,cpwell       .Update cpu alive flag.
         brxge   x1,x2,tswit           .Jump if not time for async activity.
                                       .If not an internal NOSVE site, poll
         lbyts,1 xf,a_root,x0,ve_int   .for lost external interrupts.
         brxne   xf,x0,async2          .Internal sites, hang if lost ext int.
         lbyts,1 xf,a_cst,x0,ext_int   .Check external interrupt flags in cst.
         brxeq   xf,x0,async2          .Jump if no external interrupt flags.
         addpxq  a_extret,x0,async1    .Set up return from ext int processor.
         brxgt   xf,x0,extrq           .Process external interrupts.
async1   entl    x0,0                  .Restore X0 and X2--call to extrq
         cpytx   x2,x0                 .  changed them.
async2   addaq   ae,a_root,asylock
         lbset   x1,ae,x0              .Test and set lock
         brrgt   x1,x0,tswit           .Jump if another processor is already
 .                                        processing asynchronous work.
         lx      x1,a_root,asyninc     .Update time to next check async.
         lx      xe,a_root,eiflag      .Fetch ext interrupt flag.
         sx      x2,a_root,scb+scbnsrv .Update '180 alive' flag.
         addx    x1,x2
         sx      x1,a_root,asyntime
         brxgt   xe,x2,async6          .Jump if no ext interrupts to process.
         lx      x1,a_root,eiinc
         la      ae,a_root,pextiou
         entl    x0,0
         addx    x1,x2
         sx      x1,a_root,eiflag
         sx      x0,ae,0
         monreq  proc_io
         entp    x2,0
         cpytx   x2,x2
.
async6   la      ae,a_root,pdpv$scd_time
         lx      x1,ae,0               .Test if time to call keyboard rtn.
         brxgt   x1,x2,async8          .Jump if not time
         monreq  ascii_kb
         entp    x2,0
         cpytx   x2,x2
.
async8   la      ae,a_root,mtvdftb     .Fetch pointer to DFT block.
         lx      x1,ae,dftcw           .Get DFT control word.
         shfx    x1,x1,x0,62           .Check E8 field.
         brxge   x1,x0,async12         .Jump if not set.
         monreq  proc_dft              .NOTE!! May exit with E8 still set.
         entp    x2,0                  .  If so, recall in a few hundred
         cpytx   x2,x2                 .  milliseconds.
.
async12  lx      x1,a_root,scbtime     .Check if time to look at SCB status.
         brxge   x1,x2,async15         .Jump if SCB check not required.
         monreq  mon_smu
         monreq  check_pp              .iop$check_active_pps
         entp    x2,0
         cpytx   x2,x2
.
async15  lx      x1,a_root,swaptime    .Check if time to call job swapper.
         brxge   x1,x2,async20         .Jump if job swapper call not needed.
         monreq  swap_job
         entp    x2,0
         cpytx   x2,x2
.
async20  lx      x1,a_root,mmtime      .Check if time to call Mem Mgr.
         brxge   x1,x2,async21         .Jump if Mem Mgr call not needed.
         monreq  per_call
async21  lx      x1,a_root,qstime      .Check to see if quick sweep needed.
         brxge   x1,x2,async50         .Jump if not needed.
         monreq  qs_call
.
async50  entl    x0,0
         sbyts,1 x0,a_root,x0,asylock  .Clear lock
         brreq   x0,x0,async           .Check for more work before exiting
.
.  Call the task switch routine if necessary.
.     (NOTE - the following is similar to MONREQ/RQPROC but is inline for
.             performance.)
.
tswit    lx      x1,a_cst,discntl      .Check if task switch required.
         la      a_xcb,a_cst,xcbp      .XCB will be NIL if task exited!
         shfx    x1,x1,x0,-32
         cpyax   xe,a_xcb              .XE must have XCB adr if branch to tsckpr.
         brxeq   x1,x0,tsckpr          .Jump if task switch not needed.
         brrgt   x0,xe,tswit4          .Jump if NIL XCB (processor idle).
         lbyts,2 x1,a_xcb,x0,xppit     .Calculate JOB MODE time
         lbyts,2 x2,a_xcb,x0,xppit+8
         lx      xf,a_cst,jtime
         shfx    x1,x1,x0,16
         addx    x2,x1
         ents    x2                    .Sign extend job mode time
         subx    xf,x2
         sx      xf,a_cst,jtime
         isom    x1,x0,4037(8)         .Save monitor mode time in CST.
         subx    x1,x_clock
         sx      x1,a_cst,mtime
tswit4   addaq   a_rqtbl,a_root,reqtbl+rqtbles*tsksw
         addaq   ae,a_bindin,16*tsksw
         entl    x0,r_pit
         cpysx   x2,x0                 .Get current PIT
         cpyaa   af,a_csf
         ente    x0,x_envir1           .Process the request
         callseg bs_rqtbl,ae,af
         lx      xe,a_rqtbl,totalt     .Update total and max time
         lx      xd,a_rqtbl,rqcntmax
         entl    x0,r_pit
         cpysx   xf,x0                 .Calculate time to process the request
         subx    x2,xf
         addx    xe,x2
         sx      xe,a_rqtbl,totalt
         incr    xd,1
         lx      xf,a_root,cmax        .Fetch maximum stat count.
         cpyrr   x1,xd
         subx    x1,xf
         brrgt   x0,x1,tswit41         .Less than max.
         ente    x1,0
         cpyrr   xd,x1                 .Reset request count value.
tswit41  shfc    xe,xd,x0,32           .Check if new maximum time.
         brrge   xe,x2,tswit5          .  Jump if not new max.
         cpyrr   xe,x2
         shfc    xd,xe,x0,32
tswit5   lx      x1,a_cst,cptime       .Get tasks timeslice.
         la      a_xcb,a_cst,xcbp      .Reload pointer to current XCB.
         sx      xd,a_rqtbl,rqcntmax
         isom    x_clock,x0,4037(8)    .Reset monitor clock.
         entl    x0,r_sit              .Reset SIT.
         cpyxs   x1,x0                 .Copy timeslice to SIT.
         entp    x1,0                  .Reset CST fields -
         sbyts,4 x1,a_cst,x0,discntl   .Clear task switch control flags.
         sx      x1,a_cst,mtime        .  monitor mode time
         cpyax   xe,a_xcb              .!! XCB adr must be in XE for TSCKPR.

         lbyts,1 xf,a_cst,x0,lpid      .Save the XCB pointer for next recovery
         shfc    xf,xf,x0,3
         lbyts,1 xd,a_cst,x0,ajlo      .Get the ajl ordinal that is running
         sbyts,8 xd,a_root,xf,p_mode   .to determine executing jobs.

         brrgt   x0,xe,tswit8          .Skip next part if XCB is NIL.
.
         lbyts,2 x1,a_xcb,x0,xppit     .Reset JOB MODE time
         lbyts,2 x2,a_xcb,x0,xppit+8
         shfx    x1,x1,x0,16
         addx    x2,x1
         ents    x2                    .Sign extend
         sx      x2,a_cst,jtime
         tpage   x1,a_xcb              .Save RMA of XCB in CST.
         sx      x1,a_cst,xcbrma
         entl    x0,r_jps              .Update JPS.
         cpyxs   x1,x0
tswit8   xtrace  5,x1,x2,xd,ae
.
.  Run NOS 170 if it has a priority greater than 180 has.
.       (XE = XCB.OFFSET)
.
tsckpr   lbyts,4 x2,a_cst,x0,dualstat  .Fetch dual state flag.
         brrgt   x0,xe,tsckpr3         .Jump if 180 is idle.
         brxeq   x2,x0,async90         .Jump if not dual state.
         lbyts,1 x1,a_cst,x0,lpid8     .Get cpu index
         lbyts,2 xe,a_cst,x0,dsprior   .Get 180 priority. (!! XE for call to RUNNOS)
         lbyts,2 x1,a_dscb,x1,np170pr  .Get 170 priority.
         shfc    x2,xe,x0,-4           .Shift off sub priority.
         shfc    x1,x1,x0,-4
         brrgt   x2,x1,async90         .Run 180 if 180pr > 170pr.
         brrne   x2,x1,tsckpr3         .Run 170 if 170pr > 180 pr.
         isob    x2,x2,x0,0003(8)      .Isolate 180 subpriority.
         entl    x0,0                  .Read the free running clock to calculate
         cpytx   x0,x0                 .  the 170 subpriority.
         isob    x1,x0,x0,5603(8)
         brxgt   x2,x1,async90         .Jump if 180 has highest priority.
.
tsckpr3  lx      x1,a_cst,discntl      .Dont go to NOS if async flags are set.
         brxne   x1,x0,async
         lbyts,1 x2,a_cst,x0,nextstat  .Test if CPU is being turned off/down.
         brxne   x2,x0,idle            .  Go to idle loop if being turned off/down.
         addpxq  a_inret,x0,tsckpr5    .Set up return address and
         brxeq   x0,x0,run_nos         .  run NOS 170.
tsckpr5  traktef 1                     .Enable TEF mask bit
         entl    x0,r_te               .Enable traps (RUNNOS exits with disabled).
         cpyxs   x0,x0
         cpyax   x2,a_xcb              .Test for idle system.
         brrgt   x2,x0,async90         .Run user task if system not idle.
         lx      x1,a_cst,discntl      .Cycle the loop if task switch/async.
         brxne   x1,x0,async
.
.  Idle if no 180 task was found ready.
.
idle     entl    x0,r_mm               .Get the monitor mask
         cpysx   x1,x0                 .Disable asynchronous traps
         ente    x2,(m_mcrasy+m_mcrsw) . and short_warning
         inhx    x1,x2
         cpyxs   x1,x0
idle3    bss     0
         lbyts,1 x1,a_cst,x0,nextstat  .Check the next_state of this CPU
         brxeq   x1,x0,idle4           .If state <> ON THEN CPU state changed
         ente    x0,x_envir1           .Set up call to mtp$process_cpu_state_change
         cpyaa   af,a_csf
         addaq   ae,a_bindin,16*proc_cpu
         callseg bs_rqtbl,ae,af        .Call mtp$process_cpu_state_change
idle4    enta    x0,40018(16)          .Kill some time by doing a
         shfx    x0,x0,x0,44           . double precision divide
         entp    x1,0
         divd    x0,x0
idle5    addpxq  a_extret,x0,idle5     .Branch if EXT INT is set - return
         brcr    8,0,extrq             .  to retest again - loop til no EXT INT
         lx      x1,a_cst,discntl      .Exit when flags are set
         brxne   x1,x0,idle10
         addpxq  a_sitret,x0,idle5
         brcr    11,0,prsit            .Branch if SIT is set - return to idle5.
         brcr    2,2,idle10            .Fall out if short_warning is set.
         lbyts,1 x1,a_cst,x0,caldisp   .Exit idle loop if call_dispatcher
         brxne   x1,x0,idle10          . is set
.
         entp    x0,0                  .Read microsecond clock
         cpytx   x2,x0
         la      af,a_root,frc_p       .Get FRC time to call dispatcher
         lx      x1,af,0
         brxge   x1,x2,idle3           .Jump if not time to call dispatcher
         entp    x0,1
         lbset   x1,af,x0              .Test/set bit 1 of FRC time-if already
         brrne   x1,x0,idle3           . set stay in idle loop-another processor
.                                      . is updating the timed wait queue
idle9    entp    x1,1                  .Exit idle loop and call dispatcher.
         sbyts,1 x1,a_cst,x0,caldisp
.
idle10   lx      x1,a_root,sitvalue    .Put big number in SIT to reduce
         entl    x0,r_sit              .  likelyhood of unnecessary SIT.
         cpyxs   x1,x0
         entl    x0,r_mm               .Restore monitor mask.
         cpysx   x1,x0
         ente    x2,(m_mcrasy+m_mcrsw)
         iorx    x1,x2
         cpyxs   x1,x0
         brxeq   x0,x0,async
.
.  Reload PIT for current 180 task.
.
async90  entl    x0,r_pit              .Reload monitor clock (PIT).
         cpyxs   x_clock,x0
.
.   End of task switch loop.
         page
...............   beginning of critical region ............
.
.               CRITICAL REGION - between labels BCRIT1 and ECRIT1
.
.   If any changes are made in thie following code,
.   be sure to look at the code in the trap handler.
.   Under certain circumstances, P will be reset to the beginning
.   of the critical region.
.
.
BCRIT1   bss     0
exchloop bss     0
         lx      x1,a_cst,discntl      .Get async/taskswitch flags.
         brxne   x1,x0,intdislp        .Jump if async or taskswitch.
         lbyts,2 x2,a_cst,x0,taskid    .Get taskid of current task.
         sbyts,2 x1,a_xcb,x0,xpmcr     .Clear user's MCR



         la      a_xcb,a_cst,xcbp      .reload pointer to current xcb
         cpyax   xe,a_xcb              .Must be in xe
         lbyts,1 xf,a_cst,x0,lpid      .Save the XCB pointer for next recovery
         shfc    xf,xf,x0,3
         lbyts,1 xd,a_cst,x0,ajlo      .Get the ajl ordinal that is running
         sbyts,8 xd,a_root,xf,p_mode   .to determine executing jobs.




         xtrace  0,0,x1,x0,ae
         shfx    x2,x2,x0,13
         keypoint oscmtr,x2,oskexc8x
ECRIT1   exchange
...............   end of critical region ............
.
.
.   Get the MCR from the user XP.
.
*IF $variable(mtv$test_due_pnd declared) <> 'UNKNOWN'
         lx      xd,a_root,debug0+2*8  .Get the id of the CPU to be tested
         lbyts,1 x1,a_cst,x0,lpid      .Get the current CPUs id
         brxne   xd,x1,go_on2          .Check to see if this CPU is to be tested
         lx      xd,a_root,fk_due      .Get the last time we caused a DUE
         entp    x1,0                  .Get the current time
         cpytx   x1,x1
         subx    x1,xd                 .Determine the time interval
         ente    xd,0F424(16)          .Generate 1 second (in microseconds)
         shfx    xd,xd,x0,4
         brxgt   xd,x1,go_on2          .Dont execute if less than a second
         lx      xd,a_root,debug0      .Check to see if a DUE should be forced
         brxeq   xd,x0,go_on2          .If we have cause enough DUEs, go on
         lbyts,1 x1,a_cst,x0,ajlo      .Get the AJL ordinal of current task
         brxeq   x1,x0,go_on2          .Dont do this in the system job
         cpyax   x1,a_xcb              .Find out which task is executing in the job
         ente    x2,100(16)
         brreq   x1,x2,go_on2          .Dont do this in $JOBMNTR
         lbyts,1 x1,a_xcb,x0,2         .Get p.rn from XCB
         shfx    x1,x1,x0,-4
         entp    x2,3
         brxge   x2,x1,go_on2          .Dont do if ring <= 3
         entp    x1,1
         ente    x0,6*64
         sbit    x1,a_xcb,0,x0         .set MCR DUE
         lx      x2,a_root,debug0+1*8  .Get value of debug0[1] = PND
         brxeq   x2,x0,go_on1          .IF PND = true, set PND flag
         ente    x0,131
         sbit    x1,a_xcb,0,x0         .set PND
go_on1   decx    xd,1
         sx      xd,a_root,debug0
         entp    x1,0                  .Get the current time
         cpytx   x1,x1
         sx      x1,a_root,fk_due      .Store the time we caused a DUE
go_on2   bss     0
*ELSE
. ---------- Test code was omitted at compilation time ----------
*IFEND
         lbyts,2 x_mcr,a_xcb,x0,xpmcr  .Get MCR from user XP
         xtrace  1,x_mcr,x1,x0,ae      .Save MCR in trace buffer.
         shfx    x1,x_mcr,x0,13        .Keypoint MCR.
         keypoint oscmtr,x1,oskexc8
.
.
.  Special case an MCR of EXCH ONLY. This is the most frequent interrupt in
.  dual state. If EXCH is set and other bits are set as well, the EXCH will
.  be handled later.
.
         ente    x1,m_mcrexc           .Check for only EXCH set.
         brxne   x1,x_mcr,ckhdw        .Jump if not EXCH only.
         entl    x0,r_pit              .Stop the clock.
         cpysx   x_clock,x0
         la      ae,a_root,nosxp
         sbyts,2 x1,ae,x0,xpmcr
         addpxq  a_inret,x0,ckexsp5    .Set up return address.
         lbyts,2 xe,a_cst,x0,dsprior   .Get current 180 priority.
         brxeq   x0,x0,run_nos         .Go run NOS 170.
ckexsp5  entl    x0,r_pit              .Start monitor clock.
         cpyxs   x_clock,x0
         traktef 1                     .Enable TEF mask bit
         entl    x0,r_te               .Enable traps.
         cpyxs   x0,x0
         brxeq   x0,x0,exchloop
.
.
.   Process hardware errors - (DUE, SHORT WARNING).
.
ckhdw    ente    x1,m_mcrhdw           .Check for hardware errors
         andx    x1,x_mcr
         brreq   x1,x0,ckasync
         shfc    x1,x_mcr,x0,18        .Check for short warning.
         brrge   x1,x0,ckdue           .Jump if no short warning.
         monreq  pswarn
.
ckdue    shfc    x1,x_mcr,x0,16        .Check for DUE.
         brrge   x1,x0,ckasync
         purge   x0,2                  .Purge cache and map.
         purge   x0,15
         entp    x1,0                  .Set up plist
         sx      x1,a_csf,0
         sa      a_xcb,a_csf,18
         monreq  proc_due
         ente    x_mcr,m_mcrasy        .Force async interrupts since these
.                                         may be invalid because of DUE.
.
.   Process asynchronous interrupts.
.
ckasync  ente    x1,m_mcrasy           .Check for asynchronous interrupt
         andx    x1,x_mcr
         brreq   x1,x0,ckuser          .Jump if no asynchronous interrupt
         entl    x0,r_pit              .Stop the monitor clock.
         cpysx   x_clock,x0
         shfc    x1,x_mcr,x0,27        .Check for SIT.
         brrge   x1,x0,ckextint        .Jump if no SIT.
         addpxq  a_sitret,x0,ckextint  .Set up return address.
         brxeq   x0,x0,prsit           .Go process SIT interrupt.
ckextint shfx    x1,x_mcr,x0,24        .Check for EXT INT
         addpxq  a_extret,x0,ckexch
         brrgt   x0,x1,extrq           .Jump if  EXT INT.
ckexch   ente    x1,m_mcrexs           .Clear SIT and EXTINT.
         inhx    x_mcr,x1
         sbyts,2 x_mcr,a_xcb,x0,xpmcr  .Clear MCR - see trap handler.
         shfx    x1,x_mcr,x0,21        .Check for EXCH
         brrge   x1,x0,ckasyncx        .Jump if no EXCH
         ente    x1,m_mcrexc           .Set EXCH bit in NOS XP
         la      ae,a_root,nosxp
         sbyts,2 x1,ae,x0,xpmcr
         addpxq  a_inret,x0,ckexch5
         lbyts,2 xe,a_cst,x0,dsprior   .Get current 180 priority.
         brxeq   x0,x0,run_nos         .Run NOS
ckexch5  traktef 1                     .Enable TEF mask bit
         entl    x0,r_te               .Enable traps
         cpyxs   x0,x0
ckasyncx entl    x0,r_pit              .Start monitor clock.
         cpyxs   x_clock,x0
         brxeq   x_mcr,x0,exchloop
.
.   Process faults normally handled in job mode via trap handler.
.
ckuser   ente    x1,j_mcrusr           .Check for condition that will
         andx    x1,x_mcr              .be processed in job mode          .
         brreq   x1,x0,ckpf            .Jump if no job mode request
         purge   x0,15                 .Purge required after INV SEG.
         monreq  rqfault,0,exchloop
.
.   Check for a Page Fault.
.
ckpf     shfx    x1,x_mcr,x0,57        .Check for a page fault.
         brxge   x1,x0,ckmcall         .Jump if no page fault.
         monreq  rqpf,0,exchloop
.
.   Check for a System Call request.
.
ckmcall  shfx    x1,x_mcr,x0,58        .Check for a SYSTEM CALL.
         brxge   x1,x0,ckucr           .Jump if no SYSTEM CALL.
         lbyts,1 x1,a_xcb,x0,xpxregs   .Get request code
         lbyts,1 x2,a_xcb,x0,2         .Get p.rn from XCB
         addaq   ae,a_xcb,xpxregs      .Set up plist to point to
         sa      ae,a_csf,0            .X_regs of current task
         ente    xe,mtrqmax            .Check for max req code.
         brxge   xe,x1,ckmcall5        .Jump if ok.
         entp    x1,0
ckmcall5 shfx    x2,x2,x0,-4
         monreq  x1,x2,exchloop
.
.   If control gets here, there is a chance that the MCR value was zero
.   (except for possible async/sel interrupts). Check for a UCR fault that
.   caused a monitor exchange because traps were disabled.
.
ckucr    lbyts,2 x1,a_xcb,x0,xpucr     .Check for fatal UCR faults.
         ente    x0,j_usrabt
         andx    x1,x0
         brxeq   x1,x0,exchloop        .Jump if no fatal faults.
         lbyts,2 x1,a_xcb,x0,xpflgte   .Check for traps enabled
         isob    x1,x1,x0,7601(8)
         decr    x1,2
         brreq   x1,x0,exchloop        .Jump if traps not disabled
         monreq  rqfault,0,exchloop
         page
..............................................................................
.
.   Trap Handling Routine for traps that occur in Monitor Mode
.
..............................................................................
         align   0,8
traprtn  bss     0
         entl    x0,r_pit              .Save PIT
         cpysx   x_clock,x0
         entl    x0,r_kef0             .Save and clear KEF.
         cpysx   x_kef,x0
         cpyxs   x0,x0
         la      a_root,a_bindin,bs_root
.
trtheta  ente    x2,m_mcrtef           .Check MCR mask trap enable flag
         entl    x0,r_mm               . in the monitor mask.
         cpysx   x1,x0
         andx    x1,x2                 .If MCR mask bit is set,
         brxne   x1,x0,trcnt1          . continue to handle the trap
.
. Mask bit for traps enabled NOT set
.
         lbyts,2 x_mcr,a_psa,x0,sfsa_mcr  .Get the MCR
         shfc    x1,x_mcr,x0,48        .Check for the presence of a DUE
         brxge   x1,x0,trsync          .If DUE, halt
         errstop thetadue
         halt                          .Should not return.
trsync   errstop masksync              .MCR mask out of sync; halt
         halt                          .Should not return.
.
. The code at TRCNT1 does what the macro TRAKTEF 0 would do normally.
.
trcnt1   entl    x0,r_mm               . traktef  0
         cpysx   x1,x0                 .Get live register for mtr mask
         ente    x2,m_mcrtef           .Clear the Traps_Enabled bit in the live
         inhx    x1,x2                 .  mtr mask for THETA
         cpyxs   x1,x0                 .Set live register for mtr mask
trcnt2   la      a_dscb,a_root,nostab
         ente    x0,r_bc
         cpysx   x1,x0                 .get  base constant.
         cpyax   x2,a_root
         addx    x1,x2                 .form pointer to cst
         cpyxa   a_cst,x1
         addaq   a0,a0,mstkfram
         sa      a_cst,a_csf,10        .Save CST_P in p-list.
.
         lbyts,2 x_mcr,a_psa,x0,sfsa_mcr .Get MCR
         la      a_xcb,a_cst,xcbp      .reload pointer to current xcb
         cpyax   xe,a_xcb              .Must be in xe
         lbyts,1 xf,a_cst,x0,lpid      .Save the XCB pointer for next recovery
         shfc    xf,xf,x0,3
         lbyts,1 xd,a_cst,x0,ajlo      .Get the ajl ordinal that is running
         sbyts,8 xd,a_root,xf,p_mode   .to determine executing jobs.


         xtrace  2,x_mcr,x1,x0,ae      .Save MCR in trace buffer.
.
.   DO NOT halt the processor if a DUE or SHORT WARNING occurred.
.
         ente    x1,m_mcrhlt+m_mcrhdw  .Check for fatal errors.
         andx    x1,x_mcr
         brxeq   x1,x0,trhdwx
         shfc    x1,x_mcr,x0,50        .Check short warning.
         brxge   x1,x0,trckdue
         monreq  pswarn
.
trckdue  shfc    x1,x_mcr,x0,48        .Check DUE.
         brxge   x1,x0,trhdw5
         ente    x_mcr,m_mcrasy        .Force all async interrupts.
         purge   x0,2                  .Purge cache and map.
         purge   x0,15
         entp    x1,2                  .Set up plist
         sx      x1,a_csf,0            .Store code to indicate DUE in monitor.
         sa      a2,a_csf,18           .Store pointer to save area.
         monreq  proc_due
.
trhdw5   ente    x1,m_mcrhlt           .Halt if any fatal
         andx    x1,x_mcr              .  conditions are set
         brxeq   x1,x0,trhdwx
trstop   ente    x0,00ff(16)
         callseg bs_merrs,a_bindin,ae  .Call mtp$mtr_error_stop.
         halt                          .should not return, halt if it does
trhdwx   bss     0
.
. Process page fault in monitor mode
.
         ente    x1,m_mcrpf
         andx    x1,x_mcr
         brxeq   x1,x0,nopf            .If no page fault
         sa      a2,a_csf,2            .Plist = a2
         addaq   ae,a_csf,16           .Plist = VAR halt
         sa      ae,a_csf,8
         cpyaa   ae,a_csf
         ente    x0,x_envir1
         callseg bs_pgflt,a_bindin,ae
         lbyts,1 x1,a_csf,x0,16        .Get returned value of halt
         sa      a_cst,a_csf,10        .Re-save CST_P in p-list.
         brxne   x1,x0,trstop          .Jump if fatal error
         ente    x1,m_mcrpf            .Dont reset P if MCR=0040 ONLY.
         brxeq   x1,x_mcr,trresex
nopf     bss     0
.
.  If the trap occurred between the labels BCRIT1 and ECRIT1, reset the
.  trapped 'P' address to the label BCRIT1.
.
         lbyts,4 x1,a_psa,x0,4         .Get P from SFSA.
         addpxq  ae,x0,ecrit1
         cpyax   x2,ae
         brrgt   x1,x2,trresex
         addpxq  ae,x0,bcrit1
         cpyax   x2,ae
         brrgt   x2,x1,trresex
         sa      ae,a_psa,2
.
. The following field definition is used to support the PSFSA instruction which is
. required for CYBER-2000 but is not available in the ASSEMBLER language yet.
. When it is available, replace the VFD line with the following line:
.        psfsa                      .Purge the SFSA pushdown (CYBER-2000 only)
.
         vfd,16   0701(16)          .Purge SFSA pushdown (CYBER-2000 only)
trresex  bss     0
.
.  Protect against the case where 1) a SIT or EXT INT occurred in 180 job
.  mode to cause an exchange to monitor and 2) prior to processing the
.  SIT/EXT INT an EXCH occurred to cause a trap.
.
         la      a_xcb,a_cst,xcbp      .Fetch XCB pointer.
         cpyax   x1,a_xcb              .Skip this check if NIL.
         brrgt   x0,x1,trnom
         lbyts,2 x1,a_xcb,x0,xpmcr     .Fetch MCR from current XP.
         iorx    x_mcr,x1              .Merge with trapped MCR.
         ente    x2,m_mcrasy
         inhx    x1,x2
         sbyts,2 x1,a_xcb,x0,xpmcr     .Store MCR less asynch bits.
trnom    bss     0
.
.  Process asynchronous interrupts.
.
         ente    x1,m_mcrasy           .Check for asynchronous interrupts.
         andx    x1,x_mcr
         brxeq   x1,x0,trasy15         .Jump if no asynchronous interrupts.
         shfc    x1,x_mcr,x0,27        .Check for SIT.
         brrge   x1,x0,trasy5          .Jump if no SIT.
         addpxq  a_sitret,x0,trasy5    .Set up return address.
         brxeq   x0,x0,prsit           .Go process SIT interrupt.
trasy5   shfx    x1,x_mcr,x0,24        .Check for EXT INT
         addpxq  a_extret,x0,trasy8
         brrgt   x0,x1,extrq           .Jump if  EXT INT
trasy8   shfx    x1,x_mcr,x0,21        .Check for EXCH
         brrge   x1,x0,trasy15         .Jump if no EXCH
         entl    x0,5                  .Set EXCH bit in MCR.
         la      ae,a_root,nosxp
         sbit    x0,ae,xpmcr,x0
         lbyts,2 x1,a_root,x0,mtrprior .Get 180 monitor priority.
         lbyts,2 xe,a_cst,x0,dsprior   .Dont change if already greater.
         brxgt   xe,x1,trasy9
         cpyxx   xe,x1
trasy9   entl    x0,r_jps              .Check if NOS170 is the current task.
         cpysx   x1,x0
         lbyts,4 x2,a_cst,x0,dualstat
         addpxq  a_inret,x0,trasy15
         brxne   x2,x1,run_nos         .Go run NOS 170.
.
.   Halt processor if fatal UCR fault occurred.
.
trasy15  ente    x1,m_usrabt           .Check for fatal UCR fault
         lbyts,2 x2,a_psa,x0,sfsa_ucr .Get UCR
         andx    x1,x2
         brxne   x1,x0,trstop          .Jump if fatal error
.
.   If the trap occurred in the critical area of the trap handler, POP the
.   previous stack frame and let this frame - the new trap handler - take
.   care of setting trap enable flags.
.
         lbyts,4 x1,a_psa,x0,4         .Get P from SFSA.
         addpxq  ae,x0,rqproc          .Address of end of critical TH region
         cpyax   x2,ae
         brrge   x1,x2,trexit
         addpxq  ae,x0,trexit          .Address of beginning of critical TH region
         cpyax   x2,ae
         brrgt   x2,x1,trexit
         pop                           .POP the previous stack frame (Trap Handler)
                                       . and become the real trap handler
.
.   Set TRAP ENABLE DELAY and return.
.
trexit   bss     0
         entl    x0,r_ted              .Set trap enable delay
         cpyxs   x0,x0
         traktef 1                     .Enable Traps_Enabled bit in MCR mask
         entl    x0,r_kef0             .Restore KEF.
         cpyxs   x_kef,x0
         entl    x0,r_pit              .Restore PIT
         cpyxs   x_clock,x0
         return
         page
..............................................................................
.
.      This routine updates the request statistics and calls the
.      appropriate request processor.
.      Interlocking of most monitor functions is performed by this routine.
.
.      Entry condition:
.           a_rqtbl  - pointer to request table entry for request.
.           ae       - pointer to binding section entry for request proc.
.           a_rq_ret - return address
.
..............................................................................
.
rqproc   bss     0
         lx      x1,a_root,multpro     .Test for multiple processors.
         entl    x0,r_pit              .Get current PIT
         cpysx   x2,x0                 .!! X2 contains PIT thruout this proc.
         brxeq   x1,x0,rqpr14          .Jump if not multi_processor
         lbyts,1 x1,a_rqtbl,x0,il      .Test if request must be interlocked.
         brxeq   x1,x0,rqpr14          .  jump if interlock not required
         addaq   af,a_root,il_tbl      .Calc pointer to interlock word.
         shfx    x1,x1,x0,3
         addax   af,x1                 .PVA of interlock table
         entp    x0,0                  .Try to set lock
         lbset   x1,af,x0
         brreq   x1,x0,rqpr12          .Jump if interlock obtained.
.
rqpr4    entp    x0,0                  .Keep trying to set lock.
         lbset   x1,af,x0
         brreq   x1,x0,rqpr6           .Jump if lock obtained.
         entp    x1,1                  .Kill some time by doing a
         divx    x1,x1                 .  divide
         lbyts,1 x1,a_cst,x0,cp_state+cp_nxtst  .check for step cpu request
         brxne   x1,x0,rqpr5
         lx      x1,af,0               .Get the ID of locking CPU
         brreq   x1,x0,rqpr4           .Jump if not still locked
         lbyts,1 xd,a_root,x1,nextstat .Get next state of locking CPU
         brxeq   xd,x0,rqpr4           .Jump if locking CPU still ON
         lbyts,1 x1,a_root,x1,cpstreas .Get next state of locking CPU
         entp    xd,4                  .ordinal 4 is down by operator
         brxeq   x1,xd,rqpr4           .Jump if down by operator
         errstop cpudown               .  else halt with fatal error.
         halt                          .Should not return.
rqpr5    errstop stepmes
         brxeq   x0,x0,rqpr4           .Continue trying to get the lock.
.
rqpr6    entl    x0,r_pit              .Restore PIT- don't charge user for wait.
         cpysx   x1,x0                 .Read PIT to calc wait time.
         lx      xd,a_root,lockwait    .Update lock wait time and count.
         lx      xe,a_root,lockwait+8
         subx    x1,x2
         notx    x1,x1
         addx    x1,xd
         sx      x1,a_root,lockwait
         incx    xe,1
         sx      xe,a_root,lockwait+8
         cpyxs   x2,x0
.
rqpr12   cpyax   x1,af                 .x1 = pva of interlock table
         sa      a_cst,af,lockcp       .Store ID of locking CPU
rqpr14   bss     0                     .x1 = zero if no interlock.
         ente    x0,x_envir1           .Process the request
         cpyaa   af,a_csf
         callseg bs_rqtbl,ae,af
         entl    x0,r_pit
         cpysx   xd,x0                 .Calculate time to process the request
         lx      xe,a_rqtbl,totalt     .Update total and max time
         lx      xf,a_rqtbl,rqcntmax
         subx    x2,xd
         addx    xe,x2
         sx      xe,a_rqtbl,totalt
         incr    xf,1

         lx      xd,a_root,cmax        .Fetch maximum stat count.
         cpyrr   xe,xf
         subx    xe,xd
         brrgt   x0,xe,rqpr15          .Less than max.
         ente    xe,0
         cpyrr   xf,xe                 .Reset request count value.

rqpr15   shfc    xe,xf,x0,32           .Check if new maximum time.
         brrge   xe,x2,rqpr20          .  Jump if not new max.
         cpyrr   xe,x2
         shfc    xf,xe,x0,32
rqpr20   sx      xf,a_rqtbl,rqcntmax
         brxeq   x1,x0,rqpr30          .Exit if no lock
         entl    x0,0
         cpyxa   af,x1
         sx      x0,af,ilflag          .Clear lock
rqpr30   brdir   a_rq_ret,x0           .Return
         page
..............................................................................
.
.  This routine is called whenever a SIT interrupt occurs.
.
..............................................................................
.
prsit    bss     0
         sa      a_sitret,a_cst,return .save the return address
         entp    xf,1                  .Set up X15 with 'TRUE'.
         entp    x0,0                  .Set up X0 with 'FALSE'.
         cpytx   x2,x0                 .Free running clock ->X2.
         sx      x2,a_root,scb+scbnsrv .Update '180 alive' flag.
         sx      x2,a_cst,cpwell       .Update cpu alive flag.
         sbyts,1 xf,a_cst,x0,caldisp
.
                                       .If not an internal NOSVE site, poll
         lbyts,1 xe,a_root,x0,ve_int   .for lost external interrupts.
         brxne   xe,x0,prsit2          .Internal sites, hang if lost ext int.
         lbyts,1 xe,a_cst,x0,ext_int   .Check external interrupt flags in cst.
         brxeq   xe,x0,prsit2          .Jump if no external interrupt flags.
         addpxq  a_extret,x0,prsit2    .Set up return from ext int processor.
         brxgt   xe,x0,extrq           .Process external interrupts.
.
prsit2   lx      xf,a_root,alltime     .Get time async lock has been set
         brxge   x2,xf,prsit3          .max time has been exceeded
         lx      x1,a_root,sitvalue    .Reset SIT.
         entl    x0,r_sit
         cpyxs   x1,x0
         brdir   a_sitret,x0


prsit3   monreq  mon_smu               .We got here because the system is in a
.                                       severe thrashing state and probably
.                                       spending all it's time processing memory
.                                       requests. We need to notify DFT that we
.                                       are still alive so it doesn't shut us
.                                       down with a Z617 error.
.
         entp    x0,0
         cpytx   x2,x0
         lx      x1,a_root,sitvalue     .Reset SIT
         entl    x0,r_sit
         cpyxs   x1,x0
         la      a_sitret,a_cst,return
         brdir   a_sitret,x0           .Go back to what we were doing


         page
..............................................................................
.
.   The purpose of this routine is to give control to NOS170.
.
.   NOTE: This routine may be entered with traps disabled or enabled.
.         Reentry of the routine from the trap handler is prevented by
.         setting the JPS register to NOS_JPS.  This routine exits with traps
.         disabled unless NOS is not present. In this case no change is
.         made to the TE register.
.
.     Enter with 180 priority in XE.
.
...............................................................................
.
run_nos  bss     0
.
         lbyts,4 x1,a_cst,x0,dualstat  .Exit if no dual state.
         brxeq   x1,x0,runexit
.
         entl    x0,r_jps
         cpyxs   x1,x0                 .Copy NOS_JPS to JPS reg
         la      a_innosx,a_root,nosxp
.
         lbyts,1 x1,a_cst,x0,lpid8     .Store 180 priority.
         sbyts,2 xe,a_dscb,x1,np180pr
         shfx    xe,x1,x0,-3
.
         entp    x_infrc,0             .Get current time
         cpytx   x_infrc,x_infrc
         lx      x2,a_root,nosexit     .Update time not spent in NOS
         subx    x2,x_infrc
         notx    x2,x2
         lxi     x1,a_dscb,xe,npxtime
         addx    x1,x2
         sxi     x1,a_dscb,xe,npxtime
.
.  (BEGIN - EXCH loop).   Exchange to NOS170.
.
runnos6  bss     0


.
.                                      .Dedicated NOS CPU special code follows.
.
.                                      .Purge cache on return to dedicated
.                                      .processor.


         la      ae,a_root,eicb        .EI control block pointer
         ente    x0,6                  .Position of interrupt flag
         lbit    xe,ae,0,x0            .is bit 6 of EICB word.
         brreq   xe,x0,runnos7         .Interrupt is not CPU 1
         ente    xe,0
         sbit    xe,ae,0,x0            .Clear the cache purge flag in EICB
         cpytx   x0,x2                 .Free running clock
         purge   x0,2                  .Purge cache
         sx      x0,a_cst,cachtim      .Store cache purge time

runnos7  entp    x_infrc,0             .Get current time
         cpytx   x_infrc,x_infrc
         la      af,a_root,hnsk_p      .Update the monitor handshaking time
         sx      x_infrc,af,8

         entp    x0,0                  .Don't count NOS
         lbyts,1 xf,a_cst,x0,lpid      .Save the XCB pointer for next recovery
         shfc    xf,xf,x0,3
         lbyts,1 xd,a_cst,x0,ajlo      .Get the ajl ordinal that is running
         sbyts,8 xd,a_root,xf,p_mode   .to determine executing jobs.





         xtrace  3,0,x1,xe,ae
         traktef 1                     .Enable TEF mask bit
         entl    x0,r_te               .Enable traps
         cpyxs   x0,x0
         keypoint oscmtr,x0,oskexc7
         exchange                      .EXCHANGE TO NOS (NOS-BE)
         lbyts,2 x_inmcr,a_innosx,x0,xpmcr .Get MCR
         shfx    x2,x_inmcr,x0,13
         keypoint oscmtr,x2,oskexc7x
.
. Disable TEF mask bit
.
         entl    x0,r_mm               .Get live register for mtr mask
         cpysx   x1,x0
         ente    x2,m_mcrtef           .Clear the Traps_Enabled bit in the live
         inhx    x1,x2                 .  mtr mask
         entl    x0,r_td               .Disable traps
         cpyxs   x0,x0
         entl    x0,r_mm               .Set live register for mtr mask
         cpyxs   x1,x0
         lbyts,2 x_inmcr,a_innosx,x0,xpmcr .Get MCR
         ente    x2,m_mcrexc           .Clear MCR except for EXCH
         andx    x2,x_inmcr
         sbyts,2 x2,a_innosx,x0,xpmcr

         entp    x0,0                  .Don't count NOS
         lbyts,1 xf,a_cst,x0,lpid      .Save the XCB pointer for next recovery
         shfc    xf,xf,x0,3
         lbyts,1 xd,a_cst,x0,ajlo      .Get the ajl ordinal that is running
         sbyts,8 xd,a_root,xf,p_mode   .to determine executing jobs.






         xtrace  4,x_inmcr,xe,xd,ae    .Save NOS MCR in trace buffer
.
.   Process 'give up CPU' if only bit set in the MCR is 'system call'.
.
         ente    x2,m_mcrmcl
         brxne   x_inmcr,x2,runnos8    .Jump if not sys call ONLY.
         lbyts,1 x2,a_innosx,x0,xpvmid .Make sure request is from
         brxne   x2,x0,runnos50        .  170 state.
.
.   Process hardware errors - DUE.
.
runnos8  entl    x0,r_kef0             .Save and clear KEF.
         cpysx   x_kef,x0
         cpyxs   x0,x0
         shfc    x2,x_inmcr,x0,16      .Check for DUE.
         brrge   x2,x0,runnos10        .Jump if no DUE.
         purge   x0,2                  .Purge cache and map.
         purge   x0,15
         entl    x0,1                  .Set up plist - DUE in 170 mode
         sx      x0,a_csf,0
         sa      a_innosx,a_csf,18
         monreq  proc_due
         ente    x2,0490(16)           .Force async bit - may be lost.
         iorx    x_inmcr,x2
         lbyts,1 x2,a_innosx,x0,xpflgte .Check PROCESS-NOT-DAMAGED.
         shfr    x2,x2,x0,27
         brrge   x2,x0,runnos10        .Jump if damaged.
         ente    x2,7fff(16)           .Clear DUE in MCR.
         andx    x_inmcr,x2

.
.   Process short warning conditions.
.
runnos10 shfc    x2,x_inmcr,x0,18      .Check for SHORT WARNING.
         brrge   x2,x0,runnos11        .Jump if no SHORT WARNING.
         monreq  pswarn
.
.   Process SIT interrupt.
.
runnos11 shfc    x2,x_inmcr,x0,27      .Check for SIT.
         addpxq  a_sitret,x0,runnos12  .Go process SIT interrupt.
         brrgt   x0,x2,prsit           .Jump if SIT present.
.
.   Process EXTERNAL INTERRUPT.
.
runnos12 shfc    x2,x_inmcr,x0,24      .Check for EXT INT.
         addpxq  a_extret,x0,runnos16
         brrgt   x0,x2,extrq           .Jump if  EXT INT.
.
.   Process SYSTEM CALL requests.
.
runnos16 entl    x0,r_kef0             .Restore KEF flag.
         cpyxs   x_kef,x0
         shfc    x2,x_inmcr,x0,26      .Check for SYSTEM CALL.
         brrge   x2,x0,runnos20        .Jump if no SYSTEM CALL.
         lbyts,1 x2,a_innosx,x0,xpvmid .Check whether 170 or 180 request.
         brxeq   x2,x0,runnos18        .Jump if 180 request.
         shfc    x2,x_inmcr,x0,21      .Exit if EXCH not set.
         brrge   x2,x0,runnos50
         brxeq   x0,x0,runnos6
.
.  The following code implements a debug monitor function to allow the
.  170 trap handler to issue keypoints with:  EIMTRCAL ISSUEKPT,val,NOHLT
.

runnos18 lx      x1,a_innosx,xpxregs   .fetch request code
         entp    x2,issuekpt
         brrne   x2,x1,runnos19        .if not a keypoint request
         traktef 1                     .Enable TEF mask bit
         entl    x0,r_te               .enable traps
         cpyxs   x0,x0
         lx      x2,a_innosx,xpxregs+(8*2)
         shfx    x2,x2,x0,12
         keypoint oscdbug,x2,osktrap   .issue keypoint
         brreq   x0,x0,runnos6         .branch back into 170 state
.
.  The following code implements the DONTHING function to call the dispatcher.
.
runnos19 entp    x2,donthing
         brrne   x2,x1,rnnos19         .if not a call-dispatcher request
         entp    x1,1
         sbyts,1 x1,a_cst,x0,caldisp
         shfc    x2,x_inmcr,x0,21      .Exit if EXCH not set.
         brrge   x2,x0,runnos50
         brxeq   x0,x0,runnos6

rnnos19  entp    x0,0
         sx      x0,a_csf,0*8
         ente    x0,020(16)
         sx      x0,a_csf,1*8
         addaq   ae,a_csf,24
         sa      ae,a_csf,2*8
         monreq  mm_ei,0,runnos24
.
.   Check for FATAL NOS170 errors.  Stop running 170 if fatal
.   errors occured.
.
runnos20 lbyts,1 x2,a_innosx,x0,xpvmid .Check whether 170 or 180 mode.
         brxeq   x2,x0,runnos21        .Jump if 180 mode.  .
         lx      x2,a_innosx,6*8       .Get exit mode halt bit from NOS XP
         shfx    x2,x2,x0,31
runnos21 ente    x1,0DB4C(16)          .Check for fatal 170 MCR
         andx    x1,x_inmcr
         brxgt   x0,x2,runnos22        .Jump if exit mode halt is set and 170.
         brreq   x1,x0,runnos30        .Jump if no fatal 170 errors
runnos22 entp    x0,2
         sx      x0,a_csf,0
         sx      x1,a_csf,1*8
         addaq   ae,a_csf,24
         sa      ae,a_csf,2*8
         monreq  mm_ei
.
runnos24 sa      a_cst,a_csf,10        .Restore CST_P in p-list.
         lbyts,1 x2,a_csf,X0,24
         brreq   x2,x0,runnos30        .if not a fatal nos error
         shfx    x1,x_inmcr,x0,-15     .Store termination status -
         incx    x1,1                  . 2=DUE, 1=other
         sbyts,1 x1,a_root,x0,os_terms
         entl    x0,0                  .Clear dual state flag.
         sbyts,4 x0,a_cst,x0,dualstat  .Stop running NOS170.
         lbyts,1 x1,a_cst,x0,lpid8     .Clear 170 priority.
         sbyts,2 x0,a_dscb,x1,np170pr
         monreq  mon_smu,0,runnos50    .Process change in 170 status
                                       . (may not return if dual state mandatory)
.
.   Check if it is time to run 180.  If not, exchange back to 170.
.   If 180 needs the CPU and NOS170 is in job mode, it's OK to switch to 180.
.
runnos30 lx      x2,a_cst,discntl .Check if dispat should be called
         brxeq   x2,x0,runnos6
.
.   Its time to run 180 again. If NOS170 is in 170 job mode or in EI as
.  a result of a call from job mode, its ok to exit. Otherwise, set 180
.  priority to a high value and return to NOS170. It should give up control
.  quickly.
.
         shfc    x2,x_inmcr,x0,21      .Cant exit if EXCH is set in 170 XP.
         brrgt   x0,x2,runnos35        .Jump if EXCH is set.
         lbyts,1 x2,a_innosx,x0,xpvmid .Get 170 mode VMID.
         lx      xd,a_innosx,xpucr     .Get word that contains monitor flag.
         brxne   x2,x0,runnos32         .Jump if in 170 mode.
         la      ae,a_innosx,2*8+8+2   .get pointer to stack frame save area
         lx      xd,ae,xpucr           .Get monitor flag from save area.
runnos32 shfc    xd,xd,x0,31           .Move monitor flag to bit 0.
         brxge   xd,x0,runnos50        .Jump if ok to exit from 170.
.
runnos35 lbyts,1 x1,a_cst,x0,lpid8     .Cant exit. Raise 180 priority.
         ente    x2,708(16)
         sbyts,2 x2,a_dscb,x1,np180pr
         brxeq   x0,x0,runnos6
.
.
.   End of EXCH loop.
.
runnos50 entp    x0,0                  .Get current time
         lx      x2,a_root,nostime     .Update total NOS cpu time
         cpytx   x1,x0
         sx      x1,a_root,nosexit
         subx    x1,x_infrc
         addx    x2,x1
         lbyts,1 xe,a_cst,x0,dsprior   .Get 180 priority to determine if idle
         sx      x2,a_root,nostime
         brxne   xe,x0,runnos55        .Jump if 180 was not idle
         lx      x2,a_root,nostime+8   .Get total NOS cpu time.ve_idle
         addx    x2,x1
         sx      x2,a_root,nostime+8   .Update total NOS cpu time.ve_idle
runnos55 lx      x1,a_cst,xcbrma
         entl    x0,r_jps              .Reset JPS
         cpyxs   x1,x0
runexit  brdir   a_inret,x0            .Return to where called from
         page
..............................................................................
.  EXTERNAL INTERRUPT PROCESSOR
.        entry conditions:
.           a_extret - return address
..............................................................................
.
extrq    lx      x1,a_root,multpro
         brxeq   x1,x0,extrq5          .Jump if not multiprocessor
         lx      x1,a_root,cpu1nos     .See if decicated system
         brreq   x1,x0,extrq12         .Not dedicated
.
.                                      .Dedicated NOS CPU special code follows.
.
.                                      .Purge cache and return on external
.                                      .interrupts from dedicated processor.


         la      ae,a_root,eicb        .EI control block pointer
         ente    x0,6                  .Position of interrupt flag
         lbit    xe,ae,0,x0
         brreq   xe,x0,extrq12         .Interrupt is not CPU 1
         ente    xe,0
         sbit    xe,ae,0,x0            .Clear the cache purge flag in EICB
         cpytx   x0,x2                 .Free running clock
         purge   x0,2                  .Purge cache
         sx      x0,a_cst,cachtim      .Store cache purge time
         brdir    a_extret,x0          .dont do any more with dedicated CPU.
.
extrq12  bss     0
         entp    x2,0
         entl    x0,tsk_sw
         lx      x1,a_cst,ext_int
         shfc    x1,x1,x0,tsk_sw
         brxge   x1,x0,extrq1          .Jump if no task switch
         sbit    x2,a_cst,ext_int,x0
         entl    x0,1
         sbyts,1 x0,a_cst,x0,caldisp   .Set task switch flag
extrq1   entl    x0,pur_ca
         shfc    x1,x1,x0,pur_ca-tsk_sw+64
         brxge   x1,x0,extrq2          .Jump if cache purge not needed
         sbit    x2,a_cst,ext_int,x0
         cpytx   x0,x2                 .Free running clock
         purge   x0,2                  .Purge cache
         sx      x0,a_cst,cachtim
extrq2   entl    x0,pur_map
         shfc    x1,x1,x0,pur_map-pur_ca+64
         brxge   x1,x0,extrq3          .Jump if map purge not needed
         sbit    x2,a_cst,ext_int,x0
         cpytx   x0,x2                 .Free running clock
         purge   x0,15                 .Purge map
         sx      x0,a_cst,maptim
extrq3   entl    x0,step_pr
         shfc    x1,x1,x0,step_pr-pur_map+64
         brxge   x1,x0,extrq4          .Jump if no error halt
         entl    x0,1
         sbyts,1 x0,a_cst,x0,caldisp   .Call dispatcher to process STEP
extrq4   lbyts,1 x1,a_cst,x0,memport   .Dont check IO completions if
         lbyts,1 x2,a_root,x0,intport  . IOU doesnt send them to this CPU.
         brxne   x1,x2,extrqx
extrq5   la      ae,a_root,pextiou
         lx      x1,ae,0               .Exit if no external interrupts
         brxeq   x1,x0,extrq6          . have been sent by IOU.
         entl    x0,1
         sx      x0,a_root,eiflag      .Set flag that ext interrupt.
         sx      x0,a_root,asyntime
         sbyts,1 x0,a_cst,x0,asyncp
extrq6   la      ae,a_root,dpv$scd_block_p
         addaq   ae,ae,4
         entp    x0,0
         lbset   x1,ae,x0
         brrne   x1,x0,extrq7          .If SCD block not updated
         monreq  ascii_kb
.
extrq7   entl    x0,r_eid              .Get EID.
         cpysx   x1,x0
         isob    x1,x1,x0,(40*64+7)    .High order 7 bits of model number from
                                       . element id.
         ente    x2,46(16)             .CYBER 2000 Model 46
         brreq   x1,x2,thetasit
         incx    x2,2                  .CYBER 2000 Model 48
         brreq   x1,x2,thetasit
.
extrqx   brdir   a_extret,x0
.
thetasit entl    x0,r_sit              .Get the current SIT value
         cpysx   x1,x0
         brrgt   x1,x0,extrqx          .If not negative, jump to exit
         lx      x1,a_root,sitvalue    .Reset SIT.
         entl    x0,r_sit
         cpyxs   x1,x0
         brxeq   x0,x0,extrqx
         page
..............................................................................
.
.        MTP$IDLE_180  routine to idle 180.
.
.        This routine is called to put 180 into an idle state. Only
.        the system console is kept alive and only the monitor window
.        will respond to commands. If dual state is present, 180 will idle
.        and give control to NOS/NOS-BE. Depending on why the system idled,
.        the system may be able to be resumed via a RESUME_SYSTEM command.
.
.            mtp$idle_180 (resume_permitted: boolean)
.
..............................................................................
         align     0,8
idle180  ALIAS     MTP$IDLE_180
idle180  procedur
idleres  param     val,subrange,1
.
         ploadx    x_resume,idleres            .Load RESUME_ALLOWED - A4
.                                                gets clobbered later.
         la        a_root,a_bindin,bs_root

.                                              .Disable the dedicated NOS flag
i1801    la        a_dscb,a_root,nostab
         addaq     a0,a0,mstkfram
         entl      x0,r_pit                    .Save PIT - dont charge current task
         cpysx     x_clock,x0                  . for idle time.
         ente      x0,r_bc
         cpysx     x1,x0                       .Get  base constant.
         cpyax     x2,a_root
         addx      x1,x2                       .Form pointer to cst
         cpyxa     a_cst,x1
         sa        a_cst,a_csf,10              .Save CST_P in p-list.
.
         traktef   1                           .Enable TEF mask bit
         entl      x0,r_te                     .Enable traps in case we got here via
         cpyxs     x0,x0                       . trap handler.
.
i180a    entp      xe,0                        .Set 180 priority to 0.
         addpxq    a_inret,x0,i180c            .Run NOS170 if it is present. (If not
         brreq     x0,x0,run_nos               .  present RUNNOS returns immediately.)
i180c    bss       0
         entp      x0,0                        .Set lock for calling
         addaq     af,a_root,asylocki          .  mtp$monitor_system_status.
         lbset     x1,af,x0
         brrgt     x1,x0,i180f                 .Jump if already locked.
         la        ae,a_root,mtvdftb           .Fetch pointer to DFT block.
         lx        x1,ae,dftcw                 .Get DFT control word.
         shfx      x1,x1,x0,62                 .Check E8 field.
         brxge     x1,x0,i180e                 .Jump if not set.
         ente      x0,00ff(16)
         addaq     ae,a_bindin,16*proc_dft     .Set up call to dsp$process_dft_block.
         callseg   bs_rqtbl,ae,a0              .Call dsp$process_dft_block.
i180e    bss       0
         ente      x0,00ff(16)
         addaq     ae,a_bindin,16*mon_smu
         callseg   bs_rqtbl,ae,a0              .Call mtp$monitor_system_status.
         entp      x0,0                        .Clear call environment.
         sbyts,1   x0,af,x0,0                  .Clear lock.
i180f    bss       0
         brcr      2,0,i180g                   .Clear shortwarning from MCR.
i180g    lbyts,1   x1,a_root,x0,scb+scbstepr   .Loop if STEP still requested.
         brrne     x1,x0,i180a
         brxeq     x_resume,x0,i180a           .Loop if resume not permitted.
.
         entl      x0,r_pit                    .Restore PIT.
         cpyxs     x_clock,x0
         return
         page
.........................................................................
.
.   This routine is called from cybil to send interrupts to other processors.
.
.      PROCEDURE [XREF] mtp$interrupt_processor (port_mask: 0..255)
.
.........................................................................
.
int     alias    MTP$INTERRUPT_PROCESSOR
int     procedur
intmask param    val,subrange,1
        ploadx   x2,intmask
        intrupt  x2,0
        return
        page
........................................................................
.
.   MTP$SPIN_CPU
.      Routine to make a CPU spin in a tight loop indefinitely.
.
.   This routine is called by a CPU which is about to be deconfigured
.   out of the system due to hardware errors or an operator request.
.   The CPU spins in a very tight loop, only checking whether it should
.   continue to spin.  The intent is to have the CPU executing as little
.   as possible before it is completely removed from the system
.   configuration.  The CPU is expected to be executing this portion of
.   code when Dedicated Fault Tolerance (DFT) stops a CPU which has been
.   operational.  The boolean indicating whether or not the CPU should
.   continue to spin will be changed asynchronously by another CPU.
.
.   PROCEDURE mtp$spin_cpu;
.
........................................................................
         align     0,8
spin_cpu ALIAS   mtp$spin_cpu
spin_cpu procedur
cpu_id   param   val,subrange,1
.
         la      a_root,a_bindin,bs_root
.
         ente    x0,r_bc
         cpysx   x1,x0                 .Get the base constant
         cpyax   x2,a_root
         addx    x1,x2                 .Form a pointer to the CST
         cpyxa   a_cst,x1
.
. Place the CPU into a spin, during which time it performs no useful system
. operations except purging its cache and maps.  The CPU will be downed in
. the MRT after this point and therefore will never return to be used
. in the system.
.
spin_1   purge   x0,2                  .purge cache
         purge   x0,15                 .purge map
         brxeq   x0,x0,spin_1          .Spin
.
. The CPU should never reach the following statements.
.
         entp    x_infrc,0             .Get current time
         cpytx   x_infrc,x_infrc
         sx      x1,a_cst,cachtim      .Store time of last purge for cache
         sx      x1,a_cst,maptim       .Store time of last purge for maps
         entl    x0,r_pit              .Restore the PIT
         cpyxs   x_clock,x0
         return
        page
..............................................................................

. The following is the definition of the oss$mainframe_wired_cb section.
. It will ALWAYS be cache bypass
..............................................................................
.
oss$mainframe_wired_cb  SECTION working,read+write
         use     oss$mainframe_wired_cb
osv$mainframe_wired_cb_heap  vfd,16,32    0ffff(16),080000000(16)   .Pointer to heap
         defg    osv$mainframe_wired_cb_heap
.
.        The following is the definition of the communication block to
.        talk to the NOS/VE ascii console.
.
         align   0,8
asciiblk bss     0                     .ascii console communications block
         vfd,8   0                     .input buffer id
         vfd,8,8,8 0,0,0               .character buffer
         vfd,32  0                     .rma of last output entry processed
         vfd,8   0                     .console driver command
         vfd,8   0                     .hold display flag
         vfd,8   0                     .echo line size
         vfd,8   0                     .undefined
         vfd,32  0                     .rma of output list
.
         align   0,8
extiou   vfd,64  1                     .IOU sets this word non-zero when
                                       . sending external interrupt.
dpv$scd_time  vfd,64 0

         align   0,16
a170_xp  bssz    xpsize
a170_st  bssz    a170_stl*8
.
.      Set up the NOS XP.
.
.  Initialize the NOS170 Exchange Package
.
.
         ref     mtp$170_trap_handler
a170xpin bss     0
         xpa     a170_xp,2,mtp$170_trap_handler
         xpareg  a170_xp,a_tos,nil
         xpareg  a170_xp,a_csf,nil
         xpareg  a170_xp,a_psa,nil
         xpv     a170_xp,a_bindin*8+10,01000(16)+snsf170,16
         xpareg  a170_xp,a_plist,nil
         xpareg  a170_xp,5,nil
         xpareg  a170_xp,6,nil
         xpareg  a170_xp,7,nil
         xpareg  a170_xp,8,nil
         xpareg  a170_xp,9,nil
         xpareg  a170_xp,10,nil
         xpareg  a170_xp,11,nil
         xpareg  a170_xp,12,nil
         xpareg  a170_xp,13,nil
         xpareg  a170_xp,14,nil
         xpareg  a170_xp,15,nil
         xpv     a170_xp,xpstl,a170_stl,16
         xpv     a170_xp,xpmm,0fbfc(16),16
         xpv     a170_xp,xpum,0ff7f(16),16
         xpv     a170_xp,xpkm,0ffff(16),16
         xpv     a170_xp,xppit,0000f(16),16
         xpv     a170_xp,xppit+8,04240(16),16
         xpv     a170_xp,xplrn,1,16
         xpv     a170_xp,xpflgte,00002(16),16
.
         org     a170_st+snnos170*8
         vfd,64  09a11ffff00000000(16) .STE for NOS
         org     a170_st+snsf170*8
         vfd,64  00000000000000000(16) .STE for NOS stack
         org       a170_st+snnth170*8
         vfd,64  0be11800100000000(16) .STE for NOS trap handler
         org     a170xpin
         end     begin


*DECK DECK=MTM$PROCESSOR_CONFIGURATION_MGR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'MTM$PROCESSOR_CONFIGURATION_MGR: Software reconfiguration of Central Processing Units' ??
MODULE mtm$processor_configuration_mgr;

{ PURPOSE:
{   The purpose of this module is to provide the software interfaces necessary to reconfigure a Central
{   Processing Unit (CPU) in a 180 mainframe.  These interfaces provide the following capabilities:
{     . Deconfiguration of a CPU from an ON state to a DOWN state without interrupting the system if there are
{       multiple CPUs running on the mainframe.
{     . A check of the system for a CPU which has been halted due to an error in the CPU which has been
{       detected by Dedicated Fault Tolerance (DFT).
{     . A check of the system for a CPU which has timed out; i.e. has not done any useful work in the
{       recent past.
{     . Reconfiguration of a CPU which is DOWN to an ON state without system interruption.
{
{ DESIGN:
{   This module was developed in response to DAP ARH7896: DISABLE_FAILING_CPU.  It was updated for the
{   feature CPU_REINSTATEMENT (Design Direction A9154).  For DISABLE_FAILING_CPU, the procedures are called
{   in the following manner:
{
{   - DFT processing:
{     If Dedicated Fault Tolerance detects a fatal cpu condition such as a halted CPU, it will inform the
{     system (using the logging interfaces via the SCB and the CST) of the "dead" CPU.  Another "live" CPU
{     will process the entire deconfiguration.
{
{   - DUE processing:
{     If the system detects a Detected Uncorrected Error (DUE), the CPU with the DUE puts itself in a "quiet"
{     state, and another CPU attempts to reconfigure the failing CPU out of the configuration.
{
{   - CPU timeout processing:
{     If a CPU has timed out without DFT noticing this fact, another "live" CPU will eventually discover that
{     the "dead" CPU is no longer updating a timestamp in the "dead" CPU's CST.  A "live" CPU will process the
{     entire deconfiguration.
{
{   - LCU command processing:
{     If the system operator has entered a command to DOWN a CPU element via LCU, the CPU which is targeted
{     will attempt to process part of its own deconfiguration by checking whether or not it is safe to do so.
{     A "live" CPU will finish the deconfiguration processing.
{
{   If a "live" CPU must process the entire deconfiguration (as in DUE, DFT, and Timeout processing), it
{   checks to see if the CPU deconfiguration is safe.  If the deconfiguration can be performed, the "live"
{   CPU changes system tables (such as the CPU state table) to reflect the loss of the CPU.  The live CPU then
{   informs the system job monitor task to finish the deconfiguration in job mode.  If the deconfiguration
{   cannot be performed, the system will perform either a system STEP or a system IDLE, depending on the
{   severity of the CPU failure.
{
{   If a CPU must process the "back-end" of another CPU's deconfiguration (as in LCU processing), the "live"
{   CPU changes system tables (such as the CPU state table) to reflect the loss of the CPU.  The CPU then
{   informs the system job monitor task to finish the deconfiguration in job mode.
{
{   For CPU_REINSTATEMENT, the processing is essentially the reverse of the LCU method of DISABLE_FAILING_CPU.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dst$signal_contents
*copyc dst$system_logging_types
*copyc dst$cpu_attributes
*copyc mtt$monitor_xp_slot_pointers
*copyc osc$monitor_stack_mult
*copyc osc$processor_defined_registers
*copyc oss$mainframe_wired_literal
*copyc oss$mainframe_wired
*copyc ost$170_os_type
*copyc ost$exchange_package
*copyc ost$monitor_stack
*copyc ost$processor_id
*copyc syc$monitor_request_codes
*copyc syt$monitor_flag
*copyc syt$monitor_status
*copyc tmt$mcr_faults
?? POP ??
*copyc dsp$get_cpu_attributes
*copyc dpp$change_sci_interrupt_port
*copyc dpp$display_error
*copyc i#mtr_disable_traps
*copyc i#program_error
*copyc i#real_memory_address
*copyc mtp$abort_task_with_due
*copyc mtp$cst_p
*copyc mtp$error_stop
*copyc mtp$get_date_time_at_timestamp
*copyc mtp$record_critical_hdw_status
*copyc mtp$spin_cpu
*copyc mtp$step_unstep_system
*copyc mtp$store_informative_message
*copyc osp$alert_keyp_cpu_state_chng
*copyc tmp$change_tasks_170_cp_selects
*copyc tmp$send_signal
*copyc tmp$set_monitor_flag
*copyc tmp$switch_task_from_failing_cp
*copyc tmp$update_job_task_cpu_selects
?? EJECT ??
*copyc dpv$lock
*copyc dsv$boot_control_table_p
*copyc dsv$mainframe_type
*IF $variable(mmv$test_forced_use_cache_maps, declared) <> 'UNKNOWN'
*copyc mmv$force_use_of_cache_and_maps
*ELSE
{ -------- Declarations for forcing the use of cache and maps omitted at compile time --------
*IFEND
*copyc mmv$multiple_caches
*copyc mmv$multiple_page_maps
*copyc mtv$cst0
*copyc mtv$first_cpu_monitor_stack_p
*copyc mtv$request_interlock_table
*copyc mtv$scb
*copyc mtv$step_lock_0
*copyc mtv$step_lock_1
*copyc mtv$step_lock_2
*copyc mtv$unstep_lock_0
*copyc mtv$unstep_lock_1
*copyc mtv$unstep_lock_2
*copyc osv$cpus_logically_on
*copyc osv$cpus_physically_configured
*copyc osv$external_interrupt_selector
*copyc osv$initial_monitor_xp
*copyc osv$multiprocessor_running
*copyc syv$mandatory_dualstate
*copyc tmv$dedicate_a_cpu_to_nos
*copyc tmv$multiple_cpus_active
*copyc tmv$ptl_lock
*copyc tmv$system_job_monitor_gtid
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    c$cpu_timeout_interval = 30000000, {microseconds}
    c$monitor_stack_frame_length = 20(16);

  TYPE
    t$translate_reason_to_ascii = RECORD
      reason: string (22),
      initiator: string (21),
    RECEND;
?? EJECT ??
  { The following variable is explicitly XREF'd here to avoid the common deck's attribute of READ, because
  { this module may have to change the value of this variable.


  VAR
    osv$170_os_type: [XREF] ost$170_os_type;

  VAR
    mtv$all_cpus_have_been_started: [XDCL, #GATE] boolean := FALSE,
    mtv$dual_state_cpu_number: [XDCL, #GATE] ost$processor_id := 0,
    mtv$halt_on_cpu_timeout: [XDCL, #GATE] boolean := FALSE,
    mtv$monitor_xp_slot_pointers: [XDCL, #GATE] mtt$monitor_xp_slot_pointers := [NIL, NIL],
    mtv$operator_console_hung: [XDCL] boolean := FALSE,
    mtv$reset_all_cache_now: [XDCL, #GATE] boolean := FALSE,
    mtv$cy2000_sp_recovery: [XDCL, #GATE] boolean := FALSE,

    v$170_cpu_dedicated: boolean := FALSE,
    v$translate_reason_to_ascii: [STATIC, READ, oss$mainframe_wired_literal]
          ARRAY [ost$cpu_down_state_reason] OF t$translate_reason_to_ascii := [
          { osc$cdsr_null                   } ['                      ', '                     '],
          { osc$cdsr_downed_by_dft          } [' ERROR DETECTED BY DFT', 'Initiated by DFT     '],
          { osc$cdsr_due_threshold_exceeded } ['  TOO MANY DUES IN CPU', 'Initiated by System  '],
          { osc$cdsr_cpu_timeout            } ['  CPU DETECTED TIMEOUT', 'Initiated by System  '],
          { osc$cdsr_downed_by_operator     } ['    DOWNED BY OPERATOR', 'Initiated by Operator'],
          { osc$cdsr_downed_by_system       } ['      DOWNED BY SYSTEM', 'Initiated by System  ']],

    v$translate_state_to_ascii: [STATIC, READ, oss$mainframe_wired_literal] ARRAY [cmt$element_state] OF
          string (5) := ['n  ON', 'n OFF', ' DOWN'];

?? OLDTITLE ??
?? NEWTITLE := 'check_for_fatal_errors', EJECT ??

{ PURPOSE:
{   This procedure checks for errors which would be considered fatal to normal system operations if the
{   processor with the specified id were to meet any of the conditions listed below:
{     . TMV$PTL_LOCK set
{     . DPV$LOCK set
{     . other locks set internally by procedures which don't set the Request_Table interlock
{     . MTV$REQUEST_INTERLOCK_TABLE lock set itself
{
{   In part, this procedure checks interlock ordinals of monitor requests to see if any locks are set by the
{   processor whose ID is passed into this procedure.  If any lock is set, a fatal error is returned since the
{   system has no knowledge of how to back a CPU out of the processing it was performing when it encountered
{   conditions which cause it to be deconfigured.
{
{   The only reason that locks may be set is that a DUE occurred in monitor mode when such locks can be set.
{   The processor which is executing this code may or may not be the CPU which is being deconfigured, but it
{   cannot be the CPU in which the DUE occurred.

  PROCEDURE check_for_fatal_errors
    (    processor_id: ost$processor_id;
     VAR fatal_error: boolean;
     VAR fatal_error_message: string (*<= 71));

    VAR
      base_constant: integer,
      cst_p: ^ost$cpu_state_table,
      interlock_table_index: 0 .. mtc$maximum_il_table_index,
      message: string (71);

    fatal_error := FALSE;
    fatal_error_message := ' ';

    { Check the monitor request table interlocks and other system table locks.

    cst_p := ^mtv$cst0 [processor_id];
    base_constant := #OFFSET (cst_p);

    { Check the Primary_Task_List (PTL) lock and the system console lock.

    IF tmv$ptl_lock.id = base_constant THEN
      fatal_error := TRUE;
      fatal_error_message := 'CPU failure: damaged system tables with tables interlocked';
      RETURN;
    IFEND;

    IF dpv$lock = base_constant THEN
      fatal_error := TRUE;
      fatal_error_message := 'CPU failure: damaged system tables with tables interlocked';

      { Unfortunately, if this situation arises, the system cannot even display why it is about to crash to
      { the critical message window on the system console.  The best it can do is to display the message to
      { the top line.  There is no point in going any further; therefore, simply STEP the system and try
      { again.

      message := 'VEOS5000- xxxxxxxxxxxxxxxxxxxxxx; CPU could not be deconfigured safely ';
      message (11, 22) :=
            v$translate_reason_to_ascii [mtv$cst0 [processor_id].reason_for_current_state].reason;
      mtv$operator_console_hung := TRUE;
      mtp$record_critical_hdw_status (mtc$scb_hardware_failure_step, mtc$scb_hsa_set, message);
      mtp$step_unstep_system (syc$ic_fatal_hardware_error,
            'DPV$LOCK set while deconfiguring a CPU - system STEPPED');
    IFEND;

    IF (mtv$step_lock_0 = base_constant) OR (mtv$step_lock_1 = base_constant) OR
          (mtv$step_lock_2 = base_constant) OR (mtv$unstep_lock_0 = base_constant) OR
          (mtv$unstep_lock_1 = base_constant) OR (mtv$unstep_lock_2 = base_constant) THEN
      fatal_error := TRUE;
      fatal_error_message := 'CPU failure: damaged system tables with tables interlocked';
      RETURN;
    IFEND;

    { If there are any other locks set internally by procedures which don't set rqtable interlocks and that
    { cannot be cleared safely, return a fatal error result.  Currently the procedures which don't set the
    { rqtable interlock are:
    {   Request #   Procedure
    {       1       tmp$cycle                                uses  tmv$ptl_lock
    {       2       tmp$delay                                uses  tmv$ptl_lock
    {      19       mtp$mtr_step_unstep_system               uses:
    {                   mtv$step_lock_0,1,2, mtv$unstep_lock_0,1,2, dpv$lock
    {      22       tmp$fetch_task_statistics
    {      25       tmp$mtr_ready_task                       uses  tmv$ptl_lock
    {      26       tmp$mtr_set_system_flag                  uses  tmv$ptl_lock
    {      27       tmp$mtr_wait                             uses  tmv$ptl_lock
    {      51       tmp$switch_task                          uses  tmv$ptl_lock
    {      52       mtp$process_short_warning                uses:
    {                   mtv$step_lock_0,1,2, mtv$unstep_lock_0,1,2, dpv$lock
    {      53       mtp$monitor_system_status                uses
    {                   mtv$step_lock_0,1,2, mtv$unstep_lock_0,1,2, dpv$lock
    {      55       dpp$display_request                      uses  dpv$lock
    {      56       dpp$process_scd_block                    uses  dpv$lock
    {      59       mtp$process_due
    {      62       mtp$process_170_mtr_requests             uses:
    {                   mtv$nst_p^.dscm0.dscm_interlock (3 instruction window)
    {      65       dsp$access_logging_data
    {      66       dsp$process_dft_entry
    {      85       syp$mtr_inject_hardware_fault
    {
    { If additional procedures are added which do not set the monitor request interlock table, they should be
    { listed in the appropriate place above and the locks they reference (if any) should be checked in this
    { procedure.

    FOR interlock_table_index := LOWERBOUND (mtv$request_interlock_table) TO
         UPPERBOUND (mtv$request_interlock_table) DO
      IF (mtv$request_interlock_table [interlock_table_index].flag <> 0) AND
            (mtv$request_interlock_table [interlock_table_index].locking_cpu = cst_p) THEN
        fatal_error := TRUE;
        fatal_error_message := 'CPU failure: damaged system tables';
        RETURN;
      IFEND;
    FOREND;

  PROCEND check_for_fatal_errors;
?? OLDTITLE ??
?? NEWTITLE := 'process_deconfigure_cpu', EJECT ??

{ PURPOSE:
{   This procedure determines whether or not it is permissible to deconfigure a CPU.  Permissible is defined
{   as: "does not generate a system interrupt once the CPU is removed from the configuration".  This procedure
{   checks the following conditions:
{     . The number of CPUs which are logically "on".
{     . Standalone or dualstate system.
{     . If dualstate, whether or not the 170 side is required at this site.
{     . Other possibly fatal errors (see CHECK_FOR_FATAL_ERRORS).
{   After determining whether or not it is permissible to deconfigure a CPU, this procedure either steps the
{   system, idles the system, or allows the CPU to be deconfigured.  If the CPU to be deconfigured is
{   executing this procedure, it will be put into a quiescent state and will wait for another CPU to change
{   its state in the Mainframe Reconfiguration Table (MRT).  If the CPU which is executing this code is not
{   the CPU to be deconfigured, then it is executing on behalf of a CPU which may (or may not) have been in
{   quiet state.  It is expected that, by the time execution reaches this point, the CPU which is to be
{   deconfigured is either "dead" (halted) or spinning quietly and waiting for final deconfiguration.

  PROCEDURE [XDCL] process_deconfigure_cpu
    (    cst_p: ^ost$cpu_state_table;
         cpu_state_reason: ost$cpu_down_state_reason);

    TYPE
      t$cpu_deconfiguration_result = (c$cdr_null, c$cdr_system_step, c$cdr_system_idle,
            c$cdr_deconfiguration_ok);

    VAR
      cpu_index: ost$processor_id,
      deconfiguration_result: t$cpu_deconfiguration_result,
      fatal_error: boolean,
      message: string (71),
      old_trap_enable: 0 .. 3,
      running_cst_p: ^ost$cpu_state_table;

    { If the mainframe has only one running CPU at this moment, halt the system immediately.

   IF dsv$mainframe_type <> dsc$mt_2000_mainframe THEN

{ cy2000 mainframes deconfigure after the processor has been turned down.

     IF osv$cpus_logically_on < 2 THEN
       mtp$error_stop ('Deconfigure single CPU');
     IFEND;
   IFEND;

    { If one of the following is TRUE, then it is possible that the failing CPU can be deconfigured:
    {   . Running standalone.
    {   . Running dual_state and this is NOT the CPU used by the 170 side.
    {   . Running dual_state, this is the CPU used by the 170 side, and the site has indicated that it
    {     does not need the 170 side for vital operations.

    deconfiguration_result := c$cdr_null;
    IF (osv$170_os_type = osc$ot7_none) OR (cst_p^.dual_state_jps = 0) OR (NOT syv$mandatory_dualstate) THEN
      check_for_fatal_errors (cst_p^.cst_index, fatal_error, message);
      IF fatal_error THEN
        dpp$display_error (message);
        deconfiguration_result := c$cdr_system_step;
      ELSE
        deconfiguration_result := c$cdr_deconfiguration_ok;
      IFEND;
    ELSE

      { This is a dualstate system, this is the dualstate CPU and this site needs the 170 side.  Return a
      { result that will make the system perform an IDLE_SYSTEM.

      dpp$display_error ('Fatal error: DUALSTATE CPU and MANDATORY_DUALSTATE');
      deconfiguration_result := c$cdr_system_idle;
    IFEND;

    IF (cpu_state_reason = osc$cdsr_cpu_timeout) AND mtv$halt_on_cpu_timeout THEN
      mtp$step_unstep_system (syc$ic_software_breakpoint, 'System stepped to catch timed-out CPU');
    IFEND;

    cst_p^.reason_for_current_state := cpu_state_reason;
    IF deconfiguration_result <> c$cdr_deconfiguration_ok THEN
      message := 'VEOS500x- xxxxxxxxxxxxxxxxxxxxxx; CPU could not be deconfigured safely ';
      message (11, 22) :=
            v$translate_reason_to_ascii [mtv$cst0 [cst_p^.cst_index].reason_for_current_state].reason;
      IF deconfiguration_result = c$cdr_system_step THEN
        message (8) := '0';
        mtp$record_critical_hdw_status (mtc$scb_hardware_failure_step, mtc$scb_hsa_set, message);
        mtp$step_unstep_system (syc$ic_fatal_hardware_error, message);
      ELSE {deconfiguration_result = c$cdr_system_idle}
        message (8) := '1';
        dpp$display_error ('Fatal CPU condition encountered; system IDLING.');
        mtp$record_critical_hdw_status (mtc$scb_hardware_failure_idle, mtc$scb_hsa_set, message);
      IFEND;
      RETURN;
    IFEND;

{ Flag the fact that for awhile we can't rely on the page and segment
{ maps until the processor situation has been resolved.

    mtv$reset_all_cache_now := TRUE;

    mtp$cst_p (running_cst_p);
    IF cst_p = running_cst_p THEN

      { Traps are disabled to prevent the processor from wandering off and doing anything else.  The system
      { expects the CPU to be in a very tiny loop as it is being deconfigured.

      i#mtr_disable_traps (old_trap_enable);
      reset_purge_times (cst_p);
      cst_p^.pre_processed_for_reconfig := osc$ppfr_processing_complete;
      mtp$spin_cpu;
      dpp$display_error ('MTP$SPIN_CPU returned: PROCESS_DECONFIGURE_CPU');
      WHILE TRUE DO
        i#mtr_disable_traps (old_trap_enable);
        i#program_error;
      WHILEND;

      { The CPU which is going down will never return.  A restarting CPU will begin execution at the procedure
      { MTP$BEGIN in the module MTM$MONITOR_INTERRUPT_HANDLER.

    ELSE

      { Search for the first processor which is still logically ON and use its value of the memory port
      { mask as the value of the port to which external interrupts should be sent from now on.

     /set_port/
      FOR cpu_index := 0 TO (osv$cpus_physically_configured - 1) DO
        IF (cpu_index <> cst_p^.cst_index) AND (mtv$cst0 [cpu_index].processor_state = cmc$on) THEN
          osv$external_interrupt_selector := mtv$cst0 [cpu_index].memory_port_mask;
          dpp$change_sci_interrupt_port;
          EXIT /set_port/;
        IFEND;
      FOREND /set_port/;
      cst_p^.pre_processed_for_reconfig := osc$ppfr_not_processed;
      reconfigure_cpu (cst_p^.cst_index, cmc$on, cmc$down);
    IFEND;

  PROCEND process_deconfigure_cpu;
?? OLDTITLE ??
?? NEWTITLE := 'reconfigure_cpu', EJECT ??

{ PURPOSE:
{   This procedure drives a CPU to its final state (new_state) from its initial state (old state).  This code
{   is executed by a processor which is NOT changing state; the processor which is being changed is already in
{   a state that allows this processing to complete.  This is considered the 'back-end' of CPU state change
{   processing.

  PROCEDURE [XDCL] reconfigure_cpu
    (    processor_id: ost$processor_id;
         old_state: cmt$element_state;
         new_state: cmt$element_state);

    VAR
      buffer_index: ost$processor_id,
      cpu_reconfiguration_message: string (67),
      cst_p: ^ost$cpu_state_table,
      ignore_status: syt$monitor_status,
      ijle_p: ^jmt$initiated_job_list_entry,
      operator_message: string (37),
      signal: dst$signal_contents,
      status: syt$monitor_status;

    IF new_state = cmc$on THEN

      { Update the SCB.

      mtv$scb.cpus.logically_on := mtv$scb.cpus.logically_on + $ost$processor_id_set [processor_id];
      mtv$cst0 [processor_id].dispatching_priority_integer := 0;

      { Keypoints must be turned off if they are currently active on the processor which is handling the CPU
      { state change to ON.

      osp$alert_keyp_cpu_state_chng (#READ_REGISTER (osc$pr_maintenance_id));

    ELSE {new_state = cmc$down}

      { Update the SCB.

      mtv$scb.cpus.hdw_state_change := mtv$scb.cpus.hdw_state_change - $ost$processor_id_set [processor_id];
      mtv$scb.cpus.logically_on := mtv$scb.cpus.logically_on - $ost$processor_id_set [processor_id];
      mtv$cst0 [processor_id].dispatching_priority_integer := UPPERVALUE (integer);

      { Keypoints must be turned off if they are currently active on the processor which is changing state to
      { DOWN or OFF.

      osp$alert_keyp_cpu_state_chng (processor_id);
    IFEND;

    { Update the CPU state table entry for the changed CPU.

    mtv$cst0 [processor_id].processor_state := new_state;

    { Update the boolean which indicates whether any CPU has vector divide capability.

    mtv$scb.vector_simulation_control.all_vector_divides_degraded := (mtv$scb.cpus.logically_on -
          mtv$scb.vector_simulation_control.vector_divide_degraded) = $ost$processor_id_set [];

    { Increment/decrement the number of CPUs which are logically 'on' and which are physically configured.

    IF (new_state = cmc$on) AND (old_state = cmc$down) THEN
      osv$cpus_logically_on := osv$cpus_logically_on + 1;

      { TMV$MULTIPLE_CPUS_ACTIVE is the variable used to prevent any harmful system effects from a site
      { setting DEDICATE_A_CPU_TO_NOS TRUE and only having one cpu present.  The SETSA mechanism is not
      { smart enough to detect when this would be a harmful action.

      tmv$multiple_cpus_active := TRUE;

      { If this is a dual state system and the dual state CPU is being reconfigured (mandatory_dualstate
      { equals FALSE, which is absolutely TRUE because we have gotten this far), DO NOT adjust the value of
      { the 170 OS type to allow DFT to use 170 to process its requests.  The 170 state will not run, even
      { though the dualstate CPU is being reinstated.

      reinitialize_cpu_mtr_xp (processor_id);
      mtv$cst0 [processor_id].reason_for_current_state := osc$cdsr_null;

    ELSEIF (new_state = cmc$down) AND (old_state = cmc$on) THEN

      { Remove the 'downed' CPU selection for all tasks in the system.

      tmp$update_job_task_cpu_selects;

      { The following code attempts to resurrect a task which was executing on a failing CPU.  Check to see if
      { the CPU was being deconfigured because a DUE occurred AND the process was damaged, or the task was
      { processing a system call.  If it was, send a monitor fault and attempt to switch the task to a
      { non-failing processor.  If it wasn't, switch the task to a non-failing processor.

      cst_p := ^mtv$cst0 [processor_id];
      IF cst_p^.xcb_p <> NIL THEN
        IF ((osc$detected_uncorrected_err IN cst_p^.xcb_p^.xp.monitor_condition_register) AND
              NOT (osc$process_not_damaged IN cst_p^.xcb_p^.xp.flags)) OR
             (osc$system_call IN cst_p^.xcb_p^.xp.monitor_condition_register) THEN
          mtp$abort_task_with_due (cst_p, cst_p^.xcb_p);
        IFEND;
        tmp$switch_task_from_failing_cp (cst_p);
      ELSEIF cst_p^.next_ptlo_to_dispatch <> 0 THEN
        tmp$switch_task_from_failing_cp (cst_p);
      IFEND;

      osv$cpus_logically_on := osv$cpus_logically_on - 1;

      { The following check is not sufficient if there are more than 2 cpus available to a system.
      { TMV$MULTIPLE_CPUS_ACTIVE is the variable used to prevent any harmful system effects from a site
      { setting DEDICATE_A_CPU_TO_NOS TRUE and only having one cpu present. The SETSA mechanism is not smart
      { enough to detect when this would be a harmful action.

      IF osv$cpus_logically_on = 1 THEN
        tmv$multiple_cpus_active := FALSE;
      IFEND;

      { If this is a dual state system and the dual state CPU is being deconfigured (mandatory_dualstate
      { equals FALSE which is absolutely TRUE because we have gotten this far), adjust the value of the 170 OS
      { type to prevent the OS from using a nonexistent 170 to process DFT requests.

      IF mtv$cst0 [processor_id].dual_state_jps <> 0 THEN
        osv$170_os_type := osc$ot7_none;
      IFEND;

      IF (osv$cpus_logically_on = 1) AND (mtv$cst0 [processor_id].dual_state_jps <> 0) AND
            tmv$dedicate_a_cpu_to_nos THEN
        tmv$dedicate_a_cpu_to_nos := FALSE;
        dpp$display_error ('Dualstate CPU is no longer dedicated to 170 state');
      IFEND;

      { Reset the values for the 'cache purged' and/or 'page map purged' times for the deconfigured CPU.
      { This prevents other CPUs from hanging up waiting for the deconfigured CPU to purge its cache and/or
      { page maps.

      reset_purge_times (^mtv$cst0 [processor_id]);

      CASE mtv$cst0 [processor_id].reason_for_current_state OF
      = osc$cdsr_downed_by_dft, osc$cdsr_due_threshold_exceeded, osc$cdsr_cpu_timeout =
        signal.identifier := dsc$deadstart_signal;
        signal.contents.kind := dsc$signal_post_operator_action;
        mtp$get_date_time_at_timestamp (#FREE_RUNNING_CLOCK (0), signal.contents.poa_data.date_time);
        signal.contents.poa_data.kind := dsc$signal_poa_cpu_down_by_sys;
        tmp$send_signal (tmv$system_job_monitor_gtid, signal.signal, ignore_status);
      ELSE
      CASEND;

      { Reset the values representing how cache and/or page maps should be purged.

      IF osv$cpus_logically_on = 1 THEN
        osv$multiprocessor_running := FALSE;
        mmv$multiple_caches := FALSE;
        mmv$multiple_page_maps := FALSE;

*IF $variable(mmv$test_forced_use_cache_maps, declared) <> 'UNKNOWN'

        { The following code is benchmark code to force use of cache and/or maps during benchmark runs.

        mmv$multiple_caches := mmv$multiple_caches OR mmv$force_use_of_cache_and_maps;
        mmv$multiple_page_maps := mmv$multiple_page_maps OR mmv$force_use_of_cache_and_maps;

*ELSE
{ -------- Code for forcing the use of cache and maps omitted at compile time --------
*IFEND
      IFEND;

    IFEND;

    { Notify the operator of the CPU state change.

    operator_message := 'CP n STATE CHANGED FROM OOOO TO NNNN ';
    operator_message (4) := $CHAR (processor_id + $INTEGER ('0'));
    operator_message (25, 4) := v$translate_state_to_ascii [old_state] (2, 4);
    operator_message (33, 4) := v$translate_state_to_ascii [new_state] (2, 4);
    dpp$display_error (operator_message);
    operator_message :=
          v$translate_reason_to_ascii [mtv$cst0 [processor_id].reason_for_current_state].initiator;
    IF operator_message <> ' ' THEN
      dpp$display_error (operator_message);
    IFEND;

    { Log a CM1800 engineering statistic detailing that the CPU was reconfigured.

    cpu_reconfiguration_message := 'CPU n was placed in aNNNNN condition';
    cpu_reconfiguration_message (5) := $CHAR (processor_id + $INTEGER ('0'));
    cpu_reconfiguration_message (22, 5) := v$translate_state_to_ascii [new_state];
    IF v$translate_reason_to_ascii [mtv$cst0 [processor_id].reason_for_current_state].reason = ' ' THEN
      cpu_reconfiguration_message (37) := '.';
    ELSE
      cpu_reconfiguration_message (37, 8) := ' due to ';
      cpu_reconfiguration_message (45, 22) :=
            v$translate_reason_to_ascii [mtv$cst0 [processor_id].reason_for_current_state].reason;
    IFEND;
    mtp$store_informative_message (cpu_reconfiguration_message);

    { Tell job-mode about the state change.

    mtv$cst0 [processor_id].log_cpu_state_change := TRUE;

{ Enable normal cache management.

    mtv$reset_all_cache_now := FALSE;

    { Set a system flag to log the data and change the MRT from job mode.

    tmp$set_monitor_flag (tmv$system_job_monitor_gtid, syc$mf_cpu_configuration_change, status);
    IF NOT status.normal THEN
      mtp$error_stop ('MT - unable to set MTR flag for job_mode CPU reconfiguration');
    IFEND;

  PROCEND reconfigure_cpu;
?? OLDTITLE ??
?? NEWTITLE := 'reinitialize_cpu_mtr_xp', EJECT ??

{ PURPOSE:
{   This procedure reinitializes the monitor exchange package for a CPU which is about to be reconfigured to
{   an ON state in order that the CPU can execute "cleanly" in monitor when it restarts.  The processor id
{   input parameter specifies the logical processor number of the CPU which is to be restarted.  The deck,
{   sya$constants defines where the first CPU used has the beginning of its stack.  The offset takes into
{   account the fact that the monitor segment table is located right after the monitor exchange package
{   of the first CPU used; all other CPUs use this same monitor segment table.  When reinstating the first
{   CPU used, its exchange package must be reinitialized to have A0 (csf) point to AFTER the monitor segment
{   table.  Otherwise, the moment the first CPU used begins to re-execute, it will bash the segment table
{   entry for mainframe-wired, all the CPUs will page fault for data in mainframe-wired (normally impossible),
{   and the system will halt.

  PROCEDURE reinitialize_cpu_mtr_xp
    (    restarted_cpu_id: ost$processor_id);

    VAR
      rma_slot_1: integer,
      rma_slot_2: integer,
      running_cpu_id: ost$processor_id,
      stack_p: ^ost$monitor_stack;

    { Retrieve all possible locations for the monitor exchange package that this processor could use.

    i#real_memory_address (mtv$monitor_xp_slot_pointers.slot_1_p, rma_slot_1);
    i#real_memory_address (mtv$monitor_xp_slot_pointers.slot_2_p, rma_slot_2);

    { Determine the running CPU id.

    IF restarted_cpu_id = 0 THEN
      running_cpu_id := 1;
    ELSE
      running_cpu_id := 0;
    IFEND;

    { Determine which monitor exchange package location the running CPU is using and use the other
    { monitor exchange package location for the processor being restarted.

    IF mtv$cst0 [running_cpu_id].monitor_mps = rma_slot_1 THEN
      mtv$cst0 [restarted_cpu_id].monitor_mps := rma_slot_2;
      stack_p := mtv$monitor_xp_slot_pointers.slot_2_p;
      stack_p^.xp := osv$initial_monitor_xp;
      stack_p^.xp.a1_current_stack_frame := ^stack_p^.stack;
      stack_p^.xp.a0_dynamic_space_pointer := ^stack_p^.csf;
    ELSE
      mtv$cst0 [restarted_cpu_id].monitor_mps := rma_slot_1;
      stack_p := mtv$monitor_xp_slot_pointers.slot_1_p;
      stack_p^.xp := osv$initial_monitor_xp;
      stack_p^.xp.a1_current_stack_frame := mtv$first_cpu_monitor_stack_p;
      stack_p^.xp.a0_dynamic_space_pointer := #ADDRESS (#RING (mtv$first_cpu_monitor_stack_p),
            #SEGMENT (mtv$first_cpu_monitor_stack_p), #OFFSET (mtv$first_cpu_monitor_stack_p) +
            c$monitor_stack_frame_length);
    IFEND;

    stack_p^.xp.tos_registers [1].pva.ring := #RING (^stack_p^.stack);
    stack_p^.xp.tos_registers [1].pva.seg := #SEGMENT (^stack_p^.stack);
    stack_p^.xp.tos_registers [1].pva.offset := #OFFSET (^stack_p^.stack);
    #SPOIL (stack_p^);

  PROCEND reinitialize_cpu_mtr_xp;
?? OLDTITLE ??
?? NEWTITLE := 'reset_purge_times', EJECT ??

{ PURPOSE:
{   This procedure is necessary to prevent other cpus from hanging up waiting for the deconfigured CPU to
{   purge its cache and/or page maps.  With the use of the value 'very distant future', the CPU is essentially
{   telling all of the other CPUs that it has already purged its cache and/or page maps when it is asked to do
{   so.  If there is not already a 'witty' flag indicating a dead CPU set during multiple CPU cache and/or map
{   purges,  store a very large number.

  PROCEDURE reset_purge_times
    (    cst_p: ^ost$cpu_state_table);

    CONST
      c$very_distant_future = 7fffffffffffffff(16);

    IF cst_p^.time_last_cache_purge < #FREE_RUNNING_CLOCK (0) THEN
      cst_p^.time_last_cache_purge := c$very_distant_future;
    IFEND;
    IF cst_p^.time_last_map_request < #FREE_RUNNING_CLOCK (0) THEN
      cst_p^.time_last_map_request := c$very_distant_future;
    IFEND;

  PROCEND reset_purge_times;
?? OLDTITLE ??
?? NEWTITLE := 'mtp$deconfigure_divide_unit', EJECT ??

{ PURPOSE:
{   This procedure is called to update the status of the vector divide units when DFT deconfigures a divide
{   net due to a hardware failure. Processors (theta) cannot execute vector divide instructions on processors
{   with degraded divide units.

  PROCEDURE [XDCL] mtp$deconfigure_divide_unit
    (    processor_id: ost$processor_id);

    mtv$scb.vector_simulation_control.vector_divide_degraded :=
          mtv$scb.vector_simulation_control.vector_divide_degraded + $ost$processor_id_set [processor_id];
    mtv$scb.vector_simulation_control.all_vector_divides_degraded := (mtv$scb.cpus.logically_on -
          mtv$scb.vector_simulation_control.vector_divide_degraded) = $ost$processor_id_set [];

  PROCEND mtp$deconfigure_divide_unit;
?? OLDTITLE ??
?? NEWTITLE := 'mtp$manage_processor_with_due', EJECT ??

{ PURPOSE:
{   This procedure determines whether or not it is safe to continue with a deconfiguration for a CPU which has
{   encountered a fatal detected uncorrected error (DUE).  If there is more than one CPU which is logically on
{   in the system, the CPU which is executing this code (which has encountered the DUE) will 'wait' by calling
{   MTP$SPIN_CPU and allow the system to attempt to deconfigure it.

  PROCEDURE [XDCL] mtp$manage_processor_with_due
    (    processor_id: ost$processor_id);

    VAR
      cpu_index: ost$processor_id,
      cst_p: ^ost$cpu_state_table,
      old_trap_enable: 0 .. 3;

    IF osv$cpus_logically_on > 1 THEN
      i#mtr_disable_traps (old_trap_enable);
      cst_p := ^mtv$cst0 [processor_id];
      cst_p^.next_processor_state := cmc$down;
      cst_p^.reason_for_current_state := osc$cdsr_due_threshold_exceeded;
      reset_purge_times (cst_p);
      mtp$spin_cpu;
      dpp$display_error ('MTP$SPIN_CPU returned: MTP$MANAGE_PROCESSOR_WITH_DUE');
      WHILE TRUE DO
        i#mtr_disable_traps (old_trap_enable);
        i#program_error;
      WHILEND;
    ELSE
      mtp$record_critical_hdw_status (mtc$scb_hardware_failure_step, mtc$scb_hsa_set,
            'VEOS520E- FATAL CPU ERROR: Detected Uncorrected Error (DUE)            ');
      mtp$step_unstep_system (syc$ic_fatal_hardware_error,
            'VEOS520E- FATAL CPU ERROR: Detected Uncorrected Error (DUE)');
    IFEND

  PROCEND mtp$manage_processor_with_due;
?? OLDTITLE ??
?? NEWTITLE := 'mtp$monitor_processor_status', EJECT ??

{ PURPOSE:
{   This procedure monitors CPU states and drives any CPU with a difference between its current state and its
{   next state to the state specified in the cpu_state_table field next_processor_state.  This procedure
{   processes CPUs which change state because of an error or halt detected by Dedicated Fault Tolerance (DFT),
{   a detected uncorrected error (DUE) or timeout detected by the system, or a command invoked through the
{   Logical Configuration Utility.

  PROCEDURE [XDCL] mtp$monitor_processor_status;

    VAR
      cpu_index: ost$processor_id,
      cst_p: ^ost$cpu_state_table,
      running_cst_p: ^ost$cpu_state_table;

    IF NOT mtv$all_cpus_have_been_started THEN
      RETURN;
    IFEND;

    mtp$cst_p (running_cst_p);

    FOR cpu_index := 0 TO (osv$cpus_physically_configured - 1) DO
      cst_p := ^mtv$cst0 [cpu_index];

      { Check for a CPU which is downed by Dedicated Fault Tolerance (DFT).  Only error logging code sets the
      { flag in the SCB indicating a processor with a changed state.

      IF (cst_p^.processor_state = cmc$on) AND (cst_p^.next_processor_state = cmc$down) THEN
        IF (cst_p^.pre_processed_for_reconfig = osc$ppfr_not_processed) OR
              (cpu_index IN mtv$scb.cpus.hdw_state_change) THEN
          cst_p^.previous_processor_state := cst_p^.processor_state;
          process_deconfigure_cpu (cst_p, cst_p^.reason_for_current_state);

        ELSEIF cst_p^.pre_processed_for_reconfig = osc$ppfr_processing_complete THEN

          { The CPU has processed the "front-end" of its own deconfiguration (as a result of an LCU command),
          { and is now in a state where the "back-end" processing can take over.

          process_deconfigure_cpu (cst_p, cst_p^.reason_for_current_state);

        ELSE {cst_p^.pre_processed_for_reconfig = osc$ppfr_processing_in_progress}

          { The processor is voluntarily deconfiguring itself, and the system has caught it in the middle of
          { this processing.  Wait until its preprocessing is complete, and then catch it in the statements
          { above.

        IFEND;

      ELSEIF (cst_p <> running_cst_p) AND (cst_p^.processor_state = cmc$on) AND
            (#FREE_RUNNING_CLOCK (0) > (cst_p^.cpu_alive_flag + c$cpu_timeout_interval)) THEN

        { Check for a timed-out CPU.  This is a CPU which has not updated the CPU_ALIVE flag in its CST in
        { the recent past.

        IF NOT dsv$boot_control_table_p^.flags.cpu_error_process_in_progress OR
              (dsv$boot_control_table_p^.flags.cpu_error_process_in_progress AND
              dsv$boot_control_table_p^.flags.cpu_error_fatal_after_process) THEN
          cst_p^.previous_processor_state := cst_p^.processor_state;
          cst_p^.next_processor_state := cmc$down;
          process_deconfigure_cpu (cst_p, osc$cdsr_cpu_timeout);
        IFEND;

      ELSEIF (cst_p^.processor_state = cmc$down) AND (cst_p^.next_processor_state = cmc$on) THEN
        reconfigure_cpu (cpu_index, cmc$down, cmc$on);
      IFEND;

      IF cst_p^.dual_state_jps <> 0 THEN
        mtv$dual_state_cpu_number := cpu_index;
      IFEND;

    FOREND;

    { Each time this procedure is called it must check if the status of tmv$dedicate_a_cpu_to_nos changes
    { anything.  If the desire is to dedicate a CPU, it must first check that the CPU to dedicate is not the
    { only CPU available in the 'cpus available to use' set.

    IF (osv$cpus_logically_on = 1) OR (osv$170_os_type = osc$ot7_none) THEN
      IF tmv$dedicate_a_cpu_to_nos THEN
        IF osv$170_os_type = osc$ot7_none THEN
          dpp$display_error ('Cannot dedicate a CPU to the 170 when running in standalone 180 mode.');
        ELSE
          dpp$display_error ('Cannot dedicate the only logically ON CPU to 170.');
        IFEND;
        tmv$dedicate_a_cpu_to_nos := FALSE;
      IFEND;
    ELSEIF #READ_REGISTER (osc$pr_maintenance_id) = mtv$dual_state_cpu_number THEN
      IF NOT (mtv$scb.cpus.available_for_use = $ost$processor_id_set [mtv$dual_state_cpu_number]) THEN
        IF tmv$dedicate_a_cpu_to_nos AND NOT v$170_cpu_dedicated THEN
          v$170_cpu_dedicated := TRUE;
          osp$alert_keyp_cpu_state_chng (mtv$dual_state_cpu_number);
          tmp$change_tasks_170_cp_selects (TRUE, mtv$dual_state_cpu_number);
        ELSEIF NOT tmv$dedicate_a_cpu_to_nos AND v$170_cpu_dedicated THEN
          v$170_cpu_dedicated := FALSE;
          osp$alert_keyp_cpu_state_chng (mtv$dual_state_cpu_number);
          tmp$change_tasks_170_cp_selects (FALSE, mtv$dual_state_cpu_number);
        IFEND;
      IFEND;
    IFEND;

  PROCEND mtp$monitor_processor_status;
?? OLDTITLE ??
?? NEWTITLE := 'mtp$process_cpu_state_change', EJECT ??

{ PURPOSE:
{   This procedure is called during the monitor idle loop in mtm$monitor_interrupt_handler.  This is the only
{   way a processor will voluntarily deconfigure itself if there are no hardware problems.  This procedure
{   processes a down request by the Logical_Configuration_Utility (LCU) which is posted in the processor's
{   cpu_state_table (CST).  Only a CPU which is currently "on" will ever execute this code.

  PROCEDURE [XDCL] mtp$process_cpu_state_change
    (    dummy_p: ^cell;
         cst_p: ^ost$cpu_state_table);

    process_deconfigure_cpu (cst_p, cst_p^.reason_for_current_state);

  PROCEND mtp$process_cpu_state_change;
?? OLDTITLE ??
MODEND mtm$processor_configuration_mgr;
*DECK DECK=MTM$PROCESS_170_MTR_REQUESTS EXPAND=TRUE
mtm$process_170_mtr_requests ident
         list      1,1,0
*copy ASMREGS
*copy OSA$DUAL_STATE_CONTROL_BLOCK
*copy OSA$EI_INTERFACE_CONSTANTS
*copy osa$dual_state_170_os_stack
*copy OSA$EI_CONSTANT_DEFINITIONS
*copy OSA$CYBIL_INTERFACE
*copy sya$xp_and_sf_constants
         PAGE
......................................................................
.
.         EIMT       - VE ERR0R INTERFACE
.
.         THIS PROCEDURE PROVIDES THE MONITOR MODE INTERFACE BETWEEN
.         THE NOS/VE AND C170 OPERATING SYSTEMS FOR ERROR PROCESSING
.         ON FOR THE C170 OPERATING SYSTEM.  THIS SOFTWARE SIMULATES
.         THE EFFECTS OF HARDWARE ERRORS ON C170 HARDWARE.  THIS DECK
.
. PROCEDURE mtp$process_170_mtr_requests ( req_code : mtt$ei_request_code;
.           mcr_valu : mtt$eim_mcr_value;
.           VAR err_flag : boolean);
.
. TYPE
.   mtt$ei_request_code = (mtc$eim_system_call, mtc$eim_unused_value,
.        mtc$eim_process_uncorrected_err),
.   mtt$ei_mcr_value : 0..0ffff(16)
.
......................................................................
         def       mtp$process_170_mtr_requests
         ref       dpp$process_scd_block
         ref       mtp$idle_180
         ref       mtv$ns_xp_p
         ref       mtv$nst_p
         ref       mtv$nos_jps
         ref       osp$a170_fatal_error
         ref       osp$abort_a170_job
         use       binding             .define binding section
nos_jps  address   p,mtv$nos_jps       .nos exchange package rma
osp_afe  address   p,osp$a170_fatal_error
osp_aaj  address   p,osp$abort_a170_job
mtp_hei  address   p,stop170
nos_xp   address   p,mtv$ns_xp_p             .nos/rs exchange package
pva_dscb address   p,mtv$nst_p           .dual state interface block
mtpeim   address   ce,mtp$process_170_mtr_requests
dpppsb   address   ce,dpp$process_scd_block
bs_idle  address   ce,mtp$idle_180
.
fatalerr equ       1
noerr    equ       0
.
amacscr  areg      5
.
.
.         setup registers for ei usage.
.
         use       code
BGNEIMT  BSS       0
         align     0,8
mtp$process_170_mtr_requests   procedur
req_code param     val,subrange,1
mcr_valu param     val,subrange,2
err_flag param     ref,boolean
.
         la        a6,A_bindin,nos_xp
         la        A_jps,a6,0          .pointer to nos exchange package
         lbyts,2   x1,A_jps,x0,xp_a0   .a170 working storage ring+segment#
         shfx      x1,x1,x0,32
         cpyxa     a_wrk,x1            .ei working storage PVA in AD
         la        a_nos,a_wrk,pva_of_os
         la        a_dscb,a_wrk,pva_of_dscb
         ploadx    x6,mcr_valu         .fetch mcr value
.
         ploadx    x1,req_code         .fetch request type
.
         cpyax     x4,A_jps
         purge     x4,4                .purge cache for C170 exchange package
         lbyts,1   x4,A_jps,x0,xp_vmid   .fetch VMID
         la        a7,a_bindin,osp_afe
         ente      x2,max_req
         brrge     x1,x2,pmce1         .if invalid request
         shfx      x1,x1,x0,1
         addpxq    a8,x1,req_tble
         brdir     a8,x0               .service request
.
req_tble bss       0                   .request branch table
         brreq     x0,x0,sys_call      .process system call
         brreq     x0,x0,store_err     .store error into dscb
         brreq     x0,x0,pec00         .process fatal error
max_req  equ       3
.
.        halt for invalid entry conditions.
.
pmce1    halt
         page
.
.        exit from eimt.
.
pmc      BSS       0
         ENTP      X1,1
         SBYTS,1   X1,A_jps,X0,xp_vmid .SET A170 VMID
         ENTP      X1,2                .TE=ON, TED=OFF
         SBYTS,1   X1,A_jps,X0,xp_tef  .SET TRAP ENABLES
pmce2    BSS       0
         ENTP      X3,0                .CLEAR X3
         SBYTS,2   X3,A_jps,X0,xp_mcr  .CLEAR MCR
         SBYTS,2   X3,A_jps,X0,xp_ucr  .CLEAR UCR
         ENTE      X1,NOERR
pmce3    bss       0
         pstorxp   x1,err_flag         .set error status
         RETURN                        .RETURN TO NVE MONITOR
.
.         THE C170 VIRTUAL MACHINE WAS EXECUTING IN MONITOR MODE WHEN THE
.         EXIT CONDITION OCCURRED.  ALL C170 ERRORS OF THIS TYPE CAUSE
.         THE C170 CPU TO STOP IN STAND ALONE MODE, IN DUAL STATE JUST
.         SET FATAL ERROR STATUS IN THE CALL PARAMETER LIST.
.
.        a6 = pointer to message.
.        a_dscb = pointer to EI control block (EICB).

STOP170  BSS       0
         ENTE      X1,STP170S
         SBYTS,1   X1,A_dscb,X0,ds_stat+3 .SET FATAL C170 ERROR

.        Move the message to the EICB if the EICB level is greater than 3.

         lx        x6,a_dscb,d7ty
         ente      x1,eml              .set message length.
         isob      x6,x6,x0,52*64+5    .EICB version number.
         decx      x6,4
         brrgt     x0,x6,stop170_5     .If EICB version less than 4.

.        EICB version of 4 or greater, has space for a message in the EICB.  Move the
.        message to the EICB and set values to reflect message length and indicate
.        that there is a new message.

         cpyxx     x0,x1               .set source field length.
         movb,a6,x0  a_dscb,x1  1,9,0,0  1,9,0,dfcm+(1*8)  .move message to EICB.
         sbyts,2   x1,a_dscb,x0,dfcm+2 .set message length.

.        Update the processor and model number in the message stored in the EICB.

         entl      x0,r_pid
         entx      x1,c'C'             .processor 0 value.
         cpysx     x6,x0               .get processor number.
         entl      x0,r_eid
         addx      x6,x1               .set character for processor.
         cpysx     x0,x0               .element id.
         sbyts,1   x6,a_dscb,x0,dfcm+(1*8)+14  .update processor in message.
         isob      x6,x0,x0,(40*64)+3  .high order 4 bits of model number.
         entp      x2,9
         entx      x1,c'0'
         brrge     x2,x6,stop170_2     .if digit 0 through 9.
         decx      x6,10
         entx      x1,c'A'
stop170_2 bss      0
         addx      x6,x1               .convert digit to ascii.
         sbyts,1   x6,a_dscb,x0,dfcm+(1*8)+15  .update high order 4 bits of
                                       . model number.
         isob      x6,x0,x0,(44*64)+3  .low order 4 bits of model number.
         entx      x1,c'0'
         brrge     x2,x6,stop170_4     .if digit 0 through 9.
         decx      x6,10
         entx      x1,c'A'
stop170_4 bss      0
         addx      x6,x1               .convert digit to ascii.
         lbyts,2   x1,a_dscb,x0,dfcm+6  .set new message in EICB.
         sbyts,1   x6,a_dscb,x0,dfcm+(1*8)+16  .update low order 4 bits of
                                       . model number.
         incx      x1,1
         sbyts,2   x1,a_dscb,x0,dfcm+6 .indicate new message in EICB.
stop170_5 bss      0
         ENTE      X1,FATALERR
         BRREQ     X0,X0,pmce3         .RETURN TO NVE

eml      equ       24                  .error message length, bytes.

.        Define error message put in EICB.  The error codes, "damm" and "dabr'
.        are defined in deck cti$dft_analysis_codes.  If more messages are
.        added the codes should be added to that deck.  The fault symptom
.        code format is 'Temmxxx' with the following meaning:
.                   'T' - Environment interface (EI) identifier.
.                   'e' - Processor number, C through F.
.                   'mm' - Model number.
.                   'xxx' - Error code.

damm     vfd,eml*8  c'         ERR=Temm60D    '  .170 mcr fault in monitor mode.
dabr     vfd,eml*8  c'         ERR=Temm60E    '  .bad system request from 170.
         page
..
.
.        pec00 - process error conditions.
.
pec00    addpxq    a8,x0,pec005        .return address.
         ente      x1,mcr_mask-bit_58
         andx      x6,x1               .clear unimportant MCR bits
         addaq     a_wrk,a_wrk,sf_wrk
         brdir     a7,x0               .process 170 error condition.

pec005   bss       0
         brreq     x6,x0,pmc           .if not a 170 fatal error.
         addpxq    a6,x0,damm          .PVA of error message.
         brreq     x0,x0,stop170       .process 170 fatal error.

         page
..
.        store_err - update the error status in the dual state control block.
.
.        entry     x6 = error condition to set in the log
.
store_err bss      0
         entl      x0,r_pid            .get processor id
         cpysx     x4,x0
         addr      x4,x4               .multiply by 2
         addaq     a5,a_dscb,dscm
         cpyax     x1,a5
         purge     x1,3
         lbyts,1   x1,a5,x4,3
         brreq     x0,x1,sto01         .if no previous status
         brrge     x6,x1,sto02         .if previous error was worse
sto01    entp      x0,63-59            .Update the interface block
         lbset     x1,a5,x0
         brrne     x1,x0,sto01         .If interlock not set
         entp      x0,0
         sbyts,2   x6,a5,x4,2          .store status, clear retry count
         sbyts,1   x0,a5,x0,0
sto02    entp      x1,noerr
         brreq     x0,x0,pmce3         .return
         page
........................................................................
.
.         sys_call   - process requests from NOS trap handler.
.
.         this routine gains control as the result of a request from the
.         NOS trap handler to do something with NOS.  The requests are:
.         1 - Abort NOS job with specified error condition.
.         2 - Await recovery to NOS stand alone operation.
.         3 - Do nothing.
.         4 - set interface table address.
.
........................................................................
sys_call bss       0                   .process system call
         lx        x1,a_jps,xp_x0      .get request code
         la        a7,a_bindin,osp_aaj
         entp      X2,EIRQC
         BRREQ     X2,X1,pec00         .IF A170 ERROR REQUEST
.
.        check for 180 termination request.
.
         entp      x2,dstrtxr
         brreq     x2,x1,term180       .terminate the 180
         entp      x2,donthing
         brreq     x2,x1,pmce2         .do nothing
         addpxq    a6,x0,dabr          .PVA of error message.
         brreq     x0,x0,stop170       .bad request, terminate the 170.
         page

........................................................................
.
.        term180   - start the 180 termination sequence for NOS/VE.
.
.        This starts the NOS/VE termination sequence by setting the deadstart
.        flag in the environment interface control block (EICB) to a  1 if
.        running standalone.  If running dual state the ve_down flag is set
.        and the NVE subsystem will advance to termination and a request
.        is made to revert the CPU to 170 standalone which sets the deadstart
.        flag in the EICB.  SCI starts its termination sequence when it sees
.        the deadstart flag set.
.
.        Exit is to mtp$idle_180.
.
........................................................................

         align     0,8
         def       term180
term180  ALIAS     mtp$terminate_180
term180  bss       0
 .
         la        a6,A_bindin,nos_xp  .pointer to 170 OS xp pointer.
         la        A_jps,a6,0          .PVA of 170 OS xp.
         cpyax     x2,A_jps
         isom      x3,x0,2020(8),x0
         brxeq     x2,x3,term180_1     .If 170 OS not running, standalone.

.        Form PVA of 170 trap handlers stack.

         lbyts,2   x1,A_jps,x0,xp_a0   .EI working storage ring+segment#
         shfx      x3,x3,x0,-32        .16 bits of ones right justified.
         brxeq     x1,x3,term180_1     .If 170 OS not running, xp not initialized.

.        Dual state termination.

         shfx      x1,x1,x0,32
         cpyxa     a_wrk,x1
         isom      x1,x0,(33*100(8)+0)  .set bit 2**30, VE down flag.
         sx        x1,a_wrk,ve_down    .set ve down bit for trap handler
         brxeq     x0,x0,term180_2     .continue dual state termination sequence.
.
term180_1 bss      0
         entp      x1,1                .Set VE down flag, this informs SCI to
                                       . start VE termination.
         sbyts,4   x1,a_dscb,x0,ds_flag
term180_2 bss      0
         addaq     a0,a1,8           .Dont allow resume system
         entl      x0,0              .  commands.
         sx        x0,a1,0
         cpyaa     a6,a1               .parameter list address.
         ente      x0,0120(16)       .Call mtp$idle_180.
         callseg   bs_idle,a_bindin,a6
.
errhalt  brreq     x0,x0,errhalt
         page
ENDEIMT  EQU       $
         ORG       ENDEIMT
         END
*DECK DECK=MTM$PROCESS_DUE_ERRORS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE OS : 180 Monitor DUE processor.' ??
MODULE mtm$process_due_errors;

{ PURPOSE:
{   The purpose of this module is to process the DETECTED UNCORRECTED ERRORS (DUE) triggered by bit 48 in the
{   MCR.  The DUE is logged in a circular CM buffer.  The action then taken is reflected in Figure 9.1-1 of
{   the MIGDS and 180 Operating System action section 4.2.9 of the DFT/OS Interface specification. If certain
{   conditions are met, the CPU which has encountered the DUE will be deconfigured without interrupting the
{   system.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cml$system_informative_message
*copyc mtt$due_state
*copyc mtt$due_log
*copyc mtt$170_due_info
*copyc ost$cpu_state_table
*copyc ost$exchange_package
*copyc ost$informative_message_record
*copyc ost$processor_id
*copyc ost$processor_id_set
*copyc syt$monitor_request_code
*copyc syt$monitor_status
*copyc tmt$mcr_faults
?? POP ??
*copyc dpp$display_error
*copyc dsp$report_system_message
*copyc mtp$clear_lock
*copyc mtp$error_stop
*copyc mtp$manage_processor_with_due
*copyc mtp$set_lock
*copyc mtp$step_unstep_system
*copyc tmp$cause_task_switch
*copyc tmp$send_monitor_fault
?? EJECT ??
*copyc mtv$scb
*copyc mtv$sys_core_init_complete
*copyc mtv$total_nos_cpu_time
*copyc syv$enable_fault_injection
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    mtv$aborted_task_threshold: [XDCL, #GATE] integer := 20,
    mtv$deadstart_due_threshold: [XDCL] integer := 10,
    mtv$due_log: [XDCL] mtt$due_log := [ 0, 'DUE_LOG', 0, [[0, 0], [0, 0], [0, 0]], * ],
    mtv$halt_on_proc_malf: [XDCL, #GATE] boolean := FALSE,
    mtv$170_due_info: [XDCL] mtt$170_due_info := [0, 0, 0, 0],
    mtv$processor_due_threshold: [XDCL, #GATE] integer := 10,
    mtv$time_first_mtr_due: [XDCL] integer := 0;
?? OLDTITLE ??
?? NEWTITLE := 'mtp$process_due', EJECT ??
*copyc mth$process_due
  PROCEDURE [XDCL] mtp$process_due
    (    due_state: mtt$due_state;
         cst_p: ^ost$cpu_state_table;
         xp_p: ^ost$exchange_package);

    CONST
      one_second = 1000000,
      ten_seconds = 10000000;

    VAR
      abort_task: boolean,
      conditions_warrant_cpu_deconfig: boolean,
      current_time: integer,
      process_damaged: boolean,
      processor_selections: ost$processor_id_set,
      processor_set: ost$processor_id_set,
      status: syt$monitor_status,
      xcb_p: ^ost$execution_control_block;

{ Halt if the system attribute Halt_On_Processor_Malf is set.

    IF mtv$halt_on_proc_malf THEN
      mtp$step_unstep_system (syc$ic_software_breakpoint, 'VEOS9302- DUE: Halt_On_Proc_Malf set');
    IFEND;

{ Log the DUE.

    log_due (due_state, cst_p, xp_p, process_damaged);

{ Special handling for DUE errors that occur very early in deadstart.
{ Allow a small number of PND DUEs. Note - rest of this proc has to be skipped
{ since tables are not sufficiently initialized to process the failure.

    IF NOT mtv$sys_core_init_complete THEN
      mtv$deadstart_due_threshold := mtv$deadstart_due_threshold - 1;
      IF (mtv$deadstart_due_threshold = 0) OR process_damaged THEN
        mtp$step_unstep_system (syc$ic_fatal_hardware_error,'VEOS520E- FATAL CPU ERROR');
      IFEND;
      RETURN; {<---}
    IFEND;

    abort_task := FALSE;
    conditions_warrant_cpu_deconfig := FALSE;

{ Check for fatal errors: e.g. (DUE and process_damaged) in 180 job or 180 monitor.
{ Also, check for errors which warrant deconfiguration of a CPU out of the system configuration.

    CASE due_state OF
    = mtc$due_in_nos =
      dpp$display_error ('DUE in 170 state - check 170 status');
      IF process_damaged THEN

{ The following statement is essentially useless, because the monitor interrupt handler will look for the
{ process_not_damaged flag in the 170 exchange package and, when it doesn't find it, the monitor interrupt
{ handler will cease to run 170.  DUE processing/CPU deconfiguration will be processed in a different path.

        mtv$170_due_info.aborted_job_count := mtv$170_due_info.aborted_job_count + 1;
        RETURN; {<---}
      ELSE

{ Use and maintain information about 170 DUEs separately from 180.
{ Assumption: We cannot switch 170 from the CPU on which it was initially running.  Therefore, if 170 has too
{ many DUEs in 1 hour, as defined by the following:
{
{       (mtv$170_due_info.aborted_job_count * mtv$170_due_info.due_count) >
{       (mtv$aborted_task_threshold * mtv$processor_due_threshold)
{
{ then aborting the 170 "tasks" will be the same as deconfiguring the 170 CPU.  See the previous comments.

        IF mtv$170_due_info.proc_malf_count < UPPERVALUE (mtv$170_due_info.proc_malf_count) THEN
          mtv$170_due_info.proc_malf_count := mtv$170_due_info.proc_malf_count + 1;
        IFEND;

        mtv$170_due_info.due_count := mtv$170_due_info.due_count + 1;
        IF mtv$170_due_info.due_count > (mtv$processor_due_threshold * mtv$aborted_task_threshold)THEN

{ Clear the process_not_damaged flag in the 170 exchange package.  See previous comments.

          xp_p^.flags := xp_p^.flags - $ost$flags [osc$process_not_damaged];
          mtv$170_due_info.aborted_job_count := mtv$170_due_info.aborted_job_count + 1;
        IFEND;
      IFEND;
      mtv$170_due_info.time_last_due := mtv$total_nos_cpu_time.total;

      IF mtv$170_due_info.aborted_job_count > mtv$aborted_task_threshold THEN
        conditions_warrant_cpu_deconfig := TRUE;
      ELSE
        RETURN; {<---}
      IFEND;

    = mtc$due_in_180_monitor =
      IF process_damaged THEN
        conditions_warrant_cpu_deconfig := TRUE;
      ELSE
{!      IF (#free_running_clock (0) - mtv$time_first_mtr_due) > ten_seconds THEN
{!         mtv$time_first_mtr_due := #free_running_clock (0);
{!         cst_p^.due_count := 1;
{!      ELSE
          cst_p^.due_count := cst_p^.due_count + 1;

{! Has the processor exceeded the threshold for DUEs in ten seconds?
{ Has the processor exceeded the threshold for DUEs?

          IF cst_p^.due_count > mtv$processor_due_threshold THEN
            cst_p^.due_count := 1;
            conditions_warrant_cpu_deconfig := TRUE;
          ELSE
            dpp$display_error ('Non-fatal Monitor DUE encountered');
          IFEND;
{!      IFEND;

{! KLUDGE for Hardware Fault Injection:

        IF syv$enable_fault_injection THEN
          xp_p^.p_register.pva.offset := xp_p^.p_register.pva.offset + 4;
        IFEND;
      IFEND;

    = mtc$due_in_180_job =

      {! KLUDGE for Hardware Fault Injection:

      IF syv$enable_fault_injection THEN
        xp_p^.p_register.pva.offset := xp_p^.p_register.pva.offset + 4;
      IFEND;

      xcb_p := cst_p^.xcb_p;
      IF process_damaged THEN
        abort_task := TRUE;
      ELSE

        { Has this task executed for ten seconds without a DUE?

        IF xcb_p^.proc_malf_count < UPPERVALUE(xcb_p^.proc_malf_count) THEN
          xcb_p^.proc_malf_count := xcb_p^.proc_malf_count + 1;
        IFEND;

        IF xcb_p^.cp_time.time_spent_in_job_mode > (xcb_p^.time_last_due + ten_seconds) THEN
           cst_p^.due_count := 1;
        ELSE
          cst_p^.due_count := cst_p^.due_count + 1;

          { Has the processor exceeded the threshold for DUEs in ten seconds?

          IF cst_p^.due_count > mtv$processor_due_threshold THEN
            cst_p^.due_count := 1;

            { Deselect this CPU for this task.

            processor_set := xcb_p^.processor_selections;
            processor_set := processor_set - $ost$processor_id_set [xcb_p^.last_lpid_for_task];

            { Check for remaining processor availability.

            IF cst_p^.ijle_p^.job_scheduler_data.job_class = jmc$maintenance_job_class THEN
              processor_selections := mtv$scb.cpus.logically_on;
            ELSE
              processor_selections := mtv$scb.cpus.available_for_use;
            IFEND;
            IF (processor_set * processor_selections) = $ost$processor_id_set [] THEN
              abort_task := TRUE;
            ELSE
              xcb_p^.processor_selections := processor_set;
            IFEND;
          IFEND;
        IFEND;
        xcb_p^.time_last_due := xcb_p^.cp_time.time_spent_in_job_mode;

        { Give DFT time to catch the DUE before this task can possibly run again.

        tmp$cause_task_switch;

      IFEND;
    ELSE
      mtp$error_stop ('Illegal selection for DUE_STATE, MTP$PROCESS_DUE');
    CASEND;

{ Check for task abort.  If a task need not be aborted, but a processor must be deconfigured, the task will
{ be resurrected during deconfiguration processing, if it is possible to do so.

    IF abort_task AND (due_state = mtc$due_in_180_job) THEN
      log_aborted_task_message (cst_p, xcb_p);
      cst_p^.aborted_task_count := cst_p^.aborted_task_count + 1;

      IF cst_p^.aborted_task_count > mtv$aborted_task_threshold THEN

{ If the processor is over the threshold for aborted tasks, the processor will be turned off, or the system
{ will be stepped.  The task will be aborted as a result of the processor deconfiguration.

        conditions_warrant_cpu_deconfig := TRUE;
      ELSE

{ If the processor is not over the threshold for aborted tasks, abort the task.

        mtp$abort_task_with_due (cst_p, xcb_p);
      IFEND;

    IFEND;

    IF conditions_warrant_cpu_deconfig THEN
      mtp$manage_processor_with_due (xp_p^.last_processor_id);
    IFEND;

  PROCEND mtp$process_due;
?? OLDTITLE ??
?? NEWTITLE := 'mtp$abort_task_with_due', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to send the task with a DUE a monitor fault.  The task will abort.
{
{  MTP$ABORT_TASK_WITH_DUE (CST_P, XCB_P)
{
{  CST_P: (INPUT)  Pointer to the CPU state table.
{  XCB_P: (INPUT)  Pointer to the execution control block of the task which is to be aborted.

  PROCEDURE [XDCL] mtp$abort_task_with_due
    (    cst_p: ^ost$cpu_state_table;
         xcb_p: ^ost$execution_control_block);

    VAR
      due_fault_contents_p: ^tmt$mcr_faults,
      message: string (70),
      monitor_fault: ost$monitor_fault,
      null_pva: [READ] ost$pva := [1, 0fff(16), 7fffffff(16)];

    monitor_fault.identifier := tmc$mcr_fault;
    due_fault_contents_p := #LOC (monitor_fault.contents);
    due_fault_contents_p^.faults := $ost$monitor_conditions [osc$detected_uncorrected_err];
    due_fault_contents_p^.untranslatable_pointer := null_pva;
    tmp$send_monitor_fault (cst_p^.taskid, ^monitor_fault, TRUE);

    message := ' ';
    message (1,50) := 'Uncorrected CPU Error (DUE) occured; task aborted:';
    dpp$display_error (message);

    message := ' ';
    message (1,7) := 'Task = ';
    message (8,31) := xcb_p^.save9;
    message (39,11) := ', in job = ';
    message (50,19) := cst_p^.jcb_p^.system_name;
    dpp$display_error (message);

  PROCEND mtp$abort_task_with_due;
?? OLDTITLE ??
?? NEWTITLE := 'log_due', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to log the DUE processor errors in a circular error log.
{
{  LOG_DUE (DUE_STATE, CST_P, XP_P, REGS_P, PROCESS_DAMAGED)
{
{  DUE_STATE:       (INPUT)  This parameter specifies the state of the system
{                            in which DUE occured.
{  CST_P:           (INPUT)  Pointer to the CPU state table.
{  XP_P:            (INPUT)  Pointer to the exchange package.
{  PROCESS_DAMAGED: (OUTPUT) Boolean indicating whether the executing task has
{                            been damaged by the DUE.

  PROCEDURE log_due
    (    due_state: mtt$due_state;
         cst_p: ^ost$cpu_state_table;
         xp_p: ^ost$exchange_package;
     VAR process_damaged: boolean);

    CONST
      three_seconds = 3000000;

    VAR
      duration: ost$free_running_clock,
      current_time: ost$free_running_clock,
      i: mtt$due_log_entries,
      locked: boolean;

    process_damaged := NOT (osc$process_not_damaged IN xp_p^.flags);

{ Try for 3 seconds to lock the DUE log.  If unsuccessful, just RETURN and let the previous DUE
{ (that locked the log) finish processing.

    current_time := #free_running_clock (0);
    duration := current_time + three_seconds;
    REPEAT
      mtp$set_lock (mtv$due_log.lock, locked);
    UNTIL locked OR (#free_running_clock (0) > duration) OR (cst_p^.next_processor_state <> cmc$on);

    IF NOT locked THEN
      RETURN;
    IFEND;

{ Make the entry into the DUE log.  NOTE: the DUE log is a circular log.

    i := (mtv$due_log.next_i MOD mtc$due_log_entry_count) + 1;
    mtv$due_log.next_i := i;

    mtv$due_log.total_due_count [due_state] [process_damaged] :=
          mtv$due_log.total_due_count [due_state] [process_damaged] + 1;

    mtv$due_log.dues [i].due_state := due_state;
    mtv$due_log.dues [i].process_damaged := process_damaged;
    mtv$due_log.dues [i].time := current_time;
    mtv$due_log.dues [i].task_id := cst_p^.taskid;
    mtv$due_log.dues [i].xp := xp_p^;

{ Unlock the DUE log.

    mtp$clear_lock (mtv$due_log.lock);

  PROCEND log_due;
?? OLDTITLE ??
?? NEWTITLE := 'log_aborted_task_message', EJECT ??

{ PURPOSE:
{   This procedure puts an informative message (CM1800) in the engineering log which details the termination
{   of a task because of a DUE.
{
{        LOG_ABORTED_TASK_MESSAGE
{          (    CST_P: ^OST$CPU_STATE_TABLE;
{               XCB_P: ^OST$EXECUTION_CONTROL_BLOCK);
{
{        CST_P: (INPUT) Specifies the pointer to the cpu state table of the processor with the DUE
{        XCB_P: (INPUT) Specifies the pointer to the execution control block of the task which was executing
{                       when the DUE occurred

  PROCEDURE log_aborted_task_message
    (    cst_p: ^ost$cpu_state_table;
         xcb_p: ^ost$execution_control_block);

    VAR
      message: ost$informative_message_record,
      message_logged: boolean;

{ Place some useful information in the text.  The format is as follows:
{ '$MMMM_SSSS_CCC_NNNN JJJJJJJJJJJJJJJJJJJJJJJJJJJJJJJ TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT DUE '
{   Chars 1-19: system_supplied_name
{   Char 20: blank
{   Char 21-51: user_supplied_name
{   Char 52: blank
{   Char 53-83: taskname
{   Char 84: blank
{   Char 85-88: 'DUE'

    message.message_type := cml$system_informative_message;
    message.message := ' ';
    message.message (1, 19) := cst_p^.jcb_p^.system_name;
    message.message (21, 31) := cst_p^.jcb_p^.jobname;
    message.message (53, 31) := xcb_p^.save9;
    message.message (85, 3) := 'DUE';

    dsp$report_system_message (#SEQ (message), dsc$general_du_error, dsc$informative_message, message_logged);

  PROCEND log_aborted_task_message;
?? OLDTITLE ??
MODEND mtm$process_due_errors;
*DECK DECK=MTM$SYSTEM_CONTROL EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
MODULE mtm$system_control;

{
{
{  PURPOSE:
{     This module is called periodically to do the following:
{        . monitor status of the SMU Control Block (SCB)
{     This module also contains the routines which govern:
{        . the final processing of idle_system
{        . the initial processing of resume_system
{        . step_system
{        . unstep_system
{        . terminate_system
{

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_state
*copyc dst$mf_element_table_entry
*copyc dst$system_logging_types
*copyc jmt$initiate_system_idle
*copyc mmt$rb_idle_system
*copyc mtt$monitor_lock
*copyc osc$processor_defined_registers
*copyc ost$170_os_type
*copyc oss$mainframe_wired
*copyc oss$mainframe_wired_literal
*copyc ost$cpu_state_table
*copyc ost$date_time
*copyc ost$free_running_clock
*copyc ost$keypoint_control
*copyc ost$stack_frame_save_area
*copyc ost$terminate_continue_stats
*copyc syt$180_idle_code
*copyc syt$monitor_request_code
*copyc tmc$signal_identifiers
*copyc tme$monitor_mode_exceptions
*copyc tmt$system_task_id
?? POP ??
{ Define constants for use within this module.

  CONST
    top_line_msg_size = dpc$console_row_size - 4,
    number_of_processors = 2,
    mtc$check_scb_interval = 1000000, {Interval for calling this routine to check SCB.
    mtc$max_time_to_be_away = mtc$check_scb_interval*2;  {maximum nuber of intervals to be away.

{ Define External variables and procedures.

*copyc cmp$enable_all_connections
*copyc dpp$display_error
*copyc dpv$180_operator_action
*copyc dpv$top_window_p
*copyc dsp$advance_ds_sequence_in_mtr
*copyc dsp$mtr_change_bct_flag
*copyc dsp$mtr_save_cause_and_time
*copyc dsp$mtr_save_nos_nbe_status
*copyc dsp$mtr_save_top_line_message
*copyc dsp$perform_cpu_pp_handshaking
*copyc dsp$report_system_message
*copyc iop$idle_all_paths
*copyc iop$resume_all_paths
*copyc i#mtr_disable_traps
*copyc i#mtr_enable_traps
*copyc i#program_error
*copyc i#mtr_restore_traps
*copyc mmp$include_p_reg_in_dump
*copyc mtp$clear_lock
*copyc mtp$cst_p
*copyc mtp$idle_180
*copyc mtp$interrupt_processor
*copyc mtp$monitor_processor_status
*copyc mtp$set_lock
*copyc mtp$terminate_180
*copyc mtv$cst0
*copyc mtv$dummy_trace_buffer
*copyc mtv$scb
*copyc mtv$idle_message_line
*copyc mtv$ns_xp_p
*copyc mtv$nst_p
*copyc mtv$operator_console_hung
*copyc mtv$processor_mode
*copyc mtv$request_table
*copyc mtv$time_to_check_scb_status
*copyc mtv$max_async_lock_time
*copyc osv$base_system_time
*copyc osv$cpus_physically_configured
*copyc pmp$this_is_a_leap_year
*copyc syv$mandatory_dualstate
*copyc tmp$flag_all_tasks
*copyc tmp$monitor_ready_system_task

  VAR
    v$leap_year: [STATIC, READ, oss$mainframe_wired_literal] ARRAY [1 .. 12] OF 1 .. 31 :=
          [31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31],

    v$non_leap_year: [STATIC, READ, oss$mainframe_wired_literal] ARRAY [1 .. 12] OF 1 .. 31 :=
          [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31];

{ The following variable is explicitly XREF'd here to avoid the common deck's attribute of READ, because this
{ module may have to change the value of this variable.

  VAR
    osv$170_os_type: [XREF] ost$170_os_type;

{ The following variable is used to save an idle code that could not be sent to the
{ system job monitor. The routine mtp$monitor_system_status will keep trying to send the
{ request until it is accepted.

  VAR
    idle_requested: [STATIC] syt$180_idle_code := syc$ic_null;

{ The following variable is used as a lock to serialize processor requests to the SMU.

  VAR
    mtv$smu_request_lock: [STATIC] mtt$monitor_lock := 0;

{ The following variable is set to TRUE when system core initialization is complete.

  VAR
    mtv$sys_core_init_complete: [XDCL, #GATE] boolean := FALSE;

{ The following variable is set to TRUE if we are running in NOS/CPU1 dedicated
{ mode. This implies only NOS runs in CPU 1, VE and NOS share CPU 0.

  VAR
   mtv$cpu1_dedicated_to_nos: [XREF] boolean;

?? TITLE := 'Types and variables for system control', EJECT ??

*copyc mtt$nosve_control_status

  VAR
    mtv$nosve_control_status: [XDCL, #GATE] mtt$nosve_control_status := [mtc$system_not_idle,
      mtc$system_not_stepped, mtc$trs_system_ready_to_step];

  VAR
    mtv$step_condition_has_occurred: [XDCL] boolean := FALSE;

  VAR
    mtv$automatic_unstep_resume: [XDCL, #GATE] boolean := TRUE;

  VAR
    mtv$short_warning_seen: [XDCL] integer := 0;

  VAR
    mtv$time_to_call_handshaking: [XDCL] integer := 0;


{ The following are monitor-job flags for date and time handling.

  VAR
    iov$statistics_override: [XREF] boolean,
    iov$reject_address_buffer_full: [XREF] integer,
    iov$reject_interlock_set: [XREF] integer,
    iov$reject_requests_full: [XREF] integer,
    iov$reject_unit_queue_limit: [XREF] integer,

    iov$total_queue_calls: [XREF] integer,
    iov$read_priority_invoked: [XREF] integer,
    iov$actual_requests_resolved: [XREF] integer,

{   mmv$sq_rcount: [XREF] integer,
{   mmv$sq_mcount: [XREF] integer,
{   mmv$jws_rcount: [XREF] integer,
{   mmv$jws_mcount: [XREF] integer,

    mtv$status_cycle_total: [XDCL, #GATE, oss$mainframe_wired] integer := 0,
    mtv$status_cycle_stop: [XDCL,#GATE, oss$mainframe_wired] integer := 0,
    mtv$statistics_stamp: integer;

  VAR
    osv$date_time_update: [XDCL,#GATE, oss$mainframe_wired] boolean := FALSE;

  VAR
    mtv$check_if_hdw_cleared_before: [XDCL] boolean := FALSE;

*copyc osv$170_os_termination_status

  VAR
    mtv$idle_step_message: [XDCL, #GATE] dpt$top_line_message := ' ';

?? OLDTITLE, NEWTITLE := 'MTP$RECORD_CRITICAL_HDW_STATUS', EJECT ??
{------------------------------------------------------------------------------------------
{  PURPOSE:
{  This procedure is called to update the hardware status of the SCB,
{  and to store the message sent by the logger.
{------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mtp$record_critical_hdw_status
    (    hardware_option: mtt$scb_hardware_status_options;
         hardware_action: mtt$scb_hardware_status_actions;
         hardware_message: dpt$top_line_message);


    IF hardware_action = mtc$scb_hsa_set THEN
      IF mtv$scb.hardware_status [hardware_option] = mtc$scb_max_hardware_status THEN
{       mtp$store_informative_message ('System note: Maximum hardware errors count exceeded.');
        RETURN;
      IFEND;

      IF NOT mtv$scb.hardware_status_messages [hardware_option].message_read THEN
        mtv$scb.hardware_status_messages [hardware_option].message := hardware_message;
        mtv$scb.hardware_status_messages [hardware_option].message_read := TRUE;
      IFEND;
      IF hardware_option = mtc$scb_short_warning_step THEN
        mtv$scb.hardware_status [hardware_option] := 1;
      ELSE
        mtv$scb.hardware_status [hardware_option] := mtv$scb.hardware_status [hardware_option] + 1;
      IFEND;
    ELSE {hardware_action = mtc$scb_hsa_clear}
      IF (mtv$scb.hardware_status [hardware_option] = 0) AND (hardware_option <> mtc$scb_short_warning_step)
            THEN
        mtp$store_informative_message ('System note: Hardware error CLEAR without corresponding SET.');
        RETURN;
      IFEND;

      IF NOT mtv$scb.hardware_status_messages [hardware_option].message_read THEN
        mtv$scb.hardware_status_messages [hardware_option].message := hardware_message;
        mtv$scb.hardware_status_messages [hardware_option].message_read := TRUE;
      IFEND;
      IF hardware_option = mtc$scb_short_warning_step THEN
        mtv$scb.hardware_status [hardware_option] := 0;
      ELSE
        mtv$scb.hardware_status [hardware_option] := mtv$scb.hardware_status [hardware_option] - 1;
      IFEND;
    IFEND;

  PROCEND mtp$record_critical_hdw_status;
?? OLDTITLE ??
?? NEWTITLE := 'mtp$record_noncrit_hdw_status', EJECT ??

{  PURPOSE:
{    This procedure is called to update the hardware status of the CPU system elements.  It is called by the
{    code that processes OS Actions from the DFT PP.  DFT has noticed that a CPU is no longer operating
{    correctly.

  PROCEDURE [XDCL] mtp$record_noncrit_hdw_status
    (    element_id: dst$mf_element_id);

    TYPE
      t$id_or_element = PACKED RECORD
        CASE boolean OF
        = TRUE =
          fill: 0 .. 1f(16),
          processor_id: ost$processor_id,
        = FALSE =
          element_number: dst$mf_element_number,
        CASEND,
      RECEND;

    VAR
      id_or_element: t$id_or_element;

    IF element_id.dft_entry_id = dsc$dftb_eid_cpu0_element THEN
      id_or_element.element_number := element_id.element_number;
      IF id_or_element.processor_id IN mtv$scb.cpus.logically_on THEN
        mtv$cst0 [id_or_element.processor_id].reason_for_current_state := osc$cdsr_downed_by_dft;
        mtv$scb.cpus.hdw_state_change := mtv$scb.cpus.hdw_state_change +
              $ost$processor_id_set [id_or_element.processor_id];
        mtv$cst0 [id_or_element.processor_id].next_processor_state := cmc$down;
      IFEND;
    IFEND;

  PROCEND mtp$record_noncrit_hdw_status;
?? OLDTITLE, NEWTITLE := 'MTP$MONITOR_SYSTEM_STATUS', EJECT ??
{------------------------------------------------------------------------------------------
{  PURPOSE:
{  This procedure is called periodically to check the status of the SCB. If a
{  condition has occurred that requires idling of the 180 environment, a
{  signal is sent to the system job monitor to begin system idle (for R1,
{  all jobs are aborted).
{  If the system is stepped, this procedure checks the SCB for changes in
{  DFT-detected hardware errors and notifies the operator of the change:
{        . the error can occur
{        . the error can clear
{  If there are no hardware errors the system will resume execution
{  automatically or it will inform the operator how to restart the system
{  manually.
{------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mtp$monitor_system_status
    (    dummy: ^cell;
         cst_p: ^ost$cpu_state_table);

    CONST
      one_second = 1000000, {Used in short_warning processing}
      ten_seconds = 10000000;
    TYPE
      hardware_errors = SET OF mtt$scb_hardware_status_options,
      monitor_mask = RECORD
        CASE boolean OF
        = FALSE =
          mask: ost$monitor_conditions,
        = TRUE =
          int: 0 .. 0ffff(16),
        CASEND,
      RECEND;

    VAR
      previous_hardware_errors: [XDCL, STATIC] hardware_errors := $hardware_errors [ ],
      current_hardware_errors: [XDCL, STATIC] hardware_errors := $hardware_errors [ ],
      cleared_hardware_errors: [XDCL, STATIC] hardware_errors := $hardware_errors [ ],
      new_hardware_errors: [XDCL, STATIC] hardware_errors := $hardware_errors [ ],
      hardware_status: mtt$scb_hardware_status,
      hardware_index: mtt$scb_hardware_status_options,
      local_monitor_conditions: monitor_mask,
      local_monitor_mask: monitor_mask,
      short_warning_acknowledged: [STATIC] boolean := FALSE,
      termination_of_170_acknowledged: [STATIC] boolean := FALSE,
      i: ost$logical_processor_id,
      idle_code: syt$180_idle_code,
      ignore_status: syt$monitor_status,
      j: integer,
      clear_message: dpt$top_line_message,
      nos_170_message: dpt$top_line_message;


{ Check for a date/time update.  Set by PP DFT.

    IF mtv$nst_p^.d7st.operator_date_time_update THEN
      mtv$nst_p^.d7st.operator_date_time_update := FALSE;

{ Set the OS date/time flag.  The operator task will read this flag.

      osv$date_time_update := TRUE;
    IFEND;

{ Check for special statistics reset }

{   IF (mtv$statistics_stamp - #free_running_clock(0)) < 0 THEN
{   FOR j := LOWERBOUND (mtv$request_table) TO UPPERBOUND (mtv$request_table) DO
{     mtv$request_table [j].max_time := 0;
{   FOREND;
{
{   FOR j := LOWERBOUND (mtv$request_table) TO UPPERBOUND (mtv$request_table) DO
{     mtv$request_table [j].total_cpu_time := 0;
{   FOREND;
{   mtv$statistics_stamp := #free_running_clock(0) + ten_seconds;
{   mtv$status_cycle_total := #free_running_clock(0)- mtv$status_cycle_stop;
{   mtv$status_cycle_stop := #free_running_clock(0);
{
{   iov$reject_address_buffer_full := 0;
{   iov$reject_interlock_set := 0;
{   iov$reject_requests_full := 0;
{   iov$reject_unit_queue_limit := 0;
{
{   mmv$sq_mcount := 0;
{   mmv$sq_rcount := 0;
{   mmv$jws_rcount := 0;
{   mmv$jws_mcount := 0;
{
{
{   IFEND;
{ Check CPU/PP handshaking.

    IF (mtv$time_to_call_handshaking - #free_running_clock (0)) < 0 THEN
      dsp$perform_cpu_pp_handshaking;
    IFEND;

{ Update time that this routine should be called again.

    mtv$time_to_check_scb_status := #free_running_clock (0) + mtc$check_scb_interval;
    mtv$max_async_lock_time := #free_running_clock (0) + mtc$max_time_to_be_away;




{ Check for a KILL 180 request.

    mtv$scb.kill_180 := mtv$nst_p^.d7st.drop_ve_flag;

    IF (mtv$nosve_control_status.step_state = mtc$system_not_stepped) AND
          (cst_p^.cpu_state.current_state = osc$cpu_running) THEN

      IF mtv$step_condition_has_occurred THEN
        mtv$step_condition_has_occurred := FALSE;
        tmp$flag_all_tasks (osc$system_unstep_resume_flag, ignore_status);
      IFEND;

{ If a short warning occurred during an UNSTEP sequence, process it now.

      IF mtv$scb.hardware_status [mtc$scb_short_warning_step] > 0 THEN
        IF NOT short_warning_acknowledged THEN
          short_warning_acknowledged := TRUE;
          mtv$idle_step_message := mtv$scb.hardware_status_messages [mtc$scb_short_warning_step].message;
          mtv$scb.hardware_status_messages [mtc$scb_short_warning_step].message_read := FALSE;
          mtp$step_unstep_system (syc$ic_short_power, mtv$idle_step_message);
          short_warning_acknowledged := FALSE;
        IFEND;
      IFEND;

{ Check for the occurrence of a hardware failure.

      IF mtv$scb.hardware_status [mtc$scb_hardware_failure_step] > 0 THEN
        mtv$idle_step_message := mtv$scb.hardware_status_messages [mtc$scb_hardware_failure_step].message;
        mtv$scb.hardware_status_messages [mtc$scb_hardware_failure_step].message_read := FALSE;
        mtp$step_unstep_system (syc$ic_fatal_hardware_error, mtv$idle_step_message);
      IFEND;

{ If the 170 has issued a KILL request, go directly to system step without waiting for idle to complete.
{ Exception: Don't process the STEP_SYSTEM in response to DROPVE from 170 if the system is not sufficiently
{ initialized.  DROPVE on 170 will kill 180 fast enough if the system is truly hung in early deadstart.

      IF mtv$scb.kill_180 THEN
        IF dpv$top_window_p <> NIL THEN
          mtp$step_unstep_system (syc$ic_system_terminated,
                'VEOS8000- 180 terminated by 170 via SCB request');
        IFEND;
      IFEND;

{ If system idle is not already in progress, check for conditions that would initiate a system idle.

      IF (mtv$nosve_control_status.idle_state = mtc$system_not_idle) OR
         (mtv$nosve_control_status.idle_state = mtc$resume_system_in_progress) THEN
        IF mtv$scb.hardware_status [mtc$scb_long_warning_idle] > 0 THEN
          idle_code := syc$ic_long_power;
          mtv$idle_step_message := mtv$scb.hardware_status_messages [mtc$scb_long_warning_idle].message;
          mtv$scb.hardware_status_messages [mtc$scb_long_warning_idle].message_read := FALSE;
        ELSEIF mtv$scb.hardware_status [mtc$scb_hardware_failure_idle] > 0 THEN
          idle_code := syc$ic_hardware_idle;
          mtv$idle_step_message := mtv$scb.hardware_status_messages [mtc$scb_hardware_failure_idle].message;
          mtv$scb.hardware_status_messages [mtc$scb_hardware_failure_idle].message_read := FALSE;
        ELSE
          idle_code := idle_requested;
        IFEND;

        IF idle_code <> syc$ic_null THEN
          mtp$initiate_system_idle (idle_code);
        IFEND;
      IFEND;

{ Check for a STEP request.

      IF mtv$scb.nos_180_status.system_status.step_status_block.requested_status = mtc$stepped_system THEN
        mtp$step_unstep_system (syc$ic_step_command, 'VEOS9100- System STEPPED');

{ The system will return to this point when it is unstepped, so make sure the idle code is cleared.

        idle_requested := syc$ic_null;

      IFEND; { Check for a STEP request. }

      IF mtv$scb.nos_180_status.system_status.idle_status_block.requested_status <> mtc$idled_system THEN
        mtp$monitor_processor_status;
      IFEND;

    ELSE { mtv$nosve_control_status.step_state = mtc$system_stepped }

{ Monitor the status of the STEPPED system.
{ Read the 'live' MCR.

      local_monitor_conditions.int := #read_register (osc$pr_monitor_condition_reg);
      IF NOT (osc$short_warning IN local_monitor_conditions.mask) AND (mtv$scb.hardware_status
            [mtc$scb_short_warning_step] > 0) THEN

{ The system got to this point because it saw a short warning MCR bit set and stepped while the short warning
{ bit cleared asynchronously.  Clear the short warning hardware status bit.

        mtv$scb.hardware_status [mtc$scb_short_warning_step] := 0;
      IFEND;

      hardware_status := mtv$scb.hardware_status;
      IF hardware_status [mtc$scb_short_warning_step] > 0 THEN
        mtv$short_warning_seen := #free_running_clock (0);
      IFEND;
      IF (#free_running_clock (0) - mtv$short_warning_seen) < one_second THEN
        current_hardware_errors := $hardware_errors [mtc$scb_short_warning_step];
      ELSE
        mtv$scb.hardware_status_messages [mtc$scb_short_warning_step].message :=
              '         ERR=D706         SHORT POWER WARNING NORMAL';
        mtv$scb.hardware_status_messages [mtc$scb_short_warning_step].message_read := TRUE;
      IFEND;
      IF hardware_status [mtc$scb_hardware_failure_step] > 0 THEN
        current_hardware_errors := current_hardware_errors + $hardware_errors [mtc$scb_hardware_failure_step];
      IFEND;
      IF hardware_status [mtc$scb_long_warning_idle] > 0 THEN
        current_hardware_errors := current_hardware_errors + $hardware_errors [mtc$scb_long_warning_idle];
      IFEND;
      IF hardware_status [mtc$scb_hardware_failure_idle] > 0 THEN
        current_hardware_errors := current_hardware_errors + $hardware_errors [mtc$scb_hardware_failure_idle];
      IFEND;

{ Check for changes in hardware_status since the last time this procedure was called.

      IF current_hardware_errors <> previous_hardware_errors THEN
        new_hardware_errors := current_hardware_errors - previous_hardware_errors;
        IF new_hardware_errors <> $hardware_errors [ ] THEN
          FOR hardware_index := mtc$scb_short_warning_step TO mtc$scb_hardware_failure_idle DO
            IF hardware_index IN new_hardware_errors THEN
              IF mtv$scb.hardware_status_messages [hardware_index].message_read THEN
                IF NOT mtv$operator_console_hung THEN
                  dpp$display_error (mtv$scb.hardware_status_messages [hardware_index].message);
                IFEND;
                mtv$scb.hardware_status_messages [hardware_index].message_read := FALSE;
              IFEND;
            IFEND;
          FOREND;
        IFEND; { Hardware errors have occurred. }

        cleared_hardware_errors := previous_hardware_errors - current_hardware_errors;
        IF cleared_hardware_errors <> $hardware_errors [ ] THEN
          FOR hardware_index := mtc$scb_short_warning_step TO mtc$scb_hardware_failure_idle DO
            IF hardware_index IN cleared_hardware_errors THEN
              IF mtv$scb.hardware_status_messages [hardware_index].message_read THEN
                dpp$display_error (mtv$scb.hardware_status_messages [hardware_index].message);
                mtv$scb.hardware_status_messages [hardware_index].message_read := FALSE;
              IFEND;
            IFEND;
          FOREND;
        IFEND; { Hardware errors have cleared. }
      IFEND; { Change in hardware status? }

      IF current_hardware_errors = $hardware_errors [ ] THEN

{ All hardware errors are clear.

        IF (previous_hardware_errors <> current_hardware_errors) OR (mtv$check_if_hdw_cleared_before) THEN

{ This is the first time the system has noticed that all hardware errors are clear.

          mtv$check_if_hdw_cleared_before := FALSE;
          IF mtv$scb.nos_180_status.idle_code = syc$ic_short_power THEN
            clear_message := mtv$scb.hardware_status_messages [mtc$scb_short_warning_step].message;
            mtv$scb.hardware_status_messages [mtc$scb_short_warning_step].message_read := FALSE;
            dpp$display_error ('POWER/ENVIRONMENT NORMAL                                               ');
            mtp$display_to_top_line (clear_message);
            mtp$store_informative_message (clear_message);
          ELSEIF mtv$scb.nos_180_status.idle_code = syc$ic_fatal_hardware_error THEN
            clear_message := mtv$scb.hardware_status_messages [mtc$scb_hardware_failure_step].message;
            mtv$scb.hardware_status_messages [mtc$scb_hardware_failure_step].message_read := FALSE;
            dpp$display_error ('HARDWARE ENVIRONMENT NORMAL                                            ');
            mtp$display_to_top_line (clear_message);
            mtp$store_informative_message (clear_message);
          ELSEIF mtv$scb.nos_180_status.idle_code = syc$ic_long_power THEN
            clear_message := mtv$scb.hardware_status_messages [mtc$scb_long_warning_idle].message;
            mtv$scb.hardware_status_messages [mtc$scb_long_warning_idle].message_read := FALSE;
            dpp$display_error ('POWER/ENVIRONMENT NORMAL                                               ');
            mtp$display_to_top_line (clear_message);
            mtp$store_informative_message (clear_message);
          ELSEIF mtv$scb.nos_180_status.idle_code = syc$ic_hardware_idle THEN
            clear_message := mtv$scb.hardware_status_messages [mtc$scb_hardware_failure_idle].message;
            mtv$scb.hardware_status_messages [mtc$scb_hardware_failure_idle].message_read := FALSE;
            dpp$display_error ('HARDWARE ENVIRONMENT NORMAL                                            ');
            mtp$display_to_top_line (clear_message);
            mtp$store_informative_message (clear_message);
          IFEND;

          IF mtv$nosve_control_status.idle_state <> mtc$system_idle THEN

{ If the system is in this state it is due to one of the following:
{        1. a short warning (which cleared)
{        2. a STEP_SYSTEM command
{        3. a software error below the CPU halt_ring or other software breakpoint
{        4. some other reason.
{ If the system stepped for one of the first three reasons the system can UNSTEP.  If it stepped
{ because of a short_warning which cleared we can UNSTEP the system automatically now and
{ continue with whatever the system was doing before it stepped.

            IF (mtv$scb.nos_180_status.idle_code = syc$ic_short_power) AND
               (mtv$automatic_unstep_resume) THEN { automatic unstep }
              mtv$scb.nos_180_status.system_status.step_status_block.requested_status := mtc$unstepped_system;
            ELSEIF (mtv$scb.nos_180_status.idle_code = syc$ic_short_power) OR
                   (mtv$scb.nos_180_status.idle_code = syc$ic_step_command) OR
                   (mtv$scb.nos_180_status.idle_code = syc$ic_disk_error) OR
                   (mtv$scb.nos_180_status.idle_code = syc$ic_software_breakpoint) THEN { manual unstep }
              dpp$display_error ('System ready to UNSTEP manually; use console command.');
            IFEND; { determine automatic/manual control }

          ELSE { system is idle }

{ If the system is in this state the system is idle because of
{        1. a long_warning (which cleared)
{        2. an IDLE_SYSTEM command
{        3. a hardware_idle condition (which does not currently clear)
{        4. we were caught resuming when a STEP condition occurred
{ If the system idled for one of the first two reasons the system can RESUME.  If it idled because of a
{ long_warning (which cleared) the system can RESUME automatically and allow jobs to continue processing.
{ If the system was resuming when a STEP condition occurred and this is an unsteppable condition
{ then automatically UNSTEP the system (if automatic_unstep_resume is allowed) or allow the
{ UNSTEP_SYSTEM command to be invoked.

            IF (mtv$scb.nos_180_status.idle_code = syc$ic_long_power) AND
                  (mtv$automatic_unstep_resume) THEN { automatic resume }
              mtv$scb.nos_180_status.system_status.idle_status_block.requested_status := mtc$running_system;
              mtv$scb.nos_180_status.system_status.step_status_block.requested_status :=
                    mtc$unstepped_system;
            ELSEIF (mtv$scb.nos_180_status.idle_code = syc$ic_long_power) OR
                   (mtv$scb.nos_180_status.idle_code = syc$ic_idle_command)  THEN   { manual resume }
              dpp$display_error ('System ready to RESUME manually; use console command.');
            ELSEIF (mtv$scb.nos_180_status.idle_code = syc$ic_short_power) AND
               (mtv$automatic_unstep_resume) THEN { automatic unstep }
              mtv$scb.nos_180_status.system_status.step_status_block.requested_status := mtc$unstepped_system;
            ELSEIF (mtv$scb.nos_180_status.idle_code = syc$ic_short_power) OR
                   (mtv$scb.nos_180_status.idle_code = syc$ic_step_command) OR
                   (mtv$scb.nos_180_status.idle_code = syc$ic_disk_error) OR
                   (mtv$scb.nos_180_status.idle_code = syc$ic_software_breakpoint) THEN { manual unstep }
              dpp$display_error ('System ready to UNSTEP manually; use console command.');
            IFEND; { determine automatic/manual control }

          IFEND; { determine idle/non-idle status of the system }
        IFEND; { first time to notice lack of hardware errors }
      IFEND; { hardware errors have cleared }

      previous_hardware_errors := current_hardware_errors;
      current_hardware_errors := $hardware_errors [ ];
    IFEND;

{ Determine the status of 170 and log a message describing any abnormal conditions like termination.

    IF (osv$170_os_termination_status <> osc$ots7_running) AND (NOT termination_of_170_acknowledged) THEN
      termination_of_170_acknowledged := TRUE;
      dsp$mtr_save_nos_nbe_status ($INTEGER (osv$170_os_termination_status));
      IF osv$170_os_termination_status = osc$ots7_moded_out THEN
        mtp$store_informative_message ('VEOS8210- 170 OS TERMINATED due to MODE OUT error');
        IF syv$mandatory_dualstate THEN
          mtp$record_critical_hdw_status (mtc$scb_hardware_failure_idle, mtc$scb_hsa_set,
                'VEOS8210- FATAL C170 STATE EXIT MODE HALT                              ');
        ELSE
          osv$170_os_type := osc$ot7_none;
          dpp$display_error ('ERR=VEOS8210- FATAL C170 STATE EXIT MODE HALT');
        IFEND;
      ELSE { osv$170_os_termination_status = osc$ots7_fatal_due }
        mtp$store_informative_message ('VEOS820F- 170 OS TERMINATED due to FATAL DUE');
        IF syv$mandatory_dualstate THEN
          mtp$record_critical_hdw_status (mtc$scb_hardware_failure_idle, mtc$scb_hsa_set,
                'VEOS820F- FATAL C170 STATE UNCORRECTED CPU ERROR                       ');
        ELSE
          osv$170_os_type := osc$ot7_none;
          dpp$display_error ('ERR=VEOS820F- FATAL C170 STATE UNCORRECTED CPU ERROR');
        IFEND;
      IFEND;
    IFEND;

    IF mtv$scb.hardware_status [mtc$scb_170_status] > 0 THEN
      IF mtv$scb.hardware_status_messages [mtc$scb_170_status].message_read THEN
        nos_170_message := mtv$scb.hardware_status_messages [mtc$scb_170_status].message;
        mtv$scb.hardware_status_messages [mtc$scb_170_status].message_read := FALSE;
        mtp$store_informative_message (nos_170_message);
        dpp$display_error (nos_170_message);
      IFEND;
    IFEND;


  PROCEND mtp$monitor_system_status;
?? TITLE := 'MTP$DISPLAY_TO_TOP_LINE', EJECT ??

{ PURPOSE:
{   This procedure accepts a string and displays it to the top line of the system console.  It also stores
{   the string in the System Deadstart Status data in the SSR.  This information is later logged in a
{   statistic (if the information survives the possible crash).

  PROCEDURE [XDCL] mtp$display_to_top_line
    (    message: string ( * ));

    dsp$mtr_save_top_line_message (message);

    mtv$idle_message_line.text_size := top_line_msg_size;
    mtv$idle_message_line.text := message ;
    mtv$idle_message_line.next_line_rma := mtv$idle_message_line.next_line_rma + 1;

  PROCEND mtp$display_to_top_line;
?? TITLE := 'MTP$INITIATE_SYSTEM_IDLE', EJECT ??
{------------------------------------------------------------------------------------------
{ This procedure is called to initiate a system idle. A signal is sent to
{ the job monitor of the system job to ready itself upon return to job_mode.
{ In case the need arises, the cause of the idle is saved in a local static
{ variable, and the next time a call is made to mtp$monitor_system_status,
{ an attempt is made again to send the signal.
{------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mtp$initiate_system_idle (idle_code: syt$180_idle_code);

    VAR
      status: syt$monitor_status;

    IF NOT mtv$sys_core_init_complete THEN
      idle_requested := idle_code;
      RETURN;
    IFEND;

    mtv$scb.nos_180_status.system_status.idle_status_block.requested_status := mtc$idled_system;
    tmp$monitor_ready_system_task (tmc$stid_job_monitor, status);
    IF NOT status.normal THEN
      mtp$error_stop ('MT - cannot ready job_monitor task in mtp$initiate_system_idle');
    ELSE
      mtv$scb.nos_180_status.cause_of_idle := idle_code;
    IFEND;

  PROCEND mtp$initiate_system_idle;
?? TITLE := 'MTP$PROCESS_SHORT_WARNING', EJECT ??
{------------------------------------------------------------------------------------------
{ This procedure is called to process a short warning condition. The processing
{ currently done is to idle 180 as quickly as possible (by invoking the STEP/UNSTEP
{ procedure MTP$STEP_UNSTEP_SYSTEM) and hope the image file write is fast enough.
{------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mtp$process_short_warning;

    TYPE
      monitor_mask = RECORD
        CASE boolean OF
        = FALSE =
          mask: ost$monitor_conditions,
        = TRUE =
          int: 0 .. 0ffff(16),
        CASEND,
      RECEND;

    VAR
      local_monitor_conditions: monitor_mask,
      local_monitor_mask: monitor_mask;

{ Read the 'live' MCR.

    local_monitor_conditions.int := #read_register (osc$pr_monitor_condition_reg);
    IF NOT (osc$short_warning IN local_monitor_conditions.mask) THEN
      { The system got to this point because there were some 'stale' short_warning bits left set somewhere.
      RETURN;
    IFEND;

{ Clear the short_warning bit mask bit (if it is set).

    local_monitor_mask.int := #read_register (osc$pr_monitor_mask_reg);
    IF osc$short_warning IN local_monitor_mask.mask THEN
      local_monitor_mask.mask := local_monitor_mask.mask - $ost$monitor_conditions [osc$short_warning];
      #write_register (osc$pr_monitor_mask_reg, local_monitor_mask.int);
    IFEND;

    mtv$short_warning_seen := #free_running_clock (0);
    IF mtv$scb.nos_180_status.system_status.step_status_block.actual_status = mtc$unstepped_system THEN
{
{ The system was running normally, or it was caught stepping without actually processing
{ the original reason for the STEP.  It needs to STEP as quickly as possible.
{
      mtv$scb.hardware_status [mtc$scb_short_warning_step] := 1;
      mtv$scb.hardware_status_messages [mtc$scb_short_warning_step].message :=
            '         ERR=D703         SHORT POWER WARNING';
      mtv$scb.hardware_status_messages [mtc$scb_short_warning_step].message_read := TRUE;
      mtp$step_unstep_system (syc$ic_short_power, '         ERR=D703         SHORT POWER WARNING');    {VEOS}

    ELSEIF mtv$scb.nos_180_status.system_status.step_status_block.requested_status =
          mtc$unstepped_system THEN

{ The system was unstepping, or it was resuming.  The system can wait until it cleans up the
{ previous IDLE/STEP sequence before processing this call to STEP.

        dpp$display_error ('Short power warning detected in MCR');
    ELSE

{ The system was stepped.  The system will note the short_warning condition in the procedure
{ MTP$MONITOR_SYSTEM_STATUS.  Therefore, do nothing here.

    IFEND;

  PROCEND mtp$process_short_warning;

?? TITLE := 'PROCEDURE mtp$mtr_error_stop', EJECT ??

{
{  This procedure is called by the monitor interrupt handler when a fatal MCR/UCR error in monitor
{  is found by the trap handler.  The procedure examines the stack frame that was trapped and extracts
{  the P, MCR, UCR registers and displays their contents within the error message.
{
{   Parameters:  NONE
{   XREF DECK:   NONE - procedure only called from monitor_interrupt_handler which is not CYBIL code
{

  PROCEDURE [XDCL] mtp$mtr_error_stop;

    VAR
      line: string (top_line_msg_size),
      p: ^ost$stack_frame_save_area,
      i: 0 .. 0ffff(16),
      pos: 0 .. 76,
      scr: integer;

    VAR
      hex_char: [STATIC] array [0 .. 15] of string (1) := ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
            'A', 'B', 'C', 'D', 'E', 'F'];

    line := 'ERR=VEOS1010- MONITOR MCR/UCR: PVA= ';
    pos := 37;
    p := #PREVIOUS_SAVE_AREA ();
    p := p^.minimum_save_area.a2_previous_save_area;
    line (pos, 1) := hex_char [p^.minimum_save_area.p_register.pva.ring];
    pos := pos + 2;
    scr := p^.minimum_save_area.p_register.pva.seg;
    FOR i := pos + 2 DOWNTO pos DO
      line (i, 1) := hex_char [scr MOD 16];
      scr := scr DIV 16;
    FOREND;
    pos := pos + 4;
    scr := p^.minimum_save_area.p_register.pva.offset;
    FOR i := pos + 7 DOWNTO pos DO
      line (i, 1) := hex_char [scr MOD 16];
      scr := scr DIV 16;
    FOREND;
    pos := pos + 10;
    #UNCHECKED_CONVERSION (p^.user_condition_register, i);
    scr := i;
    line (pos, 6) := '  UCR=';
    pos := pos + 6;
    FOR i := pos + 3 DOWNTO pos DO
      line (i, 1) := hex_char [scr MOD 16];
      scr := scr DIV 16;
    FOREND;
    pos := pos + 4;
    #UNCHECKED_CONVERSION (p^.monitor_condition_register, i);
    scr := i;
    line (pos, 6) := '  MCR=';
    pos := pos + 6;
    FOR i := pos + 3 DOWNTO pos DO
      line (i, 1) := hex_char [scr MOD 16];
      scr := scr DIV 16;
    FOREND;

    mtp$step_unstep_system (syc$ic_fatal_software_error, line);

  PROCEND mtp$mtr_error_stop;

?? TITLE := 'PROCEDURE mtp$mtr_step_unstep_system', EJECT ??
{------------------------------------------------------------------------------------------
{ This procedure is the entry point which is used by RQPROC in
{ MTM$MONITOR_INTERRUPT_HANDLER.  It is called via a request block which is set up in
{ the job_mode procedure OSP$IDLE_RESUME_SYSTEM_JOB and is then passed to monitor_mode.
{------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] mtp$mtr_step_unstep_system (rb: mmt$rb_idle_system);

    mtp$step_unstep_system (rb.idle_code, rb.error_message);

  PROCEND mtp$mtr_step_unstep_system;

?? TITLE := 'PROCEDURE mtp$step_unstep_system', EJECT ??

  PROCEDURE [XDCL] mtp$step_unstep_system
        (idle_code: syt$180_idle_code;
         text: string (*<=top_line_msg_size) );

    CONST
      should_not_return = 'mtp$idle_180 (false) RETURNED' ;

    TYPE
      message = string (71);

    VAR
      messages: [STATIC, READ] ARRAY [syt$180_idle_code] OF message := [
{    syc$ic_null                    } 'NULL',
{    syc$ic_system_terminated       } 'VEOS0002- System TERMINATED via OPERATOR COMMAND',

{    The next two codes are ABORT codes}

{    syc$ic_fatal_hardware_error    } 'VEOS0003- System ABORTED due to HARDWARE FAILURE',
{    syc$ic_fatal_software_error    } 'VEOS0004- System ABORTED due to SOFTWARE FAILURE',

{    The following codes are IDLE codes}

{    syc$ic_long_power              } 'VEOS0005- System IDLED due to LONG POWER WARNING',
{    syc$ic_hardware_idle           } 'VEOS0006- System IDLED due to HARDWARE IDLE CONDITION',
{    syc$ic_idle_command            } 'VEOS0007- System IDLED via OPERATOR COMMAND',

{    The following codes are STEP codes}

{    syc$ic_step_command            } 'VEOS0008- System STEPPED via OPERATOR COMMAND',
{    syc$ic_short_power             } 'VEOS0009- System STEPPED due to SHORT POWER WARNING',
{    syc$ic_disk_error              } 'VEOS0010- System STEPPED due to DISK ERROR',
{    syc$ic_software_breakpoint     } 'VEOS0011- System STEPPED due to SOFTWARE SELECTED BREAKPOINT'];


    TYPE
      monitor_mask = RECORD
        CASE boolean OF
        = FALSE =
          mask: ost$monitor_conditions,
        = TRUE =
          int: 0 .. 0ffff(16),
        CASEND,
      RECEND;

    VAR
      local_monitor_mask: monitor_mask;

    VAR
      first_step_code: [STATIC] syt$180_idle_code,
      first_step_text: [STATIC] string (top_line_msg_size),
      first_step_text_size: [STATIC] 0..top_line_msg_size,
      command_needed_to_unstep_resume: [STATIC] boolean,
      mtv$trace_p: [XDCL] ARRAY [0 .. osc$max_number_of_processors - 1] OF  ^cell,
      mtv$step_lock_0: [XDCL] mtt$monitor_lock := 0,
      mtv$step_lock_1: [XDCL] mtt$monitor_lock := 0,
      mtv$step_lock_2: [XDCL] mtt$monitor_lock := 0,
      mtv$unstep_lock_0: [XDCL] mtt$monitor_lock := 0,
      mtv$unstep_lock_1: [XDCL] mtt$monitor_lock := 0,
      mtv$unstep_lock_2: [XDCL] mtt$monitor_lock := 0,
      locked: boolean,
      osv$step_kbp: [XDCL] ARRAY [0 .. osc$max_number_of_processors - 1]
        OF integer := [REP osc$max_number_of_processors of 0],
      current_cst_p: ^ost$cpu_state_table,
      i,
      additional_cpus_not_stepped,
      additional_cpus_not_running: 0 .. 0ff(16),
      old_te: 0 .. 3,
      idle_te: 0 .. 3,
      keypoints_enabled,
      endtime: integer,
      status: syt$monitor_status;

{ Leave the following 3 statements FIRST - in case of idle while keypoints are active.
{ Thank You.

{ Terminate keypoint collection.

    keypoints_enabled := #read_register (osc$pr_clear_keypoint_enable);
    osv$step_kbp [#read_register (osc$pr_processor_id)] := #read_register (osc$pr_keypoint_buffer_ptr);
    #write_register (osc$pr_clear_keypoint_enable, osc$pr_clear_keypoint_enable);

{ Begin the NOTIFY phase of step processing.  The first CPU to reach this point
{ will send interrupts to the other processors to indicate that they should step also.

    i#mtr_disable_traps (old_te);

{ Set the variable to display a flashing message on the 170 console.

    dpv$180_operator_action := TRUE;

{ Deselect the short_warning trap bit.

    local_monitor_mask.int := #read_register (osc$pr_monitor_mask_reg);
    local_monitor_mask.mask := local_monitor_mask.mask - $ost$monitor_conditions [osc$short_warning];
    #write_register (osc$pr_monitor_mask_reg, local_monitor_mask.int);

    IF mtv$ns_xp_p <> NIL THEN
      mtv$ns_xp_p^.monitor_mask := mtv$ns_xp_p^.monitor_mask - $ost$monitor_conditions [osc$short_warning];
    IFEND;

    mtp$cst_p (current_cst_p);

{ If the SCB does not reflect a request for the system to step via the operator commands
{ IDLE_SYSTEM, STEP_SYSTEM, and TERMINATE_SYSTEM, the system is stepping/idling due to
{ system conditions like short_warning, DUEs, monitor_errors, etc.  Make sure the SCB has
{ a step request of 'system_stepped' so the system does not immediately return from the
{ idle loop in MTP$IDLE_180.

    mtv$scb.nos_180_status.system_status.step_status_block.requested_status := mtc$stepped_system;

{ Signal the other processor(s) to begin stepping.

    REPEAT
      mtp$set_lock (mtv$step_lock_0, locked);
    UNTIL locked;
    IF mtv$nosve_control_status.term_or_restart_section = mtc$trs_system_ready_to_step THEN
      mtv$nosve_control_status.step_state := mtc$system_is_stepping;
      mtv$nosve_control_status.term_or_restart_section := mtc$trs_step_processors;
      FOR i := 0 TO osv$cpus_physically_configured - 1 DO
        IF (i <> current_cst_p^.cst_index) AND (mtv$cst0 [i].cpu_state.next_state = osc$cpu_running) THEN
          mtv$trace_p [i] := mtv$cst0 [i].trace_control.buffer_p;
          mtv$cst0 [i].idle_code := idle_code;
          mtp$step_processor (i);
        IFEND;
      FOREND;
      mtv$trace_p [current_cst_p^.cst_index] := current_cst_p^.trace_control.buffer_p;
      current_cst_p^.trace_control.buffer_p := ^mtv$dummy_trace_buffer;
      current_cst_p^.cpu_state.next_state := osc$cpu_stepped;
      first_step_code := idle_code;
      first_step_text := text;
      first_step_text_size := top_line_msg_size;
      IF text(1,4) <> 'ERR=' THEN
        IF (idle_code = syc$ic_fatal_software_error) OR (idle_code = syc$ic_software_breakpoint) THEN
          first_step_text := 'ERR=';  {if appropriate, enforce convention that msg begin with "ERR="}
          first_step_text(5,*) := text;
        IFEND;
      IFEND;
    IFEND;
    mtp$clear_lock (mtv$step_lock_0);

{ End the NOTIFY phase of step processing. Shift the cpu_state.next_state
{ to the cpu_state.current_state.

    IF (current_cst_p^.cpu_state.next_state = osc$cpu_stepped) AND
         (current_cst_p^.processor_state = cmc$on) THEN
      current_cst_p^.ext_int_request.step_processor := FALSE;
      current_cst_p^.cpu_state.current_state := osc$cpu_stepped;
    IFEND;

{ Wait for the other processors to step; they will reach the call to
{ MTP$SET_LOCK below and wait.

    REPEAT
      mtp$set_lock (mtv$step_lock_1, locked);
    UNTIL locked;
    IF mtv$nosve_control_status.term_or_restart_section = mtc$trs_step_processors THEN
      mtv$nosve_control_status.term_or_restart_section := mtc$trs_idle_processors;
      endtime := #free_running_clock (0) + 2000000;
      IF first_step_code <> syc$ic_short_power THEN
        REPEAT
          additional_cpus_not_stepped := 0;
          FOR i := 0 TO osv$cpus_physically_configured - 1 DO
            IF (i <> current_cst_p^.cst_index) AND (mtv$cst0 [i].cpu_state.
                  current_state = osc$cpu_running) THEN
              additional_cpus_not_stepped := additional_cpus_not_stepped + 1;
            IFEND;
          FOREND;
        UNTIL (additional_cpus_not_stepped = 0) OR (#free_running_clock (0) > endtime);
      IFEND;

{ Idle down the peripheral processors used for IO here.  Don't wait for the idle if this is a short_warning.

      IF first_step_code <> syc$ic_short_power THEN
        iop$idle_all_paths (TRUE, status);
      ELSE
        iop$idle_all_paths (FALSE, status);
      IFEND;

    IFEND;
    mtp$clear_lock (mtv$step_lock_1);

{ At this point either 1). all of the CPUs are stepped, or 2). time has run out.
{ At this point the system is stepped and we should be able to come out of this
{ state with an 'UNSTEP' command or a 'RESUME' command (in the case of IDLE_SYSTEM).

    REPEAT
      mtp$set_lock (mtv$step_lock_2, locked);
    UNTIL locked;
    IF mtv$nosve_control_status.term_or_restart_section = mtc$trs_idle_processors THEN
      mtv$nosve_control_status.term_or_restart_section := mtc$trs_stepped_system;

{ It might be nice to see why we stepped.

      mtp$display_to_top_line(first_step_text) ;  {display text that was input to mtp$step_unstep_system}
      IF NOT mtv$operator_console_hung THEN
        dpp$display_error (messages [first_step_code]); {display message corresponding to step_code}
      IFEND;
      mtp$store_informative_statistic (osc$step_statistic, first_step_code);
      mtv$scb.nos_180_status.idle_code := first_step_code;

      CASE first_step_code OF
{ In some cases we do not need a dump during termination.
      = syc$ic_system_terminated =
        IF NOT mtv$scb.kill_180 THEN    {if it was not a DROP VE command, advance ds seq}
          dsp$advance_ds_sequence_in_mtr (dsc$dss_system_terminated);
        IFEND;
      ELSE
{ In other cases, we do.
        ;
      CASEND;
      mtv$scb.nos_180_status.system_status.step_status_block.actual_status := mtc$stepped_system;
      mtv$nosve_control_status.step_state := mtc$system_stepped;
      mtv$nosve_control_status.term_or_restart_section := mtc$trs_system_ready_to_unstep;
      mtv$check_if_hdw_cleared_before := TRUE;
    IFEND;
    mtp$clear_lock (mtv$step_lock_2);

    current_cst_p^.idle_code := idle_code;
    IF (first_step_code = syc$ic_system_terminated) THEN
      dsp$mtr_change_bct_flag (dsc$rb_sds_set_bct_flag, dsc$rb_sds_bct_ts_by_operator);

{ For a TERMINATE_SYSTEM, the OS type must be accounted for.
{ Avoid halting the processor in standalone mode.  The mtp$idle_180
{ call must be used in standalone, lest the processor(s) halt.  mtp$terminate_
{ 180 will RETURN in standalone mode, since there is not a 170 side to
{ run.  ( This is OK in a standalone recovery_complete )

      IF ( osv$170_os_type = osc$ot7_none ) AND  { Standalone T.S.
         ( first_step_code = syc$ic_system_terminated ) THEN
        mtp$idle_180 ( FALSE );                  { NO RETURN FROM HERE.
        mtp$error_stop ( should_not_return );    { Error if return.
      ELSE
        mtp$terminate_180;
        i#program_error;                         { HALTS PROCESSOR
      IFEND;

    ELSEIF (first_step_code = syc$ic_idle_command) OR
        (first_step_code = syc$ic_step_command) OR
        (first_step_code = syc$ic_disk_error) OR
        (first_step_code = syc$ic_software_breakpoint) OR
{!      (first_step_code = syc$ic_hardware_idle) OR} { Code deactivated until we REALLY can do this.
        (first_step_code = syc$ic_long_power)  OR
        (first_step_code = syc$ic_short_power) THEN
{ If we have a short_warning which goes away (i.e. the system stays up) the operator can unstep the system.
      mmp$include_p_reg_in_dump;
      i#mtr_enable_traps (idle_te);
      IF first_step_code = syc$ic_idle_command THEN
        dsp$mtr_change_bct_flag (dsc$rb_sds_set_bct_flag, dsc$rb_sds_bct_sys_has_idled);
      IFEND;
      mtp$idle_180 (TRUE);                                   { TRUE = (system is resumable) }
      dsp$mtr_change_bct_flag (dsc$rb_sds_clear_bct_flag, dsc$rb_sds_bct_sys_has_idled);
      i#mtr_restore_traps (idle_te);
    ELSE { anything else }
      mmp$include_p_reg_in_dump;
      IF osv$170_os_type = osc$ot7_none THEN { Standalone mode; allow Express Deadstart Dump }
        mtp$idle_180 (FALSE);                                { FALSE = (system is not resumable) }
        i#program_error;
      ELSE { NOT Standalone mode; allow K.*RUN dump }
        mtp$terminate_180;
        i#program_error;
      IFEND;
    IFEND;

{ This code furthers the process of UNSTEP_SYSTEM once the system has been trapped
{ or exchanged (exchange goes away in standalone) into becoming active again.

    mtv$nosve_control_status.step_state := mtc$system_is_unstepping;
    IF current_cst_p^.processor_state = cmc$on THEN
      current_cst_p^.cpu_state.current_state := osc$cpu_running;
      current_cst_p^.cpu_state.next_state := osc$cpu_running;
      current_cst_p^.idle_code := syc$ic_null;
      current_cst_p^.cpu_alive_flag := #free_running_clock (0);
    IFEND;

{ Wait for the other processors to unstep; they will reach the call to MTP$SET_LOCK below and wait.

    REPEAT
      mtp$set_lock (mtv$unstep_lock_0, locked);
    UNTIL locked;
    IF mtv$nosve_control_status.term_or_restart_section = mtc$trs_system_ready_to_unstep THEN
      mtv$nosve_control_status.term_or_restart_section := mtc$trs_unstep_processors;
      mtv$step_condition_has_occurred := TRUE;
      IF first_step_code = syc$ic_software_breakpoint  THEN

{ Display again the top line message but this time display it to the Critical Window

        dpp$display_error ('Unstepping from the following Software Breakpoint:');
        dpp$display_error (first_step_text(1,71) );
      IFEND;
      first_step_text := ' ';
      first_step_text_size := top_line_msg_size;
      command_needed_to_unstep_resume := ((first_step_code = syc$ic_idle_command) OR
            (first_step_code = syc$ic_step_command) OR (first_step_code = syc$ic_disk_error) OR
            (first_step_code = syc$ic_software_breakpoint));
      first_step_code := syc$ic_null;

{ Resume the peripheral processors used for IO here.

      iop$resume_all_paths (status);

    IFEND;
    mtp$clear_lock (mtv$unstep_lock_0);

    REPEAT
      mtp$set_lock (mtv$unstep_lock_1, locked);
    UNTIL locked;
    IF mtv$nosve_control_status.term_or_restart_section = mtc$trs_unstep_processors THEN
      endtime := #free_running_clock (0) + 2000000;
      REPEAT
        additional_cpus_not_running := 0;
        FOR i := 0 TO osv$cpus_physically_configured - 1 DO
          IF (i <> current_cst_p^.cst_index) AND (mtv$cst0 [i].cpu_state.
                current_state = osc$cpu_stepped) THEN
            additional_cpus_not_running := additional_cpus_not_running + 1;
          IFEND;
        FOREND;
      UNTIL (additional_cpus_not_running = 0) OR (#free_running_clock (0) > endtime);
      mtv$nosve_control_status.term_or_restart_section := mtc$trs_clean_up_prev_term;
    IFEND;
    mtp$clear_lock (mtv$unstep_lock_1);

{ At this point either 1). all of the CPUs are restarted, or 2). time has run out.

    REPEAT
      mtp$set_lock (mtv$unstep_lock_2, locked);
    UNTIL locked;
    IF mtv$nosve_control_status.term_or_restart_section = mtc$trs_clean_up_prev_term THEN
      mtv$nosve_control_status.term_or_restart_section := mtc$trs_system_ready_to_step;

{ Clear the Top Line message by writing a line of blanks}

      mtp$display_to_top_line (first_step_text);
      IF mtv$scb.nos_180_status.idle_code = mtv$scb.nos_180_status.cause_of_idle THEN
        mtv$scb.nos_180_status.cause_of_idle := first_step_code;
      IFEND;
      mtv$scb.nos_180_status.idle_code := first_step_code;
      IF mtv$scb.nos_180_status.system_status.idle_status_block.actual_status = mtc$idled_system THEN
        IF (NOT mtv$automatic_unstep_resume) OR (command_needed_to_unstep_resume) THEN
          dpp$display_error ('System resuming via console command');
        ELSE {automatic resume}
          dpp$display_error ('System resuming automatically;' CAT
                ' Condition for idle has been cleared');
        IFEND;
      ELSE
        IF (NOT mtv$automatic_unstep_resume) OR (command_needed_to_unstep_resume) THEN
          dpp$display_error ('System unstepped via console command');
        ELSE {automatic resume}
          dpp$display_error ('System unstepped automatically;' CAT
                ' Condition for STEP has been cleared');
        IFEND;
      IFEND;
      mtp$store_informative_statistic (osc$unstep_statistic, first_step_code);
      FOR i := 0 TO osv$cpus_physically_configured - 1 DO
        IF mtv$cst0 [i].processor_state = cmc$on THEN
          mtv$cst0 [i].trace_control.buffer_p := mtv$trace_p [i];
        IFEND;
      FOREND;
    IFEND;
    mtp$clear_lock (mtv$unstep_lock_2);

    IF current_cst_p^.processor_state = cmc$on THEN
      IF keypoints_enabled = 1 THEN
        #write_register (osc$pr_set_keypoint_enable, osc$pr_set_keypoint_enable);
      IFEND;
    IFEND;

    mtv$nosve_control_status.step_state := mtc$system_not_stepped;
    mtv$scb.nos_180_status.system_status.step_status_block.actual_status := mtc$unstepped_system;

{ Reselect the short_warning trap bit.

    local_monitor_mask.int := #read_register (osc$pr_monitor_mask_reg);
    local_monitor_mask.mask := local_monitor_mask.mask + $ost$monitor_conditions [osc$short_warning];
    #write_register (osc$pr_monitor_mask_reg, local_monitor_mask.int);

    IF mtv$ns_xp_p <> NIL THEN
      mtv$ns_xp_p^.monitor_mask := mtv$ns_xp_p^.monitor_mask + $ost$monitor_conditions [osc$short_warning];
    IFEND;

    cmp$enable_all_connections;

    dpv$180_operator_action := FALSE;
    i#mtr_restore_traps (old_te);

  PROCEND mtp$step_unstep_system;

?? TITLE := 'PROCEDURE mtp$step_processor', EJECT ??

  PROCEDURE mtp$step_processor (lpid: ost$logical_processor_id);

    IF mtv$cst0 [lpid].cpu_state.current_state = osc$cpu_stepped THEN
      {return an error- processor already stepped
    ELSE
      mtv$cst0 [lpid].cpu_state.next_state := osc$cpu_stepped;
      IF mtv$cst0 [lpid].processor_state = cmc$on THEN
        mtv$cst0 [lpid].ext_int_request.step_processor := TRUE;
        mtp$interrupt_processor (mtv$cst0 [lpid].memory_port_mask);
        mtv$cst0 [lpid].trace_control.buffer_p := ^mtv$dummy_trace_buffer;
      IFEND;
    IFEND;

  PROCEND mtp$step_processor;

?? TITLE := 'mtp$store_informative_statistic', EJECT??

{ PURPOSE:
{   The following procedure stores a system message in the mainframe_wired
{   segment from where it will be picked up and displayed into the system
{   engineering log by the system job_monitor task when it returns to job_mode.

  PROCEDURE mtp$store_informative_statistic
    (    statistic: ost$terminate_continue_stats;
         idle_code: syt$180_idle_code);

    VAR
      message_data_p: ^SEQ(*),
      message_recorded: boolean,
      message_type: dst$system_logging_types,
      terminate_continue_message: ost$terminate_continue_record;

    mtp$get_date_time_at_timestamp (#FREE_RUNNING_CLOCK (0), terminate_continue_message.date_time);
    terminate_continue_message.log_reason := idle_code;
    terminate_continue_message.log_statistic := statistic;

{ Process the message corresponding to the reason for the call to this procedure.
{ Only the processes of 'stepping' and 'unstepping' will ever call this procedure.

    CASE statistic OF
    = osc$step_statistic =
      message_type := dsc$system_termination;
      terminate_continue_message.log_message.value := 'SYSTEM STEP';
      terminate_continue_message.log_message.size := 11;
      CASE idle_code OF
      = syc$ic_fatal_hardware_error, syc$ic_long_power, syc$ic_hardware_idle, syc$ic_short_power =
        dsp$mtr_save_cause_and_time (#FREE_RUNNING_CLOCK (0), dsc$ssr_sds_cause_mainframe);
      = syc$ic_disk_error =
        dsp$mtr_save_cause_and_time (#FREE_RUNNING_CLOCK (0), dsc$ssr_sds_cause_disk);
      = syc$ic_fatal_software_error, syc$ic_software_breakpoint =
        dsp$mtr_save_cause_and_time (#FREE_RUNNING_CLOCK (0), dsc$ssr_sds_cause_software);
      = syc$ic_system_terminated, syc$ic_idle_command, syc$ic_step_command =
        dsp$mtr_save_cause_and_time (#FREE_RUNNING_CLOCK (0), dsc$ssr_sds_cause_operator);
      ELSE
        dsp$mtr_save_cause_and_time (#FREE_RUNNING_CLOCK (0), dsc$ssr_sds_cause_indeterminate);
      CASEND;
    = osc$unstep_statistic =
      message_type := dsc$system_continuation;
      terminate_continue_message.log_message.value := 'SYSTEM UNSTEP';
      terminate_continue_message.log_message.size := 13;
      dsp$mtr_save_cause_and_time (0, dsc$ssr_sds_cause_operator);
    ELSE
      ;
    CASEND;

    message_data_p := #SEQ (terminate_continue_message);
    dsp$report_system_message (message_data_p, message_type, dsc$informative_message, message_recorded);

  PROCEND mtp$store_informative_statistic;

*copyc cml$system_informative_message
?? TITLE := '  PROCEDURE mtp$store_informative_message', EJECT??

{
{ The following procedure stores an informative system message in the
{ mainframe_wired segment from where it will be picked up and displayed
{ into the system engineering log by the system job_monitor task when
{ it returns to job_mode.
{

  PROCEDURE [XDCL] mtp$store_informative_message (message_to_record: string (*));
*copyc ost$informative_message_record

    VAR
      message_data: ^SEQ(*),
      message_recorded: boolean,
      message_record: ost$informative_message_record;

    message_recorded := FALSE;

    message_record.message_type := cml$system_informative_message;

    IF STRLENGTH (message_to_record) <= osc$max_string_size THEN
      message_record.message := message_to_record;
    ELSE
      message_record.message := message_to_record (1, osc$max_string_size);
    IFEND;

    message_data := #SEQ (message_record);
    dsp$report_system_message (message_data, dsc$general_system_message, dsc$informative_message,
          message_recorded);

  PROCEND mtp$store_informative_message;

?? TITLE := 'PROCEDURE mtp$error_stop', EJECT ??

  PROCEDURE [XDCL] mtp$error_stop (text: string (*<=top_line_msg_size-13) );

    VAR enhanced_text: string (top_line_msg_size);

    enhanced_text ( 1,13) := 'ERR=VEOS1000-';
    enhanced_text (14, *) := text;
    mtp$step_unstep_system (syc$ic_fatal_software_error, enhanced_text);

  PROCEND mtp$error_stop;

?? TITLE := 'PROCEDURE mtp$breakpoint_step', EJECT ??

  PROCEDURE [XDCL] mtp$breakpoint_step (text: string (*<=top_line_msg_size-9));

    VAR  breakpoint_msg: string (top_line_msg_size);

    breakpoint_msg(1,9) := 'VEOS9999-';
    breakpoint_msg(10,*) := text;
    mtp$step_unstep_system (syc$ic_software_breakpoint, breakpoint_msg);

  PROCEND mtp$breakpoint_step;

?? TITLE := 'PROCEDURE cyp$error', EJECT ??

  PROCEDURE [XDCL] cyp$error (ec: integer;
        line: integer;
        module_p: ^string (31));

    VAR
      s: string (63),
      k: integer;

    s := 'CYBIL ERROR xx AT LINE xxxxx OF mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm';
    s (14) := CHR ((ec MOD 10) + ORD ('0'));
    s (13) := CHR ((ec DIV 10) + ORD ('0'));
    s (28) := CHR ((line MOD 10) + ORD ('0'));
    s (27) := CHR (((line MOD 100) DIV 10) + ORD ('0'));
    s (26) := CHR (((line MOD 1000) DIV 100) + ORD ('0'));
    s (25) := CHR (((line MOD 10000) DIV 1000) + ORD ('0'));
    s (24) := CHR ((line DIV 10000) + ORD ('0'));
    s (33, 31) := module_p^;
    mtp$error_stop (s);

  PROCEND cyp$error;
?? TITLE := 'mtp$get_date_time_at_timestamp', EJECT ??

{ PURPOSE:
{   This procedure uses a timestamp obtained during system execution and returns a record containing the
{   compact date and time corresponding to that timestamp.

  PROCEDURE [XDCL] mtp$get_date_time_at_timestamp
    (    timestamp: ost$free_running_clock;
     VAR date_time: ost$date_time);

    CONST
      c$max_years = 2155,  {1980 + 255
      c$ms_per_day = 24 * 60 * 60 * 1000;

    VAR
      base_system_time: ost$base_system_time,
      day: integer,
      days_in_the_month_p: ^ARRAY [1 .. 12] OF 1 .. 31,
      elapsed_time: integer,
      hour: -1 .. 47,
      minute: -30 .. 119,
      month: 1 .. 13,
      second: 0 .. 119,
      year: 0 .. c$max_years;

    base_system_time := osv$base_system_time;
    date_time.millisecond := 0;
    date_time.second := 0;
    date_time.minute := 0;
    date_time.hour := 0;
    date_time.day := 1;
    date_time.month := 1;
    date_time.year := 0;

    elapsed_time {ms} := (timestamp {us} - base_system_time.corresponding_microsecond_clock {us}) DIV 1000
          {us/ms};

    elapsed_time := elapsed_time + (base_system_time.hour * 3600 + base_system_time.minute *
          60 + base_system_time.second) * 1000;

    day := base_system_time.day + (elapsed_time DIV c$ms_per_day);
    elapsed_time := elapsed_time MOD c$ms_per_day;
    IF elapsed_time < 0 THEN
      elapsed_time := elapsed_time + c$ms_per_day;
      day := day - 1;
    IFEND;

    date_time.millisecond := elapsed_time {ms} MOD 1000 {ms} ;

    elapsed_time {sec} := elapsed_time {ms} DIV 1000 {ms/sec} ;
    date_time.second := elapsed_time {sec} MOD 60 {sec} ;

    elapsed_time {min} := elapsed_time {sec} DIV 60 {sec/min} ;
    date_time.minute := elapsed_time {min} MOD 60 {min} ;

    elapsed_time {hr} := elapsed_time {min} DIV 60 {min/hr} ;
    date_time.hour := elapsed_time {hr} MOD 24 {hr} ;

    month := base_system_time.month;
    year := base_system_time.year;

    IF pmp$this_is_a_leap_year (year) THEN
      days_in_the_month_p := ^v$leap_year;
    ELSE
      days_in_the_month_p := ^v$non_leap_year;
    IFEND;

    WHILE day < 1 DO
      IF month = 1 THEN
        month := 13;
        IF (year - 1 {yr} ) < LOWERVALUE (year) THEN
          RETURN;
        IFEND;
        year := year - 1;
        IF pmp$this_is_a_leap_year (year) THEN
          days_in_the_month_p := ^v$leap_year;
        ELSE
          days_in_the_month_p := ^v$non_leap_year;
        IFEND;
      IFEND;
      month := month - 1;
      day := day + days_in_the_month_p^ [month];
    WHILEND;

    WHILE day > days_in_the_month_p^ [month] DO
      day := day - days_in_the_month_p^ [month];
      month := month + 1 {mo} ;

      IF month > 12 {mo} THEN
        IF (year + 1 {yr} ) > UPPERVALUE (year) THEN
          RETURN;
        IFEND;

        month := 1 {mo} ;
        year := year + 1 {yr} ;

        IF pmp$this_is_a_leap_year (year) THEN
          days_in_the_month_p := ^v$leap_year;
        ELSE
          days_in_the_month_p := ^v$non_leap_year;
        IFEND;
      IFEND;
    WHILEND;

    date_time.day := day;
    date_time.month := month;
    date_time.year := year - 1900;

  PROCEND mtp$get_date_time_at_timestamp;

MODEND mtm$system_control;
*DECK DECK=MTP$ABORT_TASK_WITH_DUE EXPAND=FALSE

  PROCEDURE [XREF] mtp$abort_task_with_due
    (    cst_p: ^ost$cpu_state_table;
         xcb_p: ^ost$execution_control_block);

?? PUSH (LISTEXT := ON) ??
*copyc ost$cpu_state_table
*copyc ost$execution_control_block
?? POP ??
*DECK DECK=MTP$BREAKPOINT_STEP EXPAND=FALSE

  PROCEDURE [XREF] mtp$breakpoint_step (text: string(*<=67) );

{  Prefixes 'VEOS9999-' to the string, then steps system }

*DECK DECK=MTP$CLEAR_INTERLOCK EXPAND=FALSE

?? PUSH (LISTEXT := ON) ??
*copyc mtc$debug_constants
*copyc mtp$error_stop
*copyc mtt$monitor_interlock
*copyc osc$processor_defined_registers
?? POP ??

  PROCEDURE [INLINE] mtp$clear_interlock (VAR lock: mtt$monitor_interlock);

    VAR
      b: boolean;


    ?IF mtc$debug_interlocks THEN
      IF lock.id <> #read_register (osc$pr_maintenance_id) THEN
        mtp$error_stop ('MT - Interlock not set');
      IFEND;
    ?IFEND;

    lock.byte := 0;

  PROCEND mtp$clear_interlock;

*DECK DECK=MTP$CLEAR_LOCK EXPAND=FALSE

  PROCEDURE [INLINE] mtp$clear_lock (VAR lock: mtt$monitor_lock);

{ Reading the free running clock in the compare swap loop is to prevent two CPUs
{ from getting in synch on compare swap when one CPU is trying to set a lock while
{ the other CPU is trying to clear the lock.
{ When they get in synch, the compare swap for the set always sees the lock set,
{ while the compare swap for the clear always sees that the other processor has
{ the word locked for compare swap (left 32 bits all ones).

    VAR
      frc: ost$free_running_clock,
      id,
      actual: integer,
      result: 0..2;

    id := #read_register (osc$pr_base_constant);
    REPEAT
      frc := #FREE_RUNNING_CLOCK (0);
      #compare_swap (lock, id, 0, actual, result);
      IF result = 1 THEN
        mtp$error_stop ('MT- wrong initial value for mtp$clear_lock');
      IFEND;
    UNTIL result = 0;

  PROCEND mtp$clear_lock;

?? PUSH (LISTEXT := ON) ??
*copyc mtt$monitor_lock
*copyc osc$processor_defined_registers
*copyc ost$free_running_clock
?? POP ??
*DECK DECK=MTP$CST_P EXPAND=FALSE
  PROCEDURE [INLINE] mtp$cst_p (VAR cst_p: ^ost$cpu_state_table);
?? PUSH ( LISTEXT := ON) ??
    cst_p := #address (1, #segment(^mtv$cst0), #read_register (47(16)));
  PROCEND;
*copyc MTV$CST0
?? POP ??

*DECK DECK=MTP$CST_POINTER EXPAND=FALSE

  FUNCTION [XREF] mtp$cst_pointer (cs_id: (mtc$current_cst, mtc$alternate_cst)):
    ^ost$cpu_state_table;

?? PUSH (LISTEXT := ON) ??
*copyc OST$CPU_STATE_TABLE
?? POP ??
*DECK DECK=MTP$DECONFIGURE_DIVIDE_UNIT EXPAND=FALSE

  PROCEDURE [XREF] mtp$deconfigure_divide_unit
    (    processor_id: ost$processor_id);

?? PUSH (LISTEXT := ON) ??
*copyc ost$processor_id
?? POP ??
*DECK DECK=MTP$ERROR_STOP EXPAND=FALSE

{  PURPOSE:     procedure mtp$error_stop
{    Prefixes 'ERR=VEOS1000-' to the string and calls mtp$step_unstep_system to write string and step system}

  PROCEDURE [XREF] mtp$error_stop (text: string(*<=63) );

*DECK DECK=MTP$GET_DATE_TIME_AT_TIMESTAMP EXPAND=FALSE

  PROCEDURE [XREF] mtp$get_date_time_at_timestamp
    (    timestamp: ost$free_running_clock;
     VAR date_time: ost$date_time);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$free_running_clock
?? POP ??
*DECK DECK=MTP$GET_TIME EXPAND=FALSE

  PROCEDURE [XREF] mtp$get_time (VAR time:string(8));

{  Returns current time in format of 'HH:MM:SS'}


*DECK DECK=MTP$IDLE_180 EXPAND=FALSE

  PROCEDURE [XREF] mtp$idle_180 (resume_permitted: boolean);

*DECK DECK=MTP$INTERRUPT_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] mtp$interrupt_processor (port_mask: ost$cpu_memory_port_mask);

?? PUSH (LISTEXT := ON) ??
*copyc ost$cpu_definitions
?? POP ??
*DECK DECK=MTP$MANAGE_PROCESSOR_WITH_DUE EXPAND=FALSE

  PROCEDURE [XREF] mtp$manage_processor_with_due
    (    processor_id: ost$processor_id);

?? PUSH (LISTEXT := ON) ??
*copyc ost$processor_id
?? POP ??
*DECK DECK=MTP$MONITOR_PROCESSOR_STATUS EXPAND=FALSE

  PROCEDURE [XREF] mtp$monitor_processor_status;

*DECK DECK=MTP$MONITOR_SYSTEM_STATUS EXPAND=FALSE
  PROCEDURE [XREF] mtp$monitor_system_status;

*DECK DECK=MTP$OFF_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] mtp$off_processor (lpid: ost$logical_processor_id);

{*copyc ost$multi_cpu_definitions

*DECK DECK=MTP$PROCESS_170_MTR_REQUESTS EXPAND=FALSE
 PROCEDURE [XREF] mtp$process_170_mtr_requests (rc: mtt$ei_request_code;
        mcr: mtt$eim_mcr_value;
    VAR nos_error: boolean);

*copyc mtt$ei_request_code
*DECK DECK=MTP$RECORD_CRITICAL_HDW_STATUS EXPAND=FALSE

  PROCEDURE [XREF] mtp$record_critical_hdw_status
    (    hardware_option: mtt$scb_hardware_status_options;
         hardware_action: mtt$scb_hardware_status_actions;
         hardware_message: dpt$top_line_message);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$top_line_message
*copyc mtt$scb_hardware_status
?? POP ??
*DECK DECK=MTP$RECORD_NONCRIT_HDW_STATUS EXPAND=FALSE

  PROCEDURE [XREF] mtp$record_noncrit_hdw_status
    (    element_id: dst$mf_element_id);

?? PUSH (LISTEXT := ON) ??
*copyc dst$mf_element_table_entry
?? POP ??
*DECK DECK=MTP$SET_INTERLOCK EXPAND=FALSE

?? PUSH (LISTEXT := ON) ??
*copyc mtc$debug_constants
*copyc mtp$error_stop
*copyc mtt$monitor_interlock
*copyc osc$processor_defined_registers
?? POP ??

  PROCEDURE [INLINE] mtp$set_interlock (VAR lock: mtt$monitor_interlock);

    VAR
      b: boolean;


    ?IF mtc$debug_interlocks THEN
      IF lock.id = #read_register (osc$pr_maintenance_id) THEN
        mtp$error_stop ('MT - Interlock already set');
      IFEND;
    ?IFEND;

    REPEAT
     #TEST_SET (lock.locked, b);
    UNTIL NOT b;

    ?IF mtc$debug_interlocks THEN
      lock.id := #read_register (osc$pr_maintenance_id);
    ?IFEND;


  PROCEND mtp$set_interlock;

*DECK DECK=MTP$SET_LOCK EXPAND=FALSE

  PROCEDURE [INLINE] mtp$set_lock (VAR lock: mtt$monitor_lock;
    VAR locked: boolean);

{ Reading the free running clock in the compare swap loop is to prevent two CPUs
{ from getting in synch on compare swap when one CPU is trying to set a lock while
{ the other CPU is trying to clear the lock.
{ When they get in synch, the compare swap for the set always sees the lock set,
{ while the compare swap for the clear always sees that the other processor has
{ the word locked for compare swap (left 32 bits all ones).

    VAR
      frc: ost$free_running_clock,
      id,
      actual: integer,
      result: 0.. 2;

    id := #read_register (osc$pr_base_constant);
    REPEAT
      frc := #FREE_RUNNING_CLOCK (0);
      #compare_swap (lock, 0, id, actual, result);
    UNTIL result <> 2;
    IF result = 0 THEN
      locked := TRUE;
    ELSE
      locked := FALSE;
    IFEND;

  PROCEND mtp$set_lock;

?? PUSH (LISTEXT := ON) ??
*copyc mtt$monitor_lock
*copyc osc$processor_defined_registers
*copyc ost$free_running_clock
?? POP ??
*DECK DECK=MTP$SET_STATUS_ABNORMAL EXPAND=FALSE
  PROCEDURE [INLINE] mtp$set_status_abnormal (identifier: string (2);
        condition: osc$max_status_condition_number + 1 .. 0ffffffffff(16);
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
    status.normal := FALSE;
    status.condition := condition;
  PROCEND mtp$set_status_abnormal;
*copyc osc$max_status_condition_number
?? POP ??
*DECK DECK=MTP$SPIN_CPU EXPAND=FALSE

  PROCEDURE [XREF] mtp$spin_cpu;

*DECK DECK=MTP$STEP_UNSTEP_SYSTEM EXPAND=FALSE

{  PURPOSE:    procedure mtp$step_unstep_system
{     Writes a line of text to the Top Line of the console.  If the idle code specified indicates an error
{     (i.e. not an operator command or a recovery), then 'ERR=' must be first 4 characters or it will be
{     prefixed.  Then the system is Terminated, Aborted, Stepped, or Idled per the idle code specified.
{     All messages sent to the Top Line must have a VEOSxxxx code in the text.  Guidelines for using
{     VEOSxxxx codes and a list of all VEOSxxxx codes are documented in the comments found in the proc
{     dpp$display_error which is in the deck dpm$system_console_monitor.

  PROCEDURE [XREF] mtp$step_unstep_system
        (term_code: syt$180_idle_code; text: string(*<=76) );

?? PUSH (LISTEXT := ON)??
*copyc syt$180_idle_code
?? POP ??
*DECK DECK=MTP$STORE_INFORMATIVE_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] mtp$store_informative_message (message_to_record: string (*));
*DECK DECK=MTP$TERMINATE_180 EXPAND=FALSE

  PROCEDURE [XREF] mtp$terminate_180;

*DECK DECK=MTT$170_DUE_INFO EXPAND=FALSE

{ NOS Detected Uncorrected Error Information

  TYPE
    mtt$170_due_info = record
      time_last_due: integer,
      proc_malf_count: 0 .. 0ff(16),
      due_count: ost$parcel,
      aborted_job_count: integer,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ost$parcel
?? POP ??
*DECK DECK=MTT$CPU_DECONFIGURATION_RESULT EXPAND=FALSE
*DECK DECK=MTT$CPU_SELF_NONSELF EXPAND=FALSE
*DECK DECK=MTT$DUAL_STATE_CONTROL_BLOCK EXPAND=FALSE

  TYPE
    mtt$dual_state_control_block = RECORD

      d7ty: PACKED RECORD                        { C170 OS type
        undefined: 0 .. 0f(16),
        rfu: 0 .. 77(8),
        date: 0 .. 777777(8),
        time: 0 .. 777777(8),
        c170_os_type: 0 .. 77(8),
        version: 0 .. 77(8),
        c170_interface_level: 0 .. 77(8),
      RECEND,

      d7jp0: PACKED RECORD                       { C170 job parameters for cpu 0
        undefined: 0 .. 0f(16),
        job_unique_id: 0 .. 0fffffffff(16),
        trap_180: 0 .. 0ff(16),
        cpu_priority: 0 .. 0ff(16),
        sub_priority: 0 .. 0f(16),
        quantum: 0 .. 0f(16),
      RECEND,

      d7jp1: PACKED RECORD                       { C170 job parameters for cpu 1
        undefined: 0 .. 0f(16),
        job_unique_id: 0 .. 0fffffffff(16),
        trap_180: 0 .. 0ff(16),
        cpu_priority: 0 .. 0ff(16),
        sub_priority: 0 .. 0f(16),
        quantum: 0 .. 0f(16),
      RECEND,

      d7st: PACKED RECORD                        { C170 OS status
        undefined: 0 .. 0f(16),
        operational_mode: boolean,
        maintenance_mode: boolean,
        step_mode: boolean,
        operator_action: boolean,
        operator_date_time_update: boolean,
        rfu1: 0..7,
        checkpoint_complete: boolean,
        checkpoint_in_progress: boolean,
        rfu2: 0 .. 17777(8),
        drop_ve_flag: boolean,
        mlst_fwa: 0 .. 777777(8),
        mlst_length: 0 .. 77(8),
        rfu3: 0 .. 7777(8),
      RECEND,

      d7rs0: PACKED RECORD                       { C170 MDD save area for PP resident
        undefined: 0 .. 0f(16),
        rfu: 0 .. 07777(8),
        mdd_initiated_by_cti: boolean,
        scd_nos_active: boolean,
        c170_mdd_mode: boolean,
        mdd_port_number: 0 .. 7(8),
        pp_number: 0 .. 77(8),
        pp_resident_length: 0 .. 7777(8),
        fwa_save_area: 0 .. 77777777(8),
      RECEND,

      d7rs1: PACKED RECORD                       { C170 reserved
        undefined: 0 .. 0f(16),
        rfu1: 0 .. 0fffffff(16),
        rfu2: 0 .. 0ffffffff(16),
      RECEND,

      d7rs2: PACKED RECORD                       { SCI table
        undefined: 0 .. 0f(16),
        rfu: 0 .. 07ffffff(16),
        scipt_in_the_ssr: boolean,
        sci_table: 0 .. 0ffffffff(16),
      RECEND,

      d7cm0: PACKED RECORD                       { C170 memory allocation
        undefined: 0 .. 0f(16),
        rfu: 0 .. 7777(8),
        c170_minimum_cm: 0 .. 77777777(8),
        nve_static_block_size: 0 .. 77777777(8),
      RECEND,

      d7cm1: PACKED RECORD
        undefined: 0 .. 0f(16),
        rfu: 0 .. 7777(8),
        nve_block_fwa: 0 .. 77777777(8),
        nve_block_lwa: 0 .. 77777777(8),
      RECEND,

      d7sv0: RECORD                              { C170 save area
        last_180_cp_time_cpu0: integer,
      RECEND,

      d7sv1: RECORD
        last_180_cp_time_cpu1: integer,
      RECEND,

      d7sv2: PACKED RECORD
        undefined: 0 .. 0f(16),
        rfu: 0 .. 0fffffff(16),
        nos_system_version_rma: 0 .. 0ffffffff(16),
      RECEND,

      d7sv3: PACKED RECORD
        undefined: 0 .. 0f(16),
        rfu: 0 .. 0fffffff(16),
        nos_nbe_system_id_rma: 0 .. 0ffffffff(16),
      RECEND,

      d7sv4: PACKED RECORD
        undefined: 0 .. 0f(16),
        rfu1: 0 .. 0fffffff(16),
        rfu2: 0 .. 0ffffffff(16),
      RECEND,

      d7sv5: PACKED RECORD
        undefined: 0 .. 0f(16),
        rfu1: 0 .. 0fffffff(16),
        rfu2: 0 .. 0ffffffff(16),
      RECEND,

      d8ty: PACKED RECORD                        { C180 OS type
        nosve_psr_level: 0 .. 0ffffffff(16),
        rfu: 0 .. 3f(16),
        ei_version: 0 .. 0ff(16),
        c180_os_type: 0 .. 3f(16),
        version: 0 .. 3f(16),
        c180_interface_level: 0 .. 3f(16),
      RECEND,

      d8tm0: RECORD                              { C180 CPU time for cpu 0
        cpu_time_for_cpu0: integer,
      RECEND,

      d8tm1: RECORD                              { C180 CPU time for cpu 1
        cpu_time_for_cpu1: integer,
      RECEND,

      d8jp0: PACKED RECORD                       { C180 job parameters for cpu 0
        rfu: 0 .. 0ffffffffff(16),
        os_active: 0 .. 0ff(16),
        cpu_priority: 0 .. 0ff(16),
        unused: 0 .. 0f(16),
        sub_priority: 0 .. 0f(16),
      RECEND,

      d8jp1: PACKED RECORD                       { C180 job parameters for cpu 1
        rfu: 0 .. 0ffffffffff(16),
        os_active: 0 .. 0ff(16),
        cpu_priority: 0 .. 0ff(16),
        unused: 0 .. 0f(16),
        sub_priority: 0 .. 0f(16),
      RECEND,

      d8st: PACKED RECORD                        { C180 OS status
        rfu1: 0 .. 07f(16),
        operator_action: boolean,
        rfu2: 0 .. 07ff(16),
        sci_iou_model_number: 0 .. 0ff(16),
        sci_is_nosve_pp: boolean,
        sci_pp_number: 0 .. 0fff(16),
        sci_port_number: 0 .. 3f(16),
        sci_iou_number: 0 .. 3,
        rfu3: 0 .. 0f(16),
        dfts_load_flag: boolean,
        sci_deadstart_status: 0 .. 1f(16),
        rfu4: 0 .. 1f(16),
        sci_should_deadstart_nosve: boolean,
      RECEND,

      d8ds0: PACKED RECORD                       { C180 deadstart control
        deadstart_status: 0 .. 0ffffffff(16),
        deadstart_flag: 0 .. 0ffffffff(16),
      RECEND,

      d8ds1: PACKED RECORD
        rma_of_ei_stack: 0 .. 0ffffffff(16),
        rma_of_ei_jps: 0 .. 0ffffffff(16),
      RECEND,

      d8ds2: PACKED RECORD
        rma_of_stack: 0 .. 0ffffffff(16),
        rma_of_jps: 0 .. 0ffffffff(16),
      RECEND,

      d8sv0: RECORD                              { C180 save area
        rma_of_pp_address_table: integer,
      RECEND,

      d8sv1: RECORD
        ssr_pointer: integer,
      RECEND,

      d8sv2: RECORD
        temp_dft_block_dual_state_1: integer,
      RECEND,

      d8sv3: RECORD
        temp_dft_block_dual_state_2: integer,
      RECEND,

      d8sv4: RECORD
        rfu: integer,
      RECEND,

      d8sv5: RECORD
        rfu: integer,
      RECEND,

      dscm0: PACKED RECORD                       { System-wide status
        rfu1: 0 .. 0f(16),
        dscm_interlock: boolean,
        rfu2: 0 .. 07ff(16),
        retries_cpu0: 0 .. 0ff(16),
        cpu0_error: 0 .. 0ff(16),
        retries_cpu1: 0 .. 0ff(16),
        cpu1_error: 0 .. 0ff(16),
        iou_error_pp_number: 0 .. 0ff(16),
        iou_error_code: 0 .. 0ff(16),
      RECEND,

      dscm1: RECORD
        zero_filled: integer,
      RECEND,

      dscm2: RECORD
        cti_cm_directory_pointer: dst$r_pointer,
      RECEND,

      dscm3: RECORD
        dft_os_buffer_pointer: dst$r_pointer,
      RECEND,

      dscm4: RECORD
        zero_filled: integer,
      RECEND,

      dfcm0: PACKED RECORD                       { DFT/SCI/EI message header
        rfu1: 0 .. 0ffff(16),
        msg_length: 0 .. 0ffff(16),
        rfu2: 0 .. 0ffff(16),
        cnt: 0 .. 0ffff(16),
      RECEND,

      dfcm1: RECORD                              { DFT/SCI/EI message
        message_1: string (8),
      RECEND,

      dfcm2: RECORD
        message_2: string (8),
      RECEND,

      dfcm3: RECORD
        message_3: string (8),
      RECEND,

      dfcm4: RECORD
        previous_message_1: string (8),          { DFT/SCI/EI message from previous deadstart
      RECEND,

      dfcm5: RECORD
        previous_message_2: string (8),
      RECEND,

      dfcm6: RECORD
        previous_message_3: string (8),
      RECEND,

      dfcm7: RECORD                              { Packed wall clock chip date and time
        packed_wall_clock_chip: integer,
      RECEND,

      dfcm8: RECORD                              { Pointer to Critical Page Table
        critical_page_table_pointer: dst$r_pointer,
      RECEND,

      dfcm9: RECORD                              { Pointer to DFT/SCI relocation
        cpu_pp_communication_buffer: dst$r_pointer,
      RECEND,

      dfcm10: RECORD                             { SCI statistics
        rfu: 0 .. 0ffff(16),
        sci_overlay_loads: 0 .. 0ffff(16),
        sci_mdd_cm_writes: 0 .. 0ffff(16),
        sci_mdd_mr_writes: 0 .. 0ffff(16),
      RECEND,
    RECEND;

*copyc dst$r_pointer
*DECK DECK=MTT$DUE_LOG EXPAND=FALSE

{Define types used for logging DUE errors in a circular buffer in 180 monitor.

  CONST
    mtc$due_log_entry_count = 4;


  TYPE

    mtt$due_log_entries = 0 .. mtc$due_log_entry_count,

    mtt$due_log = RECORD
      lock: ALIGNED [0 MOD 8] mtt$monitor_lock,
      header: ALIGNED [0 MOD 8] string(7),
      next_i: mtt$due_log_entries,
      total_due_count: ALIGNED [0 MOD 8] ARRAY [mtt$due_state] of PACKED ARRAY [boolean {damaged}] of
            ost$parcel,
      dues: ALIGNED [0 MOD 8] ARRAY [1 .. mtc$due_log_entry_count] of mtt$due_log_entry,
    RECEND,

    mtt$due_log_entry = RECORD
      due_state: mtt$due_state,
      process_damaged: boolean,
      task_id: ost$global_task_id,
      time: ALIGNED [0 MOD 8] ost$free_running_clock,
      xp: ost$exchange_package,
      fill2: integer,
      fill3: integer,
    RECEND;

*copyc mtt$monitor_lock
*copyc OST$HARDWARE_SUBRANGES
*copyc OST$EXCHANGE_PACKAGE
*copyc OST$GLOBAL_TASK_ID
*DECK DECK=MTT$DUE_STATE EXPAND=FALSE
  TYPE
    mtt$due_state = (mtc$due_in_180_job, mtc$due_in_nos, mtc$due_in_180_monitor);
*DECK DECK=MTT$EI_REQUEST_CODE EXPAND=FALSE
 TYPE
    mtt$ei_request_code = (mtc$eim_system_call, mtc$eim_log_c170_cpu_error,
      mtc$eim_uncorrected_err),
    mtt$eim_mcr_value = 0 .. 0ffff(16);
*DECK DECK=MTT$MONITOR_CONDITIONS EXPAND=FALSE

{ This TYPE is identical to the TYPE ost$monitor_condition with the following
{ exception: the osc$not_assigned bit is now used in monitor to track the
{ current state of the trap enabled register.  Functionally, this is used ONLY
{ on THETA-class (model 4X) machines.

  CONST
    mtc$mcr_trap_enable_flag = osc$not_assigned;

  TYPE
    mtt$monitor_condition = ost$monitor_condition;

  TYPE
    mtt$monitor_conditions = set OF mtt$monitor_condition;

*copyc osd$conditions
*DECK DECK=MTT$MONITOR_INTERLOCK EXPAND=FALSE

{ Define byte used for monitor mode interlocks. The left most bit is used by
{ #TEST_SET_BIT as the interlock bit. If monitor is compiled with debug code active,
{ then bits 1 thru 7 will contain the CPU# that has the interlock.

  TYPE
    mtt$monitor_interlock = PACKED RECORD
      CASE boolean OF
      = FALSE =
        byte: 0 .. 255,
      = TRUE =
        locked: boolean,
        id: 0 .. 7f(16),
      CASEND,
    RECEND;
*DECK DECK=MTT$MONITOR_LOCK EXPAND=FALSE
  TYPE
    mtt$monitor_lock = integer;
*DECK DECK=MTT$MONITOR_XP_SLOT_POINTERS EXPAND=FALSE

  TYPE
    mtt$monitor_xp_slot_pointers = RECORD
      slot_1_p: ^cell,
      slot_2_p: ^cell,
    RECEND;
*DECK DECK=MTT$NOSVE_CONTROL_STATUS EXPAND=FALSE

{ This record describe the current state of the system.

  TYPE
    mtt$nosve_control_status = RECORD
      idle_state: mtt$idle_state,
      step_state: mtt$step_state,
      term_or_restart_section: mtt$term_or_restart_section,
    RECEND,

{ Describe the possible IDLE and STEP states of the system, and the section in the
{ STEP sequence which is being executed within the procedure MTP$STEP_UNSTEP_SYSTEM.

    mtt$idle_state = (mtc$system_not_idle, mtc$idle_system_in_progress,
          mtc$resume_system_in_progress, mtc$system_idle),
    mtt$step_state = (mtc$system_not_stepped, mtc$system_is_stepping,
          mtc$system_is_unstepping, mtc$system_stepped),
    mtt$term_or_restart_section = (mtc$trs_system_ready_to_step, mtc$trs_step_processors,
          mtc$trs_idle_processors, mtc$trs_stepped_system, mtc$trs_system_ready_to_unstep,
          mtc$trs_unstep_processors, mtc$trs_clean_up_prev_term);

*DECK DECK=MTT$REQUEST_INTERLOCK_TABLE EXPAND=FALSE

{ NOTE: If this record changes, be sure to make corresponding changes to the
{ ASSEMBLE record declaration for the interlock table "il_tbl".

  TYPE
    mtt$m_r_i_t_entry = RECORD
      flag: 0 .. 0ff(16),
      fill: 0 .. 0ff(16),
      locking_cpu: ^ost$cpu_state_table,
    RECEND,

    mtt$request_interlock_table = ARRAY [0 .. mtc$maximum_il_table_index] of mtt$m_r_i_t_entry;

  CONST
    mtc$maximum_il_table_index = 5;

*copyc ost$cpu_state_table
*DECK DECK=MTT$REQUEST_TABLE EXPAND=FALSE

  TYPE
    mtt$m_r_t_entry = record
      high_ring: 0 .. 15,
      il_ordinal: 0 .. 255,
      req_code: 0 .. 255,
      fill: 0 .. 0ffffffffff(16),
      total_cpu_time: integer,
      max_time: 0 .. 0ffffffff(16),
      count: 0 .. 0ffffffff(16),
    recend;

  TYPE
    mtt$request_table = array [0 .. syc$rc_maximum_value] of mtt$m_r_t_entry;

*copyc SYC$MONITOR_REQUEST_CODES
*DECK DECK=MTT$SCB_HARDWARE_STATUS EXPAND=FALSE

{ TYPE deck MTT$SCB_HARDWARE_STATUS

{ WARNING!!!!!
{ If the following TYPE (subrange) is modified, then the TYPE
{ mtt$scb_trick_variant_record MUST be changed.  See the comments
{ above the variant record definition further on.

  TYPE
    mtt$scb_hardware_status_options = (mtc$scb_short_warning_step,
          mtc$scb_hardware_failure_step, mtc$scb_long_warning_idle,
          mtc$scb_hardware_failure_idle, mtc$scb_170_status);

  TYPE
    mtt$scb_hardware_status_actions = (mtc$scb_hsa_set, mtc$scb_hsa_clear);

  TYPE
    mtt$scb_hardware_status_count = 0 .. mtc$scb_max_hardware_status,

    mtt$scb_hardware_status = ARRAY [mtt$scb_hardware_status_options] OF
          mtt$scb_hardware_status_count;

  TYPE
    mtt$scb_hardware_status_msg = RECORD
      message_read: boolean,
      message: dpt$top_line_message,
    RECEND,

    mtt$scb_hardware_status_msgs = ARRAY [mtt$scb_hardware_status_options]
          OF mtt$scb_hardware_status_msg;

{ WARNING!!!!!
{ The following record MUST be modified if the TYPE mtt$scb_hardware_status
{ changes.  The ERRORS_PRESENT variant must be the same length as the
{ HARDWARE_STATUS variant; i.e. there must be as many bytes in the
{ ERRORS_PRESENT field as there are ordinals in the TYPE
{ mtt$scb_hardware_status_options (above).

  TYPE
    mtt$scb_trick_variant_record = RECORD
      CASE 0..1 OF
      = 0 =
        hardware_status: mtt$scb_hardware_status,
      = 1 =
        errors_present: 0 .. 0ffffffffff(16),
      CASEND,
    RECEND;

*copyc dpt$top_line_message
*copyc mtc$scb_max_hardware_status
*DECK DECK=MTT$SMU_COMMUNICATIONS_BLOCK EXPAND=FALSE
{ This deck defines the format of the SMU Communications Block (SCB). The SCB is
{ used by the the 180 CPU Monitor to maintain information about the status of the
{ 180 OS and hardware.

  TYPE
    mtt$smu_communications_block = RECORD
      hardware_status: ALIGNED [0 MOD 8] mtt$scb_hardware_status,
      cpus: mtt$scb_cpu_information,
      kill_180: ALIGNED [0 MOD 8] boolean,
      vector_simulation_control: ost$vector_simulation_control,
      nos_180_status: ALIGNED [0 MOD 8] mtt$scb_180_status,
      nos_service_flag: ALIGNED [0 MOD 8] integer,
      critical_message_time_stamp: ALIGNED [0 MOD 8] integer,
      hardware_status_messages: mtt$scb_hardware_status_msgs,
    RECEND,

    mtt$scb_cpu_information = RECORD
      logically_on: ost$processor_id_set,
      available_for_use: ost$processor_id_set,
      hdw_state_change: ost$processor_id_set,
    RECEND,

{ The following field is maintained by the CPU and contains the dynamic status
{ of the 180 Operating system.

    mtt$scb_180_status = RECORD
      system_status: mtt$system_status_block,
      idle_code: syt$180_idle_code,
      fill_1: 0..0ffff(16),
      cause_of_idle: syt$180_idle_code,
    RECEND,

{ The following record contains the requested and actual status' of the
{ system for IDLE and STEP.

    mtt$system_status_block = RECORD
      idle_status_block: mtt$idle_status_block,
      step_status_block: mtt$step_status_block,
    RECEND,

{ Describe the layout of the IDLE and STEP status blocks. When the REQUESTED
{ and ACTUAL fields are not the same, the system will be driven to the state
{ found in the REQUESTED fields.

    mtt$step_status_block = RECORD
      requested_status,
      actual_status: mtt$system_step_update_request,
    RECEND,

    mtt$idle_status_block = RECORD
      requested_status,
      actual_status: mtt$system_idle_update_request,
    RECEND;

*copyc mtt$scb_hardware_status
*copyc mtt$system_update_requests
*copyc ost$processor_id_set
*copyc ost$vector_simulation_control
*copyc syt$180_idle_code
*DECK DECK=MTT$SYSTEM_STATE EXPAND=FALSE

  TYPE
    mtt$system_state = (mtc$ss_no_checkpoint, mtc$ss_checkpoint_in_progress,
      mtc$ss_checkpoint_complete),
    mtt$step_code = (mtc$sc_no_step, mtc$sc_step),
    mtt$mem_status = (mtc$page_restored, mtc$page_lost);
*DECK DECK=MTT$SYSTEM_UPDATE_REQUESTS EXPAND=FALSE

  TYPE
    mtt$system_step_update_request = (mtc$unstepped_system, mtc$stepped_system),
    mtt$system_idle_update_request = (mtc$running_system, mtc$idled_system);
*DECK DECK=MTT$SYS_STAT_UPDATE_REQUEST EXPAND=FALSE

  TYPE
    mtt$sys_stat_update_request = (mtc$ssur_step_system, mtc$ssur_unstep_system,
          mtc$ssur_idle_system, mtc$ssur_resume_system);
*DECK DECK=MTV$170_DUE_INFO EXPAND=FALSE

{ 170 dualstate partner DUE information.

  VAR
    mtv$170_due_info: [XREF] mtt$170_due_info;

?? PUSH (LISTEXT := ON) ??
*copyc mtt$170_due_info
?? POP ??
*DECK DECK=MTV$ABORTED_TASK_THRESHOLD EXPAND=FALSE

  VAR
    mtv$aborted_task_threshold: [XREF] integer;

*DECK DECK=MTV$ALL_CPUS_HAVE_BEEN_STARTED EXPAND=FALSE

  VAR
    mtv$all_cpus_have_been_started: [XREF] boolean;

*DECK DECK=MTV$AUTOMATIC_UNSTEP_RESUME EXPAND=FALSE

  VAR
    mtv$automatic_unstep_resume: [XREF] boolean;

*DECK DECK=MTV$CST0 EXPAND=FALSE

  VAR
    mtv$cst0: [XREF] ost$state_tables;

?? PUSH (LISTEXT := ON) ??
*copyc OST$CPU_STATE_TABLE
?? POP ??
*DECK DECK=MTV$DFT_BLOCK_P EXPAND=FALSE

  {Pointer to the DFT control word}

  VAR
    mtv$dft_block_p: [XREF] ^dst$dftb_control_word;

?? PUSH (LISTEXT := ON) ??
*copyc dst$180_dft_block
?? POP ??
*DECK DECK=MTV$DUAL_STATE_CPU_NUMBER EXPAND=FALSE

  VAR
    mtv$dual_state_cpu_number: [XREF] ost$processor_id;

?? PUSH (LISTEXT := ON) ??
*copyc ost$processor_id
?? POP ??
*DECK DECK=MTV$DUMMY_TRACE_BUFFER EXPAND=FALSE

{ Trace buffer used when system idle.}

  VAR
    mtv$dummy_trace_buffer: [XREF] integer;
*DECK DECK=MTV$EXECUTING_AJL_AT_FAILURE EXPAND=FALSE
{ Ordinal of job executing at time of system failure (0 if system)}

VAR
  mtv$executing_ajl_at_failure: [XREF] array [0 .. 1] of integer;
*DECK DECK=MTV$FIRST_CPU_MONITOR_STACK_P EXPAND=FALSE

  VAR
    mtv$first_cpu_monitor_stack_p: [XREF] ^cell;
*DECK DECK=MTV$HALT_CPU_RING_NUMBER EXPAND=FALSE
{If a MCR fault occurs in a task executing in a ring <= the value
{of this variable, Monitor will halt the CPU. The variable is located
{in Monitor and is intended to be used for debug only.

  VAR
    mtv$system_haltring: [XREF] 0 .. 255,
    mtv$halt_cpu_ring_number: [XREF] 0 .. 255;
*DECK DECK=MTV$HALT_ON_CPU_TIMEOUT EXPAND=FALSE
VAR
  mtv$halt_on_cpu_timeout: [XREF] boolean;
*DECK DECK=MTV$HALT_ON_PROC_MALF EXPAND=FALSE

  VAR
    mtv$halt_on_proc_malf: [XREF] boolean;
*DECK DECK=MTV$IDLE_MESSAGE_LINE EXPAND=FALSE

  VAR
    mtv$idle_message_line: [XREF] dpt$console_line;

?? PUSH (LISTEXT := ON) ??
*copyc dpt$console_line
?? POP ??
*DECK DECK=MTV$IDLE_STEP_MESSAGE EXPAND=FALSE

  VAR
    mtv$idle_step_message: [XREF] dpt$top_line_message;

?? PUSH (LISTEXT := ON) ??
*copyc dpt$top_line_message
?? POP ??
*DECK DECK=MTV$KNOWN_JOB_WARNING EXPAND=FALSE
{Maximum number of KJL entries.}

  VAR
    mtv$known_job_warning: [XREF] 0 .. 0ffffffff(16);
*DECK DECK=MTV$MAXIMUM_PROCESSOR_SET EXPAND=FALSE

  VAR
    mtv$maximum_processor_set: [XREF] ost$processor_id_set;

?? PUSH (LISTEXT := ON) ??
*copyc ost$processor_id_set
?? POP ??
*DECK DECK=MTV$MAX_ASYNC_LOCK_TIME EXPAND=FALSE
{Maximum time allowed for monitor async lock to be set before calling smu

VAR
  mtv$max_async_lock_time: [XREF] integer;
*DECK DECK=MTV$MONITOR_EXCHANGE_PACKAGE EXPAND=FALSE

  VAR
    mtv$monitor_exchange_package: [XREF] ost$exchange_package;

?? PUSH (LISTEXT := ON) ??
*copyc OST$EXCHANGE_PACKAGE
?? POP ??
*DECK DECK=MTV$MONITOR_SEGMENT_TABLE EXPAND=FALSE
{Monitor segment table.}

  VAR
    mtv$monitor_segment_table: [XREF] record
      st: ALIGNED [0 MOD 8] array [0 .. 4095] of mmt$segment_descriptor,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc MMT$SEGMENT_DESCRIPTOR_TABLE
?? POP ??
*DECK DECK=MTV$MONITOR_STACK_CPU_0_P EXPAND=FALSE
*DECK DECK=MTV$MONITOR_XP_SLOT_POINTERS EXPAND=FALSE

  VAR
    mtv$monitor_xp_slot_pointers: [XREF] mtt$monitor_xp_slot_pointers;

?? PUSH (LISTEXT := ON) ??
*copyc mtt$monitor_xp_slot_pointers
?? POP ??
*DECK DECK=MTV$MX_AJL_ENTRIES EXPAND=FALSE
{Maximum number of AJL entries - number of jobs resident in memory.}

  VAR
    mtv$mx_ajl_entries: [XREF] 0 .. 0ffffffff(16);
*DECK DECK=MTV$MX_SEGMENTS EXPAND=FALSE
{Maximum number of segments in the system (number of ASIDs).}

  VAR
    mtv$mx_segments: [XREF] 0 .. 0ffffffff(16);
*DECK DECK=MTV$NOSVE_CONTROL_STATUS EXPAND=FALSE

  VAR
    mtv$nosve_control_status: [XREF] mtt$nosve_control_status;

?? PUSH (LISTEXT := ON) ??
*copyc mtt$nosve_control_status
?? POP ??
*DECK DECK=MTV$NOS_SEGMENT_TABLE_P EXPAND=FALSE
{NOS segment table.

  VAR
    mtv$nos_segment_table_p: [XREF] ^ RECORD
      st: ALIGNED [0 MOD 8] array [0 .. *] OF mmt$segment_descriptor,
    RECEND;
?? PUSH (LISTEXT := ON) ??
*copyc mmt$segment_descriptor_table
?? POP ??
*DECK DECK=MTV$NST_P EXPAND=FALSE

  VAR
    mtv$nst_p: [XREF] ^mtt$dual_state_control_block;

?? PUSH (LISTEXT := ON) ??
*copyc mtt$dual_state_control_block
?? POP ??
*DECK DECK=MTV$NS_XP_P EXPAND=FALSE
{Pointer to NOS170 XP.}

  VAR
    mtv$ns_xp_p: [XREF] ^ost$exchange_package;

?? PUSH (LISTEXT := ON) ??
*copyc OST$EXCHANGE_PACKAGE
?? POP ??
*DECK DECK=MTV$OPERATOR_CONSOLE_HUNG EXPAND=FALSE

  VAR
    mtv$operator_console_hung: [XREF] boolean;


*DECK DECK=MTV$OUTPUT_FILE_WARNING EXPAND=FALSE
{Maximum number of KOL entries.}

  VAR
    mtv$output_file_warning: [XREF] 0 .. 0ffffffff(16);
*DECK DECK=MTV$PROCESSOR_DUE_THRESHOLD EXPAND=FALSE

  VAR
    mtv$processor_due_threshold: [XREF] integer;

*DECK DECK=MTV$PROCESSOR_MODE EXPAND=FALSE

{Used to convey whether system was in job mode or monitor mode at recovery time

VAR
    mtv$processor_mode: [XREF] array [0 .. 1] of integer;
*DECK DECK=MTV$REQUEST_INTERLOCK_TABLE EXPAND=FALSE

  VAR
    mtv$request_interlock_table: [XREF] mtt$request_interlock_table;

?? PUSH (LISTEXT := ON) ??
*copyc mtt$request_interlock_table
?? POP ??
*DECK DECK=MTV$REQUEST_TABLE EXPAND=FALSE

  VAR
    mtv$request_table: [XREF] mtt$request_table;

?? PUSH (LISTEXT := ON) ??
*copyc MTT$REQUEST_TABLE
??pop??
*DECK DECK=MTV$RESET_ALL_CACHE_NOW EXPAND=FALSE

     VAR
       mtv$reset_all_cache_now: [XREF] boolean;
*DECK DECK=MTV$SCB EXPAND=FALSE

  VAR
    mtv$scb: [XREF] mtt$smu_communications_block;

?? PUSH (LISTEXT := ON) ??
*copyc mtt$smu_communications_block
?? POP ??
*DECK DECK=MTV$STEP_LOCK_0 EXPAND=FALSE

  VAR
    mtv$step_lock_0: [XREF] mtt$monitor_lock;

?? PUSH (LISTEXT := ON) ??
*copyc mtt$monitor_lock
?? POP ??
*DECK DECK=MTV$STEP_LOCK_1 EXPAND=FALSE

  VAR
    mtv$step_lock_1: [XREF] mtt$monitor_lock;

?? PUSH (LISTEXT := ON) ??
*copyc mtt$monitor_lock
?? POP ??
*DECK DECK=MTV$STEP_LOCK_2 EXPAND=FALSE

  VAR
    mtv$step_lock_2: [XREF] mtt$monitor_lock;

?? PUSH (LISTEXT := ON) ??
*copyc mtt$monitor_lock
?? POP ??
*DECK DECK=MTV$SYSTEM_JOB_MONITOR_XCB_P EXPAND=FALSE

 VAR
    mtv$system_job_monitor_xcb_p: [XREF] ^ost$execution_control_block;

?? PUSH (LISTEXT := ON) ??
*copyc ost$execution_control_block
?? POP ??
*DECK DECK=MTV$SYS_CORE_INIT_COMPLETE EXPAND=FALSE
VAR
   mtv$sys_core_init_complete: [XREF] boolean;
*DECK DECK=MTV$TIME_TO_CALL_HANDSHAKING EXPAND=FALSE

  VAR
    mtv$time_to_call_handshaking: [XREF] integer;

*DECK DECK=MTV$TIME_TO_CHECK_SCB_STATUS EXPAND=FALSE
{Define variable that contains the value of the free_running_clock that
{specifies when the routine that monitors the status of the SCB.

  VAR
    mtv$time_to_check_scb_status: [XREF] integer;

*DECK DECK=MTV$TOTAL_NOS_CPU_TIME EXPAND=FALSE

  VAR
    mtv$total_nos_cpu_time: [XREF] RECORD
        total: integer,
        ve_idle: integer,
      recend;
*DECK DECK=MTV$UNSTEP_LOCK_0 EXPAND=FALSE

  VAR
    mtv$unstep_lock_0: [XREF] mtt$monitor_lock;

?? PUSH (LISTEXT := ON) ??
*copyc mtt$monitor_lock
?? POP ??
*DECK DECK=MTV$UNSTEP_LOCK_1 EXPAND=FALSE

  VAR
    mtv$unstep_lock_1: [XREF] mtt$monitor_lock;

?? PUSH (LISTEXT := ON) ??
*copyc mtt$monitor_lock
?? POP ??
*DECK DECK=MTV$UNSTEP_LOCK_2 EXPAND=FALSE

  VAR
    mtv$unstep_lock_2: [XREF] mtt$monitor_lock;

?? PUSH (LISTEXT := ON) ??
*copyc mtt$monitor_lock
?? POP ??
*DECK DECK=MTV$XP_INITIAL_VALUE EXPAND=FALSE
{At deadstart time, monitor copies the job Exchange Package to this location
{before the first exchange to job mode.

  VAR
    mtv$xp_initial_value: [XREF] ost$exchange_package;

?? PUSH (LISTEXT := ON) ??
*copyc OST$EXCHANGE_PACKAGE
?? POP ??
*DECK DECK=MTXMS EXPAND=FALSE
{REFERENCED BY ASSEMBLY CODE ALSO

  VAR
    mtv$mli_status: [XREF] record
      ready: boolean,
      wait_inhibit: boolean,
    recend;
*DECK DECK=N7T$FET EXPAND=FALSE
{
{ define type n7t$fet to be an integer on the 180 (i.e., dummy it out)
{
  TYPE
    n7t$fet = integer;
*DECK DECK=NAC$APPLICATION_CATALOG_LAYOUT EXPAND=FALSE
  CONST
    nac$application_family = '$SYSTEM',
    nac$application_master_catalog = '$SYSTEM',
    nac$network_subcatalog = 'NETWORK',
    nac$application_catalog = 'APPLICATION',
    nac$application_job_catalog = 'JOB',
    nac$application_file = 'DEFINITIONS';
*DECK DECK=NAC$CONDITION_CODE_LIMITS EXPAND=FALSE
  CONST
    nac$status_id = 'NA',
    nac$min_ecc = (($INTEGER ('N') * 100(16)) + $INTEGER ('A')) * 1000000(16),
    nac$max_ecc = nac$min_ecc + 9999;
*DECK DECK=NAC$DEFAULT_NETWORK_COST EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??

  CONST
    nac$default_network_cost = 10;
*DECK DECK=NAC$MAX_PREALLOCATED_REQUESTS EXPAND=FALSE

{   This declaration defines the number of preallocated CPU / IOU
{   interface request blocks.

    CONST
      nac$max_preallocated_requests = 64;
*DECK DECK=NAC$NAMVE_DEBUG_MODE EXPAND=FALSE

{ These are the constant definitions for values that the
{ system attribute NAMVE_DEBUG_MODE can take on.

  CONST
    nac$no_debug = 0,          { NAM/VE debugging disabled.
    nac$debug_on_error = 1,    { Bring task up in debugger on NAM/VE error.
    nac$halt_on_error = 2;     { Halt system on NAM/VE error.

*DECK DECK=NAC$NETWORK_CATALOG EXPAND=FALSE

  CONST
    nac$network_family = '$SYSTEM',
    nac$network_master_catalog = '$SYSTEM',
    nac$network_subcatalog = 'NETWORK',
    nac$configuration_file = 'CONFIGURATION';


*DECK DECK=NAC$NETWORK_FLAG_IDS EXPAND=FALSE
*DECK DECK=NAC$NETWORK_HEAP_SIZE EXPAND=FALSE
?? RIGHT := 110, LEFT := 1 ??

  CONST
    nac$heap_algorithm = 2,
    nac$network_heap_size = 16000000;
*DECK DECK=NAC$NETWORK_MANAGEMENT_CATALOG EXPAND=FALSE


  CONST
    nac$management_family = '$SYSTEM',
    nac$management_master_catalog = '$SYSTEM',
    nac$cdcnet_subcatalog = 'CDCNET',
    nac$template_library = 'DI_MESSAGE_TEMPLATES',
    nac$dump_catalog = 'DUMP',
    nac$version_subcatalog = 'VERSION_',
    nac$site_controlled_subcatalog = 'SITE_CONTROLLED',
    nac$version_independent_catalog = 'VERSION_INDEPENDENT',
    nac$di_object_library = 'DI_OBJECT',
    nac$tcp_ip_subcatalog = 'TCP_IP',
    nac$dns_subcatalog = 'DNS',
    nac$exception_list = 'EXCEPTION_LIST',
    nac$procedures_subcatalog = 'PROCEDURES',
    nac$load_procedures = 'DEVICE_LOAD',
    nac$operator_procedures = 'OPERATOR',
    nac$terminal_procedures = 'TERMINAL',
    nac$user_procedures = 'USER',
    nac$configuration_library = 'CONFIGURATION',
    nac$configuration_file = 'CONFIGURATION',
    nac$log_file = 'LOG',
    nac$log_processor_job = 'PROCESS_LOG_JOB',
    nac$network_subcatalog = 'NETWORK',
    nac$validations_subcatalog = 'VALIDATION_01',
    nac$validation_library_name = 'USER_DATA_BASE';
*DECK DECK=NAC$NETWORK_SIGNAL_IDS EXPAND=FALSE
*copyc tmc$signal_identifiers
*DECK DECK=NAC$NULL_CONNECTION_ID EXPAND=FALSE

  VAR
    nac$null_connection_id: [XREF] nat$connection_id;

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
?? POP ??
*DECK DECK=NAC$RESERVED_SAPS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

{   Reserved Service Access Points (SAPs) include:
{     1. the range of dedicated XNS internet SAPs 0 - 999,
{     2. the range of CDNA reserved transport SAPs 1000 - 1999, and
{     3. the range of reserved SAPs supported at the external interface 2000 - 3000.

{   Dedicated SAPs
  CONST
    nac$xi_xerox_routing_sap = 1,
    nac$xi_xerox_echo_sap = 2,
    nac$xi_xerox_error_sap = 3,
    nac$xi_cdna_directory_sap = 20;

{   Dependent ME reserved transport SAPs are defined to be the following internet dedicated SAP
{   values plus a fixed offset of 1000.
  CONST
    nac$xi_cdna_file_access_sap = 21,
    nac$xi_cdna_command_sap = 22,
    nac$xi_cdna_log_sap = 23,
    nac$transport_sap_offset = 1000;

  CONST
    nac$maximum_reserved_sap_id = 3000;

*DECK DECK=NAC$SE_MIN_FRAGMENT_SIZE EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  CONST
    nac$se_min_fragment_size = 4096;
*DECK DECK=NAC$SK_ALL_IP_ADDRESSES EXPAND=FALSE

  CONST
    nac$sk_all_ip_addresses = 0;

*DECK DECK=NAC$SK_DEFAULT_IF_TIMEOUT EXPAND=FALSE

  CONST
    nac$sk_default_if_timeout = 60*1000;  { in milliseconds }
*DECK DECK=NAC$SK_MAX_HOST_NAME_SIZE EXPAND=FALSE

  CONST
    nac$sk_max_host_name_size = 255;
*DECK DECK=NAC$SK_MAX_NONBLOCKED_DATA_SIZE EXPAND=FALSE

  CONST
    nac$sk_max_nonblocked_data_size = 9000;

*DECK DECK=NAC$SK_MAX_PORT_NUMBER EXPAND=FALSE

  CONST
    nac$sk_max_port_number = 0ffff(16);
*DECK DECK=NAC$SK_MAX_SOCKET_IDENTIFIER EXPAND=FALSE

  CONST
    nac$sk_max_socket_identifier = 0ff(16);
*DECK DECK=NAC$SK_UNNAMED_TCP_APPLICATION EXPAND=FALSE

  CONST
    nac$sk_unnamed_tcp_application = 'UNNAMED_TCP_APPLICATION';
*DECK DECK=NAC$SK_UNNAMED_UDP_APPLICATION EXPAND=FALSE

  CONST
    nac$sk_unnamed_udp_application = 'UNNAMED_UDP_APPLICATION';
*DECK DECK=NAC$STATISTICS_CODES EXPAND=FALSE
  CONST
    nac$statistic_identifier = 'NA';

  CONST
    nac$min_statistic = nac$min_ecc,
    nac$max_statistic = nac$max_ecc;

  CONST

{ Periodic statistics.

    nac$namve_stats                 = nac$min_statistic + 0,
    nac$intranet_stats              = nac$min_statistic + 1,
    nac$osi_stats                   = nac$min_statistic + 2,
    nac$osi_device_specific_stats   = nac$min_statistic + 3,

{ Event statistics.

    nac$maximum_login_attempts      = nac$min_statistic + 10;

*copyc nac$condition_code_limits

*DECK DECK=NAC$TA_ALTERNATE_PROTOCOL_CLASS EXPAND=FALSE

CONST
  nac$ta_min_alternate_protocol  = 0,

  nac$ta_no_alternate_protocol   = 1,
  nac$ta_alternate_class_0       = 2,
  nac$ta_alternate_class_2       = 3,
  nac$ta_alternate_class_0_and_2 = 4,

  nac$ta_max_alternate_protocol  = 255;
*DECK DECK=NAC$TA_PREFERRED_PROTOCOL_CLASS EXPAND=FALSE

{  NOTE:  The system always defaults to nac$ta_preferred_class_4_clns

CONST
  nac$ta_min_preferred_class    = 0,

  nac$ta_preferred_class_0      = 1,
  nac$ta_preferred_class_2      = 2,
  nac$ta_preferred_class_4_cons = 3,
  nac$ta_preferred_class_4_clns = 4,
  nac$ta_preferred_class_4_any  = 5,

  nac$ta_max_preferred_class    = 255;
*DECK DECK=NAC$XI_MAXIMUM_DATA_LENGTH EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  CONST
    nac$xi_maximum_data_length = 1466;
*DECK DECK=NAE$APPLICATION_INTERFACES EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$APPLICATION_INTERFACES ----- ''NA'' 3000..3999', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_appl_interface      = nac$min_ecc + 3000,

    nae$accept_not_pending          = nac$min_ecc_appl_interface + 5,
    {E An unexpected ACCEPT CONNECTION has been received.}

    nae$acct_version_mismatch       = nac$min_ecc_appl_interface + 7,
    {E +P version +P does not match expected version +P.}

    nae$address_protocol_mismatch   = nac$min_ecc_appl_interface + 10,
    {E Improper network address kind for specified protocol.}

    nae$appl_already_attached       = nac$min_ecc_appl_interface + 20,
    {E Job is already attached to server +P.}

    nae$application_attach_limit    = nac$min_ecc_appl_interface + 30,
    {E The number of jobs attached to server +P are sufficient to service ..
    {the maximum number of connections allowed.

    nae$application_inactive        = nac$min_ecc_appl_interface + 40,
    {E Application +P is inactive.}

    nae$application_max_conn_limit  = nac$min_ecc_appl_interface + 50,
    {E The number of connections for the client +P is at the maximum allowed.}

    nae$namve_max_connection_limit  = nac$min_ecc_appl_interface + 60,
    {E Connection request rejected because the current number of NAM/VE ..
    {connections is at the maximum allowed.}

    nae$client_protocol_mismatch    = nac$min_ecc_appl_interface + 80,
    {E The protocol on the +P request does not match the expected protocol.}

    nae$connection_not_established  = nac$min_ecc_appl_interface + 100,
    {E Connection not established.}

    nae$connection_terminated       = nac$min_ecc_appl_interface + 130,
    {E Connection has been terminated.}

    nae$data_transfer_timeout       = nac$min_ecc_appl_interface + 140,
    {E Data transfer operation terminated because timer expired.}

    nae$directory_data_too_large    = nac$min_ecc_appl_interface + 150,
    {E +P: Directory data may not contain more than 32 bytes.}

    nae$directory_search_complete   = nac$min_ecc_appl_interface + 155,
    {I All translations have been delivered.}

    nae$duplicate_selector          = nac$min_ecc_appl_interface + 160,
    {E +P1: Parameter +P2 has more than one array element with selector +P3.}

    nae$duplicate_title             = nac$min_ecc_appl_interface + 170,
    {E +P1: Title +P2 already defined for server +P3.}

    nae$duplicate_title_pattern     = nac$min_ecc_appl_interface + 180,
    {E +P1: Title pattern +P2 already defined for server +P3.}

    nae$improper_protocol           = nac$min_ecc_appl_interface + 300,
    {E The +P protocol is improper for the +P request.}

    nae$inconsistent_qualified_data = nac$min_ecc_appl_interface + 320,
    {E The SEND DATA parameter QUALIFIED DATA must remain consistent for an ..
    {incomplete data message.}

    nae$insufficient_resources      = nac$min_ecc_appl_interface + 330,
    {E Insufficient network resources are available for the +P request to ..
    {complete.}

    nae$invalid_connect_data_change = nac$min_ecc_appl_interface + 345,
    {E The CONNECT_DATA attribute may not be changed for an established ..
    {connection.}

    nae$invalid_directory_priority  = nac$min_ecc_appl_interface + 350,
    {E +P: Directory priority must be greater than 0.}

    nae$invalid_directory_search_id = nac$min_ecc_appl_interface + 355,
    {E Invalid search_identifier on +P request.}

    nae$invalid_eoi_message_size    = nac$min_ecc_appl_interface + 360,
    {E The eoi message size exceeds the maximum allowed value of +P.}

    nae$invalid_protocol            = nac$min_ecc_appl_interface + 365,
    {E +P1: +P is not a valid protocol identifier.}

    nae$invalid_selector            = nac$min_ecc_appl_interface + 370,
    {E +P1: Parameter +P2 has an invalid selector in array element +P3.}

    nae$max_connections_acquired    = nac$min_ecc_appl_interface + 500,
    {E Maximum connections allowed for server +P have been acquired.}

    nae$max_connections_mismatch    = nac$min_ecc_appl_interface + 520,
    {E Specified maximum connections value does not match server application ..
    {definition.

    nae$max_data_length_exceeded    = nac$min_ecc_appl_interface + 540,
    {E Data length exceeds +P.}

    nae$multiple_waits_attempted    = nac$min_ecc_appl_interface + 570,
    {E Multiple attempts to wait on +P.}

    nae$network_inactive            = nac$min_ecc_appl_interface + 610,
    {E Network is inactive.}

    nae$no_connection_available     = nac$min_ecc_appl_interface + 630,
    {E No connection is available for server +P.}

    nae$no_data_available           = nac$min_ecc_appl_interface + 640,
    {E No input data is available.}

    nae$no_server_response          = nac$min_ecc_appl_interface + 650,
    {E The server application has not responded to a connection request.}

    nae$no_switch_offer_pending     = nac$min_ecc_appl_interface + 660,
    {E No switch offer is pending on connection +P.}

    nae$no_switch_offered           = nac$min_ecc_appl_interface + 670,
    {E No connection switch has been offered.}

    nae$no_title_match              = nac$min_ecc_appl_interface + 675,
    {E +P1: No +P2 server title matches title pattern +P3.}

    nae$no_translation_available    = nac$min_ecc_appl_interface + 680,
    {I No translations are currently available for delivery.}

    nae$receive_outstanding         = nac$min_ecc_appl_interface + 720,
    {E A receive data operation is already in progress.}

    nae$se_interrupt_length_error   = nac$min_ecc_appl_interface + 730,
    {E Interrupt data cannot exceed +P bytes and cannot be smaller than +P ..
    {bytes.}

    nae$se_no_synch_in_progress     = nac$min_ecc_appl_interface + 735,
    {E Synchronization of output data is not in progress.  A ..
    {nap$se_synchronize_confirm request is not allowed.}

    nae$se_synch_confirm_pending    = nac$min_ecc_appl_interface + 745,
    {E The user's peer must respond to the previously issued synchronize ..
    {before another synchronize request can be processed.}

    nae$se_synchronize_in_progress  = nac$min_ecc_appl_interface + 755,
    {E A SYNCHRONIZE CONFIRM is required before the request can be accepted.}

    nae$se_synchronize_length_error = nac$min_ecc_appl_interface + 760,
    {E Synchronize data cannot exceed +P bytes and cannot be smaller than +P ..
    {bytes.}

    nae$se_unknown_synch_direction  = nac$min_ecc_appl_interface + 770,
    {E The synchronize direction specified is unknown.}

    nae$send_outstanding            = nac$min_ecc_appl_interface + 780,
    {E A send data operation is already in progress.}

    nae$server_not_attached         = nac$min_ecc_appl_interface + 800,
    {E Job is not attached to server +P.}

    nae$server_response_timeout     = nac$min_ecc_appl_interface + 820,
    {E The remote server application did not respond to the connection ..
    {request for +P.}

    nae$switch_offer_accepted       = nac$min_ecc_appl_interface + 840,
    {E Connection +P has been switched to another job.}

    nae$switch_offer_not_accepted   = nac$min_ecc_appl_interface + 845,
    {E Switch offer for connection +P was not accepted.}

    nae$switch_offer_pending        = nac$min_ecc_appl_interface + 850,
    {E Switch offer is pending on connection +P.}

    nae$title_not_authorized        = nac$min_ecc_appl_interface + 870,
    {E +P1: Title +P2 is not authorized for server +P3.}

    nae$title_too_long              = nac$min_ecc_appl_interface + 875,
    {E +P1: Title length (+P2) exceeds maximum allowed (255).}

    nae$title_too_short             = nac$min_ecc_appl_interface + 880,
    {E +P: A title must contain at least 1 character.}

    nae$title_pattern_too_long      = nac$min_ecc_appl_interface + 890,
    {E +P1: Title pattern length (+P2) exceeds maximum allowed (255).}

    nae$title_pattern_too_short     = nac$min_ecc_appl_interface + 900,
    {E +P: A title pattern must contain at least 1 character.}

    nae$unexpected_peer_operation   = nac$min_ecc_appl_interface + 920,
    {E Peer application has performed a connection operation other than data..
    { transfer.}

    nae$unknown_address_kind        = nac$min_ecc_appl_interface + 940,
    {E The address kind specified is unknown.}

    nae$unknown_application         = nac$min_ecc_appl_interface + 950,
    {E Application +P has not been defined.}

    nae$unknown_attribute           = nac$min_ecc_appl_interface + 960,
    {E An attribute specified +P is unknown.}

    nae$unknown_protocol            = nac$min_ecc_appl_interface + 970,
    {E Unknown protocol.}

    nae$variable_too_small          = nac$min_ecc_appl_interface + 990,
    {E +P1: Variable specified by array element +P3 of parameter +P2..
    { is too small to contain the requested value.}

    nae$unsupported_address         = nac$min_ecc_appl_interface + 995,
    {E Only address kinds of nac$osi_transport_address and
    { nac$internet_address are supported.}

    nae$maximum_data_fragments      = nac$min_ecc_appl_interface + 996,
    {E Data fragments may not contain more than 255 array elements.

    nac$max_ecc_appl_interface      = nac$min_ecc_appl_interface + 999;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$APPLICATION_MANAGEMENT EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$APPLICATION_MANAGEMENT ----- ''NA'' 4000..4499', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_appl_management     = nac$min_ecc + 4000,

    nae$active_connections          = nac$min_ecc_appl_management + 2,
    {E Application +P has active connections.}

    nae$active_sockets              = nac$min_ecc_appl_management + 3,
    {E Application +P has active sockets.}

    nae$unknown_socket              = nac$min_ecc_appl_management + 4,
    {E Socket undefined for application +P.}

    nae$application_active          = nac$min_ecc_appl_management + 5,
    {E Application +P is active.}

    nae$application_already_active  = nac$min_ecc_appl_management + 10,
    {E Application +P is already active.}

    nae$application_already_defined = nac$min_ecc_appl_management + 15,
    {E +P Application is already defined.}

    nae$application_already_inactiv = nac$min_ecc_appl_management + 20,
    {E Application +P is already inactive.}

    nae$application_file_error      = nac$min_ecc_appl_management + 25,
    {E +P The definitions on application file are incorrect.}

    nae$application_file_mismatch   = nac$min_ecc_appl_management + 30,
    {E Application file mismatch.}

    nae$application_file_not_open   = nac$min_ecc_appl_management + 35,
    {E +P Application definitions file is not open.}

    nae$application_not_restored    = nac$min_ecc_appl_management + 38,
    {E An error occurred while changing the +P application and also while ..
    {restoring the application to it's original state.  See the job log for ..
    {details.}

    nae$conflicting_reserved_sap    = nac$min_ecc_appl_management + 50,
    {E Reserved SAP +P is already in use.}

    nae$cycle_1_present             = nac$min_ecc_appl_management + 55,
    {W Cycle 1 of application definitions file was present and was purged.}

    nae$incorrect_appl_file_version = nac$min_ecc_appl_management + 95,
    {E The application file version +P is incorrect.

    nae$insufficient_attached_jobs  = nac$min_ecc_appl_management + 100,
    {E Attached server jobs are at maximum connections limit.}

    nae$maximum_sockets_exceeded    = nac$min_ecc_appl_management + 110,
    {E Application +P maximum sockets exceeded.}

    nae$no_server_job_attached      = nac$min_ecc_appl_management + 150,
    {E No server job is attached to +P.}

    nae$server_jobs_attached        = nac$min_ecc_appl_management + 250,
    {E Server jobs attached to +P.}

    nae$limit_max_connections       = nac$min_ecc_appl_management + 260,
    {W Maximum connections limit for +P has been set to the maximum allowed ..
    {value of +P.}

    nae$unable_to_activate_appl     = nac$min_ecc_appl_management + 400,
    {E Unable to activate application +P during NAMVE initialization.}

    nae$even_char_count_required    = nac$min_ecc_appl_management + 405,
    {E An even number of digits are required. +P digits were specified.}

    nae$invalid_hex_digit           = nac$min_ecc_appl_management + 410,
    {E Only the numbers 0 through 9 and the letters A through F are ..
    {allowed. +P was specified.}

    nae$unknown_identifier          = nac$min_ecc_appl_management + 415,
    {E The title identifier +P is not present in the current list of ..
    {registered non-CDNA titles.

    nae$unknown_osi_title           = nac$min_ecc_appl_management + 420,
    {E The title +P is not present in the current list of registered OSI titles.

    nae$empty_osi_title_list        = nac$min_ecc_appl_management + 425,
    {E No OSI titles are registered in the Directory.}

    nae$transport_network_mismatch  = nac$min_ecc_appl_management + 430,
    {E Connectionless network service requires use of Transport Class 4.}

    nae$no_server_job_active        = nac$min_ecc_appl_management + 435,
    {E No +P server job is active.}

    nae$network_applications_active = nac$min_ecc_appl_management + 440,
    {E Network applications are still active.}

    nac$max_ecc_appl_management     = nac$min_ecc_appl_management + 499;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$CLIENT_VALIDATION_DIALOG EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$CLIENT_VALIDATION_DIALOG ----- ''NA'' 5500..5599', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_validation_dialog   = nac$min_ecc + 5500,

    nae$account_prompt              = nac$min_ecc_validation_dialog + 10,
    {I Account:+X }

    nae$family_prompt               = nac$min_ecc_validation_dialog + 25,
    {I Family:+X }

    nae$improper_name_at_login      = nac$min_ecc_validation_dialog + 35,
    {E You must enter a name.}

    nae$incorrect_validation        = nac$min_ecc_validation_dialog + 40,
    {I Incorrect validation entered.}

    nae$login_parameter_invalid     = nac$min_ecc_validation_dialog + 42,
    {I Login command parameter is either missing or invalid.}

    nae$login_banner                = nac$min_ecc_validation_dialog + 45,
    {I Enter validation for service access.}

    nae$login_timeout               = nac$min_ecc_validation_dialog + 50,
    {E Response timeout. Connection rejected. +N }

    nae$login_validation_required   = nac$min_ecc_validation_dialog + 54,
    {E You must enter a +P.}

    nae$null_message                = nac$min_ecc_validation_dialog + 60,
    {I +P                          }

    nae$password_prompt             = nac$min_ecc_validation_dialog + 70,
    {I Password:+X }

    nae$project_prompt              = nac$min_ecc_validation_dialog + 72,
    {I Project:+X }

    nae$retry_limit_at_login        = nac$min_ecc_validation_dialog + 74,
    {I No more retries allowed. Connection rejected. +N }

    nae$retry_login                 = nac$min_ecc_validation_dialog + 77,
    {I Please try again. +N }

    nae$user_prompt                 = nac$min_ecc_validation_dialog + 93,
    {I User:+X }

    nac$max_ecc_validation_dialog   = nac$min_ecc_validation_dialog + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??


*DECK DECK=NAE$CONDITION_CODES EXPAND=FALSE
?? NEWTITLE := 'NAE$CONDITION_CODES ------ ''NA'' 1 .. 9999', EJECT ??

{ PURPOSE:
{   This deck contains *copyc directives for all the NAMVE exception conditions
{   decks.
{
{ NOTES:
{   This deck should only be referenced by deck OSD$EXCEPTIONS.  All other
{   decks that reference NAMVE condition codes should contain a *copyc
{   directive for only the exception conditions decks that contain the
{   referenced condition codes.  A *copyc directive must be added to this deck
{   for all new NAMVE exception conditions decks.

{ NAE$NAMVE_CONDITIONS ----------------- NA    1 ..  999

*COPYC NAE$NAMVE_CONDITIONS

{ NAE$INTERNAL_INTERACTIVE_APPL -------- NA 1000 .. 1099

*COPYC NAE$INTERNAL_INTERACTIVE_APPL

{ NAE$NETWORK_CONFIGURATION  ----------- NA 1500 .. 1599

*COPYC NAE$NETWORK_CONFIGURATION

{ NAE$ICA_CONDITIONS ------------------- NA 1600 .. 1699

*COPYC NAE$ICA_CONDITIONS

{ NAE$DIRECTORY_ME_CONDITIONS ---------- NA 2000 .. 2099

*COPYC NAE$DIRECTORY_ME_CONDITIONS

{ NAE$INITIALIZATION_ME ---------------- NA 2100 .. 2199

*COPYC NAE$INITIALIZATION_ME

{ NAE$FILE_ACCESS_ME_CONDITIONS -------- NA 2200 .. 2299

*COPYC NAE$FILE_ACCESS_ME_CONDITIONS

{ NAE$LOG_ME_CONDITIONS ---------------- NA 2300 .. 2399

*COPYC NAE$LOG_ME_CONDITIONS

{ NAE$NETWORK_OPERATOR_UTILITY --------- NA 2400 .. 2599

*COPYC NAE$NETWORK_OPERATOR_UTILITY

{ NAE$APPLICATION_INTERFACES ----------- NA 3000 .. 3999

*COPYC NAE$APPLICATION_INTERFACES

{ NAE$APPLICATION_MANAGEMENT ----------- NA 4000 .. 4499

*COPYC NAE$APPLICATION_MANAGEMENT

{ NAE$MANAGE_NETWORK_APPLICATIONS ------ NA 4500 .. 4699

*COPYC NAE$MANAGE_NETWORK_APPLICATIONS

{ NAE$CLIENT_VALIDATION_DIALOG --------- NA 5500 .. 5599

*COPYC NAE$CLIENT_VALIDATION_DIALOG

{ NAE$INITIALIZATION_INTERFACES -------- NA 6000 .. 6099

*COPYC NAE$INITIALIZATION_INTERFACES

{ NAE$SYSTEM_MGMT_ACCESS_AGENT --------- NA 6200 .. 6299

*COPYC NAE$SYSTEM_MGMT_ACCESS_AGENT

{ NAE$NETWORK_ACCESS_AGENT ------------- NA 6300 .. 6399

*COPYC NAE$NETWORK_ACCESS_AGENT

{ NAE$OSI_INTERNAL_INTERFACES ---------- NA 7000 .. 7200

*COPYC NAE$OSI_INTERNAL_INTERFACES

{ NAE$TCP_CONDITION_CODES -------------- NA 7300 .. 7399

*COPYC NAE$TCP_CONDITION_CODES

{ NAE$TCPIP_MGMT_CONDITION_CODES ------- NA 7400 .. 7499

*COPYC NAE$TCPIP_MGMT_CONDITION_CODES

{ NAE$SOCKET_LAYER --------------------- NA 7500 .. 7700

*COPYC NAE$SK_SOCKET_LAYER
?? OLDTITLE ??
*DECK DECK=NAE$DIRECTORY_ME_CONDITIONS EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$DIRECTORY_ME_CONDITIONS ----- ''NA'' 2000..2099', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_directory_me        = nac$min_ecc + 2000,

    nae$duplicate_registration      = nac$min_ecc_directory_me + 15,
    {E Title/address already registered.}

    nae$incorrect_password          = nac$min_ecc_directory_me + 40,
    {E Incorrect password given for title entry.}

    nae$title_id_not_found          = nac$min_ecc_directory_me + 80,
    {E Title/identifier pair not found in directory.}

    nae$translation_req_not_active  = nac$min_ecc_directory_me + 85,
    {E Translation request not active.}

    nae$wait_for_distributed_title  = nac$min_ecc_directory_me + 95,
    {E Waiting for distributed title.}

    nac$max_ecc_directory_me        = nac$min_ecc_directory_me + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$FILE_ACCESS_ME_CONDITIONS EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$FILE_ACCESS_ME_CONDITIONS ----- ''NA'' 2200..2299', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_file_access         = nac$min_ecc + 2200,

    nae$bad_file_access_file_name   = nac$min_ecc_file_access + 5,
    {E Improper name +P specified in file access request.}

    nae$ep_not_on_load_module       = nac$min_ecc_file_access + 15,
    {E Module with entry point +P is not a load module.}

    nae$file_type_unavailable       = nac$min_ecc_file_access + 20,
    {E File type +P unavailable.}

    nae$invalid_access_mode         = nac$min_ecc_file_access + 30,
    {E Invalid access mode for file +P.}

    nae$invalid_file_access_request = nac$min_ecc_file_access + 32,
    {E Invalid File Access request - +P.}

    nae$max_files_reached           = nac$min_ecc_file_access + 48,
    {E Unable to create new file in catalog +P, file limit reached.}

    nae$module_not_a_load_module    = nac$min_ecc_file_access + 55,
    {E Module +P is not a load module.}

    nae$module_not_program_desc     = nac$min_ecc_file_access + 58,
    {E Module +P is not a program description.}

    nae$procedure_not_on_library    = nac$min_ecc_file_access + 70,
    {E Procedure +P not on library +F.}

    nae$record_size_overflow        = nac$min_ecc_file_access + 75,
    {E Record size overflow on file +P.}

    nae$write_beyond_file_limit     = nac$min_ecc_file_access + 90,
    {E Write beyond file limit.}

    nae$invalid_net_val_database    = nac$min_ecc_file_access + 95,
    {E +F is not a valid network validation database.}

    nae$invalid_user_name           = nac$min_ecc_file_access + 96,
    {E A user specified an invalid network validation user name.}

    nac$max_ecc_file_access         = nac$min_ecc_file_access + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$ICA_CONDITIONS EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$ICA_CONDITIONS ------ ''NA'' 1600 .. 1699',  EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_ica                 = nac$min_ecc + 1600,

    nae$data_unit_size_too_big      = nac$min_ecc_ica + 5,
    {E The network device +P set a maximum data unit size of +P bytes, which ..
{is larger than the supported size of +P bytes with CYBER page size of +P bytes.}

    nae$device_down_via_pp          = nac$min_ecc_ica + 10,
    {E The network device +P down notification received from the PP.}

    nae$device_reset_thresh_exceed  = nac$min_ecc_ica + 15,
    {E The reset down threshold has been exceeded for network device +P.}

    nae$device_not_active           = nac$min_ecc_ica + 20,
    {E Network device +P is not active.}

    nae$net_device_reset_timeout    = nac$min_ecc_ica + 60,
    {E The reset down timer for network device +P has expired.}

    nae$state_change_in_progress    = nac$min_ecc_ica + 80,
    {E State change has already been initiated for the given element.}

    nae$unexpected_device_state     = nac$min_ecc_ica + 87,
    {E Network device +P in unexpected state.}

    nae$unexpected_pp_response      = nac$min_ecc_ica + 90,
    {E Unexpected +P response from network PP.}

    nae$unknown_element             = nac$min_ecc_ica + 93,
    {E The element +P is not present in the network configuration.}

    nac$max_ecc_ica                 = nac$min_ecc_ica + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$INITIALIZATION_INTERFACES EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$INITIALIZATION_INTERFACES ----- ''NA'' 6000..6099', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_initialization      = nac$min_ecc + 6000,

    nae$activate_network_config     = nac$min_ecc_initialization + 10,
    {F A NAM/VE initialization error occurred activating the network ..
    {configuration.}

    nae$install_applications        = nac$min_ecc_initialization + 40,
    {F A NAM/VE initialization error occurred installing applications.}

    nae$initialization_error        = nac$min_ecc_initialization + 50,
    {E A NAM/VE initialization error occurred in phase +P. }

    nae$initialization_fatal        = nac$min_ecc_initialization + 55,
    {F A *FATAL* NAM/VE initialization error occurred in phase +P. }

    nae$initialization_warning      = nac$min_ecc_initialization + 60,
    {W A NAM/VE initialization error occurred. }

    nae$parameter_not_supported     = nac$min_ecc_initialization + 80,
    {W The parameter +P is not supported in the current implementation.}

    nae$protocol_not_supported     = nac$min_ecc_initialization + 90,
    {W The +P protocol is not supported in the current implementation.}

    nae$connections_still_active   = nac$min_ecc_initialization + 95,
    {E Cannot deactivate NAM/VE: connections are still active.}

    nac$max_ecc_initialization      = nac$min_ecc_initialization + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$INITIALIZATION_ME EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$INITIALIZATION_ME ------ ''NA'' 2100 .. 2199',  EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_initialization_me   = nac$min_ecc + 2100,

    nae$defaults_not_set_first      = nac$min_ecc_initialization_me + 10,
    {E DEFINE_BOOT_DEFAULTS command must be the first command on the ..
    {exception list file.}

    nae$defaults_set_twice          = nac$min_ecc_initialization_me + 15,
    {E DEFINE_BOOT_DEFAULTS command can occur only once on the exception ..
    {list file.}

    nae$di_reset                    = nac$min_ecc_initialization_me + 20,
    {E +P +P reset with reset code +P.}

    nae$errors_in_exception_list    = nac$min_ecc_initialization_me + 25,
    {E Errors found in the CDCNET exception list file. +P}

    nae$excessive_resyncs           = nac$min_ecc_initialization_me + 30,
    {E Load of system +P terminated: excessive resyncs.}

    nae$init_checksum_error         = nac$min_ecc_initialization_me + 35,
    {E Checksum error detected on initialization PDU from system +P.}

    nae$unknown_or_short_pdu        = nac$min_ecc_initialization_me + 40,
    {E Unknown or short initialization data unit received from system +P.}

    nae$excluded_system             = nac$min_ecc_initialization_me + 45,
    {E Load request from system +P ignored. System support suppressed in exception list.}

    nae$unsupported_device          = nac$min_ecc_initialization_me + 50,
    {E Load request from system +P ignored. Device type not supported.}

    nae$too_many_load_requests      = nac$min_ecc_initialization_me + 55,
    {E Load request from system +P ignored. Too many load requests.}

    nae$unexpected_help_accept      = nac$min_ecc_initialization_me + 60,
    {E Unexpected help accept received from system +P.}

    nae$invalid_load_resync_request = nac$min_ecc_initialization_me + 65,
    {E Invalid load resync request received from system +P.}

    nac$max_ecc_initialization_me   = nac$min_ecc_initialization_me + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$INTERNAL_INTERACTIVE_APPL EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$INTERNAL_INTERACTIVE_APPL ----- ''NA'' 1000..1099', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_interactive_appl    = nac$min_ecc + 1000,

    nae$break_condition_active      = nac$min_ecc_interactive_appl + 5,
    {E Break condition active.}

    nae$connection_active           = nac$min_ecc_interactive_appl + 10,
    {E Connection active.}

    nae$interactive_cond_interrupt  = nac$min_ecc_interactive_appl + 30,
    {E Interactive cond interrupt.}

    nae$nominal_connection          = nac$min_ecc_interactive_appl + 50,
    {E Nominal connection.}

    nae$not_nominal_connection      = nac$min_ecc_interactive_appl + 55,
    {E Not nominal connection.}

    nae$not_simulated_conn_broken   = nac$min_ecc_interactive_appl + 60,
    {E Not simulated connection broken.}

    nae$simulated_connect_broken    = nac$min_ecc_interactive_appl + 80,
    {E Simulated connection broken.}

    nac$max_ecc_interactive_appl    = nac$min_ecc_interactive_appl + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$LINK_ACCESS_AGENT EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$LINK_ACCESS_AGENT ------ ''NA'' 6400 .. 6449', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_link_access_agent = nac$min_ecc + 6400,

    nae$la_sap_not_open = nac$min_ecc_link_access_agent + 1,
    {E The OSI link layer sap +P is not open.}

    nae$la_sap_already_open = nac$min_ecc_link_access_agent + 2,
    {E The OSI link layer sap +P is already open.}

    nac$max_ecc_link_access_agent = nac$min_ecc_link_access_agent + 49;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$LOG_ME_CONDITIONS EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$LOG_ME_CONDITIONS ------ ''NA'' 2300 .. 2399',  EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_log_me              = nac$min_ecc + 2300,

    nae$duplicate_group             = nac$min_ecc_log_me + 15,
    {E Group +P specified twice, group names must be unique.}

    nae$invalid_log_group_name      = nac$min_ecc_log_me + 38,
    {E Log group name +P is invalid, must be an SCL name.}

    nae$invalid_log_group_priority  = nac$min_ecc_log_me + 40,
    {E Log group priority +P is invalid, must be an integer between 1 and 255.}

    nae$log_file_terminated         = nac$min_ecc_log_me + 50,
    {I Network Log File terminated - Submitting Log processing job.}

    nae$logging_suspended           = nac$min_ecc_log_me + 52,
    {E Network Logging has been suspended due to abnormal disk status.}

    nae$logging_resumed              = nac$min_ecc_log_me + 54,
    {I Network Logging has resumed.}

    nae$max_cycles_reached          = nac$min_ecc_log_me + 60,
    {E Unable to create new cycle of file +P, cycle limit reached.}

    nae$unable_to_create_log_file   = nac$min_ecc_log_me + 86,
    {W Unable to create a new cycle of the Network Log file.}

    nae$unable_to_process_log_file  = nac$min_ecc_log_me + 90,
    {E Unable to process Network Log File.}

    nac$max_ecc_log_me              = nac$min_ecc_log_me + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$MANAGE_NETWORK_APPLICATIONS EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$MANAGE_NETWORK_APPLICATIONS -- ''NA'' 4500..4699', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_manna               = nac$min_ecc + 4500,

    nae$all_not_valid_appl_name     = nac$min_ecc_manna + 20,
    {E The value ALL is not allowed as the name of an application.}

    nae$appl_definition_not_changed = nac$min_ecc_manna + 25,
    {W No changes to the +P definition were entered.}

    nae$application_id_not_changed  = nac$min_ecc_manna + 30,
    {E An application identifier can not be changed to variable if it's ..
    {current value is variable.}

    nae$application_not_defined     = nac$min_ecc_manna + 35,
    {E No +P applications are defined.}

    nae$client_address_not_in_list  = nac$min_ecc_manna + 40,
    {E The specified client address is not in the current list of valid ..
    {addresses.}

    nae$command_not_allowed         = nac$min_ecc_manna + 50,
    {E The +P command is not allowed when +P.}

    nae$invalid_client_attribute    = nac$min_ecc_manna + 70,
    {E +P is not a valid client attribute name.}

    nae$invalid_server_attribute    = nac$min_ecc_manna + 75,
    {E +P is not a valid server attribute name.}

    nae$invalid_tcpip_attribute     = nac$min_ecc_manna + 77,
    {E +P is not a valid TCP/IP attribute name.}

    nae$invalid_user                = nac$min_ecc_manna + 80,
    {E User not authorized to invoke +p.}

    nae$only_disk_files_supported   = nac$min_ecc_manna + 100,
    {E Server job files must be mass storage files in the current ..
    {implementation.}

    nae$page_width_too_small        = nac$min_ecc_manna + 110,
    {E The page width of the output file must be at least +P.}

    nae$title_not_name_or_string    = nac$min_ecc_manna + 130,
    {E A title value must be specified as a name or a string, not a +P.}

    nae$unknown_title               = nac$min_ecc_manna + 140,
    {W Title +P is not in the current list of titles.}

    nae$unknown_title_pattern       = nac$min_ecc_manna + 145,
    {W Title pattern +P is not in the current list of title patterns.}

    nae$tcp_protocol_mismatch       = nac$min_ecc_manna + 150,
    {E To define a TCP/IP application using the name UNNAMED_TCP_APPLICATION..
    {  a protocol value of STREAM_SOCKET must be specified.}

    nae$udp_protocol_mismatch       = nac$min_ecc_manna + 155,
    {E To define a TCP/IP application using the name UNNAMED_UDP_APPLICATION..
    {  a protocol value of DATAGRAM_SOCKET must be specified.}

    nae$value_not_supported         = nac$min_ecc_manna + 160,
    {E The parameter value +P is not supported in the current implementation.}

    nae$warnings_processing_command = nac$min_ecc_manna + 180,
    {W Warnings detected processing MANNA command +P. See $ERRORS.}

    nac$max_ecc_manna               = nac$min_ecc_manna + 199;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$NAMVE_CONDITIONS EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$NAMVE_CONDITIONS ------ ''NA'' 1 .. 999', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    nac$min_ecc_namve               = nac$min_ecc + 1,

    nae$activity_count_zero         = nac$min_ecc_namve + 5,
    {E Number of SAP activities is at zero.}

    nae$allocation_failed           = nac$min_ecc_namve + 10,
    {E Allocation failed for +P.}

    nae$channelnet_not_configured   = nac$min_ecc_namve + 25,
    {E Channelnet +P not configured.}

    nae$client_receiving_connection = nac$min_ecc_namve + 27,
    {E Clients are not allowed to receive connection events.}

    nae$conn_terminated_by_peer     = nac$min_ecc_namve + 30,
    {E The connection was terminated by the peer process.}

    nae$connection_failed           = nac$min_ecc_namve + 35,
    {E The connection was terminated due to a failure on the network.}

    nae$connection_full             = nac$min_ecc_namve + 40,
    {E The connection is full of outbound messages and cannot process a +P.}

    nae$connection_not_open         = nac$min_ecc_namve + 45,
    {E +P layer connection +P not open.}

    nae$connection_not_proposed     = nac$min_ecc_namve + 50,
    {E +P layer connection +P not proposed for ACCEPT/REJECT.}

    nae$data_area_too_small         = nac$min_ecc_namve + 60,
    {E The data area is too small. +P}

    nae$improper_aggregate_kind     = nac$min_ecc_namve + 100,
    {E The aggregate event kind is not 'data' or 'expedited_data' on ..
    {send_aggregate_data. }

    nae$incorrect_activity          = nac$min_ecc_namve + 120,
    {E An incorrect activity is specified in the wait list.}

    nae$insufficient_data           = nac$min_ecc_namve + 125,
    {E Buffer manager: Insufficient data to extract.}

    nae$insufficient_privilege      = nac$min_ecc_namve + 130,
    {E The requestor has insufficient privilege for the request.}

    nae$invalid_job                 = nac$min_ecc_namve + 140,
    {E +P invalid job.}

    nae$invalid_request             = nac$min_ecc_namve + 157,
    {E +P request cannot be accepted at this time.  +P}

    nae$invalid_reserved_sap        = nac$min_ecc_namve + 160,
    {E The reserved SAP specified is improper.}

    nae$invalid_sap_priority        = nac$min_ecc_namve + 165,
    {E The value specified for SAP priority is out of range.}

    nae$invalid_task                = nac$min_ecc_namve + 170,
    {E +P.}

    nae$job_recovery                = nac$min_ecc_namve + 190,
    {E +P terminated due to job recovery.}

    nae$max_active_conn_exceeded    = nac$min_ecc_namve + 200,
    {E Maximum active connections specified exceeds maximum value.}

    nae$max_active_connections      = nac$min_ecc_namve + 210,
    {E Number of active connections already at maximum.}

    nae$max_active_connections_0    = nac$min_ecc_namve + 220,
    {E Maximum active connections specified is zero.}

    nae$max_activity_count_exceeded = nac$min_ecc_namve + 230,
    {E Maximum active count specified exceeds maximum value.}

    nae$max_expedited_exceeded      = nac$min_ecc_namve + 240,
    {E The number of outstanding expedited requests is at the limit for the ..
    {connection.}

    nae$maximum_activity_count      = nac$min_ecc_namve + 250,
    {E Number of SAP activities already at maximum.}

    nae$maximum_saps_open           = nac$min_ecc_namve + 260,
    {E Maximum number of +P layer SAPs already open.}

    nae$no_datagram_available       = nac$min_ecc_namve + 300,
    {E No datagram available for +P layer SAP +P.}

    nae$no_event                    = nac$min_ecc_namve + 310,
    {E +P no event found.}

    nae$destination_not_reachable   = nac$min_ecc_namve + 314,
    {E The destination system is not reachable at this time.}

    nae$protocol_error              = nac$min_ecc_namve + 350,
    {E +P layer protocol error.}

    nae$resources_unavailable       = nac$min_ecc_namve + 450,
    {E The connection cannot be established due to unavailable system ..
    {resources.}

    nae$sap_already_open            = nac$min_ecc_namve + 500,
    {E Reserved SAP +P is already in use.}

    nae$sap_not_open                = nac$min_ecc_namve + 510,
    {E +P layer SAP +P not open.}

    nae$sap_cannot_be_shared        = nac$min_ecc_namve + 518,
    {E The +P sap +P cannot be shared.}

    nae$shared_server_sap_open      = nac$min_ecc_namve + 519,
    {E The +P shared server sap +P is already open.}

    nae$supervisory_traffic_limit   = nac$min_ecc_namve + 520,
    {E The connection has reached the supervisory traffic limit and cannot ..
    {process a +P request.}

    nae$system_interrupt            = nac$min_ecc_namve + 600,
    {E System interrupt.}

    nae$unable_to_open_sap          = nac$min_ecc_namve + 700,
    {E Unable to open +P sap.}

    nac$max_ecc_namve               = nac$min_ecc_namve + 999;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$NETWORK_ACCESS_AGENT EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$NETWORK_ACCESS_AGENT ------ ''NA'' 6300 .. 6399', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_net_access_agent = nac$min_ecc + 6300,

    nae$na_sap_not_open = nac$min_ecc_net_access_agent + 1,
    {E The OSI network layer sap +P is not open.}

    nae$na_peer_disconnect = nac$min_ecc_net_access_agent + 2,
    {E The OSI network layer sap +P2 closed by the peer via +P1.}

    nae$na_sap_already_open = nac$min_ecc_net_access_agent + 3,
    {E The OSI network layer sap +P is already open.}

    nae$na_device_sap_not_open = nac$min_ecc_net_access_agent + 4,
    {E The OSI network layer sap +P is not open in the device.}

    nac$max_ecc_net_access_agent = nac$min_ecc_net_access_agent + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$NETWORK_CONFIGURATION EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$NETWORK_CONFIGURATION  ------ ''NA'' 1500..1599', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_network_config      = nac$min_ecc + 1500,

    nae$empty_network_desc_list     = nac$min_ecc_network_config + 20,
    {E Network descriptor list is empty.}

    nae$networks_already_configured = nac$min_ecc_network_config + 50,
    {I Networks are already activated.}

    nae$networks_not_activated      = nac$min_ecc_network_config + 60,
    {E Networks are not activated.}

    nac$max_ecc_network_config      = nac$min_ecc_network_config + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$NETWORK_OPERATOR_UTILITY EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$NETWORK_OPERATOR_UTILITY ------ ''NA'' 5000..5199', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_netou               = nac$min_ecc + 5000,

    nae$access_lost                 = nac$min_ecc_netou + 5,
    {E Connection to system +P lost after CDCNET command sent.}

    nae$alarms_already_active       = nac$min_ecc_netou + 10,
    {E Alarms are already active for alarm group +P.}

    nae$alarms_not_active           = nac$min_ecc_netou + 15,
    {E Alarms are not active for alarm group +P.}

    nae$command_connection_ignored  = nac$min_ecc_netou + 30,
    {E No response received for connect request to system +P.}

    nae$command_connection_rejected = nac$min_ecc_netou + 35,
    {E Unable to establish connection to system +P.}

    nae$command_not_sent_to_system  = nac$min_ecc_netou + 40,
    {E The last CDCNET command was not sent to system +P.}

    nae$errors_during_command       = nac$min_ecc_netou + 50,
    {E Errors detected processing NETOU command +P. See $ERRORS.}

    nae$invalid_alarm_group         = nac$min_ecc_netou + 90,
    {E +P is not a valid alarm group name.}

    nae$no_command_sent             = nac$min_ecc_netou + 110,
    {E No CDCNET commands have been sent.}

    nae$response_not_received       = nac$min_ecc_netou + 145,
    {E No response received from system +P for the last CDCNET command.}

    nae$system_disconnected         = nac$min_ecc_netou + 160,
    {E Connection to system +P lost before CDCNET command sent.}

    nae$system_name_required        = nac$min_ecc_netou + 165,
    {E The name parameter is required for +P when the last CDCNET command ..
    {was sent to multiple systems.}

    nae$unknown_cdna_mdu_data_kind  = nac$min_ecc_netou + 190,
    {E Network message contains unknown kind of data.}

    nae$unknown_system              = nac$min_ecc_netou + 195,
    {E System +P is unknown.}

    nae$unsupported_address_kind    = nac$min_ecc_netou + 196,
    {E Address kind +P2, received from system +P1, is not supported.}

    nac$max_ecc_netou               = nac$min_ecc_netou + 199;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??

*DECK DECK=NAE$OSI_INTERNAL_INTERFACES EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$OSI_INTERNAL_INTERFACES ------ ''NA'' 7000..7200', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_osi_interface       = nac$min_ecc + 7000,

    nae$ta_accept_data_length_error = nac$min_ecc_osi_interface + 10,
    {E Accept data length cannot exceed +P bytes.}

    nae$ta_accept_conn_not_pending  = nac$min_ecc_osi_interface + 20,
    {E An accept connection request is not pending.}

    nae$ta_connect_data_len_error   = nac$min_ecc_osi_interface + 30,
    {E Connect data length cannot exceed +P bytes.}

    nae$ta_connect_not_established  = nac$min_ecc_osi_interface + 40,
    {E Connection not established.}

    nae$ta_connection_terminated    = nac$min_ecc_osi_interface + 50,
    {E The connection has been terminated.}

    nae$ta_data_length_error        = nac$min_ecc_osi_interface + 60,
    {E Data must be greater than +P bytes.}

    nae$ta_disconnect_data_len_err  = nac$min_ecc_osi_interface + 70,
    {E Disconnect data length cannot exceed +P bytes.}

    nae$ta_expedited_length_error   = nac$min_ecc_osi_interface + 80,
    {E Expedited data cannot exceed +P bytes and cannot be smaller than +P ..
    {bytes.}

    nae$ta_expedited_not_supported     = nac$min_ecc_osi_interface + 90,
    {E The expedited data request cannot be accepted because the ..
    {expedited data option was disabled during connection establishment.}

    nae$ta_expedited_request_limit     = nac$min_ecc_osi_interface + 100,
    {E The connection has reached the expedited request limit.  The  ..
    {communicating peer must confirm the outstanding expedited requests.}

    nae$ta_improper_aggregate_kind     = nac$min_ecc_osi_interface + 110,
    {E The only acceptable nlt$ta_aggregate kinds are  ..
    {nlt$ta_data_event and nlt$ta_expedited_data_event.}

    nae$ta_protocol_not_supported      = nac$min_ecc_osi_interface + 120,
    {E The requested protocol class is currently not supported.}

    nac$max_ecc_osi_interface       = nac$min_ecc_osi_interface + 200;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$SK_SOCKET_LAYER EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$SK_SOCKET_LAYER -------------- ''NA'' 7500..7800', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_socket_layer        = nac$min_ecc + 7500,

    nae$sk_no_accept_socket_avail   = nac$min_ecc_socket_layer + 10,
    {E No accept socket available.}

    nae$sk_max_sockets_limit        = nac$min_ecc_socket_layer + 15,
    {E Number of sockets already at maximum.}

    nae$sk_unknown_socket           = nac$min_ecc_socket_layer + 20,
    {E The socket +P is not known to the current job.}

    nae$sk_invalid_event            = nac$min_ecc_socket_layer + 25,
    {E The specified event +P is invalid.}

    nae$sk_socket_already_bound     = nac$min_ecc_socket_layer + 30,
    {E The given socket +P has already been bound.}

    nae$sk_insufficient_resources   = nac$min_ecc_socket_layer + 35,
    {E Insufficient network resources are available for the +P request to ..
    {complete.}

    nae$sk_invalid_user             = nac$min_ecc_socket_layer + 40,
    {E User not authorized to invoke +P.}

    nae$sk_tcpip_host_not_defined   = nac$min_ecc_socket_layer + 45,
    {E The TCP/IP host has not been defined.}

    nae$sk_invalid_attribute        = nac$min_ecc_socket_layer + 50,
    {E The requested attribute +P1 is not valid for the +P2 socket type.}

    nae$sk_unknown_attribute        = nac$min_ecc_socket_layer + 55,
    {E The requested attribute +P is unknown.}

    nae$sk_offer_not_accepted       = nac$min_ecc_socket_layer + 60,
    {E The socket offer was not accepted by the job +P.}

    nae$sk_caller_not_the_owner     = nac$min_ecc_socket_layer + 65,
    {E The request +P can be made only by the task that owns the socket.}

    nae$sk_unbound_socket           = nac$min_ecc_socket_layer + 70,
    {E The socket +P is not bound.}

    nae$sk_incorrect_socket_type    = nac$min_ecc_socket_layer + 75,
    {E The socket type is incorrect for the +P request.}

    nae$sk_max_nonblock_size_exceed = nac$min_ecc_socket_layer + 80,
    {E The data size exceeds the maximum allowed on non blocking send.}

    nae$sk_port_already_in_use      = nac$min_ecc_socket_layer + 85,
    {E The +P1 port number +P2 is already in use.}

    nae$sk_no_available_port        = nac$min_ecc_socket_layer + 95,
    {E Maximum number of +P ports are open.}

    nae$sk_invalid_option           = nac$min_ecc_socket_layer + 100,
    {E The selected option +P2 is not valid for a +P1 socket.}

    nae$sk_no_socket_offered        = nac$min_ecc_socket_layer + 110,
    {E No socket has been offered by job +P.}

    nae$sk_no_device_configured     = nac$min_ecc_socket_layer + 115,
    {E No device has been configured with +P.}

    nae$sk_socket_terminated        = nac$min_ecc_socket_layer + 120,
    {E The socket +P has been terminated.}

    nae$sk_io_pending               = nac$min_ecc_socket_layer + 125,
    {E There is IO active on socket +P.}

    nae$sk_no_data_available        = nac$min_ecc_socket_layer + 130,
    {E No data is available on socket +P.}

    nae$sk_receive_in_progress      = nac$min_ecc_socket_layer + 135,
    {E Other receivers are active on the socket +P.}

    nae$sk_send_in_progress         = nac$min_ecc_socket_layer + 140,
    {E Other senders are active on the socket +P.}

    nae$sk_socket_disconnected      = nac$min_ecc_socket_layer + 145,
    {E The socket +P has been disconnected.}

    nae$sk_interface_timeout        = nac$min_ecc_socket_layer + 150,
    {E The interface timeout expired and the request did not complete on socket +P.}

    nae$sk_data_area_too_small      = nac$min_ecc_socket_layer + 155,
    {E The buffer is too small to hold the message received over socket +P.}

    nae$sk_incorrect_option         = nac$min_ecc_socket_layer + 160,
    {E The value specified for the socket option +P is incorrect.}

    nae$sk_null_list                = nac$min_ecc_socket_layer + 165,
    {E A null list has been specified on +P.}

    nae$sk_unknown_socket_type      = nac$min_ecc_socket_layer + 170,
    {E The socket type is unknown.}

    nae$sk_no_accept_socket         = nac$min_ecc_socket_layer + 175,
    {E No accept socket available.}

    nae$sk_listen_not_done          = nac$min_ecc_socket_layer + 180,
    {E The given socket +P is not a listen socket.}

    nae$sk_socket_already_connected = nac$min_ecc_socket_layer + 185,
    {E The given socket +P is already connected.}

    nae$sk_listen_already_active    = nac$min_ecc_socket_layer + 190,
    {E Listen is already active on socket +P.}

    nae$sk_socket_not_connected     = nac$min_ecc_socket_layer + 195,
    {E The socket +P is not connected.}

    nae$sk_write_in_progress        = nac$min_ecc_socket_layer + 200,
    {E Other writes are in progress on socket +P}

    nae$sk_read_in_progress         = nac$min_ecc_socket_layer + 205,
    {E Other reads are in progress on socket +P.}

    nae$sk_zero_length_data         = nac$min_ecc_socket_layer + 210,
    {E Request to transfer zero length data.}

    nae$sk_job_recovery             = nac$min_ecc_socket_layer + 215,
    {E Socket +P terminated due to job recovery.}

    nae$sk_protocol_mismatch        = nac$min_ecc_socket_layer + 216,
    {E The requested socket type does not match the application protocol type.}

    nae$sk_socket_closed_via_peer   = nac$min_ecc_socket_layer + 217,
    {E The peer user has closed socket +P.}

    nae$sk_listen_active            = nac$min_ecc_socket_layer + 218,
    {E Listen is active on port +P.}

    nae$sk_internal_error           = nac$min_ecc_socket_layer + 219,
    {E Internal NAM/VE error encountered in +P.}

    nae$sk_address_in_use           = nac$min_ecc_socket_layer + 220,
    {E The IP addresses used to identify the TCP connect socket +P are ..
    {already in use.}

    nae$sk_broadcast_not_enabled    = nac$min_ecc_socket_layer + 221,
    {E Broadcast has not been enabled on this socket.}

    nac$max_ecc_socket_layer        = nac$min_ecc_socket_layer  + 300;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$SYSTEM_MGMT_ACCESS_AGENT EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'NAE$SYSTEM_MGMT_ACCESS_AGENT ------ ''NA'' 6200..6299', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_sys_mgmt_agent = nac$min_ecc + 6200,

    nae$sm_no_device_configured = nac$min_ecc_sys_mgmt_agent + 1,
    {E No network device is currently available. }

    nae$sm_route_unknown = nac$min_ecc_sys_mgmt_agent + 2,
    {E No route is known to the given destination address. }

    nae$sm_devices_inaccessible = nac$min_ecc_sys_mgmt_agent + 3,
    {E The network devices are either in flow control or are being
    { initialized. }

    nae$sm_peer_disconnect = nac$min_ecc_sys_mgmt_agent + 4,
    {E The system management connection disconnected by the peer with a reason
    { code of +P.}

    nae$sm_dup_host_address_reject = nac$min_ecc_sys_mgmt_agent + 5,
    {E The network device +P rejected the host network address.}

    nae$sm_dshnet_error            = nac$min_ecc_sys_mgmt_agent + 6,
    {E NAM/VE: Incorrect Device Specific Host Address returned by network
    { device +P.}

    nac$max_ecc_sys_mgmt_agent = nac$min_ecc_sys_mgmt_agent + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$TCPIP_MGMT_CONDITION_CODES EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'nae$tcpip_mgmt_condition_codes ----- ''NA'' 7400..7499', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_tcpip_access_agent    = nac$min_ecc + 7400,

    nae$tm_resources_unavailable    = nac$min_ecc_tcpip_access_agent + 1,
    {E The network resources are temporarily unavailable.}

    nae$tm_host_not_defined         = nac$min_ecc_tcpip_access_agent + 2,
    {E The TCP/IP host has not been defined.}

    nae$tm_strict_device_unavailabl = nac$min_ecc_tcpip_access_agent + 3,
    {E The destination address +P cannot be reached through the strict static route +P.}

    nae$tm_no_tcp_device_available = nac$min_ecc_tcpip_access_agent + 4,
    {E No device(s) currently available are configured with the TCP protocol.}

    nae$tm_no_tcp_routes_known      = nac$min_ecc_tcpip_access_agent + 5,
    {E The destination address +P cannot be reached.}

    nae$tm_no_udp_device_available = nac$min_ecc_tcpip_access_agent + 6,
    {E No device(s) currently available are configured with the UDP protocol.}

    nae$tm_no_udp_routes_known      = nac$min_ecc_tcpip_access_agent + 7,
    {E The destination address +P cannot be reached.}

    nae$tm_addr_not_for_tcp_device  = nac$min_ecc_tcpip_access_agent + 8,
    {E The address +P matches with a local device which is not configured with the TCP protocol stack.}

    nae$tm_addr_not_for_udp_device  = nac$min_ecc_tcpip_access_agent + 9,
    {E The address +P matches with a local device which is not configured with the UDP protocol stack.}

    nae$tm_local_address_not_found  = nac$min_ecc_tcpip_access_agent + 10,
    {E The address +P does not match with any of the locally connected communication devices.}

    nae$tm_duplicate_route = nac$min_ecc_tcpip_access_agent + 11,
    {E A static route definition to device +P with the destination address of +P and the destination ..}
    { address mask of +P has already been defined.}

    nae$tm_equivalent_strict_route = nac$min_ecc_tcpip_access_agent + 12,
    {E A strict static route definition with the destination address of +P and the destination ..}
    { address mask of +P has been previously been defined.}

    nae$tm_device_name_not_found = nac$min_ecc_tcpip_access_agent + 13,
    {E The name +P does not match with any of the local communication devices.}

    nae$tm_route_list_too_small = nac$min_ecc_tcpip_access_agent + 14,
    {E The number of routes defined is greater than the list to receive the definitions.}

    nae$tm_tcpip_not_configured = nac$min_ecc_tcpip_access_agent + 15,
    {E Device +P supports TCP/IP but TCP/IP has not been configured in the host network configuration file.}

    nac$max_ecc_tcpip_access_agent    = nac$min_ecc_tcpip_access_agent + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAE$TCP_CONDITION_CODES EXPAND=FALSE
*copyc nac$condition_code_limits
?? NEWTITLE := 'nae$tcp_condition_codes ----- ''NA'' 7300..7399', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST

    nac$min_ecc_tcp_access_agent    = nac$min_ecc + 7300,

    nae$tcp_socket_already_accepted = nac$min_ecc_tcp_access_agent + 5,
    {E The socket has already been accepted.}

    nae$tcp_socket_not_open         = nac$min_ecc_tcp_access_agent + 10,
    {E The socket has not been accepted.}

    nae$tcp_socket_terminated       = nac$min_ecc_tcp_access_agent + 15,
    {E The socket has been terminated.}

    nac$max_ecc_tcp_access_agent    = nac$min_ecc_tcp_access_agent + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NAH$ACCEPT_CONNECTION EXPAND=FALSE
{
{    The purpose of this request is to accept establishment of a CDNA
{  connection which has been requested by a CDNA client application.  In
{  general, the client may be any application which executes on some CDNA
{  system.
{
{    A requested connection must be accepted in order to complete connection
{  establishment.  Attempts to access a requested connection before the
{  connection is accepted will result in abnormal status.
{
{    The connection end point of a requested connection must be acquired by a
{  server application job before the connection may be accepted.
{
{    The definition of a server application (refer to the
{  MANAGE_NETWORK_APPLICATIONS utility) may specify that the NAM is to accept
{  each requested connection on behalf of the server application.  In this case,
{  the connection is established when its end point is acquired by a server
{  application job and this request is not used.
{
{    If the NAM does not accept requested connections on behalf of the server
{  application, a server application job must first acquire the connection end
{  point and then accept the connection.
{
{        NAP$ACCEPT_CONNECTION (FILE, STATUS)
{
{  FILE: (input) This parameter specifies the name of the network file which
{        identifies the local end point of the connection to be accepted.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$file_not_known
{              ame$improper_device_class
{              nae$accept_not_pending
{              nae$connection_terminated
{              nae$switch_offer_accepted
{              nae$switch_offer_pending
{              {other BAM conditions}
{
*DECK DECK=NAH$ACCEPT_SWITCH_OFFER EXPAND=FALSE
{
{    The purpose of this request is to accept a switch of ownership of a CDNA
{  connection end point from another job executing on the local system.
{  Switching ownership of a connection end point is a local system operation --
{  the peer application at the remote connection end point receives no
{  indication of this action.
{
{    Switching ownership of a connection end point is a cooperative process
{  which requires the active participation of both the source job (current
{  owner) and the destination job (proposed owner).  The source job makes an
{  offer to switch a connection end point to a destination job.  The
{  destination
{  job uses this request to accept the switch offer and complete the connection
{  end point switch.
{
{    If the specified source job has not offered to switch a connection end
{  point when this request is made, the request waits a specified interval of
{  time for a switch offer to be made (and completes as soon as an offer is
{  made).  If no switch offer is made within this interval, the request
{  returns an
{  abnormal status.  The osp$await_activity_complete request may also be used
{  to
{  wait for the source job to offer to switch a connection end point.
{
{    The connection whose end point is switched may or may not be established,
{  depending on the actions taken by the source job before the connection end
{  point is switched.  If the connection is not established, attempts to access
{  the connection will result in abnormal status.
{
{        NAP$ACCEPT_SWITCH_OFFER (FILE, SOURCE, ATTRIBUTES, WAIT_TIME, STATUS)
{
{  FILE: (input) This parameter specifies the name of the network file which is
{        to be created to identify the switched connection end point.
{
{        The network file is created in the $LOCAL catalog.
{
{  SOURCE: (input) This parameter specifies the job from which a connection end
{        point is to be switched.  Only a switch offer made by the specified
{        source job may be accepted.
{
{  ATTRIBUTES: (input) This parameter specifies the connection attribute values
{        which are to be used for the switched connection.  A value of NIL for
{        this parameter indicates that default values are to be used for all
{        attributes.
{
{  WAIT_TIME: (input) This parameter specifies the number of milliseconds that
{        the request is to wait for the specified source job to offer to switch
{        a connection end point.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$file_known
{              nae$invalid_eoi_message_size
{              nae$max_data_length_exceeded
{              nae$no_switch_offered
{              nae$unknown_attribute
{              {other BAM conditions
{
*DECK DECK=NAH$ACQUIRE_CONNECTION EXPAND=FALSE
{
{    The purpose of this request is to acquire ownership of a CDNA connection
{  end point which has been assigned to a server application.  The NAM assigns
{  a connection end point to a server application in response to a request by a
{  client application to establish a connection to the server.  In general, the
{  client may be any application which executes on some CDNA system.
{
{    Acquiring a connection end point is a local system operation which only
{  establishes ownership of the connection end point.  The client application
{  receives no indication of this action.
{
{    In order to acquire a connection end point, the requesting job must first
{  attach itself to a server application.  This identifies the job to the NAM as
{  a server application job.  Any server application job attached to a server
{  application may acquire a connection end point assigned to the server.
{
{    The NAM maintains a list of CDNA connection end points which have been
{  assigned to a server application.  Acquiring a connection end point
{  associates a network file with the connection end point at the head of the
{  list and removes the connection end point from the list.
{
{    If no connection end point has been assigned to the server application
{  when this request is made, the request waits a specified interval of time for
{  a connection end point to be assigned (and completes as soon as an assignment
{  occurs).  If no connection end point is assigned within this interval, an
{  abnormal status is returned.  The osp$await_activity_complete request may
{  also be used to wait for a connection end point to be assigned to a server
{  application.
{
{    The connection whose end point is acquired may or may not be established.
{  If the NAM has been directed to accept connection requests on behalf of the
{  server application (refer to the accept_connection attribute maintained by
{  the MANAGE_NETWORK_APPLICATIONS utility), then the acquired connection will
{  be an established connection.  Otherwise, the nap$accept_connection request
{  must be used to complete establishment of the acquired connection.
{
{        NAP$ACQUIRE_CONNECTION (SERVER, FILE, ATTRIBUTES, WAIT_TIME, STATUS)
{
{  SERVER: (input) This parameter specifies the name of the server application
{        on whose behalf a connection end point is to be acquired.  The
{        requesting job must have previously attached itself to the specified
{        server application.
{
{        The specified name must be the name of a defined server application --
{        refer to the MANAGE_NETWORK_APPLICATIONS utility.  The caller must
{        be authorized to perform the functions of the specified server
{        application.  The criteria used to validate this privilege is
{        determined by the server_ring, server_system_privilege and
{        server_capability attributes of the specified server application.
{
{  FILE: (input) This parameter specifies the name of the network file which is
{        to be created to identify the acquired connection end point.
{
{        The network file is created in the $LOCAL catalog.
{
{  ATTRIBUTES: (input) This parameter specifies the connection attribute values
{        which are to be used for the acquired connection.  A value of NIL for
{        this parameter indicates that default values are to be used for all
{        attributes.
{
{  WAIT_TIME: (input) This parameter specifies the number of milliseconds that
{        the request is to wait for a connection end point to be assigned to the
{        specified server application.  A value of 0 may be specified to avoid
{        waiting.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$file_known
{              nae$application_inactive
{              nae$invalid_connect_data_change
{              nae$invalid_eoi_message_size
{              nae$max_connections_acquired
{              nae$max_data_length_exceeded
{              nae$network_inactive
{              nae$no_connection_available
{              nae$server_not_attached
{              nae$unknown_application
{              nae$unknown_attribute
{              {other BAM conditions}
{
*DECK DECK=NAH$ACTIVATE_TCPIP EXPAND=FALSE
{
{    The purpose of this procedure is to activate a tcp/ip application.
{
{       NAP$ACTIVATE_TCPIP (APPLICATION, STATUS)
{
{ APPLICATION: (input)  Specifies the application name of the application to
{       activate.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$application_already_active
{             nae$application_file_errror
{             nae$application_file_not_open
{             nae$unknown_application
{
*DECK DECK=NAH$ADD_SERVER_TITLE EXPAND=FALSE
{
{    The purpose of this request is to add a title to the list of titles
{  registered in the CDNA Directory for a server application.  The specified
{  title is registered in the directory with the network address of the server
{  application. Client applications may then translate the title to obtain the
{  associated network address.
{
{    Besides the server application's network address, certain other server
{  attributes are registered in the CDNA Directory with the title.  These
{  attributes are optionally delivered to a client application as part of a
{  title translation.  The network address of the server application and the
{  type of connection (protocol) accepted by the server are obtained from the
{  server application's definition, as specified via the
{  MANAGE_NETWORK_APPLICATIONS utility, and registered in the CDNA Directory
{  with the title.  Other server attributes which are optionally registered in
{  the CDNA Directory with the title may be specified as parameters to this
{  request.
{
{    The requesting job need not be attached to the server application.
{  However, for a self-initiated server application, at least one job must be
{  attached to the server application.
{
{    The specified title is implicitly deleted from the list of titles
{  registered in the CDNA Directory under the following conditions:
{
{      - The server application's network address becomes inactive.  For a
{        self-initiated server, this occurs when no jobs remain attached to the
{        server.  For a NAM-initiated server, this occurs when the server is
{        deactivated.
{
{      - A NOS/VE deadstart occurs.
{
{  The nap$delete_server_title request may be used to explicitly delete the
{  title.
{
{        NAP$ADD_SERVER_TITLE (SERVER, TITLE, ATTRIBUTES,
{          BROADCAST_REGISTRATION, STATUS)
{
{  SERVER: (input) This parameter specifies the name of the server application
{        on whose behalf the title is to be registered.
{
{        The specified name must be the name of a defined server application --
{        refer to the MANAGE_NETWORK_APPLICATIONS utility.  The caller must be
{        authorized to perform the functions of the specified server
{        application.  The criteria used to validate this privilege is
{        determined by the server_ring, server_system_privilege and
{        server_capability attributes of the specified server application.
{
{  TITLE: (input) This parameter specifies the title to be registered.  This
{        title must be one of the SERVER_MANAGED_TITLES specified in the server
{        application's definition (refer to the MANAGE_NETWORK_APPLICATIONS
{        utility).
{
{  ATTRIBUTES: (input) This parameter specifies attributes of the server
{        application which are to be registered in the CDNA Directory with the
{        title and optionally delivered to a client application with a
{        translation of the title.  A NIL pointer indicates that no attributes
{        are specified.
{
{        The following attributes may be specified:
{
{          nac$title_priority: Specifies the priority of the server registering
{            the title relative to other servers which register the same title.
{            If no priority is specified, the title is registered with the
{            maximum priority.
{
{          nac$title_data: Specifies application-specific data to be
{            communicated to client applications.  The syntax and semantics of
{            this data are determined by the server application.  If no data is
{            specified, then none is registered in the CDNA Directory with the
{            title.
{
{  BROADCAST_REGISTRATION: (input) This parameter specifies whether a
{        translation of the title should be broadcast to remote systems when
{        the title is registered.   Such broadcasting is necessary to make the
{        translation available to client applications which use a recurrent
{        directory search.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS: nae$application_inactive
{              nae$directory_data_too_large
{              nae$duplicate_selector
{              nae$duplicate_title
{              nae$invalid_directory_priority
{              nae$invalid_selector
{              nae$network_inactive
{              nae$no_server_job_attached
{              nae$title_not_authorized
{              nae$title_too_long
{              nae$title_too_short
{              nae$unknown_application
{
*DECK DECK=NAH$ADD_TCP_SOCKET_LIST EXPAND=FALSE
{
{    The purpose of this procedure is to add an entry to the list of active
{ sockets for the application.  The tcpip_attributes entry is assumed to have
{ been interlocked by the user.
{
{       NAP$ADD_TCP_SOCKET_LIST (SOCKET_ASSIGNED, CONNECTION_ID,
{             TCPIP_ATTRIBUTES)
{
{ SOCKET_ASSIGNED: (input)  This parameter indicates that the socket has been
{       assigned to a job (TRUE) or received on the network and is awaiting
{       acceptance (FALSE).
{
{ CONNECTION_ID: (input)  This parameter specifies the connection identifier.
{
{ TCPIP_ATTRIBUTES:  (input output) This parameter specifies a pointer to the
{       tcpip_attibutes entry to which the entry is added.
{
*DECK DECK=NAH$ADD_UDP_SOCKET_LIST EXPAND=FALSE
{
{    The purpose of this procedure is to add an entry to the list of active
{ sockets for the application.  The tcpip_attributes entry is assumed to have
{ been interlocked by the user.
{
{       NAP$ADD_UDP_SOCKET_LIST (GLOBAL_SOCKET_ID, TCPIP_ATTRIBUTES)
{
{ GLOBAL_SOCKET_ID: (input)  This parameter specifies the global socket
{       identifier.
{
{ TCPIP_ATTRIBUTES:  (input output) This parameter specifies a pointer to the
{       tcpip_attibutes entry to which the entry is added.
{
*DECK DECK=NAH$ATTACH_SERVER_APPLICATION EXPAND=FALSE
{
{    The purpose of this request is to attach the requesting job to a server
{  application.  This notifies the NAM that the job intends to acquire
{  connections on behalf of the server application being attached.
{
{    This request identifies the job to the NAM as a server application job
{  for the specified server application.  A server application job must be
{  attached to the server application in order to acquire connections from
{  client applications.
{
{    A job may be concurrently attached to multiple server applications.
{  However, a job may not attach itself to the same server application twice
{  (without an intervening detach).
{
{    Multiple server application jobs may be concurrently attached to a
{  server application.  However, when enough jobs are attached to service the
{  maximum number of connections allowed for a server application, further
{  attaches are rejected.
{
{        NAP$ATTACH_SERVER_APPLICATION (SERVER, MAXIMUM_CONNECTIONS, STATUS)
{
{  SERVER: (input) This parameter specifies the name of the server application
{        on whose behalf the requesting job intends to acquire connections.
{
{        The specified name must be the name of a defined server application --
{        refer to the MANAGE_NETWORK_APPLICATIONS utility.  The caller must
{        be authorized to perform the functions of the specified server
{        application.  The criteria used to validate this privilege is
{        determined by the server_ring, server_system_privilege and
{        server_capability attributes of the specified server application.
{
{  MAXIMUM_CONNECTIONS: (input) This parameter specifies the maximum number of
{        connections which the server application job can acquire and service
{        (for the specified server application) at any given time.
{
{        While attached to a server, a server application job is expected to
{        acquire a connection whenever the number of connections being serviced
{        by the job is less than this number.  Failure to adhere to this
{        constraint may result in client applications being unable to obtain
{        service.
{
{        A value of 0 indicates that the server application job services as
{        many connections as the server application is authorized to have
{        established.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              nae$appl_already_attached
{              nae$application_attach_limit
{              nae$application_inactive
{              nae$insufficient_resources
{              nae$max_connections_mismatch
{              nae$network_inactive
{              nae$unknown_application
{
*DECK DECK=NAH$AWAIT_DATA_AVAILABLE EXPAND=FALSE
{
{    The purpose of this request is to wait until data is available to be
{  received from a peer application over an established CDNA Session
{  connection.
{
{    This request completes as soon as data is available to be received.  If no
{  data is available when this request is made, the request waits a specified
{  interval of time for data to become available.  If no data becomes available
{  within the specified interval, the request will return abnormal status with
{  condition nae$no_data_available.
{
{    The request completes (with normal status) when one of the following
{  conditions occurs:
{
{    - A complete message (or a partial message which completes a message) is
{      available.
{
{    - A partial message whose length equals or exceeds 4096 bytes is
{      available.
{
{    - A partial message contained in 4 or more message blocks is available.
{
{    NOTE: The fact that this request completes normally when 4096 bytes of
{  partial message data are available reflects the limit on the amount of data
{  which may be held within the connection.  A receive data operation will not
{  complete upon delivering a partial message of this size.  In order to insure
{  immediate completion, a request which initiates a receive data operation
{  must specify a buffer of no more than 4096 bytes. If the peer has sent a
{  partial message in blocks smaller than the maximum Transport PDU size, then
{  it is possible for the limit of queued buffers to be reached before the limit
{  on queued data. If this occurs, a receive data operation with a buffer of
{  4096 bytes may not complete immediately, either. The receive buffer size
{  must be established based on the behavior of the peer if immediate completion
{  of a receive request is to occur.
{
{    The osp$await_activity_complete request may also be used to wait for data
{  to be available.  It indicates that data is available under the same
{  conditions.
{
{    At any given time, only one task may be waiting for data to become
{  available on a given connection (no matter which request is used to wait
{  for data).
{
{    A task may not wait for data to become available on a connection if there
{  is already a task waiting for data to become available on the connection or
{  a receive data operation is in progress for the connection.  An attempt to
{  await data availability under either of these conditions results in abnormal
{  status with the condition nae$multiple_waits_attempted.
{
{    WARNING: An application must receive data which has been sent by the peer
{  application within a reasonable amount of time.  If available data
{  accumulates in the connection over an extended period of time, the NAM
{  terminates the connection.
{
{        NAP$AWAIT_DATA_AVAILABLE (FILE_IDENTIFIER, WAIT_TIME,
{          EXPECTED_WAIT_TIME, STATUS)
{
{  FILE_IDENTIFIER: (input) This parameter specifies the file access identifier
{        established when the network file was opened.
{
{  WAIT_TIME: (input) This parameter specifies the maximum number of
{        milliseconds the request is to wait for data to become available.
{
{  EXPECTED_WAIT_TIME: (input) This parameter specifies the expected number of
{        milliseconds the request will have to wait for data to become
{        available.  A value of 0 indicates that no estimate of the actual wait
{        time is being provided.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$improper_device_class
{              ame$improper_file_id
{              ame$ring_validation_error
{              nae$multiple_waits_attempted
{              nae$no_data_available
{              {other BAM conditions}
{
*DECK DECK=NAH$AWAIT_SERVER_RESPONSE EXPAND=FALSE
{
{    The purpose of this request is to wait for a server application to respond
{  to a previous request to establish a connection.
{
{    This request waits a specified interval of time for the server application
{  to respond to the connection request.  If the server has already responded,
{  the request completes immediately.  If the server responds within this
{  interval, the request completes when the response is received.  If the
{  server does not respond within this interval, the request returns abnormal
{  status with the condition nae$no_server_response.
{
{    Note that this request may be made in a task other than the one in which
{  the request to establish the connection is made, provided that both tasks
{  execute in the same job.  However, at any given time, only one task may be
{  waiting for a server response to a requested connection.
{
{        NAP$AWAIT_SERVER_RESPONSE (FILE, WAIT_TIME, STATUS)
{
{  FILE: (input) This parameter specifies the name of the network file which
{        identifies the local end point of the requested connection.
{
{  WAIT_TIME: (input) This parameter specifies the number of milliseconds that
{        the request is to wait for the server to respond to the connection
{        request.  A value of 0 may be specified to avoid waiting (i.e., to
{        simply determine if the server has already responded).
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$file_not_known
{              ame$improper_device_class
{              nae$multiple_waits_attempted
{              nae$network_inactive
{              nae$no_server_response
{              nae$switch_offer_pending
{              {other BAM conditions}
{
*DECK DECK=NAH$BEGIN_DIRECTORY_SEARCH EXPAND=FALSE
{
{    The purpose of this request is to initiate a CDNA Directory search.  A
{  directory search consists of scanning the CDNA Directory for translations of
{  titles which match a specified title pattern.  A title translation consists
{  of the network address registered in the CDNA Directory with the title and,
{  optionally, certain other attributes of the server application which
{  registered the title.
{
{    A directory search occurs asynchronous to (concurrent with) execution of
{  the task which initiates the search.  For each title which matches the
{  specified title pattern, a title translation is made available for delivery
{  to the task which initiated the directory search.  A title translation is
{  delivered to a task via the nap$get_title_translation request.  A task may
{  use the osp$await_activity_completion request to wait for a title translation
{  to be available for delivery.  A task may terminate a directory search via
{  the nap$end_directory_search request.
{
{        NAP$BEGIN_DIRECTORY_SEARCH (TITLE_PATTERN, CLIENT, RECURRENT_SEARCH,
{          SEARCH_IDENTIFIER, STATUS)
{
{  TITLE_PATTERN: (input) This parameter specifies a title pattern which
{        matches the titles for which translations are to be delivered.
{
{  CLIENT: (input) This parameter specifies the name of the client application
{        on whose behalf the directory search is to be initiated.
{
{        The specified name must be the name of a defined client application --
{        refer to the MANAGE_NETWORK_APPLICATIONS utility.  The caller must be
{        authorized to perform the functions of the specified client
{        application.  The criteria used to validate this privilege is
{        determined by the client_ring, client_system_privilege and
{        client_capability attributes of the specified client application.
{
{        Only translations of titles registered by server applications which use
{        the same type of connection as the specified client application are
{        returned by the directory search.  The type of connection used by the
{        client application is specified when the application is defined.
{
{  RECURRENT_SEARCH: (input) This parameter specifies whether the directory
{        search is to be recurrent.
{
{        Both recurrent and non-recurrent directory searches perform an initial
{        scan of the CDNA Directory for matching titles.  When this scan is
{        complete, a non-recurrent search completes.  A recurrent search
{        continues to examine broadcasted title translations and makes
{        available for delivery any that match the specified title pattern.  A
{        recurrent search never completes; the search continues until explicitly
{        terminated by the task which initiated it.
{
{        The recurrent directory search provides a means for a client
{        application to be notified of titles which are registered in the CDNA
{        Directory after the initial scan of the directory has been completed.
{        To be effective, a recurrent search must be used in conjunction with
{        broadcasting the registration of the titles to be translated.
{
{  SEARCH_IDENTIFIER: (output) This parameter specifies an identifier for the
{        directory search which must be supplied on all subsequent requests
{        which reference the search.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS: nae$application_inactive
{              nae$network_inactive
{              nae$title_pattern_too_long
{              nae$title_pattern_too_short
{              nae$unknown_application
{
*DECK DECK=NAH$BUILD_MASTER_CONTROL_TABLE EXPAND=FALSE
{
{    The purpose of this request is to initialize the Master Control Table for
{ a given logical unit.  The specified device identifier is stored in the
{ Master Control Table.  After the table has been initialized, the INITIALIZED
{ flag in the buffer is set to TRUE.  This flag indicates to the network PP
{ that the initialization of the Master Control Table is complete.
{
{  NOTE:  The unit interface table and the unit communication buffer must be
{        setup before this procedure is called.
{
{       NAP$BUILD_MASTER_CONTROL_TABLE (LOGICAL_UNIT, DEVICE_ID)
{
{ LOGICAL_UNIT: (input)  This parameter specifies the logical unit identifier
{       of the network device being configured.
{
{ DEVICE_ID: (input)  This parameter specifies the identifier of the network
{       device being configured.
{
*DECK DECK=NAH$CANCEL_SWITCH_OFFER EXPAND=FALSE
{
{    The purpose of this request is to cancel an offer to switch ownership of a
{  CDNA connection end point to another job executing on the local system.
{
{    Switching ownership of a connection end point is a cooperative process
{  which requires the active participation of both the source job (current
{  owner) and the destination job (proposed owner).  The source job makes an
{  offer to switch a connection end point to a destination job.  The destination
{  job accepts this switch offer to complete the connection end point switch.
{
{    This request is used by a source job to retract a switch offer which has
{  not been accepted by the destination job within a reasonable amount of time.
{
{    Note that this request may be made in a task other than the one which made
{  the switch offer -- but both tasks must execute in the same job.
{
{        NAP$CANCEL_SWITCH_OFFER (FILE, STATUS)
{
{  FILE: (input) This parameter specifies the name of the network file which
{        identifies the connection end point for which a switch of ownership has
{        been offered.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$file_not_known
{              ame$improper_device_class
{              nae$no_switch_offer_pending
{              nae$switch_offer_accepted
{              {other BAM conditions}
{
*DECK DECK=NAH$CHANGE_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to specify connection attribute values to be
{  used for a connection.  The connection whose attributes are to be changed is
{  specified via the network file which identifies the local end point of the
{  connection.
{
{    If a connection access attribute is changed, the new value specifies the
{  initial instance of open attribute value to be used for subsequent instances
{  of open of the specified network file.
{
{        NAP$CHANGE_ATTRIBUTES (FILE, ATTRIBUTES, STATUS)
{
{  FILE: (input) This parameter specifies the name of the network file which
{        identifies the local end point of the connection whose attributes are
{        to be changed.
{
{  ATTRIBUTES: (input) This parameter specifies the attributes to be changed and
{        the new values for these attributes.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$file_not_known
{              ame$improper_device_class
{              nae$connection_terminated
{              nae$invalid_eoi_message_size
{              nae$invalid_connect_data_change
{              nae$max_data_length_exceeded
{              nae$switch_offer_accepted
{              nae$switch_offer_pending
{              nae$unknown_attribute
{              {other BAM conditions}
{
*DECK DECK=NAH$CHANGE_CLIENT EXPAND=FALSE

{
{    The purpose of this request is to change the attributes of a client
{  application.
{
{       NAP$CHANGE_CLIENT (CLIENT, MAX_CONNECTIONS, CONNECTION_PRIORITY,
{             RESERVED_APPLICATION_ID, APPLICATION_ID, CLIENT_CAPABILITY,
{             CLIENT_RING, CLIENT_SYSTEM_PRIVILEGE, STATUS)
{
{ CLIENT: (input) This parameter specifies the name of the client application
{       whose attributes are to be changed.
{
{ MAX_CONNECTIONS: (input) This parameter specifies the new max_connections
{       attribute value.
{
{ CONNECTION_PRIORITY: (input) This parameter specifies the new
{       connection_priority attribute value.
{
{ RESERVED_APPLICATION_ID: (input) This parameter specifies the new
{       reserved_application_id attribute value.
{
{ APPLICATION_ID: (input) This parameter specifies the new application_id
{       attribute value.
{
{ CLIENT_CAPABILITY: (input) This parameter specifies the new
{       client_capability attribute value.
{
{ CLIENT_RING: (input) This parameter specifies the new client_ring attribute
{       value.
{
{ CLIENT_SYSTEM_PRIVILEGE: (input) This parameter specifies the new
{       client_system_privilege attribute value.
{
{ STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              nae$application_file_error
{              nae$application_file_mismatch
{              nae$application_file_not_open
{              nae$application_not_restored
{              nae$incorrect_appl_file_version
{              nae$invalid_user
{

*DECK DECK=NAH$CHANGE_NAM_ATTRIBUTES_R1 EXPAND=FALSE

{
{    The purpose of this procedure is to change the value of
{    a NAM/VE attribute that resides in ring 1.
{
{          NAP$CHANGE_NAM_ATTRIBUTES_R1 (ATTRIBUTE_KIND,
{                 ATTRIBUTE)
{
{   ATTRIBUTE_KIND: (input) This parameter specifies the NAM/VE
{              attribute which is to be changed.
{
{   ATTRIBUTE: (input) This parameter specifies the new value
{              the attribute is to be changed to.
{
{    NOTE: Currently the only attribute changed by this procedure
{          is nac$max_connections_attr. Results of calling this
{          procedure with any other attribute as input are
{          indeterminate.
{
*DECK DECK=NAH$CHANGE_NETWORK_DEVICE_STATE EXPAND=FALSE
{
{    The purpose of this procedure is to change the state of the given network
{ device.  This procedure is called by the configuration mgmt procedure that
{ processes element state changes.  If the network device is being turned ON,
{ the appropriate network elements are reserved and the network access is
{ turned ON.  If the device is turned OFF or DOWN, the reserved elements are
{ returned and the network access is marked as being DOWN.  When the state
{ change is invoked by the intranet layer mgmt task, it is assumed that the PP
{ has been idled.
{
{       NAP$CHANGE_NETWORK_DEVICE_STATE (ELEMENT, NEW_STATE, OLD_STATE, STATUS)
{
{  ELEMENT (input):  This parameters specifies the element name of the
{        network device for which the state change has been requested.
{
{  NEW_STATE (input):  This parameter specifies the new state for the
{        element.
{
{  OLD_STATE (input):  This parameter specifies the old state of the
{        element.
{
{  STATUS (output):  This parameter specifies the request status.
{
*DECK DECK=NAH$CHANGE_SERVER EXPAND=FALSE

{
{    The purpose of this request is to change the attributes of a server
{  application.
{
{       NAP$CHANGE_SERVER (SERVER, SELECTED_TITLES_CHANGED, SELECTED_TITLES,
{             SERVER_MANAGED_TITLES, MAX_CONNECTIONS, CONNECTION_PRIORITY,
{             SERVER_CAPABILITY, SERVER_RING, SERVER_SYSTEM_PRIVILEGE,
{             ACCEPT_CONNECTION, CLIENT_VALIDATION, CLIENT_INFO_SOURCE,
{             CLIENT_ADDRESSES, RESERVED_APPLICATION_ID, APPLICATION_ID,
{             SERVER_JOB_CHANGED, SERVER_JOB, SERVER_JOB_VALIDATION_SOURCE,
{             SERVER_JOB_MAX_CONNECTIONS, STATUS)
{
{ SERVER: (input) This parameter specifies the name of the server application
{       whose attributes are to be changed.
{
{ SELECTED_TITLES_CHANGED: (input) This parameter specifies whether a change
{       was made to the selected titles list.
{
{ SELECTED_TITLES: (input) This parameter specifies the new selected titles
{       list attribute.
{
{ SERVER_MANAGED_TITLES: (input) This parameter specifies the new server
{       managed titles list attribute.
{
{ MAX_CONNECTIONS: (input) This parameter specifies the new max_connections
{       attribute value.
{
{ CONNECTION_PRIORITY: (input) This parameter specifies the new
{       connection_priority attribute value.
{
{ SERVER_CAPABILITY: (input) This parameter specifies the new
{       server_capability attribute value.
{
{ SERVER_RING: (input) This parameter specifies the new server_ring attribute
{       value.
{
{ SERVER_SYSTEM_PRIVILEGE: (input) This parameter specifies the new
{       server_system_privilege attribute value.
{
{ ACCEPT_CONNECTION: (input) This parameter specifies the new
{       accept_connection attribute value.
{
{ CLIENT_VALIDATION_CAPABILITY: (input) This parameter specifies the new
{       client_validation_capability attribute value.
{
{ CLIENT_INFO_SOURCE: (input) This parameter specifies the new
{       client_info_source attribute value.
{
{ CLIENT_ADDRESSES: (input) This parameter specifies the new client addresses
{       list attribute.
{
{ RESERVED_APPLICATION_ID: (input) This parameter specifies whether the
{       new application_id value is reserved.
{
{ APPLICATION_ID: (input) This parameter specifies the new application_id
{       attribute value.
{
{ SERVER_JOB_CHANGED: (input) This parameter specifies whether the server
{       job contents were changed.
{
{ SERVER_JOB: (input) This parameter specifies the name of the file that
{       contains the server job commands.
{
{ SERVER_JOB_VALIDATION_SOURCE: (input) This parameter specifies the new
{       server_job_validation_source attribute value.
{
{ SERVER_JOB_MAX_CONNECTIONS: (input) This parameter specifies the new
{       server_job_max_connections attribute value.
{
{ STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              nae$application_file_error
{              nae$application_file_mismatch
{              nae$application_file_not_open
{              nae$application_not_restored
{              nae$incorrect_appl_file_version
{              nae$invalid_user


{
{    The purpose of this request is to change the attributes of a server
{  application.
{
{       NAP$CHANGE_SERVER (SERVER, SELECTED_TITLES_CHANGED, SELECTED_TITLES,
{             SERVER_MANAGED_TITLES, MAX_CONNECTIONS, CONNECTION_PRIORITY,
{             SERVER_CAPABILITY, SERVER_RING, SERVER_SYSTEM_PRIVILEGE,
{             ACCEPT_CONNECTION, CLIENT_VALIDATION, CLIENT_INFO_SOURCE,
{             CLIENT_ADDRESSES, RESERVED_APPLICATION_ID, APPLICATION_ID,
{             SERVER_JOB_CHANGED, SERVER_JOB, SERVER_JOB_VALIDATION_SOURCE,
{             SERVER_JOB_MAX_CONNECTIONS, STATUS)
{
{ SERVER: (input) This parameter specifies the name of the server application
{       whose attributes are to be changed.
{
{ SELECTED_TITLES_CHANGED: (input) This parameter specifies whether a change
{       was made to the selected titles list.
{
{ SELECTED_TITLES: (input) This parameter specifies the new selected titles
{       list attribute.
{
{ SERVER_MANAGED_TITLES: (input) This parameter specifies the new server
{       managed titles list attribute.
{
{ MAX_CONNECTIONS: (input) This parameter specifies the new max_connections
{       attribute value.
{
{ CONNECTION_PRIORITY: (input) This parameter specifies the new
{       connection_priority attribute value.
{
{ SERVER_CAPABILITY: (input) This parameter specifies the new
{       server_capability attribute value.
{
{ SERVER_RING: (input) This parameter specifies the new server_ring attribute
{       value.
{
{ SERVER_SYSTEM_PRIVILEGE: (input) This parameter specifies the new
{       server_system_privilege attribute value.
{
{ ACCEPT_CONNECTION: (input) This parameter specifies the new
{       accept_connection attribute value.
{
{ CLIENT_VALIDATION_CAPABILITY: (input) This parameter specifies the new
{       client_validation_capability attribute value.
{
{ CLIENT_INFO_SOURCE: (input) This parameter specifies the new
{       client_info_source attribute value.
{
{ CLIENT_ADDRESSES: (input) This parameter specifies the new client addresses
{       list attribute.
{
{ RESERVED_APPLICATION_ID: (input) This parameter specifies whether the
{       new application_id value is reserved.
{
{ APPLICATION_ID: (input) This parameter specifies the new application_id
{       attribute value.
{
{ SERVER_JOB_CHANGED: (input) This parameter specifies whether the server
{       job contents were changed.
{
{ SERVER_JOB: (input) This parameter specifies the name of the file that
{       contains the server job commands.
{
{ SERVER_JOB_VALIDATION_SOURCE: (input) This parameter specifies the new
{       server_job_validation_source attribute value.
{
{ SERVER_JOB_MAX_CONNECTIONS: (input) This parameter specifies the new
{       server_job_max_connections attribute value.
{
{ STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              nae$application_file_error
{              nae$application_file_mismatch
{              nae$application_file_not_open
{              nae$application_not_restored
{              nae$incorrect_appl_file_version
{              nae$invalid_user
{

*DECK DECK=NAH$CHANGE_TCPIP EXPAND=FALSE
{
{    The purpose of this procedure is to change a given TCP/IP application
{ definition.  The change is made to the application file and if NAM/VE is
{ active to the TCP/IP attributes list.
{
{       NAP$CHANGE_TCPIP (APPLICATION, MAXIMUM_SOCKETS, TCPIP_CAPABILITY,
{             TCPIP_RING, TCPIP_SYSTEM_PRIVILEGE, STATUS)
{
{ APPLICATION: (input)  Specifies the name of the application whose definition
{       is to be changed.
{
{ MAXIMUM_SOCKETS: (input)  This parameter specifies the maximum number of
{       sockets allowed for this application.
{
{ TCPIP_CAPABILITY: (input)  This parameter specifies the capability attribute
{       of the application.
{
{ TCPIP_RING: (input)  This parameter specifies the ring attribute of the
{       application.
{
{ TCPIP_SYSTEM_PRIVILEGE: (input)  This parameter specifies the system
{       privilege attribute of the application.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$application_file_error
{             nae$application_file_not_open
{             nae$incorrect_appl_file_version
{             nae$unknown_application
{
*DECK DECK=NAH$CHECKSUM EXPAND=FALSE
{
{   The purpose of this request is to calculate the 16 bit ones complement
{ checksum of a block of data on a computer that uses twos complement
{ arithmetic. The data is allowed to be in multiple fragments.
{
{   If an odd number of bytes are given in the data block, the last byte
{ of data is treated as the first byte of a 16 bit parcel with zero fill.
{
{   A computed checksum value of minus zero is converted to plus zero.
{
{        NAP$CHECKSUM (DATA_FRAGMENTS)
{
{ DATA_FRAGMENTS: This parameter specifies the address and length of the
{        blocks of data to be checksummed.
{
*DECK DECK=NAH$CLOSE_NETWORK_SAP EXPAND=FALSE
{
{    The purpose of this request is to terminate access to a previously opened
{ service access point.  Any datagrams sent to this service access point which
{ have arrived at the local system and have not been delivered will be
{ discarded.
{
{       NAP$CLOSE_NETWORK_SAP (SAP, STATUS)
{
{ SAP: (input)  This parameter specifies an open service access point to be
{       closed.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$sap_not_open
{       IDENTIFIER: 'NA'
{
*DECK DECK=NAH$CN_CLOSE_SAP EXPAND=FALSE
{
{   The purpose of this request is to terminate access to a previously opened
{ channelnet service access point.  Any datagrams sent to this service access
{ point which have arrived at the local system and have not been delivered
{ will be discarded.
{
{       NAP$CN_CLOSE_SAP (SAP, STATUS)
{
{ SAP: (input) This parameter specifies an open service access point to be
{       closed.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$layer_access_not_authorized, nae$sap_not_open
{       IDENTIFIER: 'NA'
{
*DECK DECK=NAH$CN_OPEN_SAP EXPAND=FALSE
{
{   The purpose of this request is to establish access to a specific
{ channelnet service access point.  Channelnet datagrams may be sent and
{ received over the opened service access point.  The opened service access
{ point may be used only by the task which issued the open request.
{
{       NAP$CN_OPEN_SAP (SAP, MAXIMUM_DATA_LENGTH, STATUS)
{
{ SAP: (input) This parameter specifies the service access point which is to
{       be opened.
{
{ MAXIMUM_DATA_LENGTH: (output) This parameter specifies the maximum length of
{       the data which may be sent over the opened service access point in a
{       single datagram.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$layer_access_not_authorized, nae$sap_already_open
{       IDENTIFIER: 'NA'
{
*DECK DECK=NAH$CN_RECEIVE_DATAGRAM EXPAND=FALSE
{
{    The purpose of this request is to accept delivery of a channelnet
{ datagram.  The datagram to be delivered (if any) will be taken from the queue
{ of datagrams which have arrived at the local system.  The order in which
{ datagrams are delivered may not be the same as the order in which they were
{ sent.
{
{       NAP$CN_RECEIVE_DATAGRAM (SAP, DATA_AREA, WAIT_TIME, DEVICE, SOURCE,
{             RECEIVED_DATA_LENGTH, STATUS)
{
{ SAP: (input)  This parameter specifies an open service access point over
{       which delivery is to occur.  Only a datagram sent to this service
{       access point will be delivered.
{
{ DATA_AREA: (input)  This parameter specifies a data area to receive the data
{       contained in the datagram.
{
{ WAIT_TIME: (input)  This parameter specifies the amount of time (in
{       milliseconds) that the caller is willing to wait for a datagram to be
{       delivered.  Control will not be returned to the caller until a datagram
{       is available or the wait duration expires.  If no datagram is available
{       for delivery within this amount of time, an abnormal status will be
{       returned.
{
{ DEVICE: (output)  This parameter specifies the network device over which the
{       datagram arrived.
{
{ SOURCE: (output)  This parameter specifies the source system address.  It
{       identifies the channelnet over which the datagram was received and the
{       address of the sending system on that channelnet.
{
{ RECEIVED_DATA_LENGTH: (output)  This parameter specifies the length of the
{       data contained in the datagram and delivered to the specified data
{       area.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$layer_access_not_authorized
{             nae$sap_not_open
{             nae$data_area_too_small
{             nae$no_datagram_available
{       IDENTIFIER: 'NA'
{
*DECK DECK=NAH$CN_SEND_DATAGRAM EXPAND=FALSE
{
{    The purpose of this request is to send a channelnet datagram to a
{ specified address.  Reliable delivery of the datagram is not guaranteed.
{
{       NAP$CN_SEND_DATAGRAM (SAP, DEVICE, DESTINATION, DATA, STATUS)
{
{ SAP: (input)  This parameter specifies an open service access point from
{       which the datagram is to be sent.
{
{ DEVICE: (input)  This parameter specifies the network device thru which the
{       datagram is to be sent.
{
{ DESTINATION: (input)  This parameter specifies the destination address of the
{       system to which the datagram is to be sent.  It identifies the network
{       over which the datagram is to be sent and the address of the system on
{       that network.
{
{ DATA: (input)  This parameter specifies the data to be delivered at the
{       destination.  The length of this data may not exceed the maximum data
{       length returned when the SAP was opened.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$layer_access_not_authorized
{             nae$sap_not_open
{             nae$unknown_channelnet
{             nae$max_data_length_exceeded
{       IDENTIFIER: 'NA'
{
*DECK DECK=NAH$CN_SIGNAL_HANDLER EXPAND=FALSE
{
{    The purpose of this request is to process the 'network device error'
{   signal. This signal handler is to execute in the system input task
{   only. This signal handler is invoked for any of the following reasons:
{
{    1) To replenish the PP buffer pools,
{
{    2) To reset the link to a particular device, (in the case of a
{       detected CC protocol error)
{
{    3) To release buffers returned as part of a PP detected read error.
{
{       NAP$CN_SIGNAL_HANDLER (ORIGINATOR, SIGNAL)
{
{  ORIGINATOR: (input) This parameter is ignored.
{
{  SIGNAL: (input) This parameter specifies the signal.
{
*DECK DECK=NAH$COMPUTE_ETHERNET_CHECKSUM EXPAND=FALSE
{
{    The purpose of this request is to calculate the checksum of a specified
{ Ethernet address.  The checksum algorithm used is that described in Appendix B
{ of the Ethernet V2.0 Specification.
{
{
{       NAP$COMPUTE_ETHERNET_CHECKSUM (ETHERNET_ADDRESS, CHECKSUM)
{
{
{ ETHERNET_ADDRESS: (input)  This parameter specifies the Ethernet address to
{       be checksummed.
{
{ CHECKSUM: (output)  This parameter specifies the calculated checksum.
{
*DECK DECK=NAH$DEACTIVATE_TCPIP EXPAND=FALSE
{
{    The purpose of this procedure is to deactivate a given application .
{
{       NAP$DEACTIVATE_TCPIP (APPLICATION, TERMINATE_ACTIVE_SOCKETS, STATUS)
{
{ APPLICATION: (input)  Specifies the name of the application to deactivate.
{
{ TERMINATE_ACTIVE_SOCKETS: (input)  This parameter specifies if active sockets
{       are to be terminated.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$application_already_inactiv
{             nae$application_file_error
{             nae$application_file_not_open
{             nae$unknown_application
{
*DECK DECK=NAH$DEFINE_TCPIP EXPAND=FALSE
{
{    The purpose of this procedure is to define a TCP/IP application.
{
{       NAP$DEFINE_TCPIP (APPLICATION, MAXIMUM_SOCKETS, TCPIP_CAPABILITY,
{             TCPIP_RING, TCPIP_SYSTEM_PRIVILEGE, PROTOCOL, STATUS)
{
{ APPLICATION: (input)  Specifies the application name.
{
{ MAXIMUM_SOCKETS: (input)  This parameter specifies the maximum number of
{       sockets allowed for this application.
{
{ TCPIP_CAPABILITY: (input)  This parameter specifies the capability attribute
{       of the application.
{
{ TCPIP_RING: (input)  This parameter specifies the ring attribute of the
{       application.
{
{ TCPIP_SYSTEM_PRIVILEGE: (input)  This parameter specifies the system
{       privilege attribute of the application.
{
{ PROTOCOL: (input)  This parameter specifies the protocol attribute of the
{       application.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$application_file_not_open
{
*DECK DECK=NAH$DELETE_SERVER_TITLE EXPAND=FALSE
{
{    The purpose of this request is to delete one or more titles from the list
{  of titles registered in the CDNA Directory for a server application.  Once
{  a title has been deleted, client applications can no longer obtain a
{  translation of the title to determine the network address of the associated
{  server application.
{
{    The requesting job need not be attached to the server application.  The
{  requesting task need not be the task which added the titles to be deleted.
{
{         NAP$DELETE_SERVER_TITLE (SERVER, TITLE_PATTERN, STATUS)
{
{  SERVER: (input) This parameter specifies the name of the server application
{        whose title is to be deleted.
{
{        The specified name must be the name of a defined server application --
{        refer to the MANAGE_NETWORK_APPLICATIONS utility.  The caller must be
{        authorized to perform the functions of the specified server
{        application.  The criteria used to validate this privilege is
{        determined by the server_ring, server_system_privilege and
{        server_capability attributes of the specified server application.
{
{  TITLE_PATTERN: (input) This parameter specifies a title pattern which
{        matches the titles to be deleted.
{
{        Only server titles added to the list via the nap$add_server_title
{        request will be deleted.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS: nae$application_inactive
{              nae$network_inactive
{              nae$no_title_match
{              nae$title_pattern_too_long
{              nae$title_pattern_too_short
{              nae$unknown_application
{
*DECK DECK=NAH$DELETE_TCPIP EXPAND=FALSE
{
{    The purpose of this procedure is to delete a TCP/IP application from the
{ application definition file and the TCP/IP attributes list.
{
{       NAP$DELETE_TCPIP (APPLICATION, STATUS)
{
{ APPLICATION: (input)  This parameter specifies the name of the application to
{       delete.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$active_sockets
{             nae$application_active
{             nae$application_file_not_open
{             nae$unknown_application
{
*DECK DECK=NAH$DELIVER_INTERNET_EVENT EXPAND=FALSE
{
{    The purpose of this procedure is to deliver the Xerox Internet data events
{ to the network layer external interface.  The data events are queued on the
{ sap descriptor for the specified sap at the external interface to the network
{ layer.
{
{       NAP$DELIVER_INTERNET_EVENT (SAP, USER_SAP_ID, SOURCE_ADDRESS,
{             USER_PROTOCOL, MULTICAST, MESSAGE_HEADER, MESSAGE_HEADER_LENGTH,
{             DATAGRAM)
{
{ SAP: (input)  This parameter specifies the network sap identifier over
{       which the event was received.
{
{ USER_SAP_ID: (input) This is a dummy parameter for this interface.
{
{ SOURCE_ADDRESS: (input)  This parameter specifies the XNS internet address
{       from which the data was sent.
{
{ USER_PROTOCOL: (output) This parameter specifies the user protocol value
{       associated with the datagram.  The user protocol value may be used to
{       distinguish between different types of datagrams sent to the same
{       destination from a single source.
{
{ MULTICAST: (output) This parameter specifies whether or not the datagram was
{       delivered to the local system via a multicast on the underlying
{       network.
{
{ MESSAGE_HEADER: (input, output) This is a dummy parameter for this interface.
{       However, a NIL value is returned in this parameter.
{
{ MESSAGE_HEADER_LENGTH: (input, output): This is a dummy parameter for this interface.
{       However, a value of 0 is returned in this parameter.
{
{ DATAGRAM: (input)  This parameter specifies the data associated with the event.
{
*DECK DECK=NAH$DELIVER_NETWORK_EVENT EXPAND=FALSE
{
{    The purpose of this procedure is to queue the network data events received
{ over the Network Access channel connection.  The data events are queued on
{ the sap descriptor for the specified sap at the external interface to the
{ network layer.
{
{       NAP$DELIVER_NETWORK_EVENT (SAP, SOURCE_ADDRESS, DEVICE_ID, DATA)
{
{ SAP: (input)  This parameter specifies the identifier of the network sap over
{       which the event was received.
{
{ SOURCE_ADDRESS: (input)  This parameter specifies the NSAP address from which
{       the data was sent.
{
{ DEVICE_ID: (input)  This parameter specifies the identifier of the
{       communications device over which the event was received.
{
{ DATA: (input)  This parameter specifies the data associated with the event.
{
*DECK DECK=NAH$DETACH_SERVER_APPLICATION EXPAND=FALSE
{
{    The purpose of this request is to detach the requesting job from a server
{  application.  This notifies the NAM that the job no longer intends to
{  acquire connections on behalf of the server application being detached.
{
{    This request is used by a server application job to indicate that it is
{  terminating or idling down.  The request has no effect on previously acquired
{  connections; the job may continue providing service over such connections.
{  However, the job may not acquire new connections (unless it reattaches
{  itself to the server).
{
{    Use of this request is optional, the NAM automatically detaches a job from
{  all server applications when the job terminates.  However, if a server
{  application job does not detach itself from a server application but ceases
{  acquiring connections, then client applications may be unable to obtain
{  service.
{
{        NAP$DETACH_SERVER_APPLICATION (SERVER, STATUS)
{
{  SERVER: (input) This parameter specifies the name of the server application
{        on whose behalf the requesting job no longer intends to acquire
{        connections.  The requesting job must have previously attached itself
{        to the specified server application.
{
{        The specified name must be the name of a defined server application --
{        refer to the MANAGE_NETWORK_APPLICATIONS utility.  The caller must be
{        authorized to perform the functions of the specified server
{        application.  The criteria used to validate this privilege is
{        determined by the server_ring, server_system_privilege and
{        server_capability attributes of the specified server application.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              nae$server_not_attached
{              nae$unknown_application
{
*DECK DECK=NAH$END_DIRECTORY_SEARCH EXPAND=FALSE
{
{    The purpose of this request is to terminate a CDNA Directory search.
{
{    This request should be used when the desired title translations have been
{  delivered or, in the case of a non-recurrent directory search, when all
{  translations have been delivered.
{
{    A directory search is implicitly terminated by NOS/VE under the following
{  conditions:
{
{      - For a period of 10 minutes, at least one title translation has been
{        available for delivery, but no nap$get_title_translation request has
{        occurred.
{
{      - A period of 10 minutes has elapsed since a check for title translation
{        availability (nap$get_title_translation or
{        osp$await_activity_completion request) last occurred.
{
{      - When the nae$directory_search_complete condition is returned by the
{        nap$get_title_translation request.
{
{  Once any of these conditions occurs, requests which reference the search
{  return abnormal status with the condition nae$invalid_directory_search_id.
{
{        NAP$END_DIRECTORY_SEARCH (SEARCH_IDENTIFIER, STATUS)
{
{  SEARCH_IDENTIFIER: (input) This parameter specifies the identifier of the
{        directory search which is to be terminated.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS: nae$invalid_directory_search_id
{
*DECK DECK=NAH$FETCH_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to retrieve connection attribute values in
{  use for a connection.  The connection whose attributes are to be retrieved is
{  specified via an instance of open of the network file which identifies the
{  local end point of the connection.
{
{    If a connection access attribute is retrieved, the returned value applies
{  only when the connection is accessed via the specified instance of open of
{  the network file.
{
{        NAP$FETCH_ATTRIBUTES (FILE_IDENTIFIER, ATTRIBUTES, STATUS)
{
{  FILE_IDENTIFIER: (input) This parameter specifies the file access identifier
{        established when the network file was opened.
{
{  ATTRIBUTES: (input-output) This parameter specifies (as input) the attributes
{        whose values are to be retrieved and (as output) the current values of
{        these attributes.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$improper_device_class
{              ame$improper_file_id
{              ame$ring_validation_error
{              nae$connection_terminated
{              nae$data_area_too_small
{              nae$unknown_attribute
{              {other BAM conditions}
{
*DECK DECK=NAH$FIND_TCPIP_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this procedure is to return a pointer to the attributes for
{ the application.  It is assumed that the tcpip_attributes_list has been
{ locked by the caller.
{
{       NAP$FIND_TCPIP_ATTRIBUTES (APPLICATION, TCPIP_ATTRIBUTES)
{
{ APPLICATION: (input)  This parameter specifies the identifier of the
{       application.
{
{ TCPIP_ATTRIBUTES: (output)  This parameter specifies a pointer to the
{       tcpip_attibutes entry.
{
*DECK DECK=NAH$FLUSH_UNIT_QUEUE EXPAND=FALSE
{
{    The purpose of this request is to flush the normal and priority request
{ queues for the specified device and return the message ids associated with
{ the queued requests.  This request is for use by internal NAM/VE routines
{ only.  It is assumed upon entry that no other processes (PP or CPU) are or
{ will be accessing the device request queues while this request is
{ outstanding.
{
{       NAP$FLUSH_UNIT_QUEUE (NETWORK_DEVICE, MESSAGE_ID_ARRAY)
{
{ NETWORK_DEVICE: (input)  This parameter specifies the network device whose
{       request queues are to be flushed.
{
{ MESSAGE_ID_ARRAY: (output)  This parameter specifes the array containing the
{       message ids associated with the queued requests.
{
*DECK DECK=NAH$FREE_PP_BUFFER_DESCRIPTOR EXPAND=FALSE

{
{     The purpose of this request is to free the data structure which support
{  the PPUs use of inbound buffers.  This request is intended solely for use by
{  the NAM/VE initialization process in the case of failure in that process.
{
{       NAP$FREE_PP_BUFFER_DESCRIPTOR
{
*DECK DECK=NAH$FREE_PP_BUFFER_POOLS EXPAND=FALSE

{
{     The purpose of this request is to return PP buffer pools to a null state.
{
{       NAP$FREE_PP_BUFFER_POOLS
{
*DECK DECK=NAH$FREE_PP_SEND_QUEUE_TAILS EXPAND=FALSE
{
{    The purpose of this request is to free the structure containing the
{ pointers to the tails of the PP request queues.
{
{    NAP$FREE_PP_SEND_QUEUE_TAILS
{
*DECK DECK=NAH$FREE_REQUEST_BLOCK EXPAND=FALSE

{
{     The purpose of this request is free the CPU / IOU interface request
{  block.
{
{       NAP$FREE_REQUEST_BLOCK (REQUEST_BLOCK)
{
{  REQUEST_BLOCK: (input, output) This parameter specifies the request
{       block to be freed.  The parameter contains NIL on output.
{
*DECK DECK=NAH$GET_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to retrieve connection attribute values in
{  use for a connection.  The connection whose attributes are to be retrieved is
{  specified via the network file which identifies the local end point of the
{  connection.
{
{    If a connection access attribute is retrieved, the returned value specifies
{  the initial instance of open attribute value to be used for subsequent
{  instances of open of the specified network file.
{
{        NAP$GET_ATTRIBUTES (FILE, ATTRIBUTES, STATUS)
{
{  FILE: (input) This parameter specifies the name of the network file which
{        identifies the local end point of the connection whose attributes are
{        to be retrieved.
{
{  ATTRIBUTES: (input-output) This parameter specifies (as input) the attributes
{        whose values are to be retrieved and (as output) the current values of
{        these attributes.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$file_not_known
{              ame$improper_device_class
{              nae$connection_terminated
{              nae$data_area_too_small
{              nae$switch_offer_pending
{              nae$switch_offer_accepted
{              nae$unknown_attribute
{              {other BAM conditions}
{
*DECK DECK=NAH$GET_CONNECT_TIME_INTERVAL EXPAND=FALSE
{
{    The purpose of this request is to retrieve the interval connect time from
{ a network file.  The interval connect time is either the period since the
{ file was created or the period of time since the last nap$get_connect_time
{ request.  Note for interactive terminal files the connect time excludes the
{ time that the job is detached.
{
{       NAP$GET_CONNECT_TIME_INTERVAL (FILE, CONNECT_TIME, STATUS)
{
{  FILE: (input)  This parameter specifies the name of the network file.
{
{  CONNECT_TIME: (output)  This parameter returns the interval connect time.
{        Connect time is in microseconds.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             ame$file_not_known
{             ame$improper_device_class
{             {other BAM conditions}
{
*DECK DECK=NAH$GET_NAM_ATTRIBUTES_R1 EXPAND=FALSE

{    The purpose of this procedure is to obtain the value of
{    a NAM/VE attribute that resides in ring 1.
{
{          NAP$GET_NAM_ATTRIBUTES_R1 (ATTRIBUTE_KIND,
{                 ATTRIBUTE)
{
{   ATTRIBUTE_KIND: (input) This parameter specifies the NAM/VE
{              attribute which is to be obtained.
{
{   ATTRIBUTE: (output) This parameter specifies the current
{              value of the specified attribute.
{
{    NOTE: Currently the only attribute obtained by this procedure
{          is nac$max_connections_attr. Results of calling this
{          procedure with any other attribute as input are
{          indeterminate.
{
*DECK DECK=NAH$GET_RECEIVED_MESSAGES EXPAND=FALSE

{
{     The purpose of this request is to retrieve received messages from either
{  the execution control block received message list or the system input task
{  received message list.  The XCB list is the normal residence for received
{  messages destined for any task other than the system input task. Messages
{  destined for the system input task are always queued on the system input
{  received message list.
{
{       NAP$GET_RECEIVED_MESSAGES (XCB_LIST, RECEIVED_MESSAGES)
{
{  XCB_LIST: (input) This parameter specifies whether to retrieve messages
{       from the XCB list or the system input task list.
{
{  RECEIVED_MESSAGES: (output) This parameter specified the received messages.
{
*DECK DECK=NAH$GET_REQUEST_BLOCK EXPAND=FALSE

{
{     The purpose of this request is to obtain a CPU / IOU interface request
{  block.
{
{       NAP$GET_REQUEST_BLOCK (RMA_LIST_LENGTH, REQUEST_BLOCK)
{
{  RMA_LIST_LENGTH: (input) This parameter specifies the required number
{       of real memory address entries.
{
{  REQUEST_BLOCK: (output) This parameter specifies the obtained request
{       block.
{
*DECK DECK=NAH$GET_TCPIP_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this procedure is to return the attributes of a given
{ application .
{
{       NAP$GET_TCPIP_ATTRIBUTES (APPLICATION, TCPIP_STATUS, MAXIMUM_SOCKETS,
{             TCPIP_CAPABILITY, TCPIP_RING, TCPIP_SYSTEM_PRIVILEGE, PROTOCOL,
{             STATUS)
{
{ APPLICATION: (input)  This parameter specifies the name of the application
{       whose attributes are to be returned.
{
{ TCPIP_STATUS: (output)  This parameter specifies the status of the named
{       application.
{
{ MAXIMUM_SOCKETS: (output)  This parameter specifies the maximum number of
{       sockets allowed for this application.
{
{ TCPIP_CAPABILITY: (output)  This parameter specifies the capability attribute
{       of the application.
{
{ TCPIP_RING: (output)  This parameter specifies the ring attribute of the
{       application.
{
{ TCPIP_SYSTEM_PRIVILEGE: (output)  This parameter specifies the system
{       privilege attribute of the application.
{
{ PROTOCOL: (output)  This parameter specifies the protocol attribute of the
{       application.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$unknown_application
{
*DECK DECK=NAH$GET_TCPIP_STATUS EXPAND=FALSE
{
{    The purpose of this procedure is to return the status of a given
{ application .
{
{       NAP$GET_TCPIP_STATUS (APPLICATION, TCPIP_STATUS, ACTIVE_SOCKET_COUNT,
{             SOCKET_REJECT_COUNT, STATUS)
{
{ APPLICATION: (input)  This parameter specifies the name of the application
{       whose status is to be returned.
{
{ TCPIP_STATUS: (output)  This parameter specifies the status of the named
{       application.
{
{ ACTIVE_SOCKET_COUNT: (output)  This parameter specifies the number of active
{       sockets for this application.
{
{ SOCKET_ATTEMPT_COUNT: (output)  This parameter specifies the number of assign
{       socket requests that have been attempted since NAM/VE was last
{       activated.
{
{ SOCKET_REJECT_COUNT: (output)  This parameter specifies the number of socket
{       request for this application that have been rejected since NAM/VE was
{       last activated.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$network_inactive
{             nae$unknown_application
{
*DECK DECK=NAH$GET_TITLE_TRANSLATION EXPAND=FALSE
{
{    The purpose of this request is to deliver a title translation.  A title
{  translation consists of the network address registered in the CDNA Directory
{  with the title and, optionally, certain other attributes of the server
{  application which registered the title.
{
{    Title translations are made available for delivery by a directory search
{  activity, which is initiated via the nap$begin_directory_search request.
{  The osp$await_activity_completion request may be used to wait for a title
{  translation to be available for delivery.
{
{    If no title translation is available for delivery when this request is
{  made, the request waits a specified interval of time for a translation to
{  become available (and completes as soon as a translation is available).  If
{  no translation becomes available within this interval, an abnormal status is
{  returned.
{
{    A non-recurrent directory search completes once an initial scan of the
{  CDNA Directory has been performed.  Once all title translations have been
{  delivered for a completed directory search, the nap$get_title_translation
{  request returns abnormal status with the condition
{  nae$directory_search_complete.
{
{        NAP$GET_TITLE_TRANSLATION (SEARCH_IDENTIFIER, WAIT_TIME, ATTRIBUTES,
{          NETWORK_ADDRESS, STATUS)
{
{  SEARCH_IDENTIFIER: (input) This parameter specifies the identifier of the
{        directory search for which a title translation is to be delivered.
{
{  WAIT_TIME: (input) This parameter specifies the number of milliseconds that
{        the request is to wait for a title translation to become available for
{        delivery.
{
{        Since a non-recurrent request has a finite duration and this request
{        completes immediately once the search is complete, it is appropriate
{        to wait indefinitely for a non-recurrent search.  However, the
{        duration of a recurrent search is limited only by the actions of the
{        initiating task.  Thus this request should not wait indefinitely for a
{        recurrent search.
{
{  ATTRIBUTES: (input-output) This parameter specifies the attributes of the
{        translated title which are to be delivered.  A NIL pointer may be
{        specified to indicate that no attributes are to be delivered.
{
{        The following attributes may be returned:
{
{          nac$translation_title: Specifies the title which has been
{            translated.
{
{          nac$translation_priority: Specifies the priority registered in the
{            CDNA Directory with the translated title.  This attribute
{            specifies the priority of the server that registered the title
{            relative to other servers that register the same title.
{
{          nac$translation_data: Specifies the application-specific data
{            registered in the CDNA Directory with the translated title.  The
{            syntax and semantics of this data are determined by the server
{            application.
{
{          nac$translation_protocol: Specifies the protocol registered in the
{            CDNA Directory with the translated title.  This attribute specifies
{            the type of connection that the server application accepts.
{
{  NETWORK_ADDRESS: (output) This parameter specifies the network address
{        registered in the CDNA Directory for the title translation being
{        delivered.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS: nae$directory_search_complete
{              nae$invalid_directory_search_id
{              nae$invalid_selector
{              nae$no_translation_available
{              nae$variable_too_small
{
*DECK DECK=NAH$GT_ACCEPT_CONNECTION EXPAND=FALSE

{
{   The purpose of this request is to accept a proposal to open a connection.
{ This request will cause delivery of an "accept" event to the user who
{ proposed the connection.  Upon completion of this request the connection is
{ open and may be used to communicate with the user who proposed the
{ connection.
{
{       NAP$GT_ACCEPT_CONNECTION (CONNECTION_ID, DATA, OPTIONS, STATUS)
{
{ CONNECTION_ID: (input) This parameter specifies the proposed connection which
{       is to be accepted.
{
{ DATA: (input) This parameter specifies data to be included as part of the
{       "accept" event.  The meaning of this data must be agreed upon by the
{       communicating users.  The length of this data may not exceed 32 bytes.
{       The system buffers containing this data will be released as a result
{       of this request.
{
{ OPTIONS: (input) This parameter specifies options to be included as part of
{       the "accept" event.  This parameter only has meaning over the osi
{       stack. This parameter will be ignored if the stack is non osi (xns).
{       The options are checksum and expedited_data.  If checksum is
{       selected transport will checksum data.  IF expedited_data is selected
{       expedited requests will be accepted.  The default value for checksum
{       and expedited_data is FALSE.  Note the expedited_data option will be
{       ignored unless expedited_data was set on the connect_indication.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$connection_not_proposed
{             nae$max_data_length_exceeded
{
*DECK DECK=NAH$GT_ADD_JOB_SAP EXPAND=FALSE

{
{     The purpose of this request is to add a job local Serivce Access Point
{  to the list of SAPs open in the job.
{
{       NAP$GT_ADD_JOB_SAP (SAP)
{
{  SAP: (input) This parameter specifies the Service Access Point to be added
{       to list of open SAPs.
{
*DECK DECK=NAH$GT_AWAIT_ACTIVITY_COMPLETE EXPAND=FALSE

{
{    The purpose of this request is suspend execution of the requesting
{  task until the completion of one of the specified activities.
{
{      NAE$GT_AWAIT_ACTIVITY_COMPLETE (WAIT_LIST, READY_INDEX, STATUS)
{
{  WAIT_LIST: (input) This parameter specifies the activities that the
{        task is awaiting completion.  The activity, nac$gt_null_activity,
{        can be used as a filler to manage the list of activities.
{
{  READY_INDEX: (output) This parameter specifies the activity in the
{      WAIT_LIST which caused the task to resume execution.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: nae$incorrect_activity.
{       IDENTIFIER: 'NA'.
{
*DECK DECK=NAH$GT_CLEAR_EXCLUSIVE_TO_CLIST EXPAND=FALSE

{
{     The purpose of this request is to clear exclusive access from the job's
{  connection list.  This request is intended for use solely by condition
{  handlers where it may not known if a previously acquired exclusive access
{  has been released.
{
{       NAP$GT_CLEAR_EXCLUSIVE_TO_CLIST
{
*DECK DECK=NAH$GT_CLEAR_EXCLUSIVE_TO_SLIST EXPAND=FALSE

{
{     The purpose of this request is to clear exclusive access from the job's
{  Service Access Point (SAP) list.  This request is intended for use solely by
{  condition handlers where it may not known if a previously acquired exclusive
{  access has been released.
{
{       NAP$GT_CLEAR_EXCLUSIVE_TO_SLIST
{
*DECK DECK=NAH$GT_CLOSE_JOB_CONNECTIONS EXPAND=FALSE

{
{     The purpose of this request is to set each connection in the job's
{  connection list to 'inactive' with a termination state of connection
{  failed.  The connection is no longer viable for application peer
{  communication.  Abnormal status indicating that the connection failed
{  will be returned for the next request on the connection by an application.
{
{     The request is intended solely for use in response to a job recovery
{  condition.
{
{       NAP$GT_CLOSE_JOB_CONNECTIONS
{
*DECK DECK=NAH$GT_CLOSE_SAP EXPAND=FALSE
{
{   The purpose of this request is to terminate access to a previously opened
{ service access point.  Any connections open over the specified service
{ access point will be terminated.  No indication of such a termination is
{ given to the user at the other end of the connection.
{
{       NAP$GT_CLOSE_SAP (SAP, STATUS)
{
{ SAP: (input) This parameter specifies an open service access point to be
{       closed.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$sap_not_open
{       IDENTIFIER: 'NA'
{
*DECK DECK=NAH$GT_CREATE_JOB_CONNECTION EXPAND=FALSE

{
{     The purpose of this request is to create a job local connection, assign
{  a connection identifier and add the connection to the job connection list.
{
{       NAP$GT_CREATE_JOB_CONNECTION (SAP_ID, XNS_CONNECTION_ID,
{           JOB_CONNECTION)
{
{  SAP_ID: (input) This parameter specifies the Service Access Point identifier
{       to be assoicated with the job local connection.
{
{  XNS_CONNECTION_ID: (input) This parameter specifies the connection layer
{       identifier to be associated with the job local connection.
{
{  JOB_CONNECTION: (output) This parameter specifies the created job local
{       connection.
{
*DECK DECK=NAH$GT_DEACTIVATE_JOB_CONNECT EXPAND=FALSE

{
{     The purpose of this request is to deactivate a job local connection.
{  The job local connection is set inactive and the event which caused the
{  connection to be terminated is retained in the job local connection.
{
{       NAP$GT_DEACTIVATE_JOB_CONNECT (TERMINATION_STATE, TERMINATION_EVENT,
{            DATA_LENGTH, JOB_CONNECTION)
{
{  TERMINATION_STATE: (input) This parameter specifies the connection state
{       which caused by the termination event.
{
{  TERMINATION_EVENT: (input) This parameter specifies the event which caused
{       the connection to terminate.
{
{  DATA_LENGTH: (input) This parameter specifies the length of the data in the
{       event if any data is present.
{
{  JOB_CONNECTION: (input) This parameter specifies the job local connection.
{
*DECK DECK=NAH$GT_DELETE_JOB_CONNECTION EXPAND=FALSE

{
{     The purpose of this request is to delete a job local connection from
{  the list of job local connections and FREE the associated space.
{
{     ENTRY REQUIREMENT: the requestor must have exclusive access to the
{                        to the job connection list.
{
{       NAP$GT_DELETE_JOB_CONNECTION (CONNECTION_ID)
{
{  CONNECTION_ID: (input) This parameter specifies the connection to be
{       deleted.
{
*DECK DECK=NAH$GT_DELETE_JOB_SAP EXPAND=FALSE

{
{     The purpose of this request is to delete a job local Serivce Access Point
{  from the list of SAPs open in the job.
{
{     ENTRY REQUIREMENT: the requestor must have exclusive access to the
{                        to the job SAP list.
{
{       NAP$GT_DELETE_JOB_SAP (SAP_ID)
{
{  SAP_ID: (input) This parameter specifies the Service Access Point to be
{       deleted from list of open SAPs.
{
*DECK DECK=NAH$GT_DELETE_JOB_SAPS EXPAND=FALSE

{
{     The purpose of this request is to delete each open Service Access Point
{  from the job's SAP list.  The application can no longer receive connect
{  requests.
{
{     The request is intended solely for use in response to a job recovery
{  condition.
{
{       NAP$GT_DELETE_JOB_SAPS
{
*DECK DECK=NAH$GT_DELIVER_CONNECT_HANDLER EXPAND=FALSE

{
{     The purpose of this signal handler is to deliver connect events (i.e.,
{  an indication of a peer's desire to establish a connection) to an
{  application.
{
{       NAP$GT_DELIVER_CONNECT_HANDLER (ORIGINATOR, SIGNAL)
{
{  ORIGNATOR: (input) The originator task is not meaningful to the process.
{
{  SIGNAL: (input) The signal contains the Service Access Point identifier of
{       the SAP from which an event is to be delivered.
{
{       NOTE: The SAP may no longer be open in which case the process is null.
{
*DECK DECK=NAH$GT_DELIVER_EVENT_HANDLER EXPAND=FALSE

{
{     The purpose of this signal handler is to deliver connection events to
{  an application.
{
{       NAP$GT_DELIVER_EVENT_HANDLER (ORIGINATOR, SIGNAL)
{
{  ORIGNATOR: (input) The originator task is not meaningful to the process.
{
{  SIGNAL: (input) The signal contains the connection identifier of the
{       connection from which an event is to be delivered.
{
{       NOTE: The connection may no longer be open in which case the
{             process is null.
{
*DECK DECK=NAH$GT_DISCONNECT EXPAND=FALSE
{
{   The purpose of this request is to disconnect an open connection.  Data
{ which has been sent on the connection but has not been delivered may be lost
{ as a result of this request.  This request will result in the delivery of a
{ "disconnect" event to the user at the other end of the connection.
{
{   For an orderly termination of a connection, the communicating users should
{ agree (thru normal communication) that no further communication is necessary
{ before either user makes this request.
{
{       NAP$GT_DISCONNECT (CONNECTION, DATA, STATUS)
{
{ CONNECTION: (input) This parameter specifies the connection to be
{       disconnected.
{
{ DATA: (input) This parameter specifies data to be included as part of the
{       "disconnect" event.  It may be used to communicate the reason for the
{       disconnect.  The length of this data may not exceed 64 bytes.  The
{       system buffers containing this data will be released as a result of
{       this request.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$connection_not_open
{       IDENTIFIER: 'NA'
{
*DECK DECK=NAH$GT_GET_CONNECTION_ACTIVITY EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
{! statistics begin}
?? POP ??
{
{   The purpose of this request is to obtain the low level XEROX statistics
{ accumulated in a connection.
{
{
{   **** THIS IS NOT A RELEASE PRODUCT ****
{
{       NAH$GT_GET_CONNECTION_ACTIVITY (CONNECTION, STATISTICS, STATUS)
{
{ CONNECTION: (input) This parameter specifies the connection whose status is
{       to be obtained.
{
{ STATISTICS: (output) This parameter specifies current accumulated statistics.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$connection_not_open
{       IDENTIFIER: 'NA'
{
?? PUSH (LISTEXT := ON) ??
{! statistics end}
?? POP ??
*DECK DECK=NAH$GT_GET_CONNECTION_STATUS EXPAND=FALSE
{
{   The purpose of this request is to obtain the current status of an open
{ connection.
{
{       NAP$GT_GET_CONNECTION_STATUS (CONNECTION, CONNECTION_STATUS, STATUS)
{
{ CONNECTION: (input) This parameter specifies the connection whose status is
{       to be obtained.
{
{ CONNECTION_STATUS: (output) This parameter specifies the current status of
{       the connection.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$connection_not_open
{       IDENTIFIER: 'NA'
{
*DECK DECK=NAH$GT_GET_EXCLUSIVE_TO_CLIST EXPAND=FALSE

{
{     The purpose of this request is to get exclusive access to the job's
{  connection list.
{
{       NAP$GT_GET_EXCLUSIVE_TO_CLIST
{
*DECK DECK=NAH$GT_GET_EXCLUSIVE_TO_SLIST EXPAND=FALSE

{
{     The purpose of this request is to get exclusive access to the job's
{  Service Access Point (SAP) list.
{
{       NAP$GT_GET_EXCLUSIVE_TO_SLIST
{
*DECK DECK=NAH$GT_INITIALIZE EXPAND=FALSE
{
{    The purpose of this procedure is to initialize the template for the
{ Generic Transport External Interface connection.  This procedure should be
{ called only once during NAM/VE initialization.
{
{    NAP$GT_INITIALIZE
{
*DECK DECK=NAH$GT_OPEN_SAP EXPAND=FALSE

{
{   The purpose of this request is to establish access to a service access
{ point.  Requests to open connections may be sent and received over the
{ opened service access point.
{   If a reserved service access point is to be opened, then the particular
{ service access point is specified.  Otherwise, a service access point
{ is arbitrarily selected from a pool of allocatable service access points.
{
{       NAP$GT_OPEN_SAP (MAXIMUM_ACTIVE_CONNECTIONS, SAP_PRIORITY, RESERVED_SAP,
{         SAP, ADDRESS, STATUS)
{
{ MAXIMUM_ACTIVE_CONNECTIONS: (input) This parameter specifies the maximum
{       number of connections that can be established on the service access
{       point.  Attempts to establish a connection which would cause this
{       value to be exceeded are rejected.
{
{ SAP_PRIORITY: (input) This parameter specifies the priority to be associated
{       with the service access point which is opened as a result of this request.
{
{ RESERVED_SAP: (input) This parameter specifies whether the service access
{       point to be opened is a reserved service access point or an
{       allocatable service access point.  If a reserved service access point
{       is to be opened, then the SAP parameter specifies the service access
{       point to be opened.  Otherwise the input value of that parameter has
{       no meaning.
{
{ SAP: (input, output) This parameter specifies the service access point which
{       is opened as a result of this request.
{
{ ADDRESS: (output) This parameter specifies the network, system, and internet
{       identifiers associated with the service access point.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$network_inactive, nae$allocation_failed,
{                   nae$sap_already_open, nae$invalid_reserved_sap,
{                   nae$max_active_connections_0, nae$max_active_conn_exceeded
{       IDENTIFIER: 'NA'
{
*DECK DECK=NAH$GT_OPEN_SHARED_SAP EXPAND=FALSE
{
{    The purpose of this request is to establish a transport service access
{ point with the specified T-selector value.  Requests to open connections may
{ be sent or received over the opened service access point.  Note, all received
{ open connection requests can be processed only by the 'SERVER JOB'.  All open
{ connection requests received while the server job is not active will be
{ rejected.  A T-selector is a component of a network address.  Multiple
{ instances of an application may share the T-selector value.  There is not a
{ one-to-one correspondence between a service access point and a T-selector
{ value.
{
{       NAP$GT_OPEN_SHARED_SAP (MAXIMUM_ACTIVE_CONNECTIONS, SAP_PRIORITY,
{             SELECTOR, SERVER_JOB, SAP, STATUS);
{
{ MAXIMUM_ACTIVE_CONNECTIONS: (input)  This parameter specifies the maximum
{       number of connections that can be established on the service access
{       point.  Attempts to establish a connection which would cause this value
{       to be exceeded are rejected.
{
{ SAP_PRIORITY: (input)  This parameter specifies the priority to be associated
{       with the service access point which is opened as a result of this
{       request.
{
{ SELECTOR: (input)  This parameter specifies the T-selector to be associated
{       with the service access point.
{
{ SERVER_JOB: (input)  This parameter specifies whether the service access
{       point to be opened as a result of this request will be the server.  The
{       server SAP is the only SAP that will receive connect indications.
{
{ SAP: (output)  This parameter specifies the service access point which is
{       opened as a result of this request.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             nae$insufficient_resources
{             nae$invalid_reserved_sap
{             nae$max_active_conn_exceeded
{             nae$max_active_connections_0
{             nae$maximum_saps_open
{             nae$network_inactive
{             nae$sap_already_open
{             nae$sap_cannot_be_shared
{             nae$shared_server_sap_open
{
*DECK DECK=NAH$GT_RECEIVE_CONNECTION_EVENT EXPAND=FALSE

{
{   The purpose of this request is to accept delivery of a connection event.
{ The event to be delivered will be taken from the queue of events which have
{ arrived on the transport connection. The order in which events (with the
{ exclusion of 'expedited events) on a specific connection are delivered will
{ be the same as the order in which they were sent.
{
{       NAP$GT_RECEIVE_CONNECTION_EVENT (CONNECTION_ID, DATA_AREA, WAIT,
{         CONNECTION_EVENT, ACTIVITY_STATUS, STATUS);
{
{ CONNECTION_ID: (input) This parameter specifies the connection on which
{       delivery is to occur.  Only an event sent on this connection will be
{       delivered.
{
{ DATA_AREA: (input) This parameter specifies a data area to receive the data
{       contained in the event.  The data area must contain at least 64 bytes.
{
{ WAIT: (input) This parameter specifies the action to be taken while waiting
{       for the receive connection event operation to complete.  The permitted
{       values are:
{         osc$wait: The calling task is suspended until the receive connection
{           event operation is complete.
{
{         osc$nowait: The calling task executes concurrently with the receive
{           connection event operation.  The nap$gt_await_activity_complete may
{           be used to wait for the operation to complete.
{
{           The lifetimes of the variables specified by DATA_AREA and
{           ACTIVITY_STATUS parameters must exceed the duration of the interval
{           until the operation completes.
{
{ CONNECTION_ EVENT: (output) This parameter specifies the kind of event
{       received and the length of the data.
{
{ ACTIVITY_STATUS: (output) This parameter specifies the status of the receive
{       connection event operation.  The specified variable has the following
{       fields:
{
{         complete: A boolean value which specifies whether the operation is
{           complete.
{
{         status: A status value which specifies the completion status of the
{           operation.  The value is meaningless unless the operation is
{           complete.
{           CONDITIONS: nae$connection_failed.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$connection_not_open, nae$data_area_too_small,
{                   nae$receive_outstanding.
{       IDENTIFIER: 'NA'
{
*DECK DECK=NAH$GT_RECEIVE_CONNECT_EVENT EXPAND=FALSE

{
{   The purpose of this request is to accept delivery of a connect event (i.e.,
{ the indication of a peer's desire to establish a connection).  The event
{ delivered has been taken from the queue of connect events which have arrived
{ at the transport sap.
{
{       NAP$GT_RECEIVE_CONNECT_EVENT (SAP_ID, DATA_AREA, WAIT, CONNECT_EVENT,
{         ACTIVITY_STATUS, STATUS)
{
{ SAP_ID: (input) This parameter specifies an open service access point over
{       which delivery is to occur.  Only an event sent to this service
{       access point will be delivered.
{
{ DATA_AREA: (input) This parameter specifies a data area to receive the data
{       contained in the event.  The data area must contain at least 32 bytes.
{
{ WAIT: (input) This parameter specifies the action to be taken while waiting
{       for the receive connect event operation to complete.  The permitted
{       values are:
{         osc$wait: The calling task is suspended until the receive connect
{           event operation is complete.
{
{         osc$nowait: The calling task executes concurrently with the receive
{           connect event operation.  The  nap$gt_await_activity_complete may
{           be used to wait for the operation to complete.
{
{           The lifetimes of the variables specified by DATA_AREA and
{           ACTIVITY_STATUS parameters must exceed the duration of the interval
{           until the operation completes.
{
{ CONNECT_EVENT: (output) This parameter specifies the connect event received.
{
{ ACTIVITY_STATUS: (output) This parameter specifies the status of the receive
{       connect event operation.  The specified variable has the following
{       fields:
{
{         complete: A boolean value which specifies whether the operation is
{           complete.
{
{         status: A status value which specifies the completion status of the
{           operation.  The value is meaningless unless the operation is
{           complete.
{           CONDITIONS: nae$sap_failed.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$sap_not_open, nae$data_area_too_small,
{                   nae$receive_outstanding.
{       IDENTIFIER: 'NA'
{
*DECK DECK=NAH$GT_REJECT_CONNECTION EXPAND=FALSE
{
{   The purpose of this request is to reject a proposal to open a connection.
{ This request will cause delivery of a "reject" event to the user who
{ proposed the connection.
{
{       NAP$GT_REJECT_CONNECTION (CONNECTION, DATA, STATUS)
{
{ CONNECTION: (input) This parameter specifies the proposed connection which
{       is to be rejected.
{
{ DATA: (input) This parameter specifies data to be included as part of the
{       "reject" event.  It may be used to communicate the reason the
{       connection is being rejected.  The length of this data may not exceed
{       64 bytes.  The system buffers containing this data will be released as
{       a result of this request.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$connection_not_proposed, nae$max_data_length_exceeded
{       IDENTIFIER: 'NA'
{
*DECK DECK=NAH$GT_RELEAS_EXCLUSIV_TO_CLIST EXPAND=FALSE


{
{     The purpose of this request is to release exclusive access from the job's
{  connection list.
{
{       NAP$GT_RELEAS_EXCLUSIV_TO_CLIST
{
*DECK DECK=NAH$GT_RELEAS_EXCLUSIV_TO_SLIST EXPAND=FALSE

{
{     The purpose of this request is to release exclusive access from the job's
{  Service Access Point (SAP) list.
{
{       NAP$GT_RELEAS_EXCLUSIV_TO_SLIST
{
*DECK DECK=NAH$GT_REQUEST_CONNECTION EXPAND=FALSE

{
{   The purpose of this request is to propose that a connection to a specified
{ address be opened.  This request will cause delivery of a "connect" event at
{ the destination address.  The user at that address may accept the proposed
{ connection by calling NAP$GT_ACCEPT_CONNECTION.  This will result in an
{ "accept" event being returned on this connection.
{ Delivery of this event signals that the connection is open and may
{ be used to communicate with the user at the destination address.
{
{   Alternatively, the user at the destination address may reject the proposed
{ connection by calling NAP$GT_REJECT_CONNECTION.  This will result in a
{ "reject" event being returned on this connection.
{
{       NAP$GT_REQUEST_CONNECTION (SAP, DESTINATION, DATA, OPTIONS,
{         CONNECTION_ID, STATUS)
{
{ SAP: (input) This parameter specifies an open service access point over
{       which the connection is to be opened.
{
{ DESTINATION: (input) This parameter specifies the address to which the
{       connection is to be made.
{
{ DATA: (input) This parameter specifies data to be delivered at the
{       destination address as part of the "connect" event.  The meaning of
{       this data must be agreed upon by the communicating users.  The length
{       of this data may not exceed 32 bytes.  The system buffers containing
{       this data will be released as a result of this request.
{
{ OPTIONS: (input) This parameter specifies options to be included as part of
{       the "connect" event.  This parameter only has meaning over the osi
{       stack. This parameter will be ignored if the stack is non osi (xns).
{       The options are checksum and expedited_data.  If checksum is
{       selected transport will checksum data.  IF expedited_data is selected
{       expedited requests will be accepted.  The default value for checksum
{       and expedited_data is FALSE.
{
{ CONNECTION_ID: (output) This parameter specifies the system assigned
{       identifier to be used on subsequent requests to the generic transport
{       service.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$destination_unreachable
{             nae$invalid_selector
{             nae$max_data_length_exceeded
{             nae$max_active_connections
{             nae$maximum_data_fragments
{             nae$sap_not_open
{             nae$unsupported_address
{
*DECK DECK=NAH$GT_SEND_DATA EXPAND=FALSE
{
{   The purpose of this request is to send data over an open connection.  This
{ request will cause delivery of a "data" event to the user at to other end of
{ the connection.
{
{   No attempt is made to "block" outbound data to maximize transmitted packet
{ size.  Each request will (subject to flow control) initiate output on the
{ underlying network.
{
{       NAP$GT_SEND_DATA (CONNECTION, DATA, END_OF_MESSAGE, WAIT,
{         ACTIVITY_STATUS, STATUS)
{
{ CONNECTION: (input) This parameter specifies the connection on which data is
{       to be sent.
{
{ DATA: (input) This parameter specifies data to be included as part of the
{       "data" event.
{
{ END_OF_MESSAGE: (input) This parameter specifies whether the data specified
{       by the DATA parameter is the last data before a message boundary.  The
{       meaning of message boundaries must be agreed upon by the communicating
{       users.
{
{ WAIT: (input) This parameter specifies the action to be taken while waiting
{       for the send data operation to complete.  The permitted values are:
{         osc$wait: The calling task is suspended until the send data
{           operation is complete.
{
{         osc$nowait: The calling task executes concurrently with the send
{           data operation.  The nap$gt_await_activity_complete may be used
{           to wait for the operation to complete.
{
{           The lifetimes of the variables specified by the DATA and
{           ACTIVITY_STATUS parameters must exceed the duration of the interval
{           until the operation completes.
{
{ ACTIVITY_STATUS: (output) This parameter specifies the status of the send
{       data operation.  The specified variable has the following fields:
{
{         complete: A boolean value which specifies whether the operation is
{           complete.
{
{         status: A status value which specifies the completion status of the
{           operation.  The value is meaningless unless the operation is
{           complete.
{           CONDITIONS: nae$connection_failed, nae$conn_termnated_by_peer.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$connection_not_open, nae$conn_terminated_by_peer,
{                   nae$connection_failed.
{       IDENTIFIER: 'NA'
{
*DECK DECK=NAH$GT_SEND_DATA_HANDLER EXPAND=FALSE

{
{     The purpose of this signal handler is to send application data that
{  was previously queued by the send data request.
{
{       NAP$GT_SEND_DATA_HANDLER (ORIGINATOR, SIGNAL)
{
{  ORIGNATOR: (input) The originator task is not meaningful to the process.
{
{  SIGNAL: (input) The signal contains the connection identifier of the
{       connection from which application data is to be sent.
{
{       NOTE: The connection may no longer be open in which case the
{             process is null.
{
*DECK DECK=NAH$GT_SEND_EXPEDITED_DATA EXPAND=FALSE
{
{   The purpose of this request is to send expedited data over an open
{ connection.  This request will cause delivery of a "expedited data" event to
{ the user at the other end of the connection.  Expedited data is not subject
{ to flow control and may be delivered at the other end of the connection
{ ahead of normal data which was sent earlier.
{
{       NAP$GT_SEND_EXPEDITED_DATA (CONNECTION, DATA, STATUS)
{
{ CONNECTION: (input) This parameter specifies the connection on which the
{       expedited data is to be sent.
{
{ DATA: (input) This parameter specifies data to be included as part of the
{       "expedited data" event.  The length of this data may not exceed 16
{       bytes.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$connection_not_open, nae$max_data_length_exceeded
{       IDENTIFIER: 'NA'
{
*DECK DECK=NAH$IDLE_PP EXPAND=FALSE

{
{     The purpose of this procedure is to setup the idle command word and to
{  call the ring 1 procedure to issue the idle request to the specified PP.
{
{       NAP$IDLE_PP (PP_ORDINAL)
{
{  PP_ORDINAL: (input) This parameter specifies the PP to be idled.
{
*DECK DECK=NAH$INCOMING_MESSAGE_CLEANUP EXPAND=FALSE
{
{     The purpose of this request is to cause any received messages that may
{  may be queued on the terminating task's execution control block to be
{  requeued for the network input task to process.
{
{       NAP$INCOMING_MESSAGE_CLEANUP
{
*DECK DECK=NAH$INITIALIZE_PP_BUFFER_DESCR EXPAND=FALSE

{
{     The purpose of this request is to initialize the data structure which
{  supports the PPUs use of inbound buffers.  This request is intended solely
{  for use by the NAM/VE initialization process.
{
{       NAP$INITIALIZE_PP_BUFFER_DESCR
{
*DECK DECK=NAH$INITIALIZE_REQUEST_BLOCKS EXPAND=FALSE

{
{     The purpose of this request is to initialize the preallocated CPU / IOU
{  interface request blocks.
{
{       NAP$INITIALIZE_REQUEST_BLOCKS
{
*DECK DECK=NAH$INIT_PP_SEND_QUEUE_TAILS EXPAND=FALSE
{
{    The purpose of this request is to allocate the structure which contains
{ the pointers to the tails of the PP request queues.
{
{    NAP$INIT_PP_SEND_QUEUE_TAILS
{
*DECK DECK=NAH$ISSUE_PP_REQUEST EXPAND=FALSE
{
{    The purpose of this request is to build and queue a PP request on the PP
{ interface table of the specified PP.  The user will provide the command word
{ as well as any additional request specific data.
{
{       NAP$ISSUE_PP_REQUEST (PP_NUMBER, COMMAND, REQUEST_SPECIFIC_DATA)
{
{
{ PP_NUMBER: (input)  This parameter specifies the PP to which the request is
{       issued.
{
{ COMMAND: (input)  This parameter specifies the PP command to be placed in the
{       PP request.
{
{ REQUEST_SPECIFIC_DATA: (input)  This parameter specifies any additional data
{       to be associated with the request.  This parameter is currently only
{       used when issuing a define_ethernet_address request.
{
*DECK DECK=NAH$NAMVE_SYSTEM_ERROR EXPAND=FALSE
{
{    This routine is to be used by NAM/VE processes in place of
{ OSP$SYSTEM_ERROR and OSP$RECOVERABLE_SYSTEM_ERROR.  Whenever a process would
{ call either of these interfaces it should instead call this routine.  This
{ routine will check the system attribute NAMVE_DEBUG_MODE and perform the
{ proper debugging action prior to calling OSP$SYSTEM_ERROR or
{ OSP$RECOVERABLE_SYSTEM_ERROR.
{
{
{       NAP$NAMVE_SYSTEM_ERROR (RECOVERABLE_ERROR, ERROR_MESSAGE, STATUS)
{
{
{ RECOVERABLE_ERROR: (input)  This parameter specifies whether the error
{       detected by the calling routine is recoverable or not.  A value of
{       FALSE will result in OSP$SYSTEM_ERROR being called, whereas a value of
{       TRUE will result in a call to OSP$RECOVERABLE_SYSTEM_ERROR.
{
{ ERROR_MESSAGE: (input)  This parameter specifies the error message to be
{       logged.
{
{ STATUS: (input)  This parameter specifies the error status.
{
*DECK DECK=NAH$OFFER_CONNECTION_SWITCH EXPAND=FALSE
{
{    The purpose of this request is to offer a switch of ownership of a CDNA
{  connection end point to another job executing on the local system.  Switching
{  ownership of a connection end point is a local system operation -- the peer
{  application at the remote connection end point receives no indication of this
{  action.
{
{    Switching ownership of a connection end point is a cooperative process
{  which requires the active participation of both the source job (current
{  owner) and the destination job (proposed owner).  The source job uses this
{  request to make an offer to switch a connection end point to a destination
{  job.  The destination job must accept this switch offer to complete the
{  connection end point switch.
{
{    The source job determines the duration of the offer to switch a connection
{  end point.  If the destination job does not accept the switch offer within a
{  reasonable amount of time, the source job may cancel the switch offer.
{
{    While the switch offer is in effect, requests which reference the specified
{  network file result in abnormal status -- except for a request to detach
{  (return) the file, which cancels the switch offer and terminates the
{  connection.  Once the destination job accepts the switch offer, the network
{  file may be detached (returned) without affecting the switched connection.
{  This is the only request which may be made for the network file after the
{  switch offer has been accepted.
{
{    If there are active instances of open of the specified network file when
{  this request is made, an abnormal status is returned.
{
{    Switching a connection end point does not affect the count of the number
{  of established connections for the application which established the
{  connection.  That is, jobs which receive ownership of a connection end point
{  are effectively considered part of the application which originally
{  established the connection.
{
{        NAP$OFFER_CONNECTION_SWITCH (FILE, DESTINATION, WAIT_TIME, STATUS)
{
{  FILE: (input) This parameter specifies the name of the network file which
{        identifies the connection end point for which a switch of ownership
{        is to be offered.
{
{  DESTINATION: (input) This parameter specifies the job to which the offer to
{        switch ownership of the specified connection end point is to be made.
{
{  WAIT_TIME: (input) This parameter specifies the number of milliseconds that
{        the request is to wait for the destination job to accept the switch
{        offer.  A value of 0 indicates that the calling task is to continue
{        execution while the switch offer is in effect.
{
{        Failure of the destination job to accept the switch offer within this
{        waiting period has no effect on the switch offer.  The source job must
{        explicitly cancel the switch offer if the destination job has not
{        accepted the offer within a reasonable amount of time.
{
{        The osp$await_activity_complete request may be also used to wait for
{        the switch offer to be accepted.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$file_not_closed
{              ame$file_not_known
{              ame$improper_device_class
{              nae$switch_offer_accepted
{              nae$switch_offer_not_accepted
{              nae$switch_offer_pending
{              {other BAM conditions}
{
*DECK DECK=NAH$OPEN_NETWORK_SAP EXPAND=FALSE
{
{    The purpose of this request is to establish access to the specified
{ service access point.  The specified service access point is opened over the
{ XNS internet layer and the OSI network layer via the Network Access Agent.
{ Datagrams may be sent and received over the opened service access point.
{
{       NAP$OPEN_NETWORK_SAP (SAP_PRIORITY, SAP, STATUS)
{
{ SAP_PRIORITY: (input)  This parameter specifies the priority to be associated
{       with the service access point which is opened as a result of this
{       request.
{
{ SAP: (input)  This parameter specifies the service access point to be opened
{       over the XNS internet layer and the OSI network layer.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$allocation_failed
{             nae$sap_already_open
{       IDENTIFIER: 'NA'
{
*DECK DECK=NAH$PARSE_ACCOUNTING_DATA EXPAND=FALSE
{    The purpose of this request is to parse the peer_accounting_information
{ and peer_connect_data network connection attributes.
{
{       NAP$PARSE_ACCOUNTING_DATA (PEER_ACCOUNTING_INFORMATION,
{             PEER_CONNECT_DATA, ACCOUNTING_DATA_FIELDS, STATUS)
{
{  PEER_ACCOUNTING_INFORMATION: (input)  This parameter specifies a string of
{        connection information that may be from the network connection or the
{        job_input_device job attribute.
{
{  PEER_CONNECT_DATA: (input)  This parameter specifies a string of connection
{        information from the network connection.
{
{  ACCOUNTING_DATA_FIELDS:  (input, output) This parameter specifies (as
{        input) the accounting data values to be retrieved and (as output)
{        their current values.  The kind field which specifies the value to be
{        retrieved will be modified and set to nac$ca_unavailable_information
{        if the information requested is not in the peer_accounting_information
{        or peer_connect_data strings being parsed.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$acct_version_mismatch
{
*DECK DECK=NAH$RECEIVE_NETWORK_DATA EXPAND=FALSE
{
{    The purpose of this request is to accept delivery of a datagram.  The data
{ event to be delivered (if any) will be taken from the queue of data events
{ which have arrived at the local system.  The order in which data events are
{ delivered may not be the same as the order in which they were sent.
{
{       NAP$RECEIVE_NETWORK_DATA (SAP, DATA_AREA, WAIT_TIME, SOURCE, MULTICAST,
{             RECEIVED_DATA_LENGTH, STATUS)
{
{ SAP: (input)  This parameter specifies an open service access point over
{       which delivery is to occur.  Only a data event sent to this service
{       access point will be delivered.
{
{ DATA_AREA: (input, output)  This parameter specifies a data area to receive
{       the data contained in the data event.
{
{ WAIT_TIME: (input)  This parameter specifies the amount of time (in
{       milliseconds) that the caller is willing to wait for a datagram to be
{       delivered.  Control will not be returned to the caller until a datagram
{       is available or the wait duration expires.  If no datagram is available
{       for delivery within this amount of time, an abnormal status will be
{       returned.
{
{ SOURCE: (output)  This parameter specifies the OSI NSAP Address or the XNS
{       Internet address from which the data was sent.
{
{ MULTICAST: (output)  This parameter specifies whether or not the datagram was
{       delivered to the local system via a multicast on the underlying
{       network.  This attribute will be FALSE for events received over the OSI
{       network layer.
{
{ RECEIVED_DATA_LENGTH: (output)  This parameter specifies the length of the
{       data contained in the datagram and delivered to the specified data
{       area.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$no_datagram_available
{             nae$sap_not_open
{       IDENTIFIER: 'NA'
{
*DECK DECK=NAH$RELOAD_NETWORK_PP EXPAND=FALSE
{
{    The purpose of this procedure is to restart a network device driver when
{ the system has determined that the driver is hung. This routine assumes that
{ the driver is stopped. All network connections are terminated, all hardware
{ elements are returned, and the normal load process is reinitiated.
{
{       NAP$RELOAD_NETWORK_PP (ELEMENT, STATUS)
{
{  ELEMENT (input):  This parameters specifies the element name of the
{        network device for which the state change has been requested.
{
{  STATUS (output):  This parameter specifies the request status.
{
*DECK DECK=NAH$REQUEST_CONNECTION EXPAND=FALSE
{
{    The purpose of this request is to initiate the establishment of a CDNA
{  connection to a CDNA server application.  In general, the server may be any
{  application which is active on some CDNA system and provides its services via
{  a CDNA connection.
{
{    Establishing a connection is a cooperative process which requires the
{  active participation of both the client application and the server
{  application.  This request is used by the client to request that a connection
{  to a server be established.
{
{    The server application may either accept or reject the requested
{  connection.  If the server accepts the requested connection, the connection
{  becomes established and may be accessed.  If the server rejects the requested
{  connection, the attempt to establish the connection fails and attempts to
{  access the connection result in an abnormal status indicating that the
{  connection has been terminated by the peer application.
{
{    The specified network file is created at the beginning of the connection
{  establishment activity and may be used during this activity to manage the
{  connection.  In particular, the request to establish the connection may be
{  cancelled by detaching (returning) the network file.  However, attempts to
{  access the connection before establishment is complete result in abnormal
{  status.
{
{    The calling task specifies whether it is to wait for the server to respond
{  to the connection request or execute concurrently with the connection
{  establishment activity.  If the task waits for the server to respond, then
{  the network file is detached (returned) if the server does not respond within
{  the specified wait time.  Furthermore, if the server rejects the connection
{  while the task is waiting, the network file is detached (returned). The
{  request returns abnormal status under either of these conditions.
{
{    If the calling task executes concurrently with the connection establishment
{  activity, the nap$await_server_response (or osp$await_activity_complete)
{  request may be used to determine whether the server has responded to the
{  connection request.  A task which executes concurrently with the connection
{  establishment activity is responsible for detaching (returning) the network
{  file if the server rejects the connection or does not respond to the
{  connection request within a reasonable amount of time.
{
{        NAP$REQUEST_CONNECTION (SERVER, CLIENT, FILE, PROTOCOL, ATTRIBUTES,
{          WAIT_TIME, STATUS)
{
{  SERVER: (input) This parameter specifies the network address of the server
{        application to which a connection is to be established.
{
{  CLIENT: (input) This parameter specifies the name of the client application
{        on whose behalf the connection is requested.
{
{        The specified name must be the name of a defined client application --
{        refer to the MANAGE_NETWORK_APPLICATIONS utility.  The caller must
{        be authorized to perform the functions of the specified client
{        application.  The criteria used to validate this privilege is
{        determined by the client_ring, client_system_privilege and
{        client_capability attributes of the specified client application.
{
{  FILE: (input) This parameter specifies the name of the network file which is
{        to be created to identify the local end point of the requested
{        connection.
{
{        The network file is created in the $LOCAL catalog.
{
{  PROTOCOL: (input) This parameter specifies the protocol to be used to provide
{        the connection to be established.
{
{  ATTRIBUTES: (input) This parameter specifies the connection attribute values
{        which are to be used for the requested connection.  A value of NIL for
{        this parameter indicates that default values are to be used for all
{        attributes.
{
{  WAIT_TIME: (input) This parameter specifies the number of milliseconds that
{        the request is to wait for the server to respond to the connection
{        request.  A value of 0 indicates that the calling task is to execute
{        concurrently with the connection establishment activity.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$file_known
{              nae$address_protocol_mismatch
{              nae$application_inactive
{              nae$application_max_conn_limit
{              nae$client_protocol_mismatch
{              nae$connection_terminated
{              nae$insufficient_resources
{              nae$invalid_eoi_message_size
{              nae$max_data_length_exceeded
{              nae$network_inactive
{              nae$server_response_timeout
{              nae$unknown_address_kind
{              nae$unknown_application
{              nae$unknown_attribute
{              nae$unknown_protocol
{              {other BAM conditions}
{
*DECK DECK=NAH$RESET_NETWORK_RESPONSES EXPAND=FALSE

{
{     The purpose of this request is to return the received message list and
{  completed output request list to a null state.
{
{       NAP$RESET_NETWORK_RESPONSES
{
*DECK DECK=NAH$RESET_RECEIVED_MESSAGE_LIST EXPAND=TRUE

{
{    The purpose of this request is to set the received_message_list in the
{  execution_control_block (xcb) to NIL.  The elements that had been queued
{  on the xcb no longer exist because the network_wired segment is reinitial-
{  ized after each deadstart.
{
{    This request will be called in each task that existed before deadstart
{  and has the possiblity of being recovered.
{
{        NAP$RESET_RECEIVED_MESSAGE_LIST
{
*DECK DECK=NAH$SEND_NETWORK_DATA EXPAND=FALSE
{
{    The purpose of this request is to send a datagram to a specified address.
{ Depending on the kind of destination address, the Network Access Agent or the
{ XNS Internet layer will be used to send the data to the destination, but
{ reliable delivery is not guaranteed.
{
{       NAP$SEND_NETWORK_DATA (SAP, DESTINATION, DATA, STATUS)
{
{ SAP: (input)  This parameter specifies an open service access point from
{       which the datagram is to be sent.
{
{ DESTINATION: (input)  This parameter specifies the OSI NSAP address or the
{       XNS Internet address to which the datagram is to be sent.
{
{ DATA: (input)  This parameter specifies the data to be delivered at the
{       destination.  This data may have a maximum size of 1466 bytes if the
{       destination is an XNS Internet address.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$max_data_length_exceeded
{             nae$sap_not_open
{       IDENTIFIER: 'NA'
{
*DECK DECK=NAH$SE_CLEAR_REQUEST EXPAND=FALSE
{
{   The purpose of this request is to cause the communication path, between the
{ local user and remote user, to be broken.  Data queued on the network will
{ be discarded.  All active I/O requests associated with the network file will
{ be terminated.
{
{        NAP$SE_CLEAR_REQUEST (FILE, STATUS)
{
{  FILE: (input) This parameter specifies the name of the network file which
{        identifies the local end point of the connection which is to be broken.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$file_not_known
{              ame$improper_device_class
{              nae$connection_terminated
{              nae$switch_offer_pending
{              {other BAM conditions}
{
*DECK DECK=NAH$SE_GET_AVAILABLE_BYTE_COUNT EXPAND=FALSE
{
{    The purpose of this request is to determine the number of bytes currently
{ available for the user.
{
{    This request will not be processed if there is a receive data operation in
{ progress for the connection or a task is waiting for data to become available
{ on the connection.  A request to initiate this request under either of these
{ conditions results in abnormal status with the condition
{ nae$receive_outstanding.
{
{    WARNING:  An application must receive data which has been sent by the peer
{          application within a reasonable amount of time.  If available data
{          accumulates in the connection over an extended period of time, the
{          NAM terminates the connection.
{
{       NAP$SE_GET_AVAILABLE_BYTE_COUNT (FILE_IDENTIFIER, BYTE_COUNT, STATUS)
{
{  FILE_IDENTIFIER: (input)  This parameter specifies the file access
{        identifier established when the network file was opened.
{
{  BYTE_COUNT: (output)  This parameter specifies the number of bytes of user
{        data currently available on the connection.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             ame$improper_device_class
{             ame$improper_file_id
{             ame$ring_validation_error
{             nae$connection_terminated
{             nae$improper_protocol
{             nae$receive_outstanding
{             {other BAM conditions}
{
*DECK DECK=NAH$SE_INTERRUPT EXPAND=FALSE
{
{    The purpose of this request is to interrupt an established CDNA Session
{  connection.  A connection interrupt sends a limited amount of priority
{  information to the peer application.
{
{    An interrupt is given priority over data on a connection.  This means that
{  the peer application may receive an interrupt prior to receiving data sent
{  before the interrupt.  (The peer application always receives an interrupt
{  prior to receiving any data sent after the interrupt).
{
{    An interrupt is not subject to connection flow control.  That is, there is
{  no regulation of the number of interrupts which may be held within a
{  connection.  A connection may be interrupted even if the connection is
{  congested such that data may not be transferred to the peer application.
{
{    Since interrupts are not subject to flow control, they should be used
{  judiciously.  If an excessive number of interrupts accumulate in the
{  connection (due to failure of the peer application to receive them), the
{  network may terminate the connection.
{
{        NAP$SE_INTERRUPT (FILE_IDENTIFIER, DATA, STATUS)
{
{  FILE_IDENTIFIER: (input) This parameter specifies the file access identifier
{        established when the network file was opened.
{
{  DATA: (input) This parameter specifies the data to be sent to the peer
{        application.  The length of the data may range from 1 to 14 bytes.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$improper_device_class
{              ame$improper_file_id
{              ame$ring_validation_error
{              nae$connection_terminated
{              nae$improper_protocol
{              nae$se_interrupt_length_error
{              nae$supervisory_traffic_limit
{              {other BAM conditions}
{
*DECK DECK=NAH$SE_RECEIVE_DATA EXPAND=FALSE
{
{    The purpose of this request is to receive data from a peer application
{  over an established CDNA Session connection.  This request is also used to
{  obtain notification of peer operations other than sending data.
{
{    Data transmitted over a connection is structured into messages.  Message
{  boundaries are specified by the sender and communicated to the receiver.
{
{    There are two operations involved in the transfer of data between peer
{  applications.  The sending application performs a send data operation to
{  transfer data into the connection.  The receiving application performs a
{  receive data operation to transfer data out of the connection.
{
{    The network holds a certain amount of data within a connection to smooth
{  out the interaction between a sender and a receiver.  However, the amount of
{  data which may be held within a connection is dependent on availability of
{  resources.  Thus the rate at which an application may send data is
{  ultimately limited by the rate at which the peer application receives data.
{
{    This request initiates a receive data operation, which transfers data into
{  the application's buffer from the connection.  The transfer of data into the
{  buffer is regulated by the availibilty of data from the connection.  Data is
{  accumulated in the application's buffer until the receive data operation
{  completes.
{
{    The receive data operation completes when one of the following conditions
{  occurs:
{
{      - A complete message (or a partial message which completes a message)
{        has been received.
{
{      - The specified buffer is full.
{
{      - The peer application has performed some operation other than sending
{        data.
{
{    Each receive data operation transfers a partial or complete message to the
{  application's buffer.  A partial message may be transferred under the
{  following conditions:
{
{      - The specified buffer is too small to contain the entire message.
{
{      - The peer application performs an interrupt operation or a synchronize
{        operation which does NOT synchronize the transfer of data FROM the
{        peer application.  Note that a partial message may be transferred even
{        if the peer application performs the synchronize operation after
{        sending a complete message.
{
{      - The connection is terminated by the peer application after sending a
{        partial message.
{
{      - The connection is terminated by the network.
{
{  If a partial message is transferred as a result of either of the first two
{  conditions, then the remainder of the message will be transferred by
{  subsequent receive data operations.
{
{    Since the receive data operation transfers data into the application's
{  buffer as it becomes available, arbitrarily large messages may be received
{  over a connection.  There is no need for an application to receive a large
{  message as a series of partial messages, each of which is small enough to be
{  held entirely within a connection at some instant in time, and concatenate
{  the partial messages to form the complete message.
{
{    However, an application may choose to receive partial messages by
{  specifying a buffer size smaller than the size of the message to be received.
{  For instance, receiving partial messages might be desirable in cases where it
{  is inconvenient to receive the entire message in memory at one time.
{
{    NOTE: The partial message boundaries identified when a message is received
{  are determined solely by the interaction between the NAM and the receiving
{  application; they do not indicate partial message boundaries (if any)
{  established by the peer application when the message was sent.
{
{    The calling task specifies whether it is to be suspended until the receive
{  data operation is complete or execute concurrently with the data transfer.
{  If the data transfer is to occur concurrently with task execution, the
{  application's buffer must be left intact until the transfer is complete.
{
{    A receive data operation may not be initiated if there is already a
{  receive data operation in progress for the connection or a task is waiting
{  for data to become available on the connection.  A request to initiate a
{  receive data operation under either of these conditions results in abnormal
{  status with the condition nae$receive_outstanding, if the calling task is to
{  execute concurrently with the data transfer.  However, if the calling task is
{  to be suspended, the request waits for the condition to clear and then
{  initiates the receive data operation.  In this case, the data transfer
{  timeout includes the interval while the request is waiting to initiate the
{  operation.
{
{    If the file is closed while a concurrent receive data operation is
{  outstanding, the operation is cancelled (but the ACTIVITY_STATUS parameter is
{  not updated).  This leaves the connection in an indeterminate state, since
{  the amount of data transferred from the connection is unknown.  The
{  connection should be synchronized before further usage.
{
{    Note that the STATUS parameter indicates the status of the request to
{  initiate the receive data operation, while the ACTIVITY_STATUS parameter
{  indicates the status of the receive data operation itself.  The caller must
{  examine both parameters to determine if the requested operation has been
{  successfully performed.
{
{    WARNING: An application must receive data which has been sent by the peer
{  application within a reasonable amount of time.  If available data
{  accumulates in the connection over an extended period of time, the NAM
{  terminates the connection.
{
{        NAP$SE_RECEIVE_DATA (FILE_IDENTIFIER, BUFFER, WAIT, PEER_OPERATION,
{          ACTIVITY_STATUS, STATUS)
{
{  FILE_IDENTIFIER: (input) This parameter specifies the file access identifier
{        established when the network file was opened.
{
{  BUFFER: (input) This parameter specifies a list of address/length pairs
{        defining the buffer where data is to be delivered.
{
{  WAIT: (input) This parameter specifies the action to be taken while waiting
{        for the receive data operation to complete.  The permitted values and
{        the corresponding actions are:
{
{          osc$wait: The calling task is suspended until the receive data
{            operation is complete.
{
{          osc$nowait: The calling task executes concurrently with the receive
{            data operation.  The osp$await_activity_complete request may be
{            used to wait for the data transfer to complete.
{
{            The lifetimes of the variables specified by the PEER_OPERATION and
{            ACTIVITY_STATUS parameters and the lifetime of the buffer
{            specified by the BUFFER parameter must exceed the duration of the
{            interval until the data transfer completes.
{
{            If another receive data operation is outstanding on the same
{            connection, the request will return abnormal status with the
{            condition nae$receive_outstanding.
{
{  PEER_OPERATION: (output) This parameter specifies the operation performed by
{        the peer application which caused the receive data operation to
{        complete.  The possible values and the corresponding meanings are:
{
{          nac$se_send_data: This value indicates that peer application
{            performed a send data operation and data has been delivered to the
{            application's buffer.
{
{            In this case the parameter value contains the following
{            sub-fields:
{
{              end_of_message: This field specifies whether the received data
{                completes a message.  If TRUE, the received data is either a
{                complete message or a partial message which completes a
{                message, depending on whether the preceding data received over
{                the connection completed a message.  If FALSE, the received
{                data is a partial message and the remainder of the message is
{                to be received by subsequent receive data operations.
{
{              qualified_data: This field specifies whether the received data
{                was marked as "qualified" by the sender.
{
{              data_length: This field specifies the length (in bytes) of the
{                received data.
{
{          nac$se_interrupt: This value indicates that the peer application
{            performed an interrupt operation.
{
{            In this case the parameter value contains the following
{            sub-fields:
{
{              interrupt_data_length: This field specifies the length (in
{                bytes) of the data sent with the interrupt.
{
{              interrupt_data: This field contains the data sent with the
{                interrupt.
{
{          nac$se_synchronize: This value indicates that the peer application
{            performed a synchronize operation.
{
{            In this case the parameter value contains the following
{            sub-fields:
{
{              direction: This field specifies the direction(s) in which the
{                transfer of data has been synchronized.  The possible values
{                and their meanings are:
{
{                  nac$se_synchronize_send_data: The transfer of data to the
{                    peer application has been synchronized.
{
{                  nac$se_synchronize_receive_data: The transfer of data from
{                    the peer application has been synchronized.
{
{                  nac$se_synchronize_all_data: The transfer of data to and from
{                    the peer application has been synchronized.
{
{                If send data has been synchronized, the application must
{                perform a synchronize_confirm operation in order to permit
{                data transfer to continue.  Until the synchronization is
{                confirmed, an attempt to initiate a send data operation
{                results in abnormal status with the condition
{                nae$se_synchronize_in_progress.
{
{                If only receive data has been synchronized, no confirmation is
{                required (or allowed).  Notification of receive data
{                synchronization is solely for informational purposes.
{
{              synchronize_data_length: This field specifies the length (in
{                bytes) of the data sent by the peer application via the
{                synchronize operation.
{
{              synchronize_data: This field contains the data sent by the peer
{                application via the synchronize operation.
{
{          nac$se_synchronize_confirm: This value indicates that the peer
{            application performed a synchronize_confirm operation.
{
{        The value of this parameter is not meaningful until the
{        ACTIVITY_STATUS parameter indicates that the receive data operation is
{        complete.
{
{  ACTIVITY_STATUS: (output) This parameter specifies the status of the receive
{        data operation.  The specified variable has the following fields:
{
{          complete: A boolean value which specifies whether the operation is
{            complete.
{
{          status: A status value which specifies the completion status of the
{            operation.  This value is not meaningful unless the operation is
{            complete.
{            CONDITIONS:
{                  nae$connection_terminated
{                  nae$data_transfer_timeout
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$improper_device_class
{              ame$improper_file_id
{              ame$ring_validation_error
{              nae$connection_terminated
{              nae$data_transfer_timeout
{              nae$improper_protocol
{              nae$receive_outstanding
{              {other BAM conditions}
{
*DECK DECK=NAH$SE_SEND_DATA EXPAND=FALSE
{
{    The purpose of this request is to send data to a peer application over an
{  established CDNA Session connection.
{
{    Data transmitted over a connection is structured into messages.  Message
{  boundaries are specified by the sender and communicated to the receiver.
{
{    There are two operations involved in the transfer of data between peer
{  applications.  The sending application performs a send data operation to
{  transfer data into the connection.  The receiving application performs a
{  receive data operation to transfer data out of the connection.
{
{    The network holds a certain amount of data within a connection to smooth
{  out the interaction between a sender and a receiver.  However, the amount of
{  data which may be held within a connection is dependent on availability of
{  resources.  Thus the rate at which an application may send data is
{  ultimately limited by the rate at which the peer application receives data.
{
{    This request initiates a send data operation, which transfers data from
{  the application's buffer into the connection.  The transfer of data into the
{  connection is regulated by the capacity of the network to accept data.  The
{  send data operation completes when all of the data has been transferred into
{  the connection.
{
{    As data is transferred into the connection, it is fragmented into partial
{  messages if the amount of data to be transferred exceeds the current network
{  capacity.  The minimum size for a partial message generated in this manner is
{  defined by the constant nac$se_min_fragment_size (in units of bytes).  The
{  fact that such fragmentation occurs may be significant if the peer
{  (receiving) application is informed of partial message boundaries established
{  when a message is sent.
{
{    The following applies if the peer application is a CDCNET application:
{  The CDCNET application will have a message size limitation of 8468 bytes.
{  If the block to be sent down is larger, then it must be fragmented into
{  a message size less than 8468 bytes.  Otherwise, CDCNET will end the
{  connection.
{
{    The following applies if the peer application is not a CDCNET application:
{  Since the send data operation fragments and transfers data into a
{  connection as the capacity of the network to accept data allows, arbitrarily
{  large messages may be sent over a connection.  There is no need for an
{  application to fragment a large message into a series of partial messages,
{  each of which is small enough to be held entirely within a connection at some
{  instant in time, and send the partial messages individually.
{
{    However, an application may choose to send partial messages.  For instance,
{  sending partial messages might be desirable in cases where it is inconvenient
{  to compose the entire message in memory at one time.
{
{    NOTE: If the peer application is a NOS/VE network application, then it is
{  NOT informed of partial message boundaries established when a message is
{  sent (i.e. transferred into the connection).  This is true whether the
{  partial message boundaries are established by the application itself or by
{  the send data operation.
{
{    Each send data operation directly results in transmission of one or more
{  network blocks.  Data from partial messages transferred by separate send data
{  operations is not concatenated to optimize network utilization; i.e., to form
{  "full" network blocks.  The optimum_transfer_unit_size and
{  optimum_transfer_unit_incr connection attributes should be examined to
{  determine the amount of data that should be transferred by each send data
{  operation in order to optimize network block usage.
{
{    The calling task specifies whether it is to be suspended until the send
{  data operation is complete or execute concurrently with the data transfer.
{  If the data transfer is to occur concurrently with task execution, the data
{  must be left intact in the application's buffer until the transfer is
{  complete.
{
{    At any given time, only one send data operation may be active for a
{  connection.  A request to initiate a send data operation while one is already
{  in progress results in abnormal status with the condition
{  nae$send_outstanding if the calling task is to execute concurrently with the
{  data transfer.  However, if the calling task is to be suspended, the request
{  waits for the condition to clear and then initiates the send data operation.
{  In this case, the data transfer timeout includes the interval while the
{  request is waiting to initiate the operation.
{
{    If the file is closed while a concurrent send data operation is
{  outstanding, the operation is cancelled (but the ACTIVITY_STATUS parameter is
{  not updated).  This leaves the connection in an indeterminate state, since
{  the amount of data transferred into the connection is unknown.  The
{  connection should be synchronized before further usage.
{
{    Note that the STATUS parameter indicates the status of the request to
{  initiate the send data operation, while the ACTIVITY_STATUS parameter
{  indicates the status of the send data operation itself.  The caller must
{  examine both parameters to determine if the requested operation has been
{  successfully performed.
{
{        NAP$SE_SEND_DATA (FILE_IDENTIFIER, DATA, END_OF_MESSAGE,
{          QUALIFIED_DATA, WAIT, ACTIVITY_STATUS, STATUS)
{
{  FILE_IDENTIFIER: (input) This parameter specifies the file access identifier
{        established when the network file was opened.
{
{  DATA: (input) This parameter specifies a list of address/length pairs
{        defining the data to be sent.
{
{  END_OF_MESSAGE: (input) This parameter specifies whether the data being sent
{        completes a message.  If TRUE, the specified data is either a complete
{        message or a partial message which completes a message, depending on
{        whether the preceding data sent over the connection completed a
{        message.  If FALSE, the specified data is a partial message and the
{        remainder of the message is to be transferred by subsequent send data
{        operations.
{
{  QUALIFIED_DATA: (input) This parameter specifies whether the data being sent
{        is considered to be "qualified" by the sending application.  The
{        meaning of qualified (vs. unqualified) data must be agreed upon by
{        the peer applications.
{
{        The NAM performs no action dependent on this parameter -- other than
{        to verify that the same value is supplied for all data comprising a
{        message.  In general, this parameter may be considered as an another
{        bit of information (in addition to the information specified by the
{        DATA parameter) which is carried transparently over the connection.
{
{  WAIT: (input) This parameter specifies the action to be taken while waiting
{        for the send data operation to complete.  The permitted values and the
{        corresponding actions are:
{
{          osc$wait: The calling task is suspended until the send data
{            operation is complete.
{
{          osc$nowait: The calling task executes concurrently with the send
{            data operation.  The osp$await_activity_complete request may be
{            used to wait for the data transfer to complete.
{
{            The lifetime of the variable specified by the ACTIVITY_STATUS
{            parameter and the lifetime of the data specified by the DATA
{            parameter must exceed the duration of the interval until the send
{            data operation completes.
{
{            If another send data operation is outstanding on the same
{            connection, the request will return abnormal status with the
{            condition nae$send_outstanding.
{
{  ACTIVITY_STATUS: (output) This parameter specifies the status of the send
{        data operation.  The specified variable has the following fields:
{
{          complete: A boolean value which specifies whether the operation is
{            complete.
{
{          status: A status value which specifies the completion status of the
{            operation.  This value is not meaningful unless the operation is
{            complete.
{            CONDITIONS:
{                  nae$connection_terminated
{                  nae$data_transfer_timeout
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$improper_device_class
{              ame$improper_file_id
{              ame$ring_validation_error
{              nae$connection_terminated
{              nae$data_transfer_timeout
{              nae$improper_protocol
{              nae$inconsistent_qualified_data
{              nae$se_synchronize_in_progress
{              nae$send_outstanding
{              {other BAM conditions}
{
*DECK DECK=NAH$SE_SYNCHRONIZE EXPAND=FALSE
{
{    The purpose of this request is to synchronize data transfer over an
{  established CDNA Session connection.  Synchronizing a connection clears the
{  connection of data which has been sent (in one or both directions) but not
{  received.  Synchronizing a connection sends a limited amount of priority
{  data to the peer application.
{
{    Synchronization is given priority over data transfer on a connection.
{  This means that the peer application may be notified of the synchronization
{  prior to receiving data which was sent before the synchronize operation.
{  (The peer application is always notified of the synchronization prior to
{  receiving any data sent after the synchronize operation.)
{
{    Synchronization is not subject to connection flow control.  That is, there
{  is no regulation of the number of synchronization notifications which may
{  accumulate in a connection (due to failure of the peer application to
{  receive them).  A connection may be synchronized even if the connection is
{  congested such that data may not be transferred to the peer application.
{
{    Since synchronization is not subject to flow control, it should be used
{  judiciously.  If an excessive number of synchronization notifications
{  accumulate in the connection, the network may terminate the connection.
{
{    If send data synchronization is specified and a send data operation is
{  active, the operation completes immediately.  Normal status is returned even
{  though not all data is transferred.  Subsequent send data operations result
{  in normal data transfer.
{
{    If receive data synchronization is specified, the the peer application
{  must confirm the synchronization before the transfer of data from the peer
{  application may resume.  Until a notification of the synchronize confirm
{  operation is received by the application, no data may be received from the
{  peer application.
{
{    If receive data synchronization is specified, notification of a
{  synchronize confirm operation by the peer application must be received
{  before another synchronize request specifying receive data synchronization
{  may be made.
{
{    If only send data synchronization is specified, then no peer confirmation
{  is required.  Transfer of data to the peer application may resume upon
{  completion of the request.
{
{        NAP$SE_SYNCHRONIZE (FILE_IDENTIFIER, DIRECTION, DATA, STATUS)
{
{  FILE_IDENTIFIER: (input) This parameter specifies the file access identifier
{        established when the network file was opened.
{
{  DIRECTION : (input) This parameter specifies the direction(s) in which data
{        transfer is to be synchronized.  Data which has been sent in the
{        specified direction but not received is discarded.  The permitted
{        parameter values and their meanings are:
{
{          nac$se_synchronize_send_data: Synchronize the transfer of data to the
{            peer application.
{
{          nac$se_synchronize_receive_data: Synchronize the transfer of data
{            from the peer application.
{
{          nac$se_synchronize_all_data: Synchronize the transfer of data to and
{            from peer application.
{
{  DATA: (input) This parameter specifies the data to be sent to the peer
{        application.  The length of the data may range from 1 to 14 bytes.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$improper_device_class
{              ame$improper_file_id
{              ame$ring_validation_error
{              nae$connection_terminated
{              nae$improper_protocol
{              nae$se_synch_confirm_pending
{              nae$se_synchronize_length_error
{              nae$se_unknown_synch_direction
{              nae$supervisory_traffic_limit
{              {other BAM conditions}
{
*DECK DECK=NAH$SE_SYNCHRONIZE_CONFIRM EXPAND=FALSE
{
{    The purpose of this request is to confirm the synchronization of data
{  transfer over an established CDNA Session connection.
{
{    Following notification that the peer application has synchronized send
{  data, the synchronization must be confirmed before data may be transferred
{  to the peer application.  Until the synchronization is confirmed, an attempt
{  to initiate a send data operation results in abnormal status with the
{  condition nae$se_synchronize_in_progress.
{
{        NAP$SE_SYNCHRONIZE_CONFIRM (FILE_IDENTIFIER, STATUS)
{
{  FILE_IDENTIFIER: (input) This parameter specifies the file access identifier
{        established when the network file was opened.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$improper_device_class
{              ame$improper_file_id
{              ame$ring_validation_error
{              nae$connection_terminated
{              nae$improper_protocol
{              nae$se_no_synch_in_progress
{              nae$supervisory_traffic_limit
{              {other BAM conditions}
{
*DECK DECK=NAH$SK_ACCEPT_SOCKET EXPAND=FALSE
{
{    The purpose of this procedure is to accept a connect request received over
{ the specified listen socket.  As a result of this request a new socket called
{ the accept socket is created and a unique identifier is assigned to it.  All
{ subsequent communication over the new TCP connection will occur over this
{ accept socket.
{
{    If no connect request is available and the interface mode is blocking, the
{ user is blocked until a connect request is available or the interface timeout
{ (specified via the set socket options request) has expired.  If the
{ non-blocking mode has been selected (via the set socket options request), and
{ no connect request is available, control is returned immediately with an
{ appropriate status.
{
{    This request is valid only for a TCP (stream) socket.
{
{       NAP$SK_ACCEPT_SOCKET (LISTEN_SOCKET_ID, ACCEPT_SOCKET_ID,
{             SOURCE_SOCKET, STATUS)
{
{ LISTEN_SOCKET_ID: (input)  This parameter specifies the identifier of the
{       listen socket.
{
{ ACCEPT_SOCKET_ID: (output)  This parameter specifies the identifier of the
{       newly created accept socket.
{
{ SOURCE_SOCKET: (output)  This parameter specifies the port number and the IP
{       address of the entity issuing the connect request.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_incorrect_socket_type
{             nae$sk_invalid_user
{             nae$sk_job_recovery
{             nae$sk_listen_not_done
{             nae$sk_max_sockets_limit
{             nae$sk_no_accept_socket
{             nae$sk_socket_terminated
{             nae$sk_unknown_socket
{
*DECK DECK=NAH$SK_ACCEPT_SOCKET_OFFER EXPAND=FALSE
{
{    The purpose of this procedure is to accept a switch of ownership of a
{ socket from another job excecuting in the local system or another task
{ executing in the current job.  Switching ownership of a socket is a local
{ system operation.  The peer entity is not given any indication of the switch.
{
{    Both the source job and the destination job have to cooperate to complete
{ the switch operation.  The source job offers the socket to the destination
{ job.  The destination job must accept the socket offer within a reasonable
{ time in order to complete the switch operation.
{
{    After the switch is complete, the source job can no longer reference the
{ socket.
{
{    When this request is made and no socket offer is pending this request
{ waits for a specified interval of time.  If no socket offer is made within
{ this interval, the request will return an abnormal status.
{
{       NAP$SK_ACCEPT_SOCKET_OFFER (SOURCE_JOB, WAIT_TIME, SOCKET_ID, STATUS)
{
{ SOURCE_JOB: (input)  This parameter identifies the source job from which the
{       socket offer is to be accepted.
{
{ WAIT_TIME: (input)  This parameter specifies the number of milli- seconds the
{       user is willing to wait for the source job to offer the socket.
{
{ SOCKET_ID: (output)  This parameter specifies the identifier of the socket in
{       the current job.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             ave$missing_required_capability
{             nae$sk_invalid_user
{             nae$sk_max_sockets_limit
{             nae$sk_no_socket_offered
{             nae$sk_unknown_socket_type
{
*DECK DECK=NAH$SK_AWAIT_SOCKET_EVENTS EXPAND=FALSE
{
{    The purpose of this request is to check for the completion of the
{ specified events on the given sockets.  The list of completed events is
{ returned to the caller.  If none of the specified events has completed, the
{ execution of the current task is suspended until the completion of any one of
{ the specified events.
{
{       NAP$SK_AWAIT_SOCKET_EVENTS (SOCKET_EVENTS, COMPLETED_EVENTS, COUNT,
{             STATUS)
{
{ SOCKET_EVENTS: (input)  This parameter specifies an array of socket events to
{       be awaited.
{
{ COMPLETED_EVENTS: (output)  This parameter specifies the array of the
{       completed events.  This parameter is returned only on normal completion
{       of this request.
{
{ COUNT: (output)  This parameter specifies the count of completed events
{       returned via the COMPLETED_EVENTS parameter.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_invalid_event
{             nae$sk_null_list
{             nae$sk_unknown_socket
{
*DECK DECK=NAH$SK_BIND_SOCKET EXPAND=FALSE
{
{       The purpose of this procedure is to bind the given socket
{ to the specified port number and/or IP address. If a 0 value is
{ specified for the port number, NAM/VE will assign a unique port
{ number. If a 0 value is specified for the IP address, the socket
{ is bound to all the IP addresses known to the local host.
{
{       It must be noted that due to the asynchronous interaction
{ between the NAM/VE socket layer and the UDP protocol layer, the
{ user of a UDP socket may be blocked for a length of time
{ proportionate to system activity.
{
{       NAP$SK_BIND_SOCKET (SOCKET_ID, PORT, IP_ADDRESS, STATUS)
{
{ SOCKET_ID: (input) This parameter specifies the identifier of the
{       socket to be bound.
{
{ PORT: (input) This parameter specifies the port number to which
{       the socket is to be bound.
{
{ IP_ADDRESS: (input) This parameter specifies the IP address to which
{       the socket is to be bound.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_invalid_user
{             nae$sk_job_recovery
{             nae$sk_no_available_port
{             nae$sk_no_device_configured
{             nae$sk_port_already_in_use
{             nae$sk_socket_already_bound
{             nae$sk_socket_terminated
{             nae$sk_unknown_socket
{
*DECK DECK=NAH$SK_CLOSE_SOCKET EXPAND=FALSE
{
{    The purpose of this procedure is to close the specified socket.  The
{ socket can be closed only by the task that owns the socket.  The owner of the
{ socket is considered to be the task that creates the socket via the
{ get_socket request or accepts the ownership via the accept_socket_offer
{ request.
{
{    If a task other than the owner tries to close the socket, it will be
{ treated as a no-op i.e., the socket will not be closed and a normal status
{ will be returned to the caller. The NAM/VE will not prevent the non-owning
{ task from initiating further operations on the socket after closing it.
{
{    For a UDP socket, a graceful close is not guaranteed.  For a TCP socket, a
{ graceful close will occur by default unless the non-graceful close option has
{ been selected (via the set socket options request).  The request to close a
{ listen socket by the owner task will result in no more connect requests to be
{ received by the server.  The request to close a connect or accept socket by
{ the owner task will terminate the end to end connection.  All sockets must be
{ explicitly closed via this request.
{
{       NAP$SK_CLOSE_SOCKET (SOCKET_ID, STATUS)
{
{ SOCKET_ID: (input)  This parameter specifies the identifier of the socket to
{       be closed.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_invalid_user
{             nae$sk_unknown_socket
{
*DECK DECK=NAH$SK_CONNECT_SOCKET EXPAND=FALSE
{
{    The purpose of this procedure is to establish a TCP connection with the
{ peer at the given destination IP address and port number.  If the given
{ socket identifier has not been bound by a previous request, it is implicitly
{ bound to a unique port number and the IP address from which the destination
{ address is accessible.  The unique port number is assigned by NAM/VE.
{
{    The caller can override the implicit bind by explicitly binding the socket
{ to a specific IP address, in which case the connection will be established
{ from the specific IP address.  In case the socket is bound to more than one
{ IP address then any one of the IP addresses from which the destination
{ address is accessible will be used.
{
{    The caller will be blocked until the response (connect confirm or a
{ disconnect) is received from the peer or the interface timeout (specified
{ via the set socket options request) has expired.
{
{    This request is valid only for a TCP (stream) socket.
{
{       NAP$SK_CONNECT_SOCKET (SOCKET_ID, DESTINATION_SOCKET, STATUS)
{
{ SOCKET_ID: (input)  This parameter specifies the identifier of the connect
{       socket.
{
{ DESTINATION_SOCKET: (input)  This parameter specifies the port number and IP
{       address of the peer at the destination.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_address_in_use
{             nae$sk_already_connected
{             nae$sk_incorrect_socket_type
{             nae$sk_insufficient_resources
{             nae$sk_interface_timeout
{             nae$sk_invalid_user
{             nae$sk_job_recovery
{             nae$sk_listen_already_active
{             nae$sk_max_sockets_limit
{             nae$sk_no_available_port
{             nae$sk_socket_already_connected
{             nae$sk_socket_closed_via_peer
{             nae$sk_socket_disconnected
{             nae$sk_socket_terminated
{             nae$sk_unknown_socket
{
*DECK DECK=NAH$SK_GET_HOST_NAME EXPAND=FALSE
{
{    The purpose of this procedure is to get the domain name for the host.  An
{ abnormal status is returned if the domain name has not been defined for the
{ host.
{
{       NAP$SK_GET_HOST_NAME (HOST_NAME, STATUS)
{
{ HOST_NAME: (output)  This parameter specifies the domain name for the host.
{       This parameter is returned only on normal completion of this request.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{            nae$sk_tcpip_host_not_defined
{
*DECK DECK=NAH$SK_GET_LOCAL_ADDRESSES EXPAND=FALSE
{
{    The purpose of this procedure is to return the list of local IP addresses
{ known to the host.  An abnormal status will be returned if the TCP/IP
{ communications device support software has not been activated in the host.
{
{       NAP$SK_GET_LOCAL_ADDRESSES (LOCAL_ADDRESSES, COUNT, STATUS)
{
{ LOCAL_ADDRESSES: (output)  This parameter specifies the array to contain the
{       list of IP addresses.  The upperbound of this array must be equal to
{       the number of TCP/IP devices configured on the host.
{
{ COUNT: (output)  This parameter contains the count of the local IP addresses
{       returned via the LOCAL_ADDRESSES parameter.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_tcpip_host_not_defined
{
*DECK DECK=NAH$SK_GET_SOCKET EXPAND=FALSE
{
{    The purpose of this procedure is to create a unique socket of the
{ specified type for the given application.  Two types of sockets can be
{ created - UDP (datagram) socket or TCP (stream) socket.  The assigned
{ socket identifier is unique within the current job.
{
{    This request establishes the current task as the owner of the socket.
{
{       NAP$SK_GET_SOCKET (APPLICATION, SOCKET_TYPE, SOCKET_ID, STATUS)
{
{ APPLICATION: (input)  This parameter specifies the name of the application
{       for which the socket is to be created.  A NULL value for the parameter
{       indicates that the default value be used for the application name.  The
{       default application name is 'UNNAMED_UDP_APPLICATION' or
{       'UNNAMED_TCP_APPLICATION'. This name must have been defined by the MANNA
{       utility.
{
{ SOCKET_TYPE: (input)  This parameter specifies the type of socket to be
{       created.
{
{ SOCKET_ID: (output)  This parameter specifies the socket identifier.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$sk_application_inactive
{             nae$sk_insufficient_resources
{             nae$sk_invalid_user
{             nae$sk_max_sockets_limit
{             nae$sk_protocol_mismatch
{             nae$sk_tcpip_host_not_defined
{             nae$sk_unknown_socket_type
{
*DECK DECK=NAH$SK_GET_SOCKET_ATTRIBUTES EXPAND=TRUE
{
{    The purpose of this request is to return the attributes of the given
{ socket.  The attributes consist of both the user specified options and the
{ address(es) associated with the given socket. No addresses will be returned
{ if it is an unbound socket or if it is a TCP socket that has been bound to
{ all known IP addresses and the listen or connect request has not been issued.
{ The attributes returned will be different depending on the type of socket
{ i.e., UDP or TCP.
{
{       NAP$SK_GET_SOCKET_ATTRIBUTES (SOCKET_ID, SOCKET_ATTRIBUTES, STATUS)
{
{ SOCKET_ID: (input)  This parameter specifies the identifier of the given
{       socket.
{
{ SOCKET_ATTRIBUTES: (output)  This parameter specifies the attributes of the
{       given socket.  The user must specify an array with upper bound equal
{       to the number of configured TCP/IP devices to hold the local IP address
{       attribute.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_invalid_attribute
{             nae$sk_invalid_user
{             nae$sk_job_recovery
{             nae$sk_socket_closed_via_peer
{             nae$sk_socket_disconnected
{             nae$sk_socket_terminated
{             nae$sk_unknown_attribute
{             nae$sk_unknown_socket
{
*DECK DECK=NAH$SK_GET_SOCKET_INFO EXPAND=FALSE
{
{       The purpose of this request is to return the attributes of
{ the given socket. The attributes consist of both the user specified
{ options and the address(es) associated with the given socket. The
{ attributes returned will be different depending on the kind of
{ socket i.e., UDP or TCP.
{
{       NAP$SK_GET_SOCKET_ATTRIBUTES (SOCKET_ID, SOCKET_ATTRIBUTES)
{
{ SOCKET_ID: (input) This parameter specifies the identifier of the
{       given socket.
{
{ SOCKET_ATTRIBUTES: (output) This parameter specifies the attributes
{       of the given socket.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_unknown_socket
{
*DECK DECK=NAH$SK_GET_SOCKET_STATUS EXPAND=TRUE
{
{    The purpose of this procedure is to return information regarding the
{ status of the given socket.  The information returned, depends on the type of
{ socket i.e., UDP or TCP.
{
{       NAP$SK_GET_SOCKET_STATUS (SOCKET_ID, SOCKET_STATUS, STATUS)
{
{ SOCKET_ID: (input)  This parameter specifies the identifier of the given
{       socket.
{
{ SOCKET_STATUS: (output)  This parameter contains information regarding the
{       status of the socket.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_invalid_user
{             nae$sk_job_recovery
{             nae$sk_socket_closed_via_peer
{             nae$sk_socket_disconnected
{             nae$sk_socket_terminated
{             nae$sk_unbound_socket
{             nae$sk_unknown_socket
{
*DECK DECK=NAH$SK_LISTEN_SOCKET EXPAND=FALSE
{
{    The purpose of this procedure is to establish the specified socket as a
{ 'listen' socket.  If the given socket has not been bound by a previous
{ request, it is implicitly bound to a unique port number and all the IP
{ addresses known to the host.  The unique port number is assigned by NAM/VE.
{ After successful completion of this request, the caller can accept connect
{ requests over all the IP addresses bound to the socket.
{
{    This request is valid only for a TCP (stream) socket.
{
{       NAP$SK_LISTEN_SOCKET (SOCKET_ID, QUEUE_LIMIT, STATUS)
{
{ SOCKET_ID: (input)  This parameter specifies the identifier of the socket to
{       be established as a listen socket.
{
{ QUEUE_LIMIT: (input)  This parameter specifies the limit on the number of
{       pending connect requests awaiting accept by the TCP/IP user.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_incorrect_socket_type
{             nae$sk_invalid_user
{             nae$sk_job_recovery
{             nae$sk_listen_already_active
{             nae$sk_no_available_port
{             nae$sk_socket_already_connected
{             nae$sk_socket_terminated
{             nae$sk_unknown_socket
{
*DECK DECK=NAH$SK_OFFER_SOCKET EXPAND=FALSE
{
{    The purpose of this procedure is to offer the ownership of a socket to
{ another job executing in the local system or to another task executing in the
{ current job. The socket can be offered only by the task that owns the socket.
{ The transfer of ownership is a local operation.  The peer entity is not given
{ any indication of the switch.
{
{    Both the source job that is offering the socket and the destination job to
{ which the socket is offered must cooperate to complete the switch.  This
{ process will offer the socket and wait for a specified interval of time.  If
{ the destination job does not accept the socket within the specified time, the
{ socket offer will be cancelled.
{
{    While the socket offer is pending, no other operation may be initiated on
{ the socket. The socket offer cannot be made in the presence of outstanding
{ i/o requests on the socket and will result in this request returning an
{ abnormal status.
{
{    Note that on successful completion of this request, the socket identifier
{ is no longer valid. No further operations can be initiated on this socket.
{
{    This request is valid for UDP bound socket or TCP connect/accept socket.
{ It is not valid for a TCP listen socket.
{
{       NAP$SK_OFFER_SOCKET (SOCKET_ID, DESTINATION_JOB, WAIT_TIME, STATUS)
{
{ SOCKET_ID: (input)  This parameter specifies the identifier of the given
{       socket to be offered.
{
{ DESTINATION_JOB: (input)  This parameter identifies the job to which the
{       socket offer is to be made.
{
{ WAIT_TIME: (input)  This parameter specifies the time in milliseconds for
{       which the user is willing to wait for the destination job to accept the
{       socket offer.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_caller_not_the_owner
{             nae$sk_invalid_user
{             nae$sk_io_pending
{             nae$sk_job_recovery
{             nae$sk_listen_already_active
{             nae$sk_offer_not_accepted
{             nae$sk_socket_closed_via_peer
{             nae$sk_socket_disconnected
{             nae$sk_socket_not_connected
{             nae$sk_socket_terminated
{             nae$sk_unbound_socket
{             nae$sk_unknown_socket
{
*DECK DECK=NAH$SK_PROCESS_JOB_TERMINATION EXPAND=FALSE
{
{   The purpose of this procedure is to cleanup the socket layer
{ data structures at job end. This procedure is meant to be called
{ at job end. No other task should be executing in this job when
{ this procedure is invoked.
{
{       NAP$SK_PROCESS_JOB_TERMINATION
{
*DECK DECK=NAH$SK_READ_SOCKET EXPAND=FALSE
{
{    The purpose of this procedure is to receive data from a TCP socket.  The
{ data will be transferred to the user's buffer until the buffer is full or the
{ next byte of data belongs to an urgent message or a push flag has been
{ detected.  However, if the user's buffer is not full and no more data is
{ available and the interface mode is blocking, the caller is blocked until
{ enough data is available to complete the request or the interface timeout
{ (specified via the set socket options request) expires.  If the non-blocking
{ mode has been selected (via set socket options request), control is returned
{ to the user with an appropriate status and an indication of the actual number
{ of bytes delivered.
{
{    This request is valid only for a TCP accept or connect socket.
{
{       NAP$SK_READ_SOCKET (SOCKET_ID, URGENT_FLAG, DATA, DATA_TRANSFERRED,
{             STATUS)
{
{ SOCKET_ID: (input)  This parameter specifies the identifier of the socket
{       from which data is to be received.
{
{ URGENT_FLAG: (output)  This parameter specifies the priority associated with
{       the received data.
{
{ DATA: (input, output)  This parameter specifies the list of data buffers to
{       hold the data.
{
{ DATA_TRANSFERRED: (output)  This parameter specifies the number of bytes of
{       data placed in the user's buffer.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_data_area_too_small
{             nae$sk_incorrect_socket_type
{             nae$sk_interface_timeout
{             nae$sk_invalid_user
{             nae$sk_job_recovery
{             nae$sk_listen_already_active
{             nae$sk_no_data_available
{             nae$sk_read_in_progress
{             nae$sk_socket_closed_via_peer
{             nae$sk_socket_disconnected
{             nae$sk_socket_not_connected
{             nae$sk_socket_terminated
{             nae$sk_unbound_socket
{             nae$sk_unknown_socket
{
*DECK DECK=NAH$SK_RECEIVE_FROM_SOCKET EXPAND=FALSE
{
{    The purpose of this procedure is to receive data from a given UDP socket.
{ The user can specify an IP address and/or a port number as the selection
{ criteria to mask the incoming data. When specified, NAM/VE will deliver only
{ the data received from the selected source IP address and/or port number.
{ The data received from all other sources will
{ be discarded by NAM/VE.  If a 0 value is specified for the selection criteria,
{ data received from all sources will be delivered.
{
{    If the local IP address parameter is specified and the local IP address
{ option has been enabled (via the set socket options request), on return this
{ parameter will contain the destination IP address of the received message.
{
{    If no data is available and the interface mode is blocking for the local
{ socket, the caller will be blocked until data is available or the interface
{ timeout (specified via the set socket options request) has expired.  If the
{ interface mode is non-blocking (selected via the set socket options request)
{ and no data is available, control will be returned immediately with an
{ appropriate status.
{
{    If the user's buffer is not large enough to hold the entire message, the
{ received message will be discarded and an abnormal status will be returned to
{ the user.
{
{    This request is valid only for a UDP (datagram) socket.
{
{       NAP$SK_RECEIVE_FROM_SOCKET (SOCKET_ID, SELECTION_CRITERIA, FOREIGN_SOCKET,
{             LOCAL_IP_ADDRESS, DATA, DATA_LENGTH, STATUS)
{
{ SOCKET_ID: (input)  This parameter specifies the identifier of the local
{       socket from which data is to be received.
{
{ SELECTION_CRITERIA: (input) If specified, this parameter contains the port
{       number and/or IP address of the source from which the data is to be
{       received.
{
{ FOREIGN_SOCKET: (output) This parameter contains the port number and IP address
{       of the source from which the data was received.
{
{ LOCAL_IP_ADDRESS: (output)  If this parameter is specified and the local IP
{       address option has been enabled, it will contain the destination IP
{       address of the received message.
{
{ DATA: (input, output)  This parameter specifies the list of buffers to
{       receive the data.
{
{ DATA_LENGTH: (output)  This parameter specifies the length of data received.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_data_area_too_small
{             nae$sk_incorrect_socket_type
{             nae$sk_interface_timeout
{             nae$sk_invalid_user
{             nae$sk_job_recovery
{             nae$sk_no_data_available
{             nae$sk_receive_in_progress
{             nae$sk_socket_terminated
{             nae$sk_unbound_socket
{             nae$sk_unknown_socket
{
*DECK DECK=NAH$SK_SEND_TO_SOCKET EXPAND=FALSE
{
{    The purpose of this procedure is to send data to the given destination IP
{ address over the specified socket.  This procedure can be used by a client or
{ server application to send data to the peer using the UDP protocol.  If the
{ given socket has not been bound prior to this request, it is implicitly bound
{ to a unique port number and all the IP addresses known to the host.  The
{ unique port number is assigned by NAM/VE.
{
{    Note that if the socket is unbound, the user may experience an additional
{ delay to bind the socket.  This delay is due to the asynchronous interaction
{ between the NAM/VE socket layer and the UDP protocol layer.  The user can
{ avoid this delay on the initial send by explicitly binding the socket prior
{ to this request.
{
{    If the local IP address is specified, and the local IP address option has
{ been enabled (via the set socket options request), the data will be sent from
{ the specified IP address.  However, if a NULL value is specified for the
{ local IP address or the local IP address option has been disabled, the user
{ cache enabled option is examined.  If the user cache is enabled, the local IP
{ address from which the last datagram was sent or at which the last datagram
{ arrived, will be used for transferring data.  If the user cache has been
{ disabled (via the set socket options request), any one of the IP addresses to
{ which the socket is bound and from which the destination IP address can be
{ reached will be used.
{
{    Note that if the local socket had been bound by a previous request, the
{ local IP address must match the IP address (or match one of the list of IP
{ addresses) bound to the socket.
{
{    If sufficient resources are not available to send all the data and the
{ interface mode is blocking, the user will be blocked until resources become
{ available or the interface timeout (specified via the set socket options
{ request) expires.  If the interface mode is non-blocking (selected via the
{ set socket options request), control is returned immediately with an
{ appropriate status.
{
{    If sufficient resources are present, the user will be allowed to send a
{ maximum of 9000 bytes of data with non-blocking interface mode.  A request to
{ send messages larger than 9000 bytes with non-blocking interface mode will be
{ rejected.  The user should select an interface mode of blocking to send
{ messages larger than 9000 bytes.
{
{    This request is valid only for a UDP (datagram) socket.
{
{       NAP$SK_SEND_TO_SOCKET (SOCKET_ID, LOCAL_IP_ADDRESS, DESTINATION_SOCKET,
{             DATA, STATUS)
{
{ SOCKET_ID: (input)  This parameter specifies the identifier of the local UDP
{       socket.
{
{ LOCAL_IP_ADDRESS: (input)  This parameter specifies the local IP address from
{       which the data is to be sent.
{
{ DESTINATION_SOCKET: (input)  This parameter specifies the port number and the
{       IP address of the destination socket to which the data is to be sent.
{
{ DATA: (input)  This parameter specifies the list of data fragments to be
{       sent.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_incorrect_socket_type
{             nae$sk_insufficient_resources
{             nae$sk_interface_timeout
{             nae$sk_invalid_user
{             nae$sk_job_recovery
{             nae$sk_max_nonblock_size_exceed
{             nae$sk_send_in_progress
{             nae$sk_socket_disconnected
{             nae$sk_socket_terminated
{             nae$sk_unknown_socket
{             nae$sk_zero_length_data
{
*DECK DECK=NAH$SK_SET_SOCKET_OPTIONS EXPAND=TRUE
{
{    The purpose of this procedure is to select options for the given socket.
{ These options control the processing of various socket requests.
{
{       NAP$SK_SET_SOCKET_OPTIONS (SOCKET_ID, OPTIONS, STATUS)
{
{ SOCKET_ID: (input)  This parameter specifies the identifier of the given
{       socket for which the options are to be selected.
{
{ OPTIONS: (input)  This parameter specifies the array of options to be
{       selected for the given socket.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_incorrect_option
{             nae$sk_invalid_option
{             nae$sk_invalid_user
{             nae$sk_job_recovery
{             nae$sk_listen_already_active
{             nae$sk_socket_closed_via_peer
{             nae$sk_socket_disconnected
{             nae$sk_socket_terminated
{             nae$sk_unknown_socket
{
*DECK DECK=NAH$SK_WRITE_SOCKET EXPAND=FALSE
{
{    The purpose of this procedure is to send data over the given TCP socket
{ via the TCP connection.  The data transfer is subject to flow control.  If
{ sufficient resources are not available to send data and the interface mode is
{ blocking, the caller will be blocked until resourcess become available or the
{ interface timeout (specified via the set socket options request) expires.
{ However, if the non-blocking mode has been selected (via the set socket
{ options request), control will be returned to the user with an appropriate
{ status and an indication of the actual number of bytes sent.
{
{    The user can send urgent data by specifying the URGENT flag on the
{ request.  The user can cause the entire data path to be flushed by specifying
{ the PUSH flag.  The user can send 0 bytes of data with the PUSH flag.
{
{    This request is valid only for a TCP accept or connect socket.
{
{       NAP$SK_WRITE_SOCKET (SOCKET_ID, URGENT_FLAG, PUSH_FLAG, DATA,
{             DATA_TRANSFERRED, STATUS)
{
{ SOCKET_ID: (input)  This parameter specifies the identifier of the local
{       socket.
{
{ URGENT_FLAG: (input)  This parameter specifies the URGENT option to be
{       associated with the data.
{
{ PUSH_FLAG: (input)  This parameter specifies the PUSH option to be
{       associated with the request.
{
{ DATA: (input, output)  This parameter specifies the list of data fragments to
{       be sent.
{
{ DATA_TRANSFERRED: (output)  This parameter specifies the number of bytes
{       actually sent by this request.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_insufficient_resources
{             nae$sk_incorrect_socket_type
{             nae$sk_interface_timeout
{             nae$sk_invalid_user
{             nae$sk_job_recovery
{             nae$sk_listen_already_active
{             nae$sk_socket_closed_via_peer
{             nae$sk_socket_disconnected
{             nae$sk_socket_not_connected
{             nae$sk_socket_terminated
{             nae$sk_unbound_socket
{             nae$sk_unknown_socket
{             nae$sk_write_in_progress
{             nae$sk_zero_length_data
{
*DECK DECK=NAH$STORE_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to specify connection attribute values to be
{  used for a connection.  The connection whose attributes are to be changed is
{  specified via an instance of open of the network file which identifies the
{  local end point of the connection.
{
{    If a connection access attribute is changed, the new value applies only
{  when the connection is accessed via the specified instance of open of the
{  network file.
{
{        NAP$STORE_ATTRIBUTES (FILE_IDENTIFIER, ATTRIBUTES, STATUS)
{
{  FILE_IDENTIFIER: (input) This parameter specifies the file access identifier
{        established when the network file was opened.
{
{  ATTRIBUTES: (input) This parameter specifies the attributes to be changed and
{        the new values for these attributes.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$improper_device_class
{              ame$improper_file_id
{              ame$ring_validation_error
{              nae$connection_terminated
{              nae$invalid_eoi_message_size
{              nae$invalid_connect_data_change
{              nae$max_data_length_exceeded
{              nae$unknown_attribute
{              {other BAM conditions}
{
*DECK DECK=NAH$SYSTEM_ID EXPAND=FALSE
{
{   The purpose of this request is to return the system identifier of the
{ local system.
{
{       NAP$SYSTEM_ID ()
{
*DECK DECK=NAH$USER_NETWORK_ID EXPAND=FALSE
{
{   The purpose of this request is to return the network identifier to be used
{ in forming the Internet address for a NAM/VE user.
{
{       NAP$USER_NETWORK_ID ()
{
*DECK DECK=NAH$VERIFY_TCPIP_NAME EXPAND=FALSE
{
{    The purpose of this procedure is to verify that the given TCP/IP
{ application name is unique.
{
{       NAP$VERIFY_TCPIP_NAME (APPLICATION, STATUS)
{
{ APPLICATION: (input)  This parameter specifies the application name.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$application_already_defined
{
*DECK DECK=NAH$XNS_CHECKSUM EXPAND=FALSE
{
{   The purpose of this request is to calculate the 16 bit ones complement,
{ left shift around checksum of a block of data on a computer that uses twos
{ complement arithmetic.  The data is allowed to be in multiple fragments.
{
{   IF a odd number of bytes are given in the data block, the last byte of
{ data is treated as the first byte of a 16 bit parcel with zero fill.
{
{   A computed checksum value of minus zero is converted to a plus zero.
{
{     NAP$XNS_CHECKSUM (DATA_FRAGMENTS)
{
{   DATA_FRAGMENTS: This parameter specifies the address and length of the
{         blocks of data to be checksummed.
{
{   Note the total length of the data fragment must be even
{
*DECK DECK=NAI$DEFINE_IPI_REGISTERS EXPAND=FALSE
          SPACE  5
** BMGEN MACRO
** THIS IS A SUPPORT MACRO TO GENERATE A ONE BIT MASK AS
** SPECIFIED BY BIT.
          SPACE  2
BMGEN     MACRO  BIT
MASK$     SET    1
          DUP    BIT
MASK$     SET    MASK$+MASK$
          ENDD
          ENDM
          SPACE  5
** DMA CONTROL REGISTER
*  THE CONTROL REGISTER IS USED TO SELECT THE DIFFERENT
*  OPERATING MODES OF THE IPI ADAPTER.
          SPACE  2
 DMACR    RECORD PACKED
          ALIGN  0,16
 SBF      SUBRANGE 0,511     SINGLE BIT FIELDS
 FEC      SUBRANGE 0,127     FORCE ERROR CODES
          SPACE  2
 EFEC     EQU    7           ENABLE FORCD ERROR CODES
 PAUSE    EQU    8           ENABLE PAUSE
 TPRIME   EQU    9           ENABLE T PRIME EMPTY FLAG
 TIP      EQU    10          ENABLE TRANSFER IN PROGRESS
 TEST     EQU    12          TEST MODE
 DISTO    EQU    13          DISABLE TRANSFER TIMEOUT
 DCMI     EQU    14          ENABLE DOUBLE CMI SLOT
 CACHE    EQU    15          ENABLE CACHE INVALIDATE
          SPACE  2
          BMGEN  EFEC
 K.EFEC   EQU    MASK$
          BMGEN  PAUSE
 K.PAUSE  EQU    MASK$
          BMGEN  TPRIME
 K.TPRIME EQU    MASK$
          BMGEN  TIP
 K.TIP    EQU    MASK$
          BMGEN  TEST
 K.TEST   EQU    MASK$
          BMGEN  DISTO
 K.DISTO  EQU    MASK$
          BMGEN  DCMI
 K.DCMI   EQU    MASK$
          BMGEN  CACHE
 K.CACHE  EQU    MASK$
          SPACE  2
 DMACR    RECEND
          SPACE  5
** DMA OPERATIONAL STATUS  REGISTER
*  THE OPERATIONAL STATUS REGISTER IS A READ ONLY REGISTER WHICH
*  PROVIDES INFORMATION REGARDING THE STATE OF THE ADAPTER AND
*  IPI CHANNEL.
          SPACE  2
 DMAOSR   RECORD PACKED
          ALIGN  0,16
 REG      PPWORD
*         BITS 10 THRU 15 ARE DEFINED FOR 10 MB CHANNEL ONLY
 PEFR     EQU    15          FUNCTION REGISTER PARITY ERROR
 PECR     EQU    14          CONTROL REGISTER PARITY ERROR
 PEDRI    EQU    13          DATA REGISTER INPUT PARITY ERROR
 PEDRO    EQU    12          DATA REGISTER OUTPUT PARITY ERROR
 PETRC    EQU    11          T REGISTER COUNTER PARITY ERROR
 PEDTC    EQU    10          DEADMAN TIMER COUNTER PARITY ERROR
*         BIT 8 IS DEFINED FOR 25 MB CHANNEL ONLY
 DMACOM   EQU    8           DMA TRANSFER COMPLETE
 DMAIN    EQU    7           DMA TRANSFER IN PROGRESS
 IPIIN    EQU    6           IPI TRANSFER IN PROGRESS
 OUTM     EQU    5           OUTPUT MODE
*         BIT 4 IS DEFINED FOR 25 MB CHANNEL ONLY
 PAUS     EQU    4           CHANNEL PAUSE
 DMAMOD   EQU    3           DMA/IPI MODE
 ICIIN    EQU    2           PP/IPI MODE
 TEMP     EQU    1           T PRIME REGISTER EMPTY
 CHIN     EQU    0           CHANNEL TRANSFER IN PROGRESS
          SPACE  2
          BMGEN  PEFR
 K.PEFR   EQU    MASK$
          BMGEN  PECR
 K.PECR   EQU    MASK$
          BMGEN  PEDRI
 K.PEDRI  EQU    MASK$
          BMGEN  PEDRO
 K.PEDRO  EQU    MASK$
          BMGEN  PETRC
 K.PETRC  EQU    MASK$
          BMGEN  PEDTC
 K.PEDTC  EQU    MASK$
          BMGEN  DMACOM
 K.DMACOM EQU    MASK$
          BMGEN  DMAIN
 K.DMAIN  EQU    MASK$
          BMGEN  IPIIN
 K.IPIIN  EQU    MASK$
          BMGEN  OUTM
 K.OUTM   EQU    MASK$
          BMGEN  PAUS
 K.PAUS   EQU    MASK$
          BMGEN  DMAMOD
 K.DMAMOD EQU    MASK$
          BMGEN  ICIIN
 K.ICIIN  EQU    MASK$
          BMGEN  TEMP
 K.TEMP   EQU    MASK$
          BMGEN  CHIN
 K.CHIN   EQU    MASK$
          SPACE  2
 DMAOSR   RECEND
          SPACE  5
**  DMA ERROR STATUS REGISTER
*   THE ERROR STATUS REGISTER PROVIDES INFORMATION IN THE EVENT
*   OF A HARDWARE DETECTABLE ERROR.
          SPACE  2
 DMAESR   RECORD PACKED
          ALIGN  0,16
 REG      PPWORD
          SPACE  2
 DMAOV    EQU    15          DMA COUNT OVERFLOW (25MB ONLY)
 ILLFN    EQU    14          ILLEGAL FUNCTION OR SEQUENCE
 CMERR    EQU    13          UNCORRECTED CENTRAL MEMORY ERROR
 CMREJ    EQU    12          CENTRAL MEMORY REJECT
 INVRC    EQU    11          INVALID RESPONSE CODE
 PERC     EQU    10          CM RESPONSE CODE PARITY ERROR
 PECMI    EQU    9           CMI READ DATA PARITY ERROR
 IPIER    EQU    8           IPI ERROR
 PEDMA    EQU    7           DMA REGISTER PARITY ERROR  (10MB ONLY)
 PEMAC    EQU    6           MAC STATUS PARITY ERROR
 TIMO     EQU    5           TIME OUT                   (10MB ONLY)
 DATER    EQU    4           DMA DATA ERROR
 PEBAS    EQU    3           BAS PARITY ERROR
 ZERR     EQU    2           Z ERROR                    (10MB ONLY)
 YERR     EQU    1           Y ERROR
 XERR     EQU    0           X ERROR
          SPACE  2
          BMGEN  DMAOV
 K.DMAOV  EQU    MASK$
          BMGEN  ILLFN
 K.ILLFN  EQU    MASK$
          BMGEN  CMERR
 K.CMERR  EQU    MASK$
          BMGEN  CMREJ
 K.CMREJ  EQU    MASK$
          BMGEN  INVRC
 K.INVRC  EQU    MASK$
          BMGEN  PERC
 K.PERC   EQU    MASK$
          BMGEN  PECMI
 K.PECMI  EQU    MASK$
          BMGEN  IPIER
 K.IPIER  EQU    MASK$
          BMGEN  PEDMA
 K.PEDMA  EQU    MASK$
          BMGEN  PEMAC
 K.PEMAC  EQU    MASK$
          BMGEN  TIMO
 K.TIMO   EQU    MASK$
          BMGEN  DATER
 K.DATER  EQU    MASK$
          BMGEN  PEBAS
 K.PEBAS  EQU    MASK$
          BMGEN  ZERR
 K.ZERR   EQU    MASK$
          BMGEN  YERR
 K.YERR   EQU    MASK$
          BMGEN  XERR
 K.XERR   EQU    MASK$
 DMAESR   RECEND
          SPACE  5
** IPI STATUS REGISTER
          SPACE  2
 IPISR    RECORD PACKED
          ALIGN  0,16
 STATUS   STRUCT 1
 BUSB     STRUCT 1
          SPACE  2
 ERROR    EQU    15          ERROR BIT
 ATTEN    EQU    14          ATTENTION IN
 NOTEM    EQU    13          BUFER NOT EMPTY
 SELO     EQU    12          SELECT OUT
 SLAI     EQU    11          SLAVE IN
 MASO     EQU    10          MASTER OUT
 SYNI     EQU    9           SYNC IN
 SYNO     EQU    8           SYNC OUT
 PAUSE    EQU    7           PAUSE
          SPACE  2
          BMGEN  ERROR
 K.ERROR  EQU    MASK$
          BMGEN  ATTEN
 K.ATTEN  EQU    MASK$
          BMGEN  NOTEM
 K.NOTEM  EQU    MASK$
          BMGEN  SELO
 K.SELO   EQU    MASK$
          BMGEN  SLAI
 K.SLAI   EQU    MASK$
          BMGEN  MASO
 K.MASO   EQU    MASK$
          BMGEN  SYNI
 K.SYNI   EQU    MASK$
          BMGEN  SYNO
 K.SYNO   EQU    MASK$
          BMGEN  PAUSE
 K.PAUSE  EQU    MASK$
 K.ALLIN  EQU    K.SELO+K.SLAI+K.MASO+K.SYNI+K.SYNO
          SPACE  2
 IPISR    RECEND
** IPI ERROR REGISTER
* DEFINE THE IPI ERROR REGISTER FOR 10MD CHANNEL
          SPACE  2
 IPIER    RECORD PACKED
          ALIGN  0,16
 IPIERR   PPWORD
          SPACE  2
 PEBC     EQU    15          BUFFER COUNTER PARITY ERROR
 PESC     EQU    13          SYNC COUNTER PARITY ERROR
 PEPC     EQU    12          PERIOD COUNTER PARITY ERROR
 PEFU     EQU    11          FUNCTION UPPER PARITY ERROR
 PEFL     EQU    10          FUNCTION LOWER PARITY ERROR
 LOSTD    EQU    7           LOST DATA
 PEDU     EQU    6           DATA UPPER PARITY ERROR
 PEDL     EQU    5           DATA LOWER PARITY ERROR
 SEQER    EQU    4           IPI SEQUENCE ERROR
 PEBUSA   EQU    3           BUS A PARITY ERROR
 PEBUSB   EQU    2           BUS B PARITY ERROR
 ILLF     EQU    1           ILLEGAL FUNCTION
          BMGEN  PEBC
 K.PEBC   EQU    MASK$
          BMGEN  PESC
 K.PESC   EQU    MASK$
          BMGEN  PEPC
 K.PEPC   EQU    MASK$
          BMGEN  PEFU
 K.PEFU   EQU    MASK$
          BMGEN  PEFL
 K.PEFL   EQU    MASK$
          BMGEN  LOSTD
 K.LOSTD  EQU    MASK$
          BMGEN  PEDU
 K.PEDU   EQU    MASK$
          BMGEN  PEDL
 K.PEDL   EQU    MASK$
          BMGEN  SEQER
 K.SEQER  EQU    MASK$
          BMGEN  PEBUSA
 K.PEBUSA EQU    MASK$
          BMGEN  PEBUSB
 K.PEBUSB EQU    MASK$
          BMGEN  ILLF
 K.ILLF   EQU    MASK$
 IPIER    RECEND

*DECK DECK=NAI$NETWORK_COMMON_DECK EXPAND=FALSE
          TITLE  NETWORK DRIVER COMMON ROUTINES.
**        CCK - CLEAR CHANNEL LOCK.
*
*         CLEAR THE CHANNEL LOCK IN THE CM CHANNEL TABLE.
*
*         ENTRY  (CM.CHAN) = THE START OF 3 WORDS
*                 THAT CONTAIN A REFORMATTED CM ADDRESS
*                 POINTING TO THE CHANNEL TABLE.
*                (CHAN) = THE CHANNEL NUMBER.
*
*         EXIT    THE CHANNEL IS UNLOCKED.
*
*         USES   T5, T7.
*
*         CALLS  CLK.
          SPACE  4,10
CCK       SUBR               ENTRY/EXIT
          LDK    CM.CHAN
          STD    T7          SET POINTER TO CHANNEL TABLE
          LDML   CHAN
          STD    T5          SET CHANNEL NUMBER AS INDEX
          RJM    CLK         CLEAR THE LOCK ON THAT CM WORD
          NJN    *           ERROR LOCK CAN NOT BE CLEARED
          STML   CHLOCK      CLEAR CHANNEL LOCKED FLAG
          UJK    CCKX        EXIT

          SPACE  4,10
**        CDA - CHECK IF DATA AVAILABLE.
*
*         THIS ROUTINE OBTAINS THE GENERAL STATUS AND, IF
*         NO ERRORS, CHECKS FOR DATA AVAILABLE.
*
*         EXIT   (A) < 0, IF DATA AVAILABLE.
*
*         CALLS  GST.
          SPACE  4,10
 CDA      SUBR               ENTRY/EXIT
          RJM    CSC
          ZJN    CDA10       IF NO ERROR
          LDN    0
          UJN    CDAX        EXIT, IF CAN NOT READ STATUS

 CDA10    LDDL   GNSTAT      GENERAL STATUS
          SHN    17-S.DATAV
          UJN    CDAX        EXIT
          SPACE  4,14
**        CLK - CLEAR LOCK.
*
*         THIS ROUTINE CLEARS THE LOCK AT THE SPECIFIED
*         CM ADDRESS.
*
*         ENTRY  (T7) = CM TABLE ADDRESS.
*                (T5) = WORD OFFSET OF LOCKWORD.
*
*         EXIT   (A) = 0, IF LOCK CLEARED,
*                (A) <> 0, IF LOCK COULD NOT BE CLEARED.
*
*         USES   T1, T2, T3, T4, T5, T6, T7.
*
*         MACROS LOADR.
          SPACE  2,10
 CLK      SUBR               ENTRY/EXIT
 CLK10    LCN    0
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          IFEQ   DRTYP,1
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ENDIF
          IFEQ   DRTYP,2
          LRIL   T7
          LDML   1,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ENDIF
          ADDL   T5          ADD LOCKWORD OFFSET
          STDL   T6
          RDSL   T1          SET UPPER 32 BITS OF LOCK WORD TO '1'S
          LDDL   T1
          ADDL   T2
          ADC    400001B
          ZJN    CLK10       IF ANOTHER INTERLOCK OPERATION IS IN PROGRESS
          AODL   T5          INSURE T5 NON ZERO
          LDDL   T1
          SHN    17-15
          PJN    CLK20       IF INTERLOCK LOST (RESTORE ORIGINAL CONTENTS)
          LDDL   T4
          LMDL   PPNO        PP NUMBER
          NJN    CLK20       IF SOMEONE ELSE HAS GRABBED THE INTERLOCK
*         LDN    0
          STDL   T1          CLEAR INTERLOCK WORD
          STDL   T2
          STDL   T3
          STDL   T4
          STDL   T5
 CLK20    LDDL   T6
          ADC    400000B
          CWDL   T1          UPDATE INTERLOCK WORD
          LDDL   T5
          UJK    CLKX        RETURN
          SPACE  4,10
**        CPL - CLEAR PP INTERFACE QUEUE LOCK.
*
*         THIS ROUTINE CLEARS THE PP QUEUE LOCK IN THE PP
*         INTERFACE TABLE.
*
*         USES   T5, T7.
*
*         CALLS  CLK.
          SPACE  4,10
 CPL      SUBR               ENTRY/EXIT
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    CLK         CLEAR THE LOCKWORD
          UJK    CPLX
 CSW      SPACE  4,16
**        CSW - COMPARE-SWAP ROUTINE.
*
*         THIS ROUTINE DOES A COMPARE-SWAP OF A SPECIFIED LOCK.
*         A PSEUDO-LANGUAGE COMPARABLE CALL WOULD BE
*            CALL COMPARE-SWAP(LOCK, OLD, NEW, ACTUAL, STATUS)
*            WHERE
*                LOCK   = (T7) + (T5) = ADDRESS OF THE LOCK
*                OLD    = ((P5)) = EXPECTED VALUE OF THE LOCK
*                NEW    = ((A)) UPON ENTRY = REPLACEMENT VALUE OF THE LOCK
*                ACTUAL = (P1 - P4) RETURNED BY ROUTINE *SLR* = ORIGINAL VALUE
*                         OF THE LOCK
*                STATUS = (A) UPON EXIT = SUCCESS/FAILURE OF THE COMPARE-SWAP
*
*         ENTRY  (A)  = ADDRESS OF NEW (REPLACEMENT) VALUE FOR LOCK.
*                (P5) = ADDRESS OF OLD (EXPECTED) VALUE IN LOCK.
*                (T5) = WORD OFFSET OF LOCKWORD.
*                (T7) = CM ADDRESS OF TABLE.
*
*         EXIT   (A) = 0, IF THE COMPARE-SWAP WAS SUCCESSFUL.  (IF THE CONTENTS
*                         OF THE LOCK WERE REPLACED BY *NEW*).
*                (A) <> 0, IF THE COMPARE-SWAP FAILED.  (IF THE ORIGINAL
*                          CONTENTS REMAIN IN THE LOCK).
*                (P5) = UNDEFINED.
*
*         USES   P1 - P4, T2, T6.
*
*         CALLS  SLR.


*         OLD VALUE WAS NOT IN THE LOCK.  RESTORE ORIGINAL VALUE.

 CSW40    BSS    0
          LDDL   T6          OFFSET TO CM WORD
          ADC    400000B
          CWDL   P1          UPDATE INTERLOCK WORD WITH ORIGINAL VALUE

 CSW      SUBR               ENTRY/EXIT
          STML   CSWA        PLANT PP ADDRESS OF *NEW*

 CSW20    BSS    0
          RJM    SLR         SET LOCK RESERVATION

*         IF ACTUAL=OLD  (IF (P1) - (P1+2) = ((OLD)) - ((OLD+2))).

          LDN    2           CHECK 3 PP WORDS (0..2) (PVA SIZE IS 3 PP WORDS)
          STDL   T2          STARTING OFFSET FOR *ACTUAL*
          RADL   P5          STARTING INDIRECT VALUE FOR *OLD*

 CSW30    BSS    0
          LDIL   P5          A PORTION OF *OLD*
          LMML   P1,T2       COMPARE WITH CORRESPONDING PORTION OF *ACTUAL*
          NJK    CSW40       IF DIFFERENT
          SODL   P5          NEXT INDIRECT VALUE FOR *OLD*
          SODL   T2          NEXT OFFSET FOR *ACTUAL*
          PJK    CSW30       IF MORE TO CHECK

          LDN    1           SIZE OF *NEW* (CM WORDS)
          STDL   WC
          LDDL   T6          OFFSET TO CM WORD
          ADC    400000B
          CWML   **,WC       UPDATE INTERLOCK WORD WITH *NEW*
 CSWA     EQU    *-1         PP ADDRESS OF *NEW*

          LDN    0           CM WORD CONTENTS WERE REPLACED BY *NEW*
          UJK    CSWX        EXIT
 IRP      SPACE  4,10
**        IRP - INITIALIZE REQUEST PROCESSING.
*
*         INITIALIZES A PERIPHERAL RESPONSE TEMPLATE, AND ESTABLISHES
*         THE ENVIRONMENT FOR REQUEST PROCESSING.  TERMINATION MAY BE
*         REFLECTED THROUGH A PERIPHERAL RESPONSE AFTER THE RESPONSE
*         IS INITIALIZED.
*
*         ENTRY  (RQ) = PERIPHERAL REQUEST BEING PROCESSED.
*
*         EXIT   (RS) = RESPONSE AREA FOR RESPONSE.
          SPACE  4,10
 IRP      SUBR           ENTRY/EXIT
          LDML   RQ+/RQ/P.RECOV  RECOVER, INTERRUPT, PORT, PRIORITY
          LPC    177400B
          LMML   DEVID
          STML   RS+/RS/P.RECOV
          LDML   RQ+/RQ/P.ALRT   ALERT MASK
          STML   RS+/RS/P.ALRT
          LDML   RS+/RS/P.REQ+1
          ERRNZ  /RQ/C.CMND-/URQ/C.CODE   COMMAND CODES NOT THE SAME
          ADN    /RQ/C.CMND*8  DETERMINE RMA OF COMMAND
          STML   RS+/RS/P.LASTC+1  PUT RMA OF COMMAND IN RESPONSE BUFFER
          SHN    -16
          ADML   RS+/RS/P.REQ
          STML   RS+/RS/P.LASTC
          UJK    IRPX        EXIT
          SPACE  4,13
**        IGS - INCLUDE GENERAL STATUS.
*
*         THIS ROUTINE SETS GENERAL STATUS INTO THE
*         RESPONSE BUFFER AND SETS THE GENERAL
*         STATUS INCLUDED BIT IN THE RESPONSE.
*
*         ENTRY  (GNSTAT) = COPY OF GENERAL STATUS.
*
*         USES   T9, T10.
          SPACE  4,10
 IGS      SUBR               ENTRY/EXIT
          LDC    /RS/K.LGS
          STDL   T9
          LMC    -0
          STDL   T10
          LDML   LRS+/RS/P.LGS  STATUS FLAGS
          LPDL   T10
          ADDL   T9          ADD GENERAL STATUS
          STML   LRS+/RS/P.LGS
          LDDL   GNSTAT
          STML   LRS+/RS/P.GENST
          UJN    IGSX        EXIT
          SPACE  4,10
**        PIE - PROCESS INTERFACE ERROR.
*
*         THIS ROUTINE SETS UP THE INTERFACE ERROR CODE
*         AND THE INTERFACE ERROR BIT IN THE RESPONSE.  THE
*         RESPONSE CODE IS ALSO SET TO ABNORMAL.  IF THE
*         RESPONSE IS TO BE UNSOLICITED THEN THE RESPONSE CODE
*         WILL BE CHANGED BY ROUTINE *USR*.
*
*         ENTRY  (A) = INTERFACE ERROR CODE.
*
*         EXIT   (A) > 0.
          SPACE  4,10
 PIE      SUBR               ENTRY/EXIT
          STML   IERC        INTERFACE ERROR CODE
          LDML   ABSC        ABNORMAL STATUS
          LPC    /RS/K.INTERR
          NJN    PIE10       IF INTERFACE ERROR BIT ALREADY SET
          LDC    /RS/K.INTERR
          RAML   ABSC        SET INTERFACE ERROR BIT
 PIE10    LDN    R.ABN       ABNORMAL RESPONSE CODE
          STDL   RESPC
          UJN    PIEX        EXIT
          SPACE  4,10
**        PPR - PROCESS PP REQUESTS.
*
*         THIS ROUTINE PROCESSES ALL THE REQUESTS IN THE
*         PP QUEUE.
*
*         EXIT   PP REQUEST QUEUE EMPTY.
*
*         CALLS  GPR, PPC, STR.
          SPACE  4,10
 PPR      SUBR               ENTRY/EXIT
          LDN    0
          STML   REQTYP      SET REQUEST TYPE = PP
 PPR10    BSS    0
          IFEQ   BRK,1
          RJM    BKPM
          ENDIF
          RJM    GPR         GET PP REQUEST
          ZJN    PPRX        IF NO REQUESTS - EXIT
          RJM    PPC         PROCESS PP COMMAND
          RJM    STR         SEND TERMINATION RESPONSE
          UJN    PPR10
          SPACE  4,10
**        PRC - PUT RESPONSE CODES IN RESPONSE.
*
*         THIS ROUTINE SETS UP THE RESPONSE AND ERROR CODE
*         FIELDS IN THE PP RESPONSE BUFFER.
*
          SPACE  6
 PRC      SUBR               ENTRY/EXIT
          LDDL   RESPC       RESPONSE CODE
          SHN    /RS/L.RCON-/RS/L.RC+/RS/N.RCON-/RS/N.RC
          ADML   RCON        RESPONSE CONDITION
          SHN    /RS/L.URC-/RS/L.RCON+/RS/N.URC-/RS/N.RCON
          ERRNZ  /RS/P.URC-/RS/P.RCON
          ERRNZ  /RS/P.RC-/RS/P.URC
          ADDL   UNSC        UNSOLICITED RESPONSE CODE
          STML   RS+/RS/P.URC
          LDML   ABSC        ABNORMAL STATUS CODE
          STML   RS+/RS/P.INTERR
          LDML   IERC        INTERFACE ERROR CODE
          STML   RS+/RS/P.IEC
          UJK    PRCX
          SPACE  4,10
**        PRD - PROCESS READ.
*
*         THIS ROUTINE PERFORMS A READ IF THE
*         NETWORK DEVICE DATA IS AVAILABLE.
*
*         CALLS  CDA, PFR.
          SPACE  4,10
 PRD      SUBR               ENTRY/EXIT
          LDML   NUMBP       NUMBER OF BUFFER POOLS
          ZJN    PRDX        IF NO BUFFER DESCRIPTORS
          RJM    CDA         CHECK IF DATA AVAILABLE
          PJN    PRDX        IF NO DATA AVAILABLE
          RJM    PFR         PERFORM READ
          UJK    PRDX        EXIT
          SPACE  4,10
**        PUC - PROCESS UNIT COMMAND.
*
*         THIS ROUTINE PROCESSES A WRITE COMMAND.
*         MULTIPLE WRITE COMMANDS PER REQUEST ARE
*         NOT ALLOWED.
*
*         ENTRY  (CM) = COMMAND.
*                (RQ) = REQUEST.
*
*         EXIT   (STBI) = REQUEST CODE.
*
*         CALLS  PIE, STR, WRP.
          SPACE  4,10
 PUC      SUBR               ENTRY/EXIT
          ERRNZ  /RQ/C.CMND-/URQ/C.CODE   COMMAND CODES NOT THE SAME
          LDML   CM+/CM/P.CODE  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          STML   STBI
          LMK    C.WRTR      COMPARE WITH WRITE RECORD
          NJN    PUC10       IF BAD COMMAND CODE

*         PROCESS VALID COMMAND.

          RJM    WRP         WRITE RECORD PROCESSOR
          UJK    PUCX        EXIT

*         PROCESS INVALID COMMAND.

 PUC10    BSS    0
          LDC    E501        INTERFACE ERROR CODE
          RJM    PIE         PROCESS INTERFACE ERROR
          RJM    STR         SEND TERMINATION RESPONSE
          UJK    PUCX        EXIT
          SPACE  4,20
**        PUR - PROCESS UNIT REQUEST.
*
*         THIS ROUTINE PROCESSES ONE UNIT REQUEST FROM A UNIT QUEUE.  IF NORMAL
*         FLOW CONTROL IS ON ONLY PRIORITY REQUESTS ARE PROCESSED.  IF NORMAL
*         FLOW CONTROL IS OFF THEN A PRIORITY REQUEST WILL BE SELECTED IF
*         AVAILABLE, IF NOT A NORMAL REQUEST WILL BE SELECTED.  NOT MORE THAN
*         *MAXPR* CONSECUTIVE PRIORITY REQUESTS WILL BE SELECTED WITHOUT A
*         NORMAL REQUEST BEING SELECTED IF NORMAL FLOW CONTROL IS OFF.
*
*         ENTRY  (CM.URQ) = REFORMATTED R REGISTER PORTION OF
*                           THE MASTER CONTROL TABLE ADDRESS.
*                (CM.MCT) = REFORMATTED A REGISTER PORTION OF THE
*                           MASTER CONTROL TABLE ADDRESS.
*                (NUMPRI) < OR = MAXPR IF FLOW CONTROL OFF,
*                         > MAXPR IF FLOW CONTROL ON.
*
*         EXIT   (CM.URQ+2) = REFORMATTED A REGISTER PORTION OF THE FIRST WORD
*                             ADDRESS OF THE MASTER CONTROL TABLE DEFINITION
*                             OF THE QUEUE BEING SERVICED (NORMAL OR PRIORITY).
*
*         CALLS  GUR, PUC.
*
          SPACE  4,10
 PUR      SUBR               ENTRY/EXIT
          LCN    0
          STML   REQTYP      SET REQUEST TYPE = UNIT
          LDML   WRRTY
          LMN    FTRY
          ZJN    PUR03       IF NOT IN RECOVERY
          LDML   NUMPRI
          ZJN    PUR20       IF NORMAL REQUEST
          UJN    PUR07       PRIORITY REQUEST

 PUR03    LDML   NUMPRI
          LMN    MAXPR
          ZJN    PUR10       IF TIME TO SERVICE NORMAL
 PUR05    LDML   CM.MCT
          ADN    /MCT/C.PRI  PRIORITY QUEUE
          IFEQ   DRTYP,1
          STDL   CM.URQ+2
          ENDIF
          IFEQ   DRTYP,2
          STDL   CM.URQ+1
          ENDIF
 PUR07    RJM    GUR         GET PRIORITY UNIT REQUEST
          NJN    PUR30       IF REQUEST FOUND
          LDN    MAXPR
          SBML   NUMPRI
          MJN    PURX        IF ONLY PRIORITY ALLOWED
 PUR10    LDML   CM.MCT
          ADN    /MCT/C.NOR  NORMAL QUEUE
          IFEQ   DRTYP,1
          STDL   CM.URQ+2    NORMAL REQUEST QUEUE
          ENDIF
          IFEQ   DRTYP,2
          STDL   CM.URQ+1
          ENDIF
 PUR20    RJM    GUR         GET NORMAL UNIT REQUEST
          ZJN    PUR60       IF NO REQUESTS
          LDN    0
          STML   NUMPRI
          IFEQ   DRTYP,1     IF MDI
          LOADF  MCT+/MCT/P.NOR+/UQD/P.TAIL   UNIT NORMAL QUEUE TAIL POINTER
          ENDIF
          IFEQ   DRTYP,2     IF ICA
          LRML   MCT+/MCT/P.NOR+/UQD/P.TAIL   UNIT NORMAL QUEUE TAIL POINTER
          LDML   MCT+/MCT/P.NOR+/UQD/P.TAIL+1
          ENDIF
          UJN    PUR40       PROCESS UNIT REQUESTS

 PUR30    LDML   WRRTY
          LMN    FTRY
          NJN    PUR35       IF IN RECOVERY
          AOML   NUMPRI
 PUR35    BSS    0
          IFEQ   DRTYP,1     IF MDI
          LOADF  MCT+/MCT/P.PRI+/UQD/P.TAIL   UNIT PRIORITY QUEUE TAIL PTR
          ENDIF
          IFEQ   DRTYP,2     IF ICA
          LRML   MCT+/MCT/P.PRI+/UQD/P.TAIL   UNIT PRIORITY QUEUE TAIL PTR
          LDML   MCT+/MCT/P.PRI+/UQD/P.TAIL+1
          ENDIF
 PUR40    BSS    0
          IFEQ   DRTYP,1     IF MDI
          SRD    CM.QT
          STDL   CM.QT+2     UNIT QUEUE TAIL POINTER
          ENDIF
          IFEQ   DRTYP,2     IF ICA
          SRDL   CM.QT
          SHN    -3
          STDL   CM.QT+1     UNIT QUEUE TAIL POINTER
          ENDIF
          RJM    PUC         PROCESS UNIT COMMAND
 PUR50    UJK    PURX        EXIT

 PUR60    LDN    MAXPR
          SBML   NUMPRI
          NJN    PUR50       IF PRIORITY SEARCHED
          STML   NUMPRI
          UJK    PUR05       TRY PRIORITY
          SPACE  4,16
**        SBL - SET BUFFER POOL DESCRIPTOR LOCK.
*
*         THIS ROUTINE INTERLOCKS THE SPECIFIED WORD IN THE
*         BUFFER POOL DESCRIPTOR.
*
*         ENTRY  (A) = ARRAY INDEX OF POOL DESCRIPTOR TO LOCK.
*
*         EXIT   (A) = 0, TO SHOW THAT THE CM WORD IS INTERLOCKED.
*
*         USES   T5, T7.
*
*         CALLS  SLR.
          SPACE  4,10
 SBL      SUBR               ENTRY/EXIT
          STDL   T5
          LDK    CM.BPD      FIRST BUFFER POOL DESCRIPTOR
          STDL   T7
          RJM    SLR         SET LOCK RESERVATION
          UJK    SBLX
          IFEQ   DRTYP,2     IF ICA
          SPACE  4,10
**        SIT - SET INCOMPLETE TRANSFER.
*
*         THIS ROUTINE SETS AN INCOMPLETE TRANSFER
*         IN THE RESPONSE.
*
*         ENTRY  (A) = OPERATION TYPE MASK.
*
*         CALLS  SSC.
          SPACE  4,10
 SIT      SUBR               ENTRY/EXIT
          STML   LRS+/RS/P.OPTP  STORE OPERATION TYPE
          LDK    /RS/K.LOF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDK    /RS/K.LSIT
          RJM    SSC         SET SYMPTOM CODE
          UJN    SITX        EXIT
          ENDIF
          SPACE  4,10
**        SIU - SET INTERMEDIATE UNRECOVERED.
*
*         THIS ROUTINE SETS THE RECOVERY STATUS INTO THE
*         RESPONSE BUFFER.  RECOVERY IS EITHER INTERMEDIATE OR
*         UNRECOVERED.
*
*         ENTRY  (A) = 0 IF UNRECOVERED ERROR.
*                    <> 0 = NUMBER OF RETRIES REMAINING.
*
*         USES   T4.
          SPACE  4,10
 SIU10    LDN    REC.I
 SIU20    STML   LRS+/RS/P.RETSUC
          LDN    FTRY
          SBDL   T4
          STML   LRS+/RS/P.RETCT  STORE RETRY COUNT

 SIU      SUBR               ENTRY/EXIT
          STDL   T4
          NJN    SIU10       IF RECOVERED
          LDN    REC.U
          UJN    SIU20       STORE UNRECOVERED ERROR
          SPACE  4,10
**        SLK - SET LOCK.
*
*         THIS ROUTINE SETS THE LOCK AT THE SPECIFIED
*         CM ADDRESS.
*
*         ENTRY  (T5) = WORD OFFSET OF LOCKWORD.
*                (T7) = CM ADDRESS OF TABLE.
*
*         EXIT   (A) = 0, IF LOCK SET.
*                (A) <> 0, IF LOCK COULD NOT BE SET.
*
*         CALLS  SLR, SLW.
          SPACE  2,10
 SLK      SUBR               ENTRY/EXIT
          RJM    SLR         SET LOCK RESERVATION
          RJM    SLW         SET LOCK WORD
          UJK    SLKX        EXIT
          SPACE  4,10
**        SLR - SET LOCK RESERVATION.
*
*         THIS ROUTINE INTERLOCKS THE COMPARE/SWAP WORD AT THE SPECIFIED
*         CM ADDRESS.  IT PLACES 0FFFFFFFF(16) IN THE UPPER PORTION OF THE
*         WORD TO RESERVE IT.
*
*         ENTRY  (T5) = WORD OFFSET OF CM WORD TO INTERLOCK.
*                (T7) = CM ADDRESS OF TABLE.
*
*         EXIT   (A) = 0, INDICATES LOCK HAS BEEN RESERVED.
*                (P1 - P4) = ORIGINAL CONTENTS OF CM WORD.
*                (T6) = (A) PORTION OF ADDRESS OF CM WORD.
*
*         USES   T1, T2, T3, T4, T5, T6, T7, T8.
*
*         MACROS LOADR.
          SPACE  2,10
 SLR      SUBR               ENTRY/EXIT
 SLR10    LDC    177777B
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          IFEQ   DRTYP,1
          LOADR  0,T7        UNIT/PP INTERFACE/ETC TABLE ADDRESS
          ENDIF
          IFEQ   DRTYP,2
          LRIL   T7
          LDML   1,T7        UNIT/PP INTERFACE/ETC TABLE ADDRESS
          ENDIF
          ADDL   T5          ADD INTERLOCK WORD OFFSET
          STDL   T6
          RDSL   T1          SET UPPER 32 BITS OF LOCK WORD TO '1'S
          LDDL   T1
          ADDL   T2
          ADC    400001B
          ZJN    SLR10       IF ANOTHER INTERLOCK OPERATION IS IN PROGRESS

*         SAVE ORIGINAL CONTENTS OF CM WORD IN (P1 - P4).

          LDN    3           STARTING (AND HIGH) OFFSET OF INTERLOCK WORD (0..3)
          STDL   T8

 SLR15    BSS    0
          LDML   T1,T8       ORIGINAL CONTENTS OF CM WORD
          STML   P1,T8
          SODL   T8          NEXT OFFSET
          PJK    SLR15       IF MORE TO DO

          LDN    0           INTERLOCK RESERVED
          UJK    SLRX        EXIT, INTERLOCK RESERVED
          SPACE  4,10
**        SLW - SET LOCK WORD.
*
*         THIS ROUTINE SETS THE LOCK WORD AT THE SPECIFIED
*         CM ADDRESS.
*
*         ENTRY  (P1 - P4) = ORIGINAL CONTENTS OF LOCK.
*                (R) = R-REGISTER PORTION OF LOCK ADDRESS.
*                (T1 - T4) = ORIGINAL CONTENTS OF LOCK.
*                (T6) = A-REGISTER PORTION OF LOCK ADDRESS (LOCK OFFSET).
*
*         EXIT   (A) = 0, IF LOCK SET.
*                (A) <> 0, IF LOCK COULD NOT BE SET.
*                (P1 - P4) = ORIGINAL CONTENTS OF LOCK.
*
*         USES   T1, T2, T3, T4, T6.
          SPACE  2,10
 SLW      SUBR               ENTRY/EXIT
          LDDL   T1
          SHN    17-15
          MJN    SLW20       IF INTERLOCK ALREADY SET (RESTORE WORD)
          LDC    100000B
          RADL   T1          SET INTERLOCK BIT
          LDDL   PPNO        PP NUMBER
          STDL   T4

 SLW20    LDDL   T6
          ADC    400000B
          CWDL   T1          UPDATE INTERLOCK WORD
          LDDL   T4
          LMDL   PPNO        PP NUMBER

*         (A) = 0, IF THE INTERLOCK IS OWNED BY THIS PP

          UJK    SLWX        EXIT
          SPACE  4,10
**        SPL - SET PP INTERFACE QUEUE LOCK.
*
*         THIS ROUTINE SETS THE PP REQUEST QUEUE LOCK IN THE
*         PP INTERFACE TABLE.
*
*         EXIT   (A) = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    <> 0, IF LOCK COULD NOT BE SET.
*
*         USES   T5, T7.
*
*         CALLS  SLK.
 SPL      SUBR               ENTRY/EXIT
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    SLK         SET THE LOCKWORD
          UJK    SPLX
          SPACE  4,10
**        SRU - SET RECOVERED UNRECOVERED.
*
*         THIS ROUTINE SETS THE RECOVERY STATUS INTO THE
*         RESPONSE BUFFER.  RECOVERY IS EITHER RECOVERED OR
*         UNRECOVERED.
*
*         ENTRY  (A) = 0 IF UNRECOVERED ERROR.
*                    <> 0 = NUMBER OF RETRIES REMAINING.
*
*         USES   T4.
          SPACE  4,10
 SRU10    LDN    REC.R
 SRU20    STML   LRS+/RS/P.RETSUC
          LDN    FTRY
          SBDL   T4
          STML   LRS+/RS/P.RETCT  STORE RETRY COUNT

 SRU      SUBR               ENTRY/EXIT
          STDL   T4
          NJN    SRU10       IF RECOVERED
          LDN    REC.U
          UJN    SRU20       STORE UNRECOVERED ERROR
          SPACE  4,10
**        SSC - SET SYMPTOM CODE.
*
*         THIS ROUTINE SETS THE SYMPTOM CODE INTO THE
*         RESPONSE BUFFER. IF SYMPTOM CODE IS CHANNEL ERROR
*         RETURN ERROR REGISTER FROM *GERT* IN RESPONSE BUFFER.
*
*         ENTRY  (A) = VALUE TO SET INTO SYMPTOM CODE FIELD.
*                ((GERT)) = ERROR REGISTER IF CHANNEL ERROR.
*
*         USES   T9, T10.
          SPACE  4,10
 SSC      SUBR               ENTRY/EXIT
          STDL   T9
          LMC    -0
          STDL   T10
          LDML   LRS+/RS/P.LSGSE  SYMPTOM CODES
          LPDL   T10
          ADDL   T9          ADD SYMPTOM CODE
          STML   LRS+/RS/P.LSGSE
          IFEQ   DRTYP,1
          LPC    /RS/K.LSCEF
          ZJN    SSCX        IF NOT CHANNEL ERROR
          SOML   GERT
          ADN    1
          STDL   T10
          LDIL   T10         RETURN ERROR REGISTER
          STML   LRS+/RS/P.ERRW1
          ENDIF
          UJN    SSCX        EXIT
          SPACE  4,10
**        STB - SEARCH TABLE.
*
*         THIS ROUTINE WILL PERFORM A TABLE SEARCH ON
*         THE SPECIFIED TABLE.  THE TABLE MUST HAVE TWO
*         WORDS PER ENTRY.
*
*         ENTRY  (A) = ADDRESS - 2 OF TABLE TO SEARCH.
*                (STBI) = KEY FOR SEARCH.
*
*         EXIT   (A) = 0, IF NO MATCH FOUND.
*                (A) = ADDRESS OF PROCESSOR OR FUNCTION TO
*                      ISSUE TO MCI.
*
*         USES   T2.
          SPACE  4,10
 STB      SUBR               ENTRY/EXIT
          STDL   T2
 STB10    LDN    2
          RADL   T2
          LDIL   T2          GET NEXT ENTRY
          ZJN    STBX        IF END OF TABLE
          LMML   STBI
          NJN    STB10       IF NOT A MATCH
          AODL   T2
          LDIL   T2          GET FUNCTION CODE OR PROCESSOR ADDRESS
          UJK    STBX        EXIT WITH ADDRESS
          SPACE  4,10
**        STR - SEND TERMINATION RESPONSE.
*
*         THIS ROUTINE TERMINATES A PERIPHERAL REQUEST BY SENDING
*         A SOLICITED RESPONSE AND DELINKING THE REQUEST.
*
*         CALLS  DLR, PRC, UIP, WRB, ZRE.
          SPACE  4,10
 STR      SUBR               ENTRY/EXIT
          RJM    PRC         PUT RESPONSE CODES IN RESPONSE
          LDC    RS          RESPONSE BUFFER
          RJM    WRB         WRITE RESPONSE BUFFER
          RJM    DLR         DELINK REQUEST
          RJM    UIP         UPDATE IN POINTER
          RJM    ZRE         ZERO OUT RESPONSE BUFFER
          UJN    STRX        RETURN
          SPACE  4,10
**        USR - SEND UNSOLICITED RESPONSE.
*
*         THIS ROUTINE SENDS AN UNSOLICITED RESPONSE TO THE CP.
*
*         CALLS  PRC, UIP,WRB, ZRE.
          SPACE  4,10
 USR      SUBR               ENTRY/EXIT
          LDN    R.UNS
          STDL   RESPC       UNSOLICITED RESPONSE
          RJM    PRC         PUT RESPONSE CODES IN RESPONSE
          LDC    RS          RESPONSE TO WRITE
          RJM    WRB         WRITE RESPONSE BUFFER
          RJM    UIP         UPDATE IN POINTER
          RJM    ZRE         ZERO OUT RESPONSE BUFFER
          UJK    USRX        EXIT
          SPACE  4,10
**        ZRE - ZERO OUT RESPONSE BUFFER.
*
*         USES   T1.
          SPACE  4,10
 ZRE      SUBR               ENTRY/EXIT
          LDN    0
          STDL   UNSC        UNSOLICITED RESPONSE CODE
          STML   IERC        INTERFACE ERROR CODE
          STML   ABSC        ABNORMAL STATUS CODE
          STML   RCON        RESPONSE CONDITION
          LDK    MAXRS*4     MAX RESPONSE BUFFER SIZE (PP WORDS)
          STDL   T1
 ZRE10    LDN    0
          STML   RS-1,T1     ZERO OUT RESPONSE BUFFER
          SODL   T1
          NJN    ZRE10
          LDN    /RS/C.XFER*8+8  SET RESPONSE LENGTH FOR NORMAL RESPONSE
          STML   RS+/RS/P.RESPL
          LDML   UNIT
          STML   RS+/RS/P.LU  SET UP LOGICAL UNIT NUMBER
          LDN    R.NRM       SET RESPONSE CODE = NORMAL
          STDL   RESPC
          SHN    16-/RS/N.RC-/RS/L.RC
          STML   RS+/RS/P.RC  PUT RESPONSE CODE IN RESPONSE
          LDML   DEVID
          STML   RS+/RS/P.DEVID
          UJK    ZREX
          SPACE  4,10
          IFEQ   BRK,1
          SPACE  4,10
*         BKP - ROUTINE TO DYNAMICALLY SET UP BREAK POINTS IN PP ROUTINE
*
*         THIS ROUTINE USES 20 CM WORDS IN THE NETWORK WIRED
*         SEGMENT, POINTED TO BY  NAV$NETWORK_PP_BKPT_AREA
*
*         TO OBTAIN THE RMA OF THIS BUFFER TYPE IN THE FOLLOWING
*                SYSDEBUG 0
*                DISOSS NAV$NETWORK_PP_BKPT_AREA
*                DM   (PVA RETURNED FROM DISOSS)
*                RUN
*         THEN THE FOLLOWING MDD COMMANDS:
*                DM (PVA RETURNED FROM DM ABOVE) MPS
*                DB
*         FOR EXAMPLE PURPOSES ASSUME RMA = 22A080(16).
*
*         22A080(16) = 16/BKP SWITCH, 48/0.
*                          1= BREAKPOINTING ON.
*         22A088(16) = 16/FNC CODE, 32/A REGISTER, 16/P REGISTER.
*
*         FOUR DIFFERENT FUNCTIONS CAN BE CALLED
*
*                0 - END THIS BREAKPOINT
*
*                1 - WAIT MODE, PP WILL LOOP UNTIL FUNCTION CODE IS
*                    CHANGED
*
*                2 - READ PP MEMORY, BYTES 0 AND 1 OF WORD 22A090(16) CONTAIN
*                    STARTING ADDRESS FOR READING. *BALEN* - 3 IS THE NUMBER
*                    OF CM WORDS TO READ INTO THE BUFFER STARTING AT
*                    WORD 22A098(16). AFTER READ IT WILL GO INTO WAIT MODE.
*
*                3 - CHANGE PP MEMORY, BYTES 2 AND 3 OF WORD 22A090(16) CONTAIN
*                    PP ADDRESS TO CHANGE CONTENTS OF. WORD 22A090(16),
*                    BYTES 4 AND 5 HOLD NEW CONTENTS OF THAT ADDRESS.
*                    AFTER WRITE GOES INTO WAIT MODE.
*
*                4 - SET BREAKPOINT, WORD 22A090(16), BYTES 6 AND 7 CONTAIN
*                    PP ADDRESS AT WHICH TO SET BREAKPOINT.
*                    AFTER THIS YOU ARE IN WAIT MODE.
*
*                ANY FUNCTION CODE GREATER THAN 4 PUTS YOU IN
*                WAIT MODE.
*
          SPACE  4
 BKP      SUBR
          STML   TEMP+2            SAVE A REGISTER
          STML   TSAV4
          SHN    -16
          STML   TEMP+1
          STML   TSAV3
          LDN    1
          STML   TEMP              SET INITIAL FUNCTION = WAIT
          LDML   BKP
          SBN    2
          STML   TEMP+3            CURRENT VALUE OF P REGISTER
          STML   BKP1
          STML   BKP19
          ADN    1
          STML   BKP2
          LDML   BKPFLG
          NJN    BKP.1
          LDML   BKP19
          ADN    2
          STML   BKP19
          UJN    BKP2.1
 BKP.1    LDN    0
          STML   BKPFLG
          LDML   TSAV1             RESTORE BREAK POINTED INSTRUCTIONS
          STML   **
 BKP1     EQU    *-1
          LDML   TSAV2
          STML   **
 BKP2     EQU    *-1
 BKP2.1   LOADF  BRMA
          ADN    1
          CWML   TEMP,ONE          WRITE OUT CT. WORD 1
 BKP3     LOADF  BRMA
          ADN    1
          CRML   TEMP,ONE          READ CT. WORD 1
          LDML   TEMP              CHECK FUNCTION CODE
          NJN    BKP3.1            IF NOT END FUNCTION
          LJM    BKP18             TERMINATE THIS BREAK POINT

 BKP3.1   SBN    1
          ZJN    BKP3              IF FUNCTION = WAIT (1)
          SBN    1
          ZJN    BKP4        IF DISPLAY MEMORY FUNCTION
          UJK    BKP8

*         FUNCTION CODE 2 - READ PP MEMORY
 BKP4     LOADF  BRMA
          ADN    2
          CRML   TEMPA,ONE
          LDML   TEMPA             FWA IN PP MEMORY
          STML   BKP5
          LDML   BALEN       NUMBER OF WORDS TO READ
          SBN    3
          STDL   ONE
          LOADF  BRMA
          ADN    3
          CWML   BKP5,ONE
 BKP5     EQU    *-1
          LDN    1
          STDL   ONE         RESTORE ONE
 BKP6     LDN    1                 SET FUNCTION CODE = WAIT
          STML   TEMP
          LOADF  BRMA
          ADN    1
          CWML   TEMP,ONE
          LJM    BKP3

 BKP8     SBN    1
          NJN    BKP12             IF NOT CHANGE MEMORY FUNCTION
*         FUNCTION CODE 3 - CHANGE PP MEMORY
          LOADF  BRMA
          ADN    2
          CRML   TEMPA,ONE
          LDML   TEMPA+1           FIRST LOCATION TO BE CHANGED
          STML   BKP10
          LDML   TEMPA+2           NEW CONTENTS
          STML   **
 BKP10    EQU    *-1
          UJN    BKP6
 BKP12    SBN    1
          NJN    BKP6              IF NOT SET BKP FUNCTION
*         FUNCTION CODE 4 - SET BREAKPOINT
          LOADF  BRMA
          ADN    2
          CRML   TEMPA,ONE
          LDML   TEMPA+3
          STML   BKP14
          STML   BKP16
          ADN    1
          STML   BKP15
          STML   BKP17
          LDML   **
 BKP14    EQU    *-1
          STML   TSAV1
          LDML   **
 BKP15    EQU    *-1
          STML   TSAV2
          LDC    0200B
          STML   **
 BKP16    EQU    *-1
          LDC    BKP
          STML   **
 BKP17    EQU    *-1
          LDN    1
          STML   BKPFLG
          LJM    BKP6
 BKP18    LDML   TSAV3
          SHN    16
          ADML   TSAV4       RESTORE A REGISTER
          LJM    **
 BKP19    EQU    *-1
*
 TSAV1    BSSZ   1
 TSAV2    BSSZ   1
 TSAV3    BSSZ   1
 TSAV4    BSSZ   1
 BKPFLG   BSSZ   1
 BALEN    BSSZ   1           BREAKPOINT AREA LENGTH
 TEMP     BSSZ   4
 TEMPA    BSSZ   4
 BRMA     CON    45B
 BRMA1    CON    20200B
 SBKP     CON    7777B
          SPACE  4,10
 BKPM     SUBR
          LDML   SBKP
          NJN    BKPMX       IF SEGMENT NOT INITIALIZED
          LDML   BKPFLG
          NJN    BKPMX             IF BKP ALREADY SET
          LOADF  BRMA
          CRML   TEMPA,ONE
          LDML   TEMPA
          ZJN    BKPMX
          RJM    BKP
          UJN    BKPMX
          ENDIF
*DECK DECK=NAK$AM_KEYPOINTS_JOB_MODE EXPAND=FALSE
{ This common decks contains the keypoints used by Application/Connection
{ mgmt code.  The sub keypoints defined under a reserved value have to match
{ the corresponding constants e.g 8.1 corresponds to the 'am_poll_connections'
{ constant which is defined to be 1. These constants are also referenced by the
{ corresponding modules.


  CONST

{ The following keypoints are used by nam$application_event_processor.

    nak$application_event_processor = nak$job_base + 91,
    {E 8.0 'nap$process_connect_indication'}
    {X 8.0 'nap$process_connect_indication'}
    {E 8.1 'nap$am_poll_connections'}
    {X 8.1 'nap$am_poll_connections'}
    {E 8.2 'initiate_new_dialogs'}
    {X 8.2 'initiate_new_dialogs'}

{ The following keypoints are used by nam$internal_connection_mgmt.

    nak$internal_connection_mgmt = nak$job_base + 92,
    {E 8.0 'nap$check_connection'}
    {X 8.0 'nap$check_connection'}
    {E 8.1 'nap$check_switch_accept'}
    {X 8.1 'nap$check_switch_accept'}
    {E 8.2 'nap$check_switch_offer'}
    {X 8.2 'nap$check_switch_offer'}
    {E 8.3 'nap$monitor_server_connections'}
    {X 8.3 'nap$monitor_server_connections'}
    {E 8.4 'nap$process_task_termination'}
    {X 8.4 'nap$process_task_termination'}
    {E 8.5 'nap$remove_network_waits'}
    {X 8.5 'nap$remove_network_waits'}
    {E 8.6 'nlp$accept_switch_offer'}
    {X 8.6 'nlp$accept_switch_offer'}
    {E 8.7 'nlp$acquire_connection'}
    {X 8.7 'nlp$acquire_connection'}
    {E 8.8 'nlp$cancel_switch_offer'}
    {X 8.8 'nlp$cancel_switch_offer'}
    {E 8.9 'nlp$offer_connection_switch'}
    {X 8.9 'nlp$offer_connection_switch'}
    {E 8.10 'nlp$request_connection'}
    {X 8.10 'nlp$request_connection'}
    {E 8.11 'nap$begin_directory_search'}
    {X 8.11 'nap$begin_directory_search'}
    {E 8.12 'nap$end_directory_search'}
    {X 8.12 'nap$end_directory_search'}

{ The following keypoints are used by nam$application_management.

  nak$application_management = nak$job_base + 93;
    {E 8.0 'nap$attach_server_application'}
    {X 8.0 'nap$attach_server_application'}
    {E 8.1 'nap$detach_server_application'}
    {X 8.1 'nap$detach_server_application'}
    {E 8.2 'nap$delete_connection'}
    {X 8.2 'nap$delete_connection'}
    {E 8.3 'nap$process_job_termination'}
    {X 8.3 'nap$process_job_termination'}
    {E 8.4 'nap$add_server_title'}
    {X 8.4 'nap$add_server_title'}
    {E 8.5 'nap$delete_server_title'}
    {X 8.5 'nap$delete_server_title'}

*copyc amk$base_keypoint_values
*DECK DECK=NAK$CN_KEYPOINTS_JOB_MODE EXPAND=FALSE
 CONST
    nak$add_buffer_pools = nak$job_base + 0,
    {E 'nap$add_buffer_pools'}
    {X 'nap$add_buffer_pools'}

    nak$get_received_messages = nak$job_base + 1,
    {E 'nap$get_received_messages'}
    {X 'nap$get_received_messages'}

    nak$get_sent_messages = nak$job_base + 2,
    {E 'nap$get_sent_messages'}
    {X 'nap$get_sent_messages' 'count' I20}

    nak$send_channelnet_packet = nak$job_base + 3,
    {E 'nap$send_channelnet_packet'}
    {X 'nap$send_channelnet_packet'}

    nak$request_queue_locked = nak$job_base + 4,
    {D 'request_queue_locked'}

    nak$define_buffer_pools = nak$job_base + 5,
    {E 'nap$define_buffer_pools'}
    {X 'nap$define_buffer_pools'}

    nak$cn_unable_to_lock_table = nak$job_base + 6,
    {D 'unable_to_lock_table'}

    nak$cn_flag_handler = nak$job_base + 7,
    {E 'nap$cn_flag_handler'}
    {X 'nap$cn_flag_handler'}

    nak$cn_signal_handler = nak$job_base + 8,
    {E 'nap$cn_signal_handler'}
    {X 'nap$cn_signal_handler'}

    nak$cn_open_sap = nak$job_base + 9,
    {E 'nlp$cn_open_sap'}
    {X 'nlp$cn_open_sap'}

    nak$cn_sap_already_open = nak$job_base + 10,
    {D 'cn_sap_already_open' 'sap_id' H20}

    nak$cn_active_sap_list_full = nak$job_base + 11,
    {U 'cn_sap_list_full'}

    nak$cn_close_sap = nak$job_base + 12,
    {E 'nlp$cn_close_sap'}
    {X 'nlp$cn_close_sap'}

    nak$cn_sap_already_closed = nak$job_base + 13,
    {U 'cn_sap_already_closed' 'sap_id' H20}

    nak$cn_send_datagram = nak$job_base + 14,
    {E 'nlp$cn_send_datagram' 'sap_id' H20}
    {X 'nlp$cn_send_datagram'}

    nak$cn_max_length_exceeded = nak$job_base + 15,
    {U 'max_length_exceeded'}

    nak$cn_not_configured = nak$job_base + 16,
    {U 'cn_not_configured' 'network' I20}

    nak$cn_deliver_event = nak$job_base + 17,
    {E 'deliver_cn_event'}
    {X 'deliver_cn_event'}

    nak$cn_deliver_local_event = nak$job_base + 18,
    {E 'deliver_local_cn_event'}
    {X 'deliver_local_cn_event'}

    nak$cn_unknown_source = nak$job_base + 19,
    {U 'cn_pdu_from_unknown_source' 'systemid' H20}

    nak$replenish_buffer_pools = nak$job_base + 20,
    {E 'replenish_buffer_pools'}
    {X 'replenish_buffer_pools'}

    nak$replenish_count = nak$job_base + 21,
    {D 'buffers_added' 'count' I20}

    nak$deliver_received_messages = nak$job_base + 22,
    {E 'cn_deliver_received_messages'}
    {X 'cn_deliver_received_messages'}

    nak$release_incomplete_message = nak$job_base + 23,
    {E 'cn_release_incomplete_message'}
    {X 'cn_release_incomplete_message'}

    nak$cn_invalid_pdu = nak$job_base + 24,
    {U 'cn_invalid_pdu' 'channel' I20}

    nak$cn_limits = nak$job_base + 25;

*copyc amk$base_keypoint_values
*DECK DECK=NAK$EXTERNAL_KEYPOINTS_JOB_MODE EXPAND=FALSE
{ This common decks contains the keypoints used by Session application layer
{ code.  The sub keypoints defined under a reserved value have to match
{ the corresponding constants.

  CONST

{ The following keypoints are used by nam$se_external_interface,
{ nam$awiat_data_available, nam$se_interrupt, nam$se_receive_data,
{ nam$se_send_data, nam$se_synchronize, nam$se_synchronize_confirm,
{ and nam$store_attributes.


    nak$session_external = nak$job_base + 94;
    {E 8.0 'nap$await_data_available'}
    {X 8.0 'nap$await_data_available'}
    {E 8.1 'nap$change_attributes'}
    {X 8.1 'nap$change_attributes'}
    {E 8.2 'nap$fetch_attributes'}
    {X 8.2 'nap$fetch_attributes'}
    {E 8.3 'nap$get_attributes'}
    {X 8.3 'nap$get_attributes'}
    {E 8.4 'nap$se_interrupt'}
    {X 8.4 'nap$se_interrupt'}
    {E 8.5 'nap$se_receive_data'}
    {X 8.5 'nap$se_receive_data'}
    {E 8.6 'nap$se_send_data'}
    {X 8.6 'nap$se_send_data'}
    {E 8.7 'nap$se_synchronize'}
    {X 8.7 'nap$se_synchronize'}
    {E 8.8 'nap$se_synchronize_confirm'}
    {X 8.8 'nap$se_synchronize_confirm'}
    {E 8.9 'nap$store_attributes'}
    {X 8.9 'nap$store_attributes'}
    {E 8.10 'nap$se_get_available_byte_count'}
    {X 8.10 'nap$se_get_available_byte_count'}

*copyc amk$base_keypoint_values
*DECK DECK=NAK$ILMT_KEYPOINTS_JOB_MODE EXPAND=FALSE
{ This common decks contains the keypoints used by Intranet Layer Mgmt code.
{ The sub keypoints defined under a reserved value have to match
{ the corresponding constants e.g 8.1 corresponds to the 'manage_intranet_layer'
{ constant which is defined to be 1. These constants are also referenced by the
{ corresponding modules.


  CONST

{ The following keypoints are used by nam$intranet_layer_mgmt_r3.

    nak$intranet_layer_mgmt_r3 = nak$job_base + 95,
    {E 8.0 'nap$manage_intranet_layer'}
    {X 8.0 'nap$manage_intranet_layer'}
    {E 8.1 'nap$change_ica_state'}
    {X 8.1 'nap$change_ica_state'}

{ The following keypoints are used by nam$intranet_layer_mgmt_r1.

    nak$intranet_layer_mgmt_r1 = nak$job_base + 96;
    {E 8.0 'nap$queue_dump_request'}
    {X 8.0 'nap$queue_dump_request'}
    {E 8.1 'nap$flush_unit_queue'}
    {X 8.1 'nap$flush_unit_queue'}

*copyc amk$base_keypoint_values
*DECK DECK=NAK$JOB_MODE_KEYPOINTS EXPAND=FALSE
*copyc nak$cn_keypoints_job_mode
*copyc nak$am_keypoints_job_mode
*copyc nak$external_keypoints_job_mode
*copyc nak$ilmt_keypoints_job_mode
*DECK DECK=NAK$MONITOR_MODE_KEYPOINTS EXPAND=FALSE
  CONST
    nak$network_response_processor = nak$monitor_base + 0,
     {E 'nap$network_response_processor' 'pp_no' I20}
     {X 'nap$network_response_processor'}

    nak$unsolicited_response = nak$monitor_base + 1,
     {D 'Unsolicited response from the network pp' 'response'}

    nak$normal_response = nak$monitor_base + 2,
     {D 'Normal_response from network pp' 'response'}

    nak$no_free_response = nak$monitor_base + 3,
     {U 'No free response buffer'}

    nak$pool_empty_response = nak$monitor_base + 4,
     {U 'buffer_pool_empty' 'index' I20}

    nak$mtr_request_processor = nak$monitor_base + 10,
     {E 'nap$mtr_request_processor' 'req_code'}
     {X 'nap$mtr_request_processor'}

    nak$unable_to_lock_uit = nak$monitor_base  + 11,
     {D 'Unable to lock unit i/f table'}

    nak$limit = nak$monitor_base + 24;

*copyc amk$base_keypoint_values
*DECK DECK=NAM$ACCESS_OBJECT_LIBRARY EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
MODULE nam$access_object_library;
?? TITLE := 'nam$access_object_library' ??
*copyc amp$return
*copyc clp$find_scl_proc_in_library
*copyc nae$file_access_me_conditions
*copyc osp$append_status_file
*copyc osp$set_status_abnormal
*copyc pfp$attach
*copyc pfp$convert_pft$path_to_fs_path
*copyc pmp$close_object_library
*copyc pmp$find_entry_point_in_library
*copyc pmp$find_module_in_library
*copyc pmp$get_unique_name
*copyc pmp$open_object_library


  VAR
    highest_cycle: pft$cycle_selector := [pfc$highest_cycle],
    password: pft$password := ' ',
    share_selections: pft$share_selections := [pfc$read],
    usage_selections: pft$usage_selections := [pfc$read];

?? NEWTITLE := '[XDCL] nap$open_entry_point', EJECT ??

  PROCEDURE [XDCL] nap$open_entry_point (library_path: pft$path;
        entry_point_name: pmt$program_name;
    VAR file_identifier: amt$file_identifier;
    VAR entry_point_module: ^SEQ ( * );
    VAR local_file_name: amt$local_file_name;
    VAR status: ost$status);

    VAR
      library: ^SEQ ( * ),
      name: ost$name,
      local_status: ost$status,
      module_address: pmt$object_library_address;

    status.normal := TRUE;
    pmp$get_unique_name (name, status);
      pfp$attach (name, library_path, highest_cycle, password, usage_selections, share_selections,
            pfc$no_wait, status);
      IF status.normal THEN
        pmp$open_object_library (name, file_identifier, library, status);
        IF status.normal THEN
          pmp$find_entry_point_in_library (library, entry_point_name, module_address, status);
          IF status.normal THEN
            IF module_address.kind = llc$load_module THEN
              entry_point_module := module_address.load_module;
              local_file_name := name;
            ELSE
              pmp$close_object_library (file_identifier, local_status);
              amp$return (name, local_status);
              osp$set_status_abnormal (nac$status_id, nae$ep_not_on_load_module, entry_point_name, status);
            IFEND;
          ELSE
            pmp$close_object_library (file_identifier, local_status);
            amp$return (name, local_status);
          IFEND;
        ELSE
          amp$return (name, local_status);
        IFEND;
      IFEND;

  PROCEND nap$open_entry_point;

?? OLDTITLE ??
?? TITLE := '[XDCL] nap$open_module', EJECT ??

  PROCEDURE [XDCL] nap$open_module (library_path: pft$path;
        module_name: pmt$program_name;
    VAR file_identifier: amt$file_identifier;
    VAR object_module: ^SEQ ( * );
    VAR local_file_name: amt$local_file_name;
    VAR status: ost$status);

    VAR
      library: ^SEQ ( * ),
      name: ost$name,
      local_status: ost$status,
      module_address: pmt$object_library_address;

    status.normal := TRUE;
    pmp$get_unique_name (name, status);
      pfp$attach (name, library_path, highest_cycle, password, usage_selections, share_selections,
            pfc$no_wait, status);
      IF status.normal THEN
        pmp$open_object_library (name, file_identifier, library, status);
        IF status.normal THEN
          pmp$find_module_in_library (module_name, library, module_address, status);
          IF status.normal THEN
            IF module_address.kind = llc$load_module THEN
              object_module := module_address.load_module;
              local_file_name := name;
            ELSE
              pmp$close_object_library (file_identifier, local_status);
              amp$return (name, local_status);
              osp$set_status_abnormal (nac$status_id, nae$module_not_a_load_module, module_name, status);
            IFEND;
          ELSE
            pmp$close_object_library (file_identifier, local_status);
            amp$return (name, local_status);
          IFEND;
        ELSE
          amp$return (name, local_status);
        IFEND;
      IFEND;

  PROCEND nap$open_module;

?? OLDTITLE ??
?? TITLE := '[XDCL] nap$open_procedure', EJECT ??

  PROCEDURE [XDCL] nap$open_procedure (library_path: pft$path;
        procedure_name: ost$name;
    VAR file_identifier: amt$file_identifier;
    VAR scl_procedure: ^clt$scl_procedure;
    VAR local_file_name: amt$local_file_name;
    VAR status: ost$status);

    VAR
      library: ^SEQ ( * ),
      library_path_string: fst$path,
      library_path_size: fst$path_size,
      local_status: ost$status,
      name: ost$name;

    status.normal := TRUE;
    pmp$get_unique_name (name, status);
      pfp$attach (name, library_path, highest_cycle, password, usage_selections, share_selections,
            pfc$no_wait, status);
      IF status.normal THEN
        pmp$open_object_library (name, file_identifier, library, status);
        IF status.normal THEN
          clp$find_scl_proc_in_library (library, name, procedure_name, scl_procedure, status);
          IF status.normal THEN
            IF scl_procedure <> NIL THEN
              local_file_name := name;
            ELSE
              pmp$close_object_library (file_identifier, local_status);
              amp$return (name, local_status);
              pfp$convert_pft$path_to_fs_path (library_path, library_path_string, library_path_size);
              osp$set_status_abnormal (nac$status_id, nae$procedure_not_on_library, procedure_name, status);
              osp$append_status_file (osc$status_parameter_delimiter,
                    library_path_string(1, library_path_size), status);
            IFEND;
          ELSE
              pmp$close_object_library (file_identifier, local_status);
              amp$return (name, local_status);
          IFEND;
        ELSE
          amp$return (name, local_status);
        IFEND;
      IFEND;

  PROCEND nap$open_procedure;

?? OLDTITLE ??
MODEND nam$access_object_library;
*DECK DECK=NAM$AM_STATIC_DATA EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NAM$AM_STATIC_DATA', EJECT ??
MODULE nam$am_static_data;
{ This module contains the static data needed by application/connection mgmt.
*copyc nat$assigned_sap_list
*copyc nat$client_attributes
*copyc nat$server_attributes
*copyc nat$tcpip_attributes
*copyc nat$switched_connection
*copyc ost$date_time
?? TITLE := 'XDCLd VARIABLES', EJECT ??
*copyc oss$network_paged
  VAR
    nav$application_mgmt_taskid: [XDCL, #GATE,oss$network_paged] ost$global_task_id,
    nav$assigned_sap_list: [XDCL, #GATE, oss$network_paged] nat$assigned_sap_list :=
          [[0], [REP ((nlc$ta_max_rsvd_se_session_sap - nlc$ta_min_rsvd_se_session_sap) + 1) of
          nac$unassigned], nlc$ta_min_se_session_sap - 1, [REP 4096 of nac$unassigned]],
    nav$tcpip_attributes_list: [XDCL, #GATE, oss$network_paged]
      nat$tcpip_attributes_control := [[0,FALSE,0],NIL],
    nav$server_attributes_list: [XDCL, #GATE, oss$network_paged]
      nat$server_attributes_control := [[0,FALSE,0],NIL],
    nav$client_attributes_list: [XDCL, #GATE, oss$network_paged]
      nat$client_attributes_control := [[0,FALSE,0],NIL],
    nav$switched_connections_list: [XDCL, #GATE, oss$network_paged]
      nat$switched_connections_list := [[0,FALSE,0],NIL,NIL],
    nav$appl_defn_time_stamp: [XDCL, #GATE, oss$network_paged] ost$date_time,
    nav$applications_installed: [XDCL, #GATE, oss$network_paged] boolean := FALSE;

  MODEND nam$am_static_data;
*DECK DECK=NAM$APPLICATION_EVENT_PROCESSOR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network_access: Application Event Processor' ??
?? NEWTITLE := 'Type Definitions' ??
MODULE nam$application_event_processor;

  TYPE
    am_login_specification = (am_incomplete, am_via_string, am_via_parameters),
    am_client_validation_kind = (am_client_dialog, am_remote_attach_job),
    am_remote_attach_job_state = (am_validate_job, am_connection_switch_offered,
          am_server_inactive, am_validation_failed, am_switch_failed, am_signal_failed),

    am_received_connections_list = record
      fill: 0 .. 0ffff(16),
      received_connection: ^am_received_connection_attr,
    recend,

    am_received_connection_attr = record
      next_entry: ^am_received_connection_attr,
      server: nat$application_name,
      server_job_validation_source: nat$server_validation_source,
      activity_stamp: integer,
      connection_id: nat$connection_id,
      network_file_name: amt$local_file_name,
      peer_accounting_info_length: nat$data_length,
      peer_accounting_info: SEQ (REP jmc$job_input_device_size of cell),
      CASE client_validation_kind: am_client_validation_kind OF
      = am_client_dialog =
        terminal_file_name: amt$local_file_name,
        file_id: amt$file_identifier,
        retry_count: 0 .. 0ff(16),
        last_prompt: nat$am_login_prompt,
        login_parameters: am_login_parameters,
        login_string: ^SEQ ( * ),
        prompt_user: boolean,
        send_previous_prompt: boolean,
      = am_remote_attach_job =
        state: am_remote_attach_job_state,
        service_data_ii_length: nat$data_length,
        service_data_ii: string (128),
      CASEND,
    recend,

    am_login_parameters = record
      retry_count_for_login_prompt: 0 .. 0ff(16),
      user_name: ost$user_name,
      password: ost$name,
      family_name: ost$family_name,
      account_name: avt$account_name,
      project_name: avt$project_name,
    recend,

    osi_nsap_address = record
      subnetwork: 0 .. 0ffff(16),
      system: 0 .. 0ffffffffffff(16),
      nsap: 0 .. 0ff(16),
    recend,

    cdna_system_id = packed record
      prefix: 0 .. 0ffffff(16),
      system_type: 0 .. 3,
      cpu_0_model_number: 0 .. 0ff(16),
      cpu_0_serial_number: 0 .. 3fff(16),
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc avt$validation_items
*copyc clc$standard_file_names
*copyc cld$parameter_limits
*copyc cld$parameter_list
*copyc cld$value
*copyc cle$ecc_command_processing
*copyc clt$command_line_size
*copyc clt$line_layout
*copyc ife$error_codes
*copyc ift$format_effectors
*copyc ift$connection_attributes
*copyc jmt$job_class_name
*copyc jmt$job_submission_options
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc nac$application_catalog_layout
*copyc nac$statistics_codes
*copyc nae$application_interfaces
*copyc nae$application_management
*copyc nae$client_validation_dialog
*copyc nak$am_keypoints_job_mode
*copyc nat$am_keypoint_constants
*copyc nat$am_login_prompt
*copyc nat$create_attributes
*copyc nat$network_address
*copyc nat$number_of_connections
*copyc nat$protocol
*copyc nat$sap_identifier
*copyc nat$server_attributes
*copyc nlt$cl_connection
*copyc nlt$ta_sap_selector
*copyc osc$timesharing
*copyc osd$unique_name
*copyc ost$max_status_message_line
*copyc ost$status_message
*copyc ost$status_message_header_kind
*copyc ost$status_message_level
*copyc ost$system_flag
*copyc ost$user_identification
*copyc pmt$program_parameters
?? POP ??
?? OLDTITLE ??
?? NEWTITLE := 'XREF Procedures', EJECT ??
*copyc amp$flush
*copyc amp$get_next
*copyc amp$put_next
*copyc amp$put_partial
*copyc amp$return
*copyc avp$prevalidate_job
*copyc clp$get_login_data_for_nam
*copyc clp$pop_parameters
*copyc clp$push_parameters
*copyc clp$trimmed_string_size
*copyc clp$validate_name
*copyc fsp$close_file
*copyc fsp$open_file
*copyc i#move
*copyc iip$direct_store_trm_conn_atts
*copyc ifp$suppress_cursor_pos_echoplx
*copyc jmp$get_attribute_defaults
*copyc jmp$signal_pair_connect_target
*copyc jmp$submit_job
*copyc jmp$validate_paired_connection
*copyc nap$cancel_switch_offer
*copyc nap$create_network_file
*copyc nap$display_message
*copyc nap$find_server_attributes
*copyc nap$get_attributes
*copyc nap$parse_accounting_data
*copyc nap$offer_connection_switch
*copyc nap$remove_connection_id
*copyc nap$store_client_identity
*copyc nlp$get_exclusive_access
*copyc nlp$get_nonexclusive_access
*copyc nlp$release_exclusive_access
*copyc nlp$release_nonexclusive_access
*copyc nlp$se_accept_connection
*copyc osp$format_multi_part_message
*copyc osp$i_await_activity_completion
*copyc osp$output_status_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pfp$attach
*copyc pmp$generate_unique_name
*copyc pmp$get_executing_task_gtid
*copyc pmp$log_ascii
*copyc pmp$wait
*copyc pmp$ready_task
*copyc rmp$request_terminal
*copyc sfp$emit_statistic
?? OLDTITLE ??
?? NEWTITLE := 'Global Variables', EJECT ??
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc osv$task_private_heap
*copyc osv$task_shared_heap
*copyc jmv$executing_within_system_job
*copyc nav$application_mgmt_taskid
*copyc nav$final_login_prompt
*copyc nav$force_password_prompt
*copyc nav$maximum_login_attempts
*copyc nav$network_paged_heap
*copyc nav$prompt_for_account
*copyc nav$prompt_for_family_name
*copyc nav$prompt_for_project
*copyc nav$server_attributes_list

  VAR
    nav$received_connections_list: [XDCL, oss$task_shared] am_received_connections_list := [0, NIL];

  VAR
    connections_in_dialog: ^am_received_connection_attr := NIL,
    am_login_template: [READ, STATIC, oss$job_paged_literal] am_login_parameters :=
          [0, osc$null_name, osc$null_name, osc$null_name, osc$null_name, osc$null_name],
    final_login_prompt: nat$am_login_prompt,
    formatted_prompt: array [nat$am_login_prompt] of ^string ( * ),
    include_prompt: array [nat$am_login_prompt] of boolean := [ * , TRUE, TRUE, * , * , * ],
    raw_prompt: [READ, STATIC, oss$job_paged_literal] array [nat$am_login_prompt] of
          ost$status_condition := [nae$login_banner, nae$user_prompt, nae$password_prompt, nae$family_prompt,
          nae$account_prompt, nae$project_prompt];

  VAR
    login_blank_overwrite: [READ, oss$job_paged_literal] string (overwrite_pattern_size) := ' ',
    login_overwrite_pattern: [READ, oss$job_paged_literal] string (overwrite_pattern_size + 2) :=
          'HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI#HI';

  CONST
    suppress_cursor_positioning = TRUE,
    suppress_echoplex = TRUE,
    overwrite_pattern_size = 3 * 30, {Must be a multiple of 3.}
    max_job_submission_options = 11;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$find_sap_priority', EJECT ??

  PROCEDURE [XDCL] nap$find_sap_priority
    (    sap_id: nat$sap_identifier;
     VAR priority: nat$network_message_priority);


{ This procedure executes in the system task.
{ This procedure will be called by the session internal
{ interface when an osi transport connect indication
{ occurs.

    VAR
      server_attributes: ^nat$server_attributes;

    nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
    get_server_attributes (sap_id, server_attributes);
    IF server_attributes <> NIL THEN
      priority := server_attributes^.message_priority;
    ELSE
      priority := nac$default_message_priority;
    IFEND;
    nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
  PROCEND nap$find_sap_priority;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$process_connect_indication', EJECT ??

  PROCEDURE [XDCL] nap$process_connect_indication
    (    sap_id: nat$sap_identifier;
         connection_id: nat$connection_id;
         cl_connection: ^nlt$cl_connection;
         source_address: nat$network_address;
     VAR server: nat$application_name;
     VAR protocol: nat$protocol;
     VAR status: ost$status);


{ This procedure executes in the system task. This is the event handler that
{ is invoked whenever a sap event is received by the underlying layer.
{ If the received connection is to be validated on behalf of the application,
{ the connection is assigned to the application mgmt task. Otherwise the
{ connection is assigned to the server job. A new job is  initiated if the
{ existing server jobs are unable to acquire more connections.
{ NOTE the parameter SERVER is set even if the status returned is abnormal.
{ The exception is if the server_attributes is NIL i.e. the connect event
{ is for an unknown server.

    VAR
      actual_access_control: am_received_connections_list,
      client_addresses: ^array [1 .. * ] of nat$client_address,
      client_system: cdna_system_id,
      cs_status: osc$cs_successful .. osc$cs_variable_locked,
      i: integer,
      new_access_control: am_received_connections_list,
      nsap_address: ^osi_nsap_address,
      nsap_address_prefix: ^SEQ ( * ),
      original_access_control: am_received_connections_list,
      osi_network_address: ^SEQ ( * ),
      received_connection: ^am_received_connection_attr,
      server_attributes: ^nat$server_attributes,
      server_connection: ^nat$server_connection_attribute,
      tsap_selector: nlt$ta_sap_selector,
      valid_client_address: boolean;


    status.normal := TRUE;
    #KEYPOINT (osk$entry, osk$m * amk_process_connect_indication, nak$application_event_processor);
    nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
    get_server_attributes (sap_id, server_attributes);
    IF (server_attributes = NIL) THEN { SAP may have been deactivated.
      osp$set_status_condition (nae$application_inactive, status);
      protocol := nac$cdna_virtual_terminal;
    ELSE
      nlp$get_exclusive_access (server_attributes^.access_control);
      server := server_attributes^.server;
      protocol := server_attributes^.protocol;
      IF server_attributes^.server_status = nac$application_inactive THEN
        osp$set_status_abnormal (nac$status_id, nae$application_inactive, server_attributes^.server, status);
      ELSE
        server_attributes^.attempted_connection_count := server_attributes^.
              attempted_connection_count + 1;
        IF server_attributes^.connection_count >= server_attributes^.max_connections THEN
          server_attributes^.rejected_connection_attempts := server_attributes^.
                rejected_connection_attempts + 1;
          osp$set_status_abnormal (nac$status_id, nae$application_max_conn_limit, server_attributes^.server,
                status);
        ELSE
          valid_client_address := TRUE;

          IF source_address.kind = nac$osi_transport_address THEN
            IF server_attributes^.client_addresses <> NIL THEN
              valid_client_address := FALSE;
              client_addresses := server_attributes^.client_addresses;
              osi_network_address := ^source_address.osi_transport_address.network_address;
              RESET osi_network_address;
              IF source_address.osi_transport_address.network_address_length > #SIZE (osi_nsap_address) THEN
                NEXT nsap_address_prefix: [[REP (source_address.osi_transport_address.
                      network_address_length - #SIZE (osi_nsap_address)) OF cell]] IN osi_network_address;
              IFEND;
              NEXT nsap_address IN osi_network_address;
              IF nsap_address <> NIL THEN
                #UNCHECKED_CONVERSION (nsap_address^.system, client_system);
                IF source_address.osi_transport_address.transport_sap_selector_length =
                      #SIZE (tsap_selector) THEN
                  #UNCHECKED_CONVERSION (source_address.osi_transport_address.
                        transport_sap_selector (1, #SIZE (tsap_selector)), tsap_selector);
                ELSE
                  tsap_selector := 0;
                IFEND;

              /match_client_address/
                FOR i := 1 TO UPPERBOUND (client_addresses^) DO
                  IF (((client_addresses^ [i].network_id = 0) OR
                        (client_addresses^ [i].network_id = nsap_address^.subnetwork)) AND
                        ((NOT client_addresses^ [i].reserved_application_id) OR
                        (client_addresses^ [i].application_id = tsap_selector))) THEN
                    CASE client_addresses^ [i].system_kind OF
                    = nac$nosve_system_kind =
                      valid_client_address := (client_system.prefix = 080025(16) {CDC} ) AND
                            (client_system.system_type = 3 {NOS/VE system type} );
                    = nac$cdcnet_system_kind =
                      valid_client_address := (client_system.prefix = 080025(16) {CDC} ) AND
                            (client_system.system_type < 3 {CDCNET system type} );
                    = nac$any_system_kind =
                      valid_client_address := (client_addresses^ [i].system_id = 0) OR
                            (client_addresses^ [i].system_id = nsap_address^.system);
                    ELSE
                    CASEND;
                    IF valid_client_address THEN
                      EXIT /match_client_address/;
                    IFEND;
                  IFEND;
                FOREND /match_client_address/;
              IFEND;
            IFEND;
          IFEND;

          IF NOT valid_client_address THEN

{ *** DEBUG pmp$log ('AM - Connection from an invalid client address.', ignore_status);

            osp$set_status_abnormal (nac$status_id, nae$unknown_application, server, status);
          ELSE
            IF server_attributes^.accept_connection THEN
              nlp$se_accept_connection (cl_connection, {ignore} status);
              status.normal := TRUE;
            IFEND;

            IF ((server_attributes^.nam_initiated_server) AND
                  (server_attributes^.server_job_validation_source = nac$client)) OR
                  (server_attributes^.client_validation_capability <> osc$null_name) THEN
              ALLOCATE received_connection IN osv$task_shared_heap^;
              received_connection^.server := server_attributes^.server;
              received_connection^.server_job_validation_source :=
                    server_attributes^.server_job_validation_source;
              received_connection^.connection_id := connection_id;
              received_connection^.network_file_name := osc$null_name;
              received_connection^.client_validation_kind := am_client_dialog;
              received_connection^.terminal_file_name := osc$null_name;
              received_connection^.retry_count := 0;
              received_connection^.login_parameters := am_login_template;
              received_connection^.peer_accounting_info_length := 0;
              received_connection^.login_string := NIL;

              REPEAT
                ALLOCATE server_connection IN nav$network_paged_heap^;
                IF server_connection = NIL THEN
                  syp$cycle;
                IFEND;
              UNTIL server_connection <> NIL;
              server_connection^.connection_id := connection_id;
              server_connection^.connection_kind := nac$in_dialog;
              server_connection^.next_entry := server_attributes^.server_connections_list;
              server_attributes^.server_connections_list := server_connection;
              server_attributes^.connection_count := server_attributes^.connection_count + 1;

              received_connection^.activity_stamp := #FREE_RUNNING_CLOCK (0);
              received_connection^.next_entry := NIL;
              new_access_control.fill := 0;
              new_access_control.received_connection := received_connection;
              original_access_control.fill := 0;
              original_access_control.received_connection := NIL;
              REPEAT
                #COMPARE_SWAP (nav$received_connections_list, original_access_control, new_access_control,
                      actual_access_control, cs_status);
                IF cs_status = osc$cs_failed THEN
                  original_access_control := actual_access_control;
                  received_connection^.next_entry := actual_access_control.received_connection;
                IFEND;
              UNTIL (cs_status = osc$cs_successful);
              pmp$ready_task (nav$application_mgmt_taskid, {ignore} status);
              status.normal := TRUE;

{ *** DEBUG   pmp$log ('AM CONNECTION ASSIGNED TO AM TASK', ignore_status);

            ELSE
              assign_received_connection (server_attributes, connection_id, status);
              IF status.normal THEN
                server_attributes^.connection_count := server_attributes^.connection_count + 1;
              IFEND;

              IF (NOT status.normal) AND (server_attributes^.nam_initiated_server) THEN

{ *** DEBUG     pmp$log ('AM - Initiation of nam init server job failed.', ignore_status);

                osp$set_status_abnormal (nac$status_id, nae$unknown_application, server, status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
      nlp$release_exclusive_access (server_attributes^.access_control);
    IFEND;

    nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
    #KEYPOINT (osk$exit, osk$m * amk_process_connect_indication, nak$application_event_processor);

  PROCEND nap$process_connect_indication;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$am_poll_connections' ??
?? NEWTITLE := '  output_status_message', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$am_poll_connections
    (    task_parameter_list: pmt$program_parameters;
     VAR status: ost$status);

{ This procedure is the main loop in the application mgmt task.
{ All the received connections are polled for input and the received
{ login parameters are analyzed. If all the login parameters have been
{ received, the connection is assigned to a saj and is removed from
{ the received connections list. It is assumed that the client dialog
{ is done only with a terminal user. On a define server request, it needs
{ to be verified that the connection request validation or client supplied
{ validation options are selected only with cdna virtual terminal protocol.


    PROCEDURE output_message
      (    file_id: amt$file_identifier;
           message: ost$status);

{ NOTE: This procedure exists solely to conserve stack sapce.

      VAR
        ignore_status: ost$status;

      osp$output_status_message (file_id, osc$brief_message_level, osc$subdued_status_message_hdr, message,
            ignore_status);
    PROCEND output_message;
?? OLDTITLE, EJECT ??

    CONST
      long_wait = 2000000, {2000 sec}
      short_wait = 500, {1/2 sec}
      login_timeout_interval = 120000000, {2 min in usec}
      ten_minutes = 600000000; {10 min in usec}

    VAR
      byte_address: amt$file_byte_address,
      client_identity: nat$client_identity,
      connection_attribute: array [1 .. 1] of nat$get_attribute,
      connection_switch_kind: jmt$paired_connection_request,
      decrement_rec_conn_count: boolean,
      file_position: amt$file_position,
      job: jmt$system_supplied_name,
      last_login_parameters: ^SEQ ( * ),
      login_parameters: ^SEQ ( * ),
      login_specification: am_login_specification,
      new_connections_list: ^am_received_connection_attr,
      next_received_connection: ^am_received_connection_attr,
      wait_list: array [1 .. 2] OF ost$i_activity,    { nac$i_await_switch_accept
      parameter_data: SEQ (REP clc$nominal_command_line_size of cell),
      parameter_list: ^clt$parameter_list,
      parameter_list_contents: ^string ( * ),
      parameter_list_size: ^clt$command_line_size,
      previous_received_connection: ^^am_received_connection_attr,
      prompt_name: string (9),
      ready_index: integer,
      received_connection: ^am_received_connection_attr,
      re_prompt: boolean,
      retry_limit_reached: boolean,
      return_files: boolean,
      server_attributes: ^nat$server_attributes,
      server_connection: ^nat$server_connection_attribute,
      remote_attach_job: ^SEQ ( * ),
      transfer_count: amt$transfer_count,
      wait_time: integer;

    #KEYPOINT (osk$entry, osk$m * amk_poll_connections, nak$application_event_processor);
    IF NOT jmv$executing_within_system_job THEN
      RETURN;
    IFEND;

    connection_attribute [1].kind := nac$connection_state;
    pmp$get_executing_task_gtid (nav$application_mgmt_taskid);

    format_login_prompts;

    login_parameters := ^parameter_data;
    RESET login_parameters;
    NEXT parameter_list_size IN login_parameters;
    NEXT parameter_list_contents: [clc$nominal_command_line_size - #SIZE (parameter_list_size^)] IN
          login_parameters;

    WHILE TRUE DO

{ Initiate dialogs on new connections. If no connections are currently being processed, process the new
{ connections immediately.

      initiate_new_dialogs (new_connections_list);
      IF connections_in_dialog = NIL THEN
        connections_in_dialog := new_connections_list;
        new_connections_list := NIL;
      IFEND;

      wait_time := long_wait;
      received_connection := connections_in_dialog;
      previous_received_connection := ^connections_in_dialog;

    /process_connection/
      WHILE (received_connection <> NIL) DO
        wait_time := short_wait;
        CASE received_connection^.client_validation_kind OF
        = am_client_dialog =
        re_prompt := FALSE;
        return_files := FALSE;
        decrement_rec_conn_count := TRUE;
        retry_limit_reached := FALSE;

        IF received_connection^.prompt_user THEN
          prompt_user (received_connection, retry_limit_reached, {ignore} status);
          received_connection^.prompt_user := FALSE;
          login_specification := am_incomplete;
        IFEND;
        IF NOT retry_limit_reached THEN
          amp$get_next (received_connection^.file_id, parameter_list_contents,
                #SIZE (parameter_list_contents^), transfer_count, byte_address, file_position, status);

        /process_login_parameters/
          BEGIN

            IF NOT status.normal THEN
              IF (status.condition = ife$input_timeout_exceeded) OR
                    (status.condition = ife$no_data_available) THEN

{ Simulate ok status for input timeout.

                IF (received_connection^.activity_stamp + login_timeout_interval) <=
                      #FREE_RUNNING_CLOCK (0) THEN
                  osp$set_status_condition (nae$login_timeout, status);
                  output_message (received_connection^.file_id, status);
                  return_files := TRUE;

{ *** DEBUG       pmp$log ('User Login Timeout.', ignore_status);

                ELSE
                  previous_received_connection := ^received_connection^.next_entry;
                  received_connection := received_connection^.next_entry;
                IFEND;
              ELSE
                nap$display_message (status);
                return_files := TRUE;
              IFEND;
              EXIT /process_login_parameters/;
            IFEND;

            received_connection^.activity_stamp := #FREE_RUNNING_CLOCK (0);
            IF (file_position <> amc$eor) OR ((transfer_count <= 0) AND
                  ((received_connection^.last_prompt = nac$am_user_name) OR
                  (received_connection^.last_prompt = nac$am_password))) THEN

{ Re-request the input.

              amp$put_next (received_connection^.file_id, NIL, 0, byte_address, {ignore} status);
              IF received_connection^.last_prompt = nac$am_user_name THEN
                prompt_name := 'user name';
              ELSE
                prompt_name := 'password';
              IFEND;
              osp$set_status_abnormal (nac$status_id, nae$login_validation_required, prompt_name, status);
              output_message (received_connection^.file_id, status);
              IF received_connection^.login_parameters.retry_count_for_login_prompt <
                    (nav$maximum_login_attempts - 1) THEN
                osp$set_status_condition (nae$retry_login, status);
                output_message (received_connection^.file_id, status);
              IFEND;
              received_connection^.prompt_user := TRUE;
              received_connection^.send_previous_prompt := TRUE;
              CYCLE /process_connection/;
            ELSE
              IF transfer_count > 0 THEN
                extract_login_parameters (received_connection, transfer_count, login_parameters,
                      login_specification, re_prompt);
              ELSE
                IF received_connection^.last_prompt = final_login_prompt THEN
                  login_specification := am_via_parameters;
                IFEND;
              IFEND;

              IF login_specification <> am_incomplete THEN
                amp$flush (received_connection^.file_id, osc$wait, {ignore} status);
                assign_validated_connection (received_connection, transfer_count, login_parameters,
                      login_specification, status);
                IF status.normal THEN

{ *** DEBUG       pmp$log ('AM LOGIN DIALOG COMPLETE', ignore_status);

                  decrement_rec_conn_count := FALSE;
                  return_files := TRUE;
                  EXIT /process_login_parameters/;
                IFEND;

                output_message (received_connection^.file_id, status);

                IF (status.condition = nae$application_inactive) THEN
                  decrement_rec_conn_count := TRUE;
                  return_files := TRUE;
                  EXIT /process_login_parameters/;
                IFEND;

{ Terminate the connection if job class limit is reached or if server is deleted.

                IF (status.condition = jme$maximum_jobs) OR (status.condition = nae$unknown_application) THEN
                  osp$set_status_condition (nae$null_message, status);
                  output_message (received_connection^.file_id, status);
                  return_files := TRUE;
                  EXIT /process_login_parameters/;
                IFEND;

                IF received_connection^.retry_count >= (nav$maximum_login_attempts - 1) THEN
                  retry_limit_reached := TRUE;
                  EXIT /process_login_parameters/;
                IFEND;

                osp$set_status_condition (nae$retry_login, status);
                output_message (received_connection^.file_id, status);
                received_connection^.login_parameters := am_login_template;
                received_connection^.last_prompt := nac$am_login_banner;
                received_connection^.retry_count := received_connection^.retry_count + 1;
                re_prompt := FALSE;
              IFEND;

{   Depending on the information received send the prompt for the next required
{   validation information;

              received_connection^.prompt_user := TRUE;
              received_connection^.send_previous_prompt := re_prompt;
              CYCLE /process_connection/;
            IFEND;

            IF NOT retry_limit_reached THEN
              previous_received_connection := ^received_connection^.next_entry;
              received_connection := received_connection^.next_entry;
            IFEND;

          END /process_login_parameters/;
        IFEND;

        IF retry_limit_reached THEN
          osp$set_status_condition (nae$retry_limit_at_login, status);
          output_message (received_connection^.file_id, status);
          IF received_connection^.login_string <> NIL THEN
            last_login_parameters := received_connection^.login_string;
          ELSE
            parameter_list_size^ := transfer_count;
            last_login_parameters := login_parameters;
          IFEND;
          report_unsuccessful_login (received_connection, last_login_parameters, login_specification);
          return_files := TRUE;
        IFEND;

        IF return_files THEN
          IF decrement_rec_conn_count THEN
            decrement_received_conn_count (received_connection^.server, received_connection^.connection_id);
          IFEND;

          fsp$close_file (received_connection^.file_id, {ignore} status);
          amp$return (received_connection^.terminal_file_name, {ignore} status);
          amp$return (received_connection^.network_file_name, {ignore} status);
          previous_received_connection^ := received_connection^.next_entry;
          next_received_connection := received_connection^.next_entry;
          IF received_connection^.login_string <> NIL THEN
            FREE received_connection^.login_string IN osv$task_shared_heap^;
          IFEND;
          FREE received_connection IN osv$task_shared_heap^;
          received_connection := next_received_connection;
        IFEND;
        status.normal := TRUE;

        = am_remote_attach_job =
          CASE received_connection^.state OF
          = am_validate_job =
            nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
            nap$find_server_attributes (received_connection^.server, server_attributes);
            IF server_attributes <> NIL THEN
              nlp$get_exclusive_access (server_attributes^.access_control);
              IF server_attributes^.server_status = nac$application_active THEN
                server_connection := server_attributes^.server_connections_list;
                WHILE (server_connection <> NIL) AND (server_connection^.connection_id <>
                      received_connection^.connection_id) DO
                  server_connection := server_connection^.next_entry;
                WHILEND;
                IF server_connection <> NIL THEN
                  server_connection^.connection_kind := nac$owned_by_server;
                IFEND;
                remote_attach_job := #SEQ (received_connection^.service_data_ii (1,
                      received_connection^.service_data_ii_length));
                RESET remote_attach_job;
                jmp$validate_paired_connection (remote_attach_job, client_identity.family,
                       client_identity.user, job, connection_switch_kind, status);
                IF status.normal THEN
                  IF connection_switch_kind = jmc$pcr_leveled_job_request THEN
                    assign_connect_for_leveled_job (received_connection, server_attributes, job);
                    nap$store_client_identity (received_connection^.connection_id, client_identity,
                          {ignore} status);
                    status.normal := TRUE;

                    amp$return (received_connection^.network_file_name, {ignore} status);
                    status.normal := TRUE;
                    previous_received_connection^ := received_connection^.next_entry;
                    next_received_connection := received_connection^.next_entry;
                    FREE received_connection IN osv$task_shared_heap^;
                    received_connection := next_received_connection;

                  ELSE
                    nap$store_client_identity (received_connection^.connection_id, client_identity,
                          {ignore} status);
                    status.normal := TRUE;
                    nap$offer_connection_switch (received_connection^.network_file_name, job, 0, status);
                    IF status.normal THEN
                      jmp$signal_pair_connect_target (job, status);
                      IF status.normal THEN
                        received_connection^.state := am_connection_switch_offered;
                      ELSE
                        nap$cancel_switch_offer (received_connection^.network_file_name, {ignore} status);
                        received_connection^.state := am_signal_failed;
                        status.normal := TRUE;
                      IFEND;
                    ELSE
                      received_connection^.state := am_switch_failed;
                    IFEND;
                    received_connection := received_connection^.next_entry;
                  IFEND;
                ELSE
                  received_connection^.state := am_validation_failed;
                  received_connection := received_connection^.next_entry;
                IFEND;
              ELSE
                received_connection^.state := am_server_inactive;
                received_connection := received_connection^.next_entry;
              IFEND;
              nlp$release_exclusive_access (server_attributes^.access_control);
            ELSE
              received_connection^.state := am_server_inactive;
              received_connection := received_connection^.next_entry;
            IFEND;
            nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);

          = am_connection_switch_offered =
            wait_list [1].activity := nac$i_await_switch_accept;
            wait_list [1].connection_file := ^received_connection^.network_file_name;
            wait_list [2].activity := osc$i_await_time;
            wait_list [2].milliseconds := 0;
            osp$i_await_activity_completion (wait_list, ready_index, status);
            IF status.normal AND (ready_index = 1) THEN
              amp$return (received_connection^.network_file_name, {ignore} status);
              status.normal := TRUE;
              previous_received_connection^ := received_connection^.next_entry;
              next_received_connection := received_connection^.next_entry;
              FREE received_connection IN osv$task_shared_heap^;
              received_connection := next_received_connection;
            ELSE
              nap$get_attributes (received_connection^.network_file_name, connection_attribute, status);
              IF NOT status.normal {AND (status.condition = nae$connection_terminated)} OR
                    (status.normal AND (connection_attribute [1].connection_state = nac$terminated)) OR
                    ((received_connection^.activity_stamp + ten_minutes) < #FREE_RUNNING_CLOCK (0)) THEN
                amp$return (received_connection^.network_file_name, {ignore} status);
                nap$cancel_switch_offer (received_connection^.network_file_name, {ignore} status);
                status.normal := TRUE;
                previous_received_connection^ := received_connection^.next_entry;
                next_received_connection := received_connection^.next_entry;
                FREE received_connection IN osv$task_shared_heap^;
                received_connection := next_received_connection;
              ELSE
                received_connection := received_connection^.next_entry;
              IFEND;
            IFEND;

          = am_server_inactive, am_validation_failed, am_switch_failed, am_signal_failed =
            nap$get_attributes (received_connection^.network_file_name, connection_attribute, status);
            IF NOT status.normal {AND (status.condition = nae$connection_terminated)} OR
                  (status.normal AND (connection_attribute [1].connection_state = nac$terminated)) OR
                  ((received_connection^.activity_stamp + ten_minutes) < #FREE_RUNNING_CLOCK (0)) THEN
              amp$return (received_connection^.network_file_name, {ignore} status);
              previous_received_connection^ := received_connection^.next_entry;
              next_received_connection := received_connection^.next_entry;
              FREE received_connection IN osv$task_shared_heap^;
              received_connection := next_received_connection;
            ELSE
              received_connection := received_connection^.next_entry;
            IFEND;
          ELSE
          CASEND;
        ELSE
        CASEND;

{ Queue the new connections at the end of the connections_in_dialog list.

        IF received_connection = NIL THEN
          previous_received_connection^ := new_connections_list;
          received_connection := new_connections_list;
          new_connections_list := NIL;
        IFEND;

      WHILEND /process_connection/;

      pmp$wait (wait_time, wait_time);
    WHILEND;
    #KEYPOINT (osk$exit, osk$m * amk_poll_connections, nak$application_event_processor);

  PROCEND nap$am_poll_connections;
?? OLDTITLE ??
?? NEWTITLE := 'assign_connect_for_leveled_job', EJECT ??

{ PURPOSE:
{   The purpose of this request is to initialize the NAM/VE structures necessary for
{   a leveled interactive job.

  PROCEDURE assign_connect_for_leveled_job
    (    received_connection: ^am_received_connection_attr;
         server_attributes: ^nat$server_attributes,
         job_name: jmt$system_supplied_name);

    VAR
      assigned_connection: ^^nat$server_connection_attribute,
      ignore_status: ost$status,
      new_assigned_connection: ^nat$server_connection_attribute,
      previous_server_connection: ^^nat$server_connection_attribute,
      previous_wait_for_connection: ^^nat$wait_for_connection,
      server_connection: ^nat$server_connection_attribute,
      server_job_attributes: ^nat$server_job_attributes,
      wait_for_connection: ^nat$wait_for_connection;


{ Add server job attributes entry.

    REPEAT
      ALLOCATE server_job_attributes IN nav$network_paged_heap^;
      IF server_job_attributes = NIL THEN
        syp$cycle;
      IFEND;
    UNTIL server_job_attributes <> NIL;

    server_job_attributes^.job_name := job_name;
    server_job_attributes^.job_status := nac$server_job_initiated;
    server_job_attributes^.time_stamp := #FREE_RUNNING_CLOCK (0);
    server_job_attributes^.max_connections_per_server_job := 0;
    server_job_attributes^.connection_count := 0;
    IF (server_attributes^.server_job_validation_source = nac$client) THEN
      server_job_attributes^.assigned_connection_count := 1;
    ELSE
      server_job_attributes^.assigned_connection_count := 0;
    IFEND;

{ Link the server_job_attributes to the server_job_list.

    server_job_attributes^.next_entry := server_attributes^.server_job_list;
    server_attributes^.server_job_list := server_job_attributes;
    server_attributes^.server_job_init_pending := FALSE;

    nap$remove_connection_id (received_connection^.network_file_name, ignore_status);
    server_job_attributes^.assigned_connection_count := server_job_attributes^.assigned_connection_count + 1;

    server_connection := server_attributes^.server_connections_list;
    previous_server_connection := ^server_attributes^.server_connections_list;
    WHILE (server_connection <> NIL) AND (server_connection^.connection_id <>
          received_connection^.connection_id) DO
      previous_server_connection := ^server_connection^.next_entry;
      server_connection := server_connection^.next_entry;
    WHILEND;
    IF server_connection <> NIL THEN

      previous_server_connection^ := server_connection^.next_entry;
      new_assigned_connection := server_connection;
    ELSE

{ Connection disconnected and has been removed from list.

      RETURN;
    IFEND;

    new_assigned_connection^.connection_kind := nac$assigned_to_job;
    new_assigned_connection^.directed_connection := TRUE;
    new_assigned_connection^.destination_job_name := job_name;
    new_assigned_connection^.terminate_connection := FALSE;
    new_assigned_connection^.time_stamp := #FREE_RUNNING_CLOCK (0);
    new_assigned_connection^.next_entry := NIL;
    assigned_connection := ^server_attributes^.assigned_connections_list;

{ Queue the new connection at the end of the assigned connections list.

    WHILE assigned_connection^ <> NIL DO
      assigned_connection := ^assigned_connection^^.next_entry;
    WHILEND;
    assigned_connection^ := new_assigned_connection;

{ Ready a waiting task.

    wait_for_connection := server_attributes^.wait_for_connection;
    previous_wait_for_connection := ^server_attributes^.wait_for_connection;

    WHILE (wait_for_connection <> NIL) AND (wait_for_connection^.job_name <> job_name) DO
      previous_wait_for_connection := ^wait_for_connection^.next_entry;
      wait_for_connection := wait_for_connection^.next_entry;
    WHILEND;

    IF wait_for_connection <> NIL THEN

 { Found the waiting_job.

      previous_wait_for_connection^ := wait_for_connection^.next_entry;
      pmp$ready_task (wait_for_connection^.task_id, ignore_status);
      FREE wait_for_connection IN nav$network_paged_heap^;
    IFEND;
  PROCEND assign_connect_for_leveled_job;
?? OLDTITLE ??
?? NEWTITLE := 'initiate_new_dialogs', EJECT ??

  PROCEDURE initiate_new_dialogs
    (VAR new_connections_list: ^am_received_connection_attr);

{ The purpose of this procedure is to acquire new connections and initiate
{ client validation. The client validation is nominally obtained via a dialog
{ with an interactive user.
{
{ However, the client validation may have been obtained on a another mainframe
{ in a cluster environment and is being passed to this mainframe via the remote
{ attach job protocol in the peer accounting and connect data. If the remote
{ attach job syntax is present, it is passed to job management for validation,
{ assuming validity the connection will be offered to the job which is the object
{ of the remote attach_job.

    CONST
      fixed_user_data_length = 114,
      paired_connection = 129,
      supported_accounting_version = 1,
      supported_user_data_version = 1,
      vtp_version_length = 2;

    TYPE
      accounting_header = record
        version: 0 .. 0ffff(16),
        caller_identifer: 0 .. 0ff(16),
      recend,

      fixed_user_data_record = record
        version: 0 .. 0ff(16),
        pad: array [1 .. (fixed_user_data_length - 1)] of 0 .. 0ff(16),
      recend;

    VAR
      access_creation_selections: [STATIC, READ, oss$job_paged_literal] array [1 .. 1] of
            fst$file_cycle_attribute := [[fsc$file_contents_and_processor, amc$list, osc$null_name]],
      access_selections: [STATIC, READ, oss$job_paged_literal] array
            [1 .. 1] of fst$attachment_option := [[fsc$access_and_share_modes,
            [fsc$specific_access_modes, [fsc$read, fsc$append, fsc$modify]], [fsc$required_share_modes]]],
      accounting: ^accounting_header,
      actual_access_control: am_received_connections_list,
      byte_address: amt$file_byte_address,
      connection_attributes: array [1 .. 1] of nat$get_attribute,
      cs_status: osc$cs_successful .. osc$cs_variable_locked,
      file_id: amt$file_identifier,
      fixed_user_data: ^fixed_user_data_record,
      interactive_tip_data_length: nat$data_length,
      interactive_tip_data: SEQ (REP 512 of cell),
      network_file_name: ost$unique_name,
      new_access_control: am_received_connections_list,
      original_access_control: am_received_connections_list,
      peer_accounting: ^SEQ (REP jmc$job_input_device_size of cell),
      peer_connect_data: ^SEQ (REP 512 of cell),
      previous_received_connection: ^^am_received_connection_attr,
      received_connection: ^am_received_connection_attr,
      received_peer_accounting: ^SEQ ( * ),
      received_peer_connect_data: ^SEQ ( * ),
      retry_limit_reached: boolean,
      service_data_ii: ^string ( * ),
      service_data_length: ^0 .. 0ff(16),
      service_data: ^string ( * ),
      status: ost$status,
      terminal_file_name: ost$unique_name,
      terminal_attributes: [STATIC, READ, oss$job_paged_literal] array [1 .. 7] of
            ift$connection_attribute := [[ifc$input_editing_mode, ifc$normal_edit], [ifc$input_timeout, TRUE],
            [ifc$input_timeout_length, 0], [ifc$input_timeout_purge, TRUE],
            [ifc$partial_char_forwarding, FALSE], [ifc$prompt_string, [1, ',']], * ],
      term_conn_attributes: array [1 .. 7] of ift$connection_attribute;

    #KEYPOINT (osk$entry, osk$m * amk_initiate_new_dialogs, nak$application_event_processor);

{ Setup the selectable prompts to be included in the login dialog.

    include_prompt [nac$am_family_name] := nav$prompt_for_family_name;
    include_prompt [nac$am_account_name] := nav$prompt_for_account;
    include_prompt [nac$am_project_name] := nav$prompt_for_project;
    final_login_prompt := nav$final_login_prompt;

{ Extract the list of new connections.

    new_access_control.fill := 0;
    new_access_control.received_connection := NIL;
    original_access_control := new_access_control;
    REPEAT
      #COMPARE_SWAP (nav$received_connections_list, original_access_control, new_access_control,
            actual_access_control, cs_status);
      IF cs_status = osc$cs_failed THEN
        original_access_control := actual_access_control;
      IFEND;
    UNTIL (cs_status = osc$cs_successful);

    received_connection := original_access_control.received_connection;
    previous_received_connection := ^original_access_control.received_connection;
    connection_attributes [1].kind := nac$peer_accounting_information;

    WHILE (received_connection <> NIL) DO
      pmp$generate_unique_name (network_file_name, {ignore} status);
      nap$create_network_file (network_file_name.value, NIL, received_connection^.connection_id, FALSE,
            status);
      IF status.normal THEN
        received_connection^.network_file_name := network_file_name.value;
        connection_attributes [1].peer_accounting_information := ^received_connection^.peer_accounting_info;
        nap$get_attributes (network_file_name.value, connection_attributes, status);
      IFEND;
      IF NOT status.normal THEN
        nap$display_message (status);
        previous_received_connection^ := received_connection^.next_entry;
        decrement_received_conn_count (received_connection^.server, received_connection^.connection_id);
        FREE received_connection IN osv$task_shared_heap^;
        received_connection := previous_received_connection^;
      ELSE
        received_connection^.peer_accounting_info_length :=
              connection_attributes [1].peer_accounting_info_length;
        IF received_connection^.server = osc$timesharing THEN

{ Obtain the remote attach job protocol if present.

          peer_accounting := ^received_connection^.peer_accounting_info;
          RESET peer_accounting;
          NEXT received_peer_accounting: [[REP received_connection^.peer_accounting_info_length of cell]]
                IN peer_accounting;
          IF received_peer_accounting <> NIL THEN
            RESET received_peer_accounting;
            NEXT accounting IN received_peer_accounting;
            IF (accounting <> NIL) AND ((accounting^.version = supported_accounting_version) AND
                (accounting^.caller_identifer = paired_connection)) THEN
              received_connection^.prompt_user := FALSE;
              received_connection^.client_validation_kind := am_remote_attach_job;
              received_connection^.state := am_validation_failed;
              received_connection^.service_data_ii_length := 0;
              connection_attributes [1].kind := nac$peer_connect_data;
              connection_attributes [1].peer_connect_data := ^interactive_tip_data;
              nap$get_attributes (network_file_name.value, connection_attributes, status);
              IF status.normal THEN
                peer_connect_data := ^interactive_tip_data;
                interactive_tip_data_length := connection_attributes [1].peer_connect_data_length;
                RESET peer_connect_data;
                NEXT received_peer_connect_data: [[REP interactive_tip_data_length of cell]]
                      IN peer_connect_data;
                RESET received_peer_connect_data;
                NEXT fixed_user_data IN received_peer_connect_data;
                IF (fixed_user_data <> NIL) AND (fixed_user_data^.version = supported_user_data_version) THEN
                  NEXT service_data_length IN received_peer_connect_data;
                  IF service_data_length <> NIL THEN
                    NEXT service_data: [service_data_length^ + vtp_version_length] IN
                          received_peer_connect_data;
                    IF service_data <> NIL THEN
                      NEXT service_data_length IN received_peer_connect_data;
                      IF (service_data_length <> NIL) AND (service_data_length^ > 0) THEN
                        NEXT service_data_ii: [service_data_length^] IN received_peer_connect_data;
                        IF service_data_ii <> NIL THEN
                          received_connection^.state := am_validate_job;
                          received_connection^.service_data_ii_length := service_data_length^;
                          received_connection^.service_data_ii (1, service_data_length^) :=
                                service_data_ii^ (1, service_data_length^);
                        IFEND;
                      IFEND;
                    IFEND;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
        IF received_connection^.client_validation_kind = am_client_dialog THEN
        pmp$generate_unique_name (terminal_file_name, {ignore} status);
        term_conn_attributes := terminal_attributes;
        term_conn_attributes [UPPERBOUND (term_conn_attributes)].key := ifc$prompt_file;
        term_conn_attributes [UPPERBOUND (term_conn_attributes)].prompt_file := terminal_file_name.value;

        rmp$request_terminal (terminal_file_name.value, ^network_file_name.value, term_conn_attributes,
              status);
        IF status.normal THEN
          received_connection^.terminal_file_name := terminal_file_name.value;
          fsp$open_file (terminal_file_name.value, amc$record, ^access_selections,
                ^access_creation_selections, ^access_creation_selections, NIL, NIL, file_id, status);
          IF status.normal THEN
            received_connection^.file_id := file_id;
            amp$put_next (received_connection^.file_id, formatted_prompt [nac$am_login_banner],
                  STRLENGTH (formatted_prompt [nac$am_login_banner]^), byte_address, status);
            IF status.normal THEN
              received_connection^.last_prompt := nac$am_login_banner;
              received_connection^.prompt_user := TRUE;
              received_connection^.send_previous_prompt := FALSE;
            IFEND;
          ELSE

{ *** DEBUG pmp$log ('AM - open network file error', ignore_status);

          IFEND;
        ELSE

{ *** DEBUG pmp$log ('AM - req terminal error.', ignore_status);

        IFEND;

        IF NOT status.normal THEN

{ **** TEMP FOR DEBUG ONLY

          nap$display_message (status);

          previous_received_connection^ := received_connection^.next_entry;
          fsp$close_file (received_connection^.file_id, {ignore} status);
          amp$return (received_connection^.network_file_name, {ignore} status);
          amp$return (received_connection^.terminal_file_name, {ignore} status);
          decrement_received_conn_count (received_connection^.server, received_connection^.connection_id);
          FREE received_connection IN osv$task_shared_heap^;
          received_connection := previous_received_connection^;
        ELSE
          received_connection := received_connection^.next_entry;
        IFEND;
        ELSE
          received_connection := received_connection^.next_entry;
        IFEND;
      IFEND;
    WHILEND;

    new_connections_list := original_access_control.received_connection;
    #KEYPOINT (osk$exit, osk$m * amk_initiate_new_dialogs, nak$application_event_processor);

  PROCEND initiate_new_dialogs;
?? OLDTITLE ??
?? NEWTITLE := 'assign_connection', EJECT ??

  PROCEDURE assign_connection
    (    server_attributes: ^nat$server_attributes;
         client_validated_connection: boolean;
         connection_id: nat$connection_id;
         directed_connection: boolean;
         job_name: jmt$system_supplied_name);


    VAR
      assigned_connection: ^^nat$server_connection_attribute,
      ignore_status: ost$status,
      new_assigned_connection: ^nat$server_connection_attribute,
      previous_wait_for_connection: ^^nat$wait_for_connection,
      previous_server_connection: ^^nat$server_connection_attribute,
      server_connection: ^nat$server_connection_attribute,
      wait_for_connection: ^nat$wait_for_connection;

{ It is assumed that the server attributes entry has been locked for exclusive
{ access by the caller.

    IF client_validated_connection THEN

{ The connection had been acquired by the server to get the validation info.
{ Search the server connections list for the connection and move it to the
{ assigned connections list.

      server_connection := server_attributes^.server_connections_list;
      previous_server_connection := ^server_attributes^.server_connections_list;
      WHILE (server_connection <> NIL) AND (server_connection^.connection_id <> connection_id) DO
        previous_server_connection := ^server_connection^.next_entry;
        server_connection := server_connection^.next_entry;
      WHILEND;
      IF server_connection <> NIL THEN
        previous_server_connection^ := server_connection^.next_entry;
        new_assigned_connection := server_connection;
      ELSE

{ Connection disconnected and has been removed from list.

        RETURN;
      IFEND;
    ELSE
      REPEAT
        ALLOCATE new_assigned_connection IN nav$network_paged_heap^;
        IF new_assigned_connection = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL new_assigned_connection <> NIL;
      new_assigned_connection^.connection_id := connection_id;
    IFEND;

    new_assigned_connection^.connection_kind := nac$assigned_to_job;
    new_assigned_connection^.directed_connection := directed_connection;
    IF directed_connection THEN
      new_assigned_connection^.destination_job_name := job_name;
    IFEND;

    new_assigned_connection^.terminate_connection := FALSE;
    new_assigned_connection^.time_stamp := #FREE_RUNNING_CLOCK (0);
    new_assigned_connection^.next_entry := NIL;
    assigned_connection := ^server_attributes^.assigned_connections_list;

{ Queue the new connection at the end of the assigned connections list.

    WHILE assigned_connection^ <> NIL DO
      assigned_connection := ^assigned_connection^^.next_entry;
    WHILEND;
    assigned_connection^ := new_assigned_connection;

{  Ready a waiting task.

    wait_for_connection := server_attributes^.wait_for_connection;
    previous_wait_for_connection := ^server_attributes^.wait_for_connection;

    WHILE (wait_for_connection <> NIL) AND (directed_connection) AND
          (wait_for_connection^.job_name <> job_name) DO
      previous_wait_for_connection := ^wait_for_connection^.next_entry;
      wait_for_connection := wait_for_connection^.next_entry;
    WHILEND;

    IF wait_for_connection <> NIL THEN

{ Found the waiting job.

      previous_wait_for_connection^ := wait_for_connection^.next_entry;
      pmp$ready_task (wait_for_connection^.task_id, ignore_status);
      FREE wait_for_connection IN nav$network_paged_heap^;
    IFEND;
  PROCEND assign_connection;
?? OLDTITLE ??
?? NEWTITLE := 'assign_received_connection', EJECT ??

  PROCEDURE assign_received_connection
    (    server_attributes: ^nat$server_attributes;
         connection_id: nat$connection_id;
     VAR status: ost$status);

{ The purpose of this procedure is to assign the received connection for which
{ no validation is required. The connection is assigned either to an existing
{ job that can acquire more connections or a new job is initiated to acquire
{ the received connection. The connection would be rejected in case it is
{ destined for an application initiated server and the currently signed on jobs
{ are unable to acquire more connections.


    VAR
      server_job_attributes: ^nat$server_job_attributes,
      server_capacity: integer,
      assigned_connection: ^nat$server_connection_attribute,
      job_name: jmt$system_supplied_name,
      login: am_login_parameters;

{ This proc assumes that the server attributes has been locked for exclusive
{ access by the caller.

    status.normal := TRUE;
    server_capacity := 0;
    server_job_attributes := server_attributes^.server_job_list;

    WHILE server_job_attributes <> NIL DO
      IF server_job_attributes^.job_status = nac$server_job_initiated THEN
        server_capacity := server_capacity + server_attributes^.server_job_max_connections;
      ELSE
        IF server_job_attributes^.job_status = nac$server_job_attached THEN
          server_capacity := (server_job_attributes^.max_connections_per_server_job -
                server_job_attributes^.connection_count) + server_capacity;
        IFEND;
      IFEND;

{ NOTE: Deactivated jobs capacity is not included.

      server_job_attributes := server_job_attributes^.next_entry;
    WHILEND;

{  Sum up the assigned connections.

    assigned_connection := server_attributes^.assigned_connections_list;

    WHILE assigned_connection <> NIL DO
      server_capacity := server_capacity - 1;
      assigned_connection := assigned_connection^.next_entry;
    WHILEND;

    IF (NOT server_attributes^.nam_initiated_server) AND (server_capacity <= 0) THEN
      IF server_attributes^.server_job_list <> NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$insufficient_attached_jobs, server_attributes^.server,
              status);
      ELSE { server_attributes^.server_job_list = NIL
        osp$set_status_abnormal (nac$status_id, nae$no_server_job_active, server_attributes^.server,
              status);
      IFEND;
      nap$display_message (status);
    ELSE
      IF server_capacity <= 0 THEN
        initiate_saj (server_attributes, login, NIL, 0, NIL, job_name, status);
      IFEND;

      IF status.normal THEN
        assign_connection (server_attributes, FALSE, connection_id, FALSE, jmc$full_system_supplied_name);
      IFEND;
    IFEND;

  PROCEND assign_received_connection;
?? OLDTITLE ??
?? NEWTITLE := 'assign_validated_connection', EJECT ??

  PROCEDURE assign_validated_connection
    (    received_connection: ^am_received_connection_attr;
         transfer_count: amt$transfer_count;
         login_params: ^SEQ ( * );
         login_specification: am_login_specification;
     VAR status: ost$status);

{ The purpose of this procedure is to assign a client validated connection. A
{ client validated connection is one for which FAMILY, USER_NAME AND PASSWORD
{ have been requested from the client that initiated the connection. If the connection
{ is destined for a server that provides login, prevalidation of the requested
{ parameters is done and the connection is assigned to the server jobs. But if
{ login is to be provided by the client, prevalidation is done only if the
{ connection can be acquired by an existing server job.


    VAR
      byte_address: amt$file_byte_address,
      client_identity: nat$client_identity,
      default_job_attributes_p: ^jmt$default_attribute_results,
      ignore_status: ost$status,
      job_name: jmt$system_supplied_name,
      login_parameters: ^SEQ ( * ),
      login_password: ost$name,
      login_string: ^string ( * ),
      login_string_size: ^clt$command_line_size,
      parameter_list: ^clt$parameter_list,
      server_attributes: ^nat$server_attributes,
      server_job_attributes: ^nat$server_job_attributes,
      validation_attributes: ^avt$validation_items;


    status.normal := TRUE;
    login_parameters := login_params;
    IF login_specification = am_via_string THEN
      IF received_connection^.login_string = NIL THEN
        RESET login_parameters;
        NEXT login_string_size IN login_parameters;
        login_string_size^ := transfer_count;
        NEXT login_string: [transfer_count] IN login_parameters;
      ELSE
        login_parameters := received_connection^.login_string;
        RESET login_parameters;
        NEXT login_string_size IN login_parameters;
        NEXT login_string: [login_string_size^] IN login_parameters;
      IFEND;
    ELSE
      login_string := NIL;
    IFEND;

    nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
    nap$find_server_attributes (received_connection^.server, server_attributes);
    IF server_attributes = NIL THEN
      osp$set_status_condition (nae$unknown_application, status);
    ELSE
      nlp$get_exclusive_access (server_attributes^.access_control);
      IF server_attributes^.server_status = nac$application_inactive THEN
        osp$set_status_condition (nae$application_inactive, status);
      ELSE
        server_job_attributes := server_attributes^.server_job_list;

      /find_saj/
        WHILE server_job_attributes <> NIL DO
          IF (server_job_attributes^.connection_count + server_job_attributes^.assigned_connection_count) <
                server_job_attributes^.max_connections_per_server_job THEN
            EXIT /find_saj/;
          IFEND;

          server_job_attributes := server_job_attributes^.next_entry;
        WHILEND /find_saj/;


        IF server_job_attributes <> NIL THEN
          IF login_specification = am_via_string THEN
            RESET login_parameters;
            NEXT parameter_list: [[REP (#SIZE (login_string_size^) + login_string_size^) OF cell]] IN
                  login_parameters;
            clp$push_parameters (ignore_status);

{ The data returned by this request will be the value supplied by the user or a
{ null name (osc$null_name).

            clp$get_login_data_for_nam (parameter_list^, received_connection^.login_parameters.user_name,
                  login_password, received_connection^.login_parameters.family_name,
                  received_connection^.login_parameters.account_name,
                  received_connection^.login_parameters.project_name, status);
            clp$pop_parameters (ignore_status);
            IF NOT status.normal THEN
              nlp$release_exclusive_access (server_attributes^.access_control);
              nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
              RETURN;
            IFEND;
            IF received_connection^.login_parameters.password = osc$null_name THEN
              received_connection^.login_parameters.password := login_password;
            IFEND;
          IFEND;

{ Get default family name, if not specified.

          IF received_connection^.login_parameters.family_name = osc$null_name THEN
            PUSH default_job_attributes_p: [1 .. 1];
            default_job_attributes_p^ [1].key := jmc$login_family;
            jmp$get_attribute_defaults (jmc$batch, default_job_attributes_p, {ignore} status);
            received_connection^.login_parameters.family_name := default_job_attributes_p^ [1].login_family;
          IFEND;

{ Prevalidate job.  The validation attributes should be in the order that you want them validated.

{*** DEBUG pmp$log_ascii ('NAM prevalidate_user', $pmt$ascii_logset [pmc$system_log],
{*** DEBUG pmc$msg_origin_system, ignore_status);
{*** DEBUG pmp$log_ascii (server_attributes^.client_validation_capability, $pmt$ascii_logset [pmc$system_log],
{*** DEBUG pmc$msg_origin_system, ignore_status);

          PUSH validation_attributes: [1 .. 3];
          validation_attributes^ [1].key := avc$password_key;
          validation_attributes^ [1].password := received_connection^.login_parameters.password;
          validation_attributes^ [2].key := avc$account_project_key;
          validation_attributes^ [2].account_name := received_connection^.login_parameters.account_name;
          validation_attributes^ [2].project_name := received_connection^.login_parameters.project_name;
          IF server_attributes^.client_validation_capability <> osc$null_name THEN
            validation_attributes^ [3].key := avc$required_capability_key;
            validation_attributes^ [3].required_capability := server_attributes^.client_validation_capability;
          ELSE
            validation_attributes^ [3].key := avc$null_validation_key;
          IFEND;

          job_name := server_job_attributes^.job_name;

{ *** DEBUG pmp$log ('AM PREVALIDATE USER', ignore_status);

          nlp$release_exclusive_access (server_attributes^.access_control);
          avp$prevalidate_job (received_connection^.login_parameters.user_name,
                received_connection^.login_parameters.family_name, validation_attributes, NIL, status);
          nlp$get_exclusive_access (server_attributes^.access_control);
        ELSE
          IF server_attributes^.nam_initiated_server THEN
            initiate_saj (server_attributes, received_connection^.login_parameters, login_string,
                  received_connection^.peer_accounting_info_length,
                  ^received_connection^.peer_accounting_info, job_name, status);
          ELSE

{ Should not end up here.

            osp$set_status_abnormal (nac$status_id, nae$insufficient_attached_jobs,
                  received_connection^.server, status);
            nap$display_message (status);
          IFEND;
        IFEND;

        IF status.normal THEN
          nap$remove_connection_id (received_connection^.network_file_name, {ignore} status);
          status.normal := TRUE;
          IF server_job_attributes <> NIL THEN
            server_job_attributes^.assigned_connection_count :=
                  server_job_attributes^.assigned_connection_count + 1;
          IFEND;
          assign_connection (server_attributes, TRUE, received_connection^.connection_id, TRUE, job_name);

        IFEND;
      IFEND;
      nlp$release_exclusive_access (server_attributes^.access_control);
    IFEND;

    nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);

    IF status.normal THEN
      client_identity.family := received_connection^.login_parameters.family_name;
      client_identity.user := received_connection^.login_parameters.user_name;
      nap$store_client_identity (received_connection^.connection_id, client_identity, {ignore} status);
      status.normal := TRUE;
    IFEND;

  PROCEND assign_validated_connection;
?? OLDTITLE ??
?? NEWTITLE := 'decrement_received_conn_count', EJECT ??

  PROCEDURE decrement_received_conn_count
    (    server: nat$application_name;
         connection_id: nat$connection_id);

    VAR
      previous_server_connection: ^^nat$server_connection_attribute,
      server_attributes: ^nat$server_attributes,
      server_connection: ^nat$server_connection_attribute;


    nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
    nap$find_server_attributes (server, server_attributes);
    IF server_attributes <> NIL THEN
      nlp$get_exclusive_access (server_attributes^.access_control);
      server_connection := server_attributes^.server_connections_list;
      previous_server_connection := ^server_attributes^.server_connections_list;
      WHILE (server_connection <> NIL) AND (server_connection^.connection_id <> connection_id) DO
        previous_server_connection := ^server_connection^.next_entry;
        server_connection := server_connection^.next_entry;
      WHILEND;
      IF server_connection <> NIL THEN
        previous_server_connection^ := server_connection^.next_entry;
        FREE server_connection IN nav$network_paged_heap^;
        server_attributes^.connection_count := server_attributes^.connection_count - 1;
      IFEND;
      nlp$release_exclusive_access (server_attributes^.access_control);
    IFEND;
    nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);

  PROCEND decrement_received_conn_count;
?? OLDTITLE ??
?? NEWTITLE := 'extract_login_parameters', EJECT ??

  PROCEDURE extract_login_parameters
    (    received_connection: ^am_received_connection_attr;
         transfer_count: amt$transfer_count;
         login_params: ^SEQ ( * );
     VAR login_specification: am_login_specification;
     VAR re_prompt: boolean);

    VAR
      account_name: avt$account_name,
      byte_address: amt$file_byte_address,
      family_name: ost$family_name,
      ignore_status,
      local_status: ost$status,
      login_parameters: ^SEQ ( * ),
      parameter_list: ^clt$parameter_list,
      parameter_list_size: ^clt$command_line_size,
      parameter_name: ost$name,
      parameters: ^string ( * ),
      password: ost$name,
      project_name: avt$project_name,
      prompt: nat$am_login_prompt,
      prompt_for_password: boolean,
      user_name: ost$user_name,
      valid_name: boolean;

    login_specification := am_incomplete;
    re_prompt := FALSE;
    local_status.normal := TRUE;

    login_parameters := login_params;
    RESET login_parameters;
    NEXT parameter_list_size IN login_parameters;
    parameter_list_size^ := transfer_count;
    NEXT parameters: [transfer_count] IN login_parameters;

    IF transfer_count <= osc$max_name_size THEN
      clp$validate_name (parameters^, parameter_name, valid_name);
    ELSE
      valid_name := FALSE;
    IFEND;

    CASE received_connection^.last_prompt OF
    = nac$am_user_name =
      IF received_connection^.login_string <> NIL THEN
        FREE received_connection^.login_string IN osv$task_shared_heap^;
      IFEND;
      IF valid_name THEN
        received_connection^.login_parameters.user_name := parameter_name;
        amp$put_next (received_connection^.file_id, NIL, 0, byte_address, ignore_status);
      ELSE
        overwrite_login_info (received_connection^.file_id, transfer_count, nac$am_user_name, blackout,
              {suppress_cursor_positioning} TRUE);
        prompt_for_password := nav$force_password_prompt;
        IF NOT prompt_for_password THEN {verify password was specified in string}
          RESET login_parameters;
          NEXT parameter_list: [[REP (#SIZE (parameter_list_size^) + transfer_count) OF cell]] IN
                login_parameters;
          clp$push_parameters (ignore_status);

{ The data returned by this request will be the value supplied by the user or a null name (osc$null_name).

          clp$get_login_data_for_nam (parameter_list^, user_name, password, family_name, account_name,
                project_name, ignore_status);
          clp$pop_parameters (ignore_status);
          prompt_for_password := password = osc$null_name;
        IFEND;
        IF prompt_for_password THEN
          ALLOCATE received_connection^.login_string: [[REP (transfer_count + #SIZE (parameter_list_size^)) OF
                cell]] IN osv$task_shared_heap^;
          i#move (^login_parameters^, ^received_connection^.login_string^,
                #SIZE (received_connection^.login_string^));
        ELSE {No further prompting necessary.}
          login_specification := am_via_string;
        IFEND;
      IFEND;
    = nac$am_password =
      overwrite_login_info (received_connection^.file_id, transfer_count, nac$am_password, blank_only,
            {suppress_cursor_positioning} TRUE);
      IF valid_name THEN
        received_connection^.login_parameters.password := parameter_name;
        IF received_connection^.login_string <> NIL THEN
          login_specification := am_via_string;
        ELSEIF final_login_prompt = nac$am_password THEN
          login_specification := am_via_parameters;
        IFEND;
      ELSE
        osp$set_status_condition (nae$improper_name_at_login, local_status);
      IFEND;
    = nac$am_family_name =
      IF valid_name THEN
        received_connection^.login_parameters.family_name := parameter_name;
        IF final_login_prompt = nac$am_family_name THEN
          login_specification := am_via_parameters;
        IFEND;
      ELSE
        osp$set_status_condition (nae$improper_name_at_login, local_status);
      IFEND;
    = nac$am_account_name =
      IF valid_name THEN
        received_connection^.login_parameters.account_name := parameter_name;
        IF final_login_prompt = nac$am_account_name THEN
          login_specification := am_via_parameters;
        IFEND;
      ELSE
        osp$set_status_condition (nae$improper_name_at_login, local_status);
      IFEND;
    = nac$am_project_name =
      IF valid_name THEN
        received_connection^.login_parameters.project_name := parameter_name;
        login_specification := am_via_parameters;
      ELSE
        osp$set_status_condition (nae$improper_name_at_login, local_status);
      IFEND;
    ELSE
    CASEND;

    IF NOT local_status.normal THEN
      osp$output_status_message (received_connection^.file_id, osc$brief_message_level,
            osc$subdued_status_message_hdr, local_status, ignore_status);
      IF received_connection^.login_parameters.retry_count_for_login_prompt <
            (nav$maximum_login_attempts - 1) THEN
        osp$set_status_condition (nae$retry_login, local_status);
        osp$output_status_message (received_connection^.file_id, osc$brief_message_level,
              osc$subdued_status_message_hdr, local_status, ignore_status);
      IFEND;
      re_prompt := TRUE;
    IFEND;

  PROCEND extract_login_parameters;
?? OLDTITLE ??
?? NEWTITLE := 'format_login_prompts', EJECT ??

  PROCEDURE format_login_prompts;

    VAR
      message: ost$status_message,
      prompt: nat$am_login_prompt,
      prompt_area: ^ost$status_message,
      prompt_line: ^string ( * ),
      prompt_line_count: ^ost$status_message_line_count,
      prompt_line_size: ^ost$status_message_line_size,
      status: ost$status;

    FOR prompt := nac$am_login_banner TO nac$am_project_name DO
      osp$format_multi_part_message (osc$brief_message_level, osc$subdued_status_message_hdr,
            osc$status_message_width, raw_prompt [prompt], NIL, NIL, message, status);
      IF NOT status.normal THEN
        nap$display_message (status);
        RETURN;
      IFEND;

{ All prompts are assumed to be one line long.

      prompt_area := ^message;
      RESET prompt_area;
      NEXT prompt_line_count IN prompt_area;
      NEXT prompt_line_size IN prompt_area;
      NEXT prompt_line: [prompt_line_size^] IN prompt_area;
      ALLOCATE formatted_prompt [prompt]: [prompt_line_size^] IN osv$task_private_heap^;
      formatted_prompt [prompt]^ := prompt_line^;
    FOREND;
  PROCEND format_login_prompts;
?? OLDTITLE ??
?? NEWTITLE := 'get_server_attributes', EJECT ??

  PROCEDURE [INLINE] get_server_attributes
    (    sap: nat$sap_identifier;
     VAR server_attributes: ^nat$server_attributes);

{ This procedure assumes that the server attributes list  has been locked
{ by the caller.

    IF sap.kind = nac$osi_sap_identifier THEN
      server_attributes := nav$server_attributes_list.server_attributes;
      WHILE (server_attributes <> NIL) AND (server_attributes^.application_id.osi_sap_identifier <>
            sap.identifier) DO
        server_attributes := server_attributes^.next_entry;
      WHILEND;
    ELSE
      server_attributes := NIL;
    IFEND;

  PROCEND get_server_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'initiate_saj', EJECT ??

  PROCEDURE initiate_saj
    (    server_attributes: ^nat$server_attributes;
         login: am_login_parameters;
         login_string: ^string ( * );
         peer_accounting_info_length: nat$data_length;
         peer_accounting_info: ^SEQ (REP jmc$job_input_device_size of cell);
     VAR job_name: jmt$system_supplied_name;
     VAR status: ost$status);

{ The purpose of this procedure is to initiate a server application job.
{ If the login parameters have been requested from the client, they would be
{ provided on the call to submit job routine. If login is provided by the
{ application definer, login would be the first statement on the file that
{ represents the service provided by the application.

    VAR
      default_job_attributes: array [1 .. 1] of jmt$default_attribute_result,
      server_job_attributes: ^nat$server_job_attributes,
      highest_cycle: [STATIC, READ, oss$job_paged_literal] pft$cycle_selector := [pfc$highest_cycle],
      i: integer,
      ignore_status: ost$status,
      job_submission_options: array [1 .. max_job_submission_options] of jmt$job_submission_option,
      j: integer,
      usage_selections: [STATIC, READ, oss$job_paged_literal] pft$usage_selections := [pfc$read],
      share_selections: [STATIC, READ, oss$job_paged_literal] pft$usage_selections := [pfc$read],
      file_name: ost$unique_name,
      path: [STATIC, READ, oss$job_paged_literal] array [1 .. 6] of pft$name :=
            [nac$application_family, nac$application_master_catalog, nac$network_subcatalog,
            nac$application_catalog, nac$application_job_catalog, * ],
      path_name: array [1 .. 6] of pft$name,
      peer_accounting_information: ^string ( * ),
      peer_accounting_info_seq: ^SEQ (REP jmc$job_input_device_size of cell);


{ It is assumed that the server_attributes has been locked for exclusive access
{ by the caller.

    status.normal := TRUE;
    i := 1;


    IF server_attributes^.server_job_validation_source = nac$client THEN

      IF login_string <> NIL THEN
        job_submission_options [i].key := jmc$login_command;
        job_submission_options [i].login_command := login_string;
        i := i + 1;
        IF login.password <> osc$null_name THEN
          job_submission_options [i].key := jmc$login_password;
          job_submission_options [i].login_password := login.password;
          i := i + 1;
        IFEND;
      ELSE
        IF login.family_name <> osc$null_name THEN
          job_submission_options [i].key := jmc$login_family;
          job_submission_options [i].login_family := login.family_name;
          i := i + 1;
        IFEND;

        job_submission_options [i].key := jmc$login_password;
        job_submission_options [i].login_password := login.password;
        i := i + 1;

        job_submission_options [i].key := jmc$login_user;
        job_submission_options [i].login_user := login.user_name;
        i := i + 1;

        IF login.account_name <> osc$null_name THEN
          job_submission_options [i].key := jmc$login_account;
          job_submission_options [i].login_account := login.account_name;
          i := i + 1;
        IFEND;

        IF login.project_name <> osc$null_name THEN
          job_submission_options [i].key := jmc$login_project;
          job_submission_options [i].login_project := login.project_name;
          i := i + 1;
        IFEND;
      IFEND;

      job_submission_options [i].key := jmc$login_command_supplied;
      job_submission_options [i].login_command_supplied := FALSE;
      i := i + 1;

      IF peer_accounting_info_length > 0 THEN
        job_submission_options [i].key := jmc$job_input_device;
        PUSH job_submission_options [i].job_input_device;
        job_submission_options [i].job_input_device^.size := peer_accounting_info_length;
        peer_accounting_info_seq := peer_accounting_info;
        RESET peer_accounting_info_seq;
        NEXT peer_accounting_information: [peer_accounting_info_length] IN peer_accounting_info_seq;
        job_submission_options [i].job_input_device^.text := peer_accounting_information^;
        i := i + 1;
      IFEND;
    ELSE
      job_submission_options [i].key := jmc$login_command_supplied;
      job_submission_options [i].login_command_supplied := TRUE;
      i := i + 1;
    IFEND;

{ Fill in the common job submission attributes.

    job_submission_options [i].key := jmc$immediate_init_candidate;
    job_submission_options [i].immediate_init_candidate := TRUE;
    i := i + 1;

    IF server_attributes^.client_validation_capability <> osc$null_name THEN
      job_submission_options [i].key := jmc$required_user_capability;
      job_submission_options [i].required_user_capability := server_attributes^.client_validation_capability;
      i := i + 1;
    IFEND;

    job_submission_options [i].key := jmc$origin_application_name;
    job_submission_options [i].origin_application_name := server_attributes^.server;
    i := i + 1;

{ Get default family name.

    default_job_attributes [1].key := jmc$login_family;
    IF server_attributes^.server = osc$timesharing THEN
      jmp$get_attribute_defaults (jmc$interactive_connected, ^default_job_attributes, {ignore} status);
    ELSE
      jmp$get_attribute_defaults (jmc$batch, ^default_job_attributes, {ignore} status);
    IFEND;
    job_submission_options [i].key := jmc$default_login_family;
    job_submission_options [i].default_login_family := default_job_attributes [1].login_family;

{ Initialize unused slots to a null value.

    FOR j := (i + 1) TO UPPERBOUND (job_submission_options) DO
      job_submission_options [j].key := jmc$null_attribute;
    FOREND;

    IF NOT server_attributes^.service_file_defined THEN
      file_name.value := clc$null_file;
    ELSE
      pmp$generate_unique_name (file_name, ignore_status);
      path_name := path;
      path_name [UPPERBOUND (path_name)] := server_attributes^.server;
      pfp$attach (file_name.value, path_name, highest_cycle, osc$null_name, usage_selections,
            share_selections, pfc$no_wait, status);
      IF NOT status.normal THEN
        nap$display_message (status);
      IFEND;
    IFEND;

    IF status.normal THEN

{ *** DEBUG pmp$log ('AM SUBMITTING NAM INITIATED SAJ.', ignore_status);

      server_attributes^.server_job_init_pending := TRUE;

{ The server attributes is unlocked to avoid potential deadlocks.
{ The server attributes entry is marked to indicate that the server attributes
{ entry needs to be updated after submitting the job. The newly initiated job
{ will wait to attach to the server when this flag is set.

      nlp$release_exclusive_access (server_attributes^.access_control);
      jmp$submit_job (file_name.value, ^job_submission_options, job_name, status);

{ Note: Since the non exclusive lock to the server attributes list is not released, the
{ server cannot be deleted in the mean time. Hence no search is neccessary to find the
{ server attributes entry again.

      nlp$get_exclusive_access (server_attributes^.access_control);
      server_attributes^.server_job_init_pending := FALSE;
      IF file_name.value <> clc$null_file THEN
        amp$return (file_name.value, ignore_status);
      IFEND;

      IF status.normal THEN

{ Since the server attributes lock was released before calling jmp$submit_job we
{ need to verify the server status.

        IF server_attributes^.server_status = nac$application_inactive THEN
          osp$set_status_abnormal (nac$status_id, nae$application_inactive, server_attributes^.server,
                status);
        ELSE

{ Add server job attributes entry.

          REPEAT
            ALLOCATE server_job_attributes IN nav$network_paged_heap^;
            IF server_job_attributes = NIL THEN
              syp$cycle;
            IFEND;
          UNTIL server_job_attributes <> NIL;
          server_job_attributes^.job_name := job_name;
          server_job_attributes^.job_status := nac$server_job_initiated;
          server_job_attributes^.time_stamp := #FREE_RUNNING_CLOCK (0);
          server_job_attributes^.max_connections_per_server_job := 0;
          server_job_attributes^.connection_count := 0;

          IF (server_attributes^.server_job_validation_source = nac$client) THEN
            server_job_attributes^.assigned_connection_count := 1;
          ELSE
            server_job_attributes^.assigned_connection_count := 0;
          IFEND;

{ Link the server_job_attributes to the server_job_list.

          server_job_attributes^.next_entry := server_attributes^.server_job_list;
          server_attributes^.server_job_list := server_job_attributes;
        IFEND;
      IFEND;
    IFEND;

  PROCEND initiate_saj;
?? OLDTITLE ??
?? NEWTITLE := 'overwrite_login_info', EJECT ??

  PROCEDURE overwrite_login_info
    (    file_id: amt$file_identifier;
         user_input_length: clt$command_line_size;
         prompt: nat$am_login_prompt;
         overwrite_kind: (blank_only, blackout);
         suppress_cursor_positioning: boolean);

{ This procedure overwrites the user password at the terminal.
{ In order for the overwrite to work correctly, cursor positioning
{ must have been suppressed prior to the previous output. (i.e.,
{ cursor positioning must be suppressed before issuing the prompt)


    VAR
      byte_address: amt$file_byte_address,
      i: 0 .. 0ff(16),
      j: 0 .. 0ffff(16),
      ignore_status: ost$status,
      overwrite_length: clt$command_line_size;


    IF user_input_length < osc$max_name_size THEN
      overwrite_length := osc$max_name_size;
    ELSE
      overwrite_length := user_input_length;
    IFEND;

{ Change the format effector to a '+' so that no line feed is done prior to
{ writing the line.

    IF suppress_cursor_positioning THEN
      formatted_prompt [prompt]^ (1) := ifc$pre_print_start_of_line;
    IFEND;

    IF overwrite_kind = blackout THEN
      FOR i := 1 TO 3 DO
        amp$put_partial (file_id, formatted_prompt [prompt], STRLENGTH (formatted_prompt [prompt]^),
              byte_address, amc$start, ignore_status);
        FOR j := 1 TO (overwrite_length DIV overwrite_pattern_size) DO
          amp$put_partial (file_id, ^login_overwrite_pattern (i), overwrite_pattern_size, byte_address,
                amc$continue, ignore_status);
        FOREND;
        amp$put_partial (file_id, ^login_overwrite_pattern (i), overwrite_length MOD overwrite_pattern_size,
              byte_address, amc$terminate, ignore_status);
        formatted_prompt [prompt]^ (1) := ifc$pre_print_start_of_line;
      FOREND;
    IFEND;

{   Blank overwrite.

    formatted_prompt [prompt]^ (1) := ifc$pre_print_start_of_line;
    amp$put_partial (file_id, formatted_prompt [prompt], STRLENGTH (formatted_prompt [prompt]^), byte_address,
          amc$start, ignore_status);
    FOR j := 1 TO (overwrite_length DIV overwrite_pattern_size) DO
      amp$put_partial (file_id, ^login_blank_overwrite, overwrite_pattern_size, byte_address, amc$continue,
            ignore_status);
    FOREND;
    amp$put_partial (file_id, ^login_blank_overwrite, overwrite_length MOD overwrite_pattern_size,
          byte_address, amc$terminate, ignore_status);

{ Change format effector back to original value.

    formatted_prompt [prompt]^ (1) := ifc$pre_print_space_1;

  PROCEND overwrite_login_info;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] prompt_user', EJECT ??

  PROCEDURE [INLINE] prompt_user
    (    received_connection: ^am_received_connection_attr;
     VAR retry_limit_reached: boolean;
     VAR status: ost$status);

{ The purpose of this procedure is to set up the prompt string to be output by
{ the next call to amp$get_next. The prompt string prompts the client for the
{ required validation parameters. If SEND_PREVIOUS_PROMPT is true, then the
{ previous prompt string is set up for subsequent output to the client.


    VAR
      byte_address: amt$file_byte_address,
      prompt_control: char,
      terminal_attribute: array [1 .. 1] of ift$connection_attribute;

    status.normal := TRUE;
    retry_limit_reached := FALSE;
    IF received_connection^.send_previous_prompt THEN
      IF received_connection^.login_parameters.retry_count_for_login_prompt <
            (nav$maximum_login_attempts - 1) THEN
        received_connection^.login_parameters.retry_count_for_login_prompt :=
              received_connection^.login_parameters.retry_count_for_login_prompt + 1;
      ELSE
        retry_limit_reached := TRUE;
      IFEND;
    ELSE
      REPEAT
        received_connection^.last_prompt := SUCC (received_connection^.last_prompt);
      UNTIL include_prompt [received_connection^.last_prompt];
      received_connection^.login_parameters.retry_count_for_login_prompt := 0;
    IFEND;

    IF NOT retry_limit_reached THEN
      prompt_control := ifc$pre_print_space_1;
      IF received_connection^.last_prompt = nac$am_password THEN
        overwrite_login_info (received_connection^.file_id, osc$max_name_size, nac$am_password, blackout,
              {suppress_cursor_positioning} FALSE);
        ifp$suppress_cursor_pos_echoplx (suppress_cursor_positioning, suppress_echoplex);
        prompt_control := ifc$pre_print_start_of_line;
      ELSEIF received_connection^.last_prompt = nac$am_user_name THEN
        ifp$suppress_cursor_pos_echoplx (suppress_cursor_positioning, NOT suppress_echoplex);
      IFEND;
      terminal_attribute [1].key := ifc$prompt_string;
      terminal_attribute [1].prompt_string.size := STRLENGTH (formatted_prompt
            [received_connection^.last_prompt]^);
      terminal_attribute [1].prompt_string.value := formatted_prompt [received_connection^.last_prompt]^;
      terminal_attribute [1].prompt_string.value (1) := prompt_control;
      iip$direct_store_trm_conn_atts (received_connection^.file_id, terminal_attribute, status);
    IFEND;

  PROCEND prompt_user;
?? OLDTITLE ??
?? NEWTITLE := 'report_unsuccessful_login' ??
?? NEWTITLE := '  [INLINE] add_to_line', EJECT ??

{ The purpose of this procedure is to write a message to the system ascii log and to emit the
{ statistic nac$maximum_logins_exceeded because a user attempting to log in has exceeded the
{ maximum number of login attempts allowed.  The message and statistic contain the user name
{ and family name which the user supplied on the last invalid attempt, along with the terminal
{ name.  In addition, the statistic contains the maximum login attempts.

  PROCEDURE report_unsuccessful_login
    (    received_connection: ^am_received_connection_attr;
         login_params: ^SEQ ( * );
         login_specification: am_login_specification);

    CONST
      unknown = '???';

    CONST
      max_data_area_size = 1000;

    VAR
      account_name: avt$account_name,
      accounting_data: array [1 .. 1] of nat$accounting_data_field,
      connection_attribute: array [1 .. 1] of nat$get_attribute,
      default_job_attributes: array [1 .. 1] of jmt$default_attribute_result,
      family_name: ost$family_name,
      line: string (osc$max_string_size),
      line_size: ost$string_size,
      login_parameters: ^SEQ ( * ),
      login_string_size: ^clt$command_line_size,
      parameter_list: ^clt$parameter_list,
      password: ost$name,
      peer_accounting_information: ^string ( * ),
      peer_accounting_seq: SEQ (REP max_data_area_size of cell),
      project_name: avt$project_name,
      status: ost$status,
      terminal_name: ost$name,
      user_name: ost$user_name;


    PROCEDURE [INLINE] add_to_line
      (    text: string ( * ));

      line (line_size + 1, STRLENGTH (text)) := text;
      line_size := line_size + STRLENGTH (text);
      WHILE (line_size > 0) AND (line (line_size) = ' ') DO
        line_size := line_size - 1;
      WHILEND;

    PROCEND add_to_line;
?? OLDTITLE ??
?? NEWTITLE := '  emit_maximum_login_statistic', EJECT ??

{
{ PURPOSE:
{   This procedure is used to emit a statistic to record a possible
{   security violation.
{

    PROCEDURE emit_maximum_login_statistic
      (    user_name: ost$user_name;
           family_name: ost$family_name;
           terminal_name: ost$name);

      VAR
        counter: array [1 .. 1] of sft$counter,
        statistic_descriptive_data: ost$string,
        string_size: integer;

      statistic_descriptive_data.value := user_name;
      statistic_descriptive_data.size := clp$trimmed_string_size (statistic_descriptive_data.value);

      statistic_descriptive_data.value (statistic_descriptive_data.size + 1, 2) := ', ';
      statistic_descriptive_data.size := statistic_descriptive_data.size + 2;

      string_size := clp$trimmed_string_size (family_name);
      statistic_descriptive_data.value (statistic_descriptive_data.size + 1, string_size) :=
            family_name (1, string_size);
      statistic_descriptive_data.size := statistic_descriptive_data.size + string_size;

      statistic_descriptive_data.value (statistic_descriptive_data.size + 1, 2) := ', ';
      statistic_descriptive_data.size := statistic_descriptive_data.size + 2;

      string_size := clp$trimmed_string_size (terminal_name);
      statistic_descriptive_data.value (statistic_descriptive_data.size + 1, string_size) :=
            terminal_name (1, string_size);
      statistic_descriptive_data.size := statistic_descriptive_data.size + string_size;

      counter [1] := nav$maximum_login_attempts;

      sfp$emit_statistic (nac$maximum_login_attempts, statistic_descriptive_data.
            value (1, statistic_descriptive_data.size), ^counter, {ignore} status);

    PROCEND emit_maximum_login_statistic;
?? OLDTITLE, EJECT ??

{ Get user name and family name if the login parameters were specified in one string.

    IF login_specification = am_via_string THEN
      login_parameters := login_params;
      RESET login_parameters;
      NEXT login_string_size IN login_parameters;
      RESET login_parameters;
      NEXT parameter_list: [[REP (#SIZE (login_string_size^) + login_string_size^) OF cell]] IN
            login_parameters;
      clp$push_parameters ({ignore} status);

{ The data returned by this request will be the value supplied by the user or a null name (osc$null_name).

      clp$get_login_data_for_nam (parameter_list^, user_name, password, family_name, account_name,
            project_name, status);
      IF NOT status.normal THEN
        user_name := received_connection^.login_parameters.user_name;
        family_name := received_connection^.login_parameters.family_name;
      IFEND;
      clp$pop_parameters ({ignore} status);
    ELSE
      user_name := received_connection^.login_parameters.user_name;
      family_name := received_connection^.login_parameters.family_name;
    IFEND;

    line_size := 0;
    add_to_line ('Login retry limit exceeded by');
    add_to_line (' USER=');
    IF user_name = osc$null_name THEN
      user_name := unknown;
    IFEND;
    add_to_line (user_name);
    add_to_line (', FAMILY_NAME=');
    IF family_name = osc$null_name THEN
      default_job_attributes [1].key := jmc$login_family;
      jmp$get_attribute_defaults (jmc$batch, ^default_job_attributes, {ignore} status);
      family_name := default_job_attributes [1].login_family;
    IFEND;
    add_to_line (family_name);
    add_to_line (', TERMINAL_NAME=');

{ Retrieve the peer_accounting_information attribute.

    connection_attribute [1].kind := nac$peer_accounting_information;
    connection_attribute [1].peer_accounting_information := ^peer_accounting_seq;

    nap$get_attributes (received_connection^.network_file_name, connection_attribute, status);
    IF status.normal THEN
      IF connection_attribute [1].peer_accounting_info_length = 0 THEN
        peer_accounting_information := NIL;
      ELSE
        RESET connection_attribute [1].peer_accounting_information;
        NEXT peer_accounting_information: [connection_attribute [1].peer_accounting_info_length] IN
              connection_attribute [1].peer_accounting_information;
      IFEND;

{ Get accounting data.

      accounting_data [1].kind := nac$ca_device_name;
      nap$parse_accounting_data (peer_accounting_information, NIL, ^accounting_data, status);
      IF status.normal THEN
        terminal_name := accounting_data [1].device_name;
      ELSE
        terminal_name := unknown;
      IFEND;
    ELSE
      terminal_name := unknown;
    IFEND;
    add_to_line (terminal_name);
    pmp$log_ascii (line (1, line_size), $pmt$ascii_logset [pmc$system_log], pmc$msg_origin_system,
          {ignore} status);
    emit_maximum_login_statistic (user_name, family_name, terminal_name);

  PROCEND report_unsuccessful_login;

MODEND nam$application_event_processor;
*DECK DECK=NAM$APPLICATION_MANAGEMENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NAM$APPLICATION_MANAGEMENT' ??
MODULE nam$application_management;
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_attributes
*copyc clt$file
*copyc fst$path
*copyc jmt$system_supplied_name
*copyc mmt$access_selections
*copyc nac$application_catalog_layout
*copyc nae$application_interfaces
*copyc nae$application_management
*copyc nae$directory_me_conditions
*copyc nae$manage_network_applications
*copyc nae$namve_conditions
*copyc nak$am_keypoints_job_mode
*copyc nat$am_keypoint_constants
*copyc nat$application_name
*copyc nat$application_status
*copyc nat$application_type
*copyc nat$connection_id
*copyc nat$create_attributes
*copyc nat$directory_interfaces
*copyc nat$directory_priority
*copyc nat$directory_search_identifier
*copyc nat$protocol
*copyc nat$number_of_connections
*copyc nat$network_address
*copyc nat$termination_reason
*copyc nat$title
*copyc nat$title_attributes
*copyc nat$title_pattern
*copyc nat$title_pattern_list
*copyc nat$translation_attributes
*copyc nat$wait_time
*copyc nlc$ta_sap_ranges
*copyc osc$timesharing
*copyc ost$processor_model_number
*copyc ost$status_message
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pmt$condition
*copyc pmt$condition_handler
*copyc pmt$program_parameters
?? POP ??
*copyc nat$application_file_definition
*copyc nat$client_attributes
*copyc nat$server_attributes
*copyc nat$tcpip_address
*copyc nat$tcpip_attributes
*copyc nat$tcp_socket
*copyc nat$udp_socket
?? TITLE := 'XREF PROCEDURES', EJECT ??
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc amp$return
*copyc amp$set_segment_eoi
*copyc avp$get_capability
*copyc bap$validate_file_identifier
*copyc clp$convert_string_to_file
*copyc fsp$close_file
*copyc fsp$copy_file
*copyc fsp$open_file
*copyc i#move
*copyc jmp$generate_timesharing_title
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc nap$display_message
*copyc nap$gt_process_job_termination
*copyc nap$namve_system_error
*copyc nap$se_terminate_connection
*copyc nap$sk_process_job_termination
*copyc nlp$delete_registered_title
*copyc nlp$name_match
*copyc nlp$se_close_sap
*copyc nlp$se_open_sap
*copyc nlp$sk_tcp_terminate_all_listen
*copyc nlp$sk_tcp_terminate_socket
*copyc nlp$register_title
*copyc nlp$udp_close_socket
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$clear_job_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$format_message
*copyc osp$pop_inhibit_job_recovery
*copyc osp$push_inhibit_job_recovery
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc pfp$attach
*copyc pfp$begin_system_authority
*copyc pfp$change
*copyc pfp$convert_pft$path_to_fs_path
*copyc pfp$define
*copyc pfp$define_catalog
*copyc pfp$end_system_authority
*copyc pfp$find_cycle_array
*copyc pfp$find_cycle_entry
*copyc pfp$find_directory_array
*copyc pfp$find_direct_info_record
*copyc pfp$find_next_info_record
*copyc pfp$get_item_info
*copyc pfp$purge
*copyc pmp$get_binary_processor_id
*copyc pmp$get_compact_date_time
*copyc pmp$get_job_names
*copyc pmp$get_pseudo_mainframe_id
*copyc pmp$get_unique_name
{***DEBUG   *copyc pmp$log
*copyc pmp$ready_task
*copyc rmp$get_device_class
?? TITLE := 'GLOBAL VARIABLES', EJECT ??
*copyc oss$job_paged_literal
*copyc osv$task_private_heap
*copyc nav$assigned_sap_list
*copyc nav$network_paged_heap
*copyc nav$namve_active
*copyc nav$applications_installed
*copyc nav$appl_defn_time_stamp
*copyc nav$client_attributes_list
*copyc nav$server_attributes_list
*copyc nav$tcpip_attributes_list

  CONST
{ The following are the max connections limits for timesharing on the
{ specified 930 models.
    max_connections_930_limit1 = 7,  { For model 930a, 932a }
    max_connections_930_limit2 = 15, { For model 930b, 930c, 932b }
    minimum_xns_sap_identifier = 2000;

  VAR
    access_selections: [READ, oss$job_paged_literal] array
          [1 .. 1] of fst$attachment_option := [[fsc$access_and_share_modes,
          [fsc$specific_access_modes, [fsc$read, fsc$modify, fsc$append]],
          [fsc$determine_from_access_modes]]],
    activate_client#: [READ, oss$job_paged_literal] string (15) := 'ACTIVATE_CLIENT',
    activate_server#: [READ, oss$job_paged_literal] string (15) := 'ACTIVATE_SERVER',
    activate_tcpip#: [READ, oss$job_paged_literal] string (14) := 'ACTIVATE_TCPIP',
    add_server_title: [READ, oss$job_paged_literal] string (20) := 'NAP$ADD_SERVER_TITLE',
    appl_mgmt_capability_verified: boolean := FALSE,
    application_catalog: [READ, oss$job_paged_literal] array [1 .. 4] of
          pft$name := [nac$application_family, nac$application_master_catalog, nac$network_subcatalog,
          nac$application_catalog],
    application_file_path: [READ, oss$job_paged_literal] array [1 .. 5] of
          pft$name := [nac$application_family, nac$application_master_catalog, nac$network_subcatalog,
          nac$application_catalog, nac$application_file],
    application_job_catalog: [READ, oss$job_paged_literal] array [1 .. 5] of
          pft$name := [nac$application_family, nac$application_master_catalog, nac$network_subcatalog,
          nac$application_catalog, nac$application_job_catalog],
    application_job_file_path: [READ, STATIC, oss$job_paged_literal] array [1 .. 6] of pft$name :=
          [nac$application_family, nac$application_master_catalog, nac$network_subcatalog,
          nac$application_catalog, nac$application_job_catalog, * ],
    attach_application_file: [READ, oss$job_paged_literal] string (23) := 'ATTACH_APPLICATION_FILE',
    attributes_parameter: [READ, oss$job_paged_literal] string (10) := 'ATTRIBUTES',
    change_client: [READ, oss$job_paged_literal] string (13) := 'CHANGE_CLIENT',
    change_server: [READ, oss$job_paged_literal] string (13) := 'CHANGE_SERVER',
    change_tcpip: [READ, oss$job_paged_literal] string (12) := 'CHANGE_TCPIP',
    client: [READ, oss$job_paged_literal] string (6) := 'CLIENT',
    cycle_1: [READ, oss$job_paged_literal] pft$cycle_selector :=
          [pfc$specific_cycle, pfc$minimum_cycle_number],
    cycle_1_purged: [READ, oss$job_paged_literal] string (47) :=
          'Cycle 1 of application definitions file purged.',
    cycle_2: [READ, oss$job_paged_literal] pft$cycle_selector :=
          [pfc$specific_cycle, pfc$minimum_cycle_number + 1],
    deactivate_client#: [READ, oss$job_paged_literal] string (17) := 'DEACTIVATE_CLIENT',
    deactivate_server#: [READ, oss$job_paged_literal] string (17) := 'DEACTIVATE_SERVER',
    deactivate_tcpip#: [READ, oss$job_paged_literal] string (16) := 'DEACTIVATE_TCPIP',
    default_directory_password: [READ, oss$job_paged_literal] nat$directory_password := 0,
    default_password: [READ, oss$job_paged_literal] pft$password := '',
    define_client: [READ, oss$job_paged_literal] string (13) := 'DEFINE_CLIENT',
    define_server: [READ, oss$job_paged_literal] string (13) := 'DEFINE_SERVER',
    define_tcpip: [READ, oss$job_paged_literal] string (12) := 'DEFINE_TCPIP',
    delete_client: [READ, oss$job_paged_literal] string (13) := 'DELETE_CLIENT',
    delete_server: [READ, oss$job_paged_literal] string (13) := 'DELETE_SERVER',
    delete_tcpip: [READ, oss$job_paged_literal] string (12) := 'DELETE_TCPIP',
    delete_server_title: [READ, oss$job_paged_literal] string (23) := 'NAP$DELETE_SERVER_TITLE',
    highest_cycle: [READ, oss$job_paged_literal] pft$cycle_selector := [pfc$highest_cycle],
    highest_cycle_id: amt$file_identifier,
    highest_cycle_open: boolean := FALSE,
    initialize_access_control: [READ, oss$job_paged_literal] nlt$access_control := [0, FALSE, 0],
    job_file_access_selections: [READ, oss$job_paged_literal] array [1 .. 2] of
          fst$attachment_option := [[fsc$create_file, FALSE],
          [fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$read]],
          [fsc$specific_share_modes, [fsc$read, fsc$execute]]]],
    manage_network_applications: [READ, oss$job_paged_literal] string (35) :=
          'MANAGE_NETWORK_APPLICATIONS UTILITY',
    old_application_file: ^SEQ ( * ),
    server: [READ, oss$job_paged_literal] string (6) := 'SERVER',
    tcpip: [READ, oss$job_paged_literal] string (5) := 'TCPIP',
    verify_application_id: [READ, oss$job_paged_literal] string (25) := 'NAP$VERIFY_APPLICATION_ID';

?? TITLE := 'activate_client', EJECT ??
  PROCEDURE activate_client
    (    client_attributes: ^nat$client_attributes;
     VAR status: ost$status);

{ The client attributes list has to be locked by the caller.

    status.normal := TRUE;
    IF NOT client_attributes^.sap_open THEN
      assign_sap_identifier (client_attributes^.reserved_application_id, client_attributes^.
            application_id.osi_sap_identifier, status);
      IF status.normal THEN
        nlp$se_open_sap (nac$nil, FALSE, client_attributes^.max_connections, status);
        IF status.normal THEN
          client_attributes^.sap_open := TRUE;
        ELSE
          unassign_sap_identifier (client_attributes^.application_id.osi_sap_identifier);
        IFEND;
      IFEND;
    IFEND;

  PROCEND activate_client;
?? TITLE := 'activate_server', EJECT ??
  PROCEDURE activate_server
    (    server_attributes: ^nat$server_attributes;
     VAR status: ost$status);

    VAR
      domain: nat$title_domain,
      i: integer,
      protocol: nat$protocol,
      server_title: ^nat$server_title,
      osi_address: nat$osi_registration_address,
      user_identifier: ost$name;

{ The server attributes list has to be locked by the caller.

    IF NOT server_attributes^.sap_open THEN
      assign_sap_identifier (server_attributes^.reserved_application_id, server_attributes^.
            application_id.osi_sap_identifier, status);
      IF status.normal THEN
        nlp$se_open_sap (nac$monitor_server_connections, TRUE, server_attributes^.max_connections, status);
        IF status.normal THEN
          server_attributes^.sap_open := TRUE;
        ELSE
          unassign_sap_identifier (server_attributes^.application_id.osi_sap_identifier);
        IFEND;
      IFEND;
    IFEND;

    IF server_attributes^.sap_open THEN
      IF server_attributes^.server_titles <> NIL THEN
        osi_address.kind := nac$osi_transport_address;
        osi_address.transport_selector := server_attributes^.application_id.osi_sap_identifier;

        domain.kind := nac$catenet_domain;

        IF server_attributes^.protocol = nac$cdna_virtual_terminal THEN
          protocol := nac$cdna_virtual_terminal;
        ELSE
          protocol := nac$cdna_session;
        IFEND;

      /selected_titles/
        FOR i := 1 TO UPPERBOUND (server_attributes^.server_titles^) DO
          server_title := ^server_attributes^.server_titles^ [i];
          user_identifier := server_attributes^.server;
          nlp$register_title (server_title^.title, osi_address, protocol,
                ^server_title^.data, server_title^.data_length, server_title^.priority, domain,
                server_title^.distribute_title, nac$cdna_external, default_directory_password,
                user_identifier, server_title^.directory_id, status);
          IF NOT status.normal THEN
            nap$display_message (status);
            deactivate_server (server_attributes, TRUE);
            EXIT /selected_titles/;
          IFEND;
        FOREND /selected_titles/;
      IFEND;
    IFEND;

    IF (status.normal) AND (NOT server_attributes^.nam_initiated_server) THEN
      server_attributes^.protocol_activated := TRUE;
    IFEND;

  PROCEND activate_server;

?? TITLE := 'assign_sap_identifier', EJECT ??

  PROCEDURE assign_sap_identifier
    (    reserved_sap: boolean;
     VAR sap_identifier { input, output} : nlt$ta_sap_selector;
     VAR status: ost$status);

    VAR
      i: integer;

    status.normal := TRUE;
    osp$set_job_signature_lock (nav$assigned_sap_list.lock);
    IF reserved_sap THEN
      IF (sap_identifier >= LOWERBOUND (nav$assigned_sap_list.reserved_sap)) AND
            (sap_identifier <= UPPERBOUND (nav$assigned_sap_list.reserved_sap)) THEN
        IF nav$assigned_sap_list.reserved_sap [sap_identifier] = nac$unassigned THEN
          nav$assigned_sap_list.reserved_sap [sap_identifier] := nac$assigned;
        ELSE { sap identifier already assigned
          osp$set_status_condition ( nae$sap_already_open,  status);
          osp$append_status_integer (osc$status_parameter_delimiter, sap_identifier, 10, TRUE, status);
        IFEND;
      ELSE { invalid reserved sap identifier
        osp$set_status_condition ( nae$invalid_reserved_sap,  status);
      IFEND;
    ELSE { non reserved sap
    /search_for_available_sap/
      BEGIN
        i := nav$assigned_sap_list.last_assigned_sap;
        REPEAT
          i := i + 1;
          IF i > UPPERBOUND (nav$assigned_sap_list.sap) THEN
            i := LOWERBOUND (nav$assigned_sap_list.sap);
          IFEND;
          IF nav$assigned_sap_list.sap [i] = nac$unassigned THEN
            nav$assigned_sap_list.sap [i] := nac$assigned;
            sap_identifier := i;
            nav$assigned_sap_list.last_assigned_sap := i;
            EXIT /search_for_available_sap/;
          IFEND;
        UNTIL i = nav$assigned_sap_list.last_assigned_sap;
        osp$set_status_condition ( nae$maximum_saps_open,  status);
      END /search_for_available_sap/;
    IFEND;
    osp$clear_job_signature_lock (nav$assigned_sap_list.lock);
  PROCEND assign_sap_identifier;
?? TITLE := 'attach_server_application', EJECT ??

  PROCEDURE attach_server_application
    (    system_job_name: jmt$system_supplied_name;
         server: nat$application_name;
         max_connections: nat$number_of_connections;
     VAR status: ost$status);

    VAR
      server_job_attributes: ^nat$server_job_attributes,
      connection_count: nat$number_of_connections,
      duplicate_sign_on: boolean,
      i: integer,
      ignore_status: ost$status,
      server_attributes: ^nat$server_attributes;


    status.normal := TRUE;

    nap$find_server_attributes (server, server_attributes);
    IF server_attributes = NIL THEN
      osp$set_status_abnormal (nac$status_id, nae$unknown_application, server, status);
    ELSE
      nlp$get_exclusive_access (server_attributes^.access_control);
      nap$validate_user (server_attributes^.server_capability, server_attributes^.server_ring,
            server_attributes^.server_system_privilege, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application, server, status);
      ELSEIF server_attributes^.server_status = nac$application_inactive THEN
        osp$set_status_abnormal (nac$status_id, nae$application_inactive, server, status);
      ELSE
        IF (NOT server_attributes^.nam_initiated_server) THEN
          server_job_attributes := server_attributes^.server_job_list;

          connection_count := 0;
          duplicate_sign_on := FALSE;
          WHILE server_job_attributes <> NIL DO
            IF server_job_attributes^.job_name = system_job_name THEN
              duplicate_sign_on := TRUE;
            IFEND;
            connection_count := connection_count + server_job_attributes^.max_connections_per_server_job;
            server_job_attributes := server_job_attributes^.next_entry;
          WHILEND;

          IF duplicate_sign_on THEN
            osp$set_status_abnormal (nac$status_id, nae$appl_already_attached, server, status);
          ELSEIF connection_count >= server_attributes^.max_connections THEN
            osp$set_status_abnormal (nac$status_id, nae$application_attach_limit, server, status);
          ELSE
            IF NOT server_attributes^.protocol_activated THEN
              activate_server (server_attributes, status);
            IFEND;

            IF status.normal THEN
              REPEAT
                ALLOCATE server_job_attributes IN nav$network_paged_heap^;
                IF server_job_attributes = NIL THEN
                  osp$end_subsystem_activity;
                  syp$cycle;
                  osp$begin_subsystem_activity;
                IFEND;
              UNTIL server_job_attributes <> NIL;
              server_job_attributes^.job_name := system_job_name;
              server_job_attributes^.job_status := nac$server_job_attached;
              server_job_attributes^.time_stamp := 0;
              server_job_attributes^.assigned_connection_count := 0;
              IF max_connections = 0 THEN
                server_job_attributes^.max_connections_per_server_job := server_attributes^.max_connections;
              ELSE
                server_job_attributes^.max_connections_per_server_job := max_connections;
              IFEND;

              server_job_attributes^.connection_count := 0;
              server_job_attributes^.next_entry := server_attributes^.server_job_list;
              server_attributes^.server_job_list := server_job_attributes;
            IFEND;
          IFEND;
        ELSE

{ Nam initiated server, find the matching initiated saj attributes.

        /await_saj_initialization/
          WHILE TRUE DO
            server_job_attributes := server_attributes^.server_job_list;

          /find_matching_saj/
            WHILE (server_job_attributes <> NIL) AND (server_job_attributes^.job_name <> system_job_name) DO
              server_job_attributes := server_job_attributes^.next_entry;
            WHILEND /find_matching_saj/;

            IF server_job_attributes <> NIL THEN
              IF server_attributes^.server_job_max_connections <> max_connections THEN
                osp$set_status_condition (nae$max_connections_mismatch, status);
              ELSE
                server_job_attributes^.max_connections_per_server_job := max_connections;
                server_job_attributes^.job_status := nac$server_job_attached;
                server_job_attributes^.time_stamp := 0;
              IFEND;
              EXIT /await_saj_initialization/;
            ELSE

{ Wait for the polling task to add the server job attributes entry to the server attributes
{ entry. This is due to a race condition between the polling task and the newly initiated job
{ that is trying to attach to the server. The polling task leaves a flag in the server attributes
{ entry to indicate that the server attributes entry update is pending. The initiated job will
{ cycle until the server attributes entry has been updated.

              IF server_attributes^.server_job_init_pending THEN
                REPEAT
                  nlp$release_exclusive_access (server_attributes^.access_control);
                  syp$cycle;
                  nlp$get_exclusive_access (server_attributes^.access_control);

{ NOTE: Since the non exclusive access to the server attributes list is not released, the
{ server attributes entry cannot be deleted in the mean time. Hence no search is neccessary
{ to find the server attributes entry again.

                  IF server_attributes^.server_status = nac$application_inactive THEN
                    osp$set_status_abnormal (nac$status_id, nae$application_inactive,
                          server_attributes^.server, status);
                    EXIT /await_saj_initialization/;
                  IFEND;
                UNTIL NOT server_attributes^.server_job_init_pending;
              ELSE
                osp$set_status_abnormal (nac$status_id, nae$unknown_application, server, status);
                EXIT /await_saj_initialization/;
              IFEND;
            IFEND;
          WHILEND /await_saj_initialization/;
        IFEND;
      IFEND;
      nlp$release_exclusive_access (server_attributes^.access_control);
    IFEND;


  PROCEND attach_server_application;
?? TITLE := 'change_file_retention', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to change the retention period of a
{   file's next to the highest cycle.

  PROCEDURE change_file_retention
    (    path: pft$path;
         retention: pft$retention;
     VAR status: ost$status);

    VAR
      change_list: array [1 .. 1] of pft$change_descriptor,
      highest_cycle: pft$cycle_number,
      previous_high_cycle: pft$cycle_selector;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      osp$set_status_from_condition (nac$status_id, condition, sfsa_p, status, ignore_status);
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    find_highest_cycle_number (path, highest_cycle, status);
    IF status.normal THEN
      change_list [1].change_type := pfc$retention_change;
      change_list [1].retention := retention;
      previous_high_cycle.cycle_option := pfc$specific_cycle;
      previous_high_cycle.cycle_number := highest_cycle - 1;
      osp$establish_block_exit_hndlr (^handle_block_exit);
      pfp$begin_system_authority;
      pfp$change (path, previous_high_cycle, default_password, change_list,
            status);
      pfp$end_system_authority;
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND change_file_retention;
?? TITLE := 'change_server_added_titles', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to build the server added titles list for
{   the new server attributes.
{ DESIGN:
{   Register each title from the old server added titles list with the new
{   title attributes and link it into the new server added titles list if the
{   title is not already registered.
{

  PROCEDURE change_server_added_titles
    (    old_added_titles: ^nat$added_title;
     VAR new_server_attributes: ^nat$server_attributes;
     VAR status: ost$status);

    VAR
      domain: nat$title_domain,
      new_added_title: ^nat$added_title,
      old_title: ^nat$added_title,
      protocol: nat$protocol,
      osi_address: nat$osi_registration_address,
      user_identifier: ost$name;

    status.normal := TRUE;
    domain.kind := nac$catenet_domain;
    protocol := new_server_attributes^.protocol;

    osi_address.kind := nac$osi_transport_address;
    osi_address.transport_selector := new_server_attributes^.application_id.osi_sap_identifier;

    old_title := old_added_titles;
    user_identifier := new_server_attributes^.server;

  /added_titles/
    WHILE old_title <> NIL DO
      REPEAT
        ALLOCATE new_added_title: [STRLENGTH (old_title^.title)] IN nav$network_paged_heap^;
        IF new_added_title = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL new_added_title <> NIL;

      new_added_title^ := old_title^;
      nlp$register_title (new_added_title^.title, osi_address, protocol, ^new_added_title^.data,
            new_added_title^.data_length, new_added_title^.priority, domain,
            new_added_title^.distribute_title, nac$cdna_external,
            default_directory_password, user_identifier, new_added_title^.identifier, status);
      IF status.normal THEN
        new_added_title^.next_title := new_server_attributes^.added_titles;
        new_server_attributes^.added_titles := new_added_title;
      ELSE
        IF (status.condition = nae$duplicate_registration) THEN

{ If the title is already registered, do not link the title into server added
{ titles list of the new server attributes.

          status.normal := TRUE;
          FREE new_added_title IN nav$network_paged_heap^;
        ELSE
          EXIT /added_titles/;
        IFEND;
      IFEND;
      old_title := old_title^.next_title;
    WHILEND /added_titles/;

  PROCEND change_server_added_titles;
?? TITLE := 'close_and_change_cycle_1', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to close cycle 1 of the application file
{   and to change it to the highest cycle of the application file.
{   The retention period of the previous highest cycle is changed to two days.

  PROCEDURE close_and_change_cycle_1
    (    file_id: amt$file_identifier;
         file_pointer: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      change_list: array [1 .. 1] of pft$change_descriptor,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      file_name: amt$local_file_name,
      highest_cycle: pft$cycle_number,
      ignore_status: ost$status,
      previous_high_cycle: pft$cycle_selector;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      osp$set_status_from_condition (nac$status_id, condition, sfsa_p, status, ignore_status);
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    find_highest_cycle_number (application_file_path, highest_cycle, status);
    IF status.normal THEN
      change_list [1].change_type := pfc$cycle_number_change;
      change_list [1].cycle_number := highest_cycle + 1;

      amp$set_segment_eoi (file_id, file_pointer, status);
      IF status.normal THEN
        bap$validate_file_identifier (file_id, file_instance, file_id_is_valid);
        file_name := file_instance^.local_file_name;
        fsp$close_file (file_id, ignore_status);
        amp$return (file_name, ignore_status);
        osp$establish_block_exit_hndlr (^handle_block_exit);
        pfp$begin_system_authority;
        pfp$change (application_file_path, cycle_1, default_password, change_list, status);
        IF status.normal THEN
          change_list [1].change_type := pfc$retention_change;
          change_list [1].retention := 2;
          previous_high_cycle.cycle_option := pfc$specific_cycle;
          previous_high_cycle.cycle_number := highest_cycle;
          pfp$change (application_file_path, previous_high_cycle, default_password, change_list, status);
        IFEND;
        pfp$end_system_authority;
        osp$disestablish_cond_handler;
      IFEND;
    IFEND;

  PROCEND close_and_change_cycle_1;
?? TITLE := 'close_cycle_1', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to close and delete cycle 1 of the
{   application definitions file.

  PROCEDURE close_cycle_1
    (    file_id: amt$file_identifier);

    VAR
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      file_name: amt$local_file_name,
      ignore_status: ost$status;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      pfp$end_system_authority;
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??

      bap$validate_file_identifier (file_id, file_instance, file_id_is_valid);
      file_name := file_instance^.local_file_name;
      fsp$close_file (file_id, ignore_status);
      amp$return (file_name, ignore_status);
      osp$establish_block_exit_hndlr (^handle_block_exit);
      pfp$begin_system_authority;
      pfp$purge (application_file_path, cycle_1, default_password,
            ignore_status);
      pfp$end_system_authority;
      osp$disestablish_cond_handler;
  PROCEND close_cycle_1;
?? TITLE := 'convert_v10_client_to_v11', EJECT ??
  PROCEDURE convert_v10_client_to_v11
    (VAR v10_client_definition: ^nat$complete_client_definition;
     VAR v11_client_definition: ^nat$complete_client_definition);

{ This procedure converts a version 1.0 client definition into a version 1.1 definition. The new
{ definition is placed in a sequence allocated in the task private heap. It is the responsibility of
{ the calling procedure to free this space when it is no longer needed.

    VAR
      v10_client: ^nat$v10_client_definition,
      v11_client: ^nat$client_definition;

    RESET v10_client_definition;
    NEXT v10_client IN v10_client_definition;
    ALLOCATE v11_client_definition: [[nat$client_definition]] IN osv$task_private_heap^;
    NEXT v11_client IN v11_client_definition;
    v11_client^.client := v10_client^.client;
    v11_client^.client_status := v10_client^.client_status;
    IF v10_client^.protocol = nac$v10_cdna_session THEN
      v11_client^.protocol := nac$cdna_session;
    ELSEIF v10_client^.protocol = nac$v10_cdna_virtual_terminal THEN
      v11_client^.protocol := nac$cdna_virtual_terminal;
    ELSE
      v11_client^.protocol := nac$unknown_protocol;
    IFEND;
    v11_client^.reserved_application_id := v10_client^.reserved_application_id;
    v11_client^.application_id := v10_client^.application_id;
    v11_client^.max_connections := v10_client^.max_connections;
    v11_client^.client_capability := v10_client^.client_capability;
    v11_client^.client_ring := v10_client^.client_ring;
    v11_client^.client_system_privilege := v10_client^.client_system_privilege;
    v11_client^.message_priority := nac$default_message_priority;
    v11_client^.flags.nam_accounting := false;

  PROCEND convert_v10_client_to_v11;
?? TITLE := 'convert_v10_server_to_v11', EJECT ??
  PROCEDURE convert_v10_server_to_v11
    (VAR v10_server_definition: ^nat$complete_server_definition;
     VAR v11_server_definition: ^nat$complete_server_definition);

{ This procedure converts a version 1.0 server definition into a version 1.1 definition. The new
{ definition is placed in a sequence allocated in the task private heap. It is the responsibility of
{ the calling procedure to free this space when it is no longer needed.

    VAR
      i: integer,
      size_of_client_addresses: integer,
      size_of_selected_titles: integer,
      v10_client_addresses: ^array [1 .. * ] of nat$v10_client_address,
      v11_client_addresses: ^array [1 .. * ] of nat$client_address,
      v10_server: ^nat$v10_server_definition,
      v11_server: ^nat$server_definition,
      v10_titles: ^nat$v10_selected_titles_list,
      v11_titles: ^nat$selected_titles_list;

    RESET v10_server_definition;
    NEXT v10_server IN v10_server_definition;
    size_of_selected_titles := #SIZE (nat$selected_title) * v10_server^.title_count;
    size_of_client_addresses := #SIZE (nat$client_address) * v10_server^.client_address_count;
    ALLOCATE v11_server_definition: [[REP (#SIZE (nat$server_definition) + size_of_selected_titles +
          size_of_client_addresses) OF cell]] IN osv$task_private_heap^;
    NEXT v11_server IN v11_server_definition;
    v11_server^.server := v10_server^.server;
    v11_server^.server_status := v10_server^.server_status;
    v11_server^.max_connections := v10_server^.max_connections;
    v11_server^.title_count := v10_server^.title_count;
    IF v11_server^.title_count > 0 THEN
      v10_titles := #PTR (v10_server^.selected_titles, v10_server_definition^);
      NEXT v11_titles: [1 .. v11_server^.title_count] IN v11_server_definition;
      FOR i := LOWERBOUND (v10_titles^) TO UPPERBOUND (v10_titles^) DO
        v11_titles^ [i].title := v10_titles^ [i].title;
        v11_titles^ [i].distribute_title := v10_titles^ [i].distribute_title;
        v11_titles^ [i].priority := nac$max_directory_priority;
        v11_titles^ [i].data_length := 0;
      FOREND;
      v11_server^.selected_titles := #REL (v11_titles, v11_server_definition^);
    IFEND;
    v11_server^.server_managed_title_count := 0;
    v11_server^.server_capability := v10_server^.server_capability;
    v11_server^.server_ring := v10_server^.server_ring;
    v11_server^.server_system_privilege := v10_server^.server_system_privilege;
    v11_server^.accept_connection := v10_server^.accept_connection;
    v11_server^.client_validation_capability := v10_server^.client_validation_capability;
    v11_server^.client_info_source := v10_server^.client_info_source;
    v11_server^.client_address_count := v10_server^.client_address_count;
    IF v11_server^.client_address_count > 0 THEN
      v10_client_addresses := #PTR (v10_server^.client_addresses, v10_server_definition^);
      NEXT v11_client_addresses: [1 .. v11_server^.client_address_count] IN v11_server_definition;
      FOR i := LOWERBOUND (v10_client_addresses^) TO UPPERBOUND (v10_client_addresses^) DO
        v11_client_addresses^ [i].network_id := v10_client_addresses^ [i].network_id;
        v11_client_addresses^ [i].system_kind := nac$any_system_kind;
        v11_client_addresses^ [i].system_id := v10_client_addresses^ [i].system_id;
        v11_client_addresses^ [i].reserved_application_id := v10_client_addresses^ [i].
              reserved_application_id;
        v11_client_addresses^ [i].application_id := v10_client_addresses^ [i].application_id;
      FOREND;
      v11_server^.client_addresses := #REL (v11_client_addresses, v11_server_definition^);
    IFEND;
    v11_server^.reserved_application_id := v10_server^.reserved_application_id;
    v11_server^.application_id := v10_server^.application_id;
    IF v10_server^.protocol = nac$v10_cdna_session THEN
      v11_server^.protocol := nac$cdna_session;
    ELSEIF v10_server^.protocol = nac$v10_cdna_virtual_terminal THEN
      v11_server^.protocol := nac$cdna_virtual_terminal;
    ELSE
      v11_server^.protocol := nac$unknown_protocol;
    IFEND;
    v11_server^.message_priority := nac$default_message_priority;
    v11_server^.flags.nam_accounting := false;
    v11_server^.nam_initiated_server := v10_server^.nam_initiated_server;
    v11_server^.server_job_validation_source := v10_server^.server_job_validation_source;
    v11_server^.server_job_max_connections := v10_server^.server_job_max_connections;
    v11_server^.service_file_defined := v10_server^.service_file_defined;

  PROCEND convert_v10_server_to_v11;
?? TITLE := 'deactivate_client', EJECT ??
  PROCEDURE deactivate_client
    (    client_attributes: ^nat$client_attributes;
         terminate_active_connections: boolean);

    VAR
      client_connection: ^nat$client_connection_attribute,
      connection_released: boolean,
      ignore_status: ost$status,
      previous_client_connection: ^^nat$client_connection_attribute;

{ It is assumed that the client attributes list has been locked by the caller.

    IF terminate_active_connections THEN
      client_connection := client_attributes^.client_connections_list;
      previous_client_connection := ^client_attributes^.client_connections_list;
      WHILE client_connection <> NIL DO
        nap$se_terminate_connection (client_connection^.connection_id, nac$application_deactivated, TRUE,
              connection_released, ignore_status);
        IF connection_released THEN
          previous_client_connection^ := client_connection^.next_entry;
          FREE client_connection IN nav$network_paged_heap^;
          client_attributes^.connection_count := client_attributes^.connection_count - 1;
          client_connection := previous_client_connection^;
        ELSE
          client_connection := client_connection^.next_entry;
        IFEND;
      WHILEND;
    IFEND;

    IF (client_attributes^.sap_open) AND (client_attributes^.client_connections_list = NIL) THEN
      nlp$se_close_sap (client_attributes^.application_id, ignore_status);
      unassign_sap_identifier (client_attributes^.application_id.osi_sap_identifier);
      IF NOT client_attributes^.reserved_application_id THEN
        client_attributes^.application_id.osi_sap_identifier := 0;
      IFEND;
      client_attributes^.sap_open := FALSE;
    IFEND;

  PROCEND deactivate_client;
?? TITLE := 'deactivate_server', EJECT ??
  PROCEDURE deactivate_server
    (    server_attributes: ^nat$server_attributes;
         terminate_active_connections: boolean);

    VAR
      acquire_in_progress: ^nat$server_connection_attribute,
      added_title: ^nat$added_title,
      assigned_connection: ^nat$server_connection_attribute,
      connection_released: boolean,
      ignore_status: ost$status,
      i: integer,
      next_assigned_connection: ^nat$server_connection_attribute,
      next_title: ^nat$added_title,
      previous_job_attributes: ^^nat$server_job_attributes,
      previous_server_connection: ^^nat$server_connection_attribute,
      server_titles: ^nat$server_titles_list,
      server_connection: ^nat$server_connection_attribute,
      server_job_attributes: ^nat$server_job_attributes;

{ It is assumed that the server attributes list has been locked by the caller.

    IF server_attributes^.server_titles <> NIL THEN
      server_titles := server_attributes^.server_titles;
      FOR i := LOWERBOUND (server_titles^) TO UPPERBOUND (server_titles^) DO
        nlp$delete_registered_title (server_titles^ [i].title, default_directory_password,
              server_titles^ [i].directory_id, ignore_status);
      FOREND;
    IFEND;
    added_title := server_attributes^.added_titles;
    WHILE added_title <> NIL DO
      nlp$delete_registered_title (added_title^.title, default_directory_password, added_title^.identifier,
            ignore_status);
      next_title := added_title^.next_title;
      FREE added_title IN nav$network_paged_heap^;
      added_title := next_title;
    WHILEND;
    server_attributes^.added_titles := NIL;

    IF terminate_active_connections THEN

{    Terminate all server connections.

      server_connection := server_attributes^.server_connections_list;
      previous_server_connection := ^server_attributes^.server_connections_list;
      WHILE server_connection <> NIL DO
        nap$se_terminate_connection (server_connection^.connection_id, nac$application_deactivated, TRUE,
              connection_released, ignore_status);
        IF connection_released THEN
          previous_server_connection^ := server_connection^.next_entry;
          FREE server_connection IN nav$network_paged_heap^;
          server_attributes^.connection_count := server_attributes^.connection_count - 1;
          server_connection := previous_server_connection^;
        ELSE
          server_connection := server_connection^.next_entry;
        IFEND;
      WHILEND;

    IFEND;

{   Terminate connections assigned to the server.

    assigned_connection := server_attributes^.assigned_connections_list;
    WHILE assigned_connection <> NIL DO
      nap$se_terminate_connection (assigned_connection^.connection_id, nac$application_deactivated, FALSE,
            connection_released, ignore_status);
      next_assigned_connection := assigned_connection^.next_entry;
      FREE assigned_connection IN nav$network_paged_heap^;
      assigned_connection := next_assigned_connection;
      server_attributes^.connection_count := server_attributes^.connection_count - 1;
    WHILEND;
    server_attributes^.assigned_connections_list := NIL;

{ Mark the connections in the acquire_in_progress queue to be terminated by the
{ acquiring task. These connections cannot be terminated here because we do not
{ know it there is a file associated with the connection.

    acquire_in_progress := server_attributes^.acquire_in_progress;
    WHILE acquire_in_progress <> NIL DO
      acquire_in_progress^.terminate_connection := TRUE;
      acquire_in_progress := acquire_in_progress^.next_entry;
    WHILEND;

    server_job_attributes := server_attributes^.server_job_list;
    previous_job_attributes := ^server_attributes^.server_job_list;
    WHILE server_job_attributes <> NIL DO
      IF server_job_attributes^.job_status = nac$server_job_initiated THEN
        previous_job_attributes^ := server_job_attributes^.next_entry;
        FREE server_job_attributes IN nav$network_paged_heap^;
        server_job_attributes := previous_job_attributes^;
      ELSE
        server_job_attributes^.job_status := nac$server_job_deactivated;
        server_job_attributes^.assigned_connection_count := 0;
        previous_job_attributes := ^server_job_attributes^.next_entry;
        server_job_attributes := server_job_attributes^.next_entry;
      IFEND;
    WHILEND;

    IF (server_attributes^.sap_open) AND
          (server_attributes^.server_connections_list = NIL) AND
          (server_attributes^.acquire_in_progress = NIL) AND
          (server_attributes^.assigned_connections_list = NIL) THEN
      nlp$se_close_sap (server_attributes^.application_id, ignore_status);
      unassign_sap_identifier (server_attributes^.application_id.osi_sap_identifier);
      IF NOT server_attributes^.reserved_application_id THEN
        server_attributes^.application_id.osi_sap_identifier := 0;
      IFEND;
      server_attributes^.sap_open := FALSE;
    IFEND;

    IF NOT server_attributes^.nam_initiated_server THEN
      server_attributes^.protocol_activated := FALSE;
    IFEND;

  PROCEND deactivate_server;

?? TITLE := 'deactivate_tcpip', EJECT ??

{
{    The purpose of this procedure is to terminate assigned sockets.
{


  PROCEDURE deactivate_tcpip
    (    application: nat$application_name;
         protocol: nat$protocol;
         terminate_active_sockets: boolean;
         tcp_socket_list: ^array [1 .. * ] of nat$tcp_socket;
         udp_socket_list: ^array [1 .. * ] of nat$udp_socket);



    VAR
      connection_id: nat$connection_id,
      global_socket_id: nlt$udp_global_socket_id,
      i: integer,
      ignore_status: ost$status;

    IF protocol = nac$stream_socket THEN
      nlp$sk_tcp_terminate_all_listen (application);

      IF tcp_socket_list <> NIL THEN
        FOR i := 1 TO UPPERBOUND (tcp_socket_list^) DO
          IF (NOT tcp_socket_list^ [i].socket_assigned) OR
                (terminate_active_sockets) THEN
            nlp$sk_tcp_terminate_socket (tcp_socket_list^ [i] .connection_id);
            nlp$tcpip_decrement_appl_access (application, global_socket_id,
                 tcp_socket_list^ [i] .connection_id, ignore_status);
          IFEND;
        FOREND;
      IFEND;
    ELSE

      IF (terminate_active_sockets) AND (udp_socket_list <> NIL) THEN
        FOR i := 1 TO UPPERBOUND (udp_socket_list^) DO
          nlp$udp_close_socket (udp_socket_list^ [i] .global_socket_id, true);
          nlp$tcpip_decrement_appl_access (application,
                udp_socket_list^ [i] .global_socket_id, connection_id,
                ignore_status);
        FOREND;
      IFEND;
    IFEND;

  PROCEND deactivate_tcpip;
?? TITLE := 'define_client_attributes_entry', EJECT ??
  PROCEDURE define_client_attributes_entry
    (    client_definition: ^nat$client_definition;
     VAR client_attributes: ^nat$client_attributes);

    REPEAT
      ALLOCATE client_attributes IN nav$network_paged_heap^;
      IF client_attributes = NIL THEN
        syp$cycle;
      IFEND;
    UNTIL client_attributes <> NIL;
    client_attributes^.access_control := initialize_access_control;
    client_attributes^.next_entry := NIL;
    client_attributes^.client := client_definition^.client;
    client_attributes^.client_status := client_definition^.client_status;
    client_attributes^.client_capability := client_definition^.client_capability;
    client_attributes^.client_ring := client_definition^.client_ring;
    client_attributes^.client_system_privilege := client_definition^.client_system_privilege;
    client_attributes^.max_connections := client_definition^.max_connections;
    client_attributes^.connection_count := 0;
    client_attributes^.attempted_connection_count := 0;
    client_attributes^.rejected_connection_attempts := 0;
    client_attributes^.protocol := client_definition^.protocol;
    client_attributes^.message_priority := client_definition^.message_priority;
    client_attributes^.flags.nam_accounting := false;
    client_attributes^.reserved_application_id := client_definition^.reserved_application_id;
    IF client_attributes^.reserved_application_id THEN
      client_attributes^.application_id.xns_sap_identifier := client_definition^.application_id;
      client_attributes^.application_id.osi_sap_identifier := (client_definition^.application_id -
            minimum_xns_sap_identifier) + nlc$ta_min_rsvd_se_session_sap;
    IFEND;
    client_attributes^.sap_open := FALSE;
    client_attributes^.client_connections_list := NIL;

  PROCEND define_client_attributes_entry;
?? TITLE := 'define_server_attributes_entry', EJECT ??
  PROCEDURE define_server_attributes_entry
    (VAR complete_server_definition: ^nat$complete_server_definition;
     VAR server_attributes: ^nat$server_attributes);

    VAR
      binary_mainframe_id: pmt$binary_mainframe_id,
      client_addresses: ^array [1 .. * ] of nat$client_address,
      i: integer,
      selected_titles: ^nat$selected_titles_list,
      server_definition: ^nat$server_definition,
      server_managed_titles: ^nat$title_pattern_list,
      timesharing_title: ost$name,
      title_count: integer;

    RESET complete_server_definition;
    NEXT server_definition IN complete_server_definition;
    REPEAT
      ALLOCATE server_attributes IN nav$network_paged_heap^;
      IF server_attributes = NIL THEN
        syp$cycle;
      IFEND;
    UNTIL server_attributes <> NIL;
    server_attributes^.access_control := initialize_access_control;
    server_attributes^.next_entry := NIL;
    server_attributes^.server := server_definition^.server;
    server_attributes^.server_status := server_definition^.server_status;
    server_attributes^.max_connections := server_definition^.max_connections;
    IF (server_definition^.title_count > 0) OR (server_definition^.server = osc$timesharing) THEN
      selected_titles := #PTR (server_definition^.selected_titles, complete_server_definition^);
      IF server_definition^.server = osc$timesharing THEN
        title_count := server_definition^.title_count + 1;
      ELSE
        title_count := server_definition^.title_count;
      IFEND;
      REPEAT
        ALLOCATE server_attributes^.server_titles: [1 .. title_count] IN
              nav$network_paged_heap^;
        IF server_attributes^.server_titles = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL server_attributes^.server_titles <> NIL;
      FOR i := 1 TO server_definition^.title_count DO
        server_attributes^.server_titles^ [i].title := selected_titles^ [i].title;
        server_attributes^.server_titles^ [i].distribute_title := selected_titles^ [i].distribute_title;
        server_attributes^.server_titles^ [i].priority := selected_titles^ [i].priority;
        server_attributes^.server_titles^ [i].data_length := selected_titles^ [i].data_length;
        server_attributes^.server_titles^ [i].data := selected_titles^ [i].data;
      FOREND;
      IF server_definition^.server = osc$timesharing THEN
        pmp$get_pseudo_mainframe_id (binary_mainframe_id);
        jmp$generate_timesharing_title (binary_mainframe_id, timesharing_title);
        server_attributes^.server_titles^ [title_count].title := timesharing_title;
        server_attributes^.server_titles^ [title_count].distribute_title := FALSE;
        server_attributes^.server_titles^ [title_count].priority := nac$max_directory_priority;
        server_attributes^.server_titles^ [title_count].data_length := 0;
      IFEND;
    ELSE
      server_attributes^.server_titles := NIL;
    IFEND;
    IF server_definition^.server_managed_title_count > 0 THEN
      server_managed_titles := #PTR (server_definition^.server_managed_titles, complete_server_definition^);
      REPEAT
        ALLOCATE server_attributes^.server_managed_titles: [1 .. server_definition^.
              server_managed_title_count] IN nav$network_paged_heap^;
        IF server_attributes^.server_managed_titles = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL server_attributes^.server_managed_titles <> NIL;
      FOR i := 1 TO server_definition^.server_managed_title_count DO
        server_attributes^.server_managed_titles^ [i] := server_managed_titles^ [i];
      FOREND;
    ELSE
      server_attributes^.server_managed_titles := NIL;
    IFEND;

    server_attributes^.added_titles := NIL;
    server_attributes^.server_capability := server_definition^.server_capability;
    server_attributes^.server_ring := server_definition^.server_ring;
    server_attributes^.server_system_privilege := server_definition^.server_system_privilege;
    server_attributes^.accept_connection := server_definition^.accept_connection;
    server_attributes^.client_validation_capability := server_definition^.client_validation_capability;
    server_attributes^.client_info_source := server_definition^.client_info_source;
    IF server_definition^.client_address_count > 0 THEN
      client_addresses := #PTR (server_definition^.client_addresses, complete_server_definition^);
      REPEAT
        ALLOCATE server_attributes^.client_addresses: [1 .. server_definition^.client_address_count] IN
              nav$network_paged_heap^;
        IF server_attributes^.client_addresses = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL server_attributes^.client_addresses <> NIL;
      server_attributes^.client_addresses^ := client_addresses^;
    ELSE
      server_attributes^.client_addresses := NIL;
    IFEND;

    server_attributes^.reserved_application_id := server_definition^.reserved_application_id;
    IF server_attributes^.reserved_application_id THEN
      server_attributes^.application_id.xns_sap_identifier := server_definition^.application_id;
      server_attributes^.application_id.osi_sap_identifier := (server_definition^.application_id -
            minimum_xns_sap_identifier) + nlc$ta_min_rsvd_se_session_sap;
    IFEND;
    server_attributes^.sap_open := FALSE;
    server_attributes^.message_priority := server_definition^.message_priority;
    server_attributes^.flags.nam_accounting := false;
    server_attributes^.protocol := server_definition^.protocol;
    server_attributes^.server_connections_list := NIL;
    server_attributes^.connection_count := 0;
    server_attributes^.attempted_connection_count := 0;
    server_attributes^.rejected_connection_attempts := 0;
    server_attributes^.wait_for_connection := NIL;
    server_attributes^.assigned_connections_list := NIL;
    server_attributes^.acquire_in_progress := NIL;
    server_attributes^.server_job_list := NIL;
    server_attributes^.nam_initiated_server := server_definition^.nam_initiated_server;
    IF server_attributes^.nam_initiated_server THEN
      server_attributes^.server_job_validation_source := server_definition^.server_job_validation_source;
      server_attributes^.server_job_max_connections := server_definition^.server_job_max_connections;
      server_attributes^.service_file_defined := server_definition^.service_file_defined;
      server_attributes^.server_job_init_pending := FALSE;
    ELSE
      server_attributes^.protocol_activated := FALSE;
    IFEND;

  PROCEND define_server_attributes_entry;
?? TITLE := 'define_server_job_file', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to define a file by the server name to hold
{   the scl commands that make up the server job.

  PROCEDURE define_server_job_file
    (    path: pft$path;
         server_job: amt$local_file_name;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      output_creation_attributes: array [1 .. 1] of fst$file_cycle_attribute,
      unique_name: ost$name;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      osp$set_status_from_condition (nac$status_id, condition, sfsa_p, status, ignore_status);
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    pmp$get_unique_name (unique_name, ignore_status);
    osp$establish_block_exit_hndlr (^handle_block_exit);
    pfp$begin_system_authority;
    pfp$define (unique_name, path, highest_cycle,
          default_password, pfc$maximum_retention, pfc$no_log, status);
    IF NOT status.normal THEN
      pfp$end_system_authority;
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

{ Change the ring attributes so that the server job file is readable from
{ ring 13.

    output_creation_attributes [1].selector := fsc$ring_attributes;
    output_creation_attributes [1].ring_attributes.r1 := osc$tsrv_ring;
    output_creation_attributes [1].ring_attributes.r2 := osc$user_ring_2;
    output_creation_attributes [1].ring_attributes.r3 := osc$user_ring_2;
    fsp$copy_file (server_job, unique_name, NIL, NIL, ^output_creation_attributes, status);
    IF NOT status.normal THEN
      pfp$purge (path, highest_cycle, default_password,
            ignore_status);
    IFEND;
    pfp$end_system_authority;
    osp$disestablish_cond_handler;
    amp$return (unique_name, ignore_status);

  PROCEND define_server_job_file;
?? TITLE := 'define_tcpip_attributes_entry', EJECT ??

{
{    The purpose of this procedure is to initialize the attributes
{    entry for a tcpip application.
{

  PROCEDURE define_tcpip_attributes_entry
    (    tcpip_definition: ^nat$tcpip_definition;
     VAR tcpip_attributes: ^nat$tcpip_attributes);

    REPEAT
      ALLOCATE tcpip_attributes IN nav$network_paged_heap^;
      IF tcpip_attributes = NIL THEN
        syp$cycle;
      IFEND;
    UNTIL tcpip_attributes <> NIL;
    tcpip_attributes^.access_control := initialize_access_control;
    tcpip_attributes^.next_entry := NIL;
    tcpip_attributes^.tcpip_application := tcpip_definition^.tcpip_application;
    tcpip_attributes^.tcpip_status :=
          tcpip_definition^.tcpip_status;
    tcpip_attributes^.tcpip_capability := tcpip_definition^.tcpip_capability;
    tcpip_attributes^.tcpip_ring := tcpip_definition^.tcpip_ring;
    tcpip_attributes^.tcpip_system_privilege :=
          tcpip_definition^.tcpip_system_privilege;
    tcpip_attributes^.maximum_sockets := tcpip_definition^.maximum_sockets;
    tcpip_attributes^.active_socket_count := 0;
    tcpip_attributes^.socket_attempt_count := 0;
    tcpip_attributes^.socket_reject_count := 0;
    tcpip_attributes^.protocol := tcpip_definition^.protocol;
    tcpip_attributes^.flags.nam_accounting := FALSE;
    IF tcpip_attributes^.protocol = nac$stream_socket THEN
      tcpip_attributes^.tcp_socket_list := NIL;
    ELSE
      tcpip_attributes^.udp_socket_list := NIL;
    IFEND;

  PROCEND define_tcpip_attributes_entry;
?? TITLE := 'delete_server_added_titles', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to delete the registration of the titles
{   in the added titles list.
{ NOTES:
{   It is assumed that the server attributes list has been locked by the caller.

  PROCEDURE delete_server_added_titles
    (    added_title: ^nat$added_title);

    VAR
      ignore_status: ost$status,
      next_title: ^nat$added_title;

    next_title := added_title;
    WHILE next_title <> NIL DO
      nlp$delete_registered_title (next_title^.title,
            default_directory_password, next_title^.identifier,
            ignore_status);
      next_title := next_title^.next_title;
    WHILEND;

  PROCEND delete_server_added_titles;
?? TITLE := 'delete_server_titles', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to delete the registration of the titles
{   in the server titles list.
{ NOTES:
{   It is assumed that the server attributes list has been locked by the caller.

  PROCEDURE delete_server_titles
    (    server_titles: ^nat$server_titles_list);

    VAR
      i: 1 .. 255,
      ignore_status: ost$status;

    IF server_titles <> NIL THEN
      FOR i := LOWERBOUND (server_titles^) TO UPPERBOUND (server_titles^) DO
        nlp$delete_registered_title (server_titles^ [i].title,
              default_directory_password, server_titles^ [i].directory_id,
              ignore_status);
      FOREND;
    IFEND;

  PROCEND delete_server_titles;
?? TITLE := 'detach_server_application', EJECT ??

  PROCEDURE detach_server_application
    (    system_job_name: jmt$system_supplied_name;
         server: nat$application_name;
     VAR status: ost$status);

    VAR
      previous_server_job_attributes: ^^nat$server_job_attributes,
      previous_wait_for_connection: ^^nat$wait_for_connection,
      server_attributes: ^nat$server_attributes,
      server_connection: ^nat$server_connection_attribute,
      server_job_attributes: ^nat$server_job_attributes,
      wait_for_connection: ^nat$wait_for_connection;


    status.normal := TRUE;

    nap$find_server_attributes (server, server_attributes);
    IF server_attributes = NIL THEN
      osp$set_status_abnormal (nac$status_id, nae$unknown_application, server, status);
    ELSE
      nlp$get_exclusive_access (server_attributes^.access_control);
      nap$validate_user (server_attributes^.server_capability, server_attributes^.server_ring,
            server_attributes^.server_system_privilege, status);
      IF NOT status.normal THEN
        nap$display_message (status);
        osp$set_status_abnormal (nac$status_id, nae$server_not_attached, server, status);
      ELSE
        server_job_attributes := server_attributes^.server_job_list;
        previous_server_job_attributes := ^server_attributes^.server_job_list;
        WHILE (server_job_attributes <> NIL) AND (server_job_attributes^.job_name <> system_job_name) DO
          previous_server_job_attributes := ^server_job_attributes^.next_entry;
          server_job_attributes := server_job_attributes^.next_entry;
        WHILEND;
        IF server_job_attributes = NIL THEN
          osp$set_status_abnormal (nac$status_id, nae$server_not_attached, server, status);
        ELSE
          previous_server_job_attributes^ := server_job_attributes^.next_entry;

{ Change job connections to server connections.

          IF server_job_attributes^.connection_count > 0 THEN
            server_connection := server_attributes^.server_connections_list;

          /search/
            WHILE server_connection <> NIL DO
              IF (server_connection^.connection_kind = nac$owned_by_job) AND
                    (server_connection^.job_name = server_job_attributes^.job_name) THEN
                server_connection^.connection_kind := nac$owned_by_server;
              IFEND;
              server_connection := server_connection^.next_entry;
            WHILEND /search/;
          IFEND;

          IF server_attributes^.wait_for_connection <> NIL THEN
            previous_wait_for_connection := ^server_attributes^.wait_for_connection;
            wait_for_connection := server_attributes^.wait_for_connection;
            WHILE (wait_for_connection <> NIL) AND (wait_for_connection^.job_name <> system_job_name) DO
              previous_wait_for_connection := ^wait_for_connection^.next_entry;
              wait_for_connection := wait_for_connection^.next_entry;
            WHILEND;
            IF wait_for_connection <> NIL THEN
              previous_wait_for_connection^ := wait_for_connection^.next_entry;
              FREE wait_for_connection IN nav$network_paged_heap^;

{ *** DEBUG   pmp$log ('AM - Task removed from wait for conn q.', ignore_status);

            IFEND;
          IFEND;

          FREE server_job_attributes IN nav$network_paged_heap^;

{ For a self initiated server the last job detaching from the server should also
{ deactivate the server.

          IF (NOT server_attributes^.nam_initiated_server) AND (server_attributes^.server_job_list = NIL) AND
                (server_attributes^.protocol_activated) THEN
            deactivate_server (server_attributes, FALSE);
          IFEND;
        IFEND;
      IFEND;
      nlp$release_exclusive_access (server_attributes^.access_control);
    IFEND;

  PROCEND detach_server_application;

?? TITLE := 'display_message_to_$response', EJECT ??

{ PURPOSE
{   Format and display a NOS/VE status condition.
{ DESIGN
{   The message status is formatted with calls to system routines and written
{   to the $RESPONSE file.

  PROCEDURE display_message_to_$response
    (    message_status: ost$status;
     VAR status: ost$status);

    VAR
      attachment_selections: [STATIC, READ, oss$job_paged_literal] array [1 .. 1] of
            fst$attachment_option := [[fsc$access_and_share_modes,
            [fsc$specific_access_modes, [fsc$shorten, fsc$append, fsc$modify]],
            [fsc$required_share_modes]]],
      byte_address: amt$file_byte_address,
      error_file_id: [STATIC] amt$file_identifier,
      error_file_name: [STATIC, READ, oss$job_paged_literal] amt$local_file_name := '$RESPONSE',
      error_file_opened: [STATIC] boolean := FALSE,
      ignore_status: ost$status,
      length_pointer: ^ost$status_message_line_size,
      line_count_pointer: ^ost$status_message_line_count,
      line_index: ost$status_message_line_count,
      message: ost$status_message,
      message_sequence: ^ost$status_message,
      text_pointer: ^ost$status_message_line;

    IF NOT error_file_opened THEN
      fsp$open_file (error_file_name, amc$record, ^attachment_selections,
            {default_creation_attributes =} NIL,
            {mandated_creation_attributes =} NIL, {attribute_validation =} NIL,
            {attribute_override =} NIL, error_file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      error_file_opened := TRUE;
    IFEND;

    osp$format_message (message_status, osc$current_message_level,
          osc$max_status_message_line, message, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    message_sequence := ^message;
    RESET message_sequence;
    NEXT line_count_pointer IN message_sequence;

    FOR line_index := 1 TO line_count_pointer^ DO
      NEXT length_pointer IN message_sequence;
      NEXT text_pointer: [length_pointer^] IN message_sequence;
      amp$put_next (error_file_id, text_pointer, length_pointer^, byte_address,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND display_message_to_$response;
?? TITLE := 'find_client_definition', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to find the pointer to the definition of the given client on the
{   application file. If it is not found or is in error, a NIL pointer is returned.

  PROCEDURE find_client_definition
    (    client: nat$application_name;
     VAR application_file: ^SEQ ( * );
     VAR complete_client_definition: ^nat$complete_client_definition);

    VAR
      client_definition: ^nat$client_definition,
      client_pointers: ^nat$client_pointers,
      file_header: ^nat$application_file_header,
      i: integer,
      server_pointers: ^nat$server_pointers,
      v10_client_definition: ^nat$v10_client_definition,
      v10_v11_file_header: ^nat$v10_v11_file_header;

    complete_client_definition := NIL;
    RESET application_file;
    NEXT file_header IN application_file;
    IF file_header^.version <> nac$application_file_version THEN
      RESET application_file;
      NEXT v10_v11_file_header IN application_file;
    IFEND;
    IF file_header^.server_count > 0 THEN
      NEXT server_pointers: [1 .. file_header^.server_count] IN application_file;
    IFEND;
    IF file_header^.client_count > 0 THEN
      NEXT client_pointers: [1 .. file_header^.client_count] IN application_file;

    /search/
      FOR i := 1 TO file_header^.client_count DO
        IF client_pointers^ [i].client = client THEN
          complete_client_definition := #PTR (client_pointers^ [i].pointer, application_file^);
          RESET complete_client_definition;
          IF (file_header^.version = nac$application_file_version) OR
                (file_header^.version = nac$v11_appl_file_version) THEN
            NEXT client_definition IN complete_client_definition;
            RESET complete_client_definition;
            IF (client_definition <> NIL) AND (client <> client_definition^.client) THEN
              complete_client_definition := NIL;
            IFEND;
          ELSEIF file_header^.version = nac$v10_appl_file_version THEN
            NEXT v10_client_definition IN complete_client_definition;
            RESET complete_client_definition;
            IF (v10_client_definition <> NIL) AND (client <> v10_client_definition^.client) THEN
              complete_client_definition := NIL;
            IFEND;
          ELSE
            complete_client_definition := NIL;
          IFEND;
          EXIT /search/;
        IFEND;
      FOREND /search/;
    IFEND;

  PROCEND find_client_definition;
?? TITLE := 'find_highest_cycle_number', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to find the highest cycle number of the
{   given file.

  PROCEDURE find_highest_cycle_number
    (    path: pft$path;
     VAR cycle_number: pft$cycle_number;
     VAR status: ost$status);

    VAR
      body: pft$p_info,
      catalog_info_selections: pft$catalog_info_selections,
      cycle_array: pft$p_cycle_array,
      cycle_index: pft$array_index,
      directory_array: pft$p_directory_array,
      file_info_selections: pft$file_info_selections,
      group: pft$group,
      info_record: pft$p_info_record,
      item_record: pft$p_info_record,
      local_status: ost$status,
      segment_pointer: amt$segment_pointer;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      osp$set_status_from_condition (nac$status_id, condition, sfsa_p, status, ignore_status);
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, segment_pointer, status);
    IF status.normal THEN
      cycle_array := NIL;
      group.group_type := pfc$public;
      catalog_info_selections := $pft$catalog_info_selections [];
      file_info_selections := $pft$file_info_selections [pfc$file_directory, pfc$file_description,
            pfc$file_cycles];
      osp$establish_block_exit_hndlr (^handle_block_exit);
      pfp$begin_system_authority;
      pfp$get_item_info (path, group, catalog_info_selections, file_info_selections,
            segment_pointer.sequence_pointer, status);
      pfp$end_system_authority;
      osp$disestablish_cond_handler;
      IF status.normal THEN
        RESET segment_pointer.sequence_pointer;
        pfp$find_next_info_record (segment_pointer.sequence_pointer, info_record, status);
        IF status.normal THEN
          pfp$find_directory_array (info_record, directory_array, status);
          IF status.normal AND (directory_array <> NIL) THEN
            body := ^info_record^.body;
            pfp$find_direct_info_record (body, directory_array^ [LOWERBOUND (directory_array^)].info_offset,
                  item_record, status);
            IF status.normal THEN
              pfp$find_cycle_array (item_record, cycle_array, status);
              IF status.normal THEN
                pfp$find_cycle_entry (cycle_array, highest_cycle, cycle_index, status);
                IF status.normal THEN
                  cycle_number := cycle_array^ [cycle_index].cycle_number;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    mmp$delete_scratch_segment (segment_pointer, local_status);

  PROCEND find_highest_cycle_number;
?? TITLE := 'find_server_definition', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to find the pointer to the definition of the given server on the
{   application file. If it is not found or is in error, a NIL pointer is returned.

  PROCEDURE find_server_definition
    (    server: nat$application_name;
     VAR sequence_pointer: ^SEQ ( * );
     VAR complete_server_definition: ^nat$complete_server_definition);

    VAR
      file_header: ^nat$application_file_header,
      i: integer,
      server_definition: ^nat$server_definition,
      server_pointers: ^nat$server_pointers,
      v10_server_definition: ^nat$v10_server_definition,
      v10_v11_file_header: ^nat$v10_v11_file_header;

    complete_server_definition := NIL;
    RESET sequence_pointer;
    NEXT file_header IN sequence_pointer;
    IF file_header^.version <> nac$application_file_version THEN
      RESET sequence_pointer;
      NEXT v10_v11_file_header IN sequence_pointer;
    IFEND;
    IF file_header^.server_count > 0 THEN
      NEXT server_pointers: [1 .. file_header^.server_count] IN sequence_pointer;

    /search/
      FOR i := 1 TO file_header^.server_count DO
        IF server_pointers^ [i].server = server THEN
          complete_server_definition := #PTR (server_pointers^ [i].pointer, sequence_pointer^);
          RESET complete_server_definition;
          IF (file_header^.version = nac$application_file_version) OR
                 (file_header^.version = nac$v11_appl_file_version) THEN
            NEXT server_definition IN complete_server_definition;
            RESET complete_server_definition;
            IF (server_definition <> NIL) AND (server <> server_definition^.server) THEN
              complete_server_definition := NIL;
            IFEND;
          ELSEIF file_header^.version = nac$v10_appl_file_version THEN
            NEXT v10_server_definition IN complete_server_definition;
            RESET complete_server_definition;
            IF (v10_server_definition <> NIL) AND (server <> v10_server_definition^.server) THEN
              complete_server_definition := NIL;
            IFEND;
          ELSE
            complete_server_definition := NIL;
          IFEND;
          EXIT /search/;
        IFEND;
      FOREND /search/;
    IFEND;

  PROCEND find_server_definition;
?? TITLE := 'find_tcpip_definition', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to find the pointer to the definition of the given
{   tcpip application on the application file. If it is not found or is in error,
{   a NIL pointer is returned.

  PROCEDURE find_tcpip_definition
    (    application: nat$application_name;
     VAR application_file: ^SEQ ( * );
     VAR complete_tcpip_definition: ^nat$complete_tcpip_definition);

    VAR
      client_pointers: ^nat$client_pointers,
      file_header: ^nat$application_file_header,
      i: integer,
      server_pointers: ^nat$server_pointers,
      tcpip_definition: ^nat$tcpip_definition,
      tcpip_pointers: ^nat$tcpip_pointers;

    complete_tcpip_definition := NIL;
    RESET application_file;
    NEXT file_header IN application_file;
    IF file_header^.version = nac$application_file_version THEN
      IF file_header^.server_count > 0 THEN
        NEXT server_pointers: [1 .. file_header^.server_count] IN application_file;
      IFEND;
      IF file_header^.client_count > 0 THEN
        NEXT client_pointers: [1 .. file_header^.client_count] IN application_file;
      IFEND;
      IF file_header^.tcpip_count > 0 THEN
        NEXT tcpip_pointers: [1 .. file_header^.tcpip_count] IN application_file;

      /search/
        FOR i := 1 TO file_header^.tcpip_count DO
          IF tcpip_pointers^ [i].application = application THEN
            complete_tcpip_definition := #PTR (tcpip_pointers^ [i].pointer, application_file^);
            RESET complete_tcpip_definition;
            NEXT tcpip_definition IN complete_tcpip_definition;
            RESET complete_tcpip_definition;
            IF (tcpip_definition <> NIL) AND (application <> tcpip_definition^.tcpip_application) THEN
              complete_tcpip_definition := NIL;
            IFEND;
            EXIT /search/;
          IFEND;
        FOREND /search/;
      IFEND;
    IFEND;
  PROCEND find_tcpip_definition;

?? TITLE := 'free_server_attributes', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to free the space allocated in the
{   network paged segment for the server titles, the server managed titles,
{   the client addresses and the server added titles.

  PROCEDURE free_server_attributes
    (    free_added_titles: boolean;
         free_server_titles: boolean;
     VAR server_attributes: ^nat$server_attributes);

    VAR
      added_title: ^nat$added_title,
      next_title: ^nat$added_title;

    IF free_server_titles THEN
      IF server_attributes^.server_titles <> NIL THEN
        FREE server_attributes^.server_titles IN nav$network_paged_heap^;
      IFEND;
    IFEND;

    IF server_attributes^.server_managed_titles <> NIL THEN
      FREE server_attributes^.server_managed_titles IN nav$network_paged_heap^;
    IFEND;

    IF server_attributes^.client_addresses <> NIL THEN
      FREE server_attributes^.client_addresses IN nav$network_paged_heap^;
    IFEND;

    IF free_added_titles THEN
      added_title := server_attributes^.added_titles;
      WHILE added_title <> NIL DO
        next_title := added_title^.next_title;
        FREE added_title IN nav$network_paged_heap^;
        added_title := next_title;
      WHILEND;
    IFEND;

  PROCEND free_server_attributes;
?? TITLE := 'free_server_attributes_entry', EJECT ??
  PROCEDURE [INLINE] free_server_attributes_entry
    (VAR server_attributes: ^nat$server_attributes);

    IF server_attributes^.server_titles <> NIL THEN
      FREE server_attributes^.server_titles IN nav$network_paged_heap^;
    IFEND;

    IF server_attributes^.server_managed_titles <> NIL THEN
      FREE server_attributes^.server_managed_titles IN nav$network_paged_heap^;
    IFEND;

    IF server_attributes^.client_addresses <> NIL THEN
      FREE server_attributes^.client_addresses IN nav$network_paged_heap^;
    IFEND;

    FREE server_attributes IN nav$network_paged_heap^;

  PROCEND free_server_attributes_entry;
?? TITLE := 'move_server_definition', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to move a server definition from the
{   old application definition file to the new application definition file.

  PROCEDURE move_server_definition
    (    old_server: nat$server_pointer;
     VAR new_server: nat$server_pointer;
     VAR old_application_file: ^SEQ ( * );
     VAR new_application_file: ^SEQ ( * ));

    VAR
      converted_server_definition: ^nat$complete_server_definition,
      new_server_definition: ^nat$complete_server_definition,
      old_file_header: ^nat$application_file_header,
      old_server_definition: ^nat$complete_server_definition;

    RESET old_application_file;
    NEXT old_file_header IN old_application_file;

    old_server_definition := #PTR (old_server.pointer, old_application_file^);
    IF (old_file_header^.version = nac$application_file_version) OR
          (old_file_header^.version = nac$v11_appl_file_version) THEN
      new_server.server := old_server.server;
      NEXT new_server_definition: [[REP #SIZE (old_server_definition^) OF cell]] IN new_application_file;
      new_server.pointer := #REL (new_server_definition, new_application_file^);
      new_server_definition^ := old_server_definition^;
    ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
      convert_v10_server_to_v11 (old_server_definition, converted_server_definition);
      new_server.server := old_server.server;
      NEXT new_server_definition: [[REP #SIZE (converted_server_definition^) OF cell]] IN
            new_application_file;
      new_server.pointer := #REL (new_server_definition, new_application_file^);
      new_server_definition^ := converted_server_definition^;
      FREE converted_server_definition IN osv$task_private_heap^;
    IFEND;

  PROCEND move_server_definition;
?? TITLE := 'move_client_definition', EJECT ??

{ PURPOSE:
{ The purpose of this procedure is to move a client definition from the
{ old application definition file to the new application definition file.

  PROCEDURE move_client_definition
    (    old_client: nat$client_pointer;
     VAR new_client: nat$client_pointer;
     VAR old_application_file: ^SEQ ( * );
     VAR new_application_file: ^SEQ ( * ));

    VAR
      converted_client_definition: ^nat$complete_client_definition,
      new_client_definition: ^nat$complete_client_definition,
      old_client_definition: ^nat$complete_client_definition,
      old_file_header: ^nat$application_file_header;

    RESET old_application_file;
    NEXT old_file_header IN old_application_file;

    old_client_definition := #PTR (old_client.pointer, old_application_file^);
    IF (old_file_header^.version = nac$application_file_version) OR
          (old_file_header^.version = nac$v11_appl_file_version) THEN
      new_client.client := old_client.client;
      NEXT new_client_definition: [[REP #SIZE (old_client_definition^) OF cell]] IN new_application_file;
      new_client.pointer := #REL (new_client_definition, new_application_file^);
      new_client_definition^ := old_client_definition^;
    ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
      convert_v10_client_to_v11 (old_client_definition, converted_client_definition);
      new_client.client := old_client.client;
      NEXT new_client_definition: [[REP #SIZE (converted_client_definition^) OF cell]] IN
            new_application_file;
      new_client.pointer := #REL (new_client_definition, new_application_file^);
      new_client_definition^ := converted_client_definition^;
      FREE converted_client_definition IN osv$task_private_heap^;
    IFEND;

  PROCEND move_client_definition;
?? TITLE := 'move_tcpip_definition', EJECT ??

{ PURPOSE:
{ The purpose of this procedure is to move a tcpip definition from the
{ old application definition file to the new application definition file.

  PROCEDURE move_tcpip_definition
    (    old_tcpip: nat$tcpip_pointer;
     VAR new_tcpip: nat$tcpip_pointer;
     VAR old_application_file: ^SEQ ( * );
     VAR new_application_file: ^SEQ ( * ));

    VAR
      new_tcpip_definition: ^nat$complete_tcpip_definition,
      old_file_header: ^nat$application_file_header,
      old_tcpip_definition: ^nat$complete_tcpip_definition;

    RESET old_application_file;
    NEXT old_file_header IN old_application_file;

    old_tcpip_definition := #PTR (old_tcpip.pointer, old_application_file^);
      new_tcpip.application := old_tcpip.application;
      NEXT new_tcpip_definition: [[REP #SIZE (old_tcpip_definition^) OF cell]] IN new_application_file;
      new_tcpip.pointer := #REL (new_tcpip_definition, new_application_file^);
      new_tcpip_definition^ := old_tcpip_definition^;

  PROCEND move_tcpip_definition;
?? TITLE := 'open_cycle_1', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to define cycle 1 of the application file
{   and to open it for segment access.

  PROCEDURE open_cycle_1
    (VAR file_pointer: amt$segment_pointer;
     VAR file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      unique_name: ost$name;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      osp$set_status_from_condition (nac$status_id, condition, sfsa_p, status, ignore_status);
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??

    pmp$get_unique_name (unique_name, ignore_status);
    osp$establish_block_exit_hndlr (^handle_block_exit);
    pfp$begin_system_authority;
    pfp$define (unique_name, application_file_path, cycle_1, default_password, pfc$maximum_retention,
          pfc$no_log, status);
    IF status.normal THEN
      fsp$open_file (unique_name, amc$segment, ^access_selections, {default_creation_attributes =} NIL,
            {mandated_creation_attributes =} NIL, {attribute_validation =} NIL, {attribute_override =} NIL,
            file_id, status);
      IF status.normal THEN
        amp$get_segment_pointer (file_id, amc$sequence_pointer, file_pointer, status);
      ELSE
        amp$return (unique_name, ignore_status);
        pfp$purge (application_file_path, cycle_1, default_password,
              ignore_status);
      IFEND;
    IFEND;
    pfp$end_system_authority;
    osp$disestablish_cond_handler;

    IF NOT status.normal THEN
      nap$display_message (status);
    IFEND;

  PROCEND open_cycle_1;
?? TITLE := 'register_server_added_titles', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to register the titles in the server
{   added titles list.
{ NOTES:
{   It is assumed that the server attributes list is locked by the caller.

  PROCEDURE register_server_added_titles
    (VAR server_attributes: ^nat$server_attributes);

    VAR
      added_title: ^nat$added_title,
      domain: nat$title_domain,
      ignore_status: ost$status,
      protocol: nat$protocol,
      osi_address: nat$osi_registration_address,
      user_identifier: ost$name;

    domain.kind := nac$catenet_domain;
    protocol := server_attributes^.protocol;

    osi_address.kind := nac$osi_transport_address;
    osi_address.transport_selector := server_attributes^.application_id.osi_sap_identifier;

    added_title := server_attributes^.added_titles;
    user_identifier := server_attributes^.server;

    WHILE added_title <> NIL DO
      nlp$register_title (added_title^.title, osi_address, protocol, ^added_title^.data,
            added_title^.data_length, added_title^.priority, domain, added_title^.distribute_title,
            nac$cdna_external, default_directory_password, user_identifier, added_title^.identifier,
            ignore_status);
      added_title := added_title^.next_title;
    WHILEND;

  PROCEND register_server_added_titles;
?? TITLE := 'register_server_titles', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to register the titles in the server
{   titles list.
{ NOTES:
{   It is assumed that the server attributes list is locked by the caller.

  PROCEDURE register_server_titles
    (VAR server_attributes: ^nat$server_attributes;
     VAR status: ost$status);

    VAR
      domain: nat$title_domain,
      i: 1 .. 255,
      ignore_status: ost$status,
      protocol: nat$protocol,
      server_title: ^nat$server_title,
      osi_address: nat$osi_registration_address,
      user_identifier: ost$name;

    status.normal := TRUE;
    IF server_attributes^.server_titles <> NIL THEN
      osi_address.kind := nac$osi_transport_address;
      osi_address.transport_selector := server_attributes^.application_id.osi_sap_identifier;

      domain.kind := nac$catenet_domain;
      protocol := server_attributes^.protocol;
      user_identifier := server_attributes^.server;

    /selected_titles/
      FOR i := 1 TO UPPERBOUND (server_attributes^.server_titles^) DO
        server_title := ^server_attributes^.server_titles^ [i];
        nlp$register_title (server_title^.title, osi_address, protocol, ^server_title^.data,
              server_title^.data_length, server_title^.priority, domain, server_title^.distribute_title,
              nac$cdna_external, default_directory_password, user_identifier, server_title^.directory_id,
              status);
        IF NOT status.normal THEN
          EXIT /selected_titles/;
        IFEND;
      FOREND /selected_titles/;
    IFEND;

  PROCEND register_server_titles;

?? TITLE := 'unassign_sap_identifier', EJECT ??

  PROCEDURE unassign_sap_identifier
    (    sap_identifier: nlt$ta_sap_selector);

    osp$set_job_signature_lock (nav$assigned_sap_list.lock);
    IF (sap_identifier >= LOWERBOUND (nav$assigned_sap_list.reserved_sap)) AND
          (sap_identifier <= UPPERBOUND (nav$assigned_sap_list.reserved_sap)) THEN
      nav$assigned_sap_list.reserved_sap [sap_identifier] := nac$unassigned;
    ELSEIF (sap_identifier >= LOWERBOUND (nav$assigned_sap_list.sap)) AND
          (sap_identifier <= UPPERBOUND (nav$assigned_sap_list.sap)) THEN
      nav$assigned_sap_list.sap [sap_identifier] := nac$unassigned;
    IFEND;
    osp$clear_job_signature_lock (nav$assigned_sap_list.lock);
  PROCEND unassign_sap_identifier;
?? TITLE := 'verify_appl_mgmt_capability', EJECT ??
  PROCEDURE verify_appl_mgmt_capability
    (VAR status: ost$status);

    VAR
      network_application_manager: boolean;

    IF (NOT appl_mgmt_capability_verified) THEN
      avp$get_capability (avc$network_applic_management, avc$user, appl_mgmt_capability_verified, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT appl_mgmt_capability_verified THEN
        osp$set_status_abnormal (nac$status_id, nae$invalid_user, manage_network_applications, status);
      IFEND;
    IFEND;

  PROCEND verify_appl_mgmt_capability;
?? TITLE := '[XDCL, #GATE] nap$activate_client', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$activate_client
    (    client: nat$application_name;
     VAR status: ost$status);

    VAR
      application_file_attached: boolean,
      client_attributes: ^nat$client_attributes,
      client_definition: ^nat$client_definition,
      complete_client_definition: ^nat$complete_client_definition,
      ignore_status: ost$status,
      local_status: ost$status,
      old_file_header: ^nat$application_file_header,
      v10_client_definition: ^nat$v10_client_definition;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF nav$namve_active THEN
      osp$push_inhibit_job_recovery;
      osp$begin_subsystem_activity;
      nlp$get_nonexclusive_access (nav$client_attributes_list.access_control);
      nap$find_client_attributes (client, client_attributes);
      IF client_attributes = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application,
              client, status);
      ELSE
        nlp$get_exclusive_access (client_attributes^.access_control);
        IF client_attributes^.client_status = nac$application_active THEN
          osp$set_status_abnormal (nac$status_id,
                nae$application_already_active, client, status);
        ELSEIF NOT highest_cycle_open THEN
          osp$set_status_abnormal (nac$status_id,
                nae$application_file_not_open, activate_client#, status);
        ELSE
          RESET old_application_file;
          NEXT old_file_header IN old_application_file;
          find_client_definition (client, old_application_file,
                complete_client_definition);
          IF (complete_client_definition = NIL) THEN
            osp$set_status_abnormal (nac$status_id, nae$application_file_error,
                  activate_client#, status);
          ELSE
            activate_client (client_attributes, status);
            IF status.normal THEN
              client_attributes^.client_status := nac$application_active;
              IF (old_file_header^.version = nac$application_file_version) OR
                     (old_file_header^.version = nac$v11_appl_file_version) THEN
                NEXT client_definition IN complete_client_definition;
                client_definition^.client_status := nac$application_active;
              ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
                NEXT v10_client_definition IN complete_client_definition;
                v10_client_definition^.client_status := nac$application_active;
              IFEND;
              pmp$get_compact_date_time (old_file_header^.
                    modification_date_time, ignore_status);
              nav$appl_defn_time_stamp := old_file_header^.
                    modification_date_time;
            IFEND;
          IFEND;
        IFEND;
        nlp$release_exclusive_access (client_attributes^.access_control);
      IFEND;
      nlp$release_nonexclusive_access (nav$client_attributes_list.
            access_control);
      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;
    ELSE
      application_file_attached := FALSE;
      IF NOT highest_cycle_open THEN
        nap$attach_application_file (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        application_file_attached := TRUE;
      IFEND;

      RESET old_application_file;
      NEXT old_file_header IN old_application_file;
      find_client_definition (client, old_application_file,
            complete_client_definition);
      IF (complete_client_definition = NIL) THEN
        osp$set_status_abnormal (nac$status_id, nae$application_file_error,
              activate_client#, status);
      ELSE
        IF (old_file_header^.version = nac$application_file_version) OR
               (old_file_header^.version = nac$v11_appl_file_version) THEN
          NEXT client_definition IN complete_client_definition;
          client_definition^.client_status := nac$application_active;
        ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
          NEXT v10_client_definition IN complete_client_definition;
          v10_client_definition^.client_status := nac$application_active;
        IFEND;
        pmp$get_compact_date_time (old_file_header^.modification_date_time,
              ignore_status);

        IF application_file_attached THEN
          nap$detach_application_file (local_status);
          IF (status.normal) AND (NOT local_status.normal) THEN
            status := local_status;
          ELSE
            nap$display_message (local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND nap$activate_client;
?? TITLE := '[XDCL, #GATE] nap$activate_server', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$activate_server
    (    server: nat$application_name;
     VAR status: ost$status);

    VAR
      application_file_attached: boolean,
      complete_server_definition: ^nat$complete_server_definition,
      ignore_status: ost$status,
      local_status: ost$status,
      old_file_header: ^nat$application_file_header,
      server_definition: ^nat$server_definition,
      server_attributes: ^nat$server_attributes,
      v10_server_definition: ^nat$v10_server_definition;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF nav$namve_active THEN
      osp$push_inhibit_job_recovery;
      osp$begin_subsystem_activity;
      nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
      nap$find_server_attributes (server, server_attributes);
      IF server_attributes = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application,
              server, status);
      ELSE
        nlp$get_exclusive_access (server_attributes^.access_control);
        IF server_attributes^.server_status = nac$application_active THEN
          osp$set_status_abnormal (nac$status_id,
                nae$application_already_active, server, status);
        ELSEIF NOT highest_cycle_open THEN
          osp$set_status_abnormal (nac$status_id,
                nae$application_file_not_open, activate_server#, status);
        ELSE
          RESET old_application_file;
          NEXT old_file_header IN old_application_file;
          find_server_definition (server, old_application_file,
                complete_server_definition);
          IF (complete_server_definition = NIL) THEN
            osp$set_status_abnormal (nac$status_id, nae$application_file_error,
                  activate_server#, status);
          ELSEIF (server_attributes^.nam_initiated_server) THEN
            activate_server (server_attributes, status);
          IFEND;
          IF status.normal THEN
            server_attributes^.server_status := nac$application_active;
            IF (old_file_header^.version = nac$application_file_version) OR
                   (old_file_header^.version = nac$v11_appl_file_version) THEN
              NEXT server_definition IN complete_server_definition;
              server_definition^.server_status := nac$application_active;
            ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
              NEXT v10_server_definition IN complete_server_definition;
              v10_server_definition^.server_status := nac$application_active;
            IFEND;
            pmp$get_compact_date_time (old_file_header^.modification_date_time,
                  ignore_status);
            nav$appl_defn_time_stamp := old_file_header^.
                  modification_date_time;
          IFEND;
        IFEND;
        nlp$release_exclusive_access (server_attributes^.access_control);
      IFEND;

      nlp$release_nonexclusive_access (nav$server_attributes_list.
            access_control);
      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;
    ELSE
      application_file_attached := FALSE;
      IF NOT highest_cycle_open THEN
        nap$attach_application_file (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        application_file_attached := TRUE;
      IFEND;

      RESET old_application_file;
      NEXT old_file_header IN old_application_file;
      find_server_definition (server, old_application_file,
            complete_server_definition);
      IF (complete_server_definition = NIL) THEN
        osp$set_status_abnormal (nac$status_id, nae$application_file_error,
              activate_server#, status);
      ELSE
        IF (old_file_header^.version = nac$application_file_version) OR
               (old_file_header^.version = nac$v11_appl_file_version) THEN
          NEXT server_definition IN complete_server_definition;
          server_definition^.server_status := nac$application_active;
        ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
          NEXT v10_server_definition IN complete_server_definition;
          v10_server_definition^.server_status := nac$application_active;
        IFEND;
        pmp$get_compact_date_time (old_file_header^.modification_date_time,
              ignore_status);
      IFEND;

      IF application_file_attached THEN
        nap$detach_application_file (local_status);
        IF (status.normal) AND (NOT local_status.normal) THEN
          status := local_status;
        ELSE
          nap$display_message (local_status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND nap$activate_server;
?? TITLE := '[XDCL, #GATE] nap$activate_tcpip', EJECT ??
*copyc nah$activate_tcpip

  PROCEDURE [XDCL, #GATE] nap$activate_tcpip
    (    application: nat$application_name;
     VAR status: ost$status);


    VAR
      application_file_attached: boolean,
      complete_tcpip_definition: ^nat$complete_tcpip_definition,
      local_status: ost$status,
      old_file_header: ^nat$application_file_header,
      tcpip_attributes: ^nat$tcpip_attributes,
      tcpip_definition: ^nat$tcpip_definition;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF nav$namve_active THEN
      osp$push_inhibit_job_recovery;
      osp$begin_subsystem_activity;
      nlp$get_nonexclusive_access (nav$tcpip_attributes_list.access_control);
      nap$find_tcpip_attributes (application, tcpip_attributes);
      IF tcpip_attributes = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application,
              application, status);
      ELSE { Application name valid.
        nlp$get_exclusive_access (tcpip_attributes^.access_control);
        IF tcpip_attributes^.tcpip_status = nac$application_active THEN
          osp$set_status_abnormal (nac$status_id,
                nae$application_already_active, application, status);
        ELSEIF NOT highest_cycle_open THEN
          osp$set_status_abnormal (nac$status_id,
                nae$application_file_not_open, activate_tcpip#, status);
        ELSE
          RESET old_application_file;
          NEXT old_file_header IN old_application_file;
          find_tcpip_definition (application, old_application_file,
                complete_tcpip_definition);
          IF (complete_tcpip_definition = NIL) THEN
            osp$set_status_abnormal (nac$status_id, nae$application_file_error,
                  activate_tcpip#, status);
          ELSE
            tcpip_attributes^.tcpip_status := nac$application_active;
            NEXT tcpip_definition IN complete_tcpip_definition;
            tcpip_definition^.tcpip_status := nac$application_active;
            pmp$get_compact_date_time (old_file_header^.modification_date_time,
                  local_status);
            nav$appl_defn_time_stamp := old_file_header^.
                  modification_date_time;
          IFEND;
        IFEND;
        nlp$release_exclusive_access (tcpip_attributes^.access_control);
      IFEND;
      nlp$release_nonexclusive_access (nav$tcpip_attributes_list.
            access_control);
      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;
    ELSE { NAMVE not active.
      application_file_attached := FALSE;
      IF NOT highest_cycle_open THEN
        nap$attach_application_file (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        application_file_attached := TRUE;
      IFEND;

      RESET old_application_file;
      NEXT old_file_header IN old_application_file;
      find_tcpip_definition (application, old_application_file,
            complete_tcpip_definition);
      IF (complete_tcpip_definition = NIL) THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application,
              application, status);
      ELSE
        NEXT tcpip_definition IN complete_tcpip_definition;
        tcpip_definition^.tcpip_status := nac$application_active;
        pmp$get_compact_date_time (old_file_header^.modification_date_time,
              local_status);

        IF application_file_attached THEN
          nap$detach_application_file (local_status);
          IF (status.normal) AND (NOT local_status.normal) THEN
            status := local_status;
          ELSE
            nap$display_message (local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND nap$activate_tcpip;
?? TITLE := '[XDCL, #GATE] nap$add_server_title', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$add_server_title
    (    server: nat$application_name;
         title: nat$title;
         attributes: ^nat$title_attributes;
         broadcast_registration: boolean;
     VAR status: ost$status);

*copyc nah$add_server_title

    VAR
      added_title: ^nat$added_title,
      authorized_title: boolean,
      domain: nat$title_domain,
      i: integer,
      priority: nat$directory_priority,
      server_attributes: ^nat$server_attributes,
      user_identifier: ost$name,
      user_information: ^cell,
      user_information_length: 0 .. nac$max_directory_data_length,
      user_supplied_name: jmt$user_supplied_name,
      osi_address: nat$osi_registration_address;

    IF NOT nav$namve_active THEN
      osp$set_status_condition ( nae$network_inactive,  status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, osk$m * amk_add_server_title, nak$application_management);

    domain.kind := nac$catenet_domain;
    priority := nac$max_directory_priority;
    user_information_length := 0;
    user_information := NIL;
    IF STRLENGTH (title) < 1 THEN
      osp$set_status_abnormal (nac$status_id, nae$title_too_short, add_server_title, status);
    ELSEIF STRLENGTH (title) > nac$max_title_length THEN
      osp$set_status_abnormal (nac$status_id, nae$title_too_long, add_server_title, status);
      osp$append_status_integer (osc$status_parameter_delimiter, STRLENGTH (title), 10, FALSE, status);
    ELSEIF attributes <> NIL THEN
      FOR i := LOWERBOUND (attributes^) TO UPPERBOUND (attributes^) DO
        CASE attributes^ [i].selector OF
        = nac$title_priority =
          IF (attributes^ [i].priority >= nac$max_directory_priority) AND
                (attributes^ [i].priority <= nac$min_directory_priority) THEN
            priority := attributes^ [i].priority;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$invalid_directory_priority, add_server_title, status);
            osp$append_status_integer (osc$status_parameter_delimiter, attributes^ [i].priority, 10, FALSE,
                  status);
          IFEND;
        = nac$title_data =
          IF #SIZE (attributes^ [i].data^) <= nac$max_directory_data_length THEN
            user_information_length := #SIZE (attributes^ [i].data^);
            user_information := attributes^ [i].data;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$directory_data_too_large, add_server_title, status);
          IFEND;
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$invalid_selector, add_server_title, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, attributes_parameter, status);
          osp$append_status_integer (osc$status_parameter_delimiter, i, 10, FALSE, status);
        CASEND;
      FOREND;
    IFEND;

    IF status.normal THEN
      osp$begin_subsystem_activity;
      REPEAT
        ALLOCATE added_title: [STRLENGTH (title)] IN nav$network_paged_heap^;
        IF added_title = NIL THEN
          osp$end_subsystem_activity;
          syp$cycle;
          osp$begin_subsystem_activity;
        IFEND;
      UNTIL added_title <> NIL;
      osp$push_inhibit_job_recovery;
      nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
      nap$find_server_attributes (server, server_attributes);
      IF server_attributes = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application, server, status);
      ELSE
        nlp$get_exclusive_access (server_attributes^.access_control);
        nap$validate_user (server_attributes^.server_capability, server_attributes^.server_ring,
              server_attributes^.server_system_privilege, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (nac$status_id, nae$unknown_application, server, status);
        ELSEIF server_attributes^.server_status = nac$application_inactive THEN
          osp$set_status_abnormal (nac$status_id, nae$application_inactive, server, status);
        ELSEIF (NOT server_attributes^.nam_initiated_server) AND
              (NOT server_attributes^.protocol_activated) THEN
          osp$set_status_abnormal (nac$status_id, nae$no_server_job_attached, server, status);
        ELSE
          authorized_title := FALSE;
          IF server_attributes^.server_managed_titles <> NIL THEN

          /validate_title/
            FOR i := LOWERBOUND (server_attributes^.server_managed_titles^)
                  TO UPPERBOUND (server_attributes^.server_managed_titles^) DO
              IF nlp$name_match (server_attributes^.server_managed_titles^ [i], title) THEN
                authorized_title := TRUE;
                EXIT /validate_title/;
              IFEND;
            FOREND /validate_title/;
          IFEND;
          IF authorized_title THEN
            osi_address.kind := nac$osi_transport_address;
            osi_address.transport_selector := server_attributes^.application_id.osi_sap_identifier;

            added_title^.title := title;
            user_identifier := server_attributes^.server;
            nlp$register_title (title, osi_address, server_attributes^.protocol,
                  user_information, user_information_length, priority, domain, broadcast_registration,
                  nac$cdna_external, default_directory_password, user_identifier, added_title^.identifier,
                  status);
            IF status.normal THEN
              IF user_information <> NIL THEN
                i#move (user_information, ^added_title^.data, user_information_length);
              IFEND;
              added_title^.data_length := user_information_length;
              added_title^.distribute_title := broadcast_registration;
              added_title^.priority := priority;
              added_title^.next_title := server_attributes^.added_titles;
              server_attributes^.added_titles := added_title;
            ELSEIF status.condition = nae$duplicate_registration THEN
              osp$set_status_abnormal (nac$status_id, nae$duplicate_title, add_server_title, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, title, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, server, status);
            IFEND;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$title_not_authorized, add_server_title, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, title, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, server, status);
          IFEND;
        IFEND;
        nlp$release_exclusive_access (server_attributes^.access_control);
      IFEND;
      nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
      osp$pop_inhibit_job_recovery;
      IF NOT status.normal THEN
        FREE added_title IN nav$network_paged_heap^;
      IFEND;
      osp$end_subsystem_activity;
    IFEND;

    #KEYPOINT (osk$entry, osk$m * amk_add_server_title, nak$application_management);

  PROCEND nap$add_server_title;
?? TITLE := '[XDCL, #GATE] nap$attach_application_file', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to attach the application definition file
{   for exclusive access. If the file or the application subcatalog does not
{   exist, they are created here.

  PROCEDURE [XDCL, #GATE] nap$attach_application_file
    (VAR status: ost$status);

    VAR
      cycle_number: pft$cycle_number,
      display_status: ost$status,
      file_header: ^nat$application_file_header,
      ignore_status: ost$status,
      segment_pointer: amt$segment_pointer,
      share_selections: [STATIC, READ, oss$job_paged_literal] pft$share_selections := [],
      unique_name: ost$name,
      usage_selections: [STATIC, READ, oss$job_paged_literal] pft$usage_selections :=
            [pfc$read, pfc$shorten, pfc$append, pfc$modify];

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      osp$set_status_from_condition (nac$status_id, condition, sfsa_p, status, ignore_status);
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Purge cycle 1 of the application file if it is the only cycle of the file and
{ display a warning message to the $RESPONSE file that the previous update
{ attempt failed.

    find_highest_cycle_number (application_file_path, cycle_number, status);
    IF status.normal THEN
      IF cycle_number = pfc$minimum_cycle_number THEN
        osp$establish_block_exit_hndlr (^handle_block_exit);
        pfp$begin_system_authority;
        pfp$purge (application_file_path, cycle_1, default_password, ignore_status);
        pfp$end_system_authority;
        osp$disestablish_cond_handler;
        osp$set_status_condition ( nae$cycle_1_present, display_status);
        display_message_to_$response (display_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;
    status.normal := TRUE;

{ Attach highest cycle of the application file.

    pmp$get_unique_name (unique_name, ignore_status);
    osp$establish_block_exit_hndlr (^handle_block_exit);
    pfp$begin_system_authority;
    pfp$attach (unique_name, application_file_path, highest_cycle, default_password, usage_selections,
          share_selections, pfc$no_wait, status);
    pfp$end_system_authority;
    osp$disestablish_cond_handler;
    IF NOT status.normal THEN
      IF (status.condition <> pfe$unknown_permanent_file) AND
            (status.condition <> pfe$unknown_last_subcatalog) THEN
        nap$display_message (status);
        RETURN;
      IFEND;

      IF status.condition = pfe$unknown_last_subcatalog THEN
        osp$establish_block_exit_hndlr (^handle_block_exit);
        pfp$begin_system_authority;
        pfp$define_catalog (application_catalog, status);
        pfp$end_system_authority;
        osp$disestablish_cond_handler;
        IF NOT status.normal THEN
          nap$display_message (status);
          RETURN;
        IFEND;
      IFEND;

{ Define the application definition file.

      osp$establish_block_exit_hndlr (^handle_block_exit);
      pfp$begin_system_authority;
      pfp$define (unique_name, application_file_path, cycle_2, default_password, pfc$maximum_retention,
            pfc$no_log, status);
      pfp$end_system_authority;
      osp$disestablish_cond_handler;
      IF NOT status.normal THEN
        nap$display_message (status);
        RETURN;
      IFEND;

{ Open the file and initialize the header.

      fsp$open_file (unique_name, amc$segment, ^access_selections, {default_creation_attributes =} NIL,
            {mandated_creation_attributes =} NIL, {attribute_validation =} NIL, {attribute_override =} NIL,
            highest_cycle_id, status);
      IF NOT status.normal THEN
        nap$display_message (status);
        amp$return (unique_name, ignore_status);
        RETURN;
      IFEND;

      amp$get_segment_pointer (highest_cycle_id, amc$sequence_pointer, segment_pointer, status);
      IF NOT status.normal THEN
        nap$display_message (status);
        fsp$close_file (highest_cycle_id, ignore_status);
        amp$return (unique_name, ignore_status);
        RETURN;
      IFEND;

      old_application_file := segment_pointer.sequence_pointer;
      RESET old_application_file;
      NEXT file_header IN old_application_file;
      file_header^.version := nac$application_file_version;
      pmp$get_compact_date_time (file_header^.creation_date_time, ignore_status);
      file_header^.modification_date_time := file_header^.creation_date_time;
      file_header^.server_count := 0;
      file_header^.client_count := 0;
      file_header^.tcpip_count := 0;
      segment_pointer.sequence_pointer := old_application_file;
      amp$set_segment_eoi (highest_cycle_id, segment_pointer, status);
      RESET old_application_file;
      highest_cycle_open := TRUE;
    ELSE
      fsp$open_file (unique_name, amc$segment, ^access_selections, {default_creation_attributes =} NIL,
            {mandated_creation_attributes =} NIL, {attribute_validation =} NIL, {attribute_override =} NIL,
            highest_cycle_id, status);
      IF status.normal THEN
        amp$get_segment_pointer (highest_cycle_id, amc$sequence_pointer, segment_pointer, status);
        IF status.normal THEN
          old_application_file := segment_pointer.sequence_pointer;
          RESET old_application_file;

{ Verify that the header is present.

          NEXT file_header IN old_application_file;
          IF (file_header = NIL) OR ((file_header^.version <> nac$application_file_version) AND
                (file_header^.version <> nac$v11_appl_file_version) AND
                (file_header^.version <> nac$v10_appl_file_version)) THEN
            osp$set_status_abnormal (nac$status_id, nae$application_file_error, attach_application_file,
                  status);
          ELSEIF (nav$applications_installed) AND (file_header^.modification_date_time <>
                nav$appl_defn_time_stamp) THEN
            osp$set_status_condition ( nae$application_file_mismatch,  status);
          IFEND;
        IFEND;

        IF NOT status.normal THEN
          fsp$close_file (highest_cycle_id, ignore_status);
          amp$return (unique_name, ignore_status);
        IFEND;

        highest_cycle_open := status.normal;
      ELSE
        nap$display_message (status);
        amp$return (unique_name, ignore_status);
      IFEND;

    IFEND;

{ If cycle 1 of the application file exists, purge the file and display a
{ warning message to the $RESPONSE file that the previous update attempt failed.

    IF cycle_number <> pfc$minimum_cycle_number THEN
      pmp$get_unique_name (unique_name, ignore_status);
      osp$establish_block_exit_hndlr (^handle_block_exit);
      pfp$begin_system_authority;
      pfp$attach (unique_name, application_file_path, cycle_1, default_password, usage_selections,
            share_selections, pfc$no_wait, status);
      IF (status.normal) OR ((NOT status.normal) AND (status.condition = pfe$cycle_busy)) THEN
        amp$return (unique_name, ignore_status);
        pfp$purge (application_file_path, cycle_1, default_password, ignore_status);
        osp$set_status_condition ( nae$cycle_1_present, display_status);
        display_message_to_$response (display_status, status);
        IF NOT status.normal THEN
          pfp$end_system_authority;
          osp$disestablish_cond_handler;
          RETURN;
        IFEND;
      IFEND;
      pfp$end_system_authority;
      osp$disestablish_cond_handler;
      status.normal := TRUE;
    IFEND;

  PROCEND nap$attach_application_file;
?? TITLE := '[XDCL, #GATE] nap$attach_server_application ', EJECT ??
*copyc nah$attach_server_application
  PROCEDURE [XDCL, #GATE] nap$attach_server_application
    (    server: nat$application_name;
         max_connections: nat$number_of_connections;
     VAR status: ost$status);

    VAR
      job_name: jmt$system_supplied_name,
      ignore_status: ost$status,
      user_supplied_name: jmt$user_supplied_name;

    IF NOT nav$namve_active THEN
      osp$set_status_condition ( nae$network_inactive,  status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, osk$m * amk_attach_server_application, nak$application_management);
    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);

    pmp$get_job_names (user_supplied_name, job_name, ignore_status);
    attach_server_application (job_name, server, max_connections, status);

    nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
    osp$end_subsystem_activity;
    osp$pop_inhibit_job_recovery;
    #KEYPOINT (osk$exit, osk$m * amk_attach_server_application, nak$application_management);

  PROCEND nap$attach_server_application;
?? TITLE := '[XDCL, #GATE] nap$attach_specific_server_appl', EJECT ??

{ PURPOSE:
{   The purpose of this request is to attach the specified server application.  The
{   request is the same as nap$attach_server_application except that the job name is
{   a parameter on this request.

  PROCEDURE [XDCL, #GATE] nap$attach_specific_server_appl
    (    system_job_name: jmt$system_supplied_name;
         server: nat$application_name;
         max_connections: nat$number_of_connections;
     VAR status: ost$status);


    IF NOT nav$namve_active THEN
      osp$set_status_condition (nae$network_inactive, status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, osk$m * amk_attach_server_application, nak$application_management);
    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);

    attach_server_application (system_job_name, server, max_connections, status);

    nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
    osp$end_subsystem_activity;
    osp$pop_inhibit_job_recovery;
    #KEYPOINT (osk$exit, osk$m * amk_attach_server_application, nak$application_management);

  PROCEND nap$attach_specific_server_appl;
?? TITLE := '[XDCL, #GATE] nap$change_client', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$change_client
    (    client: nat$application_name;
         max_connections: nat$number_of_connections;
         connection_priority: nat$network_message_priority;
         reserved_application_id: boolean;
         application_id: nat$internet_sap_identifier;
         client_capability: ost$name;
         client_ring: ost$ring;
         client_system_privilege: boolean;
     VAR status: ost$status);

    VAR
      converted_client_definition: ^nat$complete_client_definition,
      i: 1 .. 65535,
      j: 1 .. 65535,
      ignore_status: ost$status,
      modification_date_time: ost$date_time,
      new_application_file: ^SEQ ( * ),
      new_client_attributes: ^nat$client_attributes,
      new_client_definition: ^nat$client_definition,
      new_client_pointers: ^nat$client_pointers,
      new_complete_client_definition: ^nat$complete_client_definition,
      new_file_header: ^nat$application_file_header,
      new_file_id: amt$file_identifier,
      new_file_pointer: amt$segment_pointer,
      new_server_pointers: ^nat$server_pointers,
      new_tcpip_pointers: ^nat$tcpip_pointers,
      old_client_attributes: ^nat$client_attributes,
      old_client_definition: ^nat$client_definition,
      old_client_pointers: ^nat$client_pointers,
      old_complete_client_definition: ^nat$complete_client_definition,
      old_file_header: ^nat$application_file_header,
      old_server_pointers: ^nat$server_pointers,
      old_tcpip_pointers: ^nat$tcpip_pointers,
      sap_changed: boolean,
      v10_v11_file_header: ^nat$v10_v11_file_header;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT (highest_cycle_open) THEN
      osp$set_status_abnormal (nac$status_id, nae$application_file_not_open,
            change_client, status);
      RETURN;
    IFEND;

    open_cycle_1 (new_file_pointer, new_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET old_application_file;
    NEXT old_file_header IN old_application_file;
    new_application_file := new_file_pointer.sequence_pointer;
    RESET new_application_file;
    NEXT new_file_header IN new_application_file;
    IF old_file_header^.version = nac$application_file_version THEN
      new_file_header^ := old_file_header^;
    ELSE
      RESET old_application_file;
      NEXT v10_v11_file_header IN old_application_file;
      new_file_header^.version := nac$application_file_version;
      new_file_header^.creation_date_time := old_file_header^.creation_date_time;
      new_file_header^.server_count := old_file_header^.server_count;
      new_file_header^.client_count := old_file_header^.client_count;
      new_file_header^.tcpip_count := 0;
    IFEND;
    pmp$get_compact_date_time (modification_date_time, ignore_status);
    new_file_header^.modification_date_time := modification_date_time;

    IF old_file_header^.server_count > 0 THEN
      NEXT old_server_pointers: [1 .. old_file_header^.server_count] IN
            old_application_file;
      NEXT new_server_pointers: [1 .. new_file_header^.server_count] IN
            new_application_file;
    IFEND;

    IF old_file_header^.client_count > 0 THEN
      NEXT old_client_pointers: [1 .. old_file_header^.client_count] IN
            old_application_file;
      NEXT new_client_pointers: [1 .. new_file_header^.client_count] IN
            new_application_file;
    IFEND;

    IF new_file_header^.tcpip_count > 0 THEN
      NEXT old_tcpip_pointers: [1 .. new_file_header^.tcpip_count] IN
            old_application_file;
      NEXT new_tcpip_pointers: [1 .. new_file_header^.tcpip_count] IN
            new_application_file;
    IFEND;

{ Move server definitions to the new application file.

    FOR i := 1 TO old_file_header^.server_count DO
      move_server_definition (old_server_pointers^ [i],
            new_server_pointers^ [i], old_application_file,
            new_application_file);
    FOREND;

    NEXT new_complete_client_definition: [[nat$client_definition]] IN
          new_application_file;
    RESET new_complete_client_definition;
    NEXT new_client_definition IN new_complete_client_definition;

{ Find the old definition of the client and move it to the new application
{ file.

    find_client_definition (client, old_application_file,
          old_complete_client_definition);
    IF old_complete_client_definition = NIL THEN
      osp$set_status_abnormal (nac$status_id, nae$application_file_error,
            change_client, status);
      close_cycle_1 (new_file_id);
      RETURN;
    IFEND;
    IF (old_file_header^.version = nac$application_file_version) OR
          (old_file_header^.version = nac$v11_appl_file_version) THEN
      NEXT old_client_definition IN old_complete_client_definition;
      new_client_definition^ := old_client_definition^;
    ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
      convert_v10_client_to_v11 (old_complete_client_definition,
            converted_client_definition);
      RESET converted_client_definition;
      NEXT old_client_definition IN converted_client_definition;
      new_client_definition^ := old_client_definition^;
      FREE converted_client_definition IN osv$task_private_heap^;
    ELSE
      osp$set_status_abnormal (nac$status_id, nae$incorrect_appl_file_version,
            old_file_header^.version, status);
      close_cycle_1 (new_file_id);
      RETURN;
    IFEND;

{  Set the new attribute values into the client definition.

    new_client_definition^.max_connections := max_connections;
    new_client_definition^.client_capability := client_capability;
    new_client_definition^.client_ring := client_ring;
    new_client_definition^.client_system_privilege := client_system_privilege;
    new_client_definition^.message_priority := connection_priority;
    new_client_definition^.reserved_application_id := reserved_application_id;
    IF reserved_application_id THEN
      new_client_definition^.application_id := application_id;
    IFEND;

{  Setup relative pointers to the new client definition.

    new_client_pointers^ [1].client := client;
    new_client_pointers^ [1].pointer := #REL (new_complete_client_definition,
          new_application_file^);

{ Move the remaining client definitions to the new application file.

    j := 1;
    FOR i := 1 TO old_file_header^.client_count DO
      IF old_client_pointers^ [i].client <> client THEN
        j := j + 1;
        move_client_definition (old_client_pointers^ [i],
              new_client_pointers^ [j], old_application_file,
              new_application_file);
      IFEND;
    FOREND;

{ Move tcpip definitions to the new application file.

    FOR i := 1 TO new_file_header^.tcpip_count DO
      move_tcpip_definition (old_tcpip_pointers^ [i], new_tcpip_pointers^ [i], old_application_file,
            new_application_file);
    FOREND;

    IF nav$namve_active THEN

{ Move the client's old attributes to a local storage area and then change the
{ old attributes to their new values.

      osp$push_inhibit_job_recovery;
      osp$begin_subsystem_activity;
      nlp$get_nonexclusive_access (nav$client_attributes_list.access_control);
      nap$find_client_attributes (client, old_client_attributes);
      IF old_client_attributes = NIL THEN
        osp$set_status_condition ( nae$application_file_mismatch, status);
        nlp$release_nonexclusive_access (nav$client_attributes_list.access_control);
        osp$end_subsystem_activity;
        osp$pop_inhibit_job_recovery;
        close_cycle_1 (new_file_id);
        RETURN;
      IFEND;
      PUSH new_client_attributes;
      nlp$get_exclusive_access (old_client_attributes^.access_control);
      new_client_attributes^ := old_client_attributes^;

      new_client_attributes^.client_capability :=
            new_client_definition^.client_capability;
      new_client_attributes^.client_ring := new_client_definition^.client_ring;
      new_client_attributes^.client_system_privilege :=
            new_client_definition^.client_system_privilege;
      new_client_attributes^.max_connections :=
            new_client_definition^.max_connections;
      new_client_attributes^.message_priority :=
            new_client_definition^.message_priority;
      new_client_attributes^.flags.nam_accounting :=
            new_client_definition^.flags.nam_accounting;
      new_client_attributes^.reserved_application_id :=
            new_client_definition^.reserved_application_id;
      IF new_client_attributes^.reserved_application_id THEN
        new_client_attributes^.application_id.xns_sap_identifier := new_client_definition^.
              application_id;
        new_client_attributes^.application_id.osi_sap_identifier := (new_client_definition^.
              application_id - minimum_xns_sap_identifier) + nlc$ta_min_rsvd_se_session_sap;
      ELSEIF old_client_attributes^.reserved_application_id THEN
        new_client_attributes^.application_id.xns_sap_identifier := 0;
        new_client_attributes^.application_id.osi_sap_identifier := 0;
      IFEND;

{ Change the client's sap if the client's application identifier changed,
{ connection priority changed or max connections were increased.

      sap_changed := FALSE;
      IF old_client_attributes^.sap_open THEN
        IF (new_client_attributes^.application_id <>
              old_client_attributes^.application_id) OR
              (new_client_attributes^.message_priority <>
              old_client_attributes^.message_priority) OR
              (new_client_attributes^.max_connections >
              old_client_attributes^.max_connections) THEN
          nlp$se_close_sap (old_client_attributes^.application_id, status);
          nap$display_message (status);

{ Unassign the old sap in case both the old sap and new sap are the same reserved value but
{ with different priorities.

          unassign_sap_identifier (old_client_attributes^.application_id.osi_sap_identifier);
          old_client_attributes^.sap_open := FALSE;
          new_client_attributes^.sap_open := FALSE;
          assign_sap_identifier (new_client_attributes^.reserved_application_id, new_client_attributes^.
                  application_id.osi_sap_identifier, status);
          IF status.normal THEN
            nlp$se_open_sap (nac$nil, FALSE, new_client_attributes^.max_connections, status);
            IF status.normal THEN
              new_client_attributes^.sap_open := TRUE;
              sap_changed := TRUE;
            ELSE
              unassign_sap_identifier (new_client_attributes^.application_id.osi_sap_identifier);
            IFEND;
          IFEND;
          IF NOT status.normal THEN
{ Error encountered while changing the client; restore the client sap.

            nap$display_message (status);
            assign_sap_identifier (old_client_attributes^.reserved_application_id,
                  old_client_attributes^.application_id.osi_sap_identifier, status);
            IF status.normal THEN
              nlp$se_open_sap (nac$nil, FALSE, old_client_attributes^.max_connections, status);
              IF status.normal THEN
                old_client_attributes^.sap_open := TRUE;
              ELSE
                unassign_sap_identifier (old_client_attributes^.application_id.osi_sap_identifier);
                nap$display_message (status);
                osp$set_status_abnormal (nac$status_id,
                      nae$application_not_restored, client, status);
                old_client_attributes^.client_status := nac$application_inactive;
              IFEND;
            ELSE
              nap$display_message (status);
              osp$set_status_abnormal (nac$status_id,
                    nae$application_not_restored, client, status);
              old_client_attributes^.client_status := nac$application_inactive;
            IFEND;
            nlp$release_exclusive_access (old_client_attributes^.
                  access_control);
            nlp$release_nonexclusive_access (nav$client_attributes_list.
                  access_control);
            osp$end_subsystem_activity;
            osp$pop_inhibit_job_recovery;
            close_cycle_1 (new_file_id);
            RETURN;
          IFEND;
        IFEND;
      IFEND;

{ Change application definition file cycle 1 to new highest cycle.

      new_file_pointer.sequence_pointer := new_application_file;
      close_and_change_cycle_1 (new_file_id, new_file_pointer, status);
      IF status.normal THEN

{ Change the client attributes entry to have the new attribute values.

        old_client_attributes^ := new_client_attributes^;
        nav$appl_defn_time_stamp := modification_date_time;
      ELSE

{ Error encountered while changing the client; restore the client sap.

        nap$display_message (status);
        IF sap_changed THEN
          nlp$se_close_sap (new_client_attributes^.application_id, status);
          unassign_sap_identifier (new_client_attributes^.application_id.osi_sap_identifier);
          assign_sap_identifier (old_client_attributes^.reserved_application_id, old_client_attributes^.
                  application_id.osi_sap_identifier, status);
          IF status.normal THEN
            nlp$se_open_sap (nac$nil, FALSE, old_client_attributes^.max_connections, status);
            IF status.normal THEN
              old_client_attributes^.sap_open := TRUE;
            ELSE
              unassign_sap_identifier (old_client_attributes^.application_id.osi_sap_identifier);
            IFEND;
          IFEND;
          IF NOT status.normal THEN
            nap$display_message (status);
            osp$set_status_abnormal (nac$status_id,
                  nae$application_not_restored, client, status);
            old_client_attributes^.client_status := nac$application_inactive;
          IFEND;
        IFEND;
      IFEND;

      nlp$release_exclusive_access (old_client_attributes^.access_control);
      nlp$release_nonexclusive_access (nav$client_attributes_list.
            access_control);
      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;

    ELSE

{ NAMVE is not active.  Change the application definition file cycle 1
{ to new highest cycle.

      new_file_pointer.sequence_pointer := new_application_file;
      close_and_change_cycle_1 (new_file_id, new_file_pointer, status);
    IFEND;

  PROCEND nap$change_client;
?? TITLE := '[XDCL, #GATE] nap$change_server', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$change_server
    (    server: nat$application_name;
         selected_titles_changed: boolean;
         selected_titles: ^nat$selected_titles_list;
         server_managed_titles: ^nat$title_pattern_list;
         max_connections: nat$number_of_connections;
         connection_priority: nat$network_message_priority;
         server_capability: ost$name;
         server_ring: ost$ring;
         server_system_privilege: boolean;
         accept_connection: boolean;
         client_validation_capability: ost$name;
         client_info_source: nat$client_info_source;
         client_addresses: ^array [1 .. * ] of nat$client_address,
         reserved_application_id: boolean;
         application_id: nat$internet_sap_identifier;
         server_job_changed: boolean;
         server_job: amt$local_file_name;
         server_job_validation_source: nat$server_validation_source,
         server_job_max_connections: nat$number_of_connections;
     VAR status: ost$status);

    VAR
      actual_max_connections: nat$number_of_connections,
      binary_mainframe_id: pmt$binary_mainframe_id,
      converted_server_definition: ^nat$complete_server_definition,
      device_assigned: boolean,
      device_class: rmt$device_class,
      domain: nat$title_domain,
      free_added_titles: boolean,
      i: 1 .. 65535,
      j: 1 .. 65535,
      ignore_status: ost$status,
      modification_date_time: ost$date_time,
      nam_initiated_server: boolean,
      new_application_file: ^SEQ ( * ),
      new_client_addresses: ^array [1 .. * ] of nat$client_address,
      new_client_pointers: ^nat$client_pointers,
      new_complete_server_definition: ^nat$complete_server_definition,
      new_file_header: ^nat$application_file_header,
      new_file_id: amt$file_identifier,
      new_file_pointer: amt$segment_pointer,
      new_patterns_list: ^nat$title_pattern_list,
      new_titles_list: ^nat$selected_titles_list,
      new_selected_titles: ^nat$selected_titles_list,
      new_selected_titles_count: integer,
      new_server_attributes: ^nat$server_attributes,
      new_server_definition: ^nat$server_definition,
      new_server_pointers: ^nat$server_pointers,
      new_tcpip_pointers: ^nat$tcpip_pointers,
      old_client_pointers: ^nat$client_pointers,
      old_complete_server_definition: ^nat$complete_server_definition,
      old_file_header: ^nat$application_file_header,
      old_server_attributes: ^nat$server_attributes,
      old_server_definition: ^nat$server_definition,
      old_server_pointers: ^nat$server_pointers,
      old_service_file_defined: boolean,
      old_tcpip_pointers: ^nat$tcpip_pointers,
      osi_address: nat$osi_registration_address,
      processor_element_id: ost$processor_element_id,
      protocol: nat$protocol,
      purge_server_file: boolean,
      register_titles: boolean,
      sap_changed: boolean,
      server_definition_file: array [1 .. 6] of pft$name,
      server_title: ^nat$server_title,
      size_of_client_addresses: integer,
      size_of_selected_titles: integer,
      size_of_server_managed_titles: integer,
      timesharing_title: ost$name,
      title_count: integer,
      user_identifier: ost$name,
      v10_v11_file_header: ^nat$v10_v11_file_header;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      osp$set_status_from_condition (nac$status_id, condition, sfsa_p, status, ignore_status);
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT (highest_cycle_open) THEN
      osp$set_status_abnormal (nac$status_id, nae$application_file_not_open,
            change_server, status);
      RETURN;
    IFEND;

    open_cycle_1 (new_file_pointer, new_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET old_application_file;
    NEXT old_file_header IN old_application_file;
    new_application_file := new_file_pointer.sequence_pointer;
    RESET new_application_file;
    NEXT new_file_header IN new_application_file;

    IF old_file_header^.version = nac$application_file_version THEN
      new_file_header^ := old_file_header^;
    ELSE
      RESET old_application_file;
      NEXT v10_v11_file_header IN old_application_file;
      new_file_header^.version := nac$application_file_version;
      new_file_header^.creation_date_time := old_file_header^.creation_date_time;
      new_file_header^.server_count := old_file_header^.server_count;
      new_file_header^.client_count := old_file_header^.client_count;
      new_file_header^.tcpip_count := 0;
    IFEND;
    pmp$get_compact_date_time (modification_date_time, ignore_status);
    new_file_header^.modification_date_time := modification_date_time;

    IF old_file_header^.server_count > 0 THEN
      NEXT old_server_pointers: [1 .. old_file_header^.server_count] IN
            old_application_file;
      NEXT new_server_pointers: [1 .. new_file_header^.server_count] IN
            new_application_file;
    IFEND;

    IF old_file_header^.client_count > 0 THEN
      NEXT old_client_pointers: [1 .. old_file_header^.client_count] IN
            old_application_file;
      NEXT new_client_pointers: [1 .. new_file_header^.client_count] IN
            new_application_file;
    IFEND;

    IF new_file_header^.tcpip_count > 0 THEN
      NEXT old_tcpip_pointers: [1 .. new_file_header^.tcpip_count] IN
            old_application_file;
      NEXT new_tcpip_pointers: [1 .. new_file_header^.tcpip_count] IN
            new_application_file;
    IFEND;

    IF selected_titles <> NIL THEN
      IF server = osc$timesharing THEN
        pmp$get_pseudo_mainframe_id (binary_mainframe_id);
        jmp$generate_timesharing_title (binary_mainframe_id, timesharing_title);
        new_selected_titles_count := 0;
        FOR i := 1 TO UPPERBOUND (selected_titles^) DO
          IF selected_titles^ [i].title <> timesharing_title THEN
            new_selected_titles_count := new_selected_titles_count + 1;
          IFEND;
        FOREND;

{ Delete the remote attach job timesharing title from the list.

        IF new_selected_titles_count < UPPERBOUND (selected_titles^) THEN
          PUSH new_selected_titles: [1 .. new_selected_titles_count];
          j := 1;
          FOR i := 1 TO UPPERBOUND (selected_titles^) DO
            IF selected_titles^ [i].title <> timesharing_title THEN
              new_selected_titles^ [j] := selected_titles^ [i];
              j := j + 1;
            IFEND;
          FOREND;
          size_of_selected_titles := #SIZE (new_selected_titles^);
        ELSE
          size_of_selected_titles := #SIZE (selected_titles^);
          new_selected_titles := selected_titles;
        IFEND;
      ELSE
        size_of_selected_titles := #SIZE (selected_titles^);
        new_selected_titles := selected_titles;
      IFEND;
    ELSE
      size_of_selected_titles := 0;
      new_selected_titles := NIL;
    IFEND;

    IF server_managed_titles <> NIL THEN
      size_of_server_managed_titles := #SIZE (server_managed_titles^);
    ELSE
      size_of_server_managed_titles := 0;
    IFEND;

    IF client_addresses <> NIL THEN
      size_of_client_addresses := #SIZE (client_addresses^);
    ELSE
      size_of_client_addresses := 0;
    IFEND;

    NEXT new_complete_server_definition: [[REP
          (#SIZE (nat$server_definition) + size_of_selected_titles +
          size_of_server_managed_titles + size_of_client_addresses) OF
          cell]] IN new_application_file;
    RESET new_complete_server_definition;
    NEXT new_server_definition IN new_complete_server_definition;

{ Find the old definition of the server and move it to the new application
{ file.

    find_server_definition (server, old_application_file,
          old_complete_server_definition);
    IF old_complete_server_definition = NIL THEN
      osp$set_status_abnormal (nac$status_id, nae$application_file_error,
            change_server, status);
      close_cycle_1 (new_file_id);
      RETURN;
    IFEND;
    IF (old_file_header^.version = nac$application_file_version) OR
          (old_file_header^.version = nac$v11_appl_file_version) THEN
      NEXT old_server_definition IN old_complete_server_definition;
      new_server_definition^ := old_server_definition^;
    ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
      convert_v10_server_to_v11 (old_complete_server_definition,
            converted_server_definition);
      RESET converted_server_definition;
      NEXT old_server_definition IN converted_server_definition;
      new_server_definition^ := old_server_definition^;
      FREE converted_server_definition IN osv$task_private_heap^;
    ELSE
      osp$set_status_abnormal (nac$status_id, nae$incorrect_appl_file_version,
            old_file_header^.version, status);
      close_cycle_1 (new_file_id);
      RETURN;
    IFEND;

{  Save some of the old attribute values before they are changed.

    nam_initiated_server := old_server_definition^.nam_initiated_server;
    old_service_file_defined := old_server_definition^.service_file_defined;

{ Check if server job file is valid.

    IF nam_initiated_server AND server_job_changed THEN
      rmp$get_device_class (server_job, device_assigned, device_class, status);
      IF (NOT status.normal) AND (device_class <> rmc$null_device) THEN
        nap$display_message (status);
        close_cycle_1 (new_file_id);
        RETURN;
      IFEND;
    IFEND;

{ Determine the actual max connections for timesharing server.

    actual_max_connections := max_connections;
    IF server = osc$timesharing THEN
      pmp$get_binary_processor_id (processor_element_id, ignore_status);
      CASE processor_element_id.model_number OF
      = osc$cyber_180_model_930a, osc$cyber_180_model_932a =
        IF max_connections > max_connections_930_limit1 THEN
          actual_max_connections := max_connections_930_limit1;
          osp$set_status_abnormal (nac$status_id, nae$limit_max_connections, server, status);
          osp$append_status_integer (osc$status_parameter_delimiter, max_connections_930_limit1,
            10, FALSE, status);
          nap$display_message (status);
        IFEND;

      = osc$cyber_180_model_930b, osc$cyber_180_model_930c, osc$cyber_180_model_932b =
        IF max_connections > max_connections_930_limit2 THEN
          actual_max_connections := max_connections_930_limit2;
          osp$set_status_abnormal (nac$status_id, nae$limit_max_connections, server, status);
          osp$append_status_integer (osc$status_parameter_delimiter, max_connections_930_limit2,
            10, FALSE, status);
          nap$display_message (status);
        IFEND;

      ELSE
      CASEND;
      status.normal := TRUE;
    IFEND;

{  Set the new attribute values into the server definition.

    new_server_definition^.max_connections := actual_max_connections;
    IF new_selected_titles <> NIL THEN
      new_server_definition^.title_count := UPPERBOUND (new_selected_titles^);
    ELSE
      new_server_definition^.title_count := 0;
    IFEND;
    IF server_managed_titles <> NIL THEN
      new_server_definition^.server_managed_title_count :=
            UPPERBOUND (server_managed_titles^);
    ELSE
      new_server_definition^.server_managed_title_count := 0;
    IFEND;
    new_server_definition^.server_capability := server_capability;
    new_server_definition^.server_ring := server_ring;
    new_server_definition^.server_system_privilege := server_system_privilege;
    new_server_definition^.accept_connection := accept_connection;
    new_server_definition^.client_validation_capability :=
          client_validation_capability;
    new_server_definition^.client_info_source := client_info_source;
    IF client_addresses <> NIL THEN
      new_server_definition^.client_address_count :=
            UPPERBOUND (client_addresses^);
    ELSE
      new_server_definition^.client_address_count := 0;
    IFEND;

    new_server_definition^.reserved_application_id := reserved_application_id;
    new_server_definition^.application_id := application_id;
    new_server_definition^.message_priority := connection_priority;
    IF nam_initiated_server THEN
      new_server_definition^.server_job_validation_source :=
            server_job_validation_source;
      new_server_definition^.server_job_max_connections :=
            server_job_max_connections;
      IF server_job_changed THEN
        new_server_definition^.service_file_defined :=
              device_class <> rmc$null_device;
      IFEND;
    IFEND;

{ Setup the selected titles.

    IF new_server_definition^.title_count > 0 THEN
      NEXT new_titles_list: [1 .. new_server_definition^.title_count] IN
            new_complete_server_definition;
      new_titles_list^ := new_selected_titles^;
      new_server_definition^.selected_titles :=
            #REL (new_titles_list, new_complete_server_definition^);
    IFEND;

{ Setup the server_managed titles.

    IF new_server_definition^.server_managed_title_count > 0 THEN
      NEXT new_patterns_list: [1 .. new_server_definition^.
            server_managed_title_count] IN new_complete_server_definition;
      new_patterns_list^ := server_managed_titles^;
      new_server_definition^.server_managed_titles :=
            #REL (new_patterns_list, new_complete_server_definition^);
    IFEND;

{ Setup the client_addresses.

    IF new_server_definition^.client_address_count > 0 THEN
      NEXT new_client_addresses: [1 .. new_server_definition^.
            client_address_count] IN new_complete_server_definition;
      new_client_addresses^ := client_addresses^;
      new_server_definition^.client_addresses :=
            #REL (new_client_addresses, new_complete_server_definition^);
    IFEND;

{ Setup the relative pointer to the new server definition.

    new_server_pointers^ [1].server := server;
    new_server_pointers^ [1].pointer := #REL (new_complete_server_definition,
          new_application_file^);

{ Move the remaining server and client definitions to the new application file.

    j := 1;
    FOR i := 1 TO old_file_header^.server_count DO
      IF old_server_pointers^ [i].server <> server THEN
        j := j + 1;
        move_server_definition (old_server_pointers^ [i],
              new_server_pointers^ [j], old_application_file,
              new_application_file);
      IFEND;
    FOREND;

    FOR i := 1 TO old_file_header^.client_count DO
      move_client_definition (old_client_pointers^ [i],
            new_client_pointers^ [i], old_application_file,
            new_application_file);
    FOREND;

{ Move tcpip definitions to the new application file.

    FOR i := 1 TO new_file_header^.tcpip_count DO
      move_tcpip_definition (old_tcpip_pointers^ [i], new_tcpip_pointers^ [i], old_application_file,
            new_application_file);
    FOREND;

    IF nav$namve_active THEN

{ Move the server's old attributes to a local storage area and then change the
{ old attributes to their new values.

      osp$push_inhibit_job_recovery;
      osp$begin_subsystem_activity;
      nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
      nap$find_server_attributes (server, old_server_attributes);
      IF old_server_attributes = NIL THEN
        osp$set_status_condition ( nae$application_file_mismatch, status);
        nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
        osp$end_subsystem_activity;
        osp$pop_inhibit_job_recovery;
        close_cycle_1 (new_file_id);
        RETURN;
      IFEND;
      PUSH new_server_attributes;
      nlp$get_exclusive_access (old_server_attributes^.access_control);
      new_server_attributes^ := old_server_attributes^;

      new_server_attributes^.accept_connection :=
            new_server_definition^.accept_connection;
      new_server_attributes^.client_info_source :=
            new_server_definition^.client_info_source;
      new_server_attributes^.client_validation_capability :=
            new_server_definition^.client_validation_capability;
      new_server_attributes^.flags.nam_accounting :=
            new_server_definition^.flags.nam_accounting;
      new_server_attributes^.max_connections :=
            new_server_definition^.max_connections;
      new_server_attributes^.message_priority :=
            new_server_definition^.message_priority;
      new_server_attributes^.reserved_application_id :=
            new_server_definition^.reserved_application_id;
      IF new_server_attributes^.reserved_application_id THEN
        new_server_attributes^.application_id.xns_sap_identifier :=
              new_server_definition^.application_id;
        new_server_attributes^.application_id.osi_sap_identifier :=
              (new_server_definition^.application_id - minimum_xns_sap_identifier)
              + nlc$ta_min_rsvd_se_session_sap;
      ELSEIF old_server_attributes^.reserved_application_id THEN
        new_server_attributes^.application_id.xns_sap_identifier := 0;
        new_server_attributes^.application_id.osi_sap_identifier := 0;
      IFEND;
      new_server_attributes^.server_capability :=
            new_server_definition^.server_capability;
      new_server_attributes^.server_ring := new_server_definition^.server_ring;
      new_server_attributes^.server_system_privilege :=
            new_server_definition^.server_system_privilege;
      IF new_server_attributes^.nam_initiated_server THEN
        new_server_attributes^.service_file_defined :=
              new_server_definition^.service_file_defined;
        new_server_attributes^.server_job_max_connections :=
              new_server_definition^.server_job_max_connections;
        new_server_attributes^.server_job_validation_source :=
              new_server_definition^.server_job_validation_source;
      IFEND;
      IF new_server_definition^.client_address_count > 0 THEN
        new_client_addresses := #PTR (new_server_definition^.client_addresses,
              new_complete_server_definition^);
        REPEAT
          ALLOCATE new_server_attributes^.client_addresses:
                [1 .. new_server_definition^.client_address_count] IN
                nav$network_paged_heap^;
          IF new_server_attributes^.client_addresses = NIL THEN
            osp$end_subsystem_activity;
            syp$cycle;
            osp$begin_subsystem_activity;
          IFEND;
        UNTIL new_server_attributes^.client_addresses <> NIL;
        new_server_attributes^.client_addresses^ := new_client_addresses^;
      ELSE
        new_server_attributes^.client_addresses := NIL;
      IFEND;

      IF selected_titles_changed THEN
        IF (new_server_definition^.title_count > 0) OR (new_server_definition^.server = osc$timesharing) THEN
          new_titles_list := #PTR (new_server_definition^.selected_titles,
                new_complete_server_definition^);
          IF new_server_definition^.server = osc$timesharing THEN
            title_count := new_server_definition^.title_count + 1;
          ELSE
            title_count := new_server_definition^.title_count;
          IFEND;
          REPEAT
            ALLOCATE new_server_attributes^.server_titles:
                  [1 .. title_count] IN
                  nav$network_paged_heap^;
            IF new_server_attributes^.server_titles = NIL THEN
              osp$end_subsystem_activity;
              syp$cycle;
              osp$begin_subsystem_activity;
            IFEND;
          UNTIL new_server_attributes^.server_titles <> NIL;
          FOR i := 1 TO new_server_definition^.title_count DO
            new_server_attributes^.server_titles^ [i].title :=
                  new_titles_list^ [i].title;
            new_server_attributes^.server_titles^ [i].distribute_title :=
                  new_titles_list^ [i].distribute_title;
            new_server_attributes^.server_titles^ [i].priority :=
                  new_titles_list^ [i].priority;
            new_server_attributes^.server_titles^ [i].data_length :=
                  new_titles_list^ [i].data_length;
            new_server_attributes^.server_titles^ [i].data :=
                  new_titles_list^ [i].data;
          FOREND;
          IF new_server_definition^.server = osc$timesharing THEN
            pmp$get_pseudo_mainframe_id (binary_mainframe_id);
            jmp$generate_timesharing_title (binary_mainframe_id, timesharing_title);
            new_server_attributes^.server_titles^ [title_count].title := timesharing_title;
            new_server_attributes^.server_titles^ [title_count].distribute_title := FALSE;
            new_server_attributes^.server_titles^ [title_count].priority := nac$max_directory_priority;
            new_server_attributes^.server_titles^ [title_count].data_length := 0;
          IFEND;
        ELSE
          new_server_attributes^.server_titles := NIL;
        IFEND;
      ELSE
        new_server_attributes^.server_titles :=
              old_server_attributes^.server_titles;
      IFEND;

      IF new_server_definition^.server_managed_title_count > 0 THEN
        new_patterns_list := #PTR (new_server_definition^.
              server_managed_titles, new_complete_server_definition^);
        REPEAT
          ALLOCATE new_server_attributes^.server_managed_titles:
                [1 .. new_server_definition^.server_managed_title_count] IN
                nav$network_paged_heap^;
          IF new_server_attributes^.server_managed_titles = NIL THEN
            osp$end_subsystem_activity;
            syp$cycle;
            osp$begin_subsystem_activity;
          IFEND;
        UNTIL new_server_attributes^.server_managed_titles <> NIL;
        FOR i := 1 TO new_server_definition^.server_managed_title_count DO
          new_server_attributes^.server_managed_titles^ [i] :=
                new_patterns_list^ [i];
        FOREND;
      ELSE
        new_server_attributes^.server_managed_titles := NIL;
      IFEND;

{ Change the server's sap if the server's application identifier changed, connection priority changed
{ or max connections were increased. Register the server titles if the titles
{ or server sap was changed and register the server managed titles if the
{ server sap was changed.

      register_titles := FALSE;
      sap_changed := FALSE;
      IF nam_initiated_server OR (NOT nam_initiated_server AND
            new_server_attributes^.protocol_activated) THEN
        IF old_server_attributes^.sap_open THEN
          IF (selected_titles_changed OR (old_server_attributes^.
                application_id <> new_server_attributes^.application_id) OR
                (new_server_attributes^.max_connections > old_server_attributes^.max_connections) OR
                (NOT new_server_attributes^.reserved_application_id AND
                (old_server_attributes^.message_priority <>
                new_server_attributes^.message_priority))) THEN
            delete_server_titles (old_server_attributes^.server_titles);
            register_titles := TRUE;
          IFEND;

          IF ((old_server_attributes^.application_id <>
                new_server_attributes^.application_id) OR
                (old_server_attributes^.message_priority <>
                new_server_attributes^.message_priority) OR
                (new_server_attributes^.max_connections >
                old_server_attributes^.max_connections)) THEN
            delete_server_added_titles (old_server_attributes^.added_titles);
            nlp$se_close_sap (old_server_attributes^.application_id, ignore_status);
            unassign_sap_identifier (old_server_attributes^.application_id.osi_sap_identifier);
            old_server_attributes^.sap_open := FALSE;
            new_server_attributes^.sap_open := FALSE;
            assign_sap_identifier (new_server_attributes^.reserved_application_id, new_server_attributes^.
                    application_id.osi_sap_identifier, status);
            IF status.normal THEN
              nlp$se_open_sap (nac$monitor_server_connections, TRUE, new_server_attributes^.max_connections,
                    status);
              IF NOT status.normal THEN
                unassign_sap_identifier (new_server_attributes^.application_id.osi_sap_identifier);
              IFEND;
            IFEND;
            IF status.normal THEN
              new_server_attributes^.sap_open := TRUE;
              sap_changed := TRUE;
            ELSE

{ An error occured while opening the new server sap; open the old server sap
{ and register the original server titles and server managed titles.

              nap$display_message (status);
              assign_sap_identifier (old_server_attributes^.reserved_application_id, old_server_attributes^.
                    application_id.osi_sap_identifier, status);
              IF status.normal THEN
                nlp$se_open_sap (nac$monitor_server_connections, TRUE, old_server_attributes^.max_connections,
                      status);
                IF NOT status.normal THEN
                  unassign_sap_identifier (old_server_attributes^.application_id.osi_sap_identifier);
                IFEND;
              IFEND;
              IF status.normal THEN
                old_server_attributes^.sap_open := TRUE;
                IF register_titles THEN
                  register_server_titles (old_server_attributes,
                        ignore_status);
                IFEND;
                register_server_added_titles (old_server_attributes);
              ELSE
                nap$display_message (status);
                osp$set_status_abnormal (nac$status_id,
                      nae$application_not_restored, server, status);
                old_server_attributes^.server_status := nac$application_inactive;
              IFEND;
              free_server_attributes ({free_added_titles} FALSE,
                    {free server titles} selected_titles_changed,
                    new_server_attributes);
              nlp$release_exclusive_access (old_server_attributes^.
                    access_control);
              nlp$release_nonexclusive_access (nav$server_attributes_list.
                    access_control);
              osp$end_subsystem_activity;
              osp$pop_inhibit_job_recovery;
              close_cycle_1 (new_file_id);
              RETURN;
            IFEND;
          IFEND;

{ If the server's selected titles were changed or the server sap was changed,
{ register the titles in the server titles list.

          IF register_titles THEN
            IF new_server_attributes^.server_titles <> NIL THEN
              osi_address.kind := nac$osi_transport_address;
              osi_address.transport_selector := new_server_attributes^.application_id.osi_sap_identifier;

              domain.kind := nac$catenet_domain;
              protocol := new_server_attributes^.protocol;
              user_identifier := new_server_attributes^.server;

            /register_title/
              FOR i := 1 TO UPPERBOUND (new_server_attributes^.server_titles^)
                    DO
                server_title := ^new_server_attributes^.server_titles^ [i];
                nlp$register_title (server_title^.title, osi_address,
                      protocol, ^server_title^.data, server_title^.data_length,
                      server_title^.priority, domain,
                      server_title^.distribute_title, nac$cdna_external,
                      default_directory_password, user_identifier, server_title^.directory_id,
                      status);
                IF NOT status.normal THEN

{ An error occurred registering the new server titles; delete the titles just
{ registered, close the new sap, reopen the original sap and register the
{ original server titles and server managed titles.

                  nap$display_message (status);
                  FOR j := 1 TO i - 1 DO
                    server_title := ^new_server_attributes^.server_titles^ [j];
                    nlp$delete_registered_title (server_title^.title,
                          default_directory_password,
                          server_title^.directory_id, ignore_status);
                  FOREND;
                  IF sap_changed THEN
                    nlp$se_close_sap (new_server_attributes^.application_id, ignore_status);
                    unassign_sap_identifier (new_server_attributes^.application_id.osi_sap_identifier);
                    new_server_attributes^.sap_open := FALSE;
                    assign_sap_identifier (old_server_attributes^.reserved_application_id,
                            old_server_attributes^.application_id.osi_sap_identifier, status);
                    IF status.normal THEN
                      nlp$se_open_sap (nac$monitor_server_connections, TRUE,
                            old_server_attributes^.max_connections, status);
                      IF NOT status.normal THEN
                        unassign_sap_identifier (old_server_attributes^.application_id.osi_sap_identifier);
                      IFEND;
                    IFEND;
                  IFEND;
                  IF status.normal THEN
                    old_server_attributes^.sap_open := TRUE;
                    register_server_titles (old_server_attributes,
                          ignore_status);
                    IF sap_changed THEN
                      register_server_added_titles (old_server_attributes);
                    IFEND;
                  ELSE
                    nap$display_message (status);
                    osp$set_status_abnormal (nac$status_id,
                          nae$application_not_restored, server, status);
                    old_server_attributes^.server_status := nac$application_inactive;
                  IFEND;
                  EXIT /register_title/;
                IFEND;
              FOREND /register_title/;
              IF NOT status.normal THEN
                free_server_attributes ({free_added_titles} FALSE,
                      {free server titles} selected_titles_changed,
                      new_server_attributes);
                nlp$release_exclusive_access (old_server_attributes^.
                      access_control);
                nlp$release_nonexclusive_access
                      (nav$server_attributes_list.access_control);
                osp$end_subsystem_activity;
                osp$pop_inhibit_job_recovery;
                close_cycle_1 (new_file_id);
                RETURN;
              IFEND;
            IFEND;
          IFEND;

{ Register the server's server managed titles if the server's sap was changed.

          IF sap_changed THEN
            new_server_attributes^.added_titles := NIL;
            change_server_added_titles (old_server_attributes^.added_titles,
                  new_server_attributes, ignore_status);
          IFEND;

        IFEND;
      IFEND;
    IFEND;

{  Change the server job file.

    purge_server_file := FALSE;
    server_definition_file := application_job_file_path;
    server_definition_file [UPPERBOUND (server_definition_file)] := server;
    IF nam_initiated_server AND server_job_changed THEN
      IF new_server_definition^.service_file_defined THEN

{  Create a new high cycle with the new server job commands.

        define_server_job_file (server_definition_file, server_job, status);
        IF NOT status.normal THEN
          IF nav$namve_active THEN
            free_added_titles := old_server_attributes^.added_titles <>
                  new_server_attributes^.added_titles;
            free_server_attributes (free_added_titles,
                  {free server titles} selected_titles_changed,
                  old_server_attributes);
            nlp$release_exclusive_access (old_server_attributes^.
                  access_control);
            nlp$release_nonexclusive_access (nav$server_attributes_list.
                  access_control);
            osp$end_subsystem_activity;
            osp$pop_inhibit_job_recovery;
          IFEND;
          close_cycle_1 (new_file_id);
          RETURN;
        IFEND;
        IF old_service_file_defined THEN

{ Change the retention period of the previous high cycle to 2 days.

          change_file_retention (server_definition_file, 2, ignore_status);
        IFEND;
      ELSE

{ The server job file was changed to undefined so set a boolean to purge the
{ old server job file after the server definition is successfully changed.

        purge_server_file := TRUE;
      IFEND;
    IFEND;

{ Change application definition file cycle 1 to new highest cycle.

    new_file_pointer.sequence_pointer := new_application_file;
    close_and_change_cycle_1 (new_file_id, new_file_pointer, status);
    IF nav$namve_active THEN
      IF status.normal THEN

{ Change the server attributes entry to the new attribute values.

        free_added_titles := old_server_attributes^.added_titles <>
              new_server_attributes^.added_titles;
        free_server_attributes (free_added_titles,
              {free server titles} selected_titles_changed,
              old_server_attributes);
        old_server_attributes^ := new_server_attributes^;
        nav$appl_defn_time_stamp := modification_date_time;
        IF purge_server_file THEN
          osp$establish_block_exit_hndlr (^handle_block_exit);
          pfp$begin_system_authority;
          pfp$purge (server_definition_file, highest_cycle, default_password,
                ignore_status);
          pfp$end_system_authority;
          osp$disestablish_cond_handler;
        IFEND;
      ELSE

{ Error encountered while changing the server; restore the server to it's
{ original state.

        nap$display_message (status);

{ Restore the server job file.

        IF nam_initiated_server AND server_job_changed THEN
          IF new_server_definition^.service_file_defined THEN
            osp$establish_block_exit_hndlr (^handle_block_exit);
            pfp$begin_system_authority;
            pfp$purge (server_definition_file, highest_cycle, default_password,
                  ignore_status);
            pfp$end_system_authority;
            osp$disestablish_cond_handler;
            IF old_service_file_defined THEN
              change_file_retention (server_definition_file,
                    pfc$maximum_retention, ignore_status);
            IFEND;
          IFEND;
        IFEND;

        IF sap_changed THEN

{ Restore the server sap.

          delete_server_titles (new_server_attributes^.server_titles);
          delete_server_added_titles (new_server_attributes^.added_titles);

          nlp$se_close_sap (new_server_attributes^.application_id, ignore_status);
          unassign_sap_identifier (new_server_attributes^.application_id.osi_sap_identifier);
          assign_sap_identifier (old_server_attributes^.reserved_application_id, old_server_attributes^.
                  application_id.osi_sap_identifier, status);
          IF status.normal THEN
            nlp$se_open_sap (nac$monitor_server_connections, TRUE, old_server_attributes^.max_connections,
                  status);
            IF NOT status.normal THEN
              unassign_sap_identifier (old_server_attributes^.application_id.osi_sap_identifier);
            IFEND;
          IFEND;
          IF NOT status.normal THEN
            nap$display_message (status);
            osp$set_status_abnormal (nac$status_id,
                  nae$application_not_restored, server, status);
            old_server_attributes^.server_status := nac$application_inactive;
          IFEND;
        IFEND;

        IF status.normal THEN

{ Restore the server titles.

          IF register_titles THEN
            register_server_titles (old_server_attributes, ignore_status);
          IFEND;
        IFEND;

        IF status.normal THEN
          IF sap_changed THEN

{ Restore the server managed titles.

            old_server_attributes^.sap_open := TRUE;
            register_server_added_titles (old_server_attributes);
          IFEND;
        IFEND;

        free_added_titles := old_server_attributes^.added_titles <>
              new_server_attributes^.added_titles;
        free_server_attributes (free_added_titles,
              {free server titles} selected_titles_changed,
              new_server_attributes);
      IFEND;

    ELSE

{ NAMVE is not active.

      IF status.normal THEN
        IF purge_server_file THEN
          osp$establish_block_exit_hndlr (^handle_block_exit);
          pfp$begin_system_authority;
          pfp$purge (server_definition_file, highest_cycle, default_password,
                ignore_status);
          pfp$end_system_authority;
          osp$disestablish_cond_handler;
        IFEND;
      ELSE

{ Error encountered while creating the new application definition file
{ high cycle; restore the server job file.

        nap$display_message (status);
        IF nam_initiated_server AND server_job_changed THEN
          IF new_server_definition^.service_file_defined THEN
            osp$establish_block_exit_hndlr (^handle_block_exit);
            pfp$begin_system_authority;
            pfp$purge (server_definition_file, highest_cycle, default_password,
                  ignore_status);
            pfp$end_system_authority;
            osp$disestablish_cond_handler;
            IF old_service_file_defined THEN
              change_file_retention (server_definition_file,
                    pfc$maximum_retention, ignore_status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF nav$namve_active THEN
      nlp$release_exclusive_access (old_server_attributes^.access_control);
      nlp$release_nonexclusive_access (nav$server_attributes_list.
            access_control);
      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;
    IFEND;

  PROCEND nap$change_server;
?? TITLE := '[XDCL, #GATE] nap$change_tcpip', EJECT ??
*copyc nah$change_tcpip

  PROCEDURE [XDCL, #GATE] nap$change_tcpip
    (    application: nat$application_name;
         maximum_sockets: nat$number_of_sockets;
         tcpip_capability: ost$name;
         tcpip_ring: ost$ring;
         tcpip_system_privilege: boolean;
     VAR status: ost$status);



    VAR
      i: 1 .. 0FFFF(16),
      ignore_status: ost$status,
      j: 1 .. 0FFFF(16),
      modification_date_time: ost$date_time,
      new_application_file: ^SEQ ( * ),
      new_client_pointers: ^nat$client_pointers,
      new_complete_tcpip_definition: ^nat$complete_tcpip_definition,
      new_file_header: ^nat$application_file_header,
      new_file_id: amt$file_identifier,
      new_file_pointer: amt$segment_pointer,
      new_server_pointers: ^nat$server_pointers,
      new_tcpip_attributes: ^nat$tcpip_attributes,
      new_tcpip_definition: ^nat$tcpip_definition,
      new_tcpip_pointers: ^nat$tcpip_pointers,
      old_client_pointers: ^nat$client_pointers,
      old_complete_tcpip_definition: ^nat$complete_tcpip_definition,
      old_file_header: ^nat$application_file_header,
      old_server_pointers: ^nat$server_pointers,
      old_tcpip_attributes: ^nat$tcpip_attributes,
      old_tcpip_definition: ^nat$tcpip_definition,
      old_tcpip_pointers: ^nat$tcpip_pointers,
      v10_v11_file_header: ^nat$v10_v11_file_header;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT highest_cycle_open THEN
      osp$set_status_abnormal (nac$status_id, nae$application_file_not_open,
            change_client, status);
      RETURN;
    IFEND;

    open_cycle_1 (new_file_pointer, new_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    new_application_file := new_file_pointer.sequence_pointer;
    RESET new_application_file;
    NEXT new_file_header IN new_application_file;
    RESET old_application_file;
    NEXT old_file_header IN old_application_file;

    IF old_file_header^.version <> nac$application_file_version THEN
      osp$set_status_abnormal (nac$status_id, nae$unknown_application,
            application, status);
      close_cycle_1 (new_file_id);
      RETURN;
    IFEND;

{ Update new file header from old.

    new_file_header^ := old_file_header^;
    pmp$get_compact_date_time (modification_date_time, ignore_status);
    new_file_header^.modification_date_time := modification_date_time;


    IF new_file_header^.server_count > 0 THEN
      NEXT old_server_pointers: [1 .. new_file_header^.server_count] IN
            old_application_file;
      NEXT new_server_pointers: [1 .. new_file_header^.server_count] IN
            new_application_file;
    IFEND;

    IF new_file_header^.client_count > 0 THEN
      NEXT old_client_pointers: [1 .. new_file_header^.client_count] IN
            old_application_file;
      NEXT new_client_pointers: [1 .. new_file_header^.client_count] IN
            new_application_file;
    IFEND;

    IF new_file_header^.tcpip_count > 0 THEN
      NEXT old_tcpip_pointers: [1 .. new_file_header^.tcpip_count] IN
            old_application_file;
      NEXT new_tcpip_pointers: [1 .. new_file_header^.tcpip_count] IN
            new_application_file;
    IFEND;


{ Move server definitions to the new application file.

    FOR i := 1 TO new_file_header^.server_count DO
      move_server_definition (old_server_pointers^ [i],
            new_server_pointers^ [i], old_application_file,
            new_application_file);
    FOREND;

{ Move client definitions to the new application file.

    FOR i := 1 TO new_file_header^.client_count DO
      move_client_definition (old_client_pointers^ [i],
            new_client_pointers^ [i], old_application_file,
            new_application_file);
    FOREND;


    NEXT new_complete_tcpip_definition: [[nat$tcpip_definition]] IN
          new_application_file;
    RESET new_complete_tcpip_definition;
    NEXT new_tcpip_definition IN new_complete_tcpip_definition;

{ Find the old definition of the tcpip application and move it to the
{ new application file.

    find_tcpip_definition (application, old_application_file,
          old_complete_tcpip_definition);
    IF old_complete_tcpip_definition = NIL THEN
      osp$set_status_abnormal (nac$status_id, nae$unknown_application,
            application, status);
      close_cycle_1 (new_file_id);
      RETURN;
    IFEND;
    NEXT old_tcpip_definition IN old_complete_tcpip_definition;
    new_tcpip_definition^ := old_tcpip_definition^;

{  Set the new attribute values into the tcpip definition.

    new_tcpip_definition^.maximum_sockets := maximum_sockets;
    new_tcpip_definition^.tcpip_capability := tcpip_capability;
    new_tcpip_definition^.tcpip_ring := tcpip_ring;
    new_tcpip_definition^.tcpip_system_privilege := tcpip_system_privilege;

{  Setup relative pointers to the new tcpip definition.

    new_tcpip_pointers^ [1].application := application;
    new_tcpip_pointers^ [1].pointer := #REL (new_complete_tcpip_definition,
          new_application_file^);

{ Move the remaining tcpip definitions to the new application file.

    j := 1;
    FOR i := 1 TO new_file_header^.tcpip_count DO
      IF old_tcpip_pointers^ [i].application <> application THEN
        j := j + 1;
        move_tcpip_definition (old_tcpip_pointers^ [i],
              new_tcpip_pointers^ [j], old_application_file,
              new_application_file);
      IFEND;
    FOREND;

    IF nav$namve_active THEN

{ Move the tcpip's old attributes to a local storage area and then change the
{ old attributes to their new values.

      osp$push_inhibit_job_recovery;
      osp$begin_subsystem_activity;
      nlp$get_nonexclusive_access (nav$tcpip_attributes_list.access_control);
      nap$find_tcpip_attributes (application, old_tcpip_attributes);
      IF old_tcpip_attributes = NIL THEN
        osp$set_status_condition ( nae$application_file_mismatch, status);
        nlp$release_nonexclusive_access (nav$tcpip_attributes_list.access_control);
        osp$end_subsystem_activity;
        osp$pop_inhibit_job_recovery;
        close_cycle_1 (new_file_id);
        RETURN;
      IFEND;
      PUSH new_tcpip_attributes;
      nlp$get_exclusive_access (old_tcpip_attributes^.access_control);
      new_tcpip_attributes^ := old_tcpip_attributes^;
      new_tcpip_attributes^.tcpip_capability :=
            new_tcpip_definition^.tcpip_capability;
      new_tcpip_attributes^.tcpip_ring := new_tcpip_definition^.tcpip_ring;
      new_tcpip_attributes^.tcpip_system_privilege :=
            new_tcpip_definition^.tcpip_system_privilege;
      new_tcpip_attributes^.maximum_sockets := new_tcpip_definition^.maximum_sockets;

{ Change application definition file cycle 1 to new highest cycle.

      new_file_pointer.sequence_pointer := new_application_file;
      close_and_change_cycle_1 (new_file_id, new_file_pointer, status);
      IF status.normal THEN

{ Change the tcpip attributes entry to have the new attribute values.

        old_tcpip_attributes^ := new_tcpip_attributes^;
        nav$appl_defn_time_stamp := modification_date_time;
      ELSE

{ Error encountered while changing the tcpip application.

        nap$display_message (status);
      IFEND;

      nlp$release_exclusive_access (old_tcpip_attributes^.access_control);
      nlp$release_nonexclusive_access (nav$tcpip_attributes_list.
            access_control);
      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;

    ELSE

{ NAMVE is not active.  Change the application definition file cycle 1
{ to new highest cycle.

      new_file_pointer.sequence_pointer := new_application_file;
      close_and_change_cycle_1 (new_file_id, new_file_pointer, status);
    IFEND;

  PROCEND nap$change_tcpip;
?? TITLE := '[XDCL, #GATE] nap$close_server_job_file', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to close the specified server job file.
{   The file should have previously been opened in ring 3.

  PROCEDURE [XDCL, #GATE] nap$close_server_job_file (server_file_identifier: amt$file_identifier;
    VAR status: ost$status);

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF status.normal THEN
      fsp$close_file (server_file_identifier, status);
    IFEND;
  PROCEND nap$close_server_job_file;
?? TITLE := '[XDCL, #GATE] nap$deactivate_client ', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$deactivate_client
    (    client: nat$application_name;
         terminate_active_connections: boolean;
     VAR status: ost$status);

    VAR
      application_file_attached: boolean,
      client_attributes: ^nat$client_attributes,
      client_definition: ^nat$client_definition,
      complete_client_definition: ^nat$complete_client_definition,
      ignore_status: ost$status,
      local_status: ost$status,
      old_file_header: ^nat$application_file_header,
      v10_client_definition: ^nat$v10_client_definition;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF nav$namve_active THEN
      osp$push_inhibit_job_recovery;
      nlp$get_exclusive_access (nav$client_attributes_list.access_control);
      nap$find_client_attributes (client, client_attributes);
      IF client_attributes = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application, client, status);
      ELSEIF client_attributes^.client_status = nac$application_inactive THEN
        osp$set_status_abnormal (nac$status_id, nae$application_already_inactiv, client, status);
      ELSEIF NOT highest_cycle_open THEN
        osp$set_status_abnormal (nac$status_id, nae$application_file_not_open, deactivate_client#, status);
      ELSE
        RESET old_application_file;
        NEXT old_file_header IN old_application_file;
        find_client_definition (client, old_application_file, complete_client_definition);
        IF (complete_client_definition = NIL) THEN
          osp$set_status_condition ( nae$application_file_error,  status);
        ELSE
          deactivate_client (client_attributes, terminate_active_connections);
          client_attributes^.client_status := nac$application_inactive;
          IF (old_file_header^.version = nac$application_file_version) OR
                (old_file_header^.version = nac$v11_appl_file_version) THEN
            NEXT client_definition IN complete_client_definition;
            client_definition^.client_status := nac$application_inactive;
          ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
            NEXT v10_client_definition IN complete_client_definition;
            v10_client_definition^.client_status := nac$application_inactive;
          IFEND;
          pmp$get_compact_date_time (old_file_header^.modification_date_time, ignore_status);
          nav$appl_defn_time_stamp := old_file_header^.modification_date_time;
        IFEND;
      IFEND;

      nlp$release_exclusive_access (nav$client_attributes_list.access_control);
      osp$pop_inhibit_job_recovery;
    ELSE
      application_file_attached := FALSE;
      IF NOT highest_cycle_open THEN
        nap$attach_application_file (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        application_file_attached := TRUE;
      IFEND;

      RESET old_application_file;
      NEXT old_file_header IN old_application_file;
      find_client_definition (client, old_application_file,
            complete_client_definition);
      IF (complete_client_definition = NIL) THEN
        osp$set_status_abnormal (nac$status_id, nae$application_file_error,
              activate_client#, status);
      ELSE
        IF (old_file_header^.version = nac$application_file_version) OR
              (old_file_header^.version = nac$v11_appl_file_version) THEN
          NEXT client_definition IN complete_client_definition;
          client_definition^.client_status := nac$application_inactive;
        ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
          NEXT v10_client_definition IN complete_client_definition;
          v10_client_definition^.client_status := nac$application_inactive;
        IFEND;
        pmp$get_compact_date_time (old_file_header^.modification_date_time,
              ignore_status);

        IF application_file_attached THEN
          nap$detach_application_file (local_status);
          IF (status.normal) AND (NOT local_status.normal) THEN
            status := local_status;
          ELSE
            nap$display_message (local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND nap$deactivate_client;
?? TITLE := '[XDCL, #GATE] nap$deactivate_server ', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$deactivate_server
    (    server: nat$application_name;
         terminate_active_connections: boolean;
     VAR status: ost$status);

    VAR
      application_file_attached: boolean,
      complete_server_definition: ^nat$complete_server_definition,
      ignore_status: ost$status,
      local_status: ost$status,
      old_file_header: ^nat$application_file_header,
      server_attributes: ^nat$server_attributes,
      server_definition: ^nat$server_definition,
      v10_server_definition: ^nat$v10_server_definition,
      wait_for_connection: ^nat$wait_for_connection;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF nav$namve_active THEN
      osp$push_inhibit_job_recovery;
      osp$begin_subsystem_activity;
      nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
      nap$find_server_attributes (server, server_attributes);
      IF server_attributes = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application, server, status);
      ELSE
        nlp$get_exclusive_access (server_attributes^.access_control);
        IF server_attributes^.server_status = nac$application_inactive THEN
          osp$set_status_abnormal (nac$status_id, nae$application_already_inactiv, server, status);
        ELSEIF NOT highest_cycle_open THEN
          osp$set_status_abnormal (nac$status_id, nae$application_file_not_open, deactivate_server#, status);
        ELSE
          RESET old_application_file;
          NEXT old_file_header IN old_application_file;
          find_server_definition (server, old_application_file, complete_server_definition);
          IF (complete_server_definition = NIL) THEN
            osp$set_status_abnormal (nac$status_id, nae$application_file_error, deactivate_server#, status);
          ELSE
            deactivate_server (server_attributes, terminate_active_connections);
            server_attributes^.server_status := nac$application_inactive;
{ Ready the server tasks waiting for a connection.
            wait_for_connection := server_attributes^.wait_for_connection;
            WHILE wait_for_connection <> NIL DO
              pmp$ready_task (wait_for_connection^.task_id, ignore_status);
              wait_for_connection := wait_for_connection^.next_entry;
            WHILEND;
            IF (old_file_header^.version = nac$application_file_version) OR
                  (old_file_header^.version = nac$v11_appl_file_version) THEN
              NEXT server_definition IN complete_server_definition;
              server_definition^.server_status := nac$application_inactive;
            ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
              NEXT v10_server_definition IN complete_server_definition;
              v10_server_definition^.server_status := nac$application_inactive;
            IFEND;
            pmp$get_compact_date_time (old_file_header^.modification_date_time, ignore_status);
            nav$appl_defn_time_stamp := old_file_header^.modification_date_time;
          IFEND;
        IFEND;

        nlp$release_exclusive_access (server_attributes^.access_control);
      IFEND;

      nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;

    ELSE
      application_file_attached := FALSE;
      IF NOT highest_cycle_open THEN
        nap$attach_application_file (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        application_file_attached := TRUE;
      IFEND;

      RESET old_application_file;
      NEXT old_file_header IN old_application_file;
      find_server_definition (server, old_application_file,
            complete_server_definition);
      IF (complete_server_definition = NIL) THEN
        osp$set_status_abnormal (nac$status_id, nae$application_file_error,
              activate_server#, status);
      ELSE
        IF (old_file_header^.version = nac$application_file_version) OR
              (old_file_header^.version = nac$v11_appl_file_version) THEN
          NEXT server_definition IN complete_server_definition;
          server_definition^.server_status := nac$application_inactive;
        ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
          NEXT v10_server_definition IN complete_server_definition;
          v10_server_definition^.server_status := nac$application_inactive;
        IFEND;
        pmp$get_compact_date_time (old_file_header^.modification_date_time,
              ignore_status);
      IFEND;

      IF application_file_attached THEN
        nap$detach_application_file (local_status);
        IF (status.normal) AND (NOT local_status.normal) THEN
          status := local_status;
        ELSE
          nap$display_message (local_status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND nap$deactivate_server;
?? TITLE := '[XDCL, #GATE] nap$deactivate_tcpip', EJECT ??
*copyc nah$deactivate_tcpip

  PROCEDURE [XDCL, #GATE] nap$deactivate_tcpip
    (    application: nat$application_name;
         terminate_active_sockets: boolean;
     VAR status: ost$status);

    VAR
      application_file_attached: boolean,
      complete_tcpip_definition: ^nat$complete_tcpip_definition,
      i: integer,
      local_status: ost$status,
      old_file_header: ^nat$application_file_header,
      protocol: nat$protocol,
      tcpip_application: nat$application_name,
      tcpip_attributes: ^nat$tcpip_attributes,
      tcpip_definition: ^nat$tcpip_definition,
      tcp_socket: ^nat$tcp_socket,
      tcp_socket_list: ^array [1 .. * ] of nat$tcp_socket,
      udp_socket: ^nat$udp_socket,
      udp_socket_list: ^array [1 .. * ] of nat$udp_socket;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF nav$namve_active THEN
      osp$push_inhibit_job_recovery;
      nlp$get_exclusive_access (nav$tcpip_attributes_list.access_control);
      nap$find_tcpip_attributes (application, tcpip_attributes);
      IF tcpip_attributes = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application,
              application, status);
      ELSEIF tcpip_attributes^.tcpip_status = nac$application_inactive THEN
        osp$set_status_abnormal (nac$status_id,
              nae$application_already_inactiv, application, status);
      ELSEIF NOT highest_cycle_open THEN
        osp$set_status_abnormal (nac$status_id, nae$application_file_not_open,
              deactivate_tcpip#, status);
      ELSE
        RESET old_application_file;
        NEXT old_file_header IN old_application_file;
        find_tcpip_definition (application, old_application_file,
              complete_tcpip_definition);
        IF (complete_tcpip_definition = NIL) THEN
          osp$set_status_condition ( nae$application_file_error, status);
        ELSE
          tcpip_attributes^.tcpip_status := nac$application_inactive;
          NEXT tcpip_definition IN complete_tcpip_definition;
          tcpip_definition^.tcpip_status := nac$application_inactive;
          pmp$get_compact_date_time (old_file_header^.modification_date_time,
                local_status);
          nav$appl_defn_time_stamp := old_file_header^.modification_date_time;
          tcp_socket_list := NIL;
          udp_socket_list := NIL;
          protocol := tcpip_attributes^.protocol;
          tcpip_application := application;
          IF (tcpip_attributes^.protocol = nac$stream_socket) AND
            (tcpip_attributes^.active_socket_count > 0) THEN
            PUSH tcp_socket_list: [1 .. tcpip_attributes^.active_socket_count];
            i := 1;
            tcp_socket := tcpip_attributes^.tcp_socket_list;
            WHILE tcp_socket <> NIL DO
              tcp_socket_list^ [i] := tcp_socket^;
              i := i + 1;
              tcp_socket := tcp_socket^.next_entry;
            WHILEND;
          ELSEIF (tcpip_attributes^.protocol = nac$datagram_socket) AND
            (tcpip_attributes^.active_socket_count <> 0) THEN
            PUSH udp_socket_list: [1 .. tcpip_attributes^.active_socket_count];
            i := 1;
            udp_socket := tcpip_attributes^.udp_socket_list;
            WHILE udp_socket <> NIL DO
              udp_socket_list^ [i] := udp_socket^;
              i := i + 1;
              udp_socket := udp_socket^.next_entry;
            WHILEND;
          IFEND;
        IFEND;
      IFEND;
      nlp$release_exclusive_access (nav$tcpip_attributes_list.access_control);
      osp$pop_inhibit_job_recovery;
      IF status.normal THEN
        deactivate_tcpip (tcpip_application, protocol,
              terminate_active_sockets, tcp_socket_list, udp_socket_list);
      IFEND;
    ELSE {NAMVE not active
      application_file_attached := FALSE;
      IF NOT highest_cycle_open THEN
        nap$attach_application_file (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        application_file_attached := TRUE;
      IFEND;
      RESET old_application_file;
      NEXT old_file_header IN old_application_file;
      find_tcpip_definition (application, old_application_file,
            complete_tcpip_definition);
      IF (complete_tcpip_definition = NIL) THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application,
              application, status);
      ELSE
        NEXT tcpip_definition IN complete_tcpip_definition;
        tcpip_definition^.tcpip_status := nac$application_inactive;
        pmp$get_compact_date_time (old_file_header^.modification_date_time,
              local_status);
      IFEND;

      IF application_file_attached THEN
        nap$detach_application_file (local_status);
        IF (status.normal) AND (NOT local_status.normal) THEN
          status := local_status;
        ELSE
          nap$display_message (local_status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND nap$deactivate_tcpip;
?? TITLE := '[XDCL, #GATE] nap$define_client ', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$define_client
    (    client: nat$application_name;
         max_connections: nat$number_of_connections;
         connection_priority: nat$network_message_priority;
         protocol: nat$protocol;
         reserved_application_id: boolean;
         application_id: nat$internet_sap_identifier;
         client_capability: ost$name;
         client_ring: ost$ring;
         client_system_privilege: boolean;
     VAR status: ost$status);

    VAR
      complete_client_definition: ^nat$complete_client_definition,
      i: integer,
      ignore_status: ost$status,
      modification_date_time: ost$date_time,
      new_client_attributes: ^nat$client_attributes,
      new_client_definition: ^nat$client_definition,
      new_client_pointers: ^nat$client_pointers,
      new_file_header: ^nat$application_file_header,
      new_file_id: amt$file_identifier,
      new_file_pointer: amt$segment_pointer,
      new_server_pointers: ^nat$server_pointers,
      new_tcpip_pointers: ^nat$tcpip_pointers,
      new_application_file: ^SEQ ( * ),
      old_client_pointers: ^nat$client_pointers,
      old_file_header: ^nat$application_file_header,
      old_server_pointers: ^nat$server_pointers,
      old_tcpip_pointers: ^nat$tcpip_pointers,
      v10_v11_file_header: ^nat$v10_v11_file_header;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT highest_cycle_open THEN
      osp$set_status_abnormal (nac$status_id, nae$application_file_not_open, define_client, status);
      RETURN;
    IFEND;

    open_cycle_1 (new_file_pointer, new_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET old_application_file;
    NEXT old_file_header IN old_application_file;
    new_application_file := new_file_pointer.sequence_pointer;
    RESET new_application_file;
    NEXT new_file_header IN new_application_file;
    IF old_file_header^.version = nac$application_file_version THEN
      new_file_header^ := old_file_header^;
    ELSE
      RESET old_application_file;
      NEXT v10_v11_file_header IN old_application_file;
      new_file_header^.version := nac$application_file_version;
      new_file_header^.creation_date_time := old_file_header^.creation_date_time;
      new_file_header^.server_count := old_file_header^.server_count;
      new_file_header^.client_count := old_file_header^.client_count;
      new_file_header^.tcpip_count := 0;
    IFEND;
    pmp$get_compact_date_time (modification_date_time, ignore_status);
    new_file_header^.modification_date_time := modification_date_time;
    new_file_header^.client_count := old_file_header^.client_count + 1;

    IF old_file_header^.server_count > 0 THEN
      NEXT old_server_pointers: [1 .. old_file_header^.server_count] IN old_application_file;
      NEXT new_server_pointers: [1 .. new_file_header^.server_count] IN new_application_file;
    IFEND;

    IF old_file_header^.client_count > 0 THEN
      NEXT old_client_pointers: [1 .. old_file_header^.client_count] IN old_application_file;
    IFEND;
    NEXT new_client_pointers: [1 .. new_file_header^.client_count] IN new_application_file;

    IF new_file_header^.tcpip_count > 0 THEN
      NEXT old_tcpip_pointers: [1 .. new_file_header^.tcpip_count] IN
            old_application_file;
      NEXT new_tcpip_pointers: [1 .. new_file_header^.tcpip_count] IN
            new_application_file;
    IFEND;


    FOR i := 1 TO old_file_header^.server_count DO
      move_server_definition (old_server_pointers^ [i], new_server_pointers^ [i], old_application_file,
            new_application_file);
    FOREND;

    NEXT complete_client_definition: [[nat$client_definition]] IN new_application_file;
    RESET complete_client_definition;
    NEXT new_client_definition IN complete_client_definition;
    new_client_definition^.client := client;
    new_client_definition^.client_status := nac$application_inactive;
    new_client_definition^.max_connections := max_connections;
    new_client_definition^.client_capability := client_capability;
    new_client_definition^.client_ring := client_ring;
    new_client_definition^.client_system_privilege := client_system_privilege;
    new_client_definition^.reserved_application_id := reserved_application_id;
    new_client_definition^.application_id := application_id;
    new_client_definition^.message_priority := connection_priority;
    new_client_definition^.flags.nam_accounting := false;
    new_client_definition^.protocol := protocol;

{ setup the relative pointer to the client definition.

    new_client_pointers^ [1].client := client;
    new_client_pointers^ [1].pointer := #REL (complete_client_definition, new_application_file^);

    FOR i := 1 TO old_file_header^.client_count DO
      move_client_definition (old_client_pointers^ [i], new_client_pointers^ [i + 1], old_application_file,
            new_application_file);
    FOREND;

{ Move tcpip definitions to the new application file.

    FOR i := 1 TO new_file_header^.tcpip_count DO
      move_tcpip_definition (old_tcpip_pointers^ [i], new_tcpip_pointers^ [i], old_application_file,
            new_application_file);
    FOREND;

{ Setup the client attributes entry in network paged segment.

    osp$push_inhibit_job_recovery;
    IF nav$namve_active THEN
      osp$begin_subsystem_activity;
      define_client_attributes_entry (new_client_definition, new_client_attributes);
    IFEND;

    new_file_pointer.sequence_pointer := new_application_file;
    close_and_change_cycle_1 (new_file_id, new_file_pointer, status);
    IF NOT status.normal THEN
      IF nav$namve_active THEN
        FREE new_client_attributes IN nav$network_paged_heap^;
        osp$end_subsystem_activity;
      IFEND;
      osp$pop_inhibit_job_recovery;
      RETURN;
    IFEND;

    IF nav$namve_active THEN
      nav$appl_defn_time_stamp := modification_date_time;
      nlp$get_exclusive_access (nav$client_attributes_list.access_control);
      new_client_attributes^.next_entry := nav$client_attributes_list.client_attributes;
      nav$client_attributes_list.client_attributes := new_client_attributes;
      nlp$release_exclusive_access (nav$client_attributes_list.access_control);
      osp$end_subsystem_activity;
    IFEND;
    osp$pop_inhibit_job_recovery;

  PROCEND nap$define_client;
?? TITLE := '[XDCL, #GATE] nap$define_server', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$define_server
    (    server: nat$application_name;
         selected_titles: ^nat$selected_titles_list;
         server_managed_titles: ^nat$title_pattern_list;
         max_connections: nat$number_of_connections;
         connection_priority: nat$network_message_priority;
         server_capability: ost$name;
         server_ring: ost$ring;
         server_system_privilege: boolean;
         accept_connection: boolean;
         client_validation_capability: ost$name;
         client_info_source: nat$client_info_source;
         client_addresses: ^array [1 .. * ] of nat$client_address,
         reserved_application_id: boolean;
         application_id: nat$internet_sap_identifier;
         protocol: nat$protocol;
         nam_initiated_server: boolean;
         server_job: amt$local_file_name;
         server_job_validation_source: nat$server_validation_source,
         server_job_max_connections: nat$number_of_connections;
     VAR status: ost$status);

    VAR
      actual_max_connections: nat$number_of_connections,
      complete_server_definition: ^nat$complete_server_definition,
      device_assigned: boolean,
      device_class: rmt$device_class,
      file_attributes: array [1 .. 1] of amt$file_item,
      i: integer,
      ignore_status: ost$status,
      modification_date_time: ost$date_time,
      new_application_file: ^SEQ ( * ),
      new_client_addresses: ^array [1 .. * ] of nat$client_address,
      new_client_pointers: ^nat$client_pointers,
      new_file_header: ^nat$application_file_header,
      new_file_id: amt$file_identifier,
      new_file_pointer: amt$segment_pointer,
      new_patterns_list: ^nat$title_pattern_list,
      new_server_attributes: ^nat$server_attributes,
      new_server_definition: ^nat$server_definition,
      new_server_pointers: ^nat$server_pointers,
      new_tcpip_pointers: ^nat$tcpip_pointers,
      new_titles_list: ^nat$selected_titles_list,
      old_client_pointers: ^nat$client_pointers,
      old_file_header: ^nat$application_file_header,
      old_server_pointers: ^nat$server_pointers,
      old_tcpip_pointers: ^nat$tcpip_pointers,
      output_creation_attributes: array [1 ..1] of fst$file_cycle_attribute,
      processor_element_id: ost$processor_element_id,
      server_definition_file: array [1 .. 6] of pft$name,
      size_of_client_addresses: integer,
      size_of_selected_titles: integer,
      size_of_server_managed_titles: integer,
      unique_name: ost$name,
      v10_v11_file_header: ^nat$v10_v11_file_header;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      osp$set_status_from_condition (nac$status_id, condition, sfsa_p, status, ignore_status);
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT (highest_cycle_open) THEN
      osp$set_status_abnormal (nac$status_id, nae$application_file_not_open, define_server, status);
      RETURN;
    IFEND;

{ Check if server job file is valid.

    IF nam_initiated_server THEN
      rmp$get_device_class (server_job, device_assigned, device_class, status);
      IF (NOT status.normal) AND (device_class <> rmc$null_device) THEN
        nap$display_message (status);
        RETURN;
      IFEND;

{ Define a file by the server name to hold the scl commands for the server.

      IF device_class <> rmc$null_device THEN
        server_definition_file := application_job_file_path;
        server_definition_file [UPPERBOUND (server_definition_file)] := server;
        pmp$get_unique_name (unique_name, ignore_status);
        osp$establish_block_exit_hndlr (^handle_block_exit);
        pfp$begin_system_authority;
        pfp$define (unique_name, server_definition_file, highest_cycle, default_password,
              pfc$maximum_retention, pfc$no_log, status);
        IF NOT status.normal THEN
          nap$display_message (status);
          IF (status.condition = pfe$unknown_last_subcatalog) OR
                (status.condition = pfe$unknown_nth_subcatalog) THEN
            pfp$define_catalog (application_job_catalog, status);
            IF NOT status.normal THEN
              pfp$end_system_authority;
              osp$disestablish_cond_handler;
              RETURN;
            IFEND;
            pfp$define (unique_name, server_definition_file, highest_cycle, default_password,
                  pfc$maximum_retention, pfc$no_log, status);
          IFEND;
          IF NOT status.normal THEN
            pfp$end_system_authority;
            osp$disestablish_cond_handler;
            RETURN;
          IFEND;
        IFEND;

{ Change the ring attributes so that the server job file is readable from
{ ring 13.

        output_creation_attributes [1].selector := fsc$ring_attributes;
        output_creation_attributes [1].ring_attributes.r1 := osc$tsrv_ring;
        output_creation_attributes [1].ring_attributes.r2 := osc$user_ring_2;
        output_creation_attributes [1].ring_attributes.r3 := osc$user_ring_2;
        fsp$copy_file (server_job, unique_name, NIL, NIL, ^output_creation_attributes, status);
        IF NOT status.normal THEN
          amp$return (unique_name, ignore_status);
          pfp$purge (server_definition_file, highest_cycle, default_password, ignore_status);
          pfp$end_system_authority;
          osp$disestablish_cond_handler;
          nap$display_message (status);
          RETURN;
        IFEND;

        pfp$end_system_authority;
        osp$disestablish_cond_handler;
        amp$return (unique_name, ignore_status);
      IFEND;
    IFEND;

    open_cycle_1 (new_file_pointer, new_file_id, status);
    IF NOT status.normal THEN
      IF (nam_initiated_server) AND (device_class <> rmc$null_device) THEN
        osp$establish_block_exit_hndlr (^handle_block_exit);
        pfp$begin_system_authority;
        pfp$purge (server_definition_file, highest_cycle, default_password, ignore_status);
        pfp$end_system_authority;
        osp$disestablish_cond_handler;
      IFEND;
      RETURN;
    IFEND;

    RESET old_application_file;
    NEXT old_file_header IN old_application_file;
    new_application_file := new_file_pointer.sequence_pointer;
    RESET new_application_file;
    NEXT new_file_header IN new_application_file;

    IF old_file_header^.version = nac$application_file_version THEN
      new_file_header^ := old_file_header^;
    ELSE
      RESET old_application_file;
      NEXT v10_v11_file_header IN old_application_file;
      new_file_header^.version := nac$application_file_version;
      new_file_header^.creation_date_time := old_file_header^.creation_date_time;
      new_file_header^.server_count := old_file_header^.server_count;
      new_file_header^.client_count := old_file_header^.client_count;
      new_file_header^.tcpip_count := 0;
    IFEND;
    pmp$get_compact_date_time (modification_date_time, ignore_status);
    new_file_header^.modification_date_time := modification_date_time;
    new_file_header^.server_count := old_file_header^.server_count + 1;

    IF old_file_header^.server_count > 0 THEN
      NEXT old_server_pointers: [1 .. old_file_header^.server_count] IN old_application_file;
    IFEND;

    NEXT new_server_pointers: [1 .. new_file_header^.server_count] IN new_application_file;
    IF old_file_header^.client_count > 0 THEN
      NEXT old_client_pointers: [1 .. old_file_header^.client_count] IN old_application_file;
      NEXT new_client_pointers: [1 .. new_file_header^.client_count] IN new_application_file;
    IFEND;

    IF new_file_header^.tcpip_count > 0 THEN
      NEXT old_tcpip_pointers: [1 .. new_file_header^.tcpip_count] IN old_application_file;
      NEXT new_tcpip_pointers: [1 .. new_file_header^.tcpip_count] IN new_application_file;
    IFEND;

    IF selected_titles <> NIL THEN
      size_of_selected_titles := #SIZE (selected_titles^);
    ELSE
      size_of_selected_titles := 0;
    IFEND;

    IF server_managed_titles <> NIL THEN
      size_of_server_managed_titles := #SIZE (server_managed_titles^);
    ELSE
      size_of_server_managed_titles := 0;
    IFEND;

    IF client_addresses <> NIL THEN
      size_of_client_addresses := #SIZE (client_addresses^);
    ELSE
      size_of_client_addresses := 0;
    IFEND;

    NEXT complete_server_definition: [[REP (#SIZE (nat$server_definition) + size_of_selected_titles +
          size_of_server_managed_titles + size_of_client_addresses) OF cell]] IN new_application_file;
    RESET complete_server_definition;
    NEXT new_server_definition IN complete_server_definition;

{ Setup the new server definition.

    new_server_definition^.server := server;
    new_server_definition^.server_status := nac$application_inactive;

{ Determine actual max connections for timesharing server.

    actual_max_connections := max_connections;
    IF server = osc$timesharing THEN
      pmp$get_binary_processor_id (processor_element_id, ignore_status);
      CASE processor_element_id.model_number OF
      = osc$cyber_180_model_930a, osc$cyber_180_model_932a =
        IF max_connections > max_connections_930_limit1 THEN
          actual_max_connections := max_connections_930_limit1;
          osp$set_status_abnormal (nac$status_id, nae$limit_max_connections, server, status);
          osp$append_status_integer (osc$status_parameter_delimiter, max_connections_930_limit1,
            10, FALSE, status);
          nap$display_message (status);
        IFEND;

      = osc$cyber_180_model_930b, osc$cyber_180_model_930c, osc$cyber_180_model_932b =
        IF max_connections > max_connections_930_limit2 THEN
          actual_max_connections := max_connections_930_limit2;
          osp$set_status_abnormal (nac$status_id, nae$limit_max_connections, server, status);
          osp$append_status_integer (osc$status_parameter_delimiter, max_connections_930_limit2,
            10, FALSE, status);
          nap$display_message (status);
        IFEND;

      ELSE
      CASEND;
      status.normal := TRUE;
    IFEND;

    new_server_definition^.max_connections := actual_max_connections;
    IF selected_titles <> NIL THEN
      new_server_definition^.title_count := UPPERBOUND (selected_titles^);
    ELSE
      new_server_definition^.title_count := 0;
    IFEND;
    IF server_managed_titles <> NIL THEN
      new_server_definition^.server_managed_title_count := UPPERBOUND (server_managed_titles^);
    ELSE
      new_server_definition^.server_managed_title_count := 0;
    IFEND;
    new_server_definition^.server_capability := server_capability;
    new_server_definition^.server_ring := server_ring;
    new_server_definition^.server_system_privilege := server_system_privilege;
    new_server_definition^.accept_connection := accept_connection;
    new_server_definition^.client_validation_capability := client_validation_capability;
    new_server_definition^.client_info_source := client_info_source;
    IF client_addresses <> NIL THEN
      new_server_definition^.client_address_count := UPPERBOUND (client_addresses^);
    ELSE
      new_server_definition^.client_address_count := 0;
    IFEND;

    new_server_definition^.reserved_application_id := reserved_application_id;
    new_server_definition^.application_id := application_id;
    new_server_definition^.message_priority := connection_priority;
    new_server_definition^.flags.nam_accounting := false;
    new_server_definition^.protocol := protocol;
    new_server_definition^.nam_initiated_server := nam_initiated_server;
    IF nam_initiated_server THEN
      new_server_definition^.server_job_validation_source := server_job_validation_source;
      new_server_definition^.server_job_max_connections := server_job_max_connections;
      new_server_definition^.service_file_defined := device_class <> rmc$null_device
    IFEND;

{ Setup the selected titles.

    IF new_server_definition^.title_count > 0 THEN
      NEXT new_titles_list: [1 .. new_server_definition^.title_count] IN complete_server_definition;
      new_titles_list^ := selected_titles^;
      new_server_definition^.selected_titles := #REL (new_titles_list, complete_server_definition^);
    IFEND;

{ Setup the server_managed titles.

    IF new_server_definition^.server_managed_title_count > 0 THEN
      NEXT new_patterns_list: [1 .. new_server_definition^.server_managed_title_count] IN
            complete_server_definition;
      new_patterns_list^ := server_managed_titles^;
      new_server_definition^.server_managed_titles := #REL (new_patterns_list, complete_server_definition^);
    IFEND;

{ Setup the client_addresses.

    IF new_server_definition^.client_address_count > 0 THEN
      NEXT new_client_addresses: [1 .. new_server_definition^.client_address_count] IN
            complete_server_definition;
      new_client_addresses^ := client_addresses^;
      new_server_definition^.client_addresses := #REL (new_client_addresses, complete_server_definition^);
    IFEND;

{ Setup the relative pointer to the new server definition.

    new_server_pointers^ [1].server := server;
    new_server_pointers^ [1].pointer := #REL (complete_server_definition, new_application_file^);

{ Move the remaining server and client definitions to the new file.

    FOR i := 1 TO old_file_header^.server_count DO
      move_server_definition (old_server_pointers^ [i], new_server_pointers^ [i + 1], old_application_file,
            new_application_file);
    FOREND;

    FOR i := 1 TO old_file_header^.client_count DO
      move_client_definition (old_client_pointers^ [i], new_client_pointers^ [i], old_application_file,
            new_application_file);
    FOREND;

{ Move tcpip definitions to the new application file.

    FOR i := 1 TO new_file_header^.tcpip_count DO
      move_tcpip_definition (old_tcpip_pointers^ [i], new_tcpip_pointers^ [i], old_application_file,
            new_application_file);
    FOREND;

{ Setup the server attributes entry in network paged segment.

    osp$push_inhibit_job_recovery;
    IF nav$namve_active THEN
      osp$begin_subsystem_activity;
      define_server_attributes_entry (complete_server_definition, new_server_attributes);
    IFEND;

    new_file_pointer.sequence_pointer := new_application_file;
    close_and_change_cycle_1 (new_file_id, new_file_pointer, status);
    IF NOT status.normal THEN
      nap$display_message (status);
      IF (nam_initiated_server) AND (device_class <> rmc$null_device) THEN
        osp$establish_block_exit_hndlr (^handle_block_exit);
        pfp$begin_system_authority;
        pfp$purge (server_definition_file, highest_cycle, default_password, ignore_status);
        pfp$end_system_authority;
        osp$disestablish_cond_handler;
      IFEND;
      IF nav$namve_active THEN
        free_server_attributes_entry (new_server_attributes);
        osp$end_subsystem_activity;
      IFEND;
      osp$pop_inhibit_job_recovery;
      RETURN;
    IFEND;

    IF nav$namve_active THEN
      nav$appl_defn_time_stamp := modification_date_time;
      nlp$get_exclusive_access (nav$server_attributes_list.access_control);
      new_server_attributes^.next_entry := nav$server_attributes_list.server_attributes;
      nav$server_attributes_list.server_attributes := new_server_attributes;
      nlp$release_exclusive_access (nav$server_attributes_list.access_control);
      osp$end_subsystem_activity;
    IFEND;
    osp$pop_inhibit_job_recovery;

  PROCEND nap$define_server;
?? TITLE := '[XDCL, #GATE] nap$define_tcpip', EJECT ??
*copyc nah$define_tcpip

  PROCEDURE [XDCL, #GATE] nap$define_tcpip
    (    application: nat$application_name;
         maximum_sockets: nat$number_of_sockets;
         tcpip_capability: ost$name;
         tcpip_ring: ost$ring;
         tcpip_system_privilege: boolean;
         protocol: nat$protocol;
     VAR status: ost$status);


    VAR
      complete_tcpip_definition: ^nat$complete_tcpip_definition,
      i: integer,
      ignore_status: ost$status,
      modification_date_time: ost$date_time,
      new_application_file: ^SEQ ( * ),
      new_client_pointers: ^nat$client_pointers,
      new_file_header: ^nat$application_file_header,
      new_file_id: amt$file_identifier,
      new_file_pointer: amt$segment_pointer,
      new_server_pointers: ^nat$server_pointers,
      new_tcpip_attributes: ^nat$tcpip_attributes,
      new_tcpip_definition: ^nat$tcpip_definition,
      new_tcpip_pointers: ^nat$tcpip_pointers,
      old_client_pointers: ^nat$client_pointers,
      old_file_header: ^nat$application_file_header,
      old_server_pointers: ^nat$server_pointers,
      old_tcpip_pointers: ^nat$tcpip_pointers,
      v10_v11_file_header: ^nat$v10_v11_file_header;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT (highest_cycle_open) THEN
      osp$set_status_abnormal (nac$status_id, nae$application_file_not_open, define_tcpip, status);
      RETURN;
    IFEND;

    open_cycle_1 (new_file_pointer, new_file_id, status);
    new_application_file := new_file_pointer.sequence_pointer;
    RESET new_application_file;
    NEXT new_file_header IN new_application_file;
    RESET old_application_file;
    NEXT old_file_header IN old_application_file;

{ Update new file header from old.
{ Old header will be different format if not latest version.

    IF old_file_header^.version = nac$application_file_version THEN
      new_file_header^ := old_file_header^;
    ELSE
      RESET old_application_file;
      NEXT v10_v11_file_header IN old_application_file;
      new_file_header^.version := nac$application_file_version;
      new_file_header^.creation_date_time := old_file_header^.creation_date_time;
      new_file_header^.server_count := old_file_header^.server_count;
      new_file_header^.client_count := old_file_header^.client_count;
      new_file_header^.tcpip_count := 0;
    IFEND;

    pmp$get_compact_date_time (modification_date_time, ignore_status);
    new_file_header^.modification_date_time := modification_date_time;
    new_file_header^.tcpip_count := new_file_header^.tcpip_count + 1;

    IF new_file_header^.server_count > 0 THEN
      NEXT old_server_pointers: [1 .. new_file_header^.server_count] IN old_application_file;
      NEXT new_server_pointers: [1 .. new_file_header^.server_count] IN new_application_file;
    IFEND;

    IF new_file_header^.client_count > 0 THEN
      NEXT old_client_pointers: [1 .. new_file_header^.client_count] IN old_application_file;
      NEXT new_client_pointers: [1 .. new_file_header^.client_count] IN new_application_file;
    IFEND;

    IF new_file_header^.tcpip_count > 1 THEN
      NEXT old_tcpip_pointers: [1 .. new_file_header^.tcpip_count - 1] IN old_application_file;
    IFEND;

    NEXT new_tcpip_pointers: [1 .. new_file_header^.tcpip_count] IN new_application_file;

{ Move the server and client definitions to the new file.

    FOR i := 1 TO new_file_header^.server_count DO
      move_server_definition (old_server_pointers^ [i], new_server_pointers^ [i], old_application_file,
            new_application_file);
    FOREND;

    FOR i := 1 TO new_file_header^.client_count DO
      move_client_definition (old_client_pointers^ [i], new_client_pointers^ [i], old_application_file,
            new_application_file);
    FOREND;

    NEXT complete_tcpip_definition: [[nat$tcpip_definition]] IN new_application_file;
    RESET complete_tcpip_definition;
    NEXT new_tcpip_definition IN complete_tcpip_definition;

{ Setup the new tcpip definition.

    new_tcpip_definition^.tcpip_application := application;
    new_tcpip_definition^.tcpip_status := nac$application_inactive;
    new_tcpip_definition^.maximum_sockets := maximum_sockets;
    new_tcpip_definition^.tcpip_capability := tcpip_capability;
    new_tcpip_definition^.tcpip_ring := tcpip_ring;
    new_tcpip_definition^.tcpip_system_privilege := tcpip_system_privilege;
    new_tcpip_definition^.flags.nam_accounting := FALSE;
    new_tcpip_definition^.protocol := protocol;
    new_tcpip_definition^.nam_initiated_server := FALSE;
    new_tcpip_definition^.accept_connection := FALSE;
    new_tcpip_definition^.reserved_application_id := FALSE;
    new_tcpip_definition^.application_id := 0;
    new_tcpip_definition^.client_validation_capability := osc$null_name;
    new_tcpip_definition^.client_info_source := nac$client_info_via_dialog;
    new_tcpip_definition^.title_count := 0;
    new_tcpip_definition^.tcpip_managed_title_count := 0;
    new_tcpip_definition^.tcpip_listen := FALSE;
    new_tcpip_definition^.tcpip_client_address_count := 0;
    new_tcpip_definition^.tcpip_job_validation_source := nac$server_job;
    new_tcpip_definition^.tcpip_job_max_sockets := UPPERVALUE (nat$number_of_sockets);
    new_tcpip_definition^.service_file_defined := FALSE;

{ Setup the relative pointer to the new tcpip definition.

    new_tcpip_pointers^ [1].application := application;
    new_tcpip_pointers^ [1].pointer := #REL (complete_tcpip_definition, new_application_file^);

    FOR i := 1 TO new_file_header^.tcpip_count - 1 DO
      move_tcpip_definition (old_tcpip_pointers^ [i], new_tcpip_pointers^ [i + 1], old_application_file,
            new_application_file);
    FOREND;

{ Setup the tcpip attributes entry in network paged segment.

    osp$push_inhibit_job_recovery;
    IF nav$namve_active THEN
      osp$begin_subsystem_activity;
      define_tcpip_attributes_entry (new_tcpip_definition, new_tcpip_attributes);
    IFEND;
    new_file_pointer.sequence_pointer := new_application_file;
    close_and_change_cycle_1 (new_file_id, new_file_pointer, status);
    IF NOT status.normal THEN
      nap$display_message (status);
      IF nav$namve_active THEN
        FREE new_tcpip_attributes IN nav$network_paged_heap^;
        osp$end_subsystem_activity;
      IFEND;
      osp$pop_inhibit_job_recovery;
      RETURN;
    IFEND;
    IF nav$namve_active THEN
      nav$appl_defn_time_stamp := modification_date_time;
      nlp$get_exclusive_access (nav$tcpip_attributes_list.access_control);

{  link new attributes in attribute list.

      new_tcpip_attributes^.next_entry := nav$tcpip_attributes_list.
            tcpip_attributes;
      nav$tcpip_attributes_list.tcpip_attributes := new_tcpip_attributes;
      nlp$release_exclusive_access (nav$tcpip_attributes_list.access_control);
      osp$end_subsystem_activity;
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$define_tcpip;
?? TITLE := '[XDCL, #GATE] nap$delete_client', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$delete_client
    (    client: nat$application_name;
     VAR status: ost$status);

    VAR
      client_attributes: ^nat$client_attributes,
      client_definition: ^nat$client_definition,
      client_status: nat$application_status,
      complete_client_definition: ^nat$complete_client_definition,
      i: integer,
      ignore_status: ost$status,
      j: integer,
      modification_date_time: ost$date_time,
      new_application_file: ^SEQ ( * ),
      new_client_pointers: ^nat$client_pointers,
      new_file_id: amt$file_identifier,
      new_file_header: ^nat$application_file_header,
      new_file_pointer: amt$segment_pointer,
      new_server_pointers: ^nat$server_pointers,
      new_tcpip_pointers: ^nat$tcpip_pointers,
      old_client_pointers: ^nat$client_pointers,
      old_file_header: ^nat$application_file_header,
      old_server_pointers: ^nat$server_pointers,
      old_tcpip_pointers: ^nat$tcpip_pointers,
      previous_client_attributes: ^^nat$client_attributes,
      v10_client_definition: ^nat$v10_client_definition,
      v10_v11_file_header: ^nat$v10_v11_file_header;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF nav$namve_active THEN
      osp$push_inhibit_job_recovery;
      nlp$get_exclusive_access (nav$client_attributes_list.access_control);
      client_attributes := nav$client_attributes_list.client_attributes;
      previous_client_attributes := ^nav$client_attributes_list.client_attributes;
      WHILE (client_attributes <> NIL) AND (client_attributes^.client <> client) DO
        previous_client_attributes := ^client_attributes^.next_entry;
        client_attributes := client_attributes^.next_entry;
      WHILEND;

      IF client_attributes = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application, client, status);
      ELSEIF client_attributes^.client_status <> nac$application_inactive THEN
        osp$set_status_abnormal (nac$status_id, nae$application_active, client, status);
      ELSEIF client_attributes^.connection_count > 0 THEN
        osp$set_status_abnormal (nac$status_id, nae$active_connections, client, status);
      ELSEIF NOT highest_cycle_open THEN
        osp$set_status_abnormal (nac$status_id, nae$application_file_not_open, delete_client, status);
      IFEND;
    ELSE

{ NAMVE is not active.

      IF NOT highest_cycle_open THEN
        osp$set_status_abnormal (nac$status_id, nae$application_file_not_open, delete_client, status);
      ELSE
        RESET old_application_file;
        NEXT old_file_header IN old_application_file;
        find_client_definition (client, old_application_file, complete_client_definition);
        IF complete_client_definition = NIL THEN
          osp$set_status_abnormal (nac$status_id, nae$unknown_application, client, status);
        ELSE
          IF (old_file_header^.version = nac$application_file_version) OR
                (old_file_header^.version = nac$v11_appl_file_version) THEN
            NEXT client_definition IN complete_client_definition;
            client_status := client_definition^.client_status;
          ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
            NEXT v10_client_definition IN complete_client_definition;
            client_status := v10_client_definition^.client_status;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$incorrect_appl_file_version, old_file_header^.version,
                  status);
          IFEND;
          IF status.normal THEN
            IF client_status <> nac$application_inactive THEN
              osp$set_status_abnormal (nac$status_id, nae$application_active, client, status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    IF status.normal THEN
      open_cycle_1 (new_file_pointer, new_file_id, status);
      IF status.normal THEN
        RESET old_application_file;
        NEXT old_file_header IN old_application_file;
        new_application_file := new_file_pointer.sequence_pointer;
        RESET new_application_file;
        NEXT new_file_header IN new_application_file;
        IF old_file_header^.version = nac$application_file_version THEN
          new_file_header^ := old_file_header^;
        ELSE
          RESET old_application_file;
          NEXT v10_v11_file_header IN old_application_file;
          new_file_header^.version := nac$application_file_version;
          new_file_header^.creation_date_time := old_file_header^.creation_date_time;
          new_file_header^.server_count := old_file_header^.server_count;
          new_file_header^.client_count := old_file_header^.client_count;
          new_file_header^.tcpip_count := 0;
        IFEND;
        pmp$get_compact_date_time (modification_date_time, ignore_status);
        new_file_header^.modification_date_time := modification_date_time;
        new_file_header^.client_count := old_file_header^.client_count - 1;
        IF new_file_header^.server_count > 0 THEN
          NEXT old_server_pointers: [1 .. old_file_header^.server_count] IN old_application_file;
          NEXT new_server_pointers: [1 .. new_file_header^.server_count] IN new_application_file;
        IFEND;

        IF old_file_header^.client_count > 0 THEN
          NEXT old_client_pointers: [1 .. old_file_header^.client_count] IN old_application_file;
        IFEND;
        IF new_file_header^.client_count > 0 THEN
          NEXT new_client_pointers: [1 .. new_file_header^.client_count] IN new_application_file;
        IFEND;

        IF new_file_header^.tcpip_count > 0 THEN
          NEXT old_tcpip_pointers: [1 .. new_file_header^.tcpip_count] IN old_application_file;
          NEXT new_tcpip_pointers: [1 .. new_file_header^.tcpip_count] IN new_application_file;
        IFEND;

        FOR i := 1 TO new_file_header^.server_count DO
          move_server_definition (old_server_pointers^ [i], new_server_pointers^ [i], old_application_file,
                new_application_file);
        FOREND;

        IF new_file_header^.client_count > 0 THEN
          j := 1;
          FOR i := 1 TO old_file_header^.client_count DO
            IF old_client_pointers^ [i].client <> client THEN
              move_client_definition (old_client_pointers^ [i], new_client_pointers^ [j],
                    old_application_file, new_application_file);
              j := j + 1;
            IFEND;
          FOREND;
        IFEND;

{ Move tcpip definitions to the new application file.

        FOR i := 1 TO new_file_header^.tcpip_count DO
          move_tcpip_definition (old_tcpip_pointers^ [i], new_tcpip_pointers^ [i], old_application_file,
                new_application_file);
        FOREND;

        new_file_pointer.sequence_pointer := new_application_file;
        close_and_change_cycle_1 (new_file_id, new_file_pointer, status);
        IF status.normal AND nav$namve_active THEN
          previous_client_attributes^ := client_attributes^.next_entry;
          FREE client_attributes IN nav$network_paged_heap^;
          nav$appl_defn_time_stamp := modification_date_time;
        IFEND;
      IFEND;
    IFEND;

    IF nav$namve_active THEN
      nlp$release_exclusive_access (nav$client_attributes_list.access_control);
      osp$pop_inhibit_job_recovery;
    IFEND;

  PROCEND nap$delete_client;
?? TITLE := '[XDCL, #GATE] nap$delete_server', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$delete_server
    (    server: nat$application_name;
     VAR status: ost$status);

    VAR
      complete_server_definition: ^nat$complete_server_definition,
      delete_server_job_file: boolean,
      i: integer,
      ignore_status: ost$status,
      j: integer,
      modification_date_time: ost$date_time,
      new_client_pointers: ^nat$client_pointers,
      new_file_header: ^nat$application_file_header,
      new_file_id: amt$file_identifier,
      new_file_pointer: amt$segment_pointer,
      new_application_file: ^SEQ ( * ),
      new_server_pointers: ^nat$server_pointers,
      new_tcpip_pointers: ^nat$tcpip_pointers,
      old_client_pointers: ^nat$client_pointers,
      old_file_header: ^nat$application_file_header,
      old_server_pointers: ^nat$server_pointers,
      old_tcpip_pointers: ^nat$tcpip_pointers,
      server_attributes: ^nat$server_attributes,
      server_definition: ^nat$server_definition,
      server_definition_file: array [1 .. 6] of pft$name,
      server_status: nat$application_status,
      previous_server_attributes: ^^nat$server_attributes,
      v10_server_definition: ^nat$v10_server_definition,
      v10_v11_file_header: ^nat$v10_v11_file_header;

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      osp$set_status_from_condition (nac$status_id, condition, sfsa_p, status, ignore_status);
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF nav$namve_active THEN
      osp$push_inhibit_job_recovery;
      nlp$get_exclusive_access (nav$server_attributes_list.access_control);
      server_attributes := nav$server_attributes_list.server_attributes;
      previous_server_attributes := ^nav$server_attributes_list.
            server_attributes;

      WHILE (server_attributes <> NIL) AND
            (server_attributes^.server <> server) DO
        previous_server_attributes := ^server_attributes^.next_entry;
        server_attributes := server_attributes^.next_entry;
      WHILEND;

      IF server_attributes = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application,
              server, status);
      ELSEIF server_attributes^.server_status <> nac$application_inactive THEN
        osp$set_status_abnormal (nac$status_id, nae$application_active, server,
              status);
      ELSEIF server_attributes^.connection_count > 0 THEN
        osp$set_status_abnormal (nac$status_id, nae$active_connections, server,
              status);
      ELSEIF server_attributes^.server_job_list <> NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$server_jobs_attached,
              server, status);
      ELSEIF NOT highest_cycle_open THEN
        osp$set_status_abnormal (nac$status_id, nae$application_file_not_open,
              delete_server, status);
      IFEND;
    ELSE

{ NAMVE is not active.

      IF NOT highest_cycle_open THEN
        osp$set_status_abnormal (nac$status_id, nae$application_file_not_open,
              delete_server, status);
      ELSE
        RESET old_application_file;
        NEXT old_file_header IN old_application_file;
        find_server_definition (server, old_application_file,
              complete_server_definition);
        IF complete_server_definition = NIL THEN
          osp$set_status_abnormal (nac$status_id, nae$unknown_application,
                server, status);
        ELSE
          IF (old_file_header^.version = nac$application_file_version) OR
                (old_file_header^.version = nac$v11_appl_file_version) THEN
            NEXT server_definition IN complete_server_definition;
            server_status := server_definition^.server_status;
          ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
            NEXT v10_server_definition IN complete_server_definition;
            server_status := v10_server_definition^.server_status;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$incorrect_appl_file_version, old_file_header^.version,
                  status);
          IFEND;
          IF status.normal THEN
            IF server_status <> nac$application_inactive THEN
              osp$set_status_abnormal (nac$status_id, nae$application_active,
                    server, status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    IF status.normal THEN
      open_cycle_1 (new_file_pointer, new_file_id, status);
      IF status.normal THEN
        RESET old_application_file;
        NEXT old_file_header IN old_application_file;
        new_application_file := new_file_pointer.sequence_pointer;
        RESET new_application_file;
        NEXT new_file_header IN new_application_file;

        IF old_file_header^.version = nac$application_file_version THEN
          new_file_header^ := old_file_header^;
        ELSE
          RESET old_application_file;
          NEXT v10_v11_file_header IN old_application_file;
          new_file_header^.version := nac$application_file_version;
          new_file_header^.creation_date_time := old_file_header^.creation_date_time;
          new_file_header^.server_count := old_file_header^.server_count;
          new_file_header^.client_count := old_file_header^.client_count;
          new_file_header^.tcpip_count := 0;
        IFEND;
        pmp$get_compact_date_time (modification_date_time, ignore_status);
        new_file_header^.modification_date_time := modification_date_time;
        new_file_header^.server_count := old_file_header^.server_count - 1;

        IF old_file_header^.server_count > 0 THEN
          NEXT old_server_pointers: [1 .. old_file_header^.server_count] IN
                old_application_file;
        IFEND;
        IF new_file_header^.server_count > 0 THEN
          NEXT new_server_pointers: [1 .. new_file_header^.server_count] IN
                new_application_file;
        IFEND;

        IF new_file_header^.client_count > 0 THEN
          NEXT old_client_pointers: [1 .. old_file_header^.client_count] IN
                old_application_file;
          NEXT new_client_pointers: [1 .. new_file_header^.client_count] IN
                new_application_file;
        IFEND;

        IF new_file_header^.tcpip_count > 0 THEN
          NEXT old_tcpip_pointers: [1 .. new_file_header^.tcpip_count] IN
                old_application_file;
          NEXT new_tcpip_pointers: [1 .. new_file_header^.tcpip_count] IN
                new_application_file;
        IFEND;

        IF new_file_header^.server_count > 0 THEN
          j := 1;
          FOR i := 1 TO old_file_header^.server_count DO
            IF old_server_pointers^ [i].server <> server THEN
              move_server_definition (old_server_pointers^ [i],
                    new_server_pointers^ [j], old_application_file,
                    new_application_file);
              j := j + 1;
            IFEND;
          FOREND;
        IFEND;

        FOR i := 1 TO new_file_header^.client_count DO
          move_client_definition (old_client_pointers^ [i],
                new_client_pointers^ [i], old_application_file,
                new_application_file);
        FOREND;

{ Move tcpip definitions to the new application file.

        FOR i := 1 TO new_file_header^.tcpip_count DO
            move_tcpip_definition (old_tcpip_pointers^ [i],
                new_tcpip_pointers^ [i], old_application_file,
                new_application_file);
        FOREND;

        delete_server_job_file := FALSE;
        IF nav$namve_active THEN
          delete_server_job_file := (server_attributes^.
                nam_initiated_server) AND (server_attributes^.
                service_file_defined);
        ELSE
          find_server_definition (server, old_application_file,
                complete_server_definition);
          IF complete_server_definition <> NIL THEN
            IF old_file_header^.version = nac$application_file_version THEN
              NEXT server_definition IN complete_server_definition;
              delete_server_job_file := (server_definition^.
                    nam_initiated_server) AND (server_definition^.
                    service_file_defined);
            ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
              NEXT v10_server_definition IN complete_server_definition;
              delete_server_job_file := (v10_server_definition^.
                    nam_initiated_server) AND (v10_server_definition^.
                    service_file_defined);
            IFEND;
          IFEND;
        IFEND;

        new_file_pointer.sequence_pointer := new_application_file;
        close_and_change_cycle_1 (new_file_id, new_file_pointer, status);
        IF status.normal THEN
          IF delete_server_job_file THEN
            server_definition_file := application_job_file_path;
            server_definition_file [UPPERBOUND (server_definition_file)] :=
                  server;
            osp$establish_block_exit_hndlr (^handle_block_exit);
            pfp$begin_system_authority;
            pfp$purge (server_definition_file, highest_cycle, default_password,
                  ignore_status);
            pfp$end_system_authority;
            osp$disestablish_cond_handler;
          IFEND;
          IF nav$namve_active THEN
            previous_server_attributes^ := server_attributes^.next_entry;
            free_server_attributes_entry (server_attributes);
            nav$appl_defn_time_stamp := modification_date_time;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF nav$namve_active THEN
      nlp$release_exclusive_access (nav$server_attributes_list.access_control);
      osp$pop_inhibit_job_recovery;
    IFEND;

  PROCEND nap$delete_server;
?? TITLE := '[XDCL, #GATE] nap$delete_server_title ', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$delete_server_title
    (    server: nat$application_name;
         title_pattern: nat$title_pattern;
     VAR status: ost$status);

*copyc nah$delete_server_title

    VAR
      added_title: ^^nat$added_title,
      i: integer,
      next_title: ^nat$added_title,
      server_attributes: ^nat$server_attributes,
      title_found: boolean;

    IF NOT nav$namve_active THEN
      osp$set_status_condition ( nae$network_inactive,  status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    title_found := FALSE;
    #KEYPOINT (osk$entry, osk$m * amk_delete_server_title, nak$application_management);

    IF STRLENGTH (title_pattern) < 1 THEN
      osp$set_status_abnormal (nac$status_id, nae$title_pattern_too_short, delete_server_title, status);
    ELSEIF STRLENGTH (title_pattern) > nac$max_title_length THEN
      osp$set_status_abnormal (nac$status_id, nae$title_pattern_too_long, delete_server_title, status);
      osp$append_status_integer (osc$status_parameter_delimiter, STRLENGTH (title_pattern),
            10, FALSE, status);
    ELSE
      osp$push_inhibit_job_recovery;
      osp$begin_subsystem_activity;
      nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
      nap$find_server_attributes (server, server_attributes);
      IF server_attributes = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application, server, status);
      ELSE
        nlp$get_exclusive_access (server_attributes^.access_control);
        nap$validate_user (server_attributes^.server_capability, server_attributes^.server_ring,
              server_attributes^.server_system_privilege, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (nac$status_id, nae$unknown_application, server, status);
        ELSEIF server_attributes^.server_status = nac$application_inactive THEN
          osp$set_status_abnormal (nac$status_id, nae$application_inactive, server, status);
        ELSEIF (NOT server_attributes^.nam_initiated_server) AND
              (NOT server_attributes^.protocol_activated) THEN
          osp$set_status_abnormal (nac$status_id, nae$no_server_job_attached, server, status);
        ELSE
          added_title := ^server_attributes^.added_titles;
          WHILE added_title^ <> NIL DO
            IF nlp$name_match (title_pattern, added_title^^.title) THEN
              nlp$delete_registered_title (added_title^^.title, default_directory_password,
                    added_title^^.identifier, status);
              IF NOT status.normal THEN
                nap$display_message (status);
              IFEND;
              title_found := TRUE;
              next_title := added_title^^.next_title;
              FREE added_title^ IN nav$network_paged_heap^;
              added_title^ := next_title;
            ELSE
              added_title := ^added_title^^.next_title;
            IFEND;
          WHILEND;
        IFEND;
        nlp$release_exclusive_access (server_attributes^.access_control);
      IFEND;
      nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;
      IF status.normal AND NOT title_found THEN
        osp$set_status_abnormal (nac$status_id, nae$no_title_match, delete_server_title, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, server, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, title_pattern, status);
      IFEND;
    IFEND;

    #KEYPOINT (osk$entry, osk$m * amk_delete_server_title, nak$application_management);

  PROCEND nap$delete_server_title;
?? TITLE := '[XDCL] nap$delete_connection', EJECT ??
  PROCEDURE [XDCL] nap$delete_connection
    (    application: nat$application_name;
         application_type: nat$application_type;
         connection_id: nat$connection_id;
     VAR active_file: boolean;
     VAR status: ost$status);

    VAR
      assigned_connection: ^nat$server_connection_attribute,
      client_attributes: ^nat$client_attributes,
      client_connection: ^nat$client_connection_attribute,
      ignore_status: ost$status,
      previous_assigned_connection: ^^nat$server_connection_attribute,
      previous_server_connection: ^^nat$server_connection_attribute,
      server_attributes: ^nat$server_attributes,
      previous_client_connection: ^^nat$client_connection_attribute,
      server_connection: ^nat$server_connection_attribute,
      server_job_attributes: ^nat$server_job_attributes;

    IF NOT nav$namve_active THEN
      osp$set_status_condition ( nae$network_inactive,  status);
      RETURN;
    IFEND;

    #KEYPOINT (osk$entry, osk$m * amk_delete_connection, nak$application_management);
    osp$push_inhibit_job_recovery;
    active_file := TRUE;
    osp$begin_subsystem_activity;
    IF application_type = nac$server_application THEN
      nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
      nap$find_server_attributes (application, server_attributes);
      IF server_attributes <> NIL THEN
        nlp$get_exclusive_access (server_attributes^.access_control);
{ Search server connections list.
        server_connection := server_attributes^.server_connections_list;
        previous_server_connection := ^server_attributes^.server_connections_list;
        WHILE (server_connection <> NIL) AND (server_connection^.connection_id <> connection_id) DO
          previous_server_connection := ^server_connection^.next_entry;
          server_connection := server_connection^.next_entry;
        WHILEND;

        IF server_connection <> NIL THEN
          previous_server_connection^ := server_connection^.next_entry;
          server_attributes^.connection_count := server_attributes^.connection_count - 1;
          IF server_connection^.connection_kind = nac$owned_by_job THEN
            server_job_attributes := server_attributes^.server_job_list;
            WHILE (server_job_attributes <> NIL) AND (server_job_attributes^.job_name <>
                  server_connection^.job_name) DO
              server_job_attributes := server_job_attributes^.next_entry;
            WHILEND;
            IF server_job_attributes <> NIL THEN
              server_job_attributes^.connection_count := server_job_attributes^.connection_count - 1;
            IFEND;
          IFEND;
          FREE server_connection IN nav$network_paged_heap^;
        ELSE
{ Search assigned connections list.
          assigned_connection := server_attributes^.assigned_connections_list;
          previous_assigned_connection := ^server_attributes^.assigned_connections_list;
          WHILE (assigned_connection <> NIL) AND (assigned_connection^.connection_id <> connection_id) DO
            previous_assigned_connection := ^assigned_connection^.next_entry;
            assigned_connection := assigned_connection^.next_entry;
          WHILEND;
          IF assigned_connection = NIL THEN
{ ***DEBUG  pmp$log ('AM Lost connection id', ignore_status);
          ELSE
            active_file := FALSE;
            previous_assigned_connection^ := assigned_connection^.next_entry;
            server_attributes^.connection_count := server_attributes^.connection_count - 1;
            IF assigned_connection^.directed_connection THEN
              server_job_attributes := server_attributes^.server_job_list;
              WHILE (server_job_attributes <> NIL) AND (server_job_attributes^.job_name <>
                    assigned_connection^.destination_job_name) DO
                server_job_attributes := server_job_attributes^.next_entry;
              WHILEND;
              IF server_job_attributes <> NIL THEN
                server_job_attributes^.assigned_connection_count :=
                      server_job_attributes^.assigned_connection_count - 1;
              IFEND;
            IFEND;
            FREE assigned_connection IN nav$network_paged_heap^;
          IFEND;
        IFEND;

        IF (server_attributes^.server_status = nac$application_inactive) AND
              (server_attributes^.connection_count = 0) THEN
          nlp$se_close_sap (server_attributes^.application_id, ignore_status);
          unassign_sap_identifier (server_attributes^.application_id.osi_sap_identifier);
          IF NOT server_attributes^.reserved_application_id THEN
            server_attributes^.application_id.osi_sap_identifier := 0;
          IFEND;
          server_attributes^.sap_open := FALSE;
        IFEND;
        nlp$release_exclusive_access (server_attributes^.access_control);
      IFEND;

      nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
    ELSE
      nlp$get_nonexclusive_access (nav$client_attributes_list.access_control);
      nap$find_client_attributes (application, client_attributes);
      IF client_attributes <> NIL THEN
        nlp$get_exclusive_access (client_attributes^.access_control);
        client_connection := client_attributes^.client_connections_list;
        previous_client_connection := ^client_attributes^.client_connections_list;
        WHILE (client_connection <> NIL) AND (client_connection^.connection_id <> connection_id) DO
          previous_client_connection := ^client_connection^.next_entry;
          client_connection := client_connection^.next_entry;
        WHILEND;

        IF client_connection <> NIL THEN
          previous_client_connection^ := client_connection^.next_entry;
          FREE client_connection IN nav$network_paged_heap^;
          client_attributes^.connection_count := client_attributes^.connection_count - 1;
        IFEND;

        IF (client_attributes^.client_status = nac$application_inactive) AND
              (client_attributes^.connection_count = 0) THEN
          nlp$se_close_sap (client_attributes^.application_id, ignore_status);
          unassign_sap_identifier (client_attributes^.application_id.osi_sap_identifier);
          IF NOT client_attributes^.reserved_application_id THEN
            client_attributes^.application_id.osi_sap_identifier := 0;
          IFEND;
          client_attributes^.sap_open := FALSE;
        IFEND;
        nlp$release_exclusive_access (client_attributes^.access_control);
      IFEND;
      nlp$release_nonexclusive_access (nav$client_attributes_list.access_control);
    IFEND;

    osp$end_subsystem_activity;
    osp$pop_inhibit_job_recovery;
    #KEYPOINT (osk$exit, osk$m * amk_delete_connection, nak$application_management);

  PROCEND nap$delete_connection;
?? TITLE := '[XDCL, #GATE] nap$delete_tcpip', EJECT ??
*copyc nah$delete_tcpip

  PROCEDURE [XDCL, #GATE] nap$delete_tcpip
    (    application: nat$application_name;
     VAR status: ost$status);

    VAR
      complete_tcpip_definition: ^nat$complete_tcpip_definition,
      i: integer,
      ignore_status: ost$status,
      j: integer,
      modification_date_time: ost$date_time,
      new_application_file: ^SEQ ( * ),
      new_client_pointers: ^nat$client_pointers,
      new_file_id: amt$file_identifier,
      new_file_header: ^nat$application_file_header,
      new_file_pointer: amt$segment_pointer,
      new_server_pointers: ^nat$server_pointers,
      new_tcpip_pointers: ^nat$tcpip_pointers,
      old_client_pointers: ^nat$client_pointers,
      old_file_header: ^nat$application_file_header,
      old_server_pointers: ^nat$server_pointers,
      old_tcpip_pointers: ^nat$tcpip_pointers,
      previous_tcpip_attributes : ^^nat$tcpip_attributes,
      tcpip_attributes: ^nat$tcpip_attributes,
      tcpip_definition: ^nat$tcpip_definition;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF nav$namve_active THEN
      osp$push_inhibit_job_recovery;
      nlp$get_exclusive_access (nav$tcpip_attributes_list.access_control);

{ Find tcpip applications attributes.

      tcpip_attributes := nav$tcpip_attributes_list.tcpip_attributes;
      previous_tcpip_attributes := ^nav$tcpip_attributes_list.tcpip_attributes;
      WHILE (tcpip_attributes <> NIL) AND (tcpip_attributes^.tcpip_application <> application) DO
        previous_tcpip_attributes := ^tcpip_attributes^.next_entry;
        tcpip_attributes := tcpip_attributes^.next_entry;
      WHILEND;

      IF tcpip_attributes = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application, application, status);
      ELSEIF tcpip_attributes^.tcpip_status <> nac$application_inactive THEN
        osp$set_status_abnormal (nac$status_id, nae$application_active, application, status);
      ELSEIF tcpip_attributes^.active_socket_count > 0 THEN
        osp$set_status_abnormal (nac$status_id, nae$active_sockets, application, status);
      ELSEIF NOT highest_cycle_open THEN
        osp$set_status_abnormal (nac$status_id, nae$application_file_not_open, delete_tcpip, status);
      IFEND;
    ELSE { NAMVE is not active.


      IF NOT highest_cycle_open THEN
        osp$set_status_abnormal (nac$status_id, nae$application_file_not_open, delete_tcpip, status);
      ELSE { Application definition file highest cycle open.
        RESET old_application_file;
        NEXT old_file_header IN old_application_file;
        find_tcpip_definition (application, old_application_file, complete_tcpip_definition);
        IF complete_tcpip_definition = NIL THEN
          osp$set_status_abnormal (nac$status_id, nae$unknown_application, application, status);
        ELSE { tcpip application definition found on appl definition file.
          NEXT tcpip_definition IN complete_tcpip_definition;
          IF status.normal THEN
            IF tcpip_definition^.tcpip_status <> nac$application_inactive THEN
              osp$set_status_abnormal (nac$status_id, nae$application_active, application, status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    IF status.normal THEN
      open_cycle_1 (new_file_pointer, new_file_id, status);
      IF status.normal THEN
        RESET old_application_file;
        NEXT old_file_header IN old_application_file;
        new_application_file := new_file_pointer.sequence_pointer;
        RESET new_application_file;
        NEXT new_file_header IN new_application_file;
        new_file_header^ := old_file_header^;
        pmp$get_compact_date_time (modification_date_time, ignore_status);
        new_file_header^.modification_date_time := modification_date_time;
        new_file_header^.tcpip_count := old_file_header^.tcpip_count - 1;

        IF new_file_header^.server_count > 0 THEN
          NEXT old_server_pointers: [1 .. old_file_header^.server_count] IN old_application_file;
          NEXT new_server_pointers: [1 .. new_file_header^.server_count] IN new_application_file;
        IFEND;

        IF new_file_header^.client_count > 0 THEN
          NEXT old_client_pointers: [1 .. old_file_header^.client_count] IN old_application_file;
          NEXT new_client_pointers: [1 .. new_file_header^.client_count] IN new_application_file;
        IFEND;

        IF old_file_header^.tcpip_count > 0 THEN
          NEXT old_tcpip_pointers: [1 .. old_file_header^.tcpip_count] IN old_application_file;
        IFEND;
        IF new_file_header^.tcpip_count > 0 THEN
          NEXT new_tcpip_pointers: [1 .. new_file_header^.tcpip_count] IN new_application_file;
        IFEND;

        FOR i := 1 TO new_file_header^.server_count DO
          move_server_definition (old_server_pointers^ [i], new_server_pointers^ [i], old_application_file,
                new_application_file);
        FOREND;

        FOR i := 1 TO new_file_header^.client_count DO
          move_client_definition (old_client_pointers^ [i], new_client_pointers^ [i], old_application_file,
                new_application_file);
        FOREND;


        IF new_file_header^.tcpip_count > 0 THEN
          j := 1;
          FOR i := 1 TO old_file_header^.tcpip_count DO
            IF old_tcpip_pointers^ [i].application <> application THEN
              move_tcpip_definition (old_tcpip_pointers^ [i], new_tcpip_pointers^ [j], old_application_file,
                    new_application_file);
              j := j + 1;
            IFEND;
          FOREND;
        IFEND;

        new_file_pointer.sequence_pointer := new_application_file;
        close_and_change_cycle_1 (new_file_id, new_file_pointer, status);
        IF status.normal AND nav$namve_active THEN

{ Delink attributes entry and release storage.

          previous_tcpip_attributes^ := tcpip_attributes^.next_entry;
          FREE tcpip_attributes IN nav$network_paged_heap^;
          nav$appl_defn_time_stamp := modification_date_time;
        IFEND;
      IFEND;
    IFEND;

    IF nav$namve_active THEN
      nlp$release_exclusive_access (nav$tcpip_attributes_list.access_control);
      osp$pop_inhibit_job_recovery;
    IFEND;
  PROCEND nap$delete_tcpip;
?? TITLE := '[XDCL, #GATE] nap$detach_application_file', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to close and return the highest cycle of the
{   application file. Application management capability is assumed since it would
{   have been required to attach the file.

  PROCEDURE [XDCL, #GATE] nap$detach_application_file
    (VAR status: ost$status);

    VAR
      cycle_id_is_valid: boolean,
      highest_cycle_instance: ^bat$task_file_entry,
      highest_cycle_lfn: amt$local_file_name;

    status.normal := TRUE;
    IF highest_cycle_open THEN
      bap$validate_file_identifier (highest_cycle_id, highest_cycle_instance, cycle_id_is_valid);
      highest_cycle_lfn := highest_cycle_instance^.local_file_name;
      fsp$close_file (highest_cycle_id, status);
      IF status.normal THEN
        highest_cycle_open := FALSE;
        amp$return (highest_cycle_lfn, status);
      IFEND;
    IFEND;

  PROCEND nap$detach_application_file;
?? TITLE := '[XDCL, #GATE] nap$detach_server_application', EJECT ??
*copyc nah$detach_server_application
  PROCEDURE [XDCL, #GATE] nap$detach_server_application
    (    server: nat$application_name;
     VAR status: ost$status);

    VAR
      job_name: jmt$system_supplied_name,
      user_supplied_name: jmt$user_supplied_name;


    IF NOT nav$namve_active THEN
      osp$set_status_condition ( nae$network_inactive,  status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, osk$m * amk_detach_server_application, nak$application_management);
    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);

    pmp$get_job_names (user_supplied_name, job_name, {ignore} status);
    status.normal := TRUE;
    detach_server_application (job_name, server, status);

    nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
    osp$end_subsystem_activity;
    osp$pop_inhibit_job_recovery;
    #KEYPOINT (osk$exit, osk$m * amk_detach_server_application, nak$application_management);

  PROCEND nap$detach_server_application;
?? TITLE := '[XDCL, #GATE] nap$detach_specific_server_appl', EJECT ??

{ PURPOSE:
{   The purpose of this request is to detach the specified server application.  The
{   request is the same as nap$detach_server_application except that the job name is
{   a parameter on this request.

  PROCEDURE [XDCL, #GATE] nap$detach_specific_server_appl
    (    system_job_name: jmt$system_supplied_name;
         server: nat$application_name;
     VAR status: ost$status);


    IF NOT nav$namve_active THEN
      osp$set_status_condition (nae$network_inactive, status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, osk$m * amk_detach_server_application, nak$application_management);
    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);

    detach_server_application (system_job_name, server, status);

    nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
    osp$end_subsystem_activity;
    osp$pop_inhibit_job_recovery;
    #KEYPOINT (osk$exit, osk$m * amk_detach_server_application, nak$application_management);

  PROCEND nap$detach_specific_server_appl;
?? TITLE := '[XDCL, #GATE] nap$get_application_names', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$get_application_names
    (    type_of_applications: SET OF nat$application_type;
     VAR application_attributes: array [1 .. * ] of nat$application_attribute;
     VAR number_of_applications: nat$max_applications;
     VAR status: ost$status);

    VAR
      application_file_attached: boolean,
      client_attributes: ^nat$client_attributes,
      i: integer,
      j: integer,
      old_client_pointers: ^nat$client_pointers,
      old_file_header: ^nat$application_file_header,
      old_server_pointers: ^nat$server_pointers,
      old_tcpip_pointers: ^nat$tcpip_pointers,
      server_attributes: ^nat$server_attributes,
      tcpip_attributes: ^nat$tcpip_attributes,
      v10_v11_file_header: ^nat$v10_v11_file_header;

    status.normal := TRUE;
    number_of_applications := 0;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF nav$namve_active THEN
      osp$push_inhibit_job_recovery;
      osp$begin_subsystem_activity;

{ Sum up all defined client applications.

      IF nac$client_application IN type_of_applications THEN
        nlp$get_nonexclusive_access (nav$client_attributes_list.access_control);
        client_attributes := nav$client_attributes_list.client_attributes;
        WHILE client_attributes <> NIL DO
          number_of_applications := number_of_applications + 1;
          client_attributes := client_attributes^.next_entry;
        WHILEND;

        nlp$release_nonexclusive_access (nav$client_attributes_list.
              access_control);
      IFEND;

{ Sum up all defined server applications.

      IF nac$server_application IN type_of_applications THEN
        nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
        server_attributes := nav$server_attributes_list.server_attributes;
        WHILE server_attributes <> NIL DO
          number_of_applications := number_of_applications + 1;
          server_attributes := server_attributes^.next_entry;
        WHILEND;

        nlp$release_nonexclusive_access (nav$server_attributes_list.
              access_control);
      IFEND;

{ Sum up all defined tcpip applications.

      IF nac$tcpip_application IN type_of_applications THEN
        nlp$get_nonexclusive_access (nav$tcpip_attributes_list.access_control);
        tcpip_attributes := nav$tcpip_attributes_list.tcpip_attributes;
        WHILE tcpip_attributes <> NIL DO
          number_of_applications := number_of_applications + 1;
          tcpip_attributes := tcpip_attributes^.next_entry;
        WHILEND;

        nlp$release_nonexclusive_access (nav$tcpip_attributes_list.
              access_control);
      IFEND;

      IF (number_of_applications > 0) AND (number_of_applications <=
            UPPERBOUND (application_attributes)) THEN
        i := LOWERBOUND (application_attributes);

        IF nac$server_application IN type_of_applications THEN
          nlp$get_nonexclusive_access (nav$server_attributes_list.
                access_control);
          server_attributes := nav$server_attributes_list.server_attributes;
          WHILE server_attributes <> NIL DO
            application_attributes [i].name := server_attributes^.server;
            application_attributes [i].application_type :=
                  nac$server_application;
            i := i + 1;
            server_attributes := server_attributes^.next_entry;
          WHILEND;

          nlp$release_nonexclusive_access (nav$server_attributes_list.
                access_control);

        IFEND;
        IF nac$client_application IN type_of_applications THEN
          nlp$get_nonexclusive_access (nav$client_attributes_list.
                access_control);
          client_attributes := nav$client_attributes_list.client_attributes;
          WHILE client_attributes <> NIL DO
            application_attributes [i].name := client_attributes^.client;
            application_attributes [i].application_type :=
                  nac$client_application;
            i := i + 1;
            client_attributes := client_attributes^.next_entry;
          WHILEND;

          nlp$release_nonexclusive_access (nav$client_attributes_list.
                access_control);
        IFEND;
        IF nac$tcpip_application IN type_of_applications THEN
          nlp$get_nonexclusive_access (nav$tcpip_attributes_list.
                access_control);
          tcpip_attributes := nav$tcpip_attributes_list.tcpip_attributes;
          WHILE tcpip_attributes <> NIL DO
            application_attributes [i].name := tcpip_attributes^.tcpip_application;
            application_attributes [i].application_type :=
                  nac$tcpip_application;
            i := i + 1;
            tcpip_attributes := tcpip_attributes^.next_entry;
          WHILEND;

          nlp$release_nonexclusive_access (nav$tcpip_attributes_list.
                access_control);
        IFEND;
      IFEND;
      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;
    ELSE

{ NAMVE is not active.

      IF NOT highest_cycle_open THEN
        nap$attach_application_file (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        application_file_attached := TRUE;
      IFEND;

{ Sum up all defined client and server applications.

      RESET old_application_file;
      NEXT old_file_header IN old_application_file;

      IF old_file_header^.version <> nac$application_file_version THEN
        RESET old_application_file;
        NEXT v10_v11_file_header IN old_application_file;
      IFEND;
      IF old_file_header^.server_count > 0 THEN
        NEXT old_server_pointers: [1 .. old_file_header^.server_count] IN
              old_application_file;
      IFEND;
      IF old_file_header^.client_count > 0 THEN
        NEXT old_client_pointers: [1 .. old_file_header^.client_count] IN
              old_application_file;
      IFEND;
      IF old_file_header^.version = nac$application_file_version THEN
        IF old_file_header^.tcpip_count > 0 THEN
          NEXT old_tcpip_pointers: [1 .. old_file_header^.tcpip_count] IN
                old_application_file;
        IFEND;
      IFEND;
      IF nac$client_application IN type_of_applications THEN
        number_of_applications := old_file_header^.client_count;
      IFEND;
      IF nac$server_application IN type_of_applications THEN
        number_of_applications := number_of_applications +
              old_file_header^.server_count;
      IFEND;
      IF (nac$tcpip_application IN type_of_applications) AND
            (old_file_header^.version = nac$application_file_version) THEN
        number_of_applications := number_of_applications +
              old_file_header^.tcpip_count;
      IFEND;

      IF (number_of_applications > 0) AND (number_of_applications <=
            UPPERBOUND (application_attributes)) THEN
        i := LOWERBOUND (application_attributes);
        IF nac$server_application IN type_of_applications THEN
          FOR j := 1 TO old_file_header^.server_count DO
            application_attributes [i].name := old_server_pointers^ [j].server;
            application_attributes [i].application_type :=
                  nac$server_application;
            i := i + 1;
          FOREND;
        IFEND;
        IF nac$client_application IN type_of_applications THEN
          FOR j := 1 TO old_file_header^.client_count DO
            application_attributes [i].name := old_client_pointers^ [j].client;
            application_attributes [i].application_type :=
                  nac$client_application;
            i := i + 1;
          FOREND;
        IFEND;
        IF (nac$tcpip_application IN type_of_applications) AND
            (old_file_header^.version = nac$application_file_version) THEN
          FOR j := 1 TO old_file_header^.tcpip_count DO
            application_attributes [i].name := old_tcpip_pointers^ [j].application;
            application_attributes [i].application_type :=
                  nac$tcpip_application;
            i := i + 1;
          FOREND;
        IFEND;

      IFEND;

      IF application_file_attached THEN
        nap$detach_application_file (status);
      IFEND;
    IFEND;

  PROCEND nap$get_application_names;
?? TITLE := '[XDCL, #GATE] nap$get_application_type', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$get_application_type
    (    application: nat$application_name;
     VAR application_type: nat$application_type;
     VAR status: ost$status);

    VAR
      application_file_attached: boolean,
      client_attributes: ^nat$client_attributes,
      client_definition: ^nat$complete_client_definition,
      ignore_status: ost$status,
      local_status: ost$status,
      old_file_header: ^nat$application_file_header,
      server_attributes: ^nat$server_attributes,
      server_definition: ^nat$complete_server_definition;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF nav$namve_active THEN
      osp$push_inhibit_job_recovery;
      osp$begin_subsystem_activity;
      nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
      nap$find_server_attributes (application, server_attributes);
      nlp$release_nonexclusive_access (nav$server_attributes_list.
            access_control);
      IF server_attributes <> NIL THEN
        application_type := nac$server_application;
      ELSE
        nlp$get_nonexclusive_access (nav$client_attributes_list.
              access_control);
        nap$find_client_attributes (application, client_attributes);
        nlp$release_nonexclusive_access (nav$client_attributes_list.
              access_control);
        IF client_attributes <> NIL THEN
          application_type := nac$client_application;
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$unknown_application,
                application, status);
        IFEND;
      IFEND;
      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;
    ELSE
      application_file_attached := FALSE;
      IF NOT highest_cycle_open THEN
        nap$attach_application_file (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        application_file_attached := TRUE;
      IFEND;

      RESET old_application_file;
      NEXT old_file_header IN old_application_file;
      find_server_definition (application, old_application_file,
            server_definition);
      IF server_definition <> NIL THEN
        application_type := nac$server_application;
      ELSE
        find_client_definition (application, old_application_file,
              client_definition);
        IF client_definition <> NIL THEN
          application_type := nac$client_application;
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$unknown_application,
                application, status);
        IFEND;
      IFEND;

      IF application_file_attached THEN
        nap$detach_application_file (local_status);
        IF (status.normal) AND (NOT local_status.normal) THEN
          status := local_status;
        ELSE
          nap$display_message (local_status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND nap$get_application_type;
?? TITLE := '[XDCL, #GATE] nap$get_client_status', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$get_client_status
    (    client: nat$application_name;
     VAR client_status: nat$application_status;
     VAR reserved_application_id: boolean;
     VAR application_id: nat$internet_sap_identifier;
     VAR active_connection_count: nat$number_of_connections;
     VAR attempted_connection_count: integer;
     VAR rejected_connection_attempts: integer;
     VAR status: ost$status);


    VAR
      client_attributes: ^nat$client_attributes;

    IF NOT nav$namve_active THEN
      osp$set_status_condition ( nae$network_inactive,  status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    nlp$get_nonexclusive_access (nav$client_attributes_list.access_control);
    nap$find_client_attributes (client, client_attributes);
    IF client_attributes = NIL THEN
      osp$set_status_abnormal (nac$status_id, nae$unknown_application, client, status);
    ELSE
      nlp$get_nonexclusive_access (client_attributes^.access_control);
      client_status := client_attributes^.client_status;
      reserved_application_id := client_attributes^.reserved_application_id;
      application_id := client_attributes^.application_id.xns_sap_identifier;
      active_connection_count := client_attributes^.connection_count;
      attempted_connection_count := client_attributes^.attempted_connection_count;
      rejected_connection_attempts := client_attributes^.rejected_connection_attempts;
      nlp$release_nonexclusive_access (client_attributes^.access_control);
    IFEND;

    nlp$release_nonexclusive_access (nav$client_attributes_list.access_control);
    osp$end_subsystem_activity;
    osp$pop_inhibit_job_recovery;

  PROCEND nap$get_client_status;
?? TITLE := '[XDCL, #GATE] nap$get_client_attributes', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$get_client_attributes
    (    client: nat$application_name;
     VAR client_status: nat$application_status;
     VAR max_connections: nat$number_of_connections;
     VAR connection_priority: nat$network_message_priority;
     VAR protocol: nat$protocol;
     VAR reserved_application_id: boolean;
     VAR application_id: nat$internet_sap_identifier;
     VAR client_capability: ost$name;
     VAR client_ring: ost$ring;
     VAR client_system_privilege: boolean;
     VAR status: ost$status);

    VAR
      application_file_attached: boolean,
      client_attributes: ^nat$client_attributes,
      client_definition: ^nat$client_definition,
      complete_client_definition: ^nat$complete_client_definition,
      converted_client_definition: ^nat$complete_client_definition,
      ignore_status: ost$status,
      local_status: ost$status,
      old_file_header: ^nat$application_file_header;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF nav$namve_active THEN
      osp$push_inhibit_job_recovery;
      osp$begin_subsystem_activity;
      nlp$get_nonexclusive_access (nav$client_attributes_list.access_control);
      nap$find_client_attributes (client, client_attributes);
      IF client_attributes = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application,
              client, status);
      ELSE
        nlp$get_nonexclusive_access (client_attributes^.access_control);
        client_status := client_attributes^.client_status;
        max_connections := client_attributes^.max_connections;
        connection_priority := client_attributes^.message_priority;
        protocol := client_attributes^.protocol;
        reserved_application_id := client_attributes^.reserved_application_id;
        IF reserved_application_id THEN
          application_id := client_attributes^.application_id.xns_sap_identifier;
        IFEND;
        client_capability := client_attributes^.client_capability;
        client_ring := client_attributes^.client_ring;
        client_system_privilege := client_attributes^.client_system_privilege;
        nlp$release_nonexclusive_access (client_attributes^.access_control);
      IFEND;
      nlp$release_nonexclusive_access (nav$client_attributes_list.
            access_control);
      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;

    ELSE

{ NAMVE is not active.

      application_file_attached := FALSE;
      IF NOT highest_cycle_open THEN
        nap$attach_application_file (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        application_file_attached := TRUE;
      IFEND;

      RESET old_application_file;
      NEXT old_file_header IN old_application_file;
      find_client_definition (client, old_application_file,
            complete_client_definition);
      IF complete_client_definition = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application,
              client, status);
      ELSE
        IF (old_file_header^.version = nac$application_file_version) OR
              (old_file_header^.version = nac$v11_appl_file_version) THEN
          NEXT client_definition IN complete_client_definition;
        ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
          convert_v10_client_to_v11 (complete_client_definition,
                converted_client_definition);
          RESET converted_client_definition;
          NEXT client_definition IN converted_client_definition;
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$incorrect_appl_file_version,
                old_file_header^.version, status);
        IFEND;
        IF status.normal THEN
          client_status := client_definition^.client_status;
          max_connections := client_definition^.max_connections;
          connection_priority := client_definition^.message_priority;
          protocol := client_definition^.protocol;
          reserved_application_id := client_definition^.reserved_application_id;
          IF reserved_application_id THEN
            application_id := client_definition^.application_id;
          IFEND;
          client_capability := client_definition^.client_capability;
          client_ring := client_definition^.client_ring;
          client_system_privilege := client_definition^.client_system_privilege;
          IF old_file_header^.version = nac$v10_appl_file_version THEN
            FREE converted_client_definition IN osv$task_private_heap^;
          IFEND;
        IFEND;
      IFEND;

      IF application_file_attached THEN
        nap$detach_application_file (local_status);
        IF (status.normal) AND (NOT local_status.normal) THEN
          status := local_status;
        ELSE
          nap$display_message (local_status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND nap$get_client_attributes;
?? TITLE := '[XDCL, #GATE] nap$get_server_attributes', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$get_server_attributes
    (    server: nat$application_name;
     VAR server_status: nat$application_status;
     VAR selected_title_count: nat$max_titles;
         selected_titles: ^nat$selected_titles_list;
     VAR server_managed_title_count: nat$max_titles;
         server_managed_titles: ^nat$title_pattern_list;
     VAR max_connections: nat$number_of_connections;
     VAR connection_priority: nat$network_message_priority;
     VAR server_capability: ost$name;
     VAR server_ring: ost$ring;
     VAR server_system_privilege: boolean;
     VAR accept_connection: boolean;
     VAR client_validation_capability: ost$name;
     VAR client_info_source: nat$client_info_source;
     VAR client_address_count: integer;
         client_addresses: ^array [1 .. * ] of nat$client_address;
     VAR reserved_application_id: boolean;
     VAR application_id: nat$internet_sap_identifier;
     VAR protocol: nat$protocol;
     VAR nam_initiated_server: boolean;
     VAR server_job_validation_source: nat$server_validation_source;
     VAR server_job_max_connections: nat$number_of_connections;
     VAR server_job_specified: boolean;
     VAR status: ost$status);

    VAR
      application_file_attached: boolean,
      client_address_list: ^array [1 .. * ] of nat$client_address,
      complete_server_definition: ^nat$complete_server_definition,
      converted_server_definition: ^nat$complete_server_definition,
      i: integer,
      ignore_status: ost$status,
      local_status: ost$status,
      old_file_header: ^nat$application_file_header,
      selected_titles_list: ^nat$selected_titles_list,
      server_attributes: ^nat$server_attributes,
      server_definition: ^nat$server_definition,
      server_managed_titles_list: ^nat$title_pattern_list;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF nav$namve_active THEN
      osp$push_inhibit_job_recovery;
      osp$begin_subsystem_activity;
      nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
      nap$find_server_attributes (server, server_attributes);
      IF server_attributes = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application,
              server, status);
      ELSE
        nlp$get_nonexclusive_access (server_attributes^.access_control);
        IF server_attributes^.server_titles <> NIL THEN
          selected_title_count := UPPERBOUND (server_attributes^.
                server_titles^);
          IF selected_title_count <= UPPERBOUND (selected_titles^) THEN
            FOR i := 1 TO selected_title_count DO
              selected_titles^ [i].title := server_attributes^.
                    server_titles^ [i].title;
              selected_titles^ [i].distribute_title :=
                    server_attributes^.server_titles^ [i].distribute_title;
              selected_titles^ [i].priority :=
                    server_attributes^.server_titles^ [i].priority;
              selected_titles^ [i].data := server_attributes^.
                    server_titles^ [i].data;
              selected_titles^ [i].data_length :=
                    server_attributes^.server_titles^ [i].data_length;
            FOREND;
          IFEND;
        ELSE
          selected_title_count := 0;
        IFEND;

        IF server_attributes^.server_managed_titles <> NIL THEN
          server_managed_title_count := UPPERBOUND (server_attributes^.
                server_managed_titles^);
          IF server_managed_title_count <= UPPERBOUND (server_managed_titles^)
                THEN
            FOR i := 1 TO server_managed_title_count DO
              server_managed_titles^ [i] := server_attributes^.
                    server_managed_titles^ [i];
            FOREND;
          IFEND;
        ELSE
          server_managed_title_count := 0;
        IFEND;

        IF server_attributes^.client_addresses <> NIL THEN
          client_address_count := UPPERBOUND (server_attributes^.
                client_addresses^);
          IF client_address_count <= UPPERBOUND (client_addresses^) THEN
            FOR i := 1 TO client_address_count DO
              client_addresses^ [i] := server_attributes^.
                    client_addresses^ [i];
            FOREND;
          IFEND;
        ELSE
          client_address_count := 0;
        IFEND;

        server_status := server_attributes^.server_status;
        max_connections := server_attributes^.max_connections;
        connection_priority := server_attributes^.message_priority;
        server_capability := server_attributes^.server_capability;
        server_ring := server_attributes^.server_ring;
        server_system_privilege := server_attributes^.server_system_privilege;
        accept_connection := server_attributes^.accept_connection;
        client_validation_capability := server_attributes^.
              client_validation_capability;
        client_info_source := server_attributes^.client_info_source;
        reserved_application_id := server_attributes^.reserved_application_id;
        IF reserved_application_id THEN
          application_id := server_attributes^.application_id.xns_sap_identifier;
        IFEND;
        protocol := server_attributes^.protocol;
        nam_initiated_server := server_attributes^.nam_initiated_server;
        IF nam_initiated_server THEN
          server_job_validation_source := server_attributes^.
                server_job_validation_source;
          server_job_max_connections := server_attributes^.
                server_job_max_connections;
          server_job_specified := server_attributes^.service_file_defined;
        IFEND;
        nlp$release_nonexclusive_access (server_attributes^.access_control);
      IFEND;

      nlp$release_nonexclusive_access (nav$server_attributes_list.
            access_control);
      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;
    ELSE

{ NAMVE is not active.

      application_file_attached := FALSE;
      IF NOT highest_cycle_open THEN
        nap$attach_application_file (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        application_file_attached := TRUE;
      IFEND;

      RESET old_application_file;
      NEXT old_file_header IN old_application_file;
      find_server_definition (server, old_application_file,
            complete_server_definition);
      IF complete_server_definition = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application,
              server, status);
      ELSE
        IF (old_file_header^.version = nac$application_file_version) OR
              (old_file_header^.version = nac$v11_appl_file_version) THEN
          NEXT server_definition IN complete_server_definition;
        ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
          convert_v10_server_to_v11 (complete_server_definition,
                converted_server_definition);
          RESET converted_server_definition;
          NEXT server_definition IN converted_server_definition;
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$incorrect_appl_file_version,
                old_file_header^.version, status);
        IFEND;
        IF status.normal THEN
          selected_title_count := server_definition^.title_count;
          IF selected_title_count > 0 THEN
            IF (old_file_header^.version = nac$application_file_version) OR
                  (old_file_header^.version = nac$v11_appl_file_version) THEN
              selected_titles_list := #PTR (server_definition^.selected_titles,
                    complete_server_definition^);
            ELSE
              selected_titles_list := #PTR (server_definition^.selected_titles,
                    converted_server_definition^);
            IFEND;
            IF selected_title_count <= UPPERBOUND (selected_titles^) THEN
              FOR i := 1 TO selected_title_count DO
                selected_titles^ [i] := selected_titles_list^ [i];
              FOREND;
            IFEND;
          IFEND;

          server_managed_title_count := server_definition^.
                server_managed_title_count;
          IF server_managed_title_count > 0 THEN
            IF (old_file_header^.version = nac$application_file_version) OR
                  (old_file_header^.version = nac$v11_appl_file_version) THEN
              server_managed_titles_list := #PTR (server_definition^.
                    server_managed_titles, complete_server_definition^);
            ELSE
              server_managed_titles_list := #PTR (server_definition^.
                    server_managed_titles, converted_server_definition^);
            IFEND;
            IF server_managed_title_count <= UPPERBOUND (server_managed_titles^)
                  THEN
              FOR i := 1 TO server_managed_title_count DO
                server_managed_titles^ [i] := server_managed_titles_list^ [i];
              FOREND;
            IFEND;
          IFEND;

          client_address_count := server_definition^.client_address_count;
          IF client_address_count > 0 THEN
            IF (old_file_header^.version = nac$application_file_version) OR
                  (old_file_header^.version = nac$v11_appl_file_version) THEN
              client_address_list := #PTR (server_definition^.client_addresses,
                    complete_server_definition^);
            ELSE
              client_address_list := #PTR (server_definition^.client_addresses,
                    converted_server_definition^);
            IFEND;
            IF client_address_count <= UPPERBOUND (client_addresses^) THEN
              FOR i := 1 TO client_address_count DO
                client_addresses^ [i] := client_address_list^ [i];
              FOREND;
            IFEND;
          IFEND;

          server_status := server_definition^.server_status;
          max_connections := server_definition^.max_connections;
          connection_priority := server_definition^.message_priority;
          server_capability := server_definition^.server_capability;
          server_ring := server_definition^.server_ring;
          server_system_privilege := server_definition^.server_system_privilege;
          accept_connection := server_definition^.accept_connection;
          client_validation_capability := server_definition^.
                client_validation_capability;
          client_info_source := server_definition^.client_info_source;
          reserved_application_id := server_definition^.reserved_application_id;
          IF reserved_application_id THEN
            application_id := server_definition^.application_id;
          IFEND;
          protocol := server_definition^.protocol;
          nam_initiated_server := server_definition^.nam_initiated_server;
          IF nam_initiated_server THEN
            server_job_validation_source := server_definition^.
                  server_job_validation_source;
            server_job_max_connections := server_definition^.
                  server_job_max_connections;
            server_job_specified := server_definition^.service_file_defined;
          IFEND;
          IF old_file_header^.version = nac$v10_appl_file_version THEN
            FREE converted_server_definition IN osv$task_private_heap^;
          IFEND;
        IFEND;
      IFEND;

      IF application_file_attached THEN
        nap$detach_application_file (local_status);
        IF (status.normal) AND (NOT local_status.normal) THEN
          status := local_status;
        ELSE
          nap$display_message (local_status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND nap$get_server_attributes;
?? TITLE := '[XDCL, #GATE] nap$get_server_status', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$get_server_status
    (    server: nat$application_name;
     VAR server_status: nat$application_status;
     VAR reserved_application_id: boolean;
     VAR application_id: nat$internet_sap_identifier;
     VAR active_job_count: integer;
     VAR display_job_attributes: array [1 .. * ] of nat$display_job_attributes;
     VAR active_connection_count: nat$number_of_connections;
     VAR attempted_connection_count: integer;
     VAR rejected_connection_attempts: integer;
     VAR server_managed_title_count: nat$max_titles;
     VAR server_managed_titles: array [1 .. * ] of string (nac$max_title_pattern_length);
     VAR status: ost$status);


    VAR
      added_title: ^nat$added_title,
      added_title_count: integer,
      i: integer,
      server_attributes: ^nat$server_attributes,
      server_job_attributes: ^nat$server_job_attributes;

    IF NOT nav$namve_active THEN
      osp$set_status_condition ( nae$network_inactive,  status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
    nap$find_server_attributes (server, server_attributes);
    IF server_attributes = NIL THEN
      osp$set_status_abnormal (nac$status_id, nae$unknown_application, server, status);
    ELSE
      nlp$get_nonexclusive_access (server_attributes^.access_control);
      server_status := server_attributes^.server_status;
      active_job_count := 0;
      server_job_attributes := server_attributes^.server_job_list;
      WHILE server_job_attributes <> NIL DO
        active_job_count := active_job_count + 1;
        IF active_job_count <= UPPERBOUND (display_job_attributes) THEN
          display_job_attributes [active_job_count].job_name := server_job_attributes^.job_name;
          display_job_attributes [active_job_count].connection_count :=
                server_job_attributes^.connection_count;
        IFEND;
        server_job_attributes := server_job_attributes^.next_entry;
      WHILEND;
      active_connection_count := server_attributes^.connection_count;
      attempted_connection_count := server_attributes^.attempted_connection_count;
      rejected_connection_attempts := server_attributes^.rejected_connection_attempts;
      added_title_count := 0;
      added_title := server_attributes^.added_titles;
      WHILE added_title <> NIL DO
        added_title_count := added_title_count + 1;
        IF added_title_count <= UPPERBOUND (server_managed_titles) THEN
          server_managed_titles [added_title_count] := added_title^.title;
        IFEND;
        added_title := added_title^.next_title;
      WHILEND;
      server_managed_title_count := added_title_count;
      nlp$release_nonexclusive_access (server_attributes^.access_control);
    IFEND;

    nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
    osp$end_subsystem_activity;
    osp$pop_inhibit_job_recovery;

  PROCEND nap$get_server_status;
?? TITLE := '[XDCL, #GATE] nap$get_tcpip_attributes', EJECT ??
*copyc nah$get_tcpip_attributes
  PROCEDURE [XDCL, #GATE] nap$get_tcpip_attributes
    (    application: nat$application_name;
     VAR tcpip_status: nat$application_status;
     VAR maximum_sockets: nat$number_of_sockets;
     VAR tcpip_capability: ost$name;
     VAR tcpip_ring: ost$ring;
     VAR tcpip_system_privilege: boolean;
     VAR protocol: nat$protocol;
     VAR status: ost$status);

    VAR
      application_file_attached: boolean,
      complete_tcpip_definition: ^nat$complete_tcpip_definition,
      local_status: ost$status,
      tcpip_attributes: ^nat$tcpip_attributes,
      tcpip_definition: ^nat$tcpip_definition;

    status.normal := TRUE;
    IF nav$namve_active THEN
      osp$push_inhibit_job_recovery;
      osp$begin_subsystem_activity;
      nlp$get_nonexclusive_access (nav$tcpip_attributes_list.access_control);
      nap$find_tcpip_attributes (application, tcpip_attributes);
      IF tcpip_attributes = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application,
              application, status);
      ELSE
        nlp$get_nonexclusive_access (tcpip_attributes^.access_control);
        tcpip_status := tcpip_attributes^.tcpip_status;
        maximum_sockets := tcpip_attributes^.maximum_sockets;
        protocol := tcpip_attributes^.protocol;
        tcpip_capability := tcpip_attributes^.tcpip_capability;
        tcpip_ring := tcpip_attributes^.tcpip_ring;
        tcpip_system_privilege := tcpip_attributes^.tcpip_system_privilege;
        nlp$release_nonexclusive_access (tcpip_attributes^.access_control);
      IFEND;
      nlp$release_nonexclusive_access (nav$tcpip_attributes_list.
            access_control);
      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;
    ELSE {NAMVE is not active.
      application_file_attached := FALSE;
      IF NOT highest_cycle_open THEN
        nap$attach_application_file (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        application_file_attached := TRUE;
      IFEND;

      find_tcpip_definition (application, old_application_file,
            complete_tcpip_definition);
      IF complete_tcpip_definition = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application,
              application, status);
      ELSE
        NEXT tcpip_definition IN complete_tcpip_definition;
        IF status.normal THEN
          tcpip_status := tcpip_definition^.tcpip_status;
          maximum_sockets := tcpip_definition^.maximum_sockets;
          protocol := tcpip_definition^.protocol;
          tcpip_capability := tcpip_definition^.tcpip_capability;
          tcpip_ring := tcpip_definition^.tcpip_ring;
          tcpip_system_privilege := tcpip_definition^.tcpip_system_privilege;
        IFEND;
      IFEND;

      IF application_file_attached THEN
        nap$detach_application_file (local_status);
        IF (status.normal) AND (NOT local_status.normal) THEN
          status := local_status;
        ELSE
          nap$display_message (local_status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND nap$get_tcpip_attributes;
?? TITLE := '[XDCL, #GATE] nap$get_tcpip_status', EJECT ??
*copyc nah$get_tcpip_status

  PROCEDURE [XDCL, #GATE] nap$get_tcpip_status
    (    application: nat$application_name;
     VAR tcpip_status: nat$application_status;
     VAR active_socket_count: nat$number_of_sockets;
     VAR socket_attempt_count: integer;
     VAR socket_reject_count: integer;
     VAR status: ost$status);

    VAR
      tcpip_attributes: ^nat$tcpip_attributes;

    IF NOT nav$namve_active THEN
      osp$set_status_condition ( nae$network_inactive, status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    nlp$get_nonexclusive_access (nav$tcpip_attributes_list.access_control);
    nap$find_tcpip_attributes (application, tcpip_attributes);
    IF tcpip_attributes = NIL THEN
      osp$set_status_abnormal (nac$status_id, nae$unknown_application,
            application, status);
    ELSE
      nlp$get_nonexclusive_access (tcpip_attributes^.access_control);
      tcpip_status := tcpip_attributes^.tcpip_status;
      active_socket_count := tcpip_attributes^.active_socket_count;
      socket_attempt_count := tcpip_attributes^.socket_attempt_count;
      socket_reject_count := tcpip_attributes^.socket_reject_count;
      nlp$release_nonexclusive_access (tcpip_attributes^.access_control);
    IFEND;
    nlp$release_nonexclusive_access (nav$tcpip_attributes_list.access_control);
    osp$end_subsystem_activity;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$get_tcpip_status;

?? TITLE := '[XDCL] nap$idle_network_applications', EJECT ??
  PROCEDURE [XDCL] nap$idle_network_applications (
        terminate_inactive_applications: boolean;
    VAR status: ost$status);

{ PURPOSE:
{   The purpose of this procedure is to shut down all defined network applications
{   and release the associated allocated data structures.  This is done to prepare
{   for NAM/VE termination. This procedure is called within the system job.
{
{ METHOD:
{   Active applications are deactivated with all connections being terminated.
{   If terminate_inactive_applications is TRUE (which will be the case on the first
{   call), inactive applications are also re-deactivated in order to terminate any
{   remaining active connections.  When an application is inactive and idle, the
{   table entry defining the application is deleted.  This procedure returns after
{   making one pass through all of the application definition tables.  Normal status
{   is returned when all application definitions have been deleted.

    VAR
      client_attributes: ^nat$client_attributes,
      i: integer,
      ignore_status: ost$status,
      server_attributes: ^nat$server_attributes,
      previous_client_attributes: ^^nat$client_attributes,
      previous_server_attributes: ^^nat$server_attributes,
      previous_tcpip_attributes: ^^nat$tcpip_attributes,
      protocol: nat$protocol,
      tcpip_application: nat$application_name,
      tcpip_attributes: ^nat$tcpip_attributes,
      tcp_socket: ^nat$tcp_socket,
      tcp_socket_list: ^array [1 .. * ] of nat$tcp_socket,
      udp_socket: ^nat$udp_socket,
      udp_socket_list: ^array [1 .. * ] of nat$udp_socket,
      wait_for_connection: ^nat$wait_for_connection;

    status.normal := TRUE;
    nlp$get_exclusive_access (nav$server_attributes_list.access_control);
    server_attributes := nav$server_attributes_list.server_attributes;
    previous_server_attributes := ^nav$server_attributes_list.server_attributes;

    WHILE (server_attributes <> NIL) DO
      IF terminate_inactive_applications OR (server_attributes^.server_status <> nac$application_inactive)
            THEN
        deactivate_server (server_attributes, {terminate_active_connections = } TRUE);
        server_attributes^.server_status := nac$application_inactive;
      IFEND;

{ Ready the server tasks waiting for a connection.

      wait_for_connection := server_attributes^.wait_for_connection;
      WHILE wait_for_connection <> NIL DO
        pmp$ready_task (wait_for_connection^.task_id, ignore_status);
        wait_for_connection := wait_for_connection^.next_entry;
      WHILEND;

      IF (server_attributes^.connection_count = 0) AND (server_attributes^.server_job_list = NIL) AND
            (server_attributes^.wait_for_connection = NIL) THEN
        previous_server_attributes^ := server_attributes^.next_entry;
        free_server_attributes_entry (server_attributes);
      ELSE
        previous_server_attributes := ^server_attributes^.next_entry;
      IFEND;

      server_attributes := previous_server_attributes^;
    WHILEND;
    nlp$release_exclusive_access (nav$server_attributes_list.access_control);

    nlp$get_exclusive_access (nav$client_attributes_list.access_control);
    client_attributes := nav$client_attributes_list.client_attributes;
    previous_client_attributes := ^nav$client_attributes_list.client_attributes;

    WHILE (client_attributes <> NIL) DO
      IF terminate_inactive_applications OR (client_attributes^.client_status <> nac$application_inactive)
            THEN
        deactivate_client (client_attributes, {terminate_active_connections = } TRUE);
        client_attributes^.client_status := nac$application_inactive;
      IFEND;

      IF (client_attributes^.connection_count = 0) THEN
        previous_client_attributes^ := client_attributes^.next_entry;
        FREE client_attributes IN nav$network_paged_heap^;
      ELSE
        previous_client_attributes := ^client_attributes^.next_entry;
      IFEND;

      client_attributes := previous_client_attributes^;
    WHILEND;
    nlp$release_exclusive_access (nav$client_attributes_list.access_control);

    nlp$get_exclusive_access (nav$tcpip_attributes_list.access_control);
    tcpip_attributes := nav$tcpip_attributes_list.tcpip_attributes;
    previous_tcpip_attributes := ^nav$tcpip_attributes_list.tcpip_attributes;

    WHILE (tcpip_attributes <> NIL) DO
      IF terminate_inactive_applications OR (tcpip_attributes^.tcpip_status <> nac$application_inactive) THEN
        tcp_socket_list := NIL;
        udp_socket_list := NIL;
        tcpip_application := tcpip_attributes^.tcpip_application;
        protocol := tcpip_attributes^.protocol;
        IF (tcpip_attributes^.protocol = nac$stream_socket) AND
          (tcpip_attributes^.active_socket_count > 0) THEN
          PUSH tcp_socket_list: [1 .. tcpip_attributes^.active_socket_count];
          i := 1;
          tcp_socket := tcpip_attributes^.tcp_socket_list;
          WHILE tcp_socket <> NIL DO
            tcp_socket_list^ [i] := tcp_socket^;
            i := i + 1;
            tcp_socket := tcp_socket^.next_entry;
          WHILEND;
        ELSEIF (tcpip_attributes^.protocol = nac$datagram_socket) AND
          (tcpip_attributes^.active_socket_count <> 0) THEN
          PUSH udp_socket_list: [1 .. tcpip_attributes^.active_socket_count];
          i := 1;
          udp_socket := tcpip_attributes^.udp_socket_list;
          WHILE udp_socket <> NIL DO
            udp_socket_list^ [i] := udp_socket^;
            i := i + 1;
            udp_socket := udp_socket^.next_entry;
          WHILEND;
        IFEND;
        tcpip_attributes^.tcpip_status := nac$application_inactive;
        nlp$release_exclusive_access (nav$tcpip_attributes_list.access_control);
        deactivate_tcpip (tcpip_application, protocol, {terminate_active_connections = } TRUE,
              tcp_socket_list, udp_socket_list);
        nlp$get_exclusive_access (nav$tcpip_attributes_list.access_control);
        previous_tcpip_attributes := ^nav$tcpip_attributes_list.tcpip_attributes;
        WHILE (previous_tcpip_attributes^ <> NIL) AND (previous_tcpip_attributes^ <> tcpip_attributes) DO
          previous_tcpip_attributes := ^previous_tcpip_attributes^^.next_entry;
        WHILEND;
        IF previous_tcpip_attributes^ <> NIL THEN
          previous_tcpip_attributes := ^previous_tcpip_attributes^^.next_entry;
        IFEND;
      ELSEIF (tcpip_attributes^.active_socket_count = 0) THEN
        previous_tcpip_attributes^ := tcpip_attributes^.next_entry;
        FREE tcpip_attributes IN nav$network_paged_heap^;
      ELSE
        previous_tcpip_attributes := ^tcpip_attributes^.next_entry;
      IFEND;

      tcpip_attributes := previous_tcpip_attributes^;
    WHILEND;
    nlp$release_exclusive_access (nav$tcpip_attributes_list.access_control);

    IF (nav$server_attributes_list.server_attributes <> NIL) OR
          (nav$client_attributes_list.client_attributes <> NIL) OR
          (nav$tcpip_attributes_list.tcpip_attributes <> NIL) THEN
      osp$set_status_condition (nae$network_applications_active, status);
    ELSE
      nav$applications_installed := FALSE;
    IFEND;

  PROCEND nap$idle_network_applications;
?? TITLE := '[XDCL] nap$initialize_application_defn', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to setup the nam application definitions in
{   the network paged segment. The application file is attached for exclusive
{   access and the definitions are copied into the network paged segment. This
{   procedure is called within the system job.

  PROCEDURE [XDCL] nap$initialize_application_defn
    (VAR status: ost$status);

    VAR
      file_header: ^nat$application_file_header,
      client_attributes: ^nat$client_attributes,
      client_definition: ^nat$client_definition,
      client_pointers: ^nat$client_pointers,
      complete_client_definition: ^nat$complete_client_definition,
      complete_server_definition: ^nat$complete_server_definition,
      complete_tcpip_definition: ^nat$complete_tcpip_definition,
      converted_client_definition: ^nat$complete_client_definition,
      converted_server_definition: ^nat$complete_server_definition,
      i: integer,
      local_status: ost$status,
      old_client_attributes: ^nat$client_attributes,
      old_server_attributes: ^nat$server_attributes,
      old_tcpip_attributes: ^nat$tcpip_attributes,
      previous_client_attributes: ^^nat$client_attributes,
      previous_server_attributes: ^^nat$server_attributes,
      previous_tcpip_attributes: ^^nat$tcpip_attributes,
      processor_element_id: ost$processor_element_id,
      server_attributes: ^nat$server_attributes,
      server_definition: ^nat$server_definition,
      server_pointers: ^nat$server_pointers,
      tcpip_attributes: ^nat$tcpip_attributes,
      tcpip_definition: ^nat$tcpip_definition,
      tcpip_pointers: ^nat$tcpip_pointers,
      v10_v11_file_header: ^nat$v10_v11_file_header;

    status.normal := TRUE;
    nap$attach_application_file (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET old_application_file;
    NEXT file_header IN old_application_file;
    IF file_header^.version <> nac$application_file_version THEN
      RESET old_application_file;
      NEXT v10_v11_file_header IN old_application_file;
    IFEND;
    IF file_header^.server_count > 0 THEN
      NEXT server_pointers: [1 .. file_header^.server_count] IN old_application_file;
    IFEND;
    IF file_header^.client_count > 0 THEN
      NEXT client_pointers: [1 .. file_header^.client_count] IN old_application_file;
    IFEND;
    IF file_header^.version = nac$application_file_version THEN
      IF file_header^.tcpip_count > 0 THEN
        NEXT tcpip_pointers: [1 .. file_header^.tcpip_count] IN old_application_file;
      IFEND;
    IFEND;

    IF file_header^.server_count > 0 THEN
      nlp$get_exclusive_access (nav$server_attributes_list.access_control);
      previous_server_attributes := ^nav$server_attributes_list.server_attributes;

      FOR i := 1 TO file_header^.server_count DO
        complete_server_definition := #PTR (server_pointers^ [i].pointer, old_application_file^);
        IF (file_header^.version = nac$application_file_version) OR
              (file_header^.version = nac$v11_appl_file_version) THEN
          define_server_attributes_entry (complete_server_definition, server_attributes);
        ELSEIF file_header^.version = nac$v10_appl_file_version THEN
          convert_v10_server_to_v11 (complete_server_definition, converted_server_definition);
          define_server_attributes_entry (converted_server_definition, server_attributes);
          FREE converted_server_definition IN osv$task_private_heap^;
        IFEND;
        nap$find_server_attributes (server_attributes^.server, old_server_attributes);
        IF old_server_attributes = NIL THEN

{ Determine max connections for timesharing server.

        IF server_attributes^.server = osc$timesharing THEN
          pmp$get_binary_processor_id (processor_element_id, {ignore}local_status);
          CASE processor_element_id.model_number OF
          = osc$cyber_180_model_930a, osc$cyber_180_model_932a =
            IF server_attributes^.max_connections > max_connections_930_limit1 THEN
              server_attributes^.max_connections := max_connections_930_limit1;
              osp$set_status_abnormal (nac$status_id, nae$limit_max_connections, server_attributes^.
                server, local_status);
              osp$append_status_integer (osc$status_parameter_delimiter, max_connections_930_limit1,
                10, FALSE, local_status);
              nap$display_message (local_status);
            IFEND;

          = osc$cyber_180_model_930b, osc$cyber_180_model_930c, osc$cyber_180_model_932b =
            IF server_attributes^.max_connections > max_connections_930_limit2 THEN
              server_attributes^.max_connections := max_connections_930_limit2;
              osp$set_status_abnormal (nac$status_id, nae$limit_max_connections, server_attributes^.
                server, local_status);
              osp$append_status_integer (osc$status_parameter_delimiter, max_connections_930_limit2,
                10, FALSE, local_status);
              nap$display_message (local_status);
            IFEND;

          ELSE
          CASEND;
        IFEND;
        previous_server_attributes^ := server_attributes;
        previous_server_attributes := ^server_attributes^.next_entry;
        ELSE
          old_server_attributes^.server_status := server_attributes^.server_status;
          free_server_attributes_entry (server_attributes);
          server_attributes := old_server_attributes;
        IFEND;
        IF (server_attributes^.nam_initiated_server) AND (server_attributes^.server_status =
              nac$application_active) THEN
          activate_server (server_attributes, local_status);
          IF NOT local_status.normal THEN
            server_attributes^.server_status := nac$application_inactive;
            nap$display_message (local_status);
            osp$set_status_abnormal (nac$status_id, nae$unable_to_activate_appl, server_attributes^.server,
                  local_status);
            nap$display_message (local_status);
          IFEND;
        IFEND;

      FOREND;

      nlp$release_exclusive_access (nav$server_attributes_list.access_control);
    IFEND;

    IF file_header^.client_count > 0 THEN
      nlp$get_exclusive_access (nav$client_attributes_list.access_control);
      previous_client_attributes := ^nav$client_attributes_list.client_attributes;

      FOR i := 1 TO file_header^.client_count DO
        complete_client_definition := #PTR (client_pointers^ [i].pointer, old_application_file^);
        IF (file_header^.version = nac$application_file_version) OR
              (file_header^.version = nac$v11_appl_file_version) THEN
          RESET complete_client_definition;
          NEXT client_definition IN complete_client_definition;
          define_client_attributes_entry (client_definition, client_attributes);
        ELSEIF file_header^.version = nac$v10_appl_file_version THEN
          convert_v10_client_to_v11 (complete_client_definition, converted_client_definition);
          RESET converted_client_definition;
          NEXT client_definition IN converted_client_definition;
          define_client_attributes_entry (client_definition, client_attributes);
          FREE converted_client_definition IN osv$task_private_heap^;
        IFEND;
        nap$find_client_attributes (client_attributes^.client, old_client_attributes);
        IF old_client_attributes = NIL THEN
          previous_client_attributes^ := client_attributes;
          previous_client_attributes := ^client_attributes^.next_entry;
        ELSE
          old_client_attributes^.client_status := client_attributes^.client_status;
          FREE client_attributes IN nav$network_paged_heap^;
          client_attributes := old_client_attributes;
        IFEND;
        IF client_attributes^.client_status = nac$application_active THEN
          activate_client (client_attributes, local_status);
          IF NOT local_status.normal THEN
            client_attributes^.client_status := nac$application_inactive;
            nap$display_message (local_status);
            osp$set_status_abnormal (nac$status_id, nae$unable_to_activate_appl, client_attributes^.client,
                  local_status);
            nap$display_message (local_status);
          IFEND;
        IFEND;
      FOREND;
      nlp$release_exclusive_access (nav$client_attributes_list.access_control);
    IFEND;

    IF file_header^.version = nac$application_file_version THEN
      IF file_header^.tcpip_count > 0 THEN
        nlp$get_exclusive_access (nav$tcpip_attributes_list.access_control);
        previous_tcpip_attributes := ^nav$tcpip_attributes_list.tcpip_attributes;

        FOR i := 1 TO file_header^.tcpip_count DO
          complete_tcpip_definition := #PTR (tcpip_pointers^ [i].pointer, old_application_file^);
          RESET complete_tcpip_definition;
          NEXT tcpip_definition IN complete_tcpip_definition;
          define_tcpip_attributes_entry (tcpip_definition, tcpip_attributes);
          nap$find_tcpip_attributes (tcpip_attributes^.tcpip_application, old_tcpip_attributes);
          IF old_tcpip_attributes = NIL THEN
            previous_tcpip_attributes^ := tcpip_attributes;
            previous_tcpip_attributes := ^tcpip_attributes^.next_entry;
          ELSE
            old_tcpip_attributes^.tcpip_status := tcpip_attributes^.tcpip_status;
            FREE tcpip_attributes IN nav$network_paged_heap^;
          IFEND;
        FOREND;
        nlp$release_exclusive_access (nav$tcpip_attributes_list.access_control);
      IFEND;
    IFEND;
    nav$applications_installed := TRUE;
    nav$appl_defn_time_stamp := file_header^.modification_date_time;
    nap$detach_application_file (status);

  PROCEND nap$initialize_application_defn;
?? TITLE := '[XDCL, #GATE] nap$open_server_job_file', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to attach and open the job definition
{   file for the given server for read access.

  PROCEDURE [XDCL, #GATE] nap$open_server_job_file (server: nat$application_name;
    VAR server_file_identifier: amt$file_identifier;
    VAR status: ost$status);

?? NEWTITLE := '    handle_block_exit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deal with block exit conditions that
{   arise while system_authority is in effect.

    PROCEDURE handle_block_exit
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pfp$end_system_authority;
      osp$set_status_from_condition (nac$status_id, condition, sfsa_p, status, ignore_status);
    PROCEND handle_block_exit;

?? OLDTITLE, EJECT ??


    VAR
      file_name: clt$file,
      job_file_path: array [1..6] of pft$name,
      job_file_path_string: fst$path,
      path_size: fst$path_size;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF status.normal THEN
      job_file_path := application_job_file_path;
      job_file_path [UPPERBOUND (job_file_path)] := server;
      pfp$convert_pft$path_to_fs_path (job_file_path, job_file_path_string, path_size);
      clp$convert_string_to_file (job_file_path_string (1, path_size), file_name, status);
      IF status.normal THEN
        osp$establish_block_exit_hndlr (^handle_block_exit);
        pfp$begin_system_authority;
        fsp$open_file (file_name.local_file_name, amc$record, ^job_file_access_selections,
              {default_creation_attributes=} NIL, {mandated_creation_attributes=} NIL,
              {attribute_validation=} NIL, {attributes_override=} NIL,
              server_file_identifier, status);
        pfp$end_system_authority;
        osp$disestablish_cond_handler;
      IFEND;
    IFEND;
  PROCEND nap$open_server_job_file;
?? TITLE := '[XDCL] nap$process_job_termination', EJECT ??

{  PURPOSE:
{    The purpose of this procedure is to detach the currently executing job from
{    all known applications.
{    In addition, nap$gt_process_job_termination is called to close all saps
{    opened within the terminating job.

  PROCEDURE [XDCL] nap$process_job_termination;

    VAR
      executing_job_name: jmt$system_supplied_name,
      ignore_status: ost$status,
      previous_server_job_attributes: ^^nat$server_job_attributes,
      previous_wait_for_connection: ^^nat$wait_for_connection,
      server_attributes: ^nat$server_attributes,
      server_job_attributes: ^nat$server_job_attributes,
      status: ost$status,
      wait_for_connection: ^nat$wait_for_connection,
      user_supplied_name: jmt$user_supplied_name;


    #KEYPOINT (osk$entry, osk$m * amk_process_job_termination, nak$application_management);
    pmp$get_job_names (user_supplied_name, executing_job_name, ignore_status);
    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
    server_attributes := nav$server_attributes_list.server_attributes;

    WHILE server_attributes <> NIL DO
      nlp$get_exclusive_access (server_attributes^.access_control);

{ Remove the task from the wait for connection queue.

      IF server_attributes^.wait_for_connection <> NIL THEN
        previous_wait_for_connection := ^server_attributes^.wait_for_connection;
        wait_for_connection := server_attributes^.wait_for_connection;
        WHILE (wait_for_connection <> NIL) AND (wait_for_connection^.job_name <> executing_job_name) DO
          previous_wait_for_connection := ^wait_for_connection^.next_entry;
          wait_for_connection := wait_for_connection^.next_entry;
        WHILEND;
        IF wait_for_connection <> NIL THEN
          previous_wait_for_connection^ := wait_for_connection^.next_entry;
          FREE wait_for_connection IN nav$network_paged_heap^;
{ *** DEBUG pmp$log ('AM - Task removed from wait for conn q.', ignore_status);
        IFEND;
      IFEND;

{ Detach the job from the server.
      server_job_attributes := server_attributes^.server_job_list;
      previous_server_job_attributes := ^server_attributes^.server_job_list;

      WHILE (server_job_attributes <> NIL) AND (server_job_attributes^.job_name <> executing_job_name) DO
        previous_server_job_attributes := ^server_job_attributes^.next_entry;
        server_job_attributes := server_job_attributes^.next_entry;
      WHILEND;

      IF server_job_attributes <> NIL THEN
        IF server_job_attributes^.connection_count > 0 THEN
          nap$namve_system_error (TRUE, 'Job terminating with active server connections.', NIL);
        IFEND;

        previous_server_job_attributes^ := server_job_attributes^.next_entry;
        FREE server_job_attributes IN nav$network_paged_heap^;
        IF (NOT server_attributes^.nam_initiated_server) AND (server_attributes^.server_job_list = NIL) AND
              (server_attributes^.protocol_activated) THEN
          deactivate_server (server_attributes, FALSE);
        IFEND;
      IFEND;

      nlp$release_exclusive_access (server_attributes^.access_control);
      server_attributes := server_attributes^.next_entry;
    WHILEND;

    nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);

    osp$end_subsystem_activity;
    osp$pop_inhibit_job_recovery;
    nap$gt_process_job_termination;
    nap$sk_process_job_termination;
    #KEYPOINT (osk$exit, osk$m * amk_process_job_termination, nak$application_management);

  PROCEND nap$process_job_termination;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$set_server_job_init_pending', EJECT ??

  PROCEDURE [XDCL] nap$set_server_job_init_pending
    (    server: nat$application_name;
         server_job_init_pending: boolean;
     VAR status: ost$status);

    VAR
      server_attributes: ^nat$server_attributes;


    status.normal := TRUE;

    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
    nap$find_server_attributes (server, server_attributes);
    IF server_attributes = NIL THEN
      osp$set_status_abnormal (nac$status_id, nae$unknown_application, server, status);
    ELSE
      nlp$get_exclusive_access (server_attributes^.access_control);
      nap$validate_user (server_attributes^.server_capability, server_attributes^.server_ring,
            server_attributes^.server_system_privilege, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_application, server, status);
      ELSEIF server_attributes^.server_status = nac$application_inactive THEN
        osp$set_status_abnormal (nac$status_id, nae$application_inactive, server, status);
      ELSE
        server_attributes^.server_job_init_pending := server_job_init_pending;
      IFEND;
      nlp$release_exclusive_access (server_attributes^.access_control);
    IFEND;

    nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
    osp$end_subsystem_activity;
    osp$pop_inhibit_job_recovery;

  PROCEND nap$set_server_job_init_pending;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$verify_application_id', EJECT ??

{ PURPOSE:
{   The purpose of this request is to verify that the given sap_id is unique
{   across all the reserved application identifiers selected for all the
{   defined servers and clients.

  PROCEDURE [XDCL, #GATE] nap$verify_application_id
    (    application_id: nat$internet_sap_identifier;
     VAR status: ost$status);

    VAR
      application_file_attached: boolean,
      client: nat$application_name,
      client_attributes: ^nat$client_attributes,
      client_definition: ^nat$client_definition,
      client_pointers: ^nat$client_pointers,
      complete_client_definition: ^nat$complete_client_definition,
      complete_server_definition: ^nat$complete_server_definition,
      i: integer,
      ignore_status: ost$status,
      local_status: ost$status,
      old_file_header: ^nat$application_file_header,
      server: nat$application_name,
      server_attributes: ^nat$server_attributes,
      server_definition: ^nat$server_definition,
      server_pointers: ^nat$server_pointers,
      v10_client_definition: ^nat$v10_client_definition,
      v10_server_definition: ^nat$v10_server_definition,
      v10_v11_file_header: ^nat$v10_v11_file_header;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF nav$namve_active THEN

{ Scan the client attributes list.

      osp$push_inhibit_job_recovery;
      osp$begin_subsystem_activity;
      nlp$get_nonexclusive_access (nav$client_attributes_list.access_control);
      client_attributes := nav$client_attributes_list.client_attributes;

    /scan_defined_clients/
      WHILE client_attributes <> NIL DO
        IF (client_attributes^.reserved_application_id) AND
              (client_attributes^.application_id.xns_sap_identifier = application_id) THEN
          osp$set_status_condition ( nae$conflicting_reserved_sap, status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                application_id, 10, TRUE, status);
          EXIT /scan_defined_clients/;
        IFEND;

        client_attributes := client_attributes^.next_entry;
      WHILEND /scan_defined_clients/;

      nlp$release_nonexclusive_access (nav$client_attributes_list.
            access_control);

{ Scan server attributes list.

      IF status.normal THEN
        nlp$get_nonexclusive_access (nav$server_attributes_list.
              access_control);
        server_attributes := nav$server_attributes_list.server_attributes;

      /scan_defined_servers/
        WHILE server_attributes <> NIL DO
          IF (server_attributes^.reserved_application_id) AND
                (server_attributes^.application_id.xns_sap_identifier = application_id) THEN
            osp$set_status_condition (nae$conflicting_reserved_sap,  status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  application_id, 10, TRUE, status);
            EXIT /scan_defined_servers/;
          IFEND;

          server_attributes := server_attributes^.next_entry;
        WHILEND /scan_defined_servers/;

        nlp$release_nonexclusive_access (nav$server_attributes_list.
              access_control);
      IFEND;
      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;

    ELSE

{ NAMVE is not active.

      application_file_attached := FALSE;
      IF NOT highest_cycle_open THEN
        nap$attach_application_file (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        application_file_attached := TRUE;
      IFEND;

      RESET old_application_file;
      NEXT old_file_header IN old_application_file;

      IF old_file_header^.version <> nac$application_file_version THEN
        RESET old_application_file;
        NEXT v10_v11_file_header IN old_application_file;
      IFEND;

{ Search the server definitions for a matching application identifier.

      IF old_file_header^.server_count > 0 THEN
        NEXT server_pointers: [1 .. old_file_header^.server_count] IN
              old_application_file;

      /search_servers/
        FOR i := 1 TO old_file_header^.server_count DO
          server := server_pointers^ [i].server;
          find_server_definition (server, old_application_file,
                complete_server_definition);
          IF complete_server_definition = NIL THEN
            osp$set_status_abnormal (nac$status_id, nae$application_file_error,
                  verify_application_id, status);
            EXIT /search_servers/;
          IFEND;
          IF (old_file_header^.version = nac$application_file_version) OR
                (old_file_header^.version = nac$v11_appl_file_version) THEN
            NEXT server_definition IN complete_server_definition;
            IF (server_definition^.reserved_application_id) AND
                  (server_definition^.application_id = application_id) THEN
              osp$set_status_condition ( nae$conflicting_reserved_sap,  status);
              osp$append_status_integer (osc$status_parameter_delimiter, application_id,
                      10, TRUE, status);
              EXIT /search_servers/;
            IFEND;
          ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
            NEXT v10_server_definition IN complete_server_definition;
            IF (v10_server_definition^.reserved_application_id) AND
                  (v10_server_definition^.application_id = application_id) THEN
              osp$set_status_condition ( nae$conflicting_reserved_sap,  status);
              osp$append_status_integer (osc$status_parameter_delimiter, application_id,
                       10, TRUE, status);
              EXIT /search_servers/;
            IFEND;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$incorrect_appl_file_version, old_file_header^.version,
                  status);
            EXIT /search_servers/;
          IFEND;
        FOREND /search_servers/;
      IFEND;

      IF status.normal THEN

{ Search the client definitions for a matching application identifier.

        IF old_file_header^.client_count > 0 THEN
          NEXT client_pointers: [1 .. old_file_header^.client_count] IN
                old_application_file;

        /search_clients/
          FOR i := 1 TO old_file_header^.client_count DO
            client := client_pointers^ [i].client;
            find_client_definition (client, old_application_file,
                  complete_client_definition);
            IF complete_client_definition = NIL THEN
              osp$set_status_abnormal (nac$status_id, nae$application_file_error,
                    verify_application_id, status);
              EXIT /search_clients/;
            IFEND;
            IF (old_file_header^.version = nac$application_file_version) OR
                  (old_file_header^.version = nac$v11_appl_file_version) THEN
              NEXT client_definition IN complete_client_definition;
              IF (client_definition^.reserved_application_id) AND
                    (client_definition^.application_id = application_id) THEN
                osp$set_status_condition ( nae$conflicting_reserved_sap,  status);
                osp$append_status_integer (osc$status_parameter_delimiter, application_id,
                       10, TRUE, status);
                EXIT /search_clients/;
              IFEND;
            ELSEIF old_file_header^.version = nac$v10_appl_file_version THEN
              NEXT v10_client_definition IN complete_client_definition;
              IF (v10_client_definition^.reserved_application_id) AND
                    (v10_client_definition^.application_id = application_id) THEN
                osp$set_status_condition ( nae$conflicting_reserved_sap,  status);
                osp$append_status_integer (osc$status_parameter_delimiter, application_id,
                          10, TRUE, status);
                EXIT /search_clients/;
              IFEND;
            ELSE
              osp$set_status_abnormal (nac$status_id, nae$incorrect_appl_file_version,
                    old_file_header^.version, status);
              EXIT /search_clients/;
            IFEND;
          FOREND /search_clients/;
        IFEND;
      IFEND;

      IF application_file_attached THEN
        nap$detach_application_file (local_status);
        IF (status.normal) AND (NOT local_status.normal) THEN
          status := local_status;
        ELSE
          nap$display_message (local_status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND nap$verify_application_id;
?? TITLE := '[XDCL, #GATE] nap$verify_application_name', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to verify that the given application name
{   is unqiue accross all defined server and client applications.

  PROCEDURE [XDCL, #GATE] nap$verify_application_name
    (    application: nat$application_name;
     VAR status: ost$status);

    VAR
      application_file_attached: boolean,
      client_attributes: ^nat$client_attributes,
      client_definition: ^nat$complete_client_definition,
      ignore_status: ost$status,
      local_status: ost$status,
      old_file_header: ^nat$application_file_header,
      server_definition: ^nat$complete_server_definition,
      server_attributes: ^nat$server_attributes;

    status.normal := TRUE;
    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF nav$namve_active THEN
      osp$push_inhibit_job_recovery;
      osp$begin_subsystem_activity;
      nlp$get_nonexclusive_access (nav$client_attributes_list.access_control);

{ Search for a matching client application name.

      nap$find_client_attributes (application, client_attributes);
      IF client_attributes <> NIL THEN
        osp$set_status_abnormal (nac$status_id,
              nae$application_already_defined, client, status);
      IFEND;
      nlp$release_nonexclusive_access (nav$client_attributes_list.
            access_control);

      IF status.normal THEN
        nlp$get_nonexclusive_access (nav$server_attributes_list.
              access_control);

{ Search for a matching server application name.

        nap$find_server_attributes (application, server_attributes);
        IF server_attributes <> NIL THEN
          osp$set_status_abnormal (nac$status_id,
                nae$application_already_defined, server, status);
        IFEND;
        nlp$release_nonexclusive_access (nav$server_attributes_list.
              access_control);
      IFEND;
      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;
    ELSE

{ NAMVE is not active.

      application_file_attached := FALSE;
      IF NOT highest_cycle_open THEN
        nap$attach_application_file (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        application_file_attached := TRUE;
      IFEND;

      RESET old_application_file;
      NEXT old_file_header IN old_application_file;

{ Search for a matching client application name.

      find_client_definition (application, old_application_file,
            client_definition);
      IF client_definition <> NIL THEN
        osp$set_status_abnormal (nac$status_id,
              nae$application_already_defined, client, status);
      IFEND;
      IF status.normal THEN

{ Search for a matching server application name.

        find_server_definition (application, old_application_file,
              server_definition);
        IF server_definition <> NIL THEN
          osp$set_status_abnormal (nac$status_id,
                nae$application_already_defined, server, status);
        IFEND;
      IFEND;

      IF application_file_attached THEN
        nap$detach_application_file (local_status);
        IF (status.normal) AND (NOT local_status.normal) THEN
          status := local_status;
        ELSE
          nap$display_message (local_status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND nap$verify_application_name;
?? TITLE := '[XDCL, #GATE] nap$verify_tcpip_name', EJECT ??
*copyc nah$verify_tcpip_name

  PROCEDURE [XDCL, #GATE] nap$verify_tcpip_name
    (    application: nat$application_name;
     VAR status: ost$status);

    VAR
      application_file_attached: boolean,
      local_status: ost$status,
      tcpip_attributes: ^nat$tcpip_attributes,
      tcpip_definition: ^nat$complete_tcpip_definition;

    status.normal := TRUE;

    verify_appl_mgmt_capability (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF nav$namve_active THEN
      osp$push_inhibit_job_recovery;
      osp$begin_subsystem_activity;
      nlp$get_nonexclusive_access (nav$tcpip_attributes_list.access_control);

{ Search for a matching tcpip application name.

      nap$find_tcpip_attributes (application, tcpip_attributes);
      IF tcpip_attributes <> NIL THEN
        osp$set_status_abnormal (nac$status_id,
              nae$application_already_defined, tcpip, status);
      IFEND;
      nlp$release_nonexclusive_access (nav$tcpip_attributes_list.
            access_control);
      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;
    ELSE

{ NAMVE is not active.

      application_file_attached := FALSE;
      IF NOT highest_cycle_open THEN
        nap$attach_application_file (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        application_file_attached := TRUE;
      IFEND;

{ Search for a matching tcpip application name.

      find_tcpip_definition (application, old_application_file,
            tcpip_definition);
      IF tcpip_definition <> NIL THEN
        osp$set_status_abnormal (nac$status_id,
              nae$application_already_defined, tcpip, status);
      IFEND;
      IF application_file_attached THEN
        nap$detach_application_file (local_status);
        IF (status.normal) AND (NOT local_status.normal) THEN
          status := local_status;
        ELSE
          nap$display_message (local_status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND nap$verify_tcpip_name;
?? TITLE := '[XDCL] nlp$tcpip_decrement_appl_access', EJECT ??
*copyc nlh$tcpip_decrement_appl_access

  PROCEDURE [XDCL] nlp$tcpip_decrement_appl_access
    (    application: nat$application_name;
         global_socket_id: nlt$udp_global_socket_id;
         connection_id: nat$connection_id;
     VAR status: ost$status);

    VAR
      connection_id_in_list: boolean,
      global_socket_id_in_list: boolean,
      previous_tcp_socket_list: ^^nat$tcp_socket,
      previous_udp_socket_list: ^^nat$udp_socket,
      tcp_socket_list: ^nat$tcp_socket,
      tcpip_attributes: ^nat$tcpip_attributes,
      udp_socket_list: ^nat$udp_socket;

    status.normal := TRUE;
    nlp$get_nonexclusive_access (nav$tcpip_attributes_list.access_control);
    nap$find_tcpip_attributes (application, tcpip_attributes);
    IF tcpip_attributes <> NIL THEN
      nlp$get_exclusive_access (tcpip_attributes^.access_control);
      IF tcpip_attributes^.protocol = nac$stream_socket THEN
        connection_id_in_list := FALSE;
        previous_tcp_socket_list := ^tcpip_attributes^.tcp_socket_list;
        tcp_socket_list := tcpip_attributes^.tcp_socket_list;

      /search_tcp/
        WHILE tcp_socket_list <> NIL DO
          IF tcp_socket_list^.connection_id = connection_id THEN
            previous_tcp_socket_list^ := tcp_socket_list^.next_entry;
            FREE tcp_socket_list IN nav$network_paged_heap^;
            connection_id_in_list := TRUE;
            EXIT /search_tcp/;
          IFEND;
          previous_tcp_socket_list := ^tcp_socket_list^.next_entry;
          tcp_socket_list := tcp_socket_list^.next_entry;
        WHILEND /search_tcp/;
        IF connection_id_in_list THEN
          tcpip_attributes^.active_socket_count :=
                tcpip_attributes^.active_socket_count - 1;
        ELSE { socket not on list

{ Ignore socket may have been terminated via application management.

        IFEND;
      ELSEIF tcpip_attributes^.protocol = nac$datagram_socket THEN
        global_socket_id_in_list := FALSE;
        previous_udp_socket_list := ^tcpip_attributes^.udp_socket_list;
        udp_socket_list := tcpip_attributes^.udp_socket_list;

      /search_udp/
        WHILE udp_socket_list <> NIL DO
          IF udp_socket_list^.global_socket_id = global_socket_id THEN
            previous_udp_socket_list^ := udp_socket_list^.next_entry;
            FREE udp_socket_list IN nav$network_paged_heap^;
            global_socket_id_in_list := TRUE;
            EXIT /search_udp/;
          IFEND;
          previous_udp_socket_list := ^udp_socket_list^.next_entry;
          udp_socket_list := udp_socket_list^.next_entry;
        WHILEND /search_udp/;
        IF global_socket_id_in_list THEN
          tcpip_attributes^.active_socket_count :=
                tcpip_attributes^.active_socket_count - 1;
        ELSE { socket not on list

{ Ignore socket may have been terminated via application management.

        IFEND;
      IFEND;
      nlp$release_exclusive_access (tcpip_attributes^.access_control);
    ELSE {unknown_application.
      osp$set_status_abnormal (nac$status_id, nae$unknown_application,
            application, status);
    IFEND;
    nlp$release_nonexclusive_access (nav$tcpip_attributes_list.access_control);
  PROCEND nlp$tcpip_decrement_appl_access;
?? TITLE := '[XDCL] nlp$tcpip_increment_appl_access', EJECT ??
*copyc nlh$tcpip_increment_appl_access

  PROCEDURE [XDCL] nlp$tcpip_increment_appl_access
    (    application: nat$application_name;
         socket_assigned: boolean;
         global_socket_id: nlt$udp_global_socket_id;
         connection_id: nat$connection_id;
     VAR status: ost$status);

    VAR
      tcpip_attributes: ^nat$tcpip_attributes;

    status.normal := TRUE;
    nlp$get_nonexclusive_access (nav$tcpip_attributes_list.access_control);
    nap$find_tcpip_attributes (application, tcpip_attributes);
    IF tcpip_attributes <> NIL THEN
      nlp$get_exclusive_access (tcpip_attributes^.access_control);
      IF tcpip_attributes^.tcpip_status = nac$application_active THEN
        tcpip_attributes^.socket_attempt_count :=
              tcpip_attributes^.socket_attempt_count + 1;
        IF tcpip_attributes^.active_socket_count <
              tcpip_attributes^.maximum_sockets THEN
          IF tcpip_attributes^.protocol = nac$stream_socket THEN
            nap$add_tcp_socket_list (socket_assigned, connection_id,
                  tcpip_attributes);
          ELSE {    datagram socket
            nap$add_udp_socket_list (global_socket_id, tcpip_attributes);
          IFEND;
          tcpip_attributes^.active_socket_count :=
                tcpip_attributes^.active_socket_count + 1;
        ELSE {maximum sockets exceeded
          osp$set_status_abnormal (nac$status_id, nae$maximum_sockets_exceeded,
                application, status);
          tcpip_attributes^.socket_reject_count :=
                tcpip_attributes^.socket_reject_count + 1;
        IFEND;
      ELSE {    reject application inactive.
        osp$set_status_abnormal (nac$status_id, nae$application_inactive,
              application, status);
      IFEND;
      nlp$release_exclusive_access (tcpip_attributes^.access_control);
    ELSE {unknown_application.
      osp$set_status_abnormal (nac$status_id, nae$unknown_application,
            application, status);
    IFEND;
    nlp$release_nonexclusive_access (nav$tcpip_attributes_list.access_control);
  PROCEND nlp$tcpip_increment_appl_access;
?? TITLE := '[XDCL] nlp$tcpip_set_socket_assigned', EJECT ??
*copyc nlh$tcpip_set_socket_assigned

  PROCEDURE [XDCL] nlp$tcpip_set_socket_assigned
    (    application: nat$application_name;
         connection_id: nat$connection_id;
     VAR status: ost$status);

    VAR
      tcp_socket_list: ^nat$tcp_socket,
      tcpip_attributes: ^nat$tcpip_attributes;

    status.normal := TRUE;
    nlp$get_nonexclusive_access (nav$tcpip_attributes_list.access_control);
    nap$find_tcpip_attributes (application, tcpip_attributes);
    IF tcpip_attributes <> NIL THEN
      nlp$get_exclusive_access (tcpip_attributes^.access_control);
      IF tcpip_attributes^.protocol = nac$stream_socket THEN
        IF tcpip_attributes^.tcpip_status = nac$application_active THEN
          tcp_socket_list := tcpip_attributes^.tcp_socket_list;
          WHILE (tcp_socket_list <> NIL) AND
                (tcp_socket_list^.connection_id <> connection_id) DO
            tcp_socket_list := tcp_socket_list^.next_entry;
          WHILEND;
          IF tcp_socket_list <> NIL THEN
            tcp_socket_list^.socket_assigned := TRUE;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$unknown_socket,
                  application, status);
          IFEND;
        ELSE {  reject application inactive.
          osp$set_status_abnormal (nac$status_id, nae$application_inactive,
                application, status);
        IFEND;
      ELSE {  application not TCP
        osp$set_status_abnormal (nac$status_id, nae$unknown_application,
              application, status);
      IFEND;
      nlp$release_exclusive_access (tcpip_attributes^.access_control);
    ELSE {unknown_application.
      osp$set_status_abnormal (nac$status_id, nae$unknown_application,
            application, status);
    IFEND;
    nlp$release_nonexclusive_access (nav$tcpip_attributes_list.access_control);
  PROCEND nlp$tcpip_set_socket_assigned;
*copyc nap$add_tcp_socket_list
*copyc nap$add_udp_socket_list
*copyc nap$find_client_attributes
*copyc nap$find_server_attributes
*copyc nap$find_tcpip_attributes
*copyc nap$validate_user
*copyc nlp$get_exclusive_access
*copyc nlp$get_nonexclusive_access
*copyc nlp$release_exclusive_access
*copyc nlp$release_nonexclusive_access
MODEND nam$application_management;
*DECK DECK=NAM$AWAIT_DATA_AVAILABLE EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE nam$await_data_available;

{ MODULE DECK NAM$AWAIT_DATA_AVAILABLE }

?? TITLE := 'NOS/VE :  NETWORK ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] NAM$AWAIT_DATA_AVAILABLE' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc nak$external_keypoints_job_mode
*copyc nat$external_keypoint_constants
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
?? EJECT ??
*copyc nah$await_data_available
 PROCEDURE [#GATE,XDCL] nap$await_data_available (
        file_identifier: amt$file_identifier;
        wait_time: nat$wait_time;
        expected_wait_time: nat$wait_time;
    VAR status: ost$status);


    CONST
      interface_name = 'NAP$SE_AWAIT_EVENT',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry , osk$m * amk_await_data_available, nak$session_external);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit , osk$m * amk_await_data_available, nak$session_external);
      RETURN;
    IFEND;

    call_block.operation := nac$await_data_available;
    call_block.await_data_available.wait_time := wait_time;
    call_block.await_data_available.expected_wait_time := expected_wait_time;

*copy BAI$CALL_FAP_CONTROL

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit , osk$m * amk_await_data_available, nak$session_external);
  PROCEND nap$await_data_available;
MODEND nam$await_data_available;

*DECK DECK=NAM$CHANNELNET_RING1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Network Access : Channelnet Ring1' ??
MODULE nam$channelnet_ring1;

{
{    PURPOSE:
{       The purpose of this module is to contain the functions necessary for
{       communication among job mode channelnet, monitor mode channelnet
{       (network response processor), and the network PPU.  The functions
{       exist in ring 1 to provide write access to the appropriate data
{       structures.
{
{    DESIGN:
{       The functions execute as the result of procedure call from ring 3
{       resident channelnet processes.
{
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nak$cn_keypoints_job_mode
*copyc iot$io_request
*copyc iot$pp_number
*copyc iot$pp_interface_table
*copyc iot$command
*copyc nac$max_preallocated_requests
*copyc nat$data_fragments
*copyc nat$request_block_list
*copyc nat$preallocated_request_blocks
*copyc nlt$bm_buffer_list_array
*copyc nlt$bm_message_id
*copyc nlt$cc_connection_class
*copyc nlt$master_control_table
*copyc ost$execution_control_block
*copyc ost$hardware_subranges
*copyc ost$signature_lock_status
*copyc ost$status
?? POP ??
*copyc i#real_memory_address
*copyc nap$free_request_block
*copyc nap$get_request_block
*copyc osp$system_error
*copyc osp$begin_system_activity
*copyc osp$end_system_activity
*copyc pmp$find_executing_task_xcb
*copyc syp$cycle
*copyc cmv$logical_unit_table
*copyc cmv$logical_pp_table_p
*copyc nav$completed_output_requests
*copyc nav$include_debug_keypoints
*copy nav$network_response_processor
*copyc nav$preallocated_request_block
*copy nav$si_received_message_list
*copyc nlv$pp_buffer
*copyc nlv$pp_send_queue_tails
*copy oss$mainframe_paged_literal
*copyc osv$mainframe_wired_cb_heap
*copy osv$mainframe_wired_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  CONST
    max_lock_retries = 20;

  VAR
    clear_lockword: [STATIC, READ, OSS$MAINFRAME_PAGED_LITERAL] iot$lockword := [FALSE, 0, [FALSE, 0, 0]],
    set_lockword: [STATIC, READ, OSS$MAINFRAME_PAGED_LITERAL] iot$lockword := [TRUE, 0, [TRUE, FALSE, 0, 0]];
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$add_buffer_pools', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$add_buffer_pools
    (    reserved_buffers: nlt$bm_buffer_list_array);

    VAR
      container_rma: integer,
      count: integer,
      current: integer,
      i: integer,
      j: integer,
      limit: integer;

    FOR i := nlc$bm_small_buffer_index TO nlc$bm_large_buffer_index DO
      IF (reserved_buffers [i].buffer_list <> NIL) AND (reserved_buffers [i].count > 0) THEN
        count := reserved_buffers [i].count;
        current := nlv$pp_buffer^.pool_header [i].inn DIV #SIZE (nlt$pp_buffer_pool_entry);
        limit := nlv$pp_buffer^.pool_header [i].limit DIV #SIZE (nlt$pp_buffer_pool_entry);

      /move_reserved_buffers_to_pool/
        FOR j := 1 TO count DO
          IF reserved_buffers [i].buffer_list^ [j] = NIL THEN
            count := j - 1;
            EXIT /move_reserved_buffers_to_pool/;
          IFEND;
          nlv$pp_buffer^.pool [i]^ [current].descriptor_pva := reserved_buffers [i].buffer_list^ [j];
          i#real_memory_address (reserved_buffers [i].buffer_list^ [j]^.container, container_rma);
          nlv$pp_buffer^.pool [i]^ [current].container_rma := container_rma;
          current := current + 1;
          IF current = limit THEN
            current := 0;
          IFEND;
        FOREND /move_reserved_buffers_to_pool/;

        nlv$pp_buffer^.pool_header [i].inn := (nlv$pp_buffer^.pool_header [i].inn +
              (count * #SIZE (nlt$pp_buffer_pool_entry))) MOD nlv$pp_buffer^.pool_header [i].limit;
      IFEND;
    FOREND;
  PROCEND nap$add_buffer_pools;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$get_received_messages', EJECT ??
*copy nah$get_received_messages

  PROCEDURE [XDCL, #GATE] nap$get_received_messages (xcb_list: boolean;
    VAR received_messages: ^nlt$bm_message_descriptor);

    VAR
      xcb: ^ost$execution_control_block,
      cs_status: osc$cs_successful .. osc$cs_variable_locked,
      current,
      new,
      actual: nat$received_message_list;

    #keypoint (osk$entry, 0, nak$get_received_messages);
    received_messages := NIL;
    new.next_received_message := NIL;
    new.fill := 0;
    current := new;
    IF xcb_list THEN
      pmp$find_executing_task_xcb (xcb);
      REPEAT
        #compare_swap (xcb^.received_message_list, current, new, actual, cs_status);
        IF (cs_status = osc$cs_failed) THEN
          current.next_received_message := actual.next_received_message;
          received_messages := actual.next_received_message;
        IFEND;
      UNTIL cs_status = osc$cs_successful;
    ELSE
      REPEAT
        #compare_swap (nav$si_received_message_list, current, new, actual, cs_status);
        IF (cs_status = osc$cs_failed) THEN
          current.next_received_message := actual.next_received_message;
          received_messages := actual.next_received_message;
        IFEND;
      UNTIL cs_status = osc$cs_successful;
    IFEND;
    #keypoint (osk$exit, 0, nak$get_received_messages);
  PROCEND nap$get_received_messages;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$get_sent_messages', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$get_sent_messages
    (    message_id_array {OUTPUT} : ^array [1 .. * ] OF nlt$bm_message_id;
     VAR message_count: 0 .. 0ff(16);
     VAR more_messages: boolean);

    VAR
      retrieved_request_blocks: [STATIC] ^nat$request_block := NIL,
      complete_request: ^nat$request_block,
      next_request_block: ^nat$request_block,
      new,
      actual,
      current: nat$request_block_list,
      cs_status: osc$cs_successful .. osc$cs_variable_locked,
      i: integer;

    #keypoint (osk$entry, 0, nak$get_sent_messages);
    message_count := 0;
    REPEAT
      IF (retrieved_request_blocks <> NIL) THEN
        REPEAT
          IF (retrieved_request_blocks^.network_request.message_id.descriptor <> NIL) THEN
            message_count := message_count + 1;
            message_id_array^ [message_count] := retrieved_request_blocks^.network_request.message_id;
          IFEND;
          next_request_block := retrieved_request_blocks^.network_request.request_block_link;
          complete_request := retrieved_request_blocks;
          nap$free_request_block (complete_request);
          retrieved_request_blocks := next_request_block;
        UNTIL ((message_count = UPPERBOUND (message_id_array^)) OR (retrieved_request_blocks = NIL));
      IFEND;
      IF (retrieved_request_blocks = NIL) THEN
        new.request_block_link := NIL;
        new.requests_queued := 0;
        current := new;
        REPEAT
          #compare_swap (nav$completed_output_requests, current, new, actual, cs_status);
          IF (cs_status = osc$cs_failed) THEN
            current := actual;
            retrieved_request_blocks := actual.request_block_link;
          IFEND;
        UNTIL (cs_status = osc$cs_successful);
      IFEND;
    UNTIL ((message_count = UPPERBOUND (message_id_array^)) OR (retrieved_request_blocks = NIL));
    more_messages := (retrieved_request_blocks <> NIL);
    #keypoint (osk$exit, 0, nak$get_sent_messages);
  PROCEND nap$get_sent_messages;
 ?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$initialize_request_blocks', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$initialize_request_blocks;
*copy nah$initialize_request_blocks

    VAR
      i: nat$request_block_identifier,
      request_block_length: integer,
      complete_request: ^nat$complete_request_block,
      complete_request_block: ^SEQ ( * ),
      request_block: ^nat$request_block,
      peripheral_request_rma: integer;

    IF (nav$preallocated_request_block = NIL) THEN
      ALLOCATE nav$preallocated_request_block: [1 .. nac$max_preallocated_requests] IN
            osv$mainframe_wired_heap^;
      request_block_length := ((((#SIZE (nat$request_block) + #SIZE (ost$word) - 1) DIV #SIZE (ost$word)) *
            #SIZE (ost$word)) + (#SIZE (mmt$rma_list_entry) * UPPERVALUE (nat$fixed_rma_list)));

      FOR i := 1 TO UPPERBOUND (nav$preallocated_request_block^) DO
        ALLOCATE complete_request: [[REP request_block_length OF cell]] IN osv$mainframe_wired_cb_heap^;
        complete_request_block := ^complete_request^.complete_sequence;
        RESET complete_request_block;
        NEXT request_block IN complete_request_block;
        request_block^.complete_request_block := complete_request;
        NEXT request_block^.network_request.rma_list: [1 .. UPPERVALUE (nat$fixed_rma_list)] IN
              complete_request_block;

        request_block^.io_request.response_processor_p := nav$network_response_processor;
        request_block^.io_request.device_request_p := #LOC (request_block^.network_request);
        request_block^.io_request.pp_request_p := ^request_block^.network_request.peripheral_request;

        request_block^.network_request.request_block_link := NIL;
        request_block^.network_request.peripheral_request.recovery := ioc$attempt_recovery;
        request_block^.network_request.peripheral_request.interrupt.value := TRUE;
        request_block^.network_request.peripheral_request.priority := 1;

        request_block^.network_request.message_id.descriptor := NIL;

        request_block^.allocation_description.preallocated := TRUE;
        request_block^.allocation_description.block_identifier := i;
        request_block^.allocation_description.next_block_identifier := i + 1;

        i#real_memory_address (^request_block^.network_request.peripheral_request, peripheral_request_rma);
        request_block^.peripheral_request_rma := peripheral_request_rma;

        nav$preallocated_request_block^ [i] := request_block;
      FOREND;
      nav$preallocated_request_block^ [UPPERBOUND (nav$preallocated_request_block^)]^.
            allocation_description.next_block_identifier := 0;
      nav$preallocated_rb_control.first_free_block := LOWERBOUND (nav$preallocated_request_block^);
    IFEND;
  PROCEND nap$initialize_request_blocks;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$send_network_packet', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$send_network_packet
    (   class: nlt$cc_connection_class;
        device_id: nlt$device_identifier;
        data: nlt$bm_message_id;
        logical_unit_number: iot$logical_unit;
        pva_list: ^nat$data_fragments);

    VAR
      i,
      request_block: ^nat$request_block,
      rma_list_length: integer;

    #keypoint (osk$entry, 0, nak$send_channelnet_packet);

    rma_list_length := UPPERBOUND (pva_list^);
    nap$get_request_block (rma_list_length, request_block);
    build_rma_list (pva_list, request_block^.network_request.rma_list);

    request_block^.network_request.peripheral_request.request_length :=
          (#SIZE (nat$peripheral_request) + (rma_list_length * #SIZE (mmt$rma_list_entry)));
    request_block^.network_request.message_id := data;
    request_block^.network_request.peripheral_request.logical_unit := logical_unit_number;
    request_block^.network_request.peripheral_request.command.command_code :=
        ioc$cc_network_output;

    queue_send_request (request_block, class, logical_unit_number,
          ^nlv$pp_send_queue_tails^ [device_id][class]);
    #keypoint (osk$exit, 0, nak$send_channelnet_packet);
  PROCEND nap$send_network_packet;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] queue_peripheral_request', EJECT ??

  PROCEDURE [INLINE] queue_peripheral_request (request_block: ^nat$request_block;
        lockword: ^iot$lockword;
        request_queue: ^^iot$io_request;
        request_queue_rma: ^ost$real_memory_address);
    VAR
      actual: iot$lockword,
      count: integer,
      cs_status: osc$cs_successful .. osc$cs_variable_locked,
      io_request: ^iot$io_request,
      network_request: ^nat$network_request;

    request_block^.network_request.peripheral_request.pp_request := NIL;

    count := 0;
    osp$begin_system_activity;
    REPEAT
      #compare_swap (lockword^, clear_lockword, set_lockword, actual, cs_status);
      CASE cs_status OF
      = osc$cs_successful =
        ;
      = osc$cs_failed =
?? PUSH (LISTEXT := ON) ??
? IF nav$include_debug_keypoints THEN
?? POP ??
        #keypoint (osk$debug, 0, nak$request_queue_locked);
?? PUSH (LISTEXT := ON) ??
? IFEND
?? POP ??
        count := count + 1;
        IF (actual.lock_owner.cpu_lock) OR (count > max_lock_retries) THEN
          osp$end_system_activity;
          syp$cycle;
          osp$begin_system_activity;
        IFEND;
      = osc$cs_variable_locked =
        ;
      CASEND;
    UNTIL (cs_status = osc$cs_successful);

    IF (request_queue^ = NIL) THEN
      request_queue^ := ^request_block^.io_request;
      request_queue_rma^ := request_block^.peripheral_request_rma;
    ELSE
      io_request := request_queue^;
      REPEAT
        network_request := #LOC (io_request^.device_request_p^);
        io_request := network_request^.peripheral_request.pp_request;
      UNTIL (io_request = NIL);
      network_request^.peripheral_request.pp_request := ^request_block^.io_request;
      network_request^.peripheral_request.next_pp_request_rma := request_block^.peripheral_request_rma;
    IFEND;

    REPEAT
      #compare_swap (lockword^, set_lockword, clear_lockword, actual, cs_status);
    UNTIL (cs_status = osc$cs_successful);
    osp$end_system_activity;
  PROCEND queue_peripheral_request;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] queue_send_request', EJECT ??

  PROCEDURE [INLINE] queue_send_request
    (    request_block: ^nat$request_block;
         class: nlt$cc_connection_class;
         logical_unit_number: iot$logical_unit;
         send_queue_tail {output} : ^nlt$pp_send_queue_tail);

    VAR
      actual: nlt$pp_send_queue_tail,
      current: nlt$pp_send_queue_tail,
      cs_status: osc$cs_successful .. osc$cs_variable_locked,
      master_control_table: ^nlt$master_control_table,
      new: nlt$pp_send_queue_tail;

    current.fill := 0;
    current.send_queue_tail := NIL;
    new.send_queue_tail := request_block;

    REPEAT
      #compare_swap (send_queue_tail^, current, new, actual, cs_status);
      CASE cs_status OF
      = osc$cs_failed =
        current := actual;
      = osc$cs_successful, osc$cs_variable_locked =
        ;
      CASEND;
    UNTIL (cs_status = osc$cs_successful);

    IF current.send_queue_tail <> NIL THEN

{ Build the backward link to be used when flushing the queue.

      request_block^.network_request.request_block_link := current.send_queue_tail;

      current.send_queue_tail^.network_request.peripheral_request.next_pp_request_length := request_block^.
            network_request.peripheral_request.request_length;
      current.send_queue_tail^.network_request.peripheral_request.next_pp_request_rma := request_block^.
            peripheral_request_rma;
    ELSE { Queue empty.

{ The backward link does not need to be set to NIL here because the backward request chain is not
{ terminated by a NIL, but rather, by a comparison with the head-of-list RMA.

      master_control_table := #LOC(cmv$logical_unit_table^ [logical_unit_number].
            unit_communication_buffer_pva^);
      master_control_table^.request_queues [class].request_length := request_block^.network_request.
            peripheral_request.request_length;
      master_control_table^.request_queues [class].request_rma := request_block^.peripheral_request_rma;
    IFEND;
  PROCEND queue_send_request;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] build_rma_list', EJECT ??

  PROCEDURE [INLINE] build_rma_list (pva_list: ^nat$data_fragments;
        rma_list: ^nat$rma_list);

    VAR
      i: integer,
      rma: integer;

    FOR i := LOWERBOUND (pva_list^) TO UPPERBOUND (pva_list^) DO
      i#real_memory_address (pva_list^ [i].address, rma);
      rma_list^ [i].rma := rma;
      rma_list^ [i].length := pva_list^ [i].length;
    FOREND;
  PROCEND build_rma_list;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$issue_pp_request', EJECT ??
*copy nah$issue_pp_request

  PROCEDURE [XDCL, #GATE] nap$issue_pp_request (pp_number : iot$pp_number;
    command: iot$command;
    request_specific_data: ^nlt$ethernet_addr_and_checksum);

    VAR
      ethernet_address_rma: integer,
      pp_interface_table: ^iot$pp_interface_table,
      request_queue: ^^iot$io_request,
      request_queue_rma: ^ost$real_memory_address,
      lockword: ^iot$lockword,
      request_block: ^nat$request_block;

    nap$get_request_block (0, request_block);
    request_block^.network_request.peripheral_request.command := command;
    IF command.command_code = ioc$cc_define_ethernet_address THEN
      i#real_memory_address (#LOC (request_block^.network_request.ethernet_address),
              ethernet_address_rma);
      request_block^.network_request.peripheral_request.command.address := ethernet_address_rma;
      request_block^.network_request.ethernet_address := request_specific_data^;
    IFEND;

    pp_interface_table := cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p;
    IF (pp_interface_table <> NIL) THEN
      request_block^.network_request.peripheral_request.logical_unit := pp_interface_table^.
              first_logical_unit;
      lockword := ^pp_interface_table^.lockword;
      request_queue := ^pp_interface_table^.pp_request_queue;
      request_queue_rma := ^pp_interface_table^.pp_request_queue_rma;
      queue_peripheral_request (request_block, lockword, request_queue, request_queue_rma);
    ELSE
      osp$system_error ('PP CONFIGURATION ERROR', NIL);
    IFEND;
  PROCEND nap$issue_pp_request;
?? OLDTITLE ??
MODEND nam$channelnet_ring1
*DECK DECK=NAM$CHANNELNET_RING3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Network Access : Channelnet' ??
?? NEWTITLE := 'Global Declarations Referenced by This Module' ??
MODULE nam$channelnet_ring3;

{
{    PURPOSE:
{      The purpose of this module is to contain NAM/VE Channelnet Protocol Layer interfaces
{      and services.  The interfaces include upper layer request interfaces, and interfaces
{      (flag and signal handlers) which receive network events.
{
{      The module also contains procedures which constitute the system input task, the
{      completed output task, and the connection establishment task.
{
{    DESIGN:
{      This module is designed to be contained on the OSF$JOB_TEMPLATE_23D library and may execute
{      in any task.  Contained interfaces are not available to callers above ring 3.
{

?? PUSH (LISTEXT := ON) ??
*copyc nac$null_connection_id
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nak$cn_keypoints_job_mode
*copyc nlt$bm_pool_index
*copyc nlt$cc_work_list
*copyc nlt$pdu_type
*copyc oss$job_paged_literal
*copyc ost$global_task_id
*copyc ost$system_flag
*copyc pmt$program_parameters
*copyc pmt$signal
*copyc nlt$bm_message_id
*copyc nat$data_fragments
*copyc nat$network_address
*copyc nat$cn_interface
*copyc nat$cn_active_sap_list
*copyc nlt$cn_event_processor
*copyc nlt$la_header_format
*copyc nlt$network_device
*copyc nlt$network_device_list
*copyc nlt$signal_device_error

{   The channelnet pdu header is composed of the
{   layer 2 and layer 3A headers.

*copyc nat$cn_pdu_header
?? POP ??
*copyc nap$add_buffer_pools
*copyc nap$record_completed_output
*copyc nap$record_system_input
*copyc nap$send_network_packet
*copyc nap$get_sent_messages
*copyc nap$get_received_messages
*copyc nap$namve_system_error
*copyc nap$record_connection_establish
*copyc nlp$bm_extract_message_prefix
*copyc nlp$bm_get_message_length
*copyc nlp$bm_build_pva_list
*copyc nlp$bm_get_buffer_list
*copyc nlp$bm_add_message_prefix
*copyc nlp$bm_release_message
*copyc nlp$bm_release_messages
*copyc nlp$cc_receive_event
*copyc nlp$cc_receive_data
*copyc nlp$cc_reset_device
*copyc nlp$cl_get_exclusive_access
*copyc nlp$cl_release_exclusive_access
*copyc nlp$delink_receiving_connection
*copyc nlp$dequeue_receiving_conection
*copyc nlp$get_exclusive_access
*copyc nlp$get_nonexclusive_access
*copyc nlp$get_receiving_connections
*copyc nlp$la_close_sap
*copyc nlp$la_open_sap
*copyc nlp$la_send_data
*copyc nlp$requeue_msgs_for_input_task
*copyc nlp$release_exclusive_access
*copyc nlp$release_nonexclusive_access
*copyc osp$append_status_integer
*copyc osp$begin_subsystem_activity
*copyc osp$end_subsystem_activity
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$push_inhibit_job_recovery
*copyc osp$pop_inhibit_job_recovery
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$wait
*copyc tmp$save_system_task_id
*copyc jmv$executing_within_system_job
*copyc nav$cdna_multicast_address
*copyc nav$cn_sap_list
*copyc nav$cn_maximum_data_length
*copyc nav$global_statistics
*copyc nav$host_subnet_id
*copyc nav$namve_active
*copyc nav$network_paged_heap
*copyc nav$network_wired_heap
*copyc nav$statistics_enabled
*copyc nav$system_id
*copyc nav$network_procedures
*copyc nlv$cc_work_list
*copyc nlv$configured_network_devices
*copyc nlv$pp_buffer
*copyc nlv$replenish_pp_buffer_pools
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    detailed_system_identifier = packed record
      fill1: 0 .. 7f(16),
      multicast: boolean,
      system_id: 0 .. 0ffffffffff(16),
    recend;


  VAR
    nav$requeue_incoming_messages: [STATIC] boolean := FALSE,
    channelnet: [STATIC, oss$job_paged_literal, READ] string (10) := 'Channelnet';

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$system_input_task', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$system_input_task
    (    parameters: pmt$program_parameters;
     VAR status: ost$status);

{
{     This procedure constitutes the system input task.  That is, entrance to the procedure causes
{  the executing task to become the system input task.  After recording the task identifier the
{  task merely waits.  The task is subsequently activated via as the result of an input response
{  from the network PPU (flag, signal, or ready task from monitor mode in the CPU), or a ready
{  task from the connection establishment task to replenish the PP buffer pools.

    CONST
      system_input_list = FALSE;

    VAR
      data: nlt$bm_message_id,
      received_messages: ^nlt$bm_message_descriptor,
      receiving_connections: ^nlt$cl_connection,
      wait_time: 0 .. 0ffffffffffff(16);

    IF jmv$executing_within_system_job THEN
      nap$record_system_input {task identifier} ;
      tmp$save_system_task_id (tmc$stid_namve_system_input, FALSE, status);
      IF status.normal THEN
        WHILE TRUE DO
          osp$begin_subsystem_activity;
          IF nlv$replenish_pp_buffer_pools THEN
            nap$replenish_pp_buffer_pools;
          IFEND;
          nap$get_received_messages (system_input_list, received_messages);
          IF (received_messages <> NIL) THEN
            deliver_received_messages (TRUE, received_messages);
          IFEND;
          nlp$get_receiving_connections (receiving_connections);
          IF receiving_connections <> NIL THEN
            process_receiving_connections (receiving_connections);
          IFEND;
          osp$end_subsystem_activity;
          IF NOT nlv$replenish_pp_buffer_pools THEN
            wait_time := 20000000;
          ELSE
            wait_time := 5000;
          IFEND;
          pmp$wait (wait_time, wait_time);
        WHILEND;
      IFEND;
    IFEND;
  PROCEND nap$system_input_task;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$completed_output_task', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$completed_output_task
    (    parameters: pmt$program_parameters;
     VAR status: ost$status);

{
{     This procedure constitutes the completed output task.  That is, entrance to the procedure causes
{  the executing task to become the completed output task.  After recording the task identifier the
{  task merely waits.  The task is subsequently activated via a ready_task call from monitor to release
{  system buffers associated with sent messages.
{

    IF jmv$executing_within_system_job THEN
      nap$record_completed_output {task identifier} ;
      tmp$save_system_task_id (tmc$stid_completed_output, FALSE, status);
      IF status.normal THEN
        WHILE TRUE DO
          release_sent_messages;
          pmp$wait (20000000, 20000000);
        WHILEND;
      IFEND;
    IFEND;
  PROCEND nap$completed_output_task;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$connection_establish_task', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$connection_establish_task
    (    parameters: pmt$program_parameters;
     VAR status: ost$status);

{
{     This procedure constitutes the connection establishment task.  That is, entrance to the procedure
{  causes the executing task to become the connection establishment task.  After recording the task
{  identifier the task merely waits.  The task is subsequently activated as the result of connect requests
{  received from the network.
{

    IF jmv$executing_within_system_job THEN
      nap$record_connection_establish {task identifier} ;
      WHILE TRUE DO
        pmp$wait (20000000, 20000000);
      WHILEND;
    IFEND;
  PROCEND nap$connection_establish_task;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL]  nap$cn_flag_handler', EJECT ??

  PROCEDURE [XDCL] nap$cn_flag_handler
    (    flag_id: ost$system_flag);

    CONST
      xcb_list = TRUE;

    VAR
      data: nlt$bm_message_id,
      received_messages: ^nlt$bm_message_descriptor;

?? NEWTITLE := 'pop_inhibit_job_recovery', EJECT ??

    PROCEDURE pop_inhibit_job_recovery
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;
      condition_status.normal := TRUE;
    PROCEND pop_inhibit_job_recovery;
?? OLDTITLE ??
?? EJECT ??
    #KEYPOINT (osk$entry, 0, nak$cn_flag_handler);
    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;

    osp$establish_block_exit_hndlr (^pop_inhibit_job_recovery);
    nap$get_received_messages (xcb_list, received_messages);
    IF (received_messages <> NIL) THEN
      IF NOT nav$requeue_incoming_messages THEN
        deliver_received_messages (FALSE, received_messages);
      ELSE
        nlp$requeue_msgs_for_input_task (received_messages);
      IFEND;
    IFEND;
    osp$disestablish_cond_handler;
    osp$end_subsystem_activity;
    osp$pop_inhibit_job_recovery;
    #KEYPOINT (osk$exit, 0, nak$cn_flag_handler);
  PROCEND nap$cn_flag_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$cn_signal_handler', EJECT ??

  PROCEDURE [XDCL] nap$cn_signal_handler
    (    originator: ost$global_task_id;
         signal: pmt$signal);

*copy nah$cn_signal_handler

    VAR
      signal_contents: ^nlt$signal_device_error;

    #KEYPOINT (osk$entry, 0, nak$cn_signal_handler);
    osp$push_inhibit_job_recovery;
    signal_contents := #LOC (signal.contents);
    IF signal_contents^.pp_pools_need_replenishing THEN
      nap$replenish_pp_buffer_pools;
    IFEND;
    IF signal_contents^.message <> NIL THEN
      IF signal_contents^.reset_device THEN

{ The device reset request was issued from monitor mode module nam$process_network_response.
{ Either the message was addressed to a nonexistent connection (destination reference number not found)
{ or an invalid CC PDU kind was received.

        nlp$cc_reset_device (signal_contents^.device_id);
      IFEND;
      release_incomplete_message (signal_contents^.message);
    IFEND;
    osp$pop_inhibit_job_recovery;
    #KEYPOINT (osk$exit, 0, nak$cn_signal_handler);
  PROCEND nap$cn_signal_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$incoming_message_cleanup', EJECT ??

  PROCEDURE [XDCL] nap$incoming_message_cleanup;

*copy nah$incoming_message_cleanup

    nav$requeue_incoming_messages := TRUE;
  PROCEND nap$incoming_message_cleanup;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$replenish_pp_buffer_pools', EJECT ??

{ PURPOSE:
{   The purpose of this request is to replenish the PP's buffers.  If buffers cannot be acquired to
{   fulfill the request the NLV$REPLENISH_PP_BUFFER_POOLS flag will be set and the wait time for the
{   input task will be reduced until the pools have been replenished.  This procedure should
{   only be called from the system input task except during initialization.  By only executing this
{   code in one task avoids the overhead of synchronization.

  PROCEDURE [XDCL] nap$replenish_pp_buffer_pools;

    VAR
      buffers_acquired: boolean,
      count: integer,
      i: nlt$bm_pool_index,
      replenish_buffers: boolean,
      reserved_buffers: nlt$bm_buffer_list_array;

    nlv$replenish_pp_buffer_pools := FALSE;
    replenish_buffers := FALSE;

    FOR i := nlc$bm_small_buffer_index TO nlc$bm_large_buffer_index DO

      IF nlv$pp_buffer^.pool_header [i].inn >= nlv$pp_buffer^.pool_header [i].cpu_out THEN
        count := (nlv$pp_buffer^.pool_header [i].inn - nlv$pp_buffer^.pool_header [i].cpu_out) DIV
              #SIZE (nlt$pp_buffer_pool_entry);
      ELSE
        count := ((nlv$pp_buffer^.pool_header [i].limit - nlv$pp_buffer^.pool_header [i].cpu_out) +
              nlv$pp_buffer^.pool_header [i].inn) DIV #SIZE (nlt$pp_buffer_pool_entry);
      IFEND;

{ Replenish buffers only if the pool is below the threshold.

      IF count < nlv$pp_buffer^.pool_header [i].threshold THEN
        reserved_buffers [i].count := (nlv$pp_buffer^.pool_header [i].limit DIV
              #SIZE (nlt$pp_buffer_pool_entry)) - count - 1;

        IF reserved_buffers [i].count > 0 THEN
          replenish_buffers := TRUE;
          PUSH reserved_buffers [i].buffer_list: [1 .. reserved_buffers [i].count];
        ELSE
          reserved_buffers [i].buffer_list := NIL;
        IFEND;

      ELSE { Above threshold.
        reserved_buffers [i].count := 0;
        reserved_buffers [i].buffer_list := NIL;
      IFEND;

{! statistics begin

      IF nav$statistics_enabled THEN
        IF count = 0 THEN
          nav$global_statistics.pp_buffer_pool.empty_pools_count [i] :=
                nav$global_statistics.pp_buffer_pool.empty_pools_count [i] + 1;
        IFEND;
      IFEND;

{! statistics end

    FOREND;

    IF replenish_buffers THEN
      nlp$bm_get_buffer_list (reserved_buffers, buffers_acquired);
      IF buffers_acquired THEN
        nap$add_buffer_pools (reserved_buffers);
      IFEND;

      IF ((nlv$pp_buffer^.pool_header [nlc$bm_small_buffer_index].
            inn = nlv$pp_buffer^.pool_header [nlc$bm_small_buffer_index].cpu_out) OR
            (nlv$pp_buffer^.pool_header [nlc$bm_large_buffer_index].
            inn = nlv$pp_buffer^.pool_header [nlc$bm_large_buffer_index].cpu_out)) THEN

        nlv$replenish_pp_buffer_pools := TRUE;
      IFEND;
    IFEND;

  PROCEND nap$replenish_pp_buffer_pools;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$namve_config_activated', EJECT ??

  FUNCTION [XDCL, #GATE] nap$namve_config_activated: boolean;

    nap$namve_config_activated := nlv$configured_network_devices.network_device_list <> NIL;

  FUNCEND nap$namve_config_activated;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$namve_active' ??

  FUNCTION [XDCL, #GATE] nap$namve_active: boolean;

    nap$namve_active := nav$namve_active;

  FUNCEND nap$namve_active;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$process_receiving_conection', EJECT ??
*copy nlh$process_receiving_conection

  PROCEDURE [XDCL] nlp$process_receiving_conection
    (    connection_id: nlt$cl_connection_id);

?? OLDTITLE ??
?? NEWTITLE := 'release_connection_access', EJECT ??
  PROCEDURE release_connection_access
    (    condition: pmt$condition;
         ignore_condition_descriptor: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR condition_status: ost$status);

    IF ((pmc$program_termination IN condition.reason) OR (pmc$program_abort IN condition.reason)) THEN
      nlp$cl_release_exclusive_access (cl_connection);
    IFEND;
    condition_status.normal := TRUE;
  PROCEND release_connection_access;
?? OLDTITLE, EJECT ??

    VAR
      access_gained: boolean,
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      cs_status: osc$cs_successful .. osc$cs_variable_locked,
      next_connection_id: nlt$cl_connection_id;

    nlp$cl_get_exclusive_access (connection_id, TRUE, connection_exists, access_gained, cl_connection);
    IF connection_exists AND access_gained THEN
      #SPOIL (cl_connection);
      osp$establish_block_exit_hndlr (^release_connection_access);

{ Turn off the IN QUEUE flag.

      nlp$dequeue_receiving_conection (cl_connection, {ignore} next_connection_id);
      nlp$cc_receive_data (cl_connection);
      osp$disestablish_cond_handler;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSEIF connection_exists THEN

{ Add the connection to the work list.

      add_connection_to_cc_work_list (connection_id);
    ELSE { connection does not exist
      nap$namve_system_error ({Recoverable_error=} TRUE,
        'Connection in work list does not exist.', NIL);
    IFEND;
  PROCEND nlp$process_receiving_conection;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$cn_open_sap', EJECT ??

  PROCEDURE [XDCL] nlp$cn_open_sap
    (    sap: nat$cn_sap_id;
         event_processor: nat$network_procedure;
     VAR maximum_data_length: nat$data_length;
     VAR status: ost$status);

*copyc nlh$cn_open_sap

    VAR
      i: integer,
      active_sap_list: ^nat$cn_active_sap_list,
      free_entry: integer,
      link_sap_open: boolean;

    #KEYPOINT (osk$entry, 0, nak$cn_open_sap);
    status.normal := TRUE;
    free_entry := 0;
    nlp$get_exclusive_access (nav$cn_sap_list.access_control);
    active_sap_list := nav$cn_sap_list.active_sap_list;
    IF (active_sap_list = NIL) THEN
      ALLOCATE active_sap_list IN nav$network_paged_heap^;
      IF (active_sap_list <> NIL) THEN
        free_entry := LOWERBOUND (active_sap_list^);
        FOR i := free_entry TO UPPERBOUND (active_sap_list^) DO
          active_sap_list^ [i].in_use := FALSE;
        FOREND;
        nav$cn_sap_list.active_sap_list := active_sap_list;
      ELSE
        osp$set_status_condition ( nae$allocation_failed,  status);
      IFEND;
    ELSE

    /search_active_sap_list/
      FOR i := LOWERBOUND (active_sap_list^) TO UPPERBOUND (active_sap_list^) DO
        IF NOT active_sap_list^ [i].in_use THEN
          IF free_entry = 0 THEN
            free_entry := i;
          IFEND;
        ELSE
          IF active_sap_list^ [i].sap_id = sap THEN
            #KEYPOINT (osk$debug, osk$m * sap, nak$cn_sap_already_open);
            osp$set_status_condition ( nae$sap_already_open,  status);
            osp$append_status_integer (osc$status_parameter_delimiter, sap, 10, TRUE, status);
            EXIT /search_active_sap_list/;
          IFEND;
        IFEND;
      FOREND /search_active_sap_list/;

      IF (free_entry = 0) AND status.normal THEN

{       ACTIVE SAP LIST full.

        #KEYPOINT (osk$unusual, 0, nak$cn_active_sap_list_full);
        osp$set_status_abnormal (nac$status_id, nae$unable_to_open_sap, channelnet, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      open_link_access_sap (sap, event_processor, link_sap_open, status);
      IF status.normal THEN
        active_sap_list^ [free_entry].in_use := TRUE;
        active_sap_list^ [free_entry].sap_id := sap;
        active_sap_list^ [free_entry].event_processor := event_processor;
        active_sap_list^ [free_entry].link_access_sap_open := link_sap_open;
        maximum_data_length := nav$cn_maximum_data_length;
      IFEND;
    IFEND;

    nlp$release_exclusive_access (nav$cn_sap_list.access_control);
    #KEYPOINT (osk$exit, 0, nak$cn_open_sap);
  PROCEND nlp$cn_open_sap;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$cn_close_sap', EJECT ??

  PROCEDURE [XDCL] nlp$cn_close_sap
    (    sap: nat$cn_sap_id;
     VAR status: ost$status);

*copyc nlh$cn_close_sap

    VAR
      i: integer,
      sap_closed: boolean,
      active_sap_list: ^nat$cn_active_sap_list;

    #KEYPOINT (osk$entry, 0, nak$cn_close_sap);
    status.normal := TRUE;
    sap_closed := FALSE;
    nlp$get_exclusive_access (nav$cn_sap_list.access_control);
    active_sap_list := nav$cn_sap_list.active_sap_list;
    IF (active_sap_list <> NIL) THEN

    /close_sap/
      FOR i := LOWERBOUND (active_sap_list^) TO UPPERBOUND (active_sap_list^) DO
        IF (active_sap_list^ [i].in_use) AND (active_sap_list^ [i].sap_id = sap) THEN
          active_sap_list^ [i].in_use := FALSE;
          sap_closed := TRUE;
          IF active_sap_list^ [i].link_access_sap_open THEN
            nlp$la_close_sap (sap, status);
          IFEND;
          EXIT /close_sap/;
        IFEND;
      FOREND /close_sap/;
    IFEND;
    nlp$release_exclusive_access (nav$cn_sap_list.access_control);
    IF NOT sap_closed THEN
      #KEYPOINT (osk$unusual, osk$m * sap, nak$cn_sap_already_closed);
      osp$set_status_abnormal (nac$status_id, nae$sap_not_open, channelnet, status);
      osp$append_status_integer (osc$status_parameter_delimiter, sap, 10, TRUE, status);
    IFEND;
    #KEYPOINT (osk$exit, 0, nak$cn_close_sap);
  PROCEND nlp$cn_close_sap;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_sap_open', EJECT ??

  PROCEDURE [INLINE] get_sap_open
    (    sap: nat$cn_sap_id;
     VAR sap_open: boolean);

    VAR
      i: integer,
      active_sap_list: ^nat$cn_active_sap_list;

    sap_open := FALSE;
    nlp$get_nonexclusive_access (nav$cn_sap_list.access_control);
    active_sap_list := nav$cn_sap_list.active_sap_list;
    IF active_sap_list <> NIL THEN

    /search_active_sap_list/
      FOR i := LOWERBOUND (active_sap_list^) TO UPPERBOUND (active_sap_list^) DO
        IF (active_sap_list^ [i].in_use) AND (active_sap_list^ [i].sap_id = sap) THEN
          sap_open := TRUE;
          EXIT /search_active_sap_list/;
        IFEND;
      FOREND /search_active_sap_list/;
    IFEND;
    nlp$release_nonexclusive_access (nav$cn_sap_list.access_control);
  PROCEND get_sap_open;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$cn_send_datagram', EJECT ??

  PROCEDURE [XDCL] nlp$cn_send_datagram
    (    sap: nat$cn_sap_id;
         device: nlt$device_identifier;
         destination: nat$system_address;
         datagram: nlt$bm_message_id;
     VAR status: ost$status);

*copyc nlh$cn_send_datagram

    VAR
      data_length: integer,
      data: nlt$bm_message_id,
      i: integer,
      new_data: nlt$bm_message_id,
      sap_open: boolean;

    #KEYPOINT (osk$entry, 0, nak$cn_send_datagram);
    status.normal := TRUE;
    nlp$bm_get_message_length (datagram, data_length);
    data := datagram;
    IF data_length <= nav$cn_maximum_data_length THEN
      get_sap_open (sap, sap_open);
      IF sap_open THEN
        nlp$get_nonexclusive_access (nlv$configured_network_devices.access_control);

{ Determine if the Channelnet PDU is destined for the directly connected device or
{ a remote device accessed by an ICA-II.

        IF (nlv$configured_network_devices.network_device_list^ [device].kind = nac$ica_2) AND
              (nlv$configured_network_devices.network_device_list^ [device].system_id <>
              destination.system) THEN
          nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);
          nlp$la_send_data (sap, destination.network, destination.system, nlc$la_standard_header,
                nlc$la_system_priority, data, status);
        ELSE { Channelnet PDU is destined for the directly connected device.
          route_channelnet_packet (^nlv$configured_network_devices.network_device_list^ [device],
                destination.system, sap, data_length, data);
          nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);
        IFEND;
      ELSE
        nlp$bm_release_message (data);
        osp$set_status_abnormal (nac$status_id, nae$sap_not_open, channelnet, status);
        osp$append_status_integer (osc$status_parameter_delimiter, sap, 10, TRUE, status);
      IFEND;
    ELSE
      #KEYPOINT (osk$unusual, 0, nak$cn_max_length_exceeded);
      nlp$bm_release_message (data);
      osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, channelnet, status);
    IFEND;
    #KEYPOINT (osk$exit, 0, nak$cn_send_datagram);
  PROCEND nlp$cn_send_datagram;
?? OLDTITLE ??
?? NEWTITLE := 'add_connection_to_cc_work_list', EJECT ??
{
{  PURPOSE:
{      The purpose of this procedure is to add a Channel Connection that has
{   input messages queued on it into the Channel Connection work list for
{   processing at a later time. The elements in the work list will be processed
{   via a flag handler.
{   This procedure is only executed in the system input task.
{
{   NOTE: This procedure will not return until the connection has been placed
{         in the work list. This may require a wait for system resources to
{         free up.
{
{        ADD_CONNECTION_TO_CC_WORK_LIST (CONNECTION_ID)
{
{  CONNECTION_ID: (input) This parameter specifies the local connection identifier.
{       This identifier will be used to obtain access to the connection structure.
{

  PROCEDURE add_connection_to_cc_work_list
    (    connection_id: nlt$cl_connection_id);

    VAR
      cc_event: ^nlt$cc_work_unit;

    REPEAT
      ALLOCATE cc_event IN nav$network_paged_heap^;
      IF cc_event = NIL THEN
        syp$cycle;
      IFEND;
    UNTIL cc_event <> NIL;
    cc_event^.next_work_unit := NIL;
    cc_event^.kind := nlc$cc_connection_work_unit;
    cc_event^.connection_id := connection_id;
    nlv$cc_work_list.append^ := cc_event;
    nlv$cc_work_list.append := ^cc_event^.next_work_unit;

  PROCEND add_connection_to_cc_work_list;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] route_channelnet_packet', EJECT ??

  PROCEDURE [INLINE] route_channelnet_packet
    (    network_device: ^nlt$network_device;
         destination_system_id: nat$system_identifier;
         sap_id: nat$cn_sap_id;
         data_length: nat$data_length;
     VAR data {INPUT, OUTPUT} : nlt$bm_message_id);


    VAR
      i: integer,
      pva_list: ^nat$data_fragments,
      channelnet_pdu_header: nat$cn_pdu_header;


    IF (network_device^.path_status = nlc$path_available) THEN
      channelnet_pdu_header.data_length := data_length + nac$3a_header_length;
      channelnet_pdu_header.source_address := nav$system_id;
      channelnet_pdu_header.destination_address := destination_system_id;
      channelnet_pdu_header.source_sap_id := sap_id;
      channelnet_pdu_header.destination_sap_id := sap_id;
      channelnet_pdu_header.control := 0;
      nlp$bm_add_message_prefix (^channelnet_pdu_header, #SIZE (nat$cn_pdu_header), data);
      nlp$bm_build_pva_list (data, pva_list);
      nap$send_network_packet (nlc$cc_normal_class, network_device^.device_id, data,
            network_device^.logical_unit, pva_list);
    ELSE
      nlp$bm_release_message (data);
    IFEND;
  PROCEND route_channelnet_packet;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_sap_info', EJECT ??

  PROCEDURE [INLINE] get_sap_info
    (    sap: nat$cn_sap_id;
     VAR sap_open: boolean;
     VAR event_processor: nlt$cn_event_processor);

    VAR
      i: integer,
      active_sap_list: ^nat$cn_active_sap_list;

    sap_open := FALSE;
    nlp$get_nonexclusive_access (nav$cn_sap_list.access_control);
    active_sap_list := nav$cn_sap_list.active_sap_list;
    IF active_sap_list <> NIL THEN

    /search_active_sap_list/
      FOR i := LOWERBOUND (active_sap_list^) TO UPPERBOUND (active_sap_list^) DO
        IF (active_sap_list^ [i].in_use) AND (active_sap_list^ [i].sap_id = sap) THEN
          sap_open := TRUE;
          event_processor := nav$network_procedures [active_sap_list^ [i].event_processor].cn_event_processor;
          EXIT /search_active_sap_list/;
        IFEND;
      FOREND /search_active_sap_list/;
    IFEND;
    nlp$release_nonexclusive_access (nav$cn_sap_list.access_control);
  PROCEND get_sap_info;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] deliver_channelnet_event', EJECT ??

  PROCEDURE [INLINE] deliver_channelnet_event
    (    sap_id: nat$cn_sap_id;
         source_device: nlt$device_identifier;
         source_address: nat$system_address;
     VAR data: nlt$bm_message_id);

    VAR
      event_processor: nlt$cn_event_processor,
      sap_open: boolean;

    get_sap_info (sap_id, sap_open, event_processor);
    IF sap_open THEN
      event_processor^ (sap_id, source_device, source_address, data);
    ELSE
      nlp$bm_release_message (data);
    IFEND;
  PROCEND deliver_channelnet_event;
?? OLDTITLE ??
?? NEWTITLE := 'process_receiving_connections', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to process the input messages queued
{   on the connections in the given linked list. This process tries to get
{   exclusive access to the connection structure. If access is not gained
{   the connection identifier is queued in the work list to be processed
{   later.

  PROCEDURE process_receiving_connections
    (    receiving_connections: ^nlt$cl_connection);

?? OLDTITLE ??
?? NEWTITLE := 'release_connection_access', EJECT ??
  PROCEDURE release_connection_access
    (    condition: pmt$condition;
         ignore_condition_descriptor: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR condition_status: ost$status);

    IF ((pmc$program_termination IN condition.reason) OR (pmc$program_abort IN condition.reason)) THEN
      nlp$cl_release_exclusive_access (cl_connection);
    IFEND;
    condition_status.normal := TRUE;
  PROCEND release_connection_access;
?? OLDTITLE, EJECT ??

    VAR
      access_gained: boolean,
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      cs_status: osc$cs_successful .. osc$cs_variable_locked,
      next_connection_id: nlt$cl_connection_id;

    next_connection_id := receiving_connections^.identifier;
    REPEAT
      nlp$cl_get_exclusive_access (next_connection_id, TRUE,
        connection_exists, access_gained, cl_connection);
      IF connection_exists AND access_gained THEN
        #SPOIL (cl_connection);
        osp$establish_block_exit_hndlr (^release_connection_access);

{ Dequeue the connection from the receiving connections queue.

        nlp$dequeue_receiving_conection (cl_connection, next_connection_id);
        nlp$cc_receive_data (cl_connection);
        osp$disestablish_cond_handler;
        nlp$cl_release_exclusive_access (cl_connection);
      ELSEIF connection_exists THEN

{ Delink the connection from the receiving connections queue. The IN QUEUE
{ flag is left set.
{ It is safe to compare swap to the connection queue without locking the
{ connection first as only monitor mode accesses the connection queue.
{ If the connection is in the receiving connection queue, monitor
{ mode process will not change the connection queue.

        nlp$delink_receiving_connection (cl_connection, next_connection_id);
        add_connection_to_cc_work_list (cl_connection^.identifier);
      ELSE { connection does not exist
        nap$namve_system_error ({Recoverable_error=} TRUE,
          'Connection in receiving connection queue does not exist.', NIL);
        next_connection_id := nac$null_connection_id;
      IFEND;
    UNTIL next_connection_id = nac$null_connection_id;

  PROCEND process_receiving_connections;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] release_sent_messages', EJECT ??

  PROCEDURE [INLINE] release_sent_messages;

    TYPE
      messages = array [1 .. 20] of nlt$bm_message_id;

    VAR
      message_id_seq: SEQ (REP 1 of messages),
      message_ids: ^SEQ ( * ),
      message_id_array: ^messages,
      more_messages: boolean,
      sent_messages: ^array [1 .. * ] of nlt$bm_message_id,
      sent_message_count: 0 .. 0ff(16);

    message_ids := ^message_id_seq;
    REPEAT
      RESET message_ids;
      NEXT message_id_array IN message_ids;
      nap$get_sent_messages (message_id_array, sent_message_count, more_messages);
      IF (sent_message_count > 0) THEN
        RESET message_ids;
        NEXT sent_messages: [1 .. sent_message_count] IN message_ids;
        nlp$bm_release_messages (sent_messages^);
      IFEND;
    UNTIL NOT more_messages;
  PROCEND release_sent_messages;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] receive_channelnet_packet', EJECT ??

{ PURPOSE:
{   The purpose of this routine is to process incoming XNS PDU's.
{   Currently the only XNS PDU's that will be received are Initialization ME PDU's.

  PROCEDURE [INLINE] receive_channelnet_packet
    (VAR data {input, output} : nlt$bm_message_id);


    VAR
      channelnet_pdu_header: nat$cn_pdu_header,
      data_length: integer,
      detailed_system_id: ^detailed_system_identifier,
      device_id: nlt$device_identifier,
      header_length: nat$data_length,
      ignore_byte_count: nat$data_length,
      network_device: ^nlt$network_device,
      source_address: nat$system_address,
      valid_multicast_address: boolean;

    nlp$bm_get_message_length (data, data_length);
    IF (data_length <= nav$cn_maximum_data_length + #SIZE (channelnet_pdu_header)) AND
          (data_length >= #SIZE (channelnet_pdu_header)) THEN

{ Device_id MUST be retrieved from the message descriptor BEFORE any extracts have been done. This is
{ because an extract could cause the message descriptor containing the received message descriptor to
{ be released.

      device_id := data.descriptor^.received_message.device_id;
      header_length := #SIZE (channelnet_pdu_header);
      nlp$bm_extract_message_prefix (^channelnet_pdu_header, header_length, data, ignore_byte_count);
      source_address.network := (nav$host_subnet_id + (device_id * 10000(16)));
      source_address.system := channelnet_pdu_header.source_address;
      nlp$get_nonexclusive_access (nlv$configured_network_devices.access_control);
      network_device := ^nlv$configured_network_devices.network_device_list^ [device_id];
      IF nav$system_id = channelnet_pdu_header.destination_address THEN
        nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);
        deliver_channelnet_event (channelnet_pdu_header.destination_sap_id, device_id, source_address, data);
      ELSE

{ Determine if it is a valid multicast.

        detailed_system_id := #LOC (channelnet_pdu_header.destination_address);
        valid_multicast_address := FALSE;
        IF detailed_system_id^.multicast THEN
          valid_multicast_address := channelnet_pdu_header.destination_address = nav$cdna_multicast_address;
        IFEND;

        nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);
        IF valid_multicast_address THEN
          deliver_channelnet_event (channelnet_pdu_header.destination_sap_id, device_id, source_address,
                data);
        ELSE
          nlp$bm_release_message (data);
        IFEND;
      IFEND;
    ELSE
      nlp$bm_release_message (data);
      #KEYPOINT (osk$unusual, osk$m * device_id, nak$cn_invalid_pdu);
    IFEND;
  PROCEND receive_channelnet_packet;
?? OLDTITLE ??
?? NEWTITLE := 'deliver_received_messages' ??
?? NEWTITLE := 'terminate_input_processing -- Job Recovery / Task Termination', EJECT ??

  PROCEDURE deliver_received_messages
    (    system_input_task: boolean;
     VAR received_messages: ^nlt$bm_message_descriptor);

    VAR
      current_message,
      previous_message,
      next_message: ^nlt$bm_message_descriptor,
      ignore_status: ost$status,
      message_id: nlt$bm_message_id;

    PROCEDURE terminate_input_processing
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        i: integer;

      IF ((pmc$program_termination IN condition.reason) OR (pmc$program_abort IN condition.reason)) THEN
        IF next_message <> NIL THEN

{ Reverse the order of the remaining messages to LIFO.

          previous_message := NIL;
          current_message := next_message;
          REPEAT
            next_message := current_message^.received_message.next_received_message;
            current_message^.received_message.next_received_message := previous_message;
            previous_message := current_message;
            current_message := next_message;
          UNTIL (current_message = NIL);

          received_messages := previous_message;
          nlp$requeue_msgs_for_input_task (received_messages);
        IFEND;
      IFEND;
      condition_status.normal := TRUE;
    PROCEND terminate_input_processing;
?? OLDTITLE, EJECT ??
    #KEYPOINT (osk$entry, 0, nak$deliver_received_messages);
    osp$establish_block_exit_hndlr (^terminate_input_processing);

{ Relink the received message list in order to process the messages in FIFO order.

    IF (received_messages <> NIL) THEN
      previous_message := NIL;
      current_message := received_messages;
      REPEAT
        next_message := current_message^.received_message.next_received_message;
        current_message^.received_message.next_received_message := previous_message;
        previous_message := current_message;
        current_message := next_message;
      UNTIL (current_message = NIL);

      received_messages := previous_message;
      REPEAT
        next_message := received_messages^.received_message.next_received_message;
        message_id.descriptor := received_messages;
        message_id.sequence_number := received_messages^.sequence_number;
        IF received_messages^.received_message.pdu_type = nlc$channel_connection_pdu THEN
          nlp$cc_receive_event (message_id);
        ELSE
          receive_channelnet_packet (message_id);
        IFEND;
        received_messages := next_message;
      UNTIL (received_messages = NIL);
    IFEND;
    osp$disestablish_cond_handler;
    #KEYPOINT (osk$exit, 0, nak$deliver_received_messages);
  PROCEND deliver_received_messages;
?? OLDTITLE ??
?? NEWTITLE := 'open_link_access_sap', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to determine if the user request
{   to open a Channelnet SAP also requires that a Link Access SAP be
{   opened in an OSI communications device, and if so, over which
{   networks should the SAP be opened. A Link Access SAP is required
{   only if the directly connected network is only accessable via an
{   ICA-II.
{

  PROCEDURE open_link_access_sap
    (    sap_id: nat$cn_sap_id;
         event_processor: nat$network_procedure;
     VAR sap_opened: boolean;
     VAR status: ost$status);

    VAR
      device: nlt$device_identifier,
      device_count: nlt$device_identifier,
      device_list: ^array [1 .. * ] of nlt$device_identifier,
      network_device_list: ^nlt$network_device_list;


    status.normal := TRUE;
    sap_opened := FALSE;
    nlp$get_nonexclusive_access (nlv$configured_network_devices.access_control);
    network_device_list := nlv$configured_network_devices.network_device_list;
    PUSH device_list: [1 .. UPPERBOUND (network_device_list^)];
    device_count := 0;

    FOR device := 1 TO UPPERBOUND (network_device_list^) DO
      IF network_device_list^ [device].kind = nac$ica_2 THEN
        device_count := device_count + 1;
        device_list^ [device_count] := device;
      IFEND;
    FOREND;
    nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);
    IF device_count > 0 THEN
      nlp$la_open_sap (sap_id, device_count, device_list, nlc$cc_normal_class, event_processor, status);
      IF status.normal THEN
        sap_opened := TRUE;
      IFEND;
    IFEND;

  PROCEND open_link_access_sap;

?? OLDTITLE ??
?? NEWTITLE := 'release_incomplete_message', EJECT ??

  PROCEDURE release_incomplete_message
    (    incomplete_message: ^nlt$bm_message_descriptor);

    VAR
      i: integer,
      message_id: nlt$bm_message_id;

    #KEYPOINT (osk$entry, 0, nak$release_incomplete_message);
    message_id.descriptor := incomplete_message;
    message_id.sequence_number := incomplete_message^.sequence_number;
    nlp$bm_release_message (message_id);
    #KEYPOINT (osk$exit, 0, nak$release_incomplete_message);
  PROCEND release_incomplete_message;
?? OLDTITLE ??
MODEND nam$channelnet_ring3;
*DECK DECK=NAM$CLOCK_ME EXPAND=TRUE
MODULE nam$clock_me;
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT:=ON) ??
*copyc clt$parameter_list
*copyc nat$bcd_time
*copyc nat$gt_interface
*copyc nat$gt_event
*copyc nat$network_message_priority
*copyc nlt$protocol
?? POP ??
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc i#move
*copyc nap$display_message
*copyc nap$gt_accept_connection
*copyc nap$gt_await_activity_complete
*copyc nap$gt_close_sap
*copyc nap$gt_disconnect
*copyc nap$gt_open_sap
*copyc nap$gt_receive_connect_event
*copyc nap$gt_receive_connection_event
*copyc nap$gt_send_data
*copyc nap$gt_reject_connection
*copyc nlp$register_title
*copyc nlp$delete_registered_title
*copyc osp$establish_block_exit_hndlr
*copyc pmp$compute_date_time_increment
*copyc pmp$get_compact_date_time
*copyc pmp$log

  CONST
    nac$clock_me_title = '$I_CLOCK_ME',
    nac$clock_title_password = 0,
    nac$max_clock_pdu_size = 51,
    nac$max_clock_trip_delay = 500,
    nac$max_connections = 1000,
    version = 1;

  CONST
    { Disconnect Reason Codes
    clock_synch_successful = 1,
    protocol_version_mismatch = 2,
    clock_synch_failed = 3,
    clock_me_busy = 4,
    clock_me_terminated = 5;

  TYPE
    clock_synchronization_pdu = record
      length: 0 .. 0ff(16),
      version_number: 0 .. 0ff(16),
      time_stamp: nat$bcd_time,
      system_address: nat$system_address,
      system_title: string (31),
    recend;

  TYPE
    connection_information = record
      activity_status: ost$activity_status,
      connection_id: nat$gt_connection_id,
      data_area: array [1 .. 1] of nat$data_fragment,
      data_buffer: SEQ (REP 40(16) of cell),
      date_time: ost$date_time,
      user_connection_id: nat$user_connection_id,
      sync_attempts: 0 .. 3,
      next_connection: ^connection_information,
      event: nat$gt_event,
    recend;


  VAR
    active_connections: 0 .. nac$max_connections := 0,
    connection_list: ^connection_information := NIL,
    max_connections: 1 .. nac$max_connections,
    temp_data_frag: array [1 .. 1] of nat$data_fragment,
    user_identifier: ost$name := nac$clock_me_title,
    wait_list: ^nat$gt_wait_list,
    wait_list_seq: ^SEQ ( * );

  ?? TITLE := 'exit_condition_handler', EJECT ??

  PROGRAM nap$clock_me (parameter_list: clt$parameter_list;
    VAR status: ost$status);



    PROCEDURE exit_condition_handler (condition: pmt$condition;
          condition_descriptor: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      VAR
        local_status: ost$status,
        output_data: array [1 .. 1] of nat$data_fragment;

      nlp$delete_registered_title (nac$clock_me_title, nac$clock_title_password, directory_title_id,
            local_status);
      IF NOT local_status.normal THEN
        nap$display_message (local_status);
      IFEND;
      disconnect_reason := clock_me_terminated;
      output_data [1].address := ^disconnect_reason;
      output_data [1].length := #SIZE (disconnect_reason);
      WHILE connection_list <> NIL DO
        nap$gt_disconnect (connection_list^.connection_id, output_data, {ignore} local_status);
        delete_connection (connection_list);
      WHILEND;
      nap$gt_close_sap (sap, {ignore} local_status);

    PROCEND exit_condition_handler;
?? TITLE := 'nap$clock_me', EJECT ??

    VAR
      activity_status: ost$activity_status,
      address: nat$internet_address,
      connection: ^connection_information,
      connect_buffer: [STATIC] SEQ (REP 20(16) of cell),
      connect_data: [STATIC] array [1 .. 1] of nat$data_fragment := [[^connect_buffer, #SIZE
        (connect_buffer)]],
      connect_event: nat$gt_connect_event,
      clock_pdu: ^clock_synchronization_pdu,
      data: ^SEQ ( * ),
      date_time: ost$date_time,
      directory_title_id: nat$directory_entry_identifier,
      disconnect_reason: 0 .. 0ff(16),
      index: integer,
      length: integer,
      log_message: [STATIC] string (35) := 'TRIP DELAY    SEC,      MILLISECOND',
      new_connection: ^connection_information,
      output_data: array [1 .. 1] of nat$data_fragment,
      sap: nat$gt_sap_identifier,
      trip_delay: pmt$time_increment;


    process_parameters (parameter_list, max_connections, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^exit_condition_handler);

    nap$gt_open_sap (max_connections, nac$system_message_priority, FALSE, sap, address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    register_title (address, sap, directory_title_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE wait_list_seq: [[REP (max_connections + 1) OF nat$gt_activity]];
    RESET wait_list_seq;
    NEXT wait_list: [1 .. 1] IN wait_list_seq;

    wait_list^ [1].activity := nac$gt_await_connect_request;
    wait_list^ [1].sap_id := sap;
    nap$gt_receive_connect_event (sap, connect_data, osc$nowait, connect_event, activity_status, status);
    IF NOT status.normal THEN
      nap$display_message (status);
      EXIT nap$clock_me;
    IFEND;

  /main_loop/
    WHILE TRUE DO
      nap$gt_await_activity_complete (wait_list^, index, status);
      IF status.normal THEN
        disconnect_reason := clock_me_busy;
        output_data [1].address := ^disconnect_reason;
        output_data [1].length := #SIZE (disconnect_reason);
        IF index = 1 THEN
          IF activity_status.status.normal AND (active_connections < max_connections) THEN
            ALLOCATE new_connection;
            IF new_connection = NIL THEN
              nap$gt_reject_connection (connect_event.connection, output_data, status);
              IF NOT status.normal THEN
                nap$display_message (status);
              IFEND;
            ELSE
              new_connection^.connection_id := connect_event.connection;
              new_connection^.data_area [1].address := ^new_connection^.data_buffer;
              new_connection^.data_area [1].length := #SIZE (new_connection^.data_buffer);
              new_connection^.next_connection := connection_list;
              new_connection^.sync_attempts := 1;
              output_data [1].address := NIL;
              output_data [1].length := 0;
              nap$gt_accept_connection (new_connection^.connection_id, output_data, NIL, status);
              IF status.normal THEN
                active_connections := active_connections + 1;
                connection_list := new_connection;
                update_wait_list (connect_event.connection);
                send_clock_pdu (address, new_connection^);
              ELSE
                nap$display_message (status);
                FREE new_connection;
                nap$gt_reject_connection (connect_event.connection, output_data, status);
                IF NOT status.normal THEN
                  nap$display_message (status);
                IFEND;
              IFEND;
            IFEND;
          ELSEIF activity_status.status.normal THEN
            pmp$log ('CK - CONNECTION REJECTED', status);
            nap$gt_reject_connection (connect_event.connection, output_data, status);
            IF NOT status.normal THEN
              nap$display_message (status);
            IFEND;
          IFEND;
          nap$gt_receive_connect_event (sap, connect_data, osc$nowait, connect_event, activity_status,
                status);
          IF NOT status.normal THEN
            nap$display_message (status);
            EXIT nap$clock_me;
          IFEND;
        ELSE
          find_connection (wait_list^ [index].receive_connection_id, connection);
          IF (connection <> NIL) AND connection^.activity_status.status.normal THEN
            CASE connection^.event.kind OF
            = nac$gt_data_event =
              data := ^connection^.data_buffer;
              RESET data;
              NEXT clock_pdu IN data;
              IF (clock_pdu^.version_number = version) AND (clock_pdu^.length = nac$max_clock_pdu_size - 1)
                    AND (connection^.event.data.data_length = nac$max_clock_pdu_size) THEN
                pmp$get_compact_date_time (date_time, status);
                pmp$compute_date_time_increment (connection^.date_time, date_time, trip_delay, status);
                log_message (12, 3) := '   ';
                log_message (20, 4) := '    ';
                STRINGREP (log_message (12, 3), length, trip_delay.second);
                STRINGREP (log_message (20, 4), length, trip_delay.millisecond);
                pmp$log (log_message, status);
                IF NOT synchronization_successful (trip_delay) THEN
                  IF connection^.sync_attempts < 3 THEN
                    connection^.sync_attempts := connection^.sync_attempts + 1;
                    send_clock_pdu (address, connection^);
                  ELSE
                    disconnect_reason := clock_synch_failed;
                    nap$gt_disconnect (connection^.connection_id, output_data, status);
                    IF NOT status.normal THEN
                      nap$display_message (status);
                    IFEND;
                    delete_connection (connection);
                  IFEND;
                ELSE
                  pmp$log ('CLOCK SYNC SUCCESSFUL', status);
                  disconnect_reason := clock_synch_successful;
                  nap$gt_disconnect (connection^.connection_id, output_data, status);
                  IF NOT status.normal THEN
                    nap$display_message (status);
                  IFEND;
                  delete_connection (connection);
                IFEND;
              ELSE
                pmp$log ('CK - INVALID CLOCK PDU', status);
                disconnect_reason := protocol_version_mismatch;
                nap$gt_disconnect (connection^.connection_id, output_data, status);
                IF NOT status.normal THEN
                  nap$display_message (status);
                IFEND;
                delete_connection (connection);
              IFEND;

            = nac$gt_expedited_data_event =
              pmp$log ('CK - X-DATA EVENT', status);
              nap$gt_disconnect (connection^.connection_id, output_data, status);
              IF NOT status.normal THEN
                nap$display_message (status);
              IFEND;
              delete_connection (connection);

            = nac$gt_disconnect_event =
              delete_connection (connection);
              pmp$log ('CK - UNEXPECTED DISCONNECT EVENT', status);
            CASEND;
          ELSE
            nap$gt_disconnect (wait_list^ [index].receive_connection_id, output_data, status);
            IF NOT status.normal THEN
              nap$display_message (status);
            IFEND;
            IF connection <> NIL THEN
              delete_connection (connection);
            ELSE
              pmp$log ('CK - DATA ON NON-EXISTENT CONNECTION', status);
            IFEND;
          IFEND;
        IFEND;
      ELSE
        EXIT /main_loop/;
      IFEND;
    WHILEND /main_loop/;
  PROCEND nap$clock_me;

?? TITLE := 'delete_connection', EJECT ??

  PROCEDURE delete_connection (connect_info: ^connection_information);

    VAR
      connection: ^connection_information,
      connection_link: ^^connection_information,
      i: 1 .. nac$max_connections;

    connection := connect_info;

  /forloop/
    FOR i := 2 TO UPPERBOUND (wait_list^) DO
      IF (wait_list^ [i].activity = nac$gt_await_receive_event) AND (wait_list^ [i].receive_connection_id =
            connection^.connection_id) THEN
        wait_list^ [i].activity := nac$gt_null_activity;
        EXIT /forloop/;
      IFEND;
    FOREND /forloop/;
    IF i = UPPERBOUND (wait_list^) THEN
      WHILE wait_list^ [i].activity = nac$gt_null_activity DO
        i := i - 1;
      WHILEND;
      RESET wait_list_seq;
      NEXT wait_list: [1 .. i] IN wait_list_seq;
    IFEND;

    connection_link := ^connection_list;
    WHILE (connection_link^ <> NIL) AND (connection_link^ <> connection) DO
      connection_link := ^connection_link^^.next_connection;
    WHILEND;
    IF connection_link^ <> NIL THEN
      connection_link^ := connection^.next_connection;
      FREE connection;
      active_connections := active_connections - 1;
    IFEND;
  PROCEND delete_connection;
?? TITLE := 'find_connection', EJECT ??

  PROCEDURE [INLINE] find_connection (connection_id: nat$gt_connection_id;
    VAR connection: ^connection_information);

    connection := connection_list;
    WHILE (connection <> NIL) AND (connection^.connection_id <> connection_id) DO
      connection := connection^.next_connection;
    WHILEND;
  PROCEND find_connection;

?? TITLE := 'send_clock_pdu', EJECT ??

  PROCEDURE send_clock_pdu (address: nat$internet_address;
    VAR connection: connection_information);

    VAR
      clock_pdu: clock_synchronization_pdu,
      date_time: ost$date_time,
      local_status: ost$status,
      output_data: array [1 .. 1] of nat$data_fragment;

    clock_pdu.length := nac$max_clock_pdu_size;
    clock_pdu.version_number := version;
    clock_pdu.system_address.network := address.network;
    clock_pdu.system_address.system := address.system;
    clock_pdu.system_title := '';
    pmp$get_compact_date_time (date_time, local_status);
    connection.date_time := date_time;
    clock_pdu.time_stamp.date.year1 := (date_time.year MOD 100) DIV 10;
    clock_pdu.time_stamp.date.year2 := date_time.year MOD 10;
    clock_pdu.time_stamp.date.month1 := date_time.month DIV 10;
    clock_pdu.time_stamp.date.month2 := date_time.month MOD 10;
    clock_pdu.time_stamp.date.day1 := date_time.day DIV 10;
    clock_pdu.time_stamp.date.day2 := date_time.day MOD 10;
    clock_pdu.time_stamp.time.hours1 := date_time.hour DIV 10;
    clock_pdu.time_stamp.time.hours2 := date_time.hour MOD 10;
    clock_pdu.time_stamp.time.minutes1 := date_time.minute DIV 10;
    clock_pdu.time_stamp.time.minutes2 := date_time.minute MOD 10;
    clock_pdu.time_stamp.time.seconds1 := date_time.second DIV 10;
    clock_pdu.time_stamp.time.seconds2 := date_time.second MOD 10;
    clock_pdu.time_stamp.time.milliseconds1 := date_time.millisecond DIV 100;
    clock_pdu.time_stamp.time.milliseconds2 := (date_time.millisecond MOD 100) DIV 10;
    clock_pdu.time_stamp.time.milliseconds3 := date_time.millisecond MOD 10;
    clock_pdu.time_stamp.time.fill := 0;

    output_data [1].address := ^clock_pdu;
    output_data [1].length := #SIZE (clock_pdu);
    nap$gt_send_data (connection.connection_id, output_data, TRUE, osc$wait, connection.activity_status,
          local_status);
    IF NOT local_status.normal THEN
      nap$display_message (local_status);
    IFEND;
    temp_data_frag [1].address := connection.data_area [1].address;
    temp_data_frag [1].length := connection.data_area [1].length;
    nap$gt_receive_connection_event (connection.connection_id, temp_data_frag, osc$nowait, connection.event,
          connection.activity_status, local_status);
    IF NOT local_status.normal THEN
      nap$display_message (local_status);
      delete_connection (^connection);
    IFEND;
  PROCEND send_clock_pdu;

?? TITLE := 'register_title', EJECT ??

  PROCEDURE register_title (address: nat$internet_address;
        sap: nat$gt_sap_identifier;
    VAR directory_identifier: nat$directory_entry_identifier;
    VAR status: ost$status);

    VAR
      class: nat$title_class,
      distribute: boolean,
      domain: nat$title_domain,
      osi_address: nat$osi_registration_address,
      priority: nat$directory_priority,
      service: nat$protocol;


    status.normal := TRUE;
    osi_address.kind := nac$osi_transport_address;
    osi_address.transport_selector := sap.osi_sap_identifier;
    service := nac$cdna_transport; { same value as for nac$osi_transport }
    priority := nac$max_directory_priority;
    domain.kind := nac$catenet_domain;
    distribute := FALSE;
    class := nac$cdna_internal;

    nlp$register_title (nac$clock_me_title, osi_address, service, NIL, 0, priority, domain,
          distribute, class, nac$clock_title_password, user_identifier, directory_identifier, status);
  PROCEND register_title;

?? TITLE := 'synchronization_successful', EJECT ??

  FUNCTION synchronization_successful (trip_delay: pmt$time_increment): boolean;

    synchronization_successful := ((trip_delay.millisecond <= nac$max_clock_trip_delay) AND (trip_delay.second
          = 0) AND (trip_delay.minute = 0) AND (trip_delay.hour = 0) AND (trip_delay.day = 0) AND (trip_delay.
          month = 0));

  FUNCEND synchronization_successful;

?? TITLE := 'process_parameters', EJECT ??

  PROCEDURE process_parameters (parameter_list: clt$parameter_list;
    VAR max_connections: 1 .. nac$max_connections;
    VAR status: ost$status);

{      PDT clock_me_pdt (
{      maximum_connections,mc:integer 1..nac$max_connections = 1000
{      status)

?? PUSH (LISTEXT := ON) ??

    VAR
      clock_me_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^clock_me_pdt_names,
        ^clock_me_pdt_params];

    VAR
      clock_me_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['MAXIMUM_CONNECTIONS', 1], ['MC', 1], ['STATUS', 2]];

    VAR
      clock_me_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ MAXIMUM_CONNECTIONS MC }
      [[clc$optional_with_default, ^clock_me_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$integer_value, 1, nac$max_connections]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      clock_me_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := '1000';

?? POP ??


    VAR
      value: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, clock_me_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('MAXIMUM_CONNECTIONS', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    max_connections := value.int.value;

  PROCEND process_parameters;

?? TITLE := 'update_wait_list', EJECT ??

  PROCEDURE [INLINE] update_wait_list (connection_id: nat$gt_connection_id);

    VAR
      i: 1 .. nac$max_connections;

  /forloop/
    FOR i := 1 TO UPPERBOUND (wait_list^) DO
      IF wait_list^ [i].activity = nac$gt_null_activity THEN
        wait_list^ [i].activity := nac$gt_await_receive_event;
        wait_list^ [i].receive_connection_id := connection_id;
        EXIT /forloop/;
      IFEND;
    FOREND /forloop/;

    { Last entry in wait_list is always in use.}

    IF i = UPPERBOUND (wait_list^) THEN
      RESET wait_list_seq;
      NEXT wait_list: [1 .. UPPERBOUND (wait_list^) + 1] IN wait_list_seq;
      wait_list^ [UPPERBOUND (wait_list^)].activity := nac$gt_await_receive_event;
      wait_list^ [UPPERBOUND (wait_list^)].receive_connection_id := connection_id;
    IFEND;

  PROCEND update_wait_list;

MODEND nam$clock_me;
*DECK DECK=NAM$DEBUG_NETWORK_PP EXPAND=TRUE
MODULE nam$debug_network_pp;
?? RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc jme$queued_file_conditions
*copyc jmp$system_job
*copyc nap$send_debug_mode_to_pp
*copyc nlv$configured_network_devices
*copyc nlp$get_nonexclusive_access
*copyc nlp$release_nonexclusive_access
*copyc nlt$network_device_list
*copyc osp$set_status_abnormal
*copyc osp$status_condition_code
?? POP ??
?? NEWTITLE := 'NAM$DEBUG_NETWORK_PP' ??

?? TITLE := '  NAP$DEBUG_NETWORK_PP', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$debug_network_pp
    (    program_parameters: clt$parameter_list;
     VAR status: ost$status);

{ PDT debug_network_pp_pdt (
{   debug_mode: boolean = false
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      debug_network_pp_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^debug_network_pp_pdt_names, ^debug_network_pp_pdt_params];

    VAR
      debug_network_pp_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of
            clt$parameter_name_descriptor := [['DEBUG_MODE', 1], ['STATUS', 2]];

    VAR
      debug_network_pp_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ DEBUG_MODE }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    CONST
      nac$debug_mode_on = 0,
      nac$debug_mode_off = 1;

    VAR
      debug_mode: nac$debug_mode_on .. nac$debug_mode_off,
      i: integer,
      network_device_list: ^nlt$network_device_list,
      parameter_specified: boolean,
      value: clt$value;

    status.normal := TRUE;
    debug_mode := nac$debug_mode_off;

    IF NOT jmp$system_job () THEN
      osp$set_status_abnormal ('JM', jme$must_be_system_job, 'nap$debug_network_pp', status);
      RETURN;
    IFEND;

    clp$scan_parameter_list (program_parameters, debug_network_pp_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$test_parameter ('DEBUG_MODE', parameter_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter_specified THEN
      clp$get_value ('DEBUG_MODE', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.bool.value THEN
        debug_mode := nac$debug_mode_on;
      IFEND;
    IFEND;
    nlp$get_nonexclusive_access (nlv$configured_network_devices.access_control);
    network_device_list := nlv$configured_network_devices.network_device_list;
    FOR i := LOWERBOUND (network_device_list^) TO UPPERBOUND (network_device_list^) DO
      IF (network_device_list^[i].path_status <> nlc$path_down) AND
            (network_device_list^[i].state = nlc$normal) THEN
        nap$send_debug_mode_to_pp (network_device_list^[i].pp_number, debug_mode);
      IFEND;
    FOREND;
    nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);

  PROCEND nap$debug_network_pp;

MODEND nam$debug_network_pp;
*DECK DECK=NAM$DISPLAY_TCPIP_STATIC_ROUTES EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE NETWORK ACCESS:  Display TCP/IP static routes.' ??
MODULE nam$display_tcpip_static_routes;

{ PURPOSE:
{   The following command procedure is used to display the TCP/IP static routes.
{
{ DESIGN:
{   This module resides on OSF$PROGRAMS library.

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nae$tcpip_mgmt_condition_codes
*copyc ost$status
?? POP ??
*copyc clp$close_display
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc nlp$tm_get_static_routes
*copyc osv$task_private_heap

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$display_tcpip_static_routes', EJECT ??

  PROCEDURE [XDCL] nap$display_tcpip_static_routes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE  display_tcpip_static_routes_pdt (
{    output,o: FILE = $OUTPUT
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 22, 13, 36, 48, 177],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$OUTPUT'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      count: integer,
      data_string: string (512),
      display_control: clt$display_control,
      i: integer,
      ignore_status: ost$status,
      length: integer,
      ring_attributes: amt$ring_attributes,
      static_routes: ^nlt$tm_static_route_definitions;

    ring_attributes.r1 := #ring (^ring_attributes);
    ring_attributes.r2 := #ring (^ring_attributes);
    ring_attributes.r3 := #ring (^ring_attributes);

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$open_display_reference (pvt [p$output].value^.file_value^, NIL, fsc$list,
      ring_attributes, display_control, status);
    IF NOT status.normal THEN
      clp$close_display (display_control, status);
      RETURN;
    IFEND;

    clp$put_display (display_control, 'Installed Static Route Definitions:', clc$trim, status);
    static_routes := NIL;
    REPEAT
      nlp$tm_get_static_routes (static_routes, count, status);
      IF (NOT status.normal) AND (status.condition = nae$tm_route_list_too_small) THEN
        IF static_routes <> NIL THEN
          FREE static_routes;
        IFEND;
        ALLOCATE static_routes: [1 .. count];
      IFEND;
    UNTIL (status.normal) OR (status.condition <> nae$tm_route_list_too_small);
    IF status.normal THEN
      FOR i := 1 to count DO
        clp$put_display (display_control, '', clc$trim, status);
        clp$put_display (display_control, '  DEFINE_TCPIP_STATIC_ROUTE ..', clc$trim, status);
        STRINGREP (data_string, length, '    LOCAL_DEVICE=', static_routes^ [i].local_device_name, ' ..');
        clp$put_display (display_control, data_string (1, length), clc$trim, status);
        STRINGREP (data_string, length, '    DESTINATION_ADDRESS=(',
              static_routes^ [i].destination_address DIV 1000000(16), ',',
              ((static_routes^ [i].destination_address MOD 1000000(16)) DIV 10000(16)), ',',
              ((static_routes^ [i].destination_address MOD 10000(16)) DIV 100(16)), ',',
              (static_routes^ [i].destination_address MOD 100(16)), ') ..');
        clp$put_display (display_control, data_string (1, length), clc$trim, status);
        STRINGREP (data_string, length, '    DESTINATION_ADDRESS_MASK=(',
              static_routes^ [i].destination_address_mask DIV 1000000(16), ',',
              ((static_routes^ [i].destination_address_mask MOD 1000000(16)) DIV 10000(16)), ',',
              ((static_routes^ [i].destination_address_mask MOD 10000(16)) DIV 100(16)), ',',
              (static_routes^ [i].destination_address_mask MOD 100(16)), ') ..');
        clp$put_display (display_control, data_string (1, length), clc$trim, status);
        IF static_routes^ [i].strict_route THEN
          clp$put_display (display_control, '    STRICT_ROUTE=TRUE', clc$trim, status);
        ELSE
          clp$put_display (display_control, '    STRICT_ROUTE=FALSE', clc$trim, status);
        IFEND;
      FOREND;
    IFEND;
    IF static_routes <> NIL THEN
      FREE static_routes;
    IFEND;
    clp$close_display (display_control, ignore_status);
  PROCEND nap$display_tcpip_static_routes;
?? OLDTITLE ??
MODEND nam$display_tcpip_static_routes;

*DECK DECK=NAM$EXTERNAL_CN_INTERFACE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Network Access : Channelnet External Interface' ??
MODULE nam$external_cn_interface;

{
{    PURPOSE:
{      The purpose of this module is to contain all NAM/VE Channelnet Application Layer interfaces.
{      The interfaces include application request interfaces and the "event processor" interface
{      which receives network events from the Channelnet Protocol Layer.
{
{    DESIGN:
{      This module is designed to be contained on the OSF$JOB_TEMPLATE_236 library and may execute
{      in any task.  Residence on the OSF$JOB_TEMPLATE_236 library restricts the use of the interfaces
{      to callers executing in rings 6 and below.
{
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nat$data_fragments
*copyc nat$network_address
*copyc nat$cn_interface
*copyc nat$open_cn_sap_descriptor
*copyc nlt$device_identifier
*copyc oss$job_paged_literal
*copyc oss$network_paged
?? POP ??
*copyc nlp$bm_create_message
*copyc nlp$bm_flush_message
*copyc nlp$bm_release_message
*copyc nlp$al_get_data_length
*copyc nlp$cn_open_sap
*copyc nlp$cn_send_datagram
*copyc nlp$cn_close_sap
*copyc osp$clear_job_signature_lock
*copyc osp$begin_subsystem_activity
*copyc osp$end_subsystem_activity
*copyc osp$append_status_integer
*copyc osp$set_status_abnormal
*copyc osp$set_job_signature_lock
*copyc pmp$wait
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_microsecond_clock
*copyc pmp$ready_task
*copyc syp$cycle
*copyc nav$network_paged_heap
*copyc nav$namve_active
*copyc nav$open_cn_sap_list_lock
*copyc nav$open_cn_sap_list
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    channelnet: [READ, oss$job_paged_literal] string (29) := 'Channelnet External Interface';

  CONST
    nac$cn_queue_limit = 256;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$cn_open_sap', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$cn_open_sap
    (    sap: nat$cn_sap_id;
     VAR maximum_data_length: nat$data_length;
     VAR status: ost$status);

    VAR
      new_sap_desc,
      sap_desc: ^nat$open_cn_sap_descriptor,
      internal_status: ost$status;

    IF NOT nav$namve_active THEN
      osp$set_status_abnormal (nac$status_id, nae$network_inactive, '', status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    osp$begin_subsystem_activity;
    ALLOCATE new_sap_desc IN nav$network_paged_heap^;
    IF new_sap_desc <> NIL THEN
      new_sap_desc^.waiting_task := FALSE;
      new_sap_desc^.sap_id := sap;
      new_sap_desc^.queued_messages := 0;
      new_sap_desc^.event_queue := NIL;
      pmp$get_executing_task_gtid (new_sap_desc^.sap_owner);
      nlp$cn_open_sap (sap, nac$cn_deliver_datagram, maximum_data_length, internal_status);
      IF internal_status.normal THEN
        new_sap_desc^.max_data_length := maximum_data_length;
        osp$set_job_signature_lock (nav$open_cn_sap_list_lock);
        new_sap_desc^.link := nav$open_cn_sap_list;
        nav$open_cn_sap_list := new_sap_desc;
        osp$clear_job_signature_lock (nav$open_cn_sap_list_lock);
      ELSE
        FREE new_sap_desc IN nav$network_paged_heap^;
        status := internal_status;
      IFEND;
    ELSE
      osp$set_status_abnormal (nac$status_id, nae$allocation_failed, channelnet, status);
    IFEND;
    osp$end_subsystem_activity;
  PROCEND nap$cn_open_sap;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$cn_send_datagram', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$cn_send_datagram
    (    sap: nat$cn_sap_id;
         device: nlt$device_identifier;
         destination: nat$system_address;
         data: nat$data_fragments;
     VAR status: ost$status);

    VAR
      data_length: nat$data_length,
      message_id: nlt$bm_message_id,
      sap_desc: ^nat$open_cn_sap_descriptor,
      task_id: ost$global_task_id,
      internal_status: ost$status;

    status.normal := TRUE;
    nlp$al_get_data_length (data, data_length);
    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (nav$open_cn_sap_list_lock);
    find_sap_descriptor (sap, sap_desc);
    osp$clear_job_signature_lock (nav$open_cn_sap_list_lock);
    IF sap_desc <> NIL THEN
      IF data_length <= sap_desc^.max_data_length THEN
        pmp$get_executing_task_gtid (task_id);
        IF sap_desc^.sap_owner = task_id THEN
          nlp$bm_create_message (data, message_id, internal_status);
          IF internal_status.normal THEN
            nlp$cn_send_datagram (sap, device, destination, message_id, internal_status);
            IF NOT internal_status.normal THEN
              status := internal_status;
            IFEND;
          ELSE
            status := internal_status;
          IFEND;
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$invalid_task,
                'Task which does send must be task which opened sap', status);
        IFEND;
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, channelnet, status);
        osp$append_status_integer (osc$status_parameter_delimiter, sap_desc^.max_data_length, 10, TRUE,
              status);
      IFEND;
    ELSE
      osp$set_status_abnormal (nac$status_id, nae$sap_not_open, channelnet, status);
      osp$append_status_integer (osc$status_parameter_delimiter, sap, 16, TRUE, status);
    IFEND;
    osp$end_subsystem_activity;
  PROCEND nap$cn_send_datagram;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$cn_close_sap', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$cn_close_sap
    (    sap: nat$cn_sap_id;
     VAR status: ost$status);

    VAR
      closed_sap_desc: ^nat$open_cn_sap_descriptor,
      event,
      next_event: ^nat$cn_event,
      next_sap_desc: ^nat$open_cn_sap_descriptor,
      sap_desc: ^^nat$open_cn_sap_descriptor,
      task_id: ost$global_task_id,
      internal_status: ost$status;

    status.normal := TRUE;
    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (nav$open_cn_sap_list_lock);
    sap_desc := ^nav$open_cn_sap_list;
    WHILE (sap_desc^ <> NIL) AND (sap_desc^^.sap_id <> sap) DO
      sap_desc := ^sap_desc^^.link;
    WHILEND;
    IF sap_desc^ <> NIL THEN
      pmp$get_executing_task_gtid (task_id);
      IF sap_desc^^.sap_owner = task_id THEN
        event := sap_desc^^.event_queue;
        next_sap_desc := sap_desc^^.link;
        closed_sap_desc := sap_desc^;
        sap_desc^ := next_sap_desc;
        osp$clear_job_signature_lock (nav$open_cn_sap_list_lock);
        FREE closed_sap_desc IN nav$network_paged_heap^;
        WHILE event <> NIL DO
          next_event := event^.link;
          nlp$bm_release_message (event^.message_id);
          FREE event IN nav$network_paged_heap^;
          event := next_event;
        WHILEND;
        nlp$cn_close_sap (sap, internal_status);
        IF NOT internal_status.normal THEN
          status := internal_status;
        IFEND;
      ELSE
        osp$clear_job_signature_lock (nav$open_cn_sap_list_lock);
        osp$set_status_abnormal (nac$status_id, nae$invalid_task,
              'Task which does close must be task which did open', status);
      IFEND;
    ELSE
      osp$clear_job_signature_lock (nav$open_cn_sap_list_lock);
      osp$set_status_abnormal (nac$status_id, nae$sap_not_open, channelnet, status);
      osp$append_status_integer (osc$status_parameter_delimiter, sap, 16, TRUE, status);
    IFEND;
    osp$end_subsystem_activity;
  PROCEND nap$cn_close_sap;
?? OLDTITLE ??
?? NEWTITLE := 'nap$cn_deliver_datagram', EJECT ??

  PROCEDURE [XDCL] nap$cn_deliver_datagram
    (    sap_id: nat$cn_sap_id;
         device: nlt$device_identifier;
         source: nat$system_address;
         datagram: nlt$bm_message_id);

    VAR
      event: ^^nat$cn_event,
      message_id: nlt$bm_message_id,
      new_event: ^nat$cn_event,
      sap_desc: ^nat$open_cn_sap_descriptor,
      ignore_status: ost$status;

    REPEAT
      ALLOCATE new_event IN nav$network_paged_heap^;
      IF new_event = NIL THEN
        syp$cycle;
      IFEND;
    UNTIL new_event <> NIL;
    new_event^.link := NIL;
    new_event^.device := device;
    new_event^.source := source;
    new_event^.message_id := datagram;
    osp$set_job_signature_lock (nav$open_cn_sap_list_lock);
    find_sap_descriptor (sap_id, sap_desc);
    IF (sap_desc <> NIL) AND (sap_desc^.queued_messages < nac$cn_queue_limit) THEN
      event := ^sap_desc^.event_queue;
      WHILE event^ <> NIL DO
        event := ^event^^.link;
      WHILEND;

      event^ := new_event;
      sap_desc^.queued_messages := sap_desc^.queued_messages + 1;
      IF sap_desc^.waiting_task THEN
        pmp$ready_task (sap_desc^.sap_owner, ignore_status);
        { ready_task status ignored - called for performance only }
        sap_desc^.waiting_task := FALSE;
      IFEND;
      osp$clear_job_signature_lock (nav$open_cn_sap_list_lock);
    ELSE
      {eat data }
      osp$clear_job_signature_lock (nav$open_cn_sap_list_lock);
      FREE new_event IN nav$network_paged_heap^;
      message_id := datagram;
      nlp$bm_release_message (message_id);
    IFEND;
  PROCEND nap$cn_deliver_datagram;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$cn_receive_datagram', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$cn_receive_datagram
    (    sap: nat$cn_sap_id;
         data_area: nat$data_fragments;
         wait_time: 0 .. 0ffffffff(16);
     VAR device: nlt$device_identifier;
     VAR source: nat$system_address;
     VAR received_data_length: integer;
     VAR status: ost$status);

    VAR
      event: ^nat$cn_event,
      sap_desc: ^nat$open_cn_sap_descriptor,
      task_id: ost$global_task_id,
      wait_timer: 0 .. 0ffffffff(16),
      internal_status: ost$status;

    status.normal := TRUE;
    internal_status.normal := TRUE;
    wait_timer := wait_time;
    pmp$get_executing_task_gtid (task_id);

  /check_for_datagram/
    REPEAT
      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (nav$open_cn_sap_list_lock);
      find_sap_descriptor (sap, sap_desc);
      IF sap_desc <> NIL THEN
        IF sap_desc^.sap_owner = task_id THEN
          IF sap_desc^.event_queue <> NIL THEN
            event := sap_desc^.event_queue;
            sap_desc^.event_queue := event^.link;
            sap_desc^.queued_messages := sap_desc^.queued_messages - 1;
            device := event^.device;
            source := event^.source;
            osp$clear_job_signature_lock (nav$open_cn_sap_list_lock);
            nlp$bm_flush_message (data_area, event^.message_id, received_data_length, internal_status);
            IF internal_status.normal THEN
              FREE event IN nav$network_paged_heap^;
            IFEND;
            osp$end_subsystem_activity;
            EXIT /check_for_datagram/
          ELSE
            IF wait_timer > 0 THEN
              sap_desc^.waiting_task := TRUE;
              osp$clear_job_signature_lock (nav$open_cn_sap_list_lock);
              osp$end_subsystem_activity;
              pmp$wait (wait_timer, wait_timer);
              wait_timer := 0;
              CYCLE /check_for_datagram/
            ELSE { no datagrams }
              sap_desc^.waiting_task := FALSE;
              osp$set_status_abnormal (nac$status_id, nae$no_datagram_available, channelnet, internal_status);
              osp$append_status_integer (osc$status_parameter_delimiter, sap, 16, TRUE, internal_status);
            IFEND;
          IFEND;
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$invalid_task,
                'Task which does receive must be task which did open', internal_status);
        IFEND;
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$sap_not_open, channelnet, internal_status);
        osp$append_status_integer (osc$status_parameter_delimiter, sap, 16, TRUE, internal_status);
      IFEND;
      osp$clear_job_signature_lock (nav$open_cn_sap_list_lock);
      osp$end_subsystem_activity;
    UNTIL NOT internal_status.normal;
    IF NOT internal_status.normal THEN
      status := internal_status;
    IFEND;
  PROCEND nap$cn_receive_datagram;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] find_sap_descriptor', EJECT ??

  PROCEDURE [INLINE] find_sap_descriptor
    (    sap: nat$cn_sap_id;
     VAR sap_desc: ^nat$open_cn_sap_descriptor);

    sap_desc := nav$open_cn_sap_list;
    WHILE ((sap_desc <> NIL) AND (sap_desc^.sap_id <> sap)) DO
      sap_desc := sap_desc^.link;
    WHILEND;

  PROCEND find_sap_descriptor;
?? OLDTITLE ??
MODEND nam$external_cn_interface;
*DECK DECK=NAM$EXTERNAL_CONNECTION_MGMT EXPAND=TRUE
?? RIGHT := 110 ??
MODULE nam$external_connection_mgmt;
{
{ This module contains the external interfaces to the connection management
{ service provided by NAMVE. These procedures call ring 3 procedures that
{ manipulate the connection management data structures.
?? PUSH (LISTEXT:=ON) ??
*copyc fst$file_reference
*copyc jmt$system_supplied_name
*copyc nae$application_interfaces
*copyc nae$directory_me_conditions
*copyc nat$change_attributes
*copyc nat$create_attributes
*copyc nat$directory_interfaces
*copyc nat$directory_search_identifier
*copyc nat$get_attributes
*copyc nat$network_address
*copyc nat$translation_attributes
*copyc nat$directory_priority
*copyc nat$protocol
*copyc nat$wait_time
*copyc ost$i_wait
?? POP ??
?? TITLE := 'XREF PROCEDURES', EJECT ??
*copyc amp$return
*copyc nap$get_attributes
*copyc nap$namve_system_error
*copyc nlp$accept_switch_offer
*copyc nlp$acquire_connection
*copyc nlp$acquire_specific_connection
*copyc nlp$get_title_translation
*copyc nlp$offer_connection_switch
*copyc nlp$request_connection
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$i_await_activity_completion
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$get_microsecond_clock
?? TITLE := 'GLOBAL VARIABLES', EJECT ??
*copyc oss$job_paged_literal
  VAR
    attributes_parameter: [READ, OSS$JOB_PAGED_LITERAL] string (10) := 'ATTRIBUTES',
    get_title_translation: [READ, OSS$JOB_PAGED_LITERAL] string (25) := 'NAP$GET_TITLE_TRANSLATION';


?? TITLE := 'NAP$ACCEPT_SWITCH_OFFER', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$accept_switch_offer (file: fst$file_reference;
        source: jmt$system_supplied_name;
        attributes: ^nat$change_attributes;
        wait_time: nat$wait_time;
    VAR status: ost$status);

*copyc nah$accept_switch_offer

    VAR
      activity_list: array [1 .. 2] of ost$i_activity,
      file_attributes: ^nat$create_attributes,
      i: integer,
      ready_index: integer;

    status.normal := TRUE;
    IF attributes <> NIL THEN
      PUSH file_attributes : [LOWERBOUND(attributes^) .. UPPERBOUND(attributes^)];
      FOR i := LOWERBOUND (attributes^) TO UPPERBOUND (attributes^) DO
        file_attributes^[i].kind := attributes^[i].kind;
        CASE attributes^[i].kind OF
        = nac$data_transfer_timeout =
          file_attributes^[i].data_transfer_timeout := attributes^[i].data_transfer_timeout;
        = nac$eoi_message =
          file_attributes^[i].eoi_message := attributes^[i].eoi_message;
        = nac$eoi_message_enabled =
          file_attributes^[i].eoi_message_enabled := attributes^[i].eoi_message_enabled;
        = nac$eoi_peer_termination =
          file_attributes^[i].eoi_peer_termination := attributes^[i].eoi_peer_termination;
        = nac$null_attribute =
            ;
        = nac$receive_wait_swapout =
          file_attributes^[i].receive_wait_swapout := attributes^[i].receive_wait_swapout;
        = nac$termination_data =
          file_attributes^[i].termination_data := attributes^[i].termination_data;
        ELSE
        CASEND;
      FOREND;
    ELSE
      file_attributes := NIL;
    IFEND;

    nlp$accept_switch_offer (file, source, file_attributes, FALSE, status);
    IF (NOT status.normal) AND (status.condition = nae$no_switch_offered) AND (wait_time > 0) THEN
      activity_list [1].activity := nac$i_await_switch_offer;
      activity_list [1].source := source;
      activity_list [2].activity := osc$i_await_time;
      activity_list [2].milliseconds := wait_time;
      osp$i_await_activity_completion (activity_list, ready_index, status);
      IF status.normal THEN
        nlp$accept_switch_offer (file, source, file_attributes, FALSE, status);
      IFEND;
    IFEND;

  PROCEND nap$accept_switch_offer;
?? TITLE := 'NAP$ACQUIRE_CONNECTION', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$acquire_connection (server: nat$application_name;
        file: fst$file_reference;
        attributes: ^nat$create_attributes;
        wait_time: nat$wait_time;
    VAR status: ost$status);

*copyc nah$acquire_connection

     CONST
       local_clock = 0;

     VAR
       activity_list: array [1 .. 2] of ost$i_activity,
       last_time: integer,
       now: integer,
       ready_index: integer,
       time: integer;

    status.normal := TRUE;
    nlp$acquire_connection (server, file, {file_exists:=} FALSE, attributes, status);
    IF NOT status.normal THEN
      activity_list [1].activity := nac$i_await_connection;
      activity_list [1].server := server;
      activity_list [2].activity := osc$i_await_time;
      activity_list [2].milliseconds := wait_time;
      time := wait_time;
      last_time := #FREE_RUNNING_CLOCK (local_clock);
      WHILE (NOT status.normal) AND (status.condition = nae$no_connection_available) AND (time > 0) DO
        activity_list [2].milliseconds := time;
        osp$i_await_activity_completion (activity_list, ready_index, status);
        IF status.normal AND (ready_index = 1) THEN
          nlp$acquire_connection (server, file, {file_exists:=} FALSE, attributes, status);
          IF NOT status.normal THEN
            now := #FREE_RUNNING_CLOCK (local_clock);
            time := time - ((now - last_time) DIV 1000);
            last_time := now;
          IFEND;
        ELSEIF status.normal AND (ready_index = 2) THEN
          time := 0;
          osp$set_status_condition ( nae$no_connection_available,  status);
        IFEND;
      WHILEND;
    IFEND;

  PROCEND nap$acquire_connection;
?? TITLE := '[XDCL, #GATE] nap$acquire_specific_connection', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$acquire_specific_connection
   (    system_job_name: jmt$system_supplied_name;
        server: nat$application_name;
        file: fst$file_reference;
        attributes: ^nat$create_attributes;
        wait_time: nat$wait_time;
    VAR status: ost$status);

     CONST
       local_clock = 0;

     VAR
       activity_list: array [1 .. 2] of ost$i_activity,
       last_time: integer,
       now: integer,
       ready_index: integer,
       time: integer;

    status.normal := TRUE;
    nlp$acquire_specific_connection (system_job_name, server, file, {file_exists} FALSE, attributes, status);
    IF NOT status.normal THEN
      activity_list [1].activity := nac$i_await_connection;
      activity_list [1].server := server;
      activity_list [2].activity := osc$i_await_time;
      activity_list [2].milliseconds := wait_time;
      time := wait_time;
      last_time := #FREE_RUNNING_CLOCK (local_clock);
      WHILE (NOT status.normal) AND (status.condition = nae$no_connection_available) AND (time > 0) DO
        activity_list [2].milliseconds := time;
        osp$i_await_activity_completion (activity_list, ready_index, status);
        IF status.normal AND (ready_index = 1) THEN
          nlp$acquire_specific_connection (system_job_name, server, file, {file_exists} FALSE, attributes,
                status);
          IF NOT status.normal THEN
            now := #FREE_RUNNING_CLOCK (local_clock);
            time := time - ((now - last_time) DIV 1000);
            last_time := now;
          IFEND;
        ELSEIF status.normal AND (ready_index = 2) THEN
          time := 0;
          osp$set_status_condition (nae$no_connection_available, status);
        IFEND;
      WHILEND;
    IFEND;

  PROCEND nap$acquire_specific_connection;
?? TITLE := 'NAP$CLONE_CONNECTION', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$clone_connection (server: nat$application_name;
        file: fst$file_reference;
        attributes: ^nat$create_attributes;
        wait_time: nat$wait_time;
    VAR status: ost$status);

*copyc nah$acquire_connection

     CONST
       local_clock = 0;

     VAR
       activity_list: array [1 .. 2] of ost$i_activity,
       last_time: integer,
       now: integer,
       ready_index: integer,
       time: integer;

    status.normal := TRUE;
    nlp$acquire_connection (server, file, {file_exists:=} TRUE, attributes, status);
    IF NOT status.normal THEN
      activity_list [1].activity := nac$i_await_connection;
      activity_list [1].server := server;
      activity_list [2].activity := osc$i_await_time;
      activity_list [2].milliseconds := wait_time;
      time := wait_time;
      last_time := #FREE_RUNNING_CLOCK (local_clock);
      WHILE (NOT status.normal) AND (status.condition = nae$no_connection_available) AND (time > 0) DO
        activity_list [2].milliseconds := time;
        osp$i_await_activity_completion (activity_list, ready_index, status);
        IF status.normal AND (ready_index = 1) THEN
          nlp$acquire_connection (server, file, {file_exists:=} TRUE, attributes, status);
          IF NOT status.normal THEN
            now := #FREE_RUNNING_CLOCK (local_clock);
            time := time - ((now - last_time) DIV 1000);
            last_time := now;
          IFEND;
        ELSEIF status.normal AND (ready_index = 2) THEN
          time := 0;
          osp$set_status_condition ( nae$no_connection_available,  status);
        IFEND;
      WHILEND;
    IFEND;

  PROCEND nap$clone_connection;
?? TITLE := 'NAP$AWAIT_SERVER_RESPONSE', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$await_server_response (file: fst$file_reference;
        wait_time: nat$wait_time;
    VAR status: ost$status);

*copyc nah$await_server_response

    VAR
      activity_list: array [1 .. 2] of ost$i_activity,
      local_file: ^fst$file_reference,
      ready_index: integer;

    status.normal := TRUE;
    PUSH local_file: [#SIZE (file)];
    local_file^ := file;

    IF wait_time > 0 THEN
      activity_list [1].activity := nac$i_await_server_response;
      activity_list [1].file := local_file;
      activity_list [2].activity := osc$i_await_time;
      activity_list [2].milliseconds := wait_time;
      osp$i_await_activity_completion (activity_list, ready_index, status);
      IF (status.normal) AND (ready_index = 2) THEN
{ The task waited for the specified time but the server did not respond.
        osp$set_status_abnormal (nac$status_id, nae$no_server_response, local_file^, status);
      IFEND;
    IFEND;

  PROCEND nap$await_server_response;
?? TITLE := 'NAP$GET_TITLE_TRANSLATION', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$get_title_translation (
         search_identifier: nat$directory_search_identifier;
         wait_time: nat$wait_time;
     VAR attributes {input, output} : ^nat$translation_attributes;
     VAR network_address: nat$network_address;
     VAR status: ost$status);

*copyc nah$get_title_translation

    VAR
      activity_list: array [1 .. 2] of ost$i_activity,
      address: nat$osi_translation_address,
      current_time: integer,
      end_time: integer,
      i: integer,
      identifier: nat$directory_entry_identifier,
      ignore_status: ost$status,
      priority: nat$directory_priority,
      ready_index: integer,
      request_complete: boolean,
      service: nat$protocol,
      title: string (nac$max_title_length),
      title_length: nat$title_length,
      user_identifier: ost$name,
      user_info: SEQ (REP nac$max_directory_data_length OF cell),
      user_info_length: nat$directory_data_length;

    status.normal := TRUE;
    IF attributes <> NIL THEN
      FOR i := LOWERBOUND (attributes^) TO UPPERBOUND (attributes^) DO
        CASE attributes^ [i].selector OF
        = nac$translation_title, nac$translation_priority, nac$translation_data, nac$translation_protocol =
          ;
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$invalid_selector, get_title_translation, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, attributes_parameter, status);
          osp$append_status_integer (osc$status_parameter_delimiter, i, 10, FALSE, status);
          RETURN;
        CASEND;
      FOREND;
    IFEND;

    request_complete := FALSE;
    pmp$get_microsecond_clock (current_time, ignore_status);
    end_time := current_time + (wait_time * 1000);
    activity_list [1].activity := nac$i_await_title_translation;
    activity_list [1].translation_request := search_identifier;
    activity_list [2].activity := osc$i_await_time;

  /get_translation/
    WHILE status.normal AND NOT request_complete DO
      pmp$get_microsecond_clock (current_time, ignore_status);
      IF end_time > current_time THEN {wait for a translation}
        activity_list [2].milliseconds := (end_time - current_time) DIV 1000;
        osp$i_await_activity_completion (activity_list, ready_index, status);
      ELSE {no wait ... look for a translation immediately}
        ready_index := 1;
      IFEND;
      IF status.normal THEN
        IF ready_index = 1 THEN
          nlp$get_title_translation (search_identifier, title, address, service, ^user_info, user_info_length,
                priority, user_identifier, identifier, status);
          IF status.normal THEN
            network_address.kind := address.kind;
            CASE address.kind OF
            = nac$osi_transport_address =
              network_address.osi_transport_address := address.osi_transport_address;
            = nac$osi_session_address, nac$osi_non_cdna_session_addr =
              network_address.osi_session_address := address.osi_session_address;
            = nac$osi_presentation_address, nac$osi_non_cdna_present_addr =
              network_address.osi_presentation_address := address.osi_presentation_address;
            ELSE {reject this translation and try for another}
              CYCLE /get_translation/;
            CASEND;
            IF attributes <> NIL THEN
              FOR i := LOWERBOUND (attributes^) TO UPPERBOUND (attributes^) DO
                CASE attributes^ [i].selector OF
                = nac$translation_title =
                  attributes^ [i].title^ := title;
                  title_length := #SIZE (title);
                  WHILE (title_length > 1) AND (title (title_length) = ' ') DO
                    title_length := title_length - 1;
                  WHILEND;
                  attributes^ [i].title_length := title_length;

                = nac$translation_priority =
                  attributes^ [i].priority := priority;

                = nac$translation_data =
                  attributes^ [i].data^ := user_info;
                  attributes^ [i].data_length := user_info_length;

                = nac$translation_protocol =
                  attributes^ [i].protocol := service;

                CASEND;
              FOREND;
            IFEND;
            request_complete := TRUE;
          ELSEIF status.condition = nae$wait_for_distributed_title THEN
            osp$set_status_condition ( nae$no_translation_available,  status);
          ELSEIF status.condition = nae$translation_req_not_active THEN
            osp$set_status_abnormal (nac$status_id, nae$invalid_directory_search_id, get_title_translation,
                  status);
          IFEND;
        ELSEIF ready_index = 2 THEN { The task waited for the specified time and the server did not respond.
          osp$set_status_condition ( nae$no_translation_available,  status);
        IFEND;
      IFEND;
    WHILEND /get_translation/;

  PROCEND nap$get_title_translation;
?? TITLE := 'NAP$OFFER_CONNECTION_SWITCH', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$offer_connection_switch (file: fst$file_reference;
        destination: jmt$system_supplied_name;
        wait_time: nat$wait_time;
    VAR status: ost$status);

*copyc nah$offer_connection_switch

    VAR
      activity_list: array [1 .. 2] of ost$i_activity,
      local_file: ^fst$file_reference,
      ready_index: integer;

    status.normal := TRUE;
    PUSH local_file: [#SIZE (file)];
    local_file^ := file;

    nlp$offer_connection_switch (local_file^, destination, FALSE, status);
    IF (status.normal) AND (wait_time > 0) THEN
      activity_list [1].activity := nac$i_await_switch_accept;
      activity_list [1].file := local_file;
      activity_list [2].activity := osc$i_await_time;
      activity_list [2].milliseconds := wait_time;
      osp$i_await_activity_completion (activity_list, ready_index, status);
      IF ready_index = 2 THEN
{ The task waited for the specified time and the switch offer was not accepted.
        osp$set_status_abnormal (nac$status_id, nae$switch_offer_not_accepted, local_file^, status);
      IFEND;
    IFEND;

  PROCEND nap$offer_connection_switch;
?? TITLE := 'NAP$REQUEST_CONNECTION', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$request_connection (server: nat$network_address;
        client: nat$application_name;
        file: fst$file_reference;
        protocol: nat$protocol;
        attributes: ^nat$create_attributes;
        wait_time: nat$wait_time;
    VAR status: ost$status);

*copyc nah$request_connection

    VAR
      activity_list: array [1 .. 2] of ost$i_activity,
      connection_attributes: array [1 .. 1] of nat$get_attribute,
      ignore_status: ost$status,
      local_file: ^fst$file_reference,
      ready_index: integer;

    status.normal := TRUE;
    PUSH local_file: [#SIZE (file)];
    local_file^ := file;

    nlp$request_connection (server, client, local_file^, protocol, attributes, status);
    IF (status.normal) AND (wait_time > 0) THEN
      activity_list [1].activity := nac$i_await_server_response;
      activity_list [1].file := local_file;
      activity_list [2].activity := osc$i_await_time;
      activity_list [2].milliseconds := wait_time;
      osp$i_await_activity_completion (activity_list, ready_index, status);
      IF (NOT status.normal) OR (ready_index = 2) THEN
        amp$return (local_file^, ignore_status);
      IFEND;

      IF ready_index = 2 THEN
{ The task waited for the specified time and the server did not respond.
        osp$set_status_abnormal (nac$status_id, nae$server_response_timeout, local_file^, status);
      IFEND;

      IF status.normal THEN
        connection_attributes [1].kind := nac$connection_state;
        nap$get_attributes (local_file^, connection_attributes, ignore_status);
        IF ignore_status.normal THEN
          CASE connection_attributes [1].connection_state OF
          = nac$connection_request_sent =
           { Should have timed out. }
          = nac$connection_request_received =
           { Should never end up here. }
            nap$namve_system_error (FALSE, 'Invalid response on request connection.', NIL);
          = nac$established =
           { Request complete. }
          = nac$terminated =
            amp$return (local_file^, ignore_status);
            osp$set_status_condition ( nae$connection_terminated,  status);
          ELSE
          CASEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND nap$request_connection;
MODEND nam$external_connection_mgmt;
*DECK DECK=NAM$EXTERNAL_GT_INTERFACE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE NETWORK ACCESS : Generic Transport Application Layer' ??
MODULE nam$external_gt_interface;
?? NEWTITLE := 'Global Declarations Referenced by This Module' ??
?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nat$gt_connection
*copyc nat$gt_connection_options
*copyc nat$gt_destination_address
*copyc nat$gt_event
*copyc nat$gt_interface
*copyc nat$gt_job_connection
*copyc nat$gt_job_sap
*copyc nat$gt_sap
*copyc nat$gt_sap_identifier
*copyc nat$gt_wait_list
*copyc nat$internet_address
*copyc nat$maximum_active_connections
*copyc nat$network_address
*copyc nat$network_message_priority
*copyc nat$ta_alternate_protocol_class
*copyc nat$ta_preferred_protocol_class
*copyc nlt$ta_event
*copyc nlt$ta_sap_selector
*copyc oss$network_paged
*copyc oss$job_paged_literal
*copyc ost$activity_status
*copyc ost$wait
?? POP ??
*copyc osp$append_status_parameter
*copyc nap$gt_add_job_sap
*copyc nap$gt_clear_exclusive_to_clist
*copyc nap$gt_clear_exclusive_to_slist
*copyc nap$gt_create_job_connection
*copyc nap$gt_deactivate_job_connect
*copyc nap$gt_delete_job_connection
*copyc nap$gt_delete_job_sap
*copyc nap$gt_get_exclusive_to_clist
*copyc nap$gt_get_exclusive_to_slist
*copyc nap$gt_releas_exclusiv_to_clist
*copyc nap$gt_releas_exclusiv_to_slist
*copyc nlp$al_deliver_data
*copyc nlp$al_fragment_data
*copyc nlp$al_get_data_length
*copyc nlp$al_get_data_requirements
*copyc nlp$al_initialize_data_descrip
*copyc nlp$bm_concatenate_messages
*copyc nlp$bm_copy_message
*copyc nlp$bm_create_message
*copyc nlp$bm_get_message_length
*copyc nlp$bm_get_message_resources
*copyc nlp$bm_release_message
*copyc nlp$cancel_timer
*copyc nlp$cl_activate_layer
*copyc nlp$cl_activate_receiver
*copyc nlp$cl_activate_sender
*copyc nlp$cl_clear_exclusive_access
*copyc nlp$cl_create_connection
*copyc nlp$cl_deactivate_layer
*copyc nlp$cl_deactivate_receiver
*copyc nlp$cl_deactivate_sender
*copyc nlp$cl_get_connection_processor
*copyc nlp$cl_get_exclusive_via_cid
*copyc nlp$cl_get_layer_connection
*copyc nlp$cl_get_sap_processor
*copyc nlp$cl_initialize_template
*copyc nlp$cl_release_exclusive_access
*copyc nlp$osi_get_outbound_capacity
*copyc nlp$select_timer
*copyc nlp$ta_accept_connection
*copyc nlp$ta_close_sap
*copyc nlp$ta_disconnect_connection
*copyc nlp$ta_initialize
*copyc nlp$ta_open_sap
*copyc nlp$ta_report_undelivered_data
*copyc nlp$ta_request_connection
*copyc nlp$ta_send_data
*copyc nlp$ta_send_expedited_data
*copyc nlp$timer_expired
*copyc osp$append_status_integer
*copyc osp$begin_subsystem_activity
*copyc osp$clear_job_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$end_subsystem_activity
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$push_inhibit_job_recovery
*copyc osp$pop_inhibit_job_recovery
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$test_sig_lock
*copyc pmp$continue_to_cause
*copyc pmp$get_executing_task_gtid
*copyc pmp$send_signal
*copyc pmp$wait
*copyc syp$cycle
*copyc nav$network_paged_heap
*copyc nav$namve_active
*copyc nav$gt_assigned_sap_list
*copyc nav$gt_sap_list
*copyc nav$gt_job_sap_list
*copyc nav$gt_job_connection_list
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    nac$gt_accept_timer_duration = (5 * 60 * 1000 * 1000), { microseconds }
    nac$gt_event_timer_duration = (8 * 60 * 1000 * 1000), { microseconds }
    nac$gt_maximum_connect_data = 32,
    nac$gt_maximum_accept_data = 32,
    nac$gt_maximum_expedited_data = 16,
    nac$gt_maximum_disconnect_data = 64,
    nac$gt_sap_event_timer_duration = (5 * 60 * 1000 * 1000); { microseconds }

  TYPE
    nat$gt_condition_cause = (nac$gt_application_data, nac$gt_application_event, nac$gt_activity_status,
          nac$gt_request_not_cause, nac$gt_task_termination);


  VAR
    nav$gt_null_sap: [STATIC, READ, oss$job_paged_literal] nat$gt_sap :=
          [ * , NIL, NIL, [FALSE], [FALSE, * , NIL, NIL, [nac$gt_fixed,
          [0, 0, [REP nac$gt_fixed_fragments of [NIL, 0]]]]], [NIL, NIL], FALSE],

    nav$gt_null_connect_rq_receiver: [STATIC, READ, oss$job_paged_literal]
          nat$gt_connect_request_receiver := [FALSE, * , NIL, NIL,
          [nac$gt_fixed, [0, 0, [REP nac$gt_fixed_fragments of [NIL, 0]]]]],

    nav$gt_null_connection: [STATIC, READ, oss$job_paged_literal] nat$gt_connection :=
          [nac$gt_closed, * , * , 0, [FALSE], [NIL, NIL], [NIL, FALSE, 0,
          [nac$gt_fixed, [0, 0, [REP nac$gt_fixed_fragments of [NIL, 0]]]]],
          [NIL, NIL, 0, FALSE, 0, [nac$gt_fixed, [0, 0, [REP nac$gt_fixed_fragments of [NIL, 0]]]]]],

    nav$gt_null_sender_request: [STATIC, READ, oss$job_paged_literal] nat$gt_sender_request :=
          [NIL, FALSE, 0, [nac$gt_fixed, [0, 0, [REP nac$gt_fixed_fragments of [NIL, 0]]]]],

    nav$gt_null_receiver_request: [STATIC, READ, oss$job_paged_literal] nat$gt_receiver_request :=
          [NIL, NIL, 0, FALSE, 0, [nac$gt_fixed, [0, 0, [REP nac$gt_fixed_fragments of [NIL, 0]]]]],

    nav$gt_null_message: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 1] of nat$data_fragment := [[NIL, 0]],

    external_interface: [STATIC, READ, oss$job_paged_literal] string (36) :=
          'GENERIC TRANSPORT EXTERNAL INTERFACE';

?? OLDTITLE ??
?? NEWTITLE := 'assign_sap_identifier', EJECT ??

  PROCEDURE assign_sap_identifier
    (    reserved_sap: boolean;
         selector: nlt$ta_sap_selector;
         shared_sap: boolean;
     VAR sap_identifier: nlt$ta_sap_selector;
     VAR status: ost$status);

    VAR
      i: integer;

    status.normal := TRUE;
    osp$set_job_signature_lock (nav$gt_assigned_sap_list.lock);
    IF reserved_sap THEN
      IF ((selector >= nlc$ta_min_rsvd_transport_sap) AND (selector <= nlc$ta_max_rsvd_transport_sap)) OR
         ((selector >= nlc$ta_mhs_min_transport_sap)  AND (selector <= nlc$ta_mhs_max_transport_sap))  OR
         ((selector >= nlc$ta_ftam_min_transport_sap) AND (selector <= nlc$ta_ftam_max_transport_sap)) OR
         ((selector >= nlc$ta_low_min_osi_sap) AND (selector <= nlc$ta_low_max_osi_sap)) THEN
        IF nav$gt_assigned_sap_list.sap [selector] = nac$gt_unassigned THEN
          nav$gt_assigned_sap_list.sap [selector] := nac$gt_assigned;
          sap_identifier := selector;
        ELSEIF shared_sap THEN
          /search_for_a_free_sap/
          BEGIN
            FOR i := nlc$ta_min_transport_sap TO UPPERBOUND (nav$gt_assigned_sap_list.sap) DO
              IF nav$gt_assigned_sap_list.sap [i] = nac$gt_unassigned THEN
                nav$gt_assigned_sap_list.sap [i] := nac$gt_assigned;
                sap_identifier := i;
                EXIT /search_for_a_free_sap/;
              IFEND;
            FOREND;
            osp$set_status_condition ( nae$maximum_saps_open,  status);
          END /search_for_a_free_sap/;
        ELSE
          osp$set_status_condition ( nae$sap_already_open,  status);
          osp$append_status_integer (osc$status_parameter_delimiter, selector, 10, TRUE, status);
        IFEND;
      ELSE { invalid reserved sap identifier
        osp$set_status_condition ( nae$invalid_reserved_sap,  status);
      IFEND;
    ELSE { non reserved sap

    /search_for_available_sap/
      BEGIN
        FOR i := nlc$ta_min_transport_sap TO UPPERBOUND (nav$gt_assigned_sap_list.sap) DO
          IF nav$gt_assigned_sap_list.sap [i] = nac$gt_unassigned THEN
            nav$gt_assigned_sap_list.sap [i] := nac$gt_assigned;
            sap_identifier := i;
            EXIT /search_for_available_sap/;
          IFEND;
        FOREND;
        osp$set_status_condition ( nae$maximum_saps_open,  status);
      END /search_for_available_sap/;
    IFEND;
    osp$clear_job_signature_lock (nav$gt_assigned_sap_list.lock);
  PROCEND assign_sap_identifier;
?? OLDTITLE ??
?? NEWTITLE := 'unassign_sap_identifier', EJECT ??

  PROCEDURE unassign_sap_identifier
    (    sap_identifier: nlt$ta_sap_selector);

    osp$set_job_signature_lock (nav$gt_assigned_sap_list.lock);
    IF (sap_identifier >= LOWERBOUND (nav$gt_assigned_sap_list.sap)) AND
          (sap_identifier <= UPPERBOUND (nav$gt_assigned_sap_list.sap)) THEN
      nav$gt_assigned_sap_list.sap [sap_identifier] := nac$gt_unassigned;
    IFEND;
    osp$clear_job_signature_lock (nav$gt_assigned_sap_list.lock);
  PROCEND unassign_sap_identifier;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$gt_accept_connection', EJECT ??
*copy nah$gt_accept_connection

  PROCEDURE [XDCL, #GATE] nap$gt_accept_connection
    (    connection_id: nat$gt_connection_id,
         data: nat$data_fragments;
         options: ^nat$gt_connection_options;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection;

?? NEWTITLE := 'terminate_accept_connection', EJECT ??

    PROCEDURE terminate_accept_connection
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        nlp$cl_clear_exclusive_access (cl_connection);
        osp$pop_inhibit_job_recovery;
        osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
        EXIT nap$gt_accept_connection;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_accept_connection;
?? OLDTITLE, EJECT ??

    VAR
      checksum: boolean,
      connection: ^nat$gt_connection,
      data_length: nat$data_length,
      expedited_data: boolean,
      message_id: nlt$bm_message_id,
      i: integer,
      internal_status: ost$status;

    status.normal := TRUE;

    IF UPPERBOUND (data) > nac$max_data_fragment_count THEN
      osp$set_status_condition (nae$maximum_data_fragments, status);
      RETURN;
    IFEND;

    nlp$al_get_data_length (data, data_length);
    IF data_length <= nac$gt_maximum_accept_data THEN
      osp$push_inhibit_job_recovery;
      get_connection_access (connection_id, cl_connection, connection, internal_status);
      IF internal_status.normal THEN
        IF connection^.state = nac$gt_connect_req_delivered THEN
          nlp$cancel_timer (connection^.timer);
          osp$establish_condition_handler (^terminate_accept_connection, FALSE);
          nlp$bm_create_message (data, message_id, internal_status);
          osp$disestablish_cond_handler;
          checksum := FALSE;
          expedited_data := FALSE;
          IF options <> NIL THEN
            FOR i := LOWERBOUND (options^) TO UPPERBOUND (options^) DO
              CASE options^ [i].kind OF
              = nac$gt_checksum =
                checksum := options^ [i].checksum;
              = nac$gt_expedited_data =
                expedited_data := options^ [i].expedited_data;
              ELSE
              CASEND;
            FOREND;
          IFEND;
          nap$gt_get_exclusive_to_slist;
          nlp$ta_accept_connection (cl_connection, checksum, message_id, expedited_data,
                sap_priority (connection^.sap_id), {quality_of_service = } NIL, internal_status);
          nap$gt_releas_exclusiv_to_slist;
          IF internal_status.normal THEN
            connection^.state := nac$gt_open;
          IFEND;
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$connection_not_proposed, external_interface,
                internal_status);
        IFEND;
        nlp$cl_release_exclusive_access (cl_connection);
        osp$pop_inhibit_job_recovery;
      IFEND;
      IF NOT internal_status.normal THEN
        osp$disestablish_cond_handler;
        status := internal_status;
      IFEND;
    ELSE
      osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, external_interface, status);
    IFEND;
  PROCEND nap$gt_accept_connection;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$gt_await_activity_complete', EJECT ??
*copy nah$gt_await_activity_complete

  PROCEDURE [XDCL, #GATE] nap$gt_await_activity_complete
    (    wait_list: nat$gt_wait_list;
     VAR ready_index: integer;
     VAR status: ost$status);

?? NEWTITLE := '[INLINE] get_sender_active', EJECT ??

    PROCEDURE [INLINE] get_sender_active
      (    connection_id: nat$gt_connection_id;
           processing_task: ost$global_task_id;
       VAR sender_active: boolean);

      VAR
        job_connection: ^nat$gt_job_connection,
        cl_connection: ^nlt$cl_connection,
        connection: ^nat$gt_connection,
        connection_exists: boolean;

      sender_active := FALSE;
      nap$gt_get_exclusive_to_clist;
      job_connection := nav$gt_job_connection_list.first_connection;
      WHILE (job_connection <> NIL) AND (job_connection^.connection_id <> connection_id) DO
        job_connection := job_connection^.next_connection;
      WHILEND;
      IF ((job_connection <> NIL) AND job_connection^.active) THEN
        nlp$cl_get_exclusive_via_cid (job_connection^.active_connection_id, connection_exists, cl_connection);
        IF connection_exists THEN
          sender_active := (cl_connection^.message_sender.active AND
                (processing_task = cl_connection^.message_sender.task));
          nlp$cl_release_exclusive_access (cl_connection);
        IFEND;
      IFEND;
      nap$gt_releas_exclusiv_to_clist;
    PROCEND get_sender_active;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_receiver_active', EJECT ??

    PROCEDURE [INLINE] get_receiver_active
      (    connection_id: nat$gt_connection_id;
           processing_task: ost$global_task_id;
       VAR receiver_active: boolean);

      VAR
        job_connection: ^nat$gt_job_connection,
        cl_connection: ^nlt$cl_connection,
        connection: ^nat$gt_connection,
        connection_exists: boolean;

      receiver_active := FALSE;
      nap$gt_get_exclusive_to_clist;
      job_connection := nav$gt_job_connection_list.first_connection;
      WHILE (job_connection <> NIL) AND (job_connection^.connection_id <> connection_id) DO
        job_connection := job_connection^.next_connection;
      WHILEND;
      IF ((job_connection <> NIL) AND job_connection^.active) THEN
        nlp$cl_get_exclusive_via_cid (job_connection^.active_connection_id, connection_exists, cl_connection);
        IF connection_exists THEN
          receiver_active := (cl_connection^.message_receiver.active AND
                (processing_task = cl_connection^.message_receiver.task));
          nlp$cl_release_exclusive_access (cl_connection);
        IFEND;
      IFEND;
      nap$gt_releas_exclusiv_to_clist;
    PROCEND get_receiver_active;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_sap_receiver_active', EJECT ??

    PROCEDURE [INLINE] get_sap_receiver_active
      (    sap_id: nat$gt_sap_identifier;
           processing_task: ost$global_task_id;
       VAR sap_receiver_active: boolean);

      VAR
        job_sap: ^nat$gt_job_sap,
        sap: ^nat$gt_sap;

      sap_receiver_active := FALSE;
      nap$gt_get_exclusive_to_slist;
      job_sap := nav$gt_job_sap_list.first_sap;
      WHILE (job_sap <> NIL) AND (job_sap^.sap_id.osi_sap_identifier <> sap_id.osi_sap_identifier) DO
        job_sap := job_sap^.next_sap;
      WHILEND;
      IF job_sap <> NIL THEN
        osp$begin_subsystem_activity;
        osp$set_job_signature_lock (nav$gt_sap_list.lock);
        sap := nav$gt_sap_list.first_sap;
        WHILE (sap <> NIL) AND (sap^.sap_id.osi_sap_identifier <> job_sap^.selector.osi_sap_identifier) DO
          sap := sap^.next_sap;
        WHILEND;
        IF sap <> NIL THEN
          sap_receiver_active := (sap^.connect_request_receiver.active AND
                (processing_task = sap^.connect_request_receiver.task));
        IFEND;
        osp$clear_job_signature_lock (nav$gt_sap_list.lock);
        osp$end_subsystem_activity;
      IFEND;
      nap$gt_releas_exclusiv_to_slist;
    PROCEND get_sap_receiver_active;
?? OLDTITLE, EJECT ??

    CONST
      local_clock = 0;

    VAR
      start_time,
      wait_time,
      current_time,
      elapsed_time: ost$free_running_clock,
      activity: integer,
      await_complete: boolean,
      time_specified: boolean,
      null_list: boolean,
      request_active: boolean,
      processing_task: ost$global_task_id;

    osp$push_inhibit_job_recovery;
    status.normal := TRUE;
    ready_index := 0;
    elapsed_time := 0;
    wait_time := UPPERVALUE (ost$free_running_clock);
    null_list := TRUE;
    time_specified := FALSE;
    pmp$get_executing_task_gtid (processing_task);
    REPEAT
      await_complete := FALSE;
      activity := 1;
      WHILE NOT await_complete AND (activity <= UPPERBOUND (wait_list)) DO
        CASE wait_list [activity].activity OF
        = nac$gt_null_activity =
          ;
        = nac$gt_await_time =
          time_specified := TRUE;
          null_list := FALSE;
          IF (elapsed_time >= (wait_list [activity].milliseconds * 1000)) THEN
            await_complete := TRUE;
          ELSEIF ((wait_list [activity].milliseconds * 1000) < wait_time) THEN
            wait_time := wait_list [activity].milliseconds * 1000;
          IFEND;
        = nac$gt_await_send_data =
          null_list := FALSE;
          get_sender_active (wait_list [activity].send_connection_id, processing_task, request_active);
          await_complete := NOT request_active;
        = nac$gt_await_receive_event =
          null_list := FALSE;
          get_receiver_active (wait_list [activity].send_connection_id, processing_task, request_active);
          await_complete := NOT request_active;
        = nac$gt_await_connect_request =
          null_list := FALSE;
          get_sap_receiver_active (wait_list [activity].sap_id, processing_task, request_active);
          await_complete := NOT request_active;
        ELSE
          await_complete := TRUE;
          osp$set_status_abnormal (nac$status_id, nae$incorrect_activity, external_interface, status);
        CASEND;
        IF NOT await_complete THEN
          activity := activity + 1;
        IFEND;
      WHILEND;

      IF await_complete THEN
        ready_index := activity;
      ELSEIF null_list THEN
        ready_index := 1;
        await_complete := TRUE;
      ELSE
        IF time_specified THEN
          IF ((wait_time - elapsed_time) > 0) THEN
            start_time := #FREE_RUNNING_CLOCK (local_clock);
            pmp$wait ((wait_time - elapsed_time) DIV 1000, (wait_time - elapsed_time) DIV 1000);
            current_time := #FREE_RUNNING_CLOCK (local_clock);
            IF current_time > start_time THEN
              elapsed_time := elapsed_time + (current_time - start_time);
            IFEND;
          IFEND;
        ELSE
          pmp$wait (100000000(16), 100000000(16));
        IFEND;
      IFEND;
    UNTIL await_complete;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$gt_await_activity_complete;
?? OLDTITLE ??
?? NEWTITLE := 'reject_connection', EJECT ??

  PROCEDURE reject_connection
    (    cl_connection_id: nlt$cl_connection_id;
     VAR reject_message {INPUT, OUTPUT} : nlt$bm_message_id);

    VAR
      connection: ^nat$gt_connection,
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      ignore_status: ost$status,
      layer_active: boolean;

    nlp$cl_get_exclusive_via_cid (cl_connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        nlp$ta_disconnect_connection (cl_connection, reject_message, ignore_status);
        connection^.state := nac$gt_closed;
        nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    IFEND;
  PROCEND reject_connection;
?? OLDTITLE ??
?? NEWTITLE := 'close_sap' ??
?? NEWTITLE := 'close_connection', EJECT ??

  PROCEDURE close_sap
    (    sap: ^nat$gt_sap;
         sap_id: nat$gt_sap_identifier;
         server_sap: boolean);


    PROCEDURE close_connection
      (    connection_id: nat$gt_connection_id);

      VAR
        cl_connection: ^nlt$cl_connection,
        cl_connection_id: nlt$cl_connection_id,
        connection: ^nat$gt_connection,
        connection_to_delete: ^^nat$gt_job_connection,
        connection_exists: boolean,
        empty_message: nlt$bm_message_id,
        ignore_status: ost$status,
        layer_active: boolean;

      nap$gt_get_exclusive_to_clist;
      connection_to_delete := ^nav$gt_job_connection_list.first_connection;
      WHILE (connection_to_delete^ <> NIL) AND (connection_to_delete^^.connection_id <> connection_id) DO
        connection_to_delete := ^connection_to_delete^^.next_connection;
      WHILEND;
      IF (connection_to_delete^ <> NIL) AND connection_to_delete^^.active THEN
        cl_connection_id := connection_to_delete^^.active_connection_id;
        nap$gt_delete_job_connection (connection_id);
        nap$gt_releas_exclusiv_to_clist;
        nlp$cl_get_exclusive_via_cid (cl_connection_id, connection_exists, cl_connection);
        IF connection_exists THEN
          IF cl_connection^.message_sender.active THEN
            nlp$cl_deactivate_sender (cl_connection);
          IFEND;
          IF cl_connection^.message_receiver.active THEN
            nlp$cl_deactivate_receiver (cl_connection);
          IFEND;
          nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active,
                connection);
          IF layer_active THEN
            delete_queued_events (connection);
            nlp$bm_create_message (nav$gt_null_message, empty_message, ignore_status);
            nlp$ta_disconnect_connection (cl_connection, empty_message, ignore_status);
            connection^.state := nac$gt_closed;
            nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
          IFEND;
          nlp$cl_release_exclusive_access (cl_connection);
        IFEND;
      ELSEIF connection_to_delete^ <> NIL THEN
        nap$gt_delete_job_connection (connection_id);
        nap$gt_releas_exclusiv_to_clist;
      ELSE
        nap$gt_releas_exclusiv_to_clist;
      IFEND;
    PROCEND close_connection;
?? OLDTITLE, EJECT ??

    VAR
      connection: ^nat$gt_sap_connection,
      connect_request: ^nat$gt_connect_request,
      ignore_status: ost$status,
      link: ^^nat$gt_sap_connection;

    link := ^sap^.first_connection;
    WHILE link^ <> NIL DO
      IF sap_id.osi_sap_identifier = link^^.sap_id.osi_sap_identifier THEN
        connection := link^;
        link^ := connection^.next_connection;
        close_connection (connection^.connection_id);
        FREE connection IN nav$network_paged_heap^;
      ELSE
        link := ^link^^.next_connection;
      IFEND;
    WHILEND;

    IF server_sap THEN
      WHILE sap^.connect_request_queue.beginning <> NIL DO
        connect_request := sap^.connect_request_queue.beginning;
        sap^.connect_request_queue.beginning := connect_request^.next_connect_request;
        reject_connection (connect_request^.connection_id, connect_request^.data);
        FREE connect_request IN nav$network_paged_heap^;
      WHILEND;
    IFEND;
    nlp$ta_close_sap (sap^.sap_id.osi_sap_identifier, ignore_status);
  PROCEND close_sap;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$gt_close_sap', EJECT ??
*copy nah$gt_close_sap

  PROCEDURE [XDCL, #GATE] nap$gt_close_sap
    (    sap_id: nat$gt_sap_identifier;
     VAR status: ost$status);

    VAR
      sap_to_delete: ^nat$gt_job_sap,
      active_sap: ^^nat$gt_sap,
      sap_to_close: ^nat$gt_sap,
      sap_found: boolean,
      selector: nat$gt_sap_identifier,
      server_sap: boolean,
      internal_status: ost$status;

    status.normal := TRUE;
    osp$push_inhibit_job_recovery;
    nap$gt_get_exclusive_to_slist;
    get_sap_to_delete (sap_id, sap_to_delete, internal_status);
    IF internal_status.normal THEN
      server_sap := sap_to_delete^.shared_sap_server;
      selector := sap_to_delete^.selector;
      nap$gt_delete_job_sap (sap_id);
      nap$gt_releas_exclusiv_to_slist;
      FREE sap_to_delete IN nav$network_paged_heap^;
      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (nav$gt_sap_list.lock);
      unassign_sap_identifier (sap_id.osi_sap_identifier);
      find_active_sap (selector, active_sap, sap_found);
      IF sap_found THEN
        IF (server_sap) AND (active_sap^^.connect_request_receiver.active) THEN
          active_sap^^.connect_request_receiver.active := FALSE;
        IFEND;
        IF (NOT active_sap^^.opened_via_share) OR (active_sap^^.shared_sap_count <= 1) THEN
          sap_to_close := active_sap^;
          active_sap^ := active_sap^^.next_sap;
          close_sap (sap_to_close, sap_id, server_sap);
          FREE sap_to_close IN nav$network_paged_heap^;
        ELSE
          active_sap^^.shared_sap_count := active_sap^^.shared_sap_count - 1;
          close_sap (active_sap^, sap_id, server_sap);
          IF server_sap THEN
            active_sap^^.shared_sap_server_active := FALSE;
          IFEND;
        IFEND;
      IFEND;
      osp$clear_job_signature_lock (nav$gt_sap_list.lock);
      osp$end_subsystem_activity;
    ELSE
      nap$gt_releas_exclusiv_to_slist;
    IFEND;
    osp$pop_inhibit_job_recovery;
    IF NOT internal_status.normal THEN
      status := internal_status;
    IFEND;
  PROCEND nap$gt_close_sap;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$gt_process_job_termination', EJECT ??

{
{    The purpose of this procedure is to release all sap and connections
{ in the current job.
{

  PROCEDURE [XDCL] nap$gt_process_job_termination;

    VAR
      active_sap: ^^nat$gt_sap,
      sap_to_close: ^nat$gt_sap,
      sap_to_delete: ^nat$gt_job_sap,
      sap_found: boolean,
      sap_id: nat$gt_sap_identifier,
      selector: nat$gt_sap_identifier,
      server_sap: boolean;

    osp$push_inhibit_job_recovery;
    nap$gt_get_exclusive_to_slist;
    WHILE nav$gt_job_sap_list.first_sap <> NIL DO
      sap_to_delete := nav$gt_job_sap_list.first_sap;
      server_sap := sap_to_delete^.shared_sap_server;
      selector := sap_to_delete^.selector;
      sap_id := sap_to_delete^.sap_id;
      nap$gt_delete_job_sap (sap_to_delete^.sap_id);
      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (nav$gt_sap_list.lock);
      unassign_sap_identifier (sap_id.osi_sap_identifier);
      find_active_sap (selector, active_sap, sap_found);
      IF sap_found THEN
        IF (server_sap) AND (active_sap^^.connect_request_receiver.active) THEN
          active_sap^^.connect_request_receiver.active := FALSE;
        IFEND;
        sap_to_close := active_sap^;
        IF (NOT sap_to_close^.opened_via_share) OR (sap_to_close^.shared_sap_count <= 1) THEN
          active_sap^ := sap_to_close^.next_sap;
          close_sap (sap_to_close, sap_id, server_sap);
          FREE sap_to_close IN nav$network_paged_heap^;
        ELSE
          sap_to_close^.shared_sap_count := sap_to_close^.shared_sap_count - 1;
          close_sap (active_sap^, sap_id, server_sap);
          IF server_sap THEN
            active_sap^^.shared_sap_server_active := FALSE;
          IFEND;
        IFEND;
      IFEND;
      osp$clear_job_signature_lock (nav$gt_sap_list.lock);
      osp$end_subsystem_activity;
      FREE sap_to_delete IN nav$network_paged_heap^;
    WHILEND;
    nap$gt_releas_exclusiv_to_slist;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$gt_process_job_termination;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$gt_disconnect', EJECT ??
*copy nah$gt_disconnect

  PROCEDURE [XDCL, #GATE] nap$gt_disconnect
    (    connection_id: nat$gt_connection_id,
         data: nat$data_fragments;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection;

?? NEWTITLE := 'terminate_disconnect', EJECT ??

    PROCEDURE terminate_disconnect
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        nlp$cl_clear_exclusive_access (cl_connection);
        osp$pop_inhibit_job_recovery;
        osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
        EXIT nap$gt_disconnect;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_disconnect;
?? OLDTITLE, EJECT ??

    VAR
      connection: ^nat$gt_connection,
      connection_to_delete: ^nat$gt_job_connection,
      data_length: nat$data_length,
      message_id: nlt$bm_message_id,
      internal_status: ost$status;

    status.normal := TRUE;

    IF UPPERBOUND (data) > nac$max_data_fragment_count THEN
      osp$set_status_condition (nae$maximum_data_fragments, status);
      RETURN;
    IFEND;

    nlp$al_get_data_length (data, data_length);
    IF data_length <= nac$gt_maximum_disconnect_data THEN
      osp$push_inhibit_job_recovery;
      nap$gt_get_exclusive_to_clist;
      get_connection_to_delete (connection_id, connection_to_delete, cl_connection, connection,
            internal_status);
      IF internal_status.normal THEN
        delete_connection_from_sap (connection_id, connection_to_delete^.sap_id);
        nap$gt_delete_job_connection (connection_id);
        nap$gt_releas_exclusiv_to_clist;
        IF cl_connection^.message_sender.active THEN
          nlp$cl_deactivate_sender (cl_connection);
        IFEND;
        IF cl_connection^.message_receiver.active THEN
          nlp$cl_deactivate_receiver (cl_connection);
        IFEND;
        delete_queued_events (connection);
        nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
        osp$establish_condition_handler (^terminate_disconnect, FALSE);
        nlp$bm_create_message (data, message_id, internal_status);
        osp$disestablish_cond_handler;
        nlp$ta_disconnect_connection (cl_connection, message_id, internal_status);
        nlp$cl_release_exclusive_access (cl_connection);
      ELSE
        nap$gt_releas_exclusiv_to_clist;
      IFEND;
      osp$pop_inhibit_job_recovery;
      IF NOT internal_status.normal THEN
        osp$disestablish_cond_handler;
        status := internal_status;
      IFEND;
    ELSE
      osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, external_interface, status);
    IFEND;
  PROCEND nap$gt_disconnect;
?? TITLE := ' [XDCL] nap$gt_initialize', EJECT ??

  PROCEDURE [XDCL] nap$gt_initialize;

*copyc nah$gt_initialize

    VAR
      connection_processor: nlt$cl_event_processor,
      sap_processor: nlt$cl_event_processor;

    nlp$cl_initialize_template (nlc$osi_generic_xport_interface,
          nlc$osi_generic_xport_interface, #SIZE (nat$gt_connection), 0,
          sap_processor, nac$gt_evaluate_sap_timers, connection_processor,
          nac$gt_evaluate_connect_timers);
    nlp$ta_initialize (nlc$osi_generic_xport_interface, nac$osi_gt_process_sap_event,
          nac$osi_gt_process_conn_event);
  PROCEND nap$gt_initialize;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$gt_open_sap', EJECT ??
*copy nah$gt_open_sap

  PROCEDURE [XDCL, #GATE] nap$gt_open_sap
    (    maximum_active_connections: nat$maximum_active_connections;
         sap_priority: nat$network_message_priority;
         reserved_sap: boolean;
     VAR sap_id {INPUT, OUTPUT} : nat$gt_sap_identifier;
     VAR address: nat$internet_address;
     VAR status: ost$status);

    VAR
      sap_processor: nlt$cl_event_processor,
      connection_processor: nlt$cl_event_processor,
      ignore_status: ost$status,
      internal_status: ost$status,
      job_sap: ^nat$gt_job_sap,
      new_sap: ^nat$gt_sap;

    IF NOT nav$namve_active THEN
      osp$set_status_condition ( nae$network_inactive,  status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    IF (sap_priority < 0) OR (sap_priority > UPPERVALUE (sap_priority)) THEN
      osp$set_status_condition (nae$invalid_sap_priority, status);
      RETURN;
    IFEND;
    IF ((maximum_active_connections > 0) AND (maximum_active_connections <=
          UPPERVALUE (nat$maximum_active_connections))) THEN
      osp$push_inhibit_job_recovery;
      ALLOCATE job_sap IN nav$network_paged_heap^;
      internal_status.normal := TRUE;
      IF job_sap <> NIL THEN
        ALLOCATE new_sap IN nav$network_paged_heap^;
        IF new_sap <> NIL THEN
          new_sap^ := nav$gt_null_sap;
          new_sap^.sap_id.xns_sap_identifier := 0;
          new_sap^.opened_via_share := FALSE;
          new_sap^.shared_sap_server_active := FALSE;
          assign_sap_identifier (reserved_sap, sap_id.osi_sap_identifier, { shared_sap = } FALSE,
                new_sap^.sap_id.osi_sap_identifier, internal_status);
          IF internal_status.normal THEN
            nlp$cl_initialize_template (nlc$osi_generic_xport_interface,
                  nlc$osi_generic_xport_interface, #SIZE (nat$gt_connection), 0, sap_processor,
                  nac$gt_evaluate_sap_timers, connection_processor, nac$gt_evaluate_connect_timers);
            nlp$ta_open_sap (nlc$osi_generic_xport_interface, nac$osi_gt_process_sap_event,
                  nac$osi_gt_process_conn_event, internal_status);
            IF internal_status.normal THEN
              job_sap^.sap_id := new_sap^.sap_id;
              job_sap^.selector := new_sap^.sap_id;
              job_sap^.priority := sap_priority;
              job_sap^.shared_sap_server := TRUE;
              sap_id := new_sap^.sap_id;
              nap$gt_add_job_sap (job_sap);
              osp$begin_subsystem_activity;
              osp$set_job_signature_lock (nav$gt_sap_list.lock);
              new_sap^.next_sap := nav$gt_sap_list.first_sap;
              nav$gt_sap_list.first_sap := new_sap;
              osp$clear_job_signature_lock (nav$gt_sap_list.lock);
              osp$end_subsystem_activity;
            ELSE
              unassign_sap_identifier (new_sap^.sap_id.osi_sap_identifier);
              FREE job_sap IN nav$network_paged_heap^;
              FREE new_sap IN nav$network_paged_heap^;
            IFEND;
          ELSE { Unable to assign sap identifier.
            FREE job_sap IN nav$network_paged_heap^;
            FREE new_sap IN nav$network_paged_heap^;
          IFEND;
        ELSE { new_sap ALLOCATION failed.
          FREE job_sap IN nav$network_paged_heap^;
          osp$set_status_abnormal (nac$status_id, nae$insufficient_resources, external_interface,
                internal_status);
        IFEND;
      ELSE { job_sap ALLOCATION failed.
        osp$set_status_abnormal (nac$status_id, nae$insufficient_resources, external_interface,
              internal_status);
      IFEND;
      osp$pop_inhibit_job_recovery;
      IF NOT internal_status.normal THEN
        status := internal_status;
      IFEND;
    ELSEIF maximum_active_connections = 0 THEN
      osp$set_status_condition ( nae$max_active_connections_0,  status);
    ELSE
      osp$set_status_condition ( nae$max_active_conn_exceeded,  status);
    IFEND;
  PROCEND nap$gt_open_sap;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$gt_open_shared_sap', EJECT ??
*copy nah$gt_open_shared_sap

  PROCEDURE [XDCL, #GATE] nap$gt_open_shared_sap
    (    maximum_active_connections: nat$maximum_active_connections;
         sap_priority: nat$network_message_priority;
         selector: nat$gt_sap_identifier,
         server_job: boolean;
     VAR sap_id : nat$gt_sap_identifier;
     VAR status: ost$status);

    VAR
      sap_processor: nlt$cl_event_processor,
      connection_processor: nlt$cl_event_processor,
      ignore_status: ost$status,
      internal_status: ost$status,
      job_sap: ^nat$gt_job_sap,
      new_sap_created: boolean,
      sap: ^nat$gt_sap;

    IF NOT nav$namve_active THEN
      osp$set_status_condition ( nae$network_inactive,  status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    IF ((maximum_active_connections > 0) AND (maximum_active_connections <=
          UPPERVALUE (nat$maximum_active_connections))) THEN
      internal_status.normal := TRUE;
      osp$push_inhibit_job_recovery;
      ALLOCATE job_sap IN nav$network_paged_heap^;
      IF job_sap <> NIL THEN
        new_sap_created := FALSE;

        sap := nav$gt_sap_list.first_sap;
        WHILE (sap <> NIL) AND
              (sap^.sap_id.osi_sap_identifier <> selector.osi_sap_identifier) DO
          sap := sap^.next_sap;
        WHILEND;
        IF sap = NIL THEN
          ALLOCATE sap IN nav$network_paged_heap^;
          IF sap <> NIL THEN
            new_sap_created := TRUE;
            sap^ := nav$gt_null_sap;
            sap^.opened_via_share := TRUE;
            sap^.shared_sap_server_active := FALSE;
            sap^.sap_id := selector;
          ELSE { sap = NIL
            osp$set_status_abnormal (nac$status_id, nae$insufficient_resources, external_interface,
                  internal_status);
          IFEND;
        ELSEIF NOT sap^.opened_via_share THEN
          osp$set_status_abnormal (nac$status_id, nae$sap_cannot_be_shared, external_interface,
                internal_status);
          osp$append_status_integer (osc$status_parameter_delimiter, selector.osi_sap_identifier, 10,
                TRUE, internal_status);
        ELSEIF (server_job) AND (sap^.shared_sap_server_active) THEN
          osp$set_status_abnormal (nac$status_id, nae$shared_server_sap_open, external_interface,
                internal_status);
          osp$append_status_integer (osc$status_parameter_delimiter, selector.osi_sap_identifier, 10,
                TRUE, internal_status);
        IFEND;

        IF internal_status.normal THEN
          assign_sap_identifier ({ reserved_sap = } TRUE, selector.osi_sap_identifier,
                { shared_sap = } TRUE, job_sap^.sap_id.osi_sap_identifier,internal_status);
          IF internal_status.normal THEN
            nlp$cl_initialize_template (nlc$osi_generic_xport_interface,
                  nlc$osi_generic_xport_interface, #SIZE (nat$gt_connection), 0, sap_processor,
                  nac$gt_evaluate_sap_timers, connection_processor, nac$gt_evaluate_connect_timers);
            nlp$ta_open_sap (nlc$osi_generic_xport_interface, nac$osi_gt_process_sap_event,
                  nac$osi_gt_process_conn_event, internal_status);
            IF internal_status.normal THEN

{ Increment shared sap count.

              sap^.shared_sap_count := sap^.shared_sap_count + 1;
              IF (NOT sap^.shared_sap_server_active) AND (server_job) THEN
                sap^.shared_sap_server_active := TRUE;
              IFEND;
              job_sap^.sap_id.xns_sap_identifier := 0;
              job_sap^.selector := selector;
              job_sap^.next_sap := NIL;
              job_sap^.priority := sap_priority;
              job_sap^.shared_sap_server := server_job;
              sap_id := job_sap^.sap_id;
              nap$gt_add_job_sap (job_sap);
              IF new_sap_created THEN
                osp$begin_subsystem_activity;
                osp$set_job_signature_lock (nav$gt_sap_list.lock);
                sap^.next_sap := nav$gt_sap_list.first_sap;
                nav$gt_sap_list.first_sap := sap;
                osp$clear_job_signature_lock (nav$gt_sap_list.lock);
                osp$end_subsystem_activity;
              IFEND;
            ELSE
              unassign_sap_identifier (sap^.sap_id.osi_sap_identifier);
              FREE job_sap IN nav$network_paged_heap^;
              IF new_sap_created THEN
                FREE sap IN nav$network_paged_heap^;
              IFEND;
            IFEND;
          ELSE { Unable to assign sap identifier.
            FREE job_sap IN nav$network_paged_heap^;
            IF new_sap_created THEN
              FREE sap IN nav$network_paged_heap^;
            IFEND;
          IFEND;
        ELSE
          FREE job_sap IN nav$network_paged_heap^;
        IFEND;
      ELSE { job_sap ALLOCATION failed.
        osp$set_status_abnormal (nac$status_id, nae$insufficient_resources, external_interface,
              internal_status);
      IFEND;
      osp$pop_inhibit_job_recovery;
      IF NOT internal_status.normal THEN
        status := internal_status;
      IFEND;
    ELSEIF maximum_active_connections = 0 THEN
      osp$set_status_condition ( nae$max_active_connections_0,  status);
    ELSE
      osp$set_status_condition ( nae$max_active_conn_exceeded,  status);
    IFEND;
  PROCEND nap$gt_open_shared_sap;
?? OLDTITLE ??
?? NEWTITLE := 'deliver_connection_events', EJECT ??

  PROCEDURE deliver_connection_events
    (    connection: ^nat$gt_connection;
         cl_connection: ^nlt$cl_connection;
     VAR delivery_complete: boolean);

{
{   ENTRY REQUIREMENT: the process of delivering connection events is dependent on the caller having a
{                      condition handler established to field conditions arising from an invalid user
{                      data area.  Further, it is expected that the condition handler causes any updating
{                      of interface flow control to be circumvented if such a condition occurs.
{

    VAR
      executing_task: ost$global_task_id,
      event_queue: ^^nat$gt_event_element,
      event_to_free: ^nat$gt_event_element,
      end_of_message: boolean,
      delivered_message_buffers: nat$data_length,
      ignore_rbc: nat$data_length;

    delivery_complete := FALSE;
    IF connection^.event_queue.beginning <> NIL THEN
      pmp$get_executing_task_gtid (executing_task);
      IF executing_task = cl_connection^.message_receiver.task THEN
        event_queue := ^connection^.event_queue.beginning;
        CASE event_queue^^.event.kind OF
        = nlc$ta_data_event =
          connection^.receiver_request.application_event^.kind := nac$gt_data_event;
          IF event_queue^^.data_length <= connection^.receiver_request.remaining_buffer_capacity THEN
            connection^.receiver_request.delivered_data_length :=
                  connection^.receiver_request.delivered_data_length + event_queue^^.data_length;
            connection^.receiver_request.application_event^.data.data_length :=
                  connection^.receiver_request.delivered_data_length;
            end_of_message := event_queue^^.event.osi_data.end_of_message;
            connection^.receiver_request.application_event^.data.end_of_message := end_of_message;
            CASE connection^.receiver_request.application_buffer.description_kind OF
            = nac$gt_fixed =
              nlp$al_deliver_data (event_queue^^.event.osi_data.data,
                    connection^.receiver_request.application_buffer.fixed_description,
                    connection^.receiver_request.remaining_buffer_capacity, delivered_message_buffers);
            = nac$gt_allocated =
              nlp$al_deliver_data (event_queue^^.event.osi_data.data,
                    connection^.receiver_request.application_buffer.allocated_description^,
                    connection^.receiver_request.remaining_buffer_capacity, delivered_message_buffers);
              IF end_of_message OR (connection^.receiver_request.remaining_buffer_capacity = 0) OR
                    (event_queue^^.next_event <> NIL) THEN
                FREE connection^.receiver_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
            CASEND;
            connection^.undelivered_message_buffers := connection^.undelivered_message_buffers -
                  delivered_message_buffers;
            event_to_free := event_queue^;
            event_queue^ := event_to_free^.next_event;
            FREE event_to_free IN nav$network_paged_heap^;
            delivery_complete := end_of_message OR (connection^.receiver_request.remaining_buffer_capacity =
                  0) OR (event_queue^ <> NIL);
            connection^.receiver_request.data_delivery_in_progress := NOT delivery_complete;
            IF event_queue^ = NIL THEN
              connection^.event_queue.ending := NIL;
              nlp$cancel_timer (connection^.timer);
            ELSE
              nlp$select_timer (nac$gt_event_timer_duration, 0, connection^.timer);
            IFEND;
          ELSE
            connection^.receiver_request.delivered_data_length :=
                  connection^.receiver_request.delivered_data_length +
                  connection^.receiver_request.remaining_buffer_capacity;
            connection^.receiver_request.application_event^.data.data_length :=
                  connection^.receiver_request.delivered_data_length;
            connection^.receiver_request.application_event^.data.end_of_message := FALSE;
            CASE connection^.receiver_request.application_buffer.description_kind OF
            = nac$gt_fixed =
              nlp$al_deliver_data (event_queue^^.event.osi_data.data,
                    connection^.receiver_request.application_buffer.fixed_description, ignore_rbc,
                    delivered_message_buffers);
            = nac$gt_allocated =
              nlp$al_deliver_data (event_queue^^.event.osi_data.data,
                    connection^.receiver_request.application_buffer.allocated_description^, ignore_rbc,
                    delivered_message_buffers);
              FREE connection^.receiver_request.application_buffer.allocated_description IN
                    nav$network_paged_heap^;
            CASEND;
            event_queue^^.data_length := event_queue^^.data_length -
                  connection^.receiver_request.remaining_buffer_capacity;
            connection^.undelivered_message_buffers := connection^.undelivered_message_buffers -
                  delivered_message_buffers;
            delivery_complete := TRUE;
            connection^.receiver_request.data_delivery_in_progress := FALSE;
            nlp$select_timer ((nac$gt_event_timer_duration DIV 2), 0, connection^.timer);
          IFEND;
?? EJECT ??

        = nlc$ta_disconnect_event =
          IF NOT connection^.receiver_request.data_delivery_in_progress THEN
            connection^.receiver_request.application_event^.kind := nac$gt_disconnect_event;
            IF event_queue^^.event.osi_disconnect.proprietary_reason = nlc$ta_user_disconnect_request THEN
              connection^.receiver_request.application_event^.disconnect.reason :=
                    event_queue^^.event.osi_disconnect.osi_8073_reason;
              connection^.receiver_request.application_event^.disconnect.data_length :=
                    event_queue^^.data_length;
              CASE connection^.receiver_request.application_buffer.description_kind OF
              = nac$gt_fixed =
                nlp$al_deliver_data (event_queue^^.event.osi_disconnect.data,
                      connection^.receiver_request.application_buffer.fixed_description,
                      connection^.receiver_request.remaining_buffer_capacity, delivered_message_buffers);
              = nac$gt_allocated =
                nlp$al_deliver_data (event_queue^^.event.osi_disconnect.data,
                      connection^.receiver_request.application_buffer.allocated_description^,
                      connection^.receiver_request.remaining_buffer_capacity, delivered_message_buffers);
                FREE connection^.receiver_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              CASEND;
            ELSE
              connection^.receiver_request.application_event^.disconnect.reason := nac$gt_layer_disconnect;
              CASE connection^.receiver_request.application_buffer.description_kind OF
              = nac$gt_fixed =
                ;
              = nac$gt_allocated =
                FREE connection^.receiver_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              CASEND;
            IFEND;
            event_to_free := event_queue^;
            event_queue^ := event_queue^^.next_event;
            FREE event_to_free IN nav$network_paged_heap^;
            IF event_queue^ = NIL THEN
              connection^.event_queue.ending := NIL;
            IFEND;
            delivery_complete := TRUE;
          ELSE
            connection^.receiver_request.data_delivery_in_progress := FALSE;
            CASE connection^.receiver_request.application_buffer.description_kind OF
            = nac$gt_fixed =
              ;
            = nac$gt_allocated =
              FREE connection^.receiver_request.application_buffer.allocated_description IN
                    nav$network_paged_heap^;
            CASEND;
            delivery_complete := TRUE;
            nlp$select_timer (nac$gt_event_timer_duration, 0, connection^.timer);
          IFEND;
?? EJECT ??

        = nlc$ta_connect_confirm_event =
          connection^.receiver_request.application_event^.kind := nac$gt_accept_event;
          connection^.receiver_request.application_event^.accept.data_length := event_queue^^.data_length;
          connection^.receiver_request.application_event^.accept.checksum :=
                event_queue^^.event.osi_connect_confirm.checksum;
          connection^.receiver_request.application_event^.accept.expedited_data :=
                event_queue^^.event.osi_connect_confirm.expedited_data;
          CASE connection^.receiver_request.application_buffer.description_kind OF
          = nac$gt_fixed =
            nlp$al_deliver_data (event_queue^^.event.osi_connect_confirm.data,
                  connection^.receiver_request.application_buffer.fixed_description,
                  connection^.receiver_request.remaining_buffer_capacity, delivered_message_buffers);
          = nac$gt_allocated =
            nlp$al_deliver_data (event_queue^^.event.osi_connect_confirm.data,
                  connection^.receiver_request.application_buffer.allocated_description^,
                  connection^.receiver_request.remaining_buffer_capacity, delivered_message_buffers);
            FREE connection^.receiver_request.application_buffer.allocated_description IN
                  nav$network_paged_heap^;
          CASEND;
          event_to_free := event_queue^;
          event_queue^ := event_to_free^.next_event;
          FREE event_to_free IN nav$network_paged_heap^;
          IF event_queue^ = NIL THEN
            connection^.event_queue.ending := NIL;
          IFEND;
          delivery_complete := TRUE;
          nlp$cancel_timer (connection^.timer);
?? EJECT ??

        = nlc$ta_expedited_data_event =
          IF NOT connection^.receiver_request.data_delivery_in_progress THEN
            connection^.receiver_request.application_event^.kind := nac$gt_expedited_data_event;
            connection^.receiver_request.application_event^.expedited_data.data_length :=
                  event_queue^^.data_length;
            CASE connection^.receiver_request.application_buffer.description_kind OF
            = nac$gt_fixed =
              nlp$al_deliver_data (event_queue^^.event.osi_expedited_data.data,
                    connection^.receiver_request.application_buffer.fixed_description,
                    connection^.receiver_request.remaining_buffer_capacity, delivered_message_buffers);
            = nac$gt_allocated =
              nlp$al_deliver_data (event_queue^^.event.osi_expedited_data.data,
                    connection^.receiver_request.application_buffer.allocated_description^,
                    connection^.receiver_request.remaining_buffer_capacity, delivered_message_buffers);
              FREE connection^.receiver_request.application_buffer.allocated_description IN
                    nav$network_paged_heap^;
            CASEND;
            event_to_free := event_queue^;
            event_queue^ := event_to_free^.next_event;
            FREE event_to_free IN nav$network_paged_heap^;
            IF event_queue^ = NIL THEN
              connection^.event_queue.ending := NIL;
              nlp$cancel_timer (connection^.timer);
            ELSE
              nlp$select_timer (nac$gt_event_timer_duration, 0, connection^.timer);
            IFEND;
            delivery_complete := TRUE;
          ELSE
            connection^.receiver_request.data_delivery_in_progress := FALSE;
            CASE connection^.receiver_request.application_buffer.description_kind OF
            = nac$gt_fixed =
              ;
            = nac$gt_allocated =
              FREE connection^.receiver_request.application_buffer.allocated_description IN
                    nav$network_paged_heap^;
            CASEND;
            delivery_complete := TRUE;
            nlp$select_timer ((nac$gt_event_timer_duration DIV 2), 0, connection^.timer);
          IFEND;
        CASEND;
      ELSE
        activate_receiver_task (cl_connection);
      IFEND;
    IFEND;
  PROCEND deliver_connection_events;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$gt_receive_connection_event', EJECT ??
*copy nah$gt_receive_connection_event

  PROCEDURE [XDCL, #GATE] nap$gt_receive_connection_event
    (    connection_id: nat$gt_connection_id;
         data_area: nat$data_fragments;
         wait: ost$wait;
     VAR connection_event: nat$gt_event;
     VAR activity_status: ost$activity_status;
     VAR status: ost$status);

    VAR
      job_connection: ^nat$gt_job_connection,
      cl_connection: ^nlt$cl_connection,
      condition_cause: nat$gt_condition_cause,
      connection: ^nat$gt_connection;

?? NEWTITLE := 'terminate_receive', EJECT ??

    PROCEDURE terminate_receive
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        requesting_task: ost$global_task_id;

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF ((condition_cause = nac$gt_application_data) OR (condition_cause = nac$gt_application_event)) THEN
          IF cl_connection <> NIL THEN
            pmp$get_executing_task_gtid (requesting_task);
            IF cl_connection^.message_receiver.active AND (cl_connection^.message_receiver.task =
                  requesting_task) THEN
              nlp$cl_deactivate_receiver (cl_connection);
              IF ((connection^.receiver_request.application_buffer.description_kind = nac$gt_allocated) AND
                    (connection^.receiver_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.receiver_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              connection^.receiver_request := nav$gt_null_receiver_request;
              CASE connection^.state OF
              = nac$gt_open =
                ;
              = nac$gt_accept_received =
                connection^.state := nac$gt_open;
              = nac$gt_peer_reject, nac$gt_peer_disconnect, nac$gt_connection_failed =
                connection^.state := nac$gt_closed;
                nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
                delete_connection_from_sap (connection_id, job_connection^.sap_id);
                nap$gt_delete_job_connection (connection_id);
              CASEND;
            IFEND;
            nlp$cl_release_exclusive_access (cl_connection);
          IFEND;
          nap$gt_clear_exclusive_to_clist;
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
          EXIT nap$gt_receive_connection_event;
        ELSE
          osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_receive;
?? OLDTITLE ??
?? NEWTITLE := 'terminate_inactive ', EJECT ??

    PROCEDURE terminate_inactive
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        osp$pop_inhibit_job_recovery;
        osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
        EXIT nap$gt_receive_connection_event;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_inactive;
?? OLDTITLE, EJECT ??

    VAR
      buffer_description: ^nlt$al_data_description,
      buffer_length: integer,
      cl_connection_id: nlt$cl_connection_id,
      connection_exists: boolean,
      data_delivery_in_progress: boolean,
      data_length: integer,
      delivery_complete: boolean,
      description_upperbound: integer,
      ignore_dmb: nat$data_length,
      ignore_rbc: nat$data_length,
      internal_status: ost$status,
      layer_active: boolean,
      message_id: nlt$bm_message_id,
      request_complete: boolean,
      requesting_task: ost$global_task_id,
      termination_state: nac$gt_peer_reject .. nac$gt_connection_failed;

    status.normal := TRUE;
    internal_status.normal := TRUE;
    activity_status.status.normal := TRUE;
    activity_status.complete := TRUE;

    IF UPPERBOUND (data_area) > nac$max_data_fragment_count THEN
      osp$set_status_condition (nae$maximum_data_fragments, status);
      RETURN;
    IFEND;

    nlp$al_get_data_requirements (data_area, buffer_length, description_upperbound);
    IF buffer_length > nac$max_data_length THEN
      osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, 'nac$max_data_length', status);
      RETURN;
    IFEND;
    IF buffer_length >= nac$gt_maximum_disconnect_data THEN
      cl_connection := NIL;
      condition_cause := nac$gt_request_not_cause;
      #SPOIL (condition_cause, cl_connection);
      osp$push_inhibit_job_recovery;
      osp$establish_condition_handler (^terminate_receive, FALSE);
      request_complete := FALSE;
      WHILE internal_status.normal AND NOT request_complete DO
        nap$gt_get_exclusive_to_clist;
        job_connection := nav$gt_job_connection_list.first_connection;
        WHILE (job_connection <> NIL) AND (job_connection^.connection_id <> connection_id) DO
          job_connection := job_connection^.next_connection;
        WHILEND;
        IF ((job_connection <> NIL) AND job_connection^.active) THEN
          nlp$cl_get_exclusive_via_cid (job_connection^.active_connection_id, connection_exists,
                cl_connection);
          IF connection_exists THEN
            nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active,
                  connection);
            IF layer_active THEN
              IF NOT cl_connection^.message_receiver.active THEN
                nlp$cl_activate_receiver (cl_connection);
                condition_cause := nac$gt_application_data;
                #SPOIL (condition_cause);
                IF description_upperbound <= nac$gt_fixed_fragments THEN
                  connection^.receiver_request.application_buffer.description_kind := nac$gt_fixed;
                  nlp$al_initialize_data_descrip (data_area, buffer_length,
                        connection^.receiver_request.application_buffer.fixed_description);
                ELSE
                  connection^.receiver_request.application_buffer.description_kind := nac$gt_allocated;
                  REPEAT
                    ALLOCATE connection^.receiver_request.application_buffer.allocated_description:
                          [1 .. description_upperbound] IN nav$network_paged_heap^;
                    IF connection^.receiver_request.application_buffer.allocated_description = NIL THEN
                      syp$cycle;
                    IFEND;
                  UNTIL connection^.receiver_request.application_buffer.allocated_description <> NIL;
                  nlp$al_initialize_data_descrip (data_area, buffer_length,
                        connection^.receiver_request.application_buffer.allocated_description^);
                IFEND;
                connection^.receiver_request.activity_status := ^activity_status;
                connection^.receiver_request.application_event := ^connection_event;
                connection^.receiver_request.delivered_data_length := 0;
                connection^.receiver_request.remaining_buffer_capacity := buffer_length;
                data_delivery_in_progress := connection^.receiver_request.data_delivery_in_progress;
                deliver_connection_events (connection, cl_connection, delivery_complete);
                condition_cause := nac$gt_request_not_cause;
                #SPOIL (condition_cause);
                nlp$ta_report_undelivered_data (cl_connection, connection^.undelivered_message_buffers);
                IF delivery_complete THEN
                  nlp$cl_deactivate_receiver (cl_connection);
                  connection^.receiver_request := nav$gt_null_receiver_request;
                  CASE connection^.state OF
                  = nac$gt_open =
                    ;
                  = nac$gt_accept_received =
                    connection^.state := nac$gt_open;
                  = nac$gt_peer_reject, nac$gt_peer_disconnect, nac$gt_connection_failed =
                    IF NOT data_delivery_in_progress THEN
                      connection^.state := nac$gt_closed;
                      nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
                      delete_connection_from_sap (connection_id, job_connection^.sap_id);
                      nap$gt_delete_job_connection (connection_id);
                    ELSE
                      nap$gt_deactivate_job_connect (connection^.state,
                            connection^.event_queue.beginning^.event,
                            connection^.event_queue.beginning^.data_length, job_connection);
                      CASE connection^.state OF
                      = nac$gt_peer_reject, nac$gt_peer_disconnect =
                        FREE connection^.event_queue.beginning IN nav$network_paged_heap^;
                      = nac$gt_connection_failed =
                        ;
                      CASEND;
                      connection^.state := nac$gt_closed;
                      nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
                    IFEND;
                  CASEND;
                  nlp$cl_release_exclusive_access (cl_connection);
                  nap$gt_releas_exclusiv_to_clist;
                  request_complete := TRUE;
                ELSE
                  condition_cause := nac$gt_request_not_cause;
                  #SPOIL (condition_cause);
                  cl_connection_id := cl_connection^.identifier;
                  nlp$cl_release_exclusive_access (cl_connection);
                  nap$gt_releas_exclusiv_to_clist;
                  activity_status.complete := FALSE;
                  IF (wait = osc$wait) THEN
                    pmp$wait (1000, 200);
                    pmp$get_executing_task_gtid (requesting_task);

                  /wait_for_request_complete/
                    REPEAT
                      nlp$cl_get_exclusive_via_cid (cl_connection_id, connection_exists, cl_connection);
                      IF connection_exists THEN
                        IF NOT cl_connection^.message_receiver.active OR
                              (cl_connection^.message_receiver.task <> requesting_task) THEN
                          request_complete := TRUE;
                          nlp$cl_release_exclusive_access (cl_connection);
                        ELSE
                          nlp$cl_release_exclusive_access (cl_connection);
                          pmp$wait (2000000, 2000000);
                        IFEND;
                      ELSE
                        request_complete := TRUE;
                        osp$set_status_abnormal (nac$status_id, nae$connection_not_open, external_interface,
                              internal_status);
                      IFEND;
                    UNTIL request_complete;
                  ELSE
                    request_complete := TRUE;
                  IFEND;
                IFEND;
              ELSEIF wait = osc$wait THEN
                nlp$cl_release_exclusive_access (cl_connection);
                nap$gt_releas_exclusiv_to_clist;
                pmp$wait (1000, 1000);
              ELSE
                nlp$cl_release_exclusive_access (cl_connection);
                nap$gt_releas_exclusiv_to_clist;
                osp$set_status_abnormal (nac$status_id, nae$receive_outstanding, external_interface,
                      internal_status);
              IFEND;
            ELSE
              nlp$cl_release_exclusive_access (cl_connection);
              delete_connection_from_sap (connection_id, job_connection^.sap_id);
              nap$gt_delete_job_connection (connection_id);
              nap$gt_releas_exclusiv_to_clist;
              osp$set_status_abnormal (nac$status_id, nae$connection_not_open, external_interface,
                    internal_status);
            IFEND;
          ELSE
            delete_connection_from_sap (connection_id, job_connection^.sap_id);
            nap$gt_delete_job_connection (connection_id);
            nap$gt_releas_exclusiv_to_clist;
            osp$set_status_abnormal (nac$status_id, nae$connection_not_open, external_interface,
                  internal_status);
          IFEND;
        ELSEIF job_connection <> NIL THEN
          PUSH buffer_description: [1 .. description_upperbound];
          termination_state := job_connection^.termination_state;
          condition_cause := nac$gt_application_event;
          #SPOIL (condition_cause);
          CASE termination_state OF
          = nac$gt_peer_disconnect =
            connection_event.kind := nac$gt_disconnect_event;
            connection_event.disconnect.reason := nac$gt_user_disconnect;
            nlp$bm_get_message_length (job_connection^.termination_event.osi_disconnect.data, data_length);
            connection_event.disconnect.data_length := data_length;
            nlp$bm_copy_message (job_connection^.termination_event.osi_disconnect.data, message_id);
          = nac$gt_connection_failed =
            connection_event.kind := nac$gt_disconnect_event;
            connection_event.disconnect.reason := nac$gt_layer_disconnect;
          ELSE
          CASEND;
          delete_connection_from_sap (connection_id, job_connection^.sap_id);
          nap$gt_delete_job_connection (connection_id);
          nap$gt_releas_exclusiv_to_clist;
          osp$establish_condition_handler (^terminate_inactive, FALSE);
          IF termination_state = nac$gt_peer_disconnect THEN
            condition_cause := nac$gt_application_data;
            #SPOIL (condition_cause);
            nlp$al_initialize_data_descrip (data_area, buffer_length, buffer_description^);
            nlp$al_deliver_data (message_id, buffer_description^, ignore_rbc, ignore_dmb);
            nlp$bm_release_message (message_id);
          IFEND;
          request_complete := TRUE;
        ELSE
          nap$gt_releas_exclusiv_to_clist;
          osp$set_status_abnormal (nac$status_id, nae$connection_not_open, external_interface,
                internal_status);
        IFEND;
      WHILEND;
      osp$pop_inhibit_job_recovery;
      osp$disestablish_cond_handler;
      IF NOT internal_status.normal THEN
        status := internal_status;
      IFEND;
    ELSE
      osp$set_status_abnormal (nac$status_id, nae$data_area_too_small, external_interface, status);
    IFEND;
  PROCEND nap$gt_receive_connection_event;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$gt_deliver_event_handler', EJECT ??
*copy nah$gt_deliver_event_handler

  PROCEDURE [XDCL] nap$gt_deliver_event_handler
    (    originator: ost$global_task_id;
         signal: pmt$signal);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$gt_connection,
      condition_cause: nat$gt_condition_cause;

?? NEWTITLE := 'terminate_delivery', EJECT ??

    PROCEDURE terminate_delivery
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        activity_status: ^ost$activity_status,
        status: ost$status;

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF (condition_cause = nac$gt_application_data) THEN
          IF cl_connection <> NIL THEN
            nlp$cl_deactivate_receiver (cl_connection);
            IF ((connection^.receiver_request.application_buffer.description_kind = nac$gt_allocated) AND
                  (connection^.receiver_request.application_buffer.allocated_description <> NIL)) THEN
              FREE connection^.receiver_request.application_buffer.allocated_description IN
                    nav$network_paged_heap^;
            IFEND;
            activity_status := connection^.receiver_request.activity_status;
            connection^.receiver_request := nav$gt_null_receiver_request;
            CASE connection^.state OF
            = nac$gt_open =
              ;
            = nac$gt_accept_received =
              connection^.state := nac$gt_open;
            = nac$gt_peer_reject, nac$gt_peer_disconnect, nac$gt_connection_failed =
              connection^.state := nac$gt_closed;
              nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
            CASEND;
            osp$establish_condition_handler (^terminate_delivery, FALSE);
            condition_cause := nac$gt_activity_status;
            #SPOIL (condition_cause);
            activity_status^.complete := TRUE;
            osp$set_status_from_condition (nac$status_id, condition, sa, activity_status^.status, status);
            nlp$cl_release_exclusive_access (cl_connection);
            osp$pop_inhibit_job_recovery;
            EXIT nap$gt_deliver_event_handler;
          IFEND;
        ELSE
          IF cl_connection <> NIL THEN
            IF cl_connection^.message_receiver.active AND (cl_connection^.message_receiver.task =
                  processing_task) THEN
              nlp$cl_deactivate_receiver (cl_connection);
              IF ((connection^.receiver_request.application_buffer.description_kind = nac$gt_allocated) AND
                    (connection^.receiver_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.receiver_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              connection^.receiver_request := nav$gt_null_receiver_request;
            IFEND;
            IF cl_connection^.message_sender.active AND (cl_connection^.message_sender.task = processing_task)
                  THEN
              nlp$cl_deactivate_sender (cl_connection);
              IF ((connection^.sender_request.application_buffer.description_kind = nac$gt_allocated) AND
                    (connection^.sender_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.sender_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              connection^.sender_request := nav$gt_null_sender_request;
            IFEND;
            nlp$cl_release_exclusive_access (cl_connection);
          IFEND;
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_delivery;
?? OLDTITLE, EJECT ??

    VAR
      cl_connection_id: ^nlt$cl_connection_id,
      connection_exists: boolean,
      layer_active: boolean,
      processing_task: ost$global_task_id,
      data_delivery_in_progress: boolean,
      delivery_complete: boolean,
      connection_id: nat$gt_connection_id,
      job_connection: ^nat$gt_job_connection,
      termination_state: nac$gt_peer_reject .. nac$gt_connection_failed,
      data_length: nat$data_length,
      termination_event: nlt$ta_event,
      activity_status: ^ost$activity_status;

    cl_connection_id := #LOC (signal.contents);
    cl_connection := NIL;
    condition_cause := nac$gt_request_not_cause;
    #SPOIL (condition_cause, cl_connection);
    osp$push_inhibit_job_recovery;
    osp$establish_condition_handler (^terminate_delivery, FALSE);
    nlp$cl_get_exclusive_via_cid (cl_connection_id^, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        pmp$get_executing_task_gtid (processing_task);
        IF cl_connection^.message_receiver.active AND (cl_connection^.message_receiver.task = processing_task)
              THEN
          data_delivery_in_progress := connection^.receiver_request.data_delivery_in_progress;
          condition_cause := nac$gt_application_data;
          #SPOIL (condition_cause);
          deliver_connection_events (connection, cl_connection, delivery_complete);
          condition_cause := nac$gt_request_not_cause;
          #SPOIL (condition_cause);
          nlp$ta_report_undelivered_data (cl_connection, connection^.undelivered_message_buffers);
          IF delivery_complete THEN
            activity_status := connection^.receiver_request.activity_status;
            connection^.receiver_request := nav$gt_null_receiver_request;
            nlp$cl_deactivate_receiver (cl_connection);
            CASE connection^.state OF
            = nac$gt_open =
              condition_cause := nac$gt_activity_status;
              #SPOIL (condition_cause);
              activity_status^.complete := TRUE;
              nlp$cl_release_exclusive_access (cl_connection);
            = nac$gt_accept_received =
              connection^.state := nac$gt_open;
              condition_cause := nac$gt_activity_status;
              #SPOIL (condition_cause);
              activity_status^.complete := TRUE;
              nlp$cl_release_exclusive_access (cl_connection);
            = nac$gt_peer_reject, nac$gt_peer_disconnect, nac$gt_connection_failed =
              connection_id := connection^.external_connection_id;
              IF NOT data_delivery_in_progress THEN
                connection^.state := nac$gt_closed;
                nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
                nlp$cl_release_exclusive_access (cl_connection);
                nap$gt_get_exclusive_to_clist;
                job_connection := nav$gt_job_connection_list.first_connection;
                WHILE (job_connection <> NIL) AND (job_connection^.connection_id <> connection_id) DO
                  job_connection := job_connection^.next_connection;
                WHILEND;
                IF job_connection <> NIL THEN
                  delete_connection_from_sap (connection_id, job_connection^.sap_id);
                  nap$gt_delete_job_connection (connection_id);
                IFEND;
                nap$gt_releas_exclusiv_to_clist;
              ELSE
                termination_state := connection^.state;
                data_length := connection^.event_queue.beginning^.data_length;
                termination_event := connection^.event_queue.beginning^.event;
                FREE connection^.event_queue.beginning IN nav$network_paged_heap^;
                connection^.state := nac$gt_closed;
                nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
                nlp$cl_release_exclusive_access (cl_connection);

                nap$gt_get_exclusive_to_clist;
                job_connection := nav$gt_job_connection_list.first_connection;
                WHILE (job_connection <> NIL) AND (job_connection^.connection_id <> connection_id) DO
                  job_connection := job_connection^.next_connection;
                WHILEND;
                IF job_connection <> NIL THEN
                  nap$gt_deactivate_job_connect (termination_state, termination_event, data_length,
                        job_connection);
                ELSE
                  CASE termination_state OF
                  = nac$gt_peer_disconnect =
                    nlp$bm_release_message (termination_event.osi_disconnect.data);
                  = nac$gt_connection_failed =
                    ;
                  ELSE
                  CASEND;
                IFEND;
                nap$gt_releas_exclusiv_to_clist;
              IFEND;
              condition_cause := nac$gt_activity_status;
              #SPOIL (condition_cause);
              activity_status^.complete := TRUE;
            CASEND;
          ELSE
            nlp$cl_release_exclusive_access (cl_connection);
          IFEND;
        ELSEIF cl_connection^.message_receiver.active THEN
          activate_receiver_task (cl_connection);
          nlp$cl_release_exclusive_access (cl_connection);
        ELSE
          nlp$cl_release_exclusive_access (cl_connection);
        IFEND;
      ELSE
        nlp$cl_release_exclusive_access (cl_connection);
      IFEND;
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$gt_deliver_event_handler;
?? OLDTITLE ??
?? NEWTITLE := 'deliver_connect_event', EJECT ??

  PROCEDURE deliver_connect_event
    (    sap: ^nat$gt_sap;
         connect_request: nat$gt_connect_request;
         connection_id: nat$gt_connection_id;
         buffer_description: ^nlt$al_data_description;
         connect_event: ^nat$gt_connect_event);

{
{   ENTRY REQUIREMENT: the process of delivering connect events is dependent on the caller having a
{                      condition handler established to field conditions arising from an invalid user
{                      data area.  Further, it is expected that the condition handler rejects the connect
{                      request and releases any buffer resources associated with the connect request if
{                      such condition occurs.
{

    VAR
      message_id: nlt$bm_message_id,
      ignore_rbc: nat$data_length,
      ignore_dmb: nat$data_length;

    connect_event^.sap_id := sap^.sap_id;
    connect_event^.data_length := connect_request.data_length;
    connect_event^.source := connect_request.source;
    connect_event^.connection := connection_id;
    connect_event^.checksum := connect_request.checksum;
    connect_event^.expedited_data := connect_request.expedited_data;
    message_id := connect_request.data;
    IF connect_request.data_length > 0 THEN
      nlp$al_deliver_data (message_id, buffer_description^, ignore_rbc, ignore_dmb);
    IFEND;
  PROCEND deliver_connect_event;
?? OLDTITLE ??
?? NEWTITLE := 'establish_inbound_connection', EJECT ??

  PROCEDURE establish_inbound_connection
    (    sap: ^nat$gt_sap;
         cl_connection: ^nlt$cl_connection;
         connection: ^nat$gt_connection;
     VAR connection_id: nat$gt_connection_id);

    VAR
      job_connection: ^nat$gt_job_connection,
      sap_connection: ^nat$gt_sap_connection,
      layer_active: boolean;

    REPEAT
      ALLOCATE sap_connection IN nav$network_paged_heap^;
      IF sap_connection = NIL THEN
        syp$cycle;
      IFEND;
    UNTIL sap_connection <> NIL;
    nap$gt_create_job_connection (sap^.sap_id, cl_connection^.identifier, job_connection);
    connection_id := job_connection^.connection_id;
    connection^.state := nac$gt_connect_req_delivered;
    connection^.external_connection_id := job_connection^.connection_id;
    sap_connection^.connection_id := job_connection^.connection_id;
    sap_connection^.next_connection := sap^.first_connection;
    sap_connection^.sap_id := sap^.sap_id;
    sap^.first_connection := sap_connection;
  PROCEND establish_inbound_connection;
?? OLDTITLE ??
?? NEWTITLE := 'get_connect_request', EJECT ??

  PROCEDURE get_connect_request
    (    sap: ^nat$gt_sap;
     VAR connect_request_found: boolean;
     VAR connect_request: nat$gt_connect_request;
     VAR cl_connection: ^nlt$cl_connection;
     VAR connection: ^nat$gt_connection);

    VAR
      cl_connection_id: nlt$cl_connection_id,
      connect_indication: ^nat$gt_connect_request;

    connect_request_found := FALSE;
    REPEAT
      IF sap^.connect_request_queue.beginning <> NIL THEN
        connect_indication := sap^.connect_request_queue.beginning;
        cl_connection_id := connect_indication^.connection_id;
        sap^.connect_request_queue.beginning := sap^.connect_request_queue.beginning^.next_connect_request;
        nlp$cl_get_exclusive_via_cid (cl_connection_id, connect_request_found, cl_connection);
        IF connect_request_found THEN
          nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, connect_request_found,
                connection);
          IF connect_request_found THEN
            connect_request := connect_indication^;
            FREE connect_indication IN nav$network_paged_heap^;
          ELSE
            nlp$cl_release_exclusive_access (cl_connection);
            nlp$bm_release_message (connect_indication^.data);
            FREE connect_indication IN nav$network_paged_heap^;
          IFEND;
        ELSE
          nlp$bm_release_message (connect_indication^.data);
          FREE connect_indication IN nav$network_paged_heap^;
        IFEND;
      IFEND;
    UNTIL (connect_request_found OR (sap^.connect_request_queue.beginning = NIL));
    IF sap^.connect_request_queue.beginning = NIL THEN
      sap^.connect_request_queue.ending := NIL;
      nlp$cancel_timer (sap^.event_timer);
    ELSE
      nlp$select_timer (nac$gt_sap_event_timer_duration, 0, sap^.event_timer);
    IFEND;
  PROCEND get_connect_request;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$gt_receive_connect_event'??
?? NEWTITLE := 'terminate_receive', EJECT ??
*copy nah$gt_receive_connect_event

  PROCEDURE [XDCL, #GATE] nap$gt_receive_connect_event
    (    sap_id: nat$gt_sap_identifier,
         data_area: nat$data_fragments,
         wait: ost$wait;
     VAR connect_event: nat$gt_connect_event;
     VAR activity_status: ost$activity_status;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connect_request: nat$gt_connect_request;


    PROCEDURE terminate_receive
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        status: ost$status;

      condition_status.normal := TRUE;
      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF cl_connection <> NIL THEN
          nlp$ta_disconnect_connection (cl_connection, connect_request.data, condition_status);
          nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
          nlp$cl_clear_exclusive_access (cl_connection);
        IFEND;
        clear_sap_access;
        nap$gt_clear_exclusive_to_clist;
        osp$pop_inhibit_job_recovery;
        osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
        EXIT nap$gt_receive_connect_event;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_receive;
?? OLDTITLE, EJECT ??

    VAR
      buffer_length: integer,
      description_upperbound: integer,
      sap: ^nat$gt_sap,
      connect_request_found: boolean,
      connection: ^nat$gt_connection,
      connection_id: nat$gt_connection_id,
      buffer_description: ^nlt$al_data_description,
      requesting_task: ost$global_task_id,
      request_complete: boolean,
      server_job: boolean,
      internal_status: ost$status;

    status.normal := TRUE;
    activity_status.complete := TRUE;
    activity_status.status.normal := TRUE;

    IF UPPERBOUND (data_area) > nac$max_data_fragment_count THEN
      osp$set_status_condition (nae$maximum_data_fragments, status);
      RETURN;
    IFEND;

    nlp$al_get_data_requirements (data_area, buffer_length, description_upperbound);
    IF buffer_length > nac$max_data_length THEN
      osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, 'nac$max_data_length', status);
      RETURN;
    IFEND;
    IF buffer_length >= nac$gt_maximum_connect_data THEN
      cl_connection := NIL;
      #SPOIL (cl_connection);
      osp$establish_condition_handler (^terminate_receive, FALSE);
      osp$push_inhibit_job_recovery;
      request_complete := FALSE;
      internal_status.normal := TRUE;
      WHILE NOT request_complete AND internal_status.normal DO
        nap$gt_get_exclusive_to_clist;
        get_sap_access (sap_id, sap, server_job, internal_status);
        IF internal_status.normal THEN
          IF server_job THEN
            IF NOT sap^.connect_request_receiver.active THEN
              get_connect_request (sap, connect_request_found, connect_request, cl_connection, connection);
              IF connect_request_found THEN
                establish_inbound_connection (sap, cl_connection, connection, connection_id);
                PUSH buffer_description: [1 .. description_upperbound];
                nlp$al_initialize_data_descrip (data_area, buffer_length, buffer_description^);
                deliver_connect_event (sap, connect_request, connection_id, buffer_description,
                      ^connect_event);
                nlp$select_timer (nac$gt_accept_timer_duration, 0, connection^.timer);
                nlp$cl_release_exclusive_access (cl_connection);
                release_sap_access;
                nap$gt_releas_exclusiv_to_clist;
                request_complete := TRUE;
              ELSE
                nap$gt_releas_exclusiv_to_clist;
                pmp$get_executing_task_gtid (requesting_task);
                sap^.connect_request_receiver.task := requesting_task;
                sap^.connect_request_receiver.activity_status := ^activity_status;
                sap^.connect_request_receiver.application_event := ^connect_event;
                IF description_upperbound <= nac$gt_fixed_fragments THEN
                  sap^.connect_request_receiver.application_buffer.description_kind := nac$gt_fixed;
                  nlp$al_initialize_data_descrip (data_area, buffer_length,
                        sap^.connect_request_receiver.application_buffer.fixed_description);
                ELSE
                  sap^.connect_request_receiver.application_buffer.description_kind := nac$gt_allocated;
                  REPEAT
                    ALLOCATE sap^.connect_request_receiver.application_buffer.allocated_description:
                          [1 .. description_upperbound] IN nav$network_paged_heap^;
                    IF sap^.connect_request_receiver.application_buffer.allocated_description = NIL THEN
                      syp$cycle;
                    IFEND;
                  UNTIL sap^.connect_request_receiver.application_buffer.allocated_description <> NIL;
                  nlp$al_initialize_data_descrip (data_area, buffer_length,
                        sap^.connect_request_receiver.application_buffer.allocated_description^);
                IFEND;
                sap^.connect_request_receiver.active := TRUE;
                activity_status.complete := FALSE;
                release_sap_access;
                IF wait = osc$wait THEN
                  pmp$wait (1000, 200);

                /wait_for_request_complete/
                  REPEAT
                    get_sap_access (sap_id, sap, server_job, internal_status);
                    IF internal_status.normal THEN
                      IF NOT sap^.connect_request_receiver.active OR
                            (sap^.connect_request_receiver.task <> requesting_task) THEN
                        request_complete := TRUE;
                        release_sap_access;
                      ELSE
                        release_sap_access;
                        pmp$wait (2000000, 2000000);
                      IFEND;
                    ELSE
                      request_complete := TRUE;
                    IFEND;
                  UNTIL request_complete;
                ELSE
                  request_complete := TRUE;
                IFEND;
              IFEND;
            ELSEIF wait = osc$wait THEN
              release_sap_access;
              nap$gt_releas_exclusiv_to_clist;
              pmp$wait (1000, 1000);
            ELSE
              release_sap_access;
              nap$gt_releas_exclusiv_to_clist;
              osp$set_status_abnormal (nac$status_id, nae$receive_outstanding, external_interface,
                    internal_status);
            IFEND;
          ELSE
            release_sap_access;
            nap$gt_releas_exclusiv_to_clist;
            osp$set_status_abnormal (nac$status_id, nae$client_receiving_connection, external_interface,
                  internal_status);
          IFEND;
        ELSE
          nap$gt_releas_exclusiv_to_clist;
        IFEND;
      WHILEND;
      osp$pop_inhibit_job_recovery;
      IF NOT internal_status.normal THEN
        status := internal_status;
      IFEND;
    ELSE
      osp$set_status_abnormal (nac$status_id, nae$data_area_too_small, external_interface, status);
    IFEND;
  PROCEND nap$gt_receive_connect_event;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$gt_deliver_connect_handler', EJECT ??
*copy nah$gt_deliver_connect_handler

  PROCEDURE [XDCL] nap$gt_deliver_connect_handler
    (    originator: ost$global_task_id;
         signal: pmt$signal);

    VAR
      sap: ^nat$gt_sap,
      cl_connection: ^nlt$cl_connection,
      connect_request: nat$gt_connect_request,
      condition_cause: nat$gt_condition_cause;

?? NEWTITLE := 'terminate_delivery', EJECT ??

    PROCEDURE terminate_delivery
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        status: ost$status;

      condition_status.normal := TRUE;
      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF condition_cause = nac$gt_application_data THEN
          nlp$ta_disconnect_connection (cl_connection, connect_request.data, condition_status);
          nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
          nlp$cl_clear_exclusive_access (cl_connection);
          activity_status := sap^.connect_request_receiver.activity_status;
          sap^.connect_request_receiver := nav$gt_null_connect_rq_receiver;
          clear_sap_access;
          nap$gt_clear_exclusive_to_clist;
          osp$pop_inhibit_job_recovery;
          condition_cause := nac$gt_activity_status;
          #SPOIL (condition_cause);
          osp$establish_condition_handler (^terminate_delivery, FALSE);
          activity_status^.complete := TRUE;
          osp$set_status_from_condition (nac$status_id, condition, sa, activity_status^.status, status);
          EXIT nap$gt_deliver_connect_handler;
        ELSE
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_delivery;
?? OLDTITLE, EJECT ??

    VAR
      sap_id: ^nat$gt_sap_identifier,
      processing_task: ost$global_task_id,
      connect_request_found: boolean,
      connection: ^nat$gt_connection,
      connection_id: nat$gt_connection_id,
      buffer_description: ^nlt$al_data_description,
      application_event: ^nat$gt_connect_event,
      activity_status: ^ost$activity_status,
      server_job: boolean,
      status: ost$status;

    sap_id := #LOC (signal.contents);
    condition_cause := nac$gt_request_not_cause;
    #SPOIL (condition_cause);
    osp$establish_condition_handler (^terminate_delivery, FALSE);
    osp$push_inhibit_job_recovery;
    nap$gt_get_exclusive_to_clist;
    get_server_sap_access (sap_id^, sap, status);
    IF status.normal THEN
      pmp$get_executing_task_gtid (processing_task);
      IF sap^.connect_request_receiver.active AND (sap^.connect_request_receiver.task = processing_task) THEN
        get_connect_request (sap, connect_request_found, connect_request, cl_connection, connection);
        IF connect_request_found THEN
          establish_inbound_connection (sap, cl_connection, connection, connection_id);
          application_event := sap^.connect_request_receiver.application_event;
          activity_status := sap^.connect_request_receiver.activity_status;
          CASE sap^.connect_request_receiver.application_buffer.description_kind OF
          = nac$gt_fixed =
            PUSH buffer_description: [1 .. UPPERBOUND (sap^.connect_request_receiver.application_buffer.
                  fixed_description.fragment)];
            buffer_description^ := sap^.connect_request_receiver.application_buffer.fixed_description;
            sap^.connect_request_receiver := nav$gt_null_connect_rq_receiver;
            condition_cause := nac$gt_application_data;
            #SPOIL (condition_cause);
            deliver_connect_event (sap, connect_request, connection_id, buffer_description,
                  application_event);
          = nac$gt_allocated =
            PUSH buffer_description: [1 .. UPPERBOUND (sap^.connect_request_receiver.application_buffer.
                  allocated_description^.fragment)];
            buffer_description^ := sap^.connect_request_receiver.application_buffer.allocated_description^;
            FREE sap^.connect_request_receiver.application_buffer.allocated_description IN
                  nav$network_paged_heap^;
            sap^.connect_request_receiver := nav$gt_null_connect_rq_receiver;
            condition_cause := nac$gt_application_data;
            #SPOIL (condition_cause);
            deliver_connect_event (sap, connect_request, connection_id, buffer_description,
                  application_event);
          CASEND;
          condition_cause := nac$gt_request_not_cause;
          #SPOIL (condition_cause);
          nlp$select_timer (nac$gt_accept_timer_duration, 0, connection^.timer);
          nlp$cl_release_exclusive_access (cl_connection);
          release_sap_access;
          nap$gt_releas_exclusiv_to_clist;
          condition_cause := nac$gt_activity_status;
          #SPOIL (condition_cause);
          activity_status^.complete := TRUE;
        ELSE
          release_sap_access;
          nap$gt_releas_exclusiv_to_clist;
        IFEND;
      ELSE
        release_sap_access;
        nap$gt_releas_exclusiv_to_clist;
      IFEND;
    ELSE
      nap$gt_releas_exclusiv_to_clist;
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$gt_deliver_connect_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$gt_reject_connection', EJECT ??
*copy nah$gt_reject_connection

  PROCEDURE [XDCL, #GATE] nap$gt_reject_connection
    (    connection_id: nat$gt_connection_id,
         data: nat$data_fragments;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      condition_cause: nat$gt_condition_cause;

?? NEWTITLE := 'terminate_reject_connection', EJECT ??

    PROCEDURE terminate_reject_connection
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF condition_cause = nac$gt_application_data THEN
          nlp$cl_clear_exclusive_access (cl_connection);
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
          EXIT nap$gt_reject_connection;
        ELSE
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_reject_connection;
?? OLDTITLE, EJECT ??

    VAR
      connection_to_delete: ^nat$gt_job_connection,
      connection: ^nat$gt_connection,
      data_length: nat$data_length,
      message_id: nlt$bm_message_id,
      internal_status: ost$status;

    status.normal := TRUE;

    IF UPPERBOUND (data) > nac$max_data_fragment_count THEN
      osp$set_status_condition (nae$maximum_data_fragments, status);
      RETURN;
    IFEND;

    nlp$al_get_data_length (data, data_length);
    IF data_length <= nac$gt_maximum_disconnect_data THEN
      condition_cause := nac$gt_request_not_cause;
      #SPOIL (condition_cause);
      osp$establish_condition_handler (^terminate_reject_connection, FALSE);
      osp$push_inhibit_job_recovery;
      nap$gt_get_exclusive_to_clist;
      get_connection_to_delete (connection_id, connection_to_delete, cl_connection, connection,
            internal_status);
      IF internal_status.normal THEN
        IF connection^.state = nac$gt_connect_req_delivered THEN
          delete_connection_from_sap (connection_id, connection_to_delete^.sap_id);
          nap$gt_delete_job_connection (connection_id);
          nap$gt_releas_exclusiv_to_clist;
          connection^.state := nac$gt_closed;
          nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
          condition_cause := nac$gt_application_data;
          #SPOIL (condition_cause);
          nlp$bm_create_message (data, message_id, internal_status);
          condition_cause := nac$gt_request_not_cause;
          #SPOIL (condition_cause);
          nlp$ta_disconnect_connection (cl_connection, message_id, internal_status);
          nlp$cl_release_exclusive_access (cl_connection);
        ELSE
          nap$gt_releas_exclusiv_to_clist;
          nlp$cl_release_exclusive_access (cl_connection);
          osp$set_status_abnormal (nac$status_id, nae$connection_not_proposed, external_interface,
                internal_status);
        IFEND;
      ELSE
        nap$gt_releas_exclusiv_to_clist;
      IFEND;
      osp$pop_inhibit_job_recovery;
      IF NOT internal_status.normal THEN
        osp$disestablish_cond_handler;
        status := internal_status;
      IFEND;
    ELSE
      osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, external_interface, status);
    IFEND;
  PROCEND nap$gt_reject_connection;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$gt_request_connection', EJECT ??
*copy nah$gt_request_connection

  PROCEDURE [XDCL, #GATE] nap$gt_request_connection
    (    sap_id: nat$gt_sap_identifier,
         destination: nat$network_address,
         data: nat$data_fragments;
         options: ^nat$gt_connection_options;
         preferred_protocol_class: nat$ta_preferred_protocol_class;
         alternate_protocol_class: nat$ta_alternate_protocol_class;
     VAR connection_id: nat$gt_connection_id;
     VAR status: ost$status);

?? NEWTITLE := 'terminate_request_connection', EJECT ??

    PROCEDURE terminate_request_connection
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF condition_cause = nac$gt_application_data THEN
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
          EXIT nap$gt_request_connection;
        ELSE
          osp$pop_inhibit_job_recovery;
          nap$gt_clear_exclusive_to_slist;
          nap$gt_clear_exclusive_to_clist;
          osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      = pmc$block_exit_processing =
        IF condition_cause = nac$gt_task_termination THEN
          IF cl_connection <> NIL THEN
            nlp$cl_deactivate_layer (nlc$osi_generic_xport_interface, cl_connection);
            nlp$cl_clear_exclusive_access (cl_connection);
          IFEND;
          osp$pop_inhibit_job_recovery;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_request_connection;
?? OLDTITLE, EJECT ??

    VAR
      active_sap: ^^nat$gt_sap,
      actual_destination_address: ^SEQ ( * ),
      checksum: boolean,
      condition_cause: nat$gt_condition_cause,
      connection: ^nat$gt_connection,
      cl_connection: ^nlt$cl_connection,
      data_length: nat$data_length,
      destination_network_address: ^SEQ ( * ),
      empty_message: nlt$bm_message_id,
      expedited_data: boolean,
      i: integer,
      ignore_layer_active: boolean,
      internal_status: ost$status,
      job_connection: ^nat$gt_job_connection,
      job_sap: ^nat$gt_job_sap,
      message_id: nlt$bm_message_id,
      sap_found: boolean,
      selector: nat$gt_sap_identifier,
      sap_connection: ^nat$gt_sap_connection;

    status.normal := TRUE;
    cl_connection := NIL;
    #SPOIL (cl_connection);

    IF UPPERBOUND (data) > nac$max_data_fragment_count THEN
      osp$set_status_condition (nae$maximum_data_fragments, status);
      RETURN;
    IFEND;

    nlp$al_get_data_length (data, data_length);
    IF data_length > nac$gt_maximum_connect_data THEN
      osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, external_interface, status);
      RETURN;
    IFEND;

    checksum := FALSE;
    expedited_data := FALSE;
    IF options <> NIL THEN
      FOR i := LOWERBOUND (options^) TO UPPERBOUND (options^) DO
        CASE options^ [i].kind OF
        = nac$gt_checksum =
          checksum := options^ [i].checksum;
        = nac$gt_expedited_data =
          expedited_data := options^ [i].expedited_data;
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$invalid_selector, external_interface, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'OPTIONS', status);
          osp$append_status_integer (osc$status_parameter_delimiter, i, 10, TRUE, status);
          RETURN;
        CASEND;
      FOREND;
    IFEND;

    IF (destination.kind <> nac$osi_transport_address) AND
          (destination.kind <> nac$osi_non_cdna_transport_addr) THEN
      osp$set_status_condition (nae$unsupported_address, status);
      RETURN;
    IFEND;

    destination_network_address := ^destination.osi_transport_address.network_address;
    RESET destination_network_address;
    IF (destination.osi_transport_address.network_address_length <= 0) OR
          (destination.osi_transport_address.network_address_length > nac$osi_max_network_address_len) THEN
      osp$set_status_condition (nae$unsupported_address, status);
      RETURN;
    IFEND;
    NEXT actual_destination_address: [[REP destination.osi_transport_address.network_address_length OF
          cell]] IN destination_network_address;
    IF actual_destination_address = NIL THEN
      osp$set_status_condition (nae$unsupported_address, status);
      RETURN;
    IFEND;

    condition_cause := nac$gt_application_data;
    #SPOIL (condition_cause);
    osp$establish_condition_handler (^terminate_request_connection, TRUE);
    osp$push_inhibit_job_recovery;
    nlp$bm_create_message (data, message_id, internal_status);
    condition_cause := nac$gt_request_not_cause;
    #SPOIL (condition_cause);
    nap$gt_get_exclusive_to_slist;
    job_sap := nav$gt_job_sap_list.first_sap;
    WHILE (job_sap <> NIL) AND (job_sap^.sap_id.osi_sap_identifier <> sap_id.osi_sap_identifier) DO
      job_sap := job_sap^.next_sap;
    WHILEND;
    IF job_sap <> NIL THEN
      selector := job_sap^.selector;
      nap$gt_releas_exclusiv_to_slist;
      nlp$cl_create_connection (nlc$osi_generic_xport_interface, cl_connection);
      IF cl_connection <> NIL THEN
        nlp$cl_activate_layer (nlc$osi_generic_xport_interface, cl_connection);
        nlp$cl_get_layer_connection (nlc$osi_generic_xport_interface, cl_connection, ignore_layer_active,
              connection);
        condition_cause := nac$gt_task_termination;
        #SPOIL (condition_cause);
        nlp$ta_request_connection (cl_connection, selector.osi_sap_identifier, checksum, message_id,
              destination.osi_transport_address.transport_sap_selector
              (1, destination.osi_transport_address.transport_sap_selector_length),
              actual_destination_address^, destination.kind = nac$osi_transport_address,
              expedited_data, sap_priority(sap_id), preferred_protocol_class, alternate_protocol_class,
              {quality_of_service =} NIL, internal_status);
        condition_cause := nac$gt_request_not_cause;
        #SPOIL (condition_cause);
        IF internal_status.normal THEN
          nap$gt_get_exclusive_to_clist;
          nap$gt_get_exclusive_to_slist;
          job_sap := nav$gt_job_sap_list.first_sap;
          WHILE (job_sap <> NIL) AND (job_sap^.sap_id.osi_sap_identifier <> sap_id.osi_sap_identifier) DO
            job_sap := job_sap^.next_sap;
          WHILEND;
          IF job_sap <> NIL THEN
            nap$gt_create_job_connection (sap_id, cl_connection^.identifier, job_connection);
            connection^ := nav$gt_null_connection;
            connection^.state := nac$gt_connect_request_sent;
            connection^.external_connection_id := job_connection^.connection_id;
            connection^.sap_id := selector;
            connection_id := job_connection^.connection_id;
            nlp$cl_release_exclusive_access (cl_connection);
            REPEAT
              ALLOCATE sap_connection IN nav$network_paged_heap^;
              IF sap_connection = NIL THEN
                syp$cycle;
              IFEND;
            UNTIL sap_connection <> NIL;
            sap_connection^.connection_id := job_connection^.connection_id;
            osp$begin_subsystem_activity;
            osp$set_job_signature_lock (nav$gt_sap_list.lock);
            find_active_sap (selector, active_sap, sap_found);
            sap_connection^.next_connection := active_sap^^.first_connection;
            active_sap^^.first_connection := sap_connection;
            osp$clear_job_signature_lock (nav$gt_sap_list.lock);
            osp$end_subsystem_activity;
          ELSE
            nlp$bm_create_message (nav$gt_null_message, empty_message, {ignore} internal_status);
            nlp$ta_disconnect_connection (cl_connection, empty_message, {ignore} internal_status);
            connection^.state := nac$gt_closed;
            nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
            nlp$cl_release_exclusive_access (cl_connection);
            osp$set_status_abnormal (nac$status_id, nae$sap_not_open, external_interface, internal_status);
          IFEND;
          nap$gt_releas_exclusiv_to_slist;
          nap$gt_releas_exclusiv_to_clist;
        ELSE
          nlp$cl_deactivate_layer (nlc$osi_generic_xport_interface, cl_connection);
          nlp$cl_release_exclusive_access (cl_connection);
          osp$set_status_condition (nae$destination_not_reachable, internal_status);
        IFEND;
      ELSE
        nlp$bm_release_message (message_id);
        osp$set_status_condition (nae$namve_max_connection_limit, internal_status);
      IFEND;
    ELSE
      nap$gt_releas_exclusiv_to_slist;
      nlp$bm_release_message (message_id);
      osp$set_status_abnormal (nac$status_id, nae$sap_not_open, external_interface, internal_status);
    IFEND;
    osp$pop_inhibit_job_recovery;
    osp$disestablish_cond_handler;
    IF NOT internal_status.normal THEN
      status := internal_status;
    IFEND;

  PROCEND nap$gt_request_connection;
?? OLDTITLE ??
?? NEWTITLE := 'send_data', EJECT ??

  PROCEDURE send_data
    (    cl_connection: ^nlt$cl_connection;
         connection: ^nat$gt_connection;
         current_connection_capacity: nat$data_length);

{
{   ENTRY REQUIREMENT: the process of sending data events is dependent on the caller having a condition
{                      handler established to field conditions arising from an invalid user data area.
{                      Further, it is expected that the condition handler performs the necessary actions
{                      to clean-up the outstanding request and report status to its user if such condition
{                      occurs.
{

    VAR
      data: ^array [1 .. * ] of nat$data_fragment,
      description_upperbound: integer,
      end_of_message: boolean,
      fragment_size: nat$data_length,
      ignore_rb: integer,
      ignore_status: ost$status,
      message: nlt$bm_message_id;

    IF current_connection_capacity > connection^.sender_request.remaining_bytes_to_send THEN
      fragment_size := connection^.sender_request.remaining_bytes_to_send;
    ELSE
      fragment_size := current_connection_capacity;
    IFEND;

    CASE connection^.sender_request.application_buffer.description_kind OF
    = nac$gt_fixed =
      nlp$al_get_data_requirements (connection^.sender_request.application_buffer.fixed_description.fragment,
            ignore_rb, description_upperbound);
      PUSH data: [1 .. description_upperbound];
      nlp$al_fragment_data (fragment_size, connection^.sender_request.application_buffer.fixed_description,
            connection^.sender_request.remaining_bytes_to_send, data^);
    = nac$gt_allocated =
      nlp$al_get_data_requirements (connection^.sender_request.application_buffer.allocated_description^.
            fragment, ignore_rb, description_upperbound);
      PUSH data: [1 .. description_upperbound];
      nlp$al_fragment_data (fragment_size, connection^.sender_request.application_buffer.
            allocated_description^, connection^.sender_request.remaining_bytes_to_send, data^);
      IF connection^.sender_request.remaining_bytes_to_send = 0 THEN
        FREE connection^.sender_request.application_buffer.allocated_description IN nav$network_paged_heap^;
      IFEND;
    CASEND;
    IF connection^.sender_request.remaining_bytes_to_send = 0 THEN
      nlp$cl_deactivate_sender (cl_connection);
      end_of_message := connection^.sender_request.end_of_message;
    ELSE
      end_of_message := FALSE;
    IFEND;
    nlp$bm_create_message (data^, message, ignore_status);
    nlp$ta_send_data (cl_connection, message, end_of_message, ignore_status);
  PROCEND send_data;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$gt_send_data', EJECT ??
*copy nah$gt_send_data

  PROCEDURE [XDCL, #GATE] nap$gt_send_data
    (    connection_id: nat$gt_connection_id;
         data: nat$data_fragments;
         end_of_message: boolean;
         wait: ost$wait;
     VAR activity_status: ost$activity_status;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      condition_cause: nat$gt_condition_cause,
      connection: ^nat$gt_connection;

?? NEWTITLE := 'terminate_send', EJECT ??

    PROCEDURE terminate_send
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        requesting_task: ost$global_task_id;

      condition_status.normal := TRUE;
      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF condition_cause = nac$gt_application_data THEN
          pmp$get_executing_task_gtid (requesting_task);
          IF cl_connection^.message_sender.active AND (cl_connection^.message_sender.task = requesting_task)
                THEN
            nlp$cl_deactivate_sender (cl_connection);
            IF ((connection^.sender_request.application_buffer.description_kind = nac$gt_allocated) AND
                  (connection^.sender_request.application_buffer.allocated_description <> NIL)) THEN
              FREE connection^.sender_request.application_buffer.allocated_description IN
                    nav$network_paged_heap^;
            IFEND;
            connection^.sender_request := nav$gt_null_sender_request;
          IFEND;
          nlp$cl_release_exclusive_access (cl_connection);
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
          EXIT nap$gt_send_data;
        ELSE
          IF cl_connection <> NIL THEN
            nlp$cl_release_exclusive_access (cl_connection);
          IFEND;
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_send;
?? OLDTITLE, EJECT ??

    VAR
      capacity: nat$data_length,
      connection_exists: boolean,
      description_upperbound: integer,
      internal_status: ost$status,
      layer_active: boolean,
      message_id: nlt$bm_message_id,
      requesting_task: ost$global_task_id,
      request_complete: boolean,
      send_data_length: integer;

    status.normal := TRUE;
    activity_status.status.normal := TRUE;
    activity_status.complete := TRUE;

    IF UPPERBOUND (data) > nac$max_data_fragment_count THEN
      osp$set_status_condition (nae$maximum_data_fragments, status);
      RETURN;
    IFEND;

    nlp$al_get_data_requirements (data, send_data_length, description_upperbound);
    IF send_data_length > nac$max_data_length THEN
      osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, 'nac$max_data_length', status);
      RETURN;
    IFEND;

    osp$push_inhibit_job_recovery;
    cl_connection := NIL;
    condition_cause := nac$gt_request_not_cause;
    #SPOIL (condition_cause, cl_connection);
    osp$establish_condition_handler (^terminate_send, FALSE);
    request_complete := FALSE;
    internal_status.normal := TRUE;

{ Loop until the connection lock is captured or until a current send has completed if wait is specified.

    WHILE NOT request_complete AND internal_status.normal DO
      get_connection_access (connection_id, cl_connection, connection, internal_status);
      IF internal_status.normal THEN
        IF connection^.state = nac$gt_open THEN
          IF NOT cl_connection^.message_sender.active THEN
            condition_cause := nac$gt_application_data;
            #SPOIL (condition_cause);
            nlp$al_get_data_requirements (data, send_data_length, description_upperbound);
            connection^.sender_request.remaining_bytes_to_send := send_data_length;
            nlp$osi_get_outbound_capacity (cl_connection, capacity);
            IF (capacity > 0) AND (capacity >= connection^.sender_request.remaining_bytes_to_send) THEN
              nlp$bm_create_message (data, message_id, {ignore_status} internal_status);
              nlp$ta_send_data (cl_connection, message_id, end_of_message, internal_status);
              condition_cause := nac$gt_request_not_cause;
              #SPOIL (condition_cause);
              nlp$cl_release_exclusive_access (cl_connection);
              request_complete := TRUE;
            ELSE
              nlp$cl_activate_sender (cl_connection);
              connection^.sender_request.end_of_message := end_of_message;
              connection^.sender_request.activity_status := ^activity_status;
              condition_cause := nac$gt_application_data;
              #SPOIL (condition_cause);
              IF description_upperbound <= nac$gt_fixed_fragments THEN
                connection^.sender_request.application_buffer.description_kind := nac$gt_fixed;
                nlp$al_initialize_data_descrip (data, connection^.sender_request.remaining_bytes_to_send,
                      connection^.sender_request.application_buffer.fixed_description);
              ELSE
                connection^.sender_request.application_buffer.description_kind := nac$gt_allocated;
                REPEAT
                  ALLOCATE connection^.sender_request.application_buffer.allocated_description:
                        [1 .. description_upperbound] IN nav$network_paged_heap^;
                  IF connection^.sender_request.application_buffer.allocated_description = NIL THEN
                    syp$cycle;
                  IFEND;
                UNTIL connection^.sender_request.application_buffer.allocated_description <> NIL;
                nlp$al_initialize_data_descrip (data, connection^.sender_request.remaining_bytes_to_send,
                      connection^.sender_request.application_buffer.allocated_description^);
              IFEND;

              WHILE (capacity > 0) AND (connection^.sender_request.remaining_bytes_to_send > 0) DO
                send_data (cl_connection, connection, capacity);
                nlp$osi_get_outbound_capacity (cl_connection, capacity);
              WHILEND;

              condition_cause := nac$gt_request_not_cause;
              #SPOIL (condition_cause);
              pmp$get_executing_task_gtid (requesting_task);
              nlp$cl_release_exclusive_access (cl_connection);
              IF connection^.sender_request.remaining_bytes_to_send > 0 THEN
                activity_status.complete := FALSE;
                IF (wait = osc$wait) THEN

                /wait_for_request_complete/
                  WHILE NOT request_complete DO
                    pmp$wait (1000, 100);
                    get_connection_access (connection_id, cl_connection, connection, internal_status);
                    IF internal_status.normal THEN
                      IF NOT cl_connection^.message_sender.active OR
                            (cl_connection^.message_sender.task <> requesting_task) THEN
                        request_complete := TRUE;
                      IFEND;
                      nlp$cl_release_exclusive_access (cl_connection);
                    ELSE
                      request_complete := TRUE;
                    IFEND;
                  WHILEND /wait_for_request_complete/;
                ELSE
                  request_complete := TRUE;
                IFEND;
              ELSE { IF connection^.sender_request.remaining_bytes_to_send = 0 THEN
                request_complete := TRUE;
              IFEND;
            IFEND;
          ELSEIF wait = osc$wait THEN
            nlp$cl_release_exclusive_access (cl_connection);
            pmp$wait (1000, 1000)
          ELSE
            nlp$cl_release_exclusive_access (cl_connection);
            osp$set_status_abnormal (nac$status_id, nae$send_outstanding, external_interface,
                  internal_status);
          IFEND;
        ELSE { The connection is not open.
          nlp$cl_release_exclusive_access (cl_connection);
          osp$set_status_abnormal (nac$status_id, nae$connection_not_open, external_interface,
                internal_status);
        IFEND;
      IFEND;
    WHILEND;
    osp$disestablish_cond_handler;
    osp$pop_inhibit_job_recovery;
    IF NOT internal_status.normal THEN
      status := internal_status;
    IFEND;
  PROCEND nap$gt_send_data;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$gt_send_data_handler', EJECT ??
*copy nah$gt_send_data_handler

  PROCEDURE [XDCL] nap$gt_send_data_handler
    (    originator: ost$global_task_id;
         signal: pmt$signal);

    VAR
      condition_cause: nat$gt_condition_cause;

?? NEWTITLE := 'terminate_send', EJECT ??

    PROCEDURE terminate_send
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        activity_status: ^ost$activity_status,
        status: ost$status;

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF condition_cause = nac$gt_application_data THEN
          activity_status := connection^.sender_request.activity_status;
          nlp$cl_deactivate_sender (cl_connection);
          IF ((connection^.sender_request.application_buffer.description_kind = nac$gt_allocated) AND
                (connection^.sender_request.application_buffer.allocated_description <> NIL)) THEN
            FREE connection^.sender_request.application_buffer.allocated_description IN
                  nav$network_paged_heap^;
          IFEND;
          connection^.sender_request := nav$gt_null_sender_request;
          osp$establish_condition_handler (^terminate_send, FALSE);
          condition_cause := nac$gt_activity_status;
          #SPOIL (condition_cause);
          activity_status^.complete := TRUE;
          osp$set_status_from_condition (nac$status_id, condition, sa, activity_status^.status,
                condition_status);
          nlp$cl_release_exclusive_access (cl_connection);
          osp$pop_inhibit_job_recovery;
          EXIT nap$gt_send_data_handler;
        ELSE
          IF cl_connection <> NIL THEN
            IF cl_connection^.message_receiver.active AND (cl_connection^.message_receiver.task =
                  processing_task) THEN
              nlp$cl_deactivate_receiver (cl_connection);
              IF ((connection^.receiver_request.application_buffer.description_kind = nac$gt_allocated) AND
                    (connection^.receiver_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.receiver_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              connection^.receiver_request := nav$gt_null_receiver_request;
            IFEND;
            IF cl_connection^.message_sender.active AND (cl_connection^.message_sender.task = processing_task)
                  THEN
              nlp$cl_deactivate_sender (cl_connection);
              IF ((connection^.sender_request.application_buffer.description_kind = nac$gt_allocated) AND
                    (connection^.sender_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.sender_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              connection^.sender_request := nav$gt_null_sender_request;
            IFEND;
            nlp$cl_release_exclusive_access (cl_connection);
          IFEND;
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_send;
?? OLDTITLE, EJECT ??

    VAR
      capacity: nat$data_length,
      cl_connection: ^nlt$cl_connection,
      cl_connection_id: ^nlt$cl_connection_id,
      connection: ^nat$gt_connection,
      connection_exists: boolean,
      layer_active: boolean,
      processing_task: ost$global_task_id;

    cl_connection_id := #LOC (signal.contents);
    osp$push_inhibit_job_recovery;
    condition_cause := nac$gt_request_not_cause;
    cl_connection := NIL;
    #SPOIL (condition_cause, cl_connection);
    osp$establish_condition_handler (^terminate_send, FALSE);
    nlp$cl_get_exclusive_via_cid (cl_connection_id^, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      pmp$get_executing_task_gtid (processing_task);
      IF layer_active AND cl_connection^.message_sender.active AND
            (cl_connection^.message_sender.task = processing_task) THEN
        nlp$osi_get_outbound_capacity (cl_connection, capacity);
        IF (capacity > 0) THEN
          WHILE (capacity > 0) AND (connection^.sender_request.remaining_bytes_to_send > 0) DO
            condition_cause := nac$gt_application_data;
            #SPOIL (condition_cause);
            send_data (cl_connection, connection, capacity);
            condition_cause := nac$gt_request_not_cause;
            #SPOIL (condition_cause);
            nlp$osi_get_outbound_capacity (cl_connection, capacity);
          WHILEND;
          condition_cause := nac$gt_activity_status;
          #SPOIL (condition_cause);
          connection^.sender_request.activity_status^.complete :=
                connection^.sender_request.remaining_bytes_to_send = 0;
          condition_cause := nac$gt_request_not_cause;
          #SPOIL (condition_cause);
        IFEND;
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$gt_send_data_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$gt_send_expedited_data', EJECT ??
*copy nah$gt_send_expedited_data

  PROCEDURE [XDCL, #GATE] nap$gt_send_expedited_data
    (    connection_id: nat$gt_connection_id,
         data: nat$data_fragments;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      condition_cause: nat$gt_condition_cause;

?? NEWTITLE := 'terminate_send_expedited', EJECT ??

    PROCEDURE terminate_send_expedited
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions =
        IF condition_cause = nac$gt_application_data THEN
          nlp$cl_release_exclusive_access (cl_connection);
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
          EXIT nap$gt_send_expedited_data;
        ELSE
          IF cl_connection <> NIL THEN
            nlp$cl_release_exclusive_access (cl_connection);
          IFEND;
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_send_expedited;
?? OLDTITLE, EJECT ??

    VAR
      connection: ^nat$gt_connection,
      data_length: nat$data_length,
      message_id: nlt$bm_message_id,
      internal_status: ost$status,
      local_status: ost$status;

    status.normal := TRUE;
    nlp$al_get_data_length (data, data_length);
    IF data_length <= nac$gt_maximum_expedited_data THEN
      osp$push_inhibit_job_recovery;
      cl_connection := NIL;
      osp$establish_condition_handler (^terminate_send_expedited, FALSE);
      condition_cause := nac$gt_request_not_cause;
      #SPOIL (condition_cause, cl_connection);
      get_connection_access (connection_id, cl_connection, connection, internal_status);
      IF internal_status.normal THEN
        IF connection^.state = nac$gt_open THEN
          condition_cause := nac$gt_application_data;
          #SPOIL (condition_cause);
          nlp$bm_create_message (data, message_id, internal_status);
          nlp$ta_send_expedited_data (cl_connection, message_id, internal_status);
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$connection_not_open, external_interface,
                internal_status);
        IFEND;
        nlp$cl_release_exclusive_access (cl_connection);
        osp$pop_inhibit_job_recovery;
      IFEND;
      IF NOT internal_status.normal THEN
        osp$disestablish_cond_handler;
        status := internal_status;
      IFEND;
    ELSE
      osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, external_interface, status);
    IFEND;
  PROCEND nap$gt_send_expedited_data;
?? OLDTITLE ??
?? NEWTITLE := 'sap_open', EJECT ??

  FUNCTION sap_open
    (    sap_id: nat$gt_sap_identifier): boolean;

    VAR
      job_sap: ^nat$gt_job_sap;

    job_sap := nav$gt_job_sap_list.first_sap;
    WHILE (job_sap <> NIL) AND (job_sap^.sap_id.osi_sap_identifier <> sap_id.osi_sap_identifier) DO
      job_sap := job_sap^.next_sap;
    WHILEND;
    sap_open := job_sap <> NIL;
  FUNCEND sap_open;
?? OLDTITLE ??
?? NEWTITLE := 'sap_priority', EJECT ??

  FUNCTION sap_priority
    (    sap_id: nat$gt_sap_identifier): nlt$ta_priority;

    VAR
      job_sap: ^nat$gt_job_sap;

    job_sap := nav$gt_job_sap_list.first_sap;
    WHILE (job_sap <> NIL) AND (job_sap^.sap_id.osi_sap_identifier <> sap_id.osi_sap_identifier) DO
      job_sap := job_sap^.next_sap;
    WHILEND;
    IF job_sap <> NIL THEN
      sap_priority := job_sap^.priority;
    ELSE
      sap_priority := 0;
    IFEND;
  FUNCEND sap_priority;
?? OLDTITLE ??
?? NEWTITLE := 'get_sap_access', EJECT ??

  PROCEDURE get_sap_access
    (    sap_id: nat$gt_sap_identifier;
     VAR sap: ^nat$gt_sap;
     VAR server_job: boolean;
     VAR status: ost$status);

    VAR
      ignore_sap_found: boolean,
      active_sap: ^^nat$gt_sap,
      job_sap: ^nat$gt_job_sap;

    status.normal := TRUE;
    nap$gt_get_exclusive_to_slist;
    job_sap := nav$gt_job_sap_list.first_sap;
    WHILE (job_sap <> NIL) AND (job_sap^.sap_id.osi_sap_identifier <> sap_id.osi_sap_identifier) DO
      job_sap := job_sap^.next_sap;
    WHILEND;
    IF job_sap <> NIL THEN
      server_job := job_sap^.shared_sap_server;
      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (nav$gt_sap_list.lock);
      find_active_sap (job_sap^.selector, active_sap, ignore_sap_found);
      sap := active_sap^;
    ELSE
      nap$gt_releas_exclusiv_to_slist;
      osp$set_status_abnormal (nac$status_id, nae$sap_not_open, external_interface, status);
    IFEND;
  PROCEND get_sap_access;
?? OLDTITLE ??
?? NEWTITLE := 'get_server_sap_access', EJECT ??

  PROCEDURE get_server_sap_access
    (    sap_id: nat$gt_sap_identifier;
     VAR sap: ^nat$gt_sap;
     VAR status: ost$status);

    VAR
      ignore_sap_found: boolean,
      active_sap: ^^nat$gt_sap,
      job_sap: ^nat$gt_job_sap;

    status.normal := TRUE;
    nap$gt_get_exclusive_to_slist;
    job_sap := nav$gt_job_sap_list.first_sap;
    /search_for_server_job_sap/
    WHILE (job_sap <> NIL) DO
      IF (job_sap^.selector.osi_sap_identifier = sap_id.osi_sap_identifier) AND
            (job_sap^.shared_sap_server) THEN
        EXIT /search_for_server_job_sap/;
      IFEND;
      job_sap := job_sap^.next_sap;
    WHILEND /search_for_server_job_sap/;
    IF job_sap <> NIL THEN
      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (nav$gt_sap_list.lock);
      find_active_sap (job_sap^.selector, active_sap, ignore_sap_found);
      sap := active_sap^;
    ELSE
      nap$gt_releas_exclusiv_to_slist;
      osp$set_status_abnormal (nac$status_id, nae$sap_not_open, external_interface, status);
    IFEND;
  PROCEND get_server_sap_access;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] release_sap_access'??
?? NEWTITLE := '[INLINE] clear_sap_access', EJECT ??

  PROCEDURE [INLINE] release_sap_access;

    osp$clear_job_signature_lock (nav$gt_sap_list.lock);
    osp$end_subsystem_activity;
    nap$gt_releas_exclusiv_to_slist;
  PROCEND release_sap_access;


  PROCEDURE [INLINE] clear_sap_access;

    VAR
      lock_status: ost$signature_lock_status;

    osp$test_sig_lock (nav$gt_sap_list.lock, lock_status);
    IF lock_status = osc$sls_locked_by_current_task THEN
      osp$clear_job_signature_lock (nav$gt_sap_list.lock);
      osp$end_subsystem_activity;
    IFEND;
    nap$gt_clear_exclusive_to_slist;
  PROCEND clear_sap_access;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] find_active_sap', EJECT ??

  PROCEDURE [INLINE] find_active_sap
    (    sap_id: nat$gt_sap_identifier;
     VAR active_sap: ^^nat$gt_sap;
     VAR sap_found: boolean);

    active_sap := ^nav$gt_sap_list.first_sap;
    WHILE (active_sap^ <> NIL) AND (active_sap^^.sap_id.osi_sap_identifier <> sap_id.osi_sap_identifier) DO
      active_sap := ^active_sap^^.next_sap;
    WHILEND;
    sap_found := active_sap^ <> NIL;
  PROCEND find_active_sap;
?? OLDTITLE ??
?? NEWTITLE := 'delete_connection_from_sap', EJECT ??

  PROCEDURE delete_connection_from_sap
    (    connection_id: nat$gt_connection_id;
         sap_id: nat$gt_sap_identifier);

    VAR
      active_sap: ^^nat$gt_sap,
      sap_connection: ^^nat$gt_sap_connection,
      connection_to_delete: ^nat$gt_sap_connection;

    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (nav$gt_sap_list.lock);
    active_sap := ^nav$gt_sap_list.first_sap;
    WHILE (active_sap^ <> NIL) AND (active_sap^^.sap_id.osi_sap_identifier <> sap_id.osi_sap_identifier) DO
      active_sap := ^active_sap^^.next_sap;
    WHILEND;
    IF (active_sap^ <> NIL) THEN
      sap_connection := ^active_sap^^.first_connection;
      WHILE (sap_connection^ <> NIL) AND (sap_connection^^.connection_id <> connection_id) DO
        sap_connection := ^sap_connection^^.next_connection;
      WHILEND;
      IF sap_connection^ <> NIL THEN
        connection_to_delete := sap_connection^;
        sap_connection^ := sap_connection^^.next_connection;
        FREE connection_to_delete IN nav$network_paged_heap^;
      IFEND;
    IFEND;
    osp$clear_job_signature_lock (nav$gt_sap_list.lock);
    osp$end_subsystem_activity;
  PROCEND delete_connection_from_sap;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_sap_to_delete', EJECT ??

  PROCEDURE [INLINE] get_sap_to_delete
    (    sap_id: nat$gt_sap_identifier;
     VAR sap_to_delete: ^nat$gt_job_sap;
     VAR status: ost$status);

    status.normal := TRUE;
    sap_to_delete := nav$gt_job_sap_list.first_sap;
    WHILE (sap_to_delete<>NIL) AND (sap_to_delete^.sap_id.osi_sap_identifier <> sap_id.osi_sap_identifier) DO
      sap_to_delete := sap_to_delete^.next_sap;
    WHILEND;
    IF sap_to_delete = NIL THEN
      osp$set_status_abnormal (nac$status_id, nae$sap_not_open, external_interface, status);
    IFEND;
  PROCEND get_sap_to_delete;
?? OLDTITLE ??
?? NEWTITLE := 'get_connection_to_delete', EJECT ??

  PROCEDURE get_connection_to_delete
    (    connection_id: nat$gt_connection_id;
     VAR connection_to_delete: ^nat$gt_job_connection;
     VAR cl_connection: ^nlt$cl_connection;
     VAR connection: ^nat$gt_connection;
     VAR status: ost$status);

    VAR
      job_connection: ^nat$gt_job_connection,
      connection_exists: boolean,
      layer_active: boolean,
      termination_condition: ost$status_condition;

    status.normal := TRUE;
    job_connection := nav$gt_job_connection_list.first_connection;
    WHILE (job_connection <> NIL) AND (job_connection^.connection_id <> connection_id) DO
      job_connection := job_connection^.next_connection;
    WHILEND;
    IF ((job_connection <> NIL) AND job_connection^.active) THEN
      nlp$cl_get_exclusive_via_cid (job_connection^.active_connection_id, connection_exists, cl_connection);
      IF connection_exists THEN
        nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active,
              connection);
        IF layer_active THEN
          IF connection^.state IN $nat$gt_connection_states [nac$gt_peer_reject, nac$gt_peer_disconnect,
                nac$gt_connection_failed] THEN
            CASE connection^.state OF
            = nac$gt_peer_disconnect =
              nlp$bm_release_message (connection^.event_queue.beginning^.event.osi_disconnect.data);
              termination_condition := nae$conn_terminated_by_peer;
            = nac$gt_connection_failed =
              termination_condition := nae$connection_failed;
            ELSE
            CASEND;
            FREE connection^.event_queue.beginning IN nav$network_paged_heap^;
            nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
            nlp$cl_release_exclusive_access (cl_connection);
            delete_connection_from_sap (connection_id, job_connection^.sap_id);
            nap$gt_delete_job_connection (connection_id);
            osp$set_status_abnormal (nac$status_id, termination_condition, external_interface, status);
          ELSE
            connection_to_delete := job_connection;
          IFEND;
        ELSE
          nlp$cl_release_exclusive_access (cl_connection);
          delete_connection_from_sap (connection_id, job_connection^.sap_id);
          nap$gt_delete_job_connection (connection_id);
          osp$set_status_abnormal (nac$status_id, nae$connection_failed, external_interface, status);
        IFEND;
      ELSE
        delete_connection_from_sap (connection_id, job_connection^.sap_id);
        nap$gt_delete_job_connection (connection_id);
        osp$set_status_abnormal (nac$status_id, nae$connection_failed, external_interface, status);
      IFEND;
    ELSEIF job_connection <> NIL THEN
      CASE job_connection^.termination_state OF
      = nac$gt_peer_disconnect =
        termination_condition := nae$conn_terminated_by_peer;
      = nac$gt_connection_failed =
        termination_condition := nae$connection_failed;
      ELSE
      CASEND;
      delete_connection_from_sap (connection_id, job_connection^.sap_id);
      nap$gt_delete_job_connection (connection_id);
      osp$set_status_abnormal (nac$status_id, termination_condition, external_interface, status);
    ELSE
      osp$set_status_abnormal (nac$status_id, nae$connection_not_open, external_interface, status);
    IFEND;
  PROCEND get_connection_to_delete;
?? OLDTITLE ??
?? NEWTITLE := 'get_connection_access', EJECT ??

  PROCEDURE get_connection_access
    (    connection_id: nat$gt_connection_id;
     VAR cl_connection: ^nlt$cl_connection;
     VAR connection: ^nat$gt_connection;
     VAR status: ost$status);

    VAR
      job_connection: ^nat$gt_job_connection,
      connection_exists: boolean,
      layer_active: boolean,
      termination_condition: ost$status_condition;

    status.normal := TRUE;
    nap$gt_get_exclusive_to_clist;
    job_connection := nav$gt_job_connection_list.first_connection;
    WHILE (job_connection <> NIL) AND (job_connection^.connection_id <> connection_id) DO
      job_connection := job_connection^.next_connection;
    WHILEND;
    IF ((job_connection <> NIL) AND job_connection^.active) THEN
      nlp$cl_get_exclusive_via_cid (job_connection^.active_connection_id, connection_exists, cl_connection);
      IF connection_exists THEN
        nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active,
              connection);
        IF layer_active THEN
          IF connection^.state IN $nat$gt_connection_states [nac$gt_peer_reject, nac$gt_peer_disconnect,
                nac$gt_connection_failed] THEN
            nap$gt_deactivate_job_connect (connection^.state, connection^.event_queue.beginning^.event,
                  connection^.event_queue.beginning^.data_length, job_connection);
            CASE connection^.state OF
            = nac$gt_peer_reject, nac$gt_peer_disconnect =
              termination_condition := nae$conn_terminated_by_peer;
            = nac$gt_connection_failed =
              termination_condition := nae$connection_failed;
            CASEND;
            FREE connection^.event_queue.beginning IN nav$network_paged_heap^;
            connection^.state := nac$gt_closed;
            nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
            nlp$cl_release_exclusive_access (cl_connection);
            osp$set_status_abnormal (nac$status_id, termination_condition, external_interface, status);
          IFEND;
        ELSE
          nlp$cl_release_exclusive_access (cl_connection);
          delete_connection_from_sap (connection_id, job_connection^.sap_id);
          nap$gt_delete_job_connection (connection_id);
          osp$set_status_abnormal (nac$status_id, nae$connection_failed, external_interface, status);
        IFEND;
      ELSE
        delete_connection_from_sap (connection_id, job_connection^.sap_id);
        nap$gt_delete_job_connection (connection_id);
        osp$set_status_abnormal (nac$status_id, nae$connection_failed, external_interface, status);
      IFEND;
    ELSEIF job_connection <> NIL THEN
      CASE job_connection^.termination_state OF
      = nac$gt_peer_reject, nac$gt_peer_disconnect =
        termination_condition := nae$conn_terminated_by_peer;
      = nac$gt_connection_failed =
        termination_condition := nae$connection_failed;
      CASEND;
      osp$set_status_abnormal (nac$status_id, termination_condition, external_interface, status);
    ELSE
      osp$set_status_abnormal (nac$status_id, nae$connection_not_open, external_interface, status);
    IFEND;
    nap$gt_releas_exclusiv_to_clist;
  PROCEND get_connection_access;
?? OLDTITLE ??
?? NEWTITLE := 'delete_queued_events', EJECT ??

  PROCEDURE delete_queued_events
    (    connection: ^nat$gt_connection);

    VAR
      event_queue: ^^nat$gt_event_element,
      event_element: ^nat$gt_event_element,
      message_id: nlt$bm_message_id;

    event_queue := ^connection^.event_queue.beginning;
    WHILE event_queue^ <> NIL DO
      CASE event_queue^^.event.kind OF
      = nlc$ta_connect_confirm_event =
        message_id := event_queue^^.event.osi_connect_confirm.data;
        nlp$bm_release_message (message_id);
      = nlc$ta_data_event =
        message_id := event_queue^^.event.osi_data.data;
        nlp$bm_release_message (message_id);
      = nlc$ta_expedited_data_event =
        message_id := event_queue^^.event.osi_expedited_data.data;
        nlp$bm_release_message (message_id);
      = nlc$ta_disconnect_event =
        IF event_queue^^.event.osi_disconnect.proprietary_reason = nlc$ta_user_disconnect_request THEN
          message_id := event_queue^^.event.osi_disconnect.data;
          nlp$bm_release_message (message_id);
        IFEND;
      CASEND;
      event_element := event_queue^;
      event_queue^ := event_queue^^.next_event;
      FREE event_element IN nav$network_paged_heap^;
    WHILEND;
    connection^.undelivered_message_buffers := 0;
    connection^.event_queue.ending := NIL;
  PROCEND delete_queued_events;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] activate_sender_task', EJECT ??

  PROCEDURE [INLINE] activate_sender_task
    (    cl_connection: ^nlt$cl_connection);

    VAR
      cl_connection_id: ^nlt$cl_connection_id,
      signal: pmt$signal,
      status: ost$status;

    signal.identifier := nac$gt_send_data;
    cl_connection_id := #LOC (signal.contents);
    cl_connection_id^ := cl_connection^.identifier;
    pmp$send_signal (cl_connection^.message_sender.task, signal, status);
    IF NOT status.normal THEN
      nlp$cl_deactivate_sender (cl_connection);
    IFEND;
  PROCEND activate_sender_task;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] activate_receiver_task', EJECT ??

  PROCEDURE [INLINE] activate_receiver_task
    (    cl_connection: ^nlt$cl_connection);

    VAR
      cl_connection_id: ^nlt$cl_connection_id,
      signal: pmt$signal,
      status: ost$status;

    signal.identifier := nac$gt_deliver_data;
    cl_connection_id := #LOC (signal.contents);
    cl_connection_id^ := cl_connection^.identifier;
    pmp$send_signal (cl_connection^.message_receiver.task, signal, status);
    IF NOT status.normal THEN
      nlp$cl_deactivate_receiver (cl_connection);
    IFEND;
  PROCEND activate_receiver_task;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$gt_process_connection_event'??
?? NEWTITLE := 'continue_send_data'??
?? NEWTITLE := 'terminate_send', EJECT ??

  PROCEDURE [XDCL] nap$gt_process_connection_event
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$ta_event;
     VAR inventory_report: nlt$ta_inventory_report);

    VAR
      status: ost$status;

    PROCEDURE continue_send_data
      (    connection: ^nat$gt_connection;
           cl_connection: ^nlt$cl_connection);

      VAR
        processing_task: ost$global_task_id,
        condition_cause: nat$gt_condition_cause;

      PROCEDURE terminate_send
        (    condition: pmt$condition;
             ignore_condition_descriptor: ^pmt$condition_information;
             sa: ^ost$stack_frame_save_area;
         VAR condition_status: ost$status);

        VAR
          activity_status: ^ost$activity_status,
          status: ost$status;

        CASE condition.selector OF
        = pmc$system_conditions, mmc$segment_access_condition =
          IF condition_cause = nac$gt_application_data THEN
            activity_status := connection^.sender_request.activity_status;
            nlp$cl_deactivate_sender (cl_connection);
            IF ((connection^.sender_request.application_buffer.description_kind = nac$gt_allocated) AND
                  (connection^.sender_request.application_buffer.allocated_description <> NIL)) THEN
              FREE connection^.sender_request.application_buffer.allocated_description IN
                    nav$network_paged_heap^;
            IFEND;
            connection^.sender_request := nav$gt_null_sender_request;
            osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
            osp$establish_condition_handler (^terminate_send, FALSE);
            condition_cause := nac$gt_activity_status;
            #SPOIL (condition_cause);
            activity_status^.complete := TRUE;
            activity_status^.status := status;
            EXIT continue_send_data;
          ELSEIF condition_cause = nac$gt_activity_status THEN
            IF cl_connection^.message_receiver.active AND (cl_connection^.message_receiver.task =
                  processing_task) THEN
              nlp$cl_deactivate_receiver (cl_connection);
              connection^.receiver_request := nav$gt_null_receiver_request;
            IFEND;
            IF cl_connection^.message_sender.active AND (cl_connection^.message_sender.task = processing_task)
                  THEN
              nlp$cl_deactivate_sender (cl_connection);
              connection^.sender_request := nav$gt_null_sender_request;
            IFEND;
            osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
          ELSE
            osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
          IFEND;
        = pmc$user_defined_condition =
          IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
            pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          IFEND;
          condition_status.normal := TRUE;
        ELSE
          condition_status.normal := TRUE;
        CASEND;
      PROCEND terminate_send;
?? OLDTITLE, EJECT ??

      VAR
        capacity: nat$data_length;

      pmp$get_executing_task_gtid (processing_task);
      IF cl_connection^.message_sender.active AND (cl_connection^.message_sender.task = processing_task) THEN
        nlp$osi_get_outbound_capacity (cl_connection, capacity);
        IF (capacity > 0) THEN
          osp$establish_condition_handler (^terminate_send, FALSE);
          condition_cause := nac$gt_application_data;
          #SPOIL (condition_cause);
          WHILE (capacity > 0) AND (connection^.sender_request.remaining_bytes_to_send > 0) DO
            send_data (cl_connection, connection, capacity);
            nlp$osi_get_outbound_capacity (cl_connection, capacity);
          WHILEND;
          condition_cause := nac$gt_activity_status;
          #SPOIL (condition_cause);
          connection^.sender_request.activity_status^.complete :=
                connection^.sender_request.remaining_bytes_to_send = 0;
        IFEND;
      ELSEIF cl_connection^.message_sender.active THEN
        activate_sender_task (cl_connection);
      IFEND;
    PROCEND continue_send_data;
?? OLDTITLE ??
?? NEWTITLE := 'reassemble_data'??
?? NEWTITLE := 'terminate_reassemble_data', EJECT ??

    PROCEDURE reassemble_data
      (VAR event {INPUT} : nlt$ta_event;
           connection: ^nat$gt_connection;
           cl_connection: ^nlt$cl_connection);

      VAR
        processing_task: ost$global_task_id,
        condition_cause: nat$gt_condition_cause;


      PROCEDURE terminate_reassemble_data
        (    condition: pmt$condition;
             ignore_condition_descriptor: ^pmt$condition_information;
             sa: ^ost$stack_frame_save_area;
         VAR condition_status: ost$status);

        CASE condition.selector OF
        = pmc$system_conditions, mmc$segment_access_condition =
          IF condition_cause = nac$gt_application_data THEN
            nlp$cl_deactivate_receiver (cl_connection);
            IF ((connection^.receiver_request.application_buffer.description_kind = nac$gt_allocated) AND
                  (connection^.receiver_request.application_buffer.allocated_description <> NIL)) THEN
              FREE connection^.receiver_request.application_buffer.allocated_description IN
                    nav$network_paged_heap^;
            IFEND;
            connection^.receiver_request := nav$gt_null_receiver_request;
            osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
            osp$establish_condition_handler (^terminate_reassemble_data, FALSE);
            condition_cause := nac$gt_activity_status;
            #SPOIL (condition_cause);
            activity_status^.complete := TRUE;
            activity_status^.status := status;
            EXIT reassemble_data;
          ELSEIF condition_cause = nac$gt_activity_status THEN
            IF cl_connection^.message_receiver.active AND (cl_connection^.message_receiver.task =
                  processing_task) THEN
              nlp$cl_deactivate_receiver (cl_connection);
              connection^.receiver_request := nav$gt_null_receiver_request;
            IFEND;
            IF cl_connection^.message_sender.active AND (cl_connection^.message_sender.task = processing_task)
                  THEN
              nlp$cl_deactivate_sender (cl_connection);
              connection^.sender_request := nav$gt_null_sender_request;
            IFEND;
            nlp$ta_report_undelivered_data (cl_connection, connection^.undelivered_message_buffers);
            osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
          ELSE
            osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
          IFEND;
        = pmc$user_defined_condition =
          IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
            pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          IFEND;
          condition_status.normal := TRUE;
        ELSE
          condition_status.normal := TRUE;
        CASEND;
      PROCEND terminate_reassemble_data;
?? OLDTITLE, EJECT ??

      VAR
        event_element: ^nat$gt_event_element,
        data_length: integer,
        number_of_buffers: integer,
        component_list: array [1 .. 2] of nlt$bm_message_id,
        delivery_complete: boolean,
        activity_status: ^ost$activity_status;

      nlp$bm_get_message_resources (event.osi_data.data, data_length, number_of_buffers);
      connection^.undelivered_message_buffers := connection^.undelivered_message_buffers + number_of_buffers;
      IF connection^.event_queue.ending <> NIL THEN
        IF ((connection^.event_queue.ending^.event.kind = nlc$ta_data_event) AND
              NOT connection^.event_queue.ending^.event.osi_data.end_of_message) THEN
          component_list [1] := connection^.event_queue.ending^.event.osi_data.data;
          component_list [2] := event.osi_data.data;
          nlp$bm_concatenate_messages (component_list, connection^.event_queue.ending^.event.osi_data.data);
          connection^.event_queue.ending^.data_length := connection^.event_queue.ending^.data_length +
                data_length;
          connection^.event_queue.ending^.event.osi_data.end_of_message := event.osi_data.end_of_message;
        ELSE
          REPEAT
            ALLOCATE event_element IN nav$network_paged_heap^;
            IF event_element = NIL THEN
              syp$cycle;
            IFEND;
          UNTIL event_element <> NIL;
          event_element^.data_length := data_length;
          event_element^.event := event;
          event_element^.next_event := NIL;
          connection^.event_queue.ending^.next_event := event_element;
          connection^.event_queue.ending := event_element;
        IFEND;
      ELSE
        REPEAT
          ALLOCATE event_element IN nav$network_paged_heap^;
          IF event_element = NIL THEN
            syp$cycle;
          IFEND;
        UNTIL event_element <> NIL;
        event_element^.data_length := data_length;
        event_element^.event := event;
        event_element^.next_event := NIL;
        connection^.event_queue.beginning := event_element;
        connection^.event_queue.ending := event_element;
        nlp$select_timer (nac$gt_event_timer_duration, 0, connection^.timer);
      IFEND;
      pmp$get_executing_task_gtid (processing_task);
      IF cl_connection^.message_receiver.active AND (cl_connection^.message_receiver.task = processing_task)
            THEN
        osp$establish_condition_handler (^terminate_reassemble_data, FALSE);
        condition_cause := nac$gt_application_data;
        #SPOIL (condition_cause);
        deliver_connection_events (connection, cl_connection, delivery_complete);
        IF delivery_complete THEN
          nlp$cl_deactivate_receiver (cl_connection);
          activity_status := connection^.receiver_request.activity_status;
          connection^.receiver_request := nav$gt_null_receiver_request;
          condition_cause := nac$gt_activity_status;
          #SPOIL (condition_cause);
          activity_status^.complete := TRUE;
        IFEND;
      ELSEIF cl_connection^.message_receiver.active THEN
        activate_receiver_task (cl_connection);
      IFEND;
    PROCEND reassemble_data;
?? OLDTITLE ??
?? NEWTITLE := 'queue_event', EJECT ??

    PROCEDURE queue_event
      (VAR event {INPUT} : nlt$ta_event;
           connection: ^nat$gt_connection;
           cl_connection: ^nlt$cl_connection);

      VAR
        event_element: ^nat$gt_event_element;

      CASE event.kind OF
      = nlc$ta_expedited_data_event =
        REPEAT
          ALLOCATE event_element IN nav$network_paged_heap^;
          IF event_element = NIL THEN
            syp$cycle;
          IFEND;
        UNTIL event_element <> NIL;
        event_element^.event := event;
        event_element^.next_event := NIL;
        nlp$bm_get_message_length (event.osi_expedited_data.data, event_element^.data_length);
        IF connection^.event_queue.beginning = NIL THEN
          connection^.event_queue.beginning := event_element;
          connection^.event_queue.ending := event_element;
          nlp$select_timer (nac$gt_event_timer_duration, 0, connection^.timer);
          IF cl_connection^.message_receiver.active THEN
            activate_receiver_task (cl_connection);
          IFEND;
        ELSE
          connection^.event_queue.ending^.next_event := event_element;
          connection^.event_queue.ending := event_element;
        IFEND;

      = nlc$ta_disconnect_event =
        delete_queued_events (connection);
        IF connection^.state <> nac$gt_connect_request_received THEN
          REPEAT
            ALLOCATE event_element IN nav$network_paged_heap^;
            IF event_element = NIL THEN
              syp$cycle;
            IFEND;
          UNTIL event_element <> NIL;
          event_element^.event := event;
          event_element^.next_event := NIL;
          connection^.event_queue.beginning := event_element;
          connection^.event_queue.ending := event_element;
          IF event.osi_disconnect.proprietary_reason = nlc$ta_user_disconnect_request THEN
            nlp$bm_get_message_length (event.osi_disconnect.data, event_element^.data_length);
            connection^.state := nac$gt_peer_disconnect;
          ELSE
            event_element^.data_length := 0;
            connection^.state := nac$gt_connection_failed;
          IFEND;
          nlp$select_timer (nac$gt_event_timer_duration, 0, connection^.timer);
          IF cl_connection^.message_receiver.active THEN
            activate_receiver_task (cl_connection);
          IFEND;
        ELSE { Application has not received connect request -- terminate connection. }
          nlp$bm_release_message (event.osi_disconnect.data);
          connection^.state := nac$gt_closed;
          nlp$cl_deactivate_layer (nlc$osi_generic_xport_interface, cl_connection);
        IFEND;

      = nlc$ta_connect_confirm_event =
        REPEAT
          ALLOCATE event_element IN nav$network_paged_heap^;
          IF event_element = NIL THEN
            syp$cycle;
          IFEND;
        UNTIL event_element <> NIL;
        event_element^.event := event;
        event_element^.next_event := NIL;
        connection^.event_queue.beginning := event_element;
        connection^.event_queue.ending := event_element;
        nlp$bm_get_message_length (event_element^.event.osi_connect_confirm.data, event_element^.data_length);
        connection^.state := nac$gt_accept_received;
        nlp$select_timer (nac$gt_event_timer_duration, 0, connection^.timer);
        IF cl_connection^.message_receiver.active THEN
          activate_receiver_task (cl_connection);
        IFEND;
      ELSE
      CASEND;
    PROCEND queue_event;
?? OLDTITLE, EJECT ??

    VAR
      layer_active: boolean,
      connection: ^nat$gt_connection,
      connection_event: nlt$ta_event;

    nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
    IF event.kind = nlc$ta_data_event THEN
      connection_event := event;
      reassemble_data (connection_event, connection, cl_connection);
      inventory_report.changed := TRUE;
      inventory_report.accumulated_message_buffers := connection^.undelivered_message_buffers;
    ELSEIF event.kind = nlc$ta_clear_to_send_event THEN
      continue_send_data (connection, cl_connection);
      inventory_report.changed := FALSE;
    ELSE
      connection_event := event;
      queue_event (connection_event, connection, cl_connection);
      inventory_report.changed := FALSE;
    IFEND;
  PROCEND nap$gt_process_connection_event;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$gt_process_sap_event', EJECT ??

  PROCEDURE [XDCL] nap$gt_process_sap_event
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$ta_event;
     VAR inventory_report: nlt$ta_inventory_report);

    VAR
      connect_request: ^nat$gt_connect_request,
      connection: ^nat$gt_connection,
      layer_active: boolean,
      message_id: nlt$bm_message_id,
      sap: ^nat$gt_sap,
      sap_id: ^nat$gt_sap_identifier,
      signal: pmt$signal,
      status: ost$status;

    inventory_report.changed := FALSE;
    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (nav$gt_sap_list.lock);
    sap := nav$gt_sap_list.first_sap;
    WHILE (sap <> NIL) AND (sap^.sap_id.osi_sap_identifier <> event.osi_connect.destination_transport_sap) DO
      sap := sap^.next_sap;
    WHILEND;
    IF (sap <> NIL) AND
          ((NOT sap^.opened_via_share) OR ((sap^.opened_via_share) AND (sap^.shared_sap_server_active))) THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      ALLOCATE connect_request IN nav$network_paged_heap^;
      IF connect_request <> NIL THEN
        connection^ := nav$gt_null_connection;
        connection^.state := nac$gt_connect_request_received;
        connection^.sap_id := sap^.sap_id;
        nlp$cl_activate_layer (cl_connection^.application_layer, cl_connection);
        connect_request^.next_connect_request := NIL;
        connect_request^.connection_id := cl_connection^.identifier;
        nlp$bm_get_message_length (event.osi_connect.data, connect_request^.data_length);
        connect_request^.data := event.osi_connect.data;
        connect_request^.source.kind := osi;
        connect_request^.source.osi_address := event.osi_connect.source_address;
        connect_request^.checksum := event.osi_connect.checksum;
        connect_request^.expedited_data := event.osi_connect.expedited_data;
        IF sap^.connect_request_queue.beginning = NIL THEN
          sap^.connect_request_queue.beginning := connect_request;
          sap^.connect_request_queue.ending := connect_request;
          nlp$select_timer (nac$gt_sap_event_timer_duration, 0, sap^.event_timer);
          IF sap^.connect_request_receiver.active THEN
            signal.identifier := nac$gt_deliver_connect_request;
            sap_id := #LOC (signal.contents);
            sap_id^ := sap^.sap_id;
            pmp$send_signal (sap^.connect_request_receiver.task, signal, {ignore} status);
          IFEND;
        ELSE
          sap^.connect_request_queue.ending^.next_connect_request := connect_request;
          sap^.connect_request_queue.ending := connect_request;
        IFEND;
      ELSE
        message_id := event.osi_connect.data;
        nlp$ta_disconnect_connection (cl_connection, message_id, status);
      IFEND;
      osp$clear_job_signature_lock (nav$gt_sap_list.lock);
      osp$end_subsystem_activity;
    ELSE
      message_id := event.osi_connect.data;
      nlp$ta_disconnect_connection (cl_connection, message_id, status);
      osp$clear_job_signature_lock (nav$gt_sap_list.lock);
      osp$end_subsystem_activity;
    IFEND;
  PROCEND nap$gt_process_sap_event;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$gt_evaluate_connect_timers', EJECT ??

  PROCEDURE [XDCL] nap$gt_evaluate_connect_timers
    (    current_time: integer;
         cl_connection: ^nlt$cl_connection);

    VAR
      layer_active: boolean,
      connection: ^nat$gt_connection,
      empty_message: nlt$bm_message_id,
      ignore_status: ost$status;

    nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
    IF layer_active THEN
      IF nlp$timer_expired (current_time, connection^.timer) THEN
        delete_queued_events (connection);
        nlp$bm_create_message (nav$gt_null_message, empty_message, ignore_status);
        nlp$ta_disconnect_connection (cl_connection, empty_message, ignore_status);
        connection^.state := nac$gt_closed;
        nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
      IFEND;
    IFEND;
  PROCEND nap$gt_evaluate_connect_timers;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$gt_evaluate_sap_timers', EJECT ??

  PROCEDURE [XDCL] nap$gt_evaluate_sap_timers
    (    current_time: integer);

    VAR
      sap: ^nat$gt_sap,
      connect_request: ^nat$gt_connect_request;

    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (nav$gt_sap_list.lock);
    sap := nav$gt_sap_list.first_sap;
    WHILE (sap <> NIL) DO
      IF nlp$timer_expired (current_time, sap^.event_timer) THEN
        IF sap^.connect_request_queue.beginning <> NIL THEN
          connect_request := sap^.connect_request_queue.beginning;
          sap^.connect_request_queue.beginning := connect_request^.next_connect_request;
          IF sap^.connect_request_queue.beginning = NIL THEN
            sap^.connect_request_queue.ending := NIL;
          IFEND;
          reject_connection (connect_request^.connection_id, connect_request^.data);
          FREE connect_request IN nav$network_paged_heap^;
          nlp$select_timer (nac$gt_sap_event_timer_duration, 0, sap^.event_timer)
        ELSE
          nlp$cancel_timer (sap^.event_timer)
        IFEND;
      IFEND;
      sap := sap^.next_sap;
    WHILEND;
    osp$clear_job_signature_lock (nav$gt_sap_list.lock);
    osp$end_subsystem_activity;
  PROCEND nap$gt_evaluate_sap_timers;
?? OLDTITLE ??
MODEND nam$external_gt_interface;
*DECK DECK=NAM$FETCH_ATTRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE nam$fetch_attributes;

{ MODULE DECK NAM$FETCH_ATTRIBUTES }

?? TITLE := 'NOS/VE :  NETWORK ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] NAM$FETCH_ATTRIBUTES' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc nak$external_keypoints_job_mode
*copyc nat$external_keypoint_constants
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
?? EJECT ??
*copyc nah$fetch_attributes
 PROCEDURE [XDCL,#GATE] nap$fetch_attributes (
        file_identifier: amt$file_identifier;
    VAR attributes: {input, output} nat$get_attributes;
    VAR status: ost$status);

    CONST
      interface_name = 'NAP$FETCH_ATTRIBUTES',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, osk$m * amk_fetch_attributes, nak$session_external);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, osk$m * amk_fetch_attributes, nak$session_external);
      RETURN;
    IFEND;

    call_block.operation := nac$fetch_attributes;

    call_block.fetch_attributes := ^attributes;

*copy BAI$CALL_FAP_CONTROL

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, osk$m * amk_fetch_attributes, nak$session_external);
  PROCEND nap$fetch_attributes;
MODEND nam$fetch_attributes;




*DECK DECK=NAM$FETCH_STATISTICAL_DATA EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access : Get Periodic Statistical Data' ??
MODULE nam$fetch_statistical_data;

{ PURPOSE:
{   This module contains the procedures to get the statistical data collected
{   by the NAM/VE layers and management entities.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nlt$device_count
*copyc oss$task_shared
*copyc ost$data_id
*copyc ost$signature_lock_status
?? POP ??
*copyc nav$global_statistics
*copyc nav$global_osi_statistics
*copyc osv$task_shared_heap
*copyc syv$nos_system_time
?? TITLE := 'Global Declarations Declared by this Module', EJECT ??

  VAR
    last_intranet_statistic: [STATIC, oss$task_shared] ^ost$intranet_statistics := NIL,
    last_namve_statistic: [STATIC, oss$task_shared] ^ost$namve_statistics := NIL,
    last_channel_device_statistic: [STATIC, oss$task_shared] ^ost$channel_device_statistics := NIL,
    last_namve_osi_statistic: [STATIC, oss$task_shared] ^ost$namve_osi_statistics := NIL;

?? TITLE := '[XDCL, #GATE] nap$get_intranet_statistics', EJECT ??

{ PURPOSE:
{   The purpose of this request is to get the data for the intranet layer
{   periodic statistics.  The statistics are collected separately for each
{   network solution.

  PROCEDURE [XDCL,#GATE] nap$get_intranet_statistics
    (    incremental: boolean;
     VAR intranet_statistic: ost$intranet_statistics);

    VAR
      i: nlt$device_count,
      local_statistic: ost$intranet_statistics,
      networks_count: nlt$device_count;

    local_statistic.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;
    networks_count := (UPPERBOUND (nav$global_statistics.intranet^) -
          LOWERBOUND (nav$global_statistics.intranet^)) + 1;
    PUSH local_statistic.stats: [1 .. networks_count];

    FOR i := 1 TO networks_count DO
      local_statistic.stats^ [i].logical_unit_number := nav$global_statistics.intranet^ [i].
            logical_unit_number;
      local_statistic.stats^ [i].network_id := nav$global_statistics.intranet^ [i].network_id;
      local_statistic.stats^ [i].current_send_pdus_queued :=
            nav$global_statistics.intranet^ [i].current_send_pdus_queued;
      local_statistic.stats^ [i].multicasts_received := statistic_value
            (^nav$global_statistics.intranet^ [i].multicasts_received);
      local_statistic.stats^ [i].multicasts_sent := statistic_value
            (^nav$global_statistics.intranet^ [i].multicasts_sent);
      local_statistic.stats^ [i].receive.value := statistic_value
            (^nav$global_statistics.intranet^ [i].receive.value);
      local_statistic.stats^ [i].receive_pdus_discarded :=
            statistic_value (^nav$global_statistics.intranet^ [i].receive_pdus_discarded);
      local_statistic.stats^ [i].send.value := statistic_value
            (^nav$global_statistics.intranet^ [i].send.value);
      local_statistic.stats^ [i].send_pdus_discarded := statistic_value
            (^nav$global_statistics.intranet^ [i].send_pdus_discarded);
    FOREND;

    IF incremental THEN
      IF last_intranet_statistic = NIL THEN
        ALLOCATE last_intranet_statistic IN osv$task_shared_heap^;
        ALLOCATE last_intranet_statistic^.stats: [1 .. networks_count] IN osv$task_shared_heap^;
        intranet_statistic := local_statistic;
      ELSE
        intranet_statistic.time := local_statistic.time - last_intranet_statistic^.time;
        FOR i := 1 TO networks_count DO
          intranet_statistic.stats^ [i].current_send_pdus_queued :=
                local_statistic.stats^ [i].current_send_pdus_queued -
                last_intranet_statistic^.stats^ [i].current_send_pdus_queued;
          intranet_statistic.stats^ [i].multicasts_received := local_statistic.stats^ [i].
                multicasts_received - last_intranet_statistic^.stats^ [i].multicasts_received;
          intranet_statistic.stats^ [i].multicasts_sent := local_statistic.stats^ [i].multicasts_sent -
                last_intranet_statistic^.stats^ [i].multicasts_sent;
          IF local_statistic.stats^ [i].receive.pdu_total >
                last_intranet_statistic^.stats^ [i].receive.pdu_total THEN
            intranet_statistic.stats^ [i].receive.pdu_average :=
                  ((local_statistic.stats^ [i].receive.pdu_average *
                  local_statistic.stats^ [i].receive.pdu_total) -
                  (last_intranet_statistic^.stats^ [i].receive.pdu_average * last_intranet_statistic^.
                  stats^ [i].receive.pdu_total)) DIV (local_statistic.stats^ [i].receive.pdu_total -
                  last_intranet_statistic^.stats^ [i].receive.pdu_total);
            intranet_statistic.stats^ [i].receive.pdu_total :=
                  local_statistic.stats^ [i].receive.pdu_total - last_intranet_statistic^.stats^ [i].receive.
                  pdu_total;
          ELSE
            intranet_statistic.stats^ [i].receive.pdu_average := 0;
            intranet_statistic.stats^ [i].receive.pdu_total := 0;
          IFEND;
          intranet_statistic.stats^ [i].receive_pdus_discarded :=
                local_statistic.stats^ [i].receive_pdus_discarded -
                last_intranet_statistic^.stats^ [i].receive_pdus_discarded;
          IF local_statistic.stats^ [i].send.pdu_total > last_intranet_statistic^.stats^ [i].send.
                pdu_total THEN
            intranet_statistic.stats^ [i].send.pdu_average_size :=
                  ((local_statistic.stats^ [i].send.pdu_average_size * local_statistic.stats^ [i].send.
                  pdu_total) - (last_intranet_statistic^.stats^ [i].send.pdu_average_size *
                  last_intranet_statistic^.stats^ [i].send.pdu_total)) DIV
                  (local_statistic.stats^ [i].send.pdu_total - last_intranet_statistic^.stats^ [i].send.
                  pdu_total);
            intranet_statistic.stats^ [i].send.pdu_fragment_average :=
                  ((local_statistic.stats^ [i].send.pdu_fragment_average *
                  local_statistic.stats^ [i].send.pdu_total) - (last_intranet_statistic^.stats^ [i].send.
                  pdu_fragment_average * last_intranet_statistic^.stats^ [i].send.pdu_total)) DIV
                  (local_statistic.stats^ [i].send.pdu_total - last_intranet_statistic^.stats^ [i].send.
                  pdu_total);
            intranet_statistic.stats^ [i].send.pdu_total := local_statistic.stats^ [i].send.pdu_total -
                  last_intranet_statistic^.stats^ [i].send.pdu_total;
          ELSE
            intranet_statistic.stats^ [i].send.pdu_average_size := 0;
            intranet_statistic.stats^ [i].send.pdu_fragment_average := 0;
            intranet_statistic.stats^ [i].send.pdu_total := 0;
          IFEND;
          intranet_statistic.stats^ [i].send_pdus_discarded := local_statistic.stats^ [i].
                send_pdus_discarded - last_intranet_statistic^.stats^ [i].send_pdus_discarded;
        FOREND;
      IFEND;
      last_intranet_statistic^.time := local_statistic.time;
      last_intranet_statistic^.stats^ := local_statistic.stats^;
    ELSE
      intranet_statistic.time := local_statistic.time;
      intranet_statistic.stats^ := local_statistic.stats^;
    IFEND;

  PROCEND nap$get_intranet_statistics;
?? TITLE := '[XDCL] nap$get_namve_statistics', EJECT ??

{ PURPOSE:
{   The purpose of this request is to get the statistical data for the NAM/VE layers.

  PROCEDURE [XDCL,#GATE] nap$get_namve_statistics
    (    incremental: boolean;
     VAR namve_statistic: ost$namve_statistics);

    VAR
      local_statistic: ost$namve_statistics;

    local_statistic.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;

    local_statistic.stats.internet.broadcasts_sent := statistic_value
          (^nav$global_statistics.internet.broadcasts_sent);
    local_statistic.stats.internet.pdus_received := statistic_value
          (^nav$global_statistics.internet.pdus_received);
    local_statistic.stats.internet.pdus_relayed := statistic_value
          (^nav$global_statistics.internet.pdus_relayed);
    local_statistic.stats.internet.pdus_routed_locally :=
          statistic_value (^nav$global_statistics.internet.pdus_routed_locally);
    local_statistic.stats.internet.pdus_sent := statistic_value (^nav$global_statistics.internet.pdus_sent);

    local_statistic.stats.transport.active_connections :=
          statistic_value (^nav$global_statistics.transport.active_connections);
    local_statistic.stats.transport.reference_number_wait :=
          statistic_value (^nav$global_statistics.transport.reference_number_wait);
    local_statistic.stats.transport.initiated_connections :=
          statistic_value (^nav$global_statistics.transport.initiated_connections);
    local_statistic.stats.transport.connections_terminated :=
          statistic_value (^nav$global_statistics.transport.connections_terminated);
    local_statistic.stats.transport.data_packets_received :=
          statistic_value (^nav$global_statistics.transport.data_packets_received);
    local_statistic.stats.transport.data_packets_sent := statistic_value
          (^nav$global_statistics.transport.data_packets_sent);
    local_statistic.stats.transport.xdata_packets_received :=
          statistic_value (^nav$global_statistics.transport.xdata_packets_received);
    local_statistic.stats.transport.xdata_packets_sent :=
          statistic_value (^nav$global_statistics.transport.xdata_packets_sent);
    local_statistic.stats.transport.retransmissions := statistic_value
          (^nav$global_statistics.transport.retransmissions);
    local_statistic.stats.transport.duplicate_data_packets :=
          statistic_value (^nav$global_statistics.transport.duplicate_data_packets);
    local_statistic.stats.transport.duplicate_xdata_packets :=
          statistic_value (^nav$global_statistics.transport.duplicate_xdata_packets);
    local_statistic.stats.transport.discarded_data_packets :=
          statistic_value (^nav$global_statistics.transport.discarded_data_packets);
    local_statistic.stats.transport.discarded_xdata_packets :=
          statistic_value (^nav$global_statistics.transport.discarded_xdata_packets);
    local_statistic.stats.transport.probe_packets_received :=
          statistic_value (^nav$global_statistics.transport.probe_packets_received);
    local_statistic.stats.transport.probe_packets_sent :=
          statistic_value (^nav$global_statistics.transport.probe_packets_sent);
    local_statistic.stats.transport.probe_packets_discarded :=
          statistic_value (^nav$global_statistics.transport.probe_packets_discarded);
    local_statistic.stats.transport.acknowledgment_requests_recved :=
          statistic_value (^nav$global_statistics.transport.acknowledgment_requests_recved);
    local_statistic.stats.transport.acknowledgment_requests_sent :=
          statistic_value (^nav$global_statistics.transport.acknowledgment_requests_sent);
    local_statistic.stats.transport.acknowledgments_discarded :=
          statistic_value (^nav$global_statistics.transport.acknowledgments_discarded);
    local_statistic.stats.transport.error_packets_received :=
          statistic_value (^nav$global_statistics.transport.error_packets_received);
    local_statistic.stats.transport.error_packets_sent :=
          statistic_value (^nav$global_statistics.transport.error_packets_sent);

    local_statistic.stats.session.interrupt_requests_received :=
          statistic_value (^nav$global_statistics.session.interrupt_requests_received);
    local_statistic.stats.session.interrupt_requests_sent :=
          statistic_value (^nav$global_statistics.session.interrupt_requests_sent);
    local_statistic.stats.session.synchronize_requests_received :=
          statistic_value (^nav$global_statistics.session.synchronize_requests_received);
    local_statistic.stats.session.synchronize_requests_sent :=
          statistic_value (^nav$global_statistics.session.synchronize_requests_sent);

    local_statistic.stats.routing.duplicate_received_ridus :=
          nav$global_statistics.routing.duplicate_received_ridus;
    local_statistic.stats.routing.ridus_aged_out := nav$global_statistics.routing.ridus_aged_out;
    local_statistic.stats.routing.ridus_received := nav$global_statistics.routing.ridus_received;
    local_statistic.stats.routing.ridus_sent := nav$global_statistics.routing.ridus_sent;
    local_statistic.stats.routing.table_partial_updates :=
          nav$global_statistics.routing.table_partial_updates;
    local_statistic.stats.routing.table_recomputed_direct_network :=
          nav$global_statistics.routing.table_recomputed_direct_network;
    local_statistic.stats.routing.table_recomputed_remote_network :=
          nav$global_statistics.routing.table_recomputed_remote_network;

    local_statistic.stats.directory.broadcast_translations_received :=
          statistic_value (^nav$global_statistics.directory.broadcast_translations_received);
    local_statistic.stats.directory.current_cache_entries :=
          nav$global_statistics.directory.current_cache_entries;
    local_statistic.stats.directory.current_registered_titles :=
          nav$global_statistics.directory.current_registered_titles;
    local_statistic.stats.directory.directory_searches_active :=
          nav$global_statistics.directory.directory_searches_active;
    local_statistic.stats.directory.directory_searches_initiated :=
          statistic_value (^nav$global_statistics.directory.directory_searches_initiated);
    local_statistic.stats.directory.translation_requests_broadcast :=
          nav$global_statistics.directory.translation_requests_broadcast;
    local_statistic.stats.directory.translation_requests_received :=
          nav$global_statistics.directory.translation_requests_received;
    local_statistic.stats.directory.translations_broadcast :=
          nav$global_statistics.directory.translations_broadcast;
    local_statistic.stats.directory.translations_delivered :=
          nav$global_statistics.directory.translations_delivered;
    local_statistic.stats.directory.translations_found_in_cache :=
          nav$global_statistics.directory.translations_found_in_cache;
    local_statistic.stats.directory.translations_found_in_local_dir :=
          nav$global_statistics.directory.translations_found_in_local_dir;
    local_statistic.stats.directory.translations_received :=
          statistic_value (^nav$global_statistics.directory.translations_received);
    local_statistic.stats.directory.translations_sent :=
          nav$global_statistics.directory.translations_sent;

    local_statistic.stats.file_access := nav$global_statistics.file_access;

    local_statistic.stats.buffer_manager := nav$global_statistics.buffer_manager;

    local_statistic.stats.pp_buffer_pool := nav$global_statistics.pp_buffer_pool;

    IF incremental THEN
      IF last_namve_statistic = NIL THEN
        ALLOCATE last_namve_statistic IN osv$task_shared_heap^;
        namve_statistic := local_statistic;
      ELSE
        namve_statistic.time := local_statistic.time - last_namve_statistic^.time;
        namve_statistic.stats.internet.broadcasts_sent := local_statistic.stats.internet.broadcasts_sent -
              last_namve_statistic^.stats.internet.broadcasts_sent;
        namve_statistic.stats.internet.pdus_received := local_statistic.stats.internet.pdus_received -
              last_namve_statistic^.stats.internet.pdus_received;
        namve_statistic.stats.internet.pdus_relayed := local_statistic.stats.internet.pdus_relayed -
              last_namve_statistic^.stats.internet.pdus_relayed;
        namve_statistic.stats.internet.pdus_routed_locally :=
              local_statistic.stats.internet.pdus_routed_locally -
              last_namve_statistic^.stats.internet.pdus_routed_locally;
        namve_statistic.stats.internet.pdus_sent := local_statistic.stats.internet.pdus_sent -
              last_namve_statistic^.stats.internet.pdus_sent;

        namve_statistic.stats.transport.active_connections :=
              local_statistic.stats.transport.active_connections -
              last_namve_statistic^.stats.transport.active_connections;
        namve_statistic.stats.transport.reference_number_wait :=
              local_statistic.stats.transport.reference_number_wait -
              last_namve_statistic^.stats.transport.reference_number_wait;
        namve_statistic.stats.transport.initiated_connections :=
              local_statistic.stats.transport.initiated_connections -
              last_namve_statistic^.stats.transport.initiated_connections;
        namve_statistic.stats.transport.connections_terminated :=
              local_statistic.stats.transport.connections_terminated -
              last_namve_statistic^.stats.transport.connections_terminated;
        namve_statistic.stats.transport.data_packets_received :=
              local_statistic.stats.transport.data_packets_received -
              last_namve_statistic^.stats.transport.data_packets_received;
        namve_statistic.stats.transport.data_packets_sent :=
              local_statistic.stats.transport.data_packets_sent -
              last_namve_statistic^.stats.transport.data_packets_sent;
        namve_statistic.stats.transport.xdata_packets_received :=
              local_statistic.stats.transport.xdata_packets_received -
              last_namve_statistic^.stats.transport.xdata_packets_received;
        namve_statistic.stats.transport.xdata_packets_sent :=
              local_statistic.stats.transport.xdata_packets_sent -
              last_namve_statistic^.stats.transport.xdata_packets_sent;
        namve_statistic.stats.transport.retransmissions := local_statistic.stats.transport.retransmissions -
              last_namve_statistic^.stats.transport.retransmissions;
        namve_statistic.stats.transport.duplicate_data_packets :=
              local_statistic.stats.transport.duplicate_data_packets -
              last_namve_statistic^.stats.transport.duplicate_data_packets;
        namve_statistic.stats.transport.duplicate_xdata_packets :=
              local_statistic.stats.transport.duplicate_xdata_packets -
              last_namve_statistic^.stats.transport.duplicate_xdata_packets;
        namve_statistic.stats.transport.discarded_data_packets :=
              local_statistic.stats.transport.discarded_data_packets -
              last_namve_statistic^.stats.transport.discarded_data_packets;
        namve_statistic.stats.transport.discarded_xdata_packets :=
              local_statistic.stats.transport.discarded_xdata_packets -
              last_namve_statistic^.stats.transport.discarded_xdata_packets;
        namve_statistic.stats.transport.probe_packets_received :=
              local_statistic.stats.transport.probe_packets_received -
              last_namve_statistic^.stats.transport.probe_packets_received;
        namve_statistic.stats.transport.probe_packets_sent :=
              local_statistic.stats.transport.probe_packets_sent -
              last_namve_statistic^.stats.transport.probe_packets_sent;
        namve_statistic.stats.transport.probe_packets_discarded :=
              local_statistic.stats.transport.probe_packets_discarded -
              last_namve_statistic^.stats.transport.probe_packets_discarded;
        namve_statistic.stats.transport.acknowledgment_requests_recved :=
              local_statistic.stats.transport.acknowledgment_requests_recved -
              last_namve_statistic^.stats.transport.acknowledgment_requests_recved;
        namve_statistic.stats.transport.acknowledgment_requests_sent :=
              local_statistic.stats.transport.acknowledgment_requests_sent -
              last_namve_statistic^.stats.transport.acknowledgment_requests_sent;
        namve_statistic.stats.transport.acknowledgments_discarded :=
              local_statistic.stats.transport.acknowledgments_discarded -
              last_namve_statistic^.stats.transport.acknowledgments_discarded;
        namve_statistic.stats.transport.error_packets_received :=
              local_statistic.stats.transport.error_packets_received -
              last_namve_statistic^.stats.transport.error_packets_received;
        namve_statistic.stats.transport.error_packets_sent :=
              local_statistic.stats.transport.error_packets_sent -
              last_namve_statistic^.stats.transport.error_packets_sent;

        namve_statistic.stats.session.interrupt_requests_received :=
              local_statistic.stats.session.interrupt_requests_received -
              last_namve_statistic^.stats.session.interrupt_requests_received;
        namve_statistic.stats.session.interrupt_requests_sent :=
              local_statistic.stats.session.interrupt_requests_sent -
              last_namve_statistic^.stats.session.interrupt_requests_sent;
        namve_statistic.stats.session.synchronize_requests_received :=
              local_statistic.stats.session.synchronize_requests_received -
              last_namve_statistic^.stats.session.synchronize_requests_received;
        namve_statistic.stats.session.synchronize_requests_sent :=
              local_statistic.stats.session.synchronize_requests_sent -
              last_namve_statistic^.stats.session.synchronize_requests_sent;

        namve_statistic.stats.routing.duplicate_received_ridus :=
              local_statistic.stats.routing.duplicate_received_ridus -
              last_namve_statistic^.stats.routing.duplicate_received_ridus;
        namve_statistic.stats.routing.ridus_aged_out := local_statistic.stats.routing.ridus_aged_out -
              last_namve_statistic^.stats.routing.ridus_aged_out;
        namve_statistic.stats.routing.ridus_received := local_statistic.stats.routing.ridus_received -
              last_namve_statistic^.stats.routing.ridus_received;
        namve_statistic.stats.routing.ridus_sent := local_statistic.stats.routing.ridus_sent -
              last_namve_statistic^.stats.routing.ridus_sent;
        namve_statistic.stats.routing.table_partial_updates :=
              local_statistic.stats.routing.table_partial_updates -
              last_namve_statistic^.stats.routing.table_partial_updates;
        namve_statistic.stats.routing.table_recomputed_direct_network :=
              local_statistic.stats.routing.table_recomputed_direct_network -
              last_namve_statistic^.stats.routing.table_recomputed_direct_network;
        namve_statistic.stats.routing.table_recomputed_remote_network :=
              local_statistic.stats.routing.table_recomputed_remote_network -
              last_namve_statistic^.stats.routing.table_recomputed_remote_network;

        namve_statistic.stats.directory.broadcast_translations_received :=
              local_statistic.stats.directory.broadcast_translations_received -
              last_namve_statistic^.stats.directory.broadcast_translations_received;
        namve_statistic.stats.directory.current_cache_entries :=
              local_statistic.stats.directory.current_cache_entries -
              last_namve_statistic^.stats.directory.current_cache_entries;
        namve_statistic.stats.directory.current_registered_titles :=
              local_statistic.stats.directory.current_registered_titles -
              last_namve_statistic^.stats.directory.current_registered_titles;
        namve_statistic.stats.directory.directory_searches_active :=
              local_statistic.stats.directory.directory_searches_active -
              last_namve_statistic^.stats.directory.directory_searches_active;
        namve_statistic.stats.directory.directory_searches_initiated :=
              local_statistic.stats.directory.directory_searches_initiated -
              last_namve_statistic^.stats.directory.directory_searches_initiated;
        namve_statistic.stats.directory.translation_requests_broadcast :=
              local_statistic.stats.directory.translation_requests_broadcast -
              last_namve_statistic^.stats.directory.translation_requests_broadcast;
        namve_statistic.stats.directory.translation_requests_received :=
              local_statistic.stats.directory.translation_requests_received -
              last_namve_statistic^.stats.directory.translation_requests_received;
        namve_statistic.stats.directory.translations_broadcast :=
              local_statistic.stats.directory.translations_broadcast -
              last_namve_statistic^.stats.directory.translations_broadcast;
        namve_statistic.stats.directory.translations_delivered :=
              local_statistic.stats.directory.translations_delivered -
              last_namve_statistic^.stats.directory.translations_delivered;
        namve_statistic.stats.directory.translations_found_in_cache :=
              local_statistic.stats.directory.translations_found_in_cache -
              last_namve_statistic^.stats.directory.translations_found_in_cache;
        namve_statistic.stats.directory.translations_found_in_local_dir :=
              local_statistic.stats.directory.translations_found_in_local_dir -
              last_namve_statistic^.stats.directory.translations_found_in_local_dir;
        namve_statistic.stats.directory.translations_received :=
              local_statistic.stats.directory.translations_received -
              last_namve_statistic^.stats.directory.translations_received;
        namve_statistic.stats.directory.translations_sent :=
              local_statistic.stats.directory.translations_sent -
              last_namve_statistic^.stats.directory.translations_sent;

        namve_statistic.stats.file_access.active_connections :=
              local_statistic.stats.file_access.active_connections -
              last_namve_statistic^.stats.file_access.active_connections;
        namve_statistic.stats.file_access.file_access_requests :=
              local_statistic.stats.file_access.file_access_requests -
              last_namve_statistic^.stats.file_access.file_access_requests;

        namve_statistic.stats.buffer_manager.containers_allocated [1] :=
              local_statistic.stats.buffer_manager.containers_allocated [1] -
              last_namve_statistic^.stats.buffer_manager.containers_allocated [1];
        namve_statistic.stats.buffer_manager.containers_allocated [2] :=
              local_statistic.stats.buffer_manager.containers_allocated [2] -
              last_namve_statistic^.stats.buffer_manager.containers_allocated [2];
        namve_statistic.stats.buffer_manager.containers_freed [1] :=
              local_statistic.stats.buffer_manager.containers_freed [1] -
              last_namve_statistic^.stats.buffer_manager.containers_freed [1];
        namve_statistic.stats.buffer_manager.containers_freed [2] :=
              local_statistic.stats.buffer_manager.containers_freed [2] -
              last_namve_statistic^.stats.buffer_manager.containers_freed [2];
        namve_statistic.stats.buffer_manager.descriptor_pool_empty_count :=
              local_statistic.stats.buffer_manager.descriptor_pool_empty_count -
              last_namve_statistic^.stats.buffer_manager.descriptor_pool_empty_count;

        namve_statistic.stats.pp_buffer_pool.empty_pools_count [1] :=
              local_statistic.stats.pp_buffer_pool.empty_pools_count [1] -
              last_namve_statistic^.stats.pp_buffer_pool.empty_pools_count [1];
        namve_statistic.stats.pp_buffer_pool.empty_pools_count [2] :=
              local_statistic.stats.pp_buffer_pool.empty_pools_count [2] -
              last_namve_statistic^.stats.pp_buffer_pool.empty_pools_count [2];
        namve_statistic.stats.pp_buffer_pool.pools_replenished [1] :=
              local_statistic.stats.pp_buffer_pool.pools_replenished [1] -
              last_namve_statistic^.stats.pp_buffer_pool.pools_replenished [1];
        namve_statistic.stats.pp_buffer_pool.pools_replenished [2] :=
              local_statistic.stats.pp_buffer_pool.pools_replenished [2] -
              last_namve_statistic^.stats.pp_buffer_pool.pools_replenished [2];
      IFEND;
      last_namve_statistic^ := local_statistic;
    ELSE
      namve_statistic := local_statistic;
    IFEND;

  PROCEND nap$get_namve_statistics;

?? TITLE := '[XDCL] nap$get_osi_device_spec_stats', EJECT ??

{ PURPOSE:
{   The purpose of this request is to get the data for the channel connection
{   periodic statistics.  The statistics are collected separately for each
{   network solution.

  PROCEDURE [XDCL,#GATE] nap$get_osi_device_spec_stats
    (    incremental: boolean;
     VAR channel_device_statistic: ost$channel_device_statistics);

    VAR
      i: nlt$device_count,
      local_statistic: ost$channel_device_statistics,
      networks_count: nlt$device_count;

    local_statistic.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;
    networks_count := (UPPERBOUND (nav$global_osi_statistics.channel_connection_device^) -
          LOWERBOUND (nav$global_osi_statistics.channel_connection_device^)) + 1;
    PUSH local_statistic.statistics: [1 .. networks_count];

    FOR i := 1 TO networks_count DO
      local_statistic.statistics^ [i].network_id := nav$global_osi_statistics.channel_connection_device^ [i].
            network_id;
      local_statistic.statistics^ [i].credit_pdus_received :=
            nav$global_osi_statistics.channel_connection_device^ [i].credit_pdus_received;
      local_statistic.statistics^ [i].credit_pdus_sent := statistic_value
            (^nav$global_osi_statistics.channel_connection_device^ [i].credit_pdus_sent);
      local_statistic.statistics^ [i].current_normal_connections :=
            statistic_value (^nav$global_osi_statistics.channel_connection_device^ [i].
            current_normal_connections);
      local_statistic.statistics^ [i].current_priority_connections :=
            statistic_value (^nav$global_osi_statistics.channel_connection_device^ [i].
            current_priority_connections);
      local_statistic.statistics^ [i].device_resets := statistic_value
            (^nav$global_osi_statistics.channel_connection_device^ [i].device_resets);
      local_statistic.statistics^ [i].duplicate_connect_indications :=
            statistic_value (^nav$global_osi_statistics.channel_connection_device^ [i].
            duplicate_connect_indications);
      local_statistic.statistics^ [i].normal_send_pdus_queued :=
            statistic_value (^nav$global_osi_statistics.channel_connection_device^ [i].
            normal_send_pdus_queued);
      local_statistic.statistics^ [i].pdus_processed_out_of_order :=
            statistic_value (^nav$global_osi_statistics.channel_connection_device^ [i].
            pdus_processed_out_of_order);
      local_statistic.statistics^ [i].priority_receive.value := statistic_value
            (^nav$global_osi_statistics.channel_connection_device^ [i].priority_receive.value);
      local_statistic.statistics^ [i].priority_receive_expedited_pdus :=
            statistic_value (^nav$global_osi_statistics.channel_connection_device^ [i].
            priority_receive_expedited_pdus);
      local_statistic.statistics^ [i].priority_receive_pdus_discarded :=
            statistic_value (^nav$global_osi_statistics.channel_connection_device^ [i].
            priority_receive_pdus_discarded);
      local_statistic.statistics^ [i].priority_send.value := statistic_value
            (^nav$global_osi_statistics.channel_connection_device^ [i].priority_send.value);
      local_statistic.statistics^ [i].priority_send_expedited_pdus :=
            statistic_value (^nav$global_osi_statistics.channel_connection_device^ [i].
            priority_send_expedited_pdus);
      local_statistic.statistics^ [i].priority_send_pdus_discarded :=
            statistic_value (^nav$global_osi_statistics.channel_connection_device^ [i].
            priority_send_pdus_discarded);
      local_statistic.statistics^ [i].priority_send_pdus_queued :=
            statistic_value (^nav$global_osi_statistics.channel_connection_device^ [i].
            priority_send_pdus_queued);
      local_statistic.statistics^ [i].receive.value := statistic_value
            (^nav$global_osi_statistics.channel_connection_device^ [i].receive.value);
      local_statistic.statistics^ [i].receive_pdus_discarded :=
            statistic_value (^nav$global_osi_statistics.channel_connection_device^ [i].
            receive_pdus_discarded);
      local_statistic.statistics^ [i].received_expedited_pdus :=
            statistic_value (^nav$global_osi_statistics.channel_connection_device^ [i].
            received_expedited_pdus);
      local_statistic.statistics^ [i].send.value := statistic_value
            (^nav$global_osi_statistics.channel_connection_device^ [i].send.value);
      local_statistic.statistics^ [i].send_expedited_pdus :=
            statistic_value (^nav$global_osi_statistics.channel_connection_device^ [i].send_expedited_pdus);
      local_statistic.statistics^ [i].send_pdus_discarded :=
            statistic_value (^nav$global_osi_statistics.channel_connection_device^ [i].send_pdus_discarded);
    FOREND;

    IF incremental THEN
      IF last_channel_device_statistic = NIL THEN
        ALLOCATE last_channel_device_statistic IN osv$task_shared_heap^;
        ALLOCATE last_channel_device_statistic^.statistics: [1 .. networks_count] IN osv$task_shared_heap^;
        channel_device_statistic := local_statistic;
      ELSE
        channel_device_statistic.time := local_statistic.time - last_channel_device_statistic^.time;
        FOR i := 1 TO networks_count DO
          channel_device_statistic.statistics^ [i].credit_pdus_received :=
                local_statistic.statistics^ [i].credit_pdus_received -
                last_channel_device_statistic^.statistics^ [i].credit_pdus_received;
          channel_device_statistic.statistics^ [i].credit_pdus_sent :=
                local_statistic.statistics^ [i].credit_pdus_sent -
                last_channel_device_statistic^.statistics^ [i].credit_pdus_sent;
          channel_device_statistic.statistics^ [i].current_normal_connections := local_statistic.
                statistics^ [i].current_normal_connections - last_channel_device_statistic^.statistics^ [i].
                current_normal_connections;
          channel_device_statistic.statistics^ [i].current_priority_connections :=
                local_statistic.statistics^ [i].current_priority_connections -
                last_channel_device_statistic^.statistics^ [i].current_priority_connections;
          channel_device_statistic.statistics^ [i].device_resets :=
                local_statistic.statistics^ [i].device_resets - last_channel_device_statistic^.
                statistics^ [i].device_resets;
          channel_device_statistic.statistics^ [i].duplicate_connect_indications :=
                local_statistic.statistics^ [i].duplicate_connect_indications -
                last_channel_device_statistic^.statistics^ [i].duplicate_connect_indications;
          channel_device_statistic.statistics^ [i].normal_send_pdus_queued :=
                local_statistic.statistics^ [i].normal_send_pdus_queued -
                last_channel_device_statistic^.statistics^ [i].normal_send_pdus_queued;
          channel_device_statistic.statistics^ [i].pdus_processed_out_of_order :=
                local_statistic.statistics^ [i].pdus_processed_out_of_order -
                last_channel_device_statistic^.statistics^ [i].pdus_processed_out_of_order;
          IF local_statistic.statistics^ [i].priority_receive.pdu_total >
                  last_channel_device_statistic^.statistics^ [i].priority_receive.pdu_total THEN
            channel_device_statistic.statistics^ [i].priority_receive.pdu_average :=
                  ((local_statistic.statistics^ [i].priority_receive.pdu_average *
                  local_statistic.statistics^ [i].priority_receive.pdu_total) -
                  (last_channel_device_statistic^.statistics^ [i].priority_receive.pdu_average *
                  last_channel_device_statistic^.statistics^ [i].priority_receive.pdu_total)) DIV
                  (local_statistic.statistics^ [i].priority_receive.pdu_total -
                  last_channel_device_statistic^.statistics^ [i].priority_receive.pdu_total);
            channel_device_statistic.statistics^ [i].priority_receive.pdu_total :=
                  local_statistic.statistics^ [i].priority_receive.pdu_total -
                  last_channel_device_statistic^.statistics^ [i].priority_receive.pdu_total;
          ELSE
            channel_device_statistic.statistics^ [i].priority_receive.pdu_average := 0;
            channel_device_statistic.statistics^ [i].priority_receive.pdu_total := 0;
          IFEND;
          channel_device_statistic.statistics^ [i].priority_receive_expedited_pdus :=
                local_statistic.statistics^ [i].priority_receive_expedited_pdus -
                last_channel_device_statistic^.statistics^ [i].priority_receive_expedited_pdus;
          channel_device_statistic.statistics^ [i].priority_receive_pdus_discarded :=
                local_statistic.statistics^ [i].priority_receive_pdus_discarded -
                last_channel_device_statistic^.statistics^ [i].priority_receive_pdus_discarded;
          IF local_statistic.statistics^ [i].priority_send.pdu_total > last_channel_device_statistic^.
                  statistics^ [i].priority_send.pdu_total THEN
            channel_device_statistic.statistics^ [i].priority_send.pdu_average :=
                  ((local_statistic.statistics^ [i].priority_send.pdu_average * local_statistic.
                  statistics^ [i].priority_send.pdu_total) - (last_channel_device_statistic^.
                  statistics^ [i].priority_send.pdu_average * last_channel_device_statistic^.
                  statistics^ [i].priority_send.pdu_total)) DIV (local_statistic.statistics^ [i].
                  priority_send.pdu_total - last_channel_device_statistic^.statistics^ [i].
                  priority_send.pdu_total);
            channel_device_statistic.statistics^ [i].priority_send.pdu_total :=
                  local_statistic.statistics^ [i].priority_send.pdu_total - last_channel_device_statistic^.
                  statistics^ [i].priority_send.pdu_total;
          ELSE
            channel_device_statistic.statistics^ [i].priority_send.pdu_average := 0;
            channel_device_statistic.statistics^ [i].priority_send.pdu_total := 0;
          IFEND;
          channel_device_statistic.statistics^ [i].priority_send_expedited_pdus :=
                local_statistic.statistics^ [i].priority_send_expedited_pdus -
                last_channel_device_statistic^.statistics^ [i].priority_send_expedited_pdus;
          channel_device_statistic.statistics^ [i].priority_send_pdus_discarded :=
                local_statistic.statistics^ [i].priority_send_pdus_discarded -
                last_channel_device_statistic^.statistics^ [i].priority_send_pdus_discarded;
          channel_device_statistic.statistics^ [i].priority_send_pdus_queued := local_statistic.
                statistics^ [i].priority_send_pdus_queued - last_channel_device_statistic^.statistics^ [i].
                priority_send_pdus_queued;
          IF local_statistic.statistics^ [i].receive.pdu_total >
                  last_channel_device_statistic^.statistics^ [i].receive.pdu_total THEN
            channel_device_statistic.statistics^ [i].receive.pdu_average :=
                  ((local_statistic.statistics^ [i].receive.pdu_average *
                  local_statistic.statistics^ [i].receive.pdu_total) -
                  (last_channel_device_statistic^.statistics^ [i].receive.pdu_average *
                  last_channel_device_statistic^.statistics^ [i].receive.pdu_total)) DIV
                  (local_statistic.statistics^ [i].receive.pdu_total -
                  last_channel_device_statistic^.statistics^ [i].receive.pdu_total);
            channel_device_statistic.statistics^ [i].receive.pdu_total :=
                  local_statistic.statistics^ [i].receive.pdu_total -
                  last_channel_device_statistic^.statistics^ [i].receive.pdu_total;
          ELSE
            channel_device_statistic.statistics^ [i].receive.pdu_average := 0;
            channel_device_statistic.statistics^ [i].receive.pdu_total := 0;
          IFEND;
          channel_device_statistic.statistics^ [i].received_expedited_pdus :=
                local_statistic.statistics^ [i].received_expedited_pdus -
                last_channel_device_statistic^.statistics^ [i].received_expedited_pdus;
          channel_device_statistic.statistics^ [i].receive_pdus_discarded :=
                local_statistic.statistics^ [i].receive_pdus_discarded -
                last_channel_device_statistic^.statistics^ [i].receive_pdus_discarded;
          IF local_statistic.statistics^ [i].send.pdu_total > last_channel_device_statistic^.
                  statistics^ [i].send.pdu_total THEN
            channel_device_statistic.statistics^ [i].send.pdu_average :=
                  ((local_statistic.statistics^ [i].send.pdu_average * local_statistic.statistics^ [i].
                  send.pdu_total) - (last_channel_device_statistic^.statistics^ [i].send.pdu_average *
                  last_channel_device_statistic^.statistics^ [i].send.pdu_total)) DIV
                  (local_statistic.statistics^ [i].send.pdu_total - last_channel_device_statistic^.
                  statistics^ [i].send.pdu_total);
            channel_device_statistic.statistics^ [i].send.pdu_total :=
                  local_statistic.statistics^ [i].send.pdu_total - last_channel_device_statistic^.
                  statistics^ [i].send.pdu_total;
          ELSE
            channel_device_statistic.statistics^ [i].send.pdu_average := 0;
            channel_device_statistic.statistics^ [i].send.pdu_total := 0;
          IFEND;
          channel_device_statistic.statistics^ [i].send_expedited_pdus :=
                local_statistic.statistics^ [i].send_expedited_pdus -
                last_channel_device_statistic^.statistics^ [i].send_expedited_pdus;
          channel_device_statistic.statistics^ [i].send_pdus_discarded :=
                local_statistic.statistics^ [i].send_pdus_discarded -
                last_channel_device_statistic^.statistics^ [i].send_pdus_discarded;
        FOREND;
      IFEND;
      last_channel_device_statistic^.time := local_statistic.time;
      last_channel_device_statistic^.statistics^ := local_statistic.statistics^;
    ELSE
      channel_device_statistic.time := local_statistic.time;
      channel_device_statistic.statistics^ := local_statistic.statistics^;
    IFEND;

  PROCEND nap$get_osi_device_spec_stats;
?? TITLE := '[XDCL] nap$get_osi_statistics', EJECT ??

{ PURPOSE:
{   The purpose of this request is to get the statistical data for the NAM/VE OSI layers.

  PROCEDURE [XDCL,#GATE] nap$get_osi_statistics
    (    incremental: boolean;
     VAR namve_osi_statistic: ost$namve_osi_statistics);

    VAR
      local_statistic: ost$namve_osi_statistics;

    local_statistic.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;

    local_statistic.statistics.channel_connection.broadcast_connect_requests :=
          statistic_value (^nav$global_osi_statistics.channel_connection.broadcast_connect_requests);
    local_statistic.statistics.channel_connection.normal_connections :=
          statistic_value (^nav$global_osi_statistics.channel_connection.normal_connections);
    local_statistic.statistics.channel_connection.priority_connections :=
          statistic_value (^nav$global_osi_statistics.channel_connection.priority_connections);

    local_statistic.statistics.link_access_agent.current_saps_open :=
          statistic_value (^nav$global_osi_statistics.link_access_agent.current_saps_open);
    local_statistic.statistics.link_access_agent.pdus_received :=
          statistic_value (^nav$global_osi_statistics.link_access_agent.pdus_received);
    local_statistic.statistics.link_access_agent.pdus_sent := statistic_value
          (^nav$global_osi_statistics.link_access_agent.pdus_sent);
    local_statistic.statistics.link_access_agent.total_bytes_received := statistic_value
          (^nav$global_osi_statistics.link_access_agent.total_bytes_received);
    local_statistic.statistics.link_access_agent.total_bytes_sent := statistic_value
          (^nav$global_osi_statistics.link_access_agent.total_bytes_sent);

    local_statistic.statistics.network_access_agent.broadcasts_sent :=
          statistic_value (^nav$global_osi_statistics.network_access_agent.broadcasts_sent);
    local_statistic.statistics.network_access_agent.pdus_received :=
          statistic_value (^nav$global_osi_statistics.network_access_agent.pdus_received);
    local_statistic.statistics.network_access_agent.pdus_sent :=
          statistic_value (^nav$global_osi_statistics.network_access_agent.pdus_sent);
    local_statistic.statistics.network_access_agent.total_bytes_received :=
          statistic_value (^nav$global_osi_statistics.network_access_agent.total_bytes_received);
    local_statistic.statistics.network_access_agent.total_bytes_sent :=
          statistic_value (^nav$global_osi_statistics.network_access_agent.total_bytes_sent);

    local_statistic.statistics.system_management_entity.cdna_address_select_device_reqs :=
          nav$global_osi_statistics.system_management_entity.cdna_address_select_device_reqs;
    local_statistic.statistics.system_management_entity.noncdna_addr_select_device_reqs :=
          nav$global_osi_statistics.system_management_entity.noncdna_addr_select_device_reqs;
    local_statistic.statistics.system_management_entity.cdna_address_route_unknown :=
          nav$global_osi_statistics.system_management_entity.cdna_address_route_unknown;
    local_statistic.statistics.system_management_entity.noncdna_address_route_unknown :=
          nav$global_osi_statistics.system_management_entity.noncdna_address_route_unknown;
    local_statistic.statistics.system_management_entity.device_routing_queries :=
          nav$global_osi_statistics.system_management_entity.device_routing_queries;
    local_statistic.statistics.system_management_entity.subnet_attribute_updates_rcvd :=
          nav$global_osi_statistics.system_management_entity.subnet_attribute_updates_rcvd;

    local_statistic.statistics.transport_access_agent.data_pdus_received :=
          statistic_value (^nav$global_osi_statistics.transport_access_agent.data_pdus_received);
    local_statistic.statistics.transport_access_agent.data_pdus_sent :=
          nav$global_osi_statistics.transport_access_agent.data_pdus_sent;
    local_statistic.statistics.transport_access_agent.expedited_pdus_received :=
          nav$global_osi_statistics.transport_access_agent.expedited_pdus_received;
    local_statistic.statistics.transport_access_agent.expedited_pdus_sent :=
          statistic_value (^nav$global_osi_statistics.transport_access_agent.expedited_pdus_sent);
    local_statistic.statistics.transport_access_agent.total_bytes_received :=
          statistic_value (^nav$global_osi_statistics.transport_access_agent.total_bytes_received);
    local_statistic.statistics.transport_access_agent.total_bytes_sent :=
          statistic_value (^nav$global_osi_statistics.transport_access_agent.total_bytes_sent);

    IF incremental THEN
      IF last_namve_osi_statistic = NIL THEN
        ALLOCATE last_namve_osi_statistic IN osv$task_shared_heap^;
        namve_osi_statistic := local_statistic;
      ELSE
        namve_osi_statistic.time := local_statistic.time - last_namve_osi_statistic^.time;
        namve_osi_statistic.statistics.channel_connection.broadcast_connect_requests :=
              local_statistic.statistics.channel_connection.broadcast_connect_requests -
              last_namve_osi_statistic^.statistics.channel_connection.broadcast_connect_requests;
        namve_osi_statistic.statistics.channel_connection.normal_connections :=
              local_statistic.statistics.channel_connection.normal_connections -
              last_namve_osi_statistic^.statistics.channel_connection.normal_connections;
        namve_osi_statistic.statistics.channel_connection.priority_connections :=
              local_statistic.statistics.channel_connection.priority_connections -
              last_namve_osi_statistic^.statistics.channel_connection.priority_connections;

        namve_osi_statistic.statistics.link_access_agent.current_saps_open :=
              local_statistic.statistics.link_access_agent.current_saps_open -
              last_namve_osi_statistic^.statistics.link_access_agent.current_saps_open;
        namve_osi_statistic.statistics.link_access_agent.pdus_received :=
              local_statistic.statistics.link_access_agent.pdus_received -
              last_namve_osi_statistic^.statistics.link_access_agent.pdus_received;
        namve_osi_statistic.statistics.link_access_agent.pdus_sent :=
              local_statistic.statistics.link_access_agent.pdus_sent -
              last_namve_osi_statistic^.statistics.link_access_agent.pdus_sent;
        namve_osi_statistic.statistics.link_access_agent.total_bytes_received :=
              local_statistic.statistics.link_access_agent.total_bytes_received -
              last_namve_osi_statistic^.statistics.link_access_agent.total_bytes_received;
        namve_osi_statistic.statistics.link_access_agent.total_bytes_sent :=
              local_statistic.statistics.link_access_agent.total_bytes_sent -
              last_namve_osi_statistic^.statistics.link_access_agent.total_bytes_sent;

        namve_osi_statistic.statistics.network_access_agent.broadcasts_sent :=
              local_statistic.statistics.network_access_agent.broadcasts_sent -
              last_namve_osi_statistic^.statistics.network_access_agent.broadcasts_sent;
        namve_osi_statistic.statistics.network_access_agent.pdus_received :=
              local_statistic.statistics.network_access_agent.pdus_received -
              last_namve_osi_statistic^.statistics.network_access_agent.pdus_received;
        namve_osi_statistic.statistics.network_access_agent.pdus_sent :=
              local_statistic.statistics.network_access_agent.pdus_sent -
              last_namve_osi_statistic^.statistics.network_access_agent.pdus_sent;
        namve_osi_statistic.statistics.network_access_agent.total_bytes_received :=
              local_statistic.statistics.network_access_agent.total_bytes_received -
              last_namve_osi_statistic^.statistics.network_access_agent.total_bytes_received;
        namve_osi_statistic.statistics.network_access_agent.total_bytes_sent :=
              local_statistic.statistics.network_access_agent.total_bytes_sent -
              last_namve_osi_statistic^.statistics.network_access_agent.total_bytes_sent;

        namve_osi_statistic.statistics.system_management_entity.cdna_address_select_device_reqs :=
              local_statistic.statistics.system_management_entity.cdna_address_select_device_reqs -
              last_namve_osi_statistic^.statistics.system_management_entity.cdna_address_select_device_reqs;
        namve_osi_statistic.statistics.system_management_entity.noncdna_addr_select_device_reqs :=
              local_statistic.statistics.system_management_entity.noncdna_addr_select_device_reqs -
              last_namve_osi_statistic^.statistics.system_management_entity.noncdna_addr_select_device_reqs;
        namve_osi_statistic.statistics.system_management_entity.cdna_address_route_unknown :=
              local_statistic.statistics.system_management_entity.cdna_address_route_unknown -
              last_namve_osi_statistic^.statistics.system_management_entity.cdna_address_route_unknown;
        namve_osi_statistic.statistics.system_management_entity.noncdna_address_route_unknown :=
              local_statistic.statistics.system_management_entity.noncdna_address_route_unknown -
              last_namve_osi_statistic^.statistics.system_management_entity.noncdna_address_route_unknown;
        namve_osi_statistic.statistics.system_management_entity.device_routing_queries :=
              local_statistic.statistics.system_management_entity.device_routing_queries -
              last_namve_osi_statistic^.statistics.system_management_entity.device_routing_queries;
        namve_osi_statistic.statistics.system_management_entity.subnet_attribute_updates_rcvd :=
              local_statistic.statistics.system_management_entity.subnet_attribute_updates_rcvd -
              last_namve_osi_statistic^.statistics.system_management_entity.subnet_attribute_updates_rcvd;

        namve_osi_statistic.statistics.transport_access_agent.data_pdus_received :=
              local_statistic.statistics.transport_access_agent.data_pdus_received -
              last_namve_osi_statistic^.statistics.transport_access_agent.data_pdus_received;
        namve_osi_statistic.statistics.transport_access_agent.data_pdus_sent :=
              local_statistic.statistics.transport_access_agent.data_pdus_sent -
              last_namve_osi_statistic^.statistics.transport_access_agent.data_pdus_sent;
        namve_osi_statistic.statistics.transport_access_agent.expedited_pdus_received :=
              local_statistic.statistics.transport_access_agent.expedited_pdus_received -
              last_namve_osi_statistic^.statistics.transport_access_agent.expedited_pdus_received;
        namve_osi_statistic.statistics.transport_access_agent.expedited_pdus_sent :=
              local_statistic.statistics.transport_access_agent.expedited_pdus_sent -
              last_namve_osi_statistic^.statistics.transport_access_agent.expedited_pdus_sent;
        namve_osi_statistic.statistics.transport_access_agent.total_bytes_received :=
              local_statistic.statistics.transport_access_agent.total_bytes_received -
              last_namve_osi_statistic^.statistics.transport_access_agent.total_bytes_received;
        namve_osi_statistic.statistics.transport_access_agent.total_bytes_sent :=
              local_statistic.statistics.transport_access_agent.total_bytes_sent -
              last_namve_osi_statistic^.statistics.transport_access_agent.total_bytes_sent;
      IFEND;
      last_namve_osi_statistic^ := local_statistic;
    ELSE
      namve_osi_statistic := local_statistic;
    IFEND;

  PROCEND nap$get_osi_statistics;

?? TITLE := 'statistic_value', EJECT ??

  FUNCTION statistic_value
    (    statistic: ^integer): integer;

    VAR
      actual_value: integer,
      compare_swap_status: osc$cs_successful .. osc$cs_variable_locked,
      initial_value: integer,
      new_value: integer;

    initial_value := 0;
    new_value := 0;

    REPEAT
      #COMPARE_SWAP (statistic^, initial_value, new_value, actual_value, compare_swap_status);
    UNTIL compare_swap_status <> osc$cs_variable_locked;
    statistic_value := actual_value;

  FUNCEND statistic_value;

MODEND nam$fetch_statistical_data;
*DECK DECK=NAM$FILE_ACCESS_ME EXPAND=TRUE
MODULE nam$file_access_me;
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc nac$network_management_catalog
*copyc nac$reserved_saps
*copyc nae$file_access_me_conditions
*copyc nat$gt_interface
*copyc nat$gt_event
*copyc nat$network_message_priority
*copyc nlt$protocol
*copyc ost$date_time
?? POP ??
*copyc amp$get_next
*copyc amp$get_segment_pointer
*copyc amp$return
*copyc amp$set_segment_eoi
*copyc bap$validate_file_identifier
*copyc clp$get_next_scl_proc_line
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc nap$open_di_dump_file
*copyc nap$open_di_load_file
*copyc nap$display_message
*copyc nap$gt_accept_connection
*copyc nap$gt_await_activity_complete
*copyc nap$gt_close_sap
*copyc nap$gt_disconnect
*copyc nap$gt_open_sap
*copyc nap$gt_send_data
*copyc nap$gt_receive_connect_event
*copyc nap$gt_receive_connection_event
*copyc nap$gt_reject_connection
*copyc nap$increment_file_access_stats
*copyc nap$open_entry_point
*copyc nap$open_module
*copyc nap$open_procedure
*copyc nlp$register_title
*copyc nlp$delete_registered_title
*copyc osp$append_status_file
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pfp$attach
*copyc pfp$convert_pf_path_to_fs_path
*copyc pfp$find_cycle_array
*copyc pfp$find_direct_info_record
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_multi_item_info
*copyc pmp$close_object_library
*copyc pmp$get_unique_name
*copyc pmp$log
*copyc osv$lower_to_upper

  CONST
    current_version = '01',
    current_version_size = 2;

  CONST
    create_request_id = 0,
    open_request_id = 2,
    delete_request_id = 4,
    close_request_id = 6,
    write_request_id = 8,
    read_request_id = 10,

    create_response_id = 1,
    open_response_id = 3,
    delete_response_id = 5,
    close_response_id = 7,
    write_response_id = 9,
    read_response_id = 11,

{ Response codes

    normal_response = 0,

{Abnormal response codes

    unspecified_error = 0,
    security_error = 1,
    insufficient_space = 2,
    unrecoverable_io_error = 3,
    file_does_not_exist = 4,
    invalid_file_position = 5,
    file_service_unavailable = 6,
    protocol_error = 7,
    unexpected_close = 8,
    no_seek_on_sequential_file = 9,
    bad_byte_count = 10,
    bad_file_name = 11,

    version = 1;

  CONST
    nac$max_connections = 1000,
    nac$max_dumps = 1000,
    max_data_block = 0ffff(16),
    unit_separator = $CHAR (1f(16));

  TYPE
    network_file_position = 0 .. 0ffffffff(16);

  TYPE
    network_file_size = 0 .. 0ffffffff(16);

  TYPE
    request_header = packed record
      version_number: 0 .. 0ffff(16),
      unused1: boolean,
      access_style: access_style, { create and open requests only }
      unused3: boolean,
      request_id: 0 .. 1f(16),
    recend;

  TYPE
    open_state_request_pdu = record
      header: request_header,
      access_mode: access_mode, { CREATE + OPEN requests only }

{ file_name: string (*)     Variable field of PDU

    recend;

  TYPE
    close_request_pdu = record
      header: request_header,
      filler: 0 .. 0ff(16),
    recend;

  TYPE
    write_request_pdu = record
      header: request_header,
      filler: 0 .. 0ff(16),
      file_position: network_file_position,

{ data: SEQ ( * ),  Data to be        written

    recend;

  TYPE
    read_request_pdu = record
      header: request_header,
      filler: 0 .. 0ff(16),
      file_position: network_file_position,
      length: 0 .. max_data_block,
    recend;

  TYPE
    response_header = packed record
      normal: boolean,
      unused: boolean,
      eoi: boolean, { read responses only }
      response_id: 0 .. 1f(16),
      response_code: 0 .. 0ff(16),
    recend;

  TYPE
    create_response_pdu = record
      header: response_header,
    recend;

  TYPE
    open_response_pdu = record
      header: response_header,
      file_size: network_file_size,
    recend;

  TYPE
    delete_response_pdu = record
      header: response_header,
    recend;

  TYPE
    close_response_pdu = record
      header: response_header,
    recend;

  TYPE
    write_response_pdu = record
      header: response_header,
      file_position: network_file_position,
    recend;

  TYPE
    read_response_pdu = record
      header: response_header,
      file_position: network_file_position,

{ data: SEQ ( * ),       Data read from file

    recend;

  TYPE
    title_info = record
      register: boolean,
      path: ^pft$path,
      network_fn_pattern: ost$string,
      min_file_name_size: 0 .. osc$max_string_size,
      max_file_name_size: 0 .. osc$max_string_size,
      password: nat$directory_password,
      case file_type: network_file_type of
      = boot, configuration, domain_name_server, dump, entry_point, exception, object_module, load_procedure,
            terminal_procedure, user_procedure =
        directory_identifier: nat$directory_entry_identifier,
        title: title_string,
        title_registered: boolean,
      = validation =
        validation_info: ^array [1 .. * ] of validation_title_info,
      casend,
    recend;

  TYPE
    validation_title_info = record
      directory_identifier: nat$directory_entry_identifier,
      title: title_string,
      title_registered: boolean,
    recend;

  TYPE
    title_array = array [boot .. validation] of title_info;

  TYPE
    access_mode = (am$read_write, am$write, am$read);

  TYPE
    fa_state = (closed, open, file_access, write_incomplete);

  TYPE
    access_style = (as$sequential, as$random);

  TYPE
    network_file_type = (boot, configuration, domain_name_server, dump, entry_point, exception, object_module,
          load_procedure, terminal_procedure, user_procedure, validation);

  TYPE
    title_string = record
      size: 0 .. nac$max_title_length,
      value: string (nac$max_title_length),
    recend;

  TYPE
    connection_information = record
      access_mode: access_mode,
      access_style: access_style,
      activity_status: ost$activity_status,
      connection_id: nat$gt_connection_id,
      current_position: network_file_position,
      data_area: array [1 .. 1] of nat$data_fragment,
      data_buffer: SEQ (REP 40(16) of cell),
      lfn: amt$local_file_name,
      file_id: amt$file_identifier,
      file_data: ^SEQ ( * ),
      file_type: network_file_type,
      file_size: network_file_size,
      state: fa_state,
      write_error: boolean,
      next_connection: ^connection_information,
      event: nat$gt_event,
    recend;

  CONST
    vnc$database_file_id='NETWORK VALIDATION DATABASE FILE VERSION 1';

  CONST
    vnc$database_file_id_size = 42;
  CONST
    vnc$date_time_size = 23,
    vnc$max_username_size = 31;

  CONST
    vnc$encrypted_password_size = 13;

  CONST
    vnc$max_delimited_password_size = 12,
    vnc$min_delimited_password_size = 7;

  CONST
    vnc$salt_size = 2;

  TYPE
    vnt$delimited_password = string (vnc$max_delimited_password_size);

  TYPE
    vnt$encrypted_password = string (vnc$encrypted_password_size);

  TYPE
    vnt$salt = string (vnc$salt_size);
  TYPE
    vnt$user_database = array [1 .. *] of vnt$validation_record;

  TYPE
    vnt$validation_record = record
      username: string(vnc$max_username_size),
      password: vnt$encrypted_password,
      date_time: ost$date_time,
    recend;

  VAR
    active_connections: 0 .. nac$max_connections := 0,
    connection_list: ^connection_information := NIL,
    max_connections: 1 .. nac$max_connections,
    max_dumps: 0 .. nac$max_dumps,
    max_dump_size: 0 .. amc$file_byte_limit,
    temp_data_frag: array [1 .. 1] of nat$data_fragment,
    titles_registered: 0 .. 9 := 0,
    trash_container: SEQ (REP 1024 of cell),
    wait_list: ^nat$gt_wait_list,
    wait_list_seq: ^SEQ ( * );

  VAR
    configuration_library_path: array [1 .. 5] of pft$name :=
          [nac$management_family, nac$management_master_catalog, nac$cdcnet_subcatalog,
          nac$site_controlled_subcatalog, nac$configuration_library];

  VAR
    min_file_path: array [1 .. 4] of pft$name := [nac$management_family, nac$management_master_catalog,
          nac$cdcnet_subcatalog, * ];

  VAR
    dns_boot_path: array [1 .. 5] of pft$name := [nac$management_family, nac$management_master_catalog,
          nac$tcp_ip_subcatalog, nac$dns_subcatalog, * ];

  VAR
    exception_list_path: array [1 .. 5] of pft$name := [nac$management_family, nac$management_master_catalog,
          nac$cdcnet_subcatalog, nac$site_controlled_subcatalog, nac$exception_list];

  VAR
    object_library_path: array [1 .. 5] of pft$name := [nac$management_family, nac$management_master_catalog,
          nac$cdcnet_subcatalog, nac$version_subcatalog, nac$di_object_library];

  VAR
    procedures_path: array [1 .. 6] of pft$name := [nac$management_family, nac$management_master_catalog,
          nac$cdcnet_subcatalog, nac$site_controlled_subcatalog, nac$procedures_subcatalog, * ];

  VAR
    validation_path: array [1 .. 6] of pft$name := [nac$management_family, nac$management_master_catalog,
          nac$network_subcatalog, nac$validations_subcatalog, * , nac$validation_library_name];

  VAR
    title_list: title_array := [[FALSE, ^object_library_path, [5, 'BOOT#'], 13, 14, 0, boot, * , [5, '$BOOT'],
          FALSE],

    [FALSE, ^configuration_library_path, [14, 'CONFIGURATION#'], 26, 26, 0, configuration, * , [14,
          '$CONFIGURATION'], FALSE],

    [FALSE, ^dns_boot_path, [4, 'DNS#'], 5, 35, 0, domain_name_server, * , [19, '$DOMAIN_NAME_SERVER'],
          FALSE],

    [FALSE, ^min_file_path, [5, 'DUMP#'], 35, 35, 0, dump, * , [5, '$DUMP'], FALSE],

    [FALSE, ^object_library_path, [6, 'ENTRY#'], 12, 42, 0, entry_point, * , [8, '$LIBRARY'], FALSE],

    [FALSE, ^exception_list_path, [14, 'EXCEPTION_LIST'], 14, 14, 0, exception, * , [10, '$EXCEPTION'],
          FALSE],

    [FALSE, ^object_library_path, [7, 'MODULE#'], 13, 43, 0, object_module, * , [8, '$LIBRARY'], FALSE],

    [FALSE, ^procedures_path, [15, 'LOAD_PROCEDURE#'], 16, 46, 0, load_procedure, * , [15, '$LOAD_PROCEDURE'],
          FALSE],

    [FALSE, ^procedures_path, [19, 'TERMINAL_PROCEDURE#'], 20, 50, 0, terminal_procedure, * , [19,
          '$TERMINAL_PROCEDURE'], FALSE],

    [FALSE, ^procedures_path, [15, 'USER_PROCEDURE#'], 16, 46, 0, user_procedure, * , [15, '$USER_PROCEDURE'],
          FALSE],

    [FALSE, ^validation_path, [13, 'VALIDATION#' CAT current_version], 14, 76, 0, validation, NIL]];

?? TITLE := 'exit_condition_handler', EJECT ??

  PROGRAM nap$file_access_me
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status,
        output_data: array [1 .. 1] of nat$data_fragment;

      delete_titles;
      output_data [1].address := NIL;
      output_data [1].length := 0;
      WHILE connection_list <> NIL DO
        nap$gt_disconnect (connection_list^.connection_id, output_data, local_status);
        delete_connection (connection_list);
      WHILEND;
      nap$gt_close_sap (sap, local_status);

    PROCEND exit_condition_handler;
?? TITLE := 'nap$file_access_me', EJECT ??

    VAR
      activity_status: ost$activity_status,
      address: nat$internet_address,
      connection: ^connection_information,
      connect_buffer: [STATIC] SEQ (REP 20(16) of cell),
      connect_data: [STATIC] array [1 .. 1] of nat$data_fragment :=
            [[^connect_buffer, #SIZE (connect_buffer)]],
      connect_event: nat$gt_connect_event,
      data: ^SEQ ( * ),
      index: integer,
      input_pdu: ^SEQ ( * ),
      new_connection: ^connection_information,
      open_state_pdu: ^open_state_request_pdu,
      output_data: [STATIC] array [1 .. 1] of nat$data_fragment := [[NIL, 0]],
      request_pdu: ^request_header,
      sap: nat$gt_sap_identifier,
      sap_id: nat$internet_sap_identifier;

    process_parameters (parameter_list, title_list, max_connections, max_dumps, max_dump_size, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^exit_condition_handler);

    nap$gt_open_sap (max_connections, nac$system_message_priority, FALSE, sap, address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    register_titles (address, sap);

    ALLOCATE wait_list_seq: [[REP (max_connections + 1) OF nat$gt_activity]];
    RESET wait_list_seq;
    NEXT wait_list: [1 .. 1] IN wait_list_seq;

    wait_list^ [1].activity := nac$gt_await_connect_request;
    wait_list^ [1].sap_id := sap;
    nap$gt_receive_connect_event (sap, connect_data, osc$nowait, connect_event, activity_status, status);
    IF NOT status.normal THEN
      nap$display_message (status);
      EXIT nap$file_access_me;
    IFEND;

  /main_loop/
    WHILE (titles_registered > 0) OR (active_connections > 0) DO
      nap$gt_await_activity_complete (wait_list^, index, status);
      IF status.normal THEN
        output_data [1].address := NIL;
        output_data [1].length := 0;
        IF index = 1 THEN
          IF connect_event.source.kind = osi THEN
            #UNCHECKED_CONVERSION (connect_event.source.osi_address.
                  transport_sap_selector (1, connect_event.source.osi_address.transport_sap_selector_length),
                  sap_id);
          ELSE
            sap_id := connect_event.source.internet_address.sap;
          IFEND;
          IF activity_status.status.normal AND (sap_id = nac$xi_cdna_file_access_sap +
                nac$transport_sap_offset) AND (active_connections < max_connections) THEN
            ALLOCATE new_connection;
            IF new_connection = NIL THEN

{ allocate failed

              nap$gt_reject_connection (connect_event.connection, output_data, status);
              IF NOT status.normal THEN
                nap$display_message (status);
              IFEND;
            ELSE
              new_connection^.state := open;
              new_connection^.connection_id := connect_event.connection;
              new_connection^.data_area [1].address := ^new_connection^.data_buffer;
              new_connection^.data_area [1].length := #SIZE (new_connection^.data_buffer);
              new_connection^.next_connection := connection_list;
              nap$gt_accept_connection (new_connection^.connection_id, output_data, NIL, status);
              IF status.normal THEN
                active_connections := active_connections + 1;

{! Statistics begin

                nap$increment_file_access_stats (1, active_connection);

{! Statistics end

                connection_list := new_connection;
                update_wait_list (connect_event.connection);
                temp_data_frag [1].address := new_connection^.data_area [1].address;
                temp_data_frag [1].length := new_connection^.data_area [1].length;
                nap$gt_receive_connection_event (new_connection^.connection_id, temp_data_frag, osc$nowait,
                      new_connection^.event, new_connection^.activity_status, status);
                IF NOT status.normal THEN
                  nap$display_message (status);
                  delete_connection (new_connection);
                IFEND;
              ELSE
                nap$display_message (status);
                FREE new_connection;
                nap$gt_reject_connection (connect_event.connection, output_data, status);
                IF NOT status.normal THEN
                  nap$display_message (status);
                IFEND;
              IFEND;
            IFEND;
          ELSEIF activity_status.status.normal THEN
            pmp$log ('FA - CONNECTION REJECTED', status);
            nap$gt_reject_connection (connect_event.connection, output_data, status);
            IF NOT status.normal THEN
              nap$display_message (status);
            IFEND;
          IFEND;
          nap$gt_receive_connect_event (sap, connect_data, osc$nowait, connect_event, activity_status,
                status);
          IF NOT status.normal THEN
            nap$display_message (status);
            EXIT nap$file_access_me;
          IFEND;
        ELSE
          find_connection (wait_list^ [index].receive_connection_id, connection);
          IF (connection <> NIL) AND connection^.activity_status.status.normal THEN
            CASE connection^.event.kind OF
            = nac$gt_data_event =
              CASE connection^.state OF
              = open =
                data := ^connection^.data_buffer;
                RESET data;
                NEXT input_pdu: [[REP connection^.event.data.data_length OF cell]] IN data;
                RESET input_pdu;
                NEXT open_state_pdu IN input_pdu;
                IF (open_state_pdu <> NIL) AND connection^.event.data.end_of_message AND
                      (#SIZE (open_state_pdu^) < connection^.event.data.data_length) AND
                      (open_state_pdu^.header.version_number = version) THEN
                  CASE open_state_pdu^.header.request_id OF

                  = create_request_id =
                    create_file (input_pdu, open_state_pdu, connection^);

                  = open_request_id =
                    open_file (input_pdu, open_state_pdu, connection^);

                  = delete_request_id =
                    delete_file (input_pdu, open_state_pdu, connection^);
                  ELSE
                    pmp$log ('FA - INVALID REQUEST FOR OPEN STATE', status);
                    nap$gt_disconnect (connection^.connection_id, output_data, status);
                    IF NOT status.normal THEN
                      nap$display_message (status);
                    IFEND;
                    delete_connection (connection);
                  CASEND;
                ELSE
                  pmp$log ('FA - INVALID PDU FOR OPEN STATE', status);
                  nap$gt_disconnect (connection^.connection_id, output_data, status);
                  IF NOT status.normal THEN
                    nap$display_message (status);
                  IFEND;
                  delete_connection (connection);
                IFEND;

              = file_access =
                data := ^connection^.data_buffer;
                RESET data;
                NEXT input_pdu: [[REP connection^.event.data.data_length OF cell]] IN data;
                RESET input_pdu;
                NEXT request_pdu IN input_pdu;
                IF (request_pdu <> NIL) THEN
                  RESET input_pdu;
                  CASE request_pdu^.request_id OF

                  = close_request_id =
                    close_file (input_pdu, connection^);

                  = write_request_id =
                    write_file (input_pdu, connection^);

                  = read_request_id =
                    read_file (input_pdu, connection^);
                  ELSE
                    pmp$log ('FA - INVALID REQUEST FOR FILE_ACCESS STATE', status);
                    nap$gt_disconnect (connection^.connection_id, output_data, status);
                    IF NOT status.normal THEN
                      nap$display_message (status);
                    IFEND;
                    delete_connection (connection);
                  CASEND;
                ELSE
                  pmp$log ('FA - INVALID PDU FOR FILE_ACCESS STATE', status);
                  nap$gt_disconnect (connection^.connection_id, output_data, status);
                  IF NOT status.normal THEN
                    nap$display_message (status);
                  IFEND;
                  delete_connection (connection);
                IFEND;

              = write_incomplete =

{ Data is written directly to the dump file.

                incomplete_write (connection^);
              ELSE
                pmp$log ('FA - INVALID STATE', status);
                nap$gt_disconnect (connection^.connection_id, output_data, status);
                IF NOT status.normal THEN
                  nap$display_message (status);
                IFEND;
                delete_connection (connection);
              CASEND;

            = nac$gt_expedited_data_event =
              pmp$log ('FA - X-DATA EVENT', status);
              nap$gt_disconnect (connection^.connection_id, output_data, status);
              IF NOT status.normal THEN
                nap$display_message (status);
              IFEND;
              delete_connection (connection);

            = nac$gt_disconnect_event =
              delete_connection (connection);
              pmp$log ('FA - DISCONNECT EVENT', status);
            ELSE
              pmp$log ('FA - UNKNOWN GT EVENT', status);
              nap$gt_disconnect (connection^.connection_id, output_data, status);
              delete_connection (connection);
            CASEND;
          ELSE
            nap$gt_disconnect (wait_list^ [index].receive_connection_id, output_data, status);
            IF NOT status.normal THEN
              nap$display_message (status);
            IFEND;
            IF connection <> NIL THEN
              delete_connection (connection);
            ELSE
              pmp$log ('FA - EVENT ON NON-EXISTENT CONNECTION', status);
            IFEND;
          IFEND;
        IFEND;
      ELSE
        EXIT /main_loop/;
      IFEND;
    WHILEND /main_loop/;
  PROCEND nap$file_access_me;
?? TITLE := 'create_file', EJECT ??

  PROCEDURE create_file
    (VAR input_pdu: ^SEQ ( * );
     VAR create_pdu: ^open_state_request_pdu;
     VAR connection: connection_information);

    CONST
      dump_type_length = 4,
      system_length = 12,
      timestamp_length = 12;

    VAR
      create_response: create_response_pdu,
      dump_file_name: ost$name,
      file_type_available: boolean,
      network_file_name: ^string ( * ),
      network_file_name_length: 0 .. osc$max_string_size,
      opened: boolean,
      output_data: array [1 .. 1] of nat$data_fragment,
      path: ^pft$path,
      status: ost$status;

    create_response.header.response_id := create_response_id;
    connection.access_mode := create_pdu^.access_mode;
    connection.access_style := create_pdu^.header.access_style;
    network_file_name_length := #SIZE (input_pdu^) - #SIZE (create_pdu^);
    NEXT network_file_name: [network_file_name_length] IN input_pdu;
    get_file_info (network_file_name, path, connection.file_type, dump_file_name, status);
    IF status.normal THEN
      CASE connection.file_type OF
      = dump =
        IF connection.access_mode = am$write THEN
          nap$open_di_dump_file (dump_file_name (dump_type_length + 2, system_length),
                dump_file_name (dump_type_length + system_length + 3, timestamp_length),
                dump_file_name (1, dump_type_length), max_dumps, max_dump_size, connection.file_id,
                connection.file_data, opened, status);
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$invalid_access_mode, network_file_name^, status);
        IFEND;
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$invalid_file_access_request, network_file_name^, status);
      CASEND;
    IFEND;
    output_data [1].address := ^create_response;
    output_data [1].length := #SIZE (create_response);
    create_response.header.normal := status.normal;
    IF status.normal THEN
      create_response.header.response_code := normal_response;
      connection.file_size := 0;
      connection.current_position := 0;
      connection.state := file_access;
      nap$gt_send_data (connection.connection_id, output_data, TRUE, osc$wait, connection.activity_status,
            status);
      IF NOT status.normal THEN
        nap$display_message (status);
      IFEND;
      temp_data_frag [1].address := connection.data_area [1].address;
      temp_data_frag [1].length := connection.data_area [1].length;
      nap$gt_receive_connection_event (connection.connection_id, temp_data_frag, osc$nowait, connection.event,
            connection.activity_status, status);
      IF NOT status.normal THEN
        nap$display_message (status);
        delete_connection (^connection);
      IFEND;
    ELSE
      CASE status.condition OF
      = nae$invalid_file_access_request =
        create_response.header.response_code := file_service_unavailable;
      = nae$invalid_access_mode =
        create_response.header.response_code := security_error;
      = nae$bad_file_access_file_name, pfe$bad_last_subcatalog_name, pfe$bad_nth_subcatalog_name,
            pfe$bad_permanent_file_name =
        create_response.header.response_code := bad_file_name;
      = nae$max_files_reached =
        create_response.header.response_code := insufficient_space;
      ELSE
        create_response.header.response_code := unrecoverable_io_error;
        check_file_type_availability (connection.file_type, file_type_available);
      CASEND;
      nap$display_message (status);
      nap$gt_disconnect (connection.connection_id, output_data, status);
      IF NOT status.normal THEN
        nap$display_message (status);
      IFEND;
      delete_connection (^connection);
    IFEND;
  PROCEND create_file;
?? TITLE := 'open_file', EJECT ??

  PROCEDURE open_file
    (VAR input_pdu: ^SEQ ( * );
     VAR open_pdu: ^open_state_request_pdu;
     VAR connection: connection_information);

    CONST
      max_card_type_length = 4,
      object_code_version_length = 4;

    VAR
      card_name: string (max_card_type_length),
      card_type: nat$card_type,
      file_type_available: boolean,
      item_name: ost$name,
      network_file_name: ^string ( * ),
      network_file_name_length: 0 .. osc$max_string_size,
      opened: boolean,
      open_response: open_response_pdu,
      output_data: array [1 .. 1] of nat$data_fragment,
      path: ^pft$path,
      status: ost$status;

    connection.access_mode := open_pdu^.access_mode;
    connection.access_style := open_pdu^.header.access_style;
    network_file_name_length := #SIZE (input_pdu^) - #SIZE (open_pdu^);
    NEXT network_file_name: [network_file_name_length] IN input_pdu;
    get_file_info (network_file_name, path, connection.file_type, item_name, status);
    IF status.normal THEN
      IF connection.access_mode = am$read THEN
        CASE connection.file_type OF
        = boot =
          card_name := item_name (object_code_version_length + 2, max_card_type_length);
          IF card_name = 'ESCI' THEN
            card_type := nac$esci_boot_card;
          ELSEIF card_name = 'HDLC' THEN
            card_type := nac$cim_boot_card;
          ELSEIF card_name = 'MCI ' THEN
            card_type := nac$mci_boot_card;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$invalid_file_access_request, network_file_name^,
                  status);
          IFEND;
          IF status.normal THEN
            nap$open_di_load_file (item_name (1, object_code_version_length), card_type, connection.file_id,
                  connection.file_data, opened, status);
          IFEND;
        = exception, domain_name_server =
          open_sequential_file (path^, connection.file_id, connection.file_data, status);
        = entry_point =
          nap$open_entry_point (path^, item_name, connection.file_id, connection.file_data, connection.lfn,
                status);
        = object_module =
          nap$open_module (path^, item_name, connection.file_id, connection.file_data, connection.lfn,
                status);
        = configuration, load_procedure, terminal_procedure, user_procedure =
          open_scl_procedure (path^, item_name, connection.file_id, connection.file_data, status);
        = validation =
          open_validation_procedure (path^, item_name, connection.file_data, status);
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$invalid_file_access_request, network_file_name^,
                status);
        CASEND;
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$invalid_access_mode, network_file_name^, status);
      IFEND;
    IFEND;
    output_data [1].address := ^open_response;
    output_data [1].length := #SIZE (open_response);
    open_response.header.response_id := open_response_id;
    open_response.header.normal := status.normal;
    IF status.normal THEN

{! Statistics begin

      nap$increment_file_access_stats (1, file_access_request);

{! Statistics end

      open_response.header.response_code := normal_response;
      connection.file_size := #SIZE (connection.file_data^);
      open_response.file_size := connection.file_size;
      connection.current_position := 0;
      connection.state := file_access;
      nap$gt_send_data (connection.connection_id, output_data, TRUE, osc$wait, connection.activity_status,
            status);
      temp_data_frag [1].address := connection.data_area [1].address;
      temp_data_frag [1].length := connection.data_area [1].length;
      nap$gt_receive_connection_event (connection.connection_id, temp_data_frag, osc$nowait, connection.event,
            connection.activity_status, status);
      IF NOT status.normal THEN
        nap$display_message (status);
        delete_connection (^connection);
      IFEND;
    ELSE
      open_response.file_size := 0;
      CASE status.condition OF
      = nae$invalid_file_access_request =
        open_response.header.response_code := file_service_unavailable;
      = nae$invalid_access_mode, pfe$usage_not_permitted, pfe$incorrect_password, pfe$bad_password =
        open_response.header.response_code := security_error;
      = nae$bad_file_access_file_name, pfe$bad_last_subcatalog_name, pfe$bad_nth_subcatalog_name,
            pfe$bad_permanent_file_name, nae$invalid_user_name =
        open_response.header.response_code := bad_file_name;
      = pfe$pf_system_error, nae$record_size_overflow, amc$min_ecc_validation .. amc$max_ecc_program_action =
        open_response.header.response_code := unrecoverable_io_error;
      ELSE
        open_response.header.response_code := file_does_not_exist;
        check_file_type_availability (connection.file_type, file_type_available);
      CASEND;
      IF status.condition <> nae$invalid_user_name THEN
        nap$display_message (status);
      IFEND;
      nap$gt_disconnect (connection.connection_id, output_data, status);
      IF NOT status.normal THEN
        nap$display_message (status);
      IFEND;
      delete_connection (^connection);
    IFEND;
  PROCEND open_file;
?? TITLE := 'delete_file', EJECT ??

  PROCEDURE delete_file
    (VAR input_pdu: ^SEQ ( * );
     VAR delete_pdu: ^open_state_request_pdu;
     VAR connection: connection_information);

    VAR
      delete_response: delete_response_pdu,
      file_type_available: boolean,
      network_file_name: ^string ( * ),
      network_file_name_length: 0 .. osc$max_string_size,
      lowest_cycle: [STATIC, READ] pft$cycle_selector := [pfc$lowest_cycle],
      password: [STATIC, READ] pft$password := ' ',
      output_data: array [1 .. 1] of nat$data_fragment,
      path: ^pft$path,
      status: ost$status,
      unused_name_param: ost$name;

{ NO DELETES OF ANY FILES ARE CURRENTLY ALLOWED

    output_data [1].address := ^delete_response;
    output_data [1].length := #SIZE (delete_response);
    delete_response.header.response_id := delete_response_id;
    delete_response.header.normal := FALSE;
    delete_response.header.response_code := security_error;
    nap$gt_disconnect (connection.connection_id, output_data, status);
    IF NOT status.normal THEN
      nap$display_message (status);
    IFEND;
    delete_connection (^connection);

{   network_file_name_length := #SIZE (input_pdu^) - #SIZE (delete_pdu^);
{   NEXT network_file_name: [network_file_name_length] IN input_pdu;
{   get_file_info (network_file_name, path, connection.file_type, unused_name_param, status);
{   IF status.normal THEN
{     pfp$purge (path^, lowest_cycle, password, status);
{   IFEND;
{   output_data [1].address := ^delete_response;
{   output_data [1].length := #SIZE (delete_response);
{   delete_response.header.response_id := delete_response_id;
{   delete_response.header.normal := status.normal;
{   IF status.normal THEN
{     delete_response.header.response_code := normal_response;
{   ELSE
{     CASE status.condition OF
{     = nae$invalid_file_access_request =
{       delete_response.header.response_code := file_service_unavailable;
{     = nae$bad_file_access_file_name, pfe$bad_last_subcatalog_name, pfe$bad_nth_subcatalog_name,
{           pfe$bad_permanent_file_name =
{       open_response.header.response_code := bad_file_name;
{     = pfe$pf_system_error =
{       delete_response.header.response_code := unrecoverable_io_error;
{     = pfe$usage_not_permitted, pfe$incorrect_password, pfe$bad_password =
{       delete_response.header.response_code := security_error;
{     ELSE
{       delete_response.header.response_code := file_does_not_exist;
{       check_file_type_availability (connection.file_type, file_type_available);
{     CASEND;
{     nap$display_message (status);
{   IFEND;
{   nap$gt_disconnect (connection.connection_id, output_data, status);
{   IF NOT status.normal THEN
{     nap$display_message (status);
{   IFEND;
{   delete_connection (^connection);

  PROCEND delete_file;
?? TITLE := 'close_file', EJECT ??

  PROCEDURE close_file
    (VAR input_pdu: ^SEQ ( * );
     VAR connection: connection_information);

    VAR
      close_pdu: ^close_request_pdu,
      close_response: close_response_pdu,
      entire_file: ^SEQ ( * ),
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      file_name: amt$local_file_name,
      local_status: ost$status,
      output_data: array [1 .. 1] of nat$data_fragment,
      segment_pointer: amt$segment_pointer,
      status: ost$status;

    status.normal := TRUE;
    output_data [1].address := NIL;
    output_data [1].length := 0;
    NEXT close_pdu IN input_pdu;
    IF (close_pdu <> NIL) AND connection.event.data.end_of_message THEN
      IF (connection.file_type <> entry_point) AND (connection.file_type <> object_module) THEN
        IF connection.access_mode <> am$read THEN
          RESET connection.file_data;
          NEXT entire_file: [[REP connection.file_size OF cell]] IN connection.file_data;
          segment_pointer.kind := amc$sequence_pointer;
          segment_pointer.sequence_pointer := connection.file_data;
          amp$set_segment_eoi (connection.file_id, segment_pointer, status);
        IFEND;
        IF connection.file_type <> validation THEN
          bap$validate_file_identifier (connection.file_id, file_instance, file_id_is_valid);
          file_name := file_instance^.local_file_name;
          fsp$close_file (connection.file_id, local_status);
          amp$return (file_name, local_status);
        ELSEIF connection.file_data <> NIL THEN
          FREE connection.file_data;
          local_status.normal := TRUE;
        IFEND;
      ELSE
        pmp$close_object_library (connection.file_id, local_status);
        amp$return (connection.lfn, local_status);
      IFEND;
      connection.state := closed;
      IF status.normal THEN
        status := local_status;
      IFEND;
      output_data [1].address := ^close_response;
      output_data [1].length := #SIZE (close_response);
      close_response.header.response_id := close_response_id;
      close_response.header.normal := status.normal;
      IF status.normal THEN
        close_response.header.response_code := normal_response;
      ELSE
        close_response.header.response_code := unrecoverable_io_error;
        nap$display_message (status);
      IFEND;
    IFEND;
    nap$gt_disconnect (connection.connection_id, output_data, status);
    IF NOT status.normal THEN
      nap$display_message (status);
    IFEND;
    delete_connection (^connection);
  PROCEND close_file;
?? TITLE := 'write_file', EJECT ??

  PROCEDURE write_file
    (VAR input_pdu: ^SEQ ( * );
     VAR connection: connection_information);

    VAR
      output_data: array [1 .. 1] of nat$data_fragment,
      status: ost$status,
      write_block: ^SEQ ( * ),
      write_block_size: 0 .. max_data_block,
      write_data: ^SEQ ( * ),
      write_length: 0 .. max_data_block,
      write_pdu: ^write_request_pdu,
      write_response: write_response_pdu;

    NEXT write_pdu IN input_pdu;
    IF write_pdu <> NIL THEN
      connection.write_error := FALSE;
      IF connection.access_style = as$random THEN
        IF write_pdu^.file_position <> connection.current_position THEN
          connection.current_position := write_pdu^.file_position;
          RESET connection.file_data;
          NEXT write_data: [[REP write_pdu^.file_position OF cell]] IN connection.file_data;
        IFEND;
      IFEND;
      write_length := #SIZE (input_pdu^) - #SIZE (write_pdu^);
      NEXT write_data: [[REP write_length OF cell]] IN input_pdu;
      perform_write (write_data, connection.file_data, status);
      IF NOT status.normal THEN
        connection.write_error := TRUE;
        nap$display_message (status);
      ELSE
        connection.current_position := connection.current_position + write_length;
        IF connection.current_position > connection.file_size THEN
          connection.file_size := connection.current_position;
        IFEND;
      IFEND;
      IF connection.event.data.end_of_message THEN
        output_data [1].address := ^write_response;
        output_data [1].length := #SIZE (write_response);
        write_response.header.response_id := write_response_id;
        IF connection.write_error THEN
          write_response.header.normal := FALSE;
          write_response.header.response_code := insufficient_space;
        ELSE
          write_response.header.normal := TRUE;
          write_response.header.response_code := normal_response;
        IFEND;
        write_response.file_position := connection.current_position;
        nap$gt_send_data (connection.connection_id, output_data, TRUE, osc$wait, connection.activity_status,
              status);
        IF NOT status.normal THEN
          nap$display_message (status);
        IFEND;
        temp_data_frag [1].address := connection.data_area [1].address;
        temp_data_frag [1].length := connection.data_area [1].length;
        nap$gt_receive_connection_event (connection.connection_id, temp_data_frag, osc$nowait,
              connection.event, connection.activity_status, status);
        IF NOT status.normal THEN
          nap$display_message (status);
          delete_connection (^connection);
        IFEND;
      ELSE
        connection.state := write_incomplete;
        IF max_dump_size - connection.file_size < max_data_block THEN
          write_block_size := max_dump_size - connection.file_size;
          IF write_block_size = 0 THEN
            connection.write_error := TRUE;
            osp$set_status_condition (nae$write_beyond_file_limit, status);
            nap$display_message (status);
          IFEND;
        ELSE
          write_block_size := max_data_block;
        IFEND;
        IF connection.write_error THEN
          connection.data_area [1].address := ^trash_container;
          connection.data_area [1].length := #SIZE (trash_container);
        ELSE
          NEXT write_block: [[REP write_block_size OF cell]] IN connection.file_data;
          connection.data_area [1].address := write_block;
          connection.data_area [1].length := write_block_size;
        IFEND;
        temp_data_frag [1].address := connection.data_area [1].address;
        temp_data_frag [1].length := connection.data_area [1].length;
        nap$gt_receive_connection_event (connection.connection_id, temp_data_frag, osc$nowait,
              connection.event, connection.activity_status, status);
        IF NOT status.normal THEN
          nap$display_message (status);
          delete_connection (^connection);
        IFEND;
      IFEND;
    ELSE
      output_data [1].address := NIL;
      output_data [1].length := 0;
      nap$gt_disconnect (connection.connection_id, output_data, status);
      IF NOT status.normal THEN
        nap$display_message (status);
      IFEND;
      delete_connection (^connection);
    IFEND;
  PROCEND write_file;
?? TITLE := 'read_file', EJECT ??

  PROCEDURE read_file
    (VAR input_pdu: ^SEQ ( * );
     VAR connection: connection_information);

    VAR
      data_transferred: 0 .. 0ffff(16),
      output_data: array [1 .. 2] of nat$data_fragment,
      read_data: ^SEQ ( * ),
      read_pdu: ^read_request_pdu,
      read_response: read_response_pdu,
      status: ost$status;

    NEXT read_pdu IN input_pdu;
    IF (read_pdu <> NIL) AND connection.event.data.end_of_message THEN
      read_response.header.eoi := FALSE;
      read_response.header.response_id := read_response_id;
      read_data := NIL;
      data_transferred := 0;
      IF read_pdu^.length > 0 THEN
        IF connection.access_style = as$random THEN
          IF read_pdu^.file_position <> connection.current_position THEN
            IF read_pdu^.file_position > connection.file_size THEN
              connection.current_position := connection.file_size;
            ELSE
              connection.current_position := read_pdu^.file_position;
            IFEND;
            RESET connection.file_data;
            NEXT read_data: [[REP connection.current_position OF cell]] IN connection.file_data;
          IFEND;
        IFEND;
        IF connection.current_position + read_pdu^.length >= connection.file_size THEN
          read_response.header.eoi := TRUE;
          data_transferred := connection.file_size - connection.current_position;
        ELSE
          data_transferred := read_pdu^.length;
        IFEND;
        IF data_transferred > 0 THEN
          NEXT read_data: [[REP data_transferred OF cell]] IN connection.file_data;
          connection.current_position := connection.current_position + data_transferred;
        IFEND;
      IFEND;
      output_data [1].address := ^read_response;
      output_data [1].length := #SIZE (read_response);
      output_data [2].address := read_data;
      output_data [2].length := data_transferred;
      read_response.header.normal := TRUE;
      read_response.header.response_code := normal_response;
      read_response.file_position := connection.current_position;
      nap$gt_send_data (connection.connection_id, output_data, TRUE, osc$wait, connection.activity_status,
            status);
      IF NOT status.normal THEN
        nap$display_message (status);
      IFEND;
      temp_data_frag [1].address := connection.data_area [1].address;
      temp_data_frag [1].length := connection.data_area [1].length;
      nap$gt_receive_connection_event (connection.connection_id, temp_data_frag, osc$nowait, connection.event,
            connection.activity_status, status);
      IF NOT status.normal THEN
        nap$display_message (status);
        delete_connection (^connection);
      IFEND;
    ELSE
      output_data [1].address := NIL;
      output_data [1].length := 0;
      output_data [2].address := NIL;
      output_data [2].length := 0;
      nap$gt_disconnect (connection.connection_id, output_data, status);
      IF NOT status.normal THEN
        nap$display_message (status);
      IFEND;
      delete_connection (^connection);
    IFEND;
  PROCEND read_file;

?? TITLE := 'incomplete_write', EJECT ??

  PROCEDURE incomplete_write
    (VAR connection: connection_information);

    VAR
      output_data: array [1 .. 1] of nat$data_fragment,
      status: ost$status,
      write_file: ^SEQ ( * ),
      write_response: write_response_pdu;

    IF NOT connection.write_error THEN
      connection.current_position := connection.current_position + connection.event.data.data_length;
      IF connection.current_position > connection.file_size THEN
        connection.file_size := connection.current_position;
      IFEND;
      RESET connection.file_data;
      NEXT write_file: [[REP connection.file_size OF cell]] IN connection.file_data;
    IFEND;
    IF connection.event.data.end_of_message THEN
      output_data [1].address := ^write_response;
      output_data [1].length := #SIZE (write_response);
      write_response.header.response_id := write_response_id;
      IF connection.write_error THEN
        write_response.header.normal := FALSE;
        write_response.header.response_code := insufficient_space;
      ELSE
        write_response.header.normal := TRUE;
        write_response.header.response_code := 0;
      IFEND;
      write_response.file_position := connection.current_position;
      nap$gt_send_data (connection.connection_id, output_data, TRUE, osc$wait, connection.activity_status,
            status);
      IF NOT status.normal THEN
        nap$display_message (status);
      IFEND;
      connection.state := file_access;
      connection.data_area [1].address := ^connection.data_buffer;
      connection.data_area [1].length := #SIZE (connection.data_buffer);
    ELSE
      IF NOT connection.write_error THEN
        connection.write_error := TRUE;
        connection.data_area [1].address := ^trash_container;
        connection.data_area [1].length := #SIZE (trash_container);
        osp$set_status_condition (nae$write_beyond_file_limit, status);
        nap$display_message (status);
      IFEND;
    IFEND;
    temp_data_frag [1].address := connection.data_area [1].address;
    temp_data_frag [1].length := connection.data_area [1].length;
    nap$gt_receive_connection_event (connection.connection_id, temp_data_frag, osc$nowait, connection.event,
          connection.activity_status, status);
    IF NOT status.normal THEN
      nap$display_message (status);
      delete_connection (^connection);
    IFEND;

  PROCEND incomplete_write;

?? TITLE := 'check_file_type_availability', EJECT ??

  PROCEDURE check_file_type_availability
    (    file_type: network_file_type;
     VAR file_type_available: boolean);

    VAR
      high_cycle: [STATIC, READ] pft$cycle_selector := [pfc$highest_cycle],
      local_status: ost$status,
      name: ost$name,
      password: [STATIC, READ] pft$password := ' ',
      path: ^pft$path,
      share: [STATIC, READ] pft$share_selections := [pfc$read],
      usage: [STATIC, READ] pft$usage_selections := [pfc$read];

{ File types 'object_module', 'entry_point', 'boot' and 'dump' are mapped into the
{ same check. This is because of the fact that the non-existance of a
{ specific subcatalog does not imply that the file type is unavailable. So for the
{ above mentioned file types the only check to be made is that the path:
{ $SYSTEM.CDCNET exists.
{ File type 'domain_name_server' checks specifically for the presence of the
{ $SYSTEM.TCP_IP.DNS catalog, but cannot check for the existence
{ of specific zone files, nor is the name of the boot file static (it can be
{ specified when the server is booted).

    pmp$get_unique_name (name, local_status);
    path := title_list [file_type].path;

    CASE file_type OF
    = load_procedure =
      path^ [UPPERBOUND (path^)] := nac$load_procedures;
    = terminal_procedure =
      path^ [UPPERBOUND (path^)] := nac$terminal_procedures;
    = user_procedure =
      path^ [UPPERBOUND (path^)] := nac$user_procedures;
    = boot, dump, entry_point, object_module =
      path := ^min_file_path;
      path^ [UPPERBOUND (path^)] := name;
    = domain_name_server =
      path^ [UPPERBOUND (path^)] := name;
    ELSE
    CASEND;

    pfp$attach (name, path^, high_cycle, password, usage, share, pfc$no_wait, local_status);

    CASE file_type OF
    = configuration, exception, load_procedure, terminal_procedure, user_procedure =
      IF local_status.normal OR (local_status.condition = pfe$cycle_busy) THEN
        file_type_available := TRUE;
        IF local_status.normal THEN
          amp$return (name, local_status);
        IFEND;
      ELSE
        file_type_available := FALSE;
      IFEND;
    = boot, domain_name_server, dump, entry_point, object_module =
      file_type_available := (local_status.condition <> pfe$unknown_last_subcatalog) AND
            (local_status.condition <> pfe$unknown_nth_subcatalog);
    ELSE
    CASEND;
    IF (NOT file_type_available) AND title_list [file_type].title_registered THEN
      nlp$delete_registered_title (title_list [file_type].title.value (1, title_list [file_type].title.size),
            title_list [file_type].password, title_list [file_type].directory_identifier, local_status);
      IF local_status.normal THEN
        title_list [file_type].title_registered := FALSE;
        titles_registered := titles_registered - 1;
        osp$set_status_abnormal (nac$status_id, nae$file_type_unavailable, title_list [file_type].title.
              value (2, * ), local_status);
      IFEND;
      nap$display_message (local_status);
    IFEND;
  PROCEND check_file_type_availability;
?? TITLE := 'delete_connection', EJECT ??

  PROCEDURE delete_connection
    (    connect_info: ^connection_information);

    VAR
      connection: ^connection_information,
      connection_link: ^^connection_information,
      entire_file: ^SEQ ( * ),
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      file_name: amt$local_file_name,
      i: 1 .. nac$max_connections,
      local_status: ost$status,
      segment_pointer: amt$segment_pointer;

    connection := connect_info;

  /forloop/
    FOR i := 2 TO UPPERBOUND (wait_list^) DO
      IF (wait_list^ [i].activity = nac$gt_await_receive_event) AND
            (wait_list^ [i].receive_connection_id = connection^.connection_id) THEN
        wait_list^ [i].activity := nac$gt_null_activity;
        EXIT /forloop/;
      IFEND;
    FOREND /forloop/;
    IF i = UPPERBOUND (wait_list^) THEN
      WHILE wait_list^ [i].activity = nac$gt_null_activity DO
        i := i - 1;
      WHILEND;
      RESET wait_list_seq;
      NEXT wait_list: [1 .. i] IN wait_list_seq;
    IFEND;

    IF (connection^.state = file_access) OR (connection^.state = write_incomplete) THEN
      IF (connection^.file_type <> entry_point) AND (connection^.file_type <> object_module) THEN
        IF connection^.access_mode <> am$read THEN
          RESET connection^.file_data;
          NEXT entire_file: [[REP connection^.file_size OF cell]] IN connection^.file_data;
          segment_pointer.kind := amc$sequence_pointer;
          segment_pointer.sequence_pointer := connection^.file_data;
          amp$set_segment_eoi (connection^.file_id, segment_pointer, local_status);
        IFEND;
        IF connection^.file_type <> validation THEN
          bap$validate_file_identifier (connection^.file_id, file_instance, file_id_is_valid);
          file_name := file_instance^.local_file_name;
          fsp$close_file (connection^.file_id, local_status);
          amp$return (file_name, local_status);
        ELSEIF connection^.file_data <> NIL THEN
          FREE connection^.file_data;
        IFEND;
      ELSE
        pmp$close_object_library (connection^.file_id, local_status);
        amp$return (connection^.lfn, local_status);
      IFEND;
    IFEND;
    connection_link := ^connection_list;
    WHILE (connection_link^ <> NIL) AND (connection_link^ <> connection) DO
      connection_link := ^connection_link^^.next_connection;
    WHILEND;
    IF connection_link^ <> NIL THEN
      connection_link^ := connection^.next_connection;
      FREE connection;
      active_connections := active_connections - 1;

{! Statistics begin

      nap$increment_file_access_stats (-1, active_connection);

{! Statistics end

    IFEND;
  PROCEND delete_connection;

?? TITLE := 'delete_titles', EJECT ??

  PROCEDURE delete_titles;

    VAR
      i: network_file_type,
      j: integer,
      local_status: ost$status;

    FOR i := LOWERBOUND (title_list) TO UPPERBOUND (title_list) DO
      IF i = validation THEN
        IF title_list [i].validation_info <> NIL THEN
          FOR j := LOWERBOUND (title_list [i].validation_info^) TO UPPERBOUND (title_list [i].
                validation_info^) DO
            IF title_list [i].validation_info^ [j].title_registered THEN
              nlp$delete_registered_title (title_list [i].validation_info^ [j].title.value (1,
                    title_list [i].validation_info^ [j].title.size), title_list [i].password,
                    title_list [i].validation_info^ [j].directory_identifier, local_status);
              IF local_status.normal THEN
                title_list [i].validation_info^ [j].title_registered := FALSE;
                titles_registered := titles_registered - 1;
              ELSE
                nap$display_message (local_status);
              IFEND;
            IFEND;
          FOREND;
        IFEND;
      ELSEIF title_list [i].title_registered THEN
        nlp$delete_registered_title (title_list [i].title.value (1, title_list [i].title.size),
              title_list [i].password, title_list [i].directory_identifier, local_status);
        IF local_status.normal THEN
          title_list [i].title_registered := FALSE;
          titles_registered := titles_registered - 1;
        ELSE
          nap$display_message (local_status);
        IFEND;
      IFEND;
    FOREND;
  PROCEND delete_titles;

?? TITLE := 'find_connection', EJECT ??

  PROCEDURE [INLINE] find_connection
    (    connection_id: nat$gt_connection_id;
     VAR connection: ^connection_information);

    connection := connection_list;
    WHILE (connection <> NIL) AND (connection^.connection_id <> connection_id) DO
      connection := connection^.next_connection;
    WHILEND;
  PROCEND find_connection;

?? TITLE := 'get_domain_and_user', EJECT ??

  PROCEDURE get_domain_and_user
    (    network_fn: ^string ( * );
     VAR domain_name: ost$name;
     VAR user_name: ost$name;
     VAR status: ost$status);

    VAR
      i: integer,
      j: integer;

    status.normal := TRUE;
    i := 1;

{ Skip 'VALIDATION#vv_'

    WHILE (i <= STRLENGTH (network_fn^)) AND (network_fn^ (i) <> '_') DO
      i := i + 1;
    WHILEND;

    i := i + 1;

    IF i < STRLENGTH (network_fn^) THEN
      j := i;
      WHILE (j <= STRLENGTH (network_fn^)) AND (network_fn^ (j) <> '@') DO
        j := j + 1;
      WHILEND;
      IF (j < STRLENGTH (network_fn^)) THEN
        user_name := osc$null_name;
        user_name := network_fn^ (i, j - i);
        domain_name := osc$null_name;
        domain_name := network_fn^ (j + 1, STRLENGTH (network_fn^) - j);
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$bad_file_access_file_name, network_fn^, status);
      IFEND;
    ELSE
      osp$set_status_abnormal (nac$status_id, nae$bad_file_access_file_name, network_fn^, status);
    IFEND;

  PROCEND get_domain_and_user;

?? TITLE := 'get_file_info', EJECT ??

  PROCEDURE get_file_info
    (    network_file_name: ^string ( * );
     VAR path: ^pft$path;
     VAR file_type: network_file_type;
     VAR item_name: ost$name;
     VAR status: ost$status);

    CONST
      config_proc_name_prefix = 'SYSTEM_',
      config_proc_name_prefix_size = 7,
      version_catalog_prefix_size = 8,
      version_length = 4;

    VAR
      domain_name: ost$name,
      i: network_file_type,
      user_name: ost$name;

    osp$set_status_abnormal (nac$status_id, nae$invalid_file_access_request, network_file_name^, status);

  /loop1/
    FOR i := LOWERBOUND (title_list) TO UPPERBOUND (title_list) DO
      IF network_file_name^ (1, title_list [i].network_fn_pattern.size) = title_list [i].
            network_fn_pattern.value THEN
        IF (STRLENGTH (network_file_name^) >= title_list [i].min_file_name_size) AND
              (STRLENGTH (network_file_name^) <= title_list [i].max_file_name_size) THEN
          path := title_list [i].path;
          file_type := title_list [i].file_type;
          CASE file_type OF
          = boot, dump =
            item_name := network_file_name^ (title_list [i].network_fn_pattern.size + 1, * );
          = configuration =
            item_name := config_proc_name_prefix;
            item_name (config_proc_name_prefix_size + 1, * ) :=
                  network_file_name^ (title_list [i].network_fn_pattern.size + 1, * );
          = domain_name_server =
            item_name := network_file_name^ (title_list [i].network_fn_pattern.size + 1, * );
            path^ [UPPERBOUND (path^)] := item_name;
          = entry_point, object_module =
            path^ [UPPERBOUND (path^) - 1] (version_catalog_prefix_size + 1,
                  version_length) := network_file_name^ (title_list [i].network_fn_pattern.size + 1,
                  version_length);
            item_name := network_file_name^ (title_list [i].network_fn_pattern.size + 1 + version_length +
                  1, * );
          = load_procedure =
            path^ [UPPERBOUND (path^)] := nac$load_procedures;
            item_name := network_file_name^ (title_list [i].network_fn_pattern.size + 1, * );
          = terminal_procedure =
            path^ [UPPERBOUND (path^)] := nac$terminal_procedures;
            item_name := network_file_name^ (title_list [i].network_fn_pattern.size + 1, * );
          = user_procedure =
            path^ [UPPERBOUND (path^)] := nac$user_procedures;
            item_name := network_file_name^ (title_list [i].network_fn_pattern.size + 1, * );
          = validation =
            get_domain_and_user (network_file_name, domain_name, user_name, status);
            IF status.normal THEN
              path^ [UPPERBOUND (path^) - 1] := domain_name;
              item_name := user_name;
            ELSE
              EXIT /loop1/;
            IFEND;
          ELSE
          CASEND;
          status.normal := TRUE;
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$bad_file_access_file_name, network_file_name^, status);
        IFEND;
        EXIT /loop1/
      IFEND;
    FOREND /loop1/;

  PROCEND get_file_info;


?? TITLE := 'get_validation_titles', EJECT ??

  PROCEDURE get_validation_titles
    (VAR titles: ^array [1 .. * ] of validation_title_info;
     VAR status: ost$status);

    VAR
      catalog_content_info: amt$segment_pointer,
      cycle_array: pft$p_cycle_array,
      end_of_directory: ^integer,
      group: pft$group,
      i: integer,
      index: integer,
      item_record: pft$p_info_record,
      new_title: title_string,
      path: ^pft$path,
      p_catalog_directory: pft$p_directory_array,
      p_info_record: pft$p_info_record,
      p_subcatalog_directory: pft$p_directory_array,
      subcatalog_path: ^pft$path,
      subdirectory_record: pft$p_info_record,
      subindex: integer,
      temp_titles: ^array [1 .. * ] of validation_title_info,
      title_size: integer;


    status.normal := TRUE;
    titles := NIL;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, catalog_content_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    group.group_type := pfc$member;
    group.member_description.family := osc$null_name;
    group.member_description.account := osc$null_name;
    group.member_description.project := osc$null_name;
    group.member_description.user := osc$null_name;

    PUSH path: [LOWERBOUND (validation_path) .. UPPERBOUND (validation_path) - 2];
    PUSH subcatalog_path: [LOWERBOUND (validation_path) .. UPPERBOUND (validation_path) - 1];
    FOR i := LOWERBOUND (path^) TO UPPERBOUND (path^) DO
      path^ [i] := validation_path [i];
      subcatalog_path^ [i] := validation_path [i];
    FOREND;

    RESET catalog_content_info.sequence_pointer;
    pfp$get_multi_item_info (path^, group, -$pft$catalog_info_selections [], -$pft$file_info_selections [],
          catalog_content_info.sequence_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT end_of_directory IN catalog_content_info.sequence_pointer;
    RESET catalog_content_info.sequence_pointer;
    pfp$find_next_info_record (catalog_content_info.sequence_pointer, p_info_record, status);
    IF status.normal THEN
      pfp$find_directory_array (p_info_record, p_catalog_directory, status);
      IF (status.normal) AND (p_catalog_directory <> NIL) THEN

      /scan_directory/
        FOR index := LOWERBOUND (p_catalog_directory^) TO UPPERBOUND (p_catalog_directory^) DO
          CASE p_catalog_directory^ [index].name_type OF
          = pfc$catalog_name =
            RESET catalog_content_info.sequence_pointer TO end_of_directory;
            subcatalog_path^ [UPPERBOUND (subcatalog_path^)] := p_catalog_directory^ [index].name;
            pfp$get_multi_item_info (subcatalog_path^, group, -$pft$catalog_info_selections [],
                  -$pft$file_info_selections [], catalog_content_info.sequence_pointer, status);
            IF NOT status.normal THEN
              CYCLE /scan_directory/;
            IFEND;
            RESET catalog_content_info.sequence_pointer TO end_of_directory;
            pfp$find_next_info_record (catalog_content_info.sequence_pointer, subdirectory_record, status);
            IF status.normal THEN
              pfp$find_directory_array (subdirectory_record, p_subcatalog_directory, status);
              IF (status.normal) AND (p_subcatalog_directory <> NIL) THEN
                FOR subindex := LOWERBOUND (p_subcatalog_directory^)
                      TO UPPERBOUND (p_subcatalog_directory^) DO
                  IF (p_subcatalog_directory^ [subindex].name_type = pfc$file_name) AND
                        (p_subcatalog_directory^ [subindex].name = nac$validation_library_name) THEN
                    pfp$find_direct_info_record (^subdirectory_record^.body,
                          p_subcatalog_directory^ [subindex].info_offset, item_record, status);
                    pfp$find_cycle_array (item_record, cycle_array, status);
                    IF status.normal THEN
                      IF (UPPERBOUND (cycle_array^) > 1) OR (cycle_array^ [1].cycle_number > 1) THEN
                        STRINGREP (new_title.value, title_size, '$VALIDATION#', current_version, '@',
                              p_catalog_directory^ [index].name (1, clp$trimmed_string_size (
                              p_catalog_directory^ [index].name)));
                        new_title.size := title_size;
                        IF titles <> NIL THEN
                          ALLOCATE temp_titles: [1 .. UPPERBOUND (titles^) + 1];
                          FOR i := 1 TO UPPERBOUND (titles^) DO
                            temp_titles^ [i] := titles^ [i];
                          FOREND;
                          temp_titles^ [UPPERBOUND (titles^) + 1].title := new_title;
                          temp_titles^ [UPPERBOUND (titles^) + 1].title_registered := FALSE;
                          FREE titles;
                          titles := temp_titles;
                        ELSE
                          ALLOCATE titles: [1 .. 1];
                          titles^ [1].title := new_title;
                          titles^ [1].title_registered := FALSE;
                        IFEND;
                      ELSE

{ Warning message??????

                      IFEND;
                    IFEND;
                    CYCLE /scan_directory/;
                  IFEND;
                FOREND;
              IFEND;
            IFEND;

          = pfc$file_name =
            ; { Do nothing - skip this file entry

          ELSE
          CASEND;
        FOREND /scan_directory/;
      IFEND;
    IFEND;

    mmp$delete_scratch_segment (catalog_content_info, status);

  PROCEND get_validation_titles;

?? TITLE := 'register_titles', EJECT ??

  PROCEDURE register_titles
    (    address: nat$internet_address;
         sap: nat$gt_sap_identifier);

    VAR
      class: nat$title_class,
      distribute: boolean,
      domain: nat$title_domain,
      file_type_available: boolean,
      i: network_file_type,
      j: integer,
      local_status: ost$status,
      osi_address: nat$osi_registration_address,
      priority: nat$directory_priority,
      service: nat$protocol,
      user_identifier: ost$name;


    local_status.normal := TRUE;
    osi_address.kind := nac$osi_transport_address;
    osi_address.transport_selector := sap.osi_sap_identifier;
    service := nac$cdna_transport;
    priority := nac$max_directory_priority;
    domain.kind := nac$catenet_domain;
    distribute := FALSE;
    class := nac$cdna_internal;
    user_identifier := '$FILE_ACCESS_ME';

    FOR i := LOWERBOUND (title_list) TO UPPERBOUND (title_list) DO
      IF title_list [i].register THEN
        IF i = validation THEN
          get_validation_titles (title_list [i].validation_info, local_status);
          IF (local_status.normal) AND (title_list [i].validation_info <> NIL) THEN
            FOR j := LOWERBOUND (title_list [i].validation_info^) TO UPPERBOUND (title_list [i].
                  validation_info^) DO
              nlp$register_title (title_list [i].validation_info^ [j].title.value (1,
                    title_list [i].validation_info^ [j].title.size), osi_address, service, NIL, 0, priority,
                    domain, distribute, class, title_list [i].password, user_identifier,
                    title_list [i].validation_info^ [j].directory_identifier, local_status);
              IF local_status.normal THEN
                title_list [i].validation_info^ [j].title_registered := TRUE;
                titles_registered := titles_registered + 1;
              ELSE
                nap$display_message (local_status);
              IFEND;
            FOREND;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$file_type_unavailable, 'VALIDATION', local_status);
            nap$display_message (local_status);
          IFEND;
        ELSE
          check_file_type_availability (i, file_type_available);
          IF file_type_available THEN
            nlp$register_title (title_list [i].title.value (1, title_list [i].title.size),
                  osi_address, service, NIL, 0, priority, domain, distribute, class, title_list [i].password,
                  user_identifier, title_list [i].directory_identifier, local_status);
            IF local_status.normal THEN
              title_list [i].title_registered := TRUE;
              titles_registered := titles_registered + 1;
            ELSE
              nap$display_message (local_status);
            IFEND;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$file_type_unavailable, title_list [i].
                  title.value (2, * ), local_status);
            nap$display_message (local_status);
          IFEND;
        IFEND;
      IFEND;
    FOREND;
  PROCEND register_titles;

?? TITLE := 'open_sequential_file', EJECT ??

  PROCEDURE open_sequential_file
    (    path: pft$path;
     VAR file_id: amt$file_identifier;
     VAR file_data: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      actual_position: ^SEQ ( * ),
      attachment_selections: [STATIC, READ] array [1 .. 3] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$read]], * ],
            [fsc$sequential_access, TRUE], [fsc$free_behind, TRUE]],
      attribute_validation: [STATIC, READ] array [1 .. 1] of fst$file_cycle_attribute :=
            [[fsc$file_organization, amc$sequential]],
      byte_address: amt$file_byte_address,
      file_pointer: amt$segment_pointer,
      file_size: 0 .. 0ffffffff(16),
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      highest_cycle: [STATIC, READ] pft$cycle_selector := [pfc$highest_cycle],
      lf_attachment_selections: [STATIC, READ] array [1 .. 3] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes,
            [fsc$read, fsc$shorten, fsc$append]], * ], [fsc$sequential_access, TRUE],
            [fsc$free_behind, TRUE]],
      lf_name: ost$name,
      local_status: ost$status,
      name: ost$name,
      next_byte: ^string (1),
      password: [STATIC, READ] pft$password := ' ',
      position: amt$file_position,
      segment_file: ^SEQ ( * ),
      seq_file_id: amt$file_identifier,
      share_selections: [STATIC, READ] pft$share_selections := [pfc$read],
      transfer_count: amt$transfer_count,
      usage_selections: [STATIC, READ] pft$usage_selections := [pfc$read],
      working_storage_area: ^string (osc$max_string_size),
      working_storage_length: amt$working_storage_length;

    status.normal := TRUE;

    pmp$get_unique_name (name, status);
    pfp$attach (name, path, highest_cycle, password, usage_selections, share_selections, pfc$no_wait, status);
    IF status.normal THEN
      fsp$open_file (name, amc$record, ^attachment_selections, {default_creation_attributes =} NIL,
            {mandated_creation_attributes =} NIL, ^attribute_validation, {attribute_override =} NIL,
            seq_file_id, status);
      IF status.normal THEN
        pmp$get_unique_name (lf_name, status);
        fsp$open_file (lf_name, amc$segment, ^lf_attachment_selections, {default_creation_attributes =} NIL,
              {mandated_creation_attributes =} NIL, {attribute_validation =} NIL, {attribute_override =} NIL,
              file_id, status);
        IF status.normal THEN
          amp$get_segment_pointer (file_id, amc$sequence_pointer, file_pointer, status);
          IF status.normal THEN
            segment_file := file_pointer.sequence_pointer;
            RESET segment_file;
            working_storage_length := osc$max_string_size;
            file_size := 0;
            REPEAT
              NEXT working_storage_area IN segment_file;
              amp$get_next (seq_file_id, working_storage_area, working_storage_length, transfer_count,
                    byte_address, position, status);
              IF status.normal AND (position = amc$eor) THEN
                file_size := file_size + transfer_count;
                RESET segment_file TO working_storage_area;
                IF transfer_count > 0 THEN
                  NEXT actual_position: [[REP transfer_count OF cell]] IN segment_file;
                IFEND;
                NEXT next_byte IN segment_file;
                next_byte^ := unit_separator;
                file_size := file_size + 1;
              IFEND;
            UNTIL (NOT status.normal) OR (position <> amc$eor);
            IF status.normal AND (position <> amc$eoi) THEN
              pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
              osp$set_status_abnormal (nac$status_id, nae$record_size_overflow, fs_path (1, fs_path_size),
                    status);
            IFEND;
            IF status.normal THEN
              RESET segment_file;
              NEXT file_data: [[REP file_size OF cell]] IN segment_file;
            ELSE
              fsp$close_file (file_id, local_status);
              amp$return (lf_name, local_status);
            IFEND;
          ELSE
            fsp$close_file (file_id, local_status);
            amp$return (lf_name, local_status);
          IFEND;
        IFEND;
        fsp$close_file (seq_file_id, local_status);
        amp$return (name, local_status);
      ELSE
        amp$return (name, local_status);
      IFEND;
    IFEND;
  PROCEND open_sequential_file;

?? TITLE := 'open_scl_procedure', EJECT ??

  PROCEDURE open_scl_procedure
    (    path: pft$path;
         procedure_name: ost$name;
     VAR file_id: amt$file_identifier;
     VAR file_data: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      attachment_selections: [STATIC, READ] array [1 .. 1] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes,
            [fsc$read, fsc$shorten, fsc$append]], * ]],
      file_pointer: amt$segment_pointer,
      file_size: 0 .. 0ffffffff(16),
      highest_cycle: [STATIC, READ] pft$cycle_selector := [pfc$highest_cycle],
      line: ^clt$command_line,
      local_file_name: amt$local_file_name,
      local_status: ost$status,
      name: ost$name,
      next_byte: ^string (1),
      password: [STATIC, READ] pft$password := ' ',
      proc_file_id: amt$file_identifier,
      proc_line: ^clt$command_line,
      scl_procedure: ^clt$scl_procedure,
      segment_file: ^SEQ ( * );

    status.normal := TRUE;

    nap$open_procedure (path, procedure_name, proc_file_id, scl_procedure, local_file_name, status);
    IF status.normal THEN
      pmp$get_unique_name (name, status);
      fsp$open_file (name, amc$segment, ^attachment_selections, {default_creation_attributes =} NIL,
            {mandated_creation_attributes =} NIL, {attribute_validation =} NIL, {attribute_override =} NIL,
            file_id, status);
      IF status.normal THEN
        amp$get_segment_pointer (file_id, amc$sequence_pointer, file_pointer, status);
        IF status.normal THEN
          segment_file := file_pointer.sequence_pointer;
          RESET segment_file;
          file_size := 0;
          REPEAT
            clp$get_next_scl_proc_line (scl_procedure, proc_line, status);
            IF proc_line <> NIL THEN
              file_size := file_size + STRLENGTH (proc_line^);
              NEXT line: [STRLENGTH (proc_line^)] IN segment_file;
              line^ := proc_line^;
              NEXT next_byte IN segment_file;
              next_byte^ := unit_separator;
              file_size := file_size + 1;
            IFEND;
          UNTIL proc_line = NIL;
          RESET segment_file;
          NEXT file_data: [[REP file_size OF cell]] IN segment_file;
        ELSE
          fsp$close_file (file_id, local_status);
          amp$return (name, local_status);
        IFEND;
      IFEND;
      pmp$close_object_library (proc_file_id, local_status);
      amp$return (local_file_name, local_status);
    IFEND;
  PROCEND open_scl_procedure;

?? TITLE := 'open_validation_procedure', EJECT ??

  PROCEDURE open_validation_procedure
    (    path: pft$path;
         user: ost$name;
     VAR file_data: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      attachment_selections: [STATIC, READ] array [1 .. 1] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$read]],
            [fsc$specific_share_modes, [fsc$read]]]],
      bottom: ost$non_negative_integers,
      database_file_id: ^string (vnc$database_file_id_size),
      database_index: ost$non_negative_integers,
      file_id: amt$file_identifier,
      file_pointer: amt$segment_pointer,
      highest_cycle: [STATIC, READ] pft$cycle_selector := [pfc$highest_cycle],
      local_status: ost$status,
      name: ost$name,
      number_of_users_in_system_nvdb: ^ost$non_negative_integers,
      password: [STATIC, READ] pft$password := ' ',
      password_size: 0 .. 0ffffffff(16),
      segment_file: ^SEQ ( * ),
      separator: ^char,
      share_selections: [STATIC, READ] pft$share_selections := [pfc$read],
      system_nvdb: ^vnt$user_database,
      temp: integer,
      top: ost$non_negative_integers,
      usage_selections: [STATIC, READ] pft$usage_selections := [pfc$read],
      user_found: boolean,
      user_password: ^string (vnc$encrypted_password_size),
      version_number: ^string (current_version_size);


    status.normal := TRUE;
    file_data := NIL;
    user_found := FALSE;

    pmp$get_unique_name (name, status);
    pfp$attach (name, path, highest_cycle, password, usage_selections, share_selections, pfc$no_wait, status);
    IF status.normal THEN
      fsp$open_file (name, amc$segment, ^attachment_selections, {default_creation_attributes =} NIL,
            {mandated_creation_attributes =} NIL, {attribute_validation =} NIL, {attribute_override =} NIL,
            file_id, status);
      IF status.normal THEN
        amp$get_segment_pointer (file_id, amc$sequence_pointer, file_pointer, status);
        IF status.normal THEN
          segment_file := file_pointer.sequence_pointer;
          RESET segment_file;
          NEXT database_file_id IN segment_file;
          IF (database_file_id <> NIL) AND (database_file_id^ = vnc$database_file_id) THEN
            NEXT number_of_users_in_system_nvdb IN segment_file;
            IF (number_of_users_in_system_nvdb <> NIL) AND (number_of_users_in_system_nvdb^ > 0) THEN
              NEXT system_nvdb: [1 .. number_of_users_in_system_nvdb^] IN segment_file;
              IF system_nvdb <> NIL THEN

  { Do a binary search on the database for the requested user.

                bottom := 1;
                top := number_of_users_in_system_nvdb^;

                REPEAT
                  temp := bottom + top;
                  database_index := temp DIV 2;
                  IF user < system_nvdb^ [database_index].username THEN
                    top := database_index - 1;
                  ELSEIF user > system_nvdb^ [database_index].username THEN
                    bottom := database_index + 1;
                  ELSE
                    user_found := TRUE;
                  IFEND;
                UNTIL (user_found) OR (bottom > top);

              IFEND;
            IFEND;
            IF user_found THEN
              ALLOCATE file_data: [[REP current_version_size + vnc$encrypted_password_size + 1 OF cell]];
              IF file_data <> NIL THEN
                RESET file_data;
                NEXT version_number IN file_data;
                version_number^ := current_version;
                NEXT user_password IN file_data;
                user_password^ := system_nvdb^ [database_index].password;
                NEXT separator IN file_data;
                separator^ := unit_separator;
                RESET file_data;
              IFEND;
            ELSE
              osp$set_status_condition (nae$invalid_user_name, status);
            IFEND;
          ELSE
            osp$set_status_condition (nae$invalid_net_val_database, status);
            osp$append_status_file (osc$status_parameter_delimiter, name, status);
          IFEND;
          fsp$close_file (file_id, local_status);
        IFEND;
      IFEND;
      amp$return (name, local_status);
    IFEND;
  PROCEND open_validation_procedure;

?? TITLE := 'perform_write [INLINE] ', EJECT ??

  PROCEDURE [INLINE] perform_write
    (VAR write_data: ^SEQ ( * );
     VAR file_data: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      write_block: ^SEQ ( * );

    status.normal := TRUE;
    NEXT write_block: [[REP #SIZE (write_data^) OF cell]] IN file_data;
    IF write_block = NIL THEN
      osp$set_status_condition (nae$write_beyond_file_limit, status);
    ELSE
      write_block^ := write_data^;
    IFEND;
  PROCEND perform_write;
?? TITLE := 'process_parameters', EJECT ??

  PROCEDURE process_parameters
    (    parameter_list: clt$parameter_list;
     VAR title_list: title_array;
     VAR max_connections: 1 .. nac$max_connections;
     VAR max_dumps: 0 .. nac$max_dumps;
     VAR max_dump_size: 0 .. amc$file_byte_limit;
     VAR status: ost$status);

{ PDT file_access_me_pdt (
{    file_type, ft: list of key exception, boot, domain_name_server, ..
{         dump, library, configuration, load_procedure, ..
{         terminal_procedure, user_procedure, validation, all = all
{    maximum_connections, mc: integer 1..nac$max_connections = 1000
{    maximum_dumps, md: integer 0..nac$max_dumps = 10
{    maximum_dump_size, mds: integer 0..amc$file_byte_limit = 16000000
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    file_access_me_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^file_access_me_pdt_names,
  ^file_access_me_pdt_params];

  VAR
    file_access_me_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 9] of
  clt$parameter_name_descriptor := [['FILE_TYPE', 1], ['FT', 1], ['MAXIMUM_CONNECTIONS', 2], ['MC', 2], [
  'MAXIMUM_DUMPS', 3], ['MD', 3], ['MAXIMUM_DUMP_SIZE', 4], ['MDS', 4], ['STATUS', 5]];

  VAR
    file_access_me_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of clt$parameter_descriptor
  := [

{ FILE_TYPE FT }
    [[clc$optional_with_default, ^file_access_me_pdt_dv1], 1, clc$max_value_sets,1, 1,
  clc$value_range_not_allowed, [^file_access_me_pdt_kv1, clc$keyword_value]],

{ MAXIMUM_CONNECTIONS MC }
    [[clc$optional_with_default, ^file_access_me_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, 1, nac$max_connections]],

{ MAXIMUM_DUMPS MD }
    [[clc$optional_with_default, ^file_access_me_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, 0, nac$max_dumps]],

{ MAXIMUM_DUMP_SIZE MDS }
    [[clc$optional_with_default, ^file_access_me_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, 0, amc$file_byte_limit]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    file_access_me_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 11] of ost$name := [
  'EXCEPTION','BOOT','DOMAIN_NAME_SERVER','DUMP','LIBRARY','CONFIGURATION','LOAD_PROCEDURE',
  'TERMINAL_PROCEDURE','USER_PROCEDURE','VALIDATION','ALL'];

  VAR
    file_access_me_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

  VAR
    file_access_me_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := '1000';

  VAR
    file_access_me_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := '10';

  VAR
    file_access_me_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (8) := '16000000';

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      i: network_file_type,
      number_of_file_types: 0 .. clc$max_value_sets,
      set_entry: 0 .. clc$max_value_sets,
      value: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, file_access_me_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('FILE_TYPE', number_of_file_types, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR set_entry := 1 TO number_of_file_types DO
      clp$get_value ('FILE_TYPE', set_entry, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE value.name.value (1) OF
      = 'E' =
        title_list [exception].register := TRUE;
      = 'B' =
        title_list [boot].register := TRUE;
      = 'D' =
        IF value.name.value = 'DUMP' THEN
          title_list [dump].register := TRUE;
        ELSEIF value.name.value = 'DOMAIN_NAME_SERVER' THEN
          title_list [domain_name_server].register := TRUE;
        IFEND;
      = 'L' =
        IF value.name.value = 'LIBRARY' THEN
          title_list [entry_point].register := TRUE;
        ELSEIF value.name.value = 'LOAD_PROCEDURE' THEN
          title_list [load_procedure].register := TRUE;
        IFEND;
      = 'C' =
        title_list [configuration].register := TRUE;
      = 'T' =
        title_list [terminal_procedure].register := TRUE;
      = 'U' =
        title_list [user_procedure].register := TRUE;
      = 'V' =
        title_list [validation].register := TRUE;
      = 'A' =
        FOR i := LOWERBOUND (title_list) TO UPPERBOUND (title_list) DO
          title_list [i].register := TRUE;
        FOREND;

{ Since 'object_module' and 'entry_point' file types map into        the same
{title ($LIBRARY), only register the title once.

        title_list [object_module].register := FALSE;
      ELSE
      CASEND;
    FOREND;

    clp$get_value ('MAXIMUM_CONNECTIONS', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    max_connections := value.int.value;

    clp$get_value ('MAXIMUM_DUMPS', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    max_dumps := value.int.value;

    clp$get_value ('MAXIMUM_DUMP_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    max_dump_size := value.int.value;

  PROCEND process_parameters;

?? TITLE := 'update_wait_list', EJECT ??

  PROCEDURE [INLINE] update_wait_list
    (    connection_id: nat$gt_connection_id);

    VAR
      i: 1 .. nac$max_connections;

    FOR i := 1 TO UPPERBOUND (wait_list^) DO
      IF wait_list^ [i].activity = nac$gt_null_activity THEN
        wait_list^ [i].activity := nac$gt_await_receive_event;
        wait_list^ [i].receive_connection_id := connection_id;
        RETURN;
      IFEND;
    FOREND;

    RESET wait_list_seq;
    NEXT wait_list: [1 .. UPPERBOUND (wait_list^) + 1] IN wait_list_seq;
    wait_list^ [UPPERBOUND (wait_list^)].activity := nac$gt_await_receive_event;
    wait_list^ [UPPERBOUND (wait_list^)].receive_connection_id := connection_id;

  PROCEND update_wait_list;

MODEND nam$file_access_me;
*DECK DECK=NAM$FILE_CYCLE_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Network Management : File Cycle Manager' ??

MODULE nam$file_cycle_manager;

{ PURPOSE:
{   This deck contains procedures which access and manipulate
{   information related to cycles.
{ DESIGN:
{   DOWN_TIME - Initialized to zero when the network file is created.
{                   Set (if a valid_start_down_time) to the difference
{                   between current time and start_down_time plus the
{                   old down_time value when a valid connection_identifier
{                   is stored in the file i.e. when valid_start_down_time
{                   is set to FALSE down_time should be set.
{   START_TIME - Initialized to the current time when the network file
{                   is created or a new connected connection_identifier
{                   is stored in the file.  Start_time is reset to the
{                   current time or start_down_time in fmp$get_connect_
{                   time_interval.  Start_time is set to current time if
{                   the connection is established.  It is set to start_
{                   down_time if the connection is disconnected.
{   START_DOWN_TIME - Set to the current time when the connection is
{                   disconnected.  Start_down_time is valid only if
{                   valid_start_down_time is TRUE.
{   VALID_START_DOWN_TIME - Set to TRUE when the connection is disconnected.
{                   Valid_start_down_time is set to FALSE when a connected
{                   connection_identifier is stored in the file.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$device_class_validation
*copyc ame$lfn_program_actions
*copyc nac$null_connection_id
*copyc nae$application_interfaces
*copyc nae$internal_interactive_appl
*copyc nae$namve_conditions
*copyc osd$integer_limits
*copyc ost$status
*copyc rme$request_command_exceptions
?? POP ??
*copyc bap$set_evaluated_file_abnormal
*copyc fmp$evaluate_path
*copyc fmp$get_cycle_description
*copyc fmp$unlock_path_table
*copyc nap$get_connection_state
*copyc nlp$connect_unsimulated_broken
*copyc nlp$connection_simulated_broken
*copyc nlp$nominal_conn_registration
*copyc nlp$nominal_disconnect_record
*copyc nlp$open_file
*copyc nlp$switch_offer_set
*copyc osp$append_status_parameter
*copyc osp$fetch_locked_variable
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition

*copyc amv$device_class_names
*copyc jmv$connection_acquired
*copyc osv$task_shared_heap

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$clear_switch_offer', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$clear_switch_offer
    (    file: fst$file_reference;
         switch_complete: boolean;
     VAR status: ost$status);

    VAR
      connection_state: nat$connection_state,
      current_time: integer,
      cycle_description: ^fmt$cycle_description;


    status.normal := TRUE;

    fmp$get_cycle_description (file, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_description^.attached_file THEN
      IF cycle_description^.device_class = rmc$network_device THEN
        IF cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
              file_state = nac$switch_offered THEN
          IF switch_complete THEN
            cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.file_state := nac$switch_completed;
          ELSE
            cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.file_state := nac$normal;
            cycle_description^.global_file_information^.device_dependent_info.network_connection_id :=
                  cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.backup_connection_id;
            IF NOT cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.disconnect_indication THEN
              nap$get_connection_state (cycle_description^.global_file_information^.device_dependent_info.
                    network_connection_id, connection_state, status);
              IF status.normal THEN
                IF connection_state <> nac$terminated THEN
                  current_time := #FREE_RUNNING_CLOCK (0);
                  cycle_description^.global_file_information^.device_dependent_info.
                        network_global_file_information^.connect.down_time :=
                        cycle_description^.global_file_information^.device_dependent_info.
                        network_global_file_information^.connect.down_time +
                        (current_time - cycle_description^.global_file_information^.device_dependent_info.
                        network_global_file_information^.connect.start_down_time);
                  cycle_description^.global_file_information^.device_dependent_info.
                        network_global_file_information^.connect.valid_start_down_time := FALSE;
                ELSE { IF connection_state = nac$terminated THEN
                  cycle_description^.global_file_information^.device_dependent_info.
                        network_global_file_information^.disconnect_indication := TRUE;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$nominal_conn_switch_offer THEN
          IF switch_complete THEN
            cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.file_state := nac$terminated_nominal_connect;
          ELSE
            cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.file_state := nac$simulated_connection_broken;
          IFEND;
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switched THEN
          cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
                file_state := nac$system_recovery;
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switchd_nom THEN
          cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
                file_state := nac$system_recovery;
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$normal THEN
          osp$set_status_condition (nae$no_switch_offer_pending, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$nominal_normal THEN
          osp$set_status_condition (nae$nominal_connection, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$switch_completed THEN
          osp$set_status_condition (nae$switch_offer_accepted, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$simulated_connection_broken THEN
          osp$set_status_condition (nae$simulated_connect_broken, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$terminated_nominal_connect THEN
          osp$set_status_condition (nae$switch_offer_accepted, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$connection_terminated THEN
          osp$set_status_condition (nae$connection_terminated, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery THEN
          osp$set_status_condition (nae$system_interrupt, status);
        IFEND;
      ELSE
        osp$set_status_condition (ame$improper_device_class, status);
      IFEND;
    ELSE
      osp$set_status_condition (ame$improper_device_class, status);
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$clear_switch_offer;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$convert_status', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$convert_status
    (    file: fst$file_reference;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      internal_status: ost$status;

    IF (NOT status.normal) AND (status.condition = nae$connection_terminated) THEN
      fmp$get_cycle_description (file, cycle_description, internal_status);
      IF NOT internal_status.normal THEN
        RETURN;
      IFEND;

      IF cycle_description^.attached_file THEN
        IF cycle_description^.device_class = rmc$network_device THEN
          IF cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.file_state = nac$nominal_normal THEN
            osp$set_status_condition (nae$interactive_cond_interrupt, status);
          ELSEIF cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.file_state = nac$simulated_connection_broken THEN
            osp$set_status_condition (nae$interactive_cond_interrupt, status);
          ELSEIF cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.file_state = nac$nominal_conn_switch_offer THEN
            osp$set_status_condition (nae$interactive_cond_interrupt, status);
          ELSEIF cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.file_state = nac$terminated_nominal_connect THEN
            osp$set_status_condition (nae$interactive_cond_interrupt, status);
          ELSEIF (cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.file_state = nac$system_recovery) OR
                (cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.file_state = nac$system_recovery_switched) OR
                (cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.file_state = nac$system_recovery_switchd_nom) THEN
            osp$set_status_condition (nae$system_interrupt, status);
          IFEND;
        IFEND;
      IFEND;
      fmp$unlock_path_table;

    IFEND;

  PROCEND fmp$convert_status;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$create_network_file', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$create_network_file
    (    file: fst$file_reference;
         connection_id: nat$connection_id;
         connection_state: nat$connection_state;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      evaluated_file_reference: fst$evaluated_file_reference,
      network_global_file_information: ^nat$global_file_information;

    cycle_description := NIL;
    status.normal := TRUE;

    fmp$evaluate_path (file, $bat$process_pt_work_list [bac$resolve_path, bac$resolve_to_catalog,
          bac$return_cycle_description, bac$record_path, bac$create_cycle_description],
          evaluated_file_reference, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /path_table_locked/
    BEGIN
      IF ((cycle_description^.static_setfa_entries <> NIL) OR
            (cycle_description^.dynamic_setfa_entries <> NIL)) THEN
        bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_known, 'FMP$CREATE_NETWORK_FILE',
              '', status);
        EXIT /path_table_locked/;
      IFEND;

      ; {
      ; { initiallizes the cycle_description
      ; {


      verify_device_assignment (evaluated_file_reference, rmc$network_device, cycle_description, status);
      IF NOT status.normal THEN
        EXIT /path_table_locked/;
      IFEND;

      IF NOT cycle_description^.attached_file THEN
        cycle_description^.attached_file := TRUE;
        cycle_description^.system_file_label.file_previously_opened := FALSE;
        cycle_description^.system_file_label.static_label := NIL;

{ If you change the following two lines, check the procedure
{ iip$xt_create_network_file.  This procedure sets the application_info_source to
{ amc$local_file_information and application_info to osc$timesharing_terminal_file.
{ These values allow the system to detect the difference between a normal network file
{ and a network file created to support xterm.

        cycle_description^.system_file_label.descriptive_label.application_info_source :=
              amc$undefined_attribute;
        cycle_description^.system_file_label.descriptive_label.global_access_mode :=
              $pft$usage_selections [pfc$read, pfc$shorten, pfc$append, pfc$modify];
        cycle_description^.system_file_label.descriptive_label.global_access_mode_source :=
              amc$access_method_default;
        cycle_description^.system_file_label.descriptive_label.global_file_name_source :=
              amc$undefined_attribute;
        cycle_description^.system_file_label.descriptive_label.internal_cycle_name_source :=
              amc$undefined_attribute;
        cycle_description^.system_file_label.descriptive_label.global_share_mode := $pft$share_selections [];
        cycle_description^.system_file_label.descriptive_label.global_share_mode_source :=
              amc$access_method_default;
        cycle_description^.system_file_label.descriptive_label.permanent_file := FALSE;
        cycle_description^.device_class := rmc$network_device;
        cycle_description^.global_file_information^.device_dependent_info.device_class := rmc$network_device;
        ALLOCATE network_global_file_information IN osv$task_shared_heap^;
        network_global_file_information^.file_state := nac$normal;
        network_global_file_information^.connect.start_time  := #FREE_RUNNING_CLOCK (0);
        network_global_file_information^.connect.down_time := 0;
        IF connection_state <> nac$terminated THEN
          network_global_file_information^.connect.valid_start_down_time := FALSE;
          network_global_file_information^.disconnect_indication := FALSE;
        ELSE { IF connection_state = nac$terminated THEN
          network_global_file_information^.connect.start_down_time :=
                network_global_file_information^.connect.start_time;
          network_global_file_information^.connect.valid_start_down_time := TRUE;
          network_global_file_information^.disconnect_indication := TRUE;
        IFEND;
        cycle_description^.global_file_information^.device_dependent_info.network_global_file_information :=
              network_global_file_information;
        cycle_description^.global_file_information^.device_dependent_info.network_connection_id :=
              connection_id;
      ELSE
        osp$set_status_condition (ame$file_known, status);
      IFEND;

    END /path_table_locked/;

    fmp$unlock_path_table;

  PROCEND fmp$create_network_file;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$create_rhfam_file', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$create_rhfam_file
    (    file: fst$file_reference;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      evaluated_file_reference: fst$evaluated_file_reference;

    cycle_description := NIL;
    status.normal := TRUE;

    fmp$evaluate_path (file, $bat$process_pt_work_list [bac$resolve_path, bac$resolve_to_catalog,
          bac$return_cycle_description, bac$record_path, bac$create_cycle_description],
          evaluated_file_reference, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /path_table_locked/
    BEGIN
      verify_device_assignment (evaluated_file_reference, rmc$rhfam_device, cycle_description, status);
      IF NOT status.normal THEN
        EXIT /path_table_locked/;
      IFEND;

      IF NOT cycle_description^.attached_file THEN
        cycle_description^.attached_file := TRUE;
        cycle_description^.system_file_label.file_previously_opened := FALSE;
        cycle_description^.system_file_label.static_label := NIL;
        cycle_description^.system_file_label.descriptive_label.application_info_source :=
              amc$undefined_attribute;
        cycle_description^.system_file_label.descriptive_label.global_access_mode :=
              $pft$usage_selections [pfc$read, pfc$shorten, pfc$append, pfc$modify];
        cycle_description^.system_file_label.descriptive_label.global_access_mode_source :=
              amc$access_method_default;
        cycle_description^.system_file_label.descriptive_label.global_file_name_source :=
              amc$undefined_attribute;
        cycle_description^.system_file_label.descriptive_label.internal_cycle_name_source :=
              amc$undefined_attribute;
        cycle_description^.system_file_label.descriptive_label.global_share_mode := $pft$share_selections [];
        cycle_description^.system_file_label.descriptive_label.global_share_mode_source :=
              amc$access_method_default;
        cycle_description^.system_file_label.descriptive_label.permanent_file := FALSE;
        cycle_description^.device_class := rmc$rhfam_device;
      ELSE
        osp$set_status_condition (ame$file_known, status);
      IFEND;

    END /path_table_locked/;

    fmp$unlock_path_table;

  PROCEND fmp$create_rhfam_file;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$delete_network_file', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$delete_network_file
    (    file: fst$file_reference;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description;

    status.normal := TRUE;

    fmp$get_cycle_description (file, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_description^.attached_file THEN
      IF cycle_description^.device_class = rmc$network_device THEN
        osp$set_status_abnormal (amc$access_method_id, 20 {device_class_mismatch} , 'rmp$delete_network_file',
              status);
      IFEND;
    ELSE
      osp$set_status_condition (ame$improper_device_class, status);
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$delete_network_file;

?? TITLE := '[XDCL, #GATE] fmp$get_connect_time_interval', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$get_connect_time_interval
    (    file: fst$file_reference;
     VAR connect_time: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      connect_time_interval: integer,
      current_time: integer,
      cycle_description: ^fmt$cycle_description;

    status.normal := TRUE;

    fmp$get_cycle_description (file, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_description^.attached_file THEN
      IF cycle_description^.device_class = rmc$network_device THEN
        IF NOT cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.connect.valid_start_down_time THEN
          current_time := #FREE_RUNNING_CLOCK (0);

{ connect_time := current_time - (start_time + down_time)

          connect_time := current_time - (cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.connect.start_time +
                cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.connect.down_time);
          cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
                connect.start_time := current_time;
          cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
                connect.down_time := 0;
        ELSE { IF cd^.gfi^.ddi.ngfi^.connect.valid_start_down_time THEN

{ connect_time_interval := start_down_time - (start_time + down_time);

          connect_time_interval := cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.connect.start_down_time -
                (cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.connect.start_time +
                cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.connect.down_time);

{ Check for a zero connect time.  It is possible to get a negative connect time.
{ When the mainframe goes through a recovery deadstart, periodically the
{ microsecond clock is initialized to a value smaller than it was before the
{ mainframe was taken down.  The psr NV0R942 will address this problem.

          IF connect_time_interval > 0 THEN
            connect_time := connect_time_interval;
          ELSE
            connect_time := 0;
          IFEND;
          cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
                connect.start_time := cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.connect.start_down_time;
          cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
                connect.down_time := 0;
        IFEND;
      ELSE
        osp$set_status_abnormal (amc$access_method_id, ame$improper_device_class,
              'fmp$get_connect_time_interval', status);
      IFEND;
    ELSE
      osp$set_status_condition (ame$improper_device_class, status);
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$get_connect_time_interval;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$get_connection_identifier', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$get_connection_identifier
    (    file: fst$file_reference;
     VAR connection_id: nat$connection_id;
     VAR switch_offer_pending: boolean;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description;

    status.normal := TRUE;

    fmp$get_cycle_description (file, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_description^.attached_file THEN
      IF cycle_description^.device_class = rmc$network_device THEN
        IF (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$normal) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$nominal_normal) THEN
          connection_id := cycle_description^.global_file_information^.device_dependent_info.
                network_connection_id;
          switch_offer_pending := FALSE;
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$simulated_connection_broken THEN
          connection_id := cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.backup_connection_id;
          switch_offer_pending := FALSE;
        ELSEIF (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$switch_offered) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$nominal_conn_switch_offer) THEN
          connection_id := cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.backup_connection_id;
          switch_offer_pending := TRUE;
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$switch_completed THEN
          osp$set_status_condition (nae$switch_offer_accepted, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$terminated_nominal_connect THEN
          osp$set_status_condition (nae$switch_offer_accepted, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$connection_terminated THEN
          osp$set_status_condition (nae$connection_terminated, status);
        ELSEIF (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switched) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switchd_nom) THEN
          osp$set_status_condition (nae$system_interrupt, status);
        IFEND;
      ELSE
        osp$set_status_abnormal (amc$access_method_id, ame$improper_device_class,
              'fmp$get_connection_identifier', status);
      IFEND;
    ELSE
      osp$set_status_condition (ame$improper_device_class, status);
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$get_connection_identifier;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$open_network_file', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$open_network_file
    (    file: fst$file_reference;
         file_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      open_count: integer;

    status.normal := TRUE;

    fmp$get_cycle_description (file, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_description^.attached_file THEN
      IF cycle_description^.device_class = rmc$network_device THEN
        IF (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$normal) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$nominal_normal) OR
              NOT jmv$connection_acquired THEN
          nlp$open_file (cycle_description^.global_file_information^.device_dependent_info.
                network_connection_id, file_identifier, status);
        ELSEIF (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$simulated_connection_broken) THEN
          nlp$open_file (cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.backup_connection_id, file_identifier, status);
        ELSEIF (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$switch_offered) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$nominal_conn_switch_offer) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switched) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switchd_nom) THEN
          osp$set_status_condition (nae$switch_offer_pending, status);
        ELSE
          osp$set_status_condition (nae$connection_not_established, status);
        IFEND;
      ELSE
        osp$set_status_condition (ame$improper_device_class, status);
      IFEND;
    ELSE
      osp$set_status_condition (ame$improper_device_class, status);
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$open_network_file;

?? TITLE := '[XDCL, #GATE] fmp$process_disconnect', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$process_disconnect
    (    file: fst$file_reference;
         connection_id: nat$connection_id);

    VAR
      cycle_description: ^fmt$cycle_description,
      status: ost$status;

    fmp$get_cycle_description (file, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_description^.attached_file THEN
      IF cycle_description^.device_class = rmc$network_device THEN

{ Start the down time only if the connection_ids match.  Otherwise
{ a connection that has just received a new connection id could be
{ invalidated.

        IF connection_id = cycle_description^.global_file_information^.device_dependent_info.
              network_connection_id THEN
          IF NOT cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.connect.valid_start_down_time THEN
            cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.connect.start_down_time := #FREE_RUNNING_CLOCK (0);
            cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.connect.valid_start_down_time := TRUE;
          IFEND;
          cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
                disconnect_indication := TRUE;
        IFEND;
      IFEND;
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$process_disconnect;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$record_nominal_disconnect', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$record_nominal_disconnect
    (    file: fst$file_reference;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      open_count: integer;

    status.normal := TRUE;

    fmp$get_cycle_description (file, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_description^.attached_file THEN
      IF cycle_description^.device_class = rmc$network_device THEN
        IF cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
              file_state = nac$nominal_normal THEN
          nlp$nominal_disconnect_record (cycle_description^.global_file_information^.device_dependent_info.
                network_connection_id, status);
          IF status.normal THEN
            cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.file_state := nac$terminated_nominal_connect;
            cycle_description^.global_file_information^.device_dependent_info.network_connection_id :=
                  nac$null_connection_id;
            IF NOT cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.connect.valid_start_down_time THEN
              cycle_description^.global_file_information^.device_dependent_info.
                    network_global_file_information^.connect.start_down_time := #FREE_RUNNING_CLOCK (0);
              cycle_description^.global_file_information^.device_dependent_info.
                    network_global_file_information^.connect.valid_start_down_time := TRUE;
            IFEND;
          IFEND;
        ELSEIF (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery) THEN
          cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
                file_state := nac$terminated_nominal_connect;
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$normal THEN
          osp$set_status_condition (nae$not_nominal_connection, status);
        ELSEIF (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$switch_offered) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$nominal_conn_switch_offer) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switched) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switchd_nom) THEN
          osp$set_status_condition (nae$switch_offer_pending, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$switch_completed THEN
          osp$set_status_condition (nae$switch_offer_accepted, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$simulated_connection_broken THEN
          osp$set_status_condition (nae$simulated_connect_broken, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$terminated_nominal_connect THEN
          osp$set_status_condition (nae$connection_terminated, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$connection_terminated THEN
          osp$set_status_condition (nae$connection_terminated, status);
        IFEND;
      ELSE
        osp$set_status_condition (ame$improper_device_class, status);
      IFEND;
    ELSE
      osp$set_status_condition (ame$improper_device_class, status);
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$record_nominal_disconnect;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$disconnect_for_clone', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$disconnect_for_clone
    (    file: fst$file_reference;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      open_count: integer;

    status.normal := TRUE;

    fmp$get_cycle_description (file, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_description^.attached_file THEN
      IF cycle_description^.device_class = rmc$network_device THEN
        cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
              file_state := nac$terminated_nominal_connect;
        cycle_description^.global_file_information^.device_dependent_info.network_connection_id :=
              nac$null_connection_id;
        cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.connect.start_time := #FREE_RUNNING_CLOCK (0);
        cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
              connect.down_time := 0;
        cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
              connect.valid_start_down_time := TRUE;
        cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
              connect.start_down_time := cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.connect.start_time;
        cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
              disconnect_indication := FALSE;
      ELSE
        osp$set_status_condition (ame$improper_device_class, status);
      IFEND;
    ELSE
      osp$set_status_condition (ame$improper_device_class, status);
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$disconnect_for_clone;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$register_nominal_connection', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$register_nominal_connection
    (    file: fst$file_reference;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      open_count: integer;

    status.normal := TRUE;

    fmp$get_cycle_description (file, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_description^.attached_file THEN
      IF cycle_description^.device_class = rmc$network_device THEN
        IF cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
              file_state = nac$normal THEN
          nlp$nominal_conn_registration (cycle_description^.global_file_information^.device_dependent_info.
                network_connection_id, status);
          IF status.normal THEN
            cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.file_state := nac$nominal_normal;
          IFEND;
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery THEN
          cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
                file_state := nac$terminated_nominal_connect;
          cycle_description^.global_file_information^.device_dependent_info.network_connection_id :=
                nac$null_connection_id;
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$nominal_normal THEN
          osp$set_status_condition (nae$nominal_connection, status);
        ELSEIF (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$switch_offered) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$nominal_conn_switch_offer) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switched) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switchd_nom) THEN
          osp$set_status_condition (nae$switch_offer_pending, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$switch_completed THEN
          osp$set_status_condition (nae$switch_offer_accepted, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$simulated_connection_broken THEN
          osp$set_status_condition (nae$simulated_connect_broken, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$terminated_nominal_connect THEN
          osp$set_status_condition (nae$connection_terminated, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$connection_terminated THEN
          osp$set_status_condition (nae$connection_terminated, status);
        IFEND;
      ELSE
        osp$set_status_condition (ame$improper_device_class, status);
      IFEND;
    ELSE
      osp$set_status_condition (ame$improper_device_class, status);
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$register_nominal_connection;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$remove_connection_id', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$remove_connection_id
    (    file: fst$file_reference;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description;

    status.normal := TRUE;

    fmp$get_cycle_description (file, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_description^.attached_file THEN
      IF cycle_description^.device_class = rmc$network_device THEN
        IF cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
              file_state = nac$normal THEN
          cycle_description^.global_file_information^.device_dependent_info.network_connection_id :=
                nac$null_connection_id;
          cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
                file_state := nac$connection_terminated;
          IF NOT cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.connect.valid_start_down_time THEN
            cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.connect.start_down_time := #FREE_RUNNING_CLOCK (0);
            cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.connect.valid_start_down_time := TRUE;
          IFEND;
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$nominal_normal THEN
          osp$set_status_condition (nae$nominal_connection, status);
        ELSEIF (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$switch_offered) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$nominal_conn_switch_offer) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switched) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switchd_nom) THEN
          osp$set_status_condition (nae$switch_offer_pending, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$switch_completed THEN
          osp$set_status_condition (nae$switch_offer_accepted, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$simulated_connection_broken THEN
          osp$set_status_condition (nae$simulated_connect_broken, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$terminated_nominal_connect THEN
          osp$set_status_condition (nae$connection_terminated, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$connection_terminated THEN
          osp$set_status_condition (nae$connection_terminated, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery THEN
          osp$set_status_condition (nae$system_interrupt, status);
        IFEND;
      ELSE
        osp$set_status_condition (ame$improper_device_class, status);
      IFEND;
    ELSE
      osp$set_status_condition (ame$improper_device_class, status);
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$remove_connection_id;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$set_switch_offer', EJECT ??

{ NOTES:
{   If the current state is nac$system_recovery the file_state will be changed to
{   nac$system_recovery_switched or nac$system_recovery_switchd_nom depending on the
{   value of the parameter timesharing_connection_switch.  In addition, the error
{   nae$system_interrupt will be returned if the file state is nac$system_recovery.

  PROCEDURE [XDCL, #GATE] fmp$set_switch_offer
    (    file: fst$file_reference;
         timesharing_connection_switch: boolean;
     VAR application_name: nat$application_name;
     VAR connection_id: nat$connection_id;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      open_count: integer;

    status.normal := TRUE;

    fmp$get_cycle_description (file, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_description^.attached_file THEN
      IF cycle_description^.device_class = rmc$network_device THEN
        IF (NOT timesharing_connection_switch) AND (cycle_description^.global_file_information^.
              device_dependent_info.network_global_file_information^.file_state = nac$normal) THEN
          osp$fetch_locked_variable (cycle_description^.global_file_information^.open_count, open_count);
          IF open_count > 0 THEN
            osp$set_status_condition (ame$file_not_closed, status);
          ELSE
            nlp$switch_offer_set (cycle_description^.global_file_information^.device_dependent_info.
                  network_connection_id, application_name, status);
            IF status.normal THEN
              cycle_description^.global_file_information^.device_dependent_info.
                    network_global_file_information^.file_state := nac$switch_offered;
              cycle_description^.global_file_information^.device_dependent_info.
                    network_global_file_information^.backup_connection_id :=
                    cycle_description^.global_file_information^.device_dependent_info.network_connection_id;
              connection_id := cycle_description^.global_file_information^.device_dependent_info.
                    network_connection_id;
              cycle_description^.global_file_information^.device_dependent_info.network_connection_id :=
                    nac$null_connection_id;
              IF NOT cycle_description^.global_file_information^.device_dependent_info.
                    network_global_file_information^.connect.valid_start_down_time THEN
                cycle_description^.global_file_information^.device_dependent_info.
                      network_global_file_information^.connect.start_down_time := #FREE_RUNNING_CLOCK (0);
                cycle_description^.global_file_information^.device_dependent_info.
                      network_global_file_information^.connect.valid_start_down_time := TRUE;
              IFEND;
            IFEND;
          IFEND;
        ELSEIF (timesharing_connection_switch) AND (cycle_description^.global_file_information^.
              device_dependent_info.network_global_file_information^.file_state =
              nac$simulated_connection_broken) THEN
          nlp$switch_offer_set (cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.backup_connection_id, application_name, status);
          IF status.normal THEN
            connection_id := cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.backup_connection_id;
            cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.file_state := nac$nominal_conn_switch_offer;
          IFEND;
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$normal THEN
          osp$set_status_condition (nae$not_nominal_connection, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$nominal_normal THEN
          osp$set_status_condition (nae$nominal_connection, status);
        ELSEIF (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$switch_offered) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$nominal_conn_switch_offer) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switched) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switchd_nom) THEN
          osp$set_status_condition (nae$switch_offer_pending, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$switch_completed THEN
          osp$set_status_condition (nae$switch_offer_accepted, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$simulated_connection_broken THEN
          osp$set_status_condition (nae$simulated_connect_broken, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$terminated_nominal_connect THEN
          osp$set_status_condition (nae$connection_terminated, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$connection_terminated THEN
          osp$set_status_condition (nae$connection_terminated, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery THEN
          osp$set_status_condition (nae$system_interrupt, status);
          IF NOT timesharing_connection_switch THEN
            osp$fetch_locked_variable (cycle_description^.global_file_information^.open_count, open_count);
            IF open_count > 0 THEN
              osp$set_status_condition (ame$file_not_closed, status);
            ELSE
              cycle_description^.global_file_information^.device_dependent_info.
                    network_global_file_information^.file_state := nac$system_recovery_switched;
            IFEND;
          ELSE
            cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.file_state := nac$system_recovery_switchd_nom;
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (ame$improper_device_class, status);
      IFEND;
    ELSE
      osp$set_status_condition (ame$improper_device_class, status);
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$set_switch_offer;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$simulate_connection_broken', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$simulate_connection_broken
    (    file: fst$file_reference;
     VAR status: ost$status);

    VAR
      cycle_description: ^fmt$cycle_description,
      open_count: integer;

    status.normal := TRUE;

    fmp$get_cycle_description (file, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_description^.attached_file THEN
      IF cycle_description^.device_class = rmc$network_device THEN
        IF cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
              file_state = nac$nominal_normal THEN
          nlp$connection_simulated_broken (cycle_description^.global_file_information^.device_dependent_info.
                network_connection_id, status);
          IF status.normal THEN
            cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.file_state := nac$simulated_connection_broken;
            cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.backup_connection_id :=
                  cycle_description^.global_file_information^.device_dependent_info.network_connection_id;
            cycle_description^.global_file_information^.device_dependent_info.network_connection_id :=
                  nac$null_connection_id;
            IF NOT cycle_description^.global_file_information^.device_dependent_info.
                  network_global_file_information^.connect.valid_start_down_time THEN
              cycle_description^.global_file_information^.device_dependent_info.
                    network_global_file_information^.connect.start_down_time := #FREE_RUNNING_CLOCK (0);
              cycle_description^.global_file_information^.device_dependent_info.
                    network_global_file_information^.connect.valid_start_down_time := TRUE;
            IFEND;
          IFEND;
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$normal THEN
          osp$set_status_condition (nae$not_nominal_connection, status);
        ELSEIF (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$switch_offered) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$nominal_conn_switch_offer) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switched) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switchd_nom) THEN
          osp$set_status_condition (nae$switch_offer_pending, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$switch_completed THEN
          osp$set_status_condition (nae$switch_offer_accepted, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$simulated_connection_broken THEN
          osp$set_status_condition (nae$simulated_connect_broken, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$terminated_nominal_connect THEN
          osp$set_status_condition (nae$connection_terminated, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$connection_terminated THEN
          osp$set_status_condition (nae$connection_terminated, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery THEN
          osp$set_status_condition (nae$system_interrupt, status);
        IFEND;
      ELSE
        osp$set_status_condition (ame$improper_device_class, status);
      IFEND;
    ELSE
      osp$set_status_condition (ame$improper_device_class, status);
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$simulate_connection_broken;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$store_connection_id', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$store_connection_id
    (    file: fst$file_reference;
         connection_id: nat$connection_id;
     VAR status: ost$status);

    VAR
      connection_state: nat$connection_state,
      current_time: integer,
      cycle_description: ^fmt$cycle_description;

    status.normal := TRUE;

    fmp$get_cycle_description (file, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_description^.attached_file THEN
      IF cycle_description^.device_class = rmc$network_device THEN
        IF cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
              file_state = nac$terminated_nominal_connect THEN
          cycle_description^.global_file_information^.device_dependent_info.network_connection_id :=
                connection_id;
          cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
                file_state := nac$normal;
          nap$get_connection_state (connection_id, connection_state, status);
          IF status.normal THEN
            IF connection_state <> nac$terminated THEN
              current_time := #FREE_RUNNING_CLOCK (0);
              cycle_description^.global_file_information^.device_dependent_info.
                    network_global_file_information^.connect.down_time :=
                    cycle_description^.global_file_information^.device_dependent_info.
                    network_global_file_information^.connect.down_time +
                    (current_time - cycle_description^.global_file_information^.device_dependent_info.
                    network_global_file_information^.connect.start_down_time);
              cycle_description^.global_file_information^.device_dependent_info.
                    network_global_file_information^.connect.valid_start_down_time := FALSE;
              cycle_description^.global_file_information^.device_dependent_info.
                    network_global_file_information^.disconnect_indication := FALSE;
            ELSE { IF connection_state = nac$terminated THEN
              cycle_description^.global_file_information^.device_dependent_info.
                    network_global_file_information^.disconnect_indication := TRUE;
            IFEND;
          IFEND;
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$normal THEN
          osp$set_status_condition (nae$connection_active, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$nominal_normal THEN
          osp$set_status_condition (nae$nominal_connection, status);
        ELSEIF (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$switch_offered) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$nominal_conn_switch_offer) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switched) OR
              (cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery_switchd_nom) THEN
          osp$set_status_abnormal (nac$status_id, nae$switch_offer_pending, 'nac$switch_offered', status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$switch_completed THEN
          osp$set_status_abnormal (nac$status_id, nae$switch_offer_accepted, 'nac$switch_completed', status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$simulated_connection_broken THEN
          osp$set_status_condition (nae$simulated_connect_broken, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$connection_terminated THEN
          osp$set_status_condition (nae$connection_terminated, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery THEN
          osp$set_status_abnormal (nac$status_id, nae$system_interrupt, 'nac$system_recovery', status);
        IFEND;
      ELSE
        osp$set_status_condition (ame$improper_device_class, status);
      IFEND;
    ELSE
      osp$set_status_condition (ame$improper_device_class, status);
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$store_connection_id;

?? TITLE := 'PROCEDURE [XDCL, #GATE] fmp$unsimulate_connection_broke', EJECT ??

  PROCEDURE [XDCL, #GATE] fmp$unsimulate_connection_broke
    (    file: fst$file_reference;
     VAR status: ost$status);

    VAR
      connection_state: nat$connection_state,
      current_time: integer,
      cycle_description: ^fmt$cycle_description,
      open_count: integer;

    status.normal := TRUE;

    fmp$get_cycle_description (file, cycle_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_description^.attached_file THEN
      IF cycle_description^.device_class = rmc$network_device THEN
        IF cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
              file_state = nac$simulated_connection_broken THEN
          nlp$connect_unsimulated_broken (cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.backup_connection_id, status);
          cycle_description^.global_file_information^.device_dependent_info.network_global_file_information^.
                file_state := nac$normal;
          cycle_description^.global_file_information^.device_dependent_info.network_connection_id :=
                cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.backup_connection_id;
          IF NOT cycle_description^.global_file_information^.device_dependent_info.
                network_global_file_information^.disconnect_indication THEN
            nap$get_connection_state (cycle_description^.global_file_information^.device_dependent_info.
                  network_connection_id, connection_state, status);
            IF status.normal THEN
              IF connection_state <> nac$terminated THEN
                current_time := #FREE_RUNNING_CLOCK (0);
                cycle_description^.global_file_information^.device_dependent_info.
                      network_global_file_information^.connect.down_time :=
                      cycle_description^.global_file_information^.device_dependent_info.
                      network_global_file_information^.connect.down_time +
                      (current_time - cycle_description^.global_file_information^.device_dependent_info.
                      network_global_file_information^.connect.start_down_time);
                cycle_description^.global_file_information^.device_dependent_info.
                      network_global_file_information^.connect.valid_start_down_time := FALSE;
              ELSE { IF connection_state = nac$terminated THEN
                cycle_description^.global_file_information^.device_dependent_info.
                      network_global_file_information^.disconnect_indication := TRUE;
              IFEND;
            IFEND;
          IFEND;
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$terminated_nominal_connect THEN
          osp$set_status_condition (nae$connection_terminated, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$connection_terminated THEN
          osp$set_status_condition (nae$connection_terminated, status);
        ELSEIF cycle_description^.global_file_information^.device_dependent_info.
              network_global_file_information^.file_state = nac$system_recovery THEN
          osp$set_status_condition (nae$system_interrupt, status);
        ELSE
          osp$set_status_condition (nae$not_simulated_conn_broken, status);
        IFEND;
      ELSE
        osp$set_status_condition (ame$improper_device_class, status);
      IFEND;
    ELSE
      osp$set_status_condition (ame$improper_device_class, status);
    IFEND;

    fmp$unlock_path_table;

  PROCEND fmp$unsimulate_connection_broke;

?? TITLE := 'PROCEDURE [INLINE] verify_device_assignment', EJECT ??

  PROCEDURE [INLINE] verify_device_assignment
    (    evaluated_file_reference: fst$evaluated_file_reference;
         required_device_class: rmt$device_class;
         cycle_description: ^fmt$cycle_description;
     VAR status: ost$status);

    status.normal := TRUE;

    IF cycle_description^.attached_file THEN
      IF cycle_description^.device_class <> required_device_class THEN
        bap$set_evaluated_file_abnormal (evaluated_file_reference, rme$device_assignment_conflict,
              'NAM$FILE_CYCLE_MANAGER', amv$device_class_names [cycle_description^.device_class].
              name (1, amv$device_class_names [cycle_description^.device_class].size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              amv$device_class_names [required_device_class].name
              (1, amv$device_class_names [required_device_class].size), status);
      ELSE
        bap$set_evaluated_file_abnormal (evaluated_file_reference, rme$redundant_device_assignment,
              'NAM$FILE_CYCLE_MANAGER', amv$device_class_names [cycle_description^.device_class].
              name (1, amv$device_class_names [cycle_description^.device_class].size), status);
      IFEND;
    ELSE
      RETURN;
    IFEND;

  PROCEND verify_device_assignment;

?? OLDTITLE ??

MODEND nam$file_cycle_manager;

*DECK DECK=NAM$GENERATE_NETWORK_MESSAGE EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? TITLE := 'NOS/VE: CDCNET Message generator' ??
?? NEWTITLE := 'Global Declarations' ??
MODULE nam$generate_network_message;
?? PUSH (LISTEXT:=ON) ??
*copyc nae$network_operator_utility
*copyc nac$network_management_catalog
*copyc nat$command_interface
*copyc nat$management_data_unit_syntax
*copyc ost$status
*copyc osc$max_status_message_line
*copyc ost$status_condition_code
*copyc ost$status_message
*copyc ost$status_message_line
*copyc ost$status_message_line_count
*copyc ost$status_message_line_size
?? POP ??
*copyc clp$convert_integer_to_string
*copyc clp$put_display
*copyc osp$establish_condition_handler
*copyc osp$format_multi_part_message
*copyc osp$set_status_abnormal
*copyc pmp$continue_to_cause

  TYPE
    template_identifier = 0 .. 65535;

  CONST
    nac$di_status_id = 'DC',
    nac$di_condition_bias = (($INTEGER ('D') * 100(16)) + $INTEGER ('C')) * 1000000(16),
    nac$di_message_module_name = 'DCM$TEMPLATES',
    nac$default_di_template_number = 0;

  TYPE
    message_parameter = ^ost$message_parameter;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$generate_network_message', EJECT ??

  PROCEDURE [XDCL] nap$generate_network_message (network_message: SEQ ( * );
    VAR display_control: clt$display_control;
    VAR status: ost$status);

{ PURPOSE: This procedure uses the CDCNET templates to format and display a network command
{          response or alarm message.
{ DESIGN:  The message template library must be accessible to the system message generator.
{          It may be in a library specified on the relevant program description or in a
{          library in the command list.
{          The data received from the DI is broken down and converted into a list of
{          parameter strings that are given to the SCL message formatter with the first
{          format request. The message formatter calls the get_message_part procedure
{          to obtain subsequent message conditions and parameter lists until the DI message
{          is exhausted.

    VAR
      condition_code: ost$status_condition_code,
      end_of_message: boolean,
      ignore_status: ost$status,
      line_count: ^ost$status_message_line_count,
      line_index: ost$status_message_line_count,
      message: [STATIC] ^SEQ (REP 5 * nac$max_command_response_length OF cell) := NIL,
      max_parameter_count: integer,
      message_data: ^SEQ ( * ),
      message_parameter_seq: ^SEQ ( * ),
      message_parameter_strings: ^SEQ ( * ),
      message_parameters: ^ost$message_parameters,
      page_width: ost$status_message_line_size,
      template_id: ^template_identifier,
      text_length: ^ost$status_message_line_size,
      text_line: ^ost$status_message_line;

?? NEWTITLE := '  condition_handler', EJECT ??

    PROCEDURE condition_handler (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

      pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN
          EXIT nap$generate_network_message;
      IFEND;

    PROCEND condition_handler;

?? OLDTITLE ??
?? NEWTITLE:='get_message_part', EJECT ??

  PROCEDURE get_message_part (VAR condition_code: ost$status_condition_code;
    VAR message_parameters: ^ost$message_parameters;
    VAR end_of_message: boolean;
    VAR status: ost$status);

    VAR
      bit_set: ^packed array [1 .. *] of boolean,
      byte: ^0 .. 255,
      count: 0 .. 256,
      end_of_template: boolean,
      fill_bit_eliminator: [STATIC, READ] array [0 .. 7] of integer := [1, 128, 64, 32, 16, 8, 4, 2],
      header: ^nat$mdu_header,
      hex_array: ^packed array [1 .. *] of 0 .. 15,
      hex_table: [STATIC, READ] array [0 .. 15] of char := ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
            'A', 'B', 'C', 'D', 'E', 'F'],
      index: integer,
      integer_string: ost$string,
      integer_value: integer,
      negative_bias: integer,
      negative_number: boolean,
      parameter_count: integer,
      working_parameters: ^ost$message_parameters;

    status.normal := TRUE;
    parameter_count := 0;
    end_of_message := FALSE;
    end_of_template := FALSE;
    RESET message_parameter_strings;
    RESET message_parameter_seq;
    NEXT working_parameters: [1 .. max_parameter_count] IN message_parameter_seq;

    NEXT header IN message_data;
    IF header = NIL THEN
      end_of_message := TRUE;
      RETURN {no data to process};
    IFEND;
    IF header^.command THEN
      NEXT template_id IN message_data;
      IF template_id <> NIL THEN
        condition_code := template_id^ + nac$di_condition_bias;
      ELSE {no template_id specified for display}
        condition_code := nac$default_di_template_number;
      IFEND;
      NEXT header IN message_data;
    ELSE
      condition_code := nac$default_di_template_number;
    IFEND;

  /process_optional_data/
    WHILE (NOT end_of_template) AND (header <> NIL) AND (NOT header^.command) DO
      parameter_count := parameter_count + 1;

      CASE header^.kind OF
      = nac$mdu_binary_string =
{ Binary string is displayed as a series of binary digits (0 and 1).
        count := header^.length + 1;
        NEXT bit_set: [1 .. count] IN message_data;
        IF bit_set <> NIL THEN
          NEXT working_parameters^ [parameter_count]: [count] IN message_parameter_strings;
          FOR index := 1 to count DO
            IF bit_set^ [index] THEN
              working_parameters^ [parameter_count]^ (index) := '1';
            ELSE
              working_parameters^ [parameter_count]^ (index) := '0';
            IFEND;
          FOREND;
        ELSE
          end_of_template := TRUE;
        IFEND;

      = nac$mdu_binary_octet =
{ Binary octet is displayed as a series of hexadecimal digits, two digits per octet. }
        count := (header^.length + 1) * 2;
        NEXT hex_array: [1 .. count] IN message_data;
        IF hex_array <> NIL THEN
          NEXT working_parameters^ [parameter_count]: [count] IN message_parameter_strings;
          FOR index := 1 to count DO
            working_parameters^ [parameter_count]^ (index) := hex_table [hex_array^ [index]];
          FOREND;
        ELSE
          end_of_template := TRUE;
        IFEND;

      = nac$mdu_unsigned_integer =
{ Integer is displayed as a series of decimal digits. Fill bits may need to be removed.}
        count := (header^.length + 1 + 7) DIV 8;
        integer_value := 0;
        FOR index := 1 TO count DO
          NEXT byte IN message_data;
          IF byte <> NIL THEN
            integer_value := (integer_value * 256) + byte^;
          IFEND;
        FOREND;
        IF byte <> NIL THEN
          integer_value := integer_value DIV fill_bit_eliminator [(header^.length + 1) MOD 8];
          clp$convert_integer_to_string (integer_value, {base} 10, {include radix} FALSE, integer_string,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          NEXT working_parameters^ [parameter_count]: [integer_string.size] IN message_parameter_strings;
          working_parameters^ [parameter_count]^ := integer_string.value;
        ELSE
          end_of_template := TRUE;
        IFEND;

      = nac$mdu_signed_integer =
{ Integer is displayed as a series of decimal digits. Fill bits may need to be removed.}
        count := (header^.length + 1 + 7) DIV 8;
        integer_value := 0;
        NEXT byte IN message_data;
        IF byte <> NIL THEN
          negative_number := byte^ >= 128;
          negative_bias := 128;
          IF negative_number THEN
            integer_value := byte^ - 128;
          ELSE {positive number}
            integer_value := byte^;
          IFEND;
          FOR index := 2 TO count DO
            NEXT byte IN message_data;
            IF byte <> NIL THEN
              integer_value := (integer_value * 256) + byte^;
              negative_bias := negative_bias * 256;
            IFEND;
          FOREND;
          IF negative_number THEN
            integer_value := integer_value - negative_bias;
          IFEND;
          integer_value := integer_value DIV fill_bit_eliminator [(header^.length + 1) MOD 8];
          clp$convert_integer_to_string (integer_value, {base} 10, {include radix} FALSE, integer_string,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          NEXT working_parameters^ [parameter_count]: [integer_string.size] IN message_parameter_strings;
          working_parameters^ [parameter_count]^ := integer_string.value;
        ELSE
          end_of_template := TRUE;
        IFEND;

      = nac$mdu_character_string =
{ Character string is displayed as a series of ASCII characters.}
        NEXT working_parameters^ [parameter_count]: [header^.length + 1] IN message_data;
        IF working_parameters^ [parameter_count] = NIL THEN
          end_of_template := TRUE;
          parameter_count := parameter_count - 1;
        IFEND;

      = nac$mdu_bcd =
{ BCD is displayed as a series of hexadecimal digits.}
        count := (header^.length + 1);
        NEXT hex_array: [1 .. count] IN message_data;
        IF hex_array <> NIL THEN
          NEXT working_parameters^ [parameter_count]: [count] IN message_parameter_strings;
          FOR index := 1 to count DO
            working_parameters^ [parameter_count]^ (index) := hex_table [hex_array^ [index]];
          FOREND;
        ELSE
          end_of_template := TRUE;
        IFEND;

      ELSE
        osp$set_status_abnormal (nac$status_id, nae$unknown_cdna_mdu_data_kind, '', status);
        RETURN;
      CASEND;

      NEXT header IN message_data;
    WHILEND {process_optional_data};

    IF (header <> NIL) AND header^.command THEN
      RESET message_data TO header {reposition sequence for next call to get_message_part};
    IFEND;

    IF parameter_count > 0 THEN
      RESET message_parameter_seq;
      NEXT  message_parameters: [1 .. parameter_count] IN message_parameter_seq;
    ELSE
      message_parameters := NIL;
    IFEND;

  PROCEND get_message_part;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    IF message = NIL THEN
      ALLOCATE message;
      RESET message;
    IFEND;

{   Each message parameter requires at least 3 bytes. Maximum number of parameters, therefore, is
{   message_size/3.

    max_parameter_count := #SIZE(network_message) DIV 3;
    PUSH message_parameter_seq: [[REP max_parameter_count OF message_parameter]];

{ Worst case for expansion of raw data to display is the binary string format.
{ Allow for 256 display bytes for each 10 bytes of message (2 header bytes + 8 data bytes)

    PUSH message_parameter_strings: [[REP (#SIZE (network_message) * 256) DIV 10 OF cell]];
    message_data := ^network_message;
    RESET message_data;

    get_message_part (condition_code, message_parameters, end_of_message, status);
    IF (NOT status.normal) OR end_of_message THEN
      RETURN;
    IFEND;

    IF display_control.page_width <= UPPERVALUE (ost$status_message_line_size) THEN
      page_width := display_control.page_width;
    ELSE
      page_width := UPPERVALUE (ost$status_message_line_size);
    IFEND;
    osp$establish_condition_handler (^condition_handler, {block exit=} FALSE);
    osp$format_multi_part_message (osc$brief_message_level, osc$error_status_message_hdr,
          page_width, condition_code, message_parameters, ^get_message_part, message^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET message;
    NEXT line_count IN message;

{ NOTE: The message formatter has placed a format effector in each line. clp$put_display will also add one,
{       so the first character of each line is skipped.

    FOR line_index := 1 TO line_count^ DO
      NEXT text_length IN message;
      NEXT text_line: [text_length^] IN message;
      clp$put_display (display_control, text_line^ (2, *), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND nap$generate_network_message;
MODEND nam$generate_network_message;
*DECK DECK=NAM$GT_APPLICATION_LAYER_R2 EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'NAM/VE: Generic Transport Application Layer' ??
?? NEWTITLE := '  Global Declarations' ??
MODULE nam$gt_application_layer_r2;
*copyc nae$namve_conditions
*copyc nat$gt_job_connection
*copyc nat$gt_connection
*copyc nat$gt_job_sap
*copyc nat$gt_sap
*copyc nat$gt_sap_identifier
*copyc nlt$ta_event
*copyc oss$job_pageable
?? TITLE := '  External Procedures', EJECT ??
*copyc nlp$bm_release_message
*copyc osp$set_job_signature_lock
*copyc osp$clear_job_signature_lock
*copyc osp$executing_in_job_monitor
*copyc osp$set_status_condition
*copyc osp$test_sig_lock
*copyc syp$cycle
?? TITLE := '  Global Variables', EJECT ??
*copyc nav$network_paged_heap
*copyc osv$job_pageable_heap

  VAR
    nav$gt_job_connection_list: [XDCL, #GATE, oss$job_pageable] nat$gt_job_connection_list := [[0], 0,
          NIL];

  VAR
    nav$gt_job_sap_list: [XDCL, #GATE, oss$job_pageable] nat$gt_job_sap_list := [[0], NIL];
?? TITLE := '  [XDCL, #GATE] nap$gt_get_exclusive_to_clist', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$gt_get_exclusive_to_clist;

*copy nah$gt_get_exclusive_to_clist

    osp$set_job_signature_lock (nav$gt_job_connection_list.lock);
  PROCEND nap$gt_get_exclusive_to_clist;
?? TITLE := '  [XDCL, #GATE] nap$gt_releas_exclusiv_to_clist', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$gt_releas_exclusiv_to_clist;

*copy nah$gt_releas_exclusiv_to_clist

    osp$clear_job_signature_lock (nav$gt_job_connection_list.lock);
  PROCEND nap$gt_releas_exclusiv_to_clist;
?? TITLE := '  [XDCL, #GATE] nap$gt_clear_exclusive_to_clist', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$gt_clear_exclusive_to_clist;

*copy nah$gt_clear_exclusive_to_clist
    VAR
      lock_status: ost$signature_lock_status;

    osp$test_sig_lock (nav$gt_job_connection_list.lock, lock_status);
    IF (lock_status = osc$sls_locked_by_current_task) THEN
      osp$clear_job_signature_lock (nav$gt_job_connection_list.lock);
    IFEND;
  PROCEND nap$gt_clear_exclusive_to_clist;
?? TITLE := '  [XDCL, #GATE] nap$gt_create_job_connection', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$gt_create_job_connection (sap_id: nat$gt_sap_identifier;
        active_connection_id: nlt$cl_connection_id;
    VAR job_connection: ^nat$gt_job_connection);
*copy nah$gt_create_job_connection

    VAR
      connection: ^nat$gt_job_connection;

    REPEAT
      ALLOCATE connection IN osv$job_pageable_heap^;
      IF connection = NIL THEN
        syp$cycle;
      IFEND;
    UNTIL connection <> NIL;
    connection^.sap_id := sap_id;
    connection^.active := TRUE;
    connection^.active_connection_id := active_connection_id;
    connection^.connection_id := nav$gt_job_connection_list.connection_id_seed + 1;
    nav$gt_job_connection_list.connection_id_seed := nav$gt_job_connection_list.connection_id_seed + 1;
    connection^.next_connection := nav$gt_job_connection_list.first_connection;
    nav$gt_job_connection_list.first_connection := connection;
    job_connection := connection;
  PROCEND nap$gt_create_job_connection;
?? TITLE := '  [XDCL, #GATE] nap$gt_deactivate_job_connect', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$gt_deactivate_job_connect (termination_state: nat$gt_connection_state;
      termination_event: nlt$ta_event;
      data_length: nat$data_length;
      job_connection: ^nat$gt_job_connection);
*copy nah$gt_deactivate_job_connect

    VAR
      jobb_connection: ^nat$gt_job_connection;

    jobb_connection := #ADDRESS (1, #SEGMENT (job_connection), #OFFSET (job_connection));
    jobb_connection^.active := FALSE;
    jobb_connection^.termination_state := termination_state;
    CASE jobb_connection^.termination_state OF
    = nac$gt_peer_reject, nac$gt_peer_disconnect =
      jobb_connection^.data_length := data_length;
      jobb_connection^.termination_event := termination_event;
    = nac$gt_connection_failed =
      ;
    CASEND;
  PROCEND nap$gt_deactivate_job_connect;
?? TITLE := '  [XDCL, #GATE] nap$gt_delete_job_connection', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$gt_delete_job_connection (connection_id: nat$gt_connection_id);
*copy nah$gt_delete_job_connection

  VAR
    job_connection: ^^nat$gt_job_connection,
    job_connection_to_free: ^nat$gt_job_connection;

    job_connection := ^nav$gt_job_connection_list.first_connection;
    WHILE ((job_connection^ <> NIL) AND (job_connection^^.connection_id <> connection_id)) DO
      job_connection := ^job_connection^^.next_connection;
    WHILEND;
    CASE job_connection^^.termination_state OF
    = nac$gt_peer_disconnect =
      nlp$bm_release_message (job_connection^^.termination_event.osi_disconnect.data);
    ELSE
    CASEND;
    job_connection_to_free := job_connection^;
    job_connection^ := job_connection^^.next_connection;
    FREE job_connection_to_free IN osv$job_pageable_heap^;
  PROCEND nap$gt_delete_job_connection;
?? TITLE := '  [XDCL, #GATE] nap$gt_get_exclusive_to_slist', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$gt_get_exclusive_to_slist;

*copy nah$gt_get_exclusive_to_slist

    osp$set_job_signature_lock (nav$gt_job_sap_list.lock);
  PROCEND nap$gt_get_exclusive_to_slist;
?? TITLE := '  [XDCL, #GATE] nap$gt_releas_exclusiv_to_slist', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$gt_releas_exclusiv_to_slist;

*copy nah$gt_releas_exclusiv_to_slist

    osp$clear_job_signature_lock (nav$gt_job_sap_list.lock);
  PROCEND nap$gt_releas_exclusiv_to_slist;
?? TITLE := '  [XDCL, #GATE] nap$gt_clear_exclusive_to_slist', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$gt_clear_exclusive_to_slist;

*copy nah$gt_clear_exclusive_to_slist
    VAR
      lock_status: ost$signature_lock_status;

    osp$test_sig_lock (nav$gt_job_sap_list.lock, lock_status);
    IF (lock_status = osc$sls_locked_by_current_task) THEN
      osp$clear_job_signature_lock (nav$gt_job_sap_list.lock);
    IFEND;
  PROCEND nap$gt_clear_exclusive_to_slist;
?? TITLE := '  [XDCL, #GATE] nap$gt_add_job_sap', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$gt_add_job_sap (sap: ^nat$gt_job_sap);
*copy nah$gt_add_job_sap

    osp$set_job_signature_lock (nav$gt_job_sap_list.lock);
    sap^.next_sap := nav$gt_job_sap_list.first_sap;
    nav$gt_job_sap_list.first_sap := sap;
    osp$clear_job_signature_lock (nav$gt_job_sap_list.lock);
  PROCEND nap$gt_add_job_sap;
?? TITLE := '  [XDCL, #GATE] nap$gt_delete_job_sap', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$gt_delete_job_sap (sap_id: nat$gt_sap_identifier);
*copy nah$gt_delete_job_sap

  VAR
    job_sap: ^^nat$gt_job_sap;

    job_sap := ^nav$gt_job_sap_list.first_sap;
    WHILE ((job_sap^ <> NIL) AND (job_sap^^.sap_id <> sap_id)) DO
      job_sap := ^job_sap^^.next_sap;
    WHILEND;
    job_sap^ := job_sap^^.next_sap;
  PROCEND nap$gt_delete_job_sap;
?? TITLE := '  [XDCL, #GATE] nap$gt_close_job_connections', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$gt_close_job_connections (VAR status: ost$status);
*copy nah$gt_close_job_connections

    VAR
      job_connection: ^^nat$gt_job_connection,
      lock_status: ost$signature_lock_status;

    status.normal := TRUE;
    osp$test_sig_lock (nav$gt_job_connection_list.lock, lock_status);
    IF (lock_status = osc$sls_not_locked) OR
          ((lock_status = osc$sls_locked_by_another_task) AND (NOT osp$executing_in_job_monitor())) THEN
      osp$set_job_signature_lock (nav$gt_job_connection_list.lock);
      job_connection := ^nav$gt_job_connection_list.first_connection;
      WHILE (job_connection^ <> NIL) DO
        IF job_connection^^.active  THEN
          job_connection^^.active := FALSE;
          job_connection^^.termination_state := nac$gt_connection_failed;
        IFEND;
        job_connection := ^job_connection^^.next_connection;
      WHILEND;
      osp$clear_job_signature_lock (nav$gt_job_connection_list.lock);
    ELSE
      osp$set_status_condition(nae$job_recovery,status);
    IFEND;
  PROCEND nap$gt_close_job_connections;
?? TITLE := '  [XDCL, #GATE] nap$gt_delete_job_saps', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$gt_delete_job_saps;
*copy nah$gt_delete_job_saps

    VAR
      job_sap: ^^nat$gt_job_sap,
      sap_to_free: ^nat$gt_job_sap,
      lock_status: ost$signature_lock_status;

    osp$test_sig_lock (nav$gt_job_sap_list.lock, lock_status);
    IF ((lock_status = osc$sls_not_locked) OR (lock_status = osc$sls_locked_by_another_task)) THEN
      osp$set_job_signature_lock (nav$gt_job_sap_list.lock);
    IFEND;
    nav$gt_job_sap_list.first_sap := NIL;
    osp$clear_job_signature_lock (nav$gt_job_sap_list.lock);
  PROCEND nap$gt_delete_job_saps;
MODEND nam$gt_application_layer_r2;
*DECK DECK=NAM$GT_STATIC_DATA EXPAND=TRUE
?? RIGHT := 110 ??
MODULE nam$gt_static_data;
{ PURPOSE: This module contains all the static data for the GENERIC TRANSPORT EXTERNAL
{          INTERFACE, that has been assigned to network paged segment.
{
?? PUSH (LISTEXT := ON) ??
*copyc nat$gt_assigned_sap_list
*copyc nat$gt_interface
*copyc nat$gt_event
*copyc nat$gt_sap
?? POP ??
*copyc oss$network_paged

  VAR
    nav$gt_sap_list: [XDCL, #GATE, oss$network_paged] nat$gt_sap_list := [ * , NIL];

 VAR
    nav$gt_assigned_sap_list: [XDCL, #GATE, oss$network_paged] nat$gt_assigned_sap_list := [[0],
        [REP (nlc$ta_low_min_osi_sap + nlc$ta_high_max_osi_sap + nac$gt_max_number_of_saps + 1) of
        nac$gt_unassigned]];
MODEND nam$gt_static_data;
*DECK DECK=NAM$ICA_DRIVER EXPAND=TRUE
          IDENT  ICAD,0
          CIPPU  J
          MEMSEL 8
          LIST   F
          TITLE  NAM$ICA DRIVER (ICAD) - INTEGRATED COMMUNICATIONS DRIVER
          COMMENT *SMD* LVL=01
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4,10
***       ICAD - INTEGRATED COMMUNICATIONS DRIVER.
          EJECT
***           ICAD PROVIDES FOR COMMUNICATION BETWEEN NAM/VE
*         AND A INTEGRATED COMMUNICATIONS ADAPTOR (ICA).
*         ICAD COMMUNICATES THROUGH AN S0 ICI CHANNEL TO THE
*         ICA HARDWARE.  THE STATUS OF THE ICA CAN BE
*         DETERMINED FROM THE GENERAL STATUS.  THE ICA HAS
*         FOUR STATES, EACH REFLECTING A DIFFERENT LEVEL OF
*         FUNCTIONALITY.  THESE STATES AND THERE MEANINGS
*         ARE:
*
*         OPERATIONAL: THE ICA MAY BE USED TO RELAY MESSAGES
*             BETWEEN A HOST CHANNEL AND AN ETHERNET.
*
*         RESET: THE ICA IS IN THE FIRST STAGE OF INITIALIZATION.
*             THE ONBOARD DIAGNOSTICS (PHASE 1) ARE EXECUTING
*             OR HAVE JUST COMPLETED EXECUTION.
*
*         DIAGNOSTIC: THE ICA IS IN THE SECOND STAGE OF
*             INITIALIZATION. THE ICA, IN COOPERATION WITH THE
*             ICA DRIVER, IS EXECUTING PHASE 2 OF ONBOARD
*             DIAGNOSTICS.
*
*         IDLE: THE ICA IS IN THE THIRD STAGE OF INITIALIZATION.
*             THE ICA HAS COMPLETED ALL DIAGNOSTICS AND IS WAITING
*             TO BE DUMPED AND/OR LOADED.
*
*             DATA TRANSFER IS ALLOWED IN IDLE OR OPERATIONAL
*         STATE.  DATA TRANSFER TO THE ICA IS INITIATED VIA
*         A WRITE BYTES REQUEST IN THE UNIT QUEUE.  THE
*         REQUEST IS TERMINATED WITH THE STANDARD RESPONSE
*         INDICATING SUCCESS OR FAILURE, AND THEN DELINKED
*         FROM THE CHAIN.  DATA TRANSFER FROM THE ICA IS
*         INITIATED BY THE ICA SETTING THE DATA-AVAILABLE
*         BIT IN GENERAL STATUS.  WHEN TRANSFERRING DATA TO
*         CM,  THE PP OBTAINS CM BUFFERS OUT OF THE BUFFER
*         POOLS SET UP BY THE CP.  MULTIPLE POOLS ALLOW THE
*         PP TO SELECT BUFFERS IN A MANNER WHICH MINIMIZES
*         MESSAGE FRAGMENTATION AND MAXIMIZES BUFFER
*         UTILIZATION.
*
*         TWO POSSIBLE RECORD TYPES MUST BE ACCEPTED FROM THE
*         ICA DEPENDING ON ICA STATE.
*         AN ICA-II RUNNING OSI MODE SENDS AND RECEIVES CHANNELNET
*         PDUS IN IDLE STATE TO LOAD AND DUMP THE ICA. AFTER THE
*         ICA SWITCHES TO OPERATIONAL STATE ALL
*         PDUS ARE CHANNEL CONNECTION FORMAT.
*
*         NOTE THAT IF THE NUMBER OF BUFFER SIZES IS INCREASED
*         BEYOND 2 THE EQUATE MAXBPD MUST BE CHANGED.
*
*         DEBUGGING CODE CAN BE INCLUDED BY SETTING DEBUG = 1
*         AND ASSEMBLING THIS DECK.
*
*         BREAKPOINT CODE CAN BE INCLUDED BY SETTING BRK = 1
*         AND ASSEMBLING THIS DECK. PLUS MODIFYING DECK
*         NAV$INCLUDE_PP_BREAKPOINT AND CHANGING THE BOOLEAN
*         TO TRUE AND COMPILE THE FOLLOWING DECKS.
*
*         NAM$CHANNELNET_RING1
*         NAM$INITIALIZE_NETWORKS_R1
*         NAM$INITIALIZE_NETWORKS_R3
*         NAM$INTRANET_LAYER_MGMT_R3


          TITLE  MACROS
***       MACRO DEFINITIONS.
*
          SPACE  4,10
 SUBR     SPACE  4
***       SUBR - DEFINE SUBROUTINE ENTRY/EXIT LINE.
*
*
*NAME     SUBR
*         DECLARE *NAME* TO BE THE ENTRY POINT TO A PP SUBROUTINE.
*         THIS SUBROUTINE IS ENTERED VIA RETURN JUMP TO *NAME*.
*
*         THE FOLLOWING CODE IS GENERATED -
*NAMEX    LJM    *
*NAME     EQU    *-1


          PURGMAC  SUBR

          MACRO  SUBR,A
A_X LJM *
A EQU *-1
  ENDM
          SPACE  4,10
**        TRACE - DEFINE TRACE MACRO.
*
*         TRACE  (LIST OF ADDRESSES OF DATA TO SAVE WITH TRACE DATA)


 TRACE    MACRO  D
          LOCAL  L
 .TR      IFEQ   DEBUG,1
          RJM    TRACE
 .T       IFC    EQ, D
          CON    0
 .T       ELSE
          CON    L
 TRACE    RMT
 L        BSS    0
          IRP    D
          CON    D
          IRP
          CON    0
          RMT
 .T       ENDIF
 .TR      ENDIF
 TRACE    ENDM
*copy iodmac1
**copy nad$temp_i0_instructions
*copy iodmac4
          SPACE  4,10
**        LOADB - LOAD BYTE ADDRESS
*
*         THIS MACRO REFORMATS A CM ADDRESS AND LOADS IT
*         INTO THE A AND R REGISTERS. CM ADDRESS IS ADJUSTED
*         TO A WORD BOUNDARY AND STARTING BYTE OFFSET IS
*         DETERMINED AND SAVED IN -SBYOFF-.
*
*         CALLING SEQUENCE - LOADB CMR,INDEX
*             THE 2-WORD UNFORMATTED CM ADDRESS IS CONTAINED
*             IN THE LOCATIONS STARTING AT -CMR- INDEXED BY
*             -INDEX-. -INDEX- IS OPTIONAL.
*

 LOADB    MACRO  CMR,INDEX
          LDC    CMR
          IFC    NE,$INDEX$$
          ADD    INDEX
          ENDIF
          STDL   T2
          LDIL   T2
          STDL   T3
          AODL   T2
          LDIL   T2
          LPN    7
          STML   SBYOFF      STARTING BYTE OFFSET
          LDIL   T2
          SCN    7
          STDL   T4
          LDN    T3
          RJM    FORMA
          ENDM

 SIMM     MACRO  TAG
          IFEQ   SIM,1
          UJK    TAG
          ENDIF
          ENDM

          TITLE  INTERFACE ERROR CODES
**        INTERFACE ERROR CODES.
*


 E101     EQU    401B        PP REQUEST QUEUE LOCKWORD TIMEOUT
 E102     EQU    402B        UNIT REQUEST QUEUE LOCKWORD TIMEOUT
 E103     EQU    403B        UNIT LOCKWORD TIMEOUT
 E104     EQU    404B        CHANNEL LOCKWORD TIMEOUT
 E105     EQU    405B        BUFFER POOL LOCKWORD TIMEOUT
 E106     EQU    406B        UNIT HARDWARE RESERVE TIMEOUT
 E107     EQU    407B        CONTROLLER HARDWARE RESERVE TIMEOUT
 E201     EQU    1001B       RMA OF CHANNEL RESERVATION TABLE NOT
                             A WORD BOUNDARY
 E202     EQU    1002B       RMA OF UNIT ACTIVITY MASK NOT A
                             WORD BOUNDARY
 E203     EQU    1003B       RMA OF PP COMMUNICATION BUFFER NOT A
                             WORD BOUNDARY
 E204     EQU    1004B       RESERVED FIELD OF THE PP COMMUNICATION
                             BUFFER DESCRIPTOR IS NOT ZERO
 E205     EQU    1005B       RESERVED FIELD OF THE PP REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 E206     EQU    1006B       RMA OF NEXT PP NOT A WORD BOUNDARY
 E207     EQU    1007B       RESERVED FIELD OF THE PP RESPONSE
                             BUFFER DESCRIPTOR IS NOT ZERO
 E208     EQU    1010B       LOGICAL UNIT OF UNIT DESCRIPTOR NOT
                             IN SEQUENCE OR NOT IN RANGE
 E209     EQU    1011B       RMA OF UNIT INTERFACE TABLE NOT A
                             WORD BOUNDARY
 E20A     EQU    1012B       INVALID CHANNEL NUMBER SPECIFIED
                             IN UNIT DESCRIPTOR
 E20B     EQU    1013B       COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS OR NOT LONG ENOUGH
 E20C     EQU    1014B       RESERVED FIELD AFTER NUMBER OF
                             UNITS IS NOT ZERO
 E20D     EQU    1015B       RESERVED FIELD OF IN POINTER
                             IS NOT ZERO
 E20E     EQU    1016B       RESERVED FIELD OF OUT POINTER
                             IS NOT ZERO
 E20F     EQU    1017B       RESERVED FIELD OF LIMIT POINTER
                             IS NOT ZERO
 E210     EQU    1020B       INVALID PHYSICAL UNIT NUMBER
 E211     EQU    1021B       RMA OF INTERRUPT WORD NOT A WORD BOUNDARY
 E212     EQU    1022B       RMA OF CHANNEL INTERLOCK TABLE NOT A
                             WORD BOUNDARY
 E301     EQU    1401B       LOGICAL UNIT NUMBER NOT EQUAL TO LOGICAL
                             UNIT OF UNIT DESCRIPTOR
 E302     EQU    1402B       RMA OF MASTER CONTROL TABLE
                             NOT A WORD BOUNDARY
 E303     EQU    1403B       A RESERVED FIELD OF THE MASTER CONTROL TABLE
                             DESCRIPTOR IS NOT ZERO
 E304     EQU    1404B       RMA OF NEXT UNIT REQUEST
                             NOT A WORD BOUNDARY
 E305     EQU    1405B       RESERVED FIELD OF UNIT REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 E306     EQU    1406B       INVALID UNIT TYPE
 E307     EQU    1407B       MASTER CONTROL TABLE LENGTH NOT A
                             MULTIPLE OF CM WORDS
 E308     EQU    1410B       MASTER CONTROL TABLE IS TOO SMALL
 E401     EQU    2001B       RMA OF NEXT REQUEST NOT A WORD BOUNDARY
 E402     EQU    2002B       REQUEST LENGTH NOT A MULTIPLE
                             OF EIGHT BYTES
 E403     EQU    2003B       REQUEST LENGTH IS LESS THAN FORTY BYTES
 E404     EQU    2004B       LOGICAL UNIT NUMBER NOT EQUAL TO LOGICAL
                             UNIT IN UNIT INTERFACE TABLE
 E405     EQU    2005B       RESERVED LINKAGE FIELD IS NOT ZERO
 E406     EQU    2006B       INVALID RECOVERY/INTERRUPT SELECTIONS
 E407     EQU    2007B       INVALID PRIORITY SELECTION
 E408     EQU    2010B       INVALID SECONDARY ADDRESS
 E501     EQU    2401B       INVALID COMMAND CODE
 E502     EQU    2402B       INVALID FLAG SELECTION
 E503     EQU    2403B       INVALID FUNCTION
 E504     EQU    2404B       FUNCTION NOT SUPPORTED BY HARDWARE
 E506     EQU    2406B       INVALID ADDRESS SPECIFICATION
                             IN COMMAND
 E507     EQU    2407B       INVALID LENGTH SPECIFICATION IN
                             INDIRECT LIST
 E508     EQU    2410B       INVALID ADDRESS SPECIFICATION
                             IN INDIRECT LIST
 E509     EQU    2411B       PP COMMAND NOT ALLOWED IN REQUEST
                             TO A UNIT
 E50A     EQU    2412B       INVALID SEQUENCE OF COMMANDS
 E50B     EQU    2413B       INVALID PARAMETER SPECIFICATION
                             (POOL READ OR COMPARE SWAP COMMANDS)
          TITLE  CYBIL STRUCTURE DEFINITIONS
**        PP INTERFACE TABLE
*


 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
          ALIGN  0,64
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL INTERLOCK TABLE (RMA)
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER
          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)
          ALIGN  32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND


          SPACE  4
* PP COMMUNICATION BUFFER.

 CB       RECORD PACKED

          ALIGN  31,64
 SLAVE    BOOLEAN            NONZERO IF SLAVE PP
 PARTNR   RMA                PARTNERS COMMUNICATION BUFFER (RMA)

          ALIGN  16,64
 CWLEN    PPWORD             LENGTH OF CONTROLWARE ADDRESS LIST
 CWRMA    RMA                ADDRESS OF FIRST ENTRY
 CB       RECEND


          SPACE  4,10
**        UNIT DESCRIPTORS.
*


 UD       RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 PORT     SUBRANGE 0,3       CHANNEL PORT NUMBER
 CNTRLR   SUBRANGE 0,77B     CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 UD       RECEND
          SPACE  4,10
**        UNIT INTERFACE TABLE
*


 UIT      RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
                               = 400B, 844-4X
                               = 401B, 885-1X
                               = 402B, 885-42
 QCNT     PPWORD             QUEUE COUNT
*
          ALIGN  16,64
 MBUFL    PPWORD             MASTER CONTROL TABLE LENGTH
 MBUF     RMA                MASTER CONTROL TABLE (RMA)
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

 UIT      RECEND
          SPACE  4,10
**        PP REQUESTS.
*


 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON QUEUE (RMA)
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS
                               0 - ATTEMPT RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
 ALRT     PPWORD             ALERT MASK
          ALIGN  0,64
 SECADR   INTEGER            SECONDARY ADDRESS
 CMND     INTEGER            COMMAND SEQUENCE

 RQ       RECEND
          SPACE  4,10
**        PP COMMAND.
*


 CM       RECORD PACKED

 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$
          MASKP  INDIR
 M.INDIR  EQU    MSK

 CM       RECEND
          SPACE  4,10
**        UNIT REQUESTS.
*


 URQ      RECORD PACKED

          ALIGN  16,64
 THISPV   STRUCT 6           THIS REQUEST ON UNIT QUEUE (PVA)
          ALIGN  0,64
 NEXTLN   PPWORD             LENGTH OF NEXT UNIT REQUEST
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 URQLEN   PPWORD             UNIT REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
          ALIGN  0,128       SKIP 6 PP WORDS (128=64*2)
 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)

*         THERE CAN BE 0, 1, OR MORE LENGTH/ADDRESS PAIRS.

          ALIGN  0,64
 MBLEN    PPWORD             MESSAGE BUFFER LENGTH (LENGTH/ADDRESS PAIR LIST)
          ALIGN  32,64
 MBRMA    RMA                MESSAGE BUFFER ADDRESS (LENGTH/ADDRESS PAIR LIST)

 URQ      RECEND
          SPACE  4,10
**        PP RESPONSE.
*


 RS       RECORD PACKED

          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 DEVID    SUBRANGE 0,377B    DEVICE IDENTIFIER
          ALIGN  48,64
 ALRT     PPWORD             ALERT MASK
          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE INTERFACE
                             ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
 CHERR    BOOLEAN            UNCORRECTABLE CHANNEL PARITY ERROR
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION
                             OCCURRED ON INPUT OR INADEQUATE DATA RATE ON OUTPUT
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A
                             HARDWARE MALFUNCTION.  EX: UNIT NOT READY,
                             UNIT NOT CONNECTED.
 FTO      BOOLEAN            FUNCTION TIMEOUT
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO DETAILED STATUS
                               1 - DETAILED STATUS
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE
                               1  - UNIT CHANGED FROM READY TO NOT READY
                               2  - UNIT CHANGED FROM NOT READY TO READY
                               3  - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
                               7  - ICA CHANNELNET READ COMPLETE
                               8  - ICA DEVICE ERROR
                               9  - PP LOG MESSAGE
                               13 - ICA CHANNEL CONNECTION READ COMPLETE
                               14 - UNIT CHANGED TO OPERATIONAL
                               15 - FLOW CONTROL STATUS CHANGE (NOT USED)
          ALIGN  49,64       ALERT CONDITIONS
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)

          ALIGN  0,64
 T1STAT   PPWORD             TYPE 1 STATUS (BUFFER POOL 1 STATUS)
 T2STAT   PPWORD             TYPE 2 STATUS (BUFFER POOL 2 STATUS)
 PSEND    PPWORD             PRIORITY SEND STATE (GLOBAL FLOW CONTROL)
 NSEND    PPWORD             NORMAL SEND STATE (GLOBAL FLOW CONTROL)

*         THERE CAN BE 0, 1, OR MORE LENGTH/ADDRESS PAIRS.

          ALIGN  0,64
 DLEN     PPWORD             DATA LENGTH OF BUFFER TO BE RETURNED
 BUFPVA   STRUCT 6           ADDRESS OF BUFFER TO BE RETURNED

 P.DUML   EQU    P.T1STAT    DUMP LENGTH
 BITC     SET    P.LASTC*16
          ALIGN  0,64
 PROV     PPWORD             CHANNEL PROTOCOL VERSION
          ALIGN  32,64
 MAXRS    STRUCT 4           MAXIMUM RECORD SIZE
 BITC     SET    P.LASTC*16
          ALIGN  0,64
 ERRID    PPWORD             ERROR IDENTIFIERS
 OPTP     PPWORD             OPRATION TYPE
          ALIGN  32,64
*
*         SYMPTOM CODES
 LSGSE    BOOLEAN            GENERAL STATUS ERROR
 LSCEF    BOOLEAN            CHANNEL ERROR FLAG
 LSCD     BOOLEAN            CHANNEL DEACTIVATION ERROR
 LSMLV    BOOLEAN            MESSAGE LENGTH VERIFICATION
 LSCA     BOOLEAN            CHANNEL ACTIVE
 LSCF     BOOLEAN            CHANNEL FULL
 LSCE     BOOLEAN            CHANNEL EMPTY
 LSMT     BOOLEAN            MESSAGE CONTENT ERROR
 LSIT     BOOLEAN            INCOMPLETE TRANSFER
 LSMSE    BOOLEAN            MAXIMUM SIZE EXCEEDED
          ALIGN  48,64
 FUNTO    PPWORD             FUNCTION CODE IF FUNCTION TIMEOUT ERROR
 PFUNC    PPWORD             PREVIOUS FUNCTION
 CURST    PPWORD             CURRENT STATE
 P.DATA1  EQU    P.CURST     ERROR DATA WORD 1
 PREST    PPWORD             PREVIOUS STATE
 P.DATA2  EQU    P.PREST     ERROR DATA WORD 2
 TSTAT    PPWORD             TRANSITION STATE
 EXPD     STRUCT 4           EXPECTED MESSAGE LENGTH
 ACTD     STRUCT 4           ACTUAL MESSAGE LENGTH
 RETSUC   PPWORD             RETRY SUCCESS
*                            0 = UNRECOVERED ERROR
*                            1 = RECOVERED ERROR
*                            2 = INTERMEDIATE ERROR
*                            3 = INFORMATIVE MESSAGE
 RETCT    PPWORD             RETRY COUNT
 LDS      BOOLEAN            DETAIL STATUS INCLUDED
 LGS      BOOLEAN            GENERAL STATUS INCLUDED
 DICA     BOOLEAN            DOWN ICA
          ALIGN  48,64
 GENST    PPWORD             GENERAL STATUS OF THE FIRST TIME ERROR
                               WAS ENCOUNTERED
          ALIGN  0,64
 DETAIL   PPWORD             START OF DETAILED STATUS - ICA SOFTWARE VERSION NUMBER
          PPWORD             ROM VERSION NUMBER
          PPWORD             HARDWARE MODEL/BOARD NUMBER
          PPWORD             LAST FUNCTION ISSUED BY PP
          PPWORD             ERROR WORD 1
          PPWORD             ERROR WORD 2
          PPWORD             LAST BUT ONE FUNCTION ISSUED BY PP
          PPWORD             LAST BUT TWO FUNCTION ISSUED BY PP
          PPWORD             MESSAGES IN OUTPUT QUEUE
          PPWORD             MESSAGES IN INPUT QUEUE
          PPWORD             NUMBER OF FREE BUFFERS
          PPWORD             PERCENT OF FREE BUFFERS

          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$
          MASKP  INTERR
 K.INTERR EQU    MSK
          MASKP  DATOV
 K.DATOV  EQU    MSK
          MASKP  DATERR
 K.DATERR EQU    MSK
          MASKP  HDWR
 K.HDWR   EQU    MSK
          MASKP  CHERR
 K.CHERR  EQU    MSK
          MASKP  NRDY
 K.NRDY   EQU    MSK
          MASKP  FTO
 K.FTO    EQU    MSK

*         ERRID CODES
 K.LFTO   EQU    1           FUNCTION TIMEOUT ERROR
 K.LTF    EQU    2           STATE TRANSITION FAILURE
 K.LIVST  EQU    3           INVALID STATE TRANSITION
 K.LGSBTO EQU    4           GENERAL STATUS BUSY TIME OUT
 K.LOF    EQU    5           OPERATION FAILURE
 K.LRBTO  EQU    6           RESET BUSY TIMEOUT
 K.LODF   EQU    7           ONBOARD DAIGNOSTIC FAILURE
 K.LGSSDT EQU    8           GENERAL STATUS SEND DATA TIMEOUT
 K.LGSAT  EQU    9           GENERAL STATUS AVAILABLE TIMEOUT
 K.LGSCF  EQU    10          GENERAL STATUS CONTENT FAILURE
 K.LIOP   EQU    11          INDETERMINATE OUTPUT PARITY
 K.LICAR  EQU    12          ICA RESET
 K.LICAO  EQU    13          ICA OPERATIONAL
 K.LGSRR  EQU    14          GENERAL STATUS REJECT ON READ DIAG FAILED
 K.LPROER EQU    15          PROTOCOL MISMATCH
 K.LUD    EQU    16          USAGE DATA
 K.LFCE   EQU    17          ILLEGAL FLOW CONTROL

*         OPERATION CODES
 K.LWRT   EQU    1           WRITE
 K.LREAD  EQU    2           READ
 K.LRDS   EQU    3           READ DETAILED STATUS
 K.LQPM   EQU    4           QUEUE PREVIOUS MESSAGE
 K.LCAT   EQU    5           CHANNEL ACTIVE TIMEOUT
 K.LSR    EQU    7           STATUS RETURN
 K.LRDC   EQU    6           READ DIAGNOSTIC COMMAND
 K.LRGS   EQU    8           READ GENERAL STATUS
 K.LLM    EQU    9           LOAD MEMORY
 K.LEIS   EQU    10          ENTER IDLE STATE
 K.LEDS   EQU    11          ENTER DIAGNOSTIC STATE
 K.LSIP   EQU    12          SET ICA PARAMETERS
 K.LDM    EQU    13          DUMP MEMORY
 K.LRCC   EQU    14          READ CONFIDENCE TEST
 K.LSEA   EQU    15          SEND ETHERNET ADDRESS
          MASKP  LSGSE
 K.LSGSE  EQU    MSK
          MASKP  LSCEF
 K.LSCEF  EQU    MSK
          MASKP  LSCD
 K.LSCD   EQU    MSK
          MASKP  LSMLV
 K.LSMLV  EQU    MSK
          MASKP  LSCA
 K.LSCA   EQU    MSK
          MASKP  LSCF
 K.LSCF   EQU    MSK
          MASKP  LSCE
 K.LSCE   EQU    MSK
          MASKP  LSMT
 K.LSMT   EQU    MSK
          MASKP  LSIT
 K.LSIT   EQU    MSK
          MASKP  LSMSE
 K.LSMSE  EQU    MSK
          MASKP  LDS
 K.LDS    EQU    MSK
          MASKP  LGS
 K.LGS    EQU    MSK
          MASKP  DICA
 K.DICA   EQU    MSK

 RS       RECEND
          SPACE 4,10
**        READ DATA UNIT HEADER
*

 RDATA    RECORD PACKED

 DLEN     PPWORD             DATA LENGTH
 DTYPE    PPWORD             DATA TYPE

 RDATA    RECEND
          SPACE 4,10
**        IEEE 802.3 HEADER.
*

 H802.3   RECORD PACKED

 DADDR    STRUCT 6           DESTINATION ADDRESS
 SADDR    STRUCT 6           SOURCE ADDRESS
 DLEN     PPWORD             DATA LENGTH

 H802.3   RECEND
          SPACE  4,10
**        CHANNEL CONNECTION HEADER.
*

 HCC      RECORD PACKED

 CCPDUH   STRUCT 4           CCPDU HEADER
 FILL     STRUCT 2           FUTURE LENGTH FIELD NOT SUPPORTED
 DLEN     STRUCT 2           LENGTH OF RECORD

 HCC      RECEND
          SPACE  4,10
**        HEADER DESCRIPTOR.
*
*         DESCRIPTOR OF DATA USED TO DESCRIBE THE HEADER CHARACTERISTICS
*         OF EACH RECORD TYPE SUPPORTED.

 HD       RECORD PACKED

 HLB      PPWORD             HEADER LENGTH IN BYTES READ
 HLC      PPWORD             HEADER LENGTH IN BYTES WRITTEN TO CM
 ALF      PPWORD             ADDRESS OF LENGTH FIELD IN HEADER
 ATL      PPWORD             ADD TO LENGTH IN HEADER
 RRC      PPWORD             READ RESPONSE CODE
 MRS      PPWORD             MAXIMUM RECORD SIZE

 HD       RECEND
          SPACE  4,10
**        UNIT QUEUE DESCRIPTOR.
*

 UQD      RECORD PACKED

 LEN      PPWORD             LENGTH OF THE HEAD OF THE SEND QUEUE
          ALIGN  32,64
 HEAD     RMA                ADDRESS OF HEAD OF THE SEND QUEUE (RMA)
          ALIGN  32,64
 TAIL     RMA                ADDRESS OF TAIL POINTER OF THE SEND QUEUE (RMA)

          SPACE  4,10
**        BUFFER POOL.
*

 BP       RECORD PACKED

          ALIGN  16,64
 PVA      STRUCT 6           PVA OF DESCRIPTOR (PVA)
          ALIGN  32,64
 RMA      RMA                RMA OF CONTAINER (RMA)

 BP       RECEND
          SPACE  4,10
**        BUFFER POOL DESCRIPTOR.
*

 BPD      RECORD PACKED

          ALIGN  32,64
 BTRMA    RMA                RMA OF BUFFER TABLE (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 CPUOUT   PPWORD             CPU OUT POINTER
          ALIGN  48,64
 PPOUT    PPWORD             PP OUT POINTER
 LEN      STRUCT 4           LENGTH OF EACH POOL BUFFER (CM BYTES)
 THRESH   PPWORD             MINIMUM NUMBER OF AVAILABLE BUFFERS ALLOWED
 LIMIT    PPWORD             LENGTH OF CIRCULAR BUFFER (CM BYTES)

 BPD      RECEND
          SPACE  4,10
**        BUFFER POOL HEADER.
*

 BPH      RECORD PACKED

 BP1      STRUCT B.BPD       TYPE 1 BUFFER POOL
 BP2      STRUCT B.BPD       TYPE 2 BUFFER POOL

 BPH      RECEND
 UQD      RECEND
          SPACE  4,10
**        MASTER CONTROL TABLE.
*

 MCT      RECORD PACKED

 FLAGS    PPWORD             FLAG WORD
          ALIGN  48,64
 DEVID    PPWORD             DEVICE IDENTIFIER
 NOR      STRUCT B.UQD       NORMAL QUEUE
 PRI      STRUCT B.UQD       PRIORITY QUEUE
          ALIGN  32,64
 BP       RMA                BUFFER POOL DESCRIPTOR POINTER (RMA)

 INIT     EQU    15          BIT ASSIGNED UNIT INITIALIZED FIELD

 MCT      RECEND
          TITLE  GENERAL EQUATES
**        GENERAL EQUATES.
*


 CHN      EQU    15B         CHANNEL NUMBER
 D.DATA1  EQU    125252B     DIAGNOSTIC CONFIDENCE TEST DATA
 D.DATA2  EQU    52525B      DIAGNOSTIC CONFIDENCE TEST DATA
 EAL      EQU    4           ETHERNET ADDRESS LENGTH
 FTRY     EQU    3           NUMBER OF RETRYS ON FUNCTION TIMEOUT
 LDSPP    EQU    12          DETAILED STATUS LENGTH IN PP WORDS (ICA-1 MODE)
 LDSOSI   EQU    8           DETAILED STATUS LENGTH IN PP WORDS (OSI MODE)
 MAXBPD   EQU    2           MAXIMUM BUFFER POOL DESCRIPTORS
 MAXDIAG  EQU    764         MAX NUMBER OF PP WORDS TO XFER IN DIAG STATE
 MAXBYTS  EQU    MAXDIAG*2   MAXIMUM LENGTH IN BYTES
*MAXDMA   EQU    1024        MAX CM BYTES THAT ICA CAN RECEIVE PER DMA TRANSFER
 MAXDMA   EQU    2048-8      MAX CM BYTES THAT ICA CAN RECEIVE PER DMA TRANSFER
 MAXLEN   EQU    1536        MAXIMUM LENGTH FOR CHANNELNET
 MINLEN   EQU    1400B       MINIMUM LENGTH OF I/O BUFFER
 MAXPR    EQU    3           MAXIMUM CONSECUTIVE PRIORITY REQUESTS

*         ALLOW FOR 6 BUFFERS PER MESSAGE. IF THIS IS CHANGED, A CORRESPONDING
*         CHANGE MUST BE MADE IN NAM$INTRANET_LAYER_MGMT_R3, PROCEDURE
*         PROCESS_UNSOLICITED_RESPONSE.

 MAXRS    EQU    12          MAXIMUM RESPONSE BUFFER SIZE (CM WORDS)
 MAXURQ   EQU    11          MAXIMUM UNIT REQUEST SIZE (CM WORDS)
 S.DATA0  EQU    124452B     ECHO STATUS DATA
 S.DATA1  EQU    50425B      ECHO STATUS DATA
 DRTYP    EQU    2           =2 IF ICA DRIVER
 U.I2TYPE EQU    1006B       ICA-2 UNIT TYPE
 SIM      EQU    0           =1, IF RUNNING ON SIMULATOR
 BRK      EQU    1           =1, IF PP BREAKPOINT CODE ASSEMBLED
 DEBUG    EQU    1           =1, IF DEBUGGING CODE ON
          SPACE  4,38
**        COMMAND CODES.
*


 C.ACK    EQU    0           ACKNOWLEDGE
 C.STOP   EQU    1           STOP UNIT
 C.SELU   EQU    2           SELECT UNIT
 C.SELC   EQU    3           SELECT CONTROLLER
 C.IDLE   EQU    4           IDLE
 C.RESUME EQU    5           RESUME
 C.DBGRM  EQU    6           READ PP MEMORY
 C.READY  EQU    7           START READY SCAN
 C.SREADY EQU    10B         STOP READY SCAN
 C.DBGSM  EQU    11B         SELECT PP MEMORY ADDRESS
 C.DBGWM  EQU    12B         WRITE PP MEMORY
 C.DEFBA  EQU    14B         DEFINE PP BKPT AREA IN CM
 C.FUNC   EQU    40B         OUTPUT FUNCTION
 C.OUTP   EQU    41B         OUTPUT 8-BIT PARAMETERS
 C.OUTD   EQU    43B         OUTPUT 8-BIT DATA
 C.IND    EQU    45B         INPUT 8-BIT DATA/PARAMETERS
 C.READ   EQU    100B        READ BYTES
 C.WRTR   EQU    121B        WRITE CHANNEL CONNECTION RECORD
 C.STATUS EQU    140B        READ STATUS
 C.COUNT  EQU    141B        STORE TRANSFER COUNT
 C.RDY    EQU    165B        SYNCHRONIZE READY
 C.GFC    EQU    167B        GLOBAL FLOW CONTROL
 C.DBUG   EQU    170B        DEBUG MODE
 C.RESET  EQU    171B        RESET ICA
 C.DEFEA  EQU    172B        DEFINE ETHERNET ADDRESS
 C.WRITEV EQU    200B        WRITE VERIFY
          SPACE  4,10
**        DIAGNOSTIC COMMAND CODES
*


 DC.UNFW  EQU    10000B      1000(16) WRITE UNFORMATTED
 DC.FW    EQU    10020B      1010(16) WRITE FORMATTED
 DC.READ  EQU    10040B      1020(16) READ DATA
 DC.ECHO  EQU    10100B      1040(16) ECHO STATUS
 DC.END   EQU    10120B      1050(16) END DIAGNOSTICS
          SPACE  4,10
**        ICA DIRECT FUNCTION CODES.
*


 F.GS     EQU    410B        0108(16) GENERAL STATUS
 F.RESET  EQU    440B        0120(16) RESET
 F.MCLEAR EQU    460B        0130(16) MASTER CLEAR
          SPACE  4,12
**        ICA RAM TRANSPARENT FUNCTION CODES.
*

 F.DS     EQU    1B          0001(16) DETAILED STATUS
 F.NORM   EQU    2B          0002(16) NORMAL FUNCTION
 F.QPREAD EQU    3B          0003(16) QUEUE PREVIOUS MESSAGE
 F.READ   EQU    4B          0004(16) TRANSPARENT READ
 F.WRITE  EQU    5B          0005(16) TRANSPARENT WRITE
 F.FCOFF  EQU    6B          0006(16) NORMAL FLOW CONTROL OFF
 F.FCON   EQU    7B          0007(16) NORMAL FLOW CONTROL ON
 F.SETPAR EQU    13B         000B(16) SET ICA PARAMETERS
          SPACE  4,10
**        ICA ROM TRANSPARENT FUNCTION CODES.
*

 F.LOAD   EQU    110000B     9000(16) LOAD MEMORY
 F.DUMP   EQU    110001B     9001(16) DUMP MEMORY
 F.IDLE   EQU    110002B     9002(16) ENTER IDLE STATE
 F.FDUMP  EQU    110003B     9003(16) FORMAT DUMP
 F.SOSI   EQU    110020B     9010(16) START OSI LOAD
 F.DEFEA  EQU    110021B     9011(16) DEFINE ETHERNET ADDRESS
          SPACE  4,14
**        ICA DIAGNOSTIC TRANSPARENT FUNCTION CODES.
*

 F.RET1   EQU    50025B      5015(16) STATUS RETURN 1
 F.RDIAG  EQU    114000B     9800(16) READ DIAGNOSTIC COMMAND
 F.OUTPUT EQU    114020B     9810(16) OUTPUT UNFORMATED MESSAGE
 F.EIDLE  EQU    114040B     9820(16) ENTER IDLE STATE
 F.EDIAG  EQU    114060B     9830(16) ENTER DIAGNOSTIC STATE
 F.GSRR   EQU    114100B     9840(16) GENERAL STATUS REJECT READ
 F.CHAATC EQU    114120B     9850(16) CHANNEL ACTIVE TIMEOUT
 F.RCC    EQU    114140B     9860(16) READ CONFIDENCE TEST
 F.WCC    EQU    114141B     9861(16) WRITE CONFIDENCE TEST
 F.RET0   EQU    124052B     A82A(16) STATUS RETURN 0


          SPACE  4,26
**        GENERAL STATUS BIT DEFINITIONS
*

 S.RC1    EQU    0           RESET CODE REASON
 S.RC2    EQU    1           RESET CODE REASON
 S.RC3    EQU    2           RESET CODE REASON
 S.FC1    EQU    0           FLOW CONTROL SUBSTATE
 S.FC2    EQU    1           FLOW CONTROL SUBSTATE
 S.FC3    EQU    2           FLOW CONTROL SUBSTATE
 S.SC1    EQU    3           SYMPTOM CODE
 S.SC2    EQU    4           SYMPTOM CODE
 S.SC3    EQU    5           SYMPTOM CODE
 S.SS1    EQU    3           OPERATIONAL SUBSTATE
 S.SS2    EQU    4           OPERATIONAL SUBSTATE
 S.SS3    EQU    5           OPERATIONAL SUBSTATE
 S.BUSY   EQU    6           BUSY BIT
 S.SEND   EQU    7           SEND DATA
 S.SB1    EQU    8           STATE BITS
 S.SB2    EQU    9           STATE BITS
 S.DATAV  EQU    10          DATA AVAILABLE
 S.IE     EQU    12          ICA ERRORS
 S.PE     EQU    13          PP ERRORS
 S.CE     EQU    14          CHANNEL ERRORS
 S.GE     EQU    15          GENERAL ERRORS
 SSMASK   EQU    7           SUBSTATE MASK
          SPACE  4,10
**        DETAILED STATUS WORD OFFSETS
*


 DS.PROV  EQU    0           CHANNEL PROTOCOL VERSION
 DS.MPS   EQU    6           MAXIMUM PDU SIZE
          SPACE  4,10
**        ICA STATES
*

 ST.RESET EQU    0           RESET STATE
 ST.DIAG  EQU    1           DIAGNOSTICS STATE
 ST.IDLE  EQU    2           IDLE STATE
 ST.OPER  EQU    3           OPERATIONAL
          SPACE  4,10
**        OPERATIONAL SUBSTATES
*

 OSS.DATA EQU    0           DATA TRANSFER
 OSS.WPN  EQU    1           WAITING FOR PROTOCOL NEGOTIATION
          SPACE  4,10
**        FLOW CONTROL SUBSTATES
*

 FSS.OFF  EQU    0           NORMAL FLOW CONTROL OFF
 FSS.ON   EQU    1           NORMAL FLOW CONTROL ON
          SPACE  4,10
**        RESPONSE CODES.
*


 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    1           INTERMEDIATE RESPONSE
 R.NRM    EQU    2           NORMAL REQUEST TERMINATION
 R.ABN    EQU    3           ABNORMAL REQUEST TERMINATION
          SPACE  4,10
**        RESPONSE CONDITIONS
*


 RC.NONE  EQU    0           NEITHER CONDITIONS 1 OR 2 OCCURRED
 RC.REC   EQU    1           RECOVERED ERROR
 RC.XRES  EQU    2           A COMMAND REQUESTING A RESPONSE WAS EXECUTED OK
 RC.BOTH  EQU    3           BOTH CONDITIONS 1 + 2 OCCURRED
          SPACE  4,15
**        UNSOLICITED RESPONSE CODES
*

 URC.RN   EQU    1           CHANGE FROM READY TO NOT READY
 URC.NR   EQU    2           CHANGE FROM NOT READY TO READY
 URC.IE   EQU    3           INTERNAL OR INTERFACE ERROR
 URC.RD   EQU    7           READ RESPONSE
 URC.DE   EQU    8           DEVICE ERROR
 URC.LM   EQU    9           PP LOG MESSAGE
 URC.CR   EQU    13          CHANNEL CONNECTION READ RESPONSE
 URC.LO   EQU    14          CHANGE TO OPERATIONAL
          SPACE  4,10
***       ERROR RECOVERY SUCCESS CODES
*

 REC.R    EQU    0           RECOVERED ERROR
 REC.U    EQU    1           UNRECOVERED ERROR
 REC.I    EQU    2           INTERMEDIATE ERROR
 REC.IM   EQU    3           INFORMATIVE MESSAGE
          SPACE  4,12
***       WAIT TIMES IN MILLISECONDS
*
 FTOLEN   EQU    50          FUNCTION TIMEOUT LENGTH  (T1/T2)
 GSBUSY   EQU    100         MAXIMUM WAIT FOR NOT BUSY  (T4)
 GSFULL   EQU    1           WAIT FOR FULL ON GENERAL STATUS
 LMBUSY1  EQU    6000        MAX BUSY WAIT FOR LOAD FOR ICA-1  (T5)
 LMBUSY2  EQU    6000        MAX BUSY WAIT FOR LOAD FOR ICA-2  (T5)
 RSBUSY1  EQU    8000        MAXIMUM RESET BUSY WAIT FOR ICA-1 (T7)
 RSBUSY2  EQU    25000       MAXIMUM RESET BUSY WAIT FOR ICA-2 (T7)
 WTDEACT  EQU    10          WAIT FOR CHANNEL TO DEACTIVATE
 WTEMPTY  EQU    1           MAXIMUM WAIT FOR CHANNEL EMPTY  (T7)
 WTFULL   EQU    1           MAXIMUM WAIT FOR CHANNEL FULL  (T7)
          SPACE  4,10
**        BUFFER POOL STATUS CONDITIONS.
*

 BP.EMPTY EQU    0           BUFFER POOL IS OUT OF BUFFERS
 BP.THRSH EQU    1           BUFFER COUNT HAS FALLEN BELOW SPECIFIED THRESHOLD
 BP.GOOD  EQU    2           BUFFER POOL CONTAINS A SUFFICIENT NUMBER OF BUFFERS

          SPACE  4,10
***       INTERNAL STATE CODES
*

 SC.PPR   EQU    1           INTERNAL RESET CODE IF RESET BY PP
 SC.ICA   EQU    2           INTERNAL RESET CODE IF RESET BY ICA
 SC.PPD   EQU    3           INTERNAL RESET CODE IF ICA DOWNED BY PP
 SC.AV    EQU    4           STATE CHANGING TO AVAILABLE
 SC.OPER  EQU    5           STATE CHANGING TO OPERATIONAL
          SPACE  4,10
**        BUFFER RETURN SEND STATE CONDITIONS.
*

 SS.CLOSE EQU    0           PP CANNOT SEND ANY MORE MESSAGES TO THE DEVICE (NOT USED)
 SS.OPEN  EQU    1           PP IS ABLE TO SEND MESSAGES TO THE DEVICE
          SPACE  4,10
***       DATA CONTENT ERROR CODES
*

 CE.WUM   EQU    1           WRITE UNFORMATTED
 CE.WFM   EQU    2           WRITE FORMATTED
 CE.RD    EQU    3           READ
 CE.ES    EQU    4           ECHO STATUS
          SPACE  4,10
**        CHANNEL PROTOCOL EQUATES.
*

 PR.MIN   EQU    0#01        MINIMUM PROTOCOL SUPPORTED BY DRIVER
 PR.MAX   EQU    0#01        MAXIMUM PROTOCOL SUPPORTED BY DRIVER
 PR.BASE  EQU    0#40        BASE FOR PROTOCOL NEGOTIATION


          TITLE  DIRECT CELL DEFINITIONS
**        DIRECT CELLS
*


          ORG    0
          CON    INT-1       STARTING ADDRESS
 ABSC     BSSZ   1           ABNORMAL STATUS CODE
 BUFLEN   BSSZ   1           CM BUFFER LENGTH IN PP WORDS
 BUSYMP   CON    1           NUMBER OF TIMES TO EXECUTE BUSY LOOP IN GST
 BYTCNT   BSSZ   1           BYTE COUNT OF TRANSFER
 BYTS     BSSZ   1           NUMBER OF BYTES TO TRANSFER TO/FROM CM
 CMADR    BSSZ   3           CM ADDRESS
 CML      BSSZ   1           INDEX TO CMLIST
 CMLISTL  BSSZ   1           NUMBER OF CM WORDS IN ADDRESS-LENGTH PAIR LIST.
 CM.PPR   BSSZ   2           CM ADDRESS OF PREVIOUS PERIPHERAL REQUEST (REFORMATTED)
 CM.PIT   BSSZ   2           CM ADDRESS OF PP INTERFACE TABLE (REFORMATTED)
 CM.URQ   BSSZ   2           CM ADDRESS OF UNIT REQUEST QUEUE (REFORMATTED)
 CM.RS    BSSZ   2           CM ADDRESS OF RESPONSE BUFFER (REFORMATTED)
 CM.QT    BSSZ   2           CM ADDRESS OF UNIT QUEUE TAIL POINTER (REFORMATTED)
 CM.BPD   BSSZ   2           CM ADDRESS OF BUFFER POOL DESCRIPTOR (REFORMATTED)
 DATADD   BSSZ   2           CM ADDRESS OF DATA AREA
 ERRCNT   BSSZ   1           NUMBER OF BYTES NOT TRANSFERED ON IO REQUEST
 ERRRCP   BSSZ   1           POINTER TO RECOVERY COUNTER
 ERRT1    BSSZ   1           TEMPORARY STORAGE FOR ERR CHECK
 FSTBD    BSSZ   1           INDEX TO BUFFER DESCRIPTOR
 FUNCD    BSSZ   1           FUNCTION CODE
 GNSTAT   BSSZ   1           GENERAL STATUS
 ICATDDP  BSSZ   1           ICA TYPE-DEPENDENT DATA POINTER
 LSTATE   BSSZ   1           LAST STATE ICA WAS KNOWN TO BE IN
 LIM      BSSZ   1           LIMIT OF CIRCULAR RESPONSE BUFFER
 ONE      CON    1           CONSTANT OF 1
 PPNO     CON    1           LOGICAL PP NUMBER

*         *P1* AND *P2* ARE MOVED TO *DRNAME* AT INITIALIZATION TIME.

 P1       DATA   H*IC*
 P2       DATA   H*AD*
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 P6       BSSZ   1
 RDCNT    BSSZ   1           BYTES READ THIS XFER
 RESPC    BSSZ   1           RESPONSE CODE
 STCHNG   CON    SC.PPR      ICA STATE CHANGE REQUESTED

*                            0 = NO STATE CHANGE REQUESTED
*                            1 = PP REQUESTED RESET
*                            2 = ICA INITIATED RESET
*                            3 = ICA DOWN
*                            4 = ICA STATE CHANGE TO IDLE
*                            5 = ICA STATE CHANGE TO OPERATIONAL

 T1       BSSZ   1
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1
 T9       BSSZ   1
 T10      BSSZ   1
 UNSC     BSSZ   1           UNSOLICITED RESPONSE CODE
 WC       BSSZ   1           WORD COUNT TO READ/WRITE CM WORDS
 C1       BSSZ   1           TEMPORARY ONLY FOR S1 TESTING
          SPACE  3
          ERRMI  72B-*       ERROR IF P > 72B
          ORG    72B

 DSRTP    CON    0           HCS REAL MEMORY WORD-ADDRESS
          CON    1
 C2       EQU    DSRTP       TEMPORARY FOR S1 TESTING
 INPNT    EQU    DSRTP+1     IN POINTER FOR RESPONSE BUFFER
 NUMBP    BSSZ   1           NUMBER OF BUFFER POOLS
 HDRTYP   BSSZ   1           INDEX INTO HEADER CHARACTERISTIC TABLE
          ERRMI  76B-*       ERROR IF P > 76B
          ORG    76B
          CON    5           TEMPORARY, PP TYPE USED BY DEADSTART
 ERRT2    EQU    76B         TEMPORARY STORAGE FOR ERR CHECK
 IOCNT    BSSZ   1           NUMBER OF CHANNEL WORDS TO TRANSFER
          SPACE  4,10
          ERRMI  100B-*      ERROR IF P > 100B
          ORG    100B
 DRNAME   LJM    INT         INITIALIZE DRIVER
          SPACE  4,10
 AVAIL    CON    URC.RN      = LAST UNSOLICITED RESPONSE CODE SENT
*                            INDICATING ICA AVAILABILITY
 BWRT     BSSZ   1           NUMBER OF BYTES TO WRITE TO CM BUFFER
 CHAN     BSSZ   1           CHANNEL NUMBER
 CHLOCK   BSSZ   1           NON ZERO IF CHANNEL LOCKED
 CM.INT   BSSZ   3           CM ADDRESS OF INTERRUPT WORD (REFORMATTED)
 CM.CHAN  BSSZ   3           CM ADDRESS OF CHANNEL INTERLOCK TABLE (REFORMATTED)
 CM.CONF  BSSZ   2           CM ADDRESS OF CONFIGURATION (REFORMATED)
 CM.LOAD  BSSZ   3           LENGTH/ADDRESS PAIR OF MICROCODE (REFORMATED)
*
*    A REGISTER PORTION OF REFORMATTED ADDRESS OF MASTER CONTROL TABLE.
*
 CM.MCT   BSSZ   1
 CPDS     BSSZ   1           CP DUMP SEQUENCER
 DBUGM    CON    1           = 0 IF DEBUG MODE ON
*                            = 1 IF DEBUG MODE OFF
 DEVID    BSSZ   1           DEVICE IDENTIFIER
 EA       BSSZ   4           ETHERNET ADDRESS OF ICA IF OSI MODE
 EBYOFF   BSSZ   1           ENDING BYTE OFFSET VALUE (ODD OR EVEN)
 ERRR     BSSZ   1           DECREMENTED BY ONE EACH TIME AN ERROR OCCURS
*                            THAT IS EXPECTED TO BE RETRIED IMMEDIATLY.
 EXPD     BSSZ   4           EXPECTED/ACTUAL LENGTH OF MESSAGE
 ACTD     EQU    EXPD+2
 FBSIZE   BSSZ   1           MAXIMUM SIZE OF FIRST BUFFER POOL BUFFER
 GFCFC    CON    F.FCOFF     FLOW CONTROL FUNCTION TO BE SENT AFTER READY
 GSSAVE   BSSZ   1           SAVE GENERAL STATUS FOR LOGGING
 OSITDD   BSS    0           ICA-2 OSI MODE TYPE DEPENDENT DATA
          LOC    0
 RSBUSY   CON    RSBUSY2/GSBUSY  MAX CYCLES TO WAIT FOR RESET FOR ICA-2
 LMBUSY   CON    LMBUSY2/GSBUSY  MAX CYCLES TO WAIT FOR LOAD FOR ICA-2
 DSCFLAG  CON    1           PERFORM DIAGNOSTIC STATUS CHECK
 OSI      CON    1           OSI SUPPORT
 LOADFC   CON    F.SOSI      FUNCTION CODE FOR LOAD
 CONFIG   CON    SEA         CONFIGURATION PROCEDURE
 STATAL   CON    ST.IDLE     STATE AFTER LOAD MEMORY
 LDS      CON    LDSOSI      LENGTH OF DETAILED STATUS
          LOC    *O
 IDLE     BSSZ   1           IDLE FLAG
 IERC     BSSZ   1           INTERFACE ERROR CODE
 INIT     BSSZ   1           0 IF IN PP INITIALIZATION
 LFLEN    BSSZ   2           LENGTH OF MICRO CODE LOAD FILE FROM HEADER
 LIOC     BSSZ   2           LARGE IO COUNT
 NIL      VFD    48/0#FFFF80000000,16/0  CYBIL NIL POINTER
 NUMPRI   BSSZ   1           NUMBER OF CONSECUTIVE PRIORITY REQUESTS
 NXTREC   BSSZ   1           NUMBER OF BYTES IN THE NEXT RECORD TO BE READ
 OSOSI    BSSZ   1           = 1 IF ICA IS OPERATIONAL
 OTYPE    BSSZ   1           OPERATION TYPE FOR ERROR CHECKING
 PREFC    BSSZ   1           PREVIOUS FUNCTION CODE
 PROV     BSSZ   1           VERSION OF CHANNEL PROTOCOL ICA SUPPORTS
 PWRT     BSSZ   1           SIZE OF DMA TRANSFER BLOCK (PP WORDS)
 PVA      BSSZ   8           PVA - RMA ADDRESS PAIR STORAGE AREA
 RMA      EQU    PVA+/RQ/P.NEXT
 RCON     BSSZ   1           RESPONSE CONDITION
 RESST    BSSZ   1           RESET STATUS
 REQTYP   BSSZ   1           =0, IF PROCESSING PP REQUEST
*                            <> 0, IF PROCESSING UNIT REQUEST
 RDRTY    BSSZ   1           DECREMENTED BY ONE EACH TIME A READ ERROR
*                            OCCURS. SET TO ZERO ON UNRECOVERED ERROR.
 SCP.DMP  BSSZ   1           SYNCHRONIZATION WORD FOR ICA DUMP
 SCP.TRM  BSSZ   1           SYNCHRONIZATION WORD FOR ICA DUMP TERMINATION
 SCP.RDY  BSSZ   1           SYNCHRONIZATION WORD FOR READY
 STBI     BSSZ   1           INPUT TO SEARCH TABLE ROUTINE

*
*         TCCH   DEFINES THE CHANNEL CONNECTION HEADER
*

 TCCH     BSS    0
          LOC    0
          VFD    16/B.HCC    CC HEADER LENGTH IN BYTES READ
          VFD    16/B.HCC    CC HEADER LENGTH IN BYTES WRITTEN TO CM
          VFD    16/IOBUF+/HCC/P.DLEN ADDRESS OF LENGTH FIELD
          VFD    16/0        ADDED TO LENGTH IN HEADER
          VFD    16/URC.CR   CC RESPONSE CODE
          VFD    16/0        SET AT PROTOCOL NEGOTIATION
          LOC    *O

*
*         TCNH   DEFINES THE CHANNELNET HEADER
*

 TCNH     BSS    0
          LOC    0
          VFD    16/C.H802.3*8  CHANNELNET HEADER LENGTH IN BYTES READ
          VFD    16/C.H802.3*8  CHANNELNET HEADER LENGTH IN BYTES WRITTEN TO CM
          VFD    16/IOBUF+/H802.3/P.DLEN  ADDRESS OF LENGTH FIELD
          VFD    16/B.H802.3  ADDED TO LENGTH IN HEADER
          VFD    16/URC.RD   CHANNELNET RESPONSE CODE
          VFD    16/MAXLEN   CHANNELNET MAXIMUM LENGTH
          LOC    *O

 TBYTS    BSSZ   1           TOTAL NUMBER OF BYTES TO ALLOCATE CM BUFFERS FOR
 TCHFR    BSSZ   1           TOTAL NUMBER OF PP WORDS TO READ
 TIMA     BSSZ   1           MOST RECENT CLOCK VALUE
 TIMB     BSSZ   1           NORMAL FUNCTION TIMER
 UNIT     BSSZ   1           LOGICAL UNIT NUMBER
 WRRTY    BSSZ   1           DECREMENTED BY ONE EACH TIME A WRITE ERROR
*                            OCCURS. SET TO ZERO ON UNRECOVERED ERROR.



          IFEQ   SIM,1
 DATCNT   BSSZ   1           CHANNEL FRAMES IN PP BUFFER
          ENDIF
 D.       IFEQ   DEBUG,1
 BUFCNT   BSSZ   MAXBPD      TOTAL CM BUFFERS USED
 EMPBUF   BSSZ   MAXBPD      NUMBER OF TIMES BUFFER POOL WENT EMPTY
 FTOCNT   BSSZ   1           FUNCTION TIMEOUT COUNT
 HISTINX  BSSZ   1           FUNCTION HISTORY INDEX
 FUNHIST  BSSZ   8           FUNCTION HISTORY TABLE
 LSTFUNC  BSSZ   1           LAST FUNCTION CODE SAVED IN TABLE
 RECNT    BSSZ   1           READ ERROR COUNT
 WECNT    BSSZ   1           WRITE ERROR COUNT
 D.       ENDIF

*         TEMPORARY FOR S1 CHECKOUT
 ASAVE    BSSZ   2
 LRURMA   BSSZ   2

          TITLE  DCS - DETERMINE CURRENT STATE
**        DCS - DETERMINE CURRENT STATE
*
*         THIS IS THE MAIN ROUTINE OF THE PP. THIS ROUTINE
*         IS ENTERED WHEN THE ICA IS TO BE RESET. IT NOTIFIES
*         THE CPU OF ANY AVAILABILITY CHANGE AND CALLS THE
*         RESET PROCESSOR. IF THE RESET IS SUCCESSFULL IT
*         CALLS THE OPERATIONAL STATE PROCESSOR.
*
*         ENTRY  NONE
*
*         USER   NONE
*
*         CALLS  SAC PPR IDL SOR PIR OSP
          SPACE  4,10
 DCS      BSS    0           ENTRY
 DCS10    RJM    PPR         PROCESS PP REQUESTS
          RJM    IDL         IDLE STATE PROCESSOR
          RJM    SAC         SEND AVAILABILITY CHANGE
          RJM    PIR         PROCESS RESET
          NJN    DCS30       IF ERRORS
          RJM    SAC         SEND AVAILABILITY CHANGE
          RJM    OSP         OPERATIONAL STATE
          LDDL   STCHNG
          SBN    SC.OPER
          NJN    DCS30       IF STATE NOT CHANGING TO OPERATIONAL
          STDL   STCHNG      CLEAR STATE CHANGE
          LDN    ST.OPER
          STDL   LSTATE      UPDATE LAST STATE
          RJM    CSC         CHECK FOR STATE CHANGE OR BUSY
          NJN    DCS30       IF STATE CHANGE OR BUSY
          RJM    NCP         NEGOTIATE CHANNEL PROTOCOL
          NJN    DCS30       IF ERRORS
          LDN    SC.OPER
          STDL   STCHNG
          RJM    SAC         SEND AVAILABILITY CHANGE
          LDN    0
          STDL   STCHNG
          RJM    SOR         LOG OPERATIONAL MESSAGE
          NJN    DCS30       IF ERRORS
          RJM    OSP         OPERATIONAL STATE
 DCS30    UJK    DCS10
          TITLE  OSP - OPERATIONAL STATE PROCESSOR
**        OSP - OPERATIONAL STATE PROCESSOR
*
*         THIS ROUTINE PERFORMS PROCESSING FOR OPERATIONAL AND IDLE
*         STATE MONITORING THE STATUS OF THE ICA. WHILE THE ICA REMAINS
*         OPERATIONAL ALTERNATE BETWEEN READING/WRITING THE ICA
*         AND HONORING PP REQUESTS. RETURNING WHEN THE ICA OR PP
*         STATE CHANGES.
*
*         ENTRY  NONE
*
*         USES   NONE
*
*         CALLS  FAN IOS PPR CSC CSD DFC PRD PUR SNF SSM
*
          SPACE  4,10
 OSP      SUBR               ENTRY/EXIT
          RJM    IOS         INITIALIZE OPERATIONAL STATE
          NJN    OSPX        IF ERRORS
 OSP10    RJM    PPR         PROCESS PP REQUESTS
 OSP20    RJM    SNF         SEND NORMAL FUNCTION
          NJN    OSPX        IF ERRORS
          RJM    CSC         CHECK IF STATE CHANGE
          NJN    OSP30       IF STATE CHANGE
          RJM    PRD         PROCESS READ
          RJM    CSC         CHECK IF STATE CHANGE
          NJN    OSP30       IF STATE CHANGE
          RJM    CSD         CHECK FOR SEND DATA
          NJN    OSP25       IF SEND DATA NOT INDICATED
          RJM    DFC         DETERMINE FLOW CONTROL
          NJN    OSP30       IF ERRORS
          RJM    PUR         PROCESS UNIT REQUEST
 OSP25    RJM    CSC         CHECK IF STATE CHANGE
          ZJN    OSP10       IF NO STATE CHANGE
 OSP30    UJK    OSPX        EXIT
          TITLE  DIA - DIAGNOSTIC STATE PROCESSOR
**        DIA - DIAGNOSTIC STATE PROCESSOR
*
*         THIS ROUTINE PERFORMS A NUMBER OF DIAGNOSTIC TESTS
*         TO DETERMINE THE CONDITION OF THE ICA AND THE CHANNEL.
*         DIA IS ENTERED IN THE RESET STATE AFTER PHASE ONE OF
*         THE ONBOARD DIAGNOSTICS HAVE RUN WITHOUT ERROR.
*         AFTER RUNNING A CONFIDENCE TEST TO VERIFY THE CHANNEL IS
*         FUNCTIONING AND A CHANNEL TIMEOUT CHECK TO VERIFY THE
*         CHANNEL ACTIVE TIMEOUT THE DIAGNOSTIC SEQUENCE IN EXECUTED.
*
*
*         ENTRY  NONE
*
*         EXIT   A = 0 IF NO ERRORS
*                A <> 0 IF ERRORS
*
*         USES   P5 P6
*
*         CALLS  DIC DAC DSC FAN GST BTE STE ERR GRB FAW STB DVE RDB
*                DDR DRD DSR
*
          SPACE  4,10
 DIA      SUBR               ENTRY/EXIT
          RJM    DIC         RUN INTERFACE CONFIDENCE CHECK
          NJN    DIAX        EXIT IF ERROR
          RJM    DAC         RUN CHANNEL TIMEOUT CHECK
*         ERRORS IN CHANNEL ACTIVE TIMEOUT ARE NOT FATAL

          RJM    DSC         RUN GENERAL STATUS REJECT CHECK
*         ERRORS IN REJECT CHECK ARE NOT FATAL

 DIA15    LDN    FTRY
          STML   ERRR        RESET RETRY COUNT
          LDC    F.EDIAG     ENTER DIAGNOSTIC STATE
          RJM    FAN
          NJN    DIAX        EXIT ON FUNCTION TIMEOUT
          LDN    77B
          STDL   LSTATE      DONT CHECK STATE
          RJM    GST         GET GENERAL STATUS
          PJN    DIA17       IF NOT BUSY
          RJM    BTE         LOG BUSY TIMEOUT ERROR
          LDN    1           EXIT
 DIA17    NJN    DIAX        EXIT IF READ GENERAL STATUS ERROR
          LDDL   GNSTAT
          SHN    -S.SB1
          LPN    3           GET STATE
          SBN    ST.DIAG
          ZJN    DIA19       IF PROPER STATE SWITCH
 DIA18    LDN    SC.PPD
          STDL   STCHNG      DOWN ICA
          LDN    ST.DIAG
          RJM    STE         LOG STATE TRANSITION ERROR
          LDN    1
          UJK    DIAX        EXIT WITH ERROR

 DIA19    LDN    ST.DIAG
          STDL   LSTATE      UPDATE LAST STATE
          LDDL   GNSTAT
          SHN    17-S.GE
          MJN    DIA18       IF GENERAL STATUS ERRORS
          LDML   BPDSIZE-1,NUMBP   GUARANTEE A LARGE BUFFER
          STML   TBYTS
 DIA20    RJM    GRB         GET A LARGE BUFFER
          ZJK    DIA20       IF NO BUFFER OBTAINED
          LRDL   DATADD      LOAD R REGISTER
 DIA25    LDC    F.RDIAG     READ DIAGNOSTIC COMMAND FUNCTION
          RJM    FAW
          NJK    DIA60       IF ERROR ON FUNCTION
          SIMM
          IAN    CHN
          STML   STBI        SAVE COMMAND
          RJM    WCI         WAIT FOR CHANNEL INACTIVE
          NJN    DIA30       IF CHANNEL INACTIVE
          LDK    /RS/K.LRDC
          RJM    CAE         LOG CHANNEL ACTIVE ERROR
          LDN    SC.PPD
          STDL   STCHNG      DOWN ICA
          RJM    SLM         SEND LOG MESSAGE
          UJK    DIA60       EXIT

 DIA30    LDN    /RS/K.LRDC
          RJM    DEC         CHECK FOR ERRORS
          NJK    DIA57       IF ERRORS CHECK FOR RETRY

          LDC    DC.END
          SBML   STBI
          ZJK    DIA50       EXIT ON END COMMAND
          LDC    DCT-2       COMMAND TABLE ADDRESS - 2
          RJM    STB         SEARCH COMMAND TABLE
          NJN    DIA40       PROCESSOR FOUND
          LDML   STBI        GET ILLEGAL COMMAND
          STML   LRS+/RS/P.DATA1
          LDK    /RS/K.LRDC
          RJM    DVE         LOG DATA VERIFICATION ERROR
          UJN    DIA60       EXIT WITH ERROR

 DIA40    STDL   P6          PROCESSOR ADDRESS
          RJM    0,P6        PROCESS COMMAND
          NJN    DIA57       IF ERRORS CHECK FOR RETRY
          UJK    DIA25       CONTINUE

 DIA50    RJM    RDB         RETURN DIAGNOSTIC BUFFER
          LDN    0
 DIA55    UJK    DIAX        EXIT

 DIA57    LDDL   STCHNG
          NJN    DIA60       IF STATE CHANGING
          RJM    RDB         RETURN DIAGNOSTIC BUFFER
          LDML   ERRR
          NJK    DIA15       RESTART DIAGNOSTICS
          UJN    DIA70       EXIT

 DIA60    RJM    RDB         RETURN DIAGNOSTIC BUFFER
 DIA70    DCN    CHN+40B     DISCONNECT CHANNEL
          TRACE
          LDN    1           ERROR RETURN
          UJN    DIA55       EXIT
          SPACE 4,10
 DCT      CON    DC.UNFW,DDR DIAGNOSTIC UNFORMATTED WRITE
          CON    DC.FW,DDR   DIAGNOSTIC FORMATTED WRITE
          CON    DC.READ,DRD DIAGNOSTIC READ
          CON    DC.ECHO,DSR DIAGNOSTIC STATUS RETURN
          CON    0
          TITLE  IDL - IDLE STATE PROCESSOR
**        IDL - IDLE STATE PROCESSOR
*
*         THIS ROUTINE IS ENTERED ANY TIME THE ICA HAS BEEN
*         DOWNED OR RESET AND WHEN AN IDLE COMMAND IS RECIEVED FROM THE
*         CPU. THIS ROUTINE WILL CONTINUE TO PROCESS PP COMMANDS
*         UNTIL THE ICA IS NO LONGER DOWN, AND A RESUME COMMAND
*         IS RECIEVED FROM THE CPU. ON ENTRY THE CHANNEL INTERLOCK
*         IS RELEASED AND ON EXIT IT IS AGAIN LOCKED.
*
*         ENTRY  NONE
*
*         USES   NONE
*
*         CALLS  CCK PPR SCK
          SPACE  4,10
 IDL      SUBR               ENTRY/EXIT
          LDML   CHLOCK
          ZJN    IDL10       IF CHANNEL NOT LOCKED
          RJM    CCK         CLEAR CHANNEL LOCK
 IDL10    RJM    PPR         PROCESS PP REQUESTS
          LDML   IDLE
          NJN    IDL10       IF STILL IN IDLE STATE
          LDN    SC.PPD
          SBDL   STCHNG
          ZJN    IDL10       IF ICA DOWN
 IDL20    RJM    SCK         SET CHANNEL LOCK
          NJN    IDL20       RETRY IF NOT LOCKED
          UJN    IDLX        EXIT
          TITLE  PIR - PROCESS ICA RESET
**        PIR - PROCESS ICA RESET.
*
*         THIS ROUTINE IS ENTERED WHEN THE PP REQUESTS A RESET OR
*         WHEN THE ICA HAS RESET ITSELF.
*         CONTROL CONTINUES WITHIN THIS ROUTINE UNTIL THE ICA
*         HAS HAD DIAGNOSTICS RUN, BEEN LOADED, DUMP TAKEN ,
*         AND HAS BEEN CONFIGURED.
*
*
*         ENTRY  STCHNG = SC.PPR IF PP REQUESTED RESET
*                         SC.ICA IF ICA RESET
*
*         EXIT   A = 0 IF NO ERRORS
*                A <> 0 IF ERRORS
*
*         USES   T1
*
*         CALLS  BTE DIA DUM FAN GST IGS LOM PAUS RBE RSE SEA SIP
*                SLM SOR SRU STE
*
          SPACE  4,10
 PIR      SUBR               ENTRY/EXIT
          LDN    FTRY
          STML   ERRR        RESET RETRY COUNT
          LDDL   STCHNG      RESET TYPE
          SBN    SC.ICA
          ZJN    PIR10       IF RESET BY ICA
          DCN    CHN+40B     DISCONNECT CHANNEL
          TRACE
 PIR05    LDC    F.RESET
          RJM    FAN         RESET ICA
          NJN    PIRX        EXIT IF ERRORS
          LDN    77B
          RJM    PAUS        PAUSE FOR RESET
 PIR10    LDML   RSBUSY,ICATDDP
          STDL   BUSYMP
          LDN    FTRY        RESET RECOVERY COUNTERS
          STML   RDRTY
          STML   WRRTY
          LDN    0           CLEAR COUNTERS
          STDL   STCHNG
          STDL   ERRCNT
          STML   OSOSI
          STML   NUMPRI
          STML   NXTREC
          LDN    77B
          STDL   LSTATE      DONT CHECK STATE
          RJM    GST         GET GENERAL STATUS
          PJN    PIR20       JUMP IF NOT BUSY
          RJM    RBE         LOG RESET BUSY TIMEOUT
          LDN    1
          UJK    PIRX        EXIT WITH ERROR

 PIR20    NJK    PIRX        IF ERRORS GETTING STATUS
          LDN    1
          STDL   BUSYMP      RESET BUSY MULTIPLIER
          LDDL   GNSTAT
          SHN    -S.SB1
          LPN    3           GET STATE
          ZJN    PIR22       IF RESET
          SOML   ERRR
          ZJN    PIR21       IF UNRECOVERED
          SBN    FTRY-1
          NJK    PIR05       IF NOT FIRST ERROR
          LDDL   GNSTAT
          STML   GSSAVE      SAVE FOR LOGGING
          UJK    PIR05       RETRY RESET FUNCTION

 PIR21    LDN    SC.PPD
          STDL   STCHNG      DOWN ICA
 PIR22    LDML   ERRR
          SBN    FTRY
          ZJN    PIR25       IF NO ERRORS
          LDML   ERRR
          RJM    SRU         SET RECOVERY STATUS
          LDDL   GNSTAT
          STML   RESST       SAVE GENERAL STATUS
          LDML   GSSAVE
          STDL   GNSTAT      SET STATUS FOR LOGGING
          LDN    ST.RESET
          RJM    STE         LOG STATE TRANSITION ERROR
          LDML   RESST
          STDL   GNSTAT      RESTORE STATUS
          LDDL   STCHNG
          NJK    PIRX        ERROR EXIT IF DOWN

 PIR25    STDL   LSTATE      SET LAST STATE TO RESET
          LDDL   GNSTAT
          STML   RESST       SAVE RESET STATUS
          SHN    17-S.GE
          PJN    PIR40       IF NOT ERRORS
          RJM    RSE         LOG RESET STATUS ERRORS
          LDN    1
          UJK    PIRX        ERROR EXIT

 PIR40    LDK    /RS/K.LICAR LOG RESET
          STML   LRS+/RS/P.ERRID
          LDN    REC.IM
          STML   LRS+/RS/P.RETSUC INFORMATIVE MESSAGE
          RJM    IGS         INCLUDE GENERAL STATUS
          RJM    SLM         SEND LOG MESSAGE

          RJM    DIA         RUN DIAGNOSTICS
          NJK    PIRX        EXIT IF ERRORS
          LDC    F.EIDLE     ENTER IDLE STATE
          RJM    FAN
          NJK    PIRX        EXIT IF ERRORS
          LDN    77B
          STDL   LSTATE      DONT CHECK STATE
          RJM    GST         GET STATUS
          ZJN    PIR50       IF NO GST ERRORS
          PJK    PIRX        EXIT IF GST ERRORS
          RJM    BTE         LOG BUSY ERROR
          LDN    1
          UJK    PIRX        ERROR EXIT

 PIR50    LDDL   GNSTAT
          SHN    -S.SB1
          LPN    3           GET STATE
          STDL   LSTATE      SAVE STATE
          SBN    ST.IDLE
          ZJN    PIR55       IF STATE CHANGED OK
 PIR52    LDN    SC.PPD
          STDL   STCHNG      DOWN ICA
          LDN    ST.IDLE
          RJM    STE         LOG STATE TRANSITION ERROR
          LDN    1
          UJK    PIRX        ERROR EXIT

 PIR55    LDDL   GNSTAT
          SHN    17-S.GE
          MJN    PIR52       IF GENERAL STATUS ERRORS
          RJM    LOM         LOAD CONTROLWARE TO ICA
          NJK    PIRX        IF ERRORS ON LOAD
          LDDL   GNSTAT
          SHN    -S.SB1
          LPN    3
          STDL   LSTATE
          LDN    1
          STML   INIT        SET PP INITIALIZED
          LDML   CONFIG,ICATDDP
          STDL   T1
          RJM    0,T1        SEND CONFIGURARION OR ETHERNET ADDRESS
          NJN    PIR70       EXIT IF ERRORS
          LDN    SC.AV
          STDL   STCHNG
          LDN    0
 PIR70    UJK    PIRX        EXIT RESET PROCESS
          TITLE  DIAGNOSTIC STATE ROUTINES
          SPACE  4,12
**        CEE - CHANNEL EMPTY ERROR.
*
*         THIS ROUTINE WILL DISCONNECT THE CHANNEL AND
*         LOG AN EMPTY CHANNEL ERROR.
*
*         ENTRY  (A) = OPERATION TYPE.
*
*         CALLS  SSC.
          SPACE  4,10
 CEE      SUBR               ENTRY/EXIT
          DCN    CHN+40B     DISCONNECT CHANNEL
          STML   LRS+/RS/P.OPTP STORE OPERATION TYPE
          LDK    /RS/K.LOF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDC    /RS/K.LSCE
          RJM    SSC         LOG SYMPTOM CODE
          UJN    CEEX        EXIT
          SPACE  4,12
**        CFE - CHANNEL FULL ERROR.
*
*         THIS ROUTINE WILL DISCONNECT THE CHANNEL AND
*         LOG A CHANNEL FULL ERROR.
*
*         ENTRY  (A) = OPERATION TYPE.
*
*         CALLS  SSC.
          SPACE  4,10
 CFE      SUBR               ENTRY/EXIT
          DCN    CHN+40B     DISCONNECT CHANNEL
          STML   LRS+/RS/P.OPTP   STORE OPERATION TYPE
          LDK    /RS/K.LOF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDC    /RS/K.LSCF
          RJM    SSC         LOG SYMPTOM CODE
          UJN    CFEX        EXIT
          SPACE  4,12
**        CIE - CHANNEL INACTIVE ERROR.
*
*         THIS ROUTINE LOGS A CHANNEL INACTIVE ERROR.
*
*         ENTRY  (A) = OPERATION TYPE.
*
*         CALLS  SSC.
          SPACE  4,10
 CIE      SUBR               ENTRY/EXIT
          STML   LRS+/RS/P.OPTP   STORE OPERATION TYPE
          LDK    /RS/K.LOF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDC    /RS/K.LSCD
          RJM    SSC         LOG SYMPTOM CODE
          UJN    CIEX        EXIT
          SPACE  4,10
**        DAC - DIAGNOSTIC ACTIVE CHANNEL TIMEOUT
*
*         THIS ROUTINE WILL TEST THE ABILITY OF THE ICA
*         TO TIME OUT AN ACTIVE CHANNEL.
*
*         ENTRY - NONE
*
*         EXIT  - (A) = 0 IF NO ERRORS
*                 (A) <> 0 IF ERRORS
*
*         USES   T2
*
*         CALLS  FAN PAUS CAE SLM GST IGS SSC
*
          SPACE  4,10
 DAC20    DCN    CHN+40B     DISCONNECT
          TRACE
          LDK    /RS/K.LCAT
          RJM    CAE         ERROR CHANNEL ACTIVE
 DAC30    RJM    SLM         SEND LOG MESSAGE
          LDN    1
          UJN    DACX        RETURN

 DAC40    LDN    0           SET STATUS

 DAC      SUBR               ENTRY/EXIT
          LDML   INIT
          NJK    DAC40       IF NOT FIRST RESET
          LDC    F.CHAATC    FUNCTION ICA FOR TIMEOUT TEST
          RJM    FAN
          NJN    DACX        EXIT IF ERRORS
          ACN    CHN
          LDN    9           PAUSE A TOTAL OF 2.1 SECONDS
          STDL   T2
 DAC10    LCN    0
          RJM    PAUS        PAUSE 262 MILLS
          SODL   T2
          NJN    DAC10       CONTINUE TO PAUSE
          SIMM   DACX
          AJM    DAC20,CHN   CHANNEL SHOULD BE INACTIVE
          RJM    GST         GET GENERAL STATUS
          NJK    DACX        CANT GET GENERAL STATUS
          LDDL   GNSTAT
          SHN    0-S.GE
          ERRNZ  S.GE-15     CODE ASSUMES VALUE
          ZJK    DACX        IF NO ERRORS
          RJM    IGS         INCLUDE GENERAL STATUS
          LDN    /RS/K.LCAT
          STML   LRS+/RS/P.OPTP OPERATION TYPE
          LDN    /RS/K.LOF
          STML   LRS+/RS/P.ERRID STORE ERROR ID
          LDK    /RS/K.LSGSE
          RJM    SSC         SET SYMPTOM CODE
          UJK    DAC30       LOG ERROR
          SPACE  4,10
**        DIC - DIAGNOSTIC CONFIDENCE TEST
*
*         THIS ROUTINE PERFORMS A BASIC TEST OF THE ICI/ICA
*         INTERFACE. THIS IS THE FIRST TEST RUN DURING RESET
*         AFTER DIAGNOSTICS PHASE 1 COMPLETE.
*
*         ENTRY - NONE
*
*         EXIT  - A = 0 IF NO ERRORS
*                  A <> 0 IF ERRORS
*
*         USES   P1 P2
*
*         CALLS  FAW ERR DVE FAN CIE CEE CFE SLM
*
          SPACE  4,10
 DIC      SUBR               ENTRY/EXIT
          LDN    FTRY
          STML   ERRR        RESET RETRY COUNTER
 DIC05    LDC    F.RCC       FUNCTION FOR READ CONFIDENCE TESTS
          RJM    FAW
          NJN    DICX        EXIT IF ERRORS
          SIMM   DIC20
          IAN    CHN         READ ONE WORD
          STDL   P1
          LDC    WTFULL*1000
          RJM    PAUS        PAUSE 1 MILL CHANNEL
          LDN    /RS/K.LREAD MUST BE FULL NOW
          IJM    DIC70,CHN   CHANNEL NOT ACTIVE
          EJM    DIC75,CHN   CHANNEL NOT FULL
          IAN    CHN         READ NEXT WORD
          STDL   P2
 DIC20    RJM    WCI         WAIT CHANNEL NOT ACTIVE
          NJN    DIC30       IF CHANNEL INACTIVE
          LDK    /RS/K.LREAD
          UJK    DIC67       CHANNEL ACTIVE ERROR

 DIC30    LDN    /RS/K.LREAD
          RJM    DEC         CHECK FOR ERRORS
          ZJN    DIC55       IF NO ERRORS
          LDDL   STCHNG
          NJK    DICX        EXIT IF DOWN OR RESET
          UJK    DIC05       IF MORE RETRY'S

 DIC55    LDC    D.DATA1     EXPECTED FIRST DATA WORD
          SBDL   P1
          NJN    DIC57       IF ERROR
          LDC    D.DATA2     EXPECTED SECOND DATA WORD
          SBDL   P2          A = 0 IF DATA OK
          ZJN    DIC59       IF DATA OKAY
 DIC57    LDDL   P1          ERROR DATA WORD 1
          STML   LRS+/RS/P.DATA1
          LDDL   P2          ERROR DATA WORD 2
          STML   LRS+/RS/P.DATA2
          LDK    /RS/K.LRCC
          RJM    DVE         LOG DATA VERIFICATION ERROR
          LDN    1
          UJK    DICX        ERROR EXIT

 DIC59    LDN    FTRY
          STML   ERRR        RESET RETRY COUNTER
 DIC60    LDC    F.WCC
          RJM    FAN         FUNCTION WRITE CONFIDENCE TEST
          NJK    DICX        EXIT IF ERRORS
          LDN    /RS/K.LWRT
          SIMM   DIC65
          ACN    CHN         ACTIVATE CHANNEL
          IJM    DIC70,CHN   NOT ACTIVE
          LDDL   P1          FIRST DATA WORD
          OAN    CHN
          LDC    WTEMPTY*1000
          RJM    PAUS        PAUSE 1 MILL CHANNEL
          LDK    /RS/K.LWRT  MUST BE EMPTY NOW
          FJM    DIC80,CHN   JUMP IF CHANNEL FULL
          IJM    DIC70,CHN   JUMP IF CHANNEL NOT ACTIVE
          LDDL   P2          SECOND DATA WORD
          OAN    CHN
          LDC    WTEMPTY*1000
          RJM    PAUS        PAUSE 1 MILL CHANNEL
          LDN    /RS/K.LWRT  MUST BE EMPTY NOW
          FJM    DIC80,CHN   JUMP IF CHANNEL FULL
          IJM    DIC70,CHN   JUMP IF CHANNEL NOT ACTIVE
          DCN    CHN+40B     DISCONNECT CHANNEL
          TRACE
 DIC65    RJM    DEC         CHECK FOR ERRORS
          ZJK    DICX        EXIT IF NO ERRORS
          LDDL   STCHNG
          NJK    DICX        EXIT IF DOWN OR RESET
          UJK    DIC60       RETRY

 DIC67    RJM    CAE         LOG CHANNEL ACTIVE
          UJK    DIC82       LOG ERROR AND DOWN ICA

 DIC70    RJM    CIE         LOG CHANNEL INACTIVE
          UJN    DIC82       LOG ERROR AND DOWN ICA

 DIC75    RJM    CEE         LOG CHANNEL EMPTY
          UJN    DIC82       LOG ERROR AND DOWN ICA

 DIC80    RJM    CFE         LOG CHANNEL FULL
 DIC82    LDN    SC.PPD
          STDL   STCHNG      DOWN ICA
          DCN    CHN+40B     DISCONNECT CHANNEL
          TRACE
          RJM    SLM         SEND LOG MESSAGE
          LDN    1
          UJK    DICX        EXIT
          SPACE  4,10
**        DRD - DIAGNOSTIC READ DATA
*
*         THIS ROUTINE WILL CHECK FOR -DATA AVAILABLE- AND THEN
*         ATTEMPT TO INPUT 1500 BYTES.
*
*         ENTRY  DATADD = 2 WORD FORMATTED CM BUFFER ADDRESS
*
*         EXIT   (A) = 0, IF NO ERRORS,
*                (A) <> 0, IF TRANSFER COULD NOT BE COMPLETED
*                IOCNT = NUMBER OF CHANNEL FRAMES TRANSFERRED.
*
*         USES   T1
*
*         CALLS  ERR GST NDA SLM FAW
          SPACE  4,10
 DRD      SUBR               ENTRY/EXIT
          RJM    GST         GET STATUS
          NJN    DRDX        ERROR IF STATE CHANGED
          LDDL   GNSTAT
          SHN    17-S.DATAV
          MJN    DRD10       IF DATA  AVAILABLE
          LDN    CE.RD       READ CONTENT ERROR
          RJM    SCE         LOG ERROR
          LDN    1
          UJN    DRDX        EXIT WITH ERROR

 DRD10    LDC    F.READ
          RJM    FAW         FUNCTION READ
          NJN    DRDX        EXIT ON ERROR
          LDC    MAXDIAG     PP WORDS PER BUFFER
          STDL   IOCNT
          LDDL   DATADD+1    CM FWA OF BUFFER
          SIMM   DRD20
          CHCM   IOCNT,CHN   READ TO CM
 DRD20    LDC    MAXDIAG     BUFFER SIZE
          SBDL   IOCNT
          STML   DDRL        SAVE TOTAL READ COUNT
          LDDL   IOCNT
          NJN    DRD30       IF THE ICA TERMINATED THE READ
*                            THE CHANNEL SHOULD BE INACTIVE
          LDC    WTDEACT*1000
          RJM    PAUS        PAUSE FOR ICA
          DCN    CHN+40B     IF NOT DISCONNECT
          TRACE
          LDC    WTDEACT*1000
          RJM    PAUS        PAUSE FOR ICA
 DRD30    RJM    WCI         WAIT CHANNEL NOT ACTIVE
          NJN    DRD40       IF NOT ACTIVE
          LDK    /RS/K.LREAD
          RJM    CAE         LOG ACTIVE CHANNEL ERROR
          LDN    SC.PPD
          STDL   STCHNG      DOWN ICA
          RJM    SLM         SEND LOG MESSAGE
          LDN    1
          UJK    DRDX        ERROR EXIT

 DRD40    LDK    /RS/K.LREAD
          RJM    DEC         CHECK FOR ERRORS
          UJK    DRDX        EXIT
          SPACE  4,10
**        DSC - DIAGNOSTIC STATUS CHECK.
*
*         THIS ROUTINE WILL TEST THE ABILITY OF THE ICA TO IGNORE A
*         GENERAL STATUS REQUEST WHEN A READ HAS NOT COMPLETED.
*
*         ENTRY - NONE
*
*         EXIT  - (A) = 0 IF NO ERRORS
*                 (A) <> 0 IF ERRORS
*
*         USES   T2
*
*         CALLS  FAG FAN SLM SSC
*
          SPACE  4,10
 DSC20    LDN    0
          STML   FAGDEM      ENABLE ERROR MESSAGE LOGGING BY *FAG*
 DSC30    LDN    1           SET STATUS
          UJN    DSCX        RETURN

 DSC40    LDN    0           SET STATUS

 DSC      SUBR               ENTRY/EXIT
          LDML   DSCFLAG,ICATDDP
          ZJN    DSCX        IF TEST IS NOT TO BE RUN
          LDML   INIT
          NJN    DSC40       IF NOT FIRST RESET
          LDK    F.GSRR      FUNCTION ICA FOR STATUS TEST
          RJM    FAN
          NJN    DSCX        EXIT IF ERRORS
          AOML   FAGDEM      DISABLE ERROR MESSAGE LOGGING BY *FAG*
          RJM    FAG         FUNCTION FOR GENERAL STATUS
          NJN    DSC20       EXIT IF UNRECOVERABLE ERRORS
*         LDN    0
          STML   FAGDEM      ENABLE ERROR MESSAGE LOGGING BY *FAG*
          LDDL   T1
          SBN    FTRY-1
          ZJN    DSCX        IF GENERAL STATUS RETURNED ON FIRST RETRY
          LDK    /RS/K.LGSRR
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDK    /RS/K.LSCD
          RJM    SSC         LOG SYMPTOM CODE
          RJM    SLM         SEND LOG MESSAGE
          UJK    DSC30       EXIT
          SPACE  4,10
**        DSR - DIAGNOSTIC STATUS RETURN
*
*         THIS ROUTINE WILL READ THE GENERAL STATUS AND RETURN
*         A FUNCTION EQUAL TO THE GENERAL STATUS READ.
*
*         ENTRY - NONE
*
*         EXIT - (A) = 0 IF NO ERRORS
*                  (A) <> 0 IF ERRORS
*
*         USES   NONE
*
*         CALLS  GST STB SCE FAN DEC
*
          SPACE  4,10
 DSR      SUBR               ENTRY/EXIT
          RJM    GST         CHECK STATE AND GET GENERAL STATUS
          NJN    DSRX        EXIT IF ERRORS
          LDDL   GNSTAT
          STML   STBI
          LDC    DSRT-2      COMMAND TABLE ADDRESS
          RJM    STB         SEARCH COMMAND TABLE
          NJN    DSR10       IF FUNCTION FOUND
          LDN    CE.ES       STATUS CONTENT ERROR
          RJM    SCE         LOG ERROR
          LDN    1
          UJN    DSRX

 DSR10    RJM    FAN         EXECUTE FUNCTION
          NJN    DSRX        EXIT ON ERROR
          LDK    /RS/K.LSR
          RJM    DEC         CHECK STATUS ERRORS
          UJN    DSRX        EXIT

*         TABLE OF LEGAL DATA RETURNED IN GENERAL STATUS

 DSRT     CON    S.DATA0,F.RET0
          CON    S.DATA1,F.RET1
          CON    0
          SPACE  4,10
**        DDR - DIAGNOSTIC DATA RETURN
*
*         THIS ROUTINE WILL CHECK FOR -SEND DATA- AND ATTEMPT
*         TO OUTPUT THE DATA IN THE PP BUFFER.
*         THIS ROUTINE IS USED FOR BOTH THE OUTPUT AND WRITE
*         FUNCTIONS. TABLE DDRT DETERMINES WHICH IS BEING USED.
*
*         ENTRY  IOCNT = NUMBER OF CHANNEL FRAMES TO TRANSFER.
*                STBI = DIAGNOSTIC COMMAND.
*
*         EXIT   (A) = 0, IF NO ERRORS,
*                (A) <> 0, IF TRANSFER COULD NOT BE COMPLETED.
*
*         USES   NONE
*
*         CALLS  GST NSD SLM STB FAN ERR SIT
*
          SPACE  4,10
 DDR      SUBR               ENTRY/EXIT
          RJM    GST         GET GENERAL STATUS
          NJN    DDRX        CANT READ OR STATE CHANGED
          LDDL   GNSTAT
          SHN    17-S.SEND
          MJN    DDR10       IF SEND DATA  STATUS
          LDC    DDRE-2      ERROR CODE TABLE
          RJM    STB         SEARCH TABLE
          RJM    SCE         LOG ERROR
          LDN    1
          UJN    DDRX        EXIT WITH ERROR

 DDR10    LDC    DDRT-2      WRITE TYPE TABLE
          RJM    STB         SEARCH TABLE
          RJM    FAN         FUNCTION WRITE/OUTPUT MESSAGE
          NJN    DDRX        EXIT ON FUNCTION REJECT
          SIMM   DDR30
          LDML   DDRL        SET BUFFER SIZE
          STDL   IOCNT
          ACN    CHN         ACTIVATE CHANNEL
          LDDL   DATADD+1    CM FWA OF BUFFER
          CMCH   IOCNT,CHN   WRITE LAST BUFFER READ
 DDR30    LDK    /RS/K.LWRT
          AJM    DDR40,CHN   IF ACTIVE
          RJM    CIE         LOG CHANNEL INACTIVE ERROR
 DDR35    LDN    SC.PPD
          STDL   STCHNG      DOWN ICA
          RJM    SLM         SEND LOG MESSAGE
          LDN    1
          UJK    DDRX        EXIT

 DDR40    LDC    WTEMPTY*2000
 DDR50    EJM    DDR60,CHN   IF CHANNEL EMPTY
          SBN    1
          NJN    DDR50       IF NOT TIMED OUT
          LDK    /RS/K.LWRT
          RJM    CFE         LOG CHANNEL FULL ERROR
          UJN    DDR35       DOWN ICA AND LOG ERROR

 DDR60    DCN    CHN+40B     DISCONNECT
          TRACE
          RJM    DEC         CHECK FOR ERRORS
          NJK    DDRX        IF ERROR EXIT
          LDDL   IOCNT
          ZJK    DDRX        IF NO ERRORS
          LDK    /RS/K.LWRT
          RJM    SIT         LOG INCOMPLETE TRANSFER
          UJK    DDR35       DOWN ICA AND SEND MESSAGE
          SPACE  2
 DDRL     CON    0           BUFFER SIZE
          SPACE  2
 DDRT     CON    DC.UNFW,F.OUTPUT
          CON    DC.FW,F.WRITE
          CON    0
          SPACE  2
 DDRE     CON    DC.UNFW,CE.WUM
          CON    DC.FW,CE.WFM
          CON    0
          SPACE  4,10
**        RDB - RETURN DIAGNOSTIC BUFFER
*
*         THIS ROUTINE WILL RETURN THE DIAGNOSTIC BUFFER
*
*         ENTRY  NONE
*
*         USES   NONE
*
*         CALLS  USR
          SPACE  4,10
 RDB      SUBR               ENTRY/EXIT
          LDN    URC.DE
          STDL   UNSC
          LDN    /RS/C.T1STAT*8+8+8
          STML   RS+/RS/P.RESPL SET RESPONSE LENGTH
          RJM    USR         SEND UNSOLICITED RESPONSE
          UJK    RDBX        EXIT
          SPACE  4,10
**        SCK - SET CHANNEL LOCK.
*
*         SETS THE CHANNEL LOCK IN THE CM CHANNEL TABLE.
*
*         ENTRY  (CM.CHAN) = START OF 3 WORDS
*                  THAT CONTAIN A REFORMATTED CM ADDRESS
*                  POINTING TO THE CHANNEL TABLE.
*
*                (CHAN) = CHANNEL NUMBER.
*
*         EXIT    (A) = 0 IF LOCK SET.
*                 (A) <> 0 IF LOCK COULD NOT BE SET.
*
*         USES   T5, T7.
*
*         CALLS  SLK.
          SPACE  4,10
SCK       SUBR               ENTRY/EXIT
          LDK    CM.CHAN
          STDL   T7          SET POINTER TO CHANNEL TABLE
          LDML   CHAN
          STDL   T5          SET CHANNEL NUMBER AS INDEX
          RJM    SLK         SET THE LOCK ON THAT CM WORD
          NJN    SCKX        EXIT IF LOCK NOT SET
          LCN    0
          STML   CHLOCK      SET CHANNEL LOCKED FLAG
          LDN    0
          UJK    SCKX        EXIT
          SPACE  4,10
**        WCI - WAIT FOR CHANNEL INACTIVE
*
*         THIS ROUTINE WILL WAIT FOR *WTDEACT* MILLISECONDS FOR
*         THE CHANNEL TO GO INACTIVE.
*
*         ENTRY  NONE
*
*         EXIT   A = 0 IF CHANNEL ACTIVE.
*                A <> 0 IF CHANNEL INACTIVE.
*
*         USES   NONE
*
*         CALLS  NONE
          SPACE  4,10
 WCI      SUBR               ENTRY/EXIT
          LDC    WTDEACT*1200  WAIT FOR CHANNEL NOT ACTIVE
 WCI10    IJM    WCIX,CHN    EXIT IF NOT ACTIVE
          SBN    1
          NJN    WCI10       IF NOT TIMED OUT
          UJK    WCIX        EXIT CHANNEL ACTIVE TO LONG
          TITLE  IDLE STATE ROUTINES - LOADING
          EJECT
**        DLC - DECREMENT LARGE COUNT
*
*         THIS ROUTINE WILL DECREMENT THE TWO WORD I/O
*         COUNT AT *LIOC* BY *ERRCNT*
*
*         ENTRY  LIOC  =  NUMBER OF PP WORDS REMAINING
*                ERRCNT  =  MAXIMUM NUMBER TO OUTPUT IN ONE REQUEST
*
*         EXIT   LIOC  = PP WORDS REMAINING AFTER I/O
*                ERRCNT  = BLOCK SIZE TO USE
*
          SPACE  4,10
 DLC      SUBR               ENTRY/EXIT
          LDML   LIOC
          NJN    DLC20       IF COUNT > 200000
          LDML   LIOC+1
          SBDL   ERRCNT
          ZJN    DLC15       IF EQUAL
          PJN    DLC30       IF MORE THAN 1 BLOCK
 DLC15    LDML   LIOC+1
          STDL   ERRCNT       LAST BLOCK SIZE
          LDN    0
          STML   LIOC+1
          UJN    DLCX        EXIT

 DLC20    LDML   LIOC+1
          SBDL   ERRCNT
          PJN    DLC30       DONT DECREMENT UPPER WORD
          ADC    200000B
          STML   LIOC+1
          LDML   LIOC
          SBN    1
          STML   LIOC
          UJN    DLC40       EXIT

 DLC30    STML   LIOC+1
 DLC40    UJK    DLCX        EXIT
          SPACE  4,10
**        LOM - LOAD MEMORY
*
*         WRITE ICA CONTROLWARE TO ICA.
*
*         ENTRY  CM.LOAD - CM.LOAD+3 = LENGTH/RMA
*
*         EXIT  A = 0 IF NO ERRORS
*                <> 0 IF ERRORS
*
          SPACE  4,10
 LOM      SUBR               ENTER/EXIT
          LDN    FTRY
          STML   ERRR        RESET RETRY COUNTER
 LOM10    LDML   LOADFC,ICATDDP  FUNCTION FOR LOAD MEMORY
          RJM    FAN
          NJN    LOMX        EXIT IF ERRORS
          SIMM   LOM20
          ACN    CHN         ACTIVATE CHANNEL
 LOM20    LDN    0
          STDL   ERRT1
          STDL   CML         CLEAR INDEX
          LDML   LFLEN
          STML   LIOC
          LDML   LFLEN+1
          STML   LIOC+1
 LOM30    LRML   CM.LOAD-1+/CM/P.RMA
          LDML   CM.LOAD-1+/CM/P.RMA+1
          ADDL   CML         ADD INDEX
          CRDL   P1          READ ONE PAIR
          LDDL   P1+/CM/P.LEN
          STDL   ERRCNT      SAVE FOR I/O AND ERROR CHECKING
          RJM    DLC         DECREMENT COUNT
          LDDL   ERRCNT
          ADN    1           ROUND UP
          SHN    -1          CONVERT TO PP WORDS
          STDL   ERRCNT      SAVE FOR IO
          LRDL   P1+/CM/P.RMA
          LDDL   P1+/CM/P.RMA+1
          SHN    -3          TO PP WORD ADDRESS
          SIMM   LOM40
          CMCH   ERRCNT,CHN  WRITE ONE BLOCK
 LOM40    LDDL   ERRCNT
          NJN    LOM50       IF INCOMPLETE TRANSFER
          AODL   CML         INCREMENT COUNT
          SBML   CM.LOAD-1+/CM/P.LEN
          NJK    LOM30       IF NOT DONE
          ZJN    LOM60       IF NOT INCOMPLETE TRANSFER
 LOM50    LDK    /RS/K.LSIT
          RADL   ERRT1       SET INCOMPLETE TRANSFER
 LOM60    AJM    LOM70,CHN   IF CHANNEL ACTIVE
          LDK    /RS/K.LSCD
          RADL   ERRT1       SET CHANNEL INACTIVE ERROR
          UJN    LOM75


 LOM70    LDC    WTEMPTY*2000
 LOM72    EJM    LOM75,CHN   IF CHANNEL EMPTY
          SBN    1
          NJN    LOM72       IF NOT TIMED OUT
          LDK    /RS/K.LSCF
          RADL   ERRT1       SET CHANNEL FULL ERROR
 LOM75    DCN    CHN+40B
          TRACE
          CFM    LOM80,CHN   IF NO CHANNEL ERROR
          LDK    /RS/K.LSCEF
          RADL   ERRT1       SET CHANNEL ERROR FLAG
 LOM80    LDML   LMBUSY,ICATDDP
          STDL   BUSYMP      BUSY WAIT FOR LOAD MEMORY
          LDN    77B
          STDL   LSTATE      DONT CHECK STATE
          RJM    GST         GET STATUS
          PJN    LOM100      IF NOT BUSY TIMEOUT
          RJM    BTE         LOG BUSY TIMEOUT
 LOM90    LDN    SC.PPR      RESET ICA
 LOM95    STDL   STCHNG      CHANGE STATE
 LOM99    LDN    1
          UJK    LOMX        ERROR EXIT

 LOM100   NJK    LOMX        IF ERRORS GETTING STATUS
          LDN    1
          STDL   BUSYMP      RESET BUSY MULTIPLIER
          LDDL   GNSTAT
          SHN    17-S.GE
          MJN    LOM120      IF GENERAL STATUS ERRORS
          LDDL   ERRT1
          NJN    LOM130      IF ERRORS
          LDDL   GNSTAT
          SHN    -S.SB1
          LPN    3
          NJN    LOM110      IF NOT RESET
          LDN    SC.ICA
          UJK    LOM95       SET ICA RESET AND EXIT

 LOM110   SBML   STATAL,ICATDDP
          ZJK    LOMX        IF CORRECT STATE AFTER LOAD
          LDML   STATAL,ICATDDP
          RJM    STE         LOG STATE TRANSITION ERROR
          UJK    LOM90       RESET ICA

 LOM120   LDK    /RS/K.LSGSE
          RADL   ERRT1
 LOM130   RJM    SSC         SET SYMPTOM CODE
          LDN    /RS/K.LLM
          STML   LRS+/RS/P.OPTP
          RJM    IGS         INCLUDE GENERAL STATUS
          LDN    /RS/K.LOF
          STML   LRS+/RS/P.ERRID
          LDDL   GNSTAT      CHECK SYMPTOM CODE
          SHN    0-S.SC1
          LPN    7
          LMN    5
          ZJN    LOM140      IF HARDWARE MISMATCH ERROR
          SOML   ERRR
          RJM    SIU         SET RETRY SUCCESS
          RJM    SLM         SEND LOG MESSAGE
          LDML   ERRR
          ZJK    LOM90       IF UNRECOVERED ERROR
          UJK    LOM10       ELSE RETRY

 LOM140   STML   ERRR
          LDN    SC.PPD      DOWN ICA
          STDL   STCHNG
          RJM    SIU         SET UNRECOVERED FAILURE
          RJM    SLM         SEND LOG MESSAGE
          UJK    LOM99       RETURN WITH ERROR STATUS
          TITLE  MAIN ROUTINES - OPERATIONAL STATE
 GPR      SPACE  4,10
**        GPR - GET PP REQUEST.
*
*         EXIT   (A) = 0 IF NO PP REQUESTS.
*                (A) <> 0 IF PP REQUEST WAS FOUND.
*
*         CALLS  CPL, IRP, SPL.
*
*         USES   P1 - P4


 GPR      SUBR               ENTRY/EXIT
          LCN    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDC    0#7FFF
          STDL   P4
          LRDL   CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          LDDL   CM.PIT+1
          RDCL   P1          CLEAR ACTIVE CHECK BIT
          ADN    /PIT/C.PPQ  CM ADDRESS OF PP REQUEST QUEUE POINTER
          CRML   P1,ONE      READ PP QUEUE POINTER
          LDDL   P3          RMA OF NEXT QUEUED PP REQUEST
          ADDL   P4
          ZJN    GPRX        IF NO PP REQUESTS
          RJM    SPL         SET PP QUEUE LOCK WORD
          ZJN    GPR10       IF LOCK WAS SET
          LDN    0
          UJK    GPRX        EXIT

 GPR10    LDN    2
          STDL   WC
          LRDL   CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          LDDL   CM.PIT+1
          ADN    /PIT/C.PPQPVA
          CRML   RS,WC       READ PVA AND RMA OF FIRST REQUEST IN CHAIN
          LDN    C.RQ
          STDL   WC
          LRML   RS+/RS/P.REQ  CM ADDRESS OF FIRST PP REQUEST
          LDML   RS+/RS/P.REQ+1
          SHN    -3
          CRML   RQ,WC       READ PP REQUEST
          RJM    CPL         CLEAR PP QUEUE LOCKWORD
          RJM    IRP         INITIALIZE REQUEST PROCESSING
          LCN    0
          UJK    GPRX        EXIT
          SPACE  4,10
**        GUR - GET UNIT REQUEST
*
*         THIS ROUTINE WILL GET THE NEXT REQUEST ON THE
*         UNIT QUEUE. IF THE REQUEST IS A WRITE, A CHECK
*         IS MADE TO SEE IF THE ICA HAS -SEND DATA- UP.
*         IF NOT, THE REQUEST IS IGNORED.
*
*         ENTRY  (CM.URQ) = REFORMATTED ADDRESS OF UNIT QUEUE TO SEARCH.
*
*         EXIT   (A) = 0, IF NO REQUESTS TO PROCESS,
*                    <> 0, IF REQUEST TO PROCESS.
*
*         USES   P1 - P4, T2, WC.
*
*         CALLS  IRP.
*
          SPACE  4,10
 GUR      SUBR               ENTRY/EXIT

*         GET THE FIRST WORD ADDRESS OF THE NEXT UNIT REQUEST.

          LRDL   CM.URQ      CM ADDRESS OF UNIT REQUEST QUEUE
          LDDL   CM.URQ+1
          ERRNZ  /UQD/C.HEAD OFFSET TO UNIT QUEUE HEAD POINTER IS NOT ZERO
*         ADN    /UQD/C.HEAD OFFSET TO UNIT QUEUE HEAD POINTER
          CRDL   P1          READ UNIT QUEUE HEAD POINTER
          LDDL   P3          RMA OF NEXT QUEUED UNIT REQUEST
          ADDL   P4
          ZJN    GURX        IF NO UNIT REQUESTS

*         CHECK THAT THE UNIT REQUEST WILL FIT IN PP MEMORY.

          LDDL   P1          REQUEST LENGTH (CM BYTES)
          SHN    -3          REQUEST LENGTH (CM WORDS)
          STDL   WC
          SBN    MAXURQ+1    COMPARE WITH MAX UNIT REQUEST SIZE
          PJN    *           IF REQUEST TOO BIG FOR PP MEMORY  --HANG--

*         READ THE UNIT REQUEST.

          LRDL   P3          CM ADDRESS OF THE NEXT REQUEST
          LDDL   P3+1
          SHN    -3
          CRML   RQ,WC       READ UNIT REQUEST

*         SAVE PVA OF UNIT REQUEST IN RESPONSE.

          LDN    2           LENGTH OF PVA - 1
          STDL   T2

 GUR20    LDML   RQ+/URQ/P.THISPV,T2   PVA OF THE UNIT REQUEST
          STML   RS+/RS/P.PVA,T2    PVA OF THE RESPONSE
          SODL   T2
          PJN    GUR20       IF MORE TO DO

*         SAVE RMA OF UNIT REQUEST IN RESPONSE.

          LDDL   P3            RMA OF THE UNIT REQUEST
          STML   RS+/RS/P.REQ  RMA OF THE RESPONSE
          LDDL   P3+1
          STML   RS+/RS/P.REQ+1

*         SET UP A DUMMY R/I FIELD IN THE REQUEST

          LDML   RQ+/RQ/P.RECOV  REQUEST R/I AND DEVICE ID FIELDS
          LPK    17400B          KEEP MEMORY PORT
          LMK    20000B          SET INTERRUPT OPTION
          STML   RQ+/RQ/P.RECOV  R/I FIELD (RECOVERY, INTERRUPT, AND MEM PORT)

          RJM    IRP         INITIALIZE REQUEST PROCESSING
          LCN    0
          UJK    GURX        EXIT
 NCP      SPACE  4,14
**        NCP - NEGOTIATE CHANNEL PROTOCOL.
*
*         NEGOTIATE WITH THE ICA TO DETERMINE WHICH CHANNEL
*         PROTOCOL WILL BE USED.
*
*         EXIT   A = 0 IF NEGOTIATIONS SUCCESSFUL
*                  <> 0 IF NEGOTIATIONS NOT SUCCESSFUL
*
*         CALLS  DST FAN ILR SLM


 NCP10    LDML   LRS+/RS/P.DETAIL+DS.MPS+1
          STML   TCCH+/HD/P.MRS
          LDN    1
          STML   OSOSI
          RJM    ILR         INITIALIZE LOG RESPONSE
          LDN    0

 NCP      SUBR               ENTRY/EXIT
          RJM    DST         GET DETAILED STATUS
          NJN    NCPX        IF ERRORS READING DETAILED STATUS
          LDML   LRS+/RS/P.DETAIL+DS.PROV
          ADC    -PR.MIN
          MJK    NCP20       IF ICA PROTOCOL .LT. MINIMUM SUPPORTED
          SBN    PR.MAX-PR.MIN+1
          MJN    NCP14       IF MAXIMUM SUPPORTED .GE. ICA MAXIMUM
          LDC    PR.MAX
          UJN    NCP15       USE MAXIMUM SUPPORTED PROTOCOL

 NCP14    LDML   LRS+/RS/P.DETAIL+DS.PROV
 NCP15    STML   PROV
          RJM    ILR         INITIALIZE LOG RESPONSE
          LDML   PROV
          ADC    PR.BASE
          RJM    FAN         SEND NEGOTIATION FUNCTION
          NJN    NCP30       IF FUNCTION TIMEOUT
          RJM    GST         WAIT FOR NOT BUSY
          NJN    NCP30       IF ERRORS GETTING GENERAL STATUS
          RJM    DST         READ DETAILED STATUS
          NJN    NCP30       IF ERRORS READING DETAILED STATUS
          LDML   LRS+/RS/P.DETAIL+DS.PROV
          SBML   PROV
          ZJK    NCP10       IF PROTOCOLS MATCH
 NCP20    LDN    SC.PPD
          STML   STCHNG      DOWN ICA
          LDK    /RS/K.LPROER
          STML   LRS+/RS/P.ERRID
          LDK    PR.MAX
          STML   LRS+/RS/P.DATA1
          RJM    SLM         SEND LOG MESSAGE
 NCP30    UJK    NCPX        EXIT
          SPACE  4,10
**        PPC - PROCESS PP COMMANDS
*
*         THIS ROUTINE PROCESSES ALL PP COMMANDS. VALID COMMANDS
*         ARE LISTED IN THE TABLE *PCT*.
*
*         ENTRY  CM - CONTAINS COMMAND
*                RQ - CONTAINS PP REQUEST.
*
*
*         CALLS  PIE  STB
*
          SPACE  4,10
 PPC      SUBR               ENTRY/EXIT
          LDML   CM+/CM/P.CODE GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          STML   STBI
          LDC    PCT-2       ADDRESS-2 OF PP COMMAND TABLE
          RJM    STB         SEARCH TABLE
          NJN    PPC20       IF MATCH FOUND

*         INVALID COMMAND

          LDC    E501        INTERFACE ERROR
          RJM    PIE         PROCESS INTERFACE ERROR
          UJN    PPC30

*         VALID COMMAND

 PPC20    STDL   P2
          RJM    0,P2        CALL COMMAND PROCESSOR
 PPC30    UJK    PPCX        EXIT

          SPACE  4,10
**        PP COMMAND TABLE
*
          SPACE  4,10
 PCT      CON    C.IDLE,IDP  IDLE PROCESSOR
          CON    C.RESUME,REP  RESUME PROCESSOR
          CON    C.DBUG,SDM    DEBUG MODE
          CON    C.GFC,GFC     GLOBAL FLOW CONTROL
          CON    C.DEFEA,DEA   DEFINE ETHERNET ADDRESS
          CON    C.RESET,RFC   RESET ICA
          CON    C.RDY,NRA     SYNCHRONIZE NOT READY
          CON    C.DBGSM,SPA   SELECT PP ADDRESS
          CON    C.DBGRM,RPM   READ PP MEMORY
          CON    C.DBGWM,WPM   WRITE PP MEMORY
 B.       IFEQ   BRK,1
          CON    C.DEFBA,DBA   DEFINE PP BKPT AREA IN CM
 B.       ENDIF
          CON    0
          SPACE  4,10
**        SAC - SEND AVAILABILITY CHANGE
*
*         THIS ROUTINE WILL SEND AN UNSOLICITED RESPONSE
*         INFORMING THE CP THAT THE ICA HAS CHANGED STATES
*         AND BECOME AVAILABLE/UNAVAILABLE.
*
*         ENTRY  *STCHNG* = STATE CHANGE CODE.
*
*         CALLS  PPR USR
          SPACE  4,10
 SAC      SUBR               ENTRY/EXIT
          LDDL   STCHNG
          LMN    SC.AV
          ZJN    SAC22       IF CHANGE TO AVAILABLE
          LMN    SC.OPER&SC.AV
          ZJN    SAC40       IF OPERATIONAL
          LDML   AVAIL
          SBN    URC.RN
          ZJN    SACX        IF ALREADY SENT
          LCN    0
          STML   SCP.RDY     DONT GO READY BEFORE CP REPLIES
          LDN    URC.RN
          UJN    SAC30       SEND UNSOLICITED NOT READY

 SAC22    LDML   SCP.RDY
          ZJN    SAC25       IF CPU HAS RESPONDED
          RJM    PPR         PROCESS PP REQUESTS
          LDML   IDLE
          ZJN    SAC22       WAIT IF NOT IDLE
          UJK    SACX        EXIT IF IDLE

 SAC25    LDN    URC.NR      SEND READY RESPONSE
 SAC30    STDL   UNSC
          STML   AVAIL
          RJM    USR         SEND UNSOLICITED RESPONSE
          UJK    SACX        EXIT

 SAC40    LDML   PROV        RETURN CHANNEL PROTOCOL VERSION
          STML   RS+/RS/P.PROV
          LDML   TCCH+/HD/P.MRS  RETURN MAXIMUM RECORD SIZE
          STML   RS+/RS/P.MAXRS+1
          LDN    /RS/C.BUFPVA*8+8
          STML   RS+/RS/P.RESPL  UPDATE RESPONSE LENGTH
          LDN    URC.LO      SEND OPERATIONAL RESPONSE
          UJK    SAC30       SEND RESPONSES
          SPACE  4,10
**        SEA -  SEND ETHERNET ADDRESS
*
*         THIS ROUTINE WILL WRITE THE ETHERNET ADDRESS
*         TO THE ICA
*
*         ENTRY  (EA - EA+3) = ETHERNET ADDRESS
*
*         EXIT   (A) = 0 IF NO ERRORS
*                (A) <> 0 IF ERRORS
*
*         CALLS  FAN ERR
          SPACE  4,10
 SEA      SUBR               ENTER/EXIT
          LDN    FTRY
          STML   ERRR        RESET ERROR COUNTER
 SEA10    LDC    F.DEFEA     FUNCTION DEFINE ETHERNET ADDRESS
          RJM    FAN
          NJN    SEAX        EXIT IF ERRORS
          ACN    CHN         ACTIVATE CHANNEL
          LDN    EAL         LENGTH OF ADDRESS
          OAM    EA,CHN      SEND ETHERNET ADDRESS
          STDL   ERRCNT      SAVE WORDS NOT WRITTEN
          LDK    /RS/K.LSEA
          RJM    ERR         CHECK FOR ERRORS
          ZJN    SEA20       IF NO ERRORS
          LDDL   STCHNG
          NJN    SEA20       IF STATE CHANGING
          LDML   ERRR
          NJK    SEA10       RETRY
          LDN    1           RETURN ERROR
 SEA20    UJK    SEAX        EXIT
          TITLE  COMMAND PROCESSORS
**        IDP - IDLE PROCESSOR
*
*         THIS ROUTINE PROCESSES THE IDLE COMMAND
*
*         ENTRY  NONE
*
*         EXIT   (A) = 0, IF NO ERRORS
*                (A) <> 0, IF ERRORS.
*
          SPACE  4,10
 IDP      SUBR               ENTRY/EXIT
          LDML   CHLOCK
          ZJN    IDP10       IF CHANNEL NOT LOCKED
          RJM    CCK         CLEAR CHANNEL LOCK
 IDP10    LCN    0
          STML   IDLE        SET IDLE FLAG NON-ZERO
          LDN    0
          UJN    IDPX        EXIT
          SPACE  4,10
**        REP - RESUME PROCESSOR
*
*         THIS ROUTINE PROCESSES THE RESUME COMMAND.
*
*         ENTRY  NONE
*
*         EXIT   (A) = 0, IF NO ERRORS
*                (A) <> 0, IF ERRORS.
*
          SPACE  4,10
 REP      SUBR               ENTRY/EXIT
          LDN    0
          STML   IDLE        CLEAR IDLE FLAG
          UJN    REPX        EXIT
          IFEQ   BRK,1
          SPACE  4,14
**        DBA - DEFINE BREAKPOINT AREA
*
*         THIS ROUTINE PROCESSES THE DEFINE BREAKPOINT AREA
*         COMMAND. THIS COMMAND TELLS THE PP WHERE IN CM
*         THE BREAKPOINT AREA IS.
*
*         ENTRY  CM - CONTAINS COMMAND.
*
*         EXIT   (A) = 0, IF NO ERRORS,
*                    <> 0, IF ERRORS,
*                BRMA-BRMA+1 = RMA OF PP BKPT AREA,
*                BALEN = LENGTH OF BKPT AREA IN CM WORDS.
*
          SPACE  4,10
 DBA      SUBR               ENTRY/EXIT
          LDML   CM+/CM/P.RMA
          STML   BRMA
          LDML   CM+/CM/P.RMA+1
          STML   BRMA+1      RMA OF PP BKPT AREA
          LDML   CM+/CM/P.LEN
          STML   BALEN       BKPT AREA LENGTH IN CM WORDS
          LDN    0
          STML   SBKP        START BREAKPOINTING
          UJK    DBAX        EXIT
          ENDIF
          SPACE  4,10
**        DEA - DEFINE ETHERNET ADDRESS
*
*         THIS ROUTINE PROCESSES THE DEFINE ETHERNET ADDRESS
*         COMMAND.
*
*         EXIT   (A) = 0.
          SPACE  4,10
 DEA      SUBR               ENTRY/EXIT
          LDML   CM+/CM/P.RMA+1
          LRML   CM+/CM/P.RMA
          SHN    -3
          CRML   EA,ONE      READ ETHERNET ADDRESS
          LDC    OSITDD
          STDL   ICATDDP     CHANGE TYPE TO OSI
          LDN    0
          UJN    DEAX        EXIT
 GFC      SPACE  4,10
**        GFC - GLOBAL FLOW CONTROL.
*
*         THIS ROUTINE PROCESSES THE GLOBAL FLOW CONTROL COMMAND.
*
*         EXIT   (A) = 0 IF NO ERRORS
*                    <> 0 IF ERRORS
*
*         CALLS  FAN PIE
          SPACE  4,10
 GFC10    LDC    E50B
          RJM    PIE         SEND INTERFACE ERROR

 GFC      SUBR               ENTRY/EXIT
          LDML   CM+/CM/P.LEN
          ZJN    GFC20       IF FLOW CONTROL ON
          SBN    1
          NJN    GFC10       IF INVALID COMMAND
          LDN    F.FCOFF
          UJN    GFC30       FUNCTION FLOW CONTROL OFF

 GFC20    LDN    F.FCON
 GFC30    STML   GFCFC
          RJM    FAN         SEND FUNCTION
          NJN    GFC40       EXIT IF ERRORS
          RJM    GST         WAIT FOR BUSY
 GFC40    LDN    0
          UJN    GFCX        EXIT
          SPACE  4,10
**        NRA - NOT READY ACKNOWLEDGE
*
*         THIS ROUTINE PROCESSES THE SYNCHRONIZE
*         READY ACKNOWLEDGE.
*
*         ENTRY  NONE
*
*         EXIT   (A) = 0, IF NO ERRORS
*                (A) <> 0, IF ERRORS.
*
          SPACE  4,10
 NRA      SUBR               ENTRY/EXIT
          LDML   SCP.RDY
          ZJN    NRA10       IF NOT WAITING FOR THIS
          LDN    0
          STML   SCP.RDY     UPDATE SYNCHRONIZATION WORD
          LDN    0
          UJK    NRAX

 NRA10    LDC    E50A
          RJM    PIE         RETURN INTERFACE ERROR
          UJN    NRAX        EXIT
          SPACE  4,18
**        PFR - PERFORM READ
*
*         THIS ROUTINE READS IN DATA FROM THE ICA.  THE
*         TOTAL LENGTH OF THE TRANSFER AND MESSAGE TYPE ARE
*         NOT KNOWN UNTIL THE HEADER HAS BEEN READ.
*
*         ENTRY  DATA AVAILABLE BIT SET IN GENERAL STATUS.
*
*         USES   P1 - P4, T2, T3, UNSC.
*
*         CALLS  ERR, FAW, GRB, QPR, RCP, RRH, USR.
          SPACE  4,10
 PFR      SUBR               ENTRY/EXIT
          LDK    BP.GOOD     BUFFER POOL CONTAINS A SUFFICIENT NUMBER OF BUFFERS
          STML   RS+/RS/P.T1STAT
          STML   RS+/RS/P.T2STAT
          LDK    SS.OPEN     PP IS ABLE TO SEND MESSAGES TO THE DEVICE
          STML   RS+/RS/P.PSEND
          STML   RS+/RS/P.NSEND
          LDK    /RS/C.T1STAT*8+8
          STML   RS+/RS/P.RESPL  UPDATE RESPONSE LENGTH

          LDN    0
          STML   ACTD
          STDL   BUFLEN      NUMBER OF FREE BYTES REMAINING IN CM BUFFER
          STML   CML         OFFSET TO LENGTH/ADDRESS PAIR IN RESPONSE BUFFER
          STDL   CMLISTL     LENGTH/ADDRESS PAIR COUNT
          LDML   NXTREC
          ZJN    PFR20       IF RECORD SIZE NOT KNOWN
          STML   TBYTS
          RJM    GRB         GET BUFFERS
          ZJK    PFR100      IF BUFFERS NOT AVAILABLE

*         ISSUE READ FUNCTION

 PFR20    LDC    F.READ
          RJM    FAW         ISSUE FUNCTION AND ACTIVATE CHANNEL
          NJK    PFR100      IF ERRORS
          RJM    RRH         READ RECORD HEADER
          MJK    PFR100      IF NO BUFFERS (OR INADEQUATE NUMBER)
          NJK    PFR80       IF ERRORS
          TRACE  (TCHFR,BUFLEN,RDCNT,EXPD+1,ACTD+1)

          LDML   OSOSI
          NJN    PFR30       IF OPERATIONAL

*         READ CHANNELNET PDU

          RJM    RCP         READ CHANNELNET PDU
          ZJK    PFR110      IF NO ERROR OCCURRED
          UJK    PFR90       IF AN ERROR OCCURRED

*         READ CHANNEL CONNECTION PDU

 PFR30    LDML   TCHFR       REMAINING WORDS TO WRITE
          SBML   BUFLEN
          ZJN    PFR40       IF LAST BUFFER
          PJN    PFR50       IF NOT LAST BUFFER

 PFR40    LDML   TCHFR
          STML   BUFLEN
          SHN    1
          SBML   EBYOFF      ODD BYTE INDICATOR
          STML   RDCNT       BYTES IN LAST BUFFER
          LDN    0
 PFR50    STML   TCHFR
          LDML   RDCNT
          RAML   ACTD+1      UPDATE ACTUAL DATA
          LRDL   DATADD      LOAD R UPPER
          LDDL   DATADD+1    FWA OF CM BUFFER
          CHCM   BUFLEN,CHN  READ ONE BUFFER
          LDDL   BUFLEN
          ZJN    PFR60       IF ALL READ
          SHN    1
          STDL   ERRCNT      FORCE ERROR FROM ERROR CHECK
          LDML   ACTD+1
          SBML   ERRCNT
          STML   ACTD+1      UPDATE ACTUAL DATA
          DCN    CHN+40B
          TRACE
          UJN    PFR70

 PFR60    LDDL   RDCNT       BYTES READ
          RAML   RS+/RS/P.XFER+1
          LDML   TCHFR
          ZJN    PFR70       IF LAST BUFFER
          AODL   CML
          RJM    SBI         SET UP NEXT BUFFER
          UJK    PFR30       READ NEXT BUFFER

 PFR70    LDK    /RS/K.LREAD
          RJM    ERR         CHECK FOR ERRORS
          ZJK    PFR110      NO ERRORS
 PFR80    LDDL   STCHNG
          NJK    PFR100      EXIT IF STATE CHANGED
          LDML   RDRTY
          NJN    PFR90       IF RETRY
          LDN    FTRY
          STML   RDRTY       RESET RECOVERY COUNTER IF UNRECOVERED
          UJN    PFR100      RETURN BUFFERS

 PFR90    RJM    QPR         QUEUE PREVIOUS READ
 PFR100   BSS    0

*         IT IS POSSIBLE FOR THE PP TO GENERATE NUMEROUS DEVICE ERRORS IF THE
*         BUFFER POOL IS EMPTY AND THE CPU HAS NOT HAD A CHANCE TO MAKE
*         ADDITIONAL BUFFERS AVAILABLE.  TO AVOID THIS, THE FOLLOWING CODE
*         CHECKS TO SEE IF THE RESPONSE BEING GENERATED IS GOING TO RETURN
*         ANY BUFFERS OR IF IT IS GOING TO RETURN A *BUFFER EMPTY* OR  A
*         *BUFFER THRESHOLD* STATUS.  IF NOT, A DEVICE ERROR UNSOLICITED
*         RESPONSE WILL NOT BE ISSUED.

          LDDL   CMLISTL     NUMBER OF LENGTH/ADDRESS PAIRS
          ADML   RS+/RS/P.T1STAT   STATUS OF TYPE 1 BUFFER POOL
          ADML   RS+/RS/P.T2STAT   STATUS OF TYPE 2 BUFFER POOL
          SBN    2*BP.GOOD   COMPARE WITH ADEQUATE NUMBER OF BUFFERS AVAILABLE
          NJN    PFR102      IF DEVICE ERROR REQUIRED
          RJM    ZRE         ZERO OUT BUFFER
          UJK    PFRX        EXIT  --  NO DEVICE ERROR REQUIRED

*         MOVE THE LAST LENGTH/ADDRESS PAIR TO BE THE FIRST ONE (IF THE FIRST
*         ONE HAS NOT BEEN ALLOCATED YET).  THIS IS NEEDED BECAUSE THE FIRST
*         BUFFER IS ALLOCATED LAST AND COULD BE UNALLOCATED AT THIS POINT.
*         THE CPU CODE EXPECTS THE BUFFER LIST TO BE CONTIGUOUS AND ALLOCATED.

 PFR102   BSS    0
          LDML   RS+/RS/P.DLEN   LENGTH OF FIRST BUFFER POOL BUFFER
          NJN    PFR108      IF FIRST BUFFER HAS BEEN ALLOCATED
          LDN    3           LENGTH/ADDRESS PAIR SIZE (PP WORDS)(0..3)
          STDL   T2          OFFSET TO FIRST LENGTH/ADDRESS PAIR
          LDDL   CMLISTL     NUMBER OF LENGTH/ADDRESS PAIRS
          SHN    2           CONVERT TO PP WORDS
          ADDL   T2          ADJUST FOR HIGHEST OFFSET
          STDL   T3          OFFSET TO LAST LENGTH/ADDRESS PAIR

 PFR105   BSS    0
          LDML   RS+/RS/P.DLEN,T3   PART OF LAST LENGTH/ADDRESS PAIR
          STML   RS+/RS/P.DLEN,T2   PART OF FIRST LENGTH/ADDRESS PAIR
          SODL   T3          NEXT OFFSET TO LAST LENGTH/ADDRESS PAIR
          SODL   T2          NEXT OFFSET TO FIRST LENGTH/ADDRESS PAIR
          PJK    PFR105      IF MORE TO MOVE

 PFR108   LDN    URC.DE      ISSUE DEVICE ERROR TO RETURN BUFFER
          UJN    PFR120      SEND UNSOLICITED RESPONSE

 PFR110   STML   NXTREC
          LDML   /HD/P.RRC,HDRTYP  GET RESPONSE CODE
 PFR120   STDL   UNSC        UNSOLICITED RESPONSE CODE
          LDDL   CMLISTL     NUMBER OF LENGTH/ADDRESS PAIRS
          SHN    3           CONVERT TO CM BYTES
          RAML   RS+/RS/P.RESPL  UPDATE RESPONSE LENGTH
          RJM    USR         SEND UNSOLICITED RESPONSE
          UJK    PFRX        EXIT
 RFC      SPACE  4,10
**        RFC - RESET FOR CPU.
*
*         THIS ROUTINE PROCESSES THE RESET COMMAND.
*
*         EXIT   (A) = 0.
          SPACE  4,10
 RFC      SUBR               ENTRY/EXIT
          LDN    SC.PPR      RESET ICA
          STDL   STCHNG
          LDN    0
          UJN    RFCX        EXIT
 SDM      SPACE  4,10
**        SDM - SET DEBUG MODE.
*
*         THIS ROUTINE PROCESSES THE SET DEBUG MODE COMMAND.
*
*         EXIT   (A) = 0 IF NO ERRORS
*                    <> 0 IF ERRORS
*
*         CALLS  PIE
          SPACE  4,10
 SDM10    LDC    E50B
          RJM    PIE         SEND INTERFACE ERROR

 SDM      SUBR               ENTRY/EXIT
          LDML   CM+/CM/P.RMA+1
          ZJN    SDM20       IF DEBUG MODE ON
          SBN    1
          NJN    SDM10       IF INVALID COMMAND
          LDN    1
 SDM20    STML   DBUGM
          LDN    0
          UJN    SDMX        EXIT
          SPACE  4,20
**        WRP - WRITE PROCESSOR
*
*         THIS ROUTINE PROCESSES THE WRITE BYTES COMMAND.
*         RECORDS WRITTEN TO THE ICA MAY BE IN FRAGMENTS
*         SCATTERED THROUGHOUT MEMORY AND ARE NOT GUARANTEED
*         TO START OR END ON WORD BOUNDARYS.  EACH FRAGMENT
*         IS WRITTEN IN A MULTIPLE OF 64 BIT CENTRAL MEMORY
*         WORDS USING THE DIRECT MEMORY ACCESS(DMA) CHANNEL
*         INSTRUCTION.  A 32 BIT HEADER MUST PRECEDE EACH
*         BLOCK DESCRIBING THE DATA WHICH FOLLOWS.  THE ICA
*         WILL THEN DISCARD LEADING AND TRAILING BYTES OF
*         UNUSED DATA.  THIS HEADER IS DEFINED AS FOLLOWS.
*
*         +-----+-----+----------+
*         |  P  |  R  |     Q    |
*         +-----+-----+----------+
*
*         P = NUMBER OF LEADING JUNK BYTES (8 BITS)
*         R = NUMBER OF TRAILING JUNK BYTES (8 BITS)
*         Q = LENGTH OF DATA PORTION IN BYTES (16 BITS)
*
*         ENTRY  CM - CONTAINS COMMAND.
*
*         USES   CML, CMLISTL, T1, T2, T3.
*
*         CALLS  ERR, FAN, STR, ZRE.
          SPACE  4,10
 WRP      SUBR               ENTRY/EXIT
          LDN    0
          STDL   CML         CURRENT CM LIST INDEX

*         ISSUE WRITE FUNCTION

          LDC    F.WRITE
          RJM    FAN         ISSUE WRITE FUNCTION
          NJK    WRPX        EXIT IF ERRORS
          ACN    CHN
          LDML   RQ+/URQ/P.URQLEN
          SBN    /URQ/C.MBRMA*8
          SHN    -3
          STDL   CMLISTL     NUMBER OF CM LENGTH/ADDRESS PAIRS

 WRP20    BSS    0
          LDDL   CML         CURRENT CM LIST INDEX
          SHN    2           CONVERT TO PP WORD OFFSET
          STDL   T3          OFFSET TO CM LENGTH/ADDRESS PAIR (PP WORDS)
          LRML   RQ+/URQ/P.MBRMA,T3     UPPER PORTION OF ADDRESS OF DATA BUFFER
          LDML   RQ+/URQ/P.MBRMA+1,T3   LOWER PORTION OF ADDRESS OF DATA BUFFER
          STML   WRPA
          LDML   RQ+/URQ/P.MBLEN,T3   LENGTH OF DATA BUFFER

 WRP22    BSS    0
          STDL   BYTS        NUMBER OF BYTES LEFT TO TRANSFER TO THE ICA
          ADK    -MAXDMA     MAX CM BYTES THAT ICA CAN RECEIVE PER DMA TRANSFER
          PJN    WRP24       IF TOO MUCH FOR 1 DMA OPERATION

          LDDL   BYTS        REMAINING BYTES TO BE TRANSFERRED
          UJN    WRP26

 WRP24    LDK    MAXDMA      MAX CM BYTES THAT ICA CAN RECEIVE PER DMA TRANSFER
 WRP26    STML   IOBUF+1
          LDML   WRPA        LOWER PORTION OF ADDRESS OF DATA BUFFER
          LPN    7
          STDL   T1          SAVE LEADING JUNK
          SHN    8
          STML   IOBUF       STORE LEADING JUNK IN HEADER
          LDML   IOBUF+1     LENGTH OF DMA TRANSFER (CM BYTES)
          ADDL   T1
          LPN    7
          STDL   T2          SAVE ENDING BYTE +1
          ZJK    WRP40       IF ON WORD BOUNDARY
          LDN    8
          SBDL   T2          FORM TRAILING JUNK
          STDL   T2
          RAML   IOBUF
 WRP40    LDML   IOBUF+1
          ADDL   T1
          ADDL   T2
          SHN    -1          PP WORD COUNT
          STML   PWRT        LENGTH OF BUFFER TO BE WRITTEN TO ICA (PP WORDS)
          LDN    2           WRITE TWO PP WORDS
          SIMM   WRP50
          OAM    IOBUF,CHN   WRITE HEADER
          NJK    WRP65       IF INCOMPLETE WRITE

 WRP50    BSS    0
          LDML   WRPA        LOWER PORTION OF ADDRESS OF DATA BUFFER
          SHN    -3          FORM WORD ADDRESS
          SIMM   WRP60
          CMCH   PWRT,CHN
          LDML   PWRT
          NJK    WRP65       IF INCOMPLETE WRITE
 WRP60    LDML   IOBUF+1     BYTES TRANSFERRED
          RAML   RS+/RS/P.XFER+1
          LDML   IOBUF+1     BYTES TRANSFERRED
          RAML   WRPA        START OF NEXT BLOCK TO BE WRITTEN TO ICA
          LDDL   BYTS        NUMBER OF BYTES LEFT TO WRITE TO THE ICA
          SBML   IOBUF+1     LESS THE AMOUNT THAT WAS JUST WRITTEN
          NJK    WRP22       IF MORE TO DO (FOR THIS BUFFER)
          AODL   CML
          SBDL   CMLISTL
          NJK    WRP20       CONTINUE IF MORE TO WRITE
 WRP65    STDL   ERRCNT      NUMBER OF WORDS NOT WRITTEN
          LDK    /RS/K.LWRT
          RJM    ERR         CHECK ERRORS
          ZJN    WRP70       IF NO ERRORS
          LDDL   STCHNG
          NJK    WRPX        EXIT IF RESET
          LDDL   ERRT1
          LPK    /RS/K.LSCEF
          ZJK    WRP66       IF NO CHANNEL ERROR FLAG
          LDDL   GNSTAT
          SHN    17-S.GE
          PJN    WRP67       IF ONLY ERROR WAS CEF
 WRP66    LDML   WRRTY
          ZJK    WRP67       IF UNRECOVERED
          RJM    ZRE         ZERO RESPONSE BUFFER
          UJK    WRPX        EXIT IF IN RECOVERY

 WRP67    LDN    FTRY
          STML   WRRTY       RESET RETRY COUNTER
          LDN    SC.PPR
          STDL   STCHNG
 WRP70    RJM    STR         SEND TERMINATION RESPONSE
          UJK    WRPX        EXIT

 WRPA     BSSZ   1           LOWER PORTION OF ADDRESS OF DATA BUFFER
          TITLE  MISCELLANEOUS ROUTINES
**        BTE - BUSY TIMEOUT ERROR
*
*         THIS ROUTINE  LOGS A BUSY TIMEOUT ERROR
*         AND RESETS THE ICA.
*
*         ENTRY  NONE
*
*         EXIT   NONE
*
*         USES   NONE
*
*         CALLS  SEI SLM
          SPACE  4,10
 BTE      SUBR               ENTRY/EXIT
          LDN    SC.PPR
          STDL   STCHNG      RESET ICA
          LDK    /RS/K.LGSBTO
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDML   PREFC
          STML   LRS+/RS/P.PFUNC SAVE PREVIOUS FUNCTION CODE
          RJM    IGS         INCLUDE GENERAL STATUS
          RJM    SLM         SEND LOG MESSAGE
          UJN    BTEX        EXIT
          SPACE  4,12
**        CAE - CHANNEL ACTIVE ERROR
*
*         THIS ROUTINE DISCONNECTS THE CHANNEL AND
*         LOGS A CHANNEL ACTIVE ERROR.
*
*         ENTRY  NONE
*
*         EXIT   NONE
*
*         USES   NONE
*
*         CALLS  SOT SEI SSC
          SPACE  4,10
 CAE      SUBR               ENTRY/EXIT
          STML   LRS+/RS/P.OPTP  LOG OPERATION TYPE
          LDK    /RS/K.LOF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDK    /RS/K.LSCA
          RJM    SSC         LOG SYMPTOM CODE
          UJN    CAEX        EXIT
 CBP      SPACE  4,16
**        CBP - CHECK IF BUFFER IN POOL.
*
*         THIS ROUTINE WILL INTERLOCK THE BUFFER POOL
*         AND DETERMINE IF A BUFFER IS AVAILABLE.
*         THE INTERLOCK WILL BE CLEARED BEFORE EXIT.
*
*         ENTRY  (FSTBD) = INDEX INTO POOL BUFFER.
*
*         EXIT   (A) = 0, IF NO BUFFER AVAILABLE.
*                    <> 0, IF BUFFER AVAILABLE.
*                RESPONSE BUFFER POOL STATUS SET APPROPRIATELY IF POOL IS
*                          EMPTY OR BELOW THRESHOLD.
*                (BP - BP+7) = BUFFER POOL TABLE ENTRY.
*
*         USES   T2, T3, T9, WC.
*
*         CALLS  SBL.
*
*         MACROS LOADC, LOADF.
          SPACE  4,10
*         BUFFER POOL DESCRIPTOR PP OUT POINTER

 PPOUT    EQU    P1+/BPD/P.PPOUT-/BPD/C.PPOUT*4

 CBP      SUBR               ENTRY/EXIT
 CBP10    BSS    0
          LDDL   FSTBD       INDEX INTO BUFFER POOL
          SHN    2
          ADDL   FSTBD       5 WORDS PER BUFFER POOL DESCRIPTOR
          STDL   T9          CM WORD OFFSET OF BUFFER POOL DESCRIPTOR
          ADK    /BPD/C.PPOUT   OFFSET TO BPD PP OUT POINTER
          RJM    SBL         SET POOL DESCRIPTOR INTERLOCK

*         GET BUFFER POOL DESCRIPTOR.

*         LDN    0
          STDL   T3          NUMBER OF BUFFERS OBTAINED
          LDN    C.BPD
          STDL   WC          LENGTH OF POOL DESCRIPTOR
          IFEQ   DRTYP,1     IF MDI
          LOADC  CM.BPD      ADDRESS OF FIRST POOL DESCRIPTOR
          ENDIF
          IFEQ   DRTYP,2     IF ICA2
          LRDL   CM.BPD      ADDRESS OF FIRST POOL DESCRIPTOR
          LDDL   CM.BPD+1
          ENDIF
          ADDL   T9          CM WORD OFFSET OF BUFFER POOL DESCRIPTOR
          CRML   BPD,WC

*         VALIDATE BUFFER POOL DESCRIPTOR IN POINTER.

          LDML   BPD+/BPD/P.IN   BUFFER POOL DESCRIPTOR IN POINTER
          LPK    7           BYTE OFFSET
          NJN    *           IF BPD IN POINTER NOT ON A CM WORD BOUNDARY

*         VALIDATE BUFFER POOL DESCRIPTOR OUT POINTER.

          LDDL   PPOUT       BUFFER POOL DESCRIPTOR PP OUT POINTER
          LPK    7           BYTE OFFSET
          NJN    *           IF BPD OUT POINTER NOT ON A CM WORD BOUNDARY

*         CHECK IF A BUFFER IS AVAILABLE.

          LDML   BPD+/BPD/P.IN   BUFFER POOL DESCRIPTOR IN POINTER
          SBDL   PPOUT           COMPARE WITH BPD PP OUT POINTER
          ZJN    CBP30       IF BUFFER POOL IS EMPTY
          AODL   T3          NUMBER OF BUFFERS OBTAINED

*         GET BUFFER POOL TABLE ENTRY.

          LDK    C.BP
          STDL   WC          BUFFER POOL ENTRY SIZE (CM WORDS)
          LDDL   PPOUT       BUFFER POOL ENTRY OFFSET (CM BYTES PER BP ENTRY)
          SHN    -3          CONVERT TO A BP ORDINAL (CM WORDS PER BP ENTRY)
          STDL   T2          BUFFER POOL ENTRY OFFSET (BP ENTRIES)
          IFEQ   DRTYP,1     IF MDI
          LOADF  BPD+/BPD/P.BTRMA   BUFFER POOL TABLE FWA
          ENDIF
          IFEQ   DRTYP,2     IF ICA2
          LRML   BPD+/BPD/P.BTRMA   BUFFER POOL TABLE FWA
          LDML   BPD+/BPD/P.BTRMA+1
          SHN    -3
          ENDIF
          ADDL   T2          BUFFER POOL ENTRY OFFSET (CM WORDS)
          CRML   BP,WC

*         DETERMINE NEW BUFFER POOL DESCRIPTOR PP OUT POINTER VALUE.

          LDDL   PPOUT       BUFFER POOL DESCRIPTOR PP OUT POINTER
          ADK    C.BP*8      NEXT BUFFER POOL TABLE ENTRY
          SBML   BPD+/BPD/P.LIMIT   COMPARE WITH LIMIT
          ZJN    CBP20       IF AT LIMIT
          ADML   BPD+/BPD/P.LIMIT   RESTORE GOOD VALUE OF NEW BPD PP OUT POINTER

 CBP20    BSS    0
          STDL   PPOUT        NEW BUFFER POOL DESCRIPTOR PP OUT POINTER

*         CHECK IF A BUFFER IS AVAILABLE.

          LDML   BPD+/BPD/P.IN   BUFFER POOL DESCRIPTOR IN POINTER
          SBDL   PPOUT           COMPARE WITH BPD PP OUT POINTER
          NJN    CBP40       IF BUFFER POOL IS NOT EMPTY

*         BUFFER POOL IS EMPTY.

 CBP30    BSS    0
          LDDL   T3          NUMBER OF BUFFERS OBTAINED
          ZJN    CBP70       IF WE DID NOT EMPTY THE POOL (IF NO BUFFERS OBTAINED)
          IFEQ   DEBUG,1
          AOML   EMPBUF,FSTBD      INCREMENT EMPTY POOL COUNT
          ENDIF
          LDK    BP.EMPTY    EMPTY BUFFER POOL STATUS
          UJN    CBP60

*         CHECK IF BELOW THRESHOLD.

 CBP40    BSS    0
          PJN    CBP50       IF LIMIT NOT CROSSED OVER (IF NEXT BUFFER CONTIGUOUS)
          ADML   BPD+/BPD/P.LIMIT   RESTORE AVAILABLE BUFFERS (CM BYTES)

 CBP50    BSS    0
          ERRNZ  16-C.BP*8   BUFFER POOL ENTRY SIZE NOT 16 CM BYTES
          SHN    -4          CONVERT ENTRY SIZE (CM BYTES) TO NUMBER OF BUFFERS
          SBML   BPD+/BPD/P.THRESH   COMPARE WITH THRESHOLD
          PJN    CBP70       IF AVAILABLE BUFFERS .GE. THRESHOLD
          ADDL   T3          NUMBER OF BUFFERS OBTAINED
          MJN    CBP70       IF WE DID NOT VIOLATE THRESHOLD
          LDK    BP.THRSH    BUFFER POOL BELOW THRESHOLD STATUS

*         SET STATUS IN THE RESPONSE.

 CBP60    BSS    0
          STML   RS+/RS/P.T1STAT,FSTBD   SET STATUS

*         UPDATE BUFFER POOL DESCRIPTOR OUT POINTERS AND CLEAR THE BPD INTERLOCK.

 CBP70    BSS    0
          IFEQ   DRTYP,1     IF MDI
          LOADC  CM.BPD      ADDRESS OF FIRST POOL DESCRIPTOR
          ENDIF
          IFEQ   DRTYP,2     IF ICA2
          LRDL   CM.BPD      ADDRESS OF FIRST POOL DESCRIPTOR
          LDDL   CM.BPD+1
          ENDIF
          ADDL   T9          CM WORD OFFSET OF BUFFER POOL DESCRIPTOR
          ADK    /BPD/C.CPUOUT   OFFSET TO BPD CPU OUT POINTER
          CWDL   PPOUT+/BPD/C.PPOUT*4-/BPD/P.PPOUT   NEW BPD CPU OUT POINTER
          ADK    /BPD/C.PPOUT-/BPD/C.CPUOUT   OFFSET TO BPD PP OUT POINTER
          CWDL   PPOUT+/BPD/C.PPOUT*4-/BPD/P.PPOUT   CLEAR THE BPD INTERLOCK
          LDDL   T3          NUMBER OF BUFFERS OBTAINED
          UJK    CBPX        EXIT

          SPACE  4,10
**        CSC - CHECK IF STATE CHANGE
*
*         THIS ROUTINE WILL CHECK IF THE ICA HAS
*         CHANGED STATES, THE PP HAS REQUESTED
*         A CHANGE, OR THE PP HAS BEEN IDLED.
*
*         ENTRY  NONE
*
*         EXIT   (A) = 0, NO STATE CHANGE
*                (A) <> 0, STATE CHANGE OR IDLE REQUESTED.
*
*         USES   NONE
*
*         CALLS  GST
*
          SPACE  4,10
 CSC      SUBR               ENTRY/EXIT
          LDML   IDLE        IDLE FLAG
          ADDL   STCHNG      ADD CHANGING STATE
          NJN    CSCX        EXIT IF IDLE OR STATE CHANGING
          RJM    GST         GET GENERAL STATUS
          LDML   IDLE        IDLE FLAG
          ADDL   STCHNG      ADD CHANGING STATE
          UJN    CSCX        EXIT
          SPACE  4,15
**        CSD - CHECK IF SEND DATA UP
*
*         THIS ROUTINE OBTAINS THE GENERAL STATUS AND CHECKS
*         FOR SEND DATA. A TIMER IS KEPT TO ASSURE THAT SEND
*         DATA IS BEING SET BY THE ICA WITHIN 1 SECOND.
*         IT IS ASSUMED THIS ROUTINE CAN ONLY BE CALLED
*         ONCE PER MICROSECOND. THIS TIMER IS KEPT ONLY IN
*         ICA-I MODE.
*
*         EXIT   (A) = 0, IF SEND DATA UP
*
*         CALLS  GST DST NSD IGS SLM
          SPACE  4,10
 CSD      SUBR               ENTRY/EXIT
          RJM    GST
          NJN    CSDX        EXIT IF STATUS CANT BE READ
          LDDL   GNSTAT      GENERAL STATUS
          SHN    17-S.SEND
          MJK    CSD10       IF SEND DATA UP
          LDML   OSI,ICATDDP
          NJN    CSDX        IF OSI MODE
          SOML   CSDTIME     DECREMENT TIMER
          NJN    CSDX        EXIT IF NOT TIMED OUT
          SOML   CSDTMP
          ZJK    CSD05       IF TIME EXAUSTED
          LDC    177777B
          STML   CSDTIME
          UJK    CSDX        EXIT

 CSD05    RJM    DST         GET DETAIL STATUS
          LDK    /RS/K.LGSSDT
          STML   LRS+/RS/P.ERRID SET ERROR ID
          RJM    IGS         INCLUDE GENERAL STATUS
          LDN    SC.PPR
          STDL   STCHNG      RESET ICA
          RJM    SLM         SEND LOG MESSAGE
          UJK    CSDX        EXIT

 CSD10    LDC    177777B
          STML   CSDTIME     RESET TIMER
          LDN    17B
          STML   CSDTMP      AND MULTIPLIER
          LDN    0
          UJK    CSDX        EXIT
          SPACE  2
 CSDTIME  CON    177777B
 CSDTMP   CON    17B
          SPACE  4,10
**        DEC - DIAGNOSTIC ERROR CHECK
*
*         THIS ROUTINE IS USED TO CHECK FOR INPUT/OUTPUT ERRORS
*         IN RESET AND DIAGNOSTIC MODE. ONLY CHANNEL PARITY ERRORS
*         WILL BE RETRIED OTHER GENERAL STATUS ERRORS ARE FATAL
*         AND CAUSE THE ICA TO BE DOWNED. AN EXCEPTION IS MADE FOR
*         THE READ DIAGNOSTIC COMMAND OPERATION IF THE COMMAND IS
*         ECHO STATUS. IN THIS CASE GENERAL STATUS IS NOT READ,
*         BUT WILL BE CHECKED BY THE COMMAND PROCESSOR.
*
*         ENTRY  (A) = OPERATION TYPE
*                ERRR = REMAINING RETRYS
*                STBI = COMMAND READ IF READ DIAGNOSTIC OPERATION
*
*         EXIT   (A) = 0 IF NO ERRORS
*                (A) <> 0 IF ERRORS
*                ERRR DECREMENTED BY ONE IF CHANNEL ERRORS
*
*         USES   T4
*
*         CALLS  GST SSC SIU IGS SLM
          SPACE  4,10
 DEC      SUBR               ENTRY/EXIT
          STML   OTYPE       SAVE OPERATION TYPE
          CFM    DEC40,CHN   IF NO CHANNEL ERROR FLAG
          RJM    GST         GET GENERAL STATUS
          NJN    DECX        IF ERRORS GETTING STATUS
          LDK    /RS/K.LSCEF
          RJM    SSC         SET SYMPTOM CODE
 DEC10    SOML   ERRR
          RJM    SIU         SET RETRY SUCCESS
          LDML   ERRR
          NJK    DEC30       IF NOT UNRECOVERED ERROR
 DEC20    LDN    SC.PPD
          STDL   STCHNG      DOWM ICA
 DEC30    RJM    IGS         INCLUDE GENERAL STATUS
          LDN    /RS/K.LOF
          STML   LRS+/RS/P.ERRID
          LDML   OTYPE
          STML   LRS+/RS/P.OPTP
          RJM    SLM         SEND LOG MESSAGE
          LDN    1
          UJK    DECX        ERROR EXIT

 DEC40    LDN    /RS/K.LRDC
          SBML   OTYPE
          NJK    DEC44       IF NOT READ DIAGNOSTIC COMMAND
          LDC    DC.ECHO
          SBML   STBI
          ZJK    DEC50       IF ECHO STATUS FUNCTION
 DEC44    RJM    GST         GET GENERAL STATUS
          NJK    DECX        EXIT IF GST ERRORS
          LDDL   GNSTAT
          SHN    17-S.GE
          PJK    DEC50       IF NO ERRORS
          LDK    /RS/K.LSGSE
          RJM    SSC         SET SYMPTOM CODE
          LDDL   GNSTAT
          SHN    17-S.CE
          MJK    DEC10       IF CHANNEL ERRORS
          UJK    DEC20       DOWN ICA

 DEC50    LDN    0
          UJK    DECX        EXIT NO ERRORS

 DFC      SPACE  4,14
**        DFC - DETERMINE FLOW CONTROL.
*
*         THIS ROUTINE DETERMINES IF THE ICA HAS SET NORMAL
*         FLOW CONTROL.  IT DOES SO BY EXAMINING THE LAST GENERAL
*         STATUS TAKEN.
*
*         ENTRY  (GNSTAT) = GENERAL STATUS, SEND DATA BIT IS SET.
*
*         EXIT   (A) = 0 IF NO ERRORS
*                    <> 0 IF FLOW CONTROL VALUE INVALID
*                (NUMPRI) = 0, IF FLOW CONTROL CHANGED FROM ON TO OFF
*                         > MAXPR IF FLOW CONTROL ON
*
*         CALLS  IGS SLM
          SPACE  4,10
 DFC10    LDN    MAXPR+1
 DFC20    STML   NUMPRI
 DFC30    LDN    0

 DFC      SUBR               ENTRY/EXIT
          LDML   OSOSI
          ZJN    DFCX        IF NOT OPERATIONAL
          LDDL   GNSTAT      GENERAL STATUS
          ERRNZ  S.FC1       ERROR IF NOT BIT ZERO
          LPN    SSMASK      LOOK AT FLOW CONTROL BITS
          LMN    FSS.ON
          ZJN    DFC10       IF FLOW CONTROL ON
          LMN    FSS.OFF&FSS.ON
          NJN    DFC40       IF INVALID FLOW CONTROL
          LDN    MAXPR
          SBML   NUMPRI
          PJN    DFC30       IF NO SWITCH IN FLOW CONTROL
          LDN    0
          UJN    DFC20       EXIT

 DFC40    LDN    /RS/K.LFCE  SET ILLEGAL FLOW CONTROL
          STML   LRS+/RS/P.ERRID
          RJM    IGS         INCLUDE GENERAL STATUS
          LDN    SC.PPR
          STDL   STCHNG      RESET MCI
          RJM    SLM         SEND LOG MESSAGE
          LDN    1
          UJN    DFCX        EXIT
          SPACE  4,10
**        DLR - DELINK REQUEST FROM QUEUE
*
*         THIS ROUTINE DELINKS THE CURRENT REQUEST
*         FROM THE APPROPRIATE QUEUE.
*
*         ENTRY  REQTYP = 0, IF PP REQUEST
*                       <> 0, IF UNIT REQUEST.
*
*         CALLS  CPL, DUR, FDR, SPL.
*
          SPACE  4,10
 DLR      SUBR               ENTRY/EXIT
          LDML   REQTYP
          NJN    DLR20       IF UNIT REQUEST

*         PP REQUEST.

 DLR10    BSS    0
          LDN    2
          STDL   WC
          RJM    SPL         SET PP QUEUE LOCK
          NJN    DLR10       IF LOCK COULD NOT BE SET
          LRDL   CM.PIT
          LDDL   CM.PIT+1
          ADN    /PIT/C.PPQPVA
          RJM    FDR         FIND AND DELINK REQUEST
          RJM    CPL         CLEAR PP QUEUE LOCK
          UJK    DLRX        EXIT

*         UNIT REQUEST.

 DLR20    BSS    0
          RJM    DUR         DELINK UNIT REQUEST
          UJK    DLRX        EXIT
          SPACE  4,16
**        DST - DETAILED STATUS.
*
*         THIS ROUTINE READS THE ICA DETAILED STATUS INTO
*         THE RESPONSE BUFFER. THE RESPONSE BUFFER IS UPDATED
*         TO SHOW DETAILED STATUS IS INCLUDED. IF ERRORS ARE
*         ENCOUNTERED THEY ARE LOGGED AS INTERMEDIATE ERRORS.
*
*         ENTRY  NONE
*
*         EXIT   (A) = 0, IF NO ERROR
*                    <> 0, IF ERROR
*         USES   - T7 T8
*
*         CALLS  - GST FAW IGS SSC SEI SOT SLM SRU
*
*
          SPACE  4,10
 DST      SUBR               ENTRY/EXIT
 S.       IFEQ   SIM,1
          LDN    0
          UJN    DSTX
 S.       ENDIF
          LDN    FTRY
          STML   DSTRC
 DST10    LDN    F.DS        DETAILED STATUS
          RJM    FAW
          NJN    DSTX        IF FUNCTION TIMEOUT OR OTHER ERROR
          LDN    0
          STML   DSTER
          LDML   LDS,ICATDDP
          SIMM   DST40
          IAM    LRS+/RS/P.DETAIL,CHN  INPUT DETAILED STATUS
          ZJN    DST20       IF INPUT COMPLETE
          LDK    /RS/K.LSIT
          RAML   DSTER       SET INCOMPLETE TRANSFER
 DST20    LDN    5
          IJM    DST30,CHN   IF CHANNEL INACTIVE
          SBN    1
          NJN    DST20       IF NOT TIMEOUT
          DCN    CHN+40B     DISCONNECT CHANNEL
          TRACE
          LDK    /RS/K.LSMLV
          RAML   DSTER       MESSAGE LENGTH ERROR
 DST30    CFM    DST40,CHN   IF NOT CHANNEL ERROR
          LDK    /RS/K.LSCEF
          RAML   DSTER       SET CHANNEL ERROR
 DST40    RJM    GST         GET GENERAL STATUS
          NJK    DSTX        EXIT IF GST ERRORS
          LDDL   GNSTAT
          SHN    17-S.GE
          PJN    DST50       IF NO ERRORS GETTING DETAILED STATUS
          LDK    /RS/K.LSGSE
          RAML   DSTER       SET GENERAL STATUS ERROR
          RJM    IGS         INCLUDE GENERAL STATUS
 DST50    LDML   DSTER
          NJN    DST60       IF ERRORS GETTING DETAIL STATUS
          LDK    /RS/K.LDS
          STML   DSTER       UPDATE DETAIL STATUS INCLUDED
          LMC    -0          BIT IN RESPONSE BUFFER
          STML   DSTRC
          LDML   LRS+/RS/P.LDS
          LPML   DSTRC
          ADML   DSTER
          STML   LRS+/RS/P.LDS
          LDN    0
          UJK    DSTX        EXIT NO ERRORS

 DST60    RJM    SSC         SET SYMPTOM CODES
          LDK    /RS/K.LOF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDK    /RS/K.LRDS
          STML   LRS+/RS/P.OPTP   STORE OPERATION TYPE
          SOML   DSTRC       DECREMENT RETRY COUNT
          ZJN    DST70       IF UNRECOVERED
          LDN    REC.I       SET INTERMEDIATE ERROR
          STML   LRS+/RS/P.RETSUC
          LDN    FTRY
          SBML   DSTRC       RETRY COUNT
          STML   LRS+/RS/P.RETCT
          RJM    SLM         SEND LOG MESSAGE
          UJK    DST10       RETRY

 DST70    RJM    SRU         SET RECOVERY SUCCESS
          LDN    SC.PPR
          STDL   STCHNG      RESET ICA
          RJM    SLM         SEND LOG MESSAGE
          LDN    1
          UJK    DSTX        EXIT WITH ERROR

 DSTRC    BSSZ   1           RETRY COUNT
 DSTER    BSSZ   1           SYMPTOM CODES
 DUR      SPACE  4,16
**        DUR - DELINK UNIT REQUEST FROM QUEUE.
*
*         THIS ROUTINE DELINKS THE CURRENT UNIT REQUEST
*         FROM THE APPROPRIATE QUEUE AND UPDATES THE UNIT QUEUE HEAD POINTER
*         TO POINT TO THE NEXT REQUEST IN THE QUEUE.
*
*         ENTRY  (CM.URQ) = REFORMATTED ADDRESS OF REQUEST QUEUE.
*
*         USES   P5, T1 - T4, T5, T7.
*
*         CALLS  CSW, CUL, SUL.
*
*         MACROS LOADC.

 DUR      SUBR               ENTRY/EXIT

*         UPDATE UNIT QUEUE HEAD POINTER.

 DUR20    BSS    0
          IFEQ   DRTYP,1     IF MDI
          LOADC  CM.URQ      CM ADDRESS OF UNIT REQUEST QUEUE
          ENDIF
          IFEQ   DRTYP,2     IF ICA2
          LRDL   CM.URQ      CM ADDRESS OF UNIT REQUEST QUEUE
          LDDL   CM.URQ+1
          ENDIF
          ERRNZ  /UQD/C.HEAD OFFSET TO UNIT QUEUE HEAD POINTER IS NOT ZERO
*         ADN    /UQD/C.HEAD OFFSET TO UNIT QUEUE HEAD POINTER
          CWML   RQ+/URQ/P.NEXTLN,ONE  UPDATE UNIT QUEUE HEAD POINTER

          LDML   RQ+/URQ/P.NEXT     NEXT UNIT REQUEST (UPPER PART)
          ADML   RQ+/URQ/P.NEXT+1   NEXT UNIT REQUEST (LOWER PART)
          NJK    DURX        IF OTHER UNIT REQUESTS IN THIS QUEUE

*         CLEAR UNIT QUEUE TAIL POINTER TO SHOW THAT THERE ARE NO OTHER UNIT
*         REQUESTS IN THIS QUEUE.  IF A NEW UNIT REQUEST IS PLACED IN THE
*         QUEUE WHILE THIS IS BEING DONE, UNIT QUEUE HEAD POINTER WILL BE
*         UPDATED INSTEAD.

          LDK    CM.QT
          STDL   T7          UNIT QUEUE TAIL POINTER
          LDN    0
          STDL   T5          OFFSET TO UNIT QUEUE TAIL POINTER (NO OFFSET)
          LDK    RQ+/URQ/P.THISPV
          STDL   P5          ADDRESS OF WORD CONTAINING PVA OF CURRENT REQUEST
          LDK    NIL         NIL POINTER
          RJM    CSW         COMPARE-SWAP (UNIT QUEUE TAIL POINTER CONTENTS)
          ZJK    DURX        IF COMPARE-SWAP SUCCEEDED

*         COMPARE-SWAP FAILED (A NEW REQUEST CAME IN).
*         RE-READ NEXTLN/NEXT WORD OF REQUEST TO GET THE NEW REQUEST POINTER.

          IFEQ   DRTYP,1     IF MDI
          LOADF  RS+/RS/P.REQ  RMA OF THE CURRENT REQUEST
          ENDIF
          IFEQ   DRTYP,2     IF ICA2
          LRML   RS+/RS/P.REQ  RMA OF THE CURRENT REQUEST
          LDML   RS+/RS/P.REQ+1
          SHN    -3
          ENDIF
          ADN    /URQ/C.NEXT OFFSET TO NEXTLN/NEXT WORD
          CRML   RQ+/URQ/P.NEXTLN,ONE  READ UNIT REQUEST NEXTLN/NEXT WORD
          UJK    DUR20       UPDATE UNIT QUEUE HEAD POINTER
          SPACE  4,10
**        DVE - DATA VERIFICATION ERROR
*
*         THIS ROUTINE LOGS A DATA VERIFICATION ERROR
*         AND DOWNS THE ICA.
*
*         ENTRY  NONE
*
*         EXIT   NONE
*
*         USES   NONE
*
*         CALLS  SEI SOT SSC SLM
          SPACE  4,10
 DVE      SUBR               ENTRY/EXIT
          STML   LRS+/RS/P.OPTP   STORE OPERATION TYPE
          LDK    /RS/K.LOF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDK    /RS/K.LSMT
          RJM    SSC         SET DATA VERIFICATION
          RJM    IGS         INCLUDE GENERAL STATUS
          LDN    SC.PPD
          STDL   STCHNG      DOWN ICA
          RJM    SLM         SEND LOG MESSAGE
          UJN    DVEX        EXIT
          EJECT
**        ERR - ERROR ROUTINE
*
*         THIS ROUTINE WILL CHECK FOR ERRORS FOLLOWING
*         AN INPUT/OUTPUT OPERATION IN OPERATIONAL MODE.
*         THREE ERROR RECOVERY COUNTERS ARE MAINTAINED
*         AS FOLLOWS.
*
*         COUNTER            ICA STATE/OPERATION
*         -------            -------------------
*         WRRTY              OPERATIONAL STATE/WRITE OPERATION
*         RDRTY              OPERATIONAL STATE/READ OPERATION
*         ERRR               OPERATIONAL STATE/SET ICA PARAMETERS
*
*
*         ENTRY  (A) = OPERATION CODE
*                (ERRCNT) = WORDS NOT TRANSFERED
*                (EXPD) = LENGTH EXPECTED
*                (ACTD) = ACTUAL LENGTH
*
*         EXIT   (A) = 0 IF NO  ERRORS
*                  <> 0 IF ERRORS
*                GNSTAT = GENERAL STATUS OF I/O REQUEST
*                ERRT1 = SYMPTOM CODES OF ERRORS
*                  IF RETRY COUNTER <> 0 RETRY REQUEST
*
*         USES   T9
*
*         CALLS  FRC GST DST IGS SSC SEI SOT SLM
          SPACE  4,10
 ERR      SUBR               ENTRY/EXIT
          STML   OTYPE       SAVE OPERATION CODE
          RJM    FRC         FIND PROPER RECOVERY COUNTER
          STDL   ERRRCP      SAVE
          LDN    0
          STDL   ERRT1       ZERO ERROR WORD
          LDML   OTYPE
          SBN    /RS/K.LREAD
          NJK    ERR50       JUMP IF WRITE
          LDC    WTDEACT*1200  WAIT FOR CHANNEL NOT ACTIVE
 ERR15    IJM    ERR30,CHN   IF CHANNEL NOT ACTIVE
          SBN    1
          NJN    ERR15       IF NOT TIMED OUT
          LDDL   ERRCNT
          NJN    ERR20       IF TRANSFER NOT COMPLETE
          STML   ACTD+1
          LDC    100000B     MESSAGE LARGER THAN EXPECTED
          STML   ACTD
          UJN    ERR40       LOG ERROR

 ERR20    LDK    /RS/K.LSIT
          UJN    ERR45       SET INCOMPLETE TRANSFER

 ERR30    LDDL   ERRCNT
          ZJK    ERR80       IF TRANSFER COMPLETE
 ERR40    LDK    /RS/K.LSMLV
 ERR45    RADL   ERRT1       MESSAGE LENGTH VERIFICATION ERROR
          UJN    ERR80       CHECK CHANNEL FLAG

 ERR50    AJM    ERR60,CHN   IF CHANNEL ACTIVE
          LDK    /RS/K.LSCD
          RADL   ERRT1       SET CHANNEL NOT ACTIVE ERROR
          UJN    ERR80       CHECK CHANNEL FLAG

 ERR60    LDDL   ERRCNT
          ZJN    ERR65       IF TRANSFER COMPLETE
          LDK    /RS/K.LSIT  SET INCOMPLETE TRANSFER
          RADL   ERRT1
 ERR65    LDC    WTEMPTY*2000
 ERR70    EJM    ERR80,CHN   IF CHANNEL EMPTY
          SBN    1
          NJN    ERR70       IF NOT TIMED OUT
          LDK    /RS/K.LSCF
          RADL   ERRT1       SET CHANNEL NOT EMPTY
 ERR80    DCN    CHN+40B     DISCONNECT
          TRACE
          CFM    ERR90,CHN   IF NO CHANNEL ERROR
          LDK    /RS/K.LSCEF
          RADL   ERRT1       SET CHANNEL ERROR FLAG
 ERR90    RJM    GST         GET GENERAL STATUS
          NJK    ERR160      IF ERRORS GETTING STATUS
          LDDL   GNSTAT
          SHN    17-S.GE
          PJN    ERR100      IF NO GENERAL STATUS ERRORS
          LDK    /RS/K.LSGSE
          RADL   ERRT1       SET GENERAL STATUS ERRORS
          LDDL   GNSTAT
          STDL   ERRT2       SAVE STATUS
          RJM    DST         GET DETAILED STATUS
*         IGNORE DST ERRORS FOR NOW
          LDDL   ERRT2
          STDL   GNSTAT      RESTORE GENERAL STATUS
 ERR100   LDDL   ERRT1
          ADDL   STCHNG
          NJN    ERR110      IF ERRORS IN GST,DST OR IO
          LDML   OTYPE
          SBN    /RS/K.LREAD
          NJN    ERR105      IF NOT READ
          LDML   OSI,ICATDDP
          SBN    1
          ZJN    ERR107      IF OSI MODE
 ERR105   LDN    FTRY
 ERR107   STIL   ERRRCP      RESET RECOVERY COUNTER
          LDN    0
          UJK    ERRX        EXIT NO ERRORS

 ERR110   LDDL   ERRT1
          NJN    ERR120      IF I/O ERRORS
          LDN    1
          UJK    ERRX        IF STATE CHANGE BY DST OR GST

 ERR120   LPK    /RS/K.LSGSE
          ZJN    ERR130      IF NOT GENERAL STATUS ERRORS
          RJM    IGS         INCLUDE GENERAL STATUS IN RESPONSE
 ERR130   LDDL   ERRT1
          RJM    SSC         SET SYMPTOM CODE
          LDN    3
          STDL   T9
 ERR135   LDML   EXPD,T9     MOVE EXPECTED/ACTUAL
          STML   LRS+/RS/P.EXPD,T9
          SODL   T9
          PJN    ERR135      IF NOT DONE
          LDK    /RS/K.LOF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDML   OTYPE
          STML   LRS+/RS/P.OPTP   STORE OPERATION TYPE
          SBN    /RS/K.LREAD
          NJN    ERR140      IF NOT READ
          LDML   OSI,ICATDDP
          ZJN    ERR140      IF NOT OSI MODE
          AOIL   ERRRCP
          STML   LRS+/RS/P.RETCT
          LDN    REC.I
          STML   LRS+/RS/P.RETSUC
          UJN    ERR150      SEND LOG MESSAGE

 ERR140   SOIL   ERRRCP
          RJM    SIU         SET RECOVERY SUCCESS
 ERR150   RJM    SLM         SEND LOG MESSAGE
 ERR160   LDN    0
          STDL   ERRCNT
          LDN    1
          UJK    ERRX        ERROR EXIT
 FAG      SPACE  4,10
**        FAG - FUNCTION AND TIMEOUT ACTIVE CHANNEL FOR GENERAL STATUS
*
*         THIS ROUTINE WILL FUNCTION THE CHANNEL FOR GENERAL STATUS AND
*         TIMEOUT THE ACTIVE CHANNEL. UNRECOVERED TIMEOUTS CAUSE THE ICA
*         TO BE DOWNED.
*
*         ENTRY - (FAGDEM) <> 0, IF ERROR LOGGING IS DISABLED
*
*         EXIT  - (A) = 0, FUNCTION ISSUED, NORMAL COMPLETION
*                 (A) <> 0, FUNCTION TIMEOUT.
*                 (T1) = RETRY COUNTER (=FTRY, IF NO RETRIES NEEDED)
*
*         USES T1
*
*         CALLS  SSC SLM SRU
          SPACE  4,10
 FAG      SUBR               ENTRY/EXIT
          LDN    FTRY
          STDL   T1          RETRY COUNTER
 FAG10    LDK    F.GS
          FAN    CHN         ISSUE FUNCTION
          LDC    FTOLEN*1000 LOOP IS ONE MICRO SECOND
 FAG30    IJM    FAG40,CHN
          SBN    1
          SHN    18          NO OP TO LENGTHEN LOOP
          NJN    FAG30       IF TIMEOUT NOT EXPIRED
          DCN    CHN+40B
          SODL   T1          DECREMENT RETRY COUNTER
          ZJN    FAG50       IF UNRECOVERED ERROR
          SBN    FTRY-1
          ADML   FAGDEM
          NJN    FAG10       IF NOT FIRST ERROR OR MESSAGES DISABLED
          LDK    F.GS
          STML   LRS+/RS/P.FUNTO  PUT FUNCTION CODE IN RESPONSE
          CFM    FAG10,CHN
          LDK    /RS/K.LSCEF
          RJM    SSC         SET SYMPTOM CODE
          UJK    FAG10       RETRY FUNCTION

 FAG40    LDML   LRS+/RS/P.FUNTO
          ZJN    FAG60       EXIT IF NO ERRORS
          LDDL   T1
 FAG50    RJM    SRU         SET RECOVERY STATUS
          LDK    /RS/K.LFTO
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDDL   T1
          ZJN    FAG70       IF UNRECOVERED
          RJM    SLM         SEND LOG MESSAGE
          LDN    0
 FAG60    UJK    FAGX        EXIT

 FAG70    LDN    SC.PPD
          STDL   STCHNG
          RJM    SLM         SEND LOG MESSAGE
          LCN    0
          UJK    FAG60       RETURN ERROR

 FAGDEM   CON    0           <> 0, IF ERROR LOGGING IS SUPPRESSED
          SPACE  4,20
**        FAN - FUNCTION AND TIMEOUT ACTIVE CHANNEL
*
*         ERROR RECOVERY ON FUNCTION TIMEOUT IS HANDLED AS FOLLOWS.
*         1. ALL FUNCTIONS ARE RETRIED UP TO TWO MORE TIMES.
*         2. ALL FUNCTION TIMEOUTS ARE LOGGED.
*         3. IF FAILING FUNCTION WAS  RESET THEN DOWN ICA.
*         4. FOR FUNCTION TIMEOUT IN RESET STATE DOWN ICA.
*         5. FOR ALL ICA STATES OTHER THAN RESET THE ICA IS RESET.
*
*
*         ENTRY - (A) = FUNCTION CODE
*
*         EXIT  - (A) = 0, FUNCTION ISSUED, NORMAL COMPLETION
*                 (A) <> 0, FUNCTION TIMEOUT.
*                 (T1) = RETRY COUNTER (=FTRY, IF NO RETRIES NEEDED)
*
*         USES T1
*
*         CALLS  CSC SSC SLM SRU
          SPACE  4,10
 FAN      SUBR               ENTRY/EXIT
          STDL   FUNCD       SAVE FUNCTION CODE
 D.       IFEQ   DEBUG,1
          AOML   HISTINX     INDEX INTO FUNCTION HISTORY TABLE
          LPN    7
          STDL   T1
          LDDL   FUNCD       FUNCTION CODE
          STML   FUNHIST,T1  STORE IN TABLE
          STML   LSTFUNC     LAST FUNCTION CODE SAVED
 D.       ENDIF
          STML   PREFC       SAVE LAST NON GENERAL STATUS FUNCTION CODE
          LDN    FTRY
          STDL   T1          RETRY COUNTER
 FAN10    LDDL   FUNCD
          FAN    CHN         ISSUE FUNCTION
 FAN20    LDC    FTOLEN*1000 LOOP IS ONE MICRO SECOND
 FAN30    IJM    FAN40,CHN
          SBN    1
          SHN    18          NO OP TO LENGTHEN LOOP
          NJN    FAN30       IF TIMEOUT NOT EXPIRED
          LDML   DBUGM
          ZJN    FAN20       IF DEBUG MODE
          DCN    CHN+40B
          TRACE
 D.       IFEQ   DEBUG,1
          AOML   FTOCNT      INCREMENT FUNCTION TIMEOUT COUNTER
 D.       ENDIF
          SODL   T1          DECREMENT RETRY COUNTER
          ZJK    FAN70       IF UNRECOVERED ERROR
          SBN    FTRY-1
          NJN    FAN10       IF NOT FIRST ERROR
*         LDN    0
          STML   FANCEF
          CFM    FAN10,CHN
          LDK    /RS/K.LSCEF
          STML   FANCEF
          UJK    FAN10       RETRY FUNCTION

 FAN40    LDDL   T1
          SBN    FTRY
          ZJN    FAN60       EXIT IF NO ERRORS
          TRACE  (FAN,FUNCD,T1)
          LDDL   T1
 FAN50    RJM    SRU         SET RECOVERY STATUS
          LDK    /RS/K.LFTO
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDML   FANCEF
          RJM    SSC         SET SYMPTOM CODE
          LDDL   FUNCD
          STML   LRS+/RS/P.FUNTO  PUT FUNCTION CODE IN RESPONSE
          RJM    SLM         SEND LOG MESSAGE
          LDDL   STCHNG      STCHNG <> 0 IF ERRORS
 FAN60    UJK    FANX        EXIT

 FAN70    RJM    CSC         CHECK STATE CHANGE
          NJK    FAN60       IF STATE CHANGED
          LDDL   LSTATE
          SBN    ST.IDLE
          PJN    FAN90       IF IDLE OR OPERATIONAL
 FAN80    LDN    SC.PPD
          UJN    FAN100      DOWN ICA

 FAN90    LDC    F.RESET
          SBDL   FUNCD
          ZJN    FAN80       IF RESET FUNCTION
          LDN    SC.PPR      RESET ICA
 FAN100   STDL   STCHNG
          LDN    0
          UJK    FAN50       LOG ERROR

 FANCEF   BSSZ   1           CHANNEL ERROR FLAG
          SPACE  4,10
**        FAW - FUNCTION THE CHANNEL AND WAIT FOR DATA
*
*         ERRORS ENCOUNTERED ACTIVATING THE CHANNEL ARE
*         LOGGED AND A RESET IS REQUESTED.
*
*         ENTRY - (A) = FUNCTION CODE
*
*         EXIT  - (A) = 0, NORMAL COMPLETION - FUNCTION IS ISSUED,
*                          CHANNEL IS ACTIVE AND FULL.
*                 (A) <> 0, FUNCTION TIMEOUT OR CHANNEL ERROR
*
*         USES   NONE
*
*         CALLS  FAN CFE CIE SLM
          SPACE  4,10
 FAW      SUBR               ENTRY/EXIT
          IFEQ   SIM,1
          LDN    0
          UJN    FAWX
          ENDIF
          STML   STBI        SAVE FUNCTION FOR ERROR PROCESSING
          RJM    FAN
          NJN    FAWX        RETURN IF FUNCTION TIMEOUT
          ACN    CHN
          LDC    WTFULL*1000 LOOP = 1 MILLISECOND
 FAW10    IJM    FAW40,CHN
          EJM    FAW30,CHN
          LDN    0
          UJN    FAWX        EXIT - (A) = 0

 FAW30    SBN    1
          NJN    FAW10
          LDC    FAWT-2      TABLE OF OP CODES
          RJM    STB         FIND OPERATION CODE
          RJM    CEE         CHANNEL DID NOT GO FULL
          UJN    FAW50       SEND MESSAGE AND RESET ICA

*         CHANNEL ERROR

 FAW40    LDC    FAWT-2      TABLE OF OP CODES
          RJM    STB         FIND OPERATION CODE
          RJM    CIE         CHANNEL INACTIVE AFTER  ACN
 FAW50    LDN    SC.PPR
          STDL   STCHNG      RESET ICA
          RJM    SLM         SEND LOG MESSAGE
          LDN    1
          UJK    FAWX        EXIT - (A) <> 0
          SPACE  3
*         TABLE EQUATING FUNCTION CODES TO OPERATION CODES
*
 FAWT     CON    F.DUMP,/RS/K.LDM
          CON    F.DS,/RS/K.LRDS
          CON    F.READ,/RS/K.LREAD
          CON    F.RDIAG,/RS/K.LRDC
          CON    F.CHAATC,/RS/K.LCAT
          CON    F.RCC,/RS/K.LRCC
          CON    0
          SPACE  4,10
**        FDR - FIND AND DELINK REQUEST
*
*         THIS ROUTINE SEARCHES THE LINKED LIST OF REQUESTS
*         FOR THE CURRENT REQUEST AND DELINKS IT.
*
*         ENTRY  (A) + (R) = CM ADDRESS OF FIRST REQUEST ON QUEUE
*                WC = 2.
*
          SPACE  4,10
 FDR      SUBR               ENTRY/EXIT
 FDR10    STDL   CM.PPR+1
          SRDL   CM.PPR      SAVE CM ADDRESS
          CRML   PVA,WC      READ NEXT PVA + RMA
          LDML   RMA
          ADML   RMA+1
          ZJN    *           *** IF NOT ON LIST
          LDML   RMA
          SBML   RS+/RS/P.REQ
          NJN    FDR30       IF NOT CURRENT REQUEST
          LDML   RMA+1
          SBML   RS+/RS/P.REQ+1
          ZJN    FDR40       IF REQUEST FOUND
 FDR30    LRML   RMA
          LDML   RMA+1
          SHN    -3
          UJK    FDR10

 FDR40    LRML   RMA
          LDML   RMA+1
          SHN    -3
          CRML   PVA,WC      READ CURRENT REQUEST
          LRDL   CM.PPR
          LDDL   CM.PPR+1
          CWML   PVA,WC      DELINK REQUEST
          UJK    FDRX        EXIT
          IFEQ   BRK,1
          SPACE  4,10
**        FORMA - FORMAT REAL MEMORY ADDRESS.
*
*         ENTRY  (A) = ADDRESS OF RMA.
*
*         EXIT   (CMADR - CMADR+2) = REFORMATTED RMA.
*                -ADDRESS-  WORD 0, BITS 0-13 AND
*                           WORD 1, BITS 3-15 ARE REFORMATTED TO:
*                  -CMADR-  WORD 0, BITS 0-9,
*                           WORD 1, BITS 0-11,
*                           WORD 2, BITS 0-5.
*


 FORMA    SUBR               ENTRY/EXIT
          STDL   C1
          LDML   1,C1
          LPN    7
          NJN    *           RMA ADDRESS ERROR, TEMPORARY HALT
          LDIL   C1
          LPN    37B
          SHN    16
          LMML   1,C1
          SHN    9
          STD    CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   C1
          SHN    -5
          STD    CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMC    400000B
          UJN    FORMAX
          ENDIF
          SPACE  4,10
**        FRC - FIND RECOVERY COUNTER
*
*         THIS ROUTINE WILL FIND AND RETURN THE ADDRESS OF
*         THE RECOVERY COUNTER FOR THE APPROPRIATE ICA STATE/OPERATION.
*         THE FOLLOWING COUNTERS ARE DEFINED.
*
*         COUNTER            ICA STATE/OPERATION
*         -------            -------------------
*         WRRTY              OPERATIONAL STATE/WRITE OPERATION
*         RDRTY              OPERATIONAL STATE/READ OPERATION
*         ERRR               SET ICA PARAMETERS AND SEND ETHERNET ADDRESS
*
*         ENTRY  (A) = OPERATION TYPE
*
*         EXIT   (A) = ADDRESS OF RECOVERY COUNTER
*
*         USES   NONE
*
*         CALLS  STB
          SPACE  4,10
 FRC      SUBR               ENTRY/EXIT
          STML   STBI        SAVE OPERATION TYPE FOR TABLE SEARCH
          LDC    FRCT-2      TABLE ADDRESS
          RJM    STB         FIND COUNTER
          UJN    FRCX        EXIT
          SPACE  2
 FRCT     CON    /RS/K.LWRT,WRRTY
          CON    /RS/K.LREAD,RDRTY
          CON    /RS/K.LSIP,ERRR
          CON    /RS/K.LSEA,ERRR
          CON    0
 GRB      SPACE  4,22
**        GRB - GET READ BUFFER.
*
*         THIS ROUTINE OBTAINS ENOUGH CM BUFFERS FROM THE BUFFER POOLS TO READ
*         A PDU *TBYTS* LONG.  THE BUFFER LENGTH/ADDRESS PAIRS ARE STORED
*         SEQUENTIALLY IN THE RESPONSE BUFFER.
*
*         PROGRAMMER NOTE -- BUFFERS 2 - N ARE ALLOCATED FIRST.  BUFFER 1 IS
*         ALLOCATED LAST.  THUS, ALL CHECKS FOR THE FIRST BUFFER ARE REALLY
*         CHECKING TO SEE IF THE LAST BUFFER HAS BEEN ALLOCATED.
*
*         ENTRY  (TBYTS) = TOTAL BYTES TO ALLOCATE CM BUFFERS FOR.
*
*         EXIT   (A) = 0, IF NO BUFFERS,
*                    <> 0, IF BUFFERS OBTAINED.
*                (BUFLEN) = LENGTH OF THE FIRST BUFFER IN THE CHAIN.
*                (CML) = 0 = OFFSET TO THE FIRST LENGTH/ADDRESS PAIR.
*                (CMLISTL) = NUMBER OF LENGTH/ADDRESS PAIRS.
*                (CM.CRB) = REFORMATTED FIRST BUFFER ADDRESS IN THE CHAIN.
*                (DATADD) = REFORMATTED FIRST DATA ADDRESS IN FIRST BUFFER.
*
*         USES   T1, T2, T3.
*
*         CALLS  CBP, SBI.


 GRB      SUBR               ENTRY/EXIT
 GRB05    LDN    0           START WITH SMALL BUFFERS
          STDL   FSTBD       INITIALIZE BUFFER POOL INDEX

          LDML   BPDSIZE,FSTBD   1 * BUFFER POOL SIZE
          SHN    1               2 * BUFFER POOL SIZE
          ADML   BPDSIZE,FSTBD   3 * BUFFER POOL SIZE
          SBML   TBYTS       COMPARE REMAINDER WITH SIZE OF 3 SMALL BUFFERS
          MJN    GRB20       IF 3 BUFFERS ARE NOT LARGE ENOUGH
 GRB10    RJM    CBP         CHECK IF BUFFERS IN POOL
          NJN    GRB50       IF BUFFER AVAILABLE

 GRB20    AODL   FSTBD
          SBML   NUMBP
          MJN    GRB10       IF MORE POOLS TO LOOK AT

*         EXIT SINCE ALL POOLS ARE EMPTY.

          LDN    0
 GRB30    UJK    GRBX        EXIT - (A) = 0, NO BUFFERS

*         ADD BUFFER TO BUFFER LIST.

 GRB50    BSS    0
          IFEQ   DEBUG,1
          AOML   BUFCNT,FSTBD    TOTAL NUMBER OF CM BUFFERS USED
          ENDIF

          AODL   CMLISTL     INCREMENT FOR A NEW LENGTH/ADDRESS PAIR
          LDML   BPDSIZE,FSTBD   BUFFER POOL SIZE
          SBML   TBYTS       COMPARE WITH REMAINING BYTES
          MJN    GRB60       IF NOT FIRST BUFFER

*         INITIALIZE FOR FIRST BUFFER.

          LDN    0
          STML   CML
          STDL   T1          OFFSET TO LENGTH/ADDRESS PAIR IN RESPONSE BUFFER
          UJN    GRB70

*         INITIALIZE FOR ALL OTHER BUFFERS.

 GRB60    BSS    0
          ERRNZ  4-C.BP*2    BUFFER POOL (SIZE) DEPENDENCY ERROR
          LDN    4
          RAML   CML
          STDL   T1          OFFSET TO LENGTH/ADDRESS PAIR IN RESPONSE BUFFER
          SBN    MAXRS*4-/RS/C.BUFPVA*4   COMPARE WITH MAXIMUM RESPONSE LENGTH
          PJN    *           IF BEYOND END OF THE RESPONSE BUFFER

*         UPDATE ADDRESS (PVA) IN LENGTH/ADDRESS PAIR OF RESPONSE BUFFER.

 GRB70    BSS    0
          LDN    0
          STDL   T3          NO PVA YET
          LDN    3
          STDL   T2          HIGH PORTION OF BUFFER POOL PVA ADDRESS (1..3)
          RADL   T1          HIGH PORTION OF LENGTH/ADDRESS FIELD IN RESPONSE

 GRB75    BSS    0
          LDML   BP+/BP/P.PVA-1,T2   BUFFER POOL PVA ADDRESS FIELD
          STML   RS+/RS/P.BUFPVA-1,T1   RESPONSE PVA ADDRESS FIELD
          RADL   T3          INCLUDE A PVA FIELD
          SODL   T1          OFFSET TO NEXT PORTION OF LENGTH/ADDRESS FIELD
          SODL   T2          OFFSET TO NEXT PORTION OF BUFFER POOL PVA ADDRESS
          NJK    GRB75       IF MORE TO DO
          LDDL   T3          ALL PVA FIELDS
          ZJN    *           IF BAD PVA

*         UPDATE CONTAINER RMA TABLE.

          ERRNZ  4-C.BP*2    BUFFER POOL (SIZE) DEPENDENCY ERROR
          LDDL   T1          OFFSET TO LENGTH/ADDRESS PAIR IN RESPONSE BUFFER
          SHN    -1          CONVERT TO CONTAINER RMA TABLE INDEX
          STDL   T2
          LDML   BP+/BP/P.RMA   UPPER PART OF BUFFER POOL CONTAINER RMA ADDRESS
          STML   BPRMA,T2    MOVE TO CONTAINER RMA TABLE
          STDL   T3          INCLUDE A RMA FIELD
          LDML   BP+/BP/P.RMA+1   LOWER PART OF BUFFER POOL CONTAINER RMA ADDRESS
          STML   BPRMA+1,T2    MOVE TO CONTAINER RMA TABLE
          RADL   T3          INCLUDE A RMA FIELD
          ZJN    *           IF BAD RMA

*         UPDATE DATA LENGTH IN LENGTH/ADDRESS PAIR OF RESPONSE BUFFER.

          LDML   BPDSIZE,FSTBD   LENGTH OF BUFFER POOL BUFFER
          STML   RS+/RS/P.DLEN,T1   RESPONSE BUFFER LENGTH FIELD
          STML   FBSIZE      MAXIMUM SIZE OF FIRST BUFFER (WHEN LOOP IS DONE)
          LDML   TBYTS       REMAINING BYTES
          SBML   FBSIZE      COMPARE WITH MAXIMUM SIZE OF BUFFER
          PJN    GRB80       IF MORE TO ALLOCATE

*         ALL BUFFERS HAVE BEEN ALLOCATED.  CALCULATE THE CORRECT BUFFER SIZE
*         FOR THE FIRST BUFFER.

          LDML   TBYTS       REMAINING BYTES
          STML   RS+/RS/P.DLEN   FIRST BUFFER SIZE (BYTES USED IN BUFFER)
          LDN    0           NO BYTES LEFT TO BE ALLOCATED FOR

 GRB80    STML   TBYTS       UPDATE TOTAL BYTES TO ALLOCATE CM BUFFERS FOR
          NJK    GRB05       IF MORE TO ALLOCATE
          RJM    SBI         INITIALIZE BUFFER POINTERS
          UJK    GRBX        EXIT
          EJECT
**        GST - GENERAL STATUS.
*
*         THIS ROUTINE OBTAINS THE ICA GENERAL STATUS, AND WAITS FOR BUSY
*         TO CLEAR. THE WAIT FOR BUSY IS EQUAL TO *GSBUSY* MILLISECONDS.
*
*
*         THE FOLLOWING TABLE DEFINES THE ERRORS DETECTED AND THE
*         RECOVERY ACTION TAKEN FOR EACH ERROR.
*
*          ENTRY STATE\ERROR  1   2   3   4   5   6   7
*         +-----------------+---+---+---+---+---+---+---+
*         | RESET           |   |   | D | F | F | F | F |
*         +-----------------+---+---+---+---+---+---+---+
*         | DIAGNOSTICS     | A | C | D | F | F | F | F |
*         +-----------------+---+---+---+---+---+---+---+
*         | IDLE            | A | C | D | F | F | F | F |
*         +-----------------+---+---+---+---+---+---+---+
*         | OPERATIONAL     | A | C | D | F | F | F | F |
*         +-----------------+---+---+---+---+---+---+---+
*         | 77B             |   |   | E | F | F | F | F |
*         +-----------------+---+---+---+---+---+---+---+
*
*
*                           ERROR TYPES
*         1.  ICA INITIATED STATE CHANGE TO RESET.
*         2.  ICA INITIATED STATE CHANGE TO OTHER THAN RESET.
*         3.  BUSY TIMEOUT.
*         4.  CHANNEL DISCONNECT.
*         5.  GENERAL STATUS UNAVAILABLE TIMEOUT.
*         6.  FUNCTION TIMEOUT.
*         7.  CHANNEL PARITY ERROR.
*
*
*                           RECOVERY ACTIONS
*         A. RESET ICA
*         C. RESET ICA, LOG INVALID STATE TRANSITION
*         D. RESET ICA, LOG GENERAL STATUS BUSY TIMEOUT
*         E. RETURN WITH (A) NEGATIVE
*         F. RETRY UP TO TWO MORE TIMES IF UNSUCCESSFUL DOWN ICA,
*            LOG ERROR
*
*         ENTRY  BUSYMP = # OF TIMES TO MULTIPLY NORMAL WAIT FOR NOT BUSY
*                LSTATE = LAST KNOWN STATE OF ICA. USED TO DETERMINE IF
*                         THE ICA CHANGED STATES.
*                         IF LSTATE = 77B DONT CHECK STATE CHANGE OR LOG
*                         BUSY TIMEOUT. THIS WILL BE DONE BY CALLER.
*
*         EXIT   (A) = 0, IF NO ERRORS
*                    <> 0, IF ERROR
*                    < 0  IF BUSY TIMEOUT NOT LOGGED
*                GNSTAT = GENERAL STATUS IF NO ERRORS
*
*         USES   T1 T2 T7 P6
*
*         CALLS  FAG SIU SEI SOT SSC SLM BTE
*
          SPACE  4,10

 GST      SUBR               ENTRY/EXIT
          IFEQ   SIM,1
          LDC    1600B
 STAT     EQU    *-1
          STDL   GNSTAT
          LDN    0
          UJK    GSTX
          ENDIF
          LDN    0
          STDL   P6          SET ERRORS TO ZERO
          LDN    FTRY
          STDL   T7          RETRY COUNTER
 GST10    RJM    FAG         FUNCTION FOR GENERAL STATUS
          NJN    GSTX        IF FUNCTION TIMEOUT OR OTHER ERROR
          ACN    CHN
          LDDL   BUSYMP
          STDL   T2
          LDC    GSBUSY*250  SET BUSY TIMER
          STDL   T8

 GST25    LDC    GSFULL*1000 WAIT FOR FULL
 GST30    AJM    GST40,CHN   IF CHANNEL ACTIVE
          LDK    /RS/K.LSCD  LOG CHANNEL NOT ACTIVE
          UJK    GST90       RETRY IF NOT UNRECOVERED

 GST40    FJM    GST50,CHN   IF CHANNEL FULL
          SBN    1
          NJN    GST30       IF NOT TIMED OUT
          LDN    /RS/K.LGSAT
          STML   LRS+/RS/P.ERRID
          LDML   PREFC
          STML   LRS+/RS/P.PFUNC SAVE PREVIOUS FUNCTION CODE
          UJK    GST100      LOG ERROR AND CHECK RECOVERY STATUS

 GST50    IAN    CHN+40B     INPUT STATUS
          IJM    GST30,CHN   IF CHANNEL INACTIVE
          CFM    GST70,CHN   IF NO CHANNEL ERROR
          LDK    /RS/K.LSCEF LOG CHANNEL ERROR
          UJK    GST90       RETRY IF NOT UNRECOVERED

 GST70    STDL   GNSTAT      SAVE STATUS
          RJM    MSC         MONITOR STATE CHANGE
          ZJN    GST85       STATE DID NOT CHANGE
          DCN    CHN+40B     DISCONNECT
          LDN    1           SET ERROR STATUS
          UJK    GSTX        ERROR EXIT

 GST85    LDDL   GNSTAT
          SHN    17-S.BUSY
          MJK    GST110      IF ICA BUSY
          DCN    CHN+40B
          LDN    0
          UJK    GSTX        EXIT NO ERRORS

*         ERROR ENCOUNTERED READING STATUS
*         DETERMINE RECOVERY ACTION AND LOG ERROR

 GST90    RJM    SSC         SET SYMPTOM CODE
          LDK    /RS/K.LOF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDK    /RS/K.LRGS
          STML   LRS+/RS/P.OPTP   STORE OPERATION TYPE
 GST100   SODL   T7          ENTERED HERE IF NOT AVAILABLE
          RJM    SIU         SET RESPONSE STATUS
          DCN    CHN+40B
          LDDL   T7
          NJN    GST105      IF NOT UNRECOVERED
          LDN    SC.PPD
          STDL   STCHNG
 GST105   RJM    SLM         SEND LOG MESSAGE
          LDDL   STCHNG
          ZJK    GST10       RETRY GENERAL STATUS
          UJK    GSTX        ELSE EXIT WITH ERROR

*         BUSY STILL SET, CHECK IF TIMEOUT OCCURED
*         AND RETURN ERROR IF SO

 GST110   LDML   DBUGM
          ZJK    GST25       IF DEBUG MODE
          SODL   T8          TIMEOUT COUNTER
          NJK    GST25       IF NOT TIMEOUT CONTINUE
          LDC    GSBUSY*250
          STDL   T8          RESET TIMER
          TRACE  (GST,GNSTAT)
          SODL   T2          CHECK IF MULTIPLE LOOPS
          NJK    GST25       IF SO CONTINUE
          DCN    CHN+40B     DISCONNECT CHANNEL
          LDDL   LSTATE
          SHN    12
          MJK    GSTX        EXIT IF NOT LOGGING BUSY
          LDN    SC.PPR
          STDL   STCHNG      RESET ICA
          RJM    BTE         LOG BUSY TIMEOUT
          LDN    1
          UJK    GSTX        EXIT WITH ERRORS
 ILR      SPACE  4,10
**        ILR - INITIALIZE LOG RESPONSE.
*
*         INITIALIZE THE BUFFER FOR SENDING LOG RESPONSES.
*
*         USES   T9
          SPACE  4,10
 ILR      SUBR               ENTRY/EXIT
          LDN    P.RS
          STDL   T9
 ILR10    LDN    0
          STML   LRS,T9
          SODL   T9
          PJN    ILR10       IF MORE TO CLEAR
          LDML   DEVID
          STML   LRS+/RS/P.DEVID
          LDN    REC.U
          STML   LRS+/RS/P.RETSUC
          UJN    ILRX        EXIT
 IOS      SPACE  4,16
**        IOS - INITIALIZE OPERATIONAL STATE
*
*         INITIALIZE THE DRIVER FOR OPERATIONAL STATE BY
*         DETERMINING THE PROPER RECORD TYPE TO BE READ.
*         IF OPERATIONAL STATE AND OSI MODE ALSO SEND THE
*         PROPER FLOW CONTROL FUNCTION.
*
*         ENTRY  (OSOSI) = 1, IF OPERATIONAL
*                (GFCFC) = FLOW CONTROL FUNCTION TO SEND IF OSI MODE
*
*         EXIT   (A) = 0, IF NO ERRORS
*                    <> 0, IF ERRORS
*                (HDRTYP) = ADDRESS OF TABLE DESCRIBING HEADER
*
*         CALLS  FAN
          SPACE  4,10
 IOS10    LDN    0
          STML   RDRTY
          LDC    TCNH
 IOS30    STDL   HDRTYP      SAVE POINTER TO HEADER DESCRIPTOR
          LDN    0

 IOS      SUBR               ENTRY/EXIT
          LDN    0
          STDL   STCHNG
          LDML   OSOSI
          ZJN    IOS10       IF NOT OPERATIONAL
          LDML   GFCFC
          RJM    FAN         FUNCTION FOR FLOW CONTROL
          NJN    IOSX        EXIT IF ERRORS
          RJM    GST         WAIT FOR BUSY
          NJN    IOSX        EXIT IF ERRORS
          LDC    TCCH
          UJN    IOS30       CONTINUE

 MDC      SPACE  4,16
**        MDC - MOVE DATA TO CM.
*
*         THIS ROUTINE TRANSFERS DATA FROM THE PP I/O BUFFER
*         TO CM.
*
*         ENTRY  (RDCNT) = REMAINING FREE BYTES IN CM BUFFER (CM BYTES).
*                (BYTCNT) = NUMBER OF BYTES IN PP BUFFER.
*
*         EXIT   (A) = 0, IF DATA MOVE COMPLETE,
*                    <> 0, IF UNABLE TO MOVE DATA TO CM,
*                PP BUFFER EMPTY.
*                BYTE COUNT FIELD IN CM BUFFER UPDATED.
*
*         USES   T1, WC.
*
*         CALLS  SBI, SDB.
*
*         MACROS LOADC.


 MDC      SUBR               ENTRY/EXIT
          LDDL   BYTCNT      NUMBER OF BYTES IN PP BUFFER
          STDL   BYTS        NUMBER OF BYTES TO TRANSFER TO CM
          ZJN    MDCX        EXIT - IF NO DATA TRANSFERRED

 MDC10    BSS    0
          LDML   RDCNT       SPACE IN CM BUFFER
          NJN    MDC20       IF BUFFER NOT EMPTY
          AOML   CML         NEXT LENGTH/ADDRESS PAIR
          RJM    SBI         INITIALIZE FOR NEXT BUFFER
          LDML   RDCNT       SPACE IN CM BUFFER

 MDC20    BSS    0
          SBDL   BYTS        BYTES IN PP BUFFER
          PJN    MDC30       IF ROOM IN CM BUFFER FOR ALL
          LDML   RDCNT
          UJN    MDC40

 MDC30    BSS    0
          LDDL   BYTS

 MDC40    STML   BWRT        BYTES TO WRITE TO CM
          IFEQ   DRTYP,1     IF MDI
          LDDL   LSTATE      LAST STATE
          LMK    ST.OPER     COMPARE WITH OPERATIONAL STATE
          ZJN    MDC45       IF OPERATIONAL STATE
          ENDIF

          LDML   CML         LENGTH/ADDRESS PAIR OFFSET (ENTRY)
          ZJN    MDC41       IF FIRST BUFFER (IF FIRST LENGTH/ADDRESS PAIR)
          LDN    0           NO MORE BYTES OFF WORD BOUNDARY
          UJN    MDC45

 MDC41    BSS    0
          LDML   RS+/RS/P.XFER+1   LENGTH OF DATA (CM BYTES)
          LPN    1           ODD/EVEN
          ZJN    MDC43       IF EVEN NUMBER OF BYTES
          RJM    SDB         SHIFT DATA BUFFER

 MDC43    BSS    0
          LDML   RS+/RS/P.XFER+1   LENGTH OF DATA (CM BYTES)
          LPN    7
          ZJN    MDC45       IF PDU SIZE IS AN EXACT MULTIPLE OF CM WORDS
          STDL   T1          NUMBER OF BYTES OFF OF THE WORD BOUNDARY
          LDN    8           CM BYTES PER CM WORD
          SBDL   T1          TAKE AWAY CM BYTES THAT ARE OFF OF THE WORD BOUNDARY

 MDC45    BSS    0
          SHN    -1          CONVERT FROM CM BYTES TO PP WORDS
          STDL   T1          NUMBER OF EXTRA CM BYTES NEEDED FOR A WORD BOUNDARY
          LDDL   BYTCNT      NUMBER OF BYTES IN PP BUFFER
          SBDL   BYTS        ADJUST BY BYTES REMAINING IN PP BUFFER
          ADN    1           ADJUST FOR POSSIBLE ODD PDU SIZE
          SHN    -1          CONVERT FROM CM BYTES TO PP WORDS
          ADC    IOBUF
          SBDL   T1          ADJUST FOR BYTES NOT ON A WORD BOUNDARY
          STML   MDCW

          LDML   BWRT
          ADN    7
          SHN    -3
          STDL   WC          WORDS TO WRITE TO CM
          IFEQ   DRTYP,1     IF MDI
          LOADC  DATADD
          ENDIF
          IFEQ   DRTYP,2     IF ICA2
          LRDL   DATADD
          LDDL   DATADD+1
          ENDIF
          CWML   IOBUF,WC
 MDCW     EQU    *-1
          IFEQ   DRTYP,1     IF MDI
          STDL   DATADD+2  UPDATE CM BUFFER ADDRESS
          ENDIF
          LDML   RDCNT
          SBML   BWRT
          STML   RDCNT       UPDATE REMAINING CM BUFFER SPACE
          LDDL   BYTS
          SBML   BWRT
          STDL   BYTS        UPDATE REMAINING BYTES IN PP
          ZJN    MDC50       IF PP BUFFER EMPTY
          UJK    MDC10

 MDC50    BSS    0
          UJK    MDCX        EXIT
          SPACE  4,10
**        MLE - MESSAGE LENGTH ERROR.
*
*         THIS ROUTINE WILL LOG A MESSAGE LENGTH VERIFICATION ERROR OR
*         MAXIMUM LENGTH EXCEEDED ERROR. IT ALSO DESCONNECTS THE CHANNEL
*         AND RETURNS ANY BUFFERS WHICH MAY HAVE BEEN ASSIGNED.
*
*         ENTRY  (A)= SYMPTOM CODE
*
*         EXIT   (A) > 0
*
*         USES   T9
*
*         CALLS  PAUS SLM SSC USR
          SPACE  4,10
 MLE      SUBR               ENTRY/EXIT
          RJM    SSC         SET SYMPTOM CODE
          TRACE
          LDK    /RS/K.LOF   STORE ERROR ID
          STML   LRS+/RS/P.ERRID
          LDK    /RS/K.LREAD  STORE OPERATION TYPE
          STML   LRS+/RS/P.OPTP
          LDN    3
          STDL   T9
 MLE10    LDML   EXPD,T9     MOVE EXPECTED/ACTUAL
          STML   LRS+/RS/P.EXPD,T9
          SODL   T9
          PJN    MLE10       IF NOT DONE
          LDN    SC.PPR      RESET ICA
          STDL   STCHNG
          DCN    CHN+40B
          LDC    5000
          RJM    PAUS        PAUSE AFTER DISCONNECT
          RJM    SLM         SEND LOG MESSAGE
          UJK    MLEX        EXIT
          SPACE  4,20
**        MSC - MONITOR STATE CHANGE
*
*         THIS ROUTINE MONITORS THE ICA STATUS AND RETURNS AN ERROR IF
*         THE ICA STATE IS NOT WHAT IS EXPECTED.
*
*         ENTRY  LSTATE = LAST KNOWN STATE OF ICA. USED TO DETERMINE IF
*                         THE ICA CHANGED STATES.
*                         IF LSTATE = 77B DONT CHECK STATE CHANGE
*                         THIS WILL BE DONE BY CALLER.
*
*                GNSTAT = ICA GENERAL STATUS
*
*
*         EXIT   (A) = 0, IF NO ERRORS
*                   <> 0, IF ERROR
*
*         USES   T10
*
*         CALLS  SEI SLM
*
          SPACE  4,10

 MSC      SUBR               ENTRY/EXIT
          LDDL   LSTATE
          SBN    77B
          ZJN    MSCX        DONT CHECK STATE
          LDDL   GNSTAT
          SHN    -S.SB1
          LPN    3
          STDL   T10
          SBDL   LSTATE
          ZJN    MSCX        ICA DIDNT CHANGE STATES
          TRACE  (MSC,GNSTAT,LSTATE)
          LDDL   T10         GET STATE
          NJN    MSC10       NOT IN RESET STATE
          LDN    SC.ICA
          STDL   STCHNG      RESET INITIATED BY ICA
          UJK    MSCX        EXIT WITH ERROR

 MSC10    LDML   OSI,ICATDDP
          ZJN    MSC20       IF NOT OSI MODE
          LDDL   T10
          LMN    ST.OPER
          NJN    MSC20       IF NOT OPERATIONAL
          LDDL   LSTATE
          LMN    ST.IDLE
          NJN    MSC20       IF NOT CHANGE FROM IDLE
          LDDL   GNSTAT
          SHN    -S.SS1
          LPN    SSMASK
          LMN    OSS.WPN
          NJN    MSC20       IF NOT WAITING FOR PROTOCOL NEGOTIATION
          LDN    SC.OPER
          STDL   STCHNG
          UJK    MSCX        EXIT

 MSC20    LDN    SC.PPR
          STDL   STCHNG      INITIATE A PP RESET
          LDDL   T10
          STML   LRS+/RS/P.CURST LOG CURRENT STATE
          LDDL   LSTATE
          STML   LRS+/RS/P.PREST LOG PREVIOUS STATE
          LDK    /RS/K.LIVST
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          RJM    IGS         INCLUDE GENERAL STATUS
          RJM    SLM         SEND LOG RESPONSE
          LDN    1
          UJK    MSCX        EXIT
          SPACE  4,10
**        PAUS - PAUSE.
*
*         DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF MICROSECONDS.
*
*         ENTRY  (A) = NUMBER OF MICROSECONDS TO BE DELAYED.
*
*         USES   T9.
          SPACE  4,10
 PAUS     SUBR               ENTRY/EXIT
          IFEQ   SIM,1
          UJN    PAUSX
          ENDIF
 PAUS10   SBN    1           EACH ITERATION OF THIS SBN-LJM LOOP
          STDL   T9          EQUALS ONE MICRO SECOND
          ZJN    PAUSX       IF TIME EXPIRED
          ZJN    PAUSX       NEEDED TO EXTEND LOOP
          LJM    PAUS10
          SPACE  4,10
**        QPR - ISSUE QUEUE PREVIOUS READ
*
*         THIS ROUTINE IS CALLED WHEN A READ ERROR HAS BEEN DETECTED
*         BY THE PP. THE QUEUE PREVIOUS READ IS ISSUED TO NOTIFY
*         THE ICA TO RESEND THIS MESSAGE ON THE NEXT READ.
*
*         ENTRY  NONE
*
*         EXIT   (A) = 0 IF NO ERRORS
*                  <> 0 IF ERRORS
*
*         USES   NONE
*
*         CALLS  FAN ERR SSC
          SPACE  4,10
 QPR      SUBR               ENTRY/EXIT
          LDN    FTRY
          STML   ERRR        RESET RETRY COUNTER
 QPR10    LDN    F.QPREAD    QUEUE PREVIOUS READ
          RJM    FAN
          NJN    QPRX        EXIT IF FUNCTION TIMEOUT
          RJM    GST         GET GENERAL STATUS
          NJN    QPRX        IF GST ERROR EXIT
          LDDL   GNSTAT
          SHN    17-S.GE
          MJK    QPR20       IF ERRORS
          LDN    0
          UJK    QPRX        IF NO ERRORS

 QPR20    RJM    DST         GET DETAILED STATUS
          RJM    IGS         INCLUDE GENERAL STATUS
          LDN    /RS/K.LQPM
          STML   LRS+/RS/P.OPTP
          LDN    /RS/K.LOF
          STML   LRS+/RS/P.ERRID
          LDK    /RS/K.LSGSE
          RJM    SSC         LOG GENERAL STATUS ERROR
          SOML   ERRR
          RJM    SIU         SET RETRY SUCCESS
          RJM    SLM         SEND LOG MESSAGE
          LDDL   STCHNG
          NJK    QPRX        EXIT IF STATE CHANGING
          LDML   ERRR
          NJK    QPR10       IF MORE RETRY S
          LDDL   SC.PPR
          STDL   STCHNG      RESET ICA
          UJK    QPRX        EXIT
          SPACE  4,10
**        RBE - RESET BUSY TIMEOUT
*
*         THIS ROUTINE LOGS A RESET BUSY TIMEOUT ERROR
*
*         ENTRY  NONE
*
*         EXIT   NONE
*
*         USES   NONE
*
*         CALLS  SEI IGS SLM
          SPACE  4,8
 RBE      SUBR               ENTRY/EXIT
          LDK    /RS/K.LRBTO
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          RJM    IGS         INCLUDE GENERAL STATUS
          LDN    SC.PPD
          STDL   STCHNG      DOWN ICA
          RJM    SLM         SEND LOG MESSAGE
          UJN    RBEX        EXIT
 RCP      SPACE  4,10
**        RCP -  READ CHANNELNET PDU.
*
*         THIS ROUTINE READS THE REMAINDER OF A CHANNELNET PDU (THE HEADER
*         HAS ALREADY BEEN READ IN) AND FORWARDS THE ENTIRE PDU TO THE
*         PRE-ALLOCATED CM BUFFERS.
*
*         ENTRY  (/HD/P.HLB) = SIZE OF HEADER ALREADY READ (CM BYTES)
*                (BYTCNT) = NUMBER OF BYTES IN PP BUFFER.
*                (TCHFR) = TOTAL CHANNEL FRAMES TO BE READ
*                (IOBUF) CONTAINS THE HEADER ALREADY READ
*
*         EXIT   (A) = 0, IF NO ERRORS
*                    <> 0, IF ERRORS
*                THE PDU IS COPIED TO THE PRE-ALLOCATED CM BUFFERS
*
*         CALLS  ERR, MDC.
          SPACE  4,10
 RCP80    BSS    0
          STML   ERRCNT      SAVE WORDS NOT READ
          LDK    /RS/K.LREAD
          RJM    ERR         PROCESS ERROR

 RCP      SUBR               ENTRY/EXIT
          LDML   /HD/P.HLB,HDRTYP  LENGTH OF HEADER READ IN BYTES
          SHN    -1          OFFSET OF NEXT LOCATION TO FILL (PP WORDS)
          ADK    IOBUF       FWA OF NEXT AVAILABLE LOCATION IN THE PP BUFFER
          STML   RCPA

          LDML   TCHFR       CHANNEL FRAMES LEFT TO TRANSFER
          IAM    IOBUF,CHN   READ THE REST OF THE PDU
 RCPA     EQU    *-1
          NJK    RCP80       IF NOT ALL READ
          LDDL   BYTCNT      TOTAL NUMBER OF CM BYTES READ IN
          STML   RS+/RS/P.XFER+1  UPDATE BYTES READ IN RESPONSE
          RJM    MDC         MOVE DATA TO CM
          UJK    RCPX        EXIT
          SPACE  4,10
**        RRH -  READ RECORD HEADER.
*
*         THIS ROUTINE READS A PDU HEADER AND OBTAINS THE REQUIRED BUFFERS
*         TO COMPLETE THE READ. CHANNELNET AND CHANNEL CONNECTION HEADERS
*         ARE WRITTEN TO THE CM BUFFERS. ICA-1 FORMAT HEADERS ARE NOT
*         PASSED TO THE CPU.
*
*         ENTRY  (NXTREC) = 0, IF RECORD LENGTH NOT KNOWN
*                         = RECORD LENGTH IF KNOWN AND BUFFERS ALLOCATED
*
*         EXIT   (A) = 0, IF NO ERRORS
*                    > 0, IF ERRORS
*                    < 0, IF BUFFERS ARE NOT AVAILABLE
*                (BUFLEN) = UNUSED PP WORDS IN FIRST BUFFER
*                (CM.CRB) = RMA OF CURRENT READ BUFFER
*                (DATADD) = RMA OF NEXT UNUSED WORD OF BUFFER
*                (EBYOFF) = 0, IF EVEN NUMBER OF BYTES IN RECORD
*                           1, IF ODD NUMBER OF BYTES IN RECORD
*                (EXPD) = LENGTH OF RECORD IN BYTES
*                (TCHFR) = TOTAL CHANNEL FRAMES TO READ
*                (RDCNT) = UNUSED BYTES IN FIRST BUFFER
*
*         USES   CML, P1 - P4, T2, T6, WC.
*
*         CALLS  ERR, GRB, GST, PAUS, QPR, SBI, USR.
          SPACE  4,10
 RRH70    STML   ERRCNT      SAVE WORDS NOT READ
          LDK    /RS/K.LREAD
          RJM    ERR         PROCESS ERROR
          UJN    RRHX        EXIT

 RRH80    DCN    CHN+40B     DISCONNECT
          LDML   ACTD+1
          STML   NXTREC
          TRACE
          LDC    5000
          RJM    PAUS        WAIT BEFORE GETTING STATUS
          RJM    GST         WAIT FOR BUSY
          NJN    RRH90       IF ERRORS
          RJM    QPR         QUEUE PREVIOUS READ
 RRH90    BSS    0
          LCN    0

 RRH      SUBR               ENTRY/EXIT
          LDN    4
          STDL   T6
 RRH10    LDN    0
          STML   EXPD-1,T6   CLEAR EXPECTED/ACTUAL
          SODL   T6
          NJN    RRH10       IF NOT DONE
          LDML   /HD/P.HLB,HDRTYP  LENGTH OF HEADER READ IN BYTES
          STML   EXPD+1
          SHN    -1
          IAM    IOBUF,CHN   READ HEADER
          NJK    RRH70       IF NOT ALL READ
          TRACE  (IOBUF,IOBUF+1,EXPD+1,ICATDDP,HDRTYP)
          LDML   /HD/P.ALF,HDRTYP  ADDRESS OF LENGTH FIELD
          STDL   T6

          LDML   0,T6
          ADML   /HD/P.ATL,HDRTYP  ADD HEADER LENGTH IF NOT INCLUDED
          STML   TBYTS       TOTAL BYTES IN RECORD
          STDL   BYTCNT
          STML   ACTD+1
          SBML   /HD/P.MRS,HDRTYP
          ZJN    RRH55       IF LENGTH = MAXIMUM
          MJN    RRH55       IF LENGTH < MAXIMUM
          LDC    /RS/K.LSMSE
          RJM    MLE         LOG MAXIMUM LENGTH EXCEEDED
          UJK    RRHX        EXIT

 RRH55    LDML   NXTREC
          NJN    RRH60       IF PREALLOCATED
          RJM    GRB         GET BUFFERS
          ZJK    RRH80       IF BUFFERS NOT AVAILABLE
          LDML   ACTD+1
          STML   TBYTS
          STML   NXTREC
 RRH60    SBML   TBYTS
          ZJN    RRH65       IF LENGTH OK
          LDML   NXTREC
          STML   EXPD+1
          LDC    /RS/K.LSMLV
          RJM    MLE         LOG MESSAGE VERIFICATION ERROR
          UJK    RRHX        EXIT

 RRH65    LDML   TBYTS
          LPN    1
          STML   EBYOFF      EVEN/ODD ENDING BYTE
          LDML   TBYTS       RECORD LENGTH
          STML   EXPD+1
          SBML   /HD/P.HLC,HDRTYP  MINUS BYTES WRITTEN TO CM
          ADN    1           ROUND TO EVEN BYTE
          SHN    -1          CONVERT TO CHANNEL FRAMES
          STML   TCHFR
          LDML   /HD/P.HLC,HDRTYP
          STML   ACTD+1
          ZJK    RRHX        EXIT IF HEADER NOT TRANSFERED TO CM
          SHN    -3
          STDL   WC
          SHN    3
          RAML   RS+/RS/P.XFER+1  UPDATE BYTES READ IN RESPONSE
          LDML   OSOSI
          ZJK    RRHX        EXIT IF NOT OPERATIONAL

*         FILL FIRST BUFFER WITH AS MUCH OF THE HEADER AS IT CAN HOLD.

          LDK    IOBUF       FWA OF FIRST PART OF HEADER IN THE PP BUFFER
          STML   RRHA

          LDML   RS+/RS/P.DLEN   LENGTH OF FIRST BUFFER (CM BYTES)
          ADN    7           ROUND UP
          SHN    -3          CONVERT TO CM WORDS
          STDL   T2          LENGTH OF FIRST BUFFER (CM WORDS)
          LDDL   WC          LENGTH OF HEADER TO BE WRITTEN TO CM (CM WORDS)
          SBDL   T2          LENGTH OF FIRST BUFFER (CM WORDS)
          ZJN    RRH68       IF IT WILL ALL FIT IN THE FIRST BUFFER
          MJN    RRH68       IF IT WILL ALL FIT IN THE FIRST BUFFER
          STDL   WC          REMAINDER (FOR THE SECOND BUFFER)

          LRDL   DATADD      LOAD R UPPER FOR THE FIRST BUFFER FIRST DATA WORD
          LDDL   DATADD+1
          CWML   IOBUF,T2    WRITE FIRST PART OF HEADER TO FIRST BUFFER

          LDDL   T2          OFFSET TO SECOND PART OF HEADER (CM WORDS)
          SHN    2           OFFSET TO SECOND PART OF HEADER (PP WORDS)
          ADK    IOBUF       FWA OF SECOND PART OF HEADER IN THE PP BUFFER
          STML   RRHA

          AODL   CML         NEXT BUFFER
          RJM    SBI         SET BUFFER INFORMATION

*         FILL THE BUFFER WITH THE REMAINDER OF THE HEADER.

 RRH68    BSS    0
          LRDL   DATADD      LOAD R UPPER
          LDDL   DATADD+1
          CWML   IOBUF,WC    WRITE HEADER TO BUFFER
 RRHA     EQU    *-1         STARTING ADDRESS ROUNDED BACK TO A WORD BOUNDARY
          STDL   DATADD+1
          LDDL   WC          SIZE OF THE REMAINDER OF THE HEADER (CM WORDS)
          SHN    2
          STDL   T6          SAVE PP WORD COUNT
          LDDL   BUFLEN
          SBDL   T6
          STDL   BUFLEN      UPDATE BUFFER LENGTH
          LDML   RDCNT
          SBML   /HD/P.HLC,HDRTYP
          STML   RDCNT       UPDATE BYTES IN BUFFER
          LDN    0
          UJK    RRHX        EXIT
          SPACE  4,10
**        RSE - RESET STATUS ERROR
*
*         THIS ROUTINE LOGS A RESET STATUS ERROR
*
*         ENTRY  NONE
*
*         EXIT   NONE
*
*         USES   NONE
*
*         CALLS  SEI IGS SSC SLM
          SPACE  4,10
 RSE      SUBR               ENTRY/EXIT
          LDK    /RS/K.LODF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          RJM    IGS         INCLUDE GENERAL STATUS
          LDK    /RS/K.LSGSE
          RJM    SSC         SET SYMPTOM CODE
          LDN    SC.PPD
          STDL   STCHNG      DOWN ICA
          RJM    SLM         SEND LOG MESSAGE
          UJN    RSEX        EXIT
 SBI      SPACE  4,14
**        SBI - SET BUFFER INFORMATION.
*
*         THIS ROUTINE WILL INITIALIZE BUFFER POINTERS
*         USED TO MOVE DATA TO CENTRAL MEMORY.
*
*         ENTRY  (BPRMA)  = BUFFER POOL BUFFER RMA TABLE.
*                (CML)    = OFFSET TO THE LENGTH/ADDRESS PAIR (TO SET BUFFER
*                           INFORMATION FOR).
*                (FBSIZE) = MAXIMUM SIZE OF FIRST BUFFER POOL BUFFER.
*
*         EXIT   (DATADD) = REFORMATTED BUFFER FIRST DATA ADDRESS.
*                (RDCNT) = LENGTH OF BUFFER (CM BYTES).
*                (BUFLEN) = LENGTH OF BUFFER (PP WORDS).
*                (A) = LENGTH OF BUFFER (PP WORDS).
*
*         USES   T2, T3, T4.
*
*         MACRO  LOADF.


 SBI      SUBR               ENTRY/EXIT
          LDML   CML         LENGTH/ADDRESS PAIR OFFSET (ENTRY)
          SHN    1
          STDL   T2          BUFFER RMA TABLE OFFSET
          SHN    1
          STDL   T3          LENGTH/ADDRESS PAIR OFFSET (PP WORDS)

          IFEQ   DRTYP,1     IF MDI
          LOADF  BPRMA,T2    RMA OF BUFFER POOL BUFFER
          SRD    DATADD      SAVE R REQISTER
          STDL   DATADD+2    OFFSET OF FIRST DATA WORD
          ENDIF
          IFEQ   DRTYP,2     IF ICA2
          LRML   BPRMA,T2    RMA OF BUFFER POOL BUFFER
          LDML   BPRMA+1,T2
          SHN    -3
          SRDL   DATADD      SAVE R REGISTER
          STDL   DATADD+1    OFFSET OF FIRST DATA WORD
          ENDIF

          LDDL   T3          LENGTH/ADDRESS PAIR OFFSET (PP WORDS)
          NJN    SBI10       IF NOT FIRST BUFFER

*         THE FIRST BUFFER IS THE ONLY ONE THAT MAY BE PARTIALLY FILLED.
*         CALCULATE THE FIRST DATA ADDRESS FOR IT.

          LDML   RS+/RS/P.DLEN,T3   LENGTH OF FIRST BUFFER (CM BYTES)
          ADN    7           ROUND UP
          SHN    -3          CONVERT TO CM WORDS
          STDL   T4          LENGTH OF FIRST BUFFER (CM WORDS)

          LDML   FBSIZE      MAXIMUM SIZE OF FIRST BUFFER (CM BYTES)
          SHN    -3          CONVERT TO CM WORDS
          IFEQ   DRTYP,1     IF MDI
          ADDL   DATADD+2    OFFSET OF FIRST BUFFER WORD
          ENDIF
          IFEQ   DRTYP,2     IF ICA2
          ADDL   DATADD+1    OFFSET OF FIRST BUFFER WORD
          ENDIF
          SBDL   T4          LENGTH OF FIRST BUFFER (CM WORDS)
          IFEQ   DRTYP,1     IF MDI
          STDL   DATADD+2    OFFSET OF FIRST DATA WORD
          ENDIF
          IFEQ   DRTYP,2     IF ICA2
          STDL   DATADD+1    OFFSET OF FIRST DATA WORD
          ENDIF

 SBI10    BSS    0
          LDML   RS+/RS/P.DLEN,T3   LENGTH PART OF LENGTH/ADDRESS PAIR
          STML   RDCNT       LENGTH (CM BYTES)
          SHN    -1
          STDL   BUFLEN      LENGTH (PP WORDS)
          UJK    SBIX        EXIT
          SPACE  4,10
**        SCE - STATUS CONTENT ERROR
*
*         THIS ROUTINE LOGS A  STATUS CONTENT ERROR
*
*         ENTRY  A = ERROR IDENTIFIER OF COMMAND IN ERROR
*
*         EXIT   NONE
*
*         USES   NONE
*
*         CALLS  IGS SLM
          SPACE  4,10
 SCE      SUBR               ENTRY/EXIT
          STML   LRS+/RS/P.DATA1
          RJM    IGS         INCLUDE GENERAL STATUS
          LDK    /RS/K.LGSCF
          STML   LRS+/RS/P.ERRID  SET ERROR IDENTIFIER
          LDN    SC.PPD
          STDL   STCHNG      DOWN ICA
          RJM    SLM         SEND LOG MESSAGE
          UJN    SCEX        EXIT
 SDB      SPACE  4,25
**        SDB - SHIFT DATA BUFFER.
*
*         THIS ROUTINE SHIFTS THE DATA BUFFER IF AN ODD NUMBER OF BYTES OF
*         DATA IS RECEIVED FROM THE DI.  THE DATA IS SHIFTED SO THAT THE
*         LAST BYTE IS IN THE LOWER PORTION OF THE LAST PP WORD INSTEAD
*         OF THE UPPER PORTION.  THIS ENSURES THAT THE DATA WILL
*         END ON A PP WORD BOUNDARY.  THIS IS NEEDED TO GUARANTEE THAT THE
*         CM BUFFER PASSED TO THE CPU WILL BE FILLED TO THE END.
*
*         E.G.  ASSUME B1, B2, ETC. ARE CM DATA BYTES (8 BITS LONG).
*               IOBUF IS THE PP DATA BUFFER CONSISTING OF 2 CM DATA BYTES FOR
*               EACH PP WORD (16 BITS LONG).
*
*                  FROM DI           SDB            TO CPU
*
*               IOBUF   B1 B2       ---->       IOBUF      B1
*                       B3 B4                           B2 B3
*                       B5                              B4 B5
*
*
*         ENTRY  (BYTCNT) = NUMBER OF BYTES IN PP BUFFER.
*
*         EXIT   DATA IN PP DATA BUFFER SHIFTED.
*
*         USES   T1, T2.


 SDB      SUBR               ENTRY/EXIT
          LDDL   BYTCNT      NUMBER OF CM BYTES IN PP BUFFER
          SHN    -1          NUMBER OF PP WORDS IN PP BUFFER
          STDL   T2          OFFSET OF THE NEW DATA LOCATION
          SBN    1
          STDL   T1          OFFSET OF THE OLD DATA LOCATION

*         SET UP THE LAST DATA LOCATION (JUST THE LOWER CM BYTE PORTION).

          LDML   IOBUF,T2    LAST DATA LOCATION
          SHN    -8          MOVE DATA BYTE OVER (LOWER CM BYTE)
          STML   IOBUF,T2    LAST DATA LOCATION INITIALIZED (LOWER CM BYTE)

*         SHIFT THE REST OF THE PP DATA BUFFER.

 SDB10    BSSZ   0

*         SET UP THE NEW DATA LOCATION (UPPER CM BYTE PORTION).

          LDML   IOBUF,T1    OLD DATA LOCATION
          LPC    377B        LOWER CM BYTE MASK
          SHN    8           MOVE DATA BYTE TO BE THE UPPER CM BYTE
          RAML   IOBUF,T2    NEW DATA LOCATION INITIALIZED (UPPER CM BYTE)

*         SET UP THE OLD DATA LOCATION (LOWER CM BYTE PORTION).

          LDML   IOBUF,T1    OLD DATA LOCATION
          SHN    -8          MOVE DATA BYTE OVER (LOWER CM BYTE)
          STML   IOBUF,T1    OLD DATA LOCATION INITIALIZED (LOWER CM BYTE)

          SODL   T2          NEXT NEW DATA LOCATION
          SODL   T1          NEXT OLD DATA LOCATION
          PJK    SDB10       IF MORE TO SHIFT
          UJK    SDBX        EXIT
 TRACE    SPACE  4,10
**        TRACE - SAVE DATA IN TRACE BUFFER


 TRACE    SUBR
          STDL   0           SAVE (A)
          LDC    30000B
 TRACEA   EQU    *-1
          STML   TRACEC
          ADN    1
          STML   TRACEB
          ADN    1
          STML   TRACED
          ADN    1
          STML   TRACEF
          ADN    5
          STM    TRACEA
          LDDL   0           SAVE (A)            WORD 1
          STML   **
 TRACEB   EQU    *-1
          LDML   TRACE       SAVE CALL ADDRESS   WORD 0
          STML   **
 TRACEC   EQU    *-1
          STDL   0
          IAN.   14B
          STML   **          SAVE TIME           WORD 2
 TRACED   EQU    *-1
          AOML   TRACE       ADJUST RETURN ADDRESS
 TRACE1   LDIL   0           GET PARAMETER LIST
          ZJN    TRACE3      IF NO PARAMETERS
          STDL   0
 TRACE2   LDIL   0
          ZJN    TRACE3      IF END OF PARAMETERS
          STML   TRACEE
          AODL   0
          LDML   **
 TRACEE   EQU    *-1
 TRACE3   STML   **
 TRACEF   EQU    *-1
          AOML   TRACEF
          LPN    7
          NJN    TRACE2      IF NOT COMPLETE
          UJK    TRACEX
          SPACE  4,10
**        SLM - SEND LOG MESSAGE
*
*         THIS ROUTINE SENDS A LOG MESSAGE RESPONSE
*         GENERAL STATUS AND/OR DETAIL STATUS
*         INCLUDED IN RESPONSE DETERMINE LENGTH
*         OF RESPONSE
*
*         ENTRY  NONE
*
*         EXIT   NONE
*
*         USES   T9
*
*         CALLS  WRB UIP
*
          SPACE  4,10
 SLM      SUBR               ENTRY/EXIT
          TRACE  (SLM,LRS+/RS/P.ERRID,FUNCD)
          LDML   DEVID
          STML   LRS+/RS/P.DEVID
          LDDL   STCHNG
          SBN    SC.PPD
          NJN    SLM05       IF NOT DOWN
          LDK    /RS/K.DICA
          RAML   LRS+/RS/P.LGS  SET DOWN ICA FLAG
 SLM05    LDML   LRS+/RS/P.LGS
          LPK    /RS/K.LDS
          NJN    SLM10       IF DETAIL STATUS INCLUDED
          LDC    /RS/C.GENST*8+8  RESPONSE LENGTH
          UJN    SLM20       CONTINUE

          ERRPL  LDSPP-28    ASSUMES DETAILED STATUS < 28 WORDS
          ERRPL  LDSOSI-28   ASSUMES DETAILED STATUS < 28 WORDS
 SLM10    LDML   LDS,ICATDDP  DETAIL STATUS LENGTH
          SHN    1
          ADN    7
          LPN    70B
          ADC    /RS/C.GENST*8+8  RESPONSE LENGTH
 SLM20    STML   LRS+/RS/P.RESPL
          LDN    URC.LM
          STML   LRS+/RS/P.URC  SET LOG MESSAGE
          LDML   UNIT        SAVE LOGICAL UNIT
          STML   LRS+/RS/P.LU
          LDC    LRS
          RJM    WRB         WRITE RESPONSE BUFFER
          RJM    UIP         UPDATE INPUT POINTER
          RJM    ILR         INITIALIZE LOG RESPONSE
          UJK    SLMX        EXIT
          SPACE  4,10
**        SNF - SEND NORMAL FUNCTION
*
*         THIS ROUTINE SENDS A NORMAL FUNCTION TO THE
*         ICA EVERY 4 SECONDS.
*
*         EXIT   A = 0 IF NO ERRORS
*                  <> 0 IF ERRORS ON FUNCTION
*
*         CALLS  FAN
          SPACE  4,10
 SNF30    LDN    0

 SNF      SUBR               ENTRY/EXIT
          LDML   OSOSI
          ZJN    SNFX        IF NOT OPERATIONAL
 SNF10    IAN    14B         READ MICROSECONF COUNTER
          LPC    7777B
          SBM    TIMA
          PJN    SNF20       IF NO OVERFLOW
          ADC    10000B      COMPENSATE FOR CLOCK OVERFLOW
 SNF20    ADC    -1000
          MJN    SNF30       IF LESS THAN 1 MILLISECOND
          LDC    1000        ADVANCE BASE BY 1 MILLISECOND
          RAM    TIMA
          SOM    TIMB
          PJN    SNF10       IF NOT TIME FOR NORMAL FUNCTION
          LDC    F.NORM
          RJM    FAN         SEND NORMAL OPERATION FUNCTION
          UJN    SNFX        EXIT
 SOR      SPACE  4,10
**        SOR - SEND OPERATIONAL RESPONSE.
*
*         LOG MESSAGE INDICATING THAT THE ICA IS OPERATIONAL.
*
*         EXIT   (A) = 0 IF NO ERRORS
*                    <> 0 IF ERRORS
          SPACE  4,10
 SOR      SUBR               ENTRY/EXIT
          RJM    DST         GET DETAILED STATUS
          NJK    SORX        EXIT IF ERRORS
          LDK    /RS/K.LICAO LOG ICA OPERATIONAL
          STML   LRS+/RS/P.ERRID
          LDN    REC.IM
          STML   LRS+/RS/P.RETSUC INFORMATIVE MESSAGE
          RJM    IGS         INCLUDE GENERAL STATUS
          RJM    SLM         SEND LOG MESSAGE
          LDN    0
          UJN    SORX        EXIT
          SPACE  4,10
**        STE - STATE TRANSITION ERROR
*
*         THIS ROUTINE SETS A STATE TRANSITION ERROR
*         IN THE RESPONSE BUFFER AND DOWN THE ICA.
*
*         ENTRY  (A) = STATE REQUESTED
*
*         EXIT   NONE
*
*         USES   NONE
*
*         CALLS  SEI IGS SLM
          SPACE  4,10
 STE      SUBR               ENTRY/EXIT
          STML   LRS+/RS/P.TSTAT
          LDK    /RS/K.LTF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          RJM    IGS         INCLUDE GENERAL STATUS
          RJM    SLM         SEND LOG MESSAGE
          UJN    STEX        EXIT
          SPACE  4,10
**        UIP - UPDATE 'IN' POINTER
*
*         THIS ROUTINE UPDATES THE RESPONSE BUFFERS IN POINTER
*         AND INTERRUPTS THE CP. THE CP IS INTERRUPTED FOR EVERY
*         UNSOLICITED RESPONSE AND EVERY EIGHTH SOLICITED RESPONSE.
*
          SPACE  4,10
 UIP      SUBR               ENTRY/EXIT

*         UPDATE THE 'IN' POINTER.

          LDN    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDDL   INPNT       NEW 'IN' POINTER
          STDL   P4
          LRDL   CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          LDDL   CM.PIT+1
          ADN    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   P1          WRITE NEW 'IN' POINTER TO CM

*         INTERRUPT PROCESSOR. WRB ROUTINE SETS UP -INTPRC-.

          LRML   CM.INT      CM ADDRESS OF INTERRUPT WORD
          LDML   CM.INT+1
          CWDL   PPNO-3      SET LAST BYTE NON-ZERO
          LDDL   RESPC
          ZJN    UIP10       IF UNSOLICITED RESPONSE
          LDDL   LSTATE
          LMK    ST.OPER
          NJN    UIP10       IF NOT OPERATIONAL
          SOML   INTRRPT
          NJN    UIP20       IF NOT TIME TO INTERRUPT
 UIP10    BSS    0
          LDN    0           FOR S0 HARDWARE PROBLEM
 INTPRC   PSN                PSN OR INTERRUPT
          LDN    8
          STML   INTRRPT     RESET INTERRUPT INTERVAL
 UIP20    UJK    UIPX


 INTRRPT  BSSZ   1           INTERRUPT INTERVAL
          SPACE  4,10
**        WRB - WRITE RESPONSE BUFFER TO CM RESPONSE BUFFER
*               THERE ARE TWO PP RESPONSE BUFFERS.
*
*         ENTRY  (A) = PP RESPONSE BUFFER ADDRESS
*
*         USES   P1 - P5, T1, T2, T3, T4, T5, T9.
*


          SPACE  4,10
 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  6
 WRB      SUBR               ENTRY/EXIT
          STDL   T9
          STML   WRB55       INSTRUCTION MODIFICATION FOR BUFFER

*         READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 WRB10    LRDL   CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          LDDL   CM.PIT+1
          ADN    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF 'IN' POINTER
          CRDL   P1          READ 'IN' POINTER

*         CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDDL   INP
          SBDL   OUTP
          MJN    WRB20       IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP
 WRB20    LDML   /RS/P.RESPL,T9  GET RESPONSE LENGTH
          STDL   INPNT
          LDN    0
          STDL   T2          FLAG TO DETERMINE IF 1 OR 2 BLOCK WRITES
          LDDL   INP
          RADL   INPNT       IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          PJK    WRB10       IF NOT ENOUGH ROOM IN BUFFER, LOOP
          LDDL   INPNT
          SBDL   LIM
          MJN    WRB40       IF IN + RESPONSE LENGTH .LT. LIMIT
          STDL   INPNT       IN + RESPONSE LENGTH - LIMIT = NEW 'IN' POINTER
          AODL   T2          2 BLOCK WRITES REQUIRED

*         WRITE RESPONSE TO CM.

 WRB40    LDDL   INP
          SHN    -3
          STDL   T3          'IN' POINTER IN WORDS
          LDML   /RS/P.RESPL,T9 CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          STDL   T5
          LDDL   T2
          ZJN    WRB50       IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADDL   T9
          STML   WRBB        RESPONSE ADDRESS FOR SECOND BLOCK WRITE
 WRB50    LRDL   CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          LDDL   CM.RS+1
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD 'IN' OFFSET
          CWML   RS,T4       WRITE RESPONSE TO CM
 WRB55    EQU    *-1
          LDDL   T5          RESPONSE LENGTH
          SBDL   T4
          ZJN    WRB70       IF ONLY 1 BLOCK WRITE REQUIRED
          STDL   T5          RESPONSE LENGTH - (LIMIT - IN)
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
                             (BEGINNING OF RESPONSE BUFFER)
 WRBB     EQU    *-1

*         SET UP INTERRUPT PROCESSOR INSTRUCTION IF INTERRUPT IS SELECTED.

 WRB70    LDML   RS+/RS/P.INT  CHECK IF INTERRUPT WAS SELECTED
          LPK    /RS/K.INT
          ZJN    WRB80       IF INTERRUPT WAS NOT SELECTED

*         AFTER THE FIRST REQUEST SELECTING INTERRUPT IS PROCESSED,
*         ALL FOLLOWING RESPONSES WILL ALSO SEND AN INTERRUPT

          LDML   RS+/RS/P.PORT  GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RS/L.PORT+/RS/N.PORT
          LPN    /RS/M.PORT
          ADC    102600B     INPN INSTRUCTION
          STML   INTPRC
 WRB80    UJK    WRBX        EXIT


 SAVEA    SUBR
          STML      ASAVE+1
          SHN       -16
          STML      ASAVE
          UJK       SAVEAX


 ARES     SUBR
          LDML      ASAVE
          SHN       16
          ADML      ASAVE+1
          UJK       ARESX


          SPACE  4,10
***       CRM   HELPER TO SIMULATE CMCH
*         ENTRY  CRM99 = FWA
*                CRM97 = PP WORDS
*
*         EXIT   CRM99 = LWA + 1
*                CRM97 = PP WORDS NOT XFERED
*
 CRM      SUBR
 CRM10    LDML   CRM99
*         SMB
          CRML   IOBUF+4,ONE
          STML   CRM99
          LDML   CRM97
          SBN    4
          MJN    CRM20
          LDN    4
          UJN    CRM30
 CRM20    LDML   CRM97
 CRM30    STML   CRM98
          SIMM   CRM33
          OAM    IOBUF+4,CHN
 CRM33    NJN    CRMX
          LDML   CRM97
          SBML   CRM98
          STML   CRM97
          NJN    CRM10
          UJK    CRMX

 CRM97    BSSZ   1
 CRM98    BSSZ   1
 CRM99    BSSZ   1

          SPACE  4,10
**        CWM  HELPER TO SIMULATE CHCM
*         ENTRY  CWM98 = PP WORDS
*                CWM99 = FWA
*
*         EXIT   CWM98 = PP WORDS NOT READ
*                CWM99 = LWA + 1
*
 CWM      SUBR
 CWM01    LDML   CWM98
          SBN    4
          MJN    CWM05
          LDN    4
          UJN    CWM10
 CWM05    LDML   CWM98
 CWM10    STML   CWM96
          SIMM   CWM15
          IAM    IOBUF+4,CHN
 CWM15    STML   CWM97
          LDML   CWM99
*         SMB
          CWML   IOBUF+4,ONE
          STML   CWM99
          LDML   CWM97
          ZJN    CWM30
          LDML   CWM98
          SBML   CWM96
          ADML   CWM97
          STML   CWM98
          UJK    CWMX

 CWM30    LDML   CWM98
          SBML   CWM96
          STML   CWM98
          NJK    CWM01
          UJK    CWMX

 CWM96    BSSZ   1
 CWM97    BSSZ   1
 CWM98    BSSZ   1
 CWM99    BSSZ   1
          EJECT
 RPM      SPACE  4,10
**        RPM - READ PP MEMORY.
*
*         THIS PP REQUEST READS PP MEMORY CHANGES.
*
*         EXIT   (A) = 0.
*
*         USES   T5.
          SPACE  2
 RPM      SUBR               ENTRY/EXIT
          LDML   CM+/CM/P.LEN GET LENGTH OF OVERLAY
          ADK    7
          SHN    -3          CONVERT LENGTH TO LENGTH IN CM WORDS
          STDL   T5          SAVE OVERLAY LENGTH FOR TRANSFER
          IFEQ   DRTYP,1     IF MDI
          LOADF  CM+/CM/P.RMA REFORMAT CM ADDRESS
          ENDIF
          IFEQ   DRTYP,2     IF ICA2
          LRML   CM+/CM/P.RMA REFORMAT CM ADDRESS
          LDML   CM+/CM/P.RMA+1
          SHN    -3
          ENDIF
          CRML   *,T5        READ IN CHANGES.
 RPMA     EQU    *-1
          LDN    0
          UJN    RPMX        EXIT
 SPA      SPACE  4,10
**        SPA - SELECT PP MEMORY.
*
*         THIS PP REQUEST MOFDIFIES READ AND WRITE
*         INSTRUCTIONS FOR READ AND WRITE MEMORY REQUESTS.
*
*         EXIT   (A) = 0.
          SPACE  2,10
 SPA      SUBR               ENTRY/EXIT
          LDML   CM+/CM/P.RMA+1  GET SECOND HALF OF PP MEM ADDR
          STML   RPMA        MODIFY READ INSTRUCTION
          STML   WPMA        MODIFY WRITE INSTRUCTION
          LDN    0
          UJN    SPAX        EXIT
 WPM      SPACE  4,10
**        WPM - WRITE PP MEMORY.
*
*         THIS PP REQUEST WRITES REQUESTED PP MEMORY
*         TO CENTRAL MEMORY.
*
*         INPUT  (SPAADD) = PP MEMORY ADDRESS.
*
*         EXIT   (A) = 0.
*
*         USES   T5, T6.
          SPACE  2,10
 WPM      SUBR               ENTRY/EXIT
          LDML   CM+/CM/P.LEN GET BYTE COUNT
          ADN    1
          SHN    -1          GET PP WORD COUNT
          STDL   T6          SAVE PP WORD COUNT
          LDC    37777B      GET MAX PP MEMORY ADDRESS
          SBML   WPMA        SUBTRACT STARTING POINT OF COPY
          STDL   T5          SAVE MAX LENGTH OF COPY
          SBDL   T6          SUBTRACT REQUESTED LENGTH
          MJN    WPM10       IF REQUESTED LENGTH TOO LARGE, SKIP
          LDDL   T6          RESET TRANSFER LENGTH TO REQUESTED LENGTH
          STDL   T5
 WPM10    LDDL   T5          GET PP WORD LENGTH OF TRANSFER
          ADN    3
          SHN    -2          CONVERT PP WORD COUNT TO CPU WORD COUNT
          STDL   WC          SAVE CPU WORD COUNT FOR CM WRITE
          IFEQ   DRTYP,1     IF MDI
          LOADF  CM+/CM/P.RMA REFORMAT CM ADDRESS
          ENDIF
          IFEQ   DRTYP,2     IF ICA2
          LRML   CM+/CM/P.RMA REFORMAT CM ADDRESS
          LDML   CM+/CM/P.RMA+1
          SHN    -3
          ENDIF
          CWML   **,WC       COPY PP MEMORY TO CM
 WPMA     EQU    *-1
          LDN    0
          UJK    WPMX        EXIT
 TRACE    SPACE  4,10
**        TRACE PARAMETER LISTS.


          LIST   G
 TRACE    HERE
          LIST   *
*copy nai$network_common_deck
          TITLE  INITIALIZATION ROUTINES
**        INT - INITIALIZE PP DRIVER.
*
*         ESTABLISHES ACCESS TO CENTRAL MEMORY TABLES AFTER DEADSTART.
*
*         ENTRY  DSRTP = CENTRAL MEMORY ADDRESS OF WORD CONTAINING
*                          POINTER TO SP-ADDRS-ARRAY.


 INT      BSS    0           ENTRY
          LDDL   P1
          STML   DRNAME
          LDDL   P2
          STML   DRNAME+1
          RJM    LPT         LOCATE PP INTERFACE TABLE
          RJM    LUT         LOCATE UNIT INTERFACE TABLE
          RJM    LMT         LOCATE MASTER CONTROL TABLE
          RJM    CHG         SET UP CHANNEL INSTRUCTIONS
          RJM    IDP         IDLE THE PP
          RJM    ILR         INITIALIZE LOG RESPONSE
          LDML   DEVID
          STML   RS+/RS/P.DEVID
          UJK    DCS         DETERMINE CURRENT ICA STATE
          EJECT
 LMT      SPACE  4,15
**        LMT - LOCATE MASTER CONTROL TABLE.
*
*         ESTABLISHES ACCESS TO THE MASTER CONTROL TABLE.
*
*         ENTRY  (CM.URQ - CM.URQ+1) = (R) PART OF MASTER CONTROL TABLE FWA.
*                (CM.MCT) = (A) PORTION OF MASTER CONTROL TABLE FWA.
*                (C.MCT) = LENGTH OF MASTER CONTROL TABLE.
*
*         CALLS  CVM, DBP.
*
*         MACROS LOADC.


 LMT      SUBR               ENTRY/EXIT

*         VALIDATE MASTER CONTROL TABLE.

          RJM    CVM         CHECK FOR VALID MASTER CONTROL TABLE
          NJN    *           IF INVALID MASTER CONTROL TABLE  --HANG--

*         DEFINE AND VALIDATE BUFFER POOLS.

          RJM    DBP         DEFINE BUFFER POOLS
          ZJN    LMTX        IF VALID BUFFER POOLS  --EXIT--
          UJN    *           INVALID BUFER POOLS, SO  --HANG--
          EJECT
**        LPT - LOCATE PP INTERFACE TABLE.
*
*         ESTABLISHES ACCESS TO THE PP INTERFACE TABLE.
*
*         ENTRY  DSRTP = CENTRAL MEMORY BYTE ADDRESS OF PP INTERFACE TABLE.
*


 LPT      SUBR               ENTRY/EXIT

*         READ PP INTERFACE TABLE

          LDN    C.PIT       LENGTH OF PP INTERFACE TABLE
          STDL   WC
          LRDL   DSRTP
          SRDL   CM.PIT
          LDDL   DSRTP+1
          SHN    -3
          STDL   CM.PIT+1
          CRML   IPIT,WC
          RJM    CVR         CHECK FOR VALID RESPONSE BUFFER
          NJN    *           IF INVALID RESPONSE BUFFER  --HANG--
          RJM    ZRE         ZERO OUT RESPONSE BUFFER
          RJM    CVP         CHECK FOR VALID PP INTERFACE TABLE
          NJN    *           IF INVALID PP INTERFACE TABLE  --HANG--
          LDML   IPIT+/PIT/P.PPNO
          STDL   PPNO        PP NUMBER

*         REFORMAT CM ADDRESSES OF INTERRUPT WORD AND CHANNEL INTERLOCK TABLE

          LDML   IPIT+/PIT/P.INT
          STML   CM.INT
          LDML   IPIT+/PIT/P.INT+1
          SHN    -3
          STML   CM.INT+1

          LDML   IPIT+/PIT/P.CHAN
          STML   CM.CHAN
          LDML   IPIT+/PIT/P.CHAN+1
          SHN    -3
          STML   CM.CHAN+1
          UJK    LPTX
          EJECT
 LUT      SPACE  4,10
**        LUT - LOCATE UNIT INTERFACE TABLE.
*
*         ESTABLISHES ACCESS TO THE UNIT INTERFACE TABLE.
*
*         ENTRY  CM.PIT - CM.PIT+2 = CM ADDRESS OF PP INTERFACE TABLE.
*
*         EXIT   CM.UIT - CM.UIT+2 = CM ADDRESS OF UNIT INTERFACE TABLE.
*                UD = UNIT DESCRIPTOR ACCESSIBLE BY THIS PP.


 LUT      SUBR           ENTRY/EXIT
          LDN    C.UD    UNIT DESCRIPTOR LENGTH
          STDL   WC
          LRDL   CM.PIT
          LDDL   CM.PIT+1
          ADN    C.PIT
          CRML   UD,WC   READ UNIT DESCRIPTOR
          RJM    CVD         CHECK FOR VALID UNIT DESCRIPTOR
          NJN    *           IF INVALID UNIT DESCRIPTOR  --HANG--
          LDML   UD+/UD/P.CHAN
          SHN    /UD/L.CHAN+/UD/N.CHAN+2
          LPN    37B
          STML   CHAN        CHANNEL NUMBER
          LDML   UD+/UD/P.LU
          STML   UNIT        LOGICAL UNIT NUMBER
          LDN    C.UIT       UNIT INTERFACE TABLE LENGTH
          STDL   WC
          LRML   UD+/UD/P.UQT  REFORMAT CM ADDRESS OF UNIT INTERFACE TABLE
          LDML   UD+/UD/P.UQT+1
          SHN    -3
          CRML   UBUF,WC  READ UNIT INTERFACE TABLE
          RJM    CVU         CHECK FOR VALID UNIT INTERFACE TABLE
          NJN    *           IF INVALID UNIT INTERFACE TABLE  --HANG--
          UJK    LUTX        EXIT
          EJECT
**        SAVAD - SAVE REFORMATTED CM ADDRESSES
*
*         THIS ROUTINE IS CALLED ONLY DURING INITIALIZATION
*         AND ONLY BY THE *REFAD* MACRO.
*
*         USES   T2


*SAVAD    SUBR               ENTRY/EXIT
*         STML   2,T2
*         LDDL   CMADR
*         STI    T2
*         LDDL   CMADR+1
*         STML   1,T2
*         UJN    SAVADX
          SPACE  4,10
**        CHG - CHANGE CHANNEL INSTRUCTIONS.
*
*         CHANGE ALL CHANNEL INSTRUCTIONS TO USE THE SPECIFIED CHANNEL.
*
*         ENTRY  CHAN = NEW CHANNEL NUMBER TO BE USED.
*                CONCH = ADDRESS OF CHANNEL INSTRUCTIONS.
*
*         USES   T1 - T2.



 CHG      SUBR               ENTRY/EXIT
          LDN    0
          STDL   T1          CHANGE ICA CHANNEL INSTRUCTIONS
 CHG10    LDML   CONCH,T1    ADDRESS OF CHANNEL INSTRUCTIONS
          ZJN    CHGX        END OF LIST
          STDL   T2
          LDIL   T2
          SCN    37B
          LMML   CHAN       CHANNEL NUMBER
          STIL   T2
          AODL   T1
          UJN    CHG10
          SPACE  4,10
 CONCH    BSS                ICA CHANNEL REFERENCES
 TCHN+40B HERE
 T40B+CHN HERE
 TCHN     HERE
          CON    0           END OF TABLE
 CVM      SPACE  4,10
**        CVM - CHECK FOR VALID MASTER CONTROL TABLE.
*
*         ENTRY  (CM.URQ - CM.URQ+1) = (R) PART OF MASTER CONTROL TABLE FWA.
*                (CM.MCT) = (A) PORTION OF MASTER CONTROL TABLE FWA.
*
*         EXIT   (A) = 0, IF VALID MASTER CONTROL TABLE.
*                    <> 0, IF INVALID.
*
*         USES   P1 - P4, T1, WC.


 CVM      SUBR               ENTRY/EXIT
          LDN    0
          STDL   T1          UNIT INTERFACE ERROR CODE

*         READ MASTER CONTROL TABLE.

          LDN    C.MCT       LENGTH OF MASTER CONTROL TABLE
          STDL   WC

 CVM20    BSS    0
          IFEQ   DRTYP,1     IF MDI
          LOADC  CM.URQ,CM.MCT   FIRST WORD ADDRESS OF MASTER CONTROL TABLE
          ENDIF
          IFEQ   DRTYP,2     IF ICA2
          LRDL   CM.URQ      FIRST WORD ADDRESS OF MASTER CONTROL TABLE
          LDML   CM.MCT
          ENDIF
          CRML   MCT,WC
          LDML   MCT+/MCT/P.FLAGS   MASTER CONTROL TABLE INITIALIZED FLAG
          SHN    17-/MCT/INIT
          PJN    CVM20       IF MASTER CONTROL TABLE NOT INITIALIZED
          LDML   MCT+/MCT/P.DEVID   DEVICE ID
          STML   DEVID       SAVE DEVICE IDENTIFIER

*         RESERVED FIELD OF UNIT REQUEST QUEUE DESCRIPTOR.

          LDML   UBUF+/UIT/P.NEXTPV-1
          ADML   UBUF+/UIT/P.NEXT-2
          ADML   UBUF+/UIT/P.NEXT-1
          NJN    CVM80       IF RESERVED FIELD NOT ZERO
 CVM70    UJK    CVMX        EXIT

 CVM80    BSS
          LDML   TUEM,T1     INTERFACE ERROR CODE
          UJK    CVM70

**        TUEM - TABLE OF UNIT INTERFACE ERROR MESSAGES.

 TUEM     BSS    0
          LOC    0
          CON    E305        RESERVED FIELD OF UNIT REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
          LOC    *O
          SPACE  4,10
**        CVP - CHECK FOR VALID PP INTERFACE TABLE
*
*
*         EXIT   (A) = 0, IF VALID PP INTERFACE TABLE,
*                    <> 0, IF INVALID.
          SPACE  4,10
 CVP      SUBR               ENTRY/EXIT
          LDN    0
          STDL   T1
          LDML   IPIT+/PIT/P.CBUFL  COMMUNICATION BUFFER LENGTH
          LPN    7
          NJK    CVP10       IF LENGTH NOT A MULTIPLE OF WORDS

          AODL   T1
          LDML   IPIT+/PIT/P.CBUFL-1  RESERVED WORD OF PP COMMUNICATION
                             BUFFER DESCRIPTOR
          NJN    CVP10       IF RESERVED WORD NOT ZERO

          AODL   T1
          LDML   IPIT+/PIT/P.CBUF+1  COMMUNICATION BUFFER (RMA)
          LPN    7
          NJN    CVP10       IF PP COMMUNICATION BUFFER NOT A WORD BOUNDARY

          AODL   T1
          LDML   IPIT+/PIT/P.PPQPVA-1  RESERVED FIELD OF PP REQUEST
                             QUEUE DESCRIPTOR
          ADML   IPIT+/PIT/P.PPQ-2
          ADML   IPIT+/PIT/P.PPQ-1
          NJN    CVP10       IF RESERVED FIELD NOT ZERO

          AODL   T1
          LDML   IPIT+/PIT/P.INT+1  INTERRUPT WORD (RMA)
          LPN    7
          NJN    CVP10       IF INTERRUPT WORD NOT A WORD BOUNDARY

          AODL   T1
          LDML   IPIT+/PIT/P.CHAN+1  CHANNEL INTERLOCK TABLE (RMA)
          LPN    7
          NJN    CVP10       IF PP INTERFACE TABLE INVALID

          AODL   T1
          RJM    VMF         VERIFY MICROCODE
          ZJN    CVP15       IF MICROCODE OK


 CVP10    LDML   CVP20,T1    INTERFACE ERROR CODE
          RJM    PIE         PROCESS INTERFACE ERROR
          LDN    URC.IE
          STDL   UNSC        UNSOLICITED RESPONSE CODE
          RJM    USR         SEND UNSOLICITED RESPONSE
          LCN    0
 CVP15    UJK    CVPX        EXIT

 CVP20    CON    E20B        COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS
          CON    E204        RESERVED WORD OF PP COMMUNICATION
                             BUFFER DESCRIPTOR NOT ZERO
          CON    E203        PP COMMUNICATION BUFFER NOT A WORD BOUNDARY
          CON    E205        RESERVED FIELD OF PP REQUEST QUEUE
                             DESCRIPTOR NOT ZERO
          CON    E211        RMA OF INTERRUPT WORD NOT A WORD BOUNDARY
          CON    E212        RMA OF CHANNEL INTERLOCK TABLE NOT A WORD BOUNDARY
          CON    E507        MICROCODE LENGTH NOT VALID
          SPACE  4,10
**        CVD - CHECK FOR VALID UNIT DESCRIPTOR
*
*         EXIT   (A) = 0, IF VALID UNIT DESCRIPTOR,
*                    <> 0, IF INVALID.
*
          SPACE  4,10
 CVD      SUBR               ENTRY/EXIT
          LDN    0
          LDML   UD+/UD/P.LU  LOGICAL UNIT
          SBML   IPIT+/PIT/P.FLU  FIRST LOGICAL UNIT
          PJN    CVD10
          LDC    E208        LOGICAL UNIT NOT IN RANGE
          UJK    CVD60

 CVD10    LDML   UD+/UD/P.CHAN  CHANNEL NUMBER
          SHN    /UD/L.CHAN+/UD/N.CHAN+2
          LPN    37B
          SBN    6           VALID CHANNELS ARE 0 - 5B AND 20B - 25B
          MJN    CVD40       CHANNEL OK
          SBN    20B-6B
          PJN    CVD30
 CVD20    LDC    E20A        INVALID CHANNEL NUMBER
          UJN    CVD60

 CVD30    SBN    26B-20B
          PJN    CVD20

 CVD40    LDML   UD+/UD/P.UQT+1  UNIT INTERFACE TABLE ADDRESS
          LPN    7
          ZJN    CVDX
          LDC    E209        UNIT INTERFACE TABLE NOT A WORD BOUNDARY

 CVD60    RJM    PIE         PROCESS INTERFACE ERROR
          LDN    URC.IE
          STDL   UNSC        UNSOLICITED RESPONSE CODE
          RJM    USR         SEND UNSOLICITED RESPONSE
          LCN    0
          UJK    CVDX        EXIT
          SPACE  4,10
**        CVU - CHECK FOR VALID UNIT INTERFACE TABLE
*
*         EXIT   (A) = 0, IF VALID UNIT INTERFACE TABLE,
*                    <> 0, IF INVALID.
*                (CM.URQ - CM.URQ+1) = (R) PART OF MASTER CONTROL TABLE FWA.
*                (CM.MCT) = (A) PORTION OF MASTER CONTROL TABLE FWA.
*
*         CALLS  STB
          SPACE  4,10
 CVU      SUBR               ENTRY/EXIT
          LDN    0
          STDL   T1
          LDML   UBUF+/UIT/P.LU  LOGICAL UNIT NUMBER
          SBML   UD+/UD/P.LU
          NJN    CVU20       LOGICAL UNIT NUMBER MISMATCH

          AODL   T1
          LDML   UBUF+/UIT/P.UTYPE  UNIT TYPE
          STML   STBI
          LDC    TITDDP-2
          RJM    STB
          ZJK    CVU40       IF UNIT TYPE SPECIFIED IS NOT AN ICA
          STDL   ICATDDP

*         RESERVED FIELD OF MASTER CONTROL TABLE DESCRIPTOR

          AODL   T1
          LDML   UBUF+/UIT/P.MBUFL-1  RESERVED FIELD OF
                             MASTER CONTROL TABLE DESCRIPTOR
          NJK    CVU40       RESERVED FIELD IS NOT ZERO

          AODL   T1
          LDML   UBUF+/UIT/P.MBUFL  MASTER CONTROL TABLE LENGTH
          ADC    -B.MCT      COMPARE WITH EXPECTED MASTER CONTROL TABLE LENGTH
          MJN    CVU20       IF BUFFER NOT LONG ENOUGH
          LPN    7
          ZJN    CVU30
 CVU20    UJK    CVU40

 CVU30    AODL   T1
          LDML   UBUF+/UIT/P.MBUF+1  MASTER CONTROL TABLE
          LPN    7
          NJK    CVU40       NOT A WORD BOUNDARY
 CVU35    BSS    0
          IFEQ   DRTYP,1     IF MDI
          LOADF  UBUF+/UIT/P.MBUF
          ENDIF
          IFEQ   DRTYP,2     IF ICA2
          LRML   UBUF+/UIT/P.MBUF
          LDML   UBUF+/UIT/P.MBUF+1
          ENDIF
          SHN    -3
          STDL   CM.URQ+1
          STML   CM.MCT
          SRDL   CM.URQ
          LDN    0           VALID UNIT INTERFACE TABLE
 CVU38    UJK    CVUX        EXIT

 CVU40    LDML   CVU50,T1    INTERFACE ERROR CODE
          RJM    PIE         PROCESS INTERFACE ERROR
          LDN    URC.IE
          STDL   UNSC        UNSOLICITED RESPONSE CODE
          RJM    USR         SEND UNSOLICITED RESPONSE
          LCN    0
          UJK    CVU38

 CVU50    CON    E301        LOGICAL UNIT NUMBER MISMATCH
          CON    E306        INVALID UNIT TYPE
          CON    E303        RESERVED FIELD OF MASTER CONTROL TABLE
                             DESCRIPTOR IS NOT ZERO
          CON    E307        MASTER CONTROL TABLE LENGTH NOT A
                             MULTIPLE OF WORDS
          CON    E302        MASTER CONTROL TABLE NOT A WORD BOUNDARY
          SPACE  4,10
**        TABLE OF ICA TYPE DEPENDENT DATA POINTERS.
*

 TITDDP   CON    U.I2TYPE,OSITDD
          CON    0
          SPACE  4,10
**        CVR - CHECK FOR VALID RESPONSE BUFFER
*
*         EXIT   (A) = 0, IF VALID RESPONSE BUFFER,
*                         CM.RS - CM.RS+2 = CM ADDRESS OF RESPONSE BUFFER,
*                    <> 0, IF INVALID.
          SPACE  4,10
 CVR      SUBR               ENTRY/EXIT
          LDML   IPIT+/PIT/P.RSBUF-2  RESERVED WORD OF RESPONSE
                             BUFFER DESCRIPTOR
          ADML   IPIT+/PIT/P.RSBUF-1
          ADML   IPIT+/PIT/P.RSPVA-1
          NJK    CVR05       IF RESERVED FIELD NOT ZERO

          LDML   IPIT+/PIT/P.IN-3  RESERVED FIELD OF IN POINTER
          ADML   IPIT+/PIT/P.IN-2
          ADML   IPIT+/PIT/P.IN-1
 CVR05    NJK    CVR10       IF RESERVED FIELD NOT ZERO

          LDML   IPIT+/PIT/P.OUT-3  RESERVED FIELD OF OUT POINTER
          ADML   IPIT+/PIT/P.OUT-2
          ADML   IPIT+/PIT/P.OUT-1
          NJK    CVR10       IF RESERVED FIELD NOT ZERO

          LDML   IPIT+/PIT/P.LIMIT-3  RESERVED FIELD OF LIMIT POINTER
          ADML   IPIT+/PIT/P.LIMIT-2
          ADML   IPIT+/PIT/P.LIMIT-1
          NJK    CVR10       IF RESERVED FIELD NOT ZERO

*         RESPONSE BUFFER VALID - REFORMAT INTO CM.RS -CM.RS+2

          LDML   IPIT+/PIT/P.RSBUF REFORMAT ADDRESS OF REPONSE BUFFER
          STDL   CM.RS
          LDML   IPIT+/PIT/P.RSBUF+1
          SHN    -3
          STDL   CM.RS+1
          LDML   IPIT+/PIT/P.LIMIT
          STDL   LIM         LIMIT OF RESPONSE BUFFER

          LDN    0
 CVR10    UJK    CVRX        EXIT
 DBP      SPACE  4,16
**        DBP - DEFINE BUFFER POOLS PROCESSOR.
*
*         THIS ROUTINE DOES THE INITIAL PROCESSING OF BUFFER POOL
*         DESCRIPTORS.  A TABLE CONTAINING THE LENGTHS OF THE
*         BUFFERS IN THE POOLS IS CREATED AT LOCATION
*         *BPDSIZE*.  THE CM ADDRESS OF THE FIRST DESCRIPTOR
*         IS ALSO SET UP.
*
*         EXIT   (A) = 0, IF NO ERRORS.
*                (A) <> 0, IF ERRORS.
*
*         USES   P1, P2, WC.
*
*         CALLS  PIE.
*
*         MACROS LOADC, LOADF.


 DBP      SUBR               ENTRY/EXIT
          ERRNG  MAXBPD-1    NO BUFFER POOLS
          LDK    MAXBPD
          STML   NUMBP       NUMBER OF BUFFER POOLS
          STDL   P2

          LDN    0
          STDL   FSTBD       RESET FSTBD
          LDN    C.BPD
          STDL   WC          LENGTH OF BUFFER POOL DESCRIPTOR
          IFEQ   DRTYP,1     IF MDI
          LOADF  MCT+/MCT/P.BP  REFORMAT CM ADDRESS OF FIRST BUFFER DESCRIPTOR
          STDL   CM.BPD+2
          SRD    CM.BPD
          ENDIF
          IFEQ   DRTYP,2     IF ICA2
          LRML   MCT+/MCT/P.BP  REFORMAT CM ADDRESS OF FIRST BUFFER DESCRIPTOR
          LDML   MCT+/MCT/P.BP+1
          SHN    -3
          STDL   CM.BPD+1
          SRDL   CM.BPD
          ENDIF

 DBP10    CRML   BPD,WC      READ BUFFER POOL DESCRIPTOR
          STDL   P1          (A) OFFSET TO NEXT BUFFER POOL DESCRIPTOR
          LDML   BPD+/BPD/P.LEN
          NJN    *           IF BUFFER LENGTH TOO BIG
          LDML   BPD+/BPD/P.LEN+1
          PJN    DBP15       IF VALID BUFFER LENGTH
          LDC    E50B        INVALID PARAMETER SPECIFICATION
 DBP12    UJK    DBPX        EXIT

 DBP15    STML   BPDSIZE,FSTBD  SAVE BUFFER LENGTH
          SODL   P2          DECREMENT NUMBER OF POOLS REMAINING
          ZJK    DBP12       IF NO MORE POOLS
          AODL   FSTBD
          IFEQ   DRTYP,1     IF MDI
          LOADC  CM.BPD,P1   CM ADDRESS OF NEXT DESCRIPTOR
          ENDIF
          IFEQ   DRTYP,2     IF ICA2
          LRDL   CM.BPD      CM ADDRESS OF NEXT DESCRIPTOR
          LDDL   P1
          ENDIF
          UJK    DBP10       LOOP
          SPACE  4,10
**        VMF - VERIFY MICROCODE FILE
*
*         VERIFY THAT THE LENGTH FIELD IN THE HEADER
*         OF THE MICROCODE LOAD FILE AGREES WITH THE
*         COMMAND PASSED IN THE COMMUNICATIONS BUFFER.
*         THIS COMMAND IS IN THE SAME FORMAT AS THE INDIRECT
*         COMMAND LIST. THE MICROCODE LENGTH FIELD IS IN THE
*         FIRST FOUR BYTES.
*
*
*         ENTRY  IPIT = PP INTERFACE TABLE
*
*         EXIT   (A) = 0 IF NO ERRORS
*                  <> 0 IF ERRORS
*
*         USES   P1 P2 P3 P4
*
 VMF      SUBR               ENTRY/EXIT
          LRML   IPIT+/PIT/P.CBUF
 VMF05    LDML   IPIT+/PIT/P.CBUF+1
          SHN    -3          FWA OF COMMUNICATION BUFFER
          ADN    /CB/C.CWLEN FWA OF ICA MICROCODE
          CRDL   P1          READ MICROCODE LEN/RMA PAIR

*         COMMAND NOT IN BUFFER UNTIL COMMAND CODE IS EQUAL TO C(16)

          LDDL   P1
          SHN    -8
          SBN    14B
          NJN    VMF05       IF NOT IN BUFFER YET

*         REFORMAT AND SAVE ADDRESS OF LENGTH/RMA LIST

          LDDL   P3          SAVE R REGISTER PORTION
          STML   CM.LOAD-1+/CM/P.RMA
          LDDL   P4
          SHN    -3          REFORMAT FIRST WORD ADDRESS
          STML   CM.LOAD-1+/CM/P.RMA+1
          LDN    0
          STDL   CML
          LDDL   P2
          SHN    -3
          STDL   CMLISTL     SAVE LENGTH OF LIST
 VMF20    LRML   CM.LOAD-1+/CM/P.RMA
          LDML   CM.LOAD-1+/CM/P.RMA+1
          ADDL   CML
          CRDL   P1          GET ONE PAIR
          LDDL   CML
          NJK    VMF30       IF NOT FIRST PAIR

*         READ HEADER OF MICROCODE FILE TO VERIFY LENGTH.

          LRDL   P1+/CM/P.RMA
          LDDL   P1+/CM/P.RMA+1
          SHN    -3          READ FIRST WORD
          CRML   IOBUF,ONE   TO GET LENGTH

*         SAVE LENGTH FOR TWO WORD DECREMENT ROUTINE

          LDML   IOBUF
          STML   LIOC
          STML   LFLEN
          LDML   IOBUF+1
          STML   LIOC+1
          STML   LFLEN+1
 VMF30    LDDL   P1+/CM/P.LEN
          ZJN    VMF35       IF END OF LIST
          STDL   ERRCNT      SAVE LENGTH FOR DECREMENT ROUTINE
          RJM    DLC         DECREMENT LENGTH BY LENGTH OF
*                            THIS SEGMENT
          AODL   CML
          SBDL   CMLISTL
          NJK    VMF20       IF MORE TO READ
 VMF35    LDDL   CML         SAVE LENGTH OF LIST
*                            ACTUAL LENGTH OF LIST IS SAVED AS
*                            THE LENGTH SENT IS GREATER THAN ACTUAL
          STML   CM.LOAD-1+/CM/P.LEN
          LDML   LIOC        LENGTH SHOULD BE DECREMENTED TO ZERO
          ADML   LIOC+1
          UJK    VMFX        EXIT A=0 IF NO ERR0RS
          SPACE  4,10
**        BUFFERS USED AT INITIALIZATION
          SPACE  4,10
 IPIT     BSSZ   P.PIT       PP INTERFACE TABLE
 UBUF     BSSZ   P.UIT       UNIT INTERFACE TABLE
 UD       BSSZ   P.UD        UNIT DESCRIPTOR
          SPACE  4,10
          TITLE  BUFFER AREA
 RS       BSSZ   MAXRS*4     RESPONSE BUFFER
 LRS      BSSZ   P.RS+4      LOGGING RESPONSE BUFFER
 MCT      BSSZ   P.MCT       MASTER CONTROL TABLE
          SPACE  4,10
**        LOCATIONS OF BUFFERS USED AFTER INITIALIZATION ARE DEFINED
*         HERE. THE USE OF ANY OF THESE BUFFERS WILL OVERWRITE THE
*         INITIALIZATION CODE.
          SPACE  4,10
 RESEND   EQU    *           END OF RESIDENT CODE

 BP       BSSZ   P.BP        BUFFER POOL TABLE ENTRY
 BPD      BSSZ   P.BPD       BUFFER POOL DESCRIPTOR
 BPDSIZE  BSSZ   MAXBPD      BUFFER POOL SIZES
 BPRMA    BSSZ   MAXRS*2-/RS/C.BUFPVA*2   BUFFER POOL CONTAINER RMAS

 INTOV    EQU    *           FIRST WORD ADDRESS OF INITIALIZATION ROUTINES
 RQ       EQU    INTOV       REQUEST BUFFER
 CM       EQU    RQ+/RQ/P.CMND  COMMAND PORTION OF REQUEST

 IOBUF    EQU    RQ+MAXURQ*4 I/O BUFFER
 IOBLEN   EQU    MINLEN      I/O BUFFER SIZE
 I1       EQU    IOBLEN*2*2/3
          IFPL   I1*3-IOBLEN*2*2
 CHCNT    EQU    I1
          ELSE
 CHCNT    EQU    I1+1
          ENDIF
 BUFEND   EQU    IOBUF+MINLEN  MINIMUM BUFFER SPACE REQUIRED
 BPDEND   EQU    BUFEND

          SPACE  4,10
          END    ICAD
/EOR
*DECK DECK=NAM$INCREMENT_FILE_ACCESS_STATS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE NETWORK ACCESS: Increment File Access' ??
MODULE nam$increment_file_access_stats;

{ PURPOSE:
{   This module contains the procedure to increment the system variable nav$global_statistics.
{
{ NOTES:
{   The active connections count is decremented if the current value is greater than zero
{   to prevent the count from being negative.

?? NEWTITLE := '  Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
?? POP ??
*copyc jmv$executing_within_system_job
*copyc nav$global_statistics
*copyc nav$statistics_enabled
*copyc osp$is_caller_system_privileged
?? TITLE := '  [XDCL, #GATE] nap$increment_file_access_stats', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$increment_file_access_stats
    (    increment: integer;
         statistic: (active_connection, file_access_request));

    IF (NOT jmv$executing_within_system_job) AND (NOT osp$is_caller_system_privileged()) THEN
      RETURN;
    IFEND;

    IF nav$statistics_enabled THEN
      IF statistic = active_connection THEN
        IF (increment > 0) OR ((increment < 0) AND (nav$global_statistics.file_access.active_connections > 0))
              THEN
          nav$global_statistics.file_access.active_connections :=
                increment + nav$global_statistics.file_access.active_connections;
        IFEND;
      ELSE
        nav$global_statistics.file_access.file_access_requests :=
              increment + nav$global_statistics.file_access.file_access_requests;
      IFEND;
    IFEND;
  PROCEND nap$increment_file_access_stats;

MODEND nam$increment_file_access_stats;
*DECK DECK=NAM$INDEPENDENT_INIT_MANAGER EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
MODULE nam$independent_init_manager;

{ PURPOSE: This module implements the Independent Initialization Management
{          entity as defined by the CDNA GDS. It provides dumping and loading
{          support for network systems that are not capable of performing these
{          functions by themselves.
{
{ DESIGN:  The initialization protocol is processed using an event driven
{          finite state machine. Two kinds of events are defined: reception of
{          data units from remote systems and expired timers. When an event
{          occurs, it is examined to determine the condition that exists for
{          the specified remote system. A table indexed by this condition
{          and the current state of the remote system is then used to determine
{          the new state of the system and the processor that handles this
{          condition.
{
{          Timers are maintained internally by periodically interrogating the
{          system clock.
{
{          The following table defines the finite state machine:
{
{              |  UNKNOWN |  HELP    |   DUMP   |  DUMPING  |   DUMP    |  LOADING  |   LOAD    | INACTIVE |
{              |          | OFFERED  | INITIATED|           |  ABORTED  |           | COMPLETE  |          |
{              |    (1)   |   (2)    |    (3)   |    (4)    |    (5)    |    (6)    |    (7)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ CHECKSUM     |    LOG   |          |          |           |           |           |           |          |
{ ERROR        |AND DELETE|   LOG    |    LOG   |    LOG    |    LOG    |    LOG    |    LOG    |    LOG   |
{              |    (1)   |   (2)    |    (3)   |    (4)    |    (5)    |    (6)    |    (7)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ UNKNOWN OR   |    LOG   |          |          |           |           |           |           |          |
{ SHORT PDU    |AND DELETE|   LOG    |    LOG   |    LOG    |    LOG    |    LOG    |    LOG    |    LOG   |
{              |    (1)   |   (2)    |    (3)   |    (4)    |    (5)    |    (6)    |    (7)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ HELP REQUEST |    LOG   |   LOG    |    LOG   | TRUNCATE  | TRUNCATE  | TRUNCATE  | TRUNCATE  |    LOG   |
{ FROM EXCLUDED|AND DELETE|AND DELETE|AND DELETE|DUMP&DELETE|DUMP&DELETE|LOAD&DELETE|LOAD&DELETE|AND DELETE|
{ SYSTEM       |    (1)   |   (1)    |    (1)   |    (1)    |    (1)    |    (1)    |    (1)    |    (1)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ HELP REQUEST |    LOG   |   LOG    |    LOG   | TRUNCATE  | TRUNCATE  | TRUNCATE  | TRUNCATE  |    LOG   |
{ DEVICE NOT   |AND DELETE|AND DELETE|AND DELETE|DUMP&DELETE|DUMP&DELETE|LOAD&DELETE|LOAD&DELETE|AND DELETE|
{ SUPPORTED    |    (1)   |   (1)    |    (1)   |    (1)    |    (1)    |    (1)    |    (1)    |    (1)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ HELP REQUEST |          |          |          |TRUNC DUMP |TRUNC DUMP |TRUNC LOAD |TRUNC LOAD |          |
{ NO MORE      |  DELETE  |INACTIVATE|INACTIVATE|&INACTIVATE|&INACTIVATE|&INACTIVATE|&INACTIVATE|    LOG   |
{ RETRIES      |    (1)   |   (8)    |    (8)   |    (8)    |    (8)    |    (8)    |    (8)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ HELP REQUEST |  OFFER   |  OFFER   |  OFFER   | TRUNCATE  | TRUNCATE  | TRUNCATE  | TRUNCATE  |  OFFER   |
{ MORE RETRIES |   HELP   |   HELP   |   HELP   |DUMP & HELP|DUMP & HELP|LOAD & HELP|LOAD & HELP|   HELP   |
{              |    (2)   |   (2)    |    (2)   |    (2)    |    (2)    |    (2)    |    (2)    |    (2)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ HELP ACCEPT  |    LOG   | INITIATE |   START  |           |           |           |           |          |
{ WITH DUMP    |AND DELETE|   HELP   |   DUMP   |    LOG    |    LOG    |    LOG    |    LOG    |    LOG   |
{              |    (1)   |   (3)    |    (3)   |    (4)    |    (5)    |    (6)    |    (7)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ HELP ACCEPT  |    LOG   | INITIATE |          |           |           |   START   |   START   |          |
{ WITHOUT DUMP |AND DELETE|   HELP   |  IGNORE  |  IGNORE   |  IGNORE   |   LOAD    |   LOAD    |    LOG   |
{              |    (1)   |   (6)    |    (3)   |    (4)    |    (5)    |    (6)    |    (6)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ EXCESSIVE    |          |          |   ABORT  |   ABORT   |           |           |           |          |
{ DUMP DATA    |  DELETE  | IGNORE   |   DUMP   |   DUMP    |  IGNORE   |  IGNORE   |  IGNORE   |  IGNORE  |
{              |    (1)   |   (2)    |    (5)   |    (5)    |    (5)    |    (6)    |    (7)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ DUMP DATA IN |          |          | SAVE DUMP| SAVE DUMP |           |           |           |          |
{ SEQUENCE     |  DELETE  | IGNORE   |   DATA   |   DATA    |  IGNORE   |  IGNORE   |  IGNORE   |  IGNORE  |
{              |    (1)   |   (2)    |    (4)   |    (4)    |    (5)    |    (6)    |    (7)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ DUMP DATA LOW|          |          |          |           |           |           |           |          |
{ SEQUENCE     |  DELETE  | IGNORE   |  IGNORE  |  IGNORE   |  IGNORE   |  IGNORE   |  IGNORE   |  IGNORE  |
{              |    (1)   |   (2)    |    (3)   |    (4)    |    (5)    |    (6)    |    (7)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ DUMP DATA    |          |          |   START  |  RESYNC   |           |           |           |          |
{ HIGH SEQUENCE|  DELETE  | IGNORE   |   DUMP   |   DUMP    |  IGNORE   |  IGNORE   |  IGNORE   |  IGNORE  |
{ TRY RESYNC   |    (1)   |   (2)    |    (3)   |    (4)    |    (5)    |    (6)    |    (7)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ DUMP DATA    |          |          |          |           |           |           |           |          |
{ HIGH SEQUENCE|  DELETE  | IGNORE   |  IGNORE  |  IGNORE   |  IGNORE   |  IGNORE   |  IGNORE   |  IGNORE  |
{ RESYNC SENT  |    (1)   |   (2)    |    (3)   |    (4)    |    (5)    |    (6)    |    (7)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ TERM DUMP IN |          |          | END DUMP | END DUMP  | END DUMP  |           |           |          |
{ SEQUENCE OR  |  DELETE  | IGNORE   |START LOAD|START LOAD |START LOAD |  IGNORE   |START LOAD |  IGNORE  |
{ ABNORMAL     |    (1)   |   (2)    |    (6)   |    (6)    |    (6)    |    (6)    |    (6)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ TERM DUMP BAD|          |          |  START   |  RESYNC   | END DUMP  |           |           |          |
{ SEQUENCE TRY |  DELETE  | IGNORE   |   DUMP   |   DUMP    |START LOAD |  IGNORE   |START LOAD |  IGNORE  |
{ RESYNC       |    (1)   |   (2)    |    (3)   |    (4)    |    (6)    |    (6)    |    (6)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ TERM DUMP BAD|          |          |          |           | END DUMP  |           |           |          |
{ SEQUENCE     |  DELETE  | IGNORE   |  IGNORE  |  IGNORE   |START LOAD |  IGNORE   |START LOAD |  IGNORE  |
{ RESYNC SENT  |    (1)   |   (2)    |    (3)   |    (4)    |    (6)    |    (6)    |    (6)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ SYNC LOAD BAD|          |          |          |           |           |           |           |          |
{ SEQUENCE     |  DELETE  |   LOG    |    LOG   |    LOG    |    LOG    |    LOG    |    LOG    |    LOG   |
{              |    (1)   |   (2)    |    (3)   |    (4)    |    (5)    |    (6)    |    (7)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ SYNC LOAD    |          |          |          |           |           |  RESYNC   |  RESYNC   |          |
{ MORE RETRIES |  DELETE  |   LOG    |    LOG   |    LOG    |    LOG    |   LOAD    |   LOAD    |    LOG   |
{              |    (1)   |   (2)    |    (3)   |    (4)    |    (5)    |    (6)    |    (6)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ SYNC LOAD NO |          |          |          |           |           |           |           |          |
{ MORE RETRIES |  DELETE  |   LOG    |    LOG   |    LOG    |    LOG    |ABORT LOAD |ABORT LOAD |    LOG   |
{              |    (1)   |   (2)    |    (3)   |    (4)    |    (5)    |    (8)    |    (8)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ TIMER EXPIRED|          |          |  START   |  RESYNC   |   ABORT   | SEND LOAD |           |          |
{ MORE RETRIES |  DELETE  |INACTIVATE|   DUMP   |   DUMP    |   DUMP    |   DATA    | INACTIVATE|INACTIVATE|
{              |    (1)   |   (8)    |    (3)   |    (4)    |    (5)    |    (6)    |    (8)    |    (8)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+
{ TIMER EXPIRED|          |          |   ABORT  |   ABORT   |           | TERMINATE |           |          |
{ NO MORE      |  DELETE  |INACTIVATE|   DUMP   |   DUMP    |INACTIVATE |   LOAD    | INACTIVATE|  DELETE  |
{ RETRIES      |    (1)   |   (8)    |    (5)   |    (5)    |    (8)    |    (7)    |    (8)    |    (1)   |
{ -------------+----------+----------+----------+-----------+-----------+-----------+-----------+----------+

?? PUSH (LISTEXT := ON) ??
*copyc llt$transfer_symbol
*copyc llt$load_module
*copyc nae$initialization_me
*copyc nae$namve_conditions
*copyc nat$init_me_directives
*copyc nat$object_code_version
*copyc nat$data_fragments
*copyc nat$checksum
*copyc nat$network_address
*copyc nat$cn_interface
*copyc amt$file_identifier
*copyc ost$status
*copyc ost$status_message
*copyc ost$status_message_line_size
*copyc ost$status_message_line_count
*copyc ost$status_message_line
*copyc pmt$condition
*copyc pmt$established_handler
*copyc cld$value
?? POP ??
?? TITLE := 'Initialization protocol definitions' ??

  TYPE
    nit$system_type = 0 .. 0f(16);

  CONST
    di_system = 1,
    ica2_system = 2;

  CONST
    load_pdu_block_count = 2 {10} {count of load pdus sent per timer interval} ;

  TYPE
    nit$data_unit_id = 0 .. 0ff(16);

  CONST
    help_request_id = 11(16),
    help_offer_id = 12(16),
    help_accept_id = 13(16),
    begin_auto_dump_id = 20(16),
    dump_data_id = 22(16),
    synchronize_dump_id = 23(16),
    terminate_dump_id = 25(16),
    abort_dump_id = 26(16),
    load_data_id = 30(16),
    synchronize_load_id = 31(16);

  TYPE
    nit$request_flags = packed record
      system_type: nit$system_type,
      auto_dump: boolean,
      directed_dump: boolean,
      previous_load_specified: boolean,
      reserved: 0 .. 1,
    recend;

  TYPE
    nit$reset_code = packed record
      code: 0 .. nac$max_di_reset_code,
    recend;

  CONST
    power_up_reset = 0,
    manual_reset = 2,
    halt_memory_fault = 3,
    dead_man_timeout = 4,
    memory_too_small = 10(16),
    improper_first_module = 11(16),
    unsatisfied_external = 12(16),
    missing_module = 13(16),
    missing_configuration = 14(16);

  TYPE
    nit$board_definition = 0 .. 0ffffffff(16);

  TYPE
    nit$service_definition = packed record
      priority: nit$service_priority,
      reserved: 0 .. 3f(16),
    recend,
    nit$service_priority = 0 .. 3;

  TYPE
    nit$dump_flow_control = 0 .. 0ff(16);

  TYPE
    nit$sequence_number = 0 .. 0ffff(16);

  TYPE
    nit$resync_info = SEQ (REP 1 of integer);

  TYPE
    nit$dump_termination_code = 0 .. 0ff(16);

  CONST
    normal_dump_termination = 0,
    dump_abort_received = 1,
    dump_memory_error = 2;

  TYPE
    nit$load_flags = packed record
      last_data_unit: boolean,
      reserved: 0 .. 7f(16),
    recend;

  TYPE
    nit$synchronize_load_flags = packed record
      overflow: boolean,
      reserved: 0 .. 7f(16),
    recend;

  TYPE
    nit$pdu = ^SEQ ( * );

  TYPE
    nit$help_request_data_unit = record
      identifier: nit$data_unit_id,
      flags: nit$request_flags,
      requesting_system_id: nat$system_identifier,
      boot_card: nat$card_type,
      reset_code: nit$reset_code,
      last_version_number: nat$object_code_version,
      last_network_id: nat$network_identifier,
      last_system_id: nat$system_identifier,
      {board_definitions: array [ * ] of nit$board_definition,
    recend;

  TYPE
    nit$help_offer_data_unit = record
      identifier: nit$data_unit_id,
      service_definition: nit$service_definition,
      version_number: nat$object_code_version,
      network_id: nat$network_identifier,
      host_system_id: nat$system_identifier,
    recend;

  TYPE
    nit$help_accept_data_unit = record
      identifier: nit$data_unit_id,
      reserved: 0 .. 0ff(16),
    recend;

  TYPE
    nit$auto_dump_data_unit = record
      identifier: nit$data_unit_id,
      flow_control: nit$dump_flow_control,
      max_data_length: 0 .. 0ffff(16),
    recend;

  TYPE
    nit$dump_data_unit = record
      identifier: nit$data_unit_id,
      flags: 0 .. 0ff(16),
      sequence_number: nit$sequence_number,
      save_area: nit$resync_info,
      {data: SEQ ( * ),
    recend;

  TYPE
    nit$synchronize_dump_data_unit = record
      identifier: nit$data_unit_id,
      reserved: 0 .. 0ff(16),
      sequence_number: nit$sequence_number,
      save_area: nit$resync_info,
    recend;

  TYPE
    nit$term_dump_data_unit = record
      identifier: nit$data_unit_id,
      code: nit$dump_termination_code,
      sequence_number: nit$sequence_number,
      error_address: 0 .. 0ffffffff(16),
    recend;

  TYPE
    nit$abort_dump_data_unit = record
      identifier: nit$data_unit_id,
      reserved: 0 .. 0ff(16),
    recend;

  TYPE
    nit$load_data_unit = record
      identifier: nit$data_unit_id,
      flags: nit$load_flags,
      sequence_number: nit$sequence_number,
      save_area: nit$resync_info,
     {data: SEQ ( * ),
    recend;

  TYPE
    nit$synchronize_load_data_unit = record
      identifier: nit$data_unit_id,
      flags: nit$synchronize_load_flags,
      sequence_number: nit$sequence_number,
      save_area: nit$resync_info,
    recend;

?? TITLE := 'Dependent System Information', EJECT ??

  CONST
    default_flow_control = 2,   { 20 ms
    max_abort_dump_count = 3,
    max_dump_count = 3,
    max_dump_resync_count = 3,
    max_load_resync_count = 10, {3}
    max_initialize_attempts = 10;

  TYPE
    nit$dependent_system = record
      abort_dump_count: 0 .. max_abort_dump_count,
      boot_card: nat$card_type,
      device_id: nlt$device_identifier,
      condition: nit$condition_kind,
      dump_count: 0 .. max_dump_count,
      dump_data: ^SEQ ( * ),
      dump_file: amt$file_identifier,
      dump_file_opened: boolean,
      dump_overflow: boolean,
      dump_required: boolean,
      dump_resync_count: 0 .. max_dump_resync_count,
      last_dump_resync_info: nit$resync_info,
      load_data: ^SEQ ( * ),
      load_file: amt$file_identifier,
      load_file_opened: boolean,
      load_resync_count: 0 .. max_load_resync_count,
      load_timer: nit$timer_value,
      max_transmission_rate: nat$transmit_rate,
      more_retries: boolean,
      next_dump_sequence_number: nit$sequence_number,
      next_load_sequence_number: nit$sequence_number,
      next_system: ^nit$dependent_system,
      number_of_initialize_attempts: 0 .. max_initialize_attempts,
      object_code_version: nat$object_code_version,
      reset_code: nit$reset_code,
      state: nit$state,
      system_address: nat$system_address,
      system_type: nit$system_type,
      timer: integer,
    recend;

  TYPE
    nit$timer_value = 0 .. max_timer_value;

  CONST
    help_offered_timer = 30000,
    dump_timer = 10000,
    inactive_timer = 600000,
    loading_timer = 100 {50} ,
    load_complete_timer = 30000,
    max_wait_time = 86400000,
    max_timer_value = 86400000 {24 hours in milliseconds} ;

  TYPE
    nit$state = (unknown, help_offered, dump_initiated, dumping, dump_aborted, loading, load_complete,
          inactive),
    nit$condition_processor = ^procedure
           (VAR input_pdu: nit$pdu;
            VAR dependent_system: nit$dependent_system),
    nit$condition_kind = (checksum_error, unknown_or_short_pdu_kind, help_request_excluded_system,
          help_request_device_unsupported, help_request_no_retries, help_request_more_retries,
          help_accept_with_dump, help_accept_without_dump, excessive_dump_data, dump_data_in_sequence,
          dump_data_low_sequence, dump_data_high_seq_try_resync, dump_data_high_seq_resync_sent,
          term_dump_in_seq_or_abnormal, term_dump_bad_seq_try_resync, term_dump_bad_seq_resync_sent,
          sync_load_bad_seq, sync_load_more_retries, sync_load_no_more_retries, timer_expired_more_retries,
          timer_expired_no_more_retries);

?? TITLE := 'External References', EJECT ??
*copyc amp$return
*copyc amp$set_segment_eoi
*copyc bap$validate_file_identifier
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc fsp$close_file
*copyc nap$xns_checksum
*copyc nap$cn_close_sap
*copyc nap$cn_open_sap
*copyc nap$cn_receive_datagram
*copyc nap$cn_send_datagram
*copyc nap$display_message
*copyc nap$process_init_directives
*copyc nap$open_di_dump_file
*copyc nap$open_di_load_file
*copyc nap$local_system_id
*copyc osp$append_status_integer
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$abort
*copyc pmp$establish_condition_handler
*copyc pmp$get_compact_date_time
*copyc pmp$get_microsecond_clock
*copyc pmp$log
*copyc pmp$get_task_cp_time

?? TITLE := 'Module Level Variables', EJECT ??

  VAR
    state_table: [STATIC, READ] array [nit$condition_kind] of array [nit$state] of record
      condition_processor: nit$condition_processor,
      new_state: nit$state,
    recend := [

    {checksum_error} [[^log_and_delete, unknown], [^log, help_offered],
          [^log, dump_initiated], [^log, dumping], [^log, dump_aborted],
          [^log, loading], [^log, load_complete], [^log, inactive]],

    {unknown_or_short_pdu_kind} [[^log_and_delete, unknown], [^log, help_offered], [^log, dump_initiated],
          [^log, dumping], [^log, dump_aborted], [^log, loading], [^log, load_complete], [^log, inactive]],

    {help_request_excluded_system} [[^log_and_delete, unknown], [^log_and_delete, unknown],
          [^log_and_delete, unknown], [^truncate_dump_and_delete, unknown],
          [^truncate_dump_and_delete, unknown], [^truncate_load_and_delete, unknown],
          [^truncate_load_and_delete, unknown], [^log_and_delete, unknown]],

    {help_request_device_unsupported} [[^log_and_delete, unknown], [^log_and_delete, unknown],
          [^log_and_delete, unknown], [^truncate_dump_and_delete, unknown],
          [^truncate_dump_and_delete, unknown], [^truncate_load_and_delete, unknown],
          [^truncate_load_and_delete, unknown], [^log_and_delete, unknown]],

    {help_request_no_retries} [[^delete, unknown], [^inactivate, inactive], [^inactivate, inactive],
          [^truncate_dump_and_inactivate, inactive], [^truncate_dump_and_inactivate, inactive],
          [^truncate_load_and_inactivate, inactive], [^truncate_load_and_inactivate, inactive],
          [^log, inactive]],

    {help_request_more_retries} [[^offer_help, help_offered], [^offer_help, help_offered],
          [^offer_help, help_offered], [^truncate_dump_and_help, help_offered],
          [^truncate_dump_and_help, help_offered], [^truncate_load_and_help, help_offered],
          [^truncate_load_and_help, help_offered], [^offer_help, help_offered]],

    {help_accept_with_dump} [[^log_and_delete, unknown], [^initiate_help, dump_initiated],
          [^start_dump, dump_initiated], [^log, dumping], [^log, dump_aborted], [^log, loading],
          [^log, load_complete], [^log, inactive]],

    {help_accept_without_dump} [[^log_and_delete, unknown], [^initiate_help, loading],
          [^ignore, dump_initiated], [^ignore, dumping], [^ignore, dump_aborted], [^start_load, loading],
          [^start_load, loading], [^log, inactive]],

    {excessive_dump_data} [[^delete, unknown], [^ignore, help_offered], [^abort_dump, dump_aborted],
          [^abort_dump, dump_aborted], [^ignore, dump_aborted], [^ignore, loading], [^ignore, load_complete],
          [^ignore, inactive]],

    {dump_data_in_sequence} [[^delete, unknown], [^ignore, help_offered], [^save_dump_data, dumping],
          [^save_dump_data, dumping], [^ignore, dump_aborted], [^ignore, loading], [^ignore, load_complete],
          [^ignore, inactive]],

    {dump_data_low_sequence} [[^delete, unknown], [^ignore, help_offered], [^ignore, dump_initiated],
          [^ignore, dumping], [^ignore, dump_aborted], [^ignore, loading], [^ignore, load_complete],
          [^ignore, inactive]],

    {dump_data_high_seq_try_resync} [[^delete, unknown], [^ignore, help_offered],
          [^start_dump, dump_initiated], [^resync_dump, dumping], [^ignore, dump_aborted], [^ignore, loading],
          [^ignore, load_complete], [^ignore, inactive]],

    {dump_data_high_seq_resync_sent} [[^delete, unknown], [^ignore, help_offered], [^ignore, dump_initiated],
          [^ignore, dumping], [^ignore, dump_aborted], [^ignore, loading], [^ignore, load_complete],
          [^ignore, inactive]],

    {term_dump_in_seq_or_abnormal} [[^delete, unknown], [^ignore, help_offered],
          [^end_dump_start_load, loading], [^end_dump_start_load, loading], [^end_dump_start_load, loading],
          [^ignore, loading], [^start_load, loading], [^ignore, inactive]],

    {term_dump_bad_seq_try_resync} [[^delete, unknown], [^ignore, help_offered],[^start_dump, dump_initiated],
          [^resync_dump, dumping], [^end_dump_start_load, loading], [^ignore, loading],[^start_load, loading],
          [^ignore, inactive]],

    {term_dump_bad_seq_resync_sent} [[^delete, unknown], [^ignore, help_offered], [^ignore, dump_initiated],
          [^ignore, dumping], [^end_dump_start_load, loading], [^ignore, loading], [^start_load, loading],
          [^ignore, inactive]],

    {sync_load_bad_seq} [[^delete, unknown], [^log, help_offered], [^log, dump_initiated], [^log, dumping],
          [^log, dump_aborted], [^log, loading], [^log, load_complete], [^log, inactive]],

    {sync_load_more_retries} [[^delete, unknown], [^log, help_offered], [^log, dump_initiated],
          [^log, dumping], [^log, dump_aborted], [^resync_load, loading], [^resync_load, loading],
          [^log, inactive]],

    {sync_load_no_more_retries} [[^delete, unknown], [^log, help_offered], [^log, dump_initiated],
          [^log, dumping], [^log, dump_aborted], [^abort_load, inactive], [^abort_load, inactive],
          [^log, inactive]],

    {timer_expired_more_retries} [[^delete, unknown], [^inactivate, inactive], [^start_dump, dump_initiated],
          [^resync_dump, dumping], [^abort_dump, dump_aborted], [^send_load_data, loading],
          [^inactivate, inactive], [^inactivate, inactive]],

    {timer_expired_no_more_retries} [[^delete, unknown], [^inactivate, inactive], [^abort_dump, dump_aborted],
          [^abort_dump, dump_aborted], [^inactivate, inactive], [^terminate_load, load_complete],
          [^inactivate, inactive], [^delete, unknown]]

    ];

  VAR
    log_message: array [nit$condition_kind] of ost$status_condition_code := [nae$init_checksum_error,
          nae$unknown_or_short_pdu, nae$excluded_system, nae$unsupported_device,
          nae$too_many_load_requests, 0, nae$unexpected_help_accept, nae$unexpected_help_accept, 0, 0, 0, 0,
          0, 0, 0, 0, nae$invalid_load_resync_request, nae$invalid_load_resync_request,
          nae$invalid_load_resync_request, 0, 0];

  VAR
    cp_time: pmt$task_cp_time := [0, 0],
    service_priority: nit$service_priority,
    default_object_code_version: nat$object_code_version,
    device_name: [STATIC, READ] array [1 .. 2] of string (3) := ['DI', 'ICA'],
    dump_error_list: nat$di_dump_error_list,
    max_connections: 0 .. 1000,
    max_dumps: 0 .. 1000,
    max_dump_size: 0 .. amc$file_byte_limit,
    max_dump_block_size: nat$data_length,
    max_load_block_size: nat$data_length,
    start_of_system_chain: ^nit$dependent_system := NIL,
    system_exceptions: nat$init_exception_list := NIL;

?? TITLE := 'Initialization Management Executive' ??
?? NEWTITLE := '  exit_condition_handler', EJECT ??

  PROGRAM nap$independent_init_manager
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      local_status.normal := TRUE;
      nap$cn_close_sap (nac$cn_initialization_me_sap, local_status);
      IF (NOT local_status.normal) AND status.normal THEN
        status := local_status;
      IFEND;

    PROCEND exit_condition_handler;
?? OLDTITLE, EJECT ??

    VAR
      data_buffer: ^SEQ ( * ),
      datagram_length: integer,
      dependent_system_location: ^nit$dependent_system,
      device_id: nlt$device_identifier,
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      establish_descriptor: pmt$established_handler,
      received_datagram: array [1 .. 1] of nat$data_fragment,
      input_pdu: nit$pdu,
      max_datagram_size: nat$data_length,
      remaining_time: nit$timer_value,
      system_address: nat$system_address;

    process_parameters (parameter_list, service_priority, max_connections, max_dumps, max_dump_size, status);
    IF NOT status.normal THEN
      nap$display_message (status);
      RETURN;
    IFEND;

    nap$process_init_directives (system_exceptions, default_object_code_version, dump_error_list, status);
    IF NOT status.normal THEN
      nap$display_message (status);
      osp$set_status_condition (nae$errors_in_exception_list, status);
      RETURN;
    IFEND;

    pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^establish_descriptor, status);
    IF NOT status.normal THEN
      nap$display_message (status);
      RETURN;
    IFEND;
    nap$cn_open_sap (nac$cn_initialization_me_sap, max_datagram_size, status);
    IF NOT status.normal THEN
      nap$display_message (status);
      RETURN;
    IFEND;
    PUSH data_buffer: [[REP max_datagram_size OF cell]];
    max_dump_block_size := max_datagram_size - #SIZE (nit$dump_data_unit) - #SIZE (nat$checksum_value);
    max_dump_block_size := max_dump_block_size - (max_dump_block_size MOD 2);
    max_load_block_size := max_datagram_size - #SIZE (nit$load_data_unit) - #SIZE (nat$checksum_value);
    max_load_block_size := max_load_block_size - (max_load_block_size MOD 2);

    remaining_time := 0;
    received_datagram [1].address := data_buffer;
    received_datagram [1].length := #SIZE (data_buffer^);

{   report_cp_time;

    WHILE TRUE DO
      nap$cn_receive_datagram (nac$cn_initialization_me_sap, received_datagram, remaining_time,
            device_id, system_address, datagram_length, status);
      IF status.normal THEN
        RESET data_buffer;
        NEXT input_pdu: [[REP datagram_length OF cell]] IN data_buffer;
        find_dependent_system (system_address, device_id, dependent_system_location);
        IF dependent_system_location = NIL THEN {nil only if memory allocation fails}
          osp$set_status_abnormal (nac$status_id, nae$allocation_failed, 'NETWORK INITIALIZER', status);
          nap$display_message (status);
        ELSE
          process_channelnet_input (input_pdu, dependent_system_location^);
        IFEND;

      ELSE

{       IF status.condition = nae$no_datagram_available THEN

        status.normal := TRUE;

{       ELSE

{         RETURN {SYSTEM ERROR ;

{       IFEND;

      IFEND;

      find_shortest_timer (dependent_system_location, remaining_time);
      IF (remaining_time = 0) THEN {a timer has expired}
        process_timer (dependent_system_location^);
        find_shortest_timer (dependent_system_location, remaining_time);
      IFEND;
    WHILEND;

  PROCEND nap$independent_init_manager;
?? TITLE := 'Initialization Parameter Processor', EJECT ??

  PROCEDURE process_parameters
    (    parameter_list: clt$parameter_list;
     VAR service_priority: nit$service_priority;
     VAR max_connections: 0 .. 1000;
     VAR max_dumps: 0 .. 1000;
     VAR max_dump_size: 0 .. amc$file_byte_limit;
     VAR status: ost$status);


{   PDT initialization_m_e_pdt (
{     priority,p : integer 0 .. 3 = 3
{     maximum_connections,mc : integer 0 .. 1000 = 1000
{     maximum_dumps,md : integer 0 .. 1000 = 10
{     maximum_dump_size,mds : integer 0 .. amc$file_byte_limit = 16000000
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    initialization_m_e_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
  ^initialization_m_e_pdt_names, ^initialization_m_e_pdt_params];

  VAR
    initialization_m_e_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 9] of
  clt$parameter_name_descriptor := [['PRIORITY', 1], ['P', 1], ['MAXIMUM_CONNECTIONS', 2], ['MC', 2], [
  'MAXIMUM_DUMPS', 3], ['MD', 3], ['MAXIMUM_DUMP_SIZE', 4], ['MDS', 4], ['STATUS', 5]];

  VAR
    initialization_m_e_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of
  clt$parameter_descriptor := [

{ PRIORITY P }
    [[clc$optional_with_default, ^initialization_m_e_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, 0, 3]],

{ MAXIMUM_CONNECTIONS MC }
    [[clc$optional_with_default, ^initialization_m_e_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, 0, 1000]],

{ MAXIMUM_DUMPS MD }
    [[clc$optional_with_default, ^initialization_m_e_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, 0, 1000]],

{ MAXIMUM_DUMP_SIZE MDS }
    [[clc$optional_with_default, ^initialization_m_e_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, 0, amc$file_byte_limit]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    initialization_m_e_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '3';

  VAR
    initialization_m_e_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := '1000';

  VAR
    initialization_m_e_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := '10';

  VAR
    initialization_m_e_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (8) := '16000000';

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      value: clt$value;

    clp$scan_parameter_list (parameter_list, initialization_m_e_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('PRIORITY', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    service_priority := value.int.value;

    clp$get_value ('MAXIMUM_CONNECTIONS', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    max_connections := value.int.value;

    clp$get_value ('MAXIMUM_DUMPS', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    max_dumps := value.int.value;

    clp$get_value ('MAXIMUM_DUMP_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    max_dump_size := value.int.value;

  PROCEND process_parameters;

?? TITLE := 'Event Processors' ??
?? NEWTITLE := 'Process_channelnet_input', EJECT ??

  PROCEDURE process_channelnet_input
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

    VAR
      condition: nit$condition_kind,
      current_state: nit$state,
      data_to_checksum: array [1 .. 1] of nat$data_fragment,
      data_unit_id: ^nit$data_unit_id,
      dump_data: ^nit$dump_data_unit,
      help_request: ^nit$help_request_data_unit,
      input_checksum: ^nat$checksum_value,
      input_data: ^SEQ ( * ),
      status: ost$status,
      synchronize_load: ^nit$synchronize_load_data_unit,
      system_address: nat$system_address,
      terminate_dump: ^nit$term_dump_data_unit;

    IF #SIZE (input_pdu^) >= (#SIZE (nat$checksum_value) + #SIZE (nit$data_unit_id)) THEN
      data_to_checksum [1].address := input_pdu;
      data_to_checksum [1].length := #SIZE (input_pdu^) - #SIZE (nat$checksum_value);
      RESET input_pdu;
      NEXT input_data: [[REP data_to_checksum [1].length OF cell]] IN input_pdu;
      NEXT input_checksum IN input_pdu;

      IF input_checksum^ = nap$xns_checksum (data_to_checksum) THEN
        RESET input_data;
        NEXT data_unit_id IN input_data;
        RESET input_data;

        CASE data_unit_id^ OF
        = help_request_id =
          status.normal := TRUE;
          nap$process_init_directives (system_exceptions, default_object_code_version, dump_error_list,
                status);
          IF NOT status.normal THEN { error processing exception file - use previous version }
            nap$display_message (status);
            osp$set_status_abnormal (nac$status_id, nae$errors_in_exception_list,
                  'Last valid exception list used.', status);
            nap$display_message (status);
          IFEND;

          NEXT help_request IN input_data;
          IF help_request = NIL THEN
            condition := unknown_or_short_pdu_kind;
          ELSEIF system_excluded (help_request^.requesting_system_id) THEN
            condition := help_request_excluded_system;
          ELSEIF (help_request^.flags.system_type <> di_system) AND
                (help_request^.flags.system_type <> ica2_system) THEN
            condition := help_request_device_unsupported;
          ELSEIF (help_request^.reset_code.code = power_up_reset) OR
                (help_request^.reset_code.code = manual_reset) THEN
            condition := help_request_more_retries;
          ELSEIF dependent_system.number_of_initialize_attempts >= max_initialize_attempts THEN
            condition := help_request_no_retries;
          ELSE
            condition := help_request_more_retries;
          IFEND;

        = help_accept_id =
          IF dependent_system.dump_required THEN
            condition := help_accept_with_dump;
          ELSE
            condition := help_accept_without_dump;
          IFEND;

        = dump_data_id =
          NEXT dump_data IN input_data;
          IF dump_data = NIL THEN
            condition := unknown_or_short_pdu_kind;
          ELSEIF dependent_system.dump_overflow THEN
            condition := excessive_dump_data;
          ELSEIF dump_data^.sequence_number = dependent_system.next_dump_sequence_number THEN
            condition := dump_data_in_sequence;
          ELSEIF dump_data^.sequence_number < dependent_system.next_dump_sequence_number THEN
            condition := dump_data_low_sequence;
          ELSEIF dependent_system.dump_resync_count = 0 THEN
            condition := dump_data_high_seq_try_resync;
          ELSE
            condition := dump_data_high_seq_resync_sent;
          IFEND;

        = terminate_dump_id =
          NEXT terminate_dump IN input_data;
          IF terminate_dump = NIL THEN
            condition := unknown_or_short_pdu_kind;
          ELSEIF (terminate_dump^.sequence_number = dependent_system.next_dump_sequence_number - 1) OR
                (terminate_dump^.code <> normal_dump_termination) THEN
            condition := term_dump_in_seq_or_abnormal;
          ELSEIF dependent_system.dump_resync_count = 0 THEN
            condition := term_dump_bad_seq_try_resync;
          ELSE
            condition := term_dump_bad_seq_resync_sent;
          IFEND;

        = synchronize_load_id =
          NEXT synchronize_load IN input_data;
          IF synchronize_load = NIL THEN
            condition := unknown_or_short_pdu_kind;
          ELSEIF synchronize_load^.sequence_number > dependent_system.next_load_sequence_number THEN
            condition := sync_load_bad_seq;
          ELSEIF dependent_system.load_resync_count < max_load_resync_count THEN
            condition := sync_load_more_retries;
          ELSE
            condition := sync_load_no_more_retries;
          IFEND;

        ELSE
          condition := unknown_or_short_pdu_kind;
        CASEND;
      ELSE
        condition := checksum_error;
      IFEND;
    ELSE
      condition := unknown_or_short_pdu_kind;
    IFEND;

    current_state := dependent_system.state;
    dependent_system.state := state_table [condition] [current_state].new_state;
    dependent_system.condition := condition;
    state_table [condition] [current_state].condition_processor^ (input_data, dependent_system);
  PROCEND process_channelnet_input;
?? TITLE := 'Process_timer', EJECT ??

  PROCEDURE process_timer
    (VAR dependent_system: nit$dependent_system);

    VAR
      condition: nit$condition_kind,
      current_state: nit$state,
      nil_input_pdu: [STATIC] nit$pdu := NIL;

    IF dependent_system.more_retries THEN
      condition := timer_expired_more_retries;
    ELSE
      condition := timer_expired_no_more_retries;
    IFEND;

    current_state := dependent_system.state;
    dependent_system.state := state_table [condition] [current_state].new_state;
    state_table [condition] [current_state].condition_processor^ (nil_input_pdu, dependent_system);
  PROCEND process_timer;
?? OLDTITLE ??
?? TITLE := 'Condition Processors' ??
?? NEWTITLE := 'abort_dump', EJECT ??

  PROCEDURE abort_dump
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

    VAR
      abort: nit$abort_dump_data_unit,
      more_retries: boolean,
      output_data: array [1 .. 1] of nat$data_fragment;

{ This processor sends an abort dump pdu to the dependent system.

    dependent_system.abort_dump_count := dependent_system.abort_dump_count + 1;

    abort.identifier := abort_dump_id;
    output_data [1].address := ^abort;
    output_data [1].length := #SIZE (abort);
    send_pdu (output_data, dependent_system.device_id, dependent_system.system_address);

    more_retries := dependent_system.abort_dump_count < max_abort_dump_count;
    set_timer (dependent_system, dump_timer, more_retries);
  PROCEND abort_dump;
?? TITLE := 'abort_load', EJECT ??

  PROCEDURE abort_load
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

{ This processor logs the load failure and inactivates the dependent system.
{ Only a help request from the dependent system will be honored.

    VAR
      status: ost$status;

    osp$set_status_abnormal (nac$status_id, nae$excessive_resyncs, '', status);
    osp$append_status_integer (osc$status_parameter_delimiter, dependent_system.system_address.system, 16,
          FALSE, status);
    nap$display_message (status);
    inactivate (input_pdu, dependent_system);
  PROCEND abort_load;
?? TITLE := 'delete', EJECT ??

  PROCEDURE delete
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

{ This processor deletes all system specific information for a dependent system

    delete_dependent_system (dependent_system.system_address);
  PROCEND delete;
?? TITLE := 'end_dump_start_load', EJECT ??

  PROCEDURE end_dump_start_load
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

{ This processor provides the transition from the dump phase to the load phase

    VAR
      terminate_dump: ^nit$term_dump_data_unit;

    RESET input_pdu;
    NEXT terminate_dump IN input_pdu;

{   IF terminate_dump^.code = dump_memory_error THEN
{     pmp$log ('dump_memory_error', status);
{   IFEND;

    close_dump_file (dependent_system);

{   report_cp_time;

    start_load (input_pdu, dependent_system);
  PROCEND end_dump_start_load;
?? TITLE := 'ignore', EJECT ??

  PROCEDURE ignore
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

{ This processor is called when an unexpected condition arises that is not a
{ definite error indication. Also, any condition that does represent an error
{ but could occur many times in a row should be logged no more than once.
{ An example is a series of dump data units when the load phase has already
{ begun.

  PROCEND ignore;
?? TITLE := 'inactivate', EJECT ??

  PROCEDURE inactivate
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

{ This processor closes any files still open for a system and establishes a long
{ timer. When this timer expires, the information for the system will be
{ deleted. However, if another help request is received before the timer expires,
{ it will be considered to be a continuation of the previous help attempt and
{ limits on help attempts and dumps will continue to be enforced.

    close_dump_file (dependent_system);
    close_load_file (dependent_system);
    set_timer (dependent_system, inactive_timer, {more retries =} FALSE);
  PROCEND inactivate;
?? TITLE := 'initiate_help', EJECT ??

  PROCEDURE initiate_help
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

    VAR
      status: ost$status;

{ This processor counts the number of times help has been provided and starts
{ the dump or load as appropriate.

    IF dependent_system.number_of_initialize_attempts < max_initialize_attempts THEN
      dependent_system.number_of_initialize_attempts := dependent_system.number_of_initialize_attempts + 1;
    IFEND;
    osp$set_status_abnormal (nac$status_id, nae$di_reset, device_name [dependent_system.system_type], status);
    osp$append_status_integer (osc$status_parameter_delimiter, dependent_system.system_address.system, 16,
          FALSE, status);
    osp$append_status_integer (osc$status_parameter_delimiter, dependent_system.reset_code.code, 16, TRUE,
          status);
    nap$display_message (status);

{   report_cp_time;

    IF dependent_system.dump_required THEN
      dependent_system.dump_resync_count := 0;
      dependent_system.abort_dump_count := 0;
      start_dump (input_pdu, dependent_system);
      dependent_system.dump_resync_count := 0 {if first dump pdu is bad, restart dump immediately} ;
    ELSE
      start_load (input_pdu, dependent_system);
    IFEND;
  PROCEND initiate_help;
?? TITLE := 'logging processors', EJECT ??

  PROCEDURE log
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

{ This processor is called when a condition arises that is an error
{ indication but no action is required in response to the condition.
{ These conditions are logged.

    VAR
      status: ost$status;

    IF log_message [dependent_system.condition] > 0 THEN
      osp$set_status_condition (log_message [dependent_system.condition], status);
      osp$append_status_integer (osc$status_parameter_delimiter, dependent_system.system_address.system, 16,
            FALSE, status);
      nap$display_message (status);
    IFEND;

  PROCEND log;


  PROCEDURE log_and_delete
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

{ This processor logs the unexpected condition and deletes the system entry.

    log (input_pdu, dependent_system);
    delete (input_pdu, dependent_system);
  PROCEND log_and_delete;

?? TITLE := 'offer_help', EJECT ??

  PROCEDURE offer_help
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

{ This processor sends a help offer pdu to a dependent system requesting help.
{ Pertinent information is saved from the help request pdu.

    VAR
      help_offer: nit$help_offer_data_unit,
      help_request: ^nit$help_request_data_unit,
      output_data: array [1 .. 1] of nat$data_fragment;

    RESET input_pdu;
    NEXT help_request IN input_pdu;

    get_system_init_values (help_request^.requesting_system_id, help_request^.reset_code.code,
          dependent_system.object_code_version, dependent_system.dump_required,
          dependent_system.max_transmission_rate);
    IF dependent_system.dump_required AND ((dependent_system.dump_count = max_dump_count) OR
          (NOT help_request^.flags.auto_dump)) THEN

{     pmp$log ('dump_suppressed', status);

      dependent_system.dump_required := FALSE;
    IFEND;

    dependent_system.boot_card := help_request^.boot_card;
    dependent_system.reset_code := help_request^.reset_code;
    dependent_system.system_type := help_request^.flags.system_type;

    dependent_system.load_timer := (max_load_block_size * 8000) DIV dependent_system.max_transmission_rate;
    IF dependent_system.load_timer < loading_timer THEN
      dependent_system.load_timer := loading_timer;
    IFEND;

    help_offer.identifier := help_offer_id;
    help_offer.service_definition.priority := service_priority;
    help_offer.service_definition.reserved := 0 {this field used by ESCI for debug} ;
    help_offer.version_number := dependent_system.object_code_version;
    help_offer.network_id := dependent_system.system_address.network;
    help_offer.host_system_id := nap$local_system_id ();

    output_data [1].address := ^help_offer;
    output_data [1].length := #SIZE (help_offer);
    send_pdu (output_data, dependent_system.device_id, dependent_system.system_address);

    set_timer (dependent_system, help_offered_timer, {more_retries =} FALSE);
  PROCEND offer_help;
?? TITLE := 'resync_dump', EJECT ??

  PROCEDURE resync_dump
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

{ This processor sends a synchronize dump pdu and keeps count of the number of
{ such pdu's sent during this resynchronization attempt.

    VAR
      more_retries: boolean,
      output_data: array [1 .. 1] of nat$data_fragment,
      synchronize_dump: nit$synchronize_dump_data_unit;

    dependent_system.dump_resync_count := dependent_system.dump_resync_count + 1;

    synchronize_dump.identifier := synchronize_dump_id;
    synchronize_dump.sequence_number := dependent_system.next_dump_sequence_number;
    synchronize_dump.save_area := dependent_system.last_dump_resync_info;

    output_data [1].address := ^synchronize_dump;
    output_data [1].length := #SIZE (synchronize_dump);
    send_pdu (output_data, dependent_system.device_id, dependent_system.system_address);

    more_retries := dependent_system.dump_resync_count < max_dump_resync_count;
    set_timer (dependent_system, dump_timer, more_retries);
  PROCEND resync_dump;
?? TITLE := 'resync_load', EJECT ??

  PROCEDURE resync_load
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

{ This processor resets the load process as requested in a synchronize load pdu

    VAR
      skipped_data: ^SEQ ( * ),
      synchronize_load: ^nit$synchronize_load_data_unit;

    RESET input_pdu;
    NEXT synchronize_load IN input_pdu;

    dependent_system.load_resync_count := dependent_system.load_resync_count + 1;
    dependent_system.next_load_sequence_number := synchronize_load^.sequence_number;
    RESET dependent_system.load_data;
    IF dependent_system.next_load_sequence_number > 0 THEN
      NEXT skipped_data: [[REP dependent_system.next_load_sequence_number * max_load_block_size OF cell]] IN
            dependent_system.load_data;
    IFEND;
    IF synchronize_load^.flags.overflow THEN
      dependent_system.load_timer := dependent_system.load_timer + loading_timer;

{
{  Make sure the load time delay never goes above 5000 milliseconds (5 seconds)
{

      IF dependent_system.load_timer > 5000 THEN
        dependent_system.load_timer := 5000;
      IFEND;
    IFEND;

    send_load_data (input_pdu, dependent_system);
  PROCEND resync_load;
?? TITLE := 'save_dump_data', EJECT ??

  PROCEDURE save_dump_data
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

{ This processor adds a block of dump data to the dump file.

    VAR
      dump_block: ^SEQ ( * ),
      dump_data: ^nit$dump_data_unit,
      dump_byte_count: nat$data_length,
      dump_information: ^SEQ ( * );

    dump_byte_count := #SIZE (input_pdu^) - #SIZE (nit$dump_data_unit);
    RESET input_pdu;
    NEXT dump_data IN input_pdu;
    NEXT dump_information: [[REP dump_byte_count OF cell]] IN input_pdu;

    dependent_system.last_dump_resync_info := dump_data^.save_area;
    dependent_system.dump_resync_count := 0;
    dependent_system.next_dump_sequence_number := dependent_system.next_dump_sequence_number + 1;

    NEXT dump_block: [[REP dump_byte_count OF cell]] IN dependent_system.dump_data;
    IF dump_block = NIL THEN
      dependent_system.dump_overflow := TRUE;

{     pmp$log ('dump truncated - too long', status);

    ELSE
      dump_block^ := dump_information^;
    IFEND;

    set_timer (dependent_system, dump_timer, {more retries =} TRUE);
  PROCEND save_dump_data;
?? TITLE := 'send_load_data', EJECT ??

  PROCEDURE send_load_data
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

{ This processor sends load data pdu's to the dependent system. Several load
{ pdu's are generated on each invocation. A short timer is used to interrupt
{ load pdu generation and allow other processing.

    VAR
      load_block_size: nat$data_length,
      load_data: nit$load_data_unit,
      load_data_pointer: ^SEQ ( * ),
      output_data: array [1 .. 3] of nat$data_fragment,
      pad_byte: [STATIC] 0 .. 0ff(16) := 0,
      pdu_count: 0 .. load_pdu_block_count;

    load_data.identifier := load_data_id;

  /send_load_pdu/
    FOR pdu_count := 1 TO load_pdu_block_count DO
      load_data.sequence_number := dependent_system.next_load_sequence_number;
      IF ((load_data.sequence_number + 1) * max_load_block_size) >= #SIZE (dependent_system.load_data^) THEN
        load_block_size := #SIZE (dependent_system.load_data^) -
              (load_data.sequence_number * max_load_block_size);

{ include pad byte if load block is odd number of bytes

        output_data [3].length := load_block_size MOD 2;
        load_data.flags.last_data_unit := TRUE;
      ELSE
        load_block_size := max_load_block_size;
        load_data.flags.last_data_unit := FALSE;
        output_data [3].length := 0 {no pad byte needed} ;
      IFEND;
      NEXT load_data_pointer: [[REP load_block_size OF cell]] IN dependent_system.load_data;

      output_data [1].address := ^load_data;
      output_data [1].length := #SIZE (load_data);
      output_data [2].address := load_data_pointer;
      output_data [2].length := load_block_size;
      output_data [3].address := ^pad_byte;
      send_pdu (output_data, dependent_system.device_id, dependent_system.system_address);
      IF load_data.flags.last_data_unit THEN
        EXIT /send_load_pdu/;
      IFEND;
      dependent_system.next_load_sequence_number := dependent_system.next_load_sequence_number + 1;
    FOREND /send_load_pdu/;

    set_timer (dependent_system, dependent_system.load_timer,
          {more retries =} NOT load_data.flags.last_data_unit);
  PROCEND send_load_data;
?? TITLE := 'start_dump', EJECT ??

  PROCEDURE start_dump
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

{ This processor issues a begin auto dump pdu. The number of start dump attempts
{ is kept to allow the dump process to be abandoned if the dependent system does
{ not respond appropriately.

    VAR
      begin_auto_dump: nit$auto_dump_data_unit,
      converted_time: string (20),
      count: integer,
      date_time: ost$date_time,
      flow_control_rate: integer,
      index: integer,
      more_retries: boolean,
      output_data: array [1 .. 1] of nat$data_fragment,
      status: ost$status,
      system: string (12),
      system_id: string (15),
      timestamp: string (12);

    IF NOT dependent_system.dump_file_opened THEN
      STRINGREP (system_id, count, dependent_system.system_address.system: 13: #(16));
      system := system_id (2, 12);
      FOR index := 1 TO #SIZE (system) DO
        IF system (index) = ' ' THEN
          system (index) := '0';
        IFEND;
      FOREND;

      pmp$get_compact_date_time (date_time, {ignore} status);
      STRINGREP (converted_time, count, date_time.year: 3, date_time.month: 3, date_time.day: 3,
            date_time.hour: 3, date_time.minute: 3, date_time.second: 3);
      timestamp (1, 2) := converted_time (2, 2) {year} ;
      timestamp (3, 2) := converted_time (5, 2) {month} ;
      timestamp (5, 2) := converted_time (8, 2) {day} ;
      timestamp (7, 2) := converted_time (11, 2) {hour} ;
      timestamp (9, 2) := converted_time (14, 2) {minute} ;
      timestamp (11, 2) := converted_time (17, 2) {second} ;
      FOR index := 1 TO #SIZE (system) DO
        IF timestamp (index) = ' ' THEN
          timestamp (index) := '0';
        IFEND;
      FOREND;
      status.normal := TRUE;
      nap$open_di_dump_file (system, timestamp, 'FULL', max_dumps, max_dump_size, dependent_system.dump_file,
            dependent_system.dump_data, dependent_system.dump_file_opened, status);
      IF status.normal THEN

{       pmp$log ('dump_initiated', status);

        dependent_system.dump_count := dependent_system.dump_count + 1;
        dependent_system.dump_overflow := FALSE;
      ELSE {abort dump}
        nap$display_message (status);
        dependent_system.dump_overflow := TRUE;

{       pmp$log ('dump_suppressed', status);
{start the di dump - dump data unit will trigger transition to loading state.

      IFEND;
    IFEND;

    dependent_system.next_dump_sequence_number := 0;
    dependent_system.dump_resync_count := dependent_system.dump_resync_count + 1;

    begin_auto_dump.identifier := begin_auto_dump_id;

{   Calculate the speed at which the dump is to occur.
{
{   This value is calculated using the following formula:
{          ((max_dump_block_size  *  8 bits  *  1000 ms)  DIV  transmission_rate)  DIV  10 ms
{
{   NOTE: The dependent system expects the flow_control value to be in 10's of milliseconds.
{         That is why there is a division by 10 ms.

    flow_control_rate := (max_dump_block_size * 800) DIV dependent_system.max_transmission_rate;
    IF flow_control_rate > UPPERVALUE(nit$dump_flow_control) THEN
      begin_auto_dump.flow_control := UPPERVALUE(nit$dump_flow_control);
    ELSEIF flow_control_rate < default_flow_control THEN
      begin_auto_dump.flow_control := default_flow_control;
    ELSE
      begin_auto_dump.flow_control := flow_control_rate;
    IFEND;
    begin_auto_dump.max_data_length := max_dump_block_size;

    output_data [1].address := ^begin_auto_dump;
    output_data [1].length := #SIZE (begin_auto_dump);
    send_pdu (output_data, dependent_system.device_id, dependent_system.system_address);

    more_retries := dependent_system.dump_resync_count < max_dump_resync_count;
    set_timer (dependent_system, dump_timer, more_retries);
  PROCEND start_dump;
?? TITLE := 'start_load', EJECT ??

  PROCEDURE start_load
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

{ This processor obtains the load file and initializes the loading process.
{ If the load file is not available, the load is marked complete and the timer
{ is set to zero to trigger an immediate state change. The reason for the
{ failure has already been logged by the load file open routine.

    VAR
      byte_count: ^1 .. llc$maximum_68000_address,
      count: integer,
      idr_header: ^llt$identification,
      index: integer,
      load_data: ^SEQ ( * ),
      m68000_text_descriptor: ^0 .. 0ffffffffff(16),
      status: ost$status,
      text_descriptor: ^llt$object_text_descriptor,
      version: string (5);

    IF dependent_system.load_file_opened THEN
      dependent_system.load_resync_count := dependent_system.load_resync_count + 1;
    ELSE
      dependent_system.load_resync_count := 0;
      STRINGREP (version, count, dependent_system.object_code_version: 5: #(16)); {allow room for leading 0}
      FOR index := 1 TO count DO
        IF version (index) = ' ' THEN
          version (index) := '0';
        IFEND;
      FOREND;
      status.normal := TRUE;
      nap$open_di_load_file (version (2, * ), dependent_system.boot_card, dependent_system.load_file,
            load_data, dependent_system.load_file_opened, status);
      IF NOT status.normal THEN {load file not available - mark load complete (no more retries)}
        nap$display_message (status);
        set_timer (dependent_system, 0, {more retries =} FALSE);
        RETURN;
      IFEND;

{     pmp$log ('load_initiated', status);

      RESET load_data;
      NEXT text_descriptor IN load_data;
      NEXT idr_header IN load_data;
      NEXT text_descriptor IN load_data;
      RESET load_data TO text_descriptor;
      NEXT m68000_text_descriptor IN load_data;
      NEXT byte_count IN load_data;
      byte_count^ := text_descriptor^.number_of_68000_bytes;
      RESET load_data TO byte_count;
      NEXT dependent_system.load_data: [[REP #SIZE (load_data^) - #SIZE (llt$object_text_descriptor) -
            #SIZE (llt$identification) - #SIZE (m68000_text_descriptor^) OF cell]] IN load_data;
    IFEND;
    dependent_system.next_load_sequence_number := 0;
    RESET dependent_system.load_data;
    send_load_data (input_pdu, dependent_system);
  PROCEND start_load;
?? TITLE := 'terminate_load', EJECT ??

  PROCEDURE terminate_load
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

{   VAR
{     status: ost$status;

{ This processor sets a timer at the end of the load process. During this timer
{ interval, synchronize load requests from the dependent system will be honored.
{ When the timer expires, the system will be changed to the inactive state and
{ only help requests will be processed. If the load file is not open at this
{ point, then a failure in the load process has occurred and a zero timer is
{ used to trigger an immediate state change.

    IF dependent_system.load_file_opened THEN
      set_timer (dependent_system, load_complete_timer, {more retries =} FALSE);

{     pmp$log ('load completed', status);
{     report_cp_time;

    ELSE
      set_timer (dependent_system, 0, {more retries =} FALSE);
    IFEND;
  PROCEND terminate_load;
?? TITLE := 'Truncate dump/load Processors', EJECT ??

{ The truncate... processors terminate a dump or load abnormally, log the
{ abnormality, and then continue with the wrapup process indicated by their
{ name.

  PROCEDURE truncate_dump_and_delete
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

    truncate_dump (dependent_system);
    delete (input_pdu, dependent_system);
  PROCEND truncate_dump_and_delete;

  PROCEDURE truncate_dump_and_help
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

    truncate_dump (dependent_system);
    offer_help (input_pdu, dependent_system);
  PROCEND truncate_dump_and_help;

  PROCEDURE truncate_dump_and_inactivate
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

    truncate_dump (dependent_system);
    inactivate (input_pdu, dependent_system);
  PROCEND truncate_dump_and_inactivate;

  PROCEDURE truncate_load_and_delete
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

    truncate_load (dependent_system);
    delete (input_pdu, dependent_system);
  PROCEND truncate_load_and_delete;

  PROCEDURE truncate_load_and_help
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

    truncate_load (dependent_system);
    offer_help (input_pdu, dependent_system);
  PROCEND truncate_load_and_help;

  PROCEDURE truncate_load_and_inactivate
    (VAR input_pdu: nit$pdu;
     VAR dependent_system: nit$dependent_system);

    truncate_load (dependent_system);
    inactivate (input_pdu, dependent_system);
  PROCEND truncate_load_and_inactivate;
?? OLDTITLE ??

?? TITLE := 'Miscellaneous Routines' ??
?? NEWTITLE := 'close (dump/load) file', EJECT ??

  PROCEDURE close_dump_file
    (VAR dependent_system: nit$dependent_system);

    VAR
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      file_name: amt$local_file_name,
      segment_pointer: amt$segment_pointer,
      status: ost$status;

    IF dependent_system.dump_file_opened THEN
      status.normal := TRUE;
      segment_pointer.kind := amc$sequence_pointer;
      segment_pointer.sequence_pointer := dependent_system.dump_data;
      amp$set_segment_eoi (dependent_system.dump_file, segment_pointer, status);
      status.normal := TRUE;
      bap$validate_file_identifier (dependent_system.dump_file, file_instance, file_id_is_valid);
      file_name := file_instance^.local_file_name;
      fsp$close_file (dependent_system.dump_file, status);
      amp$return (file_name, status);
      dependent_system.dump_file_opened := FALSE;

{     pmp$log ('dump_completed', status);

    IFEND;
  PROCEND close_dump_file;

  PROCEDURE close_load_file
    (VAR dependent_system: nit$dependent_system);

    VAR
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      file_name: amt$local_file_name,
      status: ost$status;

    IF dependent_system.load_file_opened THEN
      status.normal := TRUE;
      bap$validate_file_identifier (dependent_system.load_file, file_instance, file_id_is_valid);
      file_name := file_instance^.local_file_name;
      fsp$close_file (dependent_system.load_file, status);
      amp$return (file_name, status);
      dependent_system.load_file_opened := FALSE;
    IFEND;
  PROCEND close_load_file;
?? TITLE := 'delete_dependent_system', EJECT ??

  PROCEDURE delete_dependent_system
    (    system_address: nat$system_address);

    VAR
      dependent_system_location: ^nit$dependent_system,
      previous_link: ^^nit$dependent_system;

    previous_link := ^start_of_system_chain;
    dependent_system_location := start_of_system_chain;
    WHILE dependent_system_location <> NIL DO
      IF dependent_system_location^.system_address = system_address THEN
        previous_link^ := dependent_system_location^.next_system;
        FREE dependent_system_location;
        RETURN;
      IFEND;
      previous_link := ^dependent_system_location^.next_system;
      dependent_system_location := dependent_system_location^.next_system;
    WHILEND;
  PROCEND delete_dependent_system;
?? TITLE := 'find_dependent_system', EJECT ??

  PROCEDURE find_dependent_system
    (    system_address: nat$system_address;
         device_id: nlt$device_identifier;
     VAR dependent_system_location: ^nit$dependent_system);

    dependent_system_location := start_of_system_chain;
    WHILE dependent_system_location <> NIL DO
      IF dependent_system_location^.system_address = system_address THEN

{ Update the device identifier field. This is done in case a DI is now
{ attempting to initialize across another device (i.e., using another
{ MCI within the same DI).

        dependent_system_location^.device_id := device_id;
        RETURN;
      IFEND;
      dependent_system_location := dependent_system_location^.next_system;
    WHILEND;

    ALLOCATE dependent_system_location;
    IF dependent_system_location <> NIL THEN
      dependent_system_location^.system_address := system_address;
      dependent_system_location^.device_id := device_id;
      dependent_system_location^.next_system := start_of_system_chain;
      start_of_system_chain := dependent_system_location;

      dependent_system_location^.abort_dump_count := 0;
      dependent_system_location^.dump_count := 0;
      dependent_system_location^.dump_data := NIL;
      dependent_system_location^.dump_file_opened := FALSE;
      dependent_system_location^.dump_overflow := FALSE;
      dependent_system_location^.dump_required := FALSE;
      dependent_system_location^.dump_resync_count := 0;
      dependent_system_location^.load_data := NIL;
      dependent_system_location^.load_file_opened := FALSE;
      dependent_system_location^.load_resync_count := 0;
      dependent_system_location^.more_retries := FALSE;
      dependent_system_location^.number_of_initialize_attempts := 0;
      dependent_system_location^.state := unknown;
    IFEND;

  PROCEND find_dependent_system;
?? TITLE := 'find_shortest_timer', EJECT ??

  PROCEDURE find_shortest_timer
    (VAR dependent_system_location: ^nit$dependent_system;
     VAR remaining_time {in milliseconds} : nit$timer_value);

    VAR
      current_microsecond_time: integer,
      current_millisecond_time: integer,
      millisecond_timer: integer,
      next_system: ^nit$dependent_system,
      next_timer_to_expire: ^nit$dependent_system,
      next_timer_value: integer,
      status: ost$status;

    status.normal := TRUE;
    current_millisecond_time := #FREE_RUNNING_CLOCK (0) DIV 1000;

    next_system := start_of_system_chain;
    next_timer_to_expire := start_of_system_chain;
    next_timer_value := current_millisecond_time + max_timer_value;

    WHILE next_system <> NIL DO
      IF next_system^.timer < next_timer_value THEN
        next_timer_value := next_system^.timer;
        next_timer_to_expire := next_system;
      IFEND;
      next_system := next_system^.next_system;
    WHILEND;

    dependent_system_location := next_timer_to_expire;
    millisecond_timer := next_timer_value - current_millisecond_time;
    IF millisecond_timer < 0 THEN
      remaining_time := 0;
    ELSEIF millisecond_timer > max_wait_time THEN
      remaining_time := max_wait_time;
    ELSE
      remaining_time := millisecond_timer;
    IFEND;

  PROCEND find_shortest_timer;
?? TITLE := 'get_system_init_values', EJECT ??

  PROCEDURE get_system_init_values
    (    system_id: nat$system_identifier;
         reset_code: 0 .. nac$max_di_reset_code;
     VAR object_code_version: nat$object_code_version;
     VAR dump_required: boolean;
     VAR transmit_rate: nat$transmit_rate);

    VAR
      index: integer;

    object_code_version := default_object_code_version;
    dump_required := reset_code IN dump_error_list;
    transmit_rate := nac$high_transmit_rate;

    IF system_exceptions <> NIL THEN
      FOR index := 1 TO UPPERBOUND (system_exceptions^) DO
        IF system_exceptions^ [index].system_id = system_id THEN
          IF system_exceptions^ [index].version_specified THEN
            object_code_version := system_exceptions^ [index].object_code_version;
          IFEND;
          dump_required := reset_code IN system_exceptions^ [index].dump_error_list;
          transmit_rate := system_exceptions^ [index].transmit_rate;
          RETURN;
        IFEND;
      FOREND;
    IFEND;
  PROCEND get_system_init_values;
?? TITLE := 'report_cp_time', EJECT ??
?? NOCOMPILE ??

  PROCEDURE report_cp_time;

    VAR
      local_status: ost$status,
      new_time: pmt$task_cp_time,
      report_line: string (40),
      length: integer;

    pmp$get_task_cp_time (new_time, local_status);

    STRINGREP (report_line, length, 'Job time=', new_time.task_time - cp_time.task_time, ', Monitor time=',
          new_time.monitor_time - cp_time.monitor_time);

    pmp$log (report_line (1, length), local_status);

    cp_time := new_time;

  PROCEND report_cp_time;
?? COMPILE ??
?? TITLE := 'send_pdu', EJECT ??

  PROCEDURE send_pdu
    (    output_data: nat$data_fragments;
         device_id: nlt$device_identifier;
         system_address: nat$system_address);

    VAR
      checksum: nat$checksum_value,
      index: integer,
      output_pdu: ^nat$data_fragments,
      status: ost$status;

    PUSH output_pdu: [1 .. UPPERBOUND (output_data) + 1];
    FOR index := 1 TO UPPERBOUND (output_data) DO
      output_pdu^ [index] := output_data [index];
    FOREND;
    output_pdu^ [UPPERBOUND (output_pdu^)].address := ^checksum;
    output_pdu^ [UPPERBOUND (output_pdu^)].length := #SIZE (checksum);
    checksum := nap$xns_checksum (output_data);

    status.normal := TRUE;
    nap$cn_send_datagram (nac$cn_initialization_me_sap, device_id, system_address,
          output_pdu^, status);
    IF NOT status.normal THEN

{ *** a distinction must be made between fatal errors (pmp$abort) and nonfatal ones
{     pmp$log ('error sending datagram', status);

      nap$display_message (status);
    IFEND;
  PROCEND send_pdu;
?? TITLE := 'set_timer', EJECT ??

  PROCEDURE set_timer
    (VAR dependent_system: nit$dependent_system;
         timer_value {in milliseconds} : nit$timer_value;
         more_retries: boolean);

    VAR
      current_microsecond_time: integer,
      ignore_status: ost$status;

    pmp$get_microsecond_clock (current_microsecond_time, ignore_status);
    dependent_system.timer := (current_microsecond_time DIV 1000) + timer_value;
    dependent_system.more_retries := more_retries;
  PROCEND set_timer;
?? TITLE := 'system_excluded', EJECT ??

  FUNCTION system_excluded
    (    system_id: nat$system_identifier): boolean;

    VAR
      index: integer;

    IF system_exceptions = NIL THEN
      system_excluded := FALSE;
    ELSE
      FOR index := 1 TO UPPERBOUND (system_exceptions^) DO
        IF system_exceptions^ [index].system_id = system_id THEN
          system_excluded := NOT system_exceptions^ [index].service_system;
          RETURN;
        IFEND;
      FOREND;
      system_excluded := FALSE;
    IFEND;
  FUNCEND system_excluded;
?? TITLE := 'truncate (dump/load)', EJECT ??

  PROCEDURE truncate_dump
    (VAR dependent_system: nit$dependent_system);

{   VAR
{     status: ost$status;

    close_dump_file (dependent_system);

{   pmp$log ('dump terminated by help request', status);

  PROCEND truncate_dump;


  PROCEDURE truncate_load
    (VAR dependent_system: nit$dependent_system);

    VAR
      status: ost$status;

    close_load_file (dependent_system);

{   pmp$log ('load terminated by help request', status);

  PROCEND truncate_load;

MODEND nam$independent_init_manager;
*DECK DECK=NAM$INITIALIZE_NETWORKS_R1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access : Network Initialization' ??
?? NEWTITLE := 'Global Declarations Referenced by This Module' ??
MODULE nam$initialize_networks_r1;

{
{     PURPOSE:
{       The purpose of this module is to declare and initialize network PPU interface variables
{       in the mainframe wired segment.  This includes buffers for incoming data.
{       Procedures to return structures to a null state accompany the initialization procedures.
{
{       The module also contains procedures to record task identifies of NAM/VE well known tasks
{       in mainframe wired.
{
{     DESIGN:
{       This module must reside in the OSF$SYSTEM_CORE_113 library.  The procedure, nap$initialize_r1,
{       must only execute in the network initialize task.  The procedure nap$initialize_r1 is to be
{       called only during network initialization.  The task identifier recording procedures are
{       called each time a NAM/VE task begins execution.
{
{       NOTE: Smaller PP buffer pools are created when NOS/VE memory is below a defined threshold
{             (currently 16MB).
{
?? PUSH (LISTEXT := ON) ??
*copyc nat$network_address
*copyc nlc$bm_small_buffer_size
*copyc nlt$pp_buffer
*copyc nlt$pp_send_queue_tails
*copyc nlc$small_machine_threshold
*copyc ost$signature_lock
?? POP ??
*copyc i#real_memory_address
*copyc pmp$get_executing_task_gtid
*copyc pmp$zero_out_table

*copyc nav$network_wired_heap
*copyc nav$si_received_message_list
*copyc nav$completed_output_requests
*copyc nav$connection_establish_taskid
*copyc nav$completed_output_taskid
*copyc nav$directory_me_taskid
*copyc nav$system_input_taskid
*copyc nav$system_id
*copyc nlv$bm_large_buffer_size
*copyc nlv$configured_network_devices
*copyc osv$180_memory_limits
*copyc osv$mainframe_wired_cb_heap

  TYPE

{ Align the buffer pools pp_max_small_buffers * #SIZE(nlt$pp_buffer_pool_entry).
{ The alignment prevents the pool from crossing a page boundry.

    aligned_small_pp_pool_type = record
      pool: ALIGNED [0 MOD 1024] nlt$pp_buffer_pool,
    recend,

{ Align the buffer pools pp_max_large_buffers * #SIZE(nlt$pp_buffer_pool_entry).
{ The alignment prevents the pool from crossing a page boundry.

    aligned_large_pp_pool_type = record
      pool: ALIGNED [0 MOD 1024] nlt$pp_buffer_pool,
    recend;

  VAR
    aligned_small_pp_pool: [STATIC] ^aligned_small_pp_pool_type := NIL,
    aligned_large_pp_pool: [STATIC] ^aligned_large_pp_pool_type := NIL,

    nlv$pp_buffer: [XDCL, #GATE] ^nlt$pp_buffer := NIL,
    nlv$pp_send_queue_tails: [XDCL, #GATE] ^nlt$pp_send_queue_tails := NIL;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$free_pp_send_queue_tails', EJECT ??
*copy nah$free_pp_send_queue_tails
  PROCEDURE [XDCL, #GATE] nap$free_pp_send_queue_tails;

    FREE nlv$pp_send_queue_tails IN osv$mainframe_wired_cb_heap^;

  PROCEND nap$free_pp_send_queue_tails;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$init_pp_send_queue_tails', EJECT ??
*copy nah$init_pp_send_queue_tails
  PROCEDURE [XDCL, #GATE] nap$init_pp_send_queue_tails;

    VAR
      i: integer,
      network_device_count: nlt$device_count,
      queue: nlt$cc_connection_class;

    network_device_count := nlv$configured_network_devices.network_device_count;
    ALLOCATE nlv$pp_send_queue_tails: [1 .. network_device_count] IN osv$mainframe_wired_cb_heap^;

    FOR i := 1 TO network_device_count DO
      FOR queue := nlc$cc_normal_class TO nlc$cc_priority_class DO
        nlv$pp_send_queue_tails^ [i] [queue].send_queue_tail := NIL;
      FOREND;
    FOREND;

  PROCEND nap$init_pp_send_queue_tails;

?? TITLE := '  [XDCL, #GATE] nap$initialize_pp_buffer_descr', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$initialize_pp_buffer_descr;
*copy nah$initialize_pp_buffer_descr

  VAR
    pp_max_small_buffers: 0 .. 511,
    pp_small_buffer_threshold: 0 .. 511,
    pp_max_large_buffers: 0 .. 511,
    pp_large_buffer_threshold: 0 .. 511,
    rma: integer;

    ALLOCATE nlv$pp_buffer IN osv$mainframe_wired_cb_heap^;
    pmp$zero_out_table (#LOC (nlv$pp_buffer^), #SIZE (nlv$pp_buffer^));

    IF (osv$180_memory_limits.upper - osv$180_memory_limits.lower) < nlc$small_machine_threshold THEN
      pp_max_small_buffers := 50;
      pp_small_buffer_threshold := 25;
      pp_max_large_buffers := 30;
      pp_large_buffer_threshold := 20;
    ELSE
      pp_max_small_buffers := 256;
      pp_small_buffer_threshold := 120;
      pp_max_large_buffers := 200;
      pp_large_buffer_threshold := 120;
    IFEND;

    nlv$pp_buffer^.pool_header [nlc$bm_small_buffer_index].buffer_length := nlc$bm_small_buffer_size;
    nlv$pp_buffer^.pool_header [nlc$bm_small_buffer_index].inn := 0;
    nlv$pp_buffer^.pool_header [nlc$bm_small_buffer_index].cpu_out := 0;
    nlv$pp_buffer^.pool_header [nlc$bm_small_buffer_index].pp_out := 0;
    nlv$pp_buffer^.pool_header [nlc$bm_small_buffer_index].threshold := pp_small_buffer_threshold;
    nlv$pp_buffer^.pool_header [nlc$bm_small_buffer_index].limit :=
          ((pp_max_small_buffers + 1) * #SIZE (nlt$pp_buffer_pool_entry));

    nlv$pp_buffer^.pool_header [nlc$bm_large_buffer_index].buffer_length := nlv$bm_large_buffer_size;
    nlv$pp_buffer^.pool_header [nlc$bm_large_buffer_index].inn := 0;
    nlv$pp_buffer^.pool_header [nlc$bm_large_buffer_index].cpu_out := 0;
    nlv$pp_buffer^.pool_header [nlc$bm_large_buffer_index].pp_out := 0;
    nlv$pp_buffer^.pool_header [nlc$bm_large_buffer_index].threshold := pp_large_buffer_threshold;
    nlv$pp_buffer^.pool_header [nlc$bm_large_buffer_index].limit :=
          ((pp_max_large_buffers + 1) * #SIZE (nlt$pp_buffer_pool_entry));

    ALLOCATE aligned_small_pp_pool: [0 .. pp_max_small_buffers] IN osv$mainframe_wired_cb_heap^;
    nlv$pp_buffer^.pool [nlc$bm_small_buffer_index] := ^aligned_small_pp_pool^.pool;
    pmp$zero_out_table (#LOC (nlv$pp_buffer^.pool [nlc$bm_small_buffer_index]^),
          ((pp_max_small_buffers + 1) * #SIZE (nlt$pp_buffer_pool_entry)));
    i#real_memory_address (nlv$pp_buffer^.pool [nlc$bm_small_buffer_index], rma);
    nlv$pp_buffer^.pool_header [nlc$bm_small_buffer_index].pp_buffer_pool := rma;

    ALLOCATE aligned_large_pp_pool: [0 .. pp_max_large_buffers] IN osv$mainframe_wired_cb_heap^;
    nlv$pp_buffer^.pool [nlc$bm_large_buffer_index] := ^aligned_large_pp_pool^.pool;
    pmp$zero_out_table (#LOC (nlv$pp_buffer^.pool [nlc$bm_large_buffer_index]^),
          ((pp_max_large_buffers + 1) * #SIZE (nlt$pp_buffer_pool_entry)));
    i#real_memory_address (nlv$pp_buffer^.pool[nlc$bm_large_buffer_index], rma);
    nlv$pp_buffer^.pool_header [nlc$bm_large_buffer_index].pp_buffer_pool := rma;

  PROCEND nap$initialize_pp_buffer_descr;
?? TITLE := '[XDCL, #GATE] nap$free_pp_buffer_descriptor', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$free_pp_buffer_descriptor;
*copy nah$free_pp_buffer_descriptor

    FREE nlv$pp_buffer^.pool [nlc$bm_small_buffer_index] IN osv$mainframe_wired_cb_heap^;
    FREE nlv$pp_buffer^.pool [nlc$bm_large_buffer_index] IN osv$mainframe_wired_cb_heap^;
    FREE nlv$pp_buffer IN osv$mainframe_wired_cb_heap^;

  PROCEND nap$free_pp_buffer_descriptor;

?? TITLE := '  [XDCL, #GATE] nap$free_pp_buffer_pools', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$free_pp_buffer_pools;
*copy nah$free_pp_buffer_pools

    {
    { NOTE: message buffers in the the PP buffer pools are not actually freed, but the pools are rendered
    {       empty by this procedure.  The process relies on resetting the network wired heap to free
    {       any containers which may exist in the pools.
    {

    nlv$pp_buffer^.pool_header [nlc$bm_small_buffer_index].inn :=
          nlv$pp_buffer^.pool_header [nlc$bm_small_buffer_index].cpu_out;
    nlv$pp_buffer^.pool_header [nlc$bm_large_buffer_index].inn :=
          nlv$pp_buffer^.pool_header [nlc$bm_large_buffer_index].cpu_out;
  PROCEND nap$free_pp_buffer_pools;
?? TITLE := '  [XDCL, #GATE] nap$reset_network_responses', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$reset_network_responses;
*copy nah$reset_network_responses

    nav$si_received_message_list.next_received_message := NIL;
    nav$si_received_message_list.fill := 0;
    nav$completed_output_requests.request_block_link := NIL;
    nav$completed_output_requests.requests_queued := 0;
  PROCEND nap$reset_network_responses;
?? NEWTITLE := '  [XDCL, #GATE] nap$record_connection_establish' ??
?? NEWTITLE := '  [XDCL, #GATE] nap$record_directory_me' ??
?? NEWTITLE := '  [XDCL, #GATE] nap$record_completed_output' ??
?? NEWTITLE := '  [XDCL, #GATE] nap$record_system_id' ??
?? NEWTITLE := '  [XDCL, #GATE] nap$record_system_input', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$record_connection_establish;

    pmp$get_executing_task_gtid (nav$connection_establish_taskid);
  PROCEND nap$record_connection_establish;

  PROCEDURE [XDCL, #GATE] nap$record_completed_output;

    pmp$get_executing_task_gtid (nav$completed_output_taskid);

  PROCEND nap$record_completed_output;

  PROCEDURE [XDCL, #GATE] nap$record_directory_me;

    pmp$get_executing_task_gtid (nav$directory_me_taskid);
  PROCEND nap$record_directory_me;

  PROCEDURE [XDCL, #GATE] nap$record_system_id (system_id: nat$system_identifier);

    nav$system_id := system_id;
  PROCEND nap$record_system_id;

  PROCEDURE [XDCL, #GATE] nap$record_system_input;

    pmp$get_executing_task_gtid (nav$system_input_taskid);
  PROCEND nap$record_system_input;
?? OLDTITLE, OLDTITLE, OLDTITLE, OLDTITLE, OLDTITLE ??
MODEND nam$initialize_networks_r1;
*DECK DECK=NAM$INITIALIZE_NETWORKS_R3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Network Access : Network Initialization Task' ??
MODULE nam$initialize_networks_r3;

{
{     PURPOSE:
{       The purpose of this module is to perform network initialization.
{
{     DESIGN:
{       This module is designed to be contained in the OSF$JOB_TEMPLATE_23D library and execute only
{       within the system job.  The module causes the initialization of a limited set of NAM/VE tables.
{
{       The primary goal of this module is to initialize NAM/VE.  Most all processes in the initialization
{       phase must succeed for NAM/VE to be viable.  That is, a failure in a specific process is either
{       is catastrophic at instance of occurance or implies that a subsequent process will fail. There
{       are processes that may not be totally successful, but allow NAM/VE to execute in a degraded mode.
{       Assuming a catastrophic or implied failure, the results of predecessor processes are undone.
{       This permits the initialization process to be restarted.
{
{           NOTE: Generally, a catastrophic or implied failure is the result of some software defect
{                 occuring as the result of modification of the process.
{
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cme$reserve_element
*copyc cml$ica_failure_data
*copyc cml$ica_usage_data
*copyc cml$ivb_failure_data
*copyc cml$ivb_usage_data
*copyc cml$mdi_failure_data
*copyc cml$mdi_usage_data
*copyc cmt$element_state
*copyc dse$resource_errors
*copyc nac$reserved_saps
*copyc nae$initialization_interfaces
*copyc nae$namve_conditions
*copyc nat$nam_attributes
*copyc nat$network_message_priority
*copyc nlt$device_count
*copyc nlt$network_device
*copyc nlt$network_device_list
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc ost$status
*copyc pmt$program_parameters
?? POP ??
*copyc cmp$pc_get_element
*copyc cmp$process_state_change
*copyc nap$activate_network_config
*copyc nap$build_master_control_table
*copyc nap$change_network_device_state
*copyc nap$close_network_sap
*copyc nap$display_message
*copyc nap$free_pp_buffer_descriptor
*copyc nap$free_pp_buffer_pools
*copyc nap$free_pp_send_queue_tails
*copyc nap$get_nam_attributes_r1
*copyc nap$idle_network_applications
*copyc nap$initialize_application_defn
*copyc nap$init_pp_send_queue_tails
*copyc nap$initialize_pp_buffer_descr
*copyc nap$initialize_network_pp
*copyc nap$initialize_request_blocks
*copyc nap$idle_pp
*copyc nap$open_network_sap
*copyc nap$reserve_network_elements
*copyc nap$replenish_pp_buffer_pools
*copyc nap$return_network_elements
*copyc nap$reset_network_responses
*copyc nap$gt_initialize
*copyc nlp$cc_terminate_connections
*copyc nlp$na_initialize
*copyc nlp$se_initialize
*copyc nlp$sk_tcp_initialize
*copyc nlp$tm_initialize
*copyc nlp$sm_initialize
*copyc nlp$bm_free_buffer_pools
*copyc nlp$bm_initialize_buffer_pools
*copyc nlp$get_exclusive_access
*copyc nlp$la_initialize
*copyc nlp$release_exclusive_access
*copyc nlp$udp_initialize
*copyc osp$append_status_parameter
*copyc osp$free_heap_pages
*copyc osp$reset_heap
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$ready_task
*copyc sfp$activate_system_statistic
*copyc jmv$executing_within_system_job
*copyc nav$completed_output_taskid
*copyc nav$global_osi_statistics
*copyc nav$global_statistics
*copyc nav$intranet_mgmt_work_list
*copyc nav$namve_active
*copyc nav$network_paged_heap
*copyc nav$network_wired_heap
*copyc nav$statistics_enabled
*copyc nlv$configured_network_devices
*copyc nlv$device_usage_data
*copyc nlv$timer_monitor_task
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

    TYPE
      device_type = SET OF nat$device_type,

      initialization_phase = (uninitialized, activate_network_configuration,
            initialize_access_agents, initialize_buffer_pools,
            initialize_pp_buffer_descriptor, initialize_request_blocks, initialize_response_list,
            initialize_device_usage_data, initialize_pp_send_queue_tails,
            replenish_pp_buffer_pools, reserve_network_elements, activate_statistics,
            open_directory_sap, install_applications, initialized),

      initialization_phases = SET OF initialization_phase;

    VAR
      nav$initialization_complete: [XDCL, oss$task_shared] initialization_phases :=
            $initialization_phases [];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$terminate_namve', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$terminate_namve (ignore_parameters: pmt$program_parameters;
    VAR status: ost$status);

{ PURPOSE:
{   The purpose of this procedure is to shut down NAM/VE and release the associated
{   allocated data structures.
{ METHOD:
{   This procedure is to be called when NAM/VE has been idled by nap$idle_namve.  The remaining
{   steps of NAM/VE initialization are undone.

    VAR
      current_connections: nat$nam_attribute;

    IF NOT jmv$executing_within_system_job THEN
      osp$set_status_abnormal ('NA', nae$insufficient_privilege, 'nap$terminate_namve', status);
      RETURN;
    IFEND;

    status.normal := TRUE;

    return_namve_to_null_state;
    nav$namve_active := FALSE;

  PROCEND nap$terminate_namve;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$idle_namve', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$idle_namve (ignore_parameters: pmt$program_parameters;
    VAR status: ost$status);

{ PURPOSE:
{   The purpose of this procedure is to shut down NAM/VE applications and devices, and return all associated
{   system resources.
{ METHOD:
{   This procedure is intended to be called repeatedly by the SCL procedure, DEACTIVATE_NETWORK, until all
{   NAM/VE activity has stopped.  This is necessary since this procedure executes in ring 3 and, therefore,
{   is not interruptable.  Since a successful idling of NAM/VE requires that all jobs with network connections
{   acknowledge the disconnect signal, it is quite possible for this process to loop endlessly.  The operator
{   is allowed to terminate the idling process at any time.  The current state of the idling process is
{   maintained so that it can be resumed after an interrupt.  NAM/VE can also be reactivated after an idle
{   request is interrupted.
{
{   First, all network applications are terminated and their definitions deleted by application management.
{   Next, all network devices are idled and the system resources (PPs, channels, etc.) are returned.  This
{   has the side effect of terminating any remaining management connections.  The completed_output task is
{   invoked to clean up the PP interface structures, and the timer_monitor task is invoked to return any
{   remaining terminated connections.
{
{   When the current connection count reaches zero, normal status is returned to indicate that the idling
{   process is complete.
{
{ NOTE:
{   This procedure can be invoked only in the system job.

    VAR
      current_connections: nat$nam_attribute,
      i: integer,
      ignore_status: ost$status,
      network_device_list: ^nlt$network_device_list,
      terminate_inactive_connections: boolean;

    IF NOT jmv$executing_within_system_job THEN
      osp$set_status_abnormal ('NA', nae$insufficient_privilege, 'nap$idle_namve', status);
      RETURN;
    IFEND;

    status.normal := TRUE;

    terminate_inactive_connections := install_applications IN nav$initialization_complete;
    nap$idle_network_applications (terminate_inactive_connections, status);
    nav$initialization_complete := nav$initialization_complete - $initialization_phases
          [install_applications];
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    network_device_list := nlv$configured_network_devices.network_device_list;
    IF network_device_list <> NIL THEN
      FOR i := LOWERBOUND (network_device_list^) TO UPPERBOUND (network_device_list^) DO
        { Return the element if the network elements have been reserved for NAM/VE. }
        IF (network_device_list^[i].path_status <> nlc$path_down) THEN
          nap$change_network_device_state (network_device_list^[i].element, {new_state =} cmc$down,
            {old_state = } cmc$on, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;

    nav$initialization_complete := nav$initialization_complete - $initialization_phases
          [reserve_network_elements];

    pmp$ready_task (nav$completed_output_taskid, ignore_status);
    pmp$ready_task (nlv$timer_monitor_task, ignore_status);

    nap$get_nam_attributes_r1 (nac$current_connections_status, current_connections);
    IF current_connections.current_connections > 0 THEN
      osp$set_status_condition (nae$connections_still_active, status);
      RETURN;
    IFEND;

  PROCEND nap$idle_namve;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$initialize_networks', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$initialize_networks (ignore_parameters: pmt$program_parameters;
    VAR status: ost$status);

{     NOTE: the directory Service Access Point MUST be opened before applications are installed. }
{           Otherwise, 'nap$initialize_applications_defn' may not be able to accurately perform  }
{           its function.                                                                        }

    VAR
      required_successful: [STATIC, READ, oss$job_paged_literal] initialization_phases :=
        $initialization_phases [activate_network_configuration,
        initialize_access_agents, initialize_buffer_pools,
        initialize_pp_buffer_descriptor, initialize_request_blocks, initialize_response_list,
        initialize_device_usage_data, initialize_pp_send_queue_tails,
        replenish_pp_buffer_pools, reserve_network_elements,
        open_directory_sap, install_applications],

      failed: [STATIC, READ, oss$job_paged_literal] array [activate_network_configuration ..
            install_applications] of string (31) := [
        'activate network configuration', 'initialize access agents',
        'initialize buffer pools', 'initialize pp buffer descriptor',
        'initialize request blocks', 'initialize response list', 'initialize_device_usage_data',
        'initialize_pp_send_queue_tails', 'replenish pp buffer pools',
        'reserve network elements', 'activate statistics',
        'open directory sap', 'install applications'];


?? NEWTITLE := 'activate_network_pp', EJECT ??

    PROCEDURE activate_network_pp (network_device: ^nlt$network_device);

      { Initialize the network PPs (i.e., communicate all the required addresses to the PPs). }

      { Initialize the PP if the network elements have been reserved for NAM/VE. }
      IF network_device^.logical_unit <> 0 THEN
        nap$build_master_control_table (network_device^.logical_unit, network_device^.
          device_id);
        nap$initialize_network_pp (network_device);
      IFEND;
    PROCEND activate_network_pp;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_device_specific_stat', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to allocate space for the OSI device specific
{   statistics and initialize the statistic values to zero.
{

  PROCEDURE initialize_device_specific_stat;

    VAR
      i: nlt$device_count,
      network_device_list: ^nlt$network_device_list,
      networks_count: nlt$device_count;

    networks_count := 0;
    network_device_list := nlv$configured_network_devices.network_device_list;
    IF network_device_list <> NIL THEN
      networks_count := UPPERBOUND (network_device_list^);
      REPEAT
        ALLOCATE nav$global_osi_statistics.channel_connection_device: [1 .. networks_count]
              IN nav$network_paged_heap^;
        IF nav$global_osi_statistics.channel_connection_device = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL nav$global_osi_statistics.channel_connection_device <> NIL;
    IFEND;

{ Initialize the statistic values.

    FOR i := 1 TO networks_count DO
      nav$global_osi_statistics.channel_connection_device^ [i].credit_pdus_received := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].credit_pdus_sent := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].current_normal_connections := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].current_priority_connections := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].device_resets := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].duplicate_connect_indications := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].normal_send_pdus_queued := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].pdus_processed_out_of_order := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].priority_receive.value := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].priority_receive_expedited_pdus := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].priority_receive_pdus_discarded := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].priority_send.value := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].priority_send_expedited_pdus := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].priority_send_pdus_discarded := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].priority_send_pdus_queued := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].receive.value := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].receive_pdus_discarded := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].received_expedited_pdus := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].send.value := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].send_expedited_pdus := 0;
      nav$global_osi_statistics.channel_connection_device^ [i].send_pdus_discarded := 0;
    FOREND;
  PROCEND initialize_device_specific_stat;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_intranet_stats', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to allocate space for the intranet statistics
{   and initialize the statistic values to zero.
{

  PROCEDURE initialize_intranet_stats;

    VAR
      i: nlt$device_count,
      network_device_list: ^nlt$network_device_list,
      networks_count: nlt$device_count;

    networks_count := 0;
    network_device_list := nlv$configured_network_devices.network_device_list;
    IF network_device_list <> NIL THEN
      networks_count := UPPERBOUND (network_device_list^);
      IF nav$global_statistics.intranet = NIL THEN

{ Allocate space for the intranet statistic data structure.

        REPEAT
          ALLOCATE nav$global_statistics.intranet: [1 .. networks_count] IN nav$network_paged_heap^;
          IF nav$global_statistics.intranet = NIL THEN
            syp$cycle;
          IFEND;
        UNTIL nav$global_statistics.intranet <> NIL;
      IFEND;

{ Initialize the statistic values.

      FOR i := 1 TO networks_count DO
        nav$global_statistics.intranet^ [i].current_send_pdus_queued := 0;
        nav$global_statistics.intranet^ [i].logical_unit_number := network_device_list^[i].
          logical_unit;
        nav$global_statistics.intranet^ [i].multicasts_received := 0;
        nav$global_statistics.intranet^ [i].multicasts_sent := 0;
        nav$global_statistics.intranet^ [i].receive.value := 0;
        nav$global_statistics.intranet^ [i].receive_pdus_discarded := 0;
        nav$global_statistics.intranet^ [i].send.value := 0;
        nav$global_statistics.intranet^ [i].send_pdus_discarded := 0;
      FOREND;
    IFEND;
  PROCEND initialize_intranet_stats;
?? OLDTITLE ??
?? NEWTITLE := 'off_network_element', EJECT ??

    PROCEDURE [INLINE] off_network_element (network_device: ^nlt$network_device;
      VAR status: ost$status);

      VAR
        element_definition: ^cmt$element_definition,
        element_descriptor: cmt$element_descriptor,
        ignore_status: ost$status,
        iou_name: cmt$element_name;

      status.normal := TRUE;
      cmp$pc_get_element (network_device^.element, {not used} iou_name, element_definition, ignore_status);
      element_descriptor.element_type := element_definition^.element_type;
      element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
      element_descriptor.peripheral_descriptor.element_name := network_device^.element;
      cmp$process_state_change ({tape_element=} FALSE, {clear_lock_behind=} TRUE,
           TRUE, element_descriptor, {System critical element} FALSE,
           cmc$on, cmc$off, status);

    PROCEND off_network_element;
?? OLDTITLE, EJECT ??

    VAR
      configured_devices: SET OF nat$device_type,
      phase: initialization_phase,
      i: integer,
      iou_name: cmt$element_name,
      network_device: ^nlt$network_device,
      network_device_list: ^nlt$network_device_list,
      element_state: cmt$element_state,
      current_limit: integer,
      warning: ost$status;

{
{ NOTE: The section "NAM/VE Activation Error Troubleshooting" in the Software Release Bulletin (SRB)
{       describes site recovery from abnormalities in the initialization phases
{            activate_network_configuration,
{            reserve_network_elements, and
{            install_applications.
{       If the logic in these phases changes such that diagnostics or recovery techniques change,
{       the SRB must be updated.  Currently abnormalities detected in other phases are software defects
{       and are not documented in the SRB.
{

    status.normal := TRUE;
    warning.normal := TRUE;
    IF jmv$executing_within_system_job THEN

      nlp$get_exclusive_access (nlv$configured_network_devices.access_control);

      phase := SUCC (uninitialized);

    /initialize_networks/
      WHILE (status.normal AND (phase < initialized)) DO
        IF NOT(phase IN nav$initialization_complete) THEN
        CASE phase OF
        = activate_network_configuration =
          nap$activate_network_config (status);
          IF NOT status.normal THEN
            nlv$configured_network_devices.network_device_list := NIL;
          IFEND;

        = initialize_access_agents =
          nap$gt_initialize;
          nlp$se_initialize;
          nlp$sm_initialize;
          nlp$na_initialize;
          nlp$la_initialize;
          nlp$sk_tcp_initialize;
          nlp$udp_initialize;
          nlp$tm_initialize;

        = initialize_buffer_pools =
          nlp$bm_initialize_buffer_pools (status);

        = initialize_pp_buffer_descriptor =
          nap$initialize_pp_buffer_descr; { NOTE: due to the implementation of the mainframe wired heap,
{                                                 if the heap is full a ring 1 error system will occur and
{                                                 prevent returning of NAM/VE to a null state.

        = initialize_request_blocks =
          nap$initialize_request_blocks;
{
{

        = initialize_response_list =
          nap$initialize_response_list (status);

        = initialize_device_usage_data =
          init_device_usage_data (status);

        = initialize_pp_send_queue_tails =
          nap$init_pp_send_queue_tails;      { NOTE: due to the implementation of the mainframe wired heap,
{                                                    if the heap is full a ring 1 system error will occur and
{                                                    prevent returning of NAM/VE to a null state.

        = replenish_pp_buffer_pools =
          nap$replenish_pp_buffer_pools;

        = reserve_network_elements =

          { Reserve network elements for each configured network, provided the elements are ON. }
          network_device_list := nlv$configured_network_devices.network_device_list;
          configured_devices := $device_type [];

        /reserve_network_element/
          FOR i := LOWERBOUND (network_device_list^) TO UPPERBOUND (network_device_list^) DO
            network_device := ^network_device_list^[i];
            configured_devices := configured_devices + $device_type [network_device^.kind];

            nap$reserve_network_elements (network_device^.element, network_device^.
                  channel, network_device^. channel_address, network_device^.
                  driver_name, network_device^.logical_unit, network_device^.
                  pp_identification, network_device^.pp_number, status);
            IF (NOT status.normal AND ((status.condition = cme$element_state_not_proper) OR
                   (status.condition = dse$resource_not_available) OR
                   (status.condition = dse$pp_not_available_to_ve))) THEN
              IF (status.condition = dse$resource_not_available) OR
                      (status.condition = dse$pp_not_available_to_ve) THEN
                nap$display_message (status);
                off_network_element (network_device, status);
                IF NOT status.normal THEN
                  EXIT /reserve_network_element/;
                IFEND;
                osp$set_status_condition (nae$initialization_warning, warning);
              ELSE
                status.normal := TRUE;
              IFEND;
              network_device^.path_status := nlc$path_down;
            IFEND;

            IF status.normal THEN
              activate_network_pp (network_device);
            ELSE

            /software_defect/
              BEGIN
                { In case of unexpected error in reserving elements for any network, return all previously
                { reserved elements and free the network device list.  An unexpected error implies a breakage
                { among 'activate network configuration', 'reserve networks elements', and 'configuration
                { management'.
                EXIT /reserve_network_element/;
              END /software_defect/;
            IFEND;
          FOREND /reserve_network_element/;

        = activate_statistics =
          IF nav$statistics_enabled THEN

{ Initialize the intranet periodic statistics.

            IF nav$global_statistics.intranet = NIL THEN
              initialize_intranet_stats;
            IFEND;

{ Initialize the osi device specific periodic statistics.

            IF nav$global_osi_statistics.channel_connection_device = NIL THEN
              initialize_device_specific_stat;
            IFEND;
          IFEND;

{         NOTE: at Release 1.3.1 required statistics will be activated outside the NAM/VE initialization   }
{               process.  At that time the 'activate statistics' phase MUST be removed.                    }

          IF nac$di IN configured_devices THEN
{ Activate statistics code for MCI logging.

            sfp$activate_system_statistic (cml$mdi_failure_data, $sft$binary_logset [pmc$engineering_log],
                  status);
            IF NOT status.normal THEN
              nap$display_message (status);
            IFEND;

            sfp$activate_system_statistic (cml$mdi_usage_data, $sft$binary_logset [pmc$engineering_log],
                  status);
            IF NOT status.normal THEN
              nap$display_message (status);
            IFEND;
          IFEND;

          IF nac$ica_2 IN configured_devices THEN

{ Activate statistics code for ICA logging.

            sfp$activate_system_statistic (cml$ica_failure_data, $sft$binary_logset [pmc$engineering_log],
                  status);
            IF NOT status.normal THEN
              nap$display_message (status);
            IFEND;

            sfp$activate_system_statistic (cml$ica_usage_data, $sft$binary_logset [pmc$engineering_log],
                  status);
            IF NOT status.normal THEN
              nap$display_message (status);
            IFEND;
          IFEND;

          IF nac$expresslink IN configured_devices THEN

{ Activate statistics code for IVB logging.

            sfp$activate_system_statistic (cml$ivb_failure_data, $sft$binary_logset [pmc$engineering_log],
                  status);
            IF NOT status.normal THEN
              nap$display_message (status);
            IFEND;

            sfp$activate_system_statistic (cml$ivb_usage_data, $sft$binary_logset [pmc$engineering_log],
                  status);
            IF NOT status.normal THEN
              nap$display_message (status);
            IFEND;
          IFEND;

          status.normal := TRUE;

        = open_directory_sap =
          nav$namve_active := TRUE;
          nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
          nap$open_network_sap (nac$system_message_priority, nac$xi_cdna_directory_sap, status);
          nlp$get_exclusive_access (nlv$configured_network_devices.access_control);


        = install_applications =
          nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
          nap$initialize_application_defn (status);
          nlp$get_exclusive_access (nlv$configured_network_devices.access_control);

        CASEND;
        IFEND;

        IF status.normal THEN
          nav$initialization_complete := nav$initialization_complete + $initialization_phases [phase];
          phase := SUCC (phase);
        ELSEIF NOT (phase IN required_successful) THEN
          IF (status.condition <> nae$initialization_error) THEN
            osp$set_status_abnormal (nac$status_id, nae$initialization_error, failed [phase], status);
          ELSE
            osp$append_status_parameter (osc$status_parameter_delimiter, failed [phase], status);
          IFEND;
          nap$display_message (status);
          osp$set_status_condition (nae$initialization_warning, warning);
          phase := SUCC (phase);
          status.normal := TRUE;
        ELSE
          IF (status.condition <> nae$initialization_fatal) THEN
            nap$display_message (status);
            CASE phase OF
            = activate_network_configuration =
              osp$set_status_condition (nae$activate_network_config, status);
            = install_applications =
              osp$set_status_condition (nae$install_applications, status);
            ELSE
              osp$set_status_abnormal (nac$status_id, nae$initialization_fatal, failed [phase], status);
            CASEND;
          ELSE
            osp$append_status_parameter (osc$status_parameter_delimiter, failed [phase], status);
          IFEND;
          return_namve_to_null_state;
        IFEND;
      WHILEND /initialize_networks/;
      nav$namve_active := status.normal;
      nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
      IF status.normal THEN
        status := warning;
      IFEND;
    IFEND;
  PROCEND nap$initialize_networks;
?? OLDTITLE ??
?? NEWTITLE := 'nap$initialize_response_list', EJECT ??

  PROCEDURE nap$initialize_response_list (VAR status: ost$status);

{     The purpose of this procedure is to initialize the free queue in the intranet
{  management work list. A maximum of 25 response buffers are setup in the free
{  queue. The responses are communicated from the monitor mode process to the
{  intranet layer management task via these response buffers.

    CONST
      max_responses = 25;

    VAR
      i: integer,
      response_buffer: ^^nat$network_driver_response;

    status.normal := TRUE;
    response_buffer := ^nav$intranet_mgmt_work_list.free_responses.next_entry;
    FOR i := 1 to max_responses DO
      ALLOCATE response_buffer^ IN nav$network_wired_heap^;
      response_buffer := ^response_buffer^^.next_entry;
    FOREND;
    response_buffer^ := NIL;
    IF (i < (max_responses DIV 2)) THEN
      nap$free_response_list;
      osp$set_status_condition (nae$initialization_fatal, status);
    IFEND;
  PROCEND nap$initialize_response_list;
?? OLDTITLE ??
?? NEWTITLE := 'nap$free_response_list', EJECT ??

  PROCEDURE nap$free_response_list;

{
{     The purpose of this procedure is to clear the intranet management work list.
{     Entries are freed as the result of resetting the network wired.
{

    nav$intranet_mgmt_work_list.free_responses.next_entry := NIL;
    nav$intranet_mgmt_work_list.outstanding_responses.next_entry := NIL;
  PROCEND nap$free_response_list;
?? OLDTITLE ??
?? NEWTITLE := 'deconfigure_networks', EJECT ??

    PROCEDURE deconfigure_networks;

      VAR
        i: integer,
        network_device_list: ^nlt$network_device_list;

      network_device_list := nlv$configured_network_devices.network_device_list;
      IF network_device_list <> NIL THEN
      nlv$configured_network_devices.network_device_list := NIL;
      FOR i := LOWERBOUND (network_device_list^) TO UPPERBOUND (network_device_list^) DO
        { Return the element if the network elements have been reserved for NAM/VE. }
        IF (network_device_list^[i].logical_unit <> 0) THEN
          nap$idle_pp (network_device_list^[i].pp_number);
          nap$return_network_elements (network_device_list^[i].element, network_device_list^[i].channel,
            network_device_list^[i].pp_identification);
        IFEND;
      FOREND;
        FREE network_device_list IN nav$network_paged_heap^;
      IFEND;

    PROCEND deconfigure_networks;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] free_device_usage_data', EJECT ??
{
{ PURPOSE:
{   The purpose of this request is to clear the device usage data list.
{   The structure is freed as the result of resetting the network wired heap.
{

  PROCEDURE [INLINE] free_device_usage_data;

    nlv$device_usage_data := NIL;
  PROCEND free_device_usage_data;
?? OLDTITLE ??
?? NEWTITLE := 'init_device_usage_data', EJECT ??
  PROCEDURE init_device_usage_data
    (VAR status: ost$status);

    VAR
      i: integer,
      network_device_count: nlt$device_count;

    status.normal := TRUE;
    network_device_count := nlv$configured_network_devices.network_device_count;
    ALLOCATE nlv$device_usage_data: [1 .. network_device_count] IN nav$network_wired_heap^;

    IF nlv$device_usage_data <> NIL THEN
      FOR i := 1 TO network_device_count DO
        nlv$device_usage_data^ [i].bytes_transmitted := 0;
        nlv$device_usage_data^ [i].bytes_received := 0;
      FOREND;
    ELSE
      osp$set_status_condition (nae$initialization_fatal, status);
    IFEND;
  PROCEND init_device_usage_data;
?? OLDTITLE ??
?? NEWTITLE := 'return_namve_to_null_state', EJECT ??

    PROCEDURE return_namve_to_null_state;

      VAR
        phase: initialization_phase,
        status: ost$status;

      phase := PRED (initialized);
      WHILE (phase > uninitialized) DO
        IF (phase IN nav$initialization_complete) THEN
          CASE phase OF
          = activate_network_configuration =
            deconfigure_networks;
            nap$reset_network_responses;

          = initialize_access_agents =
            ;

          = initialize_buffer_pools =
            nlp$bm_free_buffer_pools;

          = initialize_pp_buffer_descriptor =
            nap$free_pp_buffer_descriptor;

          = initialize_request_blocks =
            ; { Request blocks need not be deallocated. }

          = initialize_response_list =
            nap$free_response_list;

          = initialize_device_usage_data =
            free_device_usage_data;

          = initialize_pp_send_queue_tails =
            nap$free_pp_send_queue_tails;

          = replenish_pp_buffer_pools =
            nap$free_pp_buffer_pools;
            { Buffer manager containers in the PP buffer pools are freed as the result of resetting the
            { network wired heap.
            ;

          = reserve_network_elements =
            deconfigure_networks;

          = activate_statistics =
{           NOTE: at Release 1.3.1 required statistics will be established outside the NAM/VE initialization }
{                 process.  In the mean time sfp$activate_system_statistics will return no errors            }
{                 when executed.  Therefore, it is unnecessary deactivate the statistics.                    }

          = open_directory_sap =
            nap$close_network_sap (nac$xi_cdna_directory_sap, status);

          = install_applications =
            ;
          CASEND;

          nav$initialization_complete := nav$initialization_complete - $initialization_phases [phase];

        IFEND;
        phase := PRED (phase);

      WHILEND;

      osp$reset_heap (nav$network_wired_heap, nac$network_heap_size, TRUE, nac$heap_algorithm);
      osp$free_heap_pages (nav$network_wired_heap);

    PROCEND return_namve_to_null_state;
?? OLDTITLE ??
MODEND nam$initialize_networks_r3;
*DECK DECK=NAM$INIT_DIRECTIVE_PROCESSOR EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
MODULE nam$init_directive_processor;
?? NEWTITLE := 'NOS/VE: Initialization M-E Directive Processors' ??
{ PURPOSE: Process Initialization Management Entity directives.
{          These directives can be used to define what system
{          versions to load and what error codes should trigger a
{          dump. Values can be specified for specific systems and
{          for a global default.
{
{ DESIGN:  A command utility is established and the directive file
{          is read by SCL. Values for the system exception list are
{          reset based on the values given on DEFINE_EXCEPTION_SYSTEM
{          commands. Default object code version and dump error list
{          are updated based on the DEFINE_BOOT_DEFAULTS command.
{
?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc nac$network_management_catalog
*copyc nae$initialization_me
*copyc nat$init_me_directives
*copyc nat$object_code_version
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*copyc amp$return
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$scan_command_file
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc osp$set_status_abnormal
*copyc pfp$attach
*copyc pmp$get_unique_name

  CONST
    system_address_prefix = 080025000000(16);

  TYPE
    linked_exception_entry = record
      link: ^linked_exception_entry,
      entry: nat$init_exception_entry,
    recend;

  VAR
    defaults_processed: boolean,
    first_system_entry: ^linked_exception_entry,
    initial_object_code_version: nat$object_code_version := LOWERVALUE (nat$object_code_version),
    initial_dump_error_list: nat$di_dump_error_list := -$nat$di_dump_error_list [nac$di_power_on_reset,
          nac$ica_channel_master_clear, nac$ica_reset_function, nac$di_reset_kils_no_dump,
          nac$di_reset_protocol_stk_chg, nac$mpb_ii_reset, nac$ac_power_low],
    dump_error_list: nat$di_dump_error_list,
    object_code_version: nat$object_code_version,
    system_count: integer;

?? EJECT ??

  PROCEDURE [XDCL] nap$process_init_directives (VAR system_exceptions: nat$init_exception_list;
    VAR default_object_code_version: nat$object_code_version;
    VAR default_dump_error_list: nat$di_dump_error_list;
    VAR status: ost$status);

{ table init_directives
{ command (define_boot_defaults,define_boot_default,defbd) p=define_boot_defaults
{ command (define_exception_system, defes) p=define_exception_system

?? PUSH (LISTEXT := ON) ??
VAR
  init_directives: [STATIC, READ] ^clt$command_table := ^init_directives_entries,

  init_directives_entries: [STATIC, READ] array [1 .. 5] of  clt$command_table_entry := [
  {} ['DEFBD                          ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^define_boot_defaults],
  {} ['DEFES                          ', clc$abbreviation_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^define_exception_system],
  {} ['DEFINE_BOOT_DEFAULT            ', clc$alias_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^define_boot_defaults],
  {} ['DEFINE_BOOT_DEFAULTS           ', clc$nominal_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^define_boot_defaults],
  {} ['DEFINE_EXCEPTION_SYSTEM        ', clc$nominal_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^define_exception_system]];

?? POP ??

    VAR
      exception_file: [STATIC] array [1 .. 5] of pft$name := [nac$management_family,
        nac$management_master_catalog, nac$cdcnet_subcatalog, nac$site_controlled_subcatalog,
        nac$exception_list ],
      exception_file_name: amt$local_file_name,
      highest_cycle: [STATIC, READ] pft$cycle_selector := [pfc$highest_cycle],
      ignore_status: ost$status,
      index: integer,
      init_me_id: [STATIC] ost$name := 'INIT_M_E',
      next_system: ^linked_exception_entry,
      password: [STATIC, READ] pft$password := ' ',
      share_selections: [STATIC, READ] pft$share_selections := [pfc$read],
      system_entry: ^linked_exception_entry,
      usage_selections: [STATIC, READ] pft$usage_selections := [pfc$read];

    defaults_processed := FALSE;
    first_system_entry := NIL;
    system_count := 0;
    object_code_version := initial_object_code_version;
    dump_error_list := initial_dump_error_list;
    status.normal := TRUE;
    pmp$get_unique_name (exception_file_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$attach (exception_file_name, exception_file, highest_cycle, password, usage_selections,
          share_selections, pfc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$push_utility (init_me_id, clc$restricted_command_search, init_directives, NIL, status);
    IF NOT status.normal THEN
      amp$return (exception_file_name, ignore_status);
      RETURN;
    IFEND;

    clp$scan_command_file (exception_file_name, init_me_id, 'IME', status);
    amp$return (exception_file_name, ignore_status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$pop_utility (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF system_exceptions <> NIL THEN
      FREE system_exceptions;
    IFEND;

    IF system_count = 0 THEN
      system_exceptions := NIL;
    ELSE
      system_entry := first_system_entry;
      ALLOCATE system_exceptions: [1 .. system_count];
      FOR index := 1 TO system_count DO
        system_exceptions^ [index] := system_entry^.entry;
        next_system := system_entry^.link;
        FREE system_entry;
        system_entry := next_system;
      FOREND;
    IFEND;

    default_object_code_version := object_code_version;
    default_dump_error_list := dump_error_list;

  PROCEND nap$process_init_directives;
?? NEWTITLE := 'define_exception_system', EJECT ??

  PROCEDURE define_exception_system (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{ PDT system_pdt (
{   system_id,si : integer 0 .. 0ffffff(16) = $REQUIRED
{   version_number,vn : integer 0 .. 0ffff(16)
{   service_system,ss : boolean = TRUE
{   delete_dump_on_error,ddoe : LIST RANGE OF integer 0 .. nac$max_di_reset_code
{   add_dump_on_error,adoe : LIST RANGE OF integer 0 .. nac$max_di_reset_code
{   transmit_rate,tr : integer 4800 .. 2000000 = 2000000
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    system_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^system_pdt_names,
  ^system_pdt_params];

  VAR
    system_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 13] of
  clt$parameter_name_descriptor := [['SYSTEM_ID', 1], ['SI', 1], ['VERSION_NUMBER', 2], ['VN', 2], [
  'SERVICE_SYSTEM', 3], ['SS', 3], ['DELETE_DUMP_ON_ERROR', 4], ['DDOE', 4], ['ADD_DUMP_ON_ERROR', 5], ['ADOE'
  , 5], ['TRANSMIT_RATE', 6], ['TR', 6], ['STATUS', 7]];

  VAR
    system_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 7] of clt$parameter_descriptor := [

{ SYSTEM_ID SI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffff(16)]],

{ VERSION_NUMBER VN }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffff(16)]],

{ SERVICE_SYSTEM SS }
    [[clc$optional_with_default, ^system_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ DELETE_DUMP_ON_ERROR DDOE }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_allowed, [NIL, clc$integer_value, 0,
  nac$max_di_reset_code]],

{ ADD_DUMP_ON_ERROR ADOE }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_allowed, [NIL, clc$integer_value, 0,
  nac$max_di_reset_code]],

{ TRANSMIT_RATE TR }
    [[clc$optional_with_default, ^system_pdt_dv6], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, 4800, 2000000]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    system_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'TRUE';

  VAR
    system_pdt_dv6: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '2000000';

?? FMT (FORMAT := ON) ??
?? POP ??
    VAR
      error_list_count: 0 .. clc$max_value_sets,
      high_value: clt$value,
      index: integer,
      low_value: clt$value,
      reset_code_index: 0 .. nac$max_di_reset_code,
      system_id: nat$system_identifier,
      system_entry: ^linked_exception_entry,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, system_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT defaults_processed THEN
      osp$set_status_abnormal (nac$status_id, nae$defaults_not_set_first, '', status);
      RETURN;
    IFEND;

    clp$get_value ('SYSTEM_ID', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    system_id := system_address_prefix + value.int.value;
    system_entry := first_system_entry;

  /find_system_entry/
    BEGIN
      WHILE system_entry <> NIL DO
        IF system_entry^.entry.system_id = system_id THEN
          EXIT /find_system_entry/;
        IFEND;
        system_entry := system_entry^.link;
      WHILEND;
      system_count := system_count + 1;
      ALLOCATE system_entry;
      system_entry^.link := first_system_entry;
      system_entry^.entry.system_id := system_id;
      system_entry^.entry.dump_error_list := dump_error_list;
      first_system_entry := system_entry;
    END /find_system_entry/;

    clp$get_value ('SERVICE_SYSTEM', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    system_entry^.entry.service_system := value.bool.value;

    clp$test_parameter ('VERSION_NUMBER', system_entry^.entry.version_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF system_entry^.entry.version_specified THEN
      clp$get_value ('VERSION_NUMBER', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      system_entry^.entry.object_code_version := value.int.value;
    IFEND;

    clp$get_set_count ('DELETE_DUMP_ON_ERROR', error_list_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    FOR index := 1 TO error_list_count DO
      clp$get_value ('DELETE_DUMP_ON_ERROR', index, 1, clc$low, low_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$get_value ('DELETE_DUMP_ON_ERROR', index, 1, clc$high, high_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      FOR reset_code_index := low_value.int.value TO high_value.int.value DO
        system_entry^.entry.dump_error_list := system_entry^.entry.dump_error_list -
              $nat$di_dump_error_list [reset_code_index];
      FOREND;
    FOREND;

    clp$get_set_count ('ADD_DUMP_ON_ERROR', error_list_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    FOR index := 1 TO error_list_count DO
      clp$get_value ('ADD_DUMP_ON_ERROR', index, 1, clc$low, low_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$get_value ('ADD_DUMP_ON_ERROR', index, 1, clc$high, high_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      FOR reset_code_index := low_value.int.value TO high_value.int.value DO
        system_entry^.entry.dump_error_list := system_entry^.entry.dump_error_list +
              $nat$di_dump_error_list [reset_code_index];
      FOREND;
    FOREND;

    clp$get_value ('TRANSMIT_RATE', 1, 1, clc$low, value, status);
    IF  NOT status.normal THEN
       RETURN;
    IFEND;
    system_entry^.entry.transmit_rate := value.int.value;

  PROCEND define_exception_system;
?? OLDTITLE ??
?? NEWTITLE := 'define_boot_defaults', EJECT ??

  PROCEDURE define_boot_defaults (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT init_defaults_pdt (
{   default_version,dv : integer 0 .. 0ffff(16) = $REQUIRED
{   delete_dump_on_error,ddoe: LIST RANGE OF integer 0 .. nac$max_di_reset_code
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    init_defaults_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^init_defaults_pdt_names,
      ^init_defaults_pdt_params];

  VAR
    init_defaults_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['DEFAULT_VERSION', 1], ['DV', 1], ['DELETE_DUMP_ON_ERROR', 2], [
      'DDOE', 2], ['STATUS', 3]];

  VAR
    init_defaults_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor
      := [

{ DEFAULT_VERSION DV }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffff(16)]],

{ DELETE_DUMP_ON_ERROR DDOE }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_allowed, [NIL, clc$integer_value, 0,
      nac$max_di_reset_code]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      error_list_count: 0 .. clc$max_value_sets,
      high_value: clt$value,
      index: 0 .. clc$max_value_sets,
      low_value: clt$value,
      reset_code_index: 0 .. nac$max_di_reset_code,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, init_defaults_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF defaults_processed THEN
      osp$set_status_abnormal (nac$status_id, nae$defaults_set_twice, '', status);
      RETURN;
    IFEND;
    defaults_processed := TRUE;

    clp$get_value ('DEFAULT_VERSION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    object_code_version := value.int.value;

    clp$get_set_count ('DELETE_DUMP_ON_ERROR', error_list_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    FOR index := 1 TO error_list_count DO
      clp$get_value ('DELETE_DUMP_ON_ERROR', index, 1, clc$low, low_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$get_value ('DELETE_DUMP_ON_ERROR', index, 1, clc$high, high_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      FOR reset_code_index := low_value.int.value TO high_value.int.value DO
        dump_error_list := dump_error_list - $nat$di_dump_error_list [reset_code_index];
      FOREND;
    FOREND;

  PROCEND define_boot_defaults;

MODEND nam$init_directive_processor;
*DECK DECK=NAM$INSTALL_TCPIP_STATIC_ROUTES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE NETWORK ACCESS: TCP/IP Routing Utility' ??
MODULE nam$install_tcpip_static_routes;

*copyc nae$tcpip_mgmt_condition_codes
*copyc nlt$tm_static_route_definition
*copyc nlt$tm_static_route_definitions
*copyc pmt$established_handler
*copyc clp$end_utility
*copyc clp$change_variable
*copyc clp$evaluate_parameters
*copyc clp$begin_utility
*copyc clp$include_file
*copyc clp$close_display
*copyc clp$end_include
*copyc clp$get_utility_attributes
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$open_display_reference
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc clp$write_variable
*copyc nlp$tm_get_device_by_name
*copyc nlp$tm_get_static_routes
*copyc nlp$tm_install_static_routes
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc oss$job_paged_literal

  CONST
    internal_workspace_length = 16500;

  VAR
    display_control: clt$display_control,
    prompt_string: ost$status_identifier,
    static_routes: ^nlt$tm_static_route_definition := NIL,
    utility_name: clt$utility_name := 'nap$install_tcpip_static_routes';

?? NEWTITLE := 'nap$install_tcpip_static_routes', EJECT ??

  PROGRAM [XDCL] nap$install_tcpip_static_routes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE  install_tcpip_static_routes, install_tcpip_static_route, instsr(
{     input, i: FILE = $system.network.tcpip_static_routes;
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (35),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 10, 25, 11, 11, 33, 285],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 35],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$system.network.tcpip_static_routes'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$input = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

{ table name=install_static_routes type=command scope=local
{ command (define_tcpip_static_route, deftsr) p=define_tcpip_static_route cm=local
{ command (display_tcpip_static_routes, display_tcpip_static_route,   ..
{   distsr)      p=display_tcpip_static_routes cm=local
{ command (quit, qui) p=quit_command cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

    VAR
      install_static_routes: [STATIC, READ] ^clt$command_table := ^install_static_routes_entries,

      install_static_routes_entries: [STATIC, READ] array [1 .. 7] of clt$command_table_entry := [
            {} ['DEFINE_TCPIP_STATIC_ROUTE      ', clc$nominal_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^define_tcpip_static_route],
            {} ['DEFTSR                         ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^define_tcpip_static_route],
            {} ['DISPLAY_TCPIP_STATIC_ROUTE     ', clc$alias_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^display_tcpip_static_routes],
            {} ['DISPLAY_TCPIP_STATIC_ROUTES    ', clc$nominal_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^display_tcpip_static_routes],
            {} ['DISTSR                         ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^display_tcpip_static_routes],
            {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^quit_command],
            {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^quit_command]];

?? POP ??

    VAR
      i: integer,
      local_status: ost$status,
      utility_attributes: array [1 .. 2] of clt$utility_attribute,
      utility_conditions: [STATIC, READ] pmt$condition := [pmc$condition_combination,
            [pmc$system_conditions, mmc$segment_access_condition, ifc$interactive_condition,
            pmc$user_defined_condition]],
      utility_descriptor: ^pmt$established_handler,
      utility_prompt: clt$utility_prompt,
      value: clt$data_value;

{   Evaluate parameter list and get the parameters specified on the call.

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{     Add the utility subcommands to the command list.

    prompt_string := 'itr';
    utility_prompt.size := 3;
    utility_prompt.value := 'itr';
    utility_attributes [1].key := clc$utility_command_table;
    utility_attributes [1].command_table := install_static_routes;
    utility_attributes [2].key := clc$utility_prompt;
    utility_attributes [2].prompt := utility_prompt;

    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Scan command line for subcommands and execute subcommands.

    clp$include_file (pvt [p$input].value^.file_value^, '', utility_name, status);

    local_status.normal := TRUE;

    clp$end_utility (utility_name, local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND nap$install_tcpip_static_routes;
?? OLDTITLE ??
?? NEWTITLE := 'define_tcpip_static_route', EJECT ??

  PROCEDURE define_tcpip_static_route
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE define_tcpip_static_route, deftsr (
{   local_device, ld: name = $required
{   destination_address, da: list 1 .. 4 of integer 0 .. 255 = $required;
{   destination_address_mask, dam: any of key address_mask, network_mask, keyend,
{         list 1 .. 4 of integer 0 .. 255, anyend = address_mask;
{   strict_route, sr: boolean = TRUE;
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type3: 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 .. 2] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        default_value: string (12),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 10, 25, 11, 9, 18, 371],
    clc$command, 9, 5, 2, 0, 0, 0, 5, ''], [
    ['DA                             ',clc$abbreviation_entry, 2],
    ['DAM                            ',clc$abbreviation_entry, 3],
    ['DESTINATION_ADDRESS            ',clc$nominal_entry, 2],
    ['DESTINATION_ADDRESS_MASK       ',clc$nominal_entry, 3],
    ['LD                             ',clc$abbreviation_entry, 1],
    ['LOCAL_DEVICE                   ',clc$nominal_entry, 1],
    ['SR                             ',clc$abbreviation_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['STRICT_ROUTE                   ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 36, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 137, clc$optional_default_parameter, 0, 12],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 4],
{ PARAMETER 5
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [20, 1, 4, FALSE],
      [[1, 0, clc$integer_type], [0, 255, 10]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['ADDRESS_MASK                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NETWORK_MASK                   ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    36, [[1, 0, clc$list_type], [20, 1, 4, FALSE],
        [[1, 0, clc$integer_type], [0, 255, 10]]
      ]
    ,
    'address_mask'],
{ PARAMETER 4
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$local_device = 1,
      p$destination_address = 2,
      p$destination_address_mask = 3,
      p$strict_route = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      device_id: nlt$device_identifier,
      error_length: integer,
      error_string: string (20),
      link: ^^nlt$tm_static_route_definition,
      static_route: ^nlt$tm_static_route_definition;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nlp$tm_get_device_by_name (pvt [p$local_device].value^.name_value, device_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE static_route;

    static_route^.destination_address := pvt [p$destination_address].value^.element_value^.integer_value.
          value * 1000000(16);
    IF pvt [p$destination_address].value^.link <> NIL THEN
      static_route^.destination_address := static_route^.destination_address +
            pvt [p$destination_address].value^.link^.element_value^.integer_value.value * 10000(16);
      IF pvt [p$destination_address].value^.link^.link <> NIL THEN
        static_route^.destination_address := static_route^.destination_address +
              pvt [p$destination_address].value^.link^.link^.element_value^.integer_value.value * 100(16);
        IF pvt [p$destination_address].value^.link^.link^.link <> NIL THEN
          static_route^.destination_address := static_route^.destination_address +
                pvt [p$destination_address].value^.link^.link^.link^.element_value^.integer_value.value;
        IFEND;
      IFEND;
    IFEND;

    IF pvt [p$destination_address_mask].value^.kind = clc$keyword THEN
      IF pvt [p$destination_address_mask].value^.keyword_value = 'ADDRESS_MASK' THEN
        static_route^.destination_address_mask := 0ffffffff(16);
      ELSE { IF pvt [p$destination_address_mask].value^.keyword_value = 'NETWORK_MASK' THEN
        IF (static_route^.destination_address DIV 40000000(16) = 0) OR
              (static_route^.destination_address DIV 40000000(16) = 1) THEN { Class A network.
          static_route^.destination_address_mask := 0ff000000(16);
        ELSEIF static_route^.destination_address DIV 40000000(16) = 2 THEN { Class B network.
          static_route^.destination_address_mask := 0ffff0000(16);
        ELSE { Class C network.
          static_route^.destination_address_mask := 0ffffff00(16);
        IFEND;
      IFEND;
    ELSE
      static_route^.destination_address_mask := pvt [p$destination_address_mask].value^.element_value^.
            integer_value.value * 1000000(16);
      IF pvt [p$destination_address_mask].value^.link <> NIL THEN
        static_route^.destination_address_mask := static_route^.destination_address_mask +
              pvt [p$destination_address_mask].value^.link^.element_value^.integer_value.value * 10000(16);
        IF pvt [p$destination_address_mask].value^.link^.link <> NIL THEN
          static_route^.destination_address_mask := static_route^.destination_address_mask +
                pvt [p$destination_address_mask].value^.link^.link^.element_value^.integer_value.value *
                100(16);
          IF pvt [p$destination_address_mask].value^.link^.link^.link <> NIL THEN
            static_route^.destination_address_mask := static_route^.destination_address_mask +
                  pvt [p$destination_address_mask].value^.link^.link^.link^.element_value^.integer_value.
                  value;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    static_route^.nextt := NIL;

    static_route^.local_device_id := device_id;
    static_route^.local_device_name := pvt [p$local_device].value^.name_value;
    static_route^.strict_route := pvt [p$strict_route].value^.boolean_value.value;
    link := ^static_routes;
    WHILE (link^ <> NIL) AND ((link^^.destination_address > static_route^.destination_address) OR
          ((link^^.destination_address = static_route^.destination_address) AND
          (link^^.destination_address_mask > static_route^.destination_address_mask))) DO
      link := ^link^^.nextt;
    WHILEND;

  /duplicate_search/
    WHILE (link^ <> NIL) AND ((link^^.destination_address = static_route^.destination_address) AND
          (link^^.destination_address_mask = static_route^.destination_address_mask)) DO
      IF link^^.local_device_id <> static_route^.local_device_id THEN
        IF NOT link^^.strict_route THEN
          link := ^link^^.nextt;
        ELSE { IF link^^.strict_route THEN
          STRINGREP (error_string, error_length, static_route^.destination_address DIV 1000000(16), '.',
                ((static_route^.destination_address MOD 1000000(16)) DIV 10000(16)), '.',
                ((static_route^.destination_address MOD 10000(16)) DIV 100(16)), '.',
                (static_route^.destination_address MOD 100(16)));
          osp$set_status_abnormal (nac$status_id, nae$tm_equivalent_strict_route,
                error_string (1, error_length), status);
          STRINGREP (error_string, error_length, static_route^.destination_address_mask DIV 1000000(16), '.',
                ((static_route^.destination_address_mask MOD 1000000(16)) DIV 10000(16)), '.',
                ((static_route^.destination_address_mask MOD 10000(16)) DIV 100(16)), '.',
                (static_route^.destination_address_mask MOD 100(16)));
          osp$append_status_parameter (osc$status_parameter_delimiter, error_string (1, error_length),
                status);
          EXIT /duplicate_search/;
        IFEND;
      ELSE { IF link^^.local_device_id = static_route^.local_device_id THEN
        osp$set_status_abnormal (nac$status_id, nae$tm_duplicate_route, pvt [p$local_device].value^.
              name_value, status);
        STRINGREP (error_string, error_length, static_route^.destination_address DIV 1000000(16), '.',
              ((static_route^.destination_address MOD 1000000(16)) DIV 10000(16)), '.',
              ((static_route^.destination_address MOD 10000(16)) DIV 100(16)), '.',
              (static_route^.destination_address MOD 100(16)));
        osp$append_status_parameter (osc$status_parameter_delimiter, error_string (1, error_length), status);
        STRINGREP (error_string, error_length, static_route^.destination_address_mask DIV 1000000(16), '.',
              ((static_route^.destination_address_mask MOD 1000000(16)) DIV 10000(16)), '.',
              ((static_route^.destination_address_mask MOD 10000(16)) DIV 100(16)), '.',
              (static_route^.destination_address_mask MOD 100(16)));
        osp$append_status_parameter (osc$status_parameter_delimiter, error_string (1, error_length), status);
        EXIT /duplicate_search/;
      IFEND;
    WHILEND /duplicate_search/;
    IF status.normal THEN
      static_route^.nextt := link^;
      link^ := static_route;
    ELSE
      FREE static_route;
    IFEND;
  PROCEND define_tcpip_static_route;
?? OLDTITLE ??
?? NEWTITLE := 'display_tcpip_static_routes', EJECT ??

  PROCEDURE display_tcpip_static_routes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE  display_tcpip_static_routes, distsr (
{    output,o: FILE = $OUTPUT
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 10, 25, 12, 29, 8, 717],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$OUTPUT'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      data_string: string (512),
      display_control: clt$display_control,
      length: integer,
      ring_attributes: amt$ring_attributes,
      static_route: ^nlt$tm_static_route_definition;

    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$open_display_reference (pvt [p$output].value^.file_value^, NIL, fsc$list, ring_attributes,
          display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, 'Uninstalled Static Route Definitions:', clc$trim, status);
    static_route := static_routes;
    WHILE static_route <> NIL DO
      clp$put_display (display_control, '', clc$trim, status);
      clp$put_display (display_control, '  DEFINE_TCPIP_STATIC_ROUTE ..', clc$trim, status);
      STRINGREP (data_string, length, '    LOCAL_DEVICE=', static_route^.local_device_name, ' ..');
      clp$put_display (display_control, data_string (1, length), clc$trim, status);
      STRINGREP (data_string, length, '    DESTINATION_ADDRESS=(',
            static_route^.destination_address DIV 1000000(16), ',',
            ((static_route^.destination_address MOD 1000000(16)) DIV 10000(16)), ',',
            ((static_route^.destination_address MOD 10000(16)) DIV 100(16)), ',',
            (static_route^.destination_address MOD 100(16)), ') ..');
      clp$put_display (display_control, data_string (1, length), clc$trim, status);
      STRINGREP (data_string, length, '    DESTINATION_ADDRESS_MASK=(',
            static_route^.destination_address_mask DIV 1000000(16), ',',
            ((static_route^.destination_address_mask MOD 1000000(16)) DIV 10000(16)), ',',
            ((static_route^.destination_address_mask MOD 10000(16)) DIV 100(16)), ',',
            (static_route^.destination_address_mask MOD 100(16)), ') .. ');
      clp$put_display (display_control, data_string (1, length), clc$trim, status);
      IF static_route^.strict_route THEN
        clp$put_display (display_control, '    STRICT_ROUTE=TRUE', clc$trim, status);
      ELSE
        clp$put_display (display_control, '    STRICT_ROUTE=FALSE', clc$trim, status);
      IFEND;
      static_route := static_route^.nextt;
    WHILEND;
    clp$close_display (display_control, status);
  PROCEND display_tcpip_static_routes;
?? OLDTITLE ??
?? NEWTITLE := 'quit_command', EJECT ??

  PROCEDURE quit_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE quit_command, quit, qui(
{   install_static_routes, install_static_route, isr: boolean = TRUE;
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 10, 25, 12, 27, 19, 230],
    clc$command, 4, 2, 0, 0, 0, 0, 2, ''], [
    ['INSTALL_STATIC_ROUTE           ',clc$alias_entry, 1],
    ['INSTALL_STATIC_ROUTES          ',clc$nominal_entry, 1],
    ['ISR                            ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$install_static_routes = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      static_route: ^nlt$tm_static_route_definition;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$install_static_routes].value^.boolean_value.value THEN
      nlp$tm_install_static_routes (static_routes, status);
    IFEND;
    IF status.normal THEN
      static_route := static_routes;
      WHILE static_route <> NIL DO
        static_routes := static_route^.nextt;
        FREE static_route;
        static_route := static_routes
      WHILEND;
      clp$end_include (utility_name, status);
    IFEND;

  PROCEND quit_command;
?? OLDTITLE ??
MODEND nam$install_tcpip_static_routes;
*DECK DECK=NAM$INTERNAL_CONNECTION_MGMT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NAM$INTERNAL_CONNECTION_MGMT' ??
MODULE nam$internal_connection_mgmt;
?? PUSH (LISTEXT:=ON) ??
*copyc bap$validate_file_Identifier
*copyc fst$file_reference
*copyc jmt$system_supplied_name
*copyc jmv$executing_within_system_job
*copyc nae$application_interfaces
*copyc nae$directory_me_conditions
*copyc nae$namve_conditions
*copyc nak$am_keypoints_job_mode
*copyc nat$am_keypoint_constants
*copyc nat$application_name
*copyc nat$directory_interfaces
*copyc nat$client_attributes
*copyc nat$create_attributes
*copyc nat$get_attributes
*copyc nat$server_attributes
*copyc nat$switched_connection
*copyc nat$wait_time
*copyc ost$i_wait
?? POP ??
?? TITLE := 'XREFd PROCEDURES', EJECT ??
*copyc amp$return
*copyc nap$clear_switch_offer
*copyc nap$create_network_file
*copyc nap$get_connection_identifier
*copyc nap$namve_system_error
*copyc nap$remove_wait_data_available
*copyc nap$remove_wait_server_response
*copyc nap$se_request_connection
*copyc nap$set_switch_offer
*copyc nap$se_terminate_connection
*copyc nlp$end_title_translation
*copyc nlp$sk_lock_job_socket
*copyc nlp$sk_tcp_remove_accept_socket
*copyc nlp$sk_tcp_remove_data_avail
*copyc nlp$sk_tcp_remove_clear_to_send
*copyc nlp$sk_remove_wait_socket_offer
*copyc nlp$sk_unlock_job_socket
*copyc nlp$translate_title
*copyc nlp$udp_remove_clear_to_send
*copyc nlp$udp_remove_data_available
*copyc osp$is_caller_system_privileged
*copyc osp$pop_inhibit_job_recovery
*copyc osp$push_inhibit_job_recovery
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$get_job_names
{*copyc pmp$log
*copyc pmp$ready_task
*copyc pmp$get_executing_task_gtid
?? TITLE := 'GLOBAL VARIABLES', EJECT ??
*copyc oss$job_paged_literal
*copyc nav$network_paged_heap
*copyc nav$namve_active
*copyc nav$client_attributes_list
*copyc nav$server_attributes_list
*copyc nav$switched_connections_list

  VAR
    end_directory_search: [READ, OSS$JOB_PAGED_LITERAL] string (20) := 'NAP$END_DIRECTORY_SEARCH';
?? TITLE := 'NAP$BEGIN_DIRECTORY_SEARCH', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$begin_directory_search (
         title_pattern: nat$title_pattern;
         client: nat$application_name;
         recurrent_search: boolean;
     VAR search_identifier: nat$directory_search_identifier;
     VAR status: ost$status);

*copyc nah$begin_directory_search

    VAR
      client_attributes: ^nat$client_attributes,
      index: integer,
      search_domain: nat$title_domain,
      wild_card: boolean,
      wild_card_characters: [STATIC, READ, OSS$JOB_PAGED_LITERAL] SET OF char := ['?', '*', '''', '[', ']'];

    IF NOT nav$namve_active THEN
      osp$set_status_condition ( nae$network_inactive,  status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    #keypoint (osk$entry, osk$m * amk_begin_directory_search, nak$internal_connection_mgmt);
    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    nlp$get_nonexclusive_access (nav$client_attributes_list.access_control);
    nap$find_client_attributes (client, client_attributes);
    IF client_attributes = NIL THEN
      osp$set_status_abnormal (nac$status_id, nae$unknown_application, client, status);
    ELSE
      nlp$get_nonexclusive_access (client_attributes^.access_control);
      nap$validate_user (client_attributes^.client_capability, client_attributes^.client_ring,
            client_attributes^.client_system_privilege, status);
      IF NOT status.normal THEN
{ Client not authorized for this request.
        osp$set_status_abnormal (nac$status_id, nae$unknown_application, client, status);
      ELSEIF client_attributes^.client_status = nac$application_inactive THEN
        osp$set_status_abnormal (nac$status_id, nae$application_inactive, client, status);
      ELSE
        #SCAN (wild_card_characters, title_pattern, index, wild_card);
        search_domain.kind := nac$catenet_domain;
        nlp$translate_title (title_pattern, wild_card, client_attributes^.protocol, recurrent_search,
              search_domain, nac$cdna_external, search_identifier, status);
      IFEND;

      nlp$release_nonexclusive_access (client_attributes^.access_control);
    IFEND;

    nlp$release_nonexclusive_access (nav$client_attributes_list.access_control);
    osp$end_subsystem_activity;
    osp$pop_inhibit_job_recovery;
    #keypoint (osk$exit, osk$m * amk_begin_directory_search, nak$internal_connection_mgmt);

  PROCEND nap$begin_directory_search;
?? TITLE := 'NAP$CHECK_CONNECTION', EJECT ??
  PROCEDURE [XDCL] nap$check_connection (server: nat$application_name;
    VAR activity_complete: boolean;
    VAR status: ost$status);

    VAR
      assigned_connection: ^nat$server_connection_attribute,
      executing_job_name: jmt$system_supplied_name,
      executing_taskid: ost$global_task_id,
      ignore_status: ost$status,
      previous_wait_for_connection: ^^nat$wait_for_connection,
      server_attributes: ^nat$server_attributes,
      server_job_attributes: ^nat$server_job_attributes,
      task_in_wait_queue: boolean,
      user_supplied_name: jmt$user_supplied_name,
      wait_for_connection: ^nat$wait_for_connection;

    status.normal := TRUE;
    #keypoint (osk$entry, osk$m * amk_check_connection, nak$internal_connection_mgmt);
    activity_complete := FALSE;
    task_in_wait_queue := FALSE;
    pmp$get_executing_task_gtid (executing_taskid);
    pmp$get_job_names (user_supplied_name, executing_job_name, ignore_status);

    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
    nap$find_server_attributes (server, server_attributes);
    IF server_attributes = NIL THEN
{ Unknown server.
      activity_complete := TRUE;
    ELSE
      nlp$get_exclusive_access (server_attributes^.access_control);
      IF server_attributes^.server_status = nac$application_inactive THEN
        activity_complete := TRUE;
      ELSE
        server_job_attributes := server_attributes^.server_job_list;
        WHILE (server_job_attributes <> NIL) AND (server_job_attributes^.job_name <> executing_job_name) DO
          server_job_attributes := server_job_attributes^.next_entry;
        WHILEND;

        IF server_job_attributes = NIL THEN
{ Server not attached.
          activity_complete := TRUE;
        ELSE
{ Check if the task is queued in the wait_for_connection queue.

          wait_for_connection := server_attributes^.wait_for_connection;
          previous_wait_for_connection := ^server_attributes^.wait_for_connection;
          WHILE (wait_for_connection <> NIL) AND (wait_for_connection^.job_name <> executing_job_name) DO
             previous_wait_for_connection := ^wait_for_connection^.next_entry;
             wait_for_connection := wait_for_connection^.next_entry;
          WHILEND;

         IF (wait_for_connection <> NIL) AND (wait_for_connection^.task_id <> executing_taskid) THEN
           activity_complete := TRUE;
           osp$set_status_condition ( nae$multiple_waits_attempted,  status);
         IFEND;

         IF status.normal THEN
           task_in_wait_queue := wait_for_connection <> NIL;

{ Check if a connection is available.

           IF server_attributes^.assigned_connections_list <> NIL THEN
             activity_complete := TRUE;
             IF task_in_wait_queue THEN
{ Remove task from the wait_for_connection queue.
               previous_wait_for_connection^ := wait_for_connection^.next_entry;
               FREE wait_for_connection IN nav$network_paged_heap^;
             IFEND;
           ELSE
             IF NOT task_in_wait_queue THEN
{ Queue task in the wait_for_connection queue.
               REPEAT
                 ALLOCATE wait_for_connection IN nav$network_paged_heap^;
                 IF wait_for_connection = NIL THEN
                   osp$end_subsystem_activity;
                   syp$cycle;
                   osp$begin_subsystem_activity;
                 IFEND;
               UNTIL wait_for_connection <> NIL;
               wait_for_connection^.task_id := executing_taskid;
               wait_for_connection^.job_name := executing_job_name;
               wait_for_connection^.next_entry := server_attributes^.wait_for_connection;
               server_attributes^.wait_for_connection := wait_for_connection;
             IFEND;
           IFEND;
         IFEND;
        IFEND;
      IFEND;

      nlp$release_exclusive_access (server_attributes^.access_control);
    IFEND;

    nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
    osp$end_subsystem_activity;
    osp$pop_inhibit_job_recovery;
    #keypoint (osk$exit, osk$m * amk_check_connection, nak$internal_connection_mgmt);

  PROCEND nap$check_connection;
?? TITLE := 'NAP$CHECK_SWITCH_ACCEPT', EJECT ??

  PROCEDURE [XDCL] nap$check_switch_accept (file: fst$file_reference;
    VAR activity_complete: boolean;
    VAR status: ost$status);

    VAR
      executing_taskid: ost$global_task_id,
      connection_id: nat$connection_id,
      ignore_status: ost$status,
      previous_switched_connection: ^^nat$switched_connection,
      switched_connection: ^nat$switched_connection;

    activity_complete := FALSE;
    status.normal := TRUE;
    #keypoint (osk$entry, osk$m * amk_check_switch_accept, nak$internal_connection_mgmt);
    nap$get_connection_identifier (file, connection_id, status);
    IF status.normal THEN
      osp$push_inhibit_job_recovery;
      nlp$get_exclusive_access (nav$switched_connections_list.access_control);
      switched_connection := nav$switched_connections_list.switched_connection;
      previous_switched_connection := ^nav$switched_connections_list.switched_connection;

      WHILE (switched_connection <> NIL) AND (switched_connection^.connection_id <> connection_id) DO
        previous_switched_connection := ^switched_connection^.next_entry;
        switched_connection := switched_connection^.next_entry;
      WHILEND;

      IF switched_connection = NIL THEN
        activity_complete := TRUE;
        osp$set_status_abnormal (nac$status_id, nae$no_switch_offer_pending, file, status);
      ELSE
        IF switched_connection^.switch_status = nac$switch_complete THEN
          activity_complete := TRUE;
          previous_switched_connection^ := switched_connection^.next_entry;
          nap$clear_switch_offer (file, TRUE, ignore_status);
          FREE switched_connection IN nav$network_paged_heap^;
        ELSE
          pmp$get_executing_task_gtid (executing_taskid);
          IF switched_connection^.wait_for_switch_accept.index = 0 THEN

{ ** It is assumed that only one task will be allowed to wait for switch accept.

            switched_connection^.wait_for_switch_accept := executing_taskid;
          ELSE
            IF switched_connection^.wait_for_switch_accept <> executing_taskid THEN
              osp$set_status_abnormal (nac$status_id, nae$multiple_waits_attempted, 'SWITCH ACCEPT', status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      nlp$release_exclusive_access (nav$switched_connections_list.access_control);
      osp$pop_inhibit_job_recovery;
    ELSEIF (NOT status.normal) AND (status.condition = nae$system_interrupt) THEN
      status.normal := TRUE;
    IFEND;
    #keypoint (osk$exit, osk$m * amk_check_switch_accept, nak$internal_connection_mgmt);

  PROCEND nap$check_switch_accept;
?? TITLE := 'NAP$CHECK_SWITCH_OFFER', EJECT ??

  PROCEDURE [XDCL] nap$check_switch_offer (source: jmt$system_supplied_name;
    VAR activity_complete: boolean;
    VAR status: ost$status);

    VAR
      executing_taskid: ost$global_task_id,
      executing_job_name: jmt$system_supplied_name,
      ignore_status: ost$status,
      previous_wait_for_switch_offer: ^^nat$wait_for_switch_offer,
      switched_connection: ^nat$switched_connection,
      task_in_wait_queue: boolean,
      user_supplied_name: jmt$user_supplied_name,
      wait_for_switch_offer: ^nat$wait_for_switch_offer;

    status.normal := TRUE;
    #keypoint (osk$entry, osk$m * amk_check_switch_offer, nak$internal_connection_mgmt);
    activity_complete := FALSE;
    task_in_wait_queue := FALSE;
    pmp$get_executing_task_gtid (executing_taskid);
    osp$push_inhibit_job_recovery;
    nlp$get_exclusive_access (nav$switched_connections_list.access_control);
    pmp$get_job_names (user_supplied_name, executing_job_name, ignore_status);

{ Check if the current task is in the wait_for_switch_offer queue.

    wait_for_switch_offer := nav$switched_connections_list.wait_for_switch_offer;
    previous_wait_for_switch_offer := ^nav$switched_connections_list.wait_for_switch_offer;

    WHILE (wait_for_switch_offer <> NIL) AND (wait_for_switch_offer^.destination_job_name <>
          executing_job_name) DO
      previous_wait_for_switch_offer := ^wait_for_switch_offer^.next_entry;
      wait_for_switch_offer := wait_for_switch_offer^.next_entry;
    WHILEND;

    IF (wait_for_switch_offer <> NIL) AND (wait_for_switch_offer^.destination_task_id <> executing_taskid)
          THEN
      activity_complete := TRUE;
      osp$set_status_abnormal (nac$status_id, nae$multiple_waits_attempted, 'SWITCH OFFER', status);
    IFEND;

    IF status.normal THEN
      task_in_wait_queue := wait_for_switch_offer <> NIL;

{ Check if a switch offer has been made.

      switched_connection := nav$switched_connections_list.switched_connection;

      WHILE (switched_connection <> NIL) AND ((switched_connection^.source_job_name <> source) OR
            (switched_connection^.destination_job_name <> executing_job_name) OR
            (switched_connection^.switch_status = nac$switch_complete)) DO
        switched_connection := switched_connection^.next_entry;
      WHILEND;

      IF switched_connection <> NIL THEN
        activity_complete := TRUE;
        IF task_in_wait_queue THEN
{ Remove the entry in the wait_for_switch_offer queue.
          previous_wait_for_switch_offer^ := wait_for_switch_offer^.next_entry;
          FREE wait_for_switch_offer IN nav$network_paged_heap^;
        IFEND;
      ELSE
{ Queue the task in the wait_for_switch_offer list.

        IF NOT task_in_wait_queue THEN
          REPEAT
            ALLOCATE wait_for_switch_offer IN nav$network_paged_heap^;
            IF wait_for_switch_offer = NIL THEN
              syp$cycle;
            IFEND;
          UNTIL wait_for_switch_offer <> NIL;
          wait_for_switch_offer^.source_job_name := source;
          wait_for_switch_offer^.destination_job_name := executing_job_name;
          wait_for_switch_offer^.destination_task_id := executing_taskid;
          wait_for_switch_offer^.next_entry := nav$switched_connections_list.wait_for_switch_offer;
          nav$switched_connections_list.wait_for_switch_offer := wait_for_switch_offer;
        IFEND;
      IFEND;
    IFEND;

    nlp$release_exclusive_access (nav$switched_connections_list.access_control);
    osp$pop_inhibit_job_recovery;
    #keypoint (osk$exit, osk$m * amk_check_switch_offer, nak$internal_connection_mgmt);

  PROCEND nap$check_switch_offer;
?? TITLE := 'NAP$CANCEL_SWITCH_OFFER', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$cancel_switch_offer (file: fst$file_reference;
    VAR status: ost$status);

    VAR
      connection_id: nat$connection_id,
      switch_complete: boolean,
      ignore_status: ost$status;

    status.normal := TRUE;
    nap$get_connection_identifier (file, connection_id, status);
    IF status.normal THEN
      nlp$cancel_switch_offer (connection_id, switch_complete, status);
      IF status.normal THEN
        nap$clear_switch_offer (file, switch_complete, ignore_status);
        IF switch_complete THEN
          osp$set_status_abnormal (nac$status_id, nae$switch_offer_accepted, file, status);
        IFEND;
      IFEND;
    ELSEIF (NOT status.normal) AND (status.condition = nae$system_interrupt) THEN
{
{ The variable switch_complete is unset.  It is just used as a place holder.
{
      nap$clear_switch_offer (file, switch_complete, ignore_status);
      status.normal := TRUE;
    IFEND;

  PROCEND nap$cancel_switch_offer;
?? TITLE := 'NAP$END_DIRECTORY_SEARCH', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$end_directory_search (
         search_identifier: nat$directory_search_identifier;
     VAR status: ost$status);

*copyc nah$end_directory_search

    status.normal := TRUE;
    #keypoint (osk$entry, osk$m * amk_end_directory_search, nak$internal_connection_mgmt);
    nlp$end_title_translation (search_identifier, status);
    IF (NOT status.normal) AND (status.condition = nae$translation_req_not_active) THEN
      osp$set_status_abnormal (nac$status_id, nae$invalid_directory_search_id, end_directory_search, status);
    IFEND;
    #keypoint (osk$exit, osk$m * amk_end_directory_search, nak$internal_connection_mgmt);

  PROCEND nap$end_directory_search;
?? TITLE := 'NAP$MONITOR_SERVER_CONNECTIONS', EJECT ??

  PROCEDURE [XDCL] nap$monitor_server_connections (current_time: integer);

   CONST
     expiration_interval = 300000000; {5 min in micro sec}

    VAR
      assigned_connection: ^nat$server_connection_attribute,
      connection_released: boolean,
      ignore_status: ost$status,
      next_server_attributes: ^nat$server_attributes,
      previous_assigned_connection: ^^nat$server_connection_attribute,
      previous_job_attributes: ^^nat$server_job_attributes,
      server_job_attributes: ^nat$server_job_attributes,
      server_attributes: ^nat$server_attributes;

    #keypoint (osk$entry, osk$m * amk_monitor_server_connections, nak$internal_connection_mgmt);

    { Scan the assigned connections list for expired unacquired connections.
    nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
    server_attributes := nav$server_attributes_list.server_attributes;

    WHILE server_attributes <> NIL DO
      nlp$get_exclusive_access (server_attributes^.access_control);
      assigned_connection := server_attributes^.assigned_connections_list;
      previous_assigned_connection := ^server_attributes^.assigned_connections_list;

      WHILE assigned_connection <> NIL DO
        IF (assigned_connection^.time_stamp + expiration_interval) <= current_time THEN
          previous_assigned_connection^ := assigned_connection^.next_entry;
          nap$se_terminate_connection (assigned_connection^.connection_id, nac$connection_failed,
                FALSE, connection_released, ignore_status);
          IF assigned_connection^.directed_connection THEN
            decrement_assigned_conn_count (server_attributes, assigned_connection^.job_name);
          IFEND;

          FREE assigned_connection IN nav$network_paged_heap^;
          server_attributes^.connection_count := server_attributes^.connection_count
            - 1;
{ *** DEBUG pmp$log ('AM - Assigned connection timeout.', ignore_status);
          assigned_connection := previous_assigned_connection^;
        ELSE
          previous_assigned_connection := ^assigned_connection^.next_entry;
          assigned_connection := assigned_connection^.next_entry;
        IFEND;
      WHILEND;


      { Scan server_attributes_list for unsigned on job entries.

      server_job_attributes := server_attributes^.server_job_list;
      previous_job_attributes := ^server_attributes^.server_job_list;
      WHILE server_job_attributes <> NIL DO
        IF (server_job_attributes^.job_status = nac$server_job_initiated) AND ((server_job_attributes^.
              time_stamp + expiration_interval) <= current_time) THEN
          previous_job_attributes^ := server_job_attributes^.next_entry;
          FREE server_job_attributes IN nav$network_paged_heap^;
 { *** DEBUG pmp$log ('AM - Initiated job did not attach to server.', ignore_status);
          server_job_attributes := previous_job_attributes^;
        ELSE
          previous_job_attributes := ^server_job_attributes^.next_entry;
          server_job_attributes := server_job_attributes^.next_entry;
        IFEND;
      WHILEND;

      next_server_attributes := server_attributes^.next_entry;
      nlp$release_exclusive_access (server_attributes^.access_control);
      server_attributes := next_server_attributes;
    WHILEND;

    nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
    #keypoint (osk$exit, osk$m * amk_monitor_server_connections, nak$internal_connection_mgmt);

  PROCEND nap$monitor_server_connections;
?? TITLE := 'NAP$PROCESS_TASK_TERMINATION', EJECT ??

  PROCEDURE [XDCL] nap$process_task_termination;

{ The purpose of this procedure is to remove the terminating task from the
{ wait_for_switch_offer queues.

    VAR
      executing_taskid: ost$global_task_id,
      local_status: ost$status,
      previous_wait_for_connection: ^^nat$wait_for_connection,
      previous_wait_for_switch_offer: ^^nat$wait_for_switch_offer,
      wait_for_connection: ^nat$wait_for_connection,
      wait_for_switch_offer: ^nat$wait_for_switch_offer;

    #keypoint (osk$entry, osk$m * amk_process_task_termination, nak$internal_connection_mgmt);
    pmp$get_executing_task_gtid (executing_taskid);
    osp$push_inhibit_job_recovery;
    nlp$get_exclusive_access (nav$switched_connections_list.access_control);

{ Check if the task had been waiting for switched connections.

    wait_for_switch_offer := nav$switched_connections_list.wait_for_switch_offer;
    previous_wait_for_switch_offer := ^nav$switched_connections_list.wait_for_switch_offer;
    WHILE (wait_for_switch_offer <> NIL) AND (wait_for_switch_offer^.destination_task_id <> executing_taskid)
          DO
      previous_wait_for_switch_offer := ^wait_for_switch_offer^.next_entry;
      wait_for_switch_offer := wait_for_switch_offer^.next_entry;
    WHILEND;

    IF wait_for_switch_offer <> NIL THEN
      previous_wait_for_switch_offer^ := wait_for_switch_offer^.next_entry;
      FREE wait_for_switch_offer IN nav$network_paged_heap^;
    IFEND;

    nlp$release_exclusive_access (nav$switched_connections_list.access_control);
    osp$pop_inhibit_job_recovery;
    #keypoint (osk$exit, osk$m * amk_process_task_termination, nak$internal_connection_mgmt);

  PROCEND nap$process_task_termination;
?? TITLE := 'NAP$REMOVE_NETWORK_WAITS', EJECT ??

  PROCEDURE [XDCL] nap$remove_network_waits (activity_list: ost$i_wait_list);

{ The purpose of this request is to remove the current task from all network
{ wait queues.

    VAR
      index: integer,
      connection_id: nat$connection_id,
      executing_taskid: ost$global_task_id,
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      job_socket: ^nat$sk_job_socket,
      local_status: ost$status,
      previous_wait_for_connection: ^^nat$wait_for_connection,
      previous_wait_for_switch_offer: ^^nat$wait_for_switch_offer,
      server_attributes: ^nat$server_attributes,
      switched_connection: ^nat$switched_connection,
      wait_for_connection: ^nat$wait_for_connection,
      wait_for_switch_offer: ^nat$wait_for_switch_offer;

    #keypoint (osk$entry, osk$m * amk_remove_network_waits, nak$internal_connection_mgmt);
    pmp$get_executing_task_gtid (executing_taskid);
    index := 1;
    osp$push_inhibit_job_recovery;
    WHILE index <= UPPERBOUND (activity_list) DO
      CASE activity_list [index].activity OF
      = osc$i_null_activity, osc$i_await_time, pmc$i_await_task_termination =

      = pmc$i_await_local_queue_message =

      = nac$i_await_server_response =
        nap$remove_wait_server_response (activity_list [index].file^);
      = nac$i_await_connection =
        osp$begin_subsystem_activity;
        nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
        nap$find_server_attributes (activity_list [index].server, server_attributes);
        IF server_attributes <> NIL THEN
          nlp$get_exclusive_access (server_attributes^.access_control);
          wait_for_connection := server_attributes^.wait_for_connection;
          previous_wait_for_connection := ^server_attributes^.wait_for_connection;

          WHILE (wait_for_connection <> NIL) AND (wait_for_connection^.task_id <> executing_taskid) DO
            previous_wait_for_connection := ^wait_for_connection^.next_entry;
            wait_for_connection := wait_for_connection^.next_entry;
          WHILEND;

          IF wait_for_connection <> NIL THEN
            previous_wait_for_connection^ := wait_for_connection^.next_entry;
            FREE wait_for_connection IN nav$network_paged_heap^;
          IFEND;

          nlp$release_exclusive_access (server_attributes^.access_control);
        IFEND;
        nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
        osp$end_subsystem_activity;

      = nac$i_await_switch_offer =
        nlp$get_exclusive_access (nav$switched_connections_list.access_control);

{ Check if the task had been waiting for switched connections.

        wait_for_switch_offer := nav$switched_connections_list.wait_for_switch_offer;
        previous_wait_for_switch_offer := ^nav$switched_connections_list.wait_for_switch_offer;
        WHILE (wait_for_switch_offer <> NIL) AND (wait_for_switch_offer^.destination_task_id <>
              executing_taskid) DO
          previous_wait_for_switch_offer := ^wait_for_switch_offer^.next_entry;
          wait_for_switch_offer := wait_for_switch_offer^.next_entry;
        WHILEND;

        IF wait_for_switch_offer <> NIL THEN
          previous_wait_for_switch_offer^ := wait_for_switch_offer^.next_entry;
          FREE wait_for_switch_offer IN nav$network_paged_heap^;
        IFEND;

        nlp$release_exclusive_access (nav$switched_connections_list.access_control);
      = nac$i_await_switch_accept =
        nap$get_connection_identifier (activity_list [index].file^, connection_id, local_status);
        IF local_status.normal THEN
          nlp$get_exclusive_access (nav$switched_connections_list.access_control);
          switched_connection := nav$switched_connections_list.switched_connection;
          WHILE (switched_connection <> NIL) AND (switched_connection^.connection_id <> connection_id) DO
            switched_connection := switched_connection^.next_entry;
          WHILEND;
          IF switched_connection <> NIL THEN
            IF switched_connection^.wait_for_switch_accept = executing_taskid THEN
              switched_connection^.wait_for_switch_accept.index := 0;
            IFEND;
          IFEND;
          nlp$release_exclusive_access (nav$switched_connections_list.access_control);
        IFEND;
      = nac$i_await_activity_status =

      = nac$i_await_data_available =
        bap$validate_file_identifier (activity_list[index].file_identifier,
          file_instance,file_is_valid);
        IF file_is_valid THEN
          IF  file_instance^.device_class = rmc$network_device THEN
            nap$remove_wait_data_available (activity_list [index].file_identifier);
          ELSE
            IF file_instance <> NIL THEN
              IF file_instance^.device_class = rmc$terminal_device THEN
                IF file_instance^.st_open_file_dsc_pointer <> NIL THEN
                  nap$remove_wait_data_available (file_instance^.st_open_file_dsc_pointer^.vtp_file_id);
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      = nac$i_await_title_translation, osc$i_await_unspecified_event =
        ;

      = nac$i_sk_await_clear_to_send =
        nlp$sk_lock_job_socket (activity_list [index].socket_identifier, job_socket);
        IF job_socket <> NIL THEN
          IF job_socket^.status = nac$sk_socket_open THEN
            IF job_socket^.socket_type = nac$sk_udp_socket THEN
              nlp$udp_remove_clear_to_send (job_socket^.global_socket_id);
            ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
              IF (job_socket^.tcp_socket_type = nlc$tcp_connect_socket) OR
                    (job_socket^.tcp_socket_type = nlc$tcp_accept_socket) THEN
                nlp$sk_tcp_remove_clear_to_send (job_socket^.connection_id);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
        nlp$sk_unlock_job_socket (activity_list [index].socket_identifier);

      = nac$i_sk_await_data_available =
        nlp$sk_lock_job_socket (activity_list [index].socket_id, job_socket);
        IF job_socket <> NIL THEN
          IF job_socket^.status = nac$sk_socket_open THEN
            IF job_socket^.socket_type = nac$sk_udp_socket THEN
              nlp$udp_remove_data_available (job_socket^.global_socket_id);
            ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
              IF (job_socket^.tcp_socket_type = nlc$tcp_connect_socket) OR (job_socket^.tcp_socket_type =
                      nlc$tcp_accept_socket) THEN
                  nlp$sk_tcp_remove_data_avail (job_socket^.connection_id);
              ELSEIF  job_socket^.tcp_socket_type = nlc$tcp_listen_socket THEN
                nlp$sk_tcp_remove_accept_socket (job_socket^.application, job_socket^.port,
                      job_socket^.bound_address);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
        nlp$sk_unlock_job_socket (activity_list [index].socket_id);

      = nac$i_sk_await_socket_offer =
        nlp$sk_remove_wait_socket_offer (activity_list [index].source_job);

      ELSE
      CASEND;

      index := index + 1;
    WHILEND;

    osp$pop_inhibit_job_recovery;
    #keypoint (osk$exit, osk$m * amk_remove_network_waits, nak$internal_connection_mgmt);

  PROCEND nap$remove_network_waits;
?? TITLE := 'NLP$ACCEPT_SWITCH_OFFER', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$accept_switch_offer (file: fst$file_reference;
        source: jmt$system_supplied_name;
        attributes: ^nat$create_attributes;
        timesharing_connection_switch: boolean;
    VAR status: ost$status);

{ The purpose of this request is to acquire a connection that has been switched
{ by the SOURCE job to the currently executing job.


    VAR
      ignore_status: ost$status,
      destination_job_name: jmt$system_supplied_name,
      switched_connection: ^nat$switched_connection,
      user_supplied_name: jmt$user_supplied_name;

    status.normal := TRUE;

    IF (NOT jmv$executing_within_system_job) AND (NOT osp$is_caller_system_privileged()) THEN
      osp$set_status_abnormal ('NA',nae$insufficient_privilege,
            'nlp$accept_switch_offer',status);
      RETURN;
    IFEND;


    #keypoint (osk$entry, osk$m * amk_accept_switch_offer, nak$internal_connection_mgmt);
    pmp$get_job_names (user_supplied_name, destination_job_name, status);
    osp$push_inhibit_job_recovery;

    nlp$get_exclusive_access (nav$switched_connections_list.access_control);
    switched_connection := nav$switched_connections_list.switched_connection;

    WHILE (switched_connection <> NIL) AND ((switched_connection^.source_job_name <> source) OR
          (switched_connection^.destination_job_name <> destination_job_name) OR
          (switched_connection^.switch_status = nac$switch_complete)) DO
      switched_connection := switched_connection^.next_entry;
    WHILEND;

    IF switched_connection <> NIL THEN
      nap$create_network_file (file, attributes, switched_connection^.connection_id,
        timesharing_connection_switch, status);
      IF status.normal THEN
        update_application_connection (switched_connection^.application, switched_connection^.source_job_name,
              switched_connection^.connection_id);
        switched_connection^.switch_status := nac$switch_complete;
        { Ready the source task that had initiated the switch.
        IF switched_connection^.wait_for_switch_accept.index <> 0 THEN
          pmp$ready_task (switched_connection^.wait_for_switch_accept, ignore_status);
        IFEND;
      IFEND;
    ELSE
      osp$set_status_abnormal (nac$status_id, nae$no_switch_offered, destination_job_name, status);
    IFEND;

    nlp$release_exclusive_access (nav$switched_connections_list.access_control);
    osp$pop_inhibit_job_recovery;
    #keypoint (osk$exit, osk$m * amk_accept_switch_offer, nak$internal_connection_mgmt);

  PROCEND nlp$accept_switch_offer;
?? TITLE := 'NLP$ACQUIRE_CONNECTION', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$acquire_connection (server: nat$application_name;
        file: fst$file_reference;
        file_exists: boolean;
        attributes: ^nat$create_attributes;
    VAR status: ost$status);

{ The purpose of this procedure is to acquire a connection assigned to a given
{ server. The connection is either assigned to a particular job in which case it
{ can only be acquired by the job to which it has been assigned or it is assigned
{ to  any server job in which case it can be acquired by any server job. The
{ request is rejected if the server is inactive or has been deleted or if the
{ acquiring job has already acquired the max connections.

    VAR
      executing_job_name: jmt$system_supplied_name,
      ignore_status: ost$status,
      user_supplied_name: jmt$user_supplied_name;


    IF (NOT jmv$executing_within_system_job) AND (NOT osp$is_caller_system_privileged()) THEN
      osp$set_status_abnormal ('NA',nae$insufficient_privilege,
            'nlp$acquire_connection',status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    #keypoint (osk$entry, osk$m * amk_acquire_connection, nak$internal_connection_mgmt);
    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);

    pmp$get_job_names (user_supplied_name, executing_job_name, ignore_status);
    acquire_connection (executing_job_name, server, file, file_exists, attributes, status);

    nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
    osp$end_subsystem_activity;
    osp$pop_inhibit_job_recovery;
    #keypoint (osk$exit, osk$m * amk_acquire_connection, nak$internal_connection_mgmt);

  PROCEND nlp$acquire_connection;
?? NEWTITLE := '[XDCL, #GATE] nlp$acquire_specific_connection', EJECT ??

{ PURPOSE:
{   The purpose of this request is the same as nap$acquire_connection except that
{   the job_name of the connection to acquire is passed as a parameter.

  PROCEDURE [XDCL, #GATE] nlp$acquire_specific_connection
    (    system_job_name: jmt$system_supplied_name;
         server: nat$application_name;
         file: fst$file_reference;
         file_exists: boolean;
         attributes: ^nat$create_attributes;
     VAR status: ost$status);

{ The purpose of this procedure is to acquire a connection assigned to a given
{ server and job.  The request is rejected if the server is inactive or has
{ been deleted or if the acquiring job has already acquired the max
{ connections.


    IF (NOT jmv$executing_within_system_job) AND (NOT osp$is_caller_system_privileged ()) THEN
      osp$set_status_abnormal ('NA', nae$insufficient_privilege, 'nlp$acquire_specific_connection', status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);

    acquire_connection (system_job_name, server, file, file_exists, attributes, status);

    nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
    osp$end_subsystem_activity;
    osp$pop_inhibit_job_recovery;

  PROCEND nlp$acquire_specific_connection;
?? OLDTITLE ??
?? TITLE := 'NLP$CANCEL_SWITCH_OFFER', EJECT ??

  PROCEDURE [XDCL] nlp$cancel_switch_offer (connection_id: nat$connection_id;
    VAR switch_complete: boolean;
    VAR status: ost$status);

    VAR
      previous_switched_connection: ^^nat$switched_connection,
      switched_connection: ^nat$switched_connection;

    status.normal := TRUE;
    #keypoint (osk$entry, osk$m * amk_cancel_switch_offer, nak$internal_connection_mgmt);
    osp$push_inhibit_job_recovery;
    nlp$get_exclusive_access (nav$switched_connections_list.access_control);
    switched_connection := nav$switched_connections_list.switched_connection;
    previous_switched_connection := ^nav$switched_connections_list.switched_connection;
    WHILE (switched_connection <> NIL) AND (switched_connection^.connection_id <> connection_id) DO
      previous_switched_connection := ^switched_connection^.next_entry;
      switched_connection := switched_connection^.next_entry;
    WHILEND;

    IF switched_connection = NIL THEN
      osp$set_status_abnormal (nac$status_id, nae$no_switch_offer_pending, 'on this file', status);
    ELSE
      switch_complete := switched_connection^.switch_status = nac$switch_complete;
      previous_switched_connection^ := switched_connection^.next_entry;
      FREE switched_connection IN nav$network_paged_heap^;
    IFEND;

    nlp$release_exclusive_access (nav$switched_connections_list.access_control);
    osp$pop_inhibit_job_recovery;
    #keypoint (osk$exit, osk$m * amk_cancel_switch_offer, nak$internal_connection_mgmt);

  PROCEND nlp$cancel_switch_offer;
?? TITLE := 'NLP$OFFER_CONNECTION_SWITCH', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$offer_connection_switch (file: fst$file_reference;
        destination: jmt$system_supplied_name;
        timesharing_connection_switch: boolean;
    VAR status: ost$status);

{ The purpose of this procedure is to switch a connection from the currently
{ executing job to the destination job. The file associated with the connection
{ is marked. The switch request is rejected if the file has outstanding instances
{ of open.


    VAR
      application: nat$application_name,
      connection_id: nat$connection_id,
      ignore_status: ost$status,
      new_switched_connection: ^nat$switched_connection,
      previous_switched_connection: ^^nat$switched_connection,
      previous_wait_for_switch_offer: ^^nat$wait_for_switch_offer,
      source_job_name: jmt$system_supplied_name,
      switched_connection: ^nat$switched_connection,
      user_supplied_name: jmt$user_supplied_name,
      wait_for_switch_offer: ^nat$wait_for_switch_offer;

    IF (NOT jmv$executing_within_system_job) AND (NOT osp$is_caller_system_privileged()) THEN
      osp$set_status_abnormal ('NA',nae$insufficient_privilege,
            'nlp$offer_connection_switch',status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    #keypoint (osk$entry, osk$m * amk_offer_connection_switch, nak$internal_connection_mgmt);
    nap$set_switch_offer (file, timesharing_connection_switch, connection_id, application, status);
    IF status.normal THEN
      osp$push_inhibit_job_recovery;
      nlp$get_exclusive_access (nav$switched_connections_list.access_control);
      REPEAT
        ALLOCATE new_switched_connection IN nav$network_paged_heap^;
        IF new_switched_connection = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL new_switched_connection <> NIL;
      new_switched_connection^.destination_job_name := destination;
      pmp$get_job_names (user_supplied_name, source_job_name, status);
      new_switched_connection^.source_job_name := source_job_name;
      new_switched_connection^.application := application;
      new_switched_connection^.switch_status := nac$switch_pending;
      new_switched_connection^.wait_for_switch_accept.index := 0;
      new_switched_connection^.connection_id := connection_id;
      new_switched_connection^.next_entry := nav$switched_connections_list.switched_connection;
      nav$switched_connections_list.switched_connection := new_switched_connection;

{  Search wait_for_switch_offer queue for the waiting job, and if found
{  ready the waiting task.

      wait_for_switch_offer := nav$switched_connections_list.wait_for_switch_offer;
      previous_wait_for_switch_offer := ^nav$switched_connections_list.wait_for_switch_offer;

      WHILE (wait_for_switch_offer <> NIL) AND ((wait_for_switch_offer^.source_job_name <> source_job_name) OR
            (wait_for_switch_offer^.destination_job_name <> destination)) DO
        previous_wait_for_switch_offer := ^wait_for_switch_offer^.next_entry;
        wait_for_switch_offer := wait_for_switch_offer^.next_entry;
      WHILEND;

      IF wait_for_switch_offer <> NIL THEN
        previous_wait_for_switch_offer^ := wait_for_switch_offer^.next_entry;
        pmp$ready_task (wait_for_switch_offer^.destination_task_id, ignore_status);
        FREE wait_for_switch_offer IN nav$network_paged_heap^;
      IFEND;

      nlp$release_exclusive_access (nav$switched_connections_list.access_control);
      osp$pop_inhibit_job_recovery;

{ The intent of checking for the status condition nae$system_interrupt is to allow
{ the switch to act as though the switch has been started.

    ELSEIF (NOT status.normal) AND (status.condition = nae$system_interrupt) THEN
      status.normal := TRUE;
    IFEND;
    #keypoint (osk$exit, osk$m * amk_offer_connection_switch, nak$internal_connection_mgmt);

  PROCEND nlp$offer_connection_switch;
?? TITLE := 'NLP$REQUEST_CONNECTION', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$request_connection (server: nat$network_address;
        client: nat$application_name;
        file: fst$file_reference;
        protocol: nat$protocol;
        attributes: ^nat$create_attributes;
    VAR status: ost$status);

    VAR
      client_attributes: ^nat$client_attributes,
      connection_id: nat$connection_id,
      client_connection: ^nat$client_connection_attribute;

{ This procedure will execute in the user task.

    IF (NOT jmv$executing_within_system_job) AND (NOT osp$is_caller_system_privileged()) THEN
      osp$set_status_abnormal ('NA',nae$insufficient_privilege,
            'nlp$request_connection',status);
      RETURN;
    IFEND;

    IF NOT nav$namve_active THEN
      osp$set_status_condition ( nae$network_inactive,  status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    #keypoint (osk$entry, osk$m * amk_request_connection, nak$internal_connection_mgmt);
    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    nlp$get_nonexclusive_access (nav$client_attributes_list.access_control);
    nap$find_client_attributes (client, client_attributes);
    IF client_attributes = NIL THEN
      osp$set_status_abnormal (nac$status_id, nae$unknown_application, client, status);
    ELSE
      nlp$get_exclusive_access (client_attributes^.access_control);
      nap$validate_user (client_attributes^.client_capability, client_attributes^.client_ring,
            client_attributes^.client_system_privilege, status);
      IF NOT status.normal THEN
{ Client not authorized for this request.
        osp$set_status_abnormal (nac$status_id, nae$unknown_application, client, status);
      ELSE
        IF client_attributes^.client_status = nac$application_inactive THEN
          osp$set_status_abnormal (nac$status_id, nae$application_inactive, client, status);
        ELSE
          client_attributes^.attempted_connection_count := client_attributes^.
                attempted_connection_count + 1;
          IF client_attributes^.connection_count >= client_attributes^.max_connections THEN
            client_attributes^.rejected_connection_attempts := client_attributes^.
                  rejected_connection_attempts + 1;
            osp$set_status_abnormal (nac$status_id, nae$application_max_conn_limit, client, status);
          ELSE
            IF (server.kind = nac$internet_address) OR (server.kind = nac$osi_transport_address) THEN
              IF client_attributes^.protocol = protocol THEN
                client_attributes^.connection_count := client_attributes^.connection_count + 1;
                nlp$release_exclusive_access (client_attributes^.access_control);
                nap$se_request_connection (client_attributes^.application_id, server, client, file,
                      attributes, client_attributes^.message_priority, connection_id, status);
                nlp$get_exclusive_access (client_attributes^.access_control);
                IF status.normal THEN
                  REPEAT
                    ALLOCATE client_connection IN nav$network_paged_heap^;
                    IF client_connection = NIL THEN
                      syp$cycle;
                    IFEND;
                  UNTIL client_connection <> NIL;
                  client_connection^.next_entry := client_attributes^.client_connections_list;
                  client_connection^.connection_id := connection_id;
                  client_attributes^.client_connections_list := client_connection;
                ELSE
                  client_attributes^.connection_count := client_attributes^.connection_count - 1;
                IFEND;
              ELSEIF (protocol = nac$cdna_session) OR (protocol = nac$cdna_virtual_terminal) THEN
                osp$set_status_abnormal (nac$status_id, nae$client_protocol_mismatch,
                      'CONNECTION', status);
              ELSE
                osp$set_status_condition ( nae$unknown_protocol,  status);
              IFEND;
            ELSEIF server.kind = nac$system_address THEN
              osp$set_status_condition ( nae$address_protocol_mismatch,  status);
            ELSE
              osp$set_status_condition ( nae$unknown_address_kind,  status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      nlp$release_exclusive_access (client_attributes^.access_control);
    IFEND;

    nlp$release_nonexclusive_access (nav$client_attributes_list.access_control);
    osp$end_subsystem_activity;
    osp$pop_inhibit_job_recovery;
    #keypoint (osk$exit, osk$m * amk_request_connection, nak$internal_connection_mgmt);
  PROCEND nlp$request_connection;
?? TITLE := 'ATTRIBUTE_SPECIFIED', EJECT ??

  FUNCTION [INLINE] attribute_specified (attributes: ^nat$create_attributes;
        attribute: nat$connection_attribute_kind):boolean;

    VAR
      i: integer;

    IF attributes <> NIL THEN
      i := LOWERBOUND (attributes^);
      WHILE (i <= UPPERBOUND (attributes^)) AND (attributes^ [i].kind <> attribute) DO
        i := i + 1;
      WHILEND;
      attribute_specified := i <= UPPERBOUND (attributes^);
    ELSE
      attribute_specified := FALSE;
    IFEND;

  FUNCEND attribute_specified;
?? TITLE := 'UPDATE_APPLICATION_CONNECTION', EJECT ??

  PROCEDURE [INLINE] update_application_connection (application: nat$application_name;
        source_job: jmt$system_supplied_name;
        connection_id: nat$connection_id);

{ The purpose of this procedure is to verify that the given application name is
{ known to application mgmt. If the connection belongs to a server application
{ job, it is retained as a server connection i.e it now belongs to the given
{ server application and not to a specific job.


    VAR
      server_job_attributes: ^nat$server_job_attributes,
      i: integer,
      ignore_status: ost$status,
      server_attributes: ^nat$server_attributes,
      server_connection: ^nat$server_connection_attribute;


    nlp$get_nonexclusive_access (nav$server_attributes_list.access_control);
    nap$find_server_attributes (application, server_attributes);
    IF server_attributes <> NIL THEN
      nlp$get_exclusive_access (server_attributes^.access_control);
      server_job_attributes := server_attributes^.server_job_list;
      WHILE (server_job_attributes <> NIL) AND (server_job_attributes^.job_name <> source_job) DO
        server_job_attributes := server_job_attributes^.next_entry;
      WHILEND;

      IF server_job_attributes <> NIL THEN
        server_connection := server_attributes^.server_connections_list;

      /search/
        WHILE server_connection <> NIL DO
          IF server_connection^.connection_id = connection_id THEN

{ Change the connection from a job to a server connection.
            IF (server_connection^.connection_kind = nac$owned_by_job) AND (server_connection^.job_name
                = source_job) THEN
              server_connection^.connection_kind := nac$owned_by_server;
              server_job_attributes^.connection_count := server_job_attributes^.connection_count - 1;
            IFEND;
            EXIT /search/;
          IFEND;
          server_connection := server_connection^.next_entry;
        WHILEND /search/;
      IFEND;

      nlp$release_exclusive_access (server_attributes^.access_control);
    IFEND;
    nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);

  PROCEND update_application_connection;
?? TITLE := 'ACQUIRE_CONNECTION', EJECT ??

  PROCEDURE acquire_connection
    (    system_job_name: jmt$system_supplied_name;
         server: nat$application_name;
         file: fst$file_reference;
         file_exists: boolean;
         attributes: ^nat$create_attributes;
     VAR status: ost$status);

    VAR
      acquire_in_progress: ^nat$server_connection_attribute,
      assigned_connection: ^nat$server_connection_attribute,
      connection_id: nat$connection_id,
      connection_released: boolean,
      i: integer,
      ignore_status: ost$status,
      previous_acquire_in_progress: ^^nat$server_connection_attribute,
      previous_assigned_connection: ^^nat$server_connection_attribute,
      server_attributes: ^nat$server_attributes,
      server_connection: ^nat$server_connection_attribute,
      server_job_attributes: ^nat$server_job_attributes;


    status.normal := TRUE;

    nap$find_server_attributes (server, server_attributes);
    IF server_attributes = NIL THEN

{ Unknown server.

      osp$set_status_abnormal (nac$status_id, nae$server_not_attached, server, status);
    ELSE

    /exclusive_lock_domain/
      BEGIN
        nlp$get_exclusive_access (server_attributes^.access_control);
        nap$validate_user (server_attributes^.server_capability, server_attributes^.server_ring,
              server_attributes^.server_system_privilege, status);
        IF NOT status.normal THEN

{ Server not authorized for this request.

          osp$set_status_abnormal (nac$status_id, nae$unknown_application, server, status);
        ELSE
          IF server_attributes^.server_status = nac$application_inactive THEN
            osp$set_status_abnormal (nac$status_id, nae$application_inactive, server, status);
          ELSE
            server_job_attributes := server_attributes^.server_job_list;
            WHILE (server_job_attributes <> NIL) AND (server_job_attributes^.job_name <> system_job_name) DO
              server_job_attributes := server_job_attributes^.next_entry;
            WHILEND;

            IF server_job_attributes = NIL THEN

{ Server not attached.

              osp$set_status_abnormal (nac$status_id, nae$server_not_attached, server, status);
            ELSE
              IF server_job_attributes^.connection_count >= server_job_attributes^.
                    max_connections_per_server_job THEN

{          Job has already acquired max connections.

                osp$set_status_abnormal (nac$status_id, nae$max_connections_acquired, system_job_name,
                      status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        IF status.normal THEN
          previous_assigned_connection := ^server_attributes^.assigned_connections_list;
          assigned_connection := server_attributes^.assigned_connections_list;

          WHILE (assigned_connection <> NIL) AND (assigned_connection^.directed_connection) AND
                (assigned_connection^.destination_job_name <> system_job_name) DO
            previous_assigned_connection := ^assigned_connection^.next_entry;
            assigned_connection := assigned_connection^.next_entry;
          WHILEND;

          IF assigned_connection <> NIL THEN
            IF (server_attributes^.accept_connection) AND (attribute_specified (attributes, nac$connect_data))
                  THEN

{ Connect_data attribute may not be specified if connection has already been accepted.

              osp$set_status_condition ( nae$invalid_connect_data_change,  status);
            ELSE

{ Move connection from the assigned connections queue to the acquire in progress queue.

              connection_id := assigned_connection^.connection_id;
              previous_assigned_connection^ := assigned_connection^.next_entry;
              assigned_connection^.next_entry := server_attributes^.acquire_in_progress;
              server_attributes^.acquire_in_progress := assigned_connection;

{ Update the connection count for the server job.

              server_job_attributes^.connection_count := server_job_attributes^.connection_count + 1;
              IF assigned_connection^.directed_connection THEN
                server_job_attributes^.assigned_connection_count :=
                      server_job_attributes^.assigned_connection_count - 1;
              IFEND;

              nlp$release_exclusive_access (server_attributes^.access_control);
              nap$create_network_file (file, attributes, connection_id, file_exists, status);

{ Since the global non exclusive lock to the server attributes list is not released, the server
{ cannot be deleted in the meantime.

              nlp$get_exclusive_access (server_attributes^.access_control);
              acquire_in_progress := server_attributes^.acquire_in_progress;
              previous_acquire_in_progress := ^server_attributes^.acquire_in_progress;
              WHILE (acquire_in_progress <> NIL) AND (acquire_in_progress^.connection_id <> connection_id) DO
                previous_acquire_in_progress := ^acquire_in_progress^.next_entry;
                acquire_in_progress := acquire_in_progress^.next_entry;
              WHILEND;

{ The resulting acquire_in_progress cannot be NIL. If it is NIL, it is a BUG.

              IF acquire_in_progress <> NIL THEN
                previous_acquire_in_progress^ := acquire_in_progress^.next_entry;
                IF NOT acquire_in_progress^.terminate_connection THEN
                  IF status.normal THEN
                    server_connection := acquire_in_progress;
                    server_connection^.next_entry := server_attributes^.server_connections_list;
                    server_connection^.connection_kind := nac$owned_by_job;
                    server_connection^.job_name := system_job_name;
                    server_attributes^.server_connections_list := server_connection;
                  ELSE

{ Requeue the connection in the assigned connections list.

                    acquire_in_progress^.next_entry := server_attributes^.assigned_connections_list;
                    server_attributes^.assigned_connections_list := acquire_in_progress;

{ Update the connection count for the server job.

                    server_job_attributes^.connection_count := server_job_attributes^.connection_count - 1;
                    IF acquire_in_progress^.directed_connection THEN
                      server_job_attributes^.assigned_connection_count :=
                            server_job_attributes^.assigned_connection_count + 1;
                    IFEND;
                  IFEND;
                ELSE { Connection has been terminate by deactivate server request }

{ Update the connection count for the server.

                  server_job_attributes^.connection_count := server_job_attributes^.connection_count - 1;
                  server_attributes^.connection_count := server_attributes^.connection_count - 1;
                  FREE acquire_in_progress IN nav$network_paged_heap^;
                  IF status.normal THEN
                    IF server_attributes^.server_status = nac$application_inactive THEN
                      osp$set_status_abnormal (nac$status_id, nae$application_inactive, server, status);
                    ELSE

{ Server may have been deactivated and then activated again.

                      osp$set_status_abnormal (nac$status_id, nae$no_connection_available, server, status);
                    IFEND;
                    nlp$release_exclusive_access (server_attributes^.access_control);
                    amp$return (file, ignore_status);
                    EXIT /exclusive_lock_domain/;
                  ELSE { no file }
                    nap$se_terminate_connection (connection_id, nac$application_deactivated, FALSE,
                          connection_released, ignore_status);
                  IFEND;
                IFEND;
              ELSE

{ Should never end up here.

                nlp$release_exclusive_access (server_attributes^.access_control);
                nlp$release_nonexclusive_access (nav$server_attributes_list.access_control);
                osp$end_subsystem_activity;
                nap$namve_system_error (FALSE, 'Connection disappeared from the acquire in progress Q.', NIL);
              IFEND;
            IFEND;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$no_connection_available, server, status);
          IFEND;
        IFEND;

        nlp$release_exclusive_access (server_attributes^.access_control);
      END /exclusive_lock_domain/;
    IFEND;

  PROCEND acquire_connection;
?? TITLE := 'DECREMENT_ASSIGNED_CONN_COUNT', EJECT ??

  PROCEDURE decrement_assigned_conn_count (server_attributes: ^nat$server_attributes;
        job_name: jmt$system_supplied_name);

    VAR
      server_job_attributes: ^nat$server_job_attributes,
      local_status: ost$status;

    server_job_attributes := server_attributes^.server_job_list;
    WHILE (server_job_attributes <> NIL) AND (server_job_attributes^.job_name <> job_name) DO
      server_job_attributes := server_job_attributes^.next_entry;
    WHILEND;

    IF server_job_attributes = NIL THEN
{ THis would happen if the job the connection was directed to terminated
{ without acquiring a connection.
    ELSE
      server_job_attributes^.assigned_connection_count := server_job_attributes^.assigned_connection_count -
            1;
    IFEND;

  PROCEND decrement_assigned_conn_count;
*copyc nap$find_client_attributes
*copyc nap$find_server_attributes
*copyc nap$validate_user
*copyc nlp$get_exclusive_access
*copyc nlp$get_nonexclusive_access
*copyc nlp$release_exclusive_access
*copyc nlp$release_nonexclusive_access
MODEND nam$internal_connection_mgmt;
*DECK DECK=NAM$INTRANET_LAYER_MGMT_R1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access : Intranet Layer Mgmt R1' ??
MODULE nam$intranet_layer_mgmt_r1;
{
{ PURPOSE:
{         The purpose of this module is to provide support in ring 1 for the
{         INTRANET LAYER MGMT FUNCTIONS.
{
{ DESIGN:
{         This module is designed to reside in OSF$SYSTEM_CORE_113 library.
{         It contains procedures to queue dump requests on the unit i/f table,
{         flush unit queues and to free request blocks in the mainframe wired
{         segment. These procedures can run only in ring 1 as they reference
{         mainframe wired segment and need to call procedures that execute in
{         ring 1. These procedures execute in the intranet layer mgmt task only.
{         This module also contains procedures which support the Change_Nam_Attrbutes
{         and Display_Nam_Attributes commands. These procedures need to access
{         global variables that reside in mainframe wired.
{
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ioc$unsolicited_response_codes
*copyc iot$command
*copyc iot$io_request
*copyc iot$logical_unit
*copyc iot$unit_interface_table
*copyc nak$ilmt_keypoints_job_mode
*copyc nat$ilmt_keypoint_constants
*copyc nat$monitor_request_block
*copyc nat$nam_attributes
*copyc nat$request_block_list
*copyc nlc$nam_configuration_constants
*copyc nlt$master_control_table
*copyc nlt$network_device
*copyc osc$purge_map_and_cache
*copyc ost$hardware_subranges
*copyc ost$signature_lock
*copyc syc$monitor_request_codes
?? POP ??
*copyc i#call_monitor
*copyc nap$free_request_block
*copyc nap$get_request_block
*copyc osp$fetch_locked_variable
*copyc syp$cycle
*copyc cmv$logical_unit_table
*copyc nav$network_paged_heap
*copyc nav$network_response_processor
*copyc nlv$cl_connections
*copyc nlv$maximum_system_connections
*copyc nlv$pp_buffer
*copyc nlv$pp_send_queue_tails
*copyc oss$mainframe_paged_literal
*copyc osv$mainframe_wired_cb_heap
*copyc osv$page_size
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
    VAR
      clear_lockword: [READ, OSS$MAINFRAME_PAGED_LITERAL] iot$lockword := [FALSE, 0, [FALSE, 0, 0]],
      set_lockword: [READ, OSS$MAINFRAME_PAGED_LITERAL] iot$lockword := [TRUE, 0, [TRUE, FALSE,
        0, 0]];


?? OLDTITLE ??
?? NEWTITLE := 'nap$flush_unit_queue', EJECT ??
*copy nah$flush_unit_queue
  PROCEDURE [XDCL, #GATE] nap$flush_unit_queue
    (    network_device: ^nlt$network_device;
     VAR message_id_array: ^array [1 .. * ] of nlt$bm_message_id);

    VAR
      actual: nlt$pp_send_queue_tail,
      cs_status: osc$cs_successful .. osc$cs_variable_locked,
      current: nlt$pp_send_queue_tail,
      end_of_queue: boolean,
      first_request: ost$real_memory_address,
      index: integer,
      local_status: ost$status,
      master_control_table: ^nlt$master_control_table,
      message_id_count: integer,
      new: nlt$pp_send_queue_tail,
      next_request_block: ^nat$request_block,
      queue: nlt$cc_connection_class,
      request_block: ^nat$request_block;


    #keypoint (osk$entry, osk$m * ilmk_flush_unit_queue, nak$intranet_layer_mgmt_r1);
    master_control_table := #LOC(cmv$logical_unit_table^ [network_device^.logical_unit].
           unit_communication_buffer_pva^);

    message_id_count := 0;
    message_id_array := NIL;
    FOR queue := nlc$cc_normal_class TO nlc$cc_priority_class DO
      current.send_queue_tail := NIL;
      new := current;
      REPEAT
        #compare_swap (nlv$pp_send_queue_tails^ [network_device^.device_id] [queue],
              current, new, actual, cs_status);
      UNTIL cs_status <> osc$cs_variable_locked;

      request_block := actual.send_queue_tail;

{ Calculate the number of message_ids in the queue. The CPU scans the
{ queue from the tail backward. The requests are chained via a backward
{ link that is not terminated by a NIL. Rather, the end of the chain is
{ discovered by comparing the pointer of the current request to that of
{ the first request in the queue.

      IF request_block <> NIL THEN
        end_of_queue := FALSE;
        first_request := master_control_table^.request_queues [queue].request_rma;
        WHILE (NOT end_of_queue) DO
          IF request_block^.network_request.message_id.descriptor <> NIL THEN
            message_id_count := message_id_count + 1;
          IFEND;
          IF request_block^.peripheral_request_rma = first_request THEN
            end_of_queue := TRUE;
          ELSE
            request_block := request_block^.network_request.request_block_link;
          IFEND;
        WHILEND;
      IFEND;
    FOREND;

    IF message_id_count > 0 THEN

{  Note: The message_id_array will be released by the PROC flush_unit_queue
{  in nam$intranet_layer_mgmt_r3.

      REPEAT
        ALLOCATE message_id_array: [1 .. message_id_count] IN nav$network_paged_heap^;
        IF message_id_array = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL message_id_array <> NIL;
    IFEND;

    index := 1;
    FOR queue := nlc$cc_normal_class TO nlc$cc_priority_class DO
      request_block := NIL;
      current.send_queue_tail := NIL;
      current.fill := 0;
      new := current;
      REPEAT
        #compare_swap (nlv$pp_send_queue_tails^ [network_device^.device_id] [queue],
              current, new, actual, cs_status);
        IF cs_status = osc$cs_failed THEN
          current := actual;
        IFEND;
      UNTIL cs_status = osc$cs_successful;
      request_block := actual.send_queue_tail;

      first_request := master_control_table^.request_queues [queue].request_rma;
      master_control_table^.request_queues [queue].request_rma := 0;
      master_control_table^.request_queues [queue].request_length := 0;

{ Place the message ids associated with the requests in the message_id_array.
{ The CPU scans the queue exactly as before.

      IF request_block <> NIL THEN
        end_of_queue := FALSE;
        WHILE (NOT end_of_queue) DO
          IF request_block^.network_request.message_id.descriptor <> NIL THEN
            message_id_array^ [index] := request_block^.network_request.message_id;
            index := index + 1;
          IFEND;
          IF request_block^.peripheral_request_rma = first_request THEN
            end_of_queue := TRUE;
          ELSE
            next_request_block := request_block^.network_request.request_block_link;
          IFEND;
          nap$free_request_block (request_block);
          IF NOT end_of_queue THEN
            request_block := next_request_block;
          IFEND;
        WHILEND;
      IFEND;
    FOREND;
    #keypoint (osk$exit, osk$m * ilmk_flush_unit_queue, nak$intranet_layer_mgmt_r1);
  PROCEND nap$flush_unit_queue;
?? OLDTITLE ??
?? NEWTITLE := 'nap$change_nam_attributes_r1', EJECT ??
*copy nah$change_nam_attributes_r1
  PROCEDURE [XDCL, #GATE] nap$change_nam_attributes_r1 (
        attribute_kind: nat$nam_attribute_kind;
        attribute: nat$nam_attribute);

    CASE attribute_kind OF
    = nac$max_connections_attr =
      nlv$maximum_system_connections := attribute.maximum_connections;
    ELSE
    CASEND;

  PROCEND nap$change_nam_attributes_r1;
?? OLDTITLE ??
?? NEWTITLE := 'nap$get_nam_attributes_r1', EJECT ??
*copy nah$get_nam_attributes_r1
  PROCEDURE [XDCL, #GATE] nap$get_nam_attributes_r1 (
        attribute_kind: nat$nam_attribute_kind;
    VAR attribute: nat$nam_attribute);


    VAR
      current_connections: integer;

    CASE attribute_kind OF
    = nac$max_connections_attr =
      attribute.maximum_connections := nlv$maximum_system_connections;

    = nac$current_connections_status =
      osp$fetch_locked_variable (nlv$cl_connections.active, current_connections);
      attribute.current_connections := current_connections;
    ELSE
    CASEND;

  PROCEND nap$get_nam_attributes_r1;
?? OLDTITLE ??
?? NEWTITLE := 'nap$build_master_control_table', EJECT ??
*copy nah$build_master_control_table
  PROCEDURE [XDCL, #GATE] nap$build_master_control_table
    (    logical_unit: iot$logical_unit;
         device_id: nlt$device_identifier);

    VAR
      last_request_rma: integer,
      master_control_table: ^nlt$master_control_table,
      pool: 0 .. 0ff(16),
      pp_pool_headers: integer,
      queue: nlt$cc_connection_class,
      unit_communication_buffer_seq: ^iot$unit_communication_buffer;

{ It is assumed that the unit communication buffer has been zeroed out
{ by configuration management.

    unit_communication_buffer_seq := cmv$logical_unit_table^ [logical_unit].
           unit_communication_buffer_pva;
    RESET unit_communication_buffer_seq;
    NEXT master_control_table IN unit_communication_buffer_seq;
    master_control_table^.device_id := device_id;
    FOR queue := nlc$cc_normal_class TO nlc$cc_priority_class DO
{     master_control_table^.request_queues [queue].request_rma := 0;
{     master_control_table^.request_queues [queue].request_length := 0;
      i#real_memory_address (#LOC (nlv$pp_send_queue_tails^ [device_id] [queue]),
            last_request_rma);
      master_control_table^.request_queues [queue].last_request := last_request_rma;
    FOREND;

    i#real_memory_address (#LOC (nlv$pp_buffer^.pool_header), pp_pool_headers);
    master_control_table^.buffer_pool_headers := pp_pool_headers;

    master_control_table^.initialized := TRUE;

  PROCEND nap$build_master_control_table;
?? OLDTITLE ??
MODEND nam$intranet_layer_mgmt_r1;

*DECK DECK=NAM$INTRANET_LAYER_MGMT_R3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access : Intranet Layer Management R3' ??
?? NEWTITLE := 'Global Declarations Referenced by This Module' ??
MODULE nam$intranet_layer_mgmt_r3;

{
{ PURPOSE:
{         The purpose of this module is to provide support in ring 3 for INTRANET
{         LAYER MGMT FUNCTIONS.
{
{ DESIGN:
{         This module is designed to reside in OSF$JOB_TEMPLATE_23D library.
{         It contains code that runs in the system job except for the i/f to
{         change ica state which can also be invoked in a user task. It contains
{         the procedures that execute in the intranet layer mgmt task.
{

?? PUSH (LISTEXT := ON) ??
*copyc cme$reserve_element
*copyc cme$physical_configuration_mgr
*copyc cml$ica_failure_data
*copyc cml$ica_usage_data
*copyc cml$ivb_failure_data
*copyc cml$ivb_usage_data
*copyc cml$mdi_failure_data
*copyc cml$mdi_usage_data
*copyc cmt$element_definition
*copyc cmt$element_descriptor
*copyc cmt$hardware_address
*copyc cmt$physical_equipment_number
*copyc cmt$physical_identification
*copyc cmt$pp_program_description
*copyc cmt$pp_identification
*copyc cmt$element_reservation
*copyc ioc$unsolicited_response_codes
*copyc nae$ica_conditions
*copyc nak$ilmt_keypoints_job_mode
*copyc nat$ica_log_msg_constants
*copyc nat$ivb_log_msg_constants
*copyc nat$mdi_log_msg_constants
*copyc nat$ica_pp_log_response
*copyc nat$ivb_pp_log_response
*copyc nat$mdi_pp_log_response
*copyc nat$ilmt_keypoint_constants
*copyc nat$network_driver_response
*copyc nat$device_type
*copyc nat$request_block_list
*copyc nlc$bm_small_buffer_size
*copyc nlt$network_device
*copyc nlt$network_device_list
*copyc ost$global_task_id
*copyc pmt$program_name
*copyc pmt$program_parameters
?? POP ??
*copyc cmp$convert_channel_ordinal
*copyc cmp$get_element_type
*copyc pmp$get_mainframe_id
*copyc cmp$search_pp_table
*copyc cmp$convert_pp_ordinal
*copyc cmp$convert_iou_name
*copyc cmp$execute_pp_program
*copyc cmp$get_logical_unit_number
*copyc cmp$pc_get_element
*copyc cmp$process_state_change
*copyc cmp$reserve_element
*copyc cmp$release_element
*copyc cmp$return_desc_data_by_lun_lpn
*copyc dpp$put_critical_message
*copyc nap$build_master_control_table
*copyc nap$compute_ethernet_checksum
*copyc nap$display_message
*copyc nap$flush_unit_queue
*copyc nap$idle_pp
*copyc nap$issue_pp_request
*copyc nap$namve_system_error
*copyc nlp$bm_release_messages
*copyc nlp$cc_terminate_connections
*copyc nlp$get_exclusive_access
*copyc nlp$get_nonexclusive_access
*copyc nlp$release_exclusive_access
*copyc nlp$release_nonexclusive_access
*copyc osp$append_status_integer
*copyc osp$set_status_abnormal
*copyc pmp$get_executing_task_gtid
*copyc pmp$ready_task
*copyc pmp$wait
*copyc sfp$emit_statistic
*copyc tmp$save_system_task_id
*copyc jmv$executing_within_system_job
*copyc nav$ica_reset_down_threshold
*copyc nav$intranet_layer_mgmt_taskid
*copyc nav$intranet_mgmt_timer_active
*copyc nav$intranet_mgmt_work_list
*copyc nav$mci_reset_down_threshold
*copyc nav$namve_active
*copyc nav$network_paged_heap
*copyc nlv$bm_large_buffer_size
*copyc nlv$configured_network_devices
*copyc nlv$device_usage_data
*copyc osv$page_size
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    null_counter = -1;

  TYPE
    channel_counter = packed record
      channel_error_status: 0 .. 0ffff(16),
      fill: 0 .. 3fffffff(16),
      iou: 0 .. 3f(16),
      fill1: 0 .. 1f(16),
      concurrent: boolean,
      fill2: 0 .. 1,
      channel: ost$physical_channel_number,
    recend,

    network_device_log_reason = (device_reset_down_thresh_exceed, device_reset_timeout),

    operational_device_attributes = record
      channel_interface_protocol: nlt$channel_interface_protocol,
      fill: 0 .. 0ffff(16),
      maximum_pdu_size: nlt$cc_pdu_size,
      system_id: nat$system_identifier,
    recend,

    pp_counter = packed record
      fill: 0 .. 3fffffffffff(16),
      iou: 0 .. 3f(16),
      fill1: 0 .. 1f(16),
      concurrent: boolean,
      pp: 0 .. 03f(16),
    recend;


  CONST
    max_ica_2_down_time = 60000000, { 60 seconds in micro sec }
    log_msg_interval = 30 * 60 * 1000000, { 30 min in micro sec }
    max_symptom_length = 80,
    ten_min = 600000000, { 10 min in micro sec }
    nac$communication_buffer_size = 4096;

?? OLDTITLE ??
?? NEWTITLE := 'nap$change_network_device_state', EJECT ??

  PROCEDURE [XDCL] nap$change_network_device_state
    (    element: cmt$element_name;
         new_state: cmt$element_state;
         old_state: cmt$element_state;
     VAR status: ost$status);

*copyc nah$change_network_device_state

    VAR
      executing_taskid: ost$global_task_id,
      network_device: ^nlt$network_device;

    #KEYPOINT (osk$entry, osk$m * ilmk_change_net_device_state, nak$intranet_layer_mgmt_r3);

  /main_block/
    BEGIN

      status.normal := TRUE;
      IF NOT nav$namve_active THEN
        RETURN;
      IFEND;

      nlp$get_exclusive_access (nlv$configured_network_devices.access_control);
      get_network_device (element, network_device);
      IF network_device = NIL THEN
        osp$set_status_abnormal (nac$status_id, nae$unknown_element, element, status);
        EXIT /main_block/;
      IFEND;

      pmp$get_executing_task_gtid (executing_taskid);

{      IF (network_device^.state = nlc$state_change_pending) AND
{            (executing_taskid <> nav$intranet_layer_mgmt_taskid) THEN
{        osp$set_status_abnormal (nac$status_id, nae$state_change_in_progress, element, status);
{        EXIT /main_block/;
{      IFEND;

      CASE new_state OF
      = cmc$off, cmc$down =

        IF executing_taskid <> nav$intranet_layer_mgmt_taskid THEN

{ If the task switch is initiated by the INTRANET_MGMT_TASK, it is assumed
{ that the network PP has been idled. When invoked in a user task, the PP is
{ idled and the task waits for the PP queues to be flushed. The intranet layer
{ mgmt task flushes the queues on receipt of the idle response from the PP
{ and readies the waiting user task.

          nap$idle_pp (network_device^.pp_number);
          network_device^.state := nlc$state_change_pending;
          network_device^.task_waiting_for_state_change := executing_taskid;
          network_device^.path_status := nlc$path_unavailable;

          REPEAT
            nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
            pmp$wait (2000, 2000);
            nlp$get_exclusive_access (nlv$configured_network_devices.access_control);
            get_network_device (element, network_device);
            IF network_device = NIL THEN
              nap$namve_system_error (FALSE, 'Network Device deconfigured.', NIL);
            IFEND;
          UNTIL network_device^.task_waiting_for_state_change.index = 0;
        IFEND;

        nap$return_network_elements (network_device^.element, network_device^.channel,
              network_device^.pp_identification);

        network_device^.path_status := nlc$path_down;
        network_device^.logical_unit := 0;

        network_device^.reset_down_count := 0;
        network_device^.reset_down_count_intervl := 0;

      = cmc$on =

        nap$reserve_network_elements (network_device^.element, network_device^.channel,
              network_device^.channel_address, network_device^.driver_name, network_device^.logical_unit,
              network_device^.pp_identification, network_device^.pp_number, status);
        IF status.normal THEN
          nap$build_master_control_table (network_device^.logical_unit, network_device^.device_id);
          nap$initialize_network_pp (network_device);
          network_device^.path_status := nlc$path_unavailable;
        IFEND;

      ELSE
      CASEND;

      IF network_device^.path_status <> nlc$path_down THEN

{ Activate timers.

        network_device^.reset_down_count := 0;
        network_device^.reset_down_count_intervl := #FREE_RUNNING_CLOCK (0) + ten_min;
        network_device^.reset_timestamp := #FREE_RUNNING_CLOCK (0);
        nav$intranet_mgmt_timer_active := TRUE;
      IFEND;
      network_device^.state := nlc$normal;

    END /main_block/;

    #KEYPOINT (osk$exit, osk$m * ilmk_change_net_device_state, nak$intranet_layer_mgmt_r3);

    nlp$release_exclusive_access (nlv$configured_network_devices.access_control);

  PROCEND nap$change_network_device_state;
?? OLDTITLE ??
?? NEWTITLE := 'nap$initialize_network_pp', EJECT ??

  PROCEDURE [XDCL] nap$initialize_network_pp
    (    network_device: ^nlt$network_device);

{ The purpose of this procedure is to communicate all the required addresses to
{ the network PP. This request is issued after the PP has been deadstarted.

    VAR
      command: iot$command,
      ethernet_address: nlt$ethernet_addr_and_checksum,
      real_memory_address: integer;

    command.flags.store_response := TRUE;

    IF network_device^.kind = nac$ica_2 THEN
      command.flags.indirect_address := TRUE;
      command.command_code := ioc$cc_define_ethernet_address;
      command.length := 0;
      ethernet_address.system_identifier := network_device^.system_id;
      nap$compute_ethernet_checksum (ethernet_address.system_identifier, ethernet_address.checksum);
      nap$issue_pp_request (network_device^.pp_number, command, ^ethernet_address);
    IFEND;

    command.flags.indirect_address := FALSE;
    command.command_code := ioc$cc_resume;
    command.length := 0;
    command.address := 0;
    nap$issue_pp_request (network_device^.pp_number, command, NIL);

  PROCEND nap$initialize_network_pp;
?? OLDTITLE ??
?? NEWTITLE := 'nap$manage_intranet_layer', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$manage_intranet_layer
    (    task_parameters: pmt$program_parameters;
     VAR status: ost$status);

{ This procedure executes in the intranet layer mgmt task. It periodically
{ scans the queue of outstanding PP responses and processes them. In its
{ main loop it also keeps track of the network device reset timers and
{ initiates a state change in case of timer expiration.

    CONST
      long_wait = 30 * 60 * 1000; { 30 min in milli sec }

    VAR
      active_timer_count: integer,
      actual: nat$response_queue_access,
      command: iot$command,
      count: integer,
      cs_status: osc$cs_successful .. osc$cs_variable_locked,
      current_outstanding_response: ^nat$network_driver_response,
      down_timestamp: integer,
      element_access: array [1 .. 1] of cmt$hardware_address,
      element_definition: cmt$element_definition,
      i: integer,
      network_device_list: ^nlt$network_device_list,
      next_network_device: ^nlt$network_device,
      next_outstanding_response: ^nat$network_driver_response,
      new: nat$response_queue_access,
      old: nat$response_queue_access,
      outstanding_response: ^nat$network_driver_response,
      previous_outstanding_response: ^nat$network_driver_response,
      remaining_time: integer,
      program_description: array [1 .. 1] of cmt$pp_program_description,
      wait_time: integer;

    #KEYPOINT (osk$entry, osk$m * ilmk_manage_intranet_layer, nak$intranet_layer_mgmt_r3);

    IF NOT jmv$executing_within_system_job THEN
      RETURN;
    IFEND;

    tmp$save_system_task_id (tmc$stid_intranet_layer_mgmt, FALSE, {ignore} status);
    pmp$get_executing_task_gtid (nav$intranet_layer_mgmt_taskid);
    wait_time := long_wait;
    nav$intranet_mgmt_timer_active := TRUE;

{ Activate timers in all the configured network devices.

    nlp$get_nonexclusive_access (nlv$configured_network_devices.access_control);
    nlv$configured_network_devices.next_log_msg_time := #FREE_RUNNING_CLOCK (0) + log_msg_interval;
    network_device_list := nlv$configured_network_devices.network_device_list;
    FOR i := 1 TO UPPERBOUND (network_device_list^) DO
      IF network_device_list^ [i].path_status <> nlc$path_down THEN
        network_device_list^ [i].reset_down_count_intervl := #FREE_RUNNING_CLOCK (0) + ten_min;
        network_device_list^ [i].reset_timestamp := #FREE_RUNNING_CLOCK (0);
      IFEND;
    FOREND;
    nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);

    WHILE TRUE DO

      IF nav$intranet_mgmt_work_list.outstanding_responses.next_entry <> NIL THEN
        REPEAT

{ Retrieve the entire list of outstanding responses.

          new.sequence := 0;
          new.next_entry := NIL;
          old := new;
          REPEAT
            #COMPARE_SWAP (nav$intranet_mgmt_work_list.outstanding_responses, old, new, actual, cs_status);
            IF cs_status = osc$cs_failed THEN
              old := actual;
              new.sequence := (actual.sequence + 1) MOD 10000(16);
            IFEND;
          UNTIL cs_status = osc$cs_successful;

          outstanding_response := actual.next_entry;
          IF outstanding_response <> NIL THEN

{ Reverse the outstanding response list to process the responses in FIFO order.

            previous_outstanding_response := NIL;
            current_outstanding_response := outstanding_response;
            WHILE current_outstanding_response <> NIL DO
              next_outstanding_response := current_outstanding_response^.next_entry;
              current_outstanding_response^.next_entry := previous_outstanding_response;
              previous_outstanding_response := current_outstanding_response;
              current_outstanding_response := next_outstanding_response;
            WHILEND;
            outstanding_response := previous_outstanding_response;
          IFEND;

          WHILE outstanding_response <> NIL DO

            CASE outstanding_response^.pp_response.response_code.primary_response OF
            = ioc$unsolicited_response =
              process_unsolicited_response (outstanding_response);

            = ioc$normal_response, ioc$abnormal_response =
              process_solicited_response (outstanding_response);

            ELSE
            CASEND;

            next_outstanding_response := outstanding_response^.next_entry;

{ Insert the processed response into the free queue.

            new.sequence := 0;
            new.next_entry := outstanding_response;
            old := new;
            REPEAT
              #COMPARE_SWAP (nav$intranet_mgmt_work_list.free_responses, old, new, actual, cs_status);
              IF cs_status = osc$cs_failed THEN
                old := actual;
                new.sequence := (actual.sequence + 1) MOD 10000(16);
                outstanding_response^.next_entry := actual.next_entry;
              IFEND;
            UNTIL cs_status = osc$cs_successful;

            outstanding_response := next_outstanding_response;
          WHILEND;

        UNTIL nav$intranet_mgmt_work_list.outstanding_responses.next_entry = NIL;

      IFEND;

      wait_time := long_wait;
      IF nav$intranet_mgmt_timer_active THEN

{ Check for expired timers.

        active_timer_count := 0;
        nlp$get_nonexclusive_access (nlv$configured_network_devices.access_control);
        network_device_list := nlv$configured_network_devices.network_device_list;
        FOR i := 1 TO UPPERBOUND (network_device_list^) DO
          IF (network_device_list^ [i].path_status = nlc$path_unavailable) AND
                (network_device_list^ [i].state <> nlc$state_change_pending) AND
                (network_device_list^ [i].kind = nac$ica_2) THEN
            down_timestamp := network_device_list^ [i].reset_timestamp + max_ica_2_down_time;

            remaining_time := (down_timestamp - #FREE_RUNNING_CLOCK (0)) DIV 1000;
            IF remaining_time <= 0 THEN

{ Initiate state change.

              osp$set_status_abnormal (nac$status_id, nae$net_device_reset_timeout,
                    network_device_list^ [i].element, status);
              nap$display_message (status);
              network_device_list^ [i].state := nlc$state_change_pending;
              nap$idle_pp (network_device_list^ [i].pp_number);
              log_cpu_message (network_device_list^ [i].kind, network_device_list^ [i].logical_unit,
                    network_device_list^ [i].pp_number, network_device_list^ [i].channel,
                    device_reset_timeout);
            ELSE
              active_timer_count := active_timer_count + 1;
              IF wait_time > remaining_time THEN
                wait_time := remaining_time;
              IFEND;
            IFEND;
          IFEND;

          remaining_time := (nlv$configured_network_devices.next_log_msg_time - #FREE_RUNNING_CLOCK (0)) DIV
                1000;
          IF remaining_time <= 0 THEN
            log_device_usage_statistics;
            nlv$configured_network_devices.next_log_msg_time := #FREE_RUNNING_CLOCK (0) + log_msg_interval;
            remaining_time := log_msg_interval DIV 1000;
          IFEND;

          IF wait_time > remaining_time THEN
            wait_time := remaining_time;
          IFEND;
          active_timer_count := active_timer_count + 1;
        FOREND;

        nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);
        nav$intranet_mgmt_timer_active := active_timer_count > 0;
      IFEND;

      pmp$wait (wait_time, wait_time);
    WHILEND;

    #KEYPOINT (osk$exit, osk$m * ilmk_manage_intranet_layer, nak$intranet_layer_mgmt_r3);

  PROCEND nap$manage_intranet_layer;
?? OLDTITLE ??
?? NEWTITLE := 'nap$reload_network_pp', EJECT ??

  PROCEDURE [XDCL] nap$reload_network_pp
    (    element: cmt$element_name;
     VAR status: ost$status);

*copyc nah$reload_network_pp

    VAR
      element_descriptor: cmt$element_descriptor,
      executing_taskid: ost$global_task_id,
      iou_name: cmt$element_name,
      ignore_status: ost$status,
      network_device: ^nlt$network_device;


    status.normal := TRUE;
    IF NOT nav$namve_active THEN
      RETURN;
    IFEND;

    nlp$get_exclusive_access (nlv$configured_network_devices.access_control);
    get_network_device (element, network_device);
    IF network_device <> NIL THEN
      CASE network_device^.state OF
      = nlc$normal =
        network_device^.path_status := nlc$path_unavailable;
        flush_unit_queue (network_device);

{ Terminate all active connections.

        nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
        nlp$cc_terminate_connections (network_device^.device_id);
        nlp$get_exclusive_access (nlv$configured_network_devices.access_control);
        nap$return_network_elements (network_device^.element, network_device^.channel,
              network_device^.pp_identification);
        network_device^.logical_unit := 0;

        nap$reserve_network_elements (network_device^.element, network_device^.channel,
              network_device^.channel_address, network_device^.driver_name, network_device^.logical_unit,
              network_device^.pp_identification, network_device^.pp_number, status);
        IF status.normal THEN
          nap$build_master_control_table (network_device^.logical_unit, network_device^.device_id);
          nap$initialize_network_pp (network_device);
          network_device^.path_status := nlc$path_unavailable;
          network_device^.reset_down_count := 0;
          network_device^.reset_down_count_intervl := #FREE_RUNNING_CLOCK (0) + ten_min;
          network_device^.reset_timestamp := #FREE_RUNNING_CLOCK (0);
          nav$intranet_mgmt_timer_active := TRUE;
        ELSE
          network_device^.path_status := nlc$path_down;
          network_device^.reset_down_count := 0;
          network_device^.reset_down_count_intervl := 0;
        IFEND;
        nlp$release_exclusive_access (nlv$configured_network_devices.access_control);

      = nlc$state_change_pending =
        network_device^.path_status := nlc$path_unavailable;
        flush_unit_queue (network_device);

{ Terminate all active connections.

        nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
        nlp$cc_terminate_connections (network_device^.device_id);
        nlp$get_exclusive_access (nlv$configured_network_devices.access_control);
        IF network_device^.task_waiting_for_state_change.index <> 0 THEN
          pmp$ready_task (network_device^.task_waiting_for_state_change, ignore_status);
          network_device^.task_waiting_for_state_change.index := 0;
          nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
        ELSE
          cmp$get_element_type (network_device^.element, {not used} iou_name, element_descriptor.element_type,
                ignore_status);
          element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
          element_descriptor.peripheral_descriptor.element_name := network_device^.element;
          nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
          cmp$process_state_change ({tape_element=} FALSE, {clear_lock_behind=} TRUE, TRUE,
                element_descriptor, {System critical element} FALSE, cmc$on, cmc$down, status);
        IFEND;

      = nlc$closed =
        nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
        osp$set_status_abnormal (nac$status_id, nae$device_not_active, network_device^.element, status);
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$unexpected_device_state, network_device^.element,
              ignore_status);
        nap$namve_system_error (TRUE, 'Invalid device state', ^ignore_status);
        nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
      CASEND;
    ELSE
      nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
      osp$set_status_abnormal (nac$status_id, nae$unknown_element, element, status);
    IFEND;

  PROCEND nap$reload_network_pp;
?? OLDTITLE ??
?? NEWTITLE := 'nap$reserve_network_elements', EJECT ??

  PROCEDURE [XDCL] nap$reserve_network_elements
    (    element: cmt$element_name;
         channel: cmt$channel_ordinal;
         channel_address: cmt$physical_equipment_number,
         driver_name: pmt$program_name;
     VAR logical_unit: iot$logical_unit;
     VAR pp_identification: cmt$pp_identification;
     VAR pp_number: iot$pp_number;
     VAR status: ost$status);

{ This purpose of this procedure is to reserve the specified element and a PP
{ and to load and initialize the pp.

    VAR
      channel_name: cmt$element_name,
      physical_pp: dst$iou_resource,
      found: boolean,
      element_access: array [1 .. 1] of cmt$hardware_address,
      element_definition: ^cmt$element_definition,
      iou_name: cmt$element_name,
      mainframe_id: pmt$mainframe_id,
      port: cmt$communications_port_number,
      program_description: array [1 .. 1] of cmt$pp_program_description,
      physical_identification: cmt$physical_identification,
      reserve_element: array [1 .. 3] of cmt$element_reservation;

    status.normal := TRUE;
    cmp$pc_get_element (element, {not used} iou_name, element_definition, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$get_mainframe_id (mainframe_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Get channel IOU name from the upline connection information of the element.
{   Also get channel name from upline connection information.

    IF element_definition^.element_type = cmc$communications_element THEN

    /search_iou_loop/
      FOR port := LOWERVALUE (cmt$communications_port_number)
            TO UPPERVALUE (cmt$communications_port_number) DO
        IF (element_definition^.communications_element.connection.port [port].configured) AND
              (element_definition^.communications_element.connection.port [port].mainframe_ownership =
              mainframe_id) THEN
          iou_name := element_definition^.communications_element.connection.port [port].iou;
          channel_name := element_definition^.communications_element.connection.port [port].element_name;
          EXIT /search_iou_loop/;
        IFEND;
      FOREND /search_iou_loop/;
    ELSE {ica}
      iou_name := element_definition^.channel_adapter.connection.channel.iou;
      channel_name := element_definition^.channel_adapter.connection.channel.element_name;
    IFEND;

    status.normal := TRUE;
    reserve_element [1].element_type := element_definition^.element_type;
    reserve_element [1].peripheral_descriptor.use_logical_identification := TRUE;
    reserve_element [1].peripheral_descriptor.element_name := element;
    reserve_element [2].element_type := cmc$data_channel_element;
    reserve_element [2].channel_descriptor.use_logical_identification := TRUE;
    reserve_element [2].channel_descriptor.name := channel_name;
    reserve_element [2].channel_descriptor.iou := iou_name;
    reserve_element [3].element_type := cmc$pp_element;
    reserve_element [3].pp_reservation.selector := cmc$choose_pp_by_channel;
    reserve_element [3].pp_reservation.channel.ordinal := channel;
    reserve_element [3].pp_reservation.channel.iou := iou_name;
    cmp$reserve_element (reserve_element, status);
    IF NOT status.normal THEN
      IF (status.condition = cme$cm_element_not_found) OR (status.condition = cme$element_already_reserved)
            THEN
        nap$namve_system_error (FALSE, 'Unable to reserve network elements.', ^status);
      IFEND;

      RETURN;
    IFEND;

    pp_identification := reserve_element [3].pp_reservation.acquired_pp_identification;

    program_description [1].pp_identification := pp_identification;
    program_description [1].iou_program_name := driver_name;
    program_description [1].pp_program := NIL;
    program_description [1].master_pp := TRUE;
    program_description [1].communication_buffer_length := nac$communication_buffer_size;
    program_description [1].communication_buffer := NIL;
    element_access [1].physical_address_specifier := $cmt$physical_address_specifier
          [cmc$iou, cmc$channel, cmc$channel_address];
    element_access [1].iou := iou_name;
    element_access [1].channel.ordinal := channel;
    element_access [1].channel.iou := iou_name;
    element_access [1].channel_address := channel_address;
    program_description [1].element_access := ^element_access;
    cmp$execute_pp_program (program_description, status);
    IF NOT status.normal THEN

{ Return the reserved elements.

      nap$return_network_elements (element, channel, pp_identification);
      RETURN;
    IFEND;
    cmp$convert_pp_ordinal (pp_identification.ordinal, physical_pp);
    cmp$convert_iou_name (pp_identification.iou, physical_pp.iou_number, status);
    IF NOT status.normal THEN
      nap$return_network_elements (element, channel, pp_identification);
      RETURN;
    IFEND;
    cmp$search_pp_table (physical_pp, pp_number, found, status);
    IF NOT status.normal THEN
      nap$return_network_elements (element, channel, pp_identification);
      RETURN;
    IFEND;
    IF NOT found THEN
      nap$namve_system_error (FALSE, 'Logical PP not found in PP Table.', NIL);
    IFEND;
    cmp$get_logical_unit_number (element, logical_unit, status);
    IF NOT status.normal THEN
      nap$namve_system_error (FALSE, 'Unable to get logical unit id.', ^status);
      RETURN;
    IFEND;

  PROCEND nap$reserve_network_elements;
?? OLDTITLE ??
?? NEWTITLE := 'nap$return_network_elements', EJECT ??

  PROCEDURE [XDCL] nap$return_network_elements
    (    element: cmt$element_name;
         channel: cmt$channel_ordinal;
         pp_identification: cmt$pp_identification);

    VAR
      channel_name: cmt$element_name,
      iou_name: cmt$element_name,
      element_definition: ^cmt$element_definition,
      mainframe_id: pmt$mainframe_id,
      port: cmt$communications_port_number,
      reserved_elements: array [1 .. 3] of cmt$element_reservation,
      local_status: ost$status;

{ ***** WARNING: It is assumed that the PP has been idled by the caller.

    cmp$pc_get_element (element, {not_used} iou_name, element_definition, local_status);
    IF NOT local_status.normal THEN
      nap$namve_system_error (FALSE, 'Unable to get element definition.', ^local_status);
      RETURN;
    IFEND;
    pmp$get_mainframe_id (mainframe_id, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    IF element_definition^.element_type = cmc$communications_element THEN

    /search_iou_loop/
      FOR port := LOWERVALUE (cmt$communications_port_number)
            TO UPPERVALUE (cmt$communications_port_number) DO
        IF (element_definition^.communications_element.connection.port [port].configured) AND
              (element_definition^.communications_element.connection.port [port].mainframe_ownership =
              mainframe_id) THEN
          iou_name := element_definition^.communications_element.connection.port [port].iou;
          channel_name := element_definition^.communications_element.connection.port [port].element_name;
          EXIT /search_iou_loop/;
        IFEND;
      FOREND /search_iou_loop/;
    ELSE {ica}
      iou_name := element_definition^.channel_adapter.connection.channel.iou;
      channel_name := element_definition^.channel_adapter.connection.channel.element_name;
    IFEND;

    reserved_elements [1].element_type := cmc$data_channel_element;
    reserved_elements [1].channel_descriptor.use_logical_identification := TRUE;
    reserved_elements [1].channel_descriptor.name := channel_name;
    reserved_elements [1].channel_descriptor.iou := iou_name;
    reserved_elements [2].element_type := element_definition^.element_type;
    reserved_elements [2].peripheral_descriptor.use_logical_identification := TRUE;
    reserved_elements [2].peripheral_descriptor.element_name := element;
    reserved_elements [3].element_type := cmc$pp_element;
    reserved_elements [3].pp_reservation.acquired_pp_identification := pp_identification;
    reserved_elements [3].pp_reservation.selector := cmc$choose_pp_by_channel;
    reserved_elements [3].pp_reservation.channel.ordinal := channel;
    reserved_elements [3].pp_reservation.channel.iou := iou_name;
    cmp$release_element (reserved_elements, local_status);
    IF NOT local_status.normal THEN
      nap$namve_system_error (FALSE, 'Unable to return reserved elements.', ^local_status);
    IFEND;

  PROCEND nap$return_network_elements;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_ica_2_detailed_status', EJECT ??

  PROCEDURE analyze_ica_2_detailed_status
    (    error_summary: ^nat$ica_pp_log_response;
         general_status: ^nat$ica_general_status;
         ica_osi_detailed_status: ^nat$ica_osi_detailed_status;
         network_device: ^nlt$network_device;
     VAR symptom_code: integer;
     VAR symptom_descriptor: string (max_symptom_length);
     VAR symptom_descriptor_length: integer);

{ The purpose of this routine is to return the symptom code and
{ descriptive data associated with a particular error, when the
{ device is an ICA-II in osi mode.


    IF error_summary^.detailed_status_included THEN
      IF ica_osi_detailed_status^.error_detail.write_parity_error THEN
        IF error_summary^.channel_error_flag THEN
          symptom_code := nac$sc_ica_iou_output_parity;
          symptom_descriptor := 'IOU OUTPUT PARITY';
        ELSE
          symptom_code := nac$sc_ica_output_ch_parity;
          symptom_descriptor := 'OUTPUT CHANNEL PARITY';
        IFEND;
      ELSEIF ica_osi_detailed_status^.error_detail.channel_active_timeout THEN
        symptom_code := nac$sc_ica_channel_timeout;
        symptom_descriptor := 'CHANNEL TIMEOUT';
      ELSEIF ica_osi_detailed_status^.error_detail.read_truncated_by_pp THEN
        symptom_code := nac$sc_ica_input_truncated;
        symptom_descriptor := 'INPUT TRUNCATED';
      ELSEIF ica_osi_detailed_status^.error_detail.write_overrun THEN
        symptom_code := nac$sc_ica_pp_overrun;
        symptom_descriptor := 'PP OVER RUN';
      ELSEIF ica_osi_detailed_status^.error_detail.write_format_error THEN
        symptom_code := nac$sc_ica_formatted_output_err;
        symptom_descriptor := 'FORMATTED OUTPUT ERROR';
      ELSEIF ica_osi_detailed_status^.error_detail.write_length_error THEN
        symptom_code := nac$sc_ica_output_length_error;
        symptom_descriptor := 'OUTPUT LENGTH ERROR';
      ELSEIF ica_osi_detailed_status^.error_detail.memory_parity_error THEN
        symptom_code := nac$sc_ica_memory_parity_error;
        symptom_descriptor := 'ICA MEMORY PARITY ERROR';
      ELSEIF ica_osi_detailed_status^.error_detail.memory_address_error THEN
        symptom_code := nac$sc_ica_memory_address_error;
        symptom_descriptor := 'ICA MEMORY ADDRESS ERROR';
      IFEND;
    IFEND;
  PROCEND analyze_ica_2_detailed_status;
?? OLDTITLE ??
?? NEWTITLE := 'flush_unit_queue', EJECT ??

  PROCEDURE flush_unit_queue
    (    network_device: ^nlt$network_device);

    VAR
      message_id_array: ^array [1 .. * ] of nlt$bm_message_id;

    nap$flush_unit_queue (network_device, message_id_array);
    IF message_id_array <> NIL THEN
      nlp$bm_release_messages (message_id_array^);
      FREE message_id_array IN nav$network_paged_heap^;
    IFEND;

  PROCEND flush_unit_queue;
?? OLDTITLE ??
?? NEWTITLE := 'get_network_device', EJECT ??

  PROCEDURE [INLINE] get_network_device
    (    element: cmt$element_name;
     VAR network_device: ^nlt$network_device);

{ The purpose of this procedure is to search the network device list for an
{ entry for the given element.  It is assumed that the network device list
{ has been locked by the caller.

    VAR
      i: integer,
      network_device_list: ^nlt$network_device_list;

    network_device := NIL;
    network_device_list := nlv$configured_network_devices.network_device_list;

  /search/
    FOR i := LOWERBOUND (network_device_list^) TO UPPERBOUND (network_device_list^) DO
      IF (network_device_list^ [i].element = element) THEN
        network_device := ^network_device_list^ [i];
        EXIT /search/;
      IFEND;
    FOREND /search/;

  PROCEND get_network_device;
?? OLDTITLE ??
?? NEWTITLE := 'get_ica_symptom_code', EJECT ??

  PROCEDURE get_ica_symptom_code
    (    unsolicited_response: ^nat$network_driver_response;
         network_device: ^nlt$network_device;
     VAR symptom_code: integer;
     VAR symptom_descriptor: string (max_symptom_length);
     VAR symptom_descriptor_length: integer);

{ The purpose of this routine is to return the symptom code and
{ descriptive data associated with a particular error.

    VAR
      detailed_status: ^iot$detailed_status,
      error_summary: ^nat$ica_pp_log_response,
      general_status_contents: 0 .. 0ffff(16),
      general_status: ^nat$ica_general_status,
      ica_detailed_status: ^nat$ica_detailed_status,
      ica_osi_detailed_status: ^nat$ica_osi_detailed_status;

    detailed_status := unsolicited_response^.detailed_status_pointer;
    RESET detailed_status;
    NEXT error_summary IN detailed_status;
    IF error_summary^.detailed_status_included THEN
      IF network_device^.kind = nac$ica_2 THEN
        NEXT ica_osi_detailed_status IN detailed_status;
      ELSE
        NEXT ica_detailed_status IN detailed_status;
      IFEND;
    IFEND;
    general_status_contents := error_summary^.general_status;
    general_status := #LOC (general_status_contents);
    symptom_code := nac$sc_ica_indeterminate;
    symptom_descriptor := 'INDETERMINATE ERROR';

{ **** WARNING
{ The following symptom descriptor length will have to be changed whenever
{ a new symptom descriptor longer that this value is returned from this routine.

    symptom_descriptor_length := 50;

    CASE error_summary^.error_id OF
    = nac$ica_function_timeout =
      IF error_summary^.channel_error_flag THEN
        symptom_code := nac$sc_ica_funct_timeout_cef;
        symptom_descriptor := 'FUNCTION TIMEOUT AND CHANNEL ERROR FLAG';
      ELSE
        symptom_code := nac$sc_ica_funct_timeout;
        symptom_descriptor := 'FUNCTION TIMEOUT';
      IFEND;

    = nac$ica_state_transition_fail =
      symptom_code := nac$sc_ica_state_transition_err;
      symptom_descriptor := 'STATE TRANSITION FAILURE';

    = nac$ica_invalid_state_change =
      symptom_code := nac$sc_ica_invalid_state_trans;
      symptom_descriptor := 'INVALID STATE TRANSITION';

    = nac$ica_gen_status_busy_timeout =
      symptom_code := nac$sc_ica_general_status_busy;
      symptom_descriptor := 'GENERAL STATUS BUSY TIMEOUT';

    = nac$ica_reset_busy_timeout =
      symptom_code := nac$sc_ica_reset_busy;
      symptom_descriptor := 'RESET BUSY TIMEOUT';

    = nac$ica_diagnostic_failure =
      CASE general_status^.symptom_code OF

      = nac$ica_sc_board_failure =
        symptom_code := nac$sc_ica_board_failure;
        symptom_descriptor := 'ICA BOARD FAILURE';

      = nac$ica_sc_no_power =
        symptom_code := nac$sc_ica_no_transiever_power;
        symptom_descriptor := 'NO ETHERNET TRANSEIVER POWER';

      = nac$ica_sc_ethernet_failure =
        symptom_code := nac$sc_ica_transiever_failure;
        symptom_descriptor := 'ETHERNET TRANSEIVER FAILURE';
      ELSE
      CASEND;

    = nac$ica_gen_status_send_timeout =
      symptom_code := nac$sc_ica_no_send_data;
      symptom_descriptor := 'GENERAL STATUS SEND DATA TIMEOUT';

    = nac$ica_gen_status_avai_timeout =
      symptom_code := nac$sc_ica_status_avail_timeout;
      symptom_descriptor := 'GENERAL STATUS AVAILABLE TIMEOUT';

    = nac$ica_gen_status_content_fail =
      CASE error_summary^.error_word1 OF

      = nac$ica_unf_write_gs_failure =
        symptom_code := nac$sc_ica_unf_write_status;
        symptom_descriptor := 'UNFORMATTED WRITE GENERAL STATUS CONTENT FAILURE';

      = nac$ica_for_write_gs_failure =
        symptom_code := nac$sc_ica_f_write_status;
        symptom_descriptor := 'FORMATTED WRITE GENERAL STATUS CONTENT FAILURE';

      = nac$ica_read_gs_failure =
        symptom_code := nac$sc_ica_read_status;
        symptom_descriptor := 'READ GENERAL STATUS CONTENT FAILURE';

      = nac$ica_echo_status_gs_failure =
        symptom_code := nac$sc_ica_echo_status;
        symptom_descriptor := 'ECHO STATUS GENERAL STATUS CONTENT FAILURE';

      ELSE
      CASEND;

    = nac$ica_reset =
      symptom_code := nac$sc_ica_reset_state;
      symptom_descriptor := 'ICA RESET';

    = nac$ica_operational =
      symptom_code := nac$sc_ica_operational_state;
      symptom_descriptor := 'ICA OPERATIONAL';

    = nac$ica_general_status_reject =
      symptom_code := nac$sc_ica_gen_status_reject;
      symptom_descriptor := 'ICA GENERAL STATUS REJECT';

    = nac$ica_indet_output_parity =
      symptom_code := nac$sc_ica_indet_output_parity;
      symptom_descriptor := 'INDETERMINATE OUTPUT PARITY';

    = nac$ica_channel_protocol_error =
      symptom_code := nac$sc_ica_channel_protocol_err;
      symptom_descriptor := 'CHANNEL PROTOCOL NOT SUPPORTED';

    = nac$ica_invalid_flow_control =
      symptom_code := nac$sc_ica_invalid_flow_control;
      symptom_descriptor := 'INVALID FLOW CONTROL';

    = nac$ica_operation_failure =
      IF error_summary^.maximum_size_exceeded THEN
        symptom_code := nac$sc_ica_max_size_exceeded;
        symptom_descriptor := 'MAXIMUM RECORD SIZE EXCEEDED';
      ELSEIF error_summary^.general_status_error THEN
        CASE general_status^.state OF
        = nac$ica_diagnostic_state =
          IF general_status^.channel_error THEN
            IF error_summary^.channel_error_flag THEN
              symptom_code := nac$sc_ica_iou_output_parity;
              symptom_descriptor := 'IOU OUTPUT PARITY';
            ELSE
              symptom_code := nac$sc_ica_output_ch_parity;
              symptom_descriptor := 'OUTPUT CHANNEL PARITY';
            IFEND;
          ELSEIF general_status^.symptom_code > 0 THEN
            CASE general_status^.symptom_code OF
            = nac$ica_sc_board_failure =
              symptom_code := nac$sc_ica_board_failure;
              symptom_descriptor := 'ICA BOARD FAILURE';

            = nac$ica_sc_unex_function =
              symptom_code := nac$sc_ica_unex_xparent_funct;
              symptom_descriptor := 'UNEXPECTED TRANSPARENT FUNCTION';

            = nac$ica_sc_forced_error =
              symptom_code := nac$sc_ica_forced_err_not_det;
              symptom_descriptor := 'FORCED ERROR NOT DETECTED';

            = nac$ica_sc_cif =
              symptom_code := nac$sc_ica_ch_interface_error;
              symptom_descriptor := 'CHANNEL INTERFACE ERROR';
            ELSE
            CASEND;
          ELSEIF error_summary^.message_content_error THEN
            IF error_summary^.operation_kind = nac$ica_op_read_diagnostic_cmd THEN
              symptom_code := nac$sc_ica_read_diag_cmd_cont;
              symptom_descriptor := 'READ DIAGNOSTIC COMMAND MESSAGE CONTENT ERROR';
            ELSE
              symptom_code := nac$sc_ica_read_conf_content;
              symptom_descriptor := 'READ CONFIDENCE TEST MESSAGE CONTENT ERROR';
            IFEND;
          ELSEIF error_summary^.channel_active THEN
            symptom_code := nac$sc_ica_channel_active;
            symptom_descriptor := 'CHANNEL ACTIVE';
          IFEND;

        = nac$ica_idle_state =
          IF general_status^.channel_error THEN
            IF error_summary^.channel_error_flag THEN
              symptom_code := nac$sc_ica_iou_output_parity;
              symptom_descriptor := 'IOU OUTPUT PARITY';
            ELSE
              symptom_code := nac$sc_ica_output_ch_parity;
              symptom_descriptor := 'OUTPUT CHANNEL PARITY';
            IFEND;
          ELSE
            CASE general_status^.symptom_code OF
            = nac$ica_checksum =
              symptom_code := nac$sc_ica_checksum_error;
              symptom_descriptor := 'CHECKSUM ERROR';

            = nac$ica_invalid_transfer =
              symptom_code := nac$sc_ica_invalid_xfer_address;
              symptom_descriptor := 'INVALID TRANSFER ADDRESS';

            = nac$ica_load_file_length =
              symptom_code := nac$sc_ica_invalid_data_packet;
              symptom_descriptor := 'INVALID DATA PACKET';

            = nac$ica_pp_overrun =
              symptom_code := nac$sc_ica_pp_overrun;
              symptom_descriptor := 'PP OVER RUN';

            = nac$ica_mismatch_hardware =
              symptom_code := nac$sc_ica_mismatch_hardware;
              symptom_descriptor := 'MISMATCH HARDWARE TYPE';
            = nac$ica_ethernet_checksum =
              symptom_code := nac$sc_ica_ethernet_checksum;
              symptom_descriptor := 'ETHERNET ADDRESS CHECKSUM ERROR';
            ELSE
              analyze_ica_2_detailed_status (error_summary, general_status, ica_osi_detailed_status,
                    network_device, symptom_code, symptom_descriptor, symptom_descriptor_length);
            CASEND;
          IFEND;

        = nac$ica_operational_state =
          IF network_device^.kind = nac$ica_2 THEN
            analyze_ica_2_detailed_status (error_summary, general_status, ica_osi_detailed_status,
                  network_device, symptom_code, symptom_descriptor, symptom_descriptor_length);
          ELSE
            IF error_summary^.detailed_status_included THEN
              IF general_status^.channel_error THEN
                IF ica_detailed_status^.error_1.channel_parity_error THEN
                  IF error_summary^.channel_error_flag THEN
                    symptom_code := nac$sc_ica_iou_output_parity;
                    symptom_descriptor := 'IOU OUTPUT PARITY';
                  ELSE
                    symptom_code := nac$sc_ica_output_ch_parity;
                    symptom_descriptor := 'OUTPUT CHANNEL PARITY';
                  IFEND;
                ELSEIF ica_detailed_status^.error_1.channel_timeout THEN
                  symptom_code := nac$sc_ica_channel_timeout;
                  symptom_descriptor := 'CHANNEL TIMEOUT';
                ELSEIF ica_detailed_status^.error_1.input_data_truncated THEN
                  symptom_code := nac$sc_ica_input_truncated;
                  symptom_descriptor := 'INPUT TRUNCATED';
                ELSEIF ica_detailed_status^.error_1.pp_overrun THEN
                  symptom_code := nac$sc_ica_pp_overrun;
                  symptom_descriptor := 'PP OVER RUN';
                ELSEIF ica_detailed_status^.error_1.formatted_output_error THEN
                  symptom_code := nac$sc_ica_formatted_output_err;
                  symptom_descriptor := 'FORMATTED OUTPUT ERROR';
                IFEND;
              IFEND;
              IF general_status^.ica_error AND ica_detailed_status^.error_1.dma_controller_error THEN
                CASE ica_detailed_status^.error_1.type_of_dma_error OF
                = nac$ica_dma_config_error =
                  symptom_code := nac$sc_ica_dma_config_error;
                  symptom_descriptor := 'ICA DMA CONFIGURATION ERROR';

                = nac$ica_dma_timing_error =
                  symptom_code := nac$sc_ica_dma_timing_error;
                  symptom_descriptor := 'ICA DMA TIMING ERROR';

                = nac$ica_dma_count_error =
                  symptom_code := nac$sc_ica_dma_count_error;
                  symptom_descriptor := 'ICA DMA COUNT ERROR';

                = nac$ica_dma_external_abort =
                  symptom_code := nac$sc_ica_dma_external_abort;
                  symptom_descriptor := 'ICA DMA EXTERNAL ABORT';

                = nac$ica_dma_software_abort =
                  symptom_code := nac$sc_ica_dma_software_abort;
                  symptom_descriptor := 'ICA DMA SOFTWARE ABORT';
                ELSE
                CASEND;
              IFEND;
              IF general_status^.pp_error THEN
                IF ica_detailed_status^.error_2.invalid_data_packet THEN
                  symptom_code := nac$sc_ica_invalid_data_packet;
                  symptom_descriptor := 'INVALID DATA PACKET';
                ELSEIF ica_detailed_status^.error_2.configuration_packet_error THEN
                  CASE ica_detailed_status^.error_2.configuration_error_reason OF
                  = nac$ica_config_no_system_addr =
                    symptom_code := nac$sc_ica_no_system_address;
                    symptom_descriptor := 'SYSTEM ADDRESS ERROR';

                  = nac$ica_config_multicast_error =
                    symptom_code := nac$sc_ica_multicast_addr_error;
                    symptom_descriptor := 'MULTICAST ADDRESS ERROR';

                  = nac$ica_config_queue_length =
                    symptom_code := nac$sc_ica_queue_length_error;
                    symptom_descriptor := 'QUEUE LENGTH ERROR';

                  = nac$ica_config_statistic_type =
                    symptom_code := nac$sc_ica_inv_statistics_type;
                    symptom_descriptor := 'INVALID STATISTICS TYPE';

                  = nac$ica_config_single_bit_thr =
                    symptom_code := nac$sc_ica_invalid_thresholds;
                    symptom_descriptor := 'INVALID THRESHOLDS';

                  = nac$ica_config_reporting_int =
                    symptom_code := nac$sc_ica_inv_reporting_inter;
                    symptom_descriptor := 'INVALID REPORTING INTERVAL';
                  ELSE
                  CASEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        ELSE
        CASEND;
      ELSEIF error_summary^.channel_error_flag THEN
        symptom_code := nac$sc_ica_input_ch_parity;
        symptom_descriptor := 'INPUT CHANNEL PARITY';
      ELSEIF error_summary^.channel_deactivation_error THEN
        symptom_code := nac$sc_ica_channel_inactive;
        symptom_descriptor := 'CHANNEL INACTIVE';
      ELSEIF error_summary^.message_length_verify_error THEN
        symptom_code := nac$sc_ica_message_length_error;
        symptom_descriptor := 'MESSAGE LENGTH ERROR';
      ELSEIF error_summary^.channel_full THEN
        symptom_code := nac$sc_ica_channel_full;
        symptom_descriptor := 'CHANNEL FULL';
      ELSEIF error_summary^.channel_empty THEN
        symptom_code := nac$sc_ica_channel_empty;
        symptom_descriptor := 'CHANNEL EMPTY';
      ELSEIF error_summary^.incomplete_transfer THEN
        symptom_code := nac$sc_ica_incomplete_transfer;
        symptom_descriptor := 'INCOMPLETE TRANSFER';
      IFEND;
    ELSE
    CASEND;

  PROCEND get_ica_symptom_code;

?? OLDTITLE ??
?? NEWTITLE := 'get_ivb_symptom_code', EJECT ??

  PROCEDURE get_ivb_symptom_code
    (    unsolicited_response: ^nat$network_driver_response;
     VAR symptom_code: integer;
     VAR symptom_descriptor: string (max_symptom_length);
     VAR symptom_descriptor_length: integer);

{ The purpose of this routine is to return the symptom code and
{ descriptive data associated with a particular IVB error.


    VAR
      detailed_status: ^iot$detailed_status,
      error_summary: ^nat$ivb_pp_log_response;

    detailed_status := unsolicited_response^.detailed_status_pointer;
    RESET detailed_status;
    NEXT error_summary IN detailed_status;
    symptom_code := nac$sc_ivb_indeterminate;
    symptom_descriptor := 'INDETERMINATE ERROR';

{ **** WARNING
{ The following symptom descriptor length will have to be changed whenever
{ a new symptom descriptor longer that this value is returned from this
{ routine.

    symptom_descriptor_length := 50;

    CASE error_summary^.symptom_code OF

    = nac$sc_ivb_funct_timeout =
      symptom_code := nac$sc_ivb_funct_timeout;
      symptom_descriptor := 'FUNCTION TIMEOUT';
    = nac$sc_ivb_channel_empty =
      symptom_code := nac$sc_ivb_channel_empty;
      symptom_descriptor := 'CHANNEL EMPTY';
    = nac$sc_ivb_period_cnter_parity =
      symptom_code := nac$sc_ivb_period_cnter_parity;
      symptom_descriptor := 'PERIOD COUNTER PARITY ERROR';
    = nac$sc_ivb_upper_ici_parity =
      symptom_code := nac$sc_ivb_upper_ici_parity;
      symptom_descriptor := 'UPPER ICI PARITY ERROR';
    = nac$sc_ivb_lower_ici_parity =
      symptom_code := nac$sc_ivb_lower_ici_parity;
      symptom_descriptor := 'LOWER ICI PARITY ERROR';
    = nac$sc_ivb_iou_error =
      symptom_code := nac$sc_ivb_iou_error;
      symptom_descriptor := 'IOU ERROR';
    = nac$sc_ivb_incomplete_transfer =
      symptom_code := nac$sc_ivb_incomplete_transfer;
      symptom_descriptor := 'INCOMPETE TRANSFER';
    = nac$sc_ivb_channel_not_empty =
      symptom_code := nac$sc_ivb_channel_not_empty;
      symptom_descriptor := 'CHANNEL NOT EMPTY';
    = nac$sc_ivb_central_mem_error =
      symptom_code := nac$sc_ivb_central_mem_error;
      symptom_descriptor := 'CENTRAL MEMORY ERROR';
    = nac$sc_ivb_invalid_cm_response =
      symptom_code := nac$sc_ivb_invalid_cm_response;
      symptom_descriptor := 'INVALID CENTRAL MEMORY RESPONSE CODE';
    = nac$sc_ivb_cm_resp_code_parity =
      symptom_code := nac$sc_ivb_cm_resp_code_parity;
      symptom_descriptor := 'CM RESPONSE CODE PARITY ERROR';
    = nac$sc_ivb_cmi_read_data_parity =
      symptom_code := nac$sc_ivb_cmi_read_data_parity;
      symptom_descriptor := 'CMI READ PARITY';
    = nac$sc_ivb_jy_data_error =
      symptom_code := nac$sc_ivb_jy_data_error;
      symptom_descriptor := 'JY DATA ERROR';
    = nac$sc_ivb_bas_parity =
      symptom_code := nac$sc_ivb_bas_parity;
      symptom_descriptor := 'BAS PARITY ERROR';
    = nac$sc_ivb_lz_error =
      symptom_code := nac$sc_ivb_lz_error;
      symptom_descriptor := 'LZ ERROR';
    = nac$sc_ivb_jy_error =
      symptom_code := nac$sc_ivb_jy_error;
      symptom_descriptor := 'JY ERROR';
    = nac$sc_ivb_lx_error =
      symptom_code := nac$sc_ivb_lx_error;
      symptom_descriptor := 'LX ERROR';
    = nac$sc_ivb_cant_select =
      symptom_code := nac$sc_ivb_cant_select;
      symptom_descriptor := 'CAN NOT SELECT IVB';
    = nac$sc_ivb_bit_sign_resp_err =
      symptom_code := nac$sc_ivb_bit_sign_resp_err;
      symptom_descriptor := 'BIT SIGNIFICANT RESPONSE ERROR';
    = nac$sc_ivb_no_sync_in =
      symptom_code := nac$sc_ivb_no_sync_in;
      symptom_descriptor := 'NO SYNC IN';
    = nac$sc_ivb_sync_in_did_not_drop =
      symptom_code := nac$sc_ivb_sync_in_did_not_drop;
      symptom_descriptor := 'SYNC IN DID NOT DROP';
    = nac$sc_ivb_ipi_sequence_error =
      symptom_code := nac$sc_ivb_ipi_sequence_error;
      symptom_descriptor := 'IPI SEQUENCE ERROR';
    = nac$sc_ivb_upper_ipi_parity =
      symptom_code := nac$sc_ivb_upper_ipi_parity;
      symptom_descriptor := 'UPPER IPI CHANNEL PARITY';
    = nac$sc_ivb_lower_ipi_parity =
      symptom_code := nac$sc_ivb_lower_ipi_parity;
      symptom_descriptor := 'LOWER IPI PARITY ERROR';
    = nac$sc_ivb_slave_in_not_set =
      symptom_code := nac$sc_ivb_slave_in_not_set;
      symptom_descriptor := 'SLAVE IN DID NOT SET';
    = nac$sc_ivb_slave_in_didnt_drop =
      symptom_code := nac$sc_ivb_slave_in_didnt_drop;
      symptom_descriptor := 'SLAVE IN DID NOT DROP';
    = nac$sc_ivb_channel_error =
      symptom_code := nac$sc_ivb_channel_error;
      symptom_descriptor := 'CHANNEL ERROR';
    = nac$sc_ivb_channel_active =
      symptom_code := nac$sc_ivb_channel_active;
      symptom_descriptor := 'CHANNEL STAYED ACTIVE';
    = nac$sc_ivb_buffer_cnt_parity =
      symptom_code := nac$sc_ivb_buffer_cnt_parity;
      symptom_descriptor := 'BUFFER COUNTER PARITY';
    = nac$sc_ivb_sync_counter_parity =
      symptom_code := nac$sc_ivb_sync_counter_parity;
      symptom_descriptor := 'SYNC COUNTER PARITY';
    = nac$sc_ivb_lost_data =
      symptom_code := nac$sc_ivb_lost_data;
      symptom_descriptor := 'LOST DATA';
    = nac$sc_ivb_bus_parity =
      symptom_code := nac$sc_ivb_bus_parity;
      symptom_descriptor := 'BUS PARITY';
    = nac$sc_ivb_command_reject =
      symptom_code := nac$sc_ivb_command_reject;
      symptom_descriptor := 'COMMAND REJECT';
    = nac$sc_ivb_sync_out_ne_sync_in =
      symptom_code := nac$sc_ivb_sync_out_ne_sync_in;
      symptom_descriptor := 'SYNC OUT NOT EQUAL SYNC IN';
    = nac$sc_ivb_bus_b_ack_error =
      symptom_code := nac$sc_ivb_bus_b_ack_error;
      symptom_descriptor := 'BUS B ACK INCORRECT';
    = nac$sc_ivb_ending_status_wrong =
      symptom_code := nac$sc_ivb_ending_status_wrong;
      symptom_descriptor := 'ENDING STATUS WRONG';
    = nac$sc_ivb_available =
      symptom_code := nac$sc_ivb_available;
      symptom_descriptor := 'IVB AVAILABLE';
    = nac$sc_ivb_reset =
      symptom_code := nac$sc_ivb_reset;
      symptom_descriptor := 'IVB RESET';
    = nac$sc_ivb_no_forced_error =
      symptom_code := nac$sc_ivb_no_forced_error;
      symptom_descriptor := 'FORCED ERROR DID NOT OCCUR';
    = nac$sc_ivb_ipi_read_resp_error =
      symptom_code := nac$sc_ivb_ipi_read_resp_error;
      symptom_descriptor := 'INVALID IPI READ RESPONSE';
    = nac$sc_ivb_ipi_param_len_error =
      symptom_code := nac$sc_ivb_ipi_param_len_error;
      symptom_descriptor := 'INVALID IPI PARAMETER LENGTH';
    = nac$sc_ivb_sequence_number_err =
      symptom_code := nac$sc_ivb_sequence_number_err;
      symptom_descriptor := 'SEQUENCE NUMBER ERROR';
    = nac$sc_ivb_status_mismatch =
      symptom_code := nac$sc_ivb_status_mismatch;
      symptom_descriptor := 'STATUS MISMATCH';
    = nac$sc_ivb_ipi_resp_code_err =
      symptom_code := nac$sc_ivb_ipi_resp_code_err;
      symptom_descriptor := 'INVALID IPI RESPONSE CODE';
    = nac$sc_ivb_ipi_response_len_err =
      symptom_code := nac$sc_ivb_ipi_response_len_err;
      symptom_descriptor := 'INVALID IPI RESPONSE LENGTH';
    = nac$sc_ivb_ipi_resp_param_err =
      symptom_code := nac$sc_ivb_ipi_resp_param_err;
      symptom_descriptor := 'INVALID READ RESPONSE PARAMETER';
    = nac$sc_ivb_diag_resp_error =
      symptom_code := nac$sc_ivb_diag_resp_error;
      symptom_descriptor := 'INVALID DIAGNOSTIC RESPONSE';
    = nac$sc_ivb_max_ccpdu_size_err =
      symptom_code := nac$sc_ivb_max_ccpdu_size_err;
      symptom_descriptor := 'MAXIMUM CCPDU SIZE EXCEEDED';
    = nac$sc_ivb_buffers_exceeded =
      symptom_code := nac$sc_ivb_buffers_exceeded;
      symptom_descriptor := 'BUFFER REQUIRMENTS EXCEEDED';
    = nac$sc_ivb_rma_not_on_word =
      symptom_code := nac$sc_ivb_rma_not_on_word;
      symptom_descriptor := 'RMA NOT ON A WORD BOUNDARY';
    = nac$sc_ivb_ccpdu_header_error =
      symptom_code := nac$sc_ivb_ccpdu_header_error;
      symptom_descriptor := 'CCPDU HEADER ERROR';
    = nac$sc_ivb_unit_request_err =
      symptom_code := nac$sc_ivb_unit_request_err;
      symptom_descriptor := 'INVALID UNIT REQUEST';
    = nac$sc_ivb_request_len_error =
      symptom_code := nac$sc_ivb_request_len_error;
      symptom_descriptor := 'WRITE REQUEST LENGTH ERROR';
    = nac$sc_ivb_protocol_neg_failed =
      symptom_code := nac$sc_ivb_protocol_neg_failed;
      symptom_descriptor := 'IVB PROTOCOL NEGOTIATION FAILED';
    = nac$sc_ivb_invalid_pp_command =
      symptom_code := nac$sc_ivb_invalid_pp_command;
      symptom_descriptor := 'INVALID PP COMMAND';
    = nac$sc_ivb_unexpected_cpu_ack =
      symptom_code := nac$sc_ivb_unexpected_cpu_ack;
      symptom_descriptor := 'UNEXPECTED CPU ACK';
    = nac$sc_ivb_cant_clear_ch_lock =
      symptom_code := nac$sc_ivb_cant_clear_ch_lock;
      symptom_descriptor := 'UNABLE TO CLEAR CHANNEL LOCK';
    = nac$sc_ivb_buffer_pool_error =
      symptom_code := nac$sc_ivb_buffer_pool_error;
      symptom_descriptor := 'INVALID BUFFER POOL DESCRIPTOR';
    = nac$sc_ivb_inv_max_ccpdu_size =
      symptom_code := nac$sc_ivb_inv_max_ccpdu_size;
      symptom_descriptor := 'MAXIMUM CCPDU SIZE REQUESTED ON SUSPEND LINK';
    ELSE
    CASEND;

  PROCEND get_ivb_symptom_code;
?? OLDTITLE ??
?? NEWTITLE := 'get_mdi_symptom_code', EJECT ??

  PROCEDURE get_mdi_symptom_code
    (    unsolicited_response: ^nat$network_driver_response;
     VAR symptom_code: integer;
     VAR symptom_descriptor: string (max_symptom_length);
     VAR symptom_descriptor_length: integer);

{ The purpose of this routine is to return the symptom code and
{ descriptive data associated with a particular MDI error.

    TYPE
      general_status_16_bit = packed record
        fill: 0 .. 0f(16),
        general_status: nat$mdi_general_status,
      recend;

    VAR
      detailed_status: ^iot$detailed_status,
      error_summary: ^nat$mdi_pp_log_response,
      general_status: ^general_status_16_bit,
      general_status_contents: 0 .. 0ffff(16),
      mdi_detailed_status: ^nat$mdi_detailed_status;

    detailed_status := unsolicited_response^.detailed_status_pointer;
    RESET detailed_status;
    NEXT error_summary IN detailed_status;
    IF error_summary^.detailed_status_included THEN
      NEXT mdi_detailed_status IN detailed_status;
    IFEND;
    general_status_contents := error_summary^.general_status;
    general_status := #LOC (general_status_contents);
    symptom_code := nac$sc_mdi_indeterminate;
    symptom_descriptor := 'INDETERMINATE ERROR';

{ **** WARNING
{ The following symptom descriptor length will have to be changed whenever
{ a new symptom descriptor longer that this value is returned from this
{ routine.

    symptom_descriptor_length := 50;

    CASE error_summary^.error_id OF
    = nac$mdi_function_timeout =
      IF error_summary^.channel_error_flag THEN
        symptom_code := nac$sc_mdi_funct_timeout_cef;
        symptom_descriptor := 'FUNCTION TIMEOUT AND CHANNEL ERROR FLAG';
      ELSE
        symptom_code := nac$sc_mdi_funct_timeout;
        symptom_descriptor := 'FUNCTION TIMEOUT';
      IFEND;

    = nac$mdi_invalid_state_change =
      symptom_code := nac$sc_mdi_invalid_state_trans;
      symptom_descriptor := 'INVALID STATE TRANSITION';

    = nac$mdi_gen_status_busy_timeout =
      symptom_code := nac$sc_mdi_general_status_busy;
      symptom_descriptor := 'GENERAL STATUS BUSY TIMEOUT';

    = nac$mdi_gen_status_send_timeout =
      symptom_code := nac$sc_mdi_no_send_data;
      symptom_descriptor := 'GENERAL STATUS SEND DATA TIMEOUT';

    = nac$mdi_gen_status_data_avail =
      symptom_code := nac$sc_mdi_no_data_avail;
      symptom_descriptor := 'GENERAL STATUS DATA AVAILABLE TIMEOUT';

    = nac$mdi_gen_status_avai_timeout =
      symptom_code := nac$sc_mdi_status_avail_timeout;
      symptom_descriptor := 'GENERAL STATUS AVAILABLE TIMEOUT';

    = nac$mdi_gen_status_content_fail =
      symptom_code := nac$sc_mdi_status_content_error;
      symptom_descriptor := 'DIAGNOSTIC MODE GENERAL STATUS CONTENT FAILURE';

    = nac$mdi_reset =
      symptom_code := nac$sc_mdi_reset_state;
      symptom_descriptor := 'MDI RESET';

    = nac$mdi_available =
      symptom_code := nac$sc_mdi_available;
      symptom_descriptor := 'MDI AVAILABLE';

    = nac$mdi_channel_protocol_error =
      symptom_code := nac$sc_mdi_channel_protocol_err;
      symptom_descriptor := 'CHANNEL PROTOCOL NOT SUPPORTED';

    = nac$mdi_master_clear_failure =
      symptom_code := nac$sc_mdi_master_clear_failure;
      symptom_descriptor := 'MASTER CLEAR FAILURE';

    = nac$mdi_invalid_message_type =
      symptom_code := nac$sc_mdi_invalid_message_type;
      symptom_descriptor := 'INVALID MESSAGE TYPE';

    = nac$mdi_operation_failure =
      IF error_summary^.channel_error_flag THEN
        IF ((error_summary^.operation_kind = nac$mdi_op_write) OR
              (error_summary^.operation_kind = nac$mdi_op_inline_write)) THEN
          IF general_status^.general_status.general_error THEN
            IF error_summary^.detailed_status_included THEN
              IF mdi_detailed_status^.error_1.channel_parity_error THEN
                symptom_code := nac$sc_mdi_iou_output_parity;
                symptom_descriptor := 'IOU OUTPUT PARITY';
              ELSE
                symptom_code := nac$sc_mdi_indet_output_parity;
                symptom_descriptor := 'INDETERMINATE OUTPUT PARITY';
              IFEND;
            ELSE
              symptom_code := nac$sc_mdi_iou_output_parity;
              symptom_descriptor := 'IOU OUTPUT PARITY';
            IFEND;
          ELSE
            symptom_code := nac$sc_mdi_indet_output_parity;
            symptom_descriptor := 'INDETERMINATE OUTPUT PARITY';
          IFEND;
        ELSE
          symptom_code := nac$sc_mdi_input_ch_parity;
          symptom_descriptor := 'INPUT CHANNEL PARITY';
        IFEND;
      ELSEIF error_summary^.maximum_size_exceeded THEN
        symptom_code := nac$sc_mdi_max_size_exceeded;
        symptom_descriptor := 'MAXIMUM RECORD SIZE EXCEEDED';
      ELSEIF general_status^.general_status.general_error AND error_summary^.detailed_status_included THEN
        IF mdi_detailed_status^.error_1.channel_parity_error AND
              ((error_summary^.operation_kind = nac$mdi_op_write) OR
              (error_summary^.operation_kind = nac$mdi_op_inline_write)) THEN
          symptom_code := nac$sc_mdi_output_ch_parity;
          symptom_descriptor := 'OUTPUT CHANNEL PARITY';
        ELSEIF mdi_detailed_status^.error_1.itb_error THEN
          symptom_code := nac$sc_mdi_itb_error;
          symptom_descriptor := 'ITB ERROR';
        ELSEIF mdi_detailed_status^.error_1.itb_parity_error THEN
          symptom_code := nac$sc_mdi_itb_parity_error;
          symptom_descriptor := 'ITB PARITY ERROR';
        ELSEIF mdi_detailed_status^.error_1.channel_timeout THEN
          symptom_code := nac$sc_mdi_channel_timeout;
          symptom_descriptor := 'CHANNEL TIMEOUT';
        ELSEIF mdi_detailed_status^.error_1.input_truncated THEN
          symptom_code := nac$sc_mdi_input_truncated;
          symptom_descriptor := 'INPUT TRUNCATED';
        ELSEIF mdi_detailed_status^.error_1.pp_overrun THEN
          symptom_code := nac$sc_mdi_pp_overrun;
          symptom_descriptor := 'PP OVERRUN';
        ELSEIF mdi_detailed_status^.software_status.length_error THEN
          symptom_code := nac$sc_mdi_length_error;
          symptom_descriptor := 'MCI DETECTED LENGTH ERROR';
        ELSE
          EXIT get_mdi_symptom_code;
        IFEND;
      ELSEIF error_summary^.message_content_error THEN
        symptom_code := nac$sc_mdi_content_error;
        symptom_descriptor := 'MESSAGE_CONTENT_ERROR';
      ELSEIF error_summary^.channel_deactivation_error THEN
        symptom_code := nac$sc_mdi_channel_inactive;
        symptom_descriptor := 'CHANNEL INACTIVE';
      ELSEIF error_summary^.message_length_verify_error THEN
        symptom_code := nac$sc_mdi_message_length_error;
        symptom_descriptor := 'MESSAGE LENGTH ERROR';
      ELSEIF error_summary^.channel_full THEN
        symptom_code := nac$sc_mdi_channel_full;
        symptom_descriptor := 'CHANNEL FULL';
      ELSEIF error_summary^.channel_empty THEN
        symptom_code := nac$sc_mdi_channel_empty;
        symptom_descriptor := 'CHANNEL EMPTY';
      ELSEIF error_summary^.incomplete_transfer THEN
        symptom_code := nac$sc_mdi_incomplete_transfer;
        symptom_descriptor := 'INCOMPLETE TRANSFER';
      IFEND;
    ELSE
    CASEND;

  PROCEND get_mdi_symptom_code;
?? OLDTITLE ??
?? NEWTITLE := 'log_cpu_message', EJECT ??

  PROCEDURE log_cpu_message
    (    device_kind: nat$device_type;
         logical_unit: iot$logical_unit;
         pp_number: iot$pp_number;
         channel: cmt$channel_ordinal;
         log_reason: network_device_log_reason);

{ The purpose of this procedure is to log significant events received or detected by the
{ intranet layer mgmt task.

    CONST
      symptom_length = 28;

    VAR
      channel_counter_word: ^channel_counter,
      channel_name: cmt$element_name,
      channel_number: ost$physical_channel_number,
      channel_port: cmt$channel_port,
      concurrent: boolean,
      counters: ^array [1 .. * ] of sft$counter,
      descriptive_data: ost$string,
      error_kind: integer,
      i: integer,
      iou_number: dst$iou_number,
      local_status: ost$status,
      message: ^string ( * ),
      number_of_counters: integer,
      physical_pp_number: 0 .. 31,
      pp_counter_word: ^pp_counter,
      size: integer,
      statistic_code: sft$statistic_code,
      symptom_code: integer,
      symptom_text: string (symptom_length);

    cmp$return_desc_data_by_lun_lpn (logical_unit, pp_number, iou_number, descriptive_data,
          physical_pp_number);
    CASE device_kind OF
    = nac$di =
      number_of_counters := 14;
      statistic_code := cml$mdi_failure_data;
      error_kind := $INTEGER (nac$mdi_unrecovered_error);
    = nac$ica_2 =
      number_of_counters := 15;
      statistic_code := cml$ica_failure_data;
      error_kind := $INTEGER (nac$ica_unrecovered_error);
    = nac$expresslink =
      number_of_counters := 40;
      statistic_code := cml$ivb_failure_data;
      error_kind := $INTEGER (nac$ivb_unrecovered_error);
    ELSE
    CASEND;

    PUSH counters: [1 .. number_of_counters];
    pp_counter_word := #LOC (counters^ [1]);
    pp_counter_word^.fill := 0;
    pp_counter_word^.iou := iou_number;
    pp_counter_word^.fill1 := 0;
    pp_counter_word^.pp := physical_pp_number;
    channel_counter_word := #LOC (counters^ [2]);
    channel_counter_word^.channel_error_status := 0;
    channel_counter_word^.fill := 0;
    channel_counter_word^.iou := iou_number;
    channel_counter_word^.fill1 := 0;
    channel_counter_word^.fill2 := 0;
    cmp$convert_channel_ordinal (channel, channel_name, channel_number, concurrent, channel_port,
          local_status);
    IF NOT local_status.normal THEN
      nap$namve_system_error (FALSE, 'CMP$CONVERT_CHANNEL_ORDINAL error.', NIL);
    IFEND;
    pp_counter_word^.concurrent := concurrent;
    channel_counter_word^.concurrent := concurrent;
    channel_counter_word^.channel := channel_number;
    counters^ [3] := null_counter;
    counters^ [4] := error_kind;

    CASE log_reason OF
    = device_reset_down_thresh_exceed =
      CASE device_kind OF
      = nac$di =
        symptom_text := '*UF*MDI RESET DOWN THRESHOLD';
        counters^ [5] := nac$sc_mdi_reset_freq_thresh;
      = nac$ica_2 =
        symptom_text := '*UF*ICA RESET DOWN THRESHOLD';
        counters^ [5] := nac$sc_ica_reset_freq_thresh;
      = nac$expresslink =
        symptom_text := '*UF*IVB RESET DOWN THRESHOLD';
        counters^ [5] := nac$sc_ivb_reset_freq_thresh;
      ELSE
      CASEND;
    = device_reset_timeout =
      CASE device_kind OF
      = nac$ica_2 =
        symptom_text := '*UF*ICA RESET TIMEOUT';
        counters^ [5] := nac$sc_ica_not_ready_timeout;
      ELSE
      CASEND;
    ELSE
    CASEND;

    FOR i := 6 TO UPPERBOUND (counters^) DO
      counters^ [i] := null_counter;
    FOREND;

    IF descriptive_data.size <= (252 - symptom_length) THEN
      size := descriptive_data.size;
    ELSE
      size := 252 - symptom_length;
    IFEND;
    PUSH message: [size + symptom_length];
    message^ (1, size) := descriptive_data.value;
    message^ (size + 1, * ) := symptom_text;
    sfp$emit_statistic (statistic_code, message^, counters, {ignore} local_status);

  PROCEND log_cpu_message;
?? OLDTITLE ??
?? NEWTITLE := 'log_device_usage_statistics', EJECT ??

  PROCEDURE log_device_usage_statistics;

{ PURPOSE:
{   The purpose of this procedure is to log the usage data for all
{   configured network devices. The usage data logged represents the
{   amount of usage since the previous log entry. If there has been
{   no usage of this device since the last log entry, no entry will
{   be made.
{
{ NOTE: The caller is assumed to have obtained at least non-exclusive
{   access to the network device list.


    VAR
      channel_counter_word: ^channel_counter,
      channel_name: cmt$element_name,
      channel_number: ost$physical_channel_number,
      channel_port: cmt$channel_port,
      concurrent: boolean,
      counters: array [1 .. 4] of sft$counter,
      current_usage_data: nlt$device_usage_data,
      descriptor_data: ost$string,
      i: integer,
      iou_number: dst$iou_number,
      local_status: ost$status,
      message: ^string ( * ),
      message_length: integer,
      network_device_list: ^nlt$network_device_list,
      physical_pp_number: 0 .. 31,
      pp_counter_word: ^pp_counter,
      size: integer,
      symptom_descriptor_length: integer;

    network_device_list := nlv$configured_network_devices.network_device_list;

    FOR i := 1 TO UPPERBOUND (network_device_list^) DO
      current_usage_data := nlv$device_usage_data^ [i];
      IF current_usage_data <> network_device_list^ [i].last_usage_data THEN
        cmp$return_desc_data_by_lun_lpn (network_device_list^ [i].logical_unit,
              network_device_list^ [i].pp_number, iou_number, descriptor_data, physical_pp_number);
        pp_counter_word := #LOC (counters [1]);
        pp_counter_word^.fill := 0;
        pp_counter_word^.iou := iou_number;
        pp_counter_word^.fill1 := 0;
        pp_counter_word^.pp := physical_pp_number;
        channel_counter_word := #LOC (counters [2]);
        channel_counter_word^.channel_error_status := 0;
        channel_counter_word^.fill := 0;
        channel_counter_word^.iou := iou_number;
        channel_counter_word^.fill1 := 0;
        channel_counter_word^.fill2 := 0;
        cmp$convert_channel_ordinal (network_device_list^ [i].channel, channel_name, channel_number,
              concurrent, channel_port, local_status);
        IF NOT local_status.normal THEN
          nap$namve_system_error (FALSE, 'CMP$CONVERT_CHANNEL_ORDINAL error.', NIL);
        IFEND;
        pp_counter_word^.concurrent := concurrent;
        channel_counter_word^.concurrent := concurrent;
        channel_counter_word^.channel := channel_number;
        counters [3] := current_usage_data.bytes_received -
              network_device_list^ [i].last_usage_data.bytes_received;
        counters [4] := current_usage_data.bytes_transmitted -
              network_device_list^ [i].last_usage_data.bytes_transmitted;
        network_device_list^ [i].last_usage_data := current_usage_data;

{ The following line should be changed if the maximum symptom descriptor length
{ increases.

        symptom_descriptor_length := 16;

        IF ((descriptor_data.size + 1) <= (252 - symptom_descriptor_length)) THEN
          size := descriptor_data.size + 1;
        ELSE
          size := 252 - symptom_descriptor_length;
        IFEND;

        message_length := size + symptom_descriptor_length;
        PUSH message: [message_length];
        message^ (1, size - 1) := descriptor_data.value;
        message^ (size, 1) := '*';
        CASE network_device_list^ [i].kind OF
        = nac$di =
          message^ (size + 1, * ) := 'MDI USAGE DATA';
          sfp$emit_statistic (cml$mdi_usage_data, message^, ^counters, {ignore} local_status);
        = nac$ica_2 =
          message^ (size + 1, * ) := 'ICA USAGE DATA';
          sfp$emit_statistic (cml$ica_usage_data, message^, ^counters, {ignore} local_status);
        = nac$expresslink =
          message^ (size + 1, * ) := 'IVB USAGE DATA';
          sfp$emit_statistic (cml$ivb_usage_data, message^, ^counters, {ignore} local_status);
        ELSE
        CASEND;
      IFEND;
    FOREND;

  PROCEND log_device_usage_statistics;
?? OLDTITLE ??
?? NEWTITLE := 'log_ica_pp_message', EJECT ??

  PROCEDURE log_ica_pp_message
    (    network_device: ^nlt$network_device;
         unsolicited_response: ^nat$network_driver_response;
     VAR ica_down: boolean);

{ The purpose of this procedure is to log the messages generated by the ICA PP.
{ The log information is setup in the detailed status portion of the PP response.



    TYPE
      split_counter = record
        fill: ost$halfword,
        first_half: 0 .. 0ffff(16),
        second_half: 0 .. 0ffff(16),
      recend;

    VAR
      assemble_counter: ^split_counter,
      channel_counter_word: ^channel_counter,
      channel_name: cmt$element_name,
      channel_number: ost$physical_channel_number,
      channel_port: cmt$channel_port,
      concurrent: boolean,
      counters: ^array [1 .. * ] of sft$counter,
      descriptor_data: ost$string,
      detailed_status: ^iot$detailed_status,
      detailed_status_word: ^integer,
      detailed_status_length: 2 .. 3,
      error_summary: ^nat$ica_pp_log_response,
      i,
      k: integer,
      iou_number: dst$iou_number,
      local_status: ost$status,
      message: ^string ( * ),
      message_length: integer,
      number_of_counters: integer,
      physical_pp_number: 0 .. 31,
      pp_counter_word: ^pp_counter,
      symptom_code: integer,
      symptom_descriptor: string (max_symptom_length),
      symptom_descriptor_length: integer,
      size: integer;

    get_ica_symptom_code (unsolicited_response, network_device, symptom_code, symptom_descriptor,
          symptom_descriptor_length);
    cmp$return_desc_data_by_lun_lpn (network_device^.logical_unit, network_device^.pp_number, iou_number,
          descriptor_data, physical_pp_number);
    detailed_status := unsolicited_response^.detailed_status_pointer;
    RESET detailed_status;
    NEXT error_summary IN detailed_status;
    IF error_summary^.detailed_status_included THEN
      number_of_counters := 17;
      detailed_status_length := 2;
    ELSE
      number_of_counters := 15;
    IFEND;

    PUSH counters: [1 .. number_of_counters];
    pp_counter_word := #LOC (counters^ [1]);
    pp_counter_word^.fill := 0;
    pp_counter_word^.iou := iou_number;
    pp_counter_word^.fill1 := 0;
    pp_counter_word^.pp := physical_pp_number;
    channel_counter_word := #LOC (counters^ [2]);
    channel_counter_word^.channel_error_status := 0;
    channel_counter_word^.fill := 0;
    channel_counter_word^.iou := iou_number;
    channel_counter_word^.fill1 := 0;
    channel_counter_word^.fill2 := 0;
    cmp$convert_channel_ordinal (network_device^.channel, channel_name, channel_number, concurrent,
          channel_port, local_status);
    IF NOT local_status.normal THEN
      nap$namve_system_error (FALSE, 'CMP$CONVERT_CHANNEL_ORDINAL error.', NIL);
    IFEND;
    pp_counter_word^.concurrent := concurrent;
    channel_counter_word^.concurrent := concurrent;
    channel_counter_word^.channel := channel_number;
    ica_down := FALSE;

    FOR k := 3 TO number_of_counters DO
      counters^ [k] := null_counter;
    FOREND;

    IF error_summary^.operation_kind <> nac$ica_null_op_kind THEN
      counters^ [3] := $INTEGER (error_summary^.operation_kind);
    IFEND;

    counters^ [4] := $INTEGER (error_summary^.error_kind);
    counters^ [5] := symptom_code;

    IF error_summary^.error_kind <> nac$ica_informative_message THEN
      counters^ [6] := error_summary^.retry_count;
    IFEND;

    IF error_summary^.error_id = nac$ica_function_timeout THEN
      counters^ [7] := error_summary^.timed_out_function;
    IFEND;

    IF (error_summary^.error_id = nac$ica_gen_status_busy_timeout) OR
          (symptom_code = nac$sc_ica_status_avail_timeout) THEN
      counters^ [8] := error_summary^.previous_function;
    IFEND;

    IF (symptom_code = nac$sc_ica_read_diag_cmd_cont) OR (symptom_code = nac$sc_ica_echo_status) THEN
      counters^ [9] := error_summary^.error_word1;
    ELSEIF symptom_code = nac$sc_ica_read_conf_content THEN
      assemble_counter := #LOC (counters^ [9]);
      assemble_counter^.fill := 0;
      assemble_counter^.first_half := error_summary^.error_word1;
      assemble_counter^.second_half := error_summary^.error_word2;
    IFEND;

    IF error_summary^.error_id = nac$ica_state_transition_fail THEN
      counters^ [10] := error_summary^.transition_state;
    IFEND;

    IF error_summary^.error_id = nac$ica_invalid_state_change THEN
      counters^ [11] := error_summary^.error_word1;
      counters^ [12] := error_summary^.error_word2;
    IFEND;

    IF error_summary^.message_length_verify_error THEN
      counters^ [13] := error_summary^.expected_length;
      counters^ [14] := error_summary^.actual_length;
    IFEND;

    IF error_summary^.general_status_included THEN
      counters^ [15] := error_summary^.general_status;
    IFEND;

    IF error_summary^.detailed_status_included THEN
      FOR i := 1 TO detailed_status_length DO
        NEXT detailed_status_word IN detailed_status;
        counters^ [15 + i] := detailed_status_word^;
      FOREND;
    IFEND;


{ Combine descriptor data with symptom message.

    IF (descriptor_data.size <= (252 - 4 - symptom_descriptor_length)) THEN
      size := descriptor_data.size;
    ELSE
      size := 252 - 4 - symptom_descriptor_length;
    IFEND;
    message_length := size + 4 + symptom_descriptor_length;
    PUSH message: [message_length];
    message^ (1, size) := descriptor_data.value;
    k := size + 1;
    CASE error_summary^.error_kind OF
    = nac$ica_unrecovered_error =
      message^ (k, 4) := '*UF*';
    = nac$ica_recovered_error =
      message^ (k, 4) := '*RF*';
    = nac$ica_intermediate_error =
      message^ (k, 4) := '*IF*';
    = nac$ica_informative_message =
      message^ (k, 4) := '*IM*';
    ELSE
    CASEND;
    k := k + 4;
    message^ (k, * ) := symptom_descriptor;
    sfp$emit_statistic (cml$ica_failure_data, message^, counters, {ignore} local_status);

    ica_down := error_summary^.ica_is_down;

  PROCEND log_ica_pp_message;

?? OLDTITLE ??
?? NEWTITLE := 'log_ivb_pp_message', EJECT ??

  PROCEDURE log_ivb_pp_message
    (    network_device: ^nlt$network_device;
         unsolicited_response: ^nat$network_driver_response;
     VAR ivb_down: boolean);

{ The purpose of this procedure is to log the messages generated by the IVB PP.
{ The log information is setup in the detailed status portion of the PP
{ response.


    CONST
      null_counter = -1;

    TYPE
      split_counter = record
        fill: 0 .. 0ffffffffffff(16),
        remaining_bytes: 0 .. 0ffff(16),
      recend;

    VAR
      assemble_counter: ^split_counter,
      channel_counter_word: ^channel_counter,
      channel_name: cmt$element_name,
      channel_number: ost$physical_channel_number,
      channel_port: cmt$channel_port,
      concurrent: boolean,
      counters: ^array [1 .. * ] of sft$counter,
      descriptor_data: ost$string,
      detailed_status: ^iot$detailed_status,
      error_summary: ^nat$ivb_pp_log_response,
      k: integer,
      iou_number: dst$iou_number,
      local_status: ost$status,
      message: ^string ( * ),
      message_length: integer,
      number_of_counters: integer,
      pp_counter_word: ^pp_counter,
      physical_pp_number: 0 .. 31,
      symptom_code: integer,
      symptom_descriptor: string (max_symptom_length),
      symptom_descriptor_length: integer,
      size: integer;

    get_ivb_symptom_code (unsolicited_response, symptom_code, symptom_descriptor, symptom_descriptor_length);
    cmp$return_desc_data_by_lun_lpn (network_device^.logical_unit, network_device^.pp_number, iou_number,
          descriptor_data, physical_pp_number);
    detailed_status := unsolicited_response^.detailed_status_pointer;
    RESET detailed_status;
    NEXT error_summary IN detailed_status;
    number_of_counters := 38;
    ivb_down := FALSE;
    PUSH counters: [1 .. number_of_counters];
    pp_counter_word := #LOC (counters^ [1]);
    pp_counter_word^.fill := 0;
    pp_counter_word^.iou := iou_number;
    pp_counter_word^.fill1 := 0;
    pp_counter_word^.pp := physical_pp_number;
    channel_counter_word := #LOC (counters^ [2]);
    channel_counter_word^.channel_error_status := 0;
    channel_counter_word^.fill := 0;
    channel_counter_word^.iou := iou_number;
    channel_counter_word^.fill1 := 0;
    channel_counter_word^.fill2 := 0;
    cmp$convert_channel_ordinal (network_device^.channel, channel_name, channel_number, concurrent,
          channel_port, local_status);
    IF NOT local_status.normal THEN
      nap$namve_system_error (FALSE, 'CMP$CONVERT_CHANNEL_ORDINAL error.', NIL);
    IFEND;
    pp_counter_word^.concurrent := concurrent;
    channel_counter_word^.concurrent := concurrent;
    channel_counter_word^.channel := channel_number;
    FOR k := 3 TO number_of_counters DO
      counters^ [k] := null_counter;
    FOREND;

    counters^ [4] := $INTEGER (error_summary^.error_kind);
    counters^ [5] := symptom_code;

    IF NOT (error_summary^.error_kind = nac$ivb_informative_message) THEN
      counters^ [6] := error_summary^.retry_count;
      counters^ [7] := error_summary^.last_function;
      counters^ [8] := error_summary^.last_1_function;
      counters^ [9] := error_summary^.last_2_function;
      counters^ [10] := error_summary^.last_3_function;
      counters^ [11] := error_summary^.last_4_function;
      counters^ [12] := error_summary^.last_5_function;
      counters^ [13] := error_summary^.last_6_function;
      counters^ [14] := error_summary^.last_7_function;
    IFEND;

    IF error_summary^.master_status_included THEN
      counters^ [15] := error_summary^.master_status;
    IFEND;

    IF error_summary^.slave_status_included THEN
      counters^ [16] := error_summary^.slave_status;
    IFEND;

    IF error_summary^.ipi_dma_registers_included THEN
      counters^ [26] := error_summary^.ipi_status_register;
      counters^ [27] := error_summary^.ipi_error_register;
      counters^ [28] := error_summary^.dma_error_register;
      counters^ [29] := error_summary^.dma_operation_register;
      counters^ [30] := error_summary^.dma_control_register;
    IFEND;

    counters^ [34] := error_summary^.pp_word_1;
    counters^ [35] := error_summary^.pp_word_2;
    counters^ [36] := error_summary^.pp_word_3;
    counters^ [37] := error_summary^.pp_word_4;
    counters^ [38] := error_summary^.pp_word_5;

    IF (symptom_code = nac$sc_ivb_ipi_read_resp_error) OR (symptom_code = nac$sc_ivb_ipi_param_len_error) OR
          (symptom_code = nac$sc_ivb_ipi_response_len_err) OR
          (symptom_code = nac$sc_ivb_unit_request_err) THEN
      counters^ [25] := error_summary^.actual_data;
    IFEND;

    IF (symptom_code = nac$sc_ivb_ipi_param_len_error) OR (symptom_code = nac$sc_ivb_ipi_resp_param_err) THEN
      counters^ [18] := error_summary^.parameter_id;
    IFEND;

    IF (symptom_code = nac$sc_ivb_sequence_number_err) THEN
      counters^ [19] := error_summary^.expected_data;
      counters^ [20] := error_summary^.actual_data;
    IFEND;

    IF (symptom_code = nac$sc_ivb_available) THEN
      counters^ [33] := error_summary^.expected_data;
      counters^ [22] := error_summary^.actual_data;
    IFEND;

    IF (symptom_code = nac$sc_ivb_ipi_resp_code_err) OR (symptom_code = nac$sc_ivb_ipi_response_len_err) OR
          (symptom_code = nac$sc_ivb_ipi_resp_param_err) OR (symptom_code = nac$sc_ivb_diag_resp_error) OR
          (symptom_code = nac$sc_ivb_unit_request_err) THEN
      counters^ [17] := error_summary^.operation_code;
    IFEND;

    IF (symptom_code = nac$sc_ivb_max_ccpdu_size_err) THEN
      counters^ [32] := error_summary^.actual_data;
    IFEND;

    IF (symptom_code = nac$sc_ivb_buffers_exceeded) THEN
      counters^ [23] := error_summary^.expected_data;
      counters^ [24] := error_summary^.actual_data;
    IFEND;

    IF (symptom_code = nac$sc_ivb_protocol_neg_failed) THEN
      counters^ [21] := error_summary^.expected_data;
      counters^ [22] := error_summary^.actual_data;
    IFEND;

    IF (symptom_code = nac$sc_ivb_incomplete_transfer) THEN
      counters^ [31] := error_summary^.expected_data;
      counters^ [32] := error_summary^.actual_data;
    IFEND;

{ Combine descriptor data with symptom message.

    IF (descriptor_data.size <= (252 - 4 - symptom_descriptor_length)) THEN
      size := descriptor_data.size;
    ELSE
      size := 252 - 4 - symptom_descriptor_length;
    IFEND;
    message_length := size + 4 + symptom_descriptor_length;
    PUSH message: [message_length];
    message^ (1, size) := descriptor_data.value;
    k := size + 1;
    CASE error_summary^.error_kind OF
    = nac$ivb_unrecovered_error =
      message^ (k, 4) := '*UF*';
    = nac$ivb_recovered_error =
      message^ (k, 4) := '*RF*';
    = nac$ivb_intermediate_error =
      message^ (k, 4) := '*IF*';
    = nac$ivb_informative_message =
      message^ (k, 4) := '*IM*';
    ELSE
    CASEND;
    k := k + 4;
    message^ (k, * ) := symptom_descriptor;
    sfp$emit_statistic (cml$ivb_failure_data, message^, counters, {ignore} local_status);

    ivb_down := error_summary^.ivb_is_down;

  PROCEND log_ivb_pp_message;
?? OLDTITLE ??
?? NEWTITLE := 'log_mdi_pp_message', EJECT ??

  PROCEDURE log_mdi_pp_message
    (    network_device: ^nlt$network_device;
         unsolicited_response: ^nat$network_driver_response;
     VAR mdi_down: boolean);

{ The purpose of this procedure is to log the messages generated by the MDI PP.
{ The log information is setup in the detailed status portion of the PP response.


    CONST
      null_counter = -1;

    TYPE
      split_counter = record
        fill: 0 .. 0ffffffffffff(16),
        remaining_bytes: 0 .. 0ffff(16),
      recend;

    VAR
      assemble_counter: ^split_counter,
      channel_counter_word: ^channel_counter,
      channel_name: cmt$element_name,
      channel_number: ost$physical_channel_number,
      channel_port: cmt$channel_port,
      concurrent: boolean,
      counters: ^array [1 .. * ] of sft$counter,
      descriptor_data: ost$string,
      detailed_status: ^iot$detailed_status,
      detailed_status_bytes: ^0 .. 0ffff(16),
      detailed_status_word: ^integer,
      error_summary: ^nat$mdi_pp_log_response,
      i,
      k: integer,
      iou_number: dst$iou_number,
      local_status: ost$status,
      message: ^string ( * ),
      message_length: integer,
      number_of_counters: integer,
      pp_counter_word: ^pp_counter,
      physical_pp_number: 0 .. 31,
      symptom_code: integer,
      symptom_descriptor: string (max_symptom_length),
      symptom_descriptor_length: integer,
      size: integer;

    get_mdi_symptom_code (unsolicited_response, symptom_code, symptom_descriptor, symptom_descriptor_length);
    cmp$return_desc_data_by_lun_lpn (network_device^.logical_unit, network_device^.pp_number, iou_number,
          descriptor_data, physical_pp_number);
    detailed_status := unsolicited_response^.detailed_status_pointer;
    RESET detailed_status;
    NEXT error_summary IN detailed_status;
    IF error_summary^.detailed_status_included THEN
      number_of_counters := 19;
    ELSE
      number_of_counters := 15;
    IFEND;

    mdi_down := FALSE;
    PUSH counters: [1 .. number_of_counters];
    pp_counter_word := #LOC (counters^ [1]);
    pp_counter_word^.fill := 0;
    pp_counter_word^.iou := iou_number;
    pp_counter_word^.fill1 := 0;
    pp_counter_word^.pp := physical_pp_number;
    channel_counter_word := #LOC (counters^ [2]);
    channel_counter_word^.channel_error_status := 0;
    channel_counter_word^.fill := 0;
    channel_counter_word^.iou := iou_number;
    channel_counter_word^.fill1 := 0;
    channel_counter_word^.fill2 := 0;
    cmp$convert_channel_ordinal (network_device^.channel, channel_name, channel_number, concurrent,
          channel_port, local_status);
    IF NOT local_status.normal THEN
      nap$namve_system_error (FALSE, 'CMP$CONVERT_CHANNEL_ORDINAL error.', NIL);
    IFEND;
    pp_counter_word^.concurrent := concurrent;
    channel_counter_word^.concurrent := concurrent;
    channel_counter_word^.channel := channel_number;

    IF error_summary^.channel_error_flag THEN
      channel_counter_word^.channel_error_status := error_summary^.error_word1;
    IFEND;

    FOR k := 3 TO number_of_counters DO
      counters^ [k] := null_counter;
    FOREND;

    IF error_summary^.operation_kind <> nac$mdi_null_op_kind THEN
      counters^ [3] := $INTEGER (error_summary^.operation_kind);
    IFEND;

    counters^ [4] := $INTEGER (error_summary^.error_kind);
    counters^ [5] := symptom_code;

    IF error_summary^.error_kind <> nac$mdi_informative_message THEN
      counters^ [6] := error_summary^.retry_count;
    IFEND;

    IF (symptom_code = nac$sc_mdi_funct_timeout) OR (symptom_code = nac$sc_mdi_funct_timeout_cef) THEN
      counters^ [7] := error_summary^.timed_out_function;
    IFEND;

    IF (error_summary^.error_id = nac$mdi_gen_status_busy_timeout) OR
          (symptom_code = nac$sc_mdi_status_avail_timeout) THEN
      counters^ [8] := error_summary^.previous_function;
    IFEND;

    IF symptom_code = nac$sc_mdi_invalid_state_trans THEN
      counters^ [9] := error_summary^.error_word1;
    IFEND;

    IF (symptom_code = nac$sc_mdi_invalid_state_trans) OR
          (symptom_code = nac$sc_mdi_status_avail_timeout) THEN
      counters^ [10] := error_summary^.error_word2;
    IFEND;

    IF (symptom_code = nac$sc_mdi_message_length_error) OR (symptom_code = nac$sc_mdi_max_size_exceeded) THEN
      counters^ [11] := error_summary^.length_1;
      counters^ [12] := error_summary^.length_2;
    IFEND;

    IF (symptom_code = nac$sc_mdi_no_data_avail) OR (symptom_code = nac$sc_mdi_content_error) OR
          (symptom_code = nac$sc_mdi_status_content_error) THEN
      counters^ [13] := error_summary^.error_word2;
    IFEND;

    IF error_summary^.general_status_included THEN
      counters^ [14] := error_summary^.general_status;
    IFEND;

    IF symptom_code = nac$sc_mdi_channel_protocol_err THEN
      counters^ [15] := error_summary^.error_word1;
    IFEND;

    IF error_summary^.detailed_status_included THEN
      assemble_counter := #LOC (counters^ [16]);
      assemble_counter^.fill := 0;
      NEXT detailed_status_bytes IN detailed_status;
      assemble_counter^.remaining_bytes := detailed_status_bytes^;
      FOR i := 1 TO 3 DO
        NEXT detailed_status_word IN detailed_status;
        counters^ [16 + i] := detailed_status_word^;
      FOREND;
    IFEND;


{ Combine descriptor data with symptom message.

    IF (descriptor_data.size <= (252 - 4 - symptom_descriptor_length)) THEN
      size := descriptor_data.size;
    ELSE
      size := 252 - 4 - symptom_descriptor_length;
    IFEND;
    message_length := size + 4 + symptom_descriptor_length;
    PUSH message: [message_length];
    message^ (1, size) := descriptor_data.value;
    k := size + 1;
    CASE error_summary^.error_kind OF
    = nac$mdi_unrecovered_error =
      message^ (k, 4) := '*UF*';
    = nac$mdi_recovered_error =
      message^ (k, 4) := '*RF*';
    = nac$mdi_intermediate_error =
      message^ (k, 4) := '*IF*';
    = nac$mdi_informative_message =
      message^ (k, 4) := '*IM*';
    ELSE
    CASEND;
    k := k + 4;
    message^ (k, * ) := symptom_descriptor;
    sfp$emit_statistic (cml$mdi_failure_data, message^, counters, {ignore} local_status);

    mdi_down := error_summary^.mdi_is_down;

  PROCEND log_mdi_pp_message;
?? OLDTITLE ??
?? NEWTITLE := 'process_solicited_response', EJECT ??

  PROCEDURE process_solicited_response
    (    solicited_response: ^nat$network_driver_response);

{ The purpose of this procedure is to process the solicited responses from
{ the network PP.
{ NOTE: A local or permanent file must not be created or extended while
{       holding an exclusive access lock to the configured network device
{       list. This is to avoid NAM/VE users from being blocked in case the
{       local or permanent device is full.

    VAR
      element_descriptor: cmt$element_descriptor,
      iou_name: cmt$element_name,
      local_status: ost$status,
      network_device: ^nlt$network_device,
      synch_dump_sub_cmd_code: integer;

    CASE solicited_response^.command.command_code OF

    = ioc$cc_synchronize_pp, ioc$cc_resume =

{   Do nothing. These responses are directed to the completed output task so that the request blocks
{   associated with the requests can be freed in ring 1.

    = ioc$cc_idle =

      nlp$get_exclusive_access (nlv$configured_network_devices.access_control);

{ The 'priority' field in the pp response contains the network device identifier.

      network_device := ^nlv$configured_network_devices.network_device_list^
            [solicited_response^.pp_response.priority];

      CASE network_device^.state OF
      = nlc$normal =
        osp$set_status_abnormal (nac$status_id, nae$unexpected_pp_response, 'IDLE', local_status);
        nap$namve_system_error (FALSE, 'CPU-PP device state mismatch', ^local_status);
        nlp$release_exclusive_access (nlv$configured_network_devices.access_control);

      = nlc$state_change_pending =
        network_device^.path_status := nlc$path_unavailable;
        flush_unit_queue (network_device);

{ Terminate all active connections.

        nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
        nlp$cc_terminate_connections (solicited_response^.pp_response.priority);
        nlp$get_exclusive_access (nlv$configured_network_devices.access_control);

{ Initiate state switch.

        IF network_device^.task_waiting_for_state_change.index <> 0 THEN
          pmp$ready_task (network_device^.task_waiting_for_state_change, {ignore} local_status);
          network_device^.task_waiting_for_state_change.index := 0;
          nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
        ELSE
          cmp$get_element_type (network_device^.element, {not used} iou_name, element_descriptor.element_type,
                {ignore} local_status);
          element_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
          element_descriptor.peripheral_descriptor.element_name := network_device^.element;
          nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
          cmp$process_state_change ({tape_element=} FALSE, {clear_lock_behind=} TRUE, TRUE,
                element_descriptor, {System critical element} FALSE, cmc$on, cmc$down, local_status);
        IFEND;

      = nlc$closed =
        nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$unexpected_device_state, network_device^.element,
              local_status);
        nap$namve_system_error (FALSE, 'Invalid device state', ^local_status);
        nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
      CASEND;

    ELSE
      osp$set_status_abnormal (nac$status_id, nae$unexpected_pp_response, 'SOLICITED', local_status);
      nap$namve_system_error (FALSE, 'Unexpected PP response', ^local_status);
    CASEND;

  PROCEND process_solicited_response;
?? OLDTITLE ??
?? NEWTITLE := 'process_unsolicited_response', EJECT ??

  PROCEDURE process_unsolicited_response
    (    unsolicited_response: ^nat$network_driver_response);

{ The purpose of this procedure is to process the unsolicited responses from
{ the network drivers i.e ICA and MDI PPs.

    VAR
      channel: cmt$channel_ordinal,
      command: iot$command,
      critical_msg: string (71),
      current_time: integer,
      detailed_status: ^iot$detailed_status,
      device_attributes: ^operational_device_attributes,
      device_kind: nat$device_type,
      device_reset_down_threshold: integer,
      down_device: boolean,
      element: cmt$element_name,
      i: integer,
      local_status: ost$status,
      logical_unit: iot$logical_unit,
      max_device_down_time: integer,
      max_supported_pdu: nlt$cc_pdu_size,
      network_device: ^nlt$network_device,
      pp_number: iot$pp_number;

    CASE unsolicited_response^.pp_response.unsolicited_response_code OF
    = ioc$unit_ready_to_not_ready, ioc$unit_not_ready_to_ready, ioc$device_operational =
      nlp$get_exclusive_access (nlv$configured_network_devices.access_control);
    ELSE
      nlp$get_nonexclusive_access (nlv$configured_network_devices.access_control);
    CASEND;

{ *** NOTE: the PRIORITY field in the pp response contains the network device identifier.

    network_device := ^nlv$configured_network_devices.network_device_list^
          [unsolicited_response^.pp_response.priority];

    IF (unsolicited_response^.pp_response.unsolicited_response_code = ioc$log_pp_message) OR
          ((network_device^.state <> nlc$state_change_pending) AND (network_device^.state <> nlc$closed)) THEN

      CASE unsolicited_response^.pp_response.unsolicited_response_code OF
      = ioc$unit_ready_to_not_ready =

{ The network access field in the configured dcn entry is changed via an exclusive access to the
{ configured dcn list.

        IF network_device^.state = nlc$normal THEN
          network_device^.path_status := nlc$path_unavailable;
          down_device := FALSE;
          network_device^.reset_timestamp := #FREE_RUNNING_CLOCK (0);

          CASE network_device^.kind OF
          = nac$di, nac$expresslink =

{ Display message in the critical window of the NOS/VE system console.

            critical_msg (1, 15) := 'Network Device ';
            critical_msg (16, * ) := network_device^.element;
            i := 15;
            REPEAT
              i := i + 1;
            UNTIL critical_msg (i, 1) = ' ';

            critical_msg (i + 1, 14) := 'is unavailable';
            dpp$put_critical_message (critical_msg, {ignore} local_status);

            device_reset_down_threshold := nav$mci_reset_down_threshold;

          = nac$ica_2 =
            device_reset_down_threshold := nav$ica_reset_down_threshold;
          ELSE
          CASEND;

          IF device_reset_down_threshold > 0 THEN
            network_device^.reset_down_count := network_device^.reset_down_count + 1;
            current_time := #FREE_RUNNING_CLOCK (0);
            down_device := (current_time <= network_device^.reset_down_count_intervl) AND
                  (network_device^.reset_down_count >= device_reset_down_threshold);
            IF (current_time >= network_device^.reset_down_count_intervl) AND (NOT down_device) THEN
              network_device^.reset_down_count_intervl := #FREE_RUNNING_CLOCK (0) + ten_min;
              network_device^.reset_down_count := 1;
            IFEND;
          IFEND;

          IF down_device THEN
            nap$idle_pp (network_device^.pp_number);
            network_device^.state := nlc$state_change_pending;
            device_kind := network_device^.kind;
            logical_unit := network_device^.logical_unit;
            pp_number := network_device^.pp_number;
            channel := network_device^.channel;
            nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
            log_cpu_message (device_kind, logical_unit, pp_number, channel, device_reset_down_thresh_exceed);

{ Display message in the job log.

            osp$set_status_abnormal (nac$status_id, nae$device_reset_thresh_exceed, network_device^.element,
                  local_status);
            nap$display_message (local_status);
          ELSE

            flush_unit_queue (network_device);

{ Terminate all active channel connections.

            nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
            nlp$cc_terminate_connections (unsolicited_response^.pp_response.priority);
            nlp$get_nonexclusive_access (nlv$configured_network_devices.access_control);

            command.command_code := ioc$cc_synchronize_pp;
            command.flags.store_response := TRUE;
            command.flags.indirect_address := FALSE;
            command.length := 0;
            command.address := 0;
            nap$issue_pp_request (network_device^.pp_number, command, NIL);
            nav$intranet_mgmt_timer_active := TRUE;
            nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);
          IFEND;
        ELSE { Kill the system - unrecoverable error
          nap$namve_system_error (FALSE, 'Unexpected PP response', NIL);
        IFEND;

      = ioc$unit_not_ready_to_ready =

{ Cancel the timer.

        network_device^.path_status := nlc$path_available;
        IF (network_device^.kind = nac$di) OR (network_device^.kind = nac$expresslink) THEN

{ Display message in the critical window of the NOS/VE system console.

          critical_msg (1, 15) := 'Network Device ';
          critical_msg (16, * ) := network_device^.element;
          i := 15;
          REPEAT
            i := i + 1;
          UNTIL critical_msg (i, 1) = ' ';

          critical_msg (i + 1, 12) := 'is available';
          dpp$put_critical_message (critical_msg, {ignore} local_status);
        IFEND;
        nlp$release_exclusive_access (nlv$configured_network_devices.access_control);

      = ioc$device_operational =
        IF network_device^.path_status <> nlc$path_down THEN
          IF (((network_device^.kind = nac$di) OR (network_device^.kind = nac$expresslink)) AND
                (network_device^.path_status = nlc$path_unavailable)) THEN

{ Display message in the critical window of the NOS/VE system console.

            critical_msg (1, 15) := 'Network Device ';
            critical_msg (16, * ) := network_device^.element;
            i := 15;
            REPEAT
              i := i + 1;
            UNTIL critical_msg (i, 1) = ' ';

            critical_msg (i + 1, 12) := 'is available';
            dpp$put_critical_message (critical_msg, {ignore} local_status);
          IFEND;

          network_device^.path_status := nlc$path_available;

{ Extract the channel interface protocol and the maximum channel connection PDU size.

          detailed_status := unsolicited_response^.detailed_status_pointer;
          RESET detailed_status;
          NEXT device_attributes IN detailed_status;
          network_device^.channel_interface_protocol := device_attributes^.channel_interface_protocol;
          network_device^.maximum_pdu_size := device_attributes^.maximum_pdu_size;
          IF (network_device^.kind = nac$di) OR (network_device^.kind = nac$expresslink) THEN
            network_device^.system_id := device_attributes^.system_id;
          IFEND;

          command.command_code := ioc$cc_synchronize_pp;
          command.flags.store_response := TRUE;
          command.flags.indirect_address := FALSE;
          command.length := 0;
          command.address := 0;
          nap$issue_pp_request (network_device^.pp_number, command, NIL);

          CASE network_device^.kind OF
          = nac$di, nac$ica_2 = { Support 6 buffers, possibly 4 large and 2 small
            max_supported_pdu := (4 * nlv$bm_large_buffer_size) + (2 * nlc$bm_small_buffer_size);
          = nac$expresslink = { Supports 8 large and 1 small buffers
            max_supported_pdu := (8 * nlv$bm_large_buffer_size) + (1 * nlc$bm_small_buffer_size);
          ELSE
            max_supported_pdu := 0;
          CASEND;
          IF network_device^.maximum_pdu_size > max_supported_pdu THEN
            osp$set_status_abnormal (nac$status_id, nae$data_unit_size_too_big, network_device^.element,
                  local_status);
            osp$append_status_integer (osc$status_parameter_delimiter, network_device^.maximum_pdu_size,
                  10, false, local_status);
            osp$append_status_integer (osc$status_parameter_delimiter, max_supported_pdu, 10, false,
                  local_status);
            osp$append_status_integer (osc$status_parameter_delimiter, osv$page_size, 10, false,
                  local_status);
            nap$display_message (local_status);
          IFEND;

          nlp$release_exclusive_access (nlv$configured_network_devices.access_control);

        ELSE { Kill the system - unrecoverable error
          nap$namve_system_error (FALSE, 'Unexpected PP response', NIL);
        IFEND;

      = ioc$log_pp_message =
        CASE network_device^.kind OF
        = nac$di =
          log_mdi_pp_message (network_device, unsolicited_response, down_device);
          device_reset_down_threshold := nav$mci_reset_down_threshold;
        = nac$ica_2 =
          log_ica_pp_message (network_device, unsolicited_response, down_device);
          device_reset_down_threshold := nav$ica_reset_down_threshold;
        = nac$expresslink =
          log_ivb_pp_message (network_device, unsolicited_response, down_device);
          device_reset_down_threshold := nav$mci_reset_down_threshold;
        ELSE
        CASEND;

        IF down_device THEN

{ Display message in the job log.

          osp$set_status_abnormal (nac$status_id, nae$device_down_via_pp, network_device^.element,
                local_status);
          nap$display_message (local_status);

{ Since the PP can generate a down indication for a device due to an ungraceful shutdown, couunt this
{ down request against the reset down threshold and then decide if the device should be downed.

          IF device_reset_down_threshold > 0 THEN
            network_device^.reset_down_count := network_device^.reset_down_count + 1;
            current_time := #FREE_RUNNING_CLOCK (0);
            down_device := (current_time <= network_device^.reset_down_count_intervl) AND
                  (network_device^.reset_down_count >= device_reset_down_threshold);
            IF (current_time >= network_device^.reset_down_count_intervl) AND (NOT down_device) THEN
              network_device^.reset_down_count_intervl := #FREE_RUNNING_CLOCK (0) + ten_min;
              network_device^.reset_down_count := 1;
            IFEND;
          ELSE
            down_device := FALSE;
          IFEND;

          IF down_device THEN
            IF (network_device^.state <> nlc$closed) AND (network_device^.state <> nlc$state_change_pending)
                  THEN

{ Display message in the job log.

              osp$set_status_abnormal (nac$status_id, nae$device_reset_thresh_exceed, network_device^.element,
                    local_status);
              nap$display_message (local_status);
              nap$idle_pp (network_device^.pp_number);
              network_device^.state := nlc$state_change_pending;
            IFEND;
          ELSE

            flush_unit_queue (network_device);

{ Terminate all active channel connections.

            nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);
            nlp$cc_terminate_connections (unsolicited_response^.pp_response.priority);
            nlp$get_nonexclusive_access (nlv$configured_network_devices.access_control);

{ Restart the PP.

            command.flags.store_response := TRUE;
            command.flags.indirect_address := FALSE;
            command.command_code := ioc$cc_resume;
            command.length := 0;
            command.address := 0;
            nap$issue_pp_request (network_device^.pp_number, command, NIL);
          IFEND;
        IFEND;
        nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);

      ELSE { Should never end up here - unrecoverable error
        nap$namve_system_error (FALSE, 'Unexpected unsolicited response.', NIL);
      CASEND;
    ELSE { Ignore the PP response
      CASE unsolicited_response^.pp_response.unsolicited_response_code OF
      = ioc$unit_not_ready_to_ready, ioc$unit_ready_to_not_ready, ioc$device_operational =
        nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
      ELSE
        nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);
      CASEND;
    IFEND;

  PROCEND process_unsolicited_response;
?? OLDTITLE ??
 MODEND nam$intranet_layer_mgmt_r3;
*DECK DECK=NAM$JOB_RECOVERY_RING1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE NETWORK ACCESS: Job Recovery Ring 1' ??
MODULE nam$job_recovery_ring1;

{ PURPOSE:
{   This module handles the ring 1 job recovery of NAM/VE.

?? NEWTITLE := 'Global Declarations Referenced by This Module' ??
?? PUSH (LISTEXT := ON) ??
*copyc nat$received_message_list
?? POP ??
*copyc pmp$find_executing_task_xcb
?? OLDTITLE ??

?? NEWTITLE := '[XDCL, #GATE] nap$reset_received_message_list', EJECT ??
*copy nah$reset_received_message_list

  PROCEDURE [XDCL, #GATE] nap$reset_received_message_list;

    VAR
      execution_control_block: ^ost$execution_control_block,
      compare_swap_status: osc$cs_successful .. osc$cs_variable_locked,
      current_value: nat$received_message_list,
      new_value: nat$received_message_list,
      actual_value: nat$received_message_list;

    new_value.next_received_message := NIL;
    new_value.fill := 0;
    current_value := new_value;
    pmp$find_executing_task_xcb (execution_control_block);
    REPEAT
      #COMPARE_SWAP (execution_control_block^.received_message_list, current_value, new_value, actual_value,
            compare_swap_status);
      IF (compare_swap_status = osc$cs_failed) THEN
        current_value.next_received_message := actual_value.next_received_message;
      IFEND;
    UNTIL compare_swap_status = osc$cs_successful;
  PROCEND nap$reset_received_message_list;
?? OLDTITLE ??
MODEND nam$job_recovery_ring1;
*DECK DECK=NAM$LOG_ME EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
MODULE nam$log_me;
?? PUSH (LISTEXT:=ON) ??
*copyc clt$parameter_list
*copyc dmt$error_condition_codes
*copyc mme$condition_codes
*copyc nac$network_management_catalog
*copyc nac$reserved_saps
*copyc nae$log_me_conditions
*copyc nat$management_data_unit_syntax
*copyc nat$gt_interface
*copyc nat$gt_event
*copyc nat$network_message_priority
*copyc nlt$protocol
?? POP ??
*copyc amp$put_next
*copyc amp$return
*copyc clp$convert_string_to_file
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$include_file
*copyc clp$scan_parameter_list
*copyc fsp$close_file
*copyc fsp$open_file
*copyc nap$display_message
*copyc nap$get_file_cycle_count
*copyc nap$gt_accept_connection
*copyc nap$gt_close_sap
*copyc nap$gt_disconnect
*copyc nap$gt_open_sap
*copyc nap$gt_receive_connect_event
*copyc nap$gt_receive_connection_event
*copyc nap$gt_send_data
*copyc nap$gt_reject_connection
*copyc nlp$register_title
*copyc nlp$delete_registered_title
*copyc osp$append_status_integer
*copyc osp$i_await_activity_completion
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pfp$attach
*copyc pfp$convert_pft$path_to_fs_path
*copyc pmp$get_unique_name
{*copyc pmp$log
*copyc pmp$wait

  CONST
    index_bias = 2,
    timer_index = 1,
    sap_index = 2,
    version = 1;

  CONST
{  Disconnect Reason Codes
    protocol_version_mismatch = 1,
    unrecognizeable_pdu = 2,
    unexpected_pdu = 3,
    insufficient_resources = 4,
    service_unavailable = 5;

  CONST
{  Dependent LOG ME PDU types
    log_message = 1,
    prepare_to_disconnect = 2;

  CONST
{  Independent LOG ME PDU types
    log_domain_definition = 1;

  CONST
    nac$max_connections = 1000,
    nac$max_log_cycles = 999,
    nac$max_log_message = 0ffff(16),
    nac$max_interval = 1440,
    nac$log_me_title_prefix = '$I_LOG_ME_',
    nac$log_me_title_prefix_length = 10;

  TYPE
    log_group = record
      title_registered: boolean,
      group_name: string (31),
      priority: 0 .. 0ff(16),
      directory_identifier: nat$directory_entry_identifier,
      password: nat$directory_password,
    recend;

  TYPE
    dependent_log_pdu_hdr = record
      length: 0 .. 0ff(16),
      version_number: 0 .. 0ff(16),
      pdu_type: 0 .. 0ff(16),
      time_stamp: nat$bcd_time,
      system_address: nat$system_address,
      log_message_number: 0 .. 0ffff(16),
      system_title: string (31),
    recend;

  TYPE
    independent_log_pdu_hdr = record
      length: 0 .. 0ff(16),
      pdu_type: 0 .. 0ff(16),
      version_number: 0 .. 0ff(16),
    recend;

  TYPE
    log_vdu_pairs = record
      string_hdr: nat$mdu_header,
      name: string (31),
      integer_hdr: nat$mdu_header,
      priority: 0 .. 0ff(16),
    recend;

  TYPE
    group_array = array [1 .. * ] of log_group;

  TYPE
    connection_state = (normal, message_incomplete);

  TYPE
    connection_information = record
      activity_status: ost$activity_status,
      connection_id: nat$gt_connection_id,
      data_area: array [1 .. 1] of nat$data_fragment,
      data_buffer: SEQ (REP 200(16) of cell),
      state: connection_state,
      message_length: integer,
      continuation_buffer: ^SEQ (REP 0ffff(16) of cell),
      event: nat$gt_event,
    recend;

  VAR
    active_connections: 0 .. nac$max_connections := 0,
    address:  nat$internet_address,
    connections: ^array [1 .. *] of ^connection_information,
    groups: ^group_array,
    log_file_termination_time: integer,
    log_file_id: amt$file_identifier,
    log_file_path: array [1 .. 4] of pft$name := [nac$management_family, nac$management_master_catalog,
      nac$cdcnet_subcatalog, nac$log_file],
    log_file_processing_requested: boolean,
    max_connection_index: 0 .. nac$max_connections,
    max_connections: 1 .. nac$max_connections,
    max_log_cycles: 2 .. nac$max_log_cycles,
    max_log_size: 0 .. amc$file_byte_limit,
    interval: integer,
    sap:  nat$gt_sap_identifier,
    temp_data_frag: array [1 .. 1] of nat$data_fragment,
    titles_registered: boolean,
    wait_list: ^ost$i_wait_list,
    wait_list_seq: ^SEQ ( * );

  ?? TITLE := 'exit_condition_handler', EJECT ??

  PROGRAM nap$log_me (parameter_list: clt$parameter_list;
    VAR status: ost$status);


    PROCEDURE exit_condition_handler (condition: pmt$condition;
          condition_descriptor: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      VAR
        disconnect_reason: 0 .. 0ff(16),
        local_status: ost$status,
        index: integer,
        output_data: array [1 .. 1] of nat$data_fragment;

      delete_titles;
      fsp$close_file (log_file_id, local_status);
      submit_log_processing_job;
      disconnect_reason := service_unavailable;
      output_data [1].address := ^disconnect_reason;
      output_data [1].length := #SIZE (disconnect_reason);
      FOR index := 1 TO max_connection_index DO
        IF connections^ [index] <> NIL THEN
          nap$gt_disconnect (connections^ [index]^.connection_id, output_data, local_status);
          delete_connection (index);
        IFEND;
      FOREND;
      FREE groups;
      nap$gt_close_sap (sap, local_status);

    PROCEND exit_condition_handler;
?? TITLE := 'nap$log_me', EJECT ??

    VAR
      activity_status: ost$activity_status,
      connection: ^connection_information,
      connection_index: integer,
      connect_buffer: [STATIC] SEQ (REP 20(16) of cell),
      connect_data: [STATIC] array [1 .. 1] of nat$data_fragment := [[^connect_buffer, #SIZE
        (connect_buffer)]],
      connect_event: nat$gt_connect_event,
      cycles: 0 .. pfc$maximum_cycle_number,
      data: ^SEQ ( * ),
      dep_log_pdu_hdr: ^dependent_log_pdu_hdr,
      disconnect_reason: 0 .. 0ff(16),
      input_pdu: ^SEQ ( * ),
      message_length: integer,
      new_connection: ^connection_information,
      output_data: array [1 .. 1] of nat$data_fragment,
      partial_message: ^SEQ ( * ),
      sap_id: nat$internet_sap_identifier,
      version_number: ^0 .. 0ff(16),
      wait_index: integer,
      wait_time: integer;

    process_parameters (parameter_list, groups, max_connections, max_log_cycles, max_log_size, interval,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$get_file_cycle_count (log_file_path, cycles, status);
    IF (status.normal) AND (cycles > 0) THEN
       submit_log_processing_job;
    IFEND;

    titles_registered := FALSE;

    create_log_file (FALSE, log_file_id, log_file_termination_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE connections: [1 .. max_connections];
    FOR connection_index := 1 TO UPPERBOUND (connections^) DO
      connections^ [connection_index] := NIL;
    FOREND;
    max_connection_index := 0;

    osp$establish_block_exit_hndlr (^exit_condition_handler);

    nap$gt_open_sap (max_connections, nac$interact_message_priority, {reserved sap=} FALSE,
          sap, address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    register_titles (address, sap, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE wait_list_seq: [[REP (max_connections + index_bias) OF ost$i_activity]];
    RESET wait_list_seq;
    NEXT wait_list: [1 .. sap_index] IN wait_list_seq;

   IF log_file_processing_requested THEN
     wait_list^ [timer_index].activity := osc$i_await_time;
   ELSE
     wait_list^ [timer_index].activity := osc$i_null_activity;
   IFEND;
    wait_list^ [sap_index].activity := nac$i_await_activity_status;
    wait_list^ [sap_index].activity_status := ^activity_status;
    nap$gt_receive_connect_event (sap, connect_data, osc$nowait, connect_event, activity_status, status);
    IF NOT status.normal THEN
      nap$display_message (status);
      EXIT nap$log_me;
    IFEND;

  /main_loop/
    WHILE TRUE DO
      output_data [1].address := NIL;
      output_data [1].length := 0;
      IF log_file_processing_requested THEN
        wait_time := log_file_termination_time - (#free_running_clock (0) DIV 1000);
        IF wait_time >= 0 THEN
          wait_list^ [timer_index].milliseconds := wait_time;
        ELSE
          wait_list^ [timer_index].milliseconds := 0;
        IFEND;
      IFEND;
      osp$i_await_activity_completion (wait_list^, wait_index, status);
      IF status.normal THEN
        IF wait_index = timer_index THEN
          create_log_file (TRUE, log_file_id, log_file_termination_time, status);
          IF NOT status.normal THEN
            nap$display_message (status);
            EXIT /main_loop/;
          IFEND;
        ELSEIF wait_index = sap_index THEN
          IF connect_event.source.kind = osi THEN
            #unchecked_conversion (connect_event.source.osi_address.transport_sap_selector(1,
                  connect_event.source.osi_address.transport_sap_selector_length), sap_id);
          ELSE
            sap_id := connect_event.source.internet_address.sap;
          IFEND;
          IF activity_status.status.normal AND (sap_id = nac$xi_cdna_log_sap + nac$transport_sap_offset) AND
                (connect_event.data_length > 0) AND (active_connections < max_connections) THEN
            ALLOCATE new_connection;
            IF new_connection = NIL THEN
              { allocate failed }
              nap$gt_reject_connection (connect_event.connection, output_data, status);
              IF NOT status.normal THEN
                nap$display_message (status);
              IFEND;
            ELSE
              new_connection^.connection_id := connect_event.connection;
              new_connection^.state := normal;
              new_connection^.data_area [1].address := ^new_connection^.data_buffer;
              new_connection^.data_area [1].length := #SIZE (new_connection^.data_buffer);
              data := ^connect_buffer;
              RESET data;
              NEXT version_number IN data;
              IF version_number^ = version THEN
                nap$gt_accept_connection (new_connection^.connection_id, output_data, NIL, status);
                IF status.normal THEN
                  add_connection_to_list (new_connection, connection_index);
                  send_domain_pdu (connection_index, FALSE);
                  temp_data_frag [1].address := new_connection^.data_area [1].address;
                  temp_data_frag [1].length := new_connection^.data_area [1].length;
                  nap$gt_receive_connection_event (new_connection^.connection_id, temp_data_frag, osc$nowait,
                        new_connection^.event, new_connection^.activity_status, status);
                  IF NOT status.normal THEN
                    nap$display_message (status);
                    delete_connection (connection_index);
                  IFEND;
                ELSE
                  nap$display_message (status);
                  FREE new_connection;
                  nap$gt_reject_connection (connect_event.connection, output_data, status);
                  IF NOT status.normal THEN
                    nap$display_message (status);
                  IFEND;
                IFEND;
              ELSE
                FREE new_connection;
                disconnect_reason := protocol_version_mismatch;
                output_data [1].address := ^disconnect_reason;
                output_data [1].length := #SIZE (disconnect_reason);
                nap$gt_reject_connection (connect_event.connection, output_data, status);
                IF NOT status.normal THEN
                  nap$display_message (status);
                IFEND;
              IFEND;
            IFEND;
          ELSE
            IF activity_status.status.normal THEN
{             pmp$log ('LG - CONNECTION REJECTED', status);
              IF active_connections < max_connections THEN
                disconnect_reason := unrecognizeable_pdu;
              ELSE
                disconnect_reason := insufficient_resources;
              IFEND;
              output_data [1].address := ^disconnect_reason;
              output_data [1].length := #SIZE (disconnect_reason);
              nap$gt_reject_connection (connect_event.connection, output_data, status);
              IF NOT status.normal THEN
                nap$display_message (status);
              IFEND;
            IFEND;
          IFEND;
          nap$gt_receive_connect_event (sap, connect_data, osc$nowait, connect_event, activity_status,
                status);
          IF NOT status.normal THEN
            nap$display_message (status);
            EXIT nap$log_me;
          IFEND;
        ELSE
          connection_index := wait_index - index_bias;
          IF connections^ [connection_index]^.activity_status.status.normal THEN
            CASE connections^ [connection_index]^.event.kind OF
            = nac$gt_data_event =
              connection := connections^ [connection_index];
              CASE connection^.state OF
              = normal =
                data := ^connection^.data_buffer;
                RESET data;
                NEXT input_pdu: [[REP connection^.event.data.data_length OF cell]] IN data;
                RESET input_pdu;
                NEXT dep_log_pdu_hdr IN input_pdu;
                IF (dep_log_pdu_hdr <> NIL) AND (dep_log_pdu_hdr^.version_number = version) THEN
                  CASE dep_log_pdu_hdr^.pdu_type OF
                  = log_message =
                    IF connection^.event.data.end_of_message THEN
                      write_message_to_log (connection^.event.data.data_length, input_pdu, status);
                      IF NOT status.normal THEN
                        nap$display_message (status);
                        EXIT /main_loop/;
                      IFEND;
                      temp_data_frag [1].address := connection^.data_area [1].address;
                      temp_data_frag [1].length := connection^.data_area [1].length;
                      nap$gt_receive_connection_event (connection^.connection_id,
                            temp_data_frag, osc$nowait, connection^.event,
                            connection^.activity_status, status);
                      IF NOT status.normal THEN
                        nap$display_message (status);
                        delete_connection (connection_index);
                      IFEND;
                    ELSE
                      { Message is larger than default buffer. Message is moved to
                      { a allocated buffer where the entire message is built before
                      { writing it to the log file.
                      connection^.state := message_incomplete;
                      connection^.message_length := connection^.event.data.data_length;
                      ALLOCATE connection^.continuation_buffer;
                      RESET connection^.continuation_buffer;
                      NEXT partial_message: [[REP connection^.message_length OF cell]] IN
                         connection^.continuation_buffer;
                      partial_message^ := input_pdu^;
                      NEXT partial_message: [[REP nac$max_log_message - connection^.message_length OF cell]]
                           IN connection^.continuation_buffer;
                      temp_data_frag [1].address := partial_message;
                      temp_data_frag [1].length := nac$max_log_message - connection^.message_length;
                      nap$gt_receive_connection_event (connection^.connection_id, temp_data_frag,
                            osc$nowait, connection^.event,
                            connection^.activity_status, status);
                      IF NOT status.normal THEN
                        nap$display_message (status);
                        FREE connection^.continuation_buffer;
                        delete_connection (connection_index);
                      IFEND;
                    IFEND;
                  = prepare_to_disconnect =
                    nap$gt_disconnect (connections^ [connection_index]^.connection_id, output_data, status);
                    IF NOT status.normal THEN
                      nap$display_message (status);
                    IFEND;
                    delete_connection (connection_index);
                  ELSE
{                   pmp$log ('LG - LOG PDU TYPE INVALID', status);
                    disconnect_reason := unrecognizeable_pdu;
                    output_data [1].address := ^disconnect_reason;
                    output_data [1].length := #SIZE (disconnect_reason);
                    nap$gt_disconnect (connections^ [connection_index]^.connection_id, output_data, status);
                    IF NOT status.normal THEN
                      nap$display_message (status);
                    IFEND;
                    delete_connection (connection_index);
                  CASEND;
               ELSE
{                 pmp$log ('LG - INVALID LOG PDU', status);
                  disconnect_reason := unrecognizeable_pdu;
                  output_data [1].address := ^disconnect_reason;
                  output_data [1].length := #SIZE (disconnect_reason);
                  nap$gt_disconnect (connections^ [connection_index]^.connection_id, output_data, status);
                  IF NOT status.normal THEN
                    nap$display_message (status);
                  IFEND;
                  delete_connection (connection_index);
                IFEND;
              = message_incomplete =
                IF connection^.event.data.end_of_message THEN
                  message_length := connection^.message_length + connection^.event.data.data_length;
                  write_message_to_log (message_length, connection^.continuation_buffer, status);
                  IF NOT status.normal THEN
                    nap$display_message (status);
                    EXIT /main_loop/;
                  IFEND;
                  connection^.state := normal;
                  FREE connection^.continuation_buffer;
                  temp_data_frag [1].address := connection^.data_area [1].address;
                  temp_data_frag [1].length := connection^.data_area [1].length;
                  nap$gt_receive_connection_event (connection^.connection_id,
                        temp_data_frag, osc$nowait, connection^.event,
                        connection^.activity_status, status);
                  IF NOT status.normal THEN
                    nap$display_message (status);
                    delete_connection (connection_index);
                  IFEND;
                ELSE
                  FREE connection^.continuation_buffer;
{                 pmp$log ('LG - MAX LOG MESSAGE SIZE EXCEEDED, CONNECTION TERMINATED', status);
                  disconnect_reason := insufficient_resources;
                  output_data [1].address := ^disconnect_reason;
                  output_data [1].length := #SIZE (disconnect_reason);
                  nap$gt_disconnect (connection^.connection_id, output_data, status);
                  IF NOT status.normal THEN
                    nap$display_message (status);
                  IFEND;
                  delete_connection (connection_index);
                IFEND;
              ELSE
              CASEND;

            = nac$gt_expedited_data_event =
{             pmp$log ('LG - X-DATA EVENT', status);
              disconnect_reason := unexpected_pdu;
              output_data [1].address := ^disconnect_reason;
              output_data [1].length := #SIZE (disconnect_reason);
              nap$gt_disconnect (connections^ [connection_index]^.connection_id, output_data, status);
              IF NOT status.normal THEN
                nap$display_message (status);
              IFEND;
              delete_connection (connection_index);

            = nac$gt_disconnect_event =
              delete_connection (connection_index);
{             pmp$log ('LG - DISCONNECT EVENT', status);
            CASEND;
          ELSE { NOT activity_status.status.normal
            nap$display_message (connections^ [connection_index]^.activity_status.status);
            disconnect_reason := service_unavailable;
            output_data [1].address := ^disconnect_reason;
            output_data [1].length := #SIZE (disconnect_reason);
            nap$gt_disconnect (connections^ [connection_index]^.connection_id, output_data, status);
            delete_connection (connection_index);
          IFEND;
        IFEND;
      ELSE
        nap$display_message (status);
        EXIT /main_loop/;
      IFEND;
    WHILEND /main_loop/;
  PROCEND nap$log_me;

?? TITLE := 'add_connection_to_list', EJECT ??

  PROCEDURE [INLINE] add_connection_to_list (connection: ^connection_information;
    VAR connection_index: integer);

    VAR
      i: integer;

    /main_loop/
    BEGIN
      FOR i := index_bias + 1 TO UPPERBOUND (wait_list^) DO
        IF wait_list^ [i].activity = osc$i_null_activity THEN
          wait_list^ [i].activity := nac$i_await_activity_status;
          wait_list^ [i].activity_status := ^connection^.activity_status;
          connections^ [i - index_bias] := connection;
          connection_index := i - index_bias;
          EXIT /main_loop/;
        IFEND;
      FOREND;

    { Last entry in wait_list is always in use.}

        RESET wait_list_seq;
        NEXT wait_list: [1 .. UPPERBOUND (wait_list^) + 1] IN wait_list_seq;
        wait_list^ [UPPERBOUND (wait_list^)].activity := nac$i_await_activity_status;
        wait_list^ [UPPERBOUND (wait_list^)].activity_status := ^connection^.activity_status;
        connections^ [UPPERBOUND (wait_list^) - index_bias] := connection;
        connection_index := UPPERBOUND (wait_list^) - index_bias;
        max_connection_index := connection_index;
    END /main_loop/;
    active_connections := active_connections + 1;

  PROCEND add_connection_to_list;

?? TITLE := 'create_log_file', EJECT ??

  PROCEDURE create_log_file (terminate_old_log: boolean;
    VAR file_id: amt$file_identifier;
    VAR termination_time: integer;
    VAR status: ost$status);

    VAR
      attachment_selections: [STATIC] array [1 .. 3] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes,
            [fsc$shorten, fsc$append, fsc$modify]], [fsc$specific_share_modes,
            [fsc$read]]], [fsc$sequential_access, TRUE], [fsc$free_behind, TRUE]],
      cycles: 0 .. pfc$maximum_cycle_number,
      file_name: clt$file,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      highest_cycle: [STATIC, READ] pft$cycle_selector := [pfc$highest_cycle],
      index: integer,
      log_processing_job_submitted: boolean,
      loop_count: 0 .. 2,
      mandated_attributes: [STATIC] array [1 .. 3] of fst$file_cycle_attribute :=
            [[fsc$file_limit, * ], [fsc$ring_attributes, *], [fsc$file_organization, amc$sequential]],
      password: [STATIC, READ] pft$password := ' ',
      titles_deleted: boolean;

    status.normal := TRUE;
    loop_count := 0;
    titles_deleted := NOT titles_registered;

    IF terminate_old_log THEN

{  Close and detach the log file.  }

      fsp$close_file (file_id, {ignore} status);
      osp$set_status_condition ( nae$log_file_terminated,  status);
      nap$display_message (status);
      status.normal := TRUE;
      submit_log_processing_job;
      log_processing_job_submitted := TRUE;
    ELSE
      log_processing_job_submitted := FALSE;
    IFEND;

{   Create new cycle of log file.

    mandated_attributes[1].file_limit := max_log_size;
    mandated_attributes[2].ring_attributes.r1 := 11;
    mandated_attributes[2].ring_attributes.r2 := 11;
    mandated_attributes[2].ring_attributes.r3 := 11;
    REPEAT
      IF NOT status.normal THEN
        nap$display_message (status);
        osp$set_status_condition ( nae$unable_to_create_log_file,  status);
        nap$display_message (status);
        IF NOT log_processing_job_submitted THEN
          submit_log_processing_job;
          log_processing_job_submitted := TRUE;
        IFEND;
        IF loop_count < 2  THEN
          loop_count := loop_count + 1;
          pmp$wait (60000, 60000);
        ELSE
          IF (NOT titles_deleted) AND (titles_registered) THEN
            delete_titles;
            nap$gt_close_sap (sap, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            titles_deleted := TRUE;
          IFEND;
          pmp$wait (60000, 60000);
        IFEND;
      IFEND;
      nap$get_file_cycle_count (log_file_path, cycles, status);
      IF status.normal THEN
        pfp$convert_pft$path_to_fs_path (log_file_path, fs_path, fs_path_size);
        IF cycles < max_log_cycles THEN
          fs_path (fs_path_size + 1, 6) := '.$NEXT';
          fs_path_size := fs_path_size + 6;
          clp$convert_string_to_file (fs_path (1, fs_path_size), file_name, status);
          IF status.normal THEN
            fsp$open_file (file_name.local_file_name, amc$record, ^attachment_selections, NIL,
                  ^mandated_attributes, NIL, NIL, file_id, status);
            termination_time := (#free_running_clock(0) DIV 1000) + interval;
          IFEND;
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$max_cycles_reached, fs_path (1, fs_path_size), status);
        IFEND;
      IFEND;
    UNTIL status.normal OR ((status.condition <> nae$max_cycles_reached) AND
         (status.condition <> pfe$cycle_overflow) AND (status.condition <> mme$volume_unavailable) AND
         (status.condition <> dme$unable_to_alloc_all_space));

    IF (titles_registered AND titles_deleted) THEN
      nap$gt_open_sap (max_connections, nac$interact_message_priority, {reserved_sap=} FALSE,
            sap, address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      register_titles (address, sap, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
  PROCEND create_log_file;

?? TITLE := 'delete_connection', EJECT ??

  PROCEDURE delete_connection (connection_index: integer);

    VAR
      i: integer;

    FREE connections^ [connection_index];
    active_connections := active_connections - 1;
    wait_list^ [connection_index + index_bias].activity := osc$i_null_activity;

    i := connection_index + index_bias;
    IF i = UPPERBOUND (wait_list^) THEN
      WHILE wait_list^ [i].activity = osc$i_null_activity DO
        i := i - 1;
      WHILEND;
      RESET wait_list_seq;
      NEXT wait_list: [1 .. i] IN wait_list_seq;
      max_connection_index := i - index_bias;
    IFEND;

  PROCEND delete_connection;

?? TITLE := 'delete_titles', EJECT ??

  PROCEDURE delete_titles;

    VAR
      i: integer,
      local_status: ost$status,
      title: string (41);

    FOR i := 1 TO UPPERBOUND (groups^) DO
      IF groups^ [i].title_registered THEN
        title := nac$log_me_title_prefix;
        title (nac$log_me_title_prefix_length + 1, * ) := groups^ [i].group_name;
        nlp$delete_registered_title (title, groups^ [i].password, groups^ [i].directory_identifier,
              local_status);
        IF local_status.normal THEN
          groups^ [i].title_registered := FALSE;
        ELSE
          nap$display_message (local_status);
        IFEND;
      IFEND;
    FOREND;
  PROCEND delete_titles;

?? TITLE := 'process_parameters', EJECT ??

  PROCEDURE process_parameters (parameter_list: clt$parameter_list;
    VAR groups: ^group_array;
    VAR max_connections: 1 .. nac$max_connections;
    VAR max_log_cycles: 2 .. nac$max_log_cycles;
    VAR max_log_size: 0 .. amc$file_byte_limit;
    VAR interval: integer;
    VAR status: ost$status);

{       PDT log_me_pdt (
{       groups,group,g: list 1..clc$max_value_sets, 1..2 of any = ((CATENET,1))
{       maximum_connections,mc:integer 1..nac$max_connections = 1000
{       maximum_log_cycles, mlc: integer 2..nac$max_log_cycles = 999
{       maximum_log_size, mls:integer 0..amc$file_byte_limit or key none = none
{       interval, i:integer 1..nac$max_interval or key none = none
{       status)

?? PUSH (LISTEXT := ON) ??

  VAR
    log_me_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^log_me_pdt_names,
      ^log_me_pdt_params];

  VAR
    log_me_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 12] of
      clt$parameter_name_descriptor := [['GROUPS', 1], ['GROUP', 1], ['G', 1], ['MAXIMUM_CONNECTIONS', 2], [
      'MC', 2], ['MAXIMUM_LOG_CYCLES', 3], ['MLC', 3], ['MAXIMUM_LOG_SIZE', 4], ['MLS', 4], ['INTERVAL', 5], [
      'I', 5], ['STATUS', 6]];

  VAR
    log_me_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 6] of clt$parameter_descriptor := [

{ GROUPS GROUP G }
    [[clc$optional_with_default, ^log_me_pdt_dv1], 1, clc$max_value_sets, 1, 2, clc$value_range_not_allowed,
      [NIL, clc$any_value]],

{ MAXIMUM_CONNECTIONS MC }
    [[clc$optional_with_default, ^log_me_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 1, nac$max_connections]],

{ MAXIMUM_LOG_CYCLES MLC }
    [[clc$optional_with_default, ^log_me_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 2, nac$max_log_cycles]],

{ MAXIMUM_LOG_SIZE MLS }
    [[clc$optional_with_default, ^log_me_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [^log_me_pdt_kv4,
      clc$integer_value, 0, amc$file_byte_limit]],

{ INTERVAL I }
    [[clc$optional_with_default, ^log_me_pdt_dv5], 1, 1, 1, 1, clc$value_range_not_allowed, [^log_me_pdt_kv5,
      clc$integer_value, 1, nac$max_interval]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    log_me_pdt_kv4: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['NONE'];

  VAR
    log_me_pdt_kv5: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['NONE'];

  VAR
    log_me_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (13) := '((CATENET,1))';

  VAR
    log_me_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := '1000';

  VAR
    log_me_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := '999';

  VAR
    log_me_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'none';

  VAR
    log_me_pdt_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'none';

?? POP ??

    VAR
      i: 0 .. clc$max_value_sets,
      set_count: 0 .. clc$max_value_sets,
      set_entry: 0 .. clc$max_value_sets,
      value: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, log_me_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('GROUPS', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    ALLOCATE groups: [1 .. set_count];

    FOR set_entry := 1 TO set_count DO
      clp$get_value ('GROUPS', set_entry, 2, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (value.kind = clc$integer_value) THEN
        IF (value.int.value >= nac$max_directory_priority) AND (value.int.value <=
              nac$min_directory_priority) THEN
          groups^ [set_entry].priority := value.int.value;
        ELSE
          osp$set_status_condition ( nae$invalid_log_group_priority,  status);
          osp$append_status_integer (osc$status_parameter_delimiter, value.int.value, 10, FALSE, status);
          RETURN;
        IFEND;
      ELSEIF (value.kind = clc$unknown_value) THEN
        groups^ [set_entry].priority := nac$max_directory_priority;
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$invalid_log_group_priority, value.descriptor, status);
        RETURN;
      IFEND;
      clp$get_value ('GROUPS', set_entry, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (value.kind <> clc$name_value) THEN
        osp$set_status_abnormal (nac$status_id, nae$invalid_log_group_name, value.descriptor, status);
        RETURN;
      IFEND;
{ Check that group is unique.
      FOR i := 1 TO set_entry - 1 DO
        IF groups^ [i].group_name = value.name.value THEN
          osp$set_status_abnormal (nac$status_id, nae$duplicate_group, value.name.value, status);
          RETURN;
        IFEND;
      FOREND;
      groups^ [set_entry].group_name := value.name.value;
      groups^ [set_entry].title_registered := FALSE;
    FOREND;

    clp$get_value ('MAXIMUM_CONNECTIONS', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    max_connections := value.int.value;

    clp$get_value ('MAXIMUM_LOG_CYCLES', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    max_log_cycles := value.int.value;

    clp$get_value ('MAXIMUM_LOG_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind = clc$name_value THEN
      max_log_size := amc$file_byte_limit;
    ELSE
      max_log_size := value.int.value;
    IFEND;

    clp$get_value ('INTERVAL', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind = clc$name_value THEN
      log_file_processing_requested := FALSE;
    ELSE
      log_file_processing_requested := TRUE;
      interval := value.int.value * 60 * 1000;
    IFEND;

  PROCEND process_parameters;

?? TITLE := 'register_titles', EJECT ??

  PROCEDURE register_titles (address: nat$internet_address;
        sap: nat$gt_sap_identifier;
    VAR status: ost$status);

    VAR
      class: nat$title_class,
      distribute: boolean,
      domain: nat$title_domain,
      i: integer,
      osi_address: nat$osi_registration_address,
      service: nat$protocol,
      title: string (41),
      user_identifier: ost$name;


    status.normal := TRUE;
    osi_address.kind := nac$osi_transport_address;
    osi_address.transport_selector := sap.osi_sap_identifier;
    service := nac$cdna_transport;
    domain.kind := nac$catenet_domain;
    distribute := TRUE;
    class := nac$cdna_internal;
    user_identifier := nac$log_me_title_prefix;

    FOR i := 1 TO UPPERBOUND (groups^) DO
      title := nac$log_me_title_prefix;
      title (nac$log_me_title_prefix_length + 1, * ) := groups^ [i].group_name;
      nlp$register_title (title, osi_address, service, NIL, 0, groups^ [i].priority, domain,
            distribute, class, groups^ [i].password, user_identifier, groups^ [i].directory_identifier,
            status);
      IF status.normal THEN
        groups^ [i].title_registered := TRUE;
      ELSE
        nap$display_message (status);
      IFEND;
    FOREND;
  PROCEND register_titles;

?? TITLE := 'send_domain_pdu', EJECT ??

  PROCEDURE send_domain_pdu (connection_index: integer;
        send_to_all: boolean);

    VAR
      domain_pdu_header: independent_log_pdu_hdr,
      i: integer,
      output_data: array [1 .. 2] of nat$data_fragment,
      status: ost$status,
      vdu_pairs: ^array [1 .. * ] of log_vdu_pairs;

    domain_pdu_header.length := 2;
    domain_pdu_header.pdu_type := log_domain_definition;
    domain_pdu_header.version_number := version;
    ALLOCATE vdu_pairs: [1 .. UPPERBOUND (groups^)];
    FOR i := 1 TO UPPERBOUND (groups^) DO
      vdu_pairs^ [i].string_hdr.kind := nac$mdu_character_string;
      vdu_pairs^ [i].string_hdr.field := TRUE;
      vdu_pairs^ [i].string_hdr.length := 30;
      vdu_pairs^ [i].name := groups^ [i].group_name;
      vdu_pairs^ [i].integer_hdr.kind := nac$mdu_unsigned_integer;
      vdu_pairs^ [i].integer_hdr.field := TRUE;
      vdu_pairs^ [i].integer_hdr.length := 7;
      vdu_pairs^ [i].priority := groups^ [i].priority;
    FOREND;
    output_data [2].address := vdu_pairs;
    output_data [2].length := #SIZE (vdu_pairs^);
    output_data [1].address := ^domain_pdu_header;
    output_data [1].length := #SIZE (domain_pdu_header);
    IF send_to_all THEN
      FOR i := index_bias + 1 TO max_connection_index DO
        IF connections^ [i] <> NIL THEN
          nap$gt_send_data (connections^ [i]^.connection_id, output_data, TRUE, osc$wait,
                 connections^ [i]^.activity_status, status);
          IF NOT status.normal THEN
            nap$display_message (status);
          IFEND;
        IFEND;
      FOREND;
    ELSE
      nap$gt_send_data (connections^ [connection_index]^.connection_id, output_data, TRUE, osc$wait,
            connections^ [connection_index]^.activity_status, status);
      IF NOT status.normal THEN
        nap$display_message (status);
      IFEND;
    IFEND;
    FREE vdu_pairs;

  PROCEND send_domain_pdu;

?? TITLE := 'submit_log_processing_file', EJECT ??

  PROCEDURE submit_log_processing_job;

    VAR
      highest_cycle: [STATIC, READ] pft$cycle_selector := [pfc$highest_cycle],
      local_status: ost$status,
      master_log_processor_path: [STATIC, READ] array [1 .. 5] of pft$name :=
        [nac$management_family, nac$management_master_catalog, nac$cdcnet_subcatalog,
         nac$version_independent_catalog,nac$log_processor_job],
      name: ost$name,
      password: [STATIC, READ] pft$password := ' ',
      share: [STATIC, READ] pft$share_selections := [pfc$read],
      usage: [STATIC, READ] pft$usage_selections := [pfc$read],
      user_log_processor_path: [STATIC, READ] array [1 .. 5] of pft$name :=
        [nac$management_family, nac$management_master_catalog, nac$cdcnet_subcatalog,
         nac$site_controlled_subcatalog,nac$log_processor_job];

{  Submit a job to perform the desired processing on the log file.  }

    pmp$get_unique_name (name, local_status);
    pfp$attach (name, user_log_processor_path, highest_cycle, password, usage,
                share, pfc$no_wait, local_status);
    IF NOT local_status.normal THEN
       IF local_status.condition <> pfe$unknown_permanent_file THEN
         nap$display_message (local_status);
       IFEND;
       pmp$get_unique_name (name, local_status);
       pfp$attach (name, master_log_processor_path, highest_cycle, password, usage,
                   share, pfc$no_wait, local_status);
    IFEND;
    IF local_status.normal THEN
      clp$include_file (name, '', osc$null_name, local_status);
      IF NOT local_status.normal THEN
        nap$display_message (local_status);
        osp$set_status_condition ( nae$unable_to_process_log_file,  local_status);
        nap$display_message (local_status);
      IFEND;
      amp$return (name, {ignore} local_status);
    ELSE
      nap$display_message (local_status);
      osp$set_status_condition ( nae$unable_to_process_log_file,  local_status);
      nap$display_message (local_status);
    IFEND;
  PROCEND submit_log_processing_job;

?? TITLE := 'write_message_to_log', EJECT ??

  PROCEDURE write_message_to_log (message_length: integer;
    message: ^cell;
    VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address;

    amp$put_next (log_file_id, message, message_length, byte_address, status);
    IF NOT status.normal THEN
      CASE status.condition OF
      = ame$put_beyond_file_limit =
        create_log_file (TRUE, log_file_id, log_file_termination_time, status);
        IF status.normal THEN
          amp$put_next (log_file_id, message, message_length, byte_address, status);
        IFEND;

      = mme$volume_unavailable, dme$unable_to_alloc_all_space =
        osp$set_status_condition (nae$logging_suspended, status);
        nap$display_message (status);
        create_log_file (TRUE, log_file_id, log_file_termination_time, status);
        IF status.normal THEN
          REPEAT
            amp$put_next (log_file_id, message, message_length, byte_address, status);
            IF NOT status.normal AND ((status.condition = mme$volume_unavailable) OR
                  (status.condition = dme$unable_to_alloc_all_space)) THEN
              pmp$wait (30000, 30000);
            IFEND;
          UNTIL status.normal OR ((status.condition <> mme$volume_unavailable) AND
                (status.condition <> dme$unable_to_alloc_all_space));
        IFEND;
        IF status.normal THEN
          osp$set_status_condition (nae$logging_resumed, status);
          nap$display_message (status);
          status.normal := TRUE;
        IFEND;

      ELSE
      CASEND;
    IFEND;

  PROCEND write_message_to_log;

MODEND nam$log_me;
*DECK DECK=NAM$MANAGE_NAM_ATTRIBUTES EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? TITLE := 'NOS/VE Command Processors for NAMVE attribute mgmt.' ??
?? NEWTITLE := '  External Procedures and Variables' ??
MODULE nam$manage_nam_attributes;
{
{ The following command procedures are used to modify and display the
{ nam attributes. This module resides on OSF$JOB_TEMPLATE_2DD library.
{
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc nat$nam_attributes
*copyc oss$job_paged_literal
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$build_standard_title
*copyc clp$convert_integer_to_string
*copyc clp$close_display
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_partial_display
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc nap$change_nam_attributes_r3
*copyc nap$get_nam_attributes_r3
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler

TYPE
  nam_attributes_set = SET OF nat$nam_attribute_kind;

VAR
  boolean_string: [STATIC, READ, oss$job_paged_literal] array [boolean] of string (5) := ['FALSE', 'TRUE'];

?? TITLE := 'NAP$CHANGE_NAM_ATTRIBUTES', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$change_nam_attributes (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE change_nam_attr_pdt (
{   enable_statistics, es: boolean = $optional
{   maximum_connections, mc: integer 0..4096 = $optional
{   maximum_login_attempts, mla: integer 1..10 = $optional
{   mci_reset_down_threshold, mrdt: any of
{       key
{         none
{       keyend
{       integer 2..100
{     anyend = $optional
{   ica_reset_down_threshold, irdt: any of
{       key
{         none
{       keyend
{       integer 2..100
{     anyend = $optional
{   additional_login_prompts, alp: list of key
{       all
{       (account, a)
{       (family, f)
{       (project, p)
{       none
{     keyend = $optional
{   force_password_prompt, fpp: boolean = $optional
{   tcpip_refresh_interval, tri: integer 10..86400 = $optional
{   tcpip_stale_release_interval, tsri: integer 10..86400 = $optional
{   directory_version, dv: integer 2..3 = $optional
{   display_directory_traffic, ddt: (BY_NAME, ADVANCED) boolean = $optional
{   log_tcpip_routing, ltr: (BY_NAME, ADVANCED) boolean = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 25] of clt$pdt_parameter_name,
      parameters: array [1 .. 13] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: 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$integer_type_qualifier,
        recend,
      recend,
      type5: 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$integer_type_qualifier,
        recend,
      recend,
      type6: 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 .. 8] of clt$keyword_specification,
        recend,
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type11: record
        header: clt$type_specification_header,
      recend,
      type12: record
        header: clt$type_specification_header,
      recend,
      type13: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [95, 8, 8, 11, 35, 44, 284],
    clc$command, 25, 13, 0, 2, 0, 0, 13, ''], [
    ['ADDITIONAL_LOGIN_PROMPTS       ',clc$nominal_entry, 6],
    ['ALP                            ',clc$abbreviation_entry, 6],
    ['DDT                            ',clc$abbreviation_entry, 11],
    ['DIRECTORY_VERSION              ',clc$nominal_entry, 10],
    ['DISPLAY_DIRECTORY_TRAFFIC      ',clc$nominal_entry, 11],
    ['DV                             ',clc$abbreviation_entry, 10],
    ['ENABLE_STATISTICS              ',clc$nominal_entry, 1],
    ['ES                             ',clc$abbreviation_entry, 1],
    ['FORCE_PASSWORD_PROMPT          ',clc$nominal_entry, 7],
    ['FPP                            ',clc$abbreviation_entry, 7],
    ['ICA_RESET_DOWN_THRESHOLD       ',clc$nominal_entry, 5],
    ['IRDT                           ',clc$abbreviation_entry, 5],
    ['LOG_TCPIP_ROUTING              ',clc$nominal_entry, 12],
    ['LTR                            ',clc$abbreviation_entry, 12],
    ['MAXIMUM_CONNECTIONS            ',clc$nominal_entry, 2],
    ['MAXIMUM_LOGIN_ATTEMPTS         ',clc$nominal_entry, 3],
    ['MC                             ',clc$abbreviation_entry, 2],
    ['MCI_RESET_DOWN_THRESHOLD       ',clc$nominal_entry, 4],
    ['MLA                            ',clc$abbreviation_entry, 3],
    ['MRDT                           ',clc$abbreviation_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 13],
    ['TCPIP_REFRESH_INTERVAL         ',clc$nominal_entry, 8],
    ['TCPIP_STALE_RELEASE_INTERVAL   ',clc$nominal_entry, 9],
    ['TRI                            ',clc$abbreviation_entry, 8],
    ['TSRI                           ',clc$abbreviation_entry, 9]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84, clc$optional_parameter,
  0, 0],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 319,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 8
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 9
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 10
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 11
    [5, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 12
    [13, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 13
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, 4096, 10]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, 10, 10]],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [2, 100, 10]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [2, 100, 10]]
    ],
{ PARAMETER 6
    [[1, 0, clc$list_type], [303, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [8], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['ACCOUNT                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['FAMILY                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['PROJECT                        ', clc$nominal_entry, clc$normal_usage_entry, 4]]
      ]
    ],
{ PARAMETER 7
    [[1, 0, clc$boolean_type]],
{ PARAMETER 8
    [[1, 0, clc$integer_type], [10, 86400, 10]],
{ PARAMETER 9
    [[1, 0, clc$integer_type], [10, 86400, 10]],
{ PARAMETER 10
    [[1, 0, clc$integer_type], [2, 3, 10]],
{ PARAMETER 11
    [[1, 0, clc$boolean_type]],
{ PARAMETER 12
    [[1, 0, clc$boolean_type]],
{ PARAMETER 13
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$enable_statistics = 1,
      p$maximum_connections = 2,
      p$maximum_login_attempts = 3,
      p$mci_reset_down_threshold = 4,
      p$ica_reset_down_threshold = 5,
      p$additional_login_prompts = 6,
      p$force_password_prompt = 7,
      p$tcpip_refresh_interval = 8,
      p$tcpip_stale_release_interval = 9,
      p$directory_version = 10,
      p$display_directory_traffic = 11,
      p$log_tcpip_routing = 12,
      p$status = 13;

    VAR
      pvt: array [1 .. 13] of clt$parameter_value;

    VAR
      attribute_seq: ^SEQ ( REP nac$max_nam_attributes OF nat$nam_attribute),
      keyword: clt$keyword,
      list_element: ^clt$data_value,
      local_status: ost$status,
      nam_attributes: ^nat$nam_attributes,
      parameter_count: integer,
      prompt_for_account: boolean,
      prompt_for_family: boolean,
      prompt_for_project: boolean;

    status.normal := TRUE;
    parameter_count := 0;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH attribute_seq;
    RESET attribute_seq;
    NEXT nam_attributes: [1 .. nac$max_nam_attributes] IN attribute_seq;

    IF pvt [p$enable_statistics].specified THEN
      parameter_count := parameter_count + 1;
      nam_attributes^ [parameter_count].kind := nac$enable_statistics_attr;
      nam_attributes^ [parameter_count].enable_statistics := pvt [p$enable_statistics].value^.boolean_value.
            value;
    IFEND;

    IF pvt [p$maximum_connections].specified THEN
      parameter_count := parameter_count + 1;
      nam_attributes^ [parameter_count].kind := nac$max_connections_attr;
      nam_attributes^ [parameter_count].maximum_connections := pvt [p$maximum_connections].value^.
            integer_value.value;
    IFEND;

    IF pvt [p$maximum_login_attempts].specified THEN
      parameter_count := parameter_count + 1;
      nam_attributes^ [parameter_count].kind := nac$maximum_login_attempts_attr;
      nam_attributes^ [parameter_count].maximum_login_attempts := pvt [p$maximum_login_attempts].value^.
            integer_value.value;
    IFEND;

    IF pvt [p$ica_reset_down_threshold].specified THEN
      parameter_count := parameter_count + 1;
      nam_attributes^ [parameter_count].kind := nac$ica_reset_down_thresh_attr;
      IF pvt [p$ica_reset_down_threshold].value^.kind = clc$keyword THEN
        nam_attributes^ [parameter_count].ica_reset_down_threshold := 0;
      ELSE
        nam_attributes^ [parameter_count].ica_reset_down_threshold := pvt [p$ica_reset_down_threshold].value^.
              integer_value.value;
      IFEND;
    IFEND;

    IF pvt [p$mci_reset_down_threshold].specified THEN
      parameter_count := parameter_count + 1;
      nam_attributes^ [parameter_count].kind := nac$mci_reset_down_thresh_attr;
      IF pvt [p$mci_reset_down_threshold].value^.kind = clc$keyword THEN
        nam_attributes^ [parameter_count].mci_reset_down_threshold := 0;
      ELSE
        nam_attributes^ [parameter_count].mci_reset_down_threshold := pvt [p$mci_reset_down_threshold].value^.
              integer_value.value;
      IFEND;
    IFEND;

    IF pvt [p$additional_login_prompts].specified THEN
      prompt_for_family := FALSE;
      prompt_for_account := FALSE;
      prompt_for_project := FALSE;

      list_element := pvt [p$additional_login_prompts].value;
      WHILE list_element <> NIL DO
        keyword := list_element^.element_value^.keyword_value;
        IF keyword = 'ALL' THEN
          prompt_for_family := TRUE;
          prompt_for_account := TRUE;
          prompt_for_project := TRUE;
        ELSEIF (keyword = 'FAMILY') THEN
          prompt_for_family := TRUE;
        ELSEIF (keyword = 'ACCOUNT') THEN
          prompt_for_account := TRUE;
        ELSEIF (keyword = 'PROJECT') THEN
          prompt_for_project := TRUE;
        ELSE  { keyword NONE specified
          prompt_for_family := FALSE;
          prompt_for_account := FALSE;
          prompt_for_project := FALSE;
        IFEND;
        list_element := list_element^.link;
      WHILEND;
      parameter_count := parameter_count + 1;
      nam_attributes^ [parameter_count].kind := nac$prompt_for_family_name_attr;
      nam_attributes^ [parameter_count].prompt_for_family_name := prompt_for_family;
      parameter_count := parameter_count + 1;
      nam_attributes^ [parameter_count].kind := nac$prompt_for_account_attr;
      nam_attributes^ [parameter_count].prompt_for_account := prompt_for_account;
      parameter_count := parameter_count + 1;
      nam_attributes^ [parameter_count].kind := nac$prompt_for_project_attr;
      nam_attributes^ [parameter_count].prompt_for_project := prompt_for_project;
    IFEND;

    IF pvt [p$force_password_prompt].specified THEN
      parameter_count := parameter_count + 1;
      nam_attributes^ [parameter_count].kind := nac$force_password_prompt_attr;
      nam_attributes^ [parameter_count].force_password_prompt := pvt [p$force_password_prompt].value^.
            boolean_value.value;
    IFEND;

    IF pvt [p$tcpip_refresh_interval].specified THEN
      parameter_count := parameter_count + 1;
      nam_attributes^ [parameter_count].kind := nac$tcpip_refresh_interval;
      nam_attributes^ [parameter_count].tcpip_refresh_interval := pvt [p$tcpip_refresh_interval].
            value^.integer_value.value * 1000;
    IFEND;

    IF pvt [p$tcpip_stale_release_interval].specified THEN
      parameter_count := parameter_count + 1;
      nam_attributes^ [parameter_count].kind := nac$tcpip_stale_release_intervl;
      nam_attributes^ [parameter_count].tcpip_stale_release_interval := pvt [p$tcpip_stale_release_interval].
            value^.integer_value.value * 1000;
    IFEND;

    IF pvt [p$directory_version].specified THEN
      parameter_count := parameter_count + 1;
      nam_attributes^ [parameter_count].kind := nac$directory_version;
      nam_attributes^ [parameter_count].directory_version := pvt [p$directory_version].value^.integer_value.
            value;
    IFEND;

    IF pvt [p$display_directory_traffic].specified THEN
      parameter_count := parameter_count + 1;
      nam_attributes^ [parameter_count].kind := nac$display_directory_traffic;
      nam_attributes^ [parameter_count].display_directory_traffic := pvt [p$display_directory_traffic].value^.
            boolean_value.value;
    IFEND;

    IF pvt [p$log_tcpip_routing].specified THEN
      parameter_count := parameter_count + 1;
      nam_attributes^ [parameter_count].kind := nac$log_tcpip_routing;
      nam_attributes^ [parameter_count].log_tcpip_routing := pvt [p$log_tcpip_routing].value^.
            boolean_value.value;
    IFEND;

    IF parameter_count > 0 THEN
      RESET attribute_seq;
      NEXT nam_attributes: [1 .. parameter_count] IN attribute_seq;
      nap$change_nam_attributes_r3 (nam_attributes^,status );
    IFEND;

  PROCEND nap$change_nam_attributes;
?? TITLE := 'nap$display_nam_attributes', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$display_nam_attributes (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE display_nam_attr_pdt (
{   display_options, display_option, do: list of key
{       all
{       (enable_statistics, es)
{       (maximum_connections, mc)
{       (current_connections, cc)
{       (maximum_login_attempts, mla)
{       (mci_reset_down_threshold, mrdt)
{       (ica_reset_down_threshold, irdt)
{       (prompt_for_login_account, pfla)
{       (prompt_for_login_family, pflf)
{       (prompt_for_login_project, pflp)
{       (force_password_prompt, fpp)
{       (system_identifier, si)
{       (tcpip_refresh_interval, tri)
{       (tcpip_stale_release_interval, tsri)
{       (directory_version, dv)
{     keyend = all
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: 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 .. 29] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 7, 31, 10, 51, 13, 726],
    clc$command, 6, 3, 0, 0, 0, 0, 3, ''], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 1],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 1],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 1096, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [1080, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [29], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['CC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
      ['CURRENT_CONNECTIONS            ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['DIRECTORY_VERSION              ', clc$nominal_entry,
  clc$normal_usage_entry, 15],
      ['DV                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 15],
      ['ENABLE_STATISTICS              ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['ES                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
      ['FORCE_PASSWORD_PROMPT          ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
      ['FPP                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 11],
      ['ICA_RESET_DOWN_THRESHOLD       ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
      ['IRDT                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
      ['MAXIMUM_CONNECTIONS            ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['MAXIMUM_LOGIN_ATTEMPTS         ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
      ['MC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
      ['MCI_RESET_DOWN_THRESHOLD       ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
      ['MLA                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
      ['MRDT                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
      ['PFLA                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
      ['PFLF                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
      ['PFLP                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
      ['PROMPT_FOR_LOGIN_ACCOUNT       ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
      ['PROMPT_FOR_LOGIN_FAMILY        ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
      ['PROMPT_FOR_LOGIN_PROJECT       ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
      ['SI                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 12],
      ['SYSTEM_IDENTIFIER              ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
      ['TCPIP_REFRESH_INTERVAL         ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
      ['TCPIP_STALE_RELEASE_INTERVAL   ', clc$nominal_entry,
  clc$normal_usage_entry, 14],
      ['TRI                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 13],
      ['TSRI                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 14]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$display_options = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;
*copyc clv$display_variables
?? NEWTITLE := 'abort_handler', EJECT ??
  PROCEDURE abort_handler (condition: pmt$condition;
        condition_information: ^pmt$condition_information;
        save_area: ^ost$stack_frame_save_area;
    VAR handler_status: ost$status);

    VAR
      ignore_status: ost$status;

    IF output_open THEN
      clp$close_display (display_control, ignore_status);
      output_open := FALSE;
    IFEND;

  PROCEND abort_handler;
*copyc clp$new_page_procedure
?? TITLE := 'put_subtitle ', EJECT ??

    PROCEDURE put_subtitle (VAR display_control: clt$display_control;
      VAR status: ost$status);

      clv$subtitles_built := FALSE;

    PROCEND put_subtitle;
?? TITLE := 'put_attribute', EJECT ??

  PROCEDURE put_attribute (header: string ( * );
        value: string ( * ));

    CONST
      max_attribute_name_size = 31,
      tab_over = max_attribute_name_size + 3;

    VAR
      edited_header: string (tab_over);

    status.normal := TRUE;
    edited_header := header;
    edited_header (tab_over - 1) := ':';

    clp$put_partial_display (display_control, edited_header, clc$no_trim, amc$start, status);
    IF NOT status.normal THEN
      EXIT nap$display_nam_attributes
    IFEND;
    clp$put_partial_display (display_control, value, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      EXIT nap$display_nam_attributes
    IFEND;

  PROCEND put_attribute;
?? OLDTITLE, EJECT ??
      VAR
        attribute: nat$nam_attribute_kind,
        attributes: nam_attributes_set,
        attribute_seq: ^SEQ ( REP nac$max_nam_attributes OF nat$nam_attribute),
        attribute_count: 0 .. nac$max_nam_attributes,
        default_ring_attributes: amt$ring_attributes,
        display_control: clt$display_control,
        i: integer,
        keyword: clt$keyword,
        local_status: ost$status,
        number_string: ost$string,
        requested_attributes: ^nat$nam_attributes,
        output_open: boolean,
        value: ^clt$data_value;

      status.normal := TRUE;
      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      attributes := $nam_attributes_set [];
      value := pvt [p$display_options].value;

    /get_attributes/
      WHILE value <> NIL DO
        keyword := value^.element_value^.keyword_value;
        IF (keyword = 'ALL') THEN
          attributes := -$nam_attributes_set [];
          EXIT /get_attributes/;
        ELSEIF (keyword = 'ENABLE_STATISTICS') THEN
          attributes := attributes + $nam_attributes_set [nac$enable_statistics_attr];
        ELSEIF (keyword = 'MAXIMUM_CONNECTIONS') THEN
          attributes := attributes + $nam_attributes_set [nac$max_connections_attr];
        ELSEIF (keyword = 'MAXIMUM_LOGIN_ATTEMPTS') THEN
          attributes := attributes + $nam_attributes_set [nac$maximum_login_attempts_attr];
        ELSEIF (keyword = 'MCI_RESET_DOWN_THRESHOLD') THEN
          attributes := attributes + $nam_attributes_set [nac$mci_reset_down_thresh_attr];
        ELSEIF (keyword = 'ICA_RESET_DOWN_THRESHOLD') THEN
          attributes := attributes + $nam_attributes_set [nac$ica_reset_down_thresh_attr];
        ELSEIF (keyword = 'PROMPT_FOR_LOGIN_ACCOUNT') THEN
          attributes := attributes + $nam_attributes_set [nac$prompt_for_account_attr];
        ELSEIF (keyword = 'PROMPT_FOR_LOGIN_FAMILY') THEN
          attributes := attributes + $nam_attributes_set [nac$prompt_for_family_name_attr];
        ELSEIF (keyword = 'PROMPT_FOR_LOGIN_PROJECT') THEN
          attributes := attributes + $nam_attributes_set [nac$prompt_for_project_attr];
        ELSEIF (keyword = 'CURRENT_CONNECTIONS') THEN
          attributes := attributes + $nam_attributes_set [nac$current_connections_status];
        ELSEIF (keyword = 'FORCE_PASSWORD_PROMPT') THEN
          attributes := attributes + $nam_attributes_set [nac$force_password_prompt_attr];
        ELSEIF (keyword = 'SYSTEM_IDENTIFIER') THEN
          attributes := attributes + $nam_attributes_set [nac$system_identifier_attr];
        ELSEIF (keyword = 'TCPIP_REFRESH_INTERVAL') THEN
          attributes := attributes + $nam_attributes_set [nac$tcpip_refresh_interval];
        ELSEIF (keyword = 'TCPIP_STALE_RELEASE_INTERVAL') THEN
          attributes := attributes + $nam_attributes_set [nac$tcpip_stale_release_intervl];
        ELSEIF (keyword = 'DIRECTORY_VERSION') THEN
          attributes := attributes + $nam_attributes_set [nac$directory_version];
        IFEND;
        value := value^.link;
      WHILEND /get_attributes/;

      output_open := FALSE;
      default_ring_attributes.r1 := #RING (^default_ring_attributes);
      default_ring_attributes.r2 := #RING (^default_ring_attributes);
      default_ring_attributes.r3 := #RING (^default_ring_attributes);

      osp$establish_block_exit_hndlr (^abort_handler);
      clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
            default_ring_attributes, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      output_open := TRUE;
      clv$titles_built := FALSE;
      clv$command_name := 'display_nam_attributes';
      IF display_control.page_width < clc$narrow_page_width THEN
        clv$page_width := clc$narrow_page_width;
      ELSEIF display_control.page_width > clc$wide_page_width THEN
        clv$page_width := clc$wide_page_width;
      ELSE
        clv$page_width := display_control.page_width;
      IFEND;

      PUSH attribute_seq;
      RESET attribute_seq;
      NEXT requested_attributes: [1 .. nac$max_nam_attributes] IN attribute_seq;
      attribute_count := 0;
      FOR attribute := LOWERVALUE (attribute) TO UPPERVALUE (attribute) DO
        IF attribute IN attributes THEN
          attribute_count := attribute_count + 1;
          requested_attributes^ [attribute_count].kind := attribute;
        IFEND;
      FOREND;
      RESET attribute_seq;
      NEXT requested_attributes: [1 .. attribute_count] IN attribute_seq;

      nap$get_nam_attributes_r3 (requested_attributes^,status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      FOR i := 1 TO attribute_count DO
        CASE requested_attributes^ [i].kind OF
        = nac$enable_statistics_attr =
          put_attribute ('Enable_Statistics', boolean_string [requested_attributes^ [i].enable_statistics]);

        = nac$max_connections_attr =
          clp$convert_integer_to_string (requested_attributes^ [i].maximum_connections,
                10, FALSE, number_string, {ignore} local_status);
          put_attribute ('Maximum_Connections', number_string.value (1, number_string.size));

        = nac$current_connections_status =
          clp$convert_integer_to_string (requested_attributes^ [i].current_connections,
                10, FALSE, number_string, {ignore} local_status);
          put_attribute ('Current_Connections', number_string.value (1, number_string.size));

        = nac$maximum_login_attempts_attr =
          clp$convert_integer_to_string (requested_attributes^ [i].maximum_login_attempts,
                10, FALSE, number_string, {ignore} local_status);
          put_attribute ('Maximum_Login_Attempts', number_string.value (1, number_string.size));

        = nac$mci_reset_down_thresh_attr =
          IF requested_attributes^ [i].mci_reset_down_threshold = 0 THEN
            put_attribute ('MCI_Reset_Down_Threshold', 'None');
          ELSE
            clp$convert_integer_to_string (requested_attributes^ [i].mci_reset_down_threshold,
                  10, FALSE, number_string, {ignore} local_status);
            put_attribute ('MCI_Reset_Down_Threshold', number_string.value (1, number_string.size));
          IFEND;

        = nac$ica_reset_down_thresh_attr =
          IF requested_attributes^ [i].ica_reset_down_threshold = 0 THEN
            put_attribute ('ICA_Reset_Down_Threshold', 'None');
          ELSE
            clp$convert_integer_to_string (requested_attributes^ [i].ica_reset_down_threshold,
                  10, FALSE, number_string, {ignore} local_status);
            put_attribute ('ICA_Reset_Down_Threshold', number_string.value (1, number_string.size));
          IFEND;

        = nac$prompt_for_account_attr =
          put_attribute ('Prompt_For_Login_Account', boolean_string
                [requested_attributes^ [i].prompt_for_account]);

        = nac$prompt_for_family_name_attr =
          put_attribute ('Prompt_For_Login_Family', boolean_string
                [requested_attributes^ [i].prompt_for_family_name]);

        = nac$prompt_for_project_attr =
          put_attribute ('Prompt_For_Login_Project', boolean_string
                [requested_attributes^ [i].prompt_for_project]);

        = nac$force_password_prompt_attr =
          put_attribute ('Force_password_prompt', boolean_string
                [requested_attributes^ [i].force_password_prompt]);

        = nac$system_identifier_attr =
          clp$convert_integer_to_string (requested_attributes^ [i].system_id, 16, TRUE, number_string,
                {ignore} local_status);
          put_attribute ('System_identifier', number_string.value (1, number_string.size));

        = nac$tcpip_refresh_interval =
          clp$convert_integer_to_string (requested_attributes^ [i].tcpip_refresh_interval DIV 1000,
                10, FALSE, number_string, {ignore} local_status);
          put_attribute ('TCPIP_Refresh_Interval', number_string.value (1, number_string.size));

        = nac$tcpip_stale_release_intervl =
          clp$convert_integer_to_string (requested_attributes^ [i].tcpip_stale_release_interval DIV 1000,
                10, FALSE, number_string, {ignore} local_status);
          put_attribute ('TCPIP_Stale_Release_Interval', number_string.value (1, number_string.size));

        = nac$directory_version =
          clp$convert_integer_to_string (requested_attributes^ [i].directory_version, 10, FALSE,
                number_string, {ignore} local_status);
          put_attribute ('Directory_version', number_string.value (1, number_string.size));

        ELSE
        CASEND;
      FOREND;

      IF output_open THEN
        clp$close_display (display_control, status);
        output_open := FALSE;
      IFEND;

      osp$disestablish_cond_handler;

  PROCEND nap$display_nam_attributes;

MODEND nam$manage_nam_attributes;
*DECK DECK=NAM$MANAGE_NAM_ATTRIBUTES_R3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access : Nam Attribute Management Ring 3' ??
MODULE nam$manage_nam_attributes_r3;

{ PURPOSE:
{   This module contains the ring 3 procedures to manage the NAM/VE configurable
{   attributes.
{

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nat$am_login_prompt
*copyc nat$nam_attributes
*copyc nat$protocol_stack
*copyc nat$protocol_stack_integer
*copyc nlc$bm_buffer_pool_index
*copyc nlc$bm_minimum_buffers_for_cpu
*copyc nlc$nam_configuration_constants
*copyc nlt$connections_per_system
*copyc nlt$network_device_list
*copyc ofe$error_codes
?? POP ??
*copyc avp$configuration_administrator
*copyc avp$system_displays
*copyc nap$change_nam_attributes_r1
*copyc nap$get_nam_attributes_r1
*copyc nap$system_id
*copyc nlp$get_exclusive_access
*copyc nlp$release_exclusive_access
*copyc osp$clear_signature_lock
*copyc osp$set_signature_lock
*copyc osp$set_status_abnormal
*copyc nav$change_nam_attributes_lock
*copyc nav$final_login_prompt
*copyc nav$global_osi_statistics
*copyc nav$global_statistics
*copyc nav$ica_reset_down_threshold
*copyc nav$maximum_login_attempts
*copyc nav$mci_reset_down_threshold
*copyc nav$network_paged_heap
*copyc nav$force_password_prompt
*copyc nav$prompt_for_account
*copyc nav$prompt_for_family_name
*copyc nav$prompt_for_project
*copyc nav$statistics_enabled
*copyc nlv$bm_allocat_buffer_threshold
*copyc nlv$bm_allocated_buffer_maximum
*copyc nlv$bm_allocated_buffer_pool
*copyc nlv$configured_network_devices
*copyc nlv$directory_version

  VAR
    nlv$log_broadcast_requests: [XREF] boolean,
    nlv$log_broadcast_translations: [XREF] boolean,
    nlv$log_tcpip_device_select: [XREF] boolean;

*copyc nlv$tm_route_cache
?? TITLE := 'initialize_global_statistics', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to allocate space for the intranet statistics
{   and set the intranet and namve statistic values to zero.
{

  PROCEDURE initialize_global_statistics;

    VAR
      i: integer,
      network_device_list: ^nlt$network_device_list,
      networks_count: integer;

    networks_count := 0;
    network_device_list := nlv$configured_network_devices.network_device_list;
    IF network_device_list <> NIL THEN
      networks_count := UPPERBOUND (network_device_list^);
      IF nav$global_statistics.intranet = NIL THEN

{ Allocate space for the intranet statistic data structure.

        REPEAT
          ALLOCATE nav$global_statistics.intranet: [1 .. networks_count] IN nav$network_paged_heap^;
          IF nav$global_statistics.intranet = NIL THEN
            syp$cycle;
          IFEND;
        UNTIL nav$global_statistics.intranet <> NIL;
      ELSE

{ Reset the namve statistic values to zero since statistics collection is being
{ enabled after being previously disabled.

        nav$global_statistics.internet.broadcasts_sent := 0;
        nav$global_statistics.internet.pdus_received := 0;
        nav$global_statistics.internet.pdus_sent := 0;
        nav$global_statistics.internet.pdus_relayed := 0;
        nav$global_statistics.internet.pdus_routed_locally := 0;

        nav$global_statistics.transport.initiated_connections := 0;
        nav$global_statistics.transport.active_connections := 0;
        nav$global_statistics.transport.reference_number_wait := 0;
        nav$global_statistics.transport.connections_terminated := 0;
        nav$global_statistics.transport.data_packets_received := 0;
        nav$global_statistics.transport.data_packets_sent := 0;
        nav$global_statistics.transport.discarded_data_packets := 0;
        nav$global_statistics.transport.duplicate_data_packets := 0;
        nav$global_statistics.transport.xdata_packets_received := 0;
        nav$global_statistics.transport.xdata_packets_sent := 0;
        nav$global_statistics.transport.discarded_xdata_packets := 0;
        nav$global_statistics.transport.duplicate_xdata_packets := 0;
        nav$global_statistics.transport.acknowledgment_requests_recved := 0;
        nav$global_statistics.transport.acknowledgment_requests_sent := 0;
        nav$global_statistics.transport.acknowledgments_discarded := 0;
        nav$global_statistics.transport.probe_packets_received := 0;
        nav$global_statistics.transport.probe_packets_sent := 0;
        nav$global_statistics.transport.probe_packets_discarded := 0;
        nav$global_statistics.transport.retransmissions := 0;
        nav$global_statistics.transport.error_packets_received := 0;
        nav$global_statistics.transport.error_packets_sent := 0;

        nav$global_statistics.session.synchronize_requests_received := 0;
        nav$global_statistics.session.synchronize_requests_sent := 0;
        nav$global_statistics.session.interrupt_requests_received := 0;
        nav$global_statistics.session.interrupt_requests_sent := 0;

        nav$global_statistics.routing.duplicate_received_ridus := 0;
        nav$global_statistics.routing.ridus_received := 0;
        nav$global_statistics.routing.ridus_sent := 0;
        nav$global_statistics.routing.ridus_aged_out := 0;
        nav$global_statistics.routing.table_recomputed_direct_network := 0;
        nav$global_statistics.routing.table_recomputed_remote_network := 0;
        nav$global_statistics.routing.table_partial_updates := 0;

        nav$global_statistics.directory.current_registered_titles := 0;
        nav$global_statistics.directory.current_cache_entries := 0;
        nav$global_statistics.directory.directory_searches_active := 0;
        nav$global_statistics.directory.directory_searches_initiated := 0;
        nav$global_statistics.directory.translations_delivered := 0;
        nav$global_statistics.directory.translations_found_in_local_dir := 0;
        nav$global_statistics.directory.translations_found_in_cache := 0;
        nav$global_statistics.directory.broadcast_translations_received := 0;
        nav$global_statistics.directory.translations_broadcast := 0;
        nav$global_statistics.directory.translations_received := 0;
        nav$global_statistics.directory.translations_sent := 0;
        nav$global_statistics.directory.translation_requests_broadcast := 0;
        nav$global_statistics.directory.translation_requests_received := 0;

        nav$global_statistics.file_access.active_connections := 0;
        nav$global_statistics.file_access.file_access_requests := 0;

        nav$global_statistics.buffer_manager.descriptor_pool_empty_count := 0;
        nav$global_statistics.buffer_manager.containers_allocated [1] := 0;
        nav$global_statistics.buffer_manager.containers_allocated [2] := 0;
        nav$global_statistics.buffer_manager.containers_freed [1] := 0;
        nav$global_statistics.buffer_manager.containers_freed [2] := 0;

        nav$global_statistics.pp_buffer_pool.empty_pools_count [1] := 0;
        nav$global_statistics.pp_buffer_pool.empty_pools_count [2] := 0;
        nav$global_statistics.pp_buffer_pool.pools_replenished [1] := 0;
        nav$global_statistics.pp_buffer_pool.pools_replenished [2] := 0;

      IFEND;

{ Set the intranet statistic values to zero.

      FOR i := 1 TO networks_count DO
        nav$global_statistics.intranet^ [i].current_send_pdus_queued := 0;
        nav$global_statistics.intranet^ [i].logical_unit_number := network_device_list^ [i].logical_unit;
        nav$global_statistics.intranet^ [i].multicasts_received := 0;
        nav$global_statistics.intranet^ [i].multicasts_sent := 0;
        nav$global_statistics.intranet^ [i].network_id := 0;
        nav$global_statistics.intranet^ [i].receive.value := 0;
        nav$global_statistics.intranet^ [i].receive_pdus_discarded := 0;
        nav$global_statistics.intranet^ [i].send.value := 0;
        nav$global_statistics.intranet^ [i].send_pdus_discarded := 0;
      FOREND;

{ Initialize NAM/VE global osi statistics.

      IF nav$global_osi_statistics.channel_connection_device = NIL THEN
        REPEAT
          ALLOCATE nav$global_osi_statistics.channel_connection_device: [1 .. networks_count]
                IN nav$network_paged_heap^;
          IF nav$global_osi_statistics.channel_connection_device = NIL THEN
            syp$cycle;
          IFEND;
        UNTIL nav$global_osi_statistics.channel_connection_device <> NIL;
      ELSE

{ Reset the namve statistic values to zero since statistics collection is being
{ enabled after being previously disabled.

        nav$global_osi_statistics.channel_connection.broadcast_connect_requests := 0;
        nav$global_osi_statistics.channel_connection.normal_connections := 0;
        nav$global_osi_statistics.channel_connection.priority_connections := 0;

        nav$global_osi_statistics.link_access_agent.current_saps_open := 0;
        nav$global_osi_statistics.link_access_agent.pdus_received := 0;
        nav$global_osi_statistics.link_access_agent.pdus_sent := 0;
        nav$global_osi_statistics.link_access_agent.total_bytes_received := 0;
        nav$global_osi_statistics.link_access_agent.total_bytes_sent := 0;

        nav$global_osi_statistics.network_access_agent.broadcasts_sent := 0;
        nav$global_osi_statistics.network_access_agent.pdus_received := 0;
        nav$global_osi_statistics.network_access_agent.pdus_sent := 0;
        nav$global_osi_statistics.network_access_agent.total_bytes_received := 0;
        nav$global_osi_statistics.network_access_agent.total_bytes_sent := 0;

        nav$global_osi_statistics.system_management_entity.cdna_address_select_device_reqs := 0;
        nav$global_osi_statistics.system_management_entity.noncdna_addr_select_device_reqs := 0;
        nav$global_osi_statistics.system_management_entity.cdna_address_route_unknown := 0;
        nav$global_osi_statistics.system_management_entity.noncdna_address_route_unknown := 0;
        nav$global_osi_statistics.system_management_entity.device_routing_queries := 0;
        nav$global_osi_statistics.system_management_entity.subnet_attribute_updates_rcvd := 0;

        nav$global_osi_statistics.transport_access_agent.data_pdus_received := 0;
        nav$global_osi_statistics.transport_access_agent.data_pdus_sent := 0;
        nav$global_osi_statistics.transport_access_agent.expedited_pdus_received := 0;
        nav$global_osi_statistics.transport_access_agent.expedited_pdus_sent := 0;
        nav$global_osi_statistics.transport_access_agent.total_bytes_received := 0;
        nav$global_osi_statistics.transport_access_agent.total_bytes_sent := 0;
      IFEND;

      FOR i := 1 TO networks_count DO
        nav$global_osi_statistics.channel_connection_device^ [i].network_id := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].credit_pdus_received := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].credit_pdus_sent := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].current_normal_connections := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].current_priority_connections := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].device_resets := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].duplicate_connect_indications := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].normal_send_pdus_queued := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].pdus_processed_out_of_order := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].priority_receive.value := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].priority_receive_expedited_pdus := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].priority_receive_pdus_discarded := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].priority_send.value := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].priority_send_expedited_pdus := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].priority_send_pdus_discarded := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].priority_send_pdus_queued := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].receive.value := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].receive_pdus_discarded := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].received_expedited_pdus := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].send.value := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].send_expedited_pdus := 0;
        nav$global_osi_statistics.channel_connection_device^ [i].send_pdus_discarded := 0;
      FOREND;
    IFEND;
  PROCEND initialize_global_statistics;
?? TITLE := '[XDCL, #GATE] nap$change_nam_attributes_r3', EJECT ??

{ PURPOSE:
{   Store the new values for the nam attributes in the network paged heap.
{

  PROCEDURE [XDCL, #GATE] nap$change_nam_attributes_r3 (
         nam_attributes: nat$nam_attributes;
     VAR status:  ost$status);

    VAR
      i: integer,
      j: integer;

    IF NOT avp$configuration_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      RETURN;
    IFEND;

    osp$set_signature_lock (nav$change_nam_attributes_lock, osc$wait, status);

    FOR i := LOWERBOUND (nam_attributes) TO UPPERBOUND (nam_attributes) DO
      CASE nam_attributes [i].kind OF
      = nac$enable_statistics_attr =
        IF NOT nav$statistics_enabled THEN

{ Initialize the global statistic fields if statistics collection is turned on.

          IF nam_attributes [i].enable_statistics THEN
            nlp$get_exclusive_access (nlv$configured_network_devices.access_control);
            initialize_global_statistics;
            nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
          IFEND;
        IFEND;
        nav$statistics_enabled := nam_attributes [i].enable_statistics;

      = nac$ica_reset_down_thresh_attr =
        nav$ica_reset_down_threshold := nam_attributes [i].ica_reset_down_threshold;

      = nac$max_connections_attr =
        nap$change_nam_attributes_r1 (nac$max_connections_attr, nam_attributes [i]);

        IF nam_attributes [i].maximum_connections > nlc$default_maximum_connections THEN
          nlv$bm_allocated_buffer_maximum := nam_attributes [i].maximum_connections * 2;
        ELSE
          nlv$bm_allocated_buffer_maximum := nlc$default_maximum_connections * 2;
        IFEND;
        IF nlv$bm_allocated_buffer_maximum > (nlv$bm_allocated_buffer_pool [nlc$bm_large_buffer_index].
              sub_pool_allocation_size * UPPERBOUND (nlv$bm_allocated_buffer_pool [nlc$bm_large_buffer_index].
              sub_pool^)) THEN
          nlv$bm_allocated_buffer_maximum := nlv$bm_allocated_buffer_pool [nlc$bm_large_buffer_index].
              sub_pool_allocation_size * UPPERBOUND (nlv$bm_allocated_buffer_pool [nlc$bm_large_buffer_index].
              sub_pool^);
        IFEND;
        nlv$bm_allocat_buffer_threshold := nlv$bm_allocated_buffer_maximum - nlc$bm_minimum_buffers_for_cpu;

      = nac$maximum_login_attempts_attr =
        nav$maximum_login_attempts := nam_attributes [i].maximum_login_attempts;

      = nac$mci_reset_down_thresh_attr =
        nav$mci_reset_down_threshold := nam_attributes [i].mci_reset_down_threshold;

      = nac$prompt_for_family_name_attr =
        nav$prompt_for_family_name := nam_attributes [i].prompt_for_family_name;

      = nac$prompt_for_account_attr =
        nav$prompt_for_account := nam_attributes [i].prompt_for_account;

      = nac$prompt_for_project_attr =
        nav$prompt_for_project := nam_attributes [i].prompt_for_project;

      = nac$force_password_prompt_attr =
        nav$force_password_prompt := nam_attributes [i].force_password_prompt;

      = nac$tcpip_refresh_interval =
        nlv$tm_route_cache.refresh_interval := nam_attributes [i].tcpip_refresh_interval;

      = nac$tcpip_stale_release_intervl =
        nlv$tm_route_cache.stale_release_interval := nam_attributes [i].tcpip_stale_release_interval;

      = nac$directory_version =
        nlv$directory_version := nam_attributes [i].directory_version;

      = nac$display_directory_traffic =
        nlv$log_broadcast_requests := nam_attributes [i].display_directory_traffic;
        nlv$log_broadcast_translations := nam_attributes [i].display_directory_traffic;

      = nac$log_tcpip_routing =
        nlv$log_tcpip_device_select := nam_attributes [i].log_tcpip_routing;

      ELSE
      CASEND;
    FOREND;

{ Setup the final prompt of the interactive login dialog.

    IF nav$prompt_for_project THEN
      nav$final_login_prompt := nac$am_project_name;
    ELSEIF nav$prompt_for_account THEN
      nav$final_login_prompt := nac$am_account_name;
    ELSEIF nav$prompt_for_family_name THEN
      nav$final_login_prompt := nac$am_family_name;
    ELSE
      nav$final_login_prompt := nac$am_password;
    IFEND;

    osp$clear_signature_lock (nav$change_nam_attributes_lock, status);

  PROCEND nap$change_nam_attributes_r3;
?? TITLE := '[XDCL, #GATE] nap$get_nam_attributes_r3', EJECT ??

{ PURPOSE:
{   Get the values of the nam attributes from the network paged heap.
{

  PROCEDURE [XDCL, #GATE] nap$get_nam_attributes_r3 (
    VAR nam_attributes: nat$nam_attributes;
    VAR status:  ost$status);

    VAR
      i: integer;

    IF NOT (avp$configuration_administrator () OR avp$system_displays () ) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration OR system_displays',
            status);
      RETURN;
    IFEND;

    FOR i := LOWERBOUND (nam_attributes) TO UPPERBOUND (nam_attributes) DO
      CASE nam_attributes [i].kind OF
      = nac$enable_statistics_attr =
        nam_attributes [i].enable_statistics := nav$statistics_enabled;

      = nac$ica_reset_down_thresh_attr =
        nam_attributes [i].ica_reset_down_threshold := nav$ica_reset_down_threshold;

      = nac$max_connections_attr =
        nap$get_nam_attributes_r1 (nac$max_connections_attr, nam_attributes [i]);

      = nac$maximum_login_attempts_attr =
        nam_attributes [i].maximum_login_attempts := nav$maximum_login_attempts;

      = nac$mci_reset_down_thresh_attr =
        nam_attributes [i].mci_reset_down_threshold := nav$mci_reset_down_threshold;

      = nac$prompt_for_family_name_attr =
        nam_attributes [i].prompt_for_family_name := nav$prompt_for_family_name;

      = nac$prompt_for_account_attr =
        nam_attributes [i].prompt_for_account := nav$prompt_for_account;

      = nac$prompt_for_project_attr =
        nam_attributes [i].prompt_for_project := nav$prompt_for_project;

      = nac$force_password_prompt_attr =
        nam_attributes [i].force_password_prompt := nav$force_password_prompt;

      = nac$current_connections_status =
        nap$get_nam_attributes_r1 (nac$current_connections_status, nam_attributes [i]);

      = nac$tcpip_refresh_interval =
        nam_attributes [i].tcpip_refresh_interval := nlv$tm_route_cache.refresh_interval;

      = nac$tcpip_stale_release_intervl =
        nam_attributes [i].tcpip_stale_release_interval := nlv$tm_route_cache.stale_release_interval;

      = nac$directory_version =
        nam_attributes [i].directory_version := nlv$directory_version;

      = nac$system_identifier_attr =
        nam_attributes [i].system_id := nap$system_id ();

      ELSE
      CASEND;
    FOREND

  PROCEND nap$get_nam_attributes_r3;
?? TITLE := '[XDCL, #GATE] nap$supported_protocol_stacks', EJECT ??

{ PURPOSE:
{   The purpose of this request is to return the protocol stacks supported
{   by NAM/VE.

  FUNCTION [XDCL, #GATE] nap$supported_protocol_stacks: nat$protocol_stack_integer;

    nap$supported_protocol_stacks := nac$osi_protocol_stack;

  FUNCEND nap$supported_protocol_stacks;

MODEND nam$manage_nam_attributes_r3;
*DECK DECK=NAM$MANAGE_NETWORK_APPLICATIONS EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? TITLE := 'NOS/VE: Manage Network Applications Utility' ??
?? NEWTITLE := 'Global Declarations' ??
MODULE nam$manage_network_applications;
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc amv$nil_file_identifier
*copyc clc$page_widths
*copyc clc$standard_file_names
*copyc cle$ecc_command_processing
*copyc clt$command_line_index
*copyc clt$command_line_size
*copyc clt$file
*copyc clt$file_reference
*copyc cyt$string_size
*copyc ift$default_terminal_attributes
*copyc nac$application_catalog_layout
*copyc nac$sk_unnamed_tcp_application
*copyc nac$sk_unnamed_udp_application
*copyc nae$application_interfaces
*copyc nae$manage_network_applications
*copyc nat$application_name
*copyc nat$application_status
*copyc nat$client_attributes
*copyc nat$internet_sap_identifier
*copyc nat$protocol
*copyc nat$server_attributes
*copyc ost$date
*copyc ost$status
*copyc ost$status_message
*copyc ost$string
*copyc ost$time
*copyc pmt$condition
*copyc pmt$condition_information
*copyc pmt$os_name
?? POP ??
*copyc amp$fetch
*copyc amp$get_next
*copyc amp$put_next
*copyc amp$put_partial
*copyc avp$get_capability
*copyc clp$begin_utility
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_file
*copyc clp$close_display
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$get_command_origin
*copyc clp$get_line_from_command_file
*copyc clp$get_path_description
*copyc clp$include_file
*copyc clp$new_display_line
*copyc clp$open_display
*copyc clp$open_display_file
*copyc clp$open_display_reference
*copyc clp$pop_input
*copyc clp$push_input
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc clp$test_parameter
*copyc clp$trimmed_string_size
*copyc clv$nil_block_handle
*copyc clv$nil_display_control
*copyc fsp$close_file
*copyc fsp$open_file
*copyc ifp$discard_suspended_output
*copyc i#move
*copyc nap$applications_installed
*copyc nap$attach_application_file
*copyc nap$activate_client
*copyc nap$activate_server
*copyc nap$activate_tcpip
*copyc nap$change_client
*copyc nap$change_server
*copyc nap$change_tcpip
*copyc nap$close_server_job_file
*copyc nap$deactivate_client
*copyc nap$deactivate_server
*copyc nap$deactivate_tcpip
*copyc nap$define_client
*copyc nap$define_server
*copyc nap$define_tcpip
*copyc nap$delete_client
*copyc nap$delete_server
*copyc nap$delete_tcpip
*copyc nap$detach_application_file
*copyc nap$get_application_names
*copyc nap$get_client_attributes
*copyc nap$get_client_status
*copyc nap$get_server_attributes
*copyc nap$get_server_status
*copyc nap$get_tcpip_attributes
*copyc nap$get_tcpip_status
*copyc nap$open_server_job_file
*copyc nap$verify_application_id
*copyc nap$verify_application_name
*copyc nap$verify_tcpip_name
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pfp$convert_pf_path_to_fs_path
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_unique_name
*copyc pmp$get_legible_date_time
*copyc pmp$get_os_version
*copyc rmp$get_device_class
?? EJECT ??

  CONST
    nac$network_administrator_vers = 'V1.2',
    nac$network_administrator_level = '88230',
    nac$default_ring = 13,
    all_keyword = 'ALL',
    display_spacer = 35,
    default_output_file = '$OUTPUT',
    prompt_string = 'MNA',
    change_server_prompt_string = 'chas',
    change_client_prompt_string = 'chac',
    change_tcpip_prompt_string = 'chat',
    define_server_prompt_string = 'defs',
    define_client_prompt_string = 'defc',
    define_tcpip_prompt_string = 'deft';


  CONST
    continuation_increment = 6,
    continuation_indicator_size = 2,
    indent_increment = 2;

  VAR
    current_indent_column: clt$command_line_index,
    initial_indent_column: clt$command_line_index := 1;

{ table change_client_commands
{ command (change_maximum_connections, chamc) processor =   change_maximum_connections
{ command (change_connection_priority, chacp) processor =   change_connection_priority
{ command (change_client_validation, chacv) processor =   change_client_validation
{ command (change_application_identifier, chaai) processor =   change_application_identifier
{ command (display_client_attributes, display_client_attribute, disca)   processor = ..
{   sub_display_client_attributes
{ command (generate_client_definition, gencd) processor =   sub_generate_client_definition
{ command (end_change_client, quit, qui, endcc) processor = end_change_client

?? PUSH (LISTEXT := ON) ??

  VAR
    change_client_commands: [STATIC, READ] ^clt$command_table := ^change_client_commands_entries,

    change_client_commands_entries: [STATIC, READ] array [1 .. 17] of clt$command_table_entry := [
          {} ['CHAAI                          ', clc$abbreviation_entry, clc$advertised_entry, 4,
          clc$automatically_log, clc$linked_call, ^change_application_identifier],
          {} ['CHACP                          ', clc$abbreviation_entry, clc$advertised_entry, 2,
          clc$automatically_log, clc$linked_call, ^change_connection_priority],
          {} ['CHACV                          ', clc$abbreviation_entry, clc$advertised_entry, 3,
          clc$automatically_log, clc$linked_call, ^change_client_validation],
          {} ['CHAMC                          ', clc$abbreviation_entry, clc$advertised_entry, 1,
          clc$automatically_log, clc$linked_call, ^change_maximum_connections],
          {} ['CHANGE_APPLICATION_IDENTIFIER  ', clc$nominal_entry, clc$advertised_entry, 4,
          clc$automatically_log, clc$linked_call, ^change_application_identifier],
          {} ['CHANGE_CLIENT_VALIDATION       ', clc$nominal_entry, clc$advertised_entry, 3,
          clc$automatically_log, clc$linked_call, ^change_client_validation],
          {} ['CHANGE_CONNECTION_PRIORITY     ', clc$nominal_entry, clc$advertised_entry, 2,
          clc$automatically_log, clc$linked_call, ^change_connection_priority],
          {} ['CHANGE_MAXIMUM_CONNECTIONS     ', clc$nominal_entry, clc$advertised_entry, 1,
          clc$automatically_log, clc$linked_call, ^change_maximum_connections],
          {} ['DISCA                          ', clc$abbreviation_entry, clc$advertised_entry, 5,
          clc$automatically_log, clc$linked_call, ^sub_display_client_attributes],
          {} ['DISPLAY_CLIENT_ATTRIBUTE       ', clc$alias_entry, clc$advertised_entry, 5,
          clc$automatically_log, clc$linked_call, ^sub_display_client_attributes],
          {} ['DISPLAY_CLIENT_ATTRIBUTES      ', clc$nominal_entry, clc$advertised_entry, 5,
          clc$automatically_log, clc$linked_call, ^sub_display_client_attributes],
          {} ['ENDCC                          ', clc$abbreviation_entry, clc$advertised_entry, 7,
          clc$automatically_log, clc$linked_call, ^end_change_client],
          {} ['END_CHANGE_CLIENT              ', clc$nominal_entry, clc$advertised_entry, 7,
          clc$automatically_log, clc$linked_call, ^end_change_client],
          {} ['GENCD                          ', clc$abbreviation_entry, clc$advertised_entry, 6,
          clc$automatically_log, clc$linked_call, ^sub_generate_client_definition],
          {} ['GENERATE_CLIENT_DEFINITION     ', clc$nominal_entry, clc$advertised_entry, 6,
          clc$automatically_log, clc$linked_call, ^sub_generate_client_definition],
          {} ['QUI                            ', clc$alias_entry, clc$advertised_entry, 7,
          clc$automatically_log, clc$linked_call, ^end_change_client],
          {} ['QUIT                           ', clc$alias_entry, clc$advertised_entry, 7,
          clc$automatically_log, clc$linked_call, ^end_change_client]];

?? POP ??


{ table change_server_commands
{ command (add_server_managed_titles, add_server_managed_title, addsmt)   processor = ..
{   add_server_managed_titles
{ command (add_titles, add_title, addt) processor = add_titles
{ command (delete_server_managed_titles, delete_server_managed_title,   delsmt) processor = ..
{   delete_server_managed_titles
{ command (delete_titles, delete_title, delt) processor = delete_titles
{ command (change_server_validation, chasv) processor =   change_server_validation
{ command (change_server_job, chasj) processor = change_server_job
{ command (change_application_identifier, chaai) processor =   change_application_identifier
{ command (change_maximum_connections, chamc) processor =   change_maximum_connections
{ command (change_connection_priority, chacp) processor =   change_connection_priority
{ command (change_accept_connection, chaac) processor =   change_accept_connection
{ command (change_client_validation, chacv) processor =   change_client_server_validation
{ command (change_client_info_source, chacis) processor =   change_client_info_source
{ command (add_client_address, addca) processor = add_client_address
{ command (delete_client_address, delca) processor = delete_client_address
{ command (display_server_attributes, display_server_attribute, dissa)   processor = ..
{   sub_display_server_attributes
{ command (generate_server_definition, gensd) processor =   sub_generate_server_definition
{ command (end_change_server, quit, qui, endcs) processor = end_change_server

?? PUSH (LISTEXT := ON) ??

  VAR
    change_server_commands: [STATIC, READ] ^clt$command_table := ^change_server_commands_entries,

    change_server_commands_entries: [STATIC, READ] array [1 .. 41] of clt$command_table_entry := [
          {} ['ADDCA                          ', clc$abbreviation_entry, clc$advertised_entry, 13,
          clc$automatically_log, clc$linked_call, ^add_client_address],
          {} ['ADDSMT                         ', clc$abbreviation_entry, clc$advertised_entry, 1,
          clc$automatically_log, clc$linked_call, ^add_server_managed_titles],
          {} ['ADDT                           ', clc$abbreviation_entry, clc$advertised_entry, 2,
          clc$automatically_log, clc$linked_call, ^add_titles],
          {} ['ADD_CLIENT_ADDRESS             ', clc$nominal_entry, clc$advertised_entry, 13,
          clc$automatically_log, clc$linked_call, ^add_client_address],
          {} ['ADD_SERVER_MANAGED_TITLE       ', clc$alias_entry, clc$advertised_entry, 1,
          clc$automatically_log, clc$linked_call, ^add_server_managed_titles],
          {} ['ADD_SERVER_MANAGED_TITLES      ', clc$nominal_entry, clc$advertised_entry, 1,
          clc$automatically_log, clc$linked_call, ^add_server_managed_titles],
          {} ['ADD_TITLE                      ', clc$alias_entry, clc$advertised_entry, 2,
          clc$automatically_log, clc$linked_call, ^add_titles],
          {} ['ADD_TITLES                     ', clc$nominal_entry, clc$advertised_entry, 2,
          clc$automatically_log, clc$linked_call, ^add_titles],
          {} ['CHAAC                          ', clc$abbreviation_entry, clc$advertised_entry, 10,
          clc$automatically_log, clc$linked_call, ^change_accept_connection],
          {} ['CHAAI                          ', clc$abbreviation_entry, clc$advertised_entry, 7,
          clc$automatically_log, clc$linked_call, ^change_application_identifier],
          {} ['CHACIS                         ', clc$abbreviation_entry, clc$advertised_entry, 12,
          clc$automatically_log, clc$linked_call, ^change_client_info_source],
          {} ['CHACP                          ', clc$abbreviation_entry, clc$advertised_entry, 9,
          clc$automatically_log, clc$linked_call, ^change_connection_priority],
          {} ['CHACV                          ', clc$abbreviation_entry, clc$advertised_entry, 11,
          clc$automatically_log, clc$linked_call, ^change_client_server_validation],
          {} ['CHAMC                          ', clc$abbreviation_entry, clc$advertised_entry, 8,
          clc$automatically_log, clc$linked_call, ^change_maximum_connections],
          {} ['CHANGE_ACCEPT_CONNECTION       ', clc$nominal_entry, clc$advertised_entry, 10,
          clc$automatically_log, clc$linked_call, ^change_accept_connection],
          {} ['CHANGE_APPLICATION_IDENTIFIER  ', clc$nominal_entry, clc$advertised_entry, 7,
          clc$automatically_log, clc$linked_call, ^change_application_identifier],
          {} ['CHANGE_CLIENT_INFO_SOURCE      ', clc$nominal_entry, clc$advertised_entry, 12,
          clc$automatically_log, clc$linked_call, ^change_client_info_source],
          {} ['CHANGE_CLIENT_VALIDATION       ', clc$nominal_entry, clc$advertised_entry, 11,
          clc$automatically_log, clc$linked_call, ^change_client_server_validation],
          {} ['CHANGE_CONNECTION_PRIORITY     ', clc$nominal_entry, clc$advertised_entry, 9,
          clc$automatically_log, clc$linked_call, ^change_connection_priority],
          {} ['CHANGE_MAXIMUM_CONNECTIONS     ', clc$nominal_entry, clc$advertised_entry, 8,
          clc$automatically_log, clc$linked_call, ^change_maximum_connections],
          {} ['CHANGE_SERVER_JOB              ', clc$nominal_entry, clc$advertised_entry, 6,
          clc$automatically_log, clc$linked_call, ^change_server_job],
          {} ['CHANGE_SERVER_VALIDATION       ', clc$nominal_entry, clc$advertised_entry, 5,
          clc$automatically_log, clc$linked_call, ^change_server_validation],
          {} ['CHASJ                          ', clc$abbreviation_entry, clc$advertised_entry, 6,
          clc$automatically_log, clc$linked_call, ^change_server_job],
          {} ['CHASV                          ', clc$abbreviation_entry, clc$advertised_entry, 5,
          clc$automatically_log, clc$linked_call, ^change_server_validation],
          {} ['DELCA                          ', clc$abbreviation_entry, clc$advertised_entry, 14,
          clc$automatically_log, clc$linked_call, ^delete_client_address],
          {} ['DELETE_CLIENT_ADDRESS          ', clc$nominal_entry, clc$advertised_entry, 14,
          clc$automatically_log, clc$linked_call, ^delete_client_address],
          {} ['DELETE_SERVER_MANAGED_TITLE    ', clc$alias_entry, clc$advertised_entry, 3,
          clc$automatically_log, clc$linked_call, ^delete_server_managed_titles],
          {} ['DELETE_SERVER_MANAGED_TITLES   ', clc$nominal_entry, clc$advertised_entry, 3,
          clc$automatically_log, clc$linked_call, ^delete_server_managed_titles],
          {} ['DELETE_TITLE                   ', clc$alias_entry, clc$advertised_entry, 4,
          clc$automatically_log, clc$linked_call, ^delete_titles],
          {} ['DELETE_TITLES                  ', clc$nominal_entry, clc$advertised_entry, 4,
          clc$automatically_log, clc$linked_call, ^delete_titles],
          {} ['DELSMT                         ', clc$abbreviation_entry, clc$advertised_entry, 3,
          clc$automatically_log, clc$linked_call, ^delete_server_managed_titles],
          {} ['DELT                           ', clc$abbreviation_entry, clc$advertised_entry, 4,
          clc$automatically_log, clc$linked_call, ^delete_titles],
          {} ['DISPLAY_SERVER_ATTRIBUTE       ', clc$alias_entry, clc$advertised_entry, 15,
          clc$automatically_log, clc$linked_call, ^sub_display_server_attributes],
          {} ['DISPLAY_SERVER_ATTRIBUTES      ', clc$nominal_entry, clc$advertised_entry, 15,
          clc$automatically_log, clc$linked_call, ^sub_display_server_attributes],
          {} ['DISSA                          ', clc$abbreviation_entry, clc$advertised_entry, 15,
          clc$automatically_log, clc$linked_call, ^sub_display_server_attributes],
          {} ['ENDCS                          ', clc$abbreviation_entry, clc$advertised_entry, 17,
          clc$automatically_log, clc$linked_call, ^end_change_server],
          {} ['END_CHANGE_SERVER              ', clc$nominal_entry, clc$advertised_entry, 17,
          clc$automatically_log, clc$linked_call, ^end_change_server],
          {} ['GENERATE_SERVER_DEFINITION     ', clc$nominal_entry, clc$advertised_entry, 16,
          clc$automatically_log, clc$linked_call, ^sub_generate_server_definition],
          {} ['GENSD                          ', clc$abbreviation_entry, clc$advertised_entry, 16,
          clc$automatically_log, clc$linked_call, ^sub_generate_server_definition],
          {} ['QUI                            ', clc$alias_entry, clc$advertised_entry, 17,
          clc$automatically_log, clc$linked_call, ^end_change_server],
          {} ['QUIT                           ', clc$alias_entry, clc$advertised_entry, 17,
          clc$automatically_log, clc$linked_call, ^end_change_server]];

?? POP ??

{ table change_tcpip_commands
{ command (change_maximum_sockets, chams) processor =        change_maximum_sockets
{ command (change_tcpip_validation, chatv) processor =       change_tcpip_validation
{ command (display_tcpip_attributes, dista) processor =      sub_display_tcpip_attributes
{ command (generate_tcpip_definition, gentd) processor =     sub_generate_tcpip_definition
{ command (end_change_tcpip_application, endcta, quit, qui) processor = end_change_tcpip_application

?? PUSH (LISTEXT := ON) ??

  VAR
    change_tcpip_commands: [STATIC, READ] ^clt$command_table := ^change_tcpip_commands_entries,

    change_tcpip_commands_entries: [STATIC, READ] array [1 .. 12] of clt$command_table_entry := [
          {} ['CHAMS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^change_maximum_sockets],
          {} ['CHANGE_MAXIMUM_SOCKETS         ', clc$nominal_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^change_maximum_sockets],
          {} ['CHANGE_TCPIP_VALIDATION        ', clc$nominal_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^change_tcpip_validation],
          {} ['CHATV                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^change_tcpip_validation],
          {} ['DISPLAY_TCPIP_ATTRIBUTES       ', clc$nominal_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^sub_display_tcpip_attributes],
          {} ['DISTA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^sub_display_tcpip_attributes],
          {} ['ENDCTA                         ', clc$alias_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^end_change_tcpip_application],
          {} ['END_CHANGE_TCPIP_APPLICATION   ', clc$nominal_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^end_change_tcpip_application],
          {} ['GENERATE_TCPIP_DEFINITION      ', clc$nominal_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^sub_generate_tcpip_definition],
          {} ['GENTD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^sub_generate_tcpip_definition],
          {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^end_change_tcpip_application],
          {} ['QUIT                           ', clc$alias_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^end_change_tcpip_application]];

?? POP ??

{ table define_client_commands
{ command (change_maximum_connections, chamc) processor = change_maximum_connections
{ command (change_connection_priority, chacp) processor = change_connection_priority
{ command (change_client_validation, chacv) processor = change_client_validation
{ command (change_application_identifier, chaai) processor = change_application_identifier
{ command (display_client_attributes, display_client_attribute, disca) processor =         ..
{   sub_display_client_attributes
{ command (generate_client_definition, gencd) processor = sub_generate_client_definition
{ command (end_define_client, quit, qui, enddc) processor = end_define_client

?? PUSH (LISTEXT := ON) ??

  VAR
    define_client_commands: [STATIC, READ] ^clt$command_table := ^define_client_commands_entries,

    define_client_commands_entries: [STATIC, READ] array [1 .. 17] of clt$command_table_entry := [
          {} ['CHAAI                          ', clc$abbreviation_entry, clc$advertised_entry, 4,
          clc$automatically_log, clc$linked_call, ^change_application_identifier],
          {} ['CHACP                          ', clc$abbreviation_entry, clc$advertised_entry, 2,
          clc$automatically_log, clc$linked_call, ^change_connection_priority],
          {} ['CHACV                          ', clc$abbreviation_entry, clc$advertised_entry, 3,
          clc$automatically_log, clc$linked_call, ^change_client_validation],
          {} ['CHAMC                          ', clc$abbreviation_entry, clc$advertised_entry, 1,
          clc$automatically_log, clc$linked_call, ^change_maximum_connections],
          {} ['CHANGE_APPLICATION_IDENTIFIER  ', clc$nominal_entry, clc$advertised_entry, 4,
          clc$automatically_log, clc$linked_call, ^change_application_identifier],
          {} ['CHANGE_CLIENT_VALIDATION       ', clc$nominal_entry, clc$advertised_entry, 3,
          clc$automatically_log, clc$linked_call, ^change_client_validation],
          {} ['CHANGE_CONNECTION_PRIORITY     ', clc$nominal_entry, clc$advertised_entry, 2,
          clc$automatically_log, clc$linked_call, ^change_connection_priority],
          {} ['CHANGE_MAXIMUM_CONNECTIONS     ', clc$nominal_entry, clc$advertised_entry, 1,
          clc$automatically_log, clc$linked_call, ^change_maximum_connections],
          {} ['DISCA                          ', clc$abbreviation_entry, clc$advertised_entry, 5,
          clc$automatically_log, clc$linked_call, ^sub_display_client_attributes],
          {} ['DISPLAY_CLIENT_ATTRIBUTE       ', clc$alias_entry, clc$advertised_entry, 5,
          clc$automatically_log, clc$linked_call, ^sub_display_client_attributes],
          {} ['DISPLAY_CLIENT_ATTRIBUTES      ', clc$nominal_entry, clc$advertised_entry, 5,
          clc$automatically_log, clc$linked_call, ^sub_display_client_attributes],
          {} ['ENDDC                          ', clc$abbreviation_entry, clc$advertised_entry, 7,
          clc$automatically_log, clc$linked_call, ^end_define_client],
          {} ['END_DEFINE_CLIENT              ', clc$nominal_entry, clc$advertised_entry, 7,
          clc$automatically_log, clc$linked_call, ^end_define_client],
          {} ['GENCD                          ', clc$abbreviation_entry, clc$advertised_entry, 6,
          clc$automatically_log, clc$linked_call, ^sub_generate_client_definition],
          {} ['GENERATE_CLIENT_DEFINITION     ', clc$nominal_entry, clc$advertised_entry, 6,
          clc$automatically_log, clc$linked_call, ^sub_generate_client_definition],
          {} ['QUI                            ', clc$alias_entry, clc$advertised_entry, 7,
          clc$automatically_log, clc$linked_call, ^end_define_client],
          {} ['QUIT                           ', clc$alias_entry, clc$advertised_entry, 7,
          clc$automatically_log, clc$linked_call, ^end_define_client]];

?? POP ??

{ table define_server_commands
{ command (add_server_managed_titles, add_server_managed_title, addsmt) processor =         ..
{   add_server_managed_titles
{ command (add_titles, add_title, addt) processor = add_titles
{ command (delete_server_managed_titles, delete_server_managed_title, delsmt) processor =         ..
{   delete_server_managed_titles
{ command (delete_titles, delete_title, delt) processor = delete_titles
{ command (change_server_validation, chasv) processor = change_server_validation
{ command (change_server_job, chasj) processor = change_server_job
{ command (change_application_identifier, chaai) processor = change_application_identifier
{ command (change_maximum_connections, chamc) processor = change_maximum_connections
{ command (change_connection_priority, chacp) processor = change_connection_priority
{ command (change_accept_connection, chaac) processor = change_accept_connection
{ command (change_client_validation, chacv) processor = change_client_server_validation
{ command (change_client_info_source, chacis) processor = change_client_info_source
{ command (add_client_address, addca) processor = add_client_address
{ command (delete_client_address, delca) processor = delete_client_address
{ command (display_server_attributes, display_server_attribute, dissa) processor =             ..
{   sub_display_server_attributes
{ command (generate_server_definition, gensd) processor = sub_generate_server_definition
{ command (end_define_server, quit, qui, endds) processor = end_define_server

?? PUSH (LISTEXT := ON) ??

  VAR
    define_server_commands: [STATIC, READ] ^clt$command_table := ^define_server_commands_entries,

    define_server_commands_entries: [STATIC, READ] array [1 .. 41] of clt$command_table_entry := [
          {} ['ADDCA                          ', clc$abbreviation_entry, clc$advertised_entry, 13,
          clc$automatically_log, clc$linked_call, ^add_client_address],
          {} ['ADDSMT                         ', clc$abbreviation_entry, clc$advertised_entry, 1,
          clc$automatically_log, clc$linked_call, ^add_server_managed_titles],
          {} ['ADDT                           ', clc$abbreviation_entry, clc$advertised_entry, 2,
          clc$automatically_log, clc$linked_call, ^add_titles],
          {} ['ADD_CLIENT_ADDRESS             ', clc$nominal_entry, clc$advertised_entry, 13,
          clc$automatically_log, clc$linked_call, ^add_client_address],
          {} ['ADD_SERVER_MANAGED_TITLE       ', clc$alias_entry, clc$advertised_entry, 1,
          clc$automatically_log, clc$linked_call, ^add_server_managed_titles],
          {} ['ADD_SERVER_MANAGED_TITLES      ', clc$nominal_entry, clc$advertised_entry, 1,
          clc$automatically_log, clc$linked_call, ^add_server_managed_titles],
          {} ['ADD_TITLE                      ', clc$alias_entry, clc$advertised_entry, 2,
          clc$automatically_log, clc$linked_call, ^add_titles],
          {} ['ADD_TITLES                     ', clc$nominal_entry, clc$advertised_entry, 2,
          clc$automatically_log, clc$linked_call, ^add_titles],
          {} ['CHAAC                          ', clc$abbreviation_entry, clc$advertised_entry, 10,
          clc$automatically_log, clc$linked_call, ^change_accept_connection],
          {} ['CHAAI                          ', clc$abbreviation_entry, clc$advertised_entry, 7,
          clc$automatically_log, clc$linked_call, ^change_application_identifier],
          {} ['CHACIS                         ', clc$abbreviation_entry, clc$advertised_entry, 12,
          clc$automatically_log, clc$linked_call, ^change_client_info_source],
          {} ['CHACP                          ', clc$abbreviation_entry, clc$advertised_entry, 9,
          clc$automatically_log, clc$linked_call, ^change_connection_priority],
          {} ['CHACV                          ', clc$abbreviation_entry, clc$advertised_entry, 11,
          clc$automatically_log, clc$linked_call, ^change_client_server_validation],
          {} ['CHAMC                          ', clc$abbreviation_entry, clc$advertised_entry, 8,
          clc$automatically_log, clc$linked_call, ^change_maximum_connections],
          {} ['CHANGE_ACCEPT_CONNECTION       ', clc$nominal_entry, clc$advertised_entry, 10,
          clc$automatically_log, clc$linked_call, ^change_accept_connection],
          {} ['CHANGE_APPLICATION_IDENTIFIER  ', clc$nominal_entry, clc$advertised_entry, 7,
          clc$automatically_log, clc$linked_call, ^change_application_identifier],
          {} ['CHANGE_CLIENT_INFO_SOURCE      ', clc$nominal_entry, clc$advertised_entry, 12,
          clc$automatically_log, clc$linked_call, ^change_client_info_source],
          {} ['CHANGE_CLIENT_VALIDATION       ', clc$nominal_entry, clc$advertised_entry, 11,
          clc$automatically_log, clc$linked_call, ^change_client_server_validation],
          {} ['CHANGE_CONNECTION_PRIORITY     ', clc$nominal_entry, clc$advertised_entry, 9,
          clc$automatically_log, clc$linked_call, ^change_connection_priority],
          {} ['CHANGE_MAXIMUM_CONNECTIONS     ', clc$nominal_entry, clc$advertised_entry, 8,
          clc$automatically_log, clc$linked_call, ^change_maximum_connections],
          {} ['CHANGE_SERVER_JOB              ', clc$nominal_entry, clc$advertised_entry, 6,
          clc$automatically_log, clc$linked_call, ^change_server_job],
          {} ['CHANGE_SERVER_VALIDATION       ', clc$nominal_entry, clc$advertised_entry, 5,
          clc$automatically_log, clc$linked_call, ^change_server_validation],
          {} ['CHASJ                          ', clc$abbreviation_entry, clc$advertised_entry, 6,
          clc$automatically_log, clc$linked_call, ^change_server_job],
          {} ['CHASV                          ', clc$abbreviation_entry, clc$advertised_entry, 5,
          clc$automatically_log, clc$linked_call, ^change_server_validation],
          {} ['DELCA                          ', clc$abbreviation_entry, clc$advertised_entry, 14,
          clc$automatically_log, clc$linked_call, ^delete_client_address],
          {} ['DELETE_CLIENT_ADDRESS          ', clc$nominal_entry, clc$advertised_entry, 14,
          clc$automatically_log, clc$linked_call, ^delete_client_address],
          {} ['DELETE_SERVER_MANAGED_TITLE    ', clc$alias_entry, clc$advertised_entry, 3,
          clc$automatically_log, clc$linked_call, ^delete_server_managed_titles],
          {} ['DELETE_SERVER_MANAGED_TITLES   ', clc$nominal_entry, clc$advertised_entry, 3,
          clc$automatically_log, clc$linked_call, ^delete_server_managed_titles],
          {} ['DELETE_TITLE                   ', clc$alias_entry, clc$advertised_entry, 4,
          clc$automatically_log, clc$linked_call, ^delete_titles],
          {} ['DELETE_TITLES                  ', clc$nominal_entry, clc$advertised_entry, 4,
          clc$automatically_log, clc$linked_call, ^delete_titles],
          {} ['DELSMT                         ', clc$abbreviation_entry, clc$advertised_entry, 3,
          clc$automatically_log, clc$linked_call, ^delete_server_managed_titles],
          {} ['DELT                           ', clc$abbreviation_entry, clc$advertised_entry, 4,
          clc$automatically_log, clc$linked_call, ^delete_titles],
          {} ['DISPLAY_SERVER_ATTRIBUTE       ', clc$alias_entry, clc$advertised_entry, 15,
          clc$automatically_log, clc$linked_call, ^sub_display_server_attributes],
          {} ['DISPLAY_SERVER_ATTRIBUTES      ', clc$nominal_entry, clc$advertised_entry, 15,
          clc$automatically_log, clc$linked_call, ^sub_display_server_attributes],
          {} ['DISSA                          ', clc$abbreviation_entry, clc$advertised_entry, 15,
          clc$automatically_log, clc$linked_call, ^sub_display_server_attributes],
          {} ['ENDDS                          ', clc$abbreviation_entry, clc$advertised_entry, 17,
          clc$automatically_log, clc$linked_call, ^end_define_server],
          {} ['END_DEFINE_SERVER              ', clc$nominal_entry, clc$advertised_entry, 17,
          clc$automatically_log, clc$linked_call, ^end_define_server],
          {} ['GENERATE_SERVER_DEFINITION     ', clc$nominal_entry, clc$advertised_entry, 16,
          clc$automatically_log, clc$linked_call, ^sub_generate_server_definition],
          {} ['GENSD                          ', clc$abbreviation_entry, clc$advertised_entry, 16,
          clc$automatically_log, clc$linked_call, ^sub_generate_server_definition],
          {} ['QUI                            ', clc$alias_entry, clc$advertised_entry, 17,
          clc$automatically_log, clc$linked_call, ^end_define_server],
          {} ['QUIT                           ', clc$alias_entry, clc$advertised_entry, 17,
          clc$automatically_log, clc$linked_call, ^end_define_server]];

?? POP ??


{ table define_tcpip_commands
{ command (change_maximum_sockets, chams) processor =        change_maximum_sockets
{ command (change_tcpip_validation, chatv) processor =       change_tcpip_validation
{ command (display_tcpip_attributes, dista) processor =      sub_display_tcpip_attributes
{ command (generate_tcpip_definition, gentd) processor =     sub_generate_tcpip_definition
{ command (end_define_tcpip_application, enddta, quit, qui) processor = end_define_tcpip_application

?? PUSH (LISTEXT := ON) ??

  VAR
    define_tcpip_commands: [STATIC, READ] ^clt$command_table := ^define_tcpip_commands_entries,

    define_tcpip_commands_entries: [STATIC, READ] array [1 .. 12] of clt$command_table_entry := [
          {} ['CHAMS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^change_maximum_sockets],
          {} ['CHANGE_MAXIMUM_SOCKETS         ', clc$nominal_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^change_maximum_sockets],
          {} ['CHANGE_TCPIP_VALIDATION        ', clc$nominal_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^change_tcpip_validation],
          {} ['CHATV                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^change_tcpip_validation],
          {} ['DISPLAY_TCPIP_ATTRIBUTES       ', clc$nominal_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^sub_display_tcpip_attributes],
          {} ['DISTA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^sub_display_tcpip_attributes],
          {} ['ENDDTA                         ', clc$alias_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^end_define_tcpip_application],
          {} ['END_DEFINE_TCPIP_APPLICATION   ', clc$nominal_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^end_define_tcpip_application],
          {} ['GENERATE_TCPIP_DEFINITION      ', clc$nominal_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^sub_generate_tcpip_definition],
          {} ['GENTD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^sub_generate_tcpip_definition],
          {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^end_define_tcpip_application],
          {} ['QUIT                           ', clc$alias_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^end_define_tcpip_application]];

?? POP ??



  CONST
    max_line_width = 300;

  TYPE
    line_space = record
      size: 0 .. max_line_width,
      value: string (max_line_width),
    recend;

  TYPE
    server_attributes = (sa$protocol, sa$nam_initiated, sa$titles, sa$title_attributes,
          sa$server_managed_titles, sa$application_id, sa$connection_priority, sa$max_connections,
          sa$server_capability, sa$server_ring, sa$server_system_priv, sa$server_job,
          sa$server_job_val_source, sa$server_job_max_connections, sa$accept_connections,
          sa$client_validation, sa$client_addresses, sa$client_info_source, sa$status),
    server_attribute_set = set of server_attributes,
    client_attributes = (ca$protocol, ca$application_id, ca$connection_priority, ca$max_connections,
          ca$client_capability, ca$client_ring, ca$client_system_priv, ca$status),
    client_attribute_set = set of client_attributes,
    tcpip_attributes = (ta$protocol, ta$maximum_sockets, ta$capability, ta$ring, ta$system_privilege),
    tcpip_attribute_set = set of tcpip_attributes,
    type_of_applications = set of nat$application_type,
    utility_states = (utility_idle, defining_server, defining_client, defining_tcpip, changing_server,
          changing_client, changing_tcpip);

  VAR
    application_status_description: array [nat$application_status] of string (8) := ['inactive', 'active'],
    boolean_label: [STATIC, READ] array [boolean] of string (5) := ['FALSE', 'TRUE'],
    change_server_utility_name: ost$name := 'CHANGE_SERVER',
    change_client_utility_name: ost$name := 'CHANGE_CLIENT',
    change_tcpip_utility_name: ost$name := 'CHANGE_TCPIP',
    client_info_label: array [nat$client_info_source] of string (22) := ['dialog', 'connection_data',
          'dialog connection_data'],
    client_system_kind: array [nat$client_system_kind] of string (6) := ['nosve', 'cdcnet', 'all'],
    command_file: string (8) := '$COMMAND',
    current_display_control: ^clt$display_control,
    define_server_utility_name: ost$name := 'DEFINE_SERVER',
    define_client_utility_name: ost$name := 'DEFINE_CLIENT',
    define_tcpip_utility_name: ost$name := 'DEFINE_TCPIP',
    definition_changed: boolean := FALSE,
    interrupt_detected: boolean := FALSE,
    line: line_space,
    local_display_control: clt$display_control,
    output_control: clt$display_control,
    output_file_id: amt$file_identifier,
    page_width: amt$page_width,
    protocol_label: [STATIC, READ] array [nat$protocol] of string (22) := [REP nac$cdna_session of ' ',
          'cdna_session', 'cdna_virtual_terminal', REP (nac$stream_socket - nac$osi_session) of ' ',
          'stream_socket', 'datagram_socket', REP (nac$max_protocol - nac$datagram_socket) of ' '],
    selected_titles_changed: boolean := FALSE,
    server_job_changed: boolean := FALSE,
    server_job_specified: boolean,
    utility_name: ost$name := 'MANAGE_NETWORK_APPLICATIONS',
    utility_state: utility_states,
    utility_state_description: array [utility_states] of string (24) := ['no subutility is active',
          'DEFINE_SERVER is active', 'DEFINE_CLIENT is active', 'DEFINE_TCP/IP is active',
          'CHANGE_SERVER is active', 'CHANGE_CLIENT is active', 'CHANGE_TCP/IP is active'],
    validation_source_label: array [nat$server_validation_source] of string (10) := ['server job', 'client'];

{ Attribute values for current application.
{ Application type is determined by the variable utility_state.

  VAR
    accept_connection: boolean,
    application_id: nat$internet_sap_identifier,
    application_name: nat$application_name,
    application_status: nat$application_status,
    capability: ost$name,
    client_addresses: ^array [1 .. * ] of nat$client_address := NIL,
    client_capability: ost$name,
    client_info_source: nat$client_info_source,
    connection_priority: nat$network_message_priority,
    max_connections: nat$number_of_connections,
    max_sockets: nat$number_of_sockets,
    nam_initiated: boolean,
    protocol: nat$protocol,
    reserved_application_id: boolean,
    ring: ost$ring,
    selected_titles: ^array [1 .. * ] of nat$selected_title := NIL,
    server_job: amt$local_file_name,
    server_job_max_connections: nat$number_of_connections,
    server_job_validation_source: nat$server_validation_source,
    server_managed_titles: ^nat$title_pattern_list := NIL,
    system_privilege: boolean;

?? OLDTITLE ??
?? NEWTITLE := 'nap$manage_network_applications', EJECT ??

  PROGRAM nap$manage_network_applications
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PURPOSE: This procedure establishes the Manage Network Applications Utility environment.
{ DESIGN:

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      local_status.normal := TRUE;

    PROCEND exit_condition_handler;

    VAR
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler,
      ignore_status: ost$status,
      interrupt_descriptor: pmt$established_handler,
      interrupt_condition: [STATIC] pmt$condition := [ifc$interactive_condition, ifc$terminate_break],
      local_status: ost$status,
      network_application_management: boolean,
      output_file: clt$value,
      utility_attributes: ^clt$utility_attributes;

{  PROCEDURE manna_pdt(
{    status)

?? 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,
      recend,
    recend := [
    [1,
    [89, 6, 23, 13, 45, 53, 262],
    clc$command, 1, 1, 0, 0, 0, 0, 1, ''], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


{ table manna_sub_commands
{ command (change_server,chas) processor = change_server
{ command (define_server,defs) processor = define_server
{ command (delete_server,dels) processor = delete_server
{ command (activate_server,acts) processor = activate_server
{ command (deactivate_server,deas) processor = deactivate_server
{ command (display_server_status,disss) processor = display_server_status
{ command (display_server_attributes,dissa) processor = display_server_attributes
{ command (generate_server_definition,gensd) processor = generate_server_definition
{ command (change_client,chac) processor = change_client
{ command (define_client,defc) processor = define_client
{ command (delete_client,delc) processor = delete_client
{ command (activate_client,actc) processor = activate_client
{ command (deactivate_client,deac) processor = deactivate_client
{ command (display_client_status,discs) processor = display_client_status
{ command (display_client_attributes,disca) processor = display_client_attributes
{ command (generate_client_definition,gencd) processor = generate_client_definition
{ command (change_tcpip_application, chata) processor = change_tcpip
{ command (define_tcpip_application, defta) processor = define_tcpip
{ command (delete_tcpip_application, delta) processor = delete_tcpip
{ command (activate_tcpip_application, actta) processor = activate_tcpip
{ command (deactivate_tcpip_application, deata) processor = deactivate_tcpip
{ command (display_tcpip_status, dists) processor = display_tcpip_status
{ command (display_tcpip_attributes, dista) processor = display_tcpip_attributes
{ command (generate_tcpip_definition, gentd) processor = generate_tcpip_definition
{ command (display_application_status,disas) processor = display_application_status
{ command (quit,qui) processor = quit
{ command (generate_application_definition, genad) processor = generate_application_definition

?? PUSH (LISTEXT := ON) ??

    VAR
      manna_sub_commands: [STATIC, READ] ^clt$command_table := ^manna_sub_commands_entries,

      manna_sub_commands_entries: [STATIC, READ] array [1 .. 54] of clt$command_table_entry := [
            {} ['ACTC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
            clc$automatically_log, clc$linked_call, ^activate_client],
            {} ['ACTIVATE_CLIENT                ', clc$nominal_entry, clc$normal_usage_entry, 12,
            clc$automatically_log, clc$linked_call, ^activate_client],
            {} ['ACTIVATE_SERVER                ', clc$nominal_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^activate_server],
            {} ['ACTIVATE_TCPIP_APPLICATION     ', clc$nominal_entry, clc$normal_usage_entry, 20,
            clc$automatically_log, clc$linked_call, ^activate_tcpip],
            {} ['ACTS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^activate_server],
            {} ['ACTTA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 20,
            clc$automatically_log, clc$linked_call, ^activate_tcpip],
            {} ['CHAC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
            clc$automatically_log, clc$linked_call, ^change_client],
            {} ['CHANGE_CLIENT                  ', clc$nominal_entry, clc$normal_usage_entry, 9,
            clc$automatically_log, clc$linked_call, ^change_client],
            {} ['CHANGE_SERVER                  ', clc$nominal_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^change_server],
            {} ['CHANGE_TCPIP_APPLICATION       ', clc$nominal_entry, clc$normal_usage_entry, 17,
            clc$automatically_log, clc$linked_call, ^change_tcpip],
            {} ['CHAS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^change_server],
            {} ['CHATA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 17,
            clc$automatically_log, clc$linked_call, ^change_tcpip],
            {} ['DEAC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 13,
            clc$automatically_log, clc$linked_call, ^deactivate_client],
            {} ['DEACTIVATE_CLIENT              ', clc$nominal_entry, clc$normal_usage_entry, 13,
            clc$automatically_log, clc$linked_call, ^deactivate_client],
            {} ['DEACTIVATE_SERVER              ', clc$nominal_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^deactivate_server],
            {} ['DEACTIVATE_TCPIP_APPLICATION   ', clc$nominal_entry, clc$normal_usage_entry, 21,
            clc$automatically_log, clc$linked_call, ^deactivate_tcpip],
            {} ['DEAS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^deactivate_server],
            {} ['DEATA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 21,
            clc$automatically_log, clc$linked_call, ^deactivate_tcpip],
            {} ['DEFC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
            clc$automatically_log, clc$linked_call, ^define_client],
            {} ['DEFINE_CLIENT                  ', clc$nominal_entry, clc$normal_usage_entry, 10,
            clc$automatically_log, clc$linked_call, ^define_client],
            {} ['DEFINE_SERVER                  ', clc$nominal_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^define_server],
            {} ['DEFINE_TCPIP_APPLICATION       ', clc$nominal_entry, clc$normal_usage_entry, 18,
            clc$automatically_log, clc$linked_call, ^define_tcpip],
            {} ['DEFS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^define_server],
            {} ['DEFTA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 18,
            clc$automatically_log, clc$linked_call, ^define_tcpip],
            {} ['DELC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 11,
            clc$automatically_log, clc$linked_call, ^delete_client],
            {} ['DELETE_CLIENT                  ', clc$nominal_entry, clc$normal_usage_entry, 11,
            clc$automatically_log, clc$linked_call, ^delete_client],
            {} ['DELETE_SERVER                  ', clc$nominal_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^delete_server],
            {} ['DELETE_TCPIP_APPLICATION       ', clc$nominal_entry, clc$normal_usage_entry, 19,
            clc$automatically_log, clc$linked_call, ^delete_tcpip],
            {} ['DELS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^delete_server],
            {} ['DELTA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 19,
            clc$automatically_log, clc$linked_call, ^delete_tcpip],
            {} ['DISAS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 25,
            clc$automatically_log, clc$linked_call, ^display_application_status],
            {} ['DISCA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 15,
            clc$automatically_log, clc$linked_call, ^display_client_attributes],
            {} ['DISCS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 14,
            clc$automatically_log, clc$linked_call, ^display_client_status],
            {} ['DISPLAY_APPLICATION_STATUS     ', clc$nominal_entry, clc$normal_usage_entry, 25,
            clc$automatically_log, clc$linked_call, ^display_application_status],
            {} ['DISPLAY_CLIENT_ATTRIBUTES      ', clc$nominal_entry, clc$normal_usage_entry, 15,
            clc$automatically_log, clc$linked_call, ^display_client_attributes],
            {} ['DISPLAY_CLIENT_STATUS          ', clc$nominal_entry, clc$normal_usage_entry, 14,
            clc$automatically_log, clc$linked_call, ^display_client_status],
            {} ['DISPLAY_SERVER_ATTRIBUTES      ', clc$nominal_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^display_server_attributes],
            {} ['DISPLAY_SERVER_STATUS          ', clc$nominal_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^display_server_status],
            {} ['DISPLAY_TCPIP_ATTRIBUTES       ', clc$nominal_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^display_tcpip_attributes],
            {} ['DISPLAY_TCPIP_STATUS           ', clc$nominal_entry, clc$normal_usage_entry, 22,
            clc$automatically_log, clc$linked_call, ^display_tcpip_status],
            {} ['DISSA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^display_server_attributes],
            {} ['DISSS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^display_server_status],
            {} ['DISTA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 23,
            clc$automatically_log, clc$linked_call, ^display_tcpip_attributes],
            {} ['DISTS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 22,
            clc$automatically_log, clc$linked_call, ^display_tcpip_status],
            {} ['GENAD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 27,
            clc$automatically_log, clc$linked_call, ^generate_application_definition],
            {} ['GENCD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 16,
            clc$automatically_log, clc$linked_call, ^generate_client_definition],
            {} ['GENERATE_APPLICATION_DEFINITION', clc$nominal_entry, clc$normal_usage_entry, 27,
            clc$automatically_log, clc$linked_call, ^generate_application_definition],
            {} ['GENERATE_CLIENT_DEFINITION     ', clc$nominal_entry, clc$normal_usage_entry, 16,
            clc$automatically_log, clc$linked_call, ^generate_client_definition],
            {} ['GENERATE_SERVER_DEFINITION     ', clc$nominal_entry, clc$normal_usage_entry, 8,
            clc$automatically_log, clc$linked_call, ^generate_server_definition],
            {} ['GENERATE_TCPIP_DEFINITION      ', clc$nominal_entry, clc$normal_usage_entry, 24,
            clc$automatically_log, clc$linked_call, ^generate_tcpip_definition],
            {} ['GENSD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
            clc$automatically_log, clc$linked_call, ^generate_server_definition],
            {} ['GENTD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 24,
            clc$automatically_log, clc$linked_call, ^generate_tcpip_definition],
            {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 26,
            clc$automatically_log, clc$linked_call, ^quit],
            {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 26,
            clc$automatically_log, clc$linked_call, ^quit]];

?? POP ??


?? EJECT ??

    status.normal := TRUE;
    line.size := 0;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$get_capability (avc$network_applic_management, avc$user, network_application_management, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT network_application_management THEN
      osp$set_status_abnormal (nac$status_id, nae$invalid_user, 'MANAGE_NETWORK_APPLICATIONS', status);
      RETURN;
    IFEND;

    pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    interrupt_detected := FALSE;
    pmp$establish_condition_handler (interrupt_condition, ^terminate_break_handler, ^interrupt_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_file.file.local_file_name := default_output_file;
    clp$open_display (output_file.file, ^generate_headers, output_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH utility_attributes: [1 .. 3];

    utility_attributes^ [1].key := clc$utility_command_search_mode;
    utility_attributes^ [1].command_search_mode := clc$global_command_search;
    utility_attributes^ [2].key := clc$utility_command_table;
    utility_attributes^ [2].command_table := manna_sub_commands;
    utility_attributes^ [3].key := clc$utility_prompt;
    utility_attributes^ [3].prompt.value := prompt_string;
    utility_attributes^ [3].prompt.size := STRLENGTH (prompt_string);

    clp$begin_utility (utility_name, utility_attributes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    utility_state := utility_idle;
    clp$include_file (clc$current_command_input, prompt_string, utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (utility_name, status);

  PROCEND nap$manage_network_applications;
?? OLDTITLE ??
?? NEWTITLE := 'Command Processors' ??
?? NEWTITLE := 'activate_client', EJECT ??

  PROCEDURE activate_client
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE activate_client_pdt (
{     client, c: name = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 30, 12, 53, 47, 587],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CLIENT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$client = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      utility_state := utility_idle;
      nap$detach_application_file (ignore_status);

    PROCEND exit_condition_handler;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF utility_state <> utility_idle THEN
      osp$set_status_abnormal (nac$status_id, nae$command_not_allowed, 'ACTIVATE_CLIENT', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, utility_state_description [utility_state],
            status);
      RETURN;
    IFEND;

    nap$attach_application_file (status);
    IF status.normal THEN
      pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$activate_client (pvt [p$client].value^.name_value, status);

  PROCEND activate_client;
?? OLDTITLE ??
?? NEWTITLE := 'activate_server', EJECT ??

  PROCEDURE activate_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE activate_server_pdt (
{     server, s: name = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 30, 12, 54, 0, 556],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['S                              ',clc$abbreviation_entry, 1],
    ['SERVER                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$server = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    VAR
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler,
      server: clt$value;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      utility_state := utility_idle;
      nap$detach_application_file (ignore_status);

    PROCEND exit_condition_handler;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF utility_state <> utility_idle THEN
      osp$set_status_abnormal (nac$status_id, nae$command_not_allowed, 'ACTIVATE_SERVER', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, utility_state_description [utility_state],
            status);
      RETURN;
    IFEND;

    nap$attach_application_file (status);
    IF status.normal THEN
      pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$activate_server (pvt [p$server].value^.name_value, status);

  PROCEND activate_server;
?? OLDTITLE ??
?? NEWTITLE := 'activate_tcpip', EJECT ??

  PROCEDURE activate_tcpip
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE activate_tcpip_pdt (
{       application, a: name = $required
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 1, 9, 40, 26, 791],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['APPLICATION                    ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    VAR
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      utility_state := utility_idle;
      nap$detach_application_file (ignore_status);

    PROCEND exit_condition_handler;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF utility_state <> utility_idle THEN
      osp$set_status_abnormal (nac$status_id, nae$command_not_allowed, 'ACTIVATE_TCPIP', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, utility_state_description [utility_state],
            status);
      RETURN;
    IFEND;

    nap$attach_application_file (status);

    IF status.normal THEN
      pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$activate_tcpip (pvt [p$application].value^.name_value, status);

  PROCEND activate_tcpip;
?? OLDTITLE ??
?? NEWTITLE := 'change_client', EJECT ??

  PROCEDURE change_client
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE change_client_pdt (
{    client, c: name = $required
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 13, 45, 10, 172],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CLIENT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$client = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    VAR
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler,
      ignore_status: ost$status,
      interrupt_descriptor: pmt$established_handler,
      interrupt_condition: [STATIC] pmt$condition := [ifc$interactive_condition, ifc$terminate_break],
      local_status: ost$status,
      utility_attributes: ^clt$utility_attributes;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      utility_state := utility_idle;
      nap$detach_application_file (ignore_status);

    PROCEND exit_condition_handler;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF utility_state <> utility_idle THEN
      osp$set_status_abnormal (nac$status_id, nae$command_not_allowed, 'CHANGE_CLIENT', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, utility_state_description [utility_state],
            status);
      RETURN;
    IFEND;

    application_name := pvt [p$client].value^.name_value;

    nap$attach_application_file (status);
    IF status.normal THEN
      utility_state := changing_client;
      pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Get the client attributes which become the initial values for the attributes
{ before changing.

    nap$get_client_attributes (application_name, application_status, max_connections, connection_priority,
          protocol, reserved_application_id, application_id, capability, ring, system_privilege, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH utility_attributes: [1 .. 3];

    utility_attributes^ [1].key := clc$utility_command_search_mode;
    utility_attributes^ [1].command_search_mode := clc$restricted_command_search;
    utility_attributes^ [2].key := clc$utility_command_table;
    utility_attributes^ [2].command_table := change_client_commands;
    utility_attributes^ [3].key := clc$utility_prompt;
    utility_attributes^ [3].prompt.value := change_client_prompt_string;
    utility_attributes^ [3].prompt.size := STRLENGTH (change_client_prompt_string);

    clp$begin_utility (change_client_utility_name, utility_attributes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    definition_changed := FALSE;

    clp$include_file (clc$current_command_input, change_client_prompt_string, change_client_utility_name,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (change_client_utility_name, status);

  PROCEND change_client;
?? OLDTITLE ??
?? NEWTITLE := 'change_server', EJECT ??

  PROCEDURE change_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE change_server_pdt (
{    server, s: name = $required
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 13, 45, 32, 567],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['S                              ',clc$abbreviation_entry, 1],
    ['SERVER                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$server = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    VAR
      client_address: array [1 .. 1] of nat$client_address,
      client_address_count: integer,
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler,
      file: clt$file,
      file_name: ost$name,
      highest_cycle: [STATIC, READ] pft$cycle_selector := [pfc$highest_cycle],
      ignore_status: ost$status,
      interrupt_descriptor: pmt$established_handler,
      interrupt_condition: [STATIC] pmt$condition := [ifc$interactive_condition, ifc$terminate_break],
      local_status: ost$status,
      old_server_job_defined: boolean,
      path_name: [STATIC] array [1 .. 6] of pft$name := [nac$application_family,
            nac$application_master_catalog, nac$network_subcatalog, nac$application_catalog,
            nac$application_job_catalog, * ],
      selected_title: array [1 .. 1] of nat$selected_title,
      selected_title_count: nat$max_titles,
      server_managed_title: array [1 .. 1] of string (nac$max_title_pattern_length),
      server_managed_title_count: nat$max_titles,
      share_selections: [STATIC, READ] pft$usage_selections := [pfc$read],
      usage_selections: [STATIC, READ] pft$usage_selections := [pfc$read],
      utility_attributes: ^clt$utility_attributes;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      utility_state := utility_idle;
      nap$detach_application_file (ignore_status);
      IF selected_titles <> NIL THEN
        FREE selected_titles;
      IFEND;
      IF client_addresses <> NIL THEN
        FREE client_addresses;
      IFEND;
      IF server_managed_titles <> NIL THEN
        FREE server_managed_titles;
      IFEND;

    PROCEND exit_condition_handler;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF utility_state <> utility_idle THEN
      osp$set_status_abnormal (nac$status_id, nae$command_not_allowed, 'CHANGE_SERVER', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, utility_state_description [utility_state],
            status);
      RETURN;
    IFEND;

    application_name := pvt [p$server].value^.name_value;

    nap$attach_application_file (status);
    IF status.normal THEN
      utility_state := changing_server;
      pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Get the server attributes which become the initial values of the attributes
{ before changing.

    selected_titles_changed := FALSE;
    server_job_changed := FALSE;

    nap$get_server_attributes (application_name, application_status, selected_title_count, ^selected_title,
          server_managed_title_count, ^server_managed_title, max_connections, connection_priority, capability,
          ring, system_privilege, accept_connection, client_capability, client_info_source,
          client_address_count, ^client_address, reserved_application_id, application_id, protocol,
          nam_initiated, server_job_validation_source, server_job_max_connections, old_server_job_defined,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF selected_title_count = 0 THEN
      selected_titles := NIL;
    ELSE
      ALLOCATE selected_titles: [1 .. selected_title_count];
    IFEND;
    IF server_managed_title_count = 0 THEN
      server_managed_titles := NIL;
    ELSE
      ALLOCATE server_managed_titles: [1 .. server_managed_title_count];
    IFEND;
    IF client_address_count = 0 THEN
      client_addresses := NIL;
    ELSE
      ALLOCATE client_addresses: [1 .. client_address_count];
    IFEND;
    IF (selected_title_count > 0) OR (client_address_count > 0) OR (server_managed_title_count > 0) THEN
      nap$get_server_attributes (application_name, application_status, selected_title_count, selected_titles,
            server_managed_title_count, server_managed_titles, max_connections, connection_priority,
            capability, ring, system_privilege, accept_connection, client_capability, client_info_source,
            client_address_count, client_addresses, reserved_application_id, application_id, protocol,
            nam_initiated, server_job_validation_source, server_job_max_connections, old_server_job_defined,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF NOT old_server_job_defined THEN
      server_job := clc$null_file;
    IFEND;
    server_job_specified := NOT old_server_job_defined;

    PUSH utility_attributes: [1 .. 3];

    utility_attributes^ [1].key := clc$utility_command_search_mode;
    utility_attributes^ [1].command_search_mode := clc$restricted_command_search;
    utility_attributes^ [2].key := clc$utility_command_table;
    utility_attributes^ [2].command_table := change_server_commands;
    utility_attributes^ [3].key := clc$utility_prompt;
    utility_attributes^ [3].prompt.value := change_server_prompt_string;
    utility_attributes^ [3].prompt.size := STRLENGTH (change_server_prompt_string);

    clp$begin_utility (change_server_utility_name, utility_attributes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    definition_changed := FALSE;

    clp$include_file (clc$current_command_input, change_server_prompt_string, change_server_utility_name,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (change_server_utility_name, status);

  PROCEND change_server;
?? OLDTITLE ??
?? NEWTITLE := 'change_tcpip', EJECT ??

  PROCEDURE change_tcpip
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE change_tcpip_pdt (
{       application, a: name = $required
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 1, 9, 40, 28, 110],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['APPLICATION                    ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler,
      tcpip_status: nat$application_status,
      utility_attributes: ^clt$utility_attributes;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      utility_state := utility_idle;
      nap$detach_application_file (ignore_status);

    PROCEND exit_condition_handler;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF utility_state <> utility_idle THEN
      osp$set_status_abnormal (nac$status_id, nae$command_not_allowed, 'CHANGE_TCP/IP', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, utility_state_description [utility_state],
            status);
      RETURN;
    IFEND;

    application_name := pvt [p$application].value^.name_value;

    nap$get_tcpip_attributes (application_name, tcpip_status, max_sockets, capability, ring, system_privilege,
          protocol, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$attach_application_file (status);
    IF status.normal THEN
      utility_state := changing_tcpip;
      pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH utility_attributes: [1 .. 3];

    utility_attributes^ [1].key := clc$utility_command_search_mode;
    utility_attributes^ [1].command_search_mode := clc$restricted_command_search;
    utility_attributes^ [2].key := clc$utility_command_table;
    utility_attributes^ [2].command_table := change_tcpip_commands;
    utility_attributes^ [3].key := clc$utility_prompt;
    utility_attributes^ [3].prompt.value := change_tcpip_prompt_string;
    utility_attributes^ [3].prompt.size := STRLENGTH (change_tcpip_prompt_string);

    clp$begin_utility (change_tcpip_utility_name, utility_attributes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    definition_changed := FALSE;

    clp$include_file (clc$current_command_input, change_tcpip_prompt_string, change_tcpip_utility_name,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (change_tcpip_utility_name, status);

  PROCEND change_tcpip;
?? OLDTITLE ??
?? NEWTITLE := 'deactivate_client', EJECT ??

  PROCEDURE deactivate_client
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE  deactivate_client_pdt (
{     client, c: name = $required
{     terminate_active_connections, tac: boolean = FALSE
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 10, 13, 11, 38, 113],
    clc$command, 5, 3, 1, 0, 0, 0, 3, ''], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CLIENT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['TAC                            ',clc$abbreviation_entry, 2],
    ['TERMINATE_ACTIVE_CONNECTIONS   ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$boolean_type],
    'FALSE'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$client = 1,
      p$terminate_active_connections = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      utility_state := utility_idle;
      nap$detach_application_file (ignore_status);

    PROCEND exit_condition_handler;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF utility_state <> utility_idle THEN
      osp$set_status_abnormal (nac$status_id, nae$command_not_allowed, 'DEACTIVATE_CLIENT', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, utility_state_description [utility_state],
            status);
      RETURN;
    IFEND;

    nap$attach_application_file (status);
    IF status.normal THEN
      pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$deactivate_client (pvt [p$client].value^.name_value,
          pvt [p$terminate_active_connections].value^.boolean_value.value, status);

  PROCEND deactivate_client;
?? OLDTITLE ??
?? NEWTITLE := 'deactivate_server', EJECT ??

  PROCEDURE deactivate_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE deactivate_server_pdt (
{     server, s: name = $required
{     terminate_active_connections, tac: boolean = FALSE
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 13, 47, 4, 820],
    clc$command, 5, 3, 1, 0, 0, 0, 3, ''], [
    ['S                              ',clc$abbreviation_entry, 1],
    ['SERVER                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['TAC                            ',clc$abbreviation_entry, 2],
    ['TERMINATE_ACTIVE_CONNECTIONS   ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$boolean_type],
    'FALSE'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$server = 1,
      p$terminate_active_connections = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      utility_state := utility_idle;
      nap$detach_application_file (ignore_status);

    PROCEND exit_condition_handler;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF utility_state <> utility_idle THEN
      osp$set_status_abnormal (nac$status_id, nae$command_not_allowed, 'DEACTIVATE_SERVER', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, utility_state_description [utility_state],
            status);
      RETURN;
    IFEND;

    nap$attach_application_file (status);
    IF status.normal THEN
      pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$deactivate_server (pvt [p$server].value^.name_value,
          pvt [p$terminate_active_connections].value^.boolean_value.value, status);

  PROCEND deactivate_server;
?? OLDTITLE ??
?? NEWTITLE := 'deactivate_tcpip', EJECT ??

  PROCEDURE deactivate_tcpip
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE deact_tcpip_appl_pdt (
{       application, a: name = $required
{       terminate_active_sockets, tas: boolean = FALSE
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 9, 11, 41, 28, 427],
    clc$command, 5, 3, 1, 0, 0, 0, 3, ''], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['APPLICATION                    ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['TAS                            ',clc$abbreviation_entry, 2],
    ['TERMINATE_ACTIVE_SOCKETS       ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$boolean_type],
    'FALSE'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application = 1,
      p$terminate_active_sockets = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      utility_state := utility_idle;
      nap$detach_application_file (ignore_status);

    PROCEND exit_condition_handler;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF utility_state <> utility_idle THEN
      osp$set_status_abnormal (nac$status_id, nae$command_not_allowed, 'DEACTIVATE_TCP/IP', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, utility_state_description [utility_state],
            status);
      RETURN;
    IFEND;

    nap$attach_application_file (status);

    IF status.normal THEN
      pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$deactivate_tcpip (pvt [p$application].value^.name_value,
          pvt [p$terminate_active_sockets].value^.boolean_value.value, status);

  PROCEND deactivate_tcpip;
?? OLDTITLE ??
?? NEWTITLE := 'define_client', EJECT ??

  PROCEDURE define_client
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE define_client_pdt (
{     client, c: name = $required
{     protocol, p: key
{         (cdna_session, cs)
{         (cdna_virtual_terminal, cvt)
{       keyend = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 13, 47, 0, 956],
    clc$command, 5, 3, 2, 0, 0, 0, 3, ''], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CLIENT                         ',clc$nominal_entry, 1],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PROTOCOL                       ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$required_parameter, 0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['CDNA_SESSION                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['CDNA_VIRTUAL_TERMINAL          ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['CS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CVT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$client = 1,
      p$protocol = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler,
      ignore_status: ost$status,
      interrupt_descriptor: pmt$established_handler,
      interrupt_condition: [STATIC] pmt$condition := [ifc$interactive_condition, ifc$terminate_break],
      local_status: ost$status,
      protocol_value: ost$name,
      utility_attributes: ^clt$utility_attributes;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      utility_state := utility_idle;
      nap$detach_application_file (ignore_status);

    PROCEND exit_condition_handler;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF utility_state <> utility_idle THEN
      osp$set_status_abnormal (nac$status_id, nae$command_not_allowed, 'DEFINE_CLIENT', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, utility_state_description [utility_state],
            status);
      RETURN;
    IFEND;

    application_name := pvt [p$client].value^.name_value;
    nap$verify_application_name (application_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$attach_application_file (status);
    IF status.normal THEN
      utility_state := defining_client;
      pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    protocol_value := pvt [p$protocol].value^.keyword_value;

    IF (protocol_value = 'CDNA_SESSION') OR (protocol_value = 'CS') THEN
      protocol := nac$cdna_session;
    ELSEIF (protocol_value = 'CDNA_VIRTUAL_TERMINAL') OR (protocol_value = 'CVT') THEN
      protocol := nac$cdna_virtual_terminal;
    IFEND;

{ Set all client attributes to initial default values.

    application_status := nac$application_inactive;
    max_connections := UPPERVALUE (nat$number_of_connections);
    connection_priority := nac$default_message_priority;
    capability := osc$null_name;
    ring := nac$default_ring;
    system_privilege := FALSE;
    reserved_application_id := FALSE;
    application_id := 0;

    PUSH utility_attributes: [1 .. 3];

    utility_attributes^ [1].key := clc$utility_command_search_mode;
    utility_attributes^ [1].command_search_mode := clc$restricted_command_search;
    utility_attributes^ [2].key := clc$utility_command_table;
    utility_attributes^ [2].command_table := define_client_commands;
    utility_attributes^ [3].key := clc$utility_prompt;
    utility_attributes^ [3].prompt.value := define_client_prompt_string;
    utility_attributes^ [3].prompt.size := STRLENGTH (define_client_prompt_string);

    clp$begin_utility (define_client_utility_name, utility_attributes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, define_client_prompt_string, define_client_utility_name,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (define_client_utility_name, status);

  PROCEND define_client;
?? OLDTITLE ??
?? NEWTITLE := 'define_server', EJECT ??

  PROCEDURE define_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE define_server_pdt (
{     server, s: name = $required
{     protocol, p: key
{         (cdna_session, cs)
{         (cdna_virtual_terminal, cvt)
{       keyend= $required
{     nam_initiated, ni: boolean = TRUE
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 13, 46, 57, 350],
    clc$command, 7, 4, 2, 0, 0, 0, 4, ''], [
    ['NAM_INITIATED                  ',clc$nominal_entry, 3],
    ['NI                             ',clc$abbreviation_entry, 3],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PROTOCOL                       ',clc$nominal_entry, 2],
    ['S                              ',clc$abbreviation_entry, 1],
    ['SERVER                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$required_parameter, 0, 0],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['CDNA_SESSION                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['CDNA_VIRTUAL_TERMINAL          ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['CS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CVT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$server = 1,
      p$protocol = 2,
      p$nam_initiated = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler,
      file: clt$file,
      ignore_status: ost$status,
      interrupt_descriptor: pmt$established_handler,
      interrupt_condition: [STATIC] pmt$condition := [ifc$interactive_condition, ifc$terminate_break],
      local_status: ost$status,
      protocol_value: ost$name,
      utility_attributes: ^clt$utility_attributes;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      utility_state := utility_idle;
      nap$detach_application_file (ignore_status);
      IF selected_titles <> NIL THEN
        FREE selected_titles;
      IFEND;
      IF client_addresses <> NIL THEN
        FREE client_addresses;
      IFEND;
      IF server_managed_titles <> NIL THEN
        FREE server_managed_titles;
      IFEND;

    PROCEND exit_condition_handler;

?? EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF utility_state <> utility_idle THEN
      osp$set_status_abnormal (nac$status_id, nae$command_not_allowed, 'DEFINE_SERVER', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, utility_state_description [utility_state],
            status);
      RETURN;
    IFEND;

    application_name := pvt [p$server].value^.name_value;
    nap$verify_application_name (application_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$attach_application_file (status);
    IF status.normal THEN
      utility_state := defining_server;
      pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Set all server attributes to initial default values.

    application_status := nac$application_inactive;
    selected_titles := NIL;
    server_managed_titles := NIL;
    max_connections := UPPERVALUE (nat$number_of_connections);
    connection_priority := nac$default_message_priority;
    capability := osc$null_name;
    ring := nac$default_ring;
    system_privilege := FALSE;
    accept_connection := TRUE;
    client_capability := osc$null_name;
    client_info_source := nac$client_info_via_dialog;
    client_addresses := NIL;
    reserved_application_id := FALSE;
    application_id := 0;
    server_job_validation_source := nac$server_job;
    server_job_max_connections := UPPERVALUE (nat$number_of_connections);
    server_job := clc$null_file;


    protocol_value := pvt [p$protocol].value^.keyword_value;
    IF (protocol_value = 'CDNA_SESSION') OR (protocol_value = 'CS') THEN
      protocol := nac$cdna_session;
    ELSEIF (protocol_value = 'CDNA_VIRTUAL_TERMINAL') OR (protocol_value = 'CVT') THEN
      protocol := nac$cdna_virtual_terminal;
    IFEND;

    nam_initiated := pvt [p$nam_initiated].value^.boolean_value.value;

    PUSH utility_attributes: [1 .. 3];

    utility_attributes^ [1].key := clc$utility_command_search_mode;
    utility_attributes^ [1].command_search_mode := clc$restricted_command_search;
    utility_attributes^ [2].key := clc$utility_command_table;
    utility_attributes^ [2].command_table := define_server_commands;
    utility_attributes^ [3].key := clc$utility_prompt;
    utility_attributes^ [3].prompt.value := define_server_prompt_string;
    utility_attributes^ [3].prompt.size := STRLENGTH (define_server_prompt_string);

    clp$begin_utility (define_server_utility_name, utility_attributes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, define_server_prompt_string, define_server_utility_name,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (define_server_utility_name, status);

  PROCEND define_server;
?? OLDTITLE ??
?? NEWTITLE := 'define_tcpip', EJECT ??

  PROCEDURE define_tcpip
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE define_tcpip_appl_pdt (
{       application, a: name = $required
{       protocol, p: key
{             (stream_socket, ss)
{             (datagram_socket, ds)
{         keyend = $required
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 1, 9, 40, 30, 141],
    clc$command, 5, 3, 2, 0, 0, 0, 3, ''], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['APPLICATION                    ',clc$nominal_entry, 1],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PROTOCOL                       ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$required_parameter, 0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['DATAGRAM_SOCKET                ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['DS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['STREAM_SOCKET                  ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application = 1,
      p$protocol = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler,
      utility_attributes: ^clt$utility_attributes;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      utility_state := utility_idle;
      nap$detach_application_file (ignore_status);

    PROCEND exit_condition_handler;

?? EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF utility_state <> utility_idle THEN
      osp$set_status_abnormal (nac$status_id, nae$command_not_allowed, 'DEFINE_TCPIP', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, utility_state_description [utility_state],
            status);
      RETURN;
    IFEND;

    application_name := pvt [p$application].value^.name_value;

    nap$verify_tcpip_name (application_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$protocol].value^.keyword_value = 'STREAM_SOCKET') OR (pvt [p$protocol].value^.keyword_value =
          'SS') THEN
      protocol := nac$stream_socket;
    ELSE
      protocol := nac$datagram_socket;
    IFEND;

    IF application_name = nac$sk_unnamed_tcp_application THEN
      IF protocol = nac$datagram_socket THEN
        osp$set_status_abnormal (nac$status_id, nae$tcp_protocol_mismatch, 'DEFINE_TCPIP', status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              utility_state_description [utility_state], status);
        RETURN;
      IFEND;
    ELSEIF application_name = nac$sk_unnamed_udp_application THEN
      IF protocol = nac$stream_socket THEN
        osp$set_status_abnormal (nac$status_id, nae$udp_protocol_mismatch, 'DEFINE_TCPIP', status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              utility_state_description [utility_state], status);
        RETURN;
      IFEND;
    IFEND;

    nap$attach_application_file (status);
    IF status.normal THEN
      utility_state := defining_tcpip;
      pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Set all tcpip attributes to initial default values.

    application_status := nac$application_inactive;
    max_sockets := UPPERVALUE (nat$number_of_sockets);
    capability := osc$null_name;
    ring := nac$default_ring;
    system_privilege := FALSE;

    PUSH utility_attributes: [1 .. 3];

    utility_attributes^ [1].key := clc$utility_command_search_mode;
    utility_attributes^ [1].command_search_mode := clc$restricted_command_search;
    utility_attributes^ [2].key := clc$utility_command_table;
    utility_attributes^ [2].command_table := define_tcpip_commands;
    utility_attributes^ [3].key := clc$utility_prompt;
    utility_attributes^ [3].prompt.value := define_tcpip_prompt_string;
    utility_attributes^ [3].prompt.size := STRLENGTH (define_tcpip_prompt_string);

    clp$begin_utility (define_tcpip_utility_name, utility_attributes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, define_tcpip_prompt_string, define_tcpip_utility_name,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (define_tcpip_utility_name, status);

  PROCEND define_tcpip;
?? OLDTITLE ??
?? NEWTITLE := 'delete_client', EJECT ??

  PROCEDURE delete_client
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE delete_client_pdt (
{     client, c: name = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 13, 46, 54, 0],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CLIENT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$client = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      utility_state := utility_idle;
      nap$detach_application_file (ignore_status);

    PROCEND exit_condition_handler;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF utility_state <> utility_idle THEN
      osp$set_status_abnormal (nac$status_id, nae$command_not_allowed, 'DELETE_CLIENT', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, utility_state_description [utility_state],
            status);
      RETURN;
    IFEND;

    nap$attach_application_file (status);
    IF status.normal THEN
      pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$delete_client (pvt [p$client].value^.name_value, status);

  PROCEND delete_client;
?? OLDTITLE ??
?? NEWTITLE := 'delete_server', EJECT ??

  PROCEDURE delete_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE delete_server_pdt (
{     server, s: name = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 13, 46, 50, 464],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['S                              ',clc$abbreviation_entry, 1],
    ['SERVER                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$server = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    VAR
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      utility_state := utility_idle;
      nap$detach_application_file (ignore_status);

    PROCEND exit_condition_handler;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF utility_state <> utility_idle THEN
      osp$set_status_abnormal (nac$status_id, nae$command_not_allowed, 'DELETE_SERVER', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, utility_state_description [utility_state],
            status);
      RETURN;
    IFEND;

    nap$attach_application_file (status);
    IF status.normal THEN
      pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$delete_server (pvt [p$server].value^.name_value, status);

  PROCEND delete_server;
?? OLDTITLE ??
?? NEWTITLE := 'delete_server_managed_titles', EJECT ??

  PROCEDURE delete_server_managed_titles
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE del_serv_man_titles_pdt (
{     title_patterns, title_pattern, tp: list of any of
{       string 1..255
{       name
{       anyend = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 9, 30, 17, 6, 54, 209],
    clc$command, 4, 2, 1, 0, 0, 0, 2, ''], [
    ['STATUS                         ',clc$nominal_entry, 2],
    ['TITLE_PATTERN                  ',clc$alias_entry, 1],
    ['TITLE_PATTERNS                 ',clc$nominal_entry, 1],
    ['TP                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 49, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$name_type,
      clc$string_type],
      TRUE, 2],
      8, [[1, 0, clc$string_type], [1, 255, FALSE]],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$title_patterns = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    VAR
      display_status: ost$status,
      i: integer,
      j: integer,
      new_title_pattern_list: ^nat$title_pattern_list,
      old_title_pattern_count: integer,
      title_pattern: string (nac$max_title_pattern_length),
      title_pattern_count: integer,
      titles_ptr: ^clt$data_value,
      warnings_given: boolean,
      valid_title_patterns: ^nat$title_pattern_list,
      valid_title_pattern_count: integer;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF server_managed_titles = NIL THEN
      old_title_pattern_count := 0;
      valid_title_pattern_count := 0;
      valid_title_patterns := NIL;
    ELSE
      old_title_pattern_count := UPPERBOUND (server_managed_titles^);
      valid_title_pattern_count := old_title_pattern_count;
      PUSH valid_title_patterns: [1 .. valid_title_pattern_count];
      valid_title_patterns^ := server_managed_titles^;
    IFEND;
    warnings_given := FALSE;

    titles_ptr := pvt [p$title_patterns].value;

  /delete/
    WHILE titles_ptr <> NIL DO
      CASE titles_ptr^.element_value^.kind OF
      = clc$name =
        title_pattern := titles_ptr^.element_value^.name_value
              (1, STRLENGTH (titles_ptr^.element_value^.name_value));
      = clc$string =
        title_pattern := titles_ptr^.element_value^.string_value^
              (1, STRLENGTH (titles_ptr^.element_value^.string_value^));
      CASEND;

      FOR j := 1 TO valid_title_pattern_count DO
        IF title_pattern = valid_title_patterns^ [j] THEN
          valid_title_patterns^ [j] := valid_title_patterns^ [valid_title_pattern_count];
          valid_title_pattern_count := valid_title_pattern_count - 1;
          titles_ptr := titles_ptr^.link;
          CYCLE /delete/;
        IFEND;
      FOREND;
      osp$set_status_abnormal (nac$status_id, nae$unknown_title_pattern, title_pattern, display_status);
      display_message (display_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      warnings_given := TRUE;

      titles_ptr := titles_ptr^.link;

    WHILEND /delete/;
    IF server_managed_titles <> NIL THEN
      FREE server_managed_titles;
    IFEND;
    IF valid_title_pattern_count > 0 THEN
      ALLOCATE new_title_pattern_list: [1 .. valid_title_pattern_count];
      FOR i := 1 TO valid_title_pattern_count DO
        new_title_pattern_list^ [i] := valid_title_patterns^ [i];
      FOREND;
      server_managed_titles := new_title_pattern_list;
    IFEND;

    definition_changed := (definition_changed) OR (old_title_pattern_count > valid_title_pattern_count);

    IF warnings_given THEN
      osp$set_status_abnormal (nac$status_id, nae$warnings_processing_command, 'DELETE_SERVER_MANAGED_TITLES',
            status);
    IFEND;

  PROCEND delete_server_managed_titles;
?? OLDTITLE ??
?? NEWTITLE := 'delete_tcpip', EJECT ??

  PROCEDURE delete_tcpip
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE delete_tcpip_appl_pdt (
{       application, a: name = $required
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 1, 9, 40, 30, 731],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['APPLICATION                    ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      utility_state := utility_idle;
      nap$detach_application_file (ignore_status);

    PROCEND exit_condition_handler;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF utility_state <> utility_idle THEN
      osp$set_status_abnormal (nac$status_id, nae$command_not_allowed, 'DELETE_TCPIP', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, utility_state_description [utility_state],
            status);
      RETURN;
    IFEND;

    nap$attach_application_file (status);

    IF status.normal THEN
      pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$delete_tcpip (pvt [p$application].value^.name_value, status);

  PROCEND delete_tcpip;
?? OLDTITLE ??
?? NEWTITLE := 'delete_titles', EJECT ??

  PROCEDURE delete_titles
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE delete_titles_pdt (
{     titles, title, t: list of any of
{       string 1..255
{       name
{       anyend = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 9, 30, 17, 7, 23, 438],
    clc$command, 4, 2, 1, 0, 0, 0, 2, ''], [
    ['STATUS                         ',clc$nominal_entry, 2],
    ['T                              ',clc$abbreviation_entry, 1],
    ['TITLE                          ',clc$alias_entry, 1],
    ['TITLES                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 49, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$name_type,
      clc$string_type],
      TRUE, 2],
      8, [[1, 0, clc$string_type], [1, 255, FALSE]],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$titles = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    VAR
      delete_title_count: integer,
      display_status: ost$status,
      i: integer,
      j: integer,
      new_title_list: ^array [1 .. * ] of nat$selected_title,
      old_title_count: integer,
      title: string (nac$max_title_length),
      title_count: integer,
      titles_ptr: ^clt$data_value,
      warnings_given: boolean,
      valid_titles: ^array [1 .. * ] of nat$selected_title,
      valid_title_count: integer;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF selected_titles = NIL THEN
      old_title_count := 0;
      valid_title_count := 0;
      valid_titles := NIL;
    ELSE
      old_title_count := UPPERBOUND (selected_titles^);
      valid_title_count := old_title_count;
      PUSH valid_titles: [1 .. valid_title_count];
      valid_titles^ := selected_titles^;
    IFEND;
    warnings_given := FALSE;

    titles_ptr := pvt [p$titles].value;

  /delete/
    WHILE titles_ptr <> NIL DO
      CASE titles_ptr^.element_value^.kind OF
      = clc$name =
        title := titles_ptr^.element_value^.name_value (1, STRLENGTH (titles_ptr^.element_value^.name_value));
      = clc$string =
        title := titles_ptr^.element_value^.string_value^ (1,
              STRLENGTH (titles_ptr^.element_value^.string_value^));
      CASEND;

      FOR j := 1 TO valid_title_count DO
        IF title = valid_titles^ [j].title THEN
          valid_titles^ [j] := valid_titles^ [valid_title_count];
          valid_title_count := valid_title_count - 1;
          selected_titles_changed := TRUE;
          titles_ptr := titles_ptr^.link;
          CYCLE /delete/;
        IFEND;
      FOREND;
      osp$set_status_abnormal (nac$status_id, nae$unknown_title, title, display_status);
      display_message (display_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      warnings_given := TRUE;

      titles_ptr := titles_ptr^.link;

    WHILEND /delete/;
    IF selected_titles <> NIL THEN
      FREE selected_titles;
    IFEND;
    IF valid_title_count > 0 THEN
      ALLOCATE new_title_list: [1 .. valid_title_count];
      FOR i := 1 TO valid_title_count DO
        new_title_list^ [i] := valid_titles^ [i];
      FOREND;
      selected_titles := new_title_list;
    IFEND;

    definition_changed := (definition_changed) OR (old_title_count > valid_title_count);

    IF warnings_given THEN
      osp$set_status_abnormal (nac$status_id, nae$warnings_processing_command, 'DELETE_TITLES', status);
    IFEND;

  PROCEND delete_titles;
?? OLDTITLE ??
?? NEWTITLE := 'display_application_status', EJECT ??

  PROCEDURE display_application_status
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE dis_appl_status_pdt (
{     applications, application, a: list of any of key
{         all
{       keyend
{       name
{       anyend = all
{     output, o: file = $output
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 13, 46, 36, 268],
    clc$command, 6, 3, 0, 0, 0, 0, 3, ''], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['APPLICATION                    ',clc$alias_entry, 1],
    ['APPLICATIONS                   ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$applications = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      application: array [1 .. 1] of nat$application_attribute,
      applications: ^array [1 .. * ] of nat$application_attribute,
      application_count: nat$max_applications,
      application_found: boolean,
      application_index: nat$max_applications,
      application_ptr: ^clt$data_value,
      application_type: nat$application_type,
      ignore_status: ost$status,
      output_specified: boolean,
      parameter_index: integer;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_output_parameter (pvt [p$output], output_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$get_application_names ($type_of_applications [nac$client_application, nac$server_application,
          nac$tcpip_application], application, application_count, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (nac$status_id, nae$application_not_defined, 'client, server, or TCP/IP',
            status);
      RETURN;
    IFEND;
    IF application_count > 0 THEN
      PUSH applications: [1 .. application_count];
      nap$get_application_names ($type_of_applications [nac$client_application, nac$server_application,
            nac$tcpip_application], applications^, application_count, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    application_ptr := pvt [p$applications].value;

  /generate_display/
    BEGIN
      WHILE application_ptr <> NIL DO
        CASE application_ptr^.element_value^.kind OF
        = clc$keyword =
          FOR application_index := 1 TO application_count DO
            CASE applications^ [application_index].application_type OF
            = nac$client_application =
              generate_client_status_display (applications^ [application_index].name, status);
            = nac$server_application =
              generate_server_status_display (applications^ [application_index].name, status);
            = nac$tcpip_application =
              generate_tcpip_status_display (applications^ [application_index].name, status);
            CASEND;
            IF NOT status.normal THEN
              EXIT /generate_display/;
            IFEND;
          FOREND;
          EXIT /generate_display/;
        = clc$name =
          application_found := FALSE;
          FOR application_index := 1 TO application_count DO
            IF (application_ptr^.element_value^.name_value = applications^ [application_index].name) THEN
              application_found := TRUE;
              CASE applications^ [application_index].application_type OF
              = nac$client_application =
                generate_client_status_display (applications^ [application_index].name, status);
              = nac$server_application =
                generate_server_status_display (applications^ [application_index].name, status);
              = nac$tcpip_application =
                generate_tcpip_status_display (applications^ [application_index].name, status);
              CASEND;
              IF NOT status.normal THEN
                EXIT /generate_display/;
              IFEND;
            IFEND;
          FOREND;
          IF NOT application_found THEN
            osp$set_status_abnormal (nac$status_id, nae$unknown_application,
                  application_ptr^.element_value^.name_value, status);
            EXIT /generate_display/;
          IFEND;
        CASEND;

        application_ptr := application_ptr^.link;

      WHILEND;
    END /generate_display/;

    IF output_specified THEN
      clp$close_display (local_display_control, ignore_status);
    IFEND;

  PROCEND display_application_status;
?? OLDTITLE ??
?? NEWTITLE := 'display_client_attributes', EJECT ??

  PROCEDURE display_client_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE dis_client_attrib_pdt (
{   client, c: list of any of key
{       all
{     keyend
{     name
{     anyend = all
{   display_options, display_option, do, attributes, attribute, a: list of key
{       (protocol, p)
{       (application_identifier, ai)
{       (maximum_connections, mc)
{       (connection_priority, cp)
{       (client_capability, cc)
{       (client_ring, cr)
{       (client_status, cs)
{       (client_system_privilege, csp)
{        all
{     keyend = all
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: 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 .. 17] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 7, 25, 7, 47, 4, 649],
    clc$command, 11, 4, 0, 0, 0, 0, 4, ''], [
    ['A                              ',clc$abbreviation_entry, 2],
    ['ATTRIBUTE                      ',clc$alias_entry, 2],
    ['ATTRIBUTES                     ',clc$alias_entry, 2],
    ['C                              ',clc$abbreviation_entry, 1],
    ['CLIENT                         ',clc$nominal_entry, 1],
    ['DISPLAY_OPTION                 ',clc$alias_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 2],
    ['DO                             ',clc$alias_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 652, clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type,
      clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$list_type], [636, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [17], [
      ['AI                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
      ['APPLICATION_IDENTIFIER         ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['CC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
      ['CLIENT_CAPABILITY              ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
      ['CLIENT_RING                    ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
      ['CLIENT_STATUS                  ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
      ['CLIENT_SYSTEM_PRIVILEGE        ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
      ['CONNECTION_PRIORITY            ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['CP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
      ['CR                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
      ['CS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
      ['CSP                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
      ['MAXIMUM_CONNECTIONS            ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['MC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
      ['P                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
      ['PROTOCOL                       ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$client = 1,
      p$display_options = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;


    VAR
      application_count: nat$max_applications,
      application_index: nat$max_applications,
      application: array [1 .. 1] of nat$application_attribute,
      applications: ^array [1 .. * ] of nat$application_attribute,
      attributes: client_attribute_set,
      client_ptr: ^clt$data_value,
      ignore_status: ost$status,
      output_specified: boolean;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_client_attrib_parameter (pvt [p$display_options], attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_output_parameter (pvt [p$output], output_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    client_ptr := pvt [p$client].value;

  /generate_display/
    BEGIN
      WHILE client_ptr <> NIL DO
        CASE client_ptr^.element_value^.kind OF
        = clc$keyword =
          nap$get_application_names ($type_of_applications [nac$client_application], application,
                application_count, status);
          IF NOT status.normal THEN
            EXIT /generate_display/;
          IFEND;
          IF application_count > 0 THEN
            PUSH applications: [1 .. application_count];
            nap$get_application_names ($type_of_applications [nac$client_application], applications^,
                  application_count, status);
            IF NOT status.normal THEN
              EXIT /generate_display/;
            IFEND;
            FOR application_index := 1 TO application_count DO
              display_installed_client (applications^ [application_index].name, attributes, status);
              IF NOT status.normal THEN
                EXIT /generate_display/;
              IFEND;
            FOREND;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$application_not_defined, 'client', status);
          IFEND;
          EXIT /generate_display/;
        = clc$name =
          display_installed_client (client_ptr^.element_value^.name_value, attributes, status);
          IF NOT status.normal THEN
            EXIT /generate_display/;
          IFEND;
        CASEND;
        client_ptr := client_ptr^.link;

      WHILEND;
    END /generate_display/;

    IF output_specified THEN
      clp$close_display (local_display_control, ignore_status);
    IFEND;

  PROCEND display_client_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'display_client_status', EJECT ??

  PROCEDURE display_client_status
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE dis_client_status_pdt (
{     client, c: list of any of key
{         all
{       keyend
{       name
{       anyend = all
{     output, o: file = $output
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 13, 47, 49, 568],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CLIENT                         ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$client = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      application_count: nat$max_applications,
      application_index: nat$max_applications,
      application: array [1 .. 1] of nat$application_attribute,
      applications: ^array [1 .. * ] of nat$application_attribute,
      client_ptr: ^clt$data_value,
      ignore_status: ost$status,
      j: integer,
      output_specified: boolean;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_output_parameter (pvt [p$output], output_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    client_ptr := pvt [p$client].value;

  /display_client/
    WHILE client_ptr <> NIL DO
      CASE client_ptr^.element_value^.kind OF
      = clc$keyword =
        nap$get_application_names ($type_of_applications [nac$client_application], application,
              application_count, status);
        IF NOT status.normal THEN
          EXIT /display_client/;
        IFEND;
        IF application_count > 0 THEN
          PUSH applications: [1 .. application_count];
          nap$get_application_names ($type_of_applications [nac$client_application], applications^,
                application_count, status);
          IF NOT status.normal THEN
            EXIT /display_client/;
          IFEND;
          FOR application_index := 1 TO application_count DO
            IF applications^ [application_index].application_type = nac$client_application THEN
              generate_client_status_display (applications^ [application_index].name, status);
              IF NOT status.normal THEN
                EXIT /display_client/;
              IFEND;
            IFEND;
          FOREND;
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$application_not_defined, 'client', status);
        IFEND;
        EXIT /display_client/;
      = clc$name =
        generate_client_status_display (client_ptr^.element_value^.name_value, status);
        IF NOT status.normal THEN
          EXIT /display_client/;
        IFEND;
      CASEND;
      client_ptr := client_ptr^.link;

    WHILEND /display_client/;

    IF output_specified THEN
      clp$close_display (local_display_control, ignore_status);
    IFEND;

  PROCEND display_client_status;
?? OLDTITLE ??
?? NEWTITLE := 'display_server_attributes', EJECT ??

  PROCEDURE display_server_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE dis_server_attrib_pdt (
{   server, s: list of any of key
{       all
{     keyend
{     name
{     anyend = all
{   display_options, display_option, do, attributes, attribute, a: list of key
{       (accept_connection, ac)
{       (application_identifier, ai)
{       (client_addresses, client_address, ca)
{       (client_info_source, cis)
{       (client_validation, cv)
{       (connection_priority, cp)
{       (maximum_connections, mc)
{       (nam_initiated, ni)
{       (protocol, p)
{       (server_capability, sc)
{       (server_job, sj)
{       (server_job_maximum_connections, sjmc)
{       (server_job_validation_source, sjvs)
{       (server_managed_titles, server_managed_title, smt)
{       (server_ring, sr)
{       (server_status, ss)
{       (server_system_privilege, ssp)
{      (titles, title, t)
{       (title_attributes, title_attribute, ta)
{       all
{     keyend = all
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: 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 .. 43] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 5, 29, 15, 57, 41, 224],
    clc$command, 11, 4, 0, 0, 0, 0, 4, ''], [
    ['A                              ',clc$abbreviation_entry, 2],
    ['ATTRIBUTE                      ',clc$alias_entry, 2],
    ['ATTRIBUTES                     ',clc$alias_entry, 2],
    ['DISPLAY_OPTION                 ',clc$alias_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 2],
    ['DO                             ',clc$alias_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['S                              ',clc$abbreviation_entry, 1],
    ['SERVER                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 1614, clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type,
      clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$list_type], [1598, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [43], [
      ['AC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
      ['ACCEPT_CONNECTION              ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['AI                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 20],
      ['APPLICATION_IDENTIFIER         ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['CA                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
      ['CIS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
      ['CLIENT_ADDRESS                 ', clc$alias_entry,
  clc$normal_usage_entry, 3],
      ['CLIENT_ADDRESSES               ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['CLIENT_INFO_SOURCE             ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['CLIENT_VALIDATION              ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
      ['CONNECTION_PRIORITY            ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
      ['CP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
      ['CV                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
      ['MAXIMUM_CONNECTIONS            ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
      ['MC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
      ['NAM_INITIATED                  ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
      ['NI                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
      ['P                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
      ['PROTOCOL                       ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
      ['SC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
      ['SERVER_CAPABILITY              ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
      ['SERVER_JOB                     ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
      ['SERVER_JOB_MAXIMUM_CONNECTIONS ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
      ['SERVER_JOB_VALIDATION_SOURCE   ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
      ['SERVER_MANAGED_TITLE           ', clc$alias_entry,
  clc$normal_usage_entry, 14],
      ['SERVER_MANAGED_TITLES          ', clc$nominal_entry,
  clc$normal_usage_entry, 14],
      ['SERVER_RING                    ', clc$nominal_entry,
  clc$normal_usage_entry, 15],
      ['SERVER_STATUS                  ', clc$nominal_entry,
  clc$normal_usage_entry, 16],
      ['SERVER_SYSTEM_PRIVILEGE        ', clc$nominal_entry,
  clc$normal_usage_entry, 17],
      ['SJ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 11],
      ['SJMC                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 12],
      ['SJVS                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 13],
      ['SMT                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 14],
      ['SR                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 15],
      ['SS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 16],
      ['SSP                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 17],
      ['T                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 18],
      ['TA                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 19],
      ['TITLE                          ', clc$alias_entry,
  clc$normal_usage_entry, 18],
      ['TITLES                         ', clc$nominal_entry,
  clc$normal_usage_entry, 18],
      ['TITLE_ATTRIBUTE                ', clc$alias_entry,
  clc$normal_usage_entry, 19],
      ['TITLE_ATTRIBUTES               ', clc$nominal_entry,
  clc$normal_usage_entry, 19]]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$server = 1,
      p$display_options = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      application_count: nat$max_applications,
      application_index: nat$max_applications,
      application: array [1 .. 1] of nat$application_attribute,
      applications: ^array [1 .. * ] of nat$application_attribute,
      attributes: server_attribute_set,
      ignore_status: ost$status,
      output_specified: boolean,
      server_ptr: ^clt$data_value;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_server_attrib_parameter (pvt [p$display_options], attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_output_parameter (pvt [p$output], output_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server_ptr := pvt [p$server].value;

  /generate_display/
    BEGIN
      WHILE server_ptr <> NIL DO
        CASE server_ptr^.element_value^.kind OF
        = clc$keyword =
          nap$get_application_names ($type_of_applications [nac$server_application], application,
                application_count, status);
          IF NOT status.normal THEN
            EXIT /generate_display/;
          IFEND;
          IF application_count > 0 THEN
            PUSH applications: [1 .. application_count];
            nap$get_application_names ($type_of_applications [nac$server_application], applications^,
                  application_count, status);
            IF NOT status.normal THEN
              EXIT /generate_display/;
            IFEND;
            FOR application_index := 1 TO application_count DO
              display_installed_server (applications^ [application_index].name, attributes, status);
              IF NOT status.normal THEN
                EXIT /generate_display/;
              IFEND;
            FOREND;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$application_not_defined, 'server', status);
          IFEND;
          EXIT /generate_display/;
        = clc$name =
          display_installed_server (server_ptr^.element_value^.name_value, attributes, status);
          IF NOT status.normal THEN
            EXIT /generate_display/;
          IFEND;
        CASEND;
        server_ptr := server_ptr^.link;

      WHILEND;
    END /generate_display/;

    IF output_specified THEN
      clp$close_display (local_display_control, ignore_status);
    IFEND;

  PROCEND display_server_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'display_server_status', EJECT ??

  PROCEDURE display_server_status
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE dis_server_status_pdt (
{     server, s: list of any of key
{         all
{       keyend
{       name
{       anyend = all
{     output, o: file = $output
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 13, 46, 20, 360],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['S                              ',clc$abbreviation_entry, 1],
    ['SERVER                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$server = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      application_count: nat$max_applications,
      application_index: nat$max_applications,
      application: array [1 .. 1] of nat$application_attribute,
      applications: ^array [1 .. * ] of nat$application_attribute,
      ignore_status: ost$status,
      output_specified: boolean,
      server_ptr: ^clt$data_value;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_output_parameter (pvt [p$output], output_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server_ptr := pvt [p$server].value;

  /generate_display/
    WHILE server_ptr <> NIL DO
      CASE server_ptr^.element_value^.kind OF
      = clc$keyword =
        nap$get_application_names ($type_of_applications [nac$server_application], application,
              application_count, status);
        IF NOT status.normal THEN
          EXIT /generate_display/;
        IFEND;
        IF application_count > 0 THEN
          PUSH applications: [1 .. application_count];
          nap$get_application_names ($type_of_applications [nac$server_application], applications^,
                application_count, status);
          IF NOT status.normal THEN
            EXIT /generate_display/;
          IFEND;
          FOR application_index := 1 TO application_count DO
            generate_server_status_display (applications^ [application_index].name, status);
            IF NOT status.normal THEN
              EXIT /generate_display/;
            IFEND;
          FOREND;
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$application_not_defined, 'server', status);
        IFEND;
        EXIT /generate_display/;
      = clc$name =
        generate_server_status_display (server_ptr^.element_value^.name_value, status);
        IF NOT status.normal THEN
          EXIT /generate_display/;
        IFEND;
      CASEND;
      server_ptr := server_ptr^.link;

    WHILEND /generate_display/;

    IF output_specified THEN
      clp$close_display (local_display_control, ignore_status);
    IFEND;

  PROCEND display_server_status;
?? OLDTITLE ??
?? NEWTITLE := 'display_tcpip_attributes', EJECT ??

  PROCEDURE display_tcpip_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_tcpip_attr_pdt (
{       application, a: list of any of key
{             all
{         keyend
{         name
{         anyend = all
{       display_option, display_options, do: list of key
{             (protocol, p)
{             (maximum_sockets, ms)
{             (capability, c)
{             (ring, r)
{             (system_privilege, sp)
{             all
{         keyend = all
{       output, o: file = $output
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 11] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 9, 11, 42, 7, 46],
    clc$command, 8, 4, 0, 0, 0, 0, 4, ''], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['APPLICATION                    ',clc$nominal_entry, 1],
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 430,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$list_type], [414, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [11], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['CAPABILITY                     ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['MAXIMUM_SOCKETS                ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['MS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['PROTOCOL                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['RING                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['SYSTEM_PRIVILEGE               ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['SP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5]]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application = 1,
      p$display_option = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;


    VAR
      application_count: nat$max_applications,
      application_index: nat$max_applications,
      application: array [1 .. 1] of nat$application_attribute,
      applications: ^array [1 .. * ] of nat$application_attribute,
      attributes: tcpip_attribute_set,
      ignore_status: ost$status,
      output_specified: boolean,
      tcpip_index_ptr: ^clt$data_value;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_tcpip_attrib_parameter (pvt [p$display_option], attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_output_parameter (pvt [p$output], output_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /generate_display/
    BEGIN
      tcpip_index_ptr := pvt [p$application].value;
      WHILE tcpip_index_ptr <> NIL DO
        CASE tcpip_index_ptr^.element_value^.kind OF
        = clc$keyword =
          nap$get_application_names ($type_of_applications [nac$tcpip_application], application,
                application_count, status);
          IF NOT status.normal THEN
            EXIT /generate_display/;
          IFEND;
          IF application_count > 0 THEN
            PUSH applications: [1 .. application_count];
            nap$get_application_names ($type_of_applications [nac$tcpip_application], applications^,
                  application_count, status);
            IF NOT status.normal THEN
              EXIT /generate_display/;
            IFEND;
            FOR application_index := 1 TO application_count DO
              display_installed_tcpip (applications^ [application_index].name, attributes, status);
              IF NOT status.normal THEN
                EXIT /generate_display/;
              IFEND;
            FOREND;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$application_not_defined, 'tcpip', status);
          IFEND;
          EXIT /generate_display/;
        = clc$name =
          display_installed_tcpip (tcpip_index_ptr^.element_value^.name_value, attributes, status);
          IF NOT status.normal THEN
            EXIT /generate_display/;
          IFEND;
        CASEND;
        tcpip_index_ptr := tcpip_index_ptr^.link;
      WHILEND;
    END /generate_display/;

    IF output_specified THEN
      clp$close_display (local_display_control, ignore_status);
    IFEND;

  PROCEND display_tcpip_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'display_tcpip_status', EJECT ??

  PROCEDURE display_tcpip_status
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_tcpip_stat_pdt (
{       application, a: list of any of key
{             all
{         keyend
{         name
{         anyend = all
{       output, o: file = $output
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 1, 9, 40, 32, 412],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['APPLICATION                    ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      application_count: nat$max_applications,
      application_index: nat$max_applications,
      application: array [1 .. 1] of nat$application_attribute,
      applications: ^array [1 .. * ] of nat$application_attribute,
      ignore_status: ost$status,
      output_specified: boolean,
      tcpip: clt$value,
      tcpip_count: integer,
      tcpip_index_ptr: ^clt$data_value;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_output_parameter (pvt [p$output], output_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    tcpip_index_ptr := pvt [p$application].value;

  /generate_display/
    WHILE tcpip_index_ptr <> NIL DO
      CASE tcpip_index_ptr^.element_value^.kind OF
      = clc$keyword =
        nap$get_application_names ($type_of_applications [nac$tcpip_application], application,
              application_count, status);
        IF NOT status.normal THEN
          EXIT /generate_display/;
        IFEND;
        IF application_count > 0 THEN
          PUSH applications: [1 .. application_count];
          nap$get_application_names ($type_of_applications [nac$tcpip_application], applications^,
                application_count, status);
          IF NOT status.normal THEN
            EXIT /generate_display/;
          IFEND;
          FOR application_index := 1 TO application_count DO
            generate_tcpip_status_display (applications^ [application_index].name, status);
            IF NOT status.normal THEN
              EXIT /generate_display/;
            IFEND;
          FOREND;
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$application_not_defined, 'tcpip', status);
        IFEND;
        EXIT /generate_display/;
      = clc$name =
        generate_tcpip_status_display (tcpip_index_ptr^.element_value^.name_value, status);
        IF NOT status.normal THEN
          EXIT /generate_display/;
        IFEND;
      CASEND;
      tcpip_index_ptr := tcpip_index_ptr^.link;
    WHILEND /generate_display/;

    IF output_specified THEN
      clp$close_display (local_display_control, ignore_status);
    IFEND;

  PROCEND display_tcpip_status;
?? OLDTITLE ??
?? NEWTITLE := 'generate_application_definition', EJECT ??

  PROCEDURE generate_application_definition
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE gen_application_def_pdt (
{        applications, application, a: list of any of key
{            all
{          keyend
{          name
{          anyend = all
{        output, o: file = $output
{        status )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 7, 25, 7, 55, 17, 9],
    clc$command, 6, 3, 0, 0, 0, 0, 3, ''], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['APPLICATION                    ',clc$alias_entry, 1],
    ['APPLICATIONS                   ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type,
      clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$applications = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      application: array [1 .. 1] of nat$application_attribute,
      applications: ^array [1 .. * ] of nat$application_attribute,
      application_count: nat$max_applications,
      application_found: boolean,
      application_index: nat$max_applications,
      application_ptr: ^clt$data_value,
      application_type: nat$application_type,
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler,
      ignore_status: ost$status,
      local_status: ost$status,
      parameter_index: integer;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (output_file_id, ignore_status);

    PROCEND exit_condition_handler;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_output_file (pvt [p$output].value^.file_value^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nap$get_application_names ($type_of_applications [nac$client_application, nac$server_application,
          nac$tcpip_application], application, application_count, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (nac$status_id, nae$application_not_defined, 'client, server, or TCP/IP',
            status);
      RETURN;
    IFEND;

    PUSH applications: [1 .. application_count];
    nap$get_application_names ($type_of_applications [nac$client_application, nac$server_application,
          nac$tcpip_application], applications^, application_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    application_ptr := pvt [p$applications].value;

  /generate_definition/
    BEGIN
      WHILE application_ptr <> NIL DO
        CASE application_ptr^.element_value^.kind OF
        = clc$keyword =
          FOR application_index := 1 TO application_count DO
            CASE applications^ [application_index].application_type OF
            = nac$client_application =
              generate_installed_client_def (applications^ [application_index].name, status);
            = nac$server_application =
              generate_installed_server_def (applications^ [application_index].name, status);
            = nac$tcpip_application =
              generate_installed_tcpip_def (applications^ [application_index].name, status);
            CASEND;
            IF NOT status.normal THEN
              EXIT /generate_definition/;
            IFEND;
          FOREND;
          EXIT /generate_definition/;
        = clc$name =
          application_found := FALSE;
          FOR application_index := 1 TO application_count DO
            IF (application_ptr^.element_value^.name_value = applications^ [application_index].name) THEN
              application_found := TRUE;
              CASE applications^ [application_index].application_type OF
              = nac$client_application =
                generate_installed_client_def (applications^ [application_index].name, status);
              = nac$server_application =
                generate_installed_server_def (applications^ [application_index].name, status);
              = nac$tcpip_application =
                generate_installed_tcpip_def (applications^ [application_index].name, status);
              CASEND;
              IF NOT status.normal THEN
                EXIT /generate_definition/;
              IFEND;
            IFEND;
          FOREND;
          IF NOT application_found THEN
            osp$set_status_abnormal (nac$status_id, nae$unknown_application,
                  application_ptr^.element_value^.name_value, status);
            EXIT /generate_definition/;
          IFEND;
        ELSE
        CASEND;

        application_ptr := application_ptr^.link;

      WHILEND;
    END /generate_definition/;

    fsp$close_file (output_file_id, local_status);
    IF (NOT local_status.normal) AND status.normal THEN
      status := local_status;
    IFEND;
    pmp$disestablish_cond_handler (exit_condition, ignore_status);

  PROCEND generate_application_definition;
?? OLDTITLE ??
?? NEWTITLE := 'generate_client_definition', EJECT ??

  PROCEDURE generate_client_definition
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE gen_client_def_pdt (
{        client, c: list of any of key
{            all
{          keyend
{          name
{          anyend = all
{        output, o: file = $output
{        status )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 13, 46, 6, 1],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CLIENT                         ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$client = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      application_count: nat$max_applications,
      application_index: nat$max_applications,
      application: array [1 .. 1] of nat$application_attribute,
      applications: ^array [1 .. * ] of nat$application_attribute,
      client_ptr: ^clt$data_value,
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler,
      ignore_status: ost$status,
      local_status: ost$status;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (output_file_id, ignore_status);

    PROCEND exit_condition_handler;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_output_file (pvt [p$output].value^.file_value^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    client_ptr := pvt [p$client].value;

  /generate_definition/
    BEGIN
      WHILE client_ptr <> NIL DO
        CASE client_ptr^.element_value^.kind OF
        = clc$keyword =
          nap$get_application_names ($type_of_applications [nac$client_application], application,
                application_count, status);
          IF NOT status.normal THEN
            EXIT /generate_definition/;
          IFEND;
          IF application_count > 0 THEN
            PUSH applications: [1 .. application_count];
            nap$get_application_names ($type_of_applications [nac$client_application], applications^,
                  application_count, status);
            IF NOT status.normal THEN
              EXIT /generate_definition/;
            IFEND;
            FOR application_index := 1 TO application_count DO
              generate_installed_client_def (applications^ [application_index].name, status);
              IF NOT status.normal THEN
                EXIT /generate_definition/;
              IFEND;
            FOREND;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$application_not_defined, 'client', status);
          IFEND;
          EXIT /generate_definition/;
        = clc$name =
          generate_installed_client_def (client_ptr^.element_value^.name_value, status);
          IF NOT status.normal THEN
            EXIT /generate_definition/;
          IFEND;
        CASEND;
        client_ptr := client_ptr^.link;

      WHILEND;
    END /generate_definition/;

    fsp$close_file (output_file_id, local_status);
    IF (NOT local_status.normal) AND status.normal THEN
      status := local_status;
    IFEND;

  PROCEND generate_client_definition;
?? OLDTITLE ??
?? NEWTITLE := 'generate_server_definition', EJECT ??

  PROCEDURE generate_server_definition
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE gen_server_def_pdt (
{        server, s: list of any of key
{            all
{          keyend
{          name
{          anyend = all
{        output, o: file = $output
{        status )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 7, 25, 8, 1, 35, 168],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['S                              ',clc$abbreviation_entry, 1],
    ['SERVER                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type,
      clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$server = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      application_count: nat$max_applications,
      application_index: nat$max_applications,
      application: array [1 .. 1] of nat$application_attribute,
      applications: ^array [1 .. * ] of nat$application_attribute,
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler,
      ignore_status: ost$status,
      local_status: ost$status,
      server_ptr: ^clt$data_value;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (output_file_id, ignore_status);

    PROCEND exit_condition_handler;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_output_file (pvt [p$output].value^.file_value^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server_ptr := pvt [p$server].value;

  /generate_definition/
    BEGIN
      WHILE server_ptr <> NIL DO
        CASE server_ptr^.element_value^.kind OF
        = clc$keyword =
          nap$get_application_names ($type_of_applications [nac$server_application], application,
                application_count, status);
          IF NOT status.normal THEN
            EXIT /generate_definition/;
          IFEND;
          IF application_count > 0 THEN
            PUSH applications: [1 .. application_count];
            nap$get_application_names ($type_of_applications [nac$server_application], applications^,
                  application_count, status);
            IF NOT status.normal THEN
              EXIT /generate_definition/;
            IFEND;
            FOR application_index := 1 TO application_count DO
              generate_installed_server_def (applications^ [application_index].name, status);
              IF NOT status.normal THEN
                EXIT /generate_definition/;
              IFEND;
            FOREND;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$application_not_defined, 'server', status);
          IFEND;
          EXIT /generate_definition/;
        = clc$name =
          generate_installed_server_def (server_ptr^.element_value^.name_value, status);
          IF NOT status.normal THEN
            EXIT /generate_definition/;
          IFEND;
        CASEND;

        server_ptr := server_ptr^.link;

      WHILEND;
    END /generate_definition/;

    fsp$close_file (output_file_id, local_status);
    IF (NOT local_status.normal) AND status.normal THEN
      status := local_status;
    IFEND;

  PROCEND generate_server_definition;
?? OLDTITLE ??
?? NEWTITLE := 'generate_tcpip_definition', EJECT ??

  PROCEDURE generate_tcpip_definition
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE generate_tcpip_definition_pdt (
{       application, a: list of any of key
{           all
{         keyend
{         name
{         anyend = all
{       output, o: file = $output
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 1, 9, 40, 34, 594],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['APPLICATION                    ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      application_count: nat$max_applications,
      application_index: nat$max_applications,
      application: array [1 .. 1] of nat$application_attribute,
      applications: ^array [1 .. * ] of nat$application_attribute,
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler,
      ignore_status: ost$status,
      local_status: ost$status,
      tcpip_index_ptr: ^clt$data_value;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (output_file_id, ignore_status);

    PROCEND exit_condition_handler;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_output_file (pvt [p$output].value^.file_value^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /generate_definition/
    BEGIN
      tcpip_index_ptr := pvt [p$application].value;
      WHILE tcpip_index_ptr <> NIL DO
        CASE tcpip_index_ptr^.element_value^.kind OF
        = clc$keyword =
          nap$get_application_names ($type_of_applications [nac$tcpip_application], application,
                application_count, status);
          IF NOT status.normal THEN
            EXIT /generate_definition/;
          IFEND;
          IF application_count > 0 THEN
            PUSH applications: [1 .. application_count];
            nap$get_application_names ($type_of_applications [nac$tcpip_application], applications^,
                  application_count, status);
            IF NOT status.normal THEN
              EXIT /generate_definition/;
            IFEND;
            FOR application_index := 1 TO application_count DO
              generate_installed_tcpip_def (applications^ [application_index].name, status);
              IF NOT status.normal THEN
                EXIT /generate_definition/;
              IFEND;
            FOREND;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$application_not_defined, 'tcpip', status);
          IFEND;
          EXIT /generate_definition/;
        = clc$name =
          generate_installed_tcpip_def (tcpip_index_ptr^.element_value^.name_value, status);
          IF NOT status.normal THEN
            EXIT /generate_definition/;
          IFEND;
        ELSE
        CASEND;
        tcpip_index_ptr := tcpip_index_ptr^.link;
      WHILEND;
    END /generate_definition/;

    fsp$close_file (output_file_id, local_status);
    IF (NOT local_status.normal) AND status.normal THEN
      status := local_status;
    IFEND;

  PROCEND generate_tcpip_definition;
?? OLDTITLE ??
?? NEWTITLE := 'quit', EJECT ??

  PROCEDURE quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PURPOSE: This procedure is the command processor for the MANNA quit command.
{ DESIGN:

{ PROCEDURE quit_pdt (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [89, 7, 10, 15, 19, 34, 604],
    clc$command, 1, 1, 0, 0, 0, 0, 1, ''], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    VAR
      ignore_status: ost$status;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$end_include (utility_name, ignore_status);
    clp$close_display (output_control, ignore_status);

  PROCEND quit;

?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'Subcommand Processors' ??
?? NEWTITLE := 'add_client_address', EJECT ??

  PROCEDURE add_client_address
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE add_client_addr_pdt (
{     network_identifier, ni: any of key
{           all
{         keyend
{         integer 1 .. 0ffffffff(16)
{         anyend = all
{     system_identifier, si: any of key
{           cdcnet,
{           nosve,
{           all
{         keyend
{         integer 1 .. 0ffffffffffff(16)
{         anyend = all
{     application_identifier, ai: any of key
{           all
{         keyend
{         integer 2000 .. 3000
{         anyend = all
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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$integer_type_qualifier,
        recend,
        default_value: string (3),
      recend,
      type2: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (3),
      recend,
      type3: 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$integer_type_qualifier,
        recend,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 7, 25, 8, 7, 11, 298],
    clc$command, 7, 4, 0, 0, 0, 0, 4, ''], [
    ['AI                             ',clc$abbreviation_entry, 3],
    ['APPLICATION_IDENTIFIER         ',clc$nominal_entry, 3],
    ['NETWORK_IDENTIFIER             ',clc$nominal_entry, 1],
    ['NI                             ',clc$abbreviation_entry, 1],
    ['SI                             ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['SYSTEM_IDENTIFIER              ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 158, clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, 0ffffffff(16), 10]]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['CDCNET                         ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NOSVE                          ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [1, 0ffffffffffff(16), 10]]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [2000, 3000, 10]]
    ,
    'all'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$network_identifier = 1,
      p$system_identifier = 2,
      p$application_identifier = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;


    VAR
      i: integer,
      new_address_list: ^array [1 .. * ] of nat$client_address,
      new_address_count: integer,
      old_address_count: integer,
      value: clt$value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF client_addresses = NIL THEN
      old_address_count := 0;
    ELSE
      old_address_count := UPPERBOUND (client_addresses^);
    IFEND;
    new_address_count := old_address_count + 1;
    ALLOCATE new_address_list: [1 .. new_address_count];
    FOR i := 1 TO old_address_count DO
      new_address_list^ [i] := client_addresses^ [i];
    FOREND;

    CASE pvt [p$network_identifier].value^.kind OF
    = clc$keyword =
      new_address_list^ [new_address_count].network_id := 0;
    = clc$integer =
      new_address_list^ [new_address_count].network_id := pvt [p$network_identifier].value^.integer_value.
            value;
    CASEND;

    CASE pvt [p$system_identifier].value^.kind OF
    = clc$keyword =
      IF pvt [p$system_identifier].value^.keyword_value = all_keyword THEN
        new_address_list^ [new_address_count].system_kind := nac$any_system_kind;
        new_address_list^ [new_address_count].system_id := 0;
      ELSEIF pvt [p$system_identifier].value^.keyword_value = 'NOSVE' THEN
        new_address_list^ [new_address_count].system_kind := nac$nosve_system_kind;
        new_address_list^ [new_address_count].system_id := 0;
      ELSE
        new_address_list^ [new_address_count].system_kind := nac$cdcnet_system_kind;
        new_address_list^ [new_address_count].system_id := 0;
      IFEND;
    = clc$integer =
      new_address_list^ [new_address_count].system_kind := nac$any_system_kind;
      new_address_list^ [new_address_count].system_id := pvt [p$system_identifier].value^.integer_value.value;
    CASEND;

    CASE pvt [p$application_identifier].value^.kind OF
    = clc$keyword =
      new_address_list^ [new_address_count].reserved_application_id := FALSE;
      new_address_list^ [new_address_count].application_id := 0;
    = clc$integer =
      new_address_list^ [new_address_count].reserved_application_id := TRUE;
      new_address_list^ [new_address_count].application_id :=
            pvt [p$application_identifier].value^.integer_value.value;
    CASEND;

    IF client_addresses <> NIL THEN
      FREE client_addresses;
    IFEND;
    client_addresses := new_address_list;

    definition_changed := TRUE;

  PROCEND add_client_address;
?? OLDTITLE ??
?? NEWTITLE := 'add_server_managed_titles', EJECT ??

  PROCEDURE add_server_managed_titles
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE add_serv_man_titles (
{     title_patterns, title_pattern, tp: list of any of
{         string 1..255
{         name
{         anyend = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 9, 30, 17, 7, 49, 994],
    clc$command, 4, 2, 1, 0, 0, 0, 2, ''], [
    ['STATUS                         ',clc$nominal_entry, 2],
    ['TITLE_PATTERN                  ',clc$alias_entry, 1],
    ['TITLE_PATTERNS                 ',clc$nominal_entry, 1],
    ['TP                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 49, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$name_type,
      clc$string_type],
      TRUE, 2],
      8, [[1, 0, clc$string_type], [1, 255, FALSE]],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$title_patterns = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    VAR
      count_ptr: ^clt$data_value,
      display_status: ost$status,
      i: integer,
      j: integer,
      new_title_pattern_count: integer,
      new_title_pattern_list: ^nat$title_pattern_list,
      old_title_pattern_count: integer,
      title_pattern: string (nac$max_title_pattern_length),
      title_pattern_count: integer,
      title_ptr: ^clt$data_value,
      warnings_given: boolean,
      valid_title_patterns: ^nat$title_pattern_list,
      valid_title_pattern_count: integer;

    warnings_given := FALSE;
    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF server_managed_titles = NIL THEN
      old_title_pattern_count := 0;
    ELSE
      old_title_pattern_count := UPPERBOUND (server_managed_titles^);
    IFEND;
    valid_title_pattern_count := 0;
    new_title_pattern_count := 0;
    count_ptr := pvt [p$title_patterns].value;
    WHILE count_ptr <> NIL DO
      new_title_pattern_count := new_title_pattern_count + 1;
      count_ptr := count_ptr^.link;
    WHILEND;

    PUSH valid_title_patterns: [1 .. new_title_pattern_count];

    title_ptr := pvt [p$title_patterns].value;

  /validate_titles/
    WHILE title_ptr <> NIL DO
      CASE title_ptr^.element_value^.kind OF
      = clc$name =
        title_pattern := title_ptr^.element_value^.name_value;
      = clc$string =
        title_pattern := title_ptr^.element_value^.string_value^;
      CASEND;
      FOR j := 1 TO old_title_pattern_count DO
        IF title_pattern = server_managed_titles^ [j] THEN
          osp$set_status_abnormal (nac$status_id, nae$duplicate_title_pattern, 'Add_server_managed_titles',
                display_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, title_pattern, display_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, application_name, display_status);
          display_message (display_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          warnings_given := TRUE;
          title_ptr := title_ptr^.link;
          CYCLE /validate_titles/;
        IFEND;
      FOREND;
      valid_title_pattern_count := valid_title_pattern_count + 1;
      valid_title_patterns^ [valid_title_pattern_count] := title_pattern;

      title_ptr := title_ptr^.link;

    WHILEND /validate_titles/;
    ALLOCATE new_title_pattern_list: [1 .. old_title_pattern_count + valid_title_pattern_count];
    FOR i := 1 TO old_title_pattern_count DO
      new_title_pattern_list^ [i] := server_managed_titles^ [i];
    FOREND;
    FOR i := 1 TO valid_title_pattern_count DO
      new_title_pattern_list^ [i + old_title_pattern_count] := valid_title_patterns^ [i];
    FOREND;
    IF server_managed_titles <> NIL THEN
      FREE server_managed_titles;
    IFEND;
    server_managed_titles := new_title_pattern_list;

    definition_changed := valid_title_pattern_count > 0;
    IF warnings_given THEN
      osp$set_status_abnormal (nac$status_id, nae$warnings_processing_command, 'ADD_SERVER_MANAGED_TITLES',
            status);
    IFEND;

  PROCEND add_server_managed_titles;
?? OLDTITLE ??
?? NEWTITLE := 'add_titles', EJECT ??

  PROCEDURE add_titles
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE add_titles_pdt (
{     titles, title, t: list of any of
{         string 1..255
{         name
{       anyend = $required
{     broadcast_registration, br: boolean = FALSE
{     priority, p: integer 1..255 = 1
{     data, d: string 1..32
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 9, 30, 17, 8, 10, 22],
    clc$command, 10, 5, 1, 0, 0, 0, 5, ''], [
    ['BR                             ',clc$abbreviation_entry, 2],
    ['BROADCAST_REGISTRATION         ',clc$nominal_entry, 2],
    ['D                              ',clc$abbreviation_entry, 4],
    ['DATA                           ',clc$nominal_entry, 4],
    ['P                              ',clc$abbreviation_entry, 3],
    ['PRIORITY                       ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['T                              ',clc$abbreviation_entry, 1],
    ['TITLE                          ',clc$alias_entry, 1],
    ['TITLES                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 49, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$name_type,
      clc$string_type],
      TRUE, 2],
      8, [[1, 0, clc$string_type], [1, 255, FALSE]],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$boolean_type],
    'FALSE'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, 255, 10],
    '1'],
{ PARAMETER 4
    [[1, 0, clc$string_type], [1, 32, FALSE]],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$titles = 1,
      p$broadcast_registration = 2,
      p$priority = 3,
      p$data = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      data_length: nat$directory_data_length,
      display_status: ost$status,
      distribute: clt$value,
      distribute_titles: boolean,
      i: integer,
      ignore_status: ost$status,
      j: integer,
      new_title_count: integer,
      new_title_list: ^array [1 .. * ] of nat$selected_title,
      old_title_count: integer,
      parameter_specified: boolean,
      title: string (nac$max_title_length),
      title_count: integer,
      title_priority: nat$directory_priority,
      titles_ptr: ^clt$data_value,
      warnings_given: boolean,
      valid_titles: ^array [1 .. * ] of nat$selected_title,
      valid_title_count: integer;

    warnings_given := FALSE;
    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    distribute_titles := pvt [p$broadcast_registration].value^.boolean_value.value;

    title_priority := pvt [p$priority].value^.integer_value.value;

    IF pvt [p$data].specified THEN
      data_length := STRLENGTH (pvt [p$data].value^.string_value^);
    ELSE
      data_length := 0;
    IFEND;

    IF selected_titles = NIL THEN
      old_title_count := 0;
    ELSE
      old_title_count := UPPERBOUND (selected_titles^);
    IFEND;
    valid_title_count := 0;

    new_title_count := 0;
    titles_ptr := pvt [p$titles].value;
    WHILE titles_ptr <> NIL DO
      new_title_count := new_title_count + 1;
      titles_ptr := titles_ptr^.link;
    WHILEND;

    PUSH valid_titles: [1 .. new_title_count];

    titles_ptr := pvt [p$titles].value;

  /validate_titles/
    WHILE titles_ptr <> NIL DO
      CASE titles_ptr^.element_value^.kind OF
      = clc$name =
        title := titles_ptr^.element_value^.name_value;
      = clc$string =
        title := titles_ptr^.element_value^.string_value^;
      CASEND;

      FOR j := 1 TO old_title_count DO
        IF title = selected_titles^ [j].title THEN
          osp$set_status_abnormal (nac$status_id, nae$duplicate_title, 'Add_titles', display_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, title, display_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, application_name, display_status);
          display_message (display_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          warnings_given := TRUE;
          titles_ptr := titles_ptr^.link;
          CYCLE /validate_titles/;
        IFEND;
      FOREND;
      valid_title_count := valid_title_count + 1;
      valid_titles^ [valid_title_count].title := title;
      valid_titles^ [valid_title_count].distribute_title := distribute_titles;
      valid_titles^ [valid_title_count].priority := title_priority;
      valid_titles^ [valid_title_count].data_length := data_length;
      IF data_length > 0 THEN
        i#move (pvt [p$data].value^.string_value, ^valid_titles^ [valid_title_count].data, data_length);
      IFEND;

      titles_ptr := titles_ptr^.link;

    WHILEND /validate_titles/;
    ALLOCATE new_title_list: [1 .. old_title_count + valid_title_count];
    FOR i := 1 TO old_title_count DO
      new_title_list^ [i] := selected_titles^ [i];
    FOREND;
    FOR i := 1 TO valid_title_count DO
      new_title_list^ [i + old_title_count] := valid_titles^ [i];
    FOREND;
    IF selected_titles <> NIL THEN
      FREE selected_titles;
    IFEND;
    selected_titles := new_title_list;

    selected_titles_changed := valid_title_count > 0;
    definition_changed := selected_titles_changed;

    IF warnings_given THEN
      osp$set_status_abnormal (nac$status_id, nae$warnings_processing_command, 'ADD_TITLES', status);
    IFEND;

  PROCEND add_titles;
?? OLDTITLE ??
?? NEWTITLE := 'change_accept_connection', EJECT ??

  PROCEDURE change_accept_connection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE change_accept_con_pdt (
{     accept_connection, ac: boolean =$required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 10, 14, 15, 13, 810],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['AC                             ',clc$abbreviation_entry, 1],
    ['ACCEPT_CONNECTION              ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$accept_connection = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    accept_connection := pvt [p$accept_connection].value^.boolean_value.value;

    definition_changed := TRUE;

  PROCEND change_accept_connection;
?? OLDTITLE ??
?? NEWTITLE := 'change_application_identifier', EJECT ??

  PROCEDURE change_application_identifier
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE change_appl_id_pdt (
{     application_identifier, ai: any of key
{           (variable, v)
{         keyend
{         integer 2000 .. 3000
{         anyend = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 10, 14, 15, 16, 292],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['AI                             ',clc$abbreviation_entry, 1],
    ['APPLICATION_IDENTIFIER         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['V                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['VARIABLE                       ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [2000, 3000, 10]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application_identifier = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE pvt [p$application_identifier].value^.kind OF
    = clc$keyword =
      IF (utility_state = changing_server) OR (utility_state = changing_client) THEN
        IF NOT reserved_application_id THEN
          osp$set_status_condition (nae$application_id_not_changed, status);
          RETURN;
        IFEND;
      IFEND;
      reserved_application_id := FALSE;
      application_id := 0;
    = clc$integer =
      nap$verify_application_id (pvt [p$application_identifier].value^.integer_value.value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      application_id := pvt [p$application_identifier].value^.integer_value.value;
      reserved_application_id := TRUE;
    CASEND;

    definition_changed := TRUE;

  PROCEND change_application_identifier;
?? OLDTITLE ??
?? NEWTITLE := 'change_client_info_source', EJECT ??

  PROCEDURE change_client_info_source
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE change_client_info_pdt (
{     source, s: list 1 .. 2 of key
{          (dialog, d)
{          (connect_data, cd)
{         keyend = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 10, 14, 15, 19, 288],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['S                              ',clc$abbreviation_entry, 1],
    ['SOURCE                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 171,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [155, 1, 2, FALSE],
      [[1, 0, clc$keyword_type], [4], [
      ['CD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['CONNECT_DATA                   ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DIALOG                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$source = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      source_ptr: ^clt$data_value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    source_ptr := pvt [p$source].value;

    WHILE source_ptr <> NIL DO
      IF source_ptr^.element_value^.keyword_value (1) = 'D' THEN
        client_info_source := nac$client_info_via_dialog;
        definition_changed := TRUE;
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$value_not_supported, 'connection_data', status);

{       client_info_source := nac$client_info_via_conn_data;

      IFEND;
      source_ptr := source_ptr^.link;
    WHILEND;

  PROCEND change_client_info_source;
?? OLDTITLE ??
?? NEWTITLE := 'change_client_server_validation', EJECT ??

  PROCEDURE change_client_server_validation
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE change_client_val_pdt (
{     capability, c: any of key
{         none
{       keyend
{       name
{       anyend = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 10, 14, 15, 22, 170],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CAPABILITY                     ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$capability = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE pvt [p$capability].value^.kind OF
    = clc$keyword =
      client_capability := osc$null_name;
    = clc$name =
      client_capability := pvt [p$capability].value^.name_value;
    CASEND;
    definition_changed := TRUE;

  PROCEND change_client_server_validation;
?? OLDTITLE ??
?? NEWTITLE := 'change_client_validation', EJECT ??

  PROCEDURE change_client_validation
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE change_client_val_pdt (
{     capability, c: any of key
{         none
{       keyend
{       name
{       anyend
{     ring, r: integer 1 .. 15
{     system_privilege, sp: boolean
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 10, 14, 15, 25, 922],
    clc$command, 7, 4, 0, 0, 0, 0, 4, ''], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CAPABILITY                     ',clc$nominal_entry, 1],
    ['R                              ',clc$abbreviation_entry, 2],
    ['RING                           ',clc$nominal_entry, 2],
    ['SP                             ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['SYSTEM_PRIVILEGE               ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, 15, 10]],
{ PARAMETER 3
    [[1, 0, clc$boolean_type]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$capability = 1,
      p$ring = 2,
      p$system_privilege = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      parameter_specified: boolean;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$capability].specified THEN
      CASE pvt [p$capability].value^.kind OF
      = clc$keyword =
        capability := osc$null_name;
      = clc$name =
        capability := pvt [p$capability].value^.name_value;
      CASEND;
      definition_changed := TRUE;
    IFEND;

    IF pvt [p$ring].specified THEN
      ring := pvt [p$ring].value^.integer_value.value;
      definition_changed := TRUE;
    IFEND;

    IF pvt [p$system_privilege].specified THEN
      system_privilege := pvt [p$system_privilege].value^.boolean_value.value;
      definition_changed := TRUE;
    IFEND;

  PROCEND change_client_validation;
?? OLDTITLE ??
?? NEWTITLE := 'change_connection_priority', EJECT ??

  PROCEDURE change_connection_priority
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE change_conn_priority_pdt (
{     connection_priority, cp: integer 0 .. 11 = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 10, 14, 15, 29, 573],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['CONNECTION_PRIORITY            ',clc$nominal_entry, 1],
    ['CP                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 11, 10]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$connection_priority = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    connection_priority := pvt [p$connection_priority].value^.integer_value.value;

    definition_changed := TRUE;

  PROCEND change_connection_priority;
?? OLDTITLE ??
?? NEWTITLE := 'change_maximum_connections', EJECT ??

  PROCEDURE change_maximum_connections
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE change_max_connect_pdt (
{     maximum_connections, mc: integer 1 .. 0ffff(16) = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 10, 14, 15, 32, 283],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['MAXIMUM_CONNECTIONS            ',clc$nominal_entry, 1],
    ['MC                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [1, 0ffff(16), 10]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$maximum_connections = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    max_connections := pvt [p$maximum_connections].value^.integer_value.value;

    definition_changed := TRUE;

  PROCEND change_maximum_connections;
?? OLDTITLE ??
?? NEWTITLE := 'change_maximum_sockets', EJECT ??

  PROCEDURE change_maximum_sockets
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE change_max_sockets_pdt (
{       maximum_sockets, ms: integer 1 .. 0ffff(16) = $required
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 1, 9, 40, 27, 388],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['MAXIMUM_SOCKETS                ',clc$nominal_entry, 1],
    ['MS                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [1, 0ffff(16), 10]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$maximum_sockets = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    max_sockets := pvt [p$maximum_sockets].value^.integer_value.value;

    definition_changed := TRUE;

  PROCEND change_maximum_sockets;
?? OLDTITLE ??
?? NEWTITLE := 'change_server_job', EJECT ??

  PROCEDURE change_server_job
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE change_server_job_pdt (
{     job, j: file
{     validation_source, vs: key
{         (client, c)
{         (server, s)
{       keyend
{     maximum_connections, mc: integer 1 .. 0ffff(16)
{     include_commands_until, icu: string = '**'
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (4),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 10, 14, 15, 34, 787],
    clc$command, 9, 5, 0, 0, 0, 0, 5, ''], [
    ['ICU                            ',clc$abbreviation_entry, 4],
    ['INCLUDE_COMMANDS_UNTIL         ',clc$nominal_entry, 4],
    ['J                              ',clc$abbreviation_entry, 1],
    ['JOB                            ',clc$nominal_entry, 1],
    ['MAXIMUM_CONNECTIONS            ',clc$nominal_entry, 3],
    ['MC                             ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['VALIDATION_SOURCE              ',clc$nominal_entry, 2],
    ['VS                             ',clc$abbreviation_entry, 2]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CLIENT                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SERVER                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, 0ffff(16), 10]],
{ PARAMETER 4
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE],
    '''**'''],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$job = 1,
      p$validation_source = 2,
      p$maximum_connections = 3,
      p$include_commands_until = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;


    VAR
      chasj_prompt_string: [STATIC, READ] string (ifc$def_prompt_string_size) := ifc$def_prompt_string_value,
      default_ring_attributes: amt$ring_attributes,
      device_assigned: boolean,
      device_class: rmt$device_class,
      display_control: clt$display_control,
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler,
      file: clt$file,
      ignore_status: ost$status,
      input_block_handle: clt$block_handle,
      input_executable: boolean,
      input_file_id: amt$file_identifier,
      interactive: boolean,
      line: ^clt$command_line,
      local_status: ost$status,
      parameter_specified: boolean,
      unique_name: ost$name,
      until_string: ^string ( * );

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);
      clp$pop_input (TRUE, input_block_handle, input_file_id, input_executable, NIL, ignore_status)

    PROCEND exit_condition_handler;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT nam_initiated THEN
      osp$set_status_abnormal (nac$status_id, nae$command_not_allowed, 'CHANGE_SERVER_JOB', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'server is not initiated by NAM', status);
      RETURN;
    IFEND;

    IF pvt [p$validation_source].specified THEN
      IF pvt [p$validation_source].value^.keyword_value (1) = 'S' THEN
        server_job_validation_source := nac$server_job;
      ELSE
        server_job_validation_source := nac$client;
      IFEND;
      definition_changed := TRUE;
    IFEND;

    IF pvt [p$maximum_connections].specified THEN
      server_job_max_connections := pvt [p$maximum_connections].value^.integer_value.value;
      definition_changed := TRUE;
    IFEND;

    IF pvt [p$job].specified THEN
      rmp$get_device_class (pvt [p$job].value^.file_value^, device_assigned, device_class, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF device_class <> rmc$null_device THEN
        PUSH until_string: [#SIZE (pvt [p$include_commands_until].value^.string_value^)];
        until_string^ := pvt [p$include_commands_until].value^.string_value^;

        input_block_handle := clv$nil_block_handle;
        input_file_id := amv$nil_file_identifier;
        display_control := clv$nil_display_control;
        #SPOIL (input_block_handle, input_file_id, display_control);
        pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);

      /open_output_file/
        BEGIN
          default_ring_attributes.r1 := #RING (^default_ring_attributes);
          default_ring_attributes.r2 := #RING (^default_ring_attributes);
          default_ring_attributes.r3 := #RING (^default_ring_attributes);

          pmp$get_unique_name (unique_name, ignore_status);
          file.local_file_name := unique_name;
          clp$open_display_file (file, NIL, fsc$legible_data, default_ring_attributes, display_control,
                status);
          IF NOT status.normal THEN
            EXIT /open_output_file/;
          IFEND;

        END /open_output_file/;

        IF NOT status.normal THEN
          clp$get_command_origin (interactive, local_status);
          IF interactive THEN
            RETURN;
          IFEND;
        IFEND;
        clp$push_input (pvt [p$job].value^.file_value^, osc$null_name, '', FALSE, TRUE, input_block_handle,
              input_file_id, input_executable, local_status);
        IF NOT local_status.normal THEN
          IF status.normal THEN
            status := local_status;
          IFEND;
          RETURN;
        IFEND;

      /collect_commands/
        WHILE TRUE DO
          clp$get_line_from_command_file (chasj_prompt_string, line, local_status);
          IF status.normal AND (NOT local_status.normal) THEN
            status := local_status;
          IFEND;
          IF NOT local_status.normal THEN
            EXIT /collect_commands/;
          ELSEIF line = NIL THEN

{  eoi encountered

            EXIT /collect_commands/;
          ELSEIF (STRLENGTH (line^) = STRLENGTH (until_string^)) AND (line^ = until_string^) THEN
            EXIT /collect_commands/;
          ELSEIF display_control.file_id <> amv$nil_file_identifier THEN
            clp$put_display (display_control, line^, clc$no_trim, local_status);
            IF NOT local_status.normal THEN
              IF status.normal THEN
                status := local_status;
              IFEND;
              clp$close_display (display_control, ignore_status);
            IFEND;
          IFEND;
        WHILEND /collect_commands/;

        clp$pop_input (TRUE, input_block_handle, input_file_id, input_executable, NIL, local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;
        IF display_control.file_id <> amv$nil_file_identifier THEN
          clp$close_display (display_control, local_status);
          IF status.normal AND (NOT local_status.normal) THEN
            status := local_status;
          IFEND;
        IFEND;
        IF status.normal THEN
          server_job := unique_name;
        IFEND;
        pmp$disestablish_cond_handler (exit_condition, ignore_status);
      IFEND;

      IF (utility_state = changing_server) THEN
        server_job_specified := TRUE;
        IF (device_class = rmc$null_device) THEN
          IF server_job = clc$null_file THEN
            server_job_changed := FALSE;
          ELSE
            server_job := clc$null_file;
            server_job_changed := TRUE;
          IFEND;
        ELSE
          server_job_changed := TRUE;
        IFEND;
        definition_changed := server_job_changed;
      IFEND;

    IFEND;

  PROCEND change_server_job;
?? OLDTITLE ??
?? NEWTITLE := 'change_server_validation', EJECT ??

  PROCEDURE change_server_validation
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE change_server_val_pdt (
{     capability, c: any of key
{         none
{       keyend
{       name
{       anyend
{     ring, r: integer 1 .. 15
{     system_privilege, sp: boolean
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 10, 14, 15, 39, 387],
    clc$command, 7, 4, 0, 0, 0, 0, 4, ''], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CAPABILITY                     ',clc$nominal_entry, 1],
    ['R                              ',clc$abbreviation_entry, 2],
    ['RING                           ',clc$nominal_entry, 2],
    ['SP                             ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['SYSTEM_PRIVILEGE               ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, 15, 10]],
{ PARAMETER 3
    [[1, 0, clc$boolean_type]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$capability = 1,
      p$ring = 2,
      p$system_privilege = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$capability].specified THEN
      CASE pvt [p$capability].value^.kind OF
      = clc$keyword =
        capability := osc$null_name;
      = clc$name =
        capability := pvt [p$capability].value^.name_value;
      CASEND;
      definition_changed := TRUE;
    IFEND;

    IF pvt [p$ring].specified THEN
      ring := pvt [p$ring].value^.integer_value.value;
      definition_changed := TRUE;
    IFEND;

    IF pvt [p$system_privilege].specified THEN
      system_privilege := pvt [p$system_privilege].value^.boolean_value.value;
      definition_changed := TRUE;
    IFEND;

  PROCEND change_server_validation;
?? OLDTITLE ??
?? NEWTITLE := 'change_tcpip_validation', EJECT ??

  PROCEDURE change_tcpip_validation
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE change_tcpip_val_pdt (
{       capability, c: any of
{         key
{           none
{         keyend
{         name
{         anyend
{       ring, r: integer 1 .. 15
{       system_privilege, sp: boolean
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 1, 9, 40, 28, 623],
    clc$command, 7, 4, 0, 0, 0, 0, 4, ''], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CAPABILITY                     ',clc$nominal_entry, 1],
    ['R                              ',clc$abbreviation_entry, 2],
    ['RING                           ',clc$nominal_entry, 2],
    ['SP                             ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['SYSTEM_PRIVILEGE               ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, 15, 10]],
{ PARAMETER 3
    [[1, 0, clc$boolean_type]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$capability = 1,
      p$ring = 2,
      p$system_privilege = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;


    VAR
      parameter_specified: boolean,
      value: clt$value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$capability].specified THEN
      CASE pvt [p$capability].value^.kind OF
      = clc$keyword =
        capability := osc$null_name;
      = clc$name =
        capability := pvt [p$capability].value^.name_value;
      CASEND;
      definition_changed := TRUE;
    IFEND;

    IF pvt [p$ring].specified THEN
      ring := pvt [p$ring].value^.integer_value.value;
      definition_changed := TRUE;
    IFEND;

    IF pvt [p$system_privilege].specified THEN
      system_privilege := pvt [p$system_privilege].value^.boolean_value.value;
      definition_changed := TRUE;
    IFEND;

  PROCEND change_tcpip_validation;
?? OLDTITLE ??
?? NEWTITLE := 'delete_client_address', EJECT ??

  PROCEDURE delete_client_address
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE del_client_addr_pdt (
{     network_identifier, ni: any of key
{         all
{       keyend
{       integer 1 .. 0ffffffff(16)
{       anyend = all
{     system_identifier, si: any of key
{         cdcnet
{         nosve
{         all
{       keyend
{       integer 1 .. 0ffffffffffff(16)
{       anyend = all
{     application_identifier, ai: any of key
{         all
{       keyend
{       integer 2000 .. 3000
{       anyend = all
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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$integer_type_qualifier,
        recend,
        default_value: string (3),
      recend,
      type2: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (3),
      recend,
      type3: 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$integer_type_qualifier,
        recend,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 13, 46, 43, 157],
    clc$command, 7, 4, 0, 0, 0, 0, 4, ''], [
    ['AI                             ',clc$abbreviation_entry, 3],
    ['APPLICATION_IDENTIFIER         ',clc$nominal_entry, 3],
    ['NETWORK_IDENTIFIER             ',clc$nominal_entry, 1],
    ['NI                             ',clc$abbreviation_entry, 1],
    ['SI                             ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['SYSTEM_IDENTIFIER              ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 158,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, 0ffffffff(16), 10]]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['CDCNET                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['NOSVE                          ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    20, [[1, 0, clc$integer_type], [1, 0ffffffffffff(16), 10]]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [2000, 3000, 10]]
    ,
    'all'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$network_identifier = 1,
      p$system_identifier = 2,
      p$application_identifier = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;


    VAR
      address_found: boolean,
      delete_address: nat$client_address,
      i: integer,
      new_address_list: ^array [1 .. * ] of nat$client_address,
      new_index: integer,
      old_address_count: integer;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE pvt [p$network_identifier].value^.kind OF
    = clc$keyword =
      delete_address.network_id := 0;
    = clc$integer =
      delete_address.network_id := pvt [p$network_identifier].value^.integer_value.value;
    CASEND;

    CASE pvt [p$system_identifier].value^.kind OF
    = clc$keyword =
      IF pvt [p$system_identifier].value^.keyword_value = all_keyword THEN
        delete_address.system_kind := nac$any_system_kind;
        delete_address.system_id := 0;
      ELSEIF pvt [p$system_identifier].value^.name_value = 'NOSVE' THEN
        delete_address.system_kind := nac$nosve_system_kind;
        delete_address.system_id := 0;
      ELSE
        delete_address.system_kind := nac$cdcnet_system_kind;
        delete_address.system_id := 0;
      IFEND;
    = clc$integer =
      delete_address.system_kind := nac$any_system_kind;
      delete_address.system_id := pvt [p$system_identifier].value^.integer_value.value;
    CASEND;

    CASE pvt [p$application_identifier].value^.kind OF
    = clc$keyword =
      delete_address.reserved_application_id := FALSE;
      delete_address.application_id := 0;
    = clc$integer =
      delete_address.reserved_application_id := TRUE;
      delete_address.application_id := pvt [p$application_identifier].value^.integer_value.value;
    CASEND;

    address_found := FALSE;
    new_address_list := NIL;
    IF client_addresses <> NIL THEN
      old_address_count := UPPERBOUND (client_addresses^);
      IF old_address_count > 1 THEN
        ALLOCATE new_address_list: [1 .. old_address_count - 1];
      IFEND;
      new_index := 1;
      FOR i := 1 TO old_address_count DO
        IF client_addresses^ [i] = delete_address THEN
          address_found := TRUE;
        ELSEIF (new_address_list <> NIL) AND (new_index <= UPPERBOUND (new_address_list^)) THEN
          new_address_list^ [new_index] := client_addresses^ [i];
          new_index := new_index + 1;
        IFEND;
      FOREND;
    IFEND;

    IF address_found THEN
      FREE client_addresses;
      client_addresses := new_address_list;
      definition_changed := TRUE;
    ELSE
      osp$set_status_condition (nae$client_address_not_in_list, status);
      IF new_address_list <> NIL THEN
        FREE new_address_list;
      IFEND;
    IFEND;

  PROCEND delete_client_address;
?? OLDTITLE ??
?? NEWTITLE := 'end_change_client', EJECT ??

  PROCEDURE end_change_client
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE end_change_client_pdt (
{    save_definition, sd: boolean = TRUE
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 13, 46, 17, 572],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['SAVE_DEFINITION                ',clc$nominal_entry, 1],
    ['SD                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$save_definition = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    VAR
      ignore_status: ost$status,
      save: clt$value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$save_definition].value^.boolean_value.value THEN
      IF definition_changed THEN
        nap$change_client (application_name, max_connections, connection_priority, reserved_application_id,
              application_id, capability, ring, system_privilege, status);
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$appl_definition_not_changed, application_name, status);
        display_message (status, ignore_status);
        status.normal := TRUE;
      IFEND;
    IFEND;
    definition_changed := FALSE;

    IF status.normal THEN
      clp$end_include (change_client_utility_name, ignore_status);
    IFEND;

  PROCEND end_change_client;
?? OLDTITLE ??
?? NEWTITLE := 'end_change_server', EJECT ??

  PROCEDURE end_change_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE end_change_server_pdt (
{    save_definition, sd: boolean = TRUE
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 13, 46, 14, 949],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['SAVE_DEFINITION                ',clc$nominal_entry, 1],
    ['SD                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$save_definition = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    VAR
      ignore_status: ost$status,
      save: clt$value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$save_definition].value^.boolean_value.value THEN
      IF definition_changed THEN
        nap$change_server (application_name, selected_titles_changed, selected_titles, server_managed_titles,
              max_connections, connection_priority, capability, ring, system_privilege, accept_connection,
              client_capability, client_info_source, client_addresses, reserved_application_id,
              application_id, server_job_changed, server_job, server_job_validation_source,
              server_job_max_connections, status);
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$appl_definition_not_changed, application_name, status);
        display_message (status, ignore_status);
        status.normal := TRUE;
      IFEND;
    IFEND;
    definition_changed := FALSE;

    IF status.normal THEN
      clp$end_include (change_server_utility_name, ignore_status);
    IFEND;

  PROCEND end_change_server;
?? OLDTITLE ??
?? NEWTITLE := 'end_change_tcpip_application', EJECT ??

  PROCEDURE end_change_tcpip_application
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE end_change_tcpip_appl_pdt (
{       save_definition, sd: boolean = TRUE
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 1, 9, 40, 33, 201],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['SAVE_DEFINITION                ',clc$nominal_entry, 1],
    ['SD                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$save_definition = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    VAR
      ignore_status: ost$status;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$save_definition].value^.boolean_value.value THEN
      IF definition_changed THEN
        nap$change_tcpip (application_name, max_sockets, capability, ring, system_privilege, status);
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$appl_definition_not_changed, application_name, status);
        display_message (status, ignore_status);
        status.normal := TRUE;
      IFEND;
    IFEND;
    definition_changed := FALSE;

    IF status.normal THEN
      clp$end_include (change_tcpip_utility_name, ignore_status);
    IFEND;

  PROCEND end_change_tcpip_application;
?? OLDTITLE ??
?? NEWTITLE := 'end_define_client', EJECT ??

  PROCEDURE end_define_client
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE end_define_client_pdt (
{     save_definition, sd: boolean = TRUE
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 13, 46, 12, 504],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['SAVE_DEFINITION                ',clc$nominal_entry, 1],
    ['SD                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$save_definition = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    VAR
      ignore_status: ost$status,
      save: clt$value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$save_definition].value^.boolean_value.value THEN
      nap$define_client (application_name, max_connections, connection_priority, protocol,
            reserved_application_id, application_id, capability, ring, system_privilege, status);
    IFEND;

    IF status.normal THEN
      clp$end_include (define_client_utility_name, ignore_status);
    IFEND;

  PROCEND end_define_client;
?? OLDTITLE ??
?? NEWTITLE := 'end_define_server', EJECT ??

  PROCEDURE end_define_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{  PROCEDURE end_define_server_pdt (
{     save_definition, sd: boolean = TRUE
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 13, 46, 10, 66],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['SAVE_DEFINITION                ',clc$nominal_entry, 1],
    ['SD                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$save_definition = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      ignore_status: ost$status,
      save: clt$value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$save_definition].value^.boolean_value.value THEN
      nap$define_server (application_name, selected_titles, server_managed_titles, max_connections,
            connection_priority, capability, ring, system_privilege, accept_connection, client_capability,
            client_info_source, client_addresses, reserved_application_id, application_id, protocol,
            nam_initiated, server_job, server_job_validation_source, server_job_max_connections, status);
    IFEND;

    IF status.normal THEN
      clp$end_include (define_server_utility_name, ignore_status);
    IFEND;

  PROCEND end_define_server;
?? OLDTITLE ??
?? NEWTITLE := 'end_define_tcpip_application', EJECT ??

  PROCEDURE end_define_tcpip_application
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE end_define_tcpip_appl_pdt (
{       save_definition, sd: boolean = TRUE
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 1, 9, 40, 33, 748],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['SAVE_DEFINITION                ',clc$nominal_entry, 1],
    ['SD                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$save_definition = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    VAR
      ignore_status: ost$status;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$save_definition].value^.boolean_value.value THEN
      nap$define_tcpip (application_name, max_sockets, capability, ring, system_privilege, protocol, status);
    IFEND;

    definition_changed := FALSE;

    IF status.normal THEN
      clp$end_include (define_tcpip_utility_name, ignore_status);
    IFEND;

  PROCEND end_define_tcpip_application;
?? OLDTITLE ??
?? NEWTITLE := 'sub_display_client_attributes', EJECT ??

  PROCEDURE sub_display_client_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE dis_client_attrib_pdt (
{  client, c: list of any of key
{      all
{    keyend
{    name
{    anyend
{  display_options, display_option, do, attributes, attribute, a: list of key
{      (protocol, p)
{      (application_identifier, ai)
{      (maximum_connections, mc)
{      (connection_priority, cp)
{      (client_capability, cc)
{      (client_ring, cr)
{      (client_status, cs)
{      (client_system_privilege, csp)
{       all
{    keyend = all
{  output, o: file = $output
{  status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 17] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 10, 14, 15, 52, 399],
    clc$command, 11, 4, 0, 0, 0, 0, 4, ''], [
    ['A                              ',clc$abbreviation_entry, 2],
    ['ATTRIBUTE                      ',clc$alias_entry, 2],
    ['ATTRIBUTES                     ',clc$alias_entry, 2],
    ['C                              ',clc$abbreviation_entry, 1],
    ['CLIENT                         ',clc$nominal_entry, 1],
    ['DISPLAY_OPTION                 ',clc$alias_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 2],
    ['DO                             ',clc$alias_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 652,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [636, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [17], [
      ['AI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['APPLICATION_IDENTIFIER         ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['CC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['CLIENT_CAPABILITY              ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['CLIENT_RING                    ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['CLIENT_STATUS                  ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['CLIENT_SYSTEM_PRIVILEGE        ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['CONNECTION_PRIORITY            ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['CP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['CR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['CS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['CSP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
      ['MAXIMUM_CONNECTIONS            ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['MC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['PROTOCOL                       ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$client = 1,
      p$display_options = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;


    VAR
      application_count: nat$max_applications,
      application_index: nat$max_applications,
      application: array [1 .. 1] of nat$application_attribute,
      applications: ^array [1 .. * ] of nat$application_attribute,
      attributes: client_attribute_set,
      client_count: integer,
      client_ptr: ^clt$data_value,
      client_specified: boolean,
      ignore_status: ost$status,
      output_specified: boolean;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_client_attrib_parameter (pvt [p$display_options], attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_output_parameter (pvt [p$output], output_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$client].specified THEN

    /generate_display/
      BEGIN
        client_ptr := pvt [p$client].value;
        WHILE client_ptr <> NIL DO
          CASE client_ptr^.element_value^.kind OF
          = clc$keyword =
            generate_client_attrib_display (application_name, attributes, application_status, max_connections,
                  connection_priority, capability, ring, system_privilege, reserved_application_id,
                  application_id, protocol, status);
            IF NOT status.normal THEN
              EXIT /generate_display/;
            IFEND;
            nap$get_application_names ($type_of_applications [nac$client_application], application,
                  application_count, status);
            IF NOT status.normal THEN
              EXIT /generate_display/;
            IFEND;
            IF application_count > 0 THEN
              PUSH applications: [1 .. application_count];
              nap$get_application_names ($type_of_applications [nac$client_application], applications^,
                    application_count, status);
              IF NOT status.normal THEN
                EXIT /generate_display/;
              IFEND;
              FOR application_index := 1 TO application_count DO
                display_installed_client (applications^ [application_index].name, attributes, status);
                IF NOT status.normal THEN
                  EXIT /generate_display/;
                IFEND;
              FOREND;
            IFEND;
            EXIT /generate_display/;
          = clc$name =
            IF client_ptr^.element_value^.name_value = application_name THEN
              generate_client_attrib_display (client_ptr^.element_value^.name_value, attributes,
                    application_status, max_connections, connection_priority, capability, ring,
                    system_privilege, reserved_application_id, application_id, protocol, status);
            ELSE
              display_installed_client (client_ptr^.element_value^.name_value, attributes, status);
            IFEND;
            IF NOT status.normal THEN
              EXIT /generate_display/;
            IFEND;
          CASEND;
          client_ptr := client_ptr^.link;
        WHILEND;
      END /generate_display/;
    ELSE
      generate_client_attrib_display (application_name, attributes, application_status, max_connections,
            connection_priority, capability, ring, system_privilege, reserved_application_id, application_id,
            protocol, status);
    IFEND;

    IF output_specified THEN
      clp$close_display (local_display_control, ignore_status);
    IFEND;

  PROCEND sub_display_client_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'sub_display_server_attributes', EJECT ??

  PROCEDURE sub_display_server_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE dis_server_attrib_pdt (
{  server, s: list of any of key
{      all
{    keyend
{    name
{    anyend
{  display_options, display_option, do, attributes, attribute, a: list of key
{      (accept_connection, ac)
{      (application_identifier, ai)
{      (client_addresses, client_address, ca)
{      (client_info_source, cis)
{      (client_validation, cv)
{      (connection_priority, cp)
{      (maximum_connections, mc)
{      (nam_initiated, ni)
{      (protocol, p)
{      (server_capability, sc)
{      (server_job, sj)
{      (server_job_maximum_connections, sjmc)
{      (server_job_validation_source, sjvs)
{      (server_managed_titles, server_managed_title, smt)
{      (server_ring, sr)
{      (server_status, ss)
{      (server_system_privilege, ssp)
{      (titles, title, t)
{      (title_attributes, title_attribute, ta)
{      all
{    keyend = all
{  output, o: file = $output
{  status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 43] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 10, 14, 15, 58, 860],
    clc$command, 11, 4, 0, 0, 0, 0, 4, ''], [
    ['A                              ',clc$abbreviation_entry, 2],
    ['ATTRIBUTE                      ',clc$alias_entry, 2],
    ['ATTRIBUTES                     ',clc$alias_entry, 2],
    ['DISPLAY_OPTION                 ',clc$alias_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 2],
    ['DO                             ',clc$alias_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['S                              ',clc$abbreviation_entry, 1],
    ['SERVER                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1614,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [1598, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [43], [
      ['AC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ACCEPT_CONNECTION              ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['AI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 20],
      ['APPLICATION_IDENTIFIER         ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['CA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['CIS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['CLIENT_ADDRESS                 ', clc$alias_entry, clc$normal_usage_entry, 3],
      ['CLIENT_ADDRESSES               ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['CLIENT_INFO_SOURCE             ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['CLIENT_VALIDATION              ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['CONNECTION_PRIORITY            ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['CP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['CV                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['MAXIMUM_CONNECTIONS            ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['MC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['NAM_INITIATED                  ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['NI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
      ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
      ['PROTOCOL                       ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['SC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
      ['SERVER_CAPABILITY              ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['SERVER_JOB                     ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['SERVER_JOB_MAXIMUM_CONNECTIONS ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['SERVER_JOB_VALIDATION_SOURCE   ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['SERVER_MANAGED_TITLE           ', clc$alias_entry, clc$normal_usage_entry, 14],
      ['SERVER_MANAGED_TITLES          ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['SERVER_RING                    ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['SERVER_STATUS                  ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['SERVER_SYSTEM_PRIVILEGE        ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['SJ                             ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
      ['SJMC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
      ['SJVS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
      ['SMT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
      ['SR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
      ['SS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
      ['SSP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
      ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
      ['TA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
      ['TITLE                          ', clc$alias_entry, clc$normal_usage_entry, 18],
      ['TITLES                         ', clc$nominal_entry, clc$normal_usage_entry, 18],
      ['TITLE_ATTRIBUTE                ', clc$alias_entry, clc$normal_usage_entry, 19],
      ['TITLE_ATTRIBUTES               ', clc$nominal_entry, clc$normal_usage_entry, 19]]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$server = 1,
      p$display_options = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;


    VAR
      application_count: nat$max_applications,
      application_index: nat$max_applications,
      application: array [1 .. 1] of nat$application_attribute,
      applications: ^array [1 .. * ] of nat$application_attribute,
      attributes: server_attribute_set,
      ignore_status: ost$status,
      output_specified: boolean,
      server_count: integer,
      server_ptr: ^clt$data_value,
      server_specified: boolean;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_server_attrib_parameter (pvt [p$display_options], attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_output_parameter (pvt [p$output], output_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF utility_state = defining_server THEN
      server_job_specified := TRUE;
    IFEND;

    IF pvt [p$server].specified THEN

    /generate_display/
      BEGIN
        server_ptr := pvt [p$server].value;
        WHILE server_ptr <> NIL DO
          CASE server_ptr^.element_value^.kind OF
          = clc$keyword =
            generate_server_attrib_display (application_name, attributes, application_status, selected_titles,
                  server_managed_titles, max_connections, connection_priority, capability, ring,
                  system_privilege, accept_connection, client_capability, client_info_source,
                  client_addresses, reserved_application_id, application_id, protocol, nam_initiated,
                  server_job_specified, server_job, server_job_validation_source, server_job_max_connections,
                  status);
            nap$get_application_names ($type_of_applications [nac$server_application], application,
                  application_count, status);
            IF NOT status.normal THEN
              EXIT /generate_display/;
            IFEND;
            IF application_count > 0 THEN
              PUSH applications: [1 .. application_count];
              nap$get_application_names ($type_of_applications [nac$server_application], applications^,
                    application_count, status);
              IF NOT status.normal THEN
                EXIT /generate_display/;
              IFEND;
              FOR application_index := 1 TO application_count DO
                display_installed_server (applications^ [application_index].name, attributes, status);
                IF NOT status.normal THEN
                  EXIT /generate_display/;
                IFEND;
              FOREND;
            IFEND;
            EXIT /generate_display/;
          = clc$name =
            IF server_ptr^.element_value^.name_value = application_name THEN
              generate_server_attrib_display (server_ptr^.element_value^.name_value, attributes,
                    application_status, selected_titles, server_managed_titles, max_connections,
                    connection_priority, capability, ring, system_privilege, accept_connection,
                    client_capability, client_info_source, client_addresses, reserved_application_id,
                    application_id, protocol, nam_initiated, server_job_specified, server_job,
                    server_job_validation_source, server_job_max_connections, status);
            ELSE
              display_installed_server (server_ptr^.element_value^.name_value, attributes, status);
            IFEND;
            IF NOT status.normal THEN
              EXIT /generate_display/;
            IFEND;
          CASEND;
          server_ptr := server_ptr^.link;
        WHILEND;
      END /generate_display/;
    ELSE
      generate_server_attrib_display (application_name, attributes, application_status, selected_titles,
            server_managed_titles, max_connections, connection_priority, capability, ring, system_privilege,
            accept_connection, client_capability, client_info_source, client_addresses,
            reserved_application_id, application_id, protocol, nam_initiated, server_job_specified,
            server_job, server_job_validation_source, server_job_max_connections, status);
    IFEND;

    IF output_specified THEN
      clp$close_display (local_display_control, ignore_status);
    IFEND;

  PROCEND sub_display_server_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'sub_display_tcpip_attributes', EJECT ??

  PROCEDURE sub_display_tcpip_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE sub_display_tcpip_attribute (
{       application, a: list of any of key
{             all
{         keyend
{         name
{         anyend
{       display_option, display_options, do: list of key
{             (protocol, p)
{             (maximum_sockets, ms)
{             (capability, c)
{             (ring, r)
{             (system_privilege, sp)
{             all
{         keyend = all
{       output, o: file = $output
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 11] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 8, 50, 30, 744],
    clc$command, 8, 4, 0, 0, 0, 0, 4, ''], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['APPLICATION                    ',clc$nominal_entry, 1],
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 430,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [414, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [11], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['CAPABILITY                     ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['MAXIMUM_SOCKETS                ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['MS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['PROTOCOL                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['RING                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['SYSTEM_PRIVILEGE               ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['SP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5]]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application = 1,
      p$display_option = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      application_count: nat$max_applications,
      application_index: nat$max_applications,
      application: array [1 .. 1] of nat$application_attribute,
      applications: ^array [1 .. * ] of nat$application_attribute,
      attributes: tcpip_attribute_set,
      ignore_status: ost$status,
      output_specified: boolean,
      tcpip_index_ptr: ^clt$data_value;


    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_tcpip_attrib_parameter (pvt [p$display_option], attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_output_parameter (pvt [p$output], output_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$application].specified THEN

    /generate_display/
      BEGIN
        tcpip_index_ptr := pvt [p$application].value;
        WHILE tcpip_index_ptr <> NIL DO
          CASE tcpip_index_ptr^.element_value^.kind OF
          = clc$keyword =
            nap$get_application_names ($type_of_applications [nac$tcpip_application], application,
                  application_count, status);
            IF NOT status.normal THEN
              EXIT /generate_display/;
            IFEND;
            IF application_count > 0 THEN
              PUSH applications: [1 .. application_count];
              nap$get_application_names ($type_of_applications [nac$tcpip_application], applications^,
                    application_count, status);
              IF NOT status.normal THEN
                EXIT /generate_display/;
              IFEND;
              FOR application_index := 1 TO application_count DO
                display_installed_tcpip (applications^ [application_index].name, attributes, status);
                IF NOT status.normal THEN
                  EXIT /generate_display/;
                IFEND;
              FOREND;
            ELSE
              osp$set_status_abnormal (nac$status_id, nae$application_not_defined, 'tcpip', status);
            IFEND;
            EXIT /generate_display/;
          = clc$name =
            IF tcpip_index_ptr^.element_value^.name_value = application_name THEN
              generate_tcpip_attrib_display (tcpip_index_ptr^.element_value^.name_value, attributes,
                    max_sockets, capability, ring, system_privilege, protocol, status);
            ELSE
              display_installed_tcpip (tcpip_index_ptr^.element_value^.name_value, attributes, status);
            IFEND;
            IF NOT status.normal THEN
              EXIT /generate_display/;
            IFEND;
          CASEND;
          tcpip_index_ptr := tcpip_index_ptr^.link;
        WHILEND;
      END /generate_display/;
    ELSE
      generate_tcpip_attrib_display (application_name, attributes, max_sockets, capability, ring,
            system_privilege, protocol, status);
    IFEND;

    IF output_specified THEN
      clp$close_display (local_display_control, ignore_status);
    IFEND;

  PROCEND sub_display_tcpip_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'sub_generate_client_definition', EJECT ??

  PROCEDURE sub_generate_client_definition
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE gen_client_def_pdt (
{        client, c: list of any of key
{            all
{          keyend
{          name
{          anyend
{        output, o: file = $output
{        status )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 10, 14, 16, 4, 559],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CLIENT                         ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$client = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      application_count: nat$max_applications,
      application_index: nat$max_applications,
      application: array [1 .. 1] of nat$application_attribute,
      applications: ^array [1 .. * ] of nat$application_attribute,
      client_count: integer,
      client_ptr: ^clt$data_value,
      client_specified: boolean,
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler,
      ignore_status: ost$status,
      local_status: ost$status;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (output_file_id, ignore_status);

    PROCEND exit_condition_handler;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);

    process_output_file (pvt [p$output].value^.file_value^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$client].specified THEN

    /generate_definition/
      BEGIN
        client_ptr := pvt [p$client].value;
        WHILE client_ptr <> NIL DO
          CASE client_ptr^.element_value^.kind OF
          = clc$keyword =
            generate_client_definition_cmds (application_name, application_status, max_connections,
                  connection_priority, capability, ring, system_privilege, reserved_application_id,
                  application_id, protocol, status);
            nap$get_application_names ($type_of_applications [nac$client_application], application,
                  application_count, status);
            IF NOT status.normal THEN
              EXIT /generate_definition/;
            IFEND;
            IF application_count > 0 THEN
              PUSH applications: [1 .. application_count];
              nap$get_application_names ($type_of_applications [nac$client_application], applications^,
                    application_count, status);
              IF NOT status.normal THEN
                EXIT /generate_definition/;
              IFEND;
              FOR application_index := 1 TO application_count DO
                generate_installed_client_def (applications^ [application_index].name, status);
                IF NOT status.normal THEN
                  EXIT /generate_definition/;
                IFEND;
              FOREND;
            IFEND;
            EXIT /generate_definition/;
          = clc$name =
            IF client_ptr^.element_value^.name_value = application_name THEN
              generate_client_definition_cmds (client_ptr^.element_value^.name_value, application_status,
                    max_connections, connection_priority, capability, ring, system_privilege,
                    reserved_application_id, application_id, protocol, status);
            ELSE
              generate_installed_client_def (client_ptr^.element_value^.name_value, status);
            IFEND;
            IF NOT status.normal THEN
              EXIT /generate_definition/;
            IFEND;
          CASEND;
          client_ptr := client_ptr^.link;

        WHILEND;
      END /generate_definition/;
    ELSE
      generate_client_definition_cmds (application_name, application_status, max_connections,
            connection_priority, capability, ring, system_privilege, reserved_application_id, application_id,
            protocol, status);
    IFEND;
    fsp$close_file (output_file_id, local_status);
    IF (NOT local_status.normal) AND status.normal THEN
      status := local_status;
    IFEND;
    pmp$disestablish_cond_handler (exit_condition, ignore_status);

  PROCEND sub_generate_client_definition;
?? OLDTITLE ??
?? NEWTITLE := 'sub_generate_server_definition', EJECT ??

  PROCEDURE sub_generate_server_definition
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE gen_server_def_pdt (
{        server, s: list of any of key
{            all
{          keyend
{          name
{          anyend
{        output, o: file = $output
{        status )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 10, 14, 16, 8, 930],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['S                              ',clc$abbreviation_entry, 1],
    ['SERVER                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$server = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      application_count: nat$max_applications,
      application_index: nat$max_applications,
      application: array [1 .. 1] of nat$application_attribute,
      applications: ^array [1 .. * ] of nat$application_attribute,
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler,
      ignore_status: ost$status,
      local_status: ost$status,
      server_count: integer,
      server_ptr: ^clt$data_value,
      server_specified: boolean;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (output_file_id, ignore_status);

    PROCEND exit_condition_handler;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);

    process_output_file (pvt [p$output].value^.file_value^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF utility_state = defining_server THEN
      server_job_specified := TRUE;
    IFEND;

    IF pvt [p$server].specified THEN

    /generate_definition/
      BEGIN
        server_ptr := pvt [p$server].value;
        WHILE server_ptr <> NIL DO
          CASE server_ptr^.element_value^.kind OF
          = clc$keyword =
            generate_server_definition_cmds (application_name, application_status, selected_titles,
                  server_managed_titles, max_connections, connection_priority, capability, ring,
                  system_privilege, accept_connection, client_capability, client_info_source,
                  client_addresses, reserved_application_id, application_id, protocol, nam_initiated,
                  server_job_specified, server_job, server_job_validation_source, server_job_max_connections,
                  status);
            nap$get_application_names ($type_of_applications [nac$server_application], application,
                  application_count, status);
            IF NOT status.normal THEN
              EXIT /generate_definition/;
            IFEND;
            IF application_count > 0 THEN
              PUSH applications: [1 .. application_count];
              nap$get_application_names ($type_of_applications [nac$server_application], applications^,
                    application_count, status);
              IF NOT status.normal THEN
                EXIT /generate_definition/;
              IFEND;
              FOR application_index := 1 TO application_count DO
                generate_installed_server_def (applications^ [application_index].name, status);
                IF NOT status.normal THEN
                  EXIT /generate_definition/;
                IFEND;
              FOREND;
            IFEND;
            EXIT /generate_definition/;
          = clc$name =
            IF server_ptr^.element_value^.name_value = application_name THEN
              generate_server_definition_cmds (server_ptr^.element_value^.name_value, application_status,
                    selected_titles, server_managed_titles, max_connections, connection_priority, capability,
                    ring, system_privilege, accept_connection, client_capability, client_info_source,
                    client_addresses, reserved_application_id, application_id, protocol, nam_initiated,
                    server_job_specified, server_job, server_job_validation_source,
                    server_job_max_connections, status);
            ELSE
              generate_installed_server_def (server_ptr^.element_value^.name_value, status);
            IFEND;
            IF NOT status.normal THEN
              EXIT /generate_definition/;
            IFEND;
          CASEND;

          server_ptr := server_ptr^.link;

        WHILEND;
      END /generate_definition/;
    ELSE
      generate_server_definition_cmds (application_name, application_status, selected_titles,
            server_managed_titles, max_connections, connection_priority, capability, ring, system_privilege,
            accept_connection, client_capability, client_info_source, client_addresses,
            reserved_application_id, application_id, protocol, nam_initiated, server_job_specified,
            server_job, server_job_validation_source, server_job_max_connections, status);
    IFEND;

    fsp$close_file (output_file_id, local_status);
    IF (NOT local_status.normal) AND status.normal THEN
      status := local_status;
    IFEND;
    pmp$disestablish_cond_handler (exit_condition, ignore_status);

  PROCEND sub_generate_server_definition;
?? OLDTITLE ??
?? NEWTITLE := 'sub_generate_tcpip_definition', EJECT ??

  PROCEDURE sub_generate_tcpip_definition
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE sub_generate_tcpip_definition (
{       application, a: list of any of key
{           all
{         keyend
{         name
{         anyend
{       output, o: file = $output
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 23, 8, 50, 41, 809],
    clc$command, 5, 3, 0, 0, 0, 0, 3, ''], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['APPLICATION                    ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [69, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      application_count: nat$max_applications,
      application_index: nat$max_applications,
      application: array [1 .. 1] of nat$application_attribute,
      applications: ^array [1 .. * ] of nat$application_attribute,
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      exit_descriptor: pmt$established_handler,
      ignore_status: ost$status,
      local_status: ost$status,
      tcpip_index_ptr: ^clt$data_value;

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_discriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (output_file_id, ignore_status);

    PROCEND exit_condition_handler;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^exit_descriptor, status);

    process_output_file (pvt [p$output].value^.file_value^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$application].specified THEN

    /generate_definition/
      BEGIN
        tcpip_index_ptr := pvt [p$application].value;
        WHILE tcpip_index_ptr <> NIL DO
          CASE tcpip_index_ptr^.element_value^.kind OF
          = clc$keyword =
            generate_installed_tcpip_cmds (application_name, max_sockets, capability, ring, system_privilege,
                  protocol, status);
            IF NOT status.normal THEN
              EXIT /generate_definition/;
            IFEND;
            nap$get_application_names ($type_of_applications [nac$tcpip_application], application,
                  application_count, status);
            IF NOT status.normal THEN
              EXIT /generate_definition/;
            IFEND;
            IF application_count > 0 THEN
              PUSH applications: [1 .. application_count];
              nap$get_application_names ($type_of_applications [nac$tcpip_application], applications^,
                    application_count, status);
              IF NOT status.normal THEN
                EXIT /generate_definition/;
              IFEND;
              FOR application_index := 1 TO application_count DO
                generate_installed_tcpip_def (applications^ [application_index].name, status);
                IF NOT status.normal THEN
                  EXIT /generate_definition/;
                IFEND;
              FOREND;
            ELSE
              osp$set_status_abnormal (nac$status_id, nae$application_not_defined, 'tcpip', status);
            IFEND;
            EXIT /generate_definition/;
          = clc$name =
            IF tcpip_index_ptr^.element_value^.name_value = application_name THEN
              generate_installed_tcpip_cmds (application_name, max_sockets, capability, ring,
                    system_privilege, protocol, status);
            ELSE
              generate_installed_tcpip_def (tcpip_index_ptr^.element_value^.name_value, status);
            IFEND;
            IF NOT status.normal THEN
              EXIT /generate_definition/;
            IFEND;
          CASEND;
          tcpip_index_ptr := tcpip_index_ptr^.link;
        WHILEND;
      END /generate_definition/;
    ELSE
      generate_installed_tcpip_cmds (application_name, max_sockets, capability, ring, system_privilege,
            protocol, status);
    IFEND;

    fsp$close_file (output_file_id, local_status);
    IF (NOT local_status.normal) AND status.normal THEN
      status := local_status;
    IFEND;
    pmp$disestablish_cond_handler (exit_condition, ignore_status);

  PROCEND sub_generate_tcpip_definition;

?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'Utility Routines' ??
?? NEWTITLE := 'add_string_to_line', EJECT ??

  PROCEDURE add_string_to_line
    (    last_parameter: boolean;
         s: string ( * );
     VAR status: ost$status);

    VAR
      reserve_size: 0 .. continuation_indicator_size,
      string_index: ost$string_index,
      string_size: ost$string_size,
      temp_size: clt$command_line_size;

    status.normal := TRUE;
    IF last_parameter THEN
      reserve_size := 0;
    ELSE
      reserve_size := continuation_indicator_size;
    IFEND;

    string_size := STRLENGTH (s);
    string_index := 1;
    WHILE string_size > 0 DO
      IF fits_on_current_line (string_size, reserve_size) THEN
        add_to_line (s (string_index, string_size));
        RETURN;
      IFEND;
      temp_size := page_width - line.size;
      IF temp_size > continuation_indicator_size THEN
        temp_size := temp_size - continuation_indicator_size;
        add_to_line (s (string_index, temp_size));
        string_size := string_size - temp_size;
        string_index := string_index + temp_size;
      IFEND;
      IF string_size > 0 THEN
        add_to_line ('..');
        put_line (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        indent_line (initial_indent_column);
      IFEND;
    WHILEND;
  PROCEND add_string_to_line;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_line_if_can', EJECT ??

  PROCEDURE add_to_line_if_can
    (    last_parameter: boolean;
         s: string ( * );
     VAR status: ost$status);

    VAR
      continuation_indent_column: clt$command_line_index,
      reserve_size: 0 .. continuation_indicator_size,
      string_size: cyt$string_size;

    status.normal := TRUE;
    continuation_indent_column := current_indent_column + continuation_increment;
    IF last_parameter THEN
      reserve_size := 0;
    ELSE
      reserve_size := continuation_indicator_size;
    IFEND;

    string_size := STRLENGTH (s);
    IF fits_on_current_line (string_size, reserve_size) THEN
      add_to_line (s (1, string_size));
    ELSE
      IF line.size > initial_indent_column THEN
        add_to_line ('..');
        put_line (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        indent_line (continuation_indent_column);
      IFEND;
      add_to_line (s (1, string_size));
    IFEND;
  PROCEND add_to_line_if_can;

?? OLDTITLE ??
?? NEWTITLE := 'display_installed_client', EJECT ??

  PROCEDURE display_installed_client
    (    client: nat$application_name;
         attributes: client_attribute_set;
     VAR status: ost$status);

    VAR
      application_id: nat$internet_sap_identifier,
      application_status: nat$application_status,
      capability: ost$name,
      connection_priority: nat$network_message_priority,
      max_connections: nat$number_of_connections,
      protocol: nat$protocol,
      reserved_application_id: boolean,
      ring: ost$ring,
      system_privilege: boolean;

    nap$get_client_attributes (client, application_status, max_connections, connection_priority, protocol,
          reserved_application_id, application_id, capability, ring, system_privilege, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    generate_client_attrib_display (client, attributes, application_status, max_connections,
          connection_priority, capability, ring, system_privilege, reserved_application_id, application_id,
          protocol, status);

  PROCEND display_installed_client;
?? OLDTITLE ??
?? NEWTITLE := 'display_installed_server', EJECT ??

  PROCEDURE display_installed_server
    (    server: nat$application_name;
         attributes: server_attribute_set;
     VAR status: ost$status);

    VAR
      accept_connection: boolean,
      application_id: nat$internet_sap_identifier,
      application_status: nat$application_status,
      capability: ost$name,
      client_capability: ost$name,
      client_info_source: nat$client_info_source,
      client_address: array [1 .. 1] of nat$client_address,
      client_addresses: ^array [1 .. * ] of nat$client_address,
      client_address_count: integer,
      connection_priority: nat$network_message_priority,
      file: clt$file,
      max_connections: nat$number_of_connections,
      nam_initiated: boolean,
      protocol: nat$protocol,
      reserved_application_id: boolean,
      ring: ost$ring,
      selected_title: array [1 .. 1] of nat$selected_title,
      selected_titles: ^array [1 .. * ] of nat$selected_title,
      selected_title_count: nat$max_titles,
      server_managed_title: array [1 .. 1] of string (nac$max_title_pattern_length),
      server_managed_titles: ^nat$title_pattern_list,
      server_managed_title_count: nat$max_titles,
      server_job: amt$local_file_name,
      server_job_validation_source: nat$server_validation_source,
      server_job_max_connections: nat$number_of_connections,
      server_job_specified: boolean,
      system_privilege: boolean;

    server_job := '';
    nap$get_server_attributes (server, application_status, selected_title_count, ^selected_title,
          server_managed_title_count, ^server_managed_title, max_connections, connection_priority, capability,
          ring, system_privilege, accept_connection, client_capability, client_info_source,
          client_address_count, ^client_address, reserved_application_id, application_id, protocol,
          nam_initiated, server_job_validation_source, server_job_max_connections, server_job_specified,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF selected_title_count = 0 THEN
      selected_titles := NIL;
    ELSE
      selected_titles := ^selected_title;
    IFEND;
    IF server_managed_title_count = 0 THEN
      server_managed_titles := NIL;
    ELSE
      server_managed_titles := ^server_managed_title;
    IFEND;
    IF client_address_count = 0 THEN
      client_addresses := NIL;
    ELSE
      client_addresses := ^client_address;
    IFEND;
    IF (selected_title_count > 1) OR (client_address_count > 1) OR (server_managed_title_count > 1) THEN
      IF selected_title_count > 1 THEN
        PUSH selected_titles: [1 .. selected_title_count];
      IFEND;
      IF server_managed_title_count > 1 THEN
        PUSH server_managed_titles: [1 .. server_managed_title_count];
      IFEND;
      IF client_address_count > 1 THEN
        PUSH client_addresses: [1 .. client_address_count];
      IFEND;
      nap$get_server_attributes (server, application_status, selected_title_count, selected_titles,
            server_managed_title_count, server_managed_titles, max_connections, connection_priority,
            capability, ring, system_privilege, accept_connection, client_capability, client_info_source,
            client_address_count, client_addresses, reserved_application_id, application_id, protocol,
            nam_initiated, server_job_validation_source, server_job_max_connections, server_job_specified,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF NOT server_job_specified THEN
      server_job := clc$null_file;
    IFEND;
    generate_server_attrib_display (server, attributes, application_status, selected_titles,
          server_managed_titles, max_connections, connection_priority, capability, ring, system_privilege,
          accept_connection, client_capability, client_info_source, client_addresses, reserved_application_id,
          application_id, protocol, nam_initiated, {server_lfn_specified} NOT server_job_specified,
          server_job, server_job_validation_source, server_job_max_connections, status);

  PROCEND display_installed_server;
?? OLDTITLE ??
?? NEWTITLE := 'display_installed_tcpip', EJECT ??

  PROCEDURE display_installed_tcpip
    (    tcpip: nat$application_name;
         attributes: tcpip_attribute_set;
     VAR status: ost$status);

    VAR
      capability: ost$name,
      max_sockets: nat$number_of_sockets,
      protocol: nat$protocol,
      ring: ost$ring,
      system_privilege: boolean,
      tcpip_status: nat$application_status;

    nap$get_tcpip_attributes (tcpip, tcpip_status, max_sockets, capability, ring, system_privilege, protocol,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    generate_tcpip_attrib_display (tcpip, attributes, max_sockets, capability, ring, system_privilege,
          protocol, status);

  PROCEND display_installed_tcpip;
?? OLDTITLE ??
?? NEWTITLE := 'display_message', EJECT ??

  PROCEDURE display_message
    (    message_status: ost$status;
     VAR status: ost$status);

{ PURPOSE: Format and display a NOS/VE status condition.
{ DESIGN:  The message status is formatted with calls to system routines and written to
{          the $ERRORS file.

    VAR
      attachment_selections: [STATIC, READ] array [1 .. 1] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes,
            [fsc$shorten, fsc$append, fsc$modify]], * ]],
      byte_address: amt$file_byte_address,
      error_file_id: [STATIC] amt$file_identifier,
      error_file_name: [STATIC, READ] amt$local_file_name := '$ERRORS',
      error_file_opened: [STATIC] boolean := FALSE,
      ignore_status: ost$status,
      length_pointer: ^ost$status_message_line_size,
      line_count_pointer: ^ost$status_message_line_count,
      line_index: ost$status_message_line_count,
      message: ost$status_message,
      message_sequence: ^ost$status_message,
      text_pointer: ^ost$status_message_line;

    IF NOT error_file_opened THEN
      fsp$open_file (error_file_name, amc$record, ^attachment_selections, {default_creation_attributes =} NIL,
            {mandated_creation_attributes =} NIL, {attribute_validation =} NIL, {attribute_override =} NIL,
            error_file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      error_file_opened := TRUE;
    IFEND;

    osp$format_message (message_status, osc$current_message_level, osc$max_status_message_line, message,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    message_sequence := ^message;
    RESET message_sequence;
    NEXT line_count_pointer IN message_sequence;

    FOR line_index := 1 TO line_count_pointer^ DO
      NEXT length_pointer IN message_sequence;
      NEXT text_pointer: [length_pointer^] IN message_sequence;
      amp$put_next (error_file_id, text_pointer, length_pointer^, byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND display_message;

?? OLDTITLE ??
?? NEWTITLE := 'get_server_job_command', EJECT ??

  PROCEDURE get_server_job_command
    (    file_identifier: amt$file_identifier;
     VAR command_line: ^clt$command_line;
     VAR line_size: clt$command_line_size;
     VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      continuation_line: ^clt$command_line,
      continuation_line_size: clt$command_line_size,
      file_position: amt$file_position,
      line_continued: boolean,
      transfer_count: amt$transfer_count;

    status.normal := TRUE;
    line_size := 0;

    PUSH continuation_line: [clc$max_command_line_size];

    amp$get_next (file_identifier, command_line, #SIZE (command_line^), transfer_count, byte_address,
          file_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF file_position = amc$eoi THEN
      command_line := NIL;
      RETURN;
    IFEND;
    line_size := transfer_count;
    IF (transfer_count >= 2) AND (command_line^ (transfer_count - 1, 2) = '..') THEN
      line_size := transfer_count - 2;
      WHILE (line_size > 0) AND (command_line^ (line_size) = '.') DO
        line_size := line_size - 1;
      WHILEND;
      REPEAT
        amp$get_next (file_identifier, continuation_line, #SIZE (continuation_line^), transfer_count,
              byte_address, file_position, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF file_position = amc$eoi THEN
          command_line := NIL;
          RETURN;
        IFEND;
        continuation_line_size := transfer_count;
        line_continued := (continuation_line_size >= 2) AND
              (continuation_line^ (continuation_line_size - 1, 2) = '..');
        IF line_continued THEN
          continuation_line_size := continuation_line_size - 2;
          WHILE (continuation_line_size > 0) AND (continuation_line^ (continuation_line_size) = '.') DO
            continuation_line_size := continuation_line_size - 1;
          WHILEND;
        IFEND;
        IF (line_size + continuation_line_size) > clc$max_command_line_size THEN
          osp$set_status_condition (cle$continued_line_too_long, status);
          RETURN;
        IFEND;
        command_line^ (line_size + 1, continuation_line_size) := continuation_line^;
        line_size := line_size + continuation_line_size;
      UNTIL NOT line_continued;
    IFEND;

  PROCEND get_server_job_command;
?? OLDTITLE ??
?? NEWTITLE := 'generate_client_attrib_display', EJECT ??

  PROCEDURE generate_client_attrib_display
    (    client: nat$application_name;
         attributes: client_attribute_set;
         application_status: nat$application_status;
         max_connections: nat$number_of_connections;
         connection_priority: nat$network_message_priority;
         capability: ost$name;
         ring: ost$ring;
         system_privilege: boolean,
         reserved_application_id: boolean;
         application_id: nat$internet_sap_identifier;
         protocol: nat$protocol;
     VAR status: ost$status);

    VAR
      address_index: integer,
      j: integer;

    status.normal := TRUE;

    add_to_line ('Client:');
    tab_line (display_spacer);
    add_to_line (client);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF ca$status IN attributes THEN
      add_to_line ('  Status: ');
      tab_line (display_spacer);
      add_to_line (application_status_description [application_status]);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF ca$protocol IN attributes THEN
      add_to_line ('  Protocol: ');
      tab_line (display_spacer);
      add_to_line (protocol_label [protocol]);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF ca$application_id IN attributes THEN
      add_to_line ('  Application_Identifier: ');
      tab_line (display_spacer);
      IF reserved_application_id THEN
        add_integer_to_line (application_id);
      ELSE
        add_to_line ('Variable');
      IFEND;
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF ca$max_connections IN attributes THEN
      add_to_line ('  Maximum_connections: ');
      tab_line (display_spacer);
      add_integer_to_line (max_connections);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF ca$connection_priority IN attributes THEN
      indent_line (3);
      add_to_line ('Connection_priority: ');
      tab_line (display_spacer);
      add_integer_to_line (connection_priority);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF ca$client_capability IN attributes THEN
      add_to_line ('  Client_capability: ');
      tab_line (display_spacer);
      IF capability = osc$null_name THEN
        add_to_line ('None');
      ELSE
        add_to_line (capability);
      IFEND;
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF ca$client_ring IN attributes THEN
      add_to_line ('  Client_ring: ');
      tab_line (display_spacer);
      add_integer_to_line (ring);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF ca$client_system_priv IN attributes THEN
      add_to_line ('  Client_system_privilege: ');
      tab_line (display_spacer);
      add_boolean_to_line (system_privilege);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND generate_client_attrib_display;
?? OLDTITLE ??
?? NEWTITLE := 'generate_client_definition_cmds', EJECT ??

  PROCEDURE generate_client_definition_cmds
    (    client: nat$application_name;
         application_status: nat$application_status;
         max_connections: nat$number_of_connections;
         connection_priority: nat$network_message_priority;
         capability: ost$name;
         ring: ost$ring;
         system_privilege: boolean;
         reserved_application_id: boolean;
         application_id: nat$internet_sap_identifier;
         protocol: nat$protocol;
     VAR status: ost$status);

    VAR
      b_string: string (5),
      current_indent_column: clt$command_line_index,
      i_string: ost$string,
      ignore_status: ost$status,
      length: integer,
      str: string (osc$max_string_size);

    status.normal := TRUE;
    current_indent_column := initial_indent_column;

{  Generate define_client command.

    put_line (status); { blank line }
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    indent_line (current_indent_column);
    add_to_line ('define_client');
    STRINGREP (str, length, ' client=', client (1, clp$trimmed_string_size (client)));
    add_to_line_if_can ({last_parameter=} FALSE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (str, length, ' protocol=', protocol_label [protocol]
          (1, clp$trimmed_string_size (protocol_label [protocol])));
    add_to_line_if_can (TRUE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  Generate define_client subcommands that make up the client definition.

    current_indent_column := initial_indent_column + indent_increment;

{   Application identifier

    indent_line (current_indent_column);
    add_to_line ('change_application_identifier');
    IF reserved_application_id THEN
      clp$convert_integer_to_string (application_id, 10, FALSE, i_string, ignore_status);
      STRINGREP (str, length, ' application_identifier=', i_string.value (1, i_string.size));
      add_to_line_if_can ({last_parameter=} TRUE, str (1, length), status);
    ELSE
      add_to_line_if_can ({last_parameter=} TRUE, ' application_identifier=variable', status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Maximum connections

    indent_line (current_indent_column);
    add_to_line ('change_maximum_connections');
    clp$convert_integer_to_string (max_connections, 10, FALSE, i_string, ignore_status);
    STRINGREP (str, length, ' maximum_connections=', i_string.value (1, i_string.size));
    add_to_line_if_can ({last_parameter=} TRUE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Connection priority

    indent_line (current_indent_column);
    add_to_line ('change_connection_priority');
    clp$convert_integer_to_string (connection_priority, 10, FALSE, i_string, ignore_status);
    STRINGREP (str, length, ' connection_priority=', i_string.value (1, i_string.size));
    add_to_line_if_can ({last_parameter=} TRUE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Client capability / Client ring / Client system privilege

    indent_line (current_indent_column);
    add_to_line ('change_client_validation');

    IF capability = osc$null_name THEN
      add_to_line_if_can ({last_parameter=} FALSE, ' capability=none', status);
    ELSE
      STRINGREP (str, length, ' capability=', capability (1, clp$trimmed_string_size (capability)));
      add_to_line_if_can ({last_parameter=} FALSE, str (1, length), status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (ring, 10, FALSE, i_string, ignore_status);
    STRINGREP (str, length, ' ring=', i_string.value (1, i_string.size));
    add_to_line_if_can ({last_parameter=} FALSE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (str, length, ' system_privilege=', boolean_label [system_privilege] (1,
          clp$trimmed_string_size (boolean_label [system_privilege])));
    add_to_line_if_can ({last_parameter=} TRUE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Generate the end_define_client command

    indent_line (initial_indent_column);
    add_to_line ('end_define_client');
    add_to_line (' save_definition=TRUE');
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND generate_client_definition_cmds;
?? OLDTITLE ??
?? NEWTITLE := 'generate_client_status_display', EJECT ??

  PROCEDURE generate_client_status_display
    (    client: nat$application_name;
     VAR status: ost$status);

    VAR
      active_connection_count: nat$number_of_connections,
      application_id: nat$internet_sap_identifier,
      attempted_connection_count: integer,
      client_status: nat$application_status,
      rejected_connection_attempts: integer,
      reserved_application_id: boolean;


    nap$get_client_status (client, client_status, reserved_application_id, application_id,
          active_connection_count, attempted_connection_count, rejected_connection_attempts, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    add_to_line ('Client: ');
    tab_line (display_spacer);
    add_to_line (client);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    add_to_line ('  Status: ');
    tab_line (display_spacer);
    add_to_line (application_status_description [client_status]);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    add_to_line ('  Active_client_connections: ');
    tab_line (display_spacer);
    add_integer_to_line (active_connection_count);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    add_to_line ('  Attempted_connection_count: ');
    tab_line (display_spacer);
    add_integer_to_line (attempted_connection_count);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    add_to_line ('  Rejected_connection_attempts: ');
    tab_line (display_spacer);
    add_integer_to_line (rejected_connection_attempts);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND generate_client_status_display;
?? OLDTITLE ??
?? NEWTITLE := 'generate_headers', EJECT ??

  PROCEDURE generate_headers
    (VAR display_control: {input,output} clt$display_control;
         page_number: integer;
     VAR status: ost$status);

{ PURPOSE: This procedure formats a page header for MANNA output.
{ DESIGN:  This procedure is called by the clp$display... routines when a page header
{          is needed. Note that this routine may be called in any of the tasks activated
{          by MANNA.

    CONST
      date_length = 18,
      long_date_start = 91,
      long_header_length = 132,
      long_os_version_start = 48,
      long_page_number_start = 127, {includes leading blank}
      long_page_title_start = 123,
      long_product_name_start = 55,
      long_product_version_start = 78,
      long_product_level_start = 85,
      long_time_start = 110,
      os_version_length = 6,
      page_number_length = 5, {includes leading blank}
      product_name = 'ADM NETWORK APPLICATIONS',
      product_name_length = 24,
      product_level_length = 5,
      product_version_length = 4,
      short_date_start = 1,
      short_header_length = 80,
      short_os_version_start = 20,
      short_page_number_start = 66, {includes leading blank}
      short_page_title_start = 62,
      short_product_name_start = 27,
      short_product_version_start = 52,
      short_product_level_start = 57,
      short_time_start = 49,
      time_length = 12;

    VAR
      date: ost$date,
      date_line: 1 .. 2,
      date_start: 0 .. long_header_length,
      header: array [1 .. 2] of string (long_header_length),
      header1_length: 0 .. long_header_length,
      header2_length: 0 .. long_header_length,
      j: integer,
      os_version: pmt$os_name,
      page_number_start: 0 .. long_header_length,
      str: string (10),
      time: ost$time,
      time_line: 1 .. 2,
      time_start: 0 .. long_header_length;

    pmp$get_legible_date_time (osc$default_date, date, osc$default_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$get_os_version (os_version, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    header [1] := ' ';
    header [2] := ' ';
    IF (display_control.page_width < long_header_length) THEN
      header1_length := short_header_length;
      header2_length := short_header_length;
      page_number_start := short_page_number_start;
      header [2] (short_os_version_start, os_version_length) := os_version;
      date_line := 2;
      date_start := short_date_start;
      time_line := 1;
      time_start := short_time_start;
      header [2] (short_product_name_start, product_name_length) := product_name;
      header [2] (short_product_version_start, product_version_length) := nac$network_administrator_vers;
      header [2] (short_product_level_start, product_level_length) := nac$network_administrator_level;
      header [1] (short_page_title_start, 4) := 'PAGE';
    ELSE
      header1_length := long_header_length;
      page_number_start := long_page_number_start;
      header [1] (long_os_version_start, os_version_length) := os_version;
      date_line := 1;
      date_start := long_date_start;
      time_line := 1;
      time_start := long_time_start;
      header [1] (long_product_name_start, product_name_length) := product_name;
      header [1] (long_product_version_start, product_version_length) := nac$network_administrator_vers;
      header [1] (long_product_level_start, product_level_length) := nac$network_administrator_level;
      header [1] (long_page_title_start, 4) := 'PAGE';
      header2_length := 0;
    IFEND;

    CASE date.date_format OF
    = osc$month_date =
      header [date_line] (date_start, date_length) := date.month;

    = osc$mdy_date =
      header [date_line] (date_start, date_length) := date.mdy;

    = osc$iso_date =
      header [date_line] (date_start, date_length) := date.iso;

    = osc$dmy_date =
      header [date_line] (date_start, date_length) := date.dmy;

    ELSE
    CASEND;

    CASE time.time_format OF
    = osc$ampm_time =
      header [time_line] (time_start, time_length) := time.ampm;

    = osc$hms_time =
      header [time_line] (time_start, time_length) := time.hms;

    = osc$millisecond_time =
      header [time_line] (time_start, time_length) := time.millisecond;

    ELSE
    CASEND;
    clp$reset_for_next_display_page (display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (str, j, page_number);
    header [1] (page_number_start, j) := str (1, j);
    clp$put_display (display_control, header [1], clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (header2_length > 0) THEN
      clp$put_display (display_control, header [2], clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND generate_headers;
?? OLDTITLE ??
?? NEWTITLE := 'generate_installed_client_def', EJECT ??

  PROCEDURE generate_installed_client_def
    (    client: nat$application_name;
     VAR status: ost$status);

    VAR
      application_id: nat$internet_sap_identifier,
      application_status: nat$application_status,
      capability: ost$name,
      connection_priority: nat$network_message_priority,
      max_connections: nat$number_of_connections,
      protocol: nat$protocol,
      reserved_application_id: boolean,
      ring: ost$ring,
      system_privilege: boolean;

    nap$get_client_attributes (client, application_status, max_connections, connection_priority, protocol,
          reserved_application_id, application_id, capability, ring, system_privilege, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    generate_client_definition_cmds (client, application_status, max_connections, connection_priority,
          capability, ring, system_privilege, reserved_application_id, application_id, protocol, status);

  PROCEND generate_installed_client_def;
?? OLDTITLE ??
?? NEWTITLE := 'generate_installed_server_def', EJECT ??

  PROCEDURE generate_installed_server_def
    (    server: nat$application_name;
     VAR status: ost$status);


    VAR
      accept_connection: boolean,
      application_id: nat$internet_sap_identifier,
      application_status: nat$application_status,
      capability: ost$name,
      client_capability: ost$name,
      client_info_source: nat$client_info_source,
      client_address: array [1 .. 1] of nat$client_address,
      client_addresses: ^array [1 .. * ] of nat$client_address,
      client_address_count: integer,
      connection_priority: nat$network_message_priority,
      max_connections: nat$number_of_connections,
      nam_initiated: boolean,
      protocol: nat$protocol,
      reserved_application_id: boolean,
      ring: ost$ring,
      selected_title: array [1 .. 1] of nat$selected_title,
      selected_titles: ^array [1 .. * ] of nat$selected_title,
      selected_title_count: nat$max_titles,
      server_managed_title: array [1 .. 1] of string (nac$max_title_pattern_length),
      server_managed_titles: ^nat$title_pattern_list,
      server_managed_title_count: nat$max_titles,
      server_job_specified: boolean,
      server_job: amt$local_file_name,
      server_job_validation_source: nat$server_validation_source,
      server_job_max_connections: nat$number_of_connections,
      system_privilege: boolean;

    server_job := '';
    nap$get_server_attributes (server, application_status, selected_title_count, ^selected_title,
          server_managed_title_count, ^server_managed_title, max_connections, connection_priority, capability,
          ring, system_privilege, accept_connection, client_capability, client_info_source,
          client_address_count, ^client_address, reserved_application_id, application_id, protocol,
          nam_initiated, server_job_validation_source, server_job_max_connections, server_job_specified,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF selected_title_count = 0 THEN
      selected_titles := NIL;
    ELSE
      selected_titles := ^selected_title;
    IFEND;
    IF server_managed_title_count = 0 THEN
      server_managed_titles := NIL;
    ELSE
      server_managed_titles := ^server_managed_title;
    IFEND;
    IF client_address_count = 0 THEN
      client_addresses := NIL;
    ELSE
      client_addresses := ^client_address;
    IFEND;
    IF (selected_title_count > 1) OR (client_address_count > 1) OR (server_managed_title_count > 1) THEN
      IF selected_title_count > 1 THEN
        PUSH selected_titles: [1 .. selected_title_count];
      IFEND;
      IF server_managed_title_count > 1 THEN
        PUSH server_managed_titles: [1 .. server_managed_title_count];
      IFEND;
      IF client_address_count > 1 THEN
        PUSH client_addresses: [1 .. client_address_count];
      IFEND;
      nap$get_server_attributes (server, application_status, selected_title_count, selected_titles,
            server_managed_title_count, server_managed_titles, max_connections, connection_priority,
            capability, ring, system_privilege, accept_connection, client_capability, client_info_source,
            client_address_count, client_addresses, reserved_application_id, application_id, protocol,
            nam_initiated, server_job_validation_source, server_job_max_connections, server_job_specified,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF NOT server_job_specified THEN
      server_job := clc$null_file;
    IFEND;
    generate_server_definition_cmds (server, application_status, selected_titles, server_managed_titles,
          max_connections, connection_priority, capability, ring, system_privilege, accept_connection,
          client_capability, client_info_source, client_addresses, reserved_application_id, application_id,
          protocol, nam_initiated, {server_lfn_specified} NOT server_job_specified, server_job,
          server_job_validation_source, server_job_max_connections, status);

  PROCEND generate_installed_server_def;

?? OLDTITLE ??
?? NEWTITLE := 'generate_installed_tcpip_cmds', EJECT ??

  PROCEDURE generate_installed_tcpip_cmds
    (    tcpip: nat$application_name;
         max_sockets: nat$number_of_sockets;
         capability: ost$name;
         ring: ost$ring;
         system_privilege: boolean;
         protocol: nat$protocol;
     VAR status: ost$status);

    VAR
      current_indent_column: clt$command_line_index,
      i_string: ost$string,
      ignore_status: ost$status,
      length: integer,
      str: string (osc$max_string_size);

    status.normal := TRUE;
    current_indent_column := initial_indent_column;

{  Generate define_tcpip command.

    put_line (status); { blank line }
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    indent_line (current_indent_column);
    add_to_line ('define_tcpip_application');
    STRINGREP (str, length, ' application=', tcpip (1, clp$trimmed_string_size (tcpip)));
    add_to_line_if_can ({last_parameter=} FALSE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (str, length, ' protocol=', protocol_label [protocol]
          (1, clp$trimmed_string_size (protocol_label [protocol])));
    add_to_line_if_can ({last_parameter=} TRUE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


{  Generate define_tcpip subcommands that make up the tcpip definition.

    current_indent_column := initial_indent_column + indent_increment;

{   Maximum sockets

    indent_line (current_indent_column);
    add_to_line ('change_maximum_sockets');
    clp$convert_integer_to_string (max_sockets, 10, FALSE, i_string, ignore_status);
    STRINGREP (str, length, ' maximum_sockets=', i_string.value (1, i_string.size));
    add_to_line_if_can ({last_parameter=} TRUE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   capability / ring / system privilege

    indent_line (current_indent_column);
    add_to_line ('change_tcpip_validation');

    IF capability = osc$null_name THEN
      add_to_line_if_can ({last_parameter=} FALSE, ' capability=none', status);
    ELSE
      STRINGREP (str, length, ' capability=', capability (1, clp$trimmed_string_size (capability)));
      add_to_line_if_can ({last_parameter=} FALSE, str (1, length), status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (ring, 10, FALSE, i_string, ignore_status);
    STRINGREP (str, length, ' ring=', i_string.value (1, i_string.size));
    add_to_line_if_can ({last_parameter=} FALSE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (str, length, ' system_privilege=', boolean_label [system_privilege] (1,
          clp$trimmed_string_size (boolean_label [system_privilege])));
    add_to_line_if_can ({last_parameter=} TRUE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Generate the end_define_tcpip command

    indent_line (initial_indent_column);
    add_to_line ('end_define_tcpip_application');
    add_to_line (' save_definition=TRUE');
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND generate_installed_tcpip_cmds;
?? OLDTITLE ??
?? NEWTITLE := 'generate_installed_tcpip_def', EJECT ??

  PROCEDURE generate_installed_tcpip_def
    (    tcpip: nat$application_name;
     VAR status: ost$status);

    VAR
      capability: ost$name,
      ignore_status: ost$status,
      local_status: ost$status,
      max_sockets: nat$number_of_sockets,
      priority: nat$network_message_priority,
      protocol: nat$protocol,
      ring: ost$ring,
      system_privilege: boolean,
      tcpip_status: nat$application_status;

    nap$get_tcpip_attributes (tcpip, tcpip_status, max_sockets, capability, ring, system_privilege, protocol,
          status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    generate_installed_tcpip_cmds (tcpip, max_sockets, capability, ring, system_privilege, protocol, status);

  PROCEND generate_installed_tcpip_def;


?? OLDTITLE ??
?? NEWTITLE := 'generate_server_attrib_display', EJECT ??

  PROCEDURE generate_server_attrib_display
    (    server: nat$application_name;
         attributes: server_attribute_set;
         application_status: nat$application_status;
         selected_titles: ^array [1 .. * ] of nat$selected_title;
         server_managed_titles: ^nat$title_pattern_list;
         max_connections: nat$number_of_connections;
         connection_priority: nat$network_message_priority;
         capability: ost$name;
         ring: ost$ring;
         system_privilege: boolean;
         accept_connection: boolean;
         client_capability: ost$name;
         client_info_source: nat$client_info_source;
         client_addresses: ^array [1 .. * ] of nat$client_address;
         reserved_application_id: boolean;
         application_id: nat$internet_sap_identifier;
         protocol: nat$protocol;
         nam_initiated: boolean;
         server_job_specified: boolean;
         server_job: amt$local_file_name;
         server_job_validation_source: nat$server_validation_source;
         server_job_max_connections: nat$number_of_connections;
     VAR status: ost$status);

    VAR
      access_selections: [STATIC, READ] array [1 .. 2] of fst$attachment_option :=
            [[fsc$create_file, FALSE], [fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$read]],
            [fsc$specific_share_modes, [fsc$read, fsc$execute]]]],
      address_index: integer,
      byte_address: amt$file_byte_address,
      client_address_count: integer,
      cycle_selector: clt$cycle_selector,
      distributed_title_found: boolean,
      file: clt$file,
      file_name: ost$name,
      file_position: amt$file_position,
      file_reference: clt$file_reference,
      highest_cycle: [STATIC, READ] pft$cycle_selector := [pfc$highest_cycle],
      ignore_status: ost$status,
      indent_column: clt$command_line_index,
      j: integer,
      job_line: ^clt$command_line,
      length: integer,
      local_status: ost$status,
      open_position: clt$open_position,
      path: ^pft$path,
      path_container: clt$path_container,
      path_name: [STATIC] array [1 .. 6] of pft$name := [nac$application_family,
            nac$application_master_catalog, nac$network_subcatalog, nac$application_catalog,
            nac$application_job_catalog, * ],
      path_size: fst$path_size,
      path_string: fst$path,
      selected_title_count: nat$max_titles,
      server_file: clt$file,
      server_file_identifier: amt$file_identifier,
      server_file_reference: clt$file_reference,
      share_selections: [STATIC, READ] pft$usage_selections := [pfc$read],
      str: string (osc$max_string_size),
      title_data: string (nac$max_directory_data_length),
      title_pattern_count: nat$max_titles,
      transfer_count: amt$transfer_count,
      usage_selections: [STATIC, READ] pft$usage_selections := [pfc$read];


    add_to_line ('Server:');
    tab_line (display_spacer);
    add_to_line (server);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF sa$status IN attributes THEN
      indent_line (3);
      add_to_line ('Status: ');
      tab_line (display_spacer);
      add_to_line (application_status_description [application_status]);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF sa$protocol IN attributes THEN
      indent_line (3);
      add_to_line ('Protocol: ');
      tab_line (display_spacer);
      add_to_line (protocol_label [protocol]);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF sa$application_id IN attributes THEN
      indent_line (3);
      add_to_line ('Application_Identifier: ');
      tab_line (display_spacer);
      IF reserved_application_id THEN
        add_integer_to_line (application_id);
      ELSE
        add_to_line ('Variable');
      IFEND;
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF sa$max_connections IN attributes THEN
      indent_line (3);
      add_to_line ('Maximum_connections: ');
      tab_line (display_spacer);
      add_integer_to_line (max_connections);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF sa$connection_priority IN attributes THEN
      indent_line (3);
      add_to_line ('Connection_priority: ');
      tab_line (display_spacer);
      add_integer_to_line (connection_priority);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF sa$server_capability IN attributes THEN
      indent_line (3);
      add_to_line ('Server_capability: ');
      tab_line (display_spacer);
      IF capability = osc$null_name THEN
        add_to_line ('None');
      ELSE
        add_to_line (capability);
      IFEND;
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF sa$server_ring IN attributes THEN
      indent_line (3);
      add_to_line ('Server_ring: ');
      tab_line (display_spacer);
      add_integer_to_line (ring);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF sa$server_system_priv IN attributes THEN
      indent_line (3);
      add_to_line ('Server_system_privilege: ');
      tab_line (display_spacer);
      add_boolean_to_line (system_privilege);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF sa$title_attributes IN attributes THEN
      IF selected_titles = NIL THEN
        indent_line (3);
        add_to_line ('Titles: ');
        tab_line (display_spacer);
        add_to_line ('None');
        flush_line (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        selected_title_count := UPPERBOUND (selected_titles^);
        FOR j := 1 TO selected_title_count DO
          indent_line (3);
          add_to_line ('Title: ');
          tab_line (display_spacer);
          add_to_line (selected_titles^ [j].title (1, clp$trimmed_string_size (selected_titles^ [j].title)));
          display_wide_line (line.value (1, line.size), status);
          line.size := 0;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          indent_line (5);
          add_to_line ('Broadcast_registration:');
          tab_line (display_spacer);
          add_boolean_to_line (selected_titles^ [j].distribute_title);
          flush_line (status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          indent_line (5);
          add_to_line ('Title_priority:');
          tab_line (display_spacer);
          add_integer_to_line (selected_titles^ [j].priority);
          flush_line (status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          indent_line (5);
          add_to_line ('Title_data:');
          IF selected_titles^ [j].data_length = 0 THEN
            tab_line (display_spacer);
            add_to_line ('None');
            flush_line (status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSE
            i#move (^selected_titles^ [j].data, ^title_data, selected_titles^ [j].data_length);
            tab_line (display_spacer);
            STRINGREP (str, length, '''', title_data (1, selected_titles^ [j].data_length), '''');
            add_to_line (str (1, length));
            flush_line (status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        FOREND;
      IFEND;
    ELSEIF sa$titles IN attributes THEN
      indent_line (3);
      add_to_line ('Titles: ');
      IF selected_titles = NIL THEN
        tab_line (display_spacer);
        add_to_line ('None');
        flush_line (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        selected_title_count := UPPERBOUND (selected_titles^);
        FOR j := 1 TO selected_title_count DO
          tab_line (display_spacer);
          add_to_line (selected_titles^ [j].title (1, clp$trimmed_string_size (selected_titles^ [j].title)));
          display_wide_line (line.value (1, line.size), status);
          line.size := 0;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    IFEND;

    IF sa$server_managed_titles IN attributes THEN
      indent_line (3);
      add_to_line ('Server_managed_titles: ');
      IF server_managed_titles = NIL THEN
        tab_line (display_spacer);
        add_to_line ('None');
        flush_line (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        title_pattern_count := UPPERBOUND (server_managed_titles^);
        FOR j := 1 TO title_pattern_count DO
          tab_line (display_spacer);
          add_to_line (server_managed_titles^ [j] (1, clp$trimmed_string_size (server_managed_titles^ [j])));
          display_wide_line (line.value (1, line.size), status);
          line.size := 0;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    IFEND;

    IF sa$accept_connections IN attributes THEN
      indent_line (3);
      add_to_line ('Accept_connection: ');
      tab_line (display_spacer);
      add_boolean_to_line (accept_connection);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF sa$client_validation IN attributes THEN
      indent_line (3);
      add_to_line ('Client_validation: ');
      tab_line (display_spacer);
      IF client_capability = osc$null_name THEN
        add_to_line ('None');
      ELSE
        add_to_line (client_capability);
      IFEND;
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF sa$client_info_source IN attributes THEN
      indent_line (3);
      add_to_line ('Client_information_source: ');
      tab_line (display_spacer);
      add_to_line (client_info_label [client_info_source]);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF sa$client_addresses IN attributes THEN
      indent_line (3);
      add_to_line ('Client_addresses: ');
      IF client_addresses = NIL THEN
        client_address_count := 0;
        tab_line (display_spacer);
        add_to_line ('all addresses');
        flush_line (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        client_address_count := UPPERBOUND (client_addresses^);
        FOR j := 1 TO client_address_count DO
          tab_line (display_spacer);
          IF client_addresses^ [j].network_id = 0 THEN
            add_to_line ('all networks, ');
          ELSE
            add_integer_to_line (client_addresses^ [j].network_id);
            add_to_line (', ');
          IFEND;
          IF (client_addresses^ [j].system_id = 0) OR (client_addresses^ [j].system_kind <>
                nac$any_system_kind) THEN
            add_to_line (client_system_kind [client_addresses^ [j].system_kind] (1,
                  clp$trimmed_string_size (client_system_kind [client_addresses^ [j].system_kind])));
            add_to_line (' systems, ');
          ELSE
            add_integer_to_line (client_addresses^ [j].system_id);
            add_to_line (', ');
          IFEND;
          IF client_addresses^ [j].reserved_application_id THEN
            add_integer_to_line (client_addresses^ [j].application_id);
          ELSE
            add_to_line ('all application identifiers');
          IFEND;
          flush_line (status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    IFEND;

    IF sa$nam_initiated IN attributes THEN
      indent_line (3);
      add_to_line ('NAM_Initiated: ');
      tab_line (display_spacer);
      add_boolean_to_line (nam_initiated);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF nam_initiated AND (sa$server_job_val_source IN attributes) THEN
      indent_line (3);
      add_to_line ('Server_job_validation_source: ');
      tab_line (display_spacer);
      add_to_line (validation_source_label [server_job_validation_source]);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF nam_initiated AND (sa$server_job_max_connections IN attributes) THEN
      indent_line (3);
      add_to_line ('Server_job_maximum_connections: ');
      tab_line (display_spacer);
      add_integer_to_line (server_job_max_connections);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF nam_initiated AND (sa$server_job IN attributes) THEN
      IF server_job_specified THEN
        fsp$open_file (server_job, amc$record, ^access_selections, {default_creation_attributes=} NIL,
              {mandated_creation_attributes=} NIL, {attribute_validation=} NIL, {attribute_override=} NIL,
              server_file_identifier, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        server_file.local_file_name := server_job;
        clp$get_path_description (server_file, server_file_reference, path_container, path, cycle_selector,
              open_position, status);
        IF NOT status.normal THEN
          fsp$close_file (server_file_identifier, ignore_status);
          RETURN;
        IFEND;
        indent_line (3);
        add_to_line ('Server_job: ');
        tab_line (display_spacer);
        add_to_line (server_file_reference.path_name (1, server_file_reference.path_name_size));
        flush_line (status);
      ELSE
        path_name [UPPERBOUND (path_name)] := server;
        nap$open_server_job_file (server, server_file_identifier, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        pfp$convert_pf_path_to_fs_path (path_name, path_string, path_size);
        indent_line (3);
        add_to_line ('Server_job: ');
        tab_line (display_spacer);
        add_to_line (path_string (1, path_size));
        flush_line (status);
      IFEND;
      IF status.normal THEN
        PUSH job_line: [clc$max_command_line_size];
        amp$get_next (server_file_identifier, job_line, #SIZE (job_line^), transfer_count, byte_address,
              file_position, status);
        WHILE status.normal AND (file_position <> amc$eoi) DO
          job_line^ (5, * ) := job_line^ (1, transfer_count);
          job_line^ (1, 4) := ' '; {indent_line}
          display_wide_line (job_line^ (1, transfer_count + 4), status);
          IF status.normal THEN
            amp$get_next (server_file_identifier, job_line, #SIZE (job_line^), transfer_count, byte_address,
                  file_position, status);
          IFEND;
        WHILEND;
      IFEND;
      IF server_job_specified THEN
        fsp$close_file (server_file_identifier, local_status);
      ELSE
        nap$close_server_job_file (server_file_identifier, local_status);
      IFEND;
      IF NOT local_status.normal AND status.normal THEN
        status := local_status;
      IFEND;
    IFEND;

  PROCEND generate_server_attrib_display;
?? OLDTITLE ??
?? NEWTITLE := 'generate_server_definition_cmds', EJECT ??

  PROCEDURE generate_server_definition_cmds
    (    server: nat$application_name;
         application_status: nat$application_status;
         selected_titles: ^array [1 .. * ] of nat$selected_title;
         server_managed_titles: ^nat$title_pattern_list;
         max_connections: nat$number_of_connections;
         connection_priority: nat$network_message_priority;
         capability: ost$name;
         ring: ost$ring;
         system_privilege: boolean;
         accept_connection: boolean;
         client_capability: ost$name;
         client_info_source: nat$client_info_source;
         client_addresses: ^array [1 .. * ] of nat$client_address;
         reserved_application_id: boolean;
         application_id: nat$internet_sap_identifier;
         protocol: nat$protocol;
         nam_initiated: boolean;
         server_job_specified: boolean;
         server_job: amt$local_file_name;
         server_job_validation_source: nat$server_validation_source;
         server_job_max_connections: nat$number_of_connections;
     VAR status: ost$status);

    VAR
      access_selections: [STATIC, READ] array [1 .. 2] of fst$attachment_option :=
            [[fsc$create_file, FALSE], [fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$read]],
            [fsc$specific_share_modes, [fsc$read, fsc$execute]]]],
      byte_address: amt$file_byte_address,
      client_address_count: integer,
      current_indent_column: clt$command_line_index,
      file: clt$file,
      file_name: ost$name,
      file_position: amt$file_position,
      highest_cycle: [STATIC, READ] pft$cycle_selector := [pfc$highest_cycle],
      i_string: ost$string,
      ignore_status: ost$status,
      j: integer,
      job_line: ^clt$command_line,
      line_size: clt$command_line_size,
      length: integer,
      local_status: ost$status,
      path_name: [STATIC] array [1 .. 6] of pft$name := [nac$application_family,
            nac$application_master_catalog, nac$network_subcatalog, nac$application_catalog,
            nac$application_job_catalog, * ],
      selected_title_count: nat$max_titles,
      server_file_identifier: amt$file_identifier,
      server_managed_title_count: nat$max_titles,
      share_selections: [STATIC, READ] pft$usage_selections := [pfc$read],
      str: string (osc$max_string_size),
      title_data: string (nac$max_directory_data_length),
      transfer_count: amt$transfer_count,
      unique_name: ost$name,
      usage_selections: [STATIC, READ] pft$usage_selections := [pfc$read];

    status.normal := TRUE;
    current_indent_column := initial_indent_column;

{  Generate define_server command.

    put_line (status); { blank line }
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    indent_line (current_indent_column);
    add_to_line ('define_server');
    STRINGREP (str, length, ' server=', server (1, clp$trimmed_string_size (server)));
    add_to_line_if_can ({last_parameter=} FALSE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (str, length, ' protocol=', protocol_label [protocol]
          (1, clp$trimmed_string_size (protocol_label [protocol])));
    add_to_line_if_can ({last_parameter=} FALSE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (str, length, ' nam_initiated=', boolean_label
          [nam_initiated] (1, clp$trimmed_string_size (boolean_label [nam_initiated])));
    add_to_line_if_can ({last_parameter=} TRUE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  Generate define_server subcommands that make up the server definition.

    current_indent_column := initial_indent_column + indent_increment;

{   Application identifier

    indent_line (current_indent_column);
    add_to_line ('change_application_identifier');
    IF reserved_application_id THEN
      clp$convert_integer_to_string (application_id, 10, FALSE, i_string, ignore_status);
      STRINGREP (str, length, ' application_identifier=', i_string.value (1, i_string.size));
      add_to_line_if_can ({last_parameter=} TRUE, str (1, length), status);
    ELSE
      add_to_line_if_can ({last_parameter=} TRUE, ' application_identifier=variable', status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Maximum connections

    indent_line (current_indent_column);
    add_to_line ('change_maximum_connections');
    clp$convert_integer_to_string (max_connections, 10, FALSE, i_string, ignore_status);
    STRINGREP (str, length, ' maximum_connections=', i_string.value (1, i_string.size));
    add_to_line_if_can ({last_parameter=} TRUE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Connection priority

    indent_line (current_indent_column);
    add_to_line ('change_connection_priority');
    clp$convert_integer_to_string (connection_priority, 10, FALSE, i_string, ignore_status);
    STRINGREP (str, length, ' connection_priority=', i_string.value (1, i_string.size));
    add_to_line_if_can ({last_parameter=} TRUE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Server capability / Server ring / Server system privilege

    indent_line (current_indent_column);
    add_to_line ('change_server_validation');

    IF capability = osc$null_name THEN
      add_to_line_if_can ({last_parameter=} FALSE, ' capability=none', status);
    ELSE
      STRINGREP (str, length, ' capability=', capability (1, clp$trimmed_string_size (capability)));
      add_to_line_if_can ({last_parameter=} FALSE, str (1, length), status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (ring, 10, FALSE, i_string, ignore_status);
    STRINGREP (str, length, ' ring=', i_string.value (1, i_string.size));
    add_to_line_if_can ({last_parameter=} FALSE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (str, length, ' system_privilege=', boolean_label [system_privilege] (1,
          clp$trimmed_string_size (boolean_label [system_privilege])));
    add_to_line_if_can ({last_parameter=} TRUE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Titles / Title attributes

    IF selected_titles <> NIL THEN
      selected_title_count := UPPERBOUND (selected_titles^);
      FOR j := 1 TO selected_title_count DO
        indent_line (current_indent_column);
        add_to_line ('add_title');
        add_to_line (' title=''');
        add_string_to_line ({last_parameter=} FALSE, selected_titles^
              [j].title (1, clp$trimmed_string_size (selected_titles^ [j].title)), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        add_string_to_line ({last_parameter=} FALSE, '''', status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        STRINGREP (str, length, ' broadcast_registration=',
              boolean_label [selected_titles^ [j].distribute_title]
              (1, clp$trimmed_string_size (boolean_label [selected_titles^ [j].distribute_title])));
        add_to_line_if_can ({last_parameter=} FALSE, str (1, length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$convert_integer_to_string (selected_titles^ [j].priority, 10, FALSE, i_string, ignore_status);
        STRINGREP (str, length, ' priority=', i_string.value (1, i_string.size));
        add_to_line_if_can ({last_parameter=} FALSE, str (1, length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF selected_titles^ [j].data_length <> 0 THEN
          i#move (^selected_titles^ [j].data, ^title_data, selected_titles^ [j].data_length);
          STRINGREP (str, length, ' data=''', title_data (1, selected_titles^ [j].data_length), '''');
          add_to_line_if_can ({last_parameter=} TRUE, str (1, length), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        put_line (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;

{   Server managed titles

    IF server_managed_titles <> NIL THEN
      server_managed_title_count := UPPERBOUND (server_managed_titles^);
      FOR j := 1 TO server_managed_title_count DO
        indent_line (current_indent_column);
        add_to_line ('add_server_managed_title');
        add_to_line (' title_pattern=''');
        add_string_to_line ({last_parameter=} FALSE, server_managed_titles^
              [j] (1, clp$trimmed_string_size (server_managed_titles^ [j])), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        add_string_to_line ({last_parameter=} FALSE, '''', status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        put_line (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;

{   Accept connection

    indent_line (current_indent_column);
    add_to_line ('change_accept_connection');
    STRINGREP (str, length, ' accept_connection=', boolean_label [accept_connection] (1,
          clp$trimmed_string_size (boolean_label [accept_connection])));
    add_to_line_if_can ({last_parameter=} TRUE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Client validation

    indent_line (current_indent_column);
    add_to_line ('change_client_validation');
    IF client_capability = osc$null_name THEN
      add_to_line_if_can ({last_parameter=} TRUE, ' capability=none', status);
    ELSE
      STRINGREP (str, length, ' capability=', client_capability
            (1, clp$trimmed_string_size (client_capability)));
      add_to_line_if_can ({last_parameter=} TRUE, str (1, length), status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Client information source

    indent_line (current_indent_column);
    add_to_line ('change_client_info_source');
    STRINGREP (str, length, ' source=', client_info_label [client_info_source]);
    add_to_line_if_can ({last_parameter=} TRUE, str (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Client addresses

    IF client_addresses <> NIL THEN
      client_address_count := UPPERBOUND (client_addresses^);
      FOR j := 1 TO client_address_count DO
        indent_line (current_indent_column);
        add_to_line ('add_client_address');
        IF client_addresses^ [j].network_id = 0 THEN
          add_to_line_if_can ({last_parameter=} FALSE, ' network_identifier=all', status);
        ELSE
          clp$convert_integer_to_string (client_addresses^ [j].network_id, 10, FALSE, i_string,
                ignore_status);
          STRINGREP (str, length, ' network_identifier=', i_string.value (1, i_string.size));
          add_to_line_if_can ({last_parameter=} FALSE, str (1, length), status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF (client_addresses^ [j].system_id = 0) OR (client_addresses^ [j].system_kind <>
              nac$any_system_kind) THEN
          STRINGREP (str, length, ' system_identifier=', client_system_kind
                [client_addresses^ [j].system_kind] (1, clp$trimmed_string_size
                (client_system_kind [client_addresses^ [j].system_kind])));
        ELSE
          clp$convert_integer_to_string (client_addresses^ [j].system_id, 10, FALSE, i_string, ignore_status);
          STRINGREP (str, length, ' system_identifier=', i_string.value (1, i_string.size));
        IFEND;
        add_to_line_if_can ({last_parameter=} FALSE, str (1, length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF client_addresses^ [j].reserved_application_id THEN
          clp$convert_integer_to_string (client_addresses^ [j].application_id, 10, FALSE, i_string,
                ignore_status);
          STRINGREP (str, length, ' application_identifier=', i_string.value (1, i_string.size));
          add_to_line_if_can ({last_parameter=} TRUE, str (1, length), status);
        ELSE
          add_to_line_if_can ({last_parameter=} TRUE, ' application_identifier=all', status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        put_line (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;

{   Server job / Server job validation source / Server job maximum connections

    IF nam_initiated THEN
      indent_line (current_indent_column);
      add_to_line ('change_server_job');
      STRINGREP (str, length, ' validation_source=', validation_source_label [server_job_validation_source]
            (1, 6)); {trims 'server job' to 'server'}
      add_to_line_if_can ({last_parameter=} FALSE, str (1, length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_string (server_job_max_connections, 10, FALSE, i_string, ignore_status);
      STRINGREP (str, length, ' maximum_connections=', i_string.value (1, i_string.size));
      add_to_line_if_can ({last_parameter=} (server_job = clc$null_file), str (1, length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF server_job <> clc$null_file THEN
        IF server_job_specified THEN
          fsp$open_file (server_job, amc$record, ^access_selections, {default_creation_attributes=} NIL,
                {mandated_creation_attributes=} NIL, {attribute_validation=} NIL, {attribute_override=} NIL,
                server_file_identifier, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          nap$open_server_job_file (server, server_file_identifier, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        STRINGREP (str, length, ' job=', command_file);
        add_to_line_if_can ({last_parameter=} FALSE, str (1, length), status);
        IF NOT status.normal THEN
          IF server_job_specified THEN
            fsp$close_file (server_file_identifier, ignore_status);
          ELSE
            nap$close_server_job_file (server_file_identifier, ignore_status);
          IFEND;
          RETURN;
        IFEND;

        add_to_line_if_can ({last_parameter=} TRUE, ' include_commands_until=''END_SERVER_JOB''', status);
        IF NOT status.normal THEN
          IF server_job_specified THEN
            fsp$close_file (server_file_identifier, ignore_status);
          ELSE
            nap$close_server_job_file (server_file_identifier, ignore_status);
          IFEND;
          RETURN;
        IFEND;
      IFEND;
      put_line (status);
      IF NOT status.normal THEN
        IF server_job_specified THEN
          fsp$close_file (server_file_identifier, ignore_status);
        ELSE
          nap$close_server_job_file (server_file_identifier, ignore_status);
        IFEND;
        RETURN;
      IFEND;

{  Get the server job commands

      IF server_job <> clc$null_file THEN
        PUSH job_line: [clc$max_command_line_size];
        current_indent_column := initial_indent_column;
        amp$get_next (server_file_identifier, job_line, #SIZE (job_line^), transfer_count, byte_address,
              file_position, status);
        WHILE status.normal AND (file_position <> amc$eoi) DO
          indent_line (current_indent_column);
          amp$put_partial (output_file_id, ^line.value, line.size, byte_address, amc$start, status);
          IF status.normal THEN
            amp$put_partial (output_file_id, job_line, transfer_count, byte_address, amc$terminate, status);
            IF status.normal THEN
              amp$get_next (server_file_identifier, job_line, #SIZE (job_line^), transfer_count, byte_address,
                    file_position, status);
            IFEND;
          IFEND;
        WHILEND;
        IF status.normal THEN
          indent_line (initial_indent_column);
          add_to_line ('END_SERVER_JOB');
          put_line (status);
        IFEND;
        IF server_job_specified THEN
          fsp$close_file (server_file_identifier, local_status);
        ELSE
          nap$close_server_job_file (server_file_identifier, local_status);
        IFEND;
        IF NOT local_status.normal AND status.normal THEN
          status := local_status;
        IFEND;
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{   Generate the end_define_server command

    indent_line (initial_indent_column);
    add_to_line ('end_define_server');
    add_to_line (' save_definition=TRUE');
    put_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND generate_server_definition_cmds;
?? OLDTITLE ??
?? NEWTITLE := 'generate_server_status_display', EJECT ??

  PROCEDURE generate_server_status_display
    (    server: nat$application_name;
     VAR status: ost$status);

    VAR
      active_connection_count: nat$number_of_connections,
      active_job_count: integer,
      application_id: nat$internet_sap_identifier,
      attempted_connection_count: integer,
      attributes: array [1 .. 1] of nat$display_job_attributes,
      attribute_list: ^array [1 .. * ] of nat$display_job_attributes,
      i: integer,
      j: integer,
      rejected_connection_attempts: integer,
      reserved_application_id: boolean,
      server_added_title_count: nat$max_titles,
      server_added_title: array [1 .. 1] of string (nac$max_title_length),
      server_added_titles: ^array [1 .. * ] of string (nac$max_title_length),
      server_status: nat$application_status;


    nap$get_server_status (server, server_status, reserved_application_id, application_id, active_job_count,
          attributes, active_connection_count, attempted_connection_count, rejected_connection_attempts,
          server_added_title_count, server_added_title, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    add_to_line ('Server: ');
    tab_line (display_spacer);
    add_to_line (server);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    add_to_line ('  Status: ');
    tab_line (display_spacer);
    add_to_line (application_status_description [server_status]);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    add_to_line ('  Active_server_connections: ');
    tab_line (display_spacer);
    add_integer_to_line (active_connection_count);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    add_to_line ('  Attempted_connection_count: ');
    tab_line (display_spacer);
    add_integer_to_line (attempted_connection_count);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    add_to_line ('  Rejected_connection_attempts: ');
    tab_line (display_spacer);
    add_integer_to_line (rejected_connection_attempts);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    add_to_line ('  Server_added_titles: ');
    IF server_added_title_count = 0 THEN
      tab_line (display_spacer);
      add_to_line ('None');
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSEIF server_added_title_count = 1 THEN
      tab_line (display_spacer);
      add_to_line (server_added_title [1] (1, clp$trimmed_string_size (server_added_title [1])));
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      PUSH server_added_titles: [1 .. server_added_title_count];
      nap$get_server_status (server, server_status, reserved_application_id, application_id, active_job_count,
            attributes, active_connection_count, attempted_connection_count, rejected_connection_attempts,
            server_added_title_count, server_added_titles^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      FOR i := 1 TO server_added_title_count DO
        tab_line (display_spacer);
        add_to_line (server_added_titles^ [i] (1, clp$trimmed_string_size (server_added_titles^ [i])));
        flush_line (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    add_to_line ('  Active_server_jobs: ');
    tab_line (display_spacer);
    add_integer_to_line (active_job_count);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF active_job_count > 0 THEN
      add_to_line ('    Job name            Connections');
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF active_job_count = 1 THEN
        tab_line (3);
        add_to_line (attributes [1].job_name);
        tab_line (32);
        add_integer_to_line (attributes [1].connection_count);
        flush_line (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        PUSH attribute_list: [1 .. active_job_count];
        nap$get_server_status (server, server_status, reserved_application_id, application_id,
              active_job_count, attribute_list^, active_connection_count, attempted_connection_count,
              rejected_connection_attempts, server_added_title_count, server_added_title, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        FOR i := 1 TO active_job_count DO
          tab_line (3);
          add_to_line (attribute_list^ [i].job_name);
          tab_line (32);
          add_integer_to_line (attribute_list^ [i].connection_count);
          flush_line (status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    IFEND;

  PROCEND generate_server_status_display;
?? OLDTITLE ??
?? NEWTITLE := 'generate_tcpip_attrib_display', EJECT ??

  PROCEDURE generate_tcpip_attrib_display
    (    tcpip: nat$application_name;
         attributes: tcpip_attribute_set;
         max_sockets: nat$number_of_sockets;
         capability: ost$name;
         ring: ost$ring;
         system_privilege: boolean;
         protocol: nat$protocol;
     VAR status: ost$status);


    add_to_line ('TCP/IP:');
    tab_line (display_spacer);
    add_to_line (tcpip);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF ta$protocol IN attributes THEN
      indent_line (3);
      add_to_line ('Protocol: ');
      tab_line (display_spacer);
      add_to_line (protocol_label [protocol]);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF ta$maximum_sockets IN attributes THEN
      indent_line (3);
      add_to_line ('Maximum_sockets: ');
      tab_line (display_spacer);
      add_integer_to_line (max_sockets);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF ta$capability IN attributes THEN
      indent_line (3);
      add_to_line ('Capability: ');
      tab_line (display_spacer);
      IF capability = osc$null_name THEN
        add_to_line ('None');
      ELSE
        add_to_line (capability);
      IFEND;
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF ta$ring IN attributes THEN
      indent_line (3);
      add_to_line ('Ring: ');
      tab_line (display_spacer);
      add_integer_to_line (ring);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF ta$system_privilege IN attributes THEN
      indent_line (3);
      add_to_line ('System_privilege: ');
      tab_line (display_spacer);
      add_boolean_to_line (system_privilege);
      flush_line (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND generate_tcpip_attrib_display;

?? OLDTITLE ??
?? NEWTITLE := 'generate_tcpip_status_display', EJECT ??

  PROCEDURE generate_tcpip_status_display
    (    tcpip: nat$application_name;
     VAR status: ost$status);

    VAR
      active_socket_count: nat$number_of_sockets,
      assign_socket_attempts: integer,
      i: integer,
      index: integer,
      ignore_status: ost$status,
      j: integer,
      output_length: integer,
      output_string: string (255),
      socket_requests_rejected: integer,
      tcpip_status: nat$application_status;


    nap$get_tcpip_status (tcpip, tcpip_status, active_socket_count, assign_socket_attempts,
          socket_requests_rejected, status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;
    add_to_line ('TCP/IP: ');
    tab_line (display_spacer);
    add_to_line (tcpip);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    add_to_line ('  Status: ');
    tab_line (display_spacer);
    add_to_line (application_status_description [tcpip_status]);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    add_to_line ('  Active_TCP/IP_sockets: ');
    tab_line (display_spacer);
    add_integer_to_line (active_socket_count);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_to_line ('  Assign TCP/IP socket attempts: ');
    tab_line (display_spacer);
    add_integer_to_line (assign_socket_attempts);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_to_line ('  TCP/IP rejected requests: ');
    tab_line (display_spacer);
    add_integer_to_line (socket_requests_rejected);
    flush_line (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND generate_tcpip_status_display;
?? OLDTITLE ??
?? NEWTITLE := 'process_client_attrib_parameter', EJECT ??

  PROCEDURE process_client_attrib_parameter
    (    display_options: clt$parameter_value;
     VAR attributes: client_attribute_set;
     VAR status: ost$status);

    VAR
      attributes_ptr: ^clt$data_value,
      keyword_value: clt$keyword;

    attributes := $client_attribute_set [];
    attributes_ptr := display_options.value;

    WHILE attributes_ptr <> NIL DO
      keyword_value := attributes_ptr^.element_value^.keyword_value;
      IF (keyword_value = 'ALL') THEN
        attributes := -$client_attribute_set [];
      ELSEIF (keyword_value = 'PROTOCOL') THEN
        attributes := attributes + $client_attribute_set [ca$protocol];
      ELSEIF (keyword_value = 'APPLICATION_IDENTIFIER') THEN
        attributes := attributes + $client_attribute_set [ca$application_id];
      ELSEIF (keyword_value = 'MAXIMUM_CONNECTIONS') THEN
        attributes := attributes + $client_attribute_set [ca$max_connections];
      ELSEIF (keyword_value = 'CONNECTION_PRIORITY') THEN
        attributes := attributes + $client_attribute_set [ca$connection_priority];
      ELSEIF (keyword_value = 'CLIENT_CAPABILITY') THEN
        attributes := attributes + $client_attribute_set [ca$client_capability];
      ELSEIF (keyword_value = 'CLIENT_RING') THEN
        attributes := attributes + $client_attribute_set [ca$client_ring];
      ELSEIF (keyword_value = 'CLIENT_STATUS') THEN
        attributes := attributes + $client_attribute_set [ca$status];
      ELSEIF (keyword_value = 'CLIENT_SYSTEM_PRIVILEGE') THEN
        attributes := attributes + $client_attribute_set [ca$client_system_priv];
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$invalid_client_attribute, keyword_value, status);
        RETURN;
      IFEND;
      attributes_ptr := attributes_ptr^.link;
    WHILEND;

  PROCEND process_client_attrib_parameter;
?? OLDTITLE ??
?? NEWTITLE := 'process_output_file', EJECT ??

  PROCEDURE process_output_file
    (    output_file_name: fst$file_reference;
     VAR status: ost$status);

    CONST
      min_page_width = 65;

    VAR
      default_creation_attributes: [STATIC] array [1 .. 1] of fst$file_cycle_attribute :=
            [[fsc$file_contents_and_processor, fsc$legible_data, fsc$unknown_processor]],
      file_attachment: [STATIC] array [1 .. 3] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$shorten, fsc$append]],
            [fsc$specific_share_modes, []]], [fsc$access_and_share_modes,
            [fsc$specific_access_modes, [fsc$append]], [fsc$specific_share_modes, []]],
            [fsc$open_share_modes, -$fst$file_access_options []]],
      ignore_status: ost$status,
      output_file_attributes: array [1 .. 2] of amt$fetch_item;

    status.normal := TRUE;

    fsp$open_file (output_file_name, amc$record, ^file_attachment, ^default_creation_attributes,
          {mandated_creation_attributes =} NIL, {attribute_validation =} NIL, {attribute_override =} NIL,
          output_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_file_attributes [1].key := amc$page_width;
    output_file_attributes [2].key := amc$file_contents;
    amp$fetch (output_file_id, output_file_attributes, status);
    IF NOT status.normal THEN
      fsp$close_file (output_file_id, ignore_status);
      RETURN;
    IFEND;
    IF (output_file_attributes [1].source <> amc$undefined_attribute) THEN
      IF output_file_attributes [1].page_width > max_line_width THEN
        page_width := max_line_width;
      ELSEIF output_file_attributes [1].page_width < min_page_width THEN
        osp$set_status_condition (nae$page_width_too_small, status);
        osp$append_status_integer (osc$status_parameter_delimiter, min_page_width, 10, FALSE, status);
        fsp$close_file (output_file_id, ignore_status);
        RETURN;
      ELSE
        page_width := output_file_attributes [1].page_width;
      IFEND;
    ELSE
      page_width := min_page_width;
    IFEND;

    IF (output_file_attributes [2].file_contents = 'LIST') THEN
      initial_indent_column := 2;
    ELSE
      initial_indent_column := 1;
    IFEND;

  PROCEND process_output_file;
?? OLDTITLE ??
?? NEWTITLE := 'process_output_parameter', EJECT ??

  PROCEDURE process_output_parameter
    (    parameter_value: clt$parameter_value;
     VAR output_specified: boolean;
     VAR status: ost$status);

    VAR
      default_ring_attributes: amt$ring_attributes;

    output_specified := parameter_value.specified;

    IF output_specified THEN
      default_ring_attributes.r1 := #RING (^default_ring_attributes);
      default_ring_attributes.r2 := #RING (^default_ring_attributes);
      default_ring_attributes.r3 := #RING (^default_ring_attributes);

      clp$open_display_reference (parameter_value.value^.file_value^, ^generate_headers, fsc$list,
            default_ring_attributes, local_display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      current_display_control := ^local_display_control;
    ELSE
      current_display_control := ^output_control;
    IFEND;
    IF current_display_control^.page_width < clc$narrow_page_width THEN
      page_width := clc$narrow_page_width;
    ELSEIF current_display_control^.page_width > clc$wide_page_width THEN
      page_width := clc$wide_page_width;
    ELSE
      page_width := current_display_control^.page_width;
    IFEND;

  PROCEND process_output_parameter;
?? OLDTITLE ??
?? NEWTITLE := 'process_server_attrib_parameter', EJECT ??

  PROCEDURE process_server_attrib_parameter
    (    display_options: clt$parameter_value;
     VAR attributes: server_attribute_set;
     VAR status: ost$status);

    VAR
      attributes_ptr: ^clt$data_value,
      keyword_value: clt$keyword;

    attributes := $server_attribute_set [];

    attributes_ptr := display_options.value;

    WHILE attributes_ptr <> NIL DO
      keyword_value := attributes_ptr^.element_value^.keyword_value;
      IF (keyword_value = 'ALL') THEN
        attributes := -$server_attribute_set [];
      ELSEIF (keyword_value = 'PROTOCOL') THEN
        attributes := attributes + $server_attribute_set [sa$protocol];
      ELSEIF (keyword_value = 'NAM_INITIATED') THEN
        attributes := attributes + $server_attribute_set [sa$nam_initiated];
      ELSEIF (keyword_value = 'TITLES') THEN
        attributes := attributes + $server_attribute_set [sa$titles];
      ELSEIF (keyword_value = 'TITLE_ATTRIBUTES') THEN
        attributes := attributes + $server_attribute_set [sa$title_attributes];
      ELSEIF (keyword_value = 'SERVER_MANAGED_TITLES') THEN
        attributes := attributes + $server_attribute_set [sa$server_managed_titles];
      ELSEIF (keyword_value = 'APPLICATION_IDENTIFIER') THEN
        attributes := attributes + $server_attribute_set [sa$application_id];
      ELSEIF (keyword_value = 'MAXIMUM_CONNECTIONS') THEN
        attributes := attributes + $server_attribute_set [sa$max_connections];
      ELSEIF (keyword_value = 'CONNECTION_PRIORITY') THEN
        attributes := attributes + $server_attribute_set [sa$connection_priority];
      ELSEIF (keyword_value = 'SERVER_CAPABILITY') THEN
        attributes := attributes + $server_attribute_set [sa$server_capability];
      ELSEIF (keyword_value = 'SERVER_RING') THEN
        attributes := attributes + $server_attribute_set [sa$server_ring];
      ELSEIF (keyword_value = 'SERVER_STATUS') THEN
        attributes := attributes + $server_attribute_set [sa$status];
      ELSEIF (keyword_value = 'SERVER_SYSTEM_PRIVILEGE') THEN
        attributes := attributes + $server_attribute_set [sa$server_system_priv];
      ELSEIF (keyword_value = 'SERVER_JOB') THEN
        attributes := attributes + $server_attribute_set [sa$server_job];
      ELSEIF (keyword_value = 'SERVER_JOB_VALIDATION_SOURCE') THEN
        attributes := attributes + $server_attribute_set [sa$server_job_val_source];
      ELSEIF (keyword_value = 'SERVER_JOB_MAXIMUM_CONNECTIONS') THEN
        attributes := attributes + $server_attribute_set [sa$server_job_max_connections];
      ELSEIF (keyword_value = 'ACCEPT_CONNECTION') THEN
        attributes := attributes + $server_attribute_set [sa$accept_connections];
      ELSEIF (keyword_value = 'CLIENT_VALIDATION') THEN
        attributes := attributes + $server_attribute_set [sa$client_validation];
      ELSEIF (keyword_value = 'CLIENT_ADDRESSES') THEN
        attributes := attributes + $server_attribute_set [sa$client_addresses];
      ELSEIF (keyword_value = 'CLIENT_INFO_SOURCE') THEN
        attributes := attributes + $server_attribute_set [sa$client_info_source];
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$invalid_server_attribute, keyword_value, status);
        RETURN;
      IFEND;
      attributes_ptr := attributes_ptr^.link;
    WHILEND;
  PROCEND process_server_attrib_parameter;
?? OLDTITLE ??
?? NEWTITLE := 'process_tcpip_attrib_parameter', EJECT ??

  PROCEDURE process_tcpip_attrib_parameter
    (    pvt: clt$parameter_value;
     VAR attributes: tcpip_attribute_set;
     VAR status: ost$status);

    VAR
      keyword_value: clt$keyword,
      pvt_pointer: ^clt$data_value;


    attributes := $tcpip_attribute_set [];
    pvt_pointer := pvt.value;

    WHILE pvt_pointer <> NIL DO
      keyword_value := pvt_pointer^.element_value^.keyword_value;
      IF (keyword_value = 'ALL') THEN
        attributes := -$tcpip_attribute_set [];
      ELSEIF (keyword_value = 'PROTOCOL') THEN
        attributes := attributes + $tcpip_attribute_set [ta$protocol];
      ELSEIF (keyword_value = 'MAXIMUM_SOCKETS') THEN
        attributes := attributes + $tcpip_attribute_set [ta$maximum_sockets];
      ELSEIF (keyword_value = 'CAPABILITY') THEN
        attributes := attributes + $tcpip_attribute_set [ta$capability];
      ELSEIF (keyword_value = 'RING') THEN
        attributes := attributes + $tcpip_attribute_set [ta$ring];
      ELSEIF (keyword_value = 'SYSTEM_PRIVILEGE') THEN
        attributes := attributes + $tcpip_attribute_set [ta$system_privilege];
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$invalid_tcpip_attribute, keyword_value, status);
        RETURN;
      IFEND;
      pvt_pointer := pvt_pointer^.link;
    WHILEND;

  PROCEND process_tcpip_attrib_parameter;
?? OLDTITLE ??
?? NEWTITLE := 'terminate_break_handler', EJECT ??

  PROCEDURE terminate_break_handler
    (    condition: pmt$condition;
         condition_descriptor: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR status: ost$status);

{ PURPOSE: This routine processes the terminate break condition for MANNA.
{ DESIGN:  The global flag interrupt_detected is set to TRUE and the condition
{          is cancelled. Queued output is also discarded. It is the responsibility
{          of the procedure establishing this condition handler to periodically
{          check the interrupt_detected flag and terminate processing when it is set.

    interrupt_detected := TRUE;
    ifp$discard_suspended_output;

  PROCEND terminate_break_handler;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_line', EJECT ??

  PROCEDURE [INLINE] add_to_line
    (    s: string ( * ));

    line.value (line.size + 1, * ) := s;
    IF (line.size + STRLENGTH (s)) <= max_line_width THEN
      line.size := line.size + STRLENGTH (s);
    ELSE
      line.size := max_line_width;
    IFEND;

  PROCEND add_to_line;
?? TITLE := 'add_boolean_to_line', EJECT ??

  PROCEDURE [INLINE] add_boolean_to_line
    (    b: boolean);

    IF b THEN
      add_to_line ('TRUE');
    ELSE
      add_to_line ('FALSE');
    IFEND;

  PROCEND add_boolean_to_line;
?? TITLE := 'add_integer_to_line', EJECT ??

  PROCEDURE [INLINE] add_integer_to_line
    (    i: integer);

    VAR
      ignore_status: ost$status,
      i_string: ost$string;

    clp$convert_integer_to_string (i, 10, FALSE, i_string, ignore_status);
    add_to_line (i_string.value (1, i_string.size));

  PROCEND add_integer_to_line;
?? TITLE := 'display_wide_line', EJECT ??

  PROCEDURE [INLINE] display_wide_line
    (    display_line: clt$command_line;
     VAR status: ost$status);

    VAR
      line_index: clt$command_line_index,
      line_size: clt$command_line_size,
      line_width: clt$command_line_size;

    line_index := 1;
    line_size := STRLENGTH (display_line);
    line_width := page_width - 1;

    WHILE line_size > line_width DO
      clp$put_display (current_display_control^, display_line (line_index, line_width), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      line_index := line_index + line_width;
      line_size := line_size - line_width;
    WHILEND;
    IF line_size > 0 THEN
      clp$put_display (current_display_control^, display_line (line_index, line_size), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND display_wide_line;

?? TITLE := 'fits_on_current_line', EJECT ??

  FUNCTION [INLINE] fits_on_current_line
    (    string_size: ost$string_size;
         reserve_size: 0 .. continuation_indicator_size): boolean;

    fits_on_current_line := (line.size + string_size + reserve_size) <= page_width;
  FUNCEND fits_on_current_line;
?? TITLE := 'flush_line', EJECT ??

  PROCEDURE [INLINE] flush_line
    (VAR status: ost$status);

    clp$put_display (current_display_control^, line.value (1, line.size), clc$trim, status);
    line.size := 0;

  PROCEND flush_line;
?? TITLE := 'indent_line', EJECT ??

  PROCEDURE [INLINE] indent_line
    (    column: integer);

    IF column <= page_width THEN
      line.value (1, (column - 1)) := ' ';
      line.size := column - 1;
    IFEND;

  PROCEND indent_line;
?? TITLE := 'put_line', EJECT ??

  PROCEDURE [INLINE] put_line
    (VAR status: ost$status);

    VAR
      ignore_byte_address: amt$file_byte_address;

    amp$put_next (output_file_id, ^line.value, line.size, ignore_byte_address, status);
    line.size := 0;
    line.value := '';

  PROCEND put_line;
?? TITLE := 'tab_line', EJECT ??

  PROCEDURE [INLINE] tab_line
    (    column: integer);

    IF line.size < (column - 1) THEN
      line.value (line.size + 1, * ) := '';
      IF column <= max_line_width THEN
        line.size := column - 1;
      ELSE
        line.size := max_line_width;
      IFEND;
    IFEND;

  PROCEND tab_line;
MODEND nam$manage_network_applications;
*DECK DECK=NAM$MANAGE_NON_CDNA_ADDRESSES EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? TITLE := 'NOS/VE: Manage Non-CDNA OSI address command processors' ??
?? NEWTITLE := 'Global Declarations' ??
MODULE nam$manage_non_cdna_addresses;

{ PURPOSE
{   This module implements the command processors for manipulating non-CDNA OSI addresses
{   in the CDNA Directory, as documented in DCS document A8273.
{ DESIGN
{   The facilities of the CDNA Directory are used to store all information used by these
{   command processors. No information is retained locally within this module or within
{   unique network paged structures. This allows these command processors to reside on the
{   $system.osf$system_library and execute in the user's ring.

?? PUSH (LISTEXT := ON) ??
*copyc clc$page_widths
*copyc clt$parameter_list
*copyc clt$parameter_value_table
*copyc clt$which_parameter
*copyc nae$application_management
*copyc nae$manage_network_applications
*copyc nat$directory_interfaces
*copyc nat$osi_address_length
*copyc nat$protocol
*copyc ost$date
*copyc ost$name
*copyc ost$status
*copyc ost$time
*copyc pmt$os_name
?? POP ??
*copyc avp$get_capability
*copyc clp$close_display
*copyc clp$evaluate_parameters
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc nlp$delete_registered_title
*copyc nlp$end_title_translation
*copyc nlp$get_title_translation
*copyc nlp$register_title
*copyc nlp$translate_title
*copyc osp$append_status_integer
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$get_legible_date_time
*copyc pmp$get_os_version
?? OLDTITLE ??
?? NEWTITLE := 'Local definitions', EJECT ??

  CONST
    command_level = '88203',
    command_version = 'V1.0',
    default_password = 1234;

  TYPE
    osi_address_header = record
      kind: nat$network_address_kind,
      length: nat$osi_address_length,
    recend,

    osi_presentation_selector = record
      length: nat$osi_psap_selector_length,
      value: nat$osi_presentation_selector,
    recend,

    osi_session_selector = record
      length: nat$osi_ssap_selector_length,
      value: nat$osi_session_selector,
    recend,

    osi_transport_selector = record
      tsap_length: nat$osi_tsap_selector_length,
      tsap: string ( * ),
    recend,

    osi_network_address = record
      network_address_length: nat$osi_network_address_length,
      network_address: string ( * ),
    recend;

  VAR
    hex_digits: [STATIC, READ] array [0 .. 15] of char := ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
          'A', 'B', 'C', 'D', 'E', 'F'],
    wild_card_title: string (1) := '*';

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$add_osi_address', EJECT ??

{ PURPOSE: This procedure processes the ADD_OSI_ADDRESS command, which adds a non-CDNA OSI
{          address to the CDNA Directory. Translations of this address are available only
{          to entities in the local system.
{ DESIGN:  The command parameters are parsed and validated. The title/address pair is then
{          placed in the local CDNA Directory. An identifier is assigned to this title/address
{          pair either by command parameter or by default. The title identifier is used as
{          the user identifier in the CDNA Directory and is used by the DISPLAY_OSI_ADDRESSES
{          and DELETE_OSI_ADDRESSES command processors.

  PROCEDURE [XDCL] nap$add_osi_address
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (nam$addosia) add_osi_addresses, add_osi_address, addosia (
{ titles, title, t: list of any of
{     string 1 .. 255
{     name
{   anyend = $required
{ network_address, na: (check) string 1 .. 40 = $required
{ transport_selector, ts: (check) string 0 .. 64 = $required
{ session_selector, ss: (check) string 0 .. 32 = $required
{ presentation_selector, ps: (check) string 0 .. 8
{ priority, p: integer 1 .. 255 = 1
{ data, d: string 1 .. 32
{ title_identifier, ti: name
{ network_service, ns: key
{     (connection_less_net_service, clns)
{     (connection_oriented_net_service, cons)
{   keyend = clns
{ transport_class, tc: integer 0 .. 4 = 4
{ status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 22] of clt$pdt_parameter_name,
      parameters: array [1 .. 11] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type11: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 16, 11, 51, 37, 272],
    clc$command, 22, 11, 4, 0, 0, 0, 11, 'NAM$ADDOSIA'], [
    ['D                              ',clc$abbreviation_entry, 7],
    ['DATA                           ',clc$nominal_entry, 7],
    ['NA                             ',clc$abbreviation_entry, 2],
    ['NETWORK_ADDRESS                ',clc$nominal_entry, 2],
    ['NETWORK_SERVICE                ',clc$nominal_entry, 9],
    ['NS                             ',clc$abbreviation_entry, 9],
    ['P                              ',clc$abbreviation_entry, 6],
    ['PRESENTATION_SELECTOR          ',clc$nominal_entry, 5],
    ['PRIORITY                       ',clc$nominal_entry, 6],
    ['PS                             ',clc$abbreviation_entry, 5],
    ['SESSION_SELECTOR               ',clc$nominal_entry, 4],
    ['SS                             ',clc$abbreviation_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 11],
    ['T                              ',clc$abbreviation_entry, 1],
    ['TC                             ',clc$abbreviation_entry, 10],
    ['TI                             ',clc$abbreviation_entry, 8],
    ['TITLE                          ',clc$alias_entry, 1],
    ['TITLES                         ',clc$nominal_entry, 1],
    ['TITLE_IDENTIFIER               ',clc$nominal_entry, 8],
    ['TRANSPORT_CLASS                ',clc$nominal_entry, 10],
    ['TRANSPORT_SELECTOR             ',clc$nominal_entry, 3],
    ['TS                             ',clc$abbreviation_entry, 3]],
    [
{ PARAMETER 1
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 49, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 5
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 6
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 7
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 8
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 9
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 10
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 11
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
      TRUE, 2],
      8, [[1, 0, clc$string_type], [1, 255, FALSE]],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 40, FALSE]],
{ PARAMETER 3
    [[1, 0, clc$string_type], [0, 64, FALSE]],
{ PARAMETER 4
    [[1, 0, clc$string_type], [0, 32, FALSE]],
{ PARAMETER 5
    [[1, 0, clc$string_type], [0, 8, FALSE]],
{ PARAMETER 6
    [[1, 0, clc$integer_type], [1, 255, 10],
    '1'],
{ PARAMETER 7
    [[1, 0, clc$string_type], [1, 32, FALSE]],
{ PARAMETER 8
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 9
    [[1, 0, clc$keyword_type], [4], [
    ['CLNS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CONNECTION_LESS_NET_SERVICE    ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['CONNECTION_ORIENTED_NET_SERVICE', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['CONS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 2]]
    ,
    'clns'],
{ PARAMETER 10
    [[1, 0, clc$integer_type], [0, 4, 10],
    '4'],
{ PARAMETER 11
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$titles = 1,
      p$network_address = 2,
      p$transport_selector = 3,
      p$session_selector = 4,
      p$presentation_selector = 5,
      p$priority = 6,
      p$data = 7,
      p$title_identifier = 8,
      p$network_service = 9,
      p$transport_class = 10,
      p$status = 11;

    VAR
      pvt: array [1 .. 11] of clt$parameter_value;

    VAR
      address_header: ^osi_address_header,
      address_length: nat$osi_address_length,
      directory_identifier: nat$directory_entry_identifier,
      domain: nat$title_domain,
      network_address: ^osi_network_address,
      network_application_management: boolean,
      osi_address: nat$osi_registration_address,
      priority: nat$directory_priority,
      protocol: nat$protocol,
      psap_selector: ^osi_presentation_selector,
      ssap_selector: ^osi_session_selector,
      title: ^string ( * ),
      title_value: ^clt$data_value,
      transport_selector: ^osi_transport_selector,
      user_data: ^string ( * ),
      user_data_length: 0 .. nac$max_directory_data_length,
      user_identifier: ost$name;

?? NEWTITLE := '  check_hex_string_parameters', EJECT ??

    PROCEDURE check_hex_string_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
        i: integer,
        legal_hex_characters: [STATIC, READ] set of char := ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
              'A', 'B', 'C', 'D', 'E', 'F', 'a', 'b', 'c', 'd', 'e', 'f'],
        parameter_length: integer,
        parameter_value: ^string ( * );

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$network_address =
          parameter_value := pvt [p$network_address].value^.string_value;

        = p$transport_selector =
          parameter_value := pvt [p$transport_selector].value^.string_value;

        = p$session_selector =
          parameter_value := pvt [p$session_selector].value^.string_value;

        = p$presentation_selector =
          parameter_value := pvt [p$presentation_selector].value^.string_value;

        ELSE
          RETURN;
        CASEND;

        parameter_length := STRLENGTH (parameter_value^);
        IF parameter_length MOD 2 = 1 THEN
          osp$set_status_condition (nae$even_char_count_required, status);
          osp$append_status_integer (osc$status_parameter_delimiter, parameter_length, 10, FALSE, status);
        ELSE
          FOR i := 1 TO parameter_length DO
            IF NOT (parameter_value^ (i, 1) IN legal_hex_characters) THEN
              osp$set_status_abnormal (nac$status_id, nae$invalid_hex_digit, parameter_value^ (i, 1), status);
              RETURN;
            IFEND;
          FOREND;
        IFEND;
      IFEND;

    PROCEND check_hex_string_parameters;

?? OLDTITLE ??
?? NEWTITLE := '  convert_hex_string_to_binary', EJECT ??

    PROCEDURE convert_hex_string_to_binary
      (    hex_string: string ( * );
       VAR binary: string ( * ));

      FUNCTION convert
        (    hex_digit: char): 0 .. 128;

        CASE hex_digit OF
        = '0' .. '9' =
          convert := $INTEGER (hex_digit) - $INTEGER ('0');
        = 'A' .. 'F' =
          convert := $INTEGER (hex_digit) - $INTEGER ('A') + 10;
        = 'a' .. 'f' =
          convert := $INTEGER (hex_digit) - $INTEGER ('a') + 10;
        ELSE
          convert := 0;
        CASEND;

      FUNCEND convert;

      VAR
        binary_index: integer,
        hex_index: integer;

      hex_index := 1;
      binary_index := 1;
      WHILE hex_index < STRLENGTH (hex_string) DO
        binary (binary_index) := $CHAR ((convert (hex_string (hex_index)) * 16) +
              convert (hex_string (hex_index + 1)));
        hex_index := hex_index + 2;
        binary_index := binary_index + 1;
      WHILEND;

    PROCEND convert_hex_string_to_binary;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_hex_string_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$get_capability (avc$network_applic_management, avc$user, network_application_management, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT network_application_management THEN
      osp$set_status_abnormal (nac$status_id, nae$invalid_user, 'ADD_OSI_ADDRESS', status);
      RETURN;
    IFEND;

{ Determine protocol value based on transport class and network service type.

    IF pvt [p$network_service].value^.keyword_value = 'CONNECTION_LESS_NET_SERVICE' THEN
      IF pvt [p$transport_class].value^.integer_value.value < 4 THEN
        osp$set_status_condition (nae$transport_network_mismatch, status);
        RETURN;
      IFEND;
      IF NOT pvt [p$presentation_selector].specified THEN
        protocol := nac$non_cdna_osi_sess_tp4_clns;
      ELSE
        protocol := nac$non_cdna_osi_pres_tp4_clns;
      IFEND;
    ELSE {'CONNECTION_ORIENTED_NET_SERVICE'
      CASE pvt [p$transport_class].value^.integer_value.value OF
      = 0, 1 =
        protocol := nac$non_cdna_osi_pres_tp0_cons;
      = 2, 3 =
        protocol := nac$non_cdna_osi_pres_tp2_cons;
      = 4 =
        protocol := nac$non_cdna_osi_pres_tp4_cons;
      CASEND;
    IFEND;

{ Compute length of address sequence.

    address_length := (STRLENGTH (pvt [p$network_address].value^.string_value^) +
          STRLENGTH (pvt [p$transport_selector].value^.string_value^) +
          STRLENGTH (pvt [p$session_selector].value^.string_value^)) DIV 2 +
          (#SIZE (nat$osi_network_address_length) + #SIZE (nat$osi_tsap_selector_length) +
          #SIZE (nat$osi_ssap_selector_length));
    IF pvt [p$presentation_selector].specified THEN
      address_length := address_length + (STRLENGTH (pvt [p$presentation_selector].value^.string_value^) DIV
            2) + #SIZE (nat$osi_psap_selector_length);
    IFEND;

    PUSH osi_address.osi_address: [[REP address_length + #SIZE (osi_address_header) OF cell]];
    RESET osi_address.osi_address;
    NEXT address_header IN osi_address.osi_address;
    address_header^.length := address_length;
    IF pvt [p$presentation_selector].specified THEN
      address_header^.kind := nac$osi_non_cdna_present_addr;
      osi_address.kind := nac$osi_non_cdna_present_addr;
      NEXT psap_selector: [STRLENGTH (pvt [p$presentation_selector].value^.string_value^) DIV 2] IN
            osi_address.osi_address;
      psap_selector^.length := STRLENGTH (pvt [p$presentation_selector].value^.string_value^) DIV 2;
      convert_hex_string_to_binary (pvt [p$presentation_selector].value^.string_value^, psap_selector^.value);
    ELSE
      address_header^.kind := nac$osi_non_cdna_session_addr;
      osi_address.kind := nac$osi_non_cdna_session_addr;
    IFEND;
    NEXT ssap_selector: [STRLENGTH (pvt [p$session_selector].value^.string_value^) DIV 2] IN
          osi_address.osi_address;
    ssap_selector^.length := STRLENGTH (pvt [p$session_selector].value^.string_value^) DIV 2;
    convert_hex_string_to_binary (pvt [p$session_selector].value^.string_value^, ssap_selector^.value);
    NEXT transport_selector: [STRLENGTH (pvt [p$transport_selector].value^.string_value^) DIV 2] IN
          osi_address.osi_address;
    transport_selector^.tsap_length := STRLENGTH (pvt [p$transport_selector].value^.string_value^) DIV 2;
    convert_hex_string_to_binary (pvt [p$transport_selector].value^.string_value^, transport_selector^.tsap);
    NEXT network_address: [STRLENGTH (pvt [p$network_address].value^.string_value^) DIV 2] IN
          osi_address.osi_address;
    network_address^.network_address_length := STRLENGTH (pvt [p$network_address].value^.string_value^) DIV 2;
    convert_hex_string_to_binary (pvt [p$network_address].value^.string_value^,
          network_address^.network_address);

    domain.kind := nac$local_system_domain;
    priority := pvt [p$priority].value^.integer_value.value;
    title_value := pvt [p$titles].value;
    IF pvt [p$data].specified THEN
      user_data := pvt [p$data].value^.string_value;
      user_data_length := #SIZE (user_data^);
    ELSE
      user_data := NIL;
      user_data_length := 0;
    IFEND;
    IF pvt [p$title_identifier].specified THEN
      user_identifier := pvt [p$title_identifier].value^.name_value;
    ELSE
      user_identifier := osc$null_name;
    IFEND;

    WHILE title_value <> NIL DO
      IF title_value^.element_value^.kind = clc$name THEN
        title := ^title_value^.element_value^.name_value;
      ELSE {title_value^.element_value^.kind = clc$string
        title := title_value^.element_value^.string_value;
      IFEND;
      nlp$register_title (title^, osi_address, protocol, user_data, user_data_length, priority,
            domain, {distribute =} FALSE, nac$cdna_external, default_password, user_identifier,
            directory_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      title_value := title_value^.link;
    WHILEND;
  PROCEND nap$add_osi_address;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$delete_osi_address', EJECT ??

{ PURPOSE: This procedure processes the DELETE_OSI_ADDRESS command, which deletes a non-CDNA
{          OSI address in the CDNA Directory.
{ DESIGN:  The command parameters are parsed and validated. The Directory is searched for the
{          entry or entries with the requested title identifier. They are then deleted.

  PROCEDURE [XDCL] nap$delete_osi_address
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (nam$delosia) delete_osi_addresses, delete_osi_address, delosia (
{  title_identifier, ti: name = $required
{  status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 12, 7, 10, 29, 32, 280],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'NAM$DELOSIA'], [
    ['STATUS                         ',clc$nominal_entry, 2],
    ['TI                             ',clc$abbreviation_entry, 1],
    ['TITLE_IDENTIFIER               ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$title_identifier = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      address: nat$osi_translation_address,
      directory_identifier: nat$directory_entry_identifier,
      local_domain: nat$title_domain,
      local_status: ost$status,
      network_application_management: boolean,
      priority: nat$directory_priority,
      protocol: nat$protocol,
      request_id: nat$directory_search_identifier,
      user_information: SEQ (REP nac$max_directory_data_length of cell),
      title: string (nac$max_title_length),
      title_found: boolean,
      user_identifier: ost$name,
      user_info_length: 0 .. nac$max_directory_data_length;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$get_capability (avc$network_applic_management, avc$user, network_application_management, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT network_application_management THEN
      osp$set_status_abnormal (nac$status_id, nae$invalid_user, 'DELETE_OSI_ADDRESS', status);
      RETURN;
    IFEND;

    local_domain.kind := nac$local_system_domain;
    nlp$translate_title (wild_card_title, {wild_card=} TRUE, nac$unknown_protocol, {recurrent_search=}
          FALSE, local_domain, nac$cdna_external, request_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    title_found := FALSE;

  /search_for_identifier/
    REPEAT
      nlp$get_title_translation (request_id, title, address, protocol, ^user_information, user_info_length,
            priority, user_identifier, directory_identifier, local_status);
      IF (local_status.normal) AND (user_identifier = pvt [p$title_identifier].value^.name_value) AND
            ((address.kind = nac$osi_non_cdna_present_addr) OR (address.kind = nac$osi_non_cdna_session_addr))
            THEN
        title_found := TRUE;
        nlp$delete_registered_title (title, default_password, directory_identifier, status);
        IF NOT status.normal THEN
          EXIT /search_for_identifier/;
        IFEND;
      IFEND;
    UNTIL NOT local_status.normal; {/search_for_identifier/}

    nlp$end_title_translation (request_id, {ignore} local_status);
    IF NOT title_found THEN
      osp$set_status_abnormal (nac$status_id, nae$unknown_identifier,
            pvt [p$title_identifier].value^.name_value, status);
    IFEND;

  PROCEND nap$delete_osi_address;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$display_osi_address', EJECT ??

{ PURPOSE: This procedure processes the DISPLAY_OSI_ADDRESS command, which displays non-CDNA
{          OSI addresses in the CDNA Directory. Translations of these addresses are available
{          only to entities in the local system.
{ DESIGN:  The command parameters are parsed and validated. The information registered for the
{          specified titles is displayed to the requested output file.

  PROCEDURE [XDCL] nap$display_osi_address
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (nam$disosia) display_osi_addresses, display_osi_address, disosia (
{ titles, title, t: list of any of key
{       all
{     keyend
{     string 1 .. 255
{     name
{   anyend = all
{ output, o: file = $output
{ status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$string_type_qualifier,
          recend,
          type_size_3: clt$type_specification_size,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 16, 11, 47, 52, 105],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'NAM$DISOSIA'], [
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['T                              ',clc$abbreviation_entry, 1],
    ['TITLE                          ',clc$alias_entry, 1],
    ['TITLES                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 97,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [81, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type, clc$string_type],
      FALSE, 3],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      8, [[1, 0, clc$string_type], [1, 255, FALSE]],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$titles = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      address: nat$osi_translation_address,
      address_header: ^osi_address_header,
      address_length: nat$osi_address_length,
      default_ring_attributes: amt$ring_attributes,
      directory_identifier: nat$directory_search_identifier,
      display_control: clt$display_control,
      line: string (nac$max_title_length + 40),
      line_length: integer,
      local_domain: nat$title_domain,
      local_status: ost$status,
      network_address: ^SEQ ( * ),
      network_address_value: ^string ( * ),
      network_application_management: boolean,
      network_service: string (20),
      priority: nat$directory_priority,
      protocol: nat$protocol,
      psap_selector: ^osi_presentation_selector,
      request_id: nat$directory_search_identifier,
      ssap_selector: ^osi_session_selector,
      title: ^clt$data_value,
      title_found: boolean,
      title_string: ^string ( * ),
      title_value: string (nac$max_title_length),
      transport_class: 0 .. 4,
      transport_selector: ^osi_transport_selector,
      user_identifier: ost$name,
      user_info: ^SEQ (REP nac$max_directory_data_length of cell),
      user_information: SEQ (REP nac$max_directory_data_length of cell),
      user_information_value: ^string ( * ),
      user_info_length: 0 .. nac$max_directory_data_length,
      wild_card: boolean;

?? NEWTITLE := '  convert_string_to_hex_digits', EJECT ??

    PROCEDURE convert_string_to_hex_digits
      (    input_string: string ( * );
       VAR output_string { input, output } : string ( * );
       VAR output_index { input, output } : integer);

      VAR
        data_index: integer;

      FOR data_index := 1 TO STRLENGTH (input_string) DO
        output_string (output_index) := hex_digits [$INTEGER (input_string (data_index)) DIV 16];
        output_string (output_index + 1) := hex_digits [$INTEGER (input_string (data_index)) MOD 16];
        output_index := output_index + 2;
      FOREND;
      output_string (output_index) := ' ';

    PROCEND convert_string_to_hex_digits;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$get_capability (avc$network_applic_management, avc$user, network_application_management, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT network_application_management THEN
      osp$set_status_abnormal (nac$status_id, nae$invalid_user, 'DISPLAY_OSI_ADDRESS', status);
      RETURN;
    IFEND;

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
    clp$open_display_reference (pvt [p$output].value^.file_value^, ^generate_headers, fsc$list,
          default_ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_domain.kind := nac$local_system_domain;
    title := pvt [p$titles].value;
    WHILE title <> NIL DO
      CASE title^.element_value^.kind OF
      = clc$name =
        title_string := ^title^.element_value^.name_value;
        wild_card := FALSE;
      = clc$string =
        title_string := title^.element_value^.string_value;
        wild_card := FALSE;
      ELSE { = clc$keyword = }
        title_string := ^wild_card_title;
        wild_card := TRUE;
      CASEND;

      nlp$translate_title (title_string^, wild_card, nac$unknown_protocol, {recurrent_search=} FALSE,
            local_domain, nac$cdna_external, request_id, status);
      IF NOT status.normal THEN
        clp$close_display (display_control, {ignore} local_status);
        RETURN;
      IFEND;

      title_found := FALSE;

      REPEAT
        nlp$get_title_translation (request_id, title_value, address, protocol, ^user_information,
              user_info_length, priority, user_identifier, directory_identifier, local_status);
        IF local_status.normal AND ((address.kind = nac$osi_non_cdna_present_addr) OR
              (address.kind = nac$osi_non_cdna_session_addr)) THEN
          title_found := TRUE;
          STRINGREP (line, line_length, '   Title:                    ', title_value);
          clp$put_display (display_control, line (1, line_length), clc$trim, status);
          IF NOT status.normal THEN
            clp$close_display (display_control, {ignore} local_status);
            RETURN;
          IFEND;
          CASE address.kind OF
          = nac$osi_non_cdna_present_addr =
            line := '     Network_address: ';
            line_length := 30;
            network_address := ^address.osi_presentation_address.network_address;
            RESET network_address;
            NEXT network_address_value: [address.osi_presentation_address.network_address_length] IN
                  network_address;
            convert_string_to_hex_digits (network_address_value^, line, line_length);
            clp$put_display (display_control, line (1, line_length), clc$trim, {ignore} status);

            line := '     Transport_selector: ';
            line_length := 30;
            IF address.osi_presentation_address.transport_selector_length > 0 THEN
              convert_string_to_hex_digits (address.osi_presentation_address.
                    transport_selector (1, address.osi_presentation_address.transport_selector_length), line,
                    line_length);
            ELSE
              line (line_length, 4) := 'None';
              line_length := line_length + 4;
            IFEND;
            clp$put_display (display_control, line (1, line_length), clc$trim, {ignore} status);

            line := '     Session_selector: ';
            line_length := 30;
            IF address.osi_presentation_address.session_selector_length > 0 THEN
              convert_string_to_hex_digits (address.osi_presentation_address.
                    session_selector (1, address.osi_presentation_address.session_selector_length), line,
                    line_length);
            ELSE
              line (line_length, 4) := 'None';
              line_length := line_length + 4;
            IFEND;
            clp$put_display (display_control, line (1, line_length), clc$trim, {ignore} status);

            line := '     Presentation_selector: ';
            line_length := 30;
            IF address.osi_presentation_address.presentation_selector_length > 0 THEN
              convert_string_to_hex_digits (address.osi_presentation_address.
                    presentation_selector (1, address.osi_presentation_address.presentation_selector_length),
                    line, line_length);
            ELSE
              line (line_length, 4) := 'None';
              line_length := line_length + 4;
            IFEND;
            clp$put_display (display_control, line (1, line_length), clc$trim, {ignore} status);

          = nac$osi_non_cdna_session_addr =
            line := '     Network_address: ';
            line_length := 30;
            network_address := ^address.osi_session_address.network_address;
            RESET network_address;
            NEXT network_address_value: [address.osi_session_address.network_address_length] IN
                  network_address;
            convert_string_to_hex_digits (network_address_value^, line, line_length);
            clp$put_display (display_control, line (1, line_length), clc$trim, {ignore} status);

            line := '     Transport_selector: ';
            line_length := 30;
            IF address.osi_session_address.transport_selector_length > 0 THEN
              convert_string_to_hex_digits (address.osi_session_address.
                    transport_selector (1, address.osi_session_address.transport_selector_length), line,
                    line_length);
            ELSE
              line (line_length, 4) := 'None';
              line_length := line_length + 4;
            IFEND;
            clp$put_display (display_control, line (1, line_length), clc$trim, {ignore} status);

            line := '     Session_selector: ';
            line_length := 30;
            IF address.osi_session_address.session_selector_length > 0 THEN
              convert_string_to_hex_digits (address.osi_session_address.
                    session_selector (1, address.osi_session_address.session_selector_length), line,
                    line_length);
            ELSE
              line (line_length, 4) := 'None';
              line_length := line_length + 4;
            IFEND;
            clp$put_display (display_control, line (1, line_length), clc$trim, {ignore} status);

          ELSE
          CASEND;

          clp$put_partial_display (display_control, '     Data:                   ', clc$no_trim, amc$start,
                {ignore} status);
          IF user_info_length > 0 THEN
            user_info := ^user_information;
            RESET user_info;
            NEXT user_information_value: [user_info_length] IN user_info;
            clp$put_partial_display (display_control, user_information_value^, clc$trim, amc$terminate,
                  {ignore} status);
          ELSE
            clp$put_partial_display (display_control, 'None', clc$trim, amc$terminate, {ignore} status);
          IFEND;
          STRINGREP (line, line_length, '     Priority:              ', priority);
          clp$put_display (display_control, line (1, line_length), clc$trim, {ignore} status);
          STRINGREP (line, line_length, '     Title_identifier:       ', user_identifier);
          clp$put_display (display_control, line (1, line_length), clc$trim, {ignore} status);
          transport_class := 4;
          network_service := ' Connection_oriented';
          CASE protocol OF
          = nac$non_cdna_osi_pres_tp0_cons =
            transport_class := 0;
          = nac$non_cdna_osi_pres_tp2_cons =
            transport_class := 2;
          = nac$non_cdna_osi_pres_tp4_cons =
            ;
          = nac$non_cdna_osi_sess_tp4_clns, nac$non_cdna_osi_pres_tp4_clns =
            network_service := ' Connection_less';
          CASEND;
          STRINGREP (line, line_length, '     Transport_class:       ', transport_class);
          clp$put_display (display_control, line (1, line_length), clc$trim, {ignore} status);
          STRINGREP (line, line_length, '     Network_service:       ', network_service);
          clp$put_display (display_control, line (1, line_length), clc$trim, {ignore} status);
        IFEND;
      UNTIL NOT local_status.normal;

      nlp$end_title_translation (request_id, {ignore} local_status);
      IF NOT title_found THEN
        IF wild_card THEN
          osp$set_status_condition (nae$empty_osi_title_list, status);
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$unknown_osi_title, title_string^, status);
        IFEND;
      IFEND;
      title := title^.link;
    WHILEND;

    clp$close_display (display_control, {ignore} local_status);

  PROCEND nap$display_osi_address;
?? OLDTITLE ??
?? NEWTITLE := 'generate_headers', EJECT ??

{ PURPOSE: This procedure formats a page header for DISOSIA output.
{ DESIGN:  This procedure is called by the clp$display... routines when a page header
{          is needed.

  PROCEDURE generate_headers
    (VAR display_control: {input,output} clt$display_control;
         page_number: integer;
     VAR status: ost$status);

    CONST
      date_length = 18,
      long_date_start = 91,
      long_header_length = 132,
      long_os_version_start = 48,
      long_page_number_start = 127, {includes leading blank}
      long_page_title_start = 123,
      long_product_level_start = 85,
      long_product_name_start = 55,
      long_product_version_start = 78,
      long_time_start = 110,
      os_version_length = 6,
      page_number_length = 5, {includes leading blank}
      product_name = 'DISPLAY OSI ADDRESSES',
      product_level_length = 5,
      product_name_length = 21,
      product_version_length = 4,
      short_date_start = 1,
      short_header_length = 80,
      short_os_version_start = 20,
      short_page_number_start = 66, {includes leading blank}
      short_page_title_start = 62,
      short_product_level_start = 57,
      short_product_name_start = 27,
      short_product_version_start = 52,
      short_time_start = 49,
      time_length = 12;

    VAR
      date: ost$date,
      date_line: 1 .. 2,
      date_start: 0 .. long_header_length,
      header: array [1 .. 2] of string (long_header_length),
      header1_length: 0 .. long_header_length,
      header2_length: 0 .. long_header_length,
      j: integer,
      os_version: pmt$os_name,
      page_number_start: 0 .. long_header_length,
      str: string (10),
      time: ost$time,
      time_line: 1 .. 2,
      time_start: 0 .. long_header_length;

    pmp$get_legible_date_time (osc$default_date, date, osc$default_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$get_os_version (os_version, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    header [1] := ' ';
    header [2] := ' ';
    IF (display_control.page_width < long_header_length) THEN
      header1_length := short_header_length;
      header2_length := short_header_length;
      page_number_start := short_page_number_start;
      header [2] (short_os_version_start, os_version_length) := os_version;
      date_line := 2;
      date_start := short_date_start;
      time_line := 1;
      time_start := short_time_start;
      header [2] (short_product_name_start, product_name_length) := product_name;
      header [2] (short_product_version_start, product_version_length) := command_version;
      header [2] (short_product_level_start, product_level_length) := command_level;
      header [1] (short_page_title_start, 4) := 'PAGE';
    ELSE
      header1_length := long_header_length;
      page_number_start := long_page_number_start;
      header [1] (long_os_version_start, os_version_length) := os_version;
      date_line := 1;
      date_start := long_date_start;
      time_line := 1;
      time_start := long_time_start;
      header [1] (long_product_name_start, product_name_length) := product_name;
      header [1] (long_product_version_start, product_version_length) := command_version;
      header [1] (long_product_level_start, product_level_length) := command_level;
      header [1] (long_page_title_start, 4) := 'PAGE';
      header2_length := 0;
    IFEND;

    CASE date.date_format OF
    = osc$month_date =
      header [date_line] (date_start, date_length) := date.month;

    = osc$mdy_date =
      header [date_line] (date_start, date_length) := date.mdy;

    = osc$iso_date =
      header [date_line] (date_start, date_length) := date.iso;

    = osc$dmy_date =
      header [date_line] (date_start, date_length) := date.dmy;

    ELSE
    CASEND;

    CASE time.time_format OF
    = osc$ampm_time =
      header [time_line] (time_start, time_length) := time.ampm;

    = osc$hms_time =
      header [time_line] (time_start, time_length) := time.hms;

    = osc$millisecond_time =
      header [time_line] (time_start, time_length) := time.millisecond;

    ELSE
    CASEND;
    clp$reset_for_next_display_page (display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (str, j, page_number);
    header [1] (page_number_start, j) := str (1, j);
    clp$put_display (display_control, header [1], clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (header2_length > 0) THEN
      clp$put_display (display_control, header [2], clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND generate_headers;
?? OLDTITLE ??
MODEND nam$manage_non_cdna_addresses;
*DECK DECK=NAM$MDI_DRIVER EXPAND=TRUE
          IDENT  NETW,0
          CIPPU  J
          TITLE  NAM$MDI DRIVER (NETW).
          COMMENT *SMD* LVL=01
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4,10
***       NETW - NETWORK DRIVER.
*         J. A. NAUMAN.  82/10/23.
*         J. P. KELLER.  83/2/3.
          SPACE  4,30
***       NETW PROVIDES FOR COMMUNICATION BETWEEN NAM/VE AND A MAINFRAME DEVICE
*         INTERFACE.  NETW COMMUNICATES THROUGH A C170 CHANNEL TO THE MCI
*         HARDWARE.  THE STATUS OF THE MCI INTERFACE CAN BE DETERMINED FROM THE
*         GENERAL STATUS.  THE GENERAL STATUS WILL INDICATE WHICH OF 5 POSSIBLE
*         STATES THE MCI INTERFACE IS IN.  THE 5 STATES ARE:  MFI RESET,
*         DIAGNOSTICS, STARTING, LOADING, OPERATIONAL.  TRANSITIONS OUT OF ANY
*         OF THESE STATES CAN OCCUR AT ANY TIME.  DATA TRANSFER IS ALLOWED ONLY
*         IN LOADING OR OPERATIONAL STATES.  DATA TRANSFER TO THE MDI IS
*         INITIATED VIA A WRITE BYTES (CHANNELNET RECORD) OR WRITE RECORD
*         (CHANNEL CONNECTION RECORD) REQUEST IN THE UNIT QUEUE.  THE REQUEST
*         IS TERMINATED WITH THE STANDARD RESPONSE INDICATING SUCCESS OR
*         FAILURE, AND THEN DELINKED FROM THE CHAIN.  DATA TRANSFER FROM THE
*         MDI IS INITIATED BY THE MDI SETTING THE DATA-AVAILABLE BIT IN GENERAL
*         STATUS.  THE STATE BITS IN GENERAL STATUS ARE ALSO USED TO INDICATE
*         THE TYPE OF DATA TO BE READ (CHANNELNET OR CHANNEL CONNECTION).  WHEN
*         TRANSFERRING DATA TO CM THE PP OBTAINS CM BUFFERS OUT OF THE BUFFER
*         POOLS SET UP BY THE CP.  MULTIPLE POOLS ALLOW THE PP TO SELECT
*         BUFFERS IN A MANNER WHICH MINIMIZES MESSAGE FRAGMENTATION AND
*         MAXIMIZES BUFFER UTILIZATION.  NOTE THAT IF THE NUMBER OF BUFFER
*         SIZES IS INCREASED BEYOND 2 THE EQUATE *MAXBPD* MUST BE CHANGED.
*
*         NETW UTILIZES THE OVERLAY CAPABILITY OF NOS/VE WHICH PASSES A POINTER
*         TO THE OVERLAYS IN THE PP COMMUNICATION BUFFER. THE OVERLAYS ARE
*         ARRANGED SUCH THAT OVERLAYS 1 AND 2 ARE THE OVERLAYS NORMALY LOADED
*         IN OPERATIONAL STATE. THE OTHER OVERLAYS ARE ONLY LOADED DURING MDI
*         STATE CHANGES, PP REQUESTS, AND ERROR RECOVERY.

          TITLE  MACROS.
***       MACRO DEFINITIONS.
*
          SPACE  4,10
 SUBR     SPACE  4
***       SUBR - DEFINE SUBROUTINE ENTRY/EXIT LINE.
*
*
*NAME     SUBR
*         DECLARE *NAME* TO BE THE ENTRY POINT TO A PP SUBROUTINE.
*         THIS SUBROUTINE IS ENTERED VIA RETURN JUMP TO *NAME*.
*
*         THE FOLLOWING CODE IS GENERATED -
*NAMEX    LJM    *
*NAME     EQU    *-1


          PURGMAC  SUBR

          MACRO  SUBR,A
A_X LJM *
A EQU *-1
  ENDM
          SPACE  4,10
*copy iodmac1
*copy iodmac4
*copy iodmac5
          SPACE  4,10
*************************************************************************
*                                                                       *
*  THE OP MACRO IS REDEFINED HERE, THE VERSION FROM IODMAC4 IS NOT USED.*
*                                                                       *
*************************************************************************
** NAME-- AJM,SCF,IJM,CCF,FJM,SFM,EJM,CFM,IAN,IAM,OAN,OAM,ACN,DCN
*         FAN,FNC,FSJM,FCJM,IAPM,OAPM,CMCH,CHCM
*
** PURPOSE-- REDEFINE I/O INSTRUCTIONS SO THAT THE ADDRESS OF CHANNEL
*            INSTRUCTIONS CAN BE SAVED IN A TABLE.
NEWOP     ECHO   ,OP=(AJM,SCF,IJM,DCN,FJM,SFM,EJM,CFM,IAN,IAM,OAN,OAM,AC
,N,FAN,FNC,FSJM,FCJM,IAPM,OAPM,CCF,CMCH,CHCM)
*
          PURGMAC OP
OP        MACRO  P1,P2
          LOCAL  TAG
L         IFC    EQ,$P2$$
TAG       EQU    *O
          OP_.   P1
T_P1      RMT                IAN,OAN,ACN,DCN,FAN
          CON    TAG
          RMT
L         ELSE
TAG       EQU    *O
          OP_.   P1,P2
T_P2      RMT                AJM,IJM,FJM,EJM,IAM,OAM,FCN,IAPM,OAPM,
                             SCF,CCF,SFM,CFM,FSJM,FCJM,CMCH,CHCM
          CON    TAG
          RMT
L         ENDIF
OP        ENDM
NEWOP     ENDD
          SPACE  4,10
**        LOADB - LOAD BYTE ADDRESS
*
*         THIS MACRO REFORMATS A CM ADDRESS AND LOADS IT
*         INTO THE A AND R REGISTERS. CM ADDRESS IS ADJUSTED
*         TO A WORD BOUNDARY AND STARTING BYTE OFFSET IS
*         DETERMINED AND SAVED IN -SBYOFF-.
*
*         CALLING SEQUENCE - LOADB CMR,INDEX
*             THE 2-WORD UNFORMATTED CM ADDRESS IS CONTAINED
*             IN THE LOCATIONS STARTING AT -CMR- INDEXED BY
*             -INDEX-. -INDEX- IS OPTIONAL.
*

 LOADB    MACRO  CMR,INDEX
          LDK    CMR
          IFC    NE,$INDEX$$
          ADD    INDEX
          ENDIF
          STDL   T2
          LDIL   T2
          STDL   T3
          AODL   T2
          LDIL   T2
          LPN    7
          STML   SBYOFF      STARTING BYTE OFFSET
          LDIL   T2
          SCN    7
          STDL   T4
          LDN    T3
          RJM    FORMA
          ENDM
 OVERFLOW SPACE  4,10
**        OVERFLOW - CHECK FOR OVERFLOW.
*
*         OVERFLOW  ADDR
*
*         REPORT AN OVERFLOW IF *+7 OVERLAPS *ADDR*.


          PURGMAC  OVERFLOW
 OVERFLOW MACRO  ADDR
          USE    OVERFLOW
          LIST   M
          ERRPL  *+7-ADDR    CODE OVERFLOWS INTO *ADDR*
          LIST   *
          ENDM
          TITLE  INTERFACE ERROR CODES.
**        INTERFACE ERROR CODES.
*


 E101     EQU    401B        PP REQUEST QUEUE LOCKWORD TIMEOUT
 E102     EQU    402B        UNIT REQUEST QUEUE LOCKWORD TIMEOUT
 E103     EQU    403B        UNIT LOCKWORD TIMEOUT
 E104     EQU    404B        CHANNEL LOCKWORD TIMEOUT
 E105     EQU    405B        BUFFER POOL LOCKWORD TIMEOUT
 E106     EQU    406B        UNIT HARDWARE RESERVE TIMEOUT
 E107     EQU    407B        CONTROLLER HARDWARE RESERVE TIMEOUT
 E201     EQU    1001B       RMA OF CHANNEL RESERVATION TABLE NOT
                             A WORD BOUNDARY
 E202     EQU    1002B       RMA OF UNIT ACTIVITY MASK NOT A
                             WORD BOUNDARY
 E203     EQU    1003B       RMA OF PP COMMUNICATION BUFFER NOT A
                             WORD BOUNDARY
 E204     EQU    1004B       RESERVED FIELD OF THE PP COMMUNICATION
                             BUFFER DESCRIPTOR IS NOT ZERO
 E205     EQU    1005B       RESERVED FIELD OF THE PP REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 E206     EQU    1006B       RMA OF NEXT PP NOT A WORD BOUNDARY
 E207     EQU    1007B       RESERVED FIELD OF THE PP RESPONSE
                             BUFFER DESCRIPTOR IS NOT ZERO
 E208     EQU    1010B       LOGICAL UNIT OF UNIT DESCRIPTOR NOT
                             IN SEQUENCE OR NOT IN RANGE
 E209     EQU    1011B       RMA OF UNIT INTERFACE TABLE NOT A
                             WORD BOUNDARY
 E20A     EQU    1012B       INVALID CHANNEL NUMBER SPECIFIED
                             IN UNIT DESCRIPTOR
 E20B     EQU    1013B       COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS OR NOT LONG ENOUGH
 E20C     EQU    1014B       RESERVED FIELD AFTER NUMBER OF
                             UNITS IS NOT ZERO
 E20D     EQU    1015B       RESERVED FIELD OF IN POINTER
                             IS NOT ZERO
 E20E     EQU    1016B       RESERVED FIELD OF OUT POINTER
                             IS NOT ZERO
 E20F     EQU    1017B       RESERVED FIELD OF LIMIT POINTER
                             IS NOT ZERO
 E210     EQU    1020B       INVALID PHYSICAL UNIT NUMBER
 E211     EQU    1021B       RMA OF INTERRUPT WORD NOT A WORD BOUNDARY
 E212     EQU    1022B       RMA OF CHANNEL INTERLOCK TABLE NOT A
                             WORD BOUNDARY
 E301     EQU    1401B       LOGICAL UNIT NUMBER NOT EQUAL TO LOGICAL
                             UNIT OF UNIT DESCRIPTOR
 E302     EQU    1402B       RMA OF MASTER CONTROL TABLE
                             NOT A WORD BOUNDARY
 E303     EQU    1403B       A RESERVED FIELD OF THE MASTER CONTROL TABLE
                             DESCRIPTOR IS NOT ZERO
 E304     EQU    1404B       RMA OF NEXT UNIT REQUEST
                             NOT A WORD BOUNDARY
 E305     EQU    1405B       RESERVED FIELD OF UNIT REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
 E306     EQU    1406B       INVALID UNIT TYPE
 E307     EQU    1407B       MASTER CONTROL TABLE LENGTH NOT A
                             MULTIPLE OF CM WORDS
 E308     EQU    1410B       MASTER CONTROL TABLE IS TOO SMALL
 E401     EQU    2001B       RMA OF NEXT REQUEST NOT A WORD BOUNDARY
 E402     EQU    2002B       REQUEST LENGTH NOT A MULTIPLE
                             OF EIGHT BYTES
 E403     EQU    2003B       REQUEST LENGTH IS LESS THAN FORTY BYTES
 E404     EQU    2004B       LOGICAL UNIT NUMBER NOT EQUAL TO LOGICAL
                             UNIT IN UNIT INTERFACE TABLE
 E405     EQU    2005B       RESERVED LINKAGE FIELD IS NOT ZERO
 E406     EQU    2006B       INVALID RECOVERY/INTERRUPT SELECTIONS
 E407     EQU    2007B       INVALID PRIORITY SELECTION
 E408     EQU    2010B       INVALID SECONDARY ADDRESS
 E501     EQU    2401B       INVALID COMMAND CODE
 E502     EQU    2402B       INVALID FLAG SELECTION
 E503     EQU    2403B       INVALID FUNCTION
 E504     EQU    2404B       FUNCTION NOT SUPPORTED BY HARDWARE
 E505     EQU    2405B       INVALID LENGTH SPECIFICATION
                             IN COMMAND
 E506     EQU    2406B       INVALID ADDRESS SPECIFICATION
                             IN COMMAND
 E507     EQU    2407B       INVALID LENGTH SPECIFICATION IN
                             INDIRECT LIST
 E508     EQU    2410B       INVALID ADDRESS SPECIFICATION
                             IN INDIRECT LIST
 E509     EQU    2411B       PP COMMAND NOT ALLOWED IN REQUEST
                             TO A UNIT
 E50A     EQU    2412B       INVALID SEQUENCE OF COMMANDS
 E50B     EQU    2413B       INVALID PARAMETER SPECIFICATION
                             (POOL READ OR COMPARE SWAP COMMANDS)
          TITLE  GENERAL EQUATES.
**        GENERAL EQUATES.
*


 CHN      EQU    15B         CHANNEL NUMBER
 DCLEN    EQU    2           LENGTH OF DIAGNOSTICS COMMAND READ
 END      EQU    7776B       END OF MEMORY
 FTRY     EQU    3           NUMBER OF RETRIES ON FUNCTION TIMEOUT
 LDS170   EQU    18          DETAILED STATUS LENGTH IN 12 BIT WORDS
 MAXCHN   EQU    1024D       MAX NUMBER OF CHANNEL FRAMES TO XFER IN DIAG STATE
 PKDCHN   EQU    8           NUMBER OF CHANNEL FRAMES TO XFER DURING READ/PACK (DIAG STATE)
 MDITYP   EQU    8           SPAA TYPE ENTRY FOR MDI
 MINLEN   EQU    1400B       MINIMUM LENGTH OF I/O BUFFER
 MAXBPD   EQU    2           MAXIMUM BUFFER POOL DESCRIPTORS
 MAXPR    EQU    3           MAXIMUM CONSECUTIVE PRIORITY REQUESTS

*         ALLOW FOR 6 BUFFERS PER MESSAGE. IF THIS IS CHANGED, A CORRESPONDING
*         CHANGE MUST BE MADE IN NAM$INTRANET_LAYER_MGMT_R3, PROCEDURE
*         PROCESS_UNSOLICITED_RESPONSE.

 MAXRS    EQU    12          MAXIMUM RESPONSE BUFFER SIZE (CM WORDS)
 MAXURQ   EQU    11          MAXIMUM UNIT REQUEST SIZE (CM WORDS)
 DRTYP    EQU    1           =1, IF MDI DRIVER
*                            =2, IF ICA DRIVER
 .INPN    EQU    102600B
 .SBN     EQU    1700B
 .SOML    EQU    105700B
 PRGNAM   MICRO  1,4,*NETW*

 DEBUG    EQU    0           =1, IF DEBUGGING CODE ON
 SIM      EQU    0           =1, IF RUNNING ON SIMULATOR
 BRK      EQU    0           =1, IF PP BREAKPOINT CODE IS ASSEMBLED
          SPACE  4,10
**        COMMAND CODES.
*


 C.ACK    EQU    0           ACKNOWLEDGE
 C.STOP   EQU    1           STOP UNIT
 C.SELU   EQU    2           SELECT UNIT
 C.SELC   EQU    3           SELECT CONTROLLER
 C.IDLE   EQU    4           IDLE
 C.RESUME EQU    5           RESUME
 C.RPM    EQU    6           READ PP MEMORY
 C.READY  EQU    7           START READY SCAN
 C.SREADY EQU    10B         STOP READY SCAN
 C.PPAD   EQU    11B         SELECT PP MEMORY ADDRESS
 C.PPMEM  EQU    12B         COPY PP MEMORY
 C.DEFBA  EQU    14B         DEFINE PP BKPT AREA IN CM
 C.FUNC   EQU    40B         OUTPUT FUNCTION
 C.OUTP   EQU    41B         OUTPUT 8-BIT PARAMETERS
 C.OUTD   EQU    43B         OUTPUT 8-BIT DATA
 C.IND    EQU    45B         INPUT 8-BIT DATA/PARAMETERS
 C.READ   EQU    100B        READ BYTES
 C.WRTB   EQU    120B        WRITE CHANNELNET RECORD
 C.WRTR   EQU    121B        WRITE CHANNEL CONNECTION RECORD
 C.STATUS EQU    140B        READ STATUS
 C.COUNT  EQU    141B        STORE TRANSFER COUNT
 C.RDY    EQU    165B        SYNCHRONIZE READY
 C.GFC    EQU    167B        GLOBAL FLOW CONTROL
 C.DBUG   EQU    170B        DEBUG MODE
 C.RESET  EQU    171B        RESET MCI
 C.WRITEV EQU    200B        WRITE VERIFY
          SPACE  4,10
**        DIAGNOSTIC COMMAND CODES.
*


 DC.TMRQ  EQU    1           TEST MODE REQUEST
 DC.DTPP  EQU    2           DATA TRANSFER TO PP REQUEST
 DC.RDPP  EQU    4           RETURN DATA FROM PP REQUEST
 DC.SBYP  EQU    10B         SET BYTE PACKING
 DC.RPBY  EQU    12B         READ + PACK BYTE DATA REQUEST
 DC.SBP   EQU    30B         SET BIT PACKING
 DC.RPBD  EQU    32B         READ + PACK BIT DATA REQUEST
          SPACE  4,10
**        MCI DIRECT FUNCTION CODES.
*


 F.MCLEAR EQU    0400B       MASTER CLEAR
 F.GS     EQU    0410B       GENERAL STATUS
 F.WRITE  EQU    0420B       WRITE DATA
 F.READ   EQU    0430B       READ DATA
 F.BITPM  EQU    0440B       BIT PACKING MODE
 F.BYTEPM EQU    0441B       BYTE PACKING MODE
          SPACE  4,10
**        MCI TRANSPARENT FUNCTION CODES.
*


 F.DS     EQU    0001B       DETAILED STATUS
 F.SHTDN  EQU    0002B       SHUT DOWN
 F.RERR   EQU    0003B       READ ERROR
 F.INTRES EQU    0004B       INTERFACE RESET
 F.STREG  EQU    0005B       START REGULATION
 F.SPREG  EQU    0006B       STOP REGULATION
 F.RQDIAG EQU    0007B       REQUEST DIAGNOSTICS
 F.RQDCMD EQU    0010B       REQUEST DIAGNOSTIC COMMAND
 F.DERR   EQU    0012B       DIAGNOSTIC ERROR DETECTED
 F.DMERR  EQU    0013B       DIAGNOSTIC MEMORY ERROR DETECTED
 F.ABDSEQ EQU    0015B       ABORT DIAGNOSTIC SEQUENCE
 F.USEBYT EQU    0021B       USE BYTE MODE TESTING
 F.USEBIT EQU    0022B       USE BIT MODE TESTING
 F.USEBOT EQU    0023B       USE BOTH BIT + BYTE MODE TESTING
 F.SETPV  EQU    0032B       SET PROTOCOL VERSION
 F.ILTO   EQU    0040B       IN-LINE TIMEOUT
 F.UNRM   EQU    0041B       UNABLE TO READ IN-LINE TEST MESSAGE
 F.NORM   EQU    0042B       NORMAL OPERATION
 F.FCON   EQU    0043B       FLOW CONTROL ON
 F.FCOFF  EQU    0044B       FLOW CONTROL OFF
 F.CCW    EQU    0045B       CHANNEL CONNECTION WRITE
 F.CNW    EQU    0046B       CHANNELNET WRITE
          SPACE  4,10
**        FUNCTIONS FOR CONCURRENT CHANNEL
*


 F.CCCLR  EQU    100000B     MASTER CLEAR
 F.WRCR   EQU    111000B     WRITE CONTROL REGISTER
 F.RDESR  EQU    112000B     READ ERROR STATUS REGISTER
 INITCR   EQU    400B        CONTROL REGISTER VALUE
          SPACE  4,10
**        GENERAL STATUS BIT DEFINITIONS.
*
          SPACE  4,10
 S.EXPERR EQU    0           EXPECTED ERROR OCCURRED (DIAGNOSTIC STATE ONLY)
 S.NORMFC EQU    0           NORMAL FLOW CONTROL
 S.EXPMER EQU    1           EXPECTED MEMORY ERROR (DIAGNOSTIC STATE ONLY)
 S.RQSYNC EQU    1           REQUEST SYNCHRONIZATION
 S.STATE1 EQU    3           STATE BIT
 S.STATE2 EQU    4           STATE BIT
 S.STATE3 EQU    5           STATE BIT
 S.OPER   EQU    6           OPERATIONAL BIT
 S.BUSY   EQU    7           BUSY BIT
 S.SEND   EQU    8           SEND DATA
 S.DATAV  EQU    9           DATA AVAILABLE
 S.MEMERR EQU    10          MEMORY ERROR
 S.ERROR  EQU    11          ERROR BIT
 S.VALID  EQU    15          SOFTWARE FLAG INDICATING ERROR BITS INVALID

 LDMESS   EQU    4B          LOADING STATE MESSAGE
 CNMESS   EQU    10B         GENERAL STATUS BIT 3-6, INDICATING CHANNELNET MESSAGE
 CCMESS   EQU    11B         GENERAL STATUS BIT 3-6, INDICATING CHANNEL CONNECTION MESSAGE
 ILMESS   EQU    15B         GENERAL STATUS BIT 3-6, INDICATING IN-LINE MESSAGE

 VALID    EQU    100000B     VALUE TO SET GENERAL STATUS VALID
 STBITS   EQU    170B        MASK FOR STATE BITS
          SPACE  4,10
**        DIAGNOSTIC ERROR STATUS EQUATES.
*
*         BITS 0-1 = GENERAL STATUS BITS 0-1,
*         BITS 2-3 = GENERAL STATUS BITS 10-11.
*


 EXER     EQU    4011B       EXPECTED ERROR
 EXME     EQU    6012B       EXPECTED MEMORY ERROR
          SPACE  4,10
**        DETAILED STATUS WORD OFFSETS
*


 DS.PROV  EQU    0           CHANNEL PROTOCOL VERSION
 DS.MPS   EQU    11          MAXIMUM PDU SIZE
          SPACE  4,10
**        IN-LINE DIAGNOSTICS TEST HEADER BIT DEFINITIONS.
*


 IL.RAREG EQU    0           READ NEXT MESSAGE USING A-REG I/O (NOT SUPPORTED)
 IL.RBLK  EQU    1           READ NEXT MESSAGE USING BLOCK I/O
 IL.WDLY  EQU    2           WRITE MESSAGE WITH DELAYS
 IL.WAREG EQU    3           WRITE MESSAGE USING A-REG I/O (NOT SUPPORTED)
 IL.WBLK  EQU    4           WRITE MESSAGE USING BLOCK I/O
 IL.DSCRD EQU    5           DISCARD MESSAGE
          SPACE  4,10
**        MDI DRIVER STATES.
*
          SPACE  2,10
 ST.MDIR  EQU    0           MDI RESET
 ST.DIAG  EQU    1           DIAGNOSTICS
 ST.STRT  EQU    3           STARTING
 ST.LOAD  EQU    4           LOADING
 ST.OPER  EQU    10B         OPERATIONAL
 ST.IDLE  EQU    11B         IDLE
 ST.ILD   EQU    12B         IN-LINE DIAGNOSTICS
 ST.PPR   EQU    13B         RESET BY PP
 ST.MDI   EQU    14B         RESET BY MDI
 ST.PPD   EQU    15B         DOWNED BY PP
          SPACE  4,10
***       WAIT TIMES IN MILLISECONDS.
*

 FTOLEN   EQU    20          FUNCTION TIMEOUT LENGTH
 GSBUSY   EQU    5000        MAXIMUM WAIT FOR NOT BUSY
 GSFULL   EQU    1           WAIT FOR FULL ON GENERAL STATUS
 WTDEACT  EQU    1           WAIT FOR CHANNEL TO DEACTIVATE
 WTEMPTY  EQU    1           MAXIMUM WAIT FOR CHANNEL EMPTY
 WTFULL   EQU    1           WAIT FOR CHANNEL FULL
 WTDAV    EQU    1000        WAIT FOR DATA AVAILABLE
 WTSD     EQU    1000        WAIT FOR SEND DATA AVAILABLE

          SPACE  4,10
**        BUFFER POOL STATUS CONDITIONS.
*

 BP.EMPTY EQU    0           BUFFER POOL IS OUT OF BUFFERS
 BP.THRSH EQU    1           BUFFER COUNT HAS FALLEN BELOW SPECIFIED THRESHOLD
 BP.GOOD  EQU    2           BUFFER POOL CONTAINS A SUFFICIENT NUMBER OF BUFFERS

          SPACE  4,10
***       FUNCTION TIMEOUT STATUS EQUATES.
*

 FTO.RC   EQU    0           RETRY COUNT
 FTO.SC   EQU    1           SYMPTOM CODE
          SPACE  4,10
**        RESPONSE CODES.
*


 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    1           INTERMEDIATE RESPONSE
 R.NRM    EQU    2           NORMAL REQUEST TERMINATION
 R.ABN    EQU    3           ABNORMAL REQUEST TERMINATION
          SPACE  4,10
**        RESPONSE CONDITIONS.
*


 RC.NONE  EQU    0           NO DETAILED STATUS
 RC.REC   EQU    1           DETAILED STATUS

          SPACE  4,10
**        BUFFER RETURN SEND STATE CONDITIONS.
*

 SS.CLOSE EQU    0           PP CANNOT SEND ANY MORE MESSAGES TO THE DEVICE (NOT USED)
 SS.OPEN  EQU    1           PP IS ABLE TO SEND MESSAGES TO THE DEVICE
          SPACE  4,10
**        UNSOLICITED RESPONSE CODES.
*
          SPACE  4,10
 URC.RN   EQU    1           CHANGE FROM READY TO MDI RESET
 URC.NR   EQU    2           CHANGE FROM NOT READY TO LOADING
 URC.IE   EQU    3           INTERNAL OR INTERFACE ERROR
 URC.RD   EQU    7           CHANNELNET READ RESPONSE
 URC.DE   EQU    8           DEVICE ERROR
 URC.LM   EQU    9           PP LOG MESSAGE
 URC.CR   EQU    13          CHANNEL CONNECTION READ RESPONSE
 URC.LO   EQU    14          CHANGE TO OPERATIONAL

          SPACE  4,10
***       ERROR RECOVERY SUCCESS CODES.
*
 REC.R    EQU    0           RECOVERED ERROR
 REC.U    EQU    1           UNRECOVERED ERROR
 REC.I    EQU    2           INTERMEDIATE ERROR
 REC.IM   EQU    3           INFORMATIVE MESSAGE
          SPACE  4,10
**        CHANNEL PROTOCOL EQUATES.
*

 PR.MIN   EQU    0#42        MINIMUM PROTOCOL SUPPORTED BY DRIVER
 PR.MAX   EQU    0#44        MAXIMUM PROTOCOL SUPPORTED BY DRIVER
 PR.BASE  EQU    0#80        BASE FOR PROTOCOL NEGOTIATION

          TITLE  CYBIL STRUCTURE DEFINITIONS.
**        PP INTERFACE TABLE.
*


 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
          ALIGN  0,64
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL INTERLOCK TABLE (RMA)
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER
          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)
          ALIGN  32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          SPACE  4,10
**        UNIT DESCRIPTORS.
*


 UD       RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 PORT     SUBRANGE 0,3       CHANNEL PORT NUMBER
 CNTRLR   SUBRANGE 0,77B     CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 UD       RECEND
          SPACE  4,10
**        UNIT INTERFACE TABLE.
*


 UIT      RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
                               = 400B, 844-4X
                               = 401B, 885-1X
                               = 402B, 885-42
 QCNT     PPWORD             QUEUE COUNT
*
          ALIGN  16,64
 MBUFL    PPWORD             MASTER CONTROL TABLE LENGTH
 MBUF     RMA                MASTER CONTROL TABLE (RMA)
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

 UIT      RECEND
          SPACE  4,10
**        PP REQUESTS.
*


 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON QUEUE (RMA)
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS
                               0 - ATTEMPT RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
 ALRT     PPWORD             ALERT MASK
          ALIGN  0,64
 SECADR   INTEGER            SECONDARY ADDRESS
 CMND     INTEGER            COMMAND SEQUENCE

 RQ       RECEND
          SPACE  4,10
**        PP COMMAND.
*


 CM       RECORD PACKED

 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$

 CM       RECEND
          SPACE  4,10
**        UNIT REQUESTS.
*


 URQ      RECORD PACKED

          ALIGN  16,64
 THISPV   STRUCT 6           THIS REQUEST ON UNIT QUEUE (PVA)
          ALIGN  0,64
 NEXTLN   PPWORD             LENGTH OF NEXT UNIT REQUEST
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 URQLEN   PPWORD             UNIT REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
          ALIGN  0,128       SKIP 6 PP WORDS (128=64*2)
 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)

*         THERE CAN BE 0, 1, OR MORE LENGTH/ADDRESS PAIRS.

          ALIGN  0,64
 MBLEN    PPWORD             MESSAGE BUFFER LENGTH (LENGTH/ADDRESS PAIR LIST)
          ALIGN  32,64
 MBRMA    RMA                MESSAGE BUFFER ADDRESS (LENGTH/ADDRESS PAIR LIST)

 URQ      RECEND
          SPACE  4,10
**        PP RESPONSE.
*


 RS       RECORD PACKED

          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 DEVID    SUBRANGE 0,377B    DEVICE IDENTIFIER
          ALIGN  48,64
 ALRT     PPWORD             ALERT MASK
          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE INTERFACE
                             ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
 CHERR    BOOLEAN            UNCORRECTABLE CHANNEL PARITY ERROR
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION
                             OCCURRED ON INPUT OR INADEQUATE DATA RATE ON OUTPUT
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A
                             HARDWARE MALFUNCTION.  EX: UNIT NOT READY,
                             UNIT NOT CONNECTED.
 FTO      BOOLEAN            FUNCTION TIMEOUT
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                               0 - NO DETAILED STATUS
                               1 - DETAILED STAUS
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE
                               1 - UNIT CHANGED FROM READY TO NOT READY
                               2 - UNIT CHANGED FROM NOT READY TO READY
                               3 - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
                               7 - MDI CHANNELNET READ COMPLETE
                               8 - MDI DEVICE ERROR
                               9 - LOG PP MESSAGE
                               13 - MDI CHANNEL CONNECTION READ COMPLETE
                               14 - UNIT CHANGED TO OPERATIONAL
                               15 - FLOW CONTROL STATUS CHANGE (NOT USED)
          ALIGN  49,64       ALERT CONDITIONS
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)

          ALIGN  0,64
 T1STAT   PPWORD             TYPE 1 STATUS (BUFFER POOL 1 STATUS)
 T2STAT   PPWORD             TYPE 2 STATUS (BUFFER POOL 2 STATUS)
 PSEND    PPWORD             PRIORITY SEND STATE (GLOBAL FLOW CONTROL)
 NSEND    PPWORD             NORMAL SEND STATE (GLOBAL FLOW CONTROL)

*         THERE CAN BE 0, 1, OR MORE LENGTH/ADDRESS PAIRS.

          ALIGN  0,64
 DLEN     PPWORD             DATA LENGTH OF BUFFER TO BE RETURNED
 BUFPVA   STRUCT 6           ADDRESS OF BUFFER TO BE RETURNED

 BITC     SET    P.LASTC*16
          ALIGN  0,64
 PROV     PPWORD             CHANNEL PROTOCOL VERSION
          ALIGN  32,64
 MAXRS    STRUCT 4           MAXIMUM RECORD SIZE
 ID       STRUCT 6

 BITC     SET    P.LASTC*16
          ALIGN  0,64
 ERRID    PPWORD             ERROR IDENTIFIERS
 OPTP     PPWORD             OPERATION TYPE
          ALIGN  32,64
*
*         SYMPTOM CODES
 LSGSE    BOOLEAN            GENERAL STATUS ERROR
 LSCEF    BOOLEAN            CHANNEL ERROR FLAG
 LSCD     BOOLEAN            CHANNEL DEACTIVATION ERROR
 LSMLV    BOOLEAN            MESSAGE LENGTH VERIFICATION
 LSCA     BOOLEAN            CHANNEL ACTIVE
 LSCF     BOOLEAN            CHANNEL FULL
 LSCE     BOOLEAN            CHANNEL EMPTY
 LSIT     BOOLEAN            INCOMPLETE TRANSFER
 LSMT     BOOLEAN            MESSAGE CONTENT ERROR
 LSMSE    BOOLEAN            MAXIMUM SIZE EXCEEDED
          ALIGN  47,64
 LSGSI    BOOLEAN            INTERNAL TO DRIVER ONLY
          ALIGN  48,64
 FUNTO    PPWORD             FUNCTION CODE IF FUNCTION TIMEOUT ERROR
 PFUNC    PPWORD             PREVIOUS FUNCTION
 CURST    PPWORD             CURRENT STATE
 P.ERRW1  EQU    P.CURST     ERROR WORD 1
 PREST    PPWORD             PREVIOUS STATE
 P.ERRW2  EQU    P.PREST     ERROR WORD 2
 GENST    PPWORD             GENERAL STATUS OF THE FIRST TIME ERROR
                               WAS ENCOUNTERED
 EXPD     STRUCT 4           EXPECTED MESSAGE LENGTH
 ACTD     STRUCT 4           ACTUAL MESSAGE LENGTH
 P.DATA1  EQU    P.EXPD      BYTES READ
 P.DATA2  EQU    P.ACTD      BYTES WRITTEN
 RETSUC   PPWORD             RETRY SUCCESS
*                            0 = RECOVERED ERROR
*                            1 = UNRECOVERED ERROR
*                            2 = INTERMEDIATE ERROR
*                            3 = INFORMATIVE MESSAGE
 RETCT    PPWORD             RETRY COUNT
 LDS      BOOLEAN            DETAIL STATUS INCLUDED
 LGS      BOOLEAN            GENERAL STATUS INCLUDED
 DICA     BOOLEAN            DOWN MDI
          ALIGN  48,64
 DETAIL   STRUCT 1           START OF DETAILED STATUS - MCI CHANNEL PROTOCOL ID
 SLOTNM   STRUCT 1           SLOT NUMBER
 SYSVER   PPWORD             SYSTEM VERSION
 SYSID    STRUCT 6           SYSTEM ID
 LSTOP    STRUCT 1           LAST I/O OPERATION
 LSTTFC   STRUCT 1           LAST TRANSPARENT FUNCTION
 LSTFUN   PPWORD             LAST FUNCTION
 LLFUN    PPWORD             LAST BUT ONE PP FUNCTION
 SUMFLG   SUBRANGE 0,17B     SUMMARY FLAGS
 MGENST   SUBRANGE 0,7777B   MCI GS AS KNOWN BY MCI SOFTWARE
 HWSTS1   STRUCT 1           MCI HW STATUS REGISTER 1
 HWSTS2   STRUCT 1           MCI HW STATUS REGISTER 3
 SOFTFG   PPWORD             SOFTWARE STATUS FLAGS
 RESERV   STRUCT 4           RESERVED FIELDS


          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$
          MASKP  INTERR
 K.INTERR EQU    MSK
          MASKP  DATOV
 K.DATOV  EQU    MSK
          MASKP  DATERR
 K.DATERR EQU    MSK
          MASKP  HDWR
 K.HDWR   EQU    MSK
          MASKP  CHERR
 K.CHERR  EQU    MSK
          MASKP  NRDY
 K.NRDY   EQU    MSK
          MASKP  FTO
 K.FTO    EQU    MSK

*         ERROR ID CODES.

 K.LFTO   EQU    1           FUNCTION TIMEOUT ERROR
 K.LGSBTO EQU    2           GENERAL STATUS BUSY TIME OUT
 K.LOF    EQU    3           OPERATION FAILURE
 K.LGSSDT EQU    4           GENERAL STATUS SEND DATA TIMEOUT
 K.LGSAT  EQU    5           GENERAL STATUS AVAILABLE TIMEOUT
 K.LGSCF  EQU    6           GENERAL STATUS CONTENT FAILURE
 K.LGSDAT EQU    7           GENERAL STATUS DATA AVAILABLE TIMEOUT
 K.LUD    EQU    8           USAGE DATA
 K.LIVST  EQU    9           INVALID STATE TRANSITION
 K.LMDIA  EQU    10          MDI AVAILABLE
 K.LMDIR  EQU    11          MDI RESET
 K.LPROER EQU    12          PROTOCOL NEGOTIATION ERROR
 K.LMCF   EQU    13          MASTER CLEAR FAILURE
 K.LMTE   EQU    15          MESSAGE TYPE ERROR

*         OPERATION CODES.

 K.LWRT   EQU    1           WRITE
 K.LREAD  EQU    2           READ
 K.LRDS   EQU    3           READ DETAILED STATUS
 K.LRDC   EQU    4           READ DIAGNOSTIC COMMAND
 K.LRGS   EQU    5           READ GENERAL STATUS
 K.LILWRT EQU    6           INLINE WRITE
          MASKP  LSGSE
 K.LSGSE  EQU    MSK
          MASKP  LSCEF
 K.LSCEF  EQU    MSK
          MASKP  LSCD
 K.LSCD   EQU    MSK
          MASKP  LSMLV
 K.LSMLV  EQU    MSK
          MASKP  LSCA
 K.LSCA   EQU    MSK
          MASKP  LSCF
 K.LSCF   EQU    MSK
          MASKP  LSCE
 K.LSCE   EQU    MSK
          MASKP  LSIT
 K.LSIT   EQU    MSK
          MASKP  LSMT
 K.LSMT   EQU    MSK
          MASKP  LSMSE
 K.LSMSE  EQU    MSK
          MASKP  LSGSI
 K.LSGSI  EQU    MSK
          MASKP  LDS
 K.LDS    EQU    MSK
          MASKP  LGS
 K.LGS    EQU    MSK
          MASKP  DICA
 K.DICA   EQU    MSK


 RS       RECEND
          SPACE  4,10
**        PPIT COMMUNICATION BUFFER.
*
*         THE MAXIMUM SIZE ALLOWED FOR COMMUNICATION BUFFER IS
*         *NAC$COMMUNICATION_BUFFER_SIZE* DEFINED IN DECK
*         NAM$INTRANET_LAYER_MGMT_R3

 CB       RECORD PACKED

          ALIGN  31,64
 SLAVE    BOOLEAN            NONZERO IF SLAVE PP
 PARTNR   RMA                PARTNER-S COMMUNICATION BUFFER (RMA)

          ALIGN  16,64
 CWLEN    PPWORD             LENGTH OF CONTROLWARE ADDRESS LIST
 CWRMA    RMA                ADDRESS OF FIRST ENTRY
          STRUCT 8           NOT USED
          ALIGN  32,64
 DRMA     RMA                OVERLAY DIRECTORY RMA
 CB       RECEND
          SPACE 4,10
**        IEEE 802.3 HEADER.
*

 H802.3   RECORD PACKED

 DADDR    STRUCT 6           DESTINATION ADDRESS
 SADDR    STRUCT 6           SOURCE ADDRESS
 DLEN     PPWORD             DATA LENGTH

 H802.3   RECEND
          SPACE 4,10
**        IEEE 802.2 HEADER.
*

 H802.2   RECORD PACKED

 DSAP     STRUCT 1           DESTINATION SAP
 SSAP     STRUCT 1           SOURCE SAP
 CNTRL    STRUCT 1           CONTROL FIELD

 H802.2   RECEND


 F1       EQU    B.H802.3*2+2
 F.H802.3 EQU    F1/3        CHANNEL FRAMES IN HEADER
          SPACE  4,10
**        CHANNEL CONNECTION HEADER.
*

 HCC      RECORD PACKED

 CCPDUH   STRUCT 4           CCPDU HEADER
 FILL     STRUCT 2           FUTURE LENGTH FIELD NOT SUPPORTED
 DLEN     STRUCT 2           LENGTH OF RECORD
 HCC      RECEND

 F2       EQU    B.HCC*2+2
 F.HCC    EQU    F2/3        CHANNEL FRAMES IN HEADER
          SPACE  4,10
**        HEADER DESCRIPTOR.
*
*         DESCRIPTOR OF DATA USED TO DESCRIBE THE HEADER CHARACTERISTICS
*         OF EACH RECORD TYPE SUPPORTED.

 HD       RECORD PACKED

 HLB      PPWORD             HEADER LENGTH IN BYTES
 HLC      PPWORD             HEADER LENGTH IN CHANNEL FRAMES
 ALF      PPWORD             OFFSET OF LENGTH FIELD IN HEADER
 ATL      PPWORD             ADD TO LENGTH IN HEADER
 RRC      PPWORD             READ RESPONSE CODE
 MRS      PPWORD             MAXIMUM RECORD SIZE

 HD       RECEND
          SPACE  4,10
**        UNIT QUEUE DESCRIPTOR.
*

 UQD      RECORD PACKED

 LEN      PPWORD             LENGTH OF THE HEAD OF THE SEND QUEUE
          ALIGN  32,64
 HEAD     RMA                ADDRESS OF HEAD OF THE SEND QUEUE (RMA)
          ALIGN  32,64
 TAIL     RMA                ADDRESS OF TAIL POINTER OF THE SEND QUEUE (RMA)

 UQD      RECEND
          SPACE  4,10
**        BUFFER POOL.
*

 BP       RECORD PACKED

          ALIGN  16,64
 PVA      STRUCT 6           PVA OF DESCRIPTOR (PVA)
          ALIGN  32,64
 RMA      RMA                RMA OF CONTAINER (RMA)

 BP       RECEND
          SPACE  4,10
**        BUFFER POOL DESCRIPTOR.
*

 BPD      RECORD PACKED

          ALIGN  32,64
 BTRMA    RMA                RMA OF BUFFER TABLE (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 CPUOUT   PPWORD             CPU OUT POINTER
          ALIGN  48,64
 PPOUT    PPWORD             PP OUT POINTER
 LEN      STRUCT 4           LENGTH OF EACH POOL BUFFER (CM BYTES)
 THRESH   PPWORD             MINIMUM NUMBER OF AVAILABLE BUFFERS ALLOWED
 LIMIT    PPWORD             LENGTH OF CIRCULAR BUFER (CM BYTES)

 BPD      RECEND
          SPACE  4,10
**        BUFFER POOL HEADER.
*

 BPH      RECORD PACKED

 BP1      STRUCT B.BPD       TYPE 1 BUFFER POOL
 BP2      STRUCT B.BPD       TYPE 2 BUFFER POOL

 BPH      RECEND
          SPACE  4,10
**        MASTER CONTROL TABLE.
*

 MCT      RECORD PACKED

 FLAGS    PPWORD             FLAG WORD
          ALIGN  48,64
 DEVID    PPWORD             DEVICE IDENTIFIER
 NOR      STRUCT B.UQD       NORMAL QUEUE
 PRI      STRUCT B.UQD       PRIORITY QUEUE
          ALIGN  32,64
 BP       RMA                BUFFER POOL DESCRIPTOR POINTER (RMA)

 INIT     EQU    15          BIT ASSIGNED UNIT INITIALIZED FIELD

 MCT      RECEND
          SPACE  4,10
**        CHANNEL INTERLOCK TABLE
*

 CIT      RECORD PACKED

 LOCK     STRUCT 256
 FLAGS    STRUCT 256
 CONC     EQU    15          BIT 15 SET IF CONCURRENT
 CIT      RECEND

          TITLE  DIRECT CELL DEFINITIONS.
**        DIRECT CELLS.
*


          ORG    0
          CON    INT-1       STARTING ADDRESS
 CM.PPR   BSSZ   3           CM ADDRESS OF PREVIOUS PERIPHERAL REQUEST (REFORMATTED)
 CM.PIT   BSSZ   3           CM ADDRESS OF PP INTERFACE TABLE (REFORMATTED)
 CM.URQ   BSSZ   3           CM ADDRESS OF UNIT REQUEST QUEUE (REFORMATTED)
 CM.RS    BSSZ   3           CM ADDRESS OF RESPONSE BUFFER (REFORMATTED)
 CM.QT    BSSZ   3           CM ADDRESS OF UNIT QUEUE TAIL POINTER (REFORMATTED)
 CM.BPD   BSSZ   3           CM ADDRESS OF BUFFER POOL DESCRIPTOR (REFORMATTED)

 T1       BSSZ   1
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1
 T9       BSSZ   1
 T10      BSSZ   1

*         *P1* AND *P2* ARE MOVED TO *DRNAME* AT INITIALIZATION TIME.

 P1       DATA   H*NE*
 P2       DATA   H*TW*
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 P6       BSSZ   1
 WC       BSSZ   1           WORD COUNT TO READ/WRITE CM WORDS

 BUFLEN   BSSZ   1           CM BUFFER LENGTH IN PP WORDS
 BYTS     BSSZ   1           NUMBER OF BYTES TO TRANSFER TO/FROM CM
 CMADR    BSSZ   3           CM ADDRESS
 CMLISTL  BSSZ   1           NUMBER OF CM WORDS IN ADDRESS-LENGTH PAIR LIST
 CURBUF   BSSZ   1           CURRENT PP BUFFER ADDRESS
 DATADD   BSSZ   3           CM ADDRESS OF DATA AREA
 ERRRCP   BSSZ   1           POINTER TO ERROR RECOVERY COUNTER
 FSTBD    BSSZ   1           INDEX TO BUFFER DESCRIPTOR
 FUNCD    BSSZ   1           FUNCTION CODE
 GNSTAT   BSSZ   1           GENERAL STATUS
 HDRTYP   BSSZ   1           INDEX INTO HEADER CHARACTERISTIC TABLE
 LSTATE   BSSZ   1           LAST STATE MDI WAS KNOWN TO BE IN
 PPNO     CON    1           LOGICAL PP NUMBER
 RBYTS    BSSZ   1           REMAINING BYTES
 RESPC    BSSZ   1           RESPONSE CODE
 SBYOFF   BSSZ   1           STARTING BYTE OFFSET IN CM BUFFER
*                            THE LOADB MACRO STORES INTO THIS LOCATION
 STCHNG   CON    ST.IDLE     NON_ZERO IF PP CHANGING MDI STATE OR IDLE
 UNSC     BSSZ   1           UNSOLICITED RESPONSE CODE
          SPACE  3
          ORG    72B

 DSRTP    CON    0           HCS REAL MEMORY WORD-ADDRESS
          CON    1
 TBYTS    EQU    DSRTP       TOTAL NUMBER OF BYTES TO ALLOCATE CM BUFFERS FOR
 INPNT    EQU    DSRTP+1     IN POINTER FOR RESPONSE BUFFER
 ERRCNT   BSSZ   1           NUMBER OF BYTES NOT TRANSFERRED ON I/O REQUEST
 ERRT1    BSSZ   1           TEMPORARY STORAGE FOR ERROR CHECK
          ORG    76B
          CON    5           TEMPORARY, PP TYPE USED BY DEADSTART
 BYTCNT   EQU    76B         BYTE COUNT OF TRANSFER
 IOCNT    BSSZ   1           NUMBER OF CHANNEL WORDS TO TRANSFER
          SPACE  4,10
*         *DRNAME* IS WRITTEN WITH THE DRIVER NAME (NETW) AT
*         INITIALIZATION TIME.

          ORG    100B
 DRNAME   LJM    INT         INITIALIZE DRIVER
          SPACE  4,10

 ABSC     BSSZ   1           ABNORMAL STATUS CODE
 AVAIL    CON    URC.RN      = LAST UNSOLICITED RESPONSE CODE SENT
*                            INDICATING MDI AVAILABILITY
 BWRT     BSSZ   1           NUMBER OF BYTES TO WRITE TO CM BUFFER
 CHAN     BSSZ   1           CHANNEL NUMBER
 CML      BSSZ   1           INDEX TO CMLIST
 CHLOCK   BSSZ   1           NON ZERO IF CHANNEL LOCKED
 CHTYP    CON    1           =1 IF NOT CONCURRENT CHANNEL
 CM.CB    BSSZ   3           CM ADDRESS OF COMMUNICATIONS BUFFER (REFORMATTED)
 CM.CHAN  BSSZ   3           CM ADDRESS OF CHANNEL INTERLOCK TABLE (REFORMATTED)
 CM.INT   BSSZ   3           CM ADDRESS OF INTERRUPT WORD (REFORMATTED)
*
*    A REGISTER PORTION OF REFORMATTED ADDRESS OF MASTER CONTROL TABLE.
*
 CM.MCT   BSSZ   1
 CSDTIME  BSSZ   1           SEND DATA TIMER
 CSDTMP   BSSZ   1           SEND DATA MULTIPLIER
 DEVID    BSSZ   1           DEVICE IDENTIFIER
 DBUGM    CON    1           = 0 IF DEBUG MODE ON
*                            = 1 IF DEBUG MODE OFF
 DH       BSSZ   3           DIRECTORY HEADER
 EBYOFF   BSSZ   1           ENDING BYTE OFFSET VALUE (ODD OR EVEN)
 ERRT2    BSSZ   1           TEMPORARY STORAGE FOR ERROR CHECK
 EXPD     BSSZ   2           EXPECTED/ACTUAL LENGTH OF MESSAGE
 ACTD     EQU    EXPD+1
 FBSIZE   BSSZ   1           MAXIMUM SIZE OF FIRST BUFFER POOL BUFFER
 FSTRD    BSSZ   1           <> 0, IF FIRST READ HAS BEEN DONE AND ANOTHER READ REQUIRED
 GFCFC    CON    F.FCOFF     FLOW CONTROL FUNCTION TO BE SENT AFTER READY
 IERC     BSSZ   1           INTERFACE ERROR CODE
 INLINE   BSSZ   1           <> 0, IF IN-LINE DIAGNOSTIC MESSAGE AWAITING OUTPUT
 LASTUR   CON    C.WRTR      LAST UNIT REQUEST
 LIM      BSSZ   1           LIMIT OF CIRCULAR RESPONSE BUFFER
 MSGTYP   BSSZ   1           =0, IF IN-LINE DIAGNOSTIC MESSAGE,
*                            <>0, IF NORMAL NETWORK MESSAGE
 NEGPR    CON    1           <> 0 IF PROTOCOL NEGOTIATION REQUIRED
 NIL      VFD    48/0#FFFF80000000,16/0  CYBIL NIL POINTER
 NUMBP    BSSZ   1           NUMBER OF BUFFER POOLS
 NUMPRI   BSSZ   1           NUMBER OF CONSECUTIVE PRIORITY REQUESTS
 NXTREC   BSSZ   1           SIZE OF NEXT RECORD TO READ
 ODDSTR   BSSZ   1           ODD BYTE START IN PP BUFFER (170 OAM NEEDED)
 OTYPE    BSSZ   1           OPERATION TYPE
 OVNUM    BSSZ   1           NUMBER OF OVERLAY LAST LOADED
 PREFC    BSSZ   1           PREVIOUS FUNCTION CODE
 PREST    BSSZ   1           PREVIOUS STATE
 PROV     BSSZ   1           VERSION OF CHANNEL PROTOCOL MDI SUPPORTS
 PVA      BSSZ   8           PVA - RMA ADDRESS PAIR STORAGE AREA
 RMA      EQU    PVA+/RQ/P.NEXT
 RCON     BSSZ   1           RESPONSE CONDITION
 RDRTY    CON    FTRY        DECREMENTED BY ONE EACH TIME A READ ERROR
*                            OCCURS, SET TO ZERO ON UNRECOVERED ERROR
 RDSYN    BSSZ   1           READ SYNCHRONIZATION WORD
 REMBYT   BSSZ   1           REMAINING BYTES IN PP BUFFER AFTER OUTPUT
 REQTYP   BSSZ   1           =0, IF PROCESSING PP REQUEST
*                            <> 0, IF PROCESSING UNIT REQUEST
 RETRY    BSSZ   1           RETRY COUNT
 RWA      BSSZ   1           READ WRITE ADDRESS
 SCP.RDY  BSSZ   1           SYNCHRONIZATION WORD FOR READY
 STBI     BSSZ   1           INPUT TO SEARCH TABLE ROUTINE
*
*         TCCH   DEFINES THE CHANNEL CONNECTION HEADER
*
 TCCH     BSS    0
          LOC    0
          VFD    16/B.HCC    CC HEADER LENGTH IN BYTES
          VFD    16/F.HCC    CC HEADER LENGTH IN FRAMES
          VFD    16/IOBUF+/HCC/P.DLEN ADDRESS OF LENGTH FIELD
          VFD    16/0        HEADER IS INCLUDED IN LENGTH
          VFD    16/URC.CR   CC RESPONSE CODE
          VFD    16/0        SET AT PROTOOCOL NEGOTIATION
          LOC    *O
*
*         TCNH   DEFINES THE CHANNELNET HEADER
*
 TCNH     BSS    0
          LOC    0
          VFD    16/B.H802.3  CHANNELNET HEADER LENGTH IN BYTES
          VFD    16/F.H802.3  CHANNELNET HEADER LENGTH IN FRAMES
          VFD    16/IOBUF+/H802.3/P.DLEN  ADDRESS OF LENGTH FIELD
          VFD    16/B.H802.3  ADD HEADER LENGTH TO LENGTH
          VFD    16/URC.RD   CHANNELNET RESPONSE CODE
          VFD    16/MINLEN*2  CHANNELNET MAXIMUM LENGTH
          LOC    *O
 TI       CON    1           SET TO 2 IF 2XPP
 TIMA     BSSZ   1           MOST RECENT CLOCK VALUE
 TIMB     BSSZ   1           NORMAL FUNCTION TIMER
 UNIT     BSSZ   1           LOGICAL UNIT NUMBER
 WRRTY    CON    FTRY        DECREMENTED BY ONE EACH TIME A WRITE ERROR
*                            OCCURS, SET TO ZERO ON UNRECOVERED ERROR
          IFEQ   SIM,1
 DATCNT   BSSZ   1           CHANNEL FRAMES IN PP BUFFER
          ENDIF
          IFEQ   DEBUG,1
 BUFCNT   BSSZ   MAXBPD      TOTAL CM BUFFERS USED
 EMPBUF   BSSZ   MAXBPD      NUMBER OF TIMES BUFFER POOL WENT EMPTY
 HISTINX  BSSZ   1           FUNCTION HISTORY INDEX
 FUNHIST  BSSZ   8           FUNCTION HISTORY TABLE
 LSTFUNC  BSSZ   1           LAST FUNCTION CODE SAVED IN TABLE
          ENDIF
          TITLE  DCS - DETERMINE CURRENT STATE.
**        DCS - DETERMINE CURRENT STATE.
*
*         THIS IS THE MAIN ROUTINE OF THE PP.  THIS ROUTINE DETERMINES THE
*         CURRENT STATE OF THE MDI DRIVER AND CALLS THE APPROPRIATE STATE
*         PROCESSOR.  WHEN A STATE TRANSITION OCCURS THE STATE PROCESSOR
*         RETURNS AND THE PROCESS RESTARTS.  ALL STATES EXCEPT IDLE, PP MCI
*         RESET, PP DOWN,AND INLINE ARE DETERMINED DIRECTLY FROM THE GENERAL
*         STATUS.  IDLE STATE IS A SOFTWARE IDLE OF THE PP; TRANSITIONS TO/FROM
*         THIS STATE ARE INITIATED BY A CP REQUEST.  INLINE STATE IS ENTERED
*         WHEN THE PP IS HOLDING AN IN-LINE MESSAGE AND WAITING TO RETURN IT,
*         GENERAL STATUS MUST SHOW OPERATIONAL STATE.  PP MCI RESET IS AN ERROR
*         RECOVERY PROCESS USED TO REINITIALIZE THE MCI.  PP DOWN IS A SOFTWARE
*         STATE ENTERED WHEN THE PP HAS DOWNED THE MDI.
          SPACE  4,10
 DCS      LDN    0
          STML   TIMB
          STDL   ERRT1       RESET ERROR REGISTER POINTER
          LDC    GERT
          STML   GERT
          LDN    FTRY
          STML   RDRTY
          STML   WRRTY
          LDDL   STCHNG
          ZJN    DCS20       IF NOT IDLE OR STATE CHANGE BY DRIVER
          STDL   LSTATE
          LMN    ST.IDLE
          ZJN    DCS10       IF IDLE
          LMN    ST.PPD&ST.IDLE
          ZJN    DCS10       IF DOWN
          LDN    0
          STDL   STCHNG
 DCS10    STML   INLINE      CLEAR INLINE MESSAGE QUEUED
          LCN    0
          STML   CSDTIME     RESET SEND DATA TIMER
          LDN    17B
          STML   CSDTMP      RESET SEND DATA MULTIPLIER
          LDDL   STCHNG
          NJK    DCS60       IF IDLE OR DOWN
          UJN    DCS50       STATE CHANGED BY SOFTWARE

 DCS20    RJM    GST         GENERAL STATUS
          NJK    DCS         IF STATUS NOT READ SUCCESSFULLY
          LDDL   LSTATE
          STML   PREST       SAVE PREVIOUS STATE IN CASE OF ERROR
          LDDL   GNSTAT      GENERAL STATUS
          SHN    17-S.OPER
          MJN    DCS30       IF OPERATIONAL STATE
          SHN    4
          LPN    7
          STDL   LSTATE      SAVE LAST STATE
          LDC    C.WRTR
          STML   LASTUR      SET TO CHANNEL CONNECTION
          LDN    0
          STML   INLINE      CLEAR INLINE MESSAGE QUEUED
          UJN    DCS50       PROCESS STATE

 DCS30    LDML   INLINE
          NJN    DCS40       IF INLINE MESSAGE AWAITING OUTPUT
          LDN    ST.OPER
 DCS40    STDL   LSTATE
 DCS50    LDN    OV7O
          RJM    RDO         LOAD OVERLAY
          LDDL   LSTATE
          SBN    ST.OPER
          NJN    DCS55       IF NOT OPERATIONAL STATE
          LDML   NEGPR
          ZJN    DCS55       IF PROTOCOL NEGOTIATED
          LDN    OV4O
          RJM    RDO         LOAD OVERLAY
          RJM    INV         LOG INVALID STATE CHANGE
          UJN    DCS70       LOOP

 DCS55    RJM    SAC         SEND AVAILABILITY CHANGE
          NJN    DCS70       IF ERRORS GETTING DETAILED STATUS
          LDN    OV1O
          RJM    RDO         GET OVERLAY 1 IN CASE THIS IS IN_LINE
 DCS60    LDML   SPT,LSTATE
          SHN    -12
          RJM    RDO         READ OVERLAY
          LDML   SPT,LSTATE
          STD    T1
          RJM    0,T1        RETURN JUMP TO STATE PROCESSOR
 DCS70    UJK    DCS         LOOP
 SPT      SPACE  4,25
**        STATE PROCESSOR TABLE.
*
*         THE STATE TABLE HAS THE FOLLOWING FORMAT
*         BITS 48 - 51   OVERLAY PROCESSOR RESIDES IN
*         BITS 52 - 63   ENTRY ADDRESS
*
          SPACE  4,10
 SPT      BSS    0
          VFD    4/OV4O,12/MFR         MDI RESET STATE PROCESSOR
          VFD    4/OV3O,12/DIA         DIAGNOSTIC STATE PROCESSOR
          VFD    4/OV4O,12/INV         INVALID STATE PROCESSOR
          VFD    4/OV7O,12/NCP         STARTING STATE PROCESSOR
          VFD    4/OV1O,12/AVA         LOADING STATE
          VFD    4/OV4O,12/INV         INVALID STATE PROCESSOR
          VFD    4/OV4O,12/INV         INVALID STATE PROCESSOR
          VFD    4/OV4O,12/INV         INVALID STATE PROCESSOR
          VFD    4/OV1O,12/AVA         OPERATIONAL STATE
          VFD    4/OV4O,12/IDL         IDLE STATE PROCESSOR
          VFD    4/OV5O,12/ILD         IN-LINE DIAGNOSTICS STATE PROCESSOR
          VFD    4/OV4O,12/MCM         MASTER CLEAR MCI
          VFD    4/OV4O,12/MFR         MDI RESET
          VFD    4/OV4O,12/IDL         DOWNED BY PP
          TITLE  AVA - LOADING AND OPERATIONAL STATE PROCESSOR.
**        AVA - LOADING AND OPERATIONAL STATE PROCESSOR.
*
*         THIS ROUTINE PERFORMS PROCESSING FOR BOTH LOADING
*         AND OPERATIONAL STATES.
*
*         CALLS  CSC,IFR,PPR,PRD,PUR,SSM.


 AVA      SUBR               ENTRY/EXIT
          LDN    0
          STML   NXTREC
          LDDL   LSTATE      LAST STATE
          LMK    ST.OPER     COMPARE WITH OPERATIONAL STATE
          NJN    AVA20       IF NOT OPERATIONAL STATE
          LDML   GFCFC
          RJM    IFR         SEND FLOW CONTROL FUNCTION
          NJN    AVAX        IF ERRORS
 AVA10    BSS    0
          LDDL   LSTATE      LAST STATE
          LMK    ST.OPER     COMPARE WITH OPERATIONAL STATE
 AVA20    NJN    AVA40       IF NOT OPERATIONAL STATE
          LDDL   GNSTAT      GENERAL STATUS
          SHN    17-S.RQSYNC
          MJN    AVA35       IF SYNCHRONIZATION REQUESTED
          IAN    14B         READ MICROSECOND COUNTER
          LPC    7777B
          SBM    TIMA
          PJN    AVA30       IF NO OVERFLOW
          ADC    10000B      COMPENSATE FOR CLOCK OVERFLOW
 AVA30    ADC    -1000
          MJN    AVA40       IF LESS THAN 1 MILLISECOND
          LDC    1000        ADVANCE BASE BY 1 MILLISECOND
          RAM    TIMA
          SOM    TIMB
          PJN    AVA10       IF NOT TIME FOR NORMAL FUNCTION
 AVA35    LDN    F.NORM
          RJM    IFR         SEND NORMAL OPERATION FUNCTION
          STML   RDSYN       CLEAR READ SYNCH IF SUCCESSFUL
 AVA40    RJM    PPR         PROCESS PP REQUESTS
          RJM    CSC         CHECK IF STATE CHANGE
          NJN    AVA60       IF STATE CHANGE
          RJM    PRD         PROCESS READ
          RJM    CSD         CHECK IF STATE CHANGE OR SEND DATA
          MJN    AVA60       IF SEND DATA TIMEOUT
          NJN    AVA50       IF SEND DATA NOT INDICATED
          RJM    DFC         DETERMINE FLOW CONTROL
          RJM    PUR         PROCESS UNIT REQUEST
 AVA50    RJM    CSC         CHECK IF STATE CHANGE
          ZJK    AVA10       IF NO STATE CHANGE
 AVA60    UJK    AVAX        EXIT

*copy iodmac6
          TITLE  MAIN ROUTINES - LOADING + OPERATIONAL STATES.
 GPR      SPACE  4,10
**        GPR - GET PP REQUEST.
*
*         EXIT   (A) = 0 IF NO PP REQUESTS.
*                (A) <> 0 IF PP REQUEST WAS FOUND.
*
*         USES   P1 - P4.
*
*         CALLS  CPL, IRP, SPL.
*
*         MACROS LOADC, LOADF.


 GPR      SUBR               ENTRY/EXIT
          LCN    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDC    0#7FFF
          STDL   P4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          RDCL   P1          CLEAR ACTIVE CHECK BIT
          ADN    /PIT/C.PPQ  CM ADDRESS OF PP REQUEST QUEUE POINTER
          CRDL   P1          READ PP QUEUE POINTER
          LDDL   P3          RMA OF NEXT QUEUED PP REQUEST
          ADDL   P4
          ZJN    GPRX        IF NO PP REQUESTS
          RJM    SPL         SET PP QUEUE LOCK WORD
          ZJN    GPR10       IF LOCK WAS SET
          LDN    0
          UJK    GPRX        EXIT

 GPR10    BSS    0
          LDN    2
          STDL   WC
          LOADC  CM.PIT
          ADN    /PIT/C.PPQPVA
          CRML   RS,WC       READ PVA AND RMA OF FIRST REQUEST IN CHAIN
          LDN    C.RQ
          STDL   WC
          LOADF  RS+/RS/P.REQ  CM ADDRESS OF FIRST PP REQUEST
          CRML   RQ,WC       READ PP REQUEST
          RJM    CPL         CLEAR PP QUEUE LOCKWORD
          RJM    IRP         INITIALIZE REQUEST PROCESSING
          LCN    0
          UJK    GPRX        EXIT
 GUR      SPACE  4,16
**        GUR - GET UNIT REQUEST.
*
*         THIS ROUTINE WILL GET THE NEXT REQUEST ON A
*         UNIT QUEUE.
*
*         ENTRY  (CM.URQ) = REFORMATTED ADDRESS OF UNIT
*                           QUEUE TO SEARCH.
*
*         EXIT   (A) = 0, IF NO REQUESTS TO PROCESS,
*                    <> 0, IF REQUEST TO PROCESS.
*
*         USES   P1 - P4, T2, WC.
*
*         CALLS  IRP.
*
*         MACROS LOADC, LOADF.


 GUR      SUBR               ENTRY/EXIT

*         GET THE FIRST WORD ADDRESS OF THE NEXT UNIT REQUEST.

          LOADC  CM.URQ      CM ADDRESS OF UNIT REQUEST QUEUE
          ERRNZ  /UQD/C.HEAD OFFSET TO UNIT QUEUE HEAD POINTER IS NOT ZERO
*         ADN    /UQD/C.HEAD OFFSET TO UNIT QUEUE HEAD POINTER
          CRDL   P1          READ UNIT QUEUE HEAD POINTER
          LDDL   P3          RMA OF NEXT QUEUED UNIT REQUEST
          ADDL   P4
          ZJN    GURX        IF NO UNIT REQUESTS

*         CHECK THAT THE UNIT REQUEST WILL FIT IN PP MEMORY.

          LDDL   P1          REQUEST LENGTH (CM BYTES)
          SHN    -3          REQUEST LENGTH (CM WORDS)
          STDL   WC
          SBN    MAXURQ+1    COMPARE WITH MAX UNIT REQUEST SIZE
          PJN    *           IF REQUEST TOO BIG FOR PP MEMORY  --HANG--

*         READ THE UNIT REQUEST.

          LOADF  P3          CM ADDRESS OF THE NEXT REQUEST
          CRML   RQ,WC       READ UNIT REQUEST

*         SAVE PVA OF UNIT REQUEST IN RESPONSE.

          LDN    2           LENGTH OF PVA - 1
          STDL   T2
 GUR20    LDML   RQ+/URQ/P.THISPV,T2   PVA OF THE UNIT REQUEST
          STML   RS+/RS/P.PVA,T2    PVA OF THE RESPONSE
          SODL   T2
          PJN    GUR20       IF MORE TO DO

*         SAVE RMA OF UNIT REQUEST IN RESPONSE.

          LDDL   P3            RMA OF THE UNIT REQUEST
          STML   RS+/RS/P.REQ  RMA OF THE RESPONSE
          LDDL   P3+1
          STML   RS+/RS/P.REQ+1

*         SET UP A DUMMY R/I FIELD IN THE REQUEST

          LDML   RQ+/RQ/P.RECOV  REQUEST R/I AND DEVICE ID FIELDS
          LPK    17400B          KEEP MEMORY PORT
          LMK    20000B          SET INTERRUPT OPTION
          STML   RQ+/RQ/P.RECOV  R/I FIELD (RECOVERY, INTERRUPT, AND MEM PORT)

          RJM    IRP         INITIALIZE REQUEST PROCESSING
          LCN    0
          UJK    GURX        EXIT
 PPC      SPACE  4,12
**        PPC - PROCESS PP COMMANDS.
*
*         THIS ROUTINE PROCESSES ALL PP COMMANDS.  AT THE
*         PRESENT TIME VALID COMMANDS ARE - C.IDLE, C.RESUME,
*         C.RDY, C.GFC, C.DBUG, C.RESET, C.PPAD, C.RPM, C.PPMEM.
*
*         ENTRY  (CM) - COMMAND.
*                (RQ) - PP REQUEST.
*
*         USES   P2.
*
*         CALLS  PIE, RDO, STB.
          SPACE  4,10
 PPC      SUBR               ENTRY/EXIT
          LDML   CM+/CM/P.CODE GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          STML   STBI
          LDC    TPPC-2      ADDRESS-2 OF PP COMMAND TABLE
          RJM    STB         SEARCH TABLE
          NJN    PPC20       IF MATCH FOUND

*         PROCESS INVALID COMMAND.

          LDC    E501        INTERFACE ERROR
          RJM    PIE         PROCESS INTERFACE ERROR
          UJN    PPC30

*         PROCESS VALID COMMAND.

 PPC20    STD    P2
          SHN    -12
          RJM    RDO         READ OVERLAY
          RJM    0,P2        CALL COMMAND PROCESSOR
 PPC30    LDN    OV2O
          RJM    RDO         LEAVE IO OVERLAY LOADED
          UJK    PPCX        EXIT
          SPACE  4,32
**        TPPC - PP COMMAND TABLE.
*
*         THE COMMAND TABLE CONTAINS TWO WORD ENTRIES IF THE FOLLOWING FORMAT
*         BITS 32 - 47   PP COMMAND CODE
*         BITS 48 - 51   OVERLAY PROCESSOR RESIDES IN
*         BITS 52 - 63   ENTRY ADDRESS
*
          SPACE  4,10
 TPPC     VFD    16/C.IDLE,4/OV9O,12/IDP  IDLE PROCESSOR
          VFD    16/C.RESUME,4/OV9O,12/REP  RESUME PROCESSOR
          VFD    16/C.RDY,4/OV9O,12/NRA     SYNCHRONIZE NOT READY
          VFD    16/C.GFC,4/OV8O,12/GFC  GLOBAL FLOW CONTROL
          VFD    16/C.DBUG,4/OV9O,12/SDM  DEBUG MODE
          VFD    16/C.RESET,4/OV9O,12/RFC  RESET MCI
          VFD    16/C.PPAD,4/OVAO,12/SPA  SELECT PP ADDRESS
          VFD    16/C.RPM,4/OVAO,12/RPM   READ PP MEMORY
          VFD    16/C.PPMEM,4/OVAO,12/WPM   WRITE PP MEMORY
          IFEQ   BRK,1
          VFD    16/C.DEFBA,4/OVAO,12/DBA DEFINE PP BKPT AREA IN CM
          ENDIF
          CON    0


          TTL    NAM$MDI DRIVER (NETW).
          TITLE  MISCELLANEOUS ROUTINES.
 CHG      SPACE  4,10
**        CHG - CHANGE CHANNEL INSTRUCTIONS.
*
*         CHANGE ALL CHANNEL INSTRUCTIONS TO USE THE SPECIFIED CHANNEL.
*
*         ENTRY  (CHAN) = NEW CHANNEL NUMBER TO BE USED.
*                (A) = 0 IF CHANGING MAIN PROGRAM,
*                      OVERLAY NUMBER IF OVERLAY.
*
*         USES   T1, T2.
          SPACE  2
 CHG      SUBR               ENTRY/EXIT
          STDL   T1
          LDML   TCHG,T1     GET INSTRUCTION ADDRESS
          STML   CHGA
          LDN    0
          STDL   T1          CHANGE MDI CHANNEL INSTRUCTIONS
 CHG10    LDML   CONCH,T1    ADDRESS OF CHANNEL INSTRUCTIONS
 CHGA     EQU    *-1         ADDRESS OF CHANNEL INSTRUCTIONS
          ZJN    CHGX        IF END OF LIST
          STDL   T2
          LDIL   T2
          SCN    37B
          LMML   CHAN        CHANNEL NUMBER
          STIL   T2
          AODL   T1
          UJN    CHG10
          SPACE  4,10
**        TCHG - TABLE OF POINTERS TO CHANNEL INSTRUCTION LIST.
*
*         POINTERS TO THE LIST OF CHANNEL INSTRUCTIONS USED IN
*         EACH OVERLAY.


 TCHG     CON    CONCH
          CON    OV1CH
          CON    OV2CH
          CON    OV3CH
          CON    OV4CH
          CON    OV5CH
          CON    OV6CH
          CON    OV7CH
          CON    OV8CH
          CON    OV9CH
          CON    OVACH
 CFT      SPACE  4,25
**        CFT - CHECK FUNCTION TIMEOUT.
*
*         THIS ROUTINE CHECKS FOR FUNCTION TIMEOUT ERRORS.
*         IF ERRORS OCCURRED THEY ARE LOGGED AND THE PROPER
*         RECOVERY ACTION IS INITIATED.
*
*         ERROR RECOVERY ON FUNCTION TIMEOUT IS HANDLED AS FOLLOWS.
*         1. ALL FUNCTIONS ARE RETRIED UP TO TWO MORE TIMES.
*         2. ALL FUNCTION TIMEOUTS (EXCEPT GENERAL STATUS) ARE LOGGED.
*         3. IF FAILING FUNCTION WAS GENERAL STATUS SET MDI STATE TO RESET.
*         4. IF FAILING FUNCTION WAS MASTER CLEAR SET MDI STATE TO DOWN.
*         5. FOR FUNCTION TIMEOUT IN DIAGNOSTIC STATE DOWN MDI.
*         6. FOR ALL MDI STATES OTHER THAN DIAGNOSTIC THE MCI IS RESET.
*
*
*         ENTRY  (A) = POINTER TO STATUS RETURN AREA(SRA).
*                (FUNCD) = FUNCTION CODE.
*
*         EXIT   (A) = 0, FUNCTION ISSUED, NORMAL COMPLETION.
*                (A) <> 0, FUNCTION TIMEOUT.
*
*         USES   T5.
*
*         CALLS  SLM, SRU, SSC.


 CFT05    LDML   FTO.RC,T5
          NJN    CFT07       IF RECOVERED GENERAL STATUS
          LDN    ST.MDI
          STDL   STCHNG      CHANGE STATE TO RESET

 CFT      SUBR               ENTRY/EXIT
          STDL   T5          SAVE STATUS AREA
          LDC    F.GS
          SBDL   FUNCD
          ZJN    CFT05       IF GENERAL STATUS
          LDDL   FUNCD
          STML   LRS+/RS/P.FUNTO  PUT FUNCTION CODE IN RESPONSE
          LDML   FTO.SC,T5
          RJM    SSC         SET SYMPTOM CODE
          LDML   FTO.RC,T5
          RJM    SRU         SET RECOVERY STATUS
          LDK    /RS/K.LFTO
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDML   FTO.RC,T5
          ZJN    CFT10       IF UNRECOVERED
          RJM    SLM         SEND LOG MESSAGE
 CFT07    LDN    0
          UJK    CFTX        EXIT

 CFT10    LDC    F.MCLEAR
          SBDL   FUNCD
          ZJN    CFT20       IF MASTER CLEAR
          LDDL   LSTATE
          SBN    ST.DIAG
          ZJN    CFT20       IF DIAGNOSTIC STATE DOWN MDI
          LDN    ST.PPR
          UJN    CFT25       RESET MCI

 CFT20    LDN    ST.PPD      DOWN MDI
 CFT25    STDL   STCHNG
          RJM    SLM         SEND LOG MESSAGE
          UJK    CFTX        RETURN ERROR
 CSC      SPACE  4,10
**        CSC - CHECK IF STATE CHANGE.
*
*         THIS ROUTINE WILL CHECK IF THE MDI HAS
*         CHANGED STATES OR HAS BEEN IDLED.
*
*         EXIT   (A) = 0, NO STATE CHANGE.
*                (A) <> 0, STATE CHANGE OR MDI NOT AVAILABLE.
*
*         CALLS  GST.


 CSC      SUBR               ENTRY/EXIT
          LDDL   STCHNG
          NJN    CSC10       IF STATE CHANGE OR IDLE
          RJM    GST
          NJN    CSCX        RETURN IF STATUS CAN NOT BE READ
          LDDL   GNSTAT      GENERAL STATUS
          SHN    17-S.OPER
          MJN    CSC20       IF IN OPERATIONAL STATE
          SHN    4
          LPN    7B
 CSC10    BSS    0
          LMDL   LSTATE      LAST KNOWN STATE
          UJN    CSCX        EXIT

 CSC20    BSS    0
          LDML   INLINE
          NJN    CSC10       IF IN-LINE MESSAGE AWAITING RETURN TO MDI
          LDN    ST.OPER
          UJN    CSC10
 CSD      SPACE  4,17
**        CSD - CHECK IF SEND DATA UP.
*
*         THIS ROUTINE OBTAINS THE GENERAL STATUS AND CHECKS
*         FOR SEND DATA.  A TIMER IS KEPT TO ASSURE THAT SEND
*         DATA IS BEING SET BY THE MDI WITHIN 1 SECOND.
*         IT IS ASSUMED THIS ROUTINE CAN ONLY BE CALLED
*         ONCE PER MICROSECOND. THIS TIMEOUT IS ONLY DONE
*         DURING DIAGNOSTIC'S AND LOADING STATES, AND IN
*         OPERATIONAL STATE WHEN AN IN-LINE DIAGNOSTICS
*         MESSAGE IS AWAITING RETURN.
*
*         EXIT   (A) = 0, IF SEND DATA UP,
*                    > 0, IF SEND DATA NOT UP,
*                    < 0, IF TIMEOUT EXPIRED.
*
*         CALLS  CSC, IGS, GDS, SLM.


 CSD30    LCN    0
          STML   CSDTIME     RESET TIMER
          LDN    17B
          STML   CSDTMP      RESET MULTIPLIER
          LDN    0

 CSD      SUBR               ENTRY/EXIT
          RJM    CSC
          NJN    CSDX        EXIT IF STATUS CAN NOT BE READ
          LDDL   GNSTAT      GENERAL STATUS
          SHN    17-S.SEND
          MJK    CSD30       IF SEND DATA UP
          LDDL   LSTATE      LAST DI STATE
          LMK    ST.OPER     COMPARE WITH OPERATIONAL STATE
          ADML   INLINE
          ZJN    CSD03       IF OPERATIONAL STATE AND NO IN-LINE MESSAGE
          SOML   CSDTIME     DECREMENT TIMER
          NJN    CSDX        IF NOT TIMED OUT
          SOML   CSDTMP
          ZJN    CSD05       IF TIME EXAUSTED
          LCN    0
          STML   CSDTIME
 CSD03    LDN    1
          UJN    CSDX        EXIT

 CSD05    LDC    /RS/K.LGSSDT
          STML   LRS+/RS/P.ERRID SET ERROR ID
          RJM    IGS         INCLUDE GENERAL STATUS
          LDDL   LSTATE
          LMK    ST.DIAG
          NJN    CSD10       IF NOT DIAGNOSTIC STATE
          LDML   PREBUF      DIAGNOSTIC COMMAND
          STML   LRS+/RS/P.ERRW2
          LDK    ST.PPD      DOWN MDI
          UJN    CSD20       CONTINUE

 CSD10    RJM    GDS         GET DETAIL STATUS
          LDN    ST.PPR      RESET MCI
 CSD20    STDL   STCHNG
          RJM    SLM         SEND LOG MESSAGE
          LCN    0
          UJK    CSDX        EXIT
 DFC      SPACE  4,14
**        DFC - DETERMINE FLOW CONTROL.
*
*         THIS ROUTINE DETERMINES IF THE MDI HAS SET NORMAL
*         FLOW CONTROL.  IT DOES SO BY EXAMINING THE LAST GENERAL
*         STATUS TAKEN.
*
*         ENTRY  (GNSTAT) = GENERAL STATUS, SEND DATA BIT IS SET.
*
*         EXIT   (NUMPRI) = 0, IF FLOW CONTROL CHANGED FROM ON TO OFF,
*                         > MAXPR IF FLOW CONTROL ON.
*


 DFC10    LDN    MAXPR+1
 DFC20    STML   NUMPRI

 DFC      SUBR               ENTRY/EXIT
          LDDL   GNSTAT      GENERAL STATUS
          SHN    17-S.OPER
          PJN    DFCX        IF NOT OPERATIONAL
          SHN    17-S.NORMFC-17+S.OPER
          MJN    DFC10       IF FLOW CONTROL ON
          LDN    MAXPR
          SBML   NUMPRI
          PJN    DFCX        IF NO SWITCH IN FLOW CONTROL
          LDN    0
          UJN    DFC20       EXIT

 DLR      SPACE  4,16
**        DLR - DELINK REQUEST FROM QUEUE.
*
*         THIS ROUTINE DELINKS THE CURRENT REQUEST
*         FROM THE APPROPRIATE QUEUE.
*
*         ENTRY  (CM.URQ) = REFORMATTED ADDRESS OF REQUEST
*                           QUEUE IF *REQTYP* <> 0.
*                (REQTYP) = 0, IF PP REQUEST,
*                         <> 0, IF UNIT REQUEST.
*
*         USES   WC.
*
*         CALLS  CPL, DUR, FDR, SPL.
*
*         MACROS LOADC.


 DLR      SUBR               ENTRY/EXIT
          LDML   REQTYP
          NJN    DLR20       IF UNIT REQUEST

*         PP REQUEST.

 DLR10    BSS    0
          LDN    2
          STDL   WC
          RJM    SPL         SET PP QUEUE LOCK
          NJN    DLR10       IF LOCK COULD NOT BE SET
          LOADC  CM.PIT
          ADN    /PIT/C.PPQPVA
          RJM    FDR         FIND AND DELINK REQUEST
          RJM    CPL         CLEAR PP QUEUE LOCK
          UJK    DLRX        EXIT

*         UNIT REQUEST.

 DLR20    BSS    0
          RJM    DUR         DELINK UNIT REQUEST
          UJK    DLRX        EXIT
 DMT      SPACE  4,18
**        DMT - DETERMINE MESSAGE TYPE.
*
*         THIS ROUTINE DETERMINES THE TYPE OF MESSAGE TO BE
*         READ NEXT.  IT DOES SO BY EXAMINING THE LAST GENERAL
*         STATUS TAKEN.
*
*         ENTRY  (GNSTAT) = GENERAL STATUS, DATA AVAILABLE BIT IS SET.
*
*         EXIT   (A) = 0 IF NO ERRORS,
*                    <> 0 IF MESSAGE TYPE ERRORS.
*                (MSGTYP) = 0, IF IN-LINE DIAGNOSTIC MESSAGE TO BE READ,
*                         <> 0, IF NORMAL NETWORK MESSAGE TO BE READ.
*                (HDRTYP) = ADDRESS OF HEADER DESCRIPTOR TABLE.
*
*         CALLS  IGS, SLM.
          SPACE  2
 DMT10    LDC    TCNH
 DMT20    STDL   HDRTYP
          LDN    0

 DMT      SUBR               ENTRY/EXIT
          LDDL   GNSTAT      GENERAL STATUS
          SHN    -S.STATE1
          LPN    17B         LOOK AT STATE AND OPERATIONAL BITS (3-6)
          LMN    ILMESS
          STML   MSGTYP
          ZJN    DMT10       IF IN_LINE DIAGNOSTIC
          LMN    CCMESS&ILMESS
          NJN    DMT30       IF NOT CHANNEL CONNECTION
          LDC    TCCH
          UJN    DMT20       EXIT

 DMT30    LMN    CNMESS&CCMESS
          ZJN    DMT10       IF CHANNELNET
          LMN    LDMESS&CNMESS
          ZJN    DMT10       IF LOADING STATE
          LDC    /RS/K.LMTE  SET ILLEGAL MESSAGE TYPE
          STML   LRS+/RS/P.ERRID
          RJM    IGS         INCLUDE GENERAL STATUS
          LDN    ST.PPR
          STDL   STCHNG      RESET MCI
          RJM    SLM         SEND LOG MESSAGE
          UJN    DMTX        EXIT
 DUR      SPACE  4,16
**        DUR - DELINK UNIT REQUEST FROM QUEUE.
*
*         THIS ROUTINE DELINKS THE CURRENT UNIT REQUEST
*         FROM THE APPROPRIATE QUEUE AND UPDATES THE UNIT QUEUE HEAD POINTER
*         TO POINT TO THE NEXT REQUEST IN THE QUEUE.
*
*         ENTRY  (CM.URQ) = REFORMATTED ADDRESS OF REQUEST QUEUE.
*
*         USES   P5, T1 - T4, T5, T7, WC.
*
*         CALLS  CSW, CUL, SUL.
*
*         MACROS LOADC.

 DUR      SUBR               ENTRY/EXIT
          LDN    1           SIZE OF UNIT QUEUE HEAD POINTER
          STDL   WC

*         UPDATE UNIT QUEUE HEAD POINTER.

 DUR20    BSS    0
          LOADC  CM.URQ      CM ADDRESS OF UNIT REQUEST QUEUE
          ERRNZ  /UQD/C.HEAD OFFSET TO UNIT QUEUE HEAD POINTER IS NOT ZERO
*         ADN    /UQD/C.HEAD OFFSET TO UNIT QUEUE HEAD POINTER
          CWML   RQ+/URQ/P.NEXTLN,WC   UPDATE UNIT QUEUE HEAD POINTER

          LDML   RQ+/URQ/P.NEXT     NEXT UNIT REQUEST (UPPER PART)
          ADML   RQ+/URQ/P.NEXT+1   NEXT UNIT REQUEST (LOWER PART)
          NJK    DURX        IF OTHER UNIT REQUESTS IN THIS QUEUE

*         CLEAR UNIT QUEUE TAIL POINTER TO SHOW THAT THERE ARE NO OTHER UNIT
*         REQUESTS IN THIS QUEUE.  IF A NEW UNIT REQUEST IS PLACED IN THE
*         QUEUE WHILE THIS IS BEING DONE, UNIT QUEUE HEAD POINTER WILL BE
*         UPDATED INSTEAD.

          LDK    CM.QT
          STDL   T7          UNIT QUEUE TAIL POINTER
          LDN    0
          STDL   T5          OFFSET TO UNIT QUEUE TAIL POINTER (NO OFFSET)
          LDK    RQ+/URQ/P.THISPV
          STDL   P5          ADDRESS OF WORD CONTAINING PVA OF CURRENT REQUEST
          LDK    NIL         NIL POINTER
          RJM    CSW         COMPARE-SWAP (UNIT QUEUE TAIL POINTER CONTENTS)
          ZJK    DURX        IF COMPARE-SWAP SUCCEEDED

*         COMPARE-SWAP FAILED (A NEW REQUEST CAME IN).
*         RE-READ NEXTLN/NEXT WORD OF REQUEST TO GET THE NEW REQUEST POINTER.

          LDN    1
          STDL   WC          SIZE OF NEXTLN/NEXT (CM WORD)
          LOADF  RS+/RS/P.REQ  RMA OF THE CURRENT REQUEST
          ADN    /URQ/C.NEXT OFFSET TO NEXTLN/NEXT WORD
          CRML   RQ+/URQ/P.NEXTLN,WC   READ UNIT REQUEST NEXTLN/NEXT WORD
          UJK    DUR20       UPDATE UNIT QUEUE HEAD POINTER
 FAW      SPACE  4,13
**        FAW - FUNCTION THE CHANNEL AND WAIT FOR DATA.
*
*         ERRORS ENCOUNTERED ACTIVATING THE CHANNEL ARE
*         LOGGED AND A RESET IS REQUESTED.
*
*         ENTRY  (A) = FUNCTION CODE.
*
*         EXIT   (A) = 0, NORMAL COMPLETION - FUNCTION IS ISSUED,
*                         CHANNEL IS ACTIVE AND FULL.
*                (A) <> 0, FUNCTION TIMEOUT OR CHANNEL ERROR.
*
*         CALLS  CEE, CIE, IFR, SLM, STB.


 FAW      SUBR               ENTRY/EXIT
          STML   STBI        SAVE FUNCTION FOR ERROR PROCESSING
          RJM    IFR
          NJN    FAWX        RETURN IF FUNCTION TIMEOUT
          ACN    CHN
          LDC    WTFULL*1000
 FAW10    IJM    FAW40,CHN
          EJM    FAW30,CHN
          LDN    0
          UJN    FAWX        EXIT NORMAL COMPLETION

 FAW30    SBN    1
*         SBN    1           (IF 4X PP SPEED)
*         SBN    2           (IF 2X PP SPEED)
 FAWA     EQU    *-1
          NJN    FAW10
          LDC    /RS/K.LSCE  CHANNEL DID NOT GO FULL
          UJN    FAW50       SEND MESSAGE AND RESET MCI

*         CHANNEL ERROR

 FAW40    LDC    /RS/K.LSCD  CHANNEL INACTIVE AFTER ACN
 FAW50    RJM    SSC         LOG SYMPTOM CODE
          LDC    FAWT-2      TABLE OF OP CODES
          RJM    STB         FIND OPERATION CODE
          STML   LRS+/RS/P.OPTP STORE OPERATION TYPE
          DCN    CHN+40B     DISCONNECT CHANNEL
          LDK    /RS/K.LOF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDDL   LSTATE
          SBN    ST.DIAG
          NJN    FAW60       IF NOT DIAGNOSTIC STATE
          LDN    ST.PPD
          UJN    FAW65       DOWN MDI

 FAW60    LDN    ST.PPR
 FAW65    STDL   STCHNG      RESET MCI
          RJM    SLM         SEND LOG MESSAGE
          UJK    FAWX        EXIT NORMAL COMPLETION
          SPACE  3
*         TABLE EQUATING FUNCTION CODES TO OPERATION CODES.

 FAWT     CON    F.DS,/RS/K.LRDS
          CON    F.READ,/RS/K.LREAD
          CON    F.RQDCMD,/RS/K.LRDC
          CON    0
 FDR      SPACE  4,10
**        FDR - FIND AND DELINK REQUEST.
*
*         THIS ROUTINE SEARCHES THE LINKED LIST OF REQUESTS
*         FOR THE CURRENT REQUEST AND DELINKS IT.
*
*         ENTRY  (A) + (R) = CM ADDRESS OF FIRST REQUEST ON QUEUE.
*                (WC) = 2.
*
*         MACROS LOADC, LOADF.


 FDR40    BSS    0
          LOADF  RMA
          CRML   PVA,WC      READ CURRENT REQUEST
          LOADC  CM.PPR
          CWML   PVA,WC      DELINK REQUEST

 FDR      SUBR               ENTRY/EXIT
 FDR10    BSS    0
          STDL   CM.PPR+2
          SRD    CM.PPR      SAVE CM ADDRESS
          CRML   PVA,WC      READ NEXT PVA + RMA
          LDML   RMA
          ADML   RMA+1
          ZJN    *           *** IF NOT ON LIST
          LDML   RMA
          SBML   RS+/RS/P.REQ
          NJN    FDR30       IF NOT CURRENT REQUEST
          LDML   RMA+1
          SBML   RS+/RS/P.REQ+1
          ZJK    FDR40       IF REQUEST FOUND
 FDR30    LOADF  RMA
          UJK    FDR10
 FORMA    SPACE  4,12
**        FORMA - FORMAT REAL MEMORY ADDRESS.
*
*         ENTRY  (A) = ADDRESS OF RMA.
*
*         EXIT   (CMADR - CMADR+2) = REFORMATTED RMA.
*                -ADDRESS-  WORD 0, BITS 0-13 AND
*                           WORD 1, BITS 3-15 ARE REFORMATTED TO:
*                  -CMADR-  WORD 0, BITS 0-9,
*                           WORD 1, BITS 0-11,
*                           WORD 2, BITS 0-5.
*
*         USES   T1.


 FORMA    SUBR               ENTRY/EXIT
          STDL   T1
          LDIL   T1
          LPN    37B
          SHN    16
          LMML   1,T1
          SHN    9
          STD    CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   T1
          SHN    -5
          STD    CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMC    400000B
          UJN    FORMAX      EXIT
 FTO      SPACE  4,18
**        FTO - FUNCTION AND TIMEOUT.
*
*         THIS ROUTINE WILL FUNCTION THE MDI AND WAIT FOR THE
*         CHANNEL TO GO INACTIVE.
*
*         ENTRY  (A) = POINTER TO STATUS RETURN AREA(SRA).
*                (FUNCD) = FUNCTION CODE.
*
*         EXIT   (A) = 0 IF NO RETRIES.
*                    < 0 IF FUNCTION WAS RETRIED.
*                (SRA WORD 1) = FTRY  IF NO ERRORS.
*                             = 0, UNRECOVERED ERROR.
*                             = FTRY - RETRIES, IF RECOVERED ERROR.
*                (SRA WORD 2) = /RS/K.LSCEF IF CHANNEL ERROR FLAG SET.
*                             = 0 IF NO CHANNEL ERROR.
*
*         USES   T9.
*
*         CALLS  GER
          SPACE  4,10
 FTO30    LDML   FTO.RC,T9
          SBN    FTRY

 FTO      SUBR               ENTRY/EXIT
          STDL   T9          SAVE STATUS RETURN POINTER
          LDN    0
          STML   FTO.RC,T9   CLEAR STATUS RETURN
          STML   FTO.SC,T9
          IFEQ   DEBUG,1
          LDC    F.GS
          SBDL   FUNCD
          NJN    FTO03       IF FUNCTION TO BE ISSUED IS NOT G.S.
          LDML   LSTFUNC     LAST FUNCTION CODE SAVED
          SBDL   FUNCD
          ZJN    FTO05       ONLY SAVE ONE OCCURANCE OF GENERAL STATUS
 FTO03    AOML   HISTINX     INDEX INTO FUNCTION HISTORY TABLE
          LPN    7
          STDL   T1
          LDDL   FUNCD       FUNCTION CODE
          STML   FUNHIST,T1  STORE IN TABLE
          STML   LSTFUNC     LAST FUNCTION CODE SAVED
 FTO05    BSS    0
          ENDIF
          LDC    F.GS
          SBDL   FUNCD
          ZJN    FTO07       IF GENERAL STATUS
          LDDL   FUNCD
          STML   PREFC       SAVE LAST NON GENERAL STATUS FUNCTION CODE
 FTO07    LDN    FTRY
          STML   FTO.RC,T9   RETRY COUNTER
 FTO10    LDDL   FUNCD
          FAN    CHN         ISSUE FUNCTION
 FTO18    LDC    FTOLEN*600
 FTO20    IJM    FTO30,CHN    EXIT IF CHANNEL INACTIVE
          SBN    1
*         SBN    1           (IF 4X PP SPEED)
*         SBN    2           (IF 2X PP SPEED)
 FTOA     EQU    *-1
          NJN    FTO20
          DCN    CHN+40B
          SOML   FTO.RC,T9   DECREMENT RETRY COUNTER
          ZJK    FTO30       IF UNRECOVERED ERROR
          SBN    FTRY-1
          NJN    FTO10       IF NOT FIRST ERROR
          CFM    FTO10,CHN   IF NOT CHANNEL ERROR
          RJM    GER         RECORD ERROR REGISTER
          STML   FTO.SC,T9   SET CHANNEL ERROR FLAG
          UJK    FTO10       RETRY FUNCTION
 GBT      SPACE  4,15
**        GBT - GENERAL STATUS BUSY TIMEOUT.
*
*         THIS ROUTINE IS CALLED WHEN THE GENERAL STATUS
*         BUSY BIT IS SET.  IF BUSY TIMEOUT IS REACHED A LOG
*         MESSAGE IS GENERATED AND THE MCI IS RESET UNLESS
*         THE LAST STATE WAS DIAGNOSTIC, IN WHICH CASE THE MDI
*         IS DOWNED.
*
*         ENTRY  (GBTL) = COUNT REMAINING IN DELAY LOOP.
*                (GBTM) = COUNT REMAINING IN MULTIPLIER LOOP.
*
*         EXIT   (A) = 0 IF NOT TIMEOUT.
*                    < 0 IF TIMEOUT.
*
*         CALLS  IGS, SLM.


 GBT10    LDN    0
 GBT      SUBR               ENTRY/EXIT
          LDML   DBUGM
          ZJN    GBTX        IF DEBUG MODE ON
          SOML   GBTL        TIMEOUT COUNTER
          UJN    *+2
          CON    GBTL
*         UJN    *+2         (IF 4X PP SPEED)
*         CON    GBTL        (IF 4X PP SPEED)
*         SOML   GBTL        (IF 2X PP SPEED)
 GBTA     EQU    *-2
          PJK    GBT10       IF NOT TIMEOUT EXIT
          LCN    0
          STML   GBTL
          SOML   GBTM
          PJN    GBT10       IF NOT TIMEOUT EXIT
          DCN    CHN+40B     DISCONNECT CHANNEL
          LDDL   LSTATE
          SBN    ST.DIAG
          NJN    GBT20       IF NOT DIAGNOSTIC STATE
          LDN    ST.PPD
          UJN    GBT30

 GBT20    LDN    ST.PPR
 GBT30    STDL   STCHNG      RESET MCI
          LDK    /RS/K.LGSBTO
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDML   PREFC
          STML   LRS+/RS/P.PFUNC  SAVE PREVIOUS FUNCTION CODE
          RJM    IGS         INCLUDE GENERAL STATUS
          RJM    SLM         SEND LOG MESSAGE
          UJK    GBTX        EXIT
          SPACE  2
 GBTL     BSSZ   1           BUSY TIMEOUT LOOP
 GBTM     BSSZ   1           BUSY TIMEOUT MULTIPLIER
          SPACE  4,10
**        GDS - GET DETAILED STATUS.
*
*         THIS ROUTINE LOADS THE DETAILED STATUS OVERLAY AND CALLS
*         THE ROUTINE *DST*. ON RETURN FROM DST OV2 IS RELOADED AND
*         THE STATUS FROM DST IS RETURNED TO THE CALLER.
*
*         EXIT   (A) = DST STATUS.
*
*         USES   T10.
*
*         CALLS  DST, RDO.
          SPACE  2,10
 GDS      SUBR               ENTRY/EXIT
          LDN    OV6O
          RJM    RDO         READ DEATAILED STATUS OVERLAY
          RJM    DST         GET DETAILED STATUS
          STML   GDSA
          LDN    OV2O
          RJM    RDO         GET MISCELLANEOUS ROUTINES
          LDC    0
 GDSA     EQU    *-1         DST STATUS
          UJN    GDSX        RETURN
          SPACE  4,10
**        GER - GET ERROR REGISTER.
*
*         THIS ROUTINE OBTAINS THE ERROR REGISTER OF A CONCURRENT
*         CHANNEL. THE ERROR REGISTER VALUE IS STORED IN THE NEXT
*         AVAILABLE ENTRY IN *GERT*. CALLERS OF *GER* MUST CALL
*         *SSC* TO LOG THIS DATA BEFORE RETURNING TO THEIR CALLER.
*
*         EXIT   (A) = /RS/K.LSCEF.
*                (GERT) = CONCURRENT CHANNEL ERROR REGISTER.
*
*         USES   T10.
          SPACE  2,10
 GER20    IAN    CHN
 GER30    DCN    CHN+40B
          STIL   T10         SAVE REGISTER FOR LOGGING
 GER40    LDC    /RS/K.LSCEF

 GER      SUBR               ENTRY/EXIT
          AOML   GERT        ADVANCE TABLE POINTER
          STDL   T10
          LDML   CHTYP
          NJN    GER40       IF NOT CONCURRENT
          DCN    CHN+40B
          LDC    F.RDESR
          RJM    FAW         FUNCTION FOR ERROR REGISTER READ
          ZJN    GER20       IF NO ERRORS
          LDN    0
          UJN    GER30       RETURN
          SPACE  4,2
 GERT     CON    GERT
          BSSZ   3
 GST      SPACE  4,24
**        GST - GENERAL STATUS.
*
*         THIS ROUTINE OBTAINS THE MCI GENERAL STATUS, AND WAITS FOR
*         BUSY TO CLEAR.  THE WAIT FOR BUSY IS EQUAL TO *GSBUSY*
*         MILLISECONDS.  BUSY TIMEOUT IN DIAGNOSTIC MODE CAUSES THE
*         MDI TO BE DOWNED.  ERRORS THAT OCCUR WHILE READING STATUS
*         ARE LOGGED WITH UNRECOVERED ERRORS, CHANGING THE MDI STATE TO
*         DOWN. DISCONNECTING THE CHANNEL DURING ERROR RECOVERY CAUSES THE
*         ERROR BITS IN GENERAL STATUS TO BE CLEARED.  IN THE CASE OF
*         RECOVERED ERRORS WHERE THE CHANNEL HAS BEEN DISCONNECTED AS
*         PART OF RECOVERY, BIT *S.VALID* IN *GNSTAT* IS SET TO INDICATE
*         THIS CONDITION.
*
*         EXIT   (A) = 0, IF NO ERRORS.
*                    <> 0, IF ERROR.
*                (GNSTAT) = GENERAL STATUS IF NO ERRORS.
*
*         USES   T2, T7, T8, P6.
*
*         CALLS  CFT, FTO, GBT, GER, LGE, SSC.
          SPACE  4,10
 GST      SUBR               ENTRY/EXIT
          LDN    FTRY
          STDL   T7          RETRY COUNTER
          LDN    0
          STDL   T8          CLEAR VALID STATUS INDICATOR
          STDL   P6
          LCN    0
          STDL   GNSTAT
 GST20    DCN    CHN+40B
          LDC    F.GS        GENERAL STATUS
          STDL   FUNCD
          LDC    GSTB        STATUS RETURN
          RJM    FTO         FUNCTION CHANNEL
          ZJN    GST25       IF NO RETRIES
          LDC    GSTB
          RJM    CFT         CHECK FOR FUNCTION TIMEOUT
          NJN    GSTX        EXIT IF FUNCTION TIMEOUT
 GST25    ACN    CHN
          LDK    GSBUSY/500  SET BUSY TIMER
          STML   GBTM
          LCN    0
          STML   GBTL
 GST30    LDC    GSFULL*400  WAIT FOR FULL
 GST40    IJM    GST92,CHN    IF CHANNEL INACTIVE

 GST50    FJM    GST60,CHN   IF CHANNEL FULL
          SBN    1
*         SBN    1           (IF 4X PP SPEED)
*         SBN    2           (IF 2X PP SPEED)
 GSTA     EQU    *-1
          NJN    GST40       IF NOT TIMED OUT
          UJK    GST100      LOG ERROR AND CHECK RECOVERY STATUS

 GST60    IAN    CHN+40B     INPUT STATUS
          IJM    GST92,CHN    IF CHANNEL INACTIVE
          CFM    GST70,CHN   IF NO CHANNEL ERROR
          LDDL   T7
          SBN    FTRY
          NJN    GST65       IF NOT FIRST ERROR
          RJM    GER         RECORD ERROR REGISTER
 GST65    UJK    GST100      RETRY IF NOT UNRECOVERED

 GST70    STDL   GNSTAT
          SHN    17-S.BUSY
          PJN    GST90       IF NOT MCI BUSY
          RJM    GBT         CHECK BUSY TIMEOUT
          NJN    GST91       IF TIMEOUT
 GST80    UJK    GST30       RETRY

 GST90    DCN    CHN+40B
          LDDL   T7
          SBN    FTRY
          NJN    GST130      IF RECOVERED ERROR
 GST91    UJK    GSTX        EXIT NO ERRORS

*         ERROR ENCOUNTERED READING STATUS
*         DETERMINE RECOVERY ACTION.

 GST92    LDK    /RS/K.LSCD  LOG CHANNEL NOT ACTIVE
 GST100   STDL   P6          SAVE SYMPTOM CODE
          SODL   T7
          ZJN    GST130      IF UNRECOVERED ERROR
          SBN    FTRY-1
          NJN    GST120      IF NOT FIRST ERROR
          LDDL   P6
          STDL   T2          SYMPTOM CODE
 GST120   LDC    VALID
          STDL   T8          SAVE ERROR STATUS NOT CORRECT
          UJK    GST20       SEND FUNCTION AGAIN

 GST130   DCN    CHN+40B
          LDDL   GNSTAT

*         SET INVALID BIT INDICATING RECOVERY DISCONNECTED MCI.

          LMDL   T8
          STDL   GNSTAT
          LDDL   T2
          RJM    SSC         SET SYMPTOM CODE
          RJM    LGE         COMPLETE LOGGING ERROR
          UJK    GST91       EXIT
          SPACE  2
 GSTB     BSSZ   2
 IFR      SPACE  4,12
**        IFR - INITIATE FUNCTION REQUEST.
*
*         THIS ROUTINE INITIATES A FUNCTION REQUEST
*         ON THE CHANNEL.
*
*         ENTRY  (A) = FUNCTION CODE.
*
*         EXIT   (A) = 0, FUNCTION ISSUED, NORMAL COMPLETION.
*                (A) <> 0, FUNCTION TIMEOUT.
*
*         CALLS  CFT, CSC, FTO.


 IFR      SUBR               ENTRY/EXIT
          STDL   FUNCD       SAVE FUNCTION CODE
          STML   IFRSV
          LDC    IFRST       STATUS AREA POINTER
          RJM    FTO         FUNCTION AND TIMEOUT
          ZJN    IFRX        IF NO RETRIES
          LDML   IFRST+FTO.RC
          NJN    IFR10       IF NOT UNRECOVERED ERROR
          RJM    CSC         CHECK STATE CHANGE
          NJN    IFRX        EXIT IF STATE CHANGE
          LDML   DBUGM
          SBN    1
          NJN    IFRX        IGNORE ERROR IF DEBUG MODE
          LDML   IFRSV
          STDL   FUNCD       RESTORE FUNCTION CODE
 IFR10    LDC    IFRST
          RJM    CFT         CHECK FOR FUNCTION TIMEOUT
          UJK    IFRX        RETURN
          SPACE  4
 IFRST    BSSZ   2           STATUS RETURN AREA
 IFRSV    BSSZ   1           SAVE FUNCTION CODE
 ILR      SPACE  4,10
**        ILR - INITIALIZE LOG RESPONSE.
*
*         INITIALIZE THE BUFFER FOR SENDING LOG RESPONSES.
*
*         USES   T9.


 ILR      SUBR               ENTRY/EXIT
          LDN    P.RS
          STDL   T9
 ILR10    LDN    0
          STML   LRS,T9
          SODL   T9
          PJN    ILR10       IF MORE TO CLEAR
          LDML   DEVID
          STML   LRS+/RS/P.DEVID
          LDN    REC.U
          STML   LRS+/RS/P.RETSUC
          UJN    ILRX        EXIT
 IRE      SPACE  4,10
**        IRE - ISSUE READ ERROR FUNCTION.
*
*         THIS ROUTINE IS CALLED WHEN A READ ERROR HAS
*         OCCURRED, BUT THE MDI IS UNAWARE OF IT.  THE
*         READ ERROR FUNCTION IS ISSUED TO NOTIFY THE MDI
*         OF THIS FACT.
*
*         CALLS  IFR.


 IRE      SUBR               ENTRY/EXIT
          LDN    F.RERR      READ ERROR FUNCTION
          RJM    IFR         ISSUE FUNCTION
          UJK    IREX        EXIT
 LGE      SPACE  4,16
**        LGE - LOG GENERAL STATUS ERRORS.
*
*         THIS ROUTINE COMPLETES LOGGING OF ERRORS ENCOUNTERED
*         WHILE READING GENERAL STATUS.
*
*         ENTRY  (T7) = 0 IF UNRECOVERED ERROR.
*                    = FTRY - RETRIES IF RECOVERED ERROR.
*                (LRS+/RS/P.LSGSE) = SYMPTOM CODE.
*
*         EXIT   (A) = 0 IF NO ERRORS OR RECOVERED ERRORS.
*                    <> 0 IF UNRECOVERED ERRORS.
*
*         USES   T7.
*
*         CALLS  SLM, SRU.


 LGE10    LDN    1

 LGE      SUBR               ENTRY/EXIT
          LDML   LRS+/RS/P.LSGSE
          NJN    LGE30       IF NOT AVAILABLE TIMEOUT

*         A GENERAL STATUS AVAILABLE TIMEOUT CAN OCCUR IF THE MDI
*         RESETS AFTER ACCEPTING THE FUNCTION BUT BEFORE THE STATUS
*         IS INPUT.  IN THIS CASE IF WE RECOVERED AND THE STATE IS
*         EQUAL TO RESET WE IGNORE THE ERROR.

          LDDL   T7
          SBN    FTRY-1
          NJN    LGE20       IF NOT RETRY COUNT OF ONE
          LDDL   GNSTAT
          LPC    STBITS
          ZJK    LGEX        IF ONLY ONE UNAVAILABLE ERROR, IGNORE
 LGE20    LDN    /RS/K.LGSAT
          STML   LRS+/RS/P.ERRID
          LDML   PREFC
          STML   LRS+/RS/P.PFUNC SAVE PREVIOUS FUNCTION CODE
          LDDL   LSTATE
          STML   LRS+/RS/P.ERRW2
          UJN    LGE40

 LGE30    LDK    /RS/K.LOF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDK    /RS/K.LRGS
          STML   LRS+/RS/P.OPTP  STORE OPERATION TYPE
 LGE40    LDDL   T7
          NJN    LGE50       IF NOT UNRECOVERED
          LDN    ST.PPD
          STDL   STCHNG      DOWN MDI
          LDDL   T7
 LGE50    RJM    SRU         SET RESPONSE STATUS
          RJM    SLM         SEND LOG MESSAGE
          LDDL   T7
          ZJK    LGE10       IF UNRECOVERED EXIT
          LDN    0
          UJK    LGEX        EXIT NO ERRORS
 RDO      SPACE  4,12
**        RDO - READ OVERLAY.
*
*         THIS ROUTINE WILL READ THE APPROPRIATE OVERLAY.
*
*         ENTRY  (A) = NUMBER OF OVERLAY TO LOAD.
*                    = 0 IF NOT IN OVERLAY.
*                (OVNUM) = NUMBER OF LAST OVERLAY LOADED.
*
*         EXIT   (OVNUM) = NUMBER OF OVERLAY LOADED.
*
*         USES   T1, WC.
*
*         CALLS  CHG, LNO.


 RDO      SUBR               ENTRY/EXIT
          ZJN    RDOX        IF NOT IN OVERLAY
          STDL   T1          SAVE OVERLAY NUMBER
          SBML   OVNUM
          ZJN    RDOX        IF ALREADY LOADED
          LDDL   T1
          STML   OVNUM       SAVE NEW OVERLAY NUMBER
          RJM    LNO         LOAD OVERLAY
          LDML   OVNUM
          RJM    CHG         CHANGE CHANNEL INSTRUCTIONS
          UJN    RDOX        EXIT
 SLM      SPACE  4,15
**        SLM - SEND LOG MESSAGE.
*
*         THIS ROUTINE SENDS A LOG MESSAGE RESPONSE
*         GENERAL STATUS AND/OR DETAILED STATUS
*         INCLUDED IN RESPONSE DETERMINE LENGTH
*         OF RESPONSE.
*
*         EXIT   (A) < 0.
*
*         USES   T9.
*
*         CALLS  ILR, UIP, WRB.


 SLM      SUBR               ENTRY/EXIT
          LDDL   STCHNG
          SBN    ST.PPD
          NJN    SLM10       IF NOT DOWN
          LDC    /RS/K.DICA
          RAML   LRS+/RS/P.LGS  SET DOWN MDI FLAG
 SLM10    LDML   LRS+/RS/P.LGS
          LPC    /RS/K.LDS
          NJN    SLM20       IF DETAILED STATUS INCLUDED
          LDC    /RS/C.RETSUC*8+8  RESPONSE LENGTH
          UJN    SLM30       CONTINUE

 SLM20    LDC    C.RS*8      RESPONSE LENGTH
 SLM30    STML   LRS+/RS/P.RESPL
          LDN    URC.LM
          STML   LRS+/RS/P.URC  SET LOG MESSAGE
          LDML   UNIT        SAVE LOGICAL UNIT
          STML   LRS+/RS/P.LU
          LDC    LRS
          RJM    WRB         WRITE RESPONSE BUFFER
          RJM    UIP         UPDATE INPUT POINTER
          RJM    ILR         INITIALIZE LOG RESPONSE
          UJK    SLMX        EXIT
 UIP      SPACE  4,12
**        UIP - UPDATE THE IN POINTER OF THE CM RESPONSE BUFFER.
*
*         ENTRY  (INPNT) = NEW IN POINTER.
*
*         USES   P1 - P4.
*
*         MACROS LOADC.
*         THIS ROUTINE UPDATES THE RESPONSE BUFFERS IN POINTER
*         AND INTERRUPTS THE CP. THE CP IS INTERRUPTED FOR EVERY
*         UNSOLICITED RESPONSE AND EVERY EIGHTH SOLICITED RESPONSE.
*


 UIP      SUBR               ENTRY/EXIT

*         UPDATE THE IN POINTER.

          LDN    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDDL   INPNT       NEW IN POINTER
          STDL   P4
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.IN   OFFSET OF IN POINTER
          CWDL   P1          WRITE NEW IN POINTER TO CM

*         INTERRUPT PROCESSOR. WRB ROUTINE SETS UP -INTPRC-.

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   PPNO-3      SET LAST BYTE NON-ZERO
          LDDL   RESPC
          ZJN    UIP10       IF UNSOLICITED RESPONSE
          SOML   INTRRPT
          PJN    UIP20       IF NOT TIME TO INTERRUPT
 UIP10    BSS    0
          LDML   CM.INT+2    ** KLUDGE FOR I4 CHECKING OS BOUNDS ON INTERRUPT
          LMC    400000B     ** KLUDGE FOR I4 BUG
 INTPRC   PSN                PSN OR INTERRUPT
          CRDL   P1          FOR S1CR HARDWARE PROBLEM
          LDN    8
          STML   INTRRPT     RESET INTERRUPT INTERVAL
 UIP20    UJK    UIPX


 INTRRPT  BSSZ   1           INTERRUPT INTERVAL
 WRB      SPACE  4,10
**        WRB - WRITE RESPONSE BUFFER TO CM RESPONSE BUFFER.
*
*               THERE ARE TWO PP RESPONSE BUFFERS.
*
*         ENTRY  (A) = PP RESPONSE BUFFER ADDRESS.
*
*         USES   P1 - P5, T1, T2, T3, T4, T5, T9.
*
*         MACROS LOADC.


 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  2
 WRB      SUBR               ENTRY/EXIT
          STDL   T9
          STML   WRBA        INSTRUCTION MODIFICATION FOR BUFFER

*         READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 WRB10    BSS
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF IN POINTER
          CRDL   P1          READ IN POINTER

*         CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDDL   INP
          SBDL   OUTP
          MJN    WRB20       IF IN .LT. OUT
          LDML   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP
 WRB20    LDML   /RS/P.RESPL,T9  GET RESPONSE LENGTH
          STDL   INPNT
          LDN    0
          STDL   T2          FLAG TO DETERMINE IF 1 OR 2 BLOCK WRITES
          LDDL   INP
          RADL   INPNT       IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          PJN    WRB10       IF NOT ENOUGH ROOM IN BUFFER, LOOP
          LDDL   INPNT
          SBML   LIM
          MJN    WRB40       IF IN + RESPONSE LENGTH .LT. LIMIT
          STDL   INPNT       IN + RESPONSE LENGTH - LIMIT = NEW IN POINTER
          AODL   T2          2 BLOCK WRITES REQUIRED

*         WRITE RESPONSE TO CM.

 WRB40    LDDL   INP
          SHN    -3
          STDL   T3          IN POINTER IN WORDS
          LDML   /RS/P.RESPL,T9  CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          STDL   T5
          LDDL   T2
          ZJN    WRB50       IF ONLY 1 BLOCK WRITE REQUIRED
          LDML   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON FIRST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADDL   T9
          STML   WRBB        RESPONSE ADDRESS FOR SECOND BLOCK WRITE
 WRB50    LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD IN OFFSET
          CWML   RS,T4       WRITE RESPONSE TO CM

*         CWML   (A),T4      ENTRY CONDITION SPECIFIES BUFFER ADDRESS

 WRBA     EQU    *-1
          LDDL   T5          RESPONSE LENGTH
          SBDL   T4
          ZJN    WRB70       IF ONLY 1 BLOCK WRITE REQUIRED
          STDL   T5          RESPONSE LENGTH - (LIMIT - IN)
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          LMC    400000B
          CWML   **,T5       WRITE SECOND PART OF RESPONSE TO CM
                             (BEGINNING OF RESPONSE BUFFER)
 WRBB     EQU    *-1

*         SET UP INTERRUPT PROCESSOR INSTRUCTION IF INTERRUPT IS SELECTED.

 WRB70    BSS
          LDML   RS+/RS/P.INT  CHECK IF INTERRUPT WAS SELECTED
          LPC    /RS/K.INT
          ZJN    WRB80       IF INTERRUPT WAS NOT SELECTED

*         AFTER THE FIRST REQUEST SELECTING INTERRUPT IS PROCESSED,
*         ALL FOLLOWING RESPONSES WILL ALSO SEND AN INTERRUPT.

          LDML   RS+/RS/P.PORT  GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RS/L.PORT+/RS/N.PORT
          LPN    /RS/M.PORT
          ADC    .INPN
          STML   INTPRC
 WRB80    BSS    0
          UJK    WRBX        EXIT
*copy nai$network_common_deck
          TITLE  BUFFER AREA.
**        LOCATIONS OF BUFFERS USED AFTER INITIALIZATION ARE DEFINED
*         HERE.  OVERLAY 2 IS ASSEMBLED IN THESE BUFFERS AND MUST BE
*         MOVED BEFORE THEY ARE USED.
          SPACE  4,25
 RS       BSSZ   MAXRS*4     RESPONSE BUFFER
 LRS      BSSZ   P.RS+4      LOGGING RESPONSE BUFFER
 MCT      BSSZ   P.MCT       MASTER CONTROL TABLE
 BP       BSSZ   P.BP        BUFFER POOL TABLE ENTRY
 BPD      BSSZ   P.BPD       BUFFER POOL DESCRIPTOR
 BPDSIZE  BSSZ   MAXBPD      BUFFER POOL SIZES
 BPRMA    BSSZ   MAXRS*2-/RS/C.BUFPVA*2   BUFFER POOL CONTAINER RMAS

 INTOV    EQU    *           FIRST WORD ADDRESS OF INITIALIZATION ROUTINES
 RQ       EQU    INTOV       REQUEST BUFFER
 CM       EQU    RQ+/RQ/P.CMND  COMMAND PORTION OF REQUEST
 PREBUF   EQU    RQ+MAXURQ*4 I/O BUFFER PREFIX USED WHEN 170 OAM IS NEEDED
 IOBUF    EQU    PREBUF+2    I/O BUFFER
 IOBLEN   EQU    MINLEN      I/O BUFFER SIZE
 I1       EQU    IOBLEN*2*2/3
          IFPL   I1*3-IOBLEN*2*2
 CHCNT    EQU    I1
          ELSE
 CHCNT    EQU    I1+1
          ENDIF
 BUFEND   EQU    IOBUF+MINLEN  MINIMUM BUFFER SPACE REQUIRED
 BPDEND   EQU    BPDSIZE+MAXBPD

          LOC    INTOV

          ERRMI  END-BUFEND  RESIDENT TOO LARGE
          TTL    NAM$MDI DRIVER (NETW).
          TITLE  INITIALIZATION ROUTINES.
**        INT - INITIALIZE PP DRIVER.
*
*         ESTABLISHES ACCESS TO CENTRAL MEMORY TABLES AFTER DEADSTART.
*
*         ENTRY  (DSRTP) = CENTRAL MEMORY ADDRESS OF WORD CONTAINING
*                          POINTER TO SP-ADDRS-ARRAY.


 INT      BSS    0           ENTRY
          LDDL   P1
          STML   DRNAME
          LDDL   P2
          STML   DRNAME+1
          RJM    LPT         LOCATE PP INTERFACE TABLE
          RJM    ILC         INITIALIZE LOOP COUNTERS
          RJM    LUT         LOCATE UNIT INTERFACE TABLE
          RJM    LMT         LOCATE MASTER CONTROL TABLE
*         LDN    0
          RJM    CHG         SET UP CHANNEL INSTRUCTIONS
          RJM    ZRE         ZERO OUT RESPONSE BUFFER
          RJM    ILR         INITIALIZE LOG RESPONSE
          UJK    DCS         DETERMINE CURRENT MDI STATE
          EJECT
 LMT      SPACE  4,15
**        LMT - LOCATE MASTER CONTROL TABLE.
*
*         ESTABLISHES ACCESS TO THE MASTER CONTROL TABLE.
*
*         ENTRY  (CM.URQ - CM.URQ+1) = (R) PART OF MASTER CONTROL TABLE FWA.
*                (CM.MCT) = (A) PORTION OF MASTER CONTROL TABLE FWA.
*                (C.MCT) = LENGTH OF MASTER CONTROL TABLE.
*
*         CALLS  CVM, DBP.
*
*         MACROS LOADC.


 LMT      SUBR               ENTRY/EXIT

*         VALIDATE MASTER CONTROL TABLE.

          RJM    CVM         CHECK FOR VALID MASTER CONTROL TABLE
          NJN    *           IF INVALID MASTER CONTROL TABLE  --HANG--

*         DEFINE AND VALIDATE BUFFER POOLS.

          RJM    DBP         DEFINE BUFFER POOLS
          ZJN    LMTX        IF VALID BUFFER POOLS  --EXIT--
          UJN    *           INVALID BUFER POOLS, SO  --HANG--
          EJECT
**        LPT - LOCATE PP INTERFACE TABLE.
*
*         ESTABLISHES ACCESS TO THE PP INTERFACE TABLE.
*
*         ENTRY  (DSRTP) = CENTRAL MEMORY BYTE ADDRESS OF PP INTERFACE TABLE.
*
*         USES   WC.
*
*         CALLS  CVP, CVR.
*
*         MACROS LOADC, REFAD.


 LPT      SUBR               ENTRY/EXIT
          REFAD  DSRTP,CM.PIT  REFORMAT PP INTERFACE TABLE ADDRESS

*         READ PP INTERFACE TABLE.

          LDN    C.PIT       LENGTH OF PP INTERFACE TABLE
          STDL   WC
          LOADC  CM.PIT
          CRML   IPIT,WC
          RJM    CVR         CHECK FOR VALID RESPONSE BUFFER
          NJN    *           IF INVALID RESPONSE BUFFER  --HANG--
          RJM    CVP         CHECK FOR VALID PP INTERFACE TABLE
          NJN    *           IF INVALID PP INTERFACE TABLE  --HANG--
          LDML   IPIT+/PIT/P.PPNO
          STDL   PPNO        PP NUMBER

*         REFORMAT CM ADDRESSES OF INTERRUPT WORD AND CHANNEL INTERLOCK TABLE.

          REFAD  IPIT+/PIT/P.INT,CM.INT  REFORMAT INTERRUPT WORD ADDRESS
          REFAD  IPIT+/PIT/P.CHAN,CM.CHAN  REFORMAT CHANNEL TABLE ADDRESS
          REFAD  IPIT+/PIT/P.CBUF,CM.CB  REFORMAT COMMUNICATION TABLE ADDRESS
          LOADC  CM.CB
          ADN    /CB/C.DRMA
          CRDL   P1
          REFAD  P3,DH       REFORMAT OVERLAY DIRECTORY RMA
          UJK    LPTX
          EJECT
 LUT      SPACE  4,15
**        LUT - LOCATE UNIT INTERFACE TABLE.
*
*         ESTABLISHES ACCESS TO THE UNIT INTERFACE TABLE.
*
*         ENTRY  (CM.PIT - CM.PIT+2) = CM ADDRESS OF PP INTERFACE TABLE.
*
*         EXIT   (A) = 0.
*                (UD) = UNIT DESCRIPTOR ACCESSIBLE BY THIS PP.
*
*         USES   WC.
*
*         CALLS  CVD, CVU.
*
*         MACROS LOADC, LOADF.


 LUT      SUBR               ENTRY/EXIT
          LDN    C.UD        UNIT DESCRIPTOR LENGTH
          STDL   WC
          LOADC  CM.PIT
          ADN    C.PIT
          CRML   UD,WC       READ UNIT DESCRIPTOR
          RJM    CVD         CHECK FOR VALID UNIT DESCRIPTOR
          NJN    *           IF INVALID UNIT DESCRIPTOR  --HANG--
          LDML   UD+/UD/P.CHAN
          SHN    /UD/L.CHAN+/UD/N.CHAN+2
          LPN    37B
          STML   CHAN        CHANNEL NUMBER
          LDML   UD+/UD/P.LU
          STML   UNIT        LOGICAL UNIT NUMBER
          LDN    C.UIT       UNIT INTERFACE TABLE LENGTH
          STDL   WC
          LOADF  UD+/UD/P.UQT  REFORMAT CM ADDRESS OF UNIT INTERFACE TABLE
          CRML   UBUF,WC     READ UNIT INTERFACE TABLE
          RJM    CVU         CHECK FOR VALID UNIT INTERFACE TABLE
          NJN    *           IF INVALID UNIT INTERFACE TABLE  --HANG--
          UJK    LUTX        EXIT
          EJECT
**        SAVAD - SAVE REFORMATTED CM ADDRESSES.
*
*         THIS ROUTINE IS CALLED ONLY DURING INITIALIZATION
*         AND ONLY BY THE *REFAD* MACRO.
*
*         USES   T2.
          SPACE  2
 SAVAD    SUBR               ENTRY/EXIT
          STML   2,T2
          LDDL   CMADR
          STI    T2
          LDDL   CMADR+1
          STML   1,T2
          UJN    SAVADX      EXIT
 CVM      SPACE  4,10
**        CVM - CHECK FOR VALID MASTER CONTROL TABLE.
*
*         ENTRY  (CM.URQ - CM.URQ+1) = (R) PART OF MASTER CONTROL TABLE FWA.
*                (CM.MCT) = (A) PORTION OF MASTER CONTROL TABLE FWA.
*
*         EXIT   (A) = 0, IF VALID MASTER CONTROL TABLE.
*                    <> 0, IF INVALID.
*
*         USES   P1 - P4, T1, WC.


 CVM      SUBR               ENTRY/EXIT
          LDN    0
          STDL   T1          UNIT INTERFACE ERROR CODE

*         READ MASTER CONTROL TABLE.

          LDN    C.MCT       LENGTH OF MASTER CONTROL TABLE
          STDL   WC

 CVM20    BSS    0
          LOADC  CM.URQ,CM.MCT   FIRST WORD ADDRESS OF MASTER CONTROL TABLE
          CRML   MCT,WC
          LDML   MCT+/MCT/P.FLAGS   MASTER CONTROL TABLE INITIALIZED FLAG
          SHN    17-/MCT/INIT
          PJN    CVM20       IF MASTER CONTROL TABLE NOT INITIALIZED
          LDML   MCT+/MCT/P.DEVID   DEVICE ID
          STML   DEVID       SAVE DEVICE IDENTIFIER

*         RESERVED FIELD OF UNIT REQUEST QUEUE DESCRIPTOR.

          LDML   UBUF+/UIT/P.NEXTPV-1
          ADML   UBUF+/UIT/P.NEXT-2
          ADML   UBUF+/UIT/P.NEXT-1
          NJN    CVM80       IF RESERVED FIELD NOT ZERO
 CVM70    UJK    CVMX        EXIT

 CVM80    BSS
          LDML   TUEM,T1     INTERFACE ERROR CODE
          UJK    CVM70

**        TUEM - TABLE OF UNIT INTERFACE ERROR MESSAGES.

 TUEM     BSS    0
          LOC    0
          CON    E305        RESERVED FIELD OF UNIT REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
          LOC    *O
          SPACE  4,10
 CONCH    BSS                MDI CHANNEL REFERENCES
 TCHN+40B HERE
 T40B+CHN HERE
 TCHN     HERE
          CON    0           END OF TABLE
          SPACE  4,10

**        BUFFERS USED AFTER CVP IS EXECUTED ARE PLACED HERE

 UBUF     EQU    *           UNIT INTERFACE TABLE
 UD       EQU    UBUF+P.UIT  UNIT DESCRITOR
 UDEND    EQU    UD+P.UD     END OF UNIT DESCRIPTOR
 CVP      SPACE  4,10
**        CVP - CHECK FOR VALID PP INTERFACE TABLE.
*
*         EXIT   (A) = 0, IF VALID PP INTERFACE TABLE.
*                    <> 0, IF INVALID.
*
*         USES   T1.


 CVP      SUBR               ENTRY/EXIT
          LDN    0
          STDL   T1
          LDML   IPIT+/PIT/P.CBUFL  COMMUNICATION BUFFER LENGTH
          LPN    7
          NJK    CVP10       IF LENGTH NOT A MULTIPLE OF WORDS
          LDML   IPIT+/PIT/P.CBUFL  COMMUNICATION BUFFER LENGTH
          SHN    -3
          ADC    -C.CB
          MJN    CVP10       IF NOT LARGE ENOUGH
          AODL   T1

*         RESERVED WORD OF PP COMMUNICATION BUFFER DESCRIPTOR

          LDML   IPIT+/PIT/P.CBUFL-1
          NJN    CVP10       IF RESERVED WORD NOT ZERO
          AODL   T1
          LDML   IPIT+/PIT/P.CBUF+1  COMMUNICATION BUFFER (RMA)
          LPN    7
          NJN    CVP10       IF PP COMMUNICATION BUFFER NOT A WORD BOUNDARY
          AODL   T1

*         RESERVED FIELD OF PP REQUEST QUEUE DESCRIPTOR

          LDML   IPIT+/PIT/P.PPQPVA-1
          ADML   IPIT+/PIT/P.PPQ-2
          ADML   IPIT+/PIT/P.PPQ-1
          NJN    CVP10       IF RESERVED FIELD NOT ZERO
          AODL   T1
          LDML   IPIT+/PIT/P.INT+1  INTERRUPT WORD (RMA)
          LPN    7
          NJN    CVP10       IF INTERRUPT WORD NOT A WORD BOUNDARY
          AODL   T1
          LDML   IPIT+/PIT/P.CHAN+1  CHANNEL INTERLOCK TABLE (RMA)
          LPN    7
          ZJN    CVP15       IF PP INTERFACE TABLE VALID
 CVP10    LDML   TPEC,T1     INTERFACE ERROR CODE
 CVP15    UJK    CVPX        EXIT

**        TPEC - TABLE OF PP INTERFACE ERROR CODES.

 TPEC     BSS    0
          LOC    0
          CON    E20B        COMMUNICATION BUFFER LENGTH NOT A
                             MULTIPLE OF WORDS
          CON    E204        RESERVED WORD OF PP COMMUNICATION
                             BUFFER DESCRIPTOR NOT ZERO
          CON    E203        PP COMMUNICATION BUFFER NOT A WORD BOUNDARY
          CON    E205        RESERVED FIELD OF PP REQUEST QUEUE
                             DESCRIPTOR NOT ZERO
          CON    E211        RMA OF INTERRUPT WORD NOT A WORD BOUNDARY
          CON    E212        RMA OF CHANNEL INTERLOCK TABLE NOT A WORD BOUNDARY
          LOC    *O
          ERRMI  *-UDEND     IF BUFFERS LARGER THAN CVD
 CVD      SPACE  4,10
**        CVD - CHECK FOR VALID UNIT DESCRIPTOR.
*
*         EXIT   (A) = 0, IF VALID UNIT DESCRIPTOR.
*                    <> 0, IF INVALID.


 CVD      SUBR               ENTRY/EXIT
          LDML   UD+/UD/P.LU  LOGICAL UNIT
          SBML   IPIT+/PIT/P.FLU  FIRST LOGICAL UNIT
          PJN    CVD10
          LDC    E208        LOGICAL UNIT NOT IN RANGE
          UJK    CVD60

 CVD10    BSS
          LDML   UD+/UD/P.CHAN  CHANNEL NUMBER
          SHN    /UD/L.CHAN+/UD/N.CHAN+2
          LPN    37B
          SBN    14B         VALID CHANNELS ARE 0 - 13B AND 20B - 33B
          MJN    CVD40       IF CHANNEL OK
          SBN    20B-14B
          PJN    CVD30       IF CHANNEL OK
 CVD20    BSS
          LDC    E20A        INVALID CHANNEL NUMBER
          UJN    CVD60

 CVD30    BSS
          SBN    34B-20B
          PJN    CVD20       IF INVALID CHANNEL
 CVD40    BSS
          LDML   UD+/UD/P.UQT+1  UNIT INTERFACE TABLE ADDRESS
          LPN    7
          ZJN    CVDX
          LDC    E209        UNIT INTERFACE TABLE NOT A WORD BOUNDARY
 CVD60    BSS
          UJK    CVDX        EXIT
 CVU      SPACE  4,10
**        CVU - CHECK FOR VALID UNIT INTERFACE TABLE.
*
*         EXIT   (A) = 0, IF VALID UNIT INTERFACE TABLE,
*                    <> 0, IF INVALID.
*                (CM.URQ - CM.URQ+1) = (R) PART OF MASTER CONTROL TABLE FWA.
*                (CM.MCT) = (A) PORTION OF MASTER CONTROL TABLE FWA.
*
*         USES   T1.


 CVU      SUBR               ENTRY/EXIT
          LDN    0
          STDL   T1
          LDML   UBUF+/UIT/P.LU  LOGICAL UNIT NUMBER
          SBML   UD+/UD/P.LU
          NJN    CVU20       LOGICAL UNIT NUMBER MISMATCH
          AODL   T1
          LDML   UBUF+/UIT/P.UTYPE  UNIT TYPE
          ADC    -1000B
          NJK    CVU40       IF INVALID UNIT TYPE
          AODL   T1

*         RESERVED FIELD OF MASTER CONTROL TABLE DESCRIPTOR

          LDML   UBUF+/UIT/P.MBUFL-1
          NJK    CVU40       RESERVED FIELD IS NOT ZERO
          AODL   T1
          LDML   UBUF+/UIT/P.MBUFL  MASTER CONTROL TABLE LENGTH
          ADC    -B.MCT      COMPARE WITH EXPECTED MASTER CONTROL TABLE LENGTH
          MJN    CVU20       IF BUFFER NOT LONG ENOUGH
          LPN    7
          ZJN    CVU30       IF BUFFER ON WORD BOUNDRY
 CVU20    UJK    CVU40       INTERFACE ERROR

 CVU30    BSS
          AODL   T1
          LDML   UBUF+/UIT/P.MBUF+1  MASTER CONTROL TABLE
          LPN    7
          NJN    CVU40       NOT A WORD BOUNDARY
          LOADF  UBUF+/UIT/P.MBUF
          STDL   CM.URQ+2
          SRD    CM.URQ
          STML   CM.MCT
          LDN    0           VALID UNIT INTERFACE TABLE
 CVU38    UJK    CVUX        EXIT

 CVU40    BSS
          LDML   TUEC,T1     INTERFACE ERROR CODE
          UJK    CVU38

**        TUEC - TABLE OF UNIT INTERFACE ERROR CODES.

 TUEC     BSS    0
          LOC    0
          CON    E301        LOGICAL UNIT NUMBER MISMATCH
          CON    E306        INVALID UNIT TYPE
          CON    E303        RESERVED FIELD OF MASTER CONTROL TABLE
                             DESCRIPTOR IS NOT ZERO
          CON    E307        MASTER CONTROL TABLE LENGTH NOT A
                             MULTIPLE OF WORDS
          CON    E302        MASTER CONTROL TABLE NOT A WORD BOUNDARY
          LOC    *O
 CVR      SPACE  4,10
**        CVR - CHECK FOR VALID RESPONSE BUFFER.
*
*         EXIT   (A) = 0, IF VALID RESPONSE BUFFER.
*                    <> 0, IF INVALID.
*                (CM.RS - CM.RS+2) = CM ADDRESS OF RESPONSE BUFFER.
*
*         MACROS LOADF.


 CVR      SUBR               ENTRY/EXIT

*         RESERVED WORD OF RESPONSE BUFFER DESCRIPTOR
          LDML   IPIT+/PIT/P.RSBUF-2
          ADML   IPIT+/PIT/P.RSBUF-1
          ADML   IPIT+/PIT/P.RSPVA-1
          NJN    CVR05       IF RESERVED FIELD NOT ZERO
          LDML   IPIT+/PIT/P.IN-3  RESERVED FIELD OF IN POINTER
          ADML   IPIT+/PIT/P.IN-2
          ADML   IPIT+/PIT/P.IN-1
 CVR05    NJN    CVR10       IF RESERVED FIELD NOT ZERO
          LDML   IPIT+/PIT/P.OUT-3  RESERVED FIELD OF OUT POINTER
          ADML   IPIT+/PIT/P.OUT-2
          ADML   IPIT+/PIT/P.OUT-1
          NJN    CVR10       IF RESERVED FIELD NOT ZERO
          LDML   IPIT+/PIT/P.LIMIT-3  RESERVED FIELD OF LIMIT POINTER
          ADML   IPIT+/PIT/P.LIMIT-2
          ADML   IPIT+/PIT/P.LIMIT-1
          NJN    CVR10       IF RESERVED FIELD NOT ZERO
*         RESPONSE BUFFER VALID - REFORMAT INTO CM.RS - CM.RS+2.

          LOADF  IPIT+/PIT/P.RSBUF REFORMAT ADDRESS OF REPONSE BUFFER
          STDL   CM.RS+2
          SRD    CM.RS
          LDML   IPIT+/PIT/P.LIMIT
          STML   LIM         LIMIT OF RESPONSE BUFFER
          LDN    0
 CVR10    UJK    CVRX        EXIT
 DBP      SPACE  4,16
**        DBP - DEFINE BUFFER POOLS PROCESSOR.
*
*         THIS ROUTINE DOES THE INITIAL PROCESSING OF BUFFER POOL
*         DESCRIPTORS.  A TABLE CONTAINING THE LENGTHS OF THE
*         BUFFERS IN THE POOLS IS CREATED AT LOCATION
*         *BPDSIZE*.  THE CM ADDRESS OF THE FIRST DESCRIPTOR
*         IS ALSO SET UP.
*
*         EXIT   (A) = 0, IF NO ERRORS.
*                (A) <> 0, IF ERRORS.
*
*         USES   P1, P2, WC.
*
*         CALLS  PIE.
*
*         MACROS LOADC, LOADF.


 DBP      SUBR               ENTRY/EXIT
          ERRNG  MAXBPD-1    NO BUFFER POOLS
          LDK    MAXBPD
          STML   NUMBP       NUMBER OF BUFFER POOLS
          STDL   P2

          LDN    0
          STDL   FSTBD       RESET FSTBD
          LDN    C.BPD
          STDL   WC          LENGTH OF BUFFER POOL DESCRIPTOR
          LOADF  MCT+/MCT/P.BP  REFORMAT CM ADDRESS OF FIRST BUFFER DESCRIPTOR
          STDL   CM.BPD+2
          SRD    CM.BPD
 DBP10    CRML   BPD,WC      READ BUFFER POOL DESCRIPTOR
          STDL   P1          (A) OFFSET TO NEXT BUFFER POOL DESCRIPTOR
          LDML   BPD+/BPD/P.LEN
          NJN    *           IF BUFFER LENGTH TOO BIG
          LDML   BPD+/BPD/P.LEN+1
          PJN    DBP15       IF VALID BUFFER LENGTH
          LDC    E50B        INVALID PARAMETER SPECIFICATION
 DBP12    UJK    DBPX        EXIT

 DBP15    STML   BPDSIZE,FSTBD  SAVE BUFFER LENGTH
          SODL   P2          DECREMENT NUMBER OF POOLS REMAINING
          ZJK    DBP12       IF NO MORE POOLS
          AODL   FSTBD
          LOADC  CM.BPD,P1   CM ADDRESS OF NEXT DESCRIPTOR
          UJK    DBP10       LOOP
 ILC      SPACE  4,11
**        ILC - INITIALIZE LOOP COUNTERS BASED ON PP SPEED.
*
*         THE PURPOSE OF THIS ROUTINE IS TO INITIALIZE ALL
*         TIMERS IN THE PP TO PROVIDE CONSISTENT TIMING BETWEEN
*         2XPP AND 4XPP.
*
*         USES   T1, T2.
*
*         NOTE   12-BIT STORE AND LOAD INSTRUCTIONS ARE USED
*                IN THIS ROUTINE TO SUPPORT BOTH 12-BIT AND 16-BIT
*                MICROSECOND CLOCK CHANNELS.


 ILC      SUBR
          IAN    14B         GET MICROSECOND CLOCK
          STD    T1
          LDC    500
 ILC10    SBN    1
          NJN    ILC10       IF DELAY NOT COMPLETE
          IAN    14B         GET CURRENT TIME
          STD    T2
          LDD    T2
          SBD    T1

*         THESE TIMES SHOULD NEVER BE EQUAL.

          PJN    ILC20       IF CLOCK DID NOT WRAP
          ADC    7777B       COMPUTE THE ACTUAL CLOCK DIFFERENCE
 ILC20    ADC    -400
          MJN    ILCX        IF THE TIME < 400 MICS THEN SHOULD BE 4XPP
          LDK    .SBN+2      SWITCH TO DECREMENT BY 2 FOR 2XPP
          STML   FAWA
          STML   FTOA
          STML   GSTA
          LDN    2
          STML   TI
          LDK    .SOML
          STML   GBTA        BUSY TIMEOUT LOOP
          UJK    ILCX
          SPACE  4,10
**        THE FOLLOWING BUFFER IS USED BEFORE THE OVERLAYS CAN BE WRITTEN.

 IPIT     BSSZ   P.PIT       PP INTERFACE TABLE

          ERRPL  *-7777B     DRIVER OVERFLOWS PP MEMORY

          OVERLAY  (INPUT/OUTPUT OVERLAY),BUFEND
          ROUTINE  OV1
          TITLE  INPUT - OUTPUT ROUTINES.
**        THE FOLLOWING CODE IS OVERLAYED IN NON-DATA TRANSFER MODE
*

 CEC      SPACE  4,13
**        CEC - COMPLETE ERROR CHECKING.
*
*         THIS ROUTINE WILL COMPLETE ERROR CHECKING BY
*         LOGGING THE ERROR IF APPLICABLE.
*
*         ENTRY  (ERRT1) = SYMPTOM CODE(S) OF ERROR.
*                (OTYPE) = OPERATION CODE.
*                (ERRRCP) = POINTER TO RECOVERY COUNTER.
*
*         EXIT   (A) <> 0.
*
*         CALLS  IGS, SIU, SLM, SSC.


 CEC      SUBR               ENTRY/EXIT
          LDDL   ERRT1
          LPC    177777B-/RS/K.LSGSI
          NJN    CEC30       IF I/O ERRORS

*         IF INVALID STATUS ONLY ERROR DO NOT LOG.

          LDN    1
          UJK    CECX

 CEC30    RJM    IGS         INCLUDE GENERAL STATUS IN RESPONSE
          LDDL   ERRT1
          RJM    SSC         SET SYMPTOM CODE
          LDDL   ERRT1
          LPC    /RS/K.LSMLV&/RS/K.LSMSE
          ZJN    CEC40       IF NOT MESSAGE LENGTH ERROR
          LDML   EXPD
          STML   LRS+/RS/P.EXPD+1  INCLUDE EXPECTED LENGTH
          LDML   ACTD
          STML   LRS+/RS/P.ACTD+1  INCLUDE ACTUAL LENGTH
 CEC40    LDK    /RS/K.LOF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDML   OTYPE
          STML   LRS+/RS/P.OPTP  STORE OPERATION TYPE
          SBN    /RS/K.LREAD
          NJN    CEC50       IF NOT READ
          LDDL   LSTATE      LAST STATE
          LMK    ST.OPER     COMPARE WITH OPERATIONAL STATE
          NJN    CEC50       IF NOT OPERATIONAL STATE
          AOIL   ERRRCP
          STML   LRS+/RS/P.RETCT
          LDN    REC.I
          STML   LRS+/RS/P.RETSUC
          UJN    CEC60       SEND MESSAGE

 CEC50    SOIL   ERRRCP
          RJM    SIU         SET RECOVERY SUCCESS
 CEC60    RJM    SLM         SEND LOG MESSAGE
          UJK    CECX        EXIT
 ERR      SPACE  4,26
**        ERR - ERROR ROUTINE.
*
*         THIS ROUTINE WILL CHECK FOR ERRORS FOLLOWING
*         AN INPUT/OUTPUT OPERATION IN OPERATIONAL MODE.
*         THREE ERROR RECOVERY COUNTERS ARE MAINTAINED
*         AS FOLLOWS.
*
*         COUNTER            OPERATION
*         -------            ---------
*         WRRTY              WRITE OPERATION
*         RDRTY              READ
*         ILRTY              IN-LINE WRITE OPERATION
*
*
*         ENTRY  (A) = OPERATION CODE.
*                (ERRCNT) = WORDS NOT TRANSFERRED.
*
*         EXIT   (A) = 0 IF NO  ERRORS.
*                    <> 0 IF ERRORS.
*                (GNSTAT) = GENERAL STATUS OF I/O REQUEST.
*                (ERRT1) = SYMPTOM CODES OF ERRORS.
*                          IF RETRY COUNTER <> 0, RETRY REQUEST.
*
*
*         CALLS  CEC, CSC, GDS, GER, IER, REC, WEC.
          SPACE  4,10
 ERR      SUBR               ENTRY/EXIT
          STML   OTYPE
          SBN    /RS/K.LREAD
          NJN    ERR10       IF WRITE
          RJM    REC         READ ERROR CHECK
          ZJN    ERRX        IF NOT LAST BLOCK
          UJN    ERR20

 ERR10    RJM    WEC         WRITE ERROR RECOVERY
 ERR20    DCN    CHN+40B     DISCONNECT
          CFM    ERR30,CHN   IF NO CHANNEL ERROR
          RJM    GER         RECORD ERROR REGISTER
          RADL   ERRT1       SET CHANNEL ERROR FLAG
 ERR30    RJM    GST         GET GENERAL STATUS
          NJN    ERRX        IF ERRORS GETTING STATUS
          LDDL   GNSTAT
          SHN    17-S.VALID
          PJN    ERR40       IF STATUS VALID
          LDN    /RS/K.LSGSI
          RADL   ERRT1       SET STATUS INVALID
          UJN    ERR50       DO NOT CHECK GENERAL STATUS

 ERR40    SHN    17-S.ERROR-17+S.VALID
          PJN    ERR50       IF NO GENERAL STATUS ERRORS
          LDC    /RS/K.LSGSE
          RADL   ERRT1       SET GENERAL STATUS ERRORS
          LDDL   GNSTAT
          STML   ERRT2       SAVE STATUS
          RJM    GDS         GET DETAILED STATUS

*         IGNORE DETAILED STATUS ERRORS FOR NOW.

          LDML   ERRT2
          STDL   GNSTAT      RESTORE GENERAL STATUS
 ERR50    LDDL   ERRT1
          NJN    ERR60       IF ERRORS
          LDDL   LSTATE      LAST STATE
          LMK    ST.OPER     COMPARE WITH OPERATIONAL STATE
          NJN    ERR55       IF NOT OPERATIONAL STATE
          LDML   OTYPE
          SBN    /RS/K.LREAD
          NJN    ERR55       IF NOT READ
          UJN    ERR57       RESET RECOVERY COUNTER

 ERR55    LDN    FTRY
 ERR57    STIL   ERRRCP      RESET RECOVERY COUNTER
          LDN    0
          UJN    ERR70       EXIT NO ERRORS

 ERR60    RJM    CEC         COMPLETE ERROR CHECKING
 ERR70    UJK    ERRX        EXIT
 PFR      SPACE  4,34
**        PFR - PERFORM READ.
*
*         THIS ROUTINE READS IN DATA FROM THE MDI.  THE TOTAL LENGTH OF THE
*         TRANSFER IS NOT KNOWN UNTIL THE MESSAGE HAS BEEN READ.  TWO TYPES OF
*         RECORDS (CHANNELNET AND CHANNEL CONNECTION), EACH WITH A DIFFERENT
*         HEADER FORMAT ARE ACCEPTED (CHANNELNET RECORDS ARE ONLY ACCEPTED
*         IN LOADING STATE AND DISCARDED OTHERWISE).  DIFFERENT UNSOLICITED
*         RESPONSE CODES ARE USED TO INDICATE THE RECORD TYPE.  THE NUMBER OF
*         BYTES TRANSFERRED IS VERIFIED AGAINST THE LENGTH FIELD IN THE HEADER.
*
*         NOTE:  DUE TO A HARDWARE PROBLEM IN THE MCI IT IS NECESSARY TO NOTIFY
*                THE MCI THAT THE PREVIOUS READ OPERATION COMPLETED WITHOUT ERROR.
*                THIS IS DONE EITHER IMPLICITLY BY COMPLETION OF A WRITE OPERATION
*                OR EXPLICITLY BY SENDING A NORMAL FUNCTION.
*
*         ENTRY  DATA AVAILABLE BIT SET IN GENERAL STATUS.
*                (HDRTYP) = ADDRESS OF HEADER DESCRIPTOR TABLE.
*                (MSGTYP) = 0, IF IN-LINE DIAGNOSTIC MESSAGE TO BE READ,
*                         <> 0, IF NORMAL NETWORK MESSAGE TO BE READ.
*                (NXTREC) = 0 IF RECORD SIZE NOT KNOWN,
*                         = RECORD LENGTH IF RECORD LENGTH KNOWN BUT
*                           BUFFERS WERE NOT AVAILABLE ON INITIAL READ.
*                (RDSYN) <> 0, IF NORMAL FUNCTION SHOULD BE SENT TO
*                           SYNCHRONIZE READ.
*
*         EXIT   (INLINE) = 0, IF NO IN-LINE MESSAGE AWAITING RETURN TO MDI,
*                      <> 0, IF IN-LINE MESSAGE AWAITING RETURN TO MDI.
*
*         USES   T2, T3, UNSC.
*
*         CALLS  CDA, ERR, FAW, GRB, IRE, MDC, USR, ZRE.


 PFR      SUBR               ENTRY/EXIT
          LDK    BP.GOOD     BUFFER POOL CONTAINS A SUFFICIENT NUMBER OF BUFFERS
          STML   RS+/RS/P.T1STAT
          STML   RS+/RS/P.T2STAT
          LDK    SS.OPEN     PP IS ABLE TO SEND MESSAGES TO THE DEVICE
          STML   RS+/RS/P.PSEND
          STML   RS+/RS/P.NSEND
          LDK    /RS/C.T1STAT*8+8
          STML   RS+/RS/P.RESPL  UPDATE RESPONSE LENGTH

          LDN    0
          STML   ACTD
          STDL   BUFLEN      NUMBER OF FREE BYTES REMAINING IN CM BUFFER
          STML   CML         OFFSET TO LENGTH/ADDRESS PAIR IN RESPONSE BUFFER
          STDL   CMLISTL     LENGTH/ADDRESS PAIR COUNT
          STML   FSTRD       FIRST READ HAS NOT OCCURRED YET
          LDML   NXTREC
          ZJN    PFR20       IF RECORD LENGTH NOT KNOWN
          STDL   TBYTS       RECORD LENGTH
          RJM    GRB         GET BUFFERS FROM POOL
          ZJN    PFR24       IF BUFFERS NOT AVAILABLE


*         ISSUE READ FUNCTION.

 PFR20    BSS    0
          LDDL   LSTATE      LAST STATE
          LMK    ST.OPER     COMPARE WITH OPERATIONAL STATE
          NJN    PFR23       IF NOT OPERATIONAL STATE
          LDML   RDSYN
          ZJN    PFR23       IF SYNCHRONIZATION NOT NEEDED
          LDN    F.NORM
          RJM    IFR         ISSUE NORMAL FUNCTION
          NJN    PFR24       IF ERRORS ON FUNCTION
          STML   RDSYN       CLEAR SYNCHRONIZATION FLAG
          RJM    CDA         CHECK DATA AVAILABLE STILL SET
          PJN    PFR24       IF NOT DATA AVAILABLE
 PFR23    RJM    DMT         DETERMINE MESSAGE TYPE
          ZJN    PFR25       IF NO MESSAGE TYPE ERROR
 PFR24    UJK    PFR90       RELEASE BUFFERS

 PFR25    LDC    F.READ
          RJM    FAW         ISSUE FUNCTION AND ACTIVATE CHANNEL
          NJK    PFR24       IF ERRORS ON FUNCTION
 PFR40    LDC    CHCNT       CHANNEL COUNT
          IAPM   IOBUF,CHN
          STDL   ERRCNT      CHANNEL FRAMES NOT READ
          LDK    /RS/K.LREAD
          RJM    ERR         CHECK FOR ERRORS
          ZJN    PFR60       IF NO ERRORS
          LDDL   STCHNG
          NJK    PFR24       IF STATE CHANGING
          LDDL   ERRT1
          LPC    /RS/K.LSGSE
          NJN    PFR24       IF GENERAL STATUS ERROR BIT, RELEASE BUFFERS
          UJK    PFR80       NOT GENERAL STATUS ERROR BIT

 PFR60    LDML   MSGTYP
          ZJK    PFR120      IF IN-LINE DIAGNOSTIC MESSAGE READ
          LDDL   HDRTYP      PDU TYPE
          LMK    TCCH
          ZJN    PFR65       IF CC PDU

*         CHANNELNET PDU WILL NOT BE PROCESSED IF MCI IS IN OPERATIONAL STATE.

          LDDL   LSTATE      LAST KNOWN STATE OF MCI
          LMN    ST.OPER
          ZJK    PFR130      IF OPERATIONAL STATE
 PFR65    BSS    0
          LDML   NXTREC
          NJN    PFR70       IF BUFFERS ALLOCATED
          LDDL   TBYTS
          STML   NXTREC
          RJM    GRB         GET CM BUFFERS
          ZJN    PFR80       IF UNABLE TO GET BUFFERS
 PFR70    BSS    0
          RJM    MDC         MOVE DATA TO CM
          LDDL   IOCNT
          NJK    PFR40       IF MORE TO READ
          STML   NXTREC
          LDML   /HD/P.RRC,HDRTYP  READ RESPONSE CODE
          STML   RDSYN       SEND NORMAL FUNCTION IF NO WRITE
          UJK    PFR100      SEND RESPONSE

 PFR80    DCN    CHN+40B
          RJM    GST         WAIT FOR BUSY
          NJN    PFR90       IF ERROR ON GENERAL STATUS
          RJM    IRE         ISSUE READ ERROR FUNCTION

 PFR90    BSS    0

*         IT IS POSSIBLE FOR THE PP TO GENERATE NUMEROUS DEVICE ERRORS IF THE
*         BUFFER POOL IS EMPTY AND THE CPU HAS NOT HAD A CHANCE TO MAKE
*         ADDITIONAL BUFFERS AVAILABLE.  TO AVOID THIS, THE FOLLOWING CODE
*         CHECKS TO SEE IF THE RESPONSE BEING GENERATED IS GOING TO RETURN
*         ANY BUFFERS OR IF IT IS GOING TO RETURN A *BUFFER EMPTY* OR  A
*         *BUFFER THRESHOLD* STATUS.  IF NOT, A DEVICE ERROR UNSOLICITED
*         RESPONSE WILL NOT BE ISSUED.

          LDDL   CMLISTL     NUMBER OF LENGTH/ADDRESS PAIRS
          ADML   RS+/RS/P.T1STAT   STATUS OF TYPE 1 BUFFER POOL
          ADML   RS+/RS/P.T2STAT   STATUS OF TYPE 2 BUFFER POOL
          SBN    2*BP.GOOD   COMPARE WITH ADEQUATE NUMBER OF BUFFERS AVAILABLE
          NJN    PFR92       IF DEVICE ERROR REQUIRED
          UJK    PFR130      NO DEVICE ERROR REQUIRED

*         MOVE THE LAST LENGTH/ADDRESS PAIR TO BE THE FIRST ONE (IF THE FIRST
*         ONE HAS NOT BEEN ALLOCATED YET).  THIS IS NEEDED BECAUSE THE FIRST
*         BUFFER IS ALLOCATED LAST AND COULD BE UNALLOCATED AT THIS POINT.
*         THE CPU CODE EXPECTS THE BUFFER LIST TO BE CONTIGUOUS AND ALLOCATED.

 PFR92    BSS    0
          LDML   RS+/RS/P.DLEN   LENGTH OF FIRST BUFFER POOL BUFFER
          NJN    PFR98       IF FIRST BUFFER HAS BEEN ALLOCATED
          LDN    3           LENGTH/ADDRESS PAIR SIZE (PP WORDS)(0..3)
          STDL   T2          OFFSET TO FIRST LENGTH/ADDRESS PAIR
          LDDL   CMLISTL     NUMBER OF LENGTH/ADDRESS PAIRS
          SHN    2           CONVERT TO PP WORDS
          ADDL   T2          ADJUST FOR HIGHEST OFFSET
          STDL   T3          OFFSET TO LAST LENGTH/ADDRESS PAIR

 PFR95    BSS    0
          LDML   RS+/RS/P.DLEN,T3   PART OF LAST LENGTH/ADDRESS PAIR
          STML   RS+/RS/P.DLEN,T2   PART OF FIRST LENGTH/ADDRESS PAIR
          SODL   T3          NEXT OFFSET TO LAST LENGTH/ADDRESS PAIR
          SODL   T2          NEXT OFFSET TO FIRST LENGTH/ADDRESS PAIR
          PJK    PFR95       IF MORE TO MOVE

 PFR98    BSS    0
          LDN    URC.DE      READ ERROR
 PFR100   STDL   UNSC        UNSOLICITED RESPONSE CODE
          LDDL   CMLISTL     NUMBER OF LENGTH/ADDRESS PAIRS
          SHN    3           CONVERT TO CM BYTES
          RAML   RS+/RS/P.RESPL  UPDATE RESPONSE LENGTH
          RJM    USR         SEND UNSOLICITED RESPONSE
          IFEQ   SIM,1
          LDC    500B
          STML   STAT
          ENDIF
          UJN    PFR140      EXIT
          SPACE  1,4
*         AN IN-LINE DIAGNOSTIC MESSAGE HAS BEEN READ, THE PP MUST LOOK AT THE
*         TEST MESSAGE HEADER TO DETERMINE IF THE MESSAGE IS TO BE SENT BACK AT
*         THE NEXT OPPORTUNITY OR DISCARDED.

 PFR120   BSS    0
          LDML   IOBUF+P.H802.3+P.H802.2  IN-LINE DIAGNOSTIC TEST HEADER
          SHN    17-IL.DSCRD-8
          MJN    PFR130      IF IN-LINE MESSAGE TO BE DISCARDED
          LDN    ST.ILD
          STML   INLINE      IN-LINE MESSAGE AWAITING RETURN
 PFR130   RJM    ZRE         RESET RESPONSE BUFFER
 PFR140   UJK    PFRX        EXIT
 WRP      SPACE  4,18
**        WRP - WRITE PROCESSOR.
*
*         THIS ROUTINE PROCESSES THE WRITE BYTES AND
*         WRITE RECORD COMMANDS. THE WRITE BYTES COMMAND
*         IS USED TO SEND CHANNELNET PDU'S AND THE WRITE
*         RECORD COMMAND IS USED TO SEND CHANNEL
*         CONNECTION PDU'S.
*
*         ENTRY  (CM) - COMMAND.
*                (LASTUR) = LAST UNIT REQUEST PROCESSED.
*                (STBI) = UNIT REQUEST.
*
*         USES   WC.
*
*         CALLS  ERR, FPB, IFR, STR, SWF, ZRE.
*
*         MACROS LOADB.


 WRP      SUBR               ENTRY/EXIT
          LDML   RQ+/URQ/P.URQLEN   UNIT REQUEST LENGTH
          SBN    /URQ/C.MBRMA*8   NUMBER OF REQUEST (CM) BYTES BEFORE LNG/ADDR LIST
          SHN    -3          8 CM BYTES FOR EACH LENGTH/ADDRESS PAIR
          STDL   CMLISTL     NUMBER OF CM LENGTH/ADDRESS PAIRS
          LDML   RQ+/URQ/P.MBLEN  LENGTH OF FIRST LENGTH/ADDRESS PAIR
          STDL   BUFLEN      CM BUFFER LENGTH IN BYTES
          LDN    0
          STML   CML         CURRENT CM LIST INDEX
          STML   REMBYT      INITIALIZE REMAINING BYTES COUNT
          LOADB  RQ+/URQ/P.MBRMA REFORMAT CM ADDRESS OF BUFFER AND
                                 SAVE STARTING BYTE OFFSET
          STDL   DATADD+2
          SRD    DATADD

*         ISSUE WRITE FUNCTION

          RJM    SWF         SELECT WRITE FORMAT
 WRP20    NJK    WRPX        EXIT - IF ERRORS
          LDC    F.WRITE
          RJM    IFR         ISSUE WRITE FUNCTION
          NJN    WRP20       IF FUNCTION ERRORS
          ACN    CHN
 WRP30    RJM    FPB         FILL PP BUFFER
          LDDL   IOCNT
          NJN    WRP40       IF DATA TO TRANSFER
          UJK    WRP75

 WRP40    BSS    0
          LDML   ODDSTR
          ZJN    WRP60       IF NOT ODD BYTE START IN PP BUFFER
          LDML   PREBUF      CONTAINS FIRST BYTE IN LOWER 8 BITS
          SHN    11-7
          SCN    17B
          STM    PREBUF      BYTE 1 IN BITS 52-59 (170 STM CLEARS UPPER 4 BITS)
          LDML   PREBUF+1
          STM    PREBUF+1    CLEAR UPPER 4 BITS IN PP WORD
          SHN    6
          LPN    17B
          RAML   PREBUF      ADD TOP 4 BITS OF BYTE 2
          LDDL   IOCNT
          STDL   P1
          SBN    2
          MJN    WRP50       IF ONLY ONE CHANNEL FRAME TO TRANSFER
          LDN    2
          STDL   P1
 WRP50    BSS    0
          LDDL   IOCNT
          SBDL   P1
          STDL   IOCNT       CHANNEL FRAMES LEFT TO TRANSFER AFTER OAM
          LDDL   P1
          IFEQ   SIM,1
          UJN    WRPP
          ENDIF
          OAM    PREBUF,CHN  OUTPUT 1 OR 2 CHANNEL FRAMES
          IFEQ   SIM,1
 WRPP     LDN    0
          ENDIF
          NJN    WRP75       IF NOT ALL DATA TAKEN
 WRP60    BSS    0
          LDDL   IOCNT       TRANSFER COUNT
          ZJN    WRP70       IF NO MORE DATA TO OUTPUT THIS PASS

          IFEQ   SIM,1
          STML   DATCNT
          UJN    XX
          ENDIF
          OAPM   IOBUF,CHN
          IFEQ   SIM,1
 XX       BSS    0
          LDN    0
          ENDIF
          NJN    WRP75       IF NOT ALL DATA TAKEN
 WRP70    BSS    0
          LDDL   BYTCNT      BYTES TRANSFERRED
          RAML   RS+/RS/P.XFER+1
          SHN    -16
          RAML   RS+/RS/P.XFER  UPDATE TRANSFER COUNT IN RESPONSE
          UJK    WRP30

 WRP75    STDL   ERRCNT      NUMBER OF WORDS NOT WRITTEN
          LDK    /RS/K.LWRT
          RJM    ERR         CHECK ERRORS
          NJN    WRP90       IF  ERRORS
          STML   RDSYN       CLEAR READ SYCHRONIZATION
          RJM    STR         SEND TERMINATION RESPONSE
 WRP80    UJK    WRPX        EXIT

 WRP90    RJM    ZRE         ZERO RESPONSE BUFFER
          LDDL   STCHNG
          NJN    WRP80       IF RESET
          LDML   WRRTY
          ZJN    WRP100      IF UNRECOVERED
          LDDL   ERRT1
          LMC    /RS/K.LSCEF
          ZJN    WRP100      IF ONLY ERROR WAS CEF
          LPN    /RS/K.LSGSI
          ZJN    WRP80       IF STATUS VALID
 WRP100   LDN    ST.PPR      RESET MCI
          STDL   STCHNG
          UJN    WRP80       EXIT
 FRC      SPACE  4,18
**        FRC - FIND RECOVERY COUNTER.
*
*         THIS ROUTINE WILL FIND AND RETURN THE ADDRESS OF
*         THE RECOVERY COUNTER FOR THE APPROPRIATE OPERATION.
*         THE FOLLOWING COUNTERS ARE DEFINED.
*
*         COUNTER               OPERATION
*         -------            -------------------
*         WRRTY              WRITE OPERATION
*         RDRTY              READ OPERATION
*         ILRTY              IN-LINE WRITE OPERATION
*
*         ENTRY  (A) = OPERATION TYPE.
*
*         EXIT   (A) = ADDRESS OF RECOVERY COUNTER.
*
*         CALLS  STB.


 FRC      SUBR               ENTRY/EXIT
          STML   STBI        SAVE OPERATION TYPE FOR TABLE SEARCH
          LDC    FRCT-2      TABLE ADDRESS
          RJM    STB         FIND COUNTER
          UJN    FRCX        EXIT
          SPACE  2
 FRCT     CON    /RS/K.LWRT,WRRTY
          CON    /RS/K.LREAD,RDRTY
          CON    /RS/K.LILWRT,RDRTY
          CON    0
 IER      SPACE  4,14
**        IER - INITIALIZE ERROR ROUTINE.
*
*         THIS ROUTINE WILL INITIALIZE FOR THE ERROR
*         RECOVERY LOGIC.
*
*         ENTRY  (OTYPE) = OPERATION CODE.
*
*         EXIT   (A) = 0.
*                (ERRRCP) = POINTER TO RECOVERY COUNTER.
*                (ERRT1) = 0.
*
*         CALLS  FRC.


 IER      SUBR               ENTRY/EXIT
          LDML   OTYPE
          RJM    FRC         FIND PROPER RECOVERY COUNTER
          STDL   ERRRCP      SAVE
          LDN    0
          STDL   ERRT1       ZERO ERROR WORD
          UJN    IERX        EXIT
 FPB      SPACE  4,22
**        FPB - FILL PP BUFFER
*
*         THIS ROUTINE FILLS THE PP I/O BUFFER WITH DATA FROM CM.  CM DATA IS
*         DEFINED VIA ADDRESS/LENGTH PAIRS.
*
*         ENTRY  (CML) = ADDRESS/LENGTH PAIR INDEX.
*                (CMLISTL) = ADDRESS/LENGTH PAIR COUNT.
*                (BUFLEN) = REMAINING DATA TO TRANSFER FROM CURRENT CM BUFFER.
*                (DATADD) = CM ADDRESS TO READ FROM.
*                (REMBYT) = REMAINING BYTES IN BUFFER AFTER LAST OUTPUT.
*
*         EXIT   (IOCNT) = NUMBER OF CHANNEL FRAMES TO TRANSFER.
*                (REMBYT) = REMAINING BYTES AFTER UPCOMING OUTPUT.
*                (BYTCNT) = NUMBER OF BYTES TO TRANSFER.
*                (CML) = OFFSET TO LAST LENGTH/ADDRESS PAIR.
*                (CMLISTL) = 0 (NUMBER OF LENGTH/ADDRESS PAIRS REMAINING).
*
*         USES   P1 - P4, T2, T3.
*
*         CALLS  CBY, IPB, MDP.
*
*         MACROS LOADB.


 FPB      SUBR               ENTRY/EXIT
          LDN    0
          STDL   BYTCNT
          LDDL   CMLISTL
          NJN    FPB10       IF CM DATA
          STDL   IOCNT       OUTPUT COMPLETE - NO MORE DATA TO SEND
          UJN    FPBX        EXIT

 FPB10    BSS    0
          RJM    IPB         INITIALIZE PP BUFFER
          LDC    IOBLEN*2    LENGTH OF PP BUFFER IN BYTES
          RADL   TBYTS       TOTAL LENGTH OF PP BUFFER
          SBDL   BYTCNT
 FPB20    BSS    0
          STDL   BYTS        FREE SPACE
          SBDL   BUFLEN      BYTES LEFT TO TRANSFER FROM CM
          MJN    FPB30       IF NOT ALL OF CM BUFFER FITS IN PP
          LDDL   BUFLEN
          STDL   BYTS
 FPB30    BSS    0
          LDDL   BYTS
          RJM    MDP         MOVE DATA TO PP BUFFER
          LDDL   BUFLEN
          SBDL   BYTS        BYTES TRANSFERRED
          STDL   BUFLEN      BYTES LEFT TO TRANSFER FROM CM
          ZJN    FPB40       IF CM BUFFER EMPTY
          UJK    FPB70       MORE BYTES TO TRANSFER FROM THIS CM BUFFER

 FPB40    BSS    0
          SODL   CMLISTL     DECREMENT LENGTH/ADDRESS PAIR COUNT
          NJN    FPB50       IF MORE CM DATA
          UJK    FPB70

*         MOVE THE NEXT LENGTH/ADDRESS PAIR TO *P1* - *P4*.

 FPB50    BSS    0
          AOML   CML         INCREMENT CM LIST INDEX
          SHN    2           OFFSET TO NEXT LENGTH/ADDRESS PAIR
          ADN    3           OFFSET TO LAST PP WORD OF NEXT LENGTH/ADDRESS PAIR
          STDL   T2
          LDN    3           4 PP WORDS PER LENGTH/ADDRESS PAIR (0..3)
          STDL   T3          NEXT OFFSET FOR COPYING THE LENGTH/ADDRESS PAIR

 FPB60    LDML   RQ+/URQ/P.MBLEN,T2   NEXT REQUEST LENGTH/ADDRESS PAIR
          STML   P1,T3
          SODL   T2          NEXT LENGTH/ADDRESS PAIR OFFSET
          SODL   T3          NEXT OFFSET FOR THE COPY
          PJK    FPB60       IF MORE TO DO

          LDDL   P1
          STDL   BUFLEN      CM BUFFER LENGTH
          LDDL   SBYOFF
          LPN    1           DETERMINE IF ODD OR EVEN
          STML   EBYOFF      ENDING BYTE OFFSET (ODD OR EVEN)
          LOADB  P1+/URQ/P.MBRMA-/URQ/P.MBLEN  REFORMAT CM ADDRESS AND
                                               SAVE STARTING BYTE OFFSET
          STDL   DATADD+2
          SRD    DATADD
          LDDL   SBYOFF      NEW STARTING BYTE OFFSET
          LPN    1           ODD OR EVEN
          LMML   EBYOFF
          NJN    FPB80       IF START OF NEXT BUFFER DOES NOT MATCH UP
          LDDL   TBYTS       TOTAL SIZE OF PP BUFFER IN BYTES
          SBDL   BYTCNT
          ZJN    FPB80       IF PP BUFFER FULL
          UJK    FPB20

 FPB70    BSS    0
          LDDL   SBYOFF
          LPN    1
          STML   EBYOFF      ENDING BYTE OFFSET (ODD OR EVEN)
 FPB80    BSS    0
          RJM    CBY         CONVERT BYTE COUNT TO CHANNEL COUNT
          LDDL   IOCNT       CHANNEL FRAMES TO TRANSFER
          NJN    FPB90       IF DATA TO TRANSFER
          UJK    FPB10

 FPB90    BSS    0
          LDDL   BYTCNT      BYTES IN PP BUFFER
          SBML   REMBYT      REMAINING BYTES (BYTES NOT TO BE TRANSFERRED)
          STDL   BYTCNT      ACTUAL NUMBER OF BYTES TO BE TRANSFERRED
          UJK    FPBX        EXIT
 GRB      SPACE  4,22
**        GRB - GET READ BUFFER.
*
*         THIS ROUTINE OBTAINS ENOUGH CM BUFFERS FROM THE BUFFER POOLS TO READ
*         A PDU *TBYTS* LONG.  THE BUFFER LENGTH/ADDRESS PAIRS ARE STORED
*         SEQUENTIALLY IN THE RESPONSE BUFFER.
*
*         PROGRAMMER NOTE -- BUFFERS 2 - N ARE ALLOCATED FIRST.  BUFFER 1 IS
*         ALLOCATED LAST.  THUS, ALL CHECKS FOR THE FIRST BUFFER ARE REALLY
*         CHECKING TO SEE IF THE LAST BUFFER HAS BEEN ALLOCATED.
*
*         ENTRY  (TBYTS) = TOTAL BYTES TO ALLOCATE CM BUFFERS FOR.
*
*         EXIT   (A) = 0, IF NO BUFFERS,
*                    <> 0, IF BUFFERS OBTAINED.
*                (BUFLEN) = LENGTH OF THE FIRST BUFFER IN THE CHAIN.
*                (CML) = 0 = OFFSET TO THE FIRST LENGTH/ADDRESS PAIR.
*                (CMLISTL) = NUMBER OF LENGTH/ADDRESS PAIRS.
*                (CM.CRB) = REFORMATTED FIRST BUFFER ADDRESS IN THE CHAIN.
*                (DATADD) = REFORMATTED FIRST DATA ADDRESS IN FIRST BUFFER.
*
*         USES   T1, T2, T3.
*
*         CALLS  CBP, SBI.


 GRB      SUBR               ENTRY/EXIT
 GRB05    LDN    0
          STDL   FSTBD       INITIALIZE BUFFER POOL INDEX

          LDML   BPDSIZE,FSTBD   1 * BUFFER POOL SIZE
          SHN    1               2 * BUFFER POOL SIZE
          ADML   BPDSIZE,FSTBD   3 * BUFFER POOL SIZE
          SBDL   TBYTS       COMPARE REMAINDER WITH SIZE OF 3 SMALL BUFFERS
          MJN    GRB20       IF 3 BUFFERS ARE NOT LARGE ENOUGH
 GRB10    RJM    CBP         CHECK IF BUFFERS IN POOL
          NJN    GRB50       IF BUFFER AVAILABLE

 GRB20    AODL   FSTBD
          SBML   NUMBP
          MJN    GRB10       IF MORE POOLS TO LOOK AT

*         EXIT SINCE ALL POOLS ARE EMPTY.

          LDN    0
          UJK    GRBX        EXIT - (A) = 0, NO BUFFERS

*         ADD BUFFER TO BUFFER LIST.

 GRB50    BSS    0
          IFEQ   DEBUG,1
          AOML   BUFCNT,FSTBD    TOTAL NUMBER OF CM BUFFERS USED
          ENDIF

          AODL   CMLISTL     INCREMENT FOR A NEW LENGTH/ADDRESS PAIR
          LDML   BPDSIZE,FSTBD   BUFFER POOL SIZE
          SBDL   TBYTS       COMPARE WITH REMAINING BYTES
          MJN    GRB60       IF NOT FIRST BUFFER

*         INITIALIZE FOR FIRST BUFFER.

          LDN    0
          STML   CML
          STDL   T1          OFFSET TO LENGTH/ADDRESS PAIR IN RESPONSE BUFFER
          UJN    GRB70

*         INITIALIZE FOR ALL OTHER BUFFERS.

 GRB60    BSS    0
          ERRNZ  4-C.BP*2    BUFFER POOL (SIZE) DEPENDENCY ERROR
          LDN    4
          RAML   CML
          STDL   T1          OFFSET TO LENGTH/ADDRESS PAIR IN RESPONSE BUFFER
          SBN    MAXRS*4-/RS/C.BUFPVA*4   COMPARE WITH MAXIMUM RESPONSE LENGTH
          PJN    *           IF BEYOND END OF THE RESPONSE BUFFER

*         UPDATE ADDRESS (PVA) IN LENGTH/ADDRESS PAIR OF RESPONSE BUFFER.

 GRB70    BSS    0
          LDN    0
          STDL   T3          NO PVA YET
          LDN    3
          STDL   T2          HIGH PORTION OF BUFFER POOL PVA ADDRESS (1..3)
          RADL   T1          HIGH PORTION OF LENGTH/ADDRESS FIELD IN RESPONSE

 GRB75    BSS    0
          LDML   BP+/BP/P.PVA-1,T2   BUFFER POOL PVA ADDRESS FIELD
          STML   RS+/RS/P.BUFPVA-1,T1   RESPONSE PVA ADDRESS FIELD
          RADL   T3          INCLUDE A PVA FIELD
          SODL   T1          OFFSET TO NEXT PORTION OF LENGTH/ADDRESS FIELD
          SODL   T2          OFFSET TO NEXT PORTION OF BUFFER POOL PVA ADDRESS
          NJK    GRB75       IF MORE TO DO
          LDDL   T3          ALL PVA FIELDS
          ZJN    *           IF BAD PVA

*         UPDATE CONTAINER RMA TABLE.

          ERRNZ  4-C.BP*2    BUFFER POOL (SIZE) DEPENDENCY ERROR
          LDDL   T1          OFFSET TO LENGTH/ADDRESS PAIR IN RESPONSE BUFFER
          SHN    -1          CONVERT TO CONTAINER RMA TABLE INDEX
          STDL   T2
          LDML   BP+/BP/P.RMA   UPPER PART OF BUFFER POOL CONTAINER RMA ADDRESS
          STML   BPRMA,T2    MOVE TO CONTAINER RMA TABLE
          STDL   T3          INCLUDE A RMA FIELD
          LDML   BP+/BP/P.RMA+1   LOWER PART OF BUFFER POOL CONTAINER RMA ADDRESS
          STML   BPRMA+1,T2    MOVE TO CONTAINER RMA TABLE
          RADL   T3          INCLUDE A RMA FIELD
          ZJN    *           IF BAD RMA

*         UPDATE DATA LENGTH IN LENGTH/ADDRESS PAIR OF RESPONSE BUFFER.

          LDML   BPDSIZE,FSTBD   LENGTH OF BUFFER POOL BUFFER
          STML   RS+/RS/P.DLEN,T1   RESPONSE BUFFER LENGTH FIELD
          STML   FBSIZE      MAXIMUM SIZE OF FIRST BUFFER (WHEN LOOP IS DONE)
          LDDL   TBYTS       REMAINING BYTES
          SBML   FBSIZE      COMPARE WITH MAXIMUM SIZE OF BUFFER
          PJN    GRB80       IF MORE TO ALLOCATE

*         ALL BUFFERS HAVE BEEN ALLOCATED.  CALCULATE THE CORRECT BUFFER SIZE
*         FOR THE FIRST BUFFER.

          LDDL   TBYTS       REMAINING BYTES
          STML   RS+/RS/P.DLEN   FIRST BUFFER SIZE (BYTES USED IN BUFFER)
          LDN    0           NO BYTES LEFT TO BE ALLOCATED FOR

 GRB80    STDL   TBYTS       UPDATE TOTAL BYTES TO ALLOCATE CM BUFFERS FOR
          NJK    GRB05       IF MORE TO ALLOCATE
          RJM    SBI         INITIALIZE BUFFER POINTERS
          UJK    GRBX        EXIT
 IPB      SPACE  4,14
**        IPB - INITIALIZE PP BUFFER.
*
*         THIS ROUTINE WILL SET UP THE PP BUFFER AND
*         THE CURRENT BUFFER POINTER, *CURBUF* FOR THE
*         UPCOMING CALL TO *MDP* (MOVE DATA TO PP).  THIS
*         INVOLVES MOVING ANY REMAINING BYTES IN THE
*         BUFFER NOT SENT OUT WITH THE LAST OUTPUT
*         INSTRUCTION, UP TO THE START OF THE BUFFER
*         AND UPDATING *CURBUF*.
*
*         ENTRY  (CURBUF) = CURRENT PP BUFFER POINTER.
*                (EBYOFF) = BYTE OFFSET (MOD 2) WHERE NEXT DATA EXPECTED TO START.
*                (REMBYT) = REMAINING BYTES LEFT IN PP BUFFER.
*                (SBYOFF) = STARTING BYTE OFFSET OF NEXT CM BYTE.


 IPB      SUBR               ENTRY/EXIT
          LDN    0
          STDL   TBYTS       INITIALIZE PP BUFFER SIZE
          LDML   REMBYT      REMAINING BYTES AFTER LAST OUTPUT
          STDL   BYTCNT      BYTES IN PP BUFFER
          NJN    IPB30       IF BYTES REMAINING
          LDDL   SBYOFF
          LPN    1
          ZJN    IPB10       IF STARTING BYTE OFFSET EVEN
          LDC    PREBUF      CURRENT BUFFER POINTER
          UJN    IPB20

 IPB10    BSS    0
          LDC    IOBUF       CURRENT BUFFER POINTER
 IPB20    UJK    IPB70

 IPB30    BSS    0
          SBN    1
          NJN    IPB40       IF 2 REMAINING BYTES
          LDML   EBYOFF
          ZJN    IPB35       IF ENDING BYTE OFFSET EVEN
          UJK    IPB60

 IPB35    BSS    0
          SODL   CURBUF
          LDIL   CURBUF
          SHN    8
          STML   IOBUF       MOVE REMAINING BYTE TO TOP OF BUFFER
          LDC    IOBUF       CURRENT BUFFER POINTER
          UJN    IPB20

 IPB40    BSS    0
          LDML   EBYOFF
          ZJN    IPB50       IF ENDING BYTE OFFSET EVEN
          LDIL   CURBUF
          SHN    10
          LPC    377B
          STML   IOBUF       MOVE SECOND REMAINING BYTE
          SODL   CURBUF      BACK UP TO GET FIRST REMAINING BYTE
          LDIL   CURBUF
          LPC    377B
          SHN    8
          RAML   IOBUF       MOVE FIRST REMAINING BYTE
          LDC    IOBUF+1     CURRENT BUFFER POINTER
          UJK    IPB70

 IPB50    BSS    0
          SODL   CURBUF
          LDIL   CURBUF
          SHN    8
          STML   PREBUF+1    MOVE SECOND REMAINING BYTE
 IPB60    BSS    0
          LDIL   CURBUF
          SHN    10
          STML   PREBUF      MOVE FIRST REMAINING BYTE
          LDC    PREBUF+1    CURRENT BUFFER POINTER
 IPB70    BSS    0
          STDL   CURBUF      UPDATE CURRENT BUFFER POINTER
          LDML   REMBYT      REMAINING BYTES
          LMDL   SBYOFF      STARTING BYTE OFFSET OF NEXT BYTE
          LPN    1
          ZJN    IPB80       IF ONLY NEED TO DO 1 OUTPUT
          LDN    3
          STDL   TBYTS       INCREASE TOTAL PP BUFFER SIZE
 IPB80    BSS    0
          STML   ODDSTR      SET FLAG FOR 170 OAM USE
          UJK    IPBX        EXIT
 MDC      SPACE  4,16
**        MDC - MOVE DATA TO CM.
*
*         THIS ROUTINE TRANSFERS DATA FROM THE PP I/O BUFFER
*         TO CM.
*
*         ENTRY  (BUFLEN) = REMAINING FREE BYTES IN CM BUFFER.
*                (BYTCNT) = NUMBER OF BYTES IN PP BUFFER.
*
*         EXIT   (A) = 0, IF DATA MOVE COMPLETE,
*                    <> 0, IF UNABLE TO MOVE DATA TO CM,
*                PP BUFFER EMPTY.
*                BYTE COUNT FIELD IN CM BUFFER UPDATED.
*
*         USES   T1, WC.
*
*         CALLS  SBI, SDB.
*
*         MACROS LOADC.


 MDC      SUBR               ENTRY/EXIT
          LDDL   BYTCNT      NUMBER OF BYTES IN PP BUFFER
          STDL   BYTS        NUMBER OF BYTES TO TRANSFER TO CM
          ZJN    MDCX        EXIT - IF NO DATA TRANSFERRED

 MDC10    BSS    0
          LDDL   BUFLEN      SPACE IN CM BUFFER
          NJN    MDC20       IF BUFFER NOT EMPTY
          AOML   CML         NEXT LENGTH/ADDRESS PAIR
          RJM    SBI         INITIALIZE FOR NEXT BUFFER

 MDC20    BSS    0
          SBDL   BYTS        BYTES IN PP BUFFER
          PJN    MDC30       IF ROOM IN CM BUFFER FOR ALL
          LDDL   BUFLEN
          UJN    MDC40

 MDC30    BSS    0
          LDDL   BYTS

 MDC40    STML   BWRT        BYTES TO WRITE TO CM
          LDDL   LSTATE      LAST STATE
          LMK    ST.OPER     COMPARE WITH OPERATIONAL STATE
          ZJN    MDC45       IF OPERATIONAL STATE

          LDML   CML         LENGTH/ADDRESS PAIR OFFSET (ENTRY)
          ZJN    MDC41       IF FIRST BUFFER (IF FIRST LENGTH/ADDRESS PAIR)
          LDN    0           NO MORE BYTES OFF WORD BOUNDARY
          UJN    MDC45

 MDC41    BSS    0
          LDML   RS+/RS/P.XFER+1   LENGTH OF DATA (CM BYTES)
          LPN    1           ODD/EVEN
          ZJN    MDC43       IF EVEN NUMBER OF BYTES
          RJM    SDB         SHIFT DATA BUFFER

 MDC43    BSS    0
          LDML   RS+/RS/P.XFER+1   LENGTH OF DATA (CM BYTES)
          LPN    7
          ZJN    MDC45       IF PDU SIZE IS AN EXACT MULTIPLE OF CM WORDS
          STDL   T1          NUMBER OF BYTES OFF OF THE WORD BOUNDARY
          LDN    8           CM BYTES PER CM WORD
          SBDL   T1          TAKE AWAY CM BYTES THAT ARE OFF OF THE WORD BOUNDARY
          SHN    -1          CONVERT FROM CM BYTES TO PP WORDS

 MDC45    BSS    0
          STDL   T1          NUMBER OF EXTRA PP WORDS NEEDED FOR A WORD BOUNDARY
          LDDL   BYTCNT      NUMBER OF BYTES IN PP BUFFER
          SBDL   BYTS        ADJUST BY BYTES REMAINING IN PP BUFFER
          ADN    1           ADJUST FOR POSSIBLE ODD PDU SIZE
          SHN    -1          CONVERT FROM CM BYTES TO PP WORDS
          ADC    IOBUF
          SBDL   T1          ADJUST FOR BYTES NOT ON A WORD BOUNDARY
          STML   MDCW

          LDML   BWRT
          ADN    7
          SHN    -3
          STDL   WC          WORDS TO WRITE TO CM
          LOADC  DATADD
          CWML   IOBUF,WC
 MDCW     EQU    *-1
          STDL   DATADD+2  UPDATE CM BUFFER ADDRESS
          LDDL   BUFLEN
          SBML   BWRT
          STDL   BUFLEN      UPDATE REMAINING CM BUFFER SPACE
          LDDL   BYTS
          SBML   BWRT
          STDL   BYTS        UPDATE REMAINING BYTES IN PP
          ZJN    MDC50       IF PP BUFFER EMPTY
          UJK    MDC10

 MDC50    BSS    0
          UJK    MDCX        EXIT
 REC      SPACE  4,26
**        REC - READ ERROR CHECK.
*
*         THIS ROUTINE WILL PERFORM INITIAL ERROR CHECKS FOR READ
*         RECOVERY. AS THE RECORD MAY BE LONGER THAN THE PP BUFFER,
*         MULTIPLE CALLS CAN BE MADE.
*
*         ENTRY  (ACTD) = 0 ON INITIAL ENTRY FOR A RECORD,
*                       = BYTES READ TO THIS POINT ON SUBSEQUENT ENTRY.
*                (ERRCNT) = NUMBER OF WORDS NOT READ.
*                (FSTRD) = 0 IF FIRST BUFFER READ FOR THIS RECORD.
*                (HDRTYP) = ADDRESS OF HEADER DESCRIPTOR TABLE.
*                (NXTREC) = 0 IF BUFFERS NOT PREALLOCATED,
*                         <> 0 = SIZE OF BUFFER ALLOCATED.
*
*         EXIT   (A) = 0 IF NO ERRORS AND NOT END OF RECORD,
*                    <> 0 IF ERRORS OR END OF RECORD.
*                (ACTD) = TOTAL BYTES READ FOR THIS RECORD.
*                (BYTCNT) = NUMBER OF BYTES IN BUFFER.
*                (EXPD) = RECORD SIZE IN BYTES.
*                (ERRT1) = SYMPTOM CODES IF ERRORS.
*                (IOCNT) = NUMBER OF CHANNEL FRAMES TO READ.
*                (TBYTS) = RECORD SIZE IN BYTES.
*
*         USES   T1.
*
*         CALLS  CBY, IER.


 REC      SUBR               ENTRY/EXIT
          LDC    CHCNT
          SBDL   ERRCNT
          STDL   ERRCNT      SAVE CHANNEL FRAMES READ
          SHN    1
          ADDL   ERRCNT
          SHN    -1          BYTES READ
          STDL   BYTCNT
          RAML   ACTD
          LDML   FSTRD
          NJK    REC30       IF NOT FIRST READ
          RJM    IER         INITIALIZE ERROR PROCCESSING
          LDML   /HD/P.HLB,HDRTYP  LENGTH OF HEADER
          STML   FSTRD
          STML   EXPD
          LDDL   ERRCNT
          SBML   /HD/P.HLC,HDRTYP  HEADER LENGTH IN CHANNEL FRAMES
          MJK    REC10       IF HEADER NOT READ
          LDML   /HD/P.ALF,HDRTYP  ADDRESS OF LENGTH FIELD
          STDL   T1
          LDML   0,T1
          ADML   /HD/P.ATL,HDRTYP
          STDL   BYTCNT      BYTES IN RECORD
          STML   RS+/RS/P.XFER+1
          STDL   TBYTS
          STML   EXPD
          LDDL   TBYTS
          SBN    1
          SBML   /HD/P.MRS,HDRTYP
          PJK    REC110      IF RECORD .GT. MAXIMUM
          LDML   NXTREC
          ZJN    REC20       IF BUFFERS NOT PREALLOCATED
          SBML   EXPD
          ZJN    REC20       IF RECORD SIZE .EQ. BUFFERS
          LDML   EXPD
          STML   ACTD
          LDML   NXTREC
          STML   EXPD
 REC10    UJN    REC50       MESSAGE LENGTH ERROR

 REC20    RJM    CBY         CONVERT TO CHANNEL FRAMES
          LDML   ACTD
          STDL   BYTCNT      RESTORE BYTE COUNT
 REC30    LDDL   IOCNT
          SBDL   ERRCNT
          STDL   IOCNT
          MJN    REC50       IF RECORD LONGER THAN EXPECTED
          NJN    REC40       IF NOT LAST BLOCK
          LDML   EXPD
          SBML   ACTD
          RADL   BYTCNT      ADJUST FOR EXTRA BYTE
          UJN    REC70       COMPLETE PROCESSING

 REC40    LDC    CHCNT
          SBDL   ERRCNT
          NJN    REC90       IF LAST READ NOT FULL BUFFER
          AJM    RECX,CHN    IF CHANNEL ACTIVE
 REC50    LDC    /RS/K.LSMLV
 REC60    RADL   ERRT1       MESSAGE LENGTH VERIFICATION ERROR
          UJK    RECX        EXIT



 REC70    LDC    WTDEACT*600   WAIT FOR CHANNEL NOT ACTIVE
 REC80    IJM    RECX,CHN    IF CHANNEL NOT ACTIVE
          SBML   TI
          NJN    REC80       IF NOT TIMED OUT
          LDDL   ERRCNT
          NJN    REC90       IF TRANSFER NOT COMPLETE
          LDC    177777B     MESSAGE LARGER THAN EXPECTED
          STML   ACTD
          UJK    REC50       LOG ERROR

 REC90    IJM    REC50,CHN   MESSAGE LENGTH ERROR
          LDC    /RS/K.LSIT
 REC100   UJK    REC60       SET INCOMPLETE TRANSFER

 REC110   LDML   EXPD
          STML   ACTD
          LDN    ST.PPR
          STDL   STCHNG      RESET MDI
          LDC    /RS/K.LSMSE
          UJN    REC100      SET MAXIMUM SIZE EXCEEDED
 SBI      SPACE  4,14
**        SBI - SET BUFFER INFORMATION.
*
*         THIS ROUTINE WILL INITIALIZE BUFFER POINTERS
*         USED TO MOVE DATA TO CENTRAL MEMORY.
*
*         ENTRY  (BPRMA)  = BUFFER POOL BUFFER RMA TABLE.
*                (CML)    = OFFSET TO THE LENGTH/ADDRESS PAIR (TO SET BUFFER
*                           INFORMATION FOR).
*                (FBSIZE) = MAXIMUM SIZE OF FIRST BUFFER POOL BUFFER.
*
*         EXIT   (DATADD) = REFORMATTED BUFFER FIRST DATA ADDRESS.
*                (BUFLEN) = LENGTH OF BUFFER.
*                (A) = LENGTH OF BUFFER.
*
*         USES   T2, T3, T4.
*
*         MACRO  LOADF.


 SBI      SUBR               ENTRY/EXIT
          LDML   CML         LENGTH/ADDRESS PAIR OFFSET (ENTRY)
          SHN    1
          STDL   T2          BUFFER RMA TABLE OFFSET
          SHN    1
          STDL   T3          LENGTH/ADDRESS PAIR OFFSET (PP WORDS)

          LOADF  BPRMA,T2    RMA OF BUFFER POOL BUFFER
          SRD    DATADD      SAVE R REQISTER
          STDL   DATADD+2    OFFSET OF FIRST DATA WORD

          LDDL   T3          LENGTH/ADDRESS PAIR OFFSET (PP WORDS)
          NJN    SBI10       IF NOT FIRST BUFFER

*         THE FIRST BUFFER IS THE ONLY ONE THAT MAY BE PARTIALLY FILLED.
*         CALCULATE THE FIRST DATA ADDRESS FOR IT.

          LDML   RS+/RS/P.DLEN,T3   LENGTH OF FIRST BUFFER (CM BYTES)
          ADN    7           ROUND UP
          SHN    -3          CONVERT TO CM WORDS
          STDL   T4          LENGTH OF FIRST BUFFER (CM WORDS)

          LDML   FBSIZE      MAXIMUM SIZE OF FIRST BUFFER (CM BYTES)
          SHN    -3          CONVERT TO CM WORDS
          ADDL   DATADD+2    OFFSET OF FIRST BUFFER WORD
          SBDL   T4          LENGTH OF FIRST BUFFER (CM WORDS)
          STDL   DATADD+2    OFFSET OF FIRST DATA WORD

 SBI10    BSS    0
          LDML   RS+/RS/P.DLEN,T3   LENGTH PART OF LENGTH/ADDRESS PAIR
          STDL   BUFLEN
          UJK    SBIX        EXIT
 SDB      SPACE  4,25
**        SDB - SHIFT DATA BUFFER.
*
*         THIS ROUTINE SHIFTS THE DATA BUFFER IF AN ODD NUMBER OF BYTES OF
*         DATA IS RECEIVED FROM THE DI.  THE DATA IS SHIFTED SO THAT THE
*         LAST BYTE IS IN THE LOWER PORTION OF THE LAST PP WORD INSTEAD
*         OF THE UPPER PORTION.  THIS ENSURES THAT THE DATA WILL
*         END ON A PP WORD BOUNDARY.  THIS IS NEEDED TO GUARANTEE THAT THE
*         CM BUFFER PASSED TO THE CPU WILL BE FILLED TO THE END.
*
*         E.G.  ASSUME B1, B2, ETC. ARE CM DATA BYTES (8 BITS LONG).
*               IOBUF IS THE PP DATA BUFFER CONSISTING OF 2 CM DATA BYTES FOR
*               EACH PP WORD (16 BITS LONG).
*
*                  FROM DI           SDB            TO CPU
*
*               IOBUF   B1 B2       ---->       IOBUF      B1
*                       B3 B4                           B2 B3
*                       B5                              B4 B5
*
*
*         ENTRY  (BYTCNT) = NUMBER OF BYTES IN PP BUFFER.
*
*         EXIT   DATA IN PP DATA BUFFER SHIFTED.
*
*         USES   T1, T2.


 SDB      SUBR               ENTRY/EXIT
          LDDL   BYTCNT      NUMBER OF CM BYTES IN PP BUFFER
          SHN    -1          NUMBER OF PP WORDS IN PP BUFFER
          STDL   T2          OFFSET OF THE NEW DATA LOCATION
          SBN    1
          STDL   T1          OFFSET OF THE OLD DATA LOCATION

*         SET UP THE LAST DATA LOCATION (JUST THE LOWER CM BYTE PORTION).

          LDML   IOBUF,T2    LAST DATA LOCATION
          SHN    -8          MOVE DATA BYTE OVER (LOWER CM BYTE)
          STML   IOBUF,T2    LAST DATA LOCATION INITIALIZED (LOWER CM BYTE)

*         SHIFT THE REST OF THE PP DATA BUFFER.

 SDB10    BSS    0

*         SET UP THE NEW DATA LOCATION (UPPER CM BYTE PORTION).

          LDML   IOBUF,T1    OLD DATA LOCATION
          LPC    377B        LOWER CM BYTE MASK
          SHN    8           MOVE DATA BYTE TO BE THE UPPER CM BYTE
          RAML   IOBUF,T2    NEW DATA LOCATION INITIALIZED (UPPER CM BYTE)

*         SET UP THE OLD DATA LOCATION (LOWER CM BYTE PORTION).

          LDML   IOBUF,T1    OLD DATA LOCATION
          SHN    -8          MOVE DATA BYTE OVER (LOWER CM BYTE)
          STML   IOBUF,T1    OLD DATA LOCATION INITIALIZED (LOWER CM BYTE)

          SODL   T2          NEXT NEW DATA LOCATION
          SODL   T1          NEXT OLD DATA LOCATION
          PJK    SDB10       IF MORE TO SHIFT
          UJK    SDBX        EXIT
          SPACE  4,10
**        OVERLAY 5 MUST NOT OVERLAY SWF
*
 OV5END   EQU    *           MAXIMUM LENGTH OF OVERLAY 5
 SWF      SPACE  4,16
**        SWF - SELECT WRITE FORMAT.
*
*         THIS ROUTINE SENDS A FUNCTION TO THE MDI INDICATING THE
*         TYPE OF PDU WHICH WILL BE SENT ON SUCCEEDING WRITES.
*
*         ENTRY  (LASTUR) = VALUE OF LAST UNIT REQUEST.
*                (LSTATE) = LAST KNOWN MDI STATE.
*                (STBI) = VALUE OF UNIT REQUEST BEING PROCESSED.
*
*         EXIT   (A) = 0 IF NO ERRORS,
*                    <> 0 IF ERRORS ON FUNCTION.
*
*         CALLS  IFR.


 SWF10    LDK    F.CNW
 SWF20    RJM    IFR         SEND FUNCTION

 SWF      SUBR               ENTRY/EXIT
          LDDL   LSTATE      LAST STATE
          LPK    ST.OPER     COMPARE WITH OPERATIONAL STATE
          ZJK    SWFX        IF NOT OPERATIONAL STATE
          LDML   LASTUR
          LMML   STBI
          ZJN    SWFX        IF NO CHANGE FROM LAST
          LDML   STBI
          STML   LASTUR
          LMC    C.WRTB
          ZJN    SWF10       IF CHANNELNET PDU
          LDK    F.CCW
          UJN    SWF20       CHANNEL CONNECTION
 WEC      SPACE  4,10
**        WEC - WRITE ERROR CHECK.
*
*         THIS ROUTINE WILL PERFORM INITIAL ERROR CHECKS
*         FOR WRITE RECOVERY.
*
*         ENTRY  (ERRCNT) = NUMBER OF WORDS NOT READ.
*
*         EXIT   (ERRT1) = SYMPTOM CODES IF ERRORS.
*
*         CALLS  IER.


 WEC      SUBR               ENTRY/EXIT
          RJM    IER         INITIALIZE ERROR RECOVERY
          STDL   CMLISTL
          AJM    WEC10,CHN   IF CHANNEL ACTIVE
          LDC    /RS/K.LSCD
          RADL   ERRT1       SET CHANNEL NOT ACTIVE ERROR
          UJN    WECX        EXIT

 WEC10    LDDL   ERRCNT
          ZJN    WEC20       IF TRANSFER COMPLETE
          LDC    /RS/K.LSIT  SET INCOMPLETE TRANSFER
          RADL   ERRT1
 WEC20    LDC    WTEMPTY*600
 WEC30    EJM    WEC40,CHN   IF CHANNEL EMPTY
          SBML   TI
          NJN    WEC30       IF NOT TIMED OUT
          LDC    /RS/K.LSCF
          RADL   ERRT1       SET CHANNEL NOT EMPTY
 WEC40    UJN    WECX        EXIT
          SPACE  4,10
 OV1CH    BSS                MDI CHANNEL REFERENCES
 TCHN+40B HERE
 T40B+CHN HERE
 TCHN     HERE
          CON    0           END OF TABLE
          SPACE  4,10
**        END OF OVERLAY
*

 OVEND    EQU    *+7
          SPACE  4,10

          OVERLAY  (MISCELLANEOUS INPUT/OUTPUT),OVEND
          ROUTINE  OV2
 CBP      SPACE  4,16
**        CBP - CHECK IF BUFFER IN POOL.
*
*         THIS ROUTINE WILL OBTAIN THE BUFFER POOL LOCK
*         AND DETERMINE IF A BUFFER IS AVAILABLE.
*         THE LOCK WILL BE CLEARED BEFORE EXIT.
*
*         ENTRY  (FSTBD) = INDEX INTO POOL BUFFER.
*
*         EXIT   (A) = 0, IF NO BUFFER AVAILABLE.
*                    <> 0, IF BUFFER AVAILABLE.
*                RESPONSE BUFFER POOL STATUS SET APPROPRIATELY IF POOL IS
*                          EMPTY OR BELOW THRESHOLD.
*                (BP - BP+7) = BUFFER POOL TABLE ENTRY.
*
*         USES   T2, T3, T9, WC.
*
*         CALLS  SBL.
*
*         MACROS LOADC, LOADF.
          SPACE  4,10
*         BUFFER POOL DESCRIPTOR PP OUT POINTER

 PPOUT    EQU    P1+/BPD/P.PPOUT-/BPD/C.PPOUT*4

 CBP      SUBR               ENTRY/EXIT
          LDDL   FSTBD       INDEX INTO BUFFER POOL
          SHN    2
          ADDL   FSTBD       5 WORDS PER BUFFER POOL DESCRIPTOR
          STDL   T9          CM WORD OFFSET OF BUFFER POOL DESCRIPTOR
          ADK    /BPD/C.PPOUT   OFFSET TO BPD PP OUT POINTER
          RJM    SBL         SET POOL DESCRIPTOR LOCK

*         GET BUFFER POOL DESCRIPTOR.

*         LDN    0
          STDL   T3          NUMBER OF BUFFERS OBTAINED
          LDN    C.BPD
          STDL   WC          LENGTH OF POOL DESCRIPTOR
          LOADC  CM.BPD      ADDRESS OF FIRST POOL DESCRIPTOR
          ADDL   T9          CM WORD OFFSET OF BUFFER POOL DESCRIPTOR
          CRML   BPD,WC

*         VALIDATE BUFFER POOL DESCRIPTOR IN POINTER.

          LDML   BPD+/BPD/P.IN   BUFFER POOL DESCRIPTOR IN POINTER
          LPK    7           BYTE OFFSET
          NJN    *           IF BPD IN POINTER NOT ON A CM WORD BOUNDARY

*         VALIDATE BUFFER POOL DESCRIPTOR OUT POINTER.

          LDDL   PPOUT       BUFFER POOL DESCRIPTOR PP OUT POINTER
          LPK    7           BYTE OFFSET
          NJN    *           IF BPD OUT POINTER NOT ON A CM WORD BOUNDARY

*         CHECK IF A BUFFER IS AVAILABLE.

          LDML   BPD+/BPD/P.IN   BUFFER POOL DESCRIPTOR IN POINTER
          SBDL   PPOUT           COMPARE WITH BPD PP OUT POINTER
          ZJN    CBP30       IF BUFFER POOL IS EMPTY
          AODL   T3          NUMBER OF BUFFERS OBTAINED

*         GET BUFFER POOL TABLE ENTRY.

          LDK    C.BP
          STDL   WC          BUFFER POOL ENTRY SIZE (CM WORDS)
          LDDL   PPOUT       BUFFER POOL ENTRY OFFSET (CM BYTES PER BP ENTRY)
          SHN    -3          CONVERT TO A BP ORDINAL (CM WORDS PER BP ENTRY)
          STDL   T2          BUFFER POOL ENTRY OFFSET (BP ENTRIES)
          LOADF  BPD+/BPD/P.BTRMA   BUFFER POOL TABLE FWA
          ADDL   T2          BUFFER POOL ENTRY OFFSET (CM WORDS)
          CRML   BP,WC

*         DETERMINE NEW BUFFER POOL DESCRIPTOR PP OUT POINTER VALUE.

          LDDL   PPOUT       BUFFER POOL DESCRIPTOR PP OUT POINTER
          ADK    C.BP*8      NEXT BUFFER POOL TABLE ENTRY
          SBML   BPD+/BPD/P.LIMIT   COMPARE WITH LIMIT
          ZJN    CBP20       IF AT LIMIT
          ADML   BPD+/BPD/P.LIMIT   RESTORE GOOD VALUE OF NEW BPD PP OUT POINTER

 CBP20    BSS    0
          STDL   PPOUT        NEW BUFFER POOL DESCRIPTOR PP OUT POINTER

*         CHECK IF A BUFFER IS AVAILABLE.

          LDML   BPD+/BPD/P.IN   BUFFER POOL DESCRIPTOR IN POINTER
          SBDL   PPOUT           COMPARE WITH BPD PP OUT POINTER
          NJN    CBP40       IF BUFFER POOL IS NOT EMPTY

*         BUFFER POOL IS EMPTY.

 CBP30    BSS    0
          LDDL   T3          NUMBER OF BUFFERS OBTAINED
          ZJN    CBP70       IF WE DID NOT EMPTY THE POOL (IF NO BUFFERS OBTAINED)
          IFEQ   DEBUG,1
          AOML   EMPBUF,FSTBD      INCREMENT EMPTY POOL COUNT
          ENDIF
          LDK    BP.EMPTY    EMPTY BUFFER POOL STATUS
          UJN    CBP60

*         CHECK IF BELOW THRESHOLD.

 CBP40    BSS    0
          PJN    CBP50       IF LIMIT NOT CROSSED OVER (IF NEXT BUFFER CONTIGUOUS)
          ADML   BPD+/BPD/P.LIMIT   RESTORE AVAILABLE BUFFERS (CM BYTES)

 CBP50    BSS    0
          ERRNZ  16-C.BP*8   BUFFER POOL ENTRY SIZE NOT 16 CM BYTES
          SHN    -4          CONVERT ENTRY SIZE (CM BYTES) TO NUMBER OF BUFFERS
          SBML   BPD+/BPD/P.THRESH   COMPARE WITH THRESHOLD
          PJN    CBP70       IF AVAILABLE BUFFERS .GE. THRESHOLD
          ADDL   T3          NUMBER OF BUFFERS OBTAINED
          MJN    CBP70       IF WE DID NOT VIOLATE THRESHOLD
          LDK    BP.THRSH    BUFFER POOL BELOW THRESHOLD STATUS

*         SET STATUS IN THE RESPONSE.

 CBP60    BSS    0
          STML   RS+/RS/P.T1STAT,FSTBD   SET STATUS

*         UPDATE BUFFER POOL DESCRIPTOR OUT POINTERS AND CLEAR THE BPD LOCK.

 CBP70    BSS    0
          LOADC  CM.BPD      ADDRESS OF FIRST POOL DESCRIPTOR
          ADDL   T9          CM WORD OFFSET OF BUFFER POOL DESCRIPTOR
          ADK    /BPD/C.CPUOUT   OFFSET TO BPD CPU OUT POINTER
          CWDL   PPOUT+/BPD/C.PPOUT*4-/BPD/P.PPOUT   NEW BPD CPU OUT POINTER
          ADK    /BPD/C.PPOUT-/BPD/C.CPUOUT   OFFSET TO BPD PP OUT POINTER
          CWDL   PPOUT+/BPD/C.PPOUT*4-/BPD/P.PPOUT   CLEAR THE BPD LOCK
          LDDL   T3          NUMBER OF BUFFERS OBTAINED
          UJK    CBPX        EXIT

 CBY      SPACE  4,12
**        CBY - CONVERT BYTE COUNT.
*
*         CONVERT BYTE COUNT TO 12-BIT CHANNEL COUNT.
*         THIS ROUTINE IS CALLED DURING BOTH READ AND WRITE
*         PROCESSING. WHEN CALLED DURING READ PROCESSING THE
*         CHANNEL COUNT IS ROUNDED UP TO INCLUDE *BYTCNT* BYTES.
*         WHEN CALLED FOR WRITE PROCESSING, THE CHANNEL COUNT
*         WILL BE ROUNDED UP ONLY IF THIS IS THE LAST FRAGMENT
*         TO BE OUTPUT (I.E., *CMLISTL* EQUALS ZERO.
*
*         ENTRY  (BYTCNT) = NUMBER OF BYTES.
*                (OTYPE) = TYPE OF OPERATION IN PROGRESS.
*                (CMLISTL) = 0, IF LAST WRITE BLOCK (I.E., ROUND UP CHANNEL COUNT)
*                          <> 0, IF NOT LAST WRITE BLOCK.
*
*         EXIT   (IOCNT) = NUMBER OF CHANNEL FRAMES REQUIRED TO SEND
*                        *BYTCNT* BYTES.
*                (REMBYT) = REMAINING BYTES IN PP BUFFER AFTER UPCOMING OUTPUT.
*
*         USES   T1, T2.


 CBY      SUBR               ENTRY/EXIT
          LDN    0
          STDL   IOCNT       CHANNEL COUNT
          LDDL   BYTCNT      BYTE COUNT
          ZJN    CBYX        IF ZERO BYTE COUNT
          STDL   T1
          LDN    3           DIVIDE BY 3
          SHN    14
          STDL   T2
 CBY10    BSS                DIVIDE LOOP
          LDDL   T1
          SBDL   T2
          MJN    CBY20
          STDL   T1
          AODL   IOCNT       INCREMENT CHANNEL COUNT
 CBY20    BSS
          LDDL   IOCNT
          SHN    1
          STDL   IOCNT       MULTIPLY BY 2
          LDDL   T2
          SHN    -1
          STDL   T2
          SBN    1
          NJN    CBY10       IF NOT DONE
          LDDL   T1
          STML   REMBYT      SAVE REMAINDER
          LDML   OTYPE       OPERATION TYPE
          SBN    /RS/K.LREAD
          ZJN    CBY25       IF READ OPERATION
          LDDL   CMLISTL
          NJN    CBY30       IF NOT LAST TRANSFER
 CBY25    LDML   REMBYT      REMAINING BYTES
          RADL   IOCNT       OUTPUT ALL DATA IN BUFFER
          LDN    0
          STML   REMBYT      ALL BYTES WILL BE TRANSFERRED
 CBY30    BSS    0
          UJK    CBYX        EXIT
 MDP      SPACE  4,18
**        MDP - MOVE DATA TO PP BUFFER.
*
*         THIS ROUTINE TRANSFERS DATA FROM CM TO THE PP
*         I/O BUFFER.
*
*         ENTRY  (A) = NUMBER OF BYTES TO TRANSFER.
*                (BYTCNT) = NUMBER OF BYTES IN PP BUFFER.
*                (CURBUF) = CURRENT PP BUFFER POINTER.
*                (SBYOFF) = STARTING BYTE OFFSET.
*
*         EXIT   (A) BYTES TRANSFERRED TO PP BUFFER.
*                (DATADD) AND (SBYOFF) UPDATED.
*
*         USES   WC.
*
*         CALLS  RPW.
*
*         MACROS LOADC.


 MDP      SUBR               ENTRY/EXIT
          STDL   RBYTS       REMAINING BYTES TO TRANSFER
          LDN    8-1
          SBDL   SBYOFF
          SBDL   RBYTS
          PJN    MDP10       IF LESS BYTES TO TRANSFER THAN IN FIRST WORD
          LDDL   SBYOFF      STARTING BYTE OFFSET
          ZJN    MDP20       IF WORD ALIGNED
 MDP10    BSS    0
          RJM    RPW         READ PARTIAL WORD
 MDP20    LDDL   RBYTS
          SHN    -3
          ZJN    MDP30       IF NO FULL WORDS TO TRANSFER
          STDL   WC
          LDDL   CURBUF      CURRENT BUFFER POINTER
          STML   MDPR        UPDATE PP ADDRESS FOR READ
          LOADC  DATADD
          CRML   IOBUF,WC
 MDPR     EQU    *-1
          STDL   DATADD+2    UPDATE CM ADDRESS
          LDDL   WC
          SHN    3
          RADL   BYTCNT      UPDATE PP BUFFER COUNT
          LDDL   WC
          SHN    2           PP WORDS READ IN
          RADL   CURBUF      UPDATE CURRENT BUFFER POINTER
 MDP30    LDDL   RBYTS
          LPN    7
          STDL   RBYTS
          ZJN    MDP40       IF DONE
          RJM    RPW         READ PARTIAL WORD
 MDP40    UJK    MDPX        EXIT
 RPW      SPACE  4,18
**        RPW - READ PARTIAL WORD.
*
*         THIS ROUTINE IS CALLED WHEN LESS THAN 1 FULL CM WORD
*         OF VALID DATA NEEDS TO BE TRANSFERRED TO THE PP-S
*         I/O BUFFER.
*
*         ENTRY  (BYTCNT) = NUMBER OF BYTES IN PP BUFFER.
*                (DATADD) = CM ADDRESS OF DATA.
*                (RBYTS) = REMAINING BYTES TO TRANSFER.
*                (SBYOFF) = STARTING BYTE OFFSET.
*
*         EXIT   (RBYTS) TRANSFERRED TO PP BUFFER.
*                (DATADD) , (BYTCNT) AND (SBYOFF) UPDATED.
*
*         USES   P1 - P4, P5, P6, T7, T8.
*
*         MACROS LOADC.


 RPW      SUBR               ENTRY/EXIT
          LOADC  DATADD
          CRDL   P1          READ CM BUFFER WORD
          AODL   DATADD+2    RMA OF NEXT CM WORD
          LDN    8
          SBDL   SBYOFF
          STDL   P5          VALID BYTES IN WORD
          LDDL   RBYTS       REMAINING BYTES TO TRANSFER
          ZJN    RPWX        EXIT - IF NO DATA
          SBDL   P5
          PJN    RPW10       IF ALL VALID BYTES TO BE TRANSFERRED
          SODL   DATADD+2    CM BUFFER WORD MUST BE READ AGAIN LATER
          LDDL   RBYTS
          STDL   P5          BYTES TO TRANSFER
 RPW10    BSS    0
          LDDL   P5
          STDL   T7
          LDDL   CURBUF      CURRENT BUFFER POINTER
          STDL   P6          PP BUFFER ADDRESS
          LDDL   SBYOFF
          SHN    -1
          STDL   T8          STARTING PP WORD OFFSET
          LDDL   SBYOFF
          LPN    1
          ZJN    RPW20       IF EVEN BYTE BOUNDARY
          LDML   P1,T8
          LPC    377B
          STML   P1,T8       CLEAR UPPER BYTE
          LDIL   P6
          LPC    177400B     CLEAR LOWER BYTE
          ADML   P1,T8       ADD LOWER BYTE
          STIL   P6
          AODL   T8
          AODL   P6          INCREMENT PP BUFFER ADDRESS
          SODL   P5
          ZJN    RPW30       IF DONE
 RPW20    BSS    0
          LDML   P1,T8
          STIL   P6          MOVE TO PP BUFFER
          AODL   T8          INCREMENT PP WORD OFFSET
          SODL   P5
          ZJN    RPW30       IF DONE
          AODL   P6          INCREMENT PP BUFFER ADDRESS
          SODL   P5
          NJN    RPW20       IF MORE BYTES TO MOVE
 RPW30    BSS    0
          LDDL   P6
          STDL   CURBUF      UPDATE CURRENT BUFFER POINTER
          LDDL   T7
          ADDL   SBYOFF
          LPN    7
          STDL   SBYOFF      NEW STARTING BYTE OFFSET
          LDDL   RBYTS
          SBDL   T7
          STDL   RBYTS       UPDATE REMAINING BYTE COUNT
          LDDL   T7
          RADL   BYTCNT      UPDATE PP BUFFER COUNT
          UJK    RPWX        EXIT
          SPACE  4,10
 OV2CH    BSS                MDI CHANNEL REFERENCES
 TCHN+40B HERE
 T40B+CHN HERE
 TCHN     HERE
          CON    0           END OF TABLE
          OVERFLOW  END
          OVERLAY  (DIAGNOSTIC STATE PROCESSOR),BUFEND
          ROUTINE  OV3
          SPACE  4,12
**        CFE - CHANNEL FULL ERROR.
*
*         THIS ROUTINE WILL DISCONNECT THE CHANNEL AND
*         LOG A CHANNEL FULL ERROR.
*
*         ENTRY  (A) = OPERATION TYPE.
*
*         CALLS  SSC.
          SPACE  4,10
 CFE      SUBR               ENTRY/EXIT
          DCN    CHN+40B     DISCONNECT CHANNEL
          STML   LRS+/RS/P.OPTP   STORE OPERATION TYPE
          LDK    /RS/K.LOF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDC    /RS/K.LSCF
          RJM    SSC         LOG SYMPTOM CODE
          UJN    CFEX        EXIT
 DIA      SPACE  4,14
**        DIA - DIAGNOSTIC STATE PROCESSOR.
*
*         THIS ROUTINE PERFORMS A NUMBER OF DIAGNOSTIC TESTS
*         TO DETERMINE THE CONDITION OF THE MCI AND THE CHANNEL.
*         AN OVERVIEW OF THE DIAGNOSTIC SEQUENCE FOLLOWS:
*         UPON SEEING GENERAL STATUS INDICATE DIAGNOSTIC STATE
*         THE PP ISSUES THE -REQUEST DIAGNOSTIC COMMAND- FUNCTION.
*         THE PP WILL THEN INPUT THE NEXT COMMAND AND EXECUTE
*         THE APPROPRIATE ROUTINE.  IF AN UNEXPECTED ERROR OCCURRED
*         THEN THE -ABORT DIAGNOSTIC SEQUENCE- FUNCTION IS ISSUED.
*
*         NOTE   DUE TO AN MCI HARDWARE PROBLEM SOME GENERAL STATUS
*                BITS CAN BE LEFT SET MOMENTARILY GIVING A FALSE
*                INDICATION OF DIAGNOSTIC STATE. THE TWO SECOND PAUSE
*                ON ENTRY ALLOWS FOR THIS CONDITION.
*
*         USES   P6.
*
*         CALLS  CSC, DEC, FAW, IFR, IGS, SLM, SSC, STB.


 DIA      SUBR               ENTRY/EXIT
*
*         PAUSE TWO SECONDS
*
          LDC    2000        WAIT TWO SECONDS
          STM    TIMB
 DIA01    RJM    CSC         CHECK IF STATE CHANGE
          NJN    DIAX        IF STATE CHANGE
 DIA02    IAN    14B         READ MICROSECOND COUNTER
          LPC    7777B
          SBM    TIMA
          PJN    DIA03       IF NO OVERFLOW
          ADC    10000B      COMPENSATE FOR CLOCK OVERFLOW
 DIA03    ADC    -1000
          MJN    DIA02       IF LESS THAN 1 MILLISECOND
          LDC    1000        ADVANCE BASE BY 1 MILLISECOND
          RAM    TIMA
          SOM    TIMB
          PJN    DIA01       IF NOT END OF PAUSE
 DIA10    BSS    0
          RJM    CSC         CHECK IF STATE CHANGE
          NJN    DIAX        IF NO STATE CHANGE
          LDDL   GNSTAT      GENERAL STATUS
          STML   STBI
          LMN    ST.DIAG*8
          NJK    DIA30       IF NOT PURE DIAGNOSTIC STATE
          LDN    F.RQDCMD    REQUEST DIAGNOSTIC COMMAND
          RJM    FAW
          NJN    DIA15       IF ERROR ON FUNCTION
          LDN    DCLEN
          IAPM   PREBUF,CHN
          RJM    DEC         CHECK FOR ERRORS
          NJN    DIA15       IF ERRORS READING COMMAND
          LDML   PREBUF
          SHN    -8
          STML   STBI        DIAGNOSTIC COMMAND
          LDC    DCT-2       COMMAND TABLE ADDRESS - 2
          RJM    STB         SEARCH TABLE
          ZJN    DIA20       IF INVALID COMMAND
          STDL   P6          PROCESSOR ADDRESS
          RJM    0,P6        PROCESS COMMAND
 DIA15    NJN    DIA35       IF PP DETECTED ERROR
          UJK    DIA10       GET NEXT COMMAND

 DIA20    LDK    /RS/K.LSMT
          RJM    SSC         SET SYMPTOM CODE
          LDK    /RS/K.LOF
          STML   LRS+/RS/P.ERRID
          LDK    /RS/K.LRDC
          STML   LRS+/RS/P.OPTP
          UJN    DIA50       COMPLETE LOGGING

 DIA30    LDC    DES-2       DIAGNOSTIC STATUS TABLE
          RJM    STB         SEARCH TABLE
          ZJN    DIA40       IF UNEXPECTED ERROR
          RJM    IFR         ISSUE FUNCTION
 DIA35    NJN    DIA60       IF ERROR ON FUNCTION
          UJK    DIA10

 DIA40    LDK    /RS/K.LGSCF
          STML   LRS+/RS/P.ERRID
 DIA50    LDML   PREBUF      LAST DIAGNOSTIC COMMAND
          STML   LRS+/RS/P.ERRW2
          RJM    IGS         INCLUDE GENERAL STATUS
          LDK    ST.PPD
          STDL   STCHNG      DOWN MDI
          RJM    SLM         SEND LOG MESSAGE
 DIA60    LDN    F.ABDSEQ    ABORT FUNCTION
          RJM    IFR         ISSUE ABORT FUNCTION AND IGNORE ERROR
          UJK    DIAX        EXIT
          SPACE  4,10
**        DIAGNOSTIC COMMAND/PROCESSOR TABLE.
*
*         EACH TWO WORD ENTRY IN *DCT* HAS THE FOLLOWING FORMAT.
*         WORD 1 = DIAGNOSTIC COMMAND.
*         WORD 2 = ADDRESS OF COMMAND PROCESSOR.

 DCT      BSS    0
          CON    DC.TMRQ,DTM   TEST MODE REQUEST
          CON    DC.DTPP,DDT   DATA TRANSFER TO PP
          CON    DC.RDPP,DRD   RETURN DATA FROM PP
          CON    DC.SBP,DSP    SET BIT PACKING
          CON    DC.RPBD,DRP   READ AND PACK BIT DATA
          CON    0
          SPACE  4,10
**        DIAGNOSTIC ERROR STATUS/FUNCTION CODE TABLE.
*
*         EACH TWO WORD ENTRY IN *DES* HAS THE FOLLOWING FORMAT.
*         WORD 1 = GENERAL STATUS ERROR CONDITION.
*         WORD 2 = FUNCTION CODE TO ISSUE AFTER ERROR.

 DES      BSS    0
          CON    EXME,F.DMERR  EXPECTED MEMORY ERROR
          CON    EXER,F.DERR   EXPECTED ERROR DETECTED
          CON    0
          TITLE  DIAGNOSTIC STATE ROUTINES.
**        DCE - DIAGNOSTIC CHANNEL ERROR.
*
*         THIS ROUTINE WILL LOG A CHANNEL ERROR IN DIAGNOSTIC
*         STATE.
*
*         ENTRY  (A) = OPERATION CODE.
*
*         EXIT   (A) <> 1.
*


*         CALLS  GER, SLM, SSC.
 DCE      SUBR               ENTRY/EXIT
          STML   LRS+/RS/P.OPTP
          RJM    GER         RECORD ERROR REGISTER
          RJM    SSC         SET SYMPTOM CODE
          LDK    /RS/K.LOF
          STML   LRS+/RS/P.ERRID
          RJM    SLM         SEND LOG MESSAGE
          UJN    DCEX        EXIT
 DDT      SPACE  4,14
**        DDT - DIAGNOSTIC DATA TRANSFER.
*
*         THIS ROUTINE WILL WAIT FOR *DATA AVAILABLE* AND THEN
*         ATTEMPT TO INPUT 1024D CHANNEL FRAMES.  IF AN ERROR
*         IS DETECTED DURING THE TRANSFER, PROCESSING WILL
*         CONTINUE, AS THE MCI MAY HAVE FORCED THE ERROR.
*
*         EXIT   (A) = 0, IF NO ERRORS.
*                (A) <> 0, IF TRANSFER COULD NOT BE STARTED.
*                (IOCNT) = NUMBER OF CHANNEL FRAMES TRANSFERRED.
*
*         USES   T2.
*
*         CALLS  DCE, FAW, TDA.


 DDT      SUBR               ENTRY/EXIT
          RJM    TDA         TIMEOUT DATA AVAILABLE
          NJN    DDTX        IF ERRORS
          LDC    F.READ
          RJM    FAW         ISSUE READ FUNCTION
          NJN    DDTX        IF CHANNEL ERROR
          LDC    MAXCHN      MAXIMUM DATA TRANSFER LENGTH
          STDL   IOCNT
          IAPM   IOBUF,CHN
          ZJN    DDT10       IF ALL DATA READ
          STDL   T2          SAVE NUMBER OF WORD LEFT TO READ
          LDDL   IOCNT
          SBDL   T2
          STDL   IOCNT       CHANNEL FRAMES TRANSFERRED
 DDT10    DCN    CHN+40B
          LDM    DRDA        ** INSTRUCTION MODIFICATION **
          ADC    100000B
          STML   DRDA        CHANGE OUTPUT INSTR TO OAPM
          LDN    0
          CFM    DDTX,CHN    EXIT IF NO CHANNEL ERROR
          LDK    /RS/K.LREAD
          RJM    DCE         LOG CHANNEL ERROR
          UJK    DDTX        EXIT (A) <> 0
 DEC      SPACE  4,11
**        DEC - DIAGNOSTIC ERROR CHECK.
*
*         THIS ROUTINE WILL PERFORM INITIAL ERROR CHECKS
*         FOR READ RECOVERY IN DIAGNOSTIC MODE.
*
*         ENTRY  (A) = NUMBER OF WORDS NOT READ.
*
*         EXIT   (A) = 0 IF NO ERRORS.
*                    <> 0 IF ERRORS.
*


*         CALLS  CSC, GER, IGS, SLM, SSC.
 DEC      SUBR               ENTRY/EXIT
          STDL   ERRCNT      SAVE WORDS NOT READ
          LDC    WTDEACT*600 WAIT FOR CHANNEL NOT ACTIVE
 DEC10    IJM    DEC30,CHN   IF CHANNEL NOT ACTIVE
          SBML   TI
          NJN    DEC10       IF NOT TIMED OUT
          LDDL   ERRCNT
          NJN    DEC20       IF TRANSFER NOT COMPLETE
          LDC    100000B     MESSAGE LARGER THAN EXPECTED
          STML   ACTD
          DCN    CHN+40B
          UJN    DEC40       LOG ERROR

 DEC20    LDC    /RS/K.LSIT
          UJN    DEC50       SET INCOMPLETE TRANSFER

 DEC30    LDN    DCLEN       LENGTH OF READ
          STML   EXPD
          SBDL   ERRCNT
          STML   ACTD
          SBN    DCLEN
          ZJN    DEC60       IF LENGTH OK
 DEC40    LDC    /RS/K.LSMLV
 DEC50    RADL   ERRT1       MESSAGE LENGTH VERIFICATION ERROR
 DEC60    CFM    DEC70,CHN   IF NO CHANNEL ERROR
          RJM    GER         RECORD ERROR REGISTER
          RADL   ERRT1       CHANNEL ERROR
 DEC70    RJM    CSC         GET STATUS AND CHECK STATE CHANGE
          NJK    DECX        IF ERRORS
          LDDL   GNSTAT
          SHN    17-S.ERROR
          PJN    DEC80       IF NO GENERAL STATUS ERROR
          LDC    /RS/K.LSGSE
          RADL   ERRT1
 DEC80    LDDL   ERRT1
          ZJN    DEC100      IF NO ERRORS EXIT
          RJM    SSC         SET SYMPTOM CODE
          RJM    IGS         INCLUDE GENERAL STATUS
          LDML   EXPD
          STML   LRS+/RS/P.EXPD+1  INCLUDE EXPECTED LENGTH
          LDML   ACTD
          STML   LRS+/RS/P.ACTD+1  INCLUDE ACTUAL LENGTH
          LDK    /RS/K.LOF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDC    /RS/K.LRDC
          STML   LRS+/RS/P.OPTP STORE OPERATION TYPE
          LDDL   ERRT1
          LMK    /RS/K.LSCEF
          ZJN    DEC90       IF ONLY CHANNEL ERROR
          LDK    ST.PPD
          STDL   STCHNG      DOWN MDI
 DEC90    RJM    SLM         SEND LOG MESSAGE
 DEC100   UJK    DECX        EXIT
 DRD      SPACE  4,16
**        DRD - DIAGNOSTIC RETURN DATA.
*
*         THIS ROUTINE WILL WAIT FOR -SEND DATA- AND ATTEMPT
*         TO OUTPUT THE DATA IN THE PP BUFFER.  THE OUTPUT IS
*         DONE USING EITHER AN OAM OR AN OAPM DEPENDING ON
*         HOW THE DATA WAS READ IN.  IF AN ERROR OCCURS DURING
*         THE OUTPUT, PROCESSING WILL CONTINUE AS THE MCI MAY
*         HAVE FORCED THE ERROR.
*
*         ENTRY  (IOCNT) = NUMBER OF CHANNEL FRAMES TO TRANSFER.
*
*         EXIT   (A) = 0, IF NO ERRORS.
*                (A) <> 0, IF TRANSFER COULD NOT BE STARTED.
*
*         CALLS  CFE, CSC, CSD, IFR, SLM.


 DRD      SUBR               ENTRY/EXIT
 DRD10    RJM    CSC         CHECK STATE CHANGE
          NJN    DRDX        IF STATE CHANGE
          RJM    CSD         CHECK IF SEND DATA UP
          NJN    DRD10       IF SEND DATA NOT UP
          LDC    F.WRITE
          RJM    IFR         ISSUE WRITE FUNCTION
          NJN    DRDX        IF FUNCTION TIMEOUT
          ACN    CHN
          LDDL   IOCNT       CHANNEL FRAMES TO OUTPUT

          OAPM   IOBUF,CHN   IF IAPM USED FOR READ
*         OAM    IOBUF,CHN   IF IAM USED FOR READ
 DRDA     EQU    *-2
          LDK    WTEMPTY*600
 DRD30    EJM    DRD40,CHN   IF CHANNEL EMPTY
          SBML   TI
          NJN    DRD30       IF NOT TIMED OUT
          LDK    /RS/K.LWRT
          RJM    CFE         SET CHANNEL FULL ERROR
          LDK    ST.PPD
          STDL   STCHNG
          RJM    SLM         SEND LOG MESSAGE
          UJN    DRD50       RETURN ERRORS

 DRD40    LDN    0           RETURN NO ERROR
 DRD50    DCN    CHN+40B
          UJK    DRDX        EXIT
 DRP      SPACE  4,14
**        DRP - DIAGNOSTIC READ AND PACK.
*
*         THIS ROUTINE WILL WAIT FOR -DATA AVAILABLE- AND
*         THEN ATTEMPT TO INPUT 8 CHANNEL FRAMES.  IF INPUT
*         IS SUCCESSFUL THE DATA WILL BE PACKED AS DESCRIBED
*         IN THE *MAINTENANCE SOFTWARE ERS* - ARH5176.
*
*         EXIT   (A) = 0, IF NO ERRORS.
*                (A) <> 0, IF TRANSFER FAILED.
*                (IOCNT) = NUMBER OF CHANNEL FRAMES TRANSFERRED.
*
*         USES   T2, T3, T4, T5.
*
*         CALLS  DCE, FAW, TDA.


 DRP      SUBR               ENTRY/EXIT
          RJM    TDA         TIMEOUT DATA AVAILABLE
          NJN    DRPX        IF ERRORS
          LDC    F.READ      READ DATA
          RJM    FAW
          NJN    DRPX        IF CHANNEL ERROR
          LDN    PKDCHN      CHANNEL FRAMES TO TRANSFER
          STDL   IOCNT
          IAM    IOBUF,CHN
          ZJN    DRP10       IF ALL DATA READ
          STDL   T2
          LDDL   IOCNT
          SBDL   T2
          STDL   IOCNT       CHANNEL FRAMES TRANSFERRED
 DRP10    BSS    0
          DCN    CHN+40B
          LDM    DRDA        ** INSTRUCTION MODIFICATION **
          STML   DRDA        CHANGE OUTPUT INSTR TO OAM

*         PACK DATA FOR RETURN TO MCI

          LDDL   IOCNT
          ADN    1
          SHN    -1
          STDL   T5
          LDN    0
          STDL   IOCNT
          LDC    IOBUF
          STDL   T3
 DRP20    BSS    0
          LDIL   T3
          SHN    -4          PACK DATA
          SCN    17B
          STDL   T4
          AODL   T3
          LDIL   T3
          SHN    -8
          LMD    T4
          LMC    7400B
          STML   IOBUF,IOCNT
          AODL   T3
          AODL   IOCNT
          SBDL   T5
          NJN    DRP20       IF MORE DATA TO PACK
          CFM    DRPX,CHN    EXIT IF NO CHANNEL ERROR
          LDK    /RS/K.LWRT
          RJM    DCE         LOG CHANNEL ERROR
          UJK    DRPX        EXIT  (A)<> 0
 DSP      SPACE  4,10
**        DSP - DIAGNOSTIC SET PACKING.
*
*         THIS ROUTINE WILL ISSUE THE *SET BIT PACKING*
*         FUNCTION.
*
*         EXIT   (A) = 0, IF NO ERRORS.
*                (A) <> 0, IF FUNCTION TIMEOUT.
*
*         CALLS  IFR.


 DSP      SUBR               ENTRY/EXIT
          LDC    F.BITPM
          RJM    IFR         ISSUE BIT PACKING MODE FUNCTION
          UJN    DSPX
 DTM      SPACE  4,10
**        DTM - DIAGNOSTIC TEST MODE.
*
*         THIS ROUTINE WILL ISSUE THE *USE BIT MODE TESTING*
*         FUNCTION.
*
*         EXIT   (A) = 0, IF NO ERRORS.
*                (A) <> 0, IF FUNCTION TIMEOUT.
*
*         CALLS  IFR.


 DTM      SUBR               ENTRY/EXIT
          LDN    F.USEBIT
          RJM    IFR         ISSUE BIT MODE TESTING FUNCTION
          UJN    DTMX
 TDA      SPACE  4,10
**        TDA - TIMEOUT DATA AVAILABLE.
*
*         THIS ROUTINE WILL WAIT FOR DATA AVAILABLE
*         WHICH MUST BE PRESENT WITHIN ONE SECOND.  IF DATA
*         AVAILABLE IS NOT PRESENT IN GENERAL STATUS THE MDI IS DOWNED.
*
*         EXIT   (A) = 0, IF NO ERRORS.
*                (A) <> 0, IF ERRORS.
*
*         CALLS  CDA, IGS, SLM.


 TDA20    LDN    0

 TDA      SUBR               ENTRY/EXIT
          LDK    WTDAV*70
          STML   RETRY
 TDA10    RJM    CDA         CHECK SEND DATA AVAILABLE
          MJN    TDA20       IF SEND DATA AVAILABLE
          LDDL   STCHNG
          NJN    TDAX        IF STATE CHANGING
          SOML   RETRY
          NJN    TDA10       IF NOT TIMEOUT
          LDK    /RS/K.LGSDAT
          STML   LRS+/RS/P.ERRID
          RJM    IGS
          LDML   PREBUF      DIAGNOSTIC COMMAND
          STML   LRS+/RS/P.ERRW2
          LDK    ST.PPD
          STDL   STCHNG      DOWN MDI
          RJM    SLM         SEND LOG MESSAGE
          UJN    TDAX        EXIT WITH ERROR
          SPACE  4,10
 OV3CH    BSS                MDI CHANNEL REFERENCES
 TCHN+40B HERE
 T40B+CHN HERE
 TCHN     HERE
          CON    0           END OF TABLE
          OVERFLOW  OVEND
          OVERLAY  (MISCELLANEOUS STATE PROCESSORS),BUFEND
          ROUTINE  OV4
          TITLE  IDL - IDLE STATE PROCESSOR.
**        IDL - IDLE STATE PROCESSOR.
*
*         THIS ROUTINE PROCESSES THE IDLE STATE.  THE IDLE STATE
*         IS UNRELATED TO THE MDI S STATE.  AN IDLE COMMAND FROM
*         THE CP CAUSES THIS STATE TO BE ENTERED, AND A RESUME
*         COMMAND CAUSES THE EXIT. IF THE MDI IS CONNECTED
*         TO A CONCURRENT CHANNEL, THE CHANNEL IS INITIALIZED
*         UPON RECEIPT OF A RESUME.
*
*         USES   T1 - T4.
*
*         CALLS  CCK, FAW, IFR, PPR, SCK.
 IDL      SUBR               ENTRY/EXIT
          LDML   CHLOCK
          ZJN    IDL10       IF CHANNEL NOT LOCKED
 IDL05    RJM    CCK         CLEAR CHANNEL LOCK
 IDL10    RJM    PPR         PROCESS PP REQUESTS
          LDDL   STCHNG
          NJN    IDL10       IF MDI DOWNED OR PP IDLE
 IDL20    RJM    SCK         SET CHANNEL LOCK
          NJN    IDL20       RETRY IF NOT LOCKED
          LOADC  CM.CHAN
          ADN    /CIT/C.FLAGS
          ADML   CHAN
          CRDL   T1          READ CHANNEL FLAG WORD
          LDDL   T1
          SHN    17-/CIT/CONC
          PJN    IDL90       IF NOT CONCURRENT
          DCN    CHN+40B
          LDC    F.CCCLR
          RJM    IFR         MASTER CLEAR CHANNEL
 IDL30    NJK    IDL05       IF ERRORS
          LDC    F.WRCR
          RJM    IFR         WRITE CONTROL REGISTER
          NJN    IDL30       IF ERRORS
          ACN    CHN
          LDC    INITCR
          OAN    CHN
          DCN    CHN+40B
          LDN    0
          STML   CHTYP
 IDL90    UJK    IDLX        EXIT
          TITLE  INV - INVALID STATE PROCESSOR.
**        INV - INVALID STATE PROCESSOR.
*
*         THIS ROUTINE PROCESSES AN MDI STATE SWITCH TO AN INVALID STATE.
*
*         CALLS  IGS, SLM.


 INV      SUBR               ENTRY/EXIT
          LDN    ST.PPR
          STDL   STCHNG      INITIATE A PP RESET
          LDDL   LSTATE
          STML   LRS+/RS/P.CURST  LOG CURRENT STATE
          LDML   PREST
          STML   LRS+/RS/P.PREST  LOG PREVIOUS STATE
          LDK    /RS/K.LIVST
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          RJM    IGS         INCLUDE GENERAL STATUS
          RJM    SLM         SEND LOG RESPONSE
          UJK    INVX        EXIT
          TITLE  MCM - MASTER CLEAR MCI.
**        MCM - MASTER CLEAR MCI.
*
*         SENDS THE MASTER CLEAR DIRECT FUNCTION TO THE MCI.
*
*         CALLS  IFR, GST.


 MCM      SUBR               ENTRY/EXIT
          LDC    F.MCLEAR    MASTER CLEAR
          RJM    IFR         ISSUE FUNCTION REQUEST
          NJN    MCMX        EXIT - IF ERROR
          LCN    0
 MCM10    SBN    1
          NJN    MCM10       IF TIMEOUT NOT COMPLETE
          RJM    GST         GET STATUS
          NJN    MCMX        IF ERRORS
          LDDL   GNSTAT
          LPC    STBITS
          SHN    17-S.OPER
          MJN    MCM20       IF OPERATIONAL
          SHN    0-3-17+S.OPER
          LMN    ST.LOAD
          NJN    MCMX        EXIT - IF NOT LOADING STATE
 MCM20    LDN    /RS/K.LMCF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          RJM    IGS         INCLUDE GENERAL STATUS
          LDN    ST.PPD
          STDL   STCHNG      DOWN MDI
          RJM    SLM         SEND LOG MESSAGE
          UJK    MCMX        EXIT
          TITLE  MFR - MDI RESET STATE PROCESSOR.
**        MFR - MDI RESET STATE PROCESSOR.
*
*         CALLS  CSC, PPR.


 MFR      SUBR               ENTRY/EXIT
 MFR10    BSS    0
          RJM    PPR         PROCESS PP REQUESTS
          RJM    CSC         CHECK IF STATE CHANGE
          NJN    MFRX        IF STATE CHANGE - EXIT
          UJN    MFR10
          SPACE  4,10
**        SCK - SET CHANNEL LOCK.
*
*         SETS THE CHANNEL LOCK IN THE CM CHANNEL TABLE.
*
*         ENTRY  (CM.CHAN) = START OF 3 WORDS
*                  THAT CONTAIN A REFORMATTED CM ADDRESS
*                  POINTING TO THE CHANNEL TABLE.
*
*                (CHAN) = CHANNEL NUMBER.
*
*         EXIT    (A) = 0 IF LOCK SET.
*                 (A) <> 0 IF LOCK COULD NOT BE SET.
*
*         USES   T5, T7.
*
*         CALLS  SLK.
          SPACE  4,10
SCK       SUBR               ENTRY/EXIT
          LDK    CM.CHAN
          STDL   T7          SET POINTER TO CHANNEL TABLE
          LDML   CHAN
          STDL   T5          SET CHANNEL NUMBER AS INDEX
          RJM    SLK         SET THE LOCK ON THAT CM WORD
          NJN    SCKX        EXIT IF LOCK NOT SET
          LCN    0
          STML   CHLOCK      SET CHANNEL LOCKED FLAG
          LDN    0
          UJK    SCKX        EXIT
          SPACE  4,10
 OV4CH    BSS                MDI CHANNEL REFERENCES
 TCHN+40B HERE
 T40B+CHN HERE
 TCHN     HERE
          CON    0           END OF TABLE
          OVERFLOW  OVEND
          OVERLAY  (RETURN INLINE MESSAGE),FPB
          ROUTINE  OV5
          TITLE  ILD - IN-LINE DIAGNOSTIC MESSAGE PROCESSOR.
 ILD      SPACE  4,7
**        ILD - IN-LINE DIAGNOSTIC MESSAGE PROCESSOR.
*
*         THIS ROUTINE IS ENTERED WHEN AN IN-LINE DIAGNOSTIC
*         MESSAGE HAS BEEN SUCCESSFULLY READ AND IS WAITING
*         TO BE RETURNED TO THE MDI.
*
*         CALLS  CSD, IFR, PPR, RIM.


 ILD      SUBR               ENTRY/EXIT
 ILD10    RJM    PPR         PROCESS PP REQUESTS
          RJM    CSC         CHECK STATE CHANGE
          NJN    ILD30       IF STATE CHANGE
          RJM    CSD         CHECK FOR SEND DATA
          ZJN    ILD20       IF SEND DATA UP
          PJN    ILD10       IF TIMEOUT NOT EXPIRED
          LDK    F.ILTO
          RJM    IFR         ISSUE TIMEOUT FUNCTION
          UJN    ILD30

 ILD20    RJM    RIM         RETURN IN-LINE MESSAGE TO MDI
 ILD30    LDN    0
          STML   INLINE      NO IN-LINE MESSAGE AWAITING RETURN
          UJN    ILDX        EXIT
 RIM      SPACE  4,18
**        RIM - RETURN IN-LINE MESSAGE.
*
*         THIS ROUTINE RETURNS THE IN-LINE DIAGNOSTIC
*         MESSAGE THAT IS IN THE PP BUFFER.  THE MESSAGE
*         CAN BE WRITTEN BACK IN ONE OF TWO MODES; THE
*         MODE TO BE USED IS DETERMINED BY EXAMINING THE
*         MESSAGE TEST HEADER.  THE MODES ARE: OUTPUT DATA
*         WITH A DELAY BETWEEN EVERY 4 CHANNEL FRAMES, OR
*         OUTPUT DATA IN ONE BLOCK.
*
*         ENTRY  SEND DATA BIT SET IN GENERAL STATUS.
*                (EXPD) = MESSAGE LENGTH IN BYTES.
*                (IOBUF) = START OF IN-LINE MESSAGE.
*
*         USES   T1 - T2.
*
*         CALLS  ERR, IFR, SWF.


 RIM      SUBR               ENTRY/EXIT
          LDC    C.WRTB
          STML   STBI
          RJM    SWF         SELECT WRITE FORMAT
          NJN    RIM07       IF FUNCTION ERRORS
          LDML   EXPD
          STDL   BYTCNT
          LDN    /RS/K.LILWRT  IN-LINE WRITE OPERATION
          STML   OTYPE
          RJM    CBY         CONVERT BYTES TO CHANNEL FRAMES
 RIM05    LDC    F.WRITE
          RJM    IFR         ISSUE WRITE FUNCTION
          ZJN    RIM10       IF FUNCTION SUCCESSFUL
 RIM07    UJK    RIM70

 RIM10    BSS    0
          LDC    IOBUF
          STML   RIMA        RESTORE OUTPUT START ADDRESS
          ACN    CHN         ACTIVATE CHANNEL
          LDML   IOBUF+P.H802.3+P.H802.2   BITS 0-7 OF TEST HEADER IN BITS 8-15
          SHN    17-IL.WDLY-8
          MJN    RIM20       IF OUTPUT WITH DELAY
          LDN    0
          STDL   T1
          STDL   T2
          LDDL   IOCNT
          UJN    RIM40

 RIM20    LDDL   IOCNT       CHANNEL COUNT TO OUTPUT MESSAGE
          SHN    -2          DIVIDE BY 4
          STDL   T1          NUMBER OF OUTPUTS AT 4 FRAMES/OUTPUT
          LDDL   IOCNT
          LPN    3
          STDL   T2          REMAINING FRAMES (IOCNT MOD 4)
 RIM30    LDN    4
 RIM40    OAPM   IOBUF,CHN   OUTPUT MESSAGE
 RIMA     EQU    *-1         MODIFIED IF OUTPUT WITH DELAY
          NJN    RIM60       IF ERROR
          LDN    3
          RAML   RIMA        INCREMENT OUTPUT ADDRESS
          SODL   T1
          ZJN    RIM50       IF ALL FULL BLOCKS SENT
          PJN    RIM30       IF OUTPUT NOT COMPLETE
          LDN    0
          UJN    RIM60       OUTPUT COMPLETE

 RIM50    BSS    0
          LDDL   T2          REMAINING FRAMES TO TRANSFER
          NJN    RIM40       IF FRAMES TO TRANSFER
 RIM60    STDL   ERRCNT      NUMBER OF WORDS NOT WRITTEN
          LDK    /RS/K.LILWRT
          RJM    ERR         CHECK ERRORS
          ZJN    RIM70       IF NO ERRORS
          LDDL   STCHNG
          NJN    RIM70       EXIT IF RESET
          LDDL   ERRT1
          LPC    /RS/K.LSCEF
          ZJN    RIM63       IF NO CHANNEL ERROR FLAG
          LDDL   GNSTAT
          SHN    17-S.ERROR
          PJN    RIM70       IF ONLY ERROR WAS CEF IGNORE
 RIM63    LDML   RDRTY
          ZJN    RIM70       IF UNRECOVERED
          UJK    RIM05       IF IN RECOVERY

 RIM70    LDN    FTRY
          STML   RDRTY       RESET RETRY COUNTER
          UJK    RIMX        EXIT
          SPACE  4,10
 OV5CH    BSS                MDI CHANNEL REFERENCES
 TCHN+40B HERE
 T40B+CHN HERE
 TCHN     HERE
          CON    0           END OF TABLE
          OVERFLOW  OV5END
          OVERLAY  (DETAILED STATUS),OVEND
          ROUTINE  OV6
 DST      SPACE  4,12
**        DST - DETAILED STATUS.
*
*         THIS ROUTINE READS THE MDI DETAILED STATUS INTO
*         THE RESPONSE BUFFER.  THE RESPONSE BUFFER IS UPDATED
*         TO SHOW DETAILED STATUS IS INCLUDED.  IF ERRORS ARE
*         ENCOUNTERED THEY ARE LOGGED AS INTERMEDIATE ERRORS.
*
*         EXIT   (A) = 0, IF NO ERROR,
*                    <> 0, IF ERROR.
*
*         USES   T7, T8.
*
*         CALLS  CSC, FAW, GER, IGS, SLM, SRU, SSC.
          SPACE  4,10
 DST      SUBR               ENTRY/EXIT
          LDN    FTRY
          STML   DSTRC
 DST10    LDN    F.DS        DETAILED STATUS
          RJM    FAW
          NJN    DSTX        IF FUNCTION TIMEOUT OR OTHER ERROR
          STML   DSTER
          LDN    LDS170
          IAPM   LRS+/RS/P.DETAIL,CHN  INPUT DETAILED STATUS
          ZJN    DST20       IF INPUT COMPLETE
          LDC    /RS/K.LSIT
          RAML   DSTER       SET INCOMPLETE TRANSFER
 DST20    LDN    5
          IJM    DST30,CHN   IF CHANNEL INACTIVE
          SBN    1
          NJN    DST20       IF NOT TIMEOUT
          DCN    CHN+40B     DISCONNECT CHANNEL
          LDC    /RS/K.LSMLV
          RAML   DSTER       MESSAGE LENGTH ERROR
 DST30    CFM    DST40,CHN   IF NOT CHANNEL ERROR
          RJM    GER         RECORD ERROR REGISTER
          RAML   DSTER       SET CHANNEL ERROR
 DST40    RJM    GST         GET GENERAL STATUS
          NJK    DSTX        IF *GST* ERRORS OR STATE CHANGE
          LDDL   GNSTAT
          SHN    17-S.ERROR
          PJN    DST50       IF NO ERRORS GETTING DETAILED STATUS
          LDC    /RS/K.LSGSE
          RAML   DSTER       SET GENERAL STATUS ERROR
          RJM    IGS         INCLUDE GENERAL STATUS
 DST50    LDML   DSTER
          NJN    DST60       IF ERRORS GETTING DETAILED STATUS
          LDC    /RS/K.LDS
          STML   DSTER       UPDATE DETAILED STATUS INCLUDED
          LMC    -0          BIT IN RESPONSE BUFFER
          STML   DSTRC
          LDML   LRS+/RS/P.LDS
          LPML   DSTRC
          ADML   DSTER
          STML   LRS+/RS/P.LDS
          LDN    0
          UJK    DSTX        EXIT NO ERRORS

 DST60    RJM    SSC         SET SYMPTOM CODES
          LDK    /RS/K.LOF
          STML   LRS+/RS/P.ERRID  STORE ERROR ID
          LDK    /RS/K.LRDS
          STML   LRS+/RS/P.OPTP   STORE OPERATION TYPE
          SOML   DSTRC       DECREMENT RETRY COUNT
          ZJN    DST70       IF UNRECOVERED
          LDN    REC.I       SET INTERMEDIATE ERROR
          STML   LRS+/RS/P.RETSUC
          LDN    FTRY
          SBML   DSTRC       RETRY COUNT
          STML   LRS+/RS/P.RETCT
          RJM    SLM         SEND LOG MESSAGE
          UJK    DST10       RETRY

 DST70    RJM    SRU         UNRECOVERED ERROR
          LDN    ST.PPR
          STDL   STCHNG      RESET MDI
          RJM    SLM         SEND LOG MESSAGE
          UJK    DSTX        EXIT WITH ERROR

 DSTRC    BSSZ   1           RETRY COUNT
 DSTER    BSSZ   1           SYMPTOM CODES
          SPACE  4,10
 OV6CH    BSS                MDI CHANNEL REFERENCES
 TCHN+40B HERE
 T40B+CHN HERE
 TCHN     HERE
          CON    0           END OF TABLE
          OVERFLOW  END
          OVERLAY  (STATE CHANGE ROUTINES),BUFEND
          ROUTINE  OV7
 LAM      SPACE  4,12
**        LAM - LOG AVAILABILITY MESSAGE.
*
*         THIS ROUTINE WILL LOG A MESSAGE INDICATING THE
*         AVAILABILITY OF THE MDI.
*
*         ENTRY  (AVAIL) = VALUE OF LAST AVAILABILITY
*                          RESPONSE SENT TO THE CPU.
*
*         EXIT   (A) = 0 IF NO ERRORS.
*                    <> 0 IF ERRORS.
*
*         CALLS  GDS, IGS, SLM.


 LAM      SUBR               ENTRY/EXIT
          LDML   AVAIL
          LMN    URC.LO
          NJN    LAM20       IF NOT AVAILABLE
          RJM    GDS         GET DETAILED STATUS
          NJN    LAMX        EXIT IF DST ERRORS
          LDK    /RS/K.LMDIA
 LAM10    STML   LRS+/RS/P.ERRID
          RJM    IGS         INCLUDE GENERAL STATUS
          LDN    REC.IM
          STML   LRS+/RS/P.RETSUC
          RJM    SLM         SEND LOG MESSAGE
          LDN    0
          UJN    LAMX        EXIT

 LAM20    STML   NEGPR
          LDK    /RS/K.LMDIR
          UJN    LAM10       CONTINUE
 NCP      SPACE  4,14
**        NCP - NEGOTIATE CHANNEL PROTOCOL.
*
*         NEGOTIATE WITH THE MDI TO DETERMINE WHICH CHANNEL
*         PROTOCOL WILL BE USED.
*
*         EXIT   A = 0 IF NEGOTIATIONS SUCCESSFULL,
*                  <> 0 IF NEGOTIATIONS NOT SUCCESSFULL.
*
*         CALLS  GDS, IFR, ILR, SLM.


 NCP10    LDML   LRS+/RS/P.DETAIL+DS.MPS+1
          STML   TCCH+/HD/P.MRS
          RJM    ILR         INITIALIZE LOG RESPONSE
          LDN    0
          STML   RDRTY       RESET RETRY COUNTER
          STML   NEGPR       CLEAR NEGOTIATION FLAG

 NCP      SUBR               ENTRY/EXIT
          RJM    GDS         GET DETAILED STATUS
          NJN    NCPX        IF ERRORS READING DETAILED STATUS
          LDML   LRS+/RS/P.DETAIL
          SHN    -8
          ADC    -PR.MIN
          MJN    NCP20       IF MDI PROTOCOL .LT. MINIMUM SUPPORTED
          SBN    PR.MAX-PR.MIN+1
          MJN    NCP14       IF MAXIMUM SUPPORTED .GE. MDI MAXIMUM
          LDC    PR.MAX
          UJN    NCP15       USE MAXIMUM SUPPORTED PROTOCOL

 NCP14    LDML   LRS+/RS/P.DETAIL
          SHN    -8
 NCP15    STML   PROV
          RJM    ILR         INITIALIZE LOG RESPONSE
          LDML   PROV
          ADC    PR.BASE
          RJM    IFR         SEND NEGOTIATION FUNCTION
          NJN    NCP30       IF FUNCTION TIMEOUT
          RJM    GDS         READ DETAILED STATUS
          NJN    NCP30       IF ERRORS READING DETAILED STATUS
          LDML   LRS+/RS/P.DETAIL
          SHN    -8
          SBML   PROV
          ZJK    NCP10       IF PROTOCOLS MATCH
 NCP20    LDN    ST.PPD
          STML   STCHNG      DOWN MDI
          LDK    /RS/K.LPROER
          STML   LRS+/RS/P.ERRID
          LDK    PR.MAX
          STML   LRS+/RS/P.ERRW1
          RJM    SLM         SEND LOG MESSAGE
 NCP30    UJK    NCPX        EXIT
 SAC      SPACE  4,13
**        SAC - SEND AVAILABILITY CHANGE.
*
*         THIS ROUTINE WILL SEND AN UNSOLICITED RESPONSE
*         INFORMING THE CP THAT THE NETWORK DEVICE HAS
*         CHANGED STATES AND BECOME AVAILABLE/UNAVAILABLE.
*
*         ENTRY  (AVAIL) = VALUE OF LAST AVAILABILITY
*                          RESPONSE SENT TO THE CPU.
*                (LSTATE) = STATE OF DEVICE.
*
*         EXIT   (A) = 0 IF NO ERRORS,
*                    <> 0 IF ERRORS.
*
*         CALLS  GDS, LAM, PPR, USR.


 SAC      SUBR               ENTRY/EXIT
          LDDL   LSTATE
          LMN    ST.STRT
          ZJN    SACX        IF STARTING STATE
          LMN    ST.OPER&ST.STRT
          ZJN    SAC40       IF CHANGE TO OPERATIONAL
          LMN    ST.LOAD&ST.OPER
          NJN    SAC30       IF NOT CHANGE TO LOADING
 SAC20    LDN    URC.NR      SEND LOADING STATE RESPONSE
          UJN    SAC50       SEND RESPONSE

 SAC30    LMN    ST.ILD&ST.LOAD
 SAC40    ZJK    SAC90       IF IN-LINE DIAGNOSTICS
          LDML   AVAIL
          SBN    URC.RN
          ZJN    SACX        IF SENT EXIT
          STML   SCP.RDY     DO NOT GO READY BEFORE CP REPLIES
          LDN    URC.RN      READY TO NOT READY
 SAC50    STDL   UNSC
          STML   AVAIL
          RJM    USR         SEND UNSOLICITED RESPONSE
 SAC60    RJM    PPR         PROCESS PP REQUESTS
          LDDL   STCHNG
          NJN    SAC70       IF IDLE OR DOWN
          LDML   SCP.RDY
          NJN    SAC60       IF CPU HAS NOT ACKNOWLEDGED
          LDDL   LSTATE
          LMN    ST.LOAD
          ZJN    SAC70       IF LOADING DO NOT LOG
          RJM    LAM         LOG AVAILABILITY
 SAC70    UJK    SACX        EXIT

 SAC90    LDML   AVAIL
          LMN    URC.LO
          ZJN    SAC70       IF AVAILABLE EXIT
          RJM    GDS         GET DETAILED STATUS
          NJN    SAC70
          LDN    2
          STDL   T1
 SAC100   LDML   LRS+/RS/P.SYSID,T1
          STML   RS+/RS/P.ID,T1
          SODL   T1
          PJN    SAC100      IF NOT DONE
          LDML   PROV        RETURN PROTOCOL VERSION
          STML   RS+/RS/P.PROV
          LDML   TCCH+/HD/P.MRS  RETURN MAXIMUM RECORD SIZE
          STML   RS+/RS/P.MAXRS+1
          RJM    ILR         INITIALIZE LOG RESPONSE
          LDN    /RS/C.ID*8+8
          STML   RS+/RS/P.RESPL  UPDATE RESPONSE LENGTH
          LDN    URC.LO      SEND OPERATIONAL RESPONSE
          STML   SCP.RDY
          UJK    SAC50       SEND RESPONSES
          SPACE  4,10
 OV7CH    BSS                MDI CHANNEL REFERENCES
 TCHN+40B HERE
 T40B+CHN HERE
 TCHN     HERE
          CON    0           END OF TABLE
          OVERFLOW  OVEND
          OVERLAY  (PP REQUESTS OVERLAY 1),OVEND
          ROUTINE  OV8
 GFC      SPACE  4,10
**        GFC - GLOBAL FLOW CONTROL.
*
*         THIS ROUTINE PROCESSES THE GLOBAL FLOW CONTROL COMMAND.
*
*         EXIT   (A) = 0 IF NO ERRORS,
*                    <> 0 IF ERRORS.
*
*         CALLS  IFR,PIE.


 GFC10    LDC    E50B
          RJM    PIE         SEND INTERFACE ERROR

 GFC      SUBR               ENTRY/EXIT
          LDML   CM+/CM/P.LEN
          ZJN    GFC20       IF FLOW CONTROL ON
          SBN    1
          NJN    GFC10       IF INVALID COMMAND
          LDN    F.FCOFF
          UJN    GFC30       FUNCTION FLOW CONTROL OFF

 GFC20    LDN    F.FCON
 GFC30    STML   GFCFC
          RJM    IFR         SEND FUNCTION
          LDN    0
          UJN    GFCX        EXIT
          SPACE  4,10
 OV8CH    BSS                MDI CHANNEL REFERENCES
 TCHN+40B HERE
 T40B+CHN HERE
 TCHN     HERE
          CON    0           END OF TABLE
          OVERFLOW  END
          OVERLAY  (PP REQUESTS OVERLAY 2),OVEND
          ROUTINE  OV9
**        IDP - IDLE PROCESSOR.
*
*         THIS ROUTINE PROCESSES THE IDLE COMMAND.
*
*         EXIT   (A) = 0.


 IDP      SUBR               ENTRY/EXIT
          LDML   CHLOCK
          ZJN    IDP10       IF CHANNEL NOT LOCKED
          RJM    CCK         CLEAR CHANNEL LOCK
 IDP10    LDN    ST.IDLE
          STDL   STCHNG      SET IDLE STATE
          LDN    0
          UJN    IDPX        EXIT
 NRA      SPACE  4,10
**        NRA - NOT READY ACKNOWLEDGE.
*
*         THIS ROUTINE PROCESSES THE SYNCHRONIZE
*         READY ACKNOWLEDGE.
*
*         EXIT   (A) = 0, IF NO ERRORS
*                (A) <> 0, IF ERRORS.
*
*         CALLS  PIE.


 NRA10    LDC    E50A
          RJM    PIE         RETURN INTERFACE ERROR

 NRA      SUBR               ENTRY/EXIT
          LDML   SCP.RDY
          ZJN    NRA10       IF NOT WAITING FOR THIS
          LDN    0
          STML   SCP.RDY     UPDATE SYNCHRONIZATION WORD
          UJN    NRAX        EXIT
 REP      SPACE  4,10
**        REP - RESUME PROCESSOR.
*
*         THIS ROUTINE PROCESSES THE RESUME COMMAND.
*
*         EXIT   (A) = 0.


 REP      SUBR               ENTRY/EXIT
          LDN    0
          STDL   STCHNG      CLEAR IDLE STATE
          UJN    REPX        EXIT
 RFC      SPACE  4,10
**        RFC - RESET FOR CPU.
*
*         THIS ROUTINE PROCESSES THE RESET COMMAND.
*
*         EXIT   (A) = 0.


 RFC      SUBR               ENTRY/EXIT
          LDN    ST.PPR      RESET MCI
          STDL   STCHNG
          LDN    0
          UJN    RFCX        EXIT
 SDM      SPACE  4,10
**        SDM - SET DEBUG MODE.
*
*         THIS ROUTINE PROCESSES THE SET DEBUG MODE COMMAND.
*
*         EXIT   (A) = 0 IF NO ERRORS,
*                    <> 0 IF ERRORS.
*
*         CALLS  PIE.


 SDM10    LDC    E50B
          RJM    PIE         SEND INTERFACE ERROR

 SDM      SUBR               ENTRY/EXIT
          LDML   CM+/CM/P.RMA+1
          ZJN    SDM20       IF DEBUG MODE ON
          SBN    1
          NJN    SDM10       IF INVALID COMMAND
          LDN    1
 SDM20    STML   DBUGM
          LDN    0
          UJN    SDMX        EXIT
          SPACE  4,10
 OV9CH    BSS                MDI CHANNEL REFERENCES
 TCHN+40B HERE
 T40B+CHN HERE
 TCHN     HERE
          CON    0           END OF TABLE
          OVERFLOW  END
          OVERLAY  (PP REQUESTS OVERLAY 3),OVEND
          ROUTINE  OVA
 RPM      SPACE  4,10
**        RPM - READ PP MEMORY.
*
*         THIS PP REQUEST READS PP MEMORY CHANGES.
*
*         EXIT   (A) = 0.
*
*         USES   T5.
          SPACE  2
 RPM      SUBR               ENTRY/EXIT
          LDML   RWA
          STML   RPMA        MODIFY READ INSTRUCTION
          LDML   CM+/CM/P.LEN GET LENGTH OF OVERLAY
          ADK    7
          SHN    -3          CONVERT LENGTH TO LENGTH IN CM WORDS
          STDL   T5          SAVE OVERLAY LENGTH FOR TRANSFER
          LOADF  CM+/CM/P.RMA REFORMAT CM ADDRESS
          CRML   *,T5        READ IN CHANGES.
 RPMA     EQU    *-1
          LDN    0
          UJN    RPMX        EXIT
 SPA      SPACE  4,10
**        SPA - SELECT PP MEMORY.
*
*         THIS PP REQUEST SAVES THE PP ADDRESS
*         FOR READ AND WRITE MEMORY REQUESTS.
*
*         EXIT   (A) = 0.
          SPACE  2
 SPA      SUBR               ENTRY/EXIT
          LDML   CM+/CM/P.RMA+1  GET SECOND HALF OF PP MEM ADDR
          STML   RWA         SAVE PP ADDRESS
          LDN    0
          UJN    SPAX        EXIT
 WPM      SPACE  4,10
**        WPM - WRITE PP MEMORY.
*
*         THIS PP REQUEST WRITES REQUESTED PP MEMORY
*         TO CENTRAL MEMORY.
*
*         EXIT   (A) = 0.
*
*         USES   T5, T6.
          SPACE  2
 WPM      SUBR               ENTRY/EXIT
          LDML   RWA
          STML   WPMA        MODIFY WRITE INSTRUCTION
          LDML   CM+/CM/P.LEN GET BYTE COUNT
          ADK    1
          SHN    -1          GET PP WORD COUNT
          STDL   T6          SAVE PP WORD COUNT
          LDK    7777B       GET MAX PP MEMORY ADDRESS
          SBML   WPMA        SUBTRACT STARTING PT. OF COPY
          STDL   T5          SAVE MAX LENGTH OF COPY
          SBDL   T6          SUBTRACT REQUESTED LENGTH
          MJN    WPM10       IF REQUESTED LENGTH TOO LARGE, SKIP
          LDDL   T6          RESET TRANSFER LENGTH TO REQUESTED LENGTH
          STDL   T5
 WPM10    LDDL   T5          GET PP WORD LENGTH OF TRANSFER
          ADK    3
          SHN    -2          CONVERT PP WORD COUNT TO CPU WORD COUNT
          STDL   WC          SAVE CPU WORD COUNT FOR CM WRITE
          LOADF  CM+/CM/P.RMA REFORMAT CM ADDRESS
          CWML   **,WC       COPY PP MEMORY TO CM
 WPMA     EQU    *-1
          LDN    0
          UJK    WPMX        EXIT
          IFEQ   BRK,1
 DBA      SPACE  4,12
**        DBA - DEFINE BREAKPOINT AREA.
*
*         THIS ROUTINE PROCESSES THE DEFINE BREAKPOINT AREA
*         COMMAND.  THIS COMMAND TELLS THE PP WHERE IN CM
*         THE BREAKPOINT AREA IS.
*
*         ENTRY  (CM) = CONTAINS COMMAND.
*
*         EXIT   (A) = 0, IF NO ERRORS.
*                    <> 0, IF ERRORS.
*                (BRMA-BRMA+1) = RMA OF PP BKPT AREA.
*                (BALEN) = LENGTH OF BKPT AREA IN CM WORDS.


 DBA      SUBR               ENTRY/EXIT
          LDML   CM+/CM/P.RMA
          STML   BRMA
          LDML   CM+/CM/P.RMA+1
          STML   BRMA+1      RMA OF PP BKPT AREA
          LDML   CM+/CM/P.LEN
          STML   BALEN       BKPT AREA LENGTH IN CM WORDS
          LDN    0
          STML   SBKP        START BREAKPOINTING
          UJK    DBAX        EXIT
          ENDIF
          SPACE  4,10
 OVACH    BSS                MDI CHANNEL REFERENCES
 TCHN+40B HERE
 T40B+CHN HERE
 TCHN     HERE
          CON    0           END OF TABLE
          OVERFLOW  END
          END    NETW
/EOR
*DECK DECK=NAM$MISCELLANEOUS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access: Miscellaneous Routines For Networks' ??
MODULE nam$miscellaneous;
?? NEWTITLE := 'Global Declarations Referenced by This Module' ??
?? PUSH (LISTEXT := ON) ??
*copyc jmv$executing_within_system_job
*copyc mmt$rb_idle_system
*copyc nac$namve_debug_mode
*copyc nae$namve_conditions
*copyc ost$caller_identifier
*copyc ost$status
?? POP ??
*copyc i#call_monitor
*copyc mmp$create_segment
*copyc mmp$delete_segment
*copyc osp$format_message
*copyc osp$is_caller_system_privileged
*copyc osp$recoverable_system_error
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osp$verify_system_privilege
*copyc pfp$find_cycle_array
*copyc pfp$find_direct_info_record
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_item_info
*copyc pmp$log_ascii
*copyc syp$invoke_system_debugger
*copyc mtv$halt_cpu_ring_number
*copyc nav$debug_mode
*copyc tmv$halt_on_hung_task

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$get_file_cycle_count', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$get_file_cycle_count (path: pft$path;
    VAR cycles: 0 .. pfc$maximum_cycle_number;
    VAR status: ost$status);

    VAR
      cycle_array: pft$p_cycle_array,
      directory: pft$p_directory_array,
      group: pft$group,
      info: pft$p_info,
      info_offset: pft$array_index,
      info_record: pft$p_info_record,
      info_segment_pointer: mmt$segment_pointer,
      item_record: pft$p_info_record,
      local_status: ost$status;

    status.normal := TRUE;

    IF (NOT jmv$executing_within_system_job) AND (NOT osp$is_caller_system_privileged()) THEN
      osp$set_status_abnormal('NA',nae$insufficient_privilege,
            'nap$get_file_cycle_count',status);
      RETURN;
    IFEND;

    mmp$create_segment (NIL, mmc$sequence_pointer, 1, info_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    info := info_segment_pointer.seq_pointer;
    RESET info;

    group.group_type := pfc$member;
    group.member_description.family := osc$null_name;
    group.member_description.account := osc$null_name;
    group.member_description.project := osc$null_name;
    group.member_description.user := osc$null_name;

    cycles := 0;
    pfp$get_item_info (path, group, $pft$catalog_info_selections [], $pft$file_info_selections
          [pfc$file_directory, pfc$file_description, pfc$file_cycles], info, status);
    IF status.normal THEN
      RESET info;
      pfp$find_next_info_record (info, info_record, status);
      IF status.normal THEN
        pfp$find_directory_array (info_record, directory, status);
        IF status.normal AND (directory <> NIL) THEN

          pfp$find_direct_info_record (^info_record^.body, directory^ [LOWERBOUND (directory^)].info_offset,
                item_record, status);
          IF status.normal THEN
            pfp$find_cycle_array (item_record, cycle_array, status);
            IF status.normal THEN
              IF cycle_array = NIL THEN
                cycles := 0;
              ELSE
                cycles := UPPERBOUND (cycle_array^);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    ELSEIF status.condition = pfe$unknown_permanent_file THEN
      status.normal := TRUE;
    IFEND;

    mmp$delete_segment (info_segment_pointer, 1, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;
  PROCEND nap$get_file_cycle_count;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$display_message', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$display_message (status_message: ost$status);

    VAR
      line_length: ^ost$status_message_line_size,
      line_count: ^ost$status_message_line_count,
      line_index: ost$status_message_line_count,
      log: pmt$ascii_logset,
      message: ost$status_message,
      message_sequence: ^ost$status_message,
      text: ^ost$status_message_line,
      ignore_status: ost$status;

    IF jmv$executing_within_system_job OR osp$is_caller_system_privileged() THEN
      log := $pmt$ascii_logset [pmc$job_log, pmc$system_log];
    ELSE
      log := $pmt$ascii_logset [pmc$job_log];
    IFEND;

    osp$format_message (status_message, osc$current_message_level, osc$max_status_message_line, message,
          ignore_status);

    message_sequence := ^message;
    RESET message_sequence;
    NEXT line_count IN message_sequence;

    FOR line_index := 1 TO line_count^ DO
      NEXT line_length IN message_sequence;
      NEXT text: [line_length^] IN message_sequence;
      pmp$log_ascii (text^, log, pmc$msg_origin_program, ignore_status);
    FOREND;

  PROCEND nap$display_message;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$namve_system_error', EJECT ??
*copy nah$namve_system_error

  PROCEDURE [XDCL, #GATE] nap$namve_system_error
    (    recoverable_error: boolean;
         error_message: string ( * );
         status: ^ost$status);

    VAR
      caller_id: ost$caller_identifier,
      ignore_status: ost$status,
      request_block: mmt$rb_idle_system;


    osp$verify_system_privilege;

    #caller_id (caller_id);
    IF caller_id.ring <= mtv$halt_cpu_ring_number THEN
      osp$system_error (error_message, status);
    IFEND;

    IF nav$debug_mode = nac$halt_on_error THEN
      request_block.reqcode := syc$rc_idle_system;
      request_block.idle_code := syc$ic_fatal_software_error;
      request_block.error_message (1, 8) := 'NAM/VE: ';
      request_block.error_message (9, *) := error_message;
      WHILE TRUE DO
        i#call_monitor (#LOC (request_block), #SIZE (request_block));
      WHILEND;
    ELSE

{ Call OSP$RECOVERABLE_SYSTEM_ERROR whether or not the error is recoverable. This is
{ done to lay down the call chain in the logs.

      osp$recoverable_system_error (error_message, status);

{ If SYSTEM_DEBUG_RING already caused OSP$RECOVERABLE_SYSTEM_ERROR to bring the
{ debugger up on this task do not do it again.

      IF (caller_id.ring > tmv$system_debug_ring) AND (nav$debug_mode = nac$debug_on_error) THEN
        syp$invoke_system_debugger (error_message, 0, ignore_status);
      IFEND;
      IF NOT recoverable_error THEN
        osp$system_error (error_message, status);
      IFEND;
    IFEND;

  PROCEND nap$namve_system_error;


MODEND nam$miscellaneous;
*DECK DECK=NAM$MISCELLANEOUS_236 EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'NAM/VE: Miscellaneous Routines (236) For Networks' ??
MODULE nam$miscellaneous_236;
{ PURPOSE:
{   The purpose of this module is to contain NAM/VE miscellaneous routines
{   that are gated only to ring 6.
{
?? PUSH (LISTEXT := ON) ??
?? NEWTITLE := '  Global Declarations', EJECT ??
*copyc nat$checksum
*copyc nat$network_address
*copyc nat$data_fragments
?? POP ??
?? TITLE := '  External Procedures', EJECT ??
*copyc mmp$create_segment
*copyc mmp$delete_segment
*copyc nap$system_id
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_multi_item_info
?? TITLE := '[XDCL,#GATE] NAP$GET_CATALOG_FILE_COUNT', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$get_catalog_file_count (path: pft$path;
    VAR files: 0 .. 7fffffff(16);
    VAR status: ost$status);

    VAR
      directory: pft$p_directory_array,
      group: pft$group,
      info: pft$p_info,
      info_record: pft$p_info_record,
      info_segment_pointer: mmt$segment_pointer,
      local_status: ost$status;

    status.normal := TRUE;
    mmp$create_segment (NIL, mmc$sequence_pointer, 1, info_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    info := info_segment_pointer.seq_pointer;
    RESET info;

    group.group_type := pfc$member;
    group.member_description.family := osc$null_name;
    group.member_description.account := osc$null_name;
    group.member_description.project := osc$null_name;
    group.member_description.user := osc$null_name;

    files := 0;
    pfp$get_multi_item_info (path, group, $pft$catalog_info_selections [], $pft$file_info_selections
          [pfc$file_directory], info, status);
    IF status.normal THEN
      RESET info;
      pfp$find_next_info_record (info, info_record, status);
      IF status.normal THEN
        pfp$find_directory_array (info_record, directory, status);
        IF status.normal THEN
          IF directory = NIL THEN
            files := 0;
          ELSE
            files := UPPERBOUND (directory^);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    mmp$delete_segment (info_segment_pointer, 1, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;
  PROCEND nap$get_catalog_file_count;
?? TITLE := '  [XDCL, #GATE] nap$local_system_id', EJECT ??

  FUNCTION [XDCL, #GATE] nap$local_system_id: nat$system_identifier;

      nap$local_system_id := nap$system_id ();
  FUNCEND nap$local_system_id;
?? TITLE := '  [XDCL, #GATE] nap$xns_checksum', EJECT ??

  FUNCTION [XDCL, #GATE] nap$xns_checksum (data_fragments: nat$data_fragments): nat$checksum_value;

*copyc nah$xns_checksum

    TYPE
      data_array = array [0 .. (nac$max_data_length - 3) DIV 2] of unsigned_sixteen_bit,
      odd_byte_record = record
        first_byte: unsigned_eight_bit,
        remaining_bytes: data_array,
      recend,
      unsigned_eight_bit = 0 .. 0ff(16),
      unsigned_sixteen_bit = 0 .. 0ffff(16);

    VAR
      accumulator: 0 .. 07fffffffffffffff(16),
      even_first_byte_data: ^data_array,
      fragment_index: integer,
      fragment_length: nat$data_length,
      fragment_address: ^cell,
      index: 0 .. nac$max_data_length DIV 2,
      max_index: - 1 .. nac$max_data_length DIV 2,
      mid_word: boolean,
      odd_first_byte_data: ^odd_byte_record,
      one_byte: ^unsigned_eight_bit;

    accumulator := 0;
    mid_word := FALSE;

    FOR fragment_index := 1 TO UPPERBOUND (data_fragments) DO
      fragment_address := data_fragments [fragment_index].address;
      fragment_length := data_fragments [fragment_index].length;
      IF (fragment_address <> NIL) AND (fragment_length > 0) THEN

{  Check for a fragment that starts in the middle of a 16 bit parcel.

        IF mid_word THEN
          odd_first_byte_data := fragment_address;
          accumulator := accumulator + (odd_first_byte_data^.first_byte * 2);
          accumulator := (accumulator MOD 65536) + (accumulator DIV 65536);
          fragment_length := fragment_length - 1;
          mid_word := FALSE;
          even_first_byte_data := ^odd_first_byte_data^.remaining_bytes;
        ELSE
          even_first_byte_data := fragment_address;
        IFEND;

        max_index := (fragment_length DIV 2) - 1;

{ Add in data 1 16 bit word at a time and shift around left 1 bit.

        FOR index := 0 TO max_index DO
          accumulator := (accumulator + even_first_byte_data^ [index]) * 2;
          accumulator := (accumulator MOD 65536) + (accumulator DIV 65536);
        FOREND;

{  Include the last 8 bit byte if there are an odd number of bytes.

        IF fragment_length MOD 2 = 1 THEN
          accumulator := (accumulator + ((even_first_byte_data^ [max_index + 1] DIV 256) * 256)) * 2;
          accumulator := (accumulator MOD 65536) + (accumulator DIV 65536);
          mid_word := TRUE;
        IFEND;
      IFEND;
    FOREND;

    accumulator := (accumulator MOD 65536) + (accumulator DIV 65536);

{  A value with all bits set (-0) represents "no checksum", and must be
{  converted to +0.

    IF accumulator = nac$no_checksum THEN
      nap$xns_checksum := 0;
    ELSE
      nap$xns_checksum := accumulator;
    IFEND;

  FUNCEND nap$xns_checksum;
MODEND nam$miscellaneous_236;

*DECK DECK=NAM$NAMVE_STATIC_DATA EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'SESSION_LAYER: Static Data - oss$network_paged' ??
MODULE nam$namve_static_data;

?? PUSH (LISTEXT := ON) ??
?? NEWTITLE := '  Global Declarations', EJECT ??

*copyc nat$data_fragments
*copyc oss$network_paged

?? POP ??
?? TITLE := '  NAM/VE Global Variables', EJECT ??

  VAR

    nav$null_data_fragments: [XDCL, #GATE, oss$network_paged] array [1 .. 1] of nat$data_fragment := [[NIL,
      0]],
    nav$unique_value: [XDCL, #GATE, oss$network_paged] integer := 0;

MODEND nam$namve_static_data;
*DECK DECK=NAM$NETWORK_ALARM_PROCESSOR EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Network Alarm Processor' ??
?? NEWTITLE := 'Global Declarations' ??
MODULE nam$network_alarm_processor;
?? PUSH (LISTEXT := ON) ??
*copyc nae$manage_network_applications
*copyc nae$namve_conditions
*copyc nat$bcd_time
*copyc nat$command_interface
*copyc nat$community_title
*copyc nat$data_fragments
*copyc nat$directory_interfaces
*copyc nat$gt_event
*copyc nat$network_address
*copyc nat$network_message_priority
*copyc nat$title
*copyc nat$system_title
*copyc nat$wait_time
*copyc nlt$protocol
*copyc ost$i_wait
*copyc ost$status
?? POP ??
*copyc avp$get_capability
*copyc i#move
*copyc nap$gt_accept_connection
*copyc nap$gt_close_sap
*copyc nap$gt_disconnect
*copyc nap$gt_open_sap
*copyc nap$gt_receive_connect_event
*copyc nap$gt_receive_connection_event
*copyc nlp$delete_registered_title
*copyc nlp$register_title
*copyc osp$i_await_activity_completion
*copyc osp$set_status_abnormal
*copyc pmp$get_microsecond_clock
*copyc pmp$log

{ Alarm data unit consists of a fixed header, followed by a variable length list of community
{ titles and a variable number of text fields.

  TYPE
    nat$alarm_header = record
      header_length: 0 .. 0ff(16),
      version: 0 .. 0ff(16),
      time_stamp: nat$bcd_time,
      system_address: nat$system_address,
      message_number: 0 .. 0ffff(16),
      system: nat$system_title,
      community_count: 0 .. 0ff(16),
      {communities: array [1 .. community_count] of nat$alarm_community_entry,
    recend;

  TYPE
    nat$alarm_community_entry = record
      code: 0 .. 0ff(16),
      length: 0 .. 0ff(16),
      community: nat$community_title,
    recend;

  CONST
    timer_index = 1, {index for timer entry in wait list}
    sap_index = 2, {index for connect request in wait list}
    index_bias = 2, {bias between indices for wait list and connection list}
    nac$alarm_title_prefix = '$I_ALARM_ME_',
    nac$alarm_title_prefix_size = 12,
    nac$alarm_version_number = 1,
    nac$max_alarm_systems = 200;

  TYPE
    alarm_connection = record
      activity_status: ost$activity_status,
      connection_id: nat$gt_connection_id,
      event: nat$gt_event,
      alarm: SEQ (REP 512 OF cell), {scratch space for communities and small messages}
      state: (connected, disconnected),
    recend;

  VAR
    alarm_communities: ^array [1 .. *] of string (nac$alarm_title_prefix_size + nac$community_title_length),
    alarm_protocol: ^0 .. 255,
    alarms_active: boolean := FALSE,
    connect_data: array [1 .. 1] of nat$data_fragment := [[^connect_info, #SIZE (connect_info)]],
    connect_event: nat$gt_connect_event,
    connect_info: SEQ (REP 32 OF cell),
    connect_status: ost$activity_status,
    connection_list: array [1 .. nac$max_alarm_systems] of ^alarm_connection := [REP nac$max_alarm_systems OF
          NIL],
    directory_identifiers: ^array [1 .. *] of nat$directory_entry_identifier := NIL,
    max_connection_index: 0 .. nac$max_alarm_systems,
    nil_data: [STATIC] array [1 .. 1] of nat$data_fragment := [[NIL, 0]],
    password: nat$directory_password := 0,
    transport_sap_id: nat$gt_sap_identifier,
    wait_list: ^ost$i_wait_list,
    wait_pointer: ^SEQ (REP nac$max_alarm_systems + index_bias of ost$i_activity) := ^wait_sequence,
    wait_sequence: SEQ (REP nac$max_alarm_systems + index_bias of ost$i_activity);

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$activate_network_alarms', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$activate_network_alarms (communities: array [1 .. *] of nat$community_title;
    VAR status: ost$status);

{ PURPOSE: This procedure establishes an Independent Alarm Management Entity.
{ DESIGN:  A Generic Transport SAP is opened and the requested alarm group titles are
{          registered. Alarm messages may then be obtained by calling the nap$receive_network_alarm
{          interface. Alarm processing is terminated by a call to the nap$deactivate_network_alarm
{          interface.

    VAR
      address: nat$internet_address,
      ignore_status: ost$status,
      index: integer,
      network_operation: boolean,
      osi_address: nat$osi_registration_address,
      title_domain: [STATIC] nat$title_domain := [nac$catenet_domain],
      user_identifier: ost$name;

    status.normal := TRUE;
    IF NOT alarms_active THEN
      avp$get_capability (avc$network_operation, avc$user, network_operation, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT network_operation THEN
        osp$set_status_abnormal (nac$status_id, nae$invalid_user, 'NETWORK OPERATOR UTILITY', status);
        RETURN;
      IFEND;
      nap$gt_open_sap (nac$max_alarm_systems, nac$system_message_priority, {reserved_sap=} FALSE,
            transport_sap_id, address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      nap$gt_receive_connect_event (transport_sap_id, connect_data, osc$nowait, connect_event,
            connect_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET wait_pointer;
      NEXT wait_list: [1 .. index_bias] IN wait_pointer;
      wait_list^ [sap_index].activity := nac$i_await_activity_status;
      wait_list^ [sap_index].activity_status := ^connect_status;
      wait_list^ [timer_index].activity := osc$i_await_time;
      max_connection_index := 0;

      alarms_active := TRUE;
      osi_address.kind := nac$osi_transport_address;
      osi_address.transport_selector := transport_sap_id.osi_sap_identifier;

      ALLOCATE directory_identifiers: [1 .. UPPERBOUND (communities)];
      ALLOCATE alarm_communities: [1 .. UPPERBOUND (communities)];
      user_identifier := nac$alarm_title_prefix;
      FOR index := LOWERBOUND (communities) TO UPPERBOUND (communities) DO
        alarm_communities^ [index] := nac$alarm_title_prefix;
        alarm_communities^ [index] (nac$alarm_title_prefix_size + 1, *) := communities [index];
        nlp$register_title (alarm_communities^ [index], osi_address, nac$cdna_transport,
              {user data} NIL, 0, nac$max_directory_priority, title_domain, {distribute} TRUE,
              nac$cdna_internal, password, user_identifier, directory_identifiers^ [index], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;

  PROCEND nap$activate_network_alarms;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$deactivate_network_alarms', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$deactivate_network_alarms (VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      index: integer;

{ PURPOSE: Terminate Alarm Management.
{ DESIGN:  The Alarm Management titles are deleted and the associated Transport SAP
{          is closed.

    status.normal := TRUE;
    IF alarms_active THEN
      FOR index := LOWERBOUND (connection_list) TO UPPERBOUND (connection_list) DO
        IF (connection_list [index] <> NIL) AND (connection_list [index]^.state = connected) THEN
          nap$gt_disconnect (connection_list [index]^.connection_id, nil_data, ignore_status);
          FREE connection_list [index];
        IFEND;
      FOREND;
      nap$gt_close_sap (transport_sap_id, status);
      IF directory_identifiers <> NIL THEN
        FOR index := LOWERBOUND (directory_identifiers^) TO UPPERBOUND (directory_identifiers^) DO
          nlp$delete_registered_title (alarm_communities^ [index], password, directory_identifiers^ [index],
                ignore_status);
        FOREND;
        FREE directory_identifiers;
        FREE alarm_communities;
      IFEND;
      alarms_active := FALSE;
    IFEND;

  PROCEND nap$deactivate_network_alarms;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$receive_network_alarm', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$receive_network_alarm (wait_time: nat$wait_time;
        alarm_message: nat$data_fragment;
    VAR message_length: nat$data_length;
    VAR system: nat$system_title;
    VAR alarm_code: nat$command_response_code;
    VAR time_stamp: nat$bcd_time;
    VAR status: ost$status);

{ PURPOSE: This procedure delivers a single network alarm message.
{ DESIGN:  The alarm protocol header information is interpreted and returned as parameter
{          values.

    VAR
      alarm_data: ^SEQ ( * ),
      alarm_header: ^nat$alarm_header,
      alarm_received: boolean,
      alarm_text: ^SEQ ( * ),
      community_list: ^array [1 .. * ] of nat$alarm_community_entry,
      connection: ^alarm_connection,
      current_time: integer,
      end_time: integer,
      ignore_status: ost$status,
      index: integer,
      remaining_length: nat$data_length,
      remaining_time: integer,
      response_buffer: array [1 .. 1] of nat$data_fragment;

    status.normal := TRUE;

    pmp$get_microsecond_clock (current_time, ignore_status);
    end_time := (current_time DIV 1000) + wait_time;
    alarm_received := FALSE;

    REPEAT
      pmp$get_microsecond_clock (current_time, ignore_status);
      remaining_time := end_time - (current_time DIV 1000);
      IF remaining_time > 0 THEN
        wait_list^ [timer_index].milliseconds := remaining_time;
      ELSE
        wait_list^ [timer_index].milliseconds := 1;
      IFEND;
      osp$i_await_activity_completion (wait_list^, index, status);
      IF status.normal THEN
        IF index = sap_index THEN
          connect_system (connect_event.connection, connection);
          nap$gt_receive_connect_event (transport_sap_id, connect_data, osc$nowait, connect_event,
                connect_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          nap$gt_accept_connection (connection^.connection_id, nil_data, NIL, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          response_buffer [1].address := ^connection^.alarm;
          response_buffer [1].length := #SIZE (connection^.alarm);
          nap$gt_receive_connection_event (connection^.connection_id, response_buffer, osc$nowait,
                connection^.event, connection^.activity_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSEIF index = timer_index THEN
          osp$set_status_abnormal (nac$status_id, nae$no_event, '', status);
        ELSEIF NOT connection_list [index - index_bias]^.activity_status.status.normal THEN
          status := connection_list [index - index_bias]^.activity_status.status;
        ELSE
          connection := connection_list [index - index_bias];
          CASE connection^.event.kind OF
          = nac$gt_data_event =
            alarm_data := ^connection^.alarm;
            NEXT alarm_header IN alarm_data;
            alarm_received := TRUE;
            system := alarm_header^.system;
            alarm_code := alarm_header^.message_number;
            time_stamp := alarm_header^.time_stamp;
            message_length := connection^.event.data.data_length - #SIZE(nat$alarm_header) - (alarm_header^.
                  community_count * #SIZE (nat$alarm_community_entry));
            IF message_length > 0 THEN {move first part of message to user's buffer}
              NEXT community_list: [1 .. alarm_header^.community_count] IN alarm_data;
              NEXT alarm_text: [[REP message_length OF cell]] IN alarm_data;
              i#move (alarm_text, alarm_message.address, message_length);
            ELSE
              message_length := 0;
            IFEND;
            IF NOT connection^.event.data.end_of_message THEN {get rest of message}
              response_buffer [1].address := #address (#ring (alarm_message.address), #segment
                    (alarm_message.address), #offset (alarm_message.address) + message_length);
              response_buffer [1].length := alarm_message.length - message_length;
              nap$gt_receive_connection_event (connection^.connection_id, response_buffer, osc$wait,
                    connection^.event, connection^.activity_status, status);
              IF status.normal AND (connection^.event.kind = nac$gt_data_event) THEN
                message_length := message_length + connection^.event.data.data_length;
              IFEND;
            IFEND;
            IF status.normal THEN
              response_buffer [1].address := ^connection^.alarm;
              response_buffer [1].length := #SIZE (connection^.alarm);
              nap$gt_receive_connection_event (connection^.connection_id, response_buffer, osc$nowait,
                    connection^.event, connection^.activity_status, status);
            IFEND;
            IF NOT status.normal THEN
              connection^.state := disconnected;
              wait_list^ [index].activity := osc$i_null_activity;
            IFEND;

          = nac$gt_disconnect_event =
            connection^.state := disconnected;
            wait_list^ [index].activity := osc$i_null_activity;

          ELSE
            pmp$log ('unexpected transport event type', ignore_status);
          CASEND;
        IFEND;
      IFEND;

    UNTIL alarm_received OR NOT status.normal;
  PROCEND nap$receive_network_alarm;

?? OLDTITLE ??
?? NEWTITLE := 'connect_system', EJECT ??

  PROCEDURE connect_system (connection_id: nat$gt_connection_id;
    VAR connection: ^alarm_connection);

    VAR
      ignore_status: ost$status,
      connection_index: integer,
      wait_index: integer;

  /search_for_entry/
    BEGIN
      FOR connection_index := 1 TO max_connection_index DO
        IF connection_list [connection_index]^.state = disconnected THEN
          connection_list [connection_index]^.state := connected;
          connection_list [connection_index]^.connection_id := connection_id;
          connection := connection_list [connection_index];
          wait_index := connection_index + index_bias;
          wait_list^ [wait_index].activity := nac$i_await_activity_status;
          wait_list^ [wait_index].activity_status := ^connection_list [connection_index]^.activity_status;
          EXIT /search_for_entry/;
        IFEND;
      FOREND;

      IF max_connection_index < UPPERVALUE (max_connection_index) THEN
        max_connection_index := max_connection_index + 1;
        ALLOCATE connection_list [max_connection_index];
        connection_list [max_connection_index]^.state := connected;
        connection_list [max_connection_index]^.connection_id := connection_id;
        connection := connection_list [max_connection_index];
        wait_index := max_connection_index + index_bias;
        RESET wait_pointer;
        NEXT wait_list: [1 .. wait_index] IN wait_pointer;
        wait_list^ [wait_index].activity := nac$i_await_activity_status;
        wait_list^ [wait_index].activity_status := ^connection_list [max_connection_index]^.activity_status;
        EXIT /search_for_entry/;
      IFEND;
      nap$gt_disconnect (connection_id, nil_data, ignore_status);
      RETURN;
    END /search_for_entry/;

  PROCEND connect_system;
?? OLDTITLE ??
MODEND nam$network_alarm_processor;
*DECK DECK=NAM$NETWORK_CONFIGURATION EXPAND=TRUE
?? RIGHT := 110 ??
MODULE nam$network_configuration;
*copyc cmc$display_element_constants
*copyc clt$display_control
*copyc jmv$executing_within_system_job
*copyc nac$null_connection_id
*copyc nat$display_option
*copyc nat$network_descriptor
*copyc nae$namve_conditions
*copyc nae$network_configuration
*copyc nlt$device_count
*copyc nlt$network_device
*copyc nlt$network_device_list
*copyc osd$unique_name
*copyc ost$name
*copyc pfd$permanent_file_definitions
*copyc pmt$processor_attributes
?? TITLE := 'XREFd PROCEDURES', EJECT ??
*copyc amp$return
*copyc clp$convert_integer_to_string
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$put_partial_display
*copyc clp$scan_command_file
*copyc cmp$clean_up_network_list
*copyc cmp$define_channel_network
*copyc cmp$define_host_network
*copyc cmp$define_network_access
*copyc cmp$define_network_connection
*copyc cmp$define_tcpip_host
*copyc cmp$validate_network_config
*copyc nap$system_id
*copyc nap$record_system_id
*copyc nlp$tm_define_tcpip_host
*copyc pfp$attach
*copyc pmp$generate_unique_name
*copyc pmp$get_pseudo_mainframe_id
*copyc osp$is_caller_system_privileged
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
?? TITLE := 'Global Variables', EJECT ??
*copyc cmv$network_descriptor_p
*copyc nav$host_subnet_id
*copyc nav$network_paged_heap
*copyc nlv$configured_network_devices
*copyc nlv$sm_devices
*copyc nlv$tm_host
*copyc nlv$tm_route_cache
*copyc oss$job_paged_literal
?? TITLE := '  [INLINE] set_system_id', EJECT ??

  PROCEDURE [INLINE] set_system_id;

{
{     The purpose of this request is to establish this  system's  CDCNET  system
{  identifier for subsequent retrieval via the NAP$SYSTEM_ID function.
{

    VAR
      mainframe_id: pmt$binary_mainframe_id,
      i: 0 .. 3,
      m: integer,
      serial_number: ^packed array [0 .. 3] of 0 .. 0f(16),
      system_identifier: ^nat$system_identifier,
      system_id: packed record
        prefix: 0 .. 0ffffff(16),
        system_type: 0 .. 3,
        cpu_0_model_number: 0 .. 0ff(16),
        cpu_0_serial_number: 0 .. 3fff(16),
      recend;

    system_id.prefix := 080025(16); {the XEROX-reserved prefix}
    system_id.system_type := 3; {NOS/VE system type}
    pmp$get_pseudo_mainframe_id (mainframe_id);
    system_id.cpu_0_model_number := mainframe_id.model_number;

{  The following code is dependent on mainframe.serial_number being in BCD format.  }

    serial_number := #LOC (mainframe_id.serial_number);
    system_id.cpu_0_serial_number := 0;
    m := 1;
    FOR i := UPPERVALUE (i) DOWNTO LOWERVALUE (i) DO
      system_id.cpu_0_serial_number :=
            system_id.cpu_0_serial_number + (serial_number^ [i] * m);
      m := m * 10;
    FOREND;
    system_identifier := #LOC (system_id);
    nap$record_system_id (system_identifier^);
  PROCEND set_system_id;

?? TITLE := 'NAP$ACTIVATE_NETWORK_CONFIG', EJECT ??
  PROCEDURE [XDCL] nap$activate_network_config
    (VAR status: ost$status);

{ The purpose of this procedure is to process the file containing the commands
{ to define networks. These commands define the networks connected directly to
{ the host mainframe.

{ WARNING:  Make sure that when this table is regenerated that it is placed in
{           the section oss$job_paged_literal.


{ table inc_command_table t=c s=local
{ command (define_host_network            ,defhn) cmp$define_host_network
{ command (define_network_connection      ,defnc) cmp$define_network_connection
{ command (define_tcpip_host              ,defth) cmp$define_tcpip_host
{ tablend
?? PUSH (LISTEXT := ON) ??

VAR
  inc_command_table: [STATIC, READ] ^clt$command_table :=
      ^inc_command_table_entries,

  inc_command_table_entries: [STATIC, READ] array [1 .. 6] of
      clt$command_table_entry := [
  {} ['DEFHN                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^cmp$define_host_network],
  {} ['DEFINE_HOST_NETWORK            ', clc$nominal_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^cmp$define_host_network],
  {} ['DEFINE_NETWORK_CONNECTION      ', clc$nominal_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^cmp$define_network_connection],
  {} ['DEFINE_TCPIP_HOST              ', clc$nominal_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^cmp$define_tcpip_host],
  {} ['DEFNC                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^cmp$define_network_connection],
  {} ['DEFTH                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^cmp$define_tcpip_host]];

?? POP ??

  VAR
    activate_network_utility: [STATIC, READ, OSS$JOB_PAGED_LITERAL] ost$name :=
      'ACTIVATE_NETWORK_CONFIGURATION',
    configuration_file_path: [STATIC, READ, OSS$JOB_PAGED_LITERAL]  array [1 .. 4] of pft$name :=
      ['$SYSTEM', '$SYSTEM', 'NETWORK', 'CONFIGURATION'],
    default_password: [STATIC, READ, OSS$JOB_PAGED_LITERAL] pft$password := '',
    highest_cycle: [STATIC, READ, OSS$JOB_PAGED_LITERAL] pft$cycle_selector := [pfc$highest_cycle],
    ignore_status: ost$status,
    share_selections: [STATIC, READ, OSS$JOB_PAGED_LITERAL] pft$share_selections := [],
    unique_name: ost$unique_name,
    usage_selections: [STATIC, READ, OSS$JOB_PAGED_LITERAL] pft$usage_selections := [pfc$read, pfc$execute];


{   Attach the $system.network.configuration file.

  pmp$generate_unique_name (unique_name, ignore_status);
  pfp$attach (unique_name.value, configuration_file_path, highest_cycle, default_password, usage_selections,
        share_selections, pfc$no_wait, status);
  IF NOT status.normal THEN
    RETURN;
  IFEND;

/activate_network_config/
  BEGIN

    clp$push_utility (activate_network_utility, clc$exclusive_command_search, inc_command_table, NIL, status);
    IF NOT status.normal THEN
      EXIT /activate_network_config/;
    IFEND;

    clp$scan_command_file (unique_name.value, activate_network_utility, '', status);
    IF NOT status.normal THEN
      EXIT /activate_network_config/;
    IFEND;

    clp$pop_utility (status);
    IF NOT status.normal THEN
      EXIT /activate_network_config/;
    IFEND;

    cmp$validate_network_config (cmv$network_descriptor_p, status);
    IF NOT status.normal THEN
      EXIT /activate_network_config/;
    IFEND;

    define_network_configuration (cmv$network_descriptor_p, status);

  END /activate_network_config/;

  cmp$clean_up_network_list (ignore_status);
  amp$return (unique_name.value, ignore_status);

PROCEND nap$activate_network_config;
?? TITLE := '   nap$display_network_config', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$display_network_config
    (    display_option: nat$display_option;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

{ The purpose of this procedure is to display the attributes of all the
{ directly connected networks.

    VAR
      field_column_number: integer,
      i: integer,
      int: integer,
      int_string: ost$string,
      network_device_list: ^nlt$network_device_list;

    status.normal := TRUE;

    IF (NOT jmv$executing_within_system_job) AND (NOT osp$is_caller_system_privileged()) THEN
      osp$set_status_abnormal('NA',nae$insufficient_privilege,
            'nap$display_network_config',status);
      RETURN;
    IFEND;

    IF nlv$configured_network_devices.network_device_list = NIL THEN
      osp$set_status_condition (nae$networks_not_activated, status);
      RETURN;
    IFEND;

    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, cmc$starting_subheader_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, cmc$msg_host_network, clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    int := nav$host_subnet_id;
    clp$convert_integer_to_string (int, 10, TRUE, int_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, int_string.value, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    network_device_list := nlv$configured_network_devices.network_device_list;

    FOR i := LOWERBOUND (network_device_list^) TO UPPERBOUND (network_device_list^) DO
      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$horizontal_tab_display (display_control, cmc$starting_subheader_column, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, cmc$msg_connected_system, clc$no_trim, amc$continue,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, network_device_list^ [i].element, clc$trim, amc$terminate,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF network_device_list^ [i].kind = nac$ica_2 THEN
        clp$horizontal_tab_display (display_control, cmc$starting_subheader_column, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_partial_display (display_control, cmc$msg_system_identifier, clc$no_trim, amc$continue,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        int := network_device_list^ [i].system_id;
        clp$convert_integer_to_string (int, 16, TRUE, int_string, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_partial_display (display_control, int_string.value, clc$trim, amc$terminate, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    IF nlv$tm_host.name_length > 0 THEN
      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$horizontal_tab_display (display_control, cmc$starting_subheader_column, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, cmc$msg_tcpip_host_name, clc$no_trim, amc$continue,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, nlv$tm_host.name (1, nlv$tm_host.name_length),
            clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$horizontal_tab_display (display_control, cmc$starting_subheader_column, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, cmc$msg_forward_search_range, clc$no_trim, amc$continue,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      int := nlv$tm_route_cache.forward_search_range;
      clp$convert_integer_to_string (int, 10, TRUE, int_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, int_string.value, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND nap$display_network_config;
?? TITLE := '  define_network_configuration', EJECT ??

  PROCEDURE define_network_configuration (network_descriptor_list: ^nat$network_descriptor;
    VAR status: ost$status);

{   This procedure creates the network device list. The network device list
{  contains entries containing the attributes of the configured network devices,
{  and the host subnet identifier.

    VAR
      i: integer,
      network_descriptor: ^nat$network_descriptor,
      network_device_count: nlt$device_count,
      network_device_list: ^nlt$network_device_list,
      system_management_list: ^nlt$sm_device_list;

    status.normal := TRUE;
    IF nlv$configured_network_devices.network_device_list <> NIL THEN
      osp$set_status_condition (nae$networks_already_configured, status);
      RETURN;
    IFEND;

    IF network_descriptor_list = NIL THEN
      osp$set_status_condition (nae$empty_network_desc_list, status);
      RETURN;
    IFEND;

{ Count the number of network devices being configured.
    network_descriptor := network_descriptor_list;
    network_device_count := 0;
    REPEAT
      IF network_descriptor^.kind = nac$network_device THEN
        network_device_count := network_device_count + 1;
      IFEND;
      network_descriptor := network_descriptor^.next_descriptor;
    UNTIL network_descriptor = NIL;
    network_descriptor := network_descriptor_list;

{ Establish the CDCNET system identifier for this system.

    set_system_id;
    ALLOCATE network_device_list: [1 .. network_device_count] IN nav$network_paged_heap^;
    nlv$configured_network_devices.network_device_list := network_device_list;
    ALLOCATE system_management_list: [1 .. network_device_count] IN nav$network_paged_heap^;
    nlv$sm_devices.list := system_management_list;
    nlv$configured_network_devices.network_device_count := network_device_count;
    i := 1;
    REPEAT
      CASE network_descriptor^.kind OF
      = nac$network_device =

{ Define network device attributes.
      network_device_list^[i].device_id := i;
      network_device_list^[i].logical_unit := 0;
      network_device_list^[i].path_status := nlc$path_unavailable;
      network_device_list^[i].channel := network_descriptor^.access.channel;
      network_device_list^[i].channel_address := network_descriptor^.access.channel_address;
      network_device_list^[i].element := network_descriptor^.access.element;
      network_device_list^[i].driver_name := network_descriptor^.driver_name;
      network_device_list^[i].state := nlc$normal;
      network_device_list^[i].last_usage_data.bytes_transmitted := 0;
      network_device_list^[i].last_usage_data.bytes_received := 0;
      network_device_list^[i].reset_down_count_intervl := 0;
      network_device_list^[i].reset_down_count := 0;
      network_device_list^[i].reset_timestamp := 0;
      network_device_list^[i].task_waiting_for_state_change.index := 0;
      network_device_list^[i].maximum_pdu_size := 0;
      network_device_list^[i].kind := network_descriptor^.device_type;
      network_device_list^[i].system_id := network_descriptor^.system_identifier;

{ Define System Management attributes.
      system_management_list^[i].device_id := i;
      system_management_list^[i].state := nlc$sm_uninitialized;
      system_management_list^[i].connection_id := nac$null_connection_id;
      system_management_list^[i].network_address_length := 0;
      system_management_list^[i].network_address_prefix := NIL;
      system_management_list^[i].active_connection_count := 0;
      system_management_list^[i].subnet_list := NIL;
      system_management_list^[i].new_subnet_list := NIL;

      i := i + 1;

    = nac$host_subnet =
      nav$host_subnet_id := network_descriptor^.network;
    = nac$define_tcpip_host =
      nlp$tm_define_tcpip_host (network_descriptor^.tcpip.host_name^, network_descriptor^.
            tcpip.forward_search_range);
    ELSE
    CASEND;

      network_descriptor := network_descriptor^.next_descriptor;
    UNTIL network_descriptor = NIL;

  PROCEND define_network_configuration;
MODEND nam$network_configuration;

*DECK DECK=NAM$NETWORK_EXTERNAL_INTERFACE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access : Network Application Layer' ??
MODULE nam$network_external_interface;

{ PURPOSE:
{   The purpose of this module is to contain all NAM/VE external interfaces to the Network
{   Access Agent and the Internet Protocol Layer.
{   The module contains request interfaces and the "event processor" interface
{   which sends/receives network events to/from both the Internet Protocol Layer and the
{   Network Access Agent.
{
{ DESIGN:
{   This module is designed to be contained on the OSF$JOB_TEMPLATE_23D library and may execute
{   in any task.  These interfaces are not gated and are meant to be called by internal NAM/VE
{   code.
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nac$xi_maximum_data_length
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nat$data_fragments
*copyc nat$internet_address
*copyc nat$network_layer_address
*copyc nat$network_message_priority
*copyc nat$network_sap_identifier
*copyc nat$open_network_sap_descriptor
*copyc nat$osi_network_address
*copyc nat$user_interface
*copyc nlt$bm_message_id
*copyc oss$job_paged_literal
?? POP ??
*copyc nlp$al_get_data_length
*copyc nlp$bm_flush_message
*copyc nlp$bm_release_message
*copyc nlp$na_close_sap
*copyc nlp$na_open_sap
*copyc nlp$na_send_data
*copyc osp$append_status_integer
*copyc osp$clear_job_signature_lock
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_microsecond_clock
*copyc pmp$ready_task
*copyc pmp$wait
*copyc syp$cycle
*copyc nav$network_paged_heap
*copyc nav$open_network_sap_list
*copyc nav$open_network_sap_list_lock
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    nac$network_queue_limit = 100;

  VAR
    network: [READ, oss$job_paged_literal] string (26) := 'Network External Interface';

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$close_network_sap', EJECT ??
*copy nah$close_network_sap

  PROCEDURE [XDCL] nap$close_network_sap
    (    sap: nat$network_sap_identifier;
     VAR status: ost$status);

    VAR
      closed_sap_descriptor: ^nat$open_network_sap_descriptor,
      event: ^nat$network_event,
      next_event: ^nat$network_event,
      sap_descriptor: ^^nat$open_network_sap_descriptor;

    status.normal := TRUE;

{ Find the open sap descriptor.

    osp$set_job_signature_lock (nav$open_network_sap_list_lock);
    sap_descriptor := ^nav$open_network_sap_list;
    WHILE (sap_descriptor^ <> NIL) AND (sap_descriptor^^.sap <> sap) DO
      sap_descriptor := ^sap_descriptor^^.link;
    WHILEND;
    IF sap_descriptor^ <> NIL THEN

{ Delink the open sap descriptor.

      closed_sap_descriptor := sap_descriptor^;
      sap_descriptor^ := closed_sap_descriptor^.link;
      osp$clear_job_signature_lock (nav$open_network_sap_list_lock);
      event := closed_sap_descriptor^.event_queue;
      FREE closed_sap_descriptor IN nav$network_paged_heap^;

{ Free any undelivered queued messages.

      WHILE event <> NIL DO
        next_event := event^.link;
        nlp$bm_release_message (event^.message_id);
        FREE event IN nav$network_paged_heap^;
        event := next_event;
      WHILEND;
      nlp$na_close_sap (sap, status);
    ELSE { Sap not open
      osp$clear_job_signature_lock (nav$open_network_sap_list_lock);
      osp$set_status_abnormal (nac$status_id, nae$sap_not_open, network, status);
      osp$append_status_integer (osc$status_parameter_delimiter, sap, 10, TRUE, status);
    IFEND;

  PROCEND nap$close_network_sap;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$deliver_network_event', EJECT ??
*copy nah$deliver_network_event

  PROCEDURE [XDCL] nap$deliver_network_event
    (    sap: nat$network_selector;
         source_address: nat$osi_network_address;
         device_id: nlt$device_identifier;
         data: nlt$bm_message_id);

    VAR
      event: ^^nat$network_event,
      ignore_status: ost$status,
      message_id: nlt$bm_message_id,
      new_event: ^nat$network_event,
      network_address: ^nat$osi_network_address,
      network_address_seq: ^SEQ ( * ),
      sap_descriptor: ^nat$open_network_sap_descriptor;

    REPEAT
      ALLOCATE new_event IN nav$network_paged_heap^;
      IF new_event = NIL THEN
        syp$cycle;
      IFEND;
    UNTIL new_event <> NIL;
    new_event^.link := NIL;
    new_event^.source.kind := nac$osi_network_address;
    new_event^.source.device_id := device_id;
    new_event^.source.network_address_length := #SIZE (source_address);
    network_address_seq := ^new_event^.source.network_address;
    RESET network_address_seq;
    NEXT network_address: [[REP #SIZE (source_address) OF cell]] IN network_address_seq;
    network_address^ := source_address;
    new_event^.message_id := data;
    osp$set_job_signature_lock (nav$open_network_sap_list_lock);
    find_sap_descriptor (sap, sap_descriptor);
    IF (sap_descriptor <> NIL) AND (sap_descriptor^.queued_messages < nac$network_queue_limit) THEN
      event := ^sap_descriptor^.event_queue;
      WHILE event^ <> NIL DO
        event := ^event^^.link;
      WHILEND;
      event^ := new_event;
      sap_descriptor^.queued_messages := sap_descriptor^.queued_messages + 1;
      IF sap_descriptor^.waiting_task_specified THEN

{ Ready the waiting task - called for performance only.

        pmp$ready_task (sap_descriptor^.waiting_task_id, ignore_status);
        sap_descriptor^.waiting_task_specified := FALSE;
      IFEND;
    ELSE { Unknown sap or max queue limit reached, release the data
      FREE new_event IN nav$network_paged_heap^;
      message_id := data;
      nlp$bm_release_message (message_id);
    IFEND;
    osp$clear_job_signature_lock (nav$open_network_sap_list_lock);

  PROCEND nap$deliver_network_event;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$open_network_sap', EJECT ??
*copy nah$open_network_sap

  PROCEDURE [XDCL] nap$open_network_sap
    (    sap_priority: nat$network_message_priority;
         sap: nat$network_sap_identifier;
     VAR status: ost$status);

    VAR
      sap_descriptor: ^nat$open_network_sap_descriptor;

    status.normal := TRUE;

{ Verify that the sap is not already open.

    osp$set_job_signature_lock (nav$open_network_sap_list_lock);
    find_sap_descriptor (sap, sap_descriptor);
    osp$clear_job_signature_lock (nav$open_network_sap_list_lock);
    IF sap_descriptor = NIL THEN
      ALLOCATE sap_descriptor IN nav$network_paged_heap^;
      IF sap_descriptor <> NIL THEN
        sap_descriptor^.waiting_task_specified := FALSE;
        sap_descriptor^.queued_messages := 0;
        sap_descriptor^.event_queue := NIL;
          nlp$na_open_sap (sap_priority, nac$deliver_network_event, sap, status);
          IF status.normal THEN
            sap_descriptor^.sap := sap;
            osp$set_job_signature_lock (nav$open_network_sap_list_lock);
            sap_descriptor^.link := nav$open_network_sap_list;
            nav$open_network_sap_list := sap_descriptor;
            osp$clear_job_signature_lock (nav$open_network_sap_list_lock);
          ELSE
            FREE sap_descriptor IN nav$network_paged_heap^;
          IFEND;
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$allocation_failed, network, status);
      IFEND;
    ELSE { Sap already open
      osp$set_status_abnormal (nac$status_id, nae$sap_already_open, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, sap, 10, TRUE, status);
    IFEND;

  PROCEND nap$open_network_sap;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$receive_network_data', EJECT ??
*copy nah$receive_network_data

  PROCEDURE [XDCL] nap$receive_network_data
    (    sap: nat$network_sap_identifier;
         data_area: nat$data_fragments;
         wait_time: 0 .. 0ffffffff(16);
     VAR source: nat$network_layer_address;
     VAR received_data_length: integer;
     VAR status: ost$status);

    VAR
      event: ^nat$network_event,
      sap_descriptor: ^nat$open_network_sap_descriptor,
      task_id: ost$global_task_id,
      wait_timer: 0 .. 0ffffffff(16);

    status.normal := TRUE;
    wait_timer := wait_time;

  /check_for_datagram/
    REPEAT
      osp$set_job_signature_lock (nav$open_network_sap_list_lock);
      find_sap_descriptor (sap, sap_descriptor);
      IF sap_descriptor <> NIL THEN
        IF sap_descriptor^.event_queue <> NIL THEN
          event := sap_descriptor^.event_queue;
          sap_descriptor^.event_queue := event^.link;
          sap_descriptor^.queued_messages := sap_descriptor^.queued_messages - 1;
          osp$clear_job_signature_lock (nav$open_network_sap_list_lock);
          source := event^.source;
          nlp$bm_flush_message (data_area, event^.message_id, received_data_length, status);
          FREE event IN nav$network_paged_heap^;
          EXIT /check_for_datagram/
        ELSE
          IF wait_timer > 0 THEN
            IF NOT sap_descriptor^.waiting_task_specified THEN
              pmp$get_executing_task_gtid (sap_descriptor^.waiting_task_id);
              sap_descriptor^.waiting_task_specified := TRUE;
            IFEND;
            osp$clear_job_signature_lock (nav$open_network_sap_list_lock);
            pmp$wait (wait_timer, wait_timer);
            wait_timer := 0;
            CYCLE /check_for_datagram/
          ELSE { Timer expired and no datagrams were received
            pmp$get_executing_task_gtid (task_id);
            IF sap_descriptor^.waiting_task_specified AND (task_id = sap_descriptor^.waiting_task_id) THEN
              sap_descriptor^.waiting_task_specified := FALSE;
            IFEND;
            osp$clear_job_signature_lock (nav$open_network_sap_list_lock);
            osp$set_status_abnormal (nac$status_id, nae$no_datagram_available, network, status);
            osp$append_status_integer (osc$status_parameter_delimiter, sap, 10, TRUE, status);
          IFEND;
        IFEND;
      ELSE { Unknown sap
        osp$clear_job_signature_lock (nav$open_network_sap_list_lock);
        osp$set_status_abnormal (nac$status_id, nae$sap_not_open, network, status);
        osp$append_status_integer (osc$status_parameter_delimiter, sap, 10, TRUE, status);
      IFEND;
    UNTIL NOT status.normal;

  PROCEND nap$receive_network_data;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$send_network_data', EJECT ??
*copy nah$send_network_data

  PROCEDURE [XDCL] nap$send_network_data
    (    sap: nat$network_sap_identifier;
         destination: nat$network_layer_address;
         data: nat$data_fragments;
     VAR status: ost$status);

    VAR
      data_length: nat$data_length,
      ignore_route_congested: boolean,
      network_address: ^nat$osi_network_address,
      network_address_seq: ^SEQ ( * ),
      sap_descriptor: ^nat$open_network_sap_descriptor;

    status.normal := TRUE;
    nlp$al_get_data_length (data, data_length);
    IF data_length <= nac$xi_maximum_data_length THEN

{ Verify that the sap is open.

      osp$set_job_signature_lock (nav$open_network_sap_list_lock);
      find_sap_descriptor (sap, sap_descriptor);
      osp$clear_job_signature_lock (nav$open_network_sap_list_lock);
      IF sap_descriptor <> NIL THEN
          network_address_seq := ^destination.network_address;
          RESET network_address_seq;
          NEXT network_address: [[REP destination.network_address_length OF cell]] IN network_address_seq;
          nlp$na_send_data (sap, destination.device_id, network_address^, data, status);
      ELSE { Sap not open
        osp$set_status_abnormal (nac$status_id, nae$sap_not_open, network, status);
        osp$append_status_integer (osc$status_parameter_delimiter, sap, 10, TRUE, status);
      IFEND;
    ELSE { Max data length exceeded
      osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, network, status);
      osp$append_status_integer (osc$status_parameter_delimiter, data_length, 10, TRUE, status);
    IFEND;

  PROCEND nap$send_network_data;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] find_sap_descriptor', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to find the sap descriptor for the
{   specified network sap identifier.
{   The sap list must be locked by the caller.

  PROCEDURE [INLINE] find_sap_descriptor
    (    sap: nat$network_sap_identifier;
     VAR sap_descriptor: ^nat$open_network_sap_descriptor);

    sap_descriptor := nav$open_network_sap_list;
    WHILE ((sap_descriptor <> NIL) AND (sap_descriptor^.sap <> sap)) DO
      sap_descriptor := sap_descriptor^.link;
    WHILEND;

  PROCEND find_sap_descriptor;
?? OLDTITLE ??
MODEND nam$network_external_interface;
*DECK DECK=NAM$NETWORK_FAP EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NAMVE: NAM$NETWORK_FAP' ??
?? NEWTITLE := 'XREF TYPES' ??
MODULE nam$network_fap;
?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
*copyc amt$call_block
*copyc ifc$interrupt
*copyc ost$caller_identifier
*copyc ost$i_wait
*copyc ost$status
?? TITLE := 'CONDITION_CODES', EJECT ??
*copyc ame$device_class_validation
*copyc nae$application_interfaces
*copyc nae$namve_conditions
?? POP ??
?? TITLE := 'XREF PROCEDURES', EJECT ??
*copyc amp$set_file_instance_abnormal
*copyc bap$close
*copyc bap$fetch
*copyc bap$fetch_access_information
*copyc bap$store
*copyc nap$open_file
*copyc nap$close_file
*copyc nlp$se_get_available_byte_count
*copyc nlp$se_receive_data
*copyc nlp$se_send_data
*copyc nlp$se_send_interrupt
*copyc nlp$se_synchronize
*copyc nlp$se_synchronize_confirm
*copyc nlp$fetch_attributes
*copyc nlp$store_attributes
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$i_await_activity_completion
*copyc osp$set_status_abnormal
*copyc pmp$continue_to_cause
*copyc pmp$long_term_wait
?? TITLE := 'NAP$NETWORK_FAP', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$network_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer: amt$fap_layer_number;
    VAR status: ost$status);

    PROCEDURE terminate_network_fap (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


    PROCEDURE process_block_exit (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

      CASE call_block.operation OF
      = amc$get_next_req, amc$get_partial_req, nac$se_receive_data_req =

        IF (status.normal) AND ((call_block.operation <> nac$se_receive_data_req) OR ((call_block.operation =
              nac$se_receive_data_req) AND (call_block.se_receive_data_req.wait = osc$wait))) THEN
          WHILE NOT activity_status^.complete DO
            IF receive_wait_swapout THEN
              pmp$long_term_wait (wait_time, 0ffffffffffff(16));
            ELSE
              pmp$long_term_wait (wait_time, 0);
            IFEND;
          WHILEND;
        IFEND;
      = amc$put_next_req, amc$put_partial_req, nac$se_send_data_req =

        IF (status.normal) AND ((call_block.operation <> nac$se_send_data_req) OR ((call_block.operation =
              nac$se_send_data_req) AND (call_block.se_send_data_req.wait = osc$wait))) THEN
          WHILE NOT activity_status^.complete DO
            pmp$long_term_wait (wait_time, 0);
          WHILEND;
        IFEND;
      ELSE
      CASEND;
      condition_status.normal := TRUE;

    PROCEND process_block_exit;

      CASE condition.selector OF
      = ifc$interactive_condition =
        IF request_started THEN
          osp$establish_block_exit_hndlr (^process_block_exit);
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IF request_started THEN
          osp$disestablish_cond_handler;
        IFEND;
        condition_status.normal := TRUE;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          CASE call_block.operation OF
          = amc$get_next_req, amc$get_partial_req, nac$se_receive_data_req =
            osp$set_status_abnormal (nac$status_id, nae$job_recovery, '', status);
            pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
            EXIT nap$network_fap;
          = amc$put_next_req, amc$put_partial_req, nac$se_send_data_req =
            osp$set_status_abnormal (nac$status_id, nae$job_recovery, '', status);
            pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
            EXIT nap$network_fap;
          ELSE
            ;
          CASEND;
        ELSE
          condition_status.normal := TRUE;
        IFEND;
      ELSE
        condition_status.normal := TRUE;
      CASEND;

    PROCEND terminate_network_fap;
    PROCEDURE terminate_await_data_available (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

      pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      IF (condition.selector = ifc$interactive_condition) AND
        (condition.interactive_condition = ifc$interrupt) THEN
        osp$set_status_abnormal (nac$status_id, nae$interactive_cond_interrupt, '', status);
        EXIT nap$network_fap;
      IFEND;
    PROCEND terminate_await_data_available;
?? EJECT ??

    CONST
      nac$wait_to_receive_increment = 2000,
      nac$wait_to_send_increment = 2000;

    VAR
      activity_status: ^ost$activity_status,
      caller_id: ost$caller_identifier,
      end_time: integer,
      ignore_structure_pointer: ^cell,
      receive_wait_swapout: boolean,
      ready_index: integer,
      request_started: boolean,
      start_time: integer,
      validation_ok: boolean,
      wait_list: array [1 .. 2] of ost$i_activity,
      wait_time: nat$wait_time;

    #caller_id (caller_id);

    status.normal := TRUE;

    CASE call_block.operation OF
    = amc$open_req =
      nap$open_file (file_identifier, layer, call_block, status);
    = amc$close_req =
      nap$close_file (file_identifier, layer, call_block, status);
      bap$close (file_identifier, status);
    = amc$fetch_access_information_rq =
      bap$fetch_access_information (file_identifier, call_block, layer, status);
    = amc$fetch_req =
      bap$fetch (file_identifier, call_block, layer, status);
    = amc$store_req =
      bap$store (file_identifier, call_block, layer, status);
    = amc$get_next_req, amc$get_partial_req, nac$se_receive_data_req =
      IF call_block.operation = nac$se_receive_data_req THEN
        activity_status := call_block.se_receive_data_req.activity_status;
      ELSE
        PUSH activity_status;
        IF call_block.operation = amc$get_next_req THEN
          call_block.getn.byte_address^ := 0;
        ELSE
          call_block.getp.byte_address^ := 0;
        IFEND;
      IFEND;
      activity_status^.complete := TRUE;
      activity_status^.status.normal := TRUE;

      request_started := FALSE;
      start_time := #FREE_RUNNING_CLOCK (0);
      osp$establish_condition_handler (^terminate_network_fap, FALSE);

      nlp$se_receive_data (file_identifier, layer, call_block, start_time, request_started, wait_time,
            receive_wait_swapout, activity_status, status);
      WHILE (status.normal AND NOT request_started AND NOT activity_status^.complete) DO
        end_time := #FREE_RUNNING_CLOCK (0);
        IF wait_time > ((end_time - start_time) DIV 1000) THEN
          wait_time := wait_time - ((end_time - start_time) DIV 1000);
          IF wait_time > nac$wait_to_receive_increment THEN
            pmp$long_term_wait (nac$wait_to_receive_increment, 0);
          ELSE
            pmp$long_term_wait (wait_time, 0);
          IFEND;
          nlp$se_receive_data (file_identifier, layer, call_block, start_time, request_started, wait_time,
                receive_wait_swapout, activity_status, status);
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$data_transfer_timeout, '', status);
        IFEND;
      WHILEND;

      IF (status.normal AND NOT activity_status^.complete) THEN
        IF ((call_block.operation <> nac$se_receive_data_req) OR ((call_block.operation =
            nac$se_receive_data_req) AND (call_block.se_receive_data_req.wait = osc$wait))) THEN
          REPEAT
            IF receive_wait_swapout THEN
              pmp$long_term_wait (wait_time, 0ffffffffffff(16));
            ELSE
              pmp$long_term_wait (wait_time, 0);
            IFEND;
          UNTIL activity_status^.complete;
          IF ((NOT activity_status^.status.normal) AND ((call_block.operation = amc$get_next_req) OR
                (call_block.operation = amc$get_partial_req))) THEN
            status := activity_status^.status;
          IFEND;
        IFEND;
      IFEND;
    = amc$put_next_req, amc$put_partial_req, nac$se_send_data_req =
      IF call_block.operation = nac$se_send_data_req THEN
        activity_status := call_block.se_send_data_req.activity_status;
      ELSE
        PUSH activity_status;
        IF call_block.operation = amc$put_next_req THEN
          call_block.putn.byte_address^ := 0;
        ELSE
          call_block.putp.byte_address^ := 0;
        IFEND;
      IFEND;
      activity_status^.complete := TRUE;
      activity_status^.status.normal := TRUE;

      request_started := FALSE;
      start_time := #FREE_RUNNING_CLOCK (0);
      osp$establish_condition_handler (^terminate_network_fap, FALSE);

      nlp$se_send_data (file_identifier, layer, call_block, start_time, request_started, wait_time,
            activity_status, status);
      WHILE (status.normal AND NOT request_started AND NOT activity_status^.complete) DO
        end_time := #FREE_RUNNING_CLOCK (0);
        IF wait_time > ((end_time - start_time) DIV 1000) THEN
          wait_time := wait_time - ((end_time - start_time) DIV 1000);
          IF wait_time > nac$wait_to_send_increment THEN
            pmp$long_term_wait (nac$wait_to_send_increment, 0);
          ELSE
            pmp$long_term_wait (wait_time, 0);
          IFEND;
          nlp$se_send_data (file_identifier, layer, call_block, start_time, request_started, wait_time,
                activity_status, status);
        ELSE
          osp$set_status_abnormal (nac$status_id, nae$data_transfer_timeout, '', status);
        IFEND;
      WHILEND;

      IF (status.normal AND NOT activity_status^.complete) THEN
        IF ((call_block.operation <> nac$se_send_data_req) OR ((call_block.operation =
            nac$se_send_data_req) AND (call_block.se_send_data_req.wait = osc$wait))) THEN
          REPEAT
            pmp$long_term_wait (wait_time, 0);
          UNTIL activity_status^.complete;
          IF ((NOT activity_status^.status.normal) AND ((call_block.operation = amc$put_next_req) OR
                (call_block.operation = amc$put_partial_req))) THEN
            status := activity_status^.status;
          IFEND;
        IFEND;
      IFEND;
    = nac$se_get_avail_byte_count_req =
      nlp$se_get_available_byte_count (file_identifier, layer, call_block, status);
    = nac$se_interrupt_req =
      nlp$se_send_interrupt (file_identifier, layer, call_block, status);
    = nac$se_synchronize_req =
      nlp$se_synchronize (file_identifier, layer, call_block, status);
    = nac$se_synchronize_confirm_req =
      nlp$se_synchronize_confirm (file_identifier, layer, call_block, status);
    = nac$await_data_available =
      wait_list [1].activity := nac$i_await_data_available;
      wait_list [1].file_identifier := file_identifier;
      wait_list [2].activity := osc$i_await_time;
      wait_list [2].milliseconds := call_block.await_data_available.wait_time;
      ; {wait_list[2].expected_wait_time := call_block.await_data_available.expected_wait_time;
      osp$establish_condition_handler (^terminate_await_data_available, FALSE);
      osp$i_await_activity_completion (wait_list, ready_index, status);
      IF (status.normal) AND (ready_index = 2) THEN
        osp$set_status_abnormal (nac$status_id, nae$no_data_available, '', status);
      IFEND;
    = nac$fetch_attributes =
      nlp$fetch_attributes (file_identifier, layer, call_block, status);
    = nac$store_attributes =
      nlp$store_attributes (file_identifier, layer, call_block, status);
    = amc$flush_req, amc$rewind_req, amc$skip_req, amc$write_end_partition_req =
      ; {ignore request (return normal status)
    ELSE
      amp$set_file_instance_abnormal (file_identifier, ame$improper_device_class , call_block.operation,
            'CALL_BLOCK ERROR - NAP$NETWORK_FAP', status);
    CASEND;
  PROCEND nap$network_fap;

MODEND nam$network_fap;
*DECK DECK=NAM$NETWORK_OPERATOR_UTILITY EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? TITLE := 'NOS/VE: Network Operator Utility' ??
?? NEWTITLE := 'Global Declarations' ??
MODULE nam$network_operator_utility;
?? PUSH (LISTEXT := ON) ??
*copyc ame$condition_codes
*copyc amt$file_byte_address
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc amd$open_declarations
*copyc amt$term_option
*copyc clt$argument_descriptor_table
*copyc nae$application_interfaces
*copyc nae$directory_me_conditions
*copyc nae$manage_network_applications
*copyc nae$namve_conditions
*copyc nae$network_operator_utility
*copyc nat$bcd_time
*copyc nat$command_interface
*copyc nat$directory_interfaces
*copyc nat$gt_event
*copyc nat$network_address
*copyc nat$system_title
*copyc nat$title
*copyc nat$wait_time
*copyc ost$date
*copyc ost$date_time
*copyc ost$signature_lock_status
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc ost$status_message
*copyc ost$time
*copyc pfe$error_condition_codes
*copyc pmt$condition
*copyc pmt$condition_information
*copyc rmt$device_class
?? POP ??
*copyc amp$flush
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc amp$return
*copyc avp$get_capability
*copyc clp$begin_utility
*copyc clp$close_display
*copyc clp$create_variable
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$get_parameter_list_text
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$include_file
*copyc clp$new_display_line
*copyc clp$open_display
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$read_variable
*copyc clp$reset_for_next_display_page
*copyc clp$scan_argument_list
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc clp$write_variable
*copyc fsp$close_file
*copyc fsp$open_file
*copyc ifp$discard_suspended_output
*copyc i#move
*copyc nap$activate_network_alarms
*copyc nap$deactivate_network_alarms
*copyc nap$display_message
*copyc nap$end_command_processing
*copyc nap$generate_network_message
*copyc nap$receive_network_alarm
*copyc nap$receive_command_response
*copyc nap$send_command
*copyc nap$terminate_command
*copyc nlp$get_title_translation
*copyc nlp$translate_title
*copyc osp$append_status_integer
*copyc osp$establish_condition_handler
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$connect_queue
*copyc pmp$continue_to_cause
*copyc pmp$define_queue
*copyc pmp$disconnect_queue
*copyc pmp$disestablish_end_handler
*copyc pmp$establish_condition_handler
*copyc pmp$establish_end_handler
*copyc pmp$execute
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pmp$get_unique_name
*copyc pmp$get_legible_date_time
*copyc pmp$get_os_version
*copyc pmp$get_program_description
*copyc pmp$get_program_size
*copyc pmp$receive_from_queue
*copyc pmp$remove_queue
*copyc pmp$send_to_queue
*copyc pmp$terminate
*copyc pmp$wait
*copyc rmp$get_device_class

  TYPE
    alarm_record = record
      responder: nat$system_title,
      response_code: nat$command_response_code,
      time_stamp: nat$bcd_time,
      response: SEQ ( * ),
    recend;

  TYPE
    output_lock_word = integer;

  TYPE
    title_return_entry = record
      size: ost$string_size,
      value: nat$system_title,
    recend;

  TYPE
    system_response = record
      command_id: nat$command_identifier,
      system: nat$system_title,
      code: nat$command_response_code,
      normal_response: boolean,
      received: boolean,
    recend;

  TYPE
    task_record = record
      task_id: pmt$task_id,
      task_status: pmt$task_status,
    recend;

  CONST
    nac$time_stamp_length = 18,
    nac$operator_utility_version = 'V1.1',
    nac$operator_utility_level = '90086',
    alarm_wait_time = 1000000000, {very long wait time}
    command_terminated = 'Command terminated.',
    command_wait_time = 120000,
    default_output_file = '$OUTPUT',
    few_destinations = 4, {Number of systems specified before requesting all translations}
    locked = 77,
    max_address_count = 1024,
    normal_response_code = 0,
    prompt_string = 'nou',
    translation_wait_time = 1000,
    unlocked = 0;

  VAR
    alarm_output_task: task_record,
    alarm_task: task_record,
    command_id: nat$command_identifier := 0,
    communication_queue: pmt$queue_connection,
    communication_queue_name: pmt$queue_name,
    display_control: ^clt$display_control,
    interrupt_detected: boolean := FALSE,
    output_control: clt$display_control,
    output_lock: ^output_lock_word := NIL,
    response_buffer: SEQ (REP nac$max_command_response_length of cell),
    response_control: clt$display_control,
    response_file: clt$file := ['$RESPONSE'],
    response_list: ^array [1 .. * ] of system_response := NIL,
    shared_segment_attachment: [STATIC, READ] array [1 .. 2] of fst$attachment_option :=
          [[fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$read, fsc$append, fsc$shorten,
          fsc$modify]], [fsc$specific_share_modes, [fsc$read, fsc$append, fsc$shorten, fsc$modify]]],
          [fsc$open_share_modes, [fsc$read, fsc$append, fsc$shorten, fsc$modify]]],
    shared_segment_id: amt$file_identifier,
    shared_segment_name: amt$local_file_name,
    utility_name: ost$name := 'NETWORK_OPERATOR_UTILITY';

{ PDT acta_pdt (
{   group,groups,g : name = CATENET
{   output,o : file = $OUTPUT
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    acta_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^acta_pdt_names, ^acta_pdt_params];

  VAR
    acta_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
      clt$parameter_name_descriptor := [['GROUP', 1], ['GROUPS', 1], ['G', 1], ['OUTPUT', 2], ['O', 2], [
      'STATUS', 3]];

  VAR
    acta_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ GROUP GROUPS G }
    [[clc$optional_with_default, ^acta_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$name_value, 1, osc$max_name_size]],

{ OUTPUT O }
    [[clc$optional_with_default, ^acta_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value
      ]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    acta_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := 'CATENET';

  VAR
    acta_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??
?? OLDTITLE ??
?? NEWTITLE := 'nap$send_network_commands', EJECT ??

  PROGRAM nap$send_network_commands (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PURPOSE: This procedure establishes the Network Operator Utility environment.
{ DESIGN:  Prolog file processing is performed if requested. SCL is then called to
{          process commands in the subutility environment.


    VAR
      device_assigned: boolean,
      device_class: rmt$device_class,
      local_status: ost$status,
      network_operation: boolean,
      output_file: clt$value,
      prolog_file: clt$value,
      prolog_specified: boolean,
      utility_attributes: [STATIC, READ] array [1 .. 4] of clt$utility_attribute := [
            [clc$utility_command_search_mode, clc$global_command_search],
            [clc$utility_command_table, ^me_sub_commands_entries],
            [clc$utility_function_table, ^me_functions_entries],
            [clc$utility_prompt, [3, prompt_string]]];

{ PDT netou_pdt(
{   prolog,p: file =$user.network_operator_prolog
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      netou_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^netou_pdt_names,
        ^netou_pdt_params];

    VAR
      netou_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['PROLOG', 1], ['P', 1], ['STATUS', 2]];

    VAR
      netou_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ PROLOG P }
      [[clc$optional_with_default, ^netou_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      netou_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (29) :=
        '$user.network_operator_prolog';

?? POP ??

{ table me_sub_commands
{ command (send_command,senc) processor = send_command
{ command (activate_alarms,activate_alarm,acta) processor = activate_alarms
{ command (deactivate_alarms,deactivate_alarm,deaa) processor = deactivate_alarms
{ command (quit,qui) processor = quit

?? PUSH (LISTEXT := ON) ??

VAR
  me_sub_commands: [STATIC, READ] ^clt$command_table := ^me_sub_commands_entries,

  me_sub_commands_entries: [STATIC, READ] array [1 .. 10] of clt$command_table_entry := [
  {} ['ACTA                           ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^activate_alarms],
  {} ['ACTIVATE_ALARM                 ', clc$alias_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^activate_alarms],
  {} ['ACTIVATE_ALARMS                ', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^activate_alarms],
  {} ['DEAA                           ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^deactivate_alarms],
  {} ['DEACTIVATE_ALARM               ', clc$alias_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^deactivate_alarms],
  {} ['DEACTIVATE_ALARMS              ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^deactivate_alarms],
  {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^quit],
  {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^quit],
  {} ['SENC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^send_command],
  {} ['SEND_COMMAND                   ', clc$nominal_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^send_command]];

?? POP ??

{ table me_functions type = function
{ function $normal_response processor = normal_response_function
{ function $response_identifier processor = response_identifier_function
{ function $matching_names processor = matching_names_function

?? PUSH (LISTEXT := ON) ??

    VAR
      me_functions: [STATIC, READ] ^clt$function_table := ^me_functions_entries,

      me_functions_entries: [STATIC, READ] array [1 .. 3] of clt$function_table_entry := [
        {} ['$MATCHING_NAMES                ', clc$nominal_entry, clc$advertised_entry, 3, clc$linked_call,
        ^matching_names_function],
        {} ['$NORMAL_RESPONSE               ', clc$nominal_entry, clc$advertised_entry, 1, clc$linked_call,
        ^normal_response_function],
        {} ['$RESPONSE_IDENTIFIER           ', clc$nominal_entry, clc$advertised_entry, 2, clc$linked_call,
        ^response_identifier_function]];

?? POP ??

?? NEWTITLE := '  condition_handler', EJECT ??

    PROCEDURE condition_handler (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

      VAR
        local_status: ost$status;

      CASE condition.selector OF
      = pmc$system_conditions =
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      = pmc$block_exit_processing =
        local_status.normal := TRUE;
        terminate_asynchronous_tasks;
        nap$end_command_processing (local_status);
      = ifc$interactive_condition =
        IF condition.interactive_condition = ifc$terminate_break THEN
          interrupt_detected := TRUE;
          ifp$discard_suspended_output;
          osp$set_status_condition ( nae$no_event,  status);
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          osp$set_status_abnormal (nac$status_id, nae$job_recovery, 'NETWORK OPERATOR', status);
          EXIT nap$send_network_commands;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;

    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    clp$scan_parameter_list (parameter_list, netou_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avp$get_capability (avc$network_operation, avc$user, network_operation, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT network_operation THEN
      osp$set_status_abnormal (nac$status_id, nae$invalid_user, 'NETWORK OPERATOR UTILITY', status);
      RETURN;
    IFEND;

    alarm_task.task_status.complete := TRUE;
    alarm_output_task.task_status.complete := TRUE;

    clp$test_parameter ('PROLOG', prolog_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_value ('PROLOG', 1, 1, clc$low, prolog_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    interrupt_detected := FALSE;
    osp$establish_condition_handler (^condition_handler, {block exit=} TRUE);

    output_file.file.local_file_name := default_output_file;
    clp$open_display (output_file.file, ^generate_headers, output_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$open_display (response_file, ^generate_headers, response_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (prolog_file.file.local_file_name, prompt_string, utility_name, status);
    IF NOT status.normal THEN
      IF prolog_specified THEN
        { forgive error for explicit prolog=$null. }
        local_status.normal := TRUE;
        rmp$get_device_class (prolog_file.file.local_file_name, device_assigned, device_class, local_status);
        IF NOT local_status.normal THEN
          status := local_status;
          RETURN;
        IFEND;
        IF device_class = rmc$null_device THEN
          status.normal := TRUE;
        IFEND;
      ELSEIF (status.condition = ame$file_not_known) OR (status.condition = pfe$unknown_permanent_file) THEN
        status.normal := TRUE;
      IFEND;
      IF NOT status.normal THEN
        display_message (status, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    clp$include_file (clc$current_command_input, prompt_string, utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (utility_name, status);

  PROCEND nap$send_network_commands;
?? OLDTITLE ??
?? NEWTITLE := 'Command Processors' ??
?? NEWTITLE := 'send_command', EJECT ??

  PROCEDURE send_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PURPOSE: This is the command processor for the NETOU send_command command.
{ DESIGN:  The command parameters are interpreted and the specified command string
{          is sent to the specified systems. Command responses are then requested
{          and displayed until exactly one response or error indication has been
{          received from each system specified. Responses are formatted and displayed
{          on the file specified on the command. A condition handler for terminate
{          break is enabled during command processing to allow the operator to
{          terminate the command and its output if necessary. If a terminate break
{          is received, an error response will be generated for each system that has
{          not terminated processing the current command.
{          The command identifier is used to associate each response with the system
{          name used to send the command, since the system may have more than one name
{          configured and will respond with a default name that may be different than
{          the one specified by the operator.
{          If a command is destined for more than a few systems, a single wild card
{          translation request will be issued to prime the Directory cache before
{          issuing individual translation requests. This is done in order to avoid
{          swamping the Network Access link with translation request broadcast PDUs.
{          Commands will be timed out after 2 minutes if all responses are not received.


  PROCEDURE terminate_break_handler (condition: pmt$condition;
        condition_descriptor: ^pmt$condition_information;
        save_area: ^ost$stack_frame_save_area;
    VAR break_status: ost$status);

{ PURPOSE: This routine processes the terminate break condition for NETOU.
{ DESIGN:  The global flag interrupt_detected is set to TRUE and the condition
{          is cancelled. Queued output is also discarded. It is the responsibility
{          of the procedure establishing this condition handler to periodically
{          check the interrupt_detected flag and terminate processing when it is set.
{          Status is set abnormal to terminate a wait condition.

    VAR
      ignore_status: ost$status;

    interrupt_detected := TRUE;
    ifp$discard_suspended_output;
    clp$put_display (output_control, command_terminated, clc$trim, ignore_status);
    osp$set_status_condition ( nae$no_event,  local_status);

  PROCEND terminate_break_handler;

    VAR
      command: clt$value,
      commands_outstanding: integer,
      commands_sent: integer,
      current_display_control: ^clt$display_control,
      display_line: string (255),
      end_time: integer,
      errors_detected: boolean,
      ignore_status: ost$status,
      index: integer,
      interrupt_descriptor: pmt$established_handler,
      interrupt_condition: [STATIC] pmt$condition := [ifc$interactive_condition, ifc$terminate_break],
      j: integer,
      local_display_control: clt$display_control,
      local_status: ost$status,
      many_translations_required: boolean,
      multiple_destinations: boolean,
      normal_response: boolean,
      output_file: clt$value,
      output_specified: boolean,
      remaining_wait_time: integer,
      responder: nat$system_title,
      response: nat$data_fragment,
      response_code: nat$command_response_code,
      response_id: nat$command_identifier,
      response_length: nat$data_length,
      response_message: ^SEQ ( * ),
      response_pointer: ^SEQ (REP nac$max_command_response_length of cell),
      system_title: clt$value,
      title_count: 0 .. clc$max_value_sets,
      truncated: boolean;

{ PDT senc_pdt (
{   command,c : string = $required
{   system,systems,s : list 1..300 of name = $required
{   output,o : file
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    senc_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^senc_pdt_names, ^senc_pdt_params];

  VAR
    senc_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 8] of
      clt$parameter_name_descriptor := [['COMMAND', 1], ['C', 1], ['SYSTEM', 2], ['SYSTEMS', 2], ['S', 2], [
      'OUTPUT', 3], ['O', 3], ['STATUS', 4]];

  VAR
    senc_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor := [

{ COMMAND C }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, osc$max_string_size
      ]],

{ SYSTEM SYSTEMS S }
    [[clc$required], 1, 300, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ OUTPUT O }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    clp$scan_parameter_list (parameter_list, senc_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('COMMAND', 1, 1, clc$low, command, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('SYSTEM', title_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    multiple_destinations := title_count > 1;
    many_translations_required := title_count > few_destinations;

    clp$test_parameter ('OUTPUT', output_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF output_specified THEN
      clp$get_value ('OUTPUT', 1, 1, clc$low, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$open_display (output_file.file, ^generate_headers, local_display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      current_display_control := ^local_display_control;
    ELSE
      current_display_control := ^output_control;
    IFEND;

    interrupt_detected := FALSE;
    pmp$establish_condition_handler (interrupt_condition, ^terminate_break_handler, ^interrupt_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Send the command to each of the specified systems.

    IF response_list <> NIL THEN
      FREE response_list;
    IFEND;
    ALLOCATE response_list: [1 .. title_count];
    errors_detected := FALSE;
    commands_sent := 0;

    FOR index := 1 TO title_count DO
      clp$get_value ('SYSTEM', index, 1, clc$low, system_title, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      command_id := (command_id + 1) MOD (UPPERVALUE (nat$command_identifier) + 1);
      response_list^ [index].command_id := command_id;
      response_list^ [index].system := system_title.name.value (1, system_title.name.size);
      response_list^ [index].received := FALSE;
      nap$send_command (^command.str.value (1, command.str.size), system_title.name.value (1, system_title.
            name.size), command_id, {retain connection} TRUE, many_translations_required, local_status);
      IF local_status.normal THEN
        commands_sent := commands_sent + 1;
      ELSEIF multiple_destinations THEN
        display_message (local_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        errors_detected := TRUE;
      ELSE
        status := local_status;
      IFEND;
    FOREND;

{ Process one response for each system to which the command was sent.

    response_pointer := ^response_buffer;
    response.address := ^response_buffer;
    response.length := #SIZE (response_buffer);
    commands_outstanding := commands_sent;
    end_time := (#free_running_clock (0) DIV 1000) + command_wait_time;
    remaining_wait_time := command_wait_time;

    WHILE (commands_outstanding > 0) AND (NOT interrupt_detected) AND (remaining_wait_time > 0) DO
      nap$receive_command_response (remaining_wait_time, response, response_length, responder, response_id,
            response_code, normal_response, truncated, local_status);
      IF local_status.normal THEN

        /save_response/
          FOR index := LOWERBOUND (response_list^) TO UPPERBOUND (response_list^) DO
            IF (response_id = response_list^ [index].command_id) AND (NOT response_list^ [index].received)
                  THEN
              response_list^ [index].received := TRUE;
              response_list^ [index].code := response_code;
              response_list^ [index].normal_response := normal_response;
              IF normal_response THEN
                display_control := current_display_control;
              ELSE
                display_control := ^response_control;
              IFEND;
              STRINGREP (display_line, j, 'FROM ', response_list^ [index].system);
              set_output_lock;
              IF normal_response THEN
                clp$put_display (display_control^, display_line (1, j), clc$trim, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              ELSE
                clp$put_partial_display (display_control^, display_line (1, j), clc$trim, amc$start, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                STRINGREP (display_line, j, response_code);
                clp$put_partial_display (display_control^, display_line (1, j), clc$trim, amc$terminate,
                      status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              IFEND;
              RESET response_pointer;
              NEXT response_message: [[REP response_length OF cell]] IN response_pointer;
              nap$generate_network_message (response_message^, display_control^, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              IF truncated THEN
                clp$put_display (display_control^, ' (Response truncated)', clc$trim, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              IFEND;
              IF multiple_destinations THEN
                amp$flush (display_control^.file_id, osc$wait, ignore_status);
              IFEND;
              clear_output_lock;
              EXIT /save_response/;
            IFEND;
          FOREND /save_response/;
          commands_outstanding := commands_outstanding - 1;

      ELSEIF local_status.condition = nae$no_event THEN
        {ignore this error condition...it is a non-event};

      ELSEIF multiple_destinations THEN
        display_message (local_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        errors_detected := TRUE;
        commands_outstanding := commands_outstanding - 1;

      ELSE {single destination with error}
        status := local_status;
        commands_outstanding := commands_outstanding - 1;
      IFEND;
      remaining_wait_time := end_time - (#free_running_clock (0) DIV 1000);
    WHILEND;

    FOR index := LOWERBOUND (response_list^) TO UPPERBOUND (response_list^) DO
      IF NOT response_list^ [index].received THEN
        nap$terminate_command (response_list^ [index].system, {retain_connection } FALSE, local_status);
        IF NOT local_status.normal THEN
          IF multiple_destinations THEN
            display_message (local_status, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            errors_detected := TRUE;
          ELSE {single destination}
            status := local_status;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

    IF output_specified THEN
      clp$close_display (local_display_control, ignore_status);
    IFEND;

    IF multiple_destinations AND errors_detected THEN
      osp$set_status_abnormal (nac$status_id, nae$errors_during_command, 'SEND_COMMAND', status);
    IFEND;

  PROCEND send_command;
?? OLDTITLE ??
?? NEWTITLE := 'activate_alarms', EJECT ??

  PROCEDURE activate_alarms (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PURPOSE: This is the command processor for the NETOU activate_alarms command.
{ DESIGN:  1. The command parameters are validated.
{          2. A local queue is created for communication among the tasks.
{             An output lock is created and passed via the local queue to the alarm output task.
{          3. An asynchronous task is started to perform the actual command and response processing.
{          4. An asynchronous task is started to produce alarm output while alarm connections are
{             processed.
{          5. The alarm tasks are terminated by the deactivate_alarms command or the quit command.

    VAR
      communication_queue_name_parm: ^pmt$queue_name,
      community_title: clt$value,
      group_count: 0 .. clc$max_value_sets,
      number_of_object_files: pmt$number_of_object_files,
      number_of_modules: pmt$number_of_modules,
      number_of_libraries: pmt$number_of_libraries,
      output_file: clt$value,
      output_file_name_parm: ^amt$local_file_name,
      output_lock_relative_pointer: ^REL (HEAP ( * )) ^output_lock_word,
      parameter_list_contents: ^pmt$program_parameters,
      program_attributes: ^pmt$program_attributes,
      program_description: ^pmt$program_description,
      queue_message: pmt$message,
      queue_message_value: ^pmt$message_value,
      shared_heap: ^HEAP ( * ),
      shared_segment_name_parm: ^amt$local_file_name,
      shared_segment_pointer: amt$segment_pointer,
      starting_procedure: pmt$program_name;

    status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, acta_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ **** Verify CATENET is the only alarm group for release 1.2.1

    clp$get_set_count ('GROUPS', group_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_value ('GROUPS', 1, 1, clc$low, community_title, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (group_count > 1) OR (community_title.name.value <> 'CATENET') THEN
      osp$set_status_abnormal (nac$status_id, nae$invalid_alarm_group, community_title.name.value, status);
      RETURN;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT alarm_task.task_status.complete THEN {alarms already active}
      osp$set_status_condition ( nae$alarms_already_active,  status);
      RETURN;
    IFEND;

    IF NOT alarm_output_task.task_status.complete THEN {alarm output task still running}
      terminate_asynchronous_tasks;
    IFEND;

{ Define and initialize the communication queue.

    pmp$get_unique_name (shared_segment_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    fsp$open_file (shared_segment_name, amc$segment, {attachment options=} ^shared_segment_attachment,
          {default creation attributes=} NIL, {mandated creation attributes=} NIL,
          {attribute validation=} NIL, {attribute override=} NIL, shared_segment_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (shared_segment_id, amc$heap_pointer, shared_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    shared_heap := shared_segment_pointer.heap_pointer;
    RESET shared_heap^;

    pmp$get_unique_name (communication_queue_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$define_queue (communication_queue_name, osc$user_ring, osc$user_ring, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$connect_queue (communication_queue_name, communication_queue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    queue_message.contents := pmc$message_value;
    queue_message_value := ^queue_message.value;
    RESET queue_message_value;
    NEXT output_lock_relative_pointer IN queue_message_value;
    ALLOCATE output_lock IN shared_heap^;
    output_lock^ := unlocked;
    output_lock_relative_pointer^ := #REL (output_lock, shared_heap^);
    pmp$send_to_queue (communication_queue, queue_message, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$disconnect_queue (communication_queue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_program_size (number_of_object_files, number_of_modules, number_of_libraries, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH program_description: [[REP (#SIZE (pmt$program_attributes) + (number_of_object_files +
          number_of_libraries) * #SIZE (amt$local_file_name) + number_of_modules * #SIZE (pmt$program_name))
          OF cell]];
    pmp$get_program_description (program_description^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET program_description;
    NEXT program_attributes IN program_description;
    program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
          [pmc$starting_proc_specified];
    program_attributes^.starting_procedure := 'NAP$PROCESS_ACTIVATE_ALARMS';
    RESET program_description;

    PUSH parameter_list_contents: [[REP 2 OF amt$local_file_name, REP 1 OF pmt$queue_name]];
    RESET parameter_list_contents;
    NEXT output_file_name_parm IN parameter_list_contents;
    output_file_name_parm^ := output_file.file.local_file_name;
    NEXT shared_segment_name_parm IN parameter_list_contents;
    shared_segment_name_parm^ := shared_segment_name;
    NEXT communication_queue_name_parm IN parameter_list_contents;
    communication_queue_name_parm^ := communication_queue_name;

    pmp$execute (program_description^, #SEQ (parameter_list_contents^) ^, osc$nowait, alarm_task.task_id,
          alarm_task.task_status, status);

    program_attributes^.starting_procedure := 'NAP$PROCESS_ALARM_OUTPUT';
    pmp$execute (program_description^, #SEQ (parameter_list_contents^) ^, osc$nowait,
          alarm_output_task.task_id, alarm_output_task.task_status, status);

  PROCEND activate_alarms;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$process_activate_alarms', EJECT ??

  PROCEDURE [XDCL] nap$process_activate_alarms (parameter_list: pmt$program_parameters;
    VAR status: ost$status);

{ PURPOSE: This procedure controls the operation of the asynchronous task that processes
{          network alarms for NETOU.
{ DESIGN:  The command parameters are interpreted and the specified alarm titles enabled.
{          Alarms are then requested and displayed until the task is terminated by its
{          parent task. Responses are formatted and displayed on the file specified on the command.

    VAR
      alarm_message: ^alarm_record,
      alarm_message_relative_pointer: ^REL (HEAP ( * )) ^alarm_record,
      communication_queue_name: ^pmt$queue_name,
      community_title: clt$value,
      exit_condition: [STATIC] pmt$condition := [pmc$condition_combination,
        [pmc$block_exit_processing, pmc$user_defined_condition]],
      establish_descriptor: pmt$established_handler,
      groups: array [1 .. 1] of nat$community_title,
      job_recovery_in_progress: [STATIC] boolean := FALSE,
      local_status: ost$status,
      output_file: ^amt$local_file_name,
      parameter_list_contents: ^pmt$program_parameters,
      queue_message: pmt$message,
      queue_message_value: ^pmt$message_value,
      responder: nat$system_title,
      response: nat$data_fragment,
      response_code: nat$command_response_code,
      response_length: nat$data_length,
      response_pointer: ^SEQ (REP nac$max_command_response_length of cell),
      shared_heap: ^HEAP ( * ),
      shared_segment_name: ^amt$local_file_name,
      shared_segment_pointer: amt$segment_pointer,
      time_stamp: nat$bcd_time;

    PROCEDURE exit_condition_handler (condition: pmt$condition;
          condition_discriptor: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      CASE condition.selector OF
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          job_recovery_in_progress := TRUE;
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
        handler_status.normal := TRUE;
      ELSE
        IF NOT job_recovery_in_progress THEN
          nap$deactivate_network_alarms (ignore_status);
        IFEND;
        pmp$disestablish_end_handler (^alarm_end_handler, status);
      CASEND;

    PROCEND exit_condition_handler;

    status.normal := TRUE;
    parameter_list_contents := ^parameter_list;
    RESET parameter_list_contents;
    NEXT output_file IN parameter_list_contents;
    NEXT shared_segment_name IN parameter_list_contents;
    NEXT communication_queue_name IN parameter_list_contents;

    fsp$open_file (shared_segment_name^, amc$segment, {attachment options=} ^shared_segment_attachment,
          {default creation attributes=} NIL, {mandated creation attributes=} NIL,
          {attribute validation=} NIL, {attribute override=} NIL, shared_segment_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    amp$get_segment_pointer (shared_segment_id, amc$heap_pointer, shared_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    shared_heap := shared_segment_pointer.heap_pointer;

    pmp$connect_queue (communication_queue_name^, communication_queue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    queue_message.contents := pmc$message_value;
    queue_message_value := ^queue_message.value;
    RESET queue_message_value;
    NEXT alarm_message_relative_pointer IN queue_message_value;

    pmp$establish_end_handler (^alarm_end_handler, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^establish_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    groups [1] := 'CATENET';
    nap$activate_network_alarms (groups, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    response_pointer := ^response_buffer;
    response.address := ^response_buffer;
    response.length := #SIZE (response_buffer);

    WHILE TRUE DO
      local_status.normal := TRUE;
      nap$receive_network_alarm (alarm_wait_time, response, response_length, responder, response_code,
            time_stamp, local_status);
      IF local_status.normal THEN
        ALLOCATE alarm_message: [[REP response_length OF cell]] IN shared_heap^;
        alarm_message^.responder := responder;
        alarm_message^.response_code := response_code;
        alarm_message^.time_stamp := time_stamp;
        i#move (response.address, ^alarm_message^.response, response_length);
        alarm_message_relative_pointer^ := #REL (alarm_message, shared_heap^);
        pmp$send_to_queue (communication_queue, queue_message, status);
        IF NOT status.normal THEN
          display_message (status, local_status);
          nap$display_message (status);
          RETURN;
        IFEND;
      ELSEIF local_status.condition <> nae$no_event THEN
        display_message (local_status, status);
        IF NOT status.normal THEN
          nap$display_message (status);
          RETURN;
        IFEND;
      IFEND;
    WHILEND;

  PROCEND nap$process_activate_alarms;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$process_alarm_output', EJECT ??

  PROCEDURE [XDCL] nap$process_alarm_output (parameter_list: pmt$program_parameters;
    VAR status: ost$status);

{ PURPOSE: This procedure controls the operation of the asynchronous task that writes
{          network alarms to the output file. By having this process in a separate asynchronous
{          task, the alarm processor will not be blocked by page wait, etc., on the output file.
{ DESIGN:  The first message on the local queue is a pointer to the lockword used to coordinate
{          output of command and alarm output. Subsequent queue messages are alarms.
{          The alarm data is received from the local queue and displayed on the output file.

    VAR
      alarm_message: ^alarm_record,
      alarm_message_relative_pointer: ^REL (HEAP ( * )) ^alarm_record,
      communication_queue_name: ^pmt$queue_name,
      display_line: string (255),
      display_control: clt$display_control,
      exit_condition: [STATIC] pmt$condition := [pmc$block_exit_processing, [pmc$block_exit,
        pmc$program_termination, pmc$program_abort]],
      establish_descriptor: pmt$established_handler,
      formatted_date: ost$date,
      formatted_time: ost$time,
      ignore_status: ost$status,
      j: integer,
      message_from_control: pmt$message,
      output_file: clt$file,
      output_file_name: ^amt$local_file_name,
      output_lock_relative_pointer: ^REL (HEAP ( * )) ^output_lock_word,
      parameter_list_contents: ^pmt$program_parameters,
      program_attributes: ^pmt$program_attributes,
      program_description: ^pmt$program_description,
      queue_message: ^pmt$message_value,
      responder: nat$system_title,
      response: nat$data_fragment,
      response_code: nat$command_response_code,
      response_length: nat$data_length,
      shared_heap: ^HEAP ( * ),
      shared_segment_name: ^amt$local_file_name,
      shared_segment_pointer: amt$segment_pointer,
      time_stamp: nat$bcd_time;


    status.normal := TRUE;
    parameter_list_contents := ^parameter_list;
    RESET parameter_list_contents;
    NEXT output_file_name IN parameter_list_contents;
    NEXT shared_segment_name IN parameter_list_contents;
    NEXT communication_queue_name IN parameter_list_contents;

    fsp$open_file (shared_segment_name^, amc$segment, {attachment options=} ^shared_segment_attachment,
          {default creation attributes=} NIL, {mandated creation attributes=} NIL,
          {attribute validation=} NIL, {attribute override=} NIL, shared_segment_id, status);
    IF NOT status.normal THEN
      display_message (status, ignore_status);
      RETURN;
    IFEND;
    amp$get_segment_pointer (shared_segment_id, amc$heap_pointer, shared_segment_pointer, status);
    IF NOT status.normal THEN
      display_message (status, ignore_status);
      RETURN;
    IFEND;
    shared_heap := shared_segment_pointer.heap_pointer;

    pmp$connect_queue (communication_queue_name^, communication_queue, status);
    IF NOT status.normal THEN
      display_message (status, ignore_status);
      RETURN;
    IFEND;

    pmp$receive_from_queue (communication_queue, osc$wait, message_from_control, status);
    IF NOT status.normal THEN
      display_message (status, ignore_status);
      RETURN;
    IFEND;
    queue_message := ^message_from_control.value;
    RESET queue_message;
    NEXT output_lock_relative_pointer IN queue_message;
    output_lock := #PTR (output_lock_relative_pointer^, shared_heap^);

    output_file.local_file_name := output_file_name^;
    clp$open_display (output_file, ^generate_headers, display_control, status);
    IF NOT status.normal THEN
      display_message (status, ignore_status);
      RETURN;
    IFEND;

    WHILE TRUE DO
      pmp$receive_from_queue (communication_queue, osc$wait, message_from_control, status);
      IF NOT status.normal THEN
        display_message (status, ignore_status);
        RETURN;
      IFEND;
      queue_message := ^message_from_control.value;
      RESET queue_message;
      NEXT alarm_message_relative_pointer IN queue_message;
      alarm_message := #PTR (alarm_message_relative_pointer^, shared_heap^);
      responder := alarm_message^.responder;
      response_code := alarm_message^.response_code;
      time_stamp := alarm_message^.time_stamp;
        format_time_stamp (time_stamp, formatted_date, formatted_time);
        STRINGREP (display_line, j, '****** ALARM FROM ', responder);
        set_output_lock;
        clp$put_partial_display (display_control, display_line (1, j), clc$trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_partial_display (display_control, ' ', clc$no_trim, amc$continue, ignore_status);
        CASE formatted_date.date_format OF
        = osc$month_date =
          clp$put_partial_display (display_control, formatted_date.month, clc$trim, amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        = osc$mdy_date =
          clp$put_partial_display (display_control, formatted_date.mdy, clc$trim, amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        = osc$iso_date =
          clp$put_partial_display (display_control, formatted_date.iso, clc$trim, amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        = osc$ordinal_date =
          clp$put_partial_display (display_control, formatted_date.ordinal, clc$trim, amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        = osc$dmy_date =
          clp$put_partial_display (display_control, formatted_date.dmy, clc$trim, amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
        CASEND;
        clp$put_partial_display (display_control, ' ', clc$no_trim, amc$continue, ignore_status);
        CASE formatted_time.time_format OF
        = osc$ampm_time =
          clp$put_partial_display (display_control, formatted_time.ampm, clc$trim, amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        = osc$hms_time =
          clp$put_partial_display (display_control, formatted_time.hms, clc$trim, amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        = osc$millisecond_time =
          clp$put_partial_display (display_control, formatted_time.millisecond, clc$trim, amc$continue,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
        CASEND;
        STRINGREP (display_line, j, response_code);
        clp$put_partial_display (display_control, display_line (1, j), clc$trim, amc$terminate, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        nap$generate_network_message (alarm_message^.response, display_control, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        amp$flush (display_control.file_id, osc$wait, ignore_status);
        clear_output_lock;
        FREE alarm_message IN shared_heap^;
    WHILEND;

  PROCEND nap$process_alarm_output;
?? OLDTITLE ??
?? NEWTITLE := 'alarm_end_handler', EJECT ??
  PROCEDURE alarm_end_handler (termination_status: ost$status;
    VAR handler_status: ost$status);

    VAR
      ignore_status: ost$status;

    nap$deactivate_network_alarms (ignore_status);

  PROCEND alarm_end_handler;
?? OLDTITLE ??
?? NEWTITLE := 'deactivate_alarms', EJECT ??

  PROCEDURE deactivate_alarms (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PURPOSE: This procedure is the command processor for the NETOU deactivate_alarms
{          command.
{ DESIGN:  If the alarm task is active, it is terminated.

{ PDT deaa_pdt(
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      deaa_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^deaa_pdt_names, ^deaa_pdt_params];

    VAR
      deaa_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
        clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      deaa_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??
      VAR
        ignore_status: ost$status;

    clp$scan_parameter_list (parameter_list, deaa_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF alarm_task.task_status.complete THEN
      osp$set_status_condition ( nae$alarms_not_active,  status);
    ELSE
      pmp$terminate (alarm_task.task_id, status);
    IFEND;
    IF NOT alarm_output_task.task_status.complete THEN
      pmp$terminate (alarm_output_task.task_id, ignore_status);
    IFEND;
    output_lock := NIL;
    fsp$close_file (shared_segment_id, ignore_status);
    pmp$remove_queue (communication_queue_name, ignore_status);
    amp$return (shared_segment_name, ignore_status);

  PROCEND deactivate_alarms;

?? OLDTITLE ??
?? NEWTITLE := 'quit', EJECT ??

  PROCEDURE quit (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PURPOSE: This procedure is the command processor for the NETOU quit command.
{ DESIGN:  All asynchronous tasks are terminated, the command SAP is closed,
{          and the NETOU command utility is terminated.

{ PDT quit_pdt ()

?? PUSH (LISTEXT := ON) ??

  VAR
    quit_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??

    VAR
      ignore_status: ost$status;

    clp$scan_parameter_list (parameter_list, quit_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$end_include (utility_name, ignore_status);
    terminate_asynchronous_tasks;
    clp$close_display (output_control, ignore_status);
    clp$close_display (response_control, ignore_status);

  PROCEND quit;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'Function Processors' ??
?? NEWTITLE := 'normal_response_function', EJECT ??

  PROCEDURE normal_response_function (function_name: clt$name;
        argument_list: string ( * );
    VAR value: clt$value;
    VAR status: ost$status);

{ PURPOSE: This procedure processes the NETOU normal_response function.
{ DESIGN:  The parameter list is processed to determine if the response of
{          a specific system is requested. Response status is maintained
{          in an array referenced via a module level pointer variable.
{          Information saved in this array reflects the status of the last
{          command sent via the send_command command.

    VAR
      avt: array [1 .. 1] of clt$value,
      index: integer,
      normal_response_adt: [STATIC, READ, cls$adt] array [1 .. 1] of clt$argument_descriptor :=
        [[[clc$optional], [NIL, clc$name_value, 1, osc$max_name_size]]];

    clp$scan_argument_list (function_name, argument_list, ^normal_response_adt, ^avt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    value.descriptor := 'BOOLEAN';
    value.kind := clc$boolean_value;
    value.bool.kind := clc$true_false_boolean;

    IF response_list = NIL THEN
      osp$set_status_condition ( nae$no_command_sent,  status);

    ELSEIF avt [1].kind = clc$unknown_value THEN {status from all systems requested}
      value.bool.value := TRUE;
      index := LOWERBOUND (response_list^);
      WHILE value.bool.value AND (index <= UPPERBOUND (response_list^)) DO
        value.bool.value := response_list^ [index].received AND response_list^ [index].normal_response;
        index := index + 1;
      WHILEND;

    ELSE {status of specific system requested}

    /search_for_system/
      FOR index := LOWERBOUND (response_list^) TO UPPERBOUND (response_list^) DO
        IF avt [1].name.value = response_list^ [index].system THEN
          value.bool.value := response_list^ [index].received AND response_list^ [index].normal_response;
          RETURN;
        IFEND;
      FOREND /search_for_system/;
      osp$set_status_abnormal (nac$status_id, nae$command_not_sent_to_system, avt [1].name.value, status);
    IFEND;

  PROCEND normal_response_function;
?? OLDTITLE ??
?? NEWTITLE := 'response_identifier_function', EJECT ??

  PROCEDURE response_identifier_function (function_name: clt$name;
        argument_list: string ( * );
    VAR value: clt$value;
    VAR status: ost$status);

{ PURPOSE: This procedure processes the NETOU response_identifier function.
{ DESIGN:  The parameter list is processed to determine if the response of
{          a specific system is requested. Response status is maintained
{          in an array referenced via a module level pointer variable.
{          Information saved in this array reflects the status of the last
{          command sent via the send_command command.
    VAR
      avt: array [1 .. 1] of clt$value,
      index: integer,
      response_identifier_adt: [STATIC, READ, cls$adt] array [1 .. 1] of clt$argument_descriptor :=
        [[[clc$optional], [NIL, clc$name_value, 1, osc$max_name_size]]];


    clp$scan_argument_list (function_name, argument_list, ^response_identifier_adt, ^avt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    value.descriptor := 'INTEGER';
    value.kind := clc$integer_value;
    value.int.radix := 10;
    value.int.radix_specified := FALSE;

    IF response_list = NIL THEN
      osp$set_status_condition ( nae$no_command_sent,  status);

    ELSEIF avt [1].kind = clc$unknown_value THEN
      IF UPPERBOUND (response_list^) = 1 THEN
        value.int.value := response_list^ [1].code;
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$system_name_required, 'function $RESPONSE_IDENTIFIER',
              status);
      IFEND;

    ELSE {response of specific system requested}

    /search_for_system/
      FOR index := LOWERBOUND (response_list^) TO UPPERBOUND (response_list^) DO
        IF avt [1].name.value = response_list^ [index].system THEN
          IF response_list^ [index].received THEN
            value.int.value := response_list^ [index].code;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$response_not_received, avt [1].name.value, status);
          IFEND;
          RETURN;
        IFEND;
      FOREND /search_for_system/;
      osp$set_status_abnormal (nac$status_id, nae$command_not_sent_to_system, avt [1].name.value, status);
    IFEND;

  PROCEND response_identifier_function;
?? OLDTITLE ??
?? NEWTITLE := 'matching_names_function', EJECT ??

  PROCEDURE matching_names_function (function_name: clt$name;
        argument_list: string ( * );
    VAR value: clt$value;
    VAR status: ost$status);

{ PURPOSE: This procedure processes the NETOU matching_names function.
{ DESIGN:  A translation request is issued to the Directory for the requested
{          name pattern with the standard system label prefixed to it. All
{          translations received are built into an SCL array variable and
{          returned.

    VAR
      address: nat$osi_translation_address,
      avt: array [1 .. 1] of clt$value,
      identifier: nat$directory_entry_identifier,
      priority: nat$directory_priority,
      local_status: ost$status,
      request_id: nat$directory_search_identifier,
      search_domain: [STATIC] nat$title_domain := [nac$catenet_domain],
      service: nat$protocol,
      system_title: string (nac$system_title_size + nac$system_title_prefix_size),
      title: string (nac$max_title_length),
      title_count: integer,
      title_index: 0 .. nac$system_title_size,
      title_list: ^array [1 .. * ] of title_return_entry,
      user_identifier: ost$name,
      user_info_length: 0 .. nac$max_directory_data_length,
      variable_sequence: ^SEQ ( * ),
      working_sequence: ^SEQ ( * );

    VAR
      matching_names_adt: [STATIC, READ, cls$adt] array [1 .. 1] of clt$argument_descriptor :=
        [[[clc$optional], [NIL, clc$string_value, 1, osc$max_string_size]]];

    status.normal := TRUE;
    clp$scan_argument_list (function_name, argument_list, ^matching_names_adt, ^avt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    system_title := nac$system_title_prefix;
    system_title (nac$system_title_prefix_size + 1, * ) := avt [1].str.value (1, avt [1].str.size);
    nlp$translate_title (system_title, {wild card} TRUE, nac$unknown_protocol, {recurrent_search} FALSE,
          search_domain, nac$cdna_internal, request_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH working_sequence: [[REP max_address_count OF title_return_entry]];
    RESET working_sequence;
    title_count := 0;
    NEXT title_list: [1 .. max_address_count] IN working_sequence;
    IF title_list <> NIL THEN

    /check_title_translation/
      REPEAT
        local_status.normal := TRUE;
        nlp$get_title_translation (request_id, title, address, service, NIL, user_info_length, priority,
              user_identifier, identifier, local_status);
        IF local_status.normal THEN
          title_count := title_count + 1;
          title_list^ [title_count].value := title (nac$system_title_prefix_size + 1, * );
          title_index := nac$system_title_size;
          WHILE (title_index > 0) AND (title_list^ [title_count].value (title_index) = ' ') DO
            title_index := title_index - 1;
          WHILEND;
          title_list^ [title_count].size := title_index;
          CYCLE /check_title_translation/
        ELSEIF local_status.condition = nae$directory_search_complete THEN
          {search is done};
        ELSEIF local_status.condition = nae$no_translation_available THEN
          pmp$wait (translation_wait_time, translation_wait_time);
        ELSEIF local_status.condition <> nae$translation_req_not_active THEN {unexpected error - report it}
          status := local_status;
          RETURN;
        IFEND;
      UNTIL ((NOT local_status.normal) AND (local_status.condition = nae$translation_req_not_active)) OR
            (title_count = max_address_count);

      IF title_count = 0 THEN
        title_list^ [1].value := ' ';
        title_list^ [1].size := 0;
        title_count := 1;
      IFEND;

      RESET working_sequence;
      NEXT variable_sequence: [[REP title_count OF title_return_entry]] IN working_sequence;
      move_names_to_value (title_count, nac$system_title_size, value, variable_sequence, status);
    IFEND;
  PROCEND matching_names_function;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'Utility routines' ??
?? NEWTITLE := 'clear_output_lock', EJECT ??

  PROCEDURE clear_output_lock;

{ PURPOSE: This procedure clears a lock to restrict access to the output file if more than
{          one task is actively writing output.

    VAR
      actual: integer,
      result: osc$cs_successful .. osc$cs_variable_locked;

    IF output_lock <> NIL THEN
      REPEAT
        #compare_swap (output_lock^, locked, unlocked, actual, result);
      UNTIL result = osc$cs_successful;
    IFEND;

  PROCEND clear_output_lock;
?? OLDTITLE ??
?? NEWTITLE := 'display_message', EJECT ??

  PROCEDURE display_message (message_status: ost$status;
    VAR status: ost$status);

{ PURPOSE: Format and display a NOS/VE status condition.
{ DESIGN:  The message status is formatted with calls to system routines and written to
{          the $ERRORS file.

    VAR
      attachment_selections: [STATIC, READ] array [1 .. 1] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes,
            [fsc$shorten, fsc$append, fsc$modify]], * ]],
      byte_address: amt$file_byte_address,
      error_file_id: [STATIC] amt$file_identifier,
      error_file_name: [STATIC, READ] amt$local_file_name := '$ERRORS',
      error_file_opened: [STATIC] boolean := FALSE,
      ignore_status: ost$status,
      length_pointer: ^ost$status_message_line_size,
      line_count_pointer: ^ost$status_message_line_count,
      line_index: ost$status_message_line_count,
      message: ost$status_message,
      message_sequence: ^ost$status_message,
      text_pointer: ^ost$status_message_line;

    IF NOT error_file_opened THEN
      fsp$open_file (error_file_name, amc$record, ^attachment_selections,
            {default_creation_attributes =} NIL, {mandated_creation_attributes =} NIL,
            {attribute_validation =} NIL, {attribute_override =} NIL, error_file_id,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      error_file_opened := TRUE;
    IFEND;

    osp$format_message (message_status, osc$current_message_level, osc$max_status_message_line, message,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    message_sequence := ^message;
    RESET message_sequence;
    NEXT line_count_pointer IN message_sequence;

    FOR line_index := 1 TO line_count_pointer^ DO
      NEXT length_pointer IN message_sequence;
      NEXT text_pointer: [length_pointer^] IN message_sequence;
      amp$put_next (error_file_id, text_pointer, length_pointer^, byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;
    amp$flush (error_file_id, osc$wait, ignore_status);

  PROCEND display_message;

?? OLDTITLE ??
?? NEWTITLE := 'format_time_stamp', EJECT ??

  PROCEDURE format_time_stamp (time_stamp: nat$bcd_time;
    VAR formatted_date: ost$date;
    VAR formatted_time: ost$time);

{ PURPOSE: This procedure converts a BCD date and time into the default date/time format.

    VAR
      date_time: ost$date_time,
      ignore_status: ost$status;

    date_time.year := (time_stamp.date.year1 * 10) + time_stamp.date.year2;
    IF date_time.year < 80 THEN {allow for years 2000 to 2080}
      date_time.year := date_time.year + 100;
    IFEND;
    date_time.month := (time_stamp.date.month1 * 10) + time_stamp.date.month2;
    date_time.day := (time_stamp.date.day1 * 10) + time_stamp.date.day2;
    date_time.hour := (time_stamp.time.hours1 * 10) + time_stamp.time.hours2;
    date_time.minute := (time_stamp.time.minutes1 * 10) + time_stamp.time.minutes2;
    date_time.second := (time_stamp.time.seconds1 * 10) + time_stamp.time.seconds2;
    date_time.millisecond := (time_stamp.time.milliseconds1 * 100) + (time_stamp.time.milliseconds2 * 10) +
          time_stamp.time.milliseconds3;

    pmp$format_compact_date (date_time, osc$default_date, formatted_date, ignore_status);
    pmp$format_compact_time (date_time, osc$millisecond_time, formatted_time, ignore_status);

  PROCEND format_time_stamp;

?? OLDTITLE ??
?? NEWTITLE := 'generate_headers', EJECT ??

  PROCEDURE generate_headers (VAR display_control: {input,output} clt$display_control;
        page_number: integer;
    VAR status: ost$status);

{ PURPOSE: This procedure formats a page header for NETOU output.
{ DESIGN:  This procedure is called by the clp$display... routines when a page header
{          is needed. Note that this routine may be called in any of the tasks activated
{          by NETOU.

    CONST
      date_length = 18,
      os_version_length = 6,
      page_number_length = 5, {includes leading blank}
      product_name = 'NETWORK OPERATOR',
      product_name_length = 16,
      product_level_length = 5,
      product_version_length = 4,
      time_length = 12,

      long_os_version_start = 48,
      long_product_name_start = 55,
      long_product_version_start = 56 + product_name_length,
      long_product_level_start = 61 + product_name_length,
      long_date_start = 91,
      long_time_start = 110,
      long_page_title_start = 123,
      long_page_number_start = 127, {includes leading blank}
      long_header_length = 132,

      short_date_start = 48,
      short_page_title_start = 70,
      short_page_number_start = 74, {includes leading blank}
      short_os_version_start = 1,
      short_product_name_start = 8,
      short_product_version_start = 9 + product_name_length,
      short_product_level_start = 14 + product_name_length,
      short_time_start = 48,
      short_header_length = 80;

    VAR
      date: ost$date,
      date_line: 1 .. 2,
      date_start: 0 .. long_header_length,
      header: array [1 .. 2] of string (long_header_length),
      header_count: 1 .. 2,
      header_length: 0 .. long_header_length,
      j: integer,
      os_version: pmt$os_name,
      page_number_start: 0 .. long_header_length,
      str: string (10),
      time: ost$time,
      time_line: 1 .. 2,
      time_start: 0 .. long_header_length;

    pmp$get_legible_date_time (osc$default_date, date, osc$default_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$get_os_version (os_version, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    header [1] := ' ';
    header [2] := ' ';
    IF (display_control.page_width < long_header_length) THEN
      header_length := short_header_length;
      header_count := 2;
      page_number_start := short_page_number_start;
      header [2] (short_os_version_start, os_version_length) := os_version;
      date_line := 1;
      date_start := short_date_start;
      time_line := 2;
      time_start := short_time_start;
      header [2] (short_product_name_start, product_name_length) := product_name;
      header [2] (short_product_version_start, product_version_length) := nac$operator_utility_version;
      header [2] (short_product_level_start, product_level_length) := nac$operator_utility_level;
      header [1] (short_page_title_start, 4) := 'PAGE';
    ELSE
      header_length := long_header_length;
      header_count := 1;
      page_number_start := long_page_number_start;
      header [1] (long_os_version_start, os_version_length) := os_version;
      date_line := 1;
      date_start := long_date_start;
      time_line := 1;
      time_start := long_time_start;
      header [1] (long_product_name_start, product_name_length) := product_name;
      header [1] (long_product_version_start, product_version_length) := nac$operator_utility_version;
      header [1] (long_product_level_start, product_level_length) := nac$operator_utility_level;
      header [1] (long_page_title_start, 4) := 'PAGE';
    IFEND;

    CASE date.date_format OF
    = osc$month_date =
      header [date_line] (date_start, date_length) := date.month;

    = osc$mdy_date =
      header [date_line] (date_start, date_length) := date.mdy;

    = osc$iso_date =
      header [date_line] (date_start, date_length) := date.iso;

    = osc$dmy_date =
      header [date_line] (date_start, date_length) := date.dmy;

    ELSE
    CASEND;

    CASE time.time_format OF
    = osc$ampm_time =
      header [time_line] (time_start, time_length) := time.ampm;

    = osc$hms_time =
      header [time_line] (time_start, time_length) := time.hms;

    = osc$millisecond_time =
      header [time_line] (time_start, time_length) := time.millisecond;

    ELSE
    CASEND;
    clp$reset_for_next_display_page (display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (str, j, page_number);
    header [1] (page_number_start, j) := str (1, j);

    FOR j := 1 TO header_count DO
      clp$put_display (display_control, header [j] (1, header_length), clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND generate_headers;

?? OLDTITLE ??
?? NEWTITLE := 'move_names_to_value', EJECT ??

  PROCEDURE move_names_to_value (name_count: integer;
        name_length: ost$string_size;
    VAR value: clt$value;
    VAR variable_sequence: ^SEQ ( * );
    VAR status: ost$status);

{ PURPOSE: This routine stores an array of strings in an SCL variable.

    VAR
      string_value: ^array [1 .. * ] of cell,
      unique_name: ost$name,
      variable: clt$variable_reference,
      variable_dimension: integer,
      variable_scope: [STATIC, READ] clt$variable_scope := [clc$local_variable];

    pmp$get_unique_name (unique_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    unique_name (1) := '#';

    IF name_count <= 0 THEN
      variable_dimension := 1;
    ELSE
      variable_dimension := name_count;
    IFEND;

    clp$create_variable (unique_name, clc$string_value, name_length, 1, variable_dimension,
          variable_scope, variable, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    value.descriptor := 'VARIABLE';
    value.kind := clc$variable_reference;
    value.var_ref := variable;

    RESET variable_sequence;
    NEXT string_value: [1 .. #SIZE (variable_sequence^)] IN variable_sequence;
    variable.value.string_value := string_value;
    clp$write_variable (unique_name, variable.value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$read_variable (unique_name, value.var_ref, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND move_names_to_value;
?? OLDTITLE ??
?? NEWTITLE := 'set_output_lock', EJECT ??

  PROCEDURE set_output_lock;

{ PURPOSE: This procedure sets a lock to restrict access to the output file if more than
{          one task is actively writing output.

    VAR
      actual: integer,
      result: osc$cs_successful .. osc$cs_variable_locked;

    IF output_lock <> NIL THEN
      REPEAT
        #compare_swap (output_lock^, unlocked, locked, actual, result);
        IF result = osc$cs_failed THEN
          pmp$wait (1000, 1000);
        IFEND;
      UNTIL result = osc$cs_successful;
    IFEND;

  PROCEND set_output_lock;
?? OLDTITLE ??
?? NEWTITLE := 'terminate_asynchronous_tasks', EJECT ??

  PROCEDURE terminate_asynchronous_tasks;

{ PURPOSE: This procedure terminates an active alarm task.

    VAR
      ignore_status: ost$status;

    IF NOT alarm_task.task_status.complete THEN
      pmp$terminate (alarm_task.task_id, ignore_status);
    IFEND;
    IF NOT alarm_output_task.task_status.complete THEN
      pmp$terminate (alarm_output_task.task_id, ignore_status);
    IFEND;
    fsp$close_file (shared_segment_id, ignore_status);
    pmp$remove_queue (communication_queue_name, ignore_status);
    amp$return (shared_segment_name, ignore_status);

  PROCEND terminate_asynchronous_tasks;
?? OLDTITLE ??
MODEND nam$network_operator_utility;
*DECK DECK=NAM$NETWORK_PROCEDURES EXPAND=TRUE
MODULE nam$network_procedures;
*copyc osd$default_pragmats
*copyc nap$cn_deliver_datagram
*copyc nap$deliver_network_event
*copyc nap$gt_evaluate_connect_timers
*copyc nap$gt_evaluate_sap_timers
*copyc nap$gt_process_connection_event
*copyc nap$gt_process_sap_event
*copyc nap$monitor_server_connections
*copyc nap$se_evaluate_io_timers
*copyc nap$se_process_connection_event
*copyc nap$se_process_sap_event
*copyc nlp$sk_tcp_conn_event_processor
*copyc nlp$sk_tcp_event_processor
*copyc nlp$cc_monitor_timers
*copyc nlp$la_connect_event_processor
*copyc nlp$la_event_processor
*copyc nlp$la_retry_constrained_saps
*copyc nlp$na_connect_event_processor
*copyc nlp$na_event_processor
*copyc nlp$na_retry_constrained_saps
*copyc nlp$sl_clear_request_timer
*copyc nlp$sl_connect_event_processor
*copyc nlp$sl_sap_event_processor
*copyc nlp$sm_connect_event_processor
*copyc nlp$sm_event_processor
*copyc nlp$ta_connect_event_processor
*copyc nlp$ta_event_processor
*copyc nlp$tcp_connect_event_processor
*copyc nlp$tcp_event_processor
*copyc nlp$tcp_flush_release_timer
*copyc nlp$tm_connect_event_processor
*copyc nlp$tm_event_processor
*copyc nlp$udp_connect_event_processor
*copyc nlp$udp_event_processor

  PROCEDURE [XREF] cyp$nil;

  VAR
    nav$network_procedures: [XDCL, READ, oss$job_paged_literal] array [nat$network_procedure] of
          nat$network_procedures := [
          [nac$monitor_server_connections, ^nap$monitor_server_connections],                 { 0}
          [nac$cn_deliver_datagram, ^nap$cn_deliver_datagram],                               { 1}
          [nac$gt_evaluate_sap_timers, ^nap$gt_evaluate_sap_timers],                         { 2}
          [nac$gt_evaluate_connect_timers, ^nap$gt_evaluate_connect_timers],                 { 3}
          [nac$nil, ^cyp$nil],                                                               { 4}
          [nac$nil, ^cyp$nil],                                                               { 5}
          [nac$nil, ^cyp$nil], { XNS stack no longer supported (nlp$receive_channelnet_data)}{ 6}
          [nac$nil, ^cyp$nil],                                                               { 7}
          [nac$se_process_sap_event, ^nap$se_process_sap_event],                             { 8}
          [nac$se_process_connection_event, ^nap$se_process_connection_event],               { 9}
          [nac$nil, ^cyp$nil],                                                               {10}
          [nac$nil, ^cyp$nil],                                                               {11}
          [nlc$sl_clear_request_timer, ^nlp$sl_clear_request_timer],                         {12}
          [nac$nil, ^cyp$nil],                                                               {13}
          [nac$nil, ^cyp$nil],                                                               {14}
          [nac$nil, ^cyp$nil],                                                               {15}
          [nac$nil, ^cyp$nil],                                                               {16}
          [nac$se_evaluate_io_timers, ^nap$se_evaluate_io_timers],                           {17}
          [nac$nil, ^cyp$nil],                                                               {18}
          [nlc$ta_connect_event_processor, ^nlp$ta_connect_event_processor],                 {19}
          [nlc$ta_event_processor, ^nlp$ta_event_processor],                                 {20}
          [nac$osi_gt_process_sap_event, ^nap$gt_process_sap_event],                         {21}
          [nac$osi_gt_process_conn_event, ^nap$gt_process_connection_event],                 {22}
          [nlc$sm_connect_event_processor, ^nlp$sm_connect_event_processor],                 {23}
          [nlc$sm_event_processor, ^nlp$sm_event_processor],                                 {24}
          [nlc$cc_monitor_timers, ^nlp$cc_monitor_timers],                                   {25}
          [nlc$osi_sl_sap_event_processor, ^nlp$sl_sap_event_processor],                     {26}
          [nlc$osi_sl_conn_event_processor, ^nlp$sl_connect_event_processor],                {27}
          [nlc$na_connect_event_processor, ^nlp$na_connect_event_processor],                 {28}
          [nlc$na_event_processor, ^nlp$na_event_processor],                                 {29}
          [nlc$na_retry_constrained_saps, ^nlp$na_retry_constrained_saps],                   {30}
          [nac$deliver_network_event, ^nap$deliver_network_event],                           {31}
          [nac$nil, ^cyp$nil],                                                               {32}
          [nlc$la_connect_event_processor, ^nlp$la_connect_event_processor],                 {33}
          [nlc$la_event_processor, ^nlp$la_event_processor],                                 {34}
          [nlc$la_retry_constrained_saps, ^nlp$la_retry_constrained_saps],                   {35}
          [nlc$tm_connect_event_processor, ^nlp$tm_connect_event_processor],                 {36}
          [nlc$tm_event_processor, ^nlp$tm_event_processor],                                 {37}
          [nlc$tcp_connect_event_processor, ^nlp$tcp_connect_event_processor],               {38}
          [nlc$tcp_event_processor, ^nlp$tcp_event_processor],                               {39}
          [nlc$sk_tcp_conn_event_processor, ^nlp$sk_tcp_conn_event_processor],               {40}
          [nlc$sk_tcp_event_processor, ^nlp$sk_tcp_event_processor],                         {41}
          [nlc$udp_connect_event_processor, ^nlp$udp_connect_event_processor],               {42}
          [nlc$udp_event_processor, ^nlp$udp_event_processor],                               {43}
          [nlc$tcp_flush_release_timer, ^nlp$tcp_flush_release_timer],                       {44}
          [nac$nil, ^cyp$nil],
          [nac$nil, ^cyp$nil],
          [nac$nil, ^cyp$nil],
          [nac$nil, ^cyp$nil],
          [nac$nil, ^cyp$nil],
          [nac$nil, ^cyp$nil],
          [nac$nil, ^cyp$nil],
          [nac$nil, ^cyp$nil],
          [nac$nil, ^cyp$nil],
          [nac$nil, ^cyp$nil],
          REP 201 OF [nac$nil, ^cyp$nil]];

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_procedures
*copyc nat$system_address
*copyc nlt$cl_connection
*copyc nat$data_length
*copyc nat$internet_address
*copyc nlt$user_interface
*copyc nlt$bm_message_id
*copyc nlt$sl_event
*copyc nlt$cl_connection
*copyc nat$cn_interface
*copyc nat$data_length
*copyc nlt$bm_message_id
*copyc oss$job_paged_literal
?? POP ??
MODEND
*DECK DECK=NAM$OPEN_DI_DUMP_FILE EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
MODULE nam$open_di_dump_file;
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$file_attributes
*copyc amt$local_file_name
*copyc amt$segment_pointer
*copyc mmt$attribute_keyword
*copyc nac$network_management_catalog
*copyc nae$file_access_me_conditions
*copyc nat$network_address
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$return
*copyc fsp$close_file
*copyc fsp$open_file
*copyc mmp$set_access_selections
*copyc nap$get_catalog_file_count
*copyc osp$set_status_abnormal
*copyc pfp$convert_pf_path_to_fs_path
*copyc pfp$define
*copyc pfp$define_catalog
*copyc pmp$log

  CONST
    dump_catalog_label = 'SYSTEM_',
    dump_catalog_label_size = 7,
    dump_file_label = '    _',
    dump_file_label_size = 5;

?? TITLE := '[XDCL] nap$open_di_dump_file', EJECT ??

  PROCEDURE [XDCL] nap$open_di_dump_file (system: string (12);
        timestamp: string (12);
        dump_type: string (4);
        max_dumps: 0 .. 1000;
        max_dump_size: 0 .. 100000000;
    VAR dump_file_id: amt$file_identifier;
    VAR dump_data: ^SEQ ( * );
    VAR dump_file_opened: boolean;
    VAR status: ost$status);

{ PURPOSE: This procedure creates and opens a dump file in the network dump
{          catalog.
{
{ DESIGN:  The dump file is created as a segment access file and is accessed
{          as a sequence. The dump file name is created in the form
{          'xxxx_yymmddhhmmss.SYSTEM_ssssssssssss' where ssssssssssss is the device
{          interface's system address, yymmddhhmmss is the year, month, day,
{          hour, minute, and second at the start of the dump and xxxx is 'FULL'
{          or 'PART'.
{          It is the responsibility of the calling program to close and return
{          the dump file.

    VAR
      attachment_selections: [STATIC, READ] array [1 .. 3] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$append]], * ],
            [fsc$sequential_access, TRUE], [fsc$free_behind, TRUE]],
      dump_catalog: [STATIC] array [1 .. 4] of pft$name := [nac$management_family,
        nac$management_master_catalog, nac$cdcnet_subcatalog, nac$dump_catalog],
      dump_catalog_name: amt$local_file_name,
      dump_file: [STATIC] array [1 .. 6] of pft$name := [nac$management_family, nac$management_master_catalog,
        nac$cdcnet_subcatalog, nac$dump_catalog, * , * ],
      dump_file_name: amt$local_file_name,
      dump_file_pointer: amt$segment_pointer,
      files: 0 .. 7fffffff(16),
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      highest_cycle: [STATIC, READ] pft$cycle_selector := [pfc$highest_cycle],
      local_status: ost$status,
      mandated_creation_attributes: array [1..1] of fst$file_cycle_attribute,
      password: [STATIC, READ] pft$password := ' ',
      retention_period: [STATIC, READ] pft$retention := pfc$maximum_retention,
      system_dump_catalog: [STATIC] array [1 .. 5] of pft$name := [nac$management_family,
        nac$management_master_catalog, nac$cdcnet_subcatalog, nac$dump_catalog, * ];

    status.normal := TRUE;
    dump_file_opened := FALSE;
    dump_catalog_name := dump_catalog_label;
    dump_catalog_name (dump_catalog_label_size + 1, * ) := system;
    dump_file_name := dump_file_label;
    dump_file_name (1, #SIZE (dump_type)) := dump_type;
    dump_file_name (dump_file_label_size + 1, * ) := timestamp;

    system_dump_catalog [UPPERBOUND (system_dump_catalog)] := dump_catalog_name;
    dump_file [UPPERBOUND (dump_file) - 1] := dump_catalog_name;
    dump_file [UPPERBOUND (dump_file)] := dump_file_name;
    dump_file_name (dump_file_label_size + 1 + #SIZE (timestamp), * ) := system;
    mandated_creation_attributes[1].selector := fsc$ring_attributes;
    mandated_creation_attributes[1].ring_attributes.r1 := 11;
    mandated_creation_attributes[1].ring_attributes.r2 := 11;
    mandated_creation_attributes[1].ring_attributes.r3 := 11;

    pfp$define_catalog (dump_catalog, status);
    IF NOT status.normal AND (status.condition <> pfe$name_already_subcatalog) THEN
      pmp$log ('pf define catalog failed - dump', local_status);
      RETURN;
    IFEND;
    status.normal := TRUE;
    pfp$define_catalog (system_dump_catalog, status);
    IF NOT status.normal AND (status.condition <> pfe$name_already_subcatalog) THEN
      pmp$log ('pf define catalog failed - system dump subcatalog', local_status);
      RETURN;
    IFEND;
    status.normal := TRUE;
    nap$get_catalog_file_count (system_dump_catalog, files, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF files >= max_dumps THEN
      pfp$convert_pf_path_to_fs_path (system_dump_catalog, fs_path, fs_path_size);
      osp$set_status_abnormal (nac$status_id, nae$max_files_reached, fs_path (1, fs_path_size), status);
      RETURN;
    IFEND;

    pfp$define (dump_file_name, dump_file, highest_cycle, password, retention_period, pfc$no_log, status);
    IF NOT status.normal THEN
      pmp$log ('pf define failed - dump', local_status);
      RETURN;
    IFEND;

    fsp$open_file (dump_file_name, amc$segment, ^attachment_selections, {default_creation_attributes =} NIL,
          ^mandated_creation_attributes, {attribute_validation =} NIL, {attribute_override =} NIL,
          dump_file_id, status);
    IF NOT status.normal THEN
      pmp$log ('open failed - dump', local_status);
      amp$return (dump_file_name, local_status);
      RETURN;
    IFEND;
    amp$get_segment_pointer (dump_file_id, amc$sequence_pointer, dump_file_pointer, status);
    IF NOT status.normal THEN
      pmp$log ('segment access failed - dump', local_status);
      fsp$close_file (dump_file_id, local_status);
      amp$return (dump_file_name, local_status);
      RETURN;
    IFEND;
    RESET dump_file_pointer.sequence_pointer;
    NEXT dump_data: [[REP max_dump_size OF cell]] IN dump_file_pointer.sequence_pointer;
    mmp$set_access_selections (dump_data, mmc$as_sequential, status);
    IF NOT status.normal THEN
      pmp$log ('sequential access failed - dump', local_status);
      fsp$close_file (dump_file_id, local_status);
      amp$return (dump_file_name, local_status);
      RETURN;
    IFEND;
    dump_file_opened := TRUE;
  PROCEND nap$open_di_dump_file;
MODEND nam$open_di_dump_file;
*DECK DECK=NAM$OPEN_DI_LOAD_FILE EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
MODULE nam$open_di_load_file;
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$file_attributes
*copyc amt$local_file_name
*copyc amt$segment_pointer
*copyc nat$object_code_version
*copyc nac$network_management_catalog
*copyc pfd$permanent_file_definitions
*copyc llt$transfer_symbol
*copyc llt$load_module
?? POP ??
*copyc nae$file_access_me_conditions
*copyc amp$get_segment_pointer
*copyc amp$return
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pfp$attach
*copyc pmp$close_object_library
*copyc pmp$continue_to_cause
*copyc pmp$establish_condition_handler
*copyc pmp$disestablish_cond_handler
*copyc pmp$find_module_in_library
*copyc pmp$get_unique_name
*copyc pmp$open_object_library

?? TITLE := 'condition_handler', EJECT ??

  PROCEDURE [XDCL] nap$open_di_load_file (object_code_version: nat$object_code_version_string;
        boot_card: nat$card_type;
    VAR load_file_id: amt$file_identifier;
    VAR load_data: ^SEQ ( * );
    VAR load_file_opened: boolean;
    VAR status: ost$status);


    PROCEDURE condition_handler (
          condition: pmt$condition;
          condition_descriptor: ^pmt$condition_information;
          stack_frame_save_area_pointer: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status );

      VAR
        ignore_status: ost$status;

      IF condition.selector = mmc$segment_access_condition THEN
        osp$set_status_from_condition ('NA', condition,
              stack_frame_save_area_pointer, status, ignore_status);
        pmp$close_object_library (library_file_id, ignore_status);
        amp$return (library_name, ignore_status);
        fsp$close_file (load_file_id, local_status);
        amp$return (name, local_status);
        EXIT nap$open_di_load_file;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

  PROCEND condition_handler;


?? TITLE := '[XDCL] nap$open_di_load_file', EJECT ??

{ PURPOSE: This procedure returns a device interface boot file for a specified
{          software version and boot card. The load file is returned as a
{          pointer to sequence.
{
{ DESIGN:  The boot file is constructed from the module list associated with
{          the program description with a name of the form
{          'BOOT_cccc' where cccc is the boot card type of MPB, HDLC, ESCI, or MCI.
{          The program description is found in the network object catalog with
{          a catalog name of the form 'VERSION_vvvv' where vvvv is the hexadecimal
{          version number under file name of 'DI_OBJECT'.
{
{          It is the responsibility of the calling program to close and return
{          the load file.

    CONST
      load_and_transfer_addr_length = 8;

    VAR
      boot_file_selections: [STATIC, READ] array [1 .. 3] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes,
            [fsc$read, fsc$shorten, fsc$append]], * ], [fsc$sequential_access, TRUE],
            [fsc$free_behind, TRUE]],
      data_block: ^SEQ ( * ),
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler,
      file_size: 0 .. 0ffffffff(16),
      highest_cycle: [STATIC, READ] pft$cycle_selector := [pfc$highest_cycle],
      index: pmt$number_of_modules,
      library: ^SEQ ( * ),
      library_file_id: amt$file_identifier,
      load_library: [STATIC] array [1 .. 5] of pft$name := [nac$management_family,
        nac$management_master_catalog, nac$cdcnet_subcatalog, *, nac$di_object_library ],
      library_name: ost$name,
      load_file_pointer: amt$segment_pointer,
      local_status: ost$status,
      module_address: pmt$object_library_address,
      module_data: ^SEQ ( * ),
      module_list: ^array [1 .. * ] of pmt$program_name,
      name: ost$name,
      object_file_list: ^llt$object_file_list,
      password: [STATIC, READ] pft$password := ' ',
      program_attributes: ^llt$program_attributes,
      program_description: ^SEQ ( * ),
      program_description_address: pmt$object_library_address,
      program_description_name: pmt$program_name,
      segment_file: ^SEQ ( * ),
      share_selections: [STATIC, READ] pft$share_selections := [pfc$read],
      usage_selections: [STATIC, READ] pft$usage_selections := [pfc$read],
      version_catalog_name: pft$name;

    established_conditions.selector := pmc$all_conditions;
    pmp$establish_condition_handler (established_conditions,
          ^condition_handler, ^established_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    status.normal := TRUE;
    load_file_opened := FALSE;
    file_size := 0;
    version_catalog_name := nac$version_subcatalog;
    version_catalog_name (9,4) := object_code_version;
    program_description_name := 'BOOT';

    CASE boot_card OF
    = nac$ica2_boot_card =
      program_description_name (5, 4) := '_ICA';
    = nac$cim_boot_card =
      program_description_name (5, 5) := '_HDLC';
    = nac$esci_boot_card =
      program_description_name (5, 5) := '_ESCI';
    = nac$mci_boot_card =
      program_description_name (5, 4) := '_MCI';
    ELSE
    CASEND;
    load_library [UPPERBOUND (load_library) - 1] := version_catalog_name;
    pmp$get_unique_name (library_name, status);
    pfp$attach (library_name, load_library, highest_cycle, password, usage_selections, share_selections,
          pfc$no_wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$open_object_library (library_name, library_file_id, library, status);
    IF NOT status.normal THEN
      amp$return (library_name, local_status);
      RETURN;
    IFEND;

    pmp$find_module_in_library (program_description_name, library, program_description_address, status);
    IF NOT status.normal THEN
      pmp$close_object_library (library_file_id, local_status);
      amp$return (library_name, local_status);
      RETURN;
    IFEND;

    IF program_description_address.kind <> llc$program_description THEN
      pmp$close_object_library (library_file_id, local_status);
      amp$return (library_name, local_status);
      osp$set_status_abnormal (nac$status_id, nae$module_not_program_desc, program_description_name, status);
      RETURN;
    IFEND;

    pmp$get_unique_name (name, status);
    fsp$open_file (name, amc$segment, ^boot_file_selections, {default_creation_attributes =} NIL,
          {mandated_creation_attributes =} NIL, {attribute_validation =} NIL, {attribute_override =} NIL,
          load_file_id, status);
    IF NOT status.normal THEN
      pmp$close_object_library (library_file_id, local_status);
      amp$return (library_name, local_status);
      RETURN;
    IFEND;

    amp$get_segment_pointer (load_file_id, amc$sequence_pointer, load_file_pointer, status);
    IF NOT status.normal THEN
      pmp$close_object_library (library_file_id, local_status);
      amp$return (library_name, local_status);
      fsp$close_file (load_file_id, local_status);
      amp$return (name, local_status);
      RETURN;
    IFEND;
    segment_file := load_file_pointer.sequence_pointer;
    RESET segment_file;

    program_description := program_description_address.program_description;
    NEXT program_attributes IN program_description;
    IF pmc$object_file_list_specified IN program_attributes^.contents THEN
      NEXT object_file_list: [1 .. program_attributes^.number_of_object_files] IN program_description;
    IFEND;

    IF pmc$module_list_specified IN program_attributes^.contents THEN
      NEXT module_list: [1 .. program_attributes^.number_of_modules] IN program_description;

    /forloop/
      FOR index := 1 TO program_attributes^.number_of_modules DO
        pmp$find_module_in_library (module_list^ [index], library, module_address, status);
        IF NOT status.normal THEN
          EXIT /forloop/;
        IFEND;
        IF module_address.kind <> llc$load_module THEN
          osp$set_status_abnormal (nac$status_id, nae$module_not_a_load_module, module_list^ [index], status);
          EXIT /forloop/;
        IFEND;
          NEXT module_data: [[REP #SIZE (module_address.load_module^) OF cell]] IN module_address.load_module;
          NEXT data_block: [[REP #SIZE (module_address.load_module^) OF cell]] IN segment_file;
          file_size := file_size + #SIZE (module_address.load_module^);
          IF data_block = NIL THEN
            osp$set_status_abnormal (nac$status_id, nae$write_beyond_file_limit, '', status);
            EXIT /forloop/;
          IFEND;
        data_block^ := module_data^;
      FOREND /forloop/;

    IFEND;
    RESET segment_file;
    NEXT load_data: [[REP file_size OF cell]] IN segment_file;

    load_file_opened := status.normal;

    IF NOT load_file_opened THEN
      fsp$close_file (load_file_id, local_status);
      amp$return (name, local_status);
    IFEND;

    pmp$close_object_library (library_file_id, local_status);
    amp$return (library_name, local_status);

    pmp$disestablish_cond_handler (established_conditions, status);

  PROCEND nap$open_di_load_file;
MODEND nam$open_di_load_file;
*DECK DECK=NAM$PARSE_ACCOUNTING_DATA EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NAM/VE: Accounting Data Parser' ??
MODULE nam$parse_accounting_data;

{ PURPOSE:
{   This module contains the interface used to parse the peer_accounting_information
{   and peer_connect_data network file attributes for communication accounting statistics.
{
{ DESIGN:
{   Procedures in this module may run in rings 2 through 13 with a call bracket of
{   ring 13.  Communication equipment identification is passed in as an input parameter
{   which may be from the network connection or the job_input_device job attribute and
{   requested fields are returned.  Since the format of the accounting data is dependent
{   on CDCNET, the design is flexible so that changes may be made to support upcoming
{   CDCNET changes without becoming dependent on a certain CDCNET build level.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$max_string_size
*copyc fst$file_reference
*copyc jmt$service_data
*copyc nae$application_interfaces
*copyc nat$accounting_data_fields
*copyc nat$data_length
*copyc oss$job_paged_literal
*copyc ost$name
?? POP ??
*copyc osp$append_status_integer
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

{ The following accounting and user data record formats were obtained from a CDCNET
{ document titled  Session Call Data Formats, DCS# ARH7243.

  CONST
    connect_data_length_position = 115,
    current_accounting_version = 1,
    ci_cdcnet_interactive_tip = 1,
    ci_cdcnet_paired_connection = 129,
    ci_cdcnet_batch_tip = 2,
    ci_cdcnet_aa_gateway = 64,
    ai_non_x25_device = 1,
    ai_x25_device = 2,
    ai_telnet_device = 3,
    ai_non_x25_aa = 64,
    ai_x25_aa = 65;

  CONST
    batch_user_data_version = 1;

  TYPE
    accounting_record_version = 0 .. 0ffff(16),
    accounting_caller_id = 0 .. 0ff(16),
    accounting_identifier = 0 .. 0ff(16),
    user_data_record_version = 0 .. 0ff(16);

  TYPE
    element_field = record
      index: 1 .. clc$max_string_size,
      size: 1 .. clc$max_string_size,
      last_character: 1 .. clc$max_string_size,
    recend;

  TYPE
    accounting_record_header = record
      version: element_field,
      caller_id: element_field,
      accounting_id: element_field,
    recend;

  TYPE
    non_x25_batch_record = record
      device_name: element_field,
      line_speed: element_field,
      line_name: element_field,
      line_subtype: element_field,
      di_system_name: element_field,
    recend;

  TYPE
    non_x25_batch_user_data_record = record
      version: element_field,
      i_o_station_name: element_field,
    recend;

  TYPE
    non_x25_interactive_record = record
      device_name: element_field,
      line_speed: element_field,
      line_name: element_field,
      line_subtype: element_field,
      di_system_name: element_field,
    recend;

  TYPE
    telnet_interactive_record = record
      device_name: element_field,
      di_system_name: element_field,
    recend;

  TYPE
    x25_aa_gateway_record = record
      trunk_name: element_field,
      pdn_name: element_field,
    recend;

  TYPE
    x25_interactive_record = record
      device_name: element_field,
      line_speed: element_field,
      trunk_name: element_field,
      trunk_subtype: element_field,
      pdn_name: element_field,
      di_system_name: element_field,
    recend;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$get_connect_data', EJECT ??
  PROCEDURE [XDCL, #GATE] nap$get_connect_data
    (peer_connect_data: ^SEQ (*);
     VAR connect_data: jmt$service_data;
     VAR connect_data_length: jmt$service_data_length;
     VAR status: ost$status);

    VAR
      connect_string: ^string (*),
      p_connect_data_seq: ^SEQ (*),
      peer_connect_info_length: nat$data_length;

    connect_data_length := 0;
    status.normal := TRUE;

    IF peer_connect_data <> NIL THEN
      peer_connect_info_length := #SIZE (peer_connect_data^);
      p_connect_data_seq := peer_connect_data;
      RESET p_connect_data_seq;
      NEXT connect_string: [peer_connect_info_length] IN p_connect_data_seq;
    ELSE
      RETURN;
    IFEND;

    IF peer_connect_info_length > 1 THEN
      IF ORD (connect_string^ (1)) = 1 THEN
        connect_data_length := ORD (connect_string^ (connect_data_length_position));
        IF connect_data_length > 0 THEN
          connect_data := connect_string^ (connect_data_length_position + 1, connect_data_length);
        IFEND;
      ELSE
        {Wrong version of connect data!
        osp$set_status_abnormal (nac$status_id, nae$acct_version_mismatch, 'User Data Record', status);
      IFEND;
    IFEND;

  PROCEND nap$get_connect_data;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$parse_accounting_data', EJECT ??
*copyc nah$parse_accounting_data

  PROCEDURE [XDCL, #GATE] nap$parse_accounting_data
    (    peer_accounting_information: ^string ( * );
         peer_connect_data: ^string ( * );
         accounting_data_fields {input, output} : ^nat$accounting_data_fields;
     VAR status: ost$status);


?? EJECT ??
?? FMT (FORMAT := OFF) ??

    VAR
      accounting_header: [STATIC, READ, oss$job_paged_literal] accounting_record_header := [
{                                      index |  size | last_character
{ version                         }  [    1,      2,      2],
{ caller_id                       }  [    3,      1,      3],
{ accounting_id                   }  [    4,      1,      4]],

      non_x25_batch: [STATIC, READ, oss$job_paged_literal] non_x25_batch_record := [
{                                      index |  size | last_character
{ device_name                     }  [   79,     31,    109],
{ line_speed                      }  [  113,      2,    114],
{ line_name                       }  [  115,     31,    145],
{ line_subtype                    }  [  146,     31,    176],
{ di_system_name                  }  [  182,     31,    212]],

      non_x25_batch_user_data: [STATIC, READ, oss$job_paged_literal] non_x25_batch_user_data_record := [
{ version                         }  [    1,      1,      1],
{ i_o_station_name                }  [    2,     31,     32]],

      non_x25_interactive: [STATIC, READ, oss$job_paged_literal] non_x25_interactive_record := [
{                                      index |  size | last_character
{ device_name                     }  [   79,     31,    109],
{ line_speed                      }  [  113,      2,    114],
{ line_name                       }  [  115,     31,    145],
{ line_subtype                    }  [  146,     31,    176],
{ di_system_name                  }  [  182,     31,    212]],

      telnet_interactive: [STATIC, READ, oss$job_paged_literal] telnet_interactive_record := [
{                                      index |  size | last_character
{ device_name                     }  [   79,     31,    109],
{ di_system_name                  }  [  125,     31,    155]],

      x25_aa_gateway: [STATIC, READ, oss$job_paged_literal] x25_aa_gateway_record := [
{ trunk_name                      }  [   70,     31,    100],
{ pdn_name                        }  [  101,     31,    131]],

      x25_interactive: [STATIC, READ, oss$job_paged_literal] x25_interactive_record := [
{                                      index |  size | last_character
{ device_name                     }  [   79,     31,    109],
{ line_speed                      }  [  113,      2,    114],
{ trunk_name                      }  [  115,     31,    145],
{ trunk_subtype                   }  [  146,     31,    176],
{ pdn_name                        }  [  146,     31,    176],
{ di_system_name                  }  [  211,     31,    241]];

?? FMT (FORMAT := ON) ??
?? EJECT ??

    VAR
      accounting_id: accounting_identifier,
      caller_id: accounting_caller_id,
      index: nat$accounting_data_kind,
      int: integer,
      local_status: ost$status,
      peer_accounting_info_length: nat$data_length,
      user_data_version: user_data_record_version,
      version: accounting_record_version;

    status.normal := TRUE;
    local_status.normal := TRUE;

    IF peer_accounting_information <> NIL THEN
      peer_accounting_info_length := STRLENGTH (peer_accounting_information^);
    ELSE
      peer_accounting_info_length := 0;
    IFEND;

{ Get the accounting version, caller id and accounting id from the accounting header.

    IF accounting_header.accounting_id.last_character <= peer_accounting_info_length THEN
      #UNCHECKED_CONVERSION (peer_accounting_information^ (accounting_header.version.index,
            accounting_header.version.size), version);

      #UNCHECKED_CONVERSION (peer_accounting_information^ (accounting_header.caller_id.index,
            accounting_header.caller_id.size), caller_id);

      #UNCHECKED_CONVERSION (peer_accounting_information^ (accounting_header.accounting_id.index,
            accounting_header.accounting_id.size), accounting_id);

    ELSE
      FOR index := 1 TO UPPERBOUND (accounting_data_fields^) DO
        accounting_data_fields^ [index].kind := nac$ca_unavailable_information;
      FOREND;
      RETURN;

    IFEND;

{ IF the accounting version is not the current version, return.

    IF version <> current_accounting_version THEN
      osp$set_status_abnormal (nac$status_id, nae$acct_version_mismatch, 'Accounting Record', status);
      osp$append_status_integer (osc$status_parameter_delimiter, version, 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, current_accounting_version, 10, FALSE,
            status);
      RETURN;
    IFEND;

    IF ((caller_id = ci_cdcnet_interactive_tip) OR (caller_id = ci_cdcnet_paired_connection)) AND
          (accounting_id = ai_non_x25_device) THEN

{ Set the value of each element in accounting_data_fields for a non x.25 interactive TIP.

      FOR index := 1 TO UPPERBOUND (accounting_data_fields^) DO
        CASE accounting_data_fields^ [index].kind OF
        = nac$ca_device_name =
          set_string_data_field (peer_accounting_information^, non_x25_interactive.device_name,
                accounting_data_fields^ [index].kind, accounting_data_fields^ [index].device_name);

        = nac$ca_line_speed =
          set_integer_data_field (peer_accounting_information^, non_x25_interactive.line_speed,
                accounting_data_fields^ [index].kind, int);
          accounting_data_fields^ [index].line_speed := int;

        = nac$ca_line_name =
          set_string_data_field (peer_accounting_information^, non_x25_interactive.line_name,
                accounting_data_fields^ [index].kind, accounting_data_fields^ [index].line_name);

        = nac$ca_line_subtype =
          set_string_data_field (peer_accounting_information^, non_x25_interactive.line_subtype,
                accounting_data_fields^ [index].kind, accounting_data_fields^ [index].line_subtype);

        = nac$ca_di_system_name =
          set_string_data_field (peer_accounting_information^, non_x25_interactive.di_system_name,
                accounting_data_fields^ [index].kind, accounting_data_fields^ [index].di_system_name);

        = nac$ca_null_information =
          ;

        ELSE
          accounting_data_fields^ [index].kind := nac$ca_unavailable_information;

        CASEND;
      FOREND;

    ELSEIF ((caller_id = ci_cdcnet_interactive_tip) OR (caller_id = ci_cdcnet_paired_connection)) AND
          (accounting_id = ai_x25_device) THEN

{ Set the value of each element in accounting_data_fields for an x.25 interactive TIP.

      FOR index := 1 TO UPPERBOUND (accounting_data_fields^) DO
        CASE accounting_data_fields^ [index].kind OF
        = nac$ca_device_name =
          set_string_data_field (peer_accounting_information^, x25_interactive.device_name,
                accounting_data_fields^ [index].kind, accounting_data_fields^ [index].device_name);

        = nac$ca_line_speed =
          set_integer_data_field (peer_accounting_information^, x25_interactive.line_speed,
                accounting_data_fields^ [index].kind, int);
          accounting_data_fields^ [index].line_speed := int;

        = nac$ca_trunk_name =
          set_string_data_field (peer_accounting_information^, x25_interactive.trunk_name,
                accounting_data_fields^ [index].kind, accounting_data_fields^ [index].trunk_name);

        = nac$ca_trunk_subtype =
          set_string_data_field (peer_accounting_information^, x25_interactive.trunk_subtype,
                accounting_data_fields^ [index].kind, accounting_data_fields^ [index].trunk_subtype);

        = nac$ca_pdn_name =
          set_string_data_field (peer_accounting_information^, x25_interactive.pdn_name,
                accounting_data_fields^ [index].kind, accounting_data_fields^ [index].pdn_name);

        = nac$ca_di_system_name =
          set_x25_interact_di_system_name (peer_accounting_information^, x25_interactive.di_system_name,
                accounting_data_fields^ [index].kind, accounting_data_fields^ [index].di_system_name);

        = nac$ca_null_information =
          ;

        ELSE
          accounting_data_fields^ [index].kind := nac$ca_unavailable_information;

        CASEND;
      FOREND;

    ELSEIF ((caller_id = ci_cdcnet_interactive_tip) OR (caller_id = ci_cdcnet_paired_connection)) AND
          (accounting_id = ai_telnet_device) THEN

{ Set the value of each element in accounting_data_fields for a TELNET interactive TIP.

      FOR index := 1 TO UPPERBOUND (accounting_data_fields^) DO
        CASE accounting_data_fields^ [index].kind OF
        = nac$ca_device_name =
          set_string_data_field (peer_accounting_information^, telnet_interactive.device_name,
                accounting_data_fields^ [index].kind, accounting_data_fields^ [index].device_name);

        = nac$ca_di_system_name =
          set_string_data_field (peer_accounting_information^, telnet_interactive.di_system_name,
                accounting_data_fields^ [index].kind, accounting_data_fields^ [index].di_system_name);

        = nac$ca_null_information =
          ;

        ELSE
          accounting_data_fields^ [index].kind := nac$ca_unavailable_information;

        CASEND;
      FOREND;

    ELSEIF (caller_id = ci_cdcnet_batch_tip) AND (accounting_id = ai_non_x25_device) THEN

{ Set the value of each element in accounting_data_fields for a non x.25 batch TIP.

      FOR index := 1 TO UPPERBOUND (accounting_data_fields^) DO
        CASE accounting_data_fields^ [index].kind OF
        = nac$ca_device_name =
          set_string_data_field (peer_accounting_information^, non_x25_batch.device_name,
                accounting_data_fields^ [index].kind, accounting_data_fields^ [index].device_name);

        = nac$ca_line_speed =
          set_integer_data_field (peer_accounting_information^, non_x25_batch.line_speed,
                accounting_data_fields^ [index].kind, int);
          accounting_data_fields^ [index].line_speed := int;

        = nac$ca_line_name =
          set_string_data_field (peer_accounting_information^, non_x25_batch.line_name,
                accounting_data_fields^ [index].kind, accounting_data_fields^ [index].line_name);

        = nac$ca_line_subtype =
          set_string_data_field (peer_accounting_information^, non_x25_batch.line_subtype,
                accounting_data_fields^ [index].kind, accounting_data_fields^ [index].line_subtype);

        = nac$ca_di_system_name =
          set_string_data_field (peer_accounting_information^, non_x25_batch.di_system_name,
                accounting_data_fields^ [index].kind, accounting_data_fields^ [index].di_system_name);

        = nac$ca_i_o_station_name =
          IF peer_connect_data <> NIL THEN
            #UNCHECKED_CONVERSION (peer_connect_data^ (non_x25_batch_user_data.version.index,
                  non_x25_batch_user_data.version.size), user_data_version);
            IF user_data_version = batch_user_data_version THEN
              set_string_data_field (peer_connect_data^, non_x25_batch_user_data.i_o_station_name,
                    accounting_data_fields^ [index].kind, accounting_data_fields^ [index].i_o_station_name);

            ELSE
              osp$set_status_abnormal (nac$status_id, nae$acct_version_mismatch, 'User Data Record', status);
              osp$append_status_integer (osc$status_parameter_delimiter, user_data_version, 10, FALSE,
                    status);
              osp$append_status_integer (osc$status_parameter_delimiter, batch_user_data_version, 10, FALSE,
                    status);
              RETURN;

            IFEND;

          ELSE
            accounting_data_fields^ [index].kind := nac$ca_unavailable_information;

          IFEND;

        = nac$ca_null_information =
          ;

        ELSE
          accounting_data_fields^ [index].kind := nac$ca_unavailable_information;

        CASEND;
      FOREND;

    ELSEIF (caller_id = ci_cdcnet_aa_gateway) AND (accounting_id = ai_x25_aa) THEN

{ Set values for each element of accounting_data_fields for an x.25 A to A gateway.

      FOR index := 1 TO UPPERBOUND (accounting_data_fields^) DO
        CASE accounting_data_fields^ [index].kind OF
        = nac$ca_pdn_name =
          set_string_data_field (peer_accounting_information^, x25_aa_gateway.pdn_name,
                accounting_data_fields^ [index].kind, accounting_data_fields^ [index].pdn_name);

        = nac$ca_trunk_name =
          set_string_data_field (peer_accounting_information^, x25_aa_gateway.trunk_name,
                accounting_data_fields^ [index].kind, accounting_data_fields^ [index].trunk_name);

        = nac$ca_null_information =
          ;

        ELSE
          accounting_data_fields^ [index].kind := nac$ca_unavailable_information;

        CASEND;
      FOREND;

    ELSE

{ Set value for each element of accounting_data_fields to nac$ca_unavailable_information.

      FOR index := 1 TO UPPERBOUND (accounting_data_fields^) DO
        accounting_data_fields^ [index].kind := nac$ca_unavailable_information;
      FOREND;
    IFEND;

  PROCEND nap$parse_accounting_data;
?? OLDTITLE ??
?? NEWTITLE := 'set_integer_data_field', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to retrieve a field in a substring.
{
{ DESIGN:
{   If the string passed in contains the field being requested, convert the
{   string field to an integer.  Otherwise set the kind parameter to
{   nac$ca_unavailable_information.

  PROCEDURE set_integer_data_field
    (    data_string: string ( * );
         map: element_field;
     VAR kind: nat$accounting_data_kind;
     VAR data_field: integer);

    VAR
      one_byte: 0 .. 0ff(16),
      two_bytes: 0 .. 0ffff(16),
      three_bytes: 0 .. 0ffffff(16),
      four_bytes: 0 .. 0ffffffff(16),
      five_bytes: 0 .. 0ffffffffff(16),
      six_bytes: 0 .. 0ffffffffffff(16),
      seven_bytes: 0 .. 0ffffffffffffff(16),
      eight_bytes: integer;

    IF map.last_character <= #SIZE (data_string) THEN
      CASE map.size OF
      = 1 =
        #UNCHECKED_CONVERSION (data_string (map.index, map.size), one_byte);
        data_field := one_byte;
      = 2 =
        #UNCHECKED_CONVERSION (data_string (map.index, map.size), two_bytes);
        data_field := two_bytes;
      = 3 =
        #UNCHECKED_CONVERSION (data_string (map.index, map.size), three_bytes);
        data_field := three_bytes;
      = 4 =
        #UNCHECKED_CONVERSION (data_string (map.index, map.size), four_bytes);
        data_field := four_bytes;
      = 5 =
        #UNCHECKED_CONVERSION (data_string (map.index, map.size), five_bytes);
        data_field := five_bytes;
      = 6 =
        #UNCHECKED_CONVERSION (data_string (map.index, map.size), six_bytes);
        data_field := six_bytes;
      = 7 =
        #UNCHECKED_CONVERSION (data_string (map.index, map.size), seven_bytes);
        data_field := seven_bytes;
      = 8 =
        #UNCHECKED_CONVERSION (data_string (map.index, map.size), eight_bytes);
        data_field := eight_bytes;
      ELSE
        ;
      CASEND;

    ELSE
      kind := nac$ca_unavailable_information;
    IFEND;
  PROCEND set_integer_data_field;
?? OLDTITLE ??
?? NEWTITLE := 'set_string_data_field', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to retrieve a field in a substring.
{
{ DESIGN:
{   If the string passed in contains the field being requested, set the
{   data_field parameter to that value.  Otherwise set the kind parameter
{   to nac$ca_unavailable_information.

  PROCEDURE set_string_data_field
    (    data_string: string ( * );
         map: element_field;
     VAR kind: nat$accounting_data_kind;
     VAR data_field: string ( * ));

    IF map.last_character <= #SIZE (data_string) THEN
      data_field := data_string (map.index, map.size);
    ELSE
      kind := nac$ca_unavailable_information;
    IFEND;
  PROCEND set_string_data_field;
?? OLDTITLE ??
?? NEWTITLE := 'set_x25_interact_di_system_name', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to retrieve a field in a substring.
{
{ DESIGN:
{   If the string passed in contains the field being requested, set the
{   data_field parameter to that value.  Otherwise set the kind parameter
{   to nac$ca_unavailable_information.  The exception is if the string
{   length is 231.  The value 231 was the old value for the di system name
{   which was incorrect.  To remain compatible we need to special case 231.
{   When level 1.5.1 is nolonger supported this procedure can be deleted.

  PROCEDURE set_x25_interact_di_system_name
    (    data_string: string ( * );
         map: element_field;
     VAR kind: nat$accounting_data_kind;
     VAR data_field: string ( * ));

    IF map.last_character <= #SIZE (data_string) THEN
      data_field := data_string (map.index, map.size);
    ELSEIF 231 <= #SIZE (data_string) THEN
      data_field := data_string (map.index, 21);
    ELSE
      kind := nac$ca_unavailable_information;
    IFEND;
  PROCEND set_x25_interact_di_system_name;
?? OLDTITLE ??
MODEND nam$parse_accounting_data
*DECK DECK=NAM$PROCESS_NETWORK_RESPONSE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access : Monitor Mode' ??
?? NEWTITLE := 'Global Declarations Referenced by This Module' ??
MODULE nam$process_network_response;

{ PURPOSE:
{   This module contains all of the NAM/VE monitor code which processes
{   network PP responses.
{
{ DESIGN:
{   This module contains code to process all solicited and unsolicited
{   responses from any network device driver. The processing which occurs is
{   specific to the particular response.
{
{   NOTE: the alogorithm employed to distribute a received message to a specific task is dependent on
{         the interlocking performed by monitor mode software outside the realm of procedures contained
{         in this module.  If this interlocking scheme changes (i.e., the duration of the locks or the
{         the protection of locks changes), the distribution procedure may be required to ensure that
{         job swapping or task termination does not cause an execution control block to disappear during
{         the execution of the distribution function.
{

?? PUSH (LISTEXT := ON) ??
*copyc iot$io_request
*copyc ioc$unsolicited_response_codes
*copyc nak$monitor_mode_keypoints
*copyc nat$network_driver_response
*copyc nat$preallocated_rb_control
*copyc nat$preallocated_request_blocks
*copyc nat$received_message_list
*copyc nat$request_block_list
*copyc nat$system_identifier
*copyc nlc$nam_configuration_constants
*copyc nlt$cc_protocol_data_unit
*copyc nlt$cl_connections
*copyc nlt$cl_reference_number
*copyc nlt$pdu_type
*copyc nlt$connections_per_system
*copyc nlt$device_usage_data_list
*copyc nlt$pp_pool_status_and_message
*copyc nlt$receiving_connections
*copyc nlt$signal_device_error
*copyc oss$network_wired
*copyc oss$mainframe_wired
*copyc oss$mainframe_wired_cb
*copyc oss$mainframe_wired_literal
*copyc ost$execution_control_block
*copyc ost$global_task_id
*copyc ost$heap
*copyc pmt$signal
*copyc syt$monitor_status
*copyc tmc$signal_identifiers
?? POP ??
*copyc jmp$get_ijle_p
*copyc jmp$unlock_ajl
*copyc mtp$error_stop
*copyc tmp$check_taskid
*copyc tmp$find_xcb
*copyc tmp$monitor_ready_system_task
*copyc tmp$send_signal
*copyc tmp$set_system_flag
*copyc tmp$set_task_ready
*copyc jmv$ijl_p
*copyc nav$include_debug_keypoints
*copyc tmv$ptl_p
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    nav$intranet_mgmt_work_list: [XDCL, #GATE, oss$network_wired] nat$network_driver_responses :=
          [[0, NIL], [0, NIL]],
    nav$network_wired_heap: [XDCL, #GATE, oss$network_wired] ^ost$heap,


    nav$system_id: [XDCL, #GATE, oss$mainframe_wired] nat$system_identifier,

    nav$system_input_taskid: [XDCL, #GATE, oss$mainframe_wired] ost$global_task_id,

    nav$si_received_message_list: [XDCL, #GATE, oss$mainframe_wired_cb] nat$received_message_list := [NIL, 0],

    nav$completed_output_taskid: [XDCL, #GATE, oss$mainframe_wired] ost$global_task_id,

    nav$connection_establish_taskid: [XDCL, #GATE, oss$mainframe_wired] ost$global_task_id,

    nav$directory_me_taskid: [XDCL, #GATE, oss$mainframe_wired] ost$global_task_id,

    nav$completed_output_requests: [XDCL, #GATE, oss$mainframe_wired] nat$request_block_list := [NIL, 0],

    nav$network_response_processor: [XDCL, #GATE, oss$mainframe_wired] iot$response_processor :=
          ^nap$network_response_processor;

  VAR
    nav$preallocated_rb_control: [XDCL, #GATE, oss$mainframe_wired] nat$preallocated_rb_control := [0, 1],
    nav$preallocated_request_block: [XDCL, #GATE, oss$mainframe_wired] nat$preallocated_request_blocks := NIL;

  VAR
    nav$access_swapped_tasks: [XDCL, #GATE, oss$mainframe_wired] boolean := FALSE;

  VAR

{ The following must be locked before modifying the pointer to connections (nlv$cl_connections).

    nlv$cl_connections_control: [XDCL, #GATE] nlt$cl_connections_control := [nlc$cl_connections_unlocked],

    nlv$maximum_system_connections: [XDCL, #GATE] nlt$connections_per_system :=
          nlc$default_maximum_connections,

    nlv$cl_connections: [XDCL, #GATE] nlt$cl_connections := [0, 0, NIL],

{   The total number of active connections (including priority connections).

    nlv$cl_active_connections: [XDCL, #GATE] nlt$cl_reference_number := 0;

  VAR
    nlv$device_usage_data: [XDCL, #GATE, oss$network_wired] ^nlt$device_usage_data_list := NIL;

  VAR
    nlv$receiving_connections: [XDCL, #GATE, oss$mainframe_wired] nlt$receiving_connections :=
      [0, NIL];

  VAR
    nlv$replenish_pp_buffer_pools: [XDCL, #GATE, oss$network_wired] boolean := TRUE;

  VAR
    illegal_pp_response: [STATIC, READ, oss$mainframe_wired_literal] string (29) :=
          'NA - ILLEGAL RESPONSE FROM PP';

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] distribute_received_message', EJECT ??

  PROCEDURE [INLINE] distribute_received_message
    (    message_descriptor: ^nlt$bm_message_descriptor;
         xcb: ^ost$execution_control_block;
         ijle_p: ^jmt$initiated_job_list_entry;
     VAR task_to_activate: ost$global_task_id);

{
{   NOTE: the algorithm employed to distribute a received message to a specific task is dependent on
{         the interlocking performed by monitor mode software outside the realm of procedures contained
{         in this module.  If this interlocking scheme changes (i.e., the duration of the locks or the
{         the protection of locks changes), the distribution procedure may be required to ensure that
{         job swapping or task termination does not cause an execution control block to disappear during
{         the execution of the distribution function.
{

    VAR
      result: osc$cs_successful .. osc$cs_variable_locked,
      initial,
      new,
      actual: nat$received_message_list,
      message_distributed: boolean,
      replenish_pp_buffer_pools: boolean,
      status: syt$monitor_status;

    message_distributed := FALSE;
    new.next_received_message := message_descriptor;
    new.fill := 0;
    initial.fill := 0;
    replenish_pp_buffer_pools := message_descriptor^.received_message.pp_pools_need_replenishing;
    IF replenish_pp_buffer_pools THEN
      nlv$replenish_pp_buffer_pools := replenish_pp_buffer_pools;
    IFEND;

    REPEAT
      message_descriptor^.received_message.next_received_message := NIL;
      initial.next_received_message := NIL;

    /push_message/
      BEGIN
        IF (task_to_activate = nav$system_input_taskid) THEN
          REPEAT
            #COMPARE_SWAP (nav$si_received_message_list, initial, new, initial, result);
            CASE result OF
            = osc$cs_successful =
              message_distributed := TRUE;
            = osc$cs_failed =
              message_descriptor^.received_message.next_received_message := initial.next_received_message;
            = osc$cs_variable_locked =
              ;
            CASEND;
          UNTIL message_distributed;
          IF (initial.next_received_message = NIL) THEN
            tmp$monitor_ready_system_task (tmc$stid_namve_system_input, status);
          IFEND;
        ELSE { Queue the message on the user task. }
          REPEAT
            #COMPARE_SWAP (xcb^.received_message_list, initial, new, initial, result);
            CASE result OF
            = osc$cs_successful =
              IF (initial.next_received_message = NIL) THEN
                tmp$set_system_flag (task_to_activate, nac$network_input_received, status);
                IF status.normal THEN
                  message_distributed := TRUE;
                ELSE { Reset the user task queue to nil. }
                  REPEAT
                    #COMPARE_SWAP (xcb^.received_message_list, new, initial, actual, result);
                  UNTIL (result = osc$cs_successful);
                  task_to_activate := nav$system_input_taskid;
                IFEND;
              ELSE
                message_distributed := TRUE;
              IFEND;
            = osc$cs_failed =
              message_descriptor^.received_message.next_received_message := initial.next_received_message;
            = osc$cs_variable_locked =
              ;
            CASEND;
          UNTIL (message_distributed OR (task_to_activate = nav$system_input_taskid));
          IF message_distributed AND replenish_pp_buffer_pools THEN
            tmp$monitor_ready_system_task (tmc$stid_namve_system_input, status);
          IFEND;
        IFEND;
      END /push_message/;
    UNTIL message_distributed;

    IF xcb <> NIL THEN
      jmp$unlock_ajl (ijle_p);
    IFEND;
  PROCEND distribute_received_message;
?? OLDTITLE ??
?? NEWTITLE := 'get_message_contents', EJECT ??

{ PURPOSE:
{    The purpose of this request is to retrieve two pointers.  The first pointer (pdu_kind) will
{    point to the 'kind' field in the CC header (NLT$CC_PROTOCOL_DATA_UNIT), this field will be
{    the first byte of the received_message.  The second pointer (destination) will point to the
{    'destination_reference' field in the CC header, this field will be located at the ninth and
{    tenth bytes of the received_message.  It is assummed that the message length will be at least
{    ten bytes.

  PROCEDURE [INLINE] get_message_contents
    (    received_message: ^nlt$bm_message_descriptor;
     VAR pdu_kind: ^cell;
     VAR destination: ^cell);

    CONST
      eight_bytes = 8;

    pdu_kind := ^received_message^.container^ (1 + received_message^.data_start);

{ The ninth byte of the first descriptor contains the start of the CC destination field.

    IF (received_message^.container_length - received_message^.data_start) > eight_bytes THEN
      destination := ^received_message^.container^ (9 + received_message^.data_start);

{ The first container held eight bytes so the destination will start at the first byte of the
{ second container.

    ELSE
      destination := ^received_message^.link^.container^ (1);
    IFEND;
  PROCEND get_message_contents;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_xcb_p', EJECT ??

  PROCEDURE [INLINE] get_xcb_p
    (    task_id: ost$global_task_id;
     VAR xcb_p: ^ost$execution_control_block;
     VAR ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      local_status: syt$monitor_status;

    local_status.normal := TRUE;
    jmp$get_ijle_p (tmv$ptl_p^ [task_id.index].ijl_ordinal, ijle_p);
    IF (NOT nav$access_swapped_tasks) AND (ijle_p^.swap_status <> jmc$iss_executing) THEN
      xcb_p := NIL;
    ELSE
      tmp$find_xcb (task_id, xcb_p, ijle_p, local_status);
      IF NOT local_status.normal THEN
        xcb_p := NIL;
      ELSEIF xcb_p^.task_is_terminating THEN
        xcb_p := NIL;
        jmp$unlock_ajl (ijle_p);
      IFEND;
    IFEND;

  PROCEND get_xcb_p;
?? OLDTITLE ??
?? NEWTITLE := 'process_invalid_cc_pdu', EJECT ??

{
{  PURPOSE:
{    The purpose of this procedure is to report that an invalid CC PDU
{    has been received and request that the message be released and the
{    offending device be reset.

  PROCEDURE process_invalid_cc_pdu
    (    message_descriptor: ^nlt$bm_message_descriptor;
     VAR status: syt$monitor_status);

    VAR
      signal: pmt$signal,
      signal_contents: ^nlt$signal_device_error;


    signal.identifier := nac$network_device_error;
    signal_contents := #LOC (signal.contents);
    signal_contents^.reset_device := TRUE;
    signal_contents^.device_id := message_descriptor^.received_message.device_id;
    signal_contents^.pp_pools_need_replenishing := message_descriptor^.received_message.
          pp_pools_need_replenishing;
    signal_contents^.peer_global_flow_control := message_descriptor^.received_message.
          peer_global_flow_control;
    signal_contents^.message := message_descriptor;
    tmp$send_signal (nav$system_input_taskid, signal, status);
  PROCEND process_invalid_cc_pdu;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] process_received_message', EJECT ??

{
{ PURPOSE:
{   The purpose of this procedure is to process incoming network
{   messages that were received without error by the PP. This procedure
{   processes both Channelnet and Channel Connection messages. If the
{   message cannot be delivered to job mode, an abnormal status is returned;
{   this will result in the message being left in the PP response buffer
{   for processing at a later time. Returning abnormal status does NOT indicate
{   that an error occurred.
{

  PROCEDURE [INLINE] process_received_message
    (    message_descriptor { input, output } : ^nlt$bm_message_descriptor;
     VAR status: syt$monitor_status);

    VAR
      cc_pdu_kind: ^nlt$cc_pdu_kind,
      consume_sequence_number: boolean,
      destination_reference: ^nlt$cl_reference_number,
      ijle_p: ^jmt$initiated_job_list_entry,
      message_queued: boolean,
      reference_number_valid: boolean,
      task: ost$global_task_id,
      validation_complete: boolean,
      xcb: ^ost$execution_control_block;

    status.normal := TRUE;
    ijle_p := NIL;
    IF message_descriptor^.received_message.pdu_type = nlc$channel_connection_pdu THEN
      get_message_contents (message_descriptor, cc_pdu_kind, destination_reference);

      CASE cc_pdu_kind^ OF
      = nlc$cc_connect_confirm, nlc$cc_disconnect_request, nlc$cc_disconnect_confirm,
        nlc$cc_credit_allocation, nlc$cc_data, nlc$cc_expedited_data =
        IF (cc_pdu_kind^ <> nlc$cc_disconnect_request) OR
          (destination_reference^ <> 0) THEN
          consume_sequence_number := ((cc_pdu_kind^ <> nlc$cc_disconnect_request) AND
                (cc_pdu_kind^ <> nlc$cc_disconnect_confirm));

{ The CC sequence number assigned to a disconnect request or confirm is not unique and is not
{ used in sequencing the disconnect for processing. A disconnect request or confirm will always
{ be processed immediately. The sequence number assigned serves only as a possible aid in debugging.

          validate_and_optional_q (message_descriptor, cc_pdu_kind^, destination_reference^,
                consume_sequence_number, validation_complete, reference_number_valid, message_queued,
                task);
          IF (validation_complete) AND (reference_number_valid) THEN
            IF message_queued THEN
              RETURN;
            IFEND;
            IF (cc_pdu_kind^ = nlc$cc_disconnect_confirm) OR
                  (cc_pdu_kind^ = nlc$cc_disconnect_request) THEN
              task := nav$connection_establish_taskid;
            IFEND;
          ELSEIF validation_complete THEN


{  The destination reference number was found to be invalid (i.e., no connection
{  structure was found).

            process_invalid_cc_pdu (message_descriptor, status);

            RETURN;
          ELSE

{  Access to the connection structure was not obtained and therefore a sequence
{  number could not be assigned.  An abnormal status will be returned; this will
{  result in the message being left in the PP response buffer for processing at
{  a later time.

            status.normal := FALSE;
            RETURN;
          IFEND;
        ELSE { disconnect request with destination reference = 0
          message_descriptor^.received_message.sequence#_or_connect_timestamp.sequence_number := 1;
          task := nav$connection_establish_taskid;
        IFEND;

        = nlc$cc_connect_request =
          message_descriptor^.received_message.sequence#_or_connect_timestamp.
                time_connect_request_received := #FREE_RUNNING_CLOCK (0);
          task := nav$connection_establish_taskid;

        = nlc$cc_global_window =
          message_descriptor^.received_message.sequence#_or_connect_timestamp.
            sequence_number := 1;
          task := nav$connection_establish_taskid;

      ELSE {Invalid CC PDU kind.
        process_invalid_cc_pdu (message_descriptor, status);
        RETURN;
      CASEND;
      IF task <> nav$system_input_taskid THEN
        get_xcb_p (task, xcb, ijle_p);
        IF xcb = NIL THEN
          task := nav$system_input_taskid;
        IFEND;
      ELSE
        xcb := NIL;
      IFEND;
    ELSE { Channelnet PDU
      task := nav$system_input_taskid;
      xcb := NIL;
    IFEND;

    distribute_received_message (message_descriptor, xcb, ijle_p, task);

  PROCEND process_received_message;
?? OLDTITLE ??
?? NEWTITLE := 'queue_response_for_mgmt_task' ??
?? NEWTITLE := '[INLINE] move_bytes', EJECT ??
{ The purpose of this procedure is to get an available response from the
{ available response queue, fill in the details and queue it on the
{ outstanding response queue in the intranet layer mgmt work list.
{ The intranet layer mgmt task is readied to process the response.


  PROCEDURE queue_response_for_mgmt_task
    (    pp_response: ^iot$pp_response;
         received_detailed_status: ^iot$detailed_status;
     VAR status: syt$monitor_status);


  PROCEDURE [INLINE] move_bytes (
        source: ^cell;
        dest: ^cell;
        length: 0 .. ioc$detailed_status_length_b);

    VAR
      str1: ^string (ioc$detailed_status_length_b),
      str2: ^string (ioc$detailed_status_length_b);

    IF length <> 0 THEN
      str1 := source;
      str2 := dest;
      str2^ (1, length) := str1^ (1, length);
      #SPOIL (str2^);
    IFEND;
  PROCEND move_bytes;
?? OLDTITLE, EJECT ??

    VAR
      available_response: ^nat$network_driver_response,
      cs_status: osc$cs_successful .. osc$cs_variable_locked,
      detailed_status: ^iot$detailed_status,
      ignore_status: syt$monitor_status,
      network_request: ^nat$network_request,
      new_response_list: nat$response_queue_access,
      old_response_list: nat$response_queue_access;

    status.normal := TRUE;
    new_response_list.sequence := 0;
    new_response_list.next_entry := NIL;
    old_response_list := new_response_list;

    REPEAT
      #COMPARE_SWAP (nav$intranet_mgmt_work_list.free_responses, old_response_list, new_response_list,
            old_response_list, cs_status);
      IF cs_status = osc$cs_failed THEN
        IF old_response_list.next_entry <> NIL THEN
          new_response_list.sequence := (old_response_list.sequence + 1) MOD 10000(16);
          new_response_list.next_entry := old_response_list.next_entry^.next_entry;
        ELSE

{ If there are no free responses, an abnormal status is returned to the caller.
{ This will cause the response to be requeued in the pp response buffer. The response
{ is reissued later.

          #KEYPOINT (osk$unusual, 0, nak$no_free_response);
          status.normal := FALSE;
          RETURN;
        IFEND;
      IFEND;
    UNTIL cs_status = osc$cs_successful;

    available_response := old_response_list.next_entry;
    IF available_response = NIL THEN
      #KEYPOINT (osk$unusual, 0, nak$no_free_response);
      status.normal := FALSE;
      RETURN;
    IFEND;
    available_response^.next_entry := NIL;
    available_response^.pp_response := pp_response^;

{ Break the link between the solicited response and the request block.

    IF pp_response^.response_code.primary_response <> ioc$unsolicited_response THEN
      network_request := pp_response^.request^.device_request_p;
      available_response^.command := network_request^.peripheral_request.command;
      available_response^.pp_response.request := NIL;
    IFEND;

    IF received_detailed_status <> NIL THEN
      detailed_status := ^available_response^.detailed_status;
      RESET detailed_status;
      move_bytes (received_detailed_status, detailed_status, (pp_response^.response_length -
            #SIZE (iot$pp_response)));
      available_response^.detailed_status_pointer := detailed_status;
    ELSE
      available_response^.detailed_status_pointer := NIL;
    IFEND;

{ Queue the response in the outstanding responses queue.

    new_response_list.sequence := 0;
    new_response_list.next_entry := available_response;
    old_response_list := new_response_list;
    REPEAT
      #COMPARE_SWAP (nav$intranet_mgmt_work_list.outstanding_responses, old_response_list, new_response_list,
            old_response_list, cs_status);
      IF cs_status = osc$cs_failed THEN
        new_response_list.sequence := (old_response_list.sequence + 1) MOD 10000(16);
        available_response^.next_entry := old_response_list.next_entry;
      IFEND;
    UNTIL cs_status = osc$cs_successful;

    tmp$monitor_ready_system_task (tmc$stid_intranet_layer_mgmt, ignore_status);

  PROCEND queue_response_for_mgmt_task;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] queue_completed_request', EJECT ??

  PROCEDURE [INLINE] queue_completed_request
    (    completed_request: ^nat$request_block;
     VAR request_block_link: ^nat$request_block);

    CONST
      maximum_queued_requests = 8;

    VAR
      current,
      new: nat$request_block_list,
      cs_status: osc$cs_successful .. osc$cs_variable_locked,
      ignore_status: syt$monitor_status;

{ Queue the completed request block on nav$completed_output_requests.

    request_block_link := NIL;
    current.request_block_link := NIL;
    current.requests_queued := 0;
    new.request_block_link := completed_request;
    new.requests_queued := 1;
    REPEAT
      #COMPARE_SWAP (nav$completed_output_requests, current, new, current, cs_status);
      IF (cs_status = osc$cs_failed) THEN
        new.requests_queued := current.requests_queued + 1;
        request_block_link := current.request_block_link;
      IFEND;
    UNTIL (cs_status = osc$cs_successful);
    IF new.requests_queued = maximum_queued_requests THEN
      tmp$monitor_ready_system_task (tmc$stid_completed_output, ignore_status);
    IFEND;
  PROCEND queue_completed_request;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] validate_and_optional_q', EJECT ??
{
{    The purpose of this procedure is to access the channel connection for
{ which the given message is destined.  The channel connection is accessed via
{ a non exclusive to the root.  The given reference number is used to find the
{ channel connection and the message is validated as belonging to the
{ referenced channel connection.  If the channel connection has the 'queue on
{ connection' attribute set and the message is other than a connect or a
{ disconnect PDU, it is queued on the channel connection and the cooresponding
{ receiver task is readied.  If the 'queue on connection' attribute is not set,
{ the requested information is returned from the channel connection.
{
{ MESSAGE_DESCRIPTOR: (input, output)  This parameter contains the pointer to
{       the message.
{
{ CC_PDU_KIND: (input) This parameter specifies the kind of the received
{       channel connection event.
{
{ RERERENCE_NUMBER: (input)  This parameter contains the reference number of
{       the channel connection for which the message is destined.
{
{ CONSUME_SEQUENCE_NUMBER: (input)  This parameter specifies whether or not a
{        Channel Connection sequence number should be consumed (i.e., whether
{        or not a unique sequence number should be assigned).  Note that only
{        data PDUs consume sequence numbers.  A disconnect or disconnect PDU
{        will not consume sequence numbers.
{
{ VALIDATION_COMPLETE: (output)  This parameter specifies whether validation
{        of the reference number was possible.  If the procedure was unable to
{        obtain access to the connection list, validation is not possible and
{        this parameter will be set to FALSE.
{
{ REFERENCE_NUMBER_VALID: (output)  This parameter specifies whether the
{        reference number is valid (i.e., whether the connection exists).  This
{        parameter is valid only if the value of the VALIDATION_COMPLETE
{        parameter is TRUE.
{
{ MESSAGE_QUEUED: (output)  This parameter is set to TRUE if the given message
{       was queued on the channel connection.  Note that if the message is not
{       going to consume sequence number it is not queued on the channel
{       connection.
{
{ TASK: (output)  This parameter specifies the last task recorded as a
{        receiver or sender if one is active, otherwise it is set to the
{        system input task.
{

  PROCEDURE [INLINE] validate_and_optional_q
    (    message_descriptor { input, output }: ^nlt$bm_message_descriptor;
         cc_pdu_kind: nlt$cc_pdu_kind;
         reference_number: nlt$cl_reference_number;
         consume_sequence_number: boolean;
     VAR validation_complete: boolean;
     VAR reference_number_valid: boolean;
     VAR message_queued: boolean;
     VAR task: ost$global_task_id);

    VAR
      actual_active_receiver: nlt$udp_active_receiver,
      actual_connection_queue: nlt$connection_queue,
      actual_receiving_connections: nlt$receiving_connections,
      cl_connection: ^nlt$cl_connection,
      cs_result: osc$cs_successful .. osc$cs_variable_locked,
      initial_active_receiver: nlt$udp_active_receiver,
      initial_connection_queue: nlt$connection_queue,
      initial_input_queue: nat$received_message_list,
      initial_receiving_connections: nlt$receiving_connections,
      initial_root: nlt$cl_connection_root_access,
      local_status: syt$monitor_status,
      message_offset: ost$segment_offset,
      new_active_receiver: nlt$udp_active_receiver,
      new_connection_queue: nlt$connection_queue,
      new_input_queue: nat$received_message_list,
      new_receiving_connections: nlt$receiving_connections,
      new_root: nlt$cl_connection_root_access,
      receiver_active: boolean,
      replenish_pp_buffer_pools: boolean,
      result: osc$cs_successful .. osc$cs_variable_locked,
      root: nlt$cl_reference_number,
      sender_active: boolean;

    validation_complete := FALSE;
    reference_number_valid := FALSE;
    message_queued := FALSE;
    IF (nlv$cl_connections.list <> NIL) THEN
      initial_root.nonexclusive_accessors := 0;
      initial_root.exclusive := FALSE;
      initial_root.fill := 0;
      new_root := initial_root;
      new_root.nonexclusive_accessors := 1;
      root := (reference_number MOD (UPPERBOUND (nlv$cl_connections.list^) + 1));

      /lock_root/
      REPEAT
        #COMPARE_SWAP (nlv$cl_connections.list^ [root].access_control, initial_root, new_root,
              initial_root, result);
        IF (result = osc$cs_successful) THEN
          validation_complete := TRUE;
          cl_connection := nlv$cl_connections.list^ [root].first;

          /find_connection/
          WHILE cl_connection <> NIL DO
            IF (reference_number = cl_connection^.identifier.reference_number) AND
                  (message_descriptor^.received_message.device_id IN cl_connection^.device_ids) AND
                  (nlc$channel_connection_layer IN cl_connection^.layers_active) THEN
              IF cl_connection^.queue_on_connection THEN
                IF consume_sequence_number THEN

{ Queue the message on the connnection.

                  replenish_pp_buffer_pools := message_descriptor^.received_message.
                    pp_pools_need_replenishing;
                  IF replenish_pp_buffer_pools THEN
                    nlv$replenish_pp_buffer_pools := replenish_pp_buffer_pools;
                  IFEND;
                  message_descriptor^.received_message.next_received_message := NIL;
                  initial_input_queue.next_received_message := NIL;
                  initial_input_queue.fill := 0;
                  new_input_queue := initial_input_queue;
                  new_input_queue.next_received_message := message_descriptor;
                  REPEAT
                    #COMPARE_SWAP (cl_connection^.input_queue, initial_input_queue,
                      new_input_queue, initial_input_queue, result);
                    CASE result OF
                    = osc$cs_successful =
                      IF initial_input_queue.next_received_message = NIL THEN

{ Activate the receiver or sender task. If neither is active, activate the system input task.

                        receiver_active := FALSE;
                        sender_active := FALSE;
                        actual_active_receiver.task_id.index := 0;
                        IF cl_connection^.active_receiver <> NIL THEN

{ This is a connection for a UDP socket.

                          initial_active_receiver.task_id.index := 0;
                          initial_active_receiver.task_id.seqno := 0;
                          initial_active_receiver.fill := 0;
                          new_active_receiver := initial_active_receiver;
                          REPEAT
                            #COMPARE_SWAP (cl_connection^.active_receiver^, initial_active_receiver,
                              new_active_receiver, actual_active_receiver, cs_result);
                          UNTIL cs_result <> osc$cs_variable_locked;
                          IF actual_active_receiver.task_id.index <> 0 THEN
                            tmp$check_taskid (actual_active_receiver.task_id, tmc$opt_return,
                              local_status);
                            IF local_status.normal THEN
                              receiver_active := TRUE;
                              tmp$set_task_ready (actual_active_receiver.task_id, 0,
                                tmc$rc_ready_conditional_wi);
                            IFEND;
                          IFEND;
                        ELSEIF (cl_connection^.message_receiver.active) AND
                          (cl_connection^.message_receiver.task.index <> 0) THEN
                          tmp$check_taskid (cl_connection^.message_receiver.task, tmc$opt_return,
                            local_status);
                          IF local_status.normal THEN
                            receiver_active := TRUE;
                            tmp$set_task_ready (cl_connection^.message_receiver.task, 0,
                              tmc$rc_ready_conditional_wi);
                          IFEND;
                        IFEND;
                        IF NOT receiver_active THEN
                          IF (cl_connection^.message_sender.active) AND
                            (cl_connection^.message_sender.task.index <> 0) AND
                            (cl_connection^.message_sender.task <> actual_active_receiver.task_id) THEN
                            tmp$check_taskid (cl_connection^.message_sender.task, tmc$opt_return,
                              local_status);
                            IF local_status.normal THEN
                              sender_active := TRUE;
                              tmp$set_task_ready (cl_connection^.message_sender.task, 0,
                                tmc$rc_ready_conditional_wi);
                            IFEND;
                          IFEND;
                        IFEND;
                        IF (NOT receiver_active) AND (NOT sender_active) THEN

{ Queue the connection in the receiving connections queue.

                          new_receiving_connections.fill := 0;
                          new_receiving_connections.next_connection := NIL;
                          initial_receiving_connections := new_receiving_connections;
                          REPEAT
                            #COMPARE_SWAP (nlv$receiving_connections, initial_receiving_connections,
                              new_receiving_connections, actual_receiving_connections, cs_result);
                          UNTIL cs_result <> osc$cs_variable_locked;

                          initial_connection_queue.in_queue := FALSE;
                          initial_connection_queue.fill := 0;
                          initial_connection_queue.next_connection := NIL;

                        /queue_connection/
                          REPEAT
                            new_connection_queue.in_queue := TRUE;
                            new_connection_queue.fill := 0;
                            new_connection_queue.next_connection := actual_receiving_connections.
                              next_connection;
                            REPEAT
                              #COMPARE_SWAP (cl_connection^.connection_queue, initial_connection_queue,
                                new_connection_queue, actual_connection_queue, cs_result);
                              IF cs_result = osc$cs_failed THEN
                                IF actual_connection_queue.in_queue THEN

{ Connection is already queued.

                                  EXIT /queue_connection/;
                                ELSE
{ There is a bug in the system.
                                IFEND;
                              IFEND;
                            UNTIL cs_result = osc$cs_successful;
                            initial_connection_queue := new_connection_queue;
                            initial_receiving_connections := actual_receiving_connections;
                            new_receiving_connections.fill := 0;
                            new_receiving_connections.next_connection := cl_connection;
                            REPEAT
                              #COMPARE_SWAP (nlv$receiving_connections, initial_receiving_connections,
                                new_receiving_connections, actual_receiving_connections, cs_result);
                              IF cs_result = osc$cs_failed THEN
                                CYCLE /queue_connection/;
                              IFEND;
                            UNTIL cs_result = osc$cs_successful;
                          UNTIL cs_result = osc$cs_successful;

{ Ready the system input task.

                          IF actual_receiving_connections.next_connection = NIL THEN
                            tmp$monitor_ready_system_task (tmc$stid_namve_system_input,
                              local_status);
                          IFEND;
                        ELSE { the receiver or sender task had been readied
                          IF replenish_pp_buffer_pools THEN
                            tmp$monitor_ready_system_task (tmc$stid_namve_system_input,
                              local_status);
                          IFEND;
                        IFEND;
                      ELSE { messages already queued on the connection
                        IF replenish_pp_buffer_pools THEN
                          tmp$monitor_ready_system_task (tmc$stid_namve_system_input,
                            local_status);
                        IFEND;
                      IFEND;
                      message_queued := TRUE;

                    = osc$cs_failed =
                      message_descriptor^.received_message.next_received_message :=
                        initial_input_queue.next_received_message;

                    = osc$cs_variable_locked =
                      ;
                    CASEND;
                  UNTIL message_queued;
                ELSE { NOT consume_sequence_number
                  message_descriptor^.received_message.connection_id := cl_connection^.identifier;
                  message_descriptor^.received_message.sequence#_or_connect_timestamp.sequence_number :=
                   1;
                IFEND;
              ELSE { do not queue on the connection
                IF cl_connection^.message_receiver.active THEN
                  task := cl_connection^.message_receiver.task;
                ELSEIF cl_connection^.message_sender.active THEN
                  task := cl_connection^.message_sender.task;
                ELSE
                  task := nav$system_input_taskid;
                IFEND;
                message_descriptor^.received_message.connection_id := cl_connection^.identifier;
                message_descriptor^.received_message.sequence#_or_connect_timestamp.sequence_number :=
                  cl_connection^.next_assignable_cc_sequence#;
                IF consume_sequence_number THEN
                  cl_connection^.next_assignable_cc_sequence# := cl_connection^.next_assignable_cc_sequence#
                    + 1;
                IFEND;
              IFEND;
              reference_number_valid := TRUE;
              EXIT /find_connection/;
            ELSE
              cl_connection := cl_connection^.nextt;
            IFEND;
          WHILEND /find_connection/;

          initial_root := new_root;
          new_root.nonexclusive_accessors := new_root.nonexclusive_accessors - 1;

        /release_root/
          REPEAT
            #COMPARE_SWAP (nlv$cl_connections.list^ [root].access_control, initial_root, new_root,
                  initial_root, result);
            IF (result = osc$cs_failed) THEN
              new_root.nonexclusive_accessors := initial_root.nonexclusive_accessors - 1;
            IFEND;
          UNTIL (result = osc$cs_successful);

        ELSEIF (result = osc$cs_failed) THEN
          IF NOT initial_root.exclusive THEN
            new_root.nonexclusive_accessors := initial_root.nonexclusive_accessors + 1;
          ELSE
            EXIT /lock_root/;
          IFEND;
        IFEND;
      UNTIL (result = osc$cs_successful);
    IFEND;
  PROCEND validate_and_optional_q;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$network_response_processor', EJECT ??

  PROCEDURE [XDCL] nap$network_response_processor
    (    pp_response: ^iot$pp_response;
         received_detailed_status: ^iot$detailed_status;
         pp: 1 .. ioc$pp_count;
     VAR status: syt$monitor_status);

{ The purpose of this procedure is to process the responses from the network
{ PPs. This procedure executes in monitor mode. The network responses are
{ communicated to the appropriate process in job mode. The return of an abnormal
{ status from this procedure does NOT indicate an error, rather it indicates
{ that a response could not be processed and should be left in the PP response
{ buffer for processing at a later time (abnormal status does NOT indicate an
{ error).

    VAR
      buffer_status_and_message: ^nlt$pp_pool_status_and_message,
      completed_network_request: ^nat$network_request,
      detailed_status: ^iot$detailed_status,
      device_error_contents: ^nlt$signal_device_error,
      i: integer,
      io_request: ^iot$io_request,
      message_descriptor: ^nlt$bm_message_descriptor,
      next_descriptor: ^nlt$bm_message_descriptor,
      normal_response: iot$io_error,
      pp_status_report: ^nlt$pp_status_report,
      signal: pmt$signal;


    #KEYPOINT (osk$entry, osk$m * pp, nak$network_response_processor);
    status.normal := TRUE;
    detailed_status := received_detailed_status;
    IF (detailed_status <> NIL) THEN
      RESET detailed_status;
    IFEND;

    CASE pp_response^.response_code.primary_response OF
    = ioc$unsolicited_response =
?? PUSH (LISTEXT := ON) ??
      ?IF nav$include_debug_keypoints THEN
?? POP ??
        #KEYPOINT (osk$debug, osk$m * pp_response^.unsolicited_response_code, nak$unsolicited_response);
?? PUSH (LISTEXT := ON) ??
      ?IFEND
?? POP ??

      CASE pp_response^.unsolicited_response_code OF
      = ioc$unit_ready_to_not_ready, ioc$unit_not_ready_to_ready, ioc$device_operational, ioc$log_pp_message =
        queue_response_for_mgmt_task (pp_response, detailed_status, status);

      = ioc$internal_error =

      = ioc$channelnet_input, ioc$channel_connection_input =
?? PUSH (LISTEXT := ON) ??
        ?IF nav$include_debug_keypoints THEN
?? POP ??
          #KEYPOINT (osk$debug, osk$m * pp_response^.unsolicited_response_code, nak$unsolicited_response);
?? PUSH (LISTEXT := ON) ??
        ?IFEND
?? POP ??
        next_descriptor := NIL;
        NEXT buffer_status_and_message: [1 .. ((pp_response^.response_length - #SIZE (iot$pp_response) -
              #SIZE (nlt$pp_status_report)) DIV #SIZE (nlt$pp_message_delivery))] IN detailed_status;
        FOR i := UPPERBOUND (buffer_status_and_message^.received_message) DOWNTO 1 DO
          message_descriptor := buffer_status_and_message^.received_message [i].message_descriptor;
          message_descriptor^.data_start := message_descriptor^.container_length -
                buffer_status_and_message^.received_message [i].data_length;
          message_descriptor^.link := next_descriptor;
          next_descriptor := message_descriptor;
        FOREND;


{ The 'priority' field of the PP response is defined to contain the network device identifier.

        message_descriptor^.received_message.device_id := pp_response^.priority;
        message_descriptor^.received_message.peer_global_flow_control :=
              buffer_status_and_message^.pp_status_report.peer_global_flow_control;

        message_descriptor^.received_message.pp_pools_need_replenishing :=
              (buffer_status_and_message^.pp_status_report.pp_buffer_pool_status [nlc$bm_large_buffer_index].
              buffer_pool_status <> nlc$buffer_pool_ok) OR (buffer_status_and_message^.pp_status_report.
              pp_buffer_pool_status [nlc$bm_small_buffer_index].buffer_pool_status <> nlc$buffer_pool_ok);

        IF pp_response^.unsolicited_response_code = ioc$channel_connection_input THEN
          message_descriptor^.received_message.pdu_type := nlc$channel_connection_pdu;
        ELSE
          message_descriptor^.received_message.pdu_type := nlc$channelnet_pdu;
        IFEND;
        process_received_message (message_descriptor, status);
        IF status.normal THEN
          nlv$device_usage_data^ [pp_response^.priority].bytes_received :=
                nlv$device_usage_data^ [pp_response^.priority].bytes_received + pp_response^.transfer_count;
        IFEND;

      = ioc$device_error, ioc$flow_control_status_change =

        IF (pp_response^.response_length - #SIZE (iot$pp_response)) = #SIZE (nlt$pp_status_report) THEN
          NEXT pp_status_report IN detailed_status;
          message_descriptor := NIL;
        ELSEIF pp_response^.unsolicited_response_code = ioc$device_error THEN
          next_descriptor := NIL;
          NEXT buffer_status_and_message: [1 .. ((pp_response^.response_length - #SIZE (iot$pp_response) -
                #SIZE (nlt$pp_status_report)) DIV #SIZE (nlt$pp_message_delivery))] IN detailed_status;
          pp_status_report := ^buffer_status_and_message^.pp_status_report;
          FOR i := UPPERBOUND (buffer_status_and_message^.received_message) DOWNTO 1 DO
            message_descriptor := buffer_status_and_message^.received_message [i].message_descriptor;
            message_descriptor^.data_start := message_descriptor^.container_length -
                  buffer_status_and_message^.received_message [i].data_length;
            message_descriptor^.link := next_descriptor;
            next_descriptor := message_descriptor;
          FOREND;
        ELSE {flow_control_status_change response too long
          mtp$error_stop (illegal_pp_response);
        IFEND;

        signal.identifier := nac$network_device_error;
        device_error_contents := #LOC (signal.contents);
        device_error_contents^.reset_device := FALSE;

{  The 'priority' field of the PP response is defined to contain the network device identifier.

        device_error_contents^.device_id := pp_response^.priority;
        device_error_contents^.pp_pools_need_replenishing :=
              (pp_status_report^.pp_buffer_pool_status [nlc$bm_large_buffer_index].buffer_pool_status <>
              nlc$buffer_pool_ok) OR (pp_status_report^.pp_buffer_pool_status [nlc$bm_small_buffer_index].
              buffer_pool_status <> nlc$buffer_pool_ok);
        device_error_contents^.peer_global_flow_control := pp_status_report^.peer_global_flow_control;
        device_error_contents^.message := message_descriptor;
        tmp$send_signal (nav$system_input_taskid, signal, status);

      ELSE
        mtp$error_stop (illegal_pp_response);
      CASEND;

    = ioc$normal_response, ioc$abnormal_response =
      io_request := pp_response^.request;
      completed_network_request := io_request^.device_request_p;
?? PUSH (LISTEXT := ON) ??
      ?IF nav$include_debug_keypoints THEN
?? POP ??
        #KEYPOINT (osk$debug, osk$m * completed_network_request^.peripheral_request.command.command_code,
              nak$normal_response);
?? PUSH (LISTEXT := ON) ??
      ?IFEND
?? POP ??
      CASE completed_network_request^.peripheral_request.command.command_code OF
      = ioc$cc_resume, ioc$cc_synchronize_pp, ioc$cc_debug_mode, ioc$cc_normal_flow_control,
            ioc$cc_reset_device, ioc$cc_define_ethernet_address =
          ;
      = ioc$cc_idle =
        queue_response_for_mgmt_task (pp_response, detailed_status, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = ioc$cc_network_output =

{  The 'priority' field of the PP response is defined to contain the network device
{  identifier.

        nlv$device_usage_data^ [pp_response^.priority].bytes_transmitted :=
              nlv$device_usage_data^ [pp_response^.priority].bytes_transmitted + pp_response^.transfer_count;

      ELSE
        mtp$error_stop (illegal_pp_response);
      CASEND;
      queue_completed_request (#LOC (io_request^), completed_network_request^.request_block_link);
    ELSE
      mtp$error_stop (illegal_pp_response);
    CASEND;
    #KEYPOINT (osk$exit, 0, nak$network_response_processor);
  PROCEND nap$network_response_processor;
?? OLDTITLE ??
MODEND nam$process_network_response;
*DECK DECK=NAM$SEND_COMMAND EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Network Command Processer' ??
?? NEWTITLE := 'Global Declarations' ??
MODULE nam$send_command;
?? PUSH (LISTEXT := ON) ??
*copyc clt$argument_descriptor_table
*copyc nat$command_interface
*copyc nac$reserved_saps
*copyc nae$application_interfaces
*copyc nae$directory_me_conditions
*copyc nae$manage_network_applications
*copyc nae$namve_conditions
*copyc nae$network_operator_utility
*copyc nat$bcd_time
*copyc nat$directory_interfaces
*copyc nat$gt_event
*copyc nat$network_address
*copyc nat$network_message_priority
*copyc nat$network_selector
*copyc nat$system_identifier
*copyc nat$system_title
*copyc nat$ta_alternate_protocol_class
*copyc nat$ta_preferred_protocol_class
*copyc nat$title
*copyc nat$wait_time
*copyc ost$i_wait
?? POP ??
*copyc avp$get_capability
*copyc i#move
*copyc nap$gt_close_sap
*copyc nap$gt_disconnect
*copyc nap$gt_open_sap
*copyc nap$gt_receive_connect_event
*copyc nap$gt_receive_connection_event
*copyc nap$gt_request_connection
*copyc nap$gt_send_data
*copyc nlp$end_title_translation
*copyc nlp$get_title_translation
*copyc nlp$translate_title
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$i_await_activity_completion
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$get_microsecond_clock
*copyc pmp$log
*copyc pmp$wait

*copyc nat$command_data_units

  TYPE
    command_connection = record
      active_command_count: integer,
      activity_status: ost$activity_status,
      address: nat$osi_translation_address,
      aliases: ^system_alias,
      connection_id: nat$gt_connection_id,
      event: nat$gt_event,
      last_activity_time: integer,
      queued_commands: ^queued_command,
      request_id: nat$directory_search_identifier,
      response: command_response,
      retain: boolean,
      state: (translation_required, translation_requested, connecting, connected, disconnected),
      system: nat$system_title,
      system_id: nat$system_identifier,
    recend,
    command_response = record
      header: nat$command_response_data_unit,
      message_data: SEQ (REP 128 OF cell), {scratch space for receipt of small messages}
    recend,
    system_alias = record
      next_alias: ^system_alias,
      system: nat$system_title,
    recend,
    queued_command = record
      link: ^queued_command,
      command: SEQ ( * ),
    recend;

  CONST
    max_connection_idle_time = 120000000 {microseconds...2 minutes},
    nac$command_pdu_header_length = 7,
    nac$command_protocol_version = 1,
    nac$command_syntax_code = 0;

  CONST
    index_bias = 2,
    sap_index = 2,
    timer_index = 1;

  TYPE
    wait_list_index = 1 .. nac$max_command_connections + index_bias;

  VAR
    connections: array [1 .. nac$max_command_connections] of ^command_connection,
    connect_data: array [1 .. 1] of nat$data_fragment := [[^connect_info, #SIZE (connect_info)]],
    connect_event: nat$gt_connect_event,
    connect_info: SEQ (REP 32 OF cell),
    delete_inactive_connections: boolean := FALSE,
    max_connection_index: 0 .. nac$max_command_connections,
    nil_data: array [1..1] of nat$data_fragment := [[NIL, 0]],
    sap_status: ost$activity_status,
    search_domain: nat$title_domain := [nac$catenet_domain],
    transport_sap_open: boolean := FALSE,
    transport_sap_id: nat$gt_sap_identifier,
    wait_list: ^ost$i_wait_list,
    wait_pointer: ^SEQ (REP nac$max_command_connections + index_bias of ost$i_activity) := ^wait_sequence,
    wait_sequence: SEQ (REP nac$max_command_connections + index_bias of ost$i_activity){systems+timer+SAP};

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$send_command', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$send_command (command: ^string ( * );
        system: string ( * <= nac$system_title_size );
        command_id: nat$command_identifier;
        retain_connection: boolean;
    VAR many_systems_specified: boolean;
    VAR status: ost$status);

{ PURPOSE: This procedure sends a network command to a single destination.
{ DESIGN:  Upon the first call to this procedure, a Generic Transport SAP
{          is opened (validation of Network Operator privilege will also
{          occur at this point). A translation request for the system title
{          will be initiated if a translation is not already known.
{          If a translation is available but the system is not connected,
{          a connection request is issued. If a connection exists, the command
{          is sent. Processing of the command is suspended after the
{          translation request, the connection request, or the command
{          transmission. The remaining processing is resumed when possible
{          by the next call to nap$receive_command_response.

    VAR
      address: nat$internet_address,
      command_pdu: [STATIC] nat$command_data_unit := [ nac$command_pdu_header_length,
            nac$command_protocol_version, *, nac$command_syntax_code, *],
      connection: ^command_connection,
      ignore_status: ost$status,
      index: integer,
      message: [STATIC] array [1 .. 2] of nat$data_fragment := [[^command_pdu, #SIZE (command_pdu)], [ * , * ]
        ],
      network_operation: boolean,
      wait_index: wait_list_index;

    status.normal := TRUE;
    IF NOT transport_sap_open THEN
      avp$get_capability (avc$network_operation, avc$user, network_operation, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF NOT network_operation THEN
        osp$set_status_abnormal (nac$status_id, nae$invalid_user, 'NETWORK OPERATOR UTILITY', status);
        RETURN;
      IFEND;
      command_pdu.privilege := nac$max_privilege;
      nap$gt_open_sap (nac$max_command_connections, nac$system_message_priority, {reserved_sap=} FALSE,
            transport_sap_id, address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      transport_sap_open := TRUE;
      nap$gt_receive_connect_event (transport_sap_id, connect_data, osc$nowait, connect_event,
            sap_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    /initialize_connection_entries/
      FOR index := 1 TO UPPERBOUND (connections) DO
        connections [index] := NIL;
      FOREND /initialize_connection_entries/;
      max_connection_index := 0;
      RESET wait_pointer;
      NEXT wait_list: [1 .. index_bias] IN wait_pointer;
      wait_list^ [timer_index].activity := osc$i_await_time;
      wait_list^ [sap_index].activity := nac$i_await_activity_status;
      wait_list^ [sap_index].activity_status := ^sap_status;
    IFEND;

    find_system (system, connection, wait_index);
    IF connection = NIL THEN
      IF many_systems_specified THEN
        cache_system_titles (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        many_systems_specified := FALSE;
        find_system (system, connection, wait_index);
      IFEND;
      IF connection = NIL THEN
        create_system_entry (system, connection, wait_index, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    connection^.retain := retain_connection;
    command_pdu.identifier := command_id;
    message [2].address := command;
    message [2].length := #SIZE (command^);

    CASE connection^.state OF
    = translation_required =
      request_translation (connection^, wait_index, status);
      IF status.normal THEN
        queue_command (message, connection^, status);
      IFEND;

    = connected =
      send_command (message, connection^, wait_index, status);
      IF (NOT status.normal) AND (status.condition = nae$system_disconnected) THEN {try to reconnect}
        status.normal := TRUE;
        connect_system (connection^, wait_index, status);
        IF status.normal THEN
          queue_command (message, connection^, status);
        IFEND;
      IFEND;

    = disconnected =
      connect_system (connection^, wait_index, status);
      IF status.normal THEN
        queue_command (message, connection^, status);
      IFEND;

    ELSE
      queue_command (message, connection^, status);
    CASEND;

    delete_inactive_connections := TRUE;

  PROCEND nap$send_command;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$receive_command_response', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$receive_command_response (wait_time: nat$wait_time;
        response: nat$data_fragment;
    VAR response_length: nat$data_length;
    VAR system: nat$system_title;
    VAR command_id: nat$command_identifier;
    VAR response_code: nat$command_response_code;
    VAR normal_response: boolean;
    VAR truncated: boolean;
    VAR status: ost$status);

{ PURPOSE: This procedure delivers a single response for a command sent to a system
{          in the network.
{ DESIGN:  All translation requests and connection requests initiated by the procedure
{          nap$send_command are processed when responses are available. When a data event
{          is received, it is returned as a command response to the caller.
{          Inactive connections are deleted on the first call to this routine after a call
{          to nap$send_command.

      PROCEDURE condition_handler (condition: pmt$condition;
            ignore_condition_descriptor: ^pmt$condition_information;
            sa: ^ost$stack_frame_save_area;
        VAR condition_status: ost$status);

        CASE condition.selector OF
        = pmc$system_conditions =
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        = ifc$interactive_condition =
          osp$set_status_condition (nae$no_event, status);
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        = pmc$user_defined_condition =
          IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
            osp$set_status_abnormal (nac$status_id, nae$job_recovery, 'NETWORK OPERATOR', status);
            pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          IFEND;
          condition_status.normal := TRUE;
        ELSE
          condition_status.normal := TRUE;
        CASEND;

      PROCEND condition_handler;

    VAR
      address: nat$osi_translation_address,
      alias_index: wait_list_index,
      alias_connection: ^command_connection,
      connection: ^command_connection,
      current_time: integer,
      end_time: integer,
      ignore_status: ost$status,
      index: integer,
      remaining_time: integer,
      response_buffer: array [1 .. 1] of nat$data_fragment,
      response_received: boolean,
      system_id: nat$system_identifier,
      system_identifier: ^nat$system_identifier,
      system_name: nat$system_title;

    status.normal := TRUE;

    pmp$get_microsecond_clock (current_time, ignore_status);
    end_time := (current_time DIV 1000) + wait_time;
    response_received := FALSE;

    IF delete_inactive_connections THEN
      FOR index := 1 to max_connection_index DO
        connection := connections [index];
        IF (connection^.state = connected) AND (connection^.queued_commands = NIL) AND (connection^.
              active_command_count = 0) AND (current_time > (connection^.last_activity_time +
              max_connection_idle_time)) THEN
          disconnect_system (connection^, index + index_bias, ignore_status);
        IFEND;
      FOREND;
      delete_inactive_connections := FALSE;
    IFEND;

    osp$establish_condition_handler (^condition_handler, {block exit=} FALSE);

    REPEAT
      pmp$get_microsecond_clock (current_time, ignore_status);
      remaining_time := end_time - (current_time DIV 1000);
      IF remaining_time > 0 THEN
        wait_list^ [timer_index].milliseconds := remaining_time;
      ELSE
        wait_list^ [timer_index].milliseconds := 1;
      IFEND;
      osp$i_await_activity_completion (wait_list^, index, status);
      IF status.normal THEN
        IF index = timer_index THEN
          osp$set_status_condition (nae$no_event, status);
        ELSEIF index = sap_index THEN
          nap$gt_disconnect (connect_event.connection, nil_data, ignore_status);
          nap$gt_receive_connect_event (transport_sap_id, connect_data, osc$nowait, connect_event,
                sap_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          connection := connections [index - index_bias];
          IF connection^.state = translation_requested THEN
            get_title_translation (connection^.request_id, system_name, system_id, address, status);
            IF status.normal THEN
              nlp$end_title_translation (connection^.request_id, ignore_status);
              find_alias (system_id, connection^.system, alias_connection, alias_index);
              IF alias_connection = NIL THEN
                connection^.address := address;
                connection^.system_id := system_id;
                connect_system (connection^, index, status);
              ELSE {send command on existing connection to alias entry}
                append_command_queue (connection^.queued_commands, alias_connection^);
                IF alias_connection^.state = disconnected THEN
                  connect_system (alias_connection^, alias_index, status);
                ELSEIF alias_connection^.state = connected THEN
                  send_queued_commands (alias_connection^, alias_index, status);
                ELSE
                  {no action required at this time...wait for pending event.
                IFEND;
                delete_connection (connection^, index, ignore_status);
              IFEND;
            ELSEIF status.condition = nae$no_translation_available THEN
              status.normal := TRUE;
            ELSEIF (status.condition = nae$translation_req_not_active) OR (status.condition =
                    nae$directory_search_complete) THEN
              osp$set_status_abnormal (nac$status_id, nae$unknown_system, connection^.system, status);
              delete_connection (connection^, index, ignore_status);
            ELSE {unexpected abnormal status}
            IFEND;

          ELSEIF NOT connection^.activity_status.status.normal THEN
            status := connection^.activity_status.status;

          ELSE
            CASE connection^.event.kind OF
            = nac$gt_data_event =
              response_received := TRUE;
              IF connection^.event.data.data_length - #SIZE (nat$command_response_data_unit) > 0 THEN
                response_length := connection^.event.data.data_length - #SIZE(nat$command_response_data_unit);
                i#move (^connection^.response.message_data, response.address, response_length);
              ELSE
                response_length := 0;
              IFEND;
              system := connection^.response.header.system_title;
              normal_response := connection^.response.header.flags.normal_response;
              truncated := connection^.response.header.flags.truncated;
              response_code := connection^.response.header.condition_code;
              command_id := connection^.response.header.command_id;
              connection^.active_command_count := connection^.active_command_count - 1;
              IF NOT connection^.event.data.end_of_message THEN {get rest of message}
                response_buffer [1].address := #address (#ring (response.address), #segment
                      (response.address), #offset (response.address) + response_length);
                response_buffer [1].length := response.length - response_length;
                nap$gt_receive_connection_event (connection^.connection_id, response_buffer, osc$wait,
                      connection^.event, connection^.activity_status, status);
                IF status.normal AND (connection^.event.kind = nac$gt_data_event) THEN
                  response_length := response_length + connection^.event.data.data_length;
                  truncated := truncated OR (NOT connection^.event.data.end_of_message);
                IFEND;
              IFEND;
              IF (connection^.active_command_count = 0) AND (NOT connection^.retain) THEN
                disconnect_system (connection^, index, ignore_status);
              ELSE
                response_buffer [1].address := ^connection^.response.header;
                response_buffer [1].length := #SIZE (command_response);
                nap$gt_receive_connection_event (connection^.connection_id, response_buffer, osc$nowait,
                      connection^.event, connection^.activity_status, status);
                pmp$get_microsecond_clock (connection^.last_activity_time, ignore_status);
              IFEND;

            = nac$gt_accept_event =
              connection^.state := connected;
              send_queued_commands (connection^, index, status);
              response_buffer [1].address := ^connection^.response.header;
              response_buffer [1].length := #SIZE (command_response);
              nap$gt_receive_connection_event (connection^.connection_id, response_buffer, osc$nowait,
                    connection^.event, connection^.activity_status, status);

            = nac$gt_disconnect_event, nac$gt_reject_event =
              IF connection^.state = connecting THEN
                osp$set_status_abnormal (nac$status_id, nae$command_connection_rejected, connection^.system,
                      status);
              ELSEIF connection^.active_command_count > 0 THEN
                osp$set_status_abnormal (nac$status_id, nae$access_lost, connection^.system, status);
              IFEND;
              delete_connection (connection^, index, ignore_status);

            ELSE
              pmp$log ('unexpected transport event type', ignore_status);
            CASEND;
          IFEND;
        IFEND;
      IFEND;

    UNTIL response_received OR NOT status.normal;

    osp$disestablish_cond_handler;

  PROCEND nap$receive_command_response;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$terminate_command', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$terminate_command (system: string ( * <= nac$system_title_size );
        retain_connection: boolean;
    VAR status: ost$status);

{ PURPOSE: This procedure terminates whatever activity is being performed for a specific
{          network system and returns an appropriate status response based on the current
{          state of that system. If a command has already been transmitted to a system,
{          execution of the command cannot be stopped by this procedure.

    VAR
      connection: ^command_connection,
      ignore_status: ost$status,
      wait_index: wait_list_index;

    status.normal := TRUE;
    find_system (system, connection, wait_index);

    IF connection <> NIL THEN
      connection^.retain := retain_connection;
      CASE connection^.state OF
      = translation_requested =
        nlp$end_title_translation (connection^.request_id, ignore_status);
        osp$set_status_abnormal (nac$status_id, nae$unknown_system, connection^.system, status);
        delete_connection (connection^, wait_index, ignore_status);

      = connecting =
        osp$set_status_abnormal (nac$status_id, nae$command_connection_ignored, connection^.system, status);
        delete_connection (connection^, wait_index, ignore_status);

      = connected =
        IF connection^.active_command_count > 0 THEN
          osp$set_status_abnormal (nac$status_id, nae$response_not_received, connection^.system, status);
          connection^.active_command_count := connection^.active_command_count - 1;
        IFEND;
        IF (connection^.active_command_count = 0) AND (NOT connection^.retain) THEN
          disconnect_system (connection^, wait_index, ignore_status);
        IFEND;

      ELSE
      CASEND;
    IFEND;

  PROCEND nap$terminate_command;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$end_command_processing', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$end_command_processing (VAR status: ost$status);

{ PURPOSE: This procedure terminates network command processing.
{ DESIGN:  All outstanding command connections are closed and the Generic
{          Transport SAP used for command connections is closed.


    status.normal := TRUE;

    IF transport_sap_open THEN

    /close_all_connections/
      WHILE max_connection_index > 0 DO
        delete_connection (connections [1]^, 1 + index_bias, {ignore} status);
      WHILEND /close_all_connections/;
      nap$gt_close_sap (transport_sap_id, status);
      transport_sap_open := FALSE;
    IFEND;
  PROCEND nap$end_command_processing;
?? OLDTITLE ??
?? NEWTITLE := 'append_command_queue', EJECT ??

  PROCEDURE append_command_queue (VAR command_queue: ^queued_command;
    VAR connection: command_connection);

    VAR
      index: integer,
      last_link: ^^queued_command;

    IF command_queue <> NIL THEN
      last_link := ^connection.queued_commands;
      WHILE last_link^ <> NIL DO
        last_link := ^last_link^^.link;
      WHILEND;
      last_link^ := command_queue;
      command_queue := NIL;
    IFEND;

  PROCEND append_command_queue;
?? OLDTITLE ??
?? NEWTITLE := 'cache_system_titles', EJECT ??

  PROCEDURE cache_system_titles (
    VAR status: ost$status);

{ If many translation requests are going to be required, a wild card translation request for all
{ system titles will first be issued so that the translations will be cached by Directory and we
{ will not flood the network with requests for individual titles. Note that Directory sends one
{ PDU to each known subnet for each active device in the host configuration.

    VAR
      address: nat$osi_translation_address,
      alias_connection: ^command_connection,
      alias_index: wait_list_index,
      ignore_status: ost$status,
      new_connection: ^command_connection,
      request_id: nat$directory_search_identifier,
      system_id: nat$system_identifier,
      system_name: nat$system_title,
      system_title: [STATIC] string (nac$system_title_size + nac$system_title_prefix_size) :=
            nac$system_title_prefix CAT '*',
      wait_index: wait_list_index;

    nlp$translate_title (system_title, {wild_card} TRUE, nac$unknown_protocol, {recurrent_search} FALSE,
          search_domain, nac$cdna_internal, request_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$wait (4000, 4000); {Wait no more than four seconds for first translation}
    REPEAT
      get_title_translation (request_id, system_name, system_id, address, status);
      IF (NOT status.normal) AND (status.condition = nae$no_translation_available) THEN
        pmp$wait (4000, 4000); {Wait no more than four seconds after the last translation arrives}
        get_title_translation (request_id, system_name, system_id, address, status);
      IFEND;
      IF status.normal THEN
        find_alias (system_id, system_name, alias_connection, alias_index);
        IF alias_connection = NIL THEN
          create_system_entry (system_name, new_connection, wait_index, status);
          IF status.normal THEN
            new_connection^.address := address;
            new_connection^.system_id := system_id;
            new_connection^.state := disconnected;
          IFEND;
        IFEND;
      IFEND;
    UNTIL NOT status.normal;
    IF status.condition <> nae$directory_search_complete THEN
      nlp$end_title_translation (request_id, ignore_status);
      IF status.condition = nae$no_translation_available THEN
        status.normal := TRUE;
      IFEND;
    ELSE
      status.normal := TRUE;
    IFEND;

  PROCEND cache_system_titles;
?? OLDTITLE ??
?? NEWTITLE := 'clear_connection', EJECT ??

  PROCEDURE clear_connection (VAR connection: command_connection;
        index: wait_list_index;
    VAR status: ost$status);

    VAR
      next_alias: ^system_alias,
      current_alias: ^system_alias;

    free_queued_commands (connection);
    IF (connection.state = connecting) OR (connection.state = connected) THEN
      disconnect_system (connection, index, status);
    IFEND;

    current_alias := connection.aliases;
    WHILE current_alias <> NIL DO
      next_alias := current_alias^.next_alias;
      FREE current_alias;
      current_alias := next_alias;
    WHILEND;

  PROCEND clear_connection;
?? OLDTITLE ??
?? NEWTITLE := 'connect_system', EJECT ??

  PROCEDURE connect_system (VAR connection: command_connection;
        wait_index: wait_list_index;
    VAR status: ost$status);

    VAR
      alternate_protocol_class: nat$ta_alternate_protocol_class,
      connection_data: array [1 .. 1] of nat$data_fragment,
      ignore_status: ost$status,
      preferred_protocol_class: nat$ta_preferred_protocol_class,
      protocol_version: [STATIC, READ] 0 .. 255 := nac$command_protocol_version,
      transport_address: nat$network_address;

    CASE connection.address.kind OF
    = nac$osi_transport_address =
      transport_address.kind := nac$osi_transport_address;
      transport_address.osi_transport_address := connection.address.osi_transport_address;
      preferred_protocol_class := nac$ta_preferred_class_4_clns;
      alternate_protocol_class := nac$ta_no_alternate_protocol;
    ELSE
      osp$set_status_abnormal (nac$status_id, nae$unsupported_address_kind, connection.system, status);
      osp$append_status_integer (osc$status_parameter_delimiter, connection.address.kind, 10, FALSE, status);
      RETURN;
    CASEND;

    connection_data [1].address := ^protocol_version;
    connection_data [1].length := #SIZE (protocol_version);
    nap$gt_request_connection (transport_sap_id, transport_address, connection_data, NIL,
          preferred_protocol_class, alternate_protocol_class, connection.connection_id, status);
    IF status.normal THEN
      connection.state := connecting;
      connection_data [1].address := ^connection.response;
      connection_data [1].length := #SIZE (connection.response);
      nap$gt_receive_connection_event (connection.connection_id, connection_data, osc$nowait,
            connection.event, connection.activity_status, status);
      wait_list^ [wait_index].activity := nac$i_await_activity_status;
      wait_list^ [wait_index].activity_status := ^connection.activity_status;
    ELSE
      delete_connection (connection, wait_index, ignore_status);
    IFEND;

  PROCEND connect_system;
?? OLDTITLE ??
?? NEWTITLE := 'create_system_entry', EJECT ??

  PROCEDURE create_system_entry (system: string ( * <= nac$system_title_size );
    VAR connection: ^command_connection;
    VAR wait_index: wait_list_index;
    VAR status: ost$status);

    PROCEDURE [INLINE] initialize_connection_entry (system: string ( * <= nac$system_title_size);
      VAR connection: command_connection);

      connection.system := system;
      connection.system_id := 0;
      connection.state := translation_required;
      connection.active_command_count := 0;
      connection.queued_commands := NIL;
      connection.aliases := NIL;

    PROCEND initialize_connection_entry;

    VAR
      connection_index: integer;

    IF max_connection_index < UPPERVALUE (max_connection_index) THEN
      max_connection_index := max_connection_index + 1;
      ALLOCATE connections [max_connection_index];
      connection := connections [max_connection_index];
      IF connection = NIL THEN
        max_connection_index := max_connection_index - 1;
        osp$set_status_abnormal (nac$status_id, nae$allocation_failed, 'command queue', status);
        RETURN;
      IFEND;
      initialize_connection_entry (system, connection^);
      wait_index := max_connection_index + index_bias;
      RESET wait_pointer;
      NEXT wait_list: [1 .. wait_index] IN wait_pointer;
      wait_list^ [wait_index].activity := osc$i_null_activity;
      RETURN;
    IFEND;

  /search_for_unused/
    FOR connection_index := 1 TO max_connection_index DO
      IF (connections [connection_index]^.state = disconnected) OR (connections [connection_index]^.state =
            translation_required) THEN
        connection := connections [connection_index];
        wait_index := connection_index + index_bias;
        clear_connection (connection^, wait_index, status);
        initialize_connection_entry (system, connection^);
        RETURN;
      IFEND;
    FOREND /search_for_unused/;

  /disconnect_inactive_entry/
    FOR connection_index := 1 TO max_connection_index DO
      IF (connections [connection_index]^.state = connected) AND (connections [connection_index]^.
            queued_commands = NIL) AND (connections [connection_index]^.active_command_count = 0) THEN
        connection := connections [connection_index];
        wait_index := connection_index + index_bias;
        clear_connection (connection^, wait_index, status);
        initialize_connection_entry (system, connection^);
        RETURN;
      IFEND;
    FOREND /disconnect_inactive_entry/;

    connection := NIL; {connection table full}
    osp$set_status_abnormal (nac$status_id, nae$allocation_failed, 'connection table', status);

  PROCEND create_system_entry;
?? OLDTITLE ??
?? NEWTITLE := 'delete_connection', EJECT ??

  PROCEDURE delete_connection (VAR connection: command_connection;
        index: wait_list_index;
    VAR status: ost$status);

    VAR
      next_alias: ^system_alias,
      current_alias: ^system_alias;

    status.normal := TRUE;
    clear_connection (connection, index, status);
    FREE connections [index - index_bias];
    IF max_connection_index > 1 THEN {compress connection list and wait list}
      connections [index - index_bias] := connections [max_connection_index];
      wait_list^ [index] := wait_list^ [UPPERBOUND (wait_list^)];
    IFEND;
    max_connection_index := max_connection_index - 1;
    RESET wait_pointer;
    NEXT wait_list: [1 .. max_connection_index + index_bias] IN wait_pointer;

  PROCEND delete_connection;
?? OLDTITLE ??
?? NEWTITLE := 'disconnect_system', EJECT ??

  PROCEDURE disconnect_system (VAR connection: command_connection;
        wait_index: wait_list_index;
    VAR status: ost$status);

    free_queued_commands (connection);
    nap$gt_disconnect (connection.connection_id, nil_data, status);
    connection.state := disconnected;
    wait_list^ [wait_index].activity := osc$i_null_activity;

  PROCEND disconnect_system;
?? OLDTITLE ??
?? NEWTITLE := 'find_alias', EJECT ??

  PROCEDURE find_alias (system_id: nat$system_identifier;
        system: nat$system_title;
    VAR connection: ^command_connection;
    VAR wait_index: wait_list_index);

    VAR
      connection_index: integer,
      current_alias: ^system_alias;

  /search_for_id/
    FOR connection_index := 1 TO max_connection_index DO
      IF connections [connection_index]^.system_id = system_id THEN
        connection := connections [connection_index];
        wait_index := connection_index + index_bias;
        ALLOCATE current_alias;
        current_alias^.system := system;
        current_alias^.next_alias := connection^.aliases;
        connection^.aliases := current_alias;
        RETURN;
      IFEND;
    FOREND /search_for_id/;

    connection := NIL;

  PROCEND find_alias;
?? OLDTITLE ??
?? NEWTITLE := 'find_system', EJECT ??

  PROCEDURE find_system (system: string ( * <= nac$system_title_size );
    VAR connection: ^command_connection;
    VAR wait_index: wait_list_index);

    VAR
      current_alias: ^system_alias,
      connection_index: integer;

  /search_for_title/
    FOR connection_index := 1 TO max_connection_index DO
      IF connections [connection_index]^.system = system THEN
        connection := connections [connection_index];
        wait_index := connection_index + index_bias;
        RETURN;
      ELSE
        current_alias := connections [connection_index]^.aliases;
        WHILE current_alias <> NIL DO
          IF current_alias^.system = system THEN
            connection := connections [connection_index];
            wait_index := connection_index + index_bias;
            RETURN;
          IFEND;
          current_alias := current_alias^.next_alias;
        WHILEND;
      IFEND;
    FOREND /search_for_title/;

    connection := NIL;

  PROCEND find_system;
?? OLDTITLE ??
?? NEWTITLE := 'free_queued_commands', EJECT ??

  PROCEDURE free_queued_commands (VAR connection: command_connection);

    VAR
      command_to_free: ^queued_command,
      next_command: ^queued_command;

    command_to_free := connection.queued_commands;
    connection.queued_commands := NIL;
    WHILE command_to_free <> NIL DO
      next_command := command_to_free^.link;
      FREE command_to_free;
      command_to_free := next_command;
    WHILEND;

  PROCEND free_queued_commands;
?? OLDTITLE ??
?? NEWTITLE := 'get_title_translation', EJECT ??

  PROCEDURE get_title_translation (request_id: nat$directory_search_identifier;
    VAR system_name: nat$system_title;
    VAR system_id: nat$system_identifier;
    VAR address: nat$osi_translation_address;
    VAR status: ost$status);

    VAR
      identifier: nat$directory_entry_identifier,
      network_address: ^SEQ ( * ),
      prefix: ^ SEQ ( * ),
      priority: nat$directory_priority,
      service: nat$protocol,
      system_identifier: ^nat$system_identifier,
      title: string (nac$max_title_length),
      user_identifier: ost$name,
      user_info_length: 0 .. nac$max_directory_data_length;


    nlp$get_title_translation (request_id, title, address, service, NIL, user_info_length, priority,
          user_identifier, identifier, status);
    IF status.normal THEN
      system_name := title (nac$system_title_prefix_size + 1, *);
      CASE address.kind OF
      = nac$osi_transport_address =
        network_address := ^address.osi_transport_address.network_address;
        RESET network_address;
        NEXT prefix: [[REP (address.osi_transport_address.network_address_length -
              #SIZE (nat$network_selector) - #SIZE (nat$system_identifier)) OF cell]] IN network_address;
        NEXT system_identifier IN network_address;
        system_id := system_identifier^;
      ELSE
        system_id := 0;
      CASEND;
    IFEND;

  PROCEND get_title_translation;

?? OLDTITLE ??
?? NEWTITLE := 'queue_command', EJECT ??

  PROCEDURE queue_command (command: nat$data_fragments;
    VAR connection: command_connection;
    VAR status: ost$status);

    VAR
      command_length: nat$data_length,
      index: integer,
      last_link: ^^queued_command,
      next_link: ^queued_command,
      save_address: ^SEQ ( * ),
      save_area: ^SEQ ( * );

    command_length := 0;
    FOR index := LOWERBOUND (command) TO UPPERBOUND (command) DO
      command_length := command_length + command [index].length;
    FOREND;

    last_link := ^connection.queued_commands;
    WHILE last_link^ <> NIL DO
      last_link := ^last_link^^.link;
    WHILEND;

    ALLOCATE next_link: [[REP command_length OF cell]];
    IF next_link <> NIL THEN
      last_link^ := next_link;
      last_link^^.link := NIL;
      save_area := ^next_link^.command;
      RESET save_area;

      FOR index := LOWERBOUND (command) TO UPPERBOUND (command) DO
        NEXT save_address: [[REP command [index].length OF cell]] IN save_area;
        i#move (command [index].address, save_address, command [index].length);
      FOREND;
    ELSE
      osp$set_status_abnormal (nac$status_id, nae$allocation_failed, 'command queue', status);
    IFEND;

  PROCEND queue_command;
?? OLDTITLE ??
?? NEWTITLE := 'request_translation', EJECT ??

  PROCEDURE request_translation (VAR connection: command_connection;
        wait_index: wait_list_index;
    VAR status: ost$status);

    VAR
      system_title: [STATIC] string (nac$system_title_size + nac$system_title_prefix_size) :=
            nac$system_title_prefix;

    system_title (nac$system_title_prefix_size + 1, * ) := connection.system;

    nlp$translate_title (system_title, {wild_card} FALSE, nac$unknown_protocol, {recurrent_search} FALSE,
          search_domain, nac$cdna_internal, connection.request_id, status);
    IF status.normal THEN
      connection.state := translation_requested;
      wait_list^ [wait_index].activity := nac$i_await_title_translation;
      wait_list^ [wait_index].translation_request := connection.request_id;
    IFEND;
  PROCEND request_translation;
?? OLDTITLE ??
?? NEWTITLE := 'send_command', EJECT ??

  PROCEDURE send_command (command: nat$data_fragments;
    VAR connection: command_connection;
        wait_index: wait_list_index;
    VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      send_status: ost$activity_status;

    IF connection.queued_commands <> NIL THEN
      send_queued_commands (connection, wait_index, status);
      IF NOT status.normal THEN
        free_queued_commands (connection);
        RETURN;
      IFEND;
    IFEND;

    nap$gt_send_data (connection.connection_id, command, {end_of_message=} TRUE, osc$wait, send_status,
          status);
    IF status.normal AND NOT send_status.status.normal THEN
      status := send_status.status;
    IFEND;
    IF status.normal THEN
      connection.active_command_count := connection.active_command_count + 1;
      pmp$get_microsecond_clock (connection.last_activity_time, ignore_status);
    ELSEIF status.condition = nae$connection_not_open THEN
      osp$set_status_abnormal (nac$status_id, nae$system_disconnected, connection.system, status);
      connection.state := disconnected;
      connection.active_command_count := 0;
      wait_list^ [wait_index].activity := osc$i_null_activity;
    IFEND;

  PROCEND send_command;
?? OLDTITLE ??
?? NEWTITLE := 'send_queued_commands', EJECT ??

  PROCEDURE send_queued_commands (VAR connection: command_connection;
        wait_index: wait_list_index;
    VAR status: ost$status);

    VAR
      command_to_free: ^queued_command,
      message: array [1 .. 1] of nat$data_fragment,
      queue: ^queued_command;

    queue := connection.queued_commands;
    connection.queued_commands := NIL;

    WHILE queue <> NIL DO
      message [1].address := ^queue^.command;
      message [1].length := #SIZE (queue^.command);
      send_command (message, connection, wait_index, status);
      IF NOT status.normal THEN
        connection.queued_commands := queue;
        RETURN;
      IFEND;
      command_to_free := queue;
      queue := queue^.link;
      FREE command_to_free;
    WHILEND;

  PROCEND send_queued_commands;

MODEND nam$send_command;
*DECK DECK=NAM$SE_EXTERNAL_INTERFACE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NAM/VE: Session Application Interface Layer' ??
?? NEWTITLE := '  Global Declarations' ??
MODULE nam$se_external_interface;
?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jmt$timesharing_signal
*copyc jmv$executing_within_system_job
*copyc nak$external_keypoints_job_mode
*copyc nat$create_attributes
*copyc nat$external_keypoint_constants
*copyc nat$network_address
*copyc nat$network_message_priority
*copyc nat$receiver_request
*copyc nat$sender_request
*copyc nlt$cc_connection
*copyc nlt$se_max_active_connections
*copyc nlt$sl_event
*copyc nlt$sl_inventory_report
*copyc nlt$sl_pdu_header
*copyc osd$integer_limits
*copyc ost$caller_identifier
*copyc oss$job_paged_literal
*copyc oss$network_paged
*copyc oss$task_private
*copyc ost$activity_status
*copyc ost$hardware_subranges
*copyc ost$wait
?? POP ??
*copyc nat$connection_state
*copyc nat$connection_descriptor
*copyc nat$se_event_element_queue
*copyc nat$se_supervisory_event_queue
?? TITLE := '  Status Condition Codes', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc ame$ring_validation_errors
*copyc cle$ecc_lexical
*copyc fme$file_management_errors
*copyc nae$application_interfaces
*copyc nae$internal_interactive_appl
?? POP ??
?? TITLE := '  External Procedures', EJECT ??
*copyc amp$return
*copyc amp$set_file_instance_abnormal
*copyc bap$validate_file_identifier
*copyc clp$convert_str_to_path_handle
*copyc fmp$clear_switch_offer
*copyc fmp$convert_status
*copyc fmp$create_network_file
*copyc fmp$get_connect_time_interval
*copyc fmp$get_connection_identifier
*copyc fmp$open_network_file
*copyc fmp$process_disconnect
*copyc fmp$record_nominal_disconnect
*copyc fmp$register_nominal_connection
*copyc fmp$remove_connection_id
*copyc fmp$set_switch_offer
*copyc fmp$simulate_connection_broken
*copyc fmp$store_connection_id
*copyc fmp$unsimulate_connection_broke
*copyc nap$delete_connection
*copyc nap$namve_system_error
*copyc nap$gt_close_job_connections
*copyc nap$gt_delete_job_saps
*copyc nap$move_data_to_user_data_area
*copyc nap$move_user_data_to_data_area
*copyc nap$process_connect_indication
*copyc nap$reset_received_message_list
*copyc nlp$al_deliver_data
*copyc nlp$al_fragment_data
*copyc nlp$al_get_data_length
*copyc nlp$al_get_data_requirements
*copyc nlp$al_initialize_data_descrip
*copyc nlp$bm_concatenate_messages
*copyc nlp$bm_create_message
*copyc nlp$bm_flush_message
*copyc nlp$bm_get_message_length
*copyc nlp$bm_get_message_prefix
*copyc nlp$bm_get_message_resources
*copyc nlp$bm_release_message
*copyc nlp$bm_valid_message_id
*copyc nlp$cancel_timer
*copyc nlp$cl_activate_layer
*copyc nlp$cl_activate_receiver
*copyc nlp$cl_activate_sender
*copyc nlp$cl_clear_exclusive_access
*copyc nlp$cl_create_connection
*copyc nlp$cl_deactivate_layer
*copyc nlp$cl_deactivate_receiver
*copyc nlp$cl_deactivate_sender
*copyc nlp$cl_get_connection_processor
*copyc nlp$cl_get_exclusive_via_cid
*copyc nlp$cl_get_layer_connection
*copyc nlp$cl_get_sap_processor
*copyc nlp$cl_initialize_template
*copyc nlp$cl_release_exclusive_access
*copyc nlp$osi_get_outbound_capacity
*copyc nlp$select_timer
*copyc nlp$sk_process_job_recovery
*copyc nlp$sl_call_request
*copyc nlp$sl_call_response
*copyc nlp$sl_clear_request
*copyc nlp$sl_close_sap
*copyc nlp$sl_data_request
*copyc nlp$sl_initialize
*copyc nlp$sl_interrupt_request
*copyc nlp$sl_open_sap
*copyc nlp$sl_synch_request
*copyc nlp$sl_synch_response
*copyc nlp$ta_report_undelivered_data
*copyc nlp$timer_expired
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$copy_local_status_to_status
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$format_message
*copyc osp$increment_locked_variable
*copyc osp$is_caller_system_privileged
*copyc osp$pop_inhibit_job_recovery
*copyc osp$push_inhibit_job_recovery
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc pmp$continue_to_cause
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_job_monitor_gtid
*copyc pmp$ready_task
*copyc pmp$send_signal
*copyc syp$cycle
?? TITLE := '  Global Variables', EJECT ??
*copyc bav$last_tft_entry
*copyc bav$task_file_table
*copyc bav$tft_entry_assignment
*copyc nlv$bm_null_message_id
*copyc jmv$connection_acquired
*copyc nav$global_statistics
*copyc nav$namve_active
*copyc nav$network_paged_heap
*copyc nav$statistics_enabled
*copyc osv$task_private_heap

  CONST
    nac$maximum_connect_data = 512,
    nac$maximum_termination_data = 512,
    nac$inactive_receiver_timeout = 600000000;

{ nat$vtp_output_data is used only in nap$process_sap_events.  It is needed for
{ any error messages that are sent to the TIP.

  TYPE
    nat$vtp_output_data = packed record
      message_type: 0 .. 0ff(16),
      formatting_mode: 0 .. 0ff(16),
      filler1: 0 .. 1f(16),
      suppress_echoplex: boolean,
      suppress_end_of_line_partition: boolean,
      partial_output: boolean,
      filler2: 0 .. 0ff(16),
    recend;

  VAR
    nav$eoi_message: [STATIC, READ, oss$job_paged_literal] nat$eoi_message := [4, '*EOI'],
    nav$se_initialized_connection: [STATIC, READ, oss$job_paged_literal] nat$connection_descriptor := [
{sender_request}*, {receiver_request}*, {send_timeout}FALSE, {receive_timeout}FALSE, {connection_state}*,
{wait_state}nac$inactive_wait, {await_server_response_task_id}*, {await_server_response}FALSE,
{intermediate_put_partial}FALSE, {send_put_partial}FALSE, {record_length}0,{transfer_count}0,
{client}FALSE, {application_name}*, {simulated_connection_broken}FALSE, {break_condition_active}FALSE,
{break_connection_receive}FALSE, {break_connection_send}FALSE, {discard_to_end_of_message}FALSE,
{synchronize_receive}FALSE,{synchronize_send}FALSE,{synchronize_request_receive}FALSE,
{synchronize_request_send}FALSE,{nominal_connection}FALSE, {nominal_connection_task_id}* ,
{receive_synchronize_count}0, {send_synchronize_count}0, {receive_file_identifier}* ,
{send_file_identifier}* , {total_data_queued}0, {total_message_buffers}0, {event_timer}*,
{receive_timer}*,{send_timer}*, {timesharing_disconnect_sent}FALSE,
{job_monitor_task_id} *, {local_file_name} ' ', {client_identity}[' ', ' '],
{connect_data}NIL, {data_transfer_timeout}60000, {eoi_message_enabled}FALSE, {eoi_message}NIL,
{eoi_peer_termination}FALSE, {local_address}*, {peer_accounting_information}NIL, {peer_address}*,
{peer_connect_data}NIL, {peer_termination_data}NIL, {receive_wait_swapout}FALSE,
{termination_data}NIL, {termination_reason}*, {protocol}nac$cdna_session,
{data_queue}[0, NIL, NIL], {supervisory_event_queue}[NIL, NIL], {event}*],

    nav$null_data: [STATIC, READ, oss$job_paged_literal] array [1 .. 1] of nat$data_fragment := [[NIL, 0]],
    application_kind: [STATIC, READ, oss$job_paged_literal] array [boolean] of nat$application_type :=
          [nac$server_application, nac$client_application],
    invalid_file_identifier: [STATIC, READ, oss$job_paged_literal] string (23) := 'Invalid file identifier';

?? TITLE := ' Internal Declarations', EJECT ??

  TYPE
    nat$se_condition_cause = (nac$application_data, nac$application_event, nac$activity_status,
          nac$request_not_cause);

?? TITLE := 'NAP$SE_REQUEST_CONNECTION' ??
?? NEWTITLE := '    TERMINATE_REQUEST_CONNECTION -- CONDITION HANDLER', EJECT ??

  PROCEDURE [XDCL] nap$se_request_connection
    (    sap_id: nat$generic_sap_identifier;
         server: nat$network_address;
         client: nat$application_name;
         file: fst$file_reference;
         attributes: ^nat$create_attributes;
         sap_priority: nat$network_message_priority;
     VAR connection_id: nat$connection_id;
     VAR status: ost$status);


    PROCEDURE terminate_request_connection
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        IF cl_connection <> NIL THEN
          connection^.connection_state := nac$terminated;
          terminate_connection (connection, cl_connection);
          nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
          nlp$cl_clear_exclusive_access (cl_connection);
          fmp$remove_connection_id (file, local_status);
          amp$return (file, local_status);
        IFEND;
        osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
        EXIT nap$se_request_connection;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      = pmc$block_exit_processing =
        IF cl_connection <> NIL THEN
          connection^.connection_state := nac$terminated;
          terminate_connection (connection, cl_connection);
          nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
          nlp$cl_clear_exclusive_access (cl_connection);
          fmp$remove_connection_id (file, local_status);
          amp$return (file, local_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_request_connection;
?? OLDTITLE, EJECT ??

    VAR
      cl_connection: ^nlt$cl_connection,
      condition_cause: nat$se_condition_cause,
      connection: ^nat$connection_descriptor,
      connection_exits: boolean,
      data_fragment: nat$data_fragment,
      evaluated_file_reference: fst$evaluated_file_reference,
      layer_active: boolean,
      local_status: ost$status;

    status.normal := TRUE;
    condition_cause := nac$request_not_cause;
    #SPOIL (condition_cause);
    cl_connection := NIL;
    #SPOIL (cl_connection);
    osp$establish_condition_handler (^terminate_request_connection, TRUE);
    IF server.kind = nac$osi_transport_address THEN
      nlp$cl_create_connection (nlc$osi_session_interface, cl_connection);
    ELSE
      osp$set_status_condition (nae$unsupported_address, status);
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    IF cl_connection <> NIL THEN
      nlp$cl_activate_layer (cl_connection^.application_layer, cl_connection);
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      #SPOIL (connection);
      connection^ := nav$se_initialized_connection;
      nlp$cancel_timer (connection^.send_timer);
      connection^.receive_timer := connection^.send_timer;
      connection^.event_timer := connection^.send_timer;
      connection^.peer_address := server;
      connection^.local_address.kind := nac$osi_sap_identifier;
      connection^.local_address.identifier := sap_id.osi_sap_identifier;
      connection^.protocol := nac$cdna_session;
      connection^.connection_state := nac$connection_request_sent;
      connection^.application_name := client;
      connection^.client := TRUE;
      pmp$get_job_monitor_gtid (connection^.job_monitor_task_id, local_status);
      clp$convert_str_to_path_handle (file, {delete_allowed=} TRUE, {resolve_path=} TRUE,
            {include_open_position=} TRUE, connection^.local_file_name, evaluated_file_reference, status);
      connection_id := cl_connection^.identifier;
      REPEAT
        ALLOCATE connection^.data_queue.beginning IN nav$network_paged_heap^;
        IF connection^.data_queue.beginning = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL connection^.data_queue.beginning <> NIL;
      connection^.data_queue.ending := connection^.data_queue.beginning;
      connection^.data_queue.beginning^.next_element := NIL;
      create_network_file (file, attributes, cl_connection^.identifier, connection, status);
      IF status.normal THEN
        data_fragment.address := connection^.connect_data;
        IF connection^.connect_data <> NIL THEN
          data_fragment.length := #SIZE (connection^.connect_data^);
        ELSE
          data_fragment.length := 0;
        IFEND;
        nlp$sl_call_request (cl_connection, sap_id, server, client, data_fragment, sap_priority, status);
        IF NOT status.normal THEN
          connection^.connection_state := nac$terminated;
          terminate_connection (connection, cl_connection);
          nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
          nlp$cl_release_exclusive_access (cl_connection);
          fmp$remove_connection_id (file, local_status);
          amp$return (file, local_status);
        ELSE
          nlp$cl_release_exclusive_access (cl_connection);
        IFEND;
      ELSE
        FREE connection^.data_queue.beginning IN nav$network_paged_heap^;
        nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
        nlp$cl_release_exclusive_access (cl_connection);
        IF (status.condition = nae$unknown_attribute) OR (status.condition = nae$max_data_length_exceeded) OR
              (status.condition = nae$invalid_eoi_message_size) THEN
          fmp$remove_connection_id (file, {ignore} local_status);
          amp$return (file, {ignore} local_status);
        IFEND;
      IFEND;
    ELSE
      osp$set_status_condition (nae$namve_max_connection_limit, status);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND nap$se_request_connection;
?? TITLE := 'NAP$CREATE_NETWORK_FILE' ??
?? NEWTITLE := '    TERMINATE_CREATE_NETWORK_FILE -- CONDITION HANDLER', EJECT ??

  PROCEDURE [XDCL] nap$create_network_file
    (    file: fst$file_reference;
         attributes: ^nat$create_attributes;
         connection_id: nat$connection_id;
         timesharing_connection_switch: boolean;
     VAR status: ost$status);


    PROCEDURE terminate_create_network_file
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF cl_connection <> NIL THEN
          nlp$cl_clear_exclusive_access (cl_connection);
          IF NOT timesharing_connection_switch THEN
            fmp$remove_connection_id (file, ignore_status);
            amp$return (file, ignore_status);
          IFEND;
        IFEND;
        osp$pop_inhibit_job_recovery;
        osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
        EXIT nap$create_network_file;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_create_network_file;
?? OLDTITLE, EJECT ??

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      evaluated_file_reference: fst$evaluated_file_reference,
      ignore_status: ost$status,
      layer_active: boolean;

    status.normal := TRUE;
    IF NOT timesharing_connection_switch THEN
      cl_connection := NIL;
      osp$push_inhibit_job_recovery;
      osp$establish_condition_handler (^terminate_create_network_file, FALSE);
      nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
      IF connection_exists THEN
        nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active,
              connection);
        IF layer_active THEN
          create_network_file (file, attributes, connection_id, connection, status);
          IF status.normal THEN
            pmp$get_job_monitor_gtid (connection^.job_monitor_task_id, status);
            clp$convert_str_to_path_handle (file, {delete_allowed=} TRUE, {resolve_path=} TRUE,
                  {include_open_position=} TRUE, connection^.local_file_name, evaluated_file_reference,
                  status);
            nlp$cl_release_exclusive_access (cl_connection);
          ELSE
            nlp$cl_release_exclusive_access (cl_connection);
            IF (status.condition = nae$unknown_attribute) OR (status.condition =
                  nae$max_data_length_exceeded) OR (status.condition = nae$invalid_eoi_message_size) THEN
              fmp$remove_connection_id (file, ignore_status);
              amp$return (file, ignore_status);
            IFEND;
          IFEND;
        ELSE
          nlp$cl_release_exclusive_access (cl_connection);
          osp$set_status_condition (nae$connection_terminated, status);
        IFEND;
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      osp$pop_inhibit_job_recovery;
    ELSE { IF timesharing_connection_switch THEN
      osp$push_inhibit_job_recovery;
      nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
      IF connection_exists THEN
        nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active,
              connection);
        IF layer_active THEN
          pmp$get_job_monitor_gtid (connection^.job_monitor_task_id, status);
          clp$convert_str_to_path_handle (file, {delete_allowed=} TRUE, {resolve_path=} TRUE,
                {include_open_position=} TRUE, connection^.local_file_name, evaluated_file_reference, status);
        IFEND;
        nlp$cl_release_exclusive_access (cl_connection);
      IFEND;
      osp$pop_inhibit_job_recovery;
      fmp$store_connection_id (file, connection_id, status);
      IF NOT status.normal THEN
        IF status.condition = fme$no_cycle_description THEN
          osp$set_status_abnormal ('AM', ame$file_not_known, file, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'NAP$CREATE_NETWORK_FILE ', status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND nap$create_network_file;

?? TITLE := 'CREATE_NETWORK_FILE', EJECT ??

  PROCEDURE create_network_file
    (    file: fst$file_reference;
         attributes: ^nat$create_attributes;
         connection_id: nat$connection_id;
         connection: ^nat$connection_descriptor;
     VAR status: ost$status);

    VAR
      error_string: string (256),
      i: integer,
      length: integer,
      local_status: ost$status;

    status.normal := TRUE;
    fmp$create_network_file (file, connection_id, connection^.connection_state, status);
    IF status.normal THEN
      IF attributes <> NIL THEN
        FOR i := LOWERBOUND (attributes^) TO UPPERBOUND (attributes^) DO
          CASE attributes^ [i].kind OF
          = nac$connect_data =
            IF ((attributes^ [i].connect_data <> NIL) AND (#SIZE (attributes^ [i].connect_data^) <=
                  nac$maximum_connect_data)) OR (attributes^ [i].connect_data = NIL) THEN
              nap$move_user_data_to_data_area (attributes^ [i].connect_data, connection^.connect_data);
            ELSE
              STRINGREP (error_string, length, nac$maximum_connect_data, ' for NAC$CONNECT_DATA');
              osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, error_string, status);
            IFEND;
          = nac$data_transfer_timeout =
            connection^.data_transfer_timeout := attributes^ [i].data_transfer_timeout;
          = nac$eoi_message =
            IF attributes^ [i].eoi_message.size <= 31 {nac$maximum_eoi_size} THEN
              IF connection^.eoi_message = NIL THEN
                REPEAT
                  ALLOCATE connection^.eoi_message IN nav$network_paged_heap^;
                  IF connection^.eoi_message = NIL THEN
                    syp$cycle;
                  IFEND;
                UNTIL connection^.eoi_message <> NIL;
              IFEND;
              connection^.eoi_message^ := attributes^ [i].eoi_message;
            ELSE
              osp$set_status_abnormal (nac$status_id, nae$invalid_eoi_message_size, '31'
                    {nac$maximum_eoi_size} , status);
            IFEND;
          = nac$eoi_message_enabled =
            connection^.eoi_message_enabled := attributes^ [i].eoi_message_enabled;
          = nac$eoi_peer_termination =
            connection^.eoi_peer_termination := attributes^ [i].eoi_peer_termination;
          = nac$null_attribute =
          = nac$receive_wait_swapout =
            connection^.receive_wait_swapout := attributes^ [i].receive_wait_swapout;
          = nac$termination_data =
            IF ((attributes^ [i].termination_data <> NIL) AND
                  (#SIZE (attributes^ [i].termination_data^) <= nac$maximum_termination_data)) OR
                  (attributes^ [i].termination_data = NIL) THEN
              nap$move_user_data_to_data_area (attributes^ [i].termination_data,
                    connection^.termination_data);
            ELSE
              STRINGREP (error_string, length, nac$maximum_termination_data, ' for NAC$TERMINATION_DATA');
              osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, error_string, status);
            IFEND;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$unknown_attribute, ' for CREATE NETWORK FILE ',
                  status);
            RETURN;
          CASEND;
        FOREND;
      IFEND;
    IFEND;
  PROCEND create_network_file;
?? TITLE := '  [XDCL] NAP$CHECK_SERVER_RESPONSE', EJECT ??

  PROCEDURE [XDCL] nap$check_server_response
    (    file: fst$file_reference;
     VAR activity_complete: boolean;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      connection_id: nat$connection_id,
      layer_active: boolean,
      processing_task: ost$global_task_id,
      switch_offer_pending: boolean;

    status.normal := TRUE;
    activity_complete := TRUE;
    fmp$get_connection_identifier (file, connection_id, switch_offer_pending, status);
    IF NOT status.normal THEN
      IF status.condition = fme$no_cycle_description THEN
        osp$set_status_abnormal ('AM', ame$file_not_known, file, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'A CHECK SERVER RESPONSE ', status);
      ELSEIF status.condition <> ame$improper_device_class THEN
        status.normal := TRUE;
      IFEND;
      RETURN;
    IFEND;

    IF switch_offer_pending THEN
      osp$set_status_abnormal (nac$status_id, nae$switch_offer_pending, file, status);
      RETURN;
    IFEND;
    osp$push_inhibit_job_recovery;
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        IF connection^.connection_state = nac$connection_request_sent THEN
          pmp$get_executing_task_gtid (processing_task);
          IF connection^.await_server_response THEN
            IF processing_task <> connection^.await_server_response_task_id THEN
              osp$set_status_abnormal (nac$status_id, nae$multiple_waits_attempted, file, status);
            ELSE
              activity_complete := FALSE;
            IFEND;
          ELSE
            activity_complete := FALSE;
            connection^.await_server_response := TRUE;
            connection^.await_server_response_task_id := processing_task;
          IFEND;
        IFEND;
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$check_server_response;

?? TITLE := '  [XDCL] NAP$REMOVE_WAIT_SERVER_RESPONSE', EJECT ??

  PROCEDURE [XDCL] nap$remove_wait_server_response
    (    file: fst$file_reference);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      connection_id: nat$connection_id,
      layer_active: boolean,
      processing_task: ost$global_task_id,
      switch_offer_pending: boolean,
      status: ost$status;

    fmp$get_connection_identifier (file, connection_id, switch_offer_pending, status);
    IF NOT status.normal THEN
      IF status.condition = fme$no_cycle_description THEN
        osp$set_status_abnormal ('AM', ame$file_not_known, file, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'A REMOVE SERVER RESPONSE WAITS ',
              status);
      IFEND;
    IFEND;

    IF switch_offer_pending THEN
      RETURN;
    IFEND;
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        IF connection^.connection_state <> nac$terminated THEN
          IF connection^.await_server_response THEN
            pmp$get_executing_task_gtid (processing_task);
            IF processing_task = connection^.await_server_response_task_id THEN
              connection^.await_server_response := FALSE;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    IFEND;
  PROCEND nap$remove_wait_server_response;
?? TITLE := '  [XDCL] NAP$CHECK_DATA_AVAILABLE', EJECT ??

  PROCEDURE [XDCL] nap$check_data_available
    (    file_identifier: amt$file_identifier;
     VAR activity_complete: boolean;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      layer_active: boolean,
      message_id: nlt$bm_message_id,
      processing_task: ost$global_task_id;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    activity_complete := TRUE;
    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_condition (ame$improper_file_id, status);
      RETURN;
    IFEND;

    IF file_instance^.device_class <> rmc$network_device THEN
      osp$set_status_condition (ame$improper_device_class, status);
      RETURN;
    IFEND;

    IF caller_id.ring > file_instance^.instance_attributes.static_label.ring_attributes.r2 THEN
      amp$set_file_instance_abnormal (file_identifier, ame$ring_validation_error, nac$await_data_available,
            '', status);
      RETURN;
    IFEND;
    osp$push_inhibit_job_recovery;
    nlp$cl_get_exclusive_via_cid (file_instance^.global_file_information^.device_dependent_info.
          network_connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        IF connection^.wait_state = nac$inactive_wait THEN
          IF (connection^.supervisory_event_queue.beginning <> NIL) OR
                ((connection^.data_queue.count > 0) AND ((connection^.total_data_queued >= 4096
                {nac$min_await_data_avail} ) OR (connection^.data_queue.beginning^.
                event_element [connection^.data_queue.beginning^.first].event.end_of_message) OR
                (connection^.total_message_buffers_queued >= 4))) THEN
            activity_complete := TRUE;
          ELSEIF (connection^.connection_state <> nac$terminated) AND
                (NOT connection^.break_condition_active) AND (NOT connection^.simulated_connection_broken)
                THEN
            nlp$cl_activate_receiver (cl_connection);
            connection^.wait_state := nac$waiting_for_data_available;
            activity_complete := FALSE;
          IFEND;
        ELSEIF connection^.wait_state = nac$waiting_for_data_available THEN
          pmp$get_executing_task_gtid (processing_task);
          IF processing_task <> cl_connection^.message_receiver.task THEN
            osp$set_status_condition (nae$multiple_waits_attempted, status);
          ELSE
            activity_complete := FALSE;
          IFEND;
        ELSE {IF connection^.wait_state = nac$wait_to_receive_data THEN
          osp$set_status_condition (nae$multiple_waits_attempted, status);
        IFEND;
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$check_data_available;
?? TITLE := '  [XDCL] NAP$REMOVE_WAIT_DATA_AVAILABLE', EJECT ??

  PROCEDURE [XDCL] nap$remove_wait_data_available
    (    file_identifier: amt$file_identifier);

    VAR
      caller_id: ost$caller_identifier,
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      layer_active: boolean,
      processing_task: ost$global_task_id,
      status: ost$status;

    #CALLER_ID (caller_id);
    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF NOT file_is_valid THEN
      RETURN;
    IFEND;

    IF caller_id.ring > file_instance^.instance_attributes.static_label.ring_attributes.r2 THEN
      RETURN;
    IFEND;

    nlp$cl_get_exclusive_via_cid (file_instance^.global_file_information^.device_dependent_info.
          network_connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        IF connection^.connection_state <> nac$terminated THEN
          IF connection^.wait_state = nac$waiting_for_data_available THEN
            pmp$get_executing_task_gtid (processing_task);
            IF processing_task = cl_connection^.message_receiver.task THEN
              nlp$cl_deactivate_receiver (cl_connection);
              connection^.wait_state := nac$inactive_wait;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    IFEND;
  PROCEND nap$remove_wait_data_available;
?? TITLE := ' [XDCL] nlp$se_initialize', EJECT ??
*copyc nlh$se_initialize

  PROCEDURE [XDCL] nlp$se_initialize;

    VAR
      sap_processor: nlt$cl_event_processor,
      connection_processor: nlt$cl_event_processor;

    nlp$cl_initialize_template (nlc$osi_session_interface, nlc$osi_session_interface,
          #SIZE (nat$connection_descriptor), 0, sap_processor, nac$monitor_server_connections
          { This is for nam$application_management} , connection_processor, nac$se_evaluate_io_timers);
    nlp$sl_initialize (nac$se_process_sap_event, nac$se_process_connection_event, nlc$osi_session_interface);
  PROCEND nlp$se_initialize;
?? TITLE := '  [XDCL] NLP$SE_CLOSE_SAP', EJECT ??

  PROCEDURE [XDCL] nlp$se_close_sap
    (    sap: nat$generic_sap_identifier;
     VAR status: ost$status);

    status.normal := TRUE;
    osp$push_inhibit_job_recovery;
    nlp$sl_close_sap (sap, status);
    osp$pop_inhibit_job_recovery;
  PROCEND nlp$se_close_sap;
?? TITLE := ' [XDCL] NLP$SE_OPEN_SAP', EJECT ??
*copyc nlh$se_open_sap

  PROCEDURE [XDCL] nlp$se_open_sap
    (    sap_timer_evaluator: nat$network_procedure;
         accept_connect_events: boolean;
         maximum_active_connections: nlt$se_max_active_connections;
     VAR status: ost$status);

    VAR
      sap_processor: nlt$cl_event_processor,
      connection_processor: nlt$cl_event_processor;

    IF NOT nav$namve_active THEN
      osp$set_status_condition (nae$network_inactive, status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    IF ((maximum_active_connections > 0) AND (maximum_active_connections <=
          UPPERVALUE (nlt$se_max_active_connections))) THEN
      osp$push_inhibit_job_recovery;
      nlp$cl_initialize_template (nlc$osi_session_interface, nlc$osi_session_interface,
            #SIZE (nat$connection_descriptor), 0, sap_processor, sap_timer_evaluator, connection_processor,
            nac$se_evaluate_io_timers);
      nlp$sl_open_sap (nac$se_process_sap_event, nac$se_process_connection_event, nlc$osi_session_interface,
            accept_connect_events, maximum_active_connections, status);
      osp$pop_inhibit_job_recovery;
    ELSEIF (maximum_active_connections = 0) THEN
      osp$set_status_condition (nae$max_active_connections_0, status);
    ELSE
      osp$set_status_condition (nae$max_active_conn_exceeded, status);
    IFEND;
  PROCEND nlp$se_open_sap;
?? TITLE := '  [XDCL] NLP$SE_ACCEPT_CONNECTION', EJECT ??

  PROCEDURE [XDCL] nlp$se_accept_connection
    (    cl_connection: ^nlt$cl_connection;
     VAR status: ost$status);

    VAR
      connection: ^nat$connection_descriptor,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      layer_active: boolean,
      message_id: nlt$bm_message_id;

    status.normal := TRUE;
    osp$push_inhibit_job_recovery;
    nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
    IF layer_active THEN
      IF connection^.connection_state = nac$connection_request_received THEN
        IF connection^.connect_data <> NIL THEN
          data_fragments [1].address := connection^.connect_data;
          data_fragments [1].length := #SIZE (connection^.connect_data^);
        ELSE
          data_fragments [1] := nav$null_data [1];
        IFEND;
        nlp$sl_call_response (cl_connection, data_fragments, status);
        IF status.normal THEN
          connection^.connection_state := nac$established;
        IFEND;
      ELSEIF connection^.connection_state = nac$terminated THEN
        osp$set_status_condition (nae$connection_terminated, status);
      ELSE
        osp$set_status_condition (nae$invalid_request, status);
      IFEND;
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nlp$se_accept_connection;

?? TITLE := '[XDCL] nap$get_connect_time_interval', EJECT ??

*copy nah$get_connect_time_interval

  PROCEDURE [XDCL] nap$get_connect_time_interval
    (    file: fst$file_reference;
     VAR connect_time: ost$non_negative_integers;
     VAR status: ost$status);

    status.normal := TRUE;
    osp$push_inhibit_job_recovery;
    fmp$get_connect_time_interval (file, connect_time, status);
    osp$pop_inhibit_job_recovery;
  PROCEND nap$get_connect_time_interval;

?? TITLE := '  [XDCL] NAP$GET_CONNECTION_IDENTIFIER', EJECT ??

  PROCEDURE [XDCL] nap$get_connection_identifier
    (    file: fst$file_reference;
     VAR connection_id: nat$connection_id;
     VAR status: ost$status);

    VAR
      switch_offer_pending: boolean;

    status.normal := TRUE;

    fmp$get_connection_identifier (file, connection_id, switch_offer_pending, status);
    IF NOT status.normal THEN
      IF status.condition = fme$no_cycle_description THEN
        osp$set_status_abnormal ('AM', ame$file_not_known, file, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'A GET CONNECTION IDENTIFIER ', status);
      IFEND;
    IFEND;
  PROCEND nap$get_connection_identifier;
?? TITLE := '  [XDCL, #GATE] nap$get_connection_state', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$get_connection_state
    (    connection_id: nat$connection_id;
     VAR connection_state: nat$connection_state;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      connection: ^nat$connection_descriptor,
      layer_active: boolean;

    #CALLER_ID (caller_id);
    IF caller_id.ring > 3 THEN
      osp$set_status_abnormal ('NA', nae$insufficient_privilege, 'nap$get_connection_state', status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        connection_state := connection^.connection_state;
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
  PROCEND nap$get_connection_state;
?? TITLE := '  [XDCL] NAP$REMOVE_CONNECTION_ID', EJECT ??

  PROCEDURE [XDCL] nap$remove_connection_id
    (    file: fst$file_reference;
     VAR status: ost$status);

    status.normal := TRUE;

    fmp$remove_connection_id (file, status);
  PROCEND nap$remove_connection_id;
?? TITLE := '  [XDCL] NAP$CLEAR_SWITCH_OFFER', EJECT ??

  PROCEDURE [XDCL] nap$clear_switch_offer
    (    file: fst$file_reference;
         switch_complete: boolean;
     VAR status: ost$status);

    status.normal := TRUE;

    fmp$clear_switch_offer (file, switch_complete, status);
  PROCEND nap$clear_switch_offer;
?? TITLE := '  [XDCL] NAP$SET_SWITCH_OFFER', EJECT ??

  PROCEDURE [XDCL] nap$set_switch_offer
    (    file: fst$file_reference;
         timesharing_connection_switch: boolean;
     VAR connection_id: nat$connection_id;
     VAR application_name: nat$application_name;
     VAR status: ost$status);

    status.normal := TRUE;

    fmp$set_switch_offer (file, timesharing_connection_switch, application_name, connection_id, status);
    IF NOT status.normal THEN
      IF status.condition = fme$no_cycle_description THEN
        osp$set_status_abnormal ('AM', ame$file_not_known, file, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'A OFFER SWITCH ', status);
      IFEND;
    IFEND;
  PROCEND nap$set_switch_offer;
?? TITLE := '  [XDCL] NLP$SWITCH_OFFER_SET', EJECT ??

  PROCEDURE [XDCL] nlp$switch_offer_set
    (    connection_id: nat$connection_id;
     VAR application_name: nat$application_name;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      layer_active: boolean;

    status.normal := TRUE;
    application_name := ' ';
    osp$push_inhibit_job_recovery;
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        IF NOT connection^.nominal_connection THEN
          application_name := connection^.application_name;
        ELSE
          osp$set_status_condition (nae$nominal_connection, status);
        IFEND;
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nlp$switch_offer_set;
?? TITLE := '  [XDCL] NLP$REGISTER_NOMINAL_CONNECTION', EJECT ??

  PROCEDURE [XDCL] nlp$register_nominal_connection
    (    file: fst$file_reference;
     VAR status: ost$status);

    status.normal := TRUE;

    fmp$register_nominal_connection (file, status);
  PROCEND nlp$register_nominal_connection;
?? TITLE := '  [XDCL] NLP$NOMINAL_CONN_REGISTRATION', EJECT ??

  PROCEDURE [XDCL] nlp$nominal_conn_registration
    (    connection_id: nat$connection_id;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      ignore_status: ost$status,
      layer_active: boolean;

    status.normal := TRUE;
    osp$push_inhibit_job_recovery;
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN

        ; {do not allow request if synch_confirm is required

        IF NOT connection^.nominal_connection THEN
          IF connection^.simulated_connection_broken THEN
            connection^.simulated_connection_broken := FALSE;
          IFEND;
          connection^.nominal_connection := TRUE;
          pmp$get_job_monitor_gtid (connection^.nominal_connection_task_id, ignore_status);
          IF connection^.supervisory_event_queue.beginning <> NIL THEN
            process_nominal_connect_events (connection, cl_connection);
          IFEND;
        ELSE
          osp$set_status_condition (nae$nominal_connection, status);
        IFEND;
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nlp$nominal_conn_registration;
?? TITLE := '  [XDCL] NLP$SIMULATE_CONNECTION_BROKEN', EJECT ??

  PROCEDURE [XDCL] nlp$simulate_connection_broken
    (    file: fst$file_reference;
     VAR status: ost$status);

    status.normal := TRUE;

    fmp$simulate_connection_broken (file, status);
  PROCEND nlp$simulate_connection_broken;
?? TITLE := '  [XDCL] NLP$CONNECTION_SIMULATED_BROKEN', EJECT ??

  PROCEDURE [XDCL] nlp$connection_simulated_broken
    (    connection_id: nat$connection_id;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      layer_active: boolean;

    status.normal := TRUE;
    osp$push_inhibit_job_recovery;
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        IF connection^.nominal_connection THEN
          IF NOT connection^.break_condition_active THEN
            connection^.nominal_connection := FALSE;
            connection^.simulated_connection_broken := TRUE;
            IF connection^.wait_state = nac$waiting_for_data_available THEN
              pmp$ready_task (cl_connection^.message_receiver.task, {ignore} status);
              nlp$cl_deactivate_receiver (cl_connection);
              connection^.wait_state := nac$inactive_wait;
            ELSEIF connection^.wait_state = nac$waiting_to_receive_data THEN
              connection^.break_connection_receive := TRUE;
              activate_receiver_task (cl_connection, cl_connection^.message_receiver.task);
            IFEND;
            IF cl_connection^.message_sender.active THEN
              connection^.break_connection_send := TRUE;
              activate_sender_task (cl_connection, cl_connection^.message_sender.task);
            IFEND;
            status.normal := TRUE;
          ELSE
            osp$set_status_condition (nae$break_condition_active, status);
          IFEND;
        ELSE
          osp$set_status_condition (nae$not_nominal_connection, status);
        IFEND;
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nlp$connection_simulated_broken;
?? TITLE := '  [XDCL] NLP$UNSIMULATE_CONNECTION_BROKE', EJECT ??

  PROCEDURE [XDCL] nlp$unsimulate_connection_broke
    (    file: fst$file_reference;
     VAR status: ost$status);

    status.normal := TRUE;

    fmp$unsimulate_connection_broke (file, status);
  PROCEND nlp$unsimulate_connection_broke;
?? TITLE := '  [XDCL] NLP$CONNECT_UNSIMULATED_BROKEN', EJECT ??

  PROCEDURE [XDCL] nlp$connect_unsimulated_broken
    (    connection_id: nat$connection_id;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      layer_active: boolean;

    status.normal := TRUE;
    osp$push_inhibit_job_recovery;
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        IF connection^.simulated_connection_broken THEN
          connection^.simulated_connection_broken := FALSE;
        IFEND;
        IF connection^.connection_state = nac$terminated THEN
          osp$set_status_condition (nae$connection_terminated, status);
        IFEND;
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nlp$connect_unsimulated_broken;
?? TITLE := '  [XDCL] NLP$RECORD_NOMINAL_DISCONNECT', EJECT ??

  PROCEDURE [XDCL] nlp$record_nominal_disconnect
    (    file: fst$file_reference;
     VAR status: ost$status);

    status.normal := TRUE;

    fmp$record_nominal_disconnect (file, status);
  PROCEND nlp$record_nominal_disconnect;
?? TITLE := '  [XDCL] NLP$NOMINAL_DISCONNECT_RECORD', EJECT ??

  PROCEDURE [XDCL] nlp$nominal_disconnect_record
    (    connection_id: nat$connection_id;
     VAR status: ost$status);

    VAR
      active_file: boolean,
      application_name: nat$application_name,
      cl_connection: ^nlt$cl_connection,
      client: boolean,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      delete_connection: boolean,
      ignore_status: ost$status,
      layer_active: boolean;

    status.normal := TRUE;
    delete_connection := FALSE;
    osp$push_inhibit_job_recovery;
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      client := (connection^.client = TRUE);
      application_name := connection^.application_name;
      IF layer_active THEN
        IF connection^.connection_state = nac$terminated THEN
          IF connection^.nominal_connection THEN
            IF (connection^.wait_state <> nac$inactive_wait) OR (cl_connection^.message_sender.active) THEN
              osp$set_status_condition (nae$connection_active, status);
            ELSE
              ; { DEACTIVATE LAYER
              delete_connection := TRUE;
              terminate_connection (connection, cl_connection);
              nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
            IFEND;
          ELSE
            osp$set_status_condition (nae$not_nominal_connection, status);
          IFEND;
        ELSE
          osp$set_status_condition (nae$connection_active, status);
        IFEND;
      ELSE
        delete_connection := TRUE;
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    IF delete_connection THEN
      nap$delete_connection (application_name, application_kind [client], connection_id, active_file,
            ignore_status);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nlp$nominal_disconnect_record;
?? TITLE := '  [XDCL, #GATE] NAP$ACCEPT_CONNECTION', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$accept_connection
    (    file: fst$file_reference;
     VAR status: ost$status);

*copyc nah$accept_connection

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      connection_id: nat$connection_id,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      layer_active: boolean,
      message_id: nlt$bm_message_id,
      switch_offer_pending: boolean;

    status.normal := TRUE;

    fmp$get_connection_identifier (file, connection_id, switch_offer_pending, status);
    IF NOT status.normal THEN
      IF status.condition = fme$no_cycle_description THEN
        osp$set_status_abnormal ('AM', ame$file_not_known, file, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'AN ACCEPT CONNECTION ', status);
      IFEND;
      RETURN;
    IFEND;

    IF switch_offer_pending THEN
      osp$set_status_condition (nae$switch_offer_pending, status);
      RETURN;
    IFEND;
    osp$push_inhibit_job_recovery;
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        IF connection^.connection_state = nac$connection_request_received THEN
          IF connection^.connect_data <> NIL THEN
            data_fragments [1].address := connection^.connect_data;
            data_fragments [1].length := #SIZE (connection^.connect_data^);
          ELSE
            data_fragments [1] := nav$null_data [1];
          IFEND;
          nlp$sl_call_response (cl_connection, data_fragments, status);
          IF status.normal THEN
            connection^.connection_state := nac$established;
          IFEND;
        ELSEIF connection^.connection_state = nac$terminated THEN
          osp$set_status_condition (nae$connection_terminated, status);
        ELSE
          osp$set_status_condition (nae$accept_not_pending, status);
        IFEND;
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$accept_connection;
?? TITLE := '[XDCL, #GATE] nlp$se_get_available_byte_count', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$se_get_available_byte_count
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

    VAR
      byte_count: nat$data_length,
      caller_id: ost$caller_identifier,
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      internal_status: ost$status,
      layer_active: boolean;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    internal_status.normal := TRUE;
    byte_count := 0;

    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_condition (ame$improper_file_id, status);
      RETURN;
    IFEND;

    IF file_instance^.device_class <> rmc$network_device THEN
      osp$set_status_condition (ame$improper_device_class, status);
      RETURN;
    IFEND;

    IF caller_id.ring > file_instance^.instance_attributes.static_label.ring_attributes.r2 THEN
      amp$set_file_instance_abnormal (file_identifier, ame$ring_validation_error, call_block.operation, '',
            status);
      RETURN;
    IFEND;
    osp$push_inhibit_job_recovery;
    nlp$cl_get_exclusive_via_cid (file_instance^.global_file_information^.device_dependent_info.
          network_connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        IF connection^.wait_state = nac$inactive_wait THEN
          byte_count := connection^.total_data_queued;
        ELSE
          osp$set_status_condition (nae$receive_outstanding, internal_status);
        IFEND;
      ELSE
        osp$set_status_condition (nae$connection_terminated, internal_status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      osp$set_status_condition (nae$connection_terminated, internal_status);
    IFEND;
    osp$pop_inhibit_job_recovery;
    osp$copy_local_status_to_status (internal_status, status);
    call_block.se_get_available_byte_count^ := byte_count;
  PROCEND nlp$se_get_available_byte_count;

?? TITLE := '  DELIVER_CONNECTION_EVENTS', EJECT ??

  PROCEDURE deliver_connection_events
    (    connection: ^nat$connection_descriptor;
         cl_connection: ^nlt$cl_connection;
     VAR delivery_complete: boolean;
     VAR condition_cause: nat$se_condition_cause;
     VAR status: ost$status);

    VAR
      event: nat$se_peer_operation,
      event_element: ^nat$se_supervisory_element,
      remaining_buffer_capacity: nat$data_length,
      delivered_message_buffers: nat$data_length;

    delivery_complete := FALSE;
    IF (connection^.data_queue.count > 0) OR (connection^.supervisory_event_queue.beginning <> NIL) THEN
      IF connection^.supervisory_event_queue.beginning = NIL THEN
        IF NOT connection^.discard_to_end_of_message THEN

?? NEWTITLE := '    FRAGMENT AND DELIVER QUEUED DATA', EJECT ??

          IF connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                queued_data_length > connection^.receiver_request.remaining_buffer_capacity THEN
            remaining_buffer_capacity := connection^.receiver_request.remaining_buffer_capacity;
            condition_cause := nac$application_data;
            #SPOIL (condition_cause);
            CASE connection^.receiver_request.application_buffer.description_kind OF
            = nac$fixed =
              IF connection^.receiver_request.remaining_buffer_capacity > 0 THEN
                nlp$al_deliver_data (connection^.data_queue.beginning^.
                      event_element [connection^.data_queue.beginning^.first].message_id,
                      connection^.receiver_request.application_buffer.fixed_description,
                      connection^.receiver_request.remaining_buffer_capacity, delivered_message_buffers);
              IFEND;
            = nac$allocated =
              IF connection^.receiver_request.remaining_buffer_capacity > 0 THEN
                nlp$al_deliver_data (connection^.data_queue.beginning^.
                      event_element [connection^.data_queue.beginning^.first].message_id,
                      connection^.receiver_request.application_buffer.allocated_description^,
                      connection^.receiver_request.remaining_buffer_capacity, delivered_message_buffers);
              IFEND;
              FREE connection^.receiver_request.application_buffer.allocated_description IN
                    nav$network_paged_heap^;
            CASEND;
            connection^.total_data_queued := connection^.total_data_queued - remaining_buffer_capacity;
            connection^.total_message_buffers_queued := connection^.total_message_buffers_queued -
                  delivered_message_buffers;
            connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                  queued_data_length := connection^.data_queue.beginning^.
                  event_element [connection^.data_queue.beginning^.first].queued_data_length -
                  remaining_buffer_capacity;
            connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                  queued_message_buffers := connection^.data_queue.beginning^.
                  event_element [connection^.data_queue.beginning^.first].queued_message_buffers -
                  delivered_message_buffers;
            connection^.receiver_request.bytes_moved := connection^.receiver_request.bytes_moved +
                  remaining_buffer_capacity;
            connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                  total_bytes_moved := connection^.data_queue.beginning^.
                  event_element [connection^.data_queue.beginning^.first].total_bytes_moved +
                  remaining_buffer_capacity;
            connection^.transfer_count := connection^.transfer_count + remaining_buffer_capacity;
            connection^.record_length := connection^.record_length + remaining_buffer_capacity;
            IF connection^.receiver_request.operation = nac$se_receive_data_req THEN
              connection^.receiver_request.peer_operation^.kind := nac$se_send_data;
              connection^.receiver_request.peer_operation^.end_of_message := FALSE;
              connection^.receiver_request.peer_operation^.qualified_data :=
                    connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                    event.qualified_data;
              connection^.receiver_request.peer_operation^.data_length := connection^.transfer_count;
            ELSEIF connection^.receiver_request.operation = amc$get_next_req THEN
              condition_cause := nac$application_event;
              #SPOIL (condition_cause);
              connection^.receiver_request.file_position^ := amc$mid_record;
              connection^.receiver_request.transfer_count^ := connection^.transfer_count;
            ELSEIF connection^.receiver_request.operation = amc$get_partial_req THEN
              condition_cause := nac$application_event;
              #SPOIL (condition_cause);
              connection^.receiver_request.file_position^ := amc$mid_record;
              connection^.receiver_request.transfer_count^ := connection^.transfer_count;
              connection^.receiver_request.record_length^ := connection^.record_length;
            IFEND;
            delivery_complete := TRUE;
            connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                  start_of_data_sequence := FALSE;
          ELSE

?? OLDTITLE ??
?? NEWTITLE := '    DELIVER QUEUED DATA', EJECT ??

            delivery_complete := (connection^.data_queue.beginning^.
                  event_element [connection^.data_queue.beginning^.first].event.end_of_message) OR
                  ((connection^.connection_state = nac$terminated) AND
                  (NOT connection^.data_queue.beginning^.event_element
                  [connection^.data_queue.beginning^.first].event.end_of_message));
            IF connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                  queued_data_length > 0 THEN
              condition_cause := nac$application_data;
              #SPOIL (condition_cause);
              CASE connection^.receiver_request.application_buffer.description_kind OF
              = nac$fixed =
                nlp$al_deliver_data (connection^.data_queue.beginning^.
                      event_element [connection^.data_queue.beginning^.first].message_id,
                      connection^.receiver_request.application_buffer.fixed_description,
                      connection^.receiver_request.remaining_buffer_capacity, delivered_message_buffers);
              = nac$allocated =
                nlp$al_deliver_data (connection^.data_queue.beginning^.
                      event_element [connection^.data_queue.beginning^.first].message_id,
                      connection^.receiver_request.application_buffer.allocated_description^,
                      connection^.receiver_request.remaining_buffer_capacity, delivered_message_buffers);
                IF delivery_complete THEN
                  FREE connection^.receiver_request.application_buffer.allocated_description IN
                        nav$network_paged_heap^;
                IFEND;
              CASEND;
              connection^.total_data_queued := connection^.total_data_queued -
                    connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                    queued_data_length;
              connection^.total_message_buffers_queued := connection^.total_message_buffers_queued -
                    delivered_message_buffers;
              connection^.receiver_request.bytes_moved := connection^.receiver_request.bytes_moved +
                    connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                    queued_data_length;
              connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                    total_bytes_moved := connection^.data_queue.beginning^.
                    event_element [connection^.data_queue.beginning^.first].total_bytes_moved +
                    connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                    queued_data_length;
              connection^.transfer_count := connection^.transfer_count +
                    connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                    queued_data_length;
              connection^.record_length := connection^.record_length +
                    connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                    queued_data_length;
              connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                    queued_data_length := 0;
              connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                    queued_message_buffers := 0;
            IFEND;
            IF delivery_complete THEN
              event := connection^.data_queue.beginning^.event_element
                    [connection^.data_queue.beginning^.first].event;
              IF (connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                    event.end_of_message) OR ((connection^.connection_state = nac$terminated) AND
                    (NOT connection^.data_queue.beginning^.event_element
                    [connection^.data_queue.beginning^.first].event.end_of_message)) THEN
                dequeue_data_event (connection^);
              ELSE
                connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                      start_of_data_sequence := FALSE;
              IFEND;
              condition_cause := nac$application_event;
              #SPOIL (condition_cause);
              IF connection^.receiver_request.operation = nac$se_receive_data_req THEN
                connection^.receiver_request.peer_operation^ := event;
                connection^.receiver_request.peer_operation^.data_length := connection^.transfer_count;
              ELSEIF connection^.receiver_request.operation = amc$get_next_req THEN
                IF (connection^.connection_state = nac$terminated) AND (NOT event.end_of_message) THEN
                  connection^.receiver_request.file_position^ := amc$mid_record;
                ELSE
                  connection^.receiver_request.file_position^ := amc$eor;
                IFEND;
                connection^.receiver_request.transfer_count^ := connection^.transfer_count;
              ELSEIF connection^.receiver_request.operation = amc$get_partial_req THEN
                IF (connection^.connection_state = nac$terminated) AND (NOT event.end_of_message) THEN
                  connection^.receiver_request.file_position^ := amc$mid_record;
                ELSE
                  connection^.receiver_request.file_position^ := amc$eor;
                IFEND;
                connection^.receiver_request.transfer_count^ := connection^.transfer_count;
                connection^.receiver_request.record_length^ := connection^.record_length;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      ELSE

?? OLDTITLE ??
?? NEWTITLE := '    DELIVER SUPERVISORY EVENT', EJECT ??

        IF connection^.receiver_request.operation = nac$se_receive_data_req THEN
          IF (connection^.receiver_request.bytes_moved = 0) OR
                ((connection^.supervisory_event_queue.beginning^.event.kind = nac$se_synchronize) AND
                ((connection^.supervisory_event_queue.beginning^.event.direction =
                nac$se_synchronize_all_data) OR (connection^.supervisory_event_queue.beginning^.event.
                direction = nac$se_synchronize_send_data))) THEN

            IF connection^.receiver_request.application_buffer.description_kind = nac$allocated THEN
              FREE connection^.receiver_request.application_buffer.allocated_description IN
                    nav$network_paged_heap^;
            IFEND;
            condition_cause := nac$application_data;
            #SPOIL (condition_cause);
            connection^.receiver_request.peer_operation^ := connection^.supervisory_event_queue.beginning^.
                  event;
            event_element := connection^.supervisory_event_queue.beginning;
            connection^.supervisory_event_queue.beginning := event_element^.next_element;
            FREE event_element IN nav$network_paged_heap^;
            delivery_complete := TRUE;
          ELSE
            IF connection^.receiver_request.application_buffer.description_kind = nac$allocated THEN
              FREE connection^.receiver_request.application_buffer.allocated_description IN
                    nav$network_paged_heap^;
            IFEND;
            delivery_complete := TRUE;
          IFEND;
        ELSE
          IF ((connection^.receiver_request.bytes_moved > 0) AND
                (((connection^.supervisory_event_queue.beginning^.event.kind = nac$se_synchronize) AND
                (connection^.supervisory_event_queue.beginning^.event.direction =
                nac$se_synchronize_receive_data)) OR (connection^.supervisory_event_queue.beginning^.event.
                kind = nac$se_synchronize_confirm) OR (connection^.supervisory_event_queue.beginning^.event.
                kind = nac$se_interrupt))) THEN
            ; {terminate receive normally
          ELSE
            osp$set_status_condition (nae$unexpected_peer_operation, status);
          IFEND;
          IF connection^.receiver_request.application_buffer.description_kind = nac$allocated THEN
            FREE connection^.receiver_request.application_buffer.allocated_description IN
                  nav$network_paged_heap^;
          IFEND;
          delivery_complete := TRUE;
        IFEND;
      IFEND;
    ELSEIF connection^.connection_state = nac$terminated THEN
      osp$set_status_condition (nae$connection_terminated, status);
      delivery_complete := TRUE;
    IFEND;

    IF delivery_complete THEN
      nlp$cancel_timer (connection^.receive_timer);
    IFEND;

  PROCEND deliver_connection_events;
?? OLDTITLE ??
?? TITLE := '  [XDCL, #GATE] NLP$SE_RECEIVE_DATA' ??
?? NEWTITLE := '    TERMINATE_RECEIVE -- CONDITION HANDLER', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$se_receive_data
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
         start_time: integer;
     VAR request_started: boolean;
     VAR wait_time: nat$wait_time;
     VAR receive_wait_swapout: boolean;
     VAR activity_status: ^ost$activity_status;
     VAR status: ost$status);


    PROCEDURE terminate_receive
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF ((condition_cause = nac$application_data) OR (condition_cause = nac$application_event) OR
              (condition_cause = nac$activity_status)) THEN
          IF cl_connection <> NIL THEN
            nlp$cl_deactivate_receiver (cl_connection);
            connection^.wait_state := nac$inactive_wait;
            IF file_instance^.receiver_active THEN
              IF ((connection^.receiver_request.application_buffer.description_kind = nac$allocated) AND
                    (connection^.receiver_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.receiver_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              file_instance^.receiver_active := FALSE;
            IFEND;
            nlp$cl_clear_exclusive_access (cl_connection);
          IFEND;
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
          EXIT nlp$se_receive_data;
        ELSE
          ; { causes the task to abort because this is probably a system
          ; {  programing error. Locks are   left locked or problem might  not be
          ; {  found.
          osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
          IF cl_connection <> NIL THEN
            nap$namve_system_error (TRUE, 'NLP$SE_RECEIVE_DATA ', ^condition_status);
            nlp$cl_clear_exclusive_access (cl_connection);
          IFEND;
          osp$pop_inhibit_job_recovery;
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_receive;
?? OLDTITLE, EJECT ??

    VAR
      buffer_length: integer,
      caller_id: ost$caller_identifier,
      cl_connection: ^nlt$cl_connection,
      cl_connection_id: nlt$cl_connection_id,
      condition_cause: nat$se_condition_cause,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      current_time: integer,
      data: array [1 .. 1] of nat$data_fragment,
      data_area: ^nat$data_fragments,
      data_length: integer,
      message_buffers_dequeued: nat$data_length,
      delivery_complete: boolean,
      description_upperbound: integer,
      event_element: ^nat$se_supervisory_element,
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      ignore_status: ost$status,
      layer_active: boolean,
      request_complete: boolean;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    activity_status^.status.normal := TRUE;
    activity_status^.complete := TRUE;
    request_complete := TRUE;


    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_condition (ame$improper_file_id, status);
      RETURN;
    IFEND;
    #SPOIL (file_instance);

    IF file_instance^.device_class <> rmc$network_device THEN
      osp$set_status_condition (ame$improper_device_class, status);
      RETURN;
    IFEND;

    IF caller_id.ring > file_instance^.instance_attributes.static_label.ring_attributes.r2 THEN
      amp$set_file_instance_abnormal (file_identifier, ame$ring_validation_error, call_block.operation, '',
            status);
      RETURN;
    IFEND;
    IF call_block.operation = nac$se_receive_data_req THEN
      data_area := call_block.se_receive_data_req.buffer;
    ELSE
      IF call_block.operation = amc$get_next_req THEN
        data [1].length := call_block.getn.working_storage_length;
        data [1].address := call_block.getn.working_storage_area;
        call_block.getn.byte_address^ := 0;
      ELSE
        data [1].length := call_block.getp.working_storage_length;
        data [1].address := call_block.getp.working_storage_area;
        call_block.getp.byte_address^ := 0;
      IFEND;
      data_area := ^data;
    IFEND;

    IF UPPERBOUND (data_area^) > nac$max_data_fragment_count THEN
      osp$set_status_condition (nae$maximum_data_fragments, status);
      RETURN;
    IFEND;

    nlp$al_get_data_requirements (data_area^, buffer_length, description_upperbound);
    IF buffer_length > nac$max_data_length THEN
      osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, 'nac$max_data_length', status);
      RETURN;
    IFEND;
    cl_connection := NIL;
    condition_cause := nac$request_not_cause;
    #SPOIL (condition_cause, cl_connection);
    osp$push_inhibit_job_recovery;
    osp$establish_condition_handler (^terminate_receive, FALSE);
    nlp$cl_get_exclusive_via_cid (file_instance^.global_file_information^.device_dependent_info.
          network_connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        #SPOIL (connection);
        IF NOT connection^.break_condition_active THEN

          IF connection^.wait_state = nac$inactive_wait THEN

?? NEWTITLE := '    PROCESS SUPERVISORY EVENT', EJECT ??

            IF connection^.supervisory_event_queue.beginning <> NIL THEN
              IF call_block.operation = nac$se_receive_data_req THEN
                condition_cause := nac$application_event;
                #SPOIL (condition_cause);
                call_block.se_receive_data_req.peer_operation^ :=
                      connection^.supervisory_event_queue.beginning^.event;
                event_element := connection^.supervisory_event_queue.beginning;
                connection^.supervisory_event_queue.beginning := event_element^.next_element;
                FREE event_element IN nav$network_paged_heap^;
              ELSE
                osp$set_status_condition (nae$unexpected_peer_operation, status);
              IFEND;

?? OLDTITLE ??
?? NEWTITLE := '    PROCESS QUEUED DATA', EJECT ??

            ELSEIF (connection^.data_queue.count > 0) AND (connection^.data_queue.beginning^.
                  event_element [connection^.data_queue.beginning^.first].event.end_of_message) AND
                  (connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                  queued_data_length <= buffer_length) AND (connection^.data_queue.beginning^.
                  event_element [connection^.data_queue.beginning^.first].start_of_data_sequence) THEN

              IF call_block.operation = nac$se_receive_data_req THEN
                condition_cause := nac$application_event;
                #SPOIL (condition_cause);
                call_block.se_receive_data_req.peer_operation^ :=
                      connection^.data_queue.beginning^.event_element
                      [connection^.data_queue.beginning^.first].event;
                call_block.se_receive_data_req.peer_operation^.data_length :=
                      connection^.data_queue.beginning^.event_element
                      [connection^.data_queue.beginning^.first].queued_data_length;
                condition_cause := nac$application_data;
                #SPOIL (condition_cause);
                nlp$bm_flush_message (data_area^, connection^.data_queue.beginning^.
                      event_element [connection^.data_queue.beginning^.first].message_id, data_length,
                      ignore_status);
                message_buffers_dequeued := connection^.data_queue.beginning^.
                      event_element [connection^.data_queue.beginning^.first].queued_message_buffers;
                connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                      queued_data_length := 0;
                connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                      queued_message_buffers := 0;
                dequeue_data_event (connection^);
              ELSEIF call_block.operation = amc$get_next_req THEN
                IF (file_instance^.eoi_message_enabled) AND (eoi_message
                      (file_instance^.eoi_message, connection^.data_queue.beginning^.
                      event_element [connection^.data_queue.beginning^.first].message_id)) THEN
                  condition_cause := nac$application_event;
                  #SPOIL (condition_cause);
                  call_block.getn.file_position^ := amc$eoi;
                  call_block.getn.transfer_count^ := 0;
                  nlp$bm_release_message (connection^.data_queue.beginning^.
                        event_element [connection^.data_queue.beginning^.first].message_id);
                  data_length := connection^.data_queue.beginning^.
                        event_element [connection^.data_queue.beginning^.first].queued_data_length;
                ELSE
                  condition_cause := nac$application_event;
                  #SPOIL (condition_cause);
                  call_block.getn.file_position^ := amc$eor;
                  call_block.getn.transfer_count^ := connection^.data_queue.beginning^.
                        event_element [connection^.data_queue.beginning^.first].queued_data_length;
                  condition_cause := nac$application_data;
                  #SPOIL (condition_cause);
                  nlp$bm_flush_message (data_area^, connection^.data_queue.beginning^.
                        event_element [connection^.data_queue.beginning^.first].message_id, data_length,
                        ignore_status);
                IFEND;
                message_buffers_dequeued := connection^.data_queue.beginning^.
                      event_element [connection^.data_queue.beginning^.first].queued_message_buffers;
                connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                      queued_data_length := 0;
                connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                      queued_message_buffers := 0;
                dequeue_data_event (connection^);
              ELSE
                IF (file_instance^.eoi_message_enabled) AND (eoi_message
                      (file_instance^.eoi_message, connection^.data_queue.beginning^.
                      event_element [connection^.data_queue.beginning^.first].message_id)) THEN
                  condition_cause := nac$application_event;
                  #SPOIL (condition_cause);
                  call_block.getp.file_position^ := amc$eoi;
                  call_block.getp.transfer_count^ := 0;
                  call_block.getp.record_length^ := 0;
                  nlp$bm_release_message (connection^.data_queue.beginning^.
                        event_element [connection^.data_queue.beginning^.first].message_id);
                  data_length := connection^.data_queue.beginning^.
                        event_element [connection^.data_queue.beginning^.first].queued_data_length;
                ELSE
                  condition_cause := nac$application_event;
                  #SPOIL (condition_cause);
                  call_block.getp.file_position^ := amc$eor;
                  call_block.getp.transfer_count^ := connection^.data_queue.beginning^.
                        event_element [connection^.data_queue.beginning^.first].queued_data_length;
                  call_block.getp.record_length^ := connection^.data_queue.beginning^.
                        event_element [connection^.data_queue.beginning^.first].queued_data_length;
                  condition_cause := nac$application_data;
                  #SPOIL (condition_cause);
                  nlp$bm_flush_message (data_area^, connection^.data_queue.beginning^.
                        event_element [connection^.data_queue.beginning^.first].message_id, data_length,
                        ignore_status);
                IFEND;
                message_buffers_dequeued := connection^.data_queue.beginning^.
                      event_element [connection^.data_queue.beginning^.first].queued_message_buffers;
                connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                      queued_data_length := 0;
                connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
                      queued_message_buffers := 0;
                dequeue_data_event (connection^);
              IFEND;
              connection^.total_data_queued := connection^.total_data_queued - data_length;
              connection^.total_message_buffers_queued := connection^.total_message_buffers_queued -
                    message_buffers_dequeued;
              nlp$ta_report_undelivered_data (cl_connection, connection^.total_message_buffers_queued);

?? OLDTITLE ??
?? NEWTITLE := '    SETUP RECEIVE COROUTINE', EJECT ??

            ELSE
              IF (connection^.connection_state = nac$terminated) AND (connection^.nominal_connection) AND
                    (connection^.data_queue.count = 0) AND (connection^.supervisory_event_queue.beginning =
                    NIL) AND (connection^.wait_state <> nac$waiting_to_receive_data) AND
                    (NOT cl_connection^.message_sender.active) THEN
                osp$set_status_condition (nae$interactive_cond_interrupt, status);
              ELSE
                nlp$cl_activate_receiver (cl_connection);
                connection^.wait_state := nac$waiting_to_receive_data;
                condition_cause := nac$application_data;
                #SPOIL (condition_cause);
                connection^.receive_file_identifier := file_identifier;
                file_instance^.receiver_activity_status := activity_status;
                file_instance^.receiver_active := TRUE;
                connection^.receiver_request.operation := call_block.operation;
                IF call_block.operation = nac$se_receive_data_req THEN
                  connection^.receiver_request.peer_operation :=
                        call_block.se_receive_data_req.peer_operation;
                ELSEIF call_block.operation = amc$get_next_req THEN
                  connection^.receiver_request.transfer_count := call_block.getn.transfer_count;
                  connection^.receiver_request.file_position := call_block.getn.file_position;
                ELSE
                  connection^.receiver_request.transfer_count := call_block.getp.transfer_count;
                  connection^.receiver_request.record_length := call_block.getp.record_length;
                  connection^.receiver_request.file_position := call_block.getp.file_position;
                IFEND;
                connection^.receiver_request.remaining_buffer_capacity := buffer_length;
                connection^.receiver_request.bytes_moved := 0;
                IF description_upperbound <= nac$fixed_fragments THEN
                  connection^.receiver_request.application_buffer.description_kind := nac$fixed;
                  nlp$al_initialize_data_descrip (data_area^, buffer_length,
                        connection^.receiver_request.application_buffer.fixed_description);
                ELSE
                  connection^.receiver_request.application_buffer.description_kind := nac$allocated;
                  REPEAT
                    ALLOCATE connection^.receiver_request.application_buffer.allocated_description:
                          [1 .. description_upperbound] IN nav$network_paged_heap^;
                    IF connection^.receiver_request.application_buffer.allocated_description = NIL THEN
                      syp$cycle;
                    IFEND;
                  UNTIL connection^.receiver_request.application_buffer.allocated_description <> NIL;
                  nlp$al_initialize_data_descrip (data_area^, buffer_length,
                        connection^.receiver_request.application_buffer.allocated_description^);
                IFEND;

                connection^.transfer_count := 0;
                IF ((connection^.data_queue.count > 0) AND (NOT connection^.data_queue.beginning^.
                      event_element [connection^.data_queue.beginning^.first].start_of_data_sequence) AND
                      ((call_block.operation = amc$get_next_req) OR
                      ((call_block.operation = amc$get_partial_req) AND
                      (call_block.getp.skip_option = amc$skip_to_eor)))) THEN

                  connection^.record_length := 0;
                  IF connection^.data_queue.beginning^.event_element
                        [connection^.data_queue.beginning^.first].event.end_of_message THEN
                    dequeue_data_event (connection^);
                  ELSE
                    IF connection^.data_queue.beginning^.event_element
                          [connection^.data_queue.beginning^.first].queued_data_length > 0 THEN
                      nlp$bm_release_message (connection^.data_queue.beginning^.
                            event_element [connection^.data_queue.beginning^.first].message_id);
                      connection^.total_data_queued := connection^.total_data_queued -
                            connection^.data_queue.beginning^.event_element
                            [connection^.data_queue.beginning^.first].queued_data_length;
                      connection^.total_message_buffers_queued := connection^.total_message_buffers_queued -
                            connection^.data_queue.beginning^.event_element
                            [connection^.data_queue.beginning^.first].queued_message_buffers;
                      connection^.data_queue.beginning^.event_element
                            [connection^.data_queue.beginning^.first].queued_data_length := 0;
                      connection^.data_queue.beginning^.event_element
                            [connection^.data_queue.beginning^.first].queued_message_buffers := 0;
                    IFEND;
                    IF NOT connection^.discard_to_end_of_message THEN
                      connection^.discard_to_end_of_message := TRUE;
                    IFEND;
                  IFEND;
                ELSEIF (connection^.data_queue.count = 0) OR ((connection^.data_queue.count > 0) AND
                      (connection^.data_queue.beginning^.event_element
                      [connection^.data_queue.beginning^.first].start_of_data_sequence)) THEN
                  connection^.record_length := 0;
                IFEND;
                deliver_connection_events (connection, cl_connection, delivery_complete, condition_cause,
                      status);
                condition_cause := nac$request_not_cause;
                #SPOIL (condition_cause);
                nlp$ta_report_undelivered_data (cl_connection, connection^.total_message_buffers_queued);
                IF delivery_complete THEN
                  nlp$cl_deactivate_receiver (cl_connection);
                  connection^.wait_state := nac$inactive_wait;
                  file_instance^.receiver_active := FALSE;
                ELSE
                  current_time := #FREE_RUNNING_CLOCK (0);
                  wait_time := file_instance^.data_transfer_timeout;
                  IF (file_instance^.data_transfer_timeout > ((current_time - start_time) DIV 1000)) THEN
                    request_started := TRUE;
                    receive_wait_swapout := connection^.receive_wait_swapout;
                    nlp$select_timer ((file_instance^.data_transfer_timeout * 1000) -
                          (current_time - start_time), 0, connection^.receive_timer);
                    activity_status^.complete := FALSE;
                  ELSE
                    ; {deactivate request
                    IF ((connection^.receiver_request.application_buffer.description_kind = nac$allocated) AND
                          (connection^.receiver_request.application_buffer.allocated_description <> NIL)) THEN
                      FREE connection^.receiver_request.application_buffer.allocated_description IN
                            nav$network_paged_heap^;
                    IFEND;
                    nlp$cl_deactivate_receiver (cl_connection);
                    connection^.wait_state := nac$inactive_wait;
                    file_instance^.receiver_active := FALSE;
                    osp$set_status_condition (nae$data_transfer_timeout, status);
                    activity_status^.status := status;
                    activity_status^.complete := TRUE;
                  IFEND;
                  cl_connection_id := cl_connection^.identifier;
                IFEND;
              IFEND;
            IFEND;
            IF (connection^.connection_state = nac$terminated) AND
                  (NOT connection^.timesharing_disconnect_sent) AND (connection^.nominal_connection) AND
                  (connection^.data_queue.count = 0) AND (connection^.supervisory_event_queue.beginning =
                  NIL) AND (connection^.wait_state <> nac$waiting_to_receive_data) AND
                  (NOT cl_connection^.message_sender.active) AND (connection^.send_synchronize_count = 0) THEN
              ; {send signal
              connection^.timesharing_disconnect_sent := TRUE;
              send_timesharing_signal (jmc$timesharing_disconnect, connection^.nominal_connection_task_id,
                    NIL);
            IFEND;
          ELSE
            IF (call_block.operation = nac$se_receive_data_req) AND
                  (call_block.se_receive_data_req.wait = osc$nowait) THEN
              osp$set_status_condition (nae$receive_outstanding, status);
            ELSE
              request_started := FALSE;
              wait_time := file_instance^.data_transfer_timeout;
              receive_wait_swapout := connection^.receive_wait_swapout;
              condition_cause := nac$activity_status;
              #SPOIL (condition_cause);
              activity_status^.complete := FALSE;
            IFEND;
          IFEND;
        ELSE
          osp$set_status_condition (nae$interactive_cond_interrupt, status);
        IFEND;
        IF connection^.wait_state <> nac$waiting_to_receive_data THEN
          IF (connection^.data_queue.count = 0) AND (connection^.supervisory_event_queue.beginning = NIL) THEN
            nlp$cancel_timer (connection^.event_timer);
          ELSE
            nlp$select_timer (nac$inactive_receiver_timeout, 0, connection^.event_timer);
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
    IF (NOT status.normal) AND (status.condition = nae$connection_terminated) THEN
      fmp$convert_status (file_instance^.local_file_name, status);
    IFEND;
  PROCEND nlp$se_receive_data;
?? OLDTITLE ??
?? TITLE := '  [XDCL] NAP$SE_DELIVER_EVENT_HANDLER' ??
?? NEWTITLE := '    TERMINATE_DELIVERY -- CONDITION HANDLER', EJECT ??

  PROCEDURE [XDCL] nap$se_deliver_event_handler
    (    originator: ost$global_task_id;
         signal: pmt$signal);


    PROCEDURE terminate_delivery
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF (condition_cause = nac$application_data) OR (condition_cause = nac$application_event) THEN
          IF cl_connection <> NIL THEN
            nlp$cl_deactivate_receiver (cl_connection);
            connection^.wait_state := nac$inactive_wait;
            IF ((connection^.receiver_request.application_buffer.description_kind = nac$allocated) AND
                  (connection^.receiver_request.application_buffer.allocated_description <> NIL)) THEN
              FREE connection^.receiver_request.application_buffer.allocated_description IN
                    nav$network_paged_heap^;
            IFEND;
            osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
            condition_cause := nac$activity_status;
            #SPOIL (condition_cause);
            osp$establish_condition_handler (^terminate_delivery, FALSE);
            complete_activity (receive, connection^.receive_file_identifier, ^condition_status,
                  valid_file_identifier);
            IF NOT valid_file_identifier THEN
              nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
            IFEND;
            nlp$cl_clear_exclusive_access (cl_connection);
          IFEND;
          condition_status.normal := TRUE;
          osp$pop_inhibit_job_recovery;
          EXIT nap$se_deliver_event_handler;
        ELSEIF condition_cause = nac$activity_status THEN
          IF cl_connection <> NIL THEN
            IF (connection^.wait_state = nac$waiting_to_receive_data) AND
                  (cl_connection^.message_receiver.task = processing_task) THEN
              nlp$cl_deactivate_receiver (cl_connection);
              connection^.wait_state := nac$inactive_wait;
              IF ((connection^.receiver_request.application_buffer.description_kind = nac$allocated) AND
                    (connection^.receiver_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.receiver_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              terminate_io (receiver, connection^.receive_file_identifier, valid_file_identifier);
              IF NOT valid_file_identifier THEN
                nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
              IFEND;
            IFEND;
            nlp$cl_clear_exclusive_access (cl_connection);
          IFEND;
          osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
        ELSE
          osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
          IF cl_connection <> NIL THEN
            nap$namve_system_error (TRUE, 'NAP$SE_DELIVER_EVENT_HANDLER ', ^condition_status);
            nlp$cl_clear_exclusive_access (cl_connection);
          IFEND;
        IFEND;
        osp$pop_inhibit_job_recovery;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_delivery;
?? OLDTITLE, EJECT ??

    VAR
      cl_connection: ^nlt$cl_connection,
      cl_connection_id: ^nlt$cl_connection_id,
      condition_cause: nat$se_condition_cause,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      delivery_complete: boolean,
      layer_active: boolean,
      processing_task: ost$global_task_id,
      valid_file_identifier: boolean,
      status: ost$status;

    status.normal := TRUE;
    cl_connection_id := #LOC (signal.contents);
    cl_connection := NIL;
    condition_cause := nac$request_not_cause;
    #SPOIL (condition_cause, cl_connection);
    osp$push_inhibit_job_recovery;
    osp$establish_condition_handler (^terminate_delivery, FALSE);
    nlp$cl_get_exclusive_via_cid (cl_connection_id^, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        #SPOIL (connection);
        pmp$get_executing_task_gtid (processing_task);
        IF (connection^.wait_state = nac$waiting_to_receive_data) AND
              (cl_connection^.message_receiver.task = processing_task) THEN
          IF (connection^.connection_state = nac$terminated) AND
                (connection^.supervisory_event_queue.beginning = NIL) AND
                (connection^.data_queue.count = 0) THEN
            IF ((connection^.receiver_request.application_buffer.description_kind = nac$allocated) AND
                  (connection^.receiver_request.application_buffer.allocated_description <> NIL)) THEN
              FREE connection^.receiver_request.application_buffer.allocated_description IN
                    nav$network_paged_heap^;
            IFEND;
            nlp$cl_deactivate_receiver (cl_connection);
            connection^.wait_state := nac$inactive_wait;
            ; {set_activity_status  nae$connection_terminated
            IF NOT connection^.nominal_connection THEN
              osp$set_status_condition (nae$connection_terminated, status);
            ELSE
              osp$set_status_condition (nae$interactive_cond_interrupt, status);
            IFEND;
            condition_cause := nac$activity_status;
            #SPOIL (condition_cause);
            complete_activity (receive, connection^.receive_file_identifier, ^status, valid_file_identifier);
            IF NOT valid_file_identifier THEN
              nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
            IFEND;
          ELSE
            IF NOT connection^.break_connection_receive THEN
              IF (connection^.supervisory_event_queue.beginning <> NIL) OR
                    (connection^.data_queue.count > 0) THEN
                IF (connection^.synchronize_request_receive) OR (connection^.synchronize_receive) THEN
                  ; {redo buffer
                  connection^.synchronize_request_receive := FALSE;
                  connection^.synchronize_receive := FALSE;
                IFEND;
                ; {continue normal processing
                condition_cause := nac$application_data;
                #SPOIL (condition_cause);
                deliver_connection_events (connection, cl_connection, delivery_complete, condition_cause,
                      status);
                condition_cause := nac$request_not_cause;
                #SPOIL (condition_cause);
                nlp$ta_report_undelivered_data (cl_connection, connection^.total_message_buffers_queued);
                IF delivery_complete THEN
                  nlp$cl_deactivate_receiver (cl_connection);
                  connection^.wait_state := nac$inactive_wait;
                  condition_cause := nac$activity_status;
                  #SPOIL (condition_cause);
                  complete_activity (receive, connection^.receive_file_identifier, ^status,
                        valid_file_identifier);
                  IF NOT valid_file_identifier THEN
                    nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
                  IFEND;
                IFEND;
              IFEND;
            ELSE
              ; {deactive_receive
              IF ((connection^.receiver_request.application_buffer.description_kind = nac$allocated) AND
                    (connection^.receiver_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.receiver_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              nlp$cl_deactivate_receiver (cl_connection);
              connection^.wait_state := nac$inactive_wait;
              connection^.break_connection_receive := FALSE;

              connection^.synchronize_request_receive := FALSE;

              connection^.synchronize_receive := FALSE;
              IF NOT cl_connection^.message_sender.active THEN
                send_timesharing_signal (jmc$timesharing_synchronize, connection^.
                      nominal_connection_task_id, ^connection^.event);
              IFEND;
              ; { nae$interactive_cond_interrupt
              condition_cause := nac$activity_status;
              #SPOIL (condition_cause);
              osp$set_status_condition (nae$interactive_cond_interrupt, status);
              complete_activity (receive, connection^.receive_file_identifier, ^status,
                    valid_file_identifier);
              IF NOT valid_file_identifier THEN
                nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
              IFEND;
            IFEND;
            IF (connection^.wait_state = nac$waiting_to_receive_data) AND (connection^.receive_timeout) THEN
              IF ((connection^.receiver_request.application_buffer.description_kind = nac$allocated) AND
                    (connection^.receiver_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.receiver_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              nlp$cl_deactivate_receiver (cl_connection);
              connection^.wait_state := nac$inactive_wait;
              condition_cause := nac$activity_status;
              #SPOIL (condition_cause);
              osp$set_status_condition (nae$data_transfer_timeout, status);
              complete_activity (receive, connection^.receive_file_identifier, ^status,
                    valid_file_identifier);
              IF NOT valid_file_identifier THEN
                nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
              IFEND;
            IFEND;
            IF connection^.wait_state <> nac$waiting_to_receive_data THEN
              IF ((connection^.data_queue.count > 0) OR (connection^.supervisory_event_queue.beginning <>
                    NIL)) THEN
                nlp$select_timer (nac$inactive_receiver_timeout, 0, connection^.event_timer);
              ELSE
                nlp$cancel_timer (connection^.event_timer);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
        IF (connection^.connection_state = nac$terminated) AND
              (NOT connection^.timesharing_disconnect_sent) AND (connection^.nominal_connection) AND
              (connection^.data_queue.count = 0) AND (connection^.supervisory_event_queue.beginning = NIL) AND
              (connection^.wait_state <> nac$waiting_to_receive_data) AND
              (NOT cl_connection^.message_sender.active) AND (connection^.send_synchronize_count = 0) THEN
          ; {send signal
          connection^.timesharing_disconnect_sent := TRUE;
          send_timesharing_signal (jmc$timesharing_disconnect, connection^.nominal_connection_task_id, NIL);
        IFEND;
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$se_deliver_event_handler;
?? TITLE := '  SEND_DATA', EJECT ??

  PROCEDURE send_data
    (    cl_connection: ^nlt$cl_connection;
         connection: ^nat$connection_descriptor);

    VAR
      capacity: nat$data_length,
      end_of_message: boolean,
      fragment_size: nat$data_length,
      qualified_data: boolean,
      description_upperbound: integer,
      ignore_rb: integer,
      ignore_status: ost$status,
      message: ^array [1 .. * ] of nat$data_fragment;

  /send_block/
    WHILE connection^.sender_request.remaining_bytes_to_send > 0 DO
      nlp$osi_get_outbound_capacity (cl_connection, capacity);
    IF capacity > connection^.sender_request.remaining_bytes_to_send THEN
      fragment_size := connection^.sender_request.remaining_bytes_to_send;
    ELSEIF capacity > 0 THEN
      fragment_size := capacity;
    ELSE
      EXIT /send_block/;
    IFEND;

    CASE connection^.sender_request.application_buffer.description_kind OF
    = nac$fixed =
      nlp$al_get_data_requirements (connection^.sender_request.application_buffer.fixed_description.fragment,
            ignore_rb, description_upperbound);
      PUSH message: [1 .. description_upperbound];
      nlp$al_fragment_data (fragment_size, connection^.sender_request.application_buffer.fixed_description,
            connection^.sender_request.remaining_bytes_to_send, message^);
    = nac$allocated =
      nlp$al_get_data_requirements (connection^.sender_request.application_buffer.allocated_description^.
            fragment, ignore_rb, description_upperbound);
      PUSH message: [1 .. description_upperbound];
      nlp$al_fragment_data (fragment_size, connection^.sender_request.application_buffer.
            allocated_description^, connection^.sender_request.remaining_bytes_to_send, message^);
      IF connection^.sender_request.remaining_bytes_to_send = 0 THEN
        FREE connection^.sender_request.application_buffer.allocated_description IN nav$network_paged_heap^;
      IFEND;
    CASEND;
    qualified_data := (connection^.sender_request.operation = nac$se_send_data_req) AND
          connection^.sender_request.qualified_data;
    IF connection^.sender_request.remaining_bytes_to_send = 0 THEN
      nlp$cl_deactivate_sender (cl_connection);
      IF connection^.sender_request.operation = nac$se_send_data_req THEN
        end_of_message := connection^.sender_request.end_of_message;
      ELSE
        end_of_message := (connection^.sender_request.operation = amc$put_next_req) OR
              ((connection^.sender_request.operation = amc$put_partial_req) AND
              (connection^.sender_request.term_option = amc$terminate));
      IFEND;
      nlp$cancel_timer (connection^.send_timer);
    ELSE
      end_of_message := FALSE;
    IFEND;
    nlp$sl_data_request (cl_connection, qualified_data, end_of_message, message^, ignore_status);
    WHILEND /send_block/;
  PROCEND send_data;
?? TITLE := '  [XDCL] NLP$SE_SEND_DATA' ??
?? NEWTITLE := '    TERMINATE_SEND -- CONDITION HANDLER', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$se_send_data
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
         start_time: integer;
     VAR request_started: boolean;
     VAR wait_time: nat$wait_time;
     VAR activity_status: ^ost$activity_status;
     VAR status: ost$status);


    PROCEDURE terminate_send
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      condition_status.normal := TRUE;
      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF (condition_cause = nac$application_data) OR (condition_cause = nac$activity_status) THEN
          IF cl_connection <> NIL THEN
            nlp$cl_deactivate_sender (cl_connection);
            IF file_instance^.sender_active THEN
              IF ((connection^.sender_request.application_buffer.description_kind = nac$allocated) AND
                    (connection^.sender_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.sender_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              file_instance^.sender_active := FALSE;
            IFEND;
            nlp$cl_clear_exclusive_access (cl_connection);
          IFEND;
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
          EXIT nlp$se_send_data;
        ELSE
          ; { causes the task to abort because this is probably a system
          ; {  programing error. Locks are   left locked or problem might  not be
          ; {  found.
          osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
          IF cl_connection <> NIL THEN
            nap$namve_system_error (TRUE, 'NLP$SE_SEND_DATA ', ^condition_status);
            nlp$cl_clear_exclusive_access (cl_connection);
          IFEND;
          osp$pop_inhibit_job_recovery;
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_send;
?? OLDTITLE, EJECT ??

    VAR
      bytes_to_send: integer,
      caller_id: ost$caller_identifier,
      capacity: nat$data_length,
      cl_connection: ^nlt$cl_connection,
      condition_cause: nat$se_condition_cause,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      current_time: integer,
      data: array [1 .. 1] of nat$data_fragment,
      data_area: ^nat$data_fragments,
      description_upperbound: integer,
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      layer_active: boolean;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    activity_status^.status.normal := TRUE;
    activity_status^.complete := TRUE;
    request_started := TRUE;
    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_condition (ame$improper_file_id, status);
      RETURN;
    IFEND;
    #SPOIL (file_instance);

    IF file_instance^.device_class <> rmc$network_device THEN
      osp$set_status_condition (ame$improper_device_class, status);
      RETURN;
    IFEND;

    IF caller_id.ring > file_instance^.instance_attributes.static_label.ring_attributes.r1 THEN
      amp$set_file_instance_abnormal (file_identifier, ame$ring_validation_error, call_block.operation, '',
            status);
      RETURN;
    IFEND;
    IF call_block.operation = nac$se_send_data_req THEN
      data_area := call_block.se_send_data_req.data;
    ELSE
      IF call_block.operation = amc$put_next_req THEN
        data [1].length := call_block.putn.working_storage_length;
        data [1].address := call_block.putn.working_storage_area;
        call_block.putn.byte_address^ := 0;
      ELSE
        data [1].length := call_block.putp.working_storage_length;
        data [1].address := call_block.putp.working_storage_area;
        call_block.putp.byte_address^ := 0;
      IFEND;
      data_area := ^data;
    IFEND;

    IF UPPERBOUND (data_area^) > nac$max_data_fragment_count THEN
      osp$set_status_condition (nae$maximum_data_fragments, status);
      RETURN;
    IFEND;

    nlp$al_get_data_requirements (data_area^, bytes_to_send, description_upperbound);
    IF bytes_to_send > nac$max_data_length THEN
      osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, 'nac$max_data_length', status);
      RETURN;
    IFEND;
    cl_connection := NIL;
    condition_cause := nac$request_not_cause;
    #SPOIL (condition_cause, cl_connection);
    osp$push_inhibit_job_recovery;
    osp$establish_condition_handler (^terminate_send, FALSE);
    nlp$cl_get_exclusive_via_cid (file_instance^.global_file_information^.device_dependent_info.
          network_connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        #SPOIL (connection);
        IF connection^.connection_state = nac$established THEN
          IF connection^.send_synchronize_count = 0 THEN
            IF NOT cl_connection^.message_sender.active THEN
              IF (connection^.send_put_partial_termination) OR
                    ((connection^.intermediate_put_partial) AND ((call_block.operation <>
                    amc$put_partial_req) OR ((call_block.operation = amc$put_partial_req) AND
                    (call_block.putp.term_option = amc$start)))) THEN
                nlp$osi_get_outbound_capacity (cl_connection, capacity);
                IF capacity > 0 THEN
                  nlp$sl_data_request (cl_connection, FALSE {qualified_data} , TRUE {END_OF_MESSAGE} ,
                        nav$null_data, status);
                  connection^.intermediate_put_partial := FALSE;
                  connection^.send_put_partial_termination := FALSE;
                ELSE
                  connection^.intermediate_put_partial := FALSE;
                  connection^.send_put_partial_termination := TRUE;
                IFEND;
              IFEND;

              ; {It is possible to get a non-zero capacity if the previous capacity was zero.

              nlp$osi_get_outbound_capacity (cl_connection, capacity);
              IF (capacity > 0) AND (capacity >= bytes_to_send) AND
                    (NOT connection^.send_put_partial_termination) THEN
                condition_cause := nac$application_data;
                #SPOIL (condition_cause);
                IF call_block.operation = nac$se_send_data_req THEN
                  nlp$sl_data_request (cl_connection, call_block.se_send_data_req.qualified_data,
                        call_block.se_send_data_req.end_of_message, data_area^, status);
                ELSEIF (call_block.operation = amc$put_partial_req) AND
                      ((call_block.putp.term_option = amc$start) OR
                      (call_block.putp.term_option = amc$continue)) THEN
                  nlp$sl_data_request (cl_connection, FALSE {qualified_data} , FALSE {END_OF_MESSAGE} ,
                        data_area^, status);
                  connection^.intermediate_put_partial := TRUE;
                ELSEIF (call_block.operation = amc$put_partial_req) AND
                      (call_block.putp.term_option = amc$terminate) THEN
                  nlp$sl_data_request (cl_connection, FALSE {qualified_data} , TRUE {END_OF_MESSAGE} ,
                        data_area^, status);
                  connection^.intermediate_put_partial := FALSE;
                ELSE
                  nlp$sl_data_request (cl_connection, FALSE {qualified_data} , TRUE {END_OF_MESSAGE} ,
                        data_area^, status);
                IFEND;
              ELSE
                nlp$cl_activate_sender (cl_connection);
                connection^.sender_request.operation := call_block.operation;
                IF call_block.operation = nac$se_send_data_req THEN
                  connection^.sender_request.end_of_message := call_block.se_send_data_req.end_of_message;
                  connection^.sender_request.qualified_data := call_block.se_send_data_req.qualified_data;
                ELSEIF call_block.operation = amc$put_partial_req THEN
                  connection^.sender_request.term_option := call_block.putp.term_option;
                  IF ((call_block.putp.term_option = amc$start) OR
                        (call_block.putp.term_option = amc$continue)) AND
                        (NOT connection^.intermediate_put_partial) THEN
                    connection^.intermediate_put_partial := TRUE;
                  IFEND;
                  IF (call_block.putp.term_option = amc$terminate) AND
                        (connection^.intermediate_put_partial) THEN
                    connection^.intermediate_put_partial := FALSE;
                  IFEND;
                IFEND;
                file_instance^.sender_activity_status := activity_status;
                file_instance^.sender_active := TRUE;
                connection^.sender_request.remaining_bytes_to_send := bytes_to_send;
                connection^.send_file_identifier := file_identifier;
                condition_cause := nac$application_data;
                #SPOIL (condition_cause);
                IF description_upperbound <= nac$fixed_fragments THEN
                  connection^.sender_request.application_buffer.description_kind := nac$fixed;
                  nlp$al_initialize_data_descrip (data_area^, connection^.sender_request.
                        remaining_bytes_to_send, connection^.sender_request.application_buffer.
                        fixed_description);
                ELSE
                  connection^.sender_request.application_buffer.description_kind := nac$allocated;
                  REPEAT
                    ALLOCATE connection^.sender_request.application_buffer.allocated_description:
                          [1 .. description_upperbound] IN nav$network_paged_heap^;
                    IF connection^.sender_request.application_buffer.allocated_description = NIL THEN
                      syp$cycle;
                    IFEND;
                  UNTIL connection^.sender_request.application_buffer.allocated_description <> NIL;
                  nlp$al_initialize_data_descrip (data_area^, connection^.sender_request.
                        remaining_bytes_to_send, connection^.sender_request.application_buffer.
                        allocated_description^);
                IFEND;
                IF (capacity > 0) AND (connection^.send_put_partial_termination) THEN
                  nlp$sl_data_request (cl_connection, FALSE {qualified_data} , TRUE {END_OF_MESSAGE} ,
                        nav$null_data, status);
                  connection^.send_put_partial_termination := FALSE;
                IFEND;
                send_data (cl_connection, connection);
                IF cl_connection^.message_sender.active THEN
                  current_time := #FREE_RUNNING_CLOCK (0);
                  wait_time := file_instance^.data_transfer_timeout;
                  IF (file_instance^.data_transfer_timeout > ((current_time - start_time) DIV 1000)) THEN
                    request_started := TRUE;
                    nlp$select_timer ((file_instance^.data_transfer_timeout * 1000) -
                          (current_time - start_time), 0, connection^.send_timer);
                    activity_status^.complete := FALSE;
                  ELSE
                    ; {deactivate request
                    IF connection^.sender_request.application_buffer.description_kind = nac$allocated THEN
                      FREE connection^.sender_request.application_buffer.allocated_description IN
                            nav$network_paged_heap^;
                    IFEND;
                    nlp$cl_deactivate_sender (cl_connection);
                    file_instance^.sender_active := FALSE;
                    osp$set_status_condition (nae$data_transfer_timeout, status);
                    condition_cause := nac$activity_status;
                    #SPOIL (condition_cause);
                    activity_status^.status := status;
                  IFEND;
                IFEND;
              IFEND;
            ELSE
              IF (call_block.operation = nac$se_send_data_req) AND
                    (call_block.se_send_data_req.wait = osc$nowait) THEN
                osp$set_status_condition (nae$send_outstanding, status);
              ELSE
                request_started := FALSE;
                wait_time := file_instance^.data_transfer_timeout;
                activity_status^.complete := FALSE;
              IFEND;
            IFEND;
          ELSE
            IF connection^.nominal_connection THEN
              osp$set_status_condition (nae$interactive_cond_interrupt, status);
            ELSE
              osp$set_status_condition (nae$se_synchronize_in_progress, status);
            IFEND;
          IFEND;
        ELSE
          IF connection^.nominal_connection THEN
            osp$set_status_condition (nae$interactive_cond_interrupt, status);
            IF (NOT connection^.timesharing_disconnect_sent) AND
                  (connection^.supervisory_event_queue.beginning = NIL) AND
                  (connection^.wait_state <> nac$waiting_to_receive_data) THEN
              connection^.timesharing_disconnect_sent := TRUE;
              send_timesharing_signal (jmc$timesharing_disconnect, connection^.nominal_connection_task_id,
                    NIL);
            IFEND;
          ELSE
            osp$set_status_condition (nae$connection_terminated, status);
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
    IF (NOT status.normal) AND (status.condition = nae$connection_terminated) THEN
      fmp$convert_status (file_instance^.local_file_name, status);
    IFEND;
  PROCEND nlp$se_send_data;

?? TITLE := '  [XDCL] NAP$SE_SEND_DATA_HANDLER' ??
?? NEWTITLE := '    TERMINATE_SEND -- CONDITION HANDLER', EJECT ??

  PROCEDURE [XDCL] nap$se_send_data_handler
    (    originator: ost$global_task_id;
         signal: pmt$signal);


    PROCEDURE terminate_send
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF condition_cause = nac$application_data THEN
          IF cl_connection <> NIL THEN
            nlp$cl_deactivate_sender (cl_connection);
            IF ((connection^.sender_request.application_buffer.description_kind = nac$allocated) AND
                  (connection^.sender_request.application_buffer.allocated_description <> NIL)) THEN
              FREE connection^.sender_request.application_buffer.allocated_description IN
                    nav$network_paged_heap^;
            IFEND;
            osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
            condition_cause := nac$activity_status;
            #SPOIL (condition_cause);
            osp$establish_condition_handler (^terminate_send, FALSE);
            complete_activity (send, connection^.send_file_identifier, ^condition_status,
                  valid_file_identifier);
            IF NOT valid_file_identifier THEN
              nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
            IFEND;
            condition_status.normal := TRUE;
            nlp$cl_clear_exclusive_access (cl_connection);
            osp$pop_inhibit_job_recovery;
            EXIT nap$se_send_data_handler;
          ELSE
            osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
          IFEND;
        ELSEIF condition_cause = nac$activity_status THEN
          IF cl_connection <> NIL THEN
            IF (cl_connection^.message_sender.active) AND (cl_connection^.message_sender.task =
                  processing_task) THEN
              nlp$cl_deactivate_sender (cl_connection);
              IF ((connection^.sender_request.application_buffer.description_kind = nac$allocated) AND
                    (connection^.sender_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.sender_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              terminate_io (sender, connection^.send_file_identifier, valid_file_identifier);
              IF NOT valid_file_identifier THEN
                nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
              IFEND;
            IFEND;
            nlp$cl_clear_exclusive_access (cl_connection);
          IFEND;
          osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
        ELSE
          osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
          IF cl_connection <> NIL THEN
            nap$namve_system_error (TRUE, 'NAP$SE_SEND_DATA_HANLDER ', ^condition_status);
            nlp$cl_clear_exclusive_access (cl_connection);
          IFEND;
        IFEND;
        osp$pop_inhibit_job_recovery;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_send;
?? OLDTITLE, EJECT ??

    VAR
      cl_connection: ^nlt$cl_connection,
      cl_connection_id: ^nlt$cl_connection_id,
      condition_cause: nat$se_condition_cause,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      capacity: nat$data_length,
      layer_active: boolean,
      processing_task: ost$global_task_id,
      valid_file_identifier: boolean,
      status: ost$status;

    status.normal := TRUE;
    cl_connection_id := #LOC (signal.contents);
    cl_connection := NIL;
    condition_cause := nac$request_not_cause;
    #SPOIL (condition_cause, cl_connection);
    osp$push_inhibit_job_recovery;
    osp$establish_condition_handler (^terminate_send, FALSE);
    nlp$cl_get_exclusive_via_cid (cl_connection_id^, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      pmp$get_executing_task_gtid (processing_task);
      IF layer_active THEN
        #SPOIL (connection);
        IF cl_connection^.message_sender.active AND (cl_connection^.message_sender.task = processing_task)
              THEN
          IF connection^.connection_state = nac$established THEN

            IF connection^.break_connection_send THEN
              ; {deactive_send
              IF ((connection^.sender_request.application_buffer.description_kind = nac$allocated) AND
                    (connection^.sender_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.sender_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              connection^.break_connection_send := FALSE;
              nlp$cl_deactivate_sender (cl_connection);

              connection^.synchronize_request_send := FALSE;

              connection^.synchronize_send := FALSE;

              IF connection^.wait_state <> nac$waiting_to_receive_data THEN
                send_timesharing_signal (jmc$timesharing_synchronize, connection^.
                      nominal_connection_task_id, ^connection^.event);
              IFEND;
              condition_cause := nac$activity_status;
              #SPOIL (condition_cause);
              ; {nae$interactive_cond_interrupt
              osp$set_status_condition (nae$interactive_cond_interrupt, status);
              complete_activity (send, connection^.send_file_identifier, ^status, valid_file_identifier);
              IF NOT valid_file_identifier THEN
                nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
              IFEND;

            ELSEIF connection^.synchronize_request_send THEN
              ; {deactivate_send
              IF ((connection^.sender_request.application_buffer.description_kind = nac$allocated) AND
                    (connection^.sender_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.sender_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              nlp$cl_deactivate_sender (cl_connection);
              ; {terminate normally
              connection^.synchronize_request_send := FALSE;

              connection^.synchronize_send := FALSE;

              condition_cause := nac$activity_status;
              #SPOIL (condition_cause);
              complete_activity (send, connection^.send_file_identifier, NIL, valid_file_identifier);
              IF NOT valid_file_identifier THEN
                nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
              IFEND;

            ELSEIF connection^.synchronize_send THEN
              connection^.synchronize_send := FALSE;
              ; {deactivate_send
              IF ((connection^.sender_request.application_buffer.description_kind = nac$allocated) AND
                    (connection^.sender_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.sender_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              nlp$cl_deactivate_sender (cl_connection);
              ; {terminate normally
              connection^.synchronize_send := FALSE;
              condition_cause := nac$activity_status;
              #SPOIL (condition_cause);
              complete_activity (send, connection^.send_file_identifier, NIL, valid_file_identifier);
              IF NOT valid_file_identifier THEN
                nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
              IFEND;
            ELSE
              ; {continue normal processing
              nlp$osi_get_outbound_capacity (cl_connection, capacity);
              IF capacity > 0 THEN
                IF connection^.send_put_partial_termination THEN
                  nlp$sl_data_request (cl_connection, FALSE {qualified_data} , TRUE {END_OF_MESSAGE} ,
                        nav$null_data, status);
                  connection^.send_put_partial_termination := FALSE;
                IFEND;
                condition_cause := nac$application_data;
                #SPOIL (condition_cause);
                send_data (cl_connection, connection);
                IF NOT cl_connection^.message_sender.active THEN
                  condition_cause := nac$activity_status;
                  #SPOIL (condition_cause);
                  complete_activity (send, connection^.send_file_identifier, NIL, valid_file_identifier);
                  IF NOT valid_file_identifier THEN
                    nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
                  IFEND;
                IFEND;

              condition_cause := nac$request_not_cause;
              #SPOIL (condition_cause);

              IFEND;
            IFEND;
            IF (cl_connection^.message_sender.active) AND (connection^.send_timeout) THEN
              IF ((connection^.sender_request.application_buffer.description_kind = nac$allocated) AND
                    (connection^.sender_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.sender_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              nlp$cl_deactivate_sender (cl_connection);
              condition_cause := nac$activity_status;
              #SPOIL (condition_cause);
              osp$set_status_condition (nae$data_transfer_timeout, status);
              complete_activity (send, connection^.send_file_identifier, ^status, valid_file_identifier);
              IF NOT valid_file_identifier THEN
                nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
              IFEND;
            IFEND;
          ELSEIF connection^.connection_state = nac$terminated THEN
            ; {deactivate send nae$connection_teminated
            IF cl_connection^.message_sender.active THEN
              IF ((connection^.sender_request.application_buffer.description_kind = nac$allocated) AND
                    (connection^.sender_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.sender_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              nlp$cl_deactivate_sender (cl_connection);
              IF NOT connection^.nominal_connection THEN
                osp$set_status_condition (nae$connection_terminated, status);
              ELSE
                osp$set_status_condition (nae$interactive_cond_interrupt, status);
              IFEND;
              condition_cause := nac$activity_status;
              #SPOIL (condition_cause);
              complete_activity (send, connection^.send_file_identifier, ^status, valid_file_identifier);
              IF NOT valid_file_identifier THEN
                nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
        IF (connection^.connection_state = nac$terminated) AND
              (NOT connection^.timesharing_disconnect_sent) AND (connection^.nominal_connection) AND
              (connection^.data_queue.count = 0) AND (connection^.supervisory_event_queue.beginning = NIL) AND
              (connection^.wait_state <> nac$waiting_to_receive_data) AND
              (NOT cl_connection^.message_sender.active) AND (connection^.send_synchronize_count = 0) THEN
          ; {send signal
          connection^.timesharing_disconnect_sent := TRUE;
          send_timesharing_signal (jmc$timesharing_disconnect, connection^.nominal_connection_task_id, NIL);
        IFEND;
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$se_send_data_handler;

?? TITLE := '  [XDCL, #GATE] NLP$SE_SEND_INTERRUPT' ??
?? NEWTITLE := '    TERMINATE_SEND_INTERRUPT -- CONDITION HANDLER', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$se_send_interrupt
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);


    PROCEDURE terminate_send_interrupt
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF cl_connection <> NIL THEN
          nlp$cl_clear_exclusive_access (cl_connection);
          IF nlp$bm_valid_message_id (message_id) THEN
            nlp$bm_release_message (message_id);
          IFEND;
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
          EXIT nlp$se_send_interrupt;
        ELSE
          IF nlp$bm_valid_message_id (message_id) THEN
            nlp$bm_release_message (message_id);
          IFEND;
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
          EXIT nlp$se_send_interrupt;
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_send_interrupt;
?? OLDTITLE, EJECT ??

    VAR
      caller_id: ost$caller_identifier,
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      data: array [1 .. 1] of nat$data_fragment,
      data_length: nat$data_length,
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      ignore: integer,
      ignore_status: ost$status,
      layer_active: boolean,
      message_id: nlt$bm_message_id;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_condition (ame$improper_file_id, status);
      RETURN;
    IFEND;

    IF file_instance^.device_class <> rmc$network_device THEN
      osp$set_status_condition (ame$improper_device_class, status);
      RETURN;
    IFEND;

    IF caller_id.ring > file_instance^.instance_attributes.static_label.ring_attributes.r1 THEN
      amp$set_file_instance_abnormal (file_identifier, ame$ring_validation_error, call_block.operation, '',
            status);
      RETURN;
    IFEND;
    data [1].address := call_block.se_interrupt_data;
    data [1].length := #SIZE (call_block.se_interrupt_data^);
    nlp$al_get_data_length (data, data_length);
    IF (data_length <= nac$se_max_interrupt_data_len) AND (data_length >= nac$se_min_interrupt_data_len) THEN
      cl_connection := NIL;
      message_id := nlv$bm_null_message_id;
      osp$push_inhibit_job_recovery;
      osp$establish_condition_handler (^terminate_send_interrupt, FALSE);
      nlp$bm_create_message (data, message_id, ignore_status);
      nlp$cl_get_exclusive_via_cid (file_instance^.global_file_information^.device_dependent_info.
            network_connection_id, connection_exists, cl_connection);
      IF connection_exists THEN
        nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active,
              connection);
        IF layer_active THEN
          IF connection^.connection_state = nac$established THEN
            nlp$sl_interrupt_request (cl_connection, message_id, status);

{! statistics begin

            IF (nav$statistics_enabled) AND (status.normal) THEN
              osp$increment_locked_variable (nav$global_statistics.session.interrupt_requests_sent, 0,ignore);
            IFEND;

{! statistics end

          ELSE
            nlp$bm_release_message (message_id);
            osp$set_status_condition (nae$connection_terminated, status);
          IFEND;
        ELSE
          nlp$bm_release_message (message_id);
          osp$set_status_condition (nae$connection_terminated, status);
        IFEND;
        nlp$cl_release_exclusive_access (cl_connection);
      ELSE
        nlp$bm_release_message (message_id);
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      osp$pop_inhibit_job_recovery;
    ELSE
      osp$set_status_condition (nae$se_interrupt_length_error, status);
      osp$append_status_integer (osc$status_parameter_delimiter, nac$se_max_interrupt_data_len, 10, FALSE,
            status);
      osp$append_status_integer (osc$status_parameter_delimiter, nac$se_min_interrupt_data_len, 10, FALSE,
            status);
    IFEND;
  PROCEND nlp$se_send_interrupt;
?? TITLE := '  [XDCL, #GATE] NLP$SE_SYNCHRONIZE' ??
?? NEWTITLE := '    TERMINATE_SYNCHRONIZE -- CONDITION HANDLER', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$se_synchronize
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);


    PROCEDURE terminate_synchronize
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF cl_connection <> NIL THEN
          nlp$cl_clear_exclusive_access (cl_connection);
          IF nlp$bm_valid_message_id (message_id) THEN
            nlp$bm_release_message (message_id);
          IFEND;
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
          EXIT nlp$se_synchronize;
        ELSE
          IF nlp$bm_valid_message_id (message_id) THEN
            nlp$bm_release_message (message_id);
          IFEND;
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
          EXIT nlp$se_synchronize;
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_synchronize;
?? OLDTITLE, EJECT ??

    VAR
      caller_id: ost$caller_identifier,
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      data: array [1 .. 1] of nat$data_fragment,
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      ignore: integer,
      layer_active: boolean,
      message_id: nlt$bm_message_id,
      processing_task: ost$global_task_id;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_condition (ame$improper_file_id, status);
      RETURN;
    IFEND;

    IF file_instance^.device_class <> rmc$network_device THEN
      osp$set_status_condition (ame$improper_device_class, status);
      RETURN;
    IFEND;

    IF caller_id.ring > file_instance^.instance_attributes.static_label.ring_attributes.r1 THEN
      amp$set_file_instance_abnormal (file_identifier, ame$ring_validation_error, call_block.operation, '',
            status);
      RETURN;
    IFEND;
    IF (#SIZE (call_block.se_synchronize_req.data^) <= nac$se_max_synch_data_length) AND
          (#SIZE (call_block.se_synchronize_req.data^) >= nac$se_min_synch_data_length) THEN
      data [1].address := call_block.se_synchronize_req.data;
      data [1].length := #SIZE (call_block.se_synchronize_req.data^);
      message_id := nlv$bm_null_message_id;
      cl_connection := NIL;
      osp$push_inhibit_job_recovery;
      osp$establish_condition_handler (^terminate_synchronize, FALSE);
      ; {release message_id if condition_handler gets called
      nlp$bm_create_message (data, message_id, {ignore} status);
      status.normal := TRUE;
      nlp$cl_get_exclusive_via_cid (file_instance^.global_file_information^.device_dependent_info.
            network_connection_id, connection_exists, cl_connection);
      IF connection_exists THEN
        nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active,
              connection);
        IF layer_active THEN
          IF connection^.connection_state = nac$established THEN
            IF call_block.se_synchronize_req.direction = nac$se_synchronize_all_data THEN
              nlp$sl_synch_request (cl_connection, nlc$sl_discard_send_receive, message_id, status);
            ELSEIF call_block.se_synchronize_req.direction = nac$se_synchronize_send_data THEN
              nlp$sl_synch_request (cl_connection, nlc$sl_discard_send, message_id, status);
            ELSEIF call_block.se_synchronize_req.direction = nac$se_synchronize_receive_data THEN
              nlp$sl_synch_request (cl_connection, nlc$sl_discard_receive, message_id, status);
            ELSE
              osp$set_status_condition (nae$se_unknown_synch_direction, status);
            IFEND;
            IF status.normal THEN
              IF (call_block.se_synchronize_req.direction = nac$se_synchronize_all_data) OR
                    (call_block.se_synchronize_req.direction = nac$se_synchronize_receive_data) THEN
                {OK} connection^.receive_synchronize_count := connection^.receive_synchronize_count + 1;
                release_data_queue (connection^);
                nlp$ta_report_undelivered_data (cl_connection, 0);
                IF connection^.wait_state = nac$waiting_to_receive_data THEN
                  IF NOT connection^.synchronize_request_receive THEN
                    connection^.synchronize_request_receive := TRUE;
                  IFEND;
                  activate_receiver_task (cl_connection, cl_connection^.message_receiver.task);
                IFEND;
              IFEND;
              IF (call_block.se_synchronize_req.direction = nac$se_synchronize_all_data) OR
                    (call_block.se_synchronize_req.direction = nac$se_synchronize_send_data) THEN
                connection^.intermediate_put_partial := FALSE;
                connection^.send_put_partial_termination := FALSE;
                IF cl_connection^.message_sender.active THEN
                  nlp$cancel_timer (connection^.send_timer);
                  connection^.synchronize_request_send := TRUE;
                  pmp$get_executing_task_gtid (processing_task);
                  IF cl_connection^.message_sender.task = processing_task THEN
                    terminate_send_data (connection, cl_connection, NIL);
                  ELSE
                    activate_sender_task (cl_connection, cl_connection^.message_sender.task);
                  IFEND;
                IFEND;
              IFEND;

{! statistics begin

              IF nav$statistics_enabled THEN
                osp$increment_locked_variable (nav$global_statistics.session.synchronize_requests_sent, 0,
                      ignore);
              IFEND;

{! statistics end

            IFEND;
          ELSE
            nlp$bm_release_message (message_id);
            osp$set_status_condition (nae$connection_terminated, status);
          IFEND;
        ELSE
          nlp$bm_release_message (message_id);
          osp$set_status_condition (nae$connection_terminated, status);
        IFEND;
        nlp$cl_release_exclusive_access (cl_connection);
      ELSE
        nlp$bm_release_message (message_id);
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      osp$pop_inhibit_job_recovery;
    ELSE
      osp$set_status_condition (nae$se_synchronize_length_error, status);
      osp$append_status_integer (osc$status_parameter_delimiter, nac$se_max_synch_data_length, 10, FALSE,
            status);
      osp$append_status_integer (osc$status_parameter_delimiter, nac$se_min_synch_data_length, 10, FALSE,
            status);
    IFEND;
  PROCEND nlp$se_synchronize;
?? TITLE := '  [XDCL, #GATE] NLP$SE_SYNCHRONIZE_CONFIRM', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$se_synchronize_confirm
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      layer_active: boolean;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_condition (ame$improper_file_id, status);
      RETURN;
    IFEND;

    IF file_instance^.device_class <> rmc$network_device THEN
      osp$set_status_condition (ame$improper_device_class, status);
      RETURN;
    IFEND;

    IF caller_id.ring > file_instance^.instance_attributes.static_label.ring_attributes.r1 THEN
      amp$set_file_instance_abnormal (file_identifier, ame$ring_validation_error, call_block.operation, '',
            status);
      RETURN;
    IFEND;
    osp$push_inhibit_job_recovery;
    nlp$cl_get_exclusive_via_cid (file_instance^.global_file_information^.device_dependent_info.
          network_connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        IF connection^.connection_state = nac$established THEN
          IF connection^.send_synchronize_count > 0 THEN
            nlp$sl_synch_response (cl_connection, status);
            IF status.normal THEN
              {OK} connection^.send_synchronize_count := connection^.send_synchronize_count - 1;
              connection^.break_condition_active := FALSE;
              IF (connection^.nominal_connection) AND (connection^.supervisory_event_queue.beginning <> NIL)
                    THEN
                process_nominal_connect_events (connection, cl_connection);
              IFEND;
            IFEND;
          ELSE
            osp$set_status_condition (nae$se_no_synch_in_progress, status);
          IFEND;
        ELSE
          IF connection^.send_synchronize_count > 0 THEN
            connection^.send_synchronize_count := connection^.send_synchronize_count - 1;
            connection^.break_condition_active := FALSE;
            IF (connection^.nominal_connection) AND (connection^.supervisory_event_queue.beginning <> NIL)
                  THEN
              process_nominal_connect_events (connection, cl_connection);
            IFEND;
          IFEND;
          IF (connection^.connection_state = nac$terminated) AND
                (NOT connection^.timesharing_disconnect_sent) AND (connection^.nominal_connection) AND
                (connection^.data_queue.count = 0) AND (connection^.supervisory_event_queue.beginning =
                NIL) AND (connection^.wait_state <> nac$waiting_to_receive_data) AND
                (NOT cl_connection^.message_sender.active) AND (connection^.send_synchronize_count = 0) THEN
            ; {send signal
            connection^.timesharing_disconnect_sent := TRUE;
            send_timesharing_signal (jmc$timesharing_disconnect, connection^.nominal_connection_task_id, NIL);
          IFEND;
          osp$set_status_condition (nae$connection_terminated, status);
        IFEND;
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nlp$se_synchronize_confirm;

?? TITLE := '  [XDCL] NAP$STORE_CLIENT_IDENTITY', EJECT ??

  PROCEDURE [XDCL] nap$store_client_identity
    (    connection_id: nat$connection_id;
         client_identity: nat$client_identity;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      layer_active: boolean;

    status.normal := TRUE;
    osp$push_inhibit_job_recovery;
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        connection^.client_identity := client_identity;
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$store_client_identity;

?? TITLE := '  [XDCL, #GATE] NLP$FETCH_ATTRIBUTES' ??
?? NEWTITLE := '    TERMINATE_FETCH_ATTRIBUTES -- CONDITION HANDLER', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$fetch_attributes
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);


    PROCEDURE terminate_fetch_attributes
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF cl_connection <> NIL THEN
          nlp$cl_clear_exclusive_access (cl_connection);
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
          EXIT nlp$fetch_attributes;
        IFEND;
        osp$pop_inhibit_job_recovery;
        osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_fetch_attributes;
?? OLDTITLE, EJECT ??

    VAR
      caller_id: ost$caller_identifier,
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      i: integer,
      layer_active: boolean,
      optimum_transfer_size: nat$data_length;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_condition (ame$improper_file_id, status);
      RETURN;
    IFEND;

    IF file_instance^.device_class <> rmc$network_device THEN
      osp$set_status_condition (ame$improper_device_class, status);
      RETURN;
    IFEND;

    IF caller_id.ring > file_instance^.instance_attributes.static_label.ring_attributes.r2 THEN
      amp$set_file_instance_abnormal (file_identifier, ame$ring_validation_error, call_block.operation, '',
            status);
      RETURN;
    IFEND;
    cl_connection := NIL;
    osp$push_inhibit_job_recovery;
    osp$establish_condition_handler (^terminate_fetch_attributes, FALSE);
    nlp$cl_get_exclusive_via_cid (file_instance^.global_file_information^.device_dependent_info.
          network_connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        IF call_block.fetch_attributes <> NIL THEN

        /attribute_loop/
          FOR i := LOWERBOUND (call_block.fetch_attributes^) TO UPPERBOUND (call_block.fetch_attributes^) DO
            CASE call_block.fetch_attributes^ [i].kind OF
            = nac$client_identity =
              call_block.fetch_attributes^ [i].client_identity := connection^.client_identity;
            = nac$connect_data =
              IF connection^.connect_data <> NIL THEN
                nap$move_data_to_user_data_area (connection^.connect_data,
                      call_block.fetch_attributes^ [i].connect_data,
                      call_block.fetch_attributes^ [i].connect_data_length, status);
                IF (NOT status.normal) AND (status.condition = nae$data_area_too_small) THEN
                  osp$append_status_parameter (osc$status_parameter_delimiter, 'See NAC$CONNECT_DATA.',
                        status);
                IFEND;
              ELSE
                call_block.fetch_attributes^ [i].connect_data_length := 0;
              IFEND;
            = nac$connection_state =
              call_block.fetch_attributes^ [i].connection_state := connection^.connection_state;
            = nac$data_transfer_timeout =
              call_block.fetch_attributes^ [i].data_transfer_timeout := file_instance^.data_transfer_timeout;
            = nac$eoi_message =
              IF file_instance^.eoi_message <> NIL THEN
                call_block.fetch_attributes^ [i].eoi_message := file_instance^.eoi_message^;
              ELSE
                call_block.fetch_attributes^ [i].eoi_message := nav$eoi_message;
              IFEND;
            = nac$eoi_message_enabled =
              call_block.fetch_attributes^ [i].eoi_message_enabled := file_instance^.eoi_message_enabled;
            = nac$eoi_peer_termination =
              call_block.fetch_attributes^ [i].eoi_peer_termination := file_instance^.eoi_peer_termination;
            = nac$local_address =
              call_block.fetch_attributes^ [i].local_address := connection^.local_address;
            = nac$null_attribute =
            = nac$optimum_transfer_unit_incr =
              get_optimum_transfer_size (cl_connection, optimum_transfer_size);
              call_block.fetch_attributes^ [i].optimum_transfer_unit_incr := optimum_transfer_size -
                    #SIZE (nlt$sl_pdu_header);
            = nac$optimum_transfer_unit_size =
              get_optimum_transfer_size (cl_connection, optimum_transfer_size);
              call_block.fetch_attributes^ [i].optimum_transfer_unit_size := optimum_transfer_size -
                    #SIZE (nlt$sl_pdu_header);
            = nac$peer_accounting_information =
              IF connection^.peer_accounting_information <> NIL THEN
                nap$move_data_to_user_data_area (connection^.peer_accounting_information,
                      call_block.fetch_attributes^ [i].peer_accounting_information,
                      call_block.fetch_attributes^ [i].peer_accounting_info_length, status);
                IF (NOT status.normal) AND (status.condition = nae$data_area_too_small) THEN
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        'See NAC$PEER_ACCOUNTING_INFORMATION.', status);
                IFEND;
              ELSE
                call_block.fetch_attributes^ [i].peer_accounting_info_length := 0;
              IFEND;
            = nac$peer_address =
              call_block.fetch_attributes^ [i].peer_address := connection^.peer_address;
            = nac$peer_connect_data =
              IF connection^.peer_connect_data <> NIL THEN
                nap$move_data_to_user_data_area (connection^.peer_connect_data, call_block.
                      fetch_attributes^ [i].peer_connect_data, call_block.fetch_attributes^ [i].
                      peer_connect_data_length, status);
                IF (NOT status.normal) AND (status.condition = nae$data_area_too_small) THEN
                  osp$append_status_parameter (osc$status_parameter_delimiter, 'SEE NAC$PEER_CONNECT_DATA.',
                        status);
                IFEND;
              ELSE
                call_block.fetch_attributes^ [i].peer_connect_data_length := 0;
              IFEND;
            = nac$peer_termination_data =
              IF connection^.peer_termination_data <> NIL THEN
                nap$move_data_to_user_data_area (connection^.peer_termination_data,
                      call_block.fetch_attributes^ [i].peer_termination_data, call_block.
                      fetch_attributes^ [i].peer_termination_data_length, status);
                IF (NOT status.normal) AND (status.condition = nae$data_area_too_small) THEN
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        'See NAC$PEER_TERMINATION_DATA.', status);
                IFEND;
              ELSE
                call_block.fetch_attributes^ [i].peer_termination_data_length := 0;
              IFEND;
            = nac$protocol =
              call_block.fetch_attributes^ [i].protocol := connection^.protocol;
            = nac$receive_wait_swapout =
              call_block.fetch_attributes^ [i].receive_wait_swapout := connection^.receive_wait_swapout;
            = nac$termination_data =
              IF connection^.termination_data <> NIL THEN
                nap$move_data_to_user_data_area (connection^.termination_data, call_block.
                      fetch_attributes^ [i].termination_data, call_block.fetch_attributes^ [i].
                      termination_data_length, status);
                IF (NOT status.normal) AND (status.condition = nae$data_area_too_small) THEN
                  osp$append_status_parameter (osc$status_parameter_delimiter, 'See NAC$TERMINATION_DATA.',
                        status);
                IFEND;
              ELSE
                call_block.fetch_attributes^ [i].termination_data_length := 0;
              IFEND;
            = nac$termination_reason =
              call_block.fetch_attributes^ [i].termination_reason := connection^.termination_reason;
            ELSE
              osp$set_status_abnormal (nac$status_id, nae$unknown_attribute, ' on FETCH_ATTRIBUTES ', status);
            CASEND;
            IF NOT status.normal THEN
              EXIT /attribute_loop/;
            IFEND;
          FOREND /attribute_loop/;
        IFEND;

      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nlp$fetch_attributes;
?? TITLE := '  [XDCL, #GATE] NLP$STORE_ATTRIBUTES' ??
?? NEWTITLE := '    TERMINATE_STORE_ATTRIBUTES -- CONDITION HANDLER', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$store_attributes
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);


    PROCEDURE terminate_store_attributes
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF cl_connection <> NIL THEN
          nlp$cl_clear_exclusive_access (cl_connection);
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
          EXIT nlp$store_attributes;
        IFEND;
        osp$pop_inhibit_job_recovery;
        osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_store_attributes;
?? OLDTITLE, EJECT ??

    VAR
      caller_id: ost$caller_identifier,
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      error_string: string (256),
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      i: integer,
      layer_active: boolean,
      length: integer;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_condition (ame$improper_file_id, status);
      RETURN;
    IFEND;

    IF file_instance^.device_class <> rmc$network_device THEN
      osp$set_status_condition (ame$improper_device_class, status);
      RETURN;
    IFEND;

    IF caller_id.ring > file_instance^.instance_attributes.static_label.ring_attributes.r1 THEN
      amp$set_file_instance_abnormal (file_identifier, ame$ring_validation_error, call_block.operation, '',
            status);
      RETURN;
    IFEND;
    cl_connection := NIL;
    osp$push_inhibit_job_recovery;
    osp$establish_condition_handler (^terminate_store_attributes, FALSE);
    nlp$cl_get_exclusive_via_cid (file_instance^.global_file_information^.device_dependent_info.
          network_connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        IF call_block.store_attributes <> NIL THEN
          FOR i := LOWERBOUND (call_block.store_attributes^) TO UPPERBOUND (call_block.store_attributes^) DO
            CASE call_block.store_attributes^ [i].kind OF
            = nac$connect_data =
              IF connection^.connection_state = nac$connection_request_received THEN
                IF ((call_block.store_attributes^ [i].connect_data <> NIL) AND
                      (#SIZE (call_block.store_attributes^ [i].connect_data^) <= nac$maximum_connect_data)) OR
                      (call_block.store_attributes^ [i].connect_data = NIL) THEN
                  nap$move_user_data_to_data_area (call_block.store_attributes^ [i].connect_data,
                        connection^.connect_data);
                ELSE
                  STRINGREP (error_string, length, nac$maximum_connect_data, ' for NAC$CONNECT_DATA');
                  osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, error_string, status);
                IFEND;
              ELSE { invalid state
                osp$set_status_condition (nae$invalid_connect_data_change, status);
              IFEND;
            = nac$data_transfer_timeout =
              file_instance^.data_transfer_timeout := call_block.store_attributes^ [i].data_transfer_timeout;
            = nac$eoi_message =
              IF call_block.store_attributes^ [i].eoi_message.size <= 31 {nac$maximum_eoi_size} THEN
                IF file_instance^.eoi_message = NIL THEN
                  ALLOCATE file_instance^.eoi_message IN osv$task_private_heap^;
                IFEND;
                file_instance^.eoi_message^ := call_block.store_attributes^ [i].eoi_message;
              ELSE
                osp$set_status_abnormal (nac$status_id, nae$invalid_eoi_message_size, '31'
                      {nac$maximum_eoi_size} , status);
              IFEND;
            = nac$eoi_message_enabled =
              file_instance^.eoi_message_enabled := call_block.store_attributes^ [i].eoi_message_enabled;
            = nac$eoi_peer_termination =
              file_instance^.eoi_peer_termination := call_block.store_attributes^ [i].eoi_peer_termination;
            = nac$null_attribute =
            = nac$receive_wait_swapout =
              connection^.receive_wait_swapout := call_block.store_attributes^ [i].receive_wait_swapout;
            = nac$termination_data =
              IF ((call_block.store_attributes^ [i].termination_data <> NIL) AND
                    (#SIZE (call_block.store_attributes^ [i].termination_data^) <=
                    nac$maximum_termination_data)) OR (call_block.store_attributes^ [i].termination_data =
                    NIL) THEN
                nap$move_user_data_to_data_area (call_block.store_attributes^ [i].termination_data,
                      connection^.termination_data);
              ELSE
                STRINGREP (error_string, length, nac$maximum_termination_data, ' for NAC$TERMINATION_DATA');
                osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, error_string, status);
              IFEND;
            ELSE
              osp$set_status_abnormal (nac$status_id, nae$unknown_attribute, ' on STORE ATTRIBUTES ', status);
            CASEND;
          FOREND;
        IFEND;
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nlp$store_attributes;

?? TITLE := 'NAP$GET_ATTRIBUTES', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$get_attributes
    (    file: fst$file_reference;
     VAR attributes: {input, output} nat$get_attributes;
     VAR status: ost$status);

*copyc nah$get_attributes

?? NEWTITLE := '    TERMINATE_GET_ATTRIBUTES -- CONDITION HANDLER', EJECT ??

    PROCEDURE terminate_get_attributes
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF cl_connection <> NIL THEN
          nlp$cl_clear_exclusive_access (cl_connection);
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
          #KEYPOINT (osk$exit, osk$m * amk_get_attributes, nak$session_external);
          EXIT nap$get_attributes;
        IFEND;
        osp$pop_inhibit_job_recovery;
        osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
        #KEYPOINT (osk$exit, osk$m * amk_get_attributes, nak$session_external);
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_get_attributes;
?? OLDTITLE, EJECT ??

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      connection_id: nat$connection_id,
      i: integer,
      layer_active: boolean,
      optimum_transfer_size: nat$data_length,
      switch_offer_pending: boolean;

    #KEYPOINT (osk$entry, osk$m * amk_get_attributes, nak$session_external);
    status.normal := TRUE;

    fmp$get_connection_identifier (file, connection_id, switch_offer_pending, status);
    IF NOT status.normal THEN
      IF status.condition = fme$no_cycle_description THEN
        osp$set_status_abnormal ('AM', ame$file_not_known, file, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'A GET ATTRIBUTES ', status);
      IFEND;
      #KEYPOINT (osk$exit, osk$m * amk_get_attributes, nak$session_external);
      RETURN;
    IFEND;

    IF switch_offer_pending THEN
      osp$set_status_condition (nae$switch_offer_pending, status);
      #KEYPOINT (osk$exit, osk$m * amk_get_attributes, nak$session_external);
      RETURN;
    IFEND;

    cl_connection := NIL;
    osp$push_inhibit_job_recovery;
    osp$establish_condition_handler (^terminate_get_attributes, FALSE);
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN

      /attribute_loop/
        FOR i := LOWERBOUND (attributes) TO UPPERBOUND (attributes) DO
          CASE attributes [i].kind OF
          = nac$client_identity =
            attributes [i].client_identity := connection^.client_identity;
          = nac$connect_data =
            IF connection^.connect_data <> NIL THEN
              nap$move_data_to_user_data_area (connection^.connect_data, attributes [i].connect_data,
                    attributes [i].connect_data_length, status);
              IF (NOT status.normal) AND (status.condition = nae$data_area_too_small) THEN
                osp$append_status_parameter (osc$status_parameter_delimiter, 'See NAC$CONNECT_DATA.', status);
              IFEND;
            ELSE
              attributes [i].connect_data_length := 0;
            IFEND;
          = nac$connection_state =
            attributes [i].connection_state := connection^.connection_state;
          = nac$data_transfer_timeout =
            attributes [i].data_transfer_timeout := connection^.data_transfer_timeout;
          = nac$eoi_message =
            IF connection^.eoi_message <> NIL THEN
              attributes [i].eoi_message := connection^.eoi_message^;
            ELSE
              attributes [i].eoi_message := nav$eoi_message;
            IFEND;
          = nac$eoi_message_enabled =
            attributes [i].eoi_message_enabled := connection^.eoi_message_enabled;
          = nac$eoi_peer_termination =
            attributes [i].eoi_peer_termination := connection^.eoi_peer_termination;
          = nac$local_address =
            attributes [i].local_address := connection^.local_address;
          = nac$null_attribute =
          = nac$optimum_transfer_unit_incr =
            get_optimum_transfer_size (cl_connection, optimum_transfer_size);
            attributes [i].optimum_transfer_unit_incr := optimum_transfer_size - #SIZE (nlt$sl_pdu_header);
          = nac$optimum_transfer_unit_size =
            get_optimum_transfer_size (cl_connection, optimum_transfer_size);
            attributes [i].optimum_transfer_unit_size := optimum_transfer_size - #SIZE (nlt$sl_pdu_header);
          = nac$peer_accounting_information =
            IF connection^.peer_accounting_information <> NIL THEN
              nap$move_data_to_user_data_area (connection^.peer_accounting_information,
                    attributes [i].peer_accounting_information, attributes [i].peer_accounting_info_length,
                    status);
              IF (NOT status.normal) AND (status.condition = nae$data_area_too_small) THEN
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      'See NAC$PEER_ACCOUNTING_INFORMATION.', status);
              IFEND;
            ELSE
              attributes [i].peer_accounting_info_length := 0;
            IFEND;
          = nac$peer_address =
            attributes [i].peer_address := connection^.peer_address;
          = nac$peer_connect_data =
            IF connection^.peer_connect_data <> NIL THEN
              nap$move_data_to_user_data_area (connection^.peer_connect_data, attributes [i].
                    peer_connect_data, attributes [i].peer_connect_data_length, status);
              IF (NOT status.normal) AND (status.condition = nae$data_area_too_small) THEN
                osp$append_status_parameter (osc$status_parameter_delimiter, 'See NAC$PEER_CONNECT_DATA.',
                      status);
              IFEND;
            ELSE
              attributes [i].peer_connect_data_length := 0;
            IFEND;
          = nac$peer_termination_data =
            IF connection^.peer_termination_data <> NIL THEN
              nap$move_data_to_user_data_area (connection^.peer_termination_data,
                    attributes [i].peer_termination_data, attributes [i].peer_termination_data_length,
                    status);
              IF (NOT status.normal) AND (status.condition = nae$data_area_too_small) THEN
                osp$append_status_parameter (osc$status_parameter_delimiter, 'See NAC$PEER_TERMINATION_DATA.',
                      status);
              IFEND;
            ELSE
              attributes [i].peer_termination_data_length := 0;
            IFEND;
          = nac$protocol =
            attributes [i].protocol := connection^.protocol;
          = nac$receive_wait_swapout =
            attributes [i].receive_wait_swapout := connection^.receive_wait_swapout;
          = nac$termination_data =
            IF connection^.termination_data <> NIL THEN
              nap$move_data_to_user_data_area (connection^.termination_data, attributes [i].termination_data,
                    attributes [i].termination_data_length, status);
              IF (NOT status.normal) AND (status.condition = nae$data_area_too_small) THEN
                osp$append_status_parameter (osc$status_parameter_delimiter, 'See NAC$TERMINATION_DATA.',
                      status);
              IFEND;
            ELSE
              attributes [i].termination_data_length := 0;
            IFEND;
          = nac$termination_reason =
            attributes [i].termination_reason := connection^.termination_reason;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$unknown_attribute, ' on GET ATTRIBUTES ', status);
          CASEND;
          IF NOT status.normal THEN
            EXIT /attribute_loop/;
          IFEND;
        FOREND /attribute_loop/;
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
    #KEYPOINT (osk$exit, osk$m * amk_get_attributes, nak$session_external);
  PROCEND nap$get_attributes;

?? TITLE := 'NAP$CHANGE_ATTRIBUTES', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$change_attributes
    (    file: fst$file_reference;
         attributes: nat$change_attributes;
     VAR status: ost$status);

*copyc nah$change_attributes

?? NEWTITLE := '    TERMINATE_CHANGE_ATTRIBUTES -- CONDITION HANDLER', EJECT ??

    PROCEDURE terminate_change_attributes
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF cl_connection <> NIL THEN
          nlp$cl_clear_exclusive_access (cl_connection);
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
          #KEYPOINT (osk$exit, osk$m * amk_change_attributes, nak$session_external);
          EXIT nap$change_attributes;
        IFEND;
        osp$pop_inhibit_job_recovery;
        osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
        #KEYPOINT (osk$exit, osk$m * amk_change_attributes, nak$session_external);
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_change_attributes;
?? OLDTITLE, EJECT ??

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      connection_id: nat$connection_id,
      error_string: string (256),
      i: integer,
      layer_active: boolean,
      length: integer,
      switch_offer_pending: boolean;

    #KEYPOINT (osk$entry, osk$m * amk_change_attributes, nak$session_external);
    status.normal := TRUE;

    fmp$get_connection_identifier (file, connection_id, switch_offer_pending, status);
    IF NOT status.normal THEN
      IF status.condition = fme$no_cycle_description THEN
        osp$set_status_abnormal ('AM', ame$file_not_known, file, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'A CHANGE ATTRIBUTES ', status);
      IFEND;
      #KEYPOINT (osk$exit, osk$m * amk_change_attributes, nak$session_external);
      RETURN;
    IFEND;

    IF switch_offer_pending THEN
      osp$set_status_condition (nae$switch_offer_pending, status);
      #KEYPOINT (osk$exit, osk$m * amk_change_attributes, nak$session_external);
      RETURN;
    IFEND;

    cl_connection := NIL;
    osp$push_inhibit_job_recovery;
    osp$establish_condition_handler (^terminate_change_attributes, FALSE);
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        FOR i := LOWERBOUND (attributes) TO UPPERBOUND (attributes) DO
          CASE attributes [i].kind OF
          = nac$connect_data =
            IF connection^.connection_state = nac$connection_request_received THEN
              IF ((attributes [i].connect_data <> NIL) AND (#SIZE (attributes [i].connect_data^) <=
                    nac$maximum_connect_data)) OR (attributes [i].connect_data = NIL) THEN
                nap$move_user_data_to_data_area (attributes [i].connect_data, connection^.connect_data);
              ELSE
                STRINGREP (error_string, length, nac$maximum_connect_data, ' for NAC$CONNECT_DATA');
                osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, error_string, status);
              IFEND;
            ELSE { invalid state
              osp$set_status_condition (nae$invalid_connect_data_change, status);
            IFEND;
          = nac$data_transfer_timeout =
            connection^.data_transfer_timeout := attributes [i].data_transfer_timeout;
          = nac$eoi_message =
            IF attributes [i].eoi_message.size <= 31 {nac$maximum_eoi_size} THEN
              IF connection^.eoi_message = NIL THEN
                REPEAT
                  ALLOCATE connection^.eoi_message IN nav$network_paged_heap^;
                  IF connection^.eoi_message = NIL THEN
                    syp$cycle;
                  IFEND;
                UNTIL connection^.eoi_message <> NIL;
              IFEND;
              connection^.eoi_message^ := attributes [i].eoi_message;
            ELSE
              osp$set_status_abnormal (nac$status_id, nae$invalid_eoi_message_size, '31'
                    {nac$maximum_eoi_size} , status);
            IFEND;
          = nac$eoi_message_enabled =
            connection^.eoi_message_enabled := attributes [i].eoi_message_enabled;
          = nac$eoi_peer_termination =
            connection^.eoi_peer_termination := attributes [i].eoi_peer_termination;
          = nac$null_attribute =
          = nac$receive_wait_swapout =
            connection^.receive_wait_swapout := attributes [i].receive_wait_swapout;
          = nac$termination_data =
            IF ((attributes [i].termination_data <> NIL) AND (#SIZE (attributes [i].termination_data^) <=
                  nac$maximum_termination_data)) OR (attributes [i].termination_data = NIL) THEN
              nap$move_user_data_to_data_area (attributes [i].termination_data, connection^.termination_data);
            ELSE
              STRINGREP (error_string, length, 'the maximum allowed termination_data length of ',
                    nac$maximum_termination_data, ' for NAC$TERMINATION_DATA');
              osp$set_status_abnormal (nac$status_id, nae$max_data_length_exceeded, error_string, status);
            IFEND;
          ELSE
            osp$set_status_abnormal (nac$status_id, nae$unknown_attribute, ' on CHANGE ATTRIBUTES ', status);
          CASEND;
        FOREND;
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
    #KEYPOINT (osk$exit, osk$m * amk_change_attributes, nak$session_external);
  PROCEND nap$change_attributes;
?? TITLE := '  [INLINE] ACTIVATE_SENDER_TASK', EJECT ??

  PROCEDURE [INLINE] activate_sender_task
    (    cl_connection: ^nlt$cl_connection;
         task: ost$global_task_id);

    VAR
      cl_connection_id: ^nlt$cl_connection_id,
      signal: pmt$signal,
      status: ost$status;

    signal.identifier := nac$se_send_data_signal;
    cl_connection_id := #LOC (signal.contents);
    cl_connection_id^ := cl_connection^.identifier;
    pmp$send_signal (task, signal, status);
    IF NOT status.normal THEN
      nlp$cl_deactivate_sender (cl_connection);
    IFEND;
  PROCEND activate_sender_task;
?? TITLE := '  [INLINE] ACTIVATE_RECEIVER_TASK', EJECT ??

  PROCEDURE [INLINE] activate_receiver_task
    (    cl_connection: ^nlt$cl_connection;
         task: ost$global_task_id);

    VAR
      cl_connection_id: ^nlt$cl_connection_id,
      signal: pmt$signal,
      status: ost$status;

    signal.identifier := nac$se_deliver_data_signal;
    cl_connection_id := #LOC (signal.contents);
    cl_connection_id^ := cl_connection^.identifier;
    pmp$send_signal (task, signal, status);
  PROCEND activate_receiver_task;
?? TITLE := '[INLINE] send_disconnect_signal', EJECT ??

  PROCEDURE [INLINE] send_disconnect_signal
    (    cl_connection: ^nlt$cl_connection;
         task: ost$global_task_id);

    VAR
      cl_connection_id: ^nlt$cl_connection_id,
      signal: pmt$signal,
      status: ost$status;

    signal.identifier := nac$se_disconnect_signal;
    cl_connection_id := #LOC (signal.contents);
    cl_connection_id^ := cl_connection^.identifier;
    pmp$send_signal (task, signal, status);
  PROCEND send_disconnect_signal;
?? TITLE := '  PROCESS_CONNECTION_EVENT' ??
?? NEWTITLE := '    CONTINUE_SEND_DATA' ??
?? NEWTITLE := '      TERMINATE_SEND -- CONDITION HANDLER', EJECT ??

  PROCEDURE [XDCL] nap$se_process_connection_event
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$sl_event;
     VAR inventory_report: nlt$sl_inventory_report);


    PROCEDURE continue_send_data
      (    connection: ^nat$connection_descriptor;
           cl_connection: ^nlt$cl_connection);

      VAR
        condition_cause: nat$se_condition_cause;

      PROCEDURE terminate_send
        (    condition: pmt$condition;
             ignore_condition_descriptor: ^pmt$condition_information;
             sa: ^ost$stack_frame_save_area;
         VAR condition_status: ost$status);

        VAR
          status: ost$status;

        CASE condition.selector OF
        = pmc$system_conditions, mmc$segment_access_condition =
          IF condition_cause = nac$application_data THEN
            nlp$cl_deactivate_sender (cl_connection);
            IF ((connection^.sender_request.application_buffer.description_kind = nac$allocated) AND
                  (connection^.sender_request.application_buffer.allocated_description <> NIL)) THEN
              FREE connection^.sender_request.application_buffer.allocated_description IN
                    nav$network_paged_heap^;
            IFEND;
            osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
            condition_cause := nac$activity_status;
            #SPOIL (condition_cause);
            osp$establish_condition_handler (^terminate_send, FALSE);
            complete_activity (send, connection^.send_file_identifier, ^status, valid_file_identifier);
            IF NOT valid_file_identifier THEN
              nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
            IFEND;
            EXIT continue_send_data;
          ELSEIF condition_cause = nac$activity_status THEN
            IF (cl_connection^.message_sender.active) AND (cl_connection^.message_sender.task =
                  processing_task) THEN
              nlp$cl_deactivate_sender (cl_connection);
              IF ((connection^.sender_request.application_buffer.description_kind = nac$allocated) AND
                    (connection^.sender_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.sender_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              terminate_io (sender, connection^.send_file_identifier, valid_file_identifier);
              IF NOT valid_file_identifier THEN
                nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
              IFEND;
            IFEND;
            osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
          ELSE
            osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
          IFEND;
        ELSE
          condition_status.normal := TRUE;
        CASEND;
      PROCEND terminate_send;
?? OLDTITLE, EJECT ??

      VAR
        capacity: nat$data_length,
        valid_file_identifier: boolean;

      ; {continue normal processing
      nlp$osi_get_outbound_capacity (cl_connection, capacity);
      IF (capacity > 0) THEN
        condition_cause := nac$application_data;
        #SPOIL (condition_cause);
        osp$establish_condition_handler (^terminate_send, FALSE);
        IF connection^.send_put_partial_termination THEN
          nlp$sl_data_request (cl_connection, FALSE {qualified_data} , TRUE {END_OF_MESSAGE} , nav$null_data,
                ignore_status);
          connection^.send_put_partial_termination := FALSE;
        IFEND;
        send_data (cl_connection, connection);
        IF NOT cl_connection^.message_sender.active THEN
          condition_cause := nac$activity_status;
          #SPOIL (condition_cause);
          complete_activity (send, connection^.send_file_identifier, NIL, valid_file_identifier);
          IF NOT valid_file_identifier THEN
            nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
          IFEND;
        IFEND;

        condition_cause := nac$request_not_cause;
        #SPOIL (condition_cause);

      IFEND;
    PROCEND continue_send_data;
?? TITLE := '    CONTINUE_RECEIVE_DATA' ??
?? NEWTITLE := '      TERMINATE_CONTINUE_RECEIVE_DATA -- CONDITION HANDLER', EJECT ??

    PROCEDURE continue_receive_data
      (    connection: ^nat$connection_descriptor;
           cl_connection: ^nlt$cl_connection);

      VAR
        condition_cause: nat$se_condition_cause;


      PROCEDURE terminate_continue_receive_data
        (    condition: pmt$condition;
             ignore_condition_descriptor: ^pmt$condition_information;
             sa: ^ost$stack_frame_save_area;
         VAR condition_status: ost$status);

        VAR
          status: ost$status;

        CASE condition.selector OF
        = pmc$system_conditions, mmc$segment_access_condition =
          IF (condition_cause = nac$application_data) OR (condition_cause = nac$application_event) THEN
            nlp$cl_deactivate_receiver (cl_connection);
            connection^.wait_state := nac$inactive_wait;
            IF ((connection^.receiver_request.application_buffer.description_kind = nac$allocated) AND
                  (connection^.receiver_request.application_buffer.allocated_description <> NIL)) THEN
              FREE connection^.receiver_request.application_buffer.allocated_description IN
                    nav$network_paged_heap^;
            IFEND;
            osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
            condition_cause := nac$activity_status;
            #SPOIL (condition_cause);
            osp$establish_condition_handler (^terminate_continue_receive_data, FALSE);
            complete_activity (receive, connection^.receive_file_identifier, ^status, valid_file_identifier);
            IF NOT valid_file_identifier THEN
              nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
            IFEND;
            EXIT continue_receive_data;
          ELSEIF condition_cause = nac$activity_status THEN
            IF (connection^.wait_state = nac$waiting_to_receive_data) AND
                  (cl_connection^.message_receiver.task = processing_task) THEN
              nlp$cl_deactivate_receiver (cl_connection);
              connection^.wait_state := nac$inactive_wait;
              IF ((connection^.receiver_request.application_buffer.description_kind = nac$allocated) AND
                    (connection^.receiver_request.application_buffer.allocated_description <> NIL)) THEN
                FREE connection^.receiver_request.application_buffer.allocated_description IN
                      nav$network_paged_heap^;
              IFEND;
              terminate_io (receiver, connection^.receive_file_identifier, valid_file_identifier);
              IF NOT valid_file_identifier THEN
                nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
              IFEND;
            IFEND;
            nlp$ta_report_undelivered_data (cl_connection, connection^.total_message_buffers_queued);
            osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
          ELSE
            osp$set_status_from_condition (nac$status_id, condition, sa, condition_status, status);
          IFEND;
        ELSE
          condition_status.normal := TRUE;
        CASEND;
      PROCEND terminate_continue_receive_data;
?? OLDTITLE, EJECT ??

      VAR
        delivery_complete: boolean,
        valid_file_identifier: boolean;

      ; {continue normal processing
      osp$establish_condition_handler (^terminate_continue_receive_data, FALSE);
      condition_cause := nac$application_data;
      #SPOIL (condition_cause);
      deliver_connection_events (connection, cl_connection, delivery_complete, condition_cause,
            ignore_status);
      IF delivery_complete THEN
        nlp$cl_deactivate_receiver (cl_connection);
        connection^.wait_state := nac$inactive_wait;
        IF (connection^.data_queue.count > 0) OR (connection^.supervisory_event_queue.beginning <> NIL) THEN
          nlp$select_timer (nac$inactive_receiver_timeout, 0, connection^.event_timer);
        ELSE
          nlp$cancel_timer (connection^.event_timer);
        IFEND;
        condition_cause := nac$activity_status;
        #SPOIL (condition_cause);
        complete_activity (receive, connection^.receive_file_identifier, NIL, valid_file_identifier);
        IF NOT valid_file_identifier THEN
          nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
        IFEND;
      IFEND;
    PROCEND continue_receive_data;
?? OLDTITLE, EJECT ??

    VAR
      accounting_info: ^array [1 .. * ] of cell,
      active_file: boolean,
      connection: ^nat$connection_descriptor,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      data_length: integer,
      event_element: ^nat$se_supervisory_element,
      ignore: integer,
      ignore_status: ost$status,
      layer_active: boolean,
      message_id: nlt$bm_message_id,
      processing_task: ost$global_task_id,
      se_event: nat$se_peer_operation;

    nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
    CASE event.kind OF
?? NEWTITLE := ' DATA_INDICATION', EJECT ??

    = nlc$sl_data_event =
      IF connection^.receive_synchronize_count > 0 THEN
        message_id := event.data.message_id;
        nlp$bm_release_message (message_id);
        inventory_report.changed := FALSE;
      ELSEIF connection^.discard_to_end_of_message THEN
        message_id := event.data.message_id;
        nlp$bm_release_message (message_id);
        IF event.data.end_of_message THEN
          dequeue_data_event (connection^);
          connection^.discard_to_end_of_message := FALSE;
        IFEND;
        inventory_report.changed := FALSE;
      ELSE
        IF (connection^.wait_state <> nac$waiting_to_receive_data) AND (connection^.data_queue.count = 0) AND
              (connection^.supervisory_event_queue.beginning = NIL) THEN
          nlp$select_timer (nac$inactive_receiver_timeout, 0, connection^.event_timer);
        IFEND;
        queue_data_event (event, connection^);
        IF (connection^.wait_state = nac$waiting_for_data_available) AND
              ((connection^.data_queue.beginning^.event_element [connection^.data_queue.beginning^.first].
              event.end_of_message) OR (connection^.total_data_queued >=
              4096 {nac$min_await_data_available} ) OR (connection^.total_message_buffers_queued >= 4)) THEN
          pmp$get_executing_task_gtid (processing_task);
          IF cl_connection^.message_receiver.task <> processing_task THEN
            pmp$ready_task (cl_connection^.message_receiver.task, ignore_status);
          IFEND;
          nlp$cl_deactivate_receiver (cl_connection);
          connection^.wait_state := nac$inactive_wait;
        ELSEIF connection^.wait_state = nac$waiting_to_receive_data THEN
          pmp$get_executing_task_gtid (processing_task);
          IF cl_connection^.message_receiver.task = processing_task THEN
            continue_receive_data (connection, cl_connection);
          ELSE
            activate_receiver_task (cl_connection, cl_connection^.message_receiver.task);
          IFEND;
        IFEND;
        inventory_report.changed := TRUE;
        inventory_report.accumulated_message_buffers := connection^.total_message_buffers_queued;
      IFEND;
    = nlc$sl_clear_to_send_event =
      IF cl_connection^.message_sender.active THEN
        pmp$get_executing_task_gtid (processing_task);
        IF cl_connection^.message_sender.task = processing_task THEN
          continue_send_data (connection, cl_connection);
        ELSE
          activate_sender_task (cl_connection, cl_connection^.message_sender.task);
        IFEND;
      IFEND;
      inventory_report.changed := FALSE;
    = nlc$sl_interrupt_event =
      IF connection^.nominal_connection THEN
        se_event.kind := nac$se_interrupt;
        data_fragments [1].address := ^se_event.interrupt_data;
        data_fragments [1].length := #SIZE (se_event.interrupt_data);
        message_id := event.interrupt.message_id;
        nlp$bm_flush_message (data_fragments, message_id, data_length, ignore_status);
        se_event.interrupt_data_length := data_length;

{send_timesharing signal

        send_timesharing_signal (jmc$timesharing_interrupt, connection^.nominal_connection_task_id,
              ^se_event);
      ELSE
        IF (connection^.wait_state <> nac$waiting_to_receive_data) AND (connection^.data_queue.count = 0) AND
              (connection^.supervisory_event_queue.beginning = NIL) THEN
          nlp$select_timer (nac$inactive_receiver_timeout, 0, connection^.event_timer);
        IFEND;
        REPEAT
          ALLOCATE event_element IN nav$network_paged_heap^;
          IF event_element = NIL THEN
            syp$cycle;
          IFEND;
        UNTIL event_element <> NIL;
        event_element^.next_element := NIL;
        IF connection^.supervisory_event_queue.beginning = NIL THEN
          connection^.supervisory_event_queue.beginning := event_element;
        ELSE
          connection^.supervisory_event_queue.ending^.next_element := event_element;
        IFEND;
        connection^.supervisory_event_queue.ending := event_element;
        event_element^.event.kind := nac$se_interrupt;
        data_fragments [1].address := ^event_element^.event.interrupt_data;
        data_fragments [1].length := #SIZE (event_element^.event.interrupt_data);
        message_id := event.interrupt.message_id;
        nlp$bm_flush_message (data_fragments, message_id, data_length, ignore_status);
        event_element^.event.interrupt_data_length := data_length;
        IF connection^.wait_state = nac$waiting_for_data_available THEN
          pmp$ready_task (cl_connection^.message_receiver.task, ignore_status);
          nlp$cl_deactivate_receiver (cl_connection);
          connection^.wait_state := nac$inactive_wait;
        ELSEIF connection^.wait_state = nac$waiting_to_receive_data THEN
          activate_receiver_task (cl_connection, cl_connection^.message_receiver.task);
        IFEND;
      IFEND;
      inventory_report.changed := FALSE;

{! statistics begin

      IF nav$statistics_enabled THEN
        osp$increment_locked_variable (nav$global_statistics.session.interrupt_requests_received, 0, ignore);
      IFEND;

{! statistics end

    = nlc$sl_synch_event =
      IF (connection^.nominal_connection) AND (NOT connection^.break_condition_active) AND
            (event.synch.discard_option = nlc$sl_discard_send_receive) THEN
        ; {setup event
        connection^.break_condition_active := TRUE;
        connection^.event.kind := nac$se_synchronize;
        connection^.event.direction := nac$se_synchronize_all_data;
        data_fragments [1].address := ^connection^.event.synchronize_data;
        data_fragments [1].length := #SIZE (connection^.event.synchronize_data);
        message_id := event.synch.message_id;
        nlp$bm_flush_message (data_fragments, message_id, data_length, ignore_status);
        connection^.event.synchronize_data_length := data_length;

{send_timesharing signal

        IF (connection^.wait_state <> nac$waiting_to_receive_data) AND
              (NOT cl_connection^.message_sender.active) THEN
          send_timesharing_signal (jmc$timesharing_synchronize, connection^.nominal_connection_task_id,
                ^connection^.event);
        IFEND;
      ELSE
        IF (connection^.wait_state <> nac$waiting_to_receive_data) AND (connection^.data_queue.count = 0) AND
              (connection^.supervisory_event_queue.beginning = NIL) THEN
          nlp$select_timer (nac$inactive_receiver_timeout, 0, connection^.event_timer);
        IFEND;

{queue_event

        REPEAT
          ALLOCATE event_element IN nav$network_paged_heap^;
          IF event_element = NIL THEN
            syp$cycle;
          IFEND;
        UNTIL event_element <> NIL;
        event_element^.next_element := NIL;
        IF connection^.supervisory_event_queue.beginning = NIL THEN
          connection^.supervisory_event_queue.beginning := event_element;
        ELSE
          connection^.supervisory_event_queue.ending^.next_element := event_element;
        IFEND;
        connection^.supervisory_event_queue.ending := event_element;
        event_element^.event.kind := nac$se_synchronize;
        IF event.synch.discard_option = nlc$sl_discard_send_receive THEN
          event_element^.event.direction := nac$se_synchronize_all_data;
        ELSEIF event.synch.discard_option = nlc$sl_discard_send THEN
          event_element^.event.direction := nac$se_synchronize_receive_data;
        ELSEIF event.synch.discard_option = nlc$sl_discard_receive THEN
          event_element^.event.direction := nac$se_synchronize_send_data;
        IFEND;
        data_fragments [1].address := ^event_element^.event.synchronize_data;
        data_fragments [1].length := #SIZE (event_element^.event.synchronize_data);
        message_id := event.synch.message_id;
        nlp$bm_flush_message (data_fragments, message_id, data_length, ignore_status);
        event_element^.event.synchronize_data_length := data_length;
        IF connection^.wait_state = nac$waiting_for_data_available THEN
          pmp$ready_task (cl_connection^.message_receiver.task, ignore_status);
          nlp$cl_deactivate_receiver (cl_connection);
          connection^.wait_state := nac$inactive_wait;
        IFEND;
      IFEND;
      IF (event.synch.discard_option = nlc$sl_discard_send_receive) OR
            (event.synch.discard_option = nlc$sl_discard_receive) THEN
        inventory_report.changed := FALSE;
        {OK} connection^.send_synchronize_count := connection^.send_synchronize_count + 1;
        connection^.intermediate_put_partial := FALSE;
        connection^.send_put_partial_termination := FALSE;
        IF cl_connection^.message_sender.active THEN
          nlp$cancel_timer (connection^.send_timer);
          IF (connection^.nominal_connection) AND (NOT connection^.break_connection_send) THEN
            connection^.break_connection_send := TRUE;
          ELSEIF (NOT connection^.nominal_connection) AND (NOT connection^.synchronize_send) THEN
            connection^.synchronize_send := TRUE;
          IFEND;
          activate_sender_task (cl_connection, cl_connection^.message_sender.task);
        IFEND;
      IFEND;
      IF (event.synch.discard_option = nlc$sl_discard_send_receive) OR
            (event.synch.discard_option = nlc$sl_discard_send) THEN
        release_data_queue (connection^);
        inventory_report.changed := TRUE;
        inventory_report.accumulated_message_buffers := connection^.total_message_buffers_queued;
        IF connection^.wait_state = nac$waiting_to_receive_data THEN
          IF (connection^.nominal_connection) AND (NOT connection^.break_connection_receive) THEN
            connection^.break_connection_receive := TRUE;
          ELSEIF (NOT connection^.nominal_connection) AND (NOT connection^.synchronize_receive) THEN
            connection^.synchronize_receive := TRUE;
          IFEND;
          activate_receiver_task (cl_connection, cl_connection^.message_receiver.task);
        IFEND;
      IFEND;
      ; {
      ; {Possibly update or terminate timers
      ; {

{! statistics begin

      IF nav$statistics_enabled THEN
        osp$increment_locked_variable (nav$global_statistics.session.synchronize_requests_received, 0,ignore);
      IFEND;

{! statistics end

    = nlc$sl_synch_confirm_event =
      IF connection^.receive_synchronize_count > 0 THEN
        IF (connection^.wait_state <> nac$waiting_to_receive_data) AND (connection^.data_queue.count = 0) AND
              (connection^.supervisory_event_queue.beginning = NIL) THEN
          nlp$select_timer (nac$inactive_receiver_timeout, 0, connection^.event_timer);
        IFEND;
        REPEAT
          ALLOCATE event_element IN nav$network_paged_heap^;
          IF event_element = NIL THEN
            syp$cycle;
          IFEND;
        UNTIL event_element <> NIL;
        event_element^.next_element := NIL;
        IF connection^.supervisory_event_queue.beginning = NIL THEN
          connection^.supervisory_event_queue.beginning := event_element;
        ELSE
          connection^.supervisory_event_queue.ending^.next_element := event_element;
        IFEND;
        connection^.supervisory_event_queue.ending := event_element;
        event_element^.event.kind := nac$se_synchronize_confirm;
        {OK} connection^.receive_synchronize_count := connection^.receive_synchronize_count - 1;

        IF connection^.wait_state = nac$waiting_to_receive_data THEN
          activate_receiver_task (cl_connection, cl_connection^.message_receiver.task);
        IFEND;
      ELSE { IF connection^.receive_synchronize_count = 0 THEN
        nap$namve_system_error (TRUE, 'Receive synchronize count = 0.', NIL);
      IFEND;
      IF connection^.wait_state = nac$waiting_for_data_available THEN
        pmp$ready_task (cl_connection^.message_receiver.task, ignore_status);
        nlp$cl_deactivate_receiver (cl_connection);
        connection^.wait_state := nac$inactive_wait;
      IFEND;
      inventory_report.changed := FALSE;
    = nlc$sl_clear_event =
      connection^.connection_state := nac$terminated;
      IF event.clear.reason = nlc$sl_user_clear THEN
        connection^.termination_reason := nac$peer_request;
        inventory_report.changed := FALSE;
      ELSE
        connection^.termination_reason := nac$connection_failed;
        release_data_queue (connection^);
        inventory_report.changed := TRUE;
        inventory_report.accumulated_message_buffers := 0;
        WHILE connection^.supervisory_event_queue.beginning <> NIL DO
          event_element := connection^.supervisory_event_queue.beginning;
          connection^.supervisory_event_queue.beginning := event_element^.next_element;
          FREE event_element IN nav$network_paged_heap^;
        WHILEND;
      IFEND;
      nlp$bm_get_message_length (event.clear.message_id, data_length);
      IF data_length > 0 THEN
        message_id := event.clear.message_id;
        REPEAT
          ALLOCATE connection^.peer_termination_data: [[REP data_length OF cell]] IN nav$network_paged_heap^;
          IF connection^.peer_termination_data = NIL THEN
            syp$cycle;
          IFEND;
        UNTIL connection^.peer_termination_data <> NIL;
        data_fragments [1].address := connection^.peer_termination_data;
        data_fragments [1].length := data_length;
        nlp$bm_flush_message (data_fragments, message_id, data_length, ignore_status);
      IFEND;
      IF connection^.await_server_response THEN
        pmp$ready_task (connection^.await_server_response_task_id, ignore_status);
        connection^.await_server_response := FALSE;
      IFEND;
      IF connection^.wait_state = nac$waiting_for_data_available THEN
        pmp$ready_task (cl_connection^.message_receiver.task, ignore_status);
        nlp$cl_deactivate_receiver (cl_connection);
        connection^.wait_state := nac$inactive_wait;
      IFEND;
      IF (connection^.nominal_connection) AND (NOT connection^.timesharing_disconnect_sent) AND
            (connection^.wait_state <> nac$waiting_to_receive_data) AND
            (NOT cl_connection^.message_sender.active) AND (connection^.send_synchronize_count = 0) THEN
        ; {send time_sharing_signal
        connection^.timesharing_disconnect_sent := TRUE;
        send_timesharing_signal (jmc$timesharing_disconnect, connection^.nominal_connection_task_id, NIL);
      ELSE
        IF connection^.wait_state = nac$waiting_to_receive_data THEN
          activate_receiver_task (cl_connection, cl_connection^.message_receiver.task);
        IFEND;
        IF cl_connection^.message_sender.active THEN
          activate_sender_task (cl_connection, cl_connection^.message_sender.task);
        IFEND;
      IFEND;
      send_disconnect_signal (cl_connection, connection^.job_monitor_task_id);
    = nlc$sl_confirm_event =
      IF connection^.connection_state = nac$connection_request_sent THEN
        connection^.connection_state := nac$established;
        nlp$bm_get_message_length (event.confirm.message_id, data_length);
        IF data_length > 0 THEN
          message_id := event.confirm.message_id;
          REPEAT
            ALLOCATE connection^.peer_connect_data: [[REP data_length OF cell]] IN nav$network_paged_heap^;

            IF connection^.peer_connect_data = NIL THEN
              syp$cycle;
            IFEND;
          UNTIL connection^.peer_connect_data <> NIL;
          data_fragments [1].address := connection^.peer_connect_data;
          data_fragments [1].length := data_length;
          nlp$bm_flush_message (data_fragments, message_id, data_length, ignore_status);
        IFEND;
        IF event.confirm.accounting_length > 0 THEN
          REPEAT
            ALLOCATE connection^.peer_accounting_information:
                  [[REP event.confirm.accounting_length OF cell]] IN nav$network_paged_heap^;
            IF connection^.peer_accounting_information = NIL THEN
              syp$cycle;
            IFEND;
          UNTIL connection^.peer_accounting_information <> NIL;
          RESET connection^.peer_accounting_information;
          NEXT accounting_info: [1 .. event.confirm.accounting_length] IN
                connection^.peer_accounting_information;
          accounting_info^ := event.confirm.accounting_info^;
        IFEND;
        IF connection^.await_server_response THEN
          pmp$ready_task (connection^.await_server_response_task_id, ignore_status);
          connection^.await_server_response := FALSE;
        IFEND;
      IFEND;
      inventory_report.changed := FALSE;
    ELSE
      nap$namve_system_error (TRUE, 'Invalid internal session event received.', NIL);
    CASEND;
  PROCEND nap$se_process_connection_event;
?? OLDTITLE ??
?? TITLE := '  PROCESS_SAP_EVENT', EJECT ??

  PROCEDURE [XDCL] nap$se_process_sap_event
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$sl_event;
     VAR inventory_report: nlt$sl_inventory_report);

    CONST
      us# = $CHAR (1f(16)); { unit separator character }

    VAR
      accounting_info: ^array [1 .. * ] of cell,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      data_length: integer,
      layer_active: boolean,
      connection: ^nat$connection_descriptor,
      data: array [1 .. 2] of nat$data_fragment,
      i: ost$status_message_line_count,
      in_message: ^ost$status_message,
      line: ^ost$status_message_line,
      line_count: ^ost$status_message_line_count,
      line_length: ^ost$status_message_line_size,
      message: ^ost$status_message,
      message_id: nlt$bm_message_id,
      message_size: integer,
      out_line: ^ost$status_message_line,
      out_message: ^ost$status_message,
      sap_identifier: nat$sap_identifier,
      status_message: ^ost$status_message,
      status: ost$status,
      vtp_output_data: nat$vtp_output_data;

    nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
    connection^ := nav$se_initialized_connection;
    nlp$cancel_timer (connection^.send_timer);
    connection^.receive_timer := connection^.send_timer;
    connection^.event_timer := connection^.send_timer;
    connection^.connection_state := nac$connection_request_received;
    ; {Setup local_address
    connection^.peer_address := event.call.source;
    connection^.local_address := event.call.sap;
    connection^.client := FALSE;
    REPEAT
      ALLOCATE connection^.data_queue.beginning IN nav$network_paged_heap^;
      IF connection^.data_queue.beginning = NIL THEN
        syp$cycle;
      IFEND;
    UNTIL connection^.data_queue.beginning <> NIL;
    connection^.data_queue.ending := connection^.data_queue.beginning;
    connection^.data_queue.beginning^.next_element := NIL;
    ; { Setup connection_attributes from event
    nlp$bm_get_message_length (event.call.message_id, data_length);
    IF data_length > 0 THEN
      message_id := event.call.message_id;
      REPEAT
        ALLOCATE connection^.peer_connect_data: [[REP data_length OF cell]] IN nav$network_paged_heap^;

        IF connection^.peer_connect_data = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL connection^.peer_connect_data <> NIL;
      data_fragments [1].address := connection^.peer_connect_data;
      data_fragments [1].length := data_length;
      nlp$bm_flush_message (data_fragments, message_id, data_length, {ignore} status);
    IFEND;
    IF event.call.accounting_length > 0 THEN
      REPEAT
        ALLOCATE connection^.peer_accounting_information: [[REP event.call.accounting_length OF cell]] IN
              nav$network_paged_heap^;
        IF connection^.peer_accounting_information = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL connection^.peer_accounting_information <> NIL;
      RESET connection^.peer_accounting_information;
      NEXT accounting_info: [1 .. event.call.accounting_length] IN connection^.peer_accounting_information;
      accounting_info^ := event.call.accounting_info^;
    IFEND;
    nlp$cl_activate_layer (cl_connection^.application_layer, cl_connection);
    sap_identifier := event.call.sap;
    nap$process_connect_indication (sap_identifier, cl_connection^.identifier, cl_connection,
          event.call.source, connection^.application_name, connection^.protocol, status);
    IF status.normal THEN
      connection^.client := FALSE;
    ELSE
      PUSH status_message;
      osp$format_message (status, osc$brief_message_level, osc$max_status_message_line, status_message^,
            {ignore} status);
      PUSH message;
      in_message := status_message;
      out_message := message;
      RESET in_message;
      RESET out_message;
      NEXT line_count IN in_message;
      message_size := 0;
      FOR i := 1 TO line_count^ DO
        NEXT line_length IN in_message;
        NEXT line: [line_length^] IN in_message;
        NEXT out_line: [line_length^] IN out_message;
        out_line^ := line^;
        message_size := message_size + line_length^;
        NEXT out_line: [1] IN out_message;
        out_line^ (1) := us#; { Lines must be separated with unit separator characters }
        message_size := message_size + 1;
      FOREND;

{ The Tip needs the vtp_output_data at the beginning of the message.  Without the
{ vtp_output_data the first three characters would be truncated.

      IF connection^.protocol = nac$cdna_virtual_terminal THEN
        data [1].length := #SIZE (vtp_output_data);
        data [1].address := ^vtp_output_data;
        vtp_output_data.message_type := 0;
        vtp_output_data.formatting_mode := 1; { virtual line mode encoding
        vtp_output_data.suppress_echoplex := FALSE; { secured input suppressed echoplex bit
        vtp_output_data.suppress_end_of_line_partition := FALSE; {secured input suppressed end of line
        vtp_output_data.partial_output := FALSE;
        NEXT out_line: [1] IN out_message;
        out_line^ (1) := ' '; { Terminate with blank line for carriage control}
        message_size := message_size + 1;
      ELSE
        data [1].length := 0;
        data [1].address := NIL;
      IFEND;
      IF message_size <= nlc$sl_max_clear_message - data [1].length THEN
        data [2].length := message_size;
      ELSE
        data [2].length := nlc$sl_max_clear_message - data [1].length;
      IFEND;
      data [2].address := out_message;
      nlp$sl_clear_request (cl_connection, data, status);
      IF NOT status.normal THEN
        nap$namve_system_error (TRUE, 'NLP$SL_CLEAR_REQUEST failed.', ^status);
      IFEND;
      connection^.connection_state := nac$terminated;
      connection^.termination_reason := nac$local_clear;
      terminate_connection (connection, cl_connection);
      nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
    IFEND;
  PROCEND nap$se_process_sap_event;
?? TITLE := '  DEQUEUE_DATA_EVENT', EJECT ??

  PROCEDURE dequeue_data_event
    (VAR connection: nat$connection_descriptor);

    VAR
      event_element: ^nat$se_event_element_queue;

    IF (connection.data_queue.count > 0) THEN
      IF (connection.data_queue.beginning^.first = connection.data_queue.beginning^.last) THEN
        IF connection.data_queue.beginning^.event_element [connection.data_queue.beginning^.first].
              queued_data_length > 0 THEN
          nlp$bm_release_message (connection.data_queue.beginning^.
                event_element [connection.data_queue.beginning^.first].message_id);
          connection.total_data_queued := connection.total_data_queued -
                connection.data_queue.beginning^.event_element [connection.data_queue.beginning^.first].
                queued_data_length;
          connection.total_message_buffers_queued := connection.total_message_buffers_queued -
                connection.data_queue.beginning^.event_element [connection.data_queue.beginning^.first].
                queued_message_buffers;
        IFEND;
        IF connection.data_queue.beginning^.next_element <> NIL THEN
          event_element := connection.data_queue.beginning;
          connection.data_queue.beginning := event_element^.next_element;
          FREE event_element IN nav$network_paged_heap^;
          connection.data_queue.count := connection.data_queue.count - nac$se_max_element_count;
        ELSE
          connection.data_queue.count := connection.data_queue.count - 1;
        IFEND;
      ELSE
        IF connection.data_queue.beginning^.event_element [connection.data_queue.beginning^.first].
              queued_data_length > 0 THEN
          nlp$bm_release_message (connection.data_queue.beginning^.
                event_element [connection.data_queue.beginning^.first].message_id);
          connection.total_data_queued := connection.total_data_queued -
                connection.data_queue.beginning^.event_element [connection.data_queue.beginning^.first].
                queued_data_length;
          connection.total_message_buffers_queued := connection.total_message_buffers_queued -
                connection.data_queue.beginning^.event_element [connection.data_queue.beginning^.first].
                queued_message_buffers;
        IFEND;
        connection.data_queue.beginning^.first := (connection.data_queue.beginning^.first + 1) MOD
              nac$se_max_element_count;
        IF connection.data_queue.beginning^.next_element = NIL THEN
          connection.data_queue.count := connection.data_queue.count - 1;
        IFEND;
      IFEND;
    ELSE
    IFEND;
  PROCEND dequeue_data_event;

?? TITLE := '  [INLINE] QUEUE_DATA_EVENT', EJECT ??

  PROCEDURE [INLINE] queue_data_event
    (    event: nlt$sl_event;
     VAR connection: nat$connection_descriptor);

    VAR
      data_length: integer,
      number_of_buffers: integer,
      event_element: ^nat$se_event_element_queue,
      index: integer,
      message_array: array [1 .. 2] of nlt$bm_message_id;

    nlp$bm_get_message_resources (event.data.message_id, data_length, number_of_buffers);
    IF (connection.data_queue.count > 0) AND (NOT connection.data_queue.ending^.
          event_element [connection.data_queue.ending^.last].event.end_of_message) THEN
      ; {concatenate_message
      IF data_length > 0 THEN
        IF connection.data_queue.ending^.event_element [connection.data_queue.ending^.last].
              queued_data_length > 0 THEN
          connection.data_queue.ending^.event_element [connection.data_queue.ending^.last].
                queued_data_length := connection.data_queue.ending^.
                event_element [connection.data_queue.ending^.last].queued_data_length + data_length;
          connection.data_queue.ending^.event_element [connection.data_queue.ending^.last].
                queued_message_buffers := connection.data_queue.ending^.
                event_element [connection.data_queue.ending^.last].queued_message_buffers + number_of_buffers;
          connection.total_data_queued := connection.total_data_queued + data_length;
          connection.total_message_buffers_queued := connection.total_message_buffers_queued +
                number_of_buffers;
          message_array [1] := connection.data_queue.ending^.
                event_element [connection.data_queue.ending^.last].message_id;
          message_array [2] := event.data.message_id;
          nlp$bm_concatenate_messages (message_array, connection.data_queue.ending^.
                event_element [connection.data_queue.ending^.last].message_id);
        ELSE
          connection.data_queue.ending^.event_element [connection.data_queue.ending^.last].
                queued_data_length := data_length;
          connection.data_queue.ending^.event_element [connection.data_queue.ending^.last].
                queued_message_buffers := number_of_buffers;
          connection.total_data_queued := connection.total_data_queued + data_length;
          connection.total_message_buffers_queued := connection.total_message_buffers_queued +
                number_of_buffers;
          connection.data_queue.ending^.event_element [connection.data_queue.ending^.last].message_id :=
                event.data.message_id;
        IFEND;
      IFEND;

      connection.data_queue.ending^.event_element [connection.data_queue.ending^.last].event.end_of_message :=
            event.data.end_of_message;
    ELSE
      IF connection.data_queue.count = 0 THEN
        connection.data_queue.beginning^.first := 0;
        connection.data_queue.beginning^.last := 0;
        index := 0;
      ELSEIF connection.data_queue.count < nac$se_max_element_count THEN
        connection.data_queue.beginning^.last := (connection.data_queue.beginning^.last + 1) MOD
              nac$se_max_element_count;
        index := connection.data_queue.beginning^.last;
      ELSEIF (connection.data_queue.count MOD nac$se_max_element_count = 0) AND
            (connection.data_queue.count > 0) THEN
        REPEAT
          ALLOCATE event_element IN nav$network_paged_heap^;
          IF event_element = NIL THEN
            syp$cycle;
          IFEND;
        UNTIL event_element <> NIL;
        event_element^.next_element := NIL;
        connection.data_queue.ending^.next_element := event_element;
        connection.data_queue.ending := event_element;
        event_element^.first := 0;
        event_element^.last := 0;
        index := 0;
      ELSE
        connection.data_queue.ending^.last := connection.data_queue.ending^.last + 1;
        index := connection.data_queue.ending^.last;
      IFEND;
      ; {setup event
      connection.data_queue.ending^.event_element [index].event.kind := nac$se_send_data;
      connection.data_queue.ending^.event_element [index].event.end_of_message := event.data.end_of_message;
      connection.data_queue.ending^.event_element [index].event.qualified_data := event.data.qualified_data;
      connection.data_queue.ending^.event_element [index].message_id := event.data.message_id;
      connection.data_queue.ending^.event_element [index].start_of_data_sequence := TRUE;
      connection.discard_to_end_of_message := FALSE;
      connection.data_queue.ending^.event_element [index].queued_data_length := data_length;
      connection.data_queue.ending^.event_element [connection.data_queue.ending^.last].
            queued_message_buffers := number_of_buffers;
      connection.total_data_queued := connection.total_data_queued + data_length;
      connection.total_message_buffers_queued := connection.total_message_buffers_queued + number_of_buffers;
      connection.data_queue.ending^.event_element [index].total_bytes_moved := 0;
      connection.data_queue.count := connection.data_queue.count + 1;
    IFEND;
  PROCEND queue_data_event;
?? TITLE := '  RELEASE_DATA_QUEUE', EJECT ??

  PROCEDURE release_data_queue
    (VAR connection: nat$connection_descriptor);

    VAR
      event_element: ^nat$se_event_element_queue,
      i: integer;

    WHILE connection.data_queue.count > 0 DO
      IF connection.data_queue.beginning^.first <= connection.data_queue.beginning^.last THEN
        FOR i := connection.data_queue.beginning^.first TO connection.data_queue.beginning^.last DO
          IF connection.data_queue.beginning^.event_element [i].queued_data_length > 0 THEN
            nlp$bm_release_message (connection.data_queue.beginning^.event_element [i].message_id);
          IFEND;
        FOREND;
      ELSE
        FOR i := connection.data_queue.beginning^.first TO (nac$se_max_element_count - 1) DO
          IF connection.data_queue.beginning^.event_element [i].queued_data_length > 0 THEN
            nlp$bm_release_message (connection.data_queue.beginning^.event_element [i].message_id);
          IFEND;
        FOREND;
        FOR i := 0 TO connection.data_queue.beginning^.last DO
          IF connection.data_queue.beginning^.event_element [i].queued_data_length > 0 THEN
            nlp$bm_release_message (connection.data_queue.beginning^.event_element [i].message_id);
          IFEND;
        FOREND;
      IFEND;
      IF connection.data_queue.beginning <> connection.data_queue.ending THEN
        event_element := connection.data_queue.beginning;
        connection.data_queue.beginning := event_element^.next_element;
        FREE event_element IN nav$network_paged_heap^;
      ELSE
        connection.data_queue.count := 0;
      IFEND;
    WHILEND;
    connection.total_data_queued := 0;
    connection.total_message_buffers_queued := 0;
  PROCEND release_data_queue;
?? TITLE := '   eoi_message', EJECT ??

  FUNCTION eoi_message
    (    eoi: ^nat$eoi_message;
         message_id: nlt$bm_message_id): boolean;

    VAR
      data_length: integer,
      ignore_status: ost$status,
      scratch_eoi_message: nat$eoi_message;

    nlp$bm_get_message_length (message_id, data_length);
    IF eoi <> NIL THEN
      IF data_length = eoi^.size THEN
        nlp$bm_get_message_prefix (^scratch_eoi_message.value, data_length, message_id, ignore_status);
        eoi_message := eoi^.value (1, data_length) = scratch_eoi_message.value (1, data_length);
      ELSE
        eoi_message := FALSE;
      IFEND;
    ELSE
      IF data_length = nav$eoi_message.size THEN
        nlp$bm_get_message_prefix (^scratch_eoi_message.value, data_length, message_id, ignore_status);
        eoi_message := nav$eoi_message.value (1, data_length) = scratch_eoi_message.value (1, data_length);
      ELSE
        eoi_message := FALSE;
      IFEND;
    IFEND;
  FUNCEND eoi_message;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$se_clear_request' ??
?? NEWTITLE := '  terminate_clear', EJECT ??

  PROCEDURE [XDCL] nap$se_clear_request
    (    file: fst$file_reference;
     VAR status: ost$status);


    PROCEDURE terminate_clear
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF cl_connection <> NIL THEN
          nlp$cl_clear_exclusive_access (cl_connection);
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
          EXIT nap$se_clear_request;
        ELSE
          osp$pop_inhibit_job_recovery;
          osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
          EXIT nap$se_clear_request;
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_clear;
?? OLDTITLE, EJECT ??

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      connection_id: nlt$cl_connection_id,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      event_element: ^nat$se_supervisory_element,
      layer_active: boolean,
      processing_task: ost$global_task_id,
      switch_offer_pending: boolean;

    status.normal := TRUE;
    fmp$get_connection_identifier (file, connection_id, switch_offer_pending, status);
    IF NOT status.normal THEN
      IF status.condition = fme$no_cycle_description THEN
        osp$set_status_abnormal ('AM', ame$file_not_known, file, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'A GET ATTRIBUTES ', status);
      IFEND;
      RETURN;
    IFEND;

    IF switch_offer_pending THEN
      osp$set_status_condition (nae$switch_offer_pending, status);
      RETURN;
    IFEND;

    cl_connection := NIL;
    #SPOIL (cl_connection);
    osp$push_inhibit_job_recovery;
    osp$establish_condition_handler (^terminate_clear, FALSE);
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        IF connection^.connection_state <> nac$terminated THEN
          IF connection^.termination_data <> NIL THEN
            data_fragments [1].address := connection^.termination_data;
            data_fragments [1].length := #SIZE (connection^.termination_data^);
          ELSE
            data_fragments [1] := nav$null_data [1];
          IFEND;
          nlp$sl_clear_request (cl_connection, data_fragments, {ignore} status);
          connection^.connection_state := nac$terminated;
          connection^.termination_reason := nac$local_clear;
          IF connection^.await_server_response THEN
            pmp$ready_task (connection^.await_server_response_task_id, {ignore} status);
            connection^.await_server_response := FALSE;
          IFEND;
          IF connection^.wait_state = nac$waiting_for_data_available THEN
            pmp$ready_task (cl_connection^.message_receiver.task, {ignore} status);
            nlp$cl_deactivate_receiver (cl_connection);
            connection^.wait_state := nac$inactive_wait;
          IFEND;
          IF connection^.data_queue.count > 0 THEN
            nlp$ta_report_undelivered_data (cl_connection, 0);
            release_data_queue (connection^);
          IFEND;
          WHILE connection^.supervisory_event_queue.beginning <> NIL DO
            event_element := connection^.supervisory_event_queue.beginning;
            connection^.supervisory_event_queue.beginning := event_element^.next_element;
            FREE event_element IN nav$network_paged_heap^;
          WHILEND;
          pmp$get_executing_task_gtid (processing_task);
          IF connection^.wait_state = nac$waiting_to_receive_data THEN
            IF cl_connection^.message_receiver.task = processing_task THEN
              IF NOT connection^.nominal_connection THEN
                osp$set_status_condition (nae$connection_terminated, status);
              ELSE
                osp$set_status_condition (nae$interactive_cond_interrupt, status);
              IFEND;
              terminate_receive_data (connection, cl_connection, ^status);
              status.normal := TRUE;
            ELSE
              activate_receiver_task (cl_connection, cl_connection^.message_receiver.task);
            IFEND;
          IFEND;
          IF cl_connection^.message_sender.active THEN
            IF cl_connection^.message_sender.task = processing_task THEN
              IF NOT connection^.nominal_connection THEN
                osp$set_status_condition (nae$connection_terminated, status);
              ELSE
                osp$set_status_condition (nae$interactive_cond_interrupt, status);
              IFEND;
              terminate_send_data (connection, cl_connection, ^status);
              status.normal := TRUE;
            ELSE
              activate_sender_task (cl_connection, cl_connection^.message_sender.task);
            IFEND;
          IFEND;
          IF (connection^.nominal_connection) AND (NOT connection^.timesharing_disconnect_sent) AND
                (connection^.wait_state <> nac$waiting_to_receive_data) AND
                (NOT cl_connection^.message_sender.active) AND (connection^.send_synchronize_count = 0) THEN
            connection^.timesharing_disconnect_sent := TRUE;
            send_timesharing_signal (jmc$timesharing_disconnect, connection^.nominal_connection_task_id, NIL);
          IFEND;
        ELSE
          osp$set_status_condition (nae$connection_terminated, status);
        IFEND;
        nlp$cl_release_exclusive_access (cl_connection);
        IF status.normal THEN
          fmp$process_disconnect (file, connection_id);
        IFEND;
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
        nlp$cl_release_exclusive_access (cl_connection);
      IFEND;
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$se_clear_request;
?? OLDTITLE ??
?? NEWTITLE := 'NAP$SE_TERMINATE_CONNECTION', EJECT ??

  PROCEDURE [XDCL] nap$se_terminate_connection
    (    connection_id: nat$connection_id;
         reason: nat$termination_reason;
         active_file: boolean;
     VAR connection_released: boolean;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      event_element: ^nat$se_supervisory_element,
      layer_active: boolean,
      message_id: nlt$bm_message_id;

    status.normal := TRUE;
    connection_released := FALSE;

    osp$push_inhibit_job_recovery;
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        IF connection^.connection_state <> nac$terminated THEN
          IF active_file THEN
            IF connection^.await_server_response THEN
              pmp$ready_task (connection^.await_server_response_task_id, {ignore} status);
              connection^.await_server_response := FALSE;
            IFEND;
            IF connection^.wait_state = nac$waiting_for_data_available THEN
              pmp$ready_task (cl_connection^.message_receiver.task, {ignore} status);
              nlp$cl_deactivate_receiver (cl_connection);
              connection^.wait_state := nac$inactive_wait;
            IFEND;
            IF (connection^.nominal_connection) AND (NOT connection^.timesharing_disconnect_sent) AND
                  (connection^.wait_state <> nac$waiting_to_receive_data) AND
                  (NOT cl_connection^.message_sender.active) AND (connection^.send_synchronize_count = 0) THEN
              connection^.timesharing_disconnect_sent := TRUE;
              send_timesharing_signal (jmc$timesharing_disconnect, connection^.nominal_connection_task_id,
                    NIL);
            ELSE
              IF connection^.data_queue.count > 0 THEN
                nlp$ta_report_undelivered_data (cl_connection, 0);
                release_data_queue (connection^);
              IFEND;
              WHILE connection^.supervisory_event_queue.beginning <> NIL DO
                event_element := connection^.supervisory_event_queue.beginning;
                connection^.supervisory_event_queue.beginning := event_element^.next_element;
                FREE event_element IN nav$network_paged_heap^;
              WHILEND;
              IF connection^.wait_state = nac$waiting_to_receive_data THEN
                activate_receiver_task (cl_connection, cl_connection^.message_receiver.task);
              IFEND;
              IF cl_connection^.message_sender.active THEN
                activate_sender_task (cl_connection, cl_connection^.message_sender.task);
              IFEND;
            IFEND;
            IF connection^.termination_data <> NIL THEN
              data_fragments [1].address := connection^.termination_data;
              data_fragments [1].length := #SIZE (connection^.termination_data^);
            ELSE
              data_fragments [1] := nav$null_data [1];
            IFEND;
            nlp$sl_clear_request (cl_connection, data_fragments, {ignore} status);
            connection^.connection_state := nac$terminated;
            connection^.termination_reason := reason;
          ELSE
            terminate_connection (connection, cl_connection);
            nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
            connection_released := TRUE;
          IFEND;
        ELSE
          nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
          connection_released := TRUE;
        IFEND;
        status.normal := TRUE;
      ELSE
        connection_released := TRUE;
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      connection_released := TRUE;
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$se_terminate_connection;

?? OLDTITLE ??
?? NEWTITLE := 'NAP$SE_RETURN_FILE', EJECT ??

  PROCEDURE [XDCL] nap$se_return_file
    (    connection_id: nat$connection_id;
     VAR status: ost$status);

    VAR
      active_file: boolean,
      application_name: nat$application_name,
      cl_connection: ^nlt$cl_connection,
      client: boolean,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      ignore_status: ost$status,
      layer_active: boolean;

    status.normal := TRUE;

    osp$push_inhibit_job_recovery;
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      client := (connection^.client = TRUE);
      application_name := connection^.application_name;
      IF layer_active THEN
        terminate_connection (connection, cl_connection);
        nlp$cl_deactivate_layer (cl_connection^.application_layer, cl_connection);
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
      nap$delete_connection (application_name, application_kind [client], connection_id, active_file,
              ignore_status);
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$se_return_file;

?? OLDTITLE ??
?? NEWTITLE := 'TERMINATE_CONNECTION', EJECT ??

  PROCEDURE terminate_connection
    (    connection: ^nat$connection_descriptor;
         cl_connection: ^nlt$cl_connection);

    VAR
      connection_element: ^nat$se_supervisory_element,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      ignore_status: ost$status,
      message_id: nlt$bm_message_id;

    IF connection^.data_queue.count > 0 THEN
      release_data_queue (connection^);
      nlp$ta_report_undelivered_data (cl_connection, 0);
    IFEND;
    IF connection^.connection_state <> nac$terminated THEN
      IF connection^.termination_data <> NIL THEN
        data_fragments [1].address := connection^.termination_data;
        data_fragments [1].length := #SIZE (connection^.termination_data^);
      ELSE
        data_fragments [1] := nav$null_data [1];
      IFEND;
      nlp$sl_clear_request (cl_connection, data_fragments, ignore_status);
    IFEND;
    IF connection^.data_queue.beginning <> NIL THEN
      FREE connection^.data_queue.beginning IN nav$network_paged_heap^;
    IFEND;
    WHILE connection^.supervisory_event_queue.beginning <> NIL DO
      connection_element := connection^.supervisory_event_queue.beginning;
      connection^.supervisory_event_queue.beginning := connection_element^.next_element;
      FREE connection_element IN nav$network_paged_heap^;
    WHILEND;
    IF connection^.connect_data <> NIL THEN
      FREE connection^.connect_data IN nav$network_paged_heap^;
    IFEND;

    IF connection^.termination_data <> NIL THEN
      FREE connection^.termination_data IN nav$network_paged_heap^;
    IFEND;

    IF connection^.peer_accounting_information <> NIL THEN
      FREE connection^.peer_accounting_information IN nav$network_paged_heap^;
    IFEND;

    IF connection^.peer_connect_data <> NIL THEN
      FREE connection^.peer_connect_data IN nav$network_paged_heap^;
    IFEND;

    IF connection^.peer_termination_data <> NIL THEN
      FREE connection^.peer_termination_data IN nav$network_paged_heap^;
    IFEND;
    IF connection^.eoi_message <> NIL THEN
      FREE connection^.eoi_message IN nav$network_paged_heap^;
    IFEND;
  PROCEND terminate_connection;
?? OLDTITLE ??
?? NEWTITLE := 'NAP$CLOSE_FILE', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$close_file
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      layer_active: boolean;

    #CALLER_ID (caller_id);
    status.normal := TRUE;

    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_condition (ame$improper_file_id, status);
      RETURN;
    IFEND;

    IF caller_id.ring > file_instance^.instance_attributes.static_label.ring_attributes.r2 THEN
      amp$set_file_instance_abnormal (file_identifier, ame$ring_validation_error, call_block.operation, '',
            status);
      RETURN;
    IFEND;

    osp$push_inhibit_job_recovery;
    nlp$cl_get_exclusive_via_cid (file_instance^.global_file_information^.device_dependent_info.
          network_connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        IF file_instance^.eoi_message <> NIL THEN
          FREE file_instance^.eoi_message IN osv$task_private_heap^;
        IFEND;
        IF file_instance^.receiver_active THEN
          ; {
          ; { Do not deactivate I/O.
          ; {
          IF ((connection^.receiver_request.application_buffer.description_kind = nac$allocated) AND
                (connection^.receiver_request.application_buffer.allocated_description <> NIL)) THEN
            FREE connection^.receiver_request.application_buffer.allocated_description IN
                  nav$network_paged_heap^;
          IFEND;
          nlp$cl_deactivate_receiver (cl_connection);
          connection^.wait_state := nac$inactive_wait;
        IFEND;
        IF file_instance^.sender_active THEN
          ; {
          ; { Do not deactivate I/O.
          ; {
          IF ((connection^.sender_request.application_buffer.description_kind = nac$allocated) AND
                (connection^.sender_request.application_buffer.allocated_description <> NIL)) THEN
            FREE connection^.sender_request.application_buffer.allocated_description IN
                  nav$network_paged_heap^;
          IFEND;
          nlp$cl_deactivate_sender (cl_connection);
        IFEND;
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      osp$set_status_condition (nae$connection_terminated, status);
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$close_file;
?? OLDTITLE ??
?? NEWTITLE := 'NAP$OPEN_FILE', EJECT ??

  PROCEDURE [XDCL, #GATE] nap$open_file
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

    status.normal := TRUE;

    IF (NOT osp$is_caller_system_privileged ()) AND (NOT jmv$executing_within_system_job) THEN
      osp$set_status_abnormal ('NA', nae$insufficient_privilege, 'nap$open_file', status);
      RETURN;
    IFEND;

    fmp$open_network_file (call_block.open.local_file_name, file_identifier, status);
    IF NOT status.normal THEN
      IF status.condition = fme$no_cycle_description THEN
        osp$set_status_abnormal ('AM', ame$file_not_known, call_block.open.local_file_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'A OPEN FILE ', status);
      IFEND;
    IFEND;
  PROCEND nap$open_file;
?? TITLE := 'NLP$OPEN_FILE', EJECT ??

  PROCEDURE [XDCL] nlp$open_file
    (    connection_id: nat$connection_id;
         file_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      cl_connection: ^nlt$cl_connection,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      layer_active: boolean;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF NOT file_is_valid THEN
      osp$set_status_condition (ame$improper_file_id, status);
      RETURN;
    IFEND;

    osp$push_inhibit_job_recovery;
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        file_instance^.sender_active := FALSE;
        file_instance^.receiver_active := FALSE;
        IF (connection^.data_queue.count > 0) OR (connection^.supervisory_event_queue.beginning <> NIL) OR
              (connection^.connection_state <> nac$terminated) OR
              ((connection^.nominal_connection) AND (connection^.connection_state = nac$terminated) AND
              (connection^.send_synchronize_count > 0)) THEN
          ; {
          ; {fillin attributes
          ; {
          file_instance^.data_transfer_timeout := connection^.data_transfer_timeout;
          file_instance^.eoi_message_enabled := connection^.eoi_message_enabled;
          IF connection^.eoi_message <> NIL THEN
            ALLOCATE file_instance^.eoi_message IN osv$task_private_heap^;
            file_instance^.eoi_message^ := connection^.eoi_message^;
          ELSE
            file_instance^.eoi_message := NIL;
          IFEND;
          file_instance^.eoi_peer_termination := connection^.eoi_peer_termination;
        ELSE
          file_instance^.eoi_message := NIL;
          osp$set_status_condition (nae$connection_terminated, status);
        IFEND;
      ELSE
        osp$set_status_condition (nae$connection_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE
      IF jmv$connection_acquired THEN
        osp$set_status_condition (nae$connection_terminated, status);
      ELSE
        file_instance^.sender_active := FALSE;
        file_instance^.receiver_active := FALSE;
        file_instance^.eoi_message := NIL;
        file_instance^.eoi_message_enabled := FALSE;
        file_instance^.data_transfer_timeout := 60000;
        file_instance^.eoi_peer_termination := FALSE;
      IFEND;
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nlp$open_file;
?? OLDTITLE ??
?? TITLE := '[XDCL] nap$se_disconnect_handler', EJECT ??

  PROCEDURE [XDCL] nap$se_disconnect_handler
    (    originator: ost$global_task_id;
         signal: pmt$signal);

    VAR
      cl_connection: ^nlt$cl_connection,
      cl_connection_id: ^nat$connection_id,
      connection: ^nat$connection_descriptor,
      connection_exists: boolean,
      layer_active: boolean,
      local_file_name: amt$local_file_name;

    cl_connection_id := #LOC (signal.contents);
    osp$push_inhibit_job_recovery;
    nlp$cl_get_exclusive_via_cid (cl_connection_id^, connection_exists, cl_connection);
    IF connection_exists THEN
      nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
        local_file_name := connection^.local_file_name;
        nlp$cl_release_exclusive_access (cl_connection);
        fmp$process_disconnect (local_file_name, cl_connection_id^);
      ELSE
        nlp$cl_release_exclusive_access (cl_connection);
      IFEND;
    IFEND;
    osp$pop_inhibit_job_recovery;
  PROCEND nap$se_disconnect_handler;
?? TITLE := '  EVALUATE_IO_TIMERS', EJECT ??

  PROCEDURE [XDCL] nap$se_evaluate_io_timers
    (    current_time: integer;
         cl_connection: ^nlt$cl_connection);

    VAR
      layer_active: boolean,
      connection: ^nat$connection_descriptor,
      ignore_status: ost$status;

    nlp$cl_get_layer_connection (cl_connection^.application_layer, cl_connection, layer_active, connection);
    IF layer_active THEN
      IF connection^.wait_state = nac$waiting_to_receive_data THEN
        IF nlp$timer_expired (current_time, connection^.receive_timer) THEN
          nlp$cancel_timer (connection^.receive_timer);
          connection^.receive_timeout := TRUE;
          activate_receiver_task (cl_connection, cl_connection^.message_receiver.task);
        IFEND;
      IFEND;
      IF cl_connection^.message_sender.active THEN
        IF nlp$timer_expired (current_time, connection^.send_timer) THEN
          nlp$cancel_timer (connection^.send_timer);
          connection^.send_timeout := TRUE;
          activate_sender_task (cl_connection, cl_connection^.message_sender.task);
        IFEND;
      IFEND;
      IF nlp$timer_expired (current_time, connection^.event_timer) THEN
        IF (connection^.data_queue.count > 0) OR (connection^.supervisory_event_queue.beginning <> NIL) THEN
          ; {
          ; { DELETE CONNECTION
          ; {
          nlp$cancel_timer (connection^.event_timer);
        IFEND;
      IFEND;
    IFEND;
  PROCEND nap$se_evaluate_io_timers;
?? TITLE := '  GET_OPTIMUM_TRANSFER_SIZE', EJECT ??

  PROCEDURE get_optimum_transfer_size
    (    cl_connection: ^nlt$cl_connection;
     VAR optimum_transfer_unit_size: nat$data_length);

    VAR
      cc_connection: ^nlt$cc_connection,
      layer_active: boolean;

    nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, layer_active, cc_connection);
    optimum_transfer_unit_size := cc_connection^.device_specific_attributes.maximum_data_length -
          nlc$lower_layer_overhead;

  PROCEND get_optimum_transfer_size;

?? TITLE := '  PROCESS_NOMINAL_CONNECT_EVENTS', EJECT ??

  PROCEDURE process_nominal_connect_events
    (    connection: ^nat$connection_descriptor;
         cl_connection: ^nlt$cl_connection);

    VAR
      dequeued_event_element: ^nat$se_supervisory_element,
      event_element: ^^nat$se_supervisory_element;

    IF (connection^.supervisory_event_queue.beginning <> NIL) AND (connection^.nominal_connection) THEN
      event_element := ^connection^.supervisory_event_queue.beginning;
      WHILE event_element^ <> NIL DO
        IF event_element^^.event.kind = nac$se_interrupt THEN
          send_timesharing_signal (jmc$timesharing_interrupt, connection^.nominal_connection_task_id,
                ^event_element^^.event);
          ; {dequeue_event
          dequeued_event_element := event_element^;
          event_element^ := event_element^^.next_element;
          FREE dequeued_event_element IN nav$network_paged_heap^;
        ELSEIF (event_element^^.event.kind = nac$se_synchronize) AND
              (event_element^^.event.direction = nac$se_synchronize_all_data) THEN
          IF connection^.break_condition_active THEN
            event_element^ := event_element^^.next_element;
          ELSE
            send_timesharing_signal (jmc$timesharing_synchronize, connection^.nominal_connection_task_id,
                  ^event_element^^.event);
            ; {dequeue_event
            dequeued_event_element := event_element^;
            event_element^ := event_element^^.next_element;
            FREE dequeued_event_element IN nav$network_paged_heap^;
            connection^.break_condition_active := TRUE;
          IFEND;
        ELSE
          event_element^ := event_element^^.next_element;
        IFEND;
      WHILEND;
    IFEND;
    IF (connection^.connection_state = nac$terminated) AND (NOT connection^.timesharing_disconnect_sent) AND
          (connection^.data_queue.count = 0) AND (connection^.supervisory_event_queue.beginning = NIL) AND
          (connection^.wait_state <> nac$waiting_to_receive_data) AND
          (NOT cl_connection^.message_sender.active) AND (connection^.send_synchronize_count = 0) THEN
      ; {send_signal (clear)
      connection^.timesharing_disconnect_sent := TRUE;
      send_timesharing_signal (jmc$timesharing_disconnect, connection^.nominal_connection_task_id, NIL);
    IFEND;

  PROCEND process_nominal_connect_events;

?? TITLE := '  SEND_TIMESHARING_SIGNAL', EJECT ??

  PROCEDURE send_timesharing_signal
    (    signal: jmt$timesharing_signal_kind;
         task_id: ost$global_task_id;
         event: ^nat$se_peer_operation);

    VAR
      data_string: ^string ( * ),
      local_status: ost$status,
      seq_ptr: ^SEQ ( * ),
      timesharing_signal: jmt$timesharing_signal;

    timesharing_signal.signal_id := jmc$timesharing_signal_id;
    timesharing_signal.signal_contents.signal_kind := signal;

    IF signal = jmc$timesharing_interrupt THEN
      seq_ptr := ^event^.interrupt_data;
      RESET seq_ptr;
      NEXT data_string: [event^.interrupt_data_length] IN seq_ptr;
      timesharing_signal.signal_contents.interrupt := data_string^;
    ELSEIF signal = jmc$timesharing_synchronize THEN
      seq_ptr := ^event^.synchronize_data;
      RESET seq_ptr;
      NEXT data_string: [event^.synchronize_data_length] IN seq_ptr;
      timesharing_signal.signal_contents.synchronize := data_string^;
    ELSEIF signal = jmc$timesharing_disconnect THEN
      timesharing_signal.signal_contents.disconnect.disconnect_reason := jmc$ts_line_disconnect;
    IFEND;

    pmp$send_signal (task_id, timesharing_signal.signal, local_status);

  PROCEND send_timesharing_signal;

?? TITLE := '  COMPLETE_ACTIVITY', EJECT ??

  PROCEDURE complete_activity
    (    operation: (send, receive);
         file_identifier: amt$file_identifier;
         status: ^ost$status;
     VAR valid_file_identifier: boolean);

    VAR
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean;

    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF file_is_valid THEN
      IF operation = send THEN
        file_instance^.sender_activity_status^.complete := TRUE;
        file_instance^.sender_active := FALSE;
        IF (status <> NIL) AND (NOT status^.normal) THEN
          file_instance^.sender_activity_status^.status := status^;
        IFEND;
      ELSE
        file_instance^.receiver_activity_status^.complete := TRUE;
        file_instance^.receiver_active := FALSE;
        IF (status <> NIL) AND (NOT status^.normal) THEN
          file_instance^.receiver_activity_status^.status := status^;
        IFEND;
      IFEND;
      valid_file_identifier := TRUE;
    ELSE
      valid_file_identifier := FALSE;
    IFEND;
  PROCEND complete_activity;

?? TITLE := '  TERMINATE_IO', EJECT ??

  PROCEDURE terminate_io
    (    operation: (sender, receiver);
         file_identifier: amt$file_identifier;
     VAR valid_file_identifier: boolean);

    VAR
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean;

    bap$validate_file_identifier (file_identifier, file_instance, file_is_valid);
    IF file_is_valid THEN
      IF operation = sender THEN
        file_instance^.sender_active := FALSE;
      ELSE
        file_instance^.receiver_active := FALSE;
      IFEND;
      valid_file_identifier := TRUE;
    ELSE
      valid_file_identifier := FALSE;
    IFEND;
  PROCEND terminate_io;

?? TITLE := '  NLP$RECOVER_TASK_ACTIVITY' ??
?? NEWTITLE := '    CONTINUE_RECOVERY -- CONDITION HANDLER', EJECT ??

  PROCEDURE [XDCL] nlp$recover_task_activity
    (VAR status: ost$status);

    PROCEDURE continue_recovery
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        nlp$recover_task_activity (condition_status);
        condition_status.normal := TRUE;
        EXIT nlp$recover_task_activity;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND continue_recovery;
?? OLDTITLE, EJECT ??

    VAR
      i: bat$tft_limit;

    status.normal := TRUE;
    nap$reset_received_message_list;
    nap$gt_close_job_connections(status);
    IF status.normal THEN
      nap$gt_delete_job_saps;
      nlp$sk_process_job_recovery;

      FOR i := 1 TO bav$last_tft_entry DO
        IF bav$tft_entry_assignment^ (i, 1) = fmc$entry_assigned THEN
          IF bav$task_file_table^ [i].device_class = rmc$network_device THEN
            osp$establish_condition_handler (^continue_recovery, FALSE);
            IF bav$task_file_table^ [i].sender_active THEN
              bav$task_file_table^ [i].sender_active := FALSE;
              osp$set_status_condition (nae$job_recovery, bav$task_file_table^ [i].sender_activity_status^.
                    status);
              bav$task_file_table^ [i].sender_activity_status^.complete := TRUE;
            IFEND;
            IF bav$task_file_table^ [i].receiver_active THEN
              bav$task_file_table^ [i].receiver_active := FALSE;
              osp$set_status_condition (nae$job_recovery, bav$task_file_table^ [i].receiver_activity_status^.
                    status);
              bav$task_file_table^ [i].receiver_activity_status^.complete := TRUE;
            IFEND;
            osp$disestablish_cond_handler;
          IFEND;
        IFEND;
      FOREND;
    IFEND;

  PROCEND nlp$recover_task_activity;
?? OLDTITLE ??
?? NEWTITLE := 'terminate_receive_data', EJECT ??

  PROCEDURE terminate_receive_data
    (    connection: ^nat$connection_descriptor;
         cl_connection: ^nlt$cl_connection;
         status: ^ost$status);

    VAR
      valid_file_identifier: boolean;

    IF ((connection^.receiver_request.application_buffer.description_kind = nac$allocated) AND
          (connection^.receiver_request.application_buffer.allocated_description <> NIL)) THEN
      FREE connection^.receiver_request.application_buffer.allocated_description IN nav$network_paged_heap^;
    IFEND;
    nlp$cl_deactivate_receiver (cl_connection);
    connection^.wait_state := nac$inactive_wait;
    complete_activity (receive, connection^.receive_file_identifier, status, valid_file_identifier);
    IF NOT valid_file_identifier THEN
      nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
    IFEND;
  PROCEND terminate_receive_data;
?? OLDTITLE ??
?? NEWTITLE := 'terminate_send_data', EJECT ??

  PROCEDURE terminate_send_data
    (    connection: ^nat$connection_descriptor;
         cl_connection: ^nlt$cl_connection;
         status: ^ost$status);

    VAR
      valid_file_identifier: boolean;

    IF ((connection^.sender_request.application_buffer.description_kind = nac$allocated) AND
          (connection^.sender_request.application_buffer.allocated_description <> NIL)) THEN
      FREE connection^.sender_request.application_buffer.allocated_description IN nav$network_paged_heap^;
    IFEND;
    nlp$cl_deactivate_sender (cl_connection);
    complete_activity (send, connection^.send_file_identifier, status, valid_file_identifier);
    IF NOT valid_file_identifier THEN
      nap$namve_system_error (TRUE, invalid_file_identifier, NIL);
    IFEND;
  PROCEND terminate_send_data;
?? OLDTITLE ??
MODEND nam$se_external_interface;
*DECK DECK=NAM$SE_GET_AVAILABLE_BYTE_COUNT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE NETWORK ACCESS: Get Available Byte Count Request' ??
MODULE nam$se_get_available_byte_count;

{ PURPOSE:
{   This module contains the procedure to get number of bytes of data currently
{   queued on a network connection.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$improper_file_id
*copyc amk$access_method
*copyc amt$fap_declarations
*copyc nak$external_keypoints_job_mode
*copyc nat$data_length
*copyc nat$external_keypoint_constants
*copyc ost$caller_identifier
?? POP ??
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
?? EJECT ??
*copyc amh$also
?? EJECT ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$se_get_available_byte_count', EJECT ??
*copyc nah$se_get_available_byte_count

  PROCEDURE [XDCL, #GATE] nap$se_get_available_byte_count
    (    file_identifier: amt$file_identifier;
     VAR byte_count: nat$data_length;
     VAR status: ost$status);


    CONST
      fap_layer_number = 0,
      interface_name = 'NAP$SE_GET_AVAILABLE_BYTE_COUNT';

    VAR
      bam_status: ost$status,
      call_block: amt$call_block,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry;

    #keypoint (osk$entry, osk$m * amk_se_get_available_byte_count, nak$session_external);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy bai$validate_file_identifier

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id, interface_name, status);
      #keypoint (osk$exit, osk$m * amk_se_get_available_byte_count, nak$session_external);
      RETURN;
    IFEND;

    call_block.operation := nac$se_get_avail_byte_count_req;
    call_block.se_get_available_byte_count := ^byte_count;

*copy bai$call_fap_control

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, osk$m * amk_se_get_available_byte_count, nak$session_external);
  PROCEND nap$se_get_available_byte_count;
?? OLDTITLE ??
MODEND nam$se_get_available_byte_count;

*DECK DECK=NAM$SE_INTERRUPT EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE nam$se_interrupt;

{ MODULE DECK NAM$SE_INTERRUPT }

?? TITLE := 'NOS/VE :  NETWORK ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] NAM$SE_INTERRUPT' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc nak$external_keypoints_job_mode
*copyc nat$external_keypoint_constants
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??

*copyc nah$se_interrupt
 PROCEDURE [#GATE,XDCL] nap$se_interrupt (
        file_identifier: amt$file_identifier;
        data: SEQ (*);
    VAR status: ost$status);


    CONST
      interface_name = 'NAP$SE_SEND_INTERRUPT',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, osk$m * amk_se_interrupt, nak$session_external);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, osk$m * amk_se_interrupt, nak$session_external);
      RETURN;
    IFEND;

    call_block.operation := nac$se_interrupt_req;

    call_block.se_interrupt_data := ^data;

*copy BAI$CALL_FAP_CONTROL

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, osk$m * amk_se_interrupt, nak$session_external);
  PROCEND nap$se_interrupt;
MODEND nam$se_interrupt;
*DECK DECK=NAM$SE_RECEIVE_DATA EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE nam$se_receive_data;

{ MODULE DECK NAM$SE_RECEIVE_DATA }

?? TITLE := 'NOS/VE :  NETWORK ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] NAM$SE_RECEIVE_DATA' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc NAT$SE_PEER_OPERATION
*copyc nak$external_keypoints_job_mode
*copyc nat$external_keypoint_constants
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
?? EJECT ??
*copyc nah$se_receive_data
 PROCEDURE [#GATE,XDCL] nap$se_receive_data (
        file_identifier: amt$file_identifier;
        buffer: nat$data_fragments;
        wait: ost$wait;
    VAR peer_operation: nat$se_peer_operation;
    VAR activity_status: ost$activity_status;
    VAR status: ost$status);


    CONST
      interface_name = 'NAP$SE_ECEIVE_DATA',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, osk$m * amk_se_receive_data, nak$session_external);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, osk$m * amk_se_receive_data, nak$session_external);
      RETURN;
    IFEND;

    call_block.operation := nac$se_receive_data_req;

    call_block.se_receive_data_req.buffer := ^buffer;
    call_block.se_receive_data_req.wait := wait;
    call_block.se_receive_data_req.peer_operation := ^peer_operation;
    call_block.se_receive_data_req.activity_status := ^activity_status;

*copy BAI$CALL_FAP_CONTROL

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, osk$m * amk_se_receive_data, nak$session_external);
  PROCEND nap$se_receive_data;
MODEND nam$se_receive_data;

*DECK DECK=NAM$SE_SEND_DATA EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE nam$se_send_data;

{ MODULE DECK NAM$SE_SEND_DATA }

?? TITLE := 'NOS/VE :  NETWORK ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] NAM$SE_SEND_DATA' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc nak$external_keypoints_job_mode
*copyc nat$external_keypoint_constants
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
?? EJECT ??


*copyc nah$se_send_data
 PROCEDURE [#GATE,XDCL] nap$se_send_data (
        file_identifier: amt$file_identifier;
        data: nat$data_fragments;
        end_of_message: boolean;
        qualified_data: boolean;
        wait: ost$wait;
    VAR activity_status: ost$activity_status;
    VAR status: ost$status);

    CONST
      interface_name = 'NAP$SE_SEND_DATA',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, osk$m * amk_se_send_data, nak$session_external);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, osk$m * amk_se_send_data, nak$session_external);
      RETURN;
    IFEND;

    call_block.operation := nac$se_send_data_req;

    call_block.se_send_data_req.data := ^data;
    call_block.se_send_data_req.end_of_message := end_of_message;
    call_block.se_send_data_req.qualified_data := qualified_data;
    call_block.se_send_data_req.wait := wait;
    call_block.se_send_data_req.activity_status := ^activity_status;

*copy BAI$CALL_FAP_CONTROL

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, osk$m * amk_se_send_data, nak$session_external);
  PROCEND nap$se_send_data;
MODEND nam$se_send_data;
*DECK DECK=NAM$SE_SYNCHRONIZE EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE nam$se_synchronize;

{ MODULE DECK NAM$SE_SYNCHRONIZE }

?? TITLE := 'NOS/VE :  NETWORK ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] NAM$SE_SYNCHRONIZE' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc nak$external_keypoints_job_mode
*copyc nat$external_keypoint_constants
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc nah$se_synchronize
 PROCEDURE [#GATE,XDCL] nap$se_synchronize (
        file_identifier: amt$file_identifier;
        direction: nat$se_synchronize_direction;
        data: SEQ (*);
    VAR status: ost$status);


    CONST
      interface_name = 'NAP$SE_SYNCHRONIZE',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, osk$m * amk_se_synchronize, nak$session_external);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, osk$m * amk_se_synchronize, nak$session_external);
      RETURN;
    IFEND;

    call_block.operation := nac$se_synchronize_req;

    call_block.se_synchronize_req.data := ^data;
    call_block.se_synchronize_req.direction := direction;

*copy BAI$CALL_FAP_CONTROL

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, osk$m * amk_se_synchronize, nak$session_external);
  PROCEND nap$se_synchronize;
MODEND nam$se_synchronize;
*DECK DECK=NAM$SE_SYNCHRONIZE_CONFIRM EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE nam$se_synchronize_confirm;

{ MODULE DECK NAM$SE_SYNCHRONIZE_CONFIRM }

?? TITLE := 'NOS/VE :  NETWORK ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] NAM$SE_SYNCHRONIZE_CONFIRM ' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc nak$external_keypoints_job_mode
*copyc nat$external_keypoint_constants
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??

*copyc nah$se_synchronize_confirm
 PROCEDURE [#GATE,XDCL] nap$se_synchronize_confirm (
        file_identifier: amt$file_identifier;
    VAR status: ost$status);


    CONST
      interface_name = 'NAP$SE_SYNCHRONIZE_CONFIRM',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, osk$m * amk_se_synchronize_confirm, nak$session_external);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, osk$m * amk_se_synchronize_confirm, nak$session_external);
      RETURN;
    IFEND;

    call_block.operation := nac$se_synchronize_confirm_req;

*copy BAI$CALL_FAP_CONTROL

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, osk$m * amk_se_synchronize_confirm, nak$session_external);
  PROCEND nap$se_synchronize_confirm;
MODEND nam$se_synchronize_confirm;
*DECK DECK=NAM$SK_AWAIT_SOCKET_EVENTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access: Socket Layer External Interface In 2DD' ??
MODULE nam$sk_await_socket_events;

{ PURPOSE:
{   This module contains the Socket Layer external interface that provides the ability
{   to await events on more than one socket.
{ DESIGN:
{   This module contains code that has an execution bracket of 2, 13. It resides on
{   OSF$JOB_TEMPLATE_2DD.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_socket_events
*copyc ost$status
?? POP ??
*copyc nlp$sk_await_socket_events
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_await_socket_events', EJECT ??
*copy nah$sk_await_socket_events

  PROCEDURE [XDCL, #GATE] nap$sk_await_socket_events
    (    socket_events: nat$sk_socket_events;
     VAR completed_events: nat$sk_socket_events;
     VAR count: integer;
     VAR status: ost$status);

    count := 0;
    status.normal := TRUE;
    REPEAT
      nlp$sk_await_socket_events (socket_events, completed_events, count, status);
    UNTIL (count > 0) OR (NOT status.normal);

  PROCEND nap$sk_await_socket_events;
?? OLDTITLE ??
MODEND nam$sk_await_socket_events;

*DECK DECK=NAM$SK_SOCKET_LAYER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access: Socket Layer External Interface' ??
MODULE nam$sk_socket_layer;

{ PURPOSE:
{   This module contains procedures neccesary to support the Program Interface to the NAM/VE
{   Socket Layer.
{ DESIGN:
{   The procedures in this module provide the ability to
{
{        - Create and delete sockets, both UDP and TCP
{        - Send and Receive data over these sockets
{        - Select options for these sockets
{        - Query the attributes of the sockets
{        - Get the local IP addresses
{
{   At present, IPAM is the only user of these procedures. The XDCL'd procedures have been
{   grouped in alphabetical order followed by the internal procedures. The internal procedures
{   are also in alphabetical order. Please refer to the ERS for NAM/VE Socket Layer (A8708)
{   for more information about these procedures.
{   This module contains code that executes in ring 3. It resides on OSF$JOB_TEMPLATE_23D.
{
{ NOTES:
{   The following abbreviations have been used in this module:
{          UDP - User Datagram Protocol
{          TCP - Transmission Control Protocol

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$system_family
*copyc nac$null_connection_id
*copyc nac$sk_all_ip_addresses
*copyc nac$sk_default_if_timeout
*copyc nac$sk_max_nonblocked_data_size
*copyc nac$sk_unnamed_tcp_application
*copyc nac$sk_unnamed_udp_application
*copyc nae$application_interfaces
*copyc nae$application_management
*copyc nae$sk_socket_layer
*copyc nat$application_name
*copyc nat$application_status
*copyc nat$connection_id
*copyc nat$data_length
*copyc nat$protocol
*copyc nat$sk_host_name
*copyc nat$sk_job_socket
*copyc nat$sk_job_socket_list
*copyc nat$sk_job_socket_status
*copyc nat$sk_listen_queue_limit
*copyc nat$sk_socket_attributes
*copyc nat$sk_socket_events
*copyc nat$sk_socket_identifier
*copyc nat$sk_socket_options
*copyc nat$sk_socket_status
*copyc nat$sk_socket_type
*copyc nat$wait_time
*copyc nlc$sk_min_assigned_port
*copyc nlc$sk_max_assigned_port
*copyc nlc$sk_max_priv_reserved_port
*copyc nlc$udp_null_global_socket_id
*copyc nlt$cl_connection
*copyc nlt$cl_connection_layer_templat
*copyc nlt$cl_layer_name
*copyc nlt$tcp_open_port
*copyc nlt$tcp_ports
*copyc nlt$tcp_received_data
*copyc nlt$tcp_receiver_task
*copyc nlt$tcp_sender_task
*copyc nlt$tcp_socket_type
*copyc nlt$udp_global_socket
*copyc nlt$udp_global_socket_id
*copyc nlt$udp_open_port
*copyc nlt$udp_ports
*copyc osd$virtual_address
*copyc ost$caller_identifier
*copyc ost$name
*copyc ost$signature_lock_status
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*copyc nap$get_tcpip_attributes
*copyc nap$namve_system_error
*copyc nap$validate_user
*copyc nlp$al_get_data_length
*copyc nlp$bm_deliver_message
*copyc nlp$cc_receive_data
*copyc nlp$cc_report_undelivered_data
*copyc nlp$cl_activate_layer
*copyc nlp$cl_activate_receiver
*copyc nlp$cl_activate_sender
*copyc nlp$cl_clear_exclusive_access
*copyc nlp$cl_create_connection
*copyc nlp$cl_deactivate_layer
*copyc nlp$cl_deactivate_receiver
*copyc nlp$cl_deactivate_sender
*copyc nlp$cl_get_exclusive_via_cid
*copyc nlp$cl_get_layer_connection
*copyc nlp$cl_release_exclusive_access
*copyc nlp$osi_get_outbound_capacity
*copyc nlp$sk_accept_socket_offer
*copyc nlp$sk_add_job_socket
*copyc nlp$sk_clear_job_socket_lock
*copyc nlp$sk_delete_job_socket
*copyc nlp$sk_free_socket_id
*copyc nlp$sk_get_socket_id
*copyc nlp$sk_lock_job_socket
*copyc nlp$sk_offer_socket
*copyc nlp$sk_tcp_accept_socket
*copyc nlp$sk_tcp_activate_listen
*copyc nlp$sk_tcp_cancel_socket_offer
*copyc nlp$sk_tcp_check_accept_socket
*copyc nlp$sk_tcp_close_socket
*copyc nlp$sk_tcp_deactivate_layer
*copyc nlp$sk_tcp_get_rec_task_entry
*copyc nlp$sk_tcp_get_listen_addresses
*copyc nlp$sk_tcp_get_send_task_entry
*copyc nlp$sk_tcp_get_socket_status
*copyc nlp$sk_tcp_offer_socket
*copyc nlp$sk_tcp_ret_rec_data_entry
*copyc nlp$sk_tcp_ret_rec_task_entry
*copyc nlp$sk_tcp_ret_send_task_entry
*copyc nlp$sk_tcp_send_data
*copyc nlp$sk_tcp_set_socket_options
*copyc nlp$sk_tcp_terminate_listen
*copyc nlp$sk_unlock_job_socket
*copyc nlp$sk_update_bound_address
*copyc nlp$sk_update_connect_socket
*copyc nlp$sk_update_job_socket
*copyc nlp$sk_update_job_socket_status
*copyc nlp$sk_update_listen_socket
*copyc nlp$sk_update_socket_options
*copyc nlp$tm_get_local_addresses
*copyc nlp$tcp_connect_socket
*copyc nlp$tcp_release_socket
*copyc nlp$tcpip_decrement_appl_access
*copyc nlp$tcpip_increment_appl_access
*copyc nlp$tm_select_by_local_tcp_addr
*copyc nlp$tm_tcp_select_device
*copyc nlp$udp_bind_socket
*copyc nlp$udp_cancel_socket_offer
*copyc nlp$udp_close_socket
*copyc nlp$udp_create_global_socket
*copyc nlp$udp_delete_global_socket
*copyc nlp$udp_free_exclusive_access
*copyc nlp$udp_get_bound_addresses
*copyc nlp$udp_get_socket_status
*copyc nlp$udp_offer_socket
*copyc nlp$udp_receive_data
*copyc nlp$udp_send_data
*copyc nlp$udp_set_socket_options
*copyc osp$append_status_integer
*copyc osp$clear_job_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$pop_inhibit_job_recovery
*copyc osp$push_inhibit_job_recovery
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc pmp$continue_to_cause
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_job_names
*copyc pmp$get_user_identification
*copyc pmp$ready_task
*copyc pmp$wait
*copyc syp$cycle
*copyc nav$network_paged_heap
*copyc nav$sk_job_socket_assignment
*copyc nav$sk_job_socket_list
*copyc nav$sk_socket_layer_active
*copyc nlv$bm_null_message_id
*copyc nlv$tcp_ports
*copyc nlv$tm_host
*copyc nlv$udp_ports
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
*copyc nlc$udp_null_global_socket_id

  CONST
    loopback_address = (127 * 256 * 256 * 256) + 1;  { 127.0.0.1 in standard IP adddress notation.

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_accept_socket', EJECT ??
*copy nah$sk_accept_socket

  PROCEDURE [XDCL, #GATE] nap$sk_accept_socket
    (    listen_socket_id: nat$sk_socket_identifier;
     VAR accept_socket_id: nat$sk_socket_identifier;
     VAR source_socket: nat$sk_socket_address;
     VAR status: ost$status);

?? NEWTITLE := 'terminate_accept_socket', EJECT ??

    PROCEDURE terminate_accept_socket
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF socket_locked THEN
        nlp$sk_clear_job_socket_lock (accept_socket_id);
        nlp$sk_free_socket_id (accept_socket_id);
      IFEND;
      osp$pop_inhibit_job_recovery;

    PROCEND terminate_accept_socket;
?? OLDTITLE, EJECT ??

    VAR
      caller_id: ost$caller_identifier,
      connection_id: nat$connection_id,
      current_task_id: ost$global_task_id,
      listen_socket: ^nat$sk_job_socket,
      local_ip_address: nat$sk_ip_address,
      nil_socket: ^nat$sk_job_socket,
      saved_job_socket: nat$sk_job_socket,
      socket_locked: boolean,
      wait_time: nat$wait_time;

    status.normal := TRUE;
    socket_locked := FALSE;
    #SPOIL (socket_locked);
    pmp$get_executing_task_gtid (current_task_id);
    osp$push_inhibit_job_recovery;
    IF listen_socket_id > 0 THEN
      nlp$sk_lock_job_socket (listen_socket_id, listen_socket);
      IF listen_socket <> NIL THEN
        #CALLER_ID (caller_id);
        IF caller_id.ring <= listen_socket^.ring THEN
          IF listen_socket^.socket_type = nac$sk_tcp_socket THEN
            IF listen_socket^.status = nac$sk_socket_open THEN
              IF listen_socket^.tcp_socket_type = nlc$tcp_listen_socket THEN
                nlp$sk_get_socket_id (accept_socket_id, status);
                IF status.normal THEN
                  #SPOIL (accept_socket_id);
                  osp$establish_block_exit_hndlr (^terminate_accept_socket);
                  nlp$sk_lock_job_socket (accept_socket_id, nil_socket);
                  socket_locked := TRUE;
                  #SPOIL (socket_locked);
                  saved_job_socket := listen_socket^;
                  nlp$sk_unlock_job_socket (listen_socket_id);
                  IF (saved_job_socket.interface_mode = nac$sk_blocking_mode) THEN
                    wait_time := saved_job_socket.interface_timeout;
                  ELSE
                    wait_time := 0;
                  IFEND;

                  nlp$sk_tcp_accept_socket (saved_job_socket.port, saved_job_socket.bound_address, TRUE
                        {graceful_close} , nac$sk_tcp_random_traffic, wait_time, connection_id, source_socket,
                        local_ip_address, status);
                  IF status.normal THEN

{ Setup the job socket attributes for the accepted socket.

                    saved_job_socket.identifier := accept_socket_id;
                    IF connection_id <> nac$null_connection_id THEN
                      saved_job_socket.status := nac$sk_socket_open;
                    ELSE
                      saved_job_socket.status := nac$sk_socket_closed_via_peer;
                    IFEND;
                    saved_job_socket.time_stamp := #FREE_RUNNING_CLOCK (0);
                    saved_job_socket.bound_address := local_ip_address;
                    saved_job_socket.owner := current_task_id;
                    saved_job_socket.interface_mode := nac$sk_blocking_mode;
                    saved_job_socket.interface_timeout := nac$sk_default_if_timeout;
                    saved_job_socket.traffic_pattern := nac$sk_tcp_random_traffic;
                    saved_job_socket.connection_id := connection_id;
                    saved_job_socket.local_ip_address := local_ip_address;
                    saved_job_socket.tcp_socket_type := nlc$tcp_accept_socket;
                    saved_job_socket.reuse_address := FALSE;
                    saved_job_socket.graceful_close := TRUE;
                    saved_job_socket.selection_criteria.ip_address := nac$sk_all_ip_addresses;
                    saved_job_socket.selection_criteria.port := 0;
                    nlp$sk_add_job_socket (accept_socket_id, saved_job_socket);
                    nlp$sk_unlock_job_socket (accept_socket_id);
                    socket_locked := FALSE;
                    #SPOIL (socket_locked);
                  ELSE
                    nlp$sk_unlock_job_socket (accept_socket_id);
                    socket_locked := FALSE;
                    #SPOIL (socket_locked);
                    nlp$sk_free_socket_id (accept_socket_id);
                    IF status.condition = nae$sk_socket_terminated THEN
                      osp$append_status_integer (osc$status_parameter_delimiter, listen_socket_id, 10, TRUE,
                            status);
                      nlp$sk_lock_job_socket (listen_socket_id, listen_socket);
                      IF (listen_socket <> NIL) AND (listen_socket^.time_stamp = saved_job_socket.time_stamp)
                            THEN
                        nlp$sk_update_job_socket_status (listen_socket_id, nac$sk_socket_terminated);
                      IFEND;
                      nlp$sk_unlock_job_socket (listen_socket_id);
                    IFEND;
                  IFEND;
                  osp$disestablish_cond_handler;
                ELSE { Max socket limit reached
                  nlp$sk_unlock_job_socket (listen_socket_id);
                IFEND;
              ELSE { Listen not done
                nlp$sk_unlock_job_socket (listen_socket_id);
                osp$set_status_condition (nae$sk_listen_not_done, status);
                osp$append_status_integer (osc$status_parameter_delimiter, listen_socket_id, 10, TRUE,
                      status);
              IFEND;
            ELSE
              nlp$sk_unlock_job_socket (listen_socket_id);
              IF listen_socket^.status = nac$sk_socket_terminated THEN
                osp$set_status_condition (nae$sk_socket_terminated, status);
              ELSEIF listen_socket^.status = nac$sk_job_recovery THEN
                osp$set_status_condition (nae$sk_job_recovery, status);
              IFEND;
              osp$append_status_integer (osc$status_parameter_delimiter, listen_socket_id, 10, TRUE, status);
            IFEND;
          ELSE { Incorrect socket type
            nlp$sk_unlock_job_socket (listen_socket_id);
            osp$set_status_abnormal (nac$status_id, nae$sk_incorrect_socket_type, 'ACCEPT SOCKET', status);
          IFEND;
        ELSE { Invalid user
          nlp$sk_unlock_job_socket (listen_socket_id);
          osp$set_status_abnormal (nac$status_id, nae$sk_invalid_user, 'NAP$SK_ACCEPT_SOCKET', status);
        IFEND;
      ELSE { Unknown socket
        nlp$sk_unlock_job_socket (listen_socket_id);
        osp$set_status_condition (nae$sk_unknown_socket, status);
        osp$append_status_integer (osc$status_parameter_delimiter, listen_socket_id, 10, TRUE, status);
      IFEND;
    ELSE { listen_socket_id = 0
      osp$set_status_condition (nae$sk_unknown_socket, status);
      osp$append_status_integer (osc$status_parameter_delimiter, listen_socket_id, 10, TRUE, status);
    IFEND;
    osp$pop_inhibit_job_recovery;

  PROCEND nap$sk_accept_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_accept_socket_offer', EJECT ??
*copy nah$sk_accept_socket_offer

  PROCEDURE [XDCL, #GATE] nap$sk_accept_socket_offer
    (    source_job: jmt$system_supplied_name;
         wait_time: nat$wait_time;
     VAR socket_id: nat$sk_socket_identifier;
     VAR status: ost$status);

?? NEWTITLE := 'terminate_accept_socket_offer', EJECT ??

    PROCEDURE terminate_accept_socket_offer
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF socket_locked THEN
        nlp$sk_clear_job_socket_lock (socket_id);
        nlp$sk_free_socket_id (socket_id);
      IFEND;
      osp$pop_inhibit_job_recovery;

    PROCEND terminate_accept_socket_offer;
?? OLDTITLE, EJECT ??

    VAR
      application: nat$application_name,
      bound_address: nat$sk_ip_address,
      capability: ost$name,
      connection_id: nat$connection_id,
      current_task_id: ost$global_task_id,
      global_socket_id: nlt$udp_global_socket_id,
      job_socket: nat$sk_job_socket,
      old_job_socket: ^nat$sk_job_socket,
      port: nat$sk_port_number,
      ring: ost$ring,
      socket_locked: boolean,
      socket_type: nat$sk_socket_type,
      tcp_socket_type: nlt$tcp_socket_type,
      time_stamp: ost$free_running_clock,
      traffic_pattern: nat$sk_traffic_pattern;

    status.normal := TRUE;
    pmp$get_executing_task_gtid (current_task_id);
    osp$push_inhibit_job_recovery;
    socket_locked := FALSE;
    #SPOIL (socket_locked);
    nlp$sk_get_socket_id (socket_id, status);
    IF status.normal THEN
      osp$establish_block_exit_hndlr (^terminate_accept_socket_offer);
      nlp$sk_lock_job_socket (socket_id, old_job_socket);
      socket_locked := TRUE;
      #SPOIL (socket_locked);
      #SPOIL (socket_id);
      IF old_job_socket = NIL THEN
        time_stamp := #FREE_RUNNING_CLOCK (0);
        nlp$sk_accept_socket_offer (source_job, socket_id, time_stamp, wait_time, socket_type,
              global_socket_id, connection_id, tcp_socket_type, bound_address, port, traffic_pattern,
              application, ring, capability, status);
        IF status.normal THEN

{ Set up the job socket entry.
{ Store all fields in the job socket entry.
{ Initialize all socket attributes to default values.
{ Initialize status to open.

          job_socket.identifier := socket_id;
          job_socket.time_stamp := time_stamp;
          job_socket.status := nac$sk_socket_open;
          job_socket.socket_type := socket_type;
          job_socket.application := application;
          job_socket.capability := capability;
          job_socket.ring := ring;
          job_socket.system_privilege := FALSE;
          job_socket.port := port;

{ Initialize the socket attributes to the default values except for
{ the bound address and the traffic pattern. The bound address and
{ traffic pattern are set to the values assigned by the source job.

          job_socket.bound_address := bound_address;
          job_socket.owner := current_task_id;
          job_socket.interface_mode := nac$sk_blocking_mode;
          job_socket.interface_timeout := nac$sk_default_if_timeout;
          job_socket.traffic_pattern := traffic_pattern;
          IF socket_type = nac$sk_udp_socket THEN
            job_socket.global_socket_id := global_socket_id;
            job_socket.checksum := TRUE;
            job_socket.local_ip_address_enabled := FALSE;
            job_socket.user_cache_enabled := TRUE;
            job_socket.broadcast_enabled := FALSE;
          ELSEIF socket_type = nac$sk_tcp_socket THEN
            job_socket.connection_id := connection_id;
            job_socket.tcp_socket_type := tcp_socket_type;
            job_socket.reuse_address := FALSE;
            job_socket.graceful_close := TRUE;
            job_socket.selection_criteria.ip_address := nac$sk_all_ip_addresses;
            job_socket.selection_criteria.port := 0;
          ELSE { unknown socket type
            nap$namve_system_error ({Recoverable_error=} TRUE, 'Accepted an unknown socket type.', NIL);
            osp$set_status_condition (nae$sk_unknown_socket_type, status);
          IFEND;
          IF status.normal THEN
            nlp$sk_add_job_socket (socket_id, job_socket);
          ELSE
            nlp$sk_free_socket_id (socket_id);
          IFEND;
        ELSE { No socket offer
          nlp$sk_free_socket_id (socket_id);
        IFEND;
      ELSE { job_socket <> NIL
        nlp$sk_free_socket_id (socket_id);
        nap$namve_system_error ({Recoverable_error=} TRUE, 'Socket layer assigned a non nil socket.', NIL);
        osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'ACCEPT SOCKET OFFER', status);
      IFEND;
      nlp$sk_unlock_job_socket (socket_id);
      osp$disestablish_cond_handler;
    IFEND;
    osp$pop_inhibit_job_recovery;

  PROCEND nap$sk_accept_socket_offer;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_bind_socket', EJECT ??
*copy nah$sk_bind_socket

  PROCEDURE [XDCL, #GATE] nap$sk_bind_socket
    (    socket_id: nat$sk_socket_identifier;
         port: nat$sk_port_number;
         ip_address: nat$sk_ip_address;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      identification: ost$user_identification,
      job_socket: ^nat$sk_job_socket;

    status.normal := TRUE;
    osp$push_inhibit_job_recovery;
    IF socket_id > 0 THEN
      nlp$sk_lock_job_socket (socket_id, job_socket);
      IF (job_socket <> NIL) THEN
        #CALLER_ID (caller_id);
        IF caller_id.ring <= job_socket^.ring THEN
          IF job_socket^.status = nac$sk_socket_unbound THEN
            IF (port > 0) AND (port <= nlc$sk_max_priv_reserved_port) THEN

{ The user must be in the $system user and family or executing in ring 6 in order to open
{ privileged ports.

              pmp$get_user_identification (identification, status);
              IF status.normal THEN

{             IF ((identification.user <> jmc$system_user) OR
{               (identification.family <> jmc$system_family)) AND
{               (caller_id.ring > osc$sj_ring_3) THEN
{               osp$set_status_abnormal (nac$status_id, nae$sk_invalid_user, 'PRIVILEGED PORT', status);
{             IFEND;

              IFEND;
            IFEND;
            IF status.normal THEN
              IF job_socket^.socket_type = nac$sk_udp_socket THEN
                bind_udp_socket (job_socket, port, ip_address, status);
                IF (NOT status.normal) AND (status.condition = nae$sk_socket_terminated) THEN
                  nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                  osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                IFEND;
              ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
                bind_tcp_socket (job_socket, port, ip_address, status);
              IFEND;
            IFEND;
          ELSEIF job_socket^.status = nac$sk_job_recovery THEN
            osp$set_status_condition (nae$sk_job_recovery, status);
            osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
          ELSE { socket already bound
            osp$set_status_condition (nae$sk_socket_already_bound, status);
            osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
          IFEND;
        ELSE { Invalid user
          osp$set_status_abnormal (nac$status_id, nae$sk_invalid_user, 'NAP$SK_BIND_SOCKET', status);
        IFEND;
      ELSE { Unknown socket
        osp$set_status_condition (nae$sk_unknown_socket, status);
        osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
      IFEND;

      nlp$sk_unlock_job_socket (socket_id);
    ELSE { socket_id = 0
      osp$set_status_condition (nae$sk_unknown_socket, status);
      osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
    IFEND;
    osp$pop_inhibit_job_recovery;

  PROCEND nap$sk_bind_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_close_socket', EJECT ??
*copy nah$sk_close_socket

  PROCEDURE [XDCL, #GATE] nap$sk_close_socket
    (    socket_id: nat$sk_socket_identifier;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      current_task_id: ost$global_task_id,
      job_socket: ^nat$sk_job_socket;

    status.normal := TRUE;
    pmp$get_executing_task_gtid (current_task_id);
    osp$push_inhibit_job_recovery;
    IF socket_id > 0 THEN
      nlp$sk_lock_job_socket (socket_id, job_socket);
      IF (job_socket <> NIL) THEN
        #CALLER_ID (caller_id);
        IF caller_id.ring <= job_socket^.ring THEN
          IF job_socket^.owner = current_task_id THEN
            close_socket (job_socket, status);
          ELSE {Current task not the owner

{       Ignore it.

          IFEND;
        ELSE { Invalid user
          osp$set_status_abnormal (nac$status_id, nae$sk_invalid_user, 'NAP$SK_CLOSE_SOCKET', status);
        IFEND;
      ELSE { job_socket = NIL
        osp$set_status_condition (nae$sk_unknown_socket, status);
        osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
      IFEND;
      nlp$sk_unlock_job_socket (socket_id);
    ELSE { socket_id = 0
      osp$set_status_condition (nae$sk_unknown_socket, status);
      osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
    IFEND;
    osp$pop_inhibit_job_recovery;

  PROCEND nap$sk_close_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_connect_socket', EJECT ??
*copy nah$sk_connect_socket

  PROCEDURE [XDCL, #GATE] nap$sk_connect_socket
    (    socket_id: nat$sk_socket_identifier;
         destination_socket: nat$sk_socket_address;
     VAR status: ost$status);

?? NEWTITLE := 'terminate_connect', EJECT ??

    PROCEDURE terminate_connect
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
      IF cl_connection <> NIL THEN
        nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active, tcp_connection);
        IF layer_active THEN
          IF (tcp_connection^.state <> nlc$tcp_conn_closed) AND
                (tcp_connection^.state <> nlc$tcp_conn_terminated) THEN

{ Send a disconnect to the peer.

            nlp$tcp_release_socket (cl_connection, {ignore} local_status);
            tcp_connection^.state := nlc$tcp_conn_closed;
            nlp$cl_deactivate_layer (nlc$tcp_interface, cl_connection);
            decrement_access_count := TRUE;
          ELSEIF tcp_connection^.state = nlc$tcp_conn_closed THEN
            decrement_access_count := TRUE;
          IFEND;
        IFEND;
        nlp$cl_release_exclusive_access (cl_connection);
        IF decrement_access_count THEN
          nlp$tcpip_decrement_appl_access (job_socket^.application, nlc$udp_null_global_socket_id,
                connection_id, {ignore} local_status);
        IFEND;

      ELSE { Socket may be gone because of job recovery.

      IFEND;
      IF job_socket^.status = nac$sk_socket_unbound THEN
        close_tcp_port (nac$sk_all_ip_addresses, port, FALSE);
      IFEND;
      nlp$sk_clear_job_socket_lock (socket_id);
      osp$pop_inhibit_job_recovery;

    PROCEND terminate_connect;
?? OLDTITLE, EJECT ??

    VAR
      caller_id: ost$caller_identifier,
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      connection_id: nat$connection_id,
      current_time: ost$free_running_clock,
      decrement_access_count: boolean,
      destination_address: nat$sk_socket_address,
      end_time: integer,
      job_socket: ^nat$sk_job_socket,
      layer_active: boolean,
      local_ip_address: nat$sk_ip_address,
      local_status: ost$status,
      port: nat$sk_port_number,
      remaining_time: integer,
      selected_device: nlt$device_identifier,
      source_socket: nat$sk_socket_address,
      tcp_connection: ^nlt$tcp_socket_layer;

    status.normal := TRUE;
    decrement_access_count := FALSE;
    #SPOIL (decrement_access_count);
    osp$push_inhibit_job_recovery;
    IF socket_id > 0 THEN
      nlp$sk_lock_job_socket (socket_id, job_socket);
      #SPOIL (job_socket);
      IF job_socket <> NIL THEN
        #CALLER_ID (caller_id);
        IF caller_id.ring <= job_socket^.ring THEN
          IF job_socket^.socket_type = nac$sk_tcp_socket THEN
            IF job_socket^.status = nac$sk_socket_unbound THEN
              open_tcp_port (job_socket^.bound_address, port, status);
              #SPOIL (port);
            ELSEIF job_socket^.status = nac$sk_socket_open THEN
              port := job_socket^.port;
              #SPOIL (port);
              IF job_socket^.connection_id <> nac$null_connection_id THEN
                osp$set_status_condition (nae$sk_socket_already_connected, status);
                osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, FALSE, status);
              ELSEIF job_socket^.tcp_socket_type = nlc$tcp_listen_socket THEN
                osp$set_status_condition (nae$sk_listen_already_active, status);
                osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, FALSE, status);
              IFEND;
            ELSEIF job_socket^.status = nac$sk_socket_terminated THEN
              osp$set_status_condition (nae$sk_socket_terminated, status);
              osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, FALSE, status);
            ELSEIF job_socket^.status = nac$sk_socket_disconnected THEN
              osp$set_status_condition (nae$sk_socket_disconnected, status);
              osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, FALSE, status);
            ELSEIF job_socket^.status = nac$sk_socket_closed_via_peer THEN
              osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
              osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, FALSE, status);
            ELSEIF job_socket^.status = nac$sk_job_recovery THEN
              osp$set_status_condition (nae$sk_job_recovery, status);
              osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, FALSE, status);
            IFEND;

            IF status.normal THEN

{ Select the device. Note that the loopback address is detected here and affects device selection.

              IF job_socket^.bound_address = nac$sk_all_ip_addresses THEN
                IF destination_socket.ip_address <> loopback_address THEN
                  destination_address := destination_socket;
                  nlp$tm_tcp_select_device (destination_socket.ip_address, selected_device, local_ip_address,
                        status);
                ELSE { loopback address ... get a valid local TCP address for destination.
                  IF nlv$tm_device_configuration^.tcp.count > 0 THEN
                    selected_device := nlv$tm_device_configuration^.tcp.identifier;
                    local_ip_address := nlv$tm_device_configuration^.list [selected_device].
                          local_device_address.full;
                    destination_address.ip_address := local_ip_address;
                    destination_address.port := destination_socket.port;
                  ELSE
                    osp$set_status_condition (nae$tm_no_tcp_device_available, status);
                  IFEND;
                IFEND;
              ELSE { bound to specific address
                local_ip_address := job_socket^.bound_address;
                nlp$tm_select_by_local_tcp_addr (local_ip_address, selected_device, status);
                IF destination_socket.ip_address <> loopback_address THEN
                  destination_address := destination_socket;
                ELSE { loopback address ... use address of device in use.
                  destination_address.ip_address := local_ip_address;
                  destination_address.port := destination_socket.port;
                IFEND;
              IFEND;

              IF status.normal THEN

{ Establish the channel connection to the destination address via the selected device.

                source_socket.ip_address := local_ip_address;
                source_socket.port := port;
                nlp$cl_create_connection (nlc$tcp_interface, cl_connection);
                IF cl_connection <> NIL THEN
                  nlp$tcpip_increment_appl_access (job_socket^.application, {assigned} TRUE,
                        nlc$udp_null_global_socket_id, cl_connection^.identifier, status);
                  IF status.normal THEN
                    nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, {ignore} layer_active,
                          tcp_connection);
                    IF tcp_connection <> NIL THEN
                      tcp_connection^.device_id := selected_device;
                      tcp_connection^.disconnect_reason := 0;
                      tcp_connection^.user_initiated_close := FALSE;
                      tcp_connection^.socket_id := socket_id;
                      tcp_connection^.socket_type := nlc$tcp_connect_socket;
                      tcp_connection^.inventory_report := 0;
                      tcp_connection^.send_queue := NIL;
                      tcp_connection^.receive_queue := NIL;
                      tcp_connection^.received_data := NIL;
                      tcp_connection^.available_receiver_pool := NIL;
                      tcp_connection^.available_sender_pool := NIL;
                      tcp_connection^.available_data_pool := NIL;
                      tcp_connection^.source_socket := source_socket;
                      tcp_connection^.destination_socket := destination_address;
                      tcp_connection^.waiting_task_id.index := 0;
                      nlp$tcp_connect_socket (cl_connection, source_socket, destination_address,
                            job_socket^.graceful_close, job_socket^.traffic_pattern, nlc$cc_normal_class,
                            selected_device, status);
                      IF status.normal THEN
                        nlp$cl_activate_layer (nlc$tcp_interface, cl_connection);
                        tcp_connection^.state := nlc$tcp_conn_await_confirm;
                        pmp$get_executing_task_gtid (tcp_connection^.waiting_task_id);
                        connection_id := cl_connection^.identifier;
                        #SPOIL (connection_id);
                      ELSE
                        decrement_access_count := TRUE;
                      IFEND;
                    ELSE { tcp_connection = NIL
                      decrement_access_count := TRUE;
                      nap$namve_system_error ({Recoverable_error=} TRUE, 'TCP Socket layer NIL.', NIL);
                      osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'CONNECT SOCKET',
                            status);
                    IFEND;
                  ELSEIF status.condition = nae$maximum_sockets_exceeded THEN
                    osp$set_status_condition (nae$sk_max_sockets_limit, status);
                  IFEND;
                  nlp$cl_release_exclusive_access (cl_connection);
                ELSE { Resource constraint
                  osp$set_status_abnormal (nac$status_id, nae$sk_insufficient_resources, 'CONNECT SOCKET',
                        status);
                IFEND;
              IFEND;

              IF status.normal THEN
                #SPOIL (connection_id);
                #SPOIL (job_socket);
                #SPOIL (decrement_access_count);
                #SPOIL (port);
                end_time := #FREE_RUNNING_CLOCK (0) + job_socket^.interface_timeout * 1000;
                remaining_time := job_socket^.interface_timeout;
                osp$establish_block_exit_hndlr (^terminate_connect);

              /wait_for_response/
                REPEAT
                  pmp$wait (remaining_time, 0);
                  current_time := #FREE_RUNNING_CLOCK (0);
                  IF current_time < end_time THEN
                    remaining_time := (end_time - current_time) DIV 1000;
                  ELSE
                    remaining_time := 0;
                  IFEND;

{ Check if the connection has been accepted.

                  nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
                  IF cl_connection <> NIL THEN
                    nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active,
                          tcp_connection);
                    IF layer_active THEN
                      IF (tcp_connection^.state = nlc$tcp_conn_open) OR
                            (tcp_connection^.state = nlc$tcp_conn_closing) THEN
                        tcp_connection^.waiting_task_id.index := 0;
                        nlp$cl_release_exclusive_access (cl_connection);
                        IF job_socket^.status = nac$sk_socket_unbound THEN
                          nlp$sk_update_job_socket (socket_id, port, nac$sk_all_ip_addresses,
                                nac$sk_socket_open);
                        IFEND;
                        nlp$sk_update_connect_socket (socket_id, connection_id, local_ip_address);
                        EXIT /wait_for_response/;
                      ELSEIF tcp_connection^.state = nlc$tcp_conn_closed THEN

{ A disconnect was received from the peer.

                        nlp$cl_deactivate_layer (nlc$tcp_interface, cl_connection);
                        CASE tcp_connection^.disconnect_reason OF
                        = nlc$tcpaa_ri_address_in_use =
                          osp$set_status_condition (nae$sk_address_in_use, status);
                        = nlc$tcpaa_ri_user_termination =
                          osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
                        ELSE
                          osp$set_status_condition (nae$sk_socket_disconnected, status);
                        CASEND;
                        osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                              status);
                        decrement_access_count := TRUE;
                      ELSEIF remaining_time = 0 THEN

{ Send a disconnect to the peer.

                        nlp$tcp_release_socket (cl_connection, {ignore} local_status);
                        tcp_connection^.state := nlc$tcp_conn_closed;
                        nlp$cl_deactivate_layer (nlc$tcp_interface, cl_connection);
                        osp$set_status_condition (nae$sk_interface_timeout, status);
                        osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                              status);
                        decrement_access_count := TRUE;
                      IFEND;
                    ELSE { Layer inactive

{ The connection was terminated via application management.

                      osp$set_status_condition (nae$sk_socket_terminated, status);
                      osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                    IFEND;
                    nlp$cl_release_exclusive_access (cl_connection);
                  ELSE { cl_connection = NIL

{ The connection was terminated via application management.

                    osp$set_status_condition (nae$sk_socket_terminated, status);
                    osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                  IFEND;
                UNTIL (NOT status.normal) OR (remaining_time = 0);
                osp$disestablish_cond_handler;
              IFEND;

              IF decrement_access_count THEN
                nlp$tcpip_decrement_appl_access (job_socket^.application, nlc$udp_null_global_socket_id,
                      connection_id, {ignore} local_status);
              IFEND;
              IF (NOT status.normal) AND (job_socket^.status = nac$sk_socket_unbound) THEN
                close_tcp_port (nac$sk_all_ip_addresses, port, FALSE);
              IFEND;
              IF (NOT status.normal) AND (status.condition = nae$sk_socket_terminated) THEN
                nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
              IFEND;
            IFEND;
          ELSE { Incorrect socket type
            osp$set_status_abnormal (nac$status_id, nae$sk_incorrect_socket_type, 'CONNECT SOCKET', status);
          IFEND;
        ELSE { Invalid user
          osp$set_status_abnormal (nac$status_id, nae$sk_invalid_user, 'NAP$SK_CONNECT_SOCKET', status);
        IFEND;
      ELSE { Unknown socket
        osp$set_status_condition (nae$sk_unknown_socket, status);
        osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
      IFEND;
      nlp$sk_unlock_job_socket (socket_id);
    ELSE { socket_id = 0
      osp$set_status_condition (nae$sk_unknown_socket, status);
      osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
    IFEND;
    osp$pop_inhibit_job_recovery;

  PROCEND nap$sk_connect_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_get_host_name', EJECT ??
*copy nah$sk_get_host_name

  PROCEDURE [XDCL, #GATE] nap$sk_get_host_name
    (VAR host_name: nat$sk_host_name;
     VAR status: ost$status);

    status.normal := TRUE;
    IF nav$sk_socket_layer_active THEN
      host_name.length := nlv$tm_host.name_length;
      host_name.value := nlv$tm_host.name;
    ELSE
      osp$set_status_condition (nae$sk_tcpip_host_not_defined, status);
    IFEND;

  PROCEND nap$sk_get_host_name;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_get_local_addresses', EJECT ??
*copy nah$sk_get_local_addresses

  PROCEDURE [XDCL, #GATE] nap$sk_get_local_addresses
    (VAR local_addresses: nat$sk_local_addresses;
     VAR count: integer;
     VAR status: ost$status);

    status.normal := TRUE;
    IF nav$sk_socket_layer_active THEN
      nlp$tm_get_local_addresses (local_addresses, count);
    ELSE
      osp$set_status_condition (nae$sk_tcpip_host_not_defined, status);
    IFEND;

  PROCEND nap$sk_get_local_addresses;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_get_socket', EJECT ??
*copy nah$sk_get_socket

  PROCEDURE [XDCL, #GATE] nap$sk_get_socket
    (    application: ^nat$application_name;
         socket_type: nat$sk_socket_type;
     VAR socket_id: nat$sk_socket_identifier;
     VAR status: ost$status);

    VAR
      application_name: nat$application_name,
      application_status: nat$application_status,
      capability: ost$name,
      current_task_id: ost$global_task_id,
      global_socket: ^nlt$udp_global_socket,
      job_socket: nat$sk_job_socket,
      max_sockets: nat$number_of_sockets,
      old_job_socket: ^nat$sk_job_socket,
      protocol: nat$protocol,
      ring: ost$ring,
      system_privilege: boolean;

    status.normal := TRUE;
    IF nav$sk_socket_layer_active THEN
      IF (socket_type = nac$sk_udp_socket) OR (socket_type = nac$sk_tcp_socket) THEN
        IF application = NIL THEN
          IF socket_type = nac$sk_udp_socket THEN
            application_name := nac$sk_unnamed_udp_application;
          ELSEIF socket_type = nac$sk_tcp_socket THEN
            application_name := nac$sk_unnamed_tcp_application;
          IFEND;
        ELSE { Known application
          application_name := application^;
        IFEND;
      ELSE { unknown socket type
        osp$set_status_condition (nae$sk_unknown_socket_type, status);
      IFEND;

{ Verify that
{    . application name is defined
{    . application is active
{    . required caller ring and capability
{    . max connection not exceeded

      IF status.normal THEN
        osp$push_inhibit_job_recovery;
        nap$get_tcpip_attributes (application_name, application_status, max_sockets, capability, ring,
              system_privilege, protocol, status);
        IF status.normal THEN
          nap$validate_user (capability, ring, system_privilege, status);
          IF status.normal THEN
            IF ((socket_type = nac$sk_udp_socket) AND (protocol = nac$datagram_socket)) OR
                  ((socket_type = nac$sk_tcp_socket) AND (protocol = nac$stream_socket)) THEN
              IF application_status = nac$application_active THEN
                nlp$sk_get_socket_id (socket_id, status);
                IF status.normal THEN
                  pmp$get_executing_task_gtid (current_task_id);
                  nlp$sk_lock_job_socket (socket_id, old_job_socket);
                  IF old_job_socket = NIL THEN

{ Setup the job socket entry. Save the application, application type, capability
{ and ring in the job socket entry.

                    job_socket.identifier := socket_id;
                    job_socket.time_stamp := #FREE_RUNNING_CLOCK (0);
                    job_socket.status := nac$sk_socket_unbound;
                    job_socket.socket_type := socket_type;
                    job_socket.application := application_name;
                    job_socket.capability := capability;
                    job_socket.ring := ring;
                    job_socket.system_privilege := system_privilege;
                    job_socket.port := 0;

{ Initialize the socket attributes to the default values.

                    job_socket.bound_address := nac$sk_all_ip_addresses;
                    job_socket.owner := current_task_id;
                    job_socket.interface_mode := nac$sk_blocking_mode;
                    job_socket.interface_timeout := nac$sk_default_if_timeout;
                    IF socket_type = nac$sk_udp_socket THEN
                      job_socket.traffic_pattern := nac$sk_udp_random_traffic;
                      job_socket.broadcast_enabled := FALSE;
                      nlp$udp_create_global_socket (global_socket);
                      IF global_socket <> NIL THEN
                        job_socket.global_socket_id := global_socket^.identifier;
                        job_socket.checksum := TRUE;
                        job_socket.local_ip_address_enabled := FALSE;
                        job_socket.user_cache_enabled := TRUE;

{ Initialize global socket. Note job_socket is a local variable.

                        initialize_global_socket (job_socket, global_socket);

                        nlp$udp_free_exclusive_access (global_socket);
                        nlp$tcpip_increment_appl_access (application_name, {assigned} TRUE,
                              job_socket.global_socket_id, nac$null_connection_id, status);
                        IF status.normal THEN
                          nlp$sk_add_job_socket (socket_id, job_socket);
                        ELSE
                          IF status.condition = nae$maximum_sockets_exceeded THEN
                            osp$set_status_condition (nae$sk_max_sockets_limit, status);
                          IFEND;
                          nlp$udp_delete_global_socket (job_socket.global_socket_id);
                          nlp$sk_free_socket_id (socket_id);
                        IFEND;
                      ELSE { global_socket = NIL
                        nlp$sk_free_socket_id (socket_id);
                        osp$set_status_abnormal (nac$status_id, nae$sk_insufficient_resources,
                              'NAP$SK_GET_SOCKET', status);
                      IFEND;
                    ELSEIF socket_type = nac$sk_tcp_socket THEN
                      job_socket.traffic_pattern := nac$sk_tcp_random_traffic;
                      job_socket.tcp_socket_type := nlc$tcp_null_socket;
                      job_socket.connection_id := nac$null_connection_id;
                      job_socket.local_ip_address := 0;
                      job_socket.reuse_address := FALSE;
                      job_socket.graceful_close := TRUE;
                      job_socket.selection_criteria.ip_address := nac$sk_all_ip_addresses;
                      job_socket.selection_criteria.port := 0;
                      nlp$sk_add_job_socket (socket_id, job_socket);
                    IFEND;
                  ELSE { Assigned socket already in use
                    nap$namve_system_error ({Recoverable_error=} TRUE, 'Assigned_socket id already in use.',
                          NIL);
                    osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'GET SOCKET', status);
                  IFEND;
                  nlp$sk_unlock_job_socket (socket_id);
                IFEND;
              ELSE { application_status <> nac$application_active
                osp$set_status_abnormal (nac$status_id, nae$application_inactive, application_name, status);
              IFEND;
            ELSE
              osp$set_status_condition (nae$sk_protocol_mismatch, status);
            IFEND;
          ELSE { Invalid user
            osp$set_status_abnormal (nac$status_id, nae$sk_invalid_user, 'NAP$SK_GET_SOCKET', status);
          IFEND;
        IFEND;
        osp$pop_inhibit_job_recovery;
      IFEND;
    ELSE { Socket layer not active
      osp$set_status_condition (nae$sk_tcpip_host_not_defined, status);
    IFEND;

  PROCEND nap$sk_get_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_get_socket_attributes', EJECT ??
*copy nah$sk_get_socket_attributes

  PROCEDURE [XDCL, #GATE] nap$sk_get_socket_attributes
    (    socket_id: nat$sk_socket_identifier;
     VAR socket_attributes: nat$sk_socket_attributes;
     VAR status: ost$status);

?? NEWTITLE := 'get_optimum_transfer_size', EJECT ??

    PROCEDURE get_optimum_transfer_size
      (    connection_id: nat$connection_id;
       VAR optimum_transfer_unit_size: nat$data_length);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_connection
?? POP ??

      VAR
        cc_connection: ^nlt$cc_connection,
        cl_connection: ^nlt$cl_connection,
        connection_exists: boolean,
        layer_active: boolean;

      nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
      IF cl_connection <> NIL THEN
        nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, layer_active,cc_connection);
        IF cc_connection <> NIL THEN
          optimum_transfer_unit_size := cc_connection^.device_specific_attributes.maximum_data_length -
                nlc$lower_layer_overhead;
        ELSE
          optimum_transfer_unit_size := 0;
        IFEND;
        nlp$cl_release_exclusive_access (cl_connection);
      ELSE
        optimum_transfer_unit_size := 0;
      IFEND;

    PROCEND get_optimum_transfer_size;

?? OLDTITLE ??
?? NEWTITLE := 'terminate_get_attributes', EJECT ??

    PROCEDURE terminate_get_attributes
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        nlp$sk_clear_job_socket_lock (socket_id);
        osp$pop_inhibit_job_recovery;
        osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
        condition_status.normal := TRUE;
        EXIT nap$sk_get_socket_attributes;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;

    PROCEND terminate_get_attributes;
?? OLDTITLE ??
?? EJECT ??

    VAR
      caller_id: ost$caller_identifier,
      i: integer,
      job_socket: ^nat$sk_job_socket,
      optimum_transfer_size: nat$data_length;

    status.normal := TRUE;
    osp$push_inhibit_job_recovery;
    osp$establish_condition_handler (^terminate_get_attributes, FALSE);
    IF socket_id > 0 THEN
      nlp$sk_lock_job_socket (socket_id, job_socket);
      IF job_socket <> NIL THEN
        #CALLER_ID (caller_id);
        IF caller_id.ring <= job_socket^.ring THEN

          /return_socket_attributes/
            FOR i := 1 TO UPPERBOUND (socket_attributes) DO
              CASE socket_attributes [i].attribute_kind OF
              = nac$sk_interface_mode_attr =
                socket_attributes [i].interface_mode := job_socket^.interface_mode;

              = nac$sk_interface_timeout_attr =
                socket_attributes [i].interface_timeout := job_socket^.interface_timeout;

              = nac$sk_checksum_attr =
                IF job_socket^.socket_type = nac$sk_udp_socket THEN
                  socket_attributes [i].checksum := job_socket^.checksum;
                ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
                  osp$set_status_abnormal (nac$status_id, nae$sk_invalid_attribute, 'TCP', status);
                  osp$append_status_integer (osc$status_parameter_delimiter, i, 10, TRUE, status);
                  EXIT /return_socket_attributes/;
                IFEND;

              = nac$sk_traffic_pattern_attr =
                socket_attributes [i].traffic_pattern := job_socket^.traffic_pattern;

              = nac$sk_graceful_close_attr =
                IF job_socket^.socket_type = nac$sk_tcp_socket THEN
                  socket_attributes [i].graceful_close := job_socket^.graceful_close;
                ELSEIF job_socket^.socket_type = nac$sk_udp_socket THEN
                  osp$set_status_abnormal (nac$status_id, nae$sk_invalid_attribute, 'UDP', status);
                  osp$append_status_integer (osc$status_parameter_delimiter, i, 10, TRUE, status);
                  EXIT /return_socket_attributes/;
                IFEND;

              = nac$sk_selection_criteria_attr =
                IF job_socket^.socket_type = nac$sk_tcp_socket THEN
                  socket_attributes [i].port := job_socket^.selection_criteria.port;
                  socket_attributes [i].ip_address := job_socket^.selection_criteria.ip_address;
                ELSEIF job_socket^.socket_type = nac$sk_udp_socket THEN
                  osp$set_status_abnormal (nac$status_id, nae$sk_invalid_attribute, 'UDP', status);
                  osp$append_status_integer (osc$status_parameter_delimiter, i, 10, TRUE, status);
                  EXIT /return_socket_attributes/;
                IFEND;

              = nac$sk_local_addr_enabled_attr =
                IF job_socket^.socket_type = nac$sk_udp_socket THEN
                  socket_attributes [i].local_ip_address_enabled := job_socket^.local_ip_address_enabled;
                ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
                  osp$set_status_abnormal (nac$status_id, nae$sk_invalid_attribute, 'TCP', status);
                  osp$append_status_integer (osc$status_parameter_delimiter, i, 10, TRUE, status);
                  EXIT /return_socket_attributes/;
                IFEND;

              = nac$sk_broadcast_enabled_attr =
                IF job_socket^.socket_type = nac$sk_udp_socket THEN
                  socket_attributes [i].broadcast_enabled := job_socket^.broadcast_enabled;
                ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
                  osp$set_status_abnormal (nac$status_id, nae$sk_invalid_attribute, 'TCP', status);
                  osp$append_status_integer (osc$status_parameter_delimiter, i, 10, TRUE, status);
                  EXIT /return_socket_attributes/;
                IFEND;

              = nac$sk_optimum_xfer_size_attr =
                IF job_socket^.socket_type = nac$sk_tcp_socket THEN
                  IF job_socket^.connection_id <> nac$null_connection_id THEN
                    get_optimum_transfer_size (job_socket^.connection_id, optimum_transfer_size);
                    socket_attributes [i].optimum_transfer_size := optimum_transfer_size;
                  ELSE
                    socket_attributes [i].optimum_transfer_size := 0;
                  IFEND;
                ELSEIF job_socket^.socket_type = nac$sk_udp_socket THEN
                  osp$set_status_abnormal (nac$status_id, nae$sk_invalid_attribute, 'UDP', status);
                  osp$append_status_integer (osc$status_parameter_delimiter, i, 10, TRUE, status);
                  EXIT /return_socket_attributes/;
                IFEND;

              = nac$sk_user_cache_enabled_attr =
                IF job_socket^.socket_type = nac$sk_udp_socket THEN
                  socket_attributes [i].user_cache_enabled := job_socket^.user_cache_enabled;
                ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
                  osp$set_status_abnormal (nac$status_id, nae$sk_invalid_attribute, 'TCP', status);
                  osp$append_status_integer (osc$status_parameter_delimiter, i, 10, TRUE, status);
                  EXIT /return_socket_attributes/;
                IFEND;

              = nac$sk_reuse_address_attr =
                IF job_socket^.socket_type = nac$sk_tcp_socket THEN
                  socket_attributes [i].reuse_address := job_socket^.reuse_address;
                ELSEIF job_socket^.socket_type = nac$sk_udp_socket THEN
                  osp$set_status_abnormal (nac$status_id, nae$sk_invalid_attribute, 'UDP', status);
                  osp$append_status_integer (osc$status_parameter_delimiter, i, 10, TRUE, status);
                  EXIT /return_socket_attributes/;
                IFEND;

              = nac$sk_local_address_attr =
                IF job_socket^.status <> nac$sk_socket_unbound THEN
                  socket_attributes [i].local_port := job_socket^.port;
                  IF job_socket^.bound_address <> nac$sk_all_ip_addresses THEN
                    socket_attributes [i].address_count := 1;
                    socket_attributes [i].local_addresses^ [1] := job_socket^.bound_address;
                  ELSE { socket bound to all known ip addresses
                    IF job_socket^.socket_type = nac$sk_udp_socket THEN
                      nlp$udp_get_bound_addresses (job_socket^.global_socket_id,
                            socket_attributes [i].local_addresses^, socket_attributes [i].address_count,
                            status);
                      IF NOT status.normal THEN
                        IF status.condition = nae$sk_socket_terminated THEN
                          nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                          osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                status);
                        IFEND;
                        EXIT /return_socket_attributes/;
                      IFEND;
                    ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
                      IF job_socket^.tcp_socket_type = nlc$tcp_listen_socket THEN
                        nlp$sk_tcp_get_listen_addresses (job_socket^.application, job_socket^.port,
                              job_socket^.bound_address, socket_attributes [i].local_addresses^,
                              socket_attributes [i].address_count, status);
                        IF NOT status.normal THEN
                          IF status.condition = nae$sk_socket_terminated THEN
                            nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                            osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                  status);
                          IFEND;
                          EXIT /return_socket_attributes/;
                        IFEND;
                      ELSE
                        IF (job_socket^.tcp_socket_type = nlc$tcp_connect_socket) OR
                              (job_socket^.tcp_socket_type = nlc$tcp_accept_socket) THEN

{ A connect or an accept socket may have been bound to all known IP addresses but
{ it is connected over one IP address only.

                          socket_attributes [i].address_count := 1;
                          socket_attributes [i].local_addresses^ [1] := job_socket^.local_ip_address;
                        ELSE { connection not estableshed
                          socket_attributes [i].address_count := 0;

{ This is the case of a TCP socket that has been bound to all IP addresses but
{ the listen has not been done or the connection has not been established i.e.,
{ the connect socket request has not been issued.

                        IFEND;
                      IFEND;
                    IFEND;
                  IFEND;
                ELSE { Socket is unbound.
                  socket_attributes [i].address_count := 0;
                  socket_attributes [i].local_port := 0;
                IFEND;
              ELSE {Invalid socket attribute
                osp$set_status_condition (nae$sk_unknown_attribute, status);
                osp$append_status_integer (osc$status_parameter_delimiter,
                      $INTEGER (socket_attributes [i].attribute_kind), 10, TRUE, status);
                EXIT /return_socket_attributes/;
              CASEND;
            FOREND /return_socket_attributes/;
        ELSE { Invalid user
          osp$set_status_abnormal (nac$status_id, nae$sk_invalid_user, 'NAP$SK_GET_SOCKET_ATTRIBUTES',
                status);
        IFEND;
      ELSE { Unknown socket
        osp$set_status_condition (nae$sk_unknown_socket, status);
        osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
      IFEND;
      nlp$sk_unlock_job_socket (socket_id);
    ELSE { socket_id = 0
      osp$set_status_condition (nae$sk_unknown_socket, status);
      osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
    IFEND;
    osp$pop_inhibit_job_recovery;

  PROCEND nap$sk_get_socket_attributes;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_get_socket_status', EJECT ??

*copy nah$sk_get_socket_status

  PROCEDURE [XDCL, #GATE] nap$sk_get_socket_status
    (    socket_id: nat$sk_socket_identifier;
     VAR socket_status: nat$sk_socket_status;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      job_socket: ^nat$sk_job_socket;

    status.normal := TRUE;
    osp$push_inhibit_job_recovery;
    IF socket_id > 0 THEN
      nlp$sk_lock_job_socket (socket_id, job_socket);
      IF job_socket <> NIL THEN
        #CALLER_ID (caller_id);
        IF caller_id.ring <= job_socket^.ring THEN
          IF job_socket^.status = nac$sk_socket_open THEN
            IF job_socket^.socket_type = nac$sk_udp_socket THEN
              socket_status.connection_pending := FALSE;
              nlp$udp_get_socket_status (job_socket^.global_socket_id, socket_status.clear_to_send,
                    socket_status.data_pending_receive, status);
              IF (NOT status.normal) AND (status.condition = nae$sk_socket_terminated) THEN
                nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
              IFEND;
            ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
              IF job_socket^.tcp_socket_type = nlc$tcp_listen_socket THEN
                nlp$sk_tcp_check_accept_socket (job_socket^.application, job_socket^.port,
                      job_socket^.bound_address, FALSE {wait} , socket_status.connection_pending);
                socket_status.clear_to_send := FALSE;
                socket_status.data_pending_receive := 0;
              ELSEIF job_socket^.tcp_socket_type <> nlc$tcp_null_socket THEN
                socket_status.connection_pending := FALSE;
                nlp$sk_tcp_get_socket_status (job_socket^.connection_id, socket_status.clear_to_send,
                      socket_status.data_pending_receive, status);
                IF NOT status.normal THEN
                  IF status.condition = nae$sk_socket_disconnected THEN
                    nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_disconnected);
                    osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                  ELSEIF status.condition = nae$sk_socket_closed_via_peer THEN
                    nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_closed_via_peer);
                    osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                  ELSEIF status.condition = nae$sk_socket_terminated THEN
                    nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                    osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                  IFEND;
                IFEND;
              ELSE
                socket_status.clear_to_send := FALSE;
                socket_status.data_pending_receive := 0;
                socket_status.connection_pending := FALSE;
              IFEND;
            IFEND;
          ELSEIF job_socket^.status = nac$sk_socket_unbound THEN
            osp$set_status_condition (nae$sk_unbound_socket, status);
            osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
          ELSEIF job_socket^.status = nac$sk_socket_disconnected THEN
            osp$set_status_condition (nae$sk_socket_disconnected, status);
            osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
          ELSEIF job_socket^.status = nac$sk_socket_closed_via_peer THEN
            osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
            osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
          ELSEIF job_socket^.status = nac$sk_socket_terminated THEN
            osp$set_status_condition (nae$sk_socket_terminated, status);
            osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
          ELSEIF job_socket^.status = nac$sk_job_recovery THEN
            osp$set_status_condition (nae$sk_job_recovery, status);
            osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
          IFEND;
        ELSE { Invalid user
          osp$set_status_abnormal (nac$status_id, nae$sk_invalid_user, 'NAP$SK_GET_SOCKET_STATUS', status);
        IFEND;
      ELSE { job_socket = NIL
        osp$set_status_condition (nae$sk_unknown_socket, status);
        osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
      IFEND;

      nlp$sk_unlock_job_socket (socket_id);
    ELSE { socket_id = 0
      osp$set_status_condition (nae$sk_unknown_socket, status);
      osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
    IFEND;
    osp$pop_inhibit_job_recovery;

  PROCEND nap$sk_get_socket_status;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_listen_socket', EJECT ??
*copy nah$sk_listen_socket

  PROCEDURE [XDCL, #GATE] nap$sk_listen_socket
    (    socket_id: nat$sk_socket_identifier;
         queue_limit: nat$sk_listen_queue_limit;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      job_socket: ^nat$sk_job_socket,
      port: nat$sk_port_number;

    status.normal := TRUE;
    osp$push_inhibit_job_recovery;
    IF socket_id > 0 THEN
      nlp$sk_lock_job_socket (socket_id, job_socket);
      IF (job_socket <> NIL) THEN
        #CALLER_ID (caller_id);
        IF caller_id.ring <= job_socket^.ring THEN
          IF job_socket^.socket_type = nac$sk_tcp_socket THEN
            IF job_socket^.status = nac$sk_socket_unbound THEN
              open_tcp_port (job_socket^.bound_address, port, status);
            ELSEIF job_socket^.status = nac$sk_socket_open THEN
              port := job_socket^.port;
              IF job_socket^.tcp_socket_type = nlc$tcp_listen_socket THEN
                osp$set_status_condition (nae$sk_listen_already_active, status);
                osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
              ELSEIF job_socket^.tcp_socket_type <> nlc$tcp_null_socket THEN
                osp$set_status_condition (nae$sk_socket_already_connected, status);
                osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
              IFEND;
            ELSEIF job_socket^.status = nac$sk_socket_terminated THEN
              osp$set_status_condition (nae$sk_socket_terminated, status);
              osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
            ELSEIF job_socket^.status = nac$sk_job_recovery THEN
              osp$set_status_condition (nae$sk_job_recovery, status);
              osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
            IFEND;

            IF status.normal THEN
              mark_listen_port (port, job_socket^.bound_address, status);
              IF status.normal THEN
                nlp$sk_tcp_activate_listen (socket_id, job_socket^.application, port,
                      job_socket^.bound_address, queue_limit, job_socket^.selection_criteria, status);
                IF status.normal THEN
                  IF job_socket^.status = nac$sk_socket_unbound THEN
                    nlp$sk_update_job_socket (socket_id, port, nac$sk_all_ip_addresses, nac$sk_socket_open);
                  IFEND;
                  nlp$sk_update_listen_socket (socket_id, port);
                ELSE
                  IF job_socket^.status = nac$sk_socket_unbound THEN
                    close_tcp_port (nac$sk_all_ip_addresses, port, TRUE);
                  IFEND;
                  IF status.condition = nae$sk_socket_terminated THEN
                    nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                    osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                  IFEND;
                IFEND;
              ELSEIF job_socket^.status = nac$sk_socket_unbound THEN
                close_tcp_port (nac$sk_all_ip_addresses, port, FALSE);
              IFEND;
            IFEND;
          ELSE { Incorrect socket type
            osp$set_status_abnormal (nac$status_id, nae$sk_incorrect_socket_type, 'LISTEN SOCKET', status);
          IFEND;
        ELSE { Invalid user
          osp$set_status_abnormal (nac$status_id, nae$sk_invalid_user, 'NAP$SK_LISTEN SOCKET', status);
        IFEND;
      ELSE { Unknown socket
        osp$set_status_condition (nae$sk_unknown_socket, status);
        osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
      IFEND;

      nlp$sk_unlock_job_socket (socket_id);
    ELSE { socket_id = 0
      osp$set_status_condition (nae$sk_unknown_socket, status);
      osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
    IFEND;
    osp$pop_inhibit_job_recovery;

  PROCEND nap$sk_listen_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_offer_socket', EJECT ??
*copy nah$sk_offer_socket

  PROCEDURE [XDCL, #GATE] nap$sk_offer_socket
    (    socket_id: nat$sk_socket_identifier;
         destination_job: jmt$system_supplied_name;
         wait_time: nat$wait_time;
     VAR status: ost$status);

?? NEWTITLE := 'terminate_offer_socket', EJECT ??

    PROCEDURE terminate_offer_socket
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF job_socket <> NIL THEN
        IF job_socket^.socket_type = nac$sk_udp_socket THEN
          nlp$udp_cancel_socket_offer (job_socket^.global_socket_id, status);
        ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
          nlp$sk_tcp_cancel_socket_offer (job_socket^.connection_id, status);
        IFEND;
        nlp$sk_clear_job_socket_lock (socket_id);
      IFEND;
      osp$pop_inhibit_job_recovery;

    PROCEND terminate_offer_socket;
?? OLDTITLE, EJECT ??

    VAR
      caller_id: ost$caller_identifier,
      connection_id: nat$connection_id,
      current_task_id: ost$global_task_id,
      global_socket_id: nlt$udp_global_socket_id,
      job_socket: ^nat$sk_job_socket,
      offer_accepted: boolean,
      tcp_socket_type: nlt$tcp_socket_type;

    status.normal := TRUE;
    pmp$get_executing_task_gtid (current_task_id);
    job_socket := NIL;
    #SPOIL (job_socket);
    osp$push_inhibit_job_recovery;
    IF socket_id > 0 THEN
      osp$establish_block_exit_hndlr (^terminate_offer_socket);
      nlp$sk_lock_job_socket (socket_id, job_socket);
      #SPOIL (job_socket);
      IF (job_socket <> NIL) THEN
        #CALLER_ID (caller_id);
        IF caller_id.ring <= job_socket^.ring THEN
          IF job_socket^.owner = current_task_id THEN
            IF job_socket^.status = nac$sk_socket_open THEN
              IF job_socket^.socket_type = nac$sk_udp_socket THEN
                connection_id := nac$null_connection_id;
                global_socket_id := job_socket^.global_socket_id;
                nlp$udp_offer_socket (job_socket^.global_socket_id, status);
                IF (NOT status.normal) AND (status.condition = nae$sk_socket_terminated) THEN
                  nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                  osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                IFEND;
              ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
                IF (job_socket^.tcp_socket_type = nlc$tcp_connect_socket) OR
                      (job_socket^.tcp_socket_type = nlc$tcp_accept_socket) THEN
                  connection_id := job_socket^.connection_id;
                  global_socket_id := nlc$udp_null_global_socket_id;
                  tcp_socket_type := job_socket^.tcp_socket_type;
                  nlp$sk_tcp_offer_socket (connection_id, status);
                  IF NOT status.normal THEN
                    IF status.condition = nae$sk_socket_disconnected THEN
                      nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_disconnected);
                    ELSEIF status.condition = nae$sk_socket_closed_via_peer THEN
                      nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_closed_via_peer);
                    ELSEIF status.condition = nae$sk_socket_terminated THEN
                      nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                      osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                    IFEND;
                  IFEND;
                ELSEIF job_socket^.tcp_socket_type = nlc$tcp_listen_socket THEN
                  osp$set_status_condition (nae$sk_listen_already_active, status);
                  osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                ELSEIF job_socket^.tcp_socket_type = nlc$tcp_null_socket THEN
                  osp$set_status_condition (nae$sk_socket_not_connected, status);
                  osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                IFEND;
              IFEND;
              IF status.normal THEN
                nlp$sk_offer_socket (socket_id, destination_job, job_socket^.socket_type, global_socket_id,
                      connection_id, tcp_socket_type, job_socket^.port, job_socket^.bound_address,
                      job_socket^.traffic_pattern, job_socket^.application, job_socket^.ring,
                      job_socket^.capability, wait_time, offer_accepted);
                IF offer_accepted THEN

{ The global socket or the TCP connection have been switched to the destination job.

                  nlp$sk_delete_job_socket (socket_id, job_socket);
                  nlp$sk_free_socket_id (socket_id);
                ELSE { NOT offer_accepted
                  IF job_socket^.socket_type = nac$sk_udp_socket THEN
                    nlp$udp_cancel_socket_offer (job_socket^.global_socket_id, status);
                    IF (NOT status.normal) AND (status.condition = nae$sk_socket_terminated) THEN
                      nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                      osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                    IFEND;
                  ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
                    nlp$sk_tcp_cancel_socket_offer (job_socket^.connection_id, status);
                    IF NOT status.normal THEN
                      IF status.condition = nae$sk_socket_disconnected THEN
                        nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_disconnected);
                      ELSEIF status.condition = nae$sk_socket_closed_via_peer THEN
                        nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_closed_via_peer);
                      ELSEIF status.condition = nae$sk_socket_terminated THEN
                        nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                        osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                              status);
                      IFEND;
                    IFEND;
                  IFEND;
                  IF status.normal THEN
                    osp$set_status_abnormal (nac$status_id, nae$sk_offer_not_accepted, destination_job,
                          status);
                  IFEND;
                IFEND;
              IFEND;
            ELSEIF job_socket^.status = nac$sk_socket_unbound THEN
              osp$set_status_condition (nae$sk_unbound_socket, status);
              osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
            ELSEIF job_socket^.status = nac$sk_socket_disconnected THEN
              osp$set_status_condition (nae$sk_socket_disconnected, status);
              osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
            ELSEIF job_socket^.status = nac$sk_socket_closed_via_peer THEN
              osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
              osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
            ELSEIF job_socket^.status = nac$sk_socket_terminated THEN
              osp$set_status_condition (nae$sk_socket_terminated, status);
              osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
            ELSEIF job_socket^.status = nac$sk_job_recovery THEN
              osp$set_status_condition (nae$sk_job_recovery, status);
              osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
            IFEND;
          ELSE { job_socket^.owner <> current_task_id
            osp$set_status_abnormal (nac$status_id, nae$sk_caller_not_the_owner, 'OFFER SOCKET', status);
          IFEND;
        ELSE { invalid user
          osp$set_status_abnormal (nac$status_id, nae$sk_invalid_user, 'NAP$SK_OFFER_SOCKET', status);
          osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
        IFEND;
      ELSE { unknown socket
        osp$set_status_condition (nae$sk_unknown_socket, status);
        osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
      IFEND;
      nlp$sk_unlock_job_socket (socket_id);
      osp$disestablish_cond_handler;
    ELSE { socket_id = 0
      osp$set_status_condition (nae$sk_unknown_socket, status);
      osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
    IFEND;
    osp$pop_inhibit_job_recovery;

  PROCEND nap$sk_offer_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nap$sk_process_job_termination', EJECT ??
*copy nah$sk_process_job_termination

  PROCEDURE [XDCL] nap$sk_process_job_termination;

    VAR
      ignore_status: ost$status,
      job_socket: ^nat$sk_job_socket,
      socket_id: nat$sk_socket_identifier;

{ The nav$sk_job_socket_assignment is not locked as no other task must be active
{ in this job when this procedure is invoked.

    osp$push_inhibit_job_recovery;
    IF nav$sk_job_socket_assignment.assigned_sockets <> NIL THEN
      FOR socket_id := 1 TO UPPERBOUND (nav$sk_job_socket_assignment.assigned_sockets^) DO
        IF nav$sk_job_socket_assignment.assigned_sockets^ [socket_id] THEN
          job_socket := nav$sk_job_socket_list^ [socket_id].job_socket;
          IF job_socket <> NIL THEN
            close_socket (job_socket, ignore_status);
          IFEND;
        IFEND;
      FOREND;
    IFEND;
    osp$pop_inhibit_job_recovery;

  PROCEND nap$sk_process_job_termination;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_read_socket', EJECT ??
*copy nah$sk_read_socket

  PROCEDURE [XDCL, #GATE] nap$sk_read_socket
    (    socket_id: nat$sk_socket_identifier;
     VAR urgent_flag: boolean;
         data { input, output} : nat$data_fragments;
     VAR data_transferred: integer;
     VAR status: ost$status);

?? NEWTITLE := 'terminate_read_socket', EJECT ??

    PROCEDURE terminate_read_socket
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF cl_connection <> NIL THEN
          nlp$cl_clear_exclusive_access (cl_connection);
        IFEND;
        IF job_socket <> NIL THEN
          nlp$sk_clear_job_socket_lock (socket_id);
        IFEND;
        osp$pop_inhibit_job_recovery;
        osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
        condition_status.normal := TRUE;
        EXIT nap$sk_read_socket;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      = pmc$block_exit_processing =
        nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
        IF cl_connection <> NIL THEN
          nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active, tcp_connection);
          IF layer_active THEN

{ Dequeue the receiver task from the receive queue.

            previous_receiver_task := ^tcp_connection^.receive_queue;
            receiver_task := tcp_connection^.receive_queue;
            WHILE (receiver_task <> NIL) AND (receiver_task^.task_id <> current_task_id) DO
              previous_receiver_task := ^receiver_task^.next_entry;
              receiver_task := receiver_task^.next_entry;
            WHILEND;
            IF receiver_task <> NIL THEN
              IF receiver_task^.received_data_length^ > 0 THEN
                data_transferred := receiver_task^.received_data_length^;
                urgent_flag := receiver_task^.urgent_flag^;
              ELSE
                osp$set_status_condition (nae$sk_no_data_available, status);
                osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
              IFEND;
              previous_receiver_task^ := receiver_task^.next_entry;
              nlp$sk_tcp_ret_rec_task_entry (tcp_connection, receiver_task);
            IFEND;
          IFEND;
          nlp$cl_release_exclusive_access (cl_connection);
        IFEND;
        osp$pop_inhibit_job_recovery;
        condition_status.normal := TRUE;
      ELSE

{ Note: Interactive condition is being ignored.

        condition_status.normal := TRUE;
      CASEND;

    PROCEND terminate_read_socket;
?? OLDTITLE ??
?? EJECT ??

    VAR
      activity_status: ost$activity_status,
      buffer_capacity: nat$data_length,
      buffers_freed: nat$data_length,
      caller_id: ost$caller_identifier,
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      connection_id: nat$connection_id,
      current_task_id: ost$global_task_id,
      current_time: ost$free_running_clock,
      data_area: ^nat$data_fragments,
      delivered_data_length: integer,
      end_time: integer,
      ignore_status: ost$status,
      interface_mode: nat$sk_interface_mode,
      interface_timeout: nat$wait_time,
      job_socket: ^nat$sk_job_socket,
      layer_active: boolean,
      previous_receiver_task: ^^nlt$tcp_receiver_task,
      received_data: ^nlt$tcp_received_data,
      received_data_length: integer,
      receiver_active: boolean,
      receiver_task: ^nlt$tcp_receiver_task,
      remaining_capacity: integer,
      remaining_time: integer,
      tcp_connection: ^nlt$tcp_socket_layer,
      urgent: boolean;

    status.normal := TRUE;
    data_transferred := 0;
    received_data_length := 0;
    urgent := FALSE;
    receiver_active := FALSE;
    cl_connection := NIL;
    #SPOIL (cl_connection);
    pmp$get_executing_task_gtid (current_task_id);
    #SPOIL (current_task_id);
    osp$push_inhibit_job_recovery;
    osp$establish_condition_handler (^terminate_read_socket, TRUE);
    IF socket_id > 0 THEN
      nlp$sk_lock_job_socket (socket_id, job_socket);
      #SPOIL (job_socket);
      IF (job_socket <> NIL) THEN
        #CALLER_ID (caller_id);
        IF caller_id.ring <= job_socket^.ring THEN
          IF job_socket^.socket_type = nac$sk_tcp_socket THEN
            IF job_socket^.status = nac$sk_socket_open THEN
              IF job_socket^.connection_id <> nac$null_connection_id THEN
                connection_id := job_socket^.connection_id;
                #SPOIL (connection_id);
                interface_mode := job_socket^.interface_mode;
                interface_timeout := job_socket^.interface_timeout;
                activity_status.complete := FALSE;
                activity_status.status.normal := TRUE;
                #SPOIL (activity_status);

{ Access the channel connection.

                nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
                #SPOIL (cl_connection);
                IF cl_connection <> NIL THEN
                  nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active,
                        tcp_connection);
                  IF layer_active THEN
                    IF tcp_connection^.state = nlc$tcp_conn_open THEN
                      PUSH data_area: [1 .. UPPERBOUND (data)];
                      data_area^ := data;
                      nlp$al_get_data_length (data_area^, buffer_capacity);
                      IF buffer_capacity > 0 THEN
                        IF tcp_connection^.receive_queue = NIL THEN
                          IF tcp_connection^.received_data <> NIL THEN

{ There is data queued, ready to be received.

                            received_data := tcp_connection^.received_data;
                            nlp$bm_deliver_message (data_area^, received_data^.message_id, data_transferred,
                                  buffers_freed);
                            remaining_capacity := buffer_capacity - data_transferred;
                            tcp_connection^.inventory_report := tcp_connection^.inventory_report -
                                  buffers_freed;
                            nlp$cc_report_undelivered_data (cl_connection, tcp_connection^.inventory_report);
                            urgent_flag := received_data^.urgent_flag;
                            IF (remaining_capacity = 0) OR (received_data^.urgent_flag) OR
                                  (received_data^.push_flag) THEN
                              activity_status.complete := TRUE;
                              IF received_data^.message_id = nlv$bm_null_message_id THEN
                                tcp_connection^.received_data := received_data^.next_entry;
                                nlp$sk_tcp_ret_rec_data_entry (tcp_connection, received_data);
                              ELSE
                                received_data^.length := received_data^.length - data_transferred;
                                received_data^.buffer_count := received_data^.buffer_count - buffers_freed;
                              IFEND;
                            ELSE { user's buffer can hold more data
                              tcp_connection^.received_data := received_data^.next_entry;
                              nlp$sk_tcp_ret_rec_data_entry (tcp_connection, received_data);
                              received_data_length := data_transferred;
                              IF interface_mode = nac$sk_blocking_mode THEN
                                nlp$sk_tcp_get_rec_task_entry (tcp_connection, receiver_task);
                                receiver_task^.next_entry := NIL;
                                receiver_task^.task_id := current_task_id;
                                receiver_task^.receive_type := nlc$tcp_receive_data;
                                receiver_task^.data_buffer := data_area;
                                receiver_task^.remaining_buffer_capacity := remaining_capacity;
                                receiver_task^.received_data_length := ^received_data_length;
                                receiver_task^.urgent_flag := ^urgent;
                                receiver_task^.activity_status := ^activity_status;

{ Queue the receiver task on the receive queue.

                                tcp_connection^.receive_queue := receiver_task;
                                nlp$cl_activate_receiver (cl_connection);
                                receiver_active := TRUE;
                              ELSE { Non-blocking mode
                                activity_status.complete := TRUE;
                              IFEND;
                            IFEND;
                          ELSE { tcp_connection^.received_data = NIL
                            IF interface_mode = nac$sk_blocking_mode THEN
                              nlp$sk_tcp_get_rec_task_entry (tcp_connection, receiver_task);
                              receiver_task^.next_entry := NIL;
                              receiver_task^.task_id := current_task_id;
                              receiver_task^.receive_type := nlc$tcp_receive_data;
                              receiver_task^.data_buffer := data_area;
                              receiver_task^.remaining_buffer_capacity := buffer_capacity;
                              receiver_task^.received_data_length := ^received_data_length;
                              receiver_task^.urgent_flag := ^urgent;
                              receiver_task^.activity_status := ^activity_status;

{ Queue the receiver task on the receive queue.

                              tcp_connection^.receive_queue := receiver_task;
                              nlp$cl_activate_receiver (cl_connection);
                              receiver_active := TRUE;
                            ELSE { Non-blocking mode
                              osp$set_status_condition (nae$sk_no_data_available, status);
                              osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                    status);
                            IFEND;
                          IFEND;
                          IF status.normal AND NOT activity_status.complete THEN
                            nlp$cc_receive_data (cl_connection);
                            IF activity_status.complete THEN
                              data_transferred := received_data_length;
                              urgent_flag := urgent;
                            IFEND;
                          IFEND;
                        ELSE { Receive_queue <> NIL
                          IF interface_mode = nac$sk_blocking_mode THEN
                            nlp$sk_tcp_get_rec_task_entry (tcp_connection, receiver_task);
                            receiver_task^.next_entry := NIL;
                            receiver_task^.task_id := current_task_id;
                            receiver_task^.receive_type := nlc$tcp_receive_data;
                            receiver_task^.data_buffer := data_area;
                            receiver_task^.remaining_buffer_capacity := buffer_capacity;
                            receiver_task^.received_data_length := ^received_data_length;
                            receiver_task^.urgent_flag := ^urgent;
                            receiver_task^.activity_status := ^activity_status;

{ Queue the receiver task at the end of the receive queue.

                            previous_receiver_task := ^tcp_connection^.receive_queue;
                            WHILE previous_receiver_task^ <> NIL DO
                              previous_receiver_task := ^previous_receiver_task^^.next_entry;
                            WHILEND;
                            previous_receiver_task^ := receiver_task;
                          ELSE { Non-blocking mode
                            osp$set_status_condition (nae$sk_read_in_progress, status);
                            osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                  status);
                          IFEND;
                        IFEND;
                      ELSE { buffer_capacity = 0
                        osp$set_status_condition (nae$sk_data_area_too_small, status);
                      IFEND;
                    ELSEIF tcp_connection^.state = nlc$tcp_conn_closing THEN
                      PUSH data_area: [1 .. UPPERBOUND (data)];
                      data_area^ := data;
                      nlp$al_get_data_length (data_area^, buffer_capacity);
                      IF buffer_capacity > 0 THEN
                        IF tcp_connection^.receive_queue = NIL THEN
                          IF tcp_connection^.received_data <> NIL THEN

{ There is queued data ready to be received.

                            received_data := tcp_connection^.received_data;
                            nlp$bm_deliver_message (data_area^, received_data^.message_id, data_transferred,
                                  buffers_freed);
                            tcp_connection^.inventory_report := tcp_connection^.inventory_report -
                                  buffers_freed;
                            urgent_flag := received_data^.urgent_flag;
                            IF received_data^.message_id = nlv$bm_null_message_id THEN
                              tcp_connection^.received_data := received_data^.next_entry;
                              FREE received_data IN nav$network_paged_heap^;

{ If all data has been delivered, update the connection state.

                              IF tcp_connection^.received_data = NIL THEN
                                tcp_connection^.state := nlc$tcp_conn_closed;
                                IF tcp_connection^.disconnect_reason = nlc$tcpaa_ri_user_termination THEN
                                  nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_closed_via_peer);
                                ELSE
                                  nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_disconnected);
                                IFEND;

{  Do not return an abnormal status yet.

                                IF tcp_connection^.send_queue = NIL THEN
                                  nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
                                IFEND;
                              IFEND;
                            ELSE { more data queued
                              received_data^.length := received_data^.length - data_transferred;
                            IFEND;
                          ELSE { received_data = NIL
                            tcp_connection^.state := nlc$tcp_conn_closed;
                            IF tcp_connection^.disconnect_reason = nlc$tcpaa_ri_user_termination THEN
                              osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
                              nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_closed_via_peer);
                            ELSE
                              osp$set_status_condition (nae$sk_socket_disconnected, status);
                              nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_disconnected);
                            IFEND;
                            osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                  status);
                            IF tcp_connection^.send_queue = NIL THEN
                              nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
                            IFEND;
                          IFEND;
                        ELSE { receive_queue <> NIL
                          IF tcp_connection^.disconnect_reason = nlc$tcpaa_ri_user_termination THEN
                            osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
                          ELSE
                            osp$set_status_condition (nae$sk_socket_disconnected, status);
                          IFEND;
                          osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                status);
                        IFEND;
                      ELSE { buffer_capacity = 0
                        osp$set_status_condition (nae$sk_data_area_too_small, status);
                      IFEND;
                      activity_status.complete := TRUE;
                    ELSEIF tcp_connection^.state = nlc$tcp_conn_closed THEN
                      IF tcp_connection^.disconnect_reason = nlc$tcpaa_ri_user_termination THEN
                        osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
                        nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_closed_via_peer);
                      ELSE
                        osp$set_status_condition (nae$sk_socket_disconnected, status);
                        nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_disconnected);
                      IFEND;
                      osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                      IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
                        nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
                      IFEND;
                    ELSEIF tcp_connection^.state = nlc$tcp_conn_terminated THEN
                      osp$set_status_condition (nae$sk_socket_terminated, status);
                      osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                      IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
                        nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
                      IFEND;
                      nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                    ELSE { All other states
                      nap$namve_system_error ({Recoverable_error=} TRUE, 'Unexpected TCP connection state',
                            NIL);
                      osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'READ SOCKET', status);
                    IFEND;
                  ELSE { Layer inactive

{ The socket is assumed to have been terminated via application management.

                    nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                    osp$set_status_condition (nae$sk_socket_terminated, status);
                    osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                  IFEND;
                  nlp$cl_release_exclusive_access (cl_connection);
                  cl_connection := NIL;
                ELSE { cl_connection = NIL

{ The socket is assumed to have been terminated via application management.

                  nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                  osp$set_status_condition (nae$sk_socket_terminated, status);
                  osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                IFEND;

                nlp$sk_unlock_job_socket (socket_id);
                job_socket := NIL;
                #SPOIL (job_socket);

                IF status.normal AND NOT activity_status.complete THEN
                  end_time := #FREE_RUNNING_CLOCK (0) + interface_timeout * 1000;
                  remaining_time := interface_timeout;
                  REPEAT
                    pmp$wait (remaining_time, 0);
                    current_time := #FREE_RUNNING_CLOCK (0);
                    IF current_time < end_time THEN
                      remaining_time := (end_time - current_time) DIV 1000;
                    ELSE
                      remaining_time := 0;
                    IFEND;

                    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
                    #SPOIL (cl_connection);
                    IF cl_connection <> NIL THEN
                      nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active,
                            tcp_connection);
                      IF layer_active THEN
                        IF tcp_connection^.state = nlc$tcp_conn_open THEN
                          IF tcp_connection^.receive_queue^.task_id = current_task_id THEN
                            receiver_task := tcp_connection^.receive_queue;

{ The current task is at the head of the queue and hence can receive data.

                            IF NOT receiver_active THEN
                              nlp$cl_activate_receiver (cl_connection);
                              receiver_active := TRUE;
                            IFEND;

                            IF tcp_connection^.received_data <> NIL THEN
                              received_data := tcp_connection^.received_data;
                              nlp$bm_deliver_message (data_area^, received_data^.message_id,
                                    delivered_data_length, buffers_freed);
                              received_data_length := received_data_length + delivered_data_length;
                              urgent := received_data^.urgent_flag;
                              receiver_task^.remaining_buffer_capacity :=
                                    receiver_task^.remaining_buffer_capacity - delivered_data_length;
                              received_data^.length := received_data^.length - delivered_data_length;
                              received_data^.buffer_count := received_data^.buffer_count - buffers_freed;

                              tcp_connection^.inventory_report := tcp_connection^.inventory_report -
                                    buffers_freed;
                              nlp$cc_report_undelivered_data (cl_connection,
                                    tcp_connection^.inventory_report);

                              IF (receiver_task^.remaining_buffer_capacity = 0) OR
                                    (received_data^.push_flag) OR (received_data^.urgent_flag) OR
                                    (remaining_time = 0) THEN

{ Receive is complete, dequeue receiver task.

                                tcp_connection^.receive_queue := receiver_task^.next_entry;
                                activity_status.complete := TRUE;
                                data_transferred := received_data_length;
                                urgent_flag := urgent;
                                nlp$sk_tcp_ret_rec_task_entry (tcp_connection, receiver_task);
                                nlp$cl_deactivate_receiver (cl_connection);

{ Ready the next task in the receive queue.

                                IF tcp_connection^.receive_queue <> NIL THEN
                                  pmp$ready_task (tcp_connection^.receive_queue^.task_id, {ignore} status);
                                 status.normal := TRUE;
                               IFEND;
                             IFEND;
                             IF received_data^.message_id = nlv$bm_null_message_id THEN
                               tcp_connection^.received_data := received_data^.next_entry;
                               nlp$sk_tcp_ret_rec_data_entry (tcp_connection, received_data);
                             IFEND;
                           IFEND;
                           IF NOT activity_status.complete THEN
                             nlp$cc_receive_data (cl_connection);
                             IF activity_status.complete THEN
                               IF activity_status.status.normal THEN
                                 data_transferred := received_data_length;
                                 urgent_flag := urgent;
                               ELSE
                                 status := activity_status.status;
                                 data_transferred := 0;
                               IFEND;
                             IFEND;
                           IFEND;
                           IF (NOT activity_status.complete) AND (remaining_time = 0) THEN
                             activity_status.complete := TRUE;
                             tcp_connection^.receive_queue := receiver_task^.next_entry;
                             IF received_data_length > 0 THEN
                               data_transferred := received_data_length;
                               urgent_flag := urgent;
                             ELSE
                               osp$set_status_condition (nae$sk_interface_timeout, status);
                               osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                     status);
                             IFEND;
                             nlp$sk_tcp_ret_rec_task_entry (tcp_connection, receiver_task);
                             nlp$cl_deactivate_receiver (cl_connection);
                             IF tcp_connection^.receive_queue <> NIL THEN
                               pmp$ready_task (tcp_connection^.receive_queue^.task_id, ignore_status);
                             IFEND;
                           IFEND;
                         ELSE { task not at the head of the queue
                           IF remaining_time = 0 THEN

{ Dequeue the receiver task.

                             previous_receiver_task := ^tcp_connection^.receive_queue;
                             receiver_task := tcp_connection^.receive_queue;
                             WHILE (receiver_task <> NIL) AND (receiver_task^.task_id <> current_task_id) DO
                               previous_receiver_task := ^receiver_task^.next_entry;
                               receiver_task := receiver_task^.next_entry;
                             WHILEND;
                             IF receiver_task <> NIL THEN
                               previous_receiver_task^ := receiver_task^.next_entry;
                               nlp$sk_tcp_ret_rec_task_entry (tcp_connection, receiver_task);
                               osp$set_status_condition (nae$sk_interface_timeout, status);
                               osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                     status);
                             IFEND;
                           IFEND;
                         IFEND;
                       ELSEIF tcp_connection^.state = nlc$tcp_conn_closing THEN
                         IF tcp_connection^.receive_queue^.task_id = current_task_id THEN

{ Current task is at the head of the queue.

                           receiver_task := tcp_connection^.receive_queue;
                           IF tcp_connection^.received_data <> NIL THEN

{ There is queued data ready to be received.

                             received_data := tcp_connection^.received_data;
                             nlp$bm_deliver_message (data_area^, received_data^.message_id,
                                   delivered_data_length, buffers_freed);
                             tcp_connection^.inventory_report := tcp_connection^.inventory_report -
                                   buffers_freed;
                             urgent_flag := received_data^.urgent_flag;
                             received_data_length := received_data_length + delivered_data_length;
                             IF received_data^.message_id = nlv$bm_null_message_id THEN
                               tcp_connection^.received_data := received_data^.next_entry;
                               FREE received_data IN nav$network_paged_heap^;

{ If all data has been delivered, update the connection state.

                               IF tcp_connection^.received_data = NIL THEN
                                 tcp_connection^.state := nlc$tcp_conn_closed;

{ Do not deactivate the layer yet. The next user call will update the job socket status.
{  Do not return an abnormal status yet.

                               IFEND;
                             ELSE { more data queued
                               received_data^.length := received_data^.length - data_transferred;
                               received_data^.buffer_count := received_data^.buffer_count - buffers_freed;
                             IFEND;
                           ELSE { received_data = NIL
                             tcp_connection^.state := nlc$tcp_conn_closed;
                             urgent_flag := urgent;
                             IF received_data_length = 0 THEN
                               IF tcp_connection^.disconnect_reason = nlc$tcpaa_ri_user_termination THEN
                                 osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
                               ELSE
                                 osp$set_status_condition (nae$sk_socket_disconnected, status);
                               IFEND;
                               osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                     status);
                             IFEND;
                           IFEND;

{ Dequeue and return the receiver task.

                           data_transferred := received_data_length;
                           tcp_connection^.receive_queue := receiver_task^.next_entry;
                           FREE receiver_task IN nav$network_paged_heap^;
                         ELSE { current task is not at the head of the queue.
                           previous_receiver_task := ^tcp_connection^.receive_queue;
                           receiver_task := tcp_connection^.receive_queue;
                           WHILE (receiver_task <> NIL) AND (receiver_task^.task_id <> current_task_id) DO
                             previous_receiver_task := ^receiver_task^.next_entry;
                             receiver_task := receiver_task^.next_entry;
                           WHILEND;
                           IF receiver_task <> NIL THEN
                             previous_receiver_task^ := receiver_task^.next_entry;
                             FREE receiver_task IN nav$network_paged_heap^;
                           IFEND;
                           IF tcp_connection^.disconnect_reason = nlc$tcpaa_ri_user_termination THEN
                             osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
                           ELSE
                             osp$set_status_condition (nae$sk_socket_disconnected, status);
                           IFEND;
                           osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                 status);
                         IFEND;
                         activity_status.complete := TRUE;
                       ELSE { connection closed or terminated

{ Dequeue the receiver task from the receive queue.

                         activity_status.complete := TRUE;
                         previous_receiver_task := ^tcp_connection^.receive_queue;
                         receiver_task := tcp_connection^.receive_queue;
                         WHILE (receiver_task <> NIL) AND (receiver_task^.task_id <> current_task_id) DO
                           previous_receiver_task := ^receiver_task^.next_entry;
                           receiver_task := receiver_task^.next_entry;
                         WHILEND;
                         IF receiver_task <> NIL THEN
                           previous_receiver_task^ := receiver_task^.next_entry;
                           data_transferred := received_data_length;
                           urgent_flag := urgent;
                           FREE receiver_task IN nav$network_paged_heap^;
                         IFEND;

{ Check if the socket has been closed in the meantime.

                         IF (tcp_connection^.state = nlc$tcp_conn_closed) THEN
                           IF tcp_connection^.user_initiated_close THEN
                             IF (tcp_connection^.send_queue = NIL) AND
                                   (tcp_connection^.receive_queue = NIL) THEN
                               nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
                             IFEND;
                             IF data_transferred = 0 THEN
                               osp$set_status_condition (nae$sk_unknown_socket, status);
                               osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                     status);
                             IFEND;
                           ELSEIF data_transferred = 0 THEN
                             IF tcp_connection^.disconnect_reason = nlc$tcpaa_ri_user_termination THEN
                               osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
                             ELSE
                               osp$set_status_condition (nae$sk_socket_disconnected, status);
                             IFEND;
                             osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                   status);
                           IFEND;
                         ELSEIF tcp_connection^.state = nlc$tcp_conn_terminated THEN
                           IF data_transferred = 0 THEN
                             osp$set_status_condition (nae$sk_socket_terminated, status);
                             osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                   status);
                             IF (tcp_connection^.send_queue = NIL) AND
                                   (tcp_connection^.receive_queue = NIL) THEN
                               nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
                             IFEND;
                           IFEND;
                         IFEND;
                       IFEND;
                     ELSE { Layer inactive
                       nap$namve_system_error ({Recoverable_error=} TRUE, 'TCP layer connection inactive',
                             NIL);
                       osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'READ SOCKET', status);
                     IFEND;
                     nlp$cl_release_exclusive_access (cl_connection);
                     cl_connection := NIL;
                   ELSE { cl_connection = NIL
                     nap$namve_system_error ({Recoverable_error=} TRUE, 'CL connection NIL', NIL);
                     osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'READ SOCKET', status);
                   IFEND;
                 UNTIL activity_status.complete OR NOT status.normal;
               IFEND;
             ELSE
               nlp$sk_unlock_job_socket (socket_id);
               IF job_socket^.tcp_socket_type = nlc$tcp_listen_socket THEN
                 osp$set_status_condition (nae$sk_listen_already_active, status);
               ELSE { job_socket^.connection_id = nac$null_connection_id
                 osp$set_status_condition (nae$sk_socket_not_connected, status);
               IFEND;
               osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
             IFEND;
           ELSE
             nlp$sk_unlock_job_socket (socket_id);
             IF job_socket^.status = nac$sk_socket_unbound THEN
               osp$set_status_condition (nae$sk_unbound_socket, status);
             ELSEIF job_socket^.status = nac$sk_socket_disconnected THEN
               osp$set_status_condition (nae$sk_socket_disconnected, status);
             ELSEIF job_socket^.status = nac$sk_socket_closed_via_peer THEN
               osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
             ELSEIF job_socket^.status = nac$sk_socket_terminated THEN
               osp$set_status_condition (nae$sk_socket_terminated, status);
             ELSEIF job_socket^.status = nac$sk_job_recovery THEN
               osp$set_status_condition (nae$sk_job_recovery, status);
             IFEND;
             osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
           IFEND;
         ELSE { Incorrect socket type
           nlp$sk_unlock_job_socket (socket_id);
           osp$set_status_abnormal (nac$status_id, nae$sk_incorrect_socket_type, 'READ SOCKET', status);
         IFEND;
       ELSE { Invalid user
         nlp$sk_unlock_job_socket (socket_id);
         osp$set_status_abnormal (nac$status_id, nae$sk_invalid_user, 'NAP$SK_READ_SOCKET', status);
       IFEND;
     ELSE { Unknown socket
       nlp$sk_unlock_job_socket (socket_id);
       osp$set_status_condition (nae$sk_unknown_socket, status);
       osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
     IFEND;
   ELSE { socket_id = 0
     osp$set_status_condition (nae$sk_unknown_socket, status);
     osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
   IFEND;
   osp$disestablish_cond_handler;
   osp$pop_inhibit_job_recovery;

 PROCEND nap$sk_read_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_receive_from_socket', EJECT ??
*copy nah$sk_receive_from_socket

 PROCEDURE [XDCL, #GATE] nap$sk_receive_from_socket
   (    socket_id: nat$sk_socket_identifier;
        selection_criteria: ^nat$sk_socket_address;
    VAR foreign_socket: nat$sk_socket_address;
    VAR local_ip_address: ^nat$sk_ip_address;
        data { input, output } : nat$data_fragments;
    VAR data_length: integer;
    VAR status: ost$status);

   VAR
     caller_id: ost$caller_identifier,
     global_socket_id: nlt$udp_global_socket_id,
     interface_mode: nat$sk_interface_mode,
     interface_timeout: nat$wait_time,
     job_socket: ^nat$sk_job_socket,
     local_address: nat$sk_ip_address,
     local_ip_address_enabled: boolean,
     time_stamp: ost$free_running_clock,
     user_cache_enabled: boolean,
     user_selection_criteria: nat$sk_socket_address;

   status.normal := TRUE;
   osp$push_inhibit_job_recovery;
   IF socket_id > 0 THEN
     nlp$sk_lock_job_socket (socket_id, job_socket);
     IF job_socket <> NIL THEN
       #CALLER_ID (caller_id);
       IF caller_id.ring <= job_socket^.ring THEN
         IF job_socket^.socket_type = nac$sk_udp_socket THEN
           IF job_socket^.status = nac$sk_socket_open THEN
             interface_mode := job_socket^.interface_mode;
             IF interface_mode = nac$sk_blocking_mode THEN
               interface_timeout := job_socket^.interface_timeout;
             ELSE
               interface_timeout := 0;
             IFEND;
             global_socket_id := job_socket^.global_socket_id;
             local_ip_address_enabled := job_socket^.local_ip_address_enabled;
             user_cache_enabled := job_socket^.user_cache_enabled;
             time_stamp := job_socket^.time_stamp;
             nlp$sk_unlock_job_socket (socket_id);
             IF selection_criteria <> NIL THEN
               user_selection_criteria := selection_criteria^;
             ELSE
               user_selection_criteria.ip_address := nac$sk_all_ip_addresses;
               user_selection_criteria.port := 0;
             IFEND;

             nlp$udp_receive_data (global_socket_id, time_stamp, user_selection_criteria, user_cache_enabled,
                   interface_mode, interface_timeout, data, foreign_socket, local_address, data_length,
                   status);
             IF status.normal THEN
               IF local_ip_address_enabled AND (local_ip_address <> NIL) THEN
                 local_ip_address^ := local_address;
               IFEND;
             ELSEIF status.condition = nae$sk_socket_terminated THEN
               nlp$sk_lock_job_socket (socket_id, job_socket);
               IF (job_socket <> NIL) AND (job_socket^.time_stamp = time_stamp) THEN
                 nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
               IFEND;
               nlp$sk_unlock_job_socket (socket_id);
               osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
             ELSEIF status.condition = nae$sk_unknown_socket THEN
               osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
             IFEND;
           ELSE
             nlp$sk_unlock_job_socket (socket_id);
             IF job_socket^.status = nac$sk_socket_unbound THEN
               osp$set_status_condition (nae$sk_unbound_socket, status);
             ELSEIF job_socket^.status = nac$sk_socket_terminated THEN
               osp$set_status_condition (nae$sk_socket_terminated, status);
             ELSEIF job_socket^.status = nac$sk_job_recovery THEN
               osp$set_status_condition (nae$sk_job_recovery, status);
             IFEND;
             osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
           IFEND;
         ELSE { Incorrect socket type
           nlp$sk_unlock_job_socket (socket_id);
           osp$set_status_abnormal (nac$status_id, nae$sk_incorrect_socket_type, 'RECEIVE FROM SOCKET',
                 status);
         IFEND;
       ELSE { Invalid user
         nlp$sk_unlock_job_socket (socket_id);
         osp$set_status_abnormal (nac$status_id, nae$sk_invalid_user, 'NAP$SK_RECEIVE_FROM_SOCKET', status);
       IFEND;
     ELSE { Unknown socket id
       nlp$sk_unlock_job_socket (socket_id);
       osp$set_status_condition (nae$sk_unknown_socket, status);
       osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
     IFEND;
   ELSE { socket_id = 0
     osp$set_status_condition (nae$sk_unknown_socket, status);
     osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
   IFEND;
   osp$pop_inhibit_job_recovery;

 PROCEND nap$sk_receive_from_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_send_to_socket', EJECT ??
*copy nah$sk_send_to_socket

 PROCEDURE [XDCL, #GATE] nap$sk_send_to_socket
   (    socket_id: nat$sk_socket_identifier;
        local_ip_address: ^nat$sk_ip_address;
        destination_socket: nat$sk_socket_address;
        data: nat$data_fragments;
    VAR status: ost$status);

?? NEWTITLE := 'terminate_send_to_socket', EJECT ??

   PROCEDURE terminate_send_to_socket
     (    condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

     CASE condition.selector OF
     = pmc$system_conditions, mmc$segment_access_condition =
       nlp$sk_clear_job_socket_lock (socket_id);
       osp$pop_inhibit_job_recovery;
       osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
       condition_status.normal := TRUE;
       EXIT nap$sk_send_to_socket;
     = pmc$user_defined_condition =
       IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
         pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
       IFEND;
       condition_status.normal := TRUE;
     ELSE
       condition_status.normal := TRUE;
     CASEND;

   PROCEND terminate_send_to_socket;
?? OLDTITLE ??
?? EJECT ??

   VAR
     caller_id: ost$caller_identifier,
     checksum: boolean,
     data_length: nat$data_length,
     destination_address: nat$sk_socket_address,
     global_socket_id: nlt$udp_global_socket_id,
     interface_mode: nat$sk_interface_mode,
     interface_timeout: nat$wait_time,
     job_socket: ^nat$sk_job_socket,
     local_address: nat$sk_ip_address,
     time_stamp: ost$free_running_clock,
     user_cache_enabled: boolean;

   status.normal := TRUE;
   osp$push_inhibit_job_recovery;
   osp$establish_condition_handler (^terminate_send_to_socket, FALSE);
   IF socket_id > 0 THEN
     nlp$sk_lock_job_socket (socket_id, job_socket);
     IF job_socket <> NIL THEN
       #CALLER_ID (caller_id);
       IF caller_id.ring <= job_socket^.ring THEN
         IF job_socket^.socket_type = nac$sk_udp_socket THEN
           IF (job_socket^.status = nac$sk_socket_open) OR (job_socket^.status = nac$sk_socket_unbound) THEN

{ Check that the user is trying to send > 9000 bytes with a non-blocking interface mode.

             nlp$al_get_data_length (data, data_length);
             IF (data_length < nac$sk_max_nonblocked_data_size) OR
                   (job_socket^.interface_mode = nac$sk_blocking_mode) THEN
               interface_mode := job_socket^.interface_mode;
               IF interface_mode = nac$sk_blocking_mode THEN
                 interface_timeout := job_socket^.interface_timeout;
               ELSE
                 interface_timeout := 0;
               IFEND;
               IF (job_socket^.local_ip_address_enabled) AND (local_ip_address <> NIL) THEN
                 local_address := local_ip_address^;
               ELSE
                 local_address := job_socket^.bound_address;
               IFEND;
               IF destination_socket.ip_address <> loopback_address THEN
                 destination_address := destination_socket;
               ELSE { loopback ... substitute local address for destination.
                 IF nlv$tm_device_configuration^.udp.count > 0 THEN
                   local_address := nlv$tm_device_configuration^.list
                         [nlv$tm_device_configuration^.udp.identifier].local_device_address.full;
                   destination_address.ip_address := local_address;
                   destination_address.port := destination_socket.port;
                 ELSE { No local address ... send will fail with no device available message.
                   destination_address := destination_socket;
                 IFEND;
               IFEND;
               global_socket_id := job_socket^.global_socket_id;
               user_cache_enabled := job_socket^.user_cache_enabled;
               checksum := job_socket^.checksum;
               time_stamp := job_socket^.time_stamp;
               IF job_socket^.status = nac$sk_socket_unbound THEN
                 bind_udp_socket (job_socket, job_socket^.port, nac$sk_all_ip_addresses, status);
               IFEND;
               IF status.normal THEN { socket is open and bound
                 nlp$sk_unlock_job_socket (socket_id);
                 nlp$udp_send_data (global_socket_id, time_stamp, local_address, destination_address, data,
                       data_length, checksum, interface_mode, interface_timeout, user_cache_enabled, status);
                 IF NOT status.normal THEN
                   IF status.condition = nae$sk_socket_terminated THEN
                     nlp$sk_lock_job_socket (socket_id, job_socket);
                     IF (job_socket <> NIL) AND (job_socket^.time_stamp = time_stamp) THEN
                       nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                     IFEND;
                     nlp$sk_unlock_job_socket (socket_id);
                     osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                   ELSEIF status.condition = nae$sk_unknown_socket THEN
                     osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                   IFEND;
                 IFEND;
               ELSE { NOT status.normal from bind_socket request.
                 IF status.condition = nae$sk_socket_terminated THEN
                   nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                 IFEND;
                 nlp$sk_unlock_job_socket (socket_id);
               IFEND;
             ELSE
               nlp$sk_unlock_job_socket (socket_id);
               osp$set_status_abnormal (nac$status_id, nae$sk_max_nonblock_size_exceed, 'SEND TO SOCKET',
                     status);
             IFEND;
           ELSE
             nlp$sk_unlock_job_socket (socket_id);
             IF job_socket^.status = nac$sk_socket_terminated THEN
               osp$set_status_condition (nae$sk_socket_terminated, status);
             ELSEIF job_socket^.status = nac$sk_job_recovery THEN
               osp$set_status_condition (nae$sk_job_recovery, status);
             IFEND;
             osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
           IFEND;
         ELSE
           nlp$sk_unlock_job_socket (socket_id);
           osp$set_status_abnormal (nac$status_id, nae$sk_incorrect_socket_type, 'SEND TO SOCKET', status);
         IFEND;
       ELSE { invalid user
         nlp$sk_unlock_job_socket (socket_id);
         osp$set_status_abnormal (nac$status_id, nae$sk_invalid_user, 'NAP$SK_SEND_TO_SOCKET', status);
       IFEND;
     ELSE
       nlp$sk_unlock_job_socket (socket_id);
       osp$set_status_condition (nae$sk_unknown_socket, status);
       osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
     IFEND;
   ELSE { socket_id = 0
     osp$set_status_condition (nae$sk_unknown_socket, status);
     osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
   IFEND;
   osp$pop_inhibit_job_recovery;

 PROCEND nap$sk_send_to_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_set_socket_options', EJECT ??
*copy nah$sk_set_socket_options

 PROCEDURE [XDCL, #GATE] nap$sk_set_socket_options
   (    socket_id: nat$sk_socket_identifier;
        options: nat$sk_socket_options;
    VAR status: ost$status);

   VAR
     caller_id: ost$caller_identifier,
     i: integer,
     job_socket: ^nat$sk_job_socket,
     old_job_socket: nat$sk_job_socket;

   status.normal := TRUE;
   osp$push_inhibit_job_recovery;
   IF socket_id > 0 THEN
     nlp$sk_lock_job_socket (socket_id, job_socket);
     IF job_socket <> NIL THEN
       #CALLER_ID (caller_id);
       IF caller_id.ring <= job_socket^.ring THEN
         IF (job_socket^.status = nac$sk_socket_open) OR (job_socket^.status = nac$sk_socket_unbound) THEN

{ Verify all socket options.

           verify_socket_options (job_socket, options, status);
           IF status.normal THEN
             old_job_socket := job_socket^;

{ Store the socket options in the job socket.

             nlp$sk_update_socket_options (job_socket^.identifier, options);
             IF job_socket^.socket_type = nac$sk_udp_socket THEN
               IF (job_socket^.traffic_pattern <> old_job_socket.traffic_pattern) OR
                     (job_socket^.broadcast_enabled <> old_job_socket.broadcast_enabled) THEN
                 nlp$udp_set_socket_options (job_socket^.global_socket_id, job_socket^.traffic_pattern,
                       job_socket^.broadcast_enabled, status);
                 IF (NOT status.normal) AND (status.condition = nae$sk_socket_terminated) THEN
                   nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                   osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                 IFEND;
               IFEND;
             ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
               IF job_socket^.tcp_socket_type <> nlc$tcp_null_socket THEN
                 IF ((job_socket^.graceful_close <> old_job_socket.graceful_close) OR
                       (job_socket^.traffic_pattern <> old_job_socket.traffic_pattern)) AND
                       (job_socket^.connection_id <> nac$null_connection_id) THEN
                   nlp$sk_tcp_set_socket_options (job_socket^.connection_id, job_socket^.graceful_close,
                         job_socket^.traffic_pattern, status);
                   IF NOT status.normal THEN
                     IF status.condition = nae$sk_socket_disconnected THEN
                       nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_disconnected);
                     ELSEIF status.condition = nae$sk_socket_closed_via_peer THEN
                       nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_closed_via_peer);
                     ELSEIF status.condition = nae$sk_socket_terminated THEN
                       nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                       osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                             status);
                     IFEND;
                   IFEND;
                 IFEND;
               IFEND;
             IFEND;
           IFEND;
         ELSEIF job_socket^.status = nac$sk_socket_disconnected THEN
           osp$set_status_condition (nae$sk_socket_disconnected, status);
           osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
         ELSEIF job_socket^.status = nac$sk_socket_closed_via_peer THEN
           osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
           osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
         ELSEIF job_socket^.status = nac$sk_socket_terminated THEN
           osp$set_status_condition (nae$sk_socket_terminated, status);
           osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
         ELSEIF job_socket^.status = nac$sk_job_recovery THEN
           osp$set_status_condition (nae$sk_job_recovery, status);
           osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
         IFEND;
       ELSE { invalid user
         osp$set_status_abnormal (nac$status_id, nae$sk_invalid_user, 'NAP$SK_SET_SOCKET_OPTIONS', status);
       IFEND;
     ELSE { job_socket = NIL
       osp$set_status_condition (nae$sk_unknown_socket, status);
       osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
     IFEND;
     nlp$sk_unlock_job_socket (socket_id);
   ELSE { socket_id = 0
     osp$set_status_condition (nae$sk_unknown_socket, status);
     osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
   IFEND;
   osp$pop_inhibit_job_recovery;

 PROCEND nap$sk_set_socket_options;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nap$sk_write_socket', EJECT ??
*copy nah$sk_write_socket

 PROCEDURE [XDCL, #GATE] nap$sk_write_socket
   (    socket_id: nat$sk_socket_identifier;
        urgent_flag: boolean;
        push_flag: boolean;
        data: nat$data_fragments;
    VAR data_transferred: integer;
    VAR status: ost$status);

?? NEWTITLE := 'terminate_write_socket', EJECT ??

   PROCEDURE terminate_write_socket
     (    condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

     CASE condition.selector OF
     = pmc$system_conditions, mmc$segment_access_condition =
       IF cl_connection <> NIL THEN
         nlp$cl_clear_exclusive_access (cl_connection);
       IFEND;
       IF job_socket <> NIL THEN
         nlp$sk_unlock_job_socket (socket_id);
       IFEND;
       osp$pop_inhibit_job_recovery;
       osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
       condition_status.normal := TRUE;
       EXIT nap$sk_write_socket;
     = pmc$user_defined_condition =
       IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
         pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
       IFEND;
       condition_status.normal := TRUE;
     = pmc$block_exit_processing =
       nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
       IF cl_connection <> NIL THEN
         nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active, tcp_connection);
         IF layer_active THEN

{ Find the sender task for the current task_id.

           sender_task := tcp_connection^.send_queue;
           previous_sender_task := ^tcp_connection^.send_queue;
           WHILE (sender_task <> NIL) AND (sender_task^.task_id <> current_task_id) DO
             previous_sender_task := ^sender_task^.next_entry;
             sender_task := sender_task^.next_entry;
           WHILEND;
           IF sender_task <> NIL THEN
             previous_sender_task^ := sender_task^.next_entry;
             nlp$sk_tcp_ret_send_task_entry (tcp_connection, sender_task);
           IFEND;
         IFEND;
         nlp$cl_release_exclusive_access (cl_connection);
       IFEND;
       condition_status.normal := TRUE;
     ELSE

{ Note: Interactive condition is being ignored.

       condition_status.normal := TRUE;
     CASEND;

   PROCEND terminate_write_socket;
?? OLDTITLE ??
?? EJECT ??

   VAR
     activity_complete: boolean,
     caller_id: ost$caller_identifier,
     capacity: nat$data_length,
     cl_connection: ^nlt$cl_connection,
     connection_exists: boolean,
     connection_id: nat$connection_id,
     current_lowerbound: nat$data_fragment_count,
     current_task_id: ost$global_task_id,
     current_time: ost$free_running_clock,
     data_fragments: ^nat$data_fragments,
     data_length: nat$data_length,
     data_length_to_be_sent: nat$data_length,
     end_time: integer,
     interface_timeout: nat$wait_time,
     job_socket: ^nat$sk_job_socket,
     layer_active: boolean,
     new_lowerbound: nat$data_fragment_count,
     previous_sender_task: ^^nlt$tcp_sender_task,
     remaining_data_length: integer,
     remaining_time: integer,
     sender_active: boolean,
     sender_task: ^nlt$tcp_sender_task,
     tcp_connection: ^nlt$tcp_socket_layer;

   status.normal := TRUE;
   cl_connection := NIL;
   #SPOIL (cl_connection);
   pmp$get_executing_task_gtid (current_task_id);
   #SPOIL (current_task_id);
   job_socket := NIL;
   #SPOIL (job_socket);
   osp$push_inhibit_job_recovery;
   osp$establish_condition_handler (^terminate_write_socket, FALSE);
   IF socket_id > 0 THEN
     nlp$sk_lock_job_socket (socket_id, job_socket);
     #SPOIL (job_socket);
     activity_complete := FALSE;
     data_transferred := 0;
     #SPOIL (data_transferred);
     IF (job_socket <> NIL) THEN
       #CALLER_ID (caller_id);
       IF caller_id.ring <= job_socket^.ring THEN
         IF job_socket^.socket_type = nac$sk_tcp_socket THEN
           IF job_socket^.status = nac$sk_socket_open THEN
             IF job_socket^.connection_id <> nac$null_connection_id THEN
               nlp$cl_get_exclusive_via_cid (job_socket^.connection_id, connection_exists, cl_connection);
               #SPOIL (cl_connection);
               sender_active := FALSE;
               IF cl_connection <> NIL THEN
                 nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active, tcp_connection);
                 IF layer_active THEN
                   IF tcp_connection^.state = nlc$tcp_conn_open THEN
                     connection_id := job_socket^.connection_id;
                     #SPOIL (connection_id);
                     interface_timeout := job_socket^.interface_timeout;

{ Setup the data fragments on the local stack.

                     PUSH data_fragments: [1 .. UPPERBOUND (data)];
                     data_fragments^ := data;
                     nlp$al_get_data_length (data, data_length);
                     IF (data_length > 0) OR ((data_length = 0) AND push_flag) THEN
                       IF tcp_connection^.send_queue = NIL THEN
                         nlp$osi_get_outbound_capacity (cl_connection, capacity);
                         IF capacity <= 0 THEN
                           nlp$cc_receive_data (cl_connection);
                           nlp$osi_get_outbound_capacity (cl_connection, capacity);
                         IFEND;
                         IF capacity > 0 THEN
                           nlp$sk_tcp_send_data (cl_connection, capacity, data_fragments^, data_length,
                                 push_flag, urgent_flag, 1, new_lowerbound, remaining_data_length);
                           activity_complete := remaining_data_length = 0;
                           data_transferred := data_length - remaining_data_length;
                           #SPOIL (data_transferred);
                           IF NOT activity_complete THEN
                             IF job_socket^.interface_mode = nac$sk_blocking_mode THEN
                               nlp$sk_tcp_get_send_task_entry (tcp_connection, sender_task);
                               sender_task^.next_entry := NIL;
                               sender_task^.task_id := current_task_id;
                               sender_task^.send_type := nlc$tcp_send_data;
                               data_length_to_be_sent := remaining_data_length;
                               current_lowerbound := new_lowerbound;
                               tcp_connection^.send_queue := sender_task;
                               nlp$cl_activate_sender (cl_connection);
                               sender_active := TRUE;
                             ELSE { non-blocking mode
                               activity_complete := TRUE;
                             IFEND;
                           IFEND;
                         ELSE { capacity = 0
                           IF job_socket^.interface_mode = nac$sk_blocking_mode THEN
                             nlp$sk_tcp_get_send_task_entry (tcp_connection, sender_task);
                             sender_task^.next_entry := NIL;
                             sender_task^.task_id := current_task_id;
                             sender_task^.send_type := nlc$tcp_send_data;
                             data_length_to_be_sent := data_length;
                             current_lowerbound := 1;
                             tcp_connection^.send_queue := sender_task;
                             nlp$cl_activate_sender (cl_connection);
                             sender_active := TRUE;
                           ELSE { Non-blocking mode
                             osp$set_status_abnormal (nac$status_id, nae$sk_insufficient_resources,
                                   'TCP Write', status);
                           IFEND;
                         IFEND;
                       ELSE { tcp_connection^.send_queue <> NIL
                         IF job_socket^.interface_mode = nac$sk_blocking_mode THEN
                           nlp$sk_tcp_get_send_task_entry (tcp_connection, sender_task);
                           sender_task^.next_entry := NIL;
                           sender_task^.task_id := current_task_id;
                           sender_task^.send_type := nlc$tcp_send_data;
                           data_length_to_be_sent := data_length;
                           current_lowerbound := 1;

{ Queue the task at the end of the send queue.

                           previous_sender_task := ^tcp_connection^.send_queue;
                           WHILE previous_sender_task^ <> NIL DO
                             previous_sender_task := ^previous_sender_task^^.next_entry;
                           WHILEND;
                           previous_sender_task^ := sender_task;
                         ELSE { Non-blocking mode
                           osp$set_status_condition (nae$sk_write_in_progress, status);
                           osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                 status);
                         IFEND;
                       IFEND;
                     ELSE { data_length = 0 AND NOT push_flag
                       osp$set_status_condition (nae$sk_zero_length_data, status);
                     IFEND;
                   ELSEIF tcp_connection^.state = nlc$tcp_conn_closed THEN
                     IF tcp_connection^.disconnect_reason = nlc$tcpaa_ri_peer_termination THEN
                       osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
                       nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_closed_via_peer);
                     ELSE
                       osp$set_status_condition (nae$sk_socket_disconnected, status);
                       nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_disconnected);
                     IFEND;
                     osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                     IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
                       nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
                     IFEND;
                   ELSEIF tcp_connection^.state = nlc$tcp_conn_closing THEN
                     IF tcp_connection^.disconnect_reason = nlc$tcpaa_ri_peer_termination THEN
                       osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
                     ELSE
                       osp$set_status_condition (nae$sk_socket_disconnected, status);
                     IFEND;
                     osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                   ELSEIF tcp_connection^.state = nlc$tcp_conn_terminated THEN
                     nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                     IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
                       nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
                     IFEND;
                     osp$set_status_condition (nae$sk_socket_terminated, status);
                     osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                   ELSE { all other states
                     nap$namve_system_error ({Recoverable_error=} TRUE, 'Unexpected socket layer state', NIL);
                     osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'WRITE SOCKET', status);
                   IFEND;
                 ELSE { Layer inactive

{ Is is assumed that the socket has been terminated via application management.

                   nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                   osp$set_status_condition (nae$sk_socket_terminated, status);
                   osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
                 IFEND;
                 nlp$cl_release_exclusive_access (cl_connection);
                 cl_connection := NIL;
                 #SPOIL (cl_connection);
               ELSE { cl_connection = NIL
                 nlp$sk_update_job_socket_status (socket_id, nac$sk_socket_terminated);
                 osp$set_status_condition (nae$sk_socket_terminated, status);
                 osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
               IFEND;

               nlp$sk_unlock_job_socket (socket_id);
               job_socket := NIL;
               #SPOIL (job_socket);
               IF (NOT activity_complete) AND (status.normal) THEN

{ Unable to send any or all data.

                 end_time := #FREE_RUNNING_CLOCK (0) + interface_timeout * 1000;
                 remaining_time := interface_timeout;
                 REPEAT
                   pmp$wait (remaining_time, 0);
                   current_time := #FREE_RUNNING_CLOCK (0);
                   IF end_time > current_time THEN
                     remaining_time := (end_time - current_time) DIV 1000;
                   ELSE
                     remaining_time := 0;
                   IFEND;

                   nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
                   #SPOIL (cl_connection);
                   IF cl_connection <> NIL THEN
                     nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active,
                           tcp_connection);
                     IF layer_active THEN
                       IF tcp_connection^.state = nlc$tcp_conn_open THEN
                         sender_task := tcp_connection^.send_queue;
                         IF sender_task^.task_id = current_task_id THEN

{ The current task is at the head of the send queue.

                           IF NOT sender_active THEN
                             nlp$cl_activate_sender (cl_connection);
                             sender_active := TRUE;
                           IFEND;
                           nlp$cc_receive_data (cl_connection);
                           nlp$osi_get_outbound_capacity (cl_connection, capacity);
                           IF capacity > 0 THEN
                             nlp$sk_tcp_send_data (cl_connection, capacity, data_fragments^,
                                   data_length_to_be_sent, push_flag, urgent_flag, current_lowerbound,
                                   new_lowerbound, remaining_data_length);
                             data_transferred := data_length - remaining_data_length;
                             #SPOIL (data_transferred);
                             IF (remaining_data_length = 0) OR (remaining_time = 0) THEN
                               activity_complete := TRUE;
                               tcp_connection^.send_queue := sender_task^.next_entry;
                               nlp$sk_tcp_ret_send_task_entry (tcp_connection, sender_task);
                               nlp$cl_deactivate_sender (cl_connection);

{ The following needs to be done to process the clear to send indication that
{ may have been queued on the connection.

                               nlp$cc_receive_data (cl_connection);
                               IF tcp_connection^.send_queue <> NIL THEN
                                 pmp$ready_task (tcp_connection^.send_queue^.task_id, {ignore} status);
                                 status.normal := TRUE;
                               IFEND;
                             ELSE { more data to be sent
                               data_length_to_be_sent := remaining_data_length;
                               current_lowerbound := new_lowerbound;
                             IFEND;
                           ELSE { capacity < = 0
                             IF remaining_time = 0 THEN
                               activity_complete := TRUE;
                               tcp_connection^.send_queue := sender_task^.next_entry;
                               nlp$sk_tcp_ret_send_task_entry (tcp_connection, sender_task);
                               nlp$cl_deactivate_sender (cl_connection);

{ The following needs to be done to process the clear to send indication that
{ may have been queued on the connection.

                               nlp$cc_receive_data (cl_connection);
                               IF tcp_connection^.send_queue <> NIL THEN
                                 pmp$ready_task (tcp_connection^.send_queue^.task_id, {ignore} status);
                                 status.normal := TRUE;
                               IFEND;
                               IF data_transferred = 0 THEN
                                 osp$set_status_condition (nae$sk_interface_timeout, status);
                                 osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10,
                                       TRUE, status);
                               IFEND;
                             IFEND;
                           IFEND;
                         ELSE { current task not at the head of the queue
                           IF remaining_time = 0 THEN

{ Dequeue the sender task.

                             previous_sender_task := ^tcp_connection^.send_queue;
                             WHILE (sender_task <> NIL) AND (sender_task^.task_id <> current_task_id) DO
                               previous_sender_task := ^sender_task^.next_entry;
                               sender_task := sender_task^.next_entry;
                             WHILEND;
                             IF sender_task <> NIL THEN
                               previous_sender_task^ := sender_task^.next_entry;
                               nlp$sk_tcp_ret_send_task_entry (tcp_connection, sender_task);
                             IFEND;
                             osp$set_status_condition (nae$sk_interface_timeout, status);
                             osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                   status);
                           IFEND;
                         IFEND;
                       ELSE { tcp_connection^.state <> nlc$tcp_conn_open
                         activity_complete := TRUE;
                         previous_sender_task := ^tcp_connection^.send_queue;
                         WHILE (sender_task <> NIL) AND (sender_task^.task_id <> current_task_id) DO
                           previous_sender_task := ^sender_task^.next_entry;
                           sender_task := sender_task^.next_entry;
                         WHILEND;
                         IF sender_task <> NIL THEN
                           previous_sender_task^ := sender_task^.next_entry;
                           nlp$sk_tcp_ret_send_task_entry (tcp_connection, sender_task);
                         IFEND;
                         IF tcp_connection^.state = nlc$tcp_conn_closed THEN
                           IF tcp_connection^.user_initiated_close THEN
                             IF (tcp_connection^.send_queue = NIL) AND
                                   (tcp_connection^.receive_queue = NIL) THEN
                               nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
                             IFEND;
                             IF data_transferred = 0 THEN
                               osp$set_status_condition (nae$sk_unknown_socket, status);
                               osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                     status);
                             IFEND;
                           ELSE { NOT tcp_connection^.user_initiated_close
                             IF data_transferred = 0 THEN
                               osp$set_status_condition (nae$sk_socket_disconnected, status);
                               osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                     status);
                             IFEND;
                           IFEND;
                         ELSEIF tcp_connection^.state = nlc$tcp_conn_closing THEN
                           IF data_transferred = 0 THEN
                             osp$set_status_condition (nae$sk_socket_disconnected, status);
                             osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                   status);
                           IFEND;
                         ELSEIF tcp_connection^.state = nlc$tcp_conn_terminated THEN
                           IF (tcp_connection^.send_queue = NIL) AND
                                 (tcp_connection^.receive_queue = NIL) THEN
                             nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
                           IFEND;
                           IF data_transferred = 0 THEN
                             osp$set_status_condition (nae$sk_socket_terminated, status);
                             osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE,
                                   status);
                           IFEND;
                         IFEND;
                       IFEND;
                     ELSE { layer inactive
                       nap$namve_system_error ({Recoverable_error=} TRUE, 'TCP socket layer inactive', NIL);
                       osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'WRITE SOCKET', status);
                     IFEND;
                     nlp$cl_release_exclusive_access (cl_connection);
                     cl_connection := NIL;
                     #SPOIL (cl_connection);
                   ELSE { cl_connection = NIL
                     nap$namve_system_error ({Recoverable_error=} TRUE, 'CL connection NIL', NIL);
                     osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'WRITE SOCKET', status);
                   IFEND;
                 UNTIL (activity_complete) OR (NOT status.normal);
               IFEND;
             ELSE
               nlp$sk_unlock_job_socket (socket_id);
               IF job_socket^.tcp_socket_type = nlc$tcp_listen_socket THEN
                 osp$set_status_condition (nae$sk_listen_already_active, status);
               ELSE { job_socket^.connection_id = nac$null_connection_id
                 osp$set_status_condition (nae$sk_socket_not_connected, status);
               IFEND;
               osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
             IFEND;
           ELSE
             nlp$sk_unlock_job_socket (socket_id);
             IF job_socket^.status = nac$sk_socket_unbound THEN
               osp$set_status_condition (nae$sk_unbound_socket, status);
             ELSEIF job_socket^.status = nac$sk_socket_disconnected THEN
               osp$set_status_condition (nae$sk_socket_disconnected, status);
             ELSEIF job_socket^.status = nac$sk_socket_closed_via_peer THEN
               osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
             ELSEIF job_socket^.status = nac$sk_socket_terminated THEN
               osp$set_status_condition (nae$sk_socket_terminated, status);
             ELSEIF job_socket^.status = nac$sk_job_recovery THEN
               osp$set_status_condition (nae$sk_job_recovery, status);
             IFEND;
             osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
           IFEND;
         ELSE { Incorrect socket type
           nlp$sk_unlock_job_socket (socket_id);
           osp$set_status_abnormal (nac$status_id, nae$sk_incorrect_socket_type, 'WRITE SOCKET', status);
         IFEND;
       ELSE { Invalid user
         nlp$sk_unlock_job_socket (socket_id);
         osp$set_status_abnormal (nac$status_id, nae$sk_invalid_user, 'NAP$SK_WRITE_SOCKET', status);
       IFEND;
     ELSE { Unknown socket
       nlp$sk_unlock_job_socket (socket_id);
       osp$set_status_condition (nae$sk_unknown_socket, status);
       osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
     IFEND;
   ELSE { socket_id = 0
     osp$set_status_condition (nae$sk_unknown_socket, status);
     osp$append_status_integer (osc$status_parameter_delimiter, socket_id, 10, TRUE, status);
   IFEND;
   osp$disestablish_cond_handler;
   osp$pop_inhibit_job_recovery;

 PROCEND nap$sk_write_socket;
?? OLDTITLE ??
?? NEWTITLE := 'bind_tcp_socket', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to bind the given TCP socket to
{ the specified port and IP address. If the port number is 0, the
{ socket is bound to a port number assigned by the socket layer.
{ If a 0 value is specified for the IP address, the socket is bound
{ to all known IP addresses.

 PROCEDURE bind_tcp_socket
   (    job_socket { input, output } : ^nat$sk_job_socket;
        port: nat$sk_port_number;
        ip_address: nat$sk_ip_address;
    VAR status: ost$status);

   VAR
     assigned_port: nat$sk_port_number;

   IF port > 0 THEN
     open_specified_tcp_port (ip_address, port, job_socket^.reuse_address, status);
     IF status.normal THEN
       nlp$sk_update_job_socket (job_socket^.identifier, port, ip_address, nac$sk_socket_open);
     IFEND;
   ELSE { Assign port
     open_tcp_port (ip_address, assigned_port, status);
     IF status.normal THEN
       nlp$sk_update_job_socket (job_socket^.identifier, assigned_port, ip_address, nac$sk_socket_open);
     IFEND;
   IFEND;

 PROCEND bind_tcp_socket;
?? OLDTITLE ??
?? NEWTITLE := 'bind_udp_socket', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to bind the given socket to
{ the specified port and IP address. If the port number is 0, the
{ socket is bound to a port number assigned by the socket layer.
{ If a 0 value is specified for the IP address, the socket is bound
{ to all known IP addresses.

 PROCEDURE bind_udp_socket
   (    job_socket { input, output } : ^nat$sk_job_socket;
        port: nat$sk_port_number;
        ip_address: nat$sk_ip_address;
    VAR status: ost$status);

   VAR
     assigned_port: nat$sk_port_number;

   status.normal := TRUE;
   IF port > 0 THEN
     open_specified_udp_port (ip_address, port, status);
     IF status.normal THEN
       nlp$udp_bind_socket (job_socket^.global_socket_id, port, job_socket^.traffic_pattern, ip_address,
             status);
       IF status.normal THEN
         nlp$sk_update_job_socket (job_socket^.identifier, port, ip_address, nac$sk_socket_open);
       ELSE
         close_udp_port (ip_address, port);
       IFEND;
     IFEND;
   ELSE { Assign a port
     open_udp_port (ip_address, assigned_port, status);
     IF status.normal THEN
       nlp$udp_bind_socket (job_socket^.global_socket_id, assigned_port, job_socket^.traffic_pattern,
             ip_address, status);
       IF status.normal THEN
         nlp$sk_update_job_socket (job_socket^.identifier, assigned_port, ip_address, nac$sk_socket_open);
       ELSE
         close_udp_port (ip_address, assigned_port);
       IFEND;
     IFEND;
   IFEND;

 PROCEND bind_udp_socket;
?? OLDTITLE ??
?? NEWTITLE := 'close_socket', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to close the specified job socket and
{ free all associated structures.

 PROCEDURE close_socket
   (VAR job_socket: ^nat$sk_job_socket;
    VAR status: ost$status);

   VAR
     socket_id: nat$sk_socket_identifier;

   socket_id := job_socket^.identifier;
   IF job_socket^.status <> nac$sk_job_recovery THEN
     IF job_socket^.socket_type = nac$sk_udp_socket THEN
       nlp$tcpip_decrement_appl_access (job_socket^.application, job_socket^.global_socket_id,
             nac$null_connection_id, {ignore} status);
       status.normal := TRUE;
       IF job_socket^.status <> nac$sk_socket_unbound THEN
         nlp$udp_close_socket (job_socket^.global_socket_id, FALSE {terminate_via_application_mgmt} );
         IF job_socket^.port > 0 THEN
           close_udp_port (job_socket^.bound_address, job_socket^.port);
         IFEND;
       ELSE {job_socket^.status = nac$sk_socket_unbound THEN
         nlp$udp_delete_global_socket (job_socket^.global_socket_id);
       IFEND;
     ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
       IF job_socket^.tcp_socket_type = nlc$tcp_listen_socket THEN
         nlp$sk_tcp_terminate_listen (job_socket^.application, job_socket^.port, job_socket^.bound_address);
         close_tcp_port (job_socket^.bound_address, job_socket^.port, TRUE);
       ELSEIF job_socket^.tcp_socket_type <> nlc$tcp_null_socket THEN

{ Connect or accept socket.

         nlp$tcpip_decrement_appl_access (job_socket^.application, nlc$udp_null_global_socket_id,
               job_socket^.connection_id, {ignore} status);
         status.normal := TRUE;
         nlp$sk_tcp_close_socket (job_socket^.connection_id, job_socket^.graceful_close);
         IF job_socket^.tcp_socket_type = nlc$tcp_connect_socket THEN
           close_tcp_port (job_socket^.bound_address, job_socket^.port, FALSE);
         IFEND;
       ELSE { null TCP socket type

{ Delete the job socket.

         IF job_socket^.status = nac$sk_socket_open THEN
           close_tcp_port (job_socket^.bound_address, job_socket^.port, FALSE);
         IFEND;
       IFEND;
     IFEND;
   IFEND;
   nlp$sk_delete_job_socket (socket_id, job_socket);
   nlp$sk_free_socket_id (socket_id);

 PROCEND close_socket;
?? OLDTITLE ??
?? NEWTITLE := 'close_tcp_port', EJECT ??

 PROCEDURE close_tcp_port
   (    ip_address: nat$sk_ip_address;
        port: nat$sk_port_number;
        listen_active: boolean);

   VAR
     open_port: ^nlt$tcp_open_port,
     previous_open_port: ^^nlt$tcp_open_port;

   osp$set_job_signature_lock (nlv$tcp_ports.lock);
   previous_open_port := ^nlv$tcp_ports.open_ports;
   WHILE (previous_open_port^ <> NIL) AND ((previous_open_port^^.port <> port) OR
         (previous_open_port^^.ip_address <> ip_address)) DO
     previous_open_port := ^previous_open_port^^.next_entry;
   WHILEND;
   IF previous_open_port^ <> NIL THEN
     open_port := previous_open_port^;
     open_port^.count := open_port^.count - 1;
     IF open_port^.count = 0 THEN
       previous_open_port^ := open_port^.next_entry;
       FREE open_port IN nav$network_paged_heap^;
     ELSEIF listen_active THEN
       open_port^.listen_active := FALSE;
     IFEND;
   ELSE { port/IP address not open
     nap$namve_system_error ({Recoverable_error=} TRUE, 'The port, IP address pair is not open.', NIL);
   IFEND;
   osp$clear_job_signature_lock (nlv$tcp_ports.lock);

 PROCEND close_tcp_port;
?? OLDTITLE ??
?? NEWTITLE := 'close_udp_port', EJECT ??

 PROCEDURE close_udp_port
   (    ip_address: nat$sk_ip_address;
        port: nat$sk_port_number);

   VAR
     i: integer,
     open_port: ^nlt$udp_open_port,
     previous_open_port: ^^nlt$udp_open_port;

   osp$set_job_signature_lock (nlv$udp_ports.lock);
   previous_open_port := ^nlv$udp_ports.open_ports;
   WHILE (previous_open_port^ <> NIL) AND ((previous_open_port^^.port <> port) OR
         (previous_open_port^^.ip_address <> ip_address)) DO
     previous_open_port := ^previous_open_port^^.next_entry;
   WHILEND;
   IF previous_open_port^ <> NIL THEN
     open_port := previous_open_port^;
     previous_open_port^ := open_port^.next_entry;
     FREE open_port IN nav$network_paged_heap^;
   ELSE { port/IP address not open
     nap$namve_system_error ({Recoverable_error=} TRUE, 'The port, IP address pair is not open.', NIL);
   IFEND;
   osp$clear_job_signature_lock (nlv$udp_ports.lock);

 PROCEND close_udp_port;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_global_socket', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to initialize the global
{ socket entry from the given job socket.

 PROCEDURE initialize_global_socket
   (    job_socket: nat$sk_job_socket;
    VAR global_socket: ^nlt$udp_global_socket);

   VAR
     i: integer;

   global_socket^.next_entry := NIL;
   global_socket^.time_stamp := job_socket.time_stamp;
   global_socket^.status := nlc$udp_global_socket_unbound;
   global_socket^.local_socket_id := job_socket.identifier;
   global_socket^.port := job_socket.port;
   global_socket^.traffic_pattern := job_socket.traffic_pattern;
   global_socket^.broadcast_enabled := job_socket.broadcast_enabled;
   global_socket^.bound_address := job_socket.bound_address;

   global_socket^.waiting_task_id.index := 0;
   global_socket^.last_receiving_device := 1;
   global_socket^.active_device_count := 0;

{ Initialize the receive queue.

   global_socket^.receive_wait_queue := NIL;

   FOR i := 1 TO UPPERBOUND (global_socket^.device_list) DO
     global_socket^.device_list [i].device_id := i;
     global_socket^.device_list [i].status := nlc$udp_device_closed;
     global_socket^.device_list [i].ip_address := nac$sk_all_ip_addresses;
     global_socket^.device_list [i].connection_id := nac$null_connection_id;
     global_socket^.device_list [i].discard_data := FALSE;
     global_socket^.device_list [i].received_messages := NIL;
     global_socket^.device_list [i].receiver_task := NIL;
   FOREND;

 PROCEND initialize_global_socket;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_tcp_pools', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to initialize the pools of available
{ sender, receiver task entries and the pool of available received data
{ entries.

 PROCEDURE initialize_tcp_pools
   (VAR tcp_connection: ^nlt$tcp_socket_layer);

   VAR
     i: integer,
     previous_received_data: ^^nlt$tcp_received_data,
     previous_receiver_task: ^^nlt$tcp_receiver_task,
     previous_sender_task: ^^nlt$tcp_sender_task,
     received_data: ^nlt$tcp_received_data,
     receiver_task: ^nlt$tcp_receiver_task,
     sender_task: ^nlt$tcp_sender_task;

{ Initialize available sender pool.

   previous_sender_task := ^tcp_connection^.available_sender_pool;
   FOR i := 1 TO nlc$tcp_max_pool_size DO
     REPEAT
       ALLOCATE sender_task IN nav$network_paged_heap^;
       IF sender_task = NIL THEN
         syp$cycle;
       IFEND;
     UNTIL sender_task <> NIL;
     previous_sender_task^ := sender_task;
     previous_sender_task := ^sender_task^.next_entry;
   FOREND;
   previous_sender_task^ := NIL;

{ Initialize available receiver pool.

   previous_receiver_task := ^tcp_connection^.available_receiver_pool;
   FOR i := 1 TO nlc$tcp_max_pool_size DO
     REPEAT
       ALLOCATE receiver_task IN nav$network_paged_heap^;
       IF receiver_task = NIL THEN
         syp$cycle;
       IFEND;
     UNTIL receiver_task <> NIL;
     previous_receiver_task^ := receiver_task;
     previous_receiver_task := ^receiver_task^.next_entry;
   FOREND;
   previous_receiver_task^ := NIL;

{ Initialize available data pool.

   previous_received_data := ^tcp_connection^.available_data_pool;
   FOR i := 1 TO nlc$tcp_max_pool_size DO
     REPEAT
       ALLOCATE received_data IN nav$network_paged_heap^;
       IF received_data = NIL THEN
         syp$cycle;
       IFEND;
     UNTIL received_data <> NIL;
     previous_received_data^ := received_data;
     previous_received_data := ^received_data^.next_entry;
   FOREND;
   previous_received_data^ := NIL;

 PROCEND initialize_tcp_pools;
?? OLDTITLE ??
?? NEWTITLE := 'mark_listen_port', EJECT ??

 PROCEDURE mark_listen_port
   (    port: nat$sk_port_number;
        ip_address: nat$sk_ip_address;
    VAR status: ost$status);

   VAR
     open_port: ^nlt$tcp_open_port;

   status.normal := TRUE;
   osp$set_job_signature_lock (nlv$tcp_ports.lock);
   open_port := nlv$tcp_ports.open_ports;
   WHILE (open_port <> NIL) AND ((open_port^.port <> port) OR (open_port^.ip_address <> ip_address)) DO
     open_port := open_port^.next_entry;
   WHILEND;
   IF open_port <> NIL THEN
     IF NOT open_port^.listen_active THEN
       open_port^.listen_active := TRUE;
     ELSE
       osp$set_status_condition (nae$sk_listen_active, status);
       osp$append_status_integer (osc$status_parameter_delimiter, port, 10, FALSE, status);
     IFEND;
   ELSE { port/IP address not open
     nap$namve_system_error ({Recoverable_error=} TRUE, 'The port, IP address pair is not open.', NIL);
     osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'MARK LISTEN PORT', status);
   IFEND;
   osp$clear_job_signature_lock (nlv$tcp_ports.lock);

 PROCEND mark_listen_port;
?? OLDTITLE ??
?? NEWTITLE := 'open_specified_tcp_port', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to open the specified TCP port
{ for the given IP address. If the specified port has already been
{ opened by another user for the given IP address and the reuse option
{ has not been specified or reuse option has been specified and listen
{ is active on the open port, an abnormal status is returned to the
{ caller. If the specified port has not been opened for the given IP
{ address, it is now opened.

 PROCEDURE open_specified_tcp_port
   (    ip_address: nat$sk_ip_address;
        port: nat$sk_port_number;
        reuse_address: boolean;
    VAR status: ost$status);

   VAR
     new_open_port: ^nlt$tcp_open_port,
     open_port: ^nlt$tcp_open_port,
     previous_open_port: ^^nlt$tcp_open_port,
     reusing_address: boolean;

   status.normal := TRUE;
   osp$set_job_signature_lock (nlv$tcp_ports.lock);

{ Check if the specified port number is open over the given IP address.

   reusing_address := FALSE;
   open_port := nlv$tcp_ports.open_ports;
   previous_open_port := ^nlv$tcp_ports.open_ports;

 /check_if_port_open/
   WHILE open_port <> NIL DO
     IF open_port^.port = port THEN
       IF open_port^.ip_address = ip_address THEN
         IF reuse_address THEN
           IF NOT open_port^.listen_active THEN
             open_port^.count := open_port^.count + 1;
             reusing_address := TRUE;
           ELSE
             osp$set_status_condition (nae$sk_listen_active, status);
             osp$append_status_integer (osc$status_parameter_delimiter, port, 10, FALSE, status);
           IFEND;
         ELSE
           osp$set_status_abnormal (nac$status_id, nae$sk_port_already_in_use, 'TCP', status);
           osp$append_status_integer (osc$status_parameter_delimiter, port, 10, FALSE, status);
         IFEND;
         EXIT /check_if_port_open/;
       ELSEIF (open_port^.ip_address = nac$sk_all_ip_addresses) OR (ip_address = nac$sk_all_ip_addresses) THEN
         osp$set_status_abnormal (nac$status_id, nae$sk_port_already_in_use, 'TCP', status);
         osp$append_status_integer (osc$status_parameter_delimiter, port, 10, FALSE, status);
         EXIT /check_if_port_open/;
       IFEND;
     IFEND;
     previous_open_port := ^open_port^.next_entry;
     open_port := open_port^.next_entry;
   WHILEND /check_if_port_open/;

   IF status.normal AND (NOT reusing_address) THEN

{ Specified port/IP_address has not been opened yet.

     REPEAT
       ALLOCATE new_open_port IN nav$network_paged_heap^;
       IF new_open_port = NIL THEN
         syp$cycle;
       IFEND;
     UNTIL new_open_port <> NIL;
     new_open_port^.next_entry := NIL;
     new_open_port^.port := port;
     new_open_port^.ip_address := ip_address;
     new_open_port^.count := 1;
     new_open_port^.listen_active := FALSE;
     previous_open_port^ := new_open_port;
   IFEND;
   osp$clear_job_signature_lock (nlv$tcp_ports.lock);

 PROCEND open_specified_tcp_port;
?? OLDTITLE ??
?? NEWTITLE := 'open_specified_udp_port', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to open the specified UDP port
{ for the given IP address. If the specified port has already been
{ opened for the given IP address, an abnormal status is returned to
{ the caller. However, if the port has been opened for another IP address,
{ it is now opened for the given IP address also.

 PROCEDURE open_specified_udp_port
   (    ip_address: nat$sk_ip_address;
        port: nat$sk_port_number;
    VAR status: ost$status);

   VAR
     i: integer,
     new_open_port: ^nlt$udp_open_port,
     open_port: ^nlt$udp_open_port,
     previous_open_port: ^^nlt$udp_open_port;

   status.normal := TRUE;
   osp$set_job_signature_lock (nlv$udp_ports.lock);

{ Check if the specified port number is open over the given IP address.

   open_port := nlv$udp_ports.open_ports;
   previous_open_port := ^nlv$udp_ports.open_ports;

 /check_if_port_open/
   WHILE open_port <> NIL DO
     IF open_port^.port = port THEN
       IF open_port^.ip_address = ip_address THEN
         osp$set_status_abnormal (nac$status_id, nae$sk_port_already_in_use, 'UDP', status);
         osp$append_status_integer (osc$status_parameter_delimiter, port, 10, FALSE, status);
         EXIT /check_if_port_open/;
       ELSEIF (open_port^.ip_address = nac$sk_all_ip_addresses) OR (ip_address = nac$sk_all_ip_addresses) THEN
         osp$set_status_abnormal (nac$status_id, nae$sk_port_already_in_use, 'UDP', status);
         osp$append_status_integer (osc$status_parameter_delimiter, port, 10, FALSE, status);
         EXIT /check_if_port_open/;
       IFEND;
     IFEND;
     previous_open_port := ^open_port^.next_entry;
     open_port := open_port^.next_entry;
   WHILEND /check_if_port_open/;

   IF status.normal THEN

{ Specified port/IP_address has not been opened yet.

     REPEAT
       ALLOCATE new_open_port IN nav$network_paged_heap^;
       IF new_open_port = NIL THEN
         syp$cycle;
       IFEND;
     UNTIL new_open_port <> NIL;
     new_open_port^.next_entry := NIL;
     new_open_port^.port := port;
     new_open_port^.ip_address := ip_address;
     previous_open_port^ := new_open_port;
   IFEND;

   osp$clear_job_signature_lock (nlv$udp_ports.lock);

 PROCEND open_specified_udp_port;
?? OLDTITLE ??
?? NEWTITLE := 'open_tcp_port', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to assign the next available
{ port number and to open it for the specified IP address. The port
{ number assigned should not be open on any other IP address.

 PROCEDURE open_tcp_port
   (    ip_address: nat$sk_ip_address;
    VAR port: nat$sk_port_number;
    VAR status: ost$status);

   VAR
     assigned_port: nat$sk_port_number,
     i: integer,
     open_port: ^nlt$tcp_open_port,
     previous_open_port: ^^nlt$tcp_open_port;

   status.normal := TRUE;
   osp$set_job_signature_lock (nlv$tcp_ports.lock);
   port := 0;
   assigned_port := nlv$tcp_ports.next_assignable_port;

 /assign_port/
   REPEAT

{ Verify that the port is not already open for any IP address.

     previous_open_port := ^nlv$tcp_ports.open_ports;
     WHILE (previous_open_port^ <> NIL) AND (previous_open_port^^.port <> assigned_port) DO
       previous_open_port := ^previous_open_port^^.next_entry;
     WHILEND;
     IF previous_open_port^ = NIL THEN
       port := assigned_port;
       REPEAT
         ALLOCATE open_port IN nav$network_paged_heap^;
         IF open_port = NIL THEN
           syp$cycle;
         IFEND;
       UNTIL open_port <> NIL;
       open_port^.next_entry := NIL;
       open_port^.port := port;
       open_port^.count := 1;
       open_port^.listen_active := FALSE;
       open_port^.ip_address := ip_address;
       previous_open_port^ := open_port;
       IF port = nlc$sk_max_assigned_port THEN
         nlv$tcp_ports.next_assignable_port := nlc$sk_min_assigned_port;
       ELSE
         nlv$tcp_ports.next_assignable_port := port + 1;
       IFEND;
       EXIT /assign_port/;
     ELSE { port is already open
       IF assigned_port = nlc$sk_max_assigned_port THEN
         assigned_port := nlc$sk_min_assigned_port;
       ELSE
         assigned_port := assigned_port + 1;
       IFEND;
     IFEND;
   UNTIL assigned_port = nlv$tcp_ports.next_assignable_port;

   IF port = 0 THEN
     osp$set_status_abnormal (nac$status_id, nae$sk_no_available_port, 'TCP', status);
   IFEND;

   osp$clear_job_signature_lock (nlv$tcp_ports.lock);

 PROCEND open_tcp_port;
?? OLDTITLE ??
?? NEWTITLE := 'open_udp_port', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to assign the next available
{ port number and to open it for the specified IP address. The port
{ number assigned should not be open on any other IP address.

 PROCEDURE open_udp_port
   (    ip_address: nat$sk_ip_address;
    VAR port: nat$sk_port_number;
    VAR status: ost$status);

   VAR
     assigned_port: nat$sk_port_number,
     open_port: ^nlt$udp_open_port,
     previous_open_port: ^^nlt$udp_open_port;

   status.normal := TRUE;
   osp$set_job_signature_lock (nlv$udp_ports.lock);
   port := 0;
   assigned_port := nlv$udp_ports.next_assignable_port;

 /assign_port/
   REPEAT

{ Verify that the port is not already open for any IP address.

     previous_open_port := ^nlv$udp_ports.open_ports;
     WHILE (previous_open_port^ <> NIL) AND (previous_open_port^^.port <> assigned_port) DO
       previous_open_port := ^previous_open_port^^.next_entry;
     WHILEND;
     IF previous_open_port^ = NIL THEN
       port := assigned_port;
       REPEAT
         ALLOCATE open_port IN nav$network_paged_heap^;
         IF open_port = NIL THEN
           syp$cycle;
         IFEND;
       UNTIL open_port <> NIL;
       open_port^.next_entry := NIL;
       open_port^.port := port;
       open_port^.ip_address := ip_address;
       previous_open_port^ := open_port;
       IF port = nlc$sk_max_assigned_port THEN
         nlv$udp_ports.next_assignable_port := nlc$sk_min_assigned_port;
       ELSE
         nlv$udp_ports.next_assignable_port := port + 1;
       IFEND;
       EXIT /assign_port/;
     ELSE { port is already open
       IF assigned_port = nlc$sk_max_assigned_port THEN
         assigned_port := nlc$sk_min_assigned_port;
       ELSE
         assigned_port := assigned_port + 1;
       IFEND;
     IFEND;
   UNTIL assigned_port = nlv$udp_ports.next_assignable_port;

   IF port = 0 THEN
     osp$set_status_abnormal (nac$status_id, nae$sk_no_available_port, 'UDP', status);
   IFEND;

   osp$clear_job_signature_lock (nlv$udp_ports.lock);

 PROCEND open_udp_port;
?? OLDTITLE ??
?? NEWTITLE := 'verify_socket_options', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to verify the selected
{ socket options against the socket type and other attributes
{ of the socket.

 PROCEDURE verify_socket_options
   (    job_socket: ^nat$sk_job_socket;
        options: nat$sk_socket_options;
    VAR status: ost$status);

   VAR
     caller_id: ost$caller_identifier,
     i: integer;

   status.normal := TRUE;

 /verify_options/
   FOR i := 1 TO UPPERBOUND (options) DO
     CASE options [i].option_kind OF
     = nac$sk_interface_mode_opt =

{ This option can be specified for either socket type.

     = nac$sk_interface_timeout_opt =

{ This options can be specified for either socket type.

     = nac$sk_checksum_opt =
       IF job_socket^.socket_type = nac$sk_tcp_socket THEN
         osp$set_status_abnormal (nac$status_id, nae$sk_invalid_option, 'TCP', status);
         osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (options [i].option_kind), 10,
               TRUE, status);
         EXIT /verify_options/;
       IFEND;

     = nac$sk_traffic_pattern_opt =
       IF (options [i].traffic_pattern = 0) OR ((options [i].traffic_pattern >
             nac$sk_udp_last_traffic_pattern) AND (job_socket^.socket_type = nac$sk_udp_socket)) OR
             ((options [i].traffic_pattern > nac$sk_tcp_last_traffic_pattern) AND
             (job_socket^.socket_type = nac$sk_tcp_socket)) THEN
         osp$set_status_condition (nae$sk_incorrect_option, status);
         osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (options [i].option_kind), 10,
               TRUE, status);
         EXIT /verify_options/;
       IFEND;

     = nac$sk_graceful_close_opt =
       IF job_socket^.socket_type = nac$sk_udp_socket THEN
         osp$set_status_abnormal (nac$status_id, nae$sk_invalid_option, 'UDP', status);
         osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (options [i].option_kind), 10,
               TRUE, status);
         EXIT /verify_options/;
       IFEND;
     = nac$sk_selection_criteria_opt =
       IF job_socket^.socket_type = nac$sk_udp_socket THEN
         osp$set_status_abnormal (nac$status_id, nae$sk_invalid_option, 'UDP', status);
         osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (options [i].option_kind), 10,
               TRUE, status);
         EXIT /verify_options/;
       ELSEIF job_socket^.tcp_socket_type = nlc$tcp_listen_socket THEN
         osp$set_status_condition (nae$sk_listen_already_active, status);
         osp$append_status_integer (osc$status_parameter_delimiter, job_socket^.identifier, 10, TRUE, status);
         EXIT /verify_options/;
       IFEND;

     = nac$sk_local_addr_enabled_opt =
       IF job_socket^.socket_type = nac$sk_tcp_socket THEN
         osp$set_status_abnormal (nac$status_id, nae$sk_invalid_option, 'TCP', status);
         osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (options [i].option_kind), 10,
               TRUE, status);
         EXIT /verify_options/;
       IFEND;

     = nac$sk_user_cache_enabled_opt =
       IF job_socket^.socket_type = nac$sk_tcp_socket THEN
         osp$set_status_abnormal (nac$status_id, nae$sk_invalid_option, 'TCP', status);
         osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (options [i].option_kind), 10,
               TRUE, status);
         EXIT /verify_options/;
       IFEND;

     = nac$sk_reuse_address_opt =
       IF job_socket^.socket_type = nac$sk_udp_socket THEN
         osp$set_status_abnormal (nac$status_id, nae$sk_invalid_option, 'UDP', status);
         osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (options [i].option_kind), 10,
               TRUE, status);
         EXIT /verify_options/;
       IFEND;

     = nac$sk_broadcast_enabled_opt =
       IF job_socket^.socket_type = nac$sk_tcp_socket THEN
         osp$set_status_abnormal (nac$status_id, nae$sk_invalid_option, 'TCP', status);
         osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (options [i].option_kind), 10,
               TRUE, status);
         EXIT /verify_options/;
       IFEND;
       #CALLER_ID (caller_id);
       IF caller_id.ring > osc$sj_ring_3 THEN
         osp$set_status_abnormal (nac$status_id, nae$sk_invalid_user, 'BROADCAST', status);
         EXIT /verify_options/;
       IFEND;

     ELSE { Invalid socket option
       osp$set_status_condition (nae$sk_invalid_option, status);
       osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (options [i].option_kind), 10,
             TRUE, status);
       EXIT /verify_options/;
     CASEND;
   FOREND /verify_options/;

 PROCEND verify_socket_options;
?? OLDTITLE ??
 MODEND nam$sk_socket_layer;
*DECK DECK=NAM$STATIC_DATA EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'NAM/VE: Static Data - oss$network_paged' ??
MODULE nam$static_data;

{
{  PURPOSE: It is intended that this module eventually contain all static data for NAM/VE
{           that is assigned to network paged segment.
{
?? PUSH (LISTEXT := ON) ??
?? NEWTITLE := '  Global Declarations', EJECT ??

*copyc nat$am_login_prompt
*copyc nat$cn_active_sap_list
*copyc nat$data_fragments
*copyc nat$global_osi_statistics
*copyc nat$global_statistics
*copyc nat$maximum_login_attempts
*copyc nat$net_device_config_param
*copyc nat$network_address
*copyc nat$network_selector
*copyc nat$open_cn_sap_descriptor
*copyc nat$open_network_sap_descriptor
*copyc nat$protocol_stack
*copyc nat$subnet_identifier
*copyc nat$title_list
*copyc nat$translation_request_list
*copyc nlc$bm_small_buffer_size
*copyc nlt$bm_allocated_buffer_pool
*copyc nlt$bm_buffer_manager_control
*copyc nlt$bm_buffer_pool
*copyc nlt$bm_message_id
*copyc nlt$cc_connection
*copyc nlt$cl_reference_number
*copyc nlt$configured_network_devices
*copyc nlt$la_open_sap_list
*copyc nlt$na_sap_list
*copyc nlt$sm_await_routing_queries
*copyc nlt$timer
*copyc nlt$sm_devices
*copyc oss$network_paged
*copyc ost$global_task_id
*copyc ost$heap
*copyc ost$signature_lock
?? POP ??
?? TITLE := '  NAM/VE Global Variables', EJECT ??

  VAR
{ Nlm$buffer_manager variables.

    nlv$bm_allocated_buffer_maximum: [XDCL, #GATE, oss$network_paged] nlt$bm_buffer_count := 512,
    nlv$bm_allocated_buffer_pool: [XDCL, #GATE, oss$network_paged] nlt$bm_allocated_buffer_pool := [
          [ 1, 1, nlc$bm_small_buffer_size, 64, ^nlv$bm_small_buffer_sub_pool],
          [ 1, 1, {large_buffer_size = } *, 32, ^nlv$bm_large_buffer_sub_pool]],
    nlv$bm_allocat_buffer_threshold: [XDCL, #GATE, oss$network_paged] nlt$bm_buffer_count := 487,
    nlv$bm_buffer_manager_caller: [XDCL, #GATE, oss$network_paged] string (21) := 'Buffer Manager Caller',

{ The following variable is used to synchronize buffer manager requests which acquire or return buffers.

    nlv$bm_buffer_manager_control: [XDCL, #GATE, oss$network_paged] nlt$bm_buffer_manager_control := [[0]],
    nlv$bm_buffer_pool: [XDCL, #GATE, oss$network_paged] nlt$bm_buffer_pool := [
          [ nlc$bm_small_buffer_size, {count =} *, {limit =} 64 * 4, NIL, NIL, NIL, 0],
          [ {large_buffer_size =} *, {count =} *, {limit =} 64 * 2, NIL, NIL, NIL, 0]],
    nlv$bm_buffers_freed: [XDCL, #GATE, oss$network_paged] boolean := FALSE,
    nlv$bm_large_buffer_size: [XDCL, #GATE, oss$network_paged] nlt$bm_buffer_length,
    nlv$bm_large_buffers: [XDCL, #GATE, oss$network_paged] nlt$bm_buffer_count := 64,
    nlv$bm_nil_message_id: [XDCL, #GATE, oss$network_paged] nlt$bm_message_id := [NIL, 0],
    nlv$bm_null_message_id: [XDCL, #GATE, oss$network_paged] nlt$bm_message_id := [NIL, 0ffff(16)],

{ Sub pool sizes are based on the amount of space available in 16MB of wired memory.

    nlv$bm_large_buffer_sub_pool: [oss$network_paged] array [1 .. 100] of nlt$bm_allocatd_buffer_sub_pool :=
          [ REP 100 OF [NIL, NIL, 0]],
    nlv$bm_small_buffer_sub_pool: [oss$network_paged] array [1 .. 200] of nlt$bm_allocatd_buffer_sub_pool :=
          [ REP 200 OF [NIL, NIL, 0]],
{ End nlm$bm_buffer_manager  variables.

    nav$change_nam_attributes_lock: [XDCL, #GATE, oss$network_paged] ost$signature_lock := [0],

    nav$network_id: [XDCL, #GATE, oss$network_paged] nat$network_identifier,
    nav$host_subnet_id: [XDCL, #GATE, oss$network_paged] nat$subnet_identifier,
    nav$cdna_broadcast_address: [XDCL, #GATE, oss$network_paged] nat$system_identifier := 0ffffffffffff(16),
    nav$cdna_multicast_address: [XDCL, #GATE, oss$network_paged] nat$system_identifier := 090025ffffff(16),

    nav$network_paged_heap: [XDCL, #GATE, oss$network_paged] ^ost$heap := NIL,

    nlv$configured_network_devices: [XDCL, #GATE, oss$network_paged] nlt$configured_network_devices :=
      [[0, FALSE, 0], 0, 0, NIL],

{   The following declarations specify the number of active priority connections.
{   NLV$CL_PRIORITY_CONNECTIONS can only be read/written via compare/swap.

    nlv$cl_priority_connections: [XDCL, #GATE, oss$network_paged] integer := 0,

{   NLV$CL_PRIORITY_CONNECT_COUNT is readable without compare/swap.

    nlv$cl_priority_connect_count: [XDCL, #GATE, oss$network_paged] nlt$cl_reference_number := 0,

{  The following declaration specifys the maximum data size for channelnet packets. This size is picked
{  to allow a link access PDU to fit in 3 small buffers.

    nav$cn_maximum_data_length: [XDCL, #GATE, oss$network_paged] nat$data_length := 1488,

    nav$cn_sap_list: [XDCL, #GATE, oss$network_paged] nat$cn_sap_list := [[0, FALSE, 0], NIL],

    nav$open_cn_sap_list_lock: [XDCL, #GATE, oss$network_paged] ost$signature_lock,
    nav$open_cn_sap_list: [XDCL, #GATE, oss$network_paged] ^nat$open_cn_sap_descriptor := NIL,

    nac$null_connection_id: [XDCL, #GATE, oss$network_paged] nat$connection_id := [0, 0],

    nav$maximum_login_attempts: [XDCL, #GATE, oss$network_paged] nat$maximum_login_attempts := 3,
    nav$prompt_for_family_name: [XDCL, #GATE, oss$network_paged] boolean := TRUE,
    nav$prompt_for_account: [XDCL, #GATE, oss$network_paged] boolean := FALSE,
    nav$prompt_for_project: [XDCL, #GATE, oss$network_paged] boolean := FALSE,
    nav$final_login_prompt: [XDCL, #GATE, oss$network_paged] nat$am_login_prompt := nac$am_family_name,
    nav$force_password_prompt: [XDCL, #GATE, oss$network_paged] boolean := FALSE,

    nav$statistics_enabled: [XDCL, #GATE, oss$network_paged] boolean := FALSE,

    nav$global_osi_statistics: [XDCL, #GATE, oss$network_paged] nat$global_osi_statistics :=
          [{ channel_connection_device = } NIL,
          { channel_connection = } [0, 0, 0],
          { link_access_agent = } [0, 0, 0, 0, 0],
          { network_access_agent = } [0, 0, 0, 0, 0],
          { system_management_entity = } [0, 0, 0, 0, 0, 0],
          { transport_access_agent = } [0, 0, 0, 0, 0, 0]],

    nav$global_statistics: [XDCL, #GATE, oss$network_paged] nat$global_statistics :=
          [NIL, [0, 0, 0, 0, 0], [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0],
          [0, 0, 0, 0], [[0, 0], [0, 0], 0], [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0],[0, 0],
          [[0, 0], [0, 0]], [0, 0, 0, 0, 0, 0, 0]],

    nav$registered_titles: [XDCL, #GATE, oss$network_paged] nat$title_list := [NIL, 0],
    nav$translation_cache: [XDCL, #GATE, oss$network_paged] nat$title_list := [NIL, 0],
    nav$translation_requests: [XDCL, #GATE, oss$network_paged] nat$translation_request_list := [NIL, 0],
    nlv$directory_version: [XDCL, #GATE, oss$network_paged] 2 .. 3 := 3,
    nlv$directory_pdu_seq_number: [XDCL, #GATE, oss$network_paged] integer := 0,
    nlv$directory_id_seq_number: [XDCL, #GATE, oss$network_paged] integer := 0,
    nav$unique_directory_identifier: [XDCL, #GATE, oss$network_paged] integer := 0,
    nlv$directory_lock: [XDCL, #GATE, oss$network_paged] ost$signature_lock := [0],
    nlv$log_broadcast_requests: [XDCL, #GATE, oss$network_paged] boolean := FALSE,
    nlv$log_broadcast_translations: [XDCL, #GATE, oss$network_paged] boolean := FALSE,

    nav$open_network_sap_list_lock: [XDCL, #GATE, oss$network_paged] ost$signature_lock := [0],
    nav$open_network_sap_list: [XDCL, #GATE, oss$network_paged] ^nat$open_network_sap_descriptor :=
      NIL;

  VAR
    nav$intranet_mgmt_timer_active: [XDCL, #GATE, oss$network_paged] boolean := FALSE;

  VAR
    nlv$timer_monitor_task: [XDCL, #GATE, oss$network_paged] ost$global_task_id;

  VAR
    nav$namve_active: [XDCL, #GATE, oss$network_paged] boolean := FALSE;

  VAR
    nav$ica_reset_down_threshold: [XDCL, #GATE, oss$network_paged] nat$ica_reset_down_threshold := 10,
    nav$intranet_layer_mgmt_taskid: [XDCL, #GATE, oss$network_paged] ost$global_task_id,
    nav$mci_reset_down_threshold: [XDCL, #GATE, oss$network_paged] nat$mci_reset_down_threshold := 10;

{ System Management variables.

  VAR
    nlv$sm_await_routing_queries: [XDCL, #GATE, oss$network_paged] nlt$sm_await_routing_queries :=
      [[0], NIL],
    nlv$sm_devices: [XDCL, #GATE, oss$network_paged] nlt$sm_devices := [[0, FALSE, 0], NIL],
    nlv$transport_network_selector: [XDCL, #GATE, oss$network_paged] nat$network_selector := 1;

{ Network Access Agent variables.

  VAR
    nlv$na_sap_list: [XDCL, #GATE, oss$network_paged] nlt$na_sap_list := [[0], [REP 256 OF FALSE],
      NIL];

{ Link Access Agent variables.

  VAR
    nlv$la_open_sap_list: [XDCL, #GATE, oss$network_paged] nlt$la_open_sap_list := [[0], NIL];

{ TCP/IP Management Access Agent variables.

  VAR
    nlv$log_tcpip_device_select: [XDCL, #GATE, oss$network_paged] boolean := FALSE;

{ Performance testing variables to externalize interesting values.

  VAR
    nlv$cc_grant_credit_trigger: [XDCL, #GATE, oss$network_paged] nlt$cc_credits := 4,
    nlv$cc_maximum_receive_window: [XDCL, #GATE, oss$network_paged] nlt$cc_credits := 12;


MODEND nam$static_data;
*DECK DECK=NAM$STORE_ATTRIBUTES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
MODULE nam$store_attributes;

{ MODULE DECK NAM$STORE_ATTRIBUTES }

?? TITLE := 'NOS/VE :  NETWORK ACCESS METHOD' ??
?? NEWTITLE := '  [XDCL] NAM$STORE_ATTRIBUTES' ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
*copyc AMK$ACCESS_METHOD
*copyc AMC$CONDITION_CODE_LIMITS
*copyc AME$IMPROPER_FILE_ID
*copyc nak$external_keypoints_job_mode
*copyc nat$external_keypoint_constants
*copyc OST$CALLER_IDENTIFIER
?? POP ??
*copyc BAP$VALIDATE_FILE_IDENTIFIER
*copyc OSP$SET_STATUS_ABNORMAL
?? EJECT ??
*copyc AMH$ALSO
?? EJECT ??
*copyc nah$store_attributes
 PROCEDURE [XDCL,#GATE] nap$store_attributes (
        file_identifier: amt$file_identifier;
        attributes: nat$change_attributes;
    VAR status: ost$status);

    CONST
      interface_name = 'NAP$STORE_ATTRIBUTES',
      fap_layer_number = 0;

    VAR
      bam_status: ost$status,
      caller_id: ost$caller_identifier,
      file_id_is_valid: boolean,
      call_block: amt$call_block,
      file_instance: ^bat$task_file_entry;


    #keypoint (osk$entry, osk$m * amk_store_attributes, nak$session_external);
    #caller_id (caller_id);
    status.normal := TRUE;
    bam_status.normal := TRUE;

*copy BAI$VALIDATE_FILE_IDENTIFIER

    IF NOT file_id_is_valid THEN
      osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id,
            interface_name, status);
      #keypoint (osk$exit, osk$m * amk_store_attributes, nak$session_external);
      RETURN;
    IFEND;

    call_block.operation := nac$store_attributes;

    call_block.store_attributes := ^attributes;

*copy BAI$CALL_FAP_CONTROL

    IF NOT bam_status.normal THEN
      IF (file_instance^.instance_attributes.dynamic_label.
            error_exit_procedure <> NIL) THEN
        file_instance^.instance_attributes.dynamic_label.
              error_exit_procedure^ (file_identifier, bam_status);
      IFEND;
      IF NOT bam_status.normal THEN
        status := bam_status;
      IFEND;
    IFEND;
    #keypoint (osk$exit, osk$m * amk_store_attributes, nak$session_external);
  PROCEND nap$store_attributes;
MODEND nam$store_attributes;
*DECK DECK=NAP$ACCEPT_CONNECTION EXPAND=FALSE

 PROCEDURE [XREF] nap$accept_connection (
        file: fst$file_reference;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$lfn_program_actions
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$ACCEPT_SWITCH_OFFER EXPAND=FALSE

  PROCEDURE [XREF] nap$accept_switch_offer (
        file: fst$file_reference;
        source: jmt$system_supplied_name;
        attributes: ^nat$change_attributes;
        wait_time: nat$wait_time;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jmt$system_supplied_name
*copyc nat$change_attributes
*copyc nat$wait_time
*copyc ost$status
*copyc ame$lfn_program_actions
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$ACQUIRE_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nap$acquire_connection (
        server: nat$application_name;
        file: fst$file_reference;
        attributes: ^nat$create_attributes;
        wait_time: nat$wait_time;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc fst$file_reference
*copyc nat$create_attributes
*copyc nat$wait_time
*copyc ost$status
*copyc ame$lfn_program_actions
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$ACQUIRE_SPECIFIC_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nap$acquire_specific_connection
   (    system_job_name: jmt$system_supplied_name;
        server: nat$application_name;
        file: fst$file_reference;
        attributes: ^nat$create_attributes;
        wait_time: nat$wait_time;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jmt$system_supplied_name
*copyc nat$application_name
*copyc nat$create_attributes
*copyc nat$wait_time
*copyc ost$status
?? POP ??
*DECK DECK=NAP$ACTIVATE_CLIENT EXPAND=FALSE

  PROCEDURE [XREF] nap$activate_client (client: nat$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$ACTIVATE_NETWORK_ALARMS EXPAND=FALSE
  PROCEDURE [XREF] nap$activate_network_alarms (communities: array [1 .. *] of nat$community_title;
    VAR status: ost$status);
?? PUSH (LISTEXT:=ON) ??
*copyc nat$community_title
*copyc ost$status
?? POP ??
*DECK DECK=NAP$ACTIVATE_NETWORK_CONFIG EXPAND=FALSE
  PROCEDURE [XREF] nap$activate_network_config (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=NAP$ACTIVATE_SERVER EXPAND=FALSE

  PROCEDURE [XREF] nap$activate_server (server: nat$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$ACTIVATE_TCPIP EXPAND=FALSE

  PROCEDURE [XREF] nap$activate_tcpip
    (    application: nat$application_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$ADD_BUFFER_POOLS EXPAND=FALSE

  PROCEDURE [XREF] nap$add_buffer_pools
    (    reserved_buffers: nlt$bm_buffer_list_array);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_buffer_list_array
?? POP ??
*DECK DECK=NAP$ADD_SERVER_TITLE EXPAND=FALSE

  PROCEDURE [XREF] nap$add_server_title (
         server: nat$application_name;
         title: nat$title;
         attributes: ^nat$title_attributes;
         broadcast_registration: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$title
*copyc nat$application_name
*copyc nat$title_attributes
*copyc ost$status
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$ADD_TCP_SOCKET_LIST EXPAND=FALSE
  PROCEDURE [INLINE] nap$add_tcp_socket_list
    (    socket_assigned: boolean;
         connection_id: nat$connection_id;
     VAR tcpip_attributes: ^nat$tcpip_attributes);

?? PUSH (listext := ON) ??
    VAR
      tcp_socket_entry: ^nat$tcp_socket;

    REPEAT
      ALLOCATE tcp_socket_entry IN nav$network_paged_heap^;
      IF tcp_socket_entry = NIL THEN
        syp$cycle;
      IFEND;
    UNTIL tcp_socket_entry <> NIL;
    tcp_socket_entry^.connection_id := connection_id;
    tcp_socket_entry^.socket_assigned := socket_assigned;
    tcp_socket_entry^.next_entry := tcpip_attributes^.
          tcp_socket_list;
    tcpip_attributes^.tcp_socket_list := tcp_socket_entry;
  PROCEND nap$add_tcp_socket_list;

*copyc nah$add_tcp_socket_list

*copyc nat$tcpip_attributes
*copyc nat$connection_id
*copyc nav$network_paged_heap
*copyc syp$cycle
?? POP ??
*DECK DECK=NAP$ADD_UDP_SOCKET_LIST EXPAND=FALSE
  PROCEDURE [INLINE] nap$add_udp_socket_list
    (    global_socket_id: nlt$udp_global_socket_id;
     VAR tcpip_attributes: ^nat$tcpip_attributes);

?? PUSH (listext := ON) ??

    VAR
      udp_socket_entry: ^nat$udp_socket;

    REPEAT
      ALLOCATE udp_socket_entry IN nav$network_paged_heap^;
      IF udp_socket_entry = NIL THEN
        syp$cycle;
      IFEND;
    UNTIL udp_socket_entry <> NIL;
    udp_socket_entry^.global_socket_id := global_socket_id;
    udp_socket_entry^.next_entry := tcpip_attributes^.udp_socket_list;
    tcpip_attributes^.udp_socket_list := udp_socket_entry;
  PROCEND nap$add_udp_socket_list;

*copyc nah$add_udp_socket_list

*copyc nat$tcpip_attributes
*copyc nlt$udp_global_socket_id
*copyc nav$network_paged_heap
*copyc syp$cycle
?? POP ??
*DECK DECK=NAP$APPLICATIONS_INSTALLED EXPAND=FALSE
*DECK DECK=NAP$ATTACH_APPLICATION_FILE EXPAND=FALSE
  PROCEDURE [XREF] nap$attach_application_file (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=NAP$ATTACH_SERVER_APPLICATION EXPAND=FALSE

  PROCEDURE [XREF] nap$attach_server_application (
        server: nat$application_name;
        maximum_connections: nat$number_of_connections;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$number_of_connections
*copyc ost$status
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$ATTACH_SPECIFIC_SERVER_APPL EXPAND=FALSE

  PROCEDURE [XREF] nap$attach_specific_server_appl
    (    system_job_name: jmt$system_supplied_name;
         server: nat$application_name;
         max_connections: nat$number_of_connections;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc jmt$system_supplied_name
*copyc nat$application_name
*copyc nat$number_of_connections
*copyc ost$status
?? POP ??
*DECK DECK=NAP$AWAIT_DATA_AVAILABLE EXPAND=FALSE

  PROCEDURE [XREF] nap$await_data_available (
        file_identifier: amt$file_identifier;
        wait_time: nat$wait_time;
        expected_wait_time: nat$wait_time;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc nat$wait_time
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$AWAIT_SERVER_RESPONSE EXPAND=FALSE

  PROCEDURE [XREF] nap$await_server_response (
        file: fst$file_reference;
        wait_time: nat$wait_time;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc nat$wait_time
*copyc ost$status
*copyc ame$lfn_program_actions
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$BEGIN_DIRECTORY_SEARCH EXPAND=FALSE

  PROCEDURE [XREF] nap$begin_directory_search (
         title_pattern: nat$title_pattern;
         client: nat$application_name;
         recurrent_search: boolean;
     VAR search_identifier: nat$directory_search_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$title_pattern
*copyc nat$application_name
*copyc nat$directory_search_identifier
*copyc ost$status
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$BUILD_MASTER_CONTROL_TABLE EXPAND=FALSE

  PROCEDURE [XREF] nap$build_master_control_table
    (    logical_unit: iot$logical_unit;
         device_id: nlt$device_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc nlt$device_identifier
?? POP ??
*DECK DECK=NAP$CANCEL_SWITCH_OFFER EXPAND=FALSE

  PROCEDURE [XREF] nap$cancel_switch_offer (
        file: fst$file_reference;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc ame$lfn_program_actions
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$CHANGE_ATTRIBUTES EXPAND=FALSE

 PROCEDURE [XREF] nap$change_attributes (
        file: fst$file_reference;
        attributes: nat$change_attributes;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc nat$change_attributes
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$lfn_program_actions
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$CHANGE_CLIENT EXPAND=FALSE
  PROCEDURE [XREF] nap$change_client
    (    client: nat$application_name;
         max_connections: nat$number_of_connections;
         connection_priority: nat$network_message_priority;
         reserved_application_id: boolean;
         application_id: nat$internet_sap_identifier;
         client_capability: ost$name;
         client_ring: ost$ring;
         client_system_privilege: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$internet_sap_identifier
*copyc nat$network_message_priority
*copyc nat$number_of_connections
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$CHANGE_NAM_ATTRIBUTES_R1 EXPAND=FALSE

  PROCEDURE [XREF] nap$change_nam_attributes_r1 (
        attribute_kind: nat$nam_attribute_kind;
        attribute: nat$nam_attribute);

?? PUSH (LISTEXT := ON) ??
*copyc nat$nam_attributes
?? POP ??
*DECK DECK=NAP$CHANGE_NAM_ATTRIBUTES_R3 EXPAND=FALSE
  PROCEDURE [XREF] nap$change_nam_attributes_r3 (
         nam_attributes: nat$nam_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc nat$nam_attributes
?? POP ??
*DECK DECK=NAP$CHANGE_NETWORK_DEVICE_STATE EXPAND=FALSE
  PROCEDURE [XREF] nap$change_network_device_state
    (    element: cmt$element_name;
         new_state: cmt$element_state;
         old_state: cmt$element_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$element_state
*copyc ost$status
?? POP ??
*DECK DECK=NAP$CHANGE_SERVER EXPAND=FALSE
  PROCEDURE [XREF] nap$change_server
    (    server: nat$application_name;
         selected_titles_changed: boolean;
         selected_titles: ^nat$selected_titles_list;
         server_managed_titles: ^nat$title_pattern_list;
         max_connections: nat$number_of_connections;
         connection_priority: nat$network_message_priority;
         server_capability: ost$name;
         server_ring: ost$ring;
         server_system_privilege: boolean;
         accept_connection: boolean;
         client_validation_capability: ost$name;
         client_info_source: nat$client_info_source;
         client_addresses: ^array [1 .. * ] of nat$client_address;
         reserved_application_id: boolean;
         application_id: nat$internet_sap_identifier;
         server_job_changed: boolean;
         server_job: amt$local_file_name;
         server_job_validation_source: nat$server_validation_source;
         server_job_max_connections: nat$number_of_connections;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc nat$application_name
*copyc nat$internet_sap_identifier
*copyc nat$network_address
*copyc nat$network_message_priority
*copyc nat$number_of_connections
*copyc nat$server_attributes
*copyc nat$title_pattern_list
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
?? POP ??

*DECK DECK=NAP$CHANGE_TCPIP EXPAND=FALSE

  PROCEDURE [XREF] nap$change_tcpip
    (    application: nat$application_name;
         maximum_sockets: nat$number_of_sockets;
         tcpip_capability: ost$name;
         tcpip_ring: ost$ring;
         tcpip_system_privilege: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$number_of_sockets
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$CHECK_CONNECTION EXPAND=FALSE
  PROCEDURE [XREF] nap$check_connection (server: nat$application_name;
    VAR activity_complete: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$CHECK_DATA_AVAILABLE EXPAND=FALSE

 PROCEDURE [XREF] nap$check_data_available (
        file_identifier: amt$file_identifier;
    VAR activity_complete: boolean;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??

*DECK DECK=NAP$CHECK_SERVER_RESPONSE EXPAND=FALSE

 PROCEDURE [XREF] nap$check_server_response (
        file: fst$file_reference;
    VAR activity_complete: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??

*DECK DECK=NAP$CHECK_SWITCH_ACCEPT EXPAND=FALSE
  PROCEDURE [XREF] nap$check_switch_accept (file: fst$file_reference;
    VAR activity_complete: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=NAP$CHECK_SWITCH_OFFER EXPAND=FALSE
  PROCEDURE [XREF] nap$check_switch_offer (source: jmt$system_supplied_name;
    VAR activity_complete: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$CHECK_TITLE_TRANSLATION EXPAND=FALSE
  PROCEDURE [XREF] nap$check_title_translation (translation_request:
    nat$directory_search_identifier;
    VAR activity_complete: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$directory_search_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$CLEAR_SWITCH_OFFER EXPAND=FALSE

  PROCEDURE [XREF] nap$clear_switch_offer (
        file: fst$file_reference;
        switch_offer_complete: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc OST$STATUS
?? POP ??
*DECK DECK=NAP$CLONE_CONNECTION EXPAND=FALSE
  PROCEDURE [XREF] nap$clone_connection (
        server: nat$application_name;
        file: fst$file_reference;
        attributes: ^nat$create_attributes;
        wait_time: nat$wait_time;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc fst$file_reference
*copyc nat$create_attributes
*copyc nat$wait_time
*copyc ost$status
*copyc ame$lfn_program_actions
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$CLOSE_FILE EXPAND=FALSE

  PROCEDURE [XREF] nap$close_file (file_identifier: amt$file_identifier;
        layer: amt$fap_layer_number;
        call_block: amt$call_block;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$CLOSE_NETWORK_SAP EXPAND=FALSE

  PROCEDURE [XREF] nap$close_network_sap
    (    sap: nat$network_sap_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$namve_conditions
*copyc nat$network_sap_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$CLOSE_SERVER_JOB_FILE EXPAND=FALSE

  PROCEDURE [XREF] nap$close_server_job_file (server_file_identifier: amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$CN_CLOSE_SAP EXPAND=FALSE
 PROCEDURE [XREF] nap$cn_close_sap (sap: nat$cn_sap_id;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$cn_interface
*copyc ost$status
?? POP ??
*DECK DECK=NAP$CN_DELIVER_DATAGRAM EXPAND=FALSE
  PROCEDURE [XREF] nap$cn_deliver_datagram
    (    sap_id: nat$cn_sap_id;
         device: nlt$device_identifier;
         source: nat$system_address;
         datagram: nlt$bm_message_id);

?? PUSH (LISTEXT := ON) ??
*copyc nat$cn_interface
*copyc nat$network_address
*copyc nlt$device_identifier
*copyc nlt$bm_message_id
?? POP ??
*DECK DECK=NAP$CN_FLAG_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] nap$cn_flag_handler (flag_id: ost$system_flag);

?? PUSH (LISTEXT := ON) ??
*copyc ost$system_flag
?? POP ??
*DECK DECK=NAP$CN_OPEN_SAP EXPAND=FALSE
 PROCEDURE [XREF] nap$cn_open_sap (sap: nat$cn_sap_id;
    VAR maximum_data_length: nat$data_length;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$cn_interface
*copyc nat$data_fragments
*copyc ost$status
?? POP ??
*DECK DECK=NAP$CN_RECEIVE_DATAGRAM EXPAND=FALSE
 PROCEDURE [XREF] nap$cn_receive_datagram (sap: nat$cn_sap_id;
        data_area: nat$data_fragments;
        wait_time: 0 .. 0ffffffff(16);
    VAR device: nlt$device_identifier;
    VAR source: nat$system_address;
    VAR received_data_length: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$cn_interface
*copyc nat$data_fragments
*copyc nat$network_address
*copyc nlt$device_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$CN_SEND_DATAGRAM EXPAND=FALSE
 PROCEDURE [XREF] nap$cn_send_datagram (sap: nat$cn_sap_id;
        device: nlt$device_identifier;
        destination: nat$system_address;
        data: nat$data_fragments;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$cn_interface
*copyc nat$data_fragments
*copyc nat$network_address
*copyc nlt$device_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$CN_SIGNAL_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] nap$cn_signal_handler (originator: ost$global_task_id;
    signal: pmt$signal);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc pmt$signal
?? POP ??
*DECK DECK=NAP$COMPUTE_ETHERNET_CHECKSUM EXPAND=FALSE

  PROCEDURE [INLINE] nap$compute_ethernet_checksum
    (    ethernet_address: nat$system_identifier;
     VAR checksum: nat$checksum_value);

?? PUSH (LISTEXT := ON) ??
*copy nah$compute_ethernet_checksum


    VAR
      i: integer,
      octets: ^array [0 .. 5] of 0 .. 0ff(16),
      running_checksum: integer;

    octets := #LOC (ethernet_address);

    running_checksum := 0;
    FOR i := 0 TO 2 DO
      running_checksum := running_checksum * 2;
      IF running_checksum >= 65536 THEN
        running_checksum := running_checksum - 65535;
      IFEND;
      running_checksum := running_checksum + 256 * octets^ [i * 2] + octets^ [(i * 2) + 1];
      IF running_checksum >= 65536 THEN
        running_checksum := running_checksum - 65535;
      IFEND;
    FOREND;
    IF running_checksum = 65535 THEN
      running_checksum := 0;
    IFEND;
    checksum := running_checksum;

  PROCEND nap$compute_ethernet_checksum;

*copyc nat$checksum
*copyc nat$system_identifier
?? POP ??

*DECK DECK=NAP$CREATE_NETWORK_FILE EXPAND=FALSE

  PROCEDURE [XREF] nap$create_network_file (
        file: fst$file_reference;
        attributes: ^nat$create_attributes;
        connection_id: nat$connection_id;
        file_exists: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc FST$FILE_REFERENCE
*copyc nat$create_attributes
*copyc nat$connection_id
*copyc OST$STATUS
?? POP ??
*DECK DECK=NAP$DEACTIVATE_CLIENT EXPAND=FALSE

  PROCEDURE [XREF] nap$deactivate_client (client: nat$application_name;
    terminate_active_connections: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$DEACTIVATE_NETWORK_ALARMS EXPAND=FALSE
  PROCEDURE [XREF] nap$deactivate_network_alarms (VAR status: ost$status);
?? PUSH (LISTEXT:=ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=NAP$DEACTIVATE_SERVER EXPAND=FALSE

  PROCEDURE [XREF] nap$deactivate_server (server: nat$application_name;
    terminate_active_connections: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$DEACTIVATE_TCPIP EXPAND=FALSE

  PROCEDURE [XREF] nap$deactivate_tcpip
    (    application: nat$application_name;
         terminate_active_sockets: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$DEFINE_CLIENT EXPAND=FALSE
  PROCEDURE [XREF] nap$define_client (client: nat$application_name;
        max_connections: nat$number_of_connections;
        connection_priority: nat$network_message_priority;
        protocol: nat$protocol;
        reserved_application_id: boolean;
        application_id: nat$internet_sap_identifier;
        client_capability: ost$name;
        client_ring: ost$ring;
        client_system_privilege: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$internet_sap_identifier
*copyc nat$network_message_priority
*copyc nat$number_of_connections
*copyc nat$protocol
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$DEFINE_SERVER EXPAND=FALSE


  PROCEDURE [XREF] nap$define_server (server: nat$application_name;
        selected_titles: ^nat$selected_titles_list;
        server_managed_titles: ^nat$title_pattern_list;
        max_connections: nat$number_of_connections;
        connection_priority: nat$network_message_priority;
        server_capability: ost$name;
        server_ring: ost$ring;
        server_system_privilege: boolean;
        accept_connection: boolean;
        client_validation_capability: ost$name;
        client_info_source: nat$client_info_source;
        client_addresses: ^array [1 .. * ] OF nat$client_address,
        reserved_application_id: boolean;
        application_id: nat$internet_sap_identifier;
        protocol: nat$protocol;
        nam_initiated_server: boolean;
        server_job: amt$local_file_name;
        server_job_validation_source: nat$server_validation_source,
        server_job_max_connections: nat$number_of_connections;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc nat$application_name
*copyc nat$internet_sap_identifier
*copyc nat$network_address
*copyc nat$network_message_priority
*copyc nat$number_of_connections
*copyc nat$protocol
*copyc nat$server_attributes
*copyc nat$title_pattern_list
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
?? POP ??

*DECK DECK=NAP$DEFINE_TCPIP EXPAND=FALSE

  PROCEDURE [XREF] nap$define_tcpip
    (    application: nat$application_name;
         maximum_sockets: nat$number_of_sockets;
         tcpip_capability: ost$name;
         tcpip_ring: ost$ring;
         tcpip_system_privilege: boolean;
         protocol: nat$protocol;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$number_of_sockets
*copyc nat$protocol
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$DELETE_CLIENT EXPAND=FALSE

  PROCEDURE [XREF] nap$delete_client (client: nat$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$DELETE_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nap$delete_connection (application: nat$application_name;
        server_or_client: nat$application_type;
        connection_id: nat$connection_id;
    VAR active_file: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$application_type
*copyc nat$connection_id
*copyc ost$status
?? POP ??


*DECK DECK=NAP$DELETE_SERVER EXPAND=FALSE

  PROCEDURE [XREF] nap$delete_server (server: nat$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$DELETE_SERVER_TITLE EXPAND=FALSE

  PROCEDURE [XREF] nap$delete_server_title (
         server: nat$application_name;
         title_pattern: nat$title_pattern;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$title_pattern
*copyc ost$status
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$DELETE_TCPIP EXPAND=FALSE

  PROCEDURE [XREF] nap$delete_tcpip
    (    application: nat$application_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$DELIVER_NETWORK_EVENT EXPAND=FALSE

  PROCEDURE [XREF] nap$deliver_network_event
    (    sap: nat$network_selector;
         source_address: nat$osi_network_address;
         device_id: nlt$device_identifier;
         data: nlt$bm_message_id);

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_selector
*copyc nat$osi_network_address
*copyc nlt$bm_message_id
*copyc nlt$device_identifier
?? POP ??
*DECK DECK=NAP$DETACH_APPLICATION_FILE EXPAND=FALSE


  PROCEDURE [XREF] nap$detach_application_file (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=NAP$DETACH_SERVER_APPLICATION EXPAND=FALSE

  PROCEDURE [XREF] nap$detach_server_application (
        server: nat$application_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc ost$status
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$DETACH_SPECIFIC_SERVER_APPL EXPAND=FALSE

  PROCEDURE [XREF] nap$detach_specific_server_appl
    (    system_job_name: jmt$system_supplied_name;
         server: nat$application_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc nat$application_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$DISPLAY_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] nap$display_message (status_message: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=NAP$DISPLAY_NETWORK_CONFIG EXPAND=FALSE



  PROCEDURE [XREF] nap$display_network_config (display_option: nat$display_option;
    VAR display_control: clt$display_control;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$display_option
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=NAP$END_COMMAND_PROCESSING EXPAND=FALSE
  PROCEDURE [XREF] nap$end_command_processing (VAR status: ost$status);

?? PUSH (LISTEXT:=ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=NAP$END_DIRECTORY_SEARCH EXPAND=FALSE

  PROCEDURE [XREF] nap$end_directory_search (
         search_identifier: nat$directory_search_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$directory_search_identifier
*copyc ost$status
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$FETCH_ATTRIBUTES EXPAND=FALSE

 PROCEDURE [XREF] nap$fetch_attributes (
        file_identifier: amt$file_identifier;
    VAR attributes: {input, output} nat$get_attributes;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc nat$get_attributes
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
*copyc nae$namve_conditions
?? POP ??
*DECK DECK=NAP$FIND_CLIENT_ATTRIBUTES EXPAND=FALSE
?? TITLE := 'NAP$FIND_CLIENT_ATTRIBUTES', EJECT ??
  PROCEDURE [INLINE] nap$find_client_attributes (client: nat$application_name;
    VAR client_attributes: ^nat$client_attributes);

{ It is assumed that client attributes list has been locked by the caller.

    client_attributes := nav$client_attributes_list.client_attributes;
    WHILE (client_attributes <> NIL) AND (client_attributes^.client <> client) DO
      client_attributes := client_attributes^.next_entry;
    WHILEND;

  PROCEND nap$find_client_attributes;
*DECK DECK=NAP$FIND_SAP_PRIORITY EXPAND=FALSE

  PROCEDURE [XREF] nap$find_sap_priority
    (    sap_id: nat$sap_identifier;
     VAR priority: nat$network_message_priority);

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_message_priority
*copyc nat$sap_identifier
?? POP ??
*DECK DECK=NAP$FIND_SERVER_ATTRIBUTES EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? TITLE := ' [INLINE] nap$find_server_attributes', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nat$server_attributes
*copyc nat$application_name
?? POP ??


  PROCEDURE [INLINE] nap$find_server_attributes (application_name: nat$application_name;
    VAR server_attributes: ^nat$server_attributes);

{ It is assumed that the server_attributes_list has been locked by the caller.

    server_attributes := nav$server_attributes_list.server_attributes;
    WHILE (server_attributes <> NIL) AND (server_attributes^.server <> application_name) DO
      server_attributes := server_attributes^.next_entry;
    WHILEND;

  PROCEND nap$find_server_attributes;
*DECK DECK=NAP$FIND_TCPIP_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [INLINE] nap$find_tcpip_attributes
    (    application_name: nat$application_name;
     VAR tcpip_attributes: ^nat$tcpip_attributes);

?? PUSH (LISTEXT := ON) ??

    tcpip_attributes := nav$tcpip_attributes_list.tcpip_attributes;
    WHILE (tcpip_attributes <> NIL) AND (tcpip_attributes^.tcpip_application <> application_name) DO
      tcpip_attributes := tcpip_attributes^.next_entry;
    WHILEND;

  PROCEND nap$find_tcpip_attributes;

*copyc nah$find_tcpip_attributes

*copyc nat$tcpip_attributes
*copyc nat$application_name
*copyc nav$tcpip_attributes_list
?? POP ??
*DECK DECK=NAP$FLUSH_UNIT_QUEUE EXPAND=FALSE
  PROCEDURE [XREF] nap$flush_unit_queue
    (    network_device: ^nlt$network_device;
      VAR message_id_list: ^array [1..*] of nlt$bm_message_id);
?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_descriptor
*copyc nlt$network_device
?? POP ??
*DECK DECK=NAP$FREE_PP_BUFFER_DESCRIPTOR EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$free_pp_buffer_descriptor;

*DECK DECK=NAP$FREE_PP_BUFFER_POOLS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$free_pp_buffer_pools;

*DECK DECK=NAP$FREE_PP_SEND_QUEUE_TAILS EXPAND=FALSE

  PROCEDURE [XREF] nap$free_pp_send_queue_tails;
*DECK DECK=NAP$FREE_REQUEST_BLOCK EXPAND=FALSE
?? RIGHT := 110 ??
  PROCEDURE [INLINE] nap$free_request_block
    (VAR request_block {INPUT, OUTPUT} : ^nat$request_block);
?? PUSH (LISTEXT := ON) ??

    VAR
      initial,
      new,
      actual: nat$preallocated_rb_control,
      cs_status: osc$cs_successful .. osc$cs_variable_locked,
      complete_request: ^nat$complete_request_block;

    IF request_block^.allocation_description.preallocated THEN
      initial.first_free_block := UPPERVALUE (nat$request_block_identifier);
      initial.sequence_number := 0;
      new := initial;
      REPEAT
        #compare_swap (nav$preallocated_rb_control, initial, new, actual, cs_status);
      UNTIL (cs_status <> osc$cs_variable_locked);

      initial := actual;
      request_block^.allocation_description.next_block_identifier := initial.first_free_block;
      new.first_free_block := request_block^.allocation_description.block_identifier;
      new.sequence_number := initial.sequence_number;
      REPEAT
        #compare_swap (nav$preallocated_rb_control, initial, new, actual, cs_status);
        CASE cs_status OF
        = osc$cs_successful =
          ;
        = osc$cs_failed =
          initial := actual;
          request_block^.allocation_description.next_block_identifier := initial.first_free_block;
          new.first_free_block := request_block^.allocation_description.block_identifier;
          new.sequence_number := initial.sequence_number;
        = osc$cs_variable_locked =
          ;
        CASEND;
      UNTIL (cs_status = osc$cs_successful);
    ELSE
      complete_request := request_block^.complete_request_block;
      FREE complete_request IN osv$mainframe_wired_cb_heap^;
    IFEND;
    request_block := NIL;
  PROCEND nap$free_request_block;

*copy nah$free_request_block
*copyc nat$preallocated_rb_control
*copyc nat$request_block
*copyc nav$preallocated_rb_control
*copyc ost$signature_lock
*copyc osv$mainframe_wired_cb_heap
*copyc i#real_memory_address
?? POP ??
*DECK DECK=NAP$GENERATE_NETWORK_MESSAGE EXPAND=FALSE
  PROCEDURE [XREF] nap$generate_network_message (network_message: SEQ ( * );
    VAR display_control: clt$display_control;
    VAR status: ost$status);

?? PUSH (LISTEXT:=ON) ??
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GET_APPLICATION_NAMES EXPAND=FALSE
  PROCEDURE [XREF] nap$get_application_names
    (    type_of_applications: set of nat$application_type;
     VAR application_attributes: array [1 .. * ] of nat$application_attribute;
     VAR number_of_applications: nat$max_applications;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_type
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GET_APPLICATION_TYPE EXPAND=FALSE
  PROCEDURE [XREF] nap$get_application_type (application: nat$application_name;
    VAR application_type: nat$application_type;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$application_type
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GET_ATTRIBUTES EXPAND=FALSE

 PROCEDURE [XREF] nap$get_attributes (
        file: fst$file_reference;
    VAR attributes: {input, output} nat$get_attributes;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc nat$get_attributes
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$lfn_program_actions
*copyc nae$application_interfaces
*copyc nae$namve_conditions
?? POP ??
*DECK DECK=NAP$GET_CATALOG_FILE_COUNT EXPAND=FALSE
 PROCEDURE [XREF] nap$get_catalog_file_count (path: pft$path;
    VAR files: 0 .. 7fffffff(16);
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=NAP$GET_CLIENT_ATTRIBUTES EXPAND=FALSE
  PROCEDURE [XREF] nap$get_client_attributes (client: nat$application_name;
        VAR client_status: nat$application_status;
        VAR max_connections: nat$number_of_connections;
        VAR connection_priority: nat$network_message_priority;
        VAR protocol: nat$protocol;
        VAR reserved_application_id: boolean;
        VAR application_id: nat$internet_sap_identifier;
        VAR client_capability: ost$name;
        VAR client_ring: ost$ring;
        VAR client_system_privilege: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$application_status
*copyc nat$internet_sap_identifier
*copyc nat$network_message_priority
*copyc nat$number_of_connections
*copyc nat$protocol
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
?? POP ??

*DECK DECK=NAP$GET_CLIENT_STATUS EXPAND=FALSE
  PROCEDURE [XREF] nap$get_client_status (client: nat$application_name;
    VAR client_status: nat$application_status;
    VAR reserved_application_id: boolean;
    VAR application_id: nat$internet_sap_identifier;
    VAR active_connection_count: nat$number_of_connections;
    VAR attempted_connection_count: integer;
    VAR rejected_connection_attempts: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$application_status
*copyc nat$internet_sap_identifier
*copyc nat$number_of_connections
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GET_CONNECTION_IDENTIFIER EXPAND=FALSE

  PROCEDURE [XREF] nap$get_connection_identifier (
        file: fst$file_reference;
    VAR connection_id: nat$connection_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc NAT$CONNECTION_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=NAP$GET_CONNECTION_STATE EXPAND=FALSE

  PROCEDURE [XREF] nap$get_connection_state
    (    connection_id: nat$connection_id;
     VAR connection_state: nat$connection_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc nat$connection_state
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GET_CONNECT_DATA EXPAND=FALSE
  PROCEDURE [XREF] nap$get_connect_data
    (    peer_connect_data: ^SEQ ( * );
     VAR connect_data: jmt$service_data;
     VAR connect_data_length: jmt$service_data_length;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$service_data
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GET_CONNECT_TIME_INTERVAL EXPAND=FALSE

  PROCEDURE [XREF] nap$get_connect_time_interval
    (    file: fst$file_reference;
     VAR connect_time: ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc osd$integer_limits
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GET_FILE_CYCLE_COUNT EXPAND=FALSE
 PROCEDURE [XREF] nap$get_file_cycle_count (path: pft$path;
    VAR cycles: 0 .. pfc$maximum_cycle_number;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=NAP$GET_INTRANET_STATISTICS EXPAND=FALSE
  PROCEDURE [XREF] nap$get_intranet_statistics
    (    incremental: boolean;
     VAR intranet_stats: ost$intranet_statistics);

?? PUSH (LISTEXT := ON) ??
*copyc ost$data_id
?? POP ??
*DECK DECK=NAP$GET_NAMVE_STATISTICS EXPAND=FALSE
  PROCEDURE [XREF] nap$get_namve_statistics
    (    incremental: boolean;
     VAR namve_stats: ost$namve_statistics);

?? PUSH (LISTEXT := ON) ??
*copyc ost$data_id
?? POP ??
*DECK DECK=NAP$GET_NAM_ATTRIBUTES_R1 EXPAND=TRUE
  PROCEDURE [XREF] nap$get_nam_attributes_r1 (
        attribute_kind: nat$nam_attribute_kind;
    VAR attribute: nat$nam_attribute);

?? PUSH (LISTEXT := ON) ??
*copyc nat$nam_attributes
?? POP ??
*DECK DECK=NAP$GET_NAM_ATTRIBUTES_R3 EXPAND=TRUE
  PROCEDURE [XREF] nap$get_nam_attributes_r3 (
    VAR nam_attributes: nat$nam_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$nam_attributes
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GET_OSI_DEVICE_SPEC_STATS EXPAND=FALSE

  PROCEDURE [XREF] nap$get_osi_device_spec_stats
    (    incremental: boolean;
     VAR channel_device_statistic: ost$channel_device_statistics);

?? PUSH (LISTEXT := ON) ??
*copyc ost$data_id
?? POP ??

*DECK DECK=NAP$GET_OSI_STATISTICS EXPAND=FALSE

  PROCEDURE [XREF] nap$get_osi_statistics
    (    incremental: boolean;
     VAR namve_osi_statistic: ost$namve_osi_statistics);

?? PUSH (LISTEXT := ON) ??
*copyc ost$data_id
?? POP ??
*DECK DECK=NAP$GET_RECEIVED_MESSAGES EXPAND=FALSE

  PROCEDURE [XREF] nap$get_received_messages (xcb_list: boolean;
    VAR received_messages: ^nlt$bm_message_descriptor);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_descriptor
?? POP ??
*DECK DECK=NAP$GET_REQUEST_BLOCK EXPAND=FALSE
?? RIGHT := 110 ??

  PROCEDURE [INLINE] nap$get_request_block (rma_list_length: integer;
    VAR request_block: ^nat$request_block);
?? PUSH (LISTEXT := ON) ??

    VAR
      initial,
      new,
      actual: nat$preallocated_rb_control,
      cs_status: osc$cs_successful .. osc$cs_variable_locked,
      io_request: ^iot$io_request,
      request_block_length: integer,
      complete_request: ^nat$complete_request_block,
      complete_request_block: ^SEQ ( * ),
      peripheral_request: ^nat$peripheral_request,
      peripheral_request_rma: integer;

    request_block := NIL;
    IF ((rma_list_length > 0) AND (rma_list_length <= UPPERVALUE (nat$fixed_rma_list))) THEN
      initial.first_free_block := UPPERVALUE (nat$request_block_identifier);
      initial.sequence_number := 0;
      new := initial;
      REPEAT
        #compare_swap (nav$preallocated_rb_control, initial, new, actual, cs_status);
      UNTIL (cs_status <> osc$cs_variable_locked);

    /get_preallocated_block/
      BEGIN
        IF (actual.first_free_block <> 0) THEN
          initial := actual;
          new.first_free_block := nav$preallocated_request_block^ [initial.first_free_block]^.
                allocation_description.next_block_identifier;
          new.sequence_number := initial.sequence_number + 1;
          REPEAT
            #compare_swap (nav$preallocated_rb_control, initial, new, actual, cs_status);
            CASE cs_status OF
            = osc$cs_successful =
              request_block := nav$preallocated_request_block^ [initial.first_free_block];
            = osc$cs_failed =
              IF (actual.first_free_block <> 0) THEN
                initial := actual;
                new.first_free_block := nav$preallocated_request_block^ [initial.first_free_block]^.
                      allocation_description.next_block_identifier;
                new.sequence_number := initial.sequence_number + 1;
              ELSE
                EXIT /get_preallocated_block/;
              IFEND;
            = osc$cs_variable_locked =
              ;
            CASEND;
          UNTIL (cs_status = osc$cs_successful);
        IFEND;
      END /get_preallocated_block/;
    IFEND;

    IF (request_block = NIL) THEN
      request_block_length := ((((#SIZE (nat$request_block) + #SIZE (ost$word) - 1) DIV #SIZE (ost$word)) *
            #SIZE (ost$word)) + (#SIZE (mmt$rma_list_entry) * rma_list_length));
      ALLOCATE complete_request: [[REP request_block_length OF cell]] IN osv$mainframe_wired_cb_heap^;
      complete_request_block := ^complete_request^.complete_sequence;
      RESET complete_request_block;
      NEXT request_block IN complete_request_block;
      request_block^.complete_request_block := complete_request;

      IF (rma_list_length = 0) THEN
        request_block^.network_request.rma_list := NIL;
      ELSE
        NEXT request_block^.network_request.rma_list: [1 .. rma_list_length] IN complete_request_block;
      IFEND;

      request_block^.io_request.response_processor_p := nav$network_response_processor;
      request_block^.io_request.device_request_p := #LOC (request_block^.network_request);
      request_block^.io_request.pp_request_p := ^request_block^.network_request.peripheral_request;

      request_block^.network_request.request_block_link := NIL;
      request_block^.network_request.peripheral_request.recovery := ioc$attempt_recovery;
      request_block^.network_request.peripheral_request.interrupt.value := TRUE;
      request_block^.network_request.peripheral_request.priority := 1;

      request_block^.allocation_description.preallocated := FALSE;

      i#real_memory_address (^request_block^.network_request.peripheral_request, peripheral_request_rma);
      request_block^.peripheral_request_rma := peripheral_request_rma;
    IFEND;
    request_block^.network_request.peripheral_request.next_pp_request_rma := 0;
    request_block^.network_request.peripheral_request.pp_request := ^request_block^.io_request;
    request_block^.network_request.message_id.descriptor := NIL;
    request_block^.network_request.peripheral_request.request_length := #SIZE (nat$peripheral_request);
    request_block^.network_request.peripheral_request.interrupt.port_number :=
          osv$external_interrupt_selector;
  PROCEND nap$get_request_block;

*copy nah$get_request_block
*copyc iot$io_request
*copyc iot$request_recovery
*copyc nat$preallocated_rb_control
*copyc nat$request_block
*copyc nav$preallocated_rb_control
*copyc nav$preallocated_request_block
*copyc ost$hardware_subranges
*copyc ost$signature_lock
*copyc osv$mainframe_wired_cb_heap
*copyc osv$external_interrupt_selector
*copyc i#real_memory_address
?? POP ??
*DECK DECK=NAP$GET_SENT_MESSAGES EXPAND=FALSE
 PROCEDURE [XREF] nap$get_sent_messages
   (    message_id_array: ^array [1 .. * ] OF nlt$bm_message_id;
    VAR message_count: 0 .. 0ff(16);
    VAR more_messages: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_id
?? POP ??
*DECK DECK=NAP$GET_SERVER_ATTRIBUTES EXPAND=FALSE
  PROCEDURE [XREF] nap$get_server_attributes (server: nat$application_name;
    VAR server_status: nat$application_status;
    VAR selected_title_count: nat$max_titles;
        selected_titles: ^nat$selected_titles_list;
    VAR server_managed_title_count: nat$max_titles;
        server_managed_titles: ^nat$title_pattern_list;
    VAR max_connections: nat$number_of_connections;
    VAR connection_priority: nat$network_message_priority;
    VAR server_capability: ost$name;
    VAR server_ring: ost$ring;
    VAR server_system_privilege: boolean;
    VAR accept_connection: boolean;
    VAR client_validation_capability: ost$name;
    VAR client_info_source: nat$client_info_source;
    VAR client_address_count: integer;
        client_addresses: ^array [1 .. * ] OF nat$client_address;
    VAR reserved_application_id: boolean;
    VAR application_id: nat$internet_sap_identifier;
    VAR protocol: nat$protocol;
    VAR nam_initiated_server: boolean;
    VAR server_job_validation_source: nat$server_validation_source;
    VAR server_job_max_connections: nat$number_of_connections;
    VAR server_job_specified: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$application_status
*copyc nat$internet_sap_identifier
*copyc nat$network_message_priority
*copyc nat$number_of_connections
*copyc nat$protocol
*copyc nat$server_attributes
*copyc nat$title_pattern_list
*copyc ost$status
?? POP ??

*DECK DECK=NAP$GET_SERVER_STATUS EXPAND=FALSE
  PROCEDURE [XREF] nap$get_server_status
   (    server: nat$application_name;
    VAR server_status: nat$application_status;
    VAR reserved_application_id: boolean;
    VAR application_id: nat$internet_sap_identifier;
    VAR active_job_count: integer;
    VAR display_job_attributes: array [1..*] of nat$display_job_attributes;
    VAR active_connection_count: nat$number_of_connections;
    VAR attempted_connection_count: integer;
    VAR rejected_connection_attempts: integer;
    VAR server_managed_title_count: nat$max_titles;
    VAR server_managed_titles: array [1..*] of string (nac$max_title_pattern_length);
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$application_status
*copyc nat$internet_sap_identifier
*copyc nat$number_of_connections
*copyc nat$server_attributes
*copyc nat$title
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GET_TCPIP_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] nap$get_tcpip_attributes
    (    application: nat$application_name;
     VAR tcpip_status: nat$application_status;
     VAR maximum_sockets: nat$number_of_sockets;
     VAR tcpip_capability: ost$name;
     VAR tcpip_ring: ost$ring;
     VAR tcpip_system_privilege: boolean;
     VAR protocol: nat$protocol;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$application_status
*copyc nat$number_of_sockets
*copyc nat$protocol
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GET_TCPIP_STATUS EXPAND=FALSE

  PROCEDURE [XREF] nap$get_tcpip_status
   (    application: nat$application_name;
    VAR tcpip_status: nat$application_status;
    VAR active_socket_count: nat$number_of_sockets;
    VAR socket_attempt_count: integer;
    VAR socket_reject_count: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$application_status
*copyc nat$number_of_sockets
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GET_TITLE_TRANSLATION EXPAND=FALSE

  PROCEDURE [XREF] nap$get_title_translation (
         search_identifier: nat$directory_search_identifier;
         wait_time: nat$wait_time;
     VAR attributes {input, output} : ^nat$translation_attributes;
     VAR network_address: nat$network_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$directory_search_identifier
*copyc nat$wait_time
*copyc nat$translation_attributes
*copyc nat$network_address
*copyc ost$status
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$GT_ACCEPT_CONNECTION EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$gt_accept_connection
    (    connection_id: nat$gt_connection_id;
         data: nat$data_fragments;
         options: ^nat$gt_connection_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nat$data_fragments
*copyc nat$gt_connection_options
*copyc nat$gt_interface
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GT_ADD_JOB_SAP EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$gt_add_job_sap (sap: ^nat$gt_job_sap);
?? PUSH (LISTEXT := ON) ??
*copyc nat$gt_job_sap
?? POP ??
*DECK DECK=NAP$GT_AWAIT_ACTIVITY_COMPLETE EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$gt_await_activity_complete (wait_list: nat$gt_wait_list;
    VAR ready_index: integer;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$gt_wait_list
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GT_CLEAR_EXCLUSIVE_TO_CLIST EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$gt_clear_exclusive_to_clist;
*DECK DECK=NAP$GT_CLEAR_EXCLUSIVE_TO_SLIST EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$gt_clear_exclusive_to_slist;
*DECK DECK=NAP$GT_CLOSE_JOB_CONNECTIONS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$gt_close_job_connections (
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GT_CLOSE_SAP EXPAND=FALSE

  PROCEDURE [XREF] nap$gt_close_sap
    (    sap: nat$gt_sap_identifier;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nae$namve_conditions
*copyc nat$gt_sap_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GT_CREATE_JOB_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nap$gt_create_job_connection
    (    sap_id: nat$gt_sap_identifier;
         active_connection_id: nlt$cl_connection_id;
     VAR job_connection: ^nat$gt_job_connection);

?? PUSH (LISTEXT := ON) ??
*copyc nat$gt_job_connection
*copyc nat$gt_sap_identifier
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NAP$GT_DEACTIVATE_JOB_CONNECT EXPAND=FALSE

  PROCEDURE [XREF] nap$gt_deactivate_job_connect (termination_state: nat$gt_connection_state;
        termination_event: nlt$ta_event;
        data_length: nat$data_length;
        job_connection: ^nat$gt_job_connection);

?? PUSH (LISTEXT := ON) ??
*copyc nat$gt_connection
*copyc nat$gt_job_connection
*copyc nlt$ta_event
?? POP ??
*DECK DECK=NAP$GT_DELETE_JOB_CONNECTION EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$gt_delete_job_connection (connection_id: nat$gt_connection_id);
?? PUSH (LISTEXT := ON) ??
*copyc nat$gt_interface
?? POP ??

*DECK DECK=NAP$GT_DELETE_JOB_SAP EXPAND=FALSE

  PROCEDURE [XREF] nap$gt_delete_job_sap
    (    sap_id: nat$gt_sap_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc nat$gt_sap_identifier
?? POP ??
*DECK DECK=NAP$GT_DELETE_JOB_SAPS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$gt_delete_JOB_saps;

*DECK DECK=NAP$GT_DELIVER_CONNECT_HANDLER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$gt_deliver_connect_handler (originator: ost$global_task_id;
        signal: pmt$signal);

?? PUSH(LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc pmt$signal
?? POP ??
*DECK DECK=NAP$GT_DELIVER_EVENT_HANDLER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$gt_deliver_event_handler (originator: ost$global_task_id;
        signal: pmt$signal);

?? PUSH(LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc pmt$signal
?? POP ??
*DECK DECK=NAP$GT_DISCONNECT EXPAND=FALSE
 PROCEDURE [XREF] nap$gt_disconnect (connection: nat$gt_connection_id;
        data: nat$data_fragments;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$gt_interface
*copyc nat$data_fragments
*copyc nae$application_interfaces
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GT_EVALUATE_CONNECT_TIMERS EXPAND=FALSE
  PROCEDURE [XREF] nap$gt_evaluate_connect_timers (current_time: integer;
      cl_connection: ^nlt$cl_connection);
*DECK DECK=NAP$GT_EVALUATE_SAP_TIMERS EXPAND=FALSE
  PROCEDURE [XREF] nap$gt_evaluate_sap_timers (current_time: integer);
*DECK DECK=NAP$GT_GET_CONNECTION_STATUS EXPAND=FALSE
 PROCEDURE [XREF] nap$gt_get_connection_status (connection:
  nat$gt_connection_id;
    VAR connection_status: nat$gt_connection_status;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$gt_interface
*copyc ost$status
*copyc nae$namve_conditions
?? POP ??
*DECK DECK=NAP$GT_GET_EXCLUSIVE_TO_CLIST EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$gt_get_exclusive_to_clist;

*DECK DECK=NAP$GT_GET_EXCLUSIVE_TO_SLIST EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$gt_get_exclusive_to_slist;
*DECK DECK=NAP$GT_INITIALIZE EXPAND=FALSE
  PROCEDURE [XREF] nap$gt_initialize;
*DECK DECK=NAP$GT_OPEN_SAP EXPAND=FALSE

  PROCEDURE [XREF] nap$gt_open_sap
   (    maximum_active_connections: nat$maximum_active_connections;
        sap_priority: nat$network_message_priority;
        reserved_sap: boolean;
    VAR sap {INPUT, OUTPUT} : nat$gt_sap_identifier;
    VAR address: nat$internet_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nat$gt_sap_identifier
*copyc nat$maximum_active_connections
*copyc nat$network_message_priority
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GT_OPEN_SHARED_SAP EXPAND=FALSE

  PROCEDURE [XREF]  nap$gt_open_shared_sap
    (    maximum_active_connections: nat$maximum_active_connections;
         sap_priority: nat$network_message_priority;
         selector: nat$gt_sap_identifier;
         server_job: boolean;
     VAR sap: nat$gt_sap_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nat$gt_sap_identifier
*copyc nat$maximum_active_connections
*copyc nat$network_message_priority
*copyc ost$status
?? POP ??

*DECK DECK=NAP$GT_PROCESS_CONNECTION_EVENT EXPAND=FALSE
  PROCEDURE [XREF] nap$gt_process_connection_event
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$ta_event;
     VAR inventory_report: nlt$ta_inventory_report);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nlt$ta_event
*copyc nlt$ta_inventory_report
?? POP ??
*DECK DECK=NAP$GT_PROCESS_JOB_TERMINATION EXPAND=FALSE

  PROCEDURE [XREF] nap$gt_process_job_termination;
*DECK DECK=NAP$GT_PROCESS_SAP_EVENT EXPAND=FALSE
  PROCEDURE [XREF] nap$gt_process_sap_event
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$ta_event;
     VAR inventory_report: nlt$ta_inventory_report);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nlt$ta_event
*copyc nlt$ta_inventory_report
?? POP ??
*DECK DECK=NAP$GT_RECEIVE_CONNECTION_EVENT EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$gt_receive_connection_event (connection_id: nat$gt_connection_id;
        data_area: nat$data_fragments;
        wait: ost$wait;
    VAR connection_event: nat$gt_event;
    VAR activity_status: ost$activity_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$gt_interface
*copyc nat$gt_event
*copyc nat$data_fragments
*copyc ost$wait
*copyc ost$activity_status
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GT_RECEIVE_CONNECT_EVENT EXPAND=FALSE

  PROCEDURE [XREF] nap$gt_receive_connect_event
    (    sap_id: nat$gt_sap_identifier;
         data_area: nat$data_fragments;
         wait: ost$wait;
     VAR connect_event: nat$gt_connect_event;
     VAR activity_status: ost$activity_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
*copyc nat$gt_event
*copyc nat$gt_interface
*copyc nat$gt_sap_identifier
*copyc ost$activity_status
*copyc ost$status
*copyc ost$wait
?? POP ??
*DECK DECK=NAP$GT_REJECT_CONNECTION EXPAND=FALSE
 PROCEDURE [XREF] nap$gt_reject_connection (connection: nat$gt_connection_id;
        data: nat$data_fragments;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$gt_interface
*copyc nat$data_fragments
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GT_RELEAS_EXCLUSIV_TO_CLIST EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$gt_releas_exclusiv_to_clist;

*DECK DECK=NAP$GT_RELEAS_EXCLUSIV_TO_SLIST EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$gt_releas_exclusiv_to_slist;
*DECK DECK=NAP$GT_REQUEST_CONNECTION EXPAND=FALSE

 PROCEDURE [XREF] nap$gt_request_connection
   (    sap: nat$gt_sap_identifier;
        destination: nat$network_address;
        data: nat$data_fragments;
        options: ^nat$gt_connection_options;
        preferred_protocol_class: nat$ta_preferred_protocol_class;
        alternate_protocol_class: nat$ta_alternate_protocol_class;
    VAR connection_id: nat$gt_connection_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nat$data_fragments
*copyc nat$gt_connection_options
*copyc nat$gt_interface
*copyc nat$gt_sap_identifier
*copyc nat$network_address
*copyc nat$ta_alternate_protocol_class
*copyc nat$ta_preferred_protocol_class
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GT_SEND_DATA EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$gt_send_data (connection: nat$gt_connection_id;
        data: nat$data_fragments;
        end_of_message: boolean;
        wait: ost$wait;
    VAR activity_status: ost$activity_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$gt_interface
*copyc nat$data_fragments
*copyc ost$wait
*copyc ost$activity_status
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc ost$status
?? POP ??
*DECK DECK=NAP$GT_SEND_DATA_HANDLER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$gt_send_data_handler (originator: ost$global_task_id;
        signal: pmt$signal);
?? PUSH(LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc pmt$signal
?? POP ??
*DECK DECK=NAP$GT_SEND_EXPEDITED_DATA EXPAND=FALSE
 PROCEDURE [XREF] nap$gt_send_expedited_data (connection: nat$gt_connection_id;
        data: nat$data_fragments;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$gt_interface
*copyc nat$data_fragments
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc ost$status
?? POP ??
*DECK DECK=NAP$IDLE_NETWORK_APPLICATIONS EXPAND=FALSE
  PROCEDURE [XREF] nap$idle_network_applications (
        terminate_inactive_applications: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=NAP$IDLE_PP EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
*copyc iot$command
*copyc nap$issue_pp_request
?? POP ??

  PROCEDURE [INLINE] nap$idle_pp
    (    pp_number : iot$pp_number);

?? PUSH (LISTEXT := ON) ??
*copyc nah$idle_pp

    VAR
      command: iot$command;

    command.command_code := ioc$cc_idle;
    command.flags.store_response := TRUE;
    command.flags.indirect_address := FALSE;
    command.length := 0;
    command.address := 0;

    nap$issue_pp_request (pp_number,command, NIL);
  PROCEND nap$idle_pp;
?? POP ??
*DECK DECK=NAP$INCOMING_MESSAGE_CLEANUP EXPAND=FALSE

  PROCEDURE [XREF] nap$incoming_message_cleanup;
*DECK DECK=NAP$INCREMENT_FILE_ACCESS_STATS EXPAND=FALSE
  PROCEDURE [XREF] nap$increment_file_access_stats
    (    increment: integer;
         statistic: (active_connection, file_access_request));

*DECK DECK=NAP$INITIALIZE_APPLICATION_DEFN EXPAND=FALSE
  PROCEDURE [XREF] nap$initialize_application_defn (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=NAP$INITIALIZE_NETWORK_PP EXPAND=FALSE
  PROCEDURE [XREF] nap$initialize_network_pp (network_device: ^nlt$network_device);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$network_device
?? POP ??
*DECK DECK=NAP$INITIALIZE_PP_BUFFER_DESCR EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$initialize_pp_buffer_descr;

*DECK DECK=NAP$INITIALIZE_REQUEST_BLOCKS EXPAND=FALSE

  PROCEDURE [XREF] nap$initialize_request_blocks;

*DECK DECK=NAP$INITIATE_TASK_SWITCH EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc pmp$set_system_flag
?? POP ??

  PROCEDURE [INLINE] nap$initiate_task_switch (flag_id: ost$system_flag;
        taskid: ost$global_task_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
    pmp$set_system_flag (flag_id, taskid, status);
  PROCEND nap$initiate_task_switch;
?? POP ??
*DECK DECK=NAP$INIT_PP_SEND_QUEUE_TAILS EXPAND=FALSE

  PROCEDURE [XREF] nap$init_pp_send_queue_tails;
*DECK DECK=NAP$ISSUE_PP_REQUEST EXPAND=FALSE
 PROCEDURE [XREF] nap$issue_pp_request (pp_number : iot$pp_number;
    command: iot$command;
    request_specific_data: ^nlt$ethernet_addr_and_checksum);

?? PUSH (LISTEXT := ON) ??
*copyc iot$command
*copyc iot$pp_number
*copyc nlt$ethernet_addr_and_checksum
?? POP ??
*DECK DECK=NAP$LOCAL_SYSTEM_ID EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  FUNCTION [XREF] nap$local_system_id: nat$system_identifier;

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_address
?? POP ??

*DECK DECK=NAP$MONITOR_SERVER_CONNECTIONS EXPAND=FALSE
  PROCEDURE [XREF] nap$monitor_server_connections (current_time: integer);
*DECK DECK=NAP$MOVE_DATA_TO_USER_DATA_AREA EXPAND=FALSE

?? PUSH (LISTEXT := ON) ??
*copyc i#move
*copyc nat$data_fragments
*copyc ost$status
?? POP ??

  PROCEDURE [INLINE] nap$move_data_to_user_data_area (
  VAR data_area: ^SEQ(*);
  VAR user_data_area: ^SEQ(*);
  VAR data_length: nat$data_length;
  VAR status: ost$status);

   status.normal := TRUE;
   IF data_area <> NIL THEN
     IF ((user_data_area <> NIL) AND (#size(user_data_area^) >= #size(data_area^)))         THEN
       i#move(data_area, user_data_area,#size(data_area^));
       data_length := #size(data_area^);
     ELSE
       osp$set_status_abnormal ('NA',nae$data_area_too_small,'',status);
     IFEND;
   ELSE
     data_length := 0;
   IFEND;
 PROCEND nap$move_data_to_user_data_area;
*DECK DECK=NAP$MOVE_USER_DATA_TO_DATA_AREA EXPAND=FALSE

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc syp$cycle
?? POP ??

  PROCEDURE [INLINE] nap$move_user_data_to_data_area (
      user_data_area: ^SEQ(*);
  VAR data_area: ^SEQ(*));

   IF user_data_area <> NIL THEN
     IF ((data_area <> NIL) AND (#size(data_area^) <> #size(user_data_area^)))         THEN
       FREE data_area in nav$network_paged_heap^;
     IFEND;
     IF data_area = NIL THEN
       REPEAT
         ALLOCATE data_area: [[REP #size(user_data_area^) of cell]] IN
                nav$network_paged_heap^;
         IF data_area = NIL THEN
           syp$cycle;
         IFEND;
       UNTIL data_area <> NIL;
     IFEND;
     data_area^ := user_data_area^;
   ELSE
     IF data_area <> NIL THEN
       FREE data_area IN nav$network_paged_heap^;
     IFEND;
   IFEND;
 PROCEND nap$move_user_data_to_data_area;
*DECK DECK=NAP$NAMVE_ACTIVE EXPAND=FALSE
FUNCTION [XREF] nap$namve_active: boolean;
*DECK DECK=NAP$NAMVE_CONFIG_ACTIVATED EXPAND=TRUE
FUNCTION [XREF] nap$namve_config_activated: boolean;
*DECK DECK=NAP$NAMVE_SYSTEM_ERROR EXPAND=FALSE

  PROCEDURE [XREF] nap$namve_system_error
    (    recoverable_error: boolean;
         error_message: string (*);
         status: ^ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=NAP$NETWORK_FAP EXPAND=FALSE

  PROCEDURE [XREF] nap$network_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FAP_DECLARATIONS
?? POP ??
*DECK DECK=NAP$OFFER_CONNECTION_SWITCH EXPAND=FALSE

  PROCEDURE [XREF] nap$offer_connection_switch (
        file: fst$file_reference;
        destination: jmt$system_supplied_name;
        wait_time: nat$wait_time;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jmt$system_supplied_name
*copyc nat$wait_time
*copyc ost$wait
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$lfn_program_actions
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$OPEN_DI_DUMP_FILE EXPAND=FALSE
 PROCEDURE [XREF] nap$open_di_dump_file (system: string (12);
        timestamp: string (12);
        dump_type: string (4);
        max_dumps: 0 .. 1000;
        max_dump_size: 0 .. 100000000;
    VAR dump_file_id: amt$file_identifier;
    VAR dump_data: ^SEQ ( * );
    VAR dump_file_opened: boolean;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$OPEN_DI_LOAD_FILE EXPAND=FALSE
 PROCEDURE [XREF] nap$open_di_load_file (object_code_version:
  nat$object_code_version_string;
        boot_card: nat$card_type;
    VAR load_file_id: amt$file_identifier;
    VAR load_data: ^SEQ ( * );
    VAR load_file_opened: boolean;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc nat$object_code_version
*copyc ost$status
?? POP ??
*DECK DECK=NAP$OPEN_ENTRY_POINT EXPAND=FALSE
 PROCEDURE [XREF] nap$open_entry_point (library_path: pft$path;
        entry_point_name: pmt$program_name;
    VAR file_identifier: amt$file_identifier;
    VAR entry_point_module: ^SEQ ( * );
    VAR local_file_name: amt$local_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc pfd$permanent_file_definitions
*copyc pmt$program_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$OPEN_FILE EXPAND=FALSE

  PROCEDURE [XREF] nap$open_file (
        file_identifier: amt$file_identifier;
        layer: amt$fap_layer_number;
        call_block: amt$call_block;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
?? POP ??
*DECK DECK=NAP$OPEN_MODULE EXPAND=FALSE
 PROCEDURE [XREF] nap$open_module (library_path: pft$path;
        module_name: pmt$program_name;
    VAR file_identifier: amt$file_identifier;
    VAR object_module: ^SEQ ( * );
    VAR local_file_name: amt$local_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc pfd$permanent_file_definitions
*copyc pmt$program_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$OPEN_NETWORK_SAP EXPAND=FALSE

  PROCEDURE [XREF] nap$open_network_sap
    (    sap_priority: nat$network_message_priority;
         sap: nat$network_sap_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$namve_conditions
*copyc nat$network_message_priority
*copyc nat$network_sap_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$OPEN_PROCEDURE EXPAND=FALSE
 PROCEDURE [XREF] nap$open_procedure (library_path: pft$path;
        procedure_name: ost$name;
    VAR file_identifier: amt$file_identifier;
    VAR scl_procedure: ^clt$scl_procedure;
    VAR local_file_name: amt$local_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc pfd$permanent_file_definitions
*copyc ost$name
*copyc clt$scl_procedure
*copyc ost$status
?? POP ??
*DECK DECK=NAP$OPEN_SERVER_JOB_FILE EXPAND=FALSE

  PROCEDURE [XREF] nap$open_server_job_file (server: nat$application_name;
    VAR server_file_identifier: amt$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc nat$application_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$PARSE_ACCOUNTING_DATA EXPAND=FALSE

  PROCEDURE [XREF] nap$parse_accounting_data
    (    peer_accounting_information: ^string ( * );
         peer_connect_data: ^string ( * );
         accounting_data_fields {input, output} : ^nat$accounting_data_fields;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nat$accounting_data_fields
*copyc ost$status
?? POP ??
*DECK DECK=NAP$PROCESS_CONNECT_INDICATION EXPAND=FALSE

 PROCEDURE [XREF] nap$process_connect_indication
   (    sap_id: nat$sap_identifier;
        connection_id: nat$connection_id;
        cl_connection: ^nlt$cl_connection;
        source_address: nat$network_address;
    VAR server: nat$application_name;
    VAR protocol: nat$protocol;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$connection_id
*copyc nat$network_address
*copyc nat$protocol
*copyc nat$sap_identifier
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??

*DECK DECK=NAP$PROCESS_INIT_DIRECTIVES EXPAND=FALSE
 PROCEDURE [XREF] nap$process_init_directives (VAR system_exceptions: nat$init_exception_list;
    VAR default_object_code_version: nat$object_code_version;
    VAR default_dump_error_list: nat$di_dump_error_list;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$init_me_directives
*copyc nat$object_code_version
*copyc ost$status
?? POP ??
*DECK DECK=NAP$PROCESS_JOB_TERMINATION EXPAND=FALSE
  PROCEDURE [XREF] nap$process_job_termination;
*DECK DECK=NAP$PROCESS_TASK_TERMINATION EXPAND=FALSE
  PROCEDURE [XREF] nap$process_task_termination;
*DECK DECK=NAP$RECEIVE_COMMAND_RESPONSE EXPAND=FALSE
  PROCEDURE [XREF] nap$receive_command_response (wait_time: nat$wait_time;
        response: nat$data_fragment;
    VAR response_length: nat$data_length;
    VAR system: nat$system_title;
    VAR command_id: nat$command_identifier;
    VAR response_code: nat$command_response_code;
    VAR normal_response: boolean;
    VAR truncated: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT:=ON) ??
*copyc nat$wait_time
*copyc nat$data_fragments
*copyc nat$system_title
*copyc nat$command_interface
*copyc ost$status
?? POP ??
*DECK DECK=NAP$RECEIVE_NETWORK_ALARM EXPAND=FALSE
  PROCEDURE [XREF] nap$receive_network_alarm (wait_time: nat$wait_time;
        alarm_message: nat$data_fragment;
    VAR message_length: nat$data_length;
    VAR system: nat$system_title;
    VAR alarm_code: nat$command_response_code;
    VAR time_stamp: nat$bcd_time;
    VAR status: ost$status);

?? PUSH (LISTEXT:=ON) ??
*copyc nat$bcd_time
*copyc nat$data_fragments
*copyc nat$command_interface
*copyc nat$wait_time
*copyc ost$status
?? POP ??
*DECK DECK=NAP$RECEIVE_NETWORK_DATA EXPAND=FALSE

  PROCEDURE [XREF] nap$receive_network_data
    (    sap: nat$network_sap_identifier;
         data_area: nat$data_fragments;
         wait_time: 0 .. 0ffffffff(16);
     VAR source: nat$network_layer_address;
     VAR received_data_length: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$namve_conditions
*copyc nat$data_fragments
*copyc nat$network_layer_address
*copyc nat$network_sap_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$RECORD_COMPLETED_OUTPUT EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$record_completed_output;

*DECK DECK=NAP$RECORD_CONNECTION_ESTABLISH EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$record_connection_establish {task identifier};
*DECK DECK=NAP$RECORD_DIRECTORY_ME EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$record_directory_me {task identifier};
*DECK DECK=NAP$RECORD_SYSTEM_ID EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$record_system_id (system_id: nat$system_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_address
?? POP ??

*DECK DECK=NAP$RECORD_SYSTEM_INPUT EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$record_system_input;
*DECK DECK=NAP$RELOAD_NETWORK_PP EXPAND=FALSE
  PROCEDURE [XREF] nap$reload_network_pp
    (    element: cmt$element_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$REMOVE_CONNECTION_ID EXPAND=FALSE

  PROCEDURE [XREF] nap$remove_connection_id (
        file: fst$file_reference;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc FST$FILE_REFERENCE
*copyc OST$STATUS
?? POP ??
*DECK DECK=NAP$REMOVE_NETWORK_WAITS EXPAND=TRUE
  PROCEDURE [XREF] nap$remove_network_waits (activity_list: ost$i_wait_list);

?? PUSH (LISTEXT := ON) ??
*copyc ost$i_wait
?? POP ??
*DECK DECK=NAP$REMOVE_WAIT_DATA_AVAILABLE EXPAND=FALSE

 PROCEDURE [XREF] nap$remove_wait_data_available (
        file_identifier: amt$file_identifier);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
?? POP ??

*DECK DECK=NAP$REMOVE_WAIT_SERVER_RESPONSE EXPAND=FALSE

 PROCEDURE [XREF] nap$remove_wait_server_response (
        file: fst$file_reference);
?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
?? POP ??

*DECK DECK=NAP$REPLENISH_PP_BUFFER_POOLS EXPAND=FALSE
  PROCEDURE [XREF] nap$replenish_pp_buffer_pools;
*DECK DECK=NAP$REQUEST_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nap$request_connection (
        server: nat$network_address;
        client: nat$application_name;
        file: fst$file_reference;
        protocol: nat$protocol;
        attributes: ^nat$create_attributes;
        wait_time: nat$wait_time;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$network_address
*copyc nat$application_name
*copyc fst$file_reference
*copyc nat$protocol
*copyc nat$create_attributes
*copyc nat$wait_time
*copyc ost$status
*copyc ame$lfn_program_actions
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$RESERVE_NETWORK_ELEMENTS EXPAND=FALSE
  PROCEDURE [XREF] nap$reserve_network_elements
    (    element: cmt$element_name;
         channel: cmt$channel_ordinal;
         channel_address: cmt$physical_equipment_number,
         driver_name: pmt$program_name;
     VAR logical_unit: iot$logical_unit;
     VAR pp_identification: cmt$pp_identification;
     VAR pp_number : iot$pp_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
*copyc cmt$channel_ordinal
*copyc cmt$element_name
*copyc cmt$physical_equipment_number
*copyc cmt$pp_identification
*copyc iot$logical_unit
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=NAP$RESET_NETWORK_RESPONSES EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$reset_network_responses;

*DECK DECK=NAP$RESET_RECEIVED_MESSAGE_LIST EXPAND=FALSE

  PROCEDURE [XREF] nap$reset_received_message_list;
*DECK DECK=NAP$RETURN_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] nap$return_attributes (VAR attributes: ^nat$connection_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=NAP$RETURN_NETWORK_ELEMENTS EXPAND=FALSE
  PROCEDURE [XREF] nap$return_network_elements
    (    element: cmt$element_name;
         channel: cmt$channel_ordinal;
         pp_identification: cmt$pp_identification);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$channel_ordinal
*copyc cmt$element_name
*copyc cmt$pp_identification
?? POP ??
*DECK DECK=NAP$SEND_COMMAND EXPAND=FALSE
  PROCEDURE [XREF] nap$send_command (command: ^string ( * );
        system: string ( * <= nac$system_title_size );
        command_id: nat$command_identifier;
        retain_connection: boolean;
    VAR many_systems_specified: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT:=ON) ??
*copyc nat$command_interface
*copyc nat$system_title
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SEND_DEBUG_MODE_TO_PP EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
*copyc iot$command
*copyc nap$issue_pp_request
?? POP ??
?? TITLE := 'NAP$SEND_DEBUG_MODE_TO_PP', EJECT ??
  PROCEDURE [INLINE] nap$send_debug_mode_to_pp (pp_number: iot$pp_number;
    debug_mode: integer);
{ The purpose of this procedure is to communicate the pp debug mode value to
{ the specified pp.

    VAR
      command: iot$command;

   command.flags.store_response := TRUE;
   command.flags.indirect_address := FALSE;
   command.command_code := ioc$cc_debug_mode;
   command.length := 0;
   command.address := debug_mode;
   nap$issue_pp_request (pp_number, command, NIL);

  PROCEND nap$send_debug_mode_to_pp;
*DECK DECK=NAP$SEND_NETWORK_DATA EXPAND=FALSE

  PROCEDURE [XREF] nap$send_network_data
    (    sap: nat$network_sap_identifier;
         destination: nat$network_layer_address;
         data: nat$data_fragments;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$namve_conditions
*copyc nae$application_interfaces
*copyc nat$data_fragments
*copyc nat$network_layer_address
*copyc nat$network_sap_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SEND_NETWORK_PACKET EXPAND=FALSE

  PROCEDURE [XREF] nap$send_network_packet
    (   class: nlt$cc_connection_class;
        device_id: nlt$device_identifier;
        data: nlt$bm_message_id;
        logical_unit_number: iot$logical_unit;
        pva_list: ^nat$data_fragments);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc nat$data_fragments
*copyc nlt$bm_message_id
*copyc nlt$cc_connection_class
*copyc nlt$device_identifier
?? POP ??
*DECK DECK=NAP$SET_SERVER_JOB_INIT_PENDING EXPAND=FALSE

  PROCEDURE [XREF] nap$set_server_job_init_pending
    (    server: nat$application_name;
         server_job_init_pending: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SET_SWITCH_OFFER EXPAND=FALSE

  PROCEDURE [XREF] nap$set_switch_offer (
        file: fst$file_reference;
        timesharing_connection_switch: boolean;
    VAR connection_id: nat$connection_id;
    VAR application_name: nat$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc NAT$CONNECTION_ID
*copyc nat$application_name
*copyc OST$STATUS
?? POP ??
*DECK DECK=NAP$SE_CLEAR_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] nap$se_clear_request
    (    file: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc fst$file_reference
*copyc nae$application_interfaces
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SE_DELIVER_EVENT_HANDLER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$se_deliver_event_handler (originator: ost$global_task_id;
        signal: pmt$signal);

?? PUSH(LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc pmt$signal
?? POP ??
*DECK DECK=NAP$SE_DISCONNECT_HANDLER EXPAND=FALSE
  PROCEDURE [XREF] nap$se_disconnect_handler
    (    originator: ost$global_task_id;
         signal: pmt$signal);

?? PUSH(LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc pmt$signal
?? POP ??
*DECK DECK=NAP$SE_EVALUATE_IO_TIMERS EXPAND=FALSE
  PROCEDURE [XREF] nap$se_evaluate_io_timers (current_time: integer;
      cl_connection: ^nlt$cl_connection);
*DECK DECK=NAP$SE_GET_AVAILABLE_BYTE_COUNT EXPAND=FALSE

  PROCEDURE [XREF] nap$se_get_available_byte_count
    (    file_identifier: amt$file_identifier;
     VAR byte_count: nat$data_length;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc amt$file_identifier
*copyc nae$application_interfaces
*copyc nat$data_length
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SE_INTERRUPT EXPAND=FALSE

 PROCEDURE [XREF] nap$se_interrupt (
        file_identifier: amt$file_identifier;
        data: SEQ (*);
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
*copyc nae$namve_conditions
?? POP ??
*DECK DECK=NAP$SE_PROCESS_CONNECTION_EVENT EXPAND=FALSE
  PROCEDURE [XREF] nap$se_process_connection_event
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$sl_event;
     VAR inventory_report: nlt$ta_inventory_report);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nlt$sl_event
*copyc nlt$ta_inventory_report
?? POP ??
*DECK DECK=NAP$SE_PROCESS_SAP_EVENT EXPAND=FALSE
  PROCEDURE [XREF] nap$se_process_sap_event
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$sl_event;
     VAR inventory_report: nlt$ta_inventory_report);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nlt$sl_event
*copyc nlt$ta_inventory_report
?? POP ??
*DECK DECK=NAP$SE_RECEIVE_DATA EXPAND=FALSE

 PROCEDURE [XREF] nap$se_receive_data (
        file_identifier: amt$file_identifier;
        buffer: nat$data_fragments;
        wait: ost$wait;
    VAR peer_operation: nat$se_peer_operation;
    VAR activity_status: ost$activity_status;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc nat$data_fragments
*copyc ost$wait
*copyc nat$se_peer_operation
*copyc ost$activity_status
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$SE_REQUEST_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nap$se_request_connection
   (    sap_id: nat$generic_sap_identifier;
        server: nat$network_address;
        client: nat$application_name;
        file: fst$file_reference;
        attributes: ^nat$create_attributes;
        sap_priority: nat$network_message_priority;
    VAR connection_id: nat$connection_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc nat$application_name
*copyc nat$connection_id
*copyc nat$create_attributes
*copyc nat$generic_sap_identifier
*copyc nat$network_address
*copyc nat$network_message_priority
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SE_RETURN_FILE EXPAND=FALSE

  PROCEDURE [XREF] nap$se_return_file (connection_id: nat$connection_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc ost$status
?? POP ??

*DECK DECK=NAP$SE_SEND_DATA EXPAND=FALSE

 PROCEDURE [XREF] nap$se_send_data (
        file_identifier: amt$file_identifier;
        data: nat$data_fragments;
        end_of_message: boolean;
        qualified_data: boolean;
        wait: ost$wait;
    VAR activity_status: ost$activity_status;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc nat$data_fragments
*copyc ost$wait
*copyc ost$activity_status
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$SE_SEND_DATA_HANDLER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nap$se_send_data_handler (originator: ost$global_task_id;
        signal: pmt$signal);

?? PUSH(LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc pmt$signal
?? POP ??
*DECK DECK=NAP$SE_SYNCHRONIZE EXPAND=FALSE

 PROCEDURE [XREF] nap$se_synchronize (
        file_identifier: amt$file_identifier;
        direction: nat$se_synchronize_direction;
        data: SEQ (*);
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc nat$se_synchronize_direction
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
*copyc nae$namve_conditions
?? POP ??
*DECK DECK=NAP$SE_SYNCHRONIZE_CONFIRM EXPAND=FALSE

 PROCEDURE [XREF] nap$se_synchronize_confirm (
        file_identifier: amt$file_identifier;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
*copyc nae$namve_conditions
?? POP ??
*DECK DECK=NAP$SE_TERMINATE_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nap$se_terminate_connection (connection_id: nat$connection_id;
        reason: nat$termination_reason;
        active_file: boolean;
    VAR connection_released: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc nat$termination_reason
*copyc ost$status
?? POP ??

*DECK DECK=NAP$SK_ACCEPT_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nap$sk_accept_socket (listen_socket_id: nat$sk_socket_identifier;
    VAR accept_socket_id: nat$sk_socket_identifier;
    VAR source_socket: nat$sk_socket_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_socket_address
*copyc nat$sk_socket_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SK_ACCEPT_SOCKET_OFFER EXPAND=FALSE

  PROCEDURE [XREF] nap$sk_accept_socket_offer
    (    source_job: jmt$system_supplied_name;
         wait_time: nat$wait_time;
     VAR socket_id: nat$sk_socket_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc nat$sk_socket_identifier
*copyc nat$wait_time
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SK_AWAIT_SOCKET_EVENTS EXPAND=FALSE

  PROCEDURE [XREF] nap$sk_await_socket_events
    (    socket_events: nat$sk_socket_events;
     VAR completed_events: nat$sk_socket_events;
     VAR count: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_socket_events
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SK_BIND_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nap$sk_bind_socket
    (    socket_id: nat$sk_socket_identifier;
         port: nat$sk_port_number;
         ip_address: nat$sk_ip_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_ip_address
*copyc nat$sk_port_number
*copyc nat$sk_socket_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SK_CLOSE_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nap$sk_close_socket
    (    socket_id: nat$sk_socket_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_socket_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SK_CONNECT_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nap$sk_connect_socket
    (    socket_id: nat$sk_socket_identifier;
         destination_socket: nat$sk_socket_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_socket_address
*copyc nat$sk_socket_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SK_GET_HOST_NAME EXPAND=FALSE

  PROCEDURE [XREF] nap$sk_get_host_name
    (VAR host_name: nat$sk_host_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_host_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SK_GET_LOCAL_ADDRESSES EXPAND=FALSE

  PROCEDURE [XREF] nap$sk_get_local_addresses
    (VAR local_addresses: nat$sk_local_addresses;
     VAR count: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_local_addresses
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SK_GET_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nap$sk_get_socket
    (    application: ^nat$application_name;
         socket_type: nat$sk_socket_type;
     VAR socket_id: nat$sk_socket_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$sk_socket_identifier
*copyc nat$sk_socket_type
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SK_GET_SOCKET_ATTRIBUTES EXPAND=TRUE

  PROCEDURE [XREF] nap$sk_get_socket_attributes
    (    socket_id: nat$sk_socket_identifier;
     VAR socket_attributes: nat$sk_socket_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_socket_attributes
*copyc nat$sk_socket_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SK_GET_SOCKET_ID EXPAND=FALSE

  PROCEDURE [XREF] nap$sk_get_socket_id
    (VAR socket_id: nat$sk_socket_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_socket_identifier
?? POP ??
*DECK DECK=NAP$SK_GET_SOCKET_STATUS EXPAND=TRUE

  PROCEDURE [XREF] nap$sk_get_socket_status
    (    socket_id: nat$sk_socket_identifier;
     VAR socket_status: nat$sk_socket_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_socket_identifier
*copyc nat$sk_socket_status
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SK_LISTEN_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nap$sk_listen_socket
    (    socket_id: nat$sk_socket_identifier;
         queue_limit: nat$sk_listen_queue_limit;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_listen_queue_limit
*copyc nat$sk_socket_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SK_OFFER_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nap$sk_offer_socket
    (    socket_id: nat$sk_socket_identifier;
         destination_job: jmt$system_supplied_name;
         wait_time: nat$wait_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc nat$sk_socket_identifier
*copyc nat$wait_time
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SK_PROCESS_JOB_TERMINATION EXPAND=FALSE

  PROCEDURE [XREF] nap$sk_process_job_termination;

*DECK DECK=NAP$SK_READ_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nap$sk_read_socket
    (    socket_id: nat$sk_socket_identifier;
     VAR urgent_flag: boolean;
         data { input, output } : nat$data_fragments;
     VAR data_transferred: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
*copyc nat$sk_socket_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SK_RECEIVE_FROM_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nap$sk_receive_from_socket
    (    socket_id: nat$sk_socket_identifier;
         selection_criteria: ^nat$sk_socket_address;
     VAR foreign_socket: nat$sk_socket_address;
     VAR local_ip_address: ^nat$sk_ip_address;
         data { input, output } : nat$data_fragments;
     VAR data_length: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
*copyc nat$sk_ip_address
*copyc nat$sk_socket_address
*copyc nat$sk_socket_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SK_SEND_TO_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nap$sk_send_to_socket
    (    socket_id: nat$sk_socket_identifier;
         local_ip_address: ^nat$sk_ip_address;
         destination_socket: nat$sk_socket_address;
         data: nat$data_fragments;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
*copyc nat$sk_socket_address
*copyc nat$sk_socket_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SK_SET_SOCKET_OPTIONS EXPAND=TRUE

  PROCEDURE [XREF] nap$sk_set_socket_options
    (    socket_id: nat$sk_socket_identifier;
         options: nat$sk_socket_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_socket_identifier
*copyc nat$sk_socket_options
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SK_WRITE_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nap$sk_write_socket
    (    socket_id: nat$sk_socket_identifier;
         urgent_fag: boolean;
         push_flag: boolean;
         data: nat$data_fragments;
     VAR data_transferred: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
*copyc nat$sk_socket_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$STORE_ATTRIBUTES EXPAND=FALSE

 PROCEDURE [XREF] nap$store_attributes (
        file_identifier: amt$file_identifier;
        attributes: nat$change_attributes;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc nat$change_attributes
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NAP$STORE_CLIENT_IDENTITY EXPAND=FALSE

  PROCEDURE [XREF] nap$store_client_identity (
        connection_id: nat$connection_id;
        client_identity: nat$client_identity;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc nat$client_identity
*copyc ost$status
?? POP ??
*DECK DECK=NAP$SUPPORTED_PROTOCOL_STACKS EXPAND=FALSE

  FUNCTION [XREF] nap$supported_protocol_stacks: nat$protocol_stack_integer;

?? PUSH (LISTEXT := ON) ??
*copyc nat$protocol_stack_integer
?? POP ??
*DECK DECK=NAP$SYSTEM_ID EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc nav$system_id
?? POP ??

  FUNCTION [INLINE] nap$system_id: nat$system_identifier;
?? PUSH (LISTEXT := ON) ??
*copy nah$system_id

    nap$system_id := nav$system_id;
  FUNCEND nap$system_id;
?? POP ??

*DECK DECK=NAP$TERMINATE_COMMAND EXPAND=FALSE
  PROCEDURE [XREF] nap$terminate_command (system: string ( * <= nac$system_title_size );
        retain_connection: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT:=ON) ??
*copyc nat$system_title
*copyc ost$status
?? POP ??
*DECK DECK=NAP$USER_NETWORK_ID EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc nav$network_id
?? POP ??

  FUNCTION [INLINE] nap$user_network_id: nat$network_identifier;
?? PUSH (LISTEXT := ON) ??
*copy nah$user_network_id

    nap$user_network_id := nav$network_id;
  FUNCEND nap$user_network_id;
?? POP ??

*DECK DECK=NAP$VALIDATE_USER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? TITLE := ' [INLINE] NAP$VALIDATE_USER', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$caller_identifier
*copyc ost$name
*copyc ost$status
*copyc avp$get_capability
*copyc osp$is_caller_system_privileged
*copyc osp$set_status_abnormal
?? POP ??

  PROCEDURE [INLINE] nap$validate_user
    (    capability: ost$name;
         ring: ost$ring;
         system_privilege: boolean;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      required_capability: boolean,
      ignore_status: ost$status;

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    status.normal := caller_id.ring <= ring;
    IF status.normal THEN
      IF system_privilege THEN
{       status.normal := osp$is_caller_system_privileged;
{       IF NOT status.normal THEN
{         RETURN;
{       IFEND;
      IFEND;

      IF capability <> osc$null_name THEN
        avp$get_capability (capability, avc$user, required_capability, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF NOT required_capability THEN
          osp$set_status_abnormal ('AV', ave$missing_required_capability, capability, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND nap$validate_user;

*DECK DECK=NAP$VERIFY_APPLICATION_ID EXPAND=FALSE

  PROCEDURE [XREF] nap$verify_application_id
    (    application_id: nat$internet_sap_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$internet_sap_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NAP$VERIFY_APPLICATION_NAME EXPAND=FALSE
  PROCEDURE [XREF] nap$verify_application_name (application: nat$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$VERIFY_TCPIP_NAME EXPAND=FALSE

  PROCEDURE [XREF] nap$verify_tcpip_name
    (    application: nat$application_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc ost$status
?? POP ??
*DECK DECK=NAP$XNS_CHECKSUM EXPAND=FALSE
 FUNCTION [XREF] nap$xns_checksum (data_fragments: nat$data_fragments):
  nat$checksum_value;

?? PUSH (LISTEXT := ON) ??
*copyc nat$checksum
*copyc nat$data_fragments
?? POP ??
*DECK DECK=NAT$ACCOUNTING_DATA_FIELDS EXPAND=FALSE

  TYPE
    nat$accounting_data_fields = array [1 .. * ] of
          nat$accounting_data_field;

  TYPE
    nat$accounting_data_field = record
      case kind: nat$accounting_data_kind of
      = nac$ca_device_name =
        device_name: ost$name,
      = nac$ca_di_system_name =
        di_system_name: ost$name,
      = nac$ca_i_o_station_name =
        i_o_station_name: ost$name,
      = nac$ca_line_speed =
        line_speed: 0 .. 0ffff(16),
      = nac$ca_line_name =
        line_name: ost$name,
      = nac$ca_line_subtype =
        line_subtype: ost$name,
      = nac$ca_null_information =
        ,
      = nac$ca_pdn_name =
        pdn_name: ost$name,
      = nac$ca_trunk_name =
        trunk_name: ost$name,
      = nac$ca_trunk_subtype =
        trunk_subtype: ost$name,
      = nac$ca_unavailable_information =
        ,
      casend,
    recend;

*copyc nat$accounting_data_kind
*copyc ost$name
*DECK DECK=NAT$ACCOUNTING_DATA_KIND EXPAND=FALSE

  CONST
    nac$ca_device_name = 0,
    nac$ca_di_system_name = 1,
    nac$ca_i_o_station_name = 2,
    nac$ca_line_speed = 3,
    nac$ca_line_name = 4,
    nac$ca_line_subtype = 5,
    nac$ca_null_information = 6,
    nac$ca_pdn_name = 7,
    nac$ca_trunk_name = 8,
    nac$ca_trunk_subtype = 9,
    nac$ca_unavailable_information = 10,
    nac$ca_max_accounting_data_kind = 0ffff(16);

  TYPE
    nat$accounting_data_kind = 0 .. nac$ca_max_accounting_data_kind;
*DECK DECK=NAT$AM_KEYPOINT_CONSTANTS EXPAND=FALSE
{ This deck contains the constants used by application mgmt code to output
{ keypoints. These constants follow the order of the keypoints setup in
{ nak$am_keypoints_job_mode.


  CONST
{ The following constants are used by nam$application_event_processor.

    amk_process_connect_indication = 0,
    amk_poll_connections = 1,
    amk_initiate_new_dialogs = 2,

{ The following constants are used by nam$internal_connection_mgmt.

    amk_check_connection = 0,
    amk_check_switch_accept = 1,
    amk_check_switch_offer = 2,
    amk_monitor_server_connections = 3,
    amk_process_task_termination = 4,
    amk_remove_network_waits = 5,
    amk_accept_switch_offer = 6,
    amk_acquire_connection = 7,
    amk_cancel_switch_offer = 8,
    amk_offer_connection_switch = 9,
    amk_request_connection = 10,
    amk_begin_directory_search = 11,
    amk_end_directory_search  = 12,

{ The following constants are used by nam$application_management.

    amk_attach_server_application = 0,
    amk_detach_server_application = 1,
    amk_delete_connection = 2,
    amk_process_job_termination = 3,
    amk_add_server_title  = 4,
    amk_delete_server_title  = 5;

*DECK DECK=NAT$AM_LOGIN_PROMPT EXPAND=FALSE
  TYPE
    nat$am_login_prompt = (nac$am_login_banner, nac$am_user_name, nac$am_password,
          nac$am_family_name, nac$am_account_name, nac$am_project_name);

*DECK DECK=NAT$APPLICATION_BUFFER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  TYPE
    nat$application_buffer = record
      CASE description_kind: nat$buffer_description_kind OF
      = nac$fixed =
        fixed_description: nat$buffer_description,
      = nac$allocated =
        allocated_description: ^nlt$al_data_description,
      CASEND,
    recend,

    nat$buffer_description_kind = (nac$fixed, nac$allocated),

    nat$buffer_description = record
      current_lowerbound: 0 .. nac$max_data_fragment_count * nac$max_data_fragment_count,
      data_length: nat$data_length,
      fragment: array [1 .. nac$fixed_fragments] of nat$data_fragment,
    recend;

    CONST
      nac$fixed_fragments = 4;

*copyc nat$data_fragments
*copyc nlt$al_data_description
*DECK DECK=NAT$APPLICATION_FILE_DEFINITION EXPAND=FALSE
{ This common deck contains the description of the application file layout.
{ The application file is setup as follows:
{      .File header
{      .Array of server names and relocatable pointers. The relocatable pointer
{       points to the start of the server definition.
{      .Array of client names and relocatable pointers. The relocatable pointer
{       points to the start of the client definition.
{      .Array of tcpip names and relocatable pointers. The relocatable pointer
{       points to the start of the tcpip definition.
{      .Server definitions. Note that each server definition is followed by the
{       titles selected for that server.
{      .Array of client addresses.
{      .Client definitions.
{      .Tcpip definitions.

  CONST
    nac$application_file_version = 'V1.2',
    nac$v10_appl_file_version = 'V1.0',
    nac$v11_appl_file_version = 'V1.1',
    nac$max_titles = 0ff(16);

  TYPE
    nat$application_file_header = record
      version: string(4),
      creation_date_time: ost$date_time,
      modification_date_time: ost$date_time,
      server_count: 0 .. 0ffff(16),
      client_count: 0 .. 0ffff(16),
      tcpip_count: 0 .. 0ffff(16),
    recend,

    nat$v10_v11_file_header = record
      version: string(4),
      creation_date_time: ost$date_time,
      modification_date_time: ost$date_time,
      server_count: 0 .. 0ffff(16),
      client_count: 0 .. 0ffff(16),
    recend,

    nat$application_file = SEQ(*),
    nat$server_pointers = array [1..*] of nat$server_pointer,
    nat$server_pointer = record
      server: nat$application_name,
      pointer: REL(nat$application_file)^nat$complete_server_definition,
    recend,

    nat$client_pointers = array [1..*] of nat$client_pointer,
    nat$client_pointer = record
      client: nat$application_name,
      pointer: REL(nat$application_file)^nat$complete_client_definition,
    recend,

    nat$tcpip_pointers = array [1..*] of nat$tcpip_pointer,
    nat$tcpip_pointer = record
      application: nat$application_name,
      pointer: REL(nat$application_file)^nat$complete_tcpip_definition,
    recend,

    nat$complete_server_definition = seq(*),
    nat$server_definition = record
      server: nat$application_name,
      server_status: nat$application_status,
      max_connections: nat$number_of_connections,
      title_count: 0 .. nac$max_titles,
      selected_titles: REL(nat$complete_server_definition) ^nat$selected_titles_list,
      server_managed_title_count: 0 .. nac$max_titles,
      server_managed_titles: REL(nat$complete_server_definition) ^nat$title_pattern_list,
{ Sever validation.
      server_capability: ost$name,
      server_ring: ost$ring,
      server_system_privilege: boolean,
{ Other attributes.
      accept_connection: boolean,
      client_validation_capability: ost$name,
      client_info_source: nat$client_info_source,
      client_address_count: 0 .. 0ffff(16),
      client_addresses: REL(nat$complete_server_definition)^array [1..*] OF nat$client_address,
      reserved_application_id: boolean,
      application_id: nat$internet_sap_identifier,
      protocol: nat$protocol,
      message_priority: nat$network_message_priority,
      flags: packed record
        nam_accounting: boolean,
      recend,
      nam_initiated_server: boolean,
      server_job_validation_source: nat$server_validation_source,
      server_job_max_connections: nat$number_of_connections,
      service_file_defined: boolean,
    recend,

    nat$v10_server_definition = record
      server: nat$application_name,
      server_status: nat$application_status,
      max_connections: nat$number_of_connections,
      title_count: 0 .. nac$max_titles,
      selected_titles: REL(nat$complete_server_definition) ^nat$v10_selected_titles_list,
{ Sever validation.
      server_capability: ost$name,
      server_ring: ost$ring,
      server_system_privilege: boolean,
{ Other attributes.
      accept_connection: boolean,
      client_validation_capability: ost$name,
      client_info_source: nat$client_info_source,
      client_address_count: 0 .. 0ffff(16),
      client_addresses: REL(nat$complete_server_definition)^array [1..*] OF nat$v10_client_address,
      reserved_application_id: boolean,
      application_id: nat$internet_sap_identifier,
      protocol: nat$protocol,
      nam_initiated_server: boolean,
      server_job_validation_source: nat$server_validation_source,
      server_job_max_connections: nat$number_of_connections,
      service_file_defined: boolean,
    recend,

    nat$v10_selected_titles_list = array [1..*] of nat$v10_selected_title,
    nat$v10_selected_title = record
      title: string (nac$max_title_length),
      distribute_title: boolean,
    recend,

    nat$v10_client_address = record
      network_id: nat$network_identifier,
      system_id: nat$system_identifier,
      reserved_application_id: boolean,
      application_id: nat$internet_sap_identifier,
    recend,

    nat$complete_client_definition = seq (*),
    nat$client_definition = record
      client: nat$application_name,
      client_status: nat$application_status,
      protocol: nat$protocol,
      reserved_application_id: boolean,
      application_id: nat$internet_sap_identifier,
      max_connections: nat$number_of_connections,
      client_capability: ost$name,
      client_ring: ost$ring,
      client_system_privilege: boolean,
      message_priority: nat$network_message_priority,
      flags: packed record
        nam_accounting: boolean,
      recend,
    recend,

    nat$v10_client_definition = record
      client: nat$application_name,
      client_status: nat$application_status,
      protocol: nat$protocol,
      reserved_application_id: boolean,
      application_id: nat$internet_sap_identifier,
      max_connections: nat$number_of_connections,
      client_capability: ost$name,
      client_ring: ost$ring,
      client_system_privilege: boolean,
    recend,

    nat$complete_tcpip_definition = seq(*),
    nat$tcpip_definition = record
      tcpip_application: nat$application_name,
      tcpip_status: nat$application_status,
      maximum_sockets: nat$number_of_sockets,
{ Application validation.
      tcpip_capability: ost$name,
      tcpip_ring: ost$ring,
      tcpip_system_privilege: boolean,
{ Other attributes.
      protocol: nat$protocol,
      flags: packed record
        nam_accounting: boolean,
      recend,
      nam_initiated_server: boolean,
{ The following attributes are not supported at this time but are included to allow supporting
{ future enhancements without requiring a change in the application file format.
      accept_connection: boolean,
      reserved_application_id: boolean,
      application_id: nat$sk_port_number,
      client_validation_capability: ost$name,
      client_info_source: nat$client_info_source,
      title_count: 0 .. nac$max_titles,
      selected_titles: REL(nat$complete_tcpip_definition) ^nat$selected_titles_list,
      tcpip_managed_title_count: 0 .. nac$max_titles,
      tcpip_managed_titles: REL(nat$complete_tcpip_definition) ^nat$title_pattern_list,
      tcpip_listen: boolean,
      tcpip_client_address_count: 0 .. 0ffff(16),
      tcpip_client_addresses: REL(nat$complete_tcpip_definition)^array [1..*] OF nat$tcpip_address,
      tcpip_job_validation_source: nat$server_validation_source,
      tcpip_job_max_sockets: nat$number_of_sockets,
      service_file_defined: boolean,
    recend;

  CONST
    nac$v10_cdna_session = 0,
    nac$v10_cdna_virtual_terminal = 2;

*copyc nat$application_name
*copyc nat$directory_data
*copyc nat$directory_entry_identifier
*copyc nat$directory_priority
*copyc nat$internet_sap_identifier
*copyc nat$network_address
*copyc nat$network_message_priority
*copyc nat$number_of_connections
*copyc nat$number_of_sockets
*copyc nat$protocol
*copyc nat$server_attributes
*copyc nat$tcpip_address
*copyc nat$tcpip_attributes
*copyc nat$title_pattern_list
*copyc osd$virtual_address
*copyc ost$date_time
*copyc ost$name

*DECK DECK=NAT$APPLICATION_NAME EXPAND=FALSE
  TYPE
    nat$application_name = ost$name;

*copyc ost$name
*DECK DECK=NAT$APPLICATION_STATUS EXPAND=FALSE

  TYPE
    nat$application_status = (nac$application_inactive, nac$application_active);
*DECK DECK=NAT$APPLICATION_TYPE EXPAND=FALSE
  TYPE
    nat$application_type = (nac$server_application, nac$client_application,
          nac$tcpip_application),
    nat$application_attribute = record
      name: nat$application_name,
      application_type: nat$application_type,
    recend,
    nat$max_applications = 0 .. 0ffff(16);

*copyc nat$application_name
*DECK DECK=NAT$ASSIGNED_CONNECTION EXPAND=FALSE

  TYPE
    nat$assigned_connections_list = RECORD
      access_control: nlt$access_control,
      acquire_connection: ^nat$acquire_connection,
      assigned_connection: ^nat$assigned_connection,
      recend,

    nat$acquire_connection = RECORD
      next_entry: ^nat$acquire_connection,
      server: nat$application_name,
      job_name: jmt$system_supplied_name,
      task_id: ost$global_task_id,
      recend,

    nat$assigned_connection = RECORD
      next_entry: ^nat$assigned_connection,
      server: nat$application_name,
      directed_connection: boolean,
      connection_id: nat$connection_id,
      job_name: jmt$system_supplied_name,
      time_stamp: integer,
      recend;

*copyc nat$connection_id
*copyc nat$application_name
*copyc jmt$system_supplied_name
*copyc ost$global_task_id
*DECK DECK=NAT$ASSIGNED_SAP_LIST EXPAND=FALSE

  CONST
    nac$max_number_of_saps = 4095;

  TYPE
    nat$assigned_sap_list = record
      lock: ost$signature_lock,
      reserved_sap: packed array [nlc$ta_min_rsvd_se_session_sap ..
            nlc$ta_max_rsvd_se_session_sap] of nat$assignment,
      last_assigned_sap: nlt$ta_sap_selector,
      sap: packed array [nlc$ta_min_se_session_sap .. nlc$ta_min_se_session_sap +
            nac$max_number_of_saps] of nat$assignment,
    recend,

    nat$assignment = (nac$unassigned, nac$assigned);

*copyc nlc$ta_sap_ranges
*copyc ost$signature_lock
*DECK DECK=NAT$AWAIT_DATA_AVAILABLE EXPAND=FALSE
 TYPE
    nat$await_data_available = record
      wait_time: nat$wait_time,
      expected_wait_time: nat$wait_time,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc nat$wait_time
?? POP ??
*DECK DECK=NAT$BCD_TIME EXPAND=FALSE
  TYPE
    nat$bcd_time = packed record
      date: packed record
        year1: nat$bcd_digit,
        year2: nat$bcd_digit,
        month1: nat$bcd_digit,
        month2: nat$bcd_digit,
        day1: nat$bcd_digit,
        day2: nat$bcd_digit,
      recend,
      time: packed record
        hours1: nat$bcd_digit,
        hours2: nat$bcd_digit,
        minutes1: nat$bcd_digit,
        minutes2: nat$bcd_digit,
        seconds1: nat$bcd_digit,
        seconds2: nat$bcd_digit,
        milliseconds1: nat$bcd_digit,
        milliseconds2: nat$bcd_digit,
        milliseconds3: nat$bcd_digit,
        fill: nat$bcd_digit,
      recend,
    recend;

  TYPE
    nat$bcd_digit = 0 .. 9;

*DECK DECK=NAT$BUFFER_LINK EXPAND=FALSE
 TYPE
    nat$buffer_link = record
      length: nlt$bm_buffer_length,
      next_buffer: ^nat$buffer_link,
    recend;

*copyc nlt$bm_message_descriptor
*DECK DECK=NAT$BUFFER_MANAGER_STATISTICS EXPAND=FALSE

{ Index 1 into containers_allocated and containers_freed is the counter for
{ small containers and index 2 is the counter for large containers.

  TYPE
    nat$buffer_manager_statistics = record
      containers_allocated: array [1 .. 2] of integer,
      containers_freed: array [1 .. 2] of integer,
      descriptor_pool_empty_count: integer,
    recend;

*DECK DECK=NAT$CHANGE_ATTRIBUTES EXPAND=FALSE
 TYPE
    nat$change_attributes = array [1 .. * ] of
      nat$change_attribute,

    nat$change_attribute = record
{
{ The value of the KIND field must be initialized to identify the attribute
{ whose value is to be changed.
{
{ The value of any field of type ^SEQ (*) must be initialized to point to a
{ program variable which contains the new value of the attribute to be changed.
{
      case kind: nat$connection_attribute_kind of
      = nac$connect_data =
        connect_data: ^SEQ(*),
      = nac$data_transfer_timeout =
        data_transfer_timeout: nat$wait_time,
      = nac$eoi_message =
        eoi_message: nat$eoi_message,
      = nac$eoi_message_enabled =
        eoi_message_enabled: boolean,
      = nac$eoi_peer_termination =
        eoi_peer_termination: boolean,
      = nac$null_attribute =
{ This value indicates that the record is to be ignored. It may be used as a
{ "placeholder" in an array of records.
        ,
      = nac$receive_wait_swapout =
        receive_wait_swapout: boolean,
      = nac$termination_data =
        termination_data: ^SEQ ( * ),
      casend,
    recend;

*copyc nat$connection_attribute_kind
*copyc nat$wait_time
*copyc nat$eoi_message
*DECK DECK=NAT$CHANNEL_CONNECTION_STATS EXPAND=FALSE

  TYPE
    nat$channel_connection_stats = record
      broadcast_connect_requests: integer,
      normal_connections: integer,
      priority_connections: integer,
    recend;

*DECK DECK=NAT$CHANNEL_DESCRIPTOR EXPAND=FALSE
 TYPE
    nat$channel_descriptor = record
      channel_no: 0 .. 0ff(16),
      logical_unit: iot$logical_unit,
    recend;

*copyc iot$logical_unit
*DECK DECK=NAT$CHANNEL_DEVICE_STATISTICS EXPAND=FALSE
  TYPE

    nat$channel_device_statistics = ^array [1 .. * ] of
          nat$channel_device_statistic,

    nat$channel_device_statistic = record
      network_id: nat$network_identifier,
      credit_pdus_received: ALIGNED [0 MOD 8] integer,
      credit_pdus_sent: integer,
      current_normal_connections: integer,                { Normal OSI connections.
      current_priority_connections: integer,              { Priority OSI connections.
      device_resets: integer,
      duplicate_connect_indications: integer,
      normal_send_pdus_queued: integer,                   { Queued on cc connections.
      pdus_processed_out_of_order: integer,
      priority_receive: osi_receive_pdu,
      priority_receive_expedited_pdus: integer,
      priority_receive_pdus_discarded: integer,
      priority_send: osi_send_pdu,
      priority_send_expedited_pdus: integer,
      priority_send_pdus_discarded: integer,
      priority_send_pdus_queued: integer,                 { Queued on cc connections.
      receive: osi_receive_pdu,
      receive_pdus_discarded: integer,
      received_expedited_pdus: integer,
      send: osi_send_pdu,
      send_expedited_pdus: integer,
      send_pdus_discarded: integer,
    recend,

    osi_receive_pdu = record
      case boolean of
      = TRUE =
        pdu_average: 0 .. 0ffffffff(16),
        pdu_total: 0 .. 0ffffffff(16),
      = FALSE =
        value: integer,
      casend,
    recend,

    osi_send_pdu = record
      case boolean of
      = TRUE =
        pdu_average: 0 .. 0ffffffff(16),
        pdu_total: 0 .. 0ffffffff(16),
      = FALSE =
        value: integer,
      casend,
    recend;

*copyc nat$network_address
*DECK DECK=NAT$CHECKSUM EXPAND=FALSE
 CONST
    nac$checksum = 0,
    nac$no_checksum = 0ffff(16);

  TYPE
    nat$checksum_value = 0 .. 0ffff(16);
*DECK DECK=NAT$CLIENT_ATTRIBUTES EXPAND=FALSE

  TYPE
    nat$client_attributes_control = RECORD
      access_control: nlt$access_control,
      client_attributes: ^nat$client_attributes,
      recend,

    nat$client_attributes = RECORD
      access_control: nlt$access_control,
      next_entry: ^nat$client_attributes,
      client: nat$application_name,
      client_status: nat$application_status,
      client_capability: ost$name,
      client_ring: ost$ring,
      client_system_privilege: boolean,
      max_connections: nat$number_of_connections,
      reserved_application_id: boolean,
      application_id: nat$generic_sap_identifier,
      sap_open: boolean,
      protocol: nat$protocol,
      message_priority: nat$network_message_priority,
      flags: packed record
        nam_accounting: boolean
      recend,
      connection_count: nat$number_of_connections,
      attempted_connection_count: integer,
      rejected_connection_attempts: integer,
      client_connections_list: ^nat$client_connection_attribute,
      recend,

      nat$client_connection_attribute = record
        next_entry: ^nat$client_connection_attribute,
        connection_id: nat$connection_id,
        recend;
*copyc nlt$access_control
*copyc nat$application_status
*copyc nat$connection_id
*copyc nat$generic_sap_identifier
*copyc nat$network_message_priority
*copyc nat$number_of_connections
*copyc nat$protocol
*copyc osd$virtual_address
*DECK DECK=NAT$CLIENT_IDENTITY EXPAND=FALSE
  TYPE
    nat$client_identity = record
      family: ost$name,
      user: ost$name,
    recend;

*copyc ost$name
*DECK DECK=NAT$CN_ACTIVE_SAP_LIST EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  TYPE
    nat$cn_sap_list = packed record
      access_control: ALIGNED [0 MOD 8] nlt$access_control,
      active_sap_list: ^nat$cn_active_sap_list,
    recend,

    nat$cn_active_sap_list = array [1 .. 10] of nat$cn_active_sap_list_entry,

    nat$cn_active_sap_list_entry = record
      in_use: boolean,
      link_access_sap_open: boolean,
      sap_id: nat$cn_sap_id,
      event_processor: nat$network_procedure,
    recend;

*copyc nat$cn_interface
*copyc nlt$access_control
*copyc nlt$cn_event_processor
*copyc ost$name
*copyc nat$network_procedure
*DECK DECK=NAT$CN_INTERFACE EXPAND=FALSE
 CONST
    nac$cn_max_sap_id = 0ff(16);

  TYPE
    nat$cn_sap_id = 0 .. nac$cn_max_sap_id;

  CONST
    { These values are to be replaced by the corresponding Ethernet packet
    { types (which are to be registered with Xerox).
    nac$cn_diagnostic_me_sap = 2,
    nac$cn_xns_internet_sap = 4,
    nac$cn_routing_me_sap = 12,
    nac$cn_initialization_me_sap = 16;
*DECK DECK=NAT$CN_LOCAL_EVENT EXPAND=FALSE

  TYPE
    nat$cn_local_event_control = record
      fill: ALIGNED [0 MOD 8] 0 .. 0ffff(16),
      local_event: ^nat$cn_local_event,
    recend,

    nat$cn_local_event = record
      next_local_event: ^nat$cn_local_event,
      sap_id: nat$cn_sap_id,
      source_network: nat$network_identifier,
      source_system: nat$system_identifier,
      multicast: boolean,
      data: nlt$bm_message_id,
      ulp_header_length: nat$data_length,
      ulp_header: array [0 .. 29] of cell, { The array size equals the
{                                            internet pdu header size.
    recend;

*copyc nat$cn_interface
*copyc nat$data_length
*copyc nat$network_address
*copyc nlt$bm_message_id
*DECK DECK=NAT$CN_PDU_HEADER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  TYPE
    nat$cn_pdu_header = record
      destination_address: nat$system_identifier,
      source_address: nat$system_identifier,
      data_length: 0 .. 0ffff(16),
      destination_sap_id: nat$cn_sap_id,
      source_sap_id: nat$cn_sap_id,
      control: 0 .. 0ff(16),
    recend;

    CONST
      nac$3a_header_length = 3;

*copyc nat$network_address
*copyc nat$cn_interface
*DECK DECK=NAT$COMMAND_DATA_UNITS EXPAND=FALSE
  CONST
    nac$max_privilege = 15;

  TYPE
    nat$command_data_unit = record
      header_length: 0 .. 0ff(16) {:=7} ,
      version: 0 .. 0ff(16) {:= 1} ,
      identifier: nat$command_identifier,
      syntax: 0 .. 0ff(16) {:= 0 or 1} ,
      privilege: 0 .. nac$max_privilege,
      {command: string ( * ),}
    recend;

  TYPE
    nat$command_response_data_unit = record
      header_length: 0 .. 0ff(16),
      version: 0 .. 0ff(16) {:= 1} ,
      time_stamp: nat$bcd_time,
      system_address: nat$system_address,
      condition_code: nat$command_response_code,
      command_id: nat$command_identifier,
      flags: packed record
        normal_response: boolean {bit 0 = response normal} ,
        truncated: boolean {bit 1 = truncated} ,
      recend,
      system_title: nat$system_title,
    recend;

*copyc nat$bcd_time
*copyc nat$command_interface
*copyc nat$network_address
*copyc nat$system_title
*DECK DECK=NAT$COMMAND_INTERFACE EXPAND=FALSE

  TYPE
    nat$command_response_code = 0 .. 0ffff(16),
    nat$command_identifier = 0 .. 0ffffffff(16);

  CONST
    nac$max_command_response_length = 65535,
    nac$max_command_connections = 300;
*DECK DECK=NAT$COMMUNITY_TITLE EXPAND=FALSE
 CONST
    nac$community_title_length = 31;

  TYPE
    nat$community_title = string (nac$community_title_length),
    nat$community_title_length = 1 .. nac$community_title_length;
*DECK DECK=NAT$CONNECTION_ATTRIBUTE_KIND EXPAND=FALSE
 CONST
    nac$client_identity = 0,
    nac$connect_data = 1,
    nac$connection_state = 2,
    nac$data_transfer_timeout = 3,
    nac$eoi_message = 4,
    nac$eoi_message_enabled = 5,
    nac$eoi_peer_termination = 6,
    nac$local_address = 7,
    nac$null_attribute = 8,
    nac$optimum_transfer_unit_incr = 9,
    nac$optimum_transfer_unit_size = 10,
    nac$peer_accounting_information = 11,
    nac$peer_address = 12,
    nac$peer_connect_data = 13,
    nac$peer_termination_data = 14,
    nac$protocol = 15,
    nac$receive_wait_swapout = 16,
    nac$termination_data = 17,
    nac$termination_reason = 18,
    nac$max_conn_attribute_kind = 0ffff(16);

  TYPE
    nat$connection_attribute_kind = 0 .. nac$max_conn_attribute_kind;
*DECK DECK=NAT$CONNECTION_DESCRIPTOR EXPAND=FALSE

  CONST
    nac$max_sap_value = 0ffff(16);

  TYPE

    nat$connection_descriptor = record
      sender_request: nat$sender_request,
      receiver_request: nat$receiver_request,
      send_timeout: boolean,
      receive_timeout: boolean,
      connection_state: nat$connection_state,
      wait_state: nat$wait_state,
      await_server_response_task_id: ost$global_task_id,
      await_server_response: boolean,
      intermediate_put_partial: boolean,
      send_put_partial_termination: boolean,
      record_length: amt$max_record_length,
      transfer_count: amt$transfer_count,
      client: boolean,
      application_name: nat$application_name,
      simulated_connection_broken: boolean,
      break_condition_active: boolean,
      break_connection_receive: boolean,
      break_connection_send: boolean,
      discard_to_end_of_message: boolean,
      synchronize_receive: boolean,
      synchronize_send: boolean,
      synchronize_request_receive: boolean,
      synchronize_request_send: boolean,
      nominal_connection: boolean,
      nominal_connection_task_id: ost$global_task_id,
      receive_synchronize_count: integer,
      send_synchronize_count: integer,
      receive_file_identifier: amt$file_identifier,
      send_file_identifier: amt$file_identifier,
      total_data_queued: nat$data_length,
      total_message_buffers_queued: integer,
      event_timer: nlt$timer,
      receive_timer: nlt$timer,
      send_timer: nlt$timer,
      timesharing_disconnect_sent: boolean,
      job_monitor_task_id: ost$global_task_id,
      local_file_name: amt$local_file_name,
      {attributes}
      client_identity: nat$client_identity,
      connect_data: ^SEQ(*),
      data_transfer_timeout: nat$wait_time,
      eoi_message_enabled: boolean,
      eoi_message: ^nat$eoi_message,
      eoi_peer_termination: boolean,
      local_address: nat$sap_identifier,
      peer_accounting_information: ^SEQ(*),
      peer_address: nat$network_address,
      peer_connect_data: ^SEQ(*),
      peer_termination_data: ^SEQ(*),
      receive_wait_swapout: boolean,
      termination_data: ^SEQ(*),
      termination_reason: nat$termination_reason,
      case protocol: nat$protocol of
      = nac$cdna_session =
        data_queue: nat$se_event_queue,
        supervisory_event_queue: nat$se_supervisory_event_queue,
        event: nat$se_peer_operation,
      casend,
    recend;

  TYPE

    nat$wait_state = (nac$inactive_wait, nac$waiting_to_receive_data, nac$waiting_for_data_available);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc amt$max_record_length
*copyc amt$transfer_count
*copyc jmt$system_supplied_name
*copyc nat$application_name
*copyc nat$client_identity
*copyc nat$connection_id
*copyc nat$connection_state
*copyc nat$eoi_message
*copyc nat$network_address
*copyc nat$protocol
*copyc nat$receiver_request
*copyc nat$sap_identifier
*copyc nat$se_event_queue
*copyc nat$se_peer_operation
*copyc nat$se_supervisory_event_queue
*copyc nat$sender_request
*copyc nat$termination_reason
*copyc nat$wait_time
*copyc nlt$timer
*copyc ost$global_task_id
?? POP ??
*DECK DECK=NAT$CONNECTION_ELEMENT EXPAND=FALSE

  TYPE

    nat$connection_element = record
      connection_id: nat$connection_id,
      next_connection_element: ^nat$connection_element,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc nat$connection_element
?? POP ??
*DECK DECK=NAT$CONNECTION_ID EXPAND=FALSE

  TYPE
    nat$connection_id = packed record
*IF $true(osv$unix)
      sequence: 0 .. 7fffffff(16),
*ELSE
      sequence: 0 .. 0ffffffffffff(16),
*IFEND
      reference_number: nlt$cl_reference_number,
    recend;

*copyc nlt$cl_reference_number
*DECK DECK=NAT$CONNECTION_STATE EXPAND=FALSE
 TYPE
    nat$connection_state = (nac$connection_request_sent,
      nac$connection_request_received, nac$established, nac$terminated);
*DECK DECK=NAT$CREATE_ATTRIBUTES EXPAND=FALSE
  TYPE
    nat$create_attributes = ARRAY [ 1 .. * ] of nat$create_attribute,

    nat$create_attribute = record
{
{ The value of the KIND field must be initialized to identify the attribute
{ whose value is being specified.
{
{ The value of any field of type ^SEQ (*) must be initialized to point to a
{ program variable which contains the desired attribute value.
{
      case kind: nat$connection_attribute_kind of
      = nac$connect_data =
        connect_data: ^SEQ(*),
      = nac$data_transfer_timeout =
        data_transfer_timeout: nat$wait_time,
      = nac$eoi_message =
        eoi_message: nat$eoi_message,
      = nac$eoi_message_enabled =
        eoi_message_enabled: boolean,
      = nac$eoi_peer_termination =
        eoi_peer_termination: boolean,
      = nac$null_attribute =
{ This value indicates that the record is to be ignored. It may be used as a
{ "placeholder" in an array of records.
        ,
      = nac$receive_wait_swapout =
        receive_wait_swapout: boolean,
      = nac$termination_data =
        termination_data: ^SEQ(*),
      casend,
    recend;

*copyc nat$connection_attribute_kind
*copyc nat$wait_time
*copyc nat$eoi_message

*DECK DECK=NAT$CREATE_FILE_ATTRIBUTES EXPAND=FALSE

  TYPE
    nat$create_file_attributes = ARRAY [ 1 .. * ] of nat$create_file_attribute,

    nat$create_file_attribute = record
      case key: nat$file_attribute_key of
      = nac$acquire_connection_timeout =
        acquire_connection_timeout: nat$wait_time,
      = nac$connection_data =
        connection_data: ^SEQ(*),
      = nac$data_transfer_timeout =
        data_transfer_timeout: nat$wait_time,
      = nac$disconnect_data =
        disconnect_data: ^SEQ(*),
      = nac$eoi_message =
        eoi_message: nat$eoi_message,
      = nac$eoi_message_enabled =
        eoi_message_enabled: boolean,
      = nac$eoi_peer_termination =
        eoi_peer_termination: boolean,
      = nac$request_connection_timeout =
        request_connection_timeout: nat$wait_time,
      casend,
    recend;

*copyc nat$file_attribute_key
*copyc nat$wait_time
*copyc nat$eoi_message

*DECK DECK=NAT$DATA_FRAGMENTS EXPAND=FALSE
  TYPE
    nat$data_fragments = array [1 .. * ] of nat$data_fragment,
    nat$data_fragment = record
      address: ^cell,
      length: nat$data_length,
    recend,
    nat$data_fragment_count = 0 .. nac$max_data_fragment_count;

{ nac$max_data_fragment_count specifies the maximum number of
{ elements which are allowed in an array of type
{ nat$data_fragments.

 CONST
    nac$max_data_fragment_count = 255;

*copyc nat$data_length
*DECK DECK=NAT$DATA_LENGTH EXPAND=FALSE
  TYPE
    nat$data_length = 0 .. nac$max_data_length;

 CONST
    nac$max_data_length = osc$max_segment_length;

*copyc osd$virtual_address
*DECK DECK=NAT$DCN_ACCESS EXPAND=TRUE
  TYPE
    nat$dcn_access = (nac$network_access_down, nac$network_access_available,
      nac$network_access_unavailable);
*DECK DECK=NAT$DEVICE_TYPE EXPAND=FALSE

  TYPE
    nat$device_type = (nac$di, nac$ica_2, nac$expresslink);
*DECK DECK=NAT$DIRECTORY_DATA EXPAND=FALSE

  CONST
    nac$max_directory_data_length = 32;

  TYPE
    nat$directory_data_length = 0 .. nac$max_directory_data_length,

    nat$directory_data = SEQ ( * );

*DECK DECK=NAT$DIRECTORY_ENTRY_IDENTIFIER EXPAND=FALSE

  TYPE
    nat$directory_entry_identifier = record
      system: nat$system_address,
      time_stamp: nat$bcd_time,
    recend;

*copyc nat$system_address
*copyc nat$bcd_time
*DECK DECK=NAT$DIRECTORY_INTERFACES EXPAND=FALSE
{ * * * ADDRESS RECORD DEFINITION

  TYPE
    nat$translation_address_kind = nat$network_address_kind,

    nat$osi_translation_address = record
      case kind: nat$network_address_kind of
      = nac$osi_transport_address =
        osi_transport_address: nat$osi_transport_address,
      = nac$osi_session_address, nac$osi_non_cdna_session_addr =
        osi_session_address: nat$osi_session_address,
      = nac$osi_presentation_address, nac$osi_non_cdna_present_addr =
        osi_presentation_address: nat$osi_presentation_address,
      casend,
    recend,

    nat$osi_registration_address = record
      case kind: nat$network_address_kind of
      = nac$osi_transport_address, nac$osi_session_address,
            nac$osi_presentation_address =
        transport_selector: nlt$ta_sap_selector,
        case nat$translation_address_kind of
        = nac$osi_session_address, nac$osi_presentation_address =
          session_selector_length: nat$osi_ssap_selector_length,
          session_selector: string (nac$osi_max_ssap_selector_len),
          case nat$translation_address_kind of
          = nac$osi_presentation_address =
            presentation_selector_length: nat$osi_psap_selector_length,
            presentation_selector: string (nac$osi_max_psap_selector_len),
          casend,
        casend,
      = nac$osi_non_cdna_session_addr, nac$osi_non_cdna_present_addr =
        osi_address: ^SEQ ( * ) { <= REP nac$max_osi_address_length OF cell} ,
      casend,
    recend;

{ * * * DEFINITION FOR DISTRIBUTION, ORIGINATOR, REQUESTOR AND SEARCH DOMAINS.

  TYPE
    nat$title_domain = record
      kind: (nac$empty_domain, nac$local_system_domain, nac$unused_domain,
            nac$catenet_domain),
    recend;

{ * * * CLASSIFICATION OF DIRECTORY USER.

  TYPE
    nat$title_class = (nac$cdna_internal, nac$cdna_external);

  TYPE
    nat$directory_password = integer;

*copyc nat$network_address_kind
*copyc nat$osi_address_length
*copyc nat$osi_presentation_address
*copyc nat$osi_session_address
*copyc nat$osi_transport_address
*copyc nlt$ta_sap_selector
*DECK DECK=NAT$DIRECTORY_PRIORITY EXPAND=FALSE

  CONST
    nac$max_directory_priority = 1,
    nac$min_directory_priority = 255;

{ Note that higher directory priorities are represented by lower numerical
{ values.

  TYPE
    nat$directory_priority = nac$max_directory_priority ..
          nac$min_directory_priority;

*DECK DECK=NAT$DIRECTORY_SEARCH_IDENTIFIER EXPAND=FALSE

  TYPE
    nat$directory_search_identifier = nat$directory_entry_identifier;

*copyc nat$directory_entry_identifier
*DECK DECK=NAT$DIRECTORY_STATISTICS EXPAND=FALSE
  TYPE
    nat$directory_statistics = record
      broadcast_translations_received: integer,
      current_cache_entries: integer,
      current_registered_titles: integer,
      directory_searches_active: integer,
      directory_searches_initiated: integer,
      translation_requests_broadcast: integer,
      translation_requests_received: integer,
      translations_broadcast: integer,
      translations_delivered: integer,
      translations_found_in_cache: integer,
      translations_found_in_local_dir: integer,
      translations_received: integer,
      translations_sent: integer,
    recend;
*DECK DECK=NAT$DISPLAY_OPTION EXPAND=FALSE

  TYPE
    nat$display_option = (nac$display_networks, nac$display_all);
*DECK DECK=NAT$EOI_MESSAGE EXPAND=FALSE
  TYPE
    nat$eoi_message = record
      size: 1 .. 31,
      value: string (31),
    recend;
*DECK DECK=NAT$EXTERNAL_KEYPOINT_CONSTANTS EXPAND=FALSE

{ This deck contains the constants used by session application layer to output
{ keypoints. These constants follow the order of the keypoints setup in
{ nak$external_job_mode_keypoints.


  CONST
{ The following constants are used by session application layer.

    amk_await_data_available = 0,
    amk_change_attributes = 1,
    amk_fetch_attributes = 2,
    amk_get_attributes = 3,
    amk_se_interrupt = 4,
    amk_se_receive_data = 5,
    amk_se_send_data = 6,
    amk_se_synchronize = 7,
    amk_se_synchronize_confirm = 8,
    amk_store_attributes = 9,
    amk_se_get_available_byte_count = 10;

*DECK DECK=NAT$FILE_ACCESS_ME_STATISTICS EXPAND=FALSE
  TYPE
    nat$file_access_me_statistics = record
      active_connections: integer,
      file_access_requests: integer,
    recend;

*DECK DECK=NAT$FILE_ATTRIBUTE_KEY EXPAND=FALSE

  CONST
    nac$acquire_connection_timeout = 0,
    nac$client_identity = 1,
    nac$connection_data = 2,
    nac$protocol = 3,
    nac$connection_state = 4,
    nac$data_transfer_timeout = 5,
    nac$disconnect_data = 6,
    nac$eoi_message = 7,
    nac$eoi_message_enabled = 8,
    nac$eoi_peer_termination = 9,
    nac$local_address = 10,
    nac$optimum_transfer_unit_incr = 11,
    nac$optimum_transfer_unit_size = 12,
    nac$peer_accounting_information = 13,
    nac$peer_connection_data = 14,
    nac$peer_disconnect_data = 15,
    nac$remote_address = 16,
    nac$request_connection_timeout = 17,
    nac$termination_reason = 18;

  TYPE
    nat$file_attribute_key = nac$acquire_connection_timeout .. nac$termination_reason;
*DECK DECK=NAT$FILE_STATE EXPAND=FALSE

  TYPE
    nat$file_state = (nac$normal, nac$switch_offered, nac$switch_completed,
      nac$simulated_connection_broken, nac$nominal_conn_switch_offer,
      nac$connection_terminated, nac$terminated_nominal_connect,
      nac$system_recovery, nac$nominal_normal,
      nac$system_recovery_switched, nac$system_recovery_switchd_nom);
*DECK DECK=NAT$GENERIC_DESTINATION_ADDRESS EXPAND=FALSE

  TYPE
    nat$generic_destination_address = nat$gt_destination_address;

*copyc nat$gt_destination_address
*DECK DECK=NAT$GENERIC_SAP_IDENTIFIER EXPAND=FALSE

  TYPE
    nat$generic_sap_identifier = nat$gt_sap_identifier;

*copyc nat$gt_sap_identifier
*DECK DECK=NAT$GET_ATTRIBUTES EXPAND=FALSE
  TYPE
    nat$get_attributes = array [1 .. * ] of
      nat$get_attribute,

    nat$get_attribute = record
{
{ The caller of the interfaces which use this record must initialize the values
{ of certain fields in this record which are used as input parameters.
{
{ The value of the KIND field must be initialized to identify the attribute
{ whose value is to be returned.
{
{ The value of any field of type ^SEQ (*) must be initialized to point to a
{ program variable where the requested attribute value is to be returned.
{ The length of the returned attribute value is returned in the corresponding
{ "length" field. If the size of the requested attribute value exceeds the size
{ of the specified program variable, then an abnormal status is returned.
{
      case kind: {input} nat$connection_attribute_kind of
      = nac$client_identity =
        client_identity: nat$client_identity,
      = nac$connect_data =
        connect_data: {input} ^SEQ ( * ),
        connect_data_length: nat$data_length,
      = nac$connection_state =
        connection_state: nat$connection_state,
      = nac$data_transfer_timeout =
        data_transfer_timeout: nat$wait_time,
      = nac$eoi_message =
        eoi_message: nat$eoi_message,
      = nac$eoi_message_enabled =
        eoi_message_enabled: boolean,
      = nac$eoi_peer_termination =
        eoi_peer_termination: boolean,
      = nac$local_address =
        local_address: nat$sap_identifier,
      = nac$null_attribute =
{ This value indicates that the record is to be ignored. It may be used as a
{ "placeholder" in an array of records.
        ,
      = nac$optimum_transfer_unit_incr =
        optimum_transfer_unit_incr: nat$data_length,
      = nac$optimum_transfer_unit_size =
        optimum_transfer_unit_size: nat$data_length,
      = nac$peer_accounting_information =
        peer_accounting_information: {input} ^SEQ ( * ),
        peer_accounting_info_length: nat$data_length,
      = nac$peer_address =
        peer_address: nat$network_address,
      = nac$peer_connect_data =
        peer_connect_data: {input} ^SEQ ( * ),
        peer_connect_data_length: nat$data_length,
      = nac$peer_termination_data =
        peer_termination_data: {input} ^SEQ ( * ),
        peer_termination_data_length: nat$data_length,
      = nac$protocol =
        protocol: nat$protocol,
      = nac$receive_wait_swapout =
        receive_wait_swapout: boolean,
      = nac$termination_data =
        termination_data: {input} ^SEQ ( * ),
        termination_data_length: nat$data_length,
      = nac$termination_reason =
        termination_reason: nat$termination_reason,
      casend,
    recend;

*copyc nat$client_identity
*copyc nat$connection_attribute_kind
*copyc nat$connection_state
*copyc nat$data_length
*copyc nat$eoi_message
*copyc nat$network_address
*copyc nat$protocol
*copyc nat$sap_identifier
*copyc nat$termination_reason
*copyc nat$wait_time
*DECK DECK=NAT$GLOBAL_FILE_INFORMATION EXPAND=FALSE
  TYPE

    nat$connect = record
      down_time: integer,
      start_time: integer,
      start_down_time: integer,
      valid_start_down_time: boolean,
    recend,

    nat$global_file_information = record
      backup_connection_id: nat$connection_id,
      connect: nat$connect,
      disconnect_indication: boolean,
      file_state: nat$file_state,
    recend;
*copyc nat$connection_id
*copyc nat$file_state
*DECK DECK=NAT$GLOBAL_OSI_STATISTICS EXPAND=FALSE

  TYPE
    nat$global_osi_statistics = RECORD
      channel_connection_device: nat$channel_device_statistics,
      channel_connection: ALIGNED [0 MOD 8] nat$channel_connection_stats,
      link_access_agent: nat$link_access_statistics,
      network_access_agent: nat$network_access_statistics,
      system_management_entity: nat$system_mgmt_entity_stats,
      transport_access_agent: nat$transport_access_statistics,
    RECEND;
*copyc nat$channel_connection_stats
*copyc nat$channel_device_statistics
*copyc nat$link_access_statistics
*copyc nat$network_access_statistics
*copyc nat$system_mgmt_entity_stats
*copyc nat$transport_access_statistics
*DECK DECK=NAT$GLOBAL_STATISTICS EXPAND=FALSE

  TYPE
    nat$global_statistics = RECORD
      intranet: nat$intranet_statistics,
      internet: ALIGNED [0 MOD 8] nat$internet_statistics,
      transport: nat$transport_statistics,
      session: nat$session_statistics,
      buffer_manager: nat$buffer_manager_statistics,
      directory: nat$directory_statistics,
      file_access: nat$file_access_me_statistics,
      pp_buffer_pool: nat$pp_buffer_pool_statistics,
      routing: nat$routing_statistics,
    RECEND;
*copyc nat$buffer_manager_statistics
*copyc nat$directory_statistics
*copyc nat$file_access_me_statistics
*copyc nat$internet_statistics
*copyc nat$intranet_statistics
*copyc nat$pp_buffer_pool_statistics
*copyc nat$routing_statistics
*copyc nat$session_statistics
*copyc nat$transport_statistics
*DECK DECK=NAT$GT_APPLICATION_BUFFER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  TYPE
    nat$gt_application_buffer = record
      CASE description_kind: nat$gt_buffer_description_kind OF
      = nac$gt_fixed =
        fixed_description: nat$gt_buffer_description,
      = nac$gt_allocated =
        allocated_description: ^nlt$al_data_description,
      CASEND,
    recend,

    nat$gt_buffer_description_kind = (nac$gt_fixed, nac$gt_allocated),

    nat$gt_buffer_description = record
      current_lowerbound: 0 .. nac$max_data_fragment_count * nac$max_data_fragment_count,
      data_length: nat$data_length,
      fragment: array [1 .. nac$gt_fixed_fragments] of nat$data_fragment,
    recend;

    CONST
      nac$gt_fixed_fragments = 2;

*copyc nat$data_fragments
*copyc nlt$al_data_description
*DECK DECK=NAT$GT_ASSIGNED_SAP_LIST EXPAND=FALSE

  CONST
    nac$gt_max_number_of_saps = 4095;

  TYPE
    nat$gt_assigned_sap_list = record
      lock: ost$signature_lock,
      sap: packed array [nlc$ta_low_min_osi_sap .. nlc$ta_high_max_osi_sap +
            nac$gt_max_number_of_saps] of nat$gt_assignment,
    recend,

    nat$gt_assignment = (nac$gt_unassigned, nac$gt_assigned);

*copyc nlc$ta_sap_ranges
*copyc ost$signature_lock
*DECK DECK=NAT$GT_CONNECTION EXPAND=FALSE

{
{  PURPOSE:
{     The purpose of the NAT$GT_CONNECTION is to describe an open Generic transport
{     connection in a system.
{
{  DESIGN:
{     The structure resides in the network paged segment accessible to all tasks.
{     Access to all open conections is controlled via Connection Layer connection manager
{     services.
{

  TYPE
    nat$gt_connection_state = (nac$gt_closed, nac$gt_connect_request_sent, nac$gt_accept_received,
          nac$gt_connect_request_received, nac$gt_connect_req_delivered, nac$gt_open, nac$gt_peer_reject,
          nac$gt_peer_disconnect, nac$gt_connection_failed),

    nat$gt_connection_states = set of nat$gt_connection_state,

    nat$gt_connection = record
      state: nat$gt_connection_state,
      external_connection_id: nat$gt_connection_id,
      sap_id: nat$gt_sap_identifier,
      undelivered_message_buffers: integer,
      timer: nlt$timer,
      event_queue: nat$gt_event_queue,
      sender_request: nat$gt_sender_request,
      receiver_request: nat$gt_receiver_request,
    recend,

    nat$gt_sender_request = record
      activity_status: ^ost$activity_status,
      end_of_message: boolean,
      remaining_bytes_to_send: nat$data_length,
      application_buffer: nat$gt_application_buffer,
    recend,

    nat$gt_receiver_request = record
      activity_status: ^ost$activity_status,
      application_event: ^nat$gt_event,
      delivered_data_length: nat$data_length,
      data_delivery_in_progress: boolean,
      remaining_buffer_capacity: nat$data_length,
      application_buffer: nat$gt_application_buffer,
    recend;

*copyc nat$data_fragments
*copyc nat$gt_application_buffer
*copyc nat$gt_event
*copyc nat$gt_event_queue
*copyc nat$gt_sap_identifier
*copyc nat$user_interface
*copyc nlt$cl_connection
*copyc nlt$timer
*copyc ost$activity_status
*DECK DECK=NAT$GT_CONNECTION_OPTIONS EXPAND=FALSE

  CONST
    nac$gt_null = 0,
    nac$gt_checksum = 1,
    nac$gt_expedited_data = 2,
    nac$gt_quality_of_service = 3;

  TYPE
    nat$gt_connection_option = record
      case kind: nat$gt_connection_option_kind of
      = nac$gt_checksum =
        checksum: boolean,
      = nac$gt_expedited_data =
        expedited_data: boolean,
      = nac$gt_quality_of_service =
        quality_of_service: ^SEQ ( * ),
      casend,
    recend,

    nat$gt_connection_option_kind = 0 .. 0ff(16),

    nat$gt_connection_options = array [1 .. * ] of nat$gt_connection_option;

*DECK DECK=NAT$GT_DESTINATION_ADDRESS EXPAND=FALSE

  TYPE
    nat$gt_destination_address = record
      case kind: nat$gt_destination_address_kind of
      = xns =
        internet_address: nat$internet_address,
      = osi =
        osi_address: nat$osi_transport_address,
      casend,
    recend,

    nat$gt_destination_address_kind = (xns, osi);

*copyc nat$internet_address
*copyc nat$osi_transport_address
*DECK DECK=NAT$GT_EVENT EXPAND=FALSE

  TYPE
    nat$gt_event_kind = (nac$gt_connect_event, nac$gt_accept_event,
      nac$gt_reject_event, nac$gt_data_event, nac$gt_expedited_data_event,
      nac$gt_disconnect_event),

    nat$gt_event = record
      case kind: nat$gt_event_kind of
      = nac$gt_connect_event =
        connect: nat$gt_connect_event,
      = nac$gt_accept_event =
        accept: nat$gt_accept_event,
      = nac$gt_reject_event =
        reject: nat$gt_reject_event,
      = nac$gt_data_event =
        data: nat$gt_data_event,
      = nac$gt_expedited_data_event =
        expedited_data: nat$gt_expedited_data_event,
      = nac$gt_disconnect_event =
        disconnect: nat$gt_disconnect_event,
      casend,
    recend,

    nat$gt_connect_event = record
      sap_id: nat$gt_sap_identifier,
      source: nat$gt_destination_address,
      checksum: boolean,
      connection: nat$gt_connection_id,
      data_length: nat$data_length,
      expedited_data: boolean,
    recend,

    nat$gt_accept_event = record
      checksum: boolean,
      data_length: nat$data_length,
      expedited_data: boolean,
    recend,

    nat$gt_reject_event = record
      data_length: nat$data_length,
    recend,

    nat$gt_disconnect_event = record
      case reason: nat$gt_disconnect_reason of
      = nac$gt_user_disconnect =
        data_length: nat$data_length,
      casend,
    recend,

    nat$gt_data_event = record
      data_length: nat$data_length,
      end_of_message: boolean,
    recend,

    nat$gt_expedited_data_event = record
      data_length: nat$data_length,
    recend;

*copyc nat$data_fragments
*copyc nat$gt_destination_address
*copyc nat$gt_interface
*copyc nat$gt_sap_identifier
*copyc nat$user_interface
*DECK DECK=NAT$GT_EVENT_QUEUE EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  TYPE
    nat$gt_event_queue = record
      beginning: ^nat$gt_event_element,
      ending: ^nat$gt_event_element,
    recend,

    nat$gt_event_element = record
      data_length: integer,
      event: nlt$ta_event,
      next_event: ^nat$gt_event_element,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$ta_event
?? POP ??
*DECK DECK=NAT$GT_INTERFACE EXPAND=FALSE

  CONST
    nac$gt_user_disconnect = 128,
    nac$gt_layer_disconnect = 0;

  TYPE
    nat$gt_connection_id = integer,

    nat$gt_disconnect_reason = 0 .. 0ff(16),

    nat$gt_connection_status = record
      unacknowledged_data_outstanding: boolean,
      window_open: boolean,
      round_trip_delay: integer {TBD} ,
    recend;
*DECK DECK=NAT$GT_JOB_CONNECTION EXPAND=FALSE

{
{  PURPOSE:
{     The purpose of the NAT$GT_JOB_CONNECTION is to describe an Generic transport connection
{     in a job.
{
{  DESIGN:
{     The structure resides in the job paged segment accessible to all tasks in a job.
{     Access to all open connections is controlled via a single signature lock (i.e., while
{     one connection is being accessed no other connection in the job can be accessed.
{

  TYPE
    nat$gt_job_connection = record
      connection_id: nat$gt_connection_id,
      sap_id: nat$gt_sap_identifier,
      next_connection: ^nat$gt_job_connection,
      CASE active: boolean OF
      = TRUE =
        active_connection_id: nlt$cl_connection_id,
      = FALSE =
        CASE termination_state: nac$gt_peer_reject .. nac$gt_connection_failed OF
        = nac$gt_peer_reject, nac$gt_peer_disconnect =
          data_length: nat$data_length,
          termination_event: nlt$ta_event,
        CASEND,
      CASEND,
    recend,

    nat$gt_job_connection_list = record
      lock: ost$signature_lock,
      connection_id_seed: nat$gt_connection_id,
      first_connection: ^nat$gt_job_connection,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
*copyc nat$gt_connection
*copyc nat$gt_event
*copyc nat$gt_sap_identifier
*copyc nat$user_interface
*copyc nlt$cl_connection
*copyc nlt$ta_event
*copyc ost$signature_lock
?? POP ??
*DECK DECK=NAT$GT_JOB_SAP EXPAND=FALSE

{
{  PURPOSE:
{     The purpose of the NAT$GT_JOB_SAP is to describe an open Service Access Points in a job.
{
{  DESIGN:
{     The structure resides in the job paged segment accessible to all tasks in a job.
{     Access to all open SAPs is controlled via a single signature lock (i.e., while one SAP
{     is being accessed no other SAP in the job can be accessed.
{

  TYPE
    nat$gt_job_sap = record
      sap_id: nat$gt_sap_identifier,
      selector: nat$gt_sap_identifier,
      next_sap: ^nat$gt_job_sap,
      priority: nlt$ta_priority,
      shared_sap_server: boolean,
    recend,

    nat$gt_job_sap_list = record
      lock: ost$signature_lock,
      first_sap: ^nat$gt_job_sap,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc nat$gt_sap_identifier
*copyc nlt$ta_priority
*copyc ost$signature_lock
?? POP ??
*DECK DECK=NAT$GT_SAP EXPAND=FALSE

{
{  PURPOSE:
{     The purpose of the NAT$GT_SAP is to describe an open Service Access Point in a system.
{
{  DESIGN:
{     The structure resides in the network paged segment accessible to all tasks in a system.
{     Access to all open SAPs is controlled via a single signature lock (i.e., while one SAP
{     is being accessed no other SAP in the system can be accessed.
{

  TYPE
    nat$gt_sap = record
      sap_id: nat$gt_sap_identifier,
      next_sap: ^nat$gt_sap,
      first_connection: ^nat$gt_sap_connection,
      event_timer: nlt$timer,
      connect_request_receiver: nat$gt_connect_request_receiver,
      connect_request_queue: nat$gt_connect_request_queue,
      CASE opened_via_share: boolean OF
      = TRUE =
        shared_sap_count: integer,
        shared_sap_server_active: boolean,
      = FALSE =
      CASEND,
    recend,

    nat$gt_sap_connection = record
      connection_id: nat$gt_connection_id,
      next_connection: ^nat$gt_sap_connection,
      sap_id: nat$gt_sap_identifier,
    recend,

    nat$gt_connect_request_receiver = record
      active: boolean,
      task: ost$global_task_id,
      activity_status: ^ost$activity_status,
      application_event: ^nat$gt_connect_event,
      application_buffer: nat$gt_application_buffer,
    recend,

    nat$gt_connect_request_queue = record
      beginning: ^nat$gt_connect_request,
      ending: ^nat$gt_connect_request,
    recend,

    nat$gt_connect_request = record
      checksum: boolean,
      connection_id: nlt$cl_connection_id,
      data_length: integer,
      expedited_data: boolean,
      source: nat$gt_destination_address,
      data: nlt$bm_message_id,
      next_connect_request: ^nat$gt_connect_request,
    recend,

    nat$gt_sap_list = record
      lock: ost$signature_lock,
      first_sap: ^nat$gt_sap,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc nat$gt_application_buffer
*copyc nat$gt_destination_address
*copyc nat$gt_event
*copyc nat$gt_interface
*copyc nat$gt_sap_identifier
*copyc nlt$bm_message_id
*copyc nlt$cl_connection
*copyc nlt$timer
*copyc ost$activity_status
*copyc ost$global_task_id
*copyc ost$signature_lock
?? POP ??
*DECK DECK=NAT$GT_SAP_IDENTIFIER EXPAND=FALSE

  TYPE
    nat$gt_sap_identifier = record
      xns_sap_identifier: nat$internet_sap_identifier,
      osi_sap_identifier: nlt$ta_sap_selector,
    recend;

*copyc nat$internet_sap_identifier
*copyc nlt$ta_sap_selector
*DECK DECK=NAT$GT_WAIT_LIST EXPAND=FALSE

  TYPE
    nat$gt_wait_list = array [1 .. * ] OF nat$gt_activity,

    nat$gt_activity = record
      case activity: nat$gt_wait_activity OF
      = nac$gt_await_time =
        milliseconds: 0 .. 0ffffffff(16),
      = nac$gt_await_send_data =
        send_connection_id: nat$gt_connection_id,
      = nac$gt_await_receive_event =
        receive_connection_id: nat$gt_connection_id,
      = nac$gt_await_connect_request =
        sap_id: nat$gt_sap_identifier,
      casend,
    recend,

    nat$gt_wait_activity = (nac$gt_null_activity, nac$gt_await_time, nac$gt_await_send_data,
          nac$gt_await_receive_event, nac$gt_await_connect_request);

*copyc nat$gt_interface
*copyc nat$gt_sap_identifier
*DECK DECK=NAT$ICA_CONFIGURATION_DATA EXPAND=FALSE
  TYPE
    nat$ica_configuration_data = packed record
      length: ALIGNED [0 MOD 8] 0 .. 0ffff(16),
      ethernet_station_address: nat$system_identifier,
      fil1: 0 .. 0ff(16),
      ethernet_output_queue_size: 1 .. 195,
      fil2: 0 .. 3f(16),
      crc_error_logging_threshold: 1 .. 1000,
      fil3: 0 .. 3f(16),
      retransmission_log_threshold: 1 .. 1000,
      fil4: 0 .. 3f(16),
      single_bit_logging_threshold: 0 .. 1000,
      fil5: 0 .. 3f(16),
      single_bit_detection_threshold: 1 .. 1000,
      ethernet_controller_threshold: 0 .. 0ffff(16),
      dma_controller_threshold: 0 .. 0ffff(16),
      fil6: 0 .. 7fff(16),
      detailed_statistics_packet: boolean,
      statistics_reporting_interval: 0 .. 0ffffffff(16),
      ethernet_configuration: nat$ethernet_configuration,
      fil7: 1 .. 7ff(16),
      number_of_multicast_addresses: 0 .. 16,
      multicast_address: array [1 .. 16] of nat$system_identifier,
    recend;

  TYPE
    nat$ethernet_configuration = packed record
      fil1: 0 .. 0f(16),
      fifo_threshold_limit: 0 .. 15,
      fil2: 0 .. 0ff(16),
      external_loopback_enabled: boolean,
      internal_loopback_enabled: boolean,
      preamble_length: 0 .. 3,
      address_and_types_in_data: boolean,
      number_of_address_bytes: 1 .. 7,
      save_bad_frames: boolean,
      srdy_not_ardy: boolean,
      fil3: 0 .. 3f(16),
      interframe_spacing: 0 .. 255,
      exponetial_backoff: boolean,
      acc_contention_resolution: 0 .. 7,
      fil4: boolean,
      linear_priority: 0 .. 7,
      number_of_retries: 0 .. 15,
      fil5: boolean,
      slot_time: 0 .. 2047,
      collision_detect_source: boolean,
      collision_detect_filter: 0 .. 7,
      carrier_sense_source: boolean,
      carrier_sense_filter: 0 .. 7,
      perform_padding: boolean,
      bit_stuffing: boolean,
      crc_type_16_bit: boolean,
      no_crc_insertion: boolean,
      tran_on_no_carrier_sense: boolean,
      nrz_encoding_decoding: boolean,
      broadcast_disable: boolean,
      promiscuous_mode: boolean,
      fil6: 0 .. 0ff(16),
      minimum_frame_length: 1 .. 255,
    recend;

*copyc nat$network_address
*DECK DECK=NAT$ICA_LOG_MSG_CONSTANTS EXPAND=TRUE
{ define symptom code constants

  CONST
    nac$sc_ica_state_transition_err = 1,
    nac$sc_ica_invalid_state_trans = 2,
    nac$sc_ica_general_status_busy = 3,
    nac$sc_ica_reset_busy = 4,
    nac$sc_ica_funct_timeout = 5,
    nac$sc_ica_funct_timeout_cef = 6,
    nac$sc_ica_input_ch_parity = 7,
    nac$sc_ica_output_ch_parity = 8,
    nac$sc_ica_iou_output_parity = 9,
    nac$sc_ica_indet_output_parity = 10,
    nac$sc_ica_reset_freq_thresh = 11,
    nac$sc_ica_read_diag_cmd_cont = 12,
    nac$sc_ica_read_conf_content = 13,
    nac$sc_ica_unf_write_status = 14,
    nac$sc_ica_f_write_status = 15,
    nac$sc_ica_read_status = 16,
    nac$sc_ica_echo_status = 17,
    nac$sc_ica_channel_full = 18,
    nac$sc_ica_channel_active = 19,
    nac$sc_ica_unex_xparent_funct = 20,
    nac$sc_ica_forced_err_not_det = 21,
    nac$sc_ica_ch_interface_error = 22,
    nac$sc_ica_board_failure = 23,
    nac$sc_ica_no_transiever_power = 24,
    nac$sc_ica_transiever_failure = 25,
    nac$sc_ica_checksum_error = 26,
    nac$sc_ica_invalid_xfer_address = 27,
    nac$sc_ica_message_length_error = 28,
    nac$sc_ica_no_send_data = 29,
    nac$sc_ica_status_avail_timeout = 30,
    nac$sc_ica_channel_timeout = 31,
    nac$sc_ica_pp_overrun = 32,
    nac$sc_ica_input_truncated = 33,
    nac$sc_ica_formatted_output_err = 34,
    nac$sc_ica_dma_config_error = 35,
    nac$sc_ica_dma_timing_error = 36,
    nac$sc_ica_dma_count_error = 37,
    nac$sc_ica_dma_external_abort = 38,
    nac$sc_ica_dma_software_abort = 39,
    nac$sc_ica_invalid_data_packet = 40,
    nac$sc_ica_no_system_address = 41,
    nac$sc_ica_multicast_addr_error = 42,
    nac$sc_ica_queue_length_error = 43,
    nac$sc_ica_inv_statistics_type = 44,
    nac$sc_ica_invalid_thresholds = 45,
    nac$sc_ica_inv_reporting_inter = 46,
    nac$sc_ica_channel_empty = 47,
    nac$sc_ica_channel_inactive = 48,
    nac$sc_ica_reset_state = 49,
    nac$sc_ica_not_ready_timeout = 50,
    nac$sc_ica_operational_state = 51,
    nac$sc_ica_incomplete_transfer = 52,
    nac$sc_ica_mismatch_hardware = 53,
    nac$sc_ica_gen_status_reject = 54,
    nac$sc_ica_indeterminate = 55,
    nac$sc_ica_channel_protocol_err = 56,
    nac$sc_ica_invalid_flow_control = 57,
    nac$sc_ica_max_size_exceeded =58,
    nac$sc_ica_ethernet_checksum = 59,
    nac$sc_ica_output_length_error = 60,
    nac$sc_ica_memory_parity_error = 61,
    nac$sc_ica_memory_address_error = 62,

{   nac$sc_ica_usage_data should always be the highest symptom code
    nac$sc_ica_usage_data = 63;

{ define constants for status verification errors

  CONST
    nac$ica_unf_write_gs_failure = 1,
    nac$ica_for_write_gs_failure = 2,
    nac$ica_read_gs_failure = 3,
    nac$ica_echo_status_gs_failure = 4;

{ define constants for diagnostics symptom codes

  CONST
    nac$ica_sc_unex_function = 1,
    nac$ica_sc_forced_error = 2,
    nac$ica_sc_cif = 3,
    nac$ica_sc_board_failure = 4,
    nac$ica_sc_no_power = 6,
    nac$ica_sc_ethernet_failure = 7;

{ define constants for idle symptom codes

  CONST
    nac$ica_checksum = 1,
    nac$ica_invalid_transfer = 2,
    nac$ica_load_file_length = 3,
    nac$ica_pp_overrun = 4,
    nac$ica_mismatch_hardware = 5,
    nac$ica_ethernet_checksum = 6;
*DECK DECK=NAT$ICA_PP_LOG_RESPONSE EXPAND=FALSE
  TYPE
    nat$ica_pp_log_response = packed record
      fill1: 0 .. 07ff(16),
      error_id: nat$ica_pp_error_id,
      fill2: 0 .. 0fff(16),
      operation_kind: nat$ica_pp_operation_kind,
{ The following bits represent the symptom codes diagnosed by the ICA pp.
      general_status_error: boolean,
      channel_error_flag: boolean,
      channel_deactivation_error: boolean,
      message_length_verify_error: boolean,
      channel_active: boolean,
      channel_full: boolean,
      channel_empty: boolean,
      message_content_error: boolean,
      incomplete_transfer: boolean,
      maximum_size_exceeded: boolean,
{ End of symptom_codes.
      fill3: 0 .. 3f(16),
      timed_out_function: 0 .. 0ffff(16),
      previous_function: 0 .. 0ffff(16),
      error_word1: 0 .. 0ffff(16),
      error_word2: 0 .. 0ffff(16),
      transition_state: 0 .. 0ffff(16),
      expected_length: 0 .. 0ffffffff(16),
      actual_length: 0 .. 0ffffffff(16),
      fill4: 0 .. 3fff(16),
      error_kind: nat$ica_pp_error_kind,
      retry_count: 0 .. 0ffff(16),
      detailed_status_included: boolean,
      general_status_included: boolean,
      ica_is_down: boolean,
      fill5: 0 .. 1fff(16),
      general_status: 0 .. 0ffff(16),
    recend,

    nat$ica_pp_error_id = (nac$ica_null_error_id, nac$ica_function_timeout,
      nac$ica_state_transition_fail, nac$ica_invalid_state_change,
      nac$ica_gen_status_busy_timeout, nac$ica_operation_failure,
      nac$ica_reset_busy_timeout, nac$ica_diagnostic_failure, nac$ica_gen_status_send_timeout,
      nac$ica_gen_status_avai_timeout, nac$ica_gen_status_content_fail, nac$ica_indet_output_parity,
      nac$ica_reset, nac$ica_operational, nac$ica_general_status_reject, nac$ica_channel_protocol_error,
      nac$ica_usage_data, nac$ica_invalid_flow_control),

    nat$ica_pp_operation_kind = (nac$ica_null_op_kind, nac$ica_op_write, nac$ica_op_read,
      nac$ica_op_read_det_status, nac$ica_op_q_previous_req, nac$ica_op_ch_active_timeout,
      nac$ica_op_read_diagnostic_cmd, nac$ica_op_status_return, nac$ica_read_gen_status,
      nac$ica_op_load_memory, nac$ica_op_enter_idle_state, nac$ica_op_enter_diag_state,
      nac$ica_op_set_ica_parameters, nac$ica_op_dump_memory, nac$ica_op_read_conf_test,
      nac$ica_op_send_ether_address),

    nat$ica_pp_error_kind = (nac$ica_recovered_error, nac$ica_unrecovered_error,
      nac$ica_intermediate_error, nac$ica_informative_message);

  TYPE
    nat$ica_general_status = packed record
      general_error: boolean,
      channel_error: boolean,
      pp_error: boolean,
      ica_error: boolean,
      fil1: boolean,
      data_available: boolean,
      state: nat$ica_states,
      send_data: boolean,
      busy: boolean,
      symptom_code: 0 .. 7,
      reset_code: nat$ica_reset_codes,
    recend;

  TYPE
    nat$ica_states = (nac$ica_reset_state, nac$ica_diagnostic_state, nac$ica_idle_state,
          nac$ica_operational_state);

  TYPE
    nat$ica_reset_codes = (nac$ica_no_rc, nac$ica_power_on, nac$ica_pp_reset,
          nac$ica_deadman_timeout, nac$ica_master_clear,
          nac$ica_reset_function, nac$ica_software_reset);

  TYPE
    nat$ica_detailed_status = packed record
      software_version_number: 0 .. 0ffff(16),
      rom_version_number: 0 .. 0ffff(16),
      board_number: 0 .. 0ffff(16),
      last_function: 0 .. 0ffff(16),
      error_1: nat$ica_ds_error_1,
      error_2: nat$ica_ds_error_2,
      last_but_one: 0 .. 0ffff(16),
      last_but_two: 0 .. 0ffff(16),
      messages_in_output_queue: 0 .. 0ffff(16),
      messages_in_input_queue: 0 .. 0ffff(16),
      number_of_free_buffers: 0 .. 0ffff(16),
      percent_of_free_buffers: 0 .. 0ffff(16),
    recend;

  TYPE
    nat$ica_ds_error_1 = packed record
      type_of_dma_error: nat$ica_dma_error,
      dma_controller_error: boolean,
      fil1: boolean,
      pp_overrun: boolean,
      input_data_truncated: boolean,
      channel_parity_error: boolean,
      channel_timeout: boolean,
      fil2: 0 .. 3f(16),
      formatted_output_error: boolean,
    recend;

  TYPE
    nat$ica_ds_error_2 = packed record
      fil1: 0 .. 1f(16),
      configuration_error_reason: nat$ica_config_error_reason,
      fil2: 0 .. 0f(16),
      invalid_data_packet: boolean,
      fil3: boolean,
      configuration_packet_error: boolean,
      ica_normal: boolean,
    recend;

  TYPE
    nat$ica_dma_error = (nac$ica_dma_no_error, nac$ica_dma_config_error,
          nac$ica_dma_timing_error, nac$ica_dma_count_error,
          nac$ica_dma_external_abort, nac$ica_dma_software_abort);


  TYPE
    nat$ica_config_error_reason = (nac$ica_config_no_error,
          nac$ica_config_no_system_addr, nac$ica_config_multicast_error,
          nac$ica_config_queue_length, nac$ica_config_statistic_type,
          nac$ica_config_single_bit_thr, nac$ica_config_reporting_int);


  TYPE
    nat$ica_osi_detailed_status = packed record
      channel_protocol_version: 0 .. 0ffff(16),
      error_detail: nat$ica_osi_error_detail,
      general_status: nat$ica_general_status,
      last_function: 0 .. 0ffff(16),
      last_but_one: 0 .. 0ffff(16),
      last_but_two: 0 .. 0ffff(16),
      max_pdu_size: 0 .. 0ffffffff(16),
    recend;

  TYPE
    nat$ica_osi_error_detail = packed record
      function_parity_error: boolean,
      invalid_function: boolean,
      channel_active_timeout: boolean,
      fil1: boolean,
      read_truncated_by_pp: boolean,
      fil2: 0 .. 7(16),
      write_length_error: boolean,
      write_format_error: boolean,
      write_parity_error: boolean,
      write_overrun: boolean,
      memory_parity_error: boolean,
      memory_address_error: boolean,
      fil3: 0 .. 3(16),
    recend;

*DECK DECK=NAT$ILMT_KEYPOINT_CONSTANTS EXPAND=FALSE
{ This deck contains the constants used by Intranet Layer Mgmt code to output
{ keypoints. These constants follow the order of the keypoints setup in
{ nak$ilmt_keypoints_job_mode.


  CONST
{ The following constants are used by nam$intranet_layer_mgmt_r3.

    ilmk_manage_intranet_layer = 0,
    ilmk_change_net_device_state = 1,

{ The following constants are used by nam$intranet_layer_mgmt_r1.

    ilmk_queue_dump_request = 0,
    ilmk_flush_unit_queue = 1;



*DECK DECK=NAT$INIT_ME_DIRECTIVES EXPAND=FALSE
 CONST
    nac$di_power_on_reset = 0(16),
    nac$ica_channel_master_clear = 5(16),
    nac$ica_reset_function = 6(16),
    nac$di_reset_kils_no_dump = 33(16),
    nac$ac_power_low = 38(16),
    nac$di_reset_protocol_stk_chg = 40(16),
    nac$mpb_ii_reset = 46(16),
    nac$max_di_reset_code = 0ff(16),
    nac$low_transmit_rate = 4800,
    nac$high_transmit_rate = 2000000;

  TYPE
    nat$di_dump_error_list = SET of 0 .. nac$max_di_reset_code,
    nat$init_exception_list = ^array [1 .. * ] of nat$init_exception_entry,
    nat$init_exception_entry = record
      system_id: nat$system_identifier,
      service_system: boolean,
      version_specified: boolean,
      object_code_version: nat$object_code_version,
      dump_error_list: nat$di_dump_error_list,
      transmit_rate: nat$transmit_rate,
    recend,
    nat$transmit_rate = nac$low_transmit_rate .. nac$high_transmit_rate;

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_address
?? POP ??
*DECK DECK=NAT$INTERNET_ADDRESS EXPAND=FALSE
  TYPE
    nat$internet_address = record
      network: nat$network_identifier,
      system: nat$system_identifier,
      sap: nat$internet_sap_identifier,
    recend;

*copyc nat$network_identifier
*copyc nat$system_identifier
*copyc nat$internet_sap_identifier
*DECK DECK=NAT$INTERNET_SAP_IDENTIFIER EXPAND=FALSE
  TYPE
    nat$internet_sap_identifier = 0 .. nac$max_internet_sap_identifier;

 CONST
    nac$max_internet_sap_identifier = 0ffff(16);
*DECK DECK=NAT$INTERNET_STATISTICS EXPAND=FALSE

  TYPE
    nat$internet_statistics = record
      broadcasts_sent: integer,
      pdus_routed_locally: integer,
      pdus_sent: integer,
      pdus_received: integer,
      pdus_relayed: integer,
    recend;

*DECK DECK=NAT$INTRANET_STATISTICS EXPAND=FALSE

  TYPE

    nat$intranet_statistics = ^array [1 .. * ] of nat$intranet_statistic,

    nat$intranet_statistic = record
      network_id: nat$network_identifier,
      logical_unit_number: iot$logical_unit,
      current_send_pdus_queued: ALIGNED [0 MOD 8] integer,
      multicasts_received: integer,
      multicasts_sent: integer,
      receive: receive_pdu,
      receive_pdus_discarded: integer,
      send: send_pdu,
      send_pdus_discarded: integer,
    recend,

    receive_pdu = record
      case boolean of
      = TRUE =
        pdu_average: 0 .. 0ffffffff(16),
        pdu_total: 0 .. 0ffffffff(16),
      = FALSE =
        value: integer,
      casend,
    recend,

    send_pdu = record
      case boolean of
      = TRUE =
        pdu_average_size: 0 .. 0ffff(16),
        pdu_fragment_average: 0 .. 0ffff(16),
        pdu_total: 0 .. 0ffffffff(16),
      = FALSE =
        value: integer,
      casend,
    recend;

*copyc iot$logical_unit
*copyc nat$network_address
*DECK DECK=NAT$IVB_LOG_MSG_CONSTANTS EXPAND=FALSE

{ define symptom code constants

  CONST
    nac$sc_ivb_funct_timeout = 1,
    nac$sc_ivb_channel_empty = 2,
    nac$sc_ivb_period_cnter_parity = 3,
    nac$sc_ivb_upper_ici_parity = 4,
    nac$sc_ivb_lower_ici_parity = 5,
    nac$sc_ivb_iou_error = 6,
    nac$sc_ivb_incomplete_transfer = 7,
    nac$sc_ivb_channel_not_empty = 8,
    nac$sc_ivb_central_mem_error = 9,
    nac$sc_ivb_invalid_cm_response = 10,
    nac$sc_ivb_cm_resp_code_parity = 11,
    nac$sc_ivb_cmi_read_data_parity = 12,
    nac$sc_ivb_jy_data_error = 13,
    nac$sc_ivb_bas_parity = 14,
    nac$sc_ivb_lz_error = 15,
    nac$sc_ivb_jy_error = 16,
    nac$sc_ivb_lx_error = 17,
    nac$sc_ivb_cant_select = 20,
    nac$sc_ivb_bit_sign_resp_err = 21,
    nac$sc_ivb_no_sync_in = 22,
    nac$sc_ivb_sync_in_did_not_drop = 23,
    nac$sc_ivb_ipi_sequence_error = 24,
    nac$sc_ivb_upper_ipi_parity = 25,
    nac$sc_ivb_lower_ipi_parity = 26,
    nac$sc_ivb_slave_in_not_set = 27,
    nac$sc_ivb_slave_in_didnt_drop = 28,
    nac$sc_ivb_channel_error = 29,
    nac$sc_ivb_channel_active = 30,
    nac$sc_ivb_buffer_cnt_parity = 31,
    nac$sc_ivb_sync_counter_parity = 32,
    nac$sc_ivb_lost_data = 33,
    nac$sc_ivb_bus_parity = 34,
    nac$sc_ivb_command_reject = 35,
    nac$sc_ivb_sync_out_ne_sync_in = 36,
    nac$sc_ivb_bus_b_ack_error = 37,
    nac$sc_ivb_ending_status_wrong = 39,
    nac$sc_ivb_available = 40,
    nac$sc_ivb_reset = 41,
    nac$sc_ivb_reset_freq_thresh = 42,
    nac$sc_ivb_no_forced_error = 100,
    nac$sc_ivb_ipi_read_resp_error = 200,
    nac$sc_ivb_ipi_param_len_error = 201,
    nac$sc_ivb_sequence_number_err = 202,
    nac$sc_ivb_status_mismatch = 203,
    nac$sc_ivb_ipi_resp_code_err = 205,
    nac$sc_ivb_ipi_response_len_err = 206,
    nac$sc_ivb_ipi_resp_param_err = 207,
    nac$sc_ivb_diag_resp_error = 221,
    nac$sc_ivb_max_ccpdu_size_err = 229,
    nac$sc_ivb_buffers_exceeded = 230,
    nac$sc_ivb_rma_not_on_word = 300,
    nac$sc_ivb_ccpdu_header_error = 301,
    nac$sc_ivb_unit_request_err = 302,
    nac$sc_ivb_request_len_error = 303,
    nac$sc_ivb_protocol_neg_failed = 320,
    nac$sc_ivb_invalid_pp_command = 321,
    nac$sc_ivb_unexpected_cpu_ack = 322,
    nac$sc_ivb_cant_clear_ch_lock = 323,
    nac$sc_ivb_buffer_pool_error = 324,
    nac$sc_ivb_inv_max_ccpdu_size = 325,
    nac$sc_ivb_indeterminate = 350;
*DECK DECK=NAT$IVB_PP_LOG_RESPONSE EXPAND=FALSE

  TYPE
      nat$ivb_pp_log_response = packed record

      symptom_code: 0 .. 0ffff(16),
      operation_code: 0 .. 0ffff(16),
      master_status: 0 .. 0ffff(16),
      slave_status: 0 .. 0ffff(16),
      fill1: 0 .. 3fff(16),
      error_kind: nat$ivb_pp_error_kind,
      retry_count: 0 .. 0ffff(16),
      master_status_included: boolean,
      slave_status_included: boolean,
      ivb_is_down: boolean,
      ipi_dma_registers_included: boolean,
      fill5: 0 .. 0fff(16),
      parameter_id: 0 .. 0ffff(16),
      last_function: 0 .. 0ffff(16),
      last_1_function: 0 .. 0ffff(16),
      last_2_function: 0 .. 0ffff(16),
      last_3_function: 0 .. 0ffff(16),
      last_4_function: 0 .. 0ffff(16),
      last_5_function: 0 .. 0ffff(16),
      last_6_function: 0 .. 0ffff(16),
      last_7_function: 0 .. 0ffff(16),
      dma_control_register: 0 .. 0ffff(16),
      dma_operation_register: 0 .. 0ffff(16),
      dma_error_register: 0 .. 0ffff(16),
      ipi_status_register: 0 .. 0ffff(16),
      ipi_error_register: 0 .. 0ffff(16),
      expected_data: 0 .. 0ffff(16),
      actual_data: 0 .. 0ffff(16),
      pp_word_1: 0 .. 0ffff(16),
      pp_word_2: 0 .. 0ffff(16),
      pp_word_3: 0 .. 0ffff(16),
      pp_word_4: 0 .. 0ffff(16),
      pp_word_5: 0 .. 0ffff(16),
    recend;

  TYPE
    nat$ivb_pp_error_kind = (nac$ivb_recovered_error, nac$ivb_unrecovered_error,
      nac$ivb_intermediate_error, nac$ivb_informative_message);


*DECK DECK=NAT$LINK_ACCESS_STATISTICS EXPAND=FALSE

  TYPE
    nat$link_access_statistics = record
      current_saps_open: integer,
      pdus_received: integer,
      pdus_sent: integer,
      total_bytes_received: integer,
      total_bytes_sent: integer,
    recend;

*DECK DECK=NAT$MANAGEMENT_DATA_UNIT_SYNTAX EXPAND=FALSE
  TYPE
    nat$mdu_data_kind = 0 .. 15,
    nat$mdu_header = packed record
      reserved: boolean,
      kind: nat$mdu_data_kind,
      compressed: boolean,
      field: boolean,
      command: boolean,
      length: 0 .. 255,
    recend;

  CONST
    nac$mdu_binary_string = 0,
    nac$mdu_binary_octet = 1,
    nac$mdu_character_string = 2,
    nac$mdu_unsigned_integer = 3,
    nac$mdu_signed_integer = 4,
    nac$mdu_bcd = 7;

*DECK DECK=NAT$MAXIMUM_ACTIVE_CONNECTIONS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  TYPE
    nat$maximum_active_connections = 1 .. 0ffff(16);
*DECK DECK=NAT$MAXIMUM_LOGIN_ATTEMPTS EXPAND=FALSE
TYPE
  nat$maximum_login_attempts = 0 .. 0f(16);
*DECK DECK=NAT$MDI_LOG_MSG_CONSTANTS EXPAND=FALSE
{ define symptom code constants

  CONST
    nac$sc_mdi_invalid_state_trans = 1,
    nac$sc_mdi_general_status_busy = 2,
    nac$sc_mdi_funct_timeout = 3,
    nac$sc_mdi_funct_timeout_cef = 4,
    nac$sc_mdi_input_ch_parity = 5,
    nac$sc_mdi_output_ch_parity = 6,
    nac$sc_mdi_iou_output_parity = 7,
    nac$sc_mdi_indet_output_parity = 8,
    nac$sc_mdi_channel_full = 9,
    nac$sc_mdi_message_length_error = 10,
    nac$sc_mdi_no_send_data = 11,
    nac$sc_mdi_status_avail_timeout = 12,
    nac$sc_mdi_channel_empty = 13,
    nac$sc_mdi_channel_inactive = 14,
    nac$sc_mdi_reset_state = 15,
    nac$sc_mdi_available = 16,
    nac$sc_mdi_incomplete_transfer = 17,
    nac$sc_mdi_indeterminate = 18,
    nac$sc_mdi_no_data_avail = 19,
    nac$sc_mdi_content_error = 20,
    nac$sc_mdi_status_content_error = 21,
    nac$sc_mdi_master_clear_failure = 22,
    nac$sc_mdi_reset_freq_thresh = 23,
    nac$sc_reserved_2 = 24,
    nac$sc_mdi_itb_error = 25,
    nac$sc_mdi_itb_parity_error = 26,
    nac$sc_mdi_channel_timeout = 27,
    nac$sc_mdi_input_truncated = 28,
    nac$sc_mdi_pp_overrun = 29,
    nac$sc_mdi_channel_protocol_err = 30,
    nac$sc_reserved_1 = 31,
    nac$sc_mdi_invalid_message_type = 32,
    nac$sc_mdi_max_size_exceeded = 33,
    nac$sc_mdi_length_error = 34,

{   nac$sc_mdi_usage_data should always be highest symptom code
    nac$sc_mdi_usage_data = 35;
*DECK DECK=NAT$MDI_PP_LOG_RESPONSE EXPAND=FALSE
  TYPE
    nat$mdi_pp_log_response = packed record
      fill1: 0 .. 0fff(16),
      error_id: nat$mdi_pp_error_id,
      fill2: 0 .. 1fff(16),
      operation_kind: nat$mdi_pp_operation_kind,
{ The following bits represent the symptom codes diagnosed by the MDI pp.
      general_status_error: boolean,
      channel_error_flag: boolean,
      channel_deactivation_error: boolean,
      message_length_verify_error: boolean,
      channel_active: boolean,
      channel_full: boolean,
      channel_empty: boolean,
      incomplete_transfer: boolean,
      message_content_error: boolean,
      maximum_size_exceeded: boolean,
{ End of symptom_codes.
      fill3: 0 .. 3f(16),
      timed_out_function: 0 .. 0ffff(16),
      previous_function: 0 .. 0ffff(16),
      error_word1: 0 .. 0ffff(16),
      error_word2: 0 .. 0ffff(16),
      fill4: 0 .. 0f(16),
      general_status: 0 .. 0fff(16),
      length_1: 0 .. 0ffffffff(16),
      length_2: 0 .. 0ffffffff(16),
      fill5: 0 .. 3fff(16),
      error_kind: nat$mdi_pp_error_kind,
      retry_count: 0 .. 0ffff(16),
      detailed_status_included: boolean,
      general_status_included: boolean,
      mdi_is_down: boolean,
      fill6: 0 .. 1fff(16),
    recend,

    nat$mdi_pp_error_id = (nac$mdi_null_error_id, nac$mdi_function_timeout,
          nac$mdi_gen_status_busy_timeout, nac$mdi_operation_failure,
          nac$mdi_gen_status_send_timeout, nac$mdi_gen_status_avai_timeout,
          nac$mdi_gen_status_content_fail, nac$mdi_gen_status_data_avail,
          nac$mdi_usage_data, nac$mdi_invalid_state_change, nac$mdi_available,
          nac$mdi_reset, nac$mdi_channel_protocol_error, nac$mdi_master_clear_failure,
          nac$mdi_invalid_flow_control, nac$mdi_invalid_message_type),

    nat$mdi_pp_operation_kind = (nac$mdi_null_op_kind, nac$mdi_op_write,
          nac$mdi_op_read, nac$mdi_op_read_det_status,
          nac$mdi_op_read_diagnostic_cmd, nac$mdi_read_gen_status,
          nac$mdi_op_inline_write),

    nat$mdi_pp_error_kind = (nac$mdi_recovered_error,
          nac$mdi_unrecovered_error, nac$mdi_intermediate_error,
          nac$mdi_informative_message);

  TYPE
    nat$mdi_general_status = packed record
      general_error: boolean,
      memory_error: boolean,
      data_available: boolean,
      send_data: boolean,
      busy: boolean,
      state: nat$mdi_states,
      fill2: boolean,
      expected_memory_error: boolean,
      expected_error: boolean,
    recend;

  TYPE
    nat$mdi_states = (nac$mdi_reset_state, nac$mdi_diagnostic_state,
          nac$mdi_maintenance_state, nac$mdi_invalid_state,
          nac$mdi_loading_state, nac$mci_reset_state,
          nac$logically_closed_state, nac$mdi_down_state,
          nac$mdi_operational_state);


  TYPE
    nat$mdi_detailed_status = packed record
      protocol_number: 0 .. 0ff(16),
      card_slot: 0 .. 0ff(16),
      software_version_number: 0 .. 0ffff(16),
      system_identifier: 0 .. 0ffffffffffff(16),
      fill1: 0 .. 03f(16),
      last_io: 0 .. 2,
      last_transparent: 0 .. 0ff(16),
      last_function: 0 .. 0ffff(16),
      last_but_one: 0 .. 0ffff(16),
      status_flag: nat$mdi_status_flags,
      general_status: nat$mdi_general_status,
      error_1: nat$mdi_icb_status_register_1,
      error_2: 0 .. 0ff(16),
      software_status: nat$mdi_software_status,
      fill2: 0 .. 0ffffffff(16),
    recend;

  TYPE
    nat$mdi_status_flags = packed record
      general_error: boolean,
      hardware_error: boolean,
      channel_error: boolean,
      pp_error: boolean,
    recend;

  TYPE
    nat$mdi_software_status = packed record
      fill1: 0 .. 3ff(16),
      reached_error: boolean,
      pp_shutdown: boolean,
      local_fault: boolean,
      external_fault: boolean,
      upline_timeout: boolean,
      length_error: boolean,
    recend;

  TYPE
    nat$mdi_icb_status_register_1 = packed record
      itb_error: boolean,
      itb_parity_error: boolean,
      channel_timeout: boolean,
      input_truncated: boolean,
      pp_overrun: boolean,
      channel_parity_error: boolean,
      fill1: boolean,
      pp_master_clear: boolean,
    recend;

*DECK DECK=NAT$MONITOR_REQUEST_BLOCK EXPAND=FALSE
  TYPE
    nat$monitor_request_block = packed record
      request_code: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      CASE sub_request_code: nat$monitor_request_code OF
        = nac$lock_and_queue_io_request =
          io_request: ^iot$io_request,
          response_processor: iot$response_processor,
          address: ^cell,
          length: 0 .. 0ffff(16),
        = nac$unlock_rma_list =
          rma_list: ^nat$rma_list,
      CASEND,
      recend,

    nat$monitor_request_code = (nac$lock_and_queue_io_request, nac$unlock_rma_list);

*copyc iot$io_request
*copyc nat$request_block_list
*copyc syc$monitor_request_codes
*copyc syt$monitor_status
*DECK DECK=NAT$MULTICAST_ADDRESS_GENERATOR EXPAND=FALSE
 CONST
    nac$multicast_address_prefix = 090025(16);

  TYPE
    nat$multicast_address_generator = 0 .. 0fffeff(16);
*DECK DECK=NAT$NAM_ATTRIBUTES EXPAND=FALSE
  CONST
    nac$max_nam_attributes = 16;
  TYPE
    nat$nam_attribute_kind = (
          nac$enable_statistics_attr, nac$max_connections_attr,
          nac$current_connections_status,
          nac$maximum_login_attempts_attr,
          nac$ica_reset_down_thresh_attr, nac$mci_reset_down_thresh_attr,
          nac$system_identifier_attr,
          nac$force_password_prompt_attr,
          nac$prompt_for_account_attr,
          nac$prompt_for_family_name_attr, nac$prompt_for_project_attr,
          nac$tcpip_refresh_interval, nac$tcpip_stale_release_intervl,
          nac$log_tcpip_routing,
          nac$directory_version, nac$display_directory_traffic),

    nat$nam_attribute = record
      CASE kind: nat$nam_attribute_kind OF
      = nac$enable_statistics_attr =
        enable_statistics: boolean,
      = nac$max_connections_attr =
        maximum_connections: nlt$connections_per_system,
      = nac$maximum_login_attempts_attr =
        maximum_login_attempts: nat$maximum_login_attempts,
      = nac$force_password_prompt_attr =
        force_password_prompt: boolean,
      = nac$ica_reset_down_thresh_attr =
        ica_reset_down_threshold: nat$ica_reset_down_threshold,
      = nac$mci_reset_down_thresh_attr =
        mci_reset_down_threshold: nat$mci_reset_down_threshold,
      = nac$prompt_for_account_attr =
        prompt_for_account: boolean,
      = nac$prompt_for_family_name_attr =
        prompt_for_family_name: boolean,
      = nac$prompt_for_project_attr =
        prompt_for_project: boolean,
      = nac$current_connections_status =
        current_connections: nlt$connections_per_system,
      = nac$tcpip_refresh_interval =
        tcpip_refresh_interval: nlt$tm_cache_interval,
      = nac$tcpip_stale_release_intervl =
        tcpip_stale_release_interval: nlt$tm_cache_interval,
      = nac$log_tcpip_routing =
        log_tcpip_routing: boolean,
      = nac$system_identifier_attr =
        system_id: nat$system_identifier,
      = nac$directory_version =
        directory_version: 2 .. 3,
      = nac$display_directory_traffic =
        display_directory_traffic: boolean,
      CASEND,
    recend,

    nat$nam_attributes = array [1..*] of nat$nam_attribute;

*copyc nlt$connections_per_system
*copyc nat$maximum_login_attempts
*copyc nat$net_device_config_param
*copyc nat$system_identifier
*copyc nlt$tm_cache_interval

*DECK DECK=NAT$NETWORK_ACCESS_STATISTICS EXPAND=FALSE

  TYPE
    nat$network_access_statistics = record
      broadcasts_sent: integer,
      pdus_received: integer,
      pdus_sent: integer,
      total_bytes_received: integer,
      total_bytes_sent: integer,
    recend;
*DECK DECK=NAT$NETWORK_ADDRESS EXPAND=FALSE
 TYPE
    nat$network_address = record
      case kind: nat$network_address_kind of
      = nac$internet_address =
        internet_address: nat$internet_address,
      = nac$system_address =
        system_address: nat$system_address,
      = nac$osi_transport_address, nac$osi_non_cdna_transport_addr =
        osi_transport_address: nat$osi_transport_address,
      = nac$osi_session_address, nac$osi_non_cdna_session_addr =
        osi_session_address: nat$osi_session_address,
      = nac$osi_presentation_address, nac$osi_non_cdna_present_addr =
        osi_presentation_address: nat$osi_presentation_address,
      casend,
    recend;

*copyc nat$network_address_kind
*copyc nat$internet_address
*copyc nat$osi_address_length
*copyc nat$osi_presentation_address
*copyc nat$osi_session_address
*copyc nat$osi_transport_address
*copyc nat$system_address

*DECK DECK=NAT$NETWORK_ADDRESS_KIND EXPAND=FALSE
  TYPE
    nat$network_address_kind = 0 .. 255;

  CONST
    nac$system_address = 0,
    nac$internet_address = 1,
    nac$osi_network_address = 6,
    nac$osi_transport_address = 7,
    nac$osi_session_address = 8,
    nac$osi_presentation_address = 9,
    nac$osi_non_cdna_session_addr = 10,
    nac$osi_non_cdna_present_addr = 11,
    nac$osi_non_cdna_transport_addr = 12;
*DECK DECK=NAT$NETWORK_DESCRIPTOR EXPAND=FALSE
 TYPE
    nat$network_descriptor = record
      next_descriptor: ^nat$network_descriptor,
      CASE kind: nat$network_descriptor_type OF
      = nac$network_device =
        access: nat$network_access,
        device_type: nat$device_type,
        driver_name: pmt$program_name,
        system_identifier: nat$system_identifier,
      = nac$host_subnet =
        network: nat$subnet_identifier,
      = nac$define_tcpip_host =
        tcpip: nat$define_tcpip_host,
      CASEND,
    recend,

    nat$network_descriptor_type = (nac$host_subnet, nac$network_device, nac$define_tcpip_host),

    nat$define_tcpip_host = record
      host_name: ^string (*),
      forward_search_range: nlt$tm_search_range,
    recend,

    nat$network_access = record
      channel: cmt$channel_ordinal,
      channel_address: cmt$physical_equipment_number,
      element: cmt$element_name,
    recend;

*copyc cmt$channel_ordinal
*copyc cmt$element_name
*copyc cmt$physical_equipment_number
*copyc nat$device_type
*copyc nat$subnet_identifier
*copyc nat$system_identifier
*copyc nlt$tm_search_range
*copyc pmt$program_name
*DECK DECK=NAT$NETWORK_DRIVER_RESPONSE EXPAND=FALSE
  TYPE
    nat$network_driver_responses = record
      free_responses: nat$response_queue_access,
      outstanding_responses: nat$response_queue_access,
    recend,

    nat$response_queue_access = record
      sequence: 0 .. 0ffff(16),
      next_entry: ^nat$network_driver_response,
    recend,

    nat$network_driver_response = record
      next_entry: ^nat$network_driver_response,
      command: iot$command,
      pp_response: iot$pp_response,
      detailed_status_pointer: ^iot$detailed_status,
      detailed_status: iot$detailed_status,
    recend;

{ The following are the sub codes used in the ioc$cc_synchronize unsolicited
{ response.

    CONST
      nac$ica_start_dump_ack = 1,
      nac$ica_start_dump_nak = 2,
      nac$ica_abort_dump_ack = 3;

*copyc iot$command
*copyc iot$pp_response
*DECK DECK=NAT$NETWORK_IDENTIFIER EXPAND=FALSE

  TYPE
    nat$network_identifier = 0 .. nac$max_network_identifier;

*IF $true(osv$unix)

  CONST
    nac$max_network_identifier = 7fffffff(16);

*ELSE

  CONST
    nac$max_network_identifier = 0ffffffff(16);

*IFEND
*DECK DECK=NAT$NETWORK_LAYER_ADDRESS EXPAND=FALSE
 TYPE
    nat$network_layer_address = record
      case kind: nat$network_address_kind of
      = nac$internet_address =
        internet_address: nat$internet_address,
      = nac$osi_network_address =
        device_id: nlt$device_identifier,
        network_address_length: nat$osi_network_address_length,
        network_address: SEQ(REP nac$osi_max_network_address_len OF cell),
      casend,
    recend;

*copyc nat$internet_address
*copyc nat$network_address_kind
*copyc nat$osi_network_address
*copyc nlt$device_identifier
*DECK DECK=NAT$NETWORK_MESSAGE_PRIORITY EXPAND=FALSE
  TYPE
    nat$network_message_priority = 0 .. 14;

  CONST
    nac$batch_message_priority = 0,
    nac$interact_message_priority = 5,
    nac$real_time_message_priority = 9,
    nac$system_message_priority = 12;

  CONST
    nac$default_message_priority = 0;
*DECK DECK=NAT$NETWORK_PROCEDURE EXPAND=FALSE
TYPE
  nat$network_procedure = 0 .. 255;

{ The following constants map one to one with a network procedures.
{ The constant name is the same as the procedure name with a 'c'
{ replacing the 'p'.  The exceptions are the procedures that are used
{ by both the xns and the osi stacks.  These exceptions should be
{ removed in the post bridge system.

  CONST
    nac$monitor_server_connections = 0,
    nac$cn_deliver_datagram = 1,
    nac$gt_evaluate_sap_timers = 2,
    nac$gt_evaluate_connect_timers = 3,
    nac$se_process_sap_event = 8,
    nac$se_process_connection_event = 9,
    nlc$sl_clear_request_timer = 12,
    nac$nil = 16,
    nac$se_evaluate_io_timers = 17,
    nlc$ta_connect_event_processor = 19,
    nlc$ta_event_processor = 20,
    nac$osi_gt_process_sap_event = 21,
    nac$osi_gt_process_conn_event = 22,
    nlc$sm_connect_event_processor = 23,
    nlc$sm_event_processor = 24,
    nlc$cc_monitor_timers = 25,
    nlc$osi_sl_sap_event_processor = 26,
    nlc$osi_sl_conn_event_processor = 27,
    nlc$na_connect_event_processor = 28,
    nlc$na_event_processor = 29,
    nlc$na_retry_constrained_saps = 30,
    nac$deliver_network_event = 31,           { Used to deliver NAA events }
    nlc$la_connect_event_processor = 33,
    nlc$la_event_processor = 34,
    nlc$la_retry_constrained_saps = 35,
    nlc$tm_connect_event_processor = 36,
    nlc$tm_event_processor = 37,
    nlc$tcp_connect_event_processor = 38,
    nlc$tcp_event_processor = 39,
    nlc$sk_tcp_conn_event_processor = 40,
    nlc$sk_tcp_event_processor = 41,
    nlc$udp_connect_event_processor = 42,
    nlc$udp_event_processor = 43,
    nlc$tcp_flush_release_timer = 44,
    nac$last_network_procedure = 255;
*DECK DECK=NAT$NETWORK_PROCEDURES EXPAND=FALSE
  TYPE
    nat$network_procedures = record
      case nat$network_procedure of
      = nac$monitor_server_connections, nac$gt_evaluate_sap_timers,
        nlc$na_retry_constrained_saps, nlc$la_retry_constrained_saps =
        cl_sap_timer: nlt$cl_evaluate_sap_timer,
      = nac$cn_deliver_datagram =
        cn_event_processor: nlt$cn_event_processor,
      = nac$gt_evaluate_connect_timers, nlc$sl_clear_request_timer,
            nac$se_evaluate_io_timers, nlc$cc_monitor_timers,
            nlc$tcp_flush_release_timer =
        cl_connection_timer: nlt$cl_evaluat_connection_timer,
      = nac$se_process_sap_event, nac$se_process_connection_event =
        sl_event_processor: nlt$sl_event_processor,
      = nac$osi_gt_process_sap_event, nac$osi_gt_process_conn_event,
            nlc$osi_sl_sap_event_processor, nlc$osi_sl_conn_event_processor =
        ta_event_processor: nlt$ta_event_processor,
      = nlc$ta_connect_event_processor, nlc$ta_event_processor,
            nlc$sm_connect_event_processor, nlc$sm_event_processor,
            nlc$na_connect_event_processor, nlc$na_event_processor,
            nlc$la_connect_event_processor, nlc$la_event_processor,
            nlc$tm_connect_event_processor, nlc$tm_event_processor,
            nlc$tcp_connect_event_processor, nlc$tcp_event_processor,
            nlc$udp_connect_event_processor, nlc$udp_event_processor =
        cc_event_processor: nlt$cc_event_processor,
      = nac$deliver_network_event =
        network_event_processor: nlt$deliver_network_event,
      = nlc$sk_tcp_conn_event_processor, nlc$sk_tcp_event_processor =
        tcpaa_event_processor: nlt$tcpaa_event_processor,
      = nac$nil =
        nil_processor: ^procedure,
      casend,
    recend;

*copyc nat$system_address
*copyc nlt$cc_event_processor
*copyc nlt$cl_connection_layer_templat
*copyc nlt$cn_event_processor
*copyc nlt$deliver_network_event
*copyc nlt$sl_event_processor
*copyc nlt$ta_event_processor
*copyc nlt$tcpaa_event_processor
*DECK DECK=NAT$NETWORK_SAP_IDENTIFIER EXPAND=FALSE

  TYPE
    nat$network_sap_identifier = 2 .. 255;
*DECK DECK=NAT$NETWORK_SELECTOR EXPAND=FALSE

  TYPE
    nat$network_selector = 0 .. 0ff(16);
*DECK DECK=NAT$NET_DEVICE_CONFIG_PARAM EXPAND=FALSE
  TYPE
    nat$ica_max_dumps = 0 .. 0fff(16),
    nat$ica_reset_down_threshold = 0 .. 0ff(16),
    nat$mci_reset_down_threshold = 0 .. 0ff(16);
*DECK DECK=NAT$NUMBER_OF_CONNECTIONS EXPAND=FALSE
  TYPE
    nat$number_of_connections = 0 .. nac$max_number_of_connections;

  CONST
    nac$max_number_of_connections = 0ffff(16);
*DECK DECK=NAT$NUMBER_OF_SOCKETS EXPAND=FALSE

  CONST
    nac$max_number_of_sockets = 0ffff(16);

  TYPE
    nat$number_of_sockets = 0 .. nac$max_number_of_sockets;
*DECK DECK=NAT$OBJECT_CODE_VERSION EXPAND=FALSE
 TYPE
    nat$object_code_version = 0 .. 0ffff(16),
    nat$object_code_version_string = string ( 4 ),
    nat$card_type = 0 .. 0ff(16);

  CONST
    nac$ica2_boot_card = 0,
    nac$cim_boot_card = 1,
    nac$esci_boot_card = 2,
    nac$mci_boot_card = 0d(16);






*DECK DECK=NAT$OPEN_CN_SAP_DESCRIPTOR EXPAND=FALSE
 CONST
    nac$max_queued_cn_messages = 0ffff(16);

 TYPE
    nat$open_cn_sap_descriptor = record
      link: ^nat$open_cn_sap_descriptor,
      sap_id: nat$cn_sap_id,
      sap_owner: ost$global_task_id,
      max_data_length: nat$data_length,
      queued_messages: 0 .. nac$max_queued_cn_messages,
      event_queue: ^nat$cn_event,
      waiting_task: boolean,
    recend,

    nat$cn_event = record
      link: ^nat$cn_event,
      device: nlt$device_identifier,
      source: nat$system_address,
      message_id: nlt$bm_message_id,
    recend;

*copyc nat$cn_interface
*copyc nat$data_fragments
*copyc nat$network_address
*copyc nlt$bm_message_id
*copyc nlt$device_identifier
*copyc ost$global_task_id
*DECK DECK=NAT$OPEN_NETWORK_SAP_DESCRIPTOR EXPAND=FALSE

 CONST
    nac$max_queued_network_messages = 0ffff(16);

 TYPE
    nat$open_network_sap_descriptor = record
      link: ^nat$open_network_sap_descriptor,
      sap: nat$network_sap_identifier,
      queued_messages: 0 .. nac$max_queued_network_messages,
      event_queue: ^nat$network_event,
      case waiting_task_specified: boolean of
      = TRUE =
        waiting_task_id: ost$global_task_id,
      casend,
    recend,

    nat$network_event = record
      link: ^nat$network_event,
      message_id: nlt$bm_message_id,
      source: nat$network_layer_address,
    recend;

*copyc nat$network_layer_address
*copyc nat$network_sap_identifier
*copyc nlt$bm_message_id
*copyc ost$global_task_id
*DECK DECK=NAT$OSI_ADDRESS_LENGTH EXPAND=FALSE

  CONST
    nac$max_osi_address_length = 01ff(16);

  TYPE
    nat$osi_address_length = 0 .. nac$max_osi_address_length;
*DECK DECK=NAT$OSI_DISCONNECT_REASON EXPAND=FALSE

  TYPE
    nat$osi_disconnect_reason = 0 .. 0ff(16);
*DECK DECK=NAT$OSI_NETWORK_ADDRESS EXPAND=FALSE

  CONST
    nac$osi_max_network_address_len = 20;

  TYPE
    nat$osi_network_address = SEQ ( * ),
    nat$osi_network_address_length = 0 .. nac$osi_max_network_address_len;

*DECK DECK=NAT$OSI_NETWORK_ADDRESS_PREFIX EXPAND=FALSE

  CONST
    nac$osi_maximum_prefix_length = 11,
    nac$osi_minimum_prefix_length = 1;

  TYPE
    nat$osi_network_address_prefix = string (*);
*DECK DECK=NAT$OSI_PRESENTATION_ADDRESS EXPAND=FALSE

  TYPE
    nat$osi_presentation_address = record
      presentation_selector_length: nat$osi_psap_selector_length,
      presentation_selector: string (nac$osi_max_psap_selector_len),
      session_selector_length: nat$osi_ssap_selector_length,
      session_selector: string (nac$osi_max_ssap_selector_len),
      transport_selector_length: nat$osi_tsap_selector_length,
      transport_selector: string (nac$osi_max_tsap_selector_len),
      network_address_length: nat$osi_network_address_length,
      network_address: SEQ (REP nac$osi_max_network_address_len OF cell),
    recend;

*copyc nat$osi_network_address
*copyc nat$osi_transport_sap_selector
*copyc nat$osi_session_selector
*copyc nat$osi_presentation_selector
*DECK DECK=NAT$OSI_PRESENTATION_SELECTOR EXPAND=FALSE

  CONST
    nac$osi_max_psap_selector_len = 4;

  TYPE
    nat$osi_presentation_selector = string
          ( * <= nac$osi_max_psap_selector_len),

    nat$osi_psap_selector_length = 0 .. nac$osi_max_psap_selector_len;

*DECK DECK=NAT$OSI_SESSION_ADDRESS EXPAND=FALSE

  TYPE
    nat$osi_session_address = record
      session_selector_length: nat$osi_ssap_selector_length,
      session_selector: string (nac$osi_max_ssap_selector_len),
      transport_selector_length: nat$osi_tsap_selector_length,
      transport_selector: string (nac$osi_max_tsap_selector_len),
      network_address_length: nat$osi_network_address_length,
      network_address: SEQ (REP nac$osi_max_network_address_len OF cell),
    recend;

*copyc nat$osi_network_address
*copyc nat$osi_transport_sap_selector
*copyc nat$osi_session_selector
*DECK DECK=NAT$OSI_SESSION_SELECTOR EXPAND=FALSE

  CONST
    nac$osi_max_ssap_selector_len = 16;

  TYPE
    nat$osi_session_selector = string ( * <= nac$osi_max_ssap_selector_len),

    nat$osi_ssap_selector_length = 0 .. nac$osi_max_ssap_selector_len;
*DECK DECK=NAT$OSI_TRANSPORT_ADDRESS EXPAND=FALSE

  TYPE
    nat$osi_transport_address = record
      transport_sap_selector_length: nat$osi_tsap_selector_length,
      transport_sap_selector: string (nac$osi_max_tsap_selector_len),
      network_address_length: nat$osi_network_address_length,
      network_address: SEQ (REP nac$osi_max_network_address_len OF cell),
    recend;

*copyc nat$osi_network_address
*copyc nat$osi_transport_sap_selector
*DECK DECK=NAT$OSI_TRANSPORT_SAP_SELECTOR EXPAND=FALSE

  CONST
    nac$osi_max_tsap_selector_len = 0ff(16);

  TYPE
    nat$osi_transport_sap_selector = string
          ( * <= nac$osi_max_tsap_selector_len),
    nat$osi_tsap_selector_length = 0 .. nac$osi_max_tsap_selector_len;

*DECK DECK=NAT$PERIPHERAL_REQUEST EXPAND=FALSE

  TYPE
    nat$peripheral_request = packed record
      fill1: ALIGNED [0 MOD 8] 0 .. 0ffff(16),
      pp_request: ^iot$io_request,         { links PP requests queued for the IOU, or
                                           { points to this request for send requests.
      next_pp_request_length: nat$request_length,
      fill2: 0 .. 0ffff(16),
      next_pp_request_rma: ost$real_memory_address,
      request_length: nat$request_length,
      logical_unit: iot$logical_unit,
      recovery: iot$request_recovery,
      interrupt: iot$interrupt,
      priority: iot$priority,
      alert_mask: iot$alert_conditions,
      secondary_address: integer,
      command: iot$command,
    recend,

    nat$request_length = 0 .. 0ffff(16);

*copyc iot$io_function
*copyc iot$io_request
*copyc ost$hardware_subranges
*copyc iot$logical_unit
*copyc iot$request_recovery
*copyc iot$alert_conditions
*copyc iot$command
*DECK DECK=NAT$PP_BUFFER_POOL_STATISTICS EXPAND=FALSE

{ Index 1 into empty_pools_count and pools_replenished is the counter for
{ small containers and index 2 is the counter for large containers.

  TYPE
    nat$pp_buffer_pool_statistics = record
      empty_pools_count: array [1 .. 2] of integer,
      pools_replenished: array [1 .. 2] of integer,
    recend;
*DECK DECK=NAT$PREALLOCATED_RB_CONTROL EXPAND=FALSE

  TYPE
    nat$preallocated_rb_control = record
      first_free_block: ALIGNED [0 MOD 8] nat$next_request_block_id,
      sequence_number: 0 .. 0ffffffffffff(16),
    recend;

*copyc nat$request_block_identifier
*DECK DECK=NAT$PREALLOCATED_REQUEST_BLOCKS EXPAND=FALSE

  TYPE
    nat$preallocated_request_blocks = ^array [1 .. * ] of ^nat$request_block;

*copyc nat$request_block
*DECK DECK=NAT$PROTOCOL EXPAND=FALSE
  TYPE
    nat$protocol = 0 .. nac$max_protocol;

  CONST {supported values for nat$protocol}
    nac$unknown_protocol = 0,
    nac$osi_clns = 2,
    nac$osi_transport = 3,
    nac$cdna_session = 4,
    nac$cdna_virtual_terminal = 5,
    nac$osi_session = 6,
    nac$osi_presentation = 7,
    nac$non_cdna_osi_sess_tp4_clns = 8,
    nac$non_cdna_osi_pres_tp4_clns = 9,
    nac$non_cdna_osi_pres_tp0_cons = 10,
    nac$non_cdna_osi_pres_tp2_cons = 11,
    nac$non_cdna_osi_pres_tp4_cons = 12,
    nac$stream_socket = 13,
    nac$datagram_socket = 14,
    nac$max_protocol = 255;
*DECK DECK=NAT$PROTOCOL_STACK EXPAND=FALSE

  TYPE
    nat$protocol_stack = (nac$xns_stack, nac$osi_stack);
*DECK DECK=NAT$PROTOCOL_STACK_INTEGER EXPAND=FALSE

{ The values of the supported protocol stacks represent bit positions.
{ Support for multiple protocol stacks is indicated by adding up the values
{ assigned to the individual protocol stacks.

  CONST
    nac$xns_protocol_stack = 1,
    nac$osi_protocol_stack = 2,
    nac$all_protocol_stacks = 3;

  TYPE
    nat$protocol_stack_integer = 0 .. 255;

*DECK DECK=NAT$RECEIVED_MESSAGE_LIST EXPAND=FALSE

  TYPE
    nat$received_message_list = record
      next_received_message: ALIGNED [0 MOD 8] ^nlt$bm_message_descriptor,
      fill: 0 .. 0ffff(16),
    recend;

*copyc nlt$bm_message_descriptor
*DECK DECK=NAT$RECEIVER_REQUEST EXPAND=FALSE
  TYPE
    nat$receiver_request = record
{     active: boolean,
{     activity_status: ^ost$activity_status,
      operation: amt$fap_operation,
      transfer_count: ^amt$transfer_count,
      file_position: ^amt$file_position,
      record_length: ^amt$max_record_length,
      peer_operation: ^nat$se_peer_operation,
      remaining_buffer_capacity: nat$data_length,
      bytes_moved: nat$data_length,
      application_buffer: nat$application_buffer,
    recend;
*copyc amt$fap_operation
*copyc amt$file_position
*copyc amt$max_record_length
*copyc amt$transfer_count
*copyc nat$application_buffer
*copyc nat$data_length
*copyc nat$se_peer_operation
{copyc ost$activity_status
*DECK DECK=NAT$RELAY_COUNT EXPAND=FALSE
 TYPE
    nat$relay_count = integer;
*DECK DECK=NAT$REQUEST_BLOCK EXPAND=FALSE

{
{  The request block is the CPU representation of the CPU / IOU processor
{  interface for network output.
{
{  NOTES:
{    1. The field 'io request' must be the first field the record.
{    2. The field (record) 'network request' is defined as such to permit
{       job / monitor communication of completed requests and to position
{       the field 'peripheral request' on a word boundary.
{    3. The field 'network_request' MUST be the last field in nat$request_block
{       and the field 'peripheral_request' MUST be the last field in nat$network_request.
{       This is because the RMA list MUST be contiguous to the peripheral request.
{

  TYPE
    nat$request_block = record
      io_request: ALIGNED [0 MOD 512] iot$io_request,
      allocation_description: nat$request_block_allocation,
      complete_request_block: ^nat$complete_request_block,
      peripheral_request_rma: ost$real_memory_address,
      network_request: nat$network_request,
    recend,

    nat$network_request = record
      request_block_link: ^nat$request_block, {links completed requests}
      message_id: nlt$bm_message_id,
      rma_list: ^nat$rma_list,
      ethernet_address: ALIGNED [0 MOD 8] nlt$ethernet_addr_and_checksum,
      peripheral_request: nat$peripheral_request,
    recend,

    nat$fixed_rma_list = 1 .. 5,
    nat$rma_list = array [1 .. * ] of nat$rma_list_entry,

    nat$rma_list_entry = record
      length: ALIGNED [0 MOD 8] 0 .. 0ffff(16),
      rma: ALIGNED [4 MOD 8] ost$real_memory_address,
    recend;

?? PUSH (LISTEXT := ON) ??
{
{  The 'complete request block' is used to allocate a 'request block' and
{  its associated 'real memory address list' with a single allocate request.
{
?? POP ??

  TYPE
    nat$complete_request_block = record
      complete_sequence: ALIGNED [0 MOD 1024] SEQ ( * ),
    recend;

*copyc iot$io_request
*copyc nat$peripheral_request
*copyc nat$request_block_allocation
*copyc nlt$bm_message_id
*copyc nlt$ethernet_addr_and_checksum
*copyc ost$hardware_subranges
*DECK DECK=NAT$REQUEST_BLOCK_ALLOCATION EXPAND=FALSE

  TYPE
    nat$request_block_allocation = record
      case preallocated: boolean of
      = TRUE =
        block_identifier: nat$request_block_identifier,

{       a value of zero (0) for next block identifier represents the end
{       of the free request block list.

        next_block_identifier: nat$next_request_block_id,
      casend,
    recend;

*copyc nat$request_block_identifier
*DECK DECK=NAT$REQUEST_BLOCK_IDENTIFIER EXPAND=FALSE

  TYPE
    nat$request_block_identifier = 1 .. 0ffff(16),
    nat$next_request_block_id = 0 .. 0ffff(16);
*DECK DECK=NAT$REQUEST_BLOCK_LIST EXPAND=FALSE

{
{  The request block list is a linked list of completed output requests.
{

  TYPE
    nat$request_block_list = record
      request_block_link: ALIGNED [0 MOD 8] ^nat$request_block,
      requests_queued: 0 .. 0ffff(16),
    recend;

*copyc nat$request_block
*DECK DECK=NAT$RESULT EXPAND=FALSE

  CONST
    nac$successful = 0,
    nac$failed = 1,
    nac$variable_locked = 2;

  TYPE

    nat$result = nac$successful .. nac$variable_locked;
*DECK DECK=NAT$ROUTING_STATISTICS EXPAND=FALSE

  TYPE
    nat$routing_statistics = record
      duplicate_received_ridus: integer,
      ridus_aged_out: integer,
      ridus_received: integer,
      ridus_sent: integer,
      table_recomputed_direct_network: integer,
      table_recomputed_remote_network: integer,
      table_partial_updates: integer,
    recend;

*DECK DECK=NAT$SAP_IDENTIFIER EXPAND=FALSE

  TYPE
    nat$sap_identifier = record
      kind: nat$sap_identifier_kind,
      identifier: nat$internet_sap_identifier,
    recend,

    nat$sap_identifier_kind = (nac$osi_sap_identifier, nac$xns_sap_identifier);

*copyc nat$internet_sap_identifier
*DECK DECK=NAT$SENDER_REQUEST EXPAND=FALSE
  TYPE
    nat$sender_request = record
{     active: boolean,
{     activity_status: ^ost$activity_status,
      operation: amt$fap_operation,
      term_option: amt$term_option,
      end_of_message: boolean,
      qualified_data: boolean,
      remaining_bytes_to_send: nat$data_length,
      application_buffer: nat$application_buffer,
    recend;
*copyc amt$fap_operation
*copyc amt$term_option
*copyc nat$application_buffer
*copyc nat$data_length
{copyc ost$activity_status
*DECK DECK=NAT$SERVER_ATTRIBUTES EXPAND=FALSE

  TYPE
    nat$server_attributes_control = record
      access_control: nlt$access_control,
      server_attributes: ^nat$server_attributes,
    recend,

    nat$server_attributes = record
      access_control: nlt$access_control,
      next_entry: ^nat$server_attributes,
      server: nat$application_name,
      server_status: nat$application_status,
      max_connections: nat$number_of_connections,
      server_titles: ^nat$server_titles_list,
      server_managed_titles: ^nat$title_pattern_list,
      added_titles: ^nat$added_title,
{ Server validation.
      server_capability: ost$name,
      server_ring: ost$ring,
      server_system_privilege: boolean,
{ Other attributes.
      accept_connection: boolean,
      client_validation_capability: ost$name,
      client_info_source: nat$client_info_source,
      client_addresses: ^array [1..*] of nat$client_address,
      reserved_application_id: boolean,
      application_id: nat$generic_sap_identifier,
      sap_open: boolean,
      message_priority: nat$network_message_priority,
      flags: packed record
        nam_accounting: boolean
      recend,
      protocol: nat$protocol,
      connection_count: nat$number_of_connections,
      attempted_connection_count: integer,
      rejected_connection_attempts: integer,
      server_connections_list: ^nat$server_connection_attribute,
      wait_for_connection: ^nat$wait_for_connection,
      assigned_connections_list: ^nat$server_connection_attribute,
      acquire_in_progress: ^nat$server_connection_attribute,
      server_job_list: ^nat$server_job_attributes,
      CASE nam_initiated_server: boolean OF
      = TRUE =
        server_job_validation_source: nat$server_validation_source,
        server_job_max_connections: nat$number_of_connections,
        service_file_defined: boolean,
        server_job_init_pending: boolean,
      = FALSE =
        protocol_activated: boolean,
      CASEND,
    recend,

    nat$server_titles_list = array [1..*] of nat$server_title,
    nat$server_title = record
      title: string (nac$max_title_length),
      distribute_title: boolean,
      priority: nat$directory_priority,
      data_length: nat$directory_data_length,
      data: SEQ (REP nac$max_directory_data_length OF cell),
      directory_id: nat$directory_entry_identifier,
    recend,

    nat$selected_titles_list = array [1..*] of nat$selected_title,
    nat$selected_title = record
      title: string (nac$max_title_length),
      distribute_title: boolean,
      priority: nat$directory_priority,
      data_length: nat$directory_data_length,
      data: SEQ (REP nac$max_directory_data_length OF cell),
    recend,

    nat$added_title = record
      next_title: ^nat$added_title,
      identifier: nat$directory_entry_identifier,
      distribute_title: boolean,
      priority: nat$directory_priority,
      data_length: nat$directory_data_length,
      data: SEQ (REP nac$max_directory_data_length OF cell),
      title: nat$title,
    recend,

    nat$server_job_attributes = record
      next_entry: ^nat$server_job_attributes,
      job_name: jmt$system_supplied_name,
      job_status: nat$server_job_status,
      time_stamp: integer,
      max_connections_per_server_job: nat$number_of_connections,
      connection_count: nat$number_of_connections,
      assigned_connection_count: nat$number_of_connections,
    recend,

    nat$server_job_status = (nac$server_job_initiated, nac$server_job_attached,
      nac$server_job_deactivated),

    nat$server_connection_kind = (nac$owned_by_server, nac$owned_by_job, nac$in_dialog,
      nac$assigned_to_job),
    nat$server_connection_attribute = record
      next_entry: ^nat$server_connection_attribute,
      connection_id: nat$connection_id,
      CASE connection_kind: nat$server_connection_kind OF
      = nac$owned_by_job =
        job_name: jmt$system_supplied_name,
      = nac$assigned_to_job =
        destination_job_name: jmt$system_supplied_name,
        directed_connection: boolean,
        time_stamp: integer,
        terminate_connection: boolean,  { This flag can be set only when acquire connection is in progress}
      CASEND,
    recend,

    nat$client_address = record
      network_id: nat$network_identifier,
      system_kind: nat$client_system_kind,
      system_id: nat$system_identifier {used only if system_kind is nac$any_system_kind},
      reserved_application_id: boolean,
      application_id: nat$internet_sap_identifier {used only for reserved_application_id = TRUE},
    recend,

    nat$client_system_kind = (nac$nosve_system_kind, nac$cdcnet_system_kind, nac$any_system_kind),

    nat$client_info_source = (nac$client_info_via_dialog, nac$client_info_via_conn_data,
       nac$client_info_via_either),
{ *** NOTE: The last two values are not supported

    nat$server_validation_source = (nac$server_job, nac$client),

    nat$wait_for_connection = record
      next_entry: ^nat$wait_for_connection,
      job_name: jmt$system_supplied_name,
      task_id: ost$global_task_id,
      recend,

    nat$max_titles = 0 .. 0ffff(16),
    nat$display_job_attributes = record
      job_name: jmt$system_supplied_name,
      connection_count: nat$number_of_connections,
    recend;

*copyc jmt$system_supplied_name
*copyc nat$connection_id
*copyc nat$application_name
*copyc nat$application_status
*copyc nat$directory_data
*copyc nat$directory_entry_identifier
*copyc nat$directory_priority
*copyc nat$generic_sap_identifier
*copyc nat$internet_sap_identifier
*copyc nat$network_address
*copyc nat$network_message_priority
*copyc nat$number_of_connections
*copyc nat$protocol
*copyc nat$title
*copyc nat$title_pattern
*copyc nat$title_pattern_list
*copyc nlt$access_control
*copyc osd$virtual_address
*copyc ost$global_task_id
*DECK DECK=NAT$SERVICE_ID EXPAND=FALSE
 TYPE
    nat$service_id = 0 .. 255;

  CONST
    nac$xns_internet_service = 1;
*DECK DECK=NAT$SESSION_STATISTICS EXPAND=FALSE

  TYPE
    nat$session_statistics = record
      interrupt_requests_received: integer,
      interrupt_requests_sent: integer,
      synchronize_requests_received: integer,
      synchronize_requests_sent: integer,
    recend;

*DECK DECK=NAT$SE_EVENT_ELEMENT EXPAND=FALSE

  TYPE
    nat$se_event_element = record
      event: nat$se_peer_operation,
      message_id: nlt$bm_message_id,
      start_of_data_sequence: boolean,
      queued_data_length: nat$data_length,
      queued_message_buffers: nat$data_length,
      total_bytes_moved: nat$data_length,
    recend;

*copyc nat$se_peer_operation
*copyc nat$data_fragments
*copyc nat$data_length
*copyc nlt$bm_message_id
*DECK DECK=NAT$SE_EVENT_ELEMENT_QUEUE EXPAND=FALSE
 CONST
    nac$se_max_element_count = 4;

  TYPE
    nat$se_event_element_queue = record
      first: 0 .. 3,
      last: 0 .. 3,
      event_element: array [0 .. nac$se_max_element_count - 1] of
        nat$se_event_element,
      next_element: ^nat$se_event_element_queue,
    recend;

*copyc nat$se_event_element
*DECK DECK=NAT$SE_EVENT_QUEUE EXPAND=FALSE
  TYPE
    nat$se_event_queue = record
      count: 0 .. 0ffffffff(16),
      beginning: ^nat$se_event_element_queue,
      ending: ^nat$se_event_element_queue,
    recend;

*copyc nat$se_event_element_queue
*DECK DECK=NAT$SE_INTERRUPT_DATA_LENGTH EXPAND=FALSE
  TYPE
    nat$se_interrupt_data_length = nac$se_min_interrupt_data_len ..
          nac$se_max_interrupt_data_len;

  CONST
    nac$se_min_interrupt_data_len = 1,
    nac$se_max_interrupt_data_len = 14;
*DECK DECK=NAT$SE_PEER_OPERATION EXPAND=FALSE
 TYPE
    nat$se_peer_operation = record
      case kind: nat$se_peer_operation_kind of
      = nac$se_send_data =
        end_of_message: boolean,
        qualified_data: boolean,
        data_length: nat$data_length,
      = nac$se_interrupt =
        interrupt_data_length: nat$se_interrupt_data_length,
        interrupt_data: SEQ (REP nac$se_max_interrupt_data_len of cell),
      = nac$se_synchronize =
        direction: nat$se_synchronize_direction,
        synchronize_data_length: nat$se_synchronize_data_length,
        synchronize_data: SEQ (REP nac$se_max_synch_data_length of cell),
      = nac$se_synchronize_confirm =
      casend,
    recend;

*copyc nat$se_peer_operation_kind
*copyc nat$data_length
*copyc nat$se_interrupt_data_length
*copyc nat$se_synchronize_direction
*copyc nat$se_synchronize_data_length
*DECK DECK=NAT$SE_PEER_OPERATION_KIND EXPAND=FALSE
 TYPE
    nat$se_peer_operation_kind = (nac$se_send_data, nac$se_interrupt,
      nac$se_synchronize, nac$se_synchronize_confirm);
*DECK DECK=NAT$SE_RECEIVE_DATA_REQ EXPAND=FALSE
 TYPE
    nat$se_receive_data_req = record
      buffer: ^nat$data_fragments,
      wait: ost$wait,
      peer_operation: ^nat$se_peer_operation,
      activity_status: ^ost$activity_status,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
*copyc ost$wait
*copyc nat$se_peer_operation
*copyc ost$activity_status
?? POP ??
*DECK DECK=NAT$SE_SEND_DATA_REQ EXPAND=FALSE
 TYPE
    nat$se_send_data_req = record
      data: ^nat$data_fragments,
      end_of_message: boolean,
      qualified_data: boolean,
      wait: ost$wait,
      activity_status: ^ost$activity_status,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
*copyc ost$activity_status
*copyc ost$wait
?? POP ??
*DECK DECK=NAT$SE_SUPERVISORY_ELEMENT EXPAND=FALSE
  TYPE
    nat$se_supervisory_element = record
      event: nat$se_peer_operation,
      next_element: ^nat$se_supervisory_element,
    recend;

*copyc nat$se_peer_operation
*DECK DECK=NAT$SE_SUPERVISORY_EVENT_QUEUE EXPAND=FALSE
  TYPE
    nat$se_supervisory_event_queue = record
      beginning: ^nat$se_supervisory_element,
      ending: ^nat$se_supervisory_element,
    recend;

*copyc nat$se_supervisory_element
*DECK DECK=NAT$SE_SYNCHRONIZE_DATA_LENGTH EXPAND=FALSE
  TYPE
    nat$se_synchronize_data_length = nac$se_min_synch_data_length ..
          nac$se_max_synch_data_length;

  CONST
    nac$se_min_synch_data_length = 1,
    nac$se_max_synch_data_length = 14;
*DECK DECK=NAT$SE_SYNCHRONIZE_DIRECTION EXPAND=FALSE
 TYPE
    nat$se_synchronize_direction = (nac$se_synchronize_all_data,
      nac$se_synchronize_send_data, nac$se_synchronize_receive_data);
*DECK DECK=NAT$SE_SYNCHRONIZE_REQ EXPAND=FALSE
 TYPE
    nat$se_synchronize_req = record
      direction: nat$se_synchronize_direction,
      data: ^SEQ (*),
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc nat$se_synchronize_direction
?? POP ??
*DECK DECK=NAT$SK_COMPLETED_EVENT EXPAND=FALSE

  TYPE
    nat$sk_completed_event = record
      CASE completed_event_kind: nat$sk_completed_event_kind OF
      = nac$sk_completed_socket_events =
        socket_id: nat$sk_socket_identifier,
        connection_pending: boolean,
        data_available: boolean,
        clear_to_send: boolean,
        network_terminated: boolean,
      = nac$sk_completed_socket_offer =
        source_job: jmt$system_supplied_name,
      = nac$sk_completed_acc_soc_offer =
        socket: nat$sk_socket_identifier,
      = nac$sk_completed_time =
      CASEND,
    recend;

*copyc jmt$system_supplied_name
*copyc nat$sk_completed_event_kind
*copyc nat$sk_socket_identifier
*DECK DECK=NAT$SK_COMPLETED_EVENTS EXPAND=FALSE

  TYPE
    nat$sk_completed_events = array [1..*] of nat$sk_completed_event;

*copyc nat$sk_completed_event
*DECK DECK=NAT$SK_COMPLETED_EVENT_KIND EXPAND=FALSE

  TYPE
    nat$sk_completed_event_kind = (nac$sk_completed_socket_events,
      nac$sk_completed_socket_offer, nac$sk_completed_acc_soc_offer,
      nac$sk_completed_time);
*DECK DECK=NAT$SK_HOST_NAME EXPAND=FALSE

  TYPE
    nat$sk_host_name = record
      length: 1 .. nac$sk_max_host_name_size,
      value: string (nac$sk_max_host_name_size),
    recend;

*copyc nac$sk_max_host_name_size
*DECK DECK=NAT$SK_INTERFACE_MODE EXPAND=FALSE

  TYPE
    nat$sk_interface_mode = (nac$sk_blocking_mode, nac$sk_non_blocking_mode);
*DECK DECK=NAT$SK_IP_ADDRESS EXPAND=FALSE

  TYPE
    nat$sk_ip_address = 0 .. 0ffffffff(16);
*DECK DECK=NAT$SK_JOB_SOCKET EXPAND=FALSE

  TYPE
    nat$sk_job_socket = record
      identifier: nat$sk_socket_identifier,  {local socket id}
      status: nat$sk_job_socket_status,
      time_stamp: ost$free_running_clock,
      application: nat$application_name,
      capability: ost$name,
      ring: ost$ring,
      system_privilege: boolean,
      port: nat$sk_port_number,
      bound_address: nat$sk_ip_address,
      owner: ost$global_task_id,
      interface_mode: nat$sk_interface_mode,
      interface_timeout: integer,
      traffic_pattern: nat$sk_traffic_pattern,
      CASE socket_type: nat$sk_socket_type OF
      = nac$sk_udp_socket =
        global_socket_id: nlt$udp_global_socket_id,
        checksum: boolean,
        local_ip_address_enabled: boolean,
        user_cache_enabled: boolean,
        broadcast_enabled: boolean,
      = nac$sk_tcp_socket =
        tcp_socket_type: nlt$tcp_socket_type,
        connection_id: nat$connection_id,
        local_ip_address: nat$sk_ip_address,
        reuse_address: boolean,
        graceful_close: boolean,
        selection_criteria: nat$sk_socket_address,
      CASEND
    recend;

*copyc nat$application_name
*copyc nat$connection_id
*copyc nat$sk_interface_mode
*copyc nat$sk_ip_address
*copyc nat$sk_job_socket_status
*copyc nat$sk_port_number
*copyc nat$sk_socket_address
*copyc nat$sk_socket_identifier
*copyc nat$sk_socket_type
*copyc nat$sk_traffic_pattern
*copyc nlt$tcp_socket_type
*copyc nlt$udp_global_socket_id
*copyc osd$virtual_address
*copyc ost$free_running_clock
*copyc ost$global_task_id
*copyc ost$name
*DECK DECK=NAT$SK_JOB_SOCKET_ACCESS EXPAND=FALSE

  TYPE
    nat$sk_job_socket_access = record
      lock: ost$signature_lock,
      job_socket: ^nat$sk_job_socket,
    recend;

*copyc nat$sk_job_socket
*copyc ost$signature_lock
*DECK DECK=NAT$SK_JOB_SOCKET_ASSIGNMENT EXPAND=FALSE

  TYPE
    nat$sk_job_socket_assignment = record
      lock: ost$signature_lock,
      assigned_sockets: ^packed array [1 .. 255] of boolean,
    recend;

*copyc ost$signature_lock
*DECK DECK=NAT$SK_JOB_SOCKET_LIST EXPAND=FALSE

  TYPE
    nat$sk_job_socket_list = array [1 .. 255] of nat$sk_job_socket_access;

*copyc nat$sk_job_socket_access
*DECK DECK=NAT$SK_JOB_SOCKET_STATUS EXPAND=FALSE

  TYPE
    nat$sk_job_socket_status = (nac$sk_socket_unbound, nac$sk_socket_open,
      nac$sk_socket_disconnected, nac$sk_socket_closed_via_peer, nac$sk_socket_terminated,
      nac$sk_job_recovery);

*DECK DECK=NAT$SK_LISTEN_QUEUE_LIMIT EXPAND=FALSE

  TYPE
    nat$sk_listen_queue_limit = 1 .. 0ff(16);
*DECK DECK=NAT$SK_LOCAL_ADDRESS EXPAND=FALSE

  TYPE
    nat$sk_local_address = record
      local_address: nat$sk_ip_address,
      supported_protocol: nat$sk_supported_protocol,
    recend;

*copyc nat$sk_ip_address
*copyc nat$sk_supported_protocol
*DECK DECK=NAT$SK_LOCAL_ADDRESSES EXPAND=FALSE

  TYPE
    nat$sk_local_addresses = array [1..*] of nat$sk_local_address;

*copyc nat$sk_local_address
*DECK DECK=NAT$SK_PORT_NUMBER EXPAND=FALSE

  TYPE
    nat$sk_port_number = 0 .. nac$sk_max_port_number;

*copyc nac$sk_max_port_number
*DECK DECK=NAT$SK_SOCKET_ADDRESS EXPAND=FALSE

  TYPE
    nat$sk_socket_address = record
      port: nat$sk_port_number,
      ip_address: nat$sk_ip_address,
    recend;

*copyc nat$sk_ip_address
*copyc nat$sk_port_number
*DECK DECK=NAT$SK_SOCKET_ATTRIBUTE EXPAND=FALSE

  TYPE
    nat$sk_socket_attribute = record
      CASE attribute_kind: nat$sk_socket_attribute_kind OF
      = nac$sk_interface_mode_attr =
        interface_mode: nat$sk_interface_mode,
      = nac$sk_interface_timeout_attr =
        interface_timeout: nat$wait_time,
      = nac$sk_checksum_attr =                       {UDP socket}
        checksum: boolean,
      = nac$sk_traffic_pattern_attr =
        traffic_pattern: nat$sk_traffic_pattern,
      = nac$sk_graceful_close_attr =                 {UDP socket}
        graceful_close: boolean,
      = nac$sk_selection_criteria_attr =             {TCP socket}
        port: nat$sk_port_number,
        ip_address: nat$sk_ip_address,
      = nac$sk_local_addr_enabled_attr =             {UDP socket}
        local_ip_address_enabled: boolean,
      = nac$sk_user_cache_enabled_attr =             {UDP socket}
        user_cache_enabled: boolean,
      = nac$sk_reuse_address_attr =                  {TCP socket}
        reuse_address: boolean,
      = nac$sk_local_address_attr =
        address_count: 0 .. 0ff(16),
        local_port: nat$sk_port_number,
        local_addresses: ^array [1..*] of nat$sk_ip_address,
      = nac$sk_broadcast_enabled_attr =              {UDP socket}
        broadcast_enabled: boolean,
      = nac$sk_optimum_xfer_size_attr =              {TCP socket}
        optimum_transfer_size: nat$data_length,
      CASEND,
    recend;

*copyc nat$data_length
*copyc nat$sk_interface_mode
*copyc nat$sk_ip_address
*copyc nat$sk_port_number
*copyc nat$sk_socket_attribute_kind
*copyc nat$sk_traffic_pattern
*copyc nat$wait_time
*DECK DECK=NAT$SK_SOCKET_ATTRIBUTES EXPAND=FALSE

  TYPE
    nat$sk_socket_attributes = array [1 .. *] of nat$sk_socket_attribute;

*copyc nat$sk_socket_attribute
*DECK DECK=NAT$SK_SOCKET_ATTRIBUTE_KIND EXPAND=FALSE

  TYPE
    nat$sk_socket_attribute_kind = (nac$sk_interface_mode_attr,
      nac$sk_interface_timeout_attr, nac$sk_checksum_attr,
      nac$sk_traffic_pattern_attr, nac$sk_graceful_close_attr,
      nac$sk_selection_criteria_attr, nac$sk_local_addr_enabled_attr,
      nac$sk_user_cache_enabled_attr, nac$sk_reuse_address_attr,
      nac$sk_local_address_attr, nac$sk_broadcast_enabled_attr,
      nac$sk_optimum_xfer_size_attr);
*DECK DECK=NAT$SK_SOCKET_EVENT EXPAND=FALSE

  TYPE
    nat$sk_socket_event = record
      CASE event_kind: nat$sk_socket_event_kind OF
      = nac$sk_await_data_available,
        nac$sk_await_clear_to_send =
        socket_id: nat$sk_socket_identifier,
      = nac$sk_await_socket_offer =
        source_job: jmt$system_supplied_name,
      = nac$sk_await_time =
        wait_time: integer,
      CASEND,
    recend;

*copyc jmt$system_supplied_name
*copyc nat$sk_socket_event_kind
*copyc nat$sk_socket_identifier
*DECK DECK=NAT$SK_SOCKET_EVENTS EXPAND=FALSE

  TYPE
    nat$sk_socket_events = array [1 .. *] of nat$sk_socket_event;

*copyc nat$sk_socket_event
*DECK DECK=NAT$SK_SOCKET_EVENT_KIND EXPAND=FALSE

  CONST
    nac$sk_null_event = 0,
    nac$sk_await_data_available = 1,
    nac$sk_await_clear_to_send = 2,
    nac$sk_await_socket_offer = 3,
    nac$sk_await_time = 4;

  TYPE
    nat$sk_socket_event_kind = 0 .. 0ff(16);

*DECK DECK=NAT$SK_SOCKET_IDENTIFIER EXPAND=FALSE

  TYPE
    nat$sk_socket_identifier = 1 .. nac$sk_max_socket_identifier;

*copyc nac$sk_max_socket_identifier
*DECK DECK=NAT$SK_SOCKET_OPTION EXPAND=FALSE

  TYPE
    nat$sk_socket_option = record
      CASE option_kind: nat$sk_socket_option_kind OF
      = nac$sk_null_opt =
         ,
      = nac$sk_interface_mode_opt =
        interface_mode: nat$sk_interface_mode,
      = nac$sk_interface_timeout_opt =
        interface_timeout: nat$wait_time,
      = nac$sk_checksum_opt =                       {UDP socket}
        checksum: boolean,
      = nac$sk_traffic_pattern_opt =
        traffic_pattern: nat$sk_traffic_pattern,
      = nac$sk_graceful_close_opt =                 {TCP socket}
        graceful_close: boolean,
      = nac$sk_selection_criteria_opt =             {TCP socket}
        port: nat$sk_port_number,
        ip_address: nat$sk_ip_address,
      = nac$sk_local_addr_enabled_opt =             {UDP socket}
        local_ip_address_enabled: boolean,
      = nac$sk_user_cache_enabled_opt =             {UDP socket}
        user_cache_enabled: boolean,
      = nac$sk_reuse_address_opt =
        reuse_address: boolean,                     {TCP socket}
      = nac$sk_broadcast_enabled_opt =              {UDP socket}
        broadcast_enabled: boolean,
      CASEND,
    recend;

*copyc nat$sk_interface_mode
*copyc nat$sk_ip_address
*copyc nat$sk_port_number
*copyc nat$sk_socket_option_kind
*copyc nat$sk_traffic_pattern
*copyc nat$wait_time
*DECK DECK=NAT$SK_SOCKET_OPTIONS EXPAND=FALSE

  TYPE
    nat$sk_socket_options = array [1 .. *] of nat$sk_socket_option;
*copyc nat$sk_socket_option
*DECK DECK=NAT$SK_SOCKET_OPTION_KIND EXPAND=FALSE

  TYPE
    nat$sk_socket_option_kind = (nac$sk_null_opt,
      nac$sk_interface_mode_opt, nac$sk_interface_timeout_opt,
      nac$sk_checksum_opt, nac$sk_traffic_pattern_opt,
      nac$sk_graceful_close_opt, nac$sk_selection_criteria_opt,
      nac$sk_local_addr_enabled_opt, nac$sk_user_cache_enabled_opt,
      nac$sk_reuse_address_opt, nac$sk_broadcast_enabled_opt);
*DECK DECK=NAT$SK_SOCKET_STATUS EXPAND=FALSE

  TYPE
    nat$sk_socket_status = record
      clear_to_send: boolean,
      data_pending_receive: integer,
      connection_pending: boolean,
    recend;
*DECK DECK=NAT$SK_SOCKET_TYPE EXPAND=FALSE

  TYPE
    nat$sk_socket_type = (nac$sk_udp_socket, nac$sk_tcp_socket);
*DECK DECK=NAT$SK_SUPPORTED_PROTOCOL EXPAND=FALSE

  TYPE
    nat$sk_supported_protocol = (nac$sk_udp, nac$sk_tcp, nac$sk_udp_and_tcp);
*DECK DECK=NAT$SK_SWITCH_EVENT_KIND EXPAND=FALSE

  TYPE
    nat$sk_switch_event_kind = (nac$sk_await_socket_offer,
      nac$sk_await_acc_socket_offer);
*DECK DECK=NAT$SK_TRAFFIC_PATTERN EXPAND=FALSE

  CONST
    nac$sk_udp_cmd_response_traffic = 1,
    nac$sk_udp_stream_input_traffic = 2,
    nac$sk_udp_stream_out_traffic = 3,
    nac$sk_udp_random_traffic = 4,
    nac$sk_udp_last_traffic_pattern = 4;

  CONST
    nac$sk_tcp_cmd_response_traffic = 1,
    nac$sk_tcp_stream_input_traffic = 2,
    nac$sk_tcp_stream_out_traffic = 3,
    nac$sk_tcp_random_traffic = 4,
    nac$sk_tcp_delay_push = 5,
    nac$sk_tcp_last_traffic_pattern = 5;

  TYPE
    nat$sk_traffic_pattern = 0 .. 0ff(16);
*DECK DECK=NAT$SK_WRITE_OPTIONS EXPAND=FALSE

  TYPE
    nat$sk_write_options = record
      urgent: boolean,
      flush: boolean,
    recend;
*DECK DECK=NAT$SUBNET_IDENTIFIER EXPAND=FALSE

  TYPE
    nat$subnet_identifier = 0 .. 0ffff(16);
*DECK DECK=NAT$SWITCHED_CONNECTION EXPAND=FALSE

  TYPE
    nat$switched_connections_list = RECORD
      access_control: nlt$access_control,
      wait_for_switch_offer: ^nat$wait_for_switch_offer,
      switched_connection: ^nat$switched_connection,
      recend,

    nat$wait_for_switch_offer = RECORD
      next_entry: ^nat$wait_for_switch_offer,
      destination_job_name: jmt$system_supplied_name,
      source_job_name: jmt$system_supplied_name,
      destination_task_id: ost$global_task_id,
      recend,

    nat$switched_connection = RECORD
      next_entry: ^nat$switched_connection,
      application: nat$application_name,
      switch_status: nat$switch_status,
      source_job_name: jmt$system_supplied_name,
      destination_job_name: jmt$system_supplied_name,
      connection_id: nat$connection_id,
      wait_for_switch_accept: ost$global_task_id,
      recend,

    nat$switch_status = (nac$switch_pending, nac$switch_complete);

*copyc jmt$system_supplied_name
*copyc ost$global_task_id
*copyc nat$application_name
*copyc nat$connection_id
*copyc nlt$access_control
*DECK DECK=NAT$SYSTEM_ADDRESS EXPAND=FALSE
  TYPE
    nat$system_address = record
      network: nat$network_identifier,
      system: nat$system_identifier,
    recend;

*copyc nat$network_identifier
*copyc nat$system_identifier
*DECK DECK=NAT$SYSTEM_IDENTIFIER EXPAND=FALSE

  TYPE
    nat$system_identifier = 0 .. nac$max_system_identifier;

*IF $true(osv$unix)

  CONST
    nac$max_system_identifier = 7fffffff(16);

*ELSE

  CONST
    nac$max_system_identifier = 0ffffffffffff(16);

*IFEND
*DECK DECK=NAT$SYSTEM_MGMT_ENTITY_STATS EXPAND=FALSE

  TYPE
    nat$system_mgmt_entity_stats = record
      cdna_address_select_device_reqs: integer,
      noncdna_addr_select_device_reqs: integer,
      cdna_address_route_unknown: integer,
      noncdna_address_route_unknown: integer,
      device_routing_queries: integer,
      subnet_attribute_updates_rcvd: integer,
    recend;
*DECK DECK=NAT$SYSTEM_TITLE EXPAND=FALSE

  CONST
    nac$system_title_size = osc$max_name_size,
    nac$system_title_prefix_size = 8,
    nac$system_title_prefix = '$SYSTEM_';

  TYPE
    nat$system_title = ost$name;

*copyc ost$name
*DECK DECK=NAT$TA_ALTERNATE_PROTOCOL_CLASS EXPAND=FALSE

TYPE
  nat$ta_alternate_protocol_class = nac$ta_min_alternate_protocol ..
        nac$ta_max_alternate_protocol;

*copyc nac$ta_alternate_protocol_class
*DECK DECK=NAT$TA_PREFERRED_PROTOCOL_CLASS EXPAND=FALSE

TYPE
  nat$ta_preferred_protocol_class = nac$ta_min_preferred_class .. nac$ta_max_preferred_class;

*copyc nac$ta_preferred_protocol_class
*DECK DECK=NAT$TCPIP_ADDRESS EXPAND=FALSE
  TYPE
    nat$tcpip_address = record
      network_id: nat$network_identifier,
      system_kind: nat$client_system_kind,
      system_id: nat$system_identifier,
      reserved_application_id: boolean,
      application_id: nat$sk_port_number,
    recend;

*copyc nat$network_identifier
*copyc nat$server_attributes
*copyc nat$sk_socket_address
*copyc nat$system_identifier
*DECK DECK=NAT$TCPIP_ATTRIBUTES EXPAND=FALSE
  TYPE
    nat$tcpip_attributes_control = record
      access_control: nlt$access_control,
      tcpip_attributes: ^nat$tcpip_attributes,
    recend,

    nat$tcpip_attributes = record
      access_control: nlt$access_control,
      next_entry: ^nat$tcpip_attributes,
      tcpip_application: nat$application_name,
      tcpip_status: nat$application_status,
      maximum_sockets: nat$number_of_sockets,
{ Application validation.
      tcpip_capability: ost$name,
      tcpip_ring: ost$ring,
      tcpip_system_privilege: boolean,
{ Other attributes.
      flags: packed record
        nam_accounting: boolean,
      recend,
      active_socket_count: nat$number_of_sockets,
      socket_attempt_count: integer,
      socket_reject_count: integer,
      CASE protocol: nat$protocol OF
      = nac$stream_socket =
        tcp_socket_list: ^nat$tcp_socket,
      = nac$datagram_socket =
        udp_socket_list: ^nat$udp_socket,
      CASEND,
    recend;

*copyc jmt$system_supplied_name
*copyc nat$application_name
*copyc nat$application_status
*copyc nat$number_of_sockets
*copyc nat$protocol
*copyc nat$server_attributes
*copyc nat$tcp_socket
*copyc nat$udp_socket
*copyc nlt$access_control
*copyc osd$virtual_address
*copyc ost$global_task_id
*copyc ost$name
*DECK DECK=NAT$TCP_SOCKET EXPAND=FALSE
  TYPE
    nat$tcp_socket = record
      next_entry: ^nat$tcp_socket,
      socket_assigned: boolean,
      connection_id: nat$connection_id,
    recend;

*copyc nat$connection_id
*DECK DECK=NAT$TERMINATION_REASON EXPAND=FALSE
  TYPE
    nat$termination_reason = (nac$peer_request, nac$connection_failed,
      nac$application_deactivated, nac$system_interrupt, nac$local_clear);
*DECK DECK=NAT$TITLE EXPAND=FALSE
 CONST
    nac$max_title_length = 255;

  TYPE
    nat$title_length = 1 .. nac$max_title_length,

    nat$title = string ( * <= nac$max_title_length);
*DECK DECK=NAT$TITLE_ATTRIBUTES EXPAND=FALSE

  TYPE
    nat$title_attributes = array [1 .. * ] of nat$title_attribute,

    nat$title_attribute_kind = (nac$title_priority, nac$title_data),

    nat$title_attribute = record
{
{ This record must be initialized such that the value of the SELECTOR field
{ identifies the attribute whose value is being specified and the corresponding
{ variant field contains (or points to) the desired attribute value.
{
      case selector: nat$title_attribute_kind of
      = nac$title_priority =
        priority: nat$directory_priority,
      = nac$title_data =
        data: ^nat$directory_data,
      casend,
    recend;

*copyc nat$directory_priority
*copyc nat$directory_data
*DECK DECK=NAT$TITLE_LIST EXPAND=FALSE
 TYPE
    nat$title_list = record
      first: ^nat$translation,
      next_timer: integer,
    recend;

*copyc nat$translation
*DECK DECK=NAT$TITLE_PATTERN EXPAND=FALSE

  CONST
    nac$max_title_pattern_length = 255;

  TYPE
    nat$title_pattern = string ( * <= nac$max_title_pattern_length);

*DECK DECK=NAT$TITLE_PATTERN_LIST EXPAND=FALSE

  TYPE
    nat$title_pattern_list = array [1 .. *] of string (nac$max_title_pattern_length);

*copyc nat$title_pattern
*DECK DECK=NAT$TRANSLATION EXPAND=FALSE
 TYPE
    nat$translation = record
      link: ^nat$translation,
      title: ^nat$title,
      identifier: nat$directory_entry_identifier,
      user_identifier: ost$name,
      change_count: 0 .. 0ffff(16),
      password: nat$directory_password,
      protocol: nat$protocol,
      {CASE} osi_address_kind: (undefined_address, registration_address, translation_address),
      {= registration_address =}
        registered_address: nat$osi_registration_address,
      {= translation_address =}
        osi_address: ^SEQ ( * ),
      {CASEND,}
      user_information: ^string ( * <= nac$max_directory_data_length),
      priority: nat$directory_priority,
      class: nat$title_class,
      domain: nat$title_domain {RDS-distribution_domain,TDS-originator_domain} ,
      distribute: boolean,
      broadcast_counter: 0 .. 0ff(16),
      time_stamp: integer {RDS-time of next broadcast, TDS-time of receipt} ,
      reported: boolean {relevant in translation list for TRDS entry only} ,
      detail: SEQ ( * ),
    recend;

*copyc nat$directory_data
*copyc nat$directory_interfaces
*copyc nat$directory_entry_identifier
*copyc nat$protocol
*copyc nat$title
*copyc nat$directory_priority
*copyc ost$name
*DECK DECK=NAT$TRANSLATION_ATTRIBUTES EXPAND=FALSE

  TYPE
    nat$translation_attributes = array [1 .. * ] of nat$translation_attribute,

    nat$translation_attribute_kind = (nac$translation_title,
          nac$translation_priority, nac$translation_data,
          nac$translation_protocol),

    nat$translation_attribute = record
{
{ The value of the SELECTOR field must be initialized to identify the attribute
{ whose value is to be returned.  The attribute value is returned in the
{ corresponding variant field or in a variable pointed to by the variant field.
{
{ The value of any input field of pointer type must point to a program variable
{ where the attribute value is to be returned.  If the pointer is an adaptable
{ pointer, then the associated output field returns an adaptable type fixer
{ which specifies the actual size of the attribute value.  If the size of the
{ attribute value exceeds the size of the specified program variable, then an
{ abnormal status is returned.
{
      case selector: {input} nat$translation_attribute_kind of
      = nac$translation_title =
        title: {input} ^nat$title,
        title_length: nat$title_length,
      = nac$translation_priority =
        priority: nat$directory_priority,
      = nac$translation_data =
        data: {input} ^nat$directory_data,
        data_length: nat$directory_data_length,
      = nac$translation_protocol =
        protocol: nat$protocol,
      casend,
    recend;

*copyc nat$title
*copyc nat$directory_priority
*copyc nat$directory_data
*copyc nat$protocol
*DECK DECK=NAT$TRANSLATION_REQUEST EXPAND=FALSE
 TYPE
    nat$translation_request = record
      link: ^nat$translation_request,
      wild_card: boolean,
      identifier: nat$directory_search_identifier,
      protocol: nat$protocol,
      class: nat$title_class,
      recurrent_search: boolean,
      domain: nat$title_domain {primitive: search_domain; pdu: request_domain} ,
      broadcast_counter: 0 .. 3,
      time_stamp: integer,
      first_translation: ^nat$translation,
      search_required: boolean,
      repeat_local_search: boolean,
      requestor: ost$global_task_id,
      title: nat$title,
    recend;

*copyc nat$directory_interfaces
*copyc nat$directory_search_identifier
*copyc nat$protocol
*copyc nat$title
*copyc nat$translation
*copyc ost$global_task_id
*DECK DECK=NAT$TRANSLATION_REQUEST_LIST EXPAND=FALSE
 TYPE
    nat$translation_request_list = record
      first: ^nat$translation_request,
      next_broadcast_time: integer,
    recend;

*copyc nat$translation_request
*DECK DECK=NAT$TRANSPORT_ACCESS_STATISTICS EXPAND=FALSE

  TYPE
    nat$transport_access_statistics = record
      data_pdus_received: integer,
      data_pdus_sent: integer,
      expedited_pdus_received: integer,
      expedited_pdus_sent: integer,
      total_bytes_received: integer,
      total_bytes_sent: integer,
    recend;
*DECK DECK=NAT$TRANSPORT_STATISTICS EXPAND=FALSE

  TYPE
    nat$transport_statistics = record
      initiated_connections: integer,
      active_connections: integer,
      reference_number_wait: integer,
      connections_terminated: integer,
      data_packets_received: integer,
      data_packets_sent: integer,
      discarded_data_packets: integer,
      duplicate_data_packets: integer,
      xdata_packets_received: integer,
      xdata_packets_sent: integer,
      discarded_xdata_packets: integer,
      duplicate_xdata_packets: integer,
      acknowledgment_requests_recved: integer,
      acknowledgment_requests_sent: integer,
      acknowledgments_discarded: integer,
      probe_packets_discarded: integer,
      probe_packets_received: integer,
      probe_packets_sent: integer,
      retransmissions: integer,
      error_packets_received: integer,
      error_packets_sent: integer,
    recend;

*DECK DECK=NAT$UDP_SOCKET EXPAND=FALSE
  TYPE
    nat$udp_socket = record
      next_entry: ^nat$udp_socket,
      global_socket_id: nlt$udp_global_socket_id,
    recend;

*copyc nlt$udp_global_socket_id
*DECK DECK=NAT$USER_INTERFACE EXPAND=FALSE
 TYPE
    nat$user_sap_id = SEQ (REP 8 of cell),
    nat$user_connection_id = SEQ (REP 8 of cell);
*DECK DECK=NAT$VERSION EXPAND=FALSE

  CONST
    nac$max_version = 255;

  TYPE
    nat$version = 0 .. 255;
*DECK DECK=NAT$WAIT_TIME EXPAND=FALSE

  TYPE
    nat$wait_time = 0 .. nac$max_wait_time;

*IF $true(osv$unix)

  CONST
    nac$max_wait_time = 7fffffff(16);

*ELSE

  CONST
    nac$max_wait_time = 0ffffffff(16);

*IFEND
*DECK DECK=NAV$APPLICATIONS_INSTALLED EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

 VAR
   nav$applications_installed: [XREF, oss$network_paged] boolean;
*DECK DECK=NAV$APPLICATION_MGMT_TASKID EXPAND=FALSE

  VAR
    nav$application_mgmt_taskid: [XREF, OSS$NETWORK_PAGED] ost$global_task_id;

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
?? POP ??
*DECK DECK=NAV$APPL_DEFN_TIME_STAMP EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  VAR
    nav$appl_defn_time_stamp: [XREF, oss$network_paged] ost$date_time;
*DECK DECK=NAV$ASSIGNED_CONNECTIONS_LIST EXPAND=FALSE

    VAR
      nav$assigned_connections_list: [XREF, OSS$NETWORK_PAGED]
        nat$assigned_connections_list;

?? PUSH (LISTEXT := ON) ??
*copyc nat$assigned_connection
?? POP ??
*DECK DECK=NAV$ASSIGNED_SAP_LIST EXPAND=FALSE

 VAR
    nav$assigned_sap_list: [XREF, oss$network_paged] nat$assigned_sap_list;

?? PUSH (LISTEXT := ON) ??
*copyc nat$assigned_sap_list
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$CDNA_BROADCAST_ADDRESS EXPAND=FALSE
 VAR
    nav$cdna_broadcast_address: [XREF, READ, oss$network_paged] nat$system_identifier;

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_address
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$CDNA_MULTICAST_ADDRESS EXPAND=FALSE
 VAR
    nav$cdna_multicast_address: [XREF, oss$network_paged] nat$system_identifier;

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_address
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$CHANGE_NAM_ATTRIBUTES_LOCK EXPAND=FALSE
 VAR
     nav$change_nam_attributes_lock: [XREF] ost$signature_lock ;

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??
*DECK DECK=NAV$CLIENT_ATTRIBUTES_LIST EXPAND=FALSE

  VAR
    nav$client_attributes_list : [XREF, OSS$NETWORK_PAGED]
      nat$client_attributes_control;

*copyc nat$client_attributes
?? POP ??
*DECK DECK=NAV$CN_MAXIMUM_DATA_LENGTH EXPAND=FALSE
 VAR
    nav$cn_maximum_data_length: [XREF, oss$network_paged] nat$data_length;

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
?? POP ??
*DECK DECK=NAV$CN_SAP_LIST EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

 VAR
    nav$cn_sap_list: [XREF, oss$network_paged] nat$cn_sap_list;

*copyc nat$cn_active_sap_list
*copyc oss$network_paged
*DECK DECK=NAV$COMPLETED_OUTPUT_REQUESTS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  VAR
    nav$completed_output_requests: [XREF] nat$request_block_list;

?? PUSH (LISTEXT := ON) ??
*copyc nat$request_block_list
?? POP ??
*DECK DECK=NAV$COMPLETED_OUTPUT_TASKID EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  VAR
    nav$completed_output_taskid: [XREF, oss$mainframe_wired] ost$global_task_id;

*copyc oss$mainframe_wired
*copyc ost$global_task_id

*DECK DECK=NAV$CONNECTION_ESTABLISH_TASKID EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  VAR
    nav$connection_establish_taskid: [XREF, oss$mainframe_wired] ost$global_task_id;

*copyc oss$mainframe_wired
*copyc ost$global_task_id
*DECK DECK=NAV$DEBUG_MODE EXPAND=FALSE

  VAR
    nav$debug_mode: [XREF] 0 .. 0ff(16);

?? PUSH (LISTEXT := ON) ??
*copyc nac$namve_debug_mode
?? POP ??

*DECK DECK=NAV$DIRECTORY_ME_TASKID EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  VAR
    nav$directory_me_taskid: [XREF, oss$mainframe_wired] ost$global_task_id;

*copyc oss$mainframe_wired
*copyc ost$global_task_id
*DECK DECK=NAV$DISABLE_NETWORK_RELAYS EXPAND=FALSE

  VAR
    nav$disable_network_relays: [XREF] boolean;
*DECK DECK=NAV$FINAL_LOGIN_PROMPT EXPAND=FALSE

  VAR
    nav$final_login_prompt: [XREF, oss$network_paged] nat$am_login_prompt;

?? PUSH (LISTEXT := ON) ??
*copyc nat$am_login_prompt
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$FORCE_PASSWORD_PROMPT EXPAND=FALSE

  VAR
    nav$force_password_prompt: [XREF, oss$network_paged] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$GLOBAL_OSI_STATISTICS EXPAND=FALSE

  VAR
    nav$global_osi_statistics: [XREF, oss$network_paged]
          nat$global_osi_statistics;

?? PUSH (LISTEXT := ON) ??
*copyc nat$global_osi_statistics
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$GLOBAL_STATISTICS EXPAND=FALSE

  VAR
    nav$global_statistics: [XREF, oss$network_paged]
          nat$global_statistics;

?? PUSH (LISTEXT := ON) ??
*copyc nat$global_statistics
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$GT_ASSIGNED_SAP_LIST EXPAND=FALSE

 VAR
    nav$gt_assigned_sap_list: [XREF, oss$network_paged] nat$gt_assigned_sap_list;

?? PUSH (LISTEXT := ON) ??
*copyc nat$gt_assigned_sap_list
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$GT_JOB_CONNECTION_LIST EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  VAR
    nav$gt_job_connection_list: [XREF] nat$gt_job_connection_list;

*copyc nat$gt_job_connection

*DECK DECK=NAV$GT_JOB_SAP_LIST EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  VAR
    nav$gt_job_sap_list: [XREF] nat$gt_job_sap_list;

*copyc nat$gt_job_sap
*DECK DECK=NAV$GT_SAP_LIST EXPAND=FALSE
 VAR
    nav$gt_sap_list: [XREF, oss$network_paged] nat$gt_sap_list;
*DECK DECK=NAV$HOST_SUBNET_ID EXPAND=FALSE

  VAR
    nav$host_subnet_id: [XREF] nat$subnet_identifier;

?? PUSH (LISTEXT := ON) ??
*copyc nat$subnet_identifier
?? POP ??
*DECK DECK=NAV$ICA_RESET_DOWN_THRESHOLD EXPAND=FALSE
  VAR
    nav$ica_reset_down_threshold: [XREF, OSS$NETWORK_PAGED] nat$ica_reset_down_threshold;
?? PUSH (LISTEXT := ON) ??
*copyc nat$net_device_config_param
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$INCLUDE_DEBUG_KEYPOINTS EXPAND=FALSE

  {  Define the variable to control compilation of debug keypoints.
  ? VAR
      nav$include_debug_keypoints: boolean := FALSE ?;
*DECK DECK=NAV$INCLUDE_PP_BREAKPOINT EXPAND=FALSE
{  define the variable to control compilation of pp breakpoint code
  ? VAR
    nav$include_pp_breakpoint: boolean := FALSE ?;
*DECK DECK=NAV$INTRANET_LAYER_MGMT_TASKID EXPAND=FALSE
  VAR
    nav$intranet_layer_mgmt_taskid : [XREF, OSS$NETWORK_WIRED] ost$global_task_id;

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc oss$network_wired
?? POP ??
*DECK DECK=NAV$INTRANET_MGMT_TIMER_ACTIVE EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  VAR
    nav$intranet_mgmt_timer_active: [XREF,  oss$network_paged] boolean;
*DECK DECK=NAV$INTRANET_MGMT_WORK_LIST EXPAND=FALSE
  VAR
    nav$intranet_mgmt_work_list: [XREF, OSS$NETWORK_WIRED] nat$network_driver_responses;

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_driver_response
*copyc oss$network_wired
?? POP ??
*DECK DECK=NAV$MAXIMUM_LOGIN_ATTEMPTS EXPAND=FALSE

  VAR
    nav$maximum_login_attempts: [XREF, oss$network_paged] nat$maximum_login_attempts;

?? PUSH (LISTEXT := ON) ??
*copyc nat$maximum_login_attempts
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$MCI_RESET_DOWN_THRESHOLD EXPAND=FALSE
  VAR
    nav$mci_reset_down_threshold: [XREF, OSS$NETWORK_PAGED] nat$mci_reset_down_threshold;
?? PUSH (LISTEXT := ON) ??
*copyc nat$net_device_config_param
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$NAMVE_ACTIVE EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  VAR
    nav$namve_active: [XREF, oss$network_paged] boolean;
*DECK DECK=NAV$NAM_INITIATED EXPAND=FALSE

  VAR
    nav$nam_initiated: [XREF, OSS$NETWORK_PAGED] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$NETWORK_ID EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  VAR
    nav$network_id: [XREF] nat$network_identifier;

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_address
?? POP ??
*DECK DECK=NAV$NETWORK_PAGED_HEAP EXPAND=FALSE

  VAR
    nav$network_paged_heap: [XREF, oss$network_paged] ^ost$heap;

?? PUSH (LISTEXT := ON) ??
*copyc nac$network_heap_size
*copyc oss$network_paged
*copyc ost$heap
?? POP ??
*DECK DECK=NAV$NETWORK_PROCEDURES EXPAND=FALSE
VAR
  nav$network_procedures: [XREF] array [nat$network_procedure] of
      nat$network_procedures;
?? PUSH (LISTEXT := ON) ??
*copyc nat$network_procedure
*copyc nat$network_procedures
?? POP ??
*DECK DECK=NAV$NETWORK_RESPONSE_PROCESSOR EXPAND=FALSE

  VAR
    nav$network_response_processor: [XREF] iot$response_processor;

?? PUSH (LISTEXT := ON) ??
*copyc IOT$IO_REQUEST
?? POP ??
*DECK DECK=NAV$NETWORK_WIRED_HEAP EXPAND=FALSE

  VAR
    nav$network_wired_heap: [XREF, oss$network_wired] ^ost$heap;

?? PUSH (LISTEXT := ON) ??
*copyc nac$network_heap_size
*copyc oss$network_wired
*copyc ost$heap
?? POP ??
*DECK DECK=NAV$OPEN_CN_SAP_LIST EXPAND=FALSE
 VAR
    nav$open_cn_sap_list: [XREF, oss$network_paged]
      ^nat$open_cn_sap_descriptor;

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
*copyc nat$open_cn_sap_descriptor
?? POP ??
*DECK DECK=NAV$OPEN_CN_SAP_LIST_LOCK EXPAND=FALSE
 VAR
    nav$open_cn_sap_list_lock: [XREF, oss$network_paged] ost$signature_lock;

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
*copyc ost$signature_lock
?? POP ??
*DECK DECK=NAV$OPEN_NETWORK_SAP_LIST EXPAND=FALSE

 VAR
    nav$open_network_sap_list: [XREF, oss$network_paged]
      ^nat$open_network_sap_descriptor;

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
*copyc nat$open_network_sap_descriptor
?? POP ??
*DECK DECK=NAV$OPEN_NETWORK_SAP_LIST_LOCK EXPAND=FALSE
 VAR
    nav$open_network_sap_list_lock: [XREF, oss$network_paged] ost$signature_lock;

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
*copyc ost$signature_lock
?? POP ??
*DECK DECK=NAV$PREALLOCATED_RB_CONTROL EXPAND=FALSE

  VAR
    nav$preallocated_rb_control: [XREF] nat$preallocated_rb_control;

?? PUSH (LISTEXT := ON) ??
*copyc nat$preallocated_rb_control
?? POP ??
*DECK DECK=NAV$PREALLOCATED_REQUEST_BLOCK EXPAND=FALSE

  VAR
    nav$preallocated_request_block: [XREF] nat$preallocated_request_blocks;

?? PUSH (LISTEXT := ON) ??
*copyc nat$preallocated_request_blocks
?? POP ??
*DECK DECK=NAV$PROMPT_FOR_ACCOUNT EXPAND=FALSE

  VAR
    nav$prompt_for_account: [XREF, oss$network_paged] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$PROMPT_FOR_FAMILY_NAME EXPAND=FALSE

  VAR
    nav$prompt_for_family_name: [XREF, oss$network_paged] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$PROMPT_FOR_PROJECT EXPAND=FALSE

  VAR
    nav$prompt_for_project: [XREF, oss$network_paged] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$REGISTERED_TITLES EXPAND=FALSE
 VAR
    nav$registered_titles: [XREF, oss$network_paged] nat$title_list;

?? PUSH (LISTEXT := ON) ??
*copyc nat$title_list
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$SERVER_ATTRIBUTES_LIST EXPAND=FALSE

  VAR
    nav$server_attributes_list: [XREF, OSS$NETWORK_PAGED]
      nat$server_attributes_control;

?? PUSH (LISTEXT := ON) ??
*copyc nat$server_attributes
?? POP ??
*DECK DECK=NAV$SI_RECEIVED_MESSAGE_LIST EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  VAR
    nav$si_received_message_list: [XREF, oss$mainframe_wired_cb] nat$received_message_list;
?? PUSH (LISTEXT := ON) ??
*copyc nat$received_message_list
*copyc oss$mainframe_wired_cb
?? POP ??
*DECK DECK=NAV$SK_JOB_SOCKET_ASSIGNMENT EXPAND=FALSE

  VAR
    nav$sk_job_socket_assignment: [XREF, oss$job_pageable] nat$sk_job_socket_assignment;

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_job_socket_assignment
*copyc oss$job_pageable
?? POP ??
*DECK DECK=NAV$SK_JOB_SOCKET_LIST EXPAND=FALSE

  VAR
    nav$sk_job_socket_list: [XREF, oss$job_pageable] ^nat$sk_job_socket_list;

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_job_socket_list
*copyc oss$job_pageable
?? POP ??
*DECK DECK=NAV$SK_SOCKET_LAYER_ACTIVE EXPAND=FALSE

  VAR
    nav$sk_socket_layer_active: [XREF, oss$network_paged] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$STATISTICS_ENABLED EXPAND=FALSE

  VAR
    nav$statistics_enabled: [XREF, oss$network_paged] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$SWITCHED_CONNECTIONS_LIST EXPAND=FALSE

  VAR
    nav$switched_connections_list: [XREF, OSS$NETWORK_PAGED]
      nat$switched_connections_list;

?? PUSH (LISTEXT := ON) ??
*copyc nat$switched_connection
?? POP ??
*DECK DECK=NAV$SYSTEM_ID EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  VAR
    nav$system_id: [XREF, oss$mainframe_wired] nat$system_identifier;

?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_wired
*copyc nat$network_address
?? POP ??
*DECK DECK=NAV$SYSTEM_INPUT_TASKID EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  VAR
    nav$system_input_taskid: [XREF, oss$mainframe_wired] ost$global_task_id;

*copyc oss$mainframe_wired
*copyc ost$global_task_id
*DECK DECK=NAV$TCPIP_ATTRIBUTES_LIST EXPAND=FALSE

  VAR
    nav$tcpip_attributes_list: [XREF, OSS$NETWORK_PAGED]
      nat$tcpip_attributes_control;

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
*copyc nat$tcpip_attributes
?? POP ??
*DECK DECK=NAV$TRANSLATION_CACHE EXPAND=FALSE
 VAR
    nav$translation_cache: [XREF, oss$network_paged] nat$title_list;

?? PUSH (LISTEXT := ON) ??
*copyc nat$title_list
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$TRANSLATION_REQUESTS EXPAND=FALSE
 VAR
    nav$translation_requests: [XREF, oss$network_paged]
      nat$translation_request_list;

?? PUSH (LISTEXT := ON) ??
*copyc nat$translation_request_list
*copyc oss$network_paged
?? POP ??
*DECK DECK=NAV$UNIQUE_DIRECTORY_IDENTIFIER EXPAND=FALSE
  VAR
    nav$unique_directory_identifier: [XREF] integer;
*DECK DECK=NET#ON EXPAND=FALSE

{  Procedure [XREF] declarations for cybil interface to the nam aip routines
{    on the c170 side.

{  The interfaces reside on (c170, compass) deck ifmcin .


  PROCEDURE [XREF] net#on (aname: iit$nam_application_name;
    nsup: ^cell;
    status: ^cell;
    minacn,
    maxacn: iit$application_connection_num);

  PROCEDURE [XREF] net#wait (time,
    kind: integer);

  PROCEDURE [XREF] net#off;

  PROCEDURE [XREF] net#gtl (aln: iit$application_list_number;
    msg: ^cell;
    tlmax: iit$text_length);

  PROCEDURE [XREF] net#get (acn: iit$application_connection_num;
    msg: ^cell;
    tlmax: iit$text_length);

  PROCEDURE [XREF] net#put (msg: ^cell);

  PROCEDURE [XREF] net#stc (onoff: integer;
    avail: ^cell);

  PROCEDURE [XREF] net#dbg (dbugsup: integer;
    dbugdat: integer;
    avail: ^cell);

  PROCEDURE [XREF] roj (time: integer);

  PROCEDURE [XREF] pause (time: integer);
*DECK DECK=NFB$SCFS_PROTOCOL_SPECIFICATION EXPAND=TRUE
\setu~
\setb@
\seth^
\folio=CONTROL DATA PRIVATE
\blank
\skip15
\center,b=SCFS/VE
\center=Protocol Specification
\center=January 25, 1991
\page1
\autosec
\tablcon
\title1=Status and Control Facility Server PS
\block,j1,i4
\ n.0 PREFACE
 This protocol specification documents the I/O processing required of the Status
and Control Facility Server on NOS/VE. SCFS/VE runs as part of the C180 host
software portion of the batch device support service.
SCFS/VE
also provides status and control services for Network Transfer Facility
(NTF) remote systems and associated batch streams.
The protocol specification
provides a specification for the work request messages received/transmitted
by SCFS/VE, the protocol required to control work request/reply messages,
as well as the necessary information needed to establish a connection with
SCFS/VE.
\ n.n notes
\item,j1,n.
 . The conventions below are followed for names used as parameters on the work
request messages:

\+flowtab;1,3

 ;-;~I/O^Station^Name~:^^The name of an I/O station.

 ;-;~Directly^Connected^Remote^System^Name~:^^The name of a remote system
directly connected to a Device Interface.

 ;-;~Accessible^Remote^System^Name~:^^The name of a remote system which is
accessible via a directly connected remote system.

 ;-;~Remote^System^Name~:^^The name of a directly connected or accessible remote
system.

 ;-;~Station^Name~:^^The name of an I/O station, a directly connected or
accessible remote system

 ;-;~Stream^Name~:^^The name of a batch stream associated with a remote
system.

 ;-;~Device^Name~:^^The name of a device associated with an I/O station or
the name of a batch stream associated with a remote system.
\-

 . Future plans will support expansion of the user identity to three
parameters (community, family, user). The full design of the community facility
is not complete, and this feature will not be implemented in the first
release of batch device support. As a result of this no community parameters
have been included in this document. Once the community facility specifications
are completed this document will be updated to include the required
parameters.
\ n.n references
\item,j1,N.
 . CDCNET Batch Device Support DAP (ARH6250)
 . NOS/VE Batch Device Support DDD
 . CDCNET Status and Control Facility/DI ERS
 . CDCNET Terminal Support ERS (ARH6408)
 . CDCNET Standalone Printer Support DAP (SVL5134)
 . Network Transfer Facility (NTF) DAP (ARH7454)
\block,j1,i4
\ n.0 WORK REQUEST MESSAGE DESCRIPTIONS
\ n.n Messages between SCFS/VE and SCF/DI
\ n.n.n.n BTFS/DI Status
 This message is received from SCF/DI to inform SCFS that the BTFS/DI service
is available and the network address or title (or both) used to access that
service.  The use of "advanced features" may also be conveyed.  The status
message is normally sent after a new connection is established between SCFS and
SCF/DI.  The status message may also be used to inform SCFS that the service
has failed (status "down").

\+block
 Message received from SCF/DI

 Required parameter

\+item
 - Status Code
\-

 Optional Parameters

\+
 - BTFS/DI Network Address
 - BTFS/DI Title
 - BTFS/DI Advanced Features
\--
\ n.n.n.n Add I/O Station
 Request to define a new I/O station under control of this SCFS/VE copy. The I/O
station name supplied is checked against all current I/O station definitions.
The I/O station name supplied is also checked against
existing remote system names.  If the I/O station name supplied does not
currently exist,
the definition is done, if the name already
exists a test is done on the "check I/O station unique" parameter. If
this parameter is TRUE the definition is rejected. If this parameter
is FALSE the definition is accepted if an existing definition is found
identical and the current definition also has "check I/O station unique"
set to FALSE.

\+
 Message received from SCF/DI

 Required parameters

\+item
 - I/O Station Name
 - Station Usage
 - File Acknowledgement
 - Check I/O Station Unique
 - Auto Operator Control
 - Default Job Destination
 - Destination Unavailable Action
 - PM Message Action
\-

 Optional Parameters

\+
 - I/O station Alias 1
 - I/O station Alias 2
 - I/O station Alias 3
 - Required Operator Device Name
\--
\ n.n.n.n Add I/O Station Response
 Response message to SCF/DI giving the result of the definition.

\+
 Message sent to SCF/DI

 Required parameters

\+
 - I/O Station Name
 - Response Code
\--
\ n.n.n.n Add Remote System
 Request to define a new remote system under control of this SCFS/VE
copy.  The remote system name supplied is checked against all current
remote system and I/O station definitions.  If the new remote system
name does not currently exist, the definition is accepted.  If the
remote system name already exists and the new logical line number
matches an existing logical line number, the new definition is
rejected.  If the remote system name already exists and the existing
definition is identical to the new definition (except for Logical Line
Number, Line Speed, Line Name and Terminal User Procedure) the new
definition is accepted.  If the remote system name already exists and
the existing definition is not identical to the new definition, the new
definition is rejected.

\+
 Message received from SCF/DI

 Required parameters

\+item
 - Directly Connected Remote System Name
 - Remote System Protocol
 - Authority Level
 - Logical Line Number
 - Line Speed
 - Line Name
 - Terminal User Procedure
 - Wait-a-bit
 - Inactivity Timer
 - Positive Acknowledge
 - Default Job Destination
 - Default File Destination
 - Store and Forward Destination
 - Remote System Type
 - Route Back Position
 - Request Permission Retry
 - Local System Name
\--
\ n.n.n.n Add Accessible Remote System
 Request to define a new accessible remote system under control of this
SCFS/VE copy.  The accessible remote system name supplied is checked
against all current remote system (directly connected and accessible)
and I/O station definitions.  If the new accessible remote system name
does not currently exist, the definition is accepted.  If the new
accessible remote system name does not currently exist for the
specified directly connected remote system, the definition is accepted.
If the accessible remote system name is already defined for the
specified directly connected remote system and the Authority Level
specified is identical to the existing definition, the new definition
is accepted.  If the accessible remote system name is already defined
for the specified directly connected remote system and the Authority
Level specified is not identical to the existing definition, the new
definition is rejected.

\+
 Message received from SCF/DI

 Required parameters

\+item
 - Directly Connected Remote System Name
 - Logical Line number
 - Accessible Remote System Name
 - Authority Level of Accessible Remote System
 - Accessible Remote System Type
 - Route Back Position
\--
\ n.n.n.n Add Remote System Response
 Response message to SCF/DI giving the result of the Add Remote System
definition.

\+
 Message sent to SCF/DI

 Required parameters

\+
 - Directly Connected Remote System Name
 - Logical Line Number
 - Response Code
\--
\ n.n.n.n Add Accessible Remote System Response
 Response message to SCF/DI giving the result of the Add Accessible Remote
System definition.

\+
 Message sent to SCF/DI

 Required parameters

\+
 - Directly Connected Remote System Name
 - Logical Line Number
 - Accessible Remote System Name
 - Response Code
\--
\ n.n.n.n Delete I/O Station
 Request to delete access to the I/O station for the specified SCF/DI
connection.  Any batch devices defined for the requesting DI, that are
defined for the I/O station are deleted.  When all SCF/DI connections
are deleted the complete I/O station is deleted.

\+
 Message received from SCF/DI

 Required parameters

\+
 - I/O Station Name
\--
\ n.n.n.n Delete I/O Station Response
 Response message to SCF/DI giving the result of the deletion.

\+
 Message sent to SCF/DI

 Required parameters

\+
 - I/O Station Name
 - Response Code
\--
\ n.n.n.n Delete Remote System
 Request to delete access to the remote system for the
specified SCF/DI connection.  Any batch streams associated with the remote
system for this DI connection are deleted.  When all SCF/DI connections
are deleted the complete remote system is deleted.
If accessible remote systems can only be reached via the deleted directly
connected remote system, then those accessible remote systems are also deleted.

\+
 Message received from SCF/DI

 Required parameters

\+item
 - Directly Connected Remote System Name
 - Logical Line Number
\--
\ n.n.n.n Delete Remote System Response
 Response message to SCF/DI giving the result of the deletion.

\+
 Message sent to SCF/DI

 Required parameters

\+item
 - Directly Connected Remote System Name
 - Response Code
 - Logical Line Number
\--
\ n.n.n.n Start I/O Station
 Inform SCF/DI that an operator has now been assigned to this I/O station.
This message is sent for all I/O stations but is required to activate
the batch devices for I/O stations which have the "check I/O station
unique" attribute set to TRUE.

\+
 Message sent to SCF/DI

 Required parameters

\+
 - I/O Station Name
 - User Identity (user and family names)
\--
\ n.n.n.n Stop I/O Station
 Inform SCF/DI that the operator for this station is no longer assigned.
This message is sent for all I/O stations but causes the batch devices
to be deactivated at the end of the current file if the "check I/O
station unique" attribute  is set to TRUE.

\+
 Message sent to SCF/DI

 Required parameters

\+
 - I/O Station Name
\--
\ n.n.n.n Switch Control
 Command to cause SCF/DI to delete an I/O station or remote system from one
control facility SCFS and to re-establish the I/O station and the
associated devices or remote system and the associated batch streams to
another control facility.
\+

 Message sent to SCF/DI

 Required parameters

\+
 - Station Name
 - Control Facility
\--
\ n.n.n.n Add Batch Device
 Request to define a new batch device within an existing I/O station.
The device name must be unique within the I/O station.
 This message is also used for a request to define a new batch stream
within an existing remote system.  The batch stream name must be unique within
the remote system.

\+
 Message received from SCF/DI

 Required parameters

\+
 - Station Name
 - Device Name
 - Device Status
 - File Transfer Status
 - Device Type
 - Tip Type
 - File Acknowledgement
 - Transmission Block Size
 - Maximum File Size
 - Page Width
 - Page Length (ignored at NOSVE R1.2.2)
 - Banner Page Count
 - Banner Highlight Field
 - Carriage Control Action
 - Forms Code 1
 - External Device Characteristics 1
 - Suppress Carriage Control
 - Code Set
 - Vertical Print Density
 - Forms Size
 - Undefined Format Effector Action
 - Unsupported Format Effector Action
 - Maximum Page Length
 - Control Code Replacement
 - Data Parity
\-

 Required parameter for NTF

\+
 - Logical Line Number
 - Transparent Mode
\-

 Optional Parameters

\+
 - Device Alias (1 - 3)
 - Terminal Model
 - Forms Code (2 -4)
 - External Device Characteristics (2 -4)
 - VFU Load Procedure
 - VFU Load Option
 - Site-defined Code Set
\-

 Optional Parameter for NTF

\+
 - Skip Punch Count
\--
\ n.n.n.n Add Batch Device Response
 Response message to SCF/DI giving the result of the definition.

\+
 Message sent to SCF/DI

 Required parameters

\+
 - Station Name
 - Device Name
 - Response Code
\--
\ n.n.n.n Delete Batch Device
 Request to delete the definition of an existing batch device within an
existing I/O station.
 This message is also used for a request to delete the definition of an
existing batch stream within an existing remote system.

\+
 Message received from SCF/DI

 Required parameters

\+
 - Station Name
 - Device Name
\--
\ n.n.n.n Delete Batch Device Response
 Response message to SCF/DI giving the result of the deletion.

\+
 Message sent to SCF/DI

 Required parameters

\+
 - Station Name
 - Device Name
 - Response Code
\--
\ n.n.n.n Batch Device Status
 This message is received from SCF/DI whenever the status of a batch device
or batch stream changes.

\+
 Message received from SCF/DI

 Required parameters

\+
 - Station Name
 - Device Name
 - Device Status
 - File Transfer Status
\--
\ n.n.n.n File Status
 This message is received from SCF/DI when a status change occurs in
the "file transfer status" (e.g. start and end of file transfer) at
a batch device or batch stream.

\+
 Message received from SCF/DI

 Required parameters

\+
 - Station Name
 - Device Name
 - Device Status
 - File Transfer Status

\-
 Required for input files.

\+
 - User Job Name
 - Actual Destination

\-
 Optional for input files

\+
\nojust
 - Requested Destination (if different from actual destination)
 - System Job Name       (if file transfer complete)
 - Input Bytes Transferred
\just

\-
 Required for output files.

\+
 - System File Name
 - System Identifier (family)
 - User File Name
 - File Position
\--
\ n.n.n.n Terminate Transfer
 Command to terminate the transfer of a job/file from/to a batch device or
batch stream.  The batch device or batch stream remains active for the
transfer of subsequent jobs/files.  The only permissible file disposition
option for an input device or receive type batch stream is DROP.  The
allowable file disposition options for an output device or transmit type
batch stream are:^REQUEUE, DROP, and HOLD.

\+
 Message sent to SCF/DI

 Required parameters

\+
 - Station Name
 - Device Name
 - File Disposition (REQUEUE/DROP/HOLD)
\--
\ n.n.n.n Terminate Transfer Response
 Response to the Terminate Transfer command above.

\+
 Message from SCF/DI

 Required parameters

\+
 - Station Name
 - Device Name
 - Response Code
\--
\ n.n.n.n Stop Batch Device
 Command to take a batch device or batch stream out of service.  The device
or batch stream is removed from service immediately for file dispositions
= SUSPEND, REQUEUE, DROP or HOLD and is removed from service at the end of
the current job/file for file disposition = FINISH.

\+
 Message sent to SCF/DI

 Required parameters

\+
 - Station Name
 - Device Name
 - File Disposition (REQUEUE/DROP/HOLD/FINISH/SUSPEND)
\--
\ n.n.n.n Stop Batch Device Response
 Response to the Stop Batch Device Command above.

\+
 Message from SCF/DI

 Required parameters

\+
 - Station Name
 - Device Name
 - Response Code
\--
\ n.n.n.n Start Batch Device
 Command to make a batch device or batch stream available for file transfer
following a Stop Batch Device Command.  A suspended, file being sent to an
I/O station, will restart at it's suspended position (unless
re-positioned) when the device was stopped.  A suspended file, being sent
to a remote system will restart from the beginning.

\+
 Message sent to SCF/DI

 Required parameters

\+
 - Station Name
 - Device Name
\--
\ n.n.n.n Start Batch Device Response
 Response to the Start Batch Device command above.

\+
 Message from SCF/DI

 Required parameters

\+
 - Station Name
 - Device Name
 - Response Code
\--
\ n.n.n.n Suppress Carriage Control
 Command to suppress carriage control or remove suppress carriage
control for a specific batch output device.

\+
 Message sent to SCF/DI

 Required parameters

\+
 - I/O Station Name
 - Device Name
 - Suppress Format Control
\--
\ n.n.n.n Suppress Carriage Control Response
 Response message to Suppress Carriage Control command above.

\+
 Message from SCF/DI

 Required parameters

\+
 - I/O Station Name
 - Device Name
 - Response Code
\--
\ n.n.n.n Change Batch Device Attributes
 Command to change the attributes defined for a specific batch device or batch
stream.  This message is generated in response to a
change_batch_device_attributes I/O station operator command or
change_batch_stream_attributes NTF operator command.

\+
 Message sent to SCF/DI

 Required parameters

\+
 - Station Name
 - Device Name
\-

 Optional parameters

\+
 - Device Alias 1
 - Device Alias 2
 - Device Alias 3
 - File Acknowledgement
 - Terminal Model
 - Transmission Block Size
 - Maximum File Size
 - Page Width
 - Page Length (ignored at NOSVE R1.2.2 and later systems)
 - Banner Page Count
 - Banner Highlight Field
 - Carriage Control Action
 - Forms Code (1 - 4)
 - External Device Characteristics (1 - 4)
 - Code Set
 - Vertical Print Density
 - VFU Load Procedure
 - Forms Size
 - Undefined Format Effector Action
 - Unsupported Format Effector Action
 - Skip Punch Count
 - Control Code Replacement
 - Data Parity
 - Site-defined Code Set
\--
\ n.n.n.n Change Batch Device Attributes Response
 Response message to the Change Batch Device Attributes command above.

\+
 Message from SCF/DI

 Required parameters

\+
 - Station Name
 - Device Name
 - Response Code
\-

 Optional parameters

\+
 - Device Alias 1
 - Device Alias 2
 - Device Alias 3
 - Terminal Model
 - File Acknowledgement
 - Transmission Block Size
 - Maximum File Size
 - Page Width
 - Page Length (ignored at NOSVE R1.2.2)
 - Banner Page Count
 - Banner Highlight Field
 - Carriage Control Action
 - Forms Code (1 - 4)
 - External Device Characteristics (1 - 4)
 - Code Set
 - Vertical Print Density
 - VFU Load Procedure
 - Forms Size
 - Undefined Format Effector Action
 - Unsupported Format Effector Action
 - Invalid Attribute (parameter # with validation error)
 - Skip Punch Count
 - Control Code Replacement
 - Data Parity
 - Site-defined Code Set
\--
\ n.n.n.n Position File Transfer
 Request to re-position an output file transfer that is currently active on
an output device. The request is sent in response to a position file
operator command. The information is forwarded to SCF/DI for processing
and the device is suspended.  The request is forwarded to BTF/VE, via BTFS/DI,
for processing.
\+

 Message sent to SCF/DI

 Required parameters

\+
 - I/O Station Name
 - Device Name
 - Parameters passed to BTF/VE as received
\--
\ n.n.n.n Position File Transfer Response
 Response to the Position File Transfer command above.

\+
 Message from SCF/DI

 Required parameters

\+
 - I/O Station Name
 - Device Name
 - Response Code
\--
\ n.n.n.n Operator Message
 Request to send a message to the I/O station
operator. This message is expected to originate in a print file "PM"
entry, upon detection of an error condition or to contain preview data for
file positioning.

\+
 Message received from SCF/DI

 Required parameters

\+
 - I/O Station Name
 - Device Name
 - text
\--
\ n.n.n.n Send Remote Command
 Request to transmit a command or message to a remote system.

\+
 Message sent to SCF/DI

 Required parameters

\+item
 - Remote System Name
 - Stream Name
 - Logical Line Number
 - Command Type (Command, Message, Signon, Signoff, TDP)
 - Command Text
\--
\ n.n.n.n Send Remote Command Response
 Response to the Send Remote Command command above.

\+
 Message received from SCF/DI

 Required parameters

\+item
 - Remote System Name
 - Stream Name
 - Command Type
 - Signon Status
 - Response Code
\--
\page
\ n.n Messages between SCFS/VE and SCF/VE or SCFS/VE and NTF/VE
 The following commands are exchanged between SCFS/VE and SCF/VE to assign
output files to batch devices.  These commands are also exchanged between
SCFS/VE and NTF/VE to assign transmit files to batch streams.
\ n.n.n.n Add File Availability
 Request to add a file entry in the transmit file
scheduling queue(s).

\+
 Message received from SCF/VE or NTF/VE

 Required parameters

\+
 - Station Name (public ios or NTF)
 - User Identity (user name + family name) (private ios)
 - Station Usage
 - System File Name
 - System Job Name
 - User File Name
 - User Job Name
 - User Name
 - User Family
 - Copies
 - Device Name
 - Device Type
 - External Device Characteristics
 - File Size
 - Forms Code
 - Output Data Mode
 - Output Initial Priority
 - Output Maximum Priority
 - Output Priority Factor
 - Output State
\-

 Required if print file

\+
 - Page Format
 - Page Length
 - Page Width
 - Vertical Print Density
 - VFU Load Procedure
\--
\ n.n.n.n Modify File Availability
 Request to modify a file entry in the transmit file
scheduling queue(s).

\+
 Message received from SCF/VE or NTF/VE

 Required parameters

\+
 - Station Name (public ios or NTF)
 - User Identity (user name + family name) (private ios)
 - Station Usage
 - System File Name
 - System Job Name
 - User File Name
 - User Job Name
\-

 Optional parameters

\+
 - Copies
 - Device Name
 - External Device Characteristics
 - Forms Code
 - Output Initial Priority
 - VFU Load Procedure
 - Vertical Print Density
\--
\page
\ n.n.n.n Delete File Availability
 Request to delete a file entry in the transmit file
scheduling queue(s).

\+
 Message received from SCF/VE or NTF/VE

 Required parameters

\+
 - Station Name (public ios or NTF)
 - User Identity (user name + family name) (private ios)
 - Station Usage
 - System File Name
 - System Job Name
 - User File Name
 - User Job Name
 - File Requeued
\-

 Optional parameters

\+
 - File held by output filter (SCF/VE only)
\--
\ n.n.n.n File Assignment
 This message is sent to SCF/VE or NTF/VE upon assignment of a transmit file to
an output device or batch stream.

\+
 Message sent to SCF/VE  or NTF/VE

 Required parameters

\+
 - Station Name
 - Device Name
 - Device Type
 - System File Name
 - Requested Destination Name
 - Requested Device Name
 - Operator Name
 - Operator Family
 - Station Usage
 - Copies
 - External Characteristics
 - Forms Code
 - Output Initial Priority
 - VFU Load Procedure
 - Vertical Print Density
\-

 Required parameters for SCF (Device Attributes)

\+

 - Banner highlight field
 - Banner page count
 - Carriage control support
 - Code set
 - File acknowledgement
 - Forms size
 - Maximum file size
 - Page width
 - Tip type
 - Transmission block size
 - Undefined FE action
 - Unsupported FE action
 - Vertical print density
 - VFU load option
\-

 Optional parameters for SCF (Device Attributes supplied if non-blank)

\+
 - Device alias 1
 - Device alias 2
 - Device alias 3
 - External characteristics 1
 - External characteristics 2
 - External characteristics 3
 - External characteristics 4
 - Forms code 1
 - Forms code 2
 - Forms code 3
 - Forms code 4
 - Terminal model
 - VFU load procedure
\-

 Optional parameters

\+
 - BTFS/DI Network Address **
 - BTFS/DI Title **

 ** One and only one of these parameters must appear
\-

 Required parameters for NTF

\+
 - Remote System Protocol
 - Remote System Type
 - Route Back Position
\--
\ n.n.n.n File Assignment Response
 This message is sent in response to the File Assignment message. If the
message is rejected by SCF/VE or NTF/VE, then SCFS/VE should remove the file
assignment and attempt to assign a different file to the batch device or
batch stream.

\+
 Message received from SCF/VE or NTF/VE

 Required parameters

\+
 - Station Name
 - Device Name
 - System File Name
 - Response Code
\--
\ n.n.n.n Delete Destination
 This message is sent to SCF/VE by SCFS/VE when an I/O station or alias has been
deleted from the control facility.  SCF/VE should wait for the destination to
return before sending file availability messages to the control facility.

\+
 Message received from SCFS/VE

 Required parameters

\+
 - Destination Name
 - Control Facility Name
\--
\ n.n.n.n BTF/VE Status
 This message is sent to SCFS/VE by SCF/VE or NTF/VE to convey the protocol
stacks supported by the NOS/VE system where the BTF/VE resides.  This message
is normally sent before any File Availability messages.

\+
 Message received from SCF/VE or NTF/VE

 Required parameter

\+
 - BTF/VE Protocol Stacks
\--
\ n.n.n.n Terminate Queued Output
 Request to delete a file from the station's output queue before it gets
transferred.

\+
 Message sent by OPERATE_STATION utility to SCFS and by SCFS/VE to SCF/VE

 Required Parameters

\+
 - I/O Station Name
 - System File Name or User File Name
\--
\ n.n.n.n Terminate Queued Output Response
 Response to Terminate Queued Output command above.

\+
 Message sent by SCF/VE to SCFS/VE and by SCFS to OPERATE_STATION utility

 Required Parameters

\+
 - I/O Station Name
 - System File Name or User File Name
 - Response Code (Status of file termination)
\--
\page
\ n.n Messages between SCFS/VE and operator utilities
 The following commands may be exchanged between SCFS/VE and the OPERATE_STATION
utility (OPES) or between SCFS/VE and the OPERATE_NTF utility (OPENTF).
\ n.n.n.n Add User
 Request to register a new user as an I/O station operator. For the first
parameter, if the I/O station is a private dynamic station then the control
facility name is used, otherwise the I/O station name is used.
 This message is also used by OPENTF to request control of a remote system
by a new NTF operator. The request may also specify whether unsolicited
messages are to be sent over the connection.

\+
 Message received from OPES or OPENTF

 Required parameters

\+
 - Station Name
 - Family Name
 - User Name
 - Control Device
\-

 Optional parameters

\+
 - Station Usage
 - Accept Messages
\--
\ n.n.n.n Add User Response
 Response message to the Add User command above.

\+
 Message sent to OPES or OPENTF

 Parameters

\+
 - Station Name
 - Response Code
\--
\ n.n.n.n Change Batch Device Attributes
 Request to change various attributes defined for batch devices or batch
streams.  This message is generated by a change_batch_device_attributes
I/O station operator command or by a change_batch_stream_attributes NTF
operator command.

\+
 Message received from OPES or OPENTF

 Required parameters

\+
 - Station Name
 - Device Name
\-

 Optional parameters

\+
 - Device Alias 1
 - Device Alias 2
 - Device Alias 3
 - Terminal Model
 - File Acknowledgement
 - Transmission Block Size
 - Maximum File Size
 - Page Width
 - Page Length (ignored at NOSVE R1.2.2)
 - Banner Page Count
 - Banner Highlight Field
 - Carriage Control Action
 - Forms Code (1 - 4)
 - External Characteristics (1 - 4)
 - Code Set
 - Vertical Print Density
 - VFU Load Procedure
 - Forms Size
 - Undefined Format Effector Action
 - Unsupported Format Effector Action
 - Skip Punch Count
 - Control Code Replacement
 - Data Parity
 - Site-defined Code Set
\--
\ n.n.n.n Change Batch Device Attributes Response
 Response message to the Change Batch Device Attributes command above.

\+
 Message sent to OPES or OPENTF

 Required parameters

\+
 - Station Name
 - Device Name
 - Response Code
\-

 Optional parameters

\+
 - Device Alias 1
 - Device Alias 2
 - Device Alias 3
 - Terminal Model
 - File Acknowledgement
 - Transmission Block Size
 - Maximum File Size
 - Page Width
 - Page Length (ignored at NOSVE R1.2.2)
 - Banner Page Count
 - Banner Highlight Field
 - Carriage Control Action
 - Forms Code (1 - 4)
 - External Device Characteristics (1 - 4)
 - Code Set
 - Vertical Print Density
 - VFU Load Procedure
 - Forms Size
 - Undefined Format Effector Action
 - Unsupported Format Effector Action
 - Invalid Attribute (parameter # with validation error)
 - Skip Punch Count
 - Control Code Replacement
 - Data Parity
 - Site-defined Code Set
\--
\ n.n.n.n Stop Batch Device
 Request that a batch device or batch stream be suspended from file scheduling.
If any
transfer is active the action required is specified by the File Disposition
parameter.

\+
 Message received from OPES or OPENTF

 Required parameters

\+
 - Station Name
 - Device Name
 - File Disposition
\--
\ n.n.n.n Stop Batch Device Response
 Response to the Stop Batch Device command above.

\+
 Message sent to OPES or OPENTF

 Required parameters

\+
 - Station Name
 - Device Name
 - Response Code
\--
\ n.n.n.n Start Batch Device
 Request that a batch device or batch stream currently "stopped" be enabled
for scheduling.

\+
 Message received from OPES or OPENTF

 Required parameters

\+
 - Station Name
 - Device Name
\--
\ n.n.n.n Start Batch Device Response
 Response to the Start Batch Device command above.

\+
 Message sent to OPES or OPENTF

 Required parameters

\+
 - Station Name
 - Device Name
 - Response Code
\--
\ n.n.n.n Terminate Transfer
 Command to terminate the transfer of a job/file from/to
a batch device or batch stream.  The batch device or batch stream
remains active for the transfer of subsequent jobs/files.
The only permissible file disposition option for an input device
or receive type batch stream
is DROP. The
allowable file disposition options for an output device
or transmit batch stream
are: REQUEUE, DROP,
and HOLD.

\+
 Message received from OPES or OPENTF

 Required parameters

\+
 - Station Name
 - Device Name
 - File Disposition
\--
\ n.n.n.n Terminate Transfer Response
 Response to the Terminate Transfer command above.

\+
 Message sent to OPES or OPENTF

 Required parameters

\+
 - Station Name
 - Device Name
 - Response Code
\--
\ n.n.n.n Select File
 Request that an output file be selected for immediate processing on the I/O
station being operated. In the event of the file being eligible for processing
on multiple I/O stations, the file is removed from selection for all I/O
stations controlled by the same Control Facility. Candidate I/O stations
controlled by another control facility are not affected.
 If the optional device name is included, the file is forced to that device.
 This message is also used to request that a NTF file be selected for
immediate processing.  If the optional batch stream name is included, the file
is forced to that batch stream.

\+
 Message received from OPES or OPENTF

 Required parameters

\+
 - Station Name
 - System File Name or User File Name
\-

 Optional parameters

\+
 - Device Name
\--
\ n.n.n.n Select File Response
 Response to the Select File command above.

\+
 Message sent to OPES or OPENTF

 Required parameters

\+
 - Station Name
 - System File Name or User File Name
 - Response Code
\-

 Optional parameters

\+
 - Device Name
\--
\ n.n.n.n Get Device Status
 Request for detailed status information about a specified batch device
or batch stream.
\+

 Message received from OPES or OPENTF

 Required parameter

\+
 - Station Name
 - Device Name
\--
\ n.n.n.n Device Status Data
 Response to Get Device Status command above. Status information is returned
for the
specified batch device or batch stream.
 If this is a response to a Station Status message that requested an OPTIMIZED
response then the Device Status Data message will contain information about all
the devices on the I/O station.  Information about each device will be separated
from the next by a NULL parameter.
\+

 Message sent to OPES or OPENTF

 Required parameters

\+
 - Station Name
 - Device Name
 - Response Code
 - Device Status
 - Device Type
 - File Transfer Status
 - Terminal Model
 - File Acknowledge
 - Maximum File Size
 - Page Length (ignored at NOSVE R1.2.2)
 - Page Width
 - Banner Page Count
 - Banner Highlight Field
 - Transmission Block Size
 - Carriage Control Action
 - Forms Code 1
 - External Characteristics 1
 - Suppress Carriage Control
 - Last Unsolicited Message
 - Code Set
 - Vertical Print Density
 - Forms Size
 - Undefined Format Effector Action
 - Unsupported Format Effector Action
 - VFU Load Option
 - Control Code Replacement
 - Data Parity
\-

 Optional parameters

\+
 - Device Alias (1 - 3)
 - External Characteristic (2 - 4)
 - Forms Code (2 - 4)
 - VFU Load Procedure
 - Site-defined Code Set
\-

 Optional parameters for output devices

\+
 - System Supplied File Name
 - User Supplied File Name
 - System Supplied Job Name of Originating Job
 - User Supplied Job Name of Originating Job
 - Login User Name of Originating Job
 - Family Name of Originating Job
 - Percent Complete
\-

 Optional parameters for input devices

\+
 - User Job Name
 - Destination Name
 - Input Bytes Transferred
\-

 Optional parameters for NTF

\+
 - Logical Line Number
 - Transparent Mode
 - Skip Punch Count
\--
\ n.n.n.n Get Queue Status
 Request for status information about output queue(s) for an I/O station or
transmit queue(s) for a remote system.  Information is accumulated for all
queues which may be processed by the I/O station or remote system.
\+

 Message received from OPES or OPENTF

 Required parameters

\+
 - Station Name
\--
\ n.n.n.n Queue Status Data
 Response to the Get Queue Status command above.  Information is returned as
specified under the Get Queue Status command above.
 The status data returned comprises:
\item,j1,l.
 . Number of files for selector
 . Total byte length of files for selector
 . Age of oldest file for selector (integer minutes)
 . Average age of files for selector (integer minutes)
\block,j1,i4

\+

 Message sent to OPES or OPENTF

 Required parameters

\+
\nojust
 - Station Name
 - Number of Files in Queue
 - Response Code
 - Count of External Characteristics
 - External Characteristic & Status (repeated Count times)
 - Count of Forms Codes
 - Forms Code & Status (repeated Count times)
 - Count of Device Names
 - Device Name & Status (repeated Count times)
 - Count of Destination Names (Station and Station Alias or Remote System Names)
 - Destination & Status (repeated Count times)
 - Count of Device Types
 - Device Type and Status
\just
\--
\ n.n.n.n Get Queue Entry List
 Request for a list of all system file names and current priorities for files
in a queue.

 If the optional parameter number of entries is supplied only that many
file names will be returned. File names are returned in priority order.

 If optimization is requested then attributes of all queue files will be returned
using the Queue Entry Data message.
\+

 Message received from OPES or OPENTF

 Required parameters

\+
 - Station Name
 - All or Top 10 Files
\-

 Optional parameter

\+
 - Optimize Queue List

\--
\ n.n.n.n Queue Entry List Data
 Response to the Get Queue Entry List command above. Information is returned as
specified under Get Queue Entry List command above.
\+

 Message sent to OPES or OPENTF

 Required parameters

\+
\nojust
 - Station Name
 - Response Code
 - Count of files
 - System File Name & Priority (repeated Count times)
\just
\--
\ n.n.n.n Get Queue Entry
 Request for detailed information about a specified queue file.
\+

 Message received from OPES or OPENTF

 Required parameters

\+
 - Station Name
 - System File Name or User File Name
\--
\ n.n.n.n Queue Entry Data
 Response to the Get Queue Entry command above,
or to the Get Queue Entry List (w/optimize) command.
Detailed information pertaining
to the specified queue file(s) is returned.
 If the number of files is more than can be sent in
one message, multiple messages will be sent, each of
which will end with the continue parameter (except
the last).
\+

 Message sent to OPES or OPENTF

 Required parameters

\+
 - Station Name
 - System File Name
 - Response Code
 - User File Name
 - Time Enqueued by SCFS/VE
 - Position in Queue
 - Priority
 - Copies
 - Creating Job Family Name
 - Creating System Job Name
 - Creating User Job Name
 - Creating User Name
 - Data Mode
 - Destination Name
 - Device Type
 - File Length
 - File Transfer State
\-

 Optional parameters

\+
 - Device name
 - External Characteristics
 - Forms Code
 - Page Format
 - Page Length (ignored at NOSVE R1.2.2)
 - Page Width
 - Vertical Print Density
 - VFU Load Procedure
 - Queue Entry Data Continues
\--
\page
\ n.n Messages between SCFS/VE and OPERATE_STATION utility
\ n.n.n.n Position File
 Request to re-position a device output transfer currently active. The
request is sent in response to a position_device operator command. The
information is forwarded to SCF/DI for processing and the device suspended.

\+
 Message received from OPERATE_STATION utility

 Required parameters

\+
 - I/O Station Name
 - Device Name
 - Location Integer
 - Location String 1
 - Location String 2
 - Units
 - Direction
 - Starting position
\-

 Optional parameters

\+
 - Preview line count
\--
 Note the location specifiers may only occur in the following groups:
\item,j1,n.
 . Location Integer alone
 . Location String 1 alone
 . Location String 1 and Location String 2
\block,j1,i4
 Any other combinations are invalid and should be considered illegal.
\ n.n.n.n Position File Transfer Response
 Response to the Position File Transfer command above.

\+
 Message sent to OPERATE_STATION utility

 Required parameters

\+
 - I/O Station Name
 - Device Name
 - Response Code
\--
\ n.n.n.n Suppress Carriage Control
 Request that carriage control processing be suppressed for a specified device.
Carriage control processing is only suppressed for a single file transfer.

\+
 Message received from OPERATE_STATION utility

 Required parameters

\+
 - I/O Station Name
 - Device Name
\--
\ n.n.n.n Suppress Carriage Control Response
 Response message to Suppress Carriage Control command above.

\+
 Message sent to OPERATE_STATION utility

 Required parameters

\+
 - I/O Station Name
 - Device Name
 - Response Code
\--
\ n.n.n.n Get Station Status
 Request for I/O station status information.
\+

 Message received from OPERATE_STATION utility

 Required parameters

\+
 - I/O Station Name
\-

 Optional parameter

\+
 - Optimized Device List
\--
\ n.n.n.n Station Status Data
 Reply to the "Get Station Status" request. Status information is returned
about the I/O station.
\+

 Message sent to OPERATE_STATION utility

 Required parameters

\+
\nojust
 - I/O Station Name
 - Response Code
 - Control Facility Name
 - Number of Files Queued for Output
 - Station Usage
 - File Acknowledgement
 - Count of Devices
 - Device Name, Device Status, File Transfer Status, & Device Type
(repeated Count times)
 - Default Job Destination
 - Destination Unavailable Action
 - PM Message Action
\-

 Optional parameters

\+
 - Required Console Device Name
 - I/O Station Alias 1
 - I/O Station Alias 2
 - I/O Station Alias 3
\--
\just
 Note the Device Name, Device Status, Device Type, and File Transfer Status are
all returned in one parameter using the "Device Status Name" parameter format.
\ n.n.n.n Terminate Queued Output
 Request to delete a file from the station's output queue before it gets
transferred.

\+
 Message sent by OPERATE_STATION utility to SCFS and by SCFS/VE to SCF/VE

 Required Parameters

\+
 - I/O Station Name
 - System File Name or User File Name
\--
\ n.n.n.n Terminate Queued Output Response
 Response to Terminate Queued Output command above.

\+
 Message sent by SCF/VE to SCFS/VE and by SCFS to OPERATE_STATION utility

 Required Parameters

\+
 - I/O Station Name
 - System File Name or User File Name
 - Response Code (Status of file termination)
\--
\ n.n.n.n Operator Message
 Request to send a message to the I/O station
operator. This message is expected to originate in a print file "PM"
entry, upon detection of an error condition, to contain preview data for
file positioning, upon file assignment to a device, upon completion of a
file transfer to a device, or upon control facility change.

\+
 Message sent to OPERATE_STATION utility

 Required parameters

\+
 - I/O Station Name
 - Device Name
 - text
\--
\page
\ n.n Messages between SCFS/VE and OPERATE_NTF utility
\ n.n.n.n Delete User
 Request to relinquish control of the remote system by the specified NTF
operator.

\+
 Message received from OPENTF

 Required parameters

\+
 - Remote System Name
 - Family Name
 - User Name
\--
\ n.n.n.n Delete User Response
 Response message to the Delete User command above.

\+
 Message sent to OPENTF

 Parameters

\+
 - Remote System Name
 - Response Code
\--
\ n.n.n.n Get Remote System Names
 Request the logical names and kinds of remote systems.

\+
Message received from OPERATE_NTF utility

 Optional parameters

\+item
 - Remote System Name
 - Logical Line Number
 - Remote System Kind
\--
\ n.n.n.n Remote System Names Data
 Response to the Get Remote System Names command above.

\+
 Message sent to OPERATE_NTF utility

 Required parameters

\+item
 - Response Code
 - Count of Remote Systems
 - Remote System Name, Type, Kind, Route Back Position and Authority
Level(repeated count times)
\--
\ n.n.n.n Get Remote System Options
 Request for remote system options information.

\+
 Message received from OPERATE_NTF utility

 Required parameter

\+item
 - Remote System Name
\--
\ n.n.n.n Remote System Options Data
 Response to the Get Remote System Options command above.

\+
 Message sent to OPERATE_NTF utility

 Required parameters

\+item
 - Directly Connected Remote System Name
 - Response Code
 - Control Facility
 - Remote System Protocol
 - Authority Level
 - Wait-a-bit
 - Inactivity Timer
 - Positive Acknowledge
 - Default Job Destination
 - Default File Destination
 - Store and Forward Destination
 - Count of Logical Line Numbers
 - Logical Line Number, Line Name and Terminal User Procedure
(repeated count times)
 - Count of Batch Streams
 - Batch Stream Name (repeated count times)
 - Remote System Type
 - Route Back Position
 - Request Permission Retry
 - Local System Name
\--
\ n.n.n.n Send Remote Command
 Request to transmit a command or message to a remote system.

\+
 Message received from OPERATE_NTF utility

 Required parameters

\+item
 - Remote System Name
 - Logical Line Number
 - Command Type (Command, Message, Signon, Signoff, TDP)
 - Command Text
\--
\ n.n.n.n Send Remote Command Response
 Response to the Send Remote Command command above.

\+
 Message sent to OPERATE_NTF utility

 Required parameters

\+item
 - Remote System Name
 - Command Type
 - Response Code
\--
\ n.n.n.n Get Remote System Status
 Request remote system status information.

\+
 Message received from OPERATE_NTF utility

 Required parameter

\+item
 - Remote System Name
\-

Optional parameters

\+
 - Logical Line Number
 - Signon Status
\--
\ n.n.n.n Remote System Status Data
 Response to the Get Remote System Status command above.

\+
 Message sent to OPERATE_NTF utility

 Required parameters

\+item
 - Remote System Name
 - Response Code
 - Count of Lines to the Remote System
 - Logical Line Number, Line Name, Line Speed, and
Signon Status (repeated count times)
\--
\page
\ n.n Messages between SCFS/VE and multiple partners
\ n.n.n.n Transfer SCFS/VE Control
 Switch between different priority copies of SCFS/VE. This message is
issued by a higher priority copy of SCFS/VE to a lower priority copy
of SCFS/VE. The lower priority copy passes control of all I/O stations
or remote systems
associated with the specified control facility title to the higher
priority copy.

\+
 Message sent to all connections

 Required parameters

\+
 - Connection Identifier
 - SCFS/VE Network Address (higher priority SCFS)
\--
\ n.0 SCFS/VE Connection Establishment
 This section describes what information is sent by the client and SCFS/VE
when a connection is being established.

 SCFS/VE expects to receive a 5 or 6 character client identifier when it
receives a SAP event. The identifiers are as follows:

\+
 - SCFDI   (indicating SCF/DI client)
 - SCFVE   (indicating SCF/VE client)
 - SCFSVE  (indicating a different priority SCFS/VE)
 - OPESVE  (indicating the OPERATE_STATION utility)
 - NTFVE   (indicating NTF/VE client)
 - OPENTF  (indicating the OPERATE_NTF utility)
\-

 When SCFS/VE accepts the connection, it sends its control facility name to the
client.
\ n.0 message protocol definitions
 This section provides detailed definitions of the message protocols
to be followed. The protocol is presented by function (e.g. configure
I/O station etc.) rather than by single message specification. This
presentation allows for a functional representation of the SCFS/VE
message flow data.
\ n.n notes
\item,j1,n.
 . A series of periods have been used to denote the passing of time. During
this time any other operations may have been performed, thus all information
related to a specific message must be assumed to be destroyed. Any "state"
information required to be preserved must be saved in the I/O station
or batch device definition tables within SCFS/VE.
\block,j1,i4
\page
\ n.n i/o station and batch device maintenance

\asis
   Action              SCF/DI              SCFS/VE
   ------              ------              -------

  New I/O station        Add I/O Station
  defined and first      ------------------------>
  batch device is
  connected to the DI.

                         Add I/O Station Response
                        <------------------------

                                .
                                .
                                .
  New batch device       Add Batch Device
  defined (one per       ------------------------->
  device)
                         Add Batch Device Response
                         <-------------------------


              Normal operation of station

                                .
                                .
                                .

  Batch device lost      Delete Batch Device
                         ------------------------->
                         Delete Batch Device Response
                         <-------------------------


                                .
                                .
                                .

  Last batch device      Delete I/O Station
  deleted (disconnected  ------------------------->
  from the network)
                         Delete I/O Station Response
                        <---------------------------
\page
\ n.n output file maintain, assign and transfer

\asis
   Action     SCF/DI      SCFS/VE       SCF/VE        OPES
   ------     ------      -------       ------        ----

  Maintain                   File Available
  file in                   <--------------
  queue                       .
                              .
                              .
  Output                    File Assignment
  device ok                 --------------->
                          File Assignment Response
                            <-----------------

                              .
                              .
                              .
                File Status
                -------------->
                (started)
                              Operator Message
                              --------------------->
                        (file acknowledgement if required)
                              .
                              .

                    file transfer underway

                              .
                              .
                File Status
                -------------->
                (percent complete update)
                              .
                              .
  Transfer      File Status
  complete      -------------->
                (complete)
                              Operator Message
                              --------------------->
                        (file acknowledgement if required)
\page
\ n.n input file transfer

\asis
   Action     SCF/DI         SCFS/VE              OPES
   ------     ------         -------              ----

  Input device  File Status
  started       ---------------->
                (active,busy)
                                .
                                .
                                .
  Transfer      File Status
  complete      ---------------->
                (complete)
                              Operator Message
                              --------------------->
                        (file acknowledgement if required)
\page
\ n.n assign i/o station operator

      Action      SCF/DI       SCFS/VE           OPES
      ------      ------       -------           ----

  New operator                        Add User
  request                         <----------------

  Validate user
                                  Add User Response
                                  ----------------->
                    Start I/O Station
                   <---------------

                                  .
                                  .
                                  .
   Operator         Stop I/O Station
   connection      <---------------
   broken
\page
\ n.n start/stop batch device

      Action      SCF/DI       SCFS/VE           OPES
      ------      ------       -------           ----

                                   Stop Batch device
                                  <----------------
                      Stop Batch Device
                    <--------------

                      Stop Batch Device Response
                    -------------->

                                 Stop Batch Device Response
                                     -------------->

                      File Status
                    -------------->
                 (complete or suspended)

                                 .
                                 .
                                 .
  Device now off
                                   Start Batch Device
                                 <----------------
                      Start Batch Device
                    <-------------
  Device now on       Start Batch Device Response
                    -------------->
                                 Start Batch Device Response
                                     -------------->
                    Batch Device Status
                    -------------->
\page
\ n.n position file

\asis
  Action          SCF/DI         SCFS/VE          OPES
  ------          ------         -------          ----

                                     position file
 Command received                   <---------------
 and forwarded      Position File Transfer
                   <-----------------
                   Position File Transfer Response
                   ----------------->
                               Position File Transfer Response
                                     --------------->

                      File Status
                    ---------------->
                      (suspended)
                                     .
                                     .
                                     .
 Optional preview  Operator Message
 data sent         ----------------->
                    (preview data)   Operator Message
                                     --------------->
                                      (preview data)
                                     .
                                     .
                                     .

 Preview complete                     Start Batch Device
                                     <---------------
                    Start Batch Device
                   <------------------
  Device now on       Start Batch Device Response
                    -------------->
                                 Start Batch Device Response
                                       ------------>
                    Batch Device Status
                    -------------->
\page
\ n.n display station status

\asis
 If OPERATE_STATION requests an OPTIMIZED device list
 the protocol is as follows:

 Action                   SCFS/VE                 OPES
 ------                   -------                 ----

 Get list of files            get station status
 in queue (optimized)        <----------------------

 Send information about       device status data
 all batch devices           ---------------------->


 If OPERATE_STATION does not request an optimized device
 list the protocol is as follows:

    Action               SCFS/VE                  OPES
    ------               -------                  ----

 Get information              get station status
 for station                <-----------------------

                              station status data
                            ----------------------->
\page
\ n.n display queue entry

\asis
 If OPERATE_STATION requests an OPTIMIZED queue entry
 list the protocol is as follows:

 Action                   SCFS/VE                 OPES
 ------                   -------                 ----

 Get list of files            get queue entry list
 in queue (optimized)        <----------------------

 Send information about       queue entry data
 all queue files             ---------------------->
                              .
 Send as many messages as     .
 needed.                      .
                              queue entry data
                             ---------------------->


 If OPERATE_STATION does not request an optimized queue entry
 list the protocol is as follows:

 Action                   SCFS/VE                 OPES
 ------                   -------                 ----

 Get list of files            get queue entry list
 in queue                    <----------------------

                              queue entry list data
                             ---------------------->
                              .
                              .
                              .

 Get information for a          get queue entry
 specific entry in the       <----------------------
 queues
                                queue entry data
                             ---------------------->

                              .
                              .

      get queue entry is repeated as required to get all data
\page
\ n.n remote system and batch stream maintenance

\asis
   Action              SCF/DI              SCFS/VE
   ------              ------              -------

  New remote system      Add Remote System
  defined and first      ------------------------>
  batch stream is
  connected to the DI.

                         Add Remote System Response
                        <------------------------

                                .
                                .
                                .
  New batch stream       Add Batch Device
  defined (one per       ------------------------->
  stream)
                         Add Batch Device Response
                         <-------------------------


                        Normal operation

                                .
                                .
                                .

  Batch stream lost      Delete Batch Device
                         ------------------------->
                         Delete Batch Device Response
                         <-------------------------


                                .
                                .
                                .

  Last batch stream      Delete Remote System
  deleted (disconnected  ------------------------->
  from the network)
                         Delete Remote System Response
                        <---------------------------
\page
\ n.n remote system output file assignment and transfer

\asis
   Action     SCF/DI      SCFS/VE       NTF/VE
   ------     ------      -------       ------

  File in
  queue
                             File Available
                            <--------------
                              .
                              .
                              .
  Output                    File Assignment
  stream ok                 --------------->
                          File Assignment Response
                            <-----------------

                              .
                              .
                              .
                File Status
                -------------->
                (started)
                              .
                              .

                    file transfer underway

                              .
                              .
                File Status
                -------------->
                (percent complete update)
                              .
                              .
  Transfer      File Status
  complete      -------------->
                (complete)
\page
\length+4
\ n.n start/stop batch stream

      SCF/DI       SCFS/VE           OPENTF     Operator
      ------       -------           ------     --------

                                        Stop_Batch_Stream
                                       <----------------
                       Stop Batch Device
                      <----------------
          Stop Batch Device
        <--------------

          Stop Batch Device Response
        -------------->

                     Stop Batch Device Response
                     -------------->

                                        Stop_Batch_Stream Response
                                       ---------------->
          File Status
        -------------->
     (complete or suspended)

                     .
                     .
                     .
  Device now off
                                        Start_Batch_Stream
                                       <----------------
                       Start Batch Device
                     <----------------
          Start Batch Device
        <-------------

  Device now on

          Start Batch Device Response
        -------------->
                     Start Batch Device Response
                         -------------->
                                        Start_Batch_Stream Response
                                       ---------------->
        Batch Device Status
         -------------->
\length
\page
\ n.n display remote system status
\block

\asis
    Action               SCFS/VE                  OPENTF
    ------               -------                  -----

 Get information              Get Remote System Status
 for remote system          <-----------------------

                              Remote System Status Data
                            ----------------------->



\ n.n display remote system queue entry

\asis
 Action                   SCFS/VE                 OPENTF
 ------                   -------                 ------

 Get list of NTF              Get Queue Entry List
 files in queue              <----------------------

                              Queue Entry List Data
                             ---------------------->
                              .
                              .
                              .

 Get information for a          Get Queue Entry
 specific entry in the       <----------------------
 queues
                                Queue Entry Data
                             ---------------------->

                              .
                              .

      Get Queue Entry is repeated as required to get all data
\setsec1
\setapp=A-Appendix A
\page1
\title2=Detailed message descriptions
\ n. introduction
\block,j1,i4
 This appendix presents detailed specifications of the message formats
for SCFS/VE. Each message is presented with all parameters and the binary
representation where applicable.
\ n.n Attribute Number/Attribute Value (AN/AV) Message Format
 AN/AV messages are command messages and are sent as Session Layer data
messages.  The required parameters as designated in
Section 2 of this document must be present in the order shown in this
appendix for all AN/AV formatted messages. Optional parameters may or
may not be present and may occur in any order.
 The An/AV messages are formatted according to the following layout. Each
message starts with a message type indicator byte. This is followed by a
variable number of (attribute/name, attribute/value) pairs. The total
message length is not restricted. The (attribute/name, attribute/value)
pairs are formatted as shown.

\asis
byte 1    <-- additional 8 bit bytes (no max. limit) --->
+----------------------------------------------------------------
|       |
| MTI   | attribute number/attribute value string
|       |
+----------------------------------------------------------------
  ^
  |
  +----- Message Type Indicator

Attribute number/attribute value strings have the following format:

+------------------------\------------\ +-------------------------
|  |         | |          |             |  |
|L |attribute|L|length    | attribute   |L |  next
|I | number  |L|field     |  value      |I |  number
|  |         | |          |             |  |
+------------------------\------------\ +-------------------------
\block,j1,i4
 The fields LI and length fields are to be interpreted in the following
manner  If the LI bit is 0 no length byte is included, and the attribute value
field has a length of one byte. If the LI field is 1 the length field is included
and is interpreted as follows.  If LL = 0, the length field is 1 byte and specifies the
attribute value length up to 127 bytes. If the LL field is set to 1, the length field
is the number of bytes that make up the length of the attribute value.  For
messages sent to and received from the DI, the length field will be 2 and
maximum attribute value length will be 65,535 bytes. For messages between
NOS/VE mainframes, the length field can be larger than 2, meaning the attribute
value length can be greater than 65535 bytes.

Examples:
\asis
+-------------------------------------\ +-------------------------
|  |         |L |         |             |  |
|L |attribute|L |length of| attribute   |L |  next
|I | number  |= | value   |  value      |I |  number
|  |         |O | 1..127  |             |  |
+-------------------------------------\ +-------------------------

 EXAMPLE ATTRIBUTE VALUE LESS THAN OR EQUAL TO 127 BYTES

+---------------------------------\+------------\+----------------
|  |         |L | length  |              |           |  |
|L |attribute|L |   of    | length bytes | attribute |L | next
|I | number  |= | length  |              |  value    |I | number
|  |         |1 | bytes*  |              |           |  |
+---------------------------------\+------------\ +---------------

 EXAMPLE ATTRIBUTE VALUE GREATER THAN 127 BYTES


\block,j1,i4
\ n.n.n Notes
\item,j1,N)
 . The message type is one byte.  The identifier parameters may vary
in length but are fixed in length for each message type.
 . Attribute value fields which represent Cybil ordinal type values are
flagged by an asterisk in the allowed value field.  The description of
these field values for reason codes is presented in appendix A4 and the
description of other field values is presented in appendix A5.
 . Some attributes are of type "Dev^Stat^Data".
The attribute is physically 3 one byte
integer fields followed by an ascii string of up to 31 bytes. It may be
considered to be the following Cybil data structure:

\+asis
  TYPE
    device_status_data = record
      device_status: device status, (1 Byte)
      file_xfer_status: file transfer status, (1 Byte)
      type: device_type, (1 Byte)
      name: string ( * <= 31),
    recend;
\-
 . Some attributes are of the type "q status data".
The attribute consists physically of
four 8 byte integer fields followed by
two fixed ascii strings of 31 bytes followed by
an ascii string of up to 31 bytes.
It may be considered to be the following Cybil data structure:

\+asis
  TYPE
    q_status_data = record
      file_count: integer, (8 Bytes)
      total_size: integer,
      oldest_age: integer,
      average_age: integer,
      operator_name: string (31),
      operator_family: string (31),
      name: string ( * <= 31),
    recend;
\-
 . Some attributes are of the type "file priority".
The attribute consists physically of
a 1 integer field followed by an ascii string of up to 31 bytes. It may be
considered to be the following Cybil data structure:

\+asis
  TYPE
    file_and_priority = record
      priority: integer, (8 Bytes)
      name: string ( * <= 31),
    recend;
\-
 . One attribute is of the type "date and time". The attribute consists
physically of a 6 one byte fields followed by a two byte field. It may be
considered to be the following Cybil data structure:

\+asis
  TYPE
    date and time = record
      year: 0 .. 255, (1 Byte)  {year minus 1900. e.g. 85 = 1985}
      month: 1 .. 12 (1 Byte)
      day: 1 .. 31 (1 Byte)
      hour: 0 .. 24 (1 Byte)
      minute: 0 .. 59 (1 Byte)
      second: 0 .. 59 (1 Byte)
      millisecond: 0 .. 999, (2 Bytes)
    recend;
\-
 . One attribute is of type "rmt^sys^data".  The attribute is physically four
one byte fields followed by an ascii string of up to 31 bytes.  It may be
considered to be the following Cybil data structure:

\+asis
  TYPE
    remote_system_data = record
      remote_system_type: remote system type, (1 Byte)
      remote_system_kind: remote system kind, (1 Byte)
      route_back_position: 0..255, (1 Byte)
      authority_level: authority level, (1 Byte)
      name: string ( * <= 31),
    recend;
\-
 . One attribute is of type "rmt^stat^data".  The attribute is physically
a two byte field followed by 2 one byte fields followed by an ascii string
of up to 31 bytes.  It may be considered to be the following Cybil data
structure:

\+asis
  TYPE
    remote_status_data = record
      logical_line_number: 0..999, (2 Bytes)
      line_speed: line speed, (2 Bytes)
      signon_status: device status, (1 Byte)
      name: string ( * <= 31),
    recend;
\-
 . One attribute is of type "log^line^data".  The attribute is
physically a two byte field followed by a fixed ascii string of 31
bytes followed by an ascii string of up to 31 bytes.  It may be
considered to be the following Cybil data structure:
\+asis
  TYPE
    logical_line_data = record
      logical_line_number: 0..999, (2 Bytes)
      tup: string (31),
      name: string ( * <= 31),
    recend;
\-
 . One attribute is of type "ccr^data".  The attribute can range from 2 to 128
bytes.  Each byte pair is interpreted as follows:  The first character must be
in the range 00..1f(16) or 80..9f(16).  This is a control code character which
is to be replaced or deleted.  The second character can equal the first
character in which case the control code is to be deleted.  If the second
character is not equal to the first then the second character is to replace the
control code.
\+asis
  TYPE
    ccr_data: array (2..128) of char;
\-
\block,j1,i4
\page
\ n.0 detailed message formats
\ n.n Messages between SCFS/VE and SCF/DI
\block
\keep33
\ n.n.n.n Add I/O Station

 Message type = 20

\box,1,12,39,47,62
\+table;2,19,40,50
 ;attribute;description;length;allowed
 ;^number;;;^values
\boxline
\+table;6,14,41,49
 ;01;I/O station name;1..31;ascii string
\boxline
 ;02;I/O station alias 1;1..31;ascii string
\boxline
 ;03;I/O station alias 2;1..31;ascii string
\boxline
 ;04;I/O station alias 3;1..31;ascii string
\boxline
 ;05;required operator device;1..31;ascii string
\boxline
 ;06;station usage;1;*0..2
\boxline
 ;07;file acknowledgement;1;0=no, 1=yes
\boxline
 ;08;check  I/O station unique;1;0=no, 1=yes
\boxline
 ;09;auto operator control;1;*0=no, 1=yes
\boxline
 ;10;default job destination;1..31;ascii string
\boxline
 ;11;dest. unavail. action;1;*0..1
\boxline
 ;12;PM message action;1;*0..2
\nobox
\--
\page
\ n.n.n.n Delete I/O Station

 Message type = 21

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;I/O station name;1..31;ascii string
\nobox
\--
\ n.n.n.n Add Batch Device

 Message type = 22

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;device status;1;*0..15
\boxline
 ;04;file transfer status;1;*0..15
\boxline
 ;05;device alias 1;1..31;ascii string
\boxline
 ;06;device alias 2;1..31;ascii string
\boxline
 ;07;device alias 3;1..31;ascii string
\boxline
 ;08;device type;1;*0..10
\boxline
 ;09;tip type;1;*0..15
\boxline
 ;10;terminal model;1..31;ascii string
\boxline
 ;11;file acknowledgement;1;0=no, 1=yes
\boxline
 ;12;transmission block size;2;tip dependant
\boxline
 ;13;maximum file size;4;0..99999999
\boxline
 ;14;page width;1;10..255
\boxline
 ;15;page length;1;0..176
\boxline
 ;16;banner page count;1;0..3
\boxline
 ;17;banner highlight field;1;*0..4
\boxline
 ;18;carriage control action;1;*0..2
\boxline
 ;19;forms code 1;1..6;ascii string
\boxline
 ;20;forms code 2;1..6;ascii string
\boxline
 ;21;forms code 3;1..6;ascii string
\boxline
 ;22;forms code 4;1..6;ascii string
\boxline
 ;23;device ext. chars. 1;1..6;ascii string
\boxline
 ;24;device ext. chars. 2;1..6;ascii string
\boxline
 ;25;device ext. chars. 3;1..6;ascii string
\boxline
 ;26;device ext. chars. 4;1..6;ascii string
\boxline
 ;27;suppress carriage cont.;1;0=off, 1=on
\boxline
 ;28;code set;1;*0..7
\boxline
 ;29;vertical print density;1;*0..3
\boxline
 ;30;VFU Load Procedure;1..31;ascii string
\boxline
 ;31;forms size;1;1..62
\boxline
 ;32;undefined fe action;1;*0..2
\boxline
 ;33;unsupported fe action;1;*0..2
\boxline
 ;34;VFU load option;1;*0..3
\boxline
 ;35;Maximum Page Length;1;0..255
\boxline
 ;36;transparent mode;1;0=off, 1=on
\boxline
 ;37;skip punch count;1;0..9
\boxline
 ;38;logical line number;2;1..999
\boxline
 ;39;Control Code replacement;2..128;ccr_data
\boxline
 ;40;Data Parity;1;*0..4
\boxline
 ;41;Site-defined Code Set;1..31;ascii string
\nobox
\--
\keep17
\ n.n.n.n Batch Device Status

 Message type = 23

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;device status;1;*0..15
\boxline
 ;04;file transfer status;1;*0..15
\nobox
\--
\keep18
\ n.n.n.n File Status

 Message type  = 24

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;device status;1;*0..15
\boxline
 ;04;file transfer status;1;*0..15
\nobox

\keep17
 Optional or Required - depending on device type

\box
 ;05;file position (% done);1;0..100
\boxline
 ;06;system job/file name;1..31;ascii string
\boxline
 ;07;system id (family);1..31;ascii string
\boxline
 ;08;user job/file name;1..31;ascii string
\boxline
 ;09;actual destination;1..31;ascii string
\boxline
 ;10;requested destination;1..31;ascii string
\boxline
 ;11;input bytes transferred;4;integer
\nobox
\--
\keep13
\ n.n.n.n Delete Batch Device

 Message type = 25

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\nobox
\--
\keep19
\ n.n.n.n BTFS/DI Status

 Message type = 26

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;BTFS/DI network address;12;gt_sap
\boxline
 ;02;BTFS/DI status;1;*0..1
\boxline
 ;03;BTFS/DI title;1..255;ascii string
\boxline
 ;04;BTFS/DI advanced features;1;*0..1
\nobox
\--
\keep13
\ n.n.n.n Add I/O Station Response

 Message type = 27

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;I/O station name;1..31;ascii string
\boxline
 ;02;response code;1;*0..3
\nobox
\--
\keep13
\ n.n.n.n Delete I/O Station Response

 Message type = 28

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;I/O station name;1..31;ascii string
\boxline
 ;02;response code;1;*0..1
\nobox
\--
\keep13
\ n.n.n.n Start I/O Station

 Message type = 29

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;I/O station name;1..31;ascii string
\boxline
 ;02;user identity;62;ascii string
\nobox
\--
\keep11
\ n.n.n.n Stop I/O Station

 Message type = 30

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;I/O station name;1..31;ascii string
\nobox
\--
\keep17
\ n.n.n.n Switch Control

 Message type = 31

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;control facility;1..31;ascii string
\nobox
\--
\keep17
\ n.n.n.n Position File (to SCF/DI)

 Message type = 32

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;I/O station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;position parameters *;1..32k;as required
\nobox
 ;*  these parameters are transferred to BTF/VE as received
\--
\keep15
\ n.n.n.n Add Batch Device Response

 Message type = 33

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;response code;1;*0..3
\nobox
\--
\keep15
\ n.n.n.n Delete Batch Device Response

 Message type = 34

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;response code;1;*0..2
\nobox
\--
\keep45
\ n.n.n.n Add Remote System

 Message type = 35

\box,1,12,39,47,62
\+table;2,19,40,50
 ;attribute;description;length;allowed
 ;^number;;;^values
\boxline
\+table;6,14,41,49
 ;01;remote system name;1..31;ascii string
\boxline
 ;02;remote system protocol;1;*0..1
\boxline
 ;03;logical line number;2;1..999
\boxline
 ;04;line speed;2;50..64000
\boxline
 ;05;line name;1..31;ascii string
\boxline
 ;06;authority level;1;*0..2
\boxline
 ;07;terminal user procedure;1..31;ascii string
\boxline
 ;08;wait-a-bit;1;*0..1
\boxline
 ;09;inactivity timer;2;0..600
\boxline
 ;10;positive acknowledge;1;*0..1
\boxline
 ;11;default job destination;1..31;ascii string
\boxline
 ;12;default file destination;1..31;ascii string
\boxline
 ;13;store/forward destination;1..31;ascii string
\boxline
 ;14;remote system type;1;*0..5
\boxline
 ;15;route back position;1;0..255
\boxline
 ;16;request permission retry;1;0=no, 1=yes
\boxline
 ;17;local system name;1..31;ascii string
\nobox
\--
\keep27
\ n.n.n.n Add Accessible Remote System

 Message type = 36

\box,1,12,39,47,62
\+table;2,19,40,50
 ;attribute;description;length;allowed
 ;^number;;;^values
\boxline
\+table;6,14,41,49
 ;01;remote system name;1..31;ascii string
\boxline
 ;02;logical line number;2;1..999
\boxline
 ;03;accessible remote system;1..31;ascii string
 ;;name
\boxline
 ;04;authority level;1;*0..2
\boxline
 ;05;remote system type;1;*0..8
\boxline
 ;06;route back position;1;0..255
\nobox
\--
\keep13
\ n.n.n.n Delete Remote System

 Message type = 37

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;remote system name;1..31;ascii string
\boxline
 ;02;logical line number;2;1..999
\nobox
\--
\keep13
\ n.n.n.n Add Remote System Response

 Message type = 38

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;remote system name;1..31;ascii string
\boxline
 ;02;logical line number;2;1..999
\boxline
 ;03;response code;1;*0..4
\nobox
\--
\keep15
\ n.n.n.n Add Accessible Remote System Response

 Message type = 09

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;directly connected system;1..31;ascii string
\boxline
 ;02;logical line number;2;1..999
\boxline
 ;03;accessible remote system;1..31;ascii string
\boxline
 ;04;response code;1;*0..4
\nobox
\--
\keep13
\ n.n.n.n Delete Remote System Response

 Message type = 39

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;remote system name;1..31;ascii string
\boxline
 ;02;logical line number;2;1..999
\boxline
 ;03;response code;1;*0..1
\nobox
\--
\page
\block,j1,i4
\ n.n Messages between SCFS/VE and SCF/VE or SCFS/VE and NTF/VE
 The File Availability message format is used for Add File Availability
(message type 01), Modify File Availability (02), and Delete File Availability
(03). For all the messages the first 10 parameters are required. The rest of the
parameters are required for Add File Availability, optional for Modify File
availability, and not used for Delete File Availability (except "file held by
filter" - which is optional on Delete File Availability).

\keep25
\ n.n.n.n File Availability Messages

 Message types = 01, 02, 03

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;operator name (private);1..31;ascii string
\boxline
 ;03;operator family (private);1..31;ascii string
\boxline
 ;04;station usage;1;*0..2
\boxline
 ;05;system file name;1..31;ascii string
\boxline
 ;06;system job name;1..31;ascii string
\boxline
 ;07;user file name;1..31;ascii string
\boxline
 ;08;user job name;1..31;ascii string
\boxline
 ;09;user name (private);1..31;ascii string
\boxline
 ;10;user family (private);1..31;ascii string
\nobox

\keep21
 required for ADD, optional for MODIFY only when changed

\box
 ;11;copies;8;integer
\boxline
 ;12;device name;1..31;ascii string
\boxline
 ;13;device type;1;*0..10
\boxline
 ;14;ext. device chars.;1..6;ascii string
\boxline
 ;15;file size;4;0..99999999
\boxline
 ;16;forms code;1..6;ascii string
\boxline
 ;17;output data mode;1;*0..1
\boxline
 ;18;output initial priority;8;integer
\boxline
 ;19;output maximum priority;8;integer
\boxline
 ;20;output priority factor;8;integer
\boxline
 ;21;output state;1;*0..4
\boxline
 ;22;page format;1;*0..2
\boxline
 ;23;page length;1;0..176
\boxline
 ;24;page width;1;10..255
\boxline
 ;25;vertical print density;1;*0..7
\boxline
 ;26;VFU Load Procedure;1..31;ascii string
\boxline
 ;27;file requeued;1;0=no, 1=yes
\nobox

 optional for DELETE - sent only by SCF/VE

\box
 ;28;file held by filter;1;0=no, 1=yes
\nobox
\--
\page
\ n.n.n.n File Assignment

 Message type = 04

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;system file name;1..31;ascii string
\boxline
 ;03;device name;1..31;ascii string
\boxline
 ;04;BTFS/DI network address;12;generic_sap
\boxline
 ;05;requested destination;1..31;ascii string
\boxline
 ;06;requested device;1..31;ascii string
\boxline
 ;07;user name;1..31;ascii string
\boxline
 ;08;user family;1..31;ascii string
\boxline
 ;09;station usage;1;*0..2
\boxline
 ;10;copies;8;integer
\boxline
 ;11;ext. device char.;1..6;ascii string
\boxline
 ;12;forms code;1..6;ascii string
\boxline
 ;13;output initial priority;8;integer
\boxline
 ;14;VFU load procedure;1..31;ascii string
\boxline
 ;15;vertical print density;1;*0..7
\boxline
 ;16;remote system protocol;1;*0..1
\boxline
 ;17;device type;1;*0..10
\boxline
 ;18;remote system type;1;*0..8
\boxline
 ;19;route back position;1;0..255
\nobox
\page
\box
 ;20;BTFS/DI title;1..255;ascii string
\boxline
 ;21;banner highlight field;1;*0..4
\boxline
 ;22;banner page count;1;0..3
\boxline
 ;23;carriage control support;1;*0..2
\boxline
 ;24;code set;1;*0..7
\boxline
 ;25;device alias 1;1..31;ascii string
\boxline
 ;26;device alias 2;1..31;ascii string
\boxline
 ;27;device alias 3;1..31;ascii string
\boxline
 ;28;ext. characteristics 1;1..6;ascii string
\boxline
 ;29;ext. characteristics 2;1..6;ascii string
\boxline
 ;30;ext. characteristics 3;1..6;ascii string
\boxline
 ;31;ext. characteristics 4;1..6;ascii string
\boxline
 ;32;file acknowledgement;1;0=no, 1=yes
\boxline
 ;33;forms code 1;1..6;ascii string
\boxline
 ;34;forms code 2;1..6;ascii string
\boxline
 ;35;forms code 3;1..6;ascii string
\boxline
 ;36;forms code 4;1..6;ascii string
\boxline
 ;37;forms size;1;1..62
\boxline
 ;38;maximum file size;4;0..FFFFFFFF
\boxline
 ;39;page width;1;10..255
\boxline
 ;40;terminal model;1..31;ascii string
\boxline
 ;41;tip type;1;*0..15
\boxline
 ;42;transmission block size;2;tip dependant
\boxline
 ;43;undefined fe action;1;*0..2
\boxline
 ;44;unsupported fe action;1;0..2
\boxline
 ;45;vertical print density;1;*0..3
\boxline
 ;46;vfu load option;1;*0..3
\boxline
 ;47;vfu load procedure;1..31;ascii string
\nobox
\--
\keep19
\ n.n.n.n File Assignment Response

 Message type = 05

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;system file name;1..31;ascii string
\boxline
 ;03;device name;1..31;ascii string
\boxline
 ;04;response code;1;*0..2
\nobox
\--
\keep15
\ n.n.n.n Delete Destination

 Message type = 06

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;Destination name;1..31;ascii string
\boxline
 ;02;Control Facility name;1..31;ascii string
\nobox
\--
\keep13
\ n.n.n.n BTF/VE Status

 Message type = 07

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;BTF/VE protocol stacks;1;*0..3
\nobox
\--
\page
\ n.n Messages between SCFS/VE and Operator Utilities
 This section describes common messages between SCFS/VE and the
OPERATE_STATION utility or between SCFS/VE and the OPERATE_NTF utility.
\keep27
\ n.n.n.n Add User

 Message type = 60

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;control device name;1..31;ascii string
\boxline
 ;03;family name;1..31;ascii string
\boxline
 ;04;user name;1..31;ascii string
\boxline
 ;05;station usage;1;*0..2
\boxline
 ;06;accept messages;1;*0..1
\nobox
\--
\keep13
\ n.n.n.n Add User Response

 Message type = 61

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;response code;1;*0..3
\nobox
\--
\keep15
\ n.n.n.n Select File

 Message type = 62

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;system/user file name;1..31;ascii string
\boxline
 ;03;device name;1..31;ascii string
\nobox
\--
\keep17
\ n.n.n.n Select File Response

 Message type = 63

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;system/user file name;1..31;ascii string
\boxline
 ;03;response code;1;*0..6
\boxline
 ;04;device name;1..31;ascii string
\nobox
\--
\keep14
\ n.n.n.n Get Device Status

 Message type = 67

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\nobox
\--
\ n.n.n.n Device Status Data

 Message type = 68

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;00;null (separator);0
\boxline
 ;01;station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;response code;1;*0..3
\boxline
 ;04;device status;1;*0..15
\boxline
 ;05;device type;1;*0..10
\boxline
 ;06;file transfer status;1;*0..15
\boxline
 ;07;terminal model;1..31;ascii string
\boxline
 ;08;file acknowledge;1;boolean
\boxline
 ;09;maximum file size;4;0..99999999
\boxline
 ;10;page width;1;10..255
\boxline
 ;11;page length;1;0..176
\boxline
 ;12;banner page count;1;0..3
\boxline
 ;13;banner highlight field;1;*0..4
\boxline
 ;14;transmission block size;2;tip dependant
\boxline
 ;15;carriage control action;1;*0..2
\boxline
 ;16;forms code 1;1..6;ascii string
\boxline
 ;17;forms code 2;1..6;ascii string
\boxline
 ;18;forms code 3;1..6;ascii string
\boxline
 ;19;forms code 4;1..6;ascii string
\boxline
 ;20;ext. characteristics 1;1..6;ascii string
\boxline
 ;21;ext. characteristics 2;1..6;ascii string
\boxline
 ;22;ext. characteristics 3;1..6;ascii string
\boxline
 ;23;ext. characteristics 4;1..6;ascii string
\boxline
 ;24;suppress carriage cont.;1;0=off, 1=on
\boxline
 ;25;device alias 1;1..31;ascii string
\boxline
 ;26;device alias 2;1..31;ascii string
\boxline
 ;27;device alias 3;1..31;ascii string
\boxline
 ;28;last unsolicited message;0..255;ascii string
\boxline
 ;29;system file name;1..31;ascii string
\boxline
 ;30;user file name;1..31;ascii string
\boxline
 ;31;system job name;1..31;ascii string
\boxline
 ;32;user job name;1..31;ascii string
\boxline
 ;33;user name;1..31;ascii string
\boxline
 ;34;family name;1..31;ascii string
\boxline
 ;35;percent complete;1;0..100
\boxline
 ;36;code set;1;*0..7
\boxline
 ;37;vertical print density;1;*0..3
\boxline
 ;38;VFU Load Procedure;1..31;ascii string
\boxline
 ;39;forms size;1;1..62
\boxline
 ;40;undefined fe action;1;*0..2
\boxline
 ;41;unsupported fe action;1;*0..2
\boxline
 ;42;VFU load option;1;*0..3
\boxline
 ;43;destination name;1..31;ascii string
\boxline
 ;44;input bytes transferred;4;integer
\boxline
 ;45;logical line number;2;1..999
\boxline
 ;46;transparent mode;1;0=off, 1=on
\boxline
 ;47;skip punch count;1;0..9
\boxline
 ;48;Control Code replacement;2..128;ccr_data
\boxline
 ;49;Data Parity;1;*0..4
\boxline
 ;50;Site-defined Code Set;1..31;ascii string
\nobox
\--
\keep13
\ n.n.n.n Get Queue Status

 Message type = 69

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\nobox
\--
\keep27
\ n.n.n.n Queue Status Data

 Message type = 70

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+table;6,14,40,49
 ;01;station name;1..31;ascii string
\boxline
 ;02;no of files;8;integer
\boxline
 ;03;response code;1;*0..3
\boxline
 ;04;count of ext. chars.;8;integer
\boxline
 ;05;ext chars & status;95..100;q status data
\boxline
 ;06;count of forms codes;8;integer
\boxline
 ;07;forms code & status;95..100;q status data
\boxline
 ;08;count of devices;8;integer
\boxline
 ;09;device name & status;95..125;q status data
\boxline
 ;10;count of destinations;8;integer
\boxline
 ;11;destinations & status;95..125;q status data
\boxline
 ;12;count of device types;8;integer
\boxline
 ;13;device type & status;95..125;q status data
\nobox
\--
\keep15
\ n.n.n.n Get Queue Entry List

 Message type = 71

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+table;6,14,41,49
 ;01;station name;1..31;ascii string
\boxline
 ;02;all or top 10;1;*0..1
\boxline
 ;03;optimize queue list;1;*0..1
\nobox
\--
\keep17
\ n.n.n.n Queue Entry List Data

 Message type = 72

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;response code;1;*0..3
\boxline
 ;03;count of files;8;integer
\boxline
 ;04;system file name & prty;9..39;file priority
\nobox
\--
\keep13
\ n.n.n.n Get Queue Entry

 Message type = 73

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;system/user file name;1..31;ascii string
\nobox
\--
\ n.n.n.n Queue Entry Data

 Message type = 74

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;00;null (separator);0
\boxline
 ;01;station name;1..31;ascii string
\boxline
 ;02;system file name;1..31;ascii string
\boxline
 ;03;response code;1;*0..3
\boxline
 ;04;user file name;1..31;ascii string
\boxline
 ;05;time enqueued;8;date and time
\boxline
 ;06;position in queue;8;integer
\boxline
 ;07;priority;8;integer
\boxline
 ;08;copies;8;integer
\boxline
 ;09;creating job family name;1..31;ascii string
\boxline
 ;10;creating system job name;1..31;ascii string
\boxline
 ;11;creating user job name;1..31;ascii string
\boxline
 ;12;destination name;1..31;ascii string
\boxline
 ;13;device type;1;*0..10
\boxline
 ;14;file length;4;0..99999999
\boxline
 ;15;output data mode;1;*0..1
\boxline
 ;16;device name;1..31;ascii string
\boxline
 ;17;ext. characteristics;1..6;ascii string
\boxline
 ;18;forms code;1..6;ascii string
\boxline
 ;19;page format;1;*0..2
\nobox
\page
\box
 ;20;page length;1;0..176
\boxline
 ;21;page width;1;10..255
\boxline
 ;22;vertical print density;1;*0..7
\boxline
 ;23;VFU load procedure;1..31;ascii string
\boxline
 ;24;creating user name;1..31;ascii string
\boxline
 ;25;file transfer state;1;*0..3
\boxline
 ;26;Q entry data continues;0
\nobox
\--
\page
\ n.n Messages between SCFS/VE and the OPERATE_STATION utility
\keep27
\ n.n.n.n Position File

 Message type = 64

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;I/O station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;location integer;2;0..65535
\boxline
 ;04;location string 1;0..255;ascii string
\boxline
 ;05;location string 2;0..255;ascii string
\boxline
 ;06;units;1;*0..1
\boxline
 ;07;direction;1;*0..1
\boxline
 ;08;starting position;1;*0..2
\boxline
 ;09;preview line count;8;integer
\nobox
\--
\keep15
\ n.n.n.n Terminate Queued Output

 Message type = 75

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;I/O station name;1..31;ascii string
\boxline
 ;02;system/user file name;1..31;ascii string
\nobox
\--
\keep17
\ n.n.n.n Terminate Queued Output Response

 Message type = 76

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;I/O station name;1..31;ascii string
\boxline
 ;02;system/user file name;1..31;ascii string
\boxline
 ;03;response code;1;*0..5
\nobox
\--
\keep11
\ n.n.n.n Get Station Status

 Message type = 65

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;I/O station name;1..31;ascii string
\boxline
 ;02;optimize device list;1;*0..1
\nobox
\--
\keep39
\ n.n.n.n Station Status Data

 Message type = 66

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;I/O station name;1..31;ascii string
\boxline
 ;02;response code;1;*0..3
\boxline
 ;03;control facility name;1..31;ascii string
\boxline
 ;04;no. of files queued;8;integer
\boxline
 ;05;station usage;1;*0..2
\boxline
 ;06;file acknowledgement;1;0=no, 1=yes
\boxline
 ;07;count of devices;8;integer
\boxline
 ;08;device status data;4..34;dev stat data
\boxline
 ;09;required console device;1..31;ascii string
\boxline
 ;10;I/O station alias 1;1..31;ascii string
\boxline
 ;11;I/O station alias 2;1..31;ascii string
\boxline
 ;12;I/O station alias 3;1..31;ascii string
\boxline
 ;13;default job destination;1..31;ascii string
\boxline
 ;14;dest. unavail. action;1;*0..1
\boxline
 ;15;PM message action;1;*0..2
\nobox
\--
\page
\ n.n Messages between SCFS/VE and OPERATE_NTF utility
\ n.n.n.n Get Remote System Names

 Message type = 10

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;remote system name;1..31;ascii string
\boxline
 ;02;logical line number;2;1..999
\boxline
 ;03;set of remote system kind;1;set of *0..2
\nobox
\--
\keep15
\ n.n.n.n Remote System Names Data

 Message type = 11

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;response code;1;*0..3
\boxline
 ;02;count of remote systems;8;integer
\boxline
 ;03;remote system name & info;5..35;rmt sys data
\nobox
\--
\keep11
\ n.n.n.n Get Remote System Options

 Message type = 12

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;remote system name;1..31;ascii string
\nobox
\--
\keep48
\ n.n.n.n Remote System Options Data

 Message type = 13

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;remote system name;1..31;ascii string
\boxline
 ;02;response code;1;*0..3
\boxline
 ;03;control facility name;1..31;ascii string
\boxline
 ;04;remote system protocol;1;*0..1
\boxline
 ;05;authority level;1;*0..2
\boxline
 ;06;wait-a-bit;1;*0..1
\boxline
 ;07;inactivity timer;2;0..600
\boxline
 ;08;positive acknowledge;1;*0..1
\boxline
 ;09;default job destination;1..31;ascii string
\boxline
 ;10;default file destination;1..31;ascii string
\boxline
 ;11;store/forward destination;1..31;ascii string
\boxline
 ;12;count of logical lines;8;integer
\boxline
 ;13;logical line data;34..64;log line data
\boxline
 ;14;count of batch streams;8;integer
\boxline
 ;15;stream name;1..31;ascii string
\boxline
 ;16;remote system type;1;*0..5
\boxline
 ;17;route back position;1;0..255
\boxline
 ;18;request permission retry;1;0=no, 1=yes
\boxline
 ;19;local system name;1..31;ascii string
\nobox
\--
\keep16
\ n.n.n.n Delete User

 Message type = 14

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;remote system name;1..31;ascii string
\boxline
 ;03;family name;1..31;ascii string
\boxline
 ;04;user name;1..31;ascii string
\nobox
\--
\keep13
\ n.n.n.n Delete User Response

 Message type = 15

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;remote system name;1..31;ascii string
\boxline
 ;02;response code;1;*0..2
\nobox
\--
\keep15
\ n.n.n.n Get Remote System Status

 Message type = 18

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;remote system name;1..31;ascii string
\boxline
 ;02;logical line number;2;1..999
\boxline
 ;03;signon stat (dev stat);1;*7..11
\nobox
\--
\keep18
\ n.n.n.n Remote System Status Data

 Message type = 19

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;remote system name;1..31;ascii string
\boxline
 ;02;response code;1;*0..3
\boxline
 ;03;count of lines;8;integer
\boxline
 ;04;remote system status;6..36;rmt stat data
\nobox
\--
\page
\ n.n messages between SCFS/VE and multiple partners
\keep6
\ n.n.n.n Switch Control Facility

 Message type = 80

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;Connection Identifier;1..31;ascii string
\boxline
 ;02;SCFS/VE network address;12;generic sap
\nobox
\--
\page
\block,j1,i4
\ n.n Common messages between SCFS/VE, SCF/DI, and OPES
  This section describes common messages between SCFS/VE and SCF/DI and between
SCF/VE and the OPERATE_STATION utility (OPES).
\keep15
\ n.n.n.n Suppress Carriage Control Response

 Message type = 40

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;I/O station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;response code;1;*0..13
\nobox
\--
\keep16
\ n.n.n.n Operator Message

 Message type = 51

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;I/O station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;text;1..32k;ascii string
\nobox
\--
\keep15
\ n.n.n.n Suppress Carriage Control

 Message type = 43

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;I/O station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;suppress format control;1;0=off, 1=on
\nobox
\--
\keep17
\ n.n.n.n Position File Transfer Response

 Message type = 50

\box
\+
 ;attribute;description;length;allowed
 ;^name;;;^value
\boxline
\+
 ;01;I/O station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;response code;1;*0..13
\nobox
\--
\page
\block,j1,i4
\ n.n Common messages between SCFS/VE, SCF/DI, and OPES or OPENTF
  This section describes common messages between SCFS/VE and SCF/DI and between
SCFS/VE and the OPERATE_STATION utility (OPES) or between SCFS/VE and the
OPERATE_NTF utility (OPENTF).
\keep19
\ n.n.n.n Change Batch Device Attributes Response

 Message type = 46

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;response code;1;*0..13
\nobox


 optional - included only when changed

\box
 ;04;device alias 1;0..31;ascii string
\boxline
 ;05;device alias 2;0..31;ascii string
\boxline
 ;06;device alias 3;0..31;ascii string
\boxline
 ;07;file acknowledge;1;boolean
\boxline
 ;08;terminal model;1..31;ascii string
\boxline
 ;09;transmission block size;2;tip dependant
\boxline
 ;10;maximum file size;4;0..99999999
\boxline
 ;11;page width;1;10..255
\boxline
 ;12;page length;1;0..176
\boxline
 ;13;banner page count;1;0..3
\boxline
 ;14;banner highlight field;1;*0..4
\boxline
 ;15;carriage control action;1;*0..2
\boxline
 ;16;forms code 1;0..6;ascii string
\boxline
 ;17;forms code 2;0..6;ascii string
\boxline
 ;18;forms code 3;0..6;ascii string
\boxline
 ;19;forms code 4;0..6;ascii string
\boxline
 ;20;external device char. 1;0..6;ascii string
\boxline
 ;21;external device char. 2;0..6;ascii string
\boxline
 ;22;external device char. 3;0..6;ascii string
\boxline
 ;23;external device char. 4;0..6;ascii string
\boxline
 ;24;code set;1;*0..7
\boxline
 ;25;vertical print density;1;*0..3
\boxline
 ;26;VFU Load Procedure;1..31;ascii string
\boxline
 ;27;forms size;1;1..62
\boxline
 ;28;undefined fe action;1;*0..2
\boxline
 ;29;unsupported fe action;1;*0..2
\boxline
 ;30;invalid attribute;1;*0..30
\boxline
 ;31;skip punch count;1;0..9
\boxline
 ;32;Control Code replacement;2..128;ccr_data
\boxline
 ;33;Data Parity;1;*0..4
\boxline
 ;34;Site-defined Code Set;1..31;ascii string
\nobox
\--
\keep13
\ n.n.n.n Start Batch Device

 Message type = 41

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\nobox
\--
\keep13
\ n.n.n.n Stop Batch Device

 Message type = 42

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;file disposition;1;*0..4
\nobox
\--
\keep16
\ n.n.n.n Terminate Transfer

 Message type = 44

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;file disposition;1;*0..2
\nobox
\--
\keep15
\ n.n.n.n Change Batch Device Attributes

 Message type = 45

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\nobox

 optional - included only when changed

\box
 ;03;device alias 1;0..31;ascii string
\boxline
 ;04;device alias 2;0..31;ascii string
\boxline
 ;05;device alias 3;0..31;ascii string
\boxline
 ;06;file acknowledge;1;boolean
\boxline
 ;07;terminal model;1..31;ascii string
\boxline
 ;08;transmission block size;2;tip dependant
\boxline
 ;09;maximum file size;4;0..99999999
\boxline
 ;10;page width;1;10..255
\boxline
 ;11;page length;1;0..176
\boxline
 ;12;banner page count;1;0..3
\boxline
 ;13;banner highlight field;1;*0..4
\boxline
 ;14;carriage control action;1;*0..2
\boxline
 ;15;forms code 1;0..6;ascii string
\boxline
 ;16;forms code 2;0..6;ascii string
\boxline
 ;17;forms code 3;0..6;ascii string
\nobox
\page
\box
 ;18;forms code 4;0..6;ascii string
\boxline
 ;19;external device char. 1;0..6;ascii string
\boxline
 ;20;external device char. 2;0..6;ascii string
\boxline
 ;21;external device char. 3;0..6;ascii string
\boxline
 ;22;external device char. 4;0..6;ascii string
\boxline
 ;23;code set;1;*0..7
\boxline
 ;24;vertical print density;1;*0..3
\boxline
 ;25;VFU Load Procedure;1..31;ascii string
\boxline
 ;26;forms size;1;1..62
\boxline
 ;27;undefined fe action;1;*0..2
\boxline
 ;28;unsupported fe action;1;*0..2
\boxline
 ;29;skip punch count;1;0..9
\boxline
 ;30;Control Code replacement;2..128;ccr_data
\boxline
 ;31;Data Parity;1;*0..4
\boxline
 ;32;Site-defined Code Set;1..31;ascii string
\nobox
\--
\keep17
\ n.n.n.n Start Batch Device Response

 Message type = 47

\box
\+
 ;attribute;description;length;allowed
 ;^name;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;response code;1;*0..13
\nobox
\--
\keep17
\ n.n.n.n Stop Batch Device Response

 Message type = 48

\box
\+
 ;attribute;description;length;allowed
 ;^name;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;response code;1;*0..13
\nobox
\--
\keep17
\ n.n.n.n Terminate Transfer Response

 Message type = 49

\box
\+
 ;attribute;description;length;allowed
 ;^name;;;^value
\boxline
\+
 ;01;station name;1..31;ascii string
\boxline
 ;02;device name;1..31;ascii string
\boxline
 ;03;response code;1;*0..13
\nobox
\--
\page
\block,j1,i4
\ n.n Common messages between SCFS/VE, SCF/DI, and OPENTF
  This section describes common messages between SCFS/VE and SCF/DI and between
SCFS/VE and the OPERATE_NTF utility (OPENTF).
\keep17
\ n.n.n.n Send Remote Command

 Message type = 16

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;remote system name;1..31;ascii string
\boxline
 ;02;stream name;1..31;ascii string
\boxline
 ;03;logical line number;2;1..999
\boxline
 ;04;command type;1;*0..6
\boxline
 ;05;command text;1..255;ascii string
\nobox
\--
\keep15
\ n.n.n.n Send Remote Command Response

 Message type = 17

\box
\+
 ;attribute;description;length;allowed
 ;^number;;;^value
\boxline
\+
 ;01;remote system name;1..31;ascii string
\boxline
 ;02;stream name;1..31;ascii string
\boxline
 ;03;command type;1;*0..6
\boxline
 ;04;device status;1;*0..15
\boxline
 ;05;response code;1;*0..3
\nobox
\--
\page
\block,j1,i4
\ n.0 Position File Parameter Format
 This section describes the format of the parameters for the Position File
message sent to SCF/DI to be eventually passed on to BTF/VE. These
parameters will form a data block that SCF/DI will pass on to BTF/VE. The
format of the data will be the A-A 56 parameter.

 The block passed to SCF/DI is defined as:
\asis
  <CCC AA......AA>

  This is all character data where:

      CCC = 001
      AAA =
          Location Count    = <01 LLL II..II> where:
              LLL           = length of II..II
              II..II        = count

          Location String 1 = <02 LLL SS..SS> where:
              LLL           = length of SS..SS
              SS..SS        = location string

          Location String 2 = <03 LLL SS..SS> where:
              LLL           = length of SS..SS
              SS..SS        = location string

          Units             = <04 LLL X> where:
              LLL           = 001
              X             = L (for lines)
                              P (for pages)

          Direction         = <05 LLL X> where:
              LLL           = 001
              X             = F (for forward)
                              B (for backward)
\page
\asis
          Start position    = <06 LLL X> where:
              LLL           = 001
              X             = E (for end of file)
                              B (for beginning of file)
                              L (for current line)

          Preview           = <07 LLL X> where:
              LLL           = 001
              X             = 0 .. 9
\block,j1,i4
\ n.0 Response codes
 This section details response codes for all response messages.
\ n.n.n.n Add I/O Station Response Codes
\+flowtab;10,17
 ;~Value~;~Meaning~

 ;0;message accepted
 ;1;duplicate definition with Check IOS Unique set to true
 ;2;duplicate definitions do not match
 ;3;duplicate alias names specified in message
 ;4;duplicate station name within domain
\-
\ n.n.n.n Delete I/O Station Response Codes
\+
 ;~Value~;~Meaning~

 ;0;message accepted
 ;1;no io station found with specified name
\-
\ n.n.n.n Add Remote System Response Codes
\+flowtab;10,17
 ;~Value~;~Meaning~

 ;0;message accepted
 ;1;duplicate definitions do not match
 ;2;duplicate logical line number
 ;3;duplicate remote system name within domain
 ;4;remote system name not found in NTF System List
\-
\ n.n.n.n Add Accessible Remote System Response Codes
\+
 ;~Value~;~Meaning~

 ;0;message accepted
 ;1;no remote system found with specified name
 ;2;no remote system found with specified logical line number
 ;3;duplicate definitions do not match
 ;4;remote system name not found in NTF System List
\-
\ n.n.n.n Delete Remote System Response Codes
\+
 ;~Value~;~Meaning~

 ;0;message accepted
 ;1;no remote system found with specified name
\-
\ n.n.n.n Add Batch Device Response Codes
\+
 ;~Value~;~Meaning~

 ;0;message accepted
 ;1;no io station or remote system found with specified name
 ;2;duplicate batch device or batch stream name
 ;3;duplicate alias names specified in message
\-
\ n.n.n.n Delete Batch Device Response Codes
\+
 ;~Value~;~Meaning~

 ;0;message accepted
 ;1;no io station or remote system found with specified name
 ;2;no batch device or batch stream found with specified name
\-
\keep9
\ n.n.n.n Add User Response Codes
\+
 ;~Value~;~Meaning~

 ;0;message accepted
 ;1;no io station or remote system found with specified name
 ;2;operator already assigned to station or remote system
 ;3;operator device does not match required operating device
\-
\ n.n.n.n Send Remote Command Response Codes
\+
 ;~Value~;~Meaning~

 ;0;message accepted
 ;1;incorrect signon status for remote system
 ;2;no remote system found with specified name
 ;3;no batch stream found with specified name
\-
\block,j1,i4
\ n.n.n.n Device Control Response Codes
  Response codes for the Start Batch Device Response, Stop Batch Device
Response, Terminate Transfer Response, Suppress Carriage Control Response,
Position File Transfer Response and Change Batch Device Attributes Response
messages.

\+flowtab;10,17
 ;~Value~;~Meaning~

 ;0;command accepted
 ;1;command rejected, BTFS/DI down
 ;2;command rejected, unknown I/O station or remote system
 ;3;command rejected, unknown device or batch stream
 ;4;command rejected, wrong device or stream type
 ;5;command rejected, wrong data mode
 ;6;message rejected, device cannot support the specified VFU
 ;7;message rejected, VFU load request outstanding
 ;8;message rejected, VFU load procedure could not be found
 ;9;message rejected, syntax error in VFU load procedure
 ;10;message rejected, VFU not changeable by the operator
 ;11;message rejected, terminal model is undefined
 ;12;message rejected, device busy, new VFU is not allowed
 ;13;message rejected, insufficient memory in DI for request
 ;14;message rejected, TIP rejected attribute
 ;15;message rejected, code set load procedure not found
\-
\block,j1,i4
\ n.n.n.n File Assignment Response Codes

\+flowtab;10,17
 ;~Value~;~Meaning~

 ;0;command accepted
 ;1;command rejected
 ;2;command rejected, cannot translate BTFS/DI title
\-
\block,j1,i4
\ n.n.n.n Select File Response Codes

\+flowtab;10,17
 ;~Value~;~Meaning~

 ;0;command accepted
 ;1;command rejected, unknown I/O station or remote system
 ;2;command rejected, unknown device or batch stream
 ;3;command rejected, unknown file
 ;4;command rejected, file already assigned
 ;5;command rejected, wrong device or stream type
 ;6;command rejected, file name not unique
\-
\block,j1,i4
\ n.n.n.n Display Status Response Codes

\+flowtab;10,17
 ;~Value~;~Meaning~

 ;0;command accepted
 ;1;command rejected, unknown I/O station or remote system
 ;2;command rejected, unknown device or batch stream
 ;3;command rejected, unknown file
\-
\block,j1,i4

 These response codes are used for the following messages:  Station
Status Data, Device Status Data, Queue Status Data, Queue Entry List
Data, Queue Entry Data, Remote System Names Data, Remote System Options
Data and Remote System Status Data.
\ n.n.n.n Delete User Response Codes
\+
 ;~Value~;~Meaning~

 ;0;message accepted
 ;1;no remote system found with specified name
 ;2;operator not assigned to remote system
\-
\ n. assorted field codes
 This section details codes for all coded fields in attribute value
descriptors.
\ n.n.n.n Accept Messages
\+
 ;~Value~;~Meaning~

 ;0;Do accept unsolicited messages
 ;1;Do not accept unsolicited messages
\-
\ n.n.n.n Action Required Codes
\+flowtab;10,17
 ;~Value~;~Meaning~

 ;0;add entry
 ;1;modify entry
 ;2;delete entry
\-
\ n.n.n.n BTF/VE Protocol Stacks
\+
 ;~Value~;~Meaning~

 ;1;XNS Protocol Stack
 ;2;OSI Protocol Stack
 ;3;XNS and OSI Protocol Stacks
 ;4-255;Reserved
\-
 NOTE: These values are derived from bit positions, they do not
represent an ordinal list.

\ n.n.n.n BTFS/DI Advanced Features
\+
 ;~Value~;~Meaning~

 ;0;No advanced features
 ;1;Transparent mode allowed for TIP type of URI.
 ;2-255;Reserved
\-
\ n.n.n.n BTFS/DI Status Codes
\+
 ;~Value~;~Meaning~

 ;0;BTFS/DI down
 ;1;BTFS/DI active
\-
\ n.n.n.n Carriage Control Action Codes
\+
 ;~Value~;~Meaning~

 ;0;pre print
 ;1;post print
 ;2;pre and post print
\-
\ n.n.n.n Connection Type Codes
\+
 ;~Value~;~Meaning~

 ;0;Cyber 180 connection
 ;1;Cyber 170 connection
\-
\ n.n.n.n Device Status Codes
\+
 ;~Value~;~Meaning~

 ;0;Active
 ;1;Stopped (disabled)
 ;2;Not ready
 ;3;Down
 ;4;VFU procedure being loaded
 ;5;VFU procedure not loadable
 ;6;Stopped by system
 ;7-10;Reserved
 ;11;Waiting for signon (NTF only)
 ;12;Signon initiated (NTF only)
 ;13;Signed on (NTF only)
 ;14;Signon failed (NTF only)
 ;15;Signed off (NTF only)
\-
\ n.n.n.n Device Type Codes
\+
 ;~Value~;~Meaning~

 ;0;Null Device
 ;1;Console
 ;2;Reader
 ;3;Printer
 ;4;Punch
 ;5;Plotter
 ;6;Remote System Input
 ;7;Job Receiver
 ;8;Sysout Receiver
 ;9;Job Transmitter
 ;10;Sysout Transmitter
\-
\ n.n.n.n File Disposition Codes
\block,j1,i4
 These disposition codes are for the Stop Batch Device, Stop Device, and
Terminate Transfer messages. The Terminate Transfer messages will use only
the first 3 codes.

\+

 ;~Value~;~Meaning~

 ;0;Requeue
 ;1;Drop
 ;2;Hold
 ;3;Finish
 ;4;Suspend
\-
\ n.n.n.n File Transfer State Codes
\+
 ;~Value~;~Meaning~

 ;0;File is eligible to transfer
 ;1;File is on hold
 ;2;File is not eligible to transfer
 ;3;File is selected to transfer
\-
\ n.n.n.n File Transfer Status Codes
\+
 ;~Value~;~Meaning~

 ;0;Idle (file transfer complete)
 ;1;Idle, device disconnected
 ;2;Idle, vfu not loadable
 ;3;Idle, transfer error (DI or HOST)
 ;4;Idle, accounting limit exceeded
 ;5;Idle, operator dropped file
 ;6;Idle, operator requeued file
 ;7;Idle, operator hold file
 ;8;Busy (file transfer started)
 ;9;Suspended, device not ready (file transfer busy)
 ;10;Suspended, PM message (file transfer busy)
 ;11;Suspended, operator command (file transfer busy)
 ;12;Suspended, operator position file (file transfer busy)
 ;13;Suspended, VFU procedure being loaded
 ;14;Reserved for other busy conditions
 ;15;Reserved for other busy conditions
\-
\ n.n.n.n Job Destination Unavailable Action Codes
\+
 ;~Value~;~Meaning~

 ;0;Stop I/O station
 ;1;Drop job
\-
\ n.n.n.n Job State Codes
\+
 ;~Value~;~meaning~

 ;0;input queue
 ;1;executing
 ;2;output queue
\-

\ n.n.n.n Optimization Request Codes
\+
 ;~Value~;~meaning~

 ;0;do not optimize
 ;1;do optimize
\-

\ n.n.n.n Output Data Mode Codes
\+
 ;~Value~;~Meaning~

 ;0;coded mode
 ;1;transparent mode
\-
\ n.n.n.n Output State Codes
\+
 ;~Value~;~Meaning~

 ;0;eligible for selection
 ;1;hold
 ;2;not eligible for selection
 ;3;selected
 ;4;completed
\-
\ n.n.n.n Page Format Codes
\+
 ;~Value~;~Meaning~

 ;0;continuous (not paged)
 ;1;burstable (paged)
 ;2;not burstable (paged)
\-
\ n.n.n.n Position Direction Codes
\+
 ;~Value~;~Meaning~

 ;0;forward
 ;1;backward
\-
\ n.n.n.n Position Units Codes
\+
 ;~Value~;~Meaning~

 ;0;lines
 ;1;pages
\-
\ n.n.n.n Starting Position Codes
\+
 ;~Value~;~Meaning~

 ;0;top of file
 ;1;bottom of file
 ;2;last line printed
\-
\ n.n.n.n Station Usage Codes
\+
 ;~Value~;~Meaning~

 ;0;public
 ;1;private
 ;2;NTF
\-
\ n.n.n.n Banner Highlight Field Codes
\+
 ;~Value~;~Meaning~

 ;0;comment banner
 ;1;routing banner
 ;2;site banner
 ;3;user file name
 ;4;user name
\-
\keep12
\ n.n.n.n Code Set Codes
\+
 ;~Value~;~Meaning~

 ;0;ASCII
 ;1;ASCII 48
 ;2;ASCII 64
 ;3;ASCII 95
 ;4;ASCII 128
 ;5;EBCDIC
 ;6;ASCII 256
 ;7;BCD (Mode 4)
 ;8;Defined by site, indicates use of site-defined code set parameter
\-
\keep8
\ n.n.n.n VFU Load Option Codes
\+
 ;~Value~;~Meaning~

 ;0;NONE - VFU not present or not loadable
 ;1;INIT - VFU loaded during initialization
 ;2;OPER - VFU changeable by operator
 ;3;USER - VFU changeable by operator or user
\-
\keep7
\ n.n.n.n Format Effector Action Codes
\+
 ;~Value~;~Meaning~

 ;0;PAS - print after spacing
 ;1;PBS - print before spacing
 ;2;DIS - discard print line
\-
\keep10
\ n.n.n.n Vertical Print Density Codes (device attribute)
\+
 ;~Value~;~Meaning~

 ;0;six only - device only capable of printing 6 lines/inch
 ;1;eight only - device only capable of printing 8 lines/inch
 ;2;six any - device capable of printing 6 or 8 lines/inch
but defaulting to 6 if user does not care
 ;3;eight any - device capable of printing 6 or 8 lines/inch
but defaulting to 8 if user does not care

\-
\ n.n.n.n Vertical Print Density Codes (output file attribute)
\+
 ;~Value~;~Meaning~

 ;0;none - the device vertical print density will be used
 ;1;6 lines per inch
 ;2;7 lines per inch
 ;3;8 lines per inch
 ;4;9 lines per inch
 ;5;10 lines per inch
 ;6;11 lines per inch
 ;7;12 lines per inch
\-
\keep7
\ n.n.n.n PM Message Action Codes
\+
 ;~Value~;~Meaning~

 ;0;print PM message
 ;1;display PM message to operator
 ;2;discard PM message
\-
\ n.n.n.n Tip Type Codes
\+
 ;~Value~;~Meaning~

 ;0;internal tip
 ;1;auto tip
 ;2;async tip
 ;3;user1 tip
 ;4;user2 tip
 ;5;user3 tip
 ;6;user4 tip
 ;7;hasp tip
 ;8;x25 async tip
 ;9;bisync 3270 tip
 ;10;bisync njef tip
 ;11;remote term emulator tip
 ;12;uri tip
 ;13;xpc tip
 ;14;mode4 tip
 ;15;ntf tip
 ;16;sna 3270 tip
 ;17;telnet tip
\-
\ n.n.n.n Data Parity Codes
\+
 ;~Value~;~Meaning~

 ;0;Zero
 ;1;Mark
 ;2;Even
 ;3;Odd
 ;4;None
\-
\ n.n.n.n Remote System Protocol Codes
\+
 ;~Value~;~Meaning~

 ;0;NJE
 ;1;HASP
\-
\ n.n.n.n Remote System Authority Level Codes
\+
 ;~Value~;~Meaning~

 ;0;NONE
 ;1;NET
 ;2;JOB
\-
\ n.n.n.n Remote System Wait-a-Bit Codes
\+
 ;~Value~;~Meaning~

 ;0;ACK
 ;1;FCS
\-
\ n.n.n.n Remote System Positive Acknowledge Codes
\+
 ;~Value~;~Meaning~

 ;0;ACK
 ;1;NULL
\-
\ n.n.n.n Remote System Kind Codes
\+
 ;~Value~;~Meaning~

 ;0;Not configured
 ;1;Directly Connected
 ;2;Accessible
\-
\ n.n.n.n Remote System Type Codes
\+
 ;~Value~;~Meaning~

 ;0;NOS/VE
 ;1;NOS
 ;2;NOS/BE
 ;3;IBM
 ;4;DEC
 ;5;User
 ;6;CYBER 205
 ;7;ETA
 ;8;Cray
\-
\ n.n.n.n Remote System Command Type Codes
\+
 ;~Value~;~Meaning~

 ;0;Command
 ;1;Message
 ;2;Signon
 ;3;Signoff
 ;4;TDP
 ;5;Broadcast
 ;6;Operator
\-
\ n.n.n.n Terminate Queued Output Response Codes
\+
 ;~Value~;~Meaning~

 ;0;Successful
 ;1;Unknown I/O Station
 ;2;Unknown File Name
 ;3;Duplicate File Names
 ;4;File Being Transferred
 ;5;Message Rejected
\-
\block,j1,i4
\ n.0 command message type tables
 This section presents consolidated lists of message type codes to
message name cross references. One list is presented in message type sequence
and one in message name sequence.
\ n.n message type sequence
\box,1,16,62
\table;3,18
 ;Message type;Message Name
\boxline
\table;8,18
 ;01;Add File Availability
 ;02;Modify File Availability
 ;03;Delete File Availability
 ;04;File Assignment
 ;05;File Assignment Response
 ;06;Delete Destination
 ;07;BTF/VE Status
 ;09;Add Accessible Remote System Response
 ;10;Get Remote System Names
 ;11;Remote System Names Data
 ;12;Get Remote System Options
 ;13;Remote System Options Data
 ;14;Delete User
 ;15;Delete User Response
 ;16;Send Remote Command
 ;17;Send Remote Command Response
 ;18;Get Remote System Status
 ;19;Remote System Status Data
 ;20;Add I/O Station
 ;21;Delete I/O Station
 ;22;Add Batch Device
 ;23;Batch Device Status
 ;24;File Status
 ;25;Delete Batch Device
 ;26;BTFS/DI Status
 ;27;Add I/O Station Response
 ;28;Delete I/O Station Response
 ;29;Start I/O Station
 ;30;Stop I/O Station
 ;31;Switch Control (to SCF/DI)
 ;32;Position File Transfer (to SCF/DI)
 ;33;Add Batch Device Response
 ;34;Delete Batch Device Response
 ;35;Add Remote System
 ;36;Add Accessible Remote System
\nobox
\page
\box
 ;37;Delete Remote System
 ;38;Add Remote System Response
 ;39;Delete Remote System Response
 ;40;Suppress Carriage Control Response
 ;41;Start Batch Device
 ;42;Stop Batch Device
 ;43;Suppress Carriage Control
 ;44;Terminate Transfer
 ;45;Change Batch Device Attribute
 ;46;Change Batch Device Attributes Response
 ;47;Start Batch Device Response
 ;48;Stop Batch Device Response
 ;49;Terminate Transfer Response
 ;50;Position File Transfer Response
 ;51;Operator Message
 ;60;Add User
 ;61;Add User Response
 ;62;Select File
 ;63;Select File Response
 ;64;Position File (from OPES)
 ;65;Get Station Status
 ;66;Station Status Data
 ;67;Get Device Status
 ;68;Device Status Data
 ;69;Get Queue Status
 ;70;Queue Status Data
 ;71;Get Queue Entry List
 ;72;Queue Entry List Data
 ;73;Get Queue Entry
 ;74;Queue Entry Data
 ;75;Terminate Queued Output
 ;76;Terminate Queued Outupt Response
 ;80;Switch Control
\nobox
\page
\ n.n command message name sequence
\box,1,16,62
\table;3,18
 ;Message type;Message Name
\boxline
\table;8,18
 ;36;Add Accessible Remote System
 ;09;Add Accessible Remote System Response
 ;22;Add Batch Device
 ;33;Add Batch Device Response
 ;01;Add File Availability
 ;20;Add I/O Station
 ;27;Add I/O Station Response
 ;35;Add Remote System
 ;38;Add Remote System Response
 ;60;Add User
 ;61;Add User Response
 ;23;Batch Device Status
 ;07;BTF/VE Status
 ;26;BTFS/DI Status
 ;45;Change Batch Device Attribute
 ;46;Change Batch Device Attribute Response
 ;25;Delete Batch Device
 ;34;Delete Batch Device Response
 ;06;Delete Destination
 ;03;Delete File Availability
 ;21;Delete I/O Station
 ;28;Delete I/O Station Response
 ;37;Delete Remote System
 ;39;Delete Remote System Response
 ;14;Delete User
 ;15;Delete User Response
 ;68;Device Status Data
 ;04;File Assignment
 ;05;File Assignment Response
 ;24;File Status
 ;67;Get Device Status
 ;73;Get Queue Entry
 ;71;Get Queue Entry List
 ;69;Get Queue Status
 ;10;Get Remote System Names
 ;12;Get Remote System Options
 ;18;Get Remote System Status
 ;65;Get Station Status
 ;03;Modify File Availability
 ;51;Operator Message
 ;64;Position File (from OPES)
 ;32;Position File Transfer (to SCF/DI)
 ;50;Position File Transfer Response
\nobox
\page
\box
 ;74;Queue Entry Data
 ;72;Queue Entry List Data
 ;70;Queue Status Data
 ;11;Remote System Names Data
 ;13;Remote System Options Data
 ;19;Remote System Status Data
 ;62;Select File
 ;63;Select File Response
 ;16;Send Remote Command
 ;17;Send Remote Command Response
 ;41;Start Batch Device
 ;47;Start Batch Device Response
 ;29;Start I/O Station
 ;66;Station Status Data
 ;42;Stop Batch Device
 ;48;Stop Batch Device Response
 ;30;Stop I/O Station
 ;43;Suppress Carriage Control
 ;40;Suppress Carriage Control Response
 ;80;Switch Control
 ;31;Switch Control (to SCF/DI)
 ;75;Terminate Queued Output
 ;76;Terminate Queued Outupt Response
 ;44;Terminate Transfer
 ;49;Terminate Transfer Response
\nobox
\title2=
*DECK DECK=NFC$ABNORMAL_CONDITIONS EXPAND=TRUE

  CONST
    nfc$status_id = 'NF',
    nfc$min_ecc = ( ($INTEGER ('N') * 100(16)) + $INTEGER('F') ) * 1000000(16),
    nfc$min_status_condition = nfc$min_ecc,
    nfc$max_ecc = ( ($INTEGER ('N') * 100(16)) + $INTEGER('G') ) * 1000000(16)
             - 1;

*DECK DECK=NFC$BTS_APPLICATION_NAMES EXPAND=TRUE
?? SKIP := 4 ??                                                                                               
  CONST                                                                                                       
    nfc$btf_application_name = 'OSA$BATCH_TRANSFER_CLIENT      ',                                             
    nfc$null_name = '                               ',                                                        
    nfc$ptf_application_name = 'OSA$FILE_TRANSFER_CLIENT       ',                                             
    nfc$ptfs_application_name = 'OSA$FILE_TRANSFER_SERVER       ';                                            
?? SKIP := 4 ??                                                                                               
*DECK DECK=NFC$COMMAND_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$command_definitions' ??

{ Nfc$command_definitions }

  CONST
    nfc$pdu_command_pos = 1, { Position of command in PDU }
    nfc$pdu_command_len = 2, { Number of digits in command }
    nfc$pdu_nparams_pos = 3, { Position of # of parameters in PDU }
    nfc$pdu_nparams_len = 2, { Number of digits in # of parameters }
    nfc$pdu_header_size = nfc$pdu_command_len + nfc$pdu_nparams_len,
    nfc$begin_params_pos = nfc$pdu_header_size + 1,
    nfc$command_buffer_size = 2043, { Size of buffer for commands }
    nfc$trace_commands = FALSE,
    nfc$trace_commands_width = 60,
    nfc$ptfs_job_line_width = 254,
    nfc$ptfs_job_line_header = '"',
    nfc$ptfs_job_line_head_len = 1,
    nfc$ptfs_job_line_tailer = '"',
    nfc$ptfs_job_line_tail_len = 1,
    nfc$ptfs_job_delimiter = '*',
    nfc$ptfs_job_end_buffer = nfc$ptfs_job_delimiter CAT 'EOB',
    nfc$ptfs_job_end_blen = 4,
    nfc$ptfs_job_end_command = nfc$ptfs_job_delimiter CAT 'EOC',
    nfc$ptfs_job_end_clen = 4,
    nfc$ptfs_switch_init_time = 30, { Number of seconds for boot to wait
    { on connection switch before checking
    { to see if user job still exists
    nfc$ptfs_switch_term_time = 30, { Number of seconds before time out
    { (P20) that switch processing
    { should be terminated to allow
    { RNEG to be sent
    nfc$max_ptfi_connects = 1,

    nfc$lcn_appl_name_ptf = 'PTF    ',
    nfc$lcn_appl_name_ptfs = 'PTFS   ',
    nfc$lcn_appl_name_qtf = 'QTF    ',
    nfc$lcn_appl_name_qtfs = 'QTFS   ',
    nfc$lcn_appl_name_btf = 'BTF    ',
    nfc$lcn_appl_name_btfs = 'BTFS   ',

    nfc$nam_appl_name_ptf = 'OSA$FILE_TRANSFER_CLIENT       ',
    nfc$nam_appl_name_ptfs = osc$file_transfer_server,
    nfc$nam_appl_name_qtf = 'OSA$QUEUE_TRANSFER_CLIENT      ',
    nfc$nam_appl_name_qtfs = osc$queue_transfer_server,
    nfc$nam_appl_name_btf = 'OSA$BATCH_TRANSFER_CLIENT      ',
    nfc$nam_appl_name_btfs = osc$batch_transfer_server,

    nfc$nam_ptfs_title_prefix = 'PTFS$',
    nfc$nam_qtfs_title_prefix = 'QTFS$',
    nfc$nam_btfs_title_prefix = 'BTFS$',
    nfc$nam_bada_title_prefix = '????$',
    nfc$nam_title_prefix_length = 5,

    nfc$milliseconds = 1000,
    nfc$connection_timeout = 60 * 1000, { 60 Milliseconds }
    nfc$command_radix = 10,
    nfc$command_include_radix = FALSE,
    nfc$command_fill_char = '0',
    nfc$command_unknown = 'XX',
    nfc$command_rft = '00',
    nfc$command_rpos = '01',
    nfc$command_rneg = '02',
    nfc$command_go = '03',
    nfc$command_stop = '04',
    nfc$command_stopr = '05',
    nfc$command_etp = '60',
    nfc$command_etpr = '61',
    nfc$command_fini = '62';

*copyc osc$batch_transfer_server
*copyc osc$file_transfer_server
*copyc osc$queue_transfer_server

?? OLDTITLE ??
*DECK DECK=NFC$EXTERNAL_CHARACTERISTIC_A9 EXPAND=FALSE
  CONST
    nfc$external_characteristic_a9 = 'A9';

*DECK DECK=NFC$LIBRARY_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$library_definitions' ??

{ Nfc$library_definitions }

  CONST
    nfc$system_library_name = '$SYSTEM.PTF_QTF.OSF$USER_FILE_TRANSFER',
    nfc$system_library_length = 38,

    nfc$ptfs_command_name = 'EXET L=' CAT nfc$system_library_name CAT
          ' SP=NFP$USER_PTFS_JOB',
    nfc$ptfs_command_length = 28 + nfc$system_library_length,

    nfc$number_ptfi_libraries = 1,
    nfc$ptfi_library_name = nfc$system_library_name,
    nfc$ptfi_library_length = nfc$system_library_length,
    nfc$ptfi_sp = 'NFP$PERFORM_IMPLICIT_TRANSFER',
    nfc$ptfi_sp_length = 30;

?? OLDTITLE ??
*DECK DECK=NFC$MANAGE_STORE_FORWARD_FILE EXPAND=FALSE

  CONST
    nfc$sf_family_name = '$SYSTEM',
    nfc$sf_permanent_file_name = 'STORE_FORWARD_NETWORK',
    nfc$sf_subcatalog_name = 'PTF_QTF',
    nfc$sf_user_name = '$SYSTEM',
    nfc$manage_store_forward_file = ':' CAT nfc$sf_family_name CAT '.'
          CAT nfc$sf_user_name CAT '.' CAT nfc$sf_subcatalog_name CAT '.'
          CAT nfc$sf_permanent_file_name;
*DECK DECK=NFC$MAX_FILE_SIZE EXPAND=FALSE
  CONST
    nfc$max_file_size = 0ffffffff(16);

*DECK DECK=NFC$MAX_INPUT_JOB_SIZE EXPAND=FALSE
CONST
  nfc$max_input_job_size = 0ffffffff(16);
*DECK DECK=NFC$NORMAL_STRING EXPAND=FALSE
  CONST
    nfc$normal_string = 'NORMAL';

*DECK DECK=NFC$NTF_CONTROL_FACILITY_PREFIX EXPAND=FALSE

  CONST
     nfc$ntf_control_facility_prefix = 'NTF_',
     nfc$ntf_control_fac_prefix_size = 4;
*DECK DECK=NFC$PARAMETER_00_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_00_definitions' ??

{ nfc$parameter_00_definitions }

  CONST
    nfc$p00_size_a102 = 4, { Length in characters of A102 string }
    nfc$p00_size_a101 = 4, { Length in characters of A101 string }
    nfc$p00_size_b101 = 4, { Length in characters of B101 string }
    nfc$p00_min_size = 4, { Length of smallest value }
    nfc$p00_max_size = 4, { Length of largest value }
    nfc$p00_value_a102 = 'A102', { Value of a102 }
    nfc$p00_value_a101 = 'A101', { Value of a101 }
    nfc$p00_value_b101 = 'B101'; { Value of b101 }

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_01_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_01_definitions' ??

{ nfc$parameter_01_definitions }

  CONST
    nfc$p01_min_size = 4, { Minimum # of digits in parameter }
    nfc$p01_max_size = 4, { Maximum # of digits in parameter }
    nfc$p01_fill_char = '0', { Pad at begining with }
    nfc$p01_min_value = 0, { Smallest value }
    nfc$p01_max_value = 9999, { Largest value }
    nfc$p01_unit = 1024, { Unit of value }
    nfc$p01_radix = 10, { Radix of value }
    nfc$p01_include_radix = FALSE; { Don't include radix }

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_02_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_02_definitions' ??

{ nfc$parameter_02_definitions }

  CONST
    nfc$p02_min_size = 0, { Minimum # of chars in parameter
    nfc$p02_max_size = 999; { Maximum # of chars in parameter

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_03_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_03_definitions' ??

{ nfc$parameter_03_definitions }

  CONST
    nfc$p03_min_size = 1, { Length of smallest value }
    nfc$p03_max_size = 8, { Length of largest value }
    nfc$p03_element_size = 1, { Size of facility element }

    nfc$p03_s_multiple_data_params = 'A',
    nfc$p03_s_collective_strings = 'C',
    nfc$p03_s_temporary_hold = 'H',
    nfc$p03_s_parameters_on_go = 'G',
    nfc$p03_s_later_resumption = 'L',
    nfc$p03_s_restart_permitted = 'R',
    nfc$p03_s_checkmark_ack_req = 'M',
    nfc$p03_s_send_data_ack_req = 'S',
    nfc$p03_s_data_compression = 'Q';

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_04_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_04_definitions' ??

{ nfc$parameter_04_definitions }

  CONST
    nfc$p04_general_state_size = 2, { # of chars in general state
    nfc$p04_specific_state_size = 4, { # of chars in specific state
    nfc$p04_max_param_len = nfc$p04_general_state_size +
          nfc$p04_specific_state_size,
    nfc$p04_min_param_len = nfc$p04_max_param_len,
    nfc$p04_max_transfer_states = 34,

{     Indexes into P04 array }
    nfc$p04_acceptable_and_satisfac = 1,
    nfc$p04_accept_and_satis_resend = 2,
    nfc$p04_unspecific_transfer = 3,
    nfc$p04_transfer_rejected_messa = 4,
    nfc$p04_unacceptable_attributes = 5,
    nfc$p04_unspecific_file_store = 6,
    nfc$p04_file_not_found = 7,
    nfc$p04_no_file_access = 8,
    nfc$p04_wrong_file_type = 9,
    nfc$p04_file_unavailable = 10,
    nfc$p04_invalid_user = 11,
    nfc$p04_invalid_password = 12,
    nfc$p04_invalid_account = 13,
    nfc$p04_invalid_account_pw = 14,
    nfc$p04_no_money = 15,
    nfc$p04_file_too_large = 16,
    nfc$p04_wrong_device = 17,
    nfc$p04_satisfac_and_complete = 18,
    nfc$p04_terminate_xfer_message = 19,
    nfc$p04_accounting_limit_execd = 20,
    nfc$p04_discard_input_file = 21,
    nfc$p04_requeue_output_file = 22,
    nfc$p04_requeue_at_cur_priority = 23,
    nfc$p04_requeue_not_eligible_fl = 24,
    nfc$p04_requeue_at_new_priority = 25,
    nfc$p04_pm_message_time_out = 26,
    nfc$p04_station_operator_termin = 27,
    nfc$p04_satisfac_and_incomplete = 28,
    nfc$p04_receiver_problem_retry = 29,
    nfc$p04_receiver_problem_noretr = 30,
    nfc$p04_sender_problem_retry = 31,
    nfc$p04_sender_problem_noretry = 32,
    nfc$p04_application_time_out = 33,
    nfc$p04_protocol_anomaly = 34;


?? OLDTITLE ??

*DECK DECK=NFC$PARAMETER_05_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_05_definitions' ??

{ nfc$parameter_05_definitions }

  CONST
    nfc$p05_min_param_len = 1, { Minimum # of chars in param
    nfc$p05_max_param_len = 999; { Maximum # of chars in param

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_06_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_06_definitions' ??

{ nfc$parameter_06_definitions }

  CONST
    nfc$p06_min_param_len = 1, { Minimum # of chars in string
    nfc$p06_max_param_len = 8, { Maximum # of chars in string
    nfc$p06_fill_char = '0', { Pad at beginning with }
    nfc$p06_min_value = 0, { Minimum accepted value }
    nfc$p06_max_value = 99999999, { Maximum accepted value }
    nfc$p06_unit = 1024, { Unit of value }
    nfc$p06_radix = 10, { Radix of parameter }
    nfc$p06_include_radix = FALSE, { No radix specification }
    nfc$p06_unlimited_value = 0; { Means no limit }

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_07_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_07_definitions' ??

{ nfc$parameter_07_definitions }

  CONST
    nfc$p07_min_param_len = 0, { Minimum # of chars for param
    nfc$p07_max_param_len_a101 = 80, { Maximum # of chars in prot id
    nfc$p07_max_param_len_a102 = 999, { Maximum # of chars in prot id
    nfc$p07_job_log_message = 'RHF - operator message from remote';

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_08_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_08_definitions' ??

{ nfc$parameter_08_definitions }

  CONST
    nfc$p08_min_param_len = 0, { Minimum # of chars for param
    nfc$p08_max_param_len_a101 = 80, { Maximum # of chars in prot id
    nfc$p08_max_param_len_a102 = 999, { Maximum # of chars in prot id
    nfc$p08_max_param_len_b101 = 999, { Maximum # of chars in prot id
    nfc$p08_job_log_message = 'RHF - user message from remote';

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_09_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_09_definitions' ??

{ nfc$parameter_09_definitions }

  CONST
    nfc$p09_min_param_len = 0, { Minimum # of chars for param
    nfc$p09_max_param_len_a101 = 80, { Maximum # of chars in prot id
    nfc$p09_max_param_len_a102 = 999, { Maximum # of chars in prot id
    nfc$p09_max_param_len_b101 = 999; { Maximum # of chars in prot id

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_10_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_10_definitions' ??

{ nfc$parameter_10_definitions }

  CONST
    nfc$p10_min_param_len = 0, { Minimum # of chars for param
    nfc$p10_max_param_len_a101 = 80, { Maximum # of chars in prot id
    nfc$p10_max_param_len_a102 = 999; { Maximum # of chars in prot id

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_11_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_11_definitions' ??

{ nfc$parameter_11_definitions }

  CONST
    nfc$p11_start_id = 1, { Position where ID value starts
    nfc$p11_length_id = 2, { # of chars in ID field
    nfc$p11_start_condition = nfc$p11_start_id + nfc$p11_length_id,
    nfc$p11_length_condition = 6, { # of chars in condition field
    nfc$p11_start_message = nfc$p11_start_condition + nfc$p11_length_condition,
    nfc$p11_max_length_message = osc$max_string_size,
    nfc$p11_min_param_len = 0,
    nfc$p11_max_param_len = 999,
    nfc$p11_radix = 10,
    nfc$p11_include_radix = FALSE,
    nfc$p11_fill_char = '0';

*copyc ost$string
?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_12_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_12_definitions' ??

{ nfc$parameter_12_definitions }

  CONST
    nfc$p12_min_size_a101 = 1,
    nfc$p12_min_size_a102 = 1,
    nfc$p12_min_size_b101 = 1,
    nfc$p12_max_size_a101 = 4,
    nfc$p12_max_size_a102 = 5,
    nfc$p12_max_size_b101 = 4,
    nfc$p12_max_value = 99999, { Maximum allowed value
    nfc$p12_infinite_size = nfc$p12_max_value,
    nfc$p12_nam_default = (3*4096)-data_header_length,
    nfc$p12_lcn_default = 4096, { Use when talking on lcn
    nfc$p12_nos_binary_size = 2880, { Nos/Nos be specific
    nfc$p12_nos_ascii_size = 3840, { Nos/Nos be specific
    nfc$p12_c200_maximum = 4064, { C200 specify
    nfc$p12_fill_char = '0',
    nfc$p12_radix = 10,
    nfc$p12_include_radix = FALSE;

*copyc nfd$transfer_declarations
*copyc nft$control_block
*copyc nft$transfer_modes
?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_13_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_13_definitions' ??

{ nfc$parameter_13_definitions }

  CONST
    nfc$p13_min_param_size = 0,
    nfc$p13_max_param_size = 8,
    nfc$p13_min_param_value = 1,
    nfc$p13_max_param_value = 99999999,
    nfc$p13_default_value = nfc$p13_max_param_value, { = infinite }
    nfc$p13_radix = 10,
    nfc$p13_include_radix = FALSE;

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_16_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_16_definitions' ??

{ nfc$parameter_16_definitions }

  CONST
    nfc$p16_min_param_length = 1,
    nfc$p16_max_param_length_a102 = 31,
    nfc$p16_max_param_length_a101 = 8,
    nfc$p16_max_param_length_b101 = 31,
    nfc$p16_max_param_length = 31, { Maximum possible }

    nfc$p16_1st_range1_a101 = '@',
    nfc$p16_last_range1_a101 = 'Z',
    nfc$p16_1st_range2_a101 = '0',
    nfc$p16_last_range2_a101 = '9',
    nfc$p16_special1_a101 = '#',
    nfc$p16_special2_a101 = '$';

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_17_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_17_definitions' ??

{ nfc$parameter_17_definitions }

  CONST
    nfc$p17_min_size = 2,
    nfc$p17_max_size = 2,
    nfc$p17_wait_queue = 'WT';

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_18_DEFINITIONS EXPAND=FALSE
?? newtitle := 'nfc$parameter_18_definitions' ??

{ nfc$parameter_18_definitions }

CONST
      nfc$p18_minimum_parameter_size = 4,
      nfc$p18_maximum_parameter_size = 4,
      nfc$p18_minimum_value = 1,
      nfc$p18_maximum_value = 255,
      nfc$p18_default_value = 2,
      nfc$p18_radix = 10,
      nfc$p18_include_radix = FALSE,
      nfc$p18_fill_character = '0';

?? oldtitle ??
*DECK DECK=NFC$PARAMETER_19_DEFINITIONS EXPAND=FALSE
?? newtitle := 'nfc$parameter_19_definitions' ??

{ nfc$parameter_19_definitions }

CONST
      nfc$p19_minimum_parameter_size = 4,
      nfc$p19_maximum_parameter_size = 4,
      nfc$p19_minimum_value = 0,
      nfc$p19_maximum_value = 9999,
      nfc$p19_default_value = 0,
      nfc$p19_radix = 10,
      nfc$p19_include_radix = FALSE,
      nfc$p19_fill_character = '0';

?? oldtitle ??
*DECK DECK=NFC$PARAMETER_20_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_20_definitions' ??

{ nfc$parameter_20_definitions }

  CONST
    nfc$p20_min_size = 4, { Minimum # of chars in parameter
    nfc$p20_max_size = 4, { Maximum # of chars in parameter
    nfc$p20_min_value = 0000, { Please don't try it
    nfc$p20_min_allowed = 0075, { Smallest we will take
    nfc$p20_max_value = 9999, { Biggest allowed
    nfc$p20_infinite_value = nfc$p20_max_value,
    nfc$p20_network_default = 0600,
    nfc$p20_network_read_short_wait = 750, { 750 milliseconds }
    nfc$p20_fill_char = '0',
    nfc$p20_radix = 10,
    nfc$p20_include_radix = FALSE;

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_21_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_21_definitions' ??

{ nfc$parameter_21_definitions }

  CONST
    nfc$p21_min_param_len = 5, { Minimum size of parameter }
    nfc$p21_max_param_len = 5, { Maximum size of parameter }
    nfc$p21_prefix_position = 1, { Position in param data of prefix }
    nfc$p21_prefix_length = 1, { Number of chars in prefix }
    nfc$p21_prefix_value_take = 'T', { Value for take }
    nfc$p21_prefix_value_give = 'G', { Value for give }
    nfc$p21_prefix_value_null = 'N', { Value for null }
    nfc$p21_opt_position = 2, { Position in param data of option }
    nfc$p21_opt_length = 4, { Number of chars in option }
    nfc$p21_num_option_values = 9, { Number of trailer values }
    nfc$p21_opt_non_specific = '0000', { Non-specific }
    nfc$p21_opt_make_only = '0001', { Create a new file (QTF,T) }
    nfc$p21_opt_replace_only = '0002', { Write over existing file }
    nfc$p21_opt_replace_make = '0003', { Write over or make new file }
    nfc$p21_opt_append_only = '0004', { Can only append to existing file }
    nfc$p21_opt_append_or_make = '0005', { Can append or make file }
    nfc$p21_opt_read_remove = '0006', { Read file and delete }
    nfc$p21_opt_read_only = '0007', { Read file (PTFS,T) }
    nfc$p21_opt_destructive_read = '0008',
          { Read destroying section by section }
    nfc$p21_opt_make_only_too = '1001';
          { Create a new file (QTF,T) ,same as 0001 - need this to support IBM }

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_22_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_22_definitions' ??

{ nfc$parameter_22_definitions }

  CONST
    nfc$p22_min_size = 3, { Minimum # of chars in parameter }
    nfc$p22_max_size = 3, { Maximum # of chars in parameter }
    nfc$p22_value_unknown_host = '???',
    nfc$p22_value_cyber_nosve = 'NVE',
    nfc$p22_value_cyber_nosve_qtf = 'NVQ',  {This is QTF at 1.4.1 and on.
    nfc$p22_number_values = 2;

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_24_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_24_definitions' ??

{ nfc$parameter_24_definitions }

  CONST
    nfc$p24_min_param_size_a101 = 3,
    nfc$p24_max_param_size_a101 = 3,
    nfc$p24_min_param_size_a102 = 1,
    nfc$p24_max_param_size_a102 = 31,
    nfc$p24_min_param_size_b101 = 1,
    nfc$p24_max_param_size_b101 = 31,
    nfc$p24_min_param_size = nfc$p24_min_param_size_a102,
    nfc$p24_max_param_size = nfc$p24_max_param_size_a102;

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_25_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_25_definitions' ??

{ nfc$parameter_25_definitions }

  CONST
    nfc$p25_input_params = 2,
    nfc$p25_input_family = 1,
    nfc$p25_input_domain = 2,

    nfc$p25_output_params = 2,
    nfc$p25_output_station = 1,
    nfc$p25_output_domain = 2,

    nfc$p25_min_param_size_a102 = 1,
    nfc$p25_max_param_size_a102 = 31,
    nfc$p25_min_param_size_a101 = 3,
    nfc$p25_max_param_size_a101 = 3,
    nfc$p25_min_param_size_b101 = 1,
    nfc$p25_max_param_size_b101 = 63,
    nfc$p25_min_param_size = 1,
    nfc$p25_max_param_size = 63;

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_26_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_26_definitions' ??

{ nfc$parameter_26_definitions }

  CONST
    nfc$p26_min_param_length = 1,
    nfc$p26_max_param_length_a102 = 31,
    nfc$p26_max_param_length_a101 = 8,
    nfc$p26_max_param_length_b101 = 31,
    nfc$p26_max_param_length = 31, { Maximum possible }
    nfc$p26_1st_char_a102 = ' ',
    nfc$p26_last_char_a102 = '`',

    nfc$p26_1st_range1_a101 = '@',
    nfc$p26_last_range1_a101 = 'Z',
    nfc$p26_1st_range2_a101 = '0',
    nfc$p26_last_range2_a101 = '9',
    nfc$p26_special1_a101 = '#',
    nfc$p26_special2_a101 = '$';

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_27_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_27_definitions' ??

{ nfc$parameter_27_definitions }

  CONST
    nfc$p27_min_param_size_a102 = 1,
    nfc$p27_max_param_size_a102 = 31,
    nfc$p27_min_param_size_a101 = 3,
    nfc$p27_max_param_size_a101 = 3,
    nfc$p27_min_param_size_b101 = 1,
    nfc$p27_max_param_size_b101 = 31,
    nfc$p27_min_param_size = 1,
    nfc$p27_max_param_size = 31;

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_28_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_28_definitions' ??

{ nfc$parameter_28_definitions }

  CONST
    nfc$p28_min_size = 3, { Minimum # of chars in parameter }
    nfc$p28_max_size = 3; { Maximum # of chars in parameter }

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_29_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_29_definitions' ??

{ nfc$parameter_29_definitions }

  CONST
    nfc$p29_min_param_size_a102 = 1,
    nfc$p29_max_param_size_a102 = nfc$max_param_size,
    nfc$p29_min_param_size_a101 = 1,
    nfc$p29_max_param_size_a101 = nfc$max_param_size,
    nfc$p29_min_param_size_b101 = 1,
    nfc$p29_max_param_size_b101 = nfc$max_param_size,
    nfc$p29_min_param_size = nfc$p29_min_param_size_a101,
    nfc$p29_max_param_size = nfc$p29_max_param_size_a101,
    nfc$p29_data_mode_parameter = 'DATA_MODE=',
    nfc$p29_data_mode_param_length = 10,
    nfc$p29_login_family_parameter = 'LOGIN_FAMILY=',
    nfc$p29_login_family_param_len = 13,
    nfc$p29_rhf_structured_length = 13,
    nfc$p29_rhf_structured_value = 'RHF_STRUCTURE',
    nfc$p29_qtfi_info = 'QTFI_INFORMATION=',
    nfc$p29_qtfi_info_length = 17,
    nfc$p29_qtfi_info_err_file = 'EF',
    nfc$p29_qtfi_info_err_file_len = 2;


*copyc nfc$parameter_definitions
?? OLDTITLE ??

*DECK DECK=NFC$PARAMETER_30_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_30_definitions' ??

{ nfc$parameter_30_definitions }

  CONST
    nfc$p30_min_param_size = 0,
    nfc$p30_max_param_size = 0,
    nfc$p30_required_space = nfc$p30_max_param_size + nfc$param_header_size,
    nfc$p30_param_value = '30S000';

*copyc nfc$parameter_definitions
?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_31_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_31_definitions' ??

{ nfc$parameter_31_definitions }

  CONST
    nfc$p31_min_param_length_a102 = 2,
    nfc$p31_min_param_length_a101 = 2,
    nfc$p31_min_param_length_b101 = 2,
    nfc$p31_max_param_length_a102 = 2,
    nfc$p31_max_param_length_a101 = 2,
    nfc$p31_max_param_length_b101 = 2,
    nfc$p31_max_param_length = 2,
    nfc$p31_unspecified_dd = '**',
    nfc$p31_ascii_64 = 'C6',
    nfc$p31_ascii_extended = 'C8',
    nfc$p31_host_dependent = 'UH',
    nfc$p31_undefined_unstructured = 'UU',
    nfc$p31_undefined_structured = 'US';

?? OLDTITLE ??

*DECK DECK=NFC$PARAMETER_32_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_32_definitions' ??

{ nfc$parameter_32_definitions }

  CONST
    nfc$p32_variant_size = 3,

    nfc$p32_cyber_id = 'CYB',
    nfc$p32_cyber_id_length = 3,
    nfc$p32_cyb_input_no_return_no = 'NO',
    nfc$p32_cyb_input_wait_queue_to = 'TO',
    nfc$p32_cyb_printer_value_lp = 'LP',
    nfc$p32_cyb_wait_queue_value_tt = 'TT',
    nfc$p32_cyb_wait_queue_value_wt = 'WT',

    nfc$p32_b101_public_ios_id = 'CN0',
      nfc$p32_b101_public_params = 2,
      nfc$p32_b101_station = 1,
      nfc$p32_b101_pub_search_domain = 2,

    nfc$p32_b101_private_ios_id = 'CN1',
      nfc$p32_b101_private_params = 5,
      nfc$p32_b101_control_facility = 1,
      nfc$p32_b101_priv_search_domain = 2,
      nfc$p32_b101_op_user_name = 3,
      nfc$p32_b101_op_family = 4,
      nfc$p32_b101_op_community = 5,

    nfc$p32_b101_ntf_id = 'NTF',
      nfc$p32_b101_ntf_params = 4,
      nfc$p32_b101_remote_sys_name = 1,
      nfc$p32_b101_remote_sys_prot = 2,
      nfc$p32_b101_ntf_control_fac = 3,
      nfc$p32_b101_ntf_search_domain = 4,

    nfc$p32_job_executing_user_id = 'UID',

    nfc$p32_min_param_length_a102 = 3,
    nfc$p32_max_param_length_a102 = 256,
    nfc$p32_min_param_length_a101 = 3,
    nfc$p32_max_param_length_a101 = 256,
    nfc$p32_min_param_length_b101 = 3,
    nfc$p32_max_param_length_b101 = 256;

?? OLDTITLE ??

*DECK DECK=NFC$PARAMETER_33_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_33_definitions' ??

{ nfc$parameter_33_definitions }

  CONST
    nfc$p33_min_param_length_a102 = 3,
    nfc$p33_max_param_length_a102 = 256,
    nfc$p33_min_param_length_a101 = 3,
    nfc$p33_max_param_length_a101 = 256,
    nfc$p33_min_param_length_b101 = 3,
    nfc$p33_max_param_length_b101 = 256,
    nfc$p33_min_param_length = 3,
    nfc$p33_max_param_length = 256,
    nfc$p33_text_delimiter = ';',
    nfc$p33_imp_wait_queue_value_wt = 'WT',
    nfc$p33_nos_ve_text_identifier = 'NV1',
    nfc$p33_nos_ve_text_id_length = 3;

?? OLDTITLE ??

*DECK DECK=NFC$PARAMETER_51_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_51_definitions' ??

{ nfc$parameter_51_definitions }

  CONST
    nfc$p51_min_param_length = 1,
    nfc$p51_max_param_length = 31;

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_52_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_52_definitions' ??

{ nfc$parameter_52_definitions }

  CONST
    nfc$p52_min_param_length = 1,
    nfc$p52_max_param_length = 27;

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_53_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_53_definitions' ??

{ nfc$parameter_53_definitions }

  CONST
    nfc$p53_min_param_length = 1,
    nfc$p53_max_param_length = 256;

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_54_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_54_definitions' ??

{ nfc$parameter_54_definitions }

  CONST
    nfc$p54_min_param_length = 1,
    nfc$p54_max_param_length = 256;

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_55_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_55_definitions' ??

{ nfc$parameter_55_definitions }

  CONST
    nfc$p55_min_param_length = 1,
    nfc$p55_max_param_length = 256;

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_58_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_58_definitions' ??

{ nfc$parameter_58_definitions }

  CONST
    nfc$p58_variant_size = 3,

    nfc$p58_b101_public_ios_id = 'CN0',
      nfc$p58_b101_public_params = 2,
      nfc$p58_b101_station = 1,
      nfc$p58_b101_pub_search_domain = 2,

    nfc$p58_b101_private_ios_id = 'CN1',
      nfc$p58_b101_private_params = 5,
      nfc$p58_b101_control_facility = 1,
      nfc$p58_b101_priv_search_domain = 2,
      nfc$p58_b101_op_user_name = 3,
      nfc$p58_b101_op_family = 4,
      nfc$p58_b101_op_community = 5,

    nfc$p58_b101_ntf_id = 'NTF',
      nfc$p58_b101_ntf_params = 4,
      nfc$p58_b101_remote_sys_name = 1,
      nfc$p58_b101_remote_sys_prot = 2,
      nfc$p58_b101_ntf_control_fac = 3,
      nfc$p58_b101_ntf_search_domain = 4,

    nfc$p58_min_param_size = 3,
    nfc$p58_max_param_size = 256;

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_59_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_59_definitions' ??

{ nfc$parameter_59_definitions }

  CONST
    nfc$p59_min_param_length = 2, { Minimum # of chars for param
    nfc$p59_max_param_length_a101 = 2, { Maximum # of chars in prot id
    nfc$p59_max_param_length_a102 = 2, { Maximum # of chars in prot id
    nfc$p59_max_param_length_b101 = 2, { Maximum # of chars in prot id
    nfc$p59_max_param_length = 2;

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_60_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_60_definitions' ??

{ nfc$parameter_60_definitions }

  CONST
    nfc$p60_min_param_len = 1, { Minimum # of chars for param
    nfc$p60_max_param_len_a101 = 31, { Maximum # of chars in prot id
    nfc$p60_max_param_len_a102 = 31, { Maximum # of chars in prot id
    nfc$p60_max_param_len_b101 = 31, { Maximum # of chars in prot id
    nfc$p60_max_param_length = 31;

?? OLDTITLE ??
*DECK DECK=NFC$PARAMETER_90_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_90_definitions' ??

{ nfc$parameter_90_definitions }

  CONST
    nfc$p90_min_param_length_a102 = nfc$min_param_size,
    nfc$p90_max_param_length_a102 = nfc$max_param_size,
    nfc$p90_min_param_length_a101 = nfc$min_param_size,
    nfc$p90_max_param_length_a101 = nfc$max_param_size,
    nfc$p90_min_param_length_b101 = nfc$min_param_size,
    nfc$p90_max_param_length_b101 = nfc$max_param_size;

*copyc nfc$parameter_definitions
?? OLDTITLE ??

*DECK DECK=NFC$PARAMETER_91_DEFINITIONS EXPAND=FALSE
?? newtitle := 'nfc$parameter_91_definitions' ??

{ nfc$parameter_91_definitions }

Const nfc$p91_min_param_length_a102      = nfc$min_param_size,
nfc$p91_max_param_length_a102      = nfc$max_param_size,
nfc$p91_min_param_length_a101      = nfc$min_param_size,
nfc$p91_max_param_length_a101      = nfc$max_param_size,
nfc$p91_min_param_length_b101      = nfc$min_param_size,
nfc$p91_max_param_length_b101      = nfc$max_param_size;

*copyc nfc$parameter_definitions
?? oldtitle ??

*DECK DECK=NFC$PARAMETER_92_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_92_definitions' ??

{ nfc$parameter_92_definitions }

  CONST
    nfc$p92_min_param_length_a102 = nfc$min_param_size,
    nfc$p92_max_param_length_a102 = nfc$max_param_size,
    nfc$p92_min_param_length_a101 = nfc$min_param_size,
    nfc$p92_max_param_length_a101 = nfc$max_param_size,
    nfc$p92_min_param_length_b101 = nfc$min_param_size,
    nfc$p92_max_param_length_b101 = nfc$max_param_size;

*copyc nfc$parameter_definitions
?? OLDTITLE ??

*DECK DECK=NFC$PARAMETER_93_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_93_definitions' ??

{ nfc$parameter_93_definitions }

  CONST
    nfc$p93_min_param_length_a102 = nfc$min_param_size,
    nfc$p93_max_param_length_a102 = nfc$max_param_size,
    nfc$p93_min_param_length_a101 = nfc$min_param_size,
    nfc$p93_max_param_length_a101 = nfc$max_param_size,
    nfc$p93_min_param_length_b101 = nfc$min_param_size,
    nfc$p93_max_param_length_b101 = nfc$max_param_size;

*copyc nfc$parameter_definitions
?? OLDTITLE ??

*DECK DECK=NFC$PARAMETER_94_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_94_definitions' ??

{ nfc$parameter_94_definitions }

  CONST
    nfc$p94_min_param_length_a102 = nfc$min_param_size,
    nfc$p94_max_param_length_a102 = nfc$max_param_size,
    nfc$p94_min_param_length_a101 = nfc$min_param_size,
    nfc$p94_max_param_length_a101 = nfc$max_param_size,
    nfc$p94_min_param_length_b101 = nfc$min_param_size,
    nfc$p94_max_param_length_b101 = nfc$max_param_size;

*copyc nfc$parameter_definitions
?? OLDTITLE ??

*DECK DECK=NFC$PARAMETER_95_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_95_definitions' ??

{ nfc$parameter_95_definitions }

  CONST
    nfc$p95_min_param_length_a102 = nfc$min_param_size,
    nfc$p95_max_param_length_a102 = nfc$max_param_size,
    nfc$p95_min_param_length_a101 = nfc$min_param_size,
    nfc$p95_max_param_length_a101 = nfc$max_param_size,
    nfc$p95_min_param_length_b101 = nfc$min_param_size,
    nfc$p95_max_param_length_b101 = nfc$max_param_size;

*copyc nfc$parameter_definitions
?? OLDTITLE ??

*DECK DECK=NFC$PARAMETER_96_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_96_definitions' ??

{ nfc$parameter_96_definitions }

  CONST
    nfc$p96_min_param_length_a102 = nfc$min_param_size,
    nfc$p96_max_param_length_a102 = nfc$max_param_size,
    nfc$p96_min_param_length_a101 = nfc$min_param_size,
    nfc$p96_max_param_length_a101 = nfc$max_param_size,
    nfc$p96_min_param_length_b101 = nfc$min_param_size,
    nfc$p96_max_param_length_b101 = nfc$max_param_size;

*copyc nfc$parameter_definitions
?? OLDTITLE ??

*DECK DECK=NFC$PARAMETER_97_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_97_definitions' ??

{ nfc$parameter_97_definitions }

  CONST
    nfc$p97_min_param_length_a102 = nfc$min_param_size,
    nfc$p97_max_param_length_a102 = nfc$max_param_size,
    nfc$p97_min_param_length_a101 = nfc$min_param_size,
    nfc$p97_max_param_length_a101 = nfc$max_param_size,
    nfc$p97_min_param_length_b101 = nfc$min_param_size,
    nfc$p97_max_param_length_b101 = nfc$max_param_size;

*copyc nfc$parameter_definitions
?? OLDTITLE ??

*DECK DECK=NFC$PARAMETER_98_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_98_definitions' ??

{ nfc$parameter_98_definitions }

  CONST
    nfc$p98_min_param_length_a102 = nfc$min_param_size,
    nfc$p98_max_param_length_a102 = nfc$max_param_size,
    nfc$p98_min_param_length_a101 = nfc$min_param_size,
    nfc$p98_max_param_length_a101 = nfc$max_param_size,
    nfc$p98_min_param_length_b101 = nfc$min_param_size,
    nfc$p98_max_param_length_b101 = nfc$max_param_size;

*copyc nfc$parameter_definitions
?? OLDTITLE ??

*DECK DECK=NFC$PARAMETER_99_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_99_definitions' ??

{ nfc$parameter_99_definitions }

  CONST
    nfc$p99_min_param_length_a102 = nfc$min_param_size,
    nfc$p99_max_param_length_a102 = nfc$max_param_size,
    nfc$p99_min_param_length_a101 = nfc$min_param_size,
    nfc$p99_max_param_length_a101 = nfc$max_param_size,
    nfc$p99_min_param_length_b101 = nfc$min_param_size,
    nfc$p99_max_param_length_b101 = nfc$max_param_size;

*copyc nfc$parameter_definitions
?? OLDTITLE ??

*DECK DECK=NFC$PARAMETER_DEFINITIONS EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_definitions' ??

{ nfc$parameter_definitions }

  CONST
    nfc$param_id_pos = 1, { Position of Id in param string
    nfc$num_param_id_digits = 2, { # of parameters in a param header }
    nfc$param_qual_pos = nfc$num_param_id_digits + nfc$param_id_pos,
    nfc$num_param_qual_digits = 1, { # of digits in a parameter header }
    nfc$num_param_size_digits = 3, { # of digits in a parameter length }
    nfc$param_size_pos = nfc$param_qual_pos + nfc$num_param_qual_digits,
    nfc$param_header_size = nfc$num_param_id_digits +
          nfc$num_param_qual_digits + nfc$num_param_size_digits,
    nfc$param_value_pos = nfc$param_header_size + 1,
    nfc$max_parameter_count = 99, { Maximum # params in pdu }
    nfc$min_parameter_count = 00, { Maximum # params in pdu }
    nfc$min_param_size = 000, { Minimum length of a parameter }
    nfc$max_param_size = 999, { Maximum length of a parameter }
    nfc$max_qualified_param_size = nfc$param_header_size + nfc$max_param_size,
    nfc$parameter_fill_char = '0', { Fill length with...}
    nfc$parameter_length_radix = 10, { Humans like base 10 }

    nfc$select_parameter = 'S',
    nfc$ignore_parameter = 'I',
    nfc$modify_parameter = 'M',

    nfc$s_protocol_id = '00',
    nfc$s_maximum_file_length = '01',
    nfc$s_transfer_id = '02',
    nfc$s_facilities = '03',
    nfc$s_state_of_transfer = '04',
    nfc$s_user_text_directive = '05',
    nfc$s_file_length = '06',
    nfc$s_operator_message = '07',
    nfc$s_user_message = '08',
    nfc$s_account_message = '09',
    nfc$s_error_log_message = '10',
    nfc$s_special_options = '11',
    nfc$s_max_block_size = '12',
    nfc$s_accounting_limit = '13',
    nfc$s_file_name = '16',
    nfc$s_file_disposition = '17',
    nfc$s_acknowledgment_window = '18',
    nfc$s_initial_checkmark = '19',
    nfc$s_minimum_timeout_interval = '20',
    nfc$s_mode_of_access = '21',
    nfc$s_host_type = '22',
    nfc$s_transfer_phase_attribute = '23',
    nfc$s_source_lid = '24',
    nfc$s_transfer_lid = '25',
    nfc$s_job_name = '26',
    nfc$s_physical_id = '27',
    nfc$s_destination_host_type = '28',
    nfc$s_echo = '29',
    nfc$s_attribute_continued = '30',
    nfc$s_data_declaration = '31',
    nfc$s_system_routing_text = '32',
    nfc$s_implicit_routing_text = '33',
    nfc$s_user_file_name = '51',
    nfc$s_banner_date_and_time = '52',
    nfc$s_banner_routing_text = '53',
    nfc$s_user_banner_text = '54',
    nfc$s_installation_banner_text = '55',
    nfc$s_reposition_output_params = '56',
    nfc$s_current_file_position = '57',
    nfc$s_output_file_destination = '58',
    nfc$s_vertical_print_density = '59',
    nfc$s_vfu_load_procedure = '60',
    nfc$s_reserved_for_site_90 = '90',
    nfc$s_reserved_for_site_91 = '91',
    nfc$s_reserved_for_site_92 = '92',
    nfc$s_reserved_for_site_93 = '93',
    nfc$s_reserved_for_site_94 = '94',
    nfc$s_reserved_for_site_95 = '95',
    nfc$s_reserved_for_site_96 = '96',
    nfc$s_reserved_for_site_97 = '97',
    nfc$s_reserved_for_site_98 = '98',
    nfc$s_reserved_for_site_99 = '99',

    nfc$i_protocol_id = 00,
    nfc$i_maximum_file_length = 01,
    nfc$i_transfer_id = 02,
    nfc$i_facilities = 03,
    nfc$i_state_of_transfer = 04,
    nfc$i_user_text_directive = 05,
    nfc$i_file_length = 06,
    nfc$i_operator_message = 07,
    nfc$i_user_message = 08,
    nfc$i_account_message = 09,
    nfc$i_error_log_message = 10,
    nfc$i_special_options = 11,
    nfc$i_max_block_size = 12,
    nfc$i_accounting_limit = 13,
    nfc$i_file_name = 16,
    nfc$i_file_disposition = 17,
    nfc$i_acknowledgment_window = 18,
    nfc$i_initial_checkmark = 19,
    nfc$i_minimum_timeout_interval = 20,
    nfc$i_mode_of_access = 21,
    nfc$i_host_type = 22,
    nfc$i_transfer_phase_attribute = 23,
    nfc$i_source_lid = 24,
    nfc$i_transfer_lid = 25,
    nfc$i_job_name = 26,
    nfc$i_physical_id = 27,
    nfc$i_destination_host_type = 28,
    nfc$i_echo = 29,
    nfc$i_attribute_continued = 30,
    nfc$i_data_declaration = 31,
    nfc$i_system_routing_text = 32,
    nfc$i_implicit_routing_text = 33,
    nfc$i_user_file_name = 51,
    nfc$i_banner_date_and_time = 52,
    nfc$i_banner_routing_text = 53,
    nfc$i_user_banner_text = 54,
    nfc$i_installation_banner_text = 55,
    nfc$i_reposition_output_params = 56,
    nfc$i_current_file_position = 57,
    nfc$i_output_file_destination = 58,
    nfc$i_vertical_print_density = 59,
    nfc$i_vfu_load_procedure = 60,
    nfc$i_reserved_for_site_90 = 90,
    nfc$i_reserved_for_site_91 = 91,
    nfc$i_reserved_for_site_92 = 92,
    nfc$i_reserved_for_site_93 = 93,
    nfc$i_reserved_for_site_94 = 94,
    nfc$i_reserved_for_site_95 = 95,
    nfc$i_reserved_for_site_96 = 96,
    nfc$i_reserved_for_site_97 = 97,
    nfc$i_reserved_for_site_98 = 98,
    nfc$i_reserved_for_site_99 = 99;

?? OLDTITLE ??
*DECK DECK=NFC$QTF_NAME_CONSTANTS EXPAND=FALSE
CONST
  nfc$namve_service_name    = 'OSA$QUEUE_TRANSFER_SERVER      ',
  nfc$qtf_namve_client_name = 'OSA$QUEUE_TRANSFER_CLIENT      ',
  nfc$qtf_rhfam_client_name = 'QTF    ',
  nfc$qtfi_task_name        = 'NFP$QTF_INITIATOR              ',
  nfc$rhfam_service_name    = 'QTFS   ';
*DECK DECK=NFC$SF_DIRECTIVE_COMMAND_NAMES EXPAND=FALSE

  CONST
    nfc$cmd_def_appl_name_switch = 'DEFINE_APPLICATION_NAME_SWITCH',
    nfc$cmd_def_appl_name_length = 30,
    nfc$cmd_def_destination_group = 'DEFINE_DESTINATION_GROUP',
    nfc$cmd_def_dest_group_length = 24,
    nfc$cmd_def_source_name_switch = 'DEFINE_SOURCE_NAME_SWITCH',
    nfc$cmd_def_source_name_length = 25,
    nfc$cmd_def_target_name_switch = 'DEFINE_DESTINATION_NAME_SWITCH',
    nfc$cmd_def_target_name_length = 30,
    nfc$cmd_quit = 'QUIT',
    nfc$cmd_quit_length = 4;
*DECK DECK=NFC$TIMER_VALUES EXPAND=FALSE
  CONST
    nfc$half_minute = 30000000,      {    30,000,000 microseconds }
    nfc$one_minute = 60000000,       {    60,000,000 microseconds }
    nfc$two_minutes = 120000000,     {   120,000,000 microseconds }
    nfc$four_minutes = 240000000,    {   240,000,000 microseconds }
    nfc$eight_minutes = 480000000,   {   480,000,000 microseconds }
    nfc$sixteen_minutes = 960000000, {   960,000,000 microseconds }
    nfc$thirty_minutes = 1800000000; { 1,800,000,000 microseconds }

*DECK DECK=NFC$WAIT_LIST_LIMIT EXPAND=FALSE
  CONST
    nfc$wait_list_limit = 100;
*DECK DECK=NFD$SOU_INTERTASK_COMMUNICATION EXPAND=TRUE

  TYPE
    nft$sou_intertask_request = RECORD
      CASE request: (nfc$sou_start_task, nfc$sou_end_task, nfc$sou_hold, nfc$sou_resume) OF
      = nfc$sou_start_task =
        file: ost$name,
      CASEND,
    RECEND;

  TYPE
    nft$sou_intertask_response = RECORD
      CASE response: (nfc$sou_complete, nfc$sou_reserved_response_1) OF
      = nfc$sou_complete =
        ,
      CASEND,
    RECEND;
*DECK DECK=NFD$TRANSFER_DECLARATIONS EXPAND=FALSE

  CONST
    initial_wait_time = 1000,
    data_header_length = 6,
    command_block_size = 14,
    batch_command_size = 2043,
    max_label_size = 65535,
    starting_mark = '0000',

    {data phase commands}
    ss_command = '30',
    ms_command = '31',
    es_command = '32',
    rr_command = '33',
    mr_command = '34',
    qr_command = '35',
    er_command = '36',
    sr_command = '37',
    pr_command = '38',
    ps_command = '39',

    {condition_codes}
    ok_condition = '0',
    ok = '0000',
    hold_condition = '1',
    temp_hold = '0010',
    pm_hold = '0011',    {pm message}
    opes_hold = '0012',  {I/O station operator}
    err_condition = '2',
    receive_err_retry = '0020',
    receive_err_no_retry = '0021',
    receive_detected_prot_err = '0022',
    receive_noGO = '0023',
    appl_termination_retry = '0025',
    appl_termination_no_retry = '0026',
    send_err_retry = '0028',
    send_err_no_retry = '0029',
    send_detected_prot_err = '002A',
    send_noGO = '002B',

    {A-A protocol data_block_clarifier codes}
    nfc$dbc_no_mark = 00(16),
    nfc$dbc_eor = 20(16),
    nfc$dbc_eof = 2f(16),
    nfc$dbc_eoi_bit = 40(16),
    nfc$dbc_ve_label = 8f(16);

  TYPE
    batch_data_header = packed record
      data_block_clarifier: 0 .. 0ff(16),
      byte_count: 0 .. 0ffff(16),
      application_block_number: 0 .. 0ffff(16),
      reserved: 0 .. 01f(16),
      unused_bit_count: 0 .. 07(16),
    recend,
    data_phase_command = record
      command_id: string(2),
      parameter_count: string(2),
      parameter_prefix: string(6),
      condition_code: string(4),
    recend,
    transfer_params = record
      connection_fid: amt$file_identifier,
      file_name: amt$local_file_name,
      facilities: nft$facility_group,
      transfer_mode: nft$transfer_modes,
      block_size: nft$block_size,
      min_timeout: nft$timeout,
      protocol_version: nft$parameter_00_values,
      network_type: nft$network_type,
      validation_ring: ost$valid_ring,
      transfer_status: ost$status,
      status: ost$status,
    recend,
    progress_states = (not_started, label_in_progress, label_complete,
      file_in_progress, transfer_complete),
    transfer_progress = record
      general_position: progress_states,
      file_byte_address: ^SEQ (*),
      current_byte_address: ^SEQ (*),
      current_byte_count: 0 .. 7fffffff(16),
      remaining_data: 0 .. 7fffffff(16),
    recend;
*DECK DECK=NFE$BATCH_TRANSFER_FACILITY EXPAND=TRUE
?? NEWTITLE := '  nfe$batch_transfer_facility', EJECT ??                                                      
                                                                                                              
*copyc nfc$abnormal_conditions                                                                                
                                                                                                              
?? FMT (FORMAT := OFF) ??                                                                                     
  CONST                                                                                                       
    nfc$btf_base_status_condition = nfc$min_status_condition + 125;                                           
?? SKIP := 2 ??                                                                                               
  CONST                                                                                                       
    nfe$non_matching_device =          nfc$btf_base_status_condition + 0;                                     
    {E The requested station/ device pair does not match the connected device.}                               
                                                                                                              
?? FMT (FORMAT:=ON) ??                                                                                        
                                                                                                              
?? OLDTITLE ??                                                                                                
*DECK DECK=NFE$BATCH_TRANSFER_SERVICES EXPAND=TRUE
?? NEWTITLE := '  nfe$batch_transfer_services nnn000 to nnn049', EJECT ??                                     
                                                                                                              
*copyc nfc$abnormal_conditions                                                                                
                                                                                                              
?? FMT (FORMAT := OFF) ??                                                                                     
                                                                                                              
  CONST                                                                                                       
                                                                                                              
    nfe$job_file_error =               nfc$min_status_condition + 0,                                          
    {E no user directives supplied for job file.}                                                             
                                                                                                              
    nfe$nil_procedure_pointer =        nfc$min_status_condition + 1,                                          
    {E pointer to procedure = NIL.}                                                                           
                                                                                                              
    nfe$required_parameter_missing =   nfc$min_status_condition + 2,                                          
    {E The +p1 parameter is required for the +p2 command.}                                                    
                                                                                                              
    nfe$invalid_command_code =         nfc$min_status_condition + 3,                                          
    {E invalid command code.}                                                                                 
                                                                                                              
    nfe$service_not_found =       nfc$min_status_condition      + 4,                                          
    {E Service is not established with location +P.}                                                          
                                                                                                              
    nfe$unknown_data_format =          nfc$min_status_condition + 5,                                          
    {E unknown data format declared.}                                                                         
                                                                                                              
    nfe$unrecognizable_parameter =     nfc$min_status_condition + 6,                                          
    {E parameter code +P is unknown to the A to A protocol}                                                   
                                                                                                              
    nfe$unrecognizable_qualifier =     nfc$min_status_condition + 7,                                          
    {E qualifier found is unknown to the A to A protocol}                                                     
                                                                                                              
    nfe$non_hex_character =            nfc$min_status_condition + 8,                                          
    {E A non-hexadecimal character representation discovered when                                             
    { decoding string.}                                                                                       
                                                                                                              
    nfe$qualifier_error =              nfc$min_status_condition + 9,                                          
    {E +P1 is an illegal qualifier for the +P2 parameter on the +P3 command.}                                 
                                                                                                              
    nfe$prohibited_parameter =         nfc$min_status_condition + 10,                                         
    {E +P1 is an prohibited parameter for the +P2 command.}                                                   
                                                                                                              
    nfe$parameter_length_error =       nfc$min_status_condition + 11,                                         
    {E The +P1 command parameter of +p2 does not correspond to the size                                       
    { limits of the protocol.}                                                                                
                                                                                                              
    nfe$unknown_facility_option =      nfc$min_status_condition + 12,                                         
    {E The +P1 facility option is undefined in the A to A protocol                                            
    { specification.}                                                                                         
                                                                                                              
    nfe$unknown_transfer_state =       nfc$min_status_condition + 13,                                         
    {E General state +P1, detail state +P2 is undefined in the A to                                           
    { A protocol specification.}                                                                              
                                                                                                              
    nfe$unknown_host_type =            nfc$min_status_condition + 14,                                         
    {E The +P host type is undefined in the A to A specification.}                                            
                                                                                                              
    nfe$unknown_protocol =             nfc$min_status_condition + 15,                                         
    {E The +P protocol identifier is undefined in the A to A specification.}                                  
                                                                                                              
    nfe$illegal_null_transfer =        nfc$min_status_condition + 16,                                         
    {E Illegal attempt to enter the transfer phase when a file transfer will                                  
    { not occur.}                                                                                             
                                                                                                              
    nfe$illegal_event =                nfc$min_status_condition + 17,                                         
    {E Illegal event received on call to procedure +P.}                                                       
                                                                                                              
    nfe$bts_internal_error =           nfc$min_status_condition + 18,                                         
    {E Procedure +P1 abnormal condition +P2.}                                                                 
                                                                                                              
    nfe$param_data_size_exceeded =     nfc$min_status_condition + 19,                                         
    {E The +P1 command parameter length exceeds the maximum defined for the                                   
    { protocol.}                                                                                              
                                                                                                              
    nfe$incompatible_address_kind =    nfc$min_status_condition + 20,                                         
    {E The address returned from title translation is of the wrong kind.}                                     
                                                                                                              
    nfe$invalid_protocol_negot = nfc$min_status_condition + 21,                                               
    {E The negotiation to +P was invalid for this transfer }                                                  
                                                                                                              
    nfe$invalid_protocol_value       = nfc$min_status_condition + 22,                                         
    {E The protocol identifier +P1 is unknown to this application }                                           
                                                                                                              
    nfe$invalid_p26_value            = nfc$min_status_condition + 23,                                         
    {E The character +P1 is invalid for protocol parameter 26 }                                               
                                                                                                              
    nfe$recoverable_connect       = nfc$min_status_condition + 25,                                            
    {E The attempt to connect to location +P failed, but is retryable}                                        
                                                                                                              
    nfe$no_available_am           = nfc$min_status_condition + 26,                                            
    {E The PTFS boot found no available access method}                                                        
                                                                                                              
    nfe$user_job_term_prematurely = nfc$min_status_condition + 27,                                            
    {E The user PTFS job terminated prematurely}                                                              
                                                                                                              
    nfe$user_job_switch_timeout = nfc$min_status_condition + 28,                                              
    {E The user PTFS job timed out before obtaining connect}                                                  
                                                                                                              
    nfe$remote_system_error_see_jl = nfc$min_status_condition + 29,                                           
    {E An error occurred on the remote system, see job log for details}                                       
                                                                                                              
    nfe$bad_or_missing_login_in_job = nfc$min_status_condition + 30;                                          
    {E Login command is either missing or incorrect}                                                          
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '  nfe$bts_condition_codes nnn050 to nnn099', EJECT ??                                         
{*****************************************************************************}                               
{                                                                             }                               
{    The following status conditions provide a direct mapping of the state    }                               
{    of transfer command parameter (04) and the transfer status. This is      }                               
{    used primarily when the remote application is non-NOS/VE. For NOS/VE to  }                               
{    NOS/VE transfers, the special options parameter (12) provides the final  }                               
{    status of the transfer. In all other cases the state of transfer must    }                               
{    provide the same function.                                               }                               
{                                                                             }                               
{    The nfe$transfer_state_abnormal status condition is special cased. It    }                               
{    is only used when the remote application is NOS/VE and is used as an     }                               
{    indication or temporary status during the application dialogue. It       }                               
{    can be overwritten by any other status condition;                        }                               
{                                                                             }                               
{*****************************************************************************}                               
                                                                                                              
                                                                                                              
  CONST                                                                                                       
    nfe$unspecific_transfer =          nfc$min_status_condition + 50,                                         
    {E Unspecific transfer.}                                                                                  
                                                                                                              
    nfe$transfer_rejected_message =    nfc$min_status_condition + 51,                                         
    {E Transfer rejected.}                                                                                    
                                                                                                              
    nfe$unacceptable_attributes =      nfc$min_status_condition + 52,                                         
    {E Unacceptable transfer control attribute settings.}                                                     
                                                                                                              
    nfe$unspecific_file_store =        nfc$min_status_condition + 53,                                         
    {E Unspecific file store.}                                                                                
                                                                                                              
    nfe$file_not_found =               nfc$min_status_condition + 54,                                         
    {E File not found or does not exist.}                                                                     
                                                                                                              
    nfe$no_file_access =               nfc$min_status_condition + 55,                                         
    {E No access to file quoted.}                                                                             
                                                                                                              
    nfe$wrong_file_type =              nfc$min_status_condition + 56,                                         
    {E Wrong file type.}                                                                                      
                                                                                                              
    nfe$file_unavailable =             nfc$min_status_condition + 57,                                         
    {E File not available or off_line.}                                                                       
                                                                                                              
    nfe$invalid_user =                 nfc$min_status_condition + 58,                                         
    {E Username unknown.}                                                                                     
                                                                                                              
    nfe$invalid_password =             nfc$min_status_condition + 59,                                         
    {E Username and/or password not quoted or quoted incorrectly.}                                            
                                                                                                              
    nfe$invalid_account =              nfc$min_status_condition + 60,                                         
    {E Account unknown.}                                                                                      
                                                                                                              
    nfe$invalid_account_pw =           nfc$min_status_condition + 61,                                         
    {E Account and/or password not quoted or quoted incorrectly.}                                             
                                                                                                              
    nfe$no_money =                     nfc$min_status_condition + 62,                                         
    {E Account dollar limit exceeded.}                                                                        
                                                                                                              
    nfe$file_too_large =               nfc$min_status_condition + 63,                                         
    {E File size limit exceeded.}                                                                             
                                                                                                              
    nfe$wrong_device =                 nfc$min_status_condition + 64,                                         
    {E Output device unknown or unavailable.}                                                                 
                                                                                                              
    nfe$satisfactory_and_complete =    nfc$min_status_condition + 65,                                         
    {E Satisfactory and complete.}                                                                            
                                                                                                              
    nfe$terminate_transfer_message =   nfc$min_status_condition + 66,                                         
    {E Terminated - refer to message text.}                                                                   
                                                                                                              
    nfe$accounting_limit_exceeded =    nfc$min_status_condition + 67,                                         
    {E Accounting limit exceeded - discard file.}                                                             
                                                                                                              
    nfe$discard_input_file =           nfc$min_status_condition + 68,                                         
    {E Private I/O station operator logout - discard input file.}                                             
                                                                                                              
    nfe$requeue_output_file =          nfc$min_status_condition + 69,                                         
    {E Private I/O station operator logout - requeue output file.}                                            
                                                                                                              
    nfe$requeue_at_current_priority =  nfc$min_status_condition + 70,                                         
    {E Private I/O station operator request - requeue at current priority.}                                   
                                                                                                              
    nfe$requeue_not_eligible_file =    nfc$min_status_condition + 71,                                         
    {E Private I/O station operator request - requeue at not eligible for                                     
    { transfer priority.}                                                                                     
                                                                                                              
    nfe$requeue_at_new_priority =      nfc$min_status_condition + 72,                                         
    {E Private I/O station operator request - requeue at specified priority.}                                 
                                                                                                              
    nfe$pm_message_time_out =          nfc$min_status_condition + 73,                                         
    {E PM message time out - requeue at not eligible for transfer priority.}                                  
                                                                                                              
    nfe$station_operator_terminate =   nfc$min_status_condition + 74,                                         
    {E Private I/O station operator terminate request - discard file.}                                        
                                                                                                              
    nfe$satisfactory_and_incomplete =  nfc$min_status_condition + 75,                                         
    {E Satisfactory and complete - No retry required.}                                                        
                                                                                                              
    nfe$receiver_problem_retry =       nfc$min_status_condition + 76,                                         
    {E Receiver problems - retry possible.}                                                                   
                                                                                                              
    nfe$receiver_problem_no_retry =    nfc$min_status_condition + 77,                                         
    {E Receiver problems - no retry possible.}                                                                
                                                                                                              
    nfe$sender_problem_retry =         nfc$min_status_condition + 78,                                         
    {E Sender problems - Retry possible.}                                                                     
                                                                                                              
    nfe$sender_problem_no_retry =      nfc$min_status_condition + 79,                                         
    {E Sender problems - No retry possible.}                                                                  
                                                                                                              
    nfe$application_time_out =         nfc$min_status_condition + 80,                                         
    {E Application time limit exceeded.}                                                                      
                                                                                                              
    nfe$protocol_anomaly =             nfc$min_status_condition + 81,                                         
    {E Irrecoverable protocol anomaly.}                                                                       
                                                                                                              
    nfe$invalid_param_count =            nfc$min_status_condition + 82,                                       
    {E Invalid command parameter count +P .}                                                                  
                                                                                                              
    nfe$invalid_protocol_command =       nfc$min_status_condition + 83,                                       
    {E Invalid protocol command +P .}                                                                         
                                                                                                              
    nfe$invalid_p06_value =              nfc$min_status_condition + 84,                                       
    {E Invalid protocol parameter 06, file size, +P .}                                                        
                                                                                                              
    nfe$invalid_p12_value   =            nfc$min_status_condition + 85,                                       
    {E Invalid command parameter 12, max xfer block size +P .}                                                
                                                                                                              
    nfe$invalid_p20_value   =            nfc$min_status_condition + 86,                                       
    {E Invalid command parameter 20, min time out +P .}                                                       
                                                                                                              
    nfe$invalid_p21_value   =            nfc$min_status_condition + 87,                                       
    {E Invalid command parameter 21 mode +P .}                                                                
                                                                                                              
    nfe$invalid_p21_spec    =            nfc$min_status_condition + 88,                                       
    {E Invalid command parameter 21 specification +P .}                                                       
                                                                                                              
    nfe$invalid_p22_value   =            nfc$min_status_condition + 89,                                       
    {E Invalid command parameter 22, host type +P .}                                                          
                                                                                                              
    nfe$user_interrupt_ignored=          nfc$min_status_condition + 90,                                       
    {W Transfer in progress, user interrupt ignored.}                                                         
                                                                                                              
    nfe$dislike_parameter     =        nfc$min_status_condition + 91,                                         
    {E protocol error +P.}                                                                                    
                                                                                                              
    nfe$transfer_failed_recovering =     nfc$min_status_condition + 92,                                       
    {E transfer failed, begin retry.}                                                                         
                                                                                                              
    nfe$invalid_p17_value         =      nfc$min_status_condition + 93,                                       
    {E Invalid command parameter 17, disposition code +P .}                                                   
                                                                                                              
    nfe$invalid_p18_value         =      nfc$min_status_condition + 94,                                       
    {E Invalid command parameter 18, acknowledgment window +P .}                                              
                                                                                                              
    nfe$invalid_p19_value         =      nfc$min_status_condition + 95;                                       
    {E Invalid command parameter 19, initial restart checkmark code +P .}                                     
                                                                                                              
?? FMT (FORMAT:=ON) ??                                                                                        
?? OLDTITLE ??                                                                                                
*DECK DECK=NFE$COMMON_TASK_COMMUNICATION EXPAND=TRUE
?? NEWTITLE := '  nfe$common_task_communicattion', EJECT ??                                                   
                                                                                                              
*copyc nfc$abnormal_conditions                                                                                
                                                                                                              
?? FMT (FORMAT := OFF) ??                                                                                     
  CONST                                                                                                       
    nfc$ctc_base_status_condition = nfc$min_status_condition + 150;                                           
?? SKIP := 2 ??                                                                                               
  CONST                                                                                                       
    nfe$task_not_responding =          nfc$ctc_base_status_condition + 0,                                     
    {E Asynchronous task not responding.}                                                                     
                                                                                                              
    nfe$async_task_timeout =           nfc$ctc_base_status_condition + 1,                                     
    {E Asynchronous task timeout.}                                                                            
                                                                                                              
    nfe$redundant_begin_task =         nfc$ctc_base_status_condition + 2,                                     
    {E Redundant NFP$BEGIN_ASYNCHRONOUS_TASK.}                                                                
                                                                                                              
    nfe$bad_message_discarded =        nfc$ctc_base_status_condition + 3,                                     
    {E Bad message discarded.}                                                                                
                                                                                                              
    nfe$activity_pending =             nfc$ctc_base_status_condition + 4,                                     
    {E Activity pending.}                                                                                     
                                                                                                              
    nfe$locked_by_another_task =       nfc$ctc_base_status_condition + 5,                                     
    {E Locked by another task.}                                                                               
                                                                                                              
    nfe$module_not_initialized =       nfc$ctc_base_status_condition + 6,                                     
    {E Module not initialized.}                                                                               
                                                                                                              
    nfe$task_not_active =              nfc$ctc_base_status_condition + 7,                                     
    {E Task not active.}                                                                                      
                                                                                                              
    nfe$task_not_found =               nfc$ctc_base_status_condition + 8,                                     
    {E Task not found in directory.}                                                                          
                                                                                                              
    nfe$redundant_initialize_seg =     nfc$ctc_base_status_condition + 9,                                     
    {E Shared segment has already been initialized.}                                                          
                                                                                                              
    nfe$allocation_failure =           nfc$ctc_base_status_condition + 10;                                    
    {E Attempt to allocate space in shared heap yielded nil pointer.}                                         
                                                                                                              
?? FMT (FORMAT:=ON) ??                                                                                        
                                                                                                              
?? OLDTITLE ??                                                                                                
*DECK DECK=NFE$DRJE_CONDITION_CODES EXPAND=FALSE
?? NEWTITLE := 'nfe$drje_condition_codes:  1400 .. 1499', EJECT ??
*copyc nfc$abnormal_conditions
?? FMT (FORMAT := OFF) ??

  CONST
    nfc$min_drje_condition_code     = nfc$min_ecc + 1400,
    nfc$max_drje_condition_code     = nfc$min_ecc + 1499;

  CONST
    nfe$drje_insufficient_memory    = nfc$min_drje_condition_code + 0,
    {E DRJE unable to ALLOCATE required space in the default heap.}

    nfe$drje_logic_error            = nfc$min_drje_condition_code + 1,
    {E DRJE internal logic error.}

    nfe$drje_lost_scfs_connection   = nfc$min_drje_condition_code + 2,
    {E DRJE lost its network connection to SCFS +P1.}

    nfe$drje_scfs_rsn_missing       = nfc$min_drje_condition_code + 20,
    {E The remote system name +P is not in the NTF system list used by SCFS.}

    nfe$drje_inconsistent_rsns      = nfc$min_drje_condition_code + 21,
    {E Required remote system names are missing from the NTF system list}
    { used by SCFS.}

    nfe$drje_already_active         = nfc$min_drje_condition_code + 70,
    {E DRJE is already active for control facility +P.}

    nfe$drje_not_active             = nfc$min_drje_condition_code + 71,
    {E DRJE is not active for control facility +P.}

    nfe$drje_cf_errors              = nfc$min_drje_condition_code + 80,
    {E Errors encountered in DRJE configuration file.  See error file: +F.}

    nfe$drje_cf_max_cmd_exceeded    = nfc$min_drje_condition_code + 81,
    {E Command length exceeds 350 characters.}

    nfe$drje_cf_max_lines_exceeded  = nfc$min_drje_condition_code + 82,
    {E Continued command exceeds 10 lines.}

    nfe$drje_cf_unexpected_eoi      = nfc$min_drje_condition_code + 83,
    {E EOI encountered during line continuation.}

    nfe$drje_cf_no_hosts_configured = nfc$min_drje_condition_code + 84,
    {E The DRJE configuration file contains no remote host definitions.}

    nfe$drje_cf_no_lines_configured = nfc$min_drje_condition_code + 85,
    {E The DRJE configuration file contains no managed line definitions.}

    nfe$drje_cf_duplicate_host      = nfc$min_drje_condition_code + 86,
    {E Remote host +P previously defined.}

    nfe$drje_cf_duplicate_line      = nfc$min_drje_condition_code + 87,
    {E Managed line +P previously defined.}

    nfe$drje_cf_line_too_long       = nfc$min_drje_condition_code + 88,
    {E Line length exceeds 256 characters.}

    nfe$drje_cf_multiple_defdp_cmds = nfc$min_drje_condition_code + 89,
    {E More than one DEFINE_DRJE_PARAMETERS command in configuration file.}

    nfe$drje_cf_line_name_too_long  = nfc$min_drje_condition_code + 90,
    {E Line name +P exceeds 18 characters when the possibility exists}
    { that SIGNON or SIGNOFF jobs may be transferred over the line.}

    nfe$drje_cf_unmatched_line_qual = nfc$min_drje_condition_code + 91,
    {E Managed line +P1 is defined with qualifier +P2, but no remote host}
    { is defined with this qualifier.}

    nfe$drje_cf_unmatched_host_qual = nfc$min_drje_condition_code + 92;
    {E Remote host +P1 is defined with qualifier +P2, but no managed line}
    { is defined with this qualifier.}

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NFE$EXCEPTION_CONDITION_CODES EXPAND=TRUE
*copyc nfc$abnormal_conditions

{ BATCH_TRANSFER_SERVICES:  00 - 49
*copyc nfe$batch_transfer_services

{ FILE_TRANSFER_BOOT:  100.
*copyc nfe$file_transfer_boot

{ BATCH_TRANSFER_FACILITY:  125.
*copyc nfe$batch_transfer_facility

{ COMMON_TASK_COMMUNICATION:  150 -
*copyc nfe$common_task_communication

{ FTS_CONDITION_CODES:  200 -
*copyc nfe$fts_condition_codes

{ MANAGE_STORE_FORWARD_NETWRK:  600 -
*copyc nfe$manage_store_forward_netwrk

{ NTF_UTILITY_CONDITIONS:  1300 - 1399
*copyc nfe$ntf_utility_conditions

{ PTF_CONDITION_CODES:  300 -
*copyc nfe$ptf_condition_codes

{ QUEUE_FILE_TRANSFER_FAC:  500 -
*copyc nfe$queue_file_transfer_fac

{ SOU_CONDITION_CODES:  350 -
*copyc nfe$sou_condition_codes

{ STATUS_CONTROL_FAC_SERVER:  400 -
*copyc nfe$status_control_fac_server

{ XFER_APPL_ERROR_CODES:  450 - 475
*copyc nfe$xfer_appl_error_codes

{ DRJE_CONDITION_CODES:  1400 - 1499
*copyc nfe$drje_condition_codes

{ OSIAM:  1500 - 1699
{ (on XTF library)

{ FTAM Utility:  1700 - 1899
{ (on FTAM library)

{ FTAM Interfaces:  1900 - 1999
{ (on FTAM library)

{ FTAM Responder:  2000 -
{ (on FTAM library)

*DECK DECK=NFE$FILE_TRANSFER_BOOT EXPAND=TRUE
?? NEWTITLE := 'nfe$file_transfer_boot', EJECT ??                                                             
                                                                                                              
*copyc nfc$abnormal_conditions                                                                                
                                                                                                              
?? FMT (FORMAT := OFF) ??                                                                                     
  CONST                                                                                                       
    nfc$boot_base_status_condition = nfc$min_status_condition + 100;                                          
?? SKIP := 2 ??                                                                                               
  CONST                                                                                                       
    nfe$ptf_deactivation_requested =  nfc$boot_base_status_condition + 0;                                     
    {E PTF deactivated by operator request.}                                                                  
                                                                                                              
?? FMT (FORMAT:=ON) ??                                                                                        
                                                                                                              
?? OLDTITLE ??                                                                                                
*DECK DECK=NFE$FTS_CONDITION_CODES EXPAND=FALSE
?? NEWTITLE := '  nfe$file_transfer_services', EJECT ??

?? FMT (FORMAT := OFF) ??
*copyc nfc$abnormal_conditions

  CONST
    nfc$fts_base_status_condition = nfc$min_status_condition + 200;
?? SKIP := 2 ??
  CONST
    nfe$application_timeout              = nfc$fts_base_status_condition + 0,
    {E Peer did not respond in allotted time.}

    nfe$application_protocol_error       = nfc$fts_base_status_condition + 1,
    {E Message received from peer application contained protocol error.}

    nfe$connection_closed_by_peer        = nfc$fts_base_status_condition + 2,
    {E Peer application unexpectedly closed connection.}

    nfe$access_method_timeout            = nfc$fts_base_status_condition + 3;
    {E Access method received no response from peer in allotted time.}

?? FMT (FORMAT := ON) ??

?? OLDTITLE ??
*DECK DECK=NFE$MANAGE_STORE_FORWARD_NETWRK EXPAND=FALSE
*copyc nfc$abnormal_conditions
?? NEWTITLE := 'NFE$MANAGE_STORE_FORWARD_NETWORK', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    nfc$manage_sfn_base_condition = nfc$min_status_condition + 600,

    nfe$sf_caller_not_privileged = nfc$manage_sfn_base_condition + 0,
    {F Caller not validated to +P.}

    nfe$sf_combine_dup_appl_def = nfc$manage_sfn_base_condition + 1,
    {I Combine the multiple definitions of DEFINE_APPLICATION_NAME_SWITCH, ..
    {  that have the destination_group_qualifier value of +P1, ..
    {  next_hop_application value of +P2 and the application_qualifiers ..
    {  are a subset of one or the other into one definition.}

    nfe$sf_combine_dup_source_def = nfc$manage_sfn_base_condition + 2,
    {I Combine the multiple definitions of DEFINE_SOURCE_NAME_SWITCH, that ..
    {  have the name value of +P1, next_hop_name value of +P2, ..
    {  destination_group_qualifier value of +P3, and the ..
    {  application_qualifiers are a subset of one another into one definition.}

    nfe$sf_combine_dup_target_def = nfc$manage_sfn_base_condition + 3,
    {I Combine the multiple definitions of DEFINE_DESTINATION_NAME_SWITCH, ..
    {  that have the name value of +P1, next_hop_name value of +P2 and the ..
    {  application_qualifiers are a subset of one another into one definition.}

    nfe$sf_dest_group_not_found = nfc$manage_sfn_base_condition + 4,
    {F The DESTINATION_GROUP_QUALIFIER +P1 has not been defined.}

    nfe$sf_dif_nha_same_aq_and_dgq = nfc$manage_sfn_base_condition + 5,
    {F The multiple definitions of DEFINE_APPLICATION_NAME_SWITCH, that ..
    {  have the destination_group_qualifier value of +P1 and overlapping ..
    {  application_qualifiers have different next_hop_applications.}

    nfe$sf_dif_nhn_same_n_aq_dgq = nfc$manage_sfn_base_condition + 6,
    {F The multiple definitions of DEFINE_SOURCE_NAME_SWITCH, that have the ..
    {  name value of +P1, destination_group_qualifier value of +P2 ..
    {  and overlapping application_qualifiers have different next_hop_names.}

    nfe$sf_dif_nhn_same_n_and_aq = nfc$manage_sfn_base_condition + 7,
    {F The multiple definitions of DEFINE_DESTINATION_NAME_SWITCH, that have ..
    {  the name value of +P1 and overlapping application_qualifiers have ..
    {  different next_hop_names.}

    nfe$sf_directive_errors = nfc$manage_sfn_base_condition + 8,
    {F MANAGE_STORE_FORWARD_NETWORK has encountered directive errors, ..
    {  see file: +P1 for additional error information.}

    nfe$sf_duplicate_appl_def = nfc$manage_sfn_base_condition + 9,
    {F The DEFINE_APPLICATION_NAME_SWITCH, that have the ..
    {  destination_group_qualifier value of +P1 and next_hop_application ..
    {  value of +P2 has multiple definitions with overlapping ..
    {  application_qualifiers.}

    nfe$sf_duplicate_group_names = nfc$manage_sfn_base_condition + 10,
    {F The DEFINE_DESTINATION_GROUP, that has the group_name value of +P1 ..
    {  has multiple definitions.}

    nfe$sf_duplicate_source_def = nfc$manage_sfn_base_condition + 11,
    {F The DEFINE_SOURCE_NAME_SWITCH, that have the name value of +P1 and ..
    {  next_hop_name value of +P2 has multiple definitions with overlapping ..
    {  application_qualifiers and destination_group_qualifiers.}

    nfe$sf_duplicate_target_def = nfc$manage_sfn_base_condition + 12,
    {F The DEFINE_DESTINATION_NAME_SWITCH, that have the name value of +P1 and ..
    {  next_hop_name value of +P2 has multiple definitions with overlapping ..
    {  application_qualifiers.}

    nfe$sf_group_name_not_used = nfc$manage_sfn_base_condition + 13,
    {I The DEFINE_DESTINATION_GROUP directive for the group_name +P1 was ..
    {  not used as a destination_group_qualifier in any other directives.}

    nfe$sf_identical_dest_list = nfc$manage_sfn_base_condition + 14,
    {I The DEFINE_DESTINATION_GROUP, that has the group_name +P1 ..
    {  has the identical destination names as group_name +P2.}

    nfe$sf_internal_error_bad_ptr = nfc$manage_sfn_base_condition + 15,
    {F An invalid pointer type has been encountered in the procedure: +P1 }

    nfe$sf_internal_error_bad_rptr = nfc$manage_sfn_base_condition + 16,
    {C An invalid pointer type has been encountered in the procedure: +P1 ..
    {  please re-install the SYSTEM's Store/Forward Network File.}

    nfe$sf_name_too_long = nfc$manage_sfn_base_condition + 17,
    {E The name value +P1 must be no longer than 31 characters in length ..
    {  for a +P2.}

    nfe$sf_name_too_short = nfc$manage_sfn_base_condition + 18,
    {E The name value +P1 must be at least 1 character in length for a +P2.}

    nfe$sf_no_store_forward_network = nfc$manage_sfn_base_condition + 19,
    {F The System's Store/Forward Network File does not exist, ..
    {  please install it.}

    nfe$sf_read_network_file_error = nfc$manage_sfn_base_condition + 20,
    {C Errors encountered on reading the System's Store/Forward Network File.}

    nfe$sf_string_too_long = nfc$manage_sfn_base_condition + 21,
    {E The string value +P1 must be no longer than 31 characters in length ..
    {  for a +P2.}

    nfe$sf_string_too_short = nfc$manage_sfn_base_condition + 22,
    {E The string value +P1 must be at least 1 character in length for a +P2.}

    nfe$sf_write_network_file_error = nfc$manage_sfn_base_condition + 23;
    {C Installation of System's Store/Forward Network File failed due to ..
    {  errors encountered on writing the Store/Forward Network File.}

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NFE$NTF_UTILITY_CONDITIONS EXPAND=FALSE
*copyc nfc$abnormal_conditions
?? NEWTITLE := 'NFE$NTF_UTILITY_CONDITIONS ''NF'' 1300 .. 1399', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    nfc$min_ecc_ntf_utility         = nfc$min_ecc + 1300,

    nfe$ntf_bad_local_name_file     = nfc$min_ecc_ntf_utility + 4,
    {E +P1 is not in the correct format for an NTF local name file.}

    nfe$ntf_bad_netdata_file        = nfc$min_ecc_ntf_utility + 6,
    {E +P1 is not in the correct format for a NETDATA file.}

    nfe$ntf_bad_rem_sys_list_file   = nfc$min_ecc_ntf_utility + 8,
    {E +P1 is not in the correct format for an NTF system list file.}

    nfe$ntf_command_not_implemented = nfc$min_ecc_ntf_utility + 12,
    {E Operator command is not implemented in NTF:  +P1.}

    nfe$ntf_control_fac_required    = nfc$min_ecc_ntf_utility + 16,
    {E A control facility must be selected before the +P1 command can be
    { issued.}

    nfe$ntf_insufficient_authority  = nfc$min_ecc_ntf_utility + 20,
    {E Insufficient authority to issue operator command:  +P1.}

    nfe$ntf_job_file_conflict       = nfc$min_ecc_ntf_utility + 24,
    {E +P1 is the name of more than one NTF controlled job or output file.}

    nfe$ntf_job_file_not_found      = nfc$min_ecc_ntf_utility + 28,
    {E +P1 is not an NTF controlled job or output file.}

    nfe$ntf_local_name_exists       = nfc$min_ecc_ntf_utility + 32,
    {E +P1 is already a NTF local name.}

    nfe$ntf_local_name_not_found    = nfc$min_ecc_ntf_utility + 36,
    {E +P1 is not an NTF local name.}

    nfe$ntf_lost_connection         = nfc$min_ecc_ntf_utility + 40,
    {E Lost connection to +P1.  Use SELECT_CONTROL_FACILITY to establish new
    { connection.}

    nfe$ntf_not_an_operator         = nfc$min_ecc_ntf_utility + 44,
    {E Only a validated NTF operator can use the +P1 command.}

    nfe$ntf_not_non_default         = nfc$min_ecc_ntf_utility + 48,
    {E +P1 is a default local name.}

    nfe$ntf_param_requires_rem_sys  = nfc$min_ecc_ntf_utility + 52,
    {E A remote system must be controlled if the +P1 parameter is specified.}

    nfe$ntf_remote_name_exists      = nfc$min_ecc_ntf_utility + 56,
    {E +P1 is already a NTF remote name.}

    nfe$ntf_remote_name_not_found   = nfc$min_ecc_ntf_utility + 60,
    {E +P1 is not an NTF remote name.}

    nfe$ntf_remote_system_required  = nfc$min_ecc_ntf_utility + 64,
    {E A remote system must be controlled before the +P1 command can be
    { issued.}

    nfe$ntf_remote_sys_in_list_file = nfc$min_ecc_ntf_utility + 68,
    {E +P1 is already in the NTF system list.}

    nfe$ntf_rem_sys_not_in_file     = nfc$min_ecc_ntf_utility + 72,
    {E +P1 is not in the NTF system list.}

    nfe$ntf_too_many_local_names    = nfc$min_ecc_ntf_utility + 76,
    {E Number of NTF local names exceeds the maximum of +P1.}

    nfe$ntf_too_many_remote_systems = nfc$min_ecc_ntf_utility + 80,
    {E Number of NTF system names exceeds the maximum of +P1.}

    nfe$ntf_unknown_control_fac     = nfc$min_ecc_ntf_utility + 84,
    {E +P1 is not a control facility known to NTF.}

    nfe$ntf_unknown_network_command = nfc$min_ecc_ntf_utility + 88,
    {E Operator command is not known to NTF:  +P1.}

    nfe$ntf_wrong_remote_name       = nfc$min_ecc_ntf_utility + 92,
    {E Local name +P1 is associated with another remote name.}

    nfc$max_ecc_ntf_utility         = nfc$min_ecc_ntf_utility + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=NFE$PTF_CONDITION_CODES EXPAND=TRUE
?? NEWTITLE := '  nfe$ptf_condition_codes', EJECT ??

*copyc nfc$abnormal_conditions
  CONST
    nfc$ptf_status_condition = nfc$min_status_condition + 300;

  CONST
    nfe$remote_val_defined =             nfc$ptf_status_condition + 00,
    {E Remote validation already defined for location +P.}

    nfe$remote_val_empty   =             nfc$ptf_status_condition + 01,
    {E No remote validation has been defined.}

    nfe$remote_val_undefined =           nfc$ptf_status_condition + 02,
    {E Remote validation undefined for location +P.}

    nfe$remote_val_device_error =        nfc$ptf_status_condition + 03,
    {E Illegal device for remote validation display.}

    nfe$both_files_remote =              nfc$ptf_status_condition + 05,
    {E Attempted copy with both files remote.}

    nfe$display_output_remote =          nfc$ptf_status_condition + 06,
    {E Output for +P may not be a remote file.}

    nfe$remote_file_not_ms =             nfc$ptf_status_condition + 07,
    {E Remote file +P not on mass storage device.}

    nfe$encountered_eoi =                nfc$ptf_status_condition + 10,
    {E +P encountered EOI.}

    nfe$directives_missing =             nfc$ptf_status_condition + 11,
    {E No server directives for +P.}

    nfe$multiple_file_transfers =        nfc$ptf_status_condition + 15,
    {E Only one file transfer allowed per remote access.}

    nfe$remote_access_terminated =       nfc$ptf_status_condition + 16,
    {E Remote access terminated.}

    nfe$call_not_permitted =             nfc$ptf_status_condition + 17;
    {E PTFS may be called only from the server application.}

?? FMT (FORMAT:=ON) ??

?? OLDTITLE ??
*DECK DECK=NFE$QUEUE_FILE_TRANSFER_FAC EXPAND=FALSE
?? NEWTITLE := 'nfe$queue_file_transfer_fac', EJECT ??
?? FMT (FORMAT := OFF) ??
*copyc nfc$abnormal_conditions

CONST
      nfc$queue_file_base_condition = nfc$min_status_condition + 500,

      nfe$invalid_explicit_text = nfc$queue_file_base_condition + 0,
      {E The explicit text directive +P1 is not a legal directive.}

      nfe$data_type_us_not_for_job = nfc$queue_file_base_condition + 1,
      {E The data declaration US may not be specified for a job.}

      nfe$invalid_data_mode_parameter = nfc$queue_file_base_condition + 2,
      {E The data mode +P1 is invalid.}

      nfe$invalid_vpd_parameter = nfc$queue_file_base_condition + 3,
      {E The vertical print density parameter +P1 is invalid.}

      nfe$invalid_implicit_text_value = nfc$queue_file_base_condition + 4,
      {E The implicit text directive +P1 is invalid.}

      nfe$copies_out_of_range = nfc$queue_file_base_condition + 5,
      {E The copies parameter specified is out of range.}

      nfe$job_exec_ring_out_of_range = nfc$queue_file_base_condition + 6,
      {E The job execution ring specified is out of range.}

      nfe$qtfc_qtfi_communication_err = nfc$queue_file_base_condition + 10,
      {E A communication error occurred between QTFC and QTFI.}

      nfe$qtf_no_loopback_jobs = nfc$queue_file_base_condition + 11,
      {E Job loopback transfers not permitted.}

      nfe$prif_to_wait_queue_not_sup = nfc$queue_file_base_condition + 12,
      {E NOS/VE QTF does not support the printing of NON-NOS/VE files to the WAIT QUEUE.}

      nfe$qtfs_chg_jad_qtf_to_public = nfc$queue_file_base_condition + 13;
      {I NOS/VE QTF SERVER has changed the OUTPUT_DESTINATION_USAGE for the system job/file ..
      {  name of + P1 from the JOB_ATTRIBUTE_DEFAULT of QTF to PUBLIC.}

?? fmt (format := on) ??
?? OLDTITLE ??
*DECK DECK=NFE$SOU_CONDITION_CODES EXPAND=TRUE
?? NEWTITLE := '  nfe$sou_condition_codes', EJECT ??
*copyc nfc$abnormal_conditions

  CONST
    nfc$sou_status_condition = nfc$min_status_condition + 350;

  CONST
    nfe$sou_invalid_intertask_req = nfc$sou_status_condition + 00,
    {E Operator Utility invalid intertask request.

    nfe$sou_invalid_intertask_resp = nfc$sou_status_condition + 01,
    {E Operator Utility invalid intertask response.

    nfe$sou_async_task_no_response = nfc$sou_status_condition + 02,
    {E Operator Utility no response from asynchronous task.

    nfe$sou_invalid_user = nfc$sou_status_condition + 05,
    {E User not validated to use +P.

    nfe$sou_scfs_no_response = nfc$sou_status_condition + 10,
    {E Station Operator received no response from Control Facility, command timed
    {out.

    nfe$sou_message_format_error = nfc$sou_status_condition + 11,
    {E Format error in +P message from Control Facility.

    nfe$sou_message_reject = nfc$sou_status_condition + 12,
    {E +P message rejected, +P.

    nfe$sou_unexpected_network_req = nfc$sou_status_condition + 13,
    {E +P request received from Control Facility.

    nfe$sou_command_reject = nfc$sou_status_condition + 14,
    {E +P command rejected, +P.

    nfe$invalid_value_for_location = nfc$sou_status_condition + 15,
    {E Invalid value for LOCATION parameter. Integer (0..65535) or list of string
    {(1..255) allowed.

    nfe$attribute_error_on_command = nfc$sou_status_condition + 17,
    {E +P command rejected, error on attribute +P.

    nfe$station_title_not_active = nfc$sou_status_condition + 18;
    {E Cannot locate I/O station +P.

?? FMT (FORMAT := ON) ??

?? OLDTITLE ??
*DECK DECK=NFE$STATUS_CONTROL_FAC_SERVER EXPAND=FALSE
?? NEWTITLE := '  nfe$status_control_fac_server', EJECT ??

*copyc nfc$abnormal_conditions

?? FMT (FORMAT := OFF) ??
  CONST
    nfc$scfs_base_status_condition = nfc$min_status_condition + 400;
?? SKIP := 2 ??
  CONST
    nfe$cf_title_already_registered =  nfc$scfs_base_status_condition + 0,
    {E Control facility title, +P, is already registered.}

    nfe$invalid_chg_requ_by_oper    =  nfc$scfs_base_status_condition + 1,
    {E Attribute request is not allowed by the device.}

    nfe$no_scfs_storage_available   =  nfc$scfs_base_status_condition + 2,
    {E Not enough storage available for SCFS tables.}

    nfe$ntf_system_list_file_error  =  nfc$scfs_base_status_condition + 3;
    {E The NTF system list is not correctly formatted.}

?? FMT (FORMAT:=ON) ??

?? OLDTITLE ??

*DECK DECK=NFE$XFER_APPL_ERROR_CODES EXPAND=TRUE
?? NEWTITLE := '  NFE$XFER_APPL_ERROR_CODES ----- ''NF'' 450 .. 475', EJECT ??
?? FMT (FORMAT := OFF) ??

*copyc nfc$abnormal_conditions

  CONST
    nfc$xfer_appl_base_condition = nfc$min_status_condition + 450,

    nfe$outside_bounds_of_sequence =      nfc$xfer_appl_base_condition + 00,
    {E Pointer outside the bounds of the message sequence.}

    nfe$invalid_parameter_value    =      nfc$xfer_appl_base_condition + 01,
    {E Incorrect or missing parameter value +P for +P protocol message.}

    nfe$invalid_descriptor_value   =      nfc$xfer_appl_base_condition + 02,
    {E Descriptor value +P invalid for application.}

    nfe$conflicting_descriptors    =      nfc$xfer_appl_base_condition + 03;
    {E Queue file descriptors must be of the same type.}

?? FMT (FORMAT:=ON) ??
?? OLDTITLE ??
*DECK DECK=NFH$ADD_BTF_TASK_TO_LIST EXPAND=FALSE

{
{    The purpose of this request is to add a BTF/VE task entry to the
{    clients list of BTF tasks.
{
{        NFP$ADD_BTF_TASK_TO_LIST (TASK_ID, QUEUE_ID, NETWORK_ADDRESS,
{              BTFS_DI_TITLE, STATION, DEVICE, WAIT_LIST, WAIT_ACTIVITY_LIST,
{              WAIT_LIST_SEQUENCE, WAIT_ACTIVITY_LIST_SEQUENCE, NEW_BTF_TASK)
{
{  TASK_ID: (input) This parameter specifies the task identifier for the
{        BTF/VE task that is to be added to the clients list.
{
{  QUEUE_ID: (input) This parameter specifies the job local queue which
{        is used for communication between the BTF/VE task and the parent
{        task.
{
{  NETWORK_ADDRESS: (input) This parameter specifies the BTFS/DI network
{        address that BTF/VE will connect to for the file transfer.
{
{  BTFS_DI_TITLE: (input) This parameter specifies the BTFS/DI title.
{
{  STATION: (input) This parameter specifies the name of the station
{        or remote system that the device or stream is associated with.
{
{  DEVICE: (input) This parameter specifies the device or stream that the file
{        will be transferred to.
{
{  WAIT_LIST: (input, output) This parameter specifies the list of activities
{        that the client is waiting for.  One of these activities is job local
{        queue messages from BTF/VE task(s).
{
{  WAIT_ACTIVITY_LIST: (input, output) This parameter specifies an association
{        list for the wait_list.  Each entry in the wait_activity_list
{        contains detailed information, with each entry in the
{        wait_activity_list corresponding to an entry in the wait_list.
{
{  WAIT_LIST_SEQUENCE: (input, output) This parameter specifies the sequence
{        where the wait_list is stored.
{
{  WAIT_ACTIVITY_LIST_SEQUENCE: (input, output) This parameter specifies the
{        sequence where the wait_activity_list is stored.
{
{  NEW_BTF_TASK: (output) This parameter specifies the btf task that
{        will transfer the data.
{
*DECK DECK=NFH$ADD_TO_WAIT_LISTS EXPAND=FALSE

{
{    The purpose of this request is to add an activity to the wait_list
{    and to the wait_activity_list.  The wait_list is a list of activities
{    the task is waiting on.  The wait_activity_list contains detailed
{    information, with each entry in the wait_activity_list corresponding to
{    an entry in the wait_list.
{
{        NFP$ADD_TO_WAIT_LISTS (ACTIVITY, WAIT_LIST, WAIT_ACTIVITY_LIST,
{              WAIT_LIST_SEQUENCE, WAIT_ACTIVITY_LIST_SEQUENCE)
{
{  ACTIVITY: (input) This parameter specifies the activity that will be added
{        to the wait list.
{
{  WAIT_LIST: (input, output) This parameter specifies the list of activities
{        that the client is waiting for.
{
{  WAIT_ACTIVITY_LIST: (input, output) This parameter specifies an association
{        list for the wait_list.  Each entry in the wait_activity_list
{        contains detailed information, with each entry in the
{        wait_activity_list corresponding to an entry in the wait_list.
{
{  WAIT_LIST_SEQUENCE: (input, output) This parameter specifies the sequence
{        where the wait_list is stored.
{
{  WAIT_ACTIVITY_LIST_SEQUENCE: (input, output) This parameter specifies the
{        sequence where the wait_activity_list is stored.



*DECK DECK=NFH$BEGIN_ASYNCHRONOUS_TASK EXPAND=FALSE
{
{    The purpose of this request is to establish job local queue communication
{  between the parent and child tasks.  The request is made by the child task.
{
{       NFP$BEGIN_ASYNCHRONOUS_COMMUNICATION (PARAMETERS, CONNECTED_TASK,
{             QUEUE_ID, STATUS);
{
{  PARAMETERS: (input) This parameter specifies the program parameters that
{        are passed by the parent task.
{
{  CONNECTED_TASK: (output) This parameter is the task id of the parent task.
{
{  QUEUE_ID: (output) This parameter is the queue connection for the child
{        task.
{
{  STATUS: (output) This parameter specifies the request_status.
{        CONDITIONS:
{              nfe$redundant_begin_task
{              nfe$async_task_timeout
{
{              pmp$define_queue error conditions
{              pmp$connect_queue error conditions
{
{        IDENTIFIER: 'NF'
{
*DECK DECK=NFH$BTFS_DI_MATCH EXPAND=FALSE
{
{     The purpose of this function is to compare the two BTFS/DI titles
{ (if defined) or the BTFS/DI network addresses (if titles not defined).
{
{       NFP$BTFS_DI_MATCH (FIRST_TITLE, FIRST_ADDRESS, SECOND_TITLE,
{             SECOND_ADDRESS)
{
{ FIRST_TITLE: (input)  This parameter specifies the first BTFS/DI title.
{
{ FIRST_ADDRESS: (input)  This parameter specifies the first network address.
{
{ SECOND_TITLE: (input)  This parameter specifies the second BTFS/DI title.
{
{ SECOND_ADDRESS: (input)  This parameter specifies the second network address.
{
*DECK DECK=NFH$CHECK_REMOTE_ACCESS EXPAND=TRUE
{
{     The purpose of this request is to determine whether a file reference in
{ a command is an implicit reference to a remote permanent file or catalog.
{ This request is made by certain SCL command processors that allow implicit
{ remote file access.
{     The path name is obtained and the family name is checked to determine
{ whether it is the name of an active family on the local NOS/VE system.
{ If not, the family is assumed to be remote.
{
{       NFP$CHECK_REMOTE_ACCESS (FILE, REMOTE_ACCESS, REMOTE_PATH,
{             REMOTE_FAMILY, STATUS)
{
{ FILE: (input)  This parameter specifies the file or catalog which is to be
{ checked for being located on a remote family.
{
{ REMOTE_ACCESS: (output)  This parameter is a boolean value which is set to
{       indicate whether the specified file or catalog is remote.
{
{ REMOTE_PATH: (output)  This parameter specifies the path name of the file or
{       catalog if it is found to be remote.  This parameter is not set if the
{       file or catalog reference is local.
{
{ REMOTE_FAMILY: (output)  This parameter specifies the name of the family in
{       which the remote file or catalog resides.  This parameter is not set
{       if the file or catalog reference is local.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: none.
{
*DECK DECK=NFH$CLOSE_STORE_FORWARD_FILE EXPAND=FALSE
{
{    The purpose of this request is to close and detach the SYSTEM's
{ Store/Forward Network file.
{
{       NFP$CLOSE_STORE_FORWARD_FILE (store_forward_file_info, status)
{
{  STORE_FORWARD_FILE_INFO: (output)  This parameter returns a record of the
{        following information about the SYSTEM's STORE_FORWARD_FILE:
{
{    LOCAL_FILE_NAME: (output)  This field returns osc$null_name as the local
{          file name for the $SYSTEM's STORE_FORWARD_FILE after this instance
{          of attach is closed and detached.
{
{    FILE_OPEN: (output)  This field returns a boolean value that states if the
{          $SYSTEM's STORE_FORWARD_FILE is open.
{
{    STORE_FORWARD_FILE_IDENTIFIER: (output)  This field returns the BAM file
{          identifier of the $SYSTEM's STORE_FORWARD_FILE when it is opened.
{
{    SEGMENT_POINTER: (output)  This field returns a NIL relative pointer to
{          the segment access file $SYSTEM STORE_FORWARD_NETWORK file.
{
{    POINTERS: (output)  This field returns a record of NIL relative pointers
{          for the linked lists of DEFINE_APPLICATION_NAME_SWITCH information,
{          DEFINE_DESTINATION_NAME information, DEFINE_SOURCE_NAME_SWITCH
{          information, and DEFINE_DESTINATION_NAME_SWITCH information.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
*DECK DECK=NFH$COUNT_DIRECTIVES_TEXT EXPAND=FALSE
{
{    The purpose of this function is to count the number of bytes of data on a
{ linked list of directives.
{
{    NFP$COUNT_DIRECTIVES_TEXT(DIRECTIVES_LIST)
{
{ DIRECTIVE_LIST: (input)  Pointer to directives list.
{
*DECK DECK=NFH$CRACK_FILE_ASSIGNMENT_MSG EXPAND=FALSE

{
{    The purpose of this request is to crack a file assignment message
{    that was received from the server task.
{
{        NFP$CRACK_FILE_ASSIGNMENT_MSG (MESSAGE, MESSAGE_LENGTH,
{              STATION, DEVICE, DEVICE_TYPE, DEVICE_ATTRIBUTES,
{              BTFS_ADDRESS, BTFS_DI_TITLE, FILE_NAME,
{              DESCRIPTOR, REMOTE_SYSTEM_PROTOCOL, REMOTE_SYSTEM_TYPE,
{              ROUTE_BACK_POSITION, LAST_PARAMETER_SENT, STATUS)
{
{  MESSAGE: (input, output) This parameter specifies the message sequence where
{        the file assignment message is to be read from.
{
{  MESSAGE_LENGTH: (input, output)  This parameter specifies the length of the
{        file assignment message.
{
{  STATION: (output) This parameter specifies the name of the station
{        or remote system that the batch device or stream is associated with.
{
{  DEVICE: (output) This parameter specifies the batch device or stream that the
{        file was assigned to.
{
{  DEVICE_TYPE (output) This parameter specifies the device_type of the batch
{        device or stream that the file was assigned to.
{
{  DEVICE_ATTRIBUTES: (output) For files assigned to SCF this parameter
{        specifies the device attributes of the device.  For Non-SCF files
{        this parameter is not meaningful.
{
{  BTFS_ADDRESS: (output) This parameter specifies the BTFS/DI network
{        address that BTF/VE will connect to for the file transfer.
{        The value of this parameter is undefined if the BTFS_DI_TITLE
{        parameter is defined (see below).
{
{  BTFS_DI_TITLE: (output) This parameter specifies the BTFS/DI network
{        title which symbolically represents the BTFS/DI network address.
{        If this parameter is defined (length > 0) then the value of the
{        BTFS_ADDRESS parameter (above) has no meaning.
{
{  FILE_NAME: (output) This parameter specifies the file that was assigned
{        to the batch device or stream.
{
{  DESCRIPTOR: (output) This parameter specifies the file descriptor
{        where the queue file attributes are to be placed.
{
{  REMOTE_SYSTEM_PROTOCOL: (output)  This parameter specifies the protocol
{        for the remote system.
{
{  REMOTE_SYSTEM_TYPE: (output)  This parameter specifies the type of the
{        remote system.
{
{  ROUTE_BACK_POSITION: (output)  This parameter specifies the route back
{        position for the remote system.
{
{  LAST_PARAMETER_SENT: (output)  This parameter specifies the last parameter
{        sent from SCFS on the protocol message.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              nfe$invalid_parameter_value
{              nfe$outside_bounds_of_sequence
{



*DECK DECK=NFH$CRACK_TERQO_MSG EXPAND=FALSE

{
{    The purpose of this request is to crack a terminate queued output message
{    that was received from or sent by the server task.
{
{        NFP$CRACK_TERQO_MSG (MESSAGE, MESSAGE_LENGTH, IO_STATION_NAME,
{              SYSTEM_FILE_NAME, STATUS)
{
{  MESSAGE: (input, output) This parameter specifies the message sequence where
{        the file assignment message is to be read from.
{
{  MESSAGE_LENGTH: (input, output)  This parameter specifies the length of the
{        file assignment message.
{
{  IO_STATION_NAME: (output) This parameter specifies the name of the station
{        or remote system that the queued output file is associated with.
{
{  SYSTEM_FILE_NAME: (output) This parameter specifies the queued output file
{        that is to be terminated.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              nfe$invalid_parameter_value
{              nfe$outside_bounds_of_sequence
{

*DECK DECK=NFH$CREATE_APPL_DEF_SEGMENT_VAR EXPAND=FALSE
{
{     The purpose of this request is create a SCL variable that will contain the
{ ring and segment number of the allocated pointers into the cybil default heap.
{ This SCL variable will then be used by the ABORT_FILE, as defined by the
{ define_system_task command.
{
{     NFP$CREATE_APPL_DEF_SEGMENT_VAR (application, application_defined_segment)
{
{  APPLICATION: (input) This parameter is the name of the calling application.
{
{  APPLICATION_DEFINE_SEGMENT: (input) This parameter is a allocated pointer to
{        the cybil default heap.
*DECK DECK=NFH$CREATE_WAIT_QUEUE_FILE_NAME EXPAND=FALSE

{
{    The purpose of this request is to create a subcatalog named $WAIT_QUEUE in
{    the user's catalog if one does not exist and create a file name in that
{    subcatalog.
{
{        NFP$CREATE_WAIT_QUEUE_FILE_NAME (FAMILY_NAME, USER_NAME,
{              USER_FILE_NAME, WAIT_QUEUE_FILE_NAME, STATUS)
{
{  FAMILY_NAME: (input) This parameter specifies the family name of the user.
{
{  USER_NAME: (input)  This parameter specifies the user name where the wait
{        queue will reside or resides.
{
{  USER_FILE_NAME: (input) This parameter specifies the name of the file that
{        will end up in the user's wait queue.
{
{  WAIT_QUEUE_FILE_NAME: (output) This parameter specifies the resultant file
{        name.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              PF conditions
{              CL conditions
{



*DECK DECK=NFH$DELETE_BTF_TASK EXPAND=FALSE

{
{    The purpose of this request is to delete a BTF/VE task entry from the
{    clients list of BTF tasks.
{
{        NFP$DELETE_BTF_TASK (LIST_INDEX, WAIT_ACTIVITY_LIST, BTF_TASK)
{
{  LIST_INDEX (input) This parameter specifies the task identifier for the
{        BTF/VE task that is to be deleted from the clients list.
{
{  WAIT_ACTIVITY_LIST: (input, output) This parameter specifies an association
{        list for the wait_list.  The indices correspond to the wait_list,
{        contains more information on the specific activity.  For job
{        local queue messages, the btf task list is kept here.
{
{  BTF_TASK: (input, output) This parameter specifies the task identifier for the
{        BTF/VE task that is to be deleted from the clients list.
{



*DECK DECK=NFH$END_ASYNC_COMMUNICATION EXPAND=FALSE
{
{    The purpose of this request is to end job local queue communication
{  between the parent and child tasks.
{
{       NFP$END_ASYNCHRONOUS_COMMUNICATION (CHECK_ACTIVITY, STATUS)
{
{  CHECK_ACTIVITY: (input) This parameter if set to TRUE will cause the support
{        routines to look to see if there are any message to or from the
{        calling task and not end communication.  If set to FALSE, communication
{        will be terminated immediately.
{
{  STATUS: (output) This parameter specifies the request_status.
{        CONDITIONS:
{              nfe$activity_pending
{              nfe$module_not_initialized
{
{              pmp$status_queue error conditions
{
{        IDENTIFIER: 'NF'
{
*DECK DECK=NFH$ESTABLISH_CF_CONNECTION EXPAND=FALSE

{
{    The purpose of this request is to establish a connection with the
{  control_facility.
{
{        NFP$ESTABLISH_CF_CONNECTION (SERVICE_ADDRESS, CONNECT_FILE,
{              CLIENT_VERSION, CLIENT_IDENTIFIER, CLIENT_NAME,
{              CONTROL_FACILITY_NAME, CONNECTION_IDENTIFIER, STATUS)
{
{  SERVICE_ADDRESS: (input) This parameter specifies the address of the
{        control facility to which the connection should be made.
{
{  CONNECT_FILE: (input) This parameter specifies the name of the
{        connection_file.
{
{  CLIENT_VERSION: (input) This parameter specifies the client data version.
{
{  CLIENT_IDENTIFIER: (input) This parameter specifies the identification
{        of the client that wants to make the connection.
{
{  CLIENT_NAME: (input) This parameter specifies the application name
{        of the client that wants to make the connection.
{
{  CONTROL_FACILITY_NAME: (output) This parameter specifies the name of the
{        control facility.
{
{  CONNECTION_IDENTIFIER: (output) This parameter specifies the network file
{        that should be used to identify the connection.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$file_not_known
{              ame$improper_device_class
{                ... other BAM conditions
{              nae$address_protocol_mismatch
{              nae$application_inactive
{              nae$client_protocol_mismatch
{              nae$connection_terminated
{              nae$improper_attribute_value
{              nae$invalid_address
{              nae$max_active_connections
{              nae$network_inactive
{              nae$no_server_response
{              nae$server_response_timeout
{              nae$switch_offer_pending
{              nae$unknown_application
{              nae$unknown_attribute
{              nae$unknown_protocol

*DECK DECK=NFH$GENERATE_PTF_STATISTIC EXPAND=FALSE
{
{    The purpose of this procedure is to emit the respective file transfer
{ statistic for PTF or PTFS.  The statistic describes the connection time in
{ seconds, size of file transferred in bytes, the bytes sent and received
{ exclusive of file transfer ( 05 and 08 messages), and a descriptive field.
{ The descriptive field contains the local PID, remote LID, and the command(s)
{ which initiated this file transfer.
{
{    NFP$GENERATE_PTF_STATISTIC( BEGIN_CONNECTION_TIME, END_CONNECTION_TIME,
{ FILE_SIZE, TRANSFER_DIRECTIVES_LENGTH, LOCAL_MAINFRAME_SYSTEM_NAME,
{ REMOTE_MAINFRAME_SYSTEM_NAME, APPLICATION, PTF_COMMAND)
{
{    BEGIN_CONNECT_TIME : (input)  Time connection was opened.
{
{    END_CONNECT_TIME : (input)  Time transfer was deemed complete.
{
{    FILE_SIZE : (input)  Size of file transferred.
{
{    TRANSFER_DIRECTIVES_LENGTH : (input)  Size of 05/08 directives sent or
{ received.
{
{    LOCAL_MAINFRAME_SYSTEM_NAME : (input)  Local LID or family.
{
{ REMOTE_MAINFRAME_SYSTEM_NAME: (input)  Remote LID/PID or family.
{
{    APPLICATION : (input)  PTFS or PTFI.
{
{    PTF_COMMAND : (input)  Command used to initiate PTF action.
{
*DECK DECK=NFH$GET_ASYNC_TASK_MESSAGE EXPAND=FALSE
{
{    The purpose of this request is to get a message sent by a partner task.
{
{       NFP$GET_ASYNC_TASK_MESSAGE (TASK_ID, WORKING_STORAGE_AREA,
{             WORKING_STORAGE_LENGTH, WAIT_TIME, TRANSFER_COUNT, STATUS)
{
{  TASK_ID: (input) This parameter specifies the task id the message should be
{        received from.
{
{  WORKING_STORAGE_AREA: (input) This parameter specifies the buffer where the
{        message will be put.
{
{  WORKING_STORAGE_LENGTH: (input) This parameter specifies the length of the
{        buffer.
{
{  WAIT_TIME: (input) This parameter specifies how long to wait for a message
{        from the specified task.
{
{  TRANSFER_COUNT: (output) This parameter specifies how long the message is
{        that got put in the working storage area.
{
{  STATUS: (output) This parameter specifies the request_status.
{        CONDITIONS:
{              nfe$bad_message_discarded
{              nfe$locked_by_another_task
{              nfe$module_not_initialized
{              nfe$task_not_active
{
{              pmp$connect_queue error conditions
{              pmp$receive_from_queue error conditions
{              pmp$status_queue error conditions
{
{        IDENTIFIER: 'NF'
{
*DECK DECK=NFH$GET_BTFS_DI_ADDRESS EXPAND=FALSE
{
{     The purpose of this request is to return the network address that
{ corresponds to the BTFS/DI title.  The title is not translated if its
{ address is already known.
{
{       NFP$GET_BTFS_DI_ADDRESS (TITLE, CLIENT, NETWORK_ADDRESS, STATUS)
{
{ TITLE: (input)  This parameter specifies the BTFS/DI title to translate.
{
{ CLIENT: (input)  This parameter specifies the client on whose behalf the
{       translation request will be made (eg:  OSA$STATUS_CONTROL_FAC_CLIENT).
{
{ NETWORK_ADDRESS: (output)  This parameter specifies the network address
{       that corresponds to the title.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             nae$no_translation_available
{
*DECK DECK=NFH$GET_CONNECTION_DATA EXPAND=FALSE

{
{    The purpose of this request is to receive data from a peer application
{  over the specified connection and to place this data in the message area.
{
{        NFP$GET_CONNECTION_DATA (MESSAGE, CONNECTION_IDENTIFIER,
{              PEER_OPERATION, ACTIVITY_STATUS, STATUS)
{
{  MESSAGE: (input) This parameter specifies the message sequence
{        where the connection data is to be placed.
{
{  CONNECTION_IDENTIFIER: (input) This parameter specifies the name of the
{        network file identifying the connection from which the data is
{        to be received.
{
{  PEER_OPERATION: (output) This parameter specifies the operation performed by
{        the peer application which caused the receive data operation to
{        complete.
{
{  ACTIVITY_STATUS: (output) This parameter specifies the status of the receive
{        data operation.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$improper_device_class
{              ame$improper_file_id
{              nae$connection_terminated
{              nae$receive_outstanding
{              nae$improper_protocol
{



*DECK DECK=NFH$GET_NEW_APPLICATION_NAME EXPAND=FALSE
{
{    The purpose of this request is to return a new application name from the
{ System's Store_Forward_Network file, if all of the following criteria are
{ met:  1.  the STORE_FORWARD_NETWORK file has an entry for the calling
{ application, and 2.  the same STORE_FORWARD_NETWORK file entry has the
{ current destination as one of the destination_group_qualifier systems.
{
{       NFP$GET_NEW_APPLICATION_NAME (application_qualifier,
{             store_forward_file_info, destination_name,
{             application_name_changed, new_application_name, status)
{
{  APPLICATION_QUALIFIER: (input)  This parameter is the name of the calling
{        application.
{
{  STORE_FORWARD_FILE_INFO: (input)  This parameter contains pointer
{        information about the various lists maintained in the SYSTEM's
{        STORE_FORWARD_FILE:
{
{  DESTINATION_NAME: (input)  This parameter is the destination name of the
{        current queue file being transferred by this application.
{
{  APPLICATION_NAME_CHANGED: (output)  This parameter returns a boolean value
{        stating if the NEW_APPLICATION_NAME has been changed to the new value.
{
{  NEW_APPLICATION_NAME: (output)  This parameter returns the new application
{        name that is to transfer the current queue file to its destination.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
*DECK DECK=NFH$GET_NEW_DESTINATION_NAME EXPAND=FALSE
{
{    The purpose of this request is to return a new target name from the
{ System's Store_Forward_Network file, if all of the following criteria are
{ met:  1.  the STORE_FORWARD_NETWORK file has an entry for the calling
{ application, and 2.  the same STORE_FORWARD_NETWORK file entry has the
{ current destination name as the destination_name for this entry.
{
{       NFP$GET_NEW_DESTINATION_NAME (application_qualifier,
{             store_forward_file_info, current_target_name,
{             target_name_changed, new_target_name, status)
{
{  APPLICATION_QUALIFIER: (input)  This parameter is the name of the calling
{        application.
{
{  STORE_FORWARD_FILE_INFO: (input)  This parameter contains pointer
{        information about the various lists maintained in the SYSTEM's
{        STORE_FORWARD_FILE:
{
{  CURRENT_TARGET_NAME: (input)  This parameter is the target name of the
{        current queue file being transferred by this application.
{
{  TARGET_NAME_CHANGED: (output)  This parameter returns a boolean value
{        stating if the NEW_TARGET_NAME has been changed to the new value.
{
{  NEW_TARGET_NAME: (output)  This parameter returns the new destination name
{        that is to be used during the transfer of the current queue file to
{        its destination.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
*DECK DECK=NFH$GET_NEW_SOURCE_NAME EXPAND=FALSE
{
{    The purpose of this request is to return a new source name from the
{ System's Store_Forward_Network file, if all of the following criteria are
{ met:  1.  the STORE_FORWARD_NETWORK file has an entry for the calling
{ application, 2.  the same STORE_FORWARD_NETWORK file entry has the current
{ source name as the source_name for this entry, and 2.  the same
{ STORE_FORWARD_NETWORK file entry has the current destination as one of the
{ destination_group_qualifier systems.
{
{       NFP$GET_NEW_SOURCE_NAME (application_qualifier,
{             store_forward_file_info, current_source_name, destination_name,
{             source_name_changed, new_source_name, status)
{
{  APPLICATION_QUALIFIER: (input)  This parameter is the name of the calling
{        application.
{
{  STORE_FORWARD_FILE_INFO: (input)  This parameter contains pointer
{        information about the various lists maintained in the SYSTEM's
{        STORE_FORWARD_FILE:
{
{  CURRENT_SOURCE_NAME: (input)  This parameter is the source name of the
{        current queue file being transferred by this application.
{
{  DESTINATION_NAME: (input)  This parameter is the destination name of the
{        current queue file being transferred by this application.
{
{  SOURCE_NAME_CHANGED: (output)  This parameter returns a boolean value
{        stating if the NEW_SOURCE_NAME has been changed to the new value.
{
{  NEW_SOURCE_NAME: (output)  This parameter returns the new source name that
{        is to be used during the transfer of the current queue file to its
{        destination.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
*DECK DECK=NFH$GET_PARAMETER_VALUE_LENGTH EXPAND=FALSE

{
{    The purpose of this request is to get the attribute length from a
{  message.
{
{        NFP$GET_PARAMETER_VALUE_LENGTH (MESSAGE, MESSAGE_LENGTH,
{              PARAMETER_VALUE_LENGTH, STATUS)
{
{  MESSAGE: (input) This parameter specifies the message sequence
{        where the attribute length is to be taken from.
{
{  MESSAGE_LENGTH: (input,output) This parameter specifies the remaining bytes
{        in the message.
{
{  PARAMETER_VALUE_LENGTH: (output) This parameter specifies the length of
{        the attribute value taken from the message.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              nfe$outside_bounds_of_sequence
{



*DECK DECK=NFH$MANAGE_STORE_FORWARD_NETWRK EXPAND=FALSE
{
{    The purpose of this request is to create, verify or replace the SYSTEM's
{ Store/Forward Network file.  The Store/Forward Network file contains
{ information for the Queue File Transfer Facility (QTF or NTF) to aid in
{ transferring queue files between connecting systems.  The connecting systems
{ do NOT have to be directly connected by either CDCNET or LCN.  The systems
{ may be connected together through an intermediate system.
{
{       NFP$MANAGE_STORE_FORWARD_NETWRK (STATUS)
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
*DECK DECK=NFH$NETWORK_ADDRESSES_MATCH EXPAND=FALSE
{
{    The purpose of this function is to compare two network address and return
{ a value of TRUE if they are equivalent.  At this time only two address kinds
{ are supported:  internet and OSI transport.  Only the system address is used
{ as a basis for comparison.  Addresses of another kind will result in a value
{ of FALSE.
{
{       NFP$NETWORK_ADDRESSES_MATCH (FIRST_ADDRESS, SECOND_ADDRESS)
{
{ FIRST_ADDRESS: (input)  This parameter specifies the first address.
{
{ SECOND_ADDRESS: (input)  This parameter specifies the second address.
{
*DECK DECK=NFH$NTF_RECEIVE_FILE EXPAND=FALSE
{
{    The purpose of this request is to process NTF files received by
{    the BTF_SERVER.
{
{        NFP$NTF_RECEIVE_FILE (CONTROL_BLOCK, P17_PARAM, P32_PARAMS,
{              P58_PARAMS, STOPR_PARAMS, QUEUE_STATUS, STATUS)
{
{  CONTROL_BLOCK: (input/output) This parameter specifies the transfer
{        control block.  The job submission options or output submission
{        options are set from the information contained in the control
{        block.
{
{  P17_PARAM: (input) This parameter specifies the dispostion code of the
{        received file.
{
{  P32_PARAMS: (input) This parameter specifies the NTF systems routing text.
{
{  P58_PARAMS: (input) This parameter specifies the NTF default output
{        destination.
{
{  STOPR_PARAMS: (output) This parameter specifies the paramters to be sent
{        to BTF/DI on the STOPR command.
{
{  QUEUE_STATUS: (output) This parameter specifies the status returned by
{        JMP$PRINT_FILE or JMP$SUBMIT_FILE.
{
{  STATUS: (output) This parameter specifies the request status.
*DECK DECK=NFH$OPEN_STORE_FORWARD_FILE EXPAND=FALSE
{
{    The purpose of this request is to attach the SYSTEM's Store/Forward
{ Network file as declared by the parameter:  ATTACH_FILE.  However, for every
{ call to this procedure a new instance of open will occur for the local file.
{ The Store/Forward Network file contains information for the Queue File
{ Transfer Facility (QTF or NTF) to aid in transferring queue files between
{ connecting systems.  The connecting systems do NOT have to be directly
{ connected by either CDCNET or LCN.  The systems may be connected together
{ through an intermediate system.
{
{       NFP$OPEN_STORE_FORWARD_FILE (attach_file, store_forward_file_info,
{             status)
{
{  ATTACH_FILE: (input)  This parameter is a boolean value that tells the
{        procedure to attach the SYSTEM's STORE_FORWARD_NETWORK file.
{
{  STORE_FORWARD_FILE_INFO: (output)  This parameter returns a record of the
{        following information about the SYSTEM's STORE_FORWARD_FILE:
{
{    LOCAL_FILE_NAME: (output)  This field returns the local file name for the
{          $SYSTEM's STORE_FORWARD_FILE for this instance of attach.
{
{    FILE_OPEN: (output)  This field returns a boolean value that states if the
{          $SYSTEM's STORE_FORWARD_FILE is open.
{
{    FILE_IDENTIFIER: (output)  This field returns the BAM file identifier of
{          the $SYSTEM's STORE_FORWARD_FILE when it is opened.
{
{    SEGMENT_POINTER: (output)  This field returns a sequence pointer to the
{          segment access file for the $SYSTEM's STORE_FORWARD_NETWORK file.
{
{    POINTERS: (output)  This field returns a record of relative pointers to
{          the linked lists of DEFINE_APPLICATION_NAME_SWITCH information,
{          DEFINE_DESTINATION_NAME information, DEFINE_SOURCE_NAME_SWITCH
{          information, and DEFINE_DESTINATION_NAME_SWITCH information.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
*DECK DECK=NFH$PERFORM_REMOTE_ACCESS EXPAND=TRUE
{
{     The purpose of this request is to perform access to a remote permanent
{ file or catalog for the calling command processor.  This procedure will
{ collect the server directives to be executed by the remote server appli-
{ cation, and call the interfaces that initiate the remote connection and
{ access.
{
{       NFP$PERFORM_REMOTE_ACCESS (LOCATION, LOCAL_FILE, REMOTE_FILE_PATH,
{             ACCESS_MODE, COMMAND_NAME, PDT, PARAMETER_CHANGES, STATUS)
{
{ LOCATION: (input)  This parameter specifies the remote location where the
{       file to be accessed resides.  This is the same as the family name
{       where the file is located.
{
{ LOCAL_FILE:  This parameter specifies the file on the local system to be
{       used as the source or destination of a file transfer, if one is to
{       take place.  This file may be a permanent file in a family on the
{       local NOS/VE system, or a local file.  If no file transfer is to take
{       place, this parameter will be ignored.
{
{ REMOTE_FILE_PATH: (input)  This parameter specifies the path name of the
{       remote file being transferred.  This parameter is ignored if no file
{       is actually to be transferred between locations (see ACCESS_MODE).
{
{ ACCESS_MODE: (input)  This parameter specifies the mode of access as speci-
{       fied in the A to A protocol.  Mode of access indicates whether a file
{       transfer is to take place, and the direction of transfer as seen by
{       the server application (give/take/null).
{
{ COMMAND_NAME: (input)  This parameter specifies the command name of the
{       command being processed, which is also to be executed by the remote
{       server application.  This parameter is left blank if the command is
{       not to be executed remotely.
{
{ PDT: (input)  This parameter specifies the parameter descriptor table for
{       the command being processed.
{
{ PARAMETER_CHANGES: (input)  This parameter specifies an array of parameter
{       names and values to be substituted in the command to be executed
{       remotely.  If no parameter modifications are required, a NIL pointer
{       is used.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: nfe$remote_val_undefined.
{       IDENTIFIER: nac$status_id.
*DECK DECK=NFH$PUT_ASYNC_TASK_MESSAGE EXPAND=FALSE
{
{    The purpose of this request is to send a message to a partner task.
{
{       NFP$PUT_ASYNC_TASK_MESSAGE (TASK_ID, WORKING_STORAGE_AREA,
{             WORKING_STORAGE_LENGTH, STATUS)
{
{  TASK_ID: (input) This parameter specifies the task id where the message
{        should be sent.
{
{  WORKING_STORAGE_AREA: (input) This parameter specifies the buffer where the
{        message is.
{
{  WORKING_STORAGE_LENGTH: (input) This parameter specifies the length of the
{        buffer.
{
{  STATUS: (output) This parameter specifies the request_status.
{        CONDITIONS:
{              nfe$allocation_failure
{              nfe$locked_by_another_task
{              nfe$module_not_initialized
{              nfe$task_not_active
{
{              pmp$connect_queue error conditions
{              pmp$send_to_queue error conditions
{
{        IDENTIFIER: 'NF'
*DECK DECK=NFH$PUT_PARAMETER_VALUE_LENGTH EXPAND=FALSE

{
{    The purpose of this request is to put an attribute length into a message.
{
{        NFP$PUT_PARAMETER_VALUE_LENGTH (PARAMETER_VALUE, MESSAGE,
{              PARAMETER_LENGTH_SIZE, STATUS)
{
{  PARAMETER_VALUE: (input) This parameter specifies the attribute whose
{        length is to be put into the message.
{
{  MESSAGE: (input,output) This parameter specifies the message sequence
{        where the attribute length is to be placed.
{
{  PARAMETER_LENGTH_SIZE: (output) This parameter specifies the length of
{        the attribute value.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              nfe$outside_bounds_of_sequence
{



*DECK DECK=NFH$QTF_PRIF_OPTIONS EXPAND=TRUE
{  SPECIAL NOTATION in this table is as follows:
{    VE --> VE means that the output file is being transferred from a NOS/VE system to the final NOS/VE system
{    non-VE --> VE means that the output file is being transferred from a non-NOS/VE system to the
{      final NOS/VE system.
{    VE --> S/F VE means that the output file is being transferred from a NOS/VE system to a
{      Store and Forward NOS/VE system
{    non-VE --> S/F VE means that the output file is being transferred from a non-NOS/VE system to a
{      Store and Forward NOS/VE system
{    REMOTE HOST DIR means that the value can be specified on the REMOTE_HOST_DIRECTIVE.
{    SYS ROUT TEXT means that the value can be specified on the SYSTEM ROUTING TEXT
{      as the parameter in parenthesis.
{    IMP ROUT TEXT (L) means that the value is specified in the LOGIN portion of the IMPLICIT ROUTING TEXT.
{    IMP ROUT TEXT (P) means that the value can be specified in the PRINT_FILE parameter portion of the
{      IMPLICIT ROUTING TEXT.
{    PROTOCOL PARAM xx means that the value is specified as the A to A PROTOCOL PARAMETER number xx.
{    JAD means that the value is supplied from the SYSTEM'S JOB ATTRIBUTE DEFAULT for that attribute.
{    A '/' means OR and the precedence is the first value stated (highest) to the last value stated (lowest).

{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ OUTPUT ATTRIBUTE NAME      | VE --> VE         | non-VE --> VE     | VE --> S/F VE     | non-VE --> S/F VE |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ COMMENT_BANNER             |                   | REMOTE HOST DIR   |                   |                   |
{                            | REMOTE HOST DIR   | IMP ROUT TEXT (P) |                   |                   |
{                            | IMP ROUT TEXT (P) | PROTOCOL PARAM 26 |                   | PROTOCOL PARAM 26 |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ CONTROL_FAMILY             |                   | SYS ROUT TEXT(CFM)|                   |                   |
{                            |                   | IMP ROUT TEXT (L) |                   |                   |
{                            | IMP ROUT TEXT (L) | PROTOCOL PARAM 24 |                   | 'NONE'            |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ CONTROL_USER               |                   | SYS ROUT TEXT(CUN)|                   |                   |
{                            |                   | IMP ROUT TEXT (L) |                   |                   |
{                            | IMP ROUT TEXT (L) | PROTOCOL PARAM 26 |                   | 'NONE'            |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ COPIES                     |                   | REMOTE HOST DIR   |                   |                   |
{                            | REMOTE HOST DIR   | SYS ROUT TEXT(REP)|                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ DATA_DECLARATION           |                   |                   |                   | PROTOCOL PARAM 31 |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ DATA_MODE                  |                   | REMOTE HOST DIR   |                   |                   |
{                            | REMOTE HOST DIR   | IMP ROUT TEXT (P) |                   |                   |
{                            | IMP ROUT TEXT (P) | CODED/TRANSPARENT |                   | 'RHF_STRUCTURE'   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ DEVICE                     | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ DEVICE_TYPE                |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ DISPOSITION_CODE           |                   | REMOTE HOST DIR   |                   |                   |
{                            | REMOTE HOST DIR   | SYS ROUT TEXT(DC) |                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) | PROTOCOL PARAM 17 | PROTOCOL PARAM 17 |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ EARLIEST_PRINT_TIME        | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ EXTERNAL_CHARACTERISTICS   |                   | REMOTE HOST DIR   |                   |                   |
{                            | REMOTE HOST DIR   | SYS ROUT TEXT(EC) |                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ FORMS_CODE                 |                   | REMOTE HOST DIR   |                   |                   |
{                            | REMOTE HOST DIR   | SYS ROUT TEXT(FC) |                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ IMPLICIT_ROUTING_TEXT      | PROTOCOL PARAM 33 | PROTOCOL PARAM 33 | PROTOCOL PARAM 33 | PROTOCOL PARAM 33 |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ LATEST_PRINT_TIME          | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ LOGIN_ACCOUNT              |                   | SYS ROUT TEXT(CHx)|                   |                   |
{                            | IMP ROUT TEXT (L) | IMP ROUT TEXT (L) |                   | 'NONE'            |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ LOGIN_FAMILY               |                   | SYS ROUT TEXT(OFM)|                   | 'NONE'            |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ LOGIN_PROJECT              |                   | SYS ROUT TEXT(PJx)|                   |                   |
{                            | IMP ROUT TEXT (L) | IMP ROUT TEXT (L) |                   | 'NONE'            |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ LOGIN_USER                 |                   | SYS ROUT TEXT(OUN)|                   | 'NONE'            |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ OPERATOR_FAMILY            |                   | REMOTE HOST DIR   |                   |                   |
{                            |                   | SYS ROUT TEXT(FM)/|                   |                   |
{                            | REMOTE HOST DIR   |CONTROL_FAMILY/NONE|                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   | 'NONE'            |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ OPERATOR_USER              |                   | REMOTE HOST DIR   |                   |                   |
{                            |                   | SYS ROUT TEXT(UN)/|                   |                   |
{                            | REMOTE HOST DIR   |CONTROL_USER/'NONE'|                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   | 'NONE'            |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ ORIGIN_APPLICATION_NAME    | 'QTFS'            | 'QTFS'            | 'QTFS'            | 'QTFS'            |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ OUTPUT_CLASS               |                   | REMOTE HOST DIR   |                   |                   |
{                            | REMOTE HOST DIR   | SYS ROUT TEXT(SCL)|                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ OUTPUT_DEFERRED_BY_USER    | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ OUTPUT_DESTINATION         |                   | REMOTE HOST DIR   |                   |                   |
{                            | REMOTE HOST DIR   | IMP ROUT TEXT (P) |                   |                   |
{                            | IMP ROUT TEXT (P) | PROTOCOL PARAM 25 |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ OUTPUT_DESTINATION_USAGE   | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   |                   |
{                            | JAD/PUBLIC        | JAD/PUBLIC        | 'QTF'             | 'QTF'             |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ OUTPUT_PRIORITY            | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ PURGE_DELAY                | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ REMOTE_HOST_DIRECTIVE      | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   |                   |
{                            | NULL              | NULL              | PROTOCOL PARAM 5  | PROTOCOL PARAM 5  |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ ROUTING_BANNER             |                   | REMOTE HOST DIR   |                   |                   |
{                            | REMOTE HOST DIR   | IMP ROUT TEXT (P) |                   |                   |
{                            | IMP ROUT TEXT (P) | PROTOCOL PARAM 26 |                   | 'NONE'            |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ SOURCE_LOGICAL_ID          |                   |                   | PROTOCOL PARAM 24 | PROTOCOL PARAM 24 |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ STATION                    | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ SYSTEM_FILE_NAME           | PROTOCOL PARAM 16 |                   | PROTOCOL PARAM 16 |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ SYSTEM_ROUTING_TEXT        |                   |                   | PROTOCOL PARAM 32 | PROTOCOL PARAM 32 |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ USER_FILE_NAME             |                   | REMOTE HOST DIR   |                   |                   |
{                            | REMOTE HOST DIR   | SYS ROUT TEXT(UJN)|                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   |                   |
{                            | PROTOCOL PARAM 26 | PROTOCOL PARAM 26 | PROTOCOL PARAM 26 | PROTOCOL PARAM 26 |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ USER_INFORMATION           | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ USER_JOB_NAME              |                   | REMOTE HOST DIR   |                   |                   |
{                            | REMOTE HOST DIR   | IMP ROUT TEXT (L) |                   |                   |
{                            | IMP ROUT TEXT (L) | PROTOCOL PARAM 26 |                   | 'NONE'            |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ VERTICAL_PRINT_DENSITY     | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ VFU_LOAD_PROCEDURE         | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{                            | IMP ROUT TEXT (P) | IMP ROUT TEXT (P) |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
*DECK DECK=NFH$QTF_SUBJ_OPTIONS EXPAND=TRUE
{  SPECIAL NOTATION in this table is as follows:
{    VE --> VE means that the input file is being transferred from a NOS/VE system to the final NOS/VE system.
{    non-VE --> VE means that the input file is being transferred from a non-NOS/VE system to the
{      final NOS/VE system.
{    VE --> S/F VE means that the input file is being transferred from a NOS/VE system to a
{      Store and Forward NOS/VE system
{    non-VE --> S/F VE means that the input file is being transferred from a non-NOS/VE system to a
{      Store and Forward NOS/VE system
{    REMOTE HOST DIR means that the value can be specified on the REMOTE_HOST_DIRECTIVE.
{    SYS ROUT TEXT means that the value can be specified on the SYSTEM ROUTING TEXT
{      as the parameter in parenthesis.
{    PROTOCOL PARAM xx means that the value is specified as the A to A PROTOCOL PARAMETER number xx.
{    JAD means that the value is supplied from the SYSTEM'S JOB ATTRIBUTE DEFAULT for that attribute.
{    A '/' means OR and the precedence is the first value stated (highest) to the last value stated (lowest).
{    For the OUTPUT_DESTINATION and OUTPUT_DESTINATION_USAGE job submission options the output file
{      can be returned to the originating system (DC=IN) or printed on the executing system (DC=IX).
{      Therefore, these options are specified on the first line for these options and the appropriated
{      value is specified under these options.

{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ JOB ATTRIBUTE NAME         | VE --> VE         | non-VE --> VE     | VE --> S/F VE     | non-VE --> S/F VE |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ COMMENT BANNER             |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+---+---------------+-------------------+
{ CONTROL_FAMILY             |                   | SYS ROUT TEXT(CFM/OFM)|               | 'NONE'            |
{----------------------------+-------------------+-----------------------+---------------+-------------------+
{ CONTROL_USER               |                   | SYS ROUT TEXT(CUN/OUN)|               | 'NONE'            |
{----------------------------+-------------------+-------------------+---+---------------+-------------------+
{ COPIES                     |                   | SYS ROUT TEXT(REP)|                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ CPU_TIME_LIMIT             | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ DATA_DECLARATION           |                   |                   |                   | PROTOCOL PARAM 31 |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ DATA_MODE                  | 'CODED'           | 'CODED'           |                   | 'RHF_STRUCTURE'   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ DEFAULT_LOGIN_ACCOUNT      |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ DEFAULT_LOGIN_FAMILY       | PROTOCOL PARAM 29 |                   |                   |                   |
{                            | JAD               | JAD               |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ DEFAULT_LOGIN_PROJECT      |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ DEFAULT_LOGIN_USER         |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ DEVICE                     |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ DISPOSITION_CODE           |                   | SYS ROUT TEXT(DC) |                   |                   |
{                            | NULL              | NULL              | PROTOCOL PARAM 17 | PROTOCOL PARAM 17 |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ EARLIEST_PRINT_TIME        |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ EARLIEST_RUN_TIME          | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ ENCRYPTED_PASSWORD         |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ EXTERNAL_CHARACTERISTICS   |                   | SYS ROUT TEXT(EC) |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ FORMS_CODE                 |                   | SYS ROUT TEXT(FC) |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ IMMEDIATE_INIT_CANDIDATE   |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ IMPLICIT_ROUTING_TEXT      | PROTOCOL PARAM 33 | PROTOCOL PARAM 33 | PROTOCOL PARAM 33 | PROTOCOL PARAM 33 |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ JOB_ABORT_DISPOSITION      | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ JOB_CLASS                  | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ JOB_DEFERRED_BY_OPERATOR   |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ JOB_DEFERRED_BY_USER       | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ JOB_DESTINATION            | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{                            | NULL              | NULL              | PROTOCOL PARAM 25 | PROTOCOL PARAM 25 |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ JOB_DESTINATION_USAGE      | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{                            | JMC$VE_QTF        | JMC$VE_QTF        | 'QTF'             | 'QTF'             |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ JOB_EXECUTION_RING         | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ JOB_INPUT_DEVICE           |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ JOB_PRIORITY               |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ JOB_QUALIFIER_LIST         | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ JOB_RECOVERY_DISPOSITION   | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ LATEST_PRINT_TIME          |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ LATEST_RUN_TIME            | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{----------------------------+-------------------+---------------- --+-------------------+-------------------+
{ LOGIN_ACCOUNT              |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ LOGIN_COMMAND              |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ LOGIN_COMMAND_SUPPLIED     | TRUE              | TRUE              | FALSE             | FALSE             |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ LOGIN_FAMILY               | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ LOGIN_PASSWORD             |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ LOGIN_PROJECT              |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ LOGIN_USER                 |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ MAGNETIC_TAPE_LIMIT        | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ MAXIMUM_WORKING_SET        | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ OMIT_CLASS_VALIDATION      |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ OMIT_USER_PROLOG_AND_EPILOG|                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ OPERATOR_FAMILY            |                   | REMOTE HOST DIR   |                   |                   |
{                            |                   | SYS ROUT TEXT(FM)/|                   |                   |
{                            | REMOTE HOST DIR   |CONTROL_FAMILY/NONE|                   | 'NONE'            |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ OPERATOR_USER              |                   | REMOTE HOST DIR   |                   |                   |
{                            |                   | SYS ROUT TEXT(UN)/|                   |                   |
{                            | REMOTE HOST DIR   |CONTROL_USER/'NONE'|                   | 'NONE'            |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ OPTIONAL_USER_CAPABILITY   |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ ORIGIN_APPLICATION_NAME    | 'QTFS'            | 'QTFS'            | 'QTFS'            | 'QTFS'            |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ OUTPUT_DEFERRED_BY_USER    |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ OUTPUT_DESTINATION         | PROTOCOL PARAM 24 | PROTOCOL PARAM 24 | PROTOCOL PARAM 24 | PROTOCOL PARAM 24 |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ OUTPUT_DESTINATION_USAGE   | DC=IN | DC=IX     | DC=IN | DC=IX     | DC=IN | DC=IX     | DC=IN | DC=IX     |
{                            |                   |                   |                   |                   |
{                            | 'QTF' | JAD/PUBLIC| 'QTF' | JAD/PUBLIC| 'QTF' |           | 'QTF' |           |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ OUTPUT_DISPOSITION         | DC=IN | DC=IX     | DC=IN  | DC=IX    |                   |                   |
{                            |                   |                   |                   |                   |
{                            | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{                            |       | NORMAL    |        | NORMAL   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ PURGE_DELAY                |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ REMOTE_HOST_DIRECTIVE      | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{                            | NULL              | NULL              | PROTOCOL PARAM 5  | PROTOCOL PARAM 5  |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ REQUIRED_USER_CAPABILITY   |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ ROUTING_BANNER             |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ SITE_INFORMATION           |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ SOURCE_LOGICAL_ID          | PROTOCOL PARAM 24 | PROTOCOL PARAM 24 | PROTOCOL PARAM 24 | PROTOCOL PARAM 24 |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ SRU_LIMIT                  | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ STATION                    | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ SYSTEM_JOB_NAME            | PROTOCOL PARAM 16 |                   | PROTOCOL PARAM 16 |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ SYSTEM_JOB_PARAMETERS      |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ SYSTEM_ROUTING_TEXT        | NULL              | NULL              | PROTOCOL PARAM 32 | PROTOCOL PARAM 32 |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ USER_INFORMATION           | REMOTE HOST DIR   | REMOTE HOST DIR   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ USER_JOB_NAME              |                   | REMOTE HOST DIR   |                   |                   |
{                            | REMOTE HOST DIR   | SYS ROUT TEXT(UJN)|                   |                   |
{                            | PROTOCOL PARAM 26 | PROTOCOL PARAM 26 | PROTOCOL PARAM 26 | PROTOCOL PARAM 26 |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ VERTICAL_PRINT_DENSITY     |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
{ VFU_LOAD_PROCEDURE         |                   |                   |                   |                   |
{----------------------------+-------------------+-------------------+-------------------+-------------------+
*DECK DECK=NFH$RECEIVE_FILE EXPAND=FALSE
{
{      The purpose of this request is to receive the contents of a
{ file from an established connection.  This interface will use the
{ NAM/VE or RHFAM/VE send /receive data routines to perform the file transfer
{ phase protocol exchange.
{
{      The data transfer phase protocol that is used is defined in the
{ RHF A to A Interface Spec (ARH4260).
{
{       NFP$RECEIVE_FILE (CONNECTION_FID, FILE_NAME, FACILITIES,
{             TRANSFER_MODE, BLOCK_SIZE, MIN_TIMEOUT, PROTOCOL_VERSION,
{             NETWORK_TYPE, VALIDATION_RING, ACTIVATE_PROTOCOL_TRACE,
{             FILE SIZE, PROTOCOL_STATE_CONSISTENT, TRANSFER_STATE, STATUS)
{
{ CONNECTION_FID: (input) This parameter specifies the identifier
{   of an open NAM or RHFAM connection to receive the file from.
{
{ FILE_NAME: (input) This parameter specifies the file reference of the
{   file to be received.
{
{ FACILITIES: (input) This parameter specifies the application
{   facilities that have been selected for this connection.
{
{ TRANSFER_MODE: (input) This parameter specifies the data type of the
{   file transfer to perform.
{
{ BLOCK_SIZE: (input) This parameter contains the maximum block
{   size to use for the file transfer. (value is number of bytes)
{
{ MIN_TIMEOUT: (input) This parameter specifies the minimum amount
{   of time to wait between network responses. (value in seconds)
{
{ PROTOCOL_VERSION: (input) This parameter specifies the version
{   of protocol being used.
{
{ NETWORK_TYPE: (input)  This parameter specifies the network that
{   will be used to perform the file transfer.  (NAM/VE or LCN)
{
{ VALIDATION_RING: (input) This parameter specifies the minimal ring
{   requirements for the file to be received.
{
{ ACTIVATE_PROTOCOL_TRACE: (input) This parameter specifies if the protocol
{   trace information is displayed in the joblog.
{
{ FILE_SIZE: (output) This parameter specifies the size of the file
{   transferred.
{
{ PROTOCOL_STATE_CONSISTENT: (output) This parameter specifies
{   whether or not the send_file routine has completed (normally or
{   abnormally) the file transfer phase protocol.
{
{ TRANSFER_STATUS: (output)  This parameter returns the status of the file
{       transfer.
{       CONDITIONS:
{             nfe$application_time_out
{             nfe$protocol_anomaly
{             nfe$terminate_transfer_message
{             nfe$transfer_rejected_message
{
{ STATUS: (output) This parameter returns the results of the request.
{       CONDITIONS:
{             nfe$access_method_timeout
{             nfe$application_protocol_error
{             nfe$application_timeout
{             nfe$connection_closed_by_peer
{
*DECK DECK=NFH$RECEIVE_QUEUE_FILE EXPAND=FALSE
{
{   The purpose of this request is to receive the contents of a queue file
{ from an established connection.  This interface will use the appropriate
{ data transfer routines to perform the data transfer phase protocol exchange.
{
{   The data transfer phase protocol is defined in the RHF A to A Interface
{ Spec (ARH4260).
{
{       NFP$RECEIVE_QUEUE_FILE(CONNECTION_IDENTIFIER, FILE_NAME, FACILITIES,
{             TRANSFER_MODE, BLOCK_SIZE, MIN_TIMEOUT, PROTOCOL_VERSION,
{             NETWORK_TYPE, ACTIVATE_PROTOCOL_TRACE, FILE_SIZE,
{             PROTOCOL_STATE_CONSISTENT, TRANSFER_STATUS, STATUS)
{
{ CONNECTION_IDENTIFIER:  (input) This parameter specifies the identifier of an
{       open NAM/VE or RHFAM connection from which the file will be received.
{
{ FILE_NAME: (input)  This parameter specifies the file reference of the
{       file that will receive the transferred queue file.
{
{ FACILITIES: (input)  This parameter specifies the application facilities that
{       have been selected for this connection.
{
{ TRANSFER_MODE: (input)  This parameter specifies the type of file
{       transfer to perform.
{
{ BLOCK_SIZE: (input)  This parameter contains the maximum block
{       size to use for the file transfer. (value in bytes)
{
{ MIN_TIMEOUT: (input)  This parameter specifies the minimum amount
{       of time to wait between network responses. (value in seconds)
{
{ PROTOCOL_VERSION: (input)  This parameter specifies the version
{       of protocol being used.
{
{ NETWORK_TYPE: (input)  This parameter specifies the network that will be used
{       to perform the file transfer.  (NAM/VE or RHFAM)
{
{ ACTIVATE_PROTOCOL_TRACE: (input) This parameter specifies if the protocol
{   trace information is displayed in the joblog.
{
{ FILE_SIZE: (output)  This parameter returns the size of the file (bytes)
{       that was received.
{
{ PROTOCOL_STATE_CONSISTENT:  (output) This parameter specifies
{       whether or not the send_file routine has completed (normally or
{       abnormally) the file transfer phase protocol.
{
{ TRANSFER_STATUS: (output)  This parameter returns the status of the file
{       transfer.
{       CONDITIONS:
{             nfe$application_time_out
{             nfe$protocol_anomaly
{             nfe$terminate_transfer_message
{             nfe$transfer_rejected_message
{
{ STATUS: (output) This parameter returns the results of the request.
{       CONDITIONS:
{             nfe$access_method_timeout
{             nfe$application_protocol_error
{             nfe$application_timeout
{             nfe$connection_closed_by_peer
{
*DECK DECK=NFH$REMOVE_FROM_WAIT_LISTS EXPAND=FALSE

{
{    The purpose of this request is to remove an activity from the wait_list
{    and from the wait_activity_list.  The wait_list is a list of activities
{    the task is waiting on.  The wait_activity_list contains detailed
{    information, with each entry in the wait_activity_list corresponding to
{    an entry in the wait_list.
{
{        NFP$REMOVE_FROM_WAIT_LISTS (INDEX, WAIT_LIST, WAIT_ACTIVITY_LIST,
{              WAIT_LIST_SEQUENCE, WAIT_ACTIVITY_LIST_SEQUENCE)
{
{  INDEX: (input) This parameter specifies the index in the wait_list and
{        the wait_activity_list that is to be deleted.
{
{  WAIT_LIST: (input, output) This parameter specifies the list of activities
{        that the client is waiting for.
{
{  WAIT_ACTIVITY_LIST: (input, output) This parameter specifies an association
{        list for the wait_list.  Each entry in the wait_activity_list
{        contains detailed information, with each entry in the
{        wait_activity_list corresponding to an entry in the wait_list.
{
{  WAIT_LIST_SEQUENCE: (input, output) This parameter specifies the sequence
{        where the wait_list is stored.
{
{  WAIT_ACTIVITY_LIST_SEQUENCE: (input, output) This parameter specifies the
{        sequence where the wait_activity_list is stored.



*DECK DECK=NFH$REQUEST_ASYNCHRONOUS_TASK EXPAND=FALSE
{
{    The purpose of this request is to start up a child task and set up job
{  local queue communication with the child task.
{
{       NFP$REQUEST_ASYNCHRONOUS_TASK (TRANSFER_SYMBOL, DEBUG_MODE,
{             CONNECTED_TASK, QUEUE_ID, STATUS)
{
{  TRANSFER_SYMBOL: (input) This parameter specifies the name of the transfer
{        symbol of child task to be executed.
{
{  DEBUG_MODE: (input) This parameter specifies whether the child task should
{        be run with debug mode.
{
{  CONNECTED_TASK: (output) This parameter is the task id of the child task.
{
{  QUEUE_ID: (output) This parameter is the queue connection for the parent
{        task.
{
{  STATUS: (output) This parameter specifies the request_status.
{        CONDITIONS:
{              nfe$locked_by_another_task
{              nfe$redundant_initialize_seg
{              nfe$task_not_found
{              nfe$task_not_responding
{
{              amp$get_segment_pointer error conditions
{              amp$open error conditions
{              pmp$define_queue error conditions
{              pmp$execute error conditions
{
{        IDENTIFIER: 'NF'
{
*DECK DECK=NFH$SEND_ADD_FILE_AVAILABLE EXPAND=FALSE

{
{    The purpose of this request is to send a message on the specified
{    connection, requesting that the file entry be added to the file
{    scheduling queue.
{
{        NFP$SEND_ADD_FILE_AVAILABLE (DESCRIPTOR, FILE_STATE,
{              CONNECTION_IDENTIFIER, MESSAGE, STATUS)
{
{  DESCRIPTOR: (input) This parameter specifies the descriptor
{        which identifies the file entry which should be added to the
{        scheduling queue.
{
{  FILE_STATE: (input) This parameter specifies the state of the
{        queue file entry.
{
{  CONNECTION_IDENTIFIER: (input) This parameter specifies the name of the
{        network file identifying the connection on which the message is to
{        be sent.
{
{  MESSAGE: (input, output) This parameter specifies the message sequence
{        where the connection data is to be placed.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$improper_device_class
{              ame$improper_file_id
{              nae$connection_terminated
{              nae$send_outstanding
{              nfe$invalid_descriptor_value
{              nfe$outside_bounds_of_sequence
{


*DECK DECK=NFH$SEND_BATCH_FILE EXPAND=FALSE
{
{      The purpose of this request is to send the contents of an batch file
{ across an established connection.  This interface will use the NAM/VE or
{ RHFAM/VE send / receive data routines to perform the data transfer
{ phase protocol exchange.
{
{      The data transfer phase protocol is defined in the RHF
{ A to A Interface Spec (ARH4260).
{
{     NFP$SEND_BATCH_FILE (CONNECTION_FID, FILE_NAME,
{           LOCAL_FILE_NAME, FACILITIES, TRANSFER_MODE, BLOCK_SIZE,
{           MIN_TIMEOUT, PROTOCOL_VERSION, DESTINATION_USAGE,
{           QUEUE_FILE_PASSWORD, DISPOSITION_CODE, ACTIVATE_PROTOCOL_TRACE,
{           FILE_POSITION, PROTOCOL_STATE_CONSISTENT, TRANSFER_STATUS, STATUS)
{
{ CONNECTION_FID: (input) This parameter specifies the identifier
{   of an open NAM or RHFAM connection on which to send the file.
{
{ FILE_NAME: (input) This parameter specifies the file reference of
{   the source file (an input or output queue file).
{
{ LOCAL_FILE_NAME: (input) This parameter specifies the file reference
{   to a local file (as opposed to a queue file).  Specify OSC$NULL_NAME
{   to transfer the queue file specified by the FILE_NAME parameter.
{   If this parameter is not null, then the local file is transferred
{   instead of the queue file.
{
{ FACILITIES: (input) This parameter specifies the application
{   facilities that have been selected for this connection.
{
{ TRANSFER_MODE: (input) This parameter specifies the data type of the
{   file transfer to perform.
{
{ BLOCK_SIZE: (input) This parameter contains the maximum block
{   size to use for the file transfer. (value is number of bytes)
{
{ MIN_TIMEOUT: (input) This parameter specifies the minimum amount
{   of time to wait between network responses. (value in seconds)
{
{ PROTOCOL_VERSION: (input) This parameter specifies the version
{   of protocol being used.
{
{ VALIDATION_RING: (input) This parameter specifies the minimal ring
{   requirements for the source file.
{
{ DESTINATION_USAGE: (input) This parameter specifies the destination
{   usage of the source file.
{
{ QUEUE_FILE_PASSWORD: (input) This parameter specifies the password
{   required to open the input or output queue file.
{
{ DISPOSITION_CODE: (input) This parameter specifies the destination usage
{   of the queue file.
{
{ ACTIVATE_PROTOCOL_TRACE: (input) This parameter specifies if the protocol
{   trace information is displayed in the joblog.
{
{ FILE_POSITION: (output) This parameter specifies the position of the
{   file upon exit of this routine.  Can be used to re-start a file from
{   where it left off in case of error.
{
{ PROTOCOL_STATE_CONSISTENT: (output) This parameter specifies
{   whether or not the send_file routine has completed (normally or
{   abnormally) the file transfer phase protocol.
{
{ TRANSFER_STATUS: (output)  This parameter returns the status of the file
{   transfer.
{       CONDITIONS:
{             nfe$application_time_out
{             nfe$protocol_anomaly
{             nfe$receiver_problem_no_retry
{             nfe$receiver_problem_retry
{             nfe$sender_problem_no_retry
{             nfe$sender_problem_retry
{             nfe$terminate_transfer_message
{
{ STATUS: (output) This parameter returns the results of the request.
{       CONDITIONS:
{             nfe$access_method_timeout
{             nfe$application_protocol_error
{             nfe$application_timeout
{             nfe$connection_closed_by_peer
{
*DECK DECK=NFH$SEND_BTF_VE_STATUS EXPAND=FALSE
{
{    The purpose of this request is to send a message on the specified
{ connection, indicating the protocol stack(s) supported by this mainframe.
{
{       NFP$SEND_BTF_VE_STATUS (CONNECTION_IDENTIFIER, MESSAGE, STATUS)
{
{
{ CONNECTION_IDENTIFIER: (input)  This parameter specifies the name of the
{       network file identifying the connection on which the message is to be
{       sent.
{
{ MESSAGE: (input, output)  This parameter specifies the message sequence where
{       the connection data is to be placed.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             ame$improper_device_class
{             ame$improper_file_id
{             nae$connection_terminated
{             nae$send_outstanding
{             nfe$outside_bounds_of_sequence
{
*DECK DECK=NFH$SEND_DELETE_FILE_AVAILABLE EXPAND=FALSE

{
{    The purpose of this request is to send a message on the specified
{    connection, requesting that a file entry be deleted from the file
{    scheduling queue.
{
{        NFP$SEND_DELETE_FILE_AVAILABLE (DESCRIPTOR, FILE_HELD_BY_FILTER,
{              FILE_REQUEUED, CONNECTION_IDENTIFIER, MESSAGE, STATUS)
{
{  DESCRIPTOR: (input) This parameter specifies the descriptor
{        which identifies the file entry which should be deleted from the
{        scheduling queue.
{
{  FILE_HELD_BY_FILTER: (input) This parameter specifies if the file was held
{        by a batch output filter.
{
{  FILE_REQUEUED: (input) This parameter specifies if the file was
{        requeued.
{
{  CONNECTION_IDENTIFIER: (input) This parameter specifies the name of the
{        network file identifying the connection on which the message is to
{        be sent.
{
{  MESSAGE: (input, output) This parameter specifies the message sequence
{        where the connection data is to be placed.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$improper_device_class
{              ame$improper_file_id
{              nae$connection_terminated
{              nae$send_outstanding
{              nfe$outside_bounds_of_sequence
{


*DECK DECK=NFH$SEND_FILE EXPAND=FALSE
{
{      The purpose of this request is to send the contents of a file
{ across an established connection.  This interface will use the NAM/VE or
{ RHFAM/VE send / receive data routines to perform the data transfer
{ phase protocol exchange.
{
{      The data transfer phase protocol is defined in the RHF
{ A to A Interface Spec (ARH4260).
{
{       NFP$SEND_FILE (CONNECTION_FID, FILE_NAME, FACILITIES,
{             TRANSFER_MODE, BLOCK_SIZE, MIN_TIMEOUT, PROTOCOL_VERSION,
{             NETWORK_TYPE, VALIDATION_RING, ACTIVATE_PROTOCOL_TRACE,
{             FILE_SIZE, PROTOCOL_STATE_CONSISTENT, TRANSFER_STATUS, STATUS)
{
{ CONNECTION_FID: (input) This parameter specifies the identifier
{   of an open NAM or RHFAM connection on which to send the file.
{
{ FILE_NAME: (input) This parameter specifies the file reference of
{   the source file.
{
{ FACILITIES: (input) This parameter specifies the application
{   facilities that have been selected for this connection.
{
{ TRANSFER_MODE: (input) This parameter specifies the data type of the
{   file transfer to perform.
{
{ BLOCK_SIZE: (input) This parameter contains the maximum block
{   size to use for the file transfer. (value is number of bytes)
{
{ MIN_TIMEOUT: (input) This parameter specifies the minimum amount
{   of time to wait between network responses. (value in seconds)
{
{ PROTOCOL_VERSION: (input) This parameter specifies the version
{   of protocol being used.
{
{ NETWORK_TYPE: (input)  This parameter specifies the network that
{       will be used to perform the file transfer.  (NAM/VE or LCN)
{
{ VALIDATION_RING: (input) This parameter specifies the minimal ring
{   requirements for the source file.
{
{ ACTIVATE_PROTOCOL_TRACE: (input) This parameter specifies if the protocol
{   trace information is displayed in the joblog.
{
{ FILE_SIZE: (output) This parameter specifies the size of the file
{   transferred.
{
{ PROTOCOL_STATE_CONSISTENT: (output) This parameter specifies
{   whether or not the send_file routine has completed (normally or
{   abnormally) the file transfer phase protocol.
{
{ TRANSFER_STATUS: (output)  This parameter returns the status of the file
{       transfer.
{       CONDITIONS:
{             nfe$application_time_out
{             nfe$protocol_anomaly
{             nfe$receiver_problem_no_retry
{             nfe$receiver_problem_retry
{             nfe$sender_problem_no_retry
{             nfe$sender_problem_retry
{             nfe$terminate_transfer_message
{
{ STATUS: (output) This parameter returns the results of the request.
{       CONDITIONS:
{             nfe$access_method_timeout
{             nfe$application_protocol_error
{             nfe$application_timeout
{             nfe$connection_closed_by_peer
{

*DECK DECK=NFH$SEND_FILE_ASSIGNMENT_RESP EXPAND=FALSE

{
{    The purpose of this request is to send a message on the specified
{    connection, indicating whether a previous file assignment message
{    was rejected or accepted.
{
{        NFP$SEND_FILE_ASSIGNMENT_RESP (STATION, DEVICE,
{              FILE_NAME, RESPONSE_CODE, CONNECTION_IDENTIFIER,
{              MESSAGE, STATUS)
{
{  STATION: (input) This parameter specifies name of the station
{        or remote system to which the control facility assigned the file.
{
{  DEVICE: (input) This parameter specifies the name of the batch device
{        or stream to which the control facility assigned the file.
{
{  FILE_NAME: (input) This parameter specifies the system supplied name of
{        the file which the control facility has assigned to a device or
{        stream.
{
{  RESPONSE_CODE: (input) This parameter specifies if the file assignment
{        was accepted or rejected.  The values are nfc$file_assigment_accepted
{        or nfc$file_assignment_rejected.
{
{  MESSAGE: (input, output) This parameter specifies the message sequence
{        where the connection data is to be placed.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$improper_device_class
{              ame$improper_file_id
{              nae$connection_terminated
{              nae$send_outstanding
{              nfe$outside_bounds_of_sequence
{



*DECK DECK=NFH$SEND_MESSAGE_ON_CONNECTION EXPAND=FALSE

{
{    The purpose of this request is to send the data in the message area
{  to a peer application over the specified connection.
{
{        NFP$SEND_MESSAGE_ON_CONNECTION (MESSAGE, LENGTH,
{              CONNECTION_IDENTIFIER, STATUS)
{
{  MESSAGE: (input) This parameter specifies the message sequence
{        where the connection data is to be placed.
{
{  LENGTH: (input) This parameter specifies the length of the data to be
{        sent over the connection.
{
{  CONNECTION_IDENTIFIER: (input) This parameter specifies the name of the
{        network file identifying the connection on which the data is
{        to be sent.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$improper_device_class
{              ame$improper_file_id
{              nae$connection_terminated
{              nae$send_outstanding
{              nae$improper_protocol
{



*DECK DECK=NFH$SEND_MODIFY_FILE_AVAILABLE EXPAND=FALSE

{
{    The purpose of this request is to send a message on the specified
{    connection, requesting that a file entry in the file scheduling
{    queue be modified.
{
{        NFP$SEND_MODIFY_FILE_AVAILABLE (MODIFIED_DESCRIPTOR, DESCRIPTOR,
{              CONNECTION_IDENTIFIER, MESSAGE, STATUS)
{
{  MODIFIED_DESCRIPTOR: (input) This parameter specifies the descriptor
{        which identifies the changed queue file attributes.
{
{  DESCRIPTOR: (input) This parameter specifies the descriptor
{        which identifies the queue file attributes before they were changed.
{
{  CONNECTION_IDENTIFIER: (input) This parameter specifies the name of the
{        network file identifying the connection on which the message is to
{        be sent.
{
{  MESSAGE: (input, output) This parameter specifies the message sequence
{        where the connection data is to be placed.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$improper_device_class
{              ame$improper_file_id
{              nae$connection_terminated
{              nae$send_outstanding
{              nfe$conflicting_descriptors
{              nfe$invalid_descriptor_value
{              nfe$outside_bounds_of_sequence
{


*DECK DECK=NFH$SEND_QUEUE_FILE EXPAND=FALSE
{
{   The purpose of this request is to transfer the contents of a queue file
{ across an established connection.  This interface will use the appropriate
{ data transfer routines to perform the data transfer phase protocol exchange.
{
{   The data transfer phase protocol is defined in the RHF A to A Interface
{ Spec (ARH4260).
{
{       NFP$SEND_QUEUE_FILE (CONNECTION_IDENTIFIER, SOURCE_FILE, FACILITIES,
{             TRANSFER_MODE, BLOCK_SIZE, MIN_TIMEOUT, PROTOCOL_VERSION,
{             NETWORK_TYPE, DESTINATION_USAGE, QUEUE_FILE_KIND,
{             QUEUE_FILE_PASSWORD, ACTIVATE_PROTOCOL_TRACE,
{             PROTOCOL_STATE_CONSISTENT, TRANSFER_STATUS, STATUS)
{
{ CONNECTION_IDENTIFIER: (input)  This parameter specifies the identifier of an
{       open NAM/VE or RHFAM connection file to send the file across.
{
{ SOURCE_FILE: (input)  This parameter specifies the file reference of the
{       source queue file.
{
{ FACILITIES: (input)  This parameter specifies the application facilities that
{       have been selected for this connection.
{
{ TRANSFER_MODE: (input)  This parameter specifies the type of file transfer
{       to perform.
{
{ BLOCK_SIZE: (input)  This parameter contains the maximum block size to use
{       for the file transfer.  (Number of bytes)
{
{ MIN_TIMEOUT: (input)  This parameter specifies the minimum amount of time to
{       wait between network responses.  (Seconds)
{
{ PROTOCOL_VERSION: (input)  This parameter specifies the version of protocol
{       being used.
{
{ NETWORK_TYPE: (input)  This parameter specifies the network that will be used
{       to perform the file transfer.  (NAM/VE or LCN)
{
{ DESTINATION_USAGE: (input)  This parameter specifies the destination
{       usage of the queue file.
{
{ QUEUE_FILE_KIND: (input)  This parameter specifies the type of queue that
{       the file resides in.
{
{ QUEUE_FILE_PASSWORD: (input)  This parameter specifies the password needed
{       to open the queue file.
{
{ ACTIVATE_PROTOCOL_TRACE: (input) This parameter specifies if the protocol
{   trace information is displayed in the joblog.
{
{ PROTOCOL_STATE_CONSISTENT: (output)  This parameter specifies whether or not
{       the send_file routine has completed (normally or abnormally) the file
{       transfer phase protocol.
{
{ TRANSFER_STATUS: (output)  This parameter returns the status of the file
{       transfer.
{       CONDITIONS:
{             nfe$application_time_out
{             nfe$protocol_anomaly
{             nfe$receiver_problem_no_retry
{             nfe$receiver_problem_retry
{             nfe$sender_problem_no_retry
{             nfe$sender_problem_retry
{             nfe$terminate_transfer_message
{
{ STATUS: (output) This parameter returns the results of the request.
{       CONDITIONS:
{             nfe$access_method_timeout
{             nfe$application_protocol_error
{             nfe$application_timeout
{             nfe$connection_closed_by_peer
{
*DECK DECK=NFH$SEND_TERQO_RESPONSE_MSG EXPAND=FALSE

{
{    The purpose of this request is to send a terminate queued output response
{    message to SCFS or OPERATE_STATION.
{
{        NFP$SEND_TERQO_RESPONSE_MSG (IO_STATION_NAME, FILE_NAME, RESPONSE,
{              CONNECTION_ID, MESSAGE, STATUS)
{
{  IO_STATION_NAME: (input) This parameter specifies the name of the station
{        or remote system that the queued output file is associated with.
{
{  FILE_NAME: (input) This parameter specifies the queued output file that is
{        to be terminated.
{
{  RESPONSE: (input) This parameter specifies the response code indicating
{        success or reason for failure.
{
{  CONNECTION_ID: (input) This parameter specifies the connection identifier of
{        the connection to send the message on.
{
{  MESSAGE: (input, output) This parameter specifies the message sequence where
{        the file assignment message is to be read from.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              nfe$invalid_parameter_value
{              nfe$outside_bounds_of_sequence
{

*DECK DECK=NFH$START_BTF_VE_TASK EXPAND=FALSE

{
{    The purpose of this request is to initiate a BTF/VE task that will
{    transfer the file to the device or stream.  BTF/VE will communicate with
{    BTFS/DI to transfer the data to the device or stream.
{
{        NFP$START_BTF_VE_TASK (BTFS_DI_NETWORK_ADDRESS, BTFS_DI_TITLE,
{              STATION, DEVICE, DEVICE_ENVIRONMENT_VARIABLE,
{              SCFS_CAN_HANDLE_FILTER_HOLD, FILE_DESCRIPTOR,
{              NTF_LOCAL_FILE_NAME, DEBUG_ASYNC_TASK, WAIT_LIST,
{              WAIT_ACTIVITY_LIST, WAIT_LIST_SEQUENCE,
{              WAIT_ACTIVITY_LIST_SEQUENCE, NEW_BTF_TASK, STATUS)
{
{  BTFS_DI_NETWORK_ADDRESS: (input) This parameter specifies the BTFS/DI network
{        address that BTF/VE will connect to for the file transfer.
{
{  BTFS_DI_TITLE: (input) This parameter specifies the BTFS/DI title.
{
{  STATION: (input) This parameter specifies the name of the station or remote
{        system that the batch device or stream is associated with.
{
{  DEVICE: (input) This parameter specifies the batch device or stream that is
{        to receive the file.
{
{  DEVICE_ENVIRONMENT_VARIABLE (input)  This parameter specifies the name of
{        an SCL variable that contains device attributes.  If this name is
{        osc$null_name then no variable has been created.
{
{  SCFS_CAN_HANDLE_FILTER_HOLD (input)  This parameter specifies if SCFS is
{        able to handle an output-filter HOLD file_action.
{
{  FILE_DESCRIPTOR: (input)  This parameter specifies the file descriptor
{        containing all necessary information for transferring the file.
{
{   NTF_LOCAL_FILE_NAME: (input) This parameter specifies the file
{        reference to a local file for NTF transfers.  Specify OSC$NULL_NAME
{        for non-NTF transfers.  If this parameter is not null, then the
{        local file instead of a queue file is transferred.
{
{  DEBUG_ASYNC_TASK: (input)  This parameter specifies whether the BTF/VE
{        task should be brought up in debug mode.
{
{  WAIT_LIST: (input, output) This parameter specifies the list of activities
{        that the client is waiting for.
{
{  WAIT_ACTIVITY_LIST: (input, output) This parameter specifies an association
{        list for the wait_list.  Each entry in the wait_activity_list
{        contains detailed information, with each entry in the
{        wait_activity_list corresponding to an entry in the wait_list.
{
{  WAIT_LIST_SEQUENCE: (input, output) This parameter specifies the sequence
{        where the wait_list is stored.
{
{  WAIT_ACTIVITY_LIST_SEQUENCE: (input, output) This parameter specifies the
{        sequence where the wait_activity_list is stored.
{
{  NEW_BTF_TASK: (output) This parameter specifies the btf task that will transfer
{        the data to the destination.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ame$improper_device_class
{              ame$improper_file_id
{              nae$connection_terminated
{              nae$receive_outstanding
{              nae$improper_protocol
{
*DECK DECK=NFH$START_TIMER EXPAND=FALSE

{
{    The purpose of this request is to start a timer based on the free running
{  clock.  The timer can be a backoff timer, where each successive time the
{  timer is set for a longer time period, or it can be set to an arbitrary time
{  by the caller.  The timer is based on microseconds.
{
{        NFP$START_TIMER (WAIT_TIME, TIMER)
{
{  WAIT_TIME: (input) This parameter specifies in microseconds how long the
{        timer is set.  If 0 is given, the timer is a backoff timer.
{
{  TIMER: (input, output) This parameter contains the time interval used in
{        for the backoff timer, and when returned it contains the wait time
{        and when the timer was set.
{
*DECK DECK=NFH$TIMER_EXPIRED EXPAND=FALSE

{
{    The purpose of this function is to see if the given timer has expired.
{
{        NFP$TIMER_EXPIRED (TIMER, LATEST_TIME)
{
{  TIMER: (input) This parameter is the timer with the wait time interval and
{        when the timer was set.
{
{  LATEST_TIME: (input) This parameter specifies a free running clock value to
{        compare against the timer.
{

*DECK DECK=NFH$TRANSFER_FILE EXPAND=FALSE
{
{    The purpose of this procedure is to transfer a file to or from a remote
{ host.
{
{    NFP$TRANSFER_FILE( CONTROL_BLOCK, STATUS )
{
{ CONTROL_BLOCK: (input, output)  Application control block.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{       Any from NAM/VE, RHFAM, NFP$SEND_FILE, NFP$RECEIVE_FILE
{
*DECK DECK=NFH$VERIFY_FAMILY EXPAND=FALSE
{
{    The purpose of this request is to evaluate if a given family name is a
{ local family on the current mainframe.
{
{       NFP$VERIFY_FAMILY (FAMILY_NAME, FAMILY_IS LOCAL, STATUS);
{
{ FAMILY_NAME: (input)  This parameter specifies the name of the family.
{
{ FAMILY_IS_LOCAL: (output)  This parameter specifies the result of the
{       evaluation.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=NFK$KEYPOINTS EXPAND=TRUE

?? FMT (FORMAT := OFF) ??

{ Batch Transfer Services Keypoints.}
  CONST
    nfk$bts_base  = nfk$base + 00;

  CONST
    nfk$access_remote_file           = nfk$bts_base + 0,
      {E  'nfp$access_remote_file' }
      {X  'nfp$access_remote_file' }

    nfk$check_remote_location        = nfk$bts_base + 1,
      {E  'nfp$check_remote_location' }
      {X  'nfp$check_remote_location' }

    nfk$dispose_output_file          = nfk$bts_base + 2,
      {E  'nfp$dispose_output_file' }
      {X  'nfp$dispose_output_file' }

    nfk$end_service                  = nfk$bts_base + 3,
      {E  'nfp$end_service' }
      {X  'nfp$end_service' }

    nfk$initiate_file_server         = nfk$bts_base + 4,
      {E  'nfp$initiate_file_server' }
      {X  'nfp$initiate_file_server' }

    nfk$service_file_access          = nfk$bts_base + 5,
      {E  'nfp$service_file_access' }
      {X  'nfp$service_file_access' }

    nfk$store_rft_parameters         = nfk$bts_base + 6,
      {E  'nfp$store_rft_parameters' }
      {X  'nfp$store_rft_parameters' }

    nfk$terminate_connection         = nfk$bts_base + 7;
      {E  'nfp$terminate_connection' }
      {X  'nfp$terminate_connection' }


{ Common Task Communication Keypoints.}
  CONST
    nfk$ctc_base  = nfk$base + 10;

  CONST
    nfk$request_asynchronous_task    = nfk$ctc_base + 0,
      {E  'nfp$request_asynchronous_task' }
      {X  'nfp$request_asynchronous_task' }

    nfk$begin_asynchronous_task      = nfk$ctc_base + 1,
      {E  'nfp$begin_asynchronous_task' }
      {X  'nfp$begin_asynchronous_task' }

    nfk$get_async_task_message       = nfk$ctc_base + 2,
      {E  'nfp$get_async_task_message' }
      {X  'nfp$get_async_task_message' }

    nfk$put_async_task_message       = nfk$ctc_base + 3,
      {E  'nfp$put_async_task_message' }
      {X  'nfp$put_async_task_message' }

    nfk$end_async_communication      = nfk$ctc_base + 4;
      {E  'nfp$end_async_communication' }
      {X  'nfp$end_async_communication' }


{ Dynamic Storage Manager Keypoints.}
  CONST
    nfk$dsm_base  = nfk$base + 15;

  CONST
    nfk$allocate_space               = nfk$ctc_base + 0,
      {E  'nfp$allocate_space' }
      {X  'nfp$allocate_space' }

    nfk$define_heap                  = nfk$ctc_base + 1,
      {E  'nfp$define_heap' }
      {X  'nfp$define_heap' }

    nfk$free_space                   = nfk$ctc_base + 2,
      {E  'nfp$free_space' }
      {X  'nfp$free_space' }

    nfk$reset_heap                   = nfk$ctc_base + 3;
      {E  'nfp$reset_heap' }
      {X  'nfp$reset_heap' }


{ File Transfer Service Keypoints.}
  CONST
    nfk$fts_base  = nfk$base + 20;


{ Permanent File Transfer Keypoints.}
  CONST
    nfk$ptf_base  = nfk$base + 34;

  CONST
    nfk$check_remote_access          = nfk$ptf_base + 0,
      {E  'nfp$check_remote_access' }
      {X  'nfp$check_remote_access' }

    nfk$perform_remote_access        = nfk$ptf_base + 1;
      {E  'nfp$perform_remote_access' }
      {X  'nfp$perform_remote_access' }


{ Station Operator Utility Keypoints.}
  CONST
    nfk$sou_base  = nfk$base + 38;

{ No keypoints presently assigned for Station Operator Utility }


{ Status and Control Facility Keypoints.}
  CONST
    nfk$scf_base  = nfk$base + 40;


{ Upper limit of range of keypoints.}
  CONST
    nfk$limit     = nfk$base + 49;

?? FMT (FORMAT := ON) ??
*copyc AMK$BASE_KEYPOINT_VALUES
*DECK DECK=NFM$$BLOCK_TEXT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'MODULE nfm$$block_text' ??
MODULE nfm$$block_text;

{  PURPOSE:    To generate a list of strings to represent the block text of
{              a string provided to this procedure.
{
{  DESCRIPTION: This routine uses the characters in a string to access the
{              boolean values of a large predefined record. Using these boolean
{              values, a list of strings is created to emulate the block text
{              found on the banner page of a CDCNET banner.
{
{  INPUT PARAMETERS: PARAMETER_LIST, created and initialized by the SCL function call.
{
{  OUTPUT PARAMETERS: WORK_AREA, the memory used by this procedure to create the SCL
{                       list of strings.
{                     RESULT, a pointer to the actual SCL type returned.
{                     STATUS, the status from clp$evaluate_parameters.
{
{  ALGORITHM:
{              Evaluate the parameters passed on the SCL function call.
{              For row = 1 to max row
{               For each character in the string passed in
{                 For column = 1 to max column
{                   Set the appropriate character value for the character position
{                     in the list of strings.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$parameter_list
*copyc clt$pdt_header
*copyc clt$work_area
*copyc ost$status
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$make_list_value
*copyc clp$make_string_value
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

CONST
    max_row = 10,
    max_column = 10,
    o = FALSE,
    space_between_chars = 3,
    x = TRUE;

CONST
    max_built_str_size = ( (max_row + space_between_chars) * {max_input_str} 256);

  TYPE
    block_char = packed array [1..max_row] of packed array [1..max_column] of boolean;

  VAR
    block_char_array: [READ] array [char] of block_char := [
      REP 33 OF
        { CHR (32)  ' '
        [ [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ]],
        { CHR (33)  '!'
        [ [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ]],
        { CHR (34)  '"'
        [ [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, o, x ,x, x, o, x, x, x, o ],
          [ o, o, o ,x, x, o, o, x, x, o ],
          [ o, o, o ,x, x, o, o, x, x, o ],
          [ o, o, o ,x, o, o, o, x, o, o ],
          [ o, o, x ,o, o, o, x, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ]],
        { CHR (35)  '#'
        [ [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, o, x ,x, o, o, x, x, o, o ]],
        { CHR (36)  '$'
        [ [ o, o, x ,x, x, x, x, x, o, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,o, x, x, o, o, o, o ],
          [ o, x, x ,x, x, x, x, x, o, o ],
          [ o, o, x ,x, x, x, x, x, x, o ],
          [ o, o, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, o, x ,x, x, x, x, x, o, o ]],
        { CHR (37)  '%'
        [ [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, x, x ],
          [ o, x, o ,o, x, o, o, x, x, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, x, x, o ],
          [ o, x, x ,o, o, o, x, o, o, x ],
          [ x, x, o ,o, o, o, o, x, x, o ]],
        { CHR (38)  '&'
        [ [ o, o, o ,o, x, o, o, o, o, o ],
          [ o, o, o ,x, o, x, o, o, o, o ],
          [ o, o, o ,x, o, x, o, o, o, o ],
          [ o, o, o ,o, x, o, o, o, o, o ],
          [ o, o, o ,o, x, o, o, o, o, o ],
          [ o, o, o ,x, o, x, o, o, o, o ],
          [ o, o, x ,o, o, o, x, o, x, o ],
          [ o, x, o ,o, o, o, o, x, o, o ],
          [ o, x, o ,o, o, o, x, o, x, o ],
          [ o, o, x ,x, x, x, o, o, o, x ]],
        { CHR (39)  '''
        [ [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, o, o, x, x, x, o ],
          [ o, o, o ,o, o, o, o, x, x, o ],
          [ o, o, o ,o, o, o, o, x, x, o ],
          [ o, o, o ,o, o, o, o, x, o, o ],
          [ o, o, o ,o, o, o, x, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ]],
        { CHR (40)  '('
        [ [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ]],
        { CHR (41)  ')'
        [ [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ]],
        { CHR (42)  '*'
        [ [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, x, o ,o, x, x, o, o, x, o ],
          [ o, o, x ,o, x, x, o, x, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, x ,o, x, x, o, x, o, o ],
          [ o, x, o ,o, x, x, o, o, x, o ],
          [ o, o, o ,o, o, o, o, o, o, o ]],
        { CHR (43)  '+'
        [ [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ]],
        { CHR (44)  ','
        [ [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,x, x, x, o, o, o, o ],
          [ o, o, x ,x, x, x, x, o, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,o, o, x, o, o, o, o ],
          [ o, o, o ,o, x, o, o, o, o, o ]],
        { CHR (45)  '-'
        [ [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ]],
        { CHR (46)  '.'
        [ [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ]],
        { CHR (47)  '/'
        [ [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, x, x ],
          [ o, o, o ,o, o, o, o, x, x, o ],
          [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, o, o ],
          [ o, x, x ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ]],
        { CHR (48)  'o'
        [ [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, x ,x, x, x, x, x, o, o ],
          [ o, x, x ,o, o, o, o, x, x, o ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ o, x, x ,o, o, o, o, x, x, o ],
          [ o, o, x ,x, x, x, x, x, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ]],
        { CHR (49)  '1'
        [ [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, x ,x, x, x, o, o, o, o ],
          [ o, o, x ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ]],
        { CHR (50)  '2'
        [ [ o, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, o, o ,o, o, o, o, o, x, x ],
          [ o, o, o ,o, o, o, o, o, x, x ],
          [ o, o, o ,o, o, o, o, x, x, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, x, x ,o, o, o, o, o, o, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ]],
        { CHR (51)  '3'
        [ [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, x, x, x, o, o, o ],
          [ o, o, o ,o, o, o, x, x, x, o ],
          [ o, o, o ,o, o, o, o, x, x, o ],
          [ x, o, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ o, x, x ,x, x, x, x, x, x, o ]],
        { CHR (52)  '4'
        [ [ o, o, o ,o, o, x, x, x, o, o ],
          [ o, o, o ,o, x, x, x, x, o, o ],
          [ o, o, o ,x, x, o, x, x, o, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, x, x ,o, o, o, x, x, o, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, o, o, x, x, o, o ]],
        { CHR (53)  '5'
        [ [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, o, o ,o, o, o, o, o, x, x ],
          [ x, o, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, x, x ,x, x, x, x, x, x, o ]],
        { CHR (54)  '6'
        [ [ o, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, o, x ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, x, x ,x, x, x, x, x, x, o ]],
        { CHR (55)  '7'
        [ [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, o, o ,o, o, o, o, x, x, o ],
          [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, o, o ]],
        { CHR (56)  '8'
        [ [ o, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, x, x ,x, x, x, x, x, x, o ]],
        { CHR (57)  '9'
        [ [ o, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, x, x ,x, x, x, x, x, x, x ],
          [ o, o, o ,o, o, o, o, o, x, x ],
          [ x, o, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, x, x ,x, x, x, x, x, x, o ]],
        { CHR (58)  ':'
        [ [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, x ,x, x, x, x, x, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, x ,x, x, x, x, x, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ]],
        { CHR (59)  ';'
        [ [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,x, x, x, o, o, o, o ],
          [ o, o, x ,x, x, x, x, o, o, o ],
          [ o, o, o ,x, x, x, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,x, x, x, o, o, o, o ],
          [ o, o, x ,x, x, x, x, o, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,o, o, x, o, o, o, o ],
          [ o, o, o ,o, x, o, o, o, o, o ]],
        { CHR (60)  '<'
        [ [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, o, o, x, x, o, o ]],
        { CHR (61)  '='
        [ [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ]],
        { CHR (62)  '>'
        [ [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, o, o ]],
        { CHR (63)  '?'
        [ [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, x, x, x, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ]],
        { CHR (64)  '@'
        [ [ o, o, o ,x, x, x, o, o, o, o ],
          [ o, o, x ,x, x, x, x, o, o, o ],
          [ o, x, o ,o, o, o, o, x, o, o ],
          [ o, o, o ,o, o, o, o, x, o, o ],
          [ o, o, o ,x, x, o, o, x, x, o ],
          [ o, o, x ,o, o, x, o, x, x, o ],
          [ o, x, x ,o, o, x, o, x, x, o ],
          [ o, x, x ,o, o, x, o, x, x, o ],
          [ o, o, x ,o, o, x, o, x, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ]],
        { CHR (65)  'A'
        [ [ o, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ]],
        { CHR (66)  'B'
        [ [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ]],
        { CHR (67)  'C'
        [ [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, o, x ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ]],
        { CHR (68)  'D'
        [ [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ]],
        { CHR (69)  'E'
        [ [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, x ,x, x, x, o, o, o, o ],
          [ x, x, x ,x, x, x, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ]],
        { CHR (70)  'F'
        [ [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, x ,x, x, x, o, o, o, o ],
          [ x, x, x ,x, x, x, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ]],
        { CHR (71)  'G'
        [ [ o, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, x, x, x, x, x ],
          [ x, x, o ,o, o, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, x, x ,x, x, x, x, x, x, x ]],
        { CHR (72)  'H'
        [ [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ]],
        { CHR (73)  'I'
        [ [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ]],
        { CHR (74)  'J'
        [ [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ x, x, o ,o, x, x, o, o, o, o ],
          [ x, x, o ,o, x, x, o, o, o, o ],
          [ x, x, x ,x, x, x, o, o, o, o ],
          [ o, x, x ,x, x, o, o, o, o, o ]],
        { CHR (75)  'K'
        [ [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, x, x, o ],
          [ x, x, o ,o, o, o, x, x, o, o ],
          [ x, x, o ,o, x, x, o, o, o, o ],
          [ x, x, x ,x, x, o, o, o, o, o ],
          [ x, x, o ,o, x, x, o, o, o, o ],
          [ x, x, o ,o, o, x, x, o, o, o ],
          [ x, x, o ,o, o, o, x, x, o, o ],
          [ x, x, o ,o, o, o, o, x, x, o ],
          [ x, x, o ,o, o, o, o, o, x, x ]],
        { CHR (76)  'L'
        [ [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ]],
        { CHR (77)  'M'
        [ [ x, x, x ,o, o, o, o, x, x, x ],
          [ x, x, x ,x, o, o, x, x, x, x ],
          [ x, x, o ,x, x, x, x, o, x, x ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ]],
        { CHR (78)  'N'
        [ [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,o, o, o, o, o, x, x ],
          [ x, x, o ,x, o, o, o, o, x, x ],
          [ x, x, o ,x, x, o, o, o, x, x ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,o, o, x, x, o, x, x ],
          [ x, x, o ,o, o, o, x, o, x, x ],
          [ x, x, o ,o, o, o, o, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ]],
        { CHR (79)  'O'
        [ [ o, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, x, x ,x, x, x, x, x, x, o ]],
        { CHR (80)  'P'
        [ [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ]],
        { CHR (81)  'Q'
        [ [ o, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, x, x, x, o, x, x ],
          [ x, x, o ,o, o, o, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ o, x, x ,x, x, x, o, x, x, x ]],
        { CHR (82)  'R'
        [ [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, o ,o, o, x, x, o, o, o ],
          [ x, x, o ,o, o, o, x, x, o, o ],
          [ x, x, o ,o, o, o, o, x, x, o ],
          [ x, x, o ,o, o, o, o, o, x, x ]],
        { CHR (83)  'S'
        [ [ o, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, o, x ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ o, x, x ,x, x, x, x, x, x, x ],
          [ o, o, o ,o, o, o, o, o, x, x ],
          [ x, o, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, x, x ,x, x, x, x, x, x, o ]],
        { CHR (84)  'T'
        [ [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ]],
        { CHR (85)  'U'
        [ [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, x, x ,x, x, x, x, x, x, o ]],
        { CHR (86)  'V'
        [ [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ o, x, x ,o, o, o, o, x, x, o ],
          [ o, x, x ,o, o, o, o, x, x, o ],
          [ o, x, x ,o, o, o, o, x, x, o ],
          [ o, x, x ,o, o, o, o, x, x, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ]],
        { CHR (87)  'W'
        [ [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,x, x, x, x, o, x, x ],
          [ o, x, x ,x, o, o, x, x, x, o ],
          [ o, x, x ,o, o, o, o, x, x, o ]],
        { CHR (88)  'X'
        [ [ x, x, o ,o, o, o, o, o, x, x ],
          [ o, x, x ,o, o, o, o, x, x, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, x, x ,o, o, o, o, x, x, o ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ]],
        { CHR (89)  'Y'
        [ [ x, x, o ,o, o, o, o, o, x, x ],
          [ o, x, x ,o, o, o, o, x, x, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ]],
        { CHR (90)  'Z'
        [ [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, o, o ],
          [ o, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ]],
        { CHR (91)  '['
        [ [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ]],
        { CHR (92)  '\'
        [ [ o, o, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ o, x, x ,o, o, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, o, o, o, x, x, o ],
          [ o, o, o ,o, o, o, o, o, x, x ]],
        { CHR (93)  ']'
        [ [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ]],
        { CHR (94)  '^'
        [ [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, x, x ,o, o, o, o, x, x, o ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ]],
        { CHR (95)  '_'
        [ [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, x, x ,x, x, x, x, x, x, o ]],
        { CHR (96)  '`'
        [ [ o, o, x ,x, x, o, o, o, o, o ],
          [ o, x, x ,x, x, x, o, o, o, o ],
          [ o, x, x ,x, x, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, o, o ],
          [ o, o, o ,x, o, o, o, o, o, o ],
          [ o, o, o ,o, x, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ]],
        { CHR (97)  'a'
        [ [ o, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ]],
        { CHR (98)  'b'
        [ [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ]],
        { CHR (99)  'c'
        [ [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, o, x ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ]],
        { CHR (100) 'd'
        [ [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ]],
        { CHR (101) 'e'
        [ [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, x ,x, x, x, o, o, o, o ],
          [ x, x, x ,x, x, x, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ]],
        { CHR (102) 'f'
        [ [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, x ,x, x, x, o, o, o, o ],
          [ x, x, x ,x, x, x, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ]],
        { CHR (103) 'g'
        [ [ o, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, x, x, x, x, x ],
          [ x, x, o ,o, o, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, x, x ,x, x, x, x, x, x, x ]],
        { CHR (104) 'h'
        [ [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ]],
        { CHR (105) 'i'
        [ [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ]],
        { CHR (106) 'j'
        [ [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, x, x ,x, x, x, x, x, x, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ x, x, o ,o, x, x, o, o, o, o ],
          [ x, x, o ,o, x, x, o, o, o, o ],
          [ x, x, x ,x, x, x, o, o, o, o ],
          [ o, x, x ,x, x, o, o, o, o, o ]],
        { CHR (107) 'k'
        [ [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, x, x, o ],
          [ x, x, o ,o, o, o, x, x, o, o ],
          [ x, x, o ,o, x, x, o, o, o, o ],
          [ x, x, x ,x, x, o, o, o, o, o ],
          [ x, x, o ,o, x, x, o, o, o, o ],
          [ x, x, o ,o, o, x, x, o, o, o ],
          [ x, x, o ,o, o, o, x, x, o, o ],
          [ x, x, o ,o, o, o, o, x, x, o ],
          [ x, x, o ,o, o, o, o, o, x, x ]],
        { CHR (108) 'l'
        [ [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ]],
        { CHR (109) 'm'
        [ [ x, x, x ,o, o, o, o, x, x, x ],
          [ x, x, x ,x, o, o, x, x, x, x ],
          [ x, x, o ,x, x, x, x, o, x, x ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ]],
        { CHR (110) 'n'
        [ [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,o, o, o, o, o, x, x ],
          [ x, x, o ,x, o, o, o, o, x, x ],
          [ x, x, o ,x, x, o, o, o, x, x ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,o, o, x, x, o, x, x ],
          [ x, x, o ,o, o, o, x, o, x, x ],
          [ x, x, o ,o, o, o, o, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ]],
        { CHR (111) 'o'
        [ [ o, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, x, x ,x, x, x, x, x, x, o ]],
        { CHR (112) 'p'
        [ [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, o ,o, o, o, o, o, o, o ]],
        { CHR (113) 'q'
        [ [ o, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, x, x, x, o, x, x ],
          [ x, x, o ,o, o, o, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ o, x, x ,x, x, x, o, x, x, x ]],
        { CHR (114) 'r'
        [ [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ x, x, o ,o, o, x, x, o, o, o ],
          [ x, x, o ,o, o, o, x, x, o, o ],
          [ x, x, o ,o, o, o, o, x, x, o ],
          [ x, x, o ,o, o, o, o, o, x, x ]],
        { CHR (115) 's'
        [ [ o, x, x ,x, x, x, x, x, x, o ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, o ,o, o, o, o, o, o, x ],
          [ x, x, o ,o, o, o, o, o, o, o ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ o, x, x ,x, x, x, x, x, x, x ],
          [ o, o, o ,o, o, o, o, o, x, x ],
          [ x, o, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, x, x ,x, x, x, x, x, x, o ]],
        { CHR (116) 't'
        [ [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ]],
        { CHR (117) 'u'
        [ [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ],
          [ o, x, x ,x, x, x, x, x, x, o ]],
        { CHR (118) 'v'
        [ [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ o, x, x ,o, o, o, o, x, x, o ],
          [ o, x, x ,o, o, o, o, x, x, o ],
          [ o, x, x ,o, o, o, o, x, x, o ],
          [ o, x, x ,o, o, o, o, x, x, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ]],
        { CHR (119) 'w'
        [ [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,o, x, x, o, o, x, x ],
          [ x, x, o ,x, x, x, x, o, x, x ],
          [ o, x, x ,x, o, o, x, x, x, o ],
          [ o, x, x ,o, o, o, o, x, x, o ]],
        { CHR (120) 'x'
        [ [ x, x, o ,o, o, o, o, o, x, x ],
          [ o, x, x ,o, o, o, o, x, x, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, x, x ,o, o, o, o, x, x, o ],
          [ x, x, o ,o, o, o, o, o, x, x ],
          [ x, x, o ,o, o, o, o, o, x, x ]],
        { CHR (121) 'y'
        [ [ x, x, o ,o, o, o, o, o, x, x ],
          [ o, x, x ,o, o, o, o, x, x, o ],
          [ o, o, x ,x, o, o, x, x, o, o ],
          [ o, o, o ,x, x, x, x, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ]],
        { CHR (122) 'z'
        [ [ x, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, o ],
          [ o, o, o ,o, o, o, x, x, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, o, o ],
          [ o, x, x ,x, x, x, x, x, x, x ],
          [ x, x, x ,x, x, x, x, x, x, x ]],
        { CHR (123) '{'
        [ [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, x ,x, o, o, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ]],
        { CHR (124) '|'
        [ [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ]],
        { CHR (125) ' '
        [ [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, o, x, x, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,o, x, x, o, o, o, o ],
          [ o, o, o ,x, x, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ]],
        { CHR (126) '~'
        [ [ o, o, x ,x, o, o, o, o, x, x ],
          [ o, x, x ,x, x, o, o, o, x, x ],
          [ x, x, o ,o, x, x, x, x, x, o ],
          [ x, x, o ,o, o, x, x, x, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ]],
        { CHR (127) DEL
        [ [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ],
          [ o, o, o ,o, o, o, o, o, o, o ]]];

?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE nfp$$block_text', EJECT ??

  PROCEDURE [XDCL] nfp$$block_text
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $block_text (
{   string: string 1..256 = $required
{   )

?? 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$string_type_qualifier,
        recend,
    recend := [
    [1,
    [90, 6, 14, 17, 34, 27, 414],
    clc$function, 1, 1, 1, 0, 0, 0, 0, ''], [
    ['STRING                         ',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, 8, clc$required_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [1, 256, FALSE]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$string = 1;

    VAR
      built_string: string (max_built_str_size),
      char_index: 1..256,
      column_index: 1..max_column,
      list_entry: ^clt$data_value,
      pvt: array [1 .. 1] of clt$parameter_value,
      row_index: 1..max_row,
      string_length: 1..256;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    string_length := STRLENGTH (pvt [p$string].value^.string_value^);

    FOR row_index := 1 TO max_row DO
      built_string := '';
      FOR char_index := 1 TO string_length DO
        FOR column_index := 1 TO max_column DO
          IF block_char_array [pvt[p$string].value^.string_value^(char_index)][row_index][column_index]
              THEN
            built_string ( ((char_index - 1) * (max_column + space_between_chars) + column_index), 1)
               := pvt[p$string].value^.string_value^(char_index);
          ELSE
            built_string ( ((char_index - 1) * (max_column + space_between_chars) + column_index), 1)
               := ' ';
          IFEND;
        FOREND;
        IF char_index < string_length THEN
          built_string (char_index * max_column + (space_between_chars * (char_index - 1)) + 1,
              space_between_chars) := '   ';
        IFEND;
      FOREND;

      IF row_index = 1 THEN
        clp$make_list_value (work_area, result);
        list_entry := result;
      ELSE
        clp$make_list_value (work_area, list_entry^.link);
        list_entry := list_entry^.link;
      IFEND;

      clp$make_string_value (built_string(1, ( (string_length - 1) * (max_row + space_between_chars)
          + max_row)), work_area, list_entry^.element_value);
    FOREND;
  PROCEND nfp$$block_text;
MODEND nfm$$block_text;
*DECK DECK=NFM$$DEVICE_ATTRIBUTES EXPAND=TRUE
FUNCTION $device_attributes, $da (
  device_environment_variable: name = $required
  attribute: key
      (banner_highlight_field, bhf)
      (banner_page_count, bpc)
      (carriage_control_support, ccs)
      (code_set, cs)
      (device_alias_1, da1)
      (device_alias_2, da2)
      (device_alias_3, da3)
      (device_name, dn)
      (device_type, dt)
      (external_characteristics_1, ec1)
      (external_characteristics_2, ec2)
      (external_characteristics_3, ec3)
      (external_characteristics_4, ec4)
      (file_acknowledgement, fa)
      (forms_code_1, fc1)
      (forms_code_2, fc2)
      (forms_code_3, fc3)
      (forms_code_4, fc4)
      (forms_size, fs)
      (maximum_file_size, mfs)
      (page_width, pw)
      (station, s)
      (terminal_model, tm)
      (tip_type, tt)
      (transmission_block_size, tbs)
      (undefined_fe_action, undfa)
      (unsupported_fe_action, unsfa)
      (vertical_print_density, vpd)
      (vfu_load_option, vlo)
      (vfu_load_procedure, vlp)
    keyend = $required
  )

" PURPOSE:
"   This function returns the value of the specified device attribute.
"
" DESIGN:
"   Create internal variable RESULT with the value of the field in the
"   DEVICE_ENVIRONMENT_VARIABLE specified by ATTRIBUTE.  If RESULT is of
"   type FILE then the DEVICE_ENVIRONMENT_VARIABLE parameter is of the
"   wrong type (SCL thought the '.' implied a file, not a record) and
"   return an error, otherwise return RESULT.
"
" NOTE:
"   This function is not meant to be modified.

  include_command 'result = '//device_environment_variable//'.'//attribute

  IF $generic_type(result) = file THEN
    CAUSE $status(false, 'CL' cle$unknown_variable, ..
          $string(device_environment_variable)//' is of wrong type, or ')
  ELSE
    EXIT function WITH result " Normal exit
  IFEND

FUNCEND $device_attributes
*DECK DECK=NFM$$WRAPPED_BLOCK_TEXT EXPAND=TRUE
FUNCTION $wrapped_block_text, $wbt (
  string: string 0..256 = $required
  maximum_line_length: integer 18..255 = 132
  maximum_line_count: integer 13..247 = 247
  )

" PURPOSE:
" This function generates a series of lines of block text for the banner page.
" The length of these lines conforms to the parameter MAXIMUM_LINE_LENGTH, and
" the total number of lines conforms to the parameter MAXIMUM_LINE_COUNT.
"
" DESIGN:
" Calculate the number of block characters that will appear on a line and the
" total number of lines to be generated from the STRING parameter. Call the
" $BLOCK_TEXT function on as many portions of the string that is necessary
" and append the value returned from that function to the return value of
" this function.
"
" NOTE:
" This function is a support function for the GENERATE_BANNER_PAGE procedure.
" It is oriented toward generating lines of block text that currently appear
" on banner pages generated by CDCNET, and provides an interface to the
" $BLOCK_TEXT function that obeys page length & width limits.
"
" The minimum value for MAXIMUM_LINE_LENGTH is obtained by adding the number
" of blanks for indendation to the width of one block character. The maximum
" value is the maximum page width that CDCNET supports for batch devices.
"
" The minimum value for MAXIMUM_LINE_COUNT is the length of one block text
" character. The maximum value is the greatest multiple of the length of a
" block character that is less than the maximum number of lines possible on a
" single printed page for a CDCNET batch device.

" Soft constants for documentation.
  VAR
    blanks_for_indentation: integer 1..5 = 5
    block_char_length: integer 1..13 = 13
    block_char_width: integer 1..13 = 13
    lines_from_$block_text: integer 1..10 = 10
  VAREND

  VAR
    append_index: integer
    block_lines_from_string: integer
    chars_for_block_line: string 1..256
    current_block_line: integer
    current_offset_in_string: integer
    number_of_block_chars_on_line: integer
    return_value: list of string 0..256
    current_block_line_text: list of string 0..256
  VAREND

" Calculate the number of block characters that will fit on one line base on the maximum line
" length specified by the caller and constants associated to the banner page layout.

  number_of_block_chars_on_line = ((maximum_line_length - blanks_for_indentation)/block_char_width)
  IF ((maximum_line_length - blanks_for_indentation) - (number_of_block_chars_on_line * block_char_width)) =..
         10 THEN
    number_of_block_chars_on_line = number_of_block_chars_on_line + 1
  IFEND

" Calculate the number of block lines that will be generated from the string
" based on the width of the block text characters and the number of characters
" in the string.  Check if an additional block line needs to be generated for
" the last few characters on the line which may not fill the full line width.

  block_lines_from_string = $integer(($strlen(string)/number_of_block_chars_on_line))
  IF $mod($strlen(string), number_of_block_chars_on_line) <> 0 THEN
    block_lines_from_string = block_lines_from_string + 1
  IFEND

" Ensure the number of block lines to be generated from the string conforms to
" the maximum line count parameter.  Partial block lines are not printed so the
" integer math rounds the line count down properly.

  IF (block_lines_from_string * block_char_length)> maximum_line_count THEN
    block_lines_from_string = $integer((maximum_line_count/block_char_length))
  IFEND

  FOR current_block_line = 1 TO block_lines_from_string DO

" Find the position in the string which is the start of this block line.

    current_offset_in_string = ((current_block_line - 1)* number_of_block_chars_on_line) + 1

" Pass the characters for this block line to the $BLOCK_TEXT function.

    chars_for_block_line = $substring(string, current_offset_in_string, number_of_block_chars_on_line)
    current_block_line_text = $block_text(chars_for_block_line)

" Append the output of the $BLOCK_TEXT function to the return value of this function.

    FOR append_index = 1 TO lines_from_$block_text DO
      return_value = $add(..
            $substring(' ', 1, blanks_for_indentation, ' ')//current_block_line_text(append_index) ..
            return_value)
    FOREND

" Append the necessary blank lines to the return value of this function.

    FOR append_index = 1 TO (block_char_length - lines_from_$block_text) DO
      return_value = $add((' ') return_value)
    FOREND
  FOREND
  EXIT function WITH $reverse(return_value)

FUNCEND $wrapped_block_text
*DECK DECK=NFM$ACTIVATE_DRJE EXPAND=TRUE
*DECK DECK=NFM$ACTIVATE_FTAM_RESPONDER EXPAND=TRUE
*DECK DECK=NFM$BOF_PROGRAM_DESCRIPTIONS EXPAND=TRUE
create_function_description n=($block_text, $bt) ..
    sp=nfp$$block_text ..
    l=osf$current_library ..
    a=normal_usage

create_program_description n=(create_t_record_file, cretrf) ..
    l=osf$current_library ..
    m=nfm$create_t_record_file ..
    sp=nfp$create_t_record_file ..
    lm=$null ..
    lmo=none ..
    tel=error ..
    dm=false ..
    a=normal_usage

create_program_description n=(emulate_format_effectors, emufe, emma) ..
    l=osf$current_library ..
    m=nfm$emulate_format_effectors ..
    sp=nfp$emulate_format_effectors ..
    lm=$null ..
    lmo=none ..
    tel=error ..
    dm=false ..
    a=normal_usage

create_program_description n=(preprocess_postscript_file, prepf) ..
    l=osf$current_library ..
    m=nfm$preprocess_postscript_file ..
    sp=nfp$preprocess_postscript_file ..
    lm=$null ..
    lmo=none ..
    tel=error ..
    dm=false ..
    a=normal_usage

create_program_description n=(preprocess_uri, preu) ..
    l=osf$current_library ..
    m=nfm$preprocess_uri ..
    sp=nfp$preprocess_uri ..
    lm=$null ..
    lmo=none ..
    tel=error ..
    dm=false ..
    a=normal_usage
*DECK DECK=NFM$BTF_CLIENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NFM$BTF_CLIENT' ??
MODULE nfm$btf_client;

{
{  PURPOSE:
{     This module is used to service the Status and Control Facility (SCF)
{     and the Network Transfer Facility (NTF) requests to send data to a
{     specific destination.
{
{  DESCRIPTION:
{     The Batch Transfer Facility (BTF/VE) executes as an asynchronous task of
{     the calling task (SCF or NTF). Information is communicated between
{     BTF and the calling task in data packets using NFM$COMMON_TASK_COMMUNICATION. These
{     packets are the request to send data to a particular destination, and the
{     completion packet when the request has terminated (either normally or
{     abnormally).
{
{     The actual data transfer protocol is performed by NFM$RHF_PROTOCOL_ENGINE and
{     NFP$SEND_BATCH_FILE.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$system_family
*copyc nat$network_address
*copyc nfc$command_definitions
*copyc nfc$parameter_00_definitions
*copyc nfc$parameter_03_definitions
*copyc nfc$parameter_04_definitions
*copyc nfc$parameter_06_definitions
*copyc nfc$parameter_08_definitions
*copyc nfc$parameter_09_definitions
*copyc nfc$parameter_12_definitions
*copyc nfc$parameter_13_definitions
*copyc nfc$parameter_16_definitions
*copyc nfc$parameter_20_definitions
*copyc nfc$parameter_22_definitions
*copyc nfc$parameter_25_definitions
*copyc nfc$parameter_26_definitions
*copyc nfc$parameter_30_definitions
*copyc nfc$parameter_31_definitions
*copyc nfc$parameter_32_definitions
*copyc nfc$parameter_51_definitions
*copyc nfc$parameter_52_definitions
*copyc nfc$parameter_53_definitions
*copyc nfc$parameter_54_definitions
*copyc nfc$parameter_55_definitions
*copyc nfc$parameter_59_definitions
*copyc nfc$parameter_60_definitions
*copyc nfc$parameter_definitions
*copyc nfe$batch_transfer_facility
*copyc nfe$batch_transfer_services
*copyc nft$application_file_descriptor
*copyc nft$batch_file_transport_info
*copyc nft$control_block
*copyc nft$command_set
*copyc nft$intertask_message
*copyc nft$last_command_received
*copyc nft$last_command_sent
*copyc nft$page_width
*copyc nft$parameter_set
*copyc nft$protocol_commands
*copyc nft$network_address
*copyc nft$network_type
*copyc nft$parameter_00_values
*copyc nft$parameter_25_definition
*copyc nft$parameter_31_type
*copyc nft$parameter_52_definition
*copyc nft$parameter_rules
*copyc nft$parameter_values
*copyc nft$protocol_parameters
*copyc nft$required_param_on_command
*copyc ost$name
*copyc sfe$counter_array_size_range
*copyc sfe$descriptive_data_size
*copyc sfe$invalid_statistic_name
*copyc sft$counter
*copyc sft$statistic_identifier
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$get_next
*copyc amp$return
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_string_to_integer
*copyc clp$create_environment_variable
*copyc clp$delete_variable
*copyc clp$evaluate_token
*copyc clp$get_variable
*copyc clp$get_work_area
*copyc clp$include_line
*copyc clp$log_comment
*copyc clp$trimmed_string_size
*copyc fsp$open_file
*copyc jmp$emit_communication_stat
*copyc jmp$update_output_status
*copyc nap$display_message
*copyc nfp$begin_asynchronous_task
*copyc nfp$dispose_user_msg_to_log
*copyc nfp$end_async_communication
*copyc nfp$format_message_to_job_log
*copyc nfp$get_async_task_message
*copyc nfp$initialize_control_block
*copyc nfp$nam_request_connect
*copyc nfp$put_async_task_message
*copyc nfp$receive_command
*copyc nfp$send_batch_file
*copyc nfp$send_command
*copyc nfp$set_abnormal_if_normal
*copyc nfp$string_length
*copyc nfp$terminate_path
*copyc osp$append_status_parameter
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pmp$compute_time_dif_in_seconds
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_compact_date_time
*copyc pmp$get_unique_name
*copyc pmp$log
*copyc pmp$wait
*copyc sfp$convert_stat_name_to_code
*copyc sfp$emit_statistic
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    fa$comment_banner = 1,
    fa$data_mode = 2,
    fa$forms_code = 3,
    fa$page_length = 4,
    fa$page_width = 5,
    fa$routing_banner = 6,
    fa$vertical_print_density = 7,
    fa$vfu_load_procedure = 8,
    fa$max = 8;

  TYPE
    file_dispositions = (hold, print_and_hold, print_and_terminate, terminate);

  VAR
    btf_required_parameters: [READ, STATIC] nft$required_param_on_command := [
          { Null Command } [],
          { RFT } [nfc$protocol_id, nfc$facilities, nfc$file_length, nfc$file_name,
          nfc$minimum_timeout_interval, nfc$host_type, nfc$transfer_lid, nfc$system_routing_text],
          { RPOS } [nfc$protocol_id, nfc$host_type],
          { RNEG } [nfc$protocol_id, nfc$state_of_transfer],
          { GO } [],
          { STOP } [nfc$state_of_transfer],
          { STOPR } [nfc$state_of_transfer],
          { ETP } [],
          { ETPR } [],
          { FINI } []],

    parameter_00_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p00_min_size, nfc$p00_max_size, [nfc$rft, nfc$rpos, nfc$rneg], [], [], [],
          FALSE]],

    parameter_01_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_02_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_03_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p03_min_size, nfc$p03_max_size, [nfc$rft], [], [], [], FALSE]],

    parameter_04_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p04_min_param_len, nfc$p04_max_param_len, [nfc$rneg, nfc$stop, nfc$stopr], [],
          [], [], FALSE]],

    parameter_05_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_06_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p06_min_param_len, nfc$p06_max_param_len, [nfc$rft], [], [], [], FALSE]],

    parameter_07_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_08_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p08_min_param_len, nfc$p08_max_param_len_b101, [], [], [], [], FALSE]],

    parameter_09_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p09_min_param_len, nfc$p09_max_param_len_b101, [], [], [], [], FALSE]],

    parameter_10_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_11_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_12_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p12_min_size_b101, nfc$p12_max_size_b101, [], [], [], [], FALSE]],

    parameter_13_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p13_min_param_size, nfc$p13_max_param_size, [], [], [], [], FALSE]],

    parameter_16_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p16_min_param_length, nfc$p16_max_param_length_b101, [nfc$rft], [], [], [],
          FALSE]],

    parameter_17_rules: [READ, STATIC] nft$parameter_rules := [
          { A102 } [FALSE],
          { A101 } [FALSE],
          { B101 } [FALSE]],

    parameter_18_rules: [READ, STATIC] nft$parameter_rules := [
          { A102 } [FALSE],
          { A101 } [FALSE],
          { B101 } [TRUE, nfc$min_param_size, nfc$min_param_size, [], [], [], [], FALSE]],

    parameter_19_rules: [READ, STATIC] nft$parameter_rules := [
          { A102 } [FALSE],
          { A101 } [FALSE],
          { B101 } [TRUE, nfc$min_param_size, nfc$min_param_size, [], [], [], [], FALSE]],

    parameter_20_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p20_min_size, nfc$p20_max_size, [nfc$rft], [], [], [], FALSE]],

    parameter_21_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_22_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p22_min_size, nfc$p22_max_size, [nfc$rft, nfc$rpos], [], [], [], FALSE]],

    parameter_23_rules: [READ, STATIC] nft$parameter_rules := [
          { A102 } [FALSE],
          { A101 } [FALSE],
          { B101 } [FALSE]],

    parameter_24_rules: [READ, STATIC] nft$parameter_rules := [
          { A102 } [FALSE],
          { A101 } [FALSE],
          { B101 } [FALSE]],

    parameter_25_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p25_min_param_size, nfc$p25_max_param_size_b101, [nfc$rft], [], [], [], FALSE]],

    parameter_26_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p26_min_param_length, nfc$p26_max_param_length_b101, [], [], [], [], FALSE]],

    parameter_27_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_28_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_29_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p29_min_param_size_b101, nfc$p29_max_param_size_b101, [nfc$rft], [], [], [],
          FALSE ]],

    parameter_30_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p30_min_param_size, nfc$p30_max_param_size, [], [], [], [], FALSE]],

    parameter_31_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p31_min_param_length_b101, nfc$p31_max_param_length_b101, [], [], [], [],
          FALSE]],

    parameter_32_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p32_min_param_length_b101, nfc$p32_max_param_length_b101, [nfc$rft], [], [], [],
          FALSE]],

    parameter_33_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_51_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p51_min_param_length, nfc$p51_max_param_length, [], [], [], [], FALSE]],

    parameter_52_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p52_min_param_length, nfc$p52_max_param_length, [], [], [], [], FALSE]],

    parameter_53_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p53_min_param_length, nfc$p53_max_param_length, [], [], [], [], FALSE]],

    parameter_54_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p54_min_param_length, nfc$p54_max_param_length, [], [], [], [], FALSE]],

    parameter_55_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p55_min_param_length, nfc$p55_max_param_length, [], [], [], [], FALSE]],

    parameter_56_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_57_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_58_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_59_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p59_min_param_length, nfc$p59_max_param_length, [], [], [], [], FALSE]],

    parameter_60_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [TRUE, nfc$p60_min_param_len, nfc$p60_max_param_length, [], [], [], [], FALSE]],

    parameter_90_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_91_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_92_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_93_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_94_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_95_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_96_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_97_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_98_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_99_rules: [READ, STATIC] nft$parameter_rules := [
          { A101 } [FALSE],
          { A102 } [FALSE],
          { B101 } [FALSE]],

    parameter_rules: [READ, STATIC] nft$parameter_rules_array :=
          [^parameter_00_rules, ^parameter_01_rules, ^parameter_02_rules, ^parameter_03_rules,
          ^parameter_04_rules, ^parameter_05_rules, ^parameter_06_rules, ^parameter_07_rules,
          ^parameter_08_rules, ^parameter_09_rules, ^parameter_10_rules, ^parameter_11_rules,
          ^parameter_12_rules, ^parameter_13_rules, ^parameter_16_rules, ^parameter_17_rules,
          ^parameter_18_rules, ^parameter_19_rules, ^parameter_20_rules, ^parameter_21_rules,
          ^parameter_22_rules, ^parameter_23_rules, ^parameter_24_rules, ^parameter_25_rules,
          ^parameter_26_rules, ^parameter_27_rules, ^parameter_28_rules, ^parameter_29_rules,
          ^parameter_30_rules, ^parameter_31_rules, ^parameter_32_rules, ^parameter_33_rules,
          ^parameter_51_rules, ^parameter_52_rules, ^parameter_53_rules, ^parameter_54_rules,
          ^parameter_55_rules, ^parameter_56_rules, ^parameter_57_rules, ^parameter_58_rules,
          ^parameter_59_rules, ^parameter_60_rules, ^parameter_90_rules, ^parameter_91_rules,
          ^parameter_92_rules, ^parameter_93_rules, ^parameter_94_rules, ^parameter_95_rules,
          ^parameter_96_rules, ^parameter_97_rules, ^parameter_98_rules, ^parameter_99_rules];

?? TITLE := 'connection_initiation_phase', EJECT ??

{
{ PURPOSE:  Handle connection establishment phase.
{
{ DESCRIPTION:  This procedure initiates the creation of a connection to
{               the peer application.
{
{ INPUT PARAMETERS:
{            Network_address         : Address to establish a connection with
{            Station                 : Name of the station or remote system
{            Device                  : Name of the batch device or stream
{
{ INPUT/OUTPUT PARAMETERS:
{            Network_file_name       : name for network file
{            Control_block           : Record containing protocol, file and status information
{
{ OUTPUT PARAMETERS:
{            Status                  : Returned status
{
{ ALGORITHM:
{            Send connect request
{

  PROCEDURE connection_initiation_phase
    (    network_address: nat$network_address;
         station: ost$name;
         device: ost$name;
     VAR network_file_name: ost$name;
     VAR control_block: nft$control_block;
     VAR status: ost$status);

    CONST
      application_version = 1;

    VAR
      ignore_status: ost$status,
      trace_string: string (256),
      trace_string_length: integer;

    status.normal := TRUE;


    pmp$get_unique_name (network_file_name, status);
    IF status.normal THEN

{  Connect to the BTFS/DI address passed by calling task.

      control_block.path.network_file := ^network_file_name;
      IF control_block.protocol_trace THEN
        STRINGREP(trace_string, trace_string_length, 'BTF request connect STATION=',
              station(1, clp$trimmed_string_size(station)), ', DEVICE=', device(1,
              clp$trimmed_string_size(device)));
        pmp$log(trace_string(1, trace_string_length), ignore_status);
      IFEND;
      nfp$nam_request_connect (control_block.path.network_file^, control_block.application,
            control_block.application_server, network_address, application_version, station, device,
            control_block.path.network_file_id, status);

      IF status.normal THEN
        control_block.path.network_type := nfc$network_nam;
        control_block.path.path_connected := TRUE;
      ELSE
        nfp$set_abnormal_if_normal (status, control_block.local_status);
      IFEND;
    IFEND;

  PROCEND connection_initiation_phase;
?? OLDTITLE ??
?? NEWTITLE := 'convert_sequence_to_hex_string', EJECT ??

{ PURPOSE:
{   This procedure converts a sequence to a printable string.
{   The sequence is interpreted as hex digits.

    PROCEDURE convert_sequence_to_hex_string
      (    sequence: ^SEQ ( * );
           sequence_length: integer;
       VAR output_string: ^string ( * );
       VAR output_string_size: integer);

      TYPE
        mask_byte_to_integer = record
          case boolean of
          = FALSE =
            byte_value: string (1),
          = TRUE =
            integer_value: 0 .. 0ff(16),
          casend,
        recend;

      VAR
        conversion_mask: mask_byte_to_integer,
        i: integer,
        sequence_pointer: ^SEQ ( * ),
        single_value: string (4),
        local_status: ost$status,
        string_pointer: ^string ( * );

      sequence_pointer := sequence;
      RESET sequence_pointer;
      NEXT string_pointer: [sequence_length] IN sequence_pointer;

      output_string_size := 0;

      FOR i := 1 TO sequence_length DO
        conversion_mask.byte_value := string_pointer^ (i, 1);
        IF (output_string_size > 0) OR (conversion_mask.integer_value <> 0) THEN
          clp$convert_integer_to_rjstring (conversion_mask.integer_value + 100(16), 16, FALSE, '0',
                single_value, local_status);
          output_string^ (output_string_size + 1, 2) := single_value (3, 2);
          output_string_size := output_string_size + 2;
        IFEND;
      FOREND;

    PROCEND convert_sequence_to_hex_string;

?? OLDTITLE ??
?? NEWTITLE := 'execute_batch_output_filter', EJECT ??

{ PURPOSE:
{   This procedure executes the main batch output filter.

  PROCEDURE execute_batch_output_filter
    (    intertask_message: nft$intertask_message;
     VAR btf_completion_packet: nft$intertask_message;
     VAR control_block: nft$control_block;
     VAR file_attributes_var: ost$name;
     VAR file_disposition: file_dispositions;
     VAR file_disposition_var: ost$name;
     VAR output: amt$local_file_name;
     VAR output_file_contains_data: boolean;
     VAR output_file_var: ost$name;
     VAR statistics_file: amt$local_file_name;
     VAR statistics_file_contains_data: boolean;
     VAR status: ost$status);

{   TYPE
{    file_attributes: record
{        comment_banner: string 0..31 = $optional
{        data_mode: key
{          (coded, c)
{          (transparent, t)
{        keyend = $optional
{        forms_code : string 0..6 = $optional
{        page_length: integer 0..4398046511103 = $optional
{        page_width: integer 10..255 = $optional
{        routing_banner: string 0..31 = $optional
{        vertical_print_density: key
{          six, eight
{        keyend = $optional
{        vfu_load_procedure: any of
{          key
{            none
{          keyend
{          name
{        anyend = $optional
{      recend
{   TYPEND

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
   fa_type_specification : [STATIC, READ, cls$declaration_section] record
      header: clt$type_specification_header,
      name: string (15),
      qualifier: clt$record_type_qualifier,
      field_spec_1: clt$field_specification,
      element_type_spec_1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      field_spec_2: clt$field_specification,
      element_type_spec_2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      field_spec_3: clt$field_specification,
      element_type_spec_3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      field_spec_4: clt$field_specification,
      element_type_spec_4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      field_spec_5: clt$field_specification,
      element_type_spec_5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      field_spec_6: clt$field_specification,
      element_type_spec_6: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      field_spec_7: clt$field_specification,
      element_type_spec_7: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
      recend,
      field_spec_8: clt$field_specification,
      element_type_spec_8: 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$name_type_qualifier,
        recend,
      recend,
    recend := [
      [1, 15, clc$record_type], 'FILE_ATTRIBUTES', [8],
      ['COMMENT_BANNER                 ', clc$optional_field, 8], [[1, 0,
  clc$string_type], [0, 31, FALSE]],
      ['DATA_MODE                      ', clc$optional_field, 155], [[1, 0,
  clc$keyword_type], [4], [
        ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['CODED                          ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['T                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['TRANSPARENT                    ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
        ],
      ['FORMS_CODE                     ', clc$optional_field, 8], [[1, 0,
  clc$string_type], [0, 6, FALSE]],
      ['PAGE_LENGTH                    ', clc$optional_field, 20], [[1, 0,
  clc$integer_type], [0, 4398046511103, 10]],
      ['PAGE_WIDTH                     ', clc$optional_field, 20], [[1, 0,
  clc$integer_type], [10, 255, 10]],
      ['ROUTING_BANNER                 ', clc$optional_field, 8], [[1, 0,
  clc$string_type], [0, 31, FALSE]],
      ['VERTICAL_PRINT_DENSITY         ', clc$optional_field, 81], [[1, 0,
  clc$keyword_type], [2], [
        ['EIGHT                          ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['SIX                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
        ],
      ['VFU_LOAD_PROCEDURE             ', clc$optional_field, 69], [[1, 0,
  clc$union_type], [[clc$keyword_type, clc$name_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
        ]
      ];

?? FMT (FORMAT := ON) ??
?? POP ??



{ TYPE
{   file_disposition: key
{       (hold, h)
{       (print_and_hold, pah)
{       (print_and_terminate, pat)
{       (terminate, t)
{     keyend
{ TYPEND

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    fd_type_specification : [STATIC, READ, cls$declaration_section] record
      header: clt$type_specification_header,
      name: string (16),
      qualifier: clt$keyword_type_qualifier,
      keyword_specs: array [1 .. 8] of clt$keyword_specification,
    recend := [
      [1, 16, clc$keyword_type], 'FILE_DISPOSITION', [8], [
      ['H                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['HOLD                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['PAH                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['PAT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['PRINT_AND_HOLD                 ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['PRINT_AND_TERMINATE            ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 4]]
      ];

?? FMT (FORMAT := ON) ??
?? POP ??

{ TYPE
{   output: file
{ TYPEND

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    o_type_specification : [STATIC, READ, cls$declaration_section] record
      header: clt$type_specification_header,
      name: string (6),
    recend := [
      [1, 6, clc$file_type], 'OUTPUT'];

?? FMT (FORMAT := ON) ??

?? POP ??

    CONST
      filter_library = '$SYSTEM.BATCH_DEVICE_SUPPORT.STANDARD_FILTERS.COMMAND_LIBRARY';

    VAR
      file_name_size: integer,
      filter_command: string (512),
      filter_command_error: boolean,
      filter_status: ost$status,
      ignore_status: ost$status,
      last_size: integer,
      line_index: ost$status_message_line_count,
      local_status: ost$status,
      log_names: array [1..2] of ost$name,
      msg_line: string (80),
      page_width_string: string (3),
      preset: clt$data_value,
      size: integer,
      type_header: ^clt$type_specification_header,
      type_keyword_qualifier: ^clt$keyword_type_qualifier,
      type_mismatch: boolean,
      type_name: ^string ( * ),
      type_record_qualifier: ^clt$record_type_qualifier,
      var_access_mode: clt$data_access_mode,
      var_class: clt$variable_class,
      var_evaluation_method: clt$expression_eval_method,
      var_type_specification: ^clt$type_specification,
      var_value: ^clt$data_value,
      var_work_area_p: ^^clt$work_area;

?? NEWTITLE := 'check_if_file_contains_data', EJECT ??

{ PURPOSE:
{   This procedure checks is the specified file contains any data.

    PROCEDURE check_if_file_contains_data
      (    file: amt$local_file_name;
       VAR file_contains_data: boolean;
       VAR status: ost$status);

      VAR
        file_exists: boolean,
        file_previously_opened: boolean,
        get_attributes: ^amt$get_attributes;

      status.normal := TRUE;

      PUSH get_attributes: [1 .. 1];
      get_attributes^ [1].key := amc$null_attribute;
      amp$get_file_attributes (file, get_attributes^, file_exists, file_previously_opened,
            file_contains_data, status);

    PROCEND check_if_file_contains_data;
?? OLDTITLE ??

?? NEWTITLE := 'display_status_in_logs', EJECT ??

{ PURPOSE:
{   This displays a status message in the specified logs.
{
{ NOTE:
{   The lines to convert the status type into lines of text were copied
{   from the procedure NAP$DISPLAY_MESSAGE in order to use the
{   CLP$LOG_COMMENT interface instead of PMP$LOG.

    PROCEDURE display_status_in_logs
      (    status_message: ost$status;
           log_names: array [1..*] of ost$name);

      VAR
        ignore_status: ost$status,
        line_count: ^ost$status_message_line_count,
        line_index: ost$status_message_line_count,
        line_length: ^ost$status_message_line_size,
        message: ost$status_message,
        message_sequence: ^ost$status_message,
        text: ^ost$status_message_line;

      osp$format_message (status_message, osc$current_message_level, osc$max_status_message_line,
          message, ignore_status);
      message_sequence := ^message;
      RESET message_sequence;
      NEXT line_count IN message_sequence;

      FOR line_index := 1 TO line_count^ DO
        NEXT line_length IN message_sequence;
        NEXT text: [line_length^] IN message_sequence;
        clp$log_comment(text^, log_names, ignore_status);
      FOREND;

    PROCEND display_status_in_logs;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    filter_status.normal := TRUE;

{ Create unique file name for STATISTICS_FILE parameter.

    pmp$get_unique_name (statistics_file, ignore_status);

{ Create SCL variables for VAR parameters.
{ Note that SCL variable names cannot start with a '$' so it is substituted
{ with a 'V'.

{ - Create OUTPUT variable.  Set it as unititialized.

    pmp$get_unique_name (output_file_var, ignore_status);
    output_file_var (1, 1) := 'V';

    preset.kind := clc$unspecified;

    clp$create_environment_variable (output_file_var, clc$job_scope, clc$read_write,
          clc$immediate_evaluation, #SEQ (o_type_specification), ^preset, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ - Create FILE_ATTRIBUTES variable.  Initialize it to values in the output file
{   descriptor.

    pmp$get_unique_name (file_attributes_var, ignore_status);
    file_attributes_var (1, 1) := 'V';

    preset.kind := clc$record;
    PUSH preset.field_values: [1 .. fa$max];

{ - Set COMMENT_BANNER.

    preset.field_values^ [fa$comment_banner].name := 'COMMENT_BANNER';
    PUSH preset.field_values^ [fa$comment_banner].value;
    preset.field_values^ [fa$comment_banner].value^.kind := clc$string;
    PUSH preset.field_values^ [fa$comment_banner].value^.string_value:
          [clp$trimmed_string_size (intertask_message.btf_file_descriptor.output_descriptor.comment_banner)];
    preset.field_values^ [fa$comment_banner].value^.string_value^ :=
          intertask_message.btf_file_descriptor.output_descriptor.comment_banner;

{ - Set DATA_MODE.

    preset.field_values^ [fa$data_mode].name := 'DATA_MODE';
    PUSH preset.field_values^ [fa$data_mode].value;
    preset.field_values^ [fa$data_mode].value^.kind := clc$keyword;
    IF intertask_message.btf_file_descriptor.output_descriptor.data_mode = jmc$coded_data THEN
      preset.field_values^ [fa$data_mode].value^.keyword_value := 'CODED';
    ELSE
      preset.field_values^ [fa$data_mode].value^.keyword_value := 'TRANSPARENT';
    IFEND;

{ - Set FORMS_CODE.

    preset.field_values^ [fa$forms_code].name := 'FORMS_CODE';
    PUSH preset.field_values^ [fa$forms_code].value;
    preset.field_values^ [fa$forms_code].value^.kind := clc$string;
    PUSH preset.field_values^ [fa$forms_code].value^.string_value:
          [clp$trimmed_string_size (intertask_message.btf_file_descriptor.output_descriptor.forms_code)];
    preset.field_values^ [fa$forms_code].value^.string_value^ :=
          intertask_message.btf_file_descriptor.output_descriptor.forms_code;

{ - Set PAGE_LENGTH.

    preset.field_values^ [fa$page_length].name := 'PAGE_LENGTH';
    PUSH preset.field_values^ [fa$page_length].value;
    preset.field_values^ [fa$page_length].value^.kind := clc$integer;
    preset.field_values^ [fa$page_length].value^.integer_value.value :=
          intertask_message.btf_file_descriptor.output_descriptor.page_length;
    preset.field_values^ [fa$page_length].value^.integer_value.radix := 10(10);
    preset.field_values^ [fa$page_length].value^.integer_value.radix_specified := FALSE;

{ - Set PAGE_WIDTH.

    preset.field_values^ [fa$page_width].name := 'PAGE_WIDTH';
    PUSH preset.field_values^ [fa$page_width].value;
    preset.field_values^ [fa$page_width].value^.kind := clc$integer;
    preset.field_values^ [fa$page_width].value^.integer_value.value :=
          intertask_message.btf_file_descriptor.output_descriptor.page_width;
    preset.field_values^ [fa$page_width].value^.integer_value.radix := 10(10);
    preset.field_values^ [fa$page_width].value^.integer_value.radix_specified := FALSE;

{ - Set ROUTING_BANNER.

    preset.field_values^ [fa$routing_banner].name := 'ROUTING_BANNER';
    PUSH preset.field_values^ [fa$routing_banner].value;
    preset.field_values^ [fa$routing_banner].value^.kind := clc$string;
    PUSH preset.field_values^ [fa$routing_banner].value^.string_value:
          [clp$trimmed_string_size (intertask_message.btf_file_descriptor.output_descriptor.routing_banner)];
    preset.field_values^ [fa$routing_banner].value^.string_value^ :=
          intertask_message.btf_file_descriptor.output_descriptor.routing_banner;

{ - Set VERTICAL_PRINT_DENSITY.

    preset.field_values^ [fa$vertical_print_density].name := 'VERTICAL_PRINT_DENSITY';
    PUSH preset.field_values^ [fa$vertical_print_density].value;
    preset.field_values^ [fa$vertical_print_density].value^.kind := clc$keyword;
    IF intertask_message.btf_file_descriptor.output_descriptor.vertical_print_density =
          jmc$vertical_print_density_6 THEN
      preset.field_values^ [fa$vertical_print_density].value^.keyword_value := 'SIX';
    ELSE
      preset.field_values^ [fa$vertical_print_density].value^.keyword_value := 'EIGHT';
    IFEND;

{ - Set VFU_LOAD_PROCEDURE.

    preset.field_values^ [fa$vfu_load_procedure].name := 'VFU_LOAD_PROCEDURE';
    PUSH preset.field_values^ [fa$vfu_load_procedure].value;
    IF intertask_message.btf_file_descriptor.output_descriptor.vfu_load_procedure = osc$null_name THEN
      preset.field_values^ [fa$vfu_load_procedure].value^.kind := clc$keyword;
      preset.field_values^ [fa$vfu_load_procedure].value^.keyword_value := 'NONE';
    ELSE
      preset.field_values^ [fa$vfu_load_procedure].value^.kind := clc$name;
      preset.field_values^ [fa$vfu_load_procedure].value^.name_value :=
            intertask_message.btf_file_descriptor.output_descriptor.vfu_load_procedure;
    IFEND;

    clp$create_environment_variable (file_attributes_var, clc$job_scope, clc$read_write,
          clc$immediate_evaluation, #SEQ (fa_type_specification), ^preset, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ - Create FILE_DISPOSITION variable.  Initialize it to PRINT_AND_TERMINATE.

    pmp$get_unique_name (file_disposition_var, ignore_status);
    file_disposition_var (1, 1) := 'V';

    preset.kind := clc$keyword;
    preset.keyword_value := 'PRINT_AND_TERMINATE';

    clp$create_environment_variable (file_disposition_var, clc$job_scope, clc$read_write,
          clc$immediate_evaluation, #SEQ (fd_type_specification), ^preset, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Build main filter command parameters.

    STRINGREP (filter_command, size, filter_library, '.MAIN_BATCH_OUTPUT_FILTER');
    last_size := size;

    STRINGREP (filter_command, size, filter_command (1, last_size), ' i=(',
          intertask_message.btf_file_descriptor.output_descriptor.system_file_name, ', ', '''',
          intertask_message.btf_file_descriptor.q_file_password, ''')');
    last_size := size;

    STRINGREP (filter_command, size, filter_command (1, last_size), ' o=', output_file_var);
    last_size := size;

    STRINGREP (filter_command, size, filter_command (1, last_size), ' sf=', statistics_file);
    last_size := size;

    STRINGREP (filter_command, size, filter_command (1, last_size), ' dev=',
          intertask_message.device_environment_variable);
    last_size := size;

    STRINGREP (filter_command, size, filter_command (1, last_size), ' fa=', file_attributes_var);
    last_size := size;

    STRINGREP (filter_command, size, filter_command (1, last_size), ' fd=', file_disposition_var);
    last_size := size;

{ Execute main batch output filter.

    clp$include_line (filter_command (1, last_size), FALSE, osc$null_name, filter_status);
    filter_command_error := NOT filter_status.normal;

    IF filter_status.normal THEN

    /filter_post_processing/
      BEGIN

        clp$get_work_area (#RING (^var_class), var_work_area_p, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Find out if a value was returned for OUTPUT and if file contains data.

{ - Get the value of the OUTPUT variable.

        output_file_contains_data := FALSE;
        clp$get_variable (output_file_var, var_work_area_p^, var_class, var_access_mode,
              var_evaluation_method, var_type_specification, var_value, filter_status);
        IF NOT filter_status.normal THEN
          EXIT /filter_post_processing/;
        IFEND;

        IF (var_value <> NIL) THEN
          file_name_size := clp$trimmed_string_size (var_value^.file_value^);
          IF (file_name_size > 8) AND (var_value^.file_value^ (1, 8) = ':$LOCAL.') THEN
            output := var_value^.file_value^ (9, file_name_size - 8);
            check_if_file_contains_data (output, output_file_contains_data, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'EXECUTE_BATCH_OUTPUT_FILTER',
                  filter_status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'OUTPUT not :$LOCAL file',
                  filter_status);
            EXIT /filter_post_processing/;
          IFEND;
        IFEND;

{ Find out if the STATISTICS_FILE contains data.

        check_if_file_contains_data (statistics_file, statistics_file_contains_data, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Get the value of the FILE_DISPOSITION variable.

        clp$get_variable (file_disposition_var, var_work_area_p^, var_class, var_access_mode,
              var_evaluation_method, var_type_specification, var_value, filter_status);
        IF NOT filter_status.normal THEN
          EXIT /filter_post_processing/;
        IFEND;

{ - Verify that the type of variable read is same as the one that was created.

        type_mismatch := TRUE;
        RESET var_type_specification;
        NEXT type_header IN var_type_specification;
        IF (type_header^.version = fd_type_specification.header.version) AND
              (type_header^.name_size = fd_type_specification.header.name_size) AND
              (type_header^.kind = fd_type_specification.header.kind) THEN
          NEXT type_name: [type_header^.name_size] IN var_type_specification;
          IF type_name <> NIL THEN
            IF type_name^ = fd_type_specification.name THEN
              NEXT type_keyword_qualifier IN var_type_specification;
              IF type_keyword_qualifier <> NIL THEN
                IF type_keyword_qualifier^ = fd_type_specification.qualifier THEN
                  type_mismatch := FALSE;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
        IF (type_mismatch OR (var_value = NIL)) THEN
          osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'EXECUTE_BATCH_OUTPUT_FILTER',
                filter_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'FILE_DISPOSITION var type mismatch',
                filter_status);
          EXIT /filter_post_processing/;
        IFEND;

        IF var_value^.keyword_value = 'HOLD' THEN
          file_disposition := hold;
        ELSEIF var_value^.keyword_value = 'PRINT_AND_HOLD' THEN
          file_disposition := print_and_hold;
        ELSEIF var_value^.keyword_value = 'PRINT_AND_TERMINATE' THEN
          file_disposition := print_and_terminate;
        ELSEIF var_value^.keyword_value = 'TERMINATE' THEN
          file_disposition := terminate;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'EXECUTE_BATCH_OUTPUT_FILTER',
                filter_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'FILE_DISPOSITION keyword error',
                filter_status);
          EXIT /filter_post_processing/;
        IFEND;
        IF ((file_disposition = hold) OR (file_disposition = print_and_hold)) AND
              (NOT intertask_message.scfs_can_handle_filter_hold) THEN
          osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'EXECUTE_BATCH_OUTPUT_FILTER',
                filter_status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'Version of SCFS cannot handle FILE_DISPOSITION of HOLD.', filter_status);
          EXIT /filter_post_processing/;
        IFEND;

        IF (file_disposition = print_and_hold) OR (file_disposition = print_and_terminate) THEN

{ If file is to print then update RFT parameter values with FILE_ATTRIBUTES
{ returned by filter.
{ NOTE:  PAGE_LENGTH is ignored since this value is not transmitted to BTFS/DI.

          clp$get_variable (file_attributes_var, var_work_area_p^, var_class, var_access_mode,
                var_evaluation_method, var_type_specification, var_value, filter_status);
          IF NOT filter_status.normal THEN
            EXIT /filter_post_processing/;
          IFEND;

{ - Verify that the type of variable read is same as the one that was created.

          type_mismatch := TRUE;
          RESET var_type_specification;
          NEXT type_header IN var_type_specification;
          IF (type_header^.version = fa_type_specification.header.version) AND
                (type_header^.name_size = fa_type_specification.header.name_size) AND
                (type_header^.kind = fa_type_specification.header.kind) THEN
            NEXT type_name: [type_header^.name_size] IN var_type_specification;
            IF type_name <> NIL THEN
              IF type_name^ = fa_type_specification.name THEN
                NEXT type_record_qualifier IN var_type_specification;
                IF type_record_qualifier <> NIL THEN
                  IF type_record_qualifier^ = fa_type_specification.qualifier THEN
                    type_mismatch := FALSE;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
          IF (type_mismatch OR (var_value = NIL) OR (var_value^.field_values = NIL)) THEN
            osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'EXECUTE_BATCH_OUTPUT_FILTER',
                  filter_status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'FILE_ATTRIBUTES var type mismatch',
                  filter_status);
            EXIT /filter_post_processing/;
          IFEND;

{ - Update USER_BANNER_MESSAGE (from COMMENT_BANNER).

          IF var_value^.field_values^ [fa$comment_banner].name = 'COMMENT_BANNER' THEN
            control_block.user_banner_message.size := clp$trimmed_string_size
                  (var_value^.field_values^ [fa$comment_banner].value^.string_value^);
            IF control_block.user_banner_message.size > jmc$output_comment_banner_size THEN
              control_block.user_banner_message.size := jmc$output_comment_banner_size;
            IFEND;
            control_block.user_banner_message.value := var_value^.field_values^ [fa$comment_banner].value^.
                  string_value^ (1, control_block.user_banner_message.size);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'EXECUTE_BATCH_OUTPUT_FILTER',
                  filter_status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'FILE_ATTRIBUTES type error (CB)',
                  filter_status);
            EXIT /filter_post_processing/;
          IFEND;

{ - Update BANNER_ROUTING_TEXT (from ROUTING_BANNER).

          IF var_value^.field_values^ [fa$routing_banner].name = 'ROUTING_BANNER' THEN
            control_block.banner_routing_text.size := clp$trimmed_string_size
                  (var_value^.field_values^ [fa$routing_banner].value^.string_value^);
            IF control_block.banner_routing_text.size > jmc$output_routing_banner_size THEN
              control_block.banner_routing_text.size := jmc$output_routing_banner_size;
            IFEND;
            control_block.banner_routing_text.value := var_value^.field_values^ [fa$routing_banner].value^.
                  string_value^ (1, control_block.banner_routing_text.size);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'EXECUTE_BATCH_OUTPUT_FILTER',
                  filter_status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'FILE_ATTRIBUTES type error (RB)',
                  filter_status);
            EXIT /filter_post_processing/;
          IFEND;

{ - Update VFU_LOAD_PROCEDURE.

          IF var_value^.field_values^ [fa$vfu_load_procedure].name = 'VFU_LOAD_PROCEDURE' THEN
            IF var_value^.field_values^ [fa$vfu_load_procedure].value^.kind = clc$name THEN
              control_block.vfu_load_procedure.value := var_value^.field_values^ [fa$vfu_load_procedure].
                    value^.name_value;
            ELSEIF var_value^.field_values^ [fa$vfu_load_procedure].value^.kind = clc$keyword THEN
              control_block.vfu_load_procedure.value := '';
            ELSE
              osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'EXECUTE_BATCH_OUTPUT_FILTER',
                    filter_status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    'FILE_ATTRIBUTES.VFU_LOAD_PROCEDURE kind error', filter_status);
              EXIT /filter_post_processing/;
            IFEND;
            control_block.vfu_load_procedure.size := clp$trimmed_string_size
                  (control_block.vfu_load_procedure.value);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'EXECUTE_BATCH_OUTPUT_FILTER',
                  filter_status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'FILE_ATTRIBUTES type error (VLP)',
                  filter_status);
            EXIT /filter_post_processing/;
          IFEND;

{ The following RFT parameters are updated only when the filter has created
{ an output file.

          IF output_file_contains_data THEN

{ - Update DATA_DECLARATION (from DATA_MODE).

            IF var_value^.field_values^ [fa$data_mode].name = 'DATA_MODE' THEN
              IF var_value^.field_values^ [fa$data_mode].value^.keyword_value = 'CODED' THEN
                control_block.data_declaration := nfc$p31_ascii_c8;
              ELSEIF var_value^.field_values^ [fa$data_mode].value^.keyword_value = 'TRANSPARENT' THEN
                control_block.data_declaration := nfc$p31_undef_unstructured_uu;
              ELSE
                osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'EXECUTE_BATCH_OUTPUT_FILTER',
                      filter_status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      'FILE_ATTRIBUTES.DATA_MODE keyword error', filter_status);
                EXIT /filter_post_processing/;
              IFEND;
            ELSE
              osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'EXECUTE_BATCH_OUTPUT_FILTER',
                    filter_status);
              osp$append_status_parameter (osc$status_parameter_delimiter, 'FILE_ATTRIBUTES type error (DM)',
                    filter_status);
              EXIT /filter_post_processing/;
            IFEND;

{ - Update ECHO_TEXT (from PAGE_WIDTH).

            IF var_value^.field_values^ [fa$page_width].name = 'PAGE_WIDTH' THEN
              IF var_value^.field_values^ [fa$page_width].value^.integer_value.value <
                    nfc$minimum_page_width THEN
                var_value^.field_values^ [fa$page_width].value^.integer_value.value := nfc$minimum_page_width;
              ELSEIF var_value^.field_values^ [fa$page_width].value^.integer_value.value >
                    nfc$maximum_page_width THEN
                var_value^.field_values^ [fa$page_width].value^.integer_value.value := nfc$maximum_page_width;
              IFEND;
              clp$convert_integer_to_rjstring (var_value^.field_values^ [fa$page_width].value^.integer_value.
                    value, {radix} 10, {include_radix} FALSE, {filler} '0', page_width_string, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              IF control_block.send_echo_text.first_text <> NIL THEN
                control_block.send_echo_text.first_text^.value := page_width_string;
              ELSE
                osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'EXECUTE_BATCH_OUTPUT_FILTER',
                      filter_status);
                osp$append_status_parameter (osc$status_parameter_delimiter, 'ECHO_TEXT not initialized',
                      filter_status);
                EXIT /filter_post_processing/;
              IFEND;
            ELSE
              osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'EXECUTE_BATCH_OUTPUT_FILTER',
                    filter_status);
              osp$append_status_parameter (osc$status_parameter_delimiter, 'FILE_ATTRIBUTES type error (PW)',
                    filter_status);
              EXIT /filter_post_processing/;
            IFEND;

{ - Update VERTICAL_PRINT_DENSITY.

            IF var_value^.field_values^ [fa$vertical_print_density].name = 'VERTICAL_PRINT_DENSITY' THEN
              IF var_value^.field_values^ [fa$vertical_print_density].value^.keyword_value = 'SIX' THEN
                control_block.vertical_print_density := jmc$vertical_print_density_6;
              ELSEIF var_value^.field_values^ [fa$vertical_print_density].value^.keyword_value = 'EIGHT' THEN
                control_block.vertical_print_density := jmc$vertical_print_density_8;
              ELSE
                osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'EXECUTE_BATCH_OUTPUT_FILTER',
                      filter_status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      'FILE_ATTRIBUTES.VPD keyword error', filter_status);
                EXIT /filter_post_processing/;
              IFEND;
            ELSE
              osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'EXECUTE_BATCH_OUTPUT_FILTER',
                    filter_status);
              osp$append_status_parameter (osc$status_parameter_delimiter, 'FILE_ATTRIBUTES type error (VPD)',
                    filter_status);
              EXIT /filter_post_processing/;
            IFEND;

          IFEND;
        IFEND;

      END /filter_post_processing/;
    IFEND;

    IF NOT filter_status.normal THEN

      log_names [1] := 'JOB';
      log_names [2] := 'SYSTEM';

{ Determine if the error was because the MAIN_BATCH_OUTPUT_FILTER is not
{ available.  If this is the case, issue a warning and print the queue file.

      IF filter_command_error THEN
        STRINGREP (filter_command, size, '$system.display_command_information c=', filter_library,
              '.MAIN_BATCH_OUTPUT_FILTER', ' o=$null');

        clp$include_line (filter_command (1, last_size), FALSE, osc$null_name, local_status);

        IF NOT local_status.normal THEN
          btf_completion_packet.filter_aborted := FALSE;
          file_disposition := print_and_terminate;
          clp$log_comment ('*** BATCH OUTPUT FILTER ERROR - Cannot execute MAIN_BATCH_OUTPUT_FILTER:',
              log_names, ignore_status);
          display_status_in_logs (filter_status, log_names);
          RETURN;
        IFEND;
      IFEND;

{ There are problems with the batch output filter.  Hold the file and log
{ significant info - SCF will notify operator of filter error.

      btf_completion_packet.filter_aborted := TRUE;
      file_disposition := hold;
      clp$log_comment ('*** BATCH OUTPUT FILTER ERROR ***', log_names, ignore_status);
      clp$log_comment ('***   STATUS:', log_names, ignore_status);
      display_status_in_logs (filter_status, log_names);
      STRINGREP (msg_line, size, '***   SYSTEM_FILE_NAME:  ',
            intertask_message.btf_file_descriptor.output_descriptor.system_file_name);
      clp$log_comment (msg_line (1, size), log_names, ignore_status);
      STRINGREP (msg_line, size, '***   STATION:  ', intertask_message.btf_file_descriptor.output_descriptor.
            station);
      clp$log_comment (msg_line (1, size), log_names, ignore_status);
      STRINGREP (msg_line, size, '***   DEVICE:  ', intertask_message.btf_file_descriptor.output_descriptor.
            device);
      clp$log_comment (msg_line (1, size), log_names, ignore_status);
    IFEND

  PROCEND execute_batch_output_filter;
?? OLDTITLE ??
?? NEWTITLE := 'init_and_data_transfer_phase', EJECT ??

{
{ PURPOSE:   This routine performs the initiation and data transfer phases
{            of the A-A protocol for a file transfer.
{
{ DESCRIPTION:
{            This routine is state table driven.  The state table takes into
{            account two things: last command sent and last command received.
{            The actions possible are send command, receive command and
{            transfer file.
{
{ INPUT PARAMETERS:
{            File Descriptor      : Input or Output Descriptor
{
{ INPUT/OUTPUT PARAMETERS:
{            Control_block        : Record containing protocol, file and status information
{
{ OUTPUT PARAMETERS:
{            Status               : Return status
{
{ ALGORITHM:
{            WHILE not done DO
{              Get state (last_sent, last_received)
{              Case state Of
{              = send_command     =>  nfp$send_command
{              = receive_command  =>  nfp$receive_command
{              = transfer_file    =>  nfp$send_batch_file
{              = terminate        =>  exit procedure
{              Casend
{              If rneg situation, set next state
{            WHILEND
{

  PROCEDURE init_and_data_transfer_phase
    (    file_descriptor: nft$application_file_descriptor;
         local_file_name: amt$local_file_name;
         ntf_local_file: boolean;
     VAR control_block: nft$control_block;
     VAR status: ost$status);

    CONST
      btf_number_of_protocol_states = 8;

    TYPE
      btf_protocol_actions = (nfc$btf_send_command, nfc$btf_receive_command, nfc$btf_start_transfer,
            nfc$btf_terminate),

      btf_protocol_states = array [1 .. btf_number_of_protocol_states] of nft$btf_state_table,

      nft$btf_state_table = record
        last_command_sent: nft$last_command_sent,
        last_command_received: nft$last_command_received,
        case action: btf_protocol_actions of
        = nfc$btf_send_command =
          send_command: nft$protocol_commands,
          send_parameters: nft$parameter_set,
        = nfc$btf_receive_command =
          legal_receive_commands: nft$command_set,
        = nfc$btf_start_transfer =
          transfer_send_command: nft$protocol_commands,
          transfer_send_parameters: nft$parameter_set,
        = nfc$btf_terminate =
        casend,
      recend,

      parameter_09_message = record
        CASE boolean OF
        = FALSE =
          text: string (16),
        = TRUE =
          number_of_lines: string (8),
          bytes_transferred: string (8),
        CASEND,
      recend;

    VAR
      btf_protocol: [READ, STATIC] btf_protocol_states := [

      [nfc$unknown_command,         { Last Command Sent }
            nfc$unknown_command,         { Last Command Received }
            nfc$btf_send_command,        { Send Command To Remote }
            nfc$rft,                     { Command to Send }
            [nfc$protocol_id, nfc$facilities, nfc$file_length, nfc$max_block_size, nfc$file_name,
            nfc$accounting_limit, nfc$minimum_timeout_interval, nfc$host_type, nfc$transfer_lid,
            nfc$data_declaration, nfc$system_routing_text]],

      [nfc$rft,                     { Last Command Sent }
            nfc$unknown_command,         { Last Command Received }
            nfc$btf_receive_command,     { Receive Command From Remote }
            [nfc$rpos, nfc$rneg]],       { Command to Receive }

      [nfc$rft,                     { Last Command Sent }
            nfc$rpos,                    { Last Command Received }
            nfc$btf_start_transfer,      { Send Command To Remote }
            nfc$go,                      { Command to Send }
            []],

      [nfc$rft,                     { Last Command Sent }
            nfc$rneg,                    { Last Command Received }
            nfc$btf_send_command,        { Send Command To Remote }
            nfc$stop,                    { Command to Send }
            [nfc$state_of_transfer]],

      [nfc$go,                      { Last Command Sent }
            nfc$rpos,                    { Last Command Received }
            nfc$btf_send_command,        { Send Command To Remote }
            nfc$stop,                    { Command to Send }
            [nfc$state_of_transfer]],

      [nfc$stop,                    { Last Command Sent }
            nfc$rneg,                    { Last Command Received }
            nfc$btf_receive_command,     { Receive Command From Remote }
            [nfc$stopr]],                { Command to Receive }

      [nfc$stop,                    { Last Command Sent }
            nfc$rpos,                    { Last Command Received }
            nfc$btf_receive_command,     { Receive Command From Remote }
            [nfc$stopr]],                { Command to Receive }

      [nfc$stop,                    { Last Command Sent }
            nfc$stopr,                   { Last Command Received }
            nfc$btf_terminate]],         { Terminate Transfer }

      account_message: parameter_09_message,
      destination_usage: jmt$destination_usage,
      device_type: jmt$output_device_type,
      elapsed_time: integer,
      end_time: ost$date_time,
      ignored_params: nft$parameter_set,
      ignore_status: ost$status,
      index: 1 .. btf_number_of_protocol_states,
      local_status: ost$status,
      modified_params: nft$parameter_set,
      new_state: btf_protocol_actions,
      number_of_lines: clt$integer,
      output_statistics: ^jmt$output_file_statistic_data,
      protocol_consistent: boolean,
      received_params: nft$parameter_set,
      send_parameters: nft$parameter_set,
      start_time: ost$date_time,
      state_known: boolean,
      statistic_data: jmt$comm_acct_statistic_data,
      system_file_name: jmt$system_supplied_name,
      transfer_mode: nft$transfer_modes,
      transfer_status: ost$status;


    status.normal := TRUE;
    control_block.negotiate_protocol := FALSE;
    control_block.last_command_sent := nfc$unknown_command;
    control_block.last_command_received := nfc$unknown_command;
    control_block.state_of_transfer.normal := TRUE;
    control_block.local_status.normal := TRUE;
    control_block.remote_status.normal := TRUE;
    control_block.send_operator_messages := NIL;
    control_block.send_user_messages := NIL;
    control_block.send_account_messages := NIL;
    control_block.send_errorlog_messages := NIL;
    transfer_status.normal := TRUE;
    protocol_consistent := TRUE;

    CASE control_block.data_declaration OF
    = nfc$p31_host_dependent_uh =
      transfer_mode := nfc$ve_to_ve_mode;
    = nfc$p31_unspecified, nfc$p31_ascii_c6, nfc$p31_ascii_c8 =
      transfer_mode := nfc$coded_data_mode;
    = nfc$p31_undef_unstructured_uu =
      transfer_mode := nfc$transparent_data_mode;
    ELSE
    CASEND;

    IF file_descriptor.file_kind = nfc$output_file THEN
      destination_usage := file_descriptor.output_descriptor.output_destination_usage;
      device_type := file_descriptor.output_descriptor.device_type;
    ELSE {file_descriptor.file_kind = nfc$input_file}
      destination_usage := file_descriptor.input_descriptor.job_destination_usage;
{  Set device_type to a value that will ensure that VPD and VLP are not sent on RFT.
{  Don't rely on destination_usage to be set correctly.
      device_type := jmc$output_device_punch;
    IFEND;

{  Continue with protocol until a STOPR is received or connection is terminated

  /advance_state_table_loop/
    WHILE control_block.path.path_connected DO
      state_known := FALSE;

    /state_loop/
      FOR index := LOWERVALUE (index) TO UPPERVALUE (index) DO
        IF ((btf_protocol [index].last_command_sent = control_block.last_command_sent) AND
              (btf_protocol [index].last_command_received = control_block.last_command_received)) THEN
          state_known := TRUE;
          EXIT /state_loop/ {----->
        IFEND;
      FOREND /state_loop/;

      IF NOT state_known THEN
        osp$set_status_abnormal (nfc$status_id, nfe$invalid_command_code, ' ', status);
        EXIT /advance_state_table_loop/ {----->
      IFEND;

      new_state := btf_protocol [index].action;

      CASE new_state OF

      = nfc$btf_send_command =

        send_parameters := btf_protocol [index].send_parameters;

        IF btf_protocol [index].send_command = nfc$rft THEN
          pmp$get_compact_date_time (start_time, status);
          IF NOT status.normal THEN
            nfp$set_abnormal_if_normal (status, control_block.local_status);
            RETURN; {----->
          IFEND;
          IF control_block.send_job_name.size <> 0 THEN
            send_parameters := send_parameters + $nft$parameter_set [nfc$job_name];
          IFEND;
          IF control_block.user_file_name.size <> 0 THEN
            send_parameters := send_parameters + $nft$parameter_set [nfc$user_file_name];
          IFEND;
          IF destination_usage <> jmc$ntf_usage THEN
            IF control_block.banner_date_and_time.size <> 0 THEN
              send_parameters := send_parameters + $nft$parameter_set [nfc$banner_date_and_time];
            IFEND;
            IF control_block.banner_routing_text.size <> 0 THEN
              send_parameters := send_parameters + $nft$parameter_set [nfc$banner_routing_text];
            IFEND;
            IF control_block.user_banner_message.size <> 0 THEN
              send_parameters := send_parameters + $nft$parameter_set [nfc$user_banner_text];
            IFEND;
            IF control_block.installation_banner_message.size <> 0 THEN
              send_parameters := send_parameters + $nft$parameter_set [nfc$installation_banner_text];
            IFEND;
            send_parameters := send_parameters + $nft$parameter_set [nfc$echo];
          IFEND;
          IF ((destination_usage = jmc$public_usage ) OR (destination_usage = jmc$private_usage))
                AND (device_type = jmc$output_device_printer) THEN
            IF control_block.vertical_print_density >= jmc$vertical_print_density_6 THEN
              send_parameters := send_parameters + $nft$parameter_set [nfc$vertical_print_density];
            IFEND;
            IF control_block.vfu_load_procedure.size <> 0 THEN
              send_parameters := send_parameters + $nft$parameter_set [nfc$vfu_load_procedure];
            IFEND;
          IFEND;
        IFEND;

        nfp$send_command (btf_protocol [index].send_command, send_parameters,
             $nft$parameter_set[ ], $nft$parameter_set[ ],
             control_block, status);

      = nfc$btf_receive_command =

        nfp$receive_command (btf_protocol [index].legal_receive_commands, btf_required_parameters,
              control_block, received_params, ignored_params, modified_params, status);

        IF (status.normal) AND (control_block.received_user_messages.head <> NIL) THEN
          nfp$dispose_user_msg_to_log (control_block.received_user_messages);
        IFEND;

{  NOTE:  Here is a trick to make the state table work for two odd conditions.
{         If RPOS was received, but an error occured, the application should treat the error as
{         if an RNEG was received.  If RPOS was received, but protocol negotiation was requested
{         by the server, the initiator should treat the condition as an RNEG

        IF (control_block.last_command_received = nfc$rpos) THEN
          IF (NOT status.normal) THEN
            control_block.last_command_received := nfc$rneg;
            osp$set_status_abnormal (nfc$status_id, nfe$protocol_anomaly, ' ',
                  control_block.state_of_transfer);
          ELSE
            IF control_block.negotiate_protocol THEN
              control_block.last_command_received := nfc$rneg;
            IFEND;
          IFEND;
        IFEND;

      = nfc$btf_start_transfer =

{  Send the file transfer protocol command to BTFS/DI.

        nfp$send_command (btf_protocol [index].transfer_send_command,
              btf_protocol [index].transfer_send_parameters,
              $nft$parameter_set[ ], $nft$parameter_set[ ],
              control_block, status);
        IF status.normal THEN

{  Transfer the file to the destination.

          system_file_name := control_block.send_file_name.value (1, jmc$system_supplied_name_size);
          IF ntf_local_file THEN
            transfer_mode := nfc$transparent_data_mode;
          IFEND;

          nfp$send_batch_file (control_block.path.network_file_id, control_block.path.network_file^,
                system_file_name, local_file_name, control_block.transfer_facilities, transfer_mode,
                control_block.data_block_size, control_block.time_out, control_block.protocol_in_use,
                control_block.destination_usage, control_block.queue_file_password,
                control_block.disposition_code, control_block.protocol_trace, control_block.file_position,
                protocol_consistent, transfer_status, status);

          IF NOT protocol_consistent THEN
            nfp$terminate_path (control_block.application, TRUE, control_block.path, ignore_status);
          IFEND;

          IF NOT status.normal THEN
            nfp$set_abnormal_if_normal (status, control_block.local_status);
          IFEND;

          IF (control_block.state_of_transfer.normal) AND protocol_consistent THEN
            control_block.state_of_transfer := transfer_status;
          IFEND;
        IFEND;

      = nfc$btf_terminate =

{ Transfer of file complete, emit communication statistic and exit procedure

        IF destination_usage <> jmc$ntf_usage THEN
          pmp$get_compact_date_time (end_time, status);
          IF NOT status.normal THEN
            nfp$set_abnormal_if_normal (status, control_block.local_status);
            RETURN; {----->
          IFEND;
          pmp$compute_time_dif_in_seconds (start_time, end_time, elapsed_time,
                status);
          IF NOT status.normal THEN
            nfp$set_abnormal_if_normal (status, control_block.local_status);
            RETURN; {----->
          IFEND;

          IF control_block.received_account_messages.head <> NIL THEN
            account_message.text := control_block.received_account_messages.
                  head^.line (1, #SIZE (parameter_09_message));
            clp$convert_string_to_integer (account_message.number_of_lines,
                  number_of_lines, status);
            IF NOT status.normal THEN
              nfp$set_abnormal_if_normal (status, control_block.local_status);
              RETURN; {----->
            IFEND;
          ELSE
            number_of_lines.value := 0;
          IFEND;

          PUSH output_statistics;

          statistic_data.statistic_id := jmc$ca_output_file;
          statistic_data.output_file := output_statistics;
          output_statistics^.connect_time := elapsed_time;
          output_statistics^.number_of_lines := number_of_lines.value;
          output_statistics^.output_descriptor := file_descriptor.output_descriptor;
          output_statistics^.network_file_name := control_block.path.network_file^;

          jmp$emit_communication_stat (statistic_data);
        IFEND;

        EXIT /advance_state_table_loop/; {----->

      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'invalid btf state table action',
              status);
        RETURN;
      CASEND;

{  Save first abnormal status.

      IF NOT status.normal THEN
        nfp$set_abnormal_if_normal (status, control_block.local_status);
        IF (status.condition = nfe$invalid_protocol_command) OR
              (status.condition = nfe$invalid_param_count) OR
              (status.condition = nfe$invalid_command_code) THEN
          RETURN;
        IFEND;
      IFEND;

    WHILEND /advance_state_table_loop/;

  PROCEND init_and_data_transfer_phase;
?? TITLE := 'nfp$btf_client', EJECT ??

  PROCEDURE [XDCL] nfp$btf_client
    (    program_parameters: pmt$program_parameters;
     VAR status: ost$status);

    VAR
      abort_message: nft$intertask_message,
      async_status: ost$status,
      block_exit_condition: [READ, STATIC] pmt$condition :=
            [pmc$block_exit_processing, [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      btf_completion_packet: nft$intertask_message,
      connected_task: pmt$task_id,
      control_block: nft$control_block,
      copies: jmt$output_copy_count,
      descriptor_packet: nft$intertask_message,
      device: ost$name,
      error_descriptor: ^pmt$established_handler,
      file_attributes_var: ost$name,
      file_disposition: file_dispositions,
      file_disposition_var: ost$name,
      file_position: jmt$output_file_position,
      ignore_queue_id: pmt$queue_connection,
      ignore_status: ost$status,
      local_file_name: amt$local_file_name,
      local_status: ost$status,
      network_file_name: ost$name,
      ntf_local_file: boolean,
      output: amt$local_file_name,
      output_file_contains_data: boolean,
      output_file_var: ost$name,
      output_status_updates: ^jmt$output_status_updates,
      retry_count: integer,
      selected_device: ost$name,
      selected_station: ost$name,
      station: ost$name,
      statistics_file: amt$local_file_name,
      statistics_file_contains_data: boolean,
      terminated_message: [STATIC] string (46) := '**** $0000_0000_AAA_0000 Terminated by filter.',
      transfer_count: 0 .. nfc$max_transfer_size,
      transfer_file: boolean;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR trap_status: ost$status);

      VAR
        local_status: ost$status;

      pmp$log ('*** BTF - Handler condition:', ignore_status);
      osp$set_status_from_condition ('NF', condition, save_area, local_status, ignore_status);
      nap$display_message (local_status);

      abort_message.task_status := local_status;
      abort_message.filter_aborted := FALSE;

      nfp$put_async_task_message (connected_task, ^abort_message, #SIZE (abort_message), async_status);
      IF NOT async_status.normal THEN
        pmp$log ('*** BTF - Handler: put_async_task_message', ignore_status);
        nap$display_message (async_status);
      IFEND;

      retry_count := 0;
      REPEAT
        pmp$wait (250, 250);
        nfp$end_async_communication (async_status.normal, local_status);
        retry_count := retry_count + 1;
      UNTIL (local_status.normal) OR (NOT async_status.normal) OR
            (local_status.condition <> nfe$activity_pending) OR (retry_count > 100);
      IF NOT local_status.normal THEN
        pmp$log ('*** BTF - Handler: end_async_communication', ignore_status);
        nap$display_message (local_status);
      IFEND;

{ If the network connection still exists, terminate it.

      IF control_block.path.path_connected THEN
        nfp$terminate_path (control_block.application, TRUE, control_block.path, ignore_status);
      IFEND;

{ Clean up output filter variables and files.  Deleting of job-scope variables
{ is done twice to bypass an SCL anomaly that does not always delete them.

      clp$delete_variable (descriptor_packet.device_environment_variable, ignore_status);
      clp$delete_variable (descriptor_packet.device_environment_variable, ignore_status);
      clp$delete_variable (file_attributes_var, ignore_status);
      clp$delete_variable (file_attributes_var, ignore_status);
      clp$delete_variable (file_disposition_var, ignore_status);
      clp$delete_variable (file_disposition_var, ignore_status);
      clp$delete_variable (output_file_var, ignore_status);
      clp$delete_variable (output_file_var, ignore_status);

      amp$return (output, ignore_status);
      amp$return (statistics_file, ignore_status);

    PROCEND condition_handler;

?? TITLE := 'log_abnormal_condition', EJECT ??

    PROCEDURE log_abnormal_condition
      (    network_address: nat$network_address;
           station: ost$name;
           device: ost$name;
           abnormal_status: ost$status);

      VAR
        converted_string: ^string ( * ),
        converted_string_length: integer,
        ignore_status: ost$status,
        message: string (80),
        message_length: integer;

      IF (network_address.kind = nac$osi_transport_address) THEN
        PUSH converted_string: [2 * network_address.osi_transport_address.network_address_length];
        convert_sequence_to_hex_string (^network_address.osi_transport_address.network_address,
              network_address.osi_transport_address.network_address_length, converted_string,
              converted_string_length);
        STRINGREP (message, message_length, 'NETWORK_ADDRESS: ', converted_string^ (1,
              converted_string_length));
        pmp$log (message (1, message_length), ignore_status);
      ELSE
        pmp$log ('NETWORK_ADDRESS: *unknown kind*', ignore_status);
      IFEND;

      STRINGREP (message, message_length, 'STATION: ', station);
      pmp$log (message (1, message_length), ignore_status);

      STRINGREP (message, message_length, 'DEVICE: ', device);
      pmp$log (message (1, message_length), ignore_status);

      nap$display_message (abnormal_status);

    PROCEND log_abnormal_condition;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    abort_message.kind := nfc$abnormal_child_task_abort;
    btf_completion_packet.btf_transfer_status := nfc$transfer_failed_re_q_file;
    btf_completion_packet.filter_aborted := FALSE;
    btf_completion_packet.kind := nfc$btf_file_transfer_status;
    PUSH control_block.path.network_file: [osc$max_name_size];
    control_block.path.path_connected := FALSE;
    PUSH error_descriptor;
    file_attributes_var := osc$null_name;
    file_disposition := print_and_terminate;
    file_disposition_var := osc$null_name;
    output := osc$null_name;
    output_file_contains_data := FALSE;
    output_file_var := osc$null_name;
    statistics_file := osc$null_name;
    statistics_file_contains_data := FALSE;

{ Initiate the communication link with the calling task (SCF or NTF).

    nfp$begin_asynchronous_task (program_parameters, connected_task, ignore_queue_id, status);
    IF NOT status.normal THEN
      pmp$log ('*** BTF: begin_asynchronous_task', ignore_status);
      nap$display_message (status);
      RETURN;
    IFEND;

    pmp$establish_condition_handler (block_exit_condition, ^condition_handler, error_descriptor,
          ignore_status);

{ Communicate with calling task to get the file descriptor information.

    nfp$get_async_task_message (connected_task, ^descriptor_packet, #SIZE (descriptor_packet),
          nfc$max_wait_time, transfer_count, status);
    IF NOT status.normal THEN
      pmp$log ('*** BTF: get_async_task_message', ignore_status);
      nap$display_message (status);
      nfp$end_async_communication (FALSE, local_status);
      IF NOT local_status.normal THEN
        pmp$log ('*** BTF: end_async_communication (1)', ignore_status);
        nap$display_message (local_status);
      IFEND;
      RETURN;
    ELSEIF {status.normal AND} transfer_count = 0 THEN
      osp$set_status_abnormal ('NF', nfe$bts_internal_error, '*** BTF', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'async task message transfer_count = 0',
            status);
      nap$display_message (status);
      RETURN;
    IFEND;

{ Check the new file descriptor for the correct station and device
{ and initialize the completion packet for this file descriptor.

    CASE descriptor_packet.btf_file_descriptor.file_kind OF
    = nfc$output_file =
      selected_station := descriptor_packet.btf_file_descriptor.output_descriptor.station;
      selected_device := descriptor_packet.btf_file_descriptor.output_descriptor.device;

      copies := descriptor_packet.btf_file_descriptor.output_descriptor.copies -
            descriptor_packet.btf_file_descriptor.output_descriptor.copies_printed;
      btf_completion_packet.btf_system_file_name := descriptor_packet.btf_file_descriptor.output_descriptor.
            system_file_name;
      btf_completion_packet.copies_printed := descriptor_packet.btf_file_descriptor.output_descriptor.
            copies_printed;
      file_position := descriptor_packet.btf_file_descriptor.output_descriptor.file_position;

    = nfc$input_file =
      selected_station := descriptor_packet.btf_file_descriptor.input_descriptor.station;
      selected_device := descriptor_packet.btf_file_descriptor.input_descriptor.job_input_device.text;

      copies := 1;
      btf_completion_packet.copies_printed := 0;
      file_position := 0;
      btf_completion_packet.btf_system_file_name := descriptor_packet.btf_file_descriptor.input_descriptor.
            system_job_name;

    CASEND;

    local_file_name := descriptor_packet.ntf_local_file_name;
    ntf_local_file := (local_file_name <> osc$null_name);

{ Initialize the file transfer control block

    setup_control_block (descriptor_packet.btf_file_descriptor, control_block, device, station, status);

{ Filter output printer files.

    IF (status.normal) AND (descriptor_packet.btf_file_descriptor.file_kind = nfc$output_file) AND
          (descriptor_packet.btf_file_descriptor.output_descriptor.output_destination_usage <> jmc$ntf_usage)
          THEN
      execute_batch_output_filter (descriptor_packet, btf_completion_packet, control_block,
            file_attributes_var, file_disposition, file_disposition_var, output, output_file_contains_data,
            output_file_var, statistics_file, statistics_file_contains_data, status);
      transfer_file := (status.normal) AND ((file_disposition = print_and_hold) OR
            (file_disposition = print_and_terminate));
      IF output_file_contains_data AND transfer_file THEN
        local_file_name := output;
      IFEND;
    ELSE
      transfer_file := status.normal;
    IFEND;

{ Connect to the network address supplied by the calling task.

    IF transfer_file THEN
      connection_initiation_phase (descriptor_packet.network_address, station, device, network_file_name,
            control_block, status);
      transfer_file := status.normal;
    IFEND;

{ Transfer the file to the batch device or stream.

  /transfer_until_copy_count/
    REPEAT

      IF transfer_file THEN
        init_and_data_transfer_phase (descriptor_packet.btf_file_descriptor, local_file_name, ntf_local_file,
              control_block, status);
        btf_completion_packet.btf_task_status := control_block.state_of_transfer;
      ELSE
        btf_completion_packet.btf_task_status := status;
      IFEND;

{ File transfer completed normally if both task_status and status are normal.

      IF btf_completion_packet.btf_task_status.normal AND status.normal THEN

        IF transfer_file THEN
          btf_completion_packet.copies_printed := btf_completion_packet.copies_printed + 1;
        IFEND;

{ Update the number of copies transferred for an output descriptor.

        IF (descriptor_packet.btf_file_descriptor.file_kind = nfc$output_file) AND
              (descriptor_packet.btf_file_descriptor.output_descriptor.output_destination_usage <>
              jmc$ntf_usage) AND (transfer_file) THEN
          PUSH output_status_updates: [1 .. 1];
          output_status_updates^ [1].key := jmc$copies_printed;
          output_status_updates^ [1].copies_printed := btf_completion_packet.copies_printed;
          jmp$update_output_status (descriptor_packet.btf_file_descriptor.output_descriptor.system_file_name,
                descriptor_packet.btf_file_descriptor.output_descriptor.output_destination_usage,
                descriptor_packet.btf_file_descriptor.q_file_password, output_status_updates, ignore_status);
        IFEND;

        IF (file_disposition = hold) OR (file_disposition = print_and_hold) THEN
          btf_completion_packet.btf_transfer_status := nfc$filter_hold_file;
        ELSE
          btf_completion_packet.btf_transfer_status := nfc$transfer_complete_drop_file;
          IF (file_disposition = terminate) THEN

{ Substitute actual system supplied file name in "terminate" message.

            terminated_message (6, jmc$system_supplied_name_size) :=
                  descriptor_packet.btf_file_descriptor.output_descriptor.system_file_name;
            pmp$log (terminated_message, ignore_status);
          IFEND;
        IFEND;

{ Emit output filter statistics if any.

        IF statistics_file_contains_data THEN
          process_statistics_file (statistics_file);
        IFEND;

      ELSE { File transfer terminated abnormally

{ In the case where both btf task status and status are abnormal, the
{ task status is more important - this status will usually be set
{ based upon the state of transfer.

        IF NOT btf_completion_packet.btf_task_status.normal THEN
          CASE btf_completion_packet.btf_task_status.condition OF
          = nfe$requeue_not_eligible_file =
            btf_completion_packet.btf_transfer_status := nfc$operator_hold_file;
          = nfe$station_operator_terminate =
            btf_completion_packet.btf_transfer_status := nfc$transfer_complete_drop_file;
          ELSE { all other abnormal conditions
            log_abnormal_condition (descriptor_packet.network_address, selected_station, selected_device,
                  btf_completion_packet.btf_task_status);
            btf_completion_packet.btf_transfer_status := nfc$transfer_failed_re_q_file;
            IF (descriptor_packet.btf_file_descriptor.file_kind = nfc$output_file) AND
                  (descriptor_packet.btf_file_descriptor.output_descriptor.output_destination_usage <>
                  jmc$ntf_usage) THEN
              PUSH output_status_updates: [1 .. 1];
              output_status_updates^ [1].key := jmc$file_position;
              output_status_updates^ [1].file_position := file_position;
              jmp$update_output_status (descriptor_packet.btf_file_descriptor.output_descriptor.
                    system_file_name, descriptor_packet.btf_file_descriptor.output_descriptor.
                    output_destination_usage, descriptor_packet.btf_file_descriptor.q_file_password,
                    output_status_updates, ignore_status);
            IFEND;
          CASEND;

        ELSE { NOT status.normal

          btf_completion_packet.btf_task_status := status;
          log_abnormal_condition (descriptor_packet.network_address, selected_station, selected_device,
                btf_completion_packet.btf_task_status);
          btf_completion_packet.btf_transfer_status := nfc$transfer_failed_re_q_file;
          IF (descriptor_packet.btf_file_descriptor.file_kind = nfc$output_file) AND
                (descriptor_packet.btf_file_descriptor.output_descriptor.output_destination_usage <>
                jmc$ntf_usage) THEN
            PUSH output_status_updates: [1 .. 1];
            output_status_updates^ [1].key := jmc$file_position;
            output_status_updates^ [1].file_position := file_position;
            jmp$update_output_status (descriptor_packet.btf_file_descriptor.output_descriptor.
                  system_file_name, descriptor_packet.btf_file_descriptor.output_descriptor.
                  output_destination_usage, descriptor_packet.btf_file_descriptor.q_file_password,
                  output_status_updates, ignore_status);
          IFEND;
        IFEND;
      IFEND;

    UNTIL (btf_completion_packet.copies_printed >= copies) OR
          (NOT btf_completion_packet.btf_task_status.normal) OR (NOT transfer_file);

{ Cleanup after output filters:  delete job-scope SCL variables and delete
{ files.  Deleting of job-scope variables is done twice to bypass an SCL anomaly
{ that does not always delete them.

    clp$delete_variable (descriptor_packet.device_environment_variable, ignore_status);
    clp$delete_variable (descriptor_packet.device_environment_variable, ignore_status);
    clp$delete_variable (file_attributes_var, ignore_status);
    clp$delete_variable (file_attributes_var, ignore_status);
    clp$delete_variable (file_disposition_var, ignore_status);
    clp$delete_variable (file_disposition_var, ignore_status);
    clp$delete_variable (output_file_var, ignore_status);
    clp$delete_variable (output_file_var, ignore_status);

    amp$return (output, ignore_status);
    amp$return (statistics_file, ignore_status);

{ Send updated completion packet to calling task.

    retry_count := 0;
    REPEAT
      IF retry_count > 0 THEN
        pmp$wait (250, 250);
      IFEND;
      nfp$put_async_task_message (connected_task, ^btf_completion_packet, #SIZE (btf_completion_packet),
            async_status);
      retry_count := retry_count + 1;
    UNTIL (async_status.normal) OR (retry_count > 10);
    IF NOT async_status.normal THEN
      pmp$log ('*** BTF: put_async_task_message (message lost)', ignore_status);
      nap$display_message (async_status);
    IFEND;

{ Wait for the calling task to pick up the completion packet

    retry_count := 0;
    REPEAT
      pmp$wait (250, 250);
      nfp$end_async_communication (async_status.normal, local_status);
      retry_count := retry_count + 1;
    UNTIL (local_status.normal) OR (NOT async_status.normal) OR
          (local_status.condition <> nfe$activity_pending) OR (retry_count > 100);
    IF NOT local_status.normal THEN
      pmp$log ('*** BTF: end_async_communication (2)', ignore_status);
      nap$display_message (local_status);
    IFEND;

{ Terminate the connection if it still exists.

    IF control_block.path.path_connected THEN
      nfp$terminate_path (control_block.application, TRUE, control_block.path, ignore_status);
    IFEND;

    pmp$disestablish_cond_handler (block_exit_condition, ignore_status);

  PROCEND nfp$btf_client;
?? OLDTITLE ??

?? NEWTITLE := 'process_statistics_file', EJECT ??

{  PROCEDURE:  process_statistics_file
{
{  PURPOSE:    To parse a file which contains legible statistics definitions
{              to be emitted using sfp$emit_statistic.
{
{  DESCRIPTION: This routine parses a legible file that was created by one
{              or more site defined procedures that executed when the main
{              batch output filter was called.
{
{  INPUT PARAMETERS: The file name of the user statistic file.
{
{  OUTPUT PARAMETERS:
{              none
{
{  ALGORITHM:
{              Attempt to open the file
{              Read lines from the file
{               Check if the first token is a name
{                 Convert the name to a statistic code
{                 Check if a valid string token is present
{                 Check if one or more integer tokens are present
{                 Emit the statistic

  PROCEDURE process_statistics_file
    (    file: fst$file_reference);

    VAR
      attachment_options: ^fst$attachment_options,
      byte_address_in_file: amt$file_byte_address,
      bytes_read_from_file: amt$transfer_count,
      counter_index: integer,
      token: clt$lexical_token,
      descriptive_data: string (sfc$max_descriptive_data_size),
      descriptive_data_length: integer,
      local_status: ost$status,
      file_identifier: amt$file_identifier,
      file_position: amt$file_position,
      line_from_stat_file: string (osc$max_string_size),
      ignore_status: ost$status,
      index_into_line: clt$string_index,
      passed_counters: ^array [1 .. * ] of sft$counter,
      spaces_before_token: boolean,
      statistic_code: sft$statistic_code,
      stored_counters: ^array [1 .. sfc$max_number_of_counters] of sft$counter,
      token_options: clt$token_evaluation_options;

    PUSH attachment_options: [1 .. 1];
    attachment_options^ [1].selector := fsc$create_file;
    attachment_options^ [1].create_file := FALSE;

    fsp$open_file (file, amc$record, attachment_options, NIL, NIL, NIL, NIL, file_identifier, local_status);
    IF local_status.normal THEN
      file_position := amc$boi;
      token_options := $clt$token_evaluation_options [clc$ignore_spaces_before_token];

      amp$get_next (file_identifier, ^line_from_stat_file, osc$max_string_size, bytes_read_from_file,
            byte_address_in_file, file_position, local_status);
      IF local_status.normal THEN
        WHILE (file_position <> amc$eoi) AND local_status.normal DO
          index_into_line := 1;
          token.kind := clc$unknown_token;
          local_status.normal := TRUE;

          clp$evaluate_token (line_from_stat_file (1, bytes_read_from_file), token_options, index_into_line,
                spaces_before_token, token, local_status);
          IF local_status.normal THEN
            IF (token.kind = clc$name_token) THEN
              sfp$convert_stat_name_to_code (token.str.value (1, 31), statistic_code, local_status);
              IF local_status.normal THEN
                clp$evaluate_token (line_from_stat_file (1, bytes_read_from_file), token_options,
                      index_into_line, spaces_before_token, token, local_status);
              IFEND;
            ELSE
              osp$set_status_abnormal ('SF', sfe$invalid_statistic_name, ' ', local_status);
            IFEND;
          IFEND;

          IF local_status.normal THEN
            IF (token.kind = clc$string_token) THEN
              IF token.str.size <= sfc$max_descriptive_data_size THEN
                descriptive_data := token.str.value;
                descriptive_data_length := token.str.size;

                clp$evaluate_token (line_from_stat_file (1, bytes_read_from_file), token_options,
                      index_into_line, spaces_before_token, token, local_status);
              ELSE
                osp$set_status_abnormal ('SF', sfe$descriptive_data_size, ' ', local_status);
              IFEND;
            ELSE
              descriptive_data := '';
              descriptive_data_length := 0;
            IFEND;
          IFEND;

          IF local_status.normal THEN
            IF (token.kind = clc$signed_integer_token) OR (token.kind = clc$unsigned_integer_token) THEN
              counter_index := 0;
              ALLOCATE stored_counters;
              WHILE ((token.kind = clc$signed_integer_token) OR
                    (token.kind = clc$unsigned_integer_token)) AND local_status.normal DO
                counter_index := counter_index + 1;
                IF counter_index <= sfc$max_number_of_counters THEN
                  stored_counters^ [counter_index] := token.int.value;
                  clp$evaluate_token (line_from_stat_file (1, bytes_read_from_file), token_options,
                        index_into_line, spaces_before_token, token, local_status);
                ELSE
                  osp$set_status_abnormal ('SF', sfe$counter_array_size_range, ' ', local_status);
                IFEND;
              WHILEND;
              IF local_status.normal THEN
                ALLOCATE passed_counters: [1 .. counter_index];
                WHILE (counter_index > 0) DO
                  passed_counters^ [counter_index] := stored_counters^ [counter_index];
                  counter_index := counter_index - 1;
                WHILEND;
              IFEND;
              FREE stored_counters;
            ELSE
              passed_counters := NIL;
            IFEND;
          IFEND;

          IF local_status.normal THEN
            sfp$emit_statistic (statistic_code, descriptive_data (1, descriptive_data_length),
                  passed_counters, local_status);
            IF passed_counters <> NIL THEN
              FREE passed_counters;
            IFEND;
          IFEND;

          IF NOT local_status.normal THEN
            pmp$log ('*** BTF process_statistics_file:', ignore_status);
            pmp$log (line_from_stat_file (1, bytes_read_from_file), ignore_status);
            nfp$format_message_to_job_log (local_status);
          IFEND;

          amp$get_next (file_identifier, ^line_from_stat_file, osc$max_string_size, bytes_read_from_file,
                byte_address_in_file, file_position, local_status);
        WHILEND;
      ELSE
        nfp$format_message_to_job_log (local_status);
      IFEND;
    ELSE
      nfp$format_message_to_job_log (local_status);
    IFEND;

  PROCEND process_statistics_file;
?? OLDTITLE ??

?? TITLE := 'setup_control_block', EJECT ??

{ PURPOSE:  Initialize the protocol parameters in the control block.

  PROCEDURE setup_control_block
    (    application_file: nft$application_file_descriptor;
     VAR control_block: nft$control_block;
     VAR device: ost$name;
     VAR station: ost$name;
     VAR status: ost$status);

    CONST
      block_size = 1452,
      catenet_value = ',CATENET',
      page_width_size = 3;

    TYPE
      date_and_time_format = (segmented, continuous),
      date_and_time_type = record
        case date_and_time_format of
        = segmented =
          month: string (2),
          slash_1: string (1),
          day: string (2),
          slash_2: string (1),
          year: string (2),
          blank_1: string (1),
          hour: string (2),
          colon_1: string (1),
          minute: string (2),
          colon_2: string (1),
          second: string (2),
        = continuous =
          date_and_time_string: string (2 + 1 + 2 + 1 + 2 + 1 + 2 + 1 + 2 + 1 + 2),
        casend,
      recend;

    VAR
      banner_date_and_time: date_and_time_type,
      echo_text: ^nft$parameter_29_definition,
      facilities: nft$parameter_03_value_set,
      family_name: ost$name,
      ignore_status: ost$status,
      page_width: string (page_width_size),
      protocol_in_use:  nft$parameter_00_values,
      queued_date_and_time: ost$date_time,
      save_network_connection_info: nft$network_connection,
      start_text_position: integer,
      system_routing_text: jmt$system_routing_text,
      system_routing_text_string: string (nfc$p32_max_param_length_b101),
      text_length: integer,
      transfer_lid_string: nft$parameter_25_definition,
      user_name: ost$name;


    status.normal := TRUE;

    save_network_connection_info.path_connected := FALSE;
    protocol_in_use := nfc$p00_b101;
    facilities := $nft$parameter_03_value_set [nfc$temporary_hold, nfc$ss_ack_required];

{ If a network connection exists, save this path information and replace this into
{ the control block after initialization of control block fields.

    IF control_block.path.path_connected THEN
      save_network_connection_info := control_block.path;
    IFEND;

{ Initialize control block with defaults.

    nfp$initialize_control_block (nfc$application_btf, nfc$p31_ascii_c8, facilities, facilities, facilities,
          protocol_in_use, nfc$take, ^parameter_rules, control_block);

{ Initialize control block with protocol defaults.

    control_block.data_block_size := block_size;
    control_block.time_out := nfc$timeout_limit;
    control_block.local_host_type := nfc$p22_nos_ve;

{ Initialize control block with file information.

    control_block.queue_file_password := application_file.q_file_password;

    CASE application_file.file_kind OF

    = nfc$output_file =

      control_block.banner_date_and_time.size := 0;
      control_block.banner_date_and_time.value := ' ';

      control_block.banner_routing_text.size := nfp$string_length
            (application_file.output_descriptor.routing_banner);
      control_block.banner_routing_text.value := application_file.output_descriptor.routing_banner;

      IF application_file.output_descriptor.data_mode = jmc$transparent_data THEN
        control_block.data_declaration := nfc$p31_undef_unstructured_uu;
      ELSE
        control_block.data_declaration := nfc$p31_ascii_c8;
      IFEND;

      control_block.destination_usage := application_file.output_descriptor.output_destination_usage;
      control_block.disposition_code := nfc$p17_line_printer;
      control_block.file_position := application_file.output_descriptor.file_position;
      control_block.file_size := application_file.output_descriptor.file_size;
      control_block.installation_banner_message.size := nfp$string_length
            (application_file.output_descriptor.site_information);
      control_block.installation_banner_message.value := application_file.output_descriptor.site_information;

      control_block.send_file_name.size := nfp$string_length
            (application_file.output_descriptor.system_file_name);
      control_block.send_file_name.value := application_file.output_descriptor.system_file_name;
      control_block.send_job_name.size  := nfp$string_length
            (application_file.output_descriptor.user_job_name);
      control_block.send_job_name.value := application_file.output_descriptor.user_job_name;

      control_block.user_banner_message.size := nfp$string_length
            (application_file.output_descriptor.comment_banner);
      control_block.user_banner_message.value := application_file.output_descriptor.comment_banner;

      control_block.user_file_name.size := nfp$string_length
            (application_file.output_descriptor.user_file_name);
      control_block.user_file_name.value := application_file.output_descriptor.user_file_name;

      control_block.vertical_print_density := application_file.output_descriptor.vertical_print_density;
      control_block.vfu_load_procedure.size := nfp$string_length
            (application_file.output_descriptor.vfu_load_procedure);
      control_block.vfu_load_procedure.value := application_file.output_descriptor.vfu_load_procedure;

      device := application_file.output_descriptor.device;
      IF application_file.output_descriptor.control_family <> osc$null_name THEN
        family_name := application_file.output_descriptor.control_family;
      ELSEIF application_file.output_descriptor.login_family <> osc$null_name THEN
        family_name := application_file.output_descriptor.login_family;
      ELSE
        family_name := osc$null_name;
      IFEND;
      station := application_file.output_descriptor.station;
      system_routing_text := application_file.output_descriptor.system_routing_text;
      IF application_file.output_descriptor.control_user <> osc$null_name THEN
        user_name := application_file.output_descriptor.control_user;
      ELSEIF application_file.output_descriptor.login_user <> osc$null_name THEN
        user_name := application_file.output_descriptor.login_user;
      ELSE
        user_name := application_file.output_descriptor.user_job_name;
      IFEND;

      IF application_file.output_descriptor.output_destination_usage <> jmc$ntf_usage THEN

{ Set page_width in send_echo_text

        ALLOCATE echo_text;
        IF echo_text = NIL THEN
          osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'ALLOCATE for echo_text failed',
                status);
          RETURN;
        IFEND;
        clp$convert_integer_to_rjstring (application_file.output_descriptor.page_width, 10, FALSE, '0',
              page_width, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        echo_text^.size := page_width_size;
        echo_text^.value := page_width;
        echo_text^.link := NIL;
        control_block.send_echo_text.first_text := echo_text;
        control_block.send_echo_text.last_text := echo_text;
      IFEND;

    = nfc$input_file =

      control_block.banner_date_and_time.size := 0;
      control_block.banner_date_and_time.value := ' ';

      IF application_file.input_descriptor.data_mode = jmc$transparent_data THEN
        control_block.data_declaration := nfc$p31_undef_unstructured_uu;
      ELSE
        control_block.data_declaration := nfc$p31_ascii_c8;
      IFEND;

      control_block.destination_usage := application_file.input_descriptor.job_destination_usage;
      control_block.disposition_code := nfc$p17_input_return;
      control_block.file_position := 0;
      control_block.file_size := application_file.input_descriptor.job_size;

      control_block.send_file_name.size := nfp$string_length
            (application_file.input_descriptor.system_job_name);
      control_block.send_file_name.value := application_file.input_descriptor.system_job_name;
      control_block.send_job_name.size  := nfp$string_length
            (application_file.input_descriptor.user_job_name);
      control_block.send_job_name.value := application_file.input_descriptor.user_job_name;

      control_block.user_file_name.size := nfp$string_length
            (application_file.input_descriptor.user_job_name);
      control_block.user_file_name.value := application_file.input_descriptor.user_job_name;

      control_block.vertical_print_density := jmc$vertical_print_density_none;
      control_block.vfu_load_procedure.size := 0;
      control_block.vfu_load_procedure.value := ' ';

      device := application_file.input_descriptor.job_input_device.text;
      family_name := application_file.input_descriptor.login_family;
      station := application_file.input_descriptor.station;
      system_routing_text := application_file.input_descriptor.system_routing_text;
      user_name := application_file.input_descriptor.login_user;

    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
            'invalid application file descriptor', status);
      RETURN;
    CASEND;

{  Build transfer lid text.

    transfer_lid_string := ' ';
    start_text_position := 1;
    text_length := nfp$string_length (station);
    transfer_lid_string (start_text_position, text_length) := station;
    start_text_position := start_text_position + text_length;
    transfer_lid_string (start_text_position, * ) := catenet_value;

    control_block.transfer_lid_length := nfp$string_length (transfer_lid_string);
    control_block.transfer_lid := transfer_lid_string;

{  Build system routing text if there currently is no text in the descriptor
{  or if the current routing text starts with 'CYB'.  Otherwise, pass down
{  original routing text.

    IF (system_routing_text.size = 0) OR ((system_routing_text.size >= nfc$p32_min_param_length_b101) AND
          (system_routing_text.parameters (1, 3) = nfc$p32_cyber_id)) THEN
      system_routing_text_string := 'UID,';
      start_text_position := 5;
      IF user_name <> osc$null_name THEN
        text_length := nfp$string_length (user_name);
      ELSE
        text_length := 1;
      IFEND;
      system_routing_text_string (start_text_position, text_length) := user_name;
      start_text_position := start_text_position + text_length;
      system_routing_text_string (start_text_position, 1) := ',';
      start_text_position := start_text_position + 1;
      IF family_name <> osc$null_name THEN
        text_length := nfp$string_length (family_name);
      ELSE
        text_length := 1;
      IFEND;
      system_routing_text_string (start_text_position, text_length) := family_name;
      start_text_position := start_text_position + text_length;
      system_routing_text_string (start_text_position, * ) := catenet_value;

      control_block.send_systems_routing_text.size := nfp$string_length (system_routing_text_string);
      control_block.send_systems_routing_text.parameters := system_routing_text_string;
    IFEND;

{  Build banner date and time text.

    CASE application_file.file_kind OF
    = nfc$output_file =
      queued_date_and_time := application_file.output_descriptor.output_submission_time;
    = nfc$input_file =
      queued_date_and_time := application_file.input_descriptor.job_submission_time;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
            'invalid application file descriptor', status);
      RETURN;
    CASEND;

    banner_date_and_time.blank_1 := ' ';
    banner_date_and_time.colon_1 := ':';
    banner_date_and_time.colon_2 := ':';
    banner_date_and_time.slash_1 := '/';
    banner_date_and_time.slash_2 := '/';

    clp$convert_integer_to_rjstring (queued_date_and_time.year, 10, FALSE, '0',
          banner_date_and_time.year, ignore_status);
    clp$convert_integer_to_rjstring (queued_date_and_time.month, 10, FALSE, '0',
          banner_date_and_time.month, ignore_status);
    clp$convert_integer_to_rjstring (queued_date_and_time.day, 10, FALSE, '0',
          banner_date_and_time.day, ignore_status);
    clp$convert_integer_to_rjstring (queued_date_and_time.hour, 10, FALSE, '0',
          banner_date_and_time.hour, ignore_status);
    clp$convert_integer_to_rjstring (queued_date_and_time.minute, 10, FALSE, '0',
          banner_date_and_time.minute, ignore_status);
    clp$convert_integer_to_rjstring (queued_date_and_time.second, 10, FALSE, '0',
          banner_date_and_time.second, ignore_status);
    control_block.banner_date_and_time.value := banner_date_and_time.date_and_time_string;
    control_block.banner_date_and_time.size := #SIZE (date_and_time_type);

{ If network connection did exist, then restore network connection path information.

    IF save_network_connection_info.path_connected THEN
      control_block.path := save_network_connection_info;
    IFEND;

  PROCEND setup_control_block;
MODEND nfm$btf_client;
*DECK DECK=NFM$BTF_SERVER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NFM$BTF_SERVER' ??
MODULE nfm$btf_server;

{}
{  PURPOSE:  This module contains procedures to perform the function of the
{            Batch Transfer Facility Server on NOS/VE (BTFS/VE).
{
{  DESCRIPTION:
{            The function of BTFS is performed by two entities:
{
{            1) The BOOT system task, which receives all incoming connections.
{               This BOOT task then executes a task to service each connection:
{
{            2) The SERVICE task, which receives a file from CDCNET via the
{               B101 A-A protocol.
{               The received file is then placed in a NOS/VE queue.
{}

?? NEWTITLE := 'Global Declarations Referenced', EJECT ??

*copyc amp$return
*copyc clp$convert_string_to_integer
*copyc clp$log_comment
*copyc clp$scan_parameter_list
*copyc clp$scan_token
*copyc fsp$open_file
*copyc jmp$submit_job
*copyc nap$attach_server_application
*copyc nap$detach_server_application
*copyc nap$get_attributes
*copyc nap$parse_accounting_data
*copyc nfp$dispose_user_msg_to_log
*copyc nfp$enqueue_status_directive
*copyc nfp$enqueue_task
*copyc nfp$format_message_to_job_log
*copyc nfp$get_server_asynch_event
*copyc nfp$initialize_control_block
*copyc nfp$ntf_receive_file
*copyc nfp$receive_command
*copyc nfp$receive_file
*copyc nfp$send_command
*copyc nfp$set_abnormal_if_normal
*copyc nfp$terminate_path
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pmp$compute_time_dif_in_seconds
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$execute
*copyc pmp$get_compact_date_time
*copyc pmp$get_program_description
*copyc pmp$get_program_size
*copyc pmp$get_unique_name
*copyc pmp$log

?? PUSH (LISTEXT := ON) ??

*copyc jmt$job_submission_options
*copyc nfc$command_definitions
*copyc nfc$parameter_definitions
*copyc nfc$parameter_00_definitions
*copyc nfc$parameter_03_definitions
*copyc nfc$parameter_04_definitions
*copyc nfc$parameter_08_definitions
*copyc nfc$parameter_09_definitions
*copyc nfc$parameter_12_definitions
*copyc nfc$parameter_13_definitions
*copyc nfc$parameter_16_definitions
*copyc nfc$parameter_17_definitions
*copyc nfc$parameter_20_definitions
*copyc nfc$parameter_22_definitions
*copyc nfc$parameter_25_definitions
*copyc nfc$parameter_26_definitions
*copyc nfc$parameter_30_definitions
*copyc nfc$parameter_31_definitions
*copyc nfc$parameter_32_definitions
*copyc nfc$parameter_58_definitions
*copyc nfe$batch_transfer_services
*copyc nft$batch_input_accounting_data
*copyc nft$command_set
*copyc nft$last_command_received
*copyc nft$last_command_sent
*copyc nft$parameter_set
*copyc nft$parameter_25_b101_text
*copyc nft$parameter_32_b101_text
*copyc nft$parameter_58_b101_text
*copyc nft$protocol_commands
*copyc nft$protocol_parameters
*copyc nft$transfer_modes
*copyc nfv$nam_application_names
*copyc osc$batch_transfer_server

?? POP ??

?? TITLE := 'Global Declarations Defined', EJECT ??

  TYPE
    batch_input_accounting = record
      CASE boolean OF
      = FALSE =
        data_string: jmt$job_input_device,
      = TRUE =
        size: 0 .. jmc$job_input_device_size,
        data_block: nft$batch_input_accounting_data,
      CASEND,
    recend,

    service_params = record
      network_file: ost$name,
      path_info: nft$network_connection,
    recend;


?? TITLE := '[XDCL] NFP$BTFS_BOOT', EJECT ??

  PROGRAM [XDCL] nfp$btfs_boot
    (VAR status: ost$status);

{}
{  PROCEDURE:  nfp$btfs_boot
{
{  PURPOSE:    The boot is a task which receives incoming BTFS connections
{              and initiates a service task to process each connection.
{
{  DESCRIPTION:
{              This routine is the starting procedure for the BTFS boot
{              task.  This task is responsible for receiving incoming BTFS
{              connections and executing a service task per connection.
{
{  INPUT PARAMETERS:
{              None
{
{  OUTPUT PARAMETERS:
{              status : status of the procedure
{
{  ALGORITHM:  Establish condition handler
{              Sign on as server to NAMVE
{              LOOP
{                Receive connect
{                If error, abort
{                Execute service task
{              LOOPEND
{}

?? NEWTITLE := '  BOOT_HANDLER', EJECT ??

    PROCEDURE boot_handler
      (    condition: pmt$condition;
           condition_desc: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR trap_status: ost$status);

{}
{  PROCEDURE:  boot_handler
{
{  PURPOSE:    This is the condition handler for nfm$btfs_boot.
{
{}

      VAR
        handler_ignore_status: ost$status,
        local_status: ost$status;

{}

      pmp$log ('BTFS boot task terminating', handler_ignore_status);

      { Break connection with BTF/DI }
      nfp$terminate_path (application, FALSE, path, handler_ignore_status);

      { Advise NAMVE that BTFS is gone }
      nap$detach_server_application (nfv$nam_application_names [application],
            handler_ignore_status);

      osp$set_status_from_condition (nfc$status_id, condition, save_area,
            local_status, handler_ignore_status);

      nfp$format_message_to_job_log (local_status);

{}

    PROCEND boot_handler;

?? OLDTITLE, EJECT ??

{}
{   NFP$BTFS_BOOT Data
{}

    VAR
      application: nft$application_values,
      conditions: pmt$condition,
      establish_descriptor: pmt$established_handler,
      lcn_boot: boolean,
      log_message: string (nfc$trace_commands_width),
      log_names: ARRAY [1..1] OF ost$name,
      log_status: ost$status,
      max_nam_connections: nat$number_of_connections,
      nam_boot: boolean,
      network_file_name: ost$name,
      number_of_libraries: pmt$number_of_libraries,
      number_of_modules: pmt$number_of_modules,
      number_of_objects: pmt$number_of_object_files,
      parameter_block: SEQ (REP 1 of service_params),
      parameter_pointer: ^service_params,
      parameter_set: service_params,
      path: nft$network_connection,
      program_attributes: ^pmt$program_attributes,
      program_description: ^pmt$program_description,
      program_parameters: ^pmt$program_parameters,
      task_id: pmt$task_id,
      task_id_string: string (10),
      task_id_string_length: integer,
      task_queue: nft$task_queue,
      task_status: pmt$task_status;

?? EJECT ??

{}
{   BEGIN nfp$btfs_boot
{}

    status.normal := TRUE;

{}
{   Establish condition handler
{}

    conditions.selector := pmc$condition_combination;
    conditions.combination := $pmt$condition_combination
          [pmc$system_conditions, mmc$segment_access_condition,
          pmc$block_exit_processing, pmc$user_defined_condition,
          ifc$interactive_condition];
    pmp$establish_condition_handler (conditions, ^boot_handler,
          ^establish_descriptor, status);
    IF NOT status.normal THEN
      nfp$format_message_to_job_log (status);
      RETURN; {----->
    IFEND;

{}
{   Initialize variables
{}

    application := nfc$application_btfs;
    lcn_boot := FALSE;
    nam_boot := TRUE;
    path.application_sequence_number := 1;
    path.path_connected := FALSE;
    ALLOCATE path.network_file: [STRLENGTH (network_file_name)];
    IF (path.network_file = NIL) THEN
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
            'BTFS nfp$btfs_boot - ALLOCATE -', status);
      nfp$format_message_to_job_log (status);
      RETURN; {----->
    IFEND;
    task_queue.head := NIL;
    task_queue.tail := NIL;
    task_queue.number_of_tasks := 0;

{}
{     Sign on as server to NAMVE
{}

    max_nam_connections := 0; {** Use all that are available **}
    nap$attach_server_application (nfv$nam_application_names [application],
          max_nam_connections, status);
    IF NOT status.normal THEN
      nfp$format_message_to_job_log (status);
      RETURN; {----->
    IFEND;

{}
{     Get program description for execute of service task.
{     Note that this BOOT task and executed SERVICE_TASK are loaded from the
{     same module,  so much of the program description data is the same.
{}

    pmp$get_program_size (number_of_objects, number_of_modules,
          number_of_libraries, status);
    IF NOT status.normal THEN
      nfp$format_message_to_job_log (status);
      RETURN; {----->
    IFEND;
    PUSH program_description: [[REP (#SIZE (pmt$program_attributes) +
          (number_of_objects * #SIZE (amt$local_file_name)) +
          (number_of_modules * #SIZE (pmt$program_name)) +
          (number_of_libraries * #SIZE (amt$local_file_name))) OF cell]];
    pmp$get_program_description (program_description^, status);
    IF NOT status.normal THEN
      nfp$format_message_to_job_log (status);
      RETURN; {----->
    IFEND;
    RESET program_description;
    NEXT program_attributes IN program_description;
    program_attributes^.contents := program_attributes^.contents +
          $pmt$prog_description_contents [pmc$starting_proc_specified];
    program_attributes^.starting_procedure := 'NFP$BTFS_SERVICE_TASK';

   log_names [1] := 'JOB_MESSAGE';
   clp$log_comment ('Batch Transfer Facility Server', log_names, log_status);

{}
{     MAIN loop
{}

  /process_connection/
    WHILE TRUE DO

{}
{     Get network path name
{}

      pmp$get_unique_name (network_file_name, status);
      IF NOT status.normal THEN
        nfp$format_message_to_job_log (status);
        RETURN; {----->
      IFEND;
      path.application_sequence_number := path.application_sequence_number + 1;
      path.network_file^ := network_file_name;

{}
{     Get network connection - this is where we wait for something to do
{     Upon normal exit from nfp$get_server_async_event we should have a
{     connection to BTF/DI
{}

      nfp$get_server_asynch_event (application, path, lcn_boot, nam_boot,
            task_queue, status);
      IF NOT status.normal THEN
        nfp$format_message_to_job_log (status);
        RETURN; {----->
      IFEND;

{}
{     Now we have a connection, execute the service task
{}

      parameter_set.path_info := path;
      parameter_set.network_file := path.network_file^;
      program_parameters := ^parameter_block;
      RESET program_parameters;
      NEXT parameter_pointer IN program_parameters;
      parameter_pointer^ := parameter_set;
      RESET program_parameters;

      pmp$execute (program_description^, program_parameters^, osc$nowait,
            task_id, task_status, status);
      IF status.normal THEN
        IF nfc$trace_commands THEN
          log_message := 'BTFS - Execute service task, task id = xxxxxxxxxx';
          STRINGREP (task_id_string, task_id_string_length, task_id);
          log_message (39, 10) := task_id_string (1, task_id_string_length);
          pmp$log (log_message, log_status);
          IF NOT log_status.normal THEN
            nfp$format_message_to_job_log (log_status);
            RETURN; {----->
          IFEND;
        IFEND;
        nfp$enqueue_task (task_id, path, task_queue);
        path.path_connected := FALSE;
      ELSE
        { Break connecton with BTF/DI }
        nfp$terminate_path (application, FALSE, path, status);
      IFEND;

    WHILEND /process_connection/;

{}

  PROCEND nfp$btfs_boot;

?? TITLE := '[XDCL] NFP$BTFS_SERVICE_TASK', EJECT ??

  PROCEDURE [XDCL] nfp$btfs_service_task
    (    parameter_list: clt$parameter_list);

{}
{  PROCEDURE:  nfp$btfs_service_task
{
{  PURPOSE:    This is the entry procedure for the BTFS service task.
{              This task is executed by the "BOOT".
{
{  DESCRIPTION:
{              This routine services a connection by transferring in a file
{              that is then placed in a NOS/VE queue.
{
{  INPUT PARAMETERS:
{              parameter_list : Passed via PMP$EXECUTE, contains network_file &
{                               network path, needed for the control_block.
{
{  OUTPUT PARAMETERS:
{              none
{
{  ALGORITHM:
{              Get connection info
{              Establish connect
{              Transfer file
{}

?? NEWTITLE := '  NFP$BTF_SERVICE_TASK Data', EJECT ??

    VAR
      parameter_00_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE],
            [{ B101: } TRUE, nfc$p00_min_size, nfc$p00_max_size,
            [nfc$rft, nfc$rpos, nfc$rneg], [], [], [], FALSE]];

    VAR
      parameter_01_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_02_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_03_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE],
            [{ B101: } TRUE, nfc$p03_min_size, nfc$p03_max_size, [nfc$rft], [],
            [], [], FALSE]];

    VAR
      parameter_04_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE],
            [{ B101: } TRUE, nfc$p04_min_param_len, nfc$p04_max_param_len,
            [nfc$rneg, nfc$stop, nfc$stopr], [], [], [], FALSE]];

    VAR
      parameter_05_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_06_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_07_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_08_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE],
            [{ B101: } TRUE, nfc$p08_min_param_len,
            nfc$p08_max_param_len_b101, [], [], [], [], TRUE]];

    VAR
      parameter_09_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE],
            [{ B101: } TRUE, nfc$p09_min_param_len,
            nfc$p09_max_param_len_b101, [], [], [], [], TRUE]];

    VAR
      parameter_10_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_11_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_12_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE],
            [{ B101: } TRUE, nfc$p12_min_size_b101, nfc$p12_max_size_b101, [],
            [], [], [], FALSE]];

    VAR
      parameter_13_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE],
            [{ B101: } TRUE, nfc$p13_min_param_size, nfc$p13_max_param_size,
            [], [], [], [], FALSE]];

    VAR
      parameter_16_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE],
            [{ B101: } TRUE, nfc$p16_min_param_length,
            nfc$p16_max_param_length_b101, [], [], [], [], FALSE]];

    VAR
      parameter_17_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } TRUE, nfc$p17_min_size, nfc$p17_max_size, [],
            [], [], [], FALSE]];

    VAR
      parameter_18_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_19_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_20_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE],
            [{ B101: } TRUE, nfc$p20_min_size, nfc$p20_max_size, [nfc$rft], [],
            [], [], FALSE]];

    VAR
      parameter_21_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_22_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE],
            [{ B101: } TRUE, nfc$p22_min_size, nfc$p22_max_size,
            [nfc$rft, nfc$rpos], [], [], [], FALSE]];

    VAR
      parameter_23_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_24_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_25_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE],
            [{ B101: } TRUE, nfc$p25_min_param_size,
            nfc$p25_max_param_size_b101, [nfc$rft], [], [], [], FALSE]];

    VAR
      parameter_26_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE],
            [{ B101: } TRUE, nfc$p26_min_param_length,
            nfc$p26_max_param_length_b101, [], [], [], [], FALSE]];

    VAR
      parameter_27_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_28_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_29_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_30_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE],
            [{ B101: } TRUE, nfc$p30_min_param_size, nfc$p30_max_param_size,
            [], [], [], [], FALSE]];

    VAR
      parameter_31_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE],
            [{ B101: } TRUE, nfc$p31_min_param_length_b101,
            nfc$p31_max_param_length_b101, [], [], [], [], FALSE]];

    VAR
      parameter_32_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE],
            [{ B101: } TRUE, nfc$p32_min_param_length_b101,
            nfc$p32_max_param_length_b101, [nfc$rft], [], [], [], FALSE]];

    VAR
      parameter_33_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_51_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_52_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_53_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_54_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_55_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_56_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_57_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_58_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE],
            [{ B101: } TRUE, nfc$p58_min_param_size, nfc$p58_max_param_size,
            [nfc$rft], [], [], [], FALSE]];

    VAR
      parameter_59_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_60_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_90_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_91_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_92_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_93_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_94_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_95_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_96_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_97_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_98_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_99_rules: [READ, STATIC] nft$parameter_rules :=
            [[{ A102: } FALSE], [{ A101: } FALSE], [{ B101: } FALSE]];

    VAR
      parameter_rules: [READ, STATIC] nft$parameter_rules_array := [

            ^parameter_00_rules, ^parameter_01_rules, ^parameter_02_rules,
            ^parameter_03_rules, ^parameter_04_rules, ^parameter_05_rules,
            ^parameter_06_rules, ^parameter_07_rules, ^parameter_08_rules,
            ^parameter_09_rules, ^parameter_10_rules, ^parameter_11_rules,
            ^parameter_12_rules, ^parameter_13_rules, ^parameter_16_rules,
            ^parameter_17_rules, ^parameter_18_rules, ^parameter_19_rules,
            ^parameter_20_rules, ^parameter_21_rules, ^parameter_22_rules,
            ^parameter_23_rules, ^parameter_24_rules, ^parameter_25_rules,
            ^parameter_26_rules, ^parameter_27_rules, ^parameter_28_rules,
            ^parameter_29_rules, ^parameter_30_rules, ^parameter_31_rules,
            ^parameter_32_rules, ^parameter_33_rules, ^parameter_51_rules,
            ^parameter_52_rules, ^parameter_53_rules, ^parameter_54_rules,
            ^parameter_55_rules, ^parameter_56_rules, ^parameter_57_rules,
            ^parameter_58_rules, ^parameter_59_rules, ^parameter_60_rules,
            ^parameter_90_rules, ^parameter_91_rules, ^parameter_92_rules,
            ^parameter_93_rules, ^parameter_94_rules, ^parameter_95_rules,
            ^parameter_96_rules, ^parameter_97_rules, ^parameter_98_rules,
            ^parameter_99_rules];

?? EJECT ??

    VAR
      conditions: pmt$condition,
      control_block: nft$control_block,
      establish_descriptor: pmt$established_handler,
      ignore_status: ost$status,
      log_message: string (nfc$trace_commands_width),
      log_message_length: integer,
      log_status: ost$status,
      network_file_name: ost$name,
      parameter_sequence: ^clt$parameter_list,
      parameter_value: ^service_params,
      p17_param: nft$parameter_17_definition,
      p25_params: nft$p25_b101_params,
      p26_param: nft$parameter_26_definition,
      p32: nft$p32_b101_text,
      p32_ntf_params: nft$p32_b101_ntf_params,
      p32_private_params: nft$p32_b101_private_params,
      p32_public_params: nft$p32_b101_public_params,
      p58: nft$p58_b101_text,
      p58_ntf_params: nft$p58_b101_ntf_params,
      p58_private_params: nft$p58_b101_private_params,
      p58_public_params: nft$p58_b101_public_params,
      status: ost$status;

?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_RFT', EJECT ??

    PROCEDURE process_rft
      (    received_params: nft$parameter_set;
       VAR control_block: nft$control_block;
       VAR process_rft_status: ost$status);

{}
{  PROCEDURE:  process_rft
{
{  PURPOSE:    This procedure unpacks parameters received on an RFT command.
{
{  DESCRIPTION:
{              The RFT command carries with it a series of mandatory and
{              optional parameters.  These parameters are:
{
{              - Parameter 17:  Disposition code (Optional)
{              - Parameter 25:  Transfer LID
{              - Parameter 26:  User job name (Optional)
{              - Parameter 32:  System routing text
{              - Parameter 58:  Output file destination
{
{  INPUT PARAMETERS:
{              received_params    : parameters received on RFT
{
{  OUTPUT PARAMETERS:
{              process_rft_status : status of procedure
{
{  INPUT/OUTPUT PARAMETER:
{              control_block      : used for communicating with various nfp$...
{                                   helper procedures
{
{  ALGORITHM:
{              Get value of file disposition from parameter 17
{              Get value of destination family from parameter 25
{              Get value of user job name from parameter 26
{              Call unpack_text to get values of parameter 32
{              Call unpack_text to get values of parameter 58
{}

?? NEWTITLE := '    UNPACK_TEXT', EJECT ??

      PROCEDURE unpack_text
        (    parameter: string ( * );
             text: string ( * );
         VAR param_array: array [1 .. * ] of ost$name;
         VAR unpack_text_status: ost$status);

{}
{  PROCEDURE:  unpack_text
{
{  PURPOSE:    This procedure unpacks names contained in a text-type protocol
{              parameter.
{
{  DESCRIPTION:
{              Text-type protocol parameters (for example parameter 32)
{              contain a variant identifier (eg CN0) followed by a comma
{              and a list of names separated by commas.  This procedure returns
{              each of these names in an element of the passed param_array.
{
{              An unexpected number of parameters, or a non-name parameter
{              will be considered a protocol violation.
{
{  INPUT PARAMETERS:
{              parameter   : A string indicating what protocol parameter is
{                            being processed - used in error messages
{              text        : The text from the protocol parameter, excluding
{                            the variant identifier
{
{  OUTPUT PARAMETERS:
{              param_array : Each element in this array will contiain a name
{                            as obtained from the input text
{              status      : Status of procedure
{
{  ALGORITHM:  clt$scan_token is used to crack the text - only commas are
{              allowed as separators
{}

        VAR
          errmsg: string (80),
          first_token: boolean,
          length: integer,
          param_index: integer,
          token_index: ost$string_index,
          token: clt$token;

{}

      /initialize_param_array/
        FOR param_index := LOWERBOUND (param_array)
              TO UPPERBOUND (param_array) DO
          param_array [param_index] := osc$null_name;
        FOREND /initialize_param_array/;

        first_token := TRUE;
        param_index := LOWERBOUND (param_array);
        token.kind := clc$unknown_token;
        token_index := 1;

{}
{     Main loop
{}

      /process_tokens/
        WHILE NOT (token.kind = clc$eol_token) DO
          clp$scan_token (text, token_index, token, unpack_text_status);
          IF NOT unpack_text_status.normal THEN
            nfp$format_message_to_job_log (unpack_text_status);
            RETURN; {----->
          IFEND;

          CASE token.kind OF
          = clc$name_token =
            param_array [param_index] := token.name.value (1, token.name.size);
          = clc$comma_token =
            IF (param_index = UPPERBOUND (param_array)) THEN
              STRINGREP (errmsg, length, 'BTFS unpack_text: (', parameter,
                    ') too many values -');
              osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
                    errmsg (1, length), unpack_text_status);
              RETURN; {----->
            ELSEIF NOT first_token THEN
              param_index := SUCC (param_index);
            IFEND;
          = clc$eol_token =
            IF (param_index <> UPPERBOUND (param_array)) THEN
              STRINGREP (errmsg, length, 'BTFS unpack_text: (', parameter,
                    ') too few values -');
              osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
                    errmsg (1, length), unpack_text_status);
              RETURN; {----->
            IFEND;
          ELSE
            STRINGREP (errmsg, length, 'BTFS unpack_text: (', parameter,
                  ') bad token -');
            osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
                  errmsg (1, length), unpack_text_status);
            RETURN; {----->
          CASEND;

          first_token := FALSE;

        WHILEND /process_tokens/;

{}

      PROCEND unpack_text;

?? OLDTITLE, EJECT ??

      VAR
        errmsg: string (80),
        length: integer;

{}
{     Process parameter 17 (disposition code - optional)
{}

      IF nfc$file_disposition IN received_params THEN
        p17_param := control_block.disposition_code;
      IFEND;

{}
{     Process parameter 25 (transfer lid - becomes execution family)
{}

      unpack_text ('P25', control_block.remote_lid, p25_params,
            process_rft_status);
      IF NOT process_rft_status.normal THEN
        RETURN; {----->
      IFEND;

{}
{     Process parameter 26 (job name - optional)


      IF nfc$job_name IN received_params THEN
        p26_param := control_block.receive_job_name;
        IF p26_param.value(1, p26_param.size) = ' ' THEN
          p26_param.size := 0;
        IFEND;
      ELSE
        p26_param.size := 0;
      IFEND;

{}
{     Process parameter 32 (system routing text)
{}

      p32.variant := control_block.receive_systems_routing_text.
            parameters (1, nfc$p32_variant_size);
      p32.text := control_block.receive_systems_routing_text.
            parameters (nfc$p32_variant_size + 1,
            control_block.receive_systems_routing_text.size -
            nfc$p32_variant_size);

      IF (p32.variant = nfc$p32_b101_private_ios_id) THEN
        unpack_text ('P32', p32.text, p32_private_params, process_rft_status);
      ELSEIF (p32.variant = nfc$p32_b101_public_ios_id) THEN
        unpack_text ('P32', p32.text, p32_public_params, process_rft_status);
      ELSEIF (p32.variant = nfc$p32_b101_ntf_id) THEN
        unpack_text ('P32', p32.text, p32_ntf_params, process_rft_status);
      ELSE
        STRINGREP (errmsg, length, 'BTFS process_rft: (P32) unknown variant -',
              p32.variant, '-');
        osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
              errmsg (1, length), process_rft_status);
        RETURN; {----->
      IFEND;

      IF NOT process_rft_status.normal THEN
        RETURN; {----->
      IFEND;

{}
{     Process parameter 58 (output file destination)
{}

      p58.variant := control_block.default_output_file_destination.
            value (1, nfc$p58_variant_size);
      p58.text := control_block.default_output_file_destination.
            value (nfc$p58_variant_size + 1, control_block.
            default_output_file_destination.size - nfc$p58_variant_size);

      IF (p58.variant = nfc$p58_b101_private_ios_id) THEN
        unpack_text ('P58', p58.text, p58_private_params, process_rft_status);
      ELSEIF (p58.variant = nfc$p58_b101_public_ios_id) THEN
        unpack_text ('P58', p58.text, p58_public_params, process_rft_status);
      ELSEIF (p58.variant = nfc$p58_b101_ntf_id) THEN
        unpack_text ('P58', p58.text, p58_ntf_params, process_rft_status);
      ELSE
        STRINGREP (errmsg, length, 'BTFS process_rft: (P58) unknown variant -',
              p58.variant, '-');
        osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
              errmsg (1, length), process_rft_status);
        RETURN; {----->
      IFEND;

      IF NOT process_rft_status.normal THEN
        RETURN; {----->
      IFEND;

      process_rft_status.normal := TRUE;

    PROCEND process_rft;

?? OLDTITLE ??
?? NEWTITLE := '  SERVICE_HANDLER', EJECT ??

    PROCEDURE service_handler
      (    condition: pmt$condition;
           condition_desc: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR trap_status: ost$status);

{}
{  PROCEDURE:  service_handler
{
{  PURPOSE:    This is the condition handler for nfm$btfs_service_task.
{
{}

      VAR
        handler_ignore_status: ost$status,
        local_status: ost$status;

{}

      { Break connection with BTF/DI }
      nfp$terminate_path (control_block.application, FALSE, control_block.path,
            handler_ignore_status);

      amp$return (control_block.file_name, handler_ignore_status);

      pmp$log ('BTFS service task terminating', handler_ignore_status);

      osp$set_status_from_condition (nfc$status_id, condition, save_area,
            local_status, handler_ignore_status);

      nfp$format_message_to_job_log (local_status);

{}

    PROCEND service_handler;

?? OLDTITLE ??
?? NEWTITLE := '  SUBMIT_JOB', EJECT ??

    PROCEDURE submit_job
      (    accounting_data: batch_input_accounting;
       VAR control_block: nft$control_block;
       VAR stopr_params: nft$parameter_set;
       VAR status: ost$status);

{}
{  PROCEDURE:  submit_job
{
{  PURPOSE:    This procedure submits the file received as a batch job
{
{  DESCRIPTION:
{              This procedure sets up the options required to properly set
{              up the job_attributes of the job to be submitted.
{              The job is then submitted to the input queue.
{              The parameters that will be returned on the STOPR are
{              determined by the success/failure of the submit_job.
{
{  INPUT PARAMETERS:
{              accounting_data : Data used for batch_input communication
{                                accounting.
{
{  OUTPUT PARAMETERS:
{              status          : Status of procedure
{              stopr_params    : Parameter set to be sent on STOPR command. Will
{                                be set depending on status of jmp$submit_job.
{
{  INPUT/OUTPUT PARAMETER:
{              control_block   : used for communicating with various nfp$...
{                                helper procedures
{
{  ALGORITHM:
{              Set up job submission options
{              Submit_job
{              IF success THEN
{                Set STOPR parameters for successful transfer
{              ELSE
{                Set STOPR parameters for unsuccessful transfer
{              IFEND
{
{}

      TYPE
        job_attributes = (control_family, control_user, destination_family,
              destination_usage, execution_family, inherit_job_attributes,
              job_input_device, output_destination, origin_application, station,
              station_operator, user_job_name);

      VAR
        attribute_index: job_attributes,
        enqueue_status: ost$status,
        index: 0 .. jmc$maximum_attribute_index,
        job_options: array [job_attributes] of boolean,
        number_of_attributes: integer,
        p08_list: nft$directive_entry_list_head,
        submit_options: ^jmt$job_submission_options,
        submit_status: ost$status,
        submit_sys_name: jmt$system_supplied_name,
        xfer_status: ost$status;

      index := 0;
      number_of_attributes := 0;
      p08_list.head := NIL;
      p08_list.tail := NIL;

{}
{     Set up job_submission_options
{}

    /initialize_job_options/
      FOR attribute_index := LOWERBOUND (job_options)
            TO UPPERBOUND (job_options) DO
        job_options [attribute_index] := FALSE;
      FOREND /initialize_job_options/;

      job_options [execution_family] := TRUE;
      number_of_attributes := number_of_attributes + 1;

      job_options [inherit_job_attributes] := TRUE;
      number_of_attributes := number_of_attributes + 1;

      job_options [job_input_device] := TRUE;
      number_of_attributes := number_of_attributes + 1;

      job_options [origin_application] := TRUE;
      number_of_attributes := number_of_attributes + 1;

      IF p26_param.size > 0 THEN
        job_options [user_job_name] := TRUE;
        number_of_attributes := number_of_attributes + 1;
      IFEND;

      IF (p32.variant = nfc$p32_b101_private_ios_id) THEN
        job_options [control_family] := TRUE;
        job_options [control_user] := TRUE;
        number_of_attributes := number_of_attributes + 2;
      IFEND;

      IF (p58.variant = nfc$p58_b101_private_ios_id) THEN
        job_options [destination_family] := TRUE;
        job_options [destination_usage] := TRUE;
        job_options [output_destination] := TRUE;
        job_options [station] := TRUE;
        job_options [station_operator] := TRUE;
        number_of_attributes := number_of_attributes + 5;
      ELSE
        job_options [destination_usage] := TRUE;
        job_options [output_destination] := TRUE;
        job_options [station] := TRUE;
        number_of_attributes := number_of_attributes + 3;
      IFEND;

      PUSH submit_options: [1 .. number_of_attributes];

{}
{     Process specified attributes
{}

    /process_specified_attributes/
      FOR attribute_index := LOWERBOUND (job_options)
            TO UPPERBOUND (job_options) DO

        IF job_options [attribute_index] THEN

          index := index + 1;

          CASE attribute_index OF

          = control_family =
            submit_options^ [index].key := jmc$control_family;
            submit_options^ [index].control_family :=
                  p32_private_params [nfc$p32_b101_op_family];

          = control_user =
           submit_options^ [index].key := jmc$control_user;
           submit_options^ [index].control_user :=
                  p32_private_params [nfc$p32_b101_op_user_name];

          = destination_family =
            IF p58_private_params [nfc$p58_b101_op_family] <> osc$null_name THEN
              submit_options^ [index].key := jmc$output_destination_family;
              submit_options^ [index].output_destination_family :=
                    p58_private_params [nfc$p58_b101_op_family];
            ELSE
              submit_options^ [index].key := jmc$null_attribute;
            IFEND;

          = destination_usage =
            submit_options^ [index].key := jmc$output_destination_usage;
            IF (p58.variant = nfc$p58_b101_private_ios_id) THEN
              submit_options^ [index].output_destination_usage :=
                    jmc$private_usage;
            ELSE
              submit_options^ [index].output_destination_usage :=
                    jmc$public_usage;
            IFEND;

          = execution_family =
            submit_options^ [index].key := jmc$default_login_family;
            submit_options^ [index].default_login_family :=
                  p25_params [nfc$p25_input_family];

          = inherit_job_attributes =

            submit_options^ [index].key := jmc$inherit_job_attributes;
            submit_options^ [index].inherit_job_attributes := FALSE;

          = job_input_device =
            submit_options^ [index].key := jmc$job_input_device;
            submit_options^ [index].job_input_device :=
                  ^accounting_data.data_string;

          = output_destination =
            submit_options^ [index].key := jmc$output_destination;
            IF (p58.variant = nfc$p58_b101_private_ios_id) THEN
              submit_options^ [index].output_destination :=
                    p58_private_params [nfc$p58_b101_control_facility];
            ELSE
              submit_options^ [index].output_destination :=
                    p58_public_params [nfc$p58_b101_station];
            IFEND;

          = origin_application =
            submit_options^ [index].key := jmc$origin_application_name;
            submit_options^ [index].origin_application_name :=
                  osc$batch_transfer_server;

          = station =
            submit_options^ [index].key := jmc$station;
            IF (p58.variant = nfc$p58_b101_private_ios_id) THEN
              submit_options^ [index].station :=
                    p58_private_params [nfc$p58_b101_control_facility];
            ELSE
              submit_options^ [index].station :=
                    p58_public_params [nfc$p58_b101_station];
            IFEND;

          = station_operator =
            submit_options^ [index].key := jmc$station_operator;
            submit_options^ [index].station_operator :=
                  p58_private_params [nfc$p58_b101_op_user_name];

          = user_job_name =
            submit_options^ [index].key := jmc$user_job_name;
            submit_options^ [index].user_job_name :=
                  p26_param.value(1, p26_param.size);

          ELSE

            osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
                  'BTFS submit_job - CASE states -', status);
            nfp$format_message_to_job_log (status);
            RETURN; {----->

          CASEND;
        IFEND;
      FOREND /process_specified_attributes/;

{}
{     Submit job to input queue
{}

      jmp$submit_job (control_block.file_name, submit_options, submit_sys_name,
            submit_status);

      IF submit_status.normal THEN
        control_block.send_file_name.value := submit_sys_name;
        control_block.send_file_name.size := jmc$system_supplied_name_size;
        stopr_params := $nft$parameter_set [nfc$state_of_transfer,
              nfc$file_name];
      ELSE
        { Set submit_status text into parameter 08 (user message) }
        nfp$enqueue_status_directive (submit_status, p08_list, status);
        IF NOT status.normal THEN
          nfp$format_message_to_job_log (status);
          RETURN; {----->
        IFEND;
        control_block.send_user_messages := p08_list.head;
        osp$set_status_abnormal (nfc$status_id, nfe$transfer_rejected_message,
              '', xfer_status);
        nfp$set_abnormal_if_normal (xfer_status,
              control_block.state_of_transfer);
        stopr_params := $nft$parameter_set [nfc$state_of_transfer,
              nfc$user_message];
      IFEND;

{}

    PROCEND submit_job;

?? OLDTITLE ??
?? NEWTITLE := '  TRANSFER_FILE', EJECT ??

    PROCEDURE transfer_file
      (VAR control_block: nft$control_block);

{}
{  PROCEDURE:  transfer_file
{
{  PURPOSE:    This procedure gets a file from the BTF/DI peer application.
{
{  DESCRIPTION:
{              This routine performs the protocol initialization and
{              termination necessary to transfer a file from BTF/DI.
{              The protocol employed is the A-A B101 protocol.  Actual
{              data transfer is performed by nfp$receive_file.
{
{              The file received will be placed in a NOS/VE queue.
{              This routine is capable of handling multiple back-to-back
{              file transfers, if needed.
{
{  INPUT PARAMETERS:
{              None
{
{  OUTPUT PARAMETERS:
{              None
{
{  INPUT/OUTPUT PARAMETER:
{              control_block : used for communicating with various nfp$...
{                              helper procedures
{
{  ALGORITHM:
{              The file transfer logic is modelled after the following state
{              table:

?? EJECT ??

{
{         FILE TRANSFER STATE TABLE
{         -------------------------
{
{
{
{                RFT     GO     STOP     ETP    FINI    ERROR
{
{             +-------+-------+-------+-------+-------+-------+
{             |  S/   |       |       |       |       |(Bad   |
{      START  | RPOS  |   *   |   *   |   *   |   *   |  RFT) |
{             |       |       |       |       |       |S/RNEG |
{             |>XFER  |       |       |       |       |>ERRSTP|
{             +-------+-------+-------+-------+-------+-------+
{             |       | Xfer  |  S/   |       |       |(Bad   |
{      XFER   |   *   | file  | STOPR |   *   |   *   | xfer) |
{             |       |       |       |       |       |       |
{             |       |>ENQF  |>WETP  |       |       |>ERRSTP|
{             +-------+-------+-------+-------+-------+-------+
{             |       |       |Enqueue|       |       |(Bad   |
{      ENQF   |   *   |   *   | file, |   *   |   *   | STOP) |
{             |       |       |S/STOPR|       |       |S/STOPR|
{             |       |       |>WETP  |       |       |>WETP  |
{             +-------+-------+-------+-------+-------+-------+
{             |       |       |  S/   |       |       |       |
{      ERRSTP |   *   |   *   | STOPR |   *   |   *   |   *   |
{             |       |       |       |       |       |       |
{             |       |       |>WETP  |       |       |       |
{             +-------+-------+-------+-------+-------+-------+
{             |  S/   |       |       |  S/   |       |(Bad   |
{      WETP   | RPOS  |   *   |   *   | ETPR  |   *   |  RFT) |
{             |       |       |       |       |       |S/RNEG |
{             |>XFER  |       |       |>WFINI |       |>ERRSTP|
{             +-------+-------+-------+-------+-------+-------+
{             |       |       |       |       |       |       |
{      WFINI  |   *   |   *   |   *   |   *   | Exit  |   *   |
{             |       |       |       |       |       |       |
{             |       |       |       |       |       |       |
{             +-------+-------+-------+-------+-------+-------+
{
{            S/  Send Command
{            >   State change
{            *   Illegal state
{            ()  Internal error condition
{}

?? EJECT ??

      TYPE
        incoming_commands = array [file_transfer_states] of nft$command_set,
        file_transfer_states = (start, xfer, enqf, errstp, wetp, wfini),

        parameter_09_message = record
          CASE boolean OF
          = FALSE =
            text: string (16),
          = TRUE =
            number_of_cards: string (8),
            bytes_transferred: string (8),
          CASEND,
        recend;

      VAR
        legal_receive_commands: [READ, STATIC] incoming_commands := [
              {  START: } [nfc$rft],
              {   XFER: } [nfc$go, nfc$stop],
              {   ENQF: } [nfc$stop],
              { ERRSTP: } [nfc$stop],
              {   WETP: } [nfc$rft, nfc$etp],
              {  WFINI: } [nfc$fini]];

      VAR
        required_params: [READ, STATIC] nft$required_param_on_command := [
              { Unknown: } [],
              { RFT:     } [nfc$protocol_id, nfc$facilities,
              nfc$minimum_timeout_interval, nfc$host_type, nfc$transfer_lid,
              nfc$system_routing_text, nfc$output_file_destination],
              { RPOS:    } [nfc$protocol_id, nfc$host_type],
              { RNEG:    } [nfc$protocol_id, nfc$state_of_transfer],
              { GO:      } [],
              { STOP:    } [nfc$state_of_transfer],
              { STOPR:   } [nfc$state_of_transfer],
              { ETP:     } [],
              { ETPR:    } [],
              { FINI:    } []];

      CONST
        max_data_area_size = 1000;

      VAR
        accounting_data: batch_input_accounting,
        account_message: parameter_09_message,
        elapsed_time: integer,
        end_time: ost$date_time,
        etpr_command: [READ, STATIC] nft$protocol_commands := nfc$etpr,
        etpr_params: [READ, STATIC] nft$parameter_set := [],
        file_size: amt$file_length,
        get_attributes: ^nat$get_attributes,
        get_accounting_data: ^nat$accounting_data_fields,
        ignored_params: nft$parameter_set,
        index: integer,
        modified_params: nft$parameter_set,
        msg_status: ost$status,
        ntf_p08_list: nft$directive_entry_list_head,
        ntf_queue_status: ost$status,
        number_of_cards: clt$integer,
        peer_accounting_information: ^string ( * ),
        peer_connect_data: ^string ( * ),
        protocol_consistent: boolean,
        rcv_status: ost$status,
        received_params: nft$parameter_set,
        rft_status: ost$status,
        rpos_command: [READ, STATIC] nft$protocol_commands := nfc$rpos,
        rpos_params: [READ, STATIC] nft$parameter_set :=
              [nfc$protocol_id, nfc$host_type],
        rneg_command: [READ, STATIC] nft$protocol_commands := nfc$rneg,
        rneg_params: [READ, STATIC] nft$parameter_set :=
              [nfc$protocol_id, nfc$state_of_transfer],
        set_status: ost$status,
        start_time: ost$date_time,
        state: file_transfer_states,
        status: ost$status,
        stopr_command: [READ, STATIC] nft$protocol_commands := nfc$stopr,
        stopr_params: nft$parameter_set,
        transfer_mode: nft$transfer_modes,
        transfer_status: ost$status;

?? EJECT ??

{}
{     BEGIN transfer_file
{}

      state := start;

{}
{     MAIN LOOP
{}

    /state_processor/
      WHILE TRUE DO

        control_block.local_status.normal := TRUE;
        control_block.state_of_transfer.normal := TRUE;

        { Get a protocol command from BTF/DI }
        nfp$receive_command (legal_receive_commands [state], required_params,
              control_block, received_params, ignored_params, modified_params,
              rcv_status);

        IF NOT control_block.path.path_connected THEN
          { Note that connection broken after sending a STOPR is legal }
          IF state <> wetp THEN
            osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
                  'BTFS transfer_file - connection broken -', msg_status);
            nfp$format_message_to_job_log (msg_status);
            nfp$format_message_to_job_log (rcv_status);
          IFEND;
          RETURN; {----->
        IFEND;

        IF NOT rcv_status.normal THEN
          nfp$format_message_to_job_log (rcv_status);
          IF rcv_status.condition = nfe$invalid_command_code THEN
            RETURN; {----->
          IFEND;
        IFEND;

        stopr_params := $nft$parameter_set [nfc$state_of_transfer];

        CASE state OF

        = start =
          { Note RFT is the only legal command for this state }
          pmp$get_compact_date_time (start_time, status);
          IF NOT status.normal THEN
            nfp$set_abnormal_if_normal (status, control_block.local_status);
            RETURN; {----->
          IFEND;
          process_rft (received_params, control_block, rft_status);
          IF (rcv_status.normal AND rft_status.normal) THEN
            { Send RPOS command to BTF/DI indicating we like RFT }
            nfp$send_command (rpos_command, rpos_params,
             $nft$parameter_set[ ], $nft$parameter_set[ ],
             control_block, status);
            state := xfer;
          ELSE
            { Send RNEG command to BTF/DI indicating we dislike RFT }
            nfp$send_command (rneg_command, rneg_params,
             $nft$parameter_set[ ], $nft$parameter_set[ ],
             control_block, status);
            state := errstp;
          IFEND;

        = xfer =
          { Note GO and STOP are the only legal commands for this state }
          IF (control_block.last_command_received = nfc$go) THEN

            { Perform data portion of file transfer }

            IF (p32.variant = nfc$p32_b101_ntf_id) THEN
              transfer_mode := nfc$transparent_data_mode;
            ELSE
              transfer_mode := nfc$coded_data_mode;
            IFEND;

            nfp$receive_file (control_block.path.network_file_id, control_block.
                  file_name, control_block.transfer_facilities,
                  transfer_mode, control_block.data_block_size,
                  control_block.time_out, nfc$p00_b101, nfc$network_nam,
                  osc$user_ring, control_block.protocol_trace,
                  file_size, protocol_consistent, transfer_status, status);

            IF NOT protocol_consistent THEN
              nfp$format_message_to_job_log (transfer_status);
              nfp$terminate_path (control_block.application, TRUE, control_block.
                    path, status);
              state := errstp;
            ELSEIF (NOT status.normal) OR (NOT transfer_status.normal) THEN
              state := errstp;
            ELSE
              state := enqf;
            IFEND;
          ELSE { control_block.last_command_received = nfc$stop }
            osp$set_status_abnormal (nfc$status_id,
                  nfe$transfer_rejected_message, '', set_status);
            nfp$set_abnormal_if_normal (set_status,
                  control_block.state_of_transfer);
            { Send STOPR command to BTF/DI indicating file transfer complete }
            nfp$send_command (stopr_command, stopr_params,
             $nft$parameter_set[ ], $nft$parameter_set[ ],
             control_block, status);
            state := wetp;
          IFEND;

        = enqf =
          { Note STOP is the only legal command for this state }
          IF rcv_status.normal THEN
            IF (p32.variant = nfc$p32_b101_ntf_id) THEN
              ntf_p08_list.head := NIL;
              ntf_p08_list.tail := NIL;
              nfp$ntf_receive_file (control_block, p17_param, p32_ntf_params,
                    p58_ntf_params, stopr_params, ntf_queue_status, status);
              IF status.normal AND (NOT ntf_queue_status.normal) THEN
                ntf_p08_list.head := NIL;
                ntf_p08_list.tail := NIL;
                nfp$enqueue_status_directive (ntf_queue_status, ntf_p08_list, status);
                IF NOT status.normal THEN
                  nfp$format_message_to_job_log (status);
                  RETURN; {----->
                IFEND;

                control_block.send_user_messages := ntf_p08_list.head;
              IFEND;
            ELSE

{ Collect communication accounting data

              pmp$get_compact_date_time (end_time, status);
              IF NOT status.normal THEN
                nfp$set_abnormal_if_normal (status, control_block.local_status);
                RETURN; {----->
              IFEND;
              pmp$compute_time_dif_in_seconds (start_time, end_time,
                    elapsed_time, status);
              IF NOT status.normal THEN
                nfp$set_abnormal_if_normal (status, control_block.local_status);
                RETURN; {----->
              IFEND;

{ Retrieve peer_accounting_information and peer_connect_data attributes.

              PUSH get_attributes: [1 .. 2];
              get_attributes^ [1].kind := nac$peer_accounting_information;
              PUSH get_attributes^ [1].peer_accounting_information: [[REP max_data_area_size OF cell]];
              get_attributes^ [2].kind := nac$peer_connect_data;
              PUSH get_attributes^ [2].peer_connect_data: [[REP max_data_area_size OF cell]];

              nap$get_attributes (control_block.path.network_file^, get_attributes^, status);
              IF NOT status.normal THEN
                nfp$set_abnormal_if_normal (status, control_block.local_status);
                RETURN; {----->
              IFEND;

              IF get_attributes^ [1].peer_accounting_info_length = 0 THEN
                peer_accounting_information := NIL;
              ELSE
                RESET get_attributes^ [1].peer_accounting_information;
                NEXT peer_accounting_information: [get_attributes^ [1].peer_accounting_info_length] IN
                      get_attributes^ [1].peer_accounting_information;
              IFEND;

              IF get_attributes^ [2].peer_connect_data_length = 0 THEN
                peer_connect_data := NIL;
              ELSE
                RESET get_attributes^ [2].peer_connect_data;
                NEXT peer_connect_data: [get_attributes^ [2].peer_connect_data_length] IN
                      get_attributes^ [2].peer_connect_data;
              IFEND;

              PUSH get_accounting_data: [1 .. 6];
              get_accounting_data^ [1].kind := nac$ca_di_system_name;
              get_accounting_data^ [2].kind := nac$ca_line_name;
              get_accounting_data^ [3].kind := nac$ca_line_subtype;
              get_accounting_data^ [4].kind := nac$ca_line_speed;
              get_accounting_data^ [5].kind := nac$ca_i_o_station_name;
              get_accounting_data^ [6].kind := nac$ca_device_name;
              nap$parse_accounting_data (peer_accounting_information, peer_connect_data,
                    get_accounting_data, status);
              IF NOT status.normal THEN
                nfp$set_abnormal_if_normal (status, control_block.local_status);
                RETURN; {----->
              IFEND;

              IF control_block.received_account_messages.head <> NIL THEN
                account_message.text := control_block.received_account_messages.
                      head^.line (1, #SIZE (parameter_09_message));
                clp$convert_string_to_integer (account_message.number_of_cards,
                      number_of_cards, status);
                IF NOT status.normal THEN
                  nfp$set_abnormal_if_normal (status, control_block.local_status);
                  RETURN; {----->
                IFEND;
              ELSE
                number_of_cards.value := 0;
              IFEND;

{ Set communication accounting data for submit_job

              accounting_data.size := #SIZE (nft$batch_input_accounting_data);
              accounting_data.data_block.connect_time := elapsed_time;
              accounting_data.data_block.number_of_cards :=
                    number_of_cards.value;
              accounting_data.data_block.di_system_name := osc$null_name;
              accounting_data.data_block.line_name := osc$null_name;
              accounting_data.data_block.line_subtype := osc$null_name;
              accounting_data.data_block.line_speed := 0;
              accounting_data.data_block.i_o_station_name := osc$null_name;
              accounting_data.data_block.device_name := osc$null_name;

              FOR index := 1 TO UPPERBOUND (get_accounting_data^) DO
                CASE get_accounting_data^ [index].kind OF
                = nac$ca_di_system_name =
                  accounting_data.data_block.di_system_name :=
                        get_accounting_data^ [index].di_system_name;
                = nac$ca_line_name =
                  accounting_data.data_block.line_name :=
                        get_accounting_data^ [index].line_name;
                = nac$ca_line_subtype =
                  accounting_data.data_block.line_subtype :=
                        get_accounting_data^ [index].line_subtype;
                = nac$ca_line_speed =
                  accounting_data.data_block.line_speed :=
                        get_accounting_data^ [index].line_speed;
                = nac$ca_i_o_station_name =
                  accounting_data.data_block.i_o_station_name :=
                        get_accounting_data^ [index].i_o_station_name;
                =nac$ca_device_name =
                  accounting_data.data_block.device_name :=
                        get_accounting_data^ [index].device_name;
                ELSE
                  ;
                CASEND;
              FOREND;

              submit_job (accounting_data, control_block, stopr_params, status);
            IFEND;
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;
          { Send STOPR command to BTF/DI indicating file transfer complete }
          nfp$send_command (stopr_command, stopr_params,
             $nft$parameter_set[ ], $nft$parameter_set[ ],
             control_block, status);
          state := wetp;

        = errstp =
          { Note STOP is the only legal command for this state }
          osp$set_status_abnormal (nfc$status_id,
                nfe$transfer_rejected_message, '', set_status);
          nfp$set_abnormal_if_normal (set_status,
                control_block.state_of_transfer);
          { Send STOPR command to BTF/DI indicating file transfer complete }
          nfp$send_command (stopr_command, stopr_params,
             $nft$parameter_set[ ], $nft$parameter_set[ ],
             control_block, status);
          state := wetp;

        = wetp =
          { Note ETP and RFT are the only legal commands for this state }
          IF (control_block.last_command_received = nfc$etp) THEN
            { Send ETPR command to BTF/DI indicating protocol complete }
            nfp$send_command (etpr_command, etpr_params,
             $nft$parameter_set[ ], $nft$parameter_set[ ],
             control_block, status);
            state := wfini;
          ELSE { control_block.last_command_received = nfc$rft }
            pmp$get_compact_date_time (start_time, status);
            IF NOT status.normal THEN
              nfp$set_abnormal_if_normal (status, control_block.local_status);
              RETURN; {----->
            IFEND;
            process_rft (received_params, control_block, rft_status);
            IF (rcv_status.normal AND rft_status.normal) THEN
              { Send RPOS command to BTF/DI indicating we like RFT }
              nfp$send_command (rpos_command, rpos_params,
                    $nft$parameter_set[ ], $nft$parameter_set[ ],
                    control_block, status);
              state := xfer;
            ELSE
              { Send RNEG command to BTF/DI indicating we dislike RFT }
              nfp$send_command (rneg_command, rpos_params,
                    $nft$parameter_set[ ], $nft$parameter_set[ ],
                    control_block, status);
              state := errstp;
            IFEND;
          IFEND;

        = wfini =
          { Note FINI is the only legal command for this state }
          RETURN; {----->

        ELSE

          osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
                'BTFS transfer_file - CASE states -', status);
          nfp$format_message_to_job_log (status);
          RETURN; {----->

        CASEND;

{}
{     Check result of previous action
{}

        IF NOT status.normal THEN
          nfp$set_abnormal_if_normal (status, control_block.local_status);
        IFEND;

      WHILEND /state_processor/;

{}

    PROCEND transfer_file;

?? OLDTITLE, EJECT ??

{}
{   BEGIN nfp$btfs_service_task
{}

    status.normal := TRUE;

{}
{   Establish condition handler
{}

    conditions.selector := pmc$condition_combination;
    conditions.combination := $pmt$condition_combination
          [pmc$system_conditions, mmc$segment_access_condition,
          pmc$block_exit_processing, pmc$user_defined_condition,
          ifc$interactive_condition];

    pmp$establish_condition_handler (conditions, ^service_handler,
          ^establish_descriptor, status);
    IF NOT status.normal THEN
      nfp$format_message_to_job_log (status);
      RETURN; {----->
    IFEND;

{}
{   Initialize control block
{}

    nfp$initialize_control_block (

    { Application:      } nfc$application_btfs,
    { Data_Declaration: } nfc$p31_unspecified,
    { Requested Facs:   } $nft$parameter_03_value_set [nfc$ss_ack_required],
    { Required Facs:    } $nft$parameter_03_value_set [nfc$ss_ack_required],
    { Allowed Facs:     } $nft$parameter_03_value_set [nfc$ss_ack_required],
    { Protocol:         } nfc$p00_b101,
    { Mode of access:   } nfc$take,
    {                   } ^parameter_rules, control_block);

    pmp$get_unique_name (control_block.file_name, status);
    IF NOT status.normal THEN
      nfp$format_message_to_job_log (status);
      RETURN; {----->
    IFEND;

    control_block.remote_ring.value := osc$user_ring;

{}
{    Get the parameters passed to the BTFS service task by the BTFS boot
{    via the PMP$EXECUTE command
{}

    parameter_sequence := ^parameter_list;
    RESET parameter_sequence;
    NEXT parameter_value IN parameter_sequence;

    control_block.path := parameter_value^.path_info;
    PUSH control_block.path.network_file: [osc$max_name_size];
    control_block.path.network_file^ := parameter_value^.network_file;

    control_block.path.network_type := nfc$network_nam;

{}
{   Open network file
{}

    fsp$open_file (control_block.path.network_file^, amc$record, NIL, NIL, NIL,
          NIL, NIL, control_block.path.network_file_id, status);
    IF NOT status.normal THEN
      nfp$format_message_to_job_log (status);
      RETURN; {----->
    IFEND;

    control_block.path.path_connected := TRUE;

{}
{   Issue TASK STARTED message
{}

    IF nfc$trace_commands THEN
      log_message := '*BTFS TASK STARTED - CONNECTION # xxxxxxxx *';
      STRINGREP (log_message (35, * ), log_message_length,
            control_block.path.application_sequence_number: 8);
      pmp$log (log_message, log_status);
      IF NOT log_status.normal THEN
        nfp$format_message_to_job_log (log_status);
        RETURN; {----->
      IFEND;
    IFEND;

{}
{   Receive file(s)
{}

    transfer_file (control_block);

{}
{   Clean up
{}

    amp$return (control_block.file_name, ignore_status);

    pmp$disestablish_cond_handler (conditions, ignore_status);

{}

  PROCEND nfp$btfs_service_task;

{}

MODEND nfm$btf_server;
*DECK DECK=NFM$COMMON_TASK_COMMUNICATION EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??                                                                                 
?? FMT (FORMAT := ON, INDENT := 2) ??                                                                         
?? SET (LIST := ON, LISTCTS := OFF) ??                                                                        
?? NEWTITLE := 'NOS/VE : common_task_communication' ??                                                        
MODULE nfm$common_task_communication;                                                                         
                                                                                                              
{********************************************************************************}                            
{                                                                                }                            
{  PURPOSE:                                                                      }                            
{     This module provides easy to use interfaces for the establishment of       }                            
{     asynchronous tasks, and the communication between asynchronous tasks.      }                            
{                                                                                }                            
{  DESCRIPTION:                                                                  }                            
{     The Common Task Communication Module uses the facilities of the system     }                            
{     Job Local Queue Manager and a shared segment to pass messages between      }                            
{     asynchronous tasks. The parent task can request the establishment of       }                            
{     multiple child tasks that run independently of the parent. All tasks       }                            
{     conceived from the same parent can communicate with any other task from    }                            
{     the same parent.                                                           }                            
{                                                                                }                            
{     The shared segment acts as an intertask directory and message buffer.      }                            
{     Messages sent to an asynchronous task are placed in the buffer until       }                            
{     they are picked up by the destination task. Multiple messages can be       }                            
{     queued for the same task.                                                  }                            
{                                                                                }                            
{     The messages are unstructured in format and left to the descretion of      }                            
{     user although there must be agreement between the communication tasks      }                            
{     as to the format of messages.                                              }                            
{                                                                                }                            
{********************************************************************************}                            
?? NEWTITLE := 'global declarations', EJECT ??                                                                
                                                                                                              
  CONST                                                                                                       
    nfc$millisecond = 1000;                                                                                   
                                                                                                              
*copyc nft$intertask_transfer_size                                                                            
*copyc nft$intertask_wait_time                                                                                
                                                                                                              
  TYPE                                                                                                        
    nft$lock_functions = (nfc$lock, nfc$unlock, nfc$examine),                                                 
                                                                                                              
    nft$key_definition = PACKED RECORD                                                                        
        lock_bits: ALIGNED [0 MOD 8] 0 .. 0ffffffff(16),                                                      
        lock_id: 0 .. 0ffffffff(16),                                                                          
      RECEND,                                                                                                 
                                                                                                              
    nft$lock_status = RECORD                                                                                  
        CASE condition: ost$signature_lock_status OF                                                          
          = osc$sls_not_locked =                                                                              
            ,                                                                                                 
          = osc$sls_locked_by_current_task =                                                                  
            ,                                                                                                 
          = osc$sls_locked_by_another_task =                                                                  
            task_id: pmt$task_id,                                                                             
        CASEND,                                                                                               
      RECEND;                                                                                                 
                                                                                                              
  TYPE                                                                                                        
    nft$directory_ordinal = 1 .. pmc$max_queues_per_job,                                                      
                                                                                                              
    nft$segment_directory = ARRAY [nft$directory_ordinal] OF                                                  
      RECORD                                                                                                  
        lock: ALIGNED [ 0 MOD 8 ] INTEGER,                                                                    
        task_id: pmt$task_id,                                                                                 
        transfer_symbol: pmt$program_name,                                                                    
        queue_id: pmt$queue_connection,                                                                       
        message_count: pmt$messages_per_queue,                                                                
      RECEND;                                                                                                 
                                                                                                              
  VAR {shared communication segment definition}                                                               
    nfv$segment_initialized: BOOLEAN := FALSE,                                                                
    nfv$segment_name: amt$local_file_name := ' ',                                                             
    nfv$segment_id: amt$file_identifier,                                                                      
    nfv$segment_pointer: amt$segment_pointer,                                                                 
    nfv$segment_directory: ^nft$segment_directory,                                                            
    nfv$segment_lock: ^INTEGER,                                                                               
    nfv$segment_heap: ^HEAP ( * ),                                                                            
    nfv$segment_attributes: ARRAY [1 .. 2] OF amt$file_item :=                                                
      [[amc$access_mode,                                                                                      
        $pft$usage_selections [pfc$read, pfc$shorten, pfc$append, pfc$modify]],                               
       [amc$record_type, amc$undefined]];                                                                     
                                                                                                              
  VAR {intertask message definition}                                                                          
    nfv$intertask_message: pmt$message,                                                                       
    nfv$intertask_message_pointer: ^pmt$message_value := ^nfv$intertask_message.value,                        
    nfv$intertask_buffer_pointer: ^SEQ ( * ),                                                                 
    nfv$intertask_buffer_rpointer: ^REL (HEAP ( * )) ^SEQ ( * );                                              
                                                                                                              
  VAR                                                                                                         
    nfv$trap_handler_conditions: [STATIC, READ, oss$job_paged_literal] pmt$condition :=                       
      [pmc$condition_combination,                                                                             
        [pmc$system_conditions, mmc$segment_access_condition,                                                 
         pmc$user_defined_condition, ifc$interactive_condition]];                                             
                                                                                                              
  VAR {miscellaneous definitions}                                                                             
    nfv$dir_ord: nft$directory_ordinal,                                                                       
    nfv$ignore_status: ost$status,                                                                            
    nfv$ignore_task_status: pmt$task_status,                                                                  
    nfv$task_id: pmt$task_id;                                                                                 
                                                                                                              
*copyc nfe$common_task_communication                                                                          
?? NEWTITLE := 'external reference declarations', EJECT ??                                                    
*copyc amp$close                                                                                              
*copyc amp$get_segment_pointer                                                                                
*copyc amp$open                                                                                               
*copyc amp$return                                                                                             
*copyc clp$convert_integer_to_string                                                                          
*copyc clp$convert_string_to_integer                                                                          
*copyc cyd$run_time_error_condition                                                                           
*copyc osp$format_message                                                                                     
*copyc osp$i_await_activity_completion                                                                        
*copyc osp$set_status_abnormal                                                                                
*copyc osp$set_status_from_condition                                                                          
*copyc oss$job_paged_literal                                                                                  
*copyc ost$signature_lock                                                                                     
*copyc osv$lower_to_upper                                                                                     
*copyc pmp$abort                                                                                              
*copyc pmp$connect_queue                                                                                      
*copyc pmp$continue_to_cause                                                                                  
*copyc pmp$define_queue                                                                                       
*copyc pmp$disconnect_queue                                                                                   
*copyc pmp$establish_condition_handler                                                                        
*copyc pmp$execute                                                                                            
*copyc pmp$get_unique_name                                                                                    
*copyc pmp$get_program_description                                                                            
*copyc pmp$get_program_size                                                                                   
*copyc pmp$get_task_id                                                                                        
*copyc pmp$log                                                                                                
*copyc pmp$receive_from_queue                                                                                 
*copyc pmp$remove_queue                                                                                       
*copyc pmp$send_to_queue                                                                                      
*copyc pmp$status_queue                                                                                       
?? OLDTITLE ??                                                                                                
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'nfp$request_asynchronous_task', EJECT ??                                                      
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc nfh$request_asynchronous_task                                                                          
?? POP ??                                                                                                     
  PROCEDURE [XDCL] nfp$request_asynchronous_task (transfer_symbol: pmt$program_name;                          
        debug_mode: pmt$debug_mode;                                                                           
    VAR connected_task: pmt$task_id;                                                                          
    VAR queue_id: pmt$queue_connection;                                                                       
    VAR status: ost$status);                                                                                  
  ?? SKIP := 2 ??                                                                                             
  {******************************************************************************}                            
  {                                                                              }                            
  {  DESCRIPTION:                                                                }                            
  {    If the shared segment has not been opened and initialized, this is        }                            
  {    done by obtaining a unique name, opening the segment, and building        }                            
  {    a empty directory for the connected tasks at the begining of the          }                            
  {    sequence. The directory entry for the requesting task is then             }                            
  {    esatblished.                                                              }                            
  {                                                                              }                            
  {    When the shared segment has been initialized, an empty directory entry    }                            
  {    is found and locked for the requested task to use when it makes its       }                            
  {    NFP$BEGIN_ASYNCHRONOUS_TASK call to initialize itself. The lock for the   }                            
  {    new tasks directory entry is changed from a lock built from the           }                            
  {    requestors task id to a lock built from the requested tasks id. This      }                            
  {    procedure will then enter a wait loop for the lock to clear or time       }                            
  {    limit exceeded.                                                           }                            
  {                                                                              }                            
  {******************************************************************************}                            
  ?? SKIP := 2 ??                                                                                             
    VAR                                                                                                       
      number_of_object_files: pmt$number_of_object_files,                                                     
      number_of_modules: pmt$number_of_modules,                                                               
      number_of_libraries: pmt$number_of_libraries,                                                           
                                                                                                              
      program_description: ^pmt$program_description,                                                          
      program_attributes: ^pmt$program_attributes,                                                            
      program_parameters: ^pmt$program_parameters,                                                            
                                                                                                              
      dir_ordinal: nft$directory_ordinal,                                                                     
      queue_name: pmt$queue_name,                                                                             
      unique_name: ost$name,                                                                                  
      shared_segment_name: ^amt$local_file_name,                                                              
      async_task_id: ^pmt$task_id,                                                                            
      repeat_count: 1 .. 360,                                                                                 
      trap_handler_descriptor: pmt$established_handler,                                                       
      lock_status: nft$lock_status;                                                                           
  ?? EJECT ??                                                                                                 
                                                                                                              
 /request_asynchronous_task/                                                                                  
    BEGIN                                                                                                     
      status.normal := TRUE;                                                                                  
      pmp$establish_condition_handler (nfv$trap_handler_conditions,                                           
        ^unlock_and_clean_up, ^trap_handler_descriptor, nfv$ignore_status);                                   
      pmp$get_program_size (number_of_object_files,                                                           
        number_of_modules, number_of_libraries, nfv$ignore_status);                                           
                                                                                                              
      PUSH program_description: [[REP (#SIZE (pmt$program_attributes) +                                       
        (number_of_object_files * #SIZE (amt$local_file_name)) +                                              
        (number_of_modules * #SIZE (pmt$program_name)) +                                                      
        (number_of_libraries * #SIZE (amt$local_file_name))) OF CELL]];                                       
                                                                                                              
      pmp$get_program_description (program_description^, nfv$ignore_status);                                  
                                                                                                              
      RESET program_description;                                                                              
      NEXT program_attributes IN program_description;                                                         
      program_attributes^.contents := program_attributes^.contents +                                          
        $pmt$prog_description_contents [pmc$starting_proc_specified, pmc$term_error_level_specified,          
          pmc$debug_mode_specified, pmc$debug_input_specified, pmc$debug_output_specified];                   
                                                                                                              
      IF NOT nfv$segment_initialized THEN                                                                     
                                                                                                              
        pmp$get_unique_name (unique_name, nfv$ignore_status);                                                 
        nfv$segment_name := unique_name;                                                                      
        initialize_shared_segment (nfv$segment_name, status);                                                 
                                                                                                              
        IF NOT status.normal THEN                                                                             
          EXIT /request_asynchronous_task/;                                                                   
        IFEND;                                                                                                
                                                                                                              
        RESET nfv$segment_heap^;                                                                              
                                                                                                              
        nfv$segment_lock^ := 0;                                                                               
        FOR dir_ordinal := LOWERVALUE(dir_ordinal) TO UPPERVALUE(dir_ordinal) DO {clear all entries}          
          nfv$segment_directory^[dir_ordinal].lock := 0;                                                      
          clear_directory_entry (dir_ordinal);                                                                
        FOREND;                                                                                               
                                                                                                              
        get_directory_ordinal (pmc$max_task_id, nfv$dir_ord, status);                                         
                                                                                                              
        IF NOT status.normal THEN                                                                             
          EXIT /request_asynchronous_task/;                                                                   
        IFEND;                                                                                                
                                                                                                              
        process_lock (nfc$lock, 0, 0, nfv$segment_directory^[nfv$dir_ord].lock, lock_status);                 
        IF lock_status.condition = osc$sls_locked_by_current_task THEN                                        
                                                                                                              
          generate_queue_name (nfv$task_id, queue_name);                                                      
          pmp$define_queue (queue_name, osc$user_ring, osc$user_ring, status);                                
          IF status.normal THEN                                                                               
                                                                                                              
            nfv$segment_directory^[nfv$dir_ord].task_id := nfv$task_id;                                       
            nfv$segment_directory^[nfv$dir_ord].                                                              
              transfer_symbol := program_attributes^.starting_procedure;                                      
            pmp$connect_queue (queue_name, nfv$segment_directory^[nfv$dir_ord].queue_id, status);             
            queue_id := nfv$segment_directory^[nfv$dir_ord].queue_id;                                         
                                                                                                              
          IFEND;                                                                                              
                                                                                                              
          process_lock (nfc$unlock, 0, 0, nfv$segment_directory^[nfv$dir_ord].lock, lock_status);             
                                                                                                              
        IFEND;                                                                                                
                                                                                                              
        IF NOT status.normal THEN                                                                             
          EXIT /request_asynchronous_task/;                                                                   
        IFEND;                                                                                                
                                                                                                              
      IFEND;                                                                                                  
                                                                                                              
      REPEAT                                                                                                  
        get_directory_ordinal (pmc$max_task_id, dir_ordinal, status);                                         
        IF NOT status.normal THEN                                                                             
          EXIT /request_asynchronous_task/;                                                                   
        IFEND;                                                                                                
        process_lock (nfc$lock, 0, 0, nfv$segment_directory^[dir_ordinal].lock, lock_status);                 
      UNTIL lock_status.condition = osc$sls_locked_by_current_task;                                           
                                                                                                              
      #TRANSLATE (osv$lower_to_upper, transfer_symbol, program_attributes^.starting_procedure);               
      program_attributes^.termination_error_level := pmc$fatal_load_errors;                                   
      program_attributes^.debug_mode := debug_mode;                                                           
      program_attributes^.debug_input := 'COMMAND';                                                           
      program_attributes^.debug_output := '$OUTPUT';                                                          
                                                                                                              
      PUSH program_parameters: [[REP 1 OF amt$local_file_name, REP 1 OF pmt$task_id]];                        
      RESET program_parameters;                                                                               
      NEXT shared_segment_name IN program_parameters;                                                         
      shared_segment_name^ := nfv$segment_name;                                                               
      NEXT async_task_id IN program_parameters;                                                               
      async_task_id^ := nfv$task_id;                                                                          
                                                                                                              
      pmp$execute (program_description^,                                                                      
        program_parameters^, osc$nowait, connected_task, nfv$ignore_task_status, status);                     
                                                                                                              
      IF status.normal THEN {interlock directory for asynchronous task}                                       
                                                                                                              
        nfv$segment_directory^[dir_ordinal].lock := key_for_lock(connected_task);                             
        FOR repeat_count := LOWERVALUE(repeat_count) TO UPPERVALUE(repeat_count) DO                           
                                                                                                              
          process_lock (nfc$examine, 0, 1, nfv$segment_directory^[dir_ordinal].lock, lock_status);            
          IF lock_status.condition = osc$sls_not_locked THEN                                                  
            {asynchronous task running}                                                                       
            EXIT /request_asynchronous_task/;                                                                 
          IFEND;                                                                                              
                                                                                                              
        FOREND;                                                                                               
                                                                                                              
        clear_directory_entry (dir_ordinal);                                                                  
        nfv$segment_directory^[dir_ordinal].lock := key_for_lock(0);                                          
        osp$set_status_abnormal (nfc$status_id, nfe$task_not_responding , '', status);                        
                                                                                                              
      IFEND;                                                                                                  
                                                                                                              
      process_lock (nfc$unlock, 0, 0, nfv$segment_directory^[dir_ordinal].lock, lock_status);                 
                                                                                                              
    END /request_asynchronous_task/;                                                                          
                                                                                                              
  PROCEND nfp$request_asynchronous_task;                                                                      
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'nfp$begin_asynchronous_task', EJECT ??                                                        
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc nfh$begin_asynchronous_task                                                                            
?? POP ??                                                                                                     
  PROCEDURE [XDCL] nfp$begin_asynchronous_task (parameters: pmt$program_parameters;                           
    VAR connected_task: pmt$task_id;                                                                          
    VAR queue_id: pmt$queue_connection;                                                                       
    VAR status: ost$status);                                                                                  
  ?? SKIP := 2 ??                                                                                             
  {******************************************************************************}                            
  {                                                                              }                            
  {  DESCRIPTION:                                                                }                            
  {    This interface uses the shared segment name and requestors task id        }                            
  {    passed through the procedure call parameters to establish communication   }                            
  {    with the requesting task. The shared segment is opened and the directory  }                            
  {    is searched for an entry that has previously been locked for this task.   }                            
  {    When the entry has been found, it completes initialization and clears     }                            
  {    the lock. This is an indication to the requestor that communication       }                            
  {    has been established and subsequent NFP$GET_ASYNC_TASK_MESSAGE and        }                            
  {    NFP$PUT_ASYNC_TASK_MESSAGE calls can be accepted.                         }                            
  {                                                                              }                            
  {******************************************************************************}                            
  ?? SKIP := 2 ??                                                                                             
    CONST                                                                                                     
      retry_limit = 20;                                                                                       
                                                                                                              
    VAR                                                                                                       
      number_of_object_files: pmt$number_of_object_files,                                                     
      number_of_modules: pmt$number_of_modules,                                                               
      number_of_libraries: pmt$number_of_libraries,                                                           
                                                                                                              
      program_description: ^pmt$program_description,                                                          
      program_attributes: ^pmt$program_attributes,                                                            
      program_parameters: ^pmt$program_parameters,                                                            
                                                                                                              
      dir_ordinal: nft$directory_ordinal,                                                                     
      queue_name: pmt$queue_name,                                                                             
      shared_segment_name: ^amt$local_file_name,                                                              
      async_task_id: ^pmt$task_id,                                                                            
      retry_count: 0 .. 3600,                                                                                 
      trap_handler_descriptor: pmt$established_handler,                                                       
      lock_status: nft$lock_status;                                                                           
  ?? OLDTITLE, EJECT ??                                                                                       
                                                                                                              
 /begin_asynchronous_task/                                                                                    
    BEGIN                                                                                                     
      status.normal := TRUE;                                                                                  
      pmp$establish_condition_handler (nfv$trap_handler_conditions,                                           
        ^unlock_and_clean_up, ^trap_handler_descriptor, nfv$ignore_status);                                   
                                                                                                              
      IF NOT nfv$segment_initialized THEN                                                                     
                                                                                                              
        pmp$get_program_size (number_of_object_files,                                                         
          number_of_modules, number_of_libraries, nfv$ignore_status);                                         
                                                                                                              
        PUSH program_description: [[REP (#SIZE (pmt$program_attributes) +                                     
          (number_of_object_files * #SIZE (amt$local_file_name)) +                                            
          (number_of_modules * #SIZE (pmt$program_name)) +                                                    
          (number_of_libraries * #SIZE (amt$local_file_name))) OF CELL]];                                     
                                                                                                              
        pmp$get_program_description (program_description^, nfv$ignore_status);                                
                                                                                                              
        RESET program_description;                                                                            
        NEXT program_attributes IN program_description;                                                       
        program_attributes^.contents := program_attributes^.contents +                                        
          $pmt$prog_description_contents [pmc$starting_proc_specified];                                       
        program_parameters := ^parameters;                                                                    
                                                                                                              
        RESET program_parameters;                                                                             
        NEXT shared_segment_name IN program_parameters;                                                       
        nfv$segment_name := shared_segment_name^;                                                             
        NEXT async_task_id IN program_parameters;                                                             
        connected_task := async_task_id^;                                                                     
        RESET program_parameters;                                                                             
                                                                                                              
        initialize_shared_segment (nfv$segment_name, status);                                                 
        IF status.normal THEN                                                                                 
                                                                                                              
          FOR retry_count := LOWERVALUE(retry_count) TO retry_limit DO                                        
            FOR nfv$dir_ord := LOWERVALUE(nfv$dir_ord) TO UPPERVALUE(nfv$dir_ord) DO                          
                                                                                                              
              process_lock (nfc$examine, 0, 0, nfv$segment_directory^[nfv$dir_ord].lock, lock_status);        
              IF lock_status.condition = osc$sls_locked_by_current_task THEN                                  
                                                                                                              
                generate_queue_name (nfv$task_id, queue_name);                                                
                pmp$define_queue (queue_name, osc$user_ring, osc$user_ring, status);                          
                IF status.normal THEN                                                                         
                                                                                                              
                  nfv$segment_directory^[nfv$dir_ord].task_id := nfv$task_id;                                 
                  nfv$segment_directory^[nfv$dir_ord].                                                        
                    transfer_symbol := program_attributes^.starting_procedure;                                
                  pmp$connect_queue (queue_name, nfv$segment_directory^[nfv$dir_ord].queue_id, status);       
                  queue_id := nfv$segment_directory^[nfv$dir_ord].queue_id;                                   
                  process_lock (nfc$unlock, 0, 0, nfv$segment_directory^[nfv$dir_ord].lock, lock_status);     
                  EXIT /begin_asynchronous_task/;                                                             
                                                                                                              
                IFEND;                                                                                        
                process_lock (nfc$unlock, 0, 0, nfv$segment_directory^[nfv$dir_ord].lock, lock_status);       
                                                                                                              
              IFEND;                                                                                          
                                                                                                              
            FOREND;                                                                                           
          FOREND;                                                                                             
                                                                                                              
          osp$set_status_abnormal (nfc$status_id, nfe$async_task_timeout, '', status);                        
        IFEND;                                                                                                
        EXIT /begin_asynchronous_task/;                                                                       
                                                                                                              
      IFEND;                                                                                                  
      osp$set_status_abnormal (nfc$status_id, nfe$redundant_begin_task, '', status);                          
    END  /begin_asynchronous_task/;                                                                           
                                                                                                              
  PROCEND nfp$begin_asynchronous_task;                                                                        
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'nfp$get_async_task_message', EJECT ??                                                         
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc nfh$get_async_task_message                                                                             
?? POP ??                                                                                                     
  PROCEDURE [XDCL] nfp$get_async_task_message (connected_task: pmt$task_id;                                   
        working_storage_area: ^CELL;                                                                          
        working_storage_length: nft$intertask_transfer_size;                                                  
        wait_time: nft$intertask_wait_time;                                                                   
    VAR transfer_count: nft$intertask_transfer_size;                                                          
    VAR status: ost$status);                                                                                  
  ?? SKIP := 2 ??                                                                                             
  {******************************************************************************}                            
  {                                                                              }                            
  {  DESCRIPTION:                                                                }                            
  {    The indication that a message is available is made by statusing the       }                            
  {    tasks unique job local queue. If a message(s) is waiting it is            }                            
  {    retrieved and the senders task id is compared against the task id from    }                            
  {    from the call. If they are equal, the message is written to the callers   }                            
  {    working storage area. If they are not equal, the message is requeued      }                            
  {    and an attempt is made to obtain another message until all messages have  }                            
  {    been scanned.                                                             }                            
  {                                                                              }                            
  {  DESIGN NOTE:                                                                }                            
  {    Because of the possibility of messages being requeued, the user of these  }                            
  {    interfaces can not be assured that messages will be returned in any       }                            
  {    specific order.                                                           }                            
  {                                                                              }                            
  {******************************************************************************}                            
  ?? SKIP := 2 ??                                                                                             
    VAR                                                                                                       
      async_ordinal: nft$directory_ordinal,                                                                   
      async_queue_id: pmt$queue_connection,                                                                   
      dir_ordinal: nft$directory_ordinal,                                                                     
      lock_status: nft$lock_status,                                                                           
      queue_status: pmt$queue_status,                                                                         
      trap_handler_descriptor: pmt$established_handler,                                                       
      working_storage_pointer: ^STRING (nfc$max_transfer_size),                                               
      ignore_status: ost$status;                                                                              
                                                                                                              
    VAR                                                                                                       
      data_pointer: ^ARRAY [ * ] OF CELL,                                                                     
      data_size: ^INTEGER,                                                                                    
      sender_id: ^pmt$task_id;                                                                                
                                                                                                              
    VAR                                                                                                       
      ready_index: INTEGER,                                                                                   
      wait_list: ^ost$i_wait_list;                                                                            
  ?? EJECT ??                                                                                                 
                                                                                                              
 /get_async_task_message/                                                                                     
    BEGIN                                                                                                     
      status.normal := TRUE;                                                                                  
      transfer_count := 0;                                                                                    
                                                                                                              
      IF NOT nfv$segment_initialized THEN                                                                     
        osp$set_status_abnormal (nfc$status_id, nfe$module_not_initialized, '', status);                      
        EXIT /get_async_task_message/;                                                                        
      IFEND;                                                                                                  
                                                                                                              
      IF (working_storage_area = NIL) OR (working_storage_length = 0) THEN                                    
        EXIT /get_async_task_message/;                                                                        
      IFEND;                                                                                                  
                                                                                                              
      IF wait_time > 0 THEN {build delay interval}                                                            
        PUSH wait_list: [1 .. 2];                                                                             
        wait_list^[1].activity := osc$i_await_time;                                                           
        wait_list^[1].milliseconds := wait_time * nfc$millisecond;                                            
        wait_list^[2].activity := pmc$i_await_local_queue_message;                                            
        wait_list^[2].qid := nfv$segment_directory^[nfv$dir_ord].queue_id;                                    
      ELSE { no wait time specified }                                                                         
        wait_list := NIL;                                                                                     
      IFEND;                                                                                                  
                                                                                                              
      REPEAT {check job local queue}                                                                          
        pmp$status_queue (nfv$segment_directory^[nfv$dir_ord].queue_id, queue_status, status);                
        IF (NOT status.normal) OR ((wait_list = NIL) AND (queue_status.messages = 0)) THEN                    
          EXIT /get_async_task_message/;                                                                      
        ELSEIF {wait_list <> NIL AND} queue_status.messages = 0 THEN                                          
          osp$i_await_activity_completion (wait_list^, ready_index, nfv$ignore_status);                       
          wait_list := NIL;                                                                                   
        IFEND;                                                                                                
      UNTIL queue_status.messages > 0;                                                                        
                                                                                                              
      pmp$establish_condition_handler (nfv$trap_handler_conditions,                                           
        ^unlock_and_clean_up, ^trap_handler_descriptor, nfv$ignore_status);                                   
      working_storage_pointer := working_storage_area;                                                        
                                                                                                              
      /get_intertask_message/                                                                                 
      WHILE queue_status.messages > 0 DO                                                                      
        pmp$receive_from_queue (nfv$segment_directory^[nfv$dir_ord].queue_id,                                 
          osc$nowait, nfv$intertask_message, status);                                                         
                                                                                                              
        IF status.normal THEN {intertask message received}                                                    
          IF nfv$intertask_message.contents = pmc$message_value THEN                                          
                                                                                                              
            queue_status.messages := queue_status.messages - 1;                                               
            RESET nfv$intertask_message_pointer;                                                              
            NEXT nfv$intertask_buffer_rpointer IN nfv$intertask_message_pointer;                              
            nfv$intertask_buffer_pointer := #ptr (nfv$intertask_buffer_rpointer^, nfv$segment_heap^);         
                                                                                                              
            RESET nfv$intertask_buffer_pointer;                                                               
            NEXT sender_id IN nfv$intertask_buffer_pointer;                                                   
                                                                                                              
            IF (sender_id <> NIL) AND (sender_id^ <> connected_task) THEN                                     
              pmp$send_to_queue (nfv$segment_directory^[nfv$dir_ord].                                         
                queue_id, nfv$intertask_message, nfv$ignore_status);                                          
              CYCLE /get_intertask_message/;                                                                  
            IFEND;                                                                                            
                                                                                                              
            NEXT data_size IN nfv$intertask_buffer_pointer;                                                   
            NEXT data_pointer: [1 .. data_size^] IN nfv$intertask_buffer_pointer;                             
                                                                                                              
            IF (data_size <> NIL) AND (data_pointer <> NIL) THEN                                              
                                                                                                              
              connect_to_task (sender_id^, async_ordinal, async_queue_id, status);                            
              IF status.normal THEN {update senders message count and transfer message}                       
                                                                                                              
                IF nfv$segment_directory^[async_ordinal].message_count > 0 THEN                               
                  nfv$segment_directory^[async_ordinal].message_count :=                                      
                    nfv$segment_directory^[async_ordinal].message_count - 1;                                  
                ELSE {senders message count not valid}                                                        
                  nfv$segment_directory^[async_ordinal].message_count := 0;                                   
                IFEND;                                                                                        
                                                                                                              
                disconnect_from_task (sender_id^, async_ordinal, nfv$ignore_status);                          
                                                                                                              
              IFEND;                                                                                          
                                                                                                              
              #UNCHECKED_CONVERSION (data_pointer^, working_storage_pointer^ (1, data_size^));                
              transfer_count := data_size^;                                                                   
              process_lock (nfc$lock, 10, 1, nfv$segment_lock^, lock_status);                                 
              IF lock_status.condition <> osc$sls_locked_by_current_task THEN                                 
                osp$set_status_abnormal (nfc$status_id, nfe$locked_by_another_task,                           
                  '', status);                                                                                
                log_status_message (status, ignore_status);                                                   
                RETURN;                                                                                       
              IFEND;                                                                                          
              FREE nfv$intertask_buffer_pointer IN nfv$segment_heap^;                                         
              process_lock (nfc$unlock, 10, 1, nfv$segment_lock^, lock_status);                               
              IF lock_status.condition <> osc$sls_not_locked THEN                                             
                osp$set_status_abnormal (nfc$status_id, nfe$locked_by_another_task,                           
                  '', status);                                                                                
                log_status_message (status, ignore_status);                                                   
              IFEND;                                                                                          
              EXIT /get_async_task_message/;                                                                  
                                                                                                              
            IFEND;                                                                                            
          IFEND;                                                                                              
          osp$set_status_abnormal (nfc$status_id, nfe$bad_message_discarded, '', status);                     
                                                                                                              
        IFEND;                                                                                                
        EXIT /get_intertask_message/;                                                                         
      WHILEND /get_intertask_message/;                                                                        
    END /get_async_task_message/;                                                                             
                                                                                                              
  PROCEND nfp$get_async_task_message;                                                                         
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'nfp$put_async_task_message', EJECT ??                                                         
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc nfh$put_async_task_message                                                                             
?? POP ??                                                                                                     
  PROCEDURE [XDCL] nfp$put_async_task_message (connected_task: pmt$task_id;                                   
        working_storage_area: ^CELL;                                                                          
        working_storage_length: nft$intertask_transfer_size;                                                  
    VAR status: ost$status);                                                                                  
  ?? SKIP := 2 ??                                                                                             
  {******************************************************************************}                            
  {                                                                              }                            
  {  DESCRIPTION:                                                                }                            
  {    Messages are sent to the asynchronous task by copying the message from    }                            
  {    the callers working storage area to the shared segment, and placing       }                            
  {    a message containg a pointer to the data in the unique job local queue    }                            
  {    for the asynchronous task.                                                }                            
  {                                                                              }                            
  {******************************************************************************}                            
  ?? SKIP := 2 ??                                                                                             
    VAR                                                                                                       
      queue_id: pmt$queue_connection,                                                                         
      trap_handler_descriptor: pmt$established_handler,                                                       
      working_storage_pointer: ^ARRAY [1 .. nfc$max_transfer_size] OF CELL,                                   
      dir_ordinal: nft$directory_ordinal,                                                                     
      async_ordinal: nft$directory_ordinal,                                                                   
      lock_status: nft$lock_status,                                                                           
      ignore_status: ost$status;                                                                              
                                                                                                              
    VAR                                                                                                       
      sender_id: ^pmt$task_id,                                                                                
      data_size: ^INTEGER,                                                                                    
      data_pointer: ^ARRAY [ * ] OF CELL;                                                                     
  ?? EJECT ??                                                                                                 
                                                                                                              
 /put_async_task_message/                                                                                     
    BEGIN                                                                                                     
      status.normal := TRUE;                                                                                  
                                                                                                              
      IF NOT nfv$segment_initialized THEN                                                                     
        osp$set_status_abnormal (nfc$status_id, nfe$module_not_initialized, '', status);                      
        EXIT /put_async_task_message/;                                                                        
      IFEND;                                                                                                  
                                                                                                              
      IF (working_storage_area = NIL) OR (working_storage_length = 0) THEN                                    
        EXIT /put_async_task_message/;                                                                        
      IFEND;                                                                                                  
                                                                                                              
      working_storage_pointer := working_storage_area;                                                        
      process_lock (nfc$lock, 10, 1, nfv$segment_lock^, lock_status);                                         
      IF lock_status.condition <> osc$sls_locked_by_current_task THEN                                         
         osp$set_status_abnormal (nfc$status_id, nfe$locked_by_another_task,                                  
           '', status);                                                                                       
         log_status_message (status, ignore_status);                                                          
         RETURN;                                                                                              
      IFEND;                                                                                                  
      ALLOCATE nfv$intertask_buffer_pointer:                                                                  
        [[REP 1 OF pmt$task_id,                                                                               
          REP 1 OF INTEGER,                                                                                   
          REP working_storage_length OF CELL]] IN nfv$segment_heap^;                                          
      IF nfv$intertask_buffer_pointer = NIL THEN                                                              
        osp$set_status_abnormal (nfc$status_id, nfe$allocation_failure, '', status);                          
        log_status_message (status, ignore_status);                                                           
        RETURN;                                                                                               
      IFEND;                                                                                                  
      process_lock (nfc$unlock, 10, 1, nfv$segment_lock^, lock_status);                                       
      IF lock_status.condition <> osc$sls_not_locked THEN                                                     
         osp$set_status_abnormal (nfc$status_id, nfe$locked_by_another_task,                                  
           '', status);                                                                                       
         log_status_message (status, ignore_status);                                                          
         RETURN;                                                                                              
      IFEND;                                                                                                  
      RESET nfv$intertask_buffer_pointer;                                                                     
      NEXT sender_id IN nfv$intertask_buffer_pointer;                                                         
      sender_id^ := nfv$task_id;                                                                              
      NEXT data_size IN nfv$intertask_buffer_pointer;                                                         
      data_size^ := working_storage_length;                                                                   
      NEXT data_pointer: [1 .. data_size^] IN nfv$intertask_buffer_pointer;                                   
      data_pointer^ := working_storage_pointer^;                                                              
      nfv$intertask_message.contents := pmc$message_value;                                                    
                                                                                                              
      RESET nfv$intertask_message_pointer;                                                                    
      NEXT nfv$intertask_buffer_rpointer IN nfv$intertask_message_pointer;                                    
      nfv$intertask_buffer_rpointer^ := #REL (nfv$intertask_buffer_pointer, nfv$segment_heap^);               
                                                                                                              
      pmp$establish_condition_handler (nfv$trap_handler_conditions,                                           
        ^unlock_and_clean_up, ^trap_handler_descriptor, nfv$ignore_status);                                   
      process_lock (nfc$lock, 60, 1, nfv$segment_directory^[nfv$dir_ord].lock, lock_status);                  
      IF lock_status.condition = osc$sls_locked_by_current_task THEN                                          
                                                                                                              
        connect_to_task (connected_task, async_ordinal, queue_id, status);                                    
                                                                                                              
        IF status.normal THEN                                                                                 
                                                                                                              
          pmp$send_to_queue (queue_id, nfv$intertask_message, status);                                        
          IF status.normal THEN                                                                               
                                                                                                              
            IF nfv$segment_directory^[nfv$dir_ord].message_count >= 0 THEN                                    
              nfv$segment_directory^[nfv$dir_ord].message_count :=                                            
               nfv$segment_directory^[nfv$dir_ord].message_count + 1;                                         
            ELSE                                                                                              
              nfv$segment_directory^[nfv$dir_ord].message_count := 1;                                         
            IFEND;                                                                                            
                                                                                                              
          IFEND;                                                                                              
          disconnect_from_task (connected_task, async_ordinal, nfv$ignore_status);                            
                                                                                                              
        IFEND;                                                                                                
                                                                                                              
        process_lock (nfc$unlock, 0, 0, nfv$segment_directory^[nfv$dir_ord].lock, lock_status);               
                                                                                                              
      ELSE                                                                                                    
        osp$set_status_abnormal (nfc$status_id, nfe$locked_by_another_task, '', status);                      
      IFEND;                                                                                                  
                                                                                                              
      IF NOT status.normal THEN {message not transfered}                                                      
        process_lock (nfc$lock, 10, 1, nfv$segment_lock^, lock_status);                                       
        IF lock_status.condition <> osc$sls_locked_by_current_task THEN                                       
          osp$set_status_abnormal (nfc$status_id, nfe$locked_by_another_task,                                 
            '', status);                                                                                      
          log_status_message (status, ignore_status);                                                         
          RETURN;                                                                                             
        IFEND;                                                                                                
        FREE nfv$intertask_buffer_pointer IN nfv$segment_heap^;                                               
        process_lock (nfc$unlock, 10, 1, nfv$segment_lock^, lock_status);                                     
        IF lock_status.condition <> osc$sls_not_locked THEN                                                   
          osp$set_status_abnormal (nfc$status_id, nfe$locked_by_another_task,                                 
            '', status);                                                                                      
          log_status_message (status, ignore_status);                                                         
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
    END /put_async_task_message/;                                                                             
                                                                                                              
  PROCEND nfp$put_async_task_message;                                                                         
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'nfp$end_async_communication', EJECT ??                                                        
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc nfh$end_async_communication                                                                            
?? POP ??                                                                                                     
  PROCEDURE [XDCL] nfp$end_async_communication (check_activity: BOOLEAN;                                      
    VAR status: ost$status);                                                                                  
  ?? SKIP := 2 ??                                                                                             
  {******************************************************************************}                            
  {                                                                              }                            
  {  DESCRIPTION:                                                                }                            
  {    If the caller requests that termination should not be completed with      }                            
  {    activity pending (CHECK_ACTIVITY := TRUE), the activity pending           }                            
  {    status condition will be returned if the tasks unique job local queue     }                            
  {    contains messages or if there are messages that this task has sent        }                            
  {    that have not been picked up. If CHECK_ACTIVITY := FALSE, intertask       }                            
  {    communication through nfm$common_task_communication is unconditionally    }                            
  {    terminated.                                                               }                            
  {                                                                              }                            
  {******************************************************************************}                            
  ?? SKIP := 2 ??                                                                                             
    VAR                                                                                                       
      queue_name: pmt$queue_name,                                                                             
      queue_status: pmt$queue_status,                                                                         
      trap_handler_descriptor: pmt$established_handler,                                                       
      lock_status: nft$lock_status;                                                                           
  ?? EJECT ??                                                                                                 
                                                                                                              
 /end_async_communication/                                                                                    
    BEGIN                                                                                                     
      status.normal := TRUE;                                                                                  
      pmp$establish_condition_handler (nfv$trap_handler_conditions,                                           
        ^unlock_and_clean_up, ^trap_handler_descriptor, nfv$ignore_status);                                   
                                                                                                              
      IF nfv$segment_initialized THEN                                                                         
                                                                                                              
        process_lock (nfc$lock, 60, 1, nfv$segment_directory^[nfv$dir_ord].lock, lock_status);                
        IF lock_status.condition = osc$sls_locked_by_current_task THEN                                        
                                                                                                              
          pmp$status_queue (nfv$segment_directory^[nfv$dir_ord].queue_id, queue_status, status);              
          IF status.normal THEN                                                                               
            IF (NOT check_activity) OR (nfv$segment_directory^[nfv$dir_ord].message_count +                   
                queue_status.messages + queue_status.waiting_tasks = 0) THEN                                  
                                                                                                              
              empty_queue (nfv$ignore_status);                                                                
              pmp$disconnect_queue (nfv$segment_directory^[nfv$dir_ord].queue_id, nfv$ignore_status);         
              generate_queue_name (nfv$task_id, queue_name);                                                  
              pmp$remove_queue (queue_name, nfv$ignore_status);                                               
              clear_directory_entry (nfv$dir_ord);                                                            
              process_lock (nfc$unlock, 0, 0, nfv$segment_directory^[nfv$dir_ord].lock, lock_status);         
              amp$close (nfv$segment_id, nfv$ignore_status);                                                  
              nfv$segment_initialized := FALSE;                                                               
              amp$return (nfv$segment_name, nfv$ignore_status);                                               
              RETURN;                                                                                         
                                                                                                              
            ELSE                                                                                              
              osp$set_status_abnormal (nfc$status_id, nfe$activity_pending, '', status);                      
            IFEND;                                                                                            
                                                                                                              
          IFEND;                                                                                              
          process_lock (nfc$unlock, 0, 0, nfv$segment_directory^[nfv$dir_ord].lock, lock_status);             
                                                                                                              
        ELSE                                                                                                  
          osp$set_status_abnormal (nfc$status_id, nfe$locked_by_another_task, '', status);                    
                                                                                                              
        IFEND;                                                                                                
        EXIT /end_async_communication/;                                                                       
                                                                                                              
      IFEND;                                                                                                  
      osp$set_status_abnormal (nfc$status_id, nfe$module_not_initialized, '', status);                        
    END /end_async_communication/;                                                                            
                                                                                                              
  PROCEND nfp$end_async_communication;                                                                        
  ?? OLDTITLE ??                                                                                              
  ?? NEWTITLE := '  utility procedures', EJECT ??                                                             
  ?? NEWTITLE := '  clear_directory_entry', EJECT ??                                                          
  PROCEDURE [INLINE] clear_directory_entry (dir_ordinal: nft$directory_ordinal);                              
  ?? SKIP := 4 ??                                                                                             
    BEGIN {clear_directory_entry}                                                                             
      nfv$segment_directory^[dir_ordinal].task_id := pmc$max_task_id;                                         
      nfv$segment_directory^[dir_ordinal].transfer_symbol := ' ';                                             
      nfv$segment_directory^[dir_ordinal].queue_id := 1;                                                      
      nfv$segment_directory^[dir_ordinal].message_count := 0;                                                 
    END;                                                                                                      
  PROCEND clear_directory_entry;                                                                              
                                                                                                              
  ?? OLDTITLE ??                                                                                              
  ?? NEWTITLE := '  connect_to_task', EJECT ??                                                                
  PROCEDURE [INLINE] connect_to_task (task_identifier: pmt$task_id;                                           
    VAR dir_ordinal: nft$directory_ordinal;                                                                   
    VAR queue_id: pmt$queue_connection;                                                                       
    VAR status: ost$status);                                                                                  
  ?? SKIP := 2 ??                                                                                             
    VAR                                                                                                       
      queue_name: pmt$queue_name,                                                                             
      wait_list: ^ost$i_wait_list,                                                                            
      ready_index: INTEGER,                                                                                   
      retry_count: 0 .. 59,                                                                                   
      lock_status: nft$lock_status;                                                                           
  ?? SKIP := 4 ??                                                                                             
    BEGIN {connect_to_task}                                                                                   
      get_directory_ordinal (task_identifier, dir_ordinal, status);                                           
      IF status.normal THEN                                                                                   
        process_lock (nfc$lock, 60, 1, nfv$segment_directory^[dir_ordinal].lock, lock_status);                
        IF lock_status.condition = osc$sls_locked_by_current_task THEN                                        
                                                                                                              
          IF nfv$segment_directory^[dir_ordinal].task_id = task_identifier THEN                               
            PUSH wait_list: [1 .. 1];                                                                         
            wait_list^[1].activity := osc$i_await_time;                                                       
            wait_list^[1].milliseconds := 1 * nfc$millisecond;                                                
            generate_queue_name (task_identifier, queue_name);                                                
            queue_id := nfv$segment_directory^[dir_ordinal].queue_id;                                         
                                                                                                              
            FOR retry_count := LOWERVALUE(retry_count) TO UPPERVALUE(retry_count) DO                          
              pmp$connect_queue (queue_name, queue_id, status);                                               
              IF (status.normal) OR (status.condition <> pme$unknown_queue_name) THEN                         
                RETURN;                                                                                       
              IFEND;                                                                                          
              osp$i_await_activity_completion (wait_list^, ready_index, nfv$ignore_status);                   
            FOREND;                                                                                           
                                                                                                              
          IFEND;                                                                                              
          process_lock (nfc$unlock, 0, 0, nfv$segment_directory^[dir_ordinal].lock, lock_status);             
          osp$set_status_abnormal (nfc$status_id, nfe$task_not_active, '', status);                           
          EXIT connect_to_task;                                                                               
        IFEND;                                                                                                
        osp$set_status_abnormal (nfc$status_id, nfe$locked_by_another_task, '', status);                      
      IFEND;                                                                                                  
    END;                                                                                                      
  PROCEND connect_to_task;                                                                                    
                                                                                                              
  ?? OLDTITLE ??                                                                                              
  ?? NEWTITLE := '  disconnect_from_task', EJECT ??                                                           
  PROCEDURE [INLINE] disconnect_from_task (task_identifier: pmt$task_id;                                      
        dir_ordinal: nft$directory_ordinal;                                                                   
    VAR status: ost$status);                                                                                  
  ?? SKIP := 2 ??                                                                                             
    VAR                                                                                                       
      lock_status: nft$lock_status,                                                                           
      local_status: ost$status;                                                                               
  ?? SKIP := 4 ??                                                                                             
    BEGIN {disconnect_from_task}                                                                              
                                                                                                              
      process_lock (nfc$examine, 0, 0, nfv$segment_directory^[dir_ordinal].lock, lock_status);                
      IF (lock_status.condition = osc$sls_locked_by_current_task) AND                                         
         (nfv$segment_directory^[dir_ordinal].task_id = task_identifier) THEN                                 
                                                                                                              
        pmp$disconnect_queue (nfv$segment_directory^[dir_ordinal].queue_id, local_status);                    
        IF local_status.normal THEN                                                                           
                                                                                                              
          process_lock (nfc$unlock, 0, 0, nfv$segment_directory^[dir_ordinal].lock, lock_status);             
          status.normal := TRUE;                                                                              
          RETURN;                                                                                             
                                                                                                              
        IFEND;                                                                                                
                                                                                                              
      ELSE {not locked by current job}                                                                        
                                                                                                              
        osp$set_status_abnormal (nfc$status_id, nfe$locked_by_another_task, '', local_status);                
                                                                                                              
      IFEND;                                                                                                  
                                                                                                              
      pmp$abort (local_status);                                                                               
    END;                                                                                                      
  PROCEND disconnect_from_task;                                                                               
                                                                                                              
  ?? OLDTITLE ??                                                                                              
  ?? NEWTITLE := '  empty_queue', EJECT ??                                                                    
  PROCEDURE empty_queue (VAR status: ost$status);                                                             
  ?? SKIP := 2 ??                                                                                             
    VAR                                                                                                       
      async_ordinal: nft$directory_ordinal,                                                                   
      async_queue_id: pmt$queue_connection,                                                                   
      data_pointer: ^ARRAY [ * ] OF CELL,                                                                     
      data_size: ^INTEGER,                                                                                    
      lock_status: nft$lock_status,                                                                           
      sender_id: ^pmt$task_id,                                                                                
      ignore_status: ost$status;                                                                              
  ?? SKIP := 4 ??                                                                                             
    BEGIN {empty_queue}                                                                                       
                                                                                                              
      WHILE TRUE DO {get message from queue}                                                                  
        pmp$receive_from_queue (nfv$segment_directory^[nfv$dir_ord].queue_id,                                 
          osc$nowait, nfv$intertask_message, status);                                                         
                                                                                                              
        IF (NOT status.normal) OR (nfv$intertask_message.contents <> pmc$message_value) THEN                  
          EXIT empty_queue;                                                                                   
        IFEND;                                                                                                
                                                                                                              
        RESET nfv$intertask_message_pointer;                                                                  
        NEXT nfv$intertask_buffer_rpointer IN nfv$intertask_message_pointer;                                  
        nfv$intertask_buffer_pointer := #ptr (nfv$intertask_buffer_rpointer^, nfv$segment_heap^);             
                                                                                                              
        RESET nfv$intertask_buffer_pointer;                                                                   
        NEXT sender_id IN nfv$intertask_buffer_pointer;                                                       
        NEXT data_size IN nfv$intertask_buffer_pointer;                                                       
        NEXT data_pointer: [1 .. data_size^] IN nfv$intertask_buffer_pointer;                                 
                                                                                                              
        connect_to_task (sender_id^, async_ordinal, async_queue_id, status);                                  
        IF status.normal THEN {update senders message count and transfer message}                             
                                                                                                              
          IF nfv$segment_directory^[async_ordinal].message_count > 0 THEN                                     
            nfv$segment_directory^[async_ordinal].message_count :=                                            
              nfv$segment_directory^[async_ordinal].message_count - 1;                                        
          ELSE {senders message count not valid}                                                              
            nfv$segment_directory^[async_ordinal].message_count := 0;                                         
          IFEND;                                                                                              
                                                                                                              
          disconnect_from_task (sender_id^, async_ordinal, nfv$ignore_status);                                
                                                                                                              
        IFEND;                                                                                                
        process_lock (nfc$lock, 10, 1, nfv$segment_lock^, lock_status);                                       
        IF lock_status.condition <> osc$sls_locked_by_current_task THEN                                       
          osp$set_status_abnormal (nfc$status_id, nfe$locked_by_another_task,                                 
            '', status);                                                                                      
          log_status_message (status, ignore_status);                                                         
          RETURN;                                                                                             
        IFEND;                                                                                                
        FREE nfv$intertask_buffer_pointer IN nfv$segment_heap^;                                               
        process_lock (nfc$unlock, 10, 1, nfv$segment_lock^, lock_status);                                     
        IF lock_status.condition <> osc$sls_not_locked THEN                                                   
          osp$set_status_abnormal (nfc$status_id, nfe$locked_by_another_task,                                 
            '', status);                                                                                      
          log_status_message (status, ignore_status);                                                         
        IFEND;                                                                                                
                                                                                                              
      WHILEND;                                                                                                
    END                                                                                                       
  PROCEND empty_queue;                                                                                        
                                                                                                              
  ?? OLDTITLE ??                                                                                              
  ?? NEWTITLE := '  generate_queue_name', EJECT ??                                                            
  PROCEDURE [INLINE] generate_queue_name (task_identifier: pmt$task_id;                                       
    VAR queue_name: pmt$queue_name);                                                                          
  ?? SKIP := 2 ??                                                                                             
    VAR                                                                                                       
      task_id_string: ost$string;                                                                             
  ?? SKIP := 4 ??                                                                                             
    BEGIN {generate_queue_name}                                                                               
      clp$convert_integer_to_string (task_identifier, 10, FALSE, task_id_string, nfv$ignore_status);          
      queue_name := 'nfd$queue_for_task_';                                                                    
      queue_name(20, *) := task_id_string.value;                                                              
    END;                                                                                                      
  PROCEND generate_queue_name;                                                                                
                                                                                                              
  ?? OLDTITLE ??                                                                                              
  ?? NEWTITLE := '  get_directory_ordinal', EJECT ??                                                          
  PROCEDURE [INLINE] get_directory_ordinal (task_identifier: pmt$task_id;                                     
    VAR dir_ordinal: nft$directory_ordinal;                                                                   
    VAR status: ost$status);                                                                                  
  ?? SKIP := 4 ??                                                                                             
    BEGIN {get_directory_ordinal}                                                                             
      FOR dir_ordinal := LOWERVALUE(dir_ordinal) TO UPPERVALUE(dir_ordinal) DO                                
        IF nfv$segment_directory^[dir_ordinal].task_id = task_identifier THEN                                 
          status.normal := TRUE;                                                                              
          {task found in directory} RETURN;                                                                   
        IFEND;                                                                                                
      FOREND;                                                                                                 
      osp$set_status_abnormal (nfc$status_id, nfe$task_not_found, '', status);                                
    END;                                                                                                      
  PROCEND get_directory_ordinal;                                                                              
                                                                                                              
  ?? OLDTITLE ??                                                                                              
  ?? NEWTITLE := '  initialize_shared_segment', EJECT ??                                                      
  PROCEDURE [INLINE] initialize_shared_segment (shared_segment: amt$local_file_name;                          
    VAR status: ost$status);                                                                                  
  ?? SKIP := 2 ??                                                                                             
    BEGIN {initialize_shared_segment}                                                                         
      IF NOT nfv$segment_initialized THEN                                                                     
        pmp$get_task_id (nfv$task_id, nfv$ignore_status);                                                     
        nfv$segment_name := shared_segment;                                                                   
        amp$open (nfv$segment_name, amc$segment, ^nfv$segment_attributes, nfv$segment_id, status);            
        IF status.normal THEN                                                                                 
          amp$get_segment_pointer (nfv$segment_id, amc$sequence_pointer, nfv$segment_pointer, status);        
          IF status.normal THEN                                                                               
            RESET nfv$segment_pointer.sequence_pointer;                                                       
            NEXT nfv$segment_lock IN nfv$segment_pointer.sequence_pointer;                                    
            NEXT nfv$segment_directory IN nfv$segment_pointer.sequence_pointer;                               
            NEXT nfv$segment_heap: [[REP pmc$max_queues_per_job * nfc$max_transfer_size OF CELL]]             
              IN nfv$segment_pointer.sequence_pointer;                                                        
            nfv$segment_initialized := TRUE;                                                                  
            RETURN;                                                                                           
          IFEND;                                                                                              
          amp$close (nfv$segment_id, nfv$ignore_status);                                                      
          amp$return (nfv$segment_name, nfv$ignore_status);                                                   
        IFEND;                                                                                                
      ELSE                                                                                                    
        osp$set_status_abnormal (nfc$status_id, nfe$redundant_initialize_seg, '', status);                    
      IFEND;                                                                                                  
    END;                                                                                                      
  PROCEND initialize_shared_segment;                                                                          
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '  key_for_lock', EJECT ??                                                                     
  FUNCTION [INLINE] key_for_lock (task_identifier: pmt$task_id): INTEGER;                                     
  ?? SKIP := 2 ??                                                                                             
    VAR                                                                                                       
      key_to_lock: INTEGER,                                                                                   
      key_definition: nft$key_definition;                                                                     
  ?? SKIP := 4 ??                                                                                             
    BEGIN {key_for_lock}                                                                                      
      key_definition.lock_bits := 0;                                                                          
      key_definition.lock_id := task_identifier;                                                              
      #UNCHECKED_CONVERSION (key_definition, key_to_lock);                                                    
      key_for_lock := key_to_lock;                                                                            
    END;                                                                                                      
  FUNCEND key_for_lock;                                                                                       
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '  process_lock', EJECT ??                                                                     
  PROCEDURE process_lock (lock_function: nft$lock_functions;                                                  
        retry_limit: 0 .. 3600 {iterations};                                                                  
        retry_delay: 0 .. 60 {seconds};                                                                       
    VAR lock: INTEGER;                                                                                        
    VAR lock_status: nft$lock_status);                                                                        
  ?? SKIP := 2 ??                                                                                             
  {******************************************************************************}                            
  {                                                                              }                            
  {  PROCEDURE:                                                                  }                            
  {    PROCESS_LOCK (LOCK_FUNCTION, RETRY_LIMIT, RETRY_DELAY, LOCK, LOCK_STATUS) }                            
  {                                                                              }                            
  {  PURPOSE:                                                                    }                            
  {    The process_lock procedure performs interlock related functions. These    }                            
  {    functions are used to lock, unlock, and examine the interlocks for        }                            
  {    the shared segment directory and insures that only one task can have      }                            
  {    write access to a directory entry.                                        }                            
  {                                                                              }                            
  {  DESCRIPTION:                                                                }                            
  {    The NFC$LOCK function is used to interlock a directory entry for this     }                            
  {    task. If the directory entry is locked by another task, the task will     }                            
  {    wait for the specified delay time and attempt the lock function again     }                            
  {    until it has retied the specified number of times.                        }                            
  {                                                                              }                            
  {    The NFC$UNLOCK function is used to unlock a directory entry that has      }                            
  {    been previously locked by this task.                                      }                            
  {                                                                              }                            
  {    The NFC$EXAMINE function is used to test the lock status. It does         }                            
  {    not perform any locking or unlocking function. The retry delay can be     }                            
  {    used to cause a time delay between repeated nfc$examine calls. The        }                            
  {    retry limit has no meaning when examining locks.                          }                            
  {                                                                              }                            
  {******************************************************************************}                            
  ?? SKIP := 2 ??                                                                                             
    VAR                                                                                                       
      old_lock_key: INTEGER,                                                                                  
      key_definition: nft$key_definition,                                                                     
      retry_count: INTEGER,                                                                                   
      wait_list: ^ost$i_wait_list,                                                                            
      ready_index: INTEGER,                                                                                   
      cs_status: 0 .. 2;                                                                                      
  ?? EJECT ??                                                                                                 
    BEGIN {process_lock}                                                                                      
                                                                                                              
      IF retry_delay > 0 THEN {build delay interval}                                                          
        PUSH wait_list: [1 .. 1];                                                                             
        wait_list^[1].activity := osc$i_await_time;                                                           
        wait_list^[1].milliseconds := retry_delay * nfc$millisecond;                                          
      ELSE {no wait required}                                                                                 
        wait_list := NIL;                                                                                     
      IFEND;                                                                                                  
                                                                                                              
      FOR retry_count := 0 TO retry_limit DO                                                                  
        CASE lock_function OF                                                                                 
          = nfc$lock =                                                                                        
            REPEAT                                                                                            
              #COMPARE_SWAP (lock, 0, key_for_lock(nfv$task_id), old_lock_key, cs_status);                    
            UNTIL cs_status <> osc$cs_variable_locked;                                                        
            IF (cs_status = osc$cs_successful) OR (key_for_lock(nfv$task_id) = old_lock_key) THEN             
              lock_status.condition := osc$sls_locked_by_current_task;                                        
              RETURN;                                                                                         
            IFEND;                                                                                            
            lock_status.condition := osc$sls_locked_by_another_task;                                          
            #UNCHECKED_CONVERSION (old_lock_key, key_definition);                                             
            lock_status.task_id := key_definition.lock_id;                                                    
                                                                                                              
          = nfc$unlock =                                                                                      
            REPEAT                                                                                            
              #COMPARE_SWAP (lock, key_for_lock(nfv$task_id), 0, old_lock_key, cs_status);                    
            UNTIL cs_status <> osc$cs_variable_locked;                                                        
            IF (cs_status = osc$cs_successful) OR (old_lock_key = 0) THEN                                     
              lock_status.condition := osc$sls_not_locked;                                                    
              RETURN;                                                                                         
            IFEND;                                                                                            
            lock_status.condition := osc$sls_locked_by_another_task;                                          
            #UNCHECKED_CONVERSION (old_lock_key, key_definition);                                             
            lock_status.task_id := key_definition.lock_id;                                                    
                                                                                                              
          = nfc$examine =                                                                                     
            REPEAT                                                                                            
              #COMPARE_SWAP (lock, 0, 0, old_lock_key, cs_status);                                            
            UNTIL cs_status <> osc$cs_variable_locked;                                                        
            IF cs_status = osc$cs_successful THEN                                                             
              lock_status.condition := osc$sls_not_locked;                                                    
            ELSEIF {NOT osc$cs_successful AND} old_lock_key = key_for_lock(nfv$task_id) THEN                  
              lock_status.condition := osc$sls_locked_by_current_task;                                        
            ELSE {NOT osc$cs_successful AND old_lock_key <> key_for_lock(nfv$task_id) THEN}                   
              lock_status.condition := osc$sls_locked_by_another_task;                                        
              #UNCHECKED_CONVERSION (old_lock_key, key_definition);                                           
              lock_status.task_id := key_definition.lock_id;                                                  
            IFEND;                                                                                            
                                                                                                              
        CASEND;                                                                                               
        IF (wait_list <> NIL) AND (retry_count <= retry_limit) THEN                                           
          osp$i_await_activity_completion (wait_list^, ready_index, nfv$ignore_status);                       
        IFEND;                                                                                                
      FOREND;                                                                                                 
    END;                                                                                                      
  PROCEND process_lock;                                                                                       
                                                                                                              
  ?? OLDTITLE ??                                                                                              
  ?? NEWTITLE := '  log_status_message', EJECT ??                                                             
  PROCEDURE log_status_message (status_for_log: ost$status;                                                   
    VAR status: ost$status);                                                                                  
    VAR                                                                                                       
      message: ost$status_message,                                                                            
      message_pointer: ^ost$status_message,                                                                   
      msg_line_count: ^ost$status_message_line_count,                                                         
      msg_line_size: ^ ost$status_message_line_size,                                                          
      msg_line_text: ^string (*),                                                                             
      i: 1 .. osc$max_status_message_lines,                                                                   
      ignore_status: ost$status;                                                                              
                                                                                                              
      osp$format_message (status_for_log, osc$full_message_level, 80,                                         
        message, ignore_status);                                                                              
      message_pointer := ^message;                                                                            
      RESET message_pointer;                                                                                  
      NEXT msg_line_count IN message_pointer;                                                                 
      FOR i := 1 to msg_line_count^ DO                                                                        
        NEXT msg_line_size IN message_pointer;                                                                
        NEXT msg_line_text: [msg_line_size^] IN message_pointer;                                              
        pmp$log (msg_line_text^, status);                                                                     
      FOREND;                                                                                                 
    PROCEND log_status_message;                                                                               
                                                                                                              
  ?? OLDTITLE ??                                                                                              
  ?? NEWTITLE := '  unlock_and_clean_up', EJECT ??                                                            
  PROCEDURE unlock_and_clean_up (condition: pmt$condition;                                                    
        condition_information: ^pmt$condition_information;                                                    
        save_area: ^ost$stack_frame_save_area;                                                                
    VAR status: ost$status);                                                                                  
  ?? SKIP := 2 ??                                                                                             
  {******************************************************************************}                            
  {                                                                              }                            
  {  PROCEDURE:                                                                  }                            
  {    UNLOCK_AND_CLEAN_UP (CONDITION, CONDITION_INFORMATION, SAVE_AREA, STATUS) }                            
  {                                                                              }                            
  {  PURPOSE:                                                                    }                            
  {    The unlock_and_clean_up procedure is the condition handler for            }                            
  {    nfm$common_task_communication.                                            }                            
  {                                                                              }                            
  {  DESCRIPTION:                                                                }                            
  {    For segment access, CYBIL run time, or interactive terminate break,       }                            
  {    all directory entries interlocked by this task will be unconditionally    }                            
  {    cleared and NFP$END_ASYNC_COMMUNICATION will be called. On all other      }                            
  {    conditions the interrupted procedure is allowed to complete.              }                            
  {                                                                              }                            
  {******************************************************************************}                            
  ?? SKIP := 2 ??                                                                                             
    VAR                                                                                                       
      dir_ordinal: nft$directory_ordinal,                                                                     
      end_async_communication: BOOLEAN,                                                                       
      ignore_status: ost$status,                                                                              
      local_status: ost$status,                                                                               
      lock_status: nft$lock_status,                                                                           
      queue_name: pmt$queue_name;                                                                             
  ?? SKIP := 4 ??                                                                                             
    BEGIN {unlock_and_clean_up}                                                                               
      pmp$log ('*** NFM$COMMON_TASK_COMMUNICATION Handler:', ignore_status);                                  
      osp$set_status_from_condition ('NF', condition, save_area, local_status, ignore_status);                
      log_status_message (local_status, ignore_status);                                                       
                                                                                                              
      status.normal := TRUE;                                                                                  
                                                                                                              
      CASE condition.selector OF                                                                              
                                                                                                              
        = pmc$user_defined_condition =                                                                        
          end_async_communication := condition.user_condition_name = cye$run_time_condition;                  
                                                                                                              
        = ifc$interactive_condition =                                                                         
          end_async_communication := condition.interactive_condition = ifc$terminate_break;                   
                                                                                                              
      ELSE {on all other conditions}                                                                          
        end_async_communication := TRUE;                                                                      
      CASEND;                                                                                                 
                                                                                                              
      IF NOT end_async_communication THEN                                                                     
        {resume processing} RETURN;                                                                           
      IFEND;                                                                                                  
                                                                                                              
      IF nfv$segment_initialized THEN {clear any locks associated with this task}                             
                                                                                                              
        empty_queue (nfv$ignore_status);                                                                      
        pmp$disconnect_queue (nfv$segment_directory^[nfv$dir_ord].queue_id, nfv$ignore_status);               
        generate_queue_name (nfv$task_id, queue_name);                                                        
        pmp$remove_queue (queue_name, nfv$ignore_status);                                                     
        clear_directory_entry (nfv$dir_ord);                                                                  
                                                                                                              
        FOR dir_ordinal := LOWERVALUE(dir_ordinal) TO UPPERVALUE(dir_ordinal) DO                              
          process_lock (nfc$unlock, 0, 0, nfv$segment_directory^[dir_ordinal].lock, lock_status);             
        FOREND;                                                                                               
                                                                                                              
        amp$close (nfv$segment_id, nfv$ignore_status);                                                        
        amp$return (nfv$segment_name, nfv$ignore_status);                                                     
        nfv$segment_initialized := FALSE;                                                                     
                                                                                                              
      IFEND;                                                                                                  
      pmp$continue_to_cause (pmc$execute_standard_procedure, status);                                         
    END;                                                                                                      
                                                                                                              
  PROCEND unlock_and_clean_up;                                                                                
?? OLDTITLE ??                                                                                                
?? OLDTITLE ??                                                                                                
MODEND nfm$common_task_communication;                                                                         
*DECK DECK=NFM$CONTROL_ACCESS EXPAND=TRUE
PROCEDURE control_access, cona (
  system_file_name, sfn: name = $required
  device_environment_variable, dev: name = $required
  authorization_file, af: file = $required
  statistics_file, sf: file = $required
  file_disposition, fd: (VAR) key
      (hold, h)
      (print_and_hold, pah)
      (print_and_terminate, pat)
      (terminate, t)
    keyend = $required
  status)

" CONTROL_ACCESS Batch Output Filter.
"
"   This filter validates the LOGIN_FAMILY/LOGIN_USER that created the queue
"   file for access to the STATION or STATION,DEVICE.
"
"   Access is granted to users who appear in the AUTHORIZATION_FILE under a
"   specific STATION or STATION,DEVICE entry, or if the specific STATION or
"   STATION,DEVICE does not appear in the AUTHORIZATION_FILE.
"   Access is also granted automatically if the AUTHORIZATION_FILE is empty
"   or does not exist.
"
"   Access is denied (the file is put on HOLD) when the STATION or
"   STATION,DEVICE entry appears in the authorization file and the user
"   does not appear below this entry.
"
"   AUTHORIZATION_FILE Format:
"
"     station_name{,device_name}
"     :family_name.user_name_1
"     :family_name.user_name_n
"                                    <--- Blank line terminates user list
"     station_name{,device_name}
"     :family_name.user_name_1
"     :family_name.user_name_n

  VAR
    device: string
    ignore: status
    local_status: status
    station: string
    station_line: integer
    user: string
  VAREND

  IF ($file(authorization_file, size) > 0) AND (file_disposition <> hold) AND ..
        (file_disposition <> terminate) THEN

    device = $string($device_attributes(dev, device_name))
    station = $string($device_attributes(dev, station))
    user = ':'//$job_output(sfn, login_family)//'.'//$job_output(sfn, login_user)

    EDIT_FILE authorization_file p=$null o=$null

" Delete Comment Lines (double quote in column 1) and remove embedded blanks.

      set_search_margins 1..1
      delete_text '"' l=a n=a status=ignore
      set_search_margins
      replace_text ' ' '' l=a n=a status=ignore

" Insert blank line (terminator) after last entry.

      position_cursor l=last
      insert_empty_line

" Search for STATION,DEVICE entry.  If not found, try STATION.

      locate_text station//','//device l=a n=1 uc=true w=true ..
            status=local_status
      IF NOT local_status.normal THEN
        locate_text station l=a n=1 uc=true w=true status=local_status
      IFEND

" If entry found, look for user before the next blank line.

      IF local_status.normal THEN
        station_line = $current_line
        locate_empty_line
        locate_text user l=station_line+1..current n=1 uc=true w=true ..
              status=local_status

" If user not found, HOLD file and issue statistic.

        IF NOT local_status.normal THEN
          file_disposition = hold
          put_line 'BF10000 ''ACCESS TO PRINTER DENIED: SFN='//sfn//' U='//..
user//' S='//station//' D='//device//'''' o=statistics_file.$eoi
        IFEND
      IFEND

    QUIT false " Changes are temporary - do not modify file.

  IFEND

PROCEND control_access
*DECK DECK=NFM$CREATE_T_RECORD_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'MODULE nfm$create_t_record_file' ??
MODULE nfm$create_t_record_file;

{ PURPOSE:    To create a file with a "T" record type and a record delimiting
{              character of US.
{
{ DESCRIPTION: This routine uses accepts the values for the file name, page
{              length and page width of the file to be created. At then attempts
{              to create the file using the values.
{
{ INPUT PARAMETERS: PARAMETER_LIST, created and initialized by the SCL procedure call.
{
{ OUTPUT PARAMETERS: STATUS.
{
{ NOTES: Unlike the standard NOS/VE command CREATE_FILE, this procedure will not
{        attempt to create the next higher cycle of the file name passed to it.
{        If a file cycle already exists, this procedure will return an error.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$work_area
?? POP ??
*copyc amp$get_file_attributes
*copyc clp$evaluate_parameters
*copyc fsp$open_file
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal

?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE nfp$create_t_record_file', EJECT ??

  PROCEDURE [XDCL] nfp$create_t_record_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE create_t_record_file (
{   file, f: file = $required
{   page_length, pl: integer 1..4398046511103 = $required
{   page_width, pw: integer 1..65535 = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          recend,
          type3: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
            recend,
            type4: record
              header: clt$type_specification_header,
              recend,
    recend := [
    [1,
    [90, 8, 9, 16, 19, 54, 33],
    clc$command, 7, 4, 3, 0, 0, 0, 4, ''], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['PAGE_LENGTH                    ',clc$nominal_entry, 2],
    ['PAGE_WIDTH                     ',clc$nominal_entry, 3],
    ['PL                             ',clc$abbreviation_entry, 2],
    ['PW                             ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, 4398046511103, 10]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, 65535, 10]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$page_length = 2,
      p$page_width = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      attachment_options: ^fst$attachment_options,
      cycle_attributes: ^fst$file_cycle_attributes,
      file_previously_opened: boolean,
      ignored_attributes: array [1..1] of amt$get_item,
      ignored_file_contains_data: boolean,
      ignored_file_exists: boolean,
      ignored_file_id: amt$file_identifier;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ignored_attributes[1].key := amc$null_attribute;
    amp$get_file_attributes (pvt [p$file].value^.file_value^, ignored_attributes, ignored_file_exists,
      file_previously_opened, ignored_file_contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    ELSEIF file_previously_opened THEN
      osp$set_status_abnormal('PF', pfe$duplicate_cycle, pvt[p$file].value^.file_value^, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'specified', status);
      RETURN;
    IFEND;

    PUSH attachment_options: [1..1];
    attachment_options^ [1].selector := fsc$create_file;
    attachment_options^ [1].create_file := TRUE;

    PUSH cycle_attributes: [1..6];
    cycle_attributes^ [1].selector := fsc$file_contents_and_processor;
    cycle_attributes^ [1].file_contents := 'LIST';
    cycle_attributes^ [1].file_processor := osc$null_name;

    cycle_attributes^ [2].selector := fsc$page_format;
    cycle_attributes^ [2].page_format := amc$continuous_form;

    cycle_attributes^ [3].selector := fsc$page_length;
    cycle_attributes^ [3].page_length := pvt [p$page_length].value^.integer_value.value;

    cycle_attributes^ [4].selector := fsc$page_width;
    cycle_attributes^ [4].page_width := pvt [p$page_width].value^.integer_value.value;

    cycle_attributes^ [5].selector := fsc$record_delimiting_character;
    cycle_attributes^ [5].record_delimiting_character :=  $char(31);

    cycle_attributes^ [6].selector := fsc$record_type;
    cycle_attributes^ [6].record_type := amc$trailing_char_delimited;

    fsp$open_file (pvt[p$file].value^.file_value^, amc$record, attachment_options, cycle_attributes,
        cycle_attributes, NIL, NIL, ignored_file_id, status);

  PROCEND nfp$create_t_record_file;
MODEND nfm$create_t_record_file;
*DECK DECK=NFM$DEACTIVATE_DRJE EXPAND=TRUE
*DECK DECK=NFM$DEACTIVATE_FTAM_RESPONDER EXPAND=TRUE
*DECK DECK=NFM$DEFINE_FTAM_INITIATOR_ADD EXPAND=TRUE
*DECK DECK=NFM$DISPLAY_SCFS_LOG EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'DISPLAY SCFS LOG' ??
MODULE nfm$display_scfs_log;

?? NEWTITLE := 'Global References', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nat$protocol_stack_integer
*copyc nft$accept_messages
*copyc nft$all_or_top_10_q_entries
*copyc nft$banner_highlight_field
*copyc nft$banner_page_count
*copyc nft$btfs_di_advanced_features
*copyc nft$carriage_control_action
*copyc nft$change_bd_attr_resp_msg
*copyc nft$code_set
*copyc nft$connection_address
*copyc nft$copies
*copyc nft$destination_unavail_actions
*copyc nft$device_control_resp_codes
*copyc nft$device_file_size
*copyc nft$device_max_page_length
*copyc nft$device_status
*copyc nft$device_status_data
*copyc nft$device_type
*copyc nft$display_status_resp_codes
*copyc nft$external_characteristics
*copyc nft$file_and_priority
*copyc nft$file_assignment_response
*copyc nft$file_count
*copyc nft$file_disposition
*copyc nft$file_position
*copyc nft$file_size
*copyc nft$file_transfer_state
*copyc nft$file_transfer_status
*copyc nft$file_vertical_print_density
*copyc nft$format_effector_actions
*copyc nft$forms_code
*copyc nft$forms_size
*copyc nft$input_job_size
*copyc nft$io_station_usage
*copyc nft$message_kind
*copyc nft$network_address
*copyc nft$ntf_authority_level
*copyc nft$ntf_command_kind
*copyc nft$ntf_command_text
*copyc nft$ntf_inactivity_timer
*copyc nft$ntf_line_speed
*copyc nft$ntf_logical_line_number
*copyc nft$ntf_positive_acknowledge
*copyc nft$ntf_remote_system_data
*copyc nft$ntf_remote_system_kind
*copyc nft$ntf_remote_system_protocol
*copyc nft$ntf_remote_system_type
*copyc nft$ntf_route_back_position
*copyc nft$ntf_skip_punch_count
*copyc nft$ntf_wait_a_bit
*copyc nft$optimize_list
*copyc nft$output_data_mode
*copyc nft$page_format
*copyc nft$page_length
*copyc nft$page_width
*copyc nft$parameter_value_length
*copyc nft$pm_message_actions
*copyc nft$position_file_param_types
*copyc nft$priority
*copyc nft$priority_multiplier
*copyc nft$q_status_data
*copyc nft$select_file_response
*copyc nft$suppress_carriage_control
*copyc nft$terminal_model
*copyc nft$terqo_file_status_codes
*copyc nft$tip_type
*copyc nft$transmit_block_size
*copyc nft$unsolicited_device_msg
*copyc nft$vertical_print_density
*copyc nft$vfu_load_option
*copyc ost$date_time
*copyc osv$ebcdic_to_ascii
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$return
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$convert_str_to_path_handle
*copyc clp$evaluate_parameters
*copyc clp$new_display_line
*copyc clp$open_display
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$translate_bytes
*copyc pmp$establish_condition_handler
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
?? TITLE := 'Global Definitions', EJECT ??

  CONST
    accept_msg_size = 3,
    all_or_top_10_size = 16,
    banner_highlight_size = 14,
    btfs_di_status_size = 14,
    cc_action_size = 19,
    chabda_param_size = 25,
    code_set_size = 12,
    data_mode_size = 11,
    dest_unavail_size = 17,
    device_status_size = 24,
    device_type_size = 23,
    display_value_size = 55,
    fe_action_size = 20,
    file_disposition_size = 8,
    file_transfer_state_size = 12,
    file_vpd_action_size = 6,
    label_size = 31,
    page_format_size = 13,
    pm_action_size = 7,
    posf_direction_size = 9,
    posf_start_pos_size = 17,
    posf_units_size = 4,
    station_usage_size = 7,
    terqo_file_status_size = 22,
    tip_types_size = 24,
    transfer_status_size = 33,
    vfu_size = 26,
    vpd_action_size = 28;

  TYPE
    nft$btfs_di_status_codes = (nfc$btfs_di_down, nfc$btfs_di_active),
    nft$connection_kind = (nfc$unknown_connection, nfc$scfdi_connection,
          nfc$scfve_connection, nfc$operator_connection,
          nfc$scfsve_connection, nfc$ntfve_connection, nfc$ntf_operator_connection);

  VAR
    all_or_top_10: [READ] array [nft$all_or_top_10_q_entries] of
          string (all_or_top_10_size) := [{nfc$all_q_entries} 'All Q Entries',
          {nfc$top_10_q_entries} 'Top 10 Q Entries'],

    authority_levels: [READ, STATIC] array [nft$ntf_authority_level] of string (display_value_size) :=
          [
          {nfc$ntf_none} 'NONE',
          {nfc$ntf_network} 'NET',
          {nfc$ntf_job} 'JOB'],

    btf_ve_protocol_stacks: [READ] array [nac$xns_protocol_stack .. nac$all_protocol_stacks] of
          string (7) := ['XNS', 'OSI', 'XNS+OSI'],

    btfs_di_advanced_features: [READ] array [nft$btfs_di_advanced_features] of
          string (23) := ['NONE', 'URI_TRANSPARENT_SUPPORT'],

    btfs_di_statuses: [READ] array [nft$btfs_di_status_codes] of
          string (btfs_di_status_size) := [{nfc$btfs_di_down} 'BTFS/DI Down',
          {nfc$btfs_di_active} 'BTFS/DI Active'],

    chabda_parameters: [READ] array [nft$change_bda_resp_parameters] of
          string (chabda_param_size) := [{nfc$null_parameter} 'ERROR',
          {nfc$io_station_name} 'ERROR',
          {nfc$device_name} 'DEVICE_NAME',
          {nfc$device_alias_1} 'DEVICE_ALIAS_1',
          {nfc$device_alias_2} 'DEVICE_ALIAS_2',
          {nfc$device_alias_3} 'DEVICE_ALIAS_3',
          {nfc$file_acknowledgement} 'FILE_ACKNOWLEDGEMENT',
          {nfc$terminal_model} 'TERMINAL_MODEL',
          {nfc$transmission_block_size} 'TRANSMISSION_BLOCK_SIZE',
          {nfc$maximum_file_size} 'MAXIMUM_FILE_SIZE',
          {nfc$page_width} 'PAGE_WIDTH',
          {nfc$page_length} 'PAGE_LENGTH',
          {nfc$banner_page_count} 'BANNER_PAGE_COUNT',
          {nfc$banner_highlight_field} 'BANNER_HIGHLIGHT_FIELD',
          {nfc$carriage_control_action} 'CARRIAGE_CONTROL_SUPPORT',
          {nfc$forms_code_1} 'FORMS_CODE_1',
          {nfc$forms_code_2} 'FORMS_CODE_2',
          {nfc$forms_code_3} 'FORMS_CODE_3',
          {nfc$forms_code_4} 'FORMS_CODE_4',
          {nfc$external_characteristics_1} 'EXTERNAL_CHARACTERISTICS_1',
          {nfc$external_characteristics_2} 'EXTERNAL_CHARACTERISTICS_2',
          {nfc$external_characteristics_3} 'EXTERNAL_CHARACTERISTICS_3',
          {nfc$external_characteristics_4} 'EXTERNAL_CHARACTERISTICS_4',
          {nfc$code_set} 'CODE_SET',
          {nfc$vertical_print_density} 'VERTICAL_PRINT_DENSITY',
          {nfc$vfu_load_procedure} 'VFU_LOAD_PROCEDURE',
          {nfc$forms_size} 'FORMS_SIZE',
          {nfc$undefined_fe_action} 'UNDEFINED_FE_ACTION',
          {nfc$unsupported_fe_action} 'UNSUPPORTED_FE_ACTION',
          {29 - 65} REP 37 of 'ERROR'],

    code_sets: [READ] array [nft$code_set] of string (code_set_size) :=
          [{nfc$ascii} 'ascii', {nfc$ascii_48}
          'ascii_48',
          {nfc$ascii_64} 'ascii_64', {nfc$ascii_95} 'ascii_95',
          {nfc$ascii_128} 'ascii_128', {nfc$ebcdic} 'ebcdic',
          {nfc$ascii_256} 'ascii_256', {nfc$bcd} 'bcd',
          {nfc$site_defined} 'site_defined'],

    command_kinds: [READ, STATIC] array [nft$ntf_command_kind] of ost$name := [
          {nfc$ntf_command} 'COMMAND',
          {nfc$ntf_message} 'MESSAGE',
          {nfc$ntf_signon} 'SIGNON',
          {nfc$ntf_signoff} 'SIGNOFF',
          {nfc$ntf_change_tdp} 'CHANGE_TDP',
          {nfc$ntf_operator_message} 'NTF_OPERATOR_MESSAGE',
          {nfc$ntf_user_message} 'NTF_USER_MESSAGE',
          {nfc$ntf_client_command} 'NTF_CLIENT_COMMAND'],

    destination_unavail_actions: [READ] array
          [nft$destination_unavail_actions] of string (dest_unavail_size) :=
          [{nfc$drop_input_job} 'drop input job',     {nfc$stop_input_device}
          'stop input device'],

    device_statuses: [READ] array [nft$device_status] of
          string (device_status_size) := [{nfc$device_active}
          'active', {nfc$device_stopped} 'stopped',
          {nfc$device_not_ready} 'not ready', {nfc$device_down} 'down',
          {nfc$device_loading_vfu} 'loading VFU',
          {nfc$default_vfu_not_loadable} 'default VFU not loadable',
          {nfc$default_stopped_by_system} 'stopped by system',
          {nfc$device_status_reserved_7} 'reserved_7',
          {nfc$device_status_reserved_8} 'reserved_8',
          {nfc$device_status_reserved_9} 'reserved_9',
          {nfc$device_status_reserved_10} 'reserved_10',
          {nfc$ntf_waiting_signon} 'NTF wait signon',
          {nfc$ntf_signon_initiated} 'NTF signon initiated',
          {nfc$ntf_signed_on} 'NTF signed on',
          {nfc$ntf_signon_failed} 'NTF signon failed',
          {nfc$ntf_signed_off} 'NTF signed off'],

    device_types: [READ] array [nft$device_type] of string
          (device_type_size) := [{nfc$null_device} ' ',
          {nfc$console} 'console',
          {nfc$reader} 'reader', {nfc$printer} 'printer',
          {nfc$punch} 'punch', {nfc$plotter} 'plotter',
          {nfc$ntf_remote_system_input} 'NTF remote system input',
          {nfc$ntf_job_receiver} 'NTF job receiver',
          {nfc$ntf_sysout_receiver} 'NTF sysout receiver',
          {nfc$ntf_job_transmitter} 'NTF job transmitter',
          {nfc$ntf_sysout_transmitter} 'NTF sysout transmitter'],

    file_dispositions: [READ] array [nft$file_disposition] of
          string (file_disposition_size) := [
          {nfc$requeue_file} 'requeue',
          {nfc$drop_file_from_q} 'drop',
          {nfc$hold_file_in_queue} 'hold',
          {nfc$complete_file} 'complete',
          {nfc$maintain_file_position} 'maintain'],

    file_transfer_statuses: [READ] array [nft$file_transfer_status] of
          string (transfer_status_size) := [{nfc$idle} 'idle',
          {nfc$idle_device_disconnect} 'idle, device disconnect',
          {nfc$idle_vfu_not_loadable} 'idle, vfu not loadable',
          {nfc$idle_transfer_error} 'idle, transfer error',
          {nfc$idle_accounting_limit} 'idle, accounting limit',
          {nfc$idle_operator_drop_file} 'idle, operator dropped file',
          {nfc$idle_operator_requeued_file} 'idle, operator requeued file',
          {nfc$idle_operator_hold_file} 'idle, operator hold file',
          {nfc$busy} 'busy',
          {nfc$suspended_device_not_ready} 'suspended, device not ready',
          {nfc$suspended_pm_message} 'suspended, PM message',
          {nfc$suspended_operator_command} 'suspended, operator command',
          {nfc$suspended_operator_posf_comd} 'suspended, operator position file',
          {nfc$suspended_vfu_being_loaded} 'suspended, VFU procedure being loaded',
          {nfc$busy_reserved_14} ' ',
          {nfc$busy_reserved_15} ' '],

    file_vpd_actions: [READ] array [nft$file_vertical_print_density] of
          string (file_vpd_action_size) := [{nfc$vertical_print_density_none}
          'none',
          {nfc$vertical_print_density_6} 'six',
          {nfc$vertical_print_density_7} 'seven',
          {nfc$vertical_print_density_8} 'eight',
          {nfc$vertical_print_density_9} 'nine',
          {nfc$vertical_print_density_10} 'ten',
          {nfc$vertical_print_density_11} 'eleven',
          {nfc$vertical_print_density_12} 'twelve'],

    format_effector_actions: [READ] array [nft$format_effector_actions] of
          string (fe_action_size) := [{nfc$print_after_spacing}
          'print_after_spacing', {nfc$print_before_spacing}
          'print_before_spacing',
          {nfc$discard_print_line} 'discard_print_line'],

    display_message: boolean,

    pm_message_actions: [READ] array [nft$pm_message_actions] of
          string (pm_action_size) := ['print', 'display', 'discard'],

    remote_system_kinds: [READ, STATIC] array [nft$ntf_remote_system_kind] of string
          (display_value_size) := ['NOT_CONFIGURED', 'DIRECTLY_CONNECTED', 'ACCESSIBLE'],

    remote_system_protocols: [READ, STATIC] array [nft$ntf_remote_system_protocol] of
            string (display_value_size) := ['NJE', 'HASP'],

    terqo_file_status_codes: [READ] array [nft$terqo_file_status_codes] of string (terqo_file_status_size) :=
          [{nfc$terqo_successful} 'terminate successful',
          {nfc$terqo_unknown_ios} 'unknown io station',
          {nfc$terqo_unknown_file_name} 'unknown file name',
          {nfc$terqo_duplicate_file_names} 'duplicate file name',
          {nfc$terqo_file_in_transfer} 'file being transferred',
          {nfc$terqo_message_rejected} 'message rejected'],

    remote_system_types: [READ, STATIC] array [nft$ntf_remote_system_type] of
          string (display_value_size) := [
          {nfc$ntf_nos_ve} 'NOS_VE',
          {nfc$ntf_nos} 'NOS',
          {nfc$ntf_nos_be} 'NOS_BE',
          {nfc$ntf_ibm} 'IBM',
          {nfc$ntf_dec} 'DEC',
          {nfc$ntf_user} 'USER',
          {nfc$ntf_cyber_205} 'CYBER_205',
          {nfc$ntf_eta} 'ETA',
          {nfc$ntf_cray} 'CRAY'],

    tip_types: [READ] array [nft$tip_type] of string (tip_types_size) :=
          [{nfc$internal_tip} 'internal_tip',
          {nfc$auto_tip} 'auto_tip',
          {nfc$async_tip} 'async_tip',
          {nfc$user1_tip} 'user1_tip',
          {nfc$user2_tip} 'user2_tip',
          {nfc$user3_tip} 'user3_tip',
          {nfc$user4_tip} 'user4_tip',
          {nfc$hasp_tip} 'hasp_tip',
          {nfc$x25_async_tip} 'x25_async_tip',
          {nfc$bisync_3270_tip} 'bisync_3270_tip',
          {nfc$bisync_njef_tip} 'bisync_njef_tip',
          {nfc$remote_term_emulator_tip} 'remote_term_emulator_tip',
          {nfc$uri_tip} 'uri_tip',
          {nfc$xpc_tip} 'xpc_tip',
          {nfc$mode4_tip} 'mode4_tip',
          {nfc$ntf_tip} 'ntf_tip',
          {nfc$sna_3270_tip} 'sna_3270_tip',
          {nfc$telnet_tip} 'telnet_tip'],

    vfu_load_option_actions: [READ] array [nft$vfu_load_option] of
          string (vfu_size) := [{nfc$vfu_not_present_or_load}
          'vfu not present or load',
          {nfc$vfu_loaded_at_init} 'vfu loaded at init',
          {nfc$vfu_changeable_by_operator} 'vfu changeable by operator',
          {nfc$vfu_changeable_by_user} 'vfu changeable by user'],

    vpd_actions: [READ] array [nft$vertical_print_density] of
          string (vpd_action_size) := [{nfc$six_only} 'six_only',
          {nfc$eight_only} 'eight_only',
          {nfc$six_any} 'six_any',                     {nfc$eight_any}
          'eight_any'],

    carriage_control_actions: [READ] array [nft$carriage_control_action] of
          string (cc_action_size) := [{nfc$pre_print} 'pre-print',
          {nfc$post_print} 'post-print',
          {nfc$pre_and_post_print} 'pre- and post-print'],

    banner_highlight_fields: [READ] array [nft$banner_highlight_field] of
          string (banner_highlight_size) := [{nfc$comment_banner}
          'comment_banner', {nfc$routing_banner} 'routing_banner',
          {nfc$site_banner} 'site_banner', {nfc$user_file_name}
          'user_file_name',
          {nfc$user_name} 'user_name'],

    station_usages: [READ] array [nft$io_station_usage] of
          string (station_usage_size) := [{nfc$public_io_station} 'public',
          {nfc$private_io_station} 'private', 'NTF'],

    accept_msg: [READ] array [nft$accept_messages] of
          string (accept_msg_size) := ['yes', 'no'],

    output_data_modes: [READ] array [nft$output_data_mode] of
          string (data_mode_size) := [{nfc$coded_mode}
          'coded', {nfc$transparent_mode} 'transparent'],

    file_transfer_states: [READ] array [nft$file_transfer_state] of
          string (file_transfer_state_size) := [{nfc$eligible_for_output}
          'eligible', {nfc$hold_output} 'hold',
          {nfc$not_eligible_for_output} 'not eligible',
          {nfc$selected_for_output} 'selected'],

    page_formats: [READ] array [nft$page_format] of string
          (page_format_size) := [{amc$continuous_form}
          'continuous', {amc$burstable_form} 'burstable',
          {amc$non_burstable_form} 'non-burstable', {amc$untitled_form}
          'untitled'],

    posf_directions: [READ] array [nft$position_file_direction] of
          string (posf_direction_size) := [{nfc$position_file_backwards}
          'backwards', {nfc$position_file_forwards} 'forwards'],

    posf_start_positions: [READ] array [nft$position_file_from_position] of
          string (posf_start_pos_size) := [{nfc$end_of_file} 'end of file',
          {nfc$beginning_of_file} 'beginning of file',
          {nfc$last_line_printed} 'last line printed'],

    posf_units: [READ] array [nft$position_file_units] of
          string (posf_units_size) := [{nfc$position_file_page} 'page',
          {nfc$position_file_line} 'line'],

    boolean_values: [READ] array [boolean] of string (3) := [{false} 'no',
          {true} 'yes'];

{ PROCEDURE display_scfs_log (
{   log_file, lf: file = $required
{   output, o: file = $output
{   display_option, do: key
{       (brief, b)
{       (full, f)
{     keyend = full
{   format, f: (BY_NAME, ADVANCED) key
{       r131, r141, r152
{     keyend = r152
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 5, 1, 11, 16, 56, 319],
    clc$command, 9, 5, 1, 1, 0, 0, 5, ''], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 3],
    ['DO                             ',clc$abbreviation_entry, 3],
    ['F                              ',clc$abbreviation_entry, 4],
    ['FORMAT                         ',clc$nominal_entry, 4],
    ['LF                             ',clc$abbreviation_entry, 1],
    ['LOG_FILE                       ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [4, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 118, clc$optional_default_parameter, 0, 4],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['BRIEF                          ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['F                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['FULL                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'full'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [3], [
    ['R131                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['R141                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['R152                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
    ,
    'r152'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$log_file = 1,
      p$output = 2,
      p$display_option = 3,
      p$format = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;
?? TITLE := '  display BTFS/DI address', EJECT ??

  PROCEDURE display_btfs_di_address
    (    address: ^nft$network_address;
     VAR display_control: clt$display_control;
     VAR log_file_seq: amt$segment_pointer;
     VAR status: ost$status);

    CONST
      label = '    BTFS DI Network Address';

    VAR
      addr_index: integer,
      address_str: ost$string,
      str: ost$string;


    clp$convert_integer_to_string (address^.network, 16, FALSE, str, status);
    address_str.value := str.value (1, str.size);
    addr_index := 1 + str.size;

    clp$convert_integer_to_string (address^.system, 16, FALSE, str, status);
    address_str.value (addr_index, str.size) := str.value (1, str.size);
    addr_index := addr_index + str.size;

    put_display_line (address_str.value (1, addr_index - 1), label,
          display_control, status);

  PROCEND display_btfs_di_address;
?? TITLE := 'display connection address', EJECT ??

  PROCEDURE display_connection_address
    (    label: string (*);
         address: ^nft$connection_address;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      addr_index: integer,
      address_str: ost$string,
      byte_index: integer,
      byte_ptr: ^0 .. 0ff(16),
      length: integer,
      osi_network_address: ^SEQ ( * ),
      str: ost$string;

    IF address^.kind = nac$internet_address THEN
      address_str.value := 'Addr (XNS): ';
      addr_index := 1 + 12;

      clp$convert_integer_to_string (address^.internet_address.network, 16,
            FALSE, str, status);
      address_str.value (addr_index, str.size) := str.value (1, str.size);
      addr_index := addr_index + str.size;

      clp$convert_integer_to_string (address^.internet_address.system, 16,
            FALSE, str, status);
      address_str.value (addr_index, str.size) := str.value (1, str.size);
      addr_index := addr_index + str.size;
    ELSE
      address_str.value := 'Addr: ';
      addr_index := 1 + 6;

      osi_network_address := ^address^.network_address;
      RESET osi_network_address;
      FOR byte_index := 1 TO address^.network_address_length DO
        NEXT byte_ptr IN osi_network_address;
        STRINGREP (str.value, length, (byte_ptr^+100(16)):4:#(16));
        address_str.value (addr_index, 2) := str.value (3, 2);
        addr_index := addr_index + 2;
      FOREND;
    IFEND;

    put_display_line (address_str.value (1, addr_index - 1), label,
          display_control, status);

  PROCEND display_connection_address;
?? TITLE := '  display connection message', EJECT ??

  PROCEDURE display_connection_message
    (VAR display_control: clt$display_control;
     VAR log_file_seq: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      message_kind_str: [STATIC] array [nft$message_kind] of string (42) :=
            [' ',
            { 1} '  Add File Availablity', { 2} '  Modify File Availablity',
            { 3} '  Delete File Availablity', { 4} '  File Assignment',
            { 5} '  File Assignment Response', { 6} '  Delete Destination',
            { 7} '  BTF/VE Status', { 8} ' ',
            { 9} '  Add Accessible Remote System Response', {10} '  Get Remote System Names',
            {11} '  Remote System Names Data', {12} '  Get Remote System Options',
            {13} '  Remote System Options Data', {14} '  Delete NTF User',
            {15} '  Delete NTF User Response',
            {16} '  Send Remote Command', {17} '  Send Remote Command Response',
            {18} '  Get Remote System Status', {19} '  Get Remote System Status Data',
            {20} '  Add I/O Station', {21} '  Delete I/O Station',
            {22} '  Add Batch Device', {23} '  Batch Device Status',
            {24} '  File Transfer Status', {25} '  Delete Batch Device',
            {26} '  BTFS/DI Status', {27} '  Add I/O Station Response',
            {28} '  Delete I/O Station Response', {29} '  Start I/O Station',
            {30} '  Stop I/O Station', {31} '  Switch Control Facility',
            {32} '  Position File', {33} '  Add Batch Device Response',
            {34} '  Delete Batch Device Response', {35} '  Add Remote System',
            {36} '  Add Accessible Remote System', {37} '  Delete Remote System',
            {38} '  Add Remote System Response', {39} '  Delete Remote System Response',
            {40} '  Suppress Carriage Control Response', {41} '  Start Batch Device',
            {42} '  Stop Batch Device', {43} '  Suppress Carriage Control',
            {44} '  Terminate Transfer', {45} '  Change Batch Device Attributes',
            {46} '  Change Batch Device Attributes Response', {47} '  Start Batch Device Response',
            {48} '  Stop Batch Device Response', {49} '  Terminate Transfer Response',
            {50} '  Position File Response', {51} '  Operator Msg',
            {52 - 59} REP 8 of ' ',
            {60} '  Add User', {61} '  Add User Response',
            {62} '  Select File', {63} '  Select File Response',
            {64} '  Position File', {65} '  Get Station Status',
            {66} '  Station Status Data', {67} '  Get Device Status',
            {68} '  Device Status Data', {69} '  Get Queue Status',
            {70} '  Queue Status Data', {71} '  Get Queue Entry List',
            {72} '  Queue Entry List Data', {73} '  Get Queue Entry',
            {74} '  Queue Entry Data', {75} '  Terminate Queued Output',
            {76} '  Terminate Queued Output Resp', {77 - 95} REP 19 of * ];

?? NEWTITLE := '    add batch device msg', EJECT ??

    PROCEDURE add_batch_device_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$add_batch_device_message

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        banner_page_count: ^nft$banner_page_count,
        banner_highlight_field: ^nft$banner_highlight_field,
        carriage_control_action: ^nft$carriage_control_action,
        code_set: ^nft$code_set,
        device_type: ^nft$device_type,
        device_status: ^nft$device_status,
        file_ack: ^boolean,
        file_transfer_status: ^nft$file_transfer_status,
        forms_size: ^nft$forms_size,
        maximum_file_size: ^nft$device_file_size,
        maximum_page_length: ^nft$device_max_page_length,
        msg_length: integer,
        page_width: ^nft$page_width,
        page_length: ^nft$page_length,
        parameter: ^nft$add_bd_message_parameter,
        str: ost$string,
        suppress_carriage_control: ^nft$suppress_carriage_control,
        tip_type: ^nft$tip_type,
        transmission_block_size: ^nft$transmit_block_size,
        undefined_fe_action: ^nft$format_effector_actions,
        unsupported_fe_action: ^nft$format_effector_actions,
        value_length: integer,
        vfu_load_option: ^nft$vfu_load_option,
        vertical_print_density: ^nft$vertical_print_density;

      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        = nfc$device_status =
          NEXT device_status IN log_file_seq.sequence_pointer;
          put_display_line (device_statuses [device_status^],
                '    Device Status', display_control, status);

        = nfc$file_transfer_status_param =
          NEXT file_transfer_status IN log_file_seq.sequence_pointer;
          put_display_line (file_transfer_statuses [file_transfer_status^],
                '    File Transfer Status', display_control, status);

        = nfc$device_alias_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Alias 1',
                display_control, status);

        = nfc$device_alias_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Alias 2',
                display_control, status);

        = nfc$device_alias_3 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Alias 3',
                display_control, status);

        = nfc$device_type =
          NEXT device_type IN log_file_seq.sequence_pointer;
          put_display_line (device_types [device_type^], '    Device Type',
                display_control, status);

        = nfc$tip_type =
          NEXT tip_type IN log_file_seq.sequence_pointer;
          put_display_line (tip_types [tip_type^], '    Tip Type',
                display_control, status);

        = nfc$terminal_model =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Terminal Model',
                display_control, status);

        = nfc$file_acknowledgement =
          NEXT file_ack IN log_file_seq.sequence_pointer;
          put_display_line (boolean_values [file_ack^],
                '    File Acknowledgement', display_control, status);

        = nfc$transmission_block_size =
          NEXT transmission_block_size IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (transmission_block_size^, 10, FALSE,
                str, status);
          put_display_line (str.value (1, str.size),
                '    Transmission Block Size', display_control, status);

        = nfc$maximum_file_size =
          NEXT maximum_file_size IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (maximum_file_size^, 10, FALSE, str,
                status);
          put_display_line (str.value (1, str.size), '    Maximum File Size',
                display_control, status);

        = nfc$page_width =
          NEXT page_width IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (page_width^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Page Width',
                display_control, status);

        = nfc$page_length =
          NEXT page_length IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (page_length^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Page Length',
                display_control, status);

        = nfc$banner_page_count =
          NEXT banner_page_count IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (banner_page_count^, 10, FALSE, str,
                status);
          put_display_line (str.value (1, str.size), '    Banner Page Count',
                display_control, status);

        = nfc$banner_highlight_field =
          NEXT banner_highlight_field IN log_file_seq.sequence_pointer;
          put_display_line (banner_highlight_fields [banner_highlight_field^],
                '    Banner_Highlight_Field', display_control, status);

        = nfc$carriage_control_action =
          NEXT carriage_control_action IN log_file_seq.sequence_pointer;
          put_display_line (carriage_control_actions
                [carriage_control_action^], '    Carriage Control Action',
                display_control, status);

        = nfc$forms_code_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code 1', display_control,
                status);

        = nfc$forms_code_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code 2', display_control,
                status);

        = nfc$forms_code_3 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code 3', display_control,
                status);

        = nfc$forms_code_4 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code 4', display_control,
                status);

        = nfc$external_characteristics_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Ext Dev Char 1',
                display_control, status);

        = nfc$external_characteristics_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Ext Dev Char 2',
                display_control, status);

        = nfc$external_characteristics_3 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Ext Dev Char 3',
                display_control, status);

        = nfc$external_characteristics_4 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Ext Dev Char 4',
                display_control, status);

        = nfc$suppress_carriage_control =
          NEXT suppress_carriage_control IN log_file_seq.sequence_pointer;
          put_display_line (boolean_values [suppress_carriage_control^],
                '    Suppress Carriage Control', display_control, status);

        = nfc$code_set =
          NEXT code_set IN log_file_seq.sequence_pointer;
          put_display_line (code_sets [code_set^], '    Code_Set',
                display_control, status);

        = nfc$vertical_print_density =
          NEXT vertical_print_density IN log_file_seq.sequence_pointer;
          put_display_line (vpd_actions [vertical_print_density^],
                '    Vertical_Print_Density', display_control, status);

        = nfc$vfu_load_procedure =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    VFU Load Image',
                display_control, status);

        = nfc$forms_size =
          NEXT forms_size IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (forms_size^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Forms Size',
                display_control, status);

        = nfc$undefined_fe_action =
          NEXT undefined_fe_action IN log_file_seq.sequence_pointer;
          put_display_line (format_effector_actions [undefined_fe_action^],
                '    Un_Defined_FE_Action', display_control, status);

        = nfc$unsupported_fe_action =
          NEXT unsupported_fe_action IN log_file_seq.sequence_pointer;
          put_display_line (format_effector_actions [unsupported_fe_action^],
                '    Un_Supported_FE_Action', display_control, status);

        = nfc$vfu_load_option =
          NEXT vfu_load_option IN log_file_seq.sequence_pointer;
          put_display_line (vfu_load_option_actions [vfu_load_option^],
                '    Vertical_Forms_Unit', display_control, status);

        = nfc$device_maximum_page_length =
          NEXT maximum_page_length IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (maximum_page_length^, 10, FALSE, str,
                status);
          put_display_line (str.value (1, str.size), '    Max Page Length',
                display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND add_batch_device_msg;
?? TITLE := '    add batch device response msg', EJECT ??

    PROCEDURE add_batch_device_resp_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$add_del_device_response
*copy nft$add_bd_resp_codes

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$add_del_bd_resp_parameter,
        response: string (40),
        response_code: ^nft$add_bd_responses,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        = nfc$response_code =
          NEXT response_code IN log_file_seq.sequence_pointer;
          CASE response_code^ OF
          = nfc$message_accepted =
            response := 'Message Accepted';
          = nfc$no_io_station_found =
            response := 'Message Rejected, no io station';
          = nfc$duplicate_device_name =
            response := 'Message Rejected, duplicate device';
          = nfc$duplicate_aliases_specified =
            response := 'Message Rejected, duplicate aliases';
          CASEND;
          put_display_line (response, '    Response', display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND add_batch_device_resp_msg;
?? TITLE := '    add io station msg', EJECT ??

    PROCEDURE add_io_station_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$add_io_station_message
*copy nft$add_ios_resp_codes

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        destination_unavail_action: ^nft$destination_unavail_actions,
        file_ack: ^boolean,
        msg_length: integer,
        parameter: ^nft$add_ios_message_parameter,
        pm_message_action: ^nft$pm_message_actions,
        io_station_usage: ^nft$io_station_usage,
        str: ost$string,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$io_station_alias_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station Alias 1',
                display_control, status);

        = nfc$io_station_alias_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station Alias 2',
                display_control, status);

        = nfc$io_station_alias_3 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station Alias 3',
                display_control, status);

        = nfc$required_operator_device =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Required Operator Device',
                display_control, status);

        = nfc$station_usage =
          NEXT io_station_usage IN log_file_seq.sequence_pointer;
          put_display_line (station_usages [io_station_usage^],
                '    Station_Usage', display_control, status);

        = nfc$file_acknowledgement =
          NEXT file_ack IN log_file_seq.sequence_pointer;
          put_display_line (boolean_values [file_ack^],
                '    File Acknowledgement', display_control, status);

        = nfc$check_station_unique =
          NEXT file_ack IN log_file_seq.sequence_pointer;
          put_display_line (boolean_values [file_ack^], '    Check IOS Unique',
                display_control, status);

        = nfc$auto_operator_control =
          NEXT file_ack IN log_file_seq.sequence_pointer;
          put_display_line (boolean_values [file_ack^],
                '    Auto Operator Control', display_control, status);

        = nfc$default_job_destination =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Default Job Destination',
                display_control, status);

        = nfc$destination_unavail_action =
          NEXT destination_unavail_action IN log_file_seq.sequence_pointer;
          put_display_line (destination_unavail_actions
                [destination_unavail_action^],
                '    Destination_Unavailable_Action', display_control, status);
        = nfc$pm_message_action =
          NEXT pm_message_action IN log_file_seq.sequence_pointer;
          put_display_line (pm_message_actions [pm_message_action^],
                '    PM Message Action', display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND add_io_station_msg;
?? TITLE := '    add io station response msg', EJECT ??

    PROCEDURE add_io_station_resp_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$add_io_station_response
*copy nft$add_ios_resp_codes

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$add_ios_resp_msg_parameter,
        response: string (53),
        response_code: ^nft$add_io_station_responses,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$response_code =
          NEXT response_code IN log_file_seq.sequence_pointer;
          CASE response_code^ OF
          = nfc$message_accepted =
            response := 'Message Accepted';
          = nfc$duplicate_with_check_unique =
            response := 'Message Rejected, duplicate definition not allowed';
          = nfc$duplicate_defs_do_not_match =
            response := 'Message Rejected, duplicate definition does not match'
                  ;
          = nfc$duplicate_alias_names =
            response := 'Message Rejected, duplicate aliases';
          = nfc$not_unique_network_title =
            response := 'Message Rejected, duplicate title';
          CASEND;
          put_display_line (response, '    Response', display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND add_io_station_resp_msg;
?? TITLE := '    add accessible remote sys msg', EJECT ??

    PROCEDURE add_accessible_remote_sys_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$ntf_add_acc_rem_sys_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        authority_level: ^nft$ntf_authority_level,
        line_number: ^nft$ntf_logical_line_number,
        parameter: ^nft$ntf_add_acc_rem_sys_msg,
        remote_system_type: ^nft$ntf_remote_system_type,
        route_back_position: ^nft$ntf_route_back_position,
        str: ost$string,
        value_length: integer;

      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$ntf_remote_system_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Remote System', display_control,
                status);

        = nfc$ntf_logical_line_number =
          NEXT line_number IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (line_number^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Logical Line Number',
                display_control, status);

        = nfc$ntf_acc_remote_system_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Acc Remote System', display_control,
                status);

        = nfc$ntf_authority_level =
          NEXT authority_level IN log_file_seq.sequence_pointer;
          put_display_line (authority_levels [authority_level^], '    Authority Level',
                display_control, status);

        = nfc$ntf_remote_system_type =
          NEXT remote_system_type IN log_file_seq.sequence_pointer;
          put_display_line (remote_system_types [remote_system_type^], '    Remote System Type',
                display_control, status);

        = nfc$ntf_route_back_position =
          NEXT route_back_position IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (route_back_position^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size),
                '    Route Back Position', display_control, status);
        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND add_accessible_remote_sys_msg;
?? TITLE := '    add acc remote system response msg', EJECT ??

    PROCEDURE add_acc_remote_system_resp_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$ntf_add_acc_rem_sys_resp
*copy nft$ntf_add_ars_response_codes

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        line_number: ^nft$ntf_logical_line_number,
        msg_length: integer,
        parameter: ^nft$ntf_add_acc_rem_sys_resp,
        response: string (53),
        response_code: ^nft$ntf_add_ars_response_codes,
        str: ost$string,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$ntf_remote_system_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Remote System', display_control,
                status);

        = nfc$ntf_logical_line_number =
          NEXT line_number IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (line_number^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Logical Line Number',
                display_control, status);

        = nfc$ntf_acc_remote_system_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Acc Remote System', display_control,
                status);

        = nfc$response_code =
          NEXT response_code IN log_file_seq.sequence_pointer;
          CASE response_code^ OF
          = nfc$message_accepted =
            response := 'Message Accepted';
          = nfc$ntf_remote_system_not_found =
            response := 'Message Rejected, remote system not found';
          = nfc$ntf_logical_line_not_found =
            response := 'Message Rejected, logical line number not found';
          = nfc$ntf_dup_defs_do_not_match =
            response := 'Message Rejected, duplicate definition does not match';
          = nfc$ntf_remote_sys_not_listed =
            response := 'Message Rejected, remote system not found in NTF System List';
          CASEND;
          put_display_line (response, '    Response', display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND add_acc_remote_system_resp_msg;
?? TITLE := '    add remote system msg', EJECT ??

    PROCEDURE add_remote_system_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$ntf_add_remote_sys_msg

      VAR
        a_level: ^nft$ntf_authority_level,
        ascii_string: ^string ( * <= osc$max_name_size),
        inactivity_timer: ^nft$ntf_inactivity_timer,
        line_number: ^nft$ntf_logical_line_number,
        line_speed: ^nft$ntf_line_speed,
        msg_length: integer,
        parameter: ^nft$ntf_add_remote_sys_msg,
        positive_acknowledge: ^nft$ntf_positive_acknowledge,
        protocol: ^nft$ntf_remote_system_protocol,
        remote_sys_type: ^nft$ntf_remote_system_type,
        request_perm_retry: ^boolean,
        route_back: ^nft$ntf_route_back_position,
        wait_a_bit: ^nft$ntf_wait_a_bit,
        str: ost$string,
        value_length: integer;

      VAR
      positive_acknowledges: [READ, STATIC] array [nft$ntf_positive_acknowledge] of
            string (display_value_size) := ['ACK', 'NULL'],
      wait_a_bits: [READ, STATIC] array [nft$ntf_wait_a_bit] of string (display_value_size) := ['ACK',
            'FCS'];

      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$ntf_remote_system_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Remote System', display_control,
                status);

        = nfc$ntf_protocol =
          NEXT protocol IN log_file_seq.sequence_pointer;
          put_display_line (remote_system_protocols [protocol^], '    Remote System Protocol',
                display_control, status);

        = nfc$ntf_logical_line_number =
          NEXT line_number IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (line_number^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Logical Line Number',
                display_control, status);

        = nfc$ntf_line_speed =
          NEXT line_speed IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (line_speed^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Line Speed',
                display_control, status);

        = nfc$ntf_line_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Line Name', display_control,
                status);

        = nfc$ntf_authority_level =
          NEXT a_level IN log_file_seq.sequence_pointer;
          put_display_line (authority_levels [a_level^], '    Authority Level',
                display_control, status);

        = nfc$ntf_terminal_user_procedure =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Terminal User Proc', display_control,
                status);

        = nfc$ntf_wait_a_bit =
          NEXT wait_a_bit IN log_file_seq.sequence_pointer;
          put_display_line (wait_a_bits [wait_a_bit^], '    Wait-A-Bit',
                display_control, status);

        = nfc$ntf_inactivity_timer =
          NEXT inactivity_timer IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (inactivity_timer^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Inactivity timer',
                display_control, status);

        = nfc$ntf_positive_acknowledge =
          NEXT positive_acknowledge IN log_file_seq.sequence_pointer;
          put_display_line (positive_acknowledges [positive_acknowledge^], '    Positive Acknowledgement',
                display_control, status);

        = nfc$ntf_default_job_destination =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Default Job Destination', display_control,
                status);

        = nfc$ntf_default_file_destin =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Default File Destination', display_control,
                status);

        = nfc$ntf_store_forward_destin =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Store-and-Forward Destination', display_control,
                status);

        = nfc$ntf_remote_system_type =
          NEXT remote_sys_type IN log_file_seq.sequence_pointer;
          put_display_line (remote_system_types [remote_sys_type^], '    Remote System Type',
                display_control, status);

        = nfc$ntf_route_back_position =
          NEXT route_back IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (route_back^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size),
                '    Route Back Position', display_control, status);

        = nfc$ntf_request_perm_retry =
          NEXT request_perm_retry IN log_file_seq.sequence_pointer;
          IF request_perm_retry^ THEN
            str.value := 'True';
          ELSE
            str.value := 'False';
          IFEND;
          put_display_line (str.value (1,5), '    Request Permission Retry',
                display_control, status);

        = nfc$ntf_local_system_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Local System Name', display_control,
                status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND add_remote_system_msg;
?? TITLE := '    ntf msg', EJECT ??

    PROCEDURE ntf_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

      NEXT byte_array: [1 .. message_length-1] IN log_file_seq.sequence_pointer;

      put_display_line ('-- Not currently displayed --', '    NTF Parameters',  display_control,
            status);

    PROCEND ntf_msg;
?? TITLE := '    add remote system response msg', EJECT ??

    PROCEDURE add_remote_system_resp_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$ntf_add_remote_sys_resp
*copy nft$ntf_add_rs_response_codes

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        line_number: ^nft$ntf_logical_line_number,
        msg_length: integer,
        parameter: ^nft$ntf_add_remote_sys_resp,
        response: string (53),
        response_code: ^nft$ntf_add_rs_response_codes,
        str: ost$string,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$ntf_remote_system_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Remote System', display_control,
                status);

        = nfc$ntf_logical_line_number =
          NEXT line_number IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (line_number^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Logical Line Number',
                display_control, status);

        = nfc$response_code =
          NEXT response_code IN log_file_seq.sequence_pointer;
          CASE response_code^ OF
          = nfc$message_accepted =
            response := 'Message Accepted';
          = nfc$ntf_dup_defs_do_not_match =
            response := 'Message Rejected, duplicate definition does not match';
          = nfc$ntf_dup_logical_line_number =
            response := 'Message Rejected, duplicate logical line number';
          = nfc$ntf_dup_rs_name_in_domain =
            response := 'Message Rejected, duplicate title';
          = nfc$ntf_remote_sys_not_listed =
            response := 'Message Rejected, remote system not found in NTF System List';
          CASEND;
          put_display_line (response, '    Response', display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND add_remote_system_resp_msg;
?? TITLE := '    add user msg', EJECT ??

    PROCEDURE add_user_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$add_user_msg

      VAR
        accept_messages: ^nft$accept_messages,
        ascii_string: ^string ( * <= osc$max_name_size),
        io_station_usage: ^nft$io_station_usage,
        msg_length: integer,
        parameter: ^nft$add_user_message_parameter,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$station_or_control_facility =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$control_device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Control Device',
                display_control, status);

        = nfc$family_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Family', display_control,
                status);

        = nfc$user_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    User', display_control,
                status);

        = nfc$station_usage =
          NEXT io_station_usage IN log_file_seq.sequence_pointer;
          put_display_line (station_usages [io_station_usage^],
                '    I/O Station Usage', display_control, status);

        = nfc$accept_messages =
          NEXT accept_messages IN log_file_seq.sequence_pointer;
          put_display_line (accept_msg [accept_messages^],
                '    Accept Messages', display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND add_user_msg;
?? TITLE := '    add user response msg', EJECT ??

    PROCEDURE add_user_resp_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$add_user_resp_msg
*copyc nft$add_user_responses

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$add_user_resp_msg_parameter,
        response: string (43),
        response_code: ^nft$add_user_responses,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$station_or_control_facility =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$response_code =
          NEXT response_code IN log_file_seq.sequence_pointer;
          CASE response_code^ OF
          = nfc$message_accepted =
            response := 'Message Accepted';
          = nfc$no_io_station_found =
            IF connection_kind^ = nfc$ntf_operator_connection THEN
              response := 'Message Accepted';
            ELSE
              response := 'Message Rejected, no io station';
            IFEND;

          = nfc$operator_already_assigned =
            response := 'Message Rejected, Operator already assigned';
          = nfc$operator_device_mismatch =
            response := 'Message Rejected, Operator device mismatch';
          CASEND;
          put_display_line (response, '    Response', display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND add_user_resp_msg;
?? TITLE := '    batch device status msg', EJECT ??

    PROCEDURE batch_device_status_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$batch_device_status_message

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        device_status: ^nft$device_status,
        file_transfer_status: ^nft$file_transfer_status,
        msg_length: integer,
        parameter: ^nft$bd_status_message_parameter,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        = nfc$device_status =
          NEXT device_status IN log_file_seq.sequence_pointer;
          put_display_line (device_statuses [device_status^],
                '    Device Status', display_control, status);

        = nfc$file_transfer_status_param =
          NEXT file_transfer_status IN log_file_seq.sequence_pointer;
          put_display_line (file_transfer_statuses [file_transfer_status^],
                '    File Transfer Status', display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND batch_device_status_msg;
?? TITLE := '    btf ve status msg', EJECT ??

  PROCEDURE btf_ve_status_msg
    (    message_length: integer;
     VAR display_control: clt$display_control;
     VAR log_file_seq: amt$segment_pointer;
     VAR status: ost$status);

*copy nft$btf_ve_status_message

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      btf_ve_protocol_stack: ^nat$protocol_stack_integer,
      msg_length: integer,
      parameter: ^nft$btf_ve_status_parameter,
      value_length: integer;

    msg_length := message_length - 1;
    NEXT parameter IN log_file_seq.sequence_pointer;

    WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
          (msg_length > 0) DO
      msg_length := msg_length - 1;
      IF parameter^.length_indicated THEN
        get_parameter_value_length (log_file_seq, msg_length, value_length,
              status);
        msg_length := msg_length - value_length;
      ELSE
        value_length := 1;
        msg_length := msg_length - 1;
      IFEND;

      IF parameter^.param = nfc$btf_ve_protocol_stacks THEN
        NEXT btf_ve_protocol_stack IN log_file_seq.sequence_pointer;
        put_display_line (btf_ve_protocol_stacks [btf_ve_protocol_stack^],
              '    BTF/VE Protocol Stacks', display_control, status);
      ELSE
{ ERROR
      IFEND;
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      IF msg_length > 0 THEN
        NEXT parameter IN log_file_seq.sequence_pointer;
      IFEND;
    WHILEND;

  PROCEND btf_ve_status_msg;
?? TITLE := '    btfs di status msg', EJECT ??

    PROCEDURE btfs_di_status_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$btfs_di_status_message

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        btfs_di_advanced_feature: ^nft$btfs_di_advanced_features,
        btfs_di_network_address: ^nft$network_address,
        btfs_di_status_code: ^nft$btfs_di_status_codes,
        msg_length: integer,
        parameter: ^nft$btfs_di_status_parameter,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$btfs_di_network_address =
          NEXT btfs_di_network_address IN log_file_seq.sequence_pointer;
          display_btfs_di_address (btfs_di_network_address, display_control,
                log_file_seq, status);

        = nfc$btfs_status_code =
          NEXT btfs_di_status_code IN log_file_seq.sequence_pointer;
          put_display_line (btfs_di_statuses [btfs_di_status_code^],
                '    BTFS/DI Status', display_control, status);

        = nfc$btfs_di_title =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    BTFS/DI Title',
                display_control, status);

        = nfc$btfs_di_advanced_features =
          NEXT btfs_di_advanced_feature IN log_file_seq.sequence_pointer;
          put_display_line (btfs_di_advanced_features [btfs_di_advanced_feature^],
                '    BTFS/DI Advanced Features', display_control, status);

        ELSE

          {       ERROR

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND btfs_di_status_msg;
?? TITLE := '    change batch device attributes', EJECT ??

    PROCEDURE change_batch_device_attributes
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$change_bd_attributes_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        banner_page_count: ^nft$banner_page_count,
        banner_highlight_field: ^nft$banner_highlight_field,
        carriage_control_action: ^nft$carriage_control_action,
        code_set: ^nft$code_set,
        file_ack: ^boolean,
        forms_size: ^nft$forms_size,
        msg_length: integer,
        maximum_file_size: ^nft$device_file_size,
        page_length: ^nft$page_length,
        page_width: ^nft$page_width,
        parameter: ^nft$change_bd_attr_parameter,
        str: ost$string,
        transmission_block_size: ^nft$transmit_block_size,
        undefined_fe_action: ^nft$format_effector_actions,
        unsupported_fe_action: ^nft$format_effector_actions,
        value_length: integer,
        vertical_print_density: ^nft$vertical_print_density;

      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        = nfc$device_alias_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Alias 1',
                display_control, status);

        = nfc$device_alias_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Alias 2',
                display_control, status);

        = nfc$device_alias_3 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Alias 3',
                display_control, status);

        = nfc$file_acknowledge =
          NEXT file_ack IN log_file_seq.sequence_pointer;
          put_display_line (boolean_values [file_ack^],
                '    File Acknowledgement', display_control, status);

        = nfc$terminal_model =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Terminal Model',
                display_control, status);

        = nfc$transmission_block_size =
          NEXT transmission_block_size IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (transmission_block_size^, 10, FALSE,
                str, status);
          put_display_line (str.value (1, str.size),
                '    Transmission Block Size', display_control, status);

        = nfc$maximum_file_size =
          NEXT maximum_file_size IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (maximum_file_size^, 10, FALSE, str,
                status);
          put_display_line (str.value (1, str.size), '    Maximum File Size',
                display_control, status);

        = nfc$page_width =
          NEXT page_width IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (page_width^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Page Width',
                display_control, status);

        = nfc$page_length =
          NEXT page_length IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (page_length^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Page Length',
                display_control, status);

        = nfc$banner_page_count =
          NEXT banner_page_count IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (banner_page_count^, 10, FALSE, str,
                status);
          put_display_line (str.value (1, str.size), '    Banner Page Count',
                display_control, status);

        = nfc$banner_highlight_field =
          NEXT banner_highlight_field IN log_file_seq.sequence_pointer;
          put_display_line (banner_highlight_fields [banner_highlight_field^],
                '    Banner_Highlight_Field', display_control, status);

        = nfc$carriage_control_action =
          NEXT carriage_control_action IN log_file_seq.sequence_pointer;
          put_display_line (carriage_control_actions
                [carriage_control_action^], '    Carriage Control Action',
                display_control, status);

        = nfc$forms_code_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code 1', display_control,
                status);

        = nfc$forms_code_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code 2', display_control,
                status);

        = nfc$forms_code_3 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code 3', display_control,
                status);

        = nfc$forms_code_4 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code 4', display_control,
                status);

        = nfc$external_characteristics_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Ext Dev Char 1',
                display_control, status);

        = nfc$external_characteristics_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Ext Dev Char 2',
                display_control, status);

        = nfc$external_characteristics_3 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Ext Dev Char 3',
                display_control, status);

        = nfc$external_characteristics_4 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Ext Dev Char 4',
                display_control, status);

        = nfc$code_set =
          NEXT code_set IN log_file_seq.sequence_pointer;
          put_display_line (code_sets [code_set^], '    Code_Set',
                display_control, status);

        = nfc$vertical_print_density =
          NEXT vertical_print_density IN log_file_seq.sequence_pointer;
          put_display_line (vpd_actions [vertical_print_density^],
                '    Vertical_Print_Density', display_control, status);

        = nfc$vfu_load_procedure =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    VFU Load Image',
                display_control, status);

        = nfc$forms_size =
          NEXT forms_size IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (forms_size^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Forms_Size',
                display_control, status);

        = nfc$undefined_fe_action =
          NEXT undefined_fe_action IN log_file_seq.sequence_pointer;
          put_display_line (format_effector_actions [undefined_fe_action^],
                '    Un_Defined_FE_Action', display_control, status);

        = nfc$unsupported_fe_action =
          NEXT unsupported_fe_action IN log_file_seq.sequence_pointer;
          put_display_line (format_effector_actions [unsupported_fe_action^],
                '    Un_Supported_FE_Action', display_control, status);


        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND change_batch_device_attributes;
?? TITLE := '    change batch device attributes response msg', EJECT ??

    PROCEDURE change_batch_device_attr_resp
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$change_bd_attr_resp_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        banner_page_count: ^nft$banner_page_count,
        banner_highlight_field: ^nft$banner_highlight_field,
        carriage_control_action: ^nft$carriage_control_action,
        code_set: ^nft$code_set,
        file_ack: ^boolean,
        forms_size: ^nft$forms_size,
        invalid_param: ^nft$change_bda_resp_parameters,
        msg_length: integer,
        maximum_file_size: ^nft$device_file_size,
        page_length: ^nft$page_length,
        page_width: ^nft$page_width,
        parameter: ^nft$change_bd_attr_resp_param,
        str: ost$string,
        transmission_block_size: ^nft$transmit_block_size,
        undefined_fe_action: ^nft$format_effector_actions,
        unsupported_fe_action: ^nft$format_effector_actions,
        value_length: integer,
        vertical_print_density: ^nft$vertical_print_density;

      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$device_alias_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Alias 1',
                display_control, status);

        = nfc$device_alias_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Alias 2',
                display_control, status);

        = nfc$device_alias_3 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Alias 3',
                display_control, status);

        = nfc$file_acknowledgement =
          NEXT file_ack IN log_file_seq.sequence_pointer;
          put_display_line (boolean_values [file_ack^],
                '    File Acknowledgement', display_control, status);

        = nfc$terminal_model =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Terminal Model',
                display_control, status);

        = nfc$transmission_block_size =
          NEXT transmission_block_size IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (transmission_block_size^, 10, FALSE,
                str, status);
          put_display_line (str.value (1, str.size),
                '    Transmission Block Size', display_control, status);

        = nfc$maximum_file_size =
          NEXT maximum_file_size IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (maximum_file_size^, 10, FALSE, str,
                status);
          put_display_line (str.value (1, str.size), '    Maximum File Size',
                display_control, status);

        = nfc$page_width =
          NEXT page_width IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (page_width^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Page Width',
                display_control, status);

        = nfc$page_length =
          NEXT page_length IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (page_length^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Page Length',
                display_control, status);

        = nfc$banner_page_count =
          NEXT banner_page_count IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (banner_page_count^, 10, FALSE, str,
                status);
          put_display_line (str.value (1, str.size), '    Banner Page Count',
                display_control, status);

        = nfc$banner_highlight_field =
          NEXT banner_highlight_field IN log_file_seq.sequence_pointer;
          put_display_line (banner_highlight_fields [banner_highlight_field^],
                '    Banner_Highlight_Field', display_control, status);

        = nfc$carriage_control_action =
          NEXT carriage_control_action IN log_file_seq.sequence_pointer;
          put_display_line (carriage_control_actions
                [carriage_control_action^], '    Carriage Control Action',
                display_control, status);

        = nfc$forms_code_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code 1', display_control,
                status);

        = nfc$forms_code_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code 2', display_control,
                status);

        = nfc$forms_code_3 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code 3', display_control,
                status);

        = nfc$forms_code_4 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code 4', display_control,
                status);

        = nfc$external_characteristics_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Ext Dev Char 1',
                display_control, status);

        = nfc$external_characteristics_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Ext Dev Char 2',
                display_control, status);

        = nfc$external_characteristics_3 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Ext Dev Char 3',
                display_control, status);

        = nfc$external_characteristics_4 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Ext Dev Char 4',
                display_control, status);

        = nfc$code_set =
          NEXT code_set IN log_file_seq.sequence_pointer;
          put_display_line (code_sets [code_set^], '    Code_Set',
                display_control, status);

        = nfc$vertical_print_density =
          NEXT vertical_print_density IN log_file_seq.sequence_pointer;
          put_display_line (vpd_actions [vertical_print_density^],
                '    Vertical Print Density', display_control, status);

        = nfc$vfu_load_procedure =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    VFU Load Image',
                display_control, status);

        = nfc$forms_size =
          NEXT forms_size IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (forms_size^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Forms_Size',
                display_control, status);

        = nfc$undefined_fe_action =
          NEXT undefined_fe_action IN log_file_seq.sequence_pointer;
          put_display_line (format_effector_actions [undefined_fe_action^],
                '    Un_Defined_FE_Action', display_control, status);

        = nfc$unsupported_fe_action =
          NEXT unsupported_fe_action IN log_file_seq.sequence_pointer;
          put_display_line (format_effector_actions [unsupported_fe_action^],
                '    Un_Supported_FE_Action', display_control, status);

        = nfc$invalid_chg_request =
          NEXT invalid_param IN log_file_seq.sequence_pointer;
          put_display_line (chabda_parameters [invalid_param^],
                '    Invalid Parameter', display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND change_batch_device_attr_resp;
?? TITLE := '    delete batch device msg', EJECT ??

    PROCEDURE delete_batch_device_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$delete_batch_device_message

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$del_bd_message_parameter,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND delete_batch_device_msg;
?? TITLE := '    delete batch device response msg', EJECT ??

    PROCEDURE delete_batch_device_resp_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$add_del_device_response
*copy nft$delete_bd_resp_codes

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$add_del_bd_resp_parameter,
        response: string (40),
        response_code: ^nft$delete_bd_responses,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        = nfc$response_code =
          NEXT response_code IN log_file_seq.sequence_pointer;
          CASE response_code^ OF
          = nfc$message_accepted =
            response := 'Message Accepted';
          = nfc$no_io_station_found =
            response := 'Message Rejected, no io station';
          = nfc$no_device_found =
            response := 'Message Rejected, no device';
          CASEND;
          put_display_line (response, '    Response', display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND delete_batch_device_resp_msg;
?? TITLE := '    delete destination msg', EJECT ??

    PROCEDURE delete_destination_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$delete_destination_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$delete_destination_param,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$destination_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Destination', display_control,
                status);

        = nfc$control_facility_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Control Facility',
                display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND delete_destination_msg;
?? TITLE := '    delete io station msg', EJECT ??

    PROCEDURE delete_io_station_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$delete_io_station_message

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$del_ios_message_parameter,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND delete_io_station_msg;
?? TITLE := '    delete io station response msg', EJECT ??

    PROCEDURE delete_io_station_resp_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$delete_io_station_response
*copy nft$delete_ios_resp_codes

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$del_ios_resp_msg_parameter,
        response: string (40),
        response_code: ^nft$delete_io_station_responses,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$response_code =
          NEXT response_code IN log_file_seq.sequence_pointer;
          CASE response_code^ OF
          = nfc$message_accepted =
            response := 'Message Accepted';
          = nfc$no_io_station =
            response := 'Message Rejected, no io station';
          CASEND;
          put_display_line (response, '    Response', display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND delete_io_station_resp_msg;
?? TITLE := '    delete ntf user response', EJECT ??

    PROCEDURE delete_ntf_user_response
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$ntf_delete_user_resp
*copyc nft$ntf_delete_user_resp_codes

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$ntf_delete_user_resp,
        response: string (45),
        response_code: ^nft$ntf_delete_user_resp_codes,
        str: ost$string,
        value_length: integer;

      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$ntf_remote_system_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Remote System', display_control,
                status);

        = nfc$response_code =
          NEXT response_code IN log_file_seq.sequence_pointer;
          CASE response_code^ OF
          = nfc$message_accepted =
            response := 'Message Accepted';
          = nfc$ntf_remote_system_not_found =
            response := 'Message Rejected, remote system not found';
          = nfc$ntf_operator_not_connected =
            response := 'Message Rejected, operator not connected';
          CASEND;
          put_display_line (response, '    Response Code', display_control, status);
        ELSE
{ ERROR
          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;
        CASEND;

        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND delete_ntf_user_response;
?? TITLE := '    device control resp msg', EJECT ??

    PROCEDURE device_control_resp_msg
      (VAR msg_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$device_control_resp_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        parameter: ^nft$device_control_resp_param,
        response: string (31),
        response_code: ^nft$device_control_resp_codes,
        value_length: integer,
        z_byte: ^0 .. 0ff(16);

      msg_length := msg_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <= nfc$response_code) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        = nfc$response_code =
          NEXT response_code IN log_file_seq.sequence_pointer;
          CASE response_code^ OF
          = nfc$dc_msg_accepted =
            response := 'Message Accepted';
          = nfc$dc_msg_reject_unknown_ios =
            response := 'Msg Rej, no io station';
          = nfc$dc_msg_reject_btfsdi_down =
            response := 'Msg Rej, BTFS DI down';
          = nfc$dc_msg_reject_unknown_dev =
            response := 'Msg Rej, no device';
          = nfc$dc_msg_reject_bad_dev_type =
            response := 'Msg Rej, bad dev type';
          = nfc$dc_msg_reject_bad_data_mode =
            response := 'Msg Rej, bad data mode';
          = nfc$dc_msg_rej_unsupported_vfu =
            response := 'Msg Rej, unsupported VFU';
          = nfc$dc_msg_rej_vfu_ld_outstand =
            response := 'Msg Rej, VFU ld req outstanding';
          = nfc$dc_msg_rej_image_not_found =
            response := 'Msg Rej, ld image not found';
          = nfc$dc_msg_rej_err_in_vfu_image =
            response := 'Msg Rej, error in VFU ld image';
          = nfc$dc_msg_rej_trm_undefined =
            response := 'Msg Rej, trm undefined';
          = nfc$dc_msg_rej_vfu_not_allow =
            response := 'Msg Rej, VFU not allowed';
          = nfc$dc_msg_rej_low_di_memory =
            response := 'Msg Rej, DI memory too low';

          CASEND;
          put_display_line (response, '    Response', display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          IF msg_length > 1 THEN
            NEXT parameter IN log_file_seq.sequence_pointer;
          ELSE
            NEXT z_byte IN log_file_seq.sequence_pointer;
            parameter := NIL;
            msg_length := 0;
          IFEND;
        IFEND;
      WHILEND;

      IF msg_length > 0 THEN
        RESET log_file_seq.sequence_pointer TO parameter;
      IFEND;

    PROCEND device_control_resp_msg;
?? TITLE := '    device status data msg', EJECT ??

    PROCEDURE device_status_data_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$device_status_data_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        banner_page_count: ^nft$banner_page_count,
        banner_highlight_field: ^nft$banner_highlight_field,
        carriage_control_action: ^nft$carriage_control_action,
        code_set: ^nft$code_set,
        device_status: ^nft$device_status,
        device_type: ^nft$device_type,
        file_ack: ^boolean,
        file_transfer_status: ^nft$file_transfer_status,
        forms_size: ^nft$forms_size,
        input_bytes_transferred: ^nft$input_job_size,
        logical_line_number: ^nft$ntf_logical_line_number,
        maximum_file_size: ^nft$device_file_size,
        msg_length: integer,
        page_width: ^nft$page_width,
        page_length: ^nft$page_length,
        parameter: ^nft$device_sd_msg_param,
        percent_complete: ^nft$file_position,
        response: string (31),
        response_code: ^nft$display_status_resp_codes,
        skip_punch_count: ^nft$ntf_skip_punch_count,
        str: ost$string,
        suppress_carriage_control: ^nft$suppress_carriage_control,
        text: ^string ( * ),
        transmission_block_size: ^nft$transmit_block_size,
        transparent_mode: ^boolean,
        undefined_fe_action: ^nft$format_effector_actions,
        unsupported_fe_action: ^nft$format_effector_actions,
        value_length: integer,
        vertical_print_density: ^nft$vertical_print_density,
        vfu_load_option: ^nft$vfu_load_option;

      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          IF (parameter^.param <> nfc$null_parameter) THEN
            value_length := 1;
            msg_length := msg_length - 1;
          IFEND;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        = nfc$response_code =
          NEXT response_code IN log_file_seq.sequence_pointer;
          CASE response_code^ OF
          = nfc$disp_msg_accepted =
            response := 'Message Accepted';
          = nfc$disp_no_io_station =
            response := 'Message Rejected, no io station';
          = nfc$disp_no_batch_device =
            response := 'Message Rejected, no batch device';
          = nfc$disp_unknown_file_name =
            response := 'Message Rejected, unknown file';
          CASEND;
          put_display_line (response, '    Response', display_control, status);

        = nfc$device_status =
          NEXT device_status IN log_file_seq.sequence_pointer;
          put_display_line (device_statuses [device_status^],
                '    Device Status', display_control, status);

        = nfc$device_type =
          NEXT device_type IN log_file_seq.sequence_pointer;
          put_display_line (device_types [device_type^], '    Device Type',
                display_control, status);

        = nfc$file_transfer_status_param =
          NEXT file_transfer_status IN log_file_seq.sequence_pointer;
          put_display_line (file_transfer_statuses [file_transfer_status^],
                '    File Transfer Status', display_control, status);

        = nfc$terminal_model =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Terminal Model',
                display_control, status);

        = nfc$file_acknowledgement =
          NEXT file_ack IN log_file_seq.sequence_pointer;
          put_display_line (boolean_values [file_ack^],
                '    File Acknowledgement', display_control, status);

        = nfc$maximum_file_size =
          NEXT maximum_file_size IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (maximum_file_size^, 10, FALSE, str,
                status);
          put_display_line (str.value (1, str.size), '    Maximum File Size',
                display_control, status);

        = nfc$page_width =
          NEXT page_width IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (page_width^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Page Width',
                display_control, status);

        = nfc$page_length =
          NEXT page_length IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (page_length^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Page Length',
                display_control, status);

        = nfc$banner_page_count =
          NEXT banner_page_count IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (banner_page_count^, 10, FALSE, str,
                status);
          put_display_line (str.value (1, str.size), '    Banner Page Count',
                display_control, status);

        = nfc$banner_highlight_field =
          NEXT banner_highlight_field IN log_file_seq.sequence_pointer;
          put_display_line (banner_highlight_fields [banner_highlight_field^],
                '    Banner_Highlight_Field', display_control, status);

        = nfc$transmission_block_size =
          NEXT transmission_block_size IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (transmission_block_size^, 10, FALSE,
                str, status);
          put_display_line (str.value (1, str.size),
                '    Transmission Block Size', display_control, status);

        = nfc$carriage_control_action =
          NEXT carriage_control_action IN log_file_seq.sequence_pointer;
          put_display_line (carriage_control_actions
                [carriage_control_action^], '    Carriage Control Action',
                display_control, status);

        = nfc$forms_code_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code 1', display_control,
                status);

        = nfc$forms_code_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code 2', display_control,
                status);

        = nfc$forms_code_3 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code 3', display_control,
                status);

        = nfc$forms_code_4 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code 4', display_control,
                status);

        = nfc$external_characteristics_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Ext Dev Char 1',
                display_control, status);

        = nfc$external_characteristics_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Ext Dev Char 2',
                display_control, status);

        = nfc$external_characteristics_3 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Ext Dev Char 3',
                display_control, status);

        = nfc$external_characteristics_4 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Ext Dev Char 4',
                display_control, status);

        = nfc$suppress_carriage_control =
          NEXT suppress_carriage_control IN log_file_seq.sequence_pointer;
          put_display_line (boolean_values [suppress_carriage_control^],
                '    Suppress Carriage Control', display_control, status);

        = nfc$device_alias_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Alias 1',
                display_control, status);

        = nfc$device_alias_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Alias 2',
                display_control, status);

        = nfc$device_alias_3 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Alias 3',
                display_control, status);

        = nfc$last_unsolicited_msg =
          NEXT text: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (text^, '    Last Unsolicited Msg', display_control,
                status);

        = nfc$system_file_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    System File Name',
                display_control, status);

        = nfc$user_file_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    User File Name',
                display_control, status);

        = nfc$system_job_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    System Job Name',
                display_control, status);

        = nfc$user_job_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    User Job Name',
                display_control, status);

        = nfc$user_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    User Name', display_control,
                status);

        = nfc$family_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Family', display_control,
                status);

        = nfc$percent_complete =
          NEXT percent_complete IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (percent_complete^, 10, FALSE, str,
                status);
          put_display_line (str.value (1, str.size), '    Percent Complete',
                display_control, status);

        = nfc$code_set =
          NEXT code_set IN log_file_seq.sequence_pointer;
          put_display_line (code_sets [code_set^], '    Code_Set',
                display_control, status);

        = nfc$vertical_print_density =
          NEXT vertical_print_density IN log_file_seq.sequence_pointer;
          put_display_line (vpd_actions [vertical_print_density^],
                '    Vertical_Print_Density', display_control, status);

        = nfc$vfu_load_procedure =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    VFU Load Image',
                display_control, status);

        = nfc$forms_size =
          NEXT forms_size IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (forms_size^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Forms_Size',
                display_control, status);

        = nfc$undefined_fe_action =
          NEXT undefined_fe_action IN log_file_seq.sequence_pointer;
          put_display_line (format_effector_actions [undefined_fe_action^],
                '    Un_Defined_FE_Action', display_control, status);

        = nfc$unsupported_fe_action =
          NEXT unsupported_fe_action IN log_file_seq.sequence_pointer;
          put_display_line (format_effector_actions [unsupported_fe_action^],
                '    Un_Supported_FE_Action', display_control, status);

        = nfc$vfu_load_option =
          NEXT vfu_load_option IN log_file_seq.sequence_pointer;
          put_display_line (vfu_load_option_actions [vfu_load_option^],
                '    Vertical_Forms_Unit', display_control, status);

        = nfc$destination_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Job Dest Name',
                display_control, status);

        = nfc$input_bytes_transferred =
          NEXT input_bytes_transferred IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (input_bytes_transferred^, 10, FALSE,
                str, status);
          put_display_line (str.value (1, str.size), '    Input Bytes',
                display_control, status);

        = nfc$ntf_logical_line_number =
          NEXT logical_line_number IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (logical_line_number^, 10, FALSE,
                str, status);
          put_display_line (str.value (1, str.size), '    Logical Line Number',
                display_control, status);

        = nfc$transparent_mode =
          NEXT transparent_mode IN log_file_seq.sequence_pointer;
          IF transparent_mode^ THEN
            str.value := 'True ';
          ELSE
            str.value := 'False';
          IFEND;
          put_display_line (str.value (1, 5), '    Transparent Mode',
                display_control, status);

        = nfc$ntf_skip_punch_count =
          NEXT skip_punch_count IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (skip_punch_count^, 10, FALSE,
                str, status);
          put_display_line (str.value (1, str.size), '    Skip Punch Count',
                display_control, status);

        = nfc$null_parameter =
          IF msg_length > 0 THEN
            put_display_line (' ', '    (Null)', display_control, status);
          IFEND;

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND device_status_data_msg;
?? TITLE := '    display file availability msg', EJECT ??

    PROCEDURE display_file_availability_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$file_availability_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        boolean_value: ^boolean,
        copies: ^nft$copies,
        device_type: ^nft$device_type,
        file_size: ^nft$file_size,
        file_transfer_state: ^nft$file_transfer_state,
        io_station_usage: ^nft$io_station_usage,
        msg_length: integer,
        output_data_mode: ^nft$output_data_mode,
        page_format: ^amt$page_format,
        page_length: ^nft$page_length,
        page_width: ^nft$page_width,
        parameter: ^nft$file_available_msg_param,
        priority: ^nft$priority,
        priority_factor: ^nft$priority_multiplier,
        str: ost$string,
        value_length: integer,
        vertical_print_density: ^nft$file_vertical_print_density;

      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$operator_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Operator Name',
                display_control, status);

        = nfc$operator_family =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Operator Family',
                display_control, status);

        = nfc$station_usage =
          NEXT io_station_usage IN log_file_seq.sequence_pointer;
          put_display_line (station_usages [io_station_usage^],
                '    I/O Station Usage', display_control, status);

        = nfc$system_file_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    System File Name',
                display_control, status);

        = nfc$system_job_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    System Job Name',
                display_control, status);

        = nfc$user_file_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    User File Name',
                display_control, status);

        = nfc$user_job_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    User Job Name',
                display_control, status);

        = nfc$user_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    User Name', display_control,
                status);

        = nfc$user_family =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    User Family', display_control,
                status);

        = nfc$copies =
          NEXT copies IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (copies^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Copies',
                display_control, status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        = nfc$device_type =
          NEXT device_type IN log_file_seq.sequence_pointer;
          put_display_line (device_types [device_type^], '    Device Type',
                display_control, status);

        = nfc$external_characteristics =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Ext Dev Char', display_control,
                status);

        = nfc$file_size =
          NEXT file_size IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (file_size^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    File Size',
                display_control, status);

        = nfc$forms_code =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code', display_control,
                status);

        = nfc$output_data_mode =
          NEXT output_data_mode IN log_file_seq.sequence_pointer;
          put_display_line (output_data_modes [output_data_mode^],
                '    Output Data Mode', display_control, status);

        = nfc$output_initial_priority =
          NEXT priority IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (priority^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size),
                '    Output Initial Priority', display_control, status);

        = nfc$output_maximum_priority =
          NEXT priority IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (priority^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size),
                '    Output Maximum Priority', display_control, status);

        = nfc$output_priority_factor =
          NEXT priority_factor IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (priority^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size),
                '    Output Priority Factor', display_control, status);

        = nfc$output_state =
          NEXT file_transfer_state IN log_file_seq.sequence_pointer;
          put_display_line (file_transfer_states [file_transfer_state^],
                '    File Transfer State', display_control, status);

        = nfc$page_format =
          NEXT page_format IN log_file_seq.sequence_pointer;
          put_display_line (page_formats [page_format^], '    Page Format',
                display_control, status);

        = nfc$page_length =
          NEXT page_length IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (page_length^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Page Length',
                display_control, status);

        = nfc$page_width =
          NEXT page_width IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (page_width^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Page Width',
                display_control, status);

        = nfc$vertical_print_density =
          NEXT vertical_print_density IN log_file_seq.sequence_pointer;
          put_display_line (file_vpd_actions [vertical_print_density^],
                '    Vertical_Print_Density', display_control, status);

        = nfc$vfu_load_procedure =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    VFU Load Image',
                display_control, status);

        = nfc$file_requeued =
          NEXT boolean_value IN log_file_seq.sequence_pointer;
          put_display_line (boolean_values [boolean_value^], '    File Requeued',
                display_control, status);

        = nfc$file_held_by_filter =
          NEXT boolean_value IN log_file_seq.sequence_pointer;
          put_display_line (boolean_values [boolean_value^], '    File Held by Filter',
                display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND display_file_availability_msg;
?? TITLE := '    file assignment msg', EJECT ??

    PROCEDURE file_assignment_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$file_assignment_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        banner_highlight_field: ^nft$banner_highlight_field,
        banner_page_count: ^nft$banner_page_count,
        btfs_di_address: ^nft$network_address,
        carriage_control_support: ^nft$carriage_control_action,
        code_set: ^nft$code_set,
        device_type: ^nft$device_type,
        dev_vertical_print_density: ^nft$vertical_print_density,
        file_ack: ^boolean,
        forms_size: ^nft$forms_size,
        maximum_file_size: ^nft$device_file_size,
        msg_length: integer,
        parameter: ^nft$file_assign_msg_parameter,
        value_length: integer,
        copies: ^nft$copies,
        io_station_usage: ^nft$io_station_usage,
        page_width: ^nft$page_width,
        priority: ^nft$priority,
        protocol: ^nft$ntf_remote_system_protocol,
        remote_system_type: ^nft$ntf_remote_system_type,
        route_back_position: ^nft$ntf_route_back_position,
        str: ost$string,
        tip_type: ^nft$tip_type,
        transmission_block_size: ^nft$transmit_block_size,
        undefined_fe_action: ^nft$format_effector_actions,
        unsupported_fe_action: ^nft$format_effector_actions,
        vertical_print_density: ^nft$file_vertical_print_density,
        vfu_load_option: ^nft$vfu_load_option;

      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$banner_highlight_field =
          NEXT banner_highlight_field IN log_file_seq.sequence_pointer;
          put_display_line (banner_highlight_fields [banner_highlight_field^],
                '    Banner_Highlight_Field', display_control, status);

        = nfc$banner_page_count =
          NEXT banner_page_count IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (banner_page_count^, {radix} 10, {include radix} FALSE, str,
                status);
          put_display_line (str.value (1, str.size), '    Banner Page Count',
                display_control, status);

        = nfc$btfs_di_title =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    BTFS/DI Title',
                display_control, status);

        = nfc$btfsdi_address =
          NEXT btfs_di_address IN log_file_seq.sequence_pointer;
          display_btfs_di_address (btfs_di_address, display_control,
                log_file_seq, status);

        = nfc$carriage_control_support =
          NEXT carriage_control_support IN log_file_seq.sequence_pointer;
          put_display_line (carriage_control_actions
                [carriage_control_support^], '    Carriage Control Support',
                display_control, status);

        = nfc$code_set =
          NEXT code_set IN log_file_seq.sequence_pointer;
          put_display_line (code_sets [code_set^], '    Code Set',
                display_control, status);

        = nfc$copies =
          NEXT copies IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (copies^, {radix} 10, {include radix} FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Copies',
                display_control, status);

        = nfc$dev_vertical_print_density =
          NEXT dev_vertical_print_density IN log_file_seq.sequence_pointer;
          put_display_line (vpd_actions [dev_vertical_print_density^],
                '    Device VPD', display_control, status);

        = nfc$dev_vfu_load_procedure =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device VFU Load Proc',
                display_control, status);

        = nfc$device_alias_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Alias 1',
                display_control, status);

        = nfc$device_alias_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Alias 2',
                display_control, status);

        = nfc$device_alias_3 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Alias 3',
                display_control, status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        = nfc$device_type =
          NEXT device_type IN log_file_seq.sequence_pointer;
          put_display_line (device_types [device_type^], '    Device Type',
                display_control, status);

        = nfc$external_characteristics =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    External Characteristics',
                display_control, status);

        = nfc$external_characteristics_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device EC 1',
                display_control, status);

        = nfc$external_characteristics_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device EC 2',
                display_control, status);

        = nfc$external_characteristics_3 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device EC 3',
                display_control, status);

        = nfc$external_characteristics_4 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device EC 4',
                display_control, status);

        = nfc$file_acknowledgement =
          NEXT file_ack IN log_file_seq.sequence_pointer;
          put_display_line (boolean_values [file_ack^],
                '    File Acknowledgement', display_control, status);

        = nfc$forms_code =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Forms Code', display_control,
                status);

        = nfc$forms_code_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Forms Code 1',
                display_control, status);

        = nfc$forms_code_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Forms Code 2',
                display_control, status);

        = nfc$forms_code_3 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Forms Code 3',
                display_control, status);

        = nfc$forms_code_4 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device Forms Code 4',
                display_control, status);

        = nfc$forms_size =
          NEXT forms_size IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (forms_size^, {radix} 10, {include radix} FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Forms Size',
                display_control, status);

        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$maximum_file_size =
          NEXT maximum_file_size IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (maximum_file_size^, {radix} 10, {include radix} FALSE, str,
                status);
          put_display_line (str.value (1, str.size), '    Maximum File Size',
                display_control, status);

        = nfc$ntf_remote_system_protocol =
          NEXT  protocol  IN log_file_seq.sequence_pointer;
          put_display_line (remote_system_protocols [protocol^], '    Remote System Protocol',
                display_control, status);

        = nfc$ntf_remote_system_type =
          NEXT remote_system_type IN log_file_seq.sequence_pointer;
          put_display_line (remote_system_types [remote_system_type^], '    Remote System Type',
                display_control, status);

        = nfc$ntf_route_back_position =
          NEXT route_back_position IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (route_back_position^, {radix} 10,
              {include radix} FALSE, str, status);
          put_display_line (str.value (1, str.size),
                '    Route Back Position', display_control, status);

        = nfc$operator_family =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Operator Family',
                display_control, status);

        = nfc$operator_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Operator Name',
                display_control, status);

        = nfc$output_initial_priority =
          NEXT priority IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (priority^, {radix} 10, {include radix} FALSE, str, status);
          put_display_line (str.value (1, str.size),
                '    Output Initial Priority', display_control, status);

        = nfc$page_width =
          NEXT page_width IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (page_width^, {radix} 10, {include radix} FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Page Width',
                display_control, status);

        = nfc$requested_device =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Requested Device',
                display_control, status);

        = nfc$requested_io_station =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Requested Station',
                display_control, status);

        = nfc$station_usage =
          NEXT io_station_usage IN log_file_seq.sequence_pointer;
          put_display_line (station_usages [io_station_usage^],
                '    I/O Station Usage', display_control, status);

        = nfc$system_file_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    System File Name',
                display_control, status);

        = nfc$terminal_model =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Terminal Model',
                display_control, status);

        = nfc$tip_type =
          NEXT tip_type IN log_file_seq.sequence_pointer;
          put_display_line (tip_types [tip_type^], '    Tip Type',
                display_control, status);

        = nfc$transmission_block_size =
          NEXT transmission_block_size IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (transmission_block_size^, {radix} 10, {include radix} FALSE,
                str, status);
          put_display_line (str.value (1, str.size),
                '    Transmission Block Size', display_control, status);

        = nfc$undefined_fe_action =
          NEXT undefined_fe_action IN log_file_seq.sequence_pointer;
          put_display_line (format_effector_actions [undefined_fe_action^],
                '    Un_Defined_FE_Action', display_control, status);

        = nfc$unsupported_fe_action =
          NEXT unsupported_fe_action IN log_file_seq.sequence_pointer;
          put_display_line (format_effector_actions [unsupported_fe_action^],
                '    Un_Supported_FE_Action', display_control, status);

        = nfc$vertical_print_density =
          NEXT vertical_print_density IN log_file_seq.sequence_pointer;
          put_display_line (file_vpd_actions [vertical_print_density^],
                '    Vertical Print Density', display_control, status);

        = nfc$vfu_load_option =
          NEXT vfu_load_option IN log_file_seq.sequence_pointer;
          put_display_line (vfu_load_option_actions [vfu_load_option^],
                '    Device VFU Load Option', display_control, status);

        = nfc$vfu_load_procedure =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    VFU Load Image',
                display_control, status);


        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND file_assignment_msg;
?? TITLE := '    file assignment response msg', EJECT ??

    PROCEDURE file_assignment_response_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$file_assignment_resp_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$file_assign_resp_parameter,
        response: string (24),
        response_code: ^nft$file_assignment_response,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$system_file_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    System File Name',
                display_control, status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        = nfc$response_code =
          NEXT response_code IN log_file_seq.sequence_pointer;
          CASE response_code^ OF
          = nfc$file_assignment_accepted =
            response := 'File Assignment Accepted';
          = nfc$file_assignment_rejected =
            response := 'File Assignment Rejected';
          = nfc$btfsdi_title_not_translated =
            response := 'BTFS/DI Title Not Translated';
          CASEND;
          put_display_line (response, '    Response', display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND file_assignment_response_msg;
?? TITLE := '    file transfer status msg', EJECT ??

    PROCEDURE file_transfer_status_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$file_status_message

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        device_status: ^nft$device_status,
        file_position: ^nft$file_position,
        file_transfer_status: ^nft$file_transfer_status,
        input_bytes_transferred: ^nft$input_job_size,
        msg_length: integer,
        parameter: ^nft$file_status_message_param,
        str: ost$string,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        = nfc$device_status =
          NEXT device_status IN log_file_seq.sequence_pointer;
          put_display_line (device_statuses [device_status^],
                '    Device Status', display_control, status);

        = nfc$file_transfer_status_param =
          NEXT file_transfer_status IN log_file_seq.sequence_pointer;
          put_display_line (file_transfer_statuses [file_transfer_status^],
                '    File Transfer Status', display_control, status);

        = nfc$file_position =
          NEXT file_position IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (file_position^, 10, FALSE, str,
                status);
          put_display_line (str.value (1, str.size), '    File Position',
                display_control, status);

        = nfc$system_job_file_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    System Job/File Name',
                display_control, status);

        = nfc$system_id_family =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    System Family',
                display_control, status);

        = nfc$user_job_file_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    User Job/File Name',
                display_control, status);

        = nfc$actual_destination =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Actual Destination',
                display_control, status);

        = nfc$requested_destination =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Requested Destination',
                display_control, status);

        = nfc$input_bytes_transferred =
          NEXT input_bytes_transferred IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (input_bytes_transferred^, 10, FALSE,
                str, status);
          put_display_line (str.value (1, str.size),
                '    Input Bytes Transferred', display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND file_transfer_status_msg;
?? TITLE := '    get device status msg', EJECT ??

    PROCEDURE get_device_status_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$get_device_status_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$get_device_status_param,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND get_device_status_msg;
?? TITLE := '    get ntf rem sys names data', EJECT ??

    PROCEDURE get_ntf_rem_sys_names_data
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$ntf_get_rem_sys_names_data
*copyc nft$display_status_resp_codes

      VAR
        count: ^integer,
        i: integer,
        msg_length: integer,
        parameter: ^nft$ntf_get_rem_sys_names_data,
        remote_system_count: integer,
        remote_system_name_data: ^nft$ntf_remote_system_data,
        response: string (40),
        response_code: ^nft$display_status_resp_codes,
        str: ost$string,
        value_length: integer;

      remote_system_count := 0;
      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$response_code =
          NEXT response_code IN log_file_seq.sequence_pointer;
          CASE response_code^ OF
          = nfc$disp_msg_accepted =
            response := 'Message Accepted';
          = nfc$disp_no_io_station =
            response := 'Message Rejected, no io station';
          = nfc$disp_no_batch_device =
            response := 'Message Rejected, no batch device';
          = nfc$disp_unknown_file_name =
            response := 'Message Rejected, unknown file';
          CASEND;
          put_display_line (response, '    Response', display_control, status);

        = nfc$ntf_remote_system_count =
          NEXT count IN log_file_seq.sequence_pointer;
          remote_system_count := count^;
          clp$convert_integer_to_string (count^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Remote System Count',
                display_control, status);

        = nfc$ntf_remote_system_data =
          IF remote_system_count <> 0 THEN
            FOR i := 1 TO remote_system_count DO
              NEXT remote_system_name_data: [value_length -
                    #SIZE (nft$ntf_remote_system_data: [0])] IN
                    log_file_seq.sequence_pointer;
              put_display_line (remote_system_name_data^.name, '    Remote System', display_control,
                    status);
              put_display_line (remote_system_types [remote_system_name_data^.remote_system_type],
                    '    Remote System Type', display_control, status);
              put_display_line (remote_system_kinds [remote_system_name_data^.kind],
                    '    Remote System Kind', display_control, status);
              clp$convert_integer_to_string (remote_system_name_data^.route_back_position, 10, FALSE, str,
                    status);
              put_display_line (str.value (1, str.size),
                    '    Route Back Position', display_control, status);
              put_display_line (authority_levels [remote_system_name_data^.authority_level],
                    '    Authority Level', display_control, status);
            FOREND;
          IFEND;

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND get_ntf_rem_sys_names_data;
?? TITLE := '    get ntf remote system names msg', EJECT ??

    PROCEDURE get_ntf_remote_system_names_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$ntf_get_rem_sys_names_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        line_number: ^nft$ntf_logical_line_number,
        remote_system_type: ^nft$ntf_remote_system_type,
        msg_length: integer,
        parameter: ^nft$ntf_get_rem_sys_names_msg,
        remote_system_kind: ^nft$ntf_remote_system_kind,
        str: ost$string,
        value_length: integer;

      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$ntf_remote_system_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Remote System', display_control,
                status);

        = nfc$ntf_logical_line_number =
          NEXT line_number IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (line_number^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Logical Line Number',
                display_control, status);

        = nfc$ntf_remote_system_kind =
          NEXT remote_system_kind IN log_file_seq.sequence_pointer;
          put_display_line (remote_system_kinds [remote_system_kind^], '    Remote System Kind',
                display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND get_ntf_remote_system_names_msg;
?? TITLE := '    get queue entry msg', EJECT ??

    PROCEDURE get_queue_entry_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$get_queue_entry_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$get_queue_entry_parameter,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$system_file_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    File Name', display_control,
                status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND get_queue_entry_msg;
?? TITLE := '    get queue entry list msg', EJECT ??

    PROCEDURE get_queue_entry_list_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$get_q_entry_list_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        entries: ^nft$all_or_top_10_q_entries,
        msg_length: integer,
        optimize_queue_list_param: ^nft$optimize_list,
        parameter: ^nft$get_q_entry_list_msg_param,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$all_or_top_ten =
          NEXT entries IN log_file_seq.sequence_pointer;
          put_display_line (all_or_top_10 [entries^], '   All or Top 10',
                display_control, status);

        = nfc$optimize_queue_list =
          NEXT optimize_queue_list_param IN log_file_seq.sequence_pointer;
          IF (optimize_queue_list_param^ = nfc$do_optimize) THEN
            put_display_line ('Yes', '    Optimize Queue List', display_control, status);
          ELSE
            put_display_line ('No', '    Optimize Queue List', display_control, status);
          IFEND;

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND get_queue_entry_list_msg;
?? TITLE := '    get queue status msg', EJECT ??

    PROCEDURE get_queue_status_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$get_station_status_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$get_station_status_param,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND get_queue_status_msg;
?? TITLE := '    get station status msg', EJECT ??

    PROCEDURE get_station_status_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$get_station_status_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        optimize_device_list_param: ^nft$optimize_list,
        parameter: ^nft$get_station_status_param,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$optimize_device_list =
          NEXT optimize_device_list_param IN log_file_seq.sequence_pointer;
          IF (optimize_device_list_param^ = nfc$do_optimize) THEN
            put_display_line ('Yes', '    Optimize Device List', display_control, status);
          ELSE
            put_display_line ('No', '    Optimize Device List', display_control, status);
          IFEND;

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND get_station_status_msg;
?? TITLE := '    operator message', EJECT ??

    PROCEDURE operator_message
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$operator_message

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$operator_message_parameter,
        text: ^string ( * ),
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        = nfc$text =
          NEXT text: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (text^, '    Text', display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND operator_message;
?? TITLE := '    position file msg to di', EJECT ??

    PROCEDURE position_file_msg_to_di
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copy nft$di_position_file_message

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$position_file_di_msg_param,
        position_parameters: ^string ( * ),
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        = nfc$position_parameters =
          NEXT position_parameters: [value_length] IN
                log_file_seq.sequence_pointer;
          put_display_line (position_parameters^, '    Position Parameters',
                display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND position_file_msg_to_di;
?? TITLE := '    position file msg', EJECT ??

    PROCEDURE position_file_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$position_file_msg

      VAR
        ascii_string: ^string ( * <= nfc$posf_max_string_length),
        direction: ^nft$position_file_direction,
        location_count: ^nft$position_file_locate_count,
        msg_length: integer,
        parameter: ^nft$position_file_msg_parameter,
        preview_count: ^nft$position_file_preview_count,
        start_position: ^nft$position_file_from_position,
        str: ost$string,
        units: ^nft$position_file_units,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        = nfc$location_integer =
          NEXT location_count IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (location_count^, 10, FALSE, str,
                status);
          put_display_line (str.value (1, str.size), '    Location Count',
                display_control, status);

        = nfc$location_string_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    String 1', display_control,
                status);

        = nfc$location_string_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    String 2', display_control,
                status);

        = nfc$units =
          NEXT units IN log_file_seq.sequence_pointer;

        = nfc$direction =
          NEXT direction IN log_file_seq.sequence_pointer;

        = nfc$starting_position =
          NEXT start_position IN log_file_seq.sequence_pointer;

        = nfc$preview_line_count =
          NEXT preview_count IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (preview_count^, 10, FALSE, str,
                status);
          put_display_line (str.value (1, str.size), '    Preview Line Count',
                display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND position_file_msg;
?? TITLE := '    queue entry data msg', EJECT ??

    PROCEDURE queue_entry_data_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$queue_entry_data_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        copies: ^nft$copies,
        date: ost$date,
        device_type: ^nft$device_type,
        file_length: ^nft$file_size,
        msg_length: integer,
        output_data_mode: ^nft$output_data_mode,
        output_state: ^nft$file_transfer_state,
        output_state_string: string (31),
        page_format: ^amt$page_format,
        page_length: ^nft$page_length,
        page_width: ^nft$page_width,
        parameter: ^nft$queue_entry_msg_parameter,
        priority: ^nft$priority,
        q_position: ^integer,
        response_code: ^nft$display_status_resp_codes,
        response: string (33),
        str: ost$string,
        time: ost$time,
        time_enqueued: ^ost$date_time,
        value_length: integer,
        vertical_print_density: ^nft$file_vertical_print_density,
        z_byte: ^0 .. 0ff(16);

      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (msg_length > 0) DO
        WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter)
              DO
          msg_length := msg_length - 1;
          IF parameter^.length_indicated THEN
            get_parameter_value_length (log_file_seq, msg_length, value_length,
                  status);
            msg_length := msg_length - value_length;
          ELSE
            value_length := 1;
            msg_length := msg_length - 1;
          IFEND;

          CASE parameter^.param OF
          = nfc$io_station_name =
            NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
            put_display_line (ascii_string^, '    Station', display_control,
                  status);

          = nfc$system_file_name =
            NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
            put_display_line (ascii_string^, '    System File Name',
                  display_control, status);

          = nfc$response_code =
            NEXT response_code IN log_file_seq.sequence_pointer;
            CASE response_code^ OF
            = nfc$disp_msg_accepted =
              response := 'Message Accepted';
            = nfc$disp_no_io_station =
              response := 'Message Rejected, no io station';
            = nfc$disp_no_batch_device =
              response := 'Message Rejected, no batch device';
            = nfc$disp_unknown_file_name =
              response := 'Message Rejected, unknown file';
            CASEND;
            put_display_line (response, '    Response', display_control,
                  status);

          = nfc$user_file_name =
            NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
            put_display_line (ascii_string^, '    User File Name',
                  display_control, status);

          = nfc$time_enqueued =
            NEXT time_enqueued IN log_file_seq.sequence_pointer;
            pmp$format_compact_date (time_enqueued^, osc$iso_date, date,
                  status);
            pmp$format_compact_time (time_enqueued^, osc$hms_time, time,
                  status);

          = nfc$position_in_queue =
            NEXT q_position IN log_file_seq.sequence_pointer;
            clp$convert_integer_to_string (q_position^, 10, FALSE, str,
                  status);
            put_display_line (str.value (1, str.size), '    Position in Q',
                  display_control, status);

          = nfc$priority =
            NEXT priority IN log_file_seq.sequence_pointer;
            clp$convert_integer_to_string (priority^, 10, FALSE, str, status);
            put_display_line (str.value (1, str.size), '    Priority',
                  display_control, status);

          = nfc$copies =
            NEXT copies IN log_file_seq.sequence_pointer;
            clp$convert_integer_to_string (copies^, 10, FALSE, str, status);
            put_display_line (str.value (1, str.size), '    Copies',
                  display_control, status);

          = nfc$create_job_family_name =
            NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
            put_display_line (ascii_string^, '    User Family Name',
                  display_control, status);

          = nfc$create_system_job_name =
            NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
            put_display_line (ascii_string^, '    System Job Name',
                  display_control, status);

          = nfc$create_user_job_name =
            NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
            put_display_line (ascii_string^, '    User Job Name',
                  display_control, status);

          = nfc$destination_name =
            NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
            put_display_line (ascii_string^, '    Destination',
                  display_control, status);

          = nfc$device_type =
            NEXT device_type IN log_file_seq.sequence_pointer;
            put_display_line (device_types [device_type^], '    Device Type',
                  display_control, status);

          = nfc$file_length =
            NEXT file_length IN log_file_seq.sequence_pointer;
            clp$convert_integer_to_string (file_length^, 10, FALSE, str,
                  status);
            put_display_line (str.value (1, str.size), '    File Length',
                  display_control, status);

          = nfc$output_data_mode =
            NEXT output_data_mode IN log_file_seq.sequence_pointer;
            put_display_line (output_data_modes [output_data_mode^],
                  '    Output Data Mode', display_control, status);

          = nfc$device_name =
            NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
            put_display_line (ascii_string^, '    Device', display_control,
                  status);

          = nfc$external_characteristics =
            NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
            put_display_line (ascii_string^, '    External Characteristics',
                  display_control, status);

          = nfc$forms_code =
            NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
            put_display_line (ascii_string^, '    Forms Code', display_control,
                  status);

          = nfc$page_format =
            NEXT page_format IN log_file_seq.sequence_pointer;
            put_display_line (page_formats [page_format^], '    Page Format',
                  display_control, status);

          = nfc$page_length =
            NEXT page_length IN log_file_seq.sequence_pointer;
            clp$convert_integer_to_string (page_length^, 10, FALSE, str,
                  status);
            put_display_line (str.value (1, str.size), '    Page Length',
                  display_control, status);

          = nfc$page_width =
            NEXT page_width IN log_file_seq.sequence_pointer;
            clp$convert_integer_to_string (page_width^, 10, FALSE, str,
                  status);
            put_display_line (str.value (1, str.size), '    Page Width',
                  display_control, status);

          = nfc$vertical_print_density =
            NEXT vertical_print_density IN log_file_seq.sequence_pointer;
            put_display_line (file_vpd_actions [vertical_print_density^],
                  '    Vertical_Print_Density', display_control, status);

          = nfc$vfu_load_procedure =
            NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
            put_display_line (ascii_string^, '    VFU Load Image',
                  display_control, status);

          = nfc$creating_user_name =
            NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
            put_display_line (ascii_string^, '    User Name', display_control,
                  status);

          = nfc$scfs_output_status =
            NEXT output_state IN log_file_seq.sequence_pointer;
            put_display_line (file_transfer_states [output_state^], '    SCFS Output State', display_control,
                  status);

          ELSE

{           ERROR

            NEXT byte_array: [1 .. value_length] IN log_file_seq.sequence_pointer;

          CASEND;
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          IF msg_length > 0 THEN
            NEXT parameter IN log_file_seq.sequence_pointer;
            IF (msg_length = 1) THEN
              IF (parameter^.param = nfc$queue_entry_data_continues) THEN
                put_display_line ('', '    Queue Entry Data Cont.', display_control, status);
              IFEND;
              parameter := NIL;
              msg_length := 0;
            IFEND;
          IFEND;
        WHILEND;
        IF (msg_length > 0) AND (parameter^.param = nfc$null_parameter) THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
          msg_length := msg_length - 1;
          put_display_line (' ', '    (Null)', display_control, status);
        IFEND;
      WHILEND;

    PROCEND queue_entry_data_msg;
?? TITLE := '    queue entry list data msg', EJECT ??

    PROCEDURE queue_entry_list_data_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$q_entry_list_data_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        file_and_priority: ^nft$file_and_priority,
        file_count: ^nft$file_count,
        msg_length: integer,
        parameter: ^nft$q_entry_list_data_msg_param,
        response_code: ^nft$display_status_resp_codes,
        response: string (33),
        str: ost$string,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$response_code =
          NEXT response_code IN log_file_seq.sequence_pointer;
          CASE response_code^ OF
          = nfc$disp_msg_accepted =
            response := 'Message Accepted';
          = nfc$disp_no_io_station =
            response := 'Message Rejected, no io station';
          = nfc$disp_no_batch_device =
            response := 'Message Rejected, no batch device';
          = nfc$disp_unknown_file_name =
            response := 'Message Rejected, unknown file';
          CASEND;
          put_display_line (response, '    Response', display_control, status);

        = nfc$number_of_files =
          NEXT file_count IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (file_count^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Number of Files',
                display_control, status);

        = nfc$sys_file_and_priority =
          NEXT file_and_priority: [value_length - #SIZE (nft$priority)] IN
                log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (file_and_priority^.priority, 10,
                FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Priority',
                display_control, status);
          put_display_line (file_and_priority^.name, '    System File Name',
                display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND queue_entry_list_data_msg;
?? TITLE := '    queue status data msg', EJECT ??

    PROCEDURE queue_status_data_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

?? NEWTITLE := '      display q status data', EJECT ??

      PROCEDURE display_q_status_data
        (    q_status_data: nft$q_status_data;
         VAR display_control: clt$display_control;
         VAR status: ost$status);

        VAR
          str: ost$string;

        put_display_line (q_status_data.name, '      Name', display_control,
              status);

        clp$convert_integer_to_string (q_status_data.file_count, 10, FALSE,
              str, status);
        put_display_line (str.value (1, str.size), '    File Count',
              display_control, status);

        clp$convert_integer_to_string (q_status_data.total_size, 10, FALSE,
              str, status);
        put_display_line (str.value (1, str.size), '    Total Size',
              display_control, status);

        clp$convert_integer_to_string (q_status_data.oldest_age, 10, FALSE,
              str, status);
        put_display_line (str.value (1, str.size), '    Oldest File Age',
              display_control, status);

        clp$convert_integer_to_string (q_status_data.average_age, 10, FALSE,
              str, status);
        put_display_line (str.value (1, str.size), '    Average Age',
              display_control, status);

        put_display_line (q_status_data.operator_name, '      Operator Name',
              display_control, status);

        put_display_line (q_status_data.operator_family,
              '      Operator Family', display_control, status);

      PROCEND display_q_status_data;
?? OLDTITLE, EJECT ??
*copyc nft$queue_status_data_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        count: ^nft$file_count,
        destination_count: nft$file_count,
        device_count: nft$file_count,
        device_types_count: nft$file_count,
        ext_chars_count: nft$file_count,
        forms_code_count: nft$file_count,
        i: integer,
        msg_length: integer,
        parameter: ^nft$queue_status_msg_parameter,
        q_status_data: ^nft$q_status_data,
        response_code: ^nft$display_status_resp_codes,
        response: string (33),
        str: ost$string,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$file_count =
          NEXT count IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (count^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    File Count',
                display_control, status);

        = nfc$response_code =
          NEXT response_code IN log_file_seq.sequence_pointer;
          CASE response_code^ OF
          = nfc$disp_msg_accepted =
            response := 'Message Accepted';
          = nfc$disp_no_io_station =
            response := 'Message Rejected, no io station';
          = nfc$disp_no_batch_device =
            response := 'Message Rejected, no batch device';
          = nfc$disp_unknown_file_name =
            response := 'Message Rejected, unknown file';
          CASEND;
          put_display_line (response, '    Response', display_control, status);

        = nfc$ext_chars_count =
          NEXT count IN log_file_seq.sequence_pointer;
          ext_chars_count := count^;
          clp$convert_integer_to_string (count^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Ext Chars Count',
                display_control, status);

        = nfc$ext_char_and_files =
          FOR i := 1 TO ext_chars_count DO
            NEXT q_status_data: [value_length -
                  nfc$fixed_q_status_data_length] IN
                  log_file_seq.sequence_pointer;
            display_q_status_data (q_status_data^, display_control, status);
          FOREND;

        = nfc$forms_code_count =
          NEXT count IN log_file_seq.sequence_pointer;
          forms_code_count := count^;
          clp$convert_integer_to_string (count^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Forms Code Count',
                display_control, status);

        = nfc$forms_code_and_files =
          FOR i := 1 TO forms_code_count DO
            NEXT q_status_data: [value_length -
                  nfc$fixed_q_status_data_length] IN
                  log_file_seq.sequence_pointer;
            display_q_status_data (q_status_data^, display_control, status);
          FOREND;

        = nfc$device_count =
          NEXT count IN log_file_seq.sequence_pointer;
          device_count := count^;
          clp$convert_integer_to_string (count^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Device Count',
                display_control, status);

        = nfc$device_names_and_files =
          FOR i := 1 TO device_count DO
            NEXT q_status_data: [value_length -
                  nfc$fixed_q_status_data_length] IN
                  log_file_seq.sequence_pointer;
            display_q_status_data (q_status_data^, display_control, status);
          FOREND;

        = nfc$destination_count =
          NEXT count IN log_file_seq.sequence_pointer;
          destination_count := count^;
          clp$convert_integer_to_string (count^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Destination Count',
                display_control, status);

        = nfc$destinations_and_files =
          FOR i := 1 TO destination_count DO
            NEXT q_status_data: [value_length -
                  nfc$fixed_q_status_data_length] IN
                  log_file_seq.sequence_pointer;
            display_q_status_data (q_status_data^, display_control, status);
          FOREND;

        = nfc$device_type_count =
          NEXT count IN log_file_seq.sequence_pointer;
          device_types_count := count^;
          clp$convert_integer_to_string (count^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Device Type Count',
                display_control, status);

        = nfc$device_types_and_files =
          FOR i := 1 TO device_types_count DO
            NEXT q_status_data: [value_length -
                  nfc$fixed_q_status_data_length] IN
                  log_file_seq.sequence_pointer;
            display_q_status_data (q_status_data^, display_control, status);
          FOREND;

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND queue_status_data_msg;
?? TITLE := '    select file msg', EJECT ??

    PROCEDURE select_file_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$select_file_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$select_file_parameter,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$system_file_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    System File Name',
                display_control, status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND select_file_msg;
?? TITLE := '    select file response msg', EJECT ??

    PROCEDURE select_file_response_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$select_file_response_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$select_file_resp_parameter,
        response: string (39),
        response_code: ^nft$select_file_response,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$system_file_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    System File Name',
                display_control, status);

        = nfc$response_code =
          NEXT response_code IN log_file_seq.sequence_pointer;
          CASE response_code^ OF
          = nfc$self_msg_accepted =
            response := 'Message Accepted';
          = nfc$self_msg_unknown_ios =
            response := 'Message Rejected, no io station';
          = nfc$self_msg_unknown_device =
            response := 'Message Rejected, no device';
          = nfc$self_msg_unknown_file =
            response := 'Message Rejected, no file';
          = nfc$self_file_already_printing =
            response := 'Message Rejected, file already printing';
          = nfc$self_wrong_device_type =
            response := 'Message Rejected, wrong device type';
          = nfc$self_duplicate_file_name =
            response := 'Message Rejected, file must be unique';
          CASEND;
          put_display_line (response, '    Response', display_control, status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND select_file_response_msg;
?? TITLE := '    send ntf remote command', EJECT ??

    PROCEDURE send_ntf_remote_command
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$ntf_send_remote_comm_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        command_kind: ^nft$ntf_command_kind,
        command_text: ^string ( * <= nfc$ntf_max_command_text_size),
        error: ost$error,
        line_number: ^nft$ntf_logical_line_number,
        msg_length: integer,
        parameter: ^nft$ntf_send_remote_comm_msg,
        str: ost$string,
        text: ^string ( * <= nfc$ntf_max_command_text_size),
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$ntf_remote_system_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Remote System', display_control,
                status);

        = nfc$ntf_console_stream_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Remote System', display_control,
                status);

        = nfc$ntf_logical_line_number =
          NEXT line_number IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (line_number^, 10, FALSE, str, status);
          put_display_line (str.value (1, str.size), '    Logical Line Number',
                display_control, status);

        = nfc$ntf_command_kind =
          NEXT command_kind IN log_file_seq.sequence_pointer;
          put_display_line (command_kinds[command_kind^], '    Command Kind',
                display_control, status);

        = nfc$ntf_command_text =
          NEXT command_text: [value_length] IN log_file_seq.sequence_pointer;
          PUSH text: [value_length];
          osp$translate_bytes (command_text, value_length, text, value_length,
                ^osv$ebcdic_to_ascii, error);
{         put_display_line (text^, '    Command Text', display_control, status);
          put_display_line ('*EBCDIC Codes*', '    Command Text', display_control, status);

        = nfc$ntf_system_identifier =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    System ID', display_control,
                status);

        = nfc$ntf_family_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Family Name', display_control,
                status);

        = nfc$ntf_user_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    User Name', display_control,
                status);

        = nfc$ntf_operator_identifier =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    NTF Operator ID', display_control,
                status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND send_ntf_remote_command;
?? TITLE := '    send ntf remote command resp', EJECT ??

    PROCEDURE send_ntf_remote_command_resp
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$ntf_send_remote_comm_resp
*copyc nft$ntf_send_rc_response_codes

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        command_kind: ^nft$ntf_command_kind,
        msg_length: integer,
        parameter: ^nft$ntf_send_remote_comm_resp,
        response: string (39),
        response_code: ^nft$ntf_send_rc_response_codes,
        signon_status: ^nft$device_status,
        str: ost$string,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$ntf_remote_system_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Remote System', display_control,
                status);

        = nfc$ntf_console_stream_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Remote System', display_control,
                status);

        = nfc$ntf_command_kind =
          NEXT command_kind IN log_file_seq.sequence_pointer;
          put_display_line (command_kinds[command_kind^], '    Command Kind',
                display_control, status);

        = nfc$ntf_signon_status =
          NEXT signon_status IN log_file_seq.sequence_pointer;
          put_display_line (device_statuses [signon_status^],
                '    Signon Status', display_control, status);

        = nfc$response_code =
          NEXT response_code IN log_file_seq.sequence_pointer;
          CASE response_code^ OF
          = nfc$message_accepted =
            response := 'Message Accepted';
          = nfc$ntf_incorrect_signon_status =
            response := 'Message Rejected, incorrect signon status';
          = nfc$ntf_remote_system_not_found =
            response := 'Message Rejected, Remote System not found';
          = nfc$ntf_batch_stream_not_found =
            response := 'Message Rejected, no Batch Stream';
          = nfc$ntf_client_not_found =
            response := 'Message Rejected, no client';
          = nfc$ntf_no_users_found =
            response := 'Message Rejected, no users';
          CASEND;
          put_display_line (response, '    Response', display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND send_ntf_remote_command_resp;
?? TITLE := '    start batch device msg', EJECT ??

    PROCEDURE start_batch_device_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$start_batch_device_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$start_bd_message_parameter,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND start_batch_device_msg;
?? TITLE := '    start io station msg', EJECT ??

    PROCEDURE start_io_station_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$start_io_station_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$start_ios_message_parameter,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$user_identity =
          NEXT ascii_string: [osc$max_name_size] IN
                log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    User', display_control,
                status);
          NEXT ascii_string: [osc$max_name_size] IN
                log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Family', display_control,
                status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND start_io_station_msg;
?? TITLE := '    station status data msg', EJECT ??

    PROCEDURE station_status_data_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$station_status_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        destination_unavail_action: ^nft$destination_unavail_actions,
        device_count: ^integer,
        device_status_data: ^nft$device_status_data,
        file_ack: ^boolean,
        fixed_size: integer,
        io_station_usage: ^nft$io_station_usage,
        msg_length: integer,
        parameter: ^nft$station_status_msg_param,
        pm_message_action: ^nft$pm_message_actions,
        q_file_count: ^integer,
        response: string (33),
        response_code: ^nft$display_status_resp_codes,
        str: ost$string,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$response_code =
          NEXT response_code IN log_file_seq.sequence_pointer;
          CASE response_code^ OF
          = nfc$disp_msg_accepted =
            response := 'Message Accepted';
          = nfc$disp_no_io_station =
            response := 'Message Rejected, no io station';
          = nfc$disp_no_batch_device =
            response := 'Message Rejected, no batch device';
          = nfc$disp_unknown_file_name =
            response := 'Message Rejected, unknown file';
          CASEND;
          put_display_line (response, '    Response', display_control, status);

        = nfc$control_facility =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Control Facility',
                display_control, status);

        = nfc$number_of_files_queued =
          ;
          NEXT q_file_count IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (q_file_count^, 10, FALSE, str,
                status);
          put_display_line (str.value (1, str.size),
                '    Number of Files Queued', display_control, status);

        = nfc$station_usage =
          NEXT io_station_usage IN log_file_seq.sequence_pointer;
          put_display_line (station_usages [io_station_usage^],
                '    Station_Usage', display_control, status);

        = nfc$file_acknowledgement =
          NEXT file_ack IN log_file_seq.sequence_pointer;
          put_display_line (boolean_values [file_ack^],
                '    File Acknowledgement', display_control, status);

        = nfc$count_of_devices =
          NEXT device_count IN log_file_seq.sequence_pointer;
          clp$convert_integer_to_string (device_count^, 10, FALSE, str,
                status);
          put_display_line (str.value (1, str.size), '    Number of Devices',
                display_control, status);

        = nfc$device_name_status =
          fixed_size := #SIZE (nft$device_status) +
                #SIZE (nft$file_transfer_status) + #SIZE (nft$device_type);
          NEXT device_status_data: [value_length - fixed_size] IN
                log_file_seq.sequence_pointer;
          put_display_line (device_statuses [device_status_data^.
                device_status], '    Device Status', display_control, status);
          put_display_line (device_types [device_status_data^.device_type],
                '    Device Type', display_control, status);
          put_display_line (file_transfer_statuses
                [device_status_data^.file_xfer_status],
                '    File Transfer Status', display_control, status);
          put_display_line (device_status_data^.name, '    Device',
                display_control, status);

        = nfc$req_console_device =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Required Operator Device',
                display_control, status);

        = nfc$io_station_alias_1 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station Alias 1',
                display_control, status);

        = nfc$io_station_alias_2 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station Alias 2',
                display_control, status);

        = nfc$io_station_alias_3 =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station Alias 3',
                display_control, status);

        = nfc$destination_unavail_action =
          NEXT destination_unavail_action IN log_file_seq.sequence_pointer;
          put_display_line (destination_unavail_actions
                [destination_unavail_action^], '    Dest Unavail Action',
                display_control, status);

        = nfc$pm_message_action =
          NEXT pm_message_action IN log_file_seq.sequence_pointer;
          put_display_line (pm_message_actions [pm_message_action^],
                '    PM Message Action', display_control, status);
        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND station_status_data_msg;
?? TITLE := '    stop batch device msg', EJECT ??

    PROCEDURE stop_batch_device_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$stop_batch_device_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        disposition: ^nft$file_disposition,
        msg_length: integer,
        parameter: ^nft$stop_bd_message_parameter,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        = nfc$file_disposition =
          NEXT disposition IN log_file_seq.sequence_pointer;
          put_display_line (file_dispositions [disposition^],
                '    File Disposition', display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND stop_batch_device_msg;
?? TITLE := '    stop io station msg', EJECT ??

    PROCEDURE stop_io_station_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$stop_io_station_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$stop_ios_message_parameter,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND stop_io_station_msg;
?? TITLE := '    suppress carriage control msg', EJECT ??

    PROCEDURE suppress_carriage_control_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$suppress_carriage_cntrl_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        format_control: ^nft$suppress_carriage_control,
        msg_length: integer,
        parameter: ^nft$suppress_cc_msg_parameter,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        = nfc$suppress_format_control =
          NEXT format_control IN log_file_seq.sequence_pointer;

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN
                log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND suppress_carriage_control_msg;
?? TITLE := '    terminate_queue_output_msg', EJECT ??

    PROCEDURE terminate_queue_output_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$terminate_queued_output_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        msg_length: integer,
        parameter: ^nft$term_queue_output_parameter,
        value_length: integer;

      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (msg_length > 0) AND (parameter^.param <> nfc$null_parameter) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control, status);

        = nfc$system_user_file_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    System/User File Name',  display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        ELSEIF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND terminate_queue_output_msg;
?? TITLE := '    terminate_queue_output_resp_msg', EJECT ??

    PROCEDURE terminate_queue_output_resp_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$terminate_q_output_resp_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        file_status_code: ^nft$terqo_file_status_codes,
        msg_length: integer,
        parameter: ^nft$term_q_output_resp_param,
        response: ^nft$terqo_file_status_codes,
        value_length: integer;

      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (msg_length > 0) AND (parameter^.param <> nfc$null_parameter) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control, status);

        = nfc$system_user_file_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    System/User File Name', display_control, status);

        = nfc$file_status_code =
          NEXT file_status_code IN log_file_seq.sequence_pointer;
          put_display_line (terqo_file_status_codes [file_status_code^], '    File_Status_Code',
              display_control, status);

        ELSE

{         ERROR

          NEXT byte_array: [1 .. value_length] IN log_file_seq.sequence_pointer;

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        ELSEIF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND terminate_queue_output_resp_msg;
?? TITLE := '    terminate transfer msg', EJECT ??

    PROCEDURE terminate_transfer_msg
      (    message_length: integer;
       VAR display_control: clt$display_control;
       VAR log_file_seq: amt$segment_pointer;
       VAR status: ost$status);

*copyc nft$terminate_transfer_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        disposition: ^nft$file_disposition,
        msg_length: integer,
        parameter: ^nft$terminate_xfer_msg_param,
        value_length: integer;


      msg_length := message_length - 1;
      NEXT parameter IN log_file_seq.sequence_pointer;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          get_parameter_value_length (log_file_seq, msg_length, value_length,
                status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Station', display_control,
                status);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN log_file_seq.sequence_pointer;
          put_display_line (ascii_string^, '    Device', display_control,
                status);

        = nfc$file_disposition =
          NEXT disposition IN log_file_seq.sequence_pointer;
          put_display_line (file_dispositions [disposition^],
                '    File Disposition', display_control, status);

        ELSE

{         ERROR

        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF msg_length > 0 THEN
          NEXT parameter IN log_file_seq.sequence_pointer;
        IFEND;
      WHILEND;

    PROCEND terminate_transfer_msg;
?? OLDTITLE, EJECT ??

    CONST
      ntf_operator = 'NTF Operator Connection',
      ntf_ve = 'NTF/VE Connection',
      operator = 'Operator Connection',
      scf_di = 'SCF/DI Connection',
      scf_ve = 'SCF/VE Connection',
      scfs_ve = 'SCFS Connection',
      unknown = 'Unknown Connection';

    VAR
      address: ^nft$connection_address,
      array_length: ^integer,
      byte_array: ^array [1 .. * ] of 0 .. 0ff(16),
      connect_msg: string (40),
      connection_kind: ^nft$connection_kind,
      log_time: ^ost$time,
      message_kind: ^nft$message_kind,
      msg_length: integer,
      xns_address: ^nft$network_address;


    NEXT connection_kind IN log_file_seq.sequence_pointer;
    IF pvt [p$format].value^.keyword_value = 'R131' THEN
      NEXT xns_address IN log_file_seq.sequence_pointer;
      PUSH address;
      address^.kind := nac$internet_address;
      address^.internet_address := xns_address^;
    ELSE
      NEXT address IN log_file_seq.sequence_pointer;
    IFEND;
    NEXT log_time IN log_file_seq.sequence_pointer;
    NEXT array_length IN log_file_seq.sequence_pointer;
    NEXT message_kind IN log_file_seq.sequence_pointer;

    CASE connection_kind^ OF
    = nfc$unknown_connection =
      connect_msg := unknown;
    = nfc$scfdi_connection =
      connect_msg := scf_di;
    = nfc$scfve_connection =
      connect_msg := scf_ve;
    = nfc$operator_connection =
      connect_msg := operator;
    = nfc$scfsve_connection =
      connect_msg := scfs_ve;
    = nfc$ntfve_connection =
      connect_msg := ntf_ve;
    = nfc$ntf_operator_connection =
      connect_msg := ntf_operator;
    CASEND;

    IF pvt [p$display_option].value^.keyword_value = 'BRIEF' THEN
      CASE message_kind^ OF
      = nfc$device_status_data,
        nfc$get_device_status,
        nfc$get_queue_entry,
        nfc$get_queue_entry_list,
        nfc$get_queue_status,
        nfc$get_station_status,
        nfc$queue_entry_data,
        nfc$queue_entry_list_data,
        nfc$queue_status_data,
        nfc$station_status_data =
        display_message := FALSE;
      ELSE
        display_message := TRUE;
      CASEND;
    ELSE
      display_message := TRUE;
    IFEND;

    IF display_message THEN
      clp$put_display (display_control, log_time^.millisecond, clc$no_trim, status);
      display_connection_address (connect_msg, address, display_control, status);
      clp$put_partial_display (display_control, message_kind_str [message_kind^], clc$trim,
            amc$start, status);
      clp$put_partial_display (display_control, ' Message', clc$no_trim, amc$terminate, status);
    IFEND;

    CASE message_kind^ OF
    = nfc$add_file_availability, nfc$modify_file_availability,
          nfc$delete_file_availability =
      display_file_availability_msg (array_length^, display_control,
            log_file_seq, status);

    = nfc$file_assignment =
      file_assignment_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$file_assignment_response =
      file_assignment_response_msg (array_length^, display_control,
            log_file_seq, status);

    = nfc$delete_destination =
      delete_destination_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$btf_ve_status =
      btf_ve_status_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$add_io_station =
      add_io_station_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$delete_io_station =
      delete_io_station_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$add_batch_device =
      add_batch_device_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$batch_device_status =
      batch_device_status_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$file_transfer_status =
      file_transfer_status_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$delete_batch_device =
      delete_batch_device_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$btfs_di_status =
      btfs_di_status_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$add_io_station_resp =
      add_io_station_resp_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$delete_io_station_resp =
      delete_io_station_resp_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$start_io_station =
      start_io_station_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$stop_io_station =
      stop_io_station_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$switch_io_station =
      ;

    = nfc$position_file_di =
      position_file_msg_to_di (array_length^, display_control, log_file_seq,
            status);

    = nfc$add_batch_device_resp =
      add_batch_device_resp_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$delete_batch_device_resp =
      delete_batch_device_resp_msg (array_length^, display_control,
            log_file_seq, status);

    = nfc$start_batch_device =
      start_batch_device_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$stop_batch_device =
      stop_batch_device_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$suppress_carriage_control =
      suppress_carriage_control_msg (array_length^, display_control,
            log_file_seq, status);

    = nfc$terminate_transfer =
      terminate_transfer_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$change_batch_device_attr =
      change_batch_device_attributes (array_length^, display_control,
            log_file_seq, status);

    = nfc$change_bat_device_attr_resp, nfc$start_batch_device_resp,
          nfc$stop_batch_device_resp, nfc$terminate_transfer_resp,
          nfc$position_file_resp, nfc$suppress_carriage_cntrl_rsp =
      msg_length := array_length^;
      device_control_resp_msg (msg_length, display_control, log_file_seq,
            status);
      IF message_kind^ = nfc$change_bat_device_attr_resp THEN
        change_batch_device_attr_resp (msg_length, display_control,
              log_file_seq, status);
      IFEND;

    = nfc$switch_control_facility =
      ;

    = nfc$operator_message =
      operator_message (array_length^, display_control, log_file_seq, status);

    = nfc$add_user =
      add_user_msg (array_length^, display_control, log_file_seq, status);

    = nfc$add_user_resp =
      add_user_resp_msg (array_length^, display_control, log_file_seq, status);

    = nfc$select_file =
      select_file_msg (array_length^, display_control, log_file_seq, status);

    = nfc$select_file_response =
      select_file_response_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$position_file_sou =
      position_file_msg (array_length^, display_control, log_file_seq, status);

    = nfc$get_station_status =
      get_station_status_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$station_status_data =
      station_status_data_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$get_device_status =
      get_device_status_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$device_status_data =
      device_status_data_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$get_queue_status =
      get_queue_status_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$queue_status_data =
      queue_status_data_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$get_queue_entry_list =
      get_queue_entry_list_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$queue_entry_list_data =
      queue_entry_list_data_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$get_queue_entry =
      get_queue_entry_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$queue_entry_data =
      queue_entry_data_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$add_ntf_acc_rem_sys_resp =
      add_acc_remote_system_resp_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$get_ntf_rem_sys_names_msg =
      get_ntf_remote_system_names_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$get_ntf_rem_sys_names_data =
      get_ntf_rem_sys_names_data (array_length^, display_control, log_file_seq,
            status);

    = nfc$get_ntf_rem_sys_opts_msg =
      ntf_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$get_ntf_rem_sys_opts_data =
      ntf_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$send_ntf_remote_comm_msg =
      send_ntf_remote_command (array_length^, display_control, log_file_seq, status);

    = nfc$send_ntf_remote_comm_resp =
      send_ntf_remote_command_resp (array_length^, display_control, log_file_seq, status);

    = nfc$get_ntf_rem_sys_stat_msg =
      ntf_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$get_ntf_rem_sys_stat_data =
      ntf_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$add_ntf_remote_sys_msg =
      add_remote_system_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$add_ntf_acc_rem_sys_msg =
      add_accessible_remote_sys_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$delete_ntf_remote_sys_msg =
      ntf_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$add_ntf_remote_sys_resp =
      add_remote_system_resp_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$delete_ntf_remote_sys_resp =
      ntf_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$delete_ntf_user_msg =
      ntf_msg (array_length^, display_control, log_file_seq,
            status);

    = nfc$delete_ntf_user_resp =
      delete_ntf_user_response (array_length^, display_control, log_file_seq,
            status);

    = nfc$terminate_queue_output =
      terminate_queue_output_msg (array_length^, display_control, log_file_seq, status);

    = nfc$terminate_queue_output_resp =
      terminate_queue_output_resp_msg (array_length^, display_control, log_file_seq, status);

    ELSE
      ;
    CASEND;

  PROCEND display_connection_message;
?? TITLE := '  display scfs log', EJECT ??

  PROCEDURE display_scfs_log
    (VAR display_control: clt$display_control;
     VAR log_file_seq: amt$segment_pointer;
     VAR status: ost$status);

    CONST
      accepted = 'ACC',
      msg = 'MSG',
      ntf_operator = 'NTF Operator Connection',
      ntf_ve = 'NTF/VE Connection',
      operator = 'Operator Connection',
      scf_di = 'SCF/DI Connection',
      scf_ve = 'SCF/VE Connection',
      scfs_ve = 'SCFS Connection',
      rejected = 'REJ',
      terminated = 'TER',
      unknown = 'Unknown Connection';

    VAR
      address: ^nft$connection_address,
      connect_kind_str: string(25),
      connection_kind: ^nft$connection_kind,
      connection_label: ost$name,
      log_entry: ^string (3),
      log_date: ^ost$date,
      log_time: ^ost$time,
      put_blank_status: ost$status,
      size: integer,
      time_stamp: string (30),
      xns_address: ^nft$network_address;

    RESET log_file_seq.sequence_pointer;
    NEXT log_entry IN log_file_seq.sequence_pointer;
    WHILE log_entry <> NIL DO
      IF (log_entry^ = accepted) OR (log_entry^ = rejected) OR
            (log_entry^ = terminated) THEN
        IF log_entry^ = accepted THEN
          connection_label := '  Connection Accepted'
        ELSEIF log_entry^ = rejected THEN
          connection_label := '  Connection Rejected'
        ELSEIF log_entry^ = terminated THEN
          connection_label := '  Connection Terminated'
        IFEND;
        IF (pvt [p$format].value^.keyword_value <> 'R131') AND
              (pvt [p$format].value^.keyword_value <> 'R141') THEN
          NEXT connection_kind IN log_file_seq.sequence_pointer;
          CASE connection_kind^ OF
          = nfc$unknown_connection =
            connect_kind_str := unknown;
          = nfc$scfdi_connection =
            connect_kind_str := scf_di;
          = nfc$scfve_connection =
            connect_kind_str := scf_ve;
          = nfc$operator_connection =
            connect_kind_str := operator;
          = nfc$scfsve_connection =
            connect_kind_str := scfs_ve;
          = nfc$ntfve_connection =
            connect_kind_str := ntf_ve;
          = nfc$ntf_operator_connection =
            connect_kind_str := ntf_operator;
          CASEND;
        IFEND;
        IF pvt [p$format].value^.keyword_value = 'R131' THEN
          NEXT xns_address IN log_file_seq.sequence_pointer;
          PUSH address;
          address^.kind := nac$internet_address;
          address^.internet_address := xns_address^;
        ELSE
          NEXT address IN log_file_seq.sequence_pointer;
        IFEND;
        NEXT log_time IN log_file_seq.sequence_pointer;
        IF (log_entry^ = accepted) AND (pvt [p$format].value^.keyword_value <> 'R131') AND
              (pvt [p$format].value^.keyword_value <> 'R141') THEN
          NEXT log_date IN log_file_seq.sequence_pointer;
          STRINGREP (time_stamp, size, log_time^.millisecond, ' / ', log_date^.iso);
        ELSE
          time_stamp := log_time^.millisecond;
          size := 12;
        IFEND;

        clp$put_display (display_control, time_stamp (1, size), clc$no_trim, status);
        IF (pvt [p$format].value^.keyword_value <> 'R131') AND
              (pvt [p$format].value^.keyword_value <> 'R141') THEN
          display_connection_address (connect_kind_str, address, display_control, status);
          clp$put_display (display_control, connection_label, clc$no_trim, status);
        ELSE
          display_connection_address (connection_label, address, display_control, status);
        IFEND;
        put_display_line (' ', ' ', display_control, put_blank_status);
      ELSEIF log_entry^ = msg THEN
        display_connection_message (display_control, log_file_seq, status);
        put_display_line (' ', ' ', display_control, put_blank_status);
      IFEND;
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      NEXT log_entry IN log_file_seq.sequence_pointer;
    WHILEND;

  PROCEND display_scfs_log;
?? TITLE := '  get parameter value length', EJECT ??

  PROCEDURE get_parameter_value_length
    (VAR log_file_seq: amt$segment_pointer;
     VAR msg_length: integer;
     VAR parameter_value_length: integer;
     VAR status: ost$status);

    VAR
      i: integer,
      length_bytes: ^array [1 .. * ] of 0 .. 0ff(16),
      parameter_length: ^nft$parameter_value_length;


    NEXT parameter_length IN log_file_seq.sequence_pointer;
    msg_length := msg_length - 1;
    IF NOT parameter_length^.long_length THEN
      parameter_value_length := parameter_length^.length;
    ELSE
      NEXT length_bytes: [1 .. parameter_length^.length] IN
            log_file_seq.sequence_pointer;
      parameter_value_length := 0;
      FOR i := 1 TO parameter_length^.length DO
        parameter_value_length := parameter_value_length *
              100(16) + length_bytes^ [i];
      FOREND;
      msg_length := msg_length - parameter_length^.length;
    IFEND;

  PROCEND get_parameter_value_length;
?? TITLE := '  put display line', EJECT ??

  PROCEDURE put_display_line
    (    line: string ( * );
         label: string ( * );
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      label_str: string (label_size);

    status.normal := TRUE;

    IF NOT display_message THEN
      RETURN;
    IFEND;

    label_str := label;
    IF label <> ' ' THEN
      label_str (label_size - 2, 3) := ' : ';
    IFEND;

    clp$put_partial_display (display_control, label_str, clc$no_trim,
          amc$start, status);
    IF status.normal THEN
      clp$put_partial_display (display_control, line, clc$trim, amc$terminate,
            status);
    IFEND;

  PROCEND put_display_line;
?? TITLE := '  nfp$display scfs log', EJECT ??

  PROGRAM nfp$display_scfs_log
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*copy clv$display_variables
?? NEWTITLE := '    clean_up', EJECT ??

    PROCEDURE clean_up;

      VAR
        close_status: ost$status,
        ignore_status: ost$status;

      IF output_open THEN
        clp$close_display (display_control, close_status);
      IFEND;
      IF log_open THEN
        fsp$close_file (log_file_id, status);
        amp$return (log_file, ignore_status);
      IFEND;

    PROCEND clean_up;
*copy clp$new_page_procedure
?? TITLE := '  exit condition handler', EJECT ??

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

    PROCEND exit_condition_handler;
?? TITLE := '    put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (    display_control: clt$display_control;
       VAR status: ost$status);

      {The display_log command has no subtitles,
      { this is merely a dummy routine used to keep
      { the module consistent with those that do produce subtitles.

    PROCEND put_subtitle;
?? OLDTITLE, EJECT ??

    VAR
      container: clt$path_container,
      cycle_selector: clt$cycle_selector,
      display_control: clt$display_control,
      establish_descriptor: pmt$established_handler,
      exit_condition: [STATIC, READ] pmt$condition :=
            [pmc$block_exit_processing, [pmc$block_exit,
            pmc$program_termination, pmc$program_abort]],
      log_file: amt$local_file_name,
      log_file_attachment_options: ^fst$attachment_options,
      log_file_id: amt$file_identifier,
      log_file_ref: fst$evaluated_file_reference,
      log_file_seq: amt$segment_pointer,
      log_open: boolean,
      open_position: clt$open_position,
      output_file: clt$file,
      output_file_ref: fst$evaluated_file_reference,
      output_open: boolean,
      path: ^pft$path;


    status.normal := TRUE;
    display_message := TRUE;
    output_open := FALSE;

    pmp$establish_condition_handler (exit_condition, ^exit_condition_handler,
          ^establish_descriptor, status);

    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    clp$convert_str_to_path_handle (pvt [p$output].value^.file_value^,
          FALSE, TRUE, TRUE, output_file.local_file_name, output_file_ref,
          status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    clp$open_display (output_file, ^clp$new_page_procedure,
          display_control, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    output_open := TRUE;
    clv$titles_built := FALSE;
    clv$command_name := 'display_scfs_log';

    clp$convert_str_to_path_handle (pvt [p$log_file].value^.file_value^,
          FALSE, TRUE, TRUE, log_file, log_file_ref, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    PUSH log_file_attachment_options: [1 .. 2];
    log_file_attachment_options^ [1].selector := fsc$access_and_share_modes;
    log_file_attachment_options^ [1].access_modes.selector :=
          fsc$specific_access_modes;
    log_file_attachment_options^ [1].access_modes.value :=
          $fst$file_access_options [fsc$read];
    log_file_attachment_options^ [1].share_modes.selector :=
          fsc$specific_share_modes;
    log_file_attachment_options^ [1].share_modes.value :=
          -$fst$file_access_options [];
    log_file_attachment_options^ [2].selector := fsc$create_file;
    log_file_attachment_options^ [2].create_file := FALSE;

    fsp$open_file (log_file, amc$segment, log_file_attachment_options, NIL, NIL, NIL,
          NIL, log_file_id, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    log_open := TRUE;
    amp$get_segment_pointer (log_file_id, amc$sequence_pointer, log_file_seq,
          status);

    display_scfs_log (display_control, log_file_seq, status);

    clean_up;

  PROCEND nfp$display_scfs_log;
MODEND nfm$display_scfs_log;
*DECK DECK=NFM$EMULATE_FORMAT_EFFECTORS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'MODULE nfm$emulate_format_effectors' ??
MODULE nfm$emulate_format_effectors;

{ PURPOSE:
{   Translate a file containing ASCII format effectors into a file which
{   contains only NOS/VE batch format effectors.
{
{ DESIGN:
{   Examine the input file on a character by character basis.  Simulate the
{   activity caused by ASCII format effectors (BS, CR, HT, LF, FF, etc.) and
{   generate output containing equivalent batch format effectors.
{
{ NOTES:
{   This filter truncates output lines to conform to the PAGE_WIDTH parameter.
{   To facilitate truncation, coded files are positioned to the next record when
{   the output line is written, and transparent files are searched for the
{   transparent end of line character.
{
{   Although the path to a permanent file may be specified for the OUTPUT
{   parameter, use of permanent files is strongly discouraged.  Additionally,
{   this procedure will return an abnormal status if the path supplied for the
{   OUTPUT parameter specifies a file which already exists.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_parsing
*copyc cle$incompatible_params_given
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$get_next
*copyc amp$get_partial
*copyc amp$put_next
*copyc clp$change_variable
*copyc clp$evaluate_parameters
*copyc clp$get_variable_value
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc jmp$close_output_file
*copyc jmp$open_output_file
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    bs = $CHAR (8),
    cr = $CHAR (13),
    first_text_column = 2,
    format_effector = 1,
    ff = $CHAR (12),
    ht = $CHAR (9),
    lf = $CHAR (10),
    maximum_input_bytes = 2048,
    maximum_output_bytes = 256,
    maximum_tab_stop = 255,
    us = $CHAR (31),
    vt = $CHAR (11);

  TYPE
    output_line_list = record
      line: string (maximum_output_bytes),
      next_line: ^output_line_list,
    recend;

  TYPE
    tab_stop_definition = packed array [0 .. maximum_tab_stop] of 0 .. 1;

?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE nfp$emaulte_ascii__filter', EJECT ??

  PROCEDURE [XDCL] nfp$emulate_format_effectors
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE emulate_ascii_format_effectors, emuafe (
{   input, i: record
{       system_file_name: name 19..19
{       password: string 1..31
{       file: file = $optional
{     recend = $required
{   output, o: file = $required
{   horizontal_tab_stops, hts: any of
{       key
{         none, standard
{       keyend
{       list of integer 0..255
{     anyend = none
{   transparent_end_of_line, teol: key
{       cr, lf
{     keyend = lf
{   vertical_tab_stops, vts: any of
{       key
{         none
{       keyend
{       list of integer 0..255
{     anyend = $optional
{   data_mode, dm: (VAR) key
{       (coded, c)
{       (transparent, t)
{     keyend = $required
{   page_length, pl: integer 1..4398046511103 = $required
{   page_width, pw: integer 10..255 = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 17] of clt$pdt_parameter_name,
      parameters: array [1 .. 9] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
            recend,
            field_spec_3: clt$field_specification,
            element_type_spec_3: record
              header: clt$type_specification_header,
              recend,
              recend,
              type2: record
                header: clt$type_specification_header,
                recend,
                type3: 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 .. 2] 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$integer_type_qualifier,
                        recend,
                        recend,
                        default_value: string (4),
                        recend,
                        type4: record
                          header: clt$type_specification_header,
                          qualifier: clt$keyword_type_qualifier,
                          keyword_specs: array [1 .. 2] of clt$keyword_specification,
                          default_value: string (2),
                          recend,
                          type5: 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$integer_type_qualifier,
                                  recend,
                                  recend,
                                  recend,
                                  type6: record
                                    header: clt$type_specification_header,
                                    qualifier: clt$keyword_type_qualifier,
                                    keyword_specs: array [1 .. 4] of clt$keyword_specification,
                                    recend,
                                    type7: record
                                      header: clt$type_specification_header,
                                      qualifier: clt$integer_type_qualifier,
                                      recend,
                                      type8: record
                                        header: clt$type_specification_header,
                                        qualifier: clt$integer_type_qualifier,
                                        recend,
                                        type9: record
                                        header: clt$type_specification_header,
                                        recend,
    recend := [
    [1,
    [90, 8, 13, 13, 0, 37, 819],
    clc$command, 17, 9, 5, 0, 0, 1, 9, ''], [
    ['DATA_MODE                      ',clc$nominal_entry, 6],
    ['DM                             ',clc$abbreviation_entry, 6],
    ['HORIZONTAL_TAB_STOPS           ',clc$nominal_entry, 3],
    ['HTS                            ',clc$abbreviation_entry, 3],
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['PAGE_LENGTH                    ',clc$nominal_entry, 7],
    ['PAGE_WIDTH                     ',clc$nominal_entry, 8],
    ['PL                             ',clc$abbreviation_entry, 7],
    ['PW                             ',clc$abbreviation_entry, 8],
    ['STATUS                         ',clc$nominal_entry, 9],
    ['TEOL                           ',clc$abbreviation_entry, 4],
    ['TRANSPARENT_END_OF_LINE        ',clc$nominal_entry, 4],
    ['VERTICAL_TAB_STOPS             ',clc$nominal_entry, 5],
    ['VTS                            ',clc$abbreviation_entry, 5]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 131,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 137,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 5
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 100,
  clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$required_parameter, 0, 0],
{ PARAMETER 7
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 8
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 9
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$record_type], [3],
    ['SYSTEM_FILE_NAME               ', clc$required_field, 5], [[1, 0, clc$name_type], [19, 19]],
      ['PASSWORD                       ', clc$required_field, 8], [[1, 0, clc$string_type], [1, 31, FALSE]],
        ['FILE                           ', clc$optional_field, 3], [[1, 0, clc$file_type]]
          ],
{ PARAMETER 2
          [[1, 0, clc$file_type]],
{ PARAMETER 3
          [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
          FALSE, 2],
          81, [[1, 0, clc$keyword_type], [2], [
            ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
            ['STANDARD                       ', clc$nominal_entry, clc$normal_usage_entry, 2]]
            ],
            36, [[1, 0, clc$list_type], [20, 1, clc$max_list_size, 0, FALSE, FALSE],
                [[1, 0, clc$integer_type], [0, 255, 10]]
                ]
                ,
                'none'],
{ PARAMETER 4
                [[1, 0, clc$keyword_type], [2], [
                ['CR                             ', clc$nominal_entry, clc$normal_usage_entry, 1],
                ['LF                             ', clc$nominal_entry, clc$normal_usage_entry, 2]]
                ,
                'lf'],
{ PARAMETER 5
                [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
                FALSE, 2],
                44, [[1, 0, clc$keyword_type], [1], [
                  ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
                  ],
                  36, [[1, 0, clc$list_type], [20, 1, clc$max_list_size, 0, FALSE, FALSE],
                      [[1, 0, clc$integer_type], [0, 255, 10]]
                      ]
                      ],
{ PARAMETER 6
                      [[1, 0, clc$keyword_type], [4], [
                      ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
                      ['CODED                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
                      ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
                      ['TRANSPARENT                    ', clc$nominal_entry, clc$normal_usage_entry, 2]]
                      ],
{ PARAMETER 7
                      [[1, 0, clc$integer_type], [1, 4398046511103, 10]],
{ PARAMETER 8
                      [[1, 0, clc$integer_type], [10, 255, 10]],
{ PARAMETER 9
                      [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$input = 1,
      p$output = 2,
      p$horizontal_tab_stops = 3,
      p$transparent_end_of_line = 4,
      p$vertical_tab_stops = 5,
      p$data_mode = 6,
      p$page_length = 7,
      p$page_width = 8,
      p$status = 9;

    VAR
      pvt: array [1 .. 9] of clt$parameter_value;

    CONST
      file_field = 3,
      p$teol = p$transparent_end_of_line,
      password_field = 2,
      sfn_field = 1;

{ Variables used for reading & containing input data.

    VAR
      ignored_record_size: amt$max_record_length,
      input_file_byte_address: amt$file_byte_address,
      input_file_byte_count: amt$transfer_count,
      input_file_id: amt$file_identifier,
      input_file_position: amt$file_position,
      input_file_prev_opened: boolean,
      input_line: string (maximum_input_bytes),
      input_line_index: integer;

{ Variables used to process input & output data.

    VAR
      blank_line: string (maximum_output_bytes),
      data_mode_value: ^clt$data_value,
      file_attachment_options: ^fst$attachment_options,
      file_attributes: array [1 .. 1] of amt$get_item,
      h_tab_stops: tab_stop_definition,
      local_status: ost$status,
      misc_index: integer,
      next_vertical_tab: integer,
      number_of_output_bytes: 1 .. 256,
      output_line_altered: boolean,
      search_character_found: boolean,
      tab_list_entry: ^clt$data_value,
      teol_character: string (1),
      v_tab_stops: tab_stop_definition;

{ Variables used for containing & writing output data.

    VAR
      current_line: ^output_line_list,
      cycle_attributes: ^fst$file_cycle_attributes,
      file_prev_opened: boolean,
      first_overstrike_line: ^output_line_list,
      ignored_file_contains_data: boolean,
      ignored_file_exists: boolean,
      new_line: ^output_line_list,
      output_file_byte_address: amt$file_byte_address,
      output_file_id: amt$file_identifier,
      output_line: string (maximum_output_bytes),
      output_line_count: integer,
      output_line_index: integer;

?? NEWTITLE := 'PROCEDURE write_output_lines', EJECT ??

    PROCEDURE write_output_lines
      (VAR first_overstrike_line: ^output_line_list;
       VAR output_file_byte_address: amt$file_byte_address;
       VAR output_file_id: amt$file_identifier;
       VAR output_line: string (maximum_output_bytes);
       VAR output_line_altered: boolean;
       VAR output_line_count: integer;
       VAR number_of_output_bytes: 1 .. 256;
       VAR status: ost$status);

      VAR
        trimmed_string_size: integer,
        current_line: ^output_line_list;

      trimmed_string_size := number_of_output_bytes;
      trimmed_string_size := clp$trimmed_string_size(output_line);
      amp$put_next (output_file_id, ^output_line (1, trimmed_string_size), number_of_output_bytes,
            output_file_byte_address, status);
      IF status.normal THEN
        current_line := first_overstrike_line;
        WHILE current_line <> NIL DO
          output_line := current_line^.line;
          trimmed_string_size := clp$trimmed_string_size(output_line);
          amp$put_next (output_file_id, ^output_line (1, trimmed_string_size), number_of_output_bytes,
                output_file_byte_address, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          current_line := current_line^.next_line;
          FREE first_overstrike_line;
          first_overstrike_line := current_line;
        WHILEND;

{ Increment the output line count and rest the output line to blanks.

        output_line := blank_line (1, number_of_output_bytes);
        output_line_altered := FALSE;
        output_line_count := output_line_count + 1;
      IFEND;

    PROCEND write_output_lines;
?? OLDTITLE ??
?? EJECT ??

{   BEGIN nfp$emulate_format_effectors;

    status.normal := TRUE;

{ Validate the parameters passed to this procedure. Return to the caller on error.

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Process the INPUT parameter. Note that memory is obtained to store file attachment
{ options unconditionally because it will be used at least once when the output
{ file is openned.

    PUSH file_attachment_options: [1 .. 1];

    IF pvt [p$input].value^.field_values^ [file_field].value = NIL THEN

{ The input file is the original queue file in the output queue.


      jmp$open_output_file (pvt [p$input].value^.field_values^ [sfn_field].
            value^.name_value (1, jmc$system_supplied_name_size), amc$record, jmc$public_usage,
            pvt [p$input].value^.field_values^ [password_field].value^.string_value^, input_file_id, status);

    ELSE

{ The input file is the output of another filter. Ignore the original queue file.

      file_attachment_options^ [1].selector := fsc$create_file;
      file_attachment_options^ [1].create_file := FALSE;
      fsp$open_file (pvt [p$input].value^.field_values^ [file_field].value^.file_value^, amc$record,
            file_attachment_options, NIL, NIL, NIL, NIL, input_file_id, status);
    IFEND;
    IF NOT status.normal THEN

{ Return to the caller of this procedure with the abnormal status from the
{ attempt to open file input file.

      RETURN;
    IFEND;

{ Process the OUTPUT parameter.  Return an abnormal status if the output file
{ already exists.


    file_attributes [1].key := amc$null_attribute;
    amp$get_file_attributes (pvt [p$output].value^.file_value^, file_attributes, ignored_file_exists,
          file_prev_opened, ignored_file_contains_data, status);

    IF status.normal AND file_prev_opened THEN
      osp$set_status_abnormal ('PF', pfe$duplicate_cycle, pvt [p$output].value^.file_value^, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'specified', status);
      RETURN;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH cycle_attributes: [1 .. 6];

{ File contents, page format, page length, and page width attributes are
{ specified to provide accurate file attributes to other batch output filters
{ which may process the output of this filter, and to prevent any COPY_FILE
{ command (in SCL batch output filters) from attempting to 'burst' the file
{ contents.

    cycle_attributes^ [1].selector := fsc$file_contents_and_processor;
    cycle_attributes^ [1].file_contents := 'LIST';
    cycle_attributes^ [1].file_processor := osc$null_name;

    cycle_attributes^ [2].selector := fsc$page_format;
    cycle_attributes^ [2].page_format := amc$continuous_form;

    cycle_attributes^ [3].selector := fsc$page_length;
    cycle_attributes^ [3].page_length := pvt [p$page_length].value^.integer_value.value;

    cycle_attributes^ [4].selector := fsc$page_width;
    cycle_attributes^ [4].page_width := pvt [p$page_width].value^.integer_value.value;

{ Record delimiting character and record type are specified for compatibility
{ with BTF/VE.  Other record types must NOT be used.

    cycle_attributes^ [5].selector := fsc$record_delimiting_character;
    cycle_attributes^ [5].record_delimiting_character := us;

    cycle_attributes^ [6].selector := fsc$record_type;
    cycle_attributes^ [6].record_type := amc$trailing_char_delimited;

    file_attachment_options^ [1].selector := fsc$create_file;
    file_attachment_options^ [1].create_file := TRUE;


    fsp$open_file (pvt [p$output].value^.file_value^, amc$record, file_attachment_options, NIL,
          cycle_attributes, NIL, NIL, output_file_id, status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Prepare to process the HORIZONTAL_TAB_STOPS parameter by initializing both tab
{ stop definitions to zero.  Because the array boundries are very similar,
{ initilize the variable BLANK_LINE in the same loop.

    FOR misc_index := 0 TO pvt [p$page_width].value^.integer_value.value DO
      v_tab_stops [misc_index] := 0;
      blank_line (misc_index + 1) := ' ';
    FOREND;
    h_tab_stops := v_tab_stops;

    IF pvt [p$horizontal_tab_stops].specified THEN
      IF (pvt [p$horizontal_tab_stops].value^.kind = clc$keyword) THEN
        IF (pvt [p$horizontal_tab_stops].value^.keyword_value (1, 8) = 'STANDARD') THEN
          FOR misc_index := 9 TO pvt [p$page_width].value^.integer_value.value DO
            IF (misc_index MOD 9) = 0 THEN
              h_tab_stops [misc_index] := 1;
            IFEND;
          FOREND;
        IFEND;
      ELSE { scan the list of tab stops specified.
        tab_list_entry := pvt [p$horizontal_tab_stops].value;
        WHILE tab_list_entry <> NIL DO
          h_tab_stops [tab_list_entry^.element_value^.integer_value.value] := 1;
          tab_list_entry := tab_list_entry^.link;
        WHILEND;
      IFEND;
    IFEND;

{ Process the TRANSPARENT_END_OF_LINE parameter.

    IF (pvt [p$teol].value^.keyword_value (1, 2) = 'CR') THEN
      teol_character := cr;
    ELSE
      teol_character := lf;
    IFEND;

{ Process the VERTICAL_TAB_STOPS parameter.

    IF pvt [p$vertical_tab_stops].specified AND (pvt [p$vertical_tab_stops].value^.kind <> clc$keyword) THEN
      tab_list_entry := pvt [p$vertical_tab_stops].value;
      WHILE tab_list_entry <> NIL DO
        v_tab_stops [tab_list_entry^.element_value^.integer_value.value] := 1;
        tab_list_entry := tab_list_entry^.link;
      WHILEND;
    IFEND;

{ Process the DATA_MODE parameter by obtaining the value of the variable
{ specified.


    clp$get_variable_value (pvt [p$data_mode].variable^, data_mode_value, status);

    IF NOT status.normal THEN

      RETURN;
    IFEND;


{ Prepare to enter the main processing loops.

    current_line := NIL;
    first_overstrike_line := NIL;
    input_line_index := 1;
    number_of_output_bytes := pvt [p$page_width].value^.integer_value.value + format_effector;
    output_line := blank_line (1, number_of_output_bytes);
    output_line_altered := FALSE;
    output_line_count := 0;
    output_line_index := first_text_column;

{ Prime the input buffer.

    amp$get_next (input_file_id, ^input_line, maximum_input_bytes, input_file_byte_count,
          input_file_byte_address, input_file_position, status);

    WHILE (input_file_position <> amc$eoi) AND status.normal DO
      WHILE (input_line_index <= input_file_byte_count) AND (output_line_index <= number_of_output_bytes) DO
        CASE input_line (input_line_index) OF
        = bs =
          IF output_line_index > first_text_column THEN
            output_line_index := output_line_index - 1;
          IFEND;

        = cr =
          IF (data_mode_value^.keyword_value (1, 11) = 'TRANSPARENT') AND (teol_character = cr) THEN
            write_output_lines (first_overstrike_line, output_file_byte_address, output_file_id, output_line,
                  output_line_altered, output_line_count, number_of_output_bytes, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

          output_line_index := first_text_column;

        = ff =

{ Only write the output line(s) if character data was actually inserted into the
{ output buffer.

          IF output_line_altered THEN
            write_output_lines (first_overstrike_line, output_file_byte_address, output_file_id, output_line,
                  output_line_altered, output_line_count, number_of_output_bytes, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

          output_line (format_effector) := '1';
          output_line_altered := TRUE;
          output_line_count := 0;

        = ht =
          IF pvt [p$horizontal_tab_stops].specified THEN
            misc_index := output_line_index;
            WHILE (h_tab_stops [misc_index] <> 1) AND (misc_index <
                  pvt [p$page_width].value^.integer_value.value) DO
              misc_index := misc_index + 1;
            WHILEND;
            IF misc_index < pvt [p$page_width].value^.integer_value.value THEN
              output_line_index := misc_index + 1;
            IFEND;
            output_line_altered := TRUE;
          IFEND;

        = lf =
          write_output_lines (first_overstrike_line, output_file_byte_address, output_file_id, output_line,
                output_line_altered, output_line_count, number_of_output_bytes, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF (data_mode_value^.keyword_value (1, 11) = 'TRANSPARENT') AND (teol_character = lf) THEN
            output_line_index := first_text_column;
          IFEND;

        = vt =
          IF pvt [p$vertical_tab_stops].specified AND (pvt [p$vertical_tab_stops].value^.kind <>
                clc$keyword) THEN
            write_output_lines (first_overstrike_line, output_file_byte_address, output_file_id, output_line,
                  output_line_altered, output_line_count, number_of_output_bytes, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            next_vertical_tab := pvt [p$page_length].value^.integer_value.value;
            misc_index := output_line_count MOD pvt [p$page_length].value^.integer_value.value;
            WHILE (v_tab_stops [misc_index] <> 1) AND ((misc_index <= maximum_tab_stop) AND
                  (misc_index < next_vertical_tab)) DO
              misc_index := misc_index + 1;
            WHILEND;

            IF (misc_index <= maximum_tab_stop) AND (misc_index < next_vertical_tab) THEN
              next_vertical_tab := misc_index;
            IFEND;

            misc_index := output_line_count MOD next_vertical_tab;
            WHILE (misc_index > 0) AND status.normal DO
              amp$put_next (output_file_id, ^output_line (1, 2), number_of_output_bytes,
                    output_file_byte_address, status);
              output_line_index := output_line_index + 1;
              misc_index := output_line_count MOD next_vertical_tab;
            WHILEND;
          IFEND;
        ELSE

{ The input character is not an ASCII format effector recognized by this filter.

          IF ($INTEGER (input_line (input_line_index)) > 31) AND
                ($INTEGER (input_line (input_line_index)) <> 127) THEN


{ If the output line index points to a blank in the output buffer than that
{ blank can be replaced by the input character.  If the output line index points
{ to a non-blank character in the output buffer, then this filter must generate
{ overstrike lines to cause the printer to print two characters at the same
{ physical location on the printed page.

            IF output_line (output_line_index) = ' ' THEN
              output_line (output_line_index) := input_line (input_line_index);
            ELSE

{ Find an overstrike line with a blank in the current position on the output
{ line. Create an overstrike line if none exists.

              IF (first_overstrike_line = NIL) THEN
                ALLOCATE first_overstrike_line;
                first_overstrike_line^.next_line := NIL;
                first_overstrike_line^.line := blank_line (1, number_of_output_bytes);
                first_overstrike_line^.line (format_effector) := '+';
                first_overstrike_line^.line (output_line_index) := input_line (input_line_index);
              ELSE
                current_line := first_overstrike_line;
                search_character_found := FALSE;
                WHILE NOT search_character_found DO
                  IF current_line^.line (output_line_index) = ' ' THEN
                    search_character_found := TRUE;
                  ELSEIF current_line^.next_line = NIL THEN
                    search_character_found := TRUE;
                    ALLOCATE new_line;
                    current_line^.next_line := new_line;
                    new_line^.next_line := NIL;
                    new_line^.line := blank_line (1, number_of_output_bytes);
                    new_line^.line (format_effector) := '+';
                    current_line := new_line;
                  ELSE
                    current_line := current_line^.next_line;
                  IFEND;
                WHILEND;
                current_line^.line (output_line_index) := input_line (input_line_index);
              IFEND;
            IFEND;
            output_line_index := output_line_index + 1;
            output_line_altered := TRUE;
          IFEND;
        CASEND;
        input_line_index := input_line_index + 1;
      WHILEND;

{ The limits of either the input buffer or the output buffer have been reached.
{ Handle the condition by writing the output buffer and/or reading new data.

      IF status.normal THEN
        IF output_line_index > number_of_output_bytes THEN
          write_output_lines (first_overstrike_line, output_file_byte_address, output_file_id, output_line,
                output_line_altered, output_line_count, number_of_output_bytes, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          output_line_index := first_text_column;

          IF input_file_position = amc$mid_record THEN

{ The data mode can not be transparent because the file would have an undefined
{ record structure and "mid-record" would be meainingless.  Assume the data mode
{ is coded, skip to the next record and refill the input buffer.

            amp$get_partial (input_file_id, ^input_line, maximum_input_bytes, ignored_record_size,
                  input_file_byte_count, input_file_byte_address, input_file_position, amc$skip_to_eor,
                  status);

            IF status.normal AND (input_file_position <> amc$eoi) THEN
              amp$get_next (input_file_id, ^input_line, maximum_input_bytes, input_file_byte_count,
                    input_file_byte_address, input_file_position, status);
            IFEND;
          ELSEIF input_file_position <> amc$eoi THEN
            IF (data_mode_value^.keyword_value (1, 5) = 'CODED') OR
                  (input_line_index > input_file_byte_count) THEN
              amp$get_next (input_file_id, ^input_line, maximum_input_bytes, input_file_byte_count,
                    input_file_byte_address, input_file_position, status);
              input_line_index := 1;
            IFEND;

            IF (data_mode_value^.keyword_value (1, 11) = 'TRANSPARENT') THEN

{ Search the input file for the next transparent end-of-line character.

              misc_index := input_line_index;
              search_character_found := FALSE;
              WHILE (NOT search_character_found) AND (input_file_position <> amc$eoi) DO
                WHILE (misc_index <= input_file_byte_count) AND (NOT search_character_found) DO
                  IF input_line (misc_index) = teol_character THEN
                    search_character_found := TRUE;
                  ELSE
                    misc_index := misc_index + 1;
                  IFEND;
                WHILEND;
                IF NOT search_character_found THEN
                  amp$get_next (input_file_id, ^input_line, maximum_input_bytes, input_file_byte_count,
                        input_file_byte_address, input_file_position, status);
                  misc_index := 1;
                IFEND;
              WHILEND;
              IF search_character_found THEN
                input_line (1, (input_file_byte_count - misc_index)) := input_line ((misc_index + 1), * );
                input_file_byte_count := (input_file_byte_count - misc_index);
              IFEND;
            IFEND; { IF data-mode = coded
          IFEND; { IF mid-record ELSE NOT end-of-file

{ At this point, the output buffer has been written, and the input buffer has
{ a fresh supply of data. Reset the index into the input line.

          input_line_index := 1;
        IFEND;

        IF (input_line_index > input_file_byte_count) AND (input_file_position <> amc$eoi) THEN
          IF input_file_position = amc$mid_record THEN
            amp$get_partial (input_file_id, ^input_line, maximum_input_bytes, ignored_record_size,
                  input_file_byte_count, input_file_byte_address, input_file_position, amc$no_skip, status);
          ELSE
            IF data_mode_value^.keyword_value (1, 5) = 'CODED' THEN
              write_output_lines (first_overstrike_line, output_file_byte_address, output_file_id,
                    output_line, output_line_altered, output_line_count, number_of_output_bytes, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              output_line_index := first_text_column;
            IFEND;

            amp$get_next (input_file_id, ^input_line, maximum_input_bytes, input_file_byte_count,
                  input_file_byte_address, input_file_position, status);
            input_line_index := 1;
          IFEND; { IF mid-record ELSE end-of-record

          input_line_index := 1;
        IFEND;
      IFEND; { IF status.normal
    WHILEND;

    IF status.normal THEN
      write_output_lines (first_overstrike_line, output_file_byte_address, output_file_id, output_line,
            output_line_altered, output_line_count, number_of_output_bytes, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$input].value^.field_values^ [file_field].value = NIL THEN
      jmp$close_output_file (input_file_id, local_status);
    ELSE
      fsp$close_file (input_file_id, local_status);
    IFEND;
    fsp$close_file (output_file_id, status);
    IF (NOT local_status.normal) AND status.normal THEN
      status := local_status;
    IFEND;

    IF status.normal THEN
      IF data_mode_value^.keyword_value (1, 11) = 'TRANSPARENT' THEN
        data_mode_value^.kind := clc$keyword;
        data_mode_value^.keyword_value := 'CODED';

        clp$change_variable (pvt [p$data_mode].variable^, data_mode_value, status);

      IFEND;
    IFEND;

  PROCEND nfp$emulate_format_effectors;
MODEND nfm$emulate_format_effectors;
*DECK DECK=NFM$FILE_TRANSFER_APPL_PROCS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NFM$FILE_TRANSFER_APPL_PROCS' ??
MODULE nfm$file_transfer_appl_procs;

{ PURPOSE:
{   This module contains procedures used by the network file transfer
{   applications to get and send data on a connection, to parse and create
{   protocol messages as well as miscellaneous procedures and functions.
{
{ DESIGN:
{   The protocol routines are based on the SCFS protocol specification.
{   The routines in this module are listed in alphabetical order.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc amt$file_identifier
*copyc clc$standard_file_names
*copyc fst$file_reference
*copyc fst$path_size
*copyc nat$application_name
*copyc nat$data_fragments
*copyc nat$network_address
*copyc nfc$timer_values
*copyc nfc$wait_list_limit
*copyc nfe$exception_condition_codes
*copyc nfs$appl_def_segment_variables
*copyc nft$appl_def_segment_values
*copyc nft$application_file_descriptor
*copyc nft$btf_task
*copyc nft$btfs_di_title
*copyc nft$byte_array
*copyc nft$copies
*copyc nft$device_attributes
*copyc nft$device_status
*copyc nft$device_type
*copyc nft$file_assignment_msg
*copyc nft$file_assignment_response
*copyc nft$file_size
*copyc nft$file_transfer_state
*copyc nft$file_vertical_print_density
*copyc nft$intertask_message
*copyc nft$io_station_usage
*copyc nft$message_kind
*copyc nft$message_sequence
*copyc nft$micro_second
*copyc nft$network_address
*copyc nft$ntf_remote_system_protocol
*copyc nft$ntf_remote_system_type
*copyc nft$ntf_route_back_position
*copyc nft$output_data_mode
*copyc nft$page_format
*copyc nft$page_length
*copyc nft$page_width
*copyc nft$parameter_value_length
*copyc nft$priority
*copyc nft$scfs_client_identifier
*copyc nft$terqo_file_status_codes
*copyc nft$timer
*copyc nft$vfu_load_procedure
*copyc nft$wait_activity_list
*copyc ost$activity_status
*copyc ost$i_wait
*copyc ost$name
*copyc pmd$local_queues
*copyc pmt$debug_mode
*copyc pmt$task_id
?? POP ??
*copyc amp$flush
*copyc amp$return
*copyc clp$create_variable
*copyc clp$get_system_file_id
*copyc clp$trimmed_string_size
*copyc clp$write_variable
*copyc fsp$open_file
*copyc nap$await_server_response
*copyc nap$begin_directory_search
*copyc nap$end_directory_search
*copyc nap$get_attributes
*copyc nap$get_title_translation
*copyc nap$request_connection
*copyc nap$se_receive_data
*copyc nap$se_send_data
*copyc nap$supported_protocol_stacks
*copyc nfp$modify_param_value_length
*copyc nfp$put_async_task_message
*copyc nfp$request_asynchronous_task
*copyc osp$append_status_parameter
*copyc osp$generate_message
*copyc osp$set_status_abnormal
*copyc pfp$define
*copyc pfp$define_catalog
*copyc pmp$get_unique_name
*copyc pmp$log
*copyc osv$lower_to_upper
?? TITLE := 'find_job_local_queue', EJECT ??

{
{  PURPOSE:
{    Determine if there is an activity index already established for
{    local queue messages (messages from BTF/VE).
{

  PROCEDURE find_job_local_queue
    (    wait_list: ost$i_wait_list;
     VAR local_queue_found: boolean;
     VAR wait_list_index: integer);


    local_queue_found := FALSE;

  /search_wait_list_for_activity/
    FOR wait_list_index := 1 TO UPPERBOUND (wait_list) DO
      local_queue_found := wait_list [wait_list_index].activity = pmc$i_await_local_queue_message;
      IF local_queue_found THEN
        RETURN; {----->
      IFEND;
    FOREND /search_wait_list_for_activity/;

  PROCEND find_job_local_queue;
?? TITLE := 'nfp$add_btf_task_to_list', EJECT ??
*copy nfh$add_btf_task_to_list

  PROCEDURE [XDCL] nfp$add_btf_task_to_list
    (    task_id: pmt$task_id;
         queue_id: pmt$queue_connection;
         network_address: nat$network_address;
         btfs_di_title: nft$btfs_di_title;
         station: ost$name;
         device: ost$name;
     VAR wait_list {input, output} : ^ost$i_wait_list;
     VAR wait_activity_list {input, output} : ^nft$wait_activity_list;
     VAR wait_list_sequence {input, output} : ^SEQ ( * );
     VAR wait_activity_list_sequence {input, output} : ^SEQ ( * );
     VAR new_btf_task: ^nft$btf_task);

    VAR
      activity: nft$wait_activity,
      local_queue_found: boolean,
      task: ^nft$btf_task,
      wait_list_index: integer;


    ALLOCATE new_btf_task;

    new_btf_task^.id := task_id;
    new_btf_task^.qid := queue_id;
    new_btf_task^.network_addr := network_address;
    new_btf_task^.btfs_di_title := btfs_di_title;
    new_btf_task^.io_station := station;
    new_btf_task^.device := device;
    new_btf_task^.back_link := NIL;
    new_btf_task^.link := NIL;

    find_job_local_queue (wait_list^, local_queue_found, wait_list_index);
    IF local_queue_found THEN
      task := wait_activity_list^ [wait_list_index].btf_task_list;
      IF task <> NIL THEN

      /find_end_of_btf_task_list/
        WHILE task^.link <> NIL DO
          task := task^.link;
        WHILEND /find_end_of_btf_task_list/;

        task^.link := new_btf_task;
        new_btf_task^.back_link := task;
      ELSE
        wait_activity_list^ [wait_list_index].btf_task_list := new_btf_task;
      IFEND;
    ELSE
      activity.kind := nfc$btfve_task_message;
      activity.btf_task_list := new_btf_task;
      nfp$add_to_wait_lists (activity, wait_list, wait_activity_list, wait_list_sequence,
            wait_activity_list_sequence);
    IFEND;

  PROCEND nfp$add_btf_task_to_list;
?? TITLE := 'nfp$add_to_wait_lists', EJECT ??
*copy nfh$add_to_wait_lists

  PROCEDURE [XDCL] nfp$add_to_wait_lists
    (    activity: nft$wait_activity;
     VAR wait_list {input, output} : ^ost$i_wait_list;
     VAR wait_activity_list {input, output} : ^nft$wait_activity_list;
     VAR wait_list_sequence {input, output} : ^SEQ ( * );
     VAR wait_activity_list_sequence {input, output} : ^SEQ ( * ));


    VAR
      index: integer,
      temp_sequence: ^SEQ ( * ),
      temp_wait_list: ^ost$i_wait_list,
      temp_wait_activity_list: ^nft$wait_activity_list,
      wait_list_limit: integer;


    wait_list_limit := UPPERBOUND (wait_list^);
    IF (wait_list_limit MOD nfc$wait_list_limit) <> 0 THEN
      RESET wait_list_sequence;
      NEXT wait_list: [1 .. (wait_list_limit + 1)] IN wait_list_sequence;
      RESET wait_activity_list_sequence;
      NEXT wait_activity_list: [nfc$wait_activity_list_lowest .. (wait_list_limit + 1)]
            IN wait_activity_list_sequence;
    ELSE
      ALLOCATE temp_sequence: [[REP (wait_list_limit + nfc$wait_list_limit) OF ost$i_activity]];
      RESET temp_sequence;
      NEXT temp_wait_list: [1 .. (wait_list_limit + 1)] IN temp_sequence;

    /set_up_temporary_wait_list/
      FOR index := 1 TO wait_list_limit DO
        temp_wait_list^ [index] := wait_list^ [index];
      FOREND /set_up_temporary_wait_list/;

      FREE wait_list_sequence;
      wait_list_sequence := temp_sequence;
      wait_list := temp_wait_list;

      ALLOCATE temp_sequence: [[REP (wait_list_limit + nfc$wait_list_limit) OF ost$i_activity]];
      RESET temp_sequence;
      NEXT temp_wait_activity_list: [nfc$wait_activity_list_lowest .. (wait_list_limit + 1)] IN temp_sequence;

    /set_up_temp_wait_activity_list/
      FOR index := nfc$wait_activity_list_lowest TO wait_list_limit DO
        temp_wait_activity_list^ [index] := wait_activity_list^ [index];
      FOREND /set_up_temp_wait_activity_list/;

      FREE wait_activity_list_sequence;
      wait_activity_list_sequence := temp_sequence;
      wait_activity_list := temp_wait_activity_list;
    IFEND;

    wait_activity_list^ [wait_list_limit + 1] := activity;

    CASE activity.kind OF

    = nfc$control_facility_connection =
      wait_list^ [wait_list_limit + 1].activity := nac$i_await_data_available;
      wait_list^ [wait_list_limit + 1].file_identifier := activity.cf^.connection_id;
      wait_activity_list^ [wait_list_limit + 1].cf^.wait_activity_index := wait_list_limit + 1;

    = nfc$btfve_task_message =
      wait_list^ [wait_list_limit + 1].activity := pmc$i_await_local_queue_message;
      wait_list^ [wait_list_limit + 1].qid := activity.btf_task_list^.qid;

    = nfc$title_translation_request =
      wait_list^ [wait_list_limit + 1].activity := nac$i_await_title_translation;
      wait_list^ [wait_list_limit + 1].translation_request := activity.dest^.title_search_id;
    CASEND;

  PROCEND nfp$add_to_wait_lists;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$btfs_di_match', EJECT ??

*copyc nfh$btfs_di_match

  FUNCTION [XDCL] nfp$btfs_di_match
    (    first_title: nft$btfs_di_title;
         first_address: nat$network_address;
         second_title: nft$btfs_di_title;
         second_address: nat$network_address): boolean;

    IF (first_title.length > 0) OR (second_title.length > 0) THEN
      nfp$btfs_di_match := first_title.title (1, first_title.length) =
            second_title.title (1, second_title.length);
    ELSE
      nfp$btfs_di_match := first_address.internet_address =
            second_address.internet_address;
    IFEND;

  FUNCEND nfp$btfs_di_match;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$crack_file_assignment_msg', EJECT ??
*copy nfh$crack_file_assignment_msg

  PROCEDURE [XDCL] nfp$crack_file_assignment_msg
    (VAR message: ^nft$message_sequence;
     VAR message_length: integer;
     VAR station: ost$name;
     VAR device: ost$name;
     VAR device_type: nft$device_type;
     VAR device_attributes: nft$device_attributes;
     VAR btfs_address: nft$network_address;
     VAR btfs_di_title: nft$btfs_di_title;
     VAR file_name: jmt$system_supplied_name;
     VAR descriptor: nft$application_file_descriptor;
     VAR remote_system_protocol: nft$ntf_remote_system_protocol;
     VAR remote_system_type: nft$ntf_remote_system_type;
     VAR route_back_position: nft$ntf_route_back_position;
     VAR last_parameter_sent: nft$file_assignment_params;
     VAR status: ost$status);


    VAR
      address_specified: boolean,
      ascii_string: ^string ( * <= osc$max_name_size),
      banner_highlight_field: ^nft$banner_highlight_field,
      banner_page_count: ^nft$banner_page_count,
      btfs_di_title_string: ^string ( * <= nac$max_title_pattern_length),
      byte_array: ^nft$byte_array,
      carriage_control_support: ^nft$carriage_control_action,
      code_set: ^nft$code_set,
      copies: ^nft$copies,
      descriptor_copies: jmt$output_copy_count,
      descriptor_destination_family: ost$name,
      descriptor_destination_usage: jmt$destination_usage,
      descriptor_device: jmt$output_device,
      descriptor_ext_characteristics: jmt$external_characteristics,
      descriptor_forms_code: jmt$forms_code,
      descriptor_output_priority: jmt$output_priority,
      descriptor_station: jmt$station,
      descriptor_station_operator: jmt$station_operator,
      descriptor_vert_print_density: jmt$vertical_print_density,
      descriptor_vfu_load_procedure: jmt$vfu_load_procedure,
      dev_vertical_print_density: ^nft$vertical_print_density,
      device_type_param: ^nft$device_type,
      file_ack: ^boolean,
      forms_size: ^nft$forms_size,
      maximum_file_size: ^nft$device_file_size,
      network_address: ^nft$network_address,
      ntf_protocol: ^nft$ntf_remote_system_protocol,
      ntf_route_back: ^nft$ntf_route_back_position,
      ntf_type: ^nft$ntf_remote_system_type,
      output_initial_priority: ^nft$priority,
      page_width: ^nft$page_width,
      parameter: ^nft$file_assign_msg_parameter,
      parameter_length: ^nft$parameter_value_length,
      priority: nft$priority,
      station_usage: ^nft$io_station_usage,
      tip_type: ^nft$tip_type,
      transmission_block_size: ^nft$transmit_block_size,
      undefined_fe_action: ^nft$format_effector_actions,
      unsupported_fe_action: ^nft$format_effector_actions,
      value_length: integer,
      vertical_print_density: ^nft$file_vertical_print_density,
      vfu_load_option: ^nft$vfu_load_option;


    status.normal := TRUE;

    address_specified := FALSE;
    last_parameter_sent := nfc$null_parameter;

{  Initialize descriptor variables.

    descriptor_copies := 1;
    descriptor_destination_family := osc$null_name;
    descriptor_destination_usage := osc$null_name;
    descriptor_device := osc$null_name;
    descriptor_ext_characteristics := ' ';
    descriptor_forms_code := ' ';
    descriptor_output_priority := ' ';
    descriptor_station := osc$null_name;
    descriptor_station_operator := osc$null_name;
    descriptor_vert_print_density := jmc$vertical_print_density_6;
    descriptor_vfu_load_procedure := osc$null_name;

{  Initialize returned variables.

    station := osc$null_name;
    device := osc$null_name;
    device_type := nfc$null_device;
    device_attributes.attributes_received := FALSE;

{ Only the following device attributes are initialized since they are the only
{ ones SCFS sends conditionally (because they are strings).  All others are
{ integers or ordinal types.

    device_attributes.device_alias_1 := osc$null_name;
    device_attributes.device_alias_2 := osc$null_name;
    device_attributes.device_alias_3 := osc$null_name;
    device_attributes.external_characteristics_1 := osc$null_name;
    device_attributes.external_characteristics_2 := osc$null_name;
    device_attributes.external_characteristics_3 := osc$null_name;
    device_attributes.external_characteristics_4 := osc$null_name;
    device_attributes.forms_code_1 := osc$null_name;
    device_attributes.forms_code_2 := osc$null_name;
    device_attributes.forms_code_3 := osc$null_name;
    device_attributes.forms_code_4 := osc$null_name;
    device_attributes.terminal_model := osc$null_name;
    device_attributes.vfu_load_procedure := osc$null_name;
    btfs_di_title.length := 0;
    btfs_di_title.title := ' ';
    file_name := jmc$blank_system_supplied_name;

    NEXT parameter IN message;
    IF parameter <> NIL THEN

    /crack_file_assign_message/
      WHILE (parameter^.param <> nfc$null_parameter) AND (message_length > 0) DO
        message_length := message_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, message_length, value_length, status);
          IF status.normal THEN
            message_length := message_length - value_length;
          ELSE
            RETURN; {----->
          IFEND;
        ELSE
          value_length := 1;
          message_length := message_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          last_parameter_sent := nfc$io_station_name;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            station := ascii_string^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$system_file_name =
          last_parameter_sent := nfc$system_file_name;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            file_name := ascii_string^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$device_name =
          last_parameter_sent := nfc$device_name;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            device := ascii_string^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$btfsdi_address =
          last_parameter_sent := nfc$btfsdi_address;
          NEXT network_address IN message;
          IF network_address <> NIL THEN
            btfs_address := network_address^;
            address_specified := TRUE;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$requested_io_station =
          last_parameter_sent := nfc$requested_io_station;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            descriptor_station := ascii_string^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$requested_device =
          last_parameter_sent := nfc$requested_device;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            descriptor_device := ascii_string^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$operator_name =
          last_parameter_sent := nfc$operator_name;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            descriptor_station_operator := ascii_string^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$operator_family =
          last_parameter_sent := nfc$operator_family;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            descriptor_destination_family := ascii_string^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$station_usage =
          last_parameter_sent := nfc$station_usage;
          NEXT station_usage IN message;
          IF station_usage <> NIL THEN
            IF station_usage^ = nfc$public_io_station THEN
              descriptor_destination_usage := jmc$public_usage;
            ELSEIF station_usage^ = nfc$private_io_station THEN
              descriptor_destination_usage := jmc$private_usage;
            ELSEIF station_usage^ = nfc$ntf_remote_system THEN
              descriptor_destination_usage := jmc$ntf_usage;
            IFEND;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$copies =
          last_parameter_sent := nfc$copies;
          NEXT copies IN message;
          IF copies <> NIL THEN
            descriptor_copies := copies^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$external_characteristics =
          last_parameter_sent := nfc$external_characteristics;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, descriptor_ext_characteristics);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$forms_code =
          last_parameter_sent := nfc$forms_code;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, descriptor_forms_code);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$output_initial_priority =
          last_parameter_sent := nfc$output_initial_priority;
          NEXT output_initial_priority IN message;
          IF output_initial_priority <> NIL THEN
            priority := output_initial_priority^ -nfc$minimum_priority;
            IF priority = nfc$low_output_priority THEN
              descriptor_output_priority := 'LOW';
            ELSEIF priority = nfc$medium_output_priority THEN
              descriptor_output_priority := 'MEDIUM';
            ELSEIF priority = nfc$high_output_priority THEN
              descriptor_output_priority := 'HIGH';
            IFEND;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$vfu_load_procedure =
          last_parameter_sent := nfc$vfu_load_procedure;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, descriptor_vfu_load_procedure);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$vertical_print_density =
          last_parameter_sent := nfc$vertical_print_density;
          NEXT vertical_print_density IN message;
          IF vertical_print_density <> NIL THEN
            CASE vertical_print_density^ OF
            = nfc$vertical_print_density_none =
              descriptor_vert_print_density := jmc$vertical_print_density_none;
            = nfc$vertical_print_density_6 =
              descriptor_vert_print_density := jmc$vertical_print_density_6;
            = nfc$vertical_print_density_7 =
              descriptor_vert_print_density := jmc$vertical_print_density_7;
            = nfc$vertical_print_density_8 =
              descriptor_vert_print_density := jmc$vertical_print_density_8;
            = nfc$vertical_print_density_9 =
              descriptor_vert_print_density := jmc$vertical_print_density_9;
            = nfc$vertical_print_density_10 =
              descriptor_vert_print_density := jmc$vertical_print_density_10;
            = nfc$vertical_print_density_11 =
              descriptor_vert_print_density := jmc$vertical_print_density_11;
            = nfc$vertical_print_density_12 =
              descriptor_vert_print_density := jmc$vertical_print_density_12;
            ELSE
            CASEND;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$ntf_remote_system_protocol =
          last_parameter_sent := nfc$ntf_remote_system_protocol;
          NEXT ntf_protocol IN message;
          IF ntf_protocol <> NIL THEN
            remote_system_protocol := ntf_protocol^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$device_type =
          last_parameter_sent := nfc$device_type;
          NEXT device_type_param IN message;
          IF device_type_param <> NIL THEN
            device_type := device_type_param^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$ntf_remote_system_type =
          last_parameter_sent := nfc$ntf_remote_system_type;
          NEXT ntf_type IN message;
          IF ntf_type <> NIL THEN
            remote_system_type := ntf_type^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$ntf_route_back_position =
          last_parameter_sent := nfc$ntf_route_back_position;
          NEXT ntf_route_back IN message;
          IF ntf_route_back  <> NIL THEN
            route_back_position := ntf_route_back^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$btfs_di_title =
          last_parameter_sent := nfc$btfs_di_title;
          NEXT btfs_di_title_string: [value_length] IN message;
          IF btfs_di_title_string <> NIL THEN
            IF value_length > 0 THEN
              address_specified := TRUE;
              btfs_di_title.length := value_length;
              btfs_di_title.title := btfs_di_title_string^;
            IFEND;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

{ NOTE:  If SCFS has sent a banner_highlight_field parameter then it is
{ an SCFS that knows how to send all device attributes.  Therefore the
{ presence of the non-optional parameter banner_highlight_field is used
{ here to signal that we have received device_attributes from SCFS.

        = nfc$banner_highlight_field =
          device_attributes.attributes_received := TRUE;
          last_parameter_sent := nfc$banner_highlight_field;
          NEXT banner_highlight_field IN message;
          IF banner_highlight_field <> NIL THEN
            device_attributes.banner_highlight_field := banner_highlight_field^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$banner_page_count =
          last_parameter_sent := nfc$banner_page_count;
          NEXT banner_page_count IN message;
          IF banner_page_count <> NIL THEN
            device_attributes.banner_page_count := banner_page_count^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$carriage_control_support =
          last_parameter_sent := nfc$carriage_control_support;
          NEXT carriage_control_support IN message;
          IF carriage_control_support <> NIL THEN
            device_attributes.carriage_control_support := carriage_control_support^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$code_set =
          last_parameter_sent := nfc$code_set;
          NEXT code_set IN message;
          IF code_set <> NIL THEN
            device_attributes.code_set := code_set^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$device_alias_1 =
          last_parameter_sent := nfc$device_alias_1;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, device_attributes.device_alias_1);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$device_alias_2 =
          last_parameter_sent := nfc$device_alias_2;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, device_attributes.device_alias_2);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$device_alias_3 =
          last_parameter_sent := nfc$device_alias_3;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, device_attributes.device_alias_3);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$external_characteristics_1 =
          last_parameter_sent := nfc$external_characteristics_1;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, device_attributes.external_characteristics_1);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$external_characteristics_2 =
          last_parameter_sent := nfc$external_characteristics_2;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, device_attributes.external_characteristics_2);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$external_characteristics_3 =
          last_parameter_sent := nfc$external_characteristics_3;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, device_attributes.external_characteristics_3);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$external_characteristics_4 =
          last_parameter_sent := nfc$external_characteristics_4;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, device_attributes.external_characteristics_4);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$file_acknowledgement =
          last_parameter_sent := nfc$file_acknowledgement;
          NEXT file_ack IN message;
          IF file_ack <> NIL THEN
            device_attributes.file_acknowledgement := file_ack^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$forms_code_1 =
          last_parameter_sent := nfc$forms_code_1;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, device_attributes.forms_code_1);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$forms_code_2 =
          last_parameter_sent := nfc$forms_code_2;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, device_attributes.forms_code_2);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$forms_code_3 =
          last_parameter_sent := nfc$forms_code_3;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, device_attributes.forms_code_3);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$forms_code_4 =
          last_parameter_sent := nfc$forms_code_4;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, device_attributes.forms_code_4);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$forms_size =
          last_parameter_sent := nfc$forms_size;
          NEXT forms_size IN message;
          IF forms_size <> NIL THEN
            device_attributes.forms_size := forms_size^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$maximum_file_size =
          last_parameter_sent := nfc$maximum_file_size;
          NEXT maximum_file_size IN message;
          IF maximum_file_size <> NIL THEN
            device_attributes.maximum_file_size := maximum_file_size^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$page_width =
          last_parameter_sent := nfc$page_width;
          NEXT page_width IN message;
          IF page_width <> NIL THEN
            device_attributes.page_width := page_width^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$terminal_model =
          last_parameter_sent := nfc$terminal_model;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, device_attributes.terminal_model);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$tip_type =
          last_parameter_sent := nfc$tip_type;
          NEXT tip_type IN message;
          IF tip_type <> NIL THEN
            device_attributes.tip_type := tip_type^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$transmission_block_size =
          last_parameter_sent := nfc$transmission_block_size;
          NEXT transmission_block_size IN message;
          IF transmission_block_size <> NIL THEN
            device_attributes.transmission_block_size := transmission_block_size^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$undefined_fe_action =
          last_parameter_sent := nfc$undefined_fe_action;
          NEXT undefined_fe_action IN message;
          IF undefined_fe_action <> NIL THEN
            device_attributes.undefined_fe_action := undefined_fe_action^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$unsupported_fe_action =
          last_parameter_sent := nfc$unsupported_fe_action;
          NEXT unsupported_fe_action IN message;
          IF unsupported_fe_action <> NIL THEN
            device_attributes.unsupported_fe_action := unsupported_fe_action^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$dev_vertical_print_density =
          last_parameter_sent := nfc$dev_vertical_print_density;
          NEXT dev_vertical_print_density IN message;
          IF dev_vertical_print_density <> NIL THEN
            device_attributes.vertical_print_density := dev_vertical_print_density^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$vfu_load_option =
          last_parameter_sent := nfc$vfu_load_option;
          NEXT vfu_load_option IN message;
          IF vfu_load_option <> NIL THEN
            device_attributes.vfu_load_option := vfu_load_option^;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        = nfc$dev_vfu_load_procedure =
          last_parameter_sent := nfc$dev_vfu_load_procedure;
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, device_attributes.vfu_load_procedure);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN;
          IFEND;

        ELSE

{         ERROR ----   Ignore parameter value.

          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
        IF parameter = NIL THEN
          osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
          RETURN; {----->
        IFEND;

      WHILEND /crack_file_assign_message/;

      IF descriptor_station = osc$null_name THEN
        descriptor_station := station;
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
    IFEND;

    IF NOT address_specified THEN
      osp$set_status_abnormal (nfc$status_id, nfe$invalid_parameter_value,
            'No BTFS/DI ADDRESS or TITLE Specified', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'file_assignment', status);
      RETURN; {----->
    IFEND;

    IF (descriptor_destination_usage = jmc$public_usage) OR
          (descriptor_destination_usage = jmc$private_usage) THEN
      descriptor.file_kind := nfc$output_file;
    ELSEIF descriptor_destination_usage = jmc$ntf_usage THEN
      IF device_type = nfc$ntf_job_transmitter THEN
        descriptor.file_kind := nfc$input_file;
      ELSEIF device_type = nfc$ntf_sysout_transmitter THEN
        descriptor.file_kind := nfc$output_file;
      ELSEIF device_type = nfc$reader THEN
        descriptor.file_kind := nfc$input_file;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$invalid_parameter_value, 'nfc$device_type', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'file_assignment', status);
        RETURN; {----->
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$invalid_parameter_value, 'destination_usage', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'file_assignment', status);
      RETURN; {----->
    IFEND;

    CASE descriptor.file_kind OF

    = nfc$output_file =

      descriptor.output_descriptor.copies := descriptor_copies;
      descriptor.output_descriptor.device := descriptor_device;
      descriptor.output_descriptor.external_characteristics := descriptor_ext_characteristics;
      descriptor.output_descriptor.forms_code := descriptor_forms_code;
      descriptor.output_descriptor.output_destination_family := descriptor_destination_family;
      descriptor.output_descriptor.output_destination_usage := descriptor_destination_usage;
      descriptor.output_descriptor.output_priority := descriptor_output_priority;
      descriptor.output_descriptor.station := descriptor_station;
      descriptor.output_descriptor.station_operator := descriptor_station_operator;
      descriptor.output_descriptor.vertical_print_density := descriptor_vert_print_density;
      descriptor.output_descriptor.vfu_load_procedure := descriptor_vfu_load_procedure;

    = nfc$input_file =

      descriptor.input_descriptor.copies := descriptor_copies;
      descriptor.input_descriptor.device := descriptor_device;
      descriptor.input_descriptor.external_characteristics := descriptor_ext_characteristics;
      descriptor.input_descriptor.forms_code := descriptor_forms_code;
      descriptor.input_descriptor.output_destination_family := descriptor_destination_family;
      descriptor.input_descriptor.job_destination_usage := descriptor_destination_usage;
      descriptor.input_descriptor.output_priority := descriptor_output_priority;
      descriptor.input_descriptor.station := descriptor_station;
      descriptor.input_descriptor.station_operator := descriptor_station_operator;
      descriptor.input_descriptor.vertical_print_density := descriptor_vert_print_density;
      descriptor.input_descriptor.vfu_load_procedure := descriptor_vfu_load_procedure;

    ELSE
    CASEND;

  PROCEND nfp$crack_file_assignment_msg;
?? TITLE := 'nfp$create_appl_def_segment_var', EJECT ??
*copy nfh$create_appl_def_segment_var

  PROCEDURE [XDCL] nfp$create_appl_def_segment_var
    (application: nft$appl_def_segment_values;
     application_defined_segment: ^cell);

    VAR
      nfv$appl_def_segment_variables: [XDCL, STATIC, READ, nfs$appl_def_segment_variables]
            ARRAY [nft$appl_def_segment_values] OF string (osc$max_name_size) :=
            ['NFV$APPL_DEF_SEGMENT_FOR_BTF', 'NFV$APPL_DEF_SEGMENT_FOR_NTF',
            'NFV$APPL_DEF_SEGMENT_FOR_QTF', 'NFV$APPL_DEF_SEGMENT_FOR_QTFS',
            'NFV$APPL_DEF_SEGMENT_FOR_SCF', 'NFV$APPL_DEF_SEGMENT_FOR_SCFS'];

    VAR
      appl_defined_segment_number: array [1 .. 1] of clt$integer,
      local_status: ost$status,
      variable_reference: clt$variable_reference,
      variable_scope: clt$variable_scope,
      variable_value: clt$variable_value;

    variable_scope.kind := clc$job_variable;
    clp$create_variable (nfv$appl_def_segment_variables [application], clc$integer_value, 0, 1, 1,
          variable_scope, variable_reference, local_status);
    IF local_status.normal OR (NOT local_status.normal AND (local_status.condition =
          cle$var_already_created)) THEN
      appl_defined_segment_number [1].value := (#ring(application_defined_segment) * 100000000000(16)) +
            (#segment(application_defined_segment) * 100000000(16));
      appl_defined_segment_number [1].radix := 16;
      appl_defined_segment_number [1].radix_specified := TRUE;
      variable_value.kind := clc$integer_value;
      variable_value.integer_value := ^appl_defined_segment_number;
      clp$write_variable (nfv$appl_def_segment_variables [application], variable_value, local_status);
    IFEND;
  PROCEND nfp$create_appl_def_segment_var;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$crack_terqo_msg', EJECT ??
*copyc nfh$crack_terqo_msg

  PROCEDURE [XDCL] nfp$crack_terqo_msg
    (VAR message: ^nft$message_sequence;
     VAR message_length: integer;
     VAR io_station_name: ost$name;
     VAR system_file_name: ost$name;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      byte_array: ^nft$byte_array,
      parameter: ^nft$term_queue_output_parameter,
      value_length: integer;

*copyc nft$terminate_queued_output_msg
?? EJECT ??
    status.normal := TRUE;
    io_station_name := osc$null_name;
    system_file_name := osc$null_name;

    NEXT parameter IN message;
    IF parameter <> NIL THEN

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
            (message_length > 0) DO
        message_length := message_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, message_length, value_length, status);
          IF status.normal THEN
            message_length := message_length - value_length;
          ELSE
            RETURN; {----->
          IFEND;
        ELSE
          value_length := 1;
          message_length := message_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, io_station_name);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        = nfc$system_user_file_name =
          NEXT ascii_string: [value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, ascii_string^, system_file_name);
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;

        ELSE

{         ERROR ----   Ignore parameter value.

          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
        IF parameter = NIL THEN
          osp$set_status_abnormal (nfc$status_id,
                nfe$outside_bounds_of_sequence, ' ', status);
          RETURN; {----->
        IFEND;
      WHILEND;
    IFEND;

  PROCEND nfp$crack_terqo_msg;
?? TITLE := 'nfp$create_wait_queue_file_name', EJECT ??
*copy nfh$create_wait_queue_file_name

  PROCEDURE [XDCL] nfp$create_wait_queue_file_name
    (    family_name: ost$name;
         user_name: ost$name;
         user_file_name: jmt$user_supplied_name;
     VAR local_wait_queue_file_name: amt$local_file_name;
     VAR status: ost$status);

    CONST
      nfc$wait_queue_name = '$WAIT_QUEUE';

    VAR
      cycle_number: pft$cycle_selector,
      path_seq: ^SEQ ( * ),
      queue_path_name: ^pft$path,
      temp_wait_q_file_name: fst$path,
      temp_wait_q_file_name_length: fst$path_size;


    PUSH path_seq: [[REP 4 OF pft$name]];

    RESET path_seq;
    NEXT queue_path_name: [1 .. 3] IN path_seq;
    queue_path_name^ [1] := family_name;
    queue_path_name^ [2] := user_name;
    queue_path_name^ [3] := nfc$wait_queue_name;

    pfp$define_catalog (queue_path_name^, status);
    IF status.normal OR ((NOT status.normal) AND (status.condition = pfe$name_already_subcatalog)) THEN
      RESET path_seq;
      NEXT queue_path_name: [1 .. 4] IN path_seq;
      queue_path_name^ [4] := user_file_name;
      cycle_number.cycle_option := pfc$highest_cycle;
      pmp$get_unique_name (local_wait_queue_file_name, status);
      IF status.normal THEN
        pfp$define (local_wait_queue_file_name, queue_path_name^, cycle_number, osc$null_name,
              pfc$maximum_retention, pfc$no_log, status);
      IFEND;
    IFEND;

  PROCEND nfp$create_wait_queue_file_name;
?? TITLE := 'nfp$delete_btf_task', EJECT ??
*copy nfh$delete_btf_task

  PROCEDURE [XDCL] nfp$delete_btf_task
    (    list_index: integer;
         wait_activity_list {input, output} : ^nft$wait_activity_list;
     VAR btf_task {input, output} : ^nft$btf_task);

    VAR
      link_task: ^nft$btf_task;


    IF wait_activity_list^ [list_index].btf_task_list = btf_task THEN
      wait_activity_list^ [list_index].btf_task_list := btf_task^.link;
      IF wait_activity_list^ [list_index].btf_task_list <> NIL THEN
        wait_activity_list^ [list_index].btf_task_list^.back_link := NIL;
      IFEND;
    ELSE
      btf_task^.back_link^.link := btf_task^.link;
    IFEND;

    IF btf_task^.link <> NIL THEN
      btf_task^.link^.back_link := btf_task^.back_link;
    IFEND;

    link_task := btf_task^.link;
    FREE btf_task;

    btf_task := link_task;

  PROCEND nfp$delete_btf_task;
?? TITLE := 'nfp$establish_cf_connection', EJECT ??
*copy nfh$establish_cf_connection

  PROCEDURE [XDCL] nfp$establish_cf_connection
    (    service_address: nat$network_address;
         connect_file: fst$file_reference;
         client_version: 0 .. 0ff(16);
         client_identifier: string (* <= nfc$max_scfs_client_id_length);
         client_name: nat$application_name;
     VAR control_facility_name: ost$name;
     VAR connection_identifier: amt$file_identifier;
     VAR status: ost$status);

    CONST
      half_minute = 30000; { 30000 milliseconds }

    VAR
      attributes: ^nat$create_attributes,
      client: ^nft$scfs_client_identifier,
      client_identifier_length: nfc$min_scfs_client_id_length .. nfc$max_scfs_client_id_length,
      connect_data: ^SEQ ( * ),
      control_facility: ^ost$name,
      local_status: ost$status,
      mandated_attributes: [STATIC, READ] array [1 .. 1] of fst$file_cycle_attribute :=
            [[fsc$file_organization, amc$sequential]],
      peer_attributes: ^nat$get_attributes;


    status.normal := TRUE;

{  Set up connection data and attributes. }

    client_identifier_length := STRLENGTH (client_identifier);

    PUSH connect_data: [[REP (client_identifier_length + 1) OF cell]];
    NEXT client: [client_identifier_length] IN connect_data;
    client^.data_version := client_version;
    client^.identifier := client_identifier;

    PUSH attributes: [1 .. 1];
    attributes^ [1].kind := nac$connect_data;
    attributes^ [1].connect_data := connect_data;

{  Request a connection to be established with the server application (SCFS). }

    nap$request_connection (service_address, client_name, connect_file, nac$cdna_session, attributes,
          half_minute, status);
    IF status.normal THEN

{  Determine if the server has responded to the requested connection.  }

      nap$await_server_response (connect_file, half_minute, status);
      IF status.normal THEN

{  The connection was accepted by the server within the time limit.  }

        fsp$open_file (connect_file, amc$record, NIL, NIL, NIL, ^mandated_attributes, NIL,
              connection_identifier, status);
        IF status.normal THEN

          PUSH peer_attributes: [1 .. 1];
          peer_attributes^ [1].kind := nac$peer_connect_data;
          PUSH peer_attributes^ [1].peer_connect_data: [[REP osc$max_name_size OF cell]];

{  Obtain the peer connection attribute values that are in use for this
{  connection. }

          nap$get_attributes (connect_file, peer_attributes^, status);
          IF status.normal THEN
            RESET peer_attributes^ [1].peer_connect_data;
            NEXT control_facility IN peer_attributes^ [1].peer_connect_data;
            control_facility_name := control_facility^ (1, peer_attributes^ [1].peer_connect_data_length);
          IFEND;
        IFEND;
      ELSE

{  The server didn't respond within the specified time limit or the connection
{  was rejected.  Detach the network file that identifies the connection.

        amp$return (connect_file, local_status);
      IFEND;
    IFEND;

  PROCEND nfp$establish_cf_connection;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$get_btfs_di_address', EJECT ??

*copyc nfh$get_btfs_di_address

  PROCEDURE [XDCL] nfp$get_btfs_di_address
    (    title: nft$btfs_di_title;
         client: nat$application_name;
         station: ost$name;
         device: ost$name;
         wait_list: ^ost$i_wait_list;
         wait_activity_list: ^nft$wait_activity_list;
     VAR network_address: nat$network_address;
     VAR status: ost$status);

    CONST
      wait_time = 10 * 1000;

    VAR
      attributes: ^nat$translation_attributes,
      ignore_status: ost$status,
      message: string(80),
      message_length: integer,
      search_identifier: ^nat$directory_search_identifier,
      title_pattern: ^nat$title_pattern;

     status.normal := TRUE;

    attributes := NIL;
    PUSH search_identifier;
    PUSH title_pattern: [title.length];
    title_pattern^ := title.title;

    nap$begin_directory_search (title_pattern^, client, FALSE,
          search_identifier^, status);
    IF status.normal THEN
      nap$get_title_translation (search_identifier^, wait_time, attributes,
            network_address, status);
      nap$end_directory_search (search_identifier^, ignore_status);
    IFEND;

    IF NOT status.normal THEN
      STRINGREP (message, message_length, '**** BTFS/DI title not translated: ',
          title_pattern^);
      pmp$log (message (1, message_length), ignore_status);
    IFEND;

  PROCEND nfp$get_btfs_di_address;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$get_connection_data', EJECT ??
*copy nfh$get_connection_data

  PROCEDURE [XDCL] nfp$get_connection_data
    (    message: ^nft$message_sequence;
         connection_identifier: amt$file_identifier;
     VAR peer_operation: nat$se_peer_operation;
     VAR activity_status: ost$activity_status;
     VAR status: ost$status);

    VAR
      connect_data: ^nat$data_fragments;


    status.normal := TRUE;

    PUSH connect_data: [1 .. 1];

    connect_data^ [1].address := message;
    connect_data^ [1].length := #SIZE (message^);

    nap$se_receive_data (connection_identifier, connect_data^, osc$nowait, peer_operation, activity_status,
          status);

  PROCEND nfp$get_connection_data;
?? TITLE := 'nfp$get_parameter_value_length', EJECT ??
*copy nfh$get_parameter_value_length

  PROCEDURE [XDCL] nfp$get_parameter_value_length
    (VAR message {input} : ^nft$message_sequence;
     VAR message_length {input, output} : integer;
     VAR parameter_value_length: integer;
     VAR status: ost$status);

    VAR
      index: integer,
      length_bytes: ^array [1 .. * ] of 0 .. 0ff(16),
      parameter_length: ^nft$parameter_value_length;


    status.normal := TRUE;

    NEXT parameter_length IN message;
    IF parameter_length <> NIL THEN
      message_length := message_length - 1;
      IF NOT parameter_length^.long_length THEN
        parameter_value_length := parameter_length^.length;
      ELSE
        NEXT length_bytes: [1 .. parameter_length^.length] IN message;
        IF length_bytes <> NIL THEN
          parameter_value_length := 0;
          FOR index := 1 TO parameter_length^.length DO
            parameter_value_length := parameter_value_length * 100(16) + length_bytes^ [index];
          FOREND;
          message_length := message_length - parameter_length^.length;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        IFEND;
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
    IFEND;

  PROCEND nfp$get_parameter_value_length;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$ptf_format_message_to_out', EJECT ??

  PROCEDURE [XDCL] nfp$ptf_format_message_to_out
    (    status: ost$status);

{
{ Procedure  nfp$ptf_format_message_to_out
{
{ Purpose    To translate a variable of type OST$STATUS and write the
{            value to the job log.
{
{ Description
{            If you think this routine looks a lot like an example in
{            CYBIL for NOS/VE System Interface, it is.
{
{ Input parameters
{            Status        : Input status value
{
{ Output parameters
{            NONE...
{
{ Algorithm
{            Translate message to string
{            For i = 1 to # of message pieces Do
{              Pmp$log( message piece)
{            Forend
{
?? EJECT ??
{}

    VAR
      local_status: ost$status,
      output_file_id: amt$file_identifier;

    clp$get_system_file_id(       clc$standard_output,
                                  output_file_id,
                                  local_status);
    osp$generate_message(status, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;
    amp$flush (output_file_id, osc$wait, local_status);
{}
  PROCEND nfp$ptf_format_message_to_out;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$network_addresses_match', EJECT ??
*copy nfh$network_addresses_match

  FUNCTION [XDCL] nfp$network_addresses_match
    (    first: nat$network_address;
         second: nat$network_address): boolean;

{ Following types must be reworked if
{ nac$osi_max_network_addres_len <> 20, or
{ if last portion of network address changes from:
{   subnetwork - 2 bytes
{   system_id  - 6 bytes
{   sap        - 1 byte

    CONST
      osi_network_address_tail_size = 2 + 6 + 1;

    TYPE
      osi_network_address_seq_type = record
        case boolean of
        = FALSE =
          sequence: SEQ (REP 20 of cell),
        = TRUE =
          bytes: string (20),
        casend,
      recend,

      osi_network_address_tail_type = record
        case boolean of
        = FALSE =
          subnetwork: 0 .. 0ffff(16),
          system: system_id_type,
          sap: 0 .. 0ff(16),
        = TRUE =
          bytes: string (osi_network_address_tail_size),
        casend,
      recend,

      system_id_type = 0 .. 0ffffffffffff(16);

    VAR
      first_system_id: system_id_type,
      second_system_id: system_id_type,
      status: ost$status;

?? NEWTITLE := 'get_system_id', EJECT ??

{ PURPOSE:
{   This procedure extracts the system ID from a network address.

    PROCEDURE get_system_id
      (    address: nat$network_address;
       VAR system_id: system_id_type;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status,
        osi_network_address_seq: osi_network_address_seq_type,
        osi_network_address_tail: osi_network_address_tail_type;

      status.normal := TRUE;

      IF address.kind = nac$osi_transport_address THEN
        IF address.osi_transport_address.network_address_length >= osi_network_address_tail_size THEN
          osi_network_address_seq.sequence := address.osi_transport_address.network_address;
          osi_network_address_tail.bytes := osi_network_address_seq.
                bytes (address.osi_transport_address.network_address_length - osi_network_address_tail_size +
                1, osi_network_address_tail_size);
          system_id := osi_network_address_tail.system;
        ELSE
          pmp$log ('**** SCF(S): OSI network address too short.', ignore_status);
          status.normal := FALSE;
        IFEND;
      ELSEIF address.kind = nac$internet_address THEN
        system_id := address.internet_address.system;
      ELSE
        pmp$log ('**** SCF(S): Unknown network address kind.', ignore_status);
        status.normal := FALSE;
      IFEND;

    PROCEND get_system_id;
?? OLDTITLE, EJECT ??

    nfp$network_addresses_match := FALSE;

    get_system_id (first, first_system_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_system_id (second, second_system_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nfp$network_addresses_match := first_system_id = second_system_id;

  FUNCEND nfp$network_addresses_match;
?? OLDTITLE ??
?? TITLE := 'nfp$put_parameter_value_length', EJECT ??
*copy nfh$put_parameter_value_length

  PROCEDURE [XDCL] nfp$put_parameter_value_length
    (    parameter_value: integer;
     VAR message {input,output} : ^nft$message_sequence;
     VAR parameter_length_size: nft$message_length;
     VAR status: ost$status);

    TYPE
      byte = 0 .. 0ff(16);

    VAR
      byte_count: integer,
      length_byte: ^byte,
      parameter_length: ^nft$parameter_value_length,
      value: integer;


    status.normal := TRUE;

    NEXT parameter_length IN message;
    IF parameter_length <> NIL THEN
      parameter_length_size := #SIZE (parameter_length^);

      IF parameter_value <= nfc$max_parameter_short_length THEN
        parameter_length^.long_length := FALSE;
        parameter_length^.length := parameter_value;
      ELSE
        parameter_length^.long_length := TRUE;
        value := parameter_value;
        byte_count := 0;

      /put_value_into_message/
        WHILE value > 0 DO
          NEXT length_byte IN message;
          IF length_byte <> NIL THEN
            byte_count := byte_count + 1;
            IF (parameter_value < 100(16)) AND (byte_count = 1) THEN
              length_byte^ := 0;
            ELSE
              length_byte^ := value MOD 100(16);
              value := value DIV 100(16);
            IFEND;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;
        WHILEND /put_value_into_message/;

        parameter_length^.length := byte_count;
        parameter_length_size := parameter_length_size + byte_count;
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
    IFEND;

  PROCEND nfp$put_parameter_value_length;
?? TITLE := 'nfp$remove_from_wait_lists', EJECT ??
*copy nfh$remove_from_wait_lists

  PROCEDURE [XDCL] nfp$remove_from_wait_lists
    (    index: integer;
     VAR wait_list {input, output} : ^ost$i_wait_list;
     VAR wait_activity_list {input, output} : ^nft$wait_activity_list;
     VAR wait_list_sequence {input, output} : ^SEQ ( * );
     VAR wait_activity_list_sequence {input, output} : ^SEQ ( * ));

    VAR
      last_index: integer;


    IF index <> 0 THEN
      IF wait_activity_list^ [index].kind = nfc$control_facility_connection THEN
        FREE wait_activity_list^ [index].cf;
      IFEND;
      last_index := UPPERBOUND (wait_list^);
      IF (last_index >= nfc$wait_activity_list_lowest + 1) AND (last_index <> index) THEN
        wait_list^ [index] := wait_list^ [last_index];
        wait_activity_list^ [index] := wait_activity_list^ [last_index];
        IF wait_activity_list^ [index].kind = nfc$control_facility_connection THEN
          wait_activity_list^ [index].cf^.wait_activity_index := index;
        IFEND;
      IFEND;

      RESET wait_list_sequence;
      NEXT wait_list: [1 .. (last_index - 1)] IN wait_list_sequence;

      IF index > nfc$wait_activity_list_lowest THEN
        RESET wait_activity_list_sequence;
        NEXT wait_activity_list: [nfc$wait_activity_list_lowest .. (last_index - 1)]
              IN wait_activity_list_sequence;
      IFEND;
    IFEND;

  PROCEND nfp$remove_from_wait_lists;
?? TITLE := 'nfp$send_add_file_available', EJECT ??
*copy nfh$send_add_file_available

  PROCEDURE [XDCL] nfp$send_add_file_available
    (    descriptor: nft$application_file_descriptor;
         file_state: nft$file_transfer_state;
         connection_identifier: amt$file_identifier;
     VAR message {input, output} : ^nft$message_sequence;
     VAR status: ost$status);

    VAR
      message_length: integer;

?? NEWTITLE := '  build_add_file_available_msg', EJECT ??

{  PURPOSE:
{    The purpose of this request is to put the actual parameters for the add
{    file available message into the message sequence.

    PROCEDURE build_add_file_available_msg
      (    descriptor: nft$application_file_descriptor;
           file_state: nft$file_transfer_state;
       VAR message: ^nft$message_sequence;
       VAR message_length: integer;
       VAR status: ost$status);

*copy nft$file_availability_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        copies: ^nft$copies,
        descriptor_copies: jmt$output_copy_count,
        descriptor_data_mode: jmt$data_mode,
        descriptor_device: jmt$output_device,
        descriptor_device_type: nft$device_type,
        descriptor_ext_characteristics: jmt$external_characteristics,
        descriptor_file_size: jmt$output_file_size,
        descriptor_forms_code: jmt$forms_code,
        descriptor_output_priority: jmt$output_priority,
        device_type: ^nft$device_type,
        file_size: ^nft$file_size,
        output_data_mode: ^nft$output_data_mode,
        output_state: ^nft$file_transfer_state,
        page_format: ^nft$page_format,
        page_length: ^nft$page_length,
        page_width: ^nft$page_width,
        parameter_kind: ^nft$file_available_msg_param,
        parameter_kind_size: nft$message_length,
        parameter_length_size: nft$message_length,
        parameter_value_length: integer,
        priority: ^nft$priority,
        vertical_print_density: ^nft$file_vertical_print_density,
        vfu_load_procedure: ^nft$vfu_load_procedure;


      status.normal := TRUE;

      CASE descriptor.file_kind OF

      = nfc$output_file =

        descriptor_copies := descriptor.output_descriptor.copies;
        descriptor_data_mode := descriptor.output_descriptor.data_mode;
        descriptor_device := descriptor.output_descriptor.device;
        IF descriptor.output_descriptor.output_destination_usage = jmc$ntf_usage THEN
          descriptor_device_type := nfc$ntf_sysout_transmitter;
        ELSEIF (descriptor.output_descriptor.output_destination_usage = jmc$public_usage) OR
              (descriptor.output_descriptor.output_destination_usage = jmc$private_usage) THEN
          CASE descriptor.output_descriptor.device_type OF
          = jmc$output_device_printer =
            descriptor_device_type := nfc$printer;
          = jmc$output_device_plotter =
            descriptor_device_type := nfc$plotter;
          = jmc$output_device_punch =
            descriptor_device_type := nfc$punch;
          CASEND;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$invalid_descriptor_value, 'output_destination_usage',
                status);
          RETURN; {----->
        IFEND;
        descriptor_ext_characteristics := descriptor.output_descriptor.external_characteristics;
        descriptor_file_size := descriptor.output_descriptor.file_size;
        descriptor_forms_code := descriptor.output_descriptor.forms_code;
        descriptor_output_priority := descriptor.output_descriptor.output_priority;

      = nfc$input_file =

        descriptor_copies := descriptor.input_descriptor.copies;
        descriptor_data_mode := descriptor.input_descriptor.data_mode;
        IF descriptor.input_descriptor.job_destination_usage = jmc$ntf_usage THEN
          descriptor_device := 'AUTOMATIC';
          descriptor_device_type := nfc$ntf_job_transmitter;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$invalid_descriptor_value, 'job_destination_usage',
                status);
          RETURN; {----->
        IFEND;
        descriptor_ext_characteristics := descriptor.input_descriptor.external_characteristics;
        descriptor_file_size := descriptor.input_descriptor.job_size;
        descriptor_forms_code := descriptor.input_descriptor.forms_code;
        descriptor_output_priority := descriptor.input_descriptor.output_priority;
      ELSE
        ;
      CASEND;

      parameter_kind_size := #SIZE (nft$file_available_msg_param);

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.length_indicated := TRUE;
        parameter_kind^.param := nfc$copies;
        parameter_value_length := #SIZE (nft$copies);
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF status.normal THEN
          NEXT copies IN message;
          IF copies <> NIL THEN
            copies^ := descriptor_copies;
            message_length := message_length + parameter_kind_size + parameter_length_size +
                  parameter_value_length;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;
        ELSE
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.param := nfc$device_name;
        parameter_value_length := clp$trimmed_string_size (descriptor_device);
        nfp$modify_param_value_length (parameter_value_length);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          parameter_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        IF ascii_string <> NIL THEN
          #TRANSLATE (osv$lower_to_upper, descriptor_device (1, parameter_value_length), ascii_string^);
          message_length := message_length + parameter_kind_size + parameter_length_size +
                parameter_value_length;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$device_type;
        NEXT device_type IN message;
        IF device_type <> NIL THEN
          device_type^ := descriptor_device_type;
          message_length := message_length + parameter_kind_size + 1;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.param := nfc$external_characteristics;
        parameter_value_length := clp$trimmed_string_size (descriptor_ext_characteristics);
        nfp$modify_param_value_length (parameter_value_length);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          parameter_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        IF ascii_string <> NIL THEN
          #TRANSLATE (osv$lower_to_upper, descriptor_ext_characteristics (1, parameter_value_length),
                ascii_string^);
          message_length := message_length + parameter_kind_size + parameter_length_size +
                parameter_value_length;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.length_indicated := TRUE;
        parameter_kind^.param := nfc$file_size;
        parameter_value_length := #SIZE (nft$file_size);
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF status.normal THEN
          NEXT file_size IN message;
          IF file_size <> NIL THEN
            file_size^ := descriptor_file_size;
            message_length := message_length + parameter_kind_size + parameter_length_size +
                  parameter_value_length;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;
        ELSE
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.param := nfc$forms_code;
        parameter_value_length := clp$trimmed_string_size (descriptor_forms_code);
        nfp$modify_param_value_length (parameter_value_length);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          parameter_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        IF ascii_string <> NIL THEN
          #TRANSLATE (osv$lower_to_upper, descriptor_forms_code (1, parameter_value_length), ascii_string^);
          message_length := message_length + parameter_kind_size + parameter_length_size +
                parameter_value_length;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$output_data_mode;
        NEXT output_data_mode IN message;
        IF output_data_mode <> NIL THEN
          CASE descriptor_data_mode OF
          = jmc$coded_data =
            output_data_mode^ := nfc$coded_mode;
          = jmc$transparent_data =
            output_data_mode^ := nfc$transparent_mode;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$invalid_descriptor_value, 'data_mode', status);
            RETURN; {----->
          CASEND;
          message_length := message_length + parameter_kind_size + 1;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.length_indicated := TRUE;
        parameter_kind^.param := nfc$output_initial_priority;
        parameter_value_length := #SIZE (nft$priority);
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF status.normal THEN
          NEXT priority IN message;
          IF priority <> NIL THEN
            priority^ := nfc$minimum_priority;
            IF descriptor_output_priority = 'LOW' THEN
              priority^ := priority^ +nfc$low_output_priority;
            ELSEIF descriptor_output_priority = 'MEDIUM' THEN
              priority^ := priority^ +nfc$medium_output_priority;
            ELSEIF descriptor_output_priority = 'HIGH' THEN
              priority^ := priority^ +nfc$high_output_priority;
            IFEND;
            message_length := message_length + parameter_kind_size + parameter_length_size +
                  parameter_value_length;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;
        ELSE
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.length_indicated := TRUE;
        parameter_kind^.param := nfc$output_maximum_priority;
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF status.normal THEN
          NEXT priority IN message;
          IF priority <> NIL THEN
            priority^ := nfc$maximum_priority;
            message_length := message_length + parameter_kind_size + parameter_length_size +
                  parameter_value_length;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;
        ELSE
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.length_indicated := TRUE;
        parameter_kind^.param := nfc$output_priority_factor;
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF status.normal THEN
          NEXT priority IN message;
          IF priority <> NIL THEN
            priority^ := 1;
            message_length := message_length + parameter_kind_size + parameter_length_size +
                  parameter_value_length;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;
        ELSE
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$output_state;
        NEXT output_state IN message;
        IF output_state <> NIL THEN
          output_state^ := file_state;
          message_length := message_length + parameter_kind_size + 1;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$page_width;
        NEXT page_width IN message;
        IF page_width <> NIL THEN
          page_width^ := descriptor.output_descriptor.page_width;
          message_length := message_length + parameter_kind_size + 1;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;

      IF device_type^ = nfc$printer THEN
        NEXT parameter_kind IN message;
        IF parameter_kind <> NIL THEN
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$page_format;
          NEXT page_format IN message;
          IF page_format <> NIL THEN
            page_format^ := descriptor.output_descriptor.page_format;
            message_length := message_length + parameter_kind_size + 1;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
          RETURN; {----->
        IFEND;

        NEXT parameter_kind IN message;
        IF parameter_kind <> NIL THEN
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$page_length;
          NEXT page_length IN message;
          IF page_length <> NIL THEN
            page_length^ := descriptor.output_descriptor.page_length;
            message_length := message_length + parameter_kind_size + 1;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
          RETURN; {----->
        IFEND;

        NEXT parameter_kind IN message;
        IF parameter_kind <> NIL THEN
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$vertical_print_density;
          NEXT vertical_print_density IN message;
          IF vertical_print_density <> NIL THEN
            CASE descriptor.output_descriptor.vertical_print_density OF
            = jmc$vertical_print_density_none =
              vertical_print_density^ := nfc$vertical_print_density_none;
            = jmc$vertical_print_density_6 =
              vertical_print_density^ := nfc$vertical_print_density_6;
            = jmc$vertical_print_density_7 =
              vertical_print_density^ := nfc$vertical_print_density_7;
            = jmc$vertical_print_density_8 =
              vertical_print_density^ := nfc$vertical_print_density_8;
            = jmc$vertical_print_density_9 =
              vertical_print_density^ := nfc$vertical_print_density_9;
            = jmc$vertical_print_density_10 =
              vertical_print_density^ := nfc$vertical_print_density_10;
            = jmc$vertical_print_density_11 =
              vertical_print_density^ := nfc$vertical_print_density_11;
            = jmc$vertical_print_density_12 =
              vertical_print_density^ := nfc$vertical_print_density_12;
            ELSE
              osp$set_status_abnormal (nfc$status_id, nfe$invalid_descriptor_value, 'vertical_print_density',
                    status);
              RETURN; {----->
            CASEND;
            message_length := message_length + parameter_kind_size + 1;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
          RETURN; {----->
        IFEND;

        NEXT parameter_kind IN message;
        IF parameter_kind <> NIL THEN
          parameter_kind^.param := nfc$vfu_load_procedure;
          parameter_value_length := clp$trimmed_string_size
                (descriptor.output_descriptor.vfu_load_procedure);
          nfp$modify_param_value_length (parameter_value_length);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSE
            parameter_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          IF ascii_string <> NIL THEN
            #TRANSLATE (osv$lower_to_upper, descriptor.output_descriptor.
                  vfu_load_procedure (1, parameter_value_length), ascii_string^);
            message_length := message_length + parameter_kind_size + parameter_length_size +
                  parameter_value_length;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
          RETURN; {----->
        IFEND;
      IFEND;

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$null_parameter;
        message_length := message_length + parameter_kind_size;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      IFEND;

    PROCEND build_add_file_available_msg;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    set_up_required_msg_params (descriptor, nfc$add_file_availability, message, message_length, status);
    IF status.normal THEN
      build_add_file_available_msg (descriptor, file_state, message, message_length, status);
      IF status.normal THEN
        nfp$send_message_on_connection (message, message_length, connection_identifier, status);
      IFEND;
    IFEND;

  PROCEND nfp$send_add_file_available;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_btf_ve_status', EJECT ??
*copy nfh$send_btf_ve_status

  PROCEDURE [XDCL] nfp$send_btf_ve_status
    (    connection_identifier: amt$file_identifier;
     VAR message: ^nft$message_sequence;
     VAR status: ost$status);

*copy nft$btf_ve_status_message

    VAR
      message_length: integer,
      message_type: ^nft$message_kind,
      parameter_kind: ^nft$btf_ve_status_parameter,
      parameter_kind_size: nft$message_length,
      parameter_length_size: nft$message_length,
      parameter_value_length: integer,
      protocol_stacks: ^nat$protocol_stack_integer;

    status.normal := TRUE;
    RESET message;
    parameter_kind_size := #SIZE (nft$btf_ve_status_parameter);

    NEXT message_type IN message;
    IF message_type <> NIL THEN
      message_type^ := nfc$btf_ve_status;
      message_length := 1;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence,
            ' ', status);
      RETURN; {----->
    IFEND;

    NEXT parameter_kind IN message;
    IF parameter_kind <> NIL THEN
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$btf_ve_protocol_stacks;
      NEXT protocol_stacks IN message;
      IF protocol_stacks <> NIL THEN
        protocol_stacks^ := nap$supported_protocol_stacks ();
        message_length := message_length + parameter_kind_size + 1;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence,
              ' ', status);
        RETURN; {----->
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence,
            ' ', status);
      RETURN; {----->
    IFEND;

    IF status.normal THEN
      nfp$send_message_on_connection (message, message_length,
            connection_identifier, status);
    IFEND;

  PROCEND nfp$send_btf_ve_status;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_delete_file_available', EJECT ??
*copy nfh$send_delete_file_available

  PROCEDURE [XDCL] nfp$send_delete_file_available
    (    descriptor: nft$application_file_descriptor;
         file_held_by_filter: boolean;
         file_requeued: boolean;
         connection_identifier: amt$file_identifier;
     VAR message: ^nft$message_sequence;
     VAR status: ost$status);


    VAR
      destination_name: ost$name,
      message_length: integer;

?? NEWTITLE := '  build_delete_file_avail_msg', EJECT ??

{  PURPOSE:
{    The purpose of this request is to add the optional parameters
{    for the delete file available message to the message sequence.

    PROCEDURE build_delete_file_avail_msg
      (    file_requeued: boolean;
           file_held_by_filter: boolean;
       VAR message: ^nft$message_sequence;
       VAR message_length: integer;
       VAR status: ost$status);

*copy nft$file_availability_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        held: ^boolean,
        parameter_kind: ^nft$file_available_msg_param,
        parameter_kind_size: nft$message_length,
        parameter_length_size: nft$message_length,
        parameter_value_length: integer,
        requeued: ^boolean;


      status.normal := TRUE;
      parameter_kind_size := #SIZE (nft$file_available_msg_param);

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$file_requeued;
        NEXT requeued IN message;
        IF requeued <> NIL THEN
          requeued^ := file_requeued;
          message_length := message_length + parameter_kind_size + 1;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$file_held_by_filter;
        NEXT held IN message;
        IF held <> NIL THEN
          held^ := file_held_by_filter;
          message_length := message_length + parameter_kind_size + 1;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$null_parameter;
        message_length := message_length + parameter_kind_size;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;

    PROCEND build_delete_file_avail_msg;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    set_up_required_msg_params (descriptor, nfc$delete_file_availability, message, message_length, status);
    IF status.normal THEN
      build_delete_file_avail_msg (file_requeued, file_held_by_filter, message, message_length, status);
      IF status.normal THEN
        nfp$send_message_on_connection (message, message_length, connection_identifier, status);
      IFEND;
    IFEND;

  PROCEND nfp$send_delete_file_available;
?? TITLE := 'nfp$send_file_assignment_resp', EJECT ??
*copy nfh$send_file_assignment_resp

  PROCEDURE [XDCL] nfp$send_file_assignment_resp
    (    station: ost$name;
         device: ost$name;
         file_name: jmt$system_supplied_name;
         response_code: nft$file_assignment_response;
         connection_identifier: amt$file_identifier;
     VAR message: ^nft$message_sequence;
     VAR status: ost$status);

*copy nft$file_assignment_resp_msg

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      message_type: ^nft$message_kind,
      message_length: integer,
      parameter_kind: ^nft$file_assign_resp_parameter,
      parameter_kind_size: nft$message_length,
      parameter_length_size: nft$message_length,
      parameter_value_length: integer,
      resp_code: ^nft$file_assignment_response;


    status.normal := TRUE;
    parameter_kind_size := #SIZE (nft$file_assign_resp_parameter);
    RESET message;

    NEXT message_type IN message;
    IF message_type <> NIL THEN
      message_type^ := nfc$file_assignment_response;
      message_length := 1;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      RETURN; {----->
    IFEND;

    NEXT parameter_kind IN message;
    IF parameter_kind <> NIL THEN
      parameter_kind^.param := nfc$io_station_name;
      parameter_value_length := clp$trimmed_string_size (station);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        parameter_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      IF ascii_string <> NIL THEN
        #TRANSLATE (osv$lower_to_upper, station (1, parameter_value_length), ascii_string^);
        message_length := message_length + parameter_kind_size + parameter_length_size +
              parameter_value_length;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      RETURN; {----->
    IFEND;

    NEXT parameter_kind IN message;
    IF parameter_kind <> NIL THEN
      parameter_kind^.param := nfc$system_file_name;
      parameter_value_length := clp$trimmed_string_size (file_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        parameter_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      IF ascii_string <> NIL THEN
        #TRANSLATE (osv$lower_to_upper, file_name (1, parameter_value_length), ascii_string^);
        message_length := message_length + parameter_kind_size + parameter_length_size +
              parameter_value_length;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      RETURN; {----->
    IFEND;

    NEXT parameter_kind IN message;
    IF parameter_kind <> NIL THEN
      parameter_kind^.param := nfc$device_name;
      parameter_value_length := clp$trimmed_string_size (device);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        parameter_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      IF ascii_string <> NIL THEN
        #TRANSLATE (osv$lower_to_upper, device (1, parameter_value_length), ascii_string^);
        message_length := message_length + parameter_kind_size + parameter_length_size +
              parameter_value_length;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      RETURN; {----->
    IFEND;

    NEXT parameter_kind IN message;
    IF parameter_kind <> NIL THEN
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$response_code;
      NEXT resp_code IN message;
      IF resp_code <> NIL THEN
        resp_code^ := response_code;
        message_length := message_length + parameter_kind_size + 1;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      RETURN; {----->
    IFEND;

    NEXT parameter_kind IN message;
    IF parameter_kind <> NIL THEN
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$null_parameter;
      message_length := message_length + parameter_kind_size;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      RETURN; {----->
    IFEND;

    nfp$send_message_on_connection (message, message_length, connection_identifier, status);

  PROCEND nfp$send_file_assignment_resp;
?? TITLE := 'nfp$send_message_on_connection', EJECT ??
*copy nfh$send_message_on_connection

  PROCEDURE [XDCL] nfp$send_message_on_connection
    (    message: ^nft$message_sequence;
         length: nft$message_length;
         connection_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      activity_status: ost$activity_status,
      data: ^nat$data_fragments;


    status.normal := TRUE;

    PUSH data: [1 .. 1];
    IF data = NIL THEN
      RETURN; {----->
    IFEND;

    data^ [1].address := message;
    data^ [1].length := length;

    nap$se_send_data (connection_identifier, data^, TRUE, FALSE, osc$wait, activity_status, status);

  PROCEND nfp$send_message_on_connection;
?? TITLE := 'nfp$send_modify_file_available', EJECT ??
*copy nfh$send_modify_file_available

  PROCEDURE [XDCL] nfp$send_modify_file_available
    (    modified_descriptor: nft$application_file_descriptor;
         descriptor: nft$application_file_descriptor;
         connection_identifier: amt$file_identifier;
     VAR message: ^nft$message_sequence;
     VAR status: ost$status);

    VAR
      message_length: integer;

?? NEWTITLE := '  build_modify_file_avaiable_msg', EJECT ??

{  PURPOSE:
{    The purpose of this request is to put the modified output attributes
{    into the message sequence.

    PROCEDURE build_modify_file_available_msg
      (    descriptor: nft$application_file_descriptor;
           modified_descriptor: nft$application_file_descriptor;
       VAR message: ^nft$message_sequence;
       VAR message_length: integer;
       VAR status: ost$status);

*copy nft$file_availability_msg

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        copies: ^nft$copies,
        output_data_mode: ^nft$output_data_mode,
        output_state: ^nft$file_transfer_state,
        page_format: ^nft$page_format,
        page_length: ^nft$page_length,
        page_width: ^nft$page_width,
        parameter_kind: ^nft$file_available_msg_param,
        parameter_kind_size: nft$message_length,
        parameter_length_size: nft$message_length,
        parameter_value_length: integer,
        vertical_print_density: ^nft$file_vertical_print_density,
        vfu_load_procedure: ^nft$vfu_load_procedure;

?? NEWTITLE := '    add_output_priority', EJECT ??

{  PURPOSE:
{    The purpose of this request is to add the output priority
{    into the message sequence.

    PROCEDURE add_output_priority
      (    output_priority: jmt$output_priority;
           parameter_kind_size: nft$message_length;
       VAR message: ^nft$message_sequence;
       VAR message_length: integer;
       VAR status: ost$status);

      VAR
        parameter_kind:  ^nft$file_available_msg_param,
        parameter_length_size: nft$message_length,
        parameter_value_length: integer,
        priority: ^nft$priority;

      status.normal := TRUE;

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.length_indicated := TRUE;
        parameter_kind^.param := nfc$output_initial_priority;
        parameter_value_length := #SIZE (nft$priority);
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF status.normal THEN
          NEXT priority IN message;
          IF priority <> NIL THEN
            priority^ := 100;
            IF output_priority = 'LOW' THEN
              priority^ := priority^ +nfc$low_output_priority;
            ELSEIF output_priority = 'MEDIUM' THEN
              priority^ := priority^ +nfc$medium_output_priority;
            ELSEIF output_priority = 'HIGH' THEN
              priority^ := priority^ +nfc$high_output_priority;
            IFEND;
            message_length := message_length + parameter_kind_size + parameter_length_size +
                  parameter_value_length;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;
        ELSE
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;

    PROCEND add_output_priority;
?? OLDTITLE, EJECT ??

      status.normal := TRUE;
      parameter_kind_size := #SIZE (nft$file_available_msg_param);

      CASE descriptor.file_kind OF

      = nfc$output_file =

        IF descriptor.output_descriptor.copies <> modified_descriptor.output_descriptor.copies THEN
          NEXT parameter_kind IN message;
          IF parameter_kind <> NIL THEN
            parameter_kind^.length_indicated := TRUE;
            parameter_kind^.param := nfc$copies;
            parameter_value_length := #SIZE (nft$copies);
            nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
            IF status.normal THEN
              NEXT copies IN message;
              IF copies <> NIL THEN
                copies^ := modified_descriptor.output_descriptor.copies;
                message_length := message_length + parameter_kind_size + parameter_length_size +
                      parameter_value_length;
              ELSE
                osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
                RETURN; {----->
              IFEND;
            ELSE
              RETURN; {----->
            IFEND;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;
        IFEND;

        IF descriptor.output_descriptor.device <> modified_descriptor.output_descriptor.device THEN
          NEXT parameter_kind IN message;
          IF parameter_kind <> NIL THEN
            parameter_kind^.param := nfc$device_name;
            parameter_value_length := clp$trimmed_string_size
                  (modified_descriptor.output_descriptor.device);
            nfp$modify_param_value_length (parameter_value_length);
            parameter_kind^.length_indicated := parameter_value_length > 1;
            IF parameter_kind^.length_indicated THEN
              nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            ELSE
              parameter_length_size := 0;
            IFEND;
            NEXT ascii_string: [parameter_value_length] IN message;
            IF ascii_string <> NIL THEN
              #TRANSLATE (osv$lower_to_upper, modified_descriptor.output_descriptor.
                    device (1, parameter_value_length), ascii_string^);
              message_length := message_length + parameter_kind_size + parameter_length_size +
                    parameter_value_length;
            ELSE
              osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
              RETURN; {----->
            IFEND;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;
        IFEND;

        IF descriptor.output_descriptor.external_characteristics <>
              modified_descriptor.output_descriptor.external_characteristics THEN
          NEXT parameter_kind IN message;
          IF parameter_kind <> NIL THEN
            parameter_kind^.param := nfc$external_characteristics;
            parameter_value_length := clp$trimmed_string_size
                  (modified_descriptor.output_descriptor.external_characteristics);
            nfp$modify_param_value_length (parameter_value_length);
            parameter_kind^.length_indicated := parameter_value_length > 1;
            IF parameter_kind^.length_indicated THEN
              nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            ELSE
              parameter_length_size := 0;
            IFEND;
            NEXT ascii_string: [parameter_value_length] IN message;
            IF ascii_string <> NIL THEN
              #TRANSLATE (osv$lower_to_upper, modified_descriptor.output_descriptor.
                    external_characteristics (1, parameter_value_length), ascii_string^);
              message_length := message_length + parameter_kind_size + parameter_length_size +
                    parameter_value_length;
            ELSE
              osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
              RETURN; {----->
            IFEND;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;
        IFEND;

        IF descriptor.output_descriptor.forms_code <> modified_descriptor.output_descriptor.forms_code THEN
          NEXT parameter_kind IN message;
          IF parameter_kind <> NIL THEN
            parameter_kind^.param := nfc$forms_code;
            parameter_value_length := clp$trimmed_string_size
                  (modified_descriptor.output_descriptor.forms_code);
            nfp$modify_param_value_length (parameter_value_length);
            parameter_kind^.length_indicated := parameter_value_length > 1;
            IF parameter_kind^.length_indicated THEN
              nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            ELSE
              parameter_length_size := 0;
            IFEND;
            NEXT ascii_string: [parameter_value_length] IN message;
            IF ascii_string <> NIL THEN
              #TRANSLATE (osv$lower_to_upper, modified_descriptor.output_descriptor.
                    forms_code (1, parameter_value_length), ascii_string^);
              message_length := message_length + parameter_kind_size + parameter_length_size +
                    parameter_value_length;
            ELSE
              osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
              RETURN; {----->
            IFEND;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;
        IFEND;

        IF descriptor.output_descriptor.output_priority <> modified_descriptor.output_descriptor.
              output_priority THEN
          add_output_priority (modified_descriptor.output_descriptor.output_priority,
                parameter_kind_size, message, message_length, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF descriptor.output_descriptor.vfu_load_procedure <>
              modified_descriptor.output_descriptor.vfu_load_procedure THEN
          NEXT parameter_kind IN message;
          IF parameter_kind <> NIL THEN
            parameter_kind^.param := nfc$vfu_load_procedure;
            parameter_value_length := clp$trimmed_string_size
                  (modified_descriptor.output_descriptor.vfu_load_procedure);
            nfp$modify_param_value_length (parameter_value_length);
            parameter_kind^.length_indicated := parameter_value_length > 1;
            IF parameter_kind^.length_indicated THEN
              nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            ELSE
              parameter_length_size := 0;
            IFEND;
            NEXT ascii_string: [parameter_value_length] IN message;
            IF ascii_string <> NIL THEN
              #TRANSLATE (osv$lower_to_upper, modified_descriptor.output_descriptor.
                    vfu_load_procedure (1, parameter_value_length), ascii_string^);
              message_length := message_length + parameter_kind_size + parameter_length_size +
                    parameter_value_length;
            ELSE
              osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
              RETURN; {----->
            IFEND;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;
        IFEND;

        IF descriptor.output_descriptor.vertical_print_density <>
              modified_descriptor.output_descriptor.vertical_print_density THEN
          NEXT parameter_kind IN message;
          IF parameter_kind <> NIL THEN
            parameter_kind^.length_indicated := FALSE;
            parameter_kind^.param := nfc$vertical_print_density;
            NEXT vertical_print_density IN message;
            IF vertical_print_density <> NIL THEN
              CASE modified_descriptor.output_descriptor.vertical_print_density OF
              = jmc$vertical_print_density_none =
                vertical_print_density^ := nfc$vertical_print_density_none;
              = jmc$vertical_print_density_6 =
                vertical_print_density^ := nfc$vertical_print_density_6;
              = jmc$vertical_print_density_7 =
                vertical_print_density^ := nfc$vertical_print_density_7;
              = jmc$vertical_print_density_8 =
                vertical_print_density^ := nfc$vertical_print_density_8;
              = jmc$vertical_print_density_9 =
                vertical_print_density^ := nfc$vertical_print_density_9;
              = jmc$vertical_print_density_10 =
                vertical_print_density^ := nfc$vertical_print_density_10;
              = jmc$vertical_print_density_11 =
                vertical_print_density^ := nfc$vertical_print_density_11;
              = jmc$vertical_print_density_12 =
                vertical_print_density^ := nfc$vertical_print_density_12;
              ELSE
                osp$set_status_abnormal (nfc$status_id, nfe$invalid_descriptor_value,
                      'vertical_print_density', status);
                RETURN; {----->
              CASEND;
              message_length := message_length + parameter_kind_size + 1;
            ELSE
              osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
              RETURN; {----->
            IFEND;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
            RETURN; {----->
          IFEND;
        IFEND;

      = nfc$input_file =

        IF descriptor.input_descriptor.output_priority <> modified_descriptor.input_descriptor.
              output_priority THEN
          add_output_priority (modified_descriptor.input_descriptor.output_priority,
                parameter_kind_size, message, message_length, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      ELSE
      CASEND;

      NEXT parameter_kind IN message;
      IF parameter_kind <> NIL THEN
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$null_parameter;
        message_length := message_length + parameter_kind_size;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;

    PROCEND build_modify_file_available_msg;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    IF descriptor.file_kind = modified_descriptor.file_kind THEN
      set_up_required_msg_params (descriptor, nfc$modify_file_availability, message, message_length, status);
      IF status.normal THEN
        build_modify_file_available_msg (descriptor, modified_descriptor, message, message_length, status);
        IF status.normal THEN
          nfp$send_message_on_connection (message, message_length, connection_identifier, status);
        IFEND;
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$conflicting_descriptors, ' ', status);
    IFEND;

  PROCEND nfp$send_modify_file_available;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$send_terqo_response_msg', EJECT ??
*copyc nfh$send_terqo_response_msg

  PROCEDURE [XDCL] nfp$send_terqo_response_msg
    (    io_station_name: ost$name;
         file_name: ost$name;
         response: nft$terqo_file_status_codes;
         connection_id: amt$file_identifier;
     VAR message: ^nft$message_sequence;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      message_length: nft$message_length,
      message_type: ^nft$message_kind,
      parameter_kind: ^nft$term_q_output_resp_param,
      parameter_kind_size: nft$message_length,
      param_length_size: nft$message_length,
      parameter_value_length: integer,
      response_param: ^nft$terqo_file_status_codes;

*copy nft$terminate_q_output_resp_msg

    parameter_kind_size := #SIZE (nft$term_q_output_resp_param);
    RESET message;

    NEXT message_type IN message;
    message_type^ := nfc$terminate_queue_output_resp;
    message_length := 1;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$io_station_name;
    parameter_value_length := clp$trimmed_string_size (io_station_name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := io_station_name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$system_user_file_name;
    parameter_value_length := clp$trimmed_string_size (file_name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := file_name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$file_status_code;
    NEXT response_param IN message;
    response_param^ := response;
    message_length := message_length + parameter_kind_size + 1;

    nfp$send_message_on_connection (message, message_length, connection_id, status);

  PROCEND nfp$send_terqo_response_msg;
?? TITLE := 'nfp$start_btf_ve_task', EJECT ??
*copy nfh$start_btf_ve_task

  PROCEDURE [XDCL] nfp$start_btf_ve_task
    (    btfs_di_network_address: nat$network_address;
         btfs_di_title: nft$btfs_di_title;
         station: ost$name;
         device: ost$name;
         device_environment_variable: ost$name;
         scfs_can_handle_filter_hold: boolean;
         file_descriptor: nft$application_file_descriptor;
         ntf_local_file_name: amt$local_file_name;
         debug_async_task: pmt$debug_mode;
     VAR wait_list {input, output} : ^ost$i_wait_list;
     VAR wait_activity_list {input, output} : ^nft$wait_activity_list;
     VAR wait_list_sequence {input, output} : ^SEQ ( * );
     VAR wait_activity_list_sequence {input, output} : ^SEQ ( * );
     VAR new_btf_task: ^nft$btf_task;
     VAR status: ost$status);

    CONST
      btf_task_name = 'NFP$BTF_CLIENT                 ';

    VAR
      btf_task_info: nft$intertask_message,
      device_length: integer,
      queue_id: pmt$queue_connection,
      task_id: pmt$task_id;

{  Set up the information that the BTF/VE task needs to establish a
{  batch transfer connection with BTFS in the DI to which the device is
{  connected.

    status.normal := TRUE;
    new_btf_task := NIL;

    btf_task_info.kind := nfc$btf_file_transfer;
    btf_task_info.network_address := btfs_di_network_address;
    btf_task_info.btf_file_descriptor := file_descriptor;
    btf_task_info.ntf_local_file_name := osc$null_name;
    btf_task_info.device_environment_variable := device_environment_variable;
    btf_task_info.scfs_can_handle_filter_hold := scfs_can_handle_filter_hold;

    CASE file_descriptor.file_kind OF
    = nfc$output_file =
      btf_task_info.btf_file_descriptor.output_descriptor.device := device;
      btf_task_info.btf_file_descriptor.output_descriptor.station := station;
      IF file_descriptor.output_descriptor.output_destination_usage = jmc$ntf_usage THEN
        btf_task_info.ntf_local_file_name := ntf_local_file_name;
      IFEND;

    = nfc$input_file =
      device_length := clp$trimmed_string_size (device);
      btf_task_info.btf_file_descriptor.input_descriptor.job_input_device.text := device;
      btf_task_info.btf_file_descriptor.input_descriptor.job_input_device.size := device_length;
      btf_task_info.btf_file_descriptor.input_descriptor.station := station;
      IF file_descriptor.input_descriptor.job_destination_usage = jmc$ntf_usage THEN
        btf_task_info.ntf_local_file_name := ntf_local_file_name;
      IFEND;
    ELSE
      ;
    CASEND;

    nfp$request_asynchronous_task (btf_task_name, debug_async_task, task_id, queue_id, status);
    IF status.normal THEN
      nfp$add_btf_task_to_list (task_id, queue_id, btfs_di_network_address, btfs_di_title, station, device,
            wait_list, wait_activity_list, wait_list_sequence, wait_activity_list_sequence, new_btf_task);
      nfp$put_async_task_message (task_id, ^btf_task_info, #SIZE (btf_task_info), status);
    IFEND;

  PROCEND nfp$start_btf_ve_task;
?? TITLE := 'nfp$start_timer', EJECT ??
*copyc nfh$start_timer

  PROCEDURE [XDCL] nfp$start_timer
    (    wait_time: nft$micro_second;
     VAR timer: nft$timer);


{  PURPOSE:
{             This procedure starts the timer specified.  If 0 is given for
{             the wait time, the timer is a back-off timer (each time it is
{             started, the time interval increases, up to a maximum interval).
{             The time interval is set either to the given wait time or the
{             back-off timer algorithm.
{


    timer.timer_set := TRUE;
    timer.last_checked := #FREE_RUNNING_CLOCK (0);

    IF wait_time <> 0 THEN
      timer.time_interval := wait_time;
    ELSE
      CASE timer.time_interval OF
      = 0 =
        timer.time_interval := nfc$one_minute;

      = nfc$one_minute =
        timer.time_interval := nfc$two_minutes;

      = nfc$two_minutes =
        timer.time_interval := nfc$four_minutes;

      = nfc$four_minutes =
        timer.time_interval := nfc$eight_minutes;

      = nfc$eight_minutes =
        timer.time_interval := nfc$sixteen_minutes;

      = nfc$sixteen_minutes =
        timer.time_interval := nfc$thirty_minutes;

      ELSE
        timer.time_interval := nfc$thirty_minutes;

      CASEND;
    IFEND;

  PROCEND  nfp$start_timer;
?? TITLE := 'nfp$timer_expired', EJECT ??
*copyc nfh$timer_expired

  FUNCTION [XDCL] nfp$timer_expired
    (    timer: nft$timer;
         latest_time: nft$micro_second): boolean;


    IF timer.timer_set THEN
      nfp$timer_expired := (latest_time - timer.time_interval) >= timer.last_checked;
    ELSE
      nfp$timer_expired := TRUE;
    IFEND;

  FUNCEND nfp$timer_expired;
?? TITLE := 'set_up_required_msg_params', EJECT ??

{
{  PURPOSE:
{    This procedure sets up the parameters that are necessary for the
{    add file availablity message, the modify file availability message
{    and the delete file availability message.
{

  PROCEDURE set_up_required_msg_params
    (    descriptor: nft$application_file_descriptor;
         message_kind: nft$message_kind;
     VAR message: ^nft$message_sequence;
     VAR message_length: integer;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      descriptor_destination_family: ost$name,
      descriptor_destination_usage: jmt$destination_usage,
      descriptor_login_family: ost$name,
      descriptor_login_user: ost$name,
      descriptor_station: jmt$station,
      descriptor_station_operator: jmt$station_operator,
      descriptor_system_file_name: jmt$system_supplied_name,
      descriptor_system_job_name: jmt$system_supplied_name,
      descriptor_user_file_name: jmt$user_supplied_name,
      descriptor_user_job_name: jmt$user_supplied_name,
      message_type: ^nft$message_kind,
      parameter_kind: ^nft$file_available_msg_param,
      parameter_kind_size: nft$message_length,
      parameter_length_size: nft$message_length,
      parameter_value_length: integer,
      station_usage: ^nft$io_station_usage,
      usage: nft$io_station_usage;

*copy nft$file_availability_msg

    status.normal := TRUE;

    CASE descriptor.file_kind OF

    = nfc$output_file =

      descriptor_destination_family := descriptor.output_descriptor.output_destination_family;
      descriptor_destination_usage := descriptor.output_descriptor.output_destination_usage;
      descriptor_login_family := descriptor.output_descriptor.login_family;
      descriptor_login_user := descriptor.output_descriptor.login_user;
      IF descriptor_destination_usage = jmc$ntf_usage THEN
        descriptor_station := descriptor.output_descriptor.output_destination;
      ELSE
        descriptor_station := descriptor.output_descriptor.station;
      IFEND;
      descriptor_station_operator := descriptor.output_descriptor.station_operator;
      descriptor_system_file_name := descriptor.output_descriptor.system_file_name;
      descriptor_system_job_name := descriptor.output_descriptor.system_job_name;
      descriptor_user_file_name := descriptor.output_descriptor.user_file_name;
      descriptor_user_job_name := descriptor.output_descriptor.user_job_name;

    = nfc$input_file =

      descriptor_destination_family := descriptor.input_descriptor.output_destination_family;
      descriptor_destination_usage := descriptor.input_descriptor.job_destination_usage;
      descriptor_login_family := descriptor.input_descriptor.login_family;
      descriptor_login_user := descriptor.input_descriptor.login_user;
      descriptor_station := descriptor.input_descriptor.job_destination_family;
      descriptor_station_operator := descriptor.input_descriptor.station_operator;
      descriptor_system_file_name := descriptor.input_descriptor.system_job_name;
      descriptor_system_job_name := descriptor.input_descriptor.system_job_name;
      descriptor_user_file_name := descriptor.input_descriptor.user_job_name;
      descriptor_user_job_name := descriptor.input_descriptor.user_job_name;

    ELSE
      ;
    CASEND;

    parameter_kind_size := #SIZE (nft$file_available_msg_param);
    RESET message;

    NEXT message_type IN message;
    IF message_type <> NIL THEN
      message_type^ := message_kind;
      message_length := 1;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      RETURN; {----->
    IFEND;

    NEXT parameter_kind IN message;
    IF parameter_kind <> NIL THEN
      parameter_kind^.param := nfc$io_station_name;
      parameter_value_length := clp$trimmed_string_size (descriptor_station);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        parameter_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      IF ascii_string <> NIL THEN
        #TRANSLATE (osv$lower_to_upper, descriptor_station (1, parameter_value_length), ascii_string^);
        message_length := message_length + parameter_kind_size + parameter_length_size +
              parameter_value_length;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      RETURN; {----->
    IFEND;

    NEXT parameter_kind IN message;
    IF parameter_kind <> NIL THEN
      parameter_kind^.param := nfc$operator_name;
      parameter_value_length := clp$trimmed_string_size (descriptor_station_operator);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        parameter_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      IF ascii_string <> NIL THEN
        #TRANSLATE (osv$lower_to_upper, descriptor_station_operator (1, parameter_value_length),
              ascii_string^);
        message_length := message_length + parameter_kind_size + parameter_length_size +
              parameter_value_length;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      RETURN; {----->
    IFEND;

    NEXT parameter_kind IN message;
    IF parameter_kind <> NIL THEN
      parameter_kind^.param := nfc$operator_family;
      parameter_value_length := clp$trimmed_string_size (descriptor_destination_family);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        parameter_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      IF ascii_string <> NIL THEN
        #TRANSLATE (osv$lower_to_upper, descriptor_destination_family (1, parameter_value_length),
              ascii_string^);
        message_length := message_length + parameter_kind_size + parameter_length_size +
              parameter_value_length;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      RETURN; {----->
    IFEND;

    IF descriptor_destination_usage = jmc$public_usage THEN
      usage := nfc$public_io_station;
    ELSEIF descriptor_destination_usage = jmc$private_usage THEN
      usage := nfc$private_io_station;
    ELSEIF descriptor_destination_usage = jmc$ntf_usage THEN
      usage := nfc$ntf_remote_system;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$invalid_descriptor_value, 'destination_usage', status);
      RETURN; {----->
    IFEND;

    NEXT parameter_kind IN message;
    IF parameter_kind <> NIL THEN
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$station_usage;
      NEXT station_usage IN message;
      IF station_usage <> NIL THEN
        station_usage^ := usage;
        message_length := message_length + parameter_kind_size + 1;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      RETURN; {----->
    IFEND;

    NEXT parameter_kind IN message;
    IF parameter_kind <> NIL THEN
      parameter_kind^.param := nfc$system_file_name;
      parameter_value_length := clp$trimmed_string_size (descriptor_system_file_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        parameter_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      IF ascii_string <> NIL THEN
        #TRANSLATE (osv$lower_to_upper, descriptor_system_file_name (1, parameter_value_length),
              ascii_string^);
        message_length := message_length + parameter_kind_size + parameter_length_size +
              parameter_value_length;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      RETURN; {----->
    IFEND;

    NEXT parameter_kind IN message;
    IF parameter_kind <> NIL THEN
      parameter_kind^.param := nfc$system_job_name;
      parameter_value_length := clp$trimmed_string_size (descriptor_system_job_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        parameter_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      IF ascii_string <> NIL THEN
        #TRANSLATE (osv$lower_to_upper, descriptor_system_job_name (1, parameter_value_length),
              ascii_string^);
        message_length := message_length + parameter_kind_size + parameter_length_size +
              parameter_value_length;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      RETURN; {----->
    IFEND;

    NEXT parameter_kind IN message;
    IF parameter_kind <> NIL THEN
      parameter_kind^.param := nfc$user_file_name;
      parameter_value_length := clp$trimmed_string_size (descriptor_user_file_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        parameter_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      IF ascii_string <> NIL THEN
        #TRANSLATE (osv$lower_to_upper, descriptor_user_file_name (1, parameter_value_length),
              ascii_string^);
        message_length := message_length + parameter_kind_size + parameter_length_size +
              parameter_value_length;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      RETURN; {----->
    IFEND;

    NEXT parameter_kind IN message;
    IF parameter_kind <> NIL THEN
      parameter_kind^.param := nfc$user_job_name;
      parameter_value_length := clp$trimmed_string_size (descriptor_user_job_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        parameter_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      IF ascii_string <> NIL THEN
        #TRANSLATE (osv$lower_to_upper, descriptor_user_job_name (1, parameter_value_length),
              ascii_string^);
        message_length := message_length + parameter_kind_size + parameter_length_size +
              parameter_value_length;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      RETURN; {----->
    IFEND;

    NEXT parameter_kind IN message;
    IF parameter_kind <> NIL THEN
      parameter_kind^.param := nfc$user_name;
      parameter_value_length := clp$trimmed_string_size (descriptor_login_user);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        parameter_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      IF ascii_string <> NIL THEN
        #TRANSLATE (osv$lower_to_upper, descriptor_login_user (1, parameter_value_length), ascii_string^);
        message_length := message_length + parameter_kind_size + parameter_length_size +
              parameter_value_length;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      RETURN; {----->
    IFEND;

    NEXT parameter_kind IN message;
    IF parameter_kind <> NIL THEN
      parameter_kind^.param := nfc$user_family;
      parameter_value_length := clp$trimmed_string_size (descriptor_login_family);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, parameter_length_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        parameter_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      IF ascii_string <> NIL THEN
        #TRANSLATE (osv$lower_to_upper, descriptor_login_family (1, parameter_value_length), ascii_string^);
        message_length := message_length + parameter_kind_size + parameter_length_size +
              parameter_value_length;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
        RETURN; {----->
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$outside_bounds_of_sequence, ' ', status);
      RETURN; {----->
    IFEND;

  PROCEND set_up_required_msg_params;

MODEND nfm$file_transfer_appl_procs;
*DECK DECK=NFM$FILE_TRANSFER_FUNCTIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'Network File Transfer : SCL Functions' ??
MODULE nfm$file_transfer_functions;

{ PURPOSE:
{   This module contains the procedures that handle the SCL functions
{   related to network file transfer applications.

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$work_area_overflow
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$make_boolean_value
*copyc nfp$find_remote_validation
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$$remote_validation', EJECT ??

  PROCEDURE [XDCL] nfp$$remote_validation
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$remote_validation) $remote_validation (
{   location: name = $required
{   )

?? 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$name_type_qualifier,
      recend,
    recend := [
    [1,
    [89, 2, 15, 10, 40, 25, 676],
    clc$function, 1, 1, 1, 0, 0, 0, 0, 'OSM$$REMOTE_VALIDATION'], [
    ['LOCATION                       ',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, 5, clc$required_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$location = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      count: 0 .. nfc$max_validation_lines;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nfp$find_remote_validation (pvt [p$location].value^.name_value, count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_boolean_value ((count > 0), clc$true_false_boolean, work_area, result);
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;

  PROCEND nfp$$remote_validation;
?? OLDTITLE ??
MODEND nfm$file_transfer_functions;
*DECK DECK=NFM$GENERATE_BANNER_PAGE EXPAND=TRUE
PROCEDURE generate_banner_page, genbp (
  input, i: record
      system_file_name: name 19..19
      password: string 1..31
      file: file = $optional
    recend = $required
  output, o: file = $required
  banner_page_count, bpc: integer 1..3 = $required
  banner_placement, bp: key
      (beginning_of_file, bof)
      (beginning_and_end, bae)
      (end_of_file, eof)
    keyend = beginning_of_file
  device_environment_variable, dev: name = $required
  comment_banner, cb: string 0..31 = $required
  data_mode, dm: key
      (coded, c)
      (transparent, t)
    keyend = $required
  routing_banner, rb: string 0..31 = $required
  status)

" PURPOSE:
"   This procedure generates one or more banner pages very similar to
"   those generated by CDCNET software for printers connected to CDCNET.
"
" DESIGN:
"   Calculate the number of lines available for the banner page based on
"  the forms size and the vertical print density of the printer. Conditionally
"  generate the banner text base on the number of lines available on
"  the banner page, and which banner highlight field the printer is defined
"  to display. Reject requests to generate banner pages for transparent
"  files if the TIP type of the printer is not ASYNC or X25_ASYNC. Non-async.
"  devices do not (currently) process transparent files.
"
" NOTE:
"   This function is meant to be a model for site designed procedures
"   which will generate customized banners to replace the CDCNET banners
"   currently generated.

" Constants.
  VAR
    burst_line: string 1...88 = ..
    '   MWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWMWM'
    key_length: integer = 14
    leading_blanks: string 18 = '                  '
  VAREND

  VAR
    banner_block_letters: list of string 0..255
    banner_highlight_field: name
    current_line: integer
    device_type: name
    device_vpd: name
    forms_size : real
    index: integer
    last_line_on_page: integer
    local_status: status
    postscript_device: boolean
    prefix_char: string 0..1
    suffix_chars: string 0..2
    terminal_model: name
    tip_type: name
  VAREND

" Determine if the SCFS/VE that sent the file assignment message to SCF/VE is
" the new 'BOF' version, or if it is the old version which does not send enough
" information to completly initialize the device environment variable. If the
" SCFS/VE is the old version, then certain device-dependent attributes must be
" assumed.

  include_command 'device_type=$device_attributes(dev, device_type)' status=local_status
  IF local_status.normal THEN
    banner_highlight_field = $device_attributes(dev, banner_highlight_field)
    device_vpd = $device_attributes(dev, vertical_print_density)
    forms_size = $device_attributes(dev, forms_size)
    page_width = $device_attributes(dev, page_width)
    terminal_model = $device_attributes(dev, terminal_model)
    tip_type = $device_attributes(dev, tip_type)
  ELSE
    banner_highlight_field = routing_banner
    device_type = printer
    device_vpd = six_only
    forms_size = 11.0
    page_width = 132
    terminal_model = unknown
    tip_type = async
  IFEND

" Determine the prefix and suffix characters for the banner and if this output
" filter should accept the file based on the data mode and the TIP type.

  IF data_mode = coded THEN
    prefix_char = ' '
    suffix_chars = ''
  ELSE
    IF (tip_type <> async) AND (tip_type <> x25_async) THEN
      display_message ..
            m='****GENERATE_BANNER_PAGE can not create a transparent banner for device type '//tip_type
      EXIT_PROC WITH $status(false 'NF' nfe$wrong_file_type)
    IFEND
    prefix_char = ''
    suffix_chars = $char(cr lf)
  IFEND

" Calculate the number of lines that are available for the banner page
" based on the forms size and the vertical print density.

  IF (device_vpd = six_only) OR (device_vpd = six_any) THEN
    IF ($job_output(input.system_file_name, vpd) = eight) THEN
      last_line_on_page = (forms_size * 8)
    ELSE "file vpd is either six, or none.
      last_line_on_page = (forms_size * 6)
    IFEND
  ELSEIF (device_vpd = eight_only) OR (device_vpd = eight_any) THEN
    IF ($job_output(input.system_file_name, vpd) = six) THEN
      last_line_on_page = (forms_size * 6)
    ELSE "file vpd is either eight, or none.
      last_line_on_page = (forms_size * 8)
    IFEND
  IFEND

" Allocate the array needed to hold the banner page text.  Since the array is
" defined as the exact size of one page, it can be written to the output file
" with a single put_line command.

  VAR
    banner_text: ARRAY 1..last_line_on_page OF STRING 0..page_width
  VAREND

  IF data_mode = coded THEN
    create_t_record_file f=output pw=page_width pl=last_line_on_page status=local_status
    EXIT_PROC WITH local_status WHEN NOT local_status.normal
  ELSE
    set_file_attributes file=output pw=page_width pl=last_line_on_page rt=undefined
  IFEND

" Reserve the last three lines of each page for burst lines.

  last_line_on_page = last_line_on_page - 3

  current_line = 1
  postscript_device = $scan_string('POSTSCRIPT', $translate(ltu, $string(terminal_model))) > 0

  IF current_line <= last_line_on_page THEN
    IF data_mode = coded THEN
      IF postscript_device THEN

" Sidestep a blank sheet of paper between the banner page and the file by
" causing the the first line of the first banner page to overstrike.

        banner_text(current_line) = '+ '//suffix_chars
      ELSE
        banner_text(current_line) = '1 '//suffix_chars
      IFEND;
    ELSE
      banner_text(current_line) = prefix_char//$char(ff)//suffix_chars
    IFEND
    current_line = current_line + 1
  IFEND

" Add padding lines.

  FOR index = 1 TO 5 DO
    IF current_line <= last_line_on_page THEN
      banner_text(current_line) = prefix_char//' '//suffix_chars
      current_line = current_line + 1
    IFEND
  FOREND

" Generate the site information line if appropriate.

  IF current_line <= last_line_on_page THEN
    IF (banner_highlight_field <> site_banner) AND ..
          $strlen($job_output(input.system_file_name, site_information)) > 0 THEN
      banner_text(current_line) = prefix_char//leading_blanks// ..
            $job_output(input.system_file_name, site_information)//suffix_chars
      current_line = current_line + 1
    IFEND
  IFEND

" Produce the appropriate file information lines.
  IF current_line <= last_line_on_page THEN
    banner_text(current_line) = prefix_char//' '//suffix_chars
    current_line = current_line + 1
  IFEND

  IF current_line <= last_line_on_page THEN
    banner_text(current_line) = prefix_char//leading_blanks//..
$substring('PRINTED', 1, key_length, ' ')//'= '//$date(mdy)//' '//$time(hms)//suffix_chars
    current_line = current_line + 1
  IFEND

  IF current_line <= last_line_on_page THEN
    banner_text(current_line) = prefix_char//leading_blanks//..
$substring('CREATED', 1, key_length, ' ')//'= '//$date(mdy, $job_output(input.system_file_name, ost))//' '//..
$time(hms, $job_output(input.system_file_name, ost))//suffix_chars
    current_line = current_line + 1
  IFEND

  IF current_line <= last_line_on_page THEN
    banner_text(current_line) = prefix_char//leading_blanks//..
$substring('FAMILY', 1, key_length, ' ')//'= '//$job_output(input.system_file_name, login_family)//..
suffix_chars
    current_line = current_line + 1
  IFEND

  IF current_line <= last_line_on_page THEN
    IF banner_highlight_field <> user_name THEN
      banner_text(current_line) = prefix_char//leading_blanks//..
$substring('USER NAME', 1, key_length, ' ')//'= '//$job_output(input.system_file_name, login_user)//..
suffix_chars
      current_line = current_line + 1
    IFEND
  IFEND

  IF current_line <= last_line_on_page THEN
    banner_text(current_line) = prefix_char//leading_blanks//..
$substring('USER JOB NAME', 1, key_length, ' ')//'= '//$job_output(input.system_file_name, ujn)//suffix_chars
    current_line = current_line + 1
  IFEND

  IF current_line <= last_line_on_page THEN
    IF banner_highlight_field <> user_file_name THEN
      banner_text(current_line) = prefix_char//leading_blanks//..
$substring('FILE NAME', 1, key_length, ' ')//'= '//$job_output(input.system_file_name, ufn)//suffix_chars
      current_line = current_line + 1
    IFEND
  IFEND

  IF current_line <= last_line_on_page THEN
    banner_text(current_line) = prefix_char//' '//suffix_chars
    current_line = current_line + 1
  IFEND

  IF current_line <= last_line_on_page THEN
    IF banner_highlight_field = comment_banner THEN
      banner_text(current_line) = prefix_char//leading_blanks//routing_banner//suffix_chars
    ELSE
      banner_text(current_line) = prefix_char//leading_blanks//comment_banner//suffix_chars
    IFEND
    current_line = current_line + 1
  IFEND

  IF current_line <= last_line_on_page THEN
    banner_text(current_line) = prefix_char//' '//suffix_chars
    current_line = current_line + 1
  IFEND

  IF current_line <= last_line_on_page THEN
    IF (banner_highlight_field <> comment_banner) AND (banner_highlight_field <> routing_banner) THEN
      banner_text(current_line) = prefix_char//leading_blanks//routing_banner//suffix_chars
    ELSE
      banner_text(current_line) = prefix_char//' '//suffix_chars
    IFEND
    current_line = current_line + 1
  IFEND

" Adding padding lines.

  FOR index = 1 TO 4 DO
    IF current_line <= last_line_on_page THEN
      banner_text(current_line) = prefix_char//' '//suffix_chars
      current_line = current_line + 1
    IFEND
  FOREND

" Generate the wrapped block text for the banner highlight field.
" Truncate the excess lines if there are not enough lines remaining
" on the banner page.

  IF current_line <= (last_line_on_page - 13) THEN
    IF banner_highlight_field = user_name THEN
      banner_block_letters = $wrapped_block_text($string($job_output(input.system_file_name, login_user)), ..
            page_width, (last_line_on_page- current_line))
    ELSEIF banner_highlight_field = comment_banner THEN
      banner_block_letters = $wrapped_block_text(comment_banner, page_width, (last_line_on_page- ..
            current_line))
    ELSEIF banner_highlight_field = routing_banner THEN
      banner_block_letters = $wrapped_block_text(routing_banner, page_width, (last_line_on_page- ..
            current_line))
    ELSEIF banner_highlight_field = site_banner THEN
      banner_block_letters = $wrapped_block_text($job_output(input.system_file_name, site_information), ..
            page_width, (last_line_on_page- current_line))
    ELSEIF banner_highlight_field = user_file_name THEN
      banner_block_letters = $wrapped_block_text(..
            $string($job_output(input.system_file_name, user_file_name)), page_width, (last_line_on_page- ..
            current_line))
    IFEND
    FOR index = 1 TO $size(banner_block_letters) DO
      banner_text(current_line) = prefix_char//banner_block_letters(index)//suffix_chars
      current_line = current_line + 1
    FOREND
  IFEND

" Add padding lines.

  FOR index = current_line TO last_line_on_page DO
    banner_text(index) = prefix_char//' '//suffix_chars
  FOREND

" Add the three burst lines that print on the same page as the other banner
" text.

  banner_text(last_line_on_page + 1) = prefix_char//burst_line//suffix_chars
  banner_text(last_line_on_page + 2) = prefix_char//burst_line//suffix_chars
  banner_text(last_line_on_page + 3) = prefix_char//burst_line//suffix_chars

" Copy either the queue file or the input file to the output file if the banner
" is to be printed after the file.

  IF (banner_placement = end_of_file) THEN
    IF $field(input, file, initialized) THEN
      copy_file i=input.file o=output.$eoi
    ELSE
      copy_output_file n=input.system_file_name o=output.$eoi
    IFEND
  IFEND

" Insert the banner page(s) into the output file.

  FOR index = 1 TO banner_page_count DO
    IF (index = 2) THEN
      banner_text(1) = prefix_char//burst_line//suffix_chars
      banner_text(2) = prefix_char//burst_line//suffix_chars
      banner_text(3) = prefix_char//burst_line//suffix_chars
    IFEND
    put_line l=banner_text o=output.$eoi
  FOREND

" Insert the three burst lines that trail onto the first page
" after the banners.

  IF NOT postscript_device THEN
    put_line l=prefix_char//burst_line//suffix_chars o=output.$eoi
    put_line l=prefix_char//burst_line//suffix_chars o=output.$eoi
    put_line l=prefix_char//burst_line//suffix_chars o=output.$eoi
  IFEND

" Append either the queue file or the input file to the file which
" contains the banner page(s).

  IF (banner_placement = beginning_of_file) OR (banner_placement = beginning_and_end) THEN
    IF $field(input, file, initialized) THEN
      copy_file i=input.file o=output.$eoi
    ELSE
      copy_output_file n=input.system_file_name o=output.$eoi
    IFEND
  IFEND

" Insert the banner pages at the end of the file, but do not waste an
" extra page of paper by appending three more burst lines.

  IF (banner_placement = beginning_and_end) THEN
    IF data_mode = coded THEN
      IF postscript_device THEN
        banner_text(1) = prefix_char//' '//suffix_chars
      ELSE
        banner_text(1) = '1 '//suffix_chars
      IFEND
      banner_text(2) = prefix_char//' '//suffix_chars
      banner_text(3) = prefix_char//' '//suffix_chars
    ELSE
      banner_text(1) = prefix_char//$char(ff)//suffix_chars
      banner_text(2) = prefix_char//' '//suffix_chars
      banner_text(3) = prefix_char//' '//suffix_chars
      current_line = current_line + 1
    IFEND
    FOR index = 1 TO banner_page_count DO
      IF (index = 2) THEN
        banner_text(1) = prefix_char//burst_line//suffix_chars
        banner_text(2) = prefix_char//burst_line//suffix_chars
        banner_text(3) = prefix_char//burst_line//suffix_chars
      IFEND
      put_line l=banner_text o=output.$eoi
    FOREND
  IFEND

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND generate_banner_page
*DECK DECK=NFM$GENERATE_POSTSCRIPT_BANNER EXPAND=TRUE
PROCEDURE generate_postscript_banner, genpb (
  input, i: record
      system_file_name: name 19..19
      password: string 1..31
      file: file = $optional
    recend = $required
  output, o: file = $required
  data_mode, dm: key
      (coded, c)
      (transparent, t)
    keyend = $required
  status)

" GENERATE_POSTSCRIPT_BANNER.
"
"   This procedure creates a file with a leading portrait banner page for
"   PostScript printers.  This banner page is actually a PostScript
"   program.  This procedure is NOT sensitve to the printer's
"   BANNER_HIGHLIGHT field; ROUTING_BANNER is always highlighted.  The
"   OUTPUT from this procedure is in the mode specidfied by DATA_MODE.

  VAR
    banner_file: file
    block: array 1..4 of string 1..8 = (' ', ' ', ' ', ' ')
    block_string: string 31
    ignore: status
    mode: key
    (coded, c)
    (transparent, t)
    keyend = data_mode
  VAREND

  IF data_mode = transparent THEN
    banner_file = $unique($local)
    WHEN exit DO
      delete_file banner_file status=ignore
    WHENEND
  ELSE
    banner_file = output
  IFEND

" Obtain time file was CREATED.

  created = $string($job_output(input.system_file_name, ost))
  created(11, 1) = ' ' " Blank out excess '.'

" Prefix all '(' and ')' characters in SITE_INFORMATION with a '\'

  site_info = $job_output(input.system_file_name, si)
  byte = 1
  FOR i = 1 TO $size(site_info) DO
    IF (site_info(byte) = '(') OR (site_info(byte) = ')') THEN
      site_info = site_info(1, byte-1)//'\'//site_info(byte, all)
      byte = byte + 1
    IFEND
    byte = byte + 1
  FOREND

" Prefix all '(' and ')' characters in COMMENT_BANNER with a '\'

  comment_banner = $job_output(input.system_file_name, cb)
  byte = 1
  FOR i = 1 TO $size(comment_banner) DO
    IF (comment_banner(byte) = '(') OR (comment_banner(byte) = ')') THEN
      comment_banner = comment_banner(1, byte-1)//'\'//comment_banner(byte, all)
      byte = byte + 1
    IFEND
    byte = byte + 1
  FOREND

" Process ROUTING_BANNER.  This is printed in up to 4 lines of 8 block letters.
" If the ROUTING_BANNER is 8 characters or less it is centered on the second
" line.

  block_size = $size($job_output(input.system_file_name, rb))
  IF (block_size <= 8) THEN
    pad = $substring('', 1, ((8-block_size)/2))
    block(2) = pad//$job_output(input.system_file_name, rb)
  ELSE
    block_string = $job_output(input.system_file_name, rb)
    block(1) = block_string(1, 8)
    block(2) = block_string(9, 8)
    block(3) = block_string(17, 8)
    block(4) = block_string(25, 7)
  IFEND

" Prefix all '(' and ')' characters in ROUTING_BANNER with a '\'

  FOR line = 1 TO 4 DO
    byte = 1
    FOR i = 1 TO $size(block(line)) DO
      IF (block(line)(byte) = '(') OR (block(line)(byte) = ')') THEN
        block(line) = block(line)(1, byte-1)//'\'//block(line)(byte, all)
        byte = byte + 1
      IFEND
      byte = byte + 1
    FOREND
  FOREND

COLLECT_TEXT banner_file sm='?'
/saveps save def
mark
/Courier findfont
12 scalefont
setfont
/savevm save def
200 700 moveto (?site_info?) show
200 676 moveto (PRINTED        = ?$date(iso)? ?$time(hms)?) show
200 664 moveto (CREATED        = ?created?) show
200 652 moveto (LOGIN FAMILY   = ?$job_output(input.system_file_name, lf)?) show
200 640 moveto (LOGIN USER     = ?$job_output(input.system_file_name, lu)?) show
200 628 moveto (USER JOB NAME  = ?$job_output(input.system_file_name, ujn)?) show
200 616 moveto (USER FILE NAME = ?$job_output(input.system_file_name, ufn)?) show
200 604 moveto (FILE SIZE      = ?$job_output(input.system_file_name, fs)? bytes) show
200 580 moveto (?comment_banner?) show
/Courier-Bold findfont
110 scalefont
0.6 setgray
setfont
40 450 moveto (?block(1)?) show
40 330 moveto (?block(2)?) show
40 210 moveto (?block(3)?) show
40  90 moveto (?block(4)?) show
/Courier-Bold findfont
160 scalefont
0.6 setgray
setfont
1 55 moveto (_______) show
showpage savevm restore cleartomark saveps restore
**

  IF data_mode = transparent THEN
    preprocess_postscript_file (input.system_file_name, ' ', banner_file) ..
          o=output dm=mode
  IFEND

  IF $field(input, file, initialized) THEN
    copy_file input.file output.$eoi
  ELSE
    copy_output_file input.system_file_name output.$eoi
  IFEND

PROCEND generate_postscript_banner
*DECK DECK=NFM$MAIN_BATCH_OUTPUT_FILTER EXPAND=TRUE
PROCEDURE main_batch_output_filter (
  input, i: record
      system_file_name: name 19..19
      password: string 1..31
    recend = $required
  output, o: (VAR) file = $required
  statistics_file, sf: file = $required
  device_environment_variable, dev: name = $required
  file_attributes, fa: (VAR) record
      comment_banner: string 0..31 = $optional
      data_mode: key
        (coded, c)
        (transparent, t)
      keyend = $optional
      forms_code: string 0..6 = $optional
      page_length: integer 0..4398046511103 = $optional
      page_width: integer 10..255 = $optional
      routing_banner: string 0..31 = $optional
      vertical_print_density: key
        six, eight
      keyend = $optional
      vfu_load_procedure: any of
        key
          none
        keyend
        name
      anyend = $optional
    recend = $required
  file_disposition, fd: (VAR) key
      (hold, h)
      (print_and_hold, pah)
      (print_and_terminate, pat)
      (terminate, t)
    keyend = $required
  status)

" Filtering disabled.

  EXIT_PROC

" Site-defined CONSTANTS

"$FORMAT=OFF
  VAR
    debug_commands: file = $system.batch_device_support.main_debug
    postscript_dictionaries: any of
        key
          none
        keyend
        list of file
      anyend = none
    postscript_dictionary_catalog: file =
          $system.batch_device_support.postscript_dictionaries
    printer_validation_file: file =
          $system.batch_device_support.printer_validation
  VAREND

" VARIABLES

  VAR
    banner_count: integer 1..3
    data_mode: key
        (coded, c)
        (transparent, t)
      keyend
    ec4: string 6
    filter_input: record
        system_file_name: name 19..19
        password: string 1..31
        file: file = $optional
      recend = (input.system_file_name, input.password)
    ignore_status: status
    local_status: status
    user_info: string
  VAREND
"$FORMAT=ON

" Obtain access to utilities and sub-filters.

  PUSH command_list
  create_command_list_entry ..
        $system.batch_device_support.standard_filters.command_library ..
        status=ignore_status

" Issue debug information if protocol_trace is enabled.

  IF $variable(nfv$rhf_protocol_trace, defined) AND ..
        (nfv$rhf_protocol_trace = 'BTFC') THEN
    display_message m='-- MAIN BATCH OUTPUT FILTER CALLED' to=job ..
          status=ignore_status
    display_message m='INPUT:' to=job status=ignore_status
    display_value input o=$local.$job_log do=ds status=ignore_status
    display_message m='STATISTICS_FILE:' to=job status=ignore_status
    display_value statistics_file o=$local.$job_log do=ds status=ignore_status
    display_message m='DEVICE_ENVIRONMENT_VARIABLE:' to=job status=ignore_status
    display_value device_environment_variable o=$local.$job_log do=ds ..
          status=ignore_status
    include_command 'display_value '//..
$string(device_environment_variable)//' do=ds o=$local.$job_log' ..
          status=ignore_status
    display_message m='FILE_ATTRIBUTES:' to=job status=ignore_status
    display_value file_attributes o=$local.$job_log do=ds status=ignore_status
    display_message m='FILE_DISPOSITION:' to=job status=ignore_status
    display_value file_disposition o=$local.$job_log do=ds status=ignore_status
  IFEND

" Determine whether the version of SCFS controlling this I/O station supports
" Batch Output Filters.  Quit if it does not.

  include_command c='test_scfs=$device_attributes('//..
$string(dev)//', banner_page_count)' status=local_status
  IF NOT local_status.normal THEN
    display_message ..
          m='-- Version of SCFS does NOT support BATCH_OUTPUT_FILTERS.' ..
          to=job status=ignore_status
    display_message m='   MAIN_BATCH_OUTPUT_FILTER abandoned.' to=job ..
          status=ignore_status
    EXIT_PROC
  IFEND

" Enter the SYSTEM_OPERATOR_UTILITY with SYSTEM_OPERATION capability.  This
" is necessary in order to use the $JOB_OUTPUT function and the
" COPY_OUTPUT_FILE command for output queue files created by other users.

  SYSTEM_OPERATOR_UTILITY capability=system_operation

" Initialize some common variables.

    data_mode = file_attributes.data_mode
    ec4 = $translate(ltu, $device_attributes(dev, external_characteristics_4))
    filter_input.system_file_name = input.system_file_name
    filter_input.password = input.password
    user_info = $translate(ltu, $job_output(input.system_file_name, ui))

" Execute commands from DEBUG_COMMANDS file (if any).

    IF ($file(debug_commands, size) > 0) THEN
      include_file debug_commands status=local_status
      IF NOT local_status.normal THEN
        display_message m='** Main Output Filter DEBUG_COMMANDS failed.' ..
              to=job status=ignore_status
        EXIT_PROC WITH local_status
      IFEND
    IFEND

" Validate user access to printer.
"
"   Site-defined convention
"   -----------------------
"
"   File $SYSTEM.BATCH_DEVICE_SUPPORT.PRINTER_VALIDATION is used to specify
"   device access restrictions.  This file should be protected by setting its
"   ring attributes to (6,6,6).  See the CONTROL_ACCESS filter for the format
"   of this file.  Note that if the file does not exist or is empty, no
"   validation checking is performed.
"
"   Note that this filter does not really filter data (no OUTPUT is produced).

    control_access sfn=input.system_file_name dev=dev ..
          af=printer_validation_file sf=statistics_file fd=file_disposition ..
          status=local_status

    IF NOT local_status.normal THEN
      display_message m='** The CONTROL_ACCESS Output Filter failed.' to=job ..
            status=ignore_status
      EXIT_PROC WITH local_status
    IFEND

    EXIT_PROC WHEN (file_disposition = hold) " Access has been denied

" Process files for PostScript devices.
"
"   Site-defined convention
"   -----------------------
"
"   If the device TERMINAL_MODEL is POSTSCRIPT then:
"
"   - If the file DATA_MODE is TRANSPARENT or the OUTPUT_ATTRIBUTE
"     USER_INFORMATION (specified on the PRINT_FILE) is 'POSTSCRIPT' then
"     the file is a PostScript file and is filtered.  The output from this
"     filter is TRANSPARENT.
"
"   - If the file DATA_MODE is CODED (with USER_INFORMATION <> 'POSTSCRIPT')
"     then no PostScript filtering is done.

    IF ($device_attributes(dev, terminal_model) = postscript) AND ..
          ((data_mode = transparent) OR (user_info = 'POSTSCRIPT')) THEN

      output = $unique($local) " Define new filter output file

      preprocess_postscript_file i=filter_input o=output ..
            dc=postscript_dictionary_catalog dn=postscript_dictionaries ..
            dm=data_mode status=local_status

      IF $field(filter_input, file, initialized) THEN
        delete_file filter_input.file status=ignore_status
      IFEND

      IF NOT local_status.normal THEN
        display_message ..
              m='** The PREPROCESS_POSTSCRIPT_FILE Output Filter failed.' ..
              to=job status=ignore_status
        EXIT_PROC WITH local_status
      IFEND

      file_attributes.data_mode = data_mode
      filter_input.file = output " Prepare for possible chaining of filters

" Add PostScript Banner.  This is only done if the device BPC is 0 and EC4
" is 'BPBOF1' (see banner page convention, below).

      IF ($device_attributes(dev, banner_page_count) = 0) AND (ec4 = 'BPBOF1')..
             THEN

        output = $unique($local) " Define new filter output file

        generate_postscript_banner i=filter_input o=output dm=data_mode ..
              status=local_status

        IF $field(filter_input, file, initialized) THEN
          delete_file filter_input.file status=ignore_status
        IFEND

        IF NOT local_status.normal THEN
          display_message m=..
'** The GENERATE_POSTSCRIPT_BANNER_PAGE Output Filter failed.' to=job ..
                status=ignore_status
          EXIT_PROC WITH local_status
        IFEND

        file_attributes.data_mode = data_mode
        filter_input.file = output " Prepare for possible chaining of filters

      IFEND

      EXIT_PROC " Can do no more with transparent PostScript file

    IFEND

" Process files with embedded ASCII format effectors.
"
"   Site-defined convention
"   -----------------------
"
"   If the file USER_INFORMATION (specified on the PRINT_FILE) is 'ASCII'
"   then the file contains ASCII format effectors and is filtered.  The
"   output from this filter is always CODED.

    IF user_info = 'ASCII' THEN

      output = $unique($local) " Define new filter output file

      emulate_format_effectors i=filter_input o=output hts=standard vts=none ..
            pl=file_attributes.page_length pw=file_attributes.page_width ..
            dm=data_mode status=local_status

      IF $field(filter_input, file, initialized) THEN
        delete_file filter_input.file status=ignore_status
      IFEND

      IF NOT local_status.normal THEN
        display_message ..
              m='** The EMULATE_FORMAT_EFFECTORS Output Filter failed.' ..
              to=job status=ignore_status
        EXIT_PROC WITH local_status
      IFEND

      file_attributes.data_mode = data_mode
      filter_input.file = output " Prepare for possible chaining of filters

    IFEND

" Generate Banner Pages.
"
"   Site-defined convention
"   -----------------------
"
"   If the device attribute BANNER_PAGE_COUNT is 0 (no banners generated by
"   the CDCNET DI) then EXTERNAL_CHARACTERISTICS_4 attribute specifies banner
"   placement.
"
"   EXTERNAL_CHARACTERISTICS_4 is assumed to be of the form:  'BPpppn'
"
"     Where:  ppp = BAE for banner at Beginning And End of file
"             ppp = BOF for banner at Beginning Of File
"             ppp = EOF for banner at End Of File
"
"             n = Number of banner-pages (1..3)
"
"   If EXTERNAL_CHARACTERISTICS_4 is not in the recognized format, no
"   banners are generated.

    IF $device_attributes(dev, banner_page_count) = 0 THEN
      IF ((ec4(1, 5) = 'BPBAE') OR (ec4(1, 5) = 'BPBOF') OR ..
            (ec4(1, 5) = 'BPEOF')) THEN
        include_command 'banner_count = '//$integer(ec4(6, 1)) ..
              status=local_status
        IF local_status.normal THEN

          output = $unique($local) " Define new filter output file

          generate_banner_page i=filter_input o=output bp=$name(ec4(3, 3)) ..
                dev=dev bpc=banner_count cb=file_attributes.comment_banner ..
                dm=data_mode rb=file_attributes.routing_banner ..
                status=local_status

          IF $field(filter_input, file, initialized) THEN
            delete_file filter_input.file status=ignore_status
          IFEND
        IFEND

        IF NOT local_status.normal THEN
          display_message ..
                m='** The GENERATE_BANNER_PAGE Output Filter failed.' to=job ..
                status=ignore_status
          EXIT_PROC WITH local_status
        IFEND

        file_attributes.data_mode = data_mode
        filter_input.file = output " Prepare for possible chaining of filters

      IFEND
    IFEND

" Process files destined to the URI Printer.
"
"   Site-defined convention
"   -----------------------
"
"   If the file STATION (specified on the PRINT_FILE) is 'URIPRINT',
"   then the file is filtered.  The input to this filter must be CODED and
"   the output is always TRANSPARENT.

    IF ($device_attributes(dev, station) = URIPRINT) AND ..
       (file_attributes.data_mode = CODED) THEN

      output = $unique($local) " Define new filter output file

      preprocess_uri i=filter_input o=output ..
            fpd = file_attributes.vertical_print_density ..
            dpd = $device_attributes(dev, vertical_print_density) ..
            pl=file_attributes.page_length pw=file_attributes.page_width ..
            status=local_status

      IF $field(filter_input, file, initialized) THEN
        delete_file filter_input.file status=ignore_status
      IFEND

      IF NOT local_status.normal THEN
        display_message ..
              m='** The PREPROCESS_URI Output Filter failed.' ..
              to=job status=ignore_status
        EXIT_PROC WITH local_status
      IFEND

      file_attributes.data_mode = transparent
      filter_input.file = output " Prepare for possible chaining of filters

    IFEND

  QUIT

PROCEND main_batch_output_filter
*DECK DECK=NFM$MANAGE_STORE_FORWARD_NETWRK EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : nfm$manage_store_forward_network' ??
MODULE nfm$manage_store_forward_netwrk;

{ PURPOSE:
{   This module will create and display the System Store/Forward
{   Network file.  This file contains the information for the Queue
{   File Facilities (QTF and NTF) for store and forward name changes
{   and application changes (ie. from QTF to NTF or from NTF to QTF).
{
{ DESIGN:
{   1.  Add this utility to the User's command list.
{   2.  Read the input file to determine what the User intends to do.
{   3.  If the User wants to display the Store/Forward Network file,
{       display the information that the User is requesting.
{   4.  If the User wants to verify an input file for the purpose of
{       creating the Store/Forward Network file, read the input file
{       and verify that all values are specified correctly.
{   5.  If the User wants to install a new Store/Forward Network file,
{       verify that the input file is valid and then create/replace
{       the System Store/Forward Network file.
{   6.  If the User wants to create a Store/Forward directive file
{       from the current System Store/Forward Network file, read the
{       System Store/Forward Network file and recreate the directives.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$ring_attributes
*copyc cle$ecc_expression_result
*copyc nfc$manage_store_forward_file
*copyc nfc$sf_directive_command_names
*copyc nfe$manage_store_forward_netwrk
*copyc nft$sf_application_name_info
*copyc nft$sf_application_set
*copyc nft$sf_destination_names_array
*copyc nft$sf_dest_group_comparision
*copyc nft$sf_display_name_value
*copyc nft$sf_display_options_set
*copyc nft$sf_group_name_information
*copyc nft$sf_rel_ptr_appl_name_info
*copyc nft$sf_rel_ptr_group_name_info
*copyc nft$sf_rel_ptr_source_name_info
*copyc nft$sf_rel_ptr_target_name_info
*copyc nft$sf_source_name_information
*copyc nft$sf_target_name_information
*copyc oss$job_paged_literal
*copyc osv$lower_to_upper
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc amp$return
*copyc amp$set_segment_eoi
*copyc avp$get_capability
*copyc clp$begin_utility
*copyc clp$close_display
*copyc clp$convert_file_ref_to_string
*copyc clp$count_list_elements
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc clp$get_parameter_list_text
*copyc clp$include_file
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$reset_for_next_display_page
*copyc clp$put_display
*copyc clp$scan_command_file
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$copy_file
*copyc fsp$open_file
*copyc jmp$system_job
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc nfp$close_store_forward_file
*copyc nfp$open_store_forward_file
*copyc nfv$manage_sfn_directives
*copyc nfv$manage_sf_network
*copyc nfv$sf_application_names
*copyc pfp$attach
*copyc pfp$define
*copyc pfp$purge
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_legible_date_time
*copyc pmp$get_os_version
*copyc pmp$get_unique_name
*copyc pmp$log
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    output_file_identifier: amt$file_identifier,
    output_file_open: boolean,
    ptr_application_name_list: ^nft$sf_application_name_info,
    ptr_group_name_list: ^nft$sf_group_name_information,
    ptr_source_name_list: ^nft$sf_source_name_information,
    ptr_target_name_list: ^nft$sf_target_name_information;

?? OLDTITLE ??
?? NEWTITLE := 'cmd_define_application_switch', EJECT ??

{ PURPOSE:
{   This is the Utility's command DEFINE_APPLICATION_NAME_SWITCH.  It will
{   add a unique application_name onto the application_names_list.

  PROCEDURE cmd_define_application_switch
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*copyc nft$pdt_def_application_switch

    VAR
      application_information: nft$sf_application_name_info,
      application_qualifier_index: nft$sf_applications,
      ignore_status: ost$status,
      parameter_text: ^clt$parameter_list_text,
      ptr_application_qualifiers: ^clt$data_value,
      ptr_last_entry: ^nft$sf_application_name_info,
      ptr_new_application_info: ^nft$sf_application_name_info;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      IF status.condition <> cle$parameters_displayed THEN

{ Get the parameter list and write the command and the parameter list to the output file

        clp$get_parameter_list_text (^parameter_list, parameter_text, ignore_status);
        write_command_to_output (nfc$cmd_def_appl_name_switch, parameter_text^, ignore_status);
        write_status_to_output (status);
      IFEND;
      RETURN;
    IFEND;

{ Get the parameter list and write the command and the parameter list to the output file

    clp$get_parameter_list_text (^parameter_list, parameter_text, status);
    IF NOT status.normal THEN
      write_status_to_output (status);
      RETURN;
    IFEND;

    write_command_to_output (nfc$cmd_def_appl_name_switch, parameter_text^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Save the next_hop_application value

    application_information.next_hop_application := pvt [p$next_hop_application].value^ .name_value;

{ Initialize the application qualifier set to NULL and then add all unique application qualifiers into the set

    application_information.application_qualifier := $nft$sf_application_set [];
    ptr_application_qualifiers := pvt [p$application_qualifier].value;

    WHILE ptr_application_qualifiers <> NIL DO
    /add_application_qual_to_set/
      FOR application_qualifier_index := LOWERBOUND (nfv$sf_application_names)
            TO UPPERBOUND (nfv$sf_application_names) DO
        IF ptr_application_qualifiers^ .element_value^ .name_value = nfv$sf_application_names
              [application_qualifier_index] THEN
          application_information.application_qualifier := application_information.application_qualifier +
                $nft$sf_application_set [application_qualifier_index];
          EXIT /add_application_qual_to_set/;
        IFEND;
      FOREND /add_application_qual_to_set/;
      ptr_application_qualifiers := ptr_application_qualifiers^ .link;
    WHILEND;

    IF pvt [p$destination_group_qualifier].specified THEN
      application_information.destination_group_qualifier := pvt [p$destination_group_qualifier].value^ .
            name_value;
    ELSE

{ The destination_group_qualifier was not specified, which means that the application will be switch for all
{ destinations.

      application_information.destination_group_qualifier := osc$null_name;
    IFEND;

    application_information.link.relative_pointer := FALSE;
    application_information.link.ptr := NIL;

{ Allocate some space for the new application_name_switch information and add it to the end of the linked list

    ALLOCATE ptr_new_application_info;
    ptr_new_application_info^ := application_information;

    IF ptr_application_name_list = NIL THEN
      ptr_application_name_list := ptr_new_application_info;
    ELSE
      ptr_last_entry := ptr_application_name_list;
      IF ptr_last_entry^.link.relative_pointer THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
              'CMD_DEFINE_APPLICATION_SWITCH 1', status);
        RETURN;
      IFEND;
      WHILE ptr_last_entry^.link.ptr <> NIL DO
        ptr_last_entry := ptr_last_entry^.link.ptr;
        IF ptr_last_entry^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                'CMD_DEFINE_APPLICATION_SWITCH 2', status);
          RETURN;
        IFEND;
      WHILEND;
      ptr_last_entry^.link.ptr := ptr_new_application_info;
    IFEND;
  PROCEND cmd_define_application_switch;
?? OLDTITLE ??
?? NEWTITLE := 'cmd_define_destination_group', EJECT ??

{ PURPOSE:
{   This is the Utility's command DEFINE_DESTINATION_GROUP.  It will
{   add a unique group_name onto the group_names_list.  If a duplicate
{   destination already exists the second occurrance will be ignored.

  PROCEDURE cmd_define_destination_group
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*copyc nft$pdt_def_destination_group

    VAR
      destination_name: nft$parameter_24_definition,
      destination_name_array_index: ost$non_negative_integers,
      duplicate_name_found: boolean,
      group_name_information: nft$sf_group_name_information,
      ignore_status: ost$status,
      index: ost$non_negative_integers,
      number_of_destination_names: ost$non_negative_integers,
      parameter_text: ^clt$parameter_list_text,
      ptr_destination_names: ^clt$data_value,
      ptr_last_entry: ^nft$sf_group_name_information,
      ptr_new_group_name_info: ^nft$sf_group_name_information;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      IF status.condition <> cle$parameters_displayed THEN

{ Get the parameter list and write the command and the parameter list to the output file

        clp$get_parameter_list_text (^parameter_list, parameter_text, ignore_status);
        write_command_to_output (nfc$cmd_def_destination_group, parameter_text^, ignore_status);
        write_status_to_output (status);
      IFEND;
      RETURN;
    IFEND;

{ Get the parameter list and write the command and the parameter list to the output file

    clp$get_parameter_list_text (^parameter_list, parameter_text, status);
    IF NOT status.normal THEN
      write_status_to_output (status);
      RETURN;
    IFEND;

    write_command_to_output (nfc$cmd_def_destination_group, parameter_text^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    group_name_information.group_name := pvt [p$group_name].value^ .name_value;

{ Get the number of destination_names specified.

    number_of_destination_names := clp$count_list_elements (pvt [p$destination_name].value);

    destination_name_array_index := 0;

{ Allocate space for the list of destination_names.

    group_name_information.ptr_destination_names.relative_pointer := FALSE;
    ALLOCATE group_name_information.ptr_destination_names.ptr: [1 .. number_of_destination_names];
    ptr_destination_names := pvt [p$destination_name] .value;

    WHILE ptr_destination_names <> NIL DO
      convert_parameter_to_ost$name (ptr_destination_names^ .element_value^, destination_name.value,
            destination_name.size, status);
      IF NOT status.normal THEN
        IF (status.condition = nfe$sf_name_too_short) OR (status.condition = nfe$sf_name_too_long) OR
              (status.condition = nfe$sf_string_too_short) OR (status.condition = nfe$sf_string_too_long) THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'destination_name', status);
        IFEND;
        write_status_to_output (status);
        RETURN;
      IFEND;

{ Check to see if the destination_name has been specified before.

      duplicate_name_found := FALSE;

      IF destination_name_array_index > 0 THEN

      /unique_destination_name/
        FOR index := 1 TO destination_name_array_index DO
          IF destination_name = group_name_information.ptr_destination_names.ptr^ [index] THEN
            duplicate_name_found := TRUE;
            EXIT /unique_destination_name/;
          IFEND;
        FOREND /unique_destination_name/;
      IFEND;

{ If the destination_name is unique add it into the destination name array

      IF NOT duplicate_name_found THEN
        destination_name_array_index := destination_name_array_index + 1;
        group_name_information.ptr_destination_names.ptr^ [destination_name_array_index] := destination_name;
      IFEND;
      ptr_destination_names := ptr_destination_names^ .link;
    WHILEND;

    group_name_information.destination_name_count := destination_name_array_index;
    group_name_information.link.relative_pointer := FALSE;
    group_name_information.link.ptr := NIL;

{ Allocate some space for the new destination_group information and add it to the end of the linked list.

    ALLOCATE ptr_new_group_name_info;
    ptr_new_group_name_info^ := group_name_information;

    IF ptr_group_name_list = NIL THEN
      ptr_group_name_list := ptr_new_group_name_info;
    ELSE
      ptr_last_entry := ptr_group_name_list;
      IF ptr_last_entry^.link.relative_pointer THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
              'CMD_DEFINE_DESTINATION_GROUP 1', status);
        RETURN;
      IFEND;
      WHILE ptr_last_entry^.link.ptr <> NIL DO
        ptr_last_entry := ptr_last_entry^.link.ptr;
        IF ptr_last_entry^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                'CMD_DEFINE_DESTINATION_GROUP 2', status);
          RETURN;
        IFEND;
      WHILEND;
      ptr_last_entry^.link.ptr := ptr_new_group_name_info;
    IFEND;
  PROCEND cmd_define_destination_group;
?? OLDTITLE ??
?? NEWTITLE := 'cmd_define_dest_name_switch', EJECT ??

{ PURPOSE:
{   This is the Utility's command DEFINE_DESTINATION_NAME_SWITCH.  It will
{   add a unique target_name onto the target_names_list.

  PROCEDURE cmd_define_dest_name_switch
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*copyc nft$pdt_def_dest_name_switch

    VAR
      application_qualifier_index: nft$sf_applications,
      application_qualifier_set: nft$sf_application_set,
      ignore_status: ost$status,
      parameter_text: ^clt$parameter_list_text,
      ptr_application_qualifiers: ^clt$data_value,
      ptr_last_entry: ^nft$sf_target_name_information,
      ptr_new_target_name_info: ^nft$sf_target_name_information,
      target_name_information: nft$sf_target_name_information;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      IF status.condition <> cle$parameters_displayed THEN

{ Get the parameter list and write the command and the parameter list to the output file

        clp$get_parameter_list_text (^parameter_list, parameter_text, ignore_status);
        write_command_to_output (nfc$cmd_def_target_name_switch, parameter_text^, ignore_status);
        write_status_to_output (status);
      IFEND;
      RETURN;
    IFEND;

{ Get the parameter list and write the command and the parameter list to the output file

    clp$get_parameter_list_text (^parameter_list, parameter_text, status);
    IF NOT status.normal THEN
      write_status_to_output (status);
      RETURN;
    IFEND;

    write_command_to_output (nfc$cmd_def_target_name_switch, parameter_text^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    convert_parameter_to_ost$name (pvt [p$name].value^, target_name_information.target_name.value,
          target_name_information.target_name.size, status);
    IF NOT status.normal THEN
      IF (status.condition = nfe$sf_name_too_short) OR (status.condition = nfe$sf_name_too_long) OR
            (status.condition = nfe$sf_string_too_short) OR (status.condition = nfe$sf_string_too_long) THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'destination name', status);
      IFEND;
      write_status_to_output (status);
      RETURN;
    IFEND;

    convert_parameter_to_ost$name (pvt [p$next_hop_name].value^, target_name_information.next_hop_name.value,
          target_name_information.next_hop_name.size, status);
    IF NOT status.normal THEN
      IF (status.condition = nfe$sf_name_too_short) OR (status.condition = nfe$sf_name_too_long) OR
            (status.condition = nfe$sf_string_too_short) OR (status.condition = nfe$sf_string_too_long) THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'next_hop_name', status);
      IFEND;
      write_status_to_output (status);
      RETURN;
    IFEND;

{ Initialize the application qualifier set to NULL and then add all unique application qualifiers into the set

    target_name_information.application_qualifier := $nft$sf_application_set [];
    ptr_application_qualifiers := pvt [p$application_qualifier] .value;

    WHILE ptr_application_qualifiers <> NIL DO
    /add_application_qual_to_set/
      FOR application_qualifier_index := LOWERBOUND (nfv$sf_application_names)
            TO UPPERBOUND (nfv$sf_application_names) DO
        IF ptr_application_qualifiers^ .element_value^ .name_value = nfv$sf_application_names
              [application_qualifier_index] THEN
          target_name_information.application_qualifier := target_name_information.application_qualifier +
                $nft$sf_application_set [application_qualifier_index];
          EXIT /add_application_qual_to_set/;
        IFEND;
      FOREND /add_application_qual_to_set/;
      ptr_application_qualifiers := ptr_application_qualifiers^ .link;
    WHILEND;
    target_name_information.link.relative_pointer := FALSE;
    target_name_information.link.ptr := NIL;

{ Allocate some space for the new target_name_switch information and add it to the end of the linked list.

    ALLOCATE ptr_new_target_name_info;
    ptr_new_target_name_info^ := target_name_information;

    IF ptr_target_name_list = NIL THEN
      ptr_target_name_list := ptr_new_target_name_info;
    ELSE
      ptr_last_entry := ptr_target_name_list;
      IF ptr_last_entry^.link.relative_pointer THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
              'CMD_DEFINE_DEST_NAME_SWITCH 1', status);
        RETURN;
      IFEND;
      WHILE ptr_last_entry^.link.ptr <> NIL DO
        ptr_last_entry := ptr_last_entry^.link.ptr;
        IF ptr_last_entry^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                'CMD_DEFINE_DEST_NAME_SWITCH 2', status);
          RETURN;
        IFEND;
      WHILEND;
      ptr_last_entry^.link.ptr := ptr_new_target_name_info;
    IFEND;
  PROCEND cmd_define_dest_name_switch;
?? OLDTITLE ??
?? NEWTITLE := 'cmd_define_source_name_switch', EJECT ??

{ PURPOSE:
{   This is the Utility's command DEFINE_SOURCE_NAME_SWITCH.  It will
{   add a unique source_name onto the source_names_list.

  PROCEDURE cmd_define_source_name_switch
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*copyc nft$pdt_def_source_name_switch

    VAR
      application_qualifier_index: nft$sf_applications,
      ignore_status: ost$status,
      source_name_information: nft$sf_source_name_information,
      parameter_text: ^clt$parameter_list_text,
      ptr_application_qualifiers: ^clt$data_value,
      ptr_last_entry: ^nft$sf_source_name_information,
      ptr_new_source_name_info: ^nft$sf_source_name_information;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      IF status.condition <> cle$parameters_displayed THEN

{ Get the parameter list and write the command and the parameter list to the output file

        clp$get_parameter_list_text (^parameter_list, parameter_text, ignore_status);
        write_command_to_output (nfc$cmd_def_source_name_switch, parameter_text^, ignore_status);
        write_status_to_output (status);
      IFEND;
      RETURN;
    IFEND;

{ Get the parameter list and write the command and the parameter list to the output file

    clp$get_parameter_list_text (^parameter_list, parameter_text, status);
    IF NOT status.normal THEN
      write_status_to_output (status);
      RETURN;
    IFEND;

    write_command_to_output (nfc$cmd_def_source_name_switch, parameter_text^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    convert_parameter_to_ost$name (pvt [p$name].value^, source_name_information.source_name.value,
          source_name_information.source_name.size, status);
    IF NOT status.normal THEN
      IF (status.condition = nfe$sf_name_too_short) OR (status.condition = nfe$sf_name_too_long) OR
            (status.condition = nfe$sf_string_too_short) OR (status.condition = nfe$sf_string_too_long) THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'source name', status);
      IFEND;
      write_status_to_output (status);
      RETURN;
    IFEND;

    convert_parameter_to_ost$name (pvt [p$next_hop_name].value^, source_name_information.next_hop_name.value,
          source_name_information.next_hop_name.size, status);
    IF NOT status.normal THEN
      IF (status.condition = nfe$sf_name_too_short) OR (status.condition = nfe$sf_name_too_long) OR
            (status.condition = nfe$sf_string_too_short) OR (status.condition = nfe$sf_string_too_long) THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'next_hop_name', status);
      IFEND;
      write_status_to_output (status);
      RETURN;
    IFEND;

{ Initialize the application qualifier set to NULL and then add all unique application qualifiers into the set

    source_name_information.application_qualifier := $nft$sf_application_set [];
    ptr_application_qualifiers := pvt [p$application_qualifier] .value;

    WHILE ptr_application_qualifiers <> NIL DO
    /add_application_qual_to_set/
      FOR application_qualifier_index := LOWERBOUND (nfv$sf_application_names)
            TO UPPERBOUND (nfv$sf_application_names) DO
        IF ptr_application_qualifiers^ .element_value^ .name_value = nfv$sf_application_names
              [application_qualifier_index] THEN
          source_name_information.application_qualifier := source_name_information.application_qualifier +
                $nft$sf_application_set [application_qualifier_index];
          EXIT /add_application_qual_to_set/;
        IFEND;
      FOREND /add_application_qual_to_set/;
      ptr_application_qualifiers := ptr_application_qualifiers^ .link;
    WHILEND;

    IF pvt [p$destination_group_qualifier].specified THEN
      source_name_information.destination_group_qualifier := pvt [p$destination_group_qualifier].value^ .
            name_value;
    ELSE

{ The destination_group_qualifier was not specified, which means that the source name will be switch for all
{ destinations.

      source_name_information.destination_group_qualifier := osc$null_name;
    IFEND;
    source_name_information.link.relative_pointer := FALSE;
    source_name_information.link.ptr := NIL;

{ Allocate some space for the new source_name_switch information and add it to the end of the linked list.

    ALLOCATE ptr_new_source_name_info;
    ptr_new_source_name_info^ := source_name_information;

    IF ptr_source_name_list = NIL THEN
      ptr_source_name_list := ptr_new_source_name_info;
    ELSE
      ptr_last_entry := ptr_source_name_list;
      IF ptr_last_entry^.link.relative_pointer THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
              'CMD_DEFINE_SOURCE_NAME_SWITCH 1', status);
        RETURN;
      IFEND;
      WHILE ptr_last_entry^.link.ptr <> NIL DO
        ptr_last_entry := ptr_last_entry^.link.ptr;
        IF ptr_last_entry^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                'CMD_DEFINE_SOURCE_NAME_SWITCH 2', status);
          RETURN;
        IFEND;
      WHILEND;
      ptr_last_entry^.link.ptr := ptr_new_source_name_info;
    IFEND;
  PROCEND cmd_define_source_name_switch;
?? OLDTITLE ??
?? NEWTITLE := 'cmd_display_sf_network', EJECT ??

{ PURPOSE:
{   This is the Utility's command DISPLAY_STORE_FORWARD_NETWORK.  It will
{   display the SYSTEM'S existing STORE/FORWARD Network file.

  PROCEDURE cmd_display_sf_network
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*copyc nft$pdt_display_sf_network

    CONST
      all_known_destinations = 'CHANGED FOR ALL DESTINATIONS',
      append_application_information = ' with the APPLICATION_QUALIFIER of ',
      append_application_length = 35,
      append_name_information = '  with the NAME or STRING of ',
      append_name_length = 29,
      application_ignored_message = ' the APPLICATION_QUALIFIER is being IGNORED.',
      application_name_w_space_length = 5,
      information_message = '  --  INFORMATION',
      line_skip_for_first_entry = 2,
      line_skip_for_next_entry = 1,
      max_display_line_length = 72,
      no_information_message = ' has no information defined',
      start_col_for_info = 40;

    VAR
      application_value: nft$sf_display_name_value,
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      display_option_index: ost$non_negative_integers,
      display_option_set: nft$sf_display_options_set,
      name_value: nft$sf_display_name_value,
      ptr_display_options: ^clt$data_value,
      store_forward_file_info: nft$store_forward_file_info;

?? NEWTITLE := 'display_application_name_switch', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to display the APPLICATION_NAME_SWITCHes to
{   the MANAGE_STORE_FORWARD_NETWORK user.

    PROCEDURE display_application_name_switch
      (    store_forward_file_info: nft$store_forward_file_info;
           name_value: nft$sf_display_name_value;
           application_value: nft$sf_display_name_value;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      CONST
        application_qual_parameter = '    APPLICATION_QUALIFIER            :  ',
        destination_group_parameter = '    DESTINATION_GROUP_QUALIFIER      :  ',
        next_hop_appl_parameter = '    NEXT_HOP_APPLICATION             :  ';

      VAR
        application_found: boolean,
        application_name: nft$sf_applications,
        application_name_offset: ost$non_negative_integers,
        application_qualifier_index: nft$sf_applications,
        display_line: string (max_display_line_length),
        display_line_length: integer,
        first_entry_found: boolean,
        ignore_status: ost$status,
        name_found: boolean,
        ptr_current_application_info: ^nft$sf_application_name_info;

      status.normal := TRUE;

{ Determine the application name for the information to display

      IF application_value.value_specified THEN
        application_name := nfc$sf_unknown_application;

      /find_application_qualifier/
        FOR application_qualifier_index := LOWERBOUND (nfv$sf_application_names)
              TO UPPERBOUND (nfv$sf_application_names) DO
          IF application_value.value = nfv$sf_application_names [application_qualifier_index] THEN
            application_name := application_qualifier_index;
            EXIT /find_application_qualifier/;
          IFEND;
        FOREND /find_application_qualifier/;
      IFEND;

      first_entry_found := FALSE;
      ptr_current_application_info := #PTR (store_forward_file_info.pointers.ptr_application_name_list,
            store_forward_file_info.segment_pointer.sequence_pointer^);

      WHILE ptr_current_application_info <> NIL DO
        IF NOT ptr_current_application_info^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_rptr,
                'DISPLAY_APPLICATION_NAME_SWITCH', status);
          RETURN;
        IFEND;

{ Verify that the value specified on the name parameter is the same as the next_hop_application name or
{ destination_group_qualifier name.  If no name parameter was specified then all entries will be displayed.

        IF name_value.value_specified THEN
          IF (name_value.value = ptr_current_application_info^.next_hop_application) OR
                (name_value.value = ptr_current_application_info^.destination_group_qualifier) THEN
            name_found := TRUE;
          ELSE
            name_found := FALSE;
          IFEND;
        ELSE
          name_found := TRUE;
        IFEND;

{ Verify that the value specified on the application_qualifier parameter is in the set of
{ application_qualifiers for this entry.  If no application_qualifier was specified then all entries will be
{ displayed.

        IF application_value.value_specified THEN
          IF application_name IN ptr_current_application_info^.application_qualifier THEN
            application_found := TRUE;
          ELSE
            application_found := FALSE;
          IFEND;
        ELSE
          application_found := TRUE;
        IFEND;

{ Display the entry if both the name value was found (or not specified) and the application_qualifier value
{ was found (or not specified).

        IF name_found AND application_found THEN
          IF NOT first_entry_found THEN

{ Display the header on the first page of information for this directive, once an qualifing entry has been
{ found.

            display_first_header (nfc$cmd_def_appl_name_switch, display_control);
            first_entry_found := TRUE;
          IFEND;

{ Display all the information to the output file for this directive. Display the next_hop_application
{ information

          clp$new_display_line (display_control, line_skip_for_next_entry, ignore_status);
          display_line := next_hop_appl_parameter;
          display_line (start_col_for_info, * ) := ptr_current_application_info^.next_hop_application;
          clp$put_display (display_control, display_line, clc$trim, ignore_status);

{ Display the application_qualifier information

          application_name_offset := 0;
          display_line := application_qual_parameter;
          FOR application_qualifier_index := LOWERBOUND (nfv$sf_application_names)
                TO UPPERBOUND (nfv$sf_application_names) DO
            IF application_qualifier_index IN ptr_current_application_info^.application_qualifier THEN
              display_line ((start_col_for_info + application_name_offset), * ) :=
                    nfv$sf_application_names [application_qualifier_index];
              application_name_offset := application_name_offset + application_name_w_space_length;
            IFEND;
          FOREND;
          clp$put_display (display_control, display_line, clc$trim, ignore_status);

{ Display the destination_group_qualifier information

          display_line := destination_group_parameter;
          IF ptr_current_application_info^.destination_group_qualifier = osc$null_name THEN
            display_line (start_col_for_info, * ) := all_known_destinations;
          ELSE
            display_line (start_col_for_info, * ) := ptr_current_application_info^.
                  destination_group_qualifier;
          IFEND;
          clp$put_display (display_control, display_line, clc$trim, ignore_status);
        IFEND;

{ Process next entry in the linked list for this directive.

        ptr_current_application_info := #PTR (ptr_current_application_info^.link.relative_ptr,
              store_forward_file_info.segment_pointer.sequence_pointer^);
      WHILEND;

      IF NOT first_entry_found THEN

{ Tell the user no information was found for the requested information for this directive.

        display_no_entry_found (nfc$cmd_def_appl_name_switch, name_value, application_value, display_control);
      IFEND;
    PROCEND display_application_name_switch;
?? OLDTITLE ??
?? NEWTITLE := 'display_destination_name_switch', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to display the DESTINATION_NAME_SWITCHes to
{   the MANAGE_STORE_FORWARD_NETWORK user.

    PROCEDURE display_destination_name_switch
      (    store_forward_file_info: nft$store_forward_file_info;
           name_value: nft$sf_display_name_value;
           application_value: nft$sf_display_name_value;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      CONST
        application_qual_parameter = '      APPLICATION_QUALIFIER          :  ',
        next_hop_name_parameter = '      NEXT_HOP_NAME                  :  ',
        target_name_parameter = '    DESTINATION NAME                 :  ';

      VAR
        application_found: boolean,
        application_name: nft$sf_applications,
        application_name_offset: ost$non_negative_integers,
        application_qualifier_index: nft$sf_applications,
        display_line: string (max_display_line_length),
        display_line_length: integer,
        first_entry_found: boolean,
        ignore_status: ost$status,
        name_found: boolean,
        ptr_current_target_name_info: ^nft$sf_target_name_information;

      status.normal := TRUE;

{ Determine the application name for the information to display

      IF application_value.value_specified THEN
        application_name := nfc$sf_unknown_application;

      /find_application_qualifier/
        FOR application_qualifier_index := LOWERBOUND (nfv$sf_application_names)
              TO UPPERBOUND (nfv$sf_application_names) DO
          IF application_value.value = nfv$sf_application_names [application_qualifier_index] THEN
            application_name := application_qualifier_index;
            EXIT /find_application_qualifier/;
          IFEND;
        FOREND /find_application_qualifier/;
      IFEND;

      first_entry_found := FALSE;
      ptr_current_target_name_info := #PTR (store_forward_file_info.pointers.ptr_target_name_list,
            store_forward_file_info.segment_pointer.sequence_pointer^);

      WHILE ptr_current_target_name_info <> NIL DO
        IF NOT ptr_current_target_name_info^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_rptr,
                'DISPLAY_DESTINATION_NAME_SWITCH', status);
          RETURN;
        IFEND;

{ Verify that the value specified on the name parameter is the same as the target_name or next_hop_name.
{ If no name parameter was specified then all entries will be displayed.

        IF name_value.value_specified THEN
          IF (name_value.value = ptr_current_target_name_info^.target_name.value) OR
                (name_value.value = ptr_current_target_name_info^.next_hop_name.value) THEN
            name_found := TRUE;
          ELSE
            name_found := FALSE;
          IFEND;
        ELSE
          name_found := TRUE;
        IFEND;

{ Verify that the value specified on the application_qualifier parameter is in the set of
{ application_qualifiers for this entry.  If no application_qualifier was specified then all entries will be
{ displayed.

        IF application_value.value_specified THEN
          IF application_name IN ptr_current_target_name_info^.application_qualifier THEN
            application_found := TRUE;
          ELSE
            application_found := FALSE;
          IFEND;
        ELSE
          application_found := TRUE;
        IFEND;

{ Display the entry if both the name value was found (or not specified) and the application_qualifier value
{ was found (or not specified).

        IF name_found AND application_found THEN
          IF NOT first_entry_found THEN

{ Display the header on the first page of information for this directive, once an qualifing entry has been
{ found.

            display_first_header (nfc$cmd_def_target_name_switch, display_control);
            first_entry_found := TRUE;
          IFEND;

{ Display all the information to the output file for this directive.  Display the current destination name
{ information

          clp$new_display_line (display_control, line_skip_for_next_entry, ignore_status);
          display_line := target_name_parameter;
          display_line (start_col_for_info, * ) := ptr_current_target_name_info^.target_name.value;
          clp$put_display (display_control, display_line, clc$trim, ignore_status);

{ Display the next_hop_name information

          display_line := next_hop_name_parameter;
          display_line (start_col_for_info, * ) := ptr_current_target_name_info^.next_hop_name.value;
          clp$put_display (display_control, display_line, clc$trim, ignore_status);

{ Display the application_qualifier information

          application_name_offset := 0;
          display_line := application_qual_parameter;
          FOR application_qualifier_index := LOWERBOUND (nfv$sf_application_names)
                TO UPPERBOUND (nfv$sf_application_names) DO
            IF application_qualifier_index IN ptr_current_target_name_info^.application_qualifier THEN
              display_line ((start_col_for_info + application_name_offset), * ) :=
                    nfv$sf_application_names [application_qualifier_index];
              application_name_offset := application_name_offset + application_name_w_space_length;
            IFEND;
          FOREND;
          clp$put_display (display_control, display_line, clc$trim, ignore_status);
        IFEND;

{ Process next entry in the linked list for this directive.

        ptr_current_target_name_info := #PTR (ptr_current_target_name_info^.link.relative_ptr,
              store_forward_file_info.segment_pointer.sequence_pointer^);
      WHILEND;

      IF NOT first_entry_found THEN

{ Tell the user no information was found for the requested information for this directive.

        display_no_entry_found (nfc$cmd_def_target_name_switch, name_value, application_value,
              display_control);
      IFEND;
    PROCEND display_destination_name_switch;
?? OLDTITLE ??
?? NEWTITLE := 'display_first_header', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to display the first message
{   header on the output file before the first entry is displayed
{   for this directive.

    PROCEDURE display_first_header
      (    command_name: string ( * );
       VAR display_control: clt$display_control);

      VAR
        display_line: string (max_display_line_length),
        display_line_length: integer,
        ignore_status: ost$status;

      clp$new_display_line (display_control, line_skip_for_first_entry, ignore_status);
      display_line := ' ';
      display_line (3, * ) := command_name;
      display_line_length := clp$trimmed_string_size (display_line);
      display_line ((display_line_length + 1), * ) := information_message;
      clp$put_display (display_control, display_line, clc$trim, ignore_status);
    PROCEND display_first_header;
?? OLDTITLE ??
?? NEWTITLE := 'display_no_entry_found', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to display a message to the user
{   stating that no entries were found for the information requested
{   for this directive.

    PROCEDURE display_no_entry_found
      (    command_name: string ( * );
           name_value: nft$sf_display_name_value;
           application_value: nft$sf_display_name_value;
       VAR display_control: clt$display_control);

      CONST
        append_null_string = '''  ''',
        append_period_string = '.',
        append_string_delimiter = '''';

      VAR
        display_line: string (max_display_line_length),
        display_line_length: integer,
        ignore_status: ost$status;

{ Display the no_information was found for this directive.

      clp$new_display_line (display_control, line_skip_for_first_entry, ignore_status);
      display_line := ' ';
      display_line (3, * ) := command_name;
      display_line_length := clp$trimmed_string_size (display_line);
      display_line ((display_line_length + 1), * ) := no_information_message;
      IF NOT (name_value.value_specified OR application_value.value_specified) THEN
        display_line_length := clp$trimmed_string_size (display_line);
        display_line ((display_line_length + 1), * ) := append_period_string;
      IFEND;
      clp$put_display (display_control, display_line, clc$trim, ignore_status);

      IF name_value.value_specified THEN

{ Display the no information was found for the name qualifier for this directive.

        display_line := append_name_information;
        display_line_length := append_name_length;

        IF (name_value.value = osc$null_name) THEN
          display_line ((display_line_length + 1), * ) := append_null_string;
        ELSE
          IF first_character_is_integer (name_value.value) THEN
            display_line ((display_line_length + 1), * ) := append_string_delimiter;
            display_line_length := display_line_length + 1;
          IFEND;
          display_line ((display_line_length + 1), * ) := name_value.value;
          display_line_length := clp$trimmed_string_size (display_line);
          IF first_character_is_integer (name_value.value) THEN
            display_line ((display_line_length + 1), * ) := append_string_delimiter;
          IFEND;
        IFEND;
        IF NOT application_value.value_specified THEN
          display_line_length := clp$trimmed_string_size (display_line);
          display_line ((display_line_length + 1), * ) := append_period_string;
        IFEND;
        clp$put_display (display_control, display_line, clc$trim, ignore_status);
      IFEND;

      IF application_value.value_specified THEN

{ Display the no information was found for the application qualifier for this directive.

        IF name_value.value_specified THEN
          display_line := '  and';
          display_line_length := 6;
        ELSE
          display_line := ' ';
          display_line_length := 2;
        IFEND;

        IF command_name = nfc$cmd_def_destination_group THEN

{ Display application_qualifier ignored for the DEFINE_DESTINATION_GROUP directive since this is not a valid
{ parameter on this command.

          display_line (display_line_length, * ) := application_ignored_message;
        ELSE
          display_line (display_line_length, * ) := append_application_information;
          display_line ((display_line_length + append_application_length), * ) := application_value.value;
          display_line ((display_line_length + append_application_length + 4), * ) := append_period_string;
        IFEND;
        clp$put_display (display_control, display_line, clc$trim, ignore_status);
      IFEND;
    PROCEND display_no_entry_found;
?? OLDTITLE ??
?? NEWTITLE := 'display_group_names', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to display the GROUP_NAMEs to
{   the MANAGE_STORE_FORWARD_NETWORK user.

    PROCEDURE display_group_names
      (    store_forward_file_info: nft$store_forward_file_info;
           name_value: nft$sf_display_name_value;
           application_value: nft$sf_display_name_value;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      CONST
        destination_name_parameter = '      DESTINATION_NAME               :  ',
        group_name_parameter = '    GROUP_NAME                       :  ';

      VAR
        destination_name_index: ost$non_negative_integers,
        display_line: string (max_display_line_length),
        display_line_length: integer,
        first_entry_found: boolean,
        ignore_status: ost$status,
        name_found: boolean,
        ptr_current_dest_names_info: ^nft$sf_destination_names_array,
        ptr_current_group_name_info: ^nft$sf_group_name_information;

      status.normal := TRUE;
      first_entry_found := FALSE;
      ptr_current_group_name_info := #PTR (store_forward_file_info.pointers.ptr_group_name_list,
            store_forward_file_info.segment_pointer.sequence_pointer^);

      WHILE ptr_current_group_name_info <> NIL DO
        IF NOT ptr_current_group_name_info^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_rptr, 'DISPLAY_GROUP_NAMES 1',
                status);
          RETURN;
        IFEND;
        IF NOT ptr_current_group_name_info^.ptr_destination_names.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_rptr, 'DISPLAY_GROUP_NAMES 2',
                status);
          RETURN;
        IFEND;

{ Verify that the value specified on the name parameter is the same as the group_name.  If no name parameter
{ was specified then all entries will be displayed.

        IF name_value.value_specified THEN
          IF name_value.value = ptr_current_group_name_info^.group_name THEN
            name_found := TRUE;
          ELSE
            name_found := FALSE;

{ Verify that the value specified on the name parameter is in the list of destination names.

            ptr_current_dest_names_info := #PTR (ptr_current_group_name_info^.ptr_destination_names.
                  relative_ptr, store_forward_file_info.segment_pointer.sequence_pointer^);

          /find_specified_name/
            FOR destination_name_index := 1 TO ptr_current_group_name_info^.destination_name_count DO
              IF name_value.value = ptr_current_dest_names_info^ [destination_name_index].value THEN
                name_found := TRUE;
                EXIT /find_specified_name/;
              IFEND;
            FOREND /find_specified_name/;
          IFEND;
        ELSE
          name_found := TRUE;
        IFEND;

{ Display the entry if the name value was found (or not specified).

        IF name_found THEN
          IF NOT first_entry_found THEN

{ Display the header on the first page of information for this directive, once an qualifing entry has been
{ found.

            display_first_header (nfc$cmd_def_destination_group, display_control);
            IF application_value.value_specified THEN

{ Display an application_qualifier was ignored message, since the application_qualifier is not a valid
{ parameter on the DEFINE_DESTINATION_GROUP directive.

              clp$new_display_line (display_control, line_skip_for_next_entry, ignore_status);
              display_line := ' ';
              display_line (4, * ) := application_ignored_message;
              clp$put_display (display_control, display_line, clc$trim, ignore_status);
            IFEND;
            first_entry_found := TRUE;
          IFEND;

{ Display all the information to the output file for this directive.  Display the destination_group_name
{ information

          clp$new_display_line (display_control, line_skip_for_next_entry, ignore_status);
          display_line := group_name_parameter;
          display_line (start_col_for_info, * ) := ptr_current_group_name_info^.group_name;
          clp$put_display (display_control, display_line, clc$trim, ignore_status);

          display_line := destination_name_parameter;
          ptr_current_dest_names_info := #PTR (ptr_current_group_name_info^.ptr_destination_names.
                relative_ptr, store_forward_file_info.segment_pointer.sequence_pointer^);
          FOR destination_name_index := 1 TO ptr_current_group_name_info^.destination_name_count DO

{ Display the destination_names information

            display_line (start_col_for_info, * ) := ptr_current_dest_names_info^ [destination_name_index].
                  value;
            clp$put_display (display_control, display_line, clc$trim, ignore_status);
          FOREND;
        IFEND;

{ Process next entry in the linked list for this directive.

        ptr_current_group_name_info := #PTR (ptr_current_group_name_info^.link.relative_ptr,
              store_forward_file_info.segment_pointer.sequence_pointer^);
      WHILEND;

      IF NOT first_entry_found THEN

{ Tell the user no information was found for the requested information for this directive.

        display_no_entry_found (nfc$cmd_def_destination_group, name_value, application_value,
              display_control);
      IFEND;
    PROCEND display_group_names;
?? OLDTITLE ??
?? NEWTITLE := 'display_source_name_switch', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to display the SOURCE_NAME_SWITCHes to
{   the MANAGE_STORE_FORWARD_NETWORK user.

    PROCEDURE display_source_name_switch
      (    store_forward_file_info: nft$store_forward_file_info;
           name_value: nft$sf_display_name_value;
           application_value: nft$sf_display_name_value;
       VAR display_control: clt$display_control;
       VAR status: ost$status);

      CONST
        application_qual_parameter = '      APPLICATION_QUALIFIER          :  ',
        destination_group_parameter = '      DESTINATION_GROUP_QUALIFIER    :  ',
        next_hop_name_parameter = '      NEXT_HOP_NAME                  :  ',
        source_name_parameter = '    SOURCE NAME                      :  ';

      VAR
        application_found: boolean,
        application_name: nft$sf_applications,
        application_name_offset: ost$non_negative_integers,
        application_qualifier_index: nft$sf_applications,
        display_line: string (max_display_line_length),
        display_line_length: integer,
        first_entry_found: boolean,
        ignore_status: ost$status,
        name_found: boolean,
        ptr_current_source_name_info: ^nft$sf_source_name_information;

      status.normal := TRUE;

{ Determine the application name for the information to display

      IF application_value.value_specified THEN
        application_name := nfc$sf_unknown_application;

      /find_application_qualifier/
        FOR application_qualifier_index := LOWERBOUND (nfv$sf_application_names)
              TO UPPERBOUND (nfv$sf_application_names) DO
          IF application_value.value = nfv$sf_application_names [application_qualifier_index] THEN
            application_name := application_qualifier_index;
            EXIT /find_application_qualifier/;
          IFEND;
        FOREND /find_application_qualifier/;
      IFEND;

      first_entry_found := FALSE;
      ptr_current_source_name_info := #PTR (store_forward_file_info.pointers.ptr_source_name_list,
            store_forward_file_info.segment_pointer.sequence_pointer^);

      WHILE ptr_current_source_name_info <> NIL DO
        IF NOT ptr_current_source_name_info^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_rptr,
                'DISPLAY_SOURCE_NAME_SWITCH', status);
          RETURN;
        IFEND;

{ Verify that the value specified on the name parameter is the same as the source_name or next_hop_name or
{ destination_group_qualifier name.  If no name parameter was specified then all entries will be displayed.

        IF name_value.value_specified THEN
          IF (name_value.value = ptr_current_source_name_info^.source_name.value) OR
                (name_value.value = ptr_current_source_name_info^.next_hop_name.value) OR
                (name_value.value = ptr_current_source_name_info^.destination_group_qualifier) THEN
            name_found := TRUE;
          ELSE
            name_found := FALSE;
          IFEND;
        ELSE
          name_found := TRUE;
        IFEND;

{ Verify that the value specified on the application_qualifier parameter is in the set of
{ application_qualifiers for this entry.  If no application_qualifier was specified then all entries will be
{ displayed.

        IF application_value.value_specified THEN
          IF application_name IN ptr_current_source_name_info^.application_qualifier THEN
            application_found := TRUE;
          ELSE
            application_found := FALSE;
          IFEND;
        ELSE
          application_found := TRUE;
        IFEND;

{ Display the entry if both the name value was found (or not specified) and the application_qualifier value
{ was found (or not specified).

        IF name_found AND application_found THEN
          IF NOT first_entry_found THEN

{ Display the header on the first page of information for this directive, once an qualifing entry has been
{ found.

            display_first_header (nfc$cmd_def_source_name_switch, display_control);
            first_entry_found := TRUE;
          IFEND;

{ Display all the information to the output file for this directive.  Display the source_name information

          clp$new_display_line (display_control, line_skip_for_next_entry, ignore_status);
          display_line := source_name_parameter;
          display_line (start_col_for_info, * ) := ptr_current_source_name_info^.source_name.value;
          clp$put_display (display_control, display_line, clc$trim, ignore_status);

{ Display the next_hop_name information

          display_line := next_hop_name_parameter;
          display_line (start_col_for_info, * ) := ptr_current_source_name_info^.next_hop_name.value;
          clp$put_display (display_control, display_line, clc$trim, ignore_status);

{ Display the application_qualifier information

          application_name_offset := 0;
          display_line := application_qual_parameter;
          FOR application_qualifier_index := LOWERBOUND (nfv$sf_application_names)
                TO UPPERBOUND (nfv$sf_application_names) DO
            IF application_qualifier_index IN ptr_current_source_name_info^.application_qualifier THEN
              display_line ((start_col_for_info + application_name_offset), * ) :=
                    nfv$sf_application_names [application_qualifier_index];
              application_name_offset := application_name_offset + application_name_w_space_length;
            IFEND;
          FOREND;
          clp$put_display (display_control, display_line, clc$trim, ignore_status);

{ Display the destination_group_qualifier information

          display_line := destination_group_parameter;
          IF ptr_current_source_name_info^.destination_group_qualifier = osc$null_name THEN
            display_line (start_col_for_info, * ) := all_known_destinations;
          ELSE
            display_line (start_col_for_info, * ) := ptr_current_source_name_info^.
                  destination_group_qualifier;
          IFEND;
          clp$put_display (display_control, display_line, clc$trim, ignore_status);
        IFEND;

{ Process next entry in the linked list for this directive.

        ptr_current_source_name_info := #PTR (ptr_current_source_name_info^.link.relative_ptr,
              store_forward_file_info.segment_pointer.sequence_pointer^);
      WHILEND;

      IF NOT first_entry_found THEN

{ Tell the user no information was found for the requested information for this directive.

        display_no_entry_found (nfc$cmd_def_source_name_switch, name_value, application_value,
              display_control);
      IFEND;
    PROCEND display_source_name_switch;
?? OLDTITLE ??
?? NEWTITLE := 'write_display_header', EJECT ??

    PROCEDURE write_display_header
      (VAR display_control: clt$display_control;
           page_number: integer;
       VAR status: ost$status);

      CONST
        date_length = 18,
        display_header_length = 132,
        long_date_start = 75,
        long_os_version_start = 21,
        long_page_number_start = 126, {includes leading blank}
        long_page_title_start = 122,
        long_product_level_start = 54,
        long_product_name_start = 28,
        long_time_start = 94,
        nfc$manage_store_forward_level = '88092',
        os_version_length = 6,
        page_number_length = 5, {includes leading blank}
        page_title = 'PAGE',
        product_name = 'ADM STORE_FORWARD_NETWORK',
        product_name_length = 25,
        product_level_length = 5,
        short_date_start = 40,
        short_os_version_start = 1,
        short_page_number_start = 76, {includes leading blank}
        short_page_title_start = 72,
        short_product_level_start = 34,
        short_product_name_start = 8,
        short_time_start = 59,
        time_length = 12;

      VAR
        date: ost$date,
        display_header: string (display_header_length),
        os_version: pmt$os_name,
        page_length: integer,
        page_string: string (10),
        start_of_date: 0 .. display_header_length,
        start_of_time: 0 .. display_header_length,
        time: ost$time;

      status.normal := TRUE;
      display_header := ' ';
      STRINGREP (page_string, page_length, page_number);

      pmp$get_os_version (os_version, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (display_control.page_width < display_header_length) THEN
        start_of_date := short_date_start;
        start_of_time := short_time_start;
        display_header (short_os_version_start, os_version_length) := os_version;
        display_header (short_product_name_start, product_name_length) := product_name;
        display_header (short_product_level_start, product_level_length) := nfc$manage_store_forward_level;
        display_header (short_page_title_start, * ) := page_title;
        display_header (short_page_number_start, page_length) := page_string (1, page_length);
      ELSE
        start_of_date := long_date_start;
        start_of_time := long_time_start;
        display_header (long_os_version_start, os_version_length) := os_version;
        display_header (long_product_name_start, product_name_length) := product_name;
        display_header (long_product_level_start, product_level_length) := nfc$manage_store_forward_level;
        display_header (long_page_title_start, * ) := page_title;
        display_header (long_page_number_start, page_length) := page_string (1, page_length);
      IFEND;

      pmp$get_legible_date_time (osc$default_date, date, osc$default_time, time, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE date.date_format OF
      = osc$month_date =
        display_header (start_of_date, date_length) := date.month;
      = osc$mdy_date =
        display_header (start_of_date, date_length) := date.mdy;
      = osc$iso_date =
        display_header (start_of_date, date_length) := date.iso;
      = osc$dmy_date =
        display_header (start_of_date, date_length) := date.dmy;
      ELSE
        ;
      CASEND;

      CASE time.time_format OF
      = osc$ampm_time =
        display_header (start_of_time, time_length) := time.ampm;
      = osc$hms_time =
        display_header (start_of_time, time_length) := time.hms;
      = osc$millisecond_time =
        display_header (start_of_time, time_length) := time.millisecond;
      ELSE
        ;
      CASEND;

      clp$reset_for_next_display_page (display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_display (display_control, display_header, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, line_skip_for_next_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    PROCEND write_display_header;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ get the name or string value for the information to be displayed

    IF pvt [p$name].specified THEN
      name_value.value_specified := TRUE;
      CASE pvt [p$name].value^ .kind OF
      = clc$name =
        name_value.value := pvt [p$name].value^ .name_value;
      = clc$string =
        #TRANSLATE (osv$lower_to_upper, pvt [p$name].value^ .string_value^, name_value.value);
      ELSE
        osp$set_status_abnormal ('CL', cle$wrong_kind_of_value, 'name or string', status);
        RETURN;
      CASEND;
    ELSE
      name_value.value_specified := FALSE;
    IFEND;

{ get the application qualifier for the information to be displayed

    IF pvt [p$application_qualifier].specified THEN
      application_value.value_specified := TRUE;
      application_value.value := pvt [p$application_qualifier] .value^ .name_value;
    ELSE
      application_value.value_specified := FALSE;
    IFEND;

    display_option_set := $nft$sf_display_options_set [];
    ptr_display_options := pvt [p$display_option] .value;

    WHILE ptr_display_options <> NIL DO

{ determine what information options will be displayed

      IF (ptr_display_options^ .element_value^ .name_value = 'APPLICATION_NAME_SWITCH') OR
            (ptr_display_options^ .name_value = 'ANS') THEN
        display_option_set := display_option_set + $nft$sf_display_options_set [nfc$sf_display_applications];
      ELSEIF (ptr_display_options^ .element_value^ .name_value = 'DESTINATION_GROUP') OR
            (ptr_display_options^ .element_value^ .name_value = 'DESTINATION_GROUPS') OR
            (ptr_display_options^ .element_value^ .name_value = 'DG') THEN
        display_option_set := display_option_set + $nft$sf_display_options_set [nfc$sf_display_group_names];
      ELSEIF (ptr_display_options^ .element_value^ .name_value = 'DESTINATION_NAME_SWITCH') OR
            (ptr_display_options^ .element_value^ .name_value = 'DNS') THEN
        display_option_set := display_option_set + $nft$sf_display_options_set [nfc$sf_display_target_names];
      ELSEIF (ptr_display_options^ .element_value^ .name_value = 'SOURCE_NAME_SWITCH') OR
            (ptr_display_options^ .element_value^ .name_value = 'SNS') THEN
        display_option_set := display_option_set + $nft$sf_display_options_set [nfc$sf_display_source_names];
      ELSEIF (ptr_display_options^ .element_value^ .name_value = 'ALL') THEN
        display_option_set := display_option_set + $nft$sf_display_options_set
              [nfc$sf_display_applications, nfc$sf_display_group_names, nfc$sf_display_source_names,
              nfc$sf_display_target_names];
      IFEND;
      ptr_display_options := ptr_display_options^ .link;
    WHILEND;

{ attach and open the latest version of the store_forward_network file

    nfp$open_store_forward_file (TRUE, store_forward_file_info, status);
    IF status.normal AND store_forward_file_info.file_open THEN

{ open the display file as specified by the output parameter

      default_ring_attributes.r1 := #RING (^default_ring_attributes);
      default_ring_attributes.r2 := #RING (^default_ring_attributes);
      default_ring_attributes.r3 := #RING (^default_ring_attributes);

      clp$open_display_reference (pvt [p$output] .value^ .file_value^, ^write_display_header, fsc$list,
            default_ring_attributes, display_control, status);
      IF status.normal THEN

{ display the various information requested

        IF (nfc$sf_display_group_names IN display_option_set) THEN
          display_group_names (store_forward_file_info, name_value, application_value, display_control,
                status);
        IFEND;

        IF (nfc$sf_display_applications IN display_option_set) THEN
          display_application_name_switch (store_forward_file_info, name_value, application_value,
                display_control, status);
        IFEND;

        IF (nfc$sf_display_source_names IN display_option_set) THEN
          display_source_name_switch (store_forward_file_info, name_value, application_value, display_control,
                status);
        IFEND;

        IF (nfc$sf_display_target_names IN display_option_set) THEN
          display_destination_name_switch (store_forward_file_info, name_value, application_value,
                display_control, status);
        IFEND;
      IFEND;

{ close the display file

      clp$close_display (display_control, status);

{ close the store_forward_network file

      nfp$close_store_forward_file (store_forward_file_info, status);
    IFEND;
  PROCEND cmd_display_sf_network;
?? OLDTITLE ??
?? NEWTITLE := 'cmd_generate_sf_network', EJECT ??

{ PURPOSE:
{   This is the Utility's command GENERATE_STORE_FORWARD_NETWORK.  It will
{   create the STORE/FORWARD Network directives from the active SYSTEM'S
{   STORE/FORWARD Network file.

  PROCEDURE cmd_generate_sf_network
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*copyc nft$pdt_generate_sf_network

    CONST
      append_continuation_line_string = '..',
      append_string_delimiter = '''',
      application_name_w_space_length = 5,
      max_command_parameter_length = 79;

    VAR
      local_status: ost$status,
      store_forward_file_info: nft$store_forward_file_info;

?? NEWTITLE := 'create_application_directives', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to create the MANAGE_STORE_FORWARD_NETWORK
{   application name directives that are currently defined in the System's
{   Store/Forward Network file.

    PROCEDURE create_application_directives
      (    store_forward_file_info: nft$store_forward_file_info;
       VAR status: ost$status);

      CONST
        max_parameter_length_appl_qual = 15,
        max_parameter_length_dest_qual = 36,
        max_parameter_length_x_hop_appl = 36,
        parameter_application_qualifier = ' AQ=(',
        parameter_length_appl_qualifier = 5,
        parameter_destination_qualifier = ' DGQ=',
        parameter_length_dest_qualifier = 5,
        parameter_next_hop_application = 'NHA=',
        parameter_length_next_hop_appl = 4;

      VAR
        application_qualifier_index: nft$sf_applications,
        application_qualifier_length: integer,
        application_qualifier_parameter: string (max_parameter_length_appl_qual),
        destination_qualifier_length: integer,
        destination_qualifier_parameter: string (max_parameter_length_dest_qual),
        next_hop_appl_length: integer,
        next_hop_appl_parameter: string (max_parameter_length_x_hop_appl),
        parameter_list: string (max_command_parameter_length + 1),
        ptr_current_application_info: ^nft$sf_application_name_info;

      status.normal := TRUE;
      ptr_current_application_info := #PTR (store_forward_file_info.pointers.ptr_application_name_list,
            store_forward_file_info.segment_pointer.sequence_pointer^);

      WHILE ptr_current_application_info <> NIL DO
        IF NOT ptr_current_application_info^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_rptr,
                'CREATE_APPLICATION_DIRECTIVES', status);
          RETURN;
        IFEND;

{ Create the next_hop_application parameter

        next_hop_appl_parameter := parameter_next_hop_application;
        next_hop_appl_parameter ((parameter_length_next_hop_appl + 1), * ) :=
              ptr_current_application_info^.next_hop_application;
        next_hop_appl_length := clp$trimmed_string_size (next_hop_appl_parameter);

{ Create the destination_group_qualifier parameter

        IF ptr_current_application_info^.destination_group_qualifier <> osc$null_name THEN
          destination_qualifier_parameter := parameter_destination_qualifier;
          destination_qualifier_parameter ((parameter_length_dest_qualifier + 1), * ) :=
                ptr_current_application_info^.destination_group_qualifier;
        ELSE
          destination_qualifier_parameter := ' ';
        IFEND;
        destination_qualifier_length := clp$trimmed_string_size (destination_qualifier_parameter);

{ Create the application_qualifier parameter

        application_qualifier_parameter := parameter_application_qualifier;
        application_qualifier_length := parameter_length_appl_qualifier;
        FOR application_qualifier_index := LOWERBOUND (nfv$sf_application_names)
              TO UPPERBOUND (nfv$sf_application_names) DO
          IF application_qualifier_index IN ptr_current_application_info^.application_qualifier THEN
            application_qualifier_parameter ((application_qualifier_length + 1), * ) :=
                  nfv$sf_application_names [application_qualifier_index];
            application_qualifier_length := application_qualifier_length + application_name_w_space_length;
          IFEND;
        FOREND;
        application_qualifier_parameter (application_qualifier_length, * ) := ')';
        application_qualifier_length := clp$trimmed_string_size (application_qualifier_parameter);

{ When writting the directive to the output file, break the directive on a parameter boundry.  The maximum
{ output line is 80 characters.  The command name is written along with the parameters on the first call to
{ write this directive to the output file.

        parameter_list := next_hop_appl_parameter;
        IF (nfc$cmd_def_appl_name_length + next_hop_appl_length + application_qualifier_length +
              destination_qualifier_length) < max_command_parameter_length THEN
          parameter_list ((next_hop_appl_length + 1), * ) := application_qualifier_parameter;
          parameter_list ((next_hop_appl_length + application_qualifier_length + 1), * ) :=
                destination_qualifier_parameter;
          write_command_to_output (nfc$cmd_def_appl_name_switch, parameter_list, status);
        ELSEIF (nfc$cmd_def_appl_name_length + next_hop_appl_length + application_qualifier_length) <
              max_command_parameter_length THEN
          parameter_list ((next_hop_appl_length + 1), * ) := application_qualifier_parameter;
          parameter_list ((next_hop_appl_length + application_qualifier_length + 1), * ) :=
                append_continuation_line_string;
          write_command_to_output (nfc$cmd_def_appl_name_switch, parameter_list, status);
          IF status.normal THEN
            write_command_to_output ('', destination_qualifier_parameter, status);
          IFEND;
        ELSE
          parameter_list ((next_hop_appl_length + 1), * ) := append_continuation_line_string;
          write_command_to_output (nfc$cmd_def_appl_name_switch, parameter_list, status);
          IF status.normal THEN
            parameter_list := application_qualifier_parameter;
            parameter_list ((application_qualifier_length + 1), * ) := destination_qualifier_parameter;
            write_command_to_output ('', parameter_list, status);
          IFEND;
        IFEND;
        ptr_current_application_info := #PTR (ptr_current_application_info^.link.relative_ptr,
              store_forward_file_info.segment_pointer.sequence_pointer^);
      WHILEND;
    PROCEND create_application_directives;
?? OLDTITLE ??
?? NEWTITLE := 'create_dest_name_directives', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to create the MANAGE_STORE_FORWARD_NETWORK
{   destination name directives that are currently defined in the System's
{   Store/Forward Network file.

    PROCEDURE create_dest_name_directives
      (    store_forward_file_info: nft$store_forward_file_info;
       VAR status: ost$status);

      CONST
        max_parameter_length_appl_qual = 25,
        max_parameter_length_name = 36,
        max_parameter_length_x_hop_name = 38,
        parameter_application_qualifier = ' AQ=(',
        parameter_length_appl_qualifier = 5,
        parameter_name = 'N=',
        parameter_length_name = 2,
        parameter_next_hop_name = ' NHN=',
        parameter_length_next_hop_name = 5;

      VAR
        application_qualifier_index: nft$sf_applications,
        application_qualifier_length: integer,
        application_qualifier_parameter: string (max_parameter_length_appl_qual),
        name_length: integer,
        name_parameter: string (max_parameter_length_name),
        next_hop_name_length: integer,
        next_hop_name_parameter: string (max_parameter_length_x_hop_name),
        parameter_list: string (max_command_parameter_length + 1),
        ptr_current_target_name_info: ^nft$sf_target_name_information;

      status.normal := TRUE;
      ptr_current_target_name_info := #PTR (store_forward_file_info.pointers.ptr_target_name_list,
            store_forward_file_info.segment_pointer.sequence_pointer^);

      WHILE ptr_current_target_name_info <> NIL DO
        IF NOT ptr_current_target_name_info^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_rptr,
                'CREATE_DEST_NAME_DIRECTIVES', status);
          RETURN;
        IFEND;

{ Create the name parameter

        name_parameter := parameter_name;
        name_length := parameter_length_name;

{ If the value for this parameter begins with an integer, make this parameter a string value by placing quotes
{ before and after the value.

        IF first_character_is_integer (ptr_current_target_name_info^.target_name.value) THEN
          name_length := name_length + 1;
          name_parameter (name_length, 1) := append_string_delimiter;
        IFEND;
        name_parameter ((name_length + 1), * ) := ptr_current_target_name_info^.target_name.value;
        name_length := clp$trimmed_string_size (name_parameter);
        IF first_character_is_integer (ptr_current_target_name_info^.target_name.value) THEN
          name_length := name_length + 1;
          name_parameter (name_length, 1) := append_string_delimiter;
        IFEND;

{ Create the next_hop_name parameter

        next_hop_name_parameter := parameter_next_hop_name;
        next_hop_name_length := parameter_length_next_hop_name;

{ If the value for this parameter begins with an integer, make this parameter a string value by placing quotes
{ before and after the value.

        IF first_character_is_integer (ptr_current_target_name_info^.next_hop_name.value) THEN
          next_hop_name_length := next_hop_name_length + 1;
          next_hop_name_parameter (next_hop_name_length, 1) := append_string_delimiter;
        IFEND;
        next_hop_name_parameter ((next_hop_name_length + 1), * ) :=
              ptr_current_target_name_info^.next_hop_name.value;
        next_hop_name_length := clp$trimmed_string_size (next_hop_name_parameter);
        IF first_character_is_integer (ptr_current_target_name_info^.next_hop_name.value) THEN
          next_hop_name_length := next_hop_name_length + 1;
          next_hop_name_parameter (next_hop_name_length, 1) := append_string_delimiter;
        IFEND;

{ Create the application_qualifier parameter

        application_qualifier_parameter := parameter_application_qualifier;
        application_qualifier_length := parameter_length_appl_qualifier;
        FOR application_qualifier_index := LOWERBOUND (nfv$sf_application_names)
              TO UPPERBOUND (nfv$sf_application_names) DO
          IF application_qualifier_index IN ptr_current_target_name_info^.application_qualifier THEN
            application_qualifier_parameter ((application_qualifier_length + 1), * ) :=
                  nfv$sf_application_names [application_qualifier_index];
            application_qualifier_length := application_qualifier_length + application_name_w_space_length;
          IFEND;
        FOREND;
        application_qualifier_parameter ((application_qualifier_length), * ) := ')';
        application_qualifier_length := clp$trimmed_string_size (application_qualifier_parameter);

{ When writting the directive to the output file, break the directive on a parameter boundry.  The maximum
{ output line is 80 characters.  The command name is written along with the parameters on the first call to
{ write this directive to the output file.

        parameter_list := name_parameter;
        IF (nfc$cmd_def_target_name_length + name_length + next_hop_name_length +
              application_qualifier_length) < max_command_parameter_length THEN
          parameter_list ((name_length + 1), * ) := next_hop_name_parameter;
          parameter_list ((name_length + next_hop_name_length + 1), * ) := application_qualifier_parameter;
          write_command_to_output (nfc$cmd_def_target_name_switch, parameter_list, status);
        ELSEIF (nfc$cmd_def_target_name_length + name_length + next_hop_name_length) <
              max_command_parameter_length THEN
          parameter_list ((name_length + 1), * ) := next_hop_name_parameter;
          parameter_list ((name_length + next_hop_name_length + 1), * ) := append_continuation_line_string;
          write_command_to_output (nfc$cmd_def_target_name_switch, parameter_list, status);
          IF status.normal THEN
            write_command_to_output ('', application_qualifier_parameter, status);
          IFEND;
        ELSE
          parameter_list ((name_length + 1), * ) := append_continuation_line_string;
          write_command_to_output (nfc$cmd_def_target_name_switch, parameter_list, status);
          IF status.normal THEN
            parameter_list := next_hop_name_parameter;
            parameter_list ((next_hop_name_length + 1), * ) := application_qualifier_parameter;
            write_command_to_output ('', parameter_list, status);
          IFEND;
        IFEND;
        ptr_current_target_name_info := #PTR (ptr_current_target_name_info^.link.relative_ptr,
              store_forward_file_info.segment_pointer.sequence_pointer^);
      WHILEND;
    PROCEND create_dest_name_directives;
?? OLDTITLE ??
?? NEWTITLE := 'create_group_name_directives', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to create the MANAGE_STORE_FORWARD_NETWORK
{   group name directives that are currently defined in the System's
{   Store/Forward Network file.

    PROCEDURE create_group_name_directives
      (    store_forward_file_info: nft$store_forward_file_info;
       VAR status: ost$status);

      CONST
        parameter_destination_names = ' DN=(',
        parameter_group_name = 'GN=',
        parameter_length_group_name = 3;

      VAR
        command_name_parameter: string (nfc$cmd_def_dest_group_length),
        command_name_length: integer,
        command_parameter_length: integer,
        destination_name_index: ost$non_negative_integers,
        destination_name_length: integer,
        parameter_length: integer,
        parameter_list: string (max_command_parameter_length + 1),
        ptr_current_dest_names_info: ^nft$sf_destination_names_array,
        ptr_current_group_name_info: ^nft$sf_group_name_information;

      status.normal := TRUE;
      ptr_current_group_name_info := #PTR (store_forward_file_info.pointers.ptr_group_name_list,
            store_forward_file_info.segment_pointer.sequence_pointer^);

      WHILE ptr_current_group_name_info <> NIL DO
        IF NOT ptr_current_group_name_info^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_rptr,
                'CREATE_GROUP_NAME_DIRECTIVES 1', status);
          RETURN;
        IFEND;
        IF NOT ptr_current_group_name_info^.ptr_destination_names.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_rptr,
                'CREATE_GROUP_NAME_DIRECTIVES 2', status);
          RETURN;
        IFEND;

        command_name_parameter := nfc$cmd_def_destination_group;
        command_name_length := nfc$cmd_def_dest_group_length;

{ create the group_name parameter

        parameter_list := parameter_group_name;
        parameter_list ((parameter_length_group_name + 1), * ) := ptr_current_group_name_info^.group_name;
        parameter_length := clp$trimmed_string_size (parameter_list);

{ create the destination_names parameter

        parameter_list ((parameter_length + 1), * ) := parameter_destination_names;
        parameter_length := clp$trimmed_string_size (parameter_list);
        command_parameter_length := command_name_length + parameter_length;

        ptr_current_dest_names_info := #PTR (ptr_current_group_name_info^.ptr_destination_names.relative_ptr,
              store_forward_file_info.segment_pointer.sequence_pointer^);
        FOR destination_name_index := 1 TO ptr_current_group_name_info^.destination_name_count DO

          destination_name_length := clp$trimmed_string_size
                (ptr_current_dest_names_info^ [destination_name_index].value);

{ When writting the directive to the output file, break the directive on a parameter boundry.  The maximum
{ output line is 80 characters.  The command name is written along with the parameters on the first call to
{ write this directive to the output file.

          IF (command_parameter_length + destination_name_length) >= max_command_parameter_length THEN
            parameter_list ((parameter_length + 1), * ) := append_continuation_line_string;
            write_command_to_output (command_name_parameter, parameter_list, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

{ Reset the command name to a blank string so that when the continuation lines are written the command name is
{ not the first part of each line.

            command_name_parameter := ' ';
            command_name_length := 0;
            parameter_list := ' ';
            parameter_length := 1;
          IFEND;

{ If the value for this parameter begins with an integer, make this parameter a string value by placing quotes
{ before and after the value.

          IF first_character_is_integer (ptr_current_dest_names_info^ [destination_name_index].value) THEN
            parameter_length := parameter_length + 1;
            parameter_list (parameter_length, 1) := append_string_delimiter;
          IFEND;
          parameter_list ((parameter_length + 1), * ) := ptr_current_dest_names_info^
                [destination_name_index].value;
          parameter_length := clp$trimmed_string_size (parameter_list);
          IF first_character_is_integer (ptr_current_dest_names_info^ [destination_name_index].value) THEN
            parameter_length := parameter_length + 1;
            parameter_list (parameter_length, 1) := append_string_delimiter;
          IFEND;
          parameter_length := parameter_length + 1;
          command_parameter_length := command_name_length + parameter_length;
        FOREND;
        parameter_list ((parameter_length), * ) := ')';
        write_command_to_output (command_name_parameter, parameter_list, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        ptr_current_group_name_info := #PTR (ptr_current_group_name_info^.link.relative_ptr,
              store_forward_file_info.segment_pointer.sequence_pointer^);
      WHILEND;
    PROCEND create_group_name_directives;
?? OLDTITLE ??
?? NEWTITLE := 'create_source_name_directives', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to create the MANAGE_STORE_FORWARD_NETWORK
{   source name directives that are currently defined in the System's
{   Store/Forward Network file.

    PROCEDURE create_source_name_directives
      (    store_forward_file_info: nft$store_forward_file_info;
       VAR status: ost$status);

      CONST
        max_parameter_length_appl_qual = 25,
        max_parameter_length_dest_qual = 36,
        max_parameter_length_name = 36,
        max_parameter_length_x_hop_name = 38,
        parameter_application_qualifier = ' AQ=(',
        parameter_length_appl_qualifier = 5,
        parameter_destination_qualifier = ' DGQ=',
        parameter_length_dest_qualifier = 5,
        parameter_name = 'N=',
        parameter_length_name = 2,
        parameter_next_hop_name = ' NHN=',
        parameter_length_next_hop_name = 5;

      VAR
        application_qualifier_index: nft$sf_applications,
        application_qualifier_length: integer,
        application_qualifier_parameter: string (max_parameter_length_appl_qual),
        destination_qualifier_length: integer,
        destination_qualifier_parameter: string (max_parameter_length_dest_qual),
        name_length: integer,
        name_parameter: string (max_parameter_length_name),
        next_hop_name_length: integer,
        next_hop_name_parameter: string (max_parameter_length_x_hop_name),
        parameter_list: string (max_command_parameter_length + 1),
        ptr_current_source_name_info: ^nft$sf_source_name_information;

      status.normal := TRUE;
      ptr_current_source_name_info := #PTR (store_forward_file_info.pointers.ptr_source_name_list,
            store_forward_file_info.segment_pointer.sequence_pointer^);

      WHILE ptr_current_source_name_info <> NIL DO
        IF NOT ptr_current_source_name_info^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_rptr,
                'CREATE_SOURCE_NAME_DIRECTIVES', status);
          RETURN;
        IFEND;

{ Create the name parameter

        name_parameter := parameter_name;
        name_length := parameter_length_name;

{ If the value for this parameter begins with an integer, make this parameter a string value by placing quotes
{ before and after the value.

        IF first_character_is_integer (ptr_current_source_name_info^.source_name.value) THEN
          name_length := name_length + 1;
          name_parameter (name_length, 1) := append_string_delimiter;
        IFEND;
        name_parameter ((name_length + 1), * ) := ptr_current_source_name_info^.source_name.value;
        name_length := clp$trimmed_string_size (name_parameter);
        IF first_character_is_integer (ptr_current_source_name_info^.source_name.value) THEN
          name_length := name_length + 1;
          name_parameter (name_length, 1) := append_string_delimiter;
        IFEND;

{ Create the next_hop_name parameter

        next_hop_name_parameter := parameter_next_hop_name;
        next_hop_name_length := parameter_length_next_hop_name;

{ If the value for this parameter begins with an integer, make this parameter a string value by placing quotes
{ before and after the value.

        IF first_character_is_integer (ptr_current_source_name_info^.next_hop_name.value) THEN
          next_hop_name_length := next_hop_name_length + 1;
          next_hop_name_parameter (next_hop_name_length, 1) := append_string_delimiter;
        IFEND;
        next_hop_name_parameter ((next_hop_name_length + 1), * ) :=
              ptr_current_source_name_info^.next_hop_name.value;
        next_hop_name_length := clp$trimmed_string_size (next_hop_name_parameter);
        IF first_character_is_integer (ptr_current_source_name_info^.next_hop_name.value) THEN
          next_hop_name_length := next_hop_name_length + 1;
          next_hop_name_parameter (next_hop_name_length, 1) := append_string_delimiter;
        IFEND;

{ Create the destination_group_qualifier parameter

        IF ptr_current_source_name_info^.destination_group_qualifier <> osc$null_name THEN
          destination_qualifier_parameter := parameter_destination_qualifier;
          destination_qualifier_parameter ((parameter_length_dest_qualifier + 1), * ) :=
                ptr_current_source_name_info^.destination_group_qualifier;
        ELSE
          destination_qualifier_parameter := ' ';
        IFEND;
        destination_qualifier_length := clp$trimmed_string_size (destination_qualifier_parameter);

{ Create the application_qualifier parameter

        application_qualifier_parameter := parameter_application_qualifier;
        application_qualifier_length := parameter_length_appl_qualifier;
        FOR application_qualifier_index := LOWERBOUND (nfv$sf_application_names)
              TO UPPERBOUND (nfv$sf_application_names) DO
          IF application_qualifier_index IN ptr_current_source_name_info^.application_qualifier THEN
            application_qualifier_parameter ((application_qualifier_length + 1), * ) :=
                  nfv$sf_application_names [application_qualifier_index];
            application_qualifier_length := application_qualifier_length + application_name_w_space_length;
          IFEND;
        FOREND;
        application_qualifier_parameter ((application_qualifier_length), * ) := ')';
        application_qualifier_length := clp$trimmed_string_size (application_qualifier_parameter);

{ When writting the directive to the output file, break the directive on a parameter boundry.  The maximum
{ output line is 80 characters.  The command name is written along with the parameters on the first call to
{ write this directive to the output file.

        parameter_list := name_parameter;
        IF (nfc$cmd_def_source_name_length + name_length + next_hop_name_length +
              application_qualifier_length + destination_qualifier_length) < max_command_parameter_length THEN
          parameter_list ((name_length + 1), * ) := next_hop_name_parameter;
          parameter_list ((name_length + next_hop_name_length + 1), * ) := application_qualifier_parameter;
          parameter_list ((name_length + next_hop_name_length + application_qualifier_length + 1), * ) :=
                destination_qualifier_parameter;
          write_command_to_output (nfc$cmd_def_source_name_switch, parameter_list, status);
        ELSEIF (nfc$cmd_def_source_name_length + name_length + next_hop_name_length +
              application_qualifier_length) < max_command_parameter_length THEN
          parameter_list ((name_length + 1), * ) := next_hop_name_parameter;
          parameter_list ((name_length + next_hop_name_length + 1), * ) := application_qualifier_parameter;
          parameter_list ((name_length + next_hop_name_length + application_qualifier_length + 1), * ) :=
                append_continuation_line_string;
          write_command_to_output (nfc$cmd_def_source_name_switch, parameter_list, status);
          IF status.normal THEN
            parameter_list := destination_qualifier_parameter;
            write_command_to_output ('', parameter_list, status);
          IFEND;
        ELSEIF (nfc$cmd_def_source_name_length + name_length + next_hop_name_length) <
              max_command_parameter_length THEN
          parameter_list ((name_length + 1), * ) := next_hop_name_parameter;
          parameter_list ((name_length + next_hop_name_length + 1), * ) := append_continuation_line_string;
          write_command_to_output (nfc$cmd_def_source_name_switch, parameter_list, status);
          IF status.normal THEN
            parameter_list := application_qualifier_parameter;
            parameter_list ((application_qualifier_length + 1), * ) := destination_qualifier_parameter;
            write_command_to_output ('', parameter_list, status);
          IFEND;
        ELSE
          parameter_list ((name_length + 1), * ) := append_continuation_line_string;
          write_command_to_output (nfc$cmd_def_source_name_switch, parameter_list, status);
          IF status.normal THEN
            parameter_list := next_hop_name_parameter;
            parameter_list ((next_hop_name_length + 1), * ) := application_qualifier_parameter;
            IF (1 + next_hop_name_length + application_qualifier_length + destination_qualifier_length) <
                  max_command_parameter_length THEN
              parameter_list ((next_hop_name_length + application_qualifier_length + 1), * ) :=
                    destination_qualifier_parameter;
              write_command_to_output ('', parameter_list, status);
            ELSE
              parameter_list ((next_hop_name_length + application_qualifier_length + 1), * ) :=
                    append_continuation_line_string;
              write_command_to_output ('', parameter_list, status);
              IF status.normal THEN
                write_command_to_output ('', destination_qualifier_parameter, status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
        ptr_current_source_name_info := #PTR (ptr_current_source_name_info^.link.relative_ptr,
              store_forward_file_info.segment_pointer.sequence_pointer^);
      WHILEND;
    PROCEND create_source_name_directives;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ attach and open the latest version of the store_forward_network file

    nfp$open_store_forward_file (TRUE, store_forward_file_info, status);
    IF status.normal AND store_forward_file_info.file_open THEN

{ open the output file as specified by the output parameter the directives will be written to this file.

      fsp$open_file (pvt [p$output] .value^ .file_value^, amc$record, NIL, NIL, NIL, NIL, NIL,
            output_file_identifier, status);
      output_file_open := status.normal;
      IF status.normal THEN

      /create_sfn_directives_block/
        BEGIN

{ create the store forward directives from the currently installed System's Store/Forward Network file.

          create_group_name_directives (store_forward_file_info, status);
          IF NOT status.normal THEN
            EXIT /create_sfn_directives_block/;
          IFEND;

          create_application_directives (store_forward_file_info, status);
          IF NOT status.normal THEN
            EXIT /create_sfn_directives_block/;
          IFEND;

          create_source_name_directives (store_forward_file_info, status);
          IF NOT status.normal THEN
            EXIT /create_sfn_directives_block/;
          IFEND;

          create_dest_name_directives (store_forward_file_info, status);
          IF NOT status.normal THEN
            EXIT /create_sfn_directives_block/;
          IFEND;

          write_command_to_output (nfc$cmd_quit, '', status);
        END /create_sfn_directives_block/;
      IFEND;

{ close the store_forward_network file

      nfp$close_store_forward_file (store_forward_file_info, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;

{ close the output file (generated directive file)

      fsp$close_file (output_file_identifier, local_status);
      output_file_open := NOT local_status.normal;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;
  PROCEND cmd_generate_sf_network;
?? OLDTITLE ??
?? NEWTITLE := 'cmd_install_sf_network', EJECT ??

{ PURPOSE:
{   This is the Utility's command INSTALL_STORE_FORWARD_NETWORK.  It will
{   verify and install (create or replace) the SYSTEM'S STORE/FORWARD
{   Network file.

  PROCEDURE cmd_install_sf_network
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*copyc nft$pdt_install_sf_network

    CONST
      max_retry_count = 5;

    VAR
      local_status: ost$status,
      ptr_file_attachment_options: ^fst$attachment_options,
      temporary_store_forward_file: amt$local_file_name;

?? NEWTITLE := 'install_sfn_directives', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to install the MANAGE_STORE_FORWARD_NETWORK
{   directives into the System's Store/Forward Network file.

    PROCEDURE install_sfn_directives
      (    temporary_store_forward_file: amt$local_file_name;
       VAR status: ost$status);

      VAR
        copy_error: boolean,
        error_retry_count: 0 .. max_retry_count,
        local_status: ost$status,
        permanent_store_forward_file: amt$local_file_name,
        pf_access_mode: pft$usage_selections,
        pf_cycle_selection: pft$cycle_selector,
        pf_logging: pft$log,
        pf_password: pft$password,
        pf_retention: pft$retention,
        pf_share_mode: pft$share_selections,
        pf_store_forward_file_path: ^pft$path;

      error_retry_count := 0;
      status.normal := TRUE;
      PUSH pf_store_forward_file_path: [1 .. 4];

{ set up the permanent file path for the System's Store/Forward Network file and have exclusive access so that
{ there is no contention when we write the file

      pf_store_forward_file_path^ [1] := nfc$sf_family_name;
      pf_store_forward_file_path^ [2] := nfc$sf_user_name;
      pf_store_forward_file_path^ [3] := nfc$sf_subcatalog_name;
      pf_store_forward_file_path^ [4] := nfc$sf_permanent_file_name;
      pf_access_mode := $pft$usage_selections [pfc$read, pfc$append, pfc$modify, pfc$shorten];
      pf_share_mode := $pft$usage_selections [];
      pf_logging := pfc$no_log;
      pf_password := osc$null_name;
      pf_retention := pfc$maximum_retention;

      REPEAT
        copy_error := FALSE;
        pmp$get_unique_name (permanent_store_forward_file, status);
        pf_cycle_selection.cycle_option := pfc$highest_cycle;

{ attach the highest cycle of the System's Store/Forward Network file

        pfp$attach (permanent_store_forward_file, pf_store_forward_file_path^, pf_cycle_selection,
              pf_password, pf_access_mode, pf_share_mode, pfc$no_wait, status);
        IF NOT status.normal THEN
          IF (status.condition = pfe$unknown_permanent_file) OR (status.condition = pfe$cycle_busy) THEN

{ if the file is unknown or is busy (attached by some other application) create the next cycle for us to write
{ the Store/Forward information

            pf_cycle_selection.cycle_option := pfc$highest_cycle;
            pfp$define (permanent_store_forward_file, pf_store_forward_file_path^, pf_cycle_selection,
                  pf_password, pf_retention, pf_logging, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSE
            RETURN;
          IFEND;
        IFEND;

{ copy the directive information into the permanent file System's Store/Forward Network file

        fsp$copy_file (temporary_store_forward_file, permanent_store_forward_file, NIL, NIL, NIL, status);
        amp$return (permanent_store_forward_file, local_status);
        IF status.normal THEN
          IF NOT local_status.normal THEN
            status := local_status;
          IFEND;
        ELSE

{ if an error occurs when we wrote to the permanent file, we will delete the cycle of the permanent file that
{ we just wrote and then we will try again to write a valid Store/Forward Network file

          copy_error := TRUE;
          error_retry_count := error_retry_count + 1;
          pf_cycle_selection.cycle_option := pfc$highest_cycle;
          pfp$purge (pf_store_forward_file_path^, pf_cycle_selection, pf_password, status);
        IFEND;
      UNTIL (NOT copy_error) OR (error_retry_count >= max_retry_count);
    PROCEND install_sfn_directives;
?? OLDTITLE ??
?? NEWTITLE := 'write_sfn_directives', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to write the MANAGE_STORE_FORWARD_NETWORK
{   directives into a file that will be copied to the System's Store/Forward
{   Network file.
{
{ NOTE:
{   The format of the Store_Forward_Network file is as follows:
{     The first series of bytes consist of relative pointers to the first
{     entry of the various linked lists for application_name_switch,
{     destination_name_switch, destination_group names, and source_name_switch.
{     This set of relative pointers are in the order as specified in the type
{     nft$store_forward_file_pointers.  The rest of the file consists of all
{     the entries for the Store/Forward directives in the following order:
{       1. application_name_switch, 2. source_name_switch,
{       3. destination_name_switch, and 4. destination_group names.
{     The destination_group names are unique because the information defining
{     a particular group_name is placed in the file first and it is followed
{     immediately by its list of destination names.
{   All of the entries for a particular directive are linked together.  To find
{   the next entry, the LINK field should be used.

    PROCEDURE write_sfn_directives
      (VAR temporary_store_forward_file: amt$local_file_name;
       VAR status: ost$status);

      VAR
        error_retry_count: 0 .. max_retry_count,
        ignore_status: ost$status,
        segment_pointer: amt$segment_pointer,
        store_forward_file_pointers: ^nft$store_forward_file_pointers,
        temporary_file_identifier: amt$file_identifier,
        write_error: boolean;

?? NEWTITLE := 'write_application_directives', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to write the DEFINE_APPLICATION_NAME_SWITCH
{   directives into a file that will be copied to the System's Store/Forward
{   Network file.

      PROCEDURE write_application_directives
        (VAR segment_pointer: amt$segment_pointer;
         VAR ptr_first_application_directive: nft$sf_rel_ptr_appl_name_info;
         VAR write_error: boolean;
         VAR status: ost$status);

        VAR
          first_entry: boolean,
          ptr_current_appl_name_file: ^nft$sf_application_name_info,
          ptr_current_appl_name_list: ^nft$sf_application_name_info,
          ptr_previous_appl_name_file: ^nft$sf_application_name_info;

{ write the Store/Forward Network application directives to the temporary file

        status.normal := TRUE;
        write_error := FALSE;
        first_entry := TRUE;
        ptr_current_appl_name_list := ptr_application_name_list;
        ptr_previous_appl_name_file := NIL;
        WHILE ptr_current_appl_name_list <> NIL DO
          IF ptr_current_appl_name_list^.link.relative_pointer THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                  'WRITE_APPLICATION_DIRECTIVES', status);
            RETURN;
          IFEND;

{ Allocate space in the temporary file for the next application directive

          NEXT ptr_current_appl_name_file IN segment_pointer.sequence_pointer;
          IF ptr_current_appl_name_file <> NIL THEN

{ write the application directive information into the temporary file

            ptr_current_appl_name_file^.link.relative_pointer := TRUE;
            ptr_current_appl_name_file^.link.relative_ptr := NIL;
            ptr_current_appl_name_file^.next_hop_application :=
                  ptr_current_appl_name_list^.next_hop_application;
            ptr_current_appl_name_file^.application_qualifier :=
                  ptr_current_appl_name_list^.application_qualifier;
            ptr_current_appl_name_file^.destination_group_qualifier :=
                  ptr_current_appl_name_list^.destination_group_qualifier;
            IF ptr_previous_appl_name_file <> NIL THEN

{ connect (link it) the current application directive with the last application directive

              ptr_previous_appl_name_file^.link.relative_ptr :=
                    #REL (ptr_current_appl_name_file, segment_pointer.sequence_pointer^);
            IFEND;
            IF first_entry THEN

{ save the pointer to the first application directive

              ptr_first_application_directive := #REL (ptr_current_appl_name_file,
                    segment_pointer.sequence_pointer^);
              first_entry := FALSE;
            IFEND;
            ptr_previous_appl_name_file := ptr_current_appl_name_file;
          ELSE
            write_error := TRUE;
          IFEND;
          ptr_current_appl_name_list := ptr_current_appl_name_list^.link.ptr;
        WHILEND;
      PROCEND write_application_directives;
?? OLDTITLE ??
?? NEWTITLE := 'write_dest_name_directives', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to write the DEFINE_DESTINATION_NAME_SWITCH
{   directives into a file that will be copied to the System's Store/Forward
{   Network file.

      PROCEDURE write_dest_name_directives
        (VAR segment_pointer: amt$segment_pointer;
         VAR ptr_first_target_name_directive: nft$sf_rel_ptr_target_name_info;
         VAR write_error: boolean;
         VAR status: ost$status);

        VAR
          first_entry: boolean,
          ptr_current_target_name_file: ^nft$sf_target_name_information,
          ptr_current_target_name_list: ^nft$sf_target_name_information,
          ptr_previous_target_name_file: ^nft$sf_target_name_information;

{ write the Store/Forward Network destination name directives to the temporary file

        status.normal := TRUE;
        write_error := FALSE;
        first_entry := TRUE;
        ptr_current_target_name_list := ptr_target_name_list;
        ptr_previous_target_name_file := NIL;
        WHILE ptr_current_target_name_list <> NIL DO
          IF ptr_current_target_name_list^.link.relative_pointer THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                  'WRITE_DEST_NAME_DIRECTIVES', status);
            RETURN;
          IFEND;

{ Allocate space in the temporary file for the next destination name directive

          NEXT ptr_current_target_name_file IN segment_pointer.sequence_pointer;
          IF ptr_current_target_name_file <> NIL THEN

{ write the destination name directive information into the temporary file

            ptr_current_target_name_file^.link.relative_pointer := TRUE;
            ptr_current_target_name_file^.link.relative_ptr := NIL;
            ptr_current_target_name_file^.target_name := ptr_current_target_name_list^.target_name;
            ptr_current_target_name_file^.next_hop_name := ptr_current_target_name_list^.next_hop_name;
            ptr_current_target_name_file^.application_qualifier :=
                  ptr_current_target_name_list^.application_qualifier;
            IF ptr_previous_target_name_file <> NIL THEN

{ connect (link it) the current destination name directive with the last destination name directive

              ptr_previous_target_name_file^.link.relative_ptr :=
                    #REL (ptr_current_target_name_file, segment_pointer.sequence_pointer^);
            IFEND;
            IF first_entry THEN

{ save the pointer to the first destination name directive

              ptr_first_target_name_directive := #REL (ptr_current_target_name_file,
                    segment_pointer.sequence_pointer^);
              first_entry := FALSE;
            IFEND;
            ptr_previous_target_name_file := ptr_current_target_name_file;
          ELSE
            write_error := TRUE;
          IFEND;
          ptr_current_target_name_list := ptr_current_target_name_list^.link.ptr;
        WHILEND;
      PROCEND write_dest_name_directives;
?? OLDTITLE ??
?? NEWTITLE := 'write_group_name_directives', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to write the DEFINE_DESTINATION_GROUP
{   directives into a file that will be copied to the System's Store/Forward
{   Network file.

      PROCEDURE write_group_name_directives
        (VAR segment_pointer: amt$segment_pointer;
         VAR ptr_first_group_name_directive: nft$sf_rel_ptr_group_name_info;
         VAR write_error: boolean;
         VAR status: ost$status);

        VAR
          first_entry: boolean,
          ptr_current_group_name_file: ^nft$sf_group_name_information,
          ptr_current_group_name_list: ^nft$sf_group_name_information,
          ptr_destination_names: ^nft$sf_destination_names_array,
          ptr_previous_group_name_file: ^nft$sf_group_name_information;

{ write the Store/Forward Network destination group directives to the temporary file

        status.normal := TRUE;
        write_error := FALSE;
        first_entry := TRUE;
        ptr_current_group_name_list := ptr_group_name_list;
        ptr_previous_group_name_file := NIL;
        WHILE ptr_current_group_name_list <> NIL DO
          IF ptr_current_group_name_list^.link.relative_pointer THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                  'WRITE_GROUP_NAME_DIRECTIVES 1', status);
            RETURN;
          IFEND;
          IF ptr_current_group_name_list^.ptr_destination_names.relative_pointer THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                  'WRITE_GROUP_NAME_DIRECTIVES 2', status);
            RETURN;
          IFEND;

{ Allocate space in the temporary file for the next destination group directive

          NEXT ptr_current_group_name_file IN segment_pointer.sequence_pointer;
          IF ptr_current_group_name_file <> NIL THEN

{ Allocate space in the temporary file for the list of destination names

            NEXT ptr_destination_names: [1 .. ptr_current_group_name_list^.destination_name_count] IN
                  segment_pointer.sequence_pointer;
            IF ptr_destination_names <> NIL THEN

{ write the destination group directive information into the temporary file

              ptr_current_group_name_file^.link.relative_pointer := TRUE;
              ptr_current_group_name_file^.link.relative_ptr := NIL;
              ptr_current_group_name_file^.group_name := ptr_current_group_name_list^.group_name;
              ptr_current_group_name_file^.destination_name_count :=
                    ptr_current_group_name_list^.destination_name_count;
              ptr_destination_names^ := ptr_current_group_name_list^.ptr_destination_names.ptr^;
              ptr_current_group_name_file^.ptr_destination_names.relative_pointer := TRUE;
              ptr_current_group_name_file^.ptr_destination_names.relative_ptr :=
                    #REL (ptr_destination_names, segment_pointer.sequence_pointer^);
              IF ptr_previous_group_name_file <> NIL THEN

{ connect (link it) the current destination group directive with the last destination group directive

                ptr_previous_group_name_file^.link.relative_ptr :=
                      #REL (ptr_current_group_name_file, segment_pointer.sequence_pointer^);
              IFEND;
              IF first_entry THEN

{ save the pointer to the first destination group directive

                ptr_first_group_name_directive := #REL (ptr_current_group_name_file,
                      segment_pointer.sequence_pointer^);
                first_entry := FALSE;
              IFEND;
              ptr_previous_group_name_file := ptr_current_group_name_file;
            IFEND;
          ELSE
            write_error := TRUE;
          IFEND;
          ptr_current_group_name_list := ptr_current_group_name_list^.link.ptr;
        WHILEND;
      PROCEND write_group_name_directives;
?? OLDTITLE ??
?? NEWTITLE := 'write_source_name_directives', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to write the DEFINE_SOURCE_NAME_SWITCH
{   directives into a file that will be copied to the System's Store/Forward
{   Network file.

      PROCEDURE write_source_name_directives
        (VAR segment_pointer: amt$segment_pointer;
         VAR ptr_first_source_name_directive: nft$sf_rel_ptr_source_name_info;
         VAR write_error: boolean;
         VAR status: ost$status);

        VAR
          first_entry: boolean,
          ptr_current_source_name_file: ^nft$sf_source_name_information,
          ptr_current_source_name_list: ^nft$sf_source_name_information,
          ptr_previous_source_name_file: ^nft$sf_source_name_information;

{ write the Store/Forward Network source name directives to the temporary file

        status.normal := TRUE;
        write_error := FALSE;
        first_entry := TRUE;
        ptr_current_source_name_list := ptr_source_name_list;
        ptr_previous_source_name_file := NIL;
        WHILE ptr_current_source_name_list <> NIL DO
          IF ptr_current_source_name_list^.link.relative_pointer THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                  'WRITE_SOURCE_NAME_DIRECTIVES', status);
            RETURN;
          IFEND;

{ Allocate space in the temporary file for the next source name directive

          NEXT ptr_current_source_name_file IN segment_pointer.sequence_pointer;
          IF ptr_current_source_name_file <> NIL THEN

{ write the source name directive information into the temporary file

            ptr_current_source_name_file^.link.relative_pointer := TRUE;
            ptr_current_source_name_file^.link.relative_ptr := NIL;
            ptr_current_source_name_file^.source_name := ptr_current_source_name_list^.source_name;
            ptr_current_source_name_file^.next_hop_name := ptr_current_source_name_list^.next_hop_name;
            ptr_current_source_name_file^.application_qualifier :=
                  ptr_current_source_name_list^.application_qualifier;
            ptr_current_source_name_file^.destination_group_qualifier :=
                  ptr_current_source_name_list^.destination_group_qualifier;
            IF ptr_previous_source_name_file <> NIL THEN

{ connect (link it) the current source name directive with the last source name directive

              ptr_previous_source_name_file^.link.relative_ptr :=
                    #REL (ptr_current_source_name_file, segment_pointer.sequence_pointer^);
            IFEND;
            IF first_entry THEN

{ save the pointer to the first source name directive

              ptr_first_source_name_directive := #REL (ptr_current_source_name_file,
                    segment_pointer.sequence_pointer^);
              first_entry := FALSE;
            IFEND;
            ptr_previous_source_name_file := ptr_current_source_name_file;
          ELSE
            write_error := TRUE;
          IFEND;
          ptr_current_source_name_list := ptr_current_source_name_list^.link.ptr;
        WHILEND;
      PROCEND write_source_name_directives;
?? OLDTITLE, EJECT ??
      status.normal := TRUE;
      error_retry_count := 0;

      REPEAT

        write_error := FALSE;

{ create a temporary file that will contain the information from the Store/Forward directives supplied by the
{ user

        pmp$get_unique_name (temporary_store_forward_file, status);
        fsp$open_file (temporary_store_forward_file, amc$segment, NIL, NIL, NIL, NIL, NIL,
              temporary_file_identifier, status);

        amp$get_segment_pointer (temporary_file_identifier, amc$sequence_pointer, segment_pointer, status);
        RESET segment_pointer.sequence_pointer;
        NEXT store_forward_file_pointers IN segment_pointer.sequence_pointer;

{ initialize the pointers to the first entry for each list

        store_forward_file_pointers^.ptr_application_name_list := NIL;
        store_forward_file_pointers^.ptr_group_name_list := NIL;
        store_forward_file_pointers^.ptr_source_name_list := NIL;
        store_forward_file_pointers^.ptr_target_name_list := NIL;

        write_application_directives (segment_pointer, store_forward_file_pointers^.ptr_application_name_list,
              write_error, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF NOT write_error THEN
          write_source_name_directives (segment_pointer, store_forward_file_pointers^.ptr_source_name_list,
                write_error, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF NOT write_error THEN
            write_dest_name_directives (segment_pointer, store_forward_file_pointers^.ptr_target_name_list,
                  write_error, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF NOT write_error THEN
              write_group_name_directives (segment_pointer, store_forward_file_pointers^.ptr_group_name_list,
                    write_error, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        IF write_error THEN

{ if an error occurred while writing the temporary Store/Forward Network file close and detach the temporary
{ file and try again

          error_retry_count := error_retry_count + 1;
          fsp$close_file (temporary_file_identifier, ignore_status);
          amp$return (temporary_store_forward_file, ignore_status);
        IFEND;
      UNTIL (NOT write_error) OR (error_retry_count >= max_retry_count);

      IF write_error THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sf_write_network_file_error, ' ', status);
      ELSE

{ if Store/Forward Network file was successfully writen set the segment end_of_information

        amp$set_segment_eoi (temporary_file_identifier, segment_pointer, status);
        fsp$close_file (temporary_file_identifier, status);
      IFEND;
    PROCEND write_sfn_directives;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ verify the Store/Forward Network directives for errors and overlapping definitions

    verify_sfn_directives (pvt [p$input] .value^ .file_value^, pvt [p$error] .value^ .file_value^, status);
    IF status.normal THEN

{ write the temporary Store/Forward Network file

      write_sfn_directives (temporary_store_forward_file, status);
      IF status.normal THEN

{ install the temporary Store/Forward Network file into the SYSTEM's Store/Forward Network file

        install_sfn_directives (temporary_store_forward_file, status);
      IFEND;
      amp$return (temporary_store_forward_file, local_status);
    IFEND;

{ FREE all the space allocated for the information associated with the Store/Forward Network directives

    free_store_forward_information (local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND cmd_install_sf_network;
?? OLDTITLE ??
?? NEWTITLE := 'cmd_quit_sf_directive', EJECT ??

{ PURPOSE:
{   This is the Utility's command to QUIT the directive phase of
{   of VERIFY_STORE_FORWARD_NETWORK or INSTALL_STORE_FORWARD_NETWORK
{   of MANAGE_STORE_FORWARD_NETWORK.

  PROCEDURE cmd_quit_sf_directive
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*copy nft$pdt_quit_store_forward

    VAR
      ignore_status: ost$status;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      IF status.condition <> cle$parameters_displayed THEN

{ write the command to the output file

        write_command_to_output (nfc$cmd_quit, '', ignore_status);
        write_status_to_output (status);
      IFEND;
      RETURN;
    IFEND;

{ write the command to the output file

    write_command_to_output (nfc$cmd_quit, '', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ end the processing of the Store/Forward Network directives

    clp$end_include (nfv$manage_sfn_directives, status);
    If NOT status.normal THEN
      write_status_to_output (status);
      RETURN;
    IFEND;
  PROCEND cmd_quit_sf_directive;
?? OLDTITLE ??
?? NEWTITLE := 'cmd_quit_sf_network', EJECT ??

{ PURPOSE:
{   This is the Utility's command to QUIT the MANAGE_STORE_FORWARD_NETWORK.

  PROCEDURE cmd_quit_sf_network
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*copy nft$pdt_quit_store_forward

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ end the processing of the MANAGE_STORE_FORWARD_NETWORK utility

    clp$end_include (nfv$manage_sf_network, status);
    If NOT status.normal THEN
      RETURN;
    IFEND;
  PROCEND cmd_quit_sf_network;
?? OLDTITLE ??
?? NEWTITLE := 'cmd_verify_sf_network', EJECT ??

{ PURPOSE:
{   This is the Utility's command VERIFY_STORE_FORWARD_NETWORK.  It will
{   verify the SYSTEM'S STORE/FORWARD Network file.

  PROCEDURE cmd_verify_sf_network
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*copyc nft$pdt_verify_sf_network

    VAR
      local_status: ost$status;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ verify the Store/Forward Network directives for errors and overlapping definitions

    verify_sfn_directives (pvt [p$input] .value^ .file_value^, pvt [p$output] .value^ .file_value^, status);

{ FREE all the space allocated for the information associated with the Store/Forward Network directives

    free_store_forward_information (local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND cmd_verify_sf_network;
?? OLDTITLE ??
?? NEWTITLE := 'convert_parameter_to_ost$name', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to convert a name or string parameter to
{   a value of ost$name.

  PROCEDURE convert_parameter_to_ost$name
    (    parameter: clt$data_value;
     VAR parameter_value: ost$name;
     VAR parameter_size: nfc$p24_min_param_size .. nfc$p24_max_param_size;
     VAR status: ost$status);

    VAR
      value_size: ost$non_negative_integers;

    status.normal := TRUE;

    CASE parameter.kind OF
    = clc$name =

{ verify that the name value meets the length restrictions for this parameter value

      value_size := clp$trimmed_string_size (parameter.name_value);

      IF value_size < LOWERVALUE (parameter_size) THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sf_name_too_short, parameter.name_value
              (1, value_size), status);
        RETURN;
      ELSEIF value_size > UPPERVALUE (parameter_size) THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sf_name_too_long, parameter.name_value
              (1, value_size), status);
        RETURN;
      IFEND;
      parameter_value := parameter.name_value;
      parameter_size := value_size;
    = clc$string =

{ verify that the string value meets the length restrictions for this parameter value

      value_size := clp$trimmed_string_size (parameter.string_value^);
      IF value_size < LOWERVALUE (parameter_size) THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sf_string_too_short, parameter.string_value^
              (1, value_size), status);
        RETURN;
      ELSEIF value_size > UPPERVALUE (parameter_size) THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sf_string_too_long, parameter.string_value^
              (1, value_size), status);
        RETURN;
      IFEND;
      #TRANSLATE (osv$lower_to_upper, parameter.string_value^, parameter_value);
      parameter_size := value_size;
    ELSE

{ the parameter should only be a name or string value

      osp$set_status_abnormal ('CL', cle$wrong_kind_of_value, 'name or string', status);
      RETURN;
    CASEND;

  PROCEND convert_parameter_to_ost$name;
?? OLDTITLE ??
?? NEWTITLE := 'first_character_is_integer', EJECT ??

{ PURPOSE:
{   The purpose of this function is to determine if the first character
{   is an integer value.

  FUNCTION first_character_is_integer
    (    string_value: string ( * )): boolean;

    TYPE
      set_of_integers = set of char;

    VAR
      compare_character: char,
      integer_set: [STATIC, READ] set_of_integers := ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'];

    compare_character := string_value (1);
    IF compare_character IN integer_set THEN
      first_character_is_integer := TRUE;
    ELSE
      first_character_is_integer := FALSE;
    IFEND;
  FUNCEND first_character_is_integer;
?? OLDTITLE ??
?? NEWTITLE := 'free_store_forward_information', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to FREE the Store/Forward Information
{   allocated by the MANAGE_STORE_FORWARD_NETWORK directives.  This
{   information is pointed to by the global pointers: ptr_application_name_list,
{     ptr_group_name_list, ptr_source_name_list, and ptr_target_name_list.

  PROCEDURE free_store_forward_information
    (VAR status: ost$status);

    VAR
      free_application_name_ptr: ^nft$sf_application_name_info,
      free_group_name_ptr: ^nft$sf_group_name_information,
      free_source_name_ptr: ^nft$sf_source_name_information,
      free_target_name_ptr: ^nft$sf_target_name_information;

    status.normal := TRUE;

{ Free all the information on the application_name_list and set the ptr_application_name_list to NIL

    IF ptr_application_name_list <> NIL THEN
      free_application_name_ptr := ptr_application_name_list;
      WHILE free_application_name_ptr <> NIL DO
        IF free_application_name_ptr^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                'FREE_STORE_FORWARD_INFORMATION 1', status);
          RETURN;
        IFEND;
        ptr_application_name_list := free_application_name_ptr^.link.ptr;
        FREE free_application_name_ptr;
        free_application_name_ptr := ptr_application_name_list;
      WHILEND;
      ptr_application_name_list := NIL;
    IFEND;

{ Free all the information on the group_name_list and set the ptr_group_name_list to NIL

    IF ptr_group_name_list <> NIL THEN
      free_group_name_ptr := ptr_group_name_list;
      WHILE free_group_name_ptr <> NIL DO
        IF free_group_name_ptr^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                'FREE_STORE_FORWARD_INFORMATION 2', status);
          RETURN;
        IFEND;
        IF free_group_name_ptr^.ptr_destination_names.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                'FREE_STORE_FORWARD_INFORMATION 3', status);
          RETURN;
        IFEND;
        ptr_group_name_list := free_group_name_ptr^.link.ptr;
        IF free_group_name_ptr^.ptr_destination_names.ptr <> NIL THEN

{ Free the list of destination names associated with this particular group name

          FREE free_group_name_ptr^.ptr_destination_names.ptr;
        IFEND;
        FREE free_group_name_ptr;
        free_group_name_ptr := ptr_group_name_list;
      WHILEND;
      ptr_group_name_list := NIL;
    IFEND;

{ Free all the information on the source_name_list and set the ptr_source_name_list to NIL

    IF ptr_source_name_list <> NIL THEN
      free_source_name_ptr := ptr_source_name_list;
      WHILE free_source_name_ptr <> NIL DO
        IF free_source_name_ptr^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                'FREE_STORE_FORWARD_INFORMATION 4', status);
          RETURN;
        IFEND;
        ptr_source_name_list := free_source_name_ptr^.link.ptr;
        FREE free_source_name_ptr;
        free_source_name_ptr := ptr_source_name_list;
      WHILEND;
      ptr_source_name_list := NIL;
    IFEND;

{ Free all the information on the target_name_list and set the ptr_target_name_list to NIL

    IF ptr_target_name_list <> NIL THEN
      free_target_name_ptr := ptr_target_name_list;
      WHILE free_target_name_ptr <> NIL DO
        IF free_target_name_ptr^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                'FREE_STORE_FORWARD_INFORMATION 5', status);
          RETURN;
        IFEND;
        ptr_target_name_list := free_target_name_ptr^.link.ptr;
        FREE free_target_name_ptr;
        free_target_name_ptr := ptr_target_name_list;
      WHILEND;
      ptr_target_name_list := NIL;
    IFEND;
  PROCEND free_store_forward_information;
?? OLDTITLE ??
?? NEWTITLE := 'verify_sfn_directives', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to write the MANAGE_STORE_FORWARD_NETWORK
{   directive abnormal status to the specified output file.

  PROCEDURE verify_sfn_directives
    (    input_file: fst$file_reference;
         output_file: fst$file_reference;
     VAR status: ost$status);

*copyc nft$cdt_manage_sfn_directives

    VAR
      evaluated_file_ref: fst$evaluated_file_reference,
      file_reference_parsing_options: clt$file_ref_parsing_options,
      local_status: ost$status,
      output_file_size: fst$path_size,
      output_file_string: fst$path,
      utility_attributes: ^clt$utility_attributes;

?? NEWTITLE := 'compare_destination_groups', EJECT ??

{ PURPOSE:
{   The purpose of this function is to compare two destination_group_names
{   arrays of destination names to determine if the destination names are:
{     identical, a subset of each other, overlapping (but not a subset),
{     unique or cannot find either or both destination group names.

    FUNCTION compare_destination_groups
      (    destination_group_name_1: ost$name;
           destination_group_name_2: ost$name): nft$sf_dest_group_comparision;

      VAR
        group_name_1_found: boolean,
        group_name_2_found: boolean,
        index_dest_group_array_1: ost$non_negative_integers,
        index_dest_group_array_2: ost$non_negative_integers,
        number_of_group_1_names: ost$non_negative_integers,
        number_of_group_2_names: ost$non_negative_integers,
        number_of_matches_found: ost$non_negative_integers,
        ptr_dest_names_array_1: ^nft$sf_destination_names_array,
        ptr_dest_names_array_2: ^nft$sf_destination_names_array,
        ptr_dest_group_names: ^nft$sf_group_name_information;

      IF destination_group_name_1 = destination_group_name_2 THEN
        compare_destination_groups := nfc$sf_dest_groups_identical;
      ELSEIF (destination_group_name_1 = osc$null_name) OR (destination_group_name_2 = osc$null_name) THEN

{ a destination_group_name of osc$null_name means that for any destination the substition for this directive
{ will take place

        compare_destination_groups := nfc$sf_dest_groups_subset;
      ELSE
        group_name_1_found := FALSE;
        group_name_2_found := FALSE;

{ find pointers for destination group names 1 and 2

        ptr_dest_group_names := ptr_group_name_list;

      /find_ptrs_for_group_names/
        WHILE ptr_dest_group_names <> NIL DO
          IF (NOT group_name_1_found) AND (ptr_dest_group_names^.group_name = destination_group_name_1) THEN
            group_name_1_found := TRUE;
            number_of_group_1_names := ptr_dest_group_names^.destination_name_count;
            ptr_dest_names_array_1 := ptr_dest_group_names^.ptr_destination_names.ptr;
          IFEND;
          IF (NOT group_name_2_found) AND (ptr_dest_group_names^.group_name = destination_group_name_2) THEN
            group_name_2_found := TRUE;
            number_of_group_2_names := ptr_dest_group_names^.destination_name_count;
            ptr_dest_names_array_2 := ptr_dest_group_names^.ptr_destination_names.ptr;
          IFEND;
          IF group_name_1_found AND group_name_2_found THEN
            EXIT /find_ptrs_for_group_names/;
          IFEND;
          ptr_dest_group_names := ptr_dest_group_names^.link.ptr;
        WHILEND /find_ptrs_for_group_names/;

        IF group_name_1_found AND group_name_2_found THEN
          number_of_matches_found := 0;

{ determine the number of identical destination names in both group_name_1 and group_name_2

        /output_dest_group_array/
          FOR index_dest_group_array_1 := 1 TO number_of_group_1_names DO
            FOR index_dest_group_array_2 := 1 TO number_of_group_2_names DO
              IF ptr_dest_names_array_1^ [index_dest_group_array_1] =
                    ptr_dest_names_array_2^ [index_dest_group_array_2] THEN
                number_of_matches_found := number_of_matches_found + 1;
                CYCLE /output_dest_group_array/;
              IFEND;
            FOREND;
          FOREND /output_dest_group_array/;

          IF (number_of_group_1_names = number_of_matches_found) AND
                (number_of_group_2_names = number_of_matches_found) THEN

{ all the destination names from group_name_1 match all the destination names from group_name_2

            compare_destination_groups := nfc$sf_dest_groups_identical;
          ELSEIF (number_of_group_1_names = number_of_matches_found) OR
                (number_of_group_2_names = number_of_matches_found) THEN

{ all the destination names from group_name_1 match a subset of destination names from group_name_2 or
{ all the destination names from group_name_2 match a subset of destination names from group_name_1

            compare_destination_groups := nfc$sf_dest_groups_subset;
          ELSEIF (number_of_matches_found > 0) THEN

{ at least one destination name from group_name_1 matches at least one destination name from group_name_2

            compare_destination_groups := nfc$sf_dest_groups_overlap;
          ELSE { number_of_matches_found = 0 }

{ none of the destination names from group_name_1 matches any of the destination names from group_name_2

            compare_destination_groups := nfc$sf_dest_groups_unique;
          IFEND;
        ELSE

{ one or both of the group_names were not found

          compare_destination_groups := nfc$sf_dest_groups_not_found;
        IFEND;
      IFEND;
    FUNCEND compare_destination_groups;
?? OLDTITLE ??
?? NEWTITLE := 'verify_application_directives', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to verify the APPLICATION_NAME_SWITCHes from
{   the MANAGE_STORE_FORWARD_NETWORK directives for uniqueness and exclusiveness.

    PROCEDURE verify_application_directives
      (VAR status: ost$status);

      VAR
        compare_application_name_ptr: ^nft$sf_application_name_info,
        destination_group_comparision: nft$sf_dest_group_comparision,
        group_name_found: boolean,
        local_status: ost$status,
        verify_errors: boolean,
        verify_application_name_ptr: ^nft$sf_application_name_info,
        verify_group_name_ptr: ^nft$sf_group_name_information;

      status.normal := TRUE;
      verify_errors := FALSE;
      verify_application_name_ptr := ptr_application_name_list;

{ check for application_definition errors

      WHILE verify_application_name_ptr <> NIL DO
        IF verify_application_name_ptr^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                'VERIFY_APPLICATION_DIRECTIVES 1', status);
          RETURN;
        IFEND;
        compare_application_name_ptr := verify_application_name_ptr^.link.ptr;
        WHILE compare_application_name_ptr <> NIL DO
          IF compare_application_name_ptr^.link.relative_pointer THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                  'VERIFY_APPLICATION_DIRECTIVES 2', status);
            RETURN;
          IFEND;

{ check to see if the application_qualifier is a subset of the other application_qualifier

          IF (verify_application_name_ptr^.application_qualifier <=
                compare_application_name_ptr^.application_qualifier) OR
                (verify_application_name_ptr^.application_qualifier >=
                compare_application_name_ptr^.application_qualifier) THEN

            destination_group_comparision := compare_destination_groups
                  (verify_application_name_ptr^.destination_group_qualifier,
                  compare_application_name_ptr^.destination_group_qualifier);

{ check to see if the destination_group_qualifier are identical or a subset of each other

            IF (destination_group_comparision = nfc$sf_dest_groups_identical) OR
                  (destination_group_comparision = nfc$sf_dest_groups_subset) THEN

{ check to see if the next_hop_appliction are the same

              IF verify_application_name_ptr^.next_hop_application =
                    compare_application_name_ptr^.next_hop_application THEN
                osp$set_status_abnormal (nfc$status_id, nfe$sf_combine_dup_appl_def,
                      verify_application_name_ptr^.destination_group_qualifier, local_status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      verify_application_name_ptr^.next_hop_application, local_status);
              ELSE { next_hop_application are different}
                verify_errors := TRUE;
                osp$set_status_abnormal (nfc$status_id, nfe$sf_dif_nha_same_aq_and_dgq,
                      verify_application_name_ptr^.destination_group_qualifier, local_status);
              IFEND;
              write_status_to_output (local_status);
            ELSEIF destination_group_comparision = nfc$sf_dest_groups_overlap THEN

{ check to see if the next_hop_appliction are the same

              IF verify_application_name_ptr^.next_hop_application =
                    compare_application_name_ptr^.next_hop_application THEN
                osp$set_status_abnormal (nfc$status_id, nfe$sf_duplicate_appl_def,
                      verify_application_name_ptr^.destination_group_qualifier, local_status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      verify_application_name_ptr^.next_hop_application, local_status);
              ELSE { next_hop_application are different}
                verify_errors := TRUE;
                osp$set_status_abnormal (nfc$status_id, nfe$sf_dif_nha_same_aq_and_dgq,
                      verify_application_name_ptr^.destination_group_qualifier, local_status);
              IFEND;
              write_status_to_output (local_status);
            IFEND;

{ check to see if the application_qualifiers overlap

          ELSEIF (verify_application_name_ptr^.application_qualifier *
                compare_application_name_ptr^.application_qualifier) <> $nft$sf_application_set [] THEN

            destination_group_comparision := compare_destination_groups
                  (verify_application_name_ptr^.destination_group_qualifier,
                  compare_application_name_ptr^.destination_group_qualifier);

{ check to see if the destination_group_qualifier are identical or a subset of each other

            IF (destination_group_comparision = nfc$sf_dest_groups_identical) OR
                  (destination_group_comparision = nfc$sf_dest_groups_subset) OR
                  (destination_group_comparision = nfc$sf_dest_groups_overlap) THEN

{ check to see if the next_hop_appliction are different

              IF verify_application_name_ptr^.next_hop_application <>
                    compare_application_name_ptr^.next_hop_application THEN
                verify_errors := TRUE;
                osp$set_status_abnormal (nfc$status_id, nfe$sf_dif_nha_same_aq_and_dgq,
                      verify_application_name_ptr^.destination_group_qualifier, local_status);
                write_status_to_output (local_status);
              IFEND;
            IFEND;
          IFEND;
          compare_application_name_ptr := compare_application_name_ptr^.link.ptr;
        WHILEND;

        IF verify_application_name_ptr^.destination_group_qualifier <> osc$null_name THEN
          group_name_found := FALSE;
          verify_group_name_ptr := ptr_group_name_list;

{ verify that the destination_group_qualifier has been defined

        /verify_group_name_loop/
          WHILE verify_group_name_ptr <> NIL DO
            IF verify_group_name_ptr^.link.relative_pointer THEN
              osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                    'VERIFY_APPLICATION_DIRECTIVES 3', status);
              RETURN;
            IFEND;
            IF verify_application_name_ptr^.destination_group_qualifier =
                  verify_group_name_ptr^.group_name THEN
              group_name_found := TRUE;
              EXIT /verify_group_name_loop/;
            IFEND;
            verify_group_name_ptr := verify_group_name_ptr^.link.ptr;
          WHILEND /verify_group_name_loop/;

          IF NOT group_name_found THEN
            verify_errors := TRUE;
            osp$set_status_abnormal (nfc$status_id, nfe$sf_dest_group_not_found,
                  verify_application_name_ptr^.destination_group_qualifier, local_status);
            write_status_to_output (local_status);
          IFEND;
        IFEND;
        verify_application_name_ptr := verify_application_name_ptr^.link.ptr;
      WHILEND;

      IF verify_errors THEN

{ report to the user that at least one fatal directive error has occurred

        osp$set_status_abnormal (nfc$status_id, nfe$sf_directive_errors, ' ', status);
      IFEND;
    PROCEND verify_application_directives;
?? OLDTITLE ??
?? NEWTITLE := 'verify_dest_name_directives', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to verify the DESTINATION_NAME_SWITCHes from
{   the MANAGE_STORE_FORWARD_NETWORK directives for uniqueness and exclusiveness.

    PROCEDURE verify_dest_name_directives
      (VAR status: ost$status);

      VAR
        compare_target_name_ptr: ^nft$sf_target_name_information,
        local_status: ost$status,
        verify_errors: boolean,
        verify_target_name_ptr: ^nft$sf_target_name_information;

      status.normal := TRUE;
      verify_errors := FALSE;
      verify_target_name_ptr := ptr_target_name_list;

{ check for target_definition errors

      WHILE verify_target_name_ptr <> NIL DO
        IF verify_target_name_ptr^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                'VERIFY_DEST_NAME_DIRECTIVES 1', status);
          RETURN;
        IFEND;
        compare_target_name_ptr := verify_target_name_ptr^.link.ptr;
        WHILE compare_target_name_ptr <> NIL DO
          IF compare_target_name_ptr^.link.relative_pointer THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                  'VERIFY_DEST_NAME_DIRECTIVES 2', status);
            RETURN;
          IFEND;
          IF verify_target_name_ptr^.target_name = compare_target_name_ptr^.target_name THEN

{ check to see if the application_qualifier is a subset of the other application_qualifier

            IF (verify_target_name_ptr^.application_qualifier <=
                  compare_target_name_ptr^.application_qualifier) OR
                  (verify_target_name_ptr^.application_qualifier >=
                  compare_target_name_ptr^.application_qualifier) THEN

{ check to see if the next_hop_names are identical

              IF verify_target_name_ptr^.next_hop_name = compare_target_name_ptr^.next_hop_name THEN

                osp$set_status_abnormal (nfc$status_id, nfe$sf_combine_dup_target_def,
                      verify_target_name_ptr^.target_name.value, local_status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      verify_target_name_ptr^.next_hop_name.value, local_status);
              ELSE
                verify_errors := TRUE;
                osp$set_status_abnormal (nfc$status_id, nfe$sf_dif_nhn_same_n_and_aq,
                      verify_target_name_ptr^.target_name.value, local_status);
              IFEND;
              write_status_to_output (local_status);

{ check to see if the application_qualifiers overlap each other

            ELSEIF (verify_target_name_ptr^.application_qualifier *
                  compare_target_name_ptr^.application_qualifier) <> $nft$sf_application_set [] THEN

              verify_errors := TRUE;

{ check to see if the next_hop_names are identical

              IF verify_target_name_ptr^.next_hop_name = compare_target_name_ptr^.next_hop_name THEN
                osp$set_status_abnormal (nfc$status_id, nfe$sf_duplicate_target_def,
                      verify_target_name_ptr^.target_name.value, local_status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      verify_target_name_ptr^.next_hop_name.value, local_status);
              ELSE
                osp$set_status_abnormal (nfc$status_id, nfe$sf_dif_nhn_same_n_and_aq,
                      verify_target_name_ptr^.target_name.value, local_status);
              IFEND;

              write_status_to_output (local_status);
            IFEND;
          IFEND;
          compare_target_name_ptr := compare_target_name_ptr^.link.ptr;
        WHILEND;
        verify_target_name_ptr := verify_target_name_ptr^.link.ptr;
      WHILEND;

      IF verify_errors THEN

{ report to the user that at least one fatal directive error has occurred

        osp$set_status_abnormal (nfc$status_id, nfe$sf_directive_errors, ' ', status);
      IFEND;
    PROCEND verify_dest_name_directives;
?? OLDTITLE ??
?? NEWTITLE := 'verify_group_name_directives', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to verify the GROUP_NAMEes from
{   the MANAGE_STORE_FORWARD_NETWORK directives for uniqueness and exclusiveness.

    PROCEDURE verify_group_name_directives
      (VAR status: ost$status);

      VAR
        compare_group_name_ptr: ^nft$sf_group_name_information,
        compare_index: ost$non_negative_integers,
        identical_destination_names: boolean,
        group_name_used: boolean,
        local_status: ost$status,
        verify_errors: boolean,
        verify_application_name_ptr: ^nft$sf_application_name_info,
        verify_group_name_ptr: ^nft$sf_group_name_information,
        verify_source_name_ptr: ^nft$sf_source_name_information,
        verify_index: ost$non_negative_integers;

      status.normal := TRUE;
      verify_errors := FALSE;

{ check for duplicate group names

      verify_group_name_ptr := ptr_group_name_list;

      WHILE verify_group_name_ptr <> NIL DO
        IF verify_group_name_ptr^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                'VERIFY_GROUP_NAME_DIRECTIVES 1', status);
          RETURN;
        IFEND;
        compare_group_name_ptr := verify_group_name_ptr^.link.ptr;
        WHILE compare_group_name_ptr <> NIL DO
          IF compare_group_name_ptr^.link.relative_pointer THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                  'VERIFY_GROUP_NAME_DIRECTIVES 2', status);
            RETURN;
          IFEND;
          IF verify_group_name_ptr^.group_name = compare_group_name_ptr^.group_name THEN
            verify_errors := TRUE;
            osp$set_status_abnormal (nfc$status_id, nfe$sf_duplicate_group_names,
                  verify_group_name_ptr^.group_name, local_status);
            write_status_to_output (local_status);
          IFEND;
          compare_group_name_ptr := compare_group_name_ptr^.link.ptr;
        WHILEND;
        verify_group_name_ptr := verify_group_name_ptr^.link.ptr;
      WHILEND;

{ check for identical destination group lists

      verify_group_name_ptr := ptr_group_name_list;

      WHILE verify_group_name_ptr <> NIL DO
        IF verify_group_name_ptr^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                'VERIFY_GROUP_NAME_DIRECTIVES 3', status);
          RETURN;
        IFEND;
        IF verify_group_name_ptr^.ptr_destination_names.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                'VERIFY_GROUP_NAME_DIRECTIVES 4', status);
          RETURN;
        IFEND;
        compare_group_name_ptr := verify_group_name_ptr^.link.ptr;
        WHILE compare_group_name_ptr <> NIL DO
          IF compare_group_name_ptr^.link.relative_pointer THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                  'VERIFY_GROUP_NAME_DIRECTIVES 5', status);
            RETURN;
          IFEND;
          IF compare_group_name_ptr^.ptr_destination_names.relative_pointer THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                  'VERIFY_GROUP_NAME_DIRECTIVES 6', status);
            RETURN;
          IFEND;
          IF verify_group_name_ptr^.destination_name_count =
                compare_group_name_ptr^.destination_name_count THEN
            identical_destination_names := TRUE;

          /verify_destination_names/
            FOR verify_index := 1 TO verify_group_name_ptr^.destination_name_count DO
              FOR compare_index := 1 TO compare_group_name_ptr^.destination_name_count DO
                IF verify_group_name_ptr^.ptr_destination_names.ptr^ [verify_index] =
                      compare_group_name_ptr^.ptr_destination_names.ptr^ [compare_index] THEN
                  CYCLE /verify_destination_names/;
                IFEND;
              FOREND;
              identical_destination_names := FALSE;
              EXIT /verify_destination_names/;
            FOREND /verify_destination_names/;
            IF identical_destination_names THEN
              osp$set_status_abnormal (nfc$status_id, nfe$sf_identical_dest_list,
                    verify_group_name_ptr^.group_name, local_status);
              osp$append_status_parameter (osc$status_parameter_delimiter, compare_group_name_ptr^.group_name,
                    local_status);
              write_status_to_output (local_status);
            IFEND;
          IFEND;
          compare_group_name_ptr := compare_group_name_ptr^.link.ptr;
        WHILEND;
        verify_group_name_ptr := verify_group_name_ptr^.link.ptr;
      WHILEND;

{ check for unused group names

      verify_group_name_ptr := ptr_group_name_list;

      WHILE verify_group_name_ptr <> NIL DO
        IF verify_group_name_ptr^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                'VERIFY_GROUP_NAME_DIRECTIVES 7', status);
          RETURN;
        IFEND;

{ check to see if the application directives use this destination_group_qualifier

        verify_application_name_ptr := ptr_application_name_list;
        group_name_used := FALSE;
        WHILE (NOT group_name_used) AND (verify_application_name_ptr <> NIL) DO
          IF verify_application_name_ptr^.link.relative_pointer THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                  'VERIFY_GROUP_NAME_DIRECTIVES 8', status);
            RETURN;
          IFEND;
          IF verify_group_name_ptr^.group_name = verify_application_name_ptr^.destination_group_qualifier THEN
            group_name_used := TRUE;
          IFEND;
          verify_application_name_ptr := verify_application_name_ptr^.link.ptr;
        WHILEND;

{ check to see if the source name directives use this destination_group_qualifier

        verify_source_name_ptr := ptr_source_name_list;
        WHILE (NOT group_name_used) AND (verify_source_name_ptr <> NIL) DO
          IF verify_source_name_ptr^.link.relative_pointer THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                  'VERIFY_GROUP_NAME_DIRECTIVES 8', status);
            RETURN;
          IFEND;
          IF verify_group_name_ptr^.group_name = verify_source_name_ptr^.destination_group_qualifier THEN
            group_name_used := TRUE;
          IFEND;
          verify_source_name_ptr := verify_source_name_ptr^.link.ptr;
        WHILEND;

        IF NOT group_name_used THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_group_name_not_used,
                verify_group_name_ptr^.group_name, local_status);
          write_status_to_output (local_status);
        IFEND;

        verify_group_name_ptr := verify_group_name_ptr^.link.ptr;
      WHILEND;

      IF verify_errors THEN

{ report to the user that at least one fatal directive error has occurred

        osp$set_status_abnormal (nfc$status_id, nfe$sf_directive_errors, ' ', status);
      IFEND;
    PROCEND verify_group_name_directives;
?? OLDTITLE ??
?? NEWTITLE := 'verify_source_name_directives', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to verify the SOURCE_NAME_SWITCHes from
{   the MANAGE_STORE_FORWARD_NETWORK directives for uniqueness and exclusiveness.

    PROCEDURE verify_source_name_directives
      (VAR status: ost$status);

      VAR
        compare_source_name_ptr: ^nft$sf_source_name_information,
        destination_group_comparision: nft$sf_dest_group_comparision,
        group_name_found: boolean,
        local_status: ost$status,
        verify_errors: boolean,
        verify_group_name_ptr: ^nft$sf_group_name_information,
        verify_source_name_ptr: ^nft$sf_source_name_information;

      status.normal := TRUE;
      verify_errors := FALSE;
      verify_source_name_ptr := ptr_source_name_list;

{ check for source_name_definition errors

      WHILE verify_source_name_ptr <> NIL DO
        IF verify_source_name_ptr^.link.relative_pointer THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                'VERIFY_SOURCE_NAME_DIRECTIVES 1', status);
          RETURN;
        IFEND;
        compare_source_name_ptr := verify_source_name_ptr^.link.ptr;
        WHILE compare_source_name_ptr <> NIL DO
          IF compare_source_name_ptr^.link.relative_pointer THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                  'VERIFY_SOURCE_NAME_DIRECTIVES 2', status);
            RETURN;
          IFEND;

{ check to see if the source_names are identical

          IF verify_source_name_ptr^.source_name = compare_source_name_ptr^.source_name THEN

{ check to see if the application_qualifier is a subset of the other application_qualifier

            IF (verify_source_name_ptr^.application_qualifier <=
                  compare_source_name_ptr^.application_qualifier) OR
                  (verify_source_name_ptr^.application_qualifier >=
                  compare_source_name_ptr^.application_qualifier) THEN

{ check to see if the destination_group_qualifier are identical or a subset of each other

              destination_group_comparision := compare_destination_groups
                    (verify_source_name_ptr^.destination_group_qualifier,
                    compare_source_name_ptr^.destination_group_qualifier);

              IF (destination_group_comparision = nfc$sf_dest_groups_identical) OR
                    (destination_group_comparision = nfc$sf_dest_groups_subset) THEN

{ check to see if the next_hop_name are the same

                IF verify_source_name_ptr^.next_hop_name = compare_source_name_ptr^.next_hop_name THEN
                  osp$set_status_abnormal (nfc$status_id, nfe$sf_combine_dup_source_def,
                        verify_source_name_ptr^.source_name.value, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        verify_source_name_ptr^.next_hop_name.value, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        verify_source_name_ptr^.destination_group_qualifier, local_status);
                ELSE { next_hop_name are different}
                  verify_errors := TRUE;
                  osp$set_status_abnormal (nfc$status_id, nfe$sf_dif_nhn_same_n_aq_dgq,
                        verify_source_name_ptr^.source_name.value, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        verify_source_name_ptr^.destination_group_qualifier, local_status);
                IFEND;
                write_status_to_output (local_status);
              ELSEIF destination_group_comparision = nfc$sf_dest_groups_overlap THEN

{ check to see if the next_hop_name are the same

                IF verify_source_name_ptr^.next_hop_name = compare_source_name_ptr^.next_hop_name THEN
                  osp$set_status_abnormal (nfc$status_id, nfe$sf_duplicate_source_def,
                        verify_source_name_ptr^.source_name.value, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        verify_source_name_ptr^.next_hop_name.value, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        verify_source_name_ptr^.destination_group_qualifier, local_status);
                ELSE { next_hop_name are different}
                  verify_errors := TRUE;
                  osp$set_status_abnormal (nfc$status_id, nfe$sf_dif_nhn_same_n_aq_dgq,
                        verify_source_name_ptr^.source_name.value, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        verify_source_name_ptr^.destination_group_qualifier, local_status);
                IFEND;
                write_status_to_output (local_status);
              IFEND;

{ check to see if the application_qualifiers overlap

            ELSEIF (verify_source_name_ptr^.application_qualifier *
                  compare_source_name_ptr^.application_qualifier) <> $nft$sf_application_set [] THEN

{ check to see if the destination_group_qualifier are identical or a subset of each other

              destination_group_comparision := compare_destination_groups
                    (verify_source_name_ptr^.destination_group_qualifier,
                    compare_source_name_ptr^.destination_group_qualifier);

              IF (destination_group_comparision = nfc$sf_dest_groups_identical) OR
                    (destination_group_comparision = nfc$sf_dest_groups_subset) OR
                    (destination_group_comparision = nfc$sf_dest_groups_overlap) THEN

{ check to see if the next_hop_name are the same

                IF verify_source_name_ptr^.next_hop_name <> compare_source_name_ptr^.next_hop_name THEN
                  verify_errors := TRUE;
                  osp$set_status_abnormal (nfc$status_id, nfe$sf_dif_nhn_same_n_aq_dgq,
                        verify_source_name_ptr^.source_name.value, local_status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        verify_source_name_ptr^.destination_group_qualifier, local_status);
                  write_status_to_output (local_status);
                IFEND;
              IFEND;
            IFEND;
          IFEND;
          compare_source_name_ptr := compare_source_name_ptr^.link.ptr;
        WHILEND;

        IF verify_source_name_ptr^.destination_group_qualifier <> osc$null_name THEN
          group_name_found := FALSE;
          verify_group_name_ptr := ptr_group_name_list;

{ verify that the destination_group_qualifier has been defined

        /verify_group_name_loop/
          WHILE verify_group_name_ptr <> NIL DO
            IF verify_group_name_ptr^.link.relative_pointer THEN
              osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                    'VERIFY_SOURCE_NAME_DIRECTIVES 3', status);
              RETURN;
            IFEND;
            IF verify_group_name_ptr^.ptr_destination_names.relative_pointer THEN
              osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_ptr,
                    'VERIFY_SOURCE_NAME_DIRECTIVES 4', status);
              RETURN;
            IFEND;
            IF verify_source_name_ptr^.destination_group_qualifier = verify_group_name_ptr^.group_name THEN
              group_name_found := TRUE;
              EXIT /verify_group_name_loop/;
            IFEND;
            verify_group_name_ptr := verify_group_name_ptr^.link.ptr;
          WHILEND /verify_group_name_loop/;

          IF NOT group_name_found THEN
            verify_errors := TRUE;
            osp$set_status_abnormal (nfc$status_id, nfe$sf_dest_group_not_found,
                  verify_source_name_ptr^.destination_group_qualifier, local_status);
            write_status_to_output (local_status);
          IFEND;
        IFEND;
        verify_source_name_ptr := verify_source_name_ptr^.link.ptr;
      WHILEND;

      IF verify_errors THEN

{ report to the user that at least one fatal directive error has occurred

        osp$set_status_abnormal (nfc$status_id, nfe$sf_directive_errors, ' ', status);
      IFEND;
    PROCEND verify_source_name_directives;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

{ open the specified output file that will receive the directives and any appropriate error messages

    fsp$open_file (output_file, amc$record, NIL, NIL, NIL, NIL, NIL, output_file_identifier, status);
    output_file_open := status.normal;
    IF status.normal THEN

      PUSH utility_attributes : [1 .. 5];
      utility_attributes^ [1].key := clc$utility_command_search_mode;
      utility_attributes^ [1].command_search_mode := clc$exclusive_command_search;
      utility_attributes^ [2].key := clc$utility_command_table;
      utility_attributes^ [2].command_table := mansfn_directive_list;
      utility_attributes^ [3].key := clc$utility_prompt;
      utility_attributes^ [3].prompt.size := 3;
      utility_attributes^ [3].prompt.value := 'vsf';
      utility_attributes^ [4].key := clc$utility_subcmnd_log_enabled;
      utility_attributes^ [4].subcommand_logging_enabled := TRUE;
      utility_attributes^ [5].key := clc$utility_termination_command;
      utility_attributes^ [5].termination_command := 'QUIT';

{ add the Store/Forward Network directives utility to the users command list

      clp$begin_utility (nfv$manage_sfn_directives, utility_attributes^, status);
      IF status.normal THEN

{ process the MANAGE_STORE_FORWARD_NETWORK utility directives from the user

        clp$include_file (input_file, '', nfv$manage_sfn_directives, status);

{ delete the Store/Forward Network directives utility to the users command list

        clp$end_utility (nfv$manage_sfn_directives, local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;

{ verify the various groups of Store/Forward Network directives

        verify_group_name_directives (local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;

        verify_application_directives (local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;

        verify_source_name_directives (local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;

        verify_dest_name_directives (local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;

        IF NOT status.normal AND NOT ((status.condition = nfe$sf_internal_error_bad_ptr) OR
              (status.condition = nfe$sf_internal_error_bad_rptr)) THEN
          file_reference_parsing_options := $clt$file_ref_parsing_options [];
          clp$evaluate_file_reference (output_file, file_reference_parsing_options, TRUE, evaluated_file_ref,
                local_status);
          clp$convert_file_ref_to_string (evaluated_file_ref, FALSE, output_file_string, output_file_size,
                local_status);
          osp$set_status_abnormal (nfc$status_id, nfe$sf_directive_errors,
                output_file_string (1, output_file_size), status);
        IFEND;

      ELSE

{ delete the Store/Forward Network directives utility to the users command list

        clp$end_utility (nfv$manage_sfn_directives, local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;
      IFEND;
    IFEND;

{ close the specified output file that received the directives and error messages

    fsp$close_file (output_file_identifier, local_status);
    output_file_open := NOT local_status.normal;
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;
  PROCEND verify_sfn_directives;
?? OLDTITLE ??
?? NEWTITLE := 'write_command_to_output', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to write the MANAGE_STORE_FORWARD_NETWORK
{   directive to the specified output file.

  PROCEDURE write_command_to_output
    (    command_name: string ( * );
         parameter_list: string ( * );
     VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      command_name_length: integer,
      length: integer,
      output_line: ^string ( * ),
      parameter_list_length: integer;

    status.normal := TRUE;
    command_name_length := clp$trimmed_string_size (command_name);
    parameter_list_length := clp$trimmed_string_size (parameter_list);
    PUSH output_line: [1 + command_name_length + 1 + parameter_list_length];
    output_line^ := ' ';
    output_line^ (2, * ) := command_name;
    output_line^ ((command_name_length + 3), * ) := parameter_list;
    amp$put_next (output_file_identifier, output_line, (command_name_length + parameter_list_length + 2),
          byte_address, status);
  PROCEND write_command_to_output;
?? OLDTITLE ??
?? NEWTITLE := 'write_status_to_output', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to write the MANAGE_STORE_FORWARD_NETWORK
{   directive abnormal status to the specified output file and to the job log.

  PROCEDURE write_status_to_output
    (    status: ost$status);

    CONST
      max_output_message_length = 80;

    VAR
      byte_address: amt$file_byte_address,
      ignore_status: ost$status,
      line_index: 1 .. osc$max_status_message_lines,
      message: ost$status_message,
      message_line_count: ^ost$status_message_line_count,
      message_line_size: ^ost$status_message_line_size,
      message_line_text: ^string ( * ),
      ptr_message: ^ost$status_message;

    osp$format_message (status, osc$full_message_level, max_output_message_length, message, ignore_status);
    ptr_message := ^message;
    RESET ptr_message;
    NEXT message_line_count IN ptr_message;
    FOR line_index := 1 TO message_line_count^ DO
      NEXT message_line_size IN ptr_message;
      NEXT message_line_text: [message_line_size^] IN ptr_message;
      pmp$log (message_line_text^, ignore_status);
      amp$put_next (output_file_identifier, message_line_text, message_line_size^, byte_address,
            ignore_status);
    FOREND;
  PROCEND write_status_to_output;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$manage_store_forward_netwrk', EJECT ??

  PROGRAM nfp$manage_store_forward_netwrk
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*copy nfh$manage_store_forward_netwrk

*copyc nft$pdt_manage_sf_network

*copyc nft$cdt_manage_sf_network

    VAR
      establish_descriptor: pmt$established_handler,
      exit_condition: [STATIC, READ] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      local_status: ost$status,
      user_capability_network_appl: boolean,
      user_capability_network_oper: boolean,
      utility_attributes: ^clt$utility_attributes;

?? NEWTITLE := 'sf_network_condition_handler', EJECT ??

{ PURPOSE:
{   This is the condition handler for the utility  MANAGE_STORE_FORWARD_NETWORK.

    PROCEDURE sf_network_condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR cond_handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pmp$log (' MANAGE_STORE_FORWARD_NETWORK error processing', ignore_status);
      IF output_file_open THEN
        fsp$close_file (output_file_identifier, ignore_status);
        output_file_open := NOT ignore_status.normal;
      IFEND;
    PROCEND sf_network_condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    output_file_open := FALSE;

{ initialize the global pointers to the various lists

    ptr_application_name_list := NIL;
    ptr_group_name_list := NIL;
    ptr_source_name_list := NIL;
    ptr_target_name_list := NIL;

{ see if the user is validated to use this utility

    IF NOT jmp$system_job () THEN
      avp$get_capability (avc$network_applic_management, avc$user, user_capability_network_appl, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      avp$get_capability (avc$network_operation, avc$user, user_capability_network_oper, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (NOT user_capability_network_appl) AND (NOT user_capability_network_oper) THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sf_caller_not_privileged, nfv$manage_sf_network, status);
        RETURN;
      IFEND;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$establish_condition_handler (exit_condition, ^sf_network_condition_handler, ^establish_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ add the Manage_Store_Forward_Network utility to the users command list

    PUSH utility_attributes : [1 .. 5];
    utility_attributes^ [1].key := clc$utility_command_search_mode;
    utility_attributes^ [1].command_search_mode := clc$global_command_search;
    utility_attributes^ [2].key := clc$utility_command_table;
    utility_attributes^ [2].command_table := mansfn_command_list;
    utility_attributes^ [3].key := clc$utility_prompt;
    utility_attributes^ [3].prompt.size := 3;
    utility_attributes^ [3].prompt.value := 'msf';
    utility_attributes^ [4].key := clc$utility_subcmnd_log_enabled;
    utility_attributes^ [4].subcommand_logging_enabled := TRUE;
    utility_attributes^ [5].key := clc$utility_termination_command;
    utility_attributes^ [5].termination_command := 'QUIT';

    clp$begin_utility (nfv$manage_sf_network, utility_attributes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ process the MANAGE_STORE_FORWARD_NETWORK utility commands from the user

    clp$include_file (clc$current_command_input, '', nfv$manage_sf_network, status);

{ delete the Manage_Store_Forward_Network utility to the users command list

    clp$end_utility (nfv$manage_sf_network, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

    pmp$disestablish_cond_handler (exit_condition, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;
  PROCEND nfp$manage_store_forward_netwrk;
?? OLDTITLE ??
MODEND nfm$manage_store_forward_netwrk;
*DECK DECK=NFM$NTF_FILE_TRANSFER_PROCS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NFM$NTF_FILE_TRANSFER_PROCS' ??
MODULE nfm$ntf_file_transfer_procs;

{ PURPOSE:
{   This module contains procedures used by the Network Transfer Facility
{   (NTF) to receive and transmit files on a connection as well as
{   miscellaneous procedures and functions.
{
{ DESIGN:
{   The protocol routines provide the processing to support EBCDIC file
{   transfers to/from  either HASP or NJE remote systems.
{   The routines in this module are listed in alphabetical order.

?? NEWTITLE := 'Global Declarations References by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nft$control_block
*copyc nft$parameter_17_definition
*copyc nft$parameter_32_b101_text
*copyc nft$parameter_58_b101_text
*copyc nft$parameter_set
?? POP ??
*copyc amp$get_next
*copyc amp$put_next
*copyc amp$return
*copyc clp$convert_string_to_file
*copyc clp$include_line
*copyc clp$read_variable
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc pmp$continue_to_cause
*copyc pmp$establish_condition_handler
*copyc pmp$get_unique_name
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    nfc$ntf_debug_library_variable = 'NFV$NTF_DEBUG_LIBRARY',
    nfc$receive_ntf_file_command_1 = 'EXECUTE_TASK L=(',
    nfc$receive_ntf_file_command_2 = ',$SYSTEM.BATCH_DEVICE_SUPPORT.OSF$BATCH_DEVICE_SUPPORT) ' CAT
          'SP=NFP$RECEIVE_NTF_FILE P=''',
    nfc$receive_ntf_file_command_3 = '''',
    nfc$system_library_path = '$SYSTEM.NETWORK_TRANSFER_FACILITY.BOUND_PRODUCT';

?? TITLE := 'get_library_path', EJECT ??

{ PURPOSE:
{   This procedure determines which library should be used for NTF receive file
{   processing.  If the SCL variable NFV$NTF_DEBUG_LIBRARY is defined with a
{   file name, that file name is used for the library.  Otherwise, the file
{   name $SYSTEM.NETWORK_TRANSFER_FACILITY.BOUND_PRODUCT is used for the
{   library.

  PROCEDURE get_library_path
    (VAR library_path: ost$string;
     VAR status: ost$status);

    VAR
      convert_status: ost$status,
      convert_string: ost$string,
      file: clt$file,
      read_status: ost$status,
      variable: clt$variable_reference;

    status.normal := TRUE;
    library_path.value := nfc$system_library_path;
    library_path.size := clp$trimmed_string_size (library_path.value);
    clp$read_variable (nfc$ntf_debug_library_variable, variable, read_status);
    IF read_status.normal AND (variable.value.kind = clc$string_value) AND (variable.lower_bound = 1) AND
          (variable.upper_bound = 1) AND (variable.value.max_string_size = osc$max_string_size) AND (#SIZE
          (variable.value.string_value^) = #SIZE (library_path)) THEN
      #UNCHECKED_CONVERSION (variable.value.string_value^, convert_string);
      clp$convert_string_to_file (convert_string.value (1, convert_string.size), file, convert_status);
      IF convert_status.normal THEN
        library_path := convert_string;
      IFEND;
    IFEND;
  PROCEND get_library_path;
?? TITLE := '[XDCL] NFP$NTF_RECEIVE_FILE', EJECT ??
*copy nfh$ntf_receive_file

  PROCEDURE [XDCL] nfp$ntf_receive_file
    (VAR control_block: nft$control_block;
     VAR p17_param: nft$parameter_17_definition;
     VAR p32_params: nft$p32_b101_ntf_params;
     VAR p58_params: nft$p58_b101_ntf_params;
     VAR stopr_params: nft$parameter_set;
     VAR queue_status: ost$status;
     VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      command: string (osc$max_string_size),
      establish_descriptor: pmt$established_handler,
      file_identifier: amt$file_identifier,
      file_position: amt$file_position,
      input: amt$local_file_name,
      library_path: ost$string,
      output: amt$local_file_name,
      transfer_count: amt$transfer_count;

    VAR
      conditions: [READ] pmt$condition := [pmc$all_conditions];

?? NEWTITLE := 'handle_conditions', EJECT ??

    PROCEDURE handle_conditions
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (file_identifier, ignore_status);
      amp$return (input, ignore_status);
      amp$return (output, ignore_status);
      IF (NOT status.normal) AND queue_status.normal THEN
        queue_status := status;
      IFEND;

      status.normal := TRUE;
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND handle_conditions;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    pmp$get_unique_name (input, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    pmp$get_unique_name (output, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    command := nfc$receive_ntf_file_command_1;
    get_library_path (library_path, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    command (clp$trimmed_string_size (command) + 1, * ) := library_path.value (1, library_path.size);
    command (clp$trimmed_string_size (command) + 1, * ) := nfc$receive_ntf_file_command_2;
    command (clp$trimmed_string_size (command) + 1, * ) := input;
    command (clp$trimmed_string_size (command) + 2, * ) := output;
    command (clp$trimmed_string_size (command) + 1, * ) := nfc$receive_ntf_file_command_3;
    pmp$establish_condition_handler (conditions, ^handle_conditions, ^establish_descriptor, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    fsp$open_file (input, amc$record, NIL, NIL, NIL, NIL, NIL, file_identifier, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    amp$put_next (file_identifier, ^control_block, #SIZE (control_block), byte_address, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    amp$put_next (file_identifier, ^p17_param, #SIZE (p17_param), byte_address, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    amp$put_next (file_identifier, ^p32_params, #SIZE (p32_params), byte_address, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    amp$put_next (file_identifier, ^p58_params, #SIZE (p58_params), byte_address, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    amp$put_next (file_identifier, ^stopr_params, #SIZE (stopr_params), byte_address, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    amp$put_next (file_identifier, ^queue_status, #SIZE (queue_status), byte_address, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    fsp$close_file (file_identifier, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    clp$include_line (command, FALSE, osc$null_name, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    amp$return (input, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    fsp$open_file (output, amc$record, NIL, NIL, NIL, NIL, NIL, file_identifier, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    amp$get_next (file_identifier, ^control_block, #SIZE (control_block), transfer_count, byte_address,
          file_position, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    amp$get_next (file_identifier, ^p17_param, #SIZE (p17_param), transfer_count, byte_address, file_position,
          status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    amp$get_next (file_identifier, ^p32_params, #SIZE (p32_params), transfer_count, byte_address,
          file_position, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    amp$get_next (file_identifier, ^p58_params, #SIZE (p58_params), transfer_count, byte_address,
          file_position, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    amp$get_next (file_identifier, ^stopr_params, #SIZE (stopr_params), transfer_count, byte_address,
          file_position, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    amp$get_next (file_identifier, ^queue_status, #SIZE (queue_status), transfer_count, byte_address,
          file_position, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    fsp$close_file (file_identifier, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    amp$return (output, status);
  PROCEND nfp$ntf_receive_file;
MODEND nfm$ntf_file_transfer_procs;
*DECK DECK=NFM$OPERATE_STATION EXPAND=TRUE
?? NEWTITLE := 'Batch I/O Station Operator Utility' ??
?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, INDENT := 2) ??
?? SET (LIST := ON, LISTCTS := OFF) ??
MODULE nfm$operate_station;

{
{ PURPOSE:
{   This module is a command utility which contains command processors
{   for the Batch I/O Station Operator Utility.  Processors in this
{   module process the operator commands, and communicate with SCFS/VE
{   through CDCNET.
{

?? NEWTITLE := '  Global declarations' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc cld$parameter_list
*copyc clt$file_reference
*copyc clt$path_display_chunks
*copyc nft$file_vertical_print_density
*copyc nae$application_interfaces
*copyc nat$title
*copyc nfd$sou_intertask_communication
*copyc nfe$batch_transfer_services
*copyc nfe$sou_condition_codes
*copyc nft$file_transfer_state
*copyc nft$message_kind
*copyc nft$message_sequence
*copyc nft$parameter_value_length
*copyc nft$scfs_client_identifier
*copyc nft$sou_message_parameter_types
*copyc nft$term_to_application_acctg
*copyc oss$job_paged_literal
*copyc ost$status
*copyc pmd$local_queues
*copyc pmt$os_name
*copyc pmt$program_parameters
?? POP ??
*copyc avp$get_capability
*copyc avp$get_name_value
*copyc amp$return
*copyc clp$build_standard_title
*copyc clp$right_justify_string
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_real
*copyc clp$new_display_line
*copyc clp$open_display
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$read_variable
*copyc clp$reset_for_next_display_page
*copyc clp$end_scan_command_file
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$scan_command_file
*copyc clp$scan_parameter_list
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc jmp$determine_name_kind
*copyc jmp$get_job_attributes
*copyc jmp$get_output_status
*copyc jmp$get_result_size
*copyc jmp$system_job
*copyc nap$await_data_available
*copyc nap$begin_directory_search
*copyc nap$end_directory_search
*copyc nap$get_title_translation
*copyc nap$request_connection
*copyc nap$se_receive_data
*copyc nap$se_send_data
*copyc nfp$end_async_communication
*copyc nfp$get_async_task_message
*copyc nfp$get_parameter_value_length
*copyc nfp$put_async_task_message
*copyc nfp$put_parameter_value_length
*copyc nfp$request_asynchronous_task
*copyc nfp$send_message_on_connection
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$i_await_activity_completion
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pmp$get_unique_name
*copyc pmp$get_microsecond_clock
*copyc pmp$get_user_identification
*copyc pmp$log
*copyc pmp$long_term_wait

?? TITLE := '  Utility global variables', EJECT ??
*copyc nft$byte_array

  TYPE
    nft$parameter_kind = 0 .. 07f(16),

    nft$parameter_type = PACKED RECORD
      length_indicated: BOOLEAN,
      param: nft$parameter_kind,
    RECEND;

  TYPE
    nft$queued_operator_message = RECORD
      link: ^nft$queued_operator_message,
      station: ost$name,
      device: ost$name,
      text: STRING (* <= nfc$maximum_message_length),
    RECEND;

  TYPE
    t$terminal_device_information = RECORD
      CASE use (get_job_attributes, get_junk_from_accounting_record) OF
      = get_job_attributes =
        attr_data: jmt$job_input_device,          {device info in string format}
      = get_junk_from_accounting_record =         {device info in record format}
        acctg_data: t$term_to_application_acctg,
      CASEND,
    RECEND;

  TYPE
    t$term_to_application_acctg = RECORD
      size: 0 .. jmc$job_input_device_size,   {for compatibility with jmt$job_input_device}
      acctg_record: nft$term_to_application_acctg,
    RECEND;

  TYPE
    t$device_list = RECORD
      name: ost$name,
      dtype: nft$device_type,
    RECEND;

  TYPE
    t$display_option = (display_all, display_brief);

  VAR
    operator_message_list: ^nft$queued_operator_message := NIL;

  VAR
    display_utility_name: [READ] ost$name := 'DISPLAY_STATION',
    operator_utility_name: [READ] ost$name := 'OPERATE_STATION',
    station_name: ost$name,
    station_operator: boolean := TRUE;

  VAR
    connection_made: BOOLEAN,
    network_file_open: BOOLEAN,
    async_task_active: BOOLEAN,
    debug_mode: pmt$debug_mode := pmc$debug_mode_off,
    network_file: ost$name,
    network_file_id: amt$file_identifier;

  VAR
    message: ^nft$message_sequence,
    message_length: INTEGER,
    msg_byte_count: INTEGER,
    message_type: ^nft$message_kind;

  VAR
    async_task_id: pmt$task_id,
    local_queue_id: pmt$queue_connection,
    transfer_count: 0 .. nfc$max_transfer_size;

?? EJECT ??

  VAR
    banner_highlight_fields: [READ] ARRAY [nft$banner_highlight_field] OF STRING (banner_highlight_size) :=
        [ {nfc$comment_banner} 'comment_banner',  {nfc$routing_banner} 'routing_banner',
          {nfc$site_banner} 'site_banner',        {nfc$user_file_name} 'user_file_name',
          {nfc$user_name} 'user_name'  ],

    boolean_values: [READ] ARRAY [BOOLEAN] OF STRING (3) :=
        [ {false} 'no',  {true} 'yes' ],

    carriage_control_actions: [READ] ARRAY [nft$carriage_control_action] OF STRING (cc_action_size) :=
        [ {nfc$pre_print} 'pre_print',                   {nfc$post_print} 'post_print',
          {nfc$pre_and_post_print} 'pre_print and post_print'  ],

    code_sets: [READ] ARRAY [nft$code_set] OF STRING (code_set_size) :=
        [ {nfc$ascii} 'ascii',                   {nfc$ascii_48} 'ascii48',
          {nfc$ascii_64} 'ascii64',              {nfc$ascii_95} 'ascii95',
          {nfc$ascii_128} 'ascii128',            {nfc$ebcdic} 'ebcdic',
          {nfc$ascii_256} 'ascii256',            {nfc$bcd} 'bcd',
          {nfc$site_defined} 'site_defined'],

    destination_unavail_actions: [READ] ARRAY [nft$destination_unavail_actions]
        OF STRING (dest_unavail_size) :=
        [ {nfc$stop_input_device} 'stop input device',
          {nfc$drop_input_job} 'drop input job'],

    device_statuses: [READ] ARRAY [nft$device_status] OF STRING (device_status_size) :=
        [ {nfc$device_active} 'active',       {nfc$device_stopped} 'stopped',
          {nfc$device_not_ready} 'not ready', {nfc$device_down} 'down',
          {nfc$device_loading_vfu} 'loading Device Load Procedure',
          {nfc$default_vfu_not_loadable} 'default Device Load Procedure not loadable',
          {nfc$device_stopped_by_system} 'stopped by system',
          {nfc$device_status_reserved_7} ' ',
          {nfc$device_status_reserved_8} ' ',
          {nfc$device_status_reserved_9} ' ',
          {nfc$device_status_reserved_10} ' ',
          {nfc$ntf_waiting_signon} ' ',
          {nfc$ntf_signon_initiated} ' ',
          {nfc$ntf_signed_on} ' ',
          {nfc$ntf_signon_failed} ' ',
          {nfc$ntf_signed_off} ' '],

    device_types: [READ] ARRAY [nft$device_type] OF STRING (device_type_size) :=
        [ {nfc$null_device} ' ',              {nfc$console} 'console',
          {nfc$reader} 'reader',              {nfc$printer} 'printer',
          {nfc$punch} 'punch',                {nfc$plotter} 'plotter',
          {nfc$ntf_remote_system_input} ' ',{nfc$ntf_job_receiver} ' ',
          {nfc$ntf_sysout_receiver} ' ',    {nfc$ntf_job_transmitter} ' ',
          {nfc$ntf_sysout_transmitter} ' '],

    file_transfer_statuses: [READ] ARRAY [nft$file_transfer_status] OF STRING (transfer_status_size) :=
        [ {nfc$idle} 'idle',
          {nfc$idle_device_disconnect} 'idle, device disconnect',
          {nfc$idle_vfu_not_loadable} 'idle, Device Load Procedure not loadable',
          {nfc$idle_transfer_error} 'idle, transfer error',
          {nfc$idle_accounting_limit} 'idle, accounting limit',
          {nfc$idle_operator_drop_file} 'idle, operator dropped file',
          {nfc$idle_operator_requeued_file} 'idle, operator requeued file',
          {nfc$idle_operator_hold_file} 'idle, operator hold file',
          {nfc$busy} 'busy',
          {nfc$suspended_device_not_ready} 'suspended, device not ready',
          {nfc$suspended_pm_message} 'suspended, PM message',
          {nfc$suspended_operator_command} 'suspended, operator command',
          {nfc$suspended_operator_posf_comd} 'suspended, operator position file',
          {nfc$suspended_vfu_being_loaded} 'suspended, Device Load Procedure being loaded',
          {nfc$busy_reserved_22} ' ',
          {nfc$busy_reserved_23} ' '   ],

    file_vpd_actions: [READ] ARRAY [nft$file_vertical_print_density] OF STRING (file_vpd_action_size) :=
        [ {nfc$vertical_print_density_none} 'none',
          {nfc$vertical_print_density_6} 'six',
          {nfc$vertical_print_density_7} 'seven',
          {nfc$vertical_print_density_8} 'eight',
          {nfc$vertical_print_density_9} 'nine',
          {nfc$vertical_print_density_10} 'ten',
          {nfc$vertical_print_density_11} 'eleven',
          {nfc$vertical_print_density_12} 'twelve'],

    format_effector_actions: [READ] ARRAY [nft$format_effector_actions] OF STRING (fe_action_size) :=
        [ {nfc$print_after_spacing} 'print_after_spacing',
          {nfc$print_before_spacing} 'print_before_spacing',
          {nfc$discard_print_line} 'discard_print_line'  ],

    output_data_modes: [READ] ARRAY [nft$output_data_mode] OF STRING (data_mode_size) :=
        [ {nfc$coded_mode} 'coded',  {nfc$transparent_mode} 'transparent' ],

    output_states: [READ] array [nft$file_transfer_state] OF string (output_state_size) :=
        [ {nfc$eligible_for_transfer}   'eligible to transfer',
          {nfc$hold_transfer}           'on hold',
          {nfc$not_eligible_for_output} 'not eligible to transfer',
          {nfc$selected_for_transfer}   'selected to transfer'     ],

    page_formats: [READ] ARRAY [nft$page_format] OF STRING (page_format_size) :=
        [ {amc$continuous_form} 'continuous',       {amc$burstable_form} 'burstable',
          {amc$non_burstable_form} 'non-burstable', {amc$untitled_form} 'untitled'    ],

    pm_message_actions: [READ] ARRAY [nft$pm_message_actions] OF STRING (pm_action_size) :=
        [ {nfc$print_pm_message} 'print',
          {nfc$display_message_to_operator} 'display',
          {nfc$discard_pm_message_line} 'discard'  ],

    station_usages: [READ] ARRAY [nft$io_station_usage] OF STRING (station_usage_size) :=
        [ {nfc$public_io_station} 'public',  {nfc$private_io_station} 'private' ,
          {nfc$ntf_remote_system_usage} 'ntf'],

    vfu_load_option_actions: [READ] ARRAY [nft$vfu_load_option] OF STRING (vfu_action_size) :=
        [ {nfc$vfu_not_present_or_load} 'VFU not present or loadable',
          {nfc$vfu_loaded_at_init} 'VFU loaded at initialization',
          {nfc$vfu_changeable_by_operator} 'VFU changeable by operator',
          {nfc$vfu_changeable_by_user} 'VFU changeable by user'  ],

    vpd_actions: [READ] ARRAY [nft$vertical_print_density] OF STRING (vpd_action_size) :=
        [ {nfc$six_only} 'six_only',                   {nfc$eight_only} 'eight_only',
          {nfc$six_any} 'six_any',                     {nfc$eight_any} 'eight_any' ];

  CONST
    banner_highlight_size = 14,
    cc_action_size = 24,
    code_set_size = 9,
    data_mode_size = 11,
    dest_unavail_size = 17,
    device_status_size = 42,
    device_type_size =  7,
    fe_action_size = 20,
    file_vpd_action_size = 6,
    output_state_size = 24,
    page_format_size = 13,
    pm_action_size = 7,
    station_usage_size = 7,
    transfer_status_size = 45,
    vfu_action_size = 28,
    vpd_action_size = 10;

  VAR
    message_types: [READ] ARRAY [nft$message_kind] OF string (message_type_size) :=
        [ {0-39}  REP 40 OF *,                           {40} 'SUPPRESS_CARRIAGE_CONTROL',
          {41} 'START_BATCH_DEVICE',                     {42} 'STOP_BATCH_DEVICE',
          {43} 'SUPPRESS_CARRIAGE_CONTROL',              {44} 'TERMINATE_TRANSFER',
          {45} 'CHANGE_BATCH_DEVICE_ATTRIBUTES',         {46} 'CHANGE_BATCH_DEVICE_ATTRIBUTES',
          {47} 'START_BATCH_DEVICE',                     {48} 'STOP_BATCH_DEVICE',
          {49} 'TERMINATE_TRANSFER',                     {50} 'POSITION_FILE',
          {51} 'OPERATOR_MESSAGE',
          {52-59}  REP 8 OF *,                           {60} 'ADD_USER',
          {61} 'ADD_USER_RESPONSE',                      {62} 'SELECT_FILE',
          {63} 'SELECT_FILE',                            {64} 'POSITION_FILE',
          {65} 'GET_STATION_STATUS',                     {66} 'STATION_STATUS_DATA',
          {67} 'GET_DEVICE_STATUS',                      {68} 'DEVICE_STATUS_DATA',
          {69} 'GET_QUEUE_STATUS',                       {70} 'QUEUE_STATUS_DATA',
          {71} 'GET_QUEUE_ENTRY_LIST',                   {72} 'QUEUE_ENTRY_LIST_DATA',
          {73} 'GET_QUEUE_ENTRY_DATA',                   {74} 'QUEUE_ENTRY_DATA',
          {75} 'TERMINATE_QUEUE_OUTPUT',                 {76} 'TERMINATE_QUEUE_OUTPUT',
          {77-95}  REP 19 OF *  ];

  CONST
    message_type_size = 30;

  VAR
    response_types: [READ] ARRAY [nft$message_kind] OF nft$message_kind :=
        [ {0-40}  REP 41 OF nfc$reserved_msg_type_0,
          {nfc$start_batch_device}          nfc$start_batch_device_resp,
          {nfc$stop_batch_device}           nfc$stop_batch_device_resp,
          {nfc$suppress_carriage_control}   nfc$suppress_carriage_cntrl_rsp,
          {nfc$terminate_transfer}          nfc$terminate_transfer_resp,
          {nfc$change_batch_device_attr}    nfc$change_bat_device_attr_resp,
          {46-59} REP 14 OF nfc$reserved_msg_type_0,
          {nfc$add_user}                    nfc$add_user_resp,
          {61} nfc$reserved_msg_type_0,
          {nfc$select_file}                 nfc$select_file_response,
          {63} nfc$reserved_msg_type_0,
          {nfc$position_file_sou}           nfc$position_file_resp,
          {nfc$get_station_status}          nfc$station_status_data,
          {66} nfc$reserved_msg_type_0,
          {nfc$get_device_status}           nfc$device_status_data,
          {68} nfc$reserved_msg_type_0,
          {nfc$get_queue_status}            nfc$queue_status_data,
          {70} nfc$reserved_msg_type_0,
          {nfc$get_queue_entry_list}        nfc$queue_entry_list_data,
          {72} nfc$reserved_msg_type_0,
          {nfc$get_queue_entry}             nfc$queue_entry_data,
          {74} nfc$reserved_msg_type_0,
          {nfc$terminate_queue_output}      nfc$terminate_queue_output_resp,
          {76} nfc$reserved_msg_type_0,
          {77-95}  REP 19 OF nfc$reserved_msg_type_0   ];

  VAR
    add_user_responses: [READ] ARRAY [nft$add_user_responses] OF STRING (response_desc_size) :=
        [ {nfc$message_accepted} '',
          {nfc$no_io_station_found} 'no io station found',
          {nfc$operator_already_assigned} 'operator already assigned',
          {nfc$operator_device_mismatch} 'operator device mismatch'   ],

    device_control_responses: [READ] ARRAY [nft$device_control_resp_codes] OF STRING (response_desc_size) :=
        [ {nfc$dc_message_accepted} '',
          {nfc$dc_msg_reject_btfsdi_down} 'BTFS DI down',
          {nfc$dc_msg_reject_unknown_ios} 'unknown io station',
          {nfc$dc_msg_reject_unknown_dev} 'unknown device',
          {nfc$dc_msg_reject_bad_dev_type} 'wrong device type',
          {nfc$dc_msg_reject_bad_data_mode} 'transparent output may only be positioned to BOI or EOI',
          {nfc$dc_msg_rej_unsupported_vfu} 'device cannot support the specified Device Load Procedure',
          {nfc$dc_msg_rej_vfu_ld_outstand} 'Device Load Procedure load request outstanding',
          {nfc$dc_msg_rej_image_not_found} 'Device Load Procedure load image not found',
          {nfc$dc_msg_rej_err_in_vfu_image} 'syntax error in Device Load Procedure load image',
          {nfc$dc_msg_rej_vfu_not_change} 'Device Load Procedure not changeable by operator',
          {nfc$dc_msg_rej_trm_undefined} 'terminal model is undefined',
          {nfc$dc_msg_rej_vfu_not_allow} 'Device Load Procedure not changeable when device is busy',
          {nfc$dc_msg_rej_low_di_memory} 'DI memory too low to process request',
          {nfc$dc_msg_rej_tip_reject_attr} 'TIP rejected attributes'],


    display_status_responses: [READ] ARRAY [nft$display_status_resp_codes] OF STRING (response_desc_size) :=
        [ {nfc$disp_msg_accepted} '',
          {nfc$disp_no_io_station} 'no io station',
          {nfc$disp_no_batch_device} 'no batch device',
          {nfc$disp_unknown_file_name} 'unknown file name'   ],

    select_file_responses: [READ] ARRAY [nft$select_file_response] OF STRING (response_desc_size) :=
        [ {nfc$self_msg_accepted} '',
          {nfc$self_msg_unknown_ios} 'unknown io station',
          {nfc$self_msg_unknown_device} 'unknown device',
          {nfc$self_msg_unknown_file} 'unknown file',
          {nfc$self_file_already_printing} 'file already printing',
          {nfc$self_wrong_device_type} 'invalid device type',
          {nfc$self_duplicate_file_name} 'file name must be unique'],

    terminate_queue_output_resps: [READ] array [nft$terqo_file_status_codes] of string (response_desc_size) :=
        [ {nfc$terqo_successful} '',
          {nfc$terqo_unknown_ios} 'unknown io station name',
          {nfc$terqo_unknown_file_name} 'unknown file name',
          {nfc$terqo_duplicate_file_names} 'file name must be unique',
          {nfc$terqo_file_in_transfer} 'file is being transferred',
          {nfc$terqo_message_rejected} 'message was rejected'];

  CONST
    no_response_code = 'no response code',
    response_desc_size = 57;

  VAR
    peer_operations: [READ] ARRAY [nat$se_peer_operation_kind] OF STRING (peer_operation_size) :=
        [ {nac$se_send_data} '',
          {nac$se_interrupt} 'Interrupt',
          {nac$se_synchronize} 'Synchronize',
          {nac$se_synchronize_confirm} 'Synchronize Confirm'  ];

  CONST
    peer_operation_size = 19;

?? TITLE := '  [XDCL] nfp$display_station', EJECT ??

  PROCEDURE [XDCL] nfp$display_station (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT diss_pdt (
{   station_name, sn: name = $required
{   status)

    VAR
      scheduling_displays: boolean;

   status.normal := TRUE;

{  Determine if the site has defined the scheduling_displays capability, and if the current username has the
{  capability.  Pretend the user has the capability if the site has not defined it.

    avp$get_capability (avc$scheduling_displays, avc$user, scheduling_displays, status);
    IF NOT status.normal THEN
      IF (status.condition <> ave$unknown_field) AND (status.condition <> ave$field_was_deleted) THEN
        RETURN;
      ELSE

{       Ignore those two conditions.

        status.normal := TRUE;

      IFEND;
    ELSEIF NOT scheduling_displays THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sou_invalid_user, 'DISPLAY_STATION', status);
      RETURN;
    IFEND;

    station_operator := FALSE;

    nfp$operate_station (parameter_list, status);

  PROCEND nfp$display_station;

?? TITLE := '  [XDCL] nfp$operate_station', EJECT ??

  PROCEDURE [XDCL] nfp$operate_station (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT opes_pdt (
{   station_name, sn: name = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    opes_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^opes_pdt_names, ^opes_pdt_params];

  VAR
    opes_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
  clt$parameter_name_descriptor := [['STATION_NAME', 1], ['SN', 1], ['STATUS', 2]];

  VAR
    opes_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ STATION_NAME SN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??


{ table station_operator_comnds
{ command (change_batch_device_attributes, change_batch_device_attribute, chabda)     ..
{   change_batch_dev_attr_command
{ command (position_file, posf) position_file_command
{ command (suppress_carriage_control, supcc) suppress_carriage_ctrl_command
{ command (terminate_transfer, tert) terminate_transfer_command
{ command (stop_batch_device, stobd, stop) stop_batch_device_command
{ command (start_batch_device, stabd, start) start_batch_device_command
{ command (select_file, self) select_file_command
{ command (display_batch_device_status, disbds) display_batch_dev_status_commnd
{ command (display_station_status, disss) display_station_status_command
{ command (display_station_queue_status, dissqs) display_statn_q_status_command
{ command (display_station_queue_entry, display_station_queue_entries, dissqe)     ..
{   display_station_q_entry_command
{ command (terminate_queued_output, terminate_queue_output, terqo)   terminate_queued_output_command
{ command (quit, qui, end) quit_command

?? PUSH (LISTEXT := ON) ??

VAR
  station_operator_comnds: [STATIC, READ] ^clt$command_table := ^station_operator_comnds_entries,

  station_operator_comnds_entries: [STATIC, READ] array [1 .. 32] of clt$command_table_entry := [
  {} ['CHABDA                         ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^change_batch_dev_attr_command],
  {} ['CHANGE_BATCH_DEVICE_ATTRIBUTE  ', clc$alias_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^change_batch_dev_attr_command],
  {} ['CHANGE_BATCH_DEVICE_ATTRIBUTES ', clc$nominal_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^change_batch_dev_attr_command],
  {} ['DISBDS                         ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^display_batch_dev_status_commnd],
  {} ['DISPLAY_BATCH_DEVICE_STATUS    ', clc$nominal_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^display_batch_dev_status_commnd],
  {} ['DISPLAY_STATION_QUEUE_ENTRIES  ', clc$alias_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^display_station_q_entry_command],
  {} ['DISPLAY_STATION_QUEUE_ENTRY    ', clc$nominal_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^display_station_q_entry_command],
  {} ['DISPLAY_STATION_QUEUE_STATUS   ', clc$nominal_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^display_statn_q_status_command],
  {} ['DISPLAY_STATION_STATUS         ', clc$nominal_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^display_station_status_command],
  {} ['DISSQE                         ', clc$abbreviation_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^display_station_q_entry_command],
  {} ['DISSQS                         ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^display_statn_q_status_command],
  {} ['DISSS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^display_station_status_command],
  {} ['END                            ', clc$abbreviation_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^quit_command],
  {} ['POSF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^position_file_command],
  {} ['POSITION_FILE                  ', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^position_file_command],
  {} ['QUI                            ', clc$alias_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^quit_command],
  {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^quit_command],
  {} ['SELECT_FILE                    ', clc$nominal_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^select_file_command],
  {} ['SELF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^select_file_command],
  {} ['STABD                          ', clc$alias_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^start_batch_device_command],
  {} ['START                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^start_batch_device_command],
  {} ['START_BATCH_DEVICE             ', clc$nominal_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^start_batch_device_command],
  {} ['STOBD                          ', clc$alias_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^stop_batch_device_command],
  {} ['STOP                           ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^stop_batch_device_command],
  {} ['STOP_BATCH_DEVICE              ', clc$nominal_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^stop_batch_device_command],
  {} ['SUPCC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^suppress_carriage_ctrl_command],
  {} ['SUPPRESS_CARRIAGE_CONTROL      ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^suppress_carriage_ctrl_command],
  {} ['TERMINATE_QUEUED_OUTPUT        ', clc$nominal_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^terminate_queued_output_command],
  {} ['TERMINATE_QUEUE_OUTPUT         ', clc$alias_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^terminate_queued_output_command],
  {} ['TERMINATE_TRANSFER             ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^terminate_transfer_command],
  {} ['TERQO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^terminate_queued_output_command],
  {} ['TERT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^terminate_transfer_command]];

?? POP ??

{ table station_display_comnds
{ command (display_batch_device_status, disbds) display_batch_dev_status_commnd
{ command (display_station_status, disss) display_station_status_command
{ command (display_station_queue_status, dissqs) display_statn_q_status_command
{ command (display_station_queue_entry, display_station_queue_entries, dissqe)       ..
{   display_station_q_entry_command
{ command (quit, qui, end) quit_command

?? PUSH (LISTEXT := ON) ??

VAR
  station_display_comnds: [STATIC, READ] ^clt$command_table := ^station_display_comnds_entries,

  station_display_comnds_entries: [STATIC, READ] array [1 .. 12] of clt$command_table_entry := [
  {} ['DISBDS                         ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^display_batch_dev_status_commnd],
  {} ['DISPLAY_BATCH_DEVICE_STATUS    ', clc$nominal_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^display_batch_dev_status_commnd],
  {} ['DISPLAY_STATION_QUEUE_ENTRIES  ', clc$alias_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^display_station_q_entry_command],
  {} ['DISPLAY_STATION_QUEUE_ENTRY    ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^display_station_q_entry_command],
  {} ['DISPLAY_STATION_QUEUE_STATUS   ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^display_statn_q_status_command],
  {} ['DISPLAY_STATION_STATUS         ', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^display_station_status_command],
  {} ['DISSQE                         ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^display_station_q_entry_command],
  {} ['DISSQS                         ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^display_statn_q_status_command],
  {} ['DISSS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^display_station_status_command],
  {} ['END                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^quit_command],
  {} ['QUI                            ', clc$alias_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^quit_command],
  {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^quit_command]];

?? POP ??

?? NEWTITLE := '  abort_handler', EJECT ??

  PROCEDURE abort_handler (condition: pmt$condition;
        condition_descriptor: ^pmt$condition_information;
        save_area: ^ost$stack_frame_save_area;
    VAR handler_status: ost$status);

      end_connection (handler_status);
      handler_status.normal := TRUE;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    CONST
      display_prompt = 'diss',
      full_prompt = 'ops';

    VAR
      error_message: string (28 + 31), { length of error message + max name length
      error_message_length: integer,
      ignored_optimization_flag: boolean,
      station_device_count: INTEGER,
      station_index: INTEGER,
      station_list: ^avt$name_list,
      station_list_size: avt$name_list_size,
      station_usage: nft$io_station_usage,
      value: clt$value,
      local_status: ost$status;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, opes_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('STATION_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    station_name := value.name.value;

{ STATION_OPERATOR will be TRUE if OPERATE_STATION was called, else DISPLAY_STATION was called and
{ no further validation of the user's cability is necessary.

    IF station_operator AND NOT jmp$system_job () THEN

{ Check if the capability STATION_OPERATION is present in the user's validation. The presence of the
{ capability is only meaningful when a list of station names is not defined in the user's validation.

      avp$get_capability (avc$station_operation, avc$user, station_operator, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Check if a list of I/O station names is present in the user's validation.

      ALLOCATE station_list: [1..avc$maximum_name_list_size];

      station_list_size := 0;

      avp$get_name_value (avc$batch_io_station_list, avc$user, station_list^, station_list_size, status);
      IF status.normal THEN
        CASE station_list_size OF
        = 0 =
          station_operator := FALSE;

        = 1 =

{ The name values "ALL" and "NONE" are considered keywords if the name values are the only name
{ values in the list of I/O station names. A user can not be validated to operate a single I/O
{ station named "ALL" or a single station named "NONE".

          station_operator := ((station_list^ [1] = station_name) OR
                (station_list^ [1](1,5) = 'ALL  ')) AND
                (station_list^ [1](1,5) <> 'NONE ');

          IF NOT station_operator THEN
            IF (station_list^ [1](1,5) = 'NONE ') THEN
              osp$set_status_abnormal (nfc$status_id, nfe$sou_invalid_user, 'OPERATE_STATION', status);
            ELSE
              STRINGREP(error_message, error_message_length, 'OPERATE_STATION for station ',
                    station_name(1, clp$trimmed_string_size(station_name)) );
              osp$set_status_abnormal (nfc$status_id, nfe$sou_invalid_user, error_message(1,
                    error_message_length), status);
            IFEND;

            RETURN;
          IFEND;
        ELSE { The I/O station name list contains two or more station names.

          station_index :=1;
          station_operator := FALSE;

          WHILE (station_index <= station_list_size) AND (NOT station_operator) DO
            station_operator := (station_list^ [station_index] = station_name);
            station_index := station_index + 1;
          WHILEND;

          IF NOT station_operator THEN
            STRINGREP(error_message, error_message_length, 'OPERATE_STATION for station ',
                  station_name(1, clp$trimmed_string_size(station_name)) );
            osp$set_status_abnormal (nfc$status_id, nfe$sou_invalid_user, error_message(1,
                  error_message_length), status);
            RETURN;
          IFEND;

        CASEND;
      ELSEIF status.condition <> ave$unknown_field THEN

{ Return the error to the user. The AVE$UNKNONW_FIELD condition is ignored because the list of I/O station
{ names is an optional enhancement to OPES caller validation.

        RETURN;
      IFEND;

      FREE station_list;

      IF NOT station_operator THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sou_invalid_user, 'OPERATE_STATION', status);
        RETURN;
      IFEND;
    IFEND;

    ALLOCATE message: [[REP nfc$maximum_send_message_length OF cell]];

    local_status.normal := TRUE;
    connection_made := FALSE;
    network_file_open := FALSE;
    async_task_active := FALSE;
    operator_message_list := NIL;

    osp$establish_block_exit_hndlr (^abort_handler);

 /connect/
    BEGIN
      establish_connection (status);
      IF NOT status.normal THEN
        IF (status.condition = nae$invalid_directory_search_id) OR
              (status.condition = nfe$service_not_found) OR
              (status.condition = nae$directory_search_complete) THEN
          osp$set_status_abnormal (nfc$status_id, nfe$station_title_not_active,
                station_name, status);
        ELSEIF status.condition = nae$server_response_timeout THEN
          osp$set_status_condition ( nfe$sou_scfs_no_response,
                status);
        IFEND;
        EXIT /connect/;
      IFEND;

      IF station_operator THEN
        add_user (status);
        IF NOT status.normal THEN
          EXIT /connect/;
        IFEND;

        start_async_task (status);
        IF NOT status.normal THEN
          EXIT /connect/;
        IFEND;
      ELSE

{       Only allow DISPLAY_STATION for public I/O stations.

        ignored_optimization_flag := FALSE;
        get_station_status (station_device_count, station_usage, ignored_optimization_flag, status);
        IF (NOT status.normal) OR (station_usage <> nfc$public_io_station) THEN
          osp$set_status_abnormal (nfc$status_id, nfe$station_title_not_active, station_name, status);
          EXIT /connect/;
        IFEND;
      IFEND;

      IF station_operator THEN
        clp$push_utility (operator_utility_name, clc$global_command_search,
            station_operator_comnds, NIL, status);
      ELSE
        clp$push_utility (display_utility_name, clc$global_command_search,
            station_display_comnds, NIL, status);
      IFEND;
      IF NOT status.normal THEN
        EXIT /connect/;
      IFEND;

      IF station_operator THEN
        clp$scan_command_file (clc$current_command_input, operator_utility_name, full_prompt, status);
      ELSE
        clp$scan_command_file (clc$current_command_input, display_utility_name, display_prompt, status);
      IFEND;

      clp$pop_utility (local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    END /connect/;

    local_status.normal := TRUE;
    end_connection (local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;
    local_status.normal := TRUE;
    osp$disestablish_cond_handler;

  PROCEND nfp$operate_station;

?? TITLE := '  establish_connection', EJECT ??

{
{   Procedure to connect the Operator Utility with SCFS/VE
{   via CDCNET.
{

  PROCEDURE establish_connection (VAR status: ost$status);

    CONST
      connect_wait_time = 60*1000 {1 minute},
      title_trans_wait_time = 30*1000 {0.5 minute};

    VAR
      client: nat$application_name,
      client_id: ^nft$scfs_client_identifier,
      connect_attributes: ^nat$create_attributes,
      control_facility_name: ost$name,
      i: 0 .. 255,
      ready_index: integer,
      recurrent_search: boolean,
      search_id: nat$directory_search_identifier,
      server_address: nat$network_address,
      title: ^nat$title_pattern,
      translation_attributes: ^nat$translation_attributes,
      translation_status: ost$status,
      unique_name: ost$name,
      wait_list: ^ost$i_wait_list,
      wait_time: nat$wait_time;


    status.normal := TRUE;
    translation_status.normal := TRUE;

    PUSH title: [osc$max_name_size + 5];
    title^ (1, 5) := 'SCFS$';
    title^ (6, *) := station_name;

    client := 'OSA$STATION_OPERATOR';
    recurrent_search := TRUE;

    nap$begin_directory_search (title^, client, recurrent_search, search_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH wait_list: [1 .. 2];
    wait_list^[1].activity := nac$i_await_title_translation;
    wait_list^[1].translation_request := search_id;
    wait_list^[2].activity := osc$i_await_time;
    wait_list^[2].milliseconds := title_trans_wait_time;
    osp$i_await_activity_completion (wait_list^, ready_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF ready_index = 2 THEN

{   Timeout.
      osp$set_status_condition ( nfe$service_not_found,  status);
    ELSE

{   Title translation found.
      wait_time := 0;
      PUSH connect_attributes: [1 .. 1];
      connect_attributes^[1].kind := nac$connect_data;
      PUSH connect_attributes^[1].connect_data: [[REP nfc$opes_ve_client_length+1 OF CELL]];
      RESET connect_attributes^[1].connect_data;
      NEXT client_id: [nfc$opes_ve_client_length] IN connect_attributes^[1].connect_data;
      client_id^.data_version := nfc$scfs_client_data_version;
      client_id^.identifier := nfc$opes_ve_client;

{  Get all the addresses that correspond to the title translation.

    /process_address/
      REPEAT
        translation_attributes := NIL;

        nap$get_title_translation ( search_id, wait_time, translation_attributes, server_address,
              translation_status);

        IF translation_status.normal THEN
          pmp$get_unique_name (unique_name, status);
          IF status.normal THEN
            network_file := unique_name;
            nap$request_connection (server_address, client, network_file, nac$cdna_session,
                 connect_attributes, connect_wait_time, status);
            IF status.normal THEN
              nap$end_directory_search (search_id, status);
              EXIT /process_address/;
            IFEND;
          IFEND;
        IFEND;

      UNTIL (NOT translation_status.normal);

    IFEND;

    IF NOT translation_status.normal THEN
      status := translation_status;
    IFEND;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    connection_made := TRUE;
    fsp$open_file (network_file, amc$record, NIL, NIL, NIL, NIL, NIL, network_file_id, status);
    network_file_open := status.normal;

  PROCEND establish_connection;

?? TITLE := '  end_connection', EJECT ??

{
{   Procedure to terminate the Operator Utility connection
{   with SCFS/VE.
{

  PROCEDURE end_connection (VAR status: ost$status);

    VAR
      local_status: ost$status;


    local_status.normal := TRUE;
    IF async_task_active THEN
      end_async_task (status);
    IFEND;

    IF connection_made THEN
      IF network_file_open THEN
        fsp$close_file (network_file_id, local_status);
        IF status.normal AND NOT local_status.normal THEN
          status := local_status;
        IFEND;
        local_status.normal := TRUE;
        amp$return (network_file, local_status);
      IFEND;
      connection_made := FALSE;
    IFEND;

    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND end_connection;

?? TITLE := '  start_async_task', EJECT ??

{
{   Procedure to start up an asynchronous task to receive and process
{   unsolicited output from SCFS via CDCNET.  The main task will be
{   in control of the connection with SCFS while processing an Operator
{   Utility command; the asynchronous task will be in control at all
{   other times.  The purpose is to allow prompt reception and display
{   of messages from SCFS to the station operator.
{

  PROCEDURE start_async_task (VAR status: ost$status);

    CONST
      nfc$sou_async_task_name = 'nfp$sou_asynchronous_task';

    VAR
      intertask_request: nft$sou_intertask_request,
      program_name: pmt$program_name;


    program_name := nfc$sou_async_task_name;
    nfp$request_asynchronous_task (program_name, debug_mode, async_task_id, local_queue_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    async_task_active := TRUE;
    intertask_request.request := nfc$sou_start_task;
    intertask_request.file := network_file;
    send_intertask_request (intertask_request, status);

  PROCEND start_async_task;

?? TITLE := '  end_async_task', EJECT ??

{
{   Procedure to end the asynchronous task that was run to process
{   unsolicited output from SCFS.  A request is sent to the async task
{   telling it to clean up and drop out.  The async task will send a
{   'complete' response before it terminates.
{

  PROCEDURE end_async_task (VAR status: ost$status);

    VAR
      intertask_request: nft$sou_intertask_request,
      end_status: ost$status;


    end_status.normal := TRUE;
    intertask_request.request := nfc$sou_end_task;
    send_intertask_request (intertask_request, end_status);

    end_status.normal := TRUE;
    nfp$end_async_communication (FALSE, end_status);
    async_task_active := FALSE;

  PROCEND end_async_task;

?? TITLE := '  send_intertask_request', EJECT ??

{
{   The purpose of this procedure is to send a request to the
{   asynchronous task and wait for a response.
{

  PROCEDURE send_intertask_request (intertask_request: nft$sou_intertask_request;
    VAR status: ost$status);

    CONST
      it_response_wait_time = 60*1000 {1 minute};

    VAR
      wait_list: ^ost$i_wait_list,
      ready_index: INTEGER,
      ignore_status: ost$status,
      intertask_response: nft$sou_intertask_response;


    nfp$put_async_task_message (async_task_id, ^intertask_request, #SIZE (intertask_request), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH wait_list: [1 .. 2];
    wait_list^[1].activity := pmc$i_await_local_queue_message;
    wait_list^[1].qid := local_queue_id;
    wait_list^[2].activity := osc$i_await_time;
    wait_list^[2].milliseconds := it_response_wait_time;
    osp$i_await_activity_completion (wait_list^, ready_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF ready_index = 2 THEN  {timeout}
      osp$set_status_condition ( nfe$sou_async_task_no_response,  status);
      RETURN;
    ELSE  {message received}
      nfp$get_async_task_message (async_task_id, ^intertask_response, #SIZE (intertask_response), 0,
            transfer_count, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF transfer_count = 0 THEN
        osp$set_status_condition ( nfe$sou_async_task_no_response,  status);
      ELSEIF intertask_response.response <> nfc$sou_complete THEN
        osp$set_status_condition ( nfe$sou_invalid_intertask_resp,  status);
      IFEND;
    IFEND;

  PROCEND send_intertask_request;

?? TITLE := '  hold_async_task', EJECT ??

{
{   The purpose of this procedure is to request that the asynchronous
{   task temporarily stop communication with SCFS to allow the primary
{   task to do so.
{

  PROCEDURE hold_async_task (VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      intertask_request: nft$sou_intertask_request;


    intertask_request.request := nfc$sou_hold;
    send_intertask_request (intertask_request, status);
    IF NOT status.normal THEN
      osp$set_status_condition ( nae$connection_terminated,status);
      clp$end_scan_command_file (operator_utility_name,ignore_status);
    IFEND;

  PROCEND hold_async_task;

?? TITLE := '  resume_async_task', EJECT ??

{
{   The purpose of this procedure is to allow the asynchronous task to
{   resume communication with SCFS.
{

  PROCEDURE resume_async_task (VAR status: ost$status);

    VAR
      local_status: ost$status,
      intertask_request: nft$sou_intertask_request;


    local_status.normal := TRUE;
    status.normal := TRUE;
 /display_msg/
    WHILE operator_message_list <> NIL DO
      display_operator_message (status);
      IF NOT status.normal THEN
        EXIT /display_msg/;
      IFEND;
    WHILEND /display_msg/;

    intertask_request.request := nfc$sou_resume;
    send_intertask_request (intertask_request, local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND resume_async_task;

?? TITLE := '  send_scfs_message', EJECT ??

{
{   The purpose of this procedure is to send a message on connection
{   to SCFS and wait for a response.  If the expected response is not
{   received within a reasonable amount of time it will time out.
{

  PROCEDURE send_scfs_message (VAR status: ost$status);

    CONST
      pause_time = 500,     {1/2 second (milliseconds)}
      timeout_interval = 1*60*1000000;  {1 minute (microseconds)}

    VAR
      message_type_sent: nft$message_kind,
      message_received: BOOLEAN,
      time: INTEGER,
      end_time: INTEGER,
      ignore_status: ost$status;


    message_type_sent := message_type^;
    nfp$send_message_on_connection (message, message_length, network_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_microsecond_clock (time, ignore_status);
    end_time := time + timeout_interval;

 /get_response/
    BEGIN

   /wait_response/
      WHILE time < end_time DO
        get_network_message (message_received, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF NOT message_received THEN
          pmp$long_term_wait (pause_time, pause_time);
          pmp$get_microsecond_clock (time, ignore_status);
          CYCLE /wait_response/;
        IFEND;

        get_message_type;
        IF message_type^ = response_types [message_type_sent] THEN
          EXIT /get_response/;
        ELSEIF message_type^ = nfc$queue_entry_data THEN
          IF (message_type_sent = nfc$get_queue_entry_list) AND station_operator THEN

{ SCFS can reply to a Get_Queue_Entry_List message with a Get_Queue_Entry_List_Data message
{ as defined in the response type table, or SCFS can reply with a Get_Queue_Entry_Data
{ message instead.  This is done to reduce response time to the OPERATE_STATION command
{ "DISSQE ALL ALL".

            EXIT /get_response/;
          IFEND;
        ELSEIF message_type^ = nfc$device_status_data THEN
          IF (message_type_sent = nfc$get_station_status) THEN

{ SCFS can reply to a Get_Station_Status message with a Station_Status_Data message
{ as defined in the response type table, or SCFS can reply with a Device_Status_Data
{ message instead.  This is done to reduce response time to the OPERATE_STATION command
{ "DISBDS ALL ALL".

            EXIT /get_response/;
          IFEND;
        ELSEIF message_type^ = nfc$operator_message THEN
          queue_operator_message;
        IFEND;

      WHILEND /wait_response/;

      IF NOT message_received THEN
        osp$set_status_condition ( nfe$sou_scfs_no_response,
               status);
      IFEND;

    END /get_response/;

  PROCEND send_scfs_message;

?? TITLE := '  await_next_message', EJECT ??

{
{ The purpose of this procedure is to return the next non-operator message found on the
{ network.  The procedure will return an abnormal status if no such message is found within
{ the timeout period.
{

  PROCEDURE await_next_message (VAR status: ost$status);

    CONST
      pause_time = 500,     { 1/2 second in milliseconds }
      timeout_interval = 1*60*1000000;  { 1 minute in microseconds }

    VAR
      message_received: BOOLEAN,
      time: INTEGER,
      end_time: INTEGER,
      ignore_status: ost$status;

    pmp$get_microsecond_clock (time, ignore_status);
    end_time := time + timeout_interval;

 /get_next_response/
    BEGIN
   /wait_next_response/
      WHILE time < end_time DO
        get_network_message (message_received, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF NOT message_received THEN
          pmp$long_term_wait (pause_time, pause_time);
          pmp$get_microsecond_clock (time, ignore_status);
          CYCLE /wait_next_response/;
        IFEND;

        IF message_type^ = nfc$operator_message THEN
          queue_operator_message;
        ELSE
          EXIT /get_next_response/;
        IFEND;
      WHILEND /wait_next_response/;

      IF NOT message_received THEN
        osp$set_status_condition (nfe$sou_scfs_no_response, status);
      IFEND;

    END /get_next_response/;
  PROCEND await_next_message;

?? TITLE := '  get_network_message', EJECT ??

{
{   The purpose of this procedure is to get a the next message
{   from SCFS/VE from the network.
{

  PROCEDURE get_network_message (VAR message_received: BOOLEAN;
    VAR status: ost$status);

    CONST
      wait_time = 0;

    VAR
      data_area: ^nat$data_fragments,
      peer_operation: nat$se_peer_operation,
      activity_status: ost$activity_status;


    message_received := FALSE;
    nap$await_data_available (network_file_id, wait_time, wait_time, status);
    IF NOT status.normal THEN
      IF status.condition = nae$no_data_available THEN
        status.normal := TRUE;
      IFEND;
      RETURN;
    IFEND;

    PUSH data_area: [1 .. 1];
    data_area^ [1].address := message;
    data_area^ [1].length := #SIZE (message^);
    nap$se_receive_data (network_file_id, data_area^, osc$wait, peer_operation, activity_status, status);
    IF status.normal AND NOT activity_status.status.normal THEN
      status := activity_status.status;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF peer_operation.kind = nac$se_send_data THEN
      message_length := peer_operation.data_length;
      message_received := TRUE;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$sou_unexpected_network_req,
            peer_operations [peer_operation.kind], status);
    IFEND;

  PROCEND get_network_message;

?? TITLE := '  add_user', EJECT ??

{
{   Procedure to register the user with SCFS/VE as an I/O
{   station operator.
{

  PROCEDURE add_user (VAR status: ost$status);

*copy nft$add_user_msg

    VAR
      user_id: ost$user_identification,
      job_attributes: ^jmt$job_attribute_results,
      terminal_device_info: t$terminal_device_information,
      control_device_name: ost$name;


    control_device_name := osc$null_name;
    PUSH job_attributes: [1 .. 1];
    job_attributes^[1].key := jmc$job_input_device;
    PUSH job_attributes^ [1].job_input_device;
    jmp$get_job_attributes (job_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF job_attributes^[1].job_input_device^.size <> 0 THEN
      terminal_device_info.attr_data := job_attributes^[1].job_input_device^;
      control_device_name := terminal_device_info.acctg_data.acctg_record.device_name;
    IFEND;

    put_message_type (nfc$add_user);
    put_string_parameter ($INTEGER(nfc$station_or_control_facility), station_name);

    pmp$get_user_identification (user_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    put_string_parameter ($INTEGER(nfc$user_name), user_id.user);
    put_string_parameter ($INTEGER(nfc$family_name), user_id.family);
    IF control_device_name <> osc$null_name THEN
      put_string_parameter ($INTEGER(nfc$control_device_name), control_device_name);
    IFEND;
    put_null_parameter;
    send_scfs_message (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_user_response (status);

  PROCEND add_user;

?? TITLE := '  check_file_ownership', EJECT ??
{   Verify that the current user is allowed to get the status for an output
{   file.

  PROCEDURE check_file_ownership
   (    system_file_name: STRING (* <= osc$max_name_size);
    VAR status: ost$status);

    VAR
      output_name: jmt$name,
      number_of_outputs_found: jmt$output_status_count,
      status_options_p: ^jmt$output_status_options,
      status_results_p: ^jmt$output_status_results,
      work_area_p: ^jmt$work_area;

    status.normal := TRUE;

{   Attempt to get the output queue file's status.

    PUSH status_options_p: [1 .. 1];
    status_options_p^ [1].key := jmc$name_list;
    status_options_p^ [1].name_list := NIL;
    PUSH status_options_p^ [1].name_list: [1 .. 1];
    status_options_p^ [1].name_list^ [1].kind := jmc$system_supplied_name;
    status_options_p^ [1].name_list^ [1].system_supplied_name := system_file_name;
    work_area_p := NIL;
    jmp$get_output_status (status_options_p, {output_status_results_keys_p} NIL,
          work_area_p, status_results_p, number_of_outputs_found, status);

  PROCEND check_file_ownership;

?? TITLE := '  change_batch_device_attributes command', EJECT ??

  PROCEDURE change_batch_dev_attr_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copy nft$change_bd_attributes_msg

{
{  PDT chabda_pdt (
{    device_name, dn                      : name = $required
{    banner_highlight_field, bhf          : key comment_banner, cb, routing_banner, rb, site_banner, sb, ..
{                                               user_file_name, ufn, user_name, un = $optional
{    banner_page_count, bpc               : integer 0..3 = $optional
{    carriage_control_support, ccs        : key pre_print, post_print, both, b = $optional
{    code_set, cs                         : key ascii, ascii48, ascii64, ascii95, ascii128 = $optional
{    device_alias_1, da1                  : name or key none = $optional
{    device_alias_2, da2                  : name or key none = $optional
{    device_alias_3, da3                  : name or key none = $optional
{    external_characteristics_1, ec1      : string 0..6 = $optional
{    external_characteristics_2, ec2      : string 0..6 = $optional
{    external_characteristics_3, ec3      : string 0..6 = $optional
{    external_characteristics_4, ec4      : string 0..6 = $optional
{    file_acknowledgement, fa             : boolean = $optional
{    forms_code_1, fc1                    : string 0..6 = $optional
{    forms_code_2, fc2                    : string 0..6 = $optional
{    forms_code_3, fc3                    : string 0..6 = $optional
{    forms_code_4, fc4                    : string 0..6 = $optional
{    forms_size, fs                       : string 1..4 = $optional
{    maximum_file_size, mfs               : integer 0..99999999 = $optional
{    page_width, pw                       : integer 10..255 = $optional
{    terminal_model, tm                   : name = $optional
{    transmission_block_size, tbs         : integer 0..65535 = $optional
{    undefined_fe_action, ..
{    un_defined_fe_action, undfa, udfa    : key print_after_spacing, pas, print_before_spacing, pbs, ..
{                                               discard_print_line, dpl = $optional
{    unsupported_fe_action, ..
{    un_supported_fe_action, unsfa, usfa  : key print_after_spacing, pas, print_before_spacing, pbs, ..
{                                               discard_print_line, dpl = $optional
{    vertical_print_density, vpd          : key six_only, eight_only, six_any, eight_any = $optional
{    vfu_load_procedure, vlp              : name = $optional
{    status                               : var of status = $optional
{    )

?? PUSH (LISTEXT := ON) ??

  VAR
    chabda_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^chabda_pdt_names,
      ^chabda_pdt_params];

  VAR
    chabda_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 57] of
      clt$parameter_name_descriptor := [['DEVICE_NAME', 1], ['DN', 1], ['BANNER_HIGHLIGHT_FIELD', 2], ['BHF',
      2], ['BANNER_PAGE_COUNT', 3], ['BPC', 3], ['CARRIAGE_CONTROL_SUPPORT', 4], ['CCS', 4], ['CODE_SET', 5],
      ['CS', 5], ['DEVICE_ALIAS_1', 6], ['DA1', 6], ['DEVICE_ALIAS_2', 7], ['DA2', 7], ['DEVICE_ALIAS_3', 8],
      ['DA3', 8], ['EXTERNAL_CHARACTERISTICS_1', 9], ['EC1', 9], ['EXTERNAL_CHARACTERISTICS_2', 10], ['EC2',
      10], ['EXTERNAL_CHARACTERISTICS_3', 11], ['EC3', 11], ['EXTERNAL_CHARACTERISTICS_4', 12], ['EC4', 12], [
      'FILE_ACKNOWLEDGEMENT', 13], ['FA', 13], ['FORMS_CODE_1', 14], ['FC1', 14], ['FORMS_CODE_2', 15], ['FC2'
      , 15], ['FORMS_CODE_3', 16], ['FC3', 16], ['FORMS_CODE_4', 17], ['FC4', 17], ['FORMS_SIZE', 18], ['FS',
      18], ['MAXIMUM_FILE_SIZE', 19], ['MFS', 19], ['PAGE_WIDTH', 20], ['PW', 20], ['TERMINAL_MODEL', 21], [
      'TM', 21], ['TRANSMISSION_BLOCK_SIZE', 22], ['TBS', 22], ['UNDEFINED_FE_ACTION', 23], [
      'UN_DEFINED_FE_ACTION', 23], ['UNDFA', 23], ['UDFA', 23], ['UNSUPPORTED_FE_ACTION', 24], [
      'UN_SUPPORTED_FE_ACTION', 24], ['UNSFA', 24], ['USFA', 24], ['VERTICAL_PRINT_DENSITY', 25], ['VPD', 25]
      , ['VFU_LOAD_PROCEDURE', 26], ['VLP', 26], ['STATUS', 27]];

  VAR
    chabda_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 27] of clt$parameter_descriptor := [

{ DEVICE_NAME DN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ BANNER_HIGHLIGHT_FIELD BHF }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [^chabda_pdt_kv2, clc$keyword_value]],

{ BANNER_PAGE_COUNT BPC }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 3]],

{ CARRIAGE_CONTROL_SUPPORT CCS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [^chabda_pdt_kv4, clc$keyword_value]],

{ CODE_SET CS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [^chabda_pdt_kv5, clc$keyword_value]],

{ DEVICE_ALIAS_1 DA1 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [^chabda_pdt_kv6, clc$name_value, 1,
      osc$max_name_size]],

{ DEVICE_ALIAS_2 DA2 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [^chabda_pdt_kv7, clc$name_value, 1,
      osc$max_name_size]],

{ DEVICE_ALIAS_3 DA3 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [^chabda_pdt_kv8, clc$name_value, 1,
      osc$max_name_size]],

{ EXTERNAL_CHARACTERISTICS_1 EC1 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, 6]],

{ EXTERNAL_CHARACTERISTICS_2 EC2 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, 6]],

{ EXTERNAL_CHARACTERISTICS_3 EC3 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, 6]],

{ EXTERNAL_CHARACTERISTICS_4 EC4 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, 6]],

{ FILE_ACKNOWLEDGEMENT FA }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ FORMS_CODE_1 FC1 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, 6]],

{ FORMS_CODE_2 FC2 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, 6]],

{ FORMS_CODE_3 FC3 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, 6]],

{ FORMS_CODE_4 FC4 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, 6]],

{ FORMS_SIZE FS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 1, 4]],

{ MAXIMUM_FILE_SIZE MFS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 99999999]],

{ PAGE_WIDTH PW }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 10, 255]],

{ TERMINAL_MODEL TM }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ TRANSMISSION_BLOCK_SIZE TBS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 65535]],

{ UNDEFINED_FE_ACTION UN_DEFINED_FE_ACTION UNDFA UDFA }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [^chabda_pdt_kv23, clc$keyword_value]],

{ UNSUPPORTED_FE_ACTION UN_SUPPORTED_FE_ACTION UNSFA USFA }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [^chabda_pdt_kv24, clc$keyword_value]],

{ VERTICAL_PRINT_DENSITY VPD }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [^chabda_pdt_kv25, clc$keyword_value]],

{ VFU_LOAD_PROCEDURE VLP }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    chabda_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 10] of ost$name := [
      'COMMENT_BANNER','CB','ROUTING_BANNER','RB','SITE_BANNER','SB','USER_FILE_NAME','UFN','USER_NAME','UN'];

  VAR
    chabda_pdt_kv4: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := ['PRE_PRINT',
      'POST_PRINT','BOTH','B'];

  VAR
    chabda_pdt_kv5: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of ost$name := ['ASCII',
      'ASCII48','ASCII64','ASCII95','ASCII128'];

  VAR
    chabda_pdt_kv6: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['NONE'];

  VAR
    chabda_pdt_kv7: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['NONE'];

  VAR
    chabda_pdt_kv8: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['NONE'];

  VAR
    chabda_pdt_kv23: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of ost$name := [
      'PRINT_AFTER_SPACING','PAS','PRINT_BEFORE_SPACING','PBS','DISCARD_PRINT_LINE','DPL'];

  VAR
    chabda_pdt_kv24: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of ost$name := [
      'PRINT_AFTER_SPACING','PAS','PRINT_BEFORE_SPACING','PBS','DISCARD_PRINT_LINE','DPL'];

  VAR
    chabda_pdt_kv25: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := ['SIX_ONLY',
      'EIGHT_ONLY','SIX_ANY','EIGHT_ANY'];

?? POP ??

    TYPE
      longreal_conversion = record
        real_word1: real,
        real_word2: real,
      recend;

    VAR
      converted_device_forms_size: longreal_conversion,
      device_forms_size: clt$real,
      divisor: [STATIC] real := 0.5,
      real_forms_size: real,
      value: clt$value,
      code_set: nft$code_set,
      device_name: ost$name,
      banner_page_count: nft$banner_page_count,
      banner_highlight_field: nft$banner_highlight_field,
      carriage_control_action: nft$carriage_control_action,
      device_alias: ost$name,
      external_characteristics: nft$external_characteristics,
      file_acknowledge: BOOLEAN,
      forms_code: nft$forms_code,
      forms_size: nft$forms_size,
      maximum_file_size: nft$device_file_size,
      page_width: nft$page_width,
      str_value: string (80),
      terminal_model: nft$terminal_model,
      transmission_block_size: nft$transmit_block_size,
      undefined_fe_action: nft$format_effector_actions,
      unsupported_fe_action: nft$format_effector_actions,
      vertical_print_density: nft$vertical_print_density,
      vfu_load_procedure: nft$vfu_load_procedure,
      local_status: ost$status;

    clp$scan_parameter_list (parameter_list, chabda_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    put_message_type (nfc$change_batch_device_attr);
    put_string_parameter ($INTEGER(nfc$io_station_name), station_name);

    clp$get_value ('DEVICE_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    device_name := value.name.value;
    put_string_parameter ($INTEGER(nfc$device_name), device_name);

    clp$get_value ('BANNER_HIGHLIGHT_FIELD', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      IF (value.name.value = 'COMMENT_BANNER') OR (value.name.value = 'CB') THEN
        banner_highlight_field := nfc$comment_banner;
      ELSEIF (value.name.value = 'ROUTING_BANNER') OR (value.name.value = 'RB') THEN
        banner_highlight_field := nfc$routing_banner;
      ELSEIF (value.name.value = 'SITE_BANNER') OR (value.name.value = 'SB') THEN
        banner_highlight_field := nfc$site_banner;
      ELSEIF (value.name.value = 'USER_FILE_NAME') OR (value.name.value = 'UFN') THEN
        banner_highlight_field := nfc$user_file_name;
      ELSE
        banner_highlight_field := nfc$user_name;
      IFEND;
      put_parameter ($INTEGER(nfc$banner_highlight_field), ^banner_highlight_field,
            #SIZE(banner_highlight_field));
    IFEND;

    clp$get_value ('BANNER_PAGE_COUNT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      banner_page_count := value.int.value;
      put_parameter ($INTEGER(nfc$banner_page_count), ^banner_page_count, #SIZE(banner_page_count));
    IFEND;

    clp$get_value ('CARRIAGE_CONTROL_SUPPORT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      IF value.name.value = 'PRE_PRINT' THEN
        carriage_control_action := nfc$pre_print;
      ELSEIF value.name.value = 'POST_PRINT' THEN
        carriage_control_action := nfc$post_print;
      ELSE
        carriage_control_action := nfc$pre_and_post_print;
      IFEND;
      put_parameter ($INTEGER(nfc$carriage_control_action), ^carriage_control_action,
            #SIZE(carriage_control_action));
    IFEND;

    clp$get_value ('CODE_SET', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      IF value.name.value = 'ASCII' THEN
        code_set := nfc$ascii;
      ELSEIF value.name.value = 'ASCII48' THEN
        code_set := nfc$ascii_48;
      ELSEIF value.name.value = 'ASCII64' THEN
        code_set := nfc$ascii_64;
      ELSEIF value.name.value = 'ASCII95' THEN
        code_set := nfc$ascii_95;
      ELSEIF value.name.value = 'ASCII128' THEN
        code_set := nfc$ascii_128;
      IFEND;
      put_parameter ($INTEGER(nfc$code_set), ^code_set, #SIZE(code_set));
    IFEND;

    clp$get_value ('VERTICAL_PRINT_DENSITY', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      IF (value.name.value = 'SIX_ONLY') THEN
        vertical_print_density := nfc$six_only;
      ELSEIF (value.name.value = 'EIGHT_ONLY') THEN
        vertical_print_density := nfc$eight_only;
      ELSEIF (value.name.value = 'SIX_ANY') THEN
        vertical_print_density := nfc$six_any;
      ELSEIF (value.name.value = 'EIGHT_ANY') THEN
        vertical_print_density := nfc$eight_any;
      IFEND;
      put_parameter ($INTEGER(nfc$vertical_print_density), ^vertical_print_density,
            #SIZE(vertical_print_density));
    IFEND;


    clp$get_value ('DEVICE_ALIAS_1', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      IF value.name.value = 'NONE' THEN
        device_alias := ' ';
      ELSE
        device_alias := value.name.value;
      IFEND;
      put_string_parameter ($INTEGER(nfc$device_alias_1), device_alias);
    IFEND;

    clp$get_value ('DEVICE_ALIAS_2', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      IF value.name.value = 'NONE' THEN
        device_alias := ' ';
      ELSE
        device_alias := value.name.value;
      IFEND;
      put_string_parameter ($INTEGER(nfc$device_alias_2), device_alias);
    IFEND;

    clp$get_value ('DEVICE_ALIAS_3', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      IF value.name.value = 'NONE' THEN
        device_alias := ' ';
      ELSE
        device_alias := value.name.value;
      IFEND;
      put_string_parameter ($INTEGER(nfc$device_alias_3), device_alias);
    IFEND;

    clp$get_value ('EXTERNAL_CHARACTERISTICS_1', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      external_characteristics := value.str.value;
      put_string_parameter ($INTEGER(nfc$external_characteristics_1), external_characteristics);
    IFEND;

    clp$get_value ('EXTERNAL_CHARACTERISTICS_2', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      external_characteristics := value.str.value;
      put_string_parameter ($INTEGER(nfc$external_characteristics_2), external_characteristics);
    IFEND;

    clp$get_value ('EXTERNAL_CHARACTERISTICS_3', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      external_characteristics := value.str.value;
      put_string_parameter ($INTEGER(nfc$external_characteristics_3), external_characteristics);
    IFEND;

    clp$get_value ('EXTERNAL_CHARACTERISTICS_4', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      external_characteristics := value.str.value;
      put_string_parameter ($INTEGER(nfc$external_characteristics_4), external_characteristics);
    IFEND;

    clp$get_value ('FILE_ACKNOWLEDGEMENT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      file_acknowledge := value.bool.value;
      put_parameter ($INTEGER(nfc$file_acknowledge), ^file_acknowledge, #SIZE(file_acknowledge));
    IFEND;

    clp$get_value ('FORMS_CODE_1', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      forms_code := value.str.value;
      put_string_parameter ($INTEGER(nfc$forms_code_1), forms_code);
    IFEND;

    clp$get_value ('FORMS_CODE_2', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      forms_code := value.str.value;
      put_string_parameter ($INTEGER(nfc$forms_code_2), forms_code);
    IFEND;

    clp$get_value ('FORMS_CODE_3', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      forms_code := value.str.value;
      put_string_parameter ($INTEGER(nfc$forms_code_3), forms_code);
    IFEND;

    clp$get_value ('FORMS_CODE_4', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      forms_code := value.str.value;
      put_string_parameter ($INTEGER(nfc$forms_code_4), forms_code);
    IFEND;

    clp$get_value ('FORMS_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      clp$convert_string_to_real (value.str.value, device_forms_size, status);
      IF status.normal THEN
        #UNCHECKED_CONVERSION(device_forms_size.value , converted_device_forms_size);
        real_forms_size := converted_device_forms_size.real_word1;

{  Check that the forms size value is within the range allowed.  }

        IF ((real_forms_size*2.0) >= $REAL (nfc$min_forms_size)) AND
              ((real_forms_size*2.0) <= $REAL (nfc$max_forms_size)) THEN

{  Check that the forms size value is a multiple of 1/2.  }

          IF $REAL ($INTEGER (real_forms_size/divisor)) = (real_forms_size/divisor) THEN
            forms_size := $INTEGER (real_forms_size*2.0);
            put_parameter ($INTEGER(nfc$forms_size), ^forms_size, #SIZE(forms_size));
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$sou_command_reject,
                  'CHANGE_BATCH_DEVICE_ATTRIBUTES', status);
            str_value (1, value.str.size) := value.str.value;
            str_value (1+value.str.size, 25) := ' is not a multiple of 1/2';
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  str_value (1, value.str.size+25), status);
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$sou_command_reject,
                'CHANGE_BATCH_DEVICE_ATTRIBUTES', status);
          str_value (1, value.str.size) := value.str.value;
          str_value (1+value.str.size, 39) := ' is outside range supported (.5 - 31.0)';
          osp$append_status_parameter (osc$status_parameter_delimiter,
                str_value (1, value.str.size+39), status);
          RETURN;
        IFEND;
      ELSE;
        RETURN;
      IFEND;
    IFEND;

    clp$get_value ('MAXIMUM_FILE_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      maximum_file_size := value.int.value;
      put_parameter ($INTEGER(nfc$maximum_file_size), ^maximum_file_size, #SIZE(maximum_file_size));
    IFEND;

    clp$get_value ('PAGE_WIDTH', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      page_width := value.int.value;
      put_parameter ($INTEGER(nfc$page_width), ^page_width, #SIZE(page_width));
    IFEND;

    clp$get_value ('TERMINAL_MODEL', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      terminal_model := value.name.value;
      put_string_parameter ($INTEGER(nfc$terminal_model), terminal_model);
    IFEND;

    clp$get_value ('TRANSMISSION_BLOCK_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      transmission_block_size := value.int.value;
      put_parameter ($INTEGER(nfc$transmission_block_size), ^transmission_block_size,
            #SIZE(transmission_block_size));
    IFEND;

    clp$get_value ('UNDEFINED_FE_ACTION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      IF (value.name.value = 'PAS') OR (value.name.value = 'PRINT_AFTER_SPACING') THEN
        undefined_fe_action := nfc$print_after_spacing;
      ELSEIF (value.name.value = 'PBS') OR (value.name.value = 'PRINT_BEFORE_SPACING') THEN
        undefined_fe_action := nfc$print_before_spacing;
      ELSEIF (value.name.value = 'DPL') OR (value.name.value = 'DISCARD_PRINT_LINE') THEN
        undefined_fe_action := nfc$discard_print_line;
      IFEND;
      put_parameter ($INTEGER(nfc$undefined_fe_action), ^undefined_fe_action, #SIZE(undefined_fe_action));
    IFEND;

    clp$get_value ('UNSUPPORTED_FE_ACTION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      IF (value.name.value = 'PAS') OR (value.name.value = 'PRINT_AFTER_SPACING') THEN
        unsupported_fe_action := nfc$print_after_spacing;
      ELSEIF (value.name.value = 'PBS') OR (value.name.value = 'PRINT_BEFORE_SPACING') THEN
        unsupported_fe_action := nfc$print_before_spacing;
      ELSEIF (value.name.value = 'DPL') OR (value.name.value = 'DISCARD_PRINT_LINE') THEN
        unsupported_fe_action := nfc$discard_print_line;
      IFEND;
      put_parameter ($INTEGER(nfc$unsupported_fe_action), ^unsupported_fe_action,
            #SIZE(unsupported_fe_action));
    IFEND;

    clp$get_value ('VFU_LOAD_PROCEDURE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      vfu_load_procedure := value.name.value;
      put_string_parameter ($INTEGER(nfc$vfu_load_procedure), vfu_load_procedure);
    IFEND;

    put_null_parameter;

    hold_async_task (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

 /send_msg/
    BEGIN
      send_scfs_message (status);
      IF NOT status.normal THEN
        EXIT /send_msg/;
      IFEND;
      local_status.normal := TRUE;
      change_dev_attributes_response (local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;
    END /send_msg/;

    local_status.normal := TRUE;
    resume_async_task (local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND change_batch_dev_attr_command;

?? TITLE := '  position_file command', EJECT ??

  PROCEDURE position_file_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  CONST
    maximum_int_location = 65535,
    maximum_str_location = osc$max_string_size;

{ PDT posf_pdt (
{   device_name, dn       : name = $required
{   location, l           : list 1..2 of any = 1
{   units, u              : key lines, line, l, pages, page, p = page
{   direction, d          : key forward, f, backward, back, b = backward
{   starting_position, sp : key beginning, b, end, e, last_line_printed, llp = last_line_printed
{   preview, pv, p        : integer 1..10 = $optional
{   status                : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    posf_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^posf_pdt_names, ^posf_pdt_params];

  VAR
    posf_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 14] of
      clt$parameter_name_descriptor := [['DEVICE_NAME', 1], ['DN', 1], ['LOCATION', 2], ['L', 2], ['UNITS', 3]
      , ['U', 3], ['DIRECTION', 4], ['D', 4], ['STARTING_POSITION', 5], ['SP', 5], ['PREVIEW', 6], ['PV', 6],
      ['P', 6], ['STATUS', 7]];

  VAR
    posf_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 7] of clt$parameter_descriptor := [

{ DEVICE_NAME DN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ LOCATION L }
    [[clc$optional_with_default, ^posf_pdt_dv2], 1, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$any_value
      ]],

{ UNITS U }
    [[clc$optional_with_default, ^posf_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [^posf_pdt_kv3,
      clc$keyword_value]],

{ DIRECTION D }
    [[clc$optional_with_default, ^posf_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [^posf_pdt_kv4,
      clc$keyword_value]],

{ STARTING_POSITION SP }
    [[clc$optional_with_default, ^posf_pdt_dv5], 1, 1, 1, 1, clc$value_range_not_allowed, [^posf_pdt_kv5,
      clc$keyword_value]],

{ PREVIEW PV P }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 1, 10]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    posf_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of ost$name := ['LINES','LINE','L'
      ,'PAGES','PAGE','P'];

  VAR
    posf_pdt_kv4: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of ost$name := ['FORWARD','F',
      'BACKWARD','BACK','B'];

  VAR
    posf_pdt_kv5: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of ost$name := ['BEGINNING','B',
      'END','E','LAST_LINE_PRINTED','LLP'];

  VAR
    posf_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '1';

  VAR
    posf_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'page';

  VAR
    posf_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (8) := 'backward';

  VAR
    posf_pdt_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (17) := 'last_line_printed';

?? POP ??

*copy nft$position_file_msg

    VAR
      device_name: ost$name,
      direction: nft$position_file_direction,
      i: 1 .. clc$max_value_sets,
      int: integer,
      local_status: ost$status,
      location_integer: nft$position_file_locate_count,
      location_string_1: STRING (nfc$posf_max_string_length),
      location_string_2: STRING (nfc$posf_max_string_length),
      loc_value_1: clt$value,
      loc_value_2: clt$value,
      preview_line_count: nft$position_file_preview_count,
      set_count: 0 .. clc$max_value_sets,
      starting_position: nft$position_file_from_position,
      units: nft$position_file_units,
      value: clt$value,
      value_1: clt$value,
      value_2: clt$value,
      variable: clt$variable_reference;


    PROCEDURE convert_variable_to_value (variable: clt$variable_reference;
          VAR  value: clt$value;
          VAR status: ost$status);

      VAR
        string_pointer: ^ost$string;

      IF variable.upper_bound <> variable.lower_bound THEN
        osp$set_status_condition ( nfe$invalid_value_for_location,  status);
        RETURN;
      IFEND;

      CASE variable.value.kind OF

      = clc$integer_value =
        value.kind := clc$integer_value;
        value.int.value := variable.value.integer_value^ [1].value;

      = clc$string_value =
        value.kind := clc$string_value;
        string_pointer := #LOC (variable.value.string_value^ [1]);
        value.str.size := string_pointer^.size;
        value.str.value := string_pointer^.value (1, value.str.size);

      = clc$boolean_value, clc$status_value, clc$real_value =
        osp$set_status_condition ( nfe$invalid_value_for_location,  status);
        RETURN;

      CASEND;

    PROCEND convert_variable_to_value;


    clp$scan_parameter_list (parameter_list, posf_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    put_message_type (nfc$position_file_sou);
    put_string_parameter ($INTEGER(nfc$io_station_name), station_name);

    clp$get_value ('DEVICE_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    device_name := value.name.value;
    put_string_parameter ($INTEGER(nfc$device_name), device_name);

{  The following code will get the 'location' parameter for the position_file command.  }
{  The checking is necessary until an scl parameter definition of the following is      }
{  supported:  location, l: integer 0..65536 or list 1..2 of string 1..255              }
{  This type of declaration will be supported at R1.3.1.                                }

    clp$get_set_count ('LOCATION', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO set_count DO
      clp$get_value ('LOCATION', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      ELSEIF i=1 THEN
        value_1 := value;
      ELSE
        value_2 := value;
      IFEND;
    FOREND;

    CASE value_1.kind OF

    = clc$integer_value, clc$string_value =
      loc_value_1 := value_1;

    = clc$name_value =
      clp$read_variable (value_1.name.value, variable, status);
      IF status.normal THEN
        convert_variable_to_value (variable, loc_value_1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSEIF status.condition = cle$unknown_variable THEN
        RETURN;
      IFEND;

    = clc$variable_reference =
      convert_variable_to_value (value_1.var_ref, loc_value_1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    ELSE  { reject all other value kinds }
      osp$set_status_condition ( nfe$invalid_value_for_location,  status);
      RETURN;

    CASEND;

    IF set_count = 2 THEN  { pick up second value }
      CASE value_2.kind OF

      = clc$integer_value, clc$string_value =
        loc_value_2 := value_2;

      = clc$name_value =
        clp$read_variable (value_2.name.value, variable, status);
        IF status.normal THEN
          convert_variable_to_value (variable, loc_value_2, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSEIF status.condition = cle$unknown_variable THEN
          RETURN;
        IFEND;

      = clc$variable_reference =
        convert_variable_to_value (value_2.var_ref, loc_value_2, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = clc$real_value, clc$boolean_value, clc$status_value =
        osp$set_status_condition ( nfe$invalid_value_for_location,  status);
        RETURN;

      CASEND;
    IFEND;
    IF set_count = 1 THEN
      IF loc_value_1.kind = clc$integer_value THEN
        int := loc_value_1.int.value;
        IF (int >= 0) AND (int <= maximum_int_location) THEN
          location_integer := int;
          put_parameter ($INTEGER(nfc$location_integer), ^location_integer, #SIZE(location_integer));
        ELSE
          osp$set_status_condition ( nfe$invalid_value_for_location,  status);
          RETURN;
        IFEND;
      ELSEIF loc_value_1.kind = clc$string_value THEN
        location_string_1 := loc_value_1.str.value;
        IF (strlength(location_string_1) > 0) AND (strlength(location_string_1) < maximum_str_location) THEN
          put_string_parameter ($INTEGER(nfc$location_string_1), location_string_1);
        ELSE
          osp$set_status_condition ( nfe$invalid_value_for_location,  status);
          RETURN;
        IFEND;
      IFEND;
    ELSEIF set_count = 2 THEN
      IF (loc_value_1.kind = clc$string_value) AND (loc_value_2.kind = clc$string_value) THEN
        location_string_1 := loc_value_1.str.value;
        location_string_2 := loc_value_2.str.value;
        IF ((strlength(location_string_1) > 0) AND (strlength(location_string_1) < maximum_str_location)) AND
           ((strlength(location_string_2) > 0) AND (strlength(location_string_2) < maximum_str_location)) THEN
          put_string_parameter ($INTEGER(nfc$location_string_1), location_string_1);
          put_string_parameter ($INTEGER(nfc$location_string_2), location_string_2);
        ELSE
          osp$set_status_condition ( nfe$invalid_value_for_location,  status);
          RETURN;
        IFEND;
      ELSE
        osp$set_status_condition ( nfe$invalid_value_for_location,  status);
        RETURN;
      IFEND;
    IFEND;

    clp$get_value ('UNITS', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (value.name.value = 'LINES') OR (value.name.value = 'LINE') OR (value.name.value = 'L') THEN
      units := nfc$position_file_line;
    ELSE {'PAGES'/'PAGE'/'P'}
      units := nfc$position_file_page;
    IFEND;
    put_parameter ($INTEGER(nfc$units), ^units, #SIZE(units));

    clp$get_value ('DIRECTION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (value.name.value = 'FORWARD') OR (value.name.value = 'F') THEN
      direction := nfc$position_file_forwards;
    ELSE {'PAGES'/'PAGE'/'P'}
      direction := nfc$position_file_backwards;
    IFEND;
    put_parameter ($INTEGER(nfc$direction), ^direction, #SIZE(direction));

    clp$get_value ('STARTING_POSITION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (value.name.value = 'BEGINNING') OR (value.name.value = 'B') THEN
      starting_position := nfc$beginning_of_file;
    ELSEIF (value.name.value = 'END') OR (value.name.value = 'E') THEN
      starting_position := nfc$end_of_file;
    ELSE {'LAST_LINE_PRINTED'/'LLP'}
      starting_position := nfc$last_line_printed;
    IFEND;
    put_parameter ($INTEGER(nfc$starting_position), ^starting_position, #SIZE(starting_position));

    clp$get_value ('PREVIEW', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      preview_line_count := value.int.value;
      put_parameter ($INTEGER(nfc$preview_line_count), ^preview_line_count, #SIZE(preview_line_count));
    IFEND;

    put_null_parameter;

    hold_async_task (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

 /send_msg/
    BEGIN
      send_scfs_message (status);
      IF NOT status.normal THEN
        EXIT /send_msg/;
      IFEND;
      local_status.normal := TRUE;
      device_control_response (nfc$position_file_resp, local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;
    END /send_msg/;

    local_status.normal := TRUE;
    resume_async_task (local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND position_file_command;

?? TITLE := '  suppress_carriage_control command', EJECT ??

  PROCEDURE suppress_carriage_ctrl_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT supcc_pdt (
{   device_name, dn : NAME = $REQUIRED
{   STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    supcc_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^supcc_pdt_names, ^supcc_pdt_params
      ];

  VAR
    supcc_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['DEVICE_NAME', 1], ['DN', 1], ['STATUS', 2]];

  VAR
    supcc_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ DEVICE_NAME DN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
*copy nft$suppress_carriage_cntrl_msg

    VAR
      local_status: ost$status,
      value: clt$value,
      device_name: ost$name,
      suppress_format_control: nft$suppress_carriage_control;


    clp$scan_parameter_list (parameter_list, supcc_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    put_message_type (nfc$suppress_carriage_control);
    put_string_parameter ($INTEGER(nfc$io_station_name), station_name);

    clp$get_value ('DEVICE_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    device_name := value.name.value;
    put_string_parameter ($INTEGER(nfc$device_name), device_name);

    suppress_format_control := TRUE;
    put_parameter ($INTEGER(nfc$suppress_format_control), ^suppress_format_control,
          #SIZE (suppress_format_control));

    put_null_parameter;

    hold_async_task (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

 /send_msg/
    BEGIN
      send_scfs_message (status);
      IF NOT status.normal THEN
        EXIT /send_msg/;
      IFEND;
      local_status.normal := TRUE;
      device_control_response (nfc$suppress_carriage_cntrl_rsp, local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;
    END /send_msg/;

    local_status.normal := TRUE;
    resume_async_task (local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND suppress_carriage_ctrl_command;

?? TITLE := '  terminate_transfer command', EJECT ??

  PROCEDURE terminate_transfer_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT tert_pdt (
{   device_name, dn : NAME = $REQUIRED
{   file_disposition, fd : KEY requeue, r, drop, d, hold, h = drop
{   STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    tert_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^tert_pdt_names, ^tert_pdt_params];

  VAR
    tert_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['DEVICE_NAME', 1], ['DN', 1], ['FILE_DISPOSITION', 2], ['FD', 2], [
      'STATUS', 3]];

  VAR
    tert_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ DEVICE_NAME DN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ FILE_DISPOSITION FD }
    [[clc$optional_with_default, ^tert_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [^tert_pdt_kv2,
      clc$keyword_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    tert_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of ost$name := ['REQUEUE','R',
      'DROP','D','HOLD','H'];

  VAR
    tert_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'drop';

?? POP ??
*copy nft$terminate_transfer_msg

    VAR
      local_status: ost$status,
      value: clt$value,
      device_name: ost$name,
      file_disposition: nft$file_disposition;


    clp$scan_parameter_list (parameter_list, tert_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    put_message_type (nfc$terminate_transfer);
    put_string_parameter ($INTEGER(nfc$io_station_name), station_name);

    clp$get_value ('DEVICE_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    device_name := value.name.value;
    put_string_parameter ($INTEGER(nfc$device_name), device_name);

    clp$get_value ('FILE_DISPOSITION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (value.name.value = 'HOLD') OR (value.name.value = 'H') THEN
      file_disposition := nfc$hold_file_in_q;
    ELSEIF (value.name.value = 'REQUEUE') OR (value.name.value = 'R') THEN
      file_disposition := nfc$requeue_file;
    ELSE {'DROP'/'D'}
      file_disposition := nfc$drop_file_from_q;
    IFEND;
    put_parameter ($INTEGER(nfc$file_disposition), ^file_disposition, #SIZE(file_disposition));

    put_null_parameter;

    hold_async_task (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

 /send_msg/
    BEGIN
      send_scfs_message (status);
      IF NOT status.normal THEN
        EXIT /send_msg/;
      IFEND;
      local_status.normal := TRUE;
      device_control_response (nfc$terminate_transfer_resp, local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;
    END /send_msg/;

    local_status.normal := TRUE;
    resume_async_task (local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND terminate_transfer_command;

?? TITLE := '  stop_batch_device command', EJECT ??

  PROCEDURE stop_batch_device_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT stobd_pdt (
{   device_name, dn : NAME = $REQUIRED
{   file_disposition, fd : KEY requeue, r, drop, d, hold, h, finish, f, suspend, s = suspend
{   STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    stobd_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^stobd_pdt_names, ^stobd_pdt_params
      ];

  VAR
    stobd_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['DEVICE_NAME', 1], ['DN', 1], ['FILE_DISPOSITION', 2], ['FD', 2], [
      'STATUS', 3]];

  VAR
    stobd_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ DEVICE_NAME DN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ FILE_DISPOSITION FD }
    [[clc$optional_with_default, ^stobd_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [^stobd_pdt_kv2,
      clc$keyword_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    stobd_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 10] of ost$name := ['REQUEUE','R',
      'DROP','D','HOLD','H','FINISH','F','SUSPEND','S'];

  VAR
    stobd_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := 'suspend';

?? POP ??
*copy nft$stop_batch_device_msg

    VAR
      local_status: ost$status,
      value: clt$value,
      device_name: ost$name,
      file_disposition: nft$file_disposition;


    clp$scan_parameter_list (parameter_list, stobd_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    put_message_type (nfc$stop_batch_device);
    put_string_parameter ($INTEGER(nfc$io_station_name), station_name);

    clp$get_value ('DEVICE_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    device_name := value.name.value;
    put_string_parameter ($INTEGER(nfc$device_name), device_name);

    clp$get_value ('FILE_DISPOSITION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (value.name.value = 'HOLD') OR (value.name.value = 'H') THEN
      file_disposition := nfc$hold_file_in_q;
    ELSEIF (value.name.value = 'REQUEUE') OR (value.name.value = 'R') THEN
      file_disposition := nfc$requeue_file;
    ELSEIF (value.name.value = 'DROP') OR (value.name.value = 'D') THEN
      file_disposition := nfc$drop_file_from_q;
    ELSEIF (value.name.value = 'FINISH') OR (value.name.value = 'F') THEN
      file_disposition := nfc$complete_file;
    ELSE {'SUSPEND'/'S'}
      file_disposition := nfc$maintain_file_position;
    IFEND;
    put_parameter ($INTEGER(nfc$file_disposition), ^file_disposition, #SIZE(file_disposition));

    put_null_parameter;

    hold_async_task (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

 /send_msg/
    BEGIN
      send_scfs_message (status);
      IF NOT status.normal THEN
        EXIT /send_msg/;
      IFEND;
      local_status.normal := TRUE;
      device_control_response (nfc$stop_batch_device_resp, local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;
    END /send_msg/;

    local_status.normal := TRUE;
    resume_async_task (local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND stop_batch_device_command;

?? TITLE := '  start_batch_device command', EJECT ??

  PROCEDURE start_batch_device_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT stabd_pdt (
{   device_name, dn : NAME = $REQUIRED
{   STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    stabd_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^stabd_pdt_names, ^stabd_pdt_params
      ];

  VAR
    stabd_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['DEVICE_NAME', 1], ['DN', 1], ['STATUS', 2]];

  VAR
    stabd_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ DEVICE_NAME DN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
*copy nft$start_batch_device_msg

    VAR
      local_status: ost$status,
      value: clt$value,
      device_name: ost$name;


    clp$scan_parameter_list (parameter_list, stabd_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    put_message_type (nfc$start_batch_device);
    put_string_parameter ($INTEGER(nfc$io_station_name), station_name);

    clp$get_value ('DEVICE_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    device_name := value.name.value;
    put_string_parameter ($INTEGER(nfc$device_name), device_name);

    put_null_parameter;

    hold_async_task (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

 /send_msg/
    BEGIN
      send_scfs_message (status);
      IF NOT status.normal THEN
        EXIT /send_msg/;
      IFEND;
      local_status.normal := TRUE;
      device_control_response (nfc$start_batch_device_resp, local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;
    END /send_msg/;

    local_status.normal := TRUE;
    resume_async_task (local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND start_batch_device_command;

?? TITLE := '  select_file command', EJECT ??

  PROCEDURE select_file_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT self_pdt (
{   name, n : NAME = $REQUIRED
{   device_name, dn : NAME = $OPTIONAL
{   STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    self_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^self_pdt_names, ^self_pdt_params];

  VAR
    self_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['NAME', 1], ['N', 1], ['DEVICE_NAME', 2], ['DN', 2], ['STATUS', 3]];

  VAR
    self_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ NAME N }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ DEVICE_NAME DN }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
*copy nft$select_file_msg

    VAR
      local_status: ost$status,
      value: clt$value,
      system_file_name: ost$name,
      device_name: ost$name;


    clp$scan_parameter_list (parameter_list, self_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    put_message_type (nfc$select_file);
    put_string_parameter ($INTEGER(nfc$io_station_name), station_name);

    clp$get_value ('NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    system_file_name := value.name.value;
    put_string_parameter ($INTEGER(nfc$system_file_name), system_file_name);

    clp$get_value ('DEVICE_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      device_name := value.name.value;
    put_string_parameter ($INTEGER(nfc$device_name), device_name);
    IFEND;

    put_null_parameter;

    hold_async_task (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

 /send_msg/
    BEGIN
      send_scfs_message (status);
      IF NOT status.normal THEN
        EXIT /send_msg/;
      IFEND;
      local_status.normal := TRUE;
      select_file_response (local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;
    END /send_msg/;

    local_status.normal := TRUE;
    resume_async_task (local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND select_file_command;

?? TITLE := '  display_batch_device_status command', EJECT ??

  PROCEDURE display_batch_dev_status_commnd (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT disbds_pdt (
{   device_name, dn : LIST OF NAME OR KEY printers, plotters, punches, readers, all = $REQUIRED
{   display_option, do : KEY all, a, brief, b = brief
{   output, o : FILE = $OUTPUT
{   STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    disbds_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^disbds_pdt_names,
      ^disbds_pdt_params];

  VAR
    disbds_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
      clt$parameter_name_descriptor := [['DEVICE_NAME', 1], ['DN', 1], ['DISPLAY_OPTION', 2], ['DO', 2], [
      'OUTPUT', 3], ['O', 3], ['STATUS', 4]];

  VAR
    disbds_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor := [

{ DEVICE_NAME DN }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [^disbds_pdt_kv1,
      clc$name_value, 1, osc$max_name_size]],

{ DISPLAY_OPTION DO }
    [[clc$optional_with_default, ^disbds_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [^disbds_pdt_kv2,
      clc$keyword_value]],

{ OUTPUT O }
    [[clc$optional_with_default, ^disbds_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    disbds_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of ost$name := ['PRINTERS',
      'PLOTTERS','PUNCHES','READERS','ALL'];

  VAR
    disbds_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := ['ALL','A',
      'BRIEF','B'];

  VAR
    disbds_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'brief';

  VAR
    disbds_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??

*copy clv$display_variables
?? NEWTITLE := '    abort_handler', EJECT ??

    PROCEDURE abort_handler (condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      close_display;

    PROCEND abort_handler;

?? TITLE := '    close_display', EJECT ??

    PROCEDURE close_display;

      VAR
        ignore_status: ost$status;

      IF output_open THEN
        clp$close_display (display_control, ignore_status);
        output_open := FALSE;
      IFEND;

    PROCEND close_display;

*copy clp$new_page_procedure
?? TITLE := 'put_subtitle', EJECT ??

{  Dummy routine for new page procedure (no subtitles created).

    PROCEDURE [INLINE] put_subtitle (display_control: clt$display_control;
      VAR status: ost$status);

    PROCEND put_subtitle;

?? TITLE := '    request_device_status', EJECT ??

{   Procedure to send device status request to SCFS, for specified
{   device.  Wait for returned device status data to display.

    PROCEDURE request_device_status (dev_name: ost$name);

      put_message_type (nfc$get_device_status);
      put_string_parameter ($INTEGER(nfc$io_station_name), station_name);
      put_string_parameter ($INTEGER(nfc$device_name), dev_name);
      put_null_parameter;

      send_scfs_message (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      display_device_status (output_file, display_option, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND request_device_status;

?? OLDTITLE, EJECT ??

*copy nft$get_device_status_msg

    VAR
      local_status: ost$status,
      value: clt$value,
      display_option: t$display_option,
      output_file: clt$file,
      name_count: 0 .. clc$max_value_sets,
      device_name: ost$name,
      i: 1 .. clc$max_value_sets,
      station_device_count: INTEGER,
      station_usage: nft$io_station_usage,
      device_found: BOOLEAN,
      j: INTEGER,
      device_type: nft$device_type,
      device_list: ^ARRAY [1 .. *] OF t$device_list,
      error_message: STRING (osc$max_string_size),
      optimized_reply: boolean,
      output_open: BOOLEAN,
      display_control: clt$display_control;


    clp$scan_parameter_list (parameter_list, disbds_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DISPLAY_OPTION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (value.name.value = 'BRIEF') OR (value.name.value = 'B') THEN
      display_option := display_brief;
    ELSE
      display_option := display_all;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output_file := value.file;

    clp$get_set_count ('DEVICE_NAME', name_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    device_list := NIL;
    station_device_count := 0;
    IF async_task_active THEN
      hold_async_task (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

 /get_status/
    BEGIN
      output_open := FALSE;
      osp$establish_block_exit_hndlr (^abort_handler);
      clp$open_display (output_file, ^clp$new_page_procedure, display_control, status);
      IF NOT status.normal THEN
        EXIT /get_status/;
      IFEND;
      output_open := TRUE;
      clv$titles_built := FALSE;
      clv$command_name := 'display_batch_device_status';
      IF display_control.page_width < clc$narrow_page_width THEN
        clv$page_width := clc$narrow_page_width;
      ELSEIF display_control.page_width > clc$wide_page_width THEN
        clv$page_width := clc$wide_page_width;
      ELSE
        clv$page_width := display_control.page_width;
      IFEND;

      FOR i := 1 TO name_count DO
        clp$get_value ('DEVICE_NAME', i, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /get_status/;
        IFEND;
        device_name := value.name.value;

        IF (device_name = 'ALL') OR (device_name = 'PRINTERS') OR (device_name = 'PLOTTERS')
              OR (device_name = 'PUNCHES') OR (device_name = 'READERS') THEN
          IF station_device_count = 0 THEN
            optimized_reply := (device_name = 'ALL');
            get_station_status (station_device_count, station_usage, optimized_reply, status);
            IF NOT status.normal THEN
              EXIT /get_status/;
            IFEND;

            IF (station_device_count <> 0) AND (NOT optimized_reply) THEN
              PUSH device_list: [1 .. station_device_count];
              get_device_list (device_list, status);
              IF NOT status.normal THEN
                EXIT /get_status/;
              IFEND;
            IFEND;
          IFEND;
          IF optimized_reply THEN

{ The In/Out parameter OPTIMIZED_REPLY indicates that SCFS replied to the Get_Station_Status
{ message a Batch_Device_Status message instead of the Station_Status_Data message.  This is
{ done to reduce the response time for the command "DISBDS ALL ALL".

            display_device_status (output_file, display_option, display_control, status);
          ELSE

            IF device_name = 'PRINTERS' THEN
              device_type := nfc$printer;
            ELSEIF device_name = 'PLOTTERS' THEN
              device_type := nfc$plotter;
            ELSEIF device_name = 'PUNCHES' THEN
              device_type := nfc$punch;
            ELSEIF device_name = 'READERS' THEN
              device_type := nfc$reader;
            IFEND;

            device_found := FALSE;
            FOR j := 1 TO station_device_count DO
              IF (device_name = 'ALL') OR (device_type = device_list^[j].dtype) THEN
                device_found := TRUE;
                request_device_status (device_list^[j].name);
                IF NOT status.normal THEN
                  EXIT /get_status/;
                IFEND;
              IFEND;
            FOREND;

            IF NOT device_found THEN
              error_message (1, 3) := 'NO ';
              error_message (4, *) := device_name;
              IF device_name = 'ALL' THEN
                error_message (4, *) := 'DEVICES';
              IFEND;
              error_message (stringsize (error_message) + 1, *) := ' CONFIGURED';
              clp$put_display (display_control, error_message, clc$trim, status);
              EXIT /get_status/;
            IFEND;
          IFEND;
        ELSE    {device_name not a keyword}
          request_device_status (device_name);
          IF NOT status.normal THEN
            EXIT /get_status/;
          IFEND;
        IFEND;
      FOREND;
    END /get_status/;

    close_display;
    osp$disestablish_cond_handler;

    local_status.normal := TRUE;
    IF async_task_active THEN
      resume_async_task (local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;
    IFEND;

  PROCEND display_batch_dev_status_commnd;

?? TITLE := '  get_station_status', EJECT ??

{
{   The purpose of this procedure is to obtain status data for this
{   i/o station from SCFS.  This is accomplished by sending a Get
{   Station Status message to SCFS, and waiting for the Station
{   Status Data message to be returned.  The procedure then scans
{   through the Station Status Data message to obtain the station
{   device count and station usage.  The procedure exits with the
{   message sequence pointer set to the first parameter after the
{   device count.  It is assumed that the device count appears after
{   the station usage, per the SCFS Protocol Specification.
{   The device count is preset to zero and the station usage is preset
{   to nfc$private_io_station before sending the message to SCFS or
{   cracking the response.
{

  PROCEDURE get_station_status
    (VAR device_count: INTEGER;
     VAR station_usage: nft$io_station_usage;
     VAR optimized_reply: boolean;
     VAR status: ost$status);

*copy nft$station_status_msg

    VAR
      byte_array: ^nft$byte_array,
      parameter: ^nft$station_status_msg_param,
      value_length: INTEGER,
      response_code: ^nft$display_status_resp_codes,
      station_status_device_count: ^INTEGER,
      station_status_station_usage: ^nft$io_station_usage,
      param_string: ^STRING (* <= osc$max_string_size);

    status.normal := TRUE;

    build_get_station_status_msg(optimized_reply);
    send_scfs_message (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    response_code := NIL;
    station_status_device_count := NIL;
    station_status_station_usage := NIL;
    device_count := 0;
    station_usage := nfc$private_io_station;
    get_message_type;
    get_parameter_type (parameter);
    optimized_reply := (parameter <> NIL) and (message_type^ = nfc$device_status_data);

    IF NOT optimized_reply THEN
   /get_station_status_items/
      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_byte_count > 0) DO
        get_parameter_length (parameter^.length_indicated, value_length);

        IF parameter^.param = nfc$response_code THEN
          NEXT response_code IN message;
        ELSEIF parameter^.param = nfc$count_of_devices THEN
          NEXT station_status_device_count IN message;
          device_count := station_status_device_count^;
          EXIT /get_station_status_items/;
        ELSEIF parameter^.param = nfc$station_usage THEN
          NEXT station_status_station_usage IN message;
          station_usage := station_status_station_usage^;
        ELSE
  {       ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;
        IFEND;

        get_parameter_type (parameter);
      WHILEND /get_station_status_items/;

      IF response_code = NIL THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sou_message_reject,
              'GET_STATION_STATUS', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, no_response_code, status);
        RETURN;
      ELSEIF response_code^ <> nfc$disp_msg_accepted THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sou_message_reject,
              'GET_STATION_STATUS', status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              display_status_responses [response_code^], status);
        RETURN;
      IFEND;

      IF (station_status_device_count = NIL) OR (station_status_station_usage = NIL) THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
              'STATION_STATUS_DATA', status);
        RETURN;
      IFEND;
    IFEND;

  PROCEND get_station_status;

?? TITLE := '  build_get_station_status_msg', EJECT ??

{
{   The purpose of this procedure is to to place in the message
{   sequence buffer the Get Station Status message to be sent
{   to SCFS.  The reason a separate procedure is used here to do
{   practically nothing is to avoid multiple symbol definition in
{   the ordinals defining the parameters in the Get Station Status
{   and the Station Status Data messages.  Cybil is too dumb
{   to recognize when multiple definitions give equal values.

  PROCEDURE build_get_station_status_msg(optimized_reply: BOOLEAN);

*copy nft$get_station_status_msg

    VAR
      optimization_option: nft$optimize_list;

    put_message_type (nfc$get_station_status);
    put_string_parameter ($INTEGER(nfc$io_station_name), station_name);
    IF optimized_reply THEN
      optimization_option := nfc$do_optimize;
    ELSE
      optimization_option := nfc$do_not_optimize;
    IFEND;
    put_parameter ($INTEGER(nfc$optimize_device_list), ^optimization_option, #SIZE(optimization_option));
    put_null_parameter;

  PROCEND build_get_station_status_msg;

?? TITLE := '  get_device_list', EJECT ??

{
{   The purpose of this procedure is to obtain a list of device
{   names and types from the Station Status Data message,
{   received from SCFS.  The sequence pointer in the message
{   buffer is positioned at the first parameter following the
{   list of device status parameters.
{

  PROCEDURE get_device_list (VAR device_list: ^ARRAY [1 .. *] OF t$device_list;
    VAR status: ost$status);

*copy nft$station_status_msg

    VAR
      byte_array: ^nft$byte_array,
      parameter: ^nft$station_status_msg_param,
      value_length: INTEGER,
      station_status_device_count: ^INTEGER,
      device_name_status: ^nft$device_status_data,
      device_count: INTEGER,
      i: INTEGER,
      param_string: ^STRING (* <= osc$max_string_size);


    get_parameter_type (parameter);

    device_count := UPPERBOUND (device_list^);
    i := 0;
    WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_byte_count > 0)
          AND (i < device_count) DO
      get_parameter_length (parameter^.length_indicated, value_length);
      IF parameter^.param = nfc$device_name_status THEN
        i := i+1;
        NEXT device_name_status: [value_length - 3] IN message;
        device_list^ [i].name := device_name_status^.name;
        device_list^ [i].dtype := device_name_status^.device_type;
      ELSE
{       ERROR ----   Ignore parameter value.
        NEXT byte_array: [1 .. value_length] IN message;
      IFEND;

      get_parameter_type (parameter);
    WHILEND;

    IF i < device_count THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
            'STATION_STATUS_DATA', status);
    IFEND;

  PROCEND get_device_list;

?? TITLE := '  display_station_status command', EJECT ??

  PROCEDURE display_station_status_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT disss_pdt (
{   output, o : FILE = $OUTPUT
{   STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    disss_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^disss_pdt_names, ^disss_pdt_params
      ];

  VAR
    disss_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['OUTPUT', 1], ['O', 1], ['STATUS', 2]];

  VAR
    disss_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ OUTPUT O }
    [[clc$optional_with_default, ^disss_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    disss_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??

*copy clv$display_variables
?? NEWTITLE := '    abort_handler', EJECT ??

    PROCEDURE abort_handler (condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      close_display;

    PROCEND abort_handler;

?? TITLE := '    close_display', EJECT ??

    PROCEDURE close_display;

      VAR
        ignore_status: ost$status;

      IF output_open THEN
        clp$close_display (display_control, ignore_status);
        output_open := FALSE;
      IFEND;

    PROCEND close_display;

*copy clp$new_page_procedure
?? TITLE := 'put_subtitle', EJECT ??

{  Dummy routine for new page procedure (no subtitles created).

    PROCEDURE [INLINE] put_subtitle (display_control: clt$display_control;
      VAR status: ost$status);

    PROCEND put_subtitle;

?? OLDTITLE, EJECT ??

*copy nft$get_station_status_msg

    VAR
      local_status: ost$status,
      output_file: clt$file,
      value: clt$value,
      output_open: BOOLEAN,
      display_control: clt$display_control;


    clp$scan_parameter_list (parameter_list, disss_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    put_message_type (nfc$get_station_status);
    put_string_parameter ($INTEGER(nfc$io_station_name), station_name);

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output_file := value.file;

    put_null_parameter;

    IF async_task_active THEN
      hold_async_task (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

 /get_status/
    BEGIN
      send_scfs_message (status);
      IF NOT status.normal THEN
        EXIT /get_status/;
      IFEND;

      output_open := FALSE;
      osp$establish_block_exit_hndlr (^abort_handler);
      clp$open_display (output_file, ^clp$new_page_procedure, display_control, status);
      IF NOT status.normal THEN
        EXIT /get_status/;
      IFEND;
      output_open := TRUE;
      clv$titles_built := FALSE;
      clv$command_name := 'display_station_status';

      display_station_status (output_file, display_control, status);
    END /get_status/;

    close_display;
    osp$disestablish_cond_handler;

    local_status.normal := TRUE;
    IF async_task_active THEN
      resume_async_task (local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;
    IFEND;

  PROCEND display_station_status_command;

?? TITLE := '  display_station_queue_status command', EJECT ??

  PROCEDURE display_statn_q_status_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT dissqs_pdt (
{   display_option, do : KEY all, a, brief, b = brief
{   output, o : FILE = $OUTPUT
{   STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    dissqs_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^dissqs_pdt_names,
      ^dissqs_pdt_params];

  VAR
    dissqs_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['DISPLAY_OPTION', 1], ['DO', 1], ['OUTPUT', 2], ['O', 2], ['STATUS',
      3]];

  VAR
    dissqs_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ DISPLAY_OPTION DO }
    [[clc$optional_with_default, ^dissqs_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [^dissqs_pdt_kv1,
      clc$keyword_value]],

{ OUTPUT O }
    [[clc$optional_with_default, ^dissqs_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    dissqs_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := ['ALL','A',
      'BRIEF','B'];

  VAR
    dissqs_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'brief';

  VAR
    dissqs_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??

*copy clv$display_variables
?? NEWTITLE := '    abort_handler', EJECT ??

    PROCEDURE abort_handler (condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      close_display;

    PROCEND abort_handler;

?? TITLE := '    close_display', EJECT ??

    PROCEDURE close_display;

      VAR
        ignore_status: ost$status;

      IF output_open THEN
        clp$close_display (display_control, ignore_status);
        output_open := FALSE;
      IFEND;

    PROCEND close_display;

*copy clp$new_page_procedure
?? TITLE := 'put_subtitle', EJECT ??

{  Dummy routine for new page procedure (no subtitles created).

    PROCEDURE [INLINE] put_subtitle (display_control: clt$display_control;
      VAR status: ost$status);

    PROCEND put_subtitle;

?? OLDTITLE, EJECT ??

*copy nft$get_station_status_msg

    VAR
      local_status: ost$status,
      display_option: t$display_option,
      output_file: clt$file,
      value: clt$value,
      output_open: BOOLEAN,
      display_control: clt$display_control;


    clp$scan_parameter_list (parameter_list, dissqs_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    put_message_type (nfc$get_queue_status);
    put_string_parameter ($INTEGER(nfc$io_station_name), station_name);

    clp$get_value ('DISPLAY_OPTION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (value.name.value = 'BRIEF') OR (value.name.value = 'B') THEN
      display_option := display_brief;
    ELSE
      display_option := display_all;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output_file := value.file;

    put_null_parameter;

    IF async_task_active THEN
      hold_async_task (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

 /get_status/
    BEGIN
      send_scfs_message (status);
      IF NOT status.normal THEN
        EXIT /get_status/;
      IFEND;

      output_open := FALSE;
      osp$establish_block_exit_hndlr (^abort_handler);
      clp$open_display (output_file, ^clp$new_page_procedure, display_control, status);
      IF NOT status.normal THEN
        EXIT /get_status/;
      IFEND;
      output_open := TRUE;
      clv$titles_built := FALSE;
      clv$command_name := 'display_station_queue_status';

      display_queue_status (output_file, display_option, display_control, status);
    END /get_status/;

    close_display;
    osp$disestablish_cond_handler;

    local_status.normal := TRUE;
    IF async_task_active THEN
      resume_async_task (local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;
    IFEND;

  PROCEND display_statn_q_status_command;

?? TITLE := '  Display_Station_Queue_Entry command', EJECT ??

  PROCEDURE display_station_q_entry_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT dissqe_pdt (
{   name, names, n : LIST OF NAME OR KEY top_ten, all = $REQUIRED
{   display_option, do : KEY all, a, brief, b = brief
{   output, o : FILE = $OUTPUT
{   STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    dissqe_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^dissqe_pdt_names,
      ^dissqe_pdt_params];

  VAR
    dissqe_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 8] of
      clt$parameter_name_descriptor := [['NAME', 1], ['NAMES', 1], ['N', 1], ['DISPLAY_OPTION', 2], ['DO', 2]
      , ['OUTPUT', 3], ['O', 3], ['STATUS', 4]];

  VAR
    dissqe_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor := [

{ NAME NAMES N }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [^dissqe_pdt_kv1,
      clc$name_value, 1, osc$max_name_size]],

{ DISPLAY_OPTION DO }
    [[clc$optional_with_default, ^dissqe_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [^dissqe_pdt_kv2,
      clc$keyword_value]],

{ OUTPUT O }
    [[clc$optional_with_default, ^dissqe_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    dissqe_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := ['TOP_TEN','ALL'
      ];

  VAR
    dissqe_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := ['ALL','A',
      'BRIEF','B'];

  VAR
    dissqe_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'brief';

  VAR
    dissqe_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??

*copy clv$display_variables
?? NEWTITLE := '    abort_handler', EJECT ??

    PROCEDURE abort_handler (condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      close_display;

    PROCEND abort_handler;

?? TITLE := '    close_display', EJECT ??

    PROCEDURE close_display;

      VAR
        ignore_status: ost$status;

      IF output_open THEN
        clp$close_display (display_control, ignore_status);
        output_open := FALSE;
      IFEND;

    PROCEND close_display;

*copy clp$new_page_procedure

?? TITLE := '    display_queue_entry', EJECT ??

    PROCEDURE display_queue_entry
     (    display_option: t$display_option;
          ignore_unknown_file_error: boolean;
      VAR display_control: clt$display_control;
      VAR status:ost$status);

?? NEWTITLE := '      put_display_line', EJECT ??

      PROCEDURE put_display_line
       (    label: STRING (*);
            value: STRING (*));

        VAR
          label_str: STRING (label_size);

        label_str := label;
        IF label <> ' ' THEN
          label_str (label_size - 2, 3) := ' : ';
        IFEND;

        clp$put_partial_display (display_control, label_str, clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          EXIT display_queue_entry;
        IFEND;
        clp$put_partial_display (display_control, value, clc$trim, amc$terminate, status);
        IF NOT status.normal THEN
          EXIT display_queue_entry;
        IFEND;

      PROCEND put_display_line;

?? OLDTITLE, EJECT ??

*copy nft$queue_entry_data_msg

      CONST
        label_size = 31;

      VAR
        byte_array: ^nft$byte_array,
        continuation_param_found :BOOLEAN,
        copies: ^INTEGER,
        date: ost$date,
        destination_name: ^STRING (* <= osc$max_name_size),
        device_name: ^STRING (* <= osc$max_name_size),
        device_type: ^nft$device_type,
        external_characteristics: ^STRING (* <= jmc$ext_characteristics_size),
        family_name: ^STRING (* <= osc$max_name_size),
        file_length: ^nft$file_size,
        forms_code: ^STRING (* <= jmc$forms_code_size),
        io_station_name: ^STRING (* <= osc$max_name_size),
        output_data_mode: ^nft$output_data_mode,
        output_state: ^nft$file_transfer_state,
        page_format: ^nft$page_format,
        page_length: ^nft$page_length,
        page_width: ^nft$page_width,
        parameter: ^nft$queue_entry_msg_parameter,
        position_in_queue: ^INTEGER,
        priority: ^nft$priority,
        response_code: ^nft$display_status_resp_codes,
        str: ost$string,
        system_file_name: ^STRING (* <= osc$max_name_size),
        system_job_name: ^STRING (* <= osc$max_name_size),
        time: ost$time,
        time_enqueued: ^ost$date_time,
        user_file_name: ^STRING (* <= osc$max_name_size),
        user_job_name: ^STRING (* <= osc$max_name_size),
        user_name: ^STRING (* <= osc$max_name_size),
        value_length: INTEGER,
        vertical_print_density: ^nft$file_vertical_print_density,
        vfu_load_procedure: ^STRING (* <= osc$max_name_size);

{ If there is more than one file with the same user_file_name, or if SCFS is responding to
{ an OPERATE_STATION request which requested an optimized display of all queue files
{ queued to the I/O station, SCFS will send the queue data for each of the files.  The
{ station name and response code will not be repeated in the message from SCFS since they
{ are identical.  The information for each file will be delimited by the null parameter,
{ so the parameters and values will continue to be parsed while the message length remains
{ greater than zero.  If the data for all of the files exceeds the maximum size of a
{ message, SCFS will send a continuation parameter at the end of the message instead of
{ the null parameter.

      io_station_name := NIL;
      response_code := NIL;

      get_message_type;
      get_parameter_type (parameter);

      REPEAT
      /get_parameters_for_each_entry/
        WHILE (msg_byte_count > 0) AND (parameter <> NIL) DO

{ Assume that all file information will fit into the first Queue_Entry_Data message.

          continuation_param_found := FALSE;

          copies := NIL;
          destination_name := NIL;
          device_name := NIL;
          device_type := NIL;
          external_characteristics := NIL;
          family_name := NIL;
          file_length := NIL;
          forms_code := NIL;
          output_data_mode := NIL;
          output_state := NIL;
          page_format := NIL;
          page_length := NIL;
          page_width := NIL;
          position_in_queue := NIL;
          priority := NIL;
          system_file_name := NIL;
          system_job_name := NIL;
          time_enqueued := NIL;
          user_file_name := NIL;
          user_job_name := NIL;
          user_name := NIL;
          vertical_print_density := NIL;
          vfu_load_procedure := NIL;

       /get_parameters/
          WHILE (parameter <> NIL) AND ((parameter^.param <> nfc$null_parameter) AND
                (parameter^.param <> nfc$queue_entry_data_continues)) DO
            get_parameter_length (parameter^.length_indicated, value_length);
            IF value_length = 0 THEN
              get_parameter_type (parameter);
              CYCLE /get_parameters/;
            IFEND;

            CASE parameter^.param OF

            = nfc$io_station_name =
              NEXT io_station_name: [value_length] IN message;

            = nfc$response_code =
              NEXT response_code IN message;

            = nfc$system_file_name =
              NEXT system_file_name: [value_length] IN message;

            = nfc$user_file_name =
              NEXT user_file_name: [value_length] IN message;

            = nfc$time_enqueued =
              NEXT time_enqueued IN message;

            = nfc$position_in_queue =
              NEXT position_in_queue IN message;

            = nfc$priority =
              NEXT priority IN message;

            = nfc$copies =
              NEXT copies IN message;

            = nfc$create_job_family_name =
              NEXT family_name: [value_length] IN message;

            = nfc$create_system_job_name =
              NEXT system_job_name: [value_length] IN message;

            = nfc$create_user_job_name =
              NEXT user_job_name: [value_length] IN message;

            = nfc$destination_name =
              NEXT destination_name: [value_length] IN message;

            = nfc$device_type =
              NEXT device_type IN message;

            = nfc$file_length =
              NEXT file_length IN message;

            = nfc$output_data_mode =
              NEXT output_data_mode IN message;

            = nfc$scfs_output_status =
              NEXT output_state IN message;

            = nfc$device_name =
              NEXT device_name: [value_length] IN message;

            = nfc$external_characteristics =
              NEXT external_characteristics: [value_length] IN message;

            = nfc$forms_code =
              NEXT forms_code: [value_length] IN message;

            = nfc$page_format =
              NEXT page_format IN message;

            = nfc$page_length =
              NEXT page_length IN message;

            = nfc$page_width =
              NEXT page_width IN message;

            = nfc$vertical_print_density =
              NEXT vertical_print_density IN message;

            = nfc$vfu_load_procedure =
              NEXT vfu_load_procedure: [value_length] IN message;

            = nfc$creating_user_name =
              NEXT user_name: [value_length] IN message;

            ELSE
  {           ERROR ----   Ignore parameter value.
              NEXT byte_array: [1 .. value_length] IN message;

            CASEND;

            get_parameter_type (parameter);
          WHILEND /get_parameters/;


          IF response_code = NIL THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sou_message_reject,
                  'GET_QUEUE_ENTRY', status);
            osp$append_status_parameter (osc$status_parameter_delimiter, no_response_code, status);
            RETURN;
          ELSEIF (response_code^ = nfc$disp_unknown_file_name) AND ignore_unknown_file_error THEN
            RETURN;
          ELSEIF response_code^ <> nfc$disp_msg_accepted THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sou_command_reject,
                  'DISPLAY_STATION_QUEUE_ENTRY', status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  display_status_responses [response_code^], status);
            RETURN;
          IFEND;

          IF system_file_name <> NIL THEN
            put_display_line ('System_Supplied_File_Name', system_file_name^);
          IFEND;

          IF (display_option = display_all) THEN
            IF (copies <> NIL) THEN
              clp$convert_integer_to_string (copies^, 10, FALSE, str, status);
              put_display_line ('  Copies', str.value (1, str.size));
            IFEND;

            IF (destination_name <> NIL) THEN
              put_display_line ('  Destination_Name', destination_name^);
            IFEND;

            IF (device_name <> NIL) THEN
              put_display_line ('  Device_Name', device_name^);
            IFEND;

            IF (device_type <> NIL) THEN
              put_display_line ('  Device_Type', device_types [device_type^]);
            IFEND;

            IF (external_characteristics <> NIL) THEN
              put_display_line ('  External_Characteristics', external_characteristics^);
            IFEND;

            IF (family_name <> NIL) THEN
              put_display_line ('  Family_Name', family_name^);
            IFEND;
          IFEND;

          IF file_length <> NIL THEN
            clp$convert_integer_to_string ($INTEGER(file_length^), 10, FALSE, str, status);
            put_display_line ('  File_Length', str.value (1, str.size));
          IFEND;

          IF (display_option = display_all) THEN
            IF (forms_code <> NIL) THEN
              put_display_line ('  Forms_Code', forms_code^);
            IFEND;

            IF (output_data_mode <> NIL) THEN
              put_display_line ('  Output_Data_Mode', output_data_modes [output_data_mode^]);
            IFEND;
          IFEND;

          IF (output_state <> NIL) AND (output_state^ <= nfc$selected_for_transfer) THEN
            put_display_line ('  Output_State', output_states [output_state^]);
          IFEND;

          IF (display_option = display_all) THEN
            IF (page_format <> NIL) THEN
              put_display_line ('  Page_Format', page_formats [page_format^]);
            IFEND;

            IF (page_length <> NIL) THEN
              clp$convert_integer_to_string ($INTEGER(page_length^), 10, FALSE, str, status);
              put_display_line ('  Page_Length', str.value (1, str.size));
            IFEND;

            IF (page_width <> NIL) THEN
              clp$convert_integer_to_string ($INTEGER(page_width^), 10, FALSE, str, status);
              put_display_line ('  Page_Width', str.value (1, str.size));
            IFEND;

            IF (position_in_queue <> NIL) THEN
              clp$convert_integer_to_string (position_in_queue^, 10, FALSE, str, status);
              put_display_line ('  Position_In_Queue', str.value (1, str.size));
            IFEND;

            IF (priority <> NIL) THEN
              clp$convert_integer_to_string (priority^, 10, FALSE, str, status);
              put_display_line ('  Priority', str.value (1, str.size));
            IFEND;

            IF (system_job_name <> NIL) THEN
              put_display_line ('  System_Supplied_Job_Name', system_job_name^);
            IFEND;

            IF (time_enqueued <> NIL) THEN
              pmp$format_compact_date (time_enqueued^, osc$iso_date, date, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              pmp$format_compact_time (time_enqueued^, osc$hms_time, time, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              str.value := date.iso;
              str.value (13, *) := time.hms;
              put_display_line ('  Time_Enqueued', str.value);
            IFEND;
          IFEND;

          IF user_name <> NIL THEN
            put_display_line ('  User_Name', user_name^);
          IFEND;

          IF user_file_name <> NIL THEN
            put_display_line ('  User_Supplied_File_Name', user_file_name^);
          IFEND;

          IF (display_option = display_all) THEN
            IF (user_job_name <> NIL) THEN
              put_display_line ('  User_Supplied_Job_Name', user_job_name^);
            IFEND;

            IF (vertical_print_density <> NIL) THEN
              put_display_line ('  Vertical_Print_Density', file_vpd_actions [vertical_print_density^]);
            IFEND;

            IF (vfu_load_procedure <> NIL) THEN
              put_display_line ('  VFU_Load_Procedure', vfu_load_procedure^);
            IFEND;
          IFEND;

          IF (display_control.line_number < display_control.page_length) OR
                (display_control.page_format = amc$continuous_form) THEN
            clp$put_display (display_control, ' ', clc$trim, status);
          IFEND;

          IF (msg_byte_count > 0) THEN
            get_parameter_type (parameter);
          IFEND;


        WHILEND /get_parameters_for_each_entry/;

        continuation_param_found := (parameter  <> NIL) AND
              (parameter^.param = nfc$queue_entry_data_continues);

        IF continuation_param_found THEN

{ All of the information for the files could not fit in one message. Get the next message.

          await_next_message (status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          get_message_type;
          get_parameter_type (parameter);

          IF (message_type^ <> nfc$queue_entry_data) THEN
            RETURN;
          IFEND;
        IFEND;
      UNTIL NOT continuation_param_found;
    PROCEND display_queue_entry;

?? TITLE := 'put_subtitle', EJECT ??

{  Dummy routine for new page procedure (no subtitles created).

    PROCEDURE [INLINE] put_subtitle (display_control: clt$display_control;
      VAR status: ost$status);

    PROCEND put_subtitle;

?? TITLE := '    request_queue_entry', EJECT ??

{   Procedure to send request for queue entry to SCFS, for specified
{   file name.

    PROCEDURE request_queue_entry (output_file_name: STRING (* <= osc$max_name_size);
          ignore_unknown_file_error: boolean);

      put_message_type (nfc$get_queue_entry);
      put_string_parameter ($INTEGER(nfc$io_station_name), station_name);
      put_string_parameter ($INTEGER(nfc$system_file_name), output_file_name);
      put_null_parameter;

      send_scfs_message (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      display_queue_entry (display_option, ignore_unknown_file_error, display_control, status);

    PROCEND request_queue_entry;

?? OLDTITLE, EJECT ??

*copy nft$get_queue_entry_msg

    VAR
      display_control: clt$display_control,
      display_option: t$display_option,
      error_message: STRING (osc$max_string_size),
      file_index: jmt$output_status_count,
      i: 1 .. clc$max_value_sets,
      j: INTEGER,
      list_type: nft$all_or_top_10_q_entries,
      local_status: ost$status,
      name_count: 0 .. clc$max_value_sets,
      number_of_outputs_found: jmt$output_status_count,
      output_file: clt$file,
      output_file_name: ost$name,
      output_index: jmt$output_status_count,
      output_name: jmt$name,
      output_open: BOOLEAN,
      queue_entry_count: INTEGER,
      result_size: ost$segment_length,
      status_options_p: ^jmt$output_status_options,
      status_results_keys_p: ^jmt$results_keys,
      status_results_p: ^jmt$output_status_results,
      system_file_list: ^ARRAY [1 .. *] OF ost$name,
      value: clt$value,
      work_area_p: ^jmt$work_area;

    clp$scan_parameter_list (parameter_list, dissqe_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DISPLAY_OPTION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (value.name.value = 'BRIEF') OR (value.name.value = 'B') THEN
      display_option := display_brief;
    ELSE
      display_option := display_all;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output_file := value.file;

    clp$get_set_count ('NAME', name_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    system_file_list := NIL;
    IF async_task_active THEN
      hold_async_task (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

 /get_entries/
    BEGIN
      output_open := FALSE;
      osp$establish_block_exit_hndlr (^abort_handler);
      clp$open_display (output_file, ^clp$new_page_procedure, display_control, status);
      IF NOT status.normal THEN
        EXIT /get_entries/;
      IFEND;
      output_open := TRUE;
      clv$titles_built := FALSE;
      clv$command_name := 'display_station_queue_entries';

      FOR i := 1 TO name_count DO
        clp$get_value ('NAME', i, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /get_entries/;
        IFEND;
        output_file_name := value.name.value;

        IF (output_file_name = 'ALL') OR (output_file_name = 'TOP_TEN') THEN
          IF output_file_name = 'ALL' THEN
            list_type := nfc$all_q_entries;
          ELSE
            list_type := nfc$top_10_q_entries;
          IFEND;

{ The STATION_OPERATOR value used below signals SCFS that OPERATE_STATION is making the
{ request and the Queue_Entry_List_Data message is not required.  DISPLAY_STATION requires
{ the Queue_Entry_List_Data message because the message contains a list of system file
{ names each of which must be checked for ownership by the DISPLAY_STATION user before
{ information about the queue file can be displayed.

          get_queue_entry_list (list_type, queue_entry_count, station_operator, status);
          IF NOT status.normal THEN
            EXIT /get_entries/;
          IFEND;

          get_message_type;

          IF message_type^ = nfc$queue_entry_data THEN

{ SCFS has sent the list of attributes of all of the files queued.  Display the attributes
{ and exit the procedure. If no files are queued, an abnormal status will  be returned.

            display_queue_entry (display_option, FALSE, display_control, status);
            IF (NOT status.normal) AND (status.condition = nfe$sou_command_reject) THEN
              error_message := 'NO FILES QUEUED';
              clp$put_display (display_control, error_message, clc$trim, status);
              EXIT /get_entries/;
            ELSE
              IF async_task_active THEN
                resume_async_task (local_status);
                IF status.normal AND NOT local_status.normal THEN
                  status := local_status;
                IFEND;
              IFEND;
              RETURN;
            IFEND;
            EXIT /get_entries/;
          IFEND;

{ SCFS has sent a list of system file names for files queued to the I/O station.  Process
{ the list.
          IF queue_entry_count = 0 THEN  {no entries to display}
            error_message := 'NO FILES QUEUED';
            clp$put_display (display_control, error_message, clc$trim, status);
            EXIT /get_entries/;
          IFEND;

          PUSH system_file_list: [1 .. queue_entry_count];
          get_system_file_list (system_file_list, status);
          IF NOT status.normal THEN
            EXIT /get_entries/;
          IFEND;
          status_results_p := NIL;
       /get_entry/
          FOR j := 1 TO queue_entry_count DO
            IF NOT station_operator THEN
              check_file_ownership (system_file_list^ [j], local_status);
              IF NOT local_status.normal THEN
                CYCLE /get_entry/;
              IFEND;
            IFEND;
            request_queue_entry (system_file_list^ [j], {ignore_unknown_file_error} TRUE);
            IF NOT status.normal THEN
              EXIT /get_entries/;
            IFEND;
          FOREND /get_entry/;
        ELSE
          IF station_operator THEN
            request_queue_entry (output_file_name, {ignore_unknown_file_error} FALSE);
            IF NOT status.normal THEN
              EXIT /get_entries/;
            IFEND;
          ELSE
            PUSH status_options_p: [1 .. 1];
            status_options_p^ [1].key := jmc$name_list;
            status_options_p^ [1].name_list := NIL;
            PUSH status_options_p^ [1].name_list: [1 .. 1];
            jmp$determine_name_kind (output_file_name, status_options_p^ [1].name_list^ [1], status);
            IF NOT status.normal THEN
              EXIT /get_entries/;
            IFEND;

            PUSH status_results_keys_p: [1 .. 1];
            status_results_keys_p^ [1] := jmc$system_file_name;
            jmp$get_result_size ({number_of_items} 1, #SEQ (status_results_keys_p^), result_size);
            PUSH work_area_p: [[REP result_size OF cell]];
            RESET work_area_p;
            jmp$get_output_status (status_options_p, status_results_keys_p, work_area_p,
                  status_results_p, number_of_outputs_found, status);

            WHILE (NOT status.normal) AND (status.condition = jme$work_area_too_small) DO
              status.normal := TRUE;
              jmp$get_result_size (number_of_outputs_found + 1, #SEQ (status_results_keys_p^), result_size);
              PUSH work_area_p: [[REP result_size OF cell]];
              RESET work_area_p;
              jmp$get_output_status (status_options_p, status_results_keys_p, work_area_p,
                    status_results_p, number_of_outputs_found, status);
            WHILEND;
            IF NOT status.normal THEN
              EXIT /get_entries/;
            IFEND;

            FOR output_index := 1 TO number_of_outputs_found DO
              request_queue_entry (status_results_p^ [output_index]^ [1].system_file_name,
                    {ignore_unknown_file_error} TRUE);
              IF NOT status.normal THEN
                EXIT /get_entries/;
              IFEND;
            FOREND;
          IFEND;
        IFEND;

      FOREND;

    END /get_entries/;

    close_display;
    osp$disestablish_cond_handler;

    local_status.normal := TRUE;
    IF async_task_active THEN
      resume_async_task (local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;
    IFEND;

  PROCEND display_station_q_entry_command;
?? TITLE := '  terminate_queued_output_command', EJECT ??

  PROCEDURE terminate_queued_output_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT terqo_pdt (
{   name, names, n : LIST OF NAME = $REQUIRED
{   STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    terqo_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^terqo_pdt_names, ^terqo_pdt_params
  ];

  VAR
    terqo_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
  clt$parameter_name_descriptor := [['NAME', 1], ['NAMES', 1], ['N', 1], ['STATUS', 2]];

  VAR
    terqo_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ NAME NAMES N }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
  osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? POP ??
    VAR
      index: 0 .. clc$max_value_sets,
      local_status: ost$status,
      name_count: 0 .. clc$max_value_sets,
      value: clt$value;
?? NEWTITLE := '    get_terqo_response', EJECT ??

    PROCEDURE get_terqo_response
      (VAR status: ost$status);

      VAR
        byte_array: ^nft$byte_array,
        io_station_name: ost$name,
        file_name: ost$name,
        file_status_code: ^nft$terqo_file_status_codes,
        name_string: ^string ( * <= osc$max_name_size),
        parameter: ^nft$term_q_output_resp_param,
        value_length: integer;

*copy nft$terminate_q_output_resp_msg
?? EJECT ??
      file_name := osc$null_name;
      io_station_name := osc$null_name;

      get_message_type;
      get_parameter_type (parameter);

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_byte_count > 0) DO
        get_parameter_length (parameter^.length_indicated, value_length);
        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT name_string: [value_length] IN message;
          io_station_name := name_string^;

        = nfc$system_user_file_name =
          NEXT name_string: [value_length] IN message;
          file_name := name_string^;

        = nfc$file_status_code =
          NEXT file_status_code IN message;

        CASEND;
        get_parameter_type (parameter);
      WHILEND;

      IF file_status_code = NIL THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sou_message_reject, 'TERMINATE_QUEUED_OUTPUT', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, no_response_code, status);
      ELSEIF file_status_code^ <> nfc$terqo_successful THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sou_command_reject, 'TERMINATE_QUEUED_OUTPUT', status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              terminate_queue_output_resps [file_status_code^], status);
      IFEND;

    PROCEND get_terqo_response;
?? TITLE := '    request_file_termination', EJECT ??

    PROCEDURE request_file_termination
      (    system_file_name: ost$name;
       VAR status: ost$status);

*copy nft$terminate_queued_output_msg

      put_message_type (nfc$terminate_queue_output);
      put_string_parameter ($integer (nfc$io_station_name), station_name);
      put_string_parameter ($integer (nfc$system_user_file_name), system_file_name);

      send_scfs_message (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND request_file_termination;
?? OLDTITLE, EJECT ??
    clp$scan_parameter_list (parameter_list, terqo_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('NAME', name_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    hold_async_task (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR index := 1 TO name_count DO
      clp$get_value ('NAME', index, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      request_file_termination (value.name.value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      get_terqo_response (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    local_status.normal := TRUE;
    resume_async_task (local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND terminate_queued_output_command;
?? TITLE := '  get_queue_entry_list', EJECT ??


{ This procedure will request information about all queue file entries for this I/O
{ station from SCFS.  This is accomplished by sending a Get_Queue_Entry_List message to
{ SCFS, and waiting for the Queue_Entry_List_Data message or Queue_Entry_Data message to
{ be returned.  If the Queue_Entry_List_Data message is returned, the procedure then scans
{ through the message to obtain the Number_of_Files parameter, which indicates the number
{ of queue entries for which data is provided.  The procedure will then exit with the
{ message sequence pointer positioned at the parameter following the Number_of_Files
{ parameter.


  PROCEDURE get_queue_entry_list (list_type: nft$all_or_top_10_q_entries;
    VAR q_entry_count: INTEGER;
        request_optimized_reply: BOOLEAN;
    VAR status: ost$status);

*copy nft$q_entry_list_data_msg

    VAR
      byte_array: ^nft$byte_array,
      parameter: ^nft$q_entry_list_data_msg_param,
      value_length: INTEGER,
      response_code: ^nft$display_status_resp_codes,
      q_entry_file_count: ^INTEGER,
      param_string: ^STRING (* <= osc$max_string_size);


    build_get_q_entry_list_msg (list_type, request_optimized_reply);
    send_scfs_message (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    response_code := NIL;
    q_entry_file_count := NIL;
    q_entry_count := 0;
    get_message_type;

    IF message_type^ = nfc$queue_entry_list_data THEN

      get_parameter_type (parameter);

   /get_entry_count/
      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_byte_count > 0) DO
        get_parameter_length (parameter^.length_indicated, value_length);

        IF parameter^.param = nfc$response_code THEN
          NEXT response_code IN message;
        ELSEIF parameter^.param = nfc$number_of_files THEN
          NEXT q_entry_file_count IN message;
          q_entry_count := q_entry_file_count^;
          EXIT /get_entry_count/;
        ELSE
  {       ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;
        IFEND;

        get_parameter_type (parameter);
      WHILEND /get_entry_count/;

      IF response_code = NIL THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sou_message_reject,
              'GET_QUEUE_ENTRY_LIST', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, no_response_code, status);
        RETURN;
      ELSEIF response_code^ <> nfc$disp_msg_accepted THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sou_message_reject,
              'GET_QUEUE_ENTRY_LIST', status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              display_status_responses [response_code^], status);
        RETURN;
      IFEND;

      IF q_entry_file_count = NIL THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
              'GET_QUEUE_ENTRY_LIST', status);
        RETURN;
      IFEND;
{ ELSE the message is the Queue_Entry_Data message returned by SCFS
{ because Request_Optimized_Reply was specified as TRUE.  Return and
{ allow the caller to process the message.

    IFEND;
  PROCEND get_queue_entry_list;

?? TITLE := '  build_get_q_entry_list_msg', EJECT ??

{
{ The purpose of this procedure is to place the Get_Queue_Entry_List message in the
{ sequence buffer.  The value Request_Optimized_Response signals SCFS that OPERATE_STATION
{ is making this request and can process the Queue_Entry_Data message without a preceeding
{ Queue_Entry_List_Data message.

  PROCEDURE build_get_q_entry_list_msg (list_type:nft$all_or_top_10_q_entries,
        request_optimized_reply: BOOLEAN);

*copy nft$get_q_entry_list_msg

    VAR
      optimization_option: nft$optimize_list;

    put_message_type (nfc$get_queue_entry_list);
    put_string_parameter ($INTEGER(nfc$io_station_name), station_name);
    put_parameter ($INTEGER(nfc$all_or_top_ten), ^list_type, #SIZE(list_type));

    IF request_optimized_reply THEN
      optimization_option := nfc$do_optimize;
    ELSE
      optimization_option := nfc$do_not_optimize;
    IFEND;
    put_parameter ($INTEGER(nfc$optimize_queue_list), ^optimization_option, #SIZE(optimization_option));
    put_null_parameter;

  PROCEND build_get_q_entry_list_msg;

?? TITLE := '  get_system_file_list', EJECT ??

{
{   The purpose of this procedure is to obtain the list of system
{   file names from the Queue Entry List Data message, received
{   from SCFS.  Upon entry, the message sequence pointer is positioned
{   at the parameter just after the Number of Files parameter.
{

  PROCEDURE get_system_file_list (VAR system_file_list: ^ARRAY [1 .. *] OF ost$name;
    VAR status: ost$status);

*copy nft$q_entry_list_data_msg

    VAR
      byte_array: ^nft$byte_array,
      parameter: ^nft$q_entry_list_data_msg_param,
      value_length: INTEGER,
      count_of_files: ^INTEGER,
      file_and_priority: ^nft$file_and_priority,
      file_count: INTEGER,
      i: INTEGER,
      param_string: ^STRING (* <= osc$max_string_size);


    get_parameter_type (parameter);

    file_count := UPPERBOUND (system_file_list^);
    i := 0;
    WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_byte_count > 0)
          AND (i < file_count) DO
      get_parameter_length (parameter^.length_indicated, value_length);
      IF parameter^.param = nfc$sys_file_and_priority THEN
        i := i+1;
        NEXT file_and_priority: [value_length - 8] IN message;
        system_file_list^ [i] := file_and_priority^.name;
      ELSE
{       ERROR ----   Ignore parameter value.
        NEXT byte_array: [1 .. value_length] IN message;
      IFEND;

      get_parameter_type (parameter);
    WHILEND;

    IF i < file_count THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
            'QUEUE_ENTRY_LIST_DATA', status);
    IFEND;

  PROCEND get_system_file_list;

?? TITLE := '  quit command', EJECT ??

  PROCEDURE quit_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT quit_pdt (
{   STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    quit_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^quit_pdt_names, ^quit_pdt_params];

  VAR
    quit_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
      clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    quit_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    clp$scan_parameter_list (parameter_list, quit_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF station_operator THEN
      clp$end_scan_command_file (operator_utility_name, status);
    ELSE
      clp$end_scan_command_file (display_utility_name, status);
    IFEND;

  PROCEND quit_command;

?? TITLE := '  queue_operator_message', EJECT ??

{
{   The purpose of this procedure is to queue an operator
{   message from SCFS in a link list until it can be
{   displayed.
{

  PROCEDURE queue_operator_message;

*copy nft$operator_message

    VAR
      byte_array: ^nft$byte_array,
      text_string: ^STRING (* <= nfc$maximum_message_length),
      name_string: ^STRING (* <= osc$max_name_size),
      device_name: ost$name,
      io_station_name: ost$name,
      parameter: ^nft$operator_message_parameter,
      value_length: INTEGER,
      queued_msg_pp: ^^nft$queued_operator_message;


    io_station_name := ' ';
    device_name := ' ';
    text_string := NIL;

    get_parameter_type (parameter);

    WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_byte_count > 0) DO
      get_parameter_length (parameter^.length_indicated, value_length);

      CASE parameter^.param OF

      = nfc$io_station_name =
        NEXT name_string: [value_length] IN message;
        io_station_name := name_string^;

      = nfc$device_name =
        NEXT name_string: [value_length] IN message;
        device_name := name_string^;

      = nfc$text =
        NEXT text_string: [value_length] IN message;

      ELSE
{       ERROR ----   Ignore parameter value.
        NEXT byte_array: [1 .. value_length] IN message;

      CASEND;

      get_parameter_type (parameter);
    WHILEND;

    IF text_string = NIL THEN
    RETURN;
    IFEND;

    queued_msg_pp := ^operator_message_list;
    WHILE queued_msg_pp^ <> NIL DO
      queued_msg_pp := ^queued_msg_pp^^.link;
    WHILEND;
    ALLOCATE queued_msg_pp^: [STRLENGTH (text_string^)];
    queued_msg_pp^^.link := NIL;
    queued_msg_pp^^.station := io_station_name;
    queued_msg_pp^^.device := device_name;
    queued_msg_pp^^.text := text_string^;
    IF operator_message_list = NIL THEN
      operator_message_list := queued_msg_pp^;
    IFEND;

  PROCEND queue_operator_message;

?? TITLE := '  display_operator_message', EJECT ??

{
{   The purpose of this procedure is to display an unsolicited
{   message to the station operator from SCFS/VE.
{

  PROCEDURE display_operator_message (VAR status: ost$status);

*copy clv$display_variables
?? NEWTITLE := '    abort_handler', EJECT ??

    PROCEDURE abort_handler (condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      close_display;

    PROCEND abort_handler;

?? TITLE := '    close_display', EJECT ??

    PROCEDURE close_display;

      VAR
        ignore_status: ost$status;

      IF output_open THEN
        clp$close_display (display_control, ignore_status);
        output_open := FALSE;
      IFEND;

    PROCEND close_display;

?? TITLE := '    put_display_line', EJECT ??

    PROCEDURE put_display_line (label: STRING (*);
          value: STRING (*));

      VAR
        label_str: STRING (label_size);

      label_str := label;
      IF label <> ' ' THEN
        label_str (label_size - 2, 3) := ' : ';
      IFEND;

      clp$put_partial_display (display_control, label_str, clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        close_display;
        EXIT display_operator_message;
      IFEND;
      clp$put_partial_display (display_control, value, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        close_display;
        EXIT display_operator_message;
      IFEND;

    PROCEND put_display_line;


?? OLDTITLE, EJECT ??

    CONST
      device_label = 'Device   : ',
      device_label_size = 11,
      label_size = 31,
      unit_separator = $CHAR (01f(16));

    VAR
      output_file: [READ] clt$file := [clc$standard_output],
      q_msg: ^nft$queued_operator_message,
      msg_size: 0 .. osc$max_string_size,
      line_size: 0 .. osc$max_string_size,
      i : 1 .. osc$max_string_size,
      display_control: clt$display_control,
      output_open: BOOLEAN,
      start_pos: 1..80,
      str_length: 0 .. osc$max_name_size,
      text: string (80),
      text_length: 0..80;

    IF operator_message_list <> NIL THEN

  /display/
    BEGIN
      output_open := FALSE;
      osp$establish_block_exit_hndlr (^abort_handler);
      clp$open_display (output_file, NIL, display_control, status);
      IF NOT status.normal THEN
        EXIT /display/;
      IFEND;
      output_open := TRUE;
      IF display_control.page_width < clc$narrow_page_width THEN
        clv$page_width := clc$narrow_page_width;
      ELSEIF display_control.page_width > clc$wide_page_width THEN
        clv$page_width := clc$wide_page_width;
      ELSE
        clv$page_width := display_control.page_width;
      IFEND;

      q_msg := operator_message_list;

{  Format the line containing the device and the station name. }

      text (1, device_label_size) := device_label;
      text_length := device_label_size;

      start_pos := text_length + 1;
      str_length := clp$trimmed_string_size (q_msg^.device);
      text (start_pos, str_length) := q_msg^.device (1, str_length);
      text_length := text_length + str_length;

      start_pos := text_length + 1;
      text (start_pos, 4) := ' at ';
      text_length := text_length + 4;

      start_pos := text_length + 1;
      str_length := clp$trimmed_string_size (q_msg^.station);
      text (start_pos, str_length) := q_msg^.station (1, str_length);
      text_length := text_length + str_length;

      clp$put_display (display_control, text (1, text_length), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display/;
      IFEND;

      line_size := clv$page_width - 1;
      msg_size := stringsize (q_msg^.text);

      WHILE msg_size > 0 DO
     /scan_msg/
        FOR i := 1 TO msg_size DO
          IF i >= line_size THEN
            EXIT /scan_msg/;
          ELSEIF q_msg^.text (i) = unit_separator THEN
            q_msg^.text (i) := ' ';
            EXIT /scan_msg/;
          IFEND;
        FOREND /scan_msg/;

        clp$put_display (display_control, q_msg^.text (1, i), clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display/
        IFEND;
        q_msg^.text := q_msg^.text (i+1, *);
        msg_size :=msg_size - i;
      WHILEND;

      operator_message_list := q_msg^.link;
      FREE q_msg;

      put_display_line (' ', ' ');
    END /display/;

      close_display;
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND display_operator_message;

?? TITLE := '  add_user_response', EJECT ??

  PROCEDURE add_user_response (VAR status:ost$status);

*copy nft$add_user_resp_msg

    VAR
      byte_array: ^nft$byte_array,
      name_string: ^STRING (* <= osc$max_name_size),
      response_code: ^nft$add_user_responses,
      parameter: ^nft$add_user_resp_msg_parameter,
      value_length: INTEGER;


    response_code := NIL;
    get_message_type;
    get_parameter_type (parameter);

 /get_params/
    WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_byte_count > 0) DO
      get_parameter_length (parameter^.length_indicated, value_length);

      CASE parameter^.param OF

      = nfc$station_or_control_facility =
        NEXT name_string: [value_length] IN message;
        station_name := name_string^;

      = nfc$response_code =
        NEXT response_code IN message;
        EXIT /get_params/;

      ELSE
{       ERROR ----   Ignore parameter value.
        NEXT byte_array: [1 .. value_length] IN message;

      CASEND;

      get_parameter_type (parameter);
    WHILEND /get_params/;

    IF response_code = NIL THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sou_message_reject, 'ADD_USER', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, no_response_code, status);
    ELSEIF response_code^ <> nfc$message_accepted THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sou_command_reject, 'OPERATE_STATION', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            add_user_responses [response_code^], status);
    IFEND;

  PROCEND add_user_response;

?? TITLE := '  change_dev_attributes_response', EJECT ??

  PROCEDURE change_dev_attributes_response (VAR status:ost$status);

    CONST
      chabda_param_size = 26;

*copy nft$change_bd_attr_resp_msg

{  This array of values is used to identify which change_batch_device_attributes
{  parameter the DI found a problem with during validation.  }
{  If a problem was found during validation, the "invalid_chg_request" }
{  parameter would be sent up on the chabda response.  This is what signals  }
{  OPES that there was a problem found.  }

    VAR
      chabda_parameters: [READ] ARRAY [nft$change_bda_resp_parameters] OF STRING (chabda_param_size) :=
        [ {nfc$null_parameter} 'ERROR',
          {nfc$io_station_name} 'ERROR',
          {nfc$device_name} 'DEVICE_NAME',
          {nfc$device_alias_1} 'DEVICE_ALIAS_1',
          {nfc$device_alias_2} 'DEVICE_ALIAS_2',
          {nfc$device_alias_3} 'DEVICE_ALIAS_3',
          {nfc$file_acknowledgement} 'FILE_ACKNOWLEDGEMENT',
          {nfc$terminal_model} 'TERMINAL_MODEL',
          {nfc$transmission_block_size} 'TRANSMISSION_BLOCK_SIZE',
          {nfc$maximum_file_size} 'MAXIMUM_FILE_SIZE',
          {nfc$page_width} 'PAGE_WIDTH',
          {nfc$page_length} 'PAGE_LENGTH',
          {nfc$banner_page_count} 'BANNER_PAGE_COUNT',
          {nfc$banner_highlight_field} 'BANNER_HIGHLIGHT_FIELD',
          {nfc$carriage_control_action} 'CARRIAGE_CONTROL_SUPPORT',
          {nfc$forms_code_1} 'FORMS_CODE_1',
          {nfc$forms_code_2} 'FORMS_CODE_2',
          {nfc$forms_code_3} 'FORMS_CODE_3',
          {nfc$forms_code_4} 'FORMS_CODE_4',
          {nfc$external_characteristics_1} 'EXTERNAL_CHARACTERISTICS_1',
          {nfc$external_characteristics_2} 'EXTERNAL_CHARACTERISTICS_2',
          {nfc$external_characteristics_3} 'EXTERNAL_CHARACTERISTICS_3',
          {nfc$external_characteristics_4} 'EXTERNAL_CHARACTERISTICS_4',
          {nfc$code_set} 'CODE_SET',
          {nfc$vertical_print_density} 'VERTICAL_PRINT_DENSITY',
          {nfc$vfu_load_procedure} 'VFU_LOAD_PROCEDURE',
          {nfc$forms_size} 'FORMS_SIZE',
          {nfc$undefined_fe_action} 'UNDEFINED_FE_ACTION',
          {nfc$unsupported_fe_action} 'UNSUPPORTED_FE_ACTION',
          {29 - 65} REP 37 OF 'ERROR'];
    VAR
      device_name: ost$name,
      invalid_param: ^nft$change_bda_resp_parameters,
      io_station_name: ost$name,
      byte_array: ^nft$byte_array,
      name_string: ^STRING (* <= osc$max_name_size),
      parameter: ^nft$change_bd_attr_resp_param,
      response_code: ^nft$device_control_resp_codes,
      value_length: INTEGER;


    device_name := ' ';
    invalid_param := NIL;
    io_station_name := ' ';
    response_code := NIL;

    get_message_type;
    get_parameter_type (parameter);

 /get_params/
    WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_byte_count > 0) DO
      get_parameter_length (parameter^.length_indicated, value_length);

      CASE parameter^.param OF

      = nfc$io_station_name =
        NEXT name_string: [value_length] IN message;
        io_station_name := name_string^;

      = nfc$device_name =
        NEXT name_string: [value_length] IN message;
        device_name := name_string^;

      = nfc$response_code =
        NEXT response_code IN message;

      = nfc$invalid_chg_request =
        NEXT invalid_param IN message;
        EXIT /get_params/

      ELSE
{       ERROR ----   Ignore parameter value.
        NEXT byte_array: [1 .. value_length] IN message;

      CASEND;

      get_parameter_type (parameter);
    WHILEND /get_params/;

{  If the "invalid request" parameter is returned on the chabda response
{  message, this indicates that the DI found an attribute validation
{  problem with one of the attributes specified on the chabda command.
{  The invalid parameter is sent along to indicate which parameter the
{  validation error occured on.  In the case where there is a problem with
{  the chabda command, the entire command is rejected and no other attributes
{  (if there were others specified) will be updated.

    IF invalid_param <> NIL THEN
      osp$set_status_abnormal (nfc$status_id, nfe$attribute_error_on_command,
            'CHANGE_BATCH_DEVICE_ATTRIBUTES', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            chabda_parameters [invalid_param^], status);
    ELSEIF response_code = NIL THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sou_message_reject,
            'CHANGE_BATCH_DEVICE_ATTRIBUTES', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, no_response_code, status);
    ELSEIF response_code^ <> nfc$dc_msg_accepted THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sou_command_reject,
            'CHANGE_BATCH_DEVICE_ATTRIBUTES', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            device_control_responses [response_code^], status);
    IFEND;

  PROCEND change_dev_attributes_response;

?? TITLE := '  device_control_response', EJECT ??

  PROCEDURE device_control_response (msg_type: nft$message_kind;
    VAR status:ost$status);

*copy nft$device_control_resp_msg

    VAR
      byte_array: ^nft$byte_array,
      name_string: ^STRING (* <= osc$max_name_size),
      response_code: ^nft$device_control_resp_codes,
      device_name: ost$name,
      io_station_name: ost$name,
      parameter: ^nft$device_control_resp_param,
      value_length: INTEGER;


    device_name := ' ';
    io_station_name := ' ';
    response_code := NIL;

    get_message_type;
    get_parameter_type (parameter);

 /get_params/
    WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_byte_count > 0) DO
      get_parameter_length (parameter^.length_indicated, value_length);

      CASE parameter^.param OF

      = nfc$io_station_name =
        NEXT name_string: [value_length] IN message;
        io_station_name := name_string^;

      = nfc$device_name =
        NEXT name_string: [value_length] IN message;
        device_name := name_string^;

      = nfc$response_code =
        NEXT response_code IN message;
        EXIT /get_params/;

      ELSE
{       ERROR ----   Ignore parameter value.
        NEXT byte_array: [1 .. value_length] IN message;

      CASEND;

      get_parameter_type (parameter);
    WHILEND /get_params/;

    IF response_code = NIL THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sou_message_reject, message_types [msg_type], status);
      osp$append_status_parameter (osc$status_parameter_delimiter, no_response_code, status);
    ELSEIF response_code^ <> nfc$dc_msg_accepted THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sou_command_reject, message_types [msg_type], status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            device_control_responses [response_code^], status);
    IFEND;

  PROCEND device_control_response;

?? TITLE := '  select_file_response', EJECT ??

  PROCEDURE select_file_response (VAR status:ost$status);

*copy nft$select_file_response_msg

    VAR
      byte_array: ^nft$byte_array,
      name_string: ^STRING (* <= osc$max_name_size),
      response_code: ^nft$select_file_response,
      device_name: ost$name,
      io_station_name: ost$name,
      parameter: ^nft$select_file_resp_parameter,
      value_length: INTEGER;


    device_name := ' ';
    io_station_name := ' ';
    response_code := NIL;

    get_message_type;
    get_parameter_type (parameter);

 /get_params/
    WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_byte_count > 0) DO
      get_parameter_length (parameter^.length_indicated, value_length);

      CASE parameter^.param OF

      = nfc$io_station_name =
        NEXT name_string: [value_length] IN message;
        io_station_name := name_string^;

      = nfc$system_file_name =
        NEXT name_string: [value_length] IN message;

      = nfc$response_code =
        NEXT response_code IN message;
        EXIT /get_params/;

      = nfc$device_name =
        NEXT name_string: [value_length] IN message;
        device_name := name_string^;

      ELSE
{       ERROR ----   Ignore parameter value.
        NEXT byte_array: [1 .. value_length] IN message;

      CASEND;

      get_parameter_type (parameter);
    WHILEND /get_params/;

    IF response_code = NIL THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sou_message_reject, 'SELECT_FILE', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, no_response_code, status);
    ELSEIF response_code^ <> nfc$self_msg_accepted THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sou_command_reject, 'SELECT_FILE', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            select_file_responses [response_code^], status);
    IFEND;

  PROCEND select_file_response;

?? TITLE := '  display_device_status', EJECT ??

  PROCEDURE display_device_status (output_file: clt$file;
        display_option: t$display_option;
    VAR display_control: clt$display_control;
    VAR status:ost$status);

?? NEWTITLE := '    put_display_line', EJECT ??

    PROCEDURE put_display_line (label: STRING (*);
          value: STRING (*));

      VAR
        label_str: STRING (label_size);

      label_str := label;
      IF label <> ' ' THEN
        label_str (label_size - 2, 3) := ' : ';
      IFEND;

      clp$put_partial_display (display_control, label_str, clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        EXIT display_device_status;
      IFEND;
      clp$put_partial_display (display_control, value, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        EXIT display_device_status;
      IFEND;

    PROCEND put_display_line;

?? OLDTITLE, EJECT ??

*copy nft$device_status_data_msg

    CONST
      unit_separator = $CHAR (01f(16)),
      label_size = 31;

    VAR
      banner_highlight_field: ^nft$banner_highlight_field,
      banner_page_count: ^nft$banner_page_count,
      carriage_control_action: ^nft$carriage_control_action,
      code_set: ^nft$code_set,
      destination_name: ^STRING (* <= osc$max_name_size),
      device_alias: ARRAY [1 .. 4] OF ^STRING (* <= osc$max_name_size),    { [4] is dummy }
      device_forms_size: real,
      device_name: ^STRING (* <= osc$max_name_size),
      device_status: ^nft$device_status,
      device_type: ^nft$device_type,
      external_characteristics: ARRAY [1 .. 4] OF ^STRING (* <= jmc$ext_characteristics_size),
      family_name: ^STRING (* <= osc$max_name_size),
      file_acknowledge: ^BOOLEAN,
      file_transfer_status: ^nft$file_transfer_status,
      forms_code: ARRAY [1 .. 4] OF ^STRING (* <= jmc$forms_code_size),
      forms_size: ^nft$forms_size,
      fs_vpd_specified: boolean,
      i: 1 .. osc$max_string_size,
      input_bytes_transferred: ^nft$input_job_size,
      byte_array: ^nft$byte_array,
      io_station_name: ^STRING (* <= osc$max_name_size),
      labl: ost$name,
      last_message: ^STRING (*  <= osc$max_string_size ),
      line_size: 0 .. osc$max_string_size,
      max_file_size: ^nft$device_file_size,
      msg_size: 0 .. osc$max_string_size,
      owner_status: ost$status,
      page_length: ^nft$page_length,
      page_width: ^nft$page_width,
      parameter: ^nft$device_sd_msg_param,
      percent_complete: ^nft$file_position,
      response_code: ^nft$display_status_resp_codes,
      response_code_required: BOOLEAN,
      str: ost$string,
      str_length: integer,
      str_value: string (80),
      suppress_carriage_control: ^BOOLEAN,
      system_file_name: ^STRING (* <= osc$max_name_size),
      system_job_name: ^STRING (* <= osc$max_name_size),
      terminal_model: ^STRING (* <= nfc$max_terminal_model_size),
      transmission_block_size: ^nft$transmit_block_size,
      undefined_fe_action: ^nft$format_effector_actions,
      unsupported_fe_action: ^nft$format_effector_actions,
      user_file_name: ^STRING (* <= osc$max_name_size),
      user_job_name: ^STRING (* <= osc$max_name_size),
      user_name: ^STRING (* <= osc$max_name_size),
      value_length: INTEGER,
      vfu_load_option: ^nft$vfu_load_option,
      vertical_print_density: ^nft$vertical_print_density,
      vfu_load_procedure: ^STRING (* <= osc$max_name_size);


    response_code_required := TRUE;

    get_message_type;
    get_parameter_type(parameter);

    WHILE (msg_byte_count > 0) AND (parameter <> NIL) DO
      banner_highlight_field := NIL;
      banner_page_count := NIL;
      carriage_control_action := NIL;
      code_set := NIL;
      destination_name := NIL;
      device_name := NIL;
      device_status := NIL;
      device_type := NIL;
      family_name := NIL;
      file_acknowledge := NIL;
      file_transfer_status := NIL;
      forms_size := NIL;
      fs_vpd_specified := FALSE;
      input_bytes_transferred := NIL;
      io_station_name := NIL;
      last_message := NIL;
      max_file_size := NIL;
      page_length := NIL;
      page_width := NIL;
      percent_complete := NIL;
      response_code := NIL;
      suppress_carriage_control := NIL;
      system_file_name := NIL;
      system_job_name := NIL;
      terminal_model := NIL;
      transmission_block_size := NIL;
      undefined_fe_action := NIL;
      unsupported_fe_action := NIL;
      user_file_name := NIL;
      user_job_name := NIL;
      user_name := NIL;
      vfu_load_option := NIL;
      vertical_print_density := NIL;
      vfu_load_procedure := NIL;

      FOR i := 1 TO 4 DO
        device_alias [i] := NIL;
        external_characteristics [i] := NIL;
        forms_code [i] := NIL;
      FOREND;

      owner_status.normal := FALSE;


   /get_parameters/
      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_byte_count > 0) DO
        get_parameter_length (parameter^.length_indicated, value_length);
        IF value_length = 0 THEN
          get_parameter_type (parameter);
          CYCLE /get_parameters/;
        IFEND;

        CASE parameter^.param OF

        = nfc$io_station_name =
          NEXT io_station_name: [value_length] IN message;

        = nfc$device_name =
          NEXT device_name: [value_length] IN message;

        = nfc$response_code =
          NEXT response_code IN message;

        = nfc$device_status =
          NEXT device_status IN message;

        = nfc$device_type =
          NEXT device_type IN message;

        = nfc$file_transfer_status_param =
          NEXT file_transfer_status IN message;

        = nfc$terminal_model =
          NEXT terminal_model: [value_length] IN message;

        = nfc$file_acknowledgement =
          NEXT file_acknowledge IN message;

        = nfc$maximum_file_size =
          NEXT max_file_size IN message;

        = nfc$page_length =
          NEXT page_length IN message;

        = nfc$page_width =
          NEXT page_width IN message;

        = nfc$banner_page_count =
          NEXT banner_page_count IN message;

        = nfc$banner_highlight_field =
          NEXT banner_highlight_field IN message;

        = nfc$transmission_block_size =
          NEXT transmission_block_size IN message;

        = nfc$carriage_control_action =
          NEXT carriage_control_action IN message;

        = nfc$suppress_carriage_control =
          NEXT suppress_carriage_control IN message;

        = nfc$forms_code_1 =
          NEXT forms_code [1]: [value_length] IN message;

        = nfc$forms_code_2 =
          NEXT forms_code [2]: [value_length] IN message;

        = nfc$forms_code_3 =
          NEXT forms_code [3]: [value_length] IN message;

        = nfc$forms_code_4 =
          NEXT forms_code [4]: [value_length] IN message;

        = nfc$external_characteristics_1 =
          NEXT external_characteristics [1]: [value_length] IN message;

        = nfc$external_characteristics_2 =
          NEXT external_characteristics [2]: [value_length] IN message;

        = nfc$external_characteristics_3 =
          NEXT external_characteristics [3]: [value_length] IN message;

        = nfc$external_characteristics_4 =
          NEXT external_characteristics [4]: [value_length] IN message;

        = nfc$device_alias_1 =
          NEXT device_alias [1]: [value_length] IN message;

        = nfc$device_alias_2 =
          NEXT device_alias [2]: [value_length] IN message;

        = nfc$device_alias_3 =
          NEXT device_alias [3]: [value_length] IN message;

        = nfc$percent_complete =
          NEXT percent_complete IN message;

        = nfc$last_unsolicited_msg =
          IF value_length <> 0 THEN
            NEXT last_message: [value_length] IN message;
          IFEND;

        = nfc$system_file_name =
          NEXT system_file_name: [value_length] IN message;
          check_file_ownership (system_file_name^, owner_status);

        = nfc$user_file_name =
          NEXT user_file_name: [value_length] IN message;

        = nfc$system_job_name =
          NEXT system_job_name: [value_length] IN message;

        = nfc$user_job_name =
          NEXT user_job_name: [value_length] IN message;

        = nfc$user_name =
          NEXT user_name: [value_length] IN message;

        = nfc$family_name =
          NEXT family_name: [value_length] IN message;

        = nfc$code_set =
          NEXT code_set IN message;

        = nfc$forms_size =
          NEXT forms_size IN message;

  {  Flag the fact that the forms_size value was specified and that page_length
  {  should not be displayed

          fs_vpd_specified := TRUE;

        = nfc$undefined_fe_action =
          NEXT undefined_fe_action IN message;

        = nfc$unsupported_fe_action =
          NEXT unsupported_fe_action IN message;

        = nfc$vertical_print_density =
          NEXT vertical_print_density IN message;

  {  Flag the fact that the vertical_print_density value was specified and that page_length
  {  should not be displayed

          fs_vpd_specified := TRUE;

        = nfc$vfu_load_procedure =
          NEXT vfu_load_procedure: [value_length] IN message;

        = nfc$vfu_load_option =
          NEXT vfu_load_option IN message;

        = nfc$destination_name =
          NEXT destination_name: [value_length] IN message;

        = nfc$input_bytes_transferred =
          NEXT input_bytes_transferred IN message;

        ELSE
  {       ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;

        get_parameter_type (parameter);
      WHILEND /get_parameters/;

      IF response_code_required THEN
        IF response_code = NIL THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sou_message_reject,
                'GET_DEVICE_STATUS', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, no_response_code, status);
          RETURN;
        ELSEIF response_code^ <> nfc$disp_msg_accepted THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sou_command_reject,
                'DISPLAY_BATCH_DEVICE_STATUS', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                display_status_responses [response_code^], status);
          RETURN;
        IFEND;

        response_code_required := FALSE;
      IFEND;

      IF device_name <> NIL THEN
        put_display_line ('Device_Name', device_name^);
      IFEND;

      IF (display_option = display_all) THEN
        IF (banner_highlight_field <> NIL) THEN
          put_display_line ('  Banner_Highlight_Field', banner_highlight_fields [banner_highlight_field^]);
        IFEND;

        IF (banner_page_count <> NIL) THEN
          clp$convert_integer_to_string ($INTEGER(banner_page_count^), 10, FALSE, str, status);
          put_display_line ('  Banner_Page_Count', str.value (1, str.size));
        IFEND;

        IF (carriage_control_action <> NIL) THEN
          put_display_line ('  Carriage_Control_Action', carriage_control_actions [carriage_control_action^]);
        IFEND;

        IF (code_set <> NIL) THEN
          put_display_line ('  Code_Set', code_sets [code_set^]);
        IFEND;

        IF (device_alias [1] <> NIL) THEN
          put_display_line ('  Device_Alias_1', device_alias [1]^);
        IFEND;

        IF (device_alias [2] <> NIL) THEN
          put_display_line ('  Device_Alias_2', device_alias [2]^);
        IFEND;

        IF (device_alias [3] <> NIL) THEN
          put_display_line ('  Device_Alias_3', device_alias [3]^);
        IFEND;
      IFEND;

      IF device_status <> NIL THEN
        put_display_line ('  Device_Status', device_statuses [device_status^]);
      IFEND;

      IF (display_option = display_all) THEN
        IF (device_type <> NIL) THEN
          put_display_line ('  Device_Type', device_types [device_type^]);
        IFEND;

        IF (external_characteristics [1] <> NIL) THEN
          put_display_line ('  External_Characteristics_1', external_characteristics [1]^);
        IFEND;

        IF (external_characteristics [2] <> NIL) THEN
          put_display_line ('  External_Characteristics_2', external_characteristics [2]^);
        IFEND;

        IF (external_characteristics [3] <> NIL) THEN
          put_display_line ('  External_Characteristics_3', external_characteristics [3]^);
        IFEND;

        IF (external_characteristics [4] <> NIL) THEN
          put_display_line ('  External_Characteristics_4', external_characteristics [4]^);
        IFEND;

        IF (file_acknowledge <> NIL) THEN
          put_display_line ('  File_Acknowledgement', boolean_values [file_acknowledge^]);
        IFEND;
      IFEND;

      IF file_transfer_status <> NIL THEN
        put_display_line ('  File_Transfer_Status', file_transfer_statuses [file_transfer_status^]);
      IFEND;

      IF (display_option = display_all) THEN
        IF (forms_code [1] <> NIL) THEN
          put_display_line ('  Forms_Code_1', forms_code [1]^);
        IFEND;

        IF (forms_code [2] <> NIL) THEN
          put_display_line ('  Forms_Code_2', forms_code [2]^);
        IFEND;

        IF (forms_code [3] <> NIL) THEN
          put_display_line ('  Forms_Code_3', forms_code [3]^);
        IFEND;

        IF (forms_code [4] <> NIL) THEN
          put_display_line ('  Forms_Code_4', forms_code [4]^);
        IFEND;

        IF (forms_size <> NIL) THEN

  {  forms size for a device is stored internally as double the value }

          device_forms_size := $REAL (forms_size^)/2.0;
          STRINGREP (str_value, str_length, device_forms_size:5:1);
          put_display_line ('  Forms_Size', str_value (1, str_length));
        IFEND;
      IFEND;

      IF (input_bytes_transferred <> NIL) THEN
        clp$convert_integer_to_string ($INTEGER(input_bytes_transferred^), 10, FALSE, str, status);
        put_display_line ('  Input_Bytes_Transferred', str.value (1, str.size));
      IFEND;

      IF (display_option = display_all) THEN
        IF (destination_name <> NIL) AND ((station_operator) OR (owner_status.normal)) THEN
          put_display_line ('  Job_Destination_Name', destination_name^);
        IFEND;
      IFEND;

      IF last_message <> NIL THEN
        labl := '  Last_Unsolicited_Message';
        line_size := display_control.page_width - label_size - 1;
        msg_size := stringsize (last_message^);

        WHILE msg_size > 0 DO
       /scan_msg/
          FOR i := 1 TO msg_size DO
            IF i >= line_size THEN
              EXIT /scan_msg/;
            ELSEIF last_message^ (i) = unit_separator THEN
              last_message^ (i) := ' ';
              EXIT /scan_msg/;
            IFEND;
          FOREND /scan_msg/;

          put_display_line (labl, last_message^ (1, i));
          labl := ' ';
          last_message^ := last_message^ (i+1, *);
          msg_size :=msg_size - i;
        WHILEND;
      IFEND;

      IF (display_option = display_all) THEN
        IF (page_length <> NIL) AND (NOT fs_vpd_specified) THEN
          clp$convert_integer_to_string ($INTEGER(page_length^), 10, FALSE, str, status);
          put_display_line ('  Page_Length', str.value (1, str.size));
        IFEND;

        IF (page_width <> NIL) THEN
          clp$convert_integer_to_string ($INTEGER(page_width^), 10, FALSE, str, status);
          put_display_line ('  Page_Width', str.value (1, str.size));
        IFEND;

        IF (max_file_size <> NIL) THEN
          IF max_file_size^ = 0 THEN
            str.value := 'unlimited';
            str.size := 9;
          ELSE
            clp$convert_integer_to_string ($INTEGER(max_file_size^), 10, FALSE, str, status);
          IFEND;
          put_display_line ('  Maximum_File_Size', str.value (1, str.size));
        IFEND;

        IF (suppress_carriage_control <> NIL) THEN
          put_display_line ('  Suppress_Carriage_Control', boolean_values [suppress_carriage_control^]);
        IFEND;

        IF (terminal_model <> NIL) THEN
          put_display_line ('  Terminal_Model', terminal_model^);
        IFEND;

        IF (transmission_block_size <> NIL) THEN
          clp$convert_integer_to_string ($INTEGER(transmission_block_size^), 10, FALSE, str, status);
          put_display_line ('  Transmission_Block_Size', str.value (1, str.size));
        IFEND;

        IF (undefined_fe_action <> NIL) THEN
          put_display_line ('  Undefined_FE_Action', format_effector_actions [undefined_fe_action^]);
        IFEND;

        IF (unsupported_fe_action <> NIL) THEN
          put_display_line ('  Unsupported_FE_Action', format_effector_actions [unsupported_fe_action^]);
        IFEND;

        IF (vertical_print_density <> NIL) THEN
          put_display_line ('  Vertical_Print_Density', vpd_actions
                [vertical_print_density^]);
        IFEND;

        IF (vfu_load_option <> NIL) THEN
          put_display_line ('  VFU_Load_Option', vfu_load_option_actions [vfu_load_option^]);
        IFEND;

        IF (vfu_load_procedure <> NIL) THEN
          put_display_line ('  VFU_Load_Procedure', vfu_load_procedure^);
        IFEND;

        IF (family_name <> NIL) AND ((station_operator) OR (owner_status.normal)) THEN
          put_display_line ('  Family_Name', family_name^);
        IFEND;

        IF (user_name <> NIL) AND ((station_operator) OR (owner_status.normal)) THEN
          put_display_line ('  Login_User_Name', user_name^);
        IFEND;
      IFEND;

      IF (percent_complete <> NIL) THEN
        clp$convert_integer_to_string ($INTEGER(percent_complete^), 10, FALSE, str, status);
        put_display_line ('  Percent_Complete', str.value (1, str.size));
      IFEND;

      IF (display_option = display_all) THEN
        IF (system_file_name <> NIL) THEN
          put_display_line ('  System_Supplied_File_Name', system_file_name^);
        IFEND;

        IF (system_job_name <> NIL) AND ((station_operator) OR (owner_status.normal)) THEN
          put_display_line ('  System_Supplied_Job_Name', system_job_name^);
        IFEND;

        IF (user_file_name <> NIL) AND ((station_operator) OR (owner_status.normal)) THEN
          put_display_line ('  User_Supplied_File_Name', user_file_name^);
        IFEND;

        IF (user_job_name <> NIL) AND ((station_operator) OR (owner_status.normal)) THEN
          put_display_line ('  User_Supplied_Job_Name', user_job_name^);
        IFEND;
      IFEND;
      IF (display_control.line_number < display_control.page_length) OR
            (display_control.page_format = amc$continuous_form) THEN
        clp$put_display (display_control, ' ', clc$trim, status);
      IFEND;
      IF (msg_byte_count > 0) THEN
        get_parameter_type (parameter);
      IFEND;
    WHILEND;

  PROCEND display_device_status;

?? TITLE := '  display_station_status', EJECT ??

  PROCEDURE display_station_status (output_file: clt$file;
    VAR display_control: clt$display_control;
    VAR status:ost$status);

?? NEWTITLE := '    put_display_line', EJECT ??

    PROCEDURE put_display_line (label: STRING (*);
          value: STRING (*));

      VAR
        label_str: STRING (label_size);

      label_str := label;
      IF label <> ' ' THEN
        label_str (label_size - 2, 3) := ' : ';
      IFEND;

      clp$put_partial_display (display_control, label_str, clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        EXIT display_station_status;
      IFEND;
      clp$put_partial_display (display_control, value, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        EXIT display_station_status;
      IFEND;

    PROCEND put_display_line;

?? OLDTITLE, EJECT ??

*copy nft$station_status_msg

    CONST
      device_status_size = 32,
      file_status_size = 9,
      label_size = 35,
      line = '  ----------------------------------------------------------------------';

    VAR
      byte_array: ^nft$byte_array,
      control_facility_name: ^STRING (* <= osc$max_name_size),
      count_of_devices: ^INTEGER,
      default_job_destination: ^STRING (* <= osc$max_name_size),
      destination_unavailable_action: ^nft$destination_unavail_actions,
      device_name: STRING (33),
      device_status: STRING (16),
      device_statuses: [STATIC, READ] ARRAY [nft$device_status] OF STRING (device_status_size) :=
          [ {nfc$device_active} 'active',       {nfc$device_stopped} 'stopped',
            {nfc$device_not_ready} 'not ready', {nfc$device_down} 'down',
            {nfc$device_loading_vfu} 'loading DLP',
            {nfc$default_vfu_not_loadable} 'can''t load DLP',
            {nfc$device_stopped_by_system} 'system stopped',
            {nfc$device_status_reserved_7} ' ',
            {nfc$device_status_reserved_8} ' ',
            {nfc$device_status_reserved_9} ' ',
            {nfc$device_status_reserved_10} ' ',
            {nfc$ntf_waiting_signon} ' ',
            {nfc$ntf_signon_initiated} ' ',
            {nfc$ntf_signed_on} ' ',
            {nfc$ntf_signon_failed} ' ',
            {nfc$ntf_signed_off} ' '],
      device_status_data: ^ARRAY [1 .. *] OF ^nft$device_status_data,
      device_type: STRING (10),
      dev_count: INTEGER,
      display_line: STRING(80),
      empty_value: STRING(4),
      file_transfer_status: STRING (11),
      file_transfer_statuses: [STATIC, READ] ARRAY [nft$file_transfer_status] OF STRING (file_status_size) :=
          [ REP 8 OF 'idle',
            {nfc$busy} 'busy',
            REP 7 OF 'suspended'],
      file_acknowledge: ^BOOLEAN,
      i: 1 .. 3,
      io_station_alias: ARRAY [1 .. 3] OF ^STRING (* <= osc$max_name_size),
      io_station_name: ^STRING (* <= osc$max_name_size),
      num_files_queued: ^INTEGER,
      parameter: ^nft$station_status_msg_param,
      pm_message_action: ^nft$pm_message_actions,
      required_console_device: ^STRING (* <= osc$max_name_size),
      response_code: ^nft$display_status_resp_codes,
      station_usage: ^nft$io_station_usage,
      string_length: INTEGER,
      str: ost$string,
      value_length: INTEGER;

    control_facility_name := NIL;
    count_of_devices := NIL;
    default_job_destination := NIL;
    destination_unavailable_action := NIL;
    device_name := ' ';
    device_status := ' ';
    device_type := ' ';
    device_status_data := NIL;
    dev_count := 0;
    empty_value := 'none';
    file_acknowledge := NIL;
    io_station_name := NIL;
    num_files_queued := NIL;
    pm_message_action := NIL;
    required_console_device := NIL;
    response_code := NIL;
    station_usage := NIL;
    FOR i := 1 TO 3 DO
      io_station_alias [i] := NIL;
    FOREND;

    get_message_type;
    get_parameter_type (parameter);

 /get_parameters/
    WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_byte_count > 0) DO
      get_parameter_length (parameter^.length_indicated, value_length);
      IF value_length = 0 THEN
        get_parameter_type (parameter);
        CYCLE /get_parameters/;
      IFEND;

      CASE parameter^.param OF

      = nfc$io_station_name =
        NEXT io_station_name: [value_length] IN message;

      = nfc$control_facility =
        NEXT control_facility_name: [value_length] IN message;

      = nfc$response_code =
        NEXT response_code IN message;

      = nfc$number_of_files_queued =
        NEXT num_files_queued IN message;

      = nfc$station_usage =
        NEXT station_usage IN message;

      = nfc$file_acknowledgement =
        NEXT file_acknowledge IN message;

      = nfc$count_of_devices =
        IF count_of_devices <> NIL THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
                'STATION_STATUS_DATA', status);
          RETURN;
        IFEND;
        NEXT count_of_devices IN message;
        PUSH device_status_data: [1 .. count_of_devices^];

      = nfc$device_name_status =
        dev_count := dev_count +1;
        IF (count_of_devices = NIL) OR (dev_count > count_of_devices^) THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
                'STATION_STATUS_DATA', status);
          RETURN;
        IFEND;
        NEXT device_status_data^ [dev_count]: [value_length -3] IN message;

      = nfc$req_console_device =
        NEXT required_console_device: [value_length] IN message;

      = nfc$io_station_alias_1 =
        NEXT io_station_alias [1]: [value_length] IN message;

      = nfc$io_station_alias_2 =
        NEXT io_station_alias [2]: [value_length] IN message;

      = nfc$io_station_alias_3 =
        NEXT io_station_alias [3]: [value_length] IN message;

      = nfc$default_job_destination =
        NEXT default_job_destination: [value_length] IN message;

      = nfc$destination_unavail_action =
        NEXT destination_unavailable_action IN message;

      = nfc$pm_message_action =
        NEXT pm_message_action IN message;


      ELSE
{       ERROR ----   Ignore parameter value.
        NEXT byte_array: [1 .. value_length] IN message;

      CASEND;

      get_parameter_type (parameter);
    WHILEND /get_parameters/;

    IF response_code = NIL THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sou_message_reject,
            'GET_STATION_STATUS', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, no_response_code, status);
      RETURN;
    ELSEIF response_code^ <> nfc$disp_msg_accepted THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sou_message_reject,
            'GET_STATION_STATUS', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            display_status_responses [response_code^], status);
      RETURN;
    IFEND;

    IF (count_of_devices <> NIL) AND (dev_count <> count_of_devices^) THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
            'STATION_STATUS_DATA', status);
      RETURN;
    IFEND;

    IF io_station_name <> NIL THEN
      put_display_line ('Station_Name', io_station_name^);
    IFEND;

    IF control_facility_name <> NIL THEN
      put_display_line ('  Control_Facility_Name', control_facility_name^);
    IFEND;

    IF default_job_destination <> NIL THEN
      put_display_line ('  Default_Job_Destination', default_job_destination^);
    IFEND;

    IF destination_unavailable_action <> NIL THEN
      put_display_line ('  Destination_Unavailable_Action', destination_unavail_actions
            [destination_unavailable_action^]);
    IFEND;

    IF file_acknowledge <> NIL THEN
      put_display_line ('  File_Acknowledgement', boolean_values [file_acknowledge^]);
    IFEND;

    IF num_files_queued <> NIL THEN
      clp$convert_integer_to_string (num_files_queued^, 10, FALSE, str, status);
      put_display_line ('  Number_Of_Files_Queued', str.value (1, str.size));
    IFEND;

    IF pm_message_action <> NIL THEN
      put_display_line ('  PM_Message_Action', pm_message_actions [pm_message_action^]);
    IFEND;

    IF required_console_device <> NIL THEN
      put_display_line ('  Required_Console_Device', required_console_device^);
    ELSE
      put_display_line ('  Required_Console_Device', empty_value);
    IFEND;

    IF io_station_alias [1] <> NIL THEN
      put_display_line ('  Station_Alias_1', io_station_alias [1]^);
    IFEND;

    IF io_station_alias [2] <> NIL THEN
      put_display_line ('  Station_Alias_2', io_station_alias [2]^);
    IFEND;

    IF io_station_alias [3] <> NIL THEN
      put_display_line ('  Station_Alias_3', io_station_alias [3]^);
    IFEND;

    IF station_usage <> NIL THEN
      put_display_line ('  Station_Usage', station_usages [station_usage^]);
    IFEND;

    IF count_of_devices <> NIL THEN
      clp$convert_integer_to_string (count_of_devices^, 10, FALSE, str, status);
      put_display_line ('  Count_Of_Devices', str.value (1, str.size));

      put_display_line (' ', ' ');

      device_name := 'Device_Name';
      device_type := 'Type';
      device_status := 'Device_Status';
      file_transfer_status := 'File_Status';

      STRINGREP (display_line, string_length, '  ', device_name, device_type,
            device_status, file_transfer_status);
      clp$put_display (display_control, display_line (1, string_length), clc$trim, status);
      IF NOT status.normal THEN
        EXIT display_station_status;
      IFEND;

      clp$put_display (display_control, line, clc$trim, status);
      IF NOT status.normal THEN
        EXIT display_station_status;
      IFEND;

      FOR dev_count := 1 TO count_of_devices^ DO
        device_name := device_status_data^ [dev_count]^.name;
        device_type := device_types [device_status_data^ [dev_count]^.
              device_type];
        device_status := device_statuses [device_status_data^ [dev_count]^.
              device_status];
        file_transfer_status := file_transfer_statuses [device_status_data^
              [dev_count]^.file_xfer_status];

        STRINGREP (display_line, string_length, '  ', device_name, device_type,
              device_status, file_transfer_status);
        clp$put_display (display_control, display_line (1, string_length), clc$trim, status);
        IF NOT status.normal THEN
          EXIT display_station_status;
        IFEND;
      FOREND;
    IFEND;

  PROCEND display_station_status;

?? TITLE := '  display_queue_status', EJECT ??

  PROCEDURE display_queue_status (output_file: clt$file;
        display_option: t$display_option;
    VAR display_control: clt$display_control;
    VAR status:ost$status);

?? NEWTITLE := '    build_private_station_dest', EJECT ??

    PROCEDURE build_private_station_dest (destination_and_status: nft$q_status_data;
      VAR private_destination: ^string (*));

      CONST
        comma_blank = ', ',
        blanks_and_commas_length = 4;

      VAR
        destination_length: 0 .. 0ff(16),
        operator_family_length: 0 .. 0ff(16),
        operator_name_length: 0 .. 0ff(16),
        position: 0 .. 0ff(16),
        private_destination_length: 0 .. 0ff(16);


      operator_name_length := stringsize (destination_and_status.operator_name);
      operator_family_length := stringsize (destination_and_status.operator_family);
      destination_length := stringsize (destination_and_status.name);
      private_destination_length := blanks_and_commas_length + operator_name_length + operator_family_length +
            destination_length;

      ALLOCATE private_destination: [private_destination_length];

      position := 1;
      private_destination^ (position, destination_length) := destination_and_status.name;
      position := position + destination_length;
      private_destination^ (position, 2) := comma_blank;
      position := position + 2;
      private_destination^ (position, operator_name_length) := destination_and_status.operator_name;
      position := position + operator_name_length;
      private_destination^ (position, 2) := comma_blank;
      position := position + 2;
      private_destination^ (position, operator_family_length) := destination_and_status.operator_family;

    PROCEND build_private_station_dest;
?? TITLE := '    put_display_line', EJECT ??

    PROCEDURE put_display_line (label: STRING (*);
          value: STRING (*));

      VAR
        label_str: STRING (label_size);

      label_str := label;
      IF label <> ' ' THEN
        label_str (label_size - 2, 3) := ' : ';
      IFEND;

      clp$put_partial_display (display_control, label_str, clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        EXIT display_queue_status;
      IFEND;
      clp$put_partial_display (display_control, value, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        EXIT display_queue_status;
      IFEND;

    PROCEND put_display_line;

?? OLDTITLE, EJECT ??

*copy nft$queue_status_data_msg

    CONST
      label_size = 31;

    VAR
      byte_array: ^nft$byte_array,
      io_station_name: ^STRING (* <= osc$max_name_size),
      response_code: ^nft$display_status_resp_codes,
      file_count: ^INTEGER,
      count_ext_characteristics: ^INTEGER,
      ext_chrstcs_and_status: ^ARRAY [1 .. *] OF ^nft$q_status_data,
      count_forms_codes: ^INTEGER,
      forms_codes_and_status: ^ARRAY [1 .. *] OF ^nft$q_status_data,
      count_devices: ^INTEGER,
      device_names_and_status: ^ARRAY [1 .. *] OF ^nft$q_status_data,
      count_destinations: ^INTEGER,
      destinations_and_status: ^ARRAY [1 .. *] OF ^nft$q_status_data,
      count_device_types: ^INTEGER,
      device_types_and_status: ^ARRAY [1 .. *] OF ^nft$q_status_data,
      ec_count: INTEGER,
      fc_count: INTEGER,
      dev_count: INTEGER,
      dest_count: INTEGER,
      dt_count: INTEGER,
      parameter: ^nft$queue_status_msg_parameter,
      private_station_destination: ^string (*),
      value_length: INTEGER,
      str: ost$string;


    io_station_name := NIL;
    response_code := NIL;
    file_count := NIL;
    count_ext_characteristics := NIL;
    ext_chrstcs_and_status := NIL;
    count_forms_codes := NIL;
    forms_codes_and_status := NIL;
    count_devices := NIL;
    device_names_and_status := NIL;
    count_destinations := NIL;
    destinations_and_status := NIL;
    count_device_types := NIL;
    device_types_and_status := NIL;
    ec_count := 0;
    fc_count := 0;
    dev_count := 0;
    dest_count := 0;
    dt_count := 0;

    get_message_type;
    get_parameter_type (parameter);

 /get_parameters/
    WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_byte_count > 0) DO
      get_parameter_length (parameter^.length_indicated, value_length);
      IF value_length = 0 THEN
        get_parameter_type (parameter);
        CYCLE /get_parameters/;
      IFEND;

      CASE parameter^.param OF

      = nfc$io_station_name =
        NEXT io_station_name: [value_length] IN message;

      = nfc$response_code =
        NEXT response_code IN message;

      = nfc$file_count =
        NEXT file_count IN message;

      = nfc$ext_chars_count =
        IF count_ext_characteristics <> NIL THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
                'QUEUE_STATUS_DATA', status);
          RETURN;
        IFEND;
        NEXT count_ext_characteristics IN message;
        IF count_ext_characteristics^ > 0 THEN
          PUSH ext_chrstcs_and_status: [1 .. count_ext_characteristics^];
        IFEND;

      = nfc$ext_char_and_files =
        ec_count := ec_count + 1;
        IF (count_ext_characteristics = NIL) OR (ec_count > count_ext_characteristics^) THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
                'QUEUE_STATUS_DATA', status);
          RETURN;
        IFEND;
        NEXT ext_chrstcs_and_status^ [ec_count]: [value_length - nfc$fixed_q_status_data_length] IN message;

      = nfc$forms_code_count =
        IF count_forms_codes <> NIL THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
                'QUEUE_STATUS_DATA', status);
          RETURN;
        IFEND;
        NEXT count_forms_codes IN message;
        IF count_forms_codes^ > 0 THEN
          PUSH forms_codes_and_status: [1 .. count_forms_codes^];
        IFEND;

      = nfc$forms_code_and_files =
        fc_count := fc_count + 1;
        IF (count_forms_codes = NIL) OR (fc_count > count_forms_codes^) THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
                'QUEUE_STATUS_DATA', status);
          RETURN;
        IFEND;
        NEXT forms_codes_and_status^ [fc_count]: [value_length - nfc$fixed_q_status_data_length] IN message;

      = nfc$device_count =
        IF count_devices <> NIL THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
                'QUEUE_STATUS_DATA', status);
          RETURN;
        IFEND;
        NEXT count_devices IN message;
        IF count_devices^ > 0 THEN
          PUSH device_names_and_status: [1 .. count_devices^];
        IFEND;

      = nfc$device_names_and_files =
        dev_count := dev_count + 1;
        IF (count_devices = NIL) OR (dev_count > count_devices^) THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
                'QUEUE_STATUS_DATA', status);
          RETURN;
        IFEND;
        NEXT device_names_and_status^ [dev_count]: [value_length - nfc$fixed_q_status_data_length] IN message;

      = nfc$destination_count =
        IF count_destinations <> NIL THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
                'QUEUE_STATUS_DATA', status);
          RETURN;
        IFEND;
        NEXT count_destinations IN message;
        IF count_destinations^ > 0 THEN
          PUSH destinations_and_status: [1 .. count_destinations^];
        IFEND;

      = nfc$destinations_and_files =
        dest_count := dest_count + 1;
        IF (count_destinations = NIL) OR (dest_count > count_destinations^) THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
                'QUEUE_STATUS_DATA', status);
          RETURN;
        IFEND;
        NEXT destinations_and_status^ [dest_count]: [value_length - nfc$fixed_q_status_data_length] IN
              message;

      = nfc$device_type_count =
        IF count_device_types <> NIL THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
                'QUEUE_STATUS_DATA', status);
          RETURN;
        IFEND;
        NEXT count_device_types IN message;
        IF count_device_types^ > 0 THEN
          PUSH device_types_and_status: [1 .. count_device_types^];
        IFEND;

      = nfc$device_types_and_files =
        dt_count := dt_count + 1;
        IF (count_device_types = NIL) OR (dt_count > count_device_types^) THEN
          osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
                'QUEUE_STATUS_DATA', status);
          RETURN;
        IFEND;
        NEXT device_types_and_status^ [dt_count]: [value_length - nfc$fixed_q_status_data_length] IN message;

      ELSE
{       ERROR ----   Ignore parameter value.
        NEXT byte_array: [1 .. value_length] IN message;

      CASEND;

      get_parameter_type (parameter);
    WHILEND /get_parameters/;

    IF response_code = NIL THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sou_message_reject,
            'GET_QUEUE_STATUS', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, no_response_code, status);
      RETURN;
    ELSEIF response_code^ <> nfc$disp_msg_accepted THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sou_message_reject,
            'GET_QUEUE_STATUS', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            display_status_responses [response_code^], status);
      RETURN;
    IFEND;

    IF ((count_ext_characteristics <> NIL) AND (ec_count <> count_ext_characteristics^))
          OR ((count_forms_codes <> NIL) AND (fc_count <> count_forms_codes^))
          OR ((count_devices <> NIL) AND (dev_count <> count_devices^))
          OR ((count_destinations <> NIL) AND (dest_count <> count_destinations^))
          OR ((count_device_types <> NIL) AND (dt_count <> count_device_types^)) THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sou_message_format_error,
            'QUEUE_STATUS_DATA', status);
      RETURN;
    IFEND;

    IF io_station_name <> NIL THEN
      put_display_line ('Station_Name', io_station_name^);
    IFEND;

    IF (file_count <> NIL) THEN
      clp$convert_integer_to_string (file_count^, 10, FALSE, str, status);
      put_display_line ('Number_Of_Files', str.value (1, str.size));
    IFEND;

    IF (display_option = display_all) THEN
      IF (count_destinations <> NIL) THEN
        FOR dest_count := 1 TO count_destinations^ DO
          IF destinations_and_status^ [dest_count]^.name = station_name THEN
            put_display_line ('  Destination', destinations_and_status^ [dest_count]^.name);
          ELSE
            build_private_station_dest (destinations_and_status^ [1]^, private_station_destination);
            put_display_line ('  Destination', private_station_destination^);
            FREE private_station_destination;
          IFEND;
          clp$convert_integer_to_string (destinations_and_status^ [dest_count]^.oldest_age,
                10, FALSE, str, status);
          put_display_line ('    Age_of_Oldest_File', str.value (1, str.size));
          clp$convert_integer_to_string (destinations_and_status^ [dest_count]^.average_age,
                10, FALSE, str, status);
          put_display_line ('    Average_Age_of_Files', str.value (1, str.size));
          clp$convert_integer_to_string (destinations_and_status^ [dest_count]^.file_count,
                10, FALSE, str, status);
          put_display_line ('    File_Count', str.value (1, str.size));
          clp$convert_integer_to_string (destinations_and_status^ [dest_count]^.total_size,
                10, FALSE, str, status);
          put_display_line ('    Total_File_Size', str.value (1, str.size));
        FOREND;
      IFEND;

      IF (count_devices <> NIL) THEN
        FOR dev_count := 1 TO count_devices^ DO
          put_display_line ('  Device_Name', device_names_and_status^ [dev_count]^.name);
          clp$convert_integer_to_string (device_names_and_status^ [dev_count]^.oldest_age,
                10, FALSE, str, status);
          put_display_line ('    Age_of_Oldest_File', str.value (1, str.size));
          clp$convert_integer_to_string (device_names_and_status^ [dev_count]^.average_age,
                10, FALSE, str, status);
          put_display_line ('    Average_Age_of_Files', str.value (1, str.size));
          clp$convert_integer_to_string (device_names_and_status^ [dev_count]^.file_count,
                10, FALSE, str, status);
          put_display_line ('    File_Count', str.value (1, str.size));
          clp$convert_integer_to_string (device_names_and_status^ [dev_count]^.total_size,
                10, FALSE, str, status);
          put_display_line ('    Total_File_Size', str.value (1, str.size));
        FOREND;
      IFEND;
    IFEND;

    IF count_device_types <> NIL THEN
      FOR dt_count := 1 TO count_device_types^ DO
        put_display_line ('  Device_Type', device_types_and_status^ [dt_count]^.name);
        clp$convert_integer_to_string (device_types_and_status^ [dt_count]^.oldest_age,
              10, FALSE, str, status);
        put_display_line ('    Age_of_Oldest_File', str.value (1, str.size));
        clp$convert_integer_to_string (device_types_and_status^ [dt_count]^.average_age,
              10, FALSE, str, status);
        put_display_line ('    Average_Age_of_Files', str.value (1, str.size));
        clp$convert_integer_to_string (device_types_and_status^ [dt_count]^.file_count,
              10, FALSE, str, status);
        put_display_line ('    File_Count', str.value (1, str.size));
        clp$convert_integer_to_string (device_types_and_status^ [dt_count]^.total_size,
              10, FALSE, str, status);
        put_display_line ('    Total_File_Size', str.value (1, str.size));
      FOREND;
    IFEND;

    IF (display_option = display_all) THEN
      IF (count_ext_characteristics <> NIL) THEN
        FOR ec_count := 1 TO count_ext_characteristics^ DO
          put_display_line ('  External_Characteristics', ext_chrstcs_and_status^ [ec_count]^.name);
          clp$convert_integer_to_string (ext_chrstcs_and_status^ [ec_count]^.oldest_age,
                10, FALSE, str, status);
          put_display_line ('    Age_of_Oldest_File', str.value (1, str.size));
          clp$convert_integer_to_string (ext_chrstcs_and_status^ [ec_count]^.average_age,
                10, FALSE, str, status);
          put_display_line ('    Average_Age_of_Files', str.value (1, str.size));
          clp$convert_integer_to_string (ext_chrstcs_and_status^ [ec_count]^.file_count,
                10, FALSE, str, status);
          put_display_line ('    File_Count', str.value (1, str.size));
          clp$convert_integer_to_string (ext_chrstcs_and_status^ [ec_count]^.total_size,
                10, FALSE, str, status);
          put_display_line ('    Total_File_Size', str.value (1, str.size));
        FOREND;
      IFEND;

      IF (count_forms_codes <> NIL) THEN
        FOR fc_count := 1 TO count_forms_codes^ DO
          put_display_line ('  Forms_Code', forms_codes_and_status^ [fc_count]^.name);
          clp$convert_integer_to_string (forms_codes_and_status^ [fc_count]^.oldest_age,
                10, FALSE, str, status);
          put_display_line ('    Age_of_Oldest_File', str.value (1, str.size));
          clp$convert_integer_to_string (forms_codes_and_status^ [fc_count]^.average_age,
                10, FALSE, str, status);
          put_display_line ('    Average_Age_of_Files', str.value (1, str.size));
          clp$convert_integer_to_string (forms_codes_and_status^ [fc_count]^.file_count,
                10, FALSE, str, status);
          put_display_line ('    File_Count', str.value (1, str.size));
          clp$convert_integer_to_string (forms_codes_and_status^ [fc_count]^.total_size,
                10, FALSE, str, status);
          put_display_line ('    Total_File_Size', str.value (1, str.size));
        FOREND;
      IFEND;
    IFEND;


  PROCEND display_queue_status;

?? TITLE := '  put_parameter', EJECT ??

{
{   Procedure to put a parameter into a message to be sent to SCFS.
{

  PROCEDURE put_parameter (parameter_kind: 0 .. 07f(16);
        parameter_value: ^CELL;
        parameter_size: nft$message_length);

    VAR
      param_type: ^nft$parameter_type,
      param_length: ^nft$parameter_value_length,
      param_length_size: nft$message_length,
      value_ptr: ^STRING (nfc$maximum_message_length),
      param_val: ^STRING (*),
      ignore_status: ost$status;


    NEXT param_type IN message;
    param_type^.length_indicated := (parameter_size > 1);
    param_type^.param := parameter_kind;
    message_length := message_length + 1;
    IF parameter_size > 1 THEN
      nfp$put_parameter_value_length (parameter_size, message, param_length_size, ignore_status);
      message_length := message_length + param_length_size;
    IFEND;
    NEXT param_val: [parameter_size] IN message;
    value_ptr := parameter_value;
    #UNCHECKED_CONVERSION (value_ptr^ (1, parameter_size), param_val^);
    message_length := message_length + parameter_size;
  PROCEND put_parameter;

?? TITLE := '  put_string_parameter', EJECT ??

{
{   Procedure to put a string type parameter into a message to be sent to SCFS.
{

  PROCEDURE put_string_parameter (parameter_kind: 0 .. 07f(16);
        parameter_value: STRING (* <= nfc$maximum_message_length));

    VAR
      length: 0 .. nfc$maximum_message_length;


    length := stringsize (parameter_value);
    IF length = 0 THEN
      length := 1;
    IFEND;
    put_parameter (parameter_kind, ^parameter_value, length);

  PROCEND put_string_parameter;

?? TITLE := '  put_null_parameter', EJECT ??

{
{   Procedure to add a null parameter type to the end of a message to be sent to SCFS.
{

  PROCEDURE put_null_parameter;

    CONST
      null_parameter = 0;

    VAR
      param_type: ^nft$parameter_type;


    NEXT param_type IN message;
    param_type^.length_indicated := FALSE;
    param_type^.param := null_parameter;
    message_length := message_length + 1;
  PROCEND put_null_parameter;

?? TITLE := '  get_parameter_length', EJECT ??

{
{   This procedure obtains the length of the next parameter value
{   in the message buffer from SCFS.  The length field, if
{   indicated, should be the next element in the message sequence.
{

  PROCEDURE get_parameter_length (length_indicated: BOOLEAN;
    VAR length: INTEGER);

    VAR
      param_length: ^nft$parameter_value_length,
      ignore_status: ost$status;


    IF length_indicated THEN
      nfp$get_parameter_value_length (message, msg_byte_count, length, ignore_status);
    ELSE
      length := 1;
    IFEND;
    msg_byte_count := msg_byte_count - length;

  PROCEND get_parameter_length;

?? TITLE := '  [INLINE] get_message_type', EJECT ??

{
{   Inline code to get the message type from the beginning of a
{   message received from SCFS.
{

  PROCEDURE [INLINE] get_message_type;


    RESET message;
    NEXT message_type IN message;
    msg_byte_count := message_length - 1;

  PROCEND get_message_type;

?? TITLE := '  [INLINE] put_message_type', EJECT ??

{
{   Inline code to initialize the message buffer to be sent to
{   SCFS by storing the specified message type at the beginning.
{

  PROCEDURE [INLINE] put_message_type (msg_type: nft$message_kind);


    RESET message;
    NEXT message_type IN message;
    message_type^ := msg_type;
    message_length := 1;

  PROCEND put_message_type;

?? TITLE := '  [INLINE] get_parameter_type', EJECT ??

{
{   Inline code to get the next parameter type from a
{   message received from SCFS.
{

  PROCEDURE [INLINE] get_parameter_type (VAR param: ^CELL);


    NEXT param IN message;
    msg_byte_count := msg_byte_count - 1;

  PROCEND get_parameter_type;

?? TITLE := '  stringsize', EJECT ??

{
{   Function to determine the length of a string, excluding trailing blanks.
{

  FUNCTION stringsize (str: string ( * )): integer;

    VAR
      str_length: ost$string_size;

    str_length := STRLENGTH (str);
    WHILE (str_length > 0) AND (str (str_length) = ' ') DO
      str_length := str_length - 1;
    WHILEND;
    stringsize := str_length;

  FUNCEND stringsize;

MODEND nfm$operate_station;
*DECK DECK=NFM$PREPROCESS_POSTSCRIPT_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'Preprocess PostScript File Batch Output Filter' ??

MODULE nfm$preprocess_postscript_file;

{ PURPOSE:
{   Filter a PostScript file.
{
{ DESIGN:
{
{   This program "normalizes" PostScript files.  It will ensure the file
{   has an Ascii EOT character at the beginning and end of the file.  Input
{   can be coded or transparent, but output will always be transparent.
{   This program will also prefix the file with the specified dictionaries
{   and it will process embedded directives and attempt to load the
{   required Apple dictionary.
{
{ NOTES:
{   PostScript is a registered trademark of Adobe Systems, Inc.

?? NEWTITLE := 'Global References', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
?? POP ??
*copyc amp$get_partial
*copyc amp$put_next
*copyc amp$put_partial
*copyc clp$change_variable
*copyc clp$evaluate_parameters
*copyc fsp$close_file
*copyc fsp$open_file
*copyc jmp$close_output_file
*copyc jmp$open_output_file
*copyc pmp$log
?? OLDTITLE ??

?? NEWTITLE := 'Global Definitions', EJECT ??
  CONST
    cr = $CHAR (13),
    eot = $CHAR (4),
    lf = $CHAR (10),
    max_buffer_size = 4096,
    sub = $CHAR (26);

  TYPE
    file_descriptor = record
      file_id: amt$file_identifier,
      file_position: amt$file_position,
      cursor: ost$non_negative_integers,
      last: amt$transfer_count,
      buffer: array [1 .. max_buffer_size] of char,
    recend;
?? OLDTITLE ??

?? NEWTITLE := 'nfp$preprocess_postscript_file ', EJECT ??

  PROGRAM nfp$preprocess_postscript_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    TYPE
      states = (beginning_of_line, mid_line);

    VAR
      byte_address: amt$file_byte_address,
      ch: char,
      data_move_var_value: clt$data_value,
      dictionary_name_entry: ^clt$data_value,
      dictionary_path: string (512),
      dictionary_path_size: integer,
      done: boolean,
      end_of_file: [STATIC] char := eot,
      ignore_status: ost$status,
      input_file: file_descriptor,
      output_file: file_descriptor,
      record_length: amt$max_record_length,
      state: states;

{ PROCEDURE preprocess_postscript_file, prepf (
{   input, i: record
{       system_file_name: name 19..19
{       password: string 1..31
{       file: file = $optional
{     recend = $required
{   output, o: file = $required
{   dictionary_catalog, dc: any of
{       key
{         none
{       keyend
{       file
{     anyend = none
{   dictionary_name, dictionary_names, dn: any of
{       key
{         none
{       keyend
{       list of name
{     anyend = none
{   data_mode, dm: (VAR) key
{       (coded, c)
{       (transparent, t)
{     keyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 12] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: 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,
        recend,
        default_value: string (4),
      recend,
      type4: 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (4),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 8, 13, 11, 11, 45, 619],
    clc$command, 12, 6, 3, 0, 0, 1, 6, ''], [
    ['DATA_MODE                      ',clc$nominal_entry, 5],
    ['DC                             ',clc$abbreviation_entry, 3],
    ['DICTIONARY_CATALOG             ',clc$nominal_entry, 3],
    ['DICTIONARY_NAME                ',clc$nominal_entry, 4],
    ['DICTIONARY_NAMES               ',clc$alias_entry, 4],
    ['DM                             ',clc$abbreviation_entry, 5],
    ['DN                             ',clc$abbreviation_entry, 4],
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 131,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 67,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 5
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$required_parameter, 0, 0],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$record_type], [3],
    ['SYSTEM_FILE_NAME               ', clc$required_field, 5], [[1, 0, clc$name_type], [19, 19]],
    ['PASSWORD                       ', clc$required_field, 8], [[1, 0, clc$string_type], [1, 31, FALSE]],
    ['FILE                           ', clc$optional_field, 3], [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'none'],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'none'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [4], [
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CODED                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TRANSPARENT                    ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$input = 1,
      p$output = 2,
      p$dictionary_catalog = 3,
      p$dictionary_name = 4,
      p$data_mode = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

?? EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    open_input_file (pvt [p$input].value, input_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    open_output_file (pvt [p$output].value^.file_value^, output_file, status);
    IF NOT status.normal THEN
      fsp$close_file (input_file.file_id, ignore_status);
      RETURN;
    IFEND;

    done := FALSE;
    input_file.file_position := amc$boi;
    output_file.buffer [1] := eot;
    output_file.cursor := 2;
    state := beginning_of_line;

{ Prefix output file with any dictionaries specified by DICTIONARY_NAME

    IF pvt [p$dictionary_name].value^.kind = clc$list THEN
      dictionary_name_entry := pvt [p$dictionary_name].value;
      WHILE dictionary_name_entry <> NIL DO
        STRINGREP (dictionary_path, dictionary_path_size, pvt [p$dictionary_catalog].value^.file_value^, '.',
              dictionary_name_entry^.element_value^.name_value);
        load_dictionary (output_file, dictionary_path (1, dictionary_path_size), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        dictionary_name_entry := dictionary_name_entry^.link;
      WHILEND;
    IFEND;

    WHILE NOT done DO
      IF input_file.cursor > input_file.last THEN { refill input buffer }
        IF input_file.file_position = amc$eoi THEN
          done := TRUE;
        ELSEIF input_file.file_position = amc$eor THEN
          input_file.file_position := amc$mid_record;
          input_file.buffer [1] := lf;
          input_file.cursor := 1;
          input_file.last := 1;
        ELSE
          input_file.cursor := 1;
          amp$get_partial (input_file.file_id, ^input_file.buffer, max_buffer_size, record_length,
                input_file.last, byte_address, input_file.file_position, amc$no_skip, status);
        IFEND;
      ELSE
        ch := input_file.buffer [input_file.cursor];
        input_file.cursor := input_file.cursor + 1;

        CASE state OF

        = beginning_of_line =
          CASE ch OF

          = cr, lf =

            IF output_file.cursor > max_buffer_size THEN
              amp$put_next (output_file.file_id, ^output_file.buffer, max_buffer_size, byte_address, status);
              output_file.cursor := 1;
            IFEND;
            output_file.buffer [output_file.cursor] := ch;
            output_file.cursor := output_file.cursor + 1;

          = sub =

{ Ignore SUB character - added by some file transfer programs.

          ELSE

            IF (ch = '%') AND (pvt [p$dictionary_catalog].value^.kind = clc$file) THEN
              process_comment (input_file, output_file, pvt [p$dictionary_catalog].value^.file_value^,
                    status);
            ELSE
              state := mid_line;
              IF output_file.cursor > max_buffer_size THEN
                amp$put_next (output_file.file_id, ^output_file.buffer, max_buffer_size, byte_address,
                      status);
                output_file.cursor := 1;
              IFEND;
              output_file.buffer [output_file.cursor] := ch;
              output_file.cursor := output_file.cursor + 1;
            IFEND;

          CASEND;

        = mid_line =

          IF (ch = cr) OR (ch = lf) THEN { end of line }
            state := beginning_of_line;
          IFEND;

          IF output_file.cursor > max_buffer_size THEN
            amp$put_next (output_file.file_id, ^output_file.buffer, max_buffer_size, byte_address, status);
            output_file.cursor := 1;
          IFEND;
          output_file.buffer [output_file.cursor] := ch;
          output_file.cursor := output_file.cursor + 1;

        CASEND;

      IFEND;

      IF NOT status.normal THEN
        close_files (input_file, pvt [p$input], output_file, ignore_status);
        RETURN;
      IFEND;

    WHILEND;

    IF output_file.cursor > 1 THEN
      amp$put_next (output_file.file_id, ^output_file.buffer, output_file.cursor - 1, byte_address, status);
      IF NOT status.normal THEN
        close_files (input_file, pvt [p$input], output_file, ignore_status);
        RETURN;
      IFEND;
    IFEND;

    amp$put_next (output_file.file_id, ^end_of_file, 1, byte_address, status);
    IF NOT status.normal THEN
      close_files (input_file, pvt [p$input], output_file, ignore_status);
      RETURN;
    IFEND;

    close_files (input_file, pvt [p$input], output_file, status);
    IF status.normal THEN
      data_move_var_value.kind := clc$keyword;
      data_move_var_value.keyword_value := 'TRANSPARENT';
      clp$change_variable (pvt [p$data_mode].variable^, ^data_move_var_value, status);
    IFEND

  PROCEND nfp$preprocess_postscript_file;
?? OLDTITLE ??

?? NEWTITLE := 'close_files', EJECT ??

  PROCEDURE close_files
    (    input_file: file_descriptor;
         input_param: clt$parameter_value;
         output_file: file_descriptor;
     VAR status: ost$status);

    VAR
      local_status: ost$status;

    status.normal := TRUE;

    IF input_param.value^.field_values^ [3].value = NIL THEN
      jmp$close_output_file (input_file.file_id, status);
    ELSE
      fsp$close_file (input_file.file_id, status);
    IFEND;

    fsp$close_file (output_file.file_id, local_status);

    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

  PROCEND close_files;
?? OLDTITLE ??

?? NEWTITLE := 'include_proc_set', EJECT ??

  PROCEDURE include_proc_set
    (VAR {input/output} output_file: file_descriptor;
         line: string ( * );
         size: ost$non_negative_integers;
         cursor_position: ost$non_negative_integers;
         dictionary_catalog: fst$file_reference;
     VAR status: ost$status);

    CONST
      apple_token = '(AppleDict md)',
      max_token_size = 100;

    VAR
      byte_address: amt$file_byte_address,
      ch: char,
      cursor: ost$non_negative_integers,
      delimiter: char,
      dictionary_path: string (512),
      dictionary_path_size: integer,
      dictionary_prefix: string (200),
      dictionary_prefix_size: integer,
      done: boolean,
      end_of_line: [STATIC] char := lf,
      ignore_status: ost$status,
      token: string (max_token_size),
      token_size: ost$non_negative_integers,
      version: string (max_token_size),
      version_size: ost$non_negative_integers;

    status.normal := TRUE;
    cursor := cursor_position + 1;

{ Get next token and compare to "(AppleDict md)"

    done := FALSE;
    WHILE NOT done DO
      IF cursor > size THEN
        done := TRUE;
      ELSEIF line (cursor) <> ' ' THEN
        done := TRUE;
      ELSE
        cursor := cursor + 1;
      IFEND;
    WHILEND;

    IF cursor <= size THEN
      IF line (cursor) = '"' THEN
        delimiter := '"';
        cursor := cursor + 1;
      ELSE
        delimiter := ' ';
      IFEND;
    IFEND;

    token_size := 0;
    done := FALSE;

    WHILE NOT done DO
      IF cursor > size THEN
        done := TRUE;
      ELSEIF line (cursor) = delimiter THEN
        cursor := cursor + 1;
        done := TRUE;
      ELSE
        ch := line (cursor);
        cursor := cursor + 1;
        IF token_size < max_token_size THEN
          token_size := token_size + 1;
          token (token_size) := ch;
        IFEND;
      IFEND;
    WHILEND;

    IF token (1, token_size) <> apple_token THEN
      RETURN;
    IFEND;

{ Get version number

    done := FALSE;
    WHILE NOT done DO
      IF cursor > size THEN
        done := TRUE;
      ELSEIF line (cursor) <> ' ' THEN
        done := TRUE;
      ELSE
        cursor := cursor + 1;
      IFEND;
    WHILEND;

    version_size := 0;
    done := FALSE;

    WHILE NOT done DO
      IF cursor > size THEN
        done := TRUE;
      ELSEIF line (cursor) = ' ' THEN
        done := TRUE;
      ELSE
        ch := line (cursor);
        cursor := cursor + 1;
        IF version_size < max_token_size THEN
          version_size := version_size + 1;
          version (version_size) := ch;
        IFEND;
      IFEND;
    WHILEND;

    IF version_size <= 0 THEN
      RETURN;
    IFEND;

    STRINGREP (dictionary_prefix, dictionary_prefix_size, 'userdict /md known {md /av known {md /av get ',
          version (1, version_size), ' eq {stop} if} if} if', end_of_line, 'serverdict begin 0 exitserver',
          end_of_line);

    amp$put_next (output_file.file_id, ^dictionary_prefix, dictionary_prefix_size, byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (dictionary_path, dictionary_path_size, dictionary_catalog, '.apple_dict_md_',
          version (1, version_size));

    load_dictionary (output_file, dictionary_path (1, dictionary_path_size), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND include_proc_set;
?? OLDTITLE ??

?? NEWTITLE := 'load_dictionary', EJECT ??

  PROCEDURE load_dictionary
    (VAR {input/output} output_file: file_descriptor;
         dictionary_path: fst$file_reference;
     VAR status: ost$status);

    VAR
      attachment_option: array [1 .. 3] of fst$attachment_option,
      byte_address: amt$file_byte_address,
      ch: char,
      dictionary_file: file_descriptor,
      done: boolean,
      ignore_status: ost$status,
      record_length: amt$max_record_length;

    status.normal := TRUE;

    attachment_option [1].selector := fsc$access_and_share_modes;
    attachment_option [1].access_modes.selector := fsc$specific_access_modes;
    attachment_option [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_option [1].share_modes.selector := fsc$specific_share_modes;
    attachment_option [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
    attachment_option [2].selector := fsc$open_share_modes;
    attachment_option [2].open_share_modes := $fst$file_access_options [fsc$read, fsc$execute];
    attachment_option [3].selector := fsc$create_file;
    attachment_option [3].create_file := FALSE;

    fsp$open_file (dictionary_path, amc$record, ^attachment_option, NIL, NIL, NIL, NIL,
          dictionary_file.file_id, status);
    IF NOT status.normal THEN
      pmp$log ('** PREPROCESS_POSTSCRIPT_FILE:  Dictionary open error:', ignore_status);
      pmp$log (dictionary_path, ignore_status);
      status.normal := TRUE;
      RETURN;
    IFEND;

    dictionary_file.cursor := max_buffer_size + 1;
    dictionary_file.last := 0;
    dictionary_file.file_position := amc$boi;

    done := FALSE;

    WHILE NOT done DO
      IF dictionary_file.cursor > dictionary_file.last THEN
        IF dictionary_file.file_position = amc$eoi THEN
          done := TRUE;
        ELSEIF dictionary_file.file_position = amc$eor THEN
          dictionary_file.file_position := amc$mid_record;
          dictionary_file.buffer [1] := lf;
          dictionary_file.cursor := 1;
          dictionary_file.last := 1;
        ELSE
          dictionary_file.cursor := 1;
          amp$get_partial (dictionary_file.file_id, ^dictionary_file.buffer, max_buffer_size, record_length,
                dictionary_file.last, byte_address, dictionary_file.file_position, amc$no_skip, status);
        IFEND;
      ELSE
        ch := dictionary_file.buffer [dictionary_file.cursor];
        IF ch = cr THEN
          ch := lf;
        IFEND;
        dictionary_file.cursor := dictionary_file.cursor + 1;

        IF output_file.cursor > max_buffer_size THEN
          amp$put_next (output_file.file_id, ^output_file.buffer, max_buffer_size, byte_address, status);
          output_file.cursor := 1;
        IFEND;

{ Ignore SUB character - added by some file transfer programs.

        IF ch <> sub THEN
          output_file.buffer [output_file.cursor] := ch;
          output_file.cursor := output_file.cursor + 1;
        IFEND;
      IFEND;

      IF NOT status.normal THEN
        fsp$close_file (dictionary_file.file_id, ignore_status);
        RETURN;
      IFEND;

    WHILEND;

    IF output_file.cursor > max_buffer_size THEN
      amp$put_next (output_file.file_id, ^output_file.buffer, max_buffer_size, byte_address, status);
      IF NOT status.normal THEN
        fsp$close_file (dictionary_file.file_id, ignore_status);
        RETURN;
      IFEND;
      output_file.cursor := 1;
    IFEND;

    output_file.buffer [output_file.cursor] := eot;
    output_file.cursor := output_file.cursor + 1;

    fsp$close_file (dictionary_file.file_id, status);

  PROCEND load_dictionary;
?? OLDTITLE ??

?? NEWTITLE := 'open_input_file', EJECT ??

  PROCEDURE open_input_file
    (    input_parameter: ^clt$data_value;
     VAR input_file: file_descriptor;
     VAR status: ost$status);

    VAR
      attachment_option: array [1 .. 3] of fst$attachment_option;

    status.normal := TRUE;

    IF input_parameter^.field_values^ [3].value = NIL THEN

      jmp$open_output_file (input_parameter^.field_values^ [1].
            value^.name_value (1, jmc$system_supplied_name_size), amc$record, jmc$public_usage,
            input_parameter^.field_values^ [2].value^.string_value^, input_file.file_id, status);

    ELSE

      attachment_option [1].selector := fsc$access_and_share_modes;
      attachment_option [1].access_modes.selector := fsc$specific_access_modes;
      attachment_option [1].access_modes.value := $fst$file_access_options [fsc$read];
      attachment_option [1].share_modes.selector := fsc$specific_share_modes;
      attachment_option [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
      attachment_option [2].selector := fsc$open_share_modes;
      attachment_option [2].open_share_modes := $fst$file_access_options [fsc$read, fsc$execute];
      attachment_option [3].selector := fsc$create_file;
      attachment_option [3].create_file := FALSE;

      fsp$open_file (input_parameter^.field_values^ [3].value^.file_value^, amc$record,
            ^attachment_option, NIL, NIL, NIL, NIL, input_file.file_id, status);

    IFEND;

    input_file.cursor := max_buffer_size + 1;
    input_file.last := 0;

  PROCEND open_input_file;
?? OLDTITLE ??

?? NEWTITLE := 'open_output_file', EJECT ??

  PROCEDURE open_output_file
    (    file_name: fst$file_reference;
     VAR output_file: file_descriptor;
     VAR status: ost$status);

    VAR
      attachment_option: array [1 .. 2] of fst$attachment_option,
      file_attributes: array [1 .. 1] of fst$file_cycle_attribute;

    status.normal := TRUE;

    attachment_option [1].selector := fsc$access_and_share_modes;
    attachment_option [1].access_modes.selector := fsc$specific_access_modes;
    attachment_option [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
    attachment_option [1].share_modes.selector := fsc$specific_share_modes;
    attachment_option [1].share_modes.value := $fst$file_access_options [];
    attachment_option [2].selector := fsc$open_share_modes;
    attachment_option [2].open_share_modes := -$fst$file_access_options [];

    file_attributes [1].selector := fsc$record_type;
    file_attributes [1].record_type := amc$undefined;

    fsp$open_file (file_name, amc$record, ^attachment_option, NIL, ^file_attributes, NIL, NIL,
          output_file.file_id, status);

    output_file.cursor := 1;

  PROCEND open_output_file;
?? OLDTITLE ??

?? NEWTITLE := 'process_comment', EJECT ??

  PROCEDURE process_comment
    (VAR {input/output} input_file: file_descriptor;
     VAR {input/output} output_file: file_descriptor;
         dictionary_catalog: fst$file_reference;
     VAR status: ost$status);

    CONST
      include_comment = '%%IncludeProcSet:',
      include_comment_size = 17,
      max_line_size = 1000;

    VAR
      byte_address: amt$file_byte_address,
      ch: char,
      cursor: ost$non_negative_integers,
      done: boolean,
      end_of_line: [STATIC] char := lf,
      ignore_status: ost$status,
      line: string (max_line_size),
      record_length: amt$max_record_length,
      size: ost$non_negative_integers;

    status.normal := TRUE;

    done := FALSE;
    line := '%';
    cursor := 2;

    WHILE NOT done DO
      IF input_file.cursor > input_file.last THEN { refill input buffer }
        IF input_file.file_position = amc$eoi THEN
          done := TRUE;
        ELSEIF input_file.file_position = amc$eor THEN
          done := TRUE;
        ELSE
          input_file.cursor := 1;
          amp$get_partial (input_file.file_id, ^input_file.buffer, max_buffer_size, record_length,
                input_file.last, byte_address, input_file.file_position, amc$no_skip, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      ELSE
        ch := input_file.buffer [input_file.cursor];
        input_file.cursor := input_file.cursor + 1;
        IF (ch = cr) OR (ch = lf) THEN
          done := TRUE;
        ELSEIF cursor <= max_line_size THEN
          line (cursor) := ch;
          cursor := cursor + 1;
        IFEND;
      IFEND;
    WHILEND;

    size := cursor - 1;

    IF output_file.cursor > 1 THEN { flush output buffer }
      amp$put_next (output_file.file_id, ^output_file.buffer, output_file.cursor - 1, byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      output_file.cursor := 1;
    IFEND;

    amp$put_partial (output_file.file_id, ^line, size, byte_address, amc$start, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$put_partial (output_file.file_id, ^end_of_line, 1, byte_address, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF line (1, include_comment_size) = include_comment THEN
      include_proc_set (output_file, line, size, include_comment_size, dictionary_catalog, status);
    IFEND;

  PROCEND process_comment;
?? OLDTITLE ??

MODEND nfm$preprocess_postscript_file;
*DECK DECK=NFM$PREPROCESS_URI EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'MODULE nfm$preprocess_uri' ??
MODULE nfm$preprocess_uri;

{ PURPOSE:
{   Translate a file containing NOS/VE batch format effectors into a
{   transparent file in the URI Access Data Format printable on a URI printer.
{
{ DESIGN:
{   Examine each format effector and generate the corresponding ASCII paper
{   instruction commands.  Put the rest of the text on the line into the
{   output file.  URI Access Data Format commands are added for end-of-line
{   and end-of-file markers.
{
{ NOTES:
{   The input file read by this program must be in coded format.  It must not
{   be called if the input file is transparent.  The main filter should be
{   modified such that this requirement is followed.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_parsing
*copyc cle$incompatible_params_given
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$get_next
*copyc amp$get_partial
*copyc amp$put_next
*copyc clp$evaluate_parameters
*copyc fsp$close_file
*copyc fsp$open_file
*copyc jmp$close_output_file
*copyc jmp$open_output_file
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE nfp$preprocess_uri', EJECT ??

  PROCEDURE [XDCL] nfp$preprocess_uri
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{    PROCEDURE  preprocess_uri, preu (
{      input, i: record
{          system_file_name: name 19..19
{          password: string 1..31
{          file: file = $optional
{        recend = $required
{      output, o: file = $required
{      file_print_density, fpd: key
{           six, eight
{        keyend = six
{      device_print_density, dpd: key
{           six_any, six_only, eight_any, eight_only
{        keyend = six_any
{      page_length, pl: integer 1..4398046511103 = $required
{      page_width, pw: integer 10..255 = $required
{      status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 10, 15, 14, 43, 30, 358],
    clc$command, 13, 7, 4, 0, 0, 0, 7, ''], [
    ['DEVICE_PRINT_DENSITY           ',clc$nominal_entry, 4],
    ['DPD                            ',clc$abbreviation_entry, 4],
    ['FILE_PRINT_DENSITY             ',clc$nominal_entry, 3],
    ['FPD                            ',clc$abbreviation_entry, 3],
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['PAGE_LENGTH                    ',clc$nominal_entry, 5],
    ['PAGE_WIDTH                     ',clc$nominal_entry, 6],
    ['PL                             ',clc$abbreviation_entry, 5],
    ['PW                             ',clc$abbreviation_entry, 6],
    ['STATUS                         ',clc$nominal_entry, 7]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 131, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 81, clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$required_parameter, 0, 0],
{ PARAMETER 6
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$required_parameter, 0, 0],
{ PARAMETER 7
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$record_type], [3],
    ['SYSTEM_FILE_NAME               ', clc$required_field, 5], [[1, 0,
  clc$name_type], [19, 19]],
    ['PASSWORD                       ', clc$required_field, 8], [[1, 0,
  clc$string_type], [1, 31, FALSE]],
    ['FILE                           ', clc$optional_field, 3], [[1, 0,
  clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [2], [
    ['EIGHT                          ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['SIX                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ,
    'six'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [4], [
    ['EIGHT_ANY                      ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['EIGHT_ONLY                     ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['SIX_ANY                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['SIX_ONLY                       ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'six_any'],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [1, 4398046511103, 10]],
{ PARAMETER 6
    [[1, 0, clc$integer_type], [10, 255, 10]],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$input = 1,
      p$output = 2,
      p$file_print_density = 3,
      p$device_print_density = 4,
      p$page_length = 5,
      p$page_width = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

  CONST
    file_field = 3,
    password_field = 2,
    sfn_field = 1;


  CONST
    fe_sequence_length_max = 8, {Maximum length of format effector sequence
    maximum_input_bytes = 2048,
    maximum_output_bytes = 256 + fe_sequence_length_max + postprint_buffer_flusher_length,
    postprint_buffer_flusher_length = 5; {Length of sequence used to flush the
                                         {buffer for a postprint format effector

  TYPE
    character_range = 0 .. 127;


{ Variables used for reading & writing data.

  VAR
    input_file_byte_address: amt$file_byte_address, {keeps track of input file position
    input_file_byte_count: amt$transfer_count, {number of characters read
    input_file_id: amt$file_identifier,
    input_file_position: amt$file_position,
    input_line: string (maximum_input_bytes),
    output_file_byte_address: amt$file_byte_address, { keeps track of output file position
    output_file_id: amt$file_identifier,
    output_line: string (maximum_output_bytes);


{
{ The following type, format_effector_action, declares the different types of
{ actions to be taken for the various format effectors.
{   Preprint - the action should be done before the printing.
{   Postprint - the action should be done after the printing.
{   VFU_load_dape - for format effector Q, deselect_auto_page_eject.  A VFU
{                   must be created and written to the output file.
{   VFU_load_sape - for format effector R, select_auto_page_eject.  A VFU
{                   must be created and written to the output file.
{   VFU_load_6lpi - for format effector S, six lines per inch.  A VFU
{                   must be created and written to the output file.
{   VFU_load_8lpi - for format effector T, eight lines per inch.  A VFU
{                   must be created and written to the output file.
{   Undefined - the format effector is not defined for the URI printer.
{

  TYPE
    format_effector_action = (preprint, postprint, vfu_load_dape, vfu_load_sape, vfu_load_6lpi,
          vfu_load_8lpi, undefined);

  TYPE
    format_effector_action_rec = record
      print_action: format_effector_action,
      paper_instruction: char,
    recend;

{ The variable fe_command_sequences, defines the print action to be done
{ for each ASCII character when it is used as a format effector.

  VAR
    fe_command_sequences: [READ] array [character_range] of format_effector_action_rec :=

    {NUL} [[undefined, $CHAR (0ff(16))],
          {SOH} [undefined, $CHAR (0ff(16))],
          {STX} [undefined, $CHAR (0ff(16))],
          {ETX} [undefined, $CHAR (0ff(16))],
          {EOT} [undefined, $CHAR (0ff(16))],
          {ENQ} [undefined, $CHAR (0ff(16))],
          {ACK} [undefined, $CHAR (0ff(16))],
          {BEL} [undefined, $CHAR (0ff(16))],
          {BS } [undefined, $CHAR (0ff(16))],
          {HT } [undefined, $CHAR (0ff(16))],
          {LF } [undefined, $CHAR (0ff(16))],
          {VT } [undefined, $CHAR (0ff(16))],
          {FF } [undefined, $CHAR (0ff(16))],
          {CR } [undefined, $CHAR (0ff(16))],
          {SO } [undefined, $CHAR (0ff(16))],
          {SI } [undefined, $CHAR (0ff(16))],
          {DLE} [undefined, $CHAR (0ff(16))],
          {DC1} [undefined, $CHAR (0ff(16))],
          {DC2} [undefined, $CHAR (0ff(16))],
          {DC3} [undefined, $CHAR (0ff(16))],
          {DC4} [undefined, $CHAR (0ff(16))],
          {NAK} [undefined, $CHAR (0ff(16))],
          {SYN} [undefined, $CHAR (0ff(16))],
          {ETB} [undefined, $CHAR (0ff(16))],
          {CAN} [undefined, $CHAR (0ff(16))],
          {EM } [undefined, $CHAR (0ff(16))],
          {SUB} [undefined, $CHAR (0ff(16))],
          {ESC} [undefined, $CHAR (0ff(16))],
          {FS } [undefined, $CHAR (0ff(16))],
          {GS } [undefined, $CHAR (0ff(16))],
          {RS } [undefined, $CHAR (0ff(16))],
          {US } [preprint, $CHAR (11(16))], { advance 1 line
          {SP } [preprint, $CHAR (11(16))], { advance 1 line
          { ! } [undefined, $CHAR (0ff(16))],
          { " } [undefined, $CHAR (0ff(16))],
          { # } [undefined, $CHAR (0ff(16))],
          { $ } [undefined, $CHAR (0ff(16))],
          { % } [undefined, $CHAR (0ff(16))],
          { & } [undefined, $CHAR (0ff(16))],
          { ' } [undefined, $CHAR (0ff(16))],
          { ( } [undefined, $CHAR (0ff(16))],
          { ) } [undefined, $CHAR (0ff(16))],
          { * } [undefined, $CHAR (0ff(16))],
          { + } [preprint, $CHAR (10(16))], { advance 0 lines
          { , } [undefined, $CHAR (0ff(16))],
          { - } [preprint, $CHAR (13(16))], { advance 3 lines
          { . } [undefined, $CHAR (0ff(16))],
          { / } [postprint, $CHAR (10(16))], { advance 0 lines
          { 0 } [preprint, $CHAR (12(16))], { advance 2 lines
          { 1 } [preprint, $CHAR (00(16))], { advance TOF
          { 2 } [preprint, $CHAR (0B(16))], { advance BOF
          { 3 } [preprint, $CHAR (05(16))], { advance channel 6
          { 4 } [preprint, $CHAR (04(16))], { advance channel 5
          { 5 } [preprint, $CHAR (03(16))], { advance channel 4
          { 6 } [preprint, $CHAR (02(16))], { advance channel 3
          { 7 } [preprint, $CHAR (01(16))], { advance channel 2
          { 8 } [preprint, $CHAR (00(16))], { advance channel 1
          { 9 } [preprint, $CHAR (06(16))], { advance channel 7
          { : } [undefined, $CHAR (0ff(16))],
          { ; } [undefined, $CHAR (0ff(16))],
          { < } [undefined, $CHAR (0ff(16))],
          { = } [undefined, $CHAR (0ff(16))],
          { > } [undefined, $CHAR (0ff(16))],
          { ? } [undefined, $CHAR (0ff(16))],
          { @ } [undefined, $CHAR (0ff(16))],
          { A } [postprint, $CHAR (00(16))], { advance TOF
          { B } [postprint, $CHAR (0B(16))], { advance BOF
          { C } [postprint, $CHAR (05(16))], { advance channel 6
          { D } [postprint, $CHAR (04(16))], { advance channel 5
          { E } [postprint, $CHAR (03(16))], { advance channel 4
          { F } [postprint, $CHAR (02(16))], { advance channel 3
          { G } [postprint, $CHAR (01(16))], { advance channel 2
          { H } [postprint, $CHAR (00(16))], { advance channel 1
          { I } [postprint, $CHAR (06(16))], { advance channel 7
          { J } [postprint, $CHAR (07(16))], { advance channel 8
          { K } [postprint, $CHAR (08(16))], { advance channel 9
          { L } [postprint, $CHAR (09(16))], { advance channel 10
          { M } [postprint, $CHAR (0A(16))], { advance channel 11
          { N } [postprint, $CHAR (0B(16))], { advance channel 12
          { O } [undefined, $CHAR (0ff(16))],
          { P } [undefined, $CHAR (0ff(16))],
          { Q } [vfu_load_dape, $CHAR (0ff(16))], { select auto eject off
          { R } [vfu_load_sape, $CHAR (0ff(16))], { select auto eject on
          { S } [vfu_load_6lpi, $CHAR (0ff(16))], { select 6 lines/inch
          { T } [vfu_load_8lpi, $CHAR (0ff(16))], { select 8 lines/inch
          { U } [preprint, $CHAR (0B(16))], { advance channel 12
          { V } [undefined, $CHAR (0ff(16))], { load VFU
          { W } [preprint, $CHAR (0A(16))], { advance channel 11
          { X } [preprint, $CHAR (07(16))], { advance channel 8
          { Y } [preprint, $CHAR (08(16))], { advance channel 9
          { Z } [preprint, $CHAR (09(16))], { advance channel 10
          { [ } [undefined, $CHAR (0ff(16))],
          { \ } [undefined, $CHAR (0ff(16))],
          { ] } [undefined, $CHAR (0ff(16))],
          { ^ } [undefined, $CHAR (0ff(16))],
          { _ } [undefined, $CHAR (0ff(16))],
          { ` } [undefined, $CHAR (0ff(16))],
          { a } [undefined, $CHAR (0ff(16))],
          { b } [undefined, $CHAR (0ff(16))],
          { c } [undefined, $CHAR (0ff(16))],
          { d } [undefined, $CHAR (0ff(16))],
          { e } [undefined, $CHAR (0ff(16))],
          { f } [undefined, $CHAR (0ff(16))],
          { g } [undefined, $CHAR (0ff(16))],
          { h } [undefined, $CHAR (0ff(16))],
          { i } [undefined, $CHAR (0ff(16))],
          { j } [undefined, $CHAR (0ff(16))],
          { k } [undefined, $CHAR (0ff(16))],
          { l } [undefined, $CHAR (0ff(16))],
          { m } [undefined, $CHAR (0ff(16))],
          { n } [undefined, $CHAR (0ff(16))],
          { o } [undefined, $CHAR (0ff(16))],
          { p } [undefined, $CHAR (0ff(16))],
          { q } [undefined, $CHAR (0ff(16))],
          { r } [undefined, $CHAR (0ff(16))],
          { s } [undefined, $CHAR (0ff(16))],
          { t } [undefined, $CHAR (0ff(16))],
          { u } [undefined, $CHAR (0ff(16))],
          { v } [undefined, $CHAR (0ff(16))],
          { w } [undefined, $CHAR (0ff(16))],
          { x } [undefined, $CHAR (0ff(16))],
          { y } [undefined, $CHAR (0ff(16))],
          { z } [undefined, $CHAR (0ff(16))],
          {   } [undefined, $CHAR (0ff(16))],
          { | } [undefined, $CHAR (0ff(16))],
          {   } [undefined, $CHAR (0ff(16))],
          { ~ } [undefined, $CHAR (0ff(16))],
          {DLE} [undefined, $CHAR (0ff(16))]];

{ URI Access Control command constant and variable strings.  These values are
{ used throughout the output file that is created, ie. in the VFU, the format
{ effector sequence, etc.

  CONST
    activate_control_after_ackin = $CHAR (00(16)) CAT $CHAR (09(16)),
    advance_0_lines = $CHAR (10(16)),
    chars_in_common_63_lines = 126,
    chars_in_common_8lpi = 46,
    chars_lines_64_to_66 = 6,
    chars_lines_87_88 = 4,
    chars_vfu_header = 12,
    chars_vfu_trailer = 8,
    deactivate_control = $CHAR (00(16)) CAT $CHAR (02(16)),
    deactivate_control_after_ackin = $CHAR (00(16)) CAT $CHAR (0A(16)),
    define_device_down = $CHAR (00(16)) CAT $CHAR (10(16)) CAT $CHAR (40(16)),
    define_not_ready = $CHAR (00(16)) CAT $CHAR (11(16)) CAT $CHAR (43(16)),
    define_recoverable_error = $CHAR (00(16)) CAT $CHAR (12(16)) CAT $CHAR (2A(16)),
    end_of_file = $CHAR (00(16)) CAT $CHAR (03(16)),
    fill_in_char = 'x',
    line_feed = $CHAR (11(16)),
    nul = $CHAR (00(16)),
    skip_to_top_of_form = $CHAR (00(16)) CAT $CHAR (00(16)),
    start_vfu_load_6lpi = $CHAR (6c(16)),
    start_vfu_load_8lpi = $CHAR (6d(16)),
    stop_vfu_load = $CHAR (6f(16)),
    vfu_load_type_position = 12, {Position in VFU header where load cmd goes.
    vfu_max_len_in_characters = 196, {Without NULs doubled, includes VFU header and trailer.
    wait_for_paper_mvmt_cio1_porta = $CHAR (00(16)) CAT $CHAR (2C(16));

  TYPE
    vfu_range = vfu_load_dape .. vfu_load_8lpi;

  VAR
    act_ctrl_after_ackin_str: [READ] string (2) := $CHAR (00(16)) CAT $CHAR (09(16)),
    currently_6lpi: boolean,
    currently_sape: [STATIC] boolean := TRUE,
    deact_ctrl_after_ackin_str: [READ] string (2) := $CHAR (00(16)) CAT $CHAR (0A(16)),
    device_print_density: clt$keyword,
    initial_vfu_loaded: boolean,
    vfu_id: vfu_range;


  VAR

{ The first 63 lines of a VFU are the same whether the VFU is defined as
{ 6 lines per inch or 8 lines per inch.

    common_63_lines_in_6lpi_8lpi: [READ] string (chars_in_common_63_lines) := {
          {line 01} $CHAR (3F(16)) CAT $CHAR (1D(16)) CAT {
          {line 02} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 03} $CHAR (02(16)) CAT $CHAR (00(16)) CAT {
          {line 04} $CHAR (04(16)) CAT $CHAR (00(16)) CAT {
          {line 05} $CHAR (0A(16)) CAT $CHAR (00(16)) CAT {
          {line 06} $CHAR (10(16)) CAT $CHAR (00(16)) CAT {
          {line 07} $CHAR (26(16)) CAT $CHAR (00(16)) CAT {
          {line 08} $CHAR (00(16)) CAT $CHAR (01(16)) CAT {
          {line 09} $CHAR (0A(16)) CAT $CHAR (00(16)) CAT {
          {line 10} $CHAR (04(16)) CAT $CHAR (04(16)) CAT {
          {line 11} $CHAR (12(16)) CAT $CHAR (08(16)) CAT {
          {line 12} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 13} $CHAR (2E(16)) CAT $CHAR (00(16)) CAT {
          {line 14} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 15} $CHAR (02(16)) CAT $CHAR (01(16)) CAT {
          {line 16} $CHAR (14(16)) CAT $CHAR (00(16)) CAT {
          {line 17} $CHAR (0A(16)) CAT $CHAR (00(16)) CAT {
          {line 18} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 19} $CHAR (26(16)) CAT $CHAR (04(16)) CAT {
          {line 20} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 21} $CHAR (1A(16)) CAT $CHAR (08(16)) CAT {
          {line 22} $CHAR (04(16)) CAT $CHAR (01(16)) CAT {
          {line 23} $CHAR (02(16)) CAT $CHAR (00(16)) CAT {
          {line 24} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 25} $CHAR (2E(16)) CAT $CHAR (00(16)) CAT {
          {line 26} $CHAR (10(16)) CAT $CHAR (00(16)) CAT {
          {line 27} $CHAR (02(16)) CAT $CHAR (00(16)) CAT {
          {line 28} $CHAR (04(16)) CAT $CHAR (04(16)) CAT {
          {line 29} $CHAR (0A(16)) CAT $CHAR (01(16)) CAT {
          {line 30} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 31} $CHAR (36(16)) CAT $CHAR (08(16)) CAT {
          {line 32} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 33} $CHAR (0A(16)) CAT $CHAR (00(16)) CAT {
          {line 34} $CHAR (04(16)) CAT $CHAR (00(16)) CAT {
          {line 35} $CHAR (02(16)) CAT $CHAR (00(16)) CAT {
          {line 36} $CHAR (10(16)) CAT $CHAR (01(16)) CAT {
          {line 37} $CHAR (2E(16)) CAT $CHAR (04(16)) CAT {
          {line 38} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 39} $CHAR (02(16)) CAT $CHAR (00(16)) CAT {
          {line 40} $CHAR (04(16)) CAT $CHAR (00(16)) CAT {
          {line 41} $CHAR (1A(16)) CAT $CHAR (08(16)) CAT {
          {line 42} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 43} $CHAR (26(16)) CAT $CHAR (01(16)) CAT {
          {line 44} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 45} $CHAR (0A(16)) CAT $CHAR (00(16)) CAT {
          {line 46} $CHAR (14(16)) CAT $CHAR (04(16)) CAT {
          {line 47} $CHAR (02(16)) CAT $CHAR (00(16)) CAT {
          {line 48} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 49} $CHAR (2E(16)) CAT $CHAR (00(16)) CAT {
          {line 50} $CHAR (00(16)) CAT $CHAR (01(16)) CAT {
          {line 51} $CHAR (12(16)) CAT $CHAR (08(16)) CAT {
          {line 52} $CHAR (04(16)) CAT $CHAR (00(16)) CAT {
          {line 53} $CHAR (0A(16)) CAT $CHAR (00(16)) CAT {
          {line 54} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 55} $CHAR (26(16)) CAT $CHAR (04(16)) CAT {
          {line 56} $CHAR (10(16)) CAT $CHAR (00(16)) CAT {
          {line 57} $CHAR (0A(16)) CAT $CHAR (01(16)) CAT {
          {line 58} $CHAR (04(16)) CAT $CHAR (00(16)) CAT {
          {line 59} $CHAR (02(16)) CAT $CHAR (00(16)) CAT {
          {line 60} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 61} $CHAR (3E(16)) CAT $CHAR (08(16)) CAT {
          {line 62} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 63} $CHAR (02(16)) CAT $CHAR (00(16)),

{ Lines 64 - 86 are common in an 8 lines per inch VFU.

    common_lines_in_8lpi: [READ] string (chars_in_common_8lpi) := {
          {line 64} $CHAR (04(16)) CAT $CHAR (05(16)) CAT {
          {line 65} $CHAR (0A(16)) CAT $CHAR (00(16)) CAT {
          {line 66} $CHAR (10(16)) CAT $CHAR (00(16)) CAT {
          {line 67} $CHAR (26(16)) CAT $CHAR (00(16)) CAT {
          {line 68} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 69} $CHAR (0A(16)) CAT $CHAR (00(16)) CAT {
          {line 70} $CHAR (04(16)) CAT $CHAR (00(16)) CAT {
          {line 71} $CHAR (12(16)) CAT $CHAR (09(16)) CAT {
          {line 72} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 73} $CHAR (2E(16)) CAT $CHAR (04(16)) CAT {
          {line 74} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 75} $CHAR (02(16)) CAT $CHAR (00(16)) CAT {
          {line 76} $CHAR (14(16)) CAT $CHAR (00(16)) CAT {
          {line 77} $CHAR (0A(16)) CAT $CHAR (00(16)) CAT {
          {line 78} $CHAR (00(16)) CAT $CHAR (01(16)) CAT {
          {line 79} $CHAR (26(16)) CAT $CHAR (00(16)) CAT {
          {line 80} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 81} $CHAR (1A(16)) CAT $CHAR (08(16)) CAT {
          {line 82} $CHAR (04(16)) CAT $CHAR (04(16)) CAT {
          {line 83} $CHAR (02(16)) CAT $CHAR (00(16)) CAT {
          {line 84} $CHAR (00(16)) CAT $CHAR (00(16)) CAT {
          {line 85} $CHAR (2E(16)) CAT $CHAR (01(16)) CAT {
          {line 86} $CHAR (10(16)) CAT $CHAR (20(16)),

{ This is the definition of lines 64 - 66 for a 6 line per inch VFU in
{ which deselect_auto_page_eject is also defined.

    lines_64_65_66_in_6lpi_dape: [READ] string (chars_lines_64_to_66) := {
          {line 64} $CHAR (04(16)) CAT $CHAR (25(16)) CAT {
          {line 65} $CHAR (0A(16)) CAT $CHAR (00(16)) CAT {
          {line 66} $CHAR (10(16)) CAT $CHAR (00(16)),

{ This is the definition of lines 64 - 66 for an 6 line per inch VFU in
{ which select_auto_page_eject is also defined.

    lines_64_65_66_in_6lpi_sape: [READ] string (chars_lines_64_to_66) := {
          {line 64} $CHAR (04(16)) CAT $CHAR (25(16)) CAT {
          {line 65} $CHAR (0A(16)) CAT $CHAR (02(16)) CAT {
          {line 66} $CHAR (10(16)) CAT $CHAR (00(16)),

{ This is the definition of lines 87 and 88 for an 8 line per inch VFU in
{ which deselect_auto_page_eject is also defined.

    lines_87_88_in_8lpi_dape: [READ] string (chars_lines_87_88) := {
          {line 87} $CHAR (02(16)) CAT $CHAR (00(16)) CAT {
          {line 88} $CHAR (04(16)) CAT $CHAR (00(16)),

{ This is the definition of lines 87 and 88 for an 8 line per inch VFU in
{ which select_auto_page_eject is also defined.

    lines_87_88_in_8lpi_sape: [READ] string (chars_lines_87_88) := {
          {line 87} $CHAR (02(16)) CAT $CHAR (02(16)) CAT {
          {line 88} $CHAR (04(16)) CAT $CHAR (00(16)),


{ This is the string that preceeds the VFU.  It contains the paper instruction
{ to go to the top of form.  The 'xx' needs to be replaced by $CHAR(6c(16))
{ or $CHAR(6d(16)) for a 6 line per inch or 8 line per inch VFU respectively.

    vfu_header: [STATIC] string (chars_vfu_header) := {
          activate_control_after_ackin CAT {
          skip_to_top_of_form CAT {
          deactivate_control_after_ackin CAT {
          define_recoverable_error CAT {
          activate_control_after_ackin CAT {
          fill_in_char, {fill_in_char is the vfu load command to be filled in

    vfu_trailer: [READ] string (chars_vfu_trailer) := {
          stop_vfu_load CAT {
          deactivate_control_after_ackin CAT {
          wait_for_paper_mvmt_cio1_porta CAT {
          define_recoverable_error;

?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE double_up_nuls', EJECT ??

{****************************************************************************}
{
{ PROCEDURE NAME: double_up_nuls
{
{ PURPOSE: This procedure looks at each character in the input_string and
{   puts it in the output string.  However, if the character is a NUL, then
{   it puts another NUL in the output string.  Strings passed to this
{   procedure contain NULs that are data.  They are doubled up so that they
{   are not interpreted as command escape characters by the URI TIP.
{
{*****************************************************************************

  PROCEDURE double_up_nuls
    (    input_string: string ( * );
     VAR double_nul_length: integer;
     VAR output_string: string ( * ));

    CONST
      characters_per_line = 2,
      lines_in_6lpi_vfu = 66,
      lines_in_8lpi_vfu = 88;

    VAR
      i: integer,
      j: integer,
      vfu_length: integer;

    IF currently_6lpi THEN
      vfu_length := lines_in_6lpi_vfu * characters_per_line;
    ELSE
      vfu_length := lines_in_8lpi_vfu * characters_per_line;
    IFEND;

    i := 1;
    j := 1;
    WHILE i <= vfu_length DO

      output_string (j) := input_string (i);
      IF input_string (i) = nul THEN
        j := j + 1;
        output_string (j) := nul
      IFEND;

      j := j + 1;
      i := i + 1;
    WHILEND;
    double_nul_length := j - 1;

  PROCEND double_up_nuls;
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE generate_file_beginning', EJECT ??

{****************************************************************************}
{
{ PROCEDURE NAME: generate_file_beginning
{
{ PURPOSE: To put the character sequence in the output file to do the
{   Define_device_down and the Define_not_ready commands.
{
{ DESCRIPTION:
{   The Define_device_down and Define_device_ready commands are put in string
{   define_attributes.  In this string there is first a command to deactivate
{   the paper instruction line, next the command to define the device down,
{   next to define not ready and next to terminate the file.
{
{*****************************************************************************

  PROCEDURE generate_file_beginning
    (    output_file_id: amt$file_identifier;
     VAR output_file_byte_address: amt$file_byte_address;
     VAR status: ost$status);

    CONST
      define_string_size = 10; { Number of characters in define commands sequence.

    VAR
      define_attributes: [STATIC] string (define_string_size) := deactivate_control CAT
            define_device_down CAT define_not_ready CAT end_of_file;

    status.normal := TRUE;
    amp$put_next (output_file_id, ^define_attributes, #SIZE (define_attributes),
          output_file_byte_address, status);

  PROCEND generate_file_beginning;
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE format_effector_pi', EJECT ??

{****************************************************************************}
{
{ PROCEDURE NAME: generate_format_effector_pi
{
{ PURPOSE: Get the format_effector out of the input_line just read and find the
{   paper instruction that matches the format effector.  Also, return in
{   variable print_action describing whether the format_effector is preprint,
{   postprint, vfu_load_dape, vfu_load_sape, vfu_load_6lpi, vfu_load_8lpi or
{   undefined.
{
{ DESCRIPTION:
{   The table fe_command_sequences contains the paper instruction for the
{   format_effectors and whether the instruction is preprint, postprint,
{   vfu_load_dape, vfu_load_sape, vfu_load_6lpi, vfu_load_8lpi, or
{   undefined.  The table is indexed from 0 to 127 containing an entry for each
{   possible character.  If the character is undefined, the value stored is
{   0ff(16); also the print_action is undefined.  This procedure gets the format
{   effector out of input_line and by indexing into the table
{   fe_command_sequences, returns the corresponding paper instruction and
{   whether or not the paper instruction is preprint, postprint or undefined.
{
{*****************************************************************************

  PROCEDURE generate_format_effector_pi
    (    input_line: string (maximum_input_bytes);
     VAR print_action: format_effector_action;
     VAR paper_instruction: char);


    VAR
      format_effector: character_range;


    format_effector := $INTEGER (input_line (1));
    paper_instruction := fe_command_sequences [format_effector].paper_instruction;
    print_action := fe_command_sequences [format_effector].print_action;


  PROCEND generate_format_effector_pi;
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE generate_line_in_output_file', EJECT ??

{****************************************************************************}
{
{ PROCEDURE NAME: generate_line_in_output_file
{
{ PURPOSE: This procedure takes the input_line passed in and generates the
{   matching output line with the appropriate URI Access Data Format commands
{   put into the line.  These commands are the format effector and the
{   define_recoverable error command.  When the output line is generated, it
{   is written to the output file.
{
{ DESCRIPTION:
{   This procedure calls procedures to do its functions.
{
{*****************************************************************************

  PROCEDURE generate_line_in_output_file
    (    input_line: string (maximum_input_bytes);
         input_file_byte_count: amt$transfer_count;
     VAR status: ost$status);

    VAR
      print_action: format_effector_action,
      paper_instruction: char;

    generate_format_effector_pi (input_line, print_action, paper_instruction);
    generate_rest_of_line (input_line, input_file_byte_count, print_action, paper_instruction,
          output_file_id, output_file_byte_address, status);

  PROCEND generate_line_in_output_file;
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE generate_rest_of_line', EJECT ??

{****************************************************************************}
{
{ PROCEDURE NAME: generate_rest_of_line
{
{ PURPOSE: Given the paper instruction and print_action passed in, put the rest
{   of the characters in the input_line in the output_line, positioning the
{   paper instruction URI Access Data Format command sequence before or after
{   the characters depending on whether it is preprint or postprint.  Also,
{   if the format effector was undefined, construct the command sequence so that
{   the line gets printed after advancing one line.
{
{ DESCRIPTION:
{   If the format effector was undefined, set the paper instruction to '11' and
{   set the print_action to preprint.  If the instruction is preprint, put
{   the URI Access Data command sequence before the rest of the line.  If it is
{   postprint, put the URI Access Data command sequence after the rest of the
{   line.  Next, put the end of line sequence at the end of output_line.
{
{*****************************************************************************

  PROCEDURE generate_rest_of_line
    (    input_line: string (maximum_input_bytes);
         input_file_byte_count: amt$transfer_count;
     VAR print_action: format_effector_action;
     VAR paper_instruction: char;
     VAR output_file_id: amt$file_identifier;
     VAR output_file_byte_address: amt$file_byte_address;
     VAR status: ost$status);

    VAR
      fe_index: 0 .. 1,
      format_effector_sequence: string (6),
      i: integer,
      character_count: integer,
      sequence_length: integer,
      postprint_buffer_flusher: [STATIC] string (postprint_buffer_flusher_length) :=
            activate_control_after_ackin CAT advance_0_lines CAT
            deactivate_control_after_ackin;


    status.normal := TRUE;

{ If the format effector indicates a VFU load for a six lines per inch VFU
{ or and eight lines per inch VFU, verify that this doesn't conflict with the
{ device print density.  If the format effector does conflict with the
{ device print density, treat the format effector the same as an undefined
{ format effector.

    IF ((print_action = vfu_load_6lpi) AND (device_print_density (1,
          10) = 'EIGHT_ONLY') OR (print_action = vfu_load_8lpi) AND
          (device_print_density (1, 8) = 'SIX_ONLY')) THEN
      print_action := undefined;
    IFEND;

    CASE print_action OF

    = preprint, postprint, undefined =

{ Process the format effector.  Insert the format_effector_sequence before the
{ text or after the text depending on whether it's preprint or postprint.
{ If the print_action is undefined, advance one line before printing.

      IF print_action = undefined THEN
        paper_instruction := line_feed;
        print_action := preprint;
      IFEND;

{ Generate the format effector sequence.

      IF paper_instruction = nul THEN
        STRINGREP (format_effector_sequence, sequence_length, act_ctrl_after_ackin_str,
              $CHAR (00), $CHAR (00), deact_ctrl_after_ackin_str);

      ELSE
        STRINGREP (format_effector_sequence, sequence_length, act_ctrl_after_ackin_str,
              paper_instruction, deact_ctrl_after_ackin_str);
      IFEND;

      IF print_action = preprint THEN
        output_line (1, sequence_length) := format_effector_sequence (1, sequence_length);
        character_count := sequence_length + 1;
      ELSE
        output_line (1, postprint_buffer_flusher_length) := postprint_buffer_flusher;
        character_count := postprint_buffer_flusher_length + 1;
      IFEND;

      FOR i := 2 TO input_file_byte_count DO
        output_line (character_count) := input_line (i);
        character_count := character_count + 1;
      FOREND;

      IF print_action = postprint THEN
        output_line (character_count, sequence_length) :=
              format_effector_sequence (1, sequence_length);
        character_count := character_count + sequence_length
      IFEND;

      output_line (character_count, 3) := define_recoverable_error;

{ Adjust characters to be output depending on whether or not input_line is empty.

      IF input_file_byte_count = 0 THEN
        fe_index := 0
      ELSE
        fe_index := 1;
      IFEND;
      amp$put_next (output_file_id, ^output_line, input_file_byte_count - fe_index +
            sequence_length + 3, output_file_byte_address, status);

    = vfu_load_dape, vfu_load_sape, vfu_load_6lpi, vfu_load_8lpi =

{ Determine which VFU needs to be used and generate it in output_line.

      generate_vfu (print_action, output_file_id, output_file_byte_address, status);

    CASEND;

  PROCEND generate_rest_of_line;
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE generate_vfu', EJECT ??

{****************************************************************************}
{
{ PROCEDURE NAME: generate_vfu
{
{ PURPOSE: To write the appropriate VFU to the output file given the vfu_id.
{
{ DESCRIPTION:
{   Given the vfu_id passed in, create the vfu defining it correctly for six
{   lines per inch, deselect auto page eject and select auto page eject.  The
{   VFU is created selecting the appropriate strings defined for a VFU.
{
{*****************************************************************************

  PROCEDURE generate_vfu
    (    vfu_id: vfu_range;
         output_file_id: amt$file_identifier;
     VAR output_file_byte_address: amt$file_byte_address;
     VAR status: ost$status);


    VAR
      temp_string: string (vfu_max_len_in_characters),
      double_nul_length: integer,
      double_nul_string: string (2 * vfu_max_len_in_characters),
      output_vfu: string ((2 * vfu_max_len_in_characters) + 20),
      vfu_length: integer;

    temp_string := ' ';
    double_nul_string := ' ';
    output_vfu := ' ';
    status.normal := TRUE;

{ Set apropriate global variable depending on the value of vfu_id.

    CASE vfu_id OF

    = vfu_load_6lpi =
      IF currently_6lpi AND initial_vfu_loaded THEN
        RETURN; { This VFU is already loaded.
      IFEND;
      currently_6lpi := TRUE;

    = vfu_load_8lpi =
      IF NOT currently_6lpi AND initial_vfu_loaded THEN
        RETURN; { This VFU is already loaded.
      IFEND;
      currently_6lpi := FALSE;

    = vfu_load_sape =
      IF currently_sape AND initial_vfu_loaded THEN
        RETURN; { This VFU is already loaded.
      IFEND;
      currently_sape := TRUE;

    = vfu_load_dape =
      IF NOT currently_sape AND initial_vfu_loaded THEN
        RETURN; { This VFU is already loaded.
      IFEND;
      currently_sape := FALSE;

    CASEND;

    temp_string (1, chars_in_common_63_lines) := common_63_lines_in_6lpi_8lpi;

    IF currently_6lpi THEN
      IF currently_sape THEN
        temp_string (chars_in_common_63_lines + 1, chars_lines_64_to_66) :=
              lines_64_65_66_in_6lpi_sape;
      ELSE
        temp_string (chars_in_common_63_lines + 1, chars_lines_64_to_66) :=
              lines_64_65_66_in_6lpi_dape;
      IFEND;
    ELSE
      temp_string (chars_in_common_63_lines + 1, chars_in_common_8lpi) := common_lines_in_8lpi;

      IF currently_sape THEN
        temp_string (chars_in_common_63_lines + chars_in_common_8lpi + 1,
              chars_lines_87_88) := lines_87_88_in_8lpi_sape
      ELSE
        temp_string (chars_in_common_63_lines + chars_in_common_8lpi + 1,
              chars_lines_87_88) := lines_87_88_in_8lpi_dape
      IFEND;
    IFEND;

{ Double all NULs in the VFU since these are data.

    double_up_nuls (temp_string, double_nul_length, double_nul_string);

{ Put on header and trailer and put in 6c or 6d and output it to a file.

    STRINGREP (output_vfu, vfu_length, vfu_header, double_nul_string (1, double_nul_length),
          vfu_trailer);
    IF currently_6lpi THEN
      output_vfu (vfu_load_type_position) := start_vfu_load_6lpi
    ELSE
      output_vfu (vfu_load_type_position) := start_vfu_load_8lpi
    IFEND;

    amp$put_next (output_file_id, ^output_vfu, vfu_length, output_file_byte_address, status);


  PROCEND generate_vfu;
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE process_parameters_open_files', EJECT ??
{****************************************************************************}
{
{ PROCEDURE NAME: process_parameters_open_files
{
{ PURPOSE: This procedure gets and validates the parameters passed in to the
{   program NFM$PREPROCESS_URI.  These parameters are input, output, data_mode,
{   vertical_print_density, page_length, page_width and status.
{   The input and output files specified are opened.
{
{*****************************************************************************

  PROCEDURE process_parameters_open_files
    (VAR input_file_id: amt$file_identifier;
     VAR output_file_id: amt$file_identifier;
     VAR vfu_id: vfu_range;
     VAR status: ost$status);

    VAR
      cycle_attributes: ^fst$file_cycle_attributes,
      file_attachment_options: ^fst$attachment_options,
      file_attributes: array [1 .. 1] of amt$get_item,
      file_prev_opened: boolean,
      ignored_file_contains_data: boolean,
      ignored_file_exists: boolean,
      vertical_print_density_value: ^clt$data_value;


{ Validate the parameters passed to this procedure. Return to the caller on error.

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Process the FILE_PRINT_DENSITY parameter.

    currently_6lpi := (pvt [p$file_print_density].value^.keyword_value (1) = 'S');

{ Process the DEVICE_PRINT_DENSITY parameter.

    device_print_density := pvt [p$device_print_density].value^.keyword_value;

{ If the file_print_density conflicts with the device_print_density, set the
{ file_print_density to match the device_print_density.

    IF currently_6lpi AND (device_print_density (1, 10) = 'EIGHT_ONLY') THEN
      currently_6lpi := FALSE
    ELSEIF NOT currently_6lpi AND (device_print_density (1, 8) = 'SIX_ONLY') THEN
      currently_6lpi := TRUE
    IFEND;

    IF currently_6lpi THEN
      vfu_id := vfu_load_6lpi
    ELSE
      vfu_id := vfu_load_8lpi
    IFEND;

{ Process the INPUT parameter. Note that memory obtained to store file attachment
{ options unconditionally because it will be used at least once when the output
{ file is opened.

    PUSH file_attachment_options: [1 .. 1];

    IF pvt [p$input].value^.field_values^ [file_field].value = NIL THEN

{ The input file is the original queue file in the output queue.


      jmp$open_output_file (pvt [p$input].value^.field_values^ [sfn_field].
            value^.name_value (1, jmc$system_supplied_name_size), amc$record, jmc$public_usage,
            pvt [p$input].value^.field_values^ [password_field].value^.string_value^,
            input_file_id, status);

    ELSE

{ The input file is the output of another filter. Ignore the original queue file.

      file_attachment_options^ [1].selector := fsc$create_file;
      file_attachment_options^ [1].create_file := FALSE;
      fsp$open_file (pvt [p$input].value^.field_values^ [file_field].value^.file_value^,
            amc$record, file_attachment_options, NIL, NIL, NIL, NIL, input_file_id, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Process the OUTPUT parameter.  Return an abnormal status if the output file
{ already exists.

    file_attributes [1].key := amc$null_attribute;
    amp$get_file_attributes (pvt [p$output].value^.file_value^, file_attributes,
          ignored_file_exists, file_prev_opened, ignored_file_contains_data, status);

    IF file_prev_opened THEN
      osp$set_status_abnormal ('PF', pfe$lfn_in_use, pvt [p$output].
            value^.file_value^, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            'pvt[p$output].value^.file_value', status);
      RETURN;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH cycle_attributes: [1 .. 5];

{ File contents, page format, page length, and page width attributes are
{ specified to provide accurate file attributes to other batch output filters
{ which may process the output of this filter, and to prevent any batch filter
{ from attempting to 'burst' the file contents.

    cycle_attributes^ [1].selector := fsc$file_contents_and_processor;
    cycle_attributes^ [1].file_contents := 'UNKNOWN';
    cycle_attributes^ [1].file_processor := osc$null_name;

    cycle_attributes^ [2].selector := fsc$page_format;
    cycle_attributes^ [2].page_format := amc$continuous_form;

    cycle_attributes^ [3].selector := fsc$page_length;
    cycle_attributes^ [3].page_length := pvt [p$page_length].value^.integer_value.value;

    cycle_attributes^ [4].selector := fsc$page_width;
    cycle_attributes^ [4].page_width := pvt [p$page_width].value^.integer_value.value;

    cycle_attributes^ [5].selector := fsc$record_type;
    cycle_attributes^ [5].record_type := amc$undefined;

    file_attachment_options^ [1].selector := fsc$create_file;
    file_attachment_options^ [1].create_file := TRUE;


    fsp$open_file (pvt [p$output].value^.file_value^, amc$record, file_attachment_options, NIL,
          cycle_attributes, NIL, NIL, output_file_id, status);


  PROCEND process_parameters_open_files;
?? OLDTITLE ??
?? EJECT ??

{   BEGIN nfp$preprocess_uri;

    status.normal := TRUE;

    process_parameters_open_files (input_file_id, output_file_id, vfu_id, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    generate_file_beginning (output_file_id, output_file_byte_address, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    initial_vfu_loaded := FALSE;
    generate_vfu (vfu_id, output_file_id, output_file_byte_address, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    initial_vfu_loaded := TRUE;

    input_line := ' ';
    amp$get_next (input_file_id, ^input_line, maximum_input_bytes, input_file_byte_count,
          input_file_byte_address, input_file_position, status);
    WHILE (input_file_position <> amc$eoi) AND status.normal DO
      generate_line_in_output_file (input_line, input_file_byte_count, status);
      input_line := ' ';
      amp$get_next (input_file_id, ^input_line, maximum_input_bytes, input_file_byte_count,
            input_file_byte_address, input_file_position, status);

    WHILEND;

    IF pvt [p$input].value^.field_values^ [file_field].value = NIL THEN
      jmp$close_output_file (input_file_id, status);
    ELSE
      fsp$close_file (input_file_id, status);
    IFEND;
    fsp$close_file (output_file_id, status);

  PROCEND nfp$preprocess_uri;

MODEND nfm$preprocess_uri;

*DECK DECK=NFM$PTF_CLIENT EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, INDENT := 2) ??
?? SET (LIST := ON, LISTCTS := OFF) ??
MODULE nfm$ptf_client;
{
{     PURPOSE:
{            This module contains procedures to perform Permanent file
{            Transfer Facility (PTF) client functions.
{
{     DESCRIPTION:
{            Requests for
{            PTF client access come either through the Manage Remote Files
{            (MANRF) command or implicit command access.  The MANRF command
{            gains access to the starting procedure nfp$manage_remote_files
{            via a program descriptor known to SCL.  Implicit command access
{            allows a number of SCL commands (e.g. Copy_File, Display_Catalog,
{            etc.) to execute a PTF client task with the starting procedure
{            nfp$perform_implicit_transfer.
{
*copyc amk$base_keypoint_values
*copyc amp$get_file_attributes
*copyc amp$open
*copyc amp$put_next
*copyc avp$get_capability
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_integer
*copyc clp$convert_str_to_path_handle
*copyc clp$evaluate_parameters
*copyc clp$get_command_origin
*copyc clp$get_fs_path_string
*copyc clp$get_line_from_command_file
*copyc clp$get_parameter_list
*copyc clp$convert_value_to_string
*copyc clp$pop_input
*copyc clp$push_input
*copyc clp$read_variable
*copyc clp$substitute_delimited_text
*copyc jme$queued_file_conditions
*copyc fmt$path_handle
*copyc fse$copy_validation_errors
*copyc fst$evaluated_file_reference
*copyc fst$path_handle_name
*copyc jmp$system_job
*copyc mmp$create_scratch_segment
*copyc nap$get_attributes
*copyc nap$request_connection
*copyc nap$se_send_data
*copyc nap$se_receive_data
*copyc nap$store_attributes
*copyc nfp$count_directives_text
*copyc nfp$find_remote_validation
*copyc nfp$format_message_to_job_log
*copyc nfp$generate_ptf_statistic
*copyc nfp$verify_family
*copyc nfp$get_remote_validation
*copyc nfp$set_abnormal_if_normal
*copyc nfp$string_length
*copyc nfp$convert_p31_to_ordinal
*copyc nfp$dispose_user_msg_to_log
*copyc nfp$find_delimitd_string_length
*copyc nfp$send_command
*copyc nfp$send_connect_request
*copyc nfp$receive_command
*copyc nfp$initialize_control_block
*copyc nfp$transfer_file
*copyc nfp$ptf_format_message_to_out
*copyc nfp$terminate_path
*copyc osp$append_status_parameter
*copyc osp$await_activity_completion
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_170_os_type
*copyc pmp$get_compact_date_time
*copyc pmp$get_job_names
*copyc pmp$get_user_identification
*copyc pmp$generate_unique_name
*copyc pmp$log
*copyc pmp$exit
*copyc rfp$get_local_host_physical_id
*copyc rfp$store
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc cle$ecc_command_processing
*copyc cle$ecc_expression_result
*copyc jme$queued_file_conditions
*copyc nae$application_interfaces
*copyc nfe$ptf_condition_codes
*copyc nfe$sou_condition_codes
*copyc nft$directive_entry
*copyc nft$file_access_mode
*copyc nft$ve_to_ve_access
*copyc oss$job_paged_literal
*copyc clc$standard_file_names
*copyc cld$parameter_list
*copyc nfk$keypoints
*copyc nfs$ptf_static_data
*copyc nft$implicit_command
*copyc nft$number_implicit_commands
*copyc ost$caller_identifier
*copyc ost$name
*copyc ost$status
*copyc nfc$abnormal_conditions
*copyc NFC$COMMAND_DEFINITIONS
*copyc NFC$PARAMETER_DEFINITIONS
*copyc NFC$PARAMETER_00_DEFINITIONS
*copyc NFC$PARAMETER_01_DEFINITIONS
*copyc NFC$PARAMETER_02_DEFINITIONS
*copyc NFC$PARAMETER_03_DEFINITIONS
*copyc NFC$PARAMETER_04_DEFINITIONS
*copyc NFC$PARAMETER_05_DEFINITIONS
*copyc NFC$PARAMETER_06_DEFINITIONS
*copyc NFC$PARAMETER_07_DEFINITIONS
*copyc NFC$PARAMETER_08_DEFINITIONS
*copyc NFC$PARAMETER_09_DEFINITIONS
*copyc NFC$PARAMETER_10_DEFINITIONS
*copyc NFC$PARAMETER_11_DEFINITIONS
*copyc NFC$PARAMETER_12_DEFINITIONS
*copyc NFC$PARAMETER_13_DEFINITIONS
*copyc NFC$PARAMETER_16_DEFINITIONS
*copyc NFC$PARAMETER_20_DEFINITIONS
*copyc NFC$PARAMETER_21_DEFINITIONS
*copyc NFC$PARAMETER_22_DEFINITIONS
*copyc NFC$PARAMETER_24_DEFINITIONS
*copyc NFC$PARAMETER_25_DEFINITIONS
*copyc NFC$PARAMETER_26_DEFINITIONS
*copyc NFC$PARAMETER_27_DEFINITIONS
*copyc NFC$PARAMETER_28_DEFINITIONS
*copyc NFC$PARAMETER_29_DEFINITIONS
*copyc NFC$PARAMETER_30_DEFINITIONS
*copyc NFC$PARAMETER_31_DEFINITIONS
*copyc NFC$PARAMETER_32_DEFINITIONS
*copyc NFC$PARAMETER_33_DEFINITIONS
*copyc NFC$PARAMETER_90_DEFINITIONS
*copyc NFC$PARAMETER_91_DEFINITIONS
*copyc NFC$PARAMETER_92_DEFINITIONS
*copyc NFC$PARAMETER_93_DEFINITIONS
*copyc NFC$PARAMETER_94_DEFINITIONS
*copyc NFC$PARAMETER_95_DEFINITIONS
*copyc NFC$PARAMETER_96_DEFINITIONS
*copyc NFC$PARAMETER_97_DEFINITIONS
*copyc NFC$PARAMETER_98_DEFINITIONS
*copyc NFC$PARAMETER_99_DEFINITIONS
*copyc nfe$batch_transfer_services
*copyc nfe$ptf_condition_codes
*copyc nft$transfer_declarations
*copyc nft$transfer_status
*copyc NFT$FILE_ACCESS_MODE
*copyc NFT$MODE_OF_ACCESS
*copyc nft$parameter_values
*copyc nft$parameter_qualifiers
*copyc nft$parameter_qualifier_values
*copyc nft$application_values
*copyc NFT$PARAMETER_00_VALUES
*copyc NFT$PARAMETER_01_VALUES
*copyc nft$parameter_03_values
*copyc nft$parameter_03_value_set
*copyc nft$parameter_03_netvalues
*copyc nft$parameter_03_elements
*copyc nft$parameter_04_values
*copyc nft$parameter_06_values
*copyc nft$parameter_12_range
*copyc nft$parameter_20_range
*copyc NFT$PARAMETER_21_values
*copyc NFT$PARAMETER_21_OPTIONS
*copyc NFT$PARAMETER_21_specifications
*copyc nft$parameter_22_values
*copyc nft$parameter_22_strings
*copyc nft$parameter_24_definition
*copyc nft$parameter_25_definition
*copyc nft$parameter_26_definition
*copyc nft$parameter_26_all_chars
*copyc nft$parameter_27_definition
*copyc NFT$PROTOCOL_COMMANDS
*copyc NFT$PROTOCOL_PARAMETERS
*copyc nft$parameter_set
*copyc nft$command_set
*COPYC NFT$P00_VALUES
*copyc nft$last_command_sent
*copyc nft$last_command_received
*copyc nft$control_block
*copyc nft$network_type
*copyc nft$directive_entry
*copyc nft$parameter_rules
*copyc nft$command_values
*copyc nft$crack_parameter_action
*copyc nft$buffer_control_block
*copyc nft$ptf_protocol_states
*copyc nft$required_param_on_command
*copyc nft$ve_to_ve_access
*copyc nfv$p04_values
*copyc osv$lower_to_upper
*copyc rfe$condition_codes

  TYPE
    nft$ptf_transfer_state = (nfc$xfer_complete_normal, nfc$xfer_retryable_term_connect,
          nfc$xfer_retryable_neg_protocol, nfc$xfer_retryable_path_discon, nfc$xfer_noretry_term_connect,
          nfc$xfer_noretry_path_discon);

  TYPE
    nft$ptf_transfer_state_set = set of nft$ptf_transfer_state;

?? NEWTITLE := 'ptf static definitions', EJECT ??

{ nfm$ptf_static_definitions }


  VAR
    nfv$ptf_required_params: [READ, STATIC, XDCL, nfs$ptf_static_data] nft$required_param_on_command := [[],
    { Null Command }
    [nfc$protocol_id, { RFT }
          nfc$user_text_directive, nfc$host_type, nfc$transfer_lid, nfc$job_name, nfc$physical_id],
          [nfc$protocol_id, { RPOS }
          nfc$mode_of_access, nfc$host_type, nfc$job_name, nfc$physical_id], [nfc$state_of_transfer], { RNEG }
          [], { GO }
          [nfc$state_of_transfer], { STOP }
          [nfc$state_of_transfer], { STOPR }
          [], { ETP }
          [], { ETPR }
          []]; { FINI }

  VAR
    ptf_parameter_00_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p00_min_size, nfc$p00_size_a101, [nfc$rft, nfc$rpos], [], [nfc$stop], [nfc$go, nfc$stopr],
          TRUE], [{ A102 }
          TRUE, nfc$p00_min_size, nfc$p00_size_a102, [nfc$rft, nfc$rpos], [], [nfc$stop], [nfc$go, nfc$stopr],
          TRUE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_01_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p01_min_size, nfc$p01_max_size, [], [], [], [], FALSE], [{ A102 }
          TRUE, nfc$p01_min_size, nfc$p01_max_size, [], [], [], [], TRUE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_02_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p02_min_size, nfc$p02_max_size, [], [], [], [], FALSE], [{ A102 }
          TRUE, nfc$p02_min_size, nfc$p02_max_size, [], [], [], [], FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_03_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p03_min_size, nfc$p03_max_size, [], [], [], [], FALSE], [{ A102 }
          TRUE, nfc$p03_min_size, nfc$p03_max_size, [], [], [], [], FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_04_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p04_min_param_len, nfc$p04_max_param_len, [], [], [], [], FALSE], [{ A102 }
          TRUE, nfc$p04_min_param_len, nfc$p04_max_param_len, [], [], [], [], FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_05_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p05_min_param_len, nfc$ptfs_job_line_width, [], [], [], [], TRUE], [{ A102 }
          TRUE, nfc$p05_min_param_len, nfc$ptfs_job_line_width, [], [], [], [], TRUE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_06_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p06_min_param_len, nfc$p06_max_param_len, [], [], [], [], FALSE], [{ A102 }
          TRUE, nfc$p06_min_param_len, nfc$p06_max_param_len, [], [], [], [], TRUE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_07_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p07_min_param_len, nfc$p07_max_param_len_a101, [], [], [], [], TRUE], [{ A102 }
          TRUE, nfc$p07_min_param_len, nfc$p07_max_param_len_a102, [], [], [], [], TRUE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_08_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p08_min_param_len, nfc$p08_max_param_len_a101, [], [], [], [], TRUE], [{ A102 }
          TRUE, nfc$p08_min_param_len, nfc$p08_max_param_len_a102, [], [], [], [], TRUE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_09_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p09_min_param_len, nfc$p09_max_param_len_a101, [], [], [], [], TRUE], [{ A102 }
          TRUE, nfc$p09_min_param_len, nfc$p09_max_param_len_a102, [], [], [], [], TRUE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_10_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p10_min_param_len, nfc$p10_max_param_len_a101, [], [], [], [], TRUE], [{ A102 }
          TRUE, nfc$p10_min_param_len, nfc$p10_max_param_len_a102, [], [], [], [], TRUE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_11_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p11_min_param_len, nfc$p11_max_param_len, [], [], [], [], TRUE], [{ A102 }
          TRUE, nfc$p11_min_param_len, nfc$p11_max_param_len, [], [], [], [], TRUE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_12_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p12_min_size_a101, nfc$p12_max_size_a101, [], [], [], [], TRUE], [{ A102 }
          TRUE, nfc$p12_min_size_a102, nfc$p12_max_size_a102, [], [], [], [], TRUE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_13_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p13_min_param_size, nfc$p13_max_param_size, [], [], [], [], TRUE], [{ A102 }
          TRUE, nfc$p13_min_param_size, nfc$p13_max_param_size, [], [], [], [], TRUE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_16_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p16_min_param_length, nfc$p16_max_param_length_a101, [], [], [], [], TRUE], [{ A102 }
          TRUE, nfc$p16_min_param_length, nfc$p16_max_param_length_a102, [], [], [], [], TRUE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_17_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A102 }
          FALSE], [{ A101 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_18_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A102 }
          FALSE], [{ A101 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_19_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A102 }
          FALSE], [{ A101 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_20_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p20_min_size, nfc$p20_max_size, [], [], [], [], TRUE], [{ A102 }
          TRUE, nfc$p20_min_size, nfc$p20_max_size, [], [], [], [], TRUE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_21_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p21_min_param_len, nfc$p21_max_param_len, [], [], [], [], TRUE], [{ A102 }
          TRUE, nfc$p21_min_param_len, nfc$p21_max_param_len, [], [], [], [], TRUE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_22_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p22_min_size, nfc$p22_max_size, [], [], [], [], TRUE], [{ A102 }
          TRUE, nfc$p22_min_size, nfc$p22_max_size, [], [], [], [], TRUE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_23_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A102 }
          FALSE], [{ A101 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_24_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A102 }
          FALSE], [{ A101 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_25_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p25_min_param_size_a101, nfc$p25_max_param_size_a101, [], [], [], [], TRUE], [{ A102 }
          TRUE, nfc$p25_min_param_size_a102, nfc$p25_max_param_size_a102, [], [], [], [], TRUE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_26_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p26_min_param_length, nfc$p26_max_param_length_a101, [], [], [], [], TRUE], [{ A102 }
          TRUE, nfc$p26_min_param_length, nfc$p26_max_param_length_a102, [], [], [], [], TRUE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_27_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p27_min_param_size_a101, nfc$p27_max_param_size_a101, [], [], [], [], FALSE], [{ A102 }
          TRUE, nfc$p27_min_param_size_a102, nfc$p27_max_param_size_a102, [], [], [], [], FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_28_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p28_min_size, nfc$p28_max_size, [], [], [], [], FALSE], [{ A102 }
          TRUE, nfc$p28_min_size, nfc$p28_max_size, [], [], [], [], FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_29_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p29_min_param_size_a101, nfc$p29_max_param_size_a101, [], [], [], [], FALSE], [{ A102 }
          TRUE, nfc$p29_min_param_size_a102, nfc$p29_max_param_size_a102, [], [], [], [], FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_30_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p30_min_param_size, nfc$p30_max_param_size, [], [], [], [], FALSE], [{ A102 }
          TRUE, nfc$p30_min_param_size, nfc$p30_max_param_size, [], [], [], [], FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_31_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p31_min_param_length_a101, nfc$p31_max_param_length_a101, [], [], [], [], FALSE],
          [{ A102 }
          TRUE, nfc$p31_min_param_length_a102, nfc$p31_max_param_length_a102, [], [], [], [], FALSE],
          [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_32_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p32_min_param_length_a101, nfc$p32_max_param_length_a101, [], [], [], [], FALSE],
          [{ A102 }
          TRUE, nfc$p32_min_param_length_a102, nfc$p32_max_param_length_a102, [], [], [], [], FALSE],
          [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_33_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          TRUE, nfc$p33_min_param_length_a101, nfc$p33_max_param_length_a101, [], [], [], [], FALSE],
          [{ A102 }
          TRUE, nfc$p33_min_param_length_a102, nfc$p33_max_param_length_a102, [], [], [], [], FALSE],
          [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_51_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_52_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_53_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_54_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_55_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_56_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_57_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_58_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_59_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_60_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_90_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_91_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_92_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_93_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_94_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_95_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_96_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_97_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_98_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    ptf_parameter_99_rules: [READ, STATIC, nfs$ptf_static_data] nft$parameter_rules := [[{ A101 }
          FALSE], [{ A102 }
          FALSE], [{ B101 }
          FALSE]];

  VAR
    nfv$ptf_parameter_rules: [STATIC, READ, XDCL, nfs$ptf_static_data] nft$parameter_rules_array :=
          [^ptf_parameter_00_rules, ^ptf_parameter_01_rules, ^ptf_parameter_02_rules, ^ptf_parameter_03_rules,
          ^ptf_parameter_04_rules, ^ptf_parameter_05_rules, ^ptf_parameter_06_rules, ^ptf_parameter_07_rules,
          ^ptf_parameter_08_rules, ^ptf_parameter_09_rules, ^ptf_parameter_10_rules, ^ptf_parameter_11_rules,
          ^ptf_parameter_12_rules, ^ptf_parameter_13_rules, ^ptf_parameter_16_rules, ^ptf_parameter_17_rules,
          ^ptf_parameter_18_rules, ^ptf_parameter_19_rules, ^ptf_parameter_20_rules, ^ptf_parameter_21_rules,
          ^ptf_parameter_22_rules, ^ptf_parameter_23_rules, ^ptf_parameter_24_rules, ^ptf_parameter_25_rules,
          ^ptf_parameter_26_rules, ^ptf_parameter_27_rules, ^ptf_parameter_28_rules, ^ptf_parameter_29_rules,
          ^ptf_parameter_30_rules, ^ptf_parameter_31_rules, ^ptf_parameter_32_rules, ^ptf_parameter_33_rules,
          ^ptf_parameter_51_rules, ^ptf_parameter_52_rules, ^ptf_parameter_53_rules, ^ptf_parameter_54_rules,
          ^ptf_parameter_55_rules, ^ptf_parameter_56_rules, ^ptf_parameter_57_rules, ^ptf_parameter_58_rules,
          ^ptf_parameter_59_rules, ^ptf_parameter_60_rules,
          ^ptf_parameter_90_rules, ^ptf_parameter_91_rules, ^ptf_parameter_92_rules, ^ptf_parameter_93_rules,
          ^ptf_parameter_94_rules, ^ptf_parameter_95_rules, ^ptf_parameter_96_rules, ^ptf_parameter_97_rules,
          ^ptf_parameter_98_rules, ^ptf_parameter_99_rules];

?? POP ??
?? OLDTITLE ??
?? NEWTITLE := 'access_remote_file', EJECT ??

  PROCEDURE access_remote_file
    (    location: ost$name;
         file_name: amt$local_file_name;
         data_declaration: nft$parameter_31_type;
         directives: ^nft$directive_entry;
         known_host: nft$ve_to_ve_access;
         ptf_command: ost$string;
     VAR status: ost$status);

{
{ Procedure access_remote_file
{
{ Purpose   Handle connect phase, protocol phase,
{           and retry conditions.
{
{ Description This module initiates connect to remote host.  Then protocol
{             exchange up to data transfer is performed.  The data transfer
{             module is called for file transfer.  If any errors occur,
{             the possibility for retry is considered.
{
{ Input parameters
{            Location             : Name of remote family/host
{            File_name            : File to be transferred (if any)
{            Data_declaration     : Data format of transfer (if any)
{            Directives           : List of remote host directives
{            File_access_mode     : Flag if mode of access is known
{            Known_host           : Flag if remote host is NOS/VE (for sure)
{            Ptf_command          : Command which initiated PTF
{
{ Output parameters
{            Status               : Returned status
{
?? EJECT ??

    VAR
      arf_conditions: pmt$condition,
      arf_condition_descriptor: pmt$established_handler,
      caller_id: ost$caller_identifier,
      control_block: nft$control_block,
      ignore_status: ost$status,
      nam_attributes: ^nat$change_attributes,
      nam_optimum_attributes: ^nat$get_attributes,
      network_file_name: ost$unique_name,
      path_name: ost$unique_name,
      physical_id: rft$physical_identifier,
      rhfam_attributes: ^rft$change_attributes,
      terminate_now: boolean,
      transfer_state: nft$ptf_transfer_state,
      user_id: ost$user_identification;

    VAR
      nfv$ptf_parameter_rules: [XREF] nft$parameter_rules_array;

    VAR
      nfv$ptf_send_p03_values: [STATIC, READ, XDCL, nfs$ptf_static_data] nft$parameter_03_netvalues :=
            [[], [nfc$collective_text_string, nfc$ss_ack_required], [nfc$collective_text_string]];

    VAR
      nfv$retry_states: [XDCL, STATIC, READ, nfs$ptf_static_data] nft$ptf_transfer_state_set :=
            [nfc$xfer_retryable_term_connect, nfc$xfer_retryable_neg_protocol,
            nfc$xfer_retryable_path_discon];

?? NEWTITLE := 'arf_condition_handler', EJECT ??

    PROCEDURE arf_condition_handler
      (    condition: pmt$condition;
           condition_desc: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR trap_status: ost$status);

{
{ Procedure  arf_condition_handler
{
{ Purpose    To handle any condition which occurs while a path is connected.
{            This handler is responsible for "cleaning up" any resources
{            (including connections) held by the application at the time
{            of the condition.
{
{ Description
{            This routine's only purpose is to terminate any outstanding
{            connection to a remote host.  This must be done so that the
{            servicer may terminate.  Note: the interactive conditions
{            pause and reconnect are treated somewhat differently.  We do
{            not allow transfers to be paused.  This would result in network
{            resources (DI/NAD buffers) being locked until path timeout
{            or the connection is resumed.  Therefore, we assume the user
{            wanted to continue, so a 'we ignored your interrupt' is
{            delivered.  The exception is for NOS/BE dual state systems.
{            NOS/BE allows only one asynch interrupt, and that is mapped
{            to NOS/VE pause.  If the pause were not serviced as a break,
{            the user could never terminate.  Therefore, on NOS/BE, a
{            pause terminates the transfer.
{
{ Input parameters
{            See info on condition handlers.  Also note, because defined
{            in access remote file, we have access to all of arf's
{            variables.
{
{ Output parameters
{            trap_status          : returned status
{

      VAR
        ignored_params: nft$parameter_set,
        local_status: ost$status,
        modified_params: nft$parameter_set,
        os_type: ost$170_os_type,
        output_status: ost$status,
        received_params: nft$parameter_set;

      VAR
        nfv$ptf_required_params: [XREF] nft$required_param_on_command;

      CASE condition.selector OF
      = ifc$interactive_condition =
        CASE condition.interactive_condition OF
        = ifc$pause_break, ifc$job_reconnect =
          pmp$get_170_os_type (os_type, local_status);
          IF (NOT local_status.normal) OR (os_type = osc$ot7_dual_state_nos_be) THEN
            IF control_block.path.path_connected THEN
              nfp$terminate_path (control_block.application, TRUE, control_block.path, local_status);
              osp$set_status_from_condition (nfc$status_id, condition, save_area, status, local_status);
              EXIT access_remote_file;
            IFEND;
          ELSE
            { spit out a message saying pause ignored }
            osp$set_status_abnormal (nfc$status_id, nfe$user_interrupt_ignored, '', output_status);
            nfp$ptf_format_message_to_out( output_status );
            RETURN;
          IFEND;
        = ifc$terminate_break =
          IF control_block.path.path_connected THEN
            nfp$terminate_path (control_block.application, TRUE, control_block.path, local_status);
          IFEND;
          pmp$continue_to_cause (pmc$execute_standard_procedure, trap_status);
          osp$set_status_from_condition (nfc$status_id, condition, save_area, status, local_status);
          EXIT access_remote_file;
        = ifc$terminal_connection_broken =
          pmp$continue_to_cause (pmc$execute_standard_procedure, trap_status);
          RETURN;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, trap_status);
          RETURN;
        CASEND;
      = pmc$block_exit_processing =
        IF control_block.path.path_connected THEN
          IF (control_block.last_command_sent <> nfc$unknown_command) AND
            (control_block.last_command_received <> nfc$unknown_command) THEN
            IF (control_block.last_command_sent = nfc$rft) AND (control_block.last_command_received =
                  nfc$rpos) THEN
              control_block.last_command_received := nfc$rneg;
            IFEND;
            ptf_process_protocol (control_block, local_status);
            IF local_status.normal THEN
              ptf_terminate_connection (control_block);
            IFEND;
            pmp$continue_to_cause (pmc$execute_standard_procedure, trap_status);
          IFEND;
          nfp$terminate_path (control_block.application, TRUE, control_block.path, local_status);
        IFEND;
        RETURN;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, trap_status);
      CASEND;

    PROCEND arf_condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    nfp$initialize_control_block (nfc$application_ptf, data_declaration,
          nfv$ptf_send_p03_values [nfc$network_lcn], nfv$ptf_send_p03_values [nfc$network_lcn],
          nfv$ptf_send_p03_values [nfc$network_nam], nfc$p00_a102, nfc$null, ^nfv$ptf_parameter_rules,
          control_block);
    control_block.retry_limit := 3;
    control_block.retry_milliseconds := 1000;
    control_block.send_directives := directives;
    control_block.ptf_scl_directive := ptf_command;
    control_block.transfer_lid_length := nfp$string_length (location);
    control_block.transfer_lid := location (1, control_block.transfer_lid_length);
    control_block.file_name := file_name;

    PUSH control_block.path.network_file: [STRLENGTH (path_name.value)];
    IF known_host.ve_server THEN
      control_block.remote_ring.value := known_host.execution_ring;
    ELSE
      #CALLER_ID (caller_id);
      control_block.remote_ring.value := caller_id.ring;
    IFEND;
    pmp$get_job_names (control_block.user_job_name, control_block.system_job_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$get_user_identification (user_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    arf_conditions.selector := pmc$condition_combination;
    arf_conditions.combination := $pmt$condition_combination
          [pmc$block_exit_processing, ifc$interactive_condition];
    pmp$establish_condition_handler (arf_conditions, ^arf_condition_handler, ^arf_condition_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    REPEAT

{     Initialize

      status.normal := TRUE;
      control_block.negotiate_protocol := FALSE;
      control_block.last_command_sent := nfc$unknown_command;
      control_block.last_command_received := nfc$unknown_command;
      control_block.data_xfer_complete := FALSE;
      control_block.state_of_transfer.normal := TRUE;
      control_block.local_status.normal := TRUE;
      control_block.remote_status.normal := TRUE;
      control_block.send_operator_messages := NIL;
      control_block.send_user_messages := NIL;
      control_block.send_account_messages := NIL;
      control_block.send_errorlog_messages := NIL;

{     Check if necessary to connect path

      IF NOT control_block.path.path_connected THEN
        pmp$generate_unique_name (network_file_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        control_block.path.network_file^ := network_file_name.value;
        nfp$send_connect_request (location, control_block.application_server, control_block.application,
              control_block.path, status);
      IFEND;

      IF status.normal THEN
        CASE control_block.path.network_type OF
        = nfc$network_nam =
          IF control_block.protocol_in_use = nfc$p00_a101 THEN { MAKE fit }
            control_block.data_block_size := nfc$p12_lcn_default;
          ELSE
            PUSH nam_optimum_attributes: [1..2];
            nam_optimum_attributes^ [1].kind := nac$optimum_transfer_unit_incr;
            nam_optimum_attributes^ [2].kind := nac$optimum_transfer_unit_size;
            nap$get_attributes(network_file_name.value, nam_optimum_attributes^, status);
            IF status.normal THEN
              control_block.data_block_size := nam_optimum_attributes^ [2].optimum_transfer_unit_size;
              IF nam_optimum_attributes^ [1].optimum_transfer_unit_incr > 0 THEN
                WHILE control_block.data_block_size < 10240 DO
                  control_block.data_block_size := control_block.data_block_size +
                      nam_optimum_attributes^ [1].optimum_transfer_unit_incr;
                WHILEND;
              IFEND;
              control_block.data_block_size := control_block.data_block_size - data_header_length;
            IFEND;
            IF (NOT status.normal) OR (control_block.data_block_size < 512) THEN
              control_block.data_block_size := nfc$p12_nam_default;
            IFEND;
          IFEND;
          control_block.transfer_pid_length := nfp$string_length (user_id.family);
          control_block.transfer_pid := user_id.family (1, control_block.transfer_pid_length);
          control_block.send_facilities := nfv$ptf_send_p03_values [nfc$network_nam];
          PUSH nam_attributes: [1 .. 1];
          nam_attributes^ [1].kind := nac$data_transfer_timeout;
          nam_attributes^ [1].data_transfer_timeout := control_block.time_out * nfc$milliseconds;
          nap$store_attributes (control_block.path.network_file_id, nam_attributes^, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        = nfc$network_lcn =
          control_block.data_block_size := nfc$p12_lcn_default;
          rfp$get_local_host_physical_id (physical_id, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          control_block.transfer_pid_length := #SIZE (physical_id);
          control_block.transfer_pid := physical_id;
          PUSH rhfam_attributes: [1 .. 1];
          rhfam_attributes^ [1].key := rfc$data_transfer_timeout;
          rhfam_attributes^ [1].data_transfer_timeout := control_block.time_out * nfc$milliseconds;
          rfp$store (control_block.path.network_file_id, rhfam_attributes^, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'access_remote_file case error',
                status);
          RETURN;
        CASEND;
        ptf_process_protocol (control_block, status);
        nfp$set_abnormal_if_normal (status, control_block.local_status);
      ELSE
        nfp$set_abnormal_if_normal (status, control_block.local_status);
      IFEND;

{     Decide if retry is necessary }

      ptf_retry (control_block, transfer_state, status);
      CASE transfer_state OF
      = nfc$xfer_retryable_term_connect, nfc$xfer_noretry_term_connect, nfc$xfer_complete_normal =
        ptf_terminate_connection (control_block);
        nfp$terminate_path (control_block.application, TRUE, control_block.path, ignore_status);
      = nfc$xfer_retryable_neg_protocol =
        { No action, around again }
      = nfc$xfer_retryable_path_discon, nfc$xfer_noretry_path_discon =
        nfp$terminate_path (control_block.application, TRUE, control_block.path, ignore_status);
      CASEND;

    UNTIL NOT (transfer_state IN nfv$retry_states);

    nfp$terminate_path (control_block.application, TRUE, control_block.path, ignore_status);
    pmp$disestablish_cond_handler (arf_conditions, ignore_status);

  PROCEND access_remote_file;
?? OLDTITLE ??
?? NEWTITLE := 'ptf_process_protocol', EJECT ??

{ PURPOSE:
{   This procedure processes the sequence of A-A protocol necessary to
{   transfer a file, which is defined by the stat table.  The state table
{   takes into account three things: last command sent, last command
{   received, and if data transfer has occured.  There are three actions
{   possible, send command, receive command, and transfer file.

  PROCEDURE ptf_process_protocol
    (VAR control_block: nft$control_block;
     VAR status: ost$status);

    VAR
      begin_connection_time: ost$date_time,
      end_connection_time: ost$date_time,
      ignored_params: nft$parameter_set,
      index: 1 .. nfc$ptf_number_pstates,
      secured_scl_directive_line: ost$string,
      modified_params: nft$parameter_set,
      new_state: nft$protocol_actions,
      received_params: nft$parameter_set,
      remote_family: nat$network_address,
      send_parameters: nft$parameter_set,
      state_known: boolean,
      terminate_status: ost$status;

    VAR
      ptfi_protocol: [READ, STATIC, nfs$ptf_static_data] nft$ptf_protocol_states := [
            [nfc$unknown_command,    { Sent command
            nfc$unknown_command,     { Received command
            FALSE,                   { Data xfer complete
            nfc$ptf_send_command,    { Send command to remote
            nfc$rft,                 { Make it RFT
            [nfc$protocol_id, nfc$facilities, nfc$user_text_directive, nfc$file_length, nfc$max_block_size,
            nfc$minimum_timeout_interval, nfc$host_type, nfc$transfer_lid, nfc$job_name, nfc$physical_id]],

            [nfc$rft,                { Sent command
            nfc$unknown_command,     { Received command
            FALSE,                   { Data xfer complete
            nfc$ptf_receive_command, { Get one
            [nfc$rpos, nfc$rneg]],

            [nfc$rft,                { Sent command
            nfc$rpos,                { Received command
            FALSE,                   { Data xfer complete
            nfc$ptf_start_transfer,  { Send command to remote
            nfc$go,                  { Make it Go
            []],

            [nfc$rft,                { Sent command
            nfc$rneg,                { Received command
            FALSE,                   { Data xfer complete
            nfc$ptf_send_command,    { Send command to remote
            nfc$stop,                { Make it Rft
            [nfc$state_of_transfer]],

            [nfc$go,                 { Sent command
            nfc$rpos,                { Received command
            TRUE,                    { Data xfer complete
            nfc$ptf_send_command,    { Send command to remote
            nfc$stop,                { Make it Rft
            [nfc$state_of_transfer]],

            [nfc$go,                 { Sent command
            nfc$rpos,                { Received command
            FALSE,                   { Data xfer complete
            nfc$ptf_send_command,    { Send command to remote
            nfc$stop,                { Make it Rft
            [nfc$state_of_transfer]],

            [nfc$stop,               { Sent command
            nfc$rneg,                { Received command
            FALSE,                   { Data xfer complete
            nfc$ptf_receive_command, { Receive STOPR
            [nfc$stopr]],

            [nfc$stop,               { Sent command
            nfc$rpos,                { Received command
            FALSE,                   { Data xfer complete
            nfc$ptf_receive_command, { Send command to remote
            [nfc$stopr]],

           [nfc$stop,                { Sent command
            nfc$rpos,                { Received command
            TRUE,                    { Data xfer complete
            nfc$ptf_receive_command, { Send command to remote
            [nfc$stopr]],

            [nfc$stop,               { Sent command
            nfc$stopr,               { Received command
            TRUE,                    { Data xfer complete
            nfc$ptf_terminate],      { All done

            [nfc$stop,               { Sent command
            nfc$stopr,               { Received command
            FALSE,                   { Data xfer complete
            nfc$ptf_terminate]];     { All done

    VAR
      nfv$ptf_required_params: [XREF] nft$required_param_on_command;
?? NEWTITLE := 'truncate_scl_directive_string', EJECT ??

    PROCEDURE truncate_scl_directive_string
      (VAR scl_directive_string: ost$string);

  {  PURPOSE:
  {      Given an SCL directive string to be used in file transfer logs, truncate
  {    the directive string at a position before a secure parameter could occur,
  {    thereby preventing the recording of secure parameters in the log entry.
  {
  {  ASSUMPTIONS:
  {    (1) When PTF obtains the SCL directive string, a pre-processor has formatted the
  {        command to conform to one of the following formats:
  {          a) "<scl_command_name> file=<file_name> ...etc..."
  {          b) "<scl_command_name> file=(<file_name>, <file_name>, ..., <file_name>) ...etc..."
  {        The use of this format allows the use of the character "=" as a landmark character;
  {        it represents the boundry between trivial and non-trivial information in the SCL
  {        directive string.
  {
  {    (2) Any string not in the previously mentioned formats can be secured by truncating
  {        at the first separator found.

      TYPE
        scan_char_flags = packed array [0 .. 255] of 0 .. 1,
        character_set = set of char;

      VAR
        scan_bit_set: scan_char_flags,
        search_char_found: boolean,
        search_index: integer,
        separator_list: character_set,
        working_string: ost$string;

      search_char_found := FALSE;
      FOR search_index := 0 TO 255 DO
        scan_bit_set [search_index] := 0;
      FOREND;
      scan_bit_set [$INTEGER ('=')] := 1;
      search_index := 0;
      working_string := scl_directive_string;

      #SCAN (scan_bit_set, working_string.value, search_index, search_char_found);

      IF search_char_found THEN
        search_index := search_index + 1;
        IF (working_string.value (search_index) = '(') THEN
          separator_list := $character_set [')'];
        ELSE { only one file name was specified in the SCL directive string.
          separator_list := $character_set [' ', ','];
        IFEND;
      ELSE { the SCL directive string isn't in the format expected, reset the search index & make best attempt
        search_index := 0;
        separator_list := $character_set [' ', '"', ')', ','];
      IFEND;

      search_char_found := FALSE;
      REPEAT
        search_index := search_index + 1;
        IF working_string.value (search_index) IN separator_list THEN
          search_char_found := TRUE;
        IFEND;
      UNTIL (search_char_found) OR (search_index >= STRLENGTH (scl_directive_string.value));

      IF (search_char_found) THEN
        scl_directive_string.value := working_string.value (1, search_index);
        scl_directive_string.size := search_index;
      IFEND;

    PROCEND truncate_scl_directive_string;

?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    pmp$get_compact_date_time( begin_connection_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    control_block.transfer_directives_length := nfp$count_directives_text(control_block.
      send_directives);

    WHILE TRUE DO { Do protocol until receive STOPR or connection is terminated
      state_known := FALSE;

    /state_loop/
      FOR index := LOWERVALUE (index) TO UPPERVALUE (index) DO
        IF ((ptfi_protocol [index].last_command_sent = control_block.last_command_sent) AND
              (ptfi_protocol [index].last_command_received = control_block.last_command_received) AND
              (ptfi_protocol [index].data_xfer_complete = control_block.data_xfer_complete)) THEN
          state_known := TRUE;
          EXIT /state_loop/
        IFEND;
      FOREND /state_loop/;
      IF NOT state_known THEN
        osp$set_status_abnormal (nfc$status_id, nfe$invalid_command_code, ' ', status);
        RETURN;
      ELSE
        new_state := ptfi_protocol [index].action;
        CASE new_state OF
        = nfc$ptf_send_command =
          send_parameters := ptfi_protocol [index].send_parameters;
          IF ptfi_protocol [index].send_command = nfc$rft THEN
            IF control_block.protocol_in_use = nfc$p00_a102 THEN
              build_ptfi_ring_parameter (control_block.remote_ring.value,
                    control_block.send_special_options, status);
              IF NOT status.normal THEN
                RETURN;
              ELSE
                send_parameters := send_parameters + $nft$parameter_set [nfc$special_options];
              IFEND;
            IFEND;
            IF control_block.data_declaration <> nfc$p31_unspecified THEN
              send_parameters := send_parameters + $nft$parameter_set [nfc$data_declaration];
            IFEND;
          IFEND;
          nfp$send_command (ptfi_protocol [index].send_command, send_parameters,
             $nft$parameter_set[ ], $nft$parameter_set[ ], control_block, status);
        = nfc$ptf_receive_command =
          nfp$receive_command (ptfi_protocol [index].legal_receive_commands, nfv$ptf_required_params,
                control_block, received_params, ignored_params, modified_params, status);
          nfp$set_abnormal_if_normal (status, control_block.local_status);
          IF (status.normal) AND (control_block.received_user_messages.head <> NIL) THEN
            control_block.transfer_directives_length := nfp$count_directives_text(control_block.
               received_user_messages.head) + control_block.transfer_directives_length;
            nfp$dispose_user_msg_to_log (control_block.received_user_messages);
          IFEND;
          IF (nfc$special_options IN received_params) AND (control_block.remote_host_type =
                nfc$p22_nos_ve) AND control_block.remote_status.normal THEN
            receive_remote_status (control_block.receive_special_options.
                  value (1, control_block.receive_special_options.size), control_block.remote_status, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

{ *** NOTE here is a trick to make the state table work for two odd conditions.
{ If RPOS was received, but an error occured, the application should treat the error as
{ if an RNEG was received.  If RPOS was received, but protocol negotiation was requested
{ by the server, the initiator should treat the condition as an RNEG.

          IF (control_block.last_command_received = nfc$rpos) THEN
            IF (NOT status.normal) THEN
              control_block.last_command_received := nfc$rneg;
              osp$set_status_abnormal (nfc$status_id, nfe$terminate_transfer_message, ' ',
                    control_block.state_of_transfer);
              status := control_block.state_of_transfer;
            ELSE
              IF (control_block.negotiate_protocol) THEN
                control_block.last_command_received := nfc$rneg;
              IFEND;
            IFEND;
          IFEND;
        = nfc$ptf_terminate =
          IF control_block.path.path_connected AND control_block.remote_status.normal AND
                control_block.local_status.normal AND control_block.state_of_transfer.
                normal AND control_block.data_xfer_complete THEN

            pmp$get_compact_date_time( end_connection_time, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            secured_scl_directive_line.value := control_block.ptf_scl_directive.value;
            secured_scl_directive_line.size  := STRLENGTH(control_block.ptf_scl_directive.value);

{ The SCL directive string is only trucated if the access mode is NFC$NULL, commands with an access mode
{ of NFC$GIVE or NFC$TAKE do not have secure parameters, and truncation is not needed.

            IF (control_block.mode_of_access = nfc$null) THEN
              truncate_scl_directive_string(secured_scl_directive_line);
            IFEND;

            nfp$generate_ptf_statistic( begin_connection_time,
                    end_connection_time, control_block.transfer_file_size,
                    control_block.transfer_directives_length,
                    control_block.transfer_pid(1,
                           control_block.transfer_pid_length),
                    control_block.transfer_lid(1,
                           control_block.transfer_lid_length),
                    control_block.application,
                    secured_scl_directive_line );
          IFEND;
          status.normal := TRUE;
          RETURN;
        = nfc$ptf_start_transfer =
          IF control_block.mode_of_access = nfc$null THEN
            control_block.data_xfer_complete := TRUE;
            control_block.last_command_sent := nfc$go;
          ELSE
            nfp$send_command (ptfi_protocol [index].xfer_send_command,
                  ptfi_protocol [index].xfer_send_parameters,
                  $nft$parameter_set[ ], $nft$parameter_set[ ],
                  control_block, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            nfp$transfer_file (control_block, status);
            control_block.data_xfer_complete := TRUE;
          IFEND;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'ptf_process_protocol', status);
          RETURN;
        CASEND;

{ Check result of previous action

        IF NOT status.normal THEN
          nfp$set_abnormal_if_normal (status, control_block.local_status);
        IFEND;
        IF NOT control_block.path.path_connected THEN
          RETURN;
        IFEND;
      IFEND;
    WHILEND;

  PROCEND ptf_process_protocol;
?? OLDTITLE ??
?? NEWTITLE := 'ptf_retry', EJECT ??

  PROCEDURE ptf_retry
    (VAR control_block: nft$control_block;
     VAR transfer_state: nft$ptf_transfer_state;
     VAR status: ost$status);

{
{ Procedure  ptf_retry
{
{ Purpose    This routine takes the results of an attempted transfer and
{            decides if it completed successfully.  If it did not, a
{            decision is made on whether or not to retry.
{
{ Description
{            The algorthim here is fairly simple, check all transfer status
{            values for an error.  If there is an error, it is checked
{            against the retryable error table.  Any NON-RETRYABLE error
{            should case PTFI to terminate without retry. Note: design
{                   direction states transfers may not be retried if an SCL (or
{            remote host command for that matter) has been executed, so if we
{            have received RPOS or RNEG already, no retry is possible.
{
{ Input parameters
{            None
{
{ Input/Output parameters
{            Control_block        input/output transfer control structure
{
{ Output parameters
{            Transfer_state       Ordinal returned indicating status of xfer,
{                                 and possible retry action.  NOTE: this value
{                                 is ALWAYS valid, even if STATUS is not!
{            Status               Return status
{
?? EJECT ??
{}

    CONST
      nfc$number_local_retry_cond = 3,
      nfc$number_remote_retry_cond = 1;

{}

    VAR
      index: 1 .. nfc$p04_max_transfer_states,
      local_status: ost$status,
      message_status: ost$status,
      ready_index: integer,
      remote_status_index: 1 .. nfc$number_remote_retry_cond,
      retry_index: 1 .. nfc$number_local_retry_cond,
      wait_list: ^ost$wait_list;

    VAR
      no_retry_states: [STATIC, READ, nfs$ptf_static_data] nft$ptf_transfer_state_set :=
            [nfc$xfer_noretry_term_connect, nfc$xfer_noretry_path_discon];

    VAR
      retryable_conditions: [READ, STATIC, nfs$ptf_static_data] array [1 .. nfc$number_local_retry_cond] of
            ost$status_condition_code := [nfe$recoverable_connect, nae$connection_terminated,
            rfe$connection_terminated];

    VAR
      remote_retryable_conditions: [READ, STATIC, nfs$ptf_static_data] array
            [1 .. nfc$number_remote_retry_cond] of ost$status_condition_code := [jme$maximum_jobs];

    VAR
      nfv$retry_states: [XREF] nft$ptf_transfer_state_set;

{}
    status.normal := TRUE;
    transfer_state := nfc$xfer_complete_normal;
{}
{     If A102/A101 protocol negotiation in progress }
{}
    IF control_block.negotiate_protocol THEN
      IF control_block.path.path_connected THEN { Expected case }
        transfer_state := nfc$xfer_retryable_neg_protocol;
        RETURN;
      ELSE { Unlikely condition, handle it as retryable }
        transfer_state := nfc$xfer_retryable_path_discon;
        osp$set_status_abnormal (nfc$status_id, nfe$protocol_anomaly, '', status);
      IFEND;
    IFEND;
{}
{     Now a hierarchy, any retryable condition here is overriden by
{     a non-retryable condition
{}
{     *** CASE # 1
{     Deviate from design direction, no retry necessary after STOP instead of
{     If RPOS or RNEG has been received, no retry is possible.  At this point,
{     no irrecoverable conditions exist.
{}
    IF (control_block.last_command_sent > nfc$unknown_command) AND
          (control_block.last_command_received < nfc$stopr) THEN
      IF NOT (control_block.path.path_connected) THEN
        transfer_state := nfc$xfer_retryable_path_discon; { Expected case }
      ELSE
        transfer_state := nfc$xfer_noretry_term_connect; { Protocol problem? }
        osp$set_status_abnormal (nfc$status_id, nfe$protocol_anomaly, '', status);
      IFEND;
    IFEND;
{}
{     *** CASE # 2
{     Here we check the state of transfer.  The state of transfer should
{     represent the "worst" case, i.e. if the servicer thinks things are
{     o.k. and the initiator thinks things are bad, we have the initiators
{     attitude contained in the SOT.
{}
    IF NOT control_block.state_of_transfer.normal THEN
      status := control_block.state_of_transfer;
      IF NOT (transfer_state IN no_retry_states) THEN

      /sot_for_loop/
        FOR index := LOWERVALUE (index) TO UPPERVALUE (index) DO
          IF nfv$p04_values [index].condition = control_block.state_of_transfer.condition THEN
            IF nfv$p04_values [index].retryable THEN
              IF control_block.path.path_connected THEN
                transfer_state := nfc$xfer_retryable_term_connect;
              ELSE
                transfer_state := nfc$xfer_retryable_path_discon;
              IFEND;
            ELSE
              IF control_block.path.path_connected THEN
                transfer_state := nfc$xfer_noretry_term_connect;
              ELSE
                transfer_state := nfc$xfer_noretry_path_discon;
              IFEND;
            IFEND;
            EXIT /sot_for_loop/;
          IFEND;
        FOREND /sot_for_loop/;
      IFEND;
    IFEND;
{}
{     *** CASE # 3
{     Check the remote status ( in NOS/VE <-> NOS/VE transfers this is
{     set by parameter 11, special options ) to see if it is retryable
{
    IF NOT control_block.remote_status.normal THEN
      status := control_block.remote_status;
      IF NOT (transfer_state IN no_retry_states) THEN
        IF control_block.path.path_connected THEN { Initialize for worst case}
          transfer_state := nfc$xfer_noretry_term_connect;
        ELSE
          transfer_state := nfc$xfer_noretry_path_discon;
        IFEND;

      /remote_status_loop/
        FOR remote_status_index := LOWERBOUND (remote_retryable_conditions)
              TO UPPERBOUND (remote_retryable_conditions) DO
          IF status.condition = remote_retryable_conditions [remote_status_index] THEN
            IF control_block.path.path_connected THEN { Initialize for worst case}
              transfer_state := nfc$xfer_retryable_term_connect;
            ELSE
              transfer_state := nfc$xfer_retryable_path_discon;
            IFEND;
            EXIT /remote_status_loop/;
          IFEND;
        FOREND /remote_status_loop/;
      IFEND;
{}
{     Change here for NV0K444.  The problem with remote status not being }
{     valid on client mainframe.  Problem has to do with path handles (file }
{     names to be translated) not having value to client.  Use a generic }
{     message instead or non-NF messages, with a couple exceptions. }
{}
      IF (status.condition<nfc$min_ecc) OR
         (status.condition>nfc$max_ecc) THEN
        IF (status.condition=ave$bad_user_validation_info) OR
           (status.condition=cle$bad_or_missing_login_in_job) THEN
          osp$set_status_abnormal(nfc$status_id,nfe$bad_or_missing_login_in_job,
                    '',status);
        ELSEIF (status.condition<>jme$maximum_jobs) THEN
          osp$set_status_abnormal(nfc$status_id,nfe$remote_system_error_see_jl,
                    '',status);
        IFEND;
      IFEND;
    IFEND;
{}
{     *** CASE # 4
{     Check the local status to see if it is retryable
{
    IF NOT control_block.local_status.normal THEN
      status := control_block.local_status;

      IF NOT (transfer_state IN no_retry_states) THEN { Assume not retryable }
        IF NOT control_block.path.path_connected THEN
          transfer_state := nfc$xfer_noretry_path_discon;
        ELSE
          transfer_state := nfc$xfer_noretry_term_connect;
        IFEND;

      /local_status_retry_loop/
        FOR retry_index := LOWERBOUND (retryable_conditions) TO UPPERBOUND (retryable_conditions) DO
          IF control_block.local_status.condition = retryable_conditions [retry_index] THEN
            IF NOT control_block.path.path_connected THEN
              transfer_state := nfc$xfer_retryable_path_discon;
            ELSE
              transfer_state := nfc$xfer_retryable_term_connect;
            IFEND;
            EXIT /local_status_retry_loop/;
          IFEND;
        FOREND /local_status_retry_loop/;
      IFEND;
    IFEND;
{}
{     See if connect retry limit is reached }
{}
    IF transfer_state IN nfv$retry_states THEN
      control_block.retry_count := control_block.retry_count + 1;
      IF control_block.retry_count > control_block.retry_limit THEN
        IF NOT control_block.path.path_connected THEN
          transfer_state := nfc$xfer_noretry_path_discon;
        ELSE
          transfer_state := nfc$xfer_noretry_term_connect;
        IFEND;
      ELSE
        nfp$ptf_format_message_to_out (status);
        osp$set_status_abnormal (nfc$status_id, nfe$transfer_failed_recovering, '', local_status);
        nfp$ptf_format_message_to_out (local_status);
        PUSH wait_list: [1 .. 1];
        wait_list^ [1].activity := osc$await_time;
        wait_list^ [1].milliseconds := control_block.retry_milliseconds;
        osp$await_activity_completion (wait_list^, ready_index, local_status);
      IFEND;
    IFEND;
{}
  PROCEND ptf_retry;
?? OLDTITLE ??
?? NEWTITLE := 'ptf_terminate_connection', EJECT ??

  PROCEDURE ptf_terminate_connection
    (VAR control_block: nft$control_block);

{
{ Procedure  ptf_terminate_connection
{
{ Purpose    To complete A-A protocol (ETP,ETPR,FINI,disconnect) on
{            a connection.
{
{ Description
{            This routine completes protocol for PTFI in this order:
{                   Send ETP
{                   Receive ETPR
{                   Send FINI
{                   Disconnect path
{
{ Input parameters
{                   None
{
{ Input/Output parameters
{            Control_block        input/output transfer control structure
{
{ Output parameters
{                   None
{
{ Algorithm
{                   Nfp$send_command( ETP )
{                   Nfp$receive_command( ETPR )
{                   Nfp$send_command( FINI )
{
?? EJECT ??

    VAR
      ignored_params: nft$parameter_set,
      legal_commands: nft$command_set,
      local_status: ost$status,
      modified_params: nft$parameter_set,
      received_params: nft$parameter_set;

    VAR
      nfv$ptf_required_params: [XREF] nft$required_param_on_command;

{}
{     Send ETP }
{}
    nfp$send_command (nfc$etp, $nft$parameter_set[ ],
      $nft$parameter_set[ ], $nft$parameter_set[ ],
      control_block, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;
{}
{     Receive ETPR }
{}
    legal_commands := $nft$command_set [nfc$etpr];
    nfp$receive_command (legal_commands, nfv$ptf_required_params, control_block, received_params,
          ignored_params, modified_params, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;
{}
{     Send FINI }
{}
    nfp$send_command (nfc$fini, $nft$parameter_set[ ],
      $nft$parameter_set[ ], $nft$parameter_set[ ],
      control_block, local_status);
{}
  PROCEND ptf_terminate_connection;
?? OLDTITLE ??
?? TITLE := 'build_ptfi_ring_parameter', EJECT ??

  PROCEDURE build_ptfi_ring_parameter
    (    ring: ost$ring;
     VAR special_options: nft$parameter_11_value;
     VAR status: ost$status);

{
{ Procedure  build_ptfi_ring_parameter
{
{ Purpose    To build a string containing the ring of the
{            initiating application.
{
{ Description
{            The current ring is encoded as a string.
{
{ Input parameters
{            ring   : Current execution ring
{
{ Output parameters
{            special_options      : returned ring representation
{            status               : return status
{
{ Algorithm
{            Encode ring
{
?? EJECT ??
{}

    VAR
      ring_string: ost$string;

{}
    status.normal := TRUE;
    clp$convert_integer_to_string (ring, 10, FALSE, ring_string, status);
    IF status.normal THEN
      special_options.size := ring_string.size;
      IF special_options.size > 0 THEN
        special_options.value := ring_string.value;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
              'build_ptfi_ring_parameter length < 0', status);
      IFEND;
    IFEND;
{}
  PROCEND build_ptfi_ring_parameter;
?? TITLE := 'receive_remote_status', EJECT ??

  PROCEDURE receive_remote_status
    (    received_parameter: string ( * <= nfc$max_param_size);
     VAR remote_status: ost$status;
     VAR status: ost$status);

{
{ Procedure  receive_remote_status
{
{ Purpose    This routing cracks the special options parameter
{            as a NOS/VE status.
{
{ Description
{            The remote status parameter is of the form
{            code condition # status parameter(s).
{
{ Input parameters
{            receive_parameter    : Text value of status parameter
{
{ Output parameters
{            remote_status        : Cracked status value
{            status               : Return status
{
{ Algorithm
{            Crack condition name
{            Crack condition integer value
{            Crack status parameter(s)
{            Build status record
{
?? EJECT ??
{}

    VAR
      integer_record: clt$integer,
      length_condition: integer,
      length_status_id: integer,
      parameter_position: nft$parameter_size,
      status_id: ost$status_identifier;

{}
    status.normal := TRUE;
    remote_status.normal := TRUE;
    nfp$find_delimitd_string_length (received_parameter, length_status_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    parameter_position := length_status_id + 2;
    nfp$find_delimitd_string_length (received_parameter (parameter_position, * ), length_condition, status);
    IF NOT status.normal THEN
      length_condition := STRLENGTH (received_parameter) - parameter_position + 1;
      IF length_condition <= 0 THEN { Incorrect parameter }
        RETURN;
      ELSE { Assume no message field }
        status.normal := TRUE;
      IFEND;
    IFEND;
    clp$convert_string_to_integer (received_parameter (parameter_position, length_condition), integer_record,
          status);
    IF status.normal THEN
      parameter_position := length_condition + 2 + parameter_position;
      status_id := received_parameter (1, length_status_id);
      IF parameter_position >= STRLENGTH (received_parameter) THEN
        osp$set_status_abnormal (status_id, integer_record.value, '', remote_status);
      ELSE
        osp$set_status_abnormal (status_id, integer_record.value, received_parameter (parameter_position, * ),
              remote_status);
      IFEND;
    IFEND;
{}
  PROCEND receive_remote_status;
?? TITLE := '  [#GATE,XDCL] nfp$perform_implicit_transfer', EJECT ??

  PROCEDURE [#GATE, XDCL] nfp$perform_implicit_transfer
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{
{ Procedure  nfp$perform_implicit_transfer
{
{ Purpose    To server as the starting point for an implicit PTF transfer.
{            Implicit PTF transfers (i.e. COPY_FILE) execute a task to
{            perform the PTF function.  This is done because the implicit
{            command processors exist as subroutines of the job monitor task
{            (for performance reasons).  However, it is desirable not to
{            have PTF in the job template, so a task is executed.
{
{ Description
{            The procedure uses a sequence, passed by execute_task, to
{            build the parameters for a PTF transfer.  The sequence is cracked
{            and a call is made to begin the transfer.
{
{ Input parameters
{            parameter_list              : Pointer to sequence
{
{ Output parameters
{            status                      : Return status
{
{ Algorithm
{            Crack sequence for transfer parameters
{            Ensure remote validation is available
{            Call access_remote_file
{
?? EJECT ??
?? TITLE := '  [INLINE] link_directive', EJECT ??

{
{   Code to link a string onto a link list of server directives.
{

    PROCEDURE [INLINE] link_directive;

      IF directive_ptr = NIL THEN
        PUSH directive_ptr: [size];
        directive_list_ptr := directive_ptr;
      ELSE
        PUSH directive_ptr^.link: [size];
        directive_ptr := directive_ptr^.link;
      IFEND;
      directive_ptr^.link := NIL;
      directive_ptr^.line := line (1, size);

    PROCEND link_directive;

?? TITLE := '  [INLINE] append_string', EJECT ??

{  Procedure to append a string to an existing string.

    PROCEDURE [INLINE] append_string
      (    add_string: string ( * );
           length: 0 .. osc$max_string_size);

      IF size + length > line_limit THEN
        line (size + 1, 2) := ellipsis;
        size := size + 2;
        PUSH directive_ptr^.link: [size];
        directive_ptr := directive_ptr^.link;
        directive_ptr^.link := NIL;
        directive_ptr^.line := line (1, size);
        size := 0;
      IFEND;

      line (size + 1, length) := add_string (1, length);
      size := size + length;
    PROCEND append_string;

?? OLDTITLE, EJECT ??

    VAR
      access_mode: nft$mode_of_access,
      access_mode_ptr: ^nft$mode_of_access,
      caller_id: ost$caller_identifier,
      command_name: ost$name,
      command_name_ptr: ^ost$name,
      contains_data: boolean,
      data_declaration: nft$parameter_31_type,
      directive_list_ptr: ^nft$directive_entry,
      directive_ptr: ^nft$directive_entry,
      file_attributes: ^amt$get_attributes,
      file_exists: boolean,
      file_length: amt$file_length,
      file_previously_opened: boolean,
      i: 0 .. clc$max_parameters,
      j: 1 .. nfc$max_validation_lines,
      implicit_command: ost$string,
      implicit_command_ptr: ^ost$string,
      index: nft$number_implicit_commands,
      line: string (osc$max_string_size),
      line_count: 0 .. nfc$max_validation_lines,
      local_file: amt$local_file_name,
      local_file_path: fst$path,
      local_file_path_size: fst$path_size,
      local_file_phn: fmt$path_handle,
      local_file_ptr: ^amt$local_file_name,
      local_status: ost$status,
      location: ost$name,
      location_ptr: ^ost$name,
      name_count: 1 .. clc$max_parameters,
      name_index: 1 .. clc$max_parameters,
      number_implicit_cmds: nft$number_implicit_commands,
      number_implicit_ptr: ^nft$number_implicit_commands,
      param_name: ^nft$number_implicit_commands,
      param_name_size: 1 .. osc$max_name_size,
      param_number: 0 .. clc$max_parameters,
      parameter_sequence: ^clt$parameter_list,
      ptf_scl_directive: ost$string,
      remote_file_path: ost$string,
      remote_file_ptr: ^ost$string,
      size: ost$string_size,
      str: ost$string,
      validation_ptr: ^array [1 .. * ] of string (osc$max_string_size),
      value: clt$value,
      ve_server: nft$ve_to_ve_access;

    CONST
      space = ' ',
      equal = '=',
      apostrophe = '''',
      ellipsis = '..',
      open_p = '(',
      close_p = ')',
      line_limit = osc$max_string_size - 2;


    #KEYPOINT (osk$entry, 0, nfk$perform_remote_access);

    status.normal := TRUE;

  /perform_remote_access/
    BEGIN

      directive_ptr := NIL;
      directive_list_ptr := NIL;
{}
{     Get input parameters }
{}
      parameter_sequence := ^parameter_list;
      RESET parameter_sequence;
      NEXT location_ptr IN parameter_sequence;
      location := location_ptr^;
      NEXT local_file_ptr IN parameter_sequence;
      local_file := local_file_ptr^;
      NEXT remote_file_ptr IN parameter_sequence;
      remote_file_path := remote_file_ptr^;
      NEXT access_mode_ptr IN parameter_sequence;
      access_mode := access_mode_ptr^;
      NEXT command_name_ptr IN parameter_sequence;
      command_name := command_name_ptr^;
      NEXT number_implicit_ptr IN parameter_sequence;
      number_implicit_cmds := number_implicit_ptr^;

{}
{     Ensure remote host is accessable }
{}
      nfp$find_remote_validation (location, line_count, status);
      IF NOT status.normal THEN
        EXIT /perform_remote_access/;
      ELSEIF line_count = 0 THEN
        osp$set_status_abnormal (nfc$status_id, nfe$remote_val_undefined, location, status);
        EXIT /perform_remote_access/;
      IFEND;

      PUSH validation_ptr: [1 .. line_count];
      nfp$get_remote_validation (location, validation_ptr, status);
      IF NOT status.normal THEN
        EXIT /perform_remote_access/;
      IFEND;
{}
{     Put validation commands on list }
{}
      FOR j := 1 TO line_count DO
        line := validation_ptr^ [j];
        size := nfp$string_length (line);
        link_directive;
      FOREND;

{ Put implicit commands (e.g. DISFA) on list
{ Note that for COPY_FILE the command_name is null

      IF number_implicit_cmds > 0 THEN
        FOR index := 1 TO number_implicit_cmds DO
          NEXT implicit_command_ptr IN parameter_sequence;
          line := implicit_command_ptr^.value;
          size := implicit_command_ptr^.size;

{ The first directive is assumed to contain the implicit command (or at
{ least the first 256 characters) that we want to save for accounting

          IF index = 1 THEN
            ptf_scl_directive.value := line (1, size);
            ptf_scl_directive.size := size;
          IFEND;
          link_directive;
        FOREND;
      IFEND;

{ Reconstruct COPY_FILE command for accounting

      IF command_name = osc$null_name THEN
        clp$get_fs_path_string (local_file, local_file_path,
              local_file_path_size, local_file_phn, status);
        IF NOT status.normal THEN
          EXIT /perform_remote_access/;
        IFEND;
        IF access_mode = nfc$give THEN
          line := 'COPY_FILE INPUT=';
          size := 16;
          line (size+1, remote_file_path.size) := remote_file_path.value
                (1, remote_file_path.size);
          size := size + remote_file_path.size;
          line (size+1, 8) := ' OUTPUT=';
          size := size + 8;
          line (size+1, local_file_path_size) := local_file_path
                (1, local_file_path_size);
          size := size + local_file_path_size;
        ELSE

{ Check if the non-remote file actually exists before initiating the transfer.

          PUSH file_attributes: [1..1];
          file_attributes^ [1].key := amc$file_length;
          file_attributes^ [1].file_length := 0;
          amp$get_file_attributes (local_file_path, file_attributes^, file_exists,
             file_previously_opened, contains_data, status);

          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF NOT file_exists THEN
            osp$set_status_abnormal ('AM', ame$file_not_known, local_file, status);
            osp$append_status_parameter(osc$status_parameter_delimiter,'FSP$OPEN_FILE', status);
            RETURN;
          ELSEIF file_attributes^ [1].file_length <= 0 THEN
            osp$set_status_abnormal ('FS', fse$empty_input_file, local_file, status);
            RETURN;
          IFEND;

          line := 'COPY_FILE INPUT=';
          size := 16;
          line (size+1, local_file_path_size) := local_file_path
                (1, local_file_path_size);
          size := size + local_file_path_size;
          line (size+1, 8) := ' OUTPUT=';
          size := size + 8;
          line (size+1, remote_file_path.size) := remote_file_path.value
                (1, remote_file_path.size);
          size := size + remote_file_path.size;
        IFEND;
        ptf_scl_directive.value := line (1, size);
        ptf_scl_directive.size := size;
      IFEND;
{}
{     Put file transfer commands on list }
{}
      IF access_mode <> nfc$null THEN
        IF access_mode = nfc$take THEN
          line := 'RECEIVE_FILE ';
          size := remote_file_path.size + 13;
          line (14, remote_file_path.size) := remote_file_path.value (1, remote_file_path.size);
        ELSE
          line := 'SEND_FILE ';
          size := remote_file_path.size + 10;
          line (11, remote_file_path.size) := remote_file_path.value (1, remote_file_path.size);
        IFEND;
        link_directive;
      IFEND;

      #CALLER_ID (caller_id);
      ve_server.ve_server := TRUE;
      ve_server.execution_ring := caller_id.ring;
      data_declaration := nfc$p31_host_dependent_uh;

      access_remote_file (location, local_file, data_declaration, directive_list_ptr,
            ve_server, ptf_scl_directive, status);

    END /perform_remote_access/;

    #KEYPOINT (osk$exit, 0, nfk$perform_remote_access);

  PROCEND nfp$perform_implicit_transfer;

?? RIGHT := 110 ??
?? NEWTITLE := 'nfm$manage_remote_files', EJECT ??

?? TITLE := '  [#GATE,XDCL] nfp$manage_remote_files', EJECT ??

  PROCEDURE [#GATE, XDCL] nfp$manage_remote_files
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{
{ Procedure  nfp$manage_remote_files
{
{ Purpose    This procedure contains the processor for the
{            manage_remote_files command.
{
{ Description
{            This routine gets the transfer parameters, via SCL calls,
{            and initiates the PTF transfer.  Note that PTF is installed
{            as a product so there is a program descriptor pointing to the
{            library in which this module resides.
{
{ Input parameters
{            parameter_list       : parameter list passed by SCL
{
{ Output parameters
{            status               : return status
{
{ Algorithm
{            Check user allowed to do explicit file transfer
{            Check SCL command valid
{            Get SCL command parameters
{            Read remote directives
{            Call access_remote_file
{
?? EJECT ??
{ PROCEDURE manage_remote_files_pdt (
{   location, l: any of
{       string 1..31
{       name
{     anyend = $required
{   file, f: file = $required
{   data_declaration, dd: key
{       c8, c6, us, uu
{     keyend = $optional
{   until, u: string = '**'
{   substitution_mark, sm: any of
{       string 1
{       key
{         none
{       keyend
{     anyend = none
{   ignore_remote_validation, irv: boolean = false
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (4),
      recend,
      type5: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (4),
      recend,
      type6: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 7, 23, 13, 42, 28, 605],
    clc$command, 13, 7, 2, 0, 0, 0, 7, ''], [
    ['DATA_DECLARATION               ',clc$nominal_entry, 3],
    ['DD                             ',clc$abbreviation_entry, 3],
    ['F                              ',clc$abbreviation_entry, 2],
    ['FILE                           ',clc$nominal_entry, 2],
    ['IGNORE_REMOTE_VALIDATION       ',clc$nominal_entry, 6],
    ['IRV                            ',clc$abbreviation_entry, 6],
    ['L                              ',clc$abbreviation_entry, 1],
    ['LOCATION                       ',clc$nominal_entry, 1],
    ['SM                             ',clc$abbreviation_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 7],
    ['SUBSTITUTION_MARK              ',clc$nominal_entry, 5],
    ['U                              ',clc$abbreviation_entry, 4],
    ['UNTIL                          ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 33,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 72,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 6
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 7
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [1, 31, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['C6                             ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['C8                             ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['US                             ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['UU                             ', clc$nominal_entry, clc$normal_usage_entry, 4]]
    ],
{ PARAMETER 4
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE],
    '''**'''],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$string_type],
    FALSE, 2],
    8, [[1, 0, clc$string_type], [1, 1, FALSE]],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'none'],
{ PARAMETER 6
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$location = 1,
      p$file = 2,
      p$data_declaration = 3,
      p$until = 4,
      p$substitution_mark = 5,
      p$ignore_remote_validation = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

?? NEWTITLE := '    abort_handler', EJECT ??
*copyc cyd$run_time_error_condition
?? POP ??
?? TITLE := '  link_directive', EJECT ??

{
{   Inline code to link a string onto a link list of server directives.
{

    PROCEDURE [INLINE] link_directive;

      IF directive_ptr = NIL THEN
        PUSH directive_ptr: [line.size];
        directive_list_ptr := directive_ptr;
      ELSE
        PUSH directive_ptr^.link: [line.size];
        directive_ptr := directive_ptr^.link;
      IFEND;
      directive_ptr^.link := NIL;
      directive_ptr^.line := line.value (1, line.size);

    PROCEND link_directive;

?? OLDTITLE, EJECT ??

    CONST
      delete_allowed = FALSE,
      include_open_pos_in_handle = TRUE,
      resolve_path = FALSE;

    VAR
      caller_in_current_task: boolean,
      data_declaration: nft$parameter_31_type,
      directive_list_ptr: ^nft$directive_entry,
      directive_ptr: ^nft$directive_entry,
      explicit_remote_file: boolean,
      file_exists: boolean,
      get_attributes: array [1 .. 1] of amt$get_item,
      i: 1 .. nfc$max_validation_lines,
      ignore_file_contains_data: boolean,
      ignore_file_is_local: boolean,
      ignore_file_reference: fst$evaluated_file_reference,
      input_block_handle: clt$block_handle,
      input_executable: boolean,
      input_file_id: amt$file_identifier,
      interactive: boolean,
      line: ost$string,
      line_count: 0 .. nfc$max_validation_lines,
      local_status: ost$status,
      location_name: ost$name,
      new_line: ost$string,
      new_line_size: clt$command_line_size,
      path_handle_name: fst$path_handle_name,
      ptf_scl_directive: ost$string,
      scl_line: ^clt$command_line,
      string_value: ^ost$string,
      validation_ptr: ^array [1 .. * ] of string (osc$max_string_size),
      variable_value: clt$variable_reference,
      ve_server: nft$ve_to_ve_access;

    VAR
      mrf_prompt: [STATIC, READ, oss$job_paged_literal] string (5) := 'mrf? ';


    status.normal := TRUE;
    IF NOT jmp$system_job () THEN

      avp$get_capability (avc$explicit_remote_file, avc$user, explicit_remote_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT explicit_remote_file THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sou_invalid_user, 'MANAGE_REMOTE_FILES', status);
        RETURN;
      IFEND;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE pvt [p$location].value^.kind OF
      =clc$name=
        location_name := pvt [p$location].value^.name_value;
      =clc$string=
        #TRANSLATE(osv$lower_to_upper, pvt [p$location].value^.string_value^, location_name);
    CASEND;

  /set_up_transfer/
    BEGIN
      IF pvt [p$data_declaration].specified THEN
        nfp$convert_p31_to_ordinal (pvt [p$data_declaration].value^.name_value, data_declaration, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        data_declaration := nfc$p31_unspecified;
      IFEND;

      directive_ptr := NIL;
      get_attributes [1].key := amc$file_contents;

      clp$convert_str_to_path_handle (pvt [p$file].value^.file_value^, delete_allowed,
        resolve_path, include_open_pos_in_handle, path_handle_name, ignore_file_reference,
        status);

      amp$get_file_attributes (path_handle_name, get_attributes, ignore_file_is_local,
            file_exists, ignore_file_contains_data, status);

      IF NOT (pvt [p$ignore_remote_validation].value^.boolean_value.value) THEN
        nfp$find_remote_validation (location_name, line_count, status);
        IF NOT status.normal THEN
          EXIT /set_up_transfer/;
        ELSEIF line_count = 0 THEN
          EXIT /set_up_transfer/;
        IFEND;

        PUSH validation_ptr: [1 .. line_count];
        nfp$get_remote_validation (location_name, validation_ptr, status);
        IF NOT status.normal THEN
          EXIT /set_up_transfer/;
        IFEND;

        FOR i := 1 TO line_count DO
          line.value := validation_ptr^ [i];
          line.size := nfp$string_length (line.value);
          link_directive;
          IF directive_ptr = NIL THEN
            RETURN;
          IFEND;
        FOREND;
      IFEND; { if prev. declared remote validations should be used.
    END /set_up_transfer/;

    local_status.normal := TRUE;

    IF NOT status.normal THEN
      clp$get_command_origin (interactive, local_status);
      IF interactive THEN
        RETURN;
      IFEND;
    IFEND;

    clp$push_input (clc$current_command_input, osc$null_name, '', FALSE, FALSE, input_block_handle,
          input_file_id, input_executable, local_status);
    IF NOT (local_status.normal) THEN
      IF status.normal THEN
        status := local_status;
      IFEND;
      RETURN;
    IFEND;

  /collect_directives/
    WHILE TRUE DO
      clp$get_line_from_command_file (mrf_prompt, scl_line, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
      IF NOT local_status.normal THEN
        EXIT /collect_directives/;
      ELSEIF scl_line = NIL THEN
        IF status.normal THEN
          osp$set_status_abnormal (nfc$status_id, nfe$encountered_eoi, 'MANAGE_REMOTE_FILES', status);
        IFEND;
        EXIT /collect_directives/;
      ELSEIF (STRLENGTH (scl_line^) = STRLENGTH (pvt [p$until].value^.string_value^ )) AND
               (scl_line^ = pvt [p$until].value^.string_value^) THEN
        EXIT /collect_directives/;
      ELSEIF STRLENGTH (scl_line^) = 0 THEN
        CYCLE /collect_directives/;
      ELSE
        IF STRLENGTH (scl_line^) <= osc$max_string_size THEN
          line.value := scl_line^;
          line.size := STRLENGTH (scl_line^);
          IF pvt [p$substitution_mark].value^.kind = clc$string THEN
            clp$substitute_delimited_text (line.value (1, line.size),
              pvt [p$substitution_mark].value^.string_value^(1), new_line.value, new_line_size, local_status);
            IF local_status.normal THEN
              IF new_line_size > osc$max_string_size THEN
                osp$set_status_abnormal (nfc$status_id, cle$string_too_long, 'FOR SUBSTITUTION', local_status);
              ELSE
                new_line.size := new_line_size;
                line := new_line;
              IFEND;
            IFEND;
          IFEND;
        ELSE
          osp$set_status_abnormal (nfc$status_id, cle$string_too_long, 'FOR MANAGE_REMOTE_FILES',
                local_status);
        IFEND;
        IF local_status.normal THEN
          link_directive;
        ELSE
          IF status.normal THEN
            status := local_status;
          IFEND;
          RETURN;
        IFEND;
      IFEND;
    WHILEND /collect_directives/;

    clp$pop_input (TRUE, input_block_handle, input_file_id, input_executable, NIL, local_status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF directive_ptr = NIL THEN
      osp$set_status_abnormal (nfc$status_id, nfe$directives_missing, 'MANAGE_REMOTE_FILES', status);
      RETURN
    IFEND;

{ Get parameter }

    build_ptfi_scl_command('manage_remote_files', ptf_scl_directive, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    ve_server.ve_server := FALSE;
    access_remote_file (location_name, path_handle_name, data_declaration,
          directive_list_ptr, ve_server, ptf_scl_directive, status);

  PROCEND nfp$manage_remote_files;

?? OLDTITLE ??
?? NEWTITLE := 'build_ptfi_scl_command', EJECT ??
{
{     The purpose of this procedure is to create an OST$STRING which
{  contains the command and parameter list used to start this task.
{
{       NFP$BUILD_PTFI_SCL_COMMAND( COMMAND, SCL_COMMAND, STATUS);
{
{ COMMAND : (input) Initiating command name.
{
{ SCL_COMMAND : (output) Output string containing command and parameters
{     used to start this PTF task.
{
{ STATUS: (output) This parameter specifies the request status.
{     CONDITIONS:
{       Any from clp$get_parameter_list.
{
  PROCEDURE build_ptfi_scl_command
      (      command: string(*<=osc$max_string_size);
        VAR  scl_command: ost$string;
        VAR  status: ost$status);

VAR
      input_command_length: ost$string_size,
      parameter_list: ost$string;

status.normal := TRUE;
clp$get_parameter_list( parameter_list, status);
IF NOT status.normal THEN
  RETURN;
IFEND;
input_command_length := STRLENGTH(command);
scl_command.value := command;
scl_command.size := input_command_length + 2;
input_command_length := scl_command.size;
IF parameter_list.size > 0 THEN
  scl_command.value(scl_command.size,*) := parameter_list.value(1,parameter_list.size);
  IF (parameter_list.size + scl_command.size > osc$max_string_size) THEN
    scl_command.size := osc$max_string_size;
  ELSE
    scl_command.size := scl_command.size + parameter_list.size;
  IFEND;
IFEND;

  PROCEND build_ptfi_scl_command;
?? OLDTITLE ??
MODEND nfm$ptf_client;
*DECK DECK=NFM$PTF_SERVER EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, INDENT := 2) ??
?? SET (LIST := ON, LISTCTS := OFF) ??
MODULE nfm$ptf_server;

{     PURPOSE:
{            This module contains procedures to perform the function of the
{            Permanent file Transfer Facility (PTF) server.  The PTF server
{            executes in respose to a connection request made by a PTF client.
{            The PTF server is composed of a number of tasks.  First, a task
{            called the boot receives incoming PTF client connections.
{            Each connection received causes a task to be executed which
{            tries to build a job on the behalf of the client user.
{            If the user job runs successfully, file transfer occurs from
{            that job.
{
{     DESCRIPTION:
{            The function of PTFS is performed by three entities.  First,
{            a system task (eventually a privileged job) receives all incoming
{            connections.  The task (called the boot) then executes another
{            task which reads protocol and builds a user PTFS job.  The user
{            PTFS job is submitted to the system.  If the user job fails, the
{            job generation task completes protocol.  Otherwise, the connection
{            is switched to the user PTFS job for the remainder of the session.
{
*copyc amp$return
*copyc amp$put_next
*copyc amp$close
*copyc amp$get_file_attributes
*copyc amp$get_next
*copyc clp$convert_integer_to_string
*copyc clp$convert_str_to_path_handle
*copyc clp$convert_string_to_integer
*copyc clp$create_file_connection
*copyc clp$delete_file_connection
*copyc clp$evaluate_parameters
*copyc clp$get_line_from_command_file
*copyc clp$get_variable_value
*copyc clp$pop_input
*copyc clp$pop_utility
*copyc clp$push_input
*copyc clp$push_utility
*copyc clp$scan_command_file
*copyc fsp$close_file
*copyc fsp$open_file
*copyc fst$attachment_options
*copyc fst$evaluated_file_reference
*copyc jme$queued_file_conditions
*copyc jmp$change_job_attributes
*copyc jmp$get_job_attributes
*copyc jmp$job_exists
*copyc jmp$submit_job
*copyc jmp$system_job
*copyc jmp$terminate_job
*copyc nap$accept_connection
*copyc nap$accept_switch_offer
*copyc nap$acquire_connection
*copyc nap$attach_server_application
*copyc nap$cancel_switch_offer
*copyc nap$detach_server_application
*copyc nap$offer_connection_switch
*copyc nap$store_attributes
*copyc nfp$count_directives_text
*copyc nfp$crack_command
*copyc nfp$crack_number_of_parameters
*copyc nfp$crack_parameter
*copyc nfp$crack_pdu
*copyc nfp$dequeue_directives_on_list
*copyc nfp$deallocate_dirs_from_head
*copyc nfp$enqueue_status_directive
*copyc nfp$enqueue_task
*copyc nfp$format_message_to_job_log
*copyc nfp$generate_ptf_statistic
*copyc nfp$get_and_crack_command
*copyc nfp$get_server_asynch_event
*copyc nfp$initialize_control_block
*copyc nfp$receive_command
*copyc nfp$receive_parameter_00
*copyc nfp$receive_parameter_20
*copyc nfp$receive_parameter_22
*copyc nfp$send_command
*copyc nfp$set_abnormal_if_normal
*copyc nfp$string_length
*copyc nfp$terminate_path
*copyc nfp$transfer_file
*copyc osp$append_status_parameter
*copyc osp$generate_log_message
*copyc osp$get_status_condition_string
*copyc osp$i_await_activity_completion
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$execute
*copyc pmp$get_unique_name
*copyc pmp$get_compact_date_time
*copyc pmp$get_job_names
*copyc pmp$get_program_description
*copyc pmp$get_program_size
*copyc pmp$get_user_identification
*copyc pmp$log
*copyc rfp$accept_connect_request
*copyc rfp$accept_switch_offer
*copyc rfp$acquire_connect_request
*copyc rfp$application_sign_off
*copyc rfp$application_sign_on
*copyc rfp$cancel_switch_offer
*copyc rfp$get_local_host_physical_id
*copyc rfp$offer_connection_switch
*copyc rfp$store
*copyc rmp$get_device_class
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_attributes
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc cld$parameter_list
*copyc fse$copy_validation_errors
*copyc jmt$system_job_parameters
*copyc nae$application_interfaces
*copyc nfc$library_definitions
*copyc nfc$command_definitions
*copyc nfc$parameter_definitions
*copyc nfc$parameter_04_definitions
*copyc nfc$parameter_20_definitions
*copyc nfe$batch_transfer_services
*copyc nfe$ptf_condition_codes
*copyc nft$application_values
*copyc nft$buffer_control_block
*copyc nft$control_block
*copyc nft$lcn_application_names
*copyc nft$nam_application_names
*copyc nft$parameter_04_values
*copyc nft$parameter_set
*copyc nft$ptfs_job_submit_block
*copyc nft$task_list
*copyc nft$task_queue
*copyc nfv$lcn_application_names
*copyc nfv$nam_application_names
*copyc nfv$ptf_parameter_rules
*copyc nfv$ptf_required_params
*copyc nft$parameter_03_netvalues
*copyc nfv$ptf_send_p03_values
*copyc nfv$p04_values
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc rfe$condition_codes
?? POP ??
{}

  CONST
    nfc$ptfs_network_flag_nam = 'N',
    nfc$ptfs_network_flag_lcn = 'L';

{}

  TYPE
    buffer_list_element = record
      buffer: string (nfc$command_buffer_size),
      length: 1 .. nfc$command_buffer_size,
      forward_pointer: ^buffer_list_element,
    recend;

{}

  TYPE
    nft$ptfs_messages = (status_msg, text_msg);

{}

  TYPE
    nft$ptfs_job_switch_params = record
      source_job_name: jmt$system_supplied_name,
      path_info: nft$network_connection,
      network_file: ost$unique_name,
    recend;

{}

  TYPE
    nft$ptfs_message = record
      case msgtype: nft$ptfs_messages of
      = status_msg =
        log_status: ost$status,
      = text_msg =
        log_text: string (nfc$trace_commands_width),
      casend,
    recend;

{}

  TYPE
    nft$ptfs_switch_states = (nfc$switch_complete, nfc$switch_failed_cancelled, nfc$switch_failed_lost,
          nfc$no_switch_attempted);

  TYPE
    caller_identifier = (user_ptfs_job_call, user_ptfs_job_logout, ptfs_job_generation_task,
                          ptfs_scan_scl_handler_id);

{}
?? NEWTITLE := 'Global variables', EJECT ??
    VAR
      nfv$rft_parameter_set: [STATIC, XDCL] nft$parameter_set;
?? OLDTITLE ??
?? NEWTITLE := '[#GATE,XDCL] nfp$file_transfer_boot', EJECT ??

  PROCEDURE [#GATE, XDCL] nfp$file_transfer_boot
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{
{ Procedure  nfp$file_transfer_boot
{
{ Purpose    This is the starting procedure for the dreaded PTFS "BOOT".
{            The boot is a task which receives all incoming PTFS connections
{            for processing.  This processing is done by boot initiated tasks
{            whose function is to build a user PTFS batch job.
{
{      ----------      --------------      -----------------
{     |          |    |              |    |                 |
{     | Connect  |--->| Spin off job |--->| Submit off PTFS |
{     | Received |--->| builder task |--->| user job        |
{     |          |    |              |    |                 |
{      ----------      --------------      -----------------
{
{     nfp$file_         nfp$ptfs_job_        nfp$user_ptfs_job
{       transfer_boot   generation_task
{
{
{ Description
{            This routine is the starting procedure for the PTFS boot
{            task.  This task is responsible for receiving incoming PTFS
{            connections and executing a service task per connection.
{            If for any reason the service task cannot be executed, the
{            connection will be terminate.
{
{ Input parameters
{            None
{
{ Output parameters
{            None
{
{ Algorithm
{            Sign on as server to access methods
{            Do forever
{              Receive connect
{              If error, abort
{              Execute service task
{            Doend
{
?? EJECT ??

    VAR
      conditions: pmt$condition,
      nfv$control_block: nft$control_block,
      establish_descriptor: pmt$established_handler,
      ignore_status: ost$status,
      lcn_boot: boolean,
      max_lcn_ptfs_connections: rft$application_connections,
      max_nam_ptfs_connections: nat$number_of_connections,
      nam_boot: boolean,
      number_of_libraries: pmt$number_of_libraries,
      number_of_modules: pmt$number_of_modules,
      number_of_objects: pmt$number_of_object_files,
      parameter_block: SEQ (REP 1 of nft$ptfs_job_switch_params),
      parameter_pointer: ^nft$ptfs_job_switch_params,
      parameter_set: nft$ptfs_job_switch_params,
      program_attributes: ^pmt$program_attributes,
      program_description: ^pmt$program_description,
      program_parameters: ^pmt$program_parameters,
      ptfs_task_queue: nft$task_queue,
      task_id: pmt$task_id,
      task_status: pmt$task_status;

?? NEWTITLE := '  ptfs_boot_handler', EJECT ??

    PROCEDURE ptfs_boot_handler
      (    condition: pmt$condition;
           condition_desc: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR trap_status: ost$status);

      VAR
        condition_handler_status: ost$status,
        local_status: ost$status;


      pmp$log ('PTFS boot task terminating', condition_handler_status);
      nfp$terminate_path (nfv$control_block.application, FALSE, nfv$control_block.path,
            condition_handler_status);
      rfp$application_sign_off (nfv$lcn_application_names [nfv$control_block.application],
            condition_handler_status);
      nap$detach_server_application (nfv$nam_application_names [nfv$control_block.application],
            condition_handler_status);
      IF condition.reason <> $pmt$block_exit_reason [pmc$program_termination] THEN
        osp$set_status_from_condition (nfc$status_id, condition, save_area, local_status,
              condition_handler_status);
        IF condition_handler_status.normal THEN
          nfp$format_message_to_job_log (local_status);
        IFEND;
      IFEND;

    PROCEND ptfs_boot_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    ptfs_task_queue.head := NIL;
    ptfs_task_queue.tail := NIL;
    ptfs_task_queue.number_of_tasks := 0;
    nam_boot := FALSE;
    lcn_boot := FALSE;
    nfv$control_block.path.application_sequence_number := 1;
    nfv$control_block.application := nfc$application_ptfs;
    nfv$control_block.path.path_connected := FALSE;
    nfv$control_block.network_buffer_list.head := NIL;
    nfv$control_block.network_buffer_list.tail := NIL;
    ALLOCATE nfv$control_block.path.network_file: [osc$max_name_size];
    IF nfv$control_block.path.network_file = NIL THEN
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'nfp$ptfs_boot - no VM', status);
      RETURN;
    IFEND;

    conditions.selector := pmc$condition_combination;
    conditions.combination := $pmt$condition_combination [pmc$block_exit_processing];
    pmp$establish_condition_handler (conditions, ^ptfs_boot_handler, ^establish_descriptor, status);
    IF NOT status.normal THEN
      pmp$log ('PTFS boot error **1', ignore_status);
      nfp$format_message_to_job_log (status);
      RETURN;
    IFEND;

{   Get description for connection servicing task

    pmp$get_program_size (number_of_objects, number_of_modules, number_of_libraries, status);
    IF NOT status.normal THEN
      pmp$log ('PTFS boot error **2', ignore_status);
      nfp$format_message_to_job_log (status);
      RETURN;
    IFEND;
    PUSH program_description: [[REP (#SIZE (pmt$program_attributes) +
          (number_of_objects * #SIZE (amt$local_file_name)) + (number_of_modules *
          #SIZE (pmt$program_name)) + (number_of_libraries * #SIZE (amt$local_file_name))) OF cell]];
    pmp$get_program_description (program_description^, status);
    IF NOT status.normal THEN
      pmp$log ('PTFS boot error **3', ignore_status);
      nfp$format_message_to_job_log (status);
      RETURN;
    IFEND;
    RESET program_description;
    NEXT program_attributes IN program_description;
    program_attributes^.contents := program_attributes^.contents +
          $pmt$prog_description_contents [pmc$starting_proc_specified, pmc$term_error_level_specified,
          pmc$debug_mode_specified, pmc$debug_input_specified, pmc$debug_output_specified];
    program_attributes^.starting_procedure := 'NFP$PTFS_JOB_GENERATION_TASK';
    program_attributes^.termination_error_level := pmc$fatal_load_errors;
    program_attributes^.debug_mode := FALSE;
    program_attributes^.debug_input := 'COMMAND';
    program_attributes^.debug_output := '$OUTPUT';

{   MAIN loop

    WHILE TRUE DO

{     Get network path name

      pmp$get_unique_name (nfv$control_block.path.network_file^, status);
      IF NOT status.normal THEN
        pmp$log ('PTFS boot error **4', ignore_status);
        nfp$format_message_to_job_log (status);
        RETURN;
      IFEND;
      nfv$control_block.parameter_rules := ^nfv$ptf_parameter_rules;
      nfv$control_block.path.application_sequence_number :=
            nfv$control_block.path.application_sequence_number + 1;

{     Get network connection }

      nfp$get_server_asynch_event (nfv$control_block.application, nfv$control_block.path, lcn_boot, nam_boot,
            ptfs_task_queue, status);
      IF NOT status.normal THEN
        pmp$log ('PTFS boot error **5', ignore_status);
        nfp$format_message_to_job_log (status);
        RETURN;
      IFEND;

{     Now we have a connection, execute the service task

      parameter_set.path_info := nfv$control_block.path;
      parameter_set.network_file.value := nfv$control_block.path.network_file^;
      program_parameters := ^parameter_block;
      RESET program_parameters;
      NEXT parameter_pointer IN program_parameters;
      parameter_pointer^ := parameter_set;
      RESET program_parameters;

      pmp$execute (program_description^, program_parameters^, osc$nowait, task_id, task_status, status);
      IF status.normal THEN
        nfp$enqueue_task (task_id, nfv$control_block.path, ptfs_task_queue);
        nfv$control_block.path.path_connected := FALSE;
      ELSE
        {** Disconnect path **}
        nfp$format_message_to_job_log (status);
        nfp$terminate_path (nfv$control_block.application, FALSE, nfv$control_block.path, ignore_status);
      IFEND;
    WHILEND;

  PROCEND nfp$file_transfer_boot;
?? OLDTITLE ??
?? NEWTITLE := '[#GATE,XDCL] nfp$ptfs_job_generation_task', EJECT ??

  PROCEDURE [#GATE, XDCL] nfp$ptfs_job_generation_task
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{
{ Procedure  nfp$ptfs_job_generation_task
{
{ Purpose    This is the entry procedure for the PTFS job generation task.
{            This task is executed by the "BOOT" to build the user PTFS job.
{            The job is then submitted for batch execution.  If the user
{            job fails, this task completes the protocol.
{
{ Description
{            Under normal conditions, this procedure has four steps.  First,
{            the connection is opened.  Second, the RFT(s) are read (network)
{            and the user job is written to a file.  Third, the user job
{            is submitted as a batch job.  Fourth, and finally, the connection
{            is switched to the user job.  Note: if either step three or
{            four fail, it is the resposibility of this task to complete
{            the A-A protocol sequence, beginning with RNEG.
{            The format of the user job includes, a LOGIN card, a command
{            to execute PTFS for the job, the login card (again) to be used
{            as recovery text (protocol parameter 05), the RFT(s) protocol
{            used to start the job, and the SCL commands to execute.
{            The user PTFS job must crack its protocol prior to sending
{            RPOS or RNEG.
{
{ Input parameters
{            parameter_list       : via PMP$EXECUTE, contains information
{                                   necessary to establish connection.
{
{ Output parameters
{            status               : final status
{
{ Algorithm
{            Get connection info
{            Establish connect
{            If success then
{              build user job
{              submit user job
{              if success then
{                switch connection
{                if success then
{                  return
{                else
{                  complete protocol (RNEG)
{                ifend
{              else
{                complete protocol (RNEG)
{              ifend
{            ifend
{
?? EJECT ??

    VAR
      conditions: pmt$condition,
      nfv$control_block: nft$control_block,
      establish_descriptor: pmt$established_handler,
      file_attributes: ^fst$attachment_options,
      job_file_id: amt$file_identifier,
      ignore_connection_time: ost$date_time,
      ignore_status: ost$status,
      initiated_job_system_name: jmt$system_supplied_name,
      nam_attributes: ^nat$change_attributes,
      rhfam_attributes: ^rft$change_attributes,
      start_up_message: nft$ptfs_message,
      switch_state: nft$ptfs_switch_states,
      trace_status: ost$status;

    VAR
      nfv$p04_values: [XREF] nft$parameter_04_values;

?? NEWTITLE := '  ptfs_job_generation_task_hand', EJECT ??

    PROCEDURE ptfs_job_generation_task_hand
      (    condition: pmt$condition;
           condition_desc: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR trap_status: ost$status);

      VAR
        condition_handler_status: ost$status,
        local_status: ost$status;


      nfp$terminate_path (nfv$control_block.application, FALSE, nfv$control_block.path,
            condition_handler_status);
      fsp$close_file (job_file_id, condition_handler_status);
      amp$return (nfv$control_block.file_name, condition_handler_status);
      IF condition.reason <> $pmt$block_exit_reason [pmc$program_termination] THEN
        pmp$log ('PTFS job generation task terminating abnormally', local_status);
        osp$set_status_from_condition (nfc$status_id, condition, save_area, status, condition_handler_status);
        IF condition_handler_status.normal THEN
          nfp$format_message_to_job_log (status);
        IFEND;
      IFEND;

    PROCEND ptfs_job_generation_task_hand;
?? OLDTITLE, EJECT ??
    IF nfc$trace_commands THEN
      pmp$log ('PTFS begin job generation task', ignore_status);
    IFEND;
    status.normal := TRUE;
    conditions.selector := pmc$condition_combination;
    conditions.combination := $pmt$condition_combination [pmc$block_exit_processing];
    pmp$establish_condition_handler (conditions, ^ptfs_job_generation_task_hand,
           ^establish_descriptor, status);
    IF NOT status.normal THEN
      pmp$log ('PTFS job generation task - cannot establish handler', ignore_status);
      nfp$format_message_to_job_log (status);
      RETURN;
    IFEND;

{ The P03 values are for requested parameter values, required parameter values, and allowed parameter
{ values.  The LCN P03 value is C and the NAM/VE P03 value is CS.

    nfp$initialize_control_block (nfc$application_ptfs, nfc$p31_unspecified,
          nfv$ptf_send_p03_values [nfc$network_lcn], nfv$ptf_send_p03_values [nfc$network_lcn],
          nfv$ptf_send_p03_values [nfc$network_nam], nfc$p00_a102, nfc$null, ^nfv$ptf_parameter_rules,
          nfv$control_block);

    PUSH nfv$control_block.path.network_file: [osc$max_name_size];
    get_ptfs_connection_info (parameter_list, nfv$control_block.path);
    fsp$open_file (nfv$control_block.path.network_file^, amc$record, NIL, NIL, NIL, NIL, NIL,
          nfv$control_block.path.network_file_id, status);
    IF NOT status.normal THEN
      IF nfc$trace_commands THEN
        pmp$log ('PTFS job generation task - cannot open connection file', ignore_status);
        nfp$format_message_to_job_log (status);
      IFEND;
      RETURN;
    ELSE
      nfv$control_block.path.path_connected := TRUE;
      CASE nfv$control_block.path.network_type OF
      = nfc$network_nam =
        PUSH nam_attributes: [1 .. 1];
        nam_attributes^ [1].kind := nac$data_transfer_timeout;
        nam_attributes^ [1].data_transfer_timeout := nfv$control_block.time_out * nfc$milliseconds;
        nap$store_attributes (nfv$control_block.path.network_file_id, nam_attributes^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      = nfc$network_lcn =
        PUSH rhfam_attributes: [1 .. 1];
        rhfam_attributes^ [1].key := rfc$data_transfer_timeout;
        rhfam_attributes^ [1].data_transfer_timeout := nfv$control_block.time_out * nfc$milliseconds;
        rfp$store (nfv$control_block.path.network_file_id, rhfam_attributes^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
              'nfp$ptfs_job_generation_task bad network type', status);
        nfp$format_message_to_job_log (status);
        RETURN;
      CASEND;
    IFEND;
    IF nfc$trace_commands THEN
      pmp$log ('PTFS connection opened o.k.', ignore_status);
    IFEND;

    start_up_message.msgtype := text_msg;
    start_up_message.log_text := 'TASK STARTED';

{   Get name for user ptfs job file

    pmp$get_unique_name (nfv$control_block.file_name, status);
    IF NOT status.normal THEN
      IF nfc$trace_commands THEN
        pmp$log ('PTFS job generation task - cannot get unique name', ignore_status);
        nfp$format_message_to_job_log (status);
      IFEND;
      RETURN;
    IFEND;
    PUSH file_attributes: [1 .. 1];
    file_attributes^ [1].selector := fsc$open_position;
    file_attributes^ [1].open_position := amc$open_at_boi;
    fsp$open_file (nfv$control_block.file_name, amc$record, file_attributes, NIL, { default creation attr }
    NIL, { mandated creation attr }
    NIL, { attribute validation }
    NIL, { attribute override }
    job_file_id, status);
    IF NOT status.normal THEN
      IF nfc$trace_commands THEN
        pmp$log ('PTFS job generation task - cannot open job file', ignore_status);
        nfp$format_message_to_job_log (status);
      IFEND;
      RETURN;
    IFEND;

{     Build job file from RFT

    IF nfc$trace_commands THEN
      pmp$log ('PTFS start build user job', ignore_status);
    IFEND;
    build_ptfs_job (job_file_id, nfv$rft_parameter_set, nfv$control_block, status);
    fsp$close_file (job_file_id, ignore_status);

{   If job was built o.k., try to submit job

    IF status.normal THEN
      IF nfc$trace_commands THEN
        pmp$log ('PTFS job write success, attempt submit', ignore_status);
      IFEND;
      ptfs_submit_user_job (nfv$control_block.path, nfv$control_block.system_job_name,
            nfv$control_block.file_name, nfv$control_block.application, nfv$control_block.remote_ring,
            initiated_job_system_name, status);
    ELSE
      IF nfc$trace_commands THEN
        pmp$log ('PTFS job write failed', ignore_status);
      IFEND;
    IFEND;

{   Clean up batch job file

    amp$return (nfv$control_block.file_name, ignore_status);

{   If batch job/build job unsuccessfull, set up status

    IF NOT status.normal THEN
      IF NOT (status.condition = jme$maximum_jobs) THEN
        osp$set_status_abnormal (nfc$status_id, nfv$p04_values [nfc$p04_invalid_account_pw].condition, '',
              nfv$control_block.state_of_transfer);
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfv$p04_values [nfc$p04_receiver_problem_retry].condition, '',
              nfv$control_block.state_of_transfer);
      IFEND;
      nfv$control_block.local_status := status;
      switch_state := nfc$no_switch_attempted;
    ELSE

{     If the job was successfully started, try to switch the connection. }

      fsp$close_file (nfv$control_block.path.network_file_id, status);
      IF NOT status.normal THEN
        switch_state := nfc$switch_failed_lost;
      ELSE
        ptfs_switch_connection (initiated_job_system_name, nfv$control_block, switch_state, status);
        nfp$set_abnormal_if_normal (status, nfv$control_block.local_status);
      IFEND;
    IFEND;

{   Handle switch/no switch situations }

    IF nfc$trace_commands THEN
      pmp$log ('PTFS handle switch states', ignore_status);
    IFEND;
    CASE switch_state OF
    = nfc$switch_complete =
      amp$return (nfv$control_block.path.network_file^, ignore_status);
      nfv$control_block.path.path_connected := FALSE;
    = nfc$switch_failed_cancelled =
      IF nfc$trace_commands THEN
        pmp$log ('PTFS JOB gen task, connect switch failed', trace_status);
      IFEND;
      fsp$open_file (nfv$control_block.path.network_file^, amc$record, NIL, { File attachment opts }
      NIL, { Default creation opts }
      NIL, { Mandated creation opts }
      NIL, { Attribute validation }
      NIL, { Attribute override }
      nfv$control_block.path.network_file_id, status);
      IF NOT status.normal THEN
        IF nfc$trace_commands THEN
          pmp$log ('PTFS job generation task - cannot reopen connection', ignore_status);
          nfp$format_message_to_job_log (status);
        IFEND;
        amp$return (nfv$control_block.path.network_file^, ignore_status);
        pmp$disestablish_cond_handler (conditions, ignore_status);
        RETURN;
      ELSE
        CASE nfv$control_block.path.network_type OF
        = nfc$network_nam =
          PUSH nam_attributes: [1 .. 1];
          nam_attributes^ [1].kind := nac$data_transfer_timeout;
          nam_attributes^ [1].data_transfer_timeout := nfv$control_block.time_out * nfc$milliseconds;
          nap$store_attributes (nfv$control_block.path.network_file_id, nam_attributes^, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        = nfc$network_lcn =
          PUSH rhfam_attributes: [1 .. 1];
          rhfam_attributes^ [1].key := rfc$data_transfer_timeout;
          rhfam_attributes^ [1].data_transfer_timeout := nfv$control_block.time_out * nfc$milliseconds;
          rfp$store (nfv$control_block.path.network_file_id, rhfam_attributes^, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
                'nfp$ptfs_job_generation_task bad network type', status);
          RETURN;
        CASEND;

      IFEND;
      IF nfv$control_block.state_of_transfer.normal THEN
        osp$set_status_abnormal (nfc$status_id, nfe$application_time_out, '',
              nfv$control_block.state_of_transfer);
      IFEND;
      ptfs_process_protocol (FALSE, ptfs_job_generation_task,
        nfv$control_block, ignore_connection_time, status);
      IF NOT status.normal THEN
        IF nfc$trace_commands THEN
          pmp$log ('PTFS job generation task - cannot complete protocol', ignore_status);
          nfp$format_message_to_job_log (status);
        IFEND;
        RETURN;
      IFEND;
      nfp$terminate_path (nfv$control_block.application, FALSE, nfv$control_block.path, status);
    = nfc$no_switch_attempted =
      ptfs_process_protocol (FALSE, ptfs_job_generation_task,
        nfv$control_block, ignore_connection_time, status);
      IF NOT status.normal THEN
        IF nfc$trace_commands THEN
          pmp$log ('PTFS job generation task - cannot complete protocol', ignore_status);
          nfp$format_message_to_job_log (status);
        IFEND;
        RETURN;
      IFEND;
      nfp$terminate_path (nfv$control_block.application, FALSE, nfv$control_block.path, status);
    = nfc$switch_failed_lost =
      IF nfc$trace_commands THEN
        pmp$log (' PTFS JOB gen task, connect switch failed', trace_status);
        nfp$format_message_to_job_log (status);
      IFEND;
      nfp$terminate_path (nfv$control_block.application, FALSE, nfv$control_block.path, status);
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
            'nfp$ptfs_job_generation_task, case error', status);
      RETURN;
    CASEND;
    IF nfc$trace_commands THEN
      pmp$log ('PTFS normal exit', ignore_status);
    IFEND;
    pmp$disestablish_cond_handler (conditions, ignore_status);

  PROCEND nfp$ptfs_job_generation_task;
?? OLDTITLE ??
?? NEWTITLE := '[#GATE,XDCL] nfp$user_ptfs_job', EJECT ??

{ PURPOSE:
{   This task is called from inside the PTFS user job.  It is the first task
{   executed after user prolog (if allowed by site).  Essentially, it readies
{   the job as a PTFS job and starts execution of user SCL statements.
{
{ DESCRIPTION:
{   This task accepts the connection switch offer and reads information out of
{   the job which was placed there by the job builder task.  This information
{   consists of recovery text (LOGIN information) which is passed back to the
{   initiating host, and protocol information.  The protocol information is the
{   RFT(s) which were used to create this job.  Once the RFT(s) have been
{   digested, assuming no errors were found, this task executes the
{   provided user SCL statements.  Here things get a bit tricky.  Before
{   executing the SCL, two new commands are given to SCL.  They are SEND_FILE
{   and RECEIVE_FILE.  Now if a SEND_FILE or RECEIVE_FILE is called it will
{   attempt file transfer.  So PTFS has called an SCL routine who has called a
{   routine back in this module.  Status and protocol information is kept
{   in the STATIC control block so SEND_FILE and RECEIVE_FILE may access it.
{   When SCL processing is complete, this routine checks to see if a file
{   transfer has been attempted.  If so, the RPOS was sent by the file
{   transfer processor.  If not, we send the RPOS or RNEG (if we got
{   back a bad status from SCL) and continue in the protocol.
{
{ NOTE:
{   Information is sent from the PTF Server task to the user job by
{   using the job attribute: JOB_INPUT_DEVICE.  This information
{   contains the system job name of the PTF Server, the connection
{   file name, and the type of connection (NAM or LCN).

  PROCEDURE [#GATE, XDCL] nfp$user_ptfs_job
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      begin_connection_time: ost$date_time,
      caller_id: ost$caller_identifier,
      caller_in_current_task: boolean,
      conditions: pmt$condition,
      error_message_string: string (osc$max_string_size),
      file_attachment_options: ^fst$attachment_options,
      ignore_file_id: amt$file_identifier,
      ignore_reporting_option: boolean,
      ignore_status: ost$status,
      establish_descriptor: pmt$established_handler,
      input_block_handle: clt$block_handle,
      input_executable: boolean,
      input_file_id: amt$file_identifier,
      job_attribute_changes_p: ^jmt$job_attribute_changes,
      lcn_number_server_connects: rft$application_connections,
      local_status: ost$status,
      nam_attributes: ^nat$change_attributes,
      nam_switch_attributes: ^nat$change_attributes,
      network_file_name: ost$name,
      physical_id: rft$physical_identifier,
      ready_index: integer,
      retrieve_archived_file: boolean,
      rhfam_attributes: ^rft$change_attributes,
      source_job_name: jmt$system_supplied_name,
      submit_option: ^jmt$job_attribute_results,
      submit_option_ptr: 1 .. jmc$job_input_device_size + 1,
      trace_status: ost$status,
      user_id: ost$user_identification,
      wait_list: ^ost$i_wait_list;

    VAR
      nfv$control_block: [STATIC, XDCL] nft$control_block;

?? NEWTITLE := 'ptfs_user_job_handler', EJECT ??

    PROCEDURE ptfs_user_job_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR trap_status: ost$status);

      VAR
        condition_handler_status: ost$status,
        local_status: ost$status;

      IF condition.reason <> $pmt$block_exit_reason [pmc$program_termination] THEN
        pmp$log ('USER PTFS job terminating abnormally', local_status);
        osp$set_status_from_condition (nfc$status_id, condition, save_area, local_status,
              condition_handler_status);
        IF condition_handler_status.normal THEN
          nfp$format_message_to_job_log (local_status);
        IFEND;
      IFEND;
      nfp$terminate_path (nfv$control_block.application, TRUE, nfv$control_block.path, local_status);

    PROCEND ptfs_user_job_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    nfv$control_block.application := nfc$application_ptfs;
    conditions.selector := pmc$condition_combination;
    conditions.combination := $pmt$condition_combination [pmc$block_exit_processing];
    pmp$establish_condition_handler (conditions, ^ptfs_user_job_handler, ^establish_descriptor, status);
    IF NOT status.normal THEN
      nfp$format_message_to_job_log (status);
      RETURN;
    IFEND;
    PUSH job_attribute_changes_p: [1 .. 1];
    job_attribute_changes_p^ [1].key := jmc$output_disposition;
    job_attribute_changes_p^ [1].output_disposition.key := jmc$discard_standard_output;
    jmp$change_job_attributes (job_attribute_changes_p, status);
    IF NOT status.normal THEN
      nfp$format_message_to_job_log (status);
      RETURN;
    IFEND;

{ Get connection information from the job attribute job_input_device.

    PUSH submit_option: [1 .. 2];
    submit_option^ [1].key := jmc$job_input_device;
    PUSH submit_option^[1].job_input_device;
    submit_option^ [2].key := jmc$origin_application_name;
    jmp$get_job_attributes (submit_option, status);
    IF NOT status.normal THEN
      nfp$format_message_to_job_log (status);
      RETURN;
    ELSE
      IF nfc$trace_commands THEN
        pmp$log(' UPTFS user job information',trace_status);
        pmp$log(submit_option^[1].job_input_device^ .text,trace_status);
        pmp$log(' UPTFS initiating application',trace_status);
        pmp$log(submit_option^[2].origin_application_name,trace_status);
      IFEND;
    IFEND;
    IF submit_option^ [2].origin_application_name <> nfv$nam_application_names
          [nfv$control_block.application] THEN
      error_message_string (1, 30) := 'Invalid initiating application';
      error_message_string (31, * ) := submit_option^ [2].origin_application_name;
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, error_message_string, status);
      RETURN;
    IFEND;

{ Crack user information for job

    submit_option_ptr := 1;
    source_job_name (submit_option_ptr, #SIZE (source_job_name)) := submit_option^ [1].
          job_input_device^ .text (1, #SIZE (source_job_name));
    submit_option_ptr := submit_option_ptr + #SIZE (source_job_name);
    network_file_name := submit_option^ [1].job_input_device^ .text
          (submit_option_ptr, #SIZE (network_file_name));
    submit_option_ptr := submit_option_ptr + #SIZE (network_file_name);

    IF submit_option^ [1].job_input_device^ .text (submit_option_ptr, 1) = nfc$ptfs_network_flag_nam THEN
      nfv$control_block.path.network_type := nfc$network_nam;
    ELSEIF submit_option^ [1].job_input_device^ .text (submit_option_ptr, 1) = nfc$ptfs_network_flag_lcn THEN
      nfv$control_block.path.network_type := nfc$network_lcn;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'nfp$user_ptfs_job bad network type',
            status);
      RETURN;
    IFEND;

{ The P03 values are for requested parameter values, required parameter values, and allowed parameter
{ values.  The LCN P03 value is C and the NAM/VE P03 value is CS.

    nfp$initialize_control_block (nfc$application_ptfs, nfc$p31_unspecified,
          nfv$ptf_send_p03_values [nfc$network_lcn], nfv$ptf_send_p03_values [nfc$network_lcn],
          nfv$ptf_send_p03_values [nfc$network_nam], nfc$p00_a102, nfc$null, ^nfv$ptf_parameter_rules,
          nfv$control_block);

{ Set the Control Block's LAST_COMMAND_RECEIVED to RFT because the RFT was received by the PTFS system task.

    nfv$control_block.last_command_received := nfc$rft;

    PUSH nfv$control_block.path.network_file: [#SIZE (network_file_name)];
    nfv$control_block.path.network_file^ := network_file_name;
    nfv$control_block.path.path_connected := TRUE;
    nfv$control_block.path.application_sequence_number := 0;

{ Accept the switch offer, if it is around

    CASE nfv$control_block.path.network_type OF
    = nfc$network_nam =
      PUSH wait_list: [1 .. 2];
      wait_list^ [1].activity := nac$i_await_switch_offer;
      wait_list^ [1].source := source_job_name;
      wait_list^ [2].activity := osc$i_await_time;
      wait_list^ [2].milliseconds := nfv$control_block.time_out * nfc$milliseconds;
      osp$i_await_activity_completion (wait_list^, ready_index, status);
      IF NOT status.normal THEN
        nfp$format_message_to_job_log (status);
        RETURN;
      IFEND;

      IF ready_index <> 1 THEN
        osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'No connect switch offer available',
              status);
        nfp$format_message_to_job_log (status);
        RETURN;
      IFEND;

      nam_switch_attributes := NIL;
      nap$accept_switch_offer (nfv$control_block.path.network_file^, source_job_name, nam_switch_attributes,
            nfv$control_block.time_out * nfc$milliseconds, status);
    = nfc$network_lcn =
      IF nfc$trace_commands THEN
        pmp$log (' UPTFS Attempt sign on', trace_status);
      IFEND;
      lcn_number_server_connects := 1;
      rfp$application_sign_on (nfv$lcn_application_names [nfv$control_block.application], rfc$partner,
            lcn_number_server_connects, status);
      IF NOT status.normal THEN
        nfp$format_message_to_job_log (status);
        RETURN;
      IFEND;

      IF nfc$trace_commands THEN
        pmp$log (' UPTFS attempt accept switch offer', trace_status);
      IFEND;
      rfp$accept_switch_offer (nfv$lcn_application_names [nfv$control_block.application],
            nfv$control_block.path.network_file^, NIL, nfv$control_block.time_out * nfc$milliseconds,
            source_job_name, status);
      nfv$control_block.send_facilities := nfv$ptf_send_p03_values [nfc$network_lcn];
      nfv$control_block.required_facilities := nfv$ptf_send_p03_values [nfc$network_lcn];
      nfv$control_block.allowed_facilities := nfv$ptf_send_p03_values [nfc$network_lcn];
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'nfp$user_ptfs_job, case error',
            status);
      nfp$format_message_to_job_log (status);
      RETURN;
    CASEND;
    IF NOT status.normal THEN
      nfp$format_message_to_job_log (status);
      RETURN;
    ELSE
      IF nfc$trace_commands THEN
        pmp$log (' UPTFS connection switch success', trace_status);
      IFEND;
      fsp$open_file (nfv$control_block.path.network_file^, amc$record, NIL, NIL, NIL, NIL, NIL,
            nfv$control_block.path.network_file_id, status);
      IF NOT status.normal THEN
        amp$return (nfv$control_block.path.network_file^, local_status);
        nfp$format_message_to_job_log (status);
        RETURN;
      ELSE
        nfv$control_block.path.path_connected := TRUE;
        CASE nfv$control_block.path.network_type OF
        = nfc$network_nam =
          PUSH nam_attributes: [1 .. 1];
          nam_attributes^ [1].kind := nac$data_transfer_timeout;
          nam_attributes^ [1].data_transfer_timeout := nfv$control_block.time_out * nfc$milliseconds;
          nap$store_attributes (nfv$control_block.path.network_file_id, nam_attributes^, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          pmp$get_user_identification (user_id, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          nfv$control_block.transfer_pid_length := nfp$string_length (user_id.family);
          nfv$control_block.transfer_pid := user_id.family (1, nfv$control_block.transfer_pid_length);
        = nfc$network_lcn =
          PUSH rhfam_attributes: [1 .. 1];
          rhfam_attributes^ [1].key := rfc$data_transfer_timeout;
          rhfam_attributes^ [1].data_transfer_timeout := nfv$control_block.time_out * nfc$milliseconds;
          rfp$store (nfv$control_block.path.network_file_id, rhfam_attributes^, status);
          IF NOT status.normal THEN
            RETURN
          IFEND;
          rfp$get_local_host_physical_id(physical_id,status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          nfv$control_block.transfer_pid_length := #SIZE(physical_id);
          nfv$control_block.transfer_pid := physical_id;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
                'nfp$ptfs_job_generation_task bad network type', status);
          RETURN;
        CASEND;
      IFEND;
    IFEND;

    pmp$get_compact_date_time( begin_connection_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    #CALLER_ID (caller_id);
    nfv$control_block.remote_ring.value := caller_id.ring;

{ Set up for reading text from the command file }

    clp$push_input (clc$current_command_input, osc$null_name, '', FALSE, TRUE, input_block_handle,
          input_file_id, input_executable, status);
    IF NOT status.normal THEN
      nfp$format_message_to_job_log (status);
      RETURN;
    IFEND;

{ Get the recovery text for this job

    IF nfc$trace_commands THEN
      pmp$log (' UPTFS get recovery text', trace_status);
    IFEND;
    get_recovery_text (nfv$control_block.send_directives, status);
    IF NOT status.normal THEN
      nfp$format_message_to_job_log (status);
      RETURN;
    IFEND;

{ Crack the RFT block(s) contained in the job

    IF nfc$trace_commands THEN
      pmp$log (' UPTFS begin cracking RFTs', trace_status);
    IFEND;
    crack_embedded_rfts (nfv$control_block, status);

      clp$pop_input (TRUE, input_block_handle, input_file_id, input_executable, NIL, ignore_status);

{ Build accounting stuff associated with directives

    nfv$control_block.transfer_directives_length := nfp$count_directives_text(nfv$control_block.
          received_directives.head);
    IF (nfv$control_block.received_directives.head^.link <> NIL) THEN
      build_05_directives_text( nfv$control_block.received_directives.head^.link, nfv$control_block.
           ptf_scl_directive);
    ELSE
      nfv$control_block.ptf_scl_directive.size := 0;
    IFEND;

    nfp$deallocate_dirs_from_head (nfv$control_block.received_directives, ignore_status);
    IF status.normal THEN

{ Pass the rest of the job stream to SCL for processing

      ptfs_scan_scl_command_file (clc$current_command_input, FALSE, begin_connection_time, nfv$control_block,
            status);
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$protocol_anomaly, '', nfv$control_block.state_of_transfer);
      nfp$set_abnormal_if_normal (status, nfv$control_block.local_status);
    IFEND;

{ The SCL processing has completed, finish protocol

    IF nfv$control_block.state_of_transfer.condition = nfv$p04_values
        [nfc$p04_file_unavailable].condition THEN
      ptfs_process_protocol (FALSE, user_ptfs_job_call, nfv$control_block, begin_connection_time,
           ignore_status);
      consult_archive_response_var (ignore_reporting_option, retrieve_archived_file);
      IF retrieve_archived_file THEN
        PUSH file_attachment_options: [1..1];
        file_attachment_options^[1].selector := fsc$create_file;
        file_attachment_options^[1].create_file := FALSE;
        fsp$open_file (nfv$control_block.file_name, amc$record, file_attachment_options, NIL, NIL,
           NIL, NIL, ignore_file_id, status);
      IFEND;
    ELSE
      ptfs_process_protocol (TRUE, user_ptfs_job_call, nfv$control_block, begin_connection_time,
           ignore_status);
    IFEND;

    nfp$terminate_path (nfv$control_block.application, TRUE, nfv$control_block.path, ignore_status);
    pmp$disestablish_cond_handler (conditions, ignore_status);

  PROCEND nfp$user_ptfs_job;
?? OLDTITLE ??
?? NEWTITLE := 'build_ptfs_job', EJECT ??

  PROCEDURE build_ptfs_job
    (    job_file_id: amt$file_identifier;
     VAR received_parameters: nft$parameter_set;
     VAR nfv$control_block: nft$control_block;
     VAR status: ost$status);

{
{ Procedure  build_ptfs_job
{
{ Purpose    This procedure writes a file which is submitted as a job
{            to initialize PTFS.  The job consists of login, a call to
{            the PTFS application, recovery text (login), and all
{            command buffers associated with the RFT.  The command
{            buffers are followed by the SCL to be executed.
{
{ Description
{            Some comments,
{            1. If the first received command buffer does not contain
{               an user text (p05) it, and all command buffers received
{               until user text is received must be saved.  The saved
{               buffers must then be written into the job in the correct
{               order.
{            2. The job looks rather like this...
{                   Login,...            User supplied login
{                   PTFS                 Call to ptfs
{                   Login,...            Again, for recovery text
{                    Command buffer 1
{                   *EOB
{                    Command buffer 2
{                   *EOB
{                    Command buffer n
{                   *EOB
{                   *EOC
{                   All SCL commands
{
{ Input parameters
{            Job_file_id          : File ID of job being written
{
{ Input/output parameters
{            Control_block        : Transfer control block
{
{ Output parameters
{            Status               : Return status
{
{ Algorithm
{            Crack command and number of parameters
{            For 1 to # of parameters Do
{              Case parameter Of
{              =protocol_id= nfp$receive_parameter_00
{              =user_text= If first occurence then
{                            Write in file (Login)
{                            Write in PTFS execute task
{                            Write in file (Login again) for recovery text
{                          Ifend
{                          Enqueue directive on list
{              =time_out= nfp$receive_parameter_20
{              =host_type= nfp$receive_parameter_22
{              Else Ignore parameter, not serviced in this task
{              Casend
{              Write command buffers into job
{              Write Enqueued directives into job
{
?? EJECT ??
{}

    VAR
      abort_xfer: boolean,
      action: nft$crack_parameter_action,
      buffer_list: ^buffer_list_element,
      buffer_position: integer,
      byte_address: amt$file_byte_address,
      command_in_process: nft$protocol_commands,
      current_element: ^buffer_list_element,
      eoc_string: string (nfc$ptfs_job_end_clen),
      expected_command: nft$command_set,
      ignored_params: nft$parameter_set,
      index: integer,
      input_buffer: string (nfc$command_buffer_size),
      input_length: nft$command_pdu_size,
      last_block_received: boolean,
      negotiate_down: boolean,
      number_of_parameters: nft$number_pdu_param_range,
      parameter_identifier: nft$protocol_parameters,
      parameter_length: nft$parameter_size,
      parameter_qualifier: nft$parameter_qualifiers,
      parameter_value: string (nfc$max_param_size),
      ptfs_command: string (nfc$ptfs_command_length),
      received_command: nft$protocol_commands,
      ring_record: clt$integer,
      special_options_found: boolean,
      user_text_received: boolean;

{}
    status.normal := TRUE;
    buffer_list := NIL;
    command_in_process := nfc$unknown_command;
    current_element := NIL;
    eoc_string := nfc$ptfs_job_end_command;
    expected_command := $nft$command_set [nfc$rft];
    last_block_received := FALSE;
    ignored_params := $nft$parameter_set [];
    ptfs_command := nfc$ptfs_command_name;
    received_parameters := $nft$parameter_set [];
    special_options_found := FALSE;
    user_text_received := FALSE;
{}
{******************************************************************************}
    WHILE NOT last_block_received DO
      last_block_received := TRUE;
      nfp$get_and_crack_command (expected_command, ^input_buffer, nfv$control_block, input_length,
            number_of_parameters, received_command, command_in_process, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
{}
      buffer_position := nfc$begin_params_pos;
      FOR index := 1 TO number_of_parameters DO
        IF buffer_position > STRLENGTH (input_buffer) THEN
          osp$set_status_abnormal (nfc$status_id, nfe$protocol_anomaly, '', status);
          RETURN;
        IFEND;
        nfp$crack_parameter (received_command, nfv$control_block.protocol_in_use,
              input_buffer (buffer_position, * ), nfv$control_block.parameter_rules^,
              nfv$control_block.network_buffer_list, parameter_length, parameter_value, parameter_identifier,
              parameter_qualifier, action, ignored_params, abort_xfer, status);
        IF status.normal THEN
          received_parameters := received_parameters +
               $nft$parameter_set [parameter_identifier];
        ELSE
          RETURN;
        IFEND;
        IF action = nfc$process THEN
          CASE parameter_identifier OF
          = nfc$protocol_id =
            nfp$receive_parameter_00 (received_command, parameter_value (1, parameter_length),
                  parameter_qualifier, nfv$control_block.protocol_in_use, nfv$control_block.protocol_in_use,
                  negotiate_down, { Server doesn't
                  status);
          = nfc$user_text_directive =
            IF NOT user_text_received THEN
              user_text_received := TRUE;
{}
{     ***Write job login }
{}
              amp$put_next (job_file_id, ^parameter_value (1, parameter_length), parameter_length,
                    byte_address, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
{}
{     *** Write PTFS command }
{}
              amp$put_next (job_file_id, ^ptfs_command, STRLENGTH (ptfs_command), byte_address, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
{}
{     *** Write login again for recovery text }
{}
              amp$put_next (job_file_id, ^parameter_value (1, parameter_length), parameter_length,
                    byte_address, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              flush_job_command_buffers (job_file_id, buffer_list, status);
            ELSE
{}
{     *** Enqueue command for end of job }
{}
              ptfs_enqueue_directive (parameter_value (1, parameter_length),
                    nfv$control_block.received_directives, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;

          = nfc$special_options =
            special_options_found := TRUE;
            nfv$control_block.receive_special_options.size := parameter_length;
            IF parameter_length > 0 THEN
              nfv$control_block.receive_special_options.value := parameter_value (1, parameter_length);
            IFEND;
          = nfc$minimum_timeout_interval =
            nfp$receive_parameter_20 (parameter_value (1, parameter_length), parameter_qualifier,
                  nfv$control_block.path, nfv$control_block.time_out, status);
          = nfc$host_type =
            nfp$receive_parameter_22 (parameter_value (1, parameter_length), parameter_qualifier,
                  nfv$control_block.remote_host_type, status);
          = nfc$attribute_continued =
            last_block_received := FALSE;
          ELSE
            {    Ignore }
          CASEND;
        ELSE
        IFEND;
        buffer_position := buffer_position + parameter_length + nfc$param_header_size;
      FOREND;
      IF NOT user_text_received THEN
        IF buffer_list = NIL THEN
          PUSH buffer_list;
          current_element := buffer_list;
          current_element^.buffer := input_buffer;
          current_element^.length := input_length;
        ELSE
          PUSH current_element^.forward_pointer;
          current_element := current_element^.forward_pointer;
          current_element^.buffer := input_buffer;
          current_element^.length := input_length;
        IFEND;
      ELSE
        write_job_command_buffer (job_file_id, input_buffer (1, input_length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    WHILEND;
{******************************************************************************}


    amp$put_next (job_file_id, ^eoc_string, STRLENGTH (eoc_string), byte_address, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    ptfs_write_user_text (job_file_id, nfv$control_block.received_directives, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    IF (special_options_found AND (nfv$control_block.remote_host_type = nfc$p22_nos_ve)) THEN
      clp$convert_string_to_integer (nfv$control_block.receive_special_options.
            value (1, nfv$control_block.receive_special_options.size), ring_record, status);
      IF status.normal THEN
        nfv$control_block.remote_ring.specified := TRUE;
        nfv$control_block.remote_ring.value := ring_record.value;
      IFEND;
    IFEND;
{}
  PROCEND build_ptfs_job;
?? OLDTITLE ??
?? NEWTITLE := 'consult_archive_response_var', EJECT ??
PROCEDURE consult_archive_response_var
  ( VAR report_file_archived: boolean;
    VAR retrieve_archived_file: boolean );

  CONST
    ptf_archive_response_variable = 'OSV$PTF_ARCHIVE_RESPONSE';

  VAR
    archive_response: ^clt$data_value,
    ignore_status: ost$status,
    status: ost$status;

    report_file_archived   := FALSE;
    retrieve_archived_file := TRUE;

    clp$get_variable_value (ptf_archive_response_variable, archive_response, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE archive_response^.kind OF
    = clc$keyword =
      IF archive_response^.keyword_value = 'REPORT_ERROR' THEN
        report_file_archived := TRUE;
        retrieve_archived_file := FALSE;
      ELSEIF archive_response^.keyword_value = 'REPORT_ERROR_AND_RETRIEVE' THEN
        report_file_archived := TRUE;
        retrieve_archived_file := TRUE;
      IFEND;
    = clc$name =
      IF archive_response^.name_value = 'REPORT_ERROR' THEN
        report_file_archived := TRUE;
        retrieve_archived_file := FALSE;
      ELSEIF archive_response^.name_value = 'REPORT_ERROR_AND_RETRIEVE' THEN
        report_file_archived := TRUE;
        retrieve_archived_file := TRUE;
      IFEND;
    ELSE
       pmp$log('***PTFS- the archive response variable was of an unknown type.', ignore_status);
    CASEND; { archive_repsonse^.kind

PROCEND consult_archive_response_var;
?? OLDTITLE ??
{}
?? NEWTITLE := 'flush_job_command_buffers', EJECT ??

  PROCEDURE flush_job_command_buffers
    (    job_file_id: amt$file_identifier;
     VAR buffer_pointer: ^buffer_list_element;
     VAR status: ost$status);

{
{ Procedure  flush_job_command_buffers
{
{ Purpose    This routine is called to pass each of the protocol command
{            buffers on the buffer list to write_job_command_buffer
{            for writing into the job file.
{
{ Description
{            This routine simply goes down the list of buffers until
{            the next buffer pointer is NIL.
{
{ Input parameters
{            Job_file_id          : ID of the job file being written
{            Buffer_pointer       : Pointer to list of PDU buffers
{
{ Output parameters
{            Status               : Value returned by
{                                        write_job_command_buffer
{
{ Algorithm
{            While pointer not NIL do
{              Nfp$write_job_command_buffer
{              If bad status, return with error
{            Whilend
{
?? EJECT ??

    VAR
      pointer: ^buffer_list_element;

{}
    status.normal := TRUE;
    pointer := buffer_pointer;
    WHILE pointer <> NIL DO
      write_job_command_buffer (job_file_id, pointer^.buffer (1, pointer^.length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      pointer := pointer^.forward_pointer;
    WHILEND;
    buffer_pointer := NIL;
{}
  PROCEND flush_job_command_buffers;
?? OLDTITLE ??
{}
?? NEWTITLE := 'write_job_command_buffer', EJECT ??

  PROCEDURE write_job_command_buffer
    (    job_file_id: amt$file_identifier;
         input_buffer: string ( * <= nfc$command_buffer_size);
     VAR status: ost$status);

{
{ Procedure  write_job_command_buffer
{
{ Purpose    This routine takes a command buffer and writes it into the
{            open file specified by Job_file_id.
{
{ Description
{            The command buffer input to this procedure is broken into
{            lines of maximum length satisfactory to job management.  At
{            present the maximum record length is rumored to be 256
{            characters.  However, here we use a size that is easily editable.
{            After the buffer has been broken up into line(s), a trailing
{            string is written into the job stream.  Note also, the PDU
{            info is shifted one character (preceded by a space) such that
{            it is easily differentiated from the trailing string.
{
{ Input parameters
{
{            job_file_id   : File id to write directive
{            input_buffer  : Directive to write
{
{ Output parameters
{
{            status        : Return status
{
{ Algorithm
{
{            While more data to write
{              Write data at maximum width
{              Update data pointer
{            Whilend
{
?? EJECT ??
{}

    VAR
      buffer_length: integer,
      buffer_pointer: integer,
      byte_address: amt$file_byte_address,
      eob_string: string (nfc$ptfs_job_end_blen),
      line: string (nfc$ptfs_job_line_width + nfc$ptfs_job_line_head_len + nfc$ptfs_job_line_tail_len),
      line_length: integer;

{}
    status.normal := TRUE;
    buffer_length := STRLENGTH (input_buffer);
    buffer_pointer := 1;
    eob_string := nfc$ptfs_job_end_buffer;
    REPEAT
      IF buffer_length - buffer_pointer >= nfc$ptfs_job_line_width THEN
        line_length := nfc$ptfs_job_line_width;
      ELSE
        line_length := buffer_length - buffer_pointer + 1;
      IFEND;
      line (1, nfc$ptfs_job_line_head_len) := nfc$ptfs_job_line_header;
      line (nfc$ptfs_job_line_head_len + 1, * ) := input_buffer (buffer_pointer, line_length);
      line (nfc$ptfs_job_line_head_len + line_length + nfc$ptfs_job_line_tail_len,
            1) := nfc$ptfs_job_line_tailer;
      amp$put_next (job_file_id, ^line, line_length + nfc$ptfs_job_line_head_len + nfc$ptfs_job_line_tail_len,
            byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      buffer_pointer := buffer_pointer + line_length;
    UNTIL (buffer_pointer > buffer_length); amp$put_next (job_file_id, ^eob_string, STRLENGTH (eob_string),
          byte_address, status);
{}
  PROCEND write_job_command_buffer;
?? OLDTITLE ??
?? NEWTITLE := 'get_ptfs_connection_info', EJECT ??

  PROCEDURE get_ptfs_connection_info
    (    parameter_list: clt$parameter_list;
     VAR path: nft$network_connection);

{
{ Procedure  get_ptfs_connection_info
{
{ Purpose    This routine is called by the PTFS job generation task to
{            get parameters passed to it by the Ptfs boot via the
{            PMP$EXECUTE command.
{
{ Description
{            The information is passed via sequence and mapped into
{            the type nft$ptfs_job_switch_params.
{
{ Input parameters
{            Parameter_list       : Input parameter list
{
{ Output parameters
{            Control_block        : Returned info goes here
{            Status               : Return status (not used at present)
{
{ Algorithm
{            Set up pointers to sequence
{            Get first in sequence
{            Place first into nfv$control_block
{

    VAR
      parameter_sequence: ^clt$parameter_list,
      parameter_set: nft$ptfs_job_switch_params,
      parameter_value: ^nft$ptfs_job_switch_params,
      save_pointer: ^fst$file_reference;

{}
    save_pointer := path.network_file;
    parameter_sequence := ^parameter_list;
    RESET parameter_sequence;
    NEXT parameter_value IN parameter_sequence;
    parameter_set := parameter_value^;
    RESET parameter_sequence;
    path := parameter_set.path_info;
    path.network_file := save_pointer;
    path.network_file^ := parameter_set.network_file.value;
{}
  PROCEND get_ptfs_connection_info;
?? OLDTITLE ??
?? NEWTITLE := 'ptfs_submit_user_job', EJECT ??

{ PURPOSE:
{   This purpose of this procedure is to submit a user PTFS job with the correct
{   attributes.  It also has a KLUDGE mode such that it can be run outside of
{   the system task (note slighly different job attributes).
{
{ NOTE:
{   The job_submission_option "JOB_INPUT_DEVICE" is used to pass information
{   from the PTF SERVER task to the user job.  The information that is passed
{   is the system job name of the PTF SERVER task, the connection file name,
{   and the type of connection file (NAM or LCN).

  PROCEDURE ptfs_submit_user_job
    (    path: nft$network_connection;
         system_job_name: jmt$system_supplied_name;
         file_name: amt$local_file_name;
         application: nft$application_values;
         remote_ring: nft$network_ring_information;
     VAR initiated_job_system_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      application_number_string: ost$string,
      caller_id: ost$caller_identifier,
      job_submit_options: ^jmt$job_submission_options,
      trace_status: ost$status,
      user_job_info_index: 1 .. jmc$job_input_device_size + 1,
      user_job_information: jmt$job_input_device;

    status.normal := TRUE;
    clp$convert_integer_to_string (path.application_sequence_number, 10, FALSE, application_number_string,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{     Build file connection information for user job

    user_job_info_index := 1;
    user_job_information.text (user_job_info_index, #SIZE (system_job_name)) := system_job_name;
    user_job_info_index := user_job_info_index + #SIZE (system_job_name);
    user_job_information.text (user_job_info_index, #SIZE (path.network_file^)) := path.network_file^;
    user_job_info_index := user_job_info_index + #SIZE (path.network_file^);
    CASE path.network_type OF
    = nfc$network_nam =
      user_job_information.text (user_job_info_index, 1) := nfc$ptfs_network_flag_nam;
      user_job_info_index := user_job_info_index + 1;
    = nfc$network_lcn =
      user_job_information.text (user_job_info_index, 1) := nfc$ptfs_network_flag_lcn;
      user_job_info_index := user_job_info_index + 1;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
            'ptfs_submit_user_job bad network type', status);
      RETURN;
    CASEND;
    user_job_information.text (user_job_info_index, * ) := ' ';
    user_job_information.size := user_job_info_index - 1;

    #CALLER_ID (caller_id);
    IF ((caller_id.ring = osc$tsrv_ring) OR (jmp$system_job ())) THEN
      PUSH job_submit_options: [1 .. 8];
      job_submit_options^ [1].key := jmc$origin_application_name;
      job_submit_options^ [1].origin_application_name := nfv$nam_application_names [application];
      job_submit_options^ [2].key := jmc$immediate_init_candidate;
      job_submit_options^ [2].immediate_init_candidate := TRUE;
      job_submit_options^ [3].key := jmc$omit_class_validation;
      job_submit_options^ [3].omit_class_validation := FALSE;
      job_submit_options^ [4].key := jmc$user_job_name;
      job_submit_options^ [4].user_job_name (1, 5) := 'PTFS_';
      job_submit_options^ [4].user_job_name (6, * ) :=
            application_number_string.value (1, application_number_string.size);
      job_submit_options^ [5].key := jmc$job_class;
      job_submit_options^ [5].job_class := 'FILE_TRANSFER';
      IF remote_ring.specified THEN
        job_submit_options^ [6].key := jmc$job_execution_ring;
        job_submit_options^ [6].job_execution_ring := remote_ring.value;
      ELSE
        job_submit_options^ [6].key := jmc$null_attribute;
      IFEND;
      job_submit_options^ [7].key := jmc$job_input_device;
      job_submit_options^ [7].job_input_device := ^user_job_information;
      job_submit_options^ [8].key := jmc$job_destination_usage;
      job_submit_options^ [8].job_destination_usage := jmc$ve_local_usage;
    ELSE {** KLUDGE for debugging, can run without system priviledge **}
      PUSH job_submit_options: [1 .. 3];
      job_submit_options^ [1].key := jmc$user_job_name;
      job_submit_options^ [1].user_job_name (1, 5) := 'PTFS_';
      job_submit_options^ [1].user_job_name (6, * ) :=
            application_number_string.value (1, application_number_string.size);
      job_submit_options^ [2].key := jmc$job_input_device;
      job_submit_options^ [2].job_input_device := ^user_job_information;
      job_submit_options^ [3].key := jmc$job_destination_usage;
      job_submit_options^ [3].job_destination_usage := jmc$ve_local_usage;
    IFEND;
    jmp$submit_job (file_name, job_submit_options, initiated_job_system_name, status);
    IF nfc$trace_commands THEN
      pmp$log ('PTF JOB gen task, submit status = ', trace_status);
      nfp$format_message_to_job_log (status);
    IFEND;

  PROCEND ptfs_submit_user_job;
?? OLDTITLE ??
?? NEWTITLE := 'ptfs_write_user_text', EJECT ??

  PROCEDURE ptfs_write_user_text
    (    job_file_id: amt$file_identifier;
         directive_list: nft$directive_entry_list_head;
     VAR status: ost$status);

{
{ Procedure  ptfs_write_user_text
{
{ Purpose    This routine writes all of the user text directives specified
{            on a list to the specified job file.
{
{ Description
{            Each directive is written into the file until the list
{            is exhausted.  Any file write error causes the procedure
{            to return.
{
{ Input parameters
{            Job_file_id          : Id of file to write directives to
{            Directive_list       : List head for directives
{
{ Output parameters
{            Status               : Return status, any from:
{                                        amp$put_next
{
{ Algorithm
{            While directives do
{              Write directive
{              If error, return
{              Next directive
{            Whilend
{
?? EJECT ??

    VAR
      byte_address: amt$file_byte_address,
      current_pointer: ^nft$directive_entry;


    status.normal := TRUE;
    current_pointer := directive_list.head;
    WHILE current_pointer <> NIL DO
      amp$put_next (job_file_id, ^current_pointer^.line, STRLENGTH (current_pointer^.line), byte_address,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      current_pointer := current_pointer^.link;
    WHILEND;

  PROCEND ptfs_write_user_text;
?? OLDTITLE ??
?? NEWTITLE := 'ptfs_enqueue_directive', EJECT ??

  PROCEDURE ptfs_enqueue_directive
    (    parameter: string ( * <= nfc$max_param_size);
     VAR directive_list: nft$directive_entry_list_head;
     VAR status: ost$status);

{
{ Procedure ptfs_enqueue_directive
{
{ Purpose    This routine enqueues a directive entry onto a linked list.
{
{ Description
{            The routine that cracks the embedded PDU(s) for
{            nfp$ptfs_job_generation_task calls this procedure to put
{            each directive on a linked list.  When PDU processing is
{            complete, this list will be written into the user job.
{
{ Input parameters
{            Parameter            : Directive to be queued
{
{ Output parameters
{            Directive_list       : List head for directives
{            Status               : Return status
{
{ Algorithm
{            Allocate directive
{            Enqueue directive
{
?? EJECT ??

    VAR
      current_entry: ^nft$directive_entry;

{}
    status.normal := TRUE;
    ALLOCATE current_entry: [#SIZE (nft$directive_entry: [#SIZE (parameter)])];
    IF current_entry = NIL THEN
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'ptfs_enqueue_directive no - vm',
            status);
      RETURN;
    IFEND;
    current_entry^.link := NIL;
    current_entry^.line := parameter;
    IF directive_list.head = NIL THEN
      directive_list.head := current_entry;
    ELSE
      directive_list.tail^.link := current_entry
    IFEND;
    directive_list.tail := current_entry;
{}
  PROCEND ptfs_enqueue_directive;
?? OLDTITLE ??
?? NEWTITLE := 'get_recovery_text', EJECT ??

  PROCEDURE get_recovery_text
    (VAR directives: ^nft$directive_entry;
     VAR status: ost$status);

{
{ Procedure  get_recovery_text
{
{ Purpose    To read the recovery text record out of the job stream.
{
{ Description
{            The job stream file must have been prepared above with
{            clp$push_input.  The first available record is
{            read, and queued onto a directive list.
{
{ Input parameters
{            None
{
{ Output parameters
{            Directives           : a directive list which the recovery
{                                   text is placed on
{            Status               : return status
{
{ Algorithm
{            clp$get_line_from_command_file
{            if success then
{              allocate      directive_entry
{              enqueue directive_entry on list
{            ifend
{
?? EJECT ??

    VAR
      current_entry: ^nft$directive_entry,
      element: ^nft$directive_entry,
      line: ^clt$command_line;

{}
    status.normal := TRUE;
    clp$get_line_from_command_file ('', line, status);
    IF status.normal THEN
      ALLOCATE current_entry: [#SIZE (nft$directive_entry: [#SIZE (line^)])];
      current_entry^.line := line^;
      current_entry^.link := NIL;
      IF directives = NIL THEN
        directives := current_entry;
      ELSE
        element := directives;
        WHILE element^.link <> NIL DO
          element := element^.link;
        WHILEND;
        element^.link := current_entry;
      IFEND;
    IFEND;
{}
  PROCEND get_recovery_text;
?? OLDTITLE ??
?? NEWTITLE := 'crack_embedded_rfts', EJECT ??

  PROCEDURE crack_embedded_rfts
    (VAR nfv$control_block: nft$control_block;
     VAR status: ost$status);

{
{ Procedure  crack_embedded_rfts
{
{ Purpose    To read text written into the job stream which represents the
{            contents of the RFT(s) which started this job.  The information
{            represented by the RFT(s) is placed into the control block.
{
{ Description
{            The job stream file must have been prepared above with
{            clp$push_input.  The first available record is
{            the begining of the first RFT.  The RFT(s) are broken into
{            lines (because job files may contain records no longer than
{            256 characters).  RFT lines begin with the character ', and
{            delimiter lines (indicating end of RFT or end of RFT(s)) begin
{            with *.  As an RFT is read, it is built into a text string
{            which is processed when the RFT is complete.
{
{ Input parameters
{            None
{
{ Input/output parameters
{            Control_block        : Transfer control block
{
{ Output parameters
{            Status               : Return status any of
{                                   returned by
{                                        nfp$crack_command
{                                        nfp$crack_number_of_parameters
{                                        nfp$crack_pdu
{
{ Algorithm
{            Loop until end of commands
{              Read line
{              if line is not delimiter then
{                add line to present command
{              else
{                if line is buffer  delimiter then
{                  crack command
{                else if line is command delimiter then
{                  end of commands = true
{                else error
{              ifend
{            loopend
{
?? EJECT ??

    VAR
      buffer_length: integer,
      done: boolean,
      ignored_params: nft$parameter_set,
      input_buffer: string (nfc$command_buffer_size),
      input_pointer: integer,
      line: ^clt$command_line,
      line_length: integer,
      modified_params: nft$parameter_set,
      more_command_blocks: boolean,
      number_of_parameters: nft$number_pdu_param_range,
      pdu_done: boolean,
      pdu_parameters: nft$parameter_set,
      received_command: nft$protocol_commands,
      trace_length: integer,
      trace_line_width: integer,
      trace_pointer: integer,
      trace_status: ost$status,
      trace_string: string (24);

   VAR
      nfv$rft_parameter_set: [XREF] nft$parameter_set;
{}
    status.normal := TRUE;
    done := FALSE;
    nfv$rft_parameter_set := $nft$parameter_set [];
    REPEAT
      input_pointer := 1;
      pdu_done := FALSE;
      REPEAT
        clp$get_line_from_command_file ('', line, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        line_length := STRLENGTH (line^);
        IF line^ (1) <> nfc$ptfs_job_delimiter THEN
          IF (line_length > nfc$command_buffer_size) OR (line_length <
                nfc$ptfs_job_line_head_len + nfc$ptfs_job_line_tail_len) THEN
            osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
                  'crack_embedded_rfts line size', status);
            RETURN;
          IFEND;
          line_length := (line_length - nfc$ptfs_job_line_head_len) - nfc$ptfs_job_line_tail_len;
          input_buffer (input_pointer, line_length) := line^ (2, line_length);
          input_pointer := input_pointer + line_length;
        ELSE
          IF line^ = nfc$ptfs_job_end_buffer THEN
            pdu_done := TRUE;
            buffer_length := input_pointer - 1;
            IF buffer_length < (nfc$pdu_nparams_pos + nfc$pdu_nparams_len - 1) THEN
              osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'NFP$CRACK_EMBEDDED_RFTS',
                    status);
              RETURN;
            IFEND;
            IF nfc$trace_commands THEN
              pmp$log ('------------------------', trace_status);
              pmp$log ('|    Receive command   |', trace_status);
              STRINGREP (trace_string, trace_length, '|    Length ', buffer_length: 5, '      |');
              pmp$log (trace_string, trace_status);
              pmp$log ('------------------------', trace_status);
              IF buffer_length > 0 THEN
                trace_pointer := 1;
                WHILE trace_pointer <= buffer_length DO
                  IF ((buffer_length - trace_pointer) >= nfc$trace_commands_width) THEN
                    trace_line_width := nfc$trace_commands_width;
                  ELSE
                    trace_line_width := buffer_length - trace_pointer + 1;
                  IFEND;
                  pmp$log (input_buffer (trace_pointer, trace_line_width), trace_status);
                  trace_pointer := trace_pointer + nfc$trace_commands_width;
                WHILEND;
              IFEND;
              pmp$log ('--------------------', trace_status);
            IFEND;
            nfp$crack_command (input_buffer (1, nfc$pdu_command_len), received_command, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            nfp$crack_number_of_parameters (input_buffer (nfc$pdu_nparams_pos, nfc$pdu_nparams_len),
                  number_of_parameters, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            nfp$crack_pdu (nfc$rft, input_buffer, number_of_parameters, more_command_blocks, pdu_parameters,
                  ignored_params, modified_params, nfv$control_block, status);
            IF NOT status.normal THEN
              RETURN;
            ELSE
              nfv$rft_parameter_set := nfv$rft_parameter_set + pdu_parameters;
            IFEND;
          ELSE {** should be end of pdu information in job **}
            IF line^ <> '*EOC' THEN
              osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
                    'crack_embedded_rfts invalid eoc', status);
              RETURN;
            ELSE
              done := TRUE;
              pdu_done := TRUE;
            IFEND;
          IFEND;
        IFEND;
      UNTIL pdu_done;
    UNTIL done;
    IF NOT (nfv$ptf_required_params [nfc$rft] <= nfv$rft_parameter_set) THEN
      osp$set_status_abnormal (nfc$status_id, nfe$required_parameter_missing, '', status);
      nfp$set_abnormal_if_normal (status, nfv$control_block.local_status);
    ELSE
      IF NOT (nfc$max_block_size IN nfv$rft_parameter_set) THEN
        CASE nfv$control_block.data_declaration OF
        = nfc$p31_host_dependent_uh =
          { No change, defaults set in init cb o.k. }
        = nfc$p31_ascii_c6, nfc$p31_ascii_c8, nfc$p31_unspecified =
          nfv$control_block.data_block_size := nfc$p12_nos_ascii_size;
        = nfc$p31_undef_unstructured_uu, nfc$p31_undefined_structured_us =
          nfv$control_block.data_block_size := nfc$p12_nos_binary_size;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
                'crack_embedded_rfts P31 case error', status);
        CASEND;
      IFEND;
    IFEND;

  PROCEND crack_embedded_rfts;
?? OLDTITLE ??
?? NEWTITLE := 'global variables', EJECT ??

{ PURPOSE:
{   This module contains procedures for the server application (PTFS)
{   in a remote permanent file access/transfer.  The server application
{   performs the functions on the remote system.

{ PROCEDURE ptfs_pdt (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [89, 5, 17, 11, 2, 57, 744],
    clc$command, 1, 1, 0, 0, 0, 0, 1, ''], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

{ table ptfs_commands
{ command (send_file, senf) send_file_command
{ command (receive_file, recf) receive_file_command

?? OLDTITLE ??
?? NEWTITLE := 'get_job_log', EJECT ??

{ PURPOSE:
{   This procedure will read the job log of the server job (this job).  The job log is
{   sent back to the initiator with the STOPR message.

  PROCEDURE get_job_log
    (VAR log_entry_ptr: ^nft$directive_entry;
     VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      directive_line: ost$string,
      file_position: amt$file_position,
      ignore_status: ost$status,
      log_attach_options: ^fst$attachment_options,
      log_file_id: amt$file_identifier,
      transfer_count: amt$transfer_count,
      user_log_ptr: ^nft$directive_entry;

    status.normal := TRUE;
    log_entry_ptr := NIL;
    user_log_ptr := NIL;

    PUSH log_attach_options: [1 .. 3];
    log_attach_options^ [1].selector := fsc$open_position;
    log_attach_options^ [1].open_position := amc$open_at_boi;
    log_attach_options^ [2].selector := fsc$access_and_share_modes;
    log_attach_options^ [2].access_modes.selector := fsc$specific_access_modes;
    log_attach_options^ [2].access_modes.value := $fst$file_access_options [fsc$read];
    log_attach_options^ [2].share_modes.selector := fsc$specific_share_modes;
    log_attach_options^ [2].share_modes.value := $fst$file_access_options
          [fsc$read, fsc$append, fsc$modify, fsc$execute];
    log_attach_options^ [3].selector := fsc$open_share_modes;
    log_attach_options^ [3].open_share_modes := $fst$file_access_options
          [fsc$read, fsc$append, fsc$modify, fsc$execute];

    fsp$open_file (clc$job_log, amc$record, log_attach_options, NIL, NIL, NIL, NIL, log_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /dump_job_log/
    WHILE status.normal DO
      amp$get_next (log_file_id, ^directive_line.value, osc$max_string_size, transfer_count, byte_address,
            file_position, status);
      IF (NOT status.normal) OR (file_position = amc$eoi) THEN
        EXIT /dump_job_log/;
      IFEND;

{ Link a string onto a link list of user log lines.

      directive_line.size := transfer_count;
      IF log_entry_ptr = NIL THEN
        ALLOCATE log_entry_ptr: [directive_line.size];
        IF log_entry_ptr = NIL THEN
          osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'link_log_entry get_job_log',
                status);
        ELSE
          user_log_ptr := log_entry_ptr;
        IFEND;
      ELSE
        ALLOCATE log_entry_ptr^.link: [directive_line.size];
        IF log_entry_ptr^.link = NIL THEN
          osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'link_log_entry get_job_log',
                status);
        ELSE
          log_entry_ptr := log_entry_ptr^.link;
        IFEND;
      IFEND;
      IF status.normal THEN
        log_entry_ptr^.link := NIL;
        log_entry_ptr^.line := directive_line.value (1, directive_line.size);
      IFEND;

    WHILEND /dump_job_log/;

    amp$close (log_file_id, ignore_status);
    log_entry_ptr := user_log_ptr;

  PROCEND get_job_log;
?? OLDTITLE ??
?? NEWTITLE := 'receive_file_command', EJECT ??

{ PURPOSE:
{   This procedure is responsible for setting up a data transfer
{   involving PTFS receiving a file from PTF.  By ensuring the
{   file is destined for a correct device, responding in protocol
{   (RPOS) or (RNEG).  If the device is correct, and RPOS is sent,
{   a GO must be received.

  PROCEDURE receive_file_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE receive_file_pdt (
{   file, f: file = $REQUIRED
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 17, 11, 2, 32, 227],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      nfv$control_block: [XREF] nft$control_block;

    VAR
      nfv$p04_values: [XREF] nft$parameter_04_values;

    VAR
      device_assigned: boolean,
      device_class: rmt$device_class,
      file_reference: fst$evaluated_file_reference,
      ignore_status: ost$status,
      ignored_params: nft$parameter_set,
      modified_params: nft$parameter_set,
      path_handle: fst$path_handle_name,
      received_params: nft$parameter_set,
      rpos_parameters: nft$parameter_set,
      trace_string: string (80),
      trace_string_length: integer,
      trace_status: ost$status;

    status.normal := TRUE;
    IF nfc$trace_commands THEN
      pmp$log ('Enter ptfs - receive_file_command', ignore_status);
    IFEND;
    IF nfv$control_block.data_xfer_complete THEN
      osp$set_status_abnormal (nfc$status_id, nfe$multiple_file_transfers, '', status);
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rmp$get_device_class (pvt [p$file].value^.file_value^, device_assigned, device_class, status);
    IF device_assigned AND (device_class <> rmc$mass_storage_device) AND
          (device_class <> rmc$null_device) THEN
      osp$set_status_abnormal (nfc$status_id, nfv$p04_values [nfc$p04_no_file_access].condition, '',
            nfv$control_block.state_of_transfer);
      osp$set_status_abnormal (nfc$status_id, nfe$remote_file_not_ms, pvt [p$file].value^.file_value^,
            status);
      RETURN;
    IFEND;

    clp$convert_str_to_path_handle(pvt [p$file].value^.file_value^, FALSE, TRUE, TRUE,
     path_handle, file_reference, status);

    IF (NOT device_assigned) AND ((file_reference.cycle_reference.specification = fsc$high_cycle) OR
          (file_reference.cycle_reference.specification = fsc$low_cycle)) THEN

{ The file to be received does not exist and a cycle reference of "$HIGH" or "$LOW" was specified on
{ the call to the RECEIVE_FILE command. Cause the command to abort with the same status as the COPY_FILE
{ command would given the same parameters.

      osp$set_status_abnormal(amc$access_method_id, ame$file_not_known, pvt [p$file].value^.file_value^,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'FSP$OPEN_FILE', status);

    ELSE

      nfv$control_block.file_name :=path_handle;
      nfv$control_block.mode_of_access := nfc$take;
      ptfs_parameters_for_rpos (rpos_parameters, nfv$control_block, status);
      IF status.normal THEN
        rpos_parameters := rpos_parameters - nfv$control_block.last_auto_modify_ignore;
        send_rpos ( rpos_parameters, nfv$rft_parameter_set, nfv$control_block,
          status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        nfp$receive_command ($nft$command_set [nfc$go, nfc$stop], nfv$ptf_required_params, nfv$control_block,
              received_params, ignored_params, modified_params, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF nfv$control_block.last_command_received = nfc$go THEN
          nfp$transfer_file (nfv$control_block, status);

  { Try to catch ANY transfer error returning bad status up so SCL command stream will terminate

          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF NOT nfv$control_block.state_of_transfer.normal THEN
            nfp$set_abnormal_if_normal (nfv$control_block.state_of_transfer, status);
            RETURN;
          IFEND;
          IF NOT nfv$control_block.local_status.normal THEN
            nfp$set_abnormal_if_normal (nfv$control_block.local_status, status);
            RETURN;
          IFEND;
        IFEND;
        nfv$control_block.data_xfer_complete := TRUE;
      IFEND;
    IFEND;
    IF nfc$trace_commands THEN
      pmp$log ('Exit ptfs - receive_file_command', ignore_status);
    IFEND;

  PROCEND receive_file_command;
?? OLDTITLE ??
?? NEWTITLE := 'send_file_command', EJECT ??

{ PURPOSE:
{   This procedure is responsible for setting up a data transfer involving PTFS
{   by sending the specified file to PTF.  The file must exist and have a
{   non-zero length.  Checking is done to ensure that the file exists and is
{   accessable.
{
{ NOTE:
{   This procedure does not send an RNEG ever, rather it sets a bad status
{   which SCL will pick up.

  PROCEDURE send_file_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE send_file_pdt (
{   file, f: file = $REQUIRED
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 17, 11, 2, 48, 164],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      attributes: array [1 .. 1] of amt$get_item,
      nfv$control_block: [XREF] nft$control_block,
      device_assigned: boolean,
      device_class: rmt$device_class,
      file_attachment_options: ^fst$attachment_options,
      file_exists: boolean,
      file_id: amt$file_identifier,
      ignore_connection_time: ost$date_time,
      ignore_file_is_local: boolean,
      ignore_file_contains_data: boolean,
      ignore_file_ref: fst$evaluated_file_reference,
      ignore_status: ost$status,
      ignored_params: nft$parameter_set,
      ignore_retrieve_option: boolean,
      modified_params: nft$parameter_set,
      path_handle: fst$path_handle_name,
      received_params: nft$parameter_set,
      report_file_archived: boolean,
      rpos_parameters: nft$parameter_set;


    status.normal := TRUE;
    IF nfc$trace_commands THEN
      pmp$log ('Enter ptfs - send_file_command', ignore_status);
    IFEND;
    IF nfv$control_block.data_xfer_complete THEN
      osp$set_status_abnormal (nfc$status_id, nfe$multiple_file_transfers, '', status);
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rmp$get_device_class (pvt [p$file].value^.file_value^, device_assigned, device_class, status);
    IF device_assigned AND (device_class <> rmc$mass_storage_device) AND
          (device_class <> rmc$null_device) THEN
      osp$set_status_abnormal (nfc$status_id, nfe$remote_file_not_ms, pvt [p$file].value^.file_value^,
            status);
      RETURN;
    IFEND;

    attributes [1].key := amc$file_length;
    amp$get_file_attributes (pvt [p$file].value^.file_value^, attributes, ignore_file_is_local, file_exists,
          ignore_file_contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF file_exists THEN

{ Convert the string into a path handle and place the value in the control block so
{ that the value is known outside of send_file. NFP$PTFS_USER_JOB will use this
{ value to retrieve the file if PTFS is to report the file is archived and retrieve.

      clp$convert_str_to_path_handle(pvt [p$file].value^.file_value^, FALSE, TRUE, TRUE,
         path_handle, ignore_file_ref, status);
      IF NOT status.normal THEN
        pmp$log('***PTFS could not convert the file name to a path handle.', ignore_status);
        RETURN;
      IFEND;
      nfv$control_block.file_name := path_handle;

      IF attributes [1].file_length <> 0 THEN
        nfv$control_block.file_size := attributes [1].file_length;

{ Check if the file is archived by calling fsp$open_file with no allowed exception conditions.

        PUSH file_attachment_options: [1..3];

        file_attachment_options^[1].selector := fsc$create_file;
        file_attachment_options^[1].create_file := FALSE;

        file_attachment_options^[2].selector := fsc$allowed_exceptions;
        file_attachment_options^[2].allowed_exceptions.access_conditions := $fst$file_access_conditions [ ];
        file_attachment_options^[2].allowed_exceptions.damage_symptoms := $fst$cycle_damage_symptoms [ ];

        file_attachment_options^ [3].selector := fsc$access_and_share_modes;
        file_attachment_options^ [3].access_modes.selector := fsc$specific_access_modes;
        file_attachment_options^ [3].access_modes.value := $fst$file_access_options [fsc$read];
        file_attachment_options^ [3].share_modes.selector := fsc$determine_from_access_modes;

        fsp$open_file (path_handle, amc$record, file_attachment_options, NIL, NIL,
              NIL, NIL, file_id, status);

        IF NOT status.normal THEN
          consult_archive_response_var (report_file_archived, ignore_retrieve_option);
          IF (status.condition = pfe$cycle_data_resides_offline) AND (report_file_archived) THEN

{ Cause the server to RNEG the RFT by setting the state of transfer to REJECTED. Include the status
{ from the FSP$OPEN_FILE call in the job log to further explain the cause of the rejection.

            osp$set_status_abnormal (nfc$status_id, nfv$p04_values [nfc$p04_file_unavailable].condition, '',
                nfv$control_block.state_of_transfer);
            nfp$format_message_to_job_log(status);
            osp$set_status_abnormal (nfc$status_id, nfv$p04_values [nfc$p04_file_unavailable].condition, '',
                nfv$control_block.local_status);
            IF (nfv$control_block.remote_host_type = nfc$p22_nos_ve) AND
               (NOT nfv$control_block.state_of_transfer.normal) THEN
              ptfs_send_status_parameter (nfv$control_block.state_of_transfer,
                nfv$control_block.send_special_options, ignore_status);
            IFEND;
            RETURN;
          IFEND;
        ELSE { fsp$open did not return an abnormal status.
          fsp$close_file(file_id, ignore_status);
        IFEND;

      ELSE
        osp$set_status_abnormal (nfc$status_id, fse$empty_input_file, pvt [p$file].value^.file_value^,
              status);
        RETURN;
      IFEND;
    ELSE { ** no file, find out why ** }
      osp$set_status_abnormal (nfc$status_id, nfv$p04_values [nfc$p04_file_not_found].condition, '',
            nfv$control_block.state_of_transfer);
      PUSH file_attachment_options: [1 .. 1];
      file_attachment_options^ [1].selector := fsc$create_file;
      file_attachment_options^ [1].create_file := FALSE;
      fsp$open_file (pvt [p$file].value^.file_value^, amc$record, file_attachment_options, NIL, NIL, NIL, NIL,
            file_id, status);
      RETURN;
    IFEND;

    nfv$control_block.mode_of_access := nfc$give;
    ptfs_parameters_for_rpos (rpos_parameters, nfv$control_block, status);
    IF status.normal THEN
      rpos_parameters := rpos_parameters - nfv$control_block.last_auto_modify_ignore;
      send_rpos ( rpos_parameters, nfv$rft_parameter_set,
         nfv$control_block, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      nfp$receive_command ($nft$command_set [nfc$go, nfc$stop], nfv$ptf_required_params, nfv$control_block,
            received_params, ignored_params, modified_params, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF nfv$control_block.last_command_received = nfc$go THEN
        nfp$transfer_file (nfv$control_block, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF NOT nfv$control_block.state_of_transfer.normal THEN
          nfp$set_abnormal_if_normal (nfv$control_block.state_of_transfer, status);
        IFEND;
      IFEND;
      nfv$control_block.data_xfer_complete := TRUE;
    IFEND;

    IF nfc$trace_commands THEN
      pmp$log ('Exit ptfs - send_file_command', ignore_status);
    IFEND;

  PROCEND send_file_command;
?? OLDTITLE ??
?? NEWTITLE := 'ptfs_process_protocol', EJECT ??

{ PURPOSE:
{   This procedure will be to process the protocol for PTFS.  It must
{   determine where it is in the A-A protocol and continue from that point.
{   If a file transfer has occurred it will begin by receiveing a STOP request.
{   If no transfer has occured and the status is good (SCL was happy with all
{   the user text) the procedure will begin by sending a RPOS request with a NULL
{   mode of access.  Otherwise an error has occurred in user SCL begin by sending
{   a RNEG request.
{
{ NOTE:
{   This is also where we would receive a second (non-continued) RFT on
{   this connection.  This procedure must handle this case by building
{   another command file and execute it.

  PROCEDURE ptfs_process_protocol
    (    accept_rfts: boolean;
         caller_identifier: caller_identifier;
     VAR nfv$control_block: nft$control_block;
     VAR begin_connection_time: ost$date_time;
     VAR status: ost$status);

    VAR
      directive_list: nft$directive_entry_list_head,
      done: boolean,
      end_connection_time: ost$date_time,
      ignore_status: ost$status,
      ignored_params: nft$parameter_set,
      modified_params: nft$parameter_set,
      parameter_set: nft$parameter_set,
      received_params: nft$parameter_set,
      rpos_parameters: nft$parameter_set,
      send_parameters: nft$parameter_set;

   VAR
      nfv$rft_parameter_set: [STATIC,XREF] nft$parameter_set;

    status.normal := TRUE;
    done := FALSE;

    WHILE NOT done DO
      IF nfv$control_block.path.path_connected THEN
        CASE nfv$control_block.last_command_received OF

        = nfc$rft =
          IF accept_rfts AND (nfv$control_block.last_command_sent = nfc$stopr) THEN

{ Go build a new command file

            ptfs_process_another_rft (begin_connection_time, nfv$control_block, status);
            IF NOT status.normal THEN
              nfp$set_abnormal_if_normal (status, nfv$control_block.local_status);
            IFEND;
          ELSEIF nfv$control_block.last_command_sent = nfc$rpos THEN
              nfp$receive_command ($nft$command_set [nfc$go, nfc$stop], nfv$ptf_required_params,
                    nfv$control_block, received_params, ignored_params, modified_params, status);
          ELSEIF nfv$control_block.last_command_sent = nfc$rneg THEN
              nfp$receive_command ($nft$command_set [nfc$stop], nfv$ptf_required_params, nfv$control_block,
                    received_params, ignored_params, modified_params, status);
          ELSE
            IF (NOT nfv$control_block.local_status.normal) OR (NOT nfv$control_block.state_of_transfer.normal)
               OR (NOT accept_rfts) THEN

{ Send RNEG with bad State of Transfer

              send_parameters := $nft$parameter_set [nfc$state_of_transfer];
              IF nfv$control_block.remote_host_type = nfc$p22_nos_ve THEN
                send_parameters := send_parameters + $nft$parameter_set [nfc$host_type];
              IFEND;

              send_rneg (send_parameters, nfv$rft_parameter_set, nfv$control_block, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              nfp$receive_command ($nft$command_set [nfc$stop], nfv$ptf_required_params, nfv$control_block,
                    received_params, ignored_params, modified_params, status);
            ELSE

{ Send RPOS with good State of Transfer and mode of access=null

              rpos_parameters := $nft$parameter_set [nfc$protocol_id, nfc$mode_of_access, nfc$host_type,
                    nfc$job_name, nfc$physical_id] - nfv$control_block.last_auto_modify_ignore;
              send_rpos (rpos_parameters, nfv$rft_parameter_set, nfv$control_block, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              nfp$receive_command ($nft$command_set [nfc$go, nfc$stop], nfv$ptf_required_params,
                    nfv$control_block, received_params, ignored_params, modified_params, status);
            IFEND;

            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

        = nfc$go =
            nfp$receive_command ($nft$command_set [nfc$stop], nfv$ptf_required_params, nfv$control_block,
                  received_params, ignored_params, modified_params, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

        = nfc$stop =
          IF nfv$control_block.last_command_sent <> nfc$stopr THEN

            CASE caller_identifier OF
            = user_ptfs_job_call, user_ptfs_job_logout =

{ Try to send back job log from user ptfs job.

                get_job_log (nfv$control_block.send_user_messages, status);
                IF NOT status.normal THEN
                  directive_list.head := NIL;
                  directive_list.tail := NIL;
                  nfp$enqueue_status_directive (status, directive_list, status);
                  nfv$control_block.send_user_messages := directive_list.head;
                IFEND;

            = ptfs_job_generation_task, ptfs_scan_scl_handler_id =

{ The user ptfs job failed and did not call ptfs_process_protocol, therefore the user ptfs job
{ log is not available. Send the send status back as a string instead.

                IF (nfv$control_block.remote_host_type = nfc$p22_nos_ve) AND
                   (NOT nfv$control_block.local_status.normal) THEN
                  ptfs_send_status_parameter (nfv$control_block.local_status,
                    nfv$control_block.send_special_options, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;
                  send_parameters := send_parameters + $nft$parameter_set [nfc$special_options];
                IFEND;

                directive_list.head := NIL;
                directive_list.tail := NIL;
                nfp$enqueue_status_directive (nfv$control_block.local_status, directive_list, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                nfv$control_block.send_user_messages := directive_list.head;
            CASEND;

            parameter_set := $nft$parameter_set [nfc$state_of_transfer, nfc$user_message];
            IF (NOT nfv$control_block.local_status.normal) AND (nfv$control_block.remote_host_type =
                  nfc$p22_nos_ve) THEN
              ptfs_send_status_parameter (nfv$control_block.local_status, nfv$control_block.
                    send_special_options, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              parameter_set := parameter_set + $nft$parameter_set [nfc$special_options];
            IFEND;

            IF NOT nfv$control_block.recovery_text THEN
              parameter_set := parameter_set + $nft$parameter_set [nfc$user_text_directive];
              nfv$control_block.recovery_text := TRUE;
            IFEND;

            nfp$send_command (nfc$stopr, parameter_set, $nft$parameter_set[ ], $nft$parameter_set[ ],
                   nfv$control_block, status);
            IF status.normal THEN
              nfp$dequeue_directives_on_list (nfv$control_block.send_user_messages, ignore_status);
            ELSE
              RETURN;
            IFEND;

            IF nfv$control_block.state_of_transfer.normal AND nfv$control_block.local_status.normal THEN

{ Account for bytes sent back in job log

              nfv$control_block.transfer_directives_length := nfv$control_block.transfer_directives_length +
                   nfp$count_directives_text (nfv$control_block.send_user_messages);

{ Get connection end time

              pmp$get_compact_date_time (end_connection_time, status);
              IF NOT status.normal THEN
                nfp$format_message_to_job_log(status);
                RETURN;
              ELSE
                nfp$generate_ptf_statistic (begin_connection_time, end_connection_time, nfv$control_block.
                   transfer_file_size, nfv$control_block.transfer_directives_length, nfv$control_block.
                   remote_lid (1,nfv$control_block.remote_lid_length), nfv$control_block.remote_pid
                   (1,nfv$control_block.remote_pid_length), nfv$control_block.application, nfv$control_block.
                   ptf_scl_directive);
              IFEND;
            IFEND;
            nfv$control_block.mode_of_access := nfc$null;
            nfv$control_block.transfer_file_size := 0;
            nfv$control_block.transfer_directives_length := 0;
            nfv$control_block.ptf_scl_directive.size := 0;
          IFEND;

{ Reset begin connection time in the event another RFT is received

          pmp$get_compact_date_time (begin_connection_time, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          nfp$receive_command ($nft$command_set [nfc$etp, nfc$rft], nfv$ptf_required_params,
                nfv$control_block, nfv$rft_parameter_set, ignored_params, modified_params, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        = nfc$etp =
          IF nfv$control_block.last_command_sent <> nfc$etpr THEN
            nfp$send_command (nfc$etpr, $nft$parameter_set [], $nft$parameter_set[ ], $nft$parameter_set[ ],
                 nfv$control_block, ignore_status);
          IFEND;

          nfp$receive_command ($nft$command_set [nfc$fini], nfv$ptf_required_params, nfv$control_block,
                received_params, ignored_params, modified_params, ignore_status);

        = nfc$fini =
          done := TRUE;

{ Server MUST wait for initiator to disconnect, if he doesn't, this times out.

          nfp$receive_command ($nft$command_set [nfc$unknown_command], nfv$ptf_required_params,
                nfv$control_block, received_params, ignored_params, modified_params, ignore_status);

        ELSE

        CASEND;
      ELSE
        done := TRUE;
      IFEND;
    WHILEND;

  PROCEND ptfs_process_protocol;
?? OLDTITLE ??
?? NEWTITLE := 'ptfs_process_another_rft', EJECT ??

  PROCEDURE ptfs_process_another_rft
    (VAR begin_connection_time: ost$date_time;
     VAR nfv$control_block: nft$control_block;
     VAR status: ost$status);

{
{ Procedure  ptfs_process_another_rft
{
{ Purpose    This routine is called on the 2,3,4, ... th RFT received.
{            It processes the commands for the RFT and returns to its
{            caller to complete protocol.
{
{ Description
{            This routine opens a new file for SCL directives.  The
{            directives are written into the file by
{            ptfs_write_user_text and that file is executed by
{            clp$scan_command_file.
{
{ Input parameters
{            None
{
{ Input/output parameters
{            Control_block        : Transfer control block
{
{ Output parameters
{            Begin_connection_time: Time received RFT
{            Status               : Return status
{
{ Algorithm
{            Open a new file
{            Write directives into file
{            Establish abort handler
{            clp$scan_command_file
{            Remove abort handler
{            Delete command file
{
?? EJECT ??

    VAR
      command_file_id: amt$file_identifier,
      command_file_name: ost$name,
      file_attributes: ^fst$attachment_options,
      ignore_status: ost$status;


{     **Set up the command file to execute **}

    status.normal := TRUE;
    pmp$get_compact_date_time( begin_connection_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_unique_name (command_file_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH file_attributes: [1 .. 1];
    file_attributes^ [1].selector := fsc$open_position;
    file_attributes^ [1].open_position := amc$open_at_boi;
    fsp$open_file (command_file_name, amc$record, file_attributes, NIL, NIL, NIL, NIL, command_file_id,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ptfs_write_user_text (command_file_id, nfv$control_block.received_directives, status);

{   Build accounting stuff associated with directives

    nfv$control_block.transfer_directives_length := nfp$count_directives_text(
           nfv$control_block.received_directives.head);
    IF (nfv$control_block.received_directives.head^.link <> NIL) THEN
      build_05_directives_text( nfv$control_block.received_directives.head^.link,
           nfv$control_block.ptf_scl_directive);
    ELSE
      nfv$control_block.ptf_scl_directive.size := 0;
    IFEND;

    nfp$deallocate_dirs_from_head (nfv$control_block.received_directives, ignore_status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$close_file (command_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   **Execute the command file **}

    nfv$control_block.data_xfer_complete := FALSE;
    ptfs_scan_scl_command_file (command_file_name, TRUE, begin_connection_time, nfv$control_block, status);

    amp$return (command_file_name, ignore_status);

  PROCEND ptfs_process_another_rft;
?? OLDTITLE ??
?? NEWTITLE := '  ptfs_switch_connection', EJECT ??

  PROCEDURE ptfs_switch_connection
    (    initiated_job_name: jmt$system_supplied_name;
     VAR nfv$control_block: nft$control_block;
     VAR switch_state: nft$ptfs_switch_states;
     VAR status: ost$status);

{
{ Procedure  ptfs_switch_connection
{
{ Purpose    To switch a connection from the current to a specified job.
{
{ Description
{            This routine attempts to switch an A-A connection to an
{            initiated user job.  This process takes several steps.
{            First, an offer switch is made with a short (30 second)
{            time out.  If the user job did not complete the switch in that
{            time, this routine checks to see if said job is still around.
{            If the job has terminated (i.e. bad prolog), a status is set
{            indicating switch failed, but the connection is still active.
{            If the job is still around, we offer the switch again, this
{            time with a much longer time out.  If this second offer is
{            not successfull, we attempt to terminate the user job.  This
{            is done to remote it from the job class, where it is wasting
{            space ( a slot ).  Note: the two switch offer method is used
{            to avoid long end user delays when the user job aborts.
{
{ Input parameters
{            Initiated_job_name          : Name of job to switch connection
{                                          to.
{
{ Input/output parameters
{            Control_block        : Transfer control block
{
{ Output parameters
{            Switch_state                : Returned switch/path state
{            Status                      : Returned status
{
{ Algorithm
{            ptfs_switch_it ( short timeout )
{            if success, return
{            else
{              check if job exists
{              if not, return
{              else
{                ptfs_switch_it ( long timeout )
{                if success, return
{                else
{                  terminate job
{                ifend
{              ifend
{            ifend
{
?? EJECT ??

    VAR
      ignore_status: ost$status,
      job_exists: boolean,
      job_name: jmt$name,
      job_termination_options: ^jmt$job_termination_options,
      local_status: ost$status,
      time_out: nft$parameter_20_range;

{}
    status.normal := TRUE;
{}
    time_out := nfc$ptfs_switch_init_time;
    ptfs_switch_it (initiated_job_name, nfv$control_block.path.network_type, time_out,
          nfv$control_block.path.network_file^, status);
    IF NOT status.normal THEN
      IF (status.condition = rfe$switch_offer_not_accepted) OR
            (status.condition = nae$switch_offer_not_accepted) THEN
        {
        { See if job exists
        {
        jmp$job_exists (initiated_job_name, $jmt$job_state_set [jmc$initiated_job, jmc$queued_job],
              job_exists, status);
        IF (NOT status.normal) OR (NOT job_exists) THEN
          ptfs_cancel_offer (nfv$control_block.path.network_file^, nfv$control_block.path.network_type,
                status);
          osp$set_status_abnormal (nfc$status_id, nfe$user_job_term_prematurely, '', status);
          switch_state := nfc$switch_failed_cancelled;
          RETURN; { Job does not exists }
        ELSE
          { Ensure there is time left if switch fails to cancel it and
          { continue with the protocol (safety margin)
          time_out := nfv$control_block.time_out - nfc$ptfs_switch_init_time - nfc$ptfs_switch_term_time;
          ptfs_cancel_offer (nfv$control_block.path.network_file^, nfv$control_block.path.network_type,
                status);
          IF NOT status.normal THEN
            switch_state := nfc$switch_failed_lost;
            RETURN;
          IFEND;
          ptfs_switch_it (initiated_job_name, nfv$control_block.path.network_type, time_out,
                nfv$control_block.path.network_file^, status);
          IF NOT status.normal THEN
            IF (status.condition = rfe$switch_offer_not_accepted) OR
                  (status.condition = nae$switch_offer_not_accepted) THEN
              { Job didn't pick up connect, kill it
              { Because there is lots of overhead to check if job
              { exists, just try to kill it.  This is necessary because
              { if the job is still running, it is taking up a slot
              { in the job class
              job_name.kind := jmc$system_supplied_name;
              job_name.system_supplied_name := initiated_job_name;
              PUSH job_termination_options: [1 .. 2];
              job_termination_options^ [1].key := jmc$job_state_set;
              job_termination_options^ [1].job_state_set := $jmt$job_state_set
                    [jmc$queued_job, jmc$initiated_job];
              job_termination_options^ [2].key := jmc$output_disposition;
              job_termination_options^ [2].output_disposition.key :=
                    jmc$discard_standard_output;
              jmp$terminate_job (job_name, job_termination_options, ignore_status);
              osp$set_status_abnormal (nfc$status_id, nfe$user_job_switch_timeout, '', status);
              ptfs_cancel_offer (nfv$control_block.path.network_file^,
                    nfv$control_block.path.network_type, local_status);
              IF local_status.normal THEN { Cancel success }
                switch_state := nfc$switch_failed_cancelled;
              ELSE { Couldn't cancel, must be lost }
                switch_state := nfc$switch_failed_lost;
              IFEND;
            ELSE { Unknown kind of error, big trouble }
              switch_state := nfc$switch_failed_lost;
              RETURN;
            IFEND;
          ELSE { Success on switch }
            switch_state := nfc$switch_complete;
          IFEND;
        IFEND;
      ELSE { Unknown error, big trouble, terminate path }
        switch_state := nfc$switch_failed_lost;
      IFEND;
    ELSE
      switch_state := nfc$switch_complete;
    IFEND;
{}
  PROCEND ptfs_switch_connection;
?? OLDTITLE ??
?? NEWTITLE := 'ptfs_switch_it', EJECT ??

  PROCEDURE ptfs_switch_it
    (    initiated_job_system_name: jmt$system_supplied_name;
         network_type: nft$network_type;
         time_out: nft$parameter_20_range;
         network_file: fst$file_reference;
     VAR status: ost$status);

{
{ Procedure  ptfs_switch_it
{
{ Purpose    To offer a connect switch to another job.
{
{ Description
{            This routine is simply a short hand way of offering a connection
{            switch to another job via RHFAM or NAM.
{
{ Input parameters
{            initiated_job_system_name   : Who you want to switch to
{            network_type                : RHFAM (LCN) or NAM
{            time_out                    : Length of switch offer
{            network_file                : Name of network path
{
{ Output parameters
{            status                      : Return status
{
{ Algorithm
{            Case network type
{            -nam- nap$offer_connection_switch
{            -lcn- rfp$offer_connection_switch
{
?? EJECT ??
{}
    status.normal := TRUE;
    CASE network_type OF
    = nfc$network_nam =
      nap$offer_connection_switch (network_file, initiated_job_system_name, time_out * nfc$milliseconds,
            status);
    = nfc$network_lcn =
      rfp$offer_connection_switch (network_file, initiated_job_system_name, time_out * nfc$milliseconds,
            status);
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'ptfs_switch_it, case error',
            status);
      nfp$format_message_to_job_log (status);
      RETURN;
    CASEND;
  PROCEND ptfs_switch_it;
?? OLDTITLE ??
?? NEWTITLE := 'ptfs_cancel_offer', EJECT ??

  PROCEDURE ptfs_cancel_offer
    (    network_file: fst$file_reference;
         network_type: nft$network_type;
     VAR status: ost$status);

{
{ Procedure  ptfs_cancel_offer
{
{ Purpose    This routine is a short hand way of cancelling a connection
{            switch offer to RHFAM or NAM.
{
{ Description
{            The appropriate cancel switch offer routine is called for the
{            network type.
{
{ Input parameters
{            network_file         : Path name of network file
{            network_type         : NAM or RHFAM (LCN)
{
{ Output parameters
{            status               : Return status
{
{ Algorithm
{            Case network type of
{            -nam- nap$cancel_switch_offer
{            -lcn- rfp$cancel_switch_offer
{            Casend
{
?? EJECT ??
{}
    status.normal := TRUE;
    CASE network_type OF
    = nfc$network_lcn =
      rfp$cancel_switch_offer (network_file, status);
    = nfc$network_nam =
      nap$cancel_switch_offer (network_file, status);
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'ptfs_cancel_offer, case error',
            status);
      nfp$format_message_to_job_log (status);
      RETURN;
    CASEND;
{}
  PROCEND ptfs_cancel_offer;
?? OLDTITLE ??
?? TITLE := 'ptfs_parameters_for_rpos', EJECT ??

  PROCEDURE ptfs_parameters_for_rpos
    (VAR rpos_parameters: nft$parameter_set;
     VAR nfv$control_block: nft$control_block;
     VAR status: ost$status);

{
{ Procedure  ptfs_parameters_for_rpos
{
{ Purpose    This routine takes information from the RFT command and sets
{            up additional RPOS parameters for PTFS.
{
{ Description
{            Several checks are made here which are important in NOS/VE to
{            NOS/VE transfers.  First, the data declaration UH can only
{            be used in NOS/VE to NOS/VE transfers.  Attempts made by other
{            host types to use UH should be RNEGed.  Second, NOS/VE to NOS/VE
{            transfers should always use type UH, no matter what was specified
{            on the RFT.
{
{ Input parameters
{            None
{
{
{ Input/output parameters
{            Control_block        : Transfer control block
{
{ Output parameters
{            Rpos_parameters             : Set of parameters to use for RPOS
{                                          command.
{            Status                      : Return status
{
{ Algorithm
{            If DD = UH and host type <> NOS/VE
{            Then
{              Set error
{            Else
{              Return
{            Ifend
{            If DD <> UH and host type = NOS/VE
{            Then
{              Add parameter DD value UH to RPOS command
{            Else
{              Return
{            Ifend
{
?? EJECT ??
    status.normal := TRUE;
    rpos_parameters := $nft$parameter_set [nfc$protocol_id, nfc$mode_of_access, nfc$host_type, nfc$job_name,
          nfc$physical_id];
    IF ((nfv$control_block.data_declaration = nfc$p31_host_dependent_uh) AND
          (nfv$control_block.remote_host_type <> nfc$p22_nos_ve)) THEN
      osp$set_status_abnormal (nfc$status_id, nfe$unknown_data_format, '', status);
      nfp$set_abnormal_if_normal (status, nfv$control_block.local_status);
      RETURN;
    IFEND;

    IF ((nfv$control_block.data_declaration <> nfc$p31_host_dependent_uh) AND
          (nfv$control_block.remote_host_type = nfc$p22_nos_ve)) THEN
      nfv$control_block.data_declaration := nfc$p31_host_dependent_uh;
      rpos_parameters := rpos_parameters + $nft$parameter_set [nfc$data_declaration];
    IFEND;
{}
  PROCEND ptfs_parameters_for_rpos;
?? OLDTITLE ??
?? NEWTITLE := 'ptfs_send_status_parameter', EJECT ??

  PROCEDURE ptfs_send_status_parameter
    (    transfer_status: ost$status;
     VAR special_options: nft$parameter_11_value;
     VAR status: ost$status);

{
{ Procedure  ptfs_send_status_parameter
{
{ Purpose    This routine takes a NOS/VE status record and converts
{            it into a string.  This string may then be sent to other
{            NOS/VE systems for communicating status information.
{
{ Description
{            The NOS/VE status parameter is made up of three parts: ID,
{            condition, and text.  Each is placed in the string delimited
{            by a space.
{
{ Input parameters
{            Transfer_status      Status to convert to string
{
{ Output parameters
{            Special_options      Returned string value
{            Status               Return status
{
{ Algorithm
{
?? EJECT ??

    VAR
      condition_string: ost$string,
      ignore_status: ost$status,
      parameter: string (nfc$p11_max_param_len),
      parameter_length: nft$parameter_size;

{}
    status.normal := TRUE;
    IF NOT transfer_status.normal THEN
      osp$get_status_condition_string (transfer_status.condition, condition_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      parameter_length := condition_string.size;
      parameter (1, parameter_length) := condition_string.value;
      parameter (parameter_length + 1, 1) := ' ';
      parameter_length := parameter_length + 1;
      IF transfer_status.text.size > 0 THEN
        parameter_length := parameter_length + 1;
        parameter (parameter_length, transfer_status.text.size) := transfer_status.text.value;
        parameter_length := parameter_length + transfer_status.text.size - 1;
      IFEND;
      special_options.size := parameter_length;
      IF parameter_length > 0 THEN
        special_options.value := parameter;
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
            'ptfs_send_status_parameter status is normal', status);
    IFEND;

  PROCEND ptfs_send_status_parameter;
?? OLDTITLE ??
?? NEWTITLE := '  ptfs_scan_scl_command_file', EJECT ??

  PROCEDURE ptfs_scan_scl_command_file
    (    scan_file: fst$file_reference;
         force_job_log_echo: boolean;
     VAR begin_connection_time: ost$date_time;
     VAR nfv$control_block: nft$control_block;
     VAR status: ost$status);

{
{ Procedure  ptfs_scan_scl_command_file
{
{ Purpose    To scan a command file for SCL commands and
{            PTFS file transfer directives.
{
{ Description
{            This routine pushes the PTFS utility and calls SCL
{            to execute commands.
{
{ Input parameters
{            scan_file:    File to read for SCL commands
{            force_job_log_echo:  Have create_connection $output $job_log
{
{ Input/Output parameters
{            begin_connection_time: Time RFT received
{
{ Output parameters
{            status:       Return status
{

?? EJECT ??
    VAR
      conditions: pmt$condition,
      establish_descriptor: pmt$established_handler,
      ignore_status: ost$status,
      local_status: ost$status,
      no_prompt: string (1),
      server_utility_name: ost$name,

      ptfs_commands_entries: [STATIC, READ] array [1 .. 4] of clt$command_table_entry := [
            {} ['RECEIVE_FILE                   ', clc$nominal_entry, clc$advertised_entry, 2,
            clc$automatically_log, clc$linked_call, ^receive_file_command],
            {} ['RECF                           ', clc$abbreviation_entry, clc$advertised_entry, 2,
            clc$automatically_log, clc$linked_call, ^receive_file_command],
            {} ['SEND_FILE                      ', clc$nominal_entry, clc$advertised_entry, 1,
            clc$automatically_log, clc$linked_call, ^send_file_command],
            {} ['SENF                           ', clc$abbreviation_entry, clc$advertised_entry, 1,
            clc$automatically_log, clc$linked_call, ^send_file_command]];

?? NEWTITLE := '    ptfs_scan_scl_handler', EJECT ??

{
{     The primary purpose of this condition handler is to catch the results of a
{ logout command in the command file being scanned.  When LOGOUT is encountered,
{ the protocol processing is not completed and the connection is broken.  This
{ condition handler will finish the protocol.
{

    PROCEDURE ptfs_scan_scl_handler
      (    condition: pmt$condition;
           condition_desc: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR trap_status: ost$status);


      IF condition.reason = $pmt$block_exit_reason [pmc$program_termination] THEN
        ptfs_process_protocol (FALSE, user_ptfs_job_logout,
         nfv$control_block, begin_connection_time, local_status);
      ELSE
        ptfs_process_protocol (FALSE, ptfs_scan_scl_handler_id,
         nfv$control_block, begin_connection_time, local_status);
        osp$set_status_from_condition (nfc$status_id, condition, save_area, status, local_status);
        IF local_status.normal THEN
          nfp$format_message_to_job_log (status);
        IFEND;
      IFEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);

    PROCEND ptfs_scan_scl_handler;
?? OLDTITLE, EJECT ??
    conditions.selector := pmc$condition_combination;
    conditions.combination := $pmt$condition_combination [pmc$block_exit_processing];
    pmp$establish_condition_handler (conditions, ^ptfs_scan_scl_handler, ^establish_descriptor, status);
    IF NOT status.normal THEN
      pmp$log ('ptfs_scan_scl_command_file unable to establish handler', ignore_status);
      nfp$format_message_to_job_log (status);
      RETURN;
    IFEND;

    server_utility_name := 'PTFS';
    no_prompt := '';
    clp$push_utility (server_utility_name, clc$global_command_search, ^ptfs_commands_entries, NIL, status);
    IF NOT status.normal THEN { Unable to process SCL commands }
      RETURN;
    ELSE
      IF force_job_log_echo THEN
        clp$create_file_connection (clc$echoed_commands, clc$job_log, ignore_status);
      IFEND;
    IFEND;

    clp$scan_command_file (scan_file, server_utility_name, no_prompt, status);
    IF force_job_log_echo THEN
      clp$delete_file_connection (clc$echoed_commands, clc$job_log, ignore_status);
    IFEND;
    clp$pop_utility (ignore_status);

{   If SCL had an error, set bad state of transfer and local status

    IF (NOT status.normal) THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, local_status);
      IF nfv$control_block.state_of_transfer.normal THEN
        osp$set_status_abnormal (nfc$status_id, nfe$transfer_rejected_message, '',
              nfv$control_block.state_of_transfer);
      IFEND;
      nfp$set_abnormal_if_normal (status, nfv$control_block.local_status);
    IFEND;

    pmp$disestablish_cond_handler (conditions, ignore_status);

  PROCEND ptfs_scan_scl_command_file;
?? OLDTITLE ??
?? NEWTITLE := 'build_05_directives_text', EJECT ??
{
{     The purpose of this routine is to concatenate directive entries
{  into a string. This string is logged via communication accounting.
{
{ USER_DIRECTIVES : (input) Linked list of directives.
{
{ TEXT : (output) Output string.
{

  PROCEDURE build_05_directives_text
    (    user_directives_p: ^nft$directive_entry;
     VAR text: ost$string);

    VAR
      current_entry_p: ^nft$directive_entry,
      current_line_length: ost$string_size;

    text.size := 0;
    IF (user_directives_p <> NIL) THEN
      current_entry_p := user_directives_p;
      /count_loop/
      REPEAT
        current_line_length := STRLENGTH(current_entry_p^.line);
        IF (osc$max_string_size-text.size>=current_line_length) THEN
          text.value(text.size+1,current_line_length) := current_entry_p^.line;
          text.size := text.size + current_line_length;
          current_entry_p := current_entry_p^.link;
          IF current_entry_p <> NIL THEN
            IF text.size+2 >= osc$max_string_size THEN
              EXIT /count_loop/;
            IFEND;
            text.size := text.size + 1;
            text.value(text.size,1) := '/';
          IFEND;
        ELSE
          text.value(text.size,*) := current_entry_p^.line;
          text.size := osc$max_string_size;
          EXIT /count_loop/;
        IFEND;
      UNTIL (current_entry_p = NIL);
    IFEND;

  PROCEND build_05_directives_text;
?? OLDTITLE ??
?? NEWTITLE := 'send_rneg', EJECT ??

  PROCEDURE send_rneg
    (    parameters: nft$parameter_set;
         rft_parameters: nft$parameter_set;
     VAR control_block: nft$control_block;
     VAR status: ost$status);

{
{     The purpose of this routine is to send an RNEG command.
{
{ PARAMETERS : (input) Parameters requested to be sent by caller.
{
{ RFT_PARAMETERS : (input) Parameters sent by initiator on RFT.
{
{ CONTROL_BLOCK : (input,output) Protocol engine control block.
{
{ STATUS : (output) Return status.
{

    VAR
      ignore_parameters: nft$parameter_set,
      select_parameters: nft$parameter_set;

    ignore_parameters := $nft$parameter_set[ ];
    select_parameters := parameters;
    IF ((nfc$special_options IN rft_parameters) AND (control_block.remote_host_type <>
          nfc$p22_nos_ve)) THEN

{ Ignore special options }

      control_block.send_special_options.size := control_block.receive_special_options.size;
      IF (control_block.send_special_options.size > 0) THEN
        control_block.send_special_options.value := control_block.receive_special_options.value;
      IFEND;
      ignore_parameters := ignore_parameters + $nft$parameter_set[ nfc$special_options ];
    IFEND;
    nfp$send_command (nfc$rneg, select_parameters, ignore_parameters, $nft$parameter_set[ ], control_block,
          status);

  PROCEND send_rneg;
?? OLDTITLE ??
?? NEWTITLE := 'send_rpos', EJECT ??

  PROCEDURE send_rpos
    (    parameters: nft$parameter_set;
         rft_parameters: nft$parameter_set;
     VAR control_block: nft$control_block;
     VAR status: ost$status);

{
{     The purpose of this routine is to send an RPOS command.
{
{ PARAMETERS : (input) Parameters requested to be sent by caller.
{
{ RFT_PARAMETERS : (input) Parameters sent by initiator on RFT.
{
{ CONTROL_BLOCK : (input,output) Protocol engine control block.
{
{ STATUS : (output) Return status.
{

    VAR
      ignore_parameters: nft$parameter_set,
      select_parameters: nft$parameter_set;

    ignore_parameters := $nft$parameter_set[ ];
    select_parameters := parameters;
    IF ((nfc$special_options IN rft_parameters) AND (control_block.remote_host_type <>
          nfc$p22_nos_ve)) THEN

{ Ignore special options }

      control_block.send_special_options.size := control_block.receive_special_options.size;
      IF (control_block.send_special_options.size > 0) THEN
        control_block.send_special_options.value := control_block.receive_special_options.value;
      IFEND;
      ignore_parameters := ignore_parameters + $nft$parameter_set[ nfc$special_options ];
    IFEND;
    nfp$send_command (nfc$rpos, select_parameters,ignore_parameters, $nft$parameter_set[ ], control_block,
          status);

  PROCEND send_rpos;
?? OLDTITLE ??
MODEND nfm$ptf_server;

*DECK DECK=NFM$QTF_APPLICATION_DATA EXPAND=TRUE
?? TITLE := 'QTF Application Values', EJECT ??

?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, INDENT := 2) ??
?? SET (LIST := ON, LISTCTS := OFF) ??
MODULE nfm$qtf_application_data;
*copyc nfc$parameter_01_definitions
*copyc nfc$parameter_03_definitions
*copyc nfc$parameter_04_definitions
*copyc nfc$parameter_05_definitions
*copyc nfc$parameter_06_definitions
*copyc nfc$parameter_07_definitions
*copyc nfc$parameter_08_definitions
*copyc nfc$parameter_12_definitions
*copyc nfc$parameter_16_definitions
*copyc nfc$parameter_17_definitions
*copyc nfc$parameter_18_definitions
*copyc nfc$parameter_20_definitions
*copyc nfc$parameter_21_definitions
*copyc nfc$parameter_22_definitions
*copyc nfc$parameter_24_definitions
*copyc nfc$parameter_25_definitions
*copyc nfc$parameter_26_definitions
*copyc nfc$parameter_27_definitions
*copyc nfc$parameter_29_definitions
*copyc nfc$parameter_30_definitions
*copyc nfc$parameter_31_definitions
*copyc nfc$parameter_32_definitions
*copyc nfc$parameter_33_definitions
*copyc nft$parameter_rules
*copyc nft$parameter_rules_array
*copyc nft$parameter_set
*copyc nft$required_param_on_command
?? NEWTITLE := '  QTF parameter rules' ??
*copyc nfs$qtf_application_data

  VAR
    nfv$qtf_parameter_rules: [XDCL, READ, nfs$qtf_application_data] nft$parameter_rules_array :=
          [^protocol_id_rules {0} , ^nil_parameter {1} , ^nil_parameter {2} , ^facilities_rules {3} ,
          ^state_of_transfer_rules {4} , ^user_text_directive_rules {5} , ^file_length_rules {6} ,
          ^operator_message_rules {7} , ^user_message_rules {8} , ^nil_parameter {9} , ^nil_parameter {10} ,
          ^nil_parameter {11} , ^max_block_size_rules {12} , ^nil_parameter {13} , ^file_name_rules {16} ,
          ^file_disposition_rules {17} , ^acknowledgement_window_rules {18} , ^nil_parameter {19} ,
          ^min_timeout_interval_rules {20} , ^mode_of_access_rules {21} , ^host_type_rules {22} ,
          ^nil_parameter {23} , ^source_lid_rules {24} , ^transfer_lid_rules {25} , ^job_name_rules {26} ,
          ^physical_id_rules {27} , ^nil_parameter {28} , ^echo_rules {29} , ^attribute_continued_rules {30} ,
          ^data_declaration_rules {31} , ^system_routing_text_rules {32} , ^implicit_routing_text_rules {33} ,
          ^nil_parameter {51} , ^nil_parameter {52} , ^nil_parameter {53} , ^nil_parameter {54} ,
          ^nil_parameter {55} , ^nil_parameter {56} , ^nil_parameter {57} , ^nil_parameter {58} ,
          ^nil_parameter {59} , ^nil_parameter {60} , ^nil_parameter {90} , ^nil_parameter {91} ,
          ^nil_parameter {92} , ^nil_parameter {93} , ^nil_parameter {94} , ^nil_parameter {95} ,
          ^nil_parameter {96} , ^nil_parameter {97} , ^nil_parameter {98} , ^nil_parameter {99} ],

    nil_parameter: [READ, nfs$qtf_application_data] nft$parameter_rules := [[FALSE], [FALSE], [FALSE]],

    protocol_id_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p01_min_size, nfc$p01_min_size, $nft$command_set [nfc$rft, nfc$rpos],
          $nft$command_set [], $nft$command_set [], $nft$command_set [], FALSE],
          [TRUE, nfc$p01_min_size, nfc$p01_min_size, $nft$command_set [nfc$rft, nfc$rpos],
          $nft$command_set [], $nft$command_set [], $nft$command_set [], FALSE], [FALSE]],

    facilities_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p03_min_size, nfc$p03_max_size, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rft, nfc$rpos], $nft$command_set [], FALSE],
          [TRUE, nfc$p03_min_size, nfc$p03_max_size, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rft, nfc$rpos], $nft$command_set [], FALSE], [FALSE]],

    state_of_transfer_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p04_min_param_len, nfc$p04_max_param_len, $nft$command_set
          [nfc$rneg, nfc$stop, nfc$stopr], $nft$command_set [], $nft$command_set [], $nft$command_set [],
          FALSE], [TRUE, nfc$p04_min_param_len, nfc$p04_max_param_len, $nft$command_set
          [nfc$rneg, nfc$stop, nfc$stopr], $nft$command_set [], $nft$command_set [], $nft$command_set [],
          FALSE], [FALSE]],

    user_text_directive_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p05_min_param_len, nfc$p05_max_param_len, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rft, nfc$rneg], $nft$command_set [], FALSE],
          [TRUE, nfc$p05_min_param_len, nfc$p05_max_param_len, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rft, nfc$rneg],  $nft$command_set [], FALSE], [FALSE]],

    file_length_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p06_min_param_len, nfc$p06_max_param_len, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rft], $nft$command_set [], FALSE],
          [TRUE, nfc$p06_min_param_len, nfc$p06_max_param_len, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rft], $nft$command_set [], FALSE], [FALSE]],

    operator_message_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p07_min_param_len, nfc$p07_max_param_len_a101, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rpos, nfc$rneg, nfc$stop, nfc$stopr], $nft$command_set [], FALSE],
          [TRUE, nfc$p07_min_param_len, nfc$p07_max_param_len_a102, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rpos, nfc$rneg, nfc$stop, nfc$stopr], $nft$command_set [], FALSE], [FALSE]],

    user_message_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p08_min_param_len, nfc$p08_max_param_len_a101, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rpos, nfc$rneg, nfc$stop, nfc$stopr], $nft$command_set [], FALSE],
          [TRUE, nfc$p08_min_param_len, nfc$p08_max_param_len_a102, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rpos, nfc$rneg, nfc$stop, nfc$stopr], $nft$command_set [], FALSE], [FALSE]],

    max_block_size_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p12_min_size_a101, nfc$p12_max_size_a101, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rft, nfc$rpos], $nft$command_set [], FALSE],
          [TRUE, nfc$p12_min_size_a102, nfc$p12_max_size_a102, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rft, nfc$rpos], $nft$command_set [], FALSE], [FALSE]],

    file_name_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p16_min_param_length, nfc$p16_max_param_length_a101, $nft$command_set [nfc$rft],
          $nft$command_set [], $nft$command_set [], $nft$command_set [], FALSE],
          [TRUE, nfc$p16_min_param_length, nfc$p16_max_param_length_a102, $nft$command_set [nfc$rft],
          $nft$command_set [], $nft$command_set [], $nft$command_set [], FALSE], [FALSE]],

    file_disposition_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p17_min_size, nfc$p17_max_size, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rft], $nft$command_set [], FALSE],
          [TRUE, nfc$p17_min_size, nfc$p17_max_size, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rft], $nft$command_set [], FALSE], [FALSE]],

    acknowledgement_window_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p18_minimum_parameter_size, nfc$p18_maximum_parameter_size, $nft$command_set [],
          $nft$command_set [], $nft$command_set [nfc$rft, nfc$rpos], $nft$command_set [], FALSE],
          [TRUE, nfc$p18_minimum_parameter_size, nfc$p18_maximum_parameter_size, $nft$command_set [],
          $nft$command_set [], $nft$command_set [nfc$rft, nfc$rpos], $nft$command_set [], FALSE], [FALSE]],

    min_timeout_interval_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p20_min_size, nfc$p20_max_size, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rft, nfc$rpos], $nft$command_set [], FALSE],
          [TRUE, nfc$p20_min_size, nfc$p20_max_size, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rft, nfc$rpos], $nft$command_set [], FALSE], [FALSE]],

    mode_of_access_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p21_min_param_len, nfc$p21_max_param_len, $nft$command_set [nfc$rft],
          $nft$command_set [nfc$rpos], $nft$command_set [], $nft$command_set [], FALSE],
          [TRUE, nfc$p21_min_param_len, nfc$p21_max_param_len, $nft$command_set [nfc$rft],
          $nft$command_set [nfc$rpos], $nft$command_set [], $nft$command_set [], FALSE], [FALSE]],

    host_type_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p22_min_size, nfc$p22_max_size, $nft$command_set [nfc$rft, nfc$rpos],
          $nft$command_set [], $nft$command_set [], $nft$command_set [], FALSE],
          [TRUE, nfc$p22_min_size, nfc$p22_max_size, $nft$command_set [nfc$rft, nfc$rpos],
          $nft$command_set [], $nft$command_set [], $nft$command_set [], FALSE], [FALSE]],

    source_lid_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p24_min_param_size_a101, nfc$p24_min_param_size_a101, $nft$command_set [],
          $nft$command_set [], $nft$command_set [nfc$rft], $nft$command_set [], FALSE],
          [TRUE, nfc$p24_min_param_size_a102, nfc$p24_max_param_size_a102, $nft$command_set [],
          $nft$command_set [], $nft$command_set [nfc$rft], $nft$command_set [], FALSE], [FALSE]],

    transfer_lid_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p25_min_param_size_a101, nfc$p25_max_param_size_a101, $nft$command_set [nfc$rft],
          $nft$command_set [], $nft$command_set [], $nft$command_set [], FALSE],
          [TRUE, nfc$p25_min_param_size_a102, nfc$p25_max_param_size_a102, $nft$command_set [nfc$rft],
          $nft$command_set [], $nft$command_set [], $nft$command_set [], FALSE], [FALSE]],

    job_name_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p26_min_param_length, nfc$p26_max_param_length_a101, $nft$command_set [nfc$rft],
          $nft$command_set [], $nft$command_set [], $nft$command_set [], FALSE],
          [TRUE, nfc$p26_min_param_length, nfc$p26_max_param_length_a102, $nft$command_set [nfc$rft],
          $nft$command_set [], $nft$command_set [], $nft$command_set [], FALSE], [FALSE]],

    physical_id_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p27_min_param_size_a101, nfc$p27_max_param_size_a101, $nft$command_set
          [nfc$rft, nfc$rpos], $nft$command_set [], $nft$command_set [], $nft$command_set [], FALSE],
          [TRUE, nfc$p27_min_param_size_a102, nfc$p27_max_param_size_a102, $nft$command_set
          [nfc$rft, nfc$rpos], $nft$command_set [], $nft$command_set [], $nft$command_set [], FALSE],
          [FALSE]],

    echo_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p29_min_param_size_a101, nfc$p29_max_param_size_a102, $nft$command_set [],
          $nft$command_set [], $nft$command_set [nfc$rft, nfc$rpos], $nft$command_set [], FALSE],
          [TRUE, nfc$p29_min_param_size_a102, nfc$p29_max_param_size_a102, $nft$command_set [],
          $nft$command_set [], $nft$command_set [nfc$rft, nfc$rpos], $nft$command_set [], FALSE], [FALSE]],

    attribute_continued_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p30_min_param_size, nfc$p30_max_param_size, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rft, nfc$rpos, nfc$rneg, nfc$stop, nfc$stopr], $nft$command_set [], FALSE],
          [TRUE, nfc$p30_min_param_size, nfc$p30_max_param_size, $nft$command_set [], $nft$command_set [],
          $nft$command_set [nfc$rft, nfc$rpos, nfc$rneg, nfc$stop, nfc$stopr], $nft$command_set [], FALSE],
          [FALSE]],

    data_declaration_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p31_min_param_length_a101, nfc$p31_max_param_length_a101, $nft$command_set [],
          $nft$command_set [], $nft$command_set [nfc$rft, nfc$rpos], $nft$command_set [], FALSE],
          [TRUE, nfc$p31_min_param_length_a102, nfc$p31_max_param_length_a102, $nft$command_set [],
          $nft$command_set [], $nft$command_set [nfc$rft, nfc$rpos], $nft$command_set [], FALSE], [FALSE]],

    system_routing_text_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p32_min_param_length_a101, nfc$p32_max_param_length_a101, $nft$command_set [],
          $nft$command_set [], $nft$command_set [nfc$rft], $nft$command_set [], FALSE],
          [TRUE, nfc$p32_min_param_length_a102, nfc$p32_max_param_length_a102, $nft$command_set [],
          $nft$command_set [], $nft$command_set [nfc$rft], $nft$command_set [], FALSE], [FALSE]],

    implicit_routing_text_rules: [READ, nfs$qtf_application_data] nft$parameter_rules :=
          [[TRUE, nfc$p33_min_param_length_a101, nfc$p33_max_param_length_a101, $nft$command_set [],
          $nft$command_set [], $nft$command_set [nfc$rft], $nft$command_set [], FALSE],
          [TRUE, nfc$p33_min_param_length_a102, nfc$p33_max_param_length_a102, $nft$command_set [],
          $nft$command_set [], $nft$command_set [nfc$rft], $nft$command_set [], FALSE], [FALSE]];

?? TITLE := '  QTF required parameters on protocol commands', EJECT ??

  VAR
    nfv$qtf_required_params_on_cmds: [XDCL, READ, nfs$qtf_application_data] nft$required_param_on_command :=
          [$nft$parameter_set [], $nft$parameter_set [nfc$protocol_id, nfc$file_name, nfc$mode_of_access,
          nfc$host_type, nfc$transfer_lid, nfc$physical_id],
          $nft$parameter_set [nfc$protocol_id, nfc$host_type, nfc$physical_id],
          $nft$parameter_set [nfc$state_of_transfer], $nft$parameter_set [],
          $nft$parameter_set [nfc$state_of_transfer], $nft$parameter_set [nfc$state_of_transfer],
          $nft$parameter_set [], $nft$parameter_set [], $nft$parameter_set []];

MODEND nfm$qtf_application_data;
*DECK DECK=NFM$QTF_CONTROLLER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Queue File Transfer Facility Controller' ??
MODULE nfm$qtf_controller;

{ PURPOSE:
{   QTF gives a user the capability to send input, output, and generic queue
{   files to remote mainframes connected by CDCNET or LCN.  This module, QTF
{   Controller (QTFC), makes up half the QTF client.  The other half is the QTF
{   Initiator (QTFI).  QTFC gets files from Queue File Manager (QFM), starts the
{   necessary QTFI tasks to transmit the files to the remote mainframe.
{
{ DESIGN:
{   QTFC acquires all input, output, and generic queue files that are to be
{   transferred to remote destinations from QFM.  Additionally, QTFC acquires
{   all queue files that have been terminated or modified by the controlling
{   user.  The priority of acquiring queue files is:  terminated, modified, and
{   new.
{
{   After acquiring the queue files, QTFC will check to see if there are any
{   files to be transferred to remote destinations and determines whether the
{   remote destinations are available through LCN or CDCNET.  If a destination
{   is available via LCN, an RHFAM connection is established.  If the
{   destination is only available via CDCNET, a NAM/VE connection is made.
{
{   If a remote destination is not available through either network QTFC will do
{   two things:  Issue a title translation request with NAM/VE, and periodically
{   check the destination's availability via RHFAM through the use of back-off
{   timers.  If the NAM/VE translation request is satisfied before the
{   destination becomes available via RHFAM, QTFC will check if the destination
{   can be reached via RHFAM once more.  This extra RHFAM check is done because
{   RHFAM / LCN is the preffered network media.  If the remote destination is
{   found via RHFAM before the NAM/VE translation request is satisified, the
{   RHFAM connection is established and the NAM/VE translation request is
{   removed.
{
{   After establishing a connection to the remote destination, QTFC will start
{   an asynchronous QTFI task and provide the task with the connection and the
{   queue file to transfer.  After attempting to transfer the queue file to the
{   remote destination, QTFI will send a message to QTFC describing the status
{   of the transfer.
{
{   If the file transfer completed normally QTFC will provide QTFI another file
{   to transfer over the same connection.  If the file transfer completed
{   abnormally QTFC will attempt to retry the file again at a later time based
{   and the type of failure encountered during the file transfer.
{
{   If there are no queue files remaining to transfer to a particular
{   destination, or the limit of transferred files has been reached, or the
{   previous file transfer failed miserably, QTFC will tell QTFI to close the
{   current connection and provide a new connection for future file transfers.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmt$qfile_attribute_keys
*copyc nae$application_interfaces
*copyc nfc$qtf_name_constants
*copyc nfc$timer_values
*copyc nfe$batch_transfer_services
*copyc nft$intertask_message
*copyc nft$network_type
*copyc nft$wait_list_size
*copyc osd$integer_limits
*copyc ost$status
*copyc osv$lower_to_upper
?? POP ??
*copyc amp$return
*copyc clp$delete_variable
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc jmp$acquire_modified_input
*copyc jmp$acquire_modified_output
*copyc jmp$acquire_modified_qfile
*copyc jmp$acquire_new_input
*copyc jmp$acquire_new_output
*copyc jmp$acquire_new_qfile
*copyc jmp$get_result_size
*copyc jmp$modified_input_exists
*copyc jmp$modified_output_exists
*copyc jmp$modified_qfile_exists
*copyc jmp$new_input_exists
*copyc jmp$new_output_exists
*copyc jmp$new_qfile_exists
*copyc jmp$register_input_application
*copyc jmp$register_output_application
*copyc jmp$register_qfile_application
*copyc jmp$set_input_completed
*copyc jmp$set_input_initiated
*copyc jmp$set_output_completed
*copyc jmp$set_output_initiated
*copyc jmp$set_qfile_completed
*copyc jmp$set_qfile_initiated
*copyc jmp$terminate_acquired_input
*copyc jmp$terminate_acquired_output
*copyc jmp$terminate_acquired_qfile
*copyc jmp$terminated_input_exists
*copyc jmp$terminated_output_exists
*copyc jmp$terminated_qfile_exists
*copyc nap$begin_directory_search
*copyc nap$display_message
*copyc nap$end_directory_search
*copyc nap$get_title_translation
*copyc nap$request_connection
*copyc nfp$close_store_forward_file
*copyc nfp$create_appl_def_segment_var
*copyc nfp$end_async_communication
*copyc nfp$get_async_task_message
*copyc nfp$get_new_destination_name
*copyc nfp$get_new_source_name
*copyc nfp$open_store_forward_file
*copyc nfp$put_async_task_message
*copyc nfp$request_asynchronous_task
*copyc nfp$start_timer
*copyc nfp$timer_expired
*copyc osp$i_await_activity_completion
*copyc osp$set_status_abnormal
*copyc pmp$establish_condition_handler
*copyc pmp$get_compact_date_time
*copyc pmd$local_queues
*copyc pmp$get_unique_name
*copyc pmp$log
*copyc pmp$wait
*copyc rfp$application_sign_on
*copyc rfp$application_sign_off
*copyc rfp$await_server_response
*copyc rfp$find_available_service
*copyc rfp$get_local_host_physical_id
*copyc rfp$request_connection
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    nfc$qtf_put_async_max_retry = 10,
    nfc$qtf_put_async_wait_time = 250,        {  this is in milliseconds.  (one-fourth of a second)
    nfc$wait_list_limit = 20;

  TYPE
    nft$bcd_digit = 0 .. 9,

    nft$bcd_time = packed record
      date: packed record
        year1: nft$bcd_digit,
        year2: nft$bcd_digit,
        month1: nft$bcd_digit,
        month2: nft$bcd_digit,
        day1: nft$bcd_digit,
        day2: nft$bcd_digit,
      recend,
      time: packed record
        hours1: nft$bcd_digit,
        hours2: nft$bcd_digit,
        minutes1: nft$bcd_digit,
        minutes2: nft$bcd_digit,
        seconds1: nft$bcd_digit,
        seconds2: nft$bcd_digit,
        milliseconds1: nft$bcd_digit,
        milliseconds2: nft$bcd_digit,
        milliseconds3: nft$bcd_digit,
        fill: nft$bcd_digit,
      recend,
    recend,

*copyc nft$micro_second
*copyc nft$timer
    nft$network_availability = record
      case available: boolean of
      = FALSE =
        timer: nft$timer,
      = TRUE =
        time_stamp: nft$bcd_time,
      casend,
    recend,

    nft$qtf_connection = record
      file_name: amt$local_file_name,
      kind: nft$network_type,
    recend,

    nft$qtf_put_async_retry_range = 0 .. (nfc$qtf_put_async_max_retry + 1),

    nft$qtfc_destination = record
      back_link: ^nft$qtfc_destination,
      link: ^nft$qtfc_destination,
      name: ost$name, {family name or LID
      next_destination_name: nft$parameter_24_definition,
      file_list: ^nft$qtfc_file,
      last_file: ^nft$qtfc_file,
      retry_timer: nft$timer,
      rhfam_timer: nft$timer,
      transfering_task: ^nft$qtfi_task,
      translation_request: ^ost$i_activity,
    recend,

    nft$qtfc_file = record
      back_link: ^nft$qtfc_file,
      link: ^nft$qtfc_file,
      name: jmt$system_supplied_name,
      transfer_state: nft$qtfc_file_transfer_state,
      application_file_descriptor: nft$application_file_descriptor,
    recend,

    nft$qtfc_file_transfer_state = (nfc$wait_to_transfer, nfc$ready_to_transfer, nfc$transfer_initiated),

    nft$qtfi_task = record
      back_link: ^nft$qtfi_task,
      link: ^nft$qtfi_task,
      file_in_transfer: ^nft$qtfc_file,
      file_transfer_start_time: nft$micro_second,
      last_message_sent: nft$intertask_message_kind,
      qid: pmt$queue_connection,
      task_id: pmt$task_id,
      transfer_connection: nft$qtf_connection,
    recend;

  VAR
    destination_list: ^nft$qtfc_destination := NIL,
    qtfc_wait_list_seq: ^SEQ ( * ) := NIL;

*copyc nfs$appl_def_segment_variables
*copyc nfv$appl_def_segment_variables
?? TITLE := 'acquire_all_q_files', EJECT ??

{ PURPOSE:
{   This procedure gets all available queue files from the Queue File
{   Manager to be transferred via QTF.  The files will be deleted from
{   file lists (terminated files), modified and/or moved to different
{   file lists (modified files), and added to file lists (new files).

  PROCEDURE acquire_all_q_files
    (    generic_q_password: jmt$queue_file_password;
         input_q_password: jmt$queue_file_password;
         output_q_password: jmt$queue_file_password;
         store_forward_file_info: nft$store_forward_file_info;
     VAR destination_list: ^nft$qtfc_destination);

?? NEWTITLE := 'acquire_terminated_files', EJECT ??

{ PURPOSE:
{   This procedure gets all the terminated output, input and generic queue files
{   from QFM and removes the files from the internal tables.

    PROCEDURE acquire_terminated_files
      (    destination_list: ^nft$qtfc_destination);

      VAR
        destination: ^nft$qtfc_destination,
        local_status: ost$status,
        system_file_name: jmt$system_supplied_name,
        terminated_file: ^nft$qtfc_file;

    /acquire_terminated_output/
      WHILE jmp$terminated_output_exists (jmc$qtf_usage) DO
        jmp$terminate_acquired_output (jmc$qtf_usage, system_file_name, local_status);
        IF local_status.normal THEN
          find_file_and_destination (system_file_name, destination_list, destination, terminated_file);
          IF (terminated_file <> NIL) AND (terminated_file^.transfer_state <> nfc$transfer_initiated) THEN
            delete_file_from_file_list (terminated_file, destination^.file_list, destination^.last_file);
          IFEND;
        ELSE
          nap$display_message (local_status);
          EXIT /acquire_terminated_output/; {----->
        IFEND;
      WHILEND /acquire_terminated_output/;

    /acquire_terminated_input/
      WHILE jmp$terminated_input_exists (jmc$qtf_usage) DO
        jmp$terminate_acquired_input (jmc$qtf_usage, system_file_name, local_status);
        IF local_status.normal THEN
          find_file_and_destination (system_file_name, destination_list, destination, terminated_file);
          IF (terminated_file <> NIL) AND (terminated_file^.transfer_state <> nfc$transfer_initiated) THEN
            delete_file_from_file_list (terminated_file, destination^.file_list, destination^.last_file);
          IFEND;
        ELSE
          nap$display_message (local_status);
          EXIT /acquire_terminated_input/; {----->
        IFEND;
      WHILEND /acquire_terminated_input/;

    /acquire_terminated_generic/
      WHILE jmp$terminated_qfile_exists (nfc$qtf_namve_client_name) DO
        jmp$terminate_acquired_qfile (nfc$qtf_namve_client_name, system_file_name, local_status);
        IF local_status.normal THEN
          find_file_and_destination (system_file_name, destination_list, destination, terminated_file);
          IF (terminated_file <> NIL) AND (terminated_file^.transfer_state <> nfc$transfer_initiated) THEN
            delete_file_from_file_list (terminated_file, destination^.file_list, destination^.last_file);
          IFEND;
        ELSE
          nap$display_message (local_status);
          EXIT /acquire_terminated_generic/;
        IFEND;
      WHILEND /acquire_terminated_generic/;

    PROCEND acquire_terminated_files;
?? TITLE := 'acquire_modified_files', EJECT ??

{ PURPOSE:
{   This procedure gets all the modified output, input and generic queue files
{   from QFM and makes the appropriate changes.

    PROCEDURE acquire_modified_files
      (    store_forward_file_info: nft$store_forward_file_info;
       VAR destination_list: ^nft$qtfc_destination);

      VAR
        current_destination: ^nft$qtfc_destination,
        generic_attribute_keys: ^jmt$qfile_attribute_keys,
        generic_attribute_results: ^jmt$qfile_attribute_results,
        generic_attribute_work_area: ^jmt$work_area,
        generic_work_area_size: ost$segment_length,
        local_status: ost$status,
        modified_generic_descriptor: nft$generic_descriptor,
        modified_input_descriptor: jmt$input_descriptor,
        modified_file: ^nft$qtfc_file,
        modified_output_descriptor: jmt$output_descriptor,
        new_file_destination: ^nft$qtfc_destination;

?? NEWTITLE := 'move_file_to_new_destination', EJECT ??

{ PURPOSE:
{    This procedure removes the specified file from the current
{    destination file list and puts it at the end of the new
{    destination file list.

      PROCEDURE move_file_to_new_destination
        (VAR modified_file: ^nft$qtfc_file;
         VAR current_destination: nft$qtfc_destination;
         VAR new_destination: nft$qtfc_destination);

{ Set all the pointers in the file list to remove the modified file from
{ the old destination file list.

        IF (current_destination.file_list = modified_file) AND
              (current_destination.last_file = modified_file) THEN
          current_destination.file_list := NIL;
          current_destination.last_file := NIL;

        ELSEIF current_destination.file_list = modified_file THEN
          current_destination.file_list := modified_file^.link;
          current_destination.file_list^.back_link := NIL;

        ELSEIF current_destination.last_file = modified_file THEN
          current_destination.last_file := modified_file^.back_link;
          current_destination.last_file^.link := NIL;

        ELSE
          modified_file^.back_link^.link := modified_file^.link;
          modified_file^.link^.back_link := modified_file^.back_link;

        IFEND;

{ Set all the pointers to include the modified file in the new
{ destination file list.

        IF new_destination.file_list = NIL THEN
          new_destination.file_list := modified_file;
          modified_file^.back_link := NIL;

        ELSE
          new_destination.last_file^.link := modified_file;
          modified_file^.back_link := new_destination.last_file;

        IFEND;

        new_destination.last_file := modified_file;
        modified_file^.link := NIL;

      PROCEND move_file_to_new_destination;
?? OLDTITLE, EJECT ??

    /acquire_modified_output/
      WHILE jmp$modified_output_exists (jmc$qtf_usage) DO
        jmp$acquire_modified_output (jmc$qtf_usage, modified_output_descriptor, local_status);
        IF local_status.normal THEN
          find_file_and_destination (modified_output_descriptor.system_file_name, destination_list,
                current_destination, modified_file);
          IF (modified_file = NIL) OR (modified_file^.application_file_descriptor.file_kind <>
                nfc$output_file) THEN

{  INTERNAL QTFC ERROR

            pmp$log('***QTF: Internal error processing modified output file. Proceeding to next file.',
                  local_status);

            CYCLE /acquire_modified_output/; {----->
          ELSEIF  modified_file^.application_file_descriptor.output_descriptor.output_destination <>
                modified_output_descriptor.output_destination THEN
            get_destination (modified_output_descriptor.output_destination, store_forward_file_info,
                  destination_list, new_file_destination);
            move_file_to_new_destination (modified_file, current_destination^, new_file_destination^);
          IFEND;
          modified_file^.application_file_descriptor.output_descriptor := modified_output_descriptor;
          modified_file^.transfer_state := nfc$ready_to_transfer;
        ELSE
          nap$display_message (local_status);
          EXIT /acquire_modified_output/; {----->
        IFEND;
      WHILEND /acquire_modified_output/;

    /acquire_modified_input/
      WHILE jmp$modified_input_exists (jmc$qtf_usage) DO
        jmp$acquire_modified_input (jmc$qtf_usage, modified_input_descriptor, local_status);
        IF local_status.normal THEN
          find_file_and_destination (modified_input_descriptor.system_job_name, destination_list,
                current_destination, modified_file);
          IF (modified_file = NIL) OR (modified_file^.application_file_descriptor.file_kind <> nfc$input_file)
                THEN

{  INTERNAL QTFC ERROR

            pmp$log('***QTF: Internal error processing modified input file. Proceeding to next file.',
                  local_status);

            CYCLE /acquire_modified_input/; {----->
          ELSEIF  modified_file^.application_file_descriptor.input_descriptor.job_destination_family <>
                modified_input_descriptor.job_destination_family THEN
            get_destination (modified_input_descriptor.job_destination_family, store_forward_file_info,
                  destination_list, new_file_destination);
            move_file_to_new_destination (modified_file, current_destination^, new_file_destination^);
          IFEND;
          modified_file^.application_file_descriptor.input_descriptor := modified_input_descriptor;
          modified_file^.transfer_state := nfc$ready_to_transfer;
        ELSE
          nap$display_message (local_status);
          EXIT /acquire_modified_input/; {----->
        IFEND;
      WHILEND /acquire_modified_input/;

      IF jmp$modified_qfile_exists (nfc$qtf_namve_client_name) THEN

        PUSH generic_attribute_keys: [1 .. 2];
        generic_attribute_keys^[1] := jmc$destination;
        generic_attribute_keys^[2] := jmc$remote_host_directive;

        jmp$get_result_size(1, #SEQ(generic_attribute_keys^), generic_work_area_size);

        ALLOCATE generic_attribute_work_area: [[REP generic_work_area_size OF CELL]];

       /acquire_modified_generic/
        WHILE jmp$modified_qfile_exists (nfc$qtf_namve_client_name) DO
          jmp$acquire_modified_qfile (nfc$qtf_namve_client_name, generic_attribute_keys,
                generic_attribute_work_area, generic_attribute_results,
                modified_generic_descriptor.system_file_name, local_status);
          IF local_status.normal THEN

{ Move the generic attributes from the JMT$QFILE_ATTRIBUTE_RESULTS data structure to the
{ NFT$GENERIC_QFILE_DESCRIPTOR's data structure.

            modified_generic_descriptor.destination := generic_attribute_results^[1]^[1].destination;
            modified_generic_descriptor.remote_host_directive :=
                  generic_attribute_results^[1]^[2].remote_host_directive^;

            find_file_and_destination (modified_generic_descriptor.system_file_name, destination_list,
                  current_destination, modified_file);
            IF (modified_file^.application_file_descriptor.file_kind <> nfc$generic_file) OR
                  (modified_file = NIL) THEN

{ INTERNAL QTFC ERROR

          pmp$log('***QTF: Internal error processing modified generic file. Proceeding to next file.',
                  local_status);

              RESET generic_attribute_work_area;
              CYCLE /acquire_modified_generic/;

            ELSEIF  modified_file^.application_file_descriptor.generic_descriptor.destination <>
                  modified_generic_descriptor.destination THEN
              get_destination (modified_generic_descriptor.destination, store_forward_file_info,
                    destination_list, new_file_destination);
              move_file_to_new_destination (modified_file, current_destination^, new_file_destination^);
            IFEND;
            modified_file^.application_file_descriptor.generic_descriptor := modified_generic_descriptor;
            modified_file^.transfer_state := nfc$ready_to_transfer;
          ELSE
            nap$display_message (local_status);
            EXIT /acquire_modified_generic/;
          IFEND;

          RESET generic_attribute_work_area;
        WHILEND /acquire_modified_generic/;

        FREE generic_attribute_work_area;
      IFEND;

    PROCEND acquire_modified_files;
?? TITLE := 'acquire_new_files', EJECT ??

{ PURPOSE:
{   This procedure gets all the new output, input, and generic queue files
{   from QFM and removes the files from the internal tables.

    PROCEDURE acquire_new_files
      (    generic_q_password: jmt$queue_file_password;
           input_q_password: jmt$queue_file_password;
           output_q_password: jmt$queue_file_password;
           store_forward_file_info: nft$store_forward_file_info;
       VAR destination_list: ^nft$qtfc_destination);

      VAR
        destination: ^nft$qtfc_destination,
        generic_attribute_keys: ^jmt$qfile_attribute_keys,
        generic_attribute_results: ^jmt$qfile_attribute_results,
        generic_attribute_work_area: ^jmt$work_area,
        generic_descriptor: nft$generic_descriptor,
        generic_work_area_size: ost$segment_length,
        input_descriptor: jmt$input_descriptor,
        local_status: ost$status,
        message: STRING (256),
        message_length: integer,
        new_qtf_file: nft$qtfc_file,
        output_descriptor: jmt$output_descriptor;

?? NEWTITLE := 'add_file_to_dest_file_list', EJECT ??

{ PURPOSE:
{   This procedure adds a file record to the end of the destination
{   file list and changes the last file pointer of the destination
{   to the new file.

      PROCEDURE add_file_to_dest_file_list
        (    qtf_file: nft$qtfc_file;
         VAR destination: ^nft$qtfc_destination);

        VAR
          new_file: ^nft$qtfc_file;

        ALLOCATE new_file;
        new_file^ := qtf_file;

        IF destination^.file_list = NIL THEN
          destination^.file_list := new_file;
        IFEND;
        IF destination^.last_file <> NIL THEN
          destination^.last_file^.link := new_file;
          new_file^.back_link := destination^.last_file;
        IFEND;
        destination^.last_file := new_file;

      PROCEND add_file_to_dest_file_list;
?? OLDTITLE, EJECT ??
      new_qtf_file.back_link := NIL;
      new_qtf_file.link := NIL;
      new_qtf_file.transfer_state := nfc$ready_to_transfer;
      new_qtf_file.application_file_descriptor.q_file_password := output_q_password;
      new_qtf_file.application_file_descriptor.file_kind := nfc$output_file;

    /acquire_new_output/
      WHILE jmp$new_output_exists (jmc$qtf_usage) DO
        jmp$acquire_new_output (jmc$qtf_usage, output_descriptor, local_status);
        IF local_status.normal THEN
          new_qtf_file.name := output_descriptor.system_file_name;
          new_qtf_file.application_file_descriptor.output_descriptor := output_descriptor;

          get_destination (output_descriptor.output_destination, store_forward_file_info,
                  destination_list, destination);
          add_file_to_dest_file_list (new_qtf_file, destination);
        ELSE
          nap$display_message (local_status);
          EXIT /acquire_new_output/; {----->
        IFEND;
      WHILEND /acquire_new_output/;

      new_qtf_file.application_file_descriptor.q_file_password := input_q_password;
      new_qtf_file.application_file_descriptor.file_kind := nfc$input_file;

    /acquire_new_input/
      WHILE jmp$new_input_exists (jmc$qtf_usage) DO
        jmp$acquire_new_input (jmc$qtf_usage, input_descriptor, local_status);
        IF local_status.normal THEN
          new_qtf_file.name := input_descriptor.system_job_name;
          new_qtf_file.application_file_descriptor.input_descriptor := input_descriptor;

          get_destination (input_descriptor.job_destination_family, store_forward_file_info,
                  destination_list, destination);
          add_file_to_dest_file_list (new_qtf_file, destination);
        ELSE
          nap$display_message (local_status);
          EXIT /acquire_new_input/; {----->
        IFEND;
      WHILEND /acquire_new_input/;

      IF jmp$new_qfile_exists (nfc$qtf_namve_client_name) THEN

        new_qtf_file.application_file_descriptor.file_kind := nfc$generic_file;
        new_qtf_file.application_file_descriptor.q_file_password := generic_q_password;

        PUSH generic_attribute_keys: [1 .. 2];
        generic_attribute_keys^[1] := jmc$destination;
        generic_attribute_keys^[2] := jmc$remote_host_directive;

        jmp$get_result_size(1, #SEQ(generic_attribute_keys^), generic_work_area_size);

        ALLOCATE generic_attribute_work_area: [[REP generic_work_area_size OF CELL]];

        /acquire_new_generic/
        WHILE jmp$new_qfile_exists (nfc$qtf_namve_client_name) DO
          jmp$acquire_new_qfile (nfc$qtf_namve_client_name, generic_attribute_keys,
                generic_attribute_work_area, generic_attribute_results, generic_descriptor.system_file_name,
                local_status);
          IF local_status.normal THEN
            new_qtf_file.name := generic_descriptor.system_file_name;

            generic_descriptor.destination := generic_attribute_results^[1]^[1].destination;

            generic_descriptor.remote_host_directive.parameters :=
                  generic_attribute_results^[1]^[2].remote_host_directive^.parameters;
            generic_descriptor.remote_host_directive.size :=
                  generic_attribute_results^[1]^[2].remote_host_directive^.size;

            IF (#SIZE(generic_descriptor.destination) > 0) AND
                  (generic_descriptor.remote_host_directive.size > 0) THEN
              new_qtf_file.application_file_descriptor.generic_descriptor := generic_descriptor;

              get_destination (generic_descriptor.destination, store_forward_file_info,
                      destination_list, destination);

              add_file_to_dest_file_list (new_qtf_file, destination);
            ELSE

{ The queue file can not be processed because the DESTINATION or REMOTE_HOST_DIRECTIVE was missing.

              STRINGREP(message, message_length, 'Queue file ', generic_descriptor.system_file_name,
                    ' was terminated. DESTINATION or REMOTE_HOST_DIRECTIVE not supplied');
              pmp$log(message(1, message_length), local_status);
              jmp$set_qfile_completed (nfc$qtf_namve_client_name, generic_descriptor.system_file_name,
                    {transfer_complete=} TRUE, local_status);
            IFEND;
          ELSE
            nap$display_message (local_status);
            jmp$set_qfile_completed (nfc$qtf_namve_client_name, generic_descriptor.system_file_name,
                  {transfer_complete=} FALSE, local_status);
            EXIT /acquire_new_generic/;
          IFEND;

          RESET generic_attribute_work_area;

        WHILEND /acquire_new_generic/;

        FREE generic_attribute_work_area;

      IFEND;
    PROCEND acquire_new_files;
?? TITLE := 'get_destination', EJECT ??

{ PURPOSE:
{   This procedure will try to find the destination entry in the list
{   or create a new entry if nothing is found.

    PROCEDURE get_destination
      (    name: ost$name;
           store_forward_file_info: nft$store_forward_file_info;
       VAR destination_list: ^nft$qtfc_destination;
       VAR destination: ^nft$qtfc_destination);

      VAR
        destination_found: boolean;

?? NEWTITLE := 'add_destination_to_list', EJECT ??

{ PURPOSE:
{   This procedure adds a new destination record to the beginning of
{   the destination list.  The new destination record is initialized.

      PROCEDURE add_destination_to_list
        (    name: ost$name;
             store_forward_file_info: nft$store_forward_file_info;
         VAR new_dest: ^nft$qtfc_destination;
         VAR destination_list: ^nft$qtfc_destination);

      VAR
        destination_name: nft$parameter_24_definition,
        ignore_status: ost$status,
        new_target_name: nft$parameter_24_definition,
        target_name_changed: boolean;

        ALLOCATE new_dest;
        new_dest^.back_link := NIL;
        new_dest^.link := NIL;
        new_dest^.name := name;
        new_dest^.next_destination_name.value := osc$null_name;
        new_dest^.next_destination_name.size := nfc$p24_min_param_size;
        new_dest^.file_list := NIL;
        new_dest^.last_file := NIL;
        new_dest^.retry_timer.timer_set := FALSE;
        new_dest^.retry_timer.last_checked := 0;
        new_dest^.retry_timer.time_interval := 0;
        new_dest^.rhfam_timer.timer_set := FALSE;
        new_dest^.rhfam_timer.last_checked := 0;
        new_dest^.rhfam_timer.time_interval := 0;
        new_dest^.transfering_task := NIL;
        new_dest^.translation_request := NIL;

        IF store_forward_file_info.file_open THEN
          destination_name.value := name;
          destination_name.size := clp$trimmed_string_size (name);
          nfp$get_new_destination_name (nfc$sf_qtf_initiator, store_forward_file_info, destination_name,
                target_name_changed, new_target_name, ignore_status);

          IF target_name_changed THEN
            new_dest^.next_destination_name := new_target_name;
          IFEND;
        IFEND;

        IF destination_list <> NIL THEN
          new_dest^.link := destination_list;
          destination_list^.back_link := new_dest;
        IFEND;
        destination_list := new_dest;

      PROCEND add_destination_to_list;
?? OLDTITLE, EJECT ??
      find_destination (name, destination_list, destination, destination_found);

      IF NOT destination_found THEN
        add_destination_to_list (name, store_forward_file_info, destination, destination_list);
      IFEND;

    PROCEND get_destination;
?? OLDTITLE, EJECT ??
    acquire_terminated_files (destination_list);

    acquire_modified_files (store_forward_file_info, destination_list);

    acquire_new_files (generic_q_password, input_q_password, output_q_password, store_forward_file_info,
          destination_list);

  PROCEND acquire_all_q_files;
?? TITLE := 'add_item_to_wait_list', EJECT ??

{ PURPOSE:
{   This procedure adds items to the wait list used by
{   osp$i_await_activity_completion.

  PROCEDURE add_item_to_wait_list
    (    activity: ost$i_activity;
     VAR wait_list: ^ost$i_wait_list);

    VAR
      i: nft$wait_list_size,
      new_seq: ^SEQ ( * ),
      new_wait_list: ^ost$i_wait_list,
      wait_list_limit: nft$wait_list_size;


    wait_list_limit := UPPERBOUND (wait_list^);
    IF (wait_list_limit MOD nfc$wait_list_limit) <> 0 THEN
      RESET qtfc_wait_list_seq;
      NEXT wait_list: [1 .. (wait_list_limit + 1)] IN qtfc_wait_list_seq;
    ELSE
      ALLOCATE new_seq: [[REP (wait_list_limit + nfc$wait_list_limit) OF ost$i_activity]];
      RESET new_seq;
      NEXT new_wait_list: [1 .. (wait_list_limit + 1)] IN new_seq;

      FOR i := LOWERBOUND (wait_list^) TO (wait_list_limit) DO
        new_wait_list^ [i] := wait_list^ [i];
      FOREND;

      FREE qtfc_wait_list_seq;
      qtfc_wait_list_seq := new_seq;
      wait_list := new_wait_list;
    IFEND;

    wait_list^ [wait_list_limit + 1] := activity;

  PROCEND add_item_to_wait_list;
?? TITLE := 'build_namve_connect_data', EJECT ??

{ PURPOSE:
{   This procedure builds connection data for access into gateways
{   if there is user data with the translation.

  PROCEDURE build_namve_connect_data
    (    translation_attributes: ^nat$translation_attributes;
     VAR connection_attributes: ^nat$create_attributes;
     VAR status: ost$status);

    CONST
      nfc$nam_connect_non_cdna = 1,
      nfc$nam_connect_gateway = 2,
      nfc$connect_version_gateway = 1,
      nfc$minimum_size_gat_version_1 = 4;

    TYPE
      gateway_connection_info = packed record
        version: 0 .. 255,
        key: string (2),
      recend;

    VAR
      gateway_connection_data: ^gateway_connection_info,
      user_info: ^string (nac$max_directory_data_length);

    status.normal := TRUE;
    connection_attributes := NIL;

    RESET translation_attributes^ [1].data;
    NEXT user_info IN translation_attributes^ [1].data;
    IF translation_attributes^ [1].data_length > 0 THEN
      IF $INTEGER (user_info^ (1, 1)) <> nfc$connect_version_gateway THEN
        osp$set_status_abnormal (nfc$status_id, nfe$incompatible_address_kind, 'user info version incorrect',
              status);
        nap$display_message (status);
      ELSEIF translation_attributes^ [1].data_length < nfc$minimum_size_gat_version_1 THEN
        osp$set_status_abnormal (nfc$status_id, nfe$incompatible_address_kind,
              'user info for version incorrect length', status);
        nap$display_message (status);
      ELSE
        ALLOCATE connection_attributes: [1 .. 1];
        connection_attributes^ [1].kind := nac$connect_data;
        ALLOCATE connection_attributes^ [1].connect_data: [[REP 1 OF gateway_connection_info]];
        RESET connection_attributes^ [1].connect_data;
        NEXT gateway_connection_data IN connection_attributes^ [1].connect_data;
        gateway_connection_data^.version := nfc$nam_connect_gateway;
        gateway_connection_data^.key := user_info^ (3, 2);
      IFEND;
    IFEND;

  PROCEND build_namve_connect_data;
?? TITLE := 'check_namve_client_status', EJECT ??

{ PURPOSE:
{   This procedure will be called whenever the namve availability
{   timer is up to see if the MANNA application client definition is
{   active.  If it isn't, the timer gets restarted.

  PROCEDURE check_namve_client_status
    (    destination_list: ^nft$qtfc_destination;
     VAR namve_availability: nft$network_availability);

    CONST
      qtf_title_length = qtf_title_part_length + osc$max_name_size,
      qtf_title_part = 'QTFS$',
      qtf_title_part_length = 5;

    VAR
      local_status: ost$status,
      title: ^nat$title_pattern,
      translation_request_id: nat$directory_search_identifier;

    local_status.normal := TRUE;

    IF destination_list <> NIL THEN
      PUSH title: [qtf_title_length];
      title^ (1, qtf_title_part_length) := qtf_title_part;
      title^ (qtf_title_part_length + 1, * ) := destination_list^.name;
      nap$begin_directory_search (title^, nfc$qtf_namve_client_name, {recurrent_search=} FALSE,
            translation_request_id, local_status);
      namve_availability.available := local_status.normal;
    IFEND;

    IF namve_availability.available THEN
      get_activation_date_time (namve_availability.time_stamp);
    ELSE
      nfp$start_timer (0, namve_availability.timer);
    IFEND;

  PROCEND check_namve_client_status;
?? TITLE := 'check_rhfam_sign_on', EJECT ??

{ PURPOSE:
{   This procedure will be called to see if RHFAM is available
{   on the system this task is running on.  If it isn't, the
{   timer gets started or started again.

  PROCEDURE check_rhfam_sign_on
    (VAR rhfam_availability: nft$network_availability;
     VAR rhfam_host_pid: rft$physical_identifier);

    VAR
      ignore_status: ost$status,
      maximum_rhf_connections: rft$application_connections,
      rhfam_status: ost$status;

    maximum_rhf_connections := 0;          {  Really this means unlimited. }
    rfp$application_sign_on (nfc$qtf_rhfam_client_name, rfc$client, maximum_rhf_connections, rhfam_status);
    IF rhfam_status.normal THEN

{ This call is made to get what the PID is defined as in the RHFAM configuration.

      rfp$get_local_host_physical_id (rhfam_host_pid, rhfam_status);
    IFEND;

    rhfam_availability.available := rhfam_status.normal;
    IF rhfam_availability.available THEN
      get_activation_date_time (rhfam_availability.time_stamp);
    ELSE
      rfp$application_sign_off (nfc$qtf_rhfam_client_name, ignore_status);
      nfp$start_timer (0, rhfam_availability.timer);
    IFEND;

  PROCEND check_rhfam_sign_on;
?? TITLE := 'delete_destination_from_list', EJECT ??

{ PURPOSE:
{   This procedure will delete the given destination from the
{   destination list.  Upon exit, DESTINATION = NIL.

  PROCEDURE delete_destination_from_list
    (VAR destination: ^nft$qtfc_destination;
     VAR destination_list: ^nft$qtfc_destination;
     VAR wait_list: ^ost$i_wait_list);

    VAR
      next_destination: ^nft$qtfc_destination,
      prior_destination: ^nft$qtfc_destination;

    find_and_delete_title_request (destination, destination_list, wait_list);

    prior_destination := destination^.back_link;
    next_destination := destination^.link;

    IF prior_destination <> NIL THEN
      prior_destination^.link := destination^.link;
    IFEND;

    IF next_destination <> NIL THEN
      next_destination^.back_link := destination^.back_link;
    IFEND;

    IF destination_list = destination THEN
      destination_list := destination^.link;
    IFEND;

    FREE destination;

  PROCEND delete_destination_from_list;
?? TITLE := 'delete_file_from_file_list', EJECT ??

{ PURPOSE:
{   This procedure deletes the specified file from the specified file
{   list.  When this procedure exits, DELETED_FILE = NIL.

  PROCEDURE delete_file_from_file_list
    (VAR deleted_file: ^nft$qtfc_file;
     VAR file_list: ^nft$qtfc_file;
     VAR last_file: ^nft$qtfc_file);

    VAR
      back_link_file: ^nft$qtfc_file,
      link_file: ^nft$qtfc_file;

    back_link_file := deleted_file^.back_link;
    link_file := deleted_file^.link;

    IF back_link_file <> NIL THEN
      back_link_file^.link := deleted_file^.link;
    IFEND;

    IF link_file <> NIL THEN
      link_file^.back_link := deleted_file^.back_link;
    IFEND;

    IF deleted_file = file_list THEN
      file_list := deleted_file^.link;
    IFEND;

    IF deleted_file = last_file THEN
      last_file := deleted_file^.back_link;
    IFEND;

    FREE deleted_file;

  PROCEND delete_file_from_file_list;
?? TITLE := 'delete_item_from_wait_list', EJECT ??

{ PURPOSE:
{   This procedure removes activity items from the wait list used
{   by osp$i_await_activity_completion.
{
{ NOTES:
{   The parameter INDEX is an integer because of OSP$I_AWAIT_ACTIVITY_COMPLETION.
{
{   4 is used because the first 2 activities in the wait list should
{   always be in the wait list.  If last_index = 3 then the last
{   activity is just removed.  INDEX should never be 1 or 2.

  PROCEDURE delete_item_from_wait_list
    (    destination_list: ^nft$qtfc_destination;
         index: integer;
     VAR wait_list: ^ost$i_wait_list);

    VAR
      destination: ^nft$qtfc_destination,
      last_index: nft$wait_list_size;

    last_index := UPPERBOUND (wait_list^);

    IF (last_index >= 4) AND (last_index <> index) THEN
      wait_list^ [index] := wait_list^ [last_index];

{ update the destination_list pointer to the outstanding title translation request

      destination := destination_list;

   /update_destination_title_req/
      WHILE destination <> NIL DO
        IF destination^.translation_request <> NIL THEN
          IF wait_list^ [last_index].translation_request = destination^.translation_request^
                .translation_request THEN
            destination^.translation_request := ^wait_list^ [index];
            EXIT /update_destination_title_req/;
          IFEND;
        IFEND;
        destination := destination^.link;
      WHILEND /update_destination_title_req/;
    IFEND;

    wait_list^ [last_index].activity := osc$i_null_activity;
    RESET qtfc_wait_list_seq;
    NEXT wait_list: [1 .. (last_index - 1)] IN qtfc_wait_list_seq;

  PROCEND delete_item_from_wait_list;
?? TITLE := 'establish_server_connection', EJECT ??

{ PURPOSE:
{   This procedure is called to set up a connection with the remote destination.

  PROCEDURE establish_server_connection
    (    destination: ^nft$qtfc_destination;
         destination_list: ^nft$qtfc_destination;
     VAR rhfam_availability: nft$network_availability;
     VAR namve_availability: nft$network_availability;
     VAR connection: nft$qtf_connection;
     VAR wait_list: ^ost$i_wait_list);

    VAR
      connection_status: ost$status,
      ignore_status: ost$status,
      latest_time_check: nft$micro_second,
      unique_name: ost$name;

?? NEWTITLE := 'establish_namve_connection', EJECT ??

{ PURPOSE:
{   This procedure does all the initial steps to set up a NAM/VE
{   connection with a QTF Server on a remote system.  If the QTFS on
{   the remote system is found through the title translation, a call
{   is made request_namve_connection to finish establishing the
{   connection.

    PROCEDURE establish_namve_connection
      (    destination: ^nft$qtfc_destination;
       VAR connection: nft$qtf_connection;
       VAR wait_list: ^ost$i_wait_list;
       VAR namve_availability: nft$network_availability;
       VAR status: ost$status);

      CONST
        translation_wait_time = 15000;      { milliseconds }

      VAR
        activity: ost$i_activity,
        connection_attributes: ^nat$create_attributes,
        directory_data: ^nat$directory_data,
        error_message_string: string(132),
        error_message_string_length: integer,
        ignore_status: ost$status,
        translation_address: nat$network_address,
        translation_attributes: ^nat$translation_attributes,
        translation_request_id: nat$directory_search_identifier;

      status.normal := TRUE;

      IF destination^.next_destination_name.value = osc$null_name THEN
        issue_title_translation (destination^.name, translation_request_id, namve_availability, status);
      ELSE
         issue_title_translation (destination^.next_destination_name.value, translation_request_id,
               namve_availability, status);
      IFEND;
      IF status.normal THEN
        PUSH directory_data: [[REP nac$max_directory_data_length OF cell]];
        PUSH translation_attributes: [1 .. 1];
        translation_attributes^ [1].selector := nac$translation_data;
        translation_attributes^ [1].data := directory_data;
        nap$get_title_translation (translation_request_id, translation_wait_time, translation_attributes,
              translation_address, status);
        IF status.normal THEN
          nap$end_directory_search (translation_request_id, ignore_status);

          build_namve_connect_data (translation_attributes, connection_attributes, status);
          IF status.normal THEN
            request_namve_connection (translation_address, connection_attributes, connection, status);
            IF NOT status.normal THEN
              amp$return (connection.file_name, ignore_status);
              connection.kind := nfc$unknown_network;
              IF (status.condition = nae$unknown_application) OR
                    (status.condition = nae$application_inactive) OR
                    (status.condition = nae$network_inactive) THEN
                namve_availability.available := FALSE;
                nfp$start_timer (nfc$one_minute, namve_availability.timer);
              ELSE

{ log the bad status to the SYSTEM's job_log and place this destination into a delayed retry condition
{ because the title translation was successful but the connection was not successful.

                IF destination^.next_destination_name.value = osc$null_name THEN
                  STRINGREP(error_message_string, error_message_string_length,
                        '***QTF/EstNC: Connection request failed for title ',
                        destination^.name(1, clp$trimmed_string_size(destination^.name)),
                        ' with the following status:');
                ELSE
                  STRINGREP(error_message_string, error_message_string_length,
                        '***QTF/EstNC: Connection request failed for title ',
                        destination^.next_destination_name.value(1, clp$trimmed_string_size(
                        destination^.next_destination_name.value)), ' with the following status:');
                IFEND;
                pmp$log (error_message_string(1, error_message_string_length), ignore_status);
                nap$display_message (status);

                nfp$start_timer (0, destination^.retry_timer);
              IFEND;
            IFEND;
          IFEND;
          IF connection_attributes <> NIL THEN
            FREE connection_attributes^ [1].connect_data;
            FREE connection_attributes;
          IFEND;
        ELSE
          activity.activity := nac$i_await_title_translation;
          activity.translation_request := translation_request_id;
          add_item_to_wait_list (activity, wait_list);
          destination^.translation_request := ^wait_list^ [UPPERBOUND (wait_list^)];
        IFEND;
      IFEND;

    PROCEND establish_namve_connection;
?? TITLE := 'establish_rhfam_connection', EJECT ??

{ PURPOSE:
{   This procedure does all the initial steps to set up a RHFAM
{   connection with a QTF Server on a remote system.  If the QTFS on
{   the remote system is found through the title translation, a call
{   is made request_rhfam_connection to finish establishing the
{   connection.

    PROCEDURE establish_rhfam_connection
      (    destination: ^nft$qtfc_destination;
       VAR connection: nft$qtf_connection;
       VAR rhfam_availability: nft$network_availability;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status;

      status.normal := TRUE;

      IF destination^.next_destination_name.value = osc$null_name THEN
        request_rhfam_connection (destination^.name, connection, status);
      ELSE
        request_rhfam_connection (destination^.next_destination_name.value, connection, status);
      IFEND;
      IF (NOT status.normal) AND (status.condition = rfe$system_task_not_active) THEN
        rhfam_availability.available := FALSE;
        amp$return (connection.file_name, ignore_status);
        connection.kind := nfc$unknown_network;
        rfp$application_sign_off (nfc$qtf_rhfam_client_name, ignore_status);
        nfp$start_timer (0, rhfam_availability.timer);
      ELSEIF NOT status.normal THEN
        amp$return (connection.file_name, ignore_status);
        connection.kind := nfc$unknown_network;
        nfp$start_timer (nfc$one_minute, destination^.rhfam_timer);
      ELSE
        destination^.rhfam_timer.timer_set := FALSE;
        destination^.rhfam_timer.last_checked := 0;
        destination^.rhfam_timer.time_interval := 0;
      IFEND;

    PROCEND establish_rhfam_connection;
?? OLDTITLE, EJECT ??
    latest_time_check := #FREE_RUNNING_CLOCK (0);

    pmp$get_unique_name (unique_name, ignore_status);
    connection.file_name := unique_name;
    connection.kind := nfc$unknown_network;

    IF rhfam_availability.available AND nfp$timer_expired (destination^.rhfam_timer, latest_time_check) THEN
      establish_rhfam_connection (destination, connection, rhfam_availability, connection_status);
      IF connection_status.normal THEN
        find_and_delete_title_request (destination, destination_list, wait_list);
      IFEND;
    IFEND;
    IF (connection.kind = nfc$unknown_network) AND (destination^.translation_request = NIL) AND
          namve_availability.available THEN
      establish_namve_connection (destination, connection, wait_list, namve_availability,
            connection_status);
    IFEND;

  PROCEND establish_server_connection;
?? TITLE := 'find_and_delete_title_request', EJECT ??

{ PURPOSE:
{   This procedure will find the title request for this destination in the
{   wait list and delete it.  Upon exit, DESTINATION.TRANSLATION_REQUEST = NIL.

  PROCEDURE find_and_delete_title_request
    (    destination: ^nft$qtfc_destination;
         destination_list: ^nft$qtfc_destination;
     VAR wait_list: ^ost$i_wait_list);

    CONST
      first_element = 3;

    VAR
      found: boolean,
      ignore_status: ost$status,
      index: nft$wait_list_size,
      last_index: nft$wait_list_size;

    IF destination^.translation_request <> NIL THEN
      IF destination^.translation_request^.activity = nac$i_await_title_translation THEN
        nap$end_directory_search (destination^.translation_request^.translation_request, ignore_status);

        found := FALSE;
        index := first_element;
        last_index := UPPERBOUND(wait_list^);

        REPEAT
          IF ((wait_list^[index].activity = nac$i_await_title_translation) AND
                (destination^.translation_request^.translation_request =
                wait_list^ [index].translation_request)) THEN
            delete_item_from_wait_list (destination_list, index, wait_list);
            found := TRUE;
          IFEND;
          index := index + 1;
        UNTIL found OR (index > last_index);
      IFEND;
      destination^.translation_request := NIL;
    IFEND;
  PROCEND find_and_delete_title_request;
?? TITLE := 'find_destination', EJECT ??

{ PURPOSE:
{   Given a name, this procedure will attempt to find a destination
{   with that name in the destination list.

  PROCEDURE find_destination
    (    destination_name: ost$name;
         destination_list: ^nft$qtfc_destination;
     VAR destination: ^nft$qtfc_destination;
     VAR destination_found: boolean);

    destination := destination_list;
    destination_found := FALSE;

    WHILE (NOT destination_found) AND (destination <> NIL) DO
      destination_found := destination_name = destination^.name;
      IF NOT destination_found THEN
        destination := destination^.link;
      IFEND;
    WHILEND;

  PROCEND find_destination;
?? TITLE := 'find_file_and_destination', EJECT ??

{ PURPOSE:
{   This procedure finds a file and the destination it belongs to
{   using the system supplied file name.

  PROCEDURE find_file_and_destination
    (    system_file_name: jmt$system_supplied_name;
         destination_list: ^nft$qtfc_destination;
     VAR destination: ^nft$qtfc_destination;
     VAR requested_file: ^nft$qtfc_file);

    VAR
      file_found: boolean;

    file_found := FALSE;

    destination := destination_list;
    WHILE (NOT file_found) AND (destination <> NIL) DO
      requested_file := destination^.file_list;

      WHILE (NOT file_found) AND (requested_file <> NIL) DO
        file_found := system_file_name = requested_file^.name;
        IF NOT file_found THEN
          requested_file := requested_file^.link;
        IFEND;
      WHILEND;

      IF NOT file_found THEN
        destination := destination^.link;
      IFEND;
    WHILEND;

  PROCEND find_file_and_destination;
?? TITLE := 'get_activation_date_time', EJECT ??

{ PURPOSE:
{   This procedure will get the current date and time in a coded format.

  PROCEDURE get_activation_date_time (VAR activation_date_time: nft$bcd_time);

    VAR
      date_time: ost$date_time,
      ignore_status: ost$status;

    pmp$get_compact_date_time (date_time, ignore_status);

    activation_date_time.date.year1 := (date_time.year MOD 100) DIV 10;
    activation_date_time.date.year2 := date_time.year MOD 10;
    activation_date_time.date.month1 := date_time.month DIV 10;
    activation_date_time.date.month2 := date_time.month MOD 10;
    activation_date_time.date.day1 := date_time.day DIV 10;
    activation_date_time.date.day2 := date_time.day MOD 10;
    activation_date_time.time.hours1 := date_time.hour DIV 10;
    activation_date_time.time.hours2 := date_time.hour MOD 10;
    activation_date_time.time.minutes1 := date_time.minute DIV 10;
    activation_date_time.time.minutes2 := date_time.minute MOD 10;
    activation_date_time.time.seconds1 := date_time.second DIV 10;
    activation_date_time.time.seconds2 := date_time.second MOD 10;
    activation_date_time.time.milliseconds1 := date_time.millisecond DIV 100;
    activation_date_time.time.milliseconds2 := (date_time.millisecond MOD 100) DIV 10;
    activation_date_time.time.milliseconds3 := date_time.millisecond MOD 10;
    activation_date_time.time.fill := 0;

  PROCEND get_activation_date_time;
?? TITLE := 'issue_title_translation', EJECT ??

{ PURPOSE:
{   This procedure will issue a title translation request for the
{   given destination name.  If the client application has been
{   deactivated or does not exsist, NAM/VE will be considered un-
{   available.

  PROCEDURE issue_title_translation
    (    destination_name: ost$name;
     VAR translation_request_id: nat$directory_search_identifier;
     VAR namve_availability: nft$network_availability;
     VAR status: ost$status);

    CONST
      qtf_title_length = qtf_title_part_length + osc$max_name_size,
      qtf_title_part = 'QTFS$',
      qtf_title_part_length = 5;

    VAR
      title: ^nat$title_pattern;

    status.normal := TRUE;

    PUSH title: [qtf_title_length];
    title^ (1, qtf_title_part_length) := qtf_title_part;
    title^ (qtf_title_part_length + 1, * ) := destination_name;
    nap$begin_directory_search (title^, nfc$qtf_namve_client_name, {recurrent_search=} TRUE,
          translation_request_id, status);
    IF (NOT status.normal) AND ((status.condition = nae$unknown_application) OR
          (status.condition = nae$application_inactive) OR (status.condition = nae$network_inactive)) THEN
      namve_availability.available := FALSE;
      nfp$start_timer (nfc$one_minute, namve_availability.timer);
    IFEND;

  PROCEND issue_title_translation;
?? TITLE := 'process_intertask_message', EJECT ??

{ PURPOSE:
{   This procedure receives messages from the QTFI tasks.  Based on
{   what the message indicates, this procedure will take the appropriate
{   action and probably send a message back to the QTFI task.

  PROCEDURE process_intertask_message
    (    destination_list: ^nft$qtfc_destination;
         namve_host_pid: ost$name;
         rhfam_host_pid: rft$physical_identifier;
         store_forward_file_info: nft$store_forward_file_info;
     VAR namve_availability: nft$network_availability;
     VAR number_of_running_qtfi_tasks: ost$non_negative_integers;
     VAR rhfam_availability: nft$network_availability;
     VAR wait_list: ^ost$i_wait_list;
     VAR single_transfer_per_connection: boolean);

    CONST
      decrement_task_count = TRUE,
      free_task_information = TRUE,
      keep_task_information = FALSE,
      no_decrement_task_count = FALSE;

    VAR
      connection: nft$qtf_connection,
      current_task: ^nft$qtfi_task,
      destination: ^nft$qtfc_destination,
      ignore_status: ost$status,
      new_destination: ^nft$qtfc_destination,
      new_destination_task: ^nft$qtfi_task,
      task_msg: nft$intertask_message,
      task_msg_size: nft$intertask_transfer_size,
      transfer_count: nft$intertask_transfer_size,
      transfer_file: ^nft$qtfc_file,
      status: ost$status;
?? NEWTITLE := 'decode_file_transfer_status', EJECT ??

{ PURPOSE:
{   This procedure is given a file transfer status message and decides
{   what actions to take based on the file transfer status.

    PROCEDURE decode_file_transfer_status
      (    task_msg: nft$intertask_message;
           destination: ^nft$qtfc_destination;
           current_task: ^nft$qtfi_task;
           namve_host_pid: ost$name;
           rhfam_host_pid: rft$physical_identifier;
           store_forward_file_info: nft$store_forward_file_info;
           single_transfer_per_connection: boolean;
       VAR status: ost$status);

      VAR
        new_transfer_file: ^nft$qtfc_file,
        normal_transfer_complete: boolean,
        transferred_file: ^nft$qtfc_file;

      status.normal := TRUE;

      transferred_file := current_task^.file_in_transfer;
      IF transferred_file <> NIL THEN
        IF transferred_file^.name <> task_msg.qtf_system_file_name THEN

{ TROUBLE

          RETURN; {----->
        IFEND;

        normal_transfer_complete := (task_msg.qtf_transfer_status = nfc$qtf_transfer_complete) OR
              (task_msg.qtf_transfer_status = nfc$qtf_transfer_failed_noretry);
        CASE task_msg.qtf_transfer_status OF
        = nfc$qtf_transfer_complete, nfc$qtf_transfer_failed_noretry =
          IF single_transfer_per_connection THEN
            send_terminate_connection (current_task^.transfer_connection, current_task^.task_id,
                  current_task^.last_message_sent, status);
          ELSE
            select_file_for_transfer (destination, current_task^.transfer_connection, namve_host_pid,
                  rhfam_host_pid, store_forward_file_info, new_transfer_file);
            current_task^.file_in_transfer := new_transfer_file;
            IF new_transfer_file <> NIL THEN
              send_file_transfer_msg_to_task (new_transfer_file, current_task^.transfer_connection,
                    namve_host_pid, rhfam_host_pid, current_task^.task_id, current_task^.last_message_sent,
                    current_task^.file_transfer_start_time, status);
            ELSE
              send_terminate_connection (current_task^.transfer_connection, current_task^.task_id,
                    current_task^.last_message_sent, status);
            IFEND;
          IFEND;

        = nfc$qtf_transfer_failed_retry =
          send_terminate_connection (current_task^.transfer_connection, current_task^.task_id,
                current_task^.last_message_sent, status);

{ set up transferred file to attempt retry later.

          nfp$start_timer (0, destination^.retry_timer);

        = nfc$qtf_transfer_aborted =
          send_terminate_connection (current_task^.transfer_connection, current_task^.task_id,
                current_task^.last_message_sent, status);

        ELSE
          ;
        CASEND;
        notify_qfm_and_delete_file (normal_transfer_complete, transferred_file, destination^.file_list,
              destination^.last_file);
      ELSE

{ Send out error message. This file is in DEEP WEEDS.

      IFEND;

    PROCEND decode_file_transfer_status;
?? TITLE := 'notify_qfm_and_delete_file', EJECT ??

{ PURPOSE:
{   This procedure notifies QFM of the completion status of a file
{   that has been transfered.  The file will be deleted from QTFC's
{   internal tables.  QFM may give the same file back later to try
{   another transfer.

    PROCEDURE notify_qfm_and_delete_file
      (    transfer_complete: boolean;
       VAR transferred_file: ^nft$qtfc_file;
       VAR file_list: ^nft$qtfc_file;
       VAR last_file: ^nft$qtfc_file);

      VAR
        ignore_status: ost$status;

      IF transferred_file^.application_file_descriptor.file_kind = nfc$output_file THEN
        jmp$set_output_completed (jmc$qtf_usage, transferred_file^.name, transfer_complete, ignore_status);
      ELSEIF transferred_file^.application_file_descriptor.file_kind = nfc$input_file THEN
        jmp$set_input_completed (jmc$qtf_usage, transferred_file^.name, transfer_complete, ignore_status);
      ELSEIF transferred_file^.application_file_descriptor.file_kind = nfc$generic_file THEN
        jmp$set_qfile_completed (nfc$qtf_namve_client_name, transferred_file^.name, transfer_complete,
              ignore_status);
      IFEND;

      delete_file_from_file_list (transferred_file, destination^.file_list, destination^.last_file);

    PROCEND notify_qfm_and_delete_file;
?? TITLE := 'delete_qtfi_task', EJECT ??

{ PURPOSE:
{   This procedure will remove the specified QTFI task from the task
{   list because the task has terminated.
{
{ NOTES:
{   When this procedure returns, current task will point to the next
{   task entry in the task list.

    PROCEDURE delete_qtfi_task
      (    free_task_information: boolean;
           decrement_task_count: boolean;
       VAR current_task: ^nft$qtfi_task;
       VAR number_of_running_qtfi_tasks: ost$non_negative_integers;
       VAR qtfi_task_list: ^nft$qtfi_task);

      VAR
        next_task: ^nft$qtfi_task,
        prior_task_task: ^nft$qtfi_task,
        task_to_free: ^nft$qtfi_task;

      prior_task_task := current_task^.back_link;
      next_task := current_task^.link;
      task_to_free := current_task;

      IF prior_task_task <> NIL THEN
        prior_task_task^.link := current_task^.link;
      IFEND;

      IF next_task <> NIL THEN
        next_task^.back_link := current_task^.back_link;
      IFEND;

      IF qtfi_task_list = current_task THEN
        qtfi_task_list := current_task^.link;
      IFEND;

      IF free_task_information THEN
        FREE task_to_free;
      IFEND;

      IF decrement_task_count THEN
        number_of_running_qtfi_tasks := number_of_running_qtfi_tasks - 1;
      IFEND;
      current_task := next_task;

    PROCEND delete_qtfi_task;
?? TITLE := 'find_idle_destination', EJECT ??

{ PURPOSE:
{   This procedure finds a destination without a connection file and
{   no QTFI task.  This will be only be effective when there is a
{   limit on the number of QTFI tasks that can be running at the same
{   time.

    PROCEDURE find_idle_destination
      (    destination_list: ^nft$qtfc_destination;
       VAR connection: nft$qtf_connection;
       VAR namve_availability: nft$network_availability;
       VAR rhfam_availability: nft$network_availability;
       VAR destination: ^nft$qtfc_destination;
       VAR wait_list: ^ost$i_wait_list);

      VAR
        destination_found: boolean;

      destination_found := FALSE;
      destination := destination_list;
      WHILE (NOT destination_found) AND (destination <> NIL) DO
        destination_found := (destination^.transfering_task = NIL) AND
              (destination^.file_list <> NIL) AND (destination^.translation_request = NIL) AND
              nfp$timer_expired (destination^.retry_timer, #FREE_RUNNING_CLOCK (0));
        IF destination_found THEN
          destination^.retry_timer.timer_set := FALSE;
          destination^.retry_timer.last_checked := 0;
          destination^.retry_timer.time_interval := 0;

          establish_server_connection (destination, destination_list, rhfam_availability, namve_availability,
              connection, wait_list);
          destination_found := (connection.kind <> nfc$unknown_network);
        IFEND;
        IF NOT destination_found THEN
          destination := destination^.link;
        IFEND;
      WHILEND;

    PROCEND find_idle_destination;
?? TITLE := 'send_terminate_connection', EJECT ??

{ PURPOSE:
{   This procedure will send a message to a QTFI task telling the task
{   to close and return the connection.

    PROCEDURE send_terminate_connection
      (    connection: nft$qtf_connection;
           task_id: pmt$task_id;
       VAR last_message_sent: nft$intertask_message_kind;
       VAR status: ost$status);

      VAR
        qtfi_task_msg: nft$intertask_message,
        retry_count: nft$qtf_put_async_retry_range;

      status.normal := TRUE;
      qtfi_task_msg.kind := nfc$qtf_terminate_connection;
      qtfi_task_msg.connect_file_name := connection.file_name;
      retry_count := 0;

      REPEAT
        nfp$put_async_task_message (task_id, ^qtfi_task_msg, #SIZE (qtfi_task_msg), status);
        IF status.normal THEN
          last_message_sent := nfc$qtf_terminate_connection;
        ELSE
          pmp$wait (nfc$qtf_put_async_wait_time, nfc$qtf_put_async_wait_time);
          retry_count := retry_count + 1;
        IFEND;
      UNTIL (status.normal) OR (retry_count > nfc$qtf_put_async_max_retry);

    PROCEND send_terminate_connection;
?? TITLE := 'send_terminate_task_msg', EJECT ??

{ PURPOSE:
{   This procedure will send a message to a QTFI task telling the task
{   to terminate itself.

    PROCEDURE send_terminate_task_msg
      (    task_id: pmt$task_id;
       VAR last_message_sent: nft$intertask_message_kind;
       VAR status: ost$status);

      VAR
        qtfi_task_msg: nft$intertask_message,
        retry_count: nft$qtf_put_async_retry_range;

      status.normal := TRUE;
      qtfi_task_msg.kind := nfc$qtf_terminate_task;
      retry_count := 0;

      REPEAT
        nfp$put_async_task_message (task_id, ^qtfi_task_msg, #SIZE (qtfi_task_msg), status);
        IF status.normal THEN
          last_message_sent := nfc$qtf_terminate_task;
        ELSE
          pmp$wait (nfc$qtf_put_async_wait_time, nfc$qtf_put_async_wait_time);
          retry_count := retry_count + 1;
        IFEND;
      UNTIL (status.normal) OR (retry_count > nfc$qtf_put_async_max_retry);

    PROCEND send_terminate_task_msg;
?? OLDTITLE, EJECT ??
    task_msg_size := #SIZE (nft$intertask_message);
    destination := destination_list;
    WHILE destination <> NIL DO
      current_task := destination^.transfering_task;

{ All tasks have to be checked because there is no way of knowing which task
{ sent the intertask message.

      WHILE current_task <> NIL DO
        nfp$get_async_task_message (current_task^.task_id, ^task_msg, task_msg_size, 0, transfer_count,
              status);
        IF NOT status.normal THEN
          delete_qtfi_task (free_task_information, decrement_task_count, current_task,
                number_of_running_qtfi_tasks, destination^.transfering_task);
        ELSEIF (status.normal) AND (transfer_count > 0) THEN
          CASE task_msg.kind OF

{ These kinds of messages should not be received by QTFC or QTFI, they
{ are messages between BTF and SCF or NTF.

          = nfc$btf_file_transfer, nfc$btf_file_transfer_status,

{ These kinds of messages are sent to QTFI and should not be received.

          nfc$qtf_file_transfer, nfc$qtf_terminate_connection, nfc$qtf_terminate_task =
            current_task := current_task^.link;

          = nfc$qtf_file_transfer_status =
            IF NOT task_msg.qtf_task_status.normal THEN
              nap$display_message (task_msg.qtf_task_status);
            IFEND;
            current_task^.file_transfer_start_time := 0;
            decode_file_transfer_status (task_msg, destination, current_task, namve_host_pid,
                  rhfam_host_pid, store_forward_file_info, single_transfer_per_connection, status);
            current_task := current_task^.link;

          = nfc$qtf_connection_terminated =
            amp$return (current_task^.transfer_connection.file_name, ignore_status);
            current_task^.transfer_connection.file_name := osc$null_name;
            current_task^.transfer_connection.kind := nfc$unknown_network;

            find_idle_destination (destination_list, connection, namve_availability, rhfam_availability,
                  new_destination, wait_list);
            IF new_destination <> NIL THEN

{ Save the current task information from the old destination
{ so that it can be moved to the new (idle) destination

              new_destination_task := current_task;
              delete_qtfi_task (keep_task_information, no_decrement_task_count, current_task,
                    number_of_running_qtfi_tasks, destination^.transfering_task);
              new_destination_task^.back_link := NIL;
              new_destination_task^.link := NIL;
              new_destination_task^.file_in_transfer := NIL;
              new_destination_task^.file_transfer_start_time := 0;
              new_destination_task^.transfer_connection := connection;
              IF new_destination^.transfering_task <> NIL THEN
                new_destination^.transfering_task^.back_link := new_destination_task;
                new_destination_task^.link := new_destination^.transfering_task;
              IFEND;
              new_destination^.transfering_task := new_destination_task;

              select_file_for_transfer (new_destination, connection, namve_host_pid, rhfam_host_pid,
                    store_forward_file_info, transfer_file);
              new_destination_task^.file_in_transfer := transfer_file;
              IF transfer_file <> NIL THEN
                send_file_transfer_msg_to_task (transfer_file, new_destination_task^.transfer_connection,
                      namve_host_pid, rhfam_host_pid, new_destination_task^.task_id,
                      new_destination_task^.last_message_sent, new_destination_task^.file_transfer_start_time,
                      status);
              ELSE
                send_terminate_task_msg (new_destination_task^.task_id,
                      new_destination_task^.last_message_sent, status);
              IFEND;
            ELSE
              send_terminate_task_msg (current_task^.task_id, current_task^.last_message_sent, status);
              current_task := current_task^.link;
            IFEND;

          = nfc$qtf_task_terminated =
            delete_qtfi_task (free_task_information, decrement_task_count, current_task,
                  number_of_running_qtfi_tasks, destination^.transfering_task);

          = nfc$abnormal_child_task_abort =
            IF (current_task^.last_message_sent = nfc$qtf_file_transfer) AND (current_task^.file_in_transfer
                  <> NIL) THEN
              notify_qfm_and_delete_file (FALSE, current_task^.file_in_transfer, destination^.file_list,
                    destination^.last_file);
            IFEND;

            IF current_task^.transfer_connection.kind <> nfc$unknown_network THEN
              amp$return (current_task^.transfer_connection.file_name, ignore_status);
              current_task^.transfer_connection.file_name := osc$null_name;
              current_task^.transfer_connection.kind := nfc$unknown_network;
            IFEND;

            delete_qtfi_task (free_task_information, decrement_task_count, current_task,
                  number_of_running_qtfi_tasks, destination^.transfering_task);

          ELSE
            ;
          CASEND;
        ELSE
          current_task := current_task^.link;
        IFEND;
      WHILEND;
      destination := destination^.link;
    WHILEND;

  PROCEND process_intertask_message;
?? TITLE := 'remove_translation_requests', EJECT ??

{ PURPOSE:
{   This procedure will remove any title translation requests from
{   the wait list if the MANNA application definition is deactivated
{   while QTFC is running.
{
{ NOTES:
{   This procedure does not look at the first two elements in the
{   wait list because they should always be there.
{   The upperbound of WAIT_LIST^ should always be calculated because
{   the size of the wait list will be changing as activities are
{   removed.

  PROCEDURE remove_translation_requests
    (    destination_list: ^nft$qtfc_destination;
     VAR wait_list: ^ost$i_wait_list);

    CONST
      first_element = 3;

    VAR
      destination: ^nft$qtfc_destination,
      ignore_status: ost$status,
      index: nft$wait_list_size;

    index := first_element;
    WHILE index <= UPPERBOUND (wait_list^) DO
      IF wait_list^ [index].activity = nac$i_await_title_translation THEN
        nap$end_directory_search (wait_list^ [index].translation_request, ignore_status);

{ clear out (set to NIL) the destination_list pointer to the removed title translation request

        destination := destination_list;

     /clear_out_destination_title_req/
        WHILE destination <> NIL DO
          IF destination^.translation_request <> NIL THEN
            IF wait_list^ [index].translation_request = destination^.translation_request^.translation_request
                  THEN
              destination^.translation_request := NIL;
              EXIT /clear_out_destination_title_req/;
            IFEND;
          IFEND;
          destination := destination^.link;
        WHILEND /clear_out_destination_title_req/;

        delete_item_from_wait_list (destination_list, index, wait_list);
      ELSE
        index := index + 1;
      IFEND;
    WHILEND;

  PROCEND remove_translation_requests;
?? TITLE := 'request_namve_connection', EJECT ??

{ PURPOSE:
{   This procedure will establish a connection with QTFS on a remote
{   mainframe via NAM/VE.
{
{ NOTES:
{   This procedure does not wait for a server reponse or open the
{   connection file.  QTFI will wait for a server reponse, set up the
{   file attributes and open the file.  QTFC will pass the connection
{   file name to QTFI.

  PROCEDURE request_namve_connection
    (    service_address: nat$network_address;
         connection_attributes: ^nat$create_attributes;
     VAR connection: nft$qtf_connection;
     VAR status: ost$status);

    status.normal := TRUE;

    nap$request_connection (service_address, nfc$qtf_namve_client_name, connection.file_name,
          nac$cdna_session, connection_attributes, nfc$half_minute, status);
    IF status.normal THEN
      connection.kind := nfc$network_nam;
    IFEND;

  PROCEND request_namve_connection;
?? TITLE := 'request_rhfam_connection', EJECT ??

{ PURPOSE:
{   This procedure will establish a connection with QTFS on a remote
{   mainframe via RHFAM.
{
{ NOTES:
{   This procedure does not wait for a server reponse or open the
{   connection file.  QTFI will wait for a server reponse, set up the
{   file attributes and open the file.  QTFC will pass the connection
{   file name to QTFI.

  PROCEDURE request_rhfam_connection
    (    destination_name: ost$name;
     VAR connection: nft$qtf_connection;
     VAR status: ost$status);

    CONST
      wait_time = 2 * 60 * 1000;    { 2 minutes in milliseconds }

    VAR
      destination_host: rft$host_identifier,
      host_ids: rft$destination_hosts,
      i: rft$number_of_hosts,
      number_of_hosts: rft$number_of_hosts,
      server_response: rft$server_response;

    status.normal := TRUE;

    destination_host.host_identifier_kind := rfc$logical_identifier;
    destination_host.logical_identifier := destination_name;

    rfp$find_available_service (nfc$rhfam_service_name, destination_host, host_ids, number_of_hosts, status);
    IF status.normal THEN
      FOR i := LOWERBOUND (host_ids) TO number_of_hosts DO
        rfp$request_connection (nfc$qtf_rhfam_client_name, nfc$rhfam_service_name, host_ids [i],
              connection.file_name, {connect_file_attributes=} NIL, status);
        IF status.normal THEN
          rfp$await_server_response (connection.file_name, wait_time, server_response, status);
          IF status.normal  AND (server_response.server_response_kind = rfc$accept) THEN
            connection.kind := nfc$network_lcn;

{ The remote destination has been found and the remote server responded positively;
{ there is no need to look further.

            RETURN; {----->
          IFEND;
        IFEND;
      FOREND;
    IFEND;

  PROCEND request_rhfam_connection;
?? TITLE := 'satisfy_title_translation', EJECT ??

{ PURPOSE:
{   This procedure is called whenever a title translation request is
{   satisfied or becomes stale.  If the request is satisfied, a
{   connection is established.
{
{ NOTES:
{   The parameter ACTIVITY_INDEX is an integer because of OSP$I_AWAIT_ACTIVITY_COMPLETION.
{
{   RHFAM is always checked for a path to the destination if RHFAM is available on the
{   host system.   The NAM/VE connection request is always made because NAM/VE was
{   available for use when the translation request was made.  If NAM/VE is not
{   available for use when the connection request is made, that will be flagged.

  PROCEDURE satisfy_title_translation
    (    activity_index: integer;
         destination_list: ^nft$qtfc_destination;
         rhfam_availability: nft$network_availability;
     VAR namve_availability: nft$network_availability;
     VAR wait_list: ^ost$i_wait_list);

    CONST
      translation_wait_time = 0;

    VAR
      connection_attributes: ^nat$create_attributes,
      connection: nft$qtf_connection,
      destination: ^nft$qtfc_destination,
      directory_data: ^nat$directory_data,
      ignore_status: ost$status,
      translation_address: nat$network_address,
      translation_attributes: ^nat$translation_attributes,
      unique_name: ost$name,
      status: ost$status;

?? NEWTITLE := 'find_destination_with_req_id', EJECT ??

{ PURPOSE:
{   This procedure finds a destination that has a title translation
{   request that is the same as the given translation request.
{
{ NOTES:
{   An assumption made in this routine is that title translation
{   requests are the only activities removed from the wait list.
{   When a title translation request is added to the wait list, the
{   destination entry that spawns the title has a pointer set to that
{   activity in the wait list.

    PROCEDURE find_destination_with_req_id
      (    translation_request: nat$directory_search_identifier;
           destination_list: ^nft$qtfc_destination;
       VAR destination: ^nft$qtfc_destination);

      VAR
        destination_found: boolean;

      destination_found := FALSE;
      destination := destination_list;
      WHILE (NOT destination_found) AND (destination <> NIL) DO
        IF destination^.translation_request <> NIL THEN
          destination_found := translation_request = destination^.translation_request^.translation_request;
        IFEND;
        IF NOT destination_found THEN
          destination := destination^.link;
        IFEND;
      WHILEND;

    PROCEND find_destination_with_req_id;
?? OLDTITLE, EJECT ??
    find_destination_with_req_id (wait_list^ [activity_index].translation_request, destination_list,
          destination);

    IF destination = NIL THEN

{       INTERNAL ERROR

      nap$end_directory_search (wait_list^ [activity_index].translation_request, ignore_status);
      delete_item_from_wait_list (destination_list, activity_index, wait_list);
    ELSE
      PUSH directory_data: [[REP nac$max_directory_data_length OF cell]];
      PUSH translation_attributes: [1 .. 1];
      translation_attributes^ [1].selector := nac$translation_data;
      translation_attributes^ [1].data := directory_data;
      nap$get_title_translation (wait_list^ [activity_index].translation_request, translation_wait_time,
            translation_attributes, translation_address, status);
      IF status.normal THEN
        nap$end_directory_search (wait_list^ [activity_index].translation_request, ignore_status);
        delete_item_from_wait_list (destination_list, activity_index, wait_list);

        destination^.translation_request := NIL;

        pmp$get_unique_name (unique_name, status);
        connection.file_name := unique_name;
        connection.kind := nfc$unknown_network;

        IF rhfam_availability.available THEN
          IF destination^.next_destination_name.value = osc$null_name THEN
            request_rhfam_connection (destination^.name, connection, status);
          ELSE
            request_rhfam_connection (destination^.next_destination_name.value, connection, status);
          IFEND;
          IF NOT status.normal THEN
            amp$return (connection.file_name, ignore_status);
            connection.kind := nfc$unknown_network;
          IFEND;
        IFEND;
        IF connection.kind = nfc$unknown_network THEN
          build_namve_connect_data (translation_attributes, connection_attributes, status);
          IF status.normal THEN
            request_namve_connection (translation_address, connection_attributes, connection, status);
            IF (NOT status.normal) AND ((status.condition = nae$unknown_application) OR
                  (status.condition = nae$application_inactive) OR (status.condition = nae$network_inactive))
                  THEN
              namve_availability.available := FALSE;
              nfp$start_timer (nfc$one_minute, namve_availability.timer);
            IFEND;
          IFEND;
        IFEND;

      ELSEIF (NOT status.normal) AND (status.condition = nae$invalid_directory_search_id) THEN
        IF destination^.next_destination_name.value = osc$null_name THEN
          issue_title_translation (destination^.name, wait_list^ [activity_index].translation_request,
                namve_availability, status);
        ELSE
          issue_title_translation (destination^.next_destination_name.value, wait_list^ [activity_index].
                translation_request, namve_availability, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND satisfy_title_translation;
?? TITLE := 'select_file_for_transfer', EJECT ??

{ PURPOSE:
{   This procedure finds the next file in the destination file list
{   to be transmitted by QTFI to the remote system.
{
{ NOTES:
{   File selection on a first come, first served basis.  This file
{   selection process is being used until a better priority
{   algorithm is devised.

  PROCEDURE select_file_for_transfer
    (    destination: ^nft$qtfc_destination;
         connection: nft$qtf_connection;
         namve_host_pid: ost$name;
         rhfam_host_pid: rft$physical_identifier;
         store_forward_file_info: nft$store_forward_file_info;
     VAR transfer_file: ^nft$qtfc_file);

    VAR
      current_source_name: nft$parameter_24_definition,
      destination_name: nft$parameter_24_definition,
      file_found: boolean,
      local_status: ost$status,
      new_source_name: nft$parameter_24_definition,
      source_name_changed: boolean;

    local_status.normal := TRUE;
    file_found := FALSE;

    transfer_file := destination^.file_list;
    WHILE (NOT file_found) AND (transfer_file <> NIL) DO
      file_found := (transfer_file^.transfer_state = nfc$ready_to_transfer);
      IF file_found THEN
        IF transfer_file^.application_file_descriptor.file_kind = nfc$output_file THEN
          jmp$set_output_initiated (jmc$qtf_usage, transfer_file^.application_file_descriptor.
                output_descriptor.system_file_name, local_status);
        ELSEIF transfer_file^.application_file_descriptor.file_kind = nfc$input_file THEN
          jmp$set_input_initiated (jmc$qtf_usage, transfer_file^.application_file_descriptor.input_descriptor.
                system_job_name, local_status);
        ELSEIF transfer_file^.application_file_descriptor.file_kind = nfc$generic_file THEN
          jmp$set_qfile_initiated (nfc$qtf_namve_client_name, transfer_file^.application_file_descriptor
                .generic_descriptor.system_file_name, local_status);
        IFEND;
        file_found := local_status.normal;
        IF local_status.normal THEN
          transfer_file^.transfer_state := nfc$transfer_initiated;
          IF store_forward_file_info.file_open THEN
            destination_name.value := destination^.name;
            destination_name.size := clp$trimmed_string_size (destination_name.value);
            IF (transfer_file^.application_file_descriptor.file_kind = nfc$output_file) AND
                  (transfer_file^.application_file_descriptor.output_descriptor.source_logical_id <>
                    osc$null_name) THEN
              current_source_name.value := transfer_file^.application_file_descriptor.
                    output_descriptor.source_logical_id;
            ELSEIF (transfer_file^.application_file_descriptor.file_kind = nfc$input_file) AND
                  (transfer_file^.application_file_descriptor.input_descriptor.source_logical_id <>
                    osc$null_name) THEN
              current_source_name.value := transfer_file^.application_file_descriptor.
                    input_descriptor.source_logical_id;
            ELSEIF connection.kind = nfc$network_nam THEN
              current_source_name.value := namve_host_pid;
            ELSEIF connection.kind = nfc$network_lcn THEN
              current_source_name.value := rhfam_host_pid;
            IFEND;
            current_source_name.size := clp$trimmed_string_size (current_source_name.value);
            nfp$get_new_source_name (nfc$sf_qtf_initiator, store_forward_file_info, current_source_name,
                  destination_name, source_name_changed, new_source_name, local_status);
            IF source_name_changed THEN
              IF transfer_file^.application_file_descriptor.file_kind = nfc$output_file THEN
                transfer_file^.application_file_descriptor.output_descriptor.source_logical_id :=
                      new_source_name.value;
              ELSEIF transfer_file^.application_file_descriptor.file_kind = nfc$input_file THEN
                transfer_file^.application_file_descriptor.input_descriptor.source_logical_id :=
                      new_source_name.value;
              IFEND;
            IFEND;
            IF destination^.next_destination_name.value <> osc$null_name THEN
              IF transfer_file^.application_file_descriptor.file_kind = nfc$output_file THEN
                transfer_file^.application_file_descriptor.output_descriptor.output_destination :=
                      destination^.next_destination_name.value;
              ELSEIF transfer_file^.application_file_descriptor.file_kind = nfc$input_file THEN
                transfer_file^.application_file_descriptor.input_descriptor.job_destination_family :=
                      destination^.next_destination_name.value;
              ELSEIF transfer_file^.application_file_descriptor.file_kind = nfc$generic_file THEN
                transfer_file^.application_file_descriptor.generic_descriptor.destination :=
                      destination^.next_destination_name.value;
              IFEND;
            IFEND;
          IFEND;
        ELSE
          transfer_file^.transfer_state := nfc$wait_to_transfer;
        IFEND;
      IFEND;

{ This should be separate because file_found can change inside the previous IF statement

      IF NOT file_found THEN
        transfer_file := transfer_file^.link;
      IFEND;
    WHILEND;

  PROCEND select_file_for_transfer;
?? TITLE := 'send_file_transfer_msg_to_task', EJECT ??

{ PURPOSE:
{   This procedure will send a message to a QTFI task telling the task
{   to transfer a file over a connection, the connection file name,
{   the connection type, and the host physical identifier.

  PROCEDURE send_file_transfer_msg_to_task
    (    transfer_file: ^nft$qtfc_file;
         connection: nft$qtf_connection;
         namve_host_pid: ost$name;
         rhfam_host_pid: rft$physical_identifier;
         task_id: pmt$task_id;
     VAR last_message_sent: nft$intertask_message_kind;
     VAR transfer_start_time: nft$micro_second;
     VAR status: ost$status);

    VAR
      qtfi_task: nft$qtfi_task,
      qtfi_task_msg: nft$intertask_message,
      retry_count: nft$qtf_put_async_retry_range;

    status.normal := TRUE;
    qtfi_task_msg.kind := nfc$qtf_file_transfer;
    qtfi_task_msg.connection_kind := connection.kind;
    qtfi_task_msg.connection_file := connection.file_name;
    qtfi_task_msg.qtf_file_descriptor := transfer_file^.application_file_descriptor;

    IF qtfi_task_msg.connection_kind = nfc$network_nam THEN
      qtfi_task_msg.host_pid := namve_host_pid;
    ELSEIF qtfi_task_msg.connection_kind = nfc$network_lcn THEN
      qtfi_task_msg.host_pid := rhfam_host_pid;
    IFEND;

    retry_count := 0;

    REPEAT
      nfp$put_async_task_message (task_id, ^qtfi_task_msg, #SIZE (qtfi_task_msg), status);
      IF status.normal THEN
        last_message_sent := nfc$qtf_file_transfer;
        transfer_start_time := #FREE_RUNNING_CLOCK (0);
      ELSE
        pmp$wait (nfc$qtf_put_async_wait_time, nfc$qtf_put_async_wait_time);
        retry_count := retry_count + 1;
      IFEND;
    UNTIL (status.normal) OR (retry_count > nfc$qtf_put_async_max_retry);

  PROCEND send_file_transfer_msg_to_task;
?? TITLE := 'start_transmitting_tasks', EJECT ??

{ PURPOSE:
{   This procedure is called after acquiring queue files to start the
{   QTFI tasks to transmit files to remote destinations.  If a
{   destination entry already has a QTFI task, then the destination
{   is ignored.

  PROCEDURE start_transmitting_tasks
    (    destination_list: ^nft$qtfc_destination;
         maximum_qtfi_tasks: ost$non_negative_integers;
         namve_host_pid: ost$name;
         rhfam_host_pid: rft$physical_identifier;
         store_forward_file_info: nft$store_forward_file_info;
     VAR namve_availability: nft$network_availability;
     VAR number_of_running_qtfi_tasks: ost$non_negative_integers;
     VAR rhfam_availability: nft$network_availability;
     VAR wait_list: ^ost$i_wait_list);

    VAR
      connection: nft$qtf_connection,
      destination: ^nft$qtfc_destination,
      status: ost$status;

?? NEWTITLE := 'start_qtfi_task', EJECT ??

{ PURPOSE:
{   This procedure starts up a QTF Initiator child task to perform
{   the file transfer(s).
{
{ NOTE:
{   The file is selected before the QTFI task is started because
{   there is a possibility that there is only one file to transfer
{   but it could not be selected.  The file could have been modified
{   or terminated by the user and QTFC has not yet been notified of
{   the change in the file status.

    PROCEDURE start_qtfi_task
      (    destination: ^nft$qtfc_destination;
           namve_host_pid: ost$name;
           rhfam_host_pid: rft$physical_identifier;
           store_forward_file_info: nft$store_forward_file_info;
       VAR connection: nft$qtf_connection;
       VAR wait_list: ^ost$i_wait_list);

      CONST
        debug_async_task = FALSE;

      VAR
        current_task: ^nft$qtfi_task,
        file_complete_status: ost$status,
        ignore_status: ost$status,
        qid: pmt$queue_connection,
        task_id: pmt$task_id,
        transfer_file: ^nft$qtfc_file,
        status: ost$status;

?? NEWTITLE := 'add_qtfi_task_to_list', EJECT ??

{ PURPOSE:
{   This procedure adds a new QTFI task to the task list and will
{   add an await local queue message activity to the wait list if
{   it has not been added previously.
{
{ NOTE:
{   The procedure ADD_ITEM_TO_WAIT_LIST will only be called once
{   to add the local queue message activity.  It has to be added
{   after the first QTFI task has been started so QTFC will wait
{   for messages from all QTFI tasks that get started.  After the
{   await local queue message activity has been added to the list,
{   it should never be removed.

      PROCEDURE add_qtfi_task_to_list
        (    task_id: pmt$task_id;
             qid: pmt$queue_connection;
             destination: ^nft$qtfc_destination;
             connection: nft$qtf_connection;
         VAR wait_list: ^ost$i_wait_list;
         VAR new_task: ^nft$qtfi_task);

        VAR
          activity: ost$i_activity,
          add_local_q_msg_to_wait_list: [STATIC] boolean := TRUE;

        IF add_local_q_msg_to_wait_list THEN
          activity.activity := pmc$i_await_local_queue_message;
          activity.qid := qid;
          add_item_to_wait_list (activity, wait_list);
          add_local_q_msg_to_wait_list := FALSE;
        IFEND;

        ALLOCATE new_task;
        new_task^.back_link := NIL;
        new_task^.link := NIL;
        new_task^.file_in_transfer := NIL;
        new_task^.file_transfer_start_time := 0;
        new_task^.qid := qid;
        new_task^.task_id := task_id;
        new_task^.transfer_connection := connection;

        IF destination^.transfering_task <> NIL THEN
          destination^.transfering_task^.back_link := new_task;
          new_task^.link := destination^.transfering_task;
        IFEND;
        destination^.transfering_task := new_task;

      PROCEND add_qtfi_task_to_list;
?? OLDTITLE, EJECT ??
      select_file_for_transfer (destination, connection, namve_host_pid, rhfam_host_pid,
            store_forward_file_info, transfer_file);
      IF transfer_file <> NIL THEN
        nfp$request_asynchronous_task (nfc$qtfi_task_name, debug_async_task, task_id, qid, status);
        IF status.normal THEN
          number_of_running_qtfi_tasks := number_of_running_qtfi_tasks + 1;

          add_qtfi_task_to_list (task_id, qid, destination, connection, wait_list, current_task);

          current_task^.file_in_transfer := transfer_file;

          send_file_transfer_msg_to_task (transfer_file, connection, namve_host_pid,
                rhfam_host_pid, task_id, current_task^.last_message_sent,
                current_task^.file_transfer_start_time, status);
        ELSE
          amp$return (connection.file_name, ignore_status);
          connection.file_name := osc$null_name;
          connection.kind := nfc$unknown_network;
          transfer_file^.transfer_state := nfc$ready_to_transfer;
          IF transfer_file^.application_file_descriptor.file_kind = nfc$output_file THEN
            jmp$set_output_completed (jmc$qtf_usage, transfer_file^.name, FALSE, file_complete_status);
          ELSEIF transfer_file^.application_file_descriptor.file_kind = nfc$input_file THEN
            jmp$set_input_completed (jmc$qtf_usage, transfer_file^.name, FALSE, file_complete_status);
          ELSEIF transfer_file^.application_file_descriptor.file_kind = nfc$generic_file THEN
            jmp$set_qfile_completed (nfc$qtf_namve_client_name, transfer_file^.name, FALSE,
                  file_complete_status);
          IFEND;
        IFEND;
      IFEND;

    PROCEND  start_qtfi_task;
?? OLDTITLE, EJECT ??
    destination := destination_list;
    WHILE destination <> NIL DO
      IF (destination^.transfering_task = NIL) AND
            nfp$timer_expired (destination^.retry_timer, #FREE_RUNNING_CLOCK (0)) AND
            (destination^.file_list <> NIL) AND ((maximum_qtfi_tasks = 0) OR
            ((maximum_qtfi_tasks > 0) AND (number_of_running_qtfi_tasks < maximum_qtfi_tasks))) THEN

        establish_server_connection (destination, destination_list, rhfam_availability, namve_availability,
              connection, wait_list);
        IF connection.kind <> nfc$unknown_network THEN
          destination^.retry_timer.timer_set := FALSE;
          destination^.retry_timer.last_checked := 0;
          destination^.retry_timer.time_interval := 0;
          start_qtfi_task (destination, namve_host_pid, rhfam_host_pid, store_forward_file_info,
                connection, wait_list);
        IFEND;
      IFEND;
      destination := destination^.link;
    WHILEND;

  PROCEND start_transmitting_tasks;
?? TITLE := 'nfp$qtf_controller', EJECT ??

{ PURPOSE:
{   This procedure is the QTFC main routine.

  PROGRAM nfp$qtf_controller
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      activation_date_time_qtfc: nft$bcd_time,
      destination: ^nft$qtfc_destination,
      establish_descriptor: pmt$established_handler,
      exit_condition: [STATIC, READ] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      latest_time_check: nft$micro_second,
      maximum_qtfi_tasks: ost$non_negative_integers,
      namve_availability: nft$network_availability,
      namve_host_pid: ost$name,
      number_of_running_qtfi_tasks: ost$non_negative_integers,
      qtf_generic_q_password: jmt$queue_file_password,
      qtf_input_q_password: jmt$queue_file_password,
      qtf_output_q_password: jmt$queue_file_password,
      ready_index: integer,       { This has to be an integer for osp$i_await_activity_completion.
      rhfam_availability: nft$network_availability,
      rhfam_host_pid: rft$physical_identifier,
      single_transfer_per_connection: boolean,
      store_forward_file_info: nft$store_forward_file_info,
      wait_list: ^ost$i_wait_list;

?? NEWTITLE := 'exit condition handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler.  When executed, it will
{   sign off as an RHFAM application, end all current title
{   translation requests and close, end communication with the QTFI
{   child tasks, and close and return all connection files.

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        destination: ^nft$qtfc_destination,
        ignore_status: ost$status,
        transfering_task: ^nft$qtfi_task;

      pmp$log ('Queue file Transfer Facility dropping', ignore_status);

{ End asynchronous communications with QTFI tasks.

      nfp$end_async_communication (FALSE, ignore_status);

{ End all title translations and return all connection files.

      destination := destination_list;
      WHILE destination <> NIL DO
        IF destination^.translation_request <> NIL THEN
          nap$end_directory_search (destination^.translation_request^.translation_request, ignore_status);
        IFEND;
        transfering_task := destination^.transfering_task;
        WHILE transfering_task <> NIL DO
          IF transfering_task^.transfer_connection.kind <> nfc$unknown_network THEN
            amp$return (transfering_task^.transfer_connection.file_name, ignore_status);
            IF ignore_status.normal THEN
              transfering_task^.transfer_connection.file_name := osc$null_name;
              transfering_task^.transfer_connection.kind := nfc$unknown_network;
            IFEND;
          IFEND;
          transfering_task := transfering_task^.link;
        WHILEND;
        destination := destination^.link;
      WHILEND;

      rfp$application_sign_off (nfc$qtf_rhfam_client_name, ignore_status);

      IF store_forward_file_info.file_open THEN
        nfp$close_store_forward_file (store_forward_file_info, ignore_status);
      IFEND;

      REPEAT
        clp$delete_variable (nfv$appl_def_segment_variables [nfc$appl_def_segment_for_qtf], ignore_status);
      UNTIL NOT ignore_status.normal;

    PROCEND exit_condition_handler;
?? TITLE := 'initialize qtf controller', EJECT ??

{ PURPOSE:
{   This procedure initializes values and get parameters from the
{   program call.
{
{ NOTE:
{   The host pid is a required parameter in the protocol.  The
{   parameter for the host pid is required for use with NAM/VE.
{   If RHFAM is available, QTF will use the value returned by
{   rfp$get_local_host_pid.

    PROCEDURE initialize_qtf_controller
      (    parameter_list: clt$parameter_list;
       VAR namve_host_pid: ost$name;
       VAR rhfam_host_pid: rft$physical_identifier;
       VAR qtf_generic_q_password: jmt$queue_file_password;
       VAR qtf_input_q_password: jmt$queue_file_password;
       VAR qtf_output_q_password: jmt$queue_file_password;
       VAR wait_list: ^ost$i_wait_list;
       VAR rhfam_availability: nft$network_availability;
       VAR maximum_qtfi_tasks: ost$non_negative_integers;
       VAR single_transfer_per_connection: boolean;
       VAR status: ost$status);

*copyc nft$qtf_controller_pdt

      VAR
        generic_q_registration_options: ^jmt$qfile_registration_options,
        maximum_rhf_connections: rft$application_connections,
        rhfam_status: ost$status,
        value_specified: boolean;

      status.normal := TRUE;

      jmp$register_input_application (nfc$qtf_namve_client_name, jmc$qtf_usage, qtf_input_q_password, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

      jmp$register_output_application (nfc$qtf_namve_client_name, jmc$qtf_usage, qtf_output_q_password,
            status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

      PUSH generic_q_registration_options: [1..1];
      generic_q_registration_options^[1].key := jmc$notify_on_terminate;
      generic_q_registration_options^[1].notify_on_terminate := TRUE;

      jmp$register_qfile_application (nfc$qtf_namve_client_name, generic_q_registration_options,
            qtf_generic_q_password, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

      clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

      #translate(osv$lower_to_upper, pvt [p$host_physical_identifier].value^.string_value^, namve_host_pid);

      maximum_qtfi_tasks := 0;
      IF pvt [p$maximum_qtfi_subtasks].specified THEN
          maximum_qtfi_tasks := pvt [p$maximum_qtfi_subtasks].value^.integer_value.value;
      IFEND;

      single_transfer_per_connection := pvt [p$single_transfer_per_connectio].value^.boolean_value.value;

      rhfam_availability.available := FALSE;
      rhfam_availability.timer.timer_set := FALSE;
      rhfam_availability.timer.last_checked := 0;
      rhfam_availability.timer.time_interval := 0;
      check_rhfam_sign_on (rhfam_availability, rhfam_host_pid);

      ALLOCATE qtfc_wait_list_seq: [[REP nfc$wait_list_limit OF ost$i_activity]];
      RESET qtfc_wait_list_seq;
      NEXT wait_list: [1 .. 2] IN qtfc_wait_list_seq;
      wait_list^ [1].activity := osc$i_await_unspecified_event;
      wait_list^ [2].activity := osc$i_await_time;
      wait_list^ [2].milliseconds := nfc$one_minute DIV 1000;

      nfp$create_appl_def_segment_var (nfc$appl_def_segment_for_qtf, qtfc_wait_list_seq);

    PROCEND initialize_qtf_controller;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    number_of_running_qtfi_tasks := 0;

    get_activation_date_time (activation_date_time_qtfc);
    namve_availability.available := TRUE;   { Assumption until told otherwise.
    namve_availability.time_stamp := activation_date_time_qtfc;

    pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^establish_descriptor, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    initialize_qtf_controller (parameter_list, namve_host_pid, rhfam_host_pid, qtf_generic_q_password,
          qtf_input_q_password, qtf_output_q_password, wait_list, rhfam_availability, maximum_qtfi_tasks,
          single_transfer_per_connection, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    nfp$open_store_forward_file (TRUE, store_forward_file_info, status);

    acquire_all_q_files (qtf_generic_q_password, qtf_input_q_password, qtf_output_q_password,
          store_forward_file_info, destination_list);
    start_transmitting_tasks (destination_list, maximum_qtfi_tasks, namve_host_pid, rhfam_host_pid,
          store_forward_file_info, namve_availability,number_of_running_qtfi_tasks,
          rhfam_availability, wait_list);

    WHILE TRUE DO
      osp$i_await_activity_completion (wait_list^, ready_index, status);
      IF status.normal THEN
        CASE wait_list^ [ready_index].activity OF
        = osc$i_await_time =
          latest_time_check := #FREE_RUNNING_CLOCK (0);
          IF (NOT rhfam_availability.available) AND (nfp$timer_expired
                (rhfam_availability.timer, latest_time_check)) THEN
            check_rhfam_sign_on (rhfam_availability, rhfam_host_pid);
          IFEND;
          IF (NOT namve_availability.available) AND (nfp$timer_expired
                (namve_availability.timer, latest_time_check)) THEN
            check_namve_client_status (destination_list, namve_availability);
          IFEND;

        = nac$i_await_title_translation =
          satisfy_title_translation (ready_index, destination_list, rhfam_availability, namve_availability,
                wait_list);

        = pmc$i_await_local_queue_message =
          process_intertask_message (destination_list, namve_host_pid, rhfam_host_pid,
                store_forward_file_info, namve_availability, number_of_running_qtfi_tasks,
                rhfam_availability, wait_list, single_transfer_per_connection);

        ELSE
          ;
        CASEND;
        acquire_all_q_files (qtf_generic_q_password, qtf_input_q_password, qtf_output_q_password,
              store_forward_file_info, destination_list);

        start_transmitting_tasks (destination_list, maximum_qtfi_tasks, namve_host_pid, rhfam_host_pid,
              store_forward_file_info, namve_availability, number_of_running_qtfi_tasks,
              rhfam_availability, wait_list);

        IF (NOT namve_availability.available) AND (UPPERBOUND (wait_list^) > 2) THEN
          remove_translation_requests (destination_list, wait_list);
        IFEND;

        destination := destination_list;
        WHILE (destination <> NIL) DO
          IF (destination^.file_list = NIL) AND (destination^.transfering_task = NIL) THEN
            delete_destination_from_list (destination, destination_list, wait_list);
            destination := destination_list;
          ELSE
            destination := destination^.link;
          IFEND;
        WHILEND;
      IFEND;
    WHILEND;

    IF store_forward_file_info.file_open THEN
      nfp$close_store_forward_file (store_forward_file_info, status);
    IFEND;

  PROCEND nfp$qtf_controller;
?? OLDTITLE ??
MODEND nfm$qtf_controller;
*DECK DECK=NFM$QTF_INITIATOR EXPAND=TRUE
?? TITLE := 'QUEUE FILE TRANSFER FACILITY INITIATOR' ??

?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, INDENT := 2) ??
?? SET (LIST := ON, LISTCTS := OFF) ??
MODULE nfm$qtf_initiator;

{  PURPOSE:
{             This module does the actual transfer of a queue file.  It only
{             transfers one file at a time but may transfer several files over
{             a connection in succession.  It may also use several connections
{             in succession.  QTFI gets what connection to use and file to
{             transfer from the parent task, QTFC.
{
{  ALGORITHM:
{             Set up communication with parent task through job local queues.
{
{             Loop waiting for messages using osp$i_await_activity_completion.
{               Get message from job local queue.
{               For each message kind:
{               - file transfer message:
{                 Transfer file.
{
{               - connection termination message:
{                 Terminate connection.
{
{               - task termination message:
{                 Ready task for termination.
{                 Exit.
{
{               - any other message kind
{                 Communication error with parent task.
{

?? EJECT ??
*copyc osc$queue_transfer_client
*copyc ost$status
*copyc osv$lower_to_upper
*copyc nft$intertask_message
*copyc nft$transfer_modes

*copyc amp$change_file_attributes
*copyc amp$put_next
*copyc amp$return
*copyc clp$convert_integer_to_string
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc jmp$emit_communication_stat
*copyc jmp$get_attribute_defaults
*copyc jmp$open_input_file
*copyc jmp$open_output_file
*copyc jmp$open_qfile
*copyc jmp$print_file
*copyc nap$await_server_response
*copyc nap$get_attributes
*copyc nap$store_attributes
*copyc nfc$external_characteristic_a9
*copyc nfc$normal_string
*copyc nfc$parameter_29_definitions
*copyc nfc$parameter_31_definitions
*copyc nfc$parameter_32_definitions
*copyc nfc$parameter_33_definitions
*copyc nfc$qtf_name_constants
*copyc nfe$exception_condition_codes
*copyc nfp$begin_asynchronous_task
*copyc nfp$create_wait_queue_file_name
*copyc nfp$deallocate_dirs_from_head
*copyc nfp$end_async_communication
*copyc nfp$format_message_to_job_log
*copyc nfp$get_async_task_message
*copyc nfp$put_async_task_message
*copyc nfp$initialize_control_block
*copyc nfp$receive_command
*copyc nfp$send_command
*copyc nfp$send_queue_file
*copyc osp$i_await_activity_completion
*copyc osp$output_status_message
*copyc osp$set_status_abnormal
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_unique_name
*copyc pmp$log
*copyc pmp$wait
*copyc rfp$store
?? NEWTITLE := 'QTFI Module Global Variables', EJECT ??
*copyc nfv$qtf_parameter_rules
*copyc nfv$qtf_required_params_on_cmds

  CONST
    qtfi_tenth_of_a_second = 100,          {  This is in milliseconds.
    qtfi_unknown_job_name = 'XXXX';

  VAR
    qtfi_connection_file_name: amt$local_file_name := osc$null_name;

?? TITLE := 'end_and_finish_protocol', EJECT ??

{ PURPOSE:
{   This procedure is used to finish the protocol with the server
{   before terminating the connection.

  PROCEDURE end_and_finish_protocol
    (VAR control_block: nft$control_block);

    VAR
      etp_legal_resp_commands: nft$command_set,
      etp_parameter_set: nft$parameter_set,
      etpr_ignored_params: nft$parameter_set,
      etpr_modified_params: nft$parameter_set,
      etpr_received_params: nft$parameter_set,
      fini_parameter_set: nft$parameter_set,
      local_status: ost$status;

    local_status.normal := TRUE;

    etp_legal_resp_commands := $nft$command_set [nfc$etpr];
    etp_parameter_set := $nft$parameter_set [];
    fini_parameter_set := $nft$parameter_set [];

    nfp$send_command (nfc$etp, etp_parameter_set, $nft$parameter_set[ ], $nft$parameter_set[ ],
          control_block, local_status);
    IF local_status.normal THEN
      nfp$receive_command (etp_legal_resp_commands, nfv$qtf_required_params_on_cmds, control_block,
            etpr_received_params, etpr_ignored_params, etpr_modified_params, local_status);
      IF local_status.normal THEN
        nfp$send_command (nfc$fini, fini_parameter_set, $nft$parameter_set[ ], $nft$parameter_set[ ],
              control_block, local_status);
      IFEND;
    IFEND;

  PROCEND end_and_finish_protocol;
?? NEWTITLE := 'generate_error_file', EJECT ??

{ PURPOSE:
{   This procedure opens up and writes a listing file if a queue
{   file could not be transferred to the remote destination.  The
{   resulting listing file is sent back to the source destination
{   via QTF.

  PROCEDURE generate_error_file
    (    error_file: fst$file_reference;
         control_block: nft$control_block;
         qtf_file_descriptor: nft$application_file_descriptor;
     VAR status: ost$status);

    CONST
      comment_banner_line     = ' Comment_Banner        : ',
      destination_line        = ' Destination           : ',
      insertion_location  = 26,
      login_family_line       = ' Login_Family          : ',
      login_user_line         = ' Login_User            : ',
      output_destination_line = ' Output_Destination    : ',
      remote_host_dir_line    = ' Remote Host Directive : ',
      system_file_name_line   = ' System_File_Name      : ',
      system_job_name_line    = ' System_Job_Name       : ',
      user_file_name_line     = ' User_File_Name        : ',
      user_job_name_line      = ' User_Job_Name         : ';

    VAR
      byte_address: amt$file_byte_address,
      default_creation_attributes: ^fst$file_cycle_attributes,
      directive_entry: ^nft$directive_entry,
      error_file_id: amt$file_identifier,
      ignore_status: ost$status,
      output_text_line: string (insertion_location + osc$max_name_size);

    status.normal := TRUE;

    PUSH default_creation_attributes: [1 .. 4];

    default_creation_attributes^ [1].selector := fsc$file_contents_and_processor;
    default_creation_attributes^ [1].file_contents := amc$legible;
    default_creation_attributes^ [1].file_processor := amc$unknown_processor;

    default_creation_attributes^ [2].selector := fsc$page_length;
    default_creation_attributes^ [2].page_length := 60;

    default_creation_attributes^ [3].selector := fsc$page_width;
    default_creation_attributes^ [3].page_width := 132;

    default_creation_attributes^ [4].selector := fsc$page_format;
    default_creation_attributes^ [4].page_format := amc$burstable_form;

    fsp$open_file (error_file, amc$record, NIL, default_creation_attributes, NIL, NIL, NIL, error_file_id,
          status);
    IF status.normal THEN
      IF qtf_file_descriptor.file_kind = nfc$input_file THEN
        output_text_line := system_job_name_line;
        output_text_line(insertion_location, jmc$system_supplied_name_size) :=
            control_block.send_file_name.value;
        amp$put_next (error_file_id, ^output_text_line, #SIZE(output_text_line), byte_address, ignore_status);

        output_text_line := user_job_name_line;
        output_text_line(insertion_location, jmc$system_supplied_name_size) :=
            control_block.send_job_name.value;
        amp$put_next (error_file_id, ^output_text_line, #SIZE(output_text_line), byte_address, ignore_status);
      ELSEIF qtf_file_descriptor.file_kind = nfc$output_file THEN
        output_text_line := comment_banner_line;
        output_text_line(insertion_location, jmc$system_supplied_name_size) :=
            qtf_file_descriptor.output_descriptor.comment_banner;
        amp$put_next (error_file_id, ^output_text_line, #SIZE(output_text_line), byte_address, ignore_status);

        output_text_line := login_family_line;
        output_text_line(insertion_location, jmc$system_supplied_name_size) :=
            qtf_file_descriptor.output_descriptor.login_family;
        amp$put_next (error_file_id, ^output_text_line, #SIZE(output_text_line), byte_address, ignore_status);

        output_text_line := login_user_line;
        output_text_line(insertion_location, jmc$system_supplied_name_size) :=
            qtf_file_descriptor.output_descriptor.login_user;
        amp$put_next (error_file_id, ^output_text_line, #SIZE(output_text_line), byte_address, ignore_status);

        output_text_line := output_destination_line;
        output_text_line(insertion_location, jmc$system_supplied_name_size) :=
            qtf_file_descriptor.output_descriptor.output_destination;
        amp$put_next (error_file_id, ^output_text_line, #SIZE(output_text_line), byte_address, ignore_status);

        output_text_line := system_file_name_line;
        output_text_line(insertion_location, jmc$system_supplied_name_size) :=
            control_block.send_file_name.value;
        amp$put_next (error_file_id, ^output_text_line, #SIZE(output_text_line), byte_address, ignore_status);

        output_text_line := user_file_name_line;
        output_text_line(insertion_location, jmc$system_supplied_name_size) :=
            control_block.send_job_name.value;
        amp$put_next (error_file_id, ^output_text_line, #SIZE(output_text_line), byte_address, ignore_status);

        output_text_line := user_job_name_line;
        output_text_line(insertion_location, jmc$system_supplied_name_size) :=
            qtf_file_descriptor.output_descriptor.user_job_name;

        amp$put_next (error_file_id, ^output_text_line, #SIZE(output_text_line), byte_address, ignore_status);
      ELSE { generic queue file.

        output_text_line := destination_line;
        output_text_line(insertion_location, osc$max_name_size) :=
              qtf_file_descriptor.generic_descriptor.destination;
        amp$put_next (error_file_id, ^output_text_line, #SIZE(output_text_line), byte_address, ignore_status);

        output_text_line := remote_host_dir_line;
        output_text_line(insertion_location,
              qtf_file_descriptor.generic_descriptor.remote_host_directive.size) :=
              qtf_file_descriptor.generic_descriptor.remote_host_directive.parameters;
        amp$put_next (error_file_id, ^output_text_line, #SIZE(output_text_line), byte_address, ignore_status);

        output_text_line := system_file_name_line;
        output_text_line(insertion_location, jmc$system_supplied_name_size) :=
            control_block.send_file_name.value;
        amp$put_next (error_file_id, ^output_text_line, #SIZE(output_text_line), byte_address, ignore_status);

      IFEND;
      output_text_line := '  ';
      amp$put_next (error_file_id, ^output_text_line, #SIZE(output_text_line), byte_address, ignore_status);

      directive_entry := control_block.received_operator_messages.head;
      WHILE directive_entry <> NIL DO
        amp$put_next (error_file_id, ^directive_entry^.line, #SIZE (directive_entry^.line), byte_address,
                ignore_status);
        directive_entry := directive_entry^.link;
      WHILEND;

      directive_entry := control_block.received_user_messages.head;
      WHILE directive_entry <> NIL DO
        amp$put_next (error_file_id, ^directive_entry^.line, #SIZE (directive_entry^.line), byte_address,
              ignore_status);
        directive_entry := directive_entry^.link;
      WHILEND;

      osp$output_status_message (error_file_id, osc$full_message_level, osc$standard_status_message_hdr,
            control_block.state_of_transfer, ignore_status);

      fsp$close_file (error_file_id, status);
    IFEND;

  PROCEND generate_error_file;
?? TITLE := 'print_output_error_file', EJECT ??

{ PURPOSE:
{   This procedure is called when a queue file could not be
{   transferred to the remote destination or the job could not
{   execute on the remote destination.  An output queue file is
{   generated and sent back to the user on the originating system.

  PROCEDURE print_output_error_file
    (    qtf_file_descriptor: nft$application_file_descriptor;
         control_block: nft$control_block);

    CONST
      min_print_options = 1,
      max_generic_options = 8,
      max_print_options = 23;

    VAR
      comment_banner: jmt$output_comment_banner,
      control_family: ost$name,
      control_user: ost$name,
      default_attributes: ^jmt$default_attribute_results,
      device: jmt$output_device,
      error_file: ^fst$file_reference,
      external_characteristics: jmt$external_characteristics,
      forms_code: jmt$forms_code,
      generate_unique_name: boolean,
      local_status: ost$status,
      new_file_attributes: ^amt$file_attributes,
      operator_family: ost$name,
      originating_account: avt$account_name,
      originating_family: ost$name,
      originating_project: avt$project_name,
      originating_user: ost$name,
      output_destination: ost$name,
      output_destination_usage: jmt$destination_usage,
      output_priority: jmt$output_priority,
      print_file_options: ^jmt$output_submission_options,
      routing_banner: jmt$output_routing_banner,
      source_logical_id: jmt$source_logical_id,
      station: jmt$station,
      station_operator: jmt$station_operator,
      system_file_name: jmt$system_supplied_name,
      unique_name: ost$name,
      user_file_name: jmt$user_supplied_name,
      user_information: jmt$user_information,
      user_job_name: jmt$user_supplied_name,
      vfu_load_procedure: jmt$vfu_load_procedure,
      wait_queue_file_name: amt$local_file_name;

?? OLDTITLE, EJECT ??
    local_status.normal := TRUE;

    generate_unique_name := TRUE;
    IF (qtf_file_descriptor.file_kind = nfc$input_file) AND
          (qtf_file_descriptor.input_descriptor.output_disposition.key = jmc$wait_queue_path) THEN
      IF qtf_file_descriptor.input_descriptor.user_job_name <> osc$null_name THEN
        user_job_name := qtf_file_descriptor.input_descriptor.user_job_name;
      ELSE
        user_job_name := qtfi_unknown_job_name;
      IFEND;
      nfp$create_wait_queue_file_name (qtf_file_descriptor.input_descriptor.control_family,
            qtf_file_descriptor.input_descriptor.control_user, user_job_name,
            wait_queue_file_name, local_status);
      generate_unique_name := NOT local_status.normal;
      error_file := ^wait_queue_file_name;
    IFEND;
    IF generate_unique_name THEN
      pmp$get_unique_name (unique_name, local_status);
      error_file := ^unique_name;
    IFEND;

    generate_error_file (error_file^, control_block, qtf_file_descriptor, local_status);

{ IF generate_unique_name is FALSE, the error file would have been created in
{ the user's $wait_queue and there is no reason to print the file.

    IF (NOT local_status.normal) OR (NOT generate_unique_name) THEN
      PUSH new_file_attributes: [1..1];
      new_file_attributes^ [1].key := amc$ring_attributes;
      new_file_attributes^ [1].ring_attributes.r1 := osc$user_ring;
      new_file_attributes^ [1].ring_attributes.r2 := osc$user_ring;
      new_file_attributes^ [1].ring_attributes.r3 := osc$user_ring;

      amp$change_file_attributes(error_file^, new_file_attributes, local_status);
      IF NOT local_status.normal THEN
        nfp$format_message_to_job_log(local_status);
        pmp$log('***QTF Initiator: Error changing ring attributes of wait queue file.', local_status);
      IFEND;

      amp$return (error_file^, local_status);
      RETURN;
    IFEND;

    IF qtf_file_descriptor.file_kind = nfc$generic_file THEN
      PUSH print_file_options: [min_print_options .. max_generic_options];
      print_file_options^ [1].key := jmc$comment_banner;
      print_file_options^ [1].comment_banner := 'QTF/VE Error Report';

      print_file_options^ [2].key := jmc$output_destination;
      print_file_options^ [2].output_destination := qtf_file_descriptor.generic_descriptor.destination;

      print_file_options^ [3].key := jmc$output_destination_usage;
      print_file_options^ [3].output_destination_usage := jmc$qtf_usage;

      print_file_options^ [4].key := jmc$origin_application_name;
      print_file_options^ [4].origin_application_name := osc$queue_transfer_client;

      print_file_options^ [5].key := jmc$routing_banner;
      print_file_options^ [5].routing_banner := 'QTF/VE Error Report';

      print_file_options^ [6].key := jmc$user_file_name;
      print_file_options^ [6].user_file_name := 'OUTPUT';

      print_file_options^ [7].key := jmc$user_job_name;
      print_file_options^ [7].user_job_name := qtf_file_descriptor.generic_descriptor.system_file_name;

      print_file_options^ [8].key := jmc$source_logical_id;
      print_file_options^ [8].source_logical_id := control_block.transfer_pid;
    ELSE
      PUSH print_file_options: [min_print_options .. max_print_options];
      print_file_options^ [1].key := jmc$implicit_routing_text;

      IF qtf_file_descriptor.file_kind = nfc$output_file THEN
        comment_banner := qtf_file_descriptor.output_descriptor.comment_banner;
        control_family := qtf_file_descriptor.output_descriptor.control_family;
        control_user := qtf_file_descriptor.output_descriptor.control_user;
        device := qtf_file_descriptor.output_descriptor.device;
        external_characteristics := qtf_file_descriptor.output_descriptor.external_characteristics;
        forms_code := qtf_file_descriptor.output_descriptor.forms_code;
        operator_family := qtf_file_descriptor.output_descriptor.output_destination_family;
        originating_family := qtf_file_descriptor.output_descriptor.login_family;
        originating_user := qtf_file_descriptor.output_descriptor.login_user;
        originating_account := qtf_file_descriptor.output_descriptor.login_account;
        originating_project := qtf_file_descriptor.output_descriptor.login_project;
        output_destination := qtf_file_descriptor.output_descriptor.output_destination;
        output_priority := qtf_file_descriptor.output_descriptor.output_priority;
        routing_banner := qtf_file_descriptor.output_descriptor.routing_banner;
        source_logical_id := qtf_file_descriptor.output_descriptor.source_logical_id;
        station := qtf_file_descriptor.output_descriptor.station;
        station_operator := qtf_file_descriptor.output_descriptor.station_operator;
        user_file_name := qtf_file_descriptor.output_descriptor.user_file_name;
        user_information := qtf_file_descriptor.output_descriptor.user_information;
        user_job_name := qtf_file_descriptor.output_descriptor.user_job_name;
        vfu_load_procedure := qtf_file_descriptor.output_descriptor.vfu_load_procedure;

        print_file_options^ [1].implicit_routing_text := ^qtf_file_descriptor.output_descriptor.
              implicit_routing_text;

      ELSEIF qtf_file_descriptor.file_kind = nfc$input_file THEN
        comment_banner := qtf_file_descriptor.input_descriptor.comment_banner;
        control_family := qtf_file_descriptor.input_descriptor.control_family;
        control_user := qtf_file_descriptor.input_descriptor.control_user;
        device := qtf_file_descriptor.input_descriptor.device;
        external_characteristics := qtf_file_descriptor.input_descriptor.external_characteristics;
        forms_code := qtf_file_descriptor.input_descriptor.forms_code;
        operator_family := qtf_file_descriptor.input_descriptor.output_destination_family;
        originating_family := qtf_file_descriptor.input_descriptor.originating_login_family;
        originating_user := qtf_file_descriptor.input_descriptor.originating_login_user;
        originating_account := qtf_file_descriptor.input_descriptor.originating_login_account;
        originating_project := qtf_file_descriptor.input_descriptor.originating_login_project;
        output_destination := qtf_file_descriptor.input_descriptor.output_destination;
        output_destination_usage := qtf_file_descriptor.input_descriptor.output_destination_usage;
        output_priority := qtf_file_descriptor.input_descriptor.output_priority;
        routing_banner := qtf_file_descriptor.input_descriptor.routing_banner;
        source_logical_id := qtf_file_descriptor.input_descriptor.source_logical_id;
        station := qtf_file_descriptor.input_descriptor.station;
        station_operator := qtf_file_descriptor.input_descriptor.station_operator;
        user_file_name := 'OUTPUT';
        user_information := qtf_file_descriptor.input_descriptor.user_information;
        user_job_name := qtf_file_descriptor.input_descriptor.user_job_name;
        vfu_load_procedure := qtf_file_descriptor.input_descriptor.vfu_load_procedure;

        print_file_options^ [1].implicit_routing_text := ^qtf_file_descriptor.input_descriptor.
              implicit_routing_text;
      IFEND;

      print_file_options^ [2].key := jmc$output_destination_usage;
      print_file_options^ [3].key := jmc$station;

      IF source_logical_id <> osc$null_name THEN
        print_file_options^ [2].output_destination_usage := jmc$qtf_usage;
        print_file_options^ [3].station := station;
      ELSEIF qtf_file_descriptor.file_kind = nfc$input_file THEN
        print_file_options^ [2].output_destination_usage := output_destination_usage;
        print_file_options^ [3].station := station;
      ELSEIF qtf_file_descriptor.file_kind = nfc$output_file THEN
        PUSH default_attributes: [1 .. 2];
        default_attributes^[1].key := jmc$output_destination_usage;
        default_attributes^[2].key := jmc$station;

        jmp$get_attribute_defaults (jmc$batch, default_attributes, local_status);
        IF local_status.normal THEN
          print_file_options^ [2].output_destination_usage := default_attributes^[1].output_destination_usage;
          print_file_options^ [3].station := default_attributes^[2].station;
        IFEND;
      IFEND;

      print_file_options^ [4].key := jmc$output_destination_family;
      print_file_options^ [4].output_destination_family := operator_family;

      print_file_options^ [5].key := jmc$control_family;
      print_file_options^ [5].control_family := control_family;

      print_file_options^ [6].key := jmc$control_user;
      print_file_options^ [6].control_user := control_user;

      print_file_options^ [7].key := jmc$login_family;
      print_file_options^ [7].login_family := originating_family;

      print_file_options^ [8].key := jmc$login_user;
      print_file_options^ [8].login_user := originating_user;

      print_file_options^ [9].key := jmc$login_account;
      print_file_options^ [9].login_account := originating_account;

      print_file_options^ [10].key := jmc$login_project;
      print_file_options^ [10].login_project := originating_project;

      print_file_options^ [11].key := jmc$comment_banner;
      print_file_options^ [11].comment_banner := comment_banner;

      print_file_options^ [12].key := jmc$routing_banner;
      print_file_options^ [12].routing_banner := routing_banner;

      print_file_options^ [13].key := jmc$output_destination;
      IF source_logical_id <> osc$null_name THEN
        print_file_options^ [13].output_destination := source_logical_id;
      ELSE
        print_file_options^ [13].output_destination := output_destination;
      IFEND;

      print_file_options^ [14].key := jmc$station_operator;
      print_file_options^ [14].station_operator := station_operator;

      print_file_options^ [15].key := jmc$user_job_name;
      print_file_options^ [15].user_job_name := user_job_name;

      print_file_options^ [16].key := jmc$device;
      print_file_options^ [16].device := device;

      print_file_options^ [17].key := jmc$external_characteristics;
      print_file_options^ [17].external_characteristics := external_characteristics;

      print_file_options^ [18].key := jmc$forms_code;
      print_file_options^ [18].forms_code := forms_code;

      print_file_options^ [19].key := jmc$output_priority;
      print_file_options^ [19].output_priority := output_priority;

      print_file_options^ [20].key := jmc$user_information;
      print_file_options^ [20].user_information := ^user_information;

      print_file_options^ [21].key := jmc$user_file_name;
      print_file_options^ [21].user_file_name := user_file_name;

      print_file_options^ [22].key := jmc$vfu_load_procedure;
      print_file_options^ [22].vfu_load_procedure := vfu_load_procedure;

      print_file_options^ [23].key := jmc$origin_application_name;
      print_file_options^ [23].origin_application_name := osc$queue_transfer_client;
    IFEND;


    jmp$print_file (error_file^, print_file_options, system_file_name, local_status);

    amp$return (error_file^, local_status);

  PROCEND print_output_error_file;
?? TITLE := 'retry_print_output_error_file', EJECT ??

{ PURPOSE:
{   This procedure is called if the error listing printed by
{   print_output_error_file fails to transfer. The name of the
{   error listing is changed from OUTPUT to QTFERR to allow
{   QTFI to distinguish between error listings queued from this
{   procedure, and those queued from print_output_error_file.
{   The attributes of the new error listing default mainly from
{   the job attributes of the system job where QTFI executes.

  PROCEDURE retry_print_output_error_file
    (    qtf_file_descriptor: nft$application_file_descriptor;
         control_block: nft$control_block);

    CONST
      min_retry_print_options = 1,
      max_retry_print_options = 16;

    VAR
      error_file: ^fst$file_reference,
      local_status: ost$status,
      print_file_options: ^jmt$output_submission_options,
      system_file_name : jmt$system_supplied_name,
      unique_name: ost$name;

    local_status.normal := TRUE;

    pmp$get_unique_name (unique_name, local_status);
    error_file := ^unique_name;

    generate_error_file (error_file^, control_block, qtf_file_descriptor, local_status);

    IF (NOT local_status.normal) THEN
      amp$return (error_file^, local_status);
      RETURN;
    IFEND;

    PUSH print_file_options: [min_retry_print_options .. max_retry_print_options];

    print_file_options^ [1].key := jmc$comment_banner;
    print_file_options^ [1].comment_banner := qtf_file_descriptor.output_descriptor.login_user;

    print_file_options^ [2].key := jmc$control_family;
    print_file_options^ [2].control_family := qtf_file_descriptor.output_descriptor.control_family;

    print_file_options^ [3].key := jmc$control_user;
    print_file_options^ [3].control_user := qtf_file_descriptor.output_descriptor.control_user;

    print_file_options^ [4].key := jmc$login_account;
    print_file_options^ [4].login_account := qtf_file_descriptor.output_descriptor.login_account;

    print_file_options^ [5].key := jmc$login_family;
    print_file_options^ [5].login_family := qtf_file_descriptor.output_descriptor.login_family;

    print_file_options^ [6].key := jmc$login_project;
    print_file_options^ [6].login_project := qtf_file_descriptor.output_descriptor.login_project;

    print_file_options^ [7].key := jmc$login_user;
    print_file_options^ [7].login_user := qtf_file_descriptor.output_descriptor.login_user;

    print_file_options^ [8].key := jmc$origin_application_name;
    print_file_options^ [8].origin_application_name := osc$queue_transfer_client;

    print_file_options^ [9].key := jmc$output_destination_family;
    print_file_options^ [9].output_destination_family :=
        qtf_file_descriptor.output_descriptor.output_destination_family;

    print_file_options^ [10].key := jmc$output_priority;
    print_file_options^ [10].output_priority := qtf_file_descriptor.output_descriptor.output_priority;

    print_file_options^ [11].key := jmc$routing_banner;
    print_file_options^ [11].routing_banner := qtf_file_descriptor.output_descriptor.login_user;

    print_file_options^ [12].key := jmc$station_operator;
    print_file_options^ [12].station_operator := qtf_file_descriptor.output_descriptor.station_operator;

    print_file_options^ [13].key := jmc$user_file_name;
    print_file_options^ [13].user_file_name := 'QTFERR';

    print_file_options^ [14].key := jmc$user_information;
    print_file_options^ [14].user_information := ^qtf_file_descriptor.output_descriptor.user_information;

    print_file_options^ [15].key := jmc$user_job_name;
    print_file_options^ [15].user_job_name := 'QTFERR';

    print_file_options^ [16].key := jmc$vfu_load_procedure;
    print_file_options^ [16].vfu_load_procedure := qtf_file_descriptor.output_descriptor.vfu_load_procedure;

    jmp$print_file (error_file^, print_file_options, system_file_name, local_status);

    amp$return (error_file^, local_status);

  PROCEND retry_print_output_error_file;
?? TITLE := 'ready_task_for_termination', EJECT ??

{ PURPOSE:
{   This procedure makes sure everything is cleaned up so the task
{   can go down with expected results.  The QTFC task issued the
{   message to QTFI and QTFC is expecting a normal termination.

  PROCEDURE ready_task_for_termination
    (    qtfc_task_id: pmt$task_id;
         control_block: nft$control_block);

    VAR
      local_status: ost$status,
      retry_count: 0 .. 10,
      task_terminated_msg: nft$intertask_message;


    task_terminated_msg.kind := nfc$qtf_task_terminated;
    nfp$put_async_task_message (qtfc_task_id, ^task_terminated_msg, #SIZE (task_terminated_msg),
          local_status);

    retry_count := 0;
    REPEAT
      nfp$end_async_communication (TRUE, local_status);
      IF NOT local_status.normal THEN

{ QTFI should wait for 100 milliseconds.  This is done to insure that the
{ last message sent was picked up by QTFC.

        pmp$wait (qtfi_tenth_of_a_second, qtfi_tenth_of_a_second);
      IFEND;
      retry_count := retry_count + 1;
    UNTIL local_status.normal OR (retry_count = 10);

{ This makes sure that QTFI will end communication with QTFC and terminate.
{ If QTFI can't end communications, this assumes that QTFC is going down and is
{ not able to talk to QTFI.

    IF retry_count = 10 THEN
      nfp$end_async_communication (FALSE, local_status);
    IFEND;

    IF control_block.path.path_connected THEN
      fsp$close_file (control_block.path.network_file_id, local_status);
    IFEND;

  PROCEND ready_task_for_termination;
?? TITLE := 'stop_transfer_protocol', EJECT ??

{ PURPOSE:
{   This procedure is used to finish the transfer protocol with the
{   server, indicating a file transfer is completed.

  PROCEDURE stop_transfer_protocol
    (    qtf_file_descriptor: nft$application_file_descriptor;
     VAR control_block: nft$control_block;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      stop_legal_resp_commands: nft$command_set,
      stop_parameter_set: nft$parameter_set,
      stopr_ignored_params: nft$parameter_set,
      stopr_modified_params: nft$parameter_set,
      stopr_received_params: nft$parameter_set;


    status.normal := TRUE;

    stop_legal_resp_commands := $nft$command_set [nfc$stopr];
    stop_parameter_set := $nft$parameter_set [nfc$state_of_transfer];

    IF control_block.path.path_connected THEN
      nfp$send_command (nfc$stop, stop_parameter_set, $nft$parameter_set[ ],
            $nft$parameter_set[ ], control_block, status);
      IF status.normal THEN
        nfp$receive_command (stop_legal_resp_commands, nfv$qtf_required_params_on_cmds, control_block,
              stopr_received_params, stopr_ignored_params, stopr_modified_params, status);
      IFEND;
    IFEND;
    IF (NOT control_block.state_of_transfer.normal) AND
       NOT ((control_block.state_of_transfer.condition = nfe$receiver_problem_retry)
        OR (control_block.state_of_transfer.condition = nfe$sender_problem_retry)) AND
       NOT(control_block.negotiate_protocol) THEN

      IF qtf_file_descriptor.file_kind = nfc$output_file THEN
        IF (qtf_file_descriptor.output_descriptor.originating_application_name <>
           osc$queue_transfer_client) THEN

{ QTFI has NOT generated this file as an error listing. Generate an error listing for the first time.

          print_output_error_file (qtf_file_descriptor, control_block);

        ELSE { file_kind = nfc$output_file AND originating_application = osc$queue_transfer_client

{ QTFI has generated this file as an error listing and this file failed to transfer.
{ If the user_file_name of this file is NOT QTFERR, then make a second attempt to
{ generate & print an error listing. IF user_file_name is QTFERR, then this file is
{ QTFI's second attempt to print an error-listing. QTFI will not attempt a third listing.

          IF qtf_file_descriptor.output_descriptor.user_file_name(1,6) <> 'QTFERR' THEN
            retry_print_output_error_file (qtf_file_descriptor, control_block);
          ELSE
            pmp$log ('***QTFI, STOP_TRANSFER_PROTOCOL: unable to transfer file or error listing.',
              local_status);
          IFEND;

        IFEND;
      ELSE { (file_kind = nfc$input_file) OR (file_kind = nfc$generic_file)
        print_output_error_file (qtf_file_descriptor, control_block);
      IFEND;
    IFEND;
    IF (control_block.received_operator_messages.head <> NIL) THEN
      nfp$deallocate_dirs_from_head( control_block.received_operator_messages, local_status);
    IFEND;
    IF (control_block.received_user_messages.head <> NIL) THEN
      nfp$deallocate_dirs_from_head( control_block.received_user_messages, local_status);
    IFEND;

  PROCEND  stop_transfer_protocol;
?? TITLE := 'terminate_connection', EJECT ??

{ PURPOSE:
{   This procedure is called when the current connection is no longer
{   needed.  The connection file is closed but not returned.  QTFC
{   will return the connection.
{
{ NOTE:
{   qtfi_connection_file_name is a global variable.

  PROCEDURE terminate_connection
    (    qtfc_task_id: pmt$task_id;
         connection_file_name: amt$local_file_name;
     VAR control_block: nft$control_block);

    VAR
      connection_terminated_msg: nft$intertask_message,
      local_status: ost$status;


    local_status.normal := TRUE;

    IF (control_block.path.network_file <> NIL) AND (connection_file_name =
          control_block.path.network_file^) AND control_block.path.path_connected THEN
      end_and_finish_protocol (control_block);
      qtfi_connection_file_name := osc$null_name;
      control_block.transfer_pid := osc$null_name;
      control_block.path.network_file := NIL;
      control_block.path.path_connected := FALSE;
      fsp$close_file (control_block.path.network_file_id, local_status);
    IFEND;

    connection_terminated_msg.kind := nfc$qtf_connection_terminated;
    nfp$put_async_task_message (qtfc_task_id, ^connection_terminated_msg, #SIZE (connection_terminated_msg),
          local_status);

  PROCEND terminate_connection;
?? TITLE := 'transfer_file', EJECT ??

{ PURPOSE:
{   This procedure does most of the work to transfer a file.  If the
{   file transfer does not complete normally and the file is an
{   output file, QTFI will create an error listing and submit it to
{   be printed at the source mainframe.

  PROCEDURE transfer_file
    (    qtfc_task_id: pmt$task_id;
         file_transfer_msg: nft$intertask_message;
     VAR control_block: nft$control_block;
     VAR status: ost$status);

    VAR
      consistent_protocol_state: boolean,
      open_access_level: amt$access_level,
      queue_file_identifier: amt$file_identifier,
      stop_transfer_status: ost$status,
      system_file_name: jmt$system_supplied_name,
      transfer_mode: nft$transfer_modes,
      transfer_status_msg: nft$intertask_message;

?? NEWTITLE := 'generate_qtf_statistic', EJECT ??
{
{     The purpose of this request is to emit the origin QTF statistic.
{
{       GENERATE_QTF_STATISTIC(FILE_DESCRIPTOR,SOURCE_LOGICAL_IDENTIFIER,
{            TRANSFER_LOGICAL_IDENTIFIER)
{
{ FILE_DESCRIPTOR : (input) Attributes of queue file.
{
{ SOURCE_LOGICAL_IDENTIFIER : (input) Initiating mainframe name.
{
{ TRANSFER_LOGICAL_IDENTIFIER : (input) Received mainframe name.
{
    PROCEDURE generate_qtf_statistic
      (      file_descriptor: nft$application_file_descriptor;
             source_logical_identifier: string(*<=nfc$p24_max_param_size);
             transfer_logical_identifier: string(*<=nfc$p24_max_param_size));

 VAR
      local_status: ost$status,
      qtf_statistic: jmt$qtf_statistic_data,
      statistic_data: jmt$comm_acct_statistic_data;

{ If the source lid is set, this is a store and forward case, no stat.

    IF (file_descriptor.file_kind = nfc$output_file) THEN
      IF (file_descriptor.output_descriptor.source_logical_id <> '') THEN
        RETURN;
      ELSE
        qtf_statistic.user_identification.user :=
             file_descriptor.output_descriptor.login_user;
        qtf_statistic.user_identification.family :=
             file_descriptor.output_descriptor.login_family;
        qtf_statistic.account_name :=
             file_descriptor.output_descriptor.login_account;
        qtf_statistic.project_name :=
             file_descriptor.output_descriptor.login_project;

{ Output file statistic uses system_job_name and user_file_name for
{ tracking purposes.

        qtf_statistic.system_job_name :=
             file_descriptor.output_descriptor.system_job_name;
        qtf_statistic.user_job_name :=
             file_descriptor.output_descriptor.user_file_name;
        qtf_statistic.file_size :=
             file_descriptor.output_descriptor.file_size;
        qtf_statistic.origin_mainframe_name :=
             source_logical_identifier;
        qtf_statistic.dest_mainframe_name :=
             transfer_logical_identifier;
      IFEND;
    ELSEIF (file_descriptor.file_kind = nfc$input_file) THEN
      IF (file_descriptor.input_descriptor.source_logical_id <> '') THEN
        RETURN;
      ELSE
        qtf_statistic.user_identification.user :=
             file_descriptor.input_descriptor.originating_login_user;
        qtf_statistic.user_identification.family :=
             file_descriptor.input_descriptor.originating_login_family;
        qtf_statistic.account_name :=
             file_descriptor.input_descriptor.originating_login_account;
        qtf_statistic.project_name :=
             file_descriptor.input_descriptor.originating_login_project;
        qtf_statistic.system_job_name :=
             file_descriptor.input_descriptor.originating_system_job_name;
        qtf_statistic.user_job_name :=
             file_descriptor.input_descriptor.user_job_name;
        qtf_statistic.file_size :=
             file_descriptor.input_descriptor.job_size;
        qtf_statistic.origin_mainframe_name :=
             source_logical_identifier;
        qtf_statistic.dest_mainframe_name :=
             transfer_logical_identifier;
      IFEND;
    ELSE
      osp$set_status_abnormal( nfc$status_id, nfe$bts_internal_error,
             'QTF_INITIATOR - generate_qtf_statistic, bad file_kind',
             local_status );
      nfp$format_message_to_job_log( local_status );
    IFEND;

    statistic_data.statistic_id := jmc$ca_origin_qf_transfer;
    statistic_data.origin_queue_file_transfer := ^qtf_statistic;
    jmp$emit_communication_stat( statistic_data );

    PROCEND generate_qtf_statistic;
?? OLDTITLE ??
?? NEWTITLE := 'negotiate_file_transfer', EJECT ??

{ PURPOSE:
{   This procedure does the file transfer negotiation.  It sets up
{   the RFT and receives the RPOS.  These two protocol commands are
{   considered the file transfer negotiation.

    PROCEDURE negotiate_file_transfer
      (    transfer_file_descriptor: nft$application_file_descriptor;
       VAR control_block: nft$control_block;
       VAR transfer_mode: nft$transfer_modes;
       VAR status: ost$status);

      VAR
        go_parameter_set: nft$parameter_set,
        rft_legal_resp_commands: nft$command_set,
        rft_parameter_set: nft$parameter_set,
        rpos_ignored_params: nft$parameter_set,
        rpos_modified_params: nft$parameter_set,
        rpos_received_params: nft$parameter_set;

?? NEWTITLE := 'set_transfer_mode', EJECT ??

{ PURPOSE:
{   This function will determine what the transfer mode should be
{   given the data declaration set in the protocol negotiation.

      FUNCTION set_transfer_mode
        (    transfer_file_descriptor: nft$application_file_descriptor;
             rft_parameters: nft$parameter_set;
             rpos_received_parameters: nft$parameter_set;
             rpos_modified_parameters: nft$parameter_set;
             control_block: nft$control_block): nft$transfer_modes;

        VAR
          data_mode: jmt$data_mode;


        IF control_block.data_declaration = nfc$p31_host_dependent_uh THEN
          set_transfer_mode := nfc$ve_to_ve_mode;
        ELSEIF control_block.data_declaration = nfc$p31_undef_unstructured_uu THEN
          set_transfer_mode := nfc$transparent_data_mode;
        ELSEIF control_block.data_declaration = nfc$p31_undefined_structured_us THEN
          set_transfer_mode := nfc$rhf_structured_mode;
        ELSEIF (control_block.data_declaration = nfc$p31_ascii_c6) OR
              (control_block.data_declaration = nfc$p31_ascii_c8) OR
              (control_block.data_declaration = nfc$p31_unspecified) OR
              ((NOT (nfc$data_declaration IN rft_parameters)) AND
              (NOT (nfc$data_declaration IN rpos_received_parameters)) AND
              (NOT (nfc$data_declaration IN rpos_modified_parameters))) THEN
          IF transfer_file_descriptor.file_kind = nfc$output_file THEN
            data_mode := transfer_file_descriptor.output_descriptor.data_mode;
          ELSEIF transfer_file_descriptor.file_kind = nfc$input_file THEN
            data_mode := transfer_file_descriptor.input_descriptor.data_mode;
          IFEND;
          IF data_mode = jmc$rhf_structure THEN
            set_transfer_mode := nfc$rhf_structured_mode;
          ELSE
            set_transfer_mode := nfc$coded_data_mode;
          IFEND;
        IFEND;

      FUNCEND set_transfer_mode;
?? TITLE := 'set_up_rft', EJECT ??

{ PURPOSE:
{   This procedure sets up all the parameters in the RFT based on
{   the queue file attributes.

      PROCEDURE set_up_rft
        (    file_desc: nft$application_file_descriptor;
         VAR rft_parameter_set: nft$parameter_set;
         VAR control_block: nft$control_block);

        VAR
          data_declaration: jmt$data_declaration,
          data_mode: jmt$data_mode,
          file_disposition: jmt$disposition_code,
          implicit_routing_text: jmt$implicit_routing_text,
          index: nft$protocol_parameters,
          output_disposition: jmt$output_disposition,
          nam_optimum_attributes: ^nat$get_attributes,
          remote_host_directive: jmt$remote_host_directive,
          source_lid: nft$parameter_24_definition,
          system_routing_text: jmt$system_routing_text,
          user_text_directive: [STATIC] ^nft$directive_entry := NIL;

?? NEWTITLE := 'build_implicit_routing_text', EJECT ??
{ PURPOSE:
{   This procedure builds the implicit routing text from selected
{   attributes of the queue file.  The format of implicit routing
{   text is defined in the QTF Design direction.
{
{ NOTE:
{   Implicit routing text has the format of:
{     <osid><sjn>';'<login parameters>';'<print file parameters>
{   where osid = 'NV1' and sjn is the system job name of the input
{   queue file being transferred to a remote system.
{
{   If an attribute has a value of NONE or NORMAL, then the parameter
{   will not be included in the implicit routing text.

        PROCEDURE build_implicit_routing_text
          (    file_desc: nft$application_file_descriptor;
           VAR implicit_routing_text: jmt$implicit_routing_text);

          CONST
            blank_fill = ' ',
            semicolon = ';',
            max_key_size = 4,
            min_key_size = 2,
            key_size_3 = 3;

          TYPE
            login_parameters = (user, family, user_job_name, account, project),
            prif_parameters = (disposition_code, output_destination_usage, station, output_destination,
                  operator_user, operator_family, device, forms_code, external_characteristics,
                  vertical_print_density, vfu_load_proc, routing_banner, comment_banner, copies, output_class,
                  output_priority, purge_delay, latest_print_time, earliest_print_time);

          VAR
            copy_count_str: ost$string,
            irt_param_length: 0 .. jmc$implicit_routing_text_size,
            irt_parameter: string (jmc$implicit_routing_text_size),
            local_status: ost$status,
            login_index: login_parameters,
            login_keys: [STATIC, READ] array [login_parameters] of string (max_key_size) := ['U=', 'FN=',
                  'UJN=', 'A=', 'P='],
            prif_index: prif_parameters,
            prif_keys: [STATIC, READ] array [prif_parameters] of string (max_key_size) := ['DC=', 'DU=', 'S=',
                  'ODE=', 'OU=', 'OF=', 'D=', 'FC=', 'EC=', 'VPD=', 'VLP=', 'RB=', 'CB=', 'C=', 'OC=', 'OP=',
                  'PD=', 'LPT=', 'EPT='];

?? NEWTITLE := 'map_vpd_to_irt_parameter', EJECT ??

{ PURPOSE:
{   This procedure maps an ordinal value of the vertical print
{   density to a keyword value.

          PROCEDURE map_vpd_to_irt_parameter
            (    vertical_print_density: jmt$vertical_print_density;
             VAR  irt_parameter: string (jmc$implicit_routing_text_size));

            CASE vertical_print_density OF
            = jmc$vertical_print_density_file =
              irt_parameter (max_key_size + 1, * ) := 'FILE';

            = jmc$vertical_print_density_6 =
              irt_parameter (max_key_size + 1, * ) := 'SIX';

            = jmc$vertical_print_density_8 =
              irt_parameter (max_key_size + 1, * ) := 'EIGHT';

            = jmc$vertical_print_density_none, jmc$vertical_print_density_7, jmc$vertical_print_density_9,
                  jmc$vertical_print_density_10, jmc$vertical_print_density_11,
                  jmc$vertical_print_density_12 =

{ These print densities do not have key values at R.1.2.3.

              irt_parameter := ' ';

            ELSE
              irt_parameter := ' ';

            CASEND;

          PROCEND map_vpd_to_irt_parameter;
?? OLDTITLE, EJECT ??
          IF (file_desc.file_kind = nfc$output_file) or (file_desc.file_kind = nfc$generic_file) THEN
            implicit_routing_text.size := 0;
            implicit_routing_text.text := osc$null_name;
          ELSEIF file_desc.file_kind = nfc$input_file THEN
            implicit_routing_text.text := nfc$p33_nos_ve_text_identifier;
            implicit_routing_text.text (nfc$p33_nos_ve_text_id_length + 1, jmc$system_supplied_name_size) :=
                  file_desc.input_descriptor.system_job_name;
            implicit_routing_text.size := nfc$p33_nos_ve_text_id_length + jmc$system_supplied_name_size;

            implicit_routing_text.text (implicit_routing_text.size + 1) := semicolon;
            implicit_routing_text.size := implicit_routing_text.size + 1;

            FOR login_index := user TO project DO
              irt_parameter := login_keys [login_index];
              CASE login_index OF
              = user =
                irt_parameter (min_key_size + 1, * ) := file_desc.input_descriptor.originating_login_user;

              = family =
                irt_parameter (key_size_3 + 1, * ) := file_desc.input_descriptor.originating_login_family;

              = user_job_name =
                IF file_desc.input_descriptor.user_job_name <> ' ' THEN
                  irt_parameter (max_key_size + 1, * ) := file_desc.input_descriptor.user_job_name;
                ELSE
                  irt_parameter := ' ';
                IFEND;

              = account =
                IF file_desc.input_descriptor.originating_login_account <> ' ' THEN
                  irt_parameter (min_key_size + 1, * ) := file_desc.input_descriptor.
                        originating_login_account;
                ELSE
                  irt_parameter := ' ';
                IFEND;

              = project =
                IF file_desc.input_descriptor.originating_login_project <> ' ' THEN
                  irt_parameter (min_key_size + 1, * ) := file_desc.input_descriptor.
                        originating_login_project;
                ELSE
                  irt_parameter := ' ';
                IFEND;

              ELSE
                irt_parameter := ' ';

              CASEND;
              IF irt_parameter <> ' ' THEN
                irt_param_length := clp$trimmed_string_size (irt_parameter);
                IF ((irt_param_length + implicit_routing_text.size) <= jmc$implicit_routing_text_size) THEN
                  implicit_routing_text.text (implicit_routing_text.size + 1,
                        irt_param_length) := irt_parameter (1, irt_param_length);
                  implicit_routing_text.size := implicit_routing_text.size + irt_param_length;

                  implicit_routing_text.text (implicit_routing_text.size + 1) := blank_fill;
                  implicit_routing_text.size := implicit_routing_text.size + 1;
                IFEND;
              IFEND;
            FOREND;

            implicit_routing_text.text (implicit_routing_text.size) := semicolon;

            FOR prif_index := disposition_code TO earliest_print_time DO
              irt_parameter := prif_keys [prif_index];
              CASE prif_index OF
              = disposition_code =
                IF file_desc.input_descriptor.output_disposition.key = jmc$wait_queue_path THEN
                  irt_parameter (key_size_3 + 1, * ) := nfc$p33_imp_wait_queue_value_wt;
                ELSE
                  irt_parameter := ' ';
                IFEND;

              = output_destination_usage =
                IF (file_desc.input_descriptor.output_destination_usage <>jmc$qtf_usage) OR
                      ((file_desc.input_descriptor.output_destination_usage = jmc$qtf_usage) AND
                      (file_desc.input_descriptor.output_destination <> file_desc.input_descriptor.
                      originating_login_family)) THEN
                  irt_parameter (key_size_3 + 1, * ) := file_desc.input_descriptor.output_destination_usage;
                ELSE
                  irt_parameter := ' ';
                IFEND;

              = station =
                irt_parameter (min_key_size + 1, * ) := file_desc.input_descriptor.station;

              = output_destination =
                irt_parameter (max_key_size + 1, * ) := file_desc.input_descriptor.output_destination;

              = operator_user =
                irt_parameter (key_size_3 + 1, * ) := file_desc.input_descriptor.station_operator;

              = operator_family =
                irt_parameter (key_size_3 + 1, * ) := file_desc.input_descriptor.output_destination_family;

              = device =
                irt_parameter (min_key_size + 1, * ) := file_desc.input_descriptor.device;

              = forms_code =
                IF file_desc.input_descriptor.forms_code <> nfc$normal_string THEN
                  irt_parameter (key_size_3 + 1, * ) := '''';
                  irt_parameter (key_size_3 + 2, * ) := file_desc.input_descriptor.forms_code;
                  irt_parameter (key_size_3 + 2 + clp$trimmed_string_size
                        (file_desc.input_descriptor.forms_code), * ) := '''';
                ELSE
                  irt_parameter := ' ';
                IFEND;

              = external_characteristics =
                IF file_desc.input_descriptor.external_characteristics <> nfc$normal_string THEN
                  irt_parameter (key_size_3 + 1, * ) := '''';
                  irt_parameter (key_size_3 + 2, * ) := file_desc.input_descriptor.external_characteristics;
                  irt_parameter (key_size_3 + 2 + clp$trimmed_string_size
                        (file_desc.input_descriptor.external_characteristics), * ) := '''';
                ELSE
                  irt_parameter := ' ';
                IFEND;

              = vertical_print_density =
                map_vpd_to_irt_parameter (file_desc.input_descriptor.vertical_print_density, irt_parameter);

              = vfu_load_proc =
                IF file_desc.input_descriptor.vfu_load_procedure = osc$null_name THEN
                  irt_parameter := ' ';
                ELSE
                  irt_parameter (max_key_size + 1, * ) := file_desc.input_descriptor.vfu_load_procedure;
                IFEND;

              = routing_banner =
                IF file_desc.input_descriptor.routing_banner = osc$null_name THEN
                  irt_parameter := ' ';
                ELSE
                  irt_parameter (key_size_3 + 1, * ) := '''';
                  irt_parameter (key_size_3 + 2, * ) := file_desc.input_descriptor.routing_banner;
                  irt_parameter (key_size_3 + 2 + clp$trimmed_string_size
                        (file_desc.input_descriptor.routing_banner), * ) := '''';
                IFEND;

              = comment_banner =
                IF file_desc.input_descriptor.comment_banner = osc$null_name THEN
                  irt_parameter := ' ';
                ELSE
                  irt_parameter (key_size_3 + 1, * ) := '''';
                  irt_parameter (key_size_3 + 2, * ) := file_desc.input_descriptor.comment_banner;
                  irt_parameter (key_size_3 + 2 + clp$trimmed_string_size
                        (file_desc.input_descriptor.comment_banner), * ) := '''';
                IFEND;

              = copies =
                clp$convert_integer_to_string (file_desc.input_descriptor.copies, 10, FALSE, copy_count_str,
                      local_status);
                irt_parameter (min_key_size + 1, * ) := copy_count_str.value;

              = output_class =
                IF file_desc.input_descriptor.output_class <> nfc$normal_string THEN
                  irt_parameter (key_size_3 + 1, * ) := file_desc.input_descriptor.output_class;
                ELSE
                  irt_parameter := ' ';
                IFEND;

              = output_priority =
                irt_parameter (key_size_3 + 1, * ) := file_desc.input_descriptor.output_priority;

              = purge_delay, latest_print_time, earliest_print_time =

{ These parameters are not supported until SCL allows time variables.  Check with QFM ERS for
{ availability and make sure QTFS will accept these parameters.

                irt_parameter := ' ';

              ELSE
                irt_parameter := ' ';

              CASEND;
              IF irt_parameter <> ' ' THEN
                irt_param_length := clp$trimmed_string_size (irt_parameter);
                IF ((irt_param_length + implicit_routing_text.size) <= jmc$implicit_routing_text_size) THEN
                  implicit_routing_text.text (implicit_routing_text.size + 1,
                        irt_param_length) := irt_parameter (1, irt_param_length);
                  implicit_routing_text.size := implicit_routing_text.size + irt_param_length;

                  IF implicit_routing_text.size < jmc$implicit_routing_text_size THEN
                    implicit_routing_text.text (implicit_routing_text.size + 1) := blank_fill;
                    implicit_routing_text.size := implicit_routing_text.size + 1;
                  IFEND;
                IFEND;
              IFEND;
            FOREND;

            IF implicit_routing_text.text (implicit_routing_text.size) = blank_fill THEN
              implicit_routing_text.size := implicit_routing_text.size - 1;
            IFEND;
          IFEND;

        PROCEND build_implicit_routing_text;
?? TITLE := 'build_parameter_29_echo_text', EJECT ??

{ PURPOSE:
{   This procedure will create the echo text (parameter 29) with the
{   values for the user specified LOGIN_FAMILY and the DATA_MODE of
{   RHF_STRUCTURED.  The data mode needs to be transferred for a
{   store and forward queue file.

        PROCEDURE build_parameter_29_echo_text
          (    login_family: ost$name;
               data_declaration: jmt$data_declaration;
               data_mode: jmt$data_mode;
               protocol_in_use: nft$parameter_00_values;
               originating_application_name: ost$name;
           VAR rft_parameter_set: nft$parameter_set;
           VAR parameter_29_list_head: nft$parameter_29_list_head);

          VAR
            created_echo_text: boolean,
            echo_text_size: ost$non_negative_integers,
            p29_text: [STATIC] nft$parameter_29_definition;

          created_echo_text := FALSE;
          echo_text_size := 0;

          IF (login_family <> osc$null_name) AND (protocol_in_use = nfc$p00_a102) THEN
            created_echo_text := TRUE;
            p29_text.value ((echo_text_size + 1), nfc$p29_login_family_param_len) :=
                  nfc$p29_login_family_parameter;
            echo_text_size := echo_text_size + nfc$p29_login_family_param_len;
            p29_text.value ((echo_text_size + 1), * ) := login_family;
            echo_text_size := clp$trimmed_string_size (p29_text.value);
          IFEND;

          IF NOT ((data_declaration = nfc$p31_ascii_64) OR (data_declaration = nfc$p31_undefined_unstructured)
                OR (data_declaration = nfc$p31_ascii_extended) OR (data_declaration = nfc$p31_host_dependent)
                OR (data_declaration = nfc$p31_undefined_structured)) AND (data_mode = jmc$rhf_structure) THEN

            IF created_echo_text THEN

{ separate the two parameters by a comma

              echo_text_size := echo_text_size + 1;
              p29_text.value (echo_text_size, * ) := ',';
            ELSE
              created_echo_text := TRUE;
            IFEND;
            p29_text.value ((echo_text_size + 1), nfc$p29_data_mode_param_length) :=
                  nfc$p29_data_mode_parameter;
            echo_text_size := echo_text_size + nfc$p29_data_mode_param_length;
            p29_text.value ((echo_text_size + 1), nfc$p29_rhf_structured_length) :=
                  nfc$p29_rhf_structured_value;
            echo_text_size := echo_text_size + nfc$p29_rhf_structured_length;
          IFEND;

          IF originating_application_name = osc$queue_transfer_client THEN
            IF created_echo_text THEN

{ separate the two parameters by a comma

              echo_text_size := echo_text_size + 1;
              p29_text.value (echo_text_size, * ) := ',';
            ELSE
              created_echo_text := TRUE;
            IFEND;
            p29_text.value ((echo_text_size +1), nfc$p29_qtfi_info_length) :=
                  nfc$p29_qtfi_info;
            echo_text_size := echo_text_size + nfc$p29_qtfi_info_length;
            p29_text.value ((echo_text_size + 1), nfc$p29_qtfi_info_err_file_len) :=
                  nfc$p29_qtfi_info_err_file;
            echo_text_size := echo_text_size + nfc$p29_qtfi_info_err_file_len;
          IFEND;

          IF created_echo_text THEN
            p29_text.size := echo_text_size;
            p29_text.link := NIL;
            parameter_29_list_head.first_text := ^p29_text;
            parameter_29_list_head.last_text := ^p29_text;
            rft_parameter_set := rft_parameter_set + $nft$parameter_set [nfc$echo];
          IFEND;

        PROCEND build_parameter_29_echo_text;

?? TITLE := 'truncate_name', EJECT ??

{ PURPOSE:
{   Truncate family, user and job name to maximum of 7 characters.
{
{ NOTE:
{   Only allowed characters include A-Z, 0..9, $, #, and @.

        PROCEDURE truncate_name
          (    original_name : ost$name;
           VAR return_string : string(31);
           VAR return_size : 0 .. 7);

          CONST
            maximum_name_length = 7;

          VAR
            index: 1 .. 31,
            original_name_length: 1 .. 31,
            scratch_index: 1 .. 31;

          original_name_length := clp$trimmed_string_size (original_name);

          return_size := 0;
          scratch_index := 1;

        /check_character/
          FOR index := 1 TO original_name_length DO
            IF (($INTEGER (original_name (index)) >= $INTEGER (nfc$p26_1st_range1_a101)) AND
                ($INTEGER (original_name (index)) <= $INTEGER (nfc$p26_last_range1_a101))) OR
                (($INTEGER (original_name (index)) >= $INTEGER (nfc$p26_1st_range2_a101)) AND
                ($INTEGER (original_name (index)) <= $INTEGER (nfc$p26_last_range2_a101))) OR
                ($INTEGER (original_name (index)) = $INTEGER (nfc$p26_special1_a101)) OR
                ($INTEGER (original_name (index)) = $INTEGER (nfc$p26_special2_a101)) THEN
              return_string (scratch_index) := original_name (index);
              scratch_index := scratch_index + 1;
              return_size := return_size + 1;
              IF return_size = maximum_name_length THEN
                EXIT /check_character/
              IFEND;
            IFEND;
          FOREND /check_character/;

        PROCEND truncate_name;
?? TITLE := 'build_system_routing_text', EJECT ??

{ PURPOSE:
{   This procedure builds the system routing text from selected
{   attributes of the queue file.  The format of system routing text
{   is defined in the QTF Design direction.  The system routing text
{   format is also used by NOS and NOS/BE

        PROCEDURE build_system_routing_text
          (    file_desc: nft$application_file_descriptor;
           VAR system_routing_text: jmt$system_routing_text);

          CONST
            period = '.',
            srt_identifier_length = 3,
            srt_key_long_length = 5,
            srt_key_short_length = 4,
            user_job_name_prefix = '#';

          TYPE
            system_routing_text_parameters = (srt_control_family_name, srt_control_user_name,
                  srt_owner_family_name, srt_owner_user_name, srt_charge_part_1, srt_charge_part_2,
                  srt_project_part_1, srt_project_part_2, srt_project_part_3, srt_project_part_4,
                  srt_disposition_code, srt_external_characteristics, srt_forms_code, srt_copies,
                  srt_user_job_name);

          VAR
            copy_count: jmt$output_copy_count,
            copy_count_str: ost$string,
            disposition_code: jmt$disposition_code,
            external_characteristics: jmt$external_characteristics,
            forms_code: jmt$forms_code,
            local_status: ost$status,
            login_charge: avt$account_name,
            login_family: ost$name,
            login_project: avt$project_name,
            login_user: ost$name,
            srt_parameter: string (jmc$system_routing_text_size),
            srt_parameter_length: 0 .. jmc$system_routing_text_size,
            system_routing_text_keys: [STATIC] array [system_routing_text_parameters] of
                  string (srt_key_long_length) := [',CFM=', ',CUN=', ',OFM=', ',OUN=', ',CH1=', ',CH2=',
                  ',PJ1=', ',PJ2=', ',PJ3=', ',PJ4=', ',DC=', ',EC=', ',FC=', ',REP=', ',UJN='],
            system_routing_text_param: system_routing_text_parameters,
            temp_size: 0 .. 7,
            temp_string: string(31),
            user_job_name: jmt$user_supplied_name;


{ The system routing text identifier was set in the procedure initialize_control_block.

          system_routing_text.parameters (srt_identifier_length + 1, * ) := '';
          system_routing_text.size := srt_identifier_length;

          IF file_desc.file_kind = nfc$output_file THEN
            copy_count := file_desc.output_descriptor.copies;
            IF file_desc.output_descriptor.output_disposition_key <> jmc$wait_queue_path THEN
              IF (file_desc.output_descriptor.disposition_code = 'IN') OR
                 (file_desc.output_descriptor.disposition_code = 'IX') OR
                 (file_desc.output_descriptor.disposition_code = 'NO') THEN
                disposition_code := 'LP';
              ELSEIF  file_desc.output_descriptor.disposition_code = 'TO' THEN
                disposition_code := 'WT';
              ELSE
                disposition_code := file_desc.output_descriptor.disposition_code;
              IFEND;
            ELSE
              disposition_code := 'WT';
            IFEND;
            external_characteristics := file_desc.output_descriptor.external_characteristics;
            forms_code := file_desc.output_descriptor.forms_code;
            login_charge := file_desc.output_descriptor.login_account;
            login_family := file_desc.output_descriptor.login_family;
            login_project := file_desc.output_descriptor.login_project;
            login_user := file_desc.output_descriptor.login_user;
            user_job_name := file_desc.output_descriptor.user_file_name;
          ELSEIF file_desc.file_kind = nfc$input_file THEN
            copy_count := file_desc.input_descriptor.copies;
            disposition_code := file_desc.input_descriptor.disposition_code;
            external_characteristics := file_desc.input_descriptor.external_characteristics;
            forms_code := file_desc.input_descriptor.forms_code;
            login_charge := file_desc.input_descriptor.originating_login_account;
            login_family := file_desc.input_descriptor.originating_login_family;
            login_project := file_desc.input_descriptor.originating_login_project;
            login_user := file_desc.input_descriptor.originating_login_user;
            user_job_name := file_desc.input_descriptor.user_job_name;
          IFEND;

          FOR system_routing_text_param := srt_control_family_name TO srt_user_job_name DO
            srt_parameter := system_routing_text_keys [system_routing_text_param];
            CASE system_routing_text_param OF
            = srt_control_family_name, srt_owner_family_name =
              truncate_name (login_family, temp_string, temp_size);
              srt_parameter (srt_key_long_length + 1, temp_size ) := temp_string (1, temp_size);

            = srt_control_user_name, srt_owner_user_name =
              truncate_name (login_user, temp_string, temp_size);
              srt_parameter (srt_key_long_length + 1, temp_size ) := temp_string (1, temp_size);

            = srt_charge_part_1 =
              IF login_charge <> ' ' THEN
                srt_parameter (srt_key_long_length + 1, 7) := login_charge;
              ELSE
                srt_parameter := ' ';
              IFEND;

            = srt_charge_part_2 =
              srt_parameter_length := clp$trimmed_string_size (login_charge);
              IF srt_parameter_length > 7 THEN
                srt_parameter (srt_key_long_length + 1, 3) := login_charge (8, 3);
              ELSE
                srt_parameter := ' ';
              IFEND;

            = srt_project_part_1 =
              IF login_project <> ' ' THEN
                srt_parameter (srt_key_long_length + 1, 7) := login_project;
              ELSE
                srt_parameter := ' ';
              IFEND;

            = srt_project_part_2 =
              srt_parameter_length := clp$trimmed_string_size (login_project);
              IF srt_parameter_length > 7 THEN
                srt_parameter (srt_key_long_length + 1, 3) := login_project (8, 3);
              ELSE
                srt_parameter := ' ';
              IFEND;

            = srt_project_part_3 =
              srt_parameter_length := clp$trimmed_string_size (login_project);
              IF srt_parameter_length > 10 THEN
                srt_parameter (srt_key_long_length + 1, 7) := login_project (11, 7);
              ELSE
                srt_parameter := ' ';
              IFEND;

            = srt_project_part_4 =
              srt_parameter_length := clp$trimmed_string_size (login_project);
              IF srt_parameter_length > 17 THEN
                srt_parameter (srt_key_long_length + 1, 3) := login_project (18, 3);
              ELSE
                srt_parameter := ' ';
              IFEND;

            = srt_disposition_code =
              IF disposition_code <> '' THEN
                srt_parameter (srt_key_short_length + 1, * ) := disposition_code;
              ELSE
                srt_parameter := ' ';
              IFEND;

            = srt_external_characteristics =
              IF (file_desc.file_kind = nfc$output_file) AND (external_characteristics <> '') AND
                    (external_characteristics <> nfc$normal_string) THEN
                srt_parameter (srt_key_short_length + 1, * ) := external_characteristics (1, 2);
              ELSEIF (file_desc.file_kind = nfc$output_file) AND
                    (external_characteristics = nfc$normal_string) THEN
                srt_parameter (srt_key_short_length + 1, * ) := nfc$external_characteristic_a9;
              ELSE
                srt_parameter := ' ';
              IFEND;

            = srt_forms_code =
              IF (file_desc.file_kind = nfc$output_file) AND (forms_code <> '') AND
                    (forms_code <> nfc$normal_string) THEN
                srt_parameter (srt_key_short_length + 1, * ) := forms_code (1, 2);
              ELSE
                srt_parameter := ' ';
              IFEND;

            = srt_copies =
              clp$convert_integer_to_string ((copy_count - 1), 10, FALSE, copy_count_str, local_status);
              srt_parameter (srt_key_long_length + 1, * ) := copy_count_str.value;

            = srt_user_job_name =
              IF user_job_name <> '' THEN
                IF (user_job_name (1, 1) = user_job_name_prefix) THEN
                  user_job_name := user_job_name (2, *);
                IFEND;
                truncate_name (user_job_name, temp_string, temp_size);

{ If necessary, alter the UJN specification on the system routing text so that
{ it does not end with '$PRI'. NOS will reject the file transfer if a UJN is
{ specified with '$PRI' as the last four characters.

                IF control_block.protocol_in_use = nfc$p00_a101 THEN
                  IF temp_size > 3 THEN
                      IF temp_string ((temp_size - 3), 4) = '$PRI' THEN
                          temp_string((temp_size - 3), 4) := '$PRX' ;
                      IFEND;
                  IFEND;
                IFEND;

                srt_parameter (srt_key_long_length + 1, temp_size) := temp_string (1, temp_size);
              ELSE
                srt_parameter (srt_key_long_length + 1, * ) := qtfi_unknown_job_name;
              IFEND;

            CASEND;
            IF srt_parameter <> '' THEN
              srt_parameter_length := clp$trimmed_string_size (srt_parameter);
              IF ((srt_parameter_length + system_routing_text.size) <= jmc$system_routing_text_size) THEN
                system_routing_text.parameters (system_routing_text.size + 1,
                      srt_parameter_length) := srt_parameter;
                system_routing_text.size := system_routing_text.size + srt_parameter_length;
              IFEND;
            IFEND;
          FOREND;

          IF system_routing_text.size < jmc$system_routing_text_size THEN
            system_routing_text.parameters (system_routing_text.size + 1, 1) := period;
            system_routing_text.size := system_routing_text.size + 1;
          IFEND;

        PROCEND build_system_routing_text;
?? TITLE := 'set_data_declaration_param', EJECT ??

{ PURPOSE:
{   This function maps a string value data declaration to an ordinal
{   value.  The protocol engine will take  the ordinal valu and use
{   it to in the RFT.

        FUNCTION set_data_declaration_param
          (    data_declaration: jmt$data_declaration;
               data_mode: jmt$data_mode): nft$parameter_31_type;

          IF data_declaration = 'C6' THEN
            set_data_declaration_param := nfc$p31_ascii_c6;
          ELSEIF data_declaration = 'C8' THEN
            set_data_declaration_param := nfc$p31_ascii_c8;
          ELSEIF data_declaration = 'UH' THEN
            set_data_declaration_param := nfc$p31_host_dependent_uh;
          ELSEIF data_declaration = 'US' THEN
            set_data_declaration_param := nfc$p31_undefined_structured_us;
          ELSEIF (data_declaration = 'UU') OR ((data_declaration = '') AND (data_mode = jmc$transparent_data))
                THEN
            set_data_declaration_param := nfc$p31_undef_unstructured_uu;
          ELSE
            set_data_declaration_param := nfc$p31_unspecified;
          IFEND;

        FUNCEND set_data_declaration_param;
?? OLDTITLE, EJECT ??

{ These are the required parameters for the QTF RFT command:
{   Parameters 00, 16, 21, 22, 25, 26, 27
{ All the others are optional parameters.

        rft_parameter_set := $nft$parameter_set [nfc$protocol_id, nfc$file_name, nfc$mode_of_access,
              nfc$host_type, nfc$transfer_lid, nfc$job_name, nfc$physical_id];

        IF file_desc.file_kind = nfc$output_file THEN
          control_block.file_size := file_desc.output_descriptor.file_size;                        {P06}
          control_block.transfer_lid := file_desc.output_descriptor.output_destination;            {P25}
          control_block.send_file_name.value := file_desc.output_descriptor.system_file_name;      {P16}
          control_block.send_job_name.value := file_desc.output_descriptor.user_file_name;         {P26}
          data_declaration := file_desc.output_descriptor.data_declaration;
          data_mode := file_desc.output_descriptor.data_mode;
          file_disposition := file_desc.output_descriptor.disposition_code;
          implicit_routing_text := file_desc.output_descriptor.implicit_routing_text;
          remote_host_directive := file_desc.output_descriptor.remote_host_directive;
          source_lid.value := file_desc.output_descriptor.source_logical_id;
          system_routing_text := file_desc.output_descriptor.system_routing_text;
        ELSEIF file_desc.file_kind = nfc$input_file THEN
          control_block.file_size := file_desc.input_descriptor.job_size;                          {P06}
          control_block.transfer_lid := file_desc.input_descriptor.job_destination_family;         {P25}
          control_block.send_file_name.value := file_desc.input_descriptor.system_job_name;        {P16}
          IF file_desc.input_descriptor.user_job_name <> '' THEN                                   {P26}
            control_block.send_job_name.value := file_desc.input_descriptor.user_job_name;
          ELSE
            control_block.send_job_name.value := qtfi_unknown_job_name;
          IFEND;
          data_declaration := file_desc.input_descriptor.data_declaration;
          data_mode := file_desc.input_descriptor.data_mode;
          file_disposition := file_desc.input_descriptor.disposition_code;
          implicit_routing_text := file_desc.input_descriptor.implicit_routing_text;
          output_disposition := file_desc.input_descriptor.output_disposition;
          remote_host_directive := file_desc.input_descriptor.remote_host_directive;
          source_lid.value := file_desc.input_descriptor.source_logical_id;
          system_routing_text := file_desc.input_descriptor.system_routing_text;
        ELSEIF file_desc.file_kind = nfc$generic_file THEN
          control_block.file_size := 1;                                                            {P06}
          control_block.transfer_lid := file_desc.generic_descriptor.destination;                  {P25}
          control_block.send_file_name.value := file_desc.generic_descriptor.system_file_name;     {P16}
          control_block.send_job_name.value := file_desc.generic_descriptor.system_file_name;      {P26}
          data_declaration := 'UH';
          implicit_routing_text.size := 0;
          implicit_routing_text.text := '';
          remote_host_directive := file_desc.generic_descriptor.remote_host_directive;
          source_lid.value := control_block.transfer_pid;
          system_routing_text.parameters := '';
          system_routing_text.size := 0;

        IFEND;
        control_block.send_file_name.size := clp$trimmed_string_size (control_block.send_file_name.value);
        control_block.send_job_name.size := clp$trimmed_string_size (control_block.send_job_name.value);
        control_block.transfer_lid_length := clp$trimmed_string_size (control_block.transfer_lid);

        FOR index := nfc$protocol_id TO nfc$implicit_routing_text DO
          CASE index OF
          = nfc$facilities =                { Parameter 03 }
            IF control_block.path.network_type = nfc$network_nam THEN
              rft_parameter_set := rft_parameter_set + $nft$parameter_set [nfc$facilities];
            IFEND;

          = nfc$user_text_directive =       { Parameter 05 }
            IF remote_host_directive.size <> 0 THEN
              IF user_text_directive <> NIL THEN
                FREE user_text_directive;
              IFEND;
              ALLOCATE user_text_directive: [remote_host_directive.size];
              user_text_directive^.link := NIL;
              user_text_directive^.line := '';

              #TRANSLATE (osv$lower_to_upper, remote_host_directive.parameters, user_text_directive^.line);
              control_block.send_directives := user_text_directive;
              rft_parameter_set := rft_parameter_set + $nft$parameter_set [nfc$user_text_directive];
            IFEND;

          = nfc$file_length =               { Parameter 06 }
            rft_parameter_set := rft_parameter_set + $nft$parameter_set [nfc$file_length];

          = nfc$max_block_size =            { Parameter 12 }
            IF (control_block.path.network_type = nfc$network_nam) AND
               (control_block.protocol_in_use = nfc$p00_a102) THEN
              PUSH nam_optimum_attributes: [1..2];
              nam_optimum_attributes^ [1].kind := nac$optimum_transfer_unit_incr;
              nam_optimum_attributes^ [2].kind := nac$optimum_transfer_unit_size;
              nap$get_attributes(control_block.path.network_file^, nam_optimum_attributes^, status);
              IF status.normal THEN
                control_block.data_block_size := nam_optimum_attributes^ [2].optimum_transfer_unit_size;
                IF nam_optimum_attributes^ [1].optimum_transfer_unit_incr > 0 THEN
                  WHILE control_block.data_block_size < 10240 DO
                    control_block.data_block_size := control_block.data_block_size +
                        nam_optimum_attributes^ [1].optimum_transfer_unit_incr;
                  WHILEND;
                IFEND;
                control_block.data_block_size := control_block.data_block_size - data_header_length;
              IFEND;
              IF (NOT status.normal) OR (control_block.data_block_size < 512) THEN
                control_block.data_block_size := nfc$p12_nam_default;
              IFEND;
            ELSE

{ By using LCN or the A101 protocol, the data_block_size
{ will be set to the LCN default block size

              control_block.data_block_size := nfc$p12_lcn_default;
            IFEND;
            rft_parameter_set := rft_parameter_set + $nft$parameter_set [nfc$max_block_size];

          = nfc$file_disposition =          { Parameter 17 }
            IF file_desc.file_kind = nfc$input_file THEN

{ nfc$p17_input_return, 'IN', is the default for all input files.

              control_block.disposition_code := nfc$p17_input_return;

              IF (file_disposition = 'IX') OR (output_disposition.key = jmc$local_output_disposition) THEN
                control_block.disposition_code := nfc$p17_input_no_return;
              IFEND;
            ELSEIF file_desc.file_kind = nfc$output_file THEN

{ nfc$p17_line_printer, 'LP', is the default for all output files.
{ Some file_disposition codes (like 'NO' and 'TO') need to be masked
{ to the default nfc$p17_line_printer value because they are not valid
{ values for RFT parameter 17, but are valid for RFT parameter 32.

              control_block.disposition_code := nfc$p17_line_printer;

              IF (file_disposition = 'SP') OR ((file_disposition = '') AND
                    (file_desc.output_descriptor.device_type = jmc$output_device_plotter)) THEN
                control_block.disposition_code := nfc$p17_special_output;

              ELSEIF (file_disposition = 'PU') OR ((file_disposition = '') AND
                    (file_desc.output_descriptor.device_type = jmc$output_device_punch)) THEN
                control_block.disposition_code := nfc$p17_hollerith_card_punch;

              ELSEIF file_disposition = 'P8' THEN
                control_block.disposition_code := nfc$p17_binary_checksummed_cp;

              ELSEIF file_disposition = 'PB' THEN
                control_block.disposition_code := nfc$p17_binary_card_punch;
              IFEND;

            ELSEIF file_desc.file_kind = nfc$generic_file THEN
              control_block.disposition_code := nfc$p17_generic_queue;
            IFEND;

            rft_parameter_set := rft_parameter_set + $nft$parameter_set [nfc$file_disposition];

          = nfc$acknowledgment_window =  { Parameter 18 }

{ This parameter is being sent to correct a NOS QTF bug using NAM.   It should be taken out when
{ the NOS bug is fixed.

            IF control_block.path.network_type = nfc$network_nam THEN
              control_block.acknowledgment_window := 2;
              rft_parameter_set := rft_parameter_set + $nft$parameter_set [nfc$acknowledgment_window];
            IFEND;

          = nfc$minimum_timeout_interval =  { Parameter 20 }

{ The minimum timeout inteval is set in the control block so the
{ protocol engine will take care of this parameter.

          = nfc$source_lid =                { Parameter 24 }
            IF source_lid.value <> '' THEN
              control_block.source_lid.value := source_lid.value;
            ELSE
              control_block.source_lid.value := control_block.transfer_pid;
            IFEND;
            control_block.source_lid.size := clp$trimmed_string_size (control_block.source_lid.value);
            rft_parameter_set := rft_parameter_set + $nft$parameter_set [nfc$source_lid];

          = nfc$echo =                      { Parameter 29 }

{ This parameter is used to specify the desired login family on the remote system for a job in a
{ VE - VE transfer.  If the login family was specified on the SUBJ command or on the login
{ statement of the job file, the login family field in the input file descriptor will contain the
{ value.  If no parameter was specified, (use the default value on the remote system),  the login
{ family field will be blank.  This parameter will also be used to pass the data_mode of
{ RHF_STRUCTURED queues files for a data_declaration of UNSPECIFIED.

            IF file_desc.file_kind = nfc$input_file THEN
              build_parameter_29_echo_text (file_desc.input_descriptor.login_family, data_declaration,
                    data_mode, control_block.protocol_in_use,
                    file_desc.input_descriptor.originating_application_name, rft_parameter_set,
                    control_block.send_echo_text);
            ELSE
              build_parameter_29_echo_text (osc$null_name, data_declaration, data_mode,
                    control_block.protocol_in_use, file_desc.output_descriptor.originating_application_name,
                    rft_parameter_set, control_block.send_echo_text);
            IFEND;

          = nfc$data_declaration =          { Parameter 31 }
            control_block.data_declaration := set_data_declaration_param (data_declaration, data_mode);
            IF control_block.data_declaration <> nfc$p31_unspecified THEN
              rft_parameter_set := rft_parameter_set + $nft$parameter_set [nfc$data_declaration];
            IFEND;

          = nfc$system_routing_text =       { Parameter 32 }
            IF (file_desc.file_kind = nfc$input_file) OR (file_desc.file_kind = nfc$output_file) THEN
              IF system_routing_text.size <> 0 THEN
                control_block.send_systems_routing_text := system_routing_text;
              ELSE
                build_system_routing_text (file_desc, control_block.send_systems_routing_text);
              IFEND;
              rft_parameter_set := rft_parameter_set + $nft$parameter_set [nfc$system_routing_text];
            IFEND;

          = nfc$implicit_routing_text =     { Parameter 33 }
            IF implicit_routing_text.size <> 0 THEN
              control_block.send_implicit_routing_text := implicit_routing_text;
            ELSE
              build_implicit_routing_text (file_desc, control_block.send_implicit_routing_text);
            IFEND;

{ Implicit routing text will have been created if the input file
{ originated on a NOS/VE machine.

            IF control_block.send_implicit_routing_text.size <> 0 THEN
              rft_parameter_set := rft_parameter_set + $nft$parameter_set [nfc$implicit_routing_text];
            IFEND;

          ELSE
            ;
          CASEND;
        FOREND;

      PROCEND set_up_rft;
?? OLDTITLE, EJECT ??
      status.normal := TRUE;

      set_up_rft (transfer_file_descriptor, rft_parameter_set, control_block);

      go_parameter_set := $nft$parameter_set [];
      rft_legal_resp_commands := $nft$command_set [nfc$rpos, nfc$rneg];

      nfp$send_command (nfc$rft, rft_parameter_set, $nft$parameter_set[ ], $nft$parameter_set[ ],
            control_block, status);
      IF status.normal THEN
        nfp$receive_command (rft_legal_resp_commands, nfv$qtf_required_params_on_cmds, control_block,
              rpos_received_params, rpos_ignored_params, rpos_modified_params, status);

        IF (status.normal) AND (control_block.last_command_sent = nfc$rft) AND
              (control_block.last_command_received = nfc$rpos) THEN
          transfer_mode := set_transfer_mode (transfer_file_descriptor, rft_parameter_set,
                rpos_received_params, rpos_modified_params, control_block);

          nfp$send_command (nfc$go, go_parameter_set, $nft$parameter_set[ ], $nft$parameter_set[ ],
                control_block, status);

        ELSEIF (status.normal) AND (control_block.last_command_sent = nfc$rft) AND
              (control_block.last_command_received = nfc$rneg) AND (control_block.negotiate_protocol) THEN

{ Make sure the protocol is set to A101.

          control_block.protocol_in_use := nfc$p00_a101;
          control_block.state_of_transfer.normal := TRUE;

          stop_transfer_protocol (transfer_file_descriptor, control_block, status);
          IF status.normal THEN

{ control_block.protocol_in_use has been set to the A101 protocol by the protocol engine.

            control_block.negotiate_protocol := FALSE;
            negotiate_file_transfer (transfer_file_descriptor, control_block, transfer_mode, status);
          IFEND;
        IFEND;
      IFEND;

    PROCEND negotiate_file_transfer;
?? TITLE := 'open_connection', EJECT ??

{ PURPOSE:
{   This procedure opens the connection that was created by QTFC.
{   The connection file should only be opened if the connection is a
{   new connection, but should be checked if this procedure is called
{   again for multiple file transfers over the same connection.
{
{ NOTE:
{   qtfi_connection_file_name is a global variable.

    PROCEDURE open_connection
      (    connection_info: nft$intertask_message;
       VAR connection_path: nft$network_connection;
       VAR status: ost$status);

      CONST
        access_mode = amc$record,
        wait_time = 15000;   { 15000 milliseconds }

      VAR
        ignore_status: ost$status,
        namve_attributes: ^nat$change_attributes,
        rhfam_attributes: ^rft$change_attributes;

      status.normal := TRUE;
      IF connection_path.path_connected THEN
        IF (connection_path.network_file <> NIL) AND ((connection_path.network_file^ <>
              connection_info.connection_file) OR (connection_path.network_type <>
              connection_info.connection_kind)) THEN
          osp$set_status_abnormal ('NF', nfe$qtfc_qtfi_communication_err, ' ', status);
        IFEND;
      ELSE
        IF connection_info.connection_kind = nfc$unknown_network THEN
          osp$set_status_abnormal(nfc$status_id,nfe$bts_internal_error,
               'QTF Initiator - open_connection - invalid network kind',status);
          nfp$format_message_to_job_log (status);
          RETURN; {----->
        IFEND;
        IF connection_info.connection_kind = nfc$network_nam THEN
          nap$await_server_response (connection_info.connection_file, wait_time, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;
        fsp$open_file (connection_info.connection_file, access_mode, NIL, NIL, NIL, NIL, NIL,
              connection_path.network_file_id, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        CASE connection_info.connection_kind OF
        = nfc$network_nam =
          control_block.send_facilities := control_block.send_facilities +
                $nft$parameter_03_value_set [nfc$ss_ack_required];
          control_block.transfer_facilities := control_block.send_facilities;

          PUSH namve_attributes: [1 .. 1];
          namve_attributes^ [1].kind := nac$data_transfer_timeout;
          namve_attributes^ [1].data_transfer_timeout := control_block.time_out * nfc$milliseconds;
          nap$store_attributes (connection_path.network_file_id, namve_attributes^, status);
        = nfc$network_lcn =
          PUSH rhfam_attributes: [1 .. 1];
          rhfam_attributes^ [1].key := rfc$data_transfer_timeout;
          rhfam_attributes^ [1].data_transfer_timeout := control_block.time_out * nfc$milliseconds;
          rfp$store (connection_path.network_file_id, rhfam_attributes^, status);
        ELSE
        CASEND;
        IF NOT status.normal THEN
          fsp$close_file (connection_path.network_file_id, ignore_status);
          RETURN; {----->
        IFEND;

        qtfi_connection_file_name := connection_info.connection_file;
        connection_path.network_file := ^qtfi_connection_file_name;
        connection_path.path_connected := TRUE;
        connection_path.network_type := connection_info.connection_kind;
      IFEND;

    PROCEND open_connection;
?? TITLE := 'set_qtf_transfer_status', EJECT ??

{ PURPOSE:
{   This function maps a status from nfp$send_queue_file to a
{   QTF transfer status for QTFC to interpret.

    FUNCTION set_qtf_transfer_status
      (    task_status: ost$status;
           state_of_transfer: ost$status): nft$qtf_transfer_status;

      IF task_status.normal AND state_of_transfer.normal THEN
        set_qtf_transfer_status := nfc$qtf_transfer_complete;
      ELSEIF NOT state_of_transfer.normal THEN
        IF ((state_of_transfer.condition = nfe$receiver_problem_retry) OR
              (state_of_transfer.condition = nfe$sender_problem_retry)) THEN
          set_qtf_transfer_status := nfc$qtf_transfer_failed_retry;
        ELSE
          set_qtf_transfer_status := nfc$qtf_transfer_failed_noretry;
        IFEND;
      ELSEIF NOT task_status.normal THEN
        set_qtf_transfer_status := nfc$qtf_transfer_aborted;
      IFEND;

    FUNCEND set_qtf_transfer_status;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    stop_transfer_status.normal := TRUE;

    IF control_block.transfer_pid = osc$null_name THEN
      control_block.transfer_pid := file_transfer_msg.host_pid;
      control_block.transfer_pid_length := clp$trimmed_string_size (file_transfer_msg.host_pid);
    IFEND;

    IF file_transfer_msg.qtf_file_descriptor.file_kind = nfc$output_file THEN
      system_file_name := file_transfer_msg.qtf_file_descriptor.output_descriptor.system_file_name;
    ELSEIF file_transfer_msg.qtf_file_descriptor.file_kind = nfc$input_file THEN
      system_file_name := file_transfer_msg.qtf_file_descriptor.input_descriptor.system_job_name;
    ELSEIF file_transfer_msg.qtf_file_descriptor.file_kind = nfc$generic_file THEN
      system_file_name := file_transfer_msg.qtf_file_descriptor.generic_descriptor.system_file_name;
    IFEND;

    open_connection (file_transfer_msg, control_block.path, status);
    IF status.normal THEN
      negotiate_file_transfer (file_transfer_msg.qtf_file_descriptor, control_block, transfer_mode, status);
      IF status.normal AND (control_block.last_command_received = nfc$rpos) AND
            (control_block.last_command_sent = nfc$go) THEN
        IF transfer_mode = nfc$rhf_structured_mode THEN
          open_access_level := amc$record;
        ELSE
          open_access_level := amc$segment;
        IFEND;

        IF file_transfer_msg.qtf_file_descriptor.file_kind = nfc$input_file THEN
          jmp$open_input_file (system_file_name, open_access_level, jmc$qtf_usage,
                file_transfer_msg.qtf_file_descriptor.q_file_password, queue_file_identifier, status);
        ELSEIF file_transfer_msg.qtf_file_descriptor.file_kind = nfc$output_file THEN
          jmp$open_output_file (system_file_name, open_access_level, jmc$qtf_usage,
                file_transfer_msg.qtf_file_descriptor.q_file_password, queue_file_identifier, status);
        ELSE { file_transfer_msg.qtf_file_descriptor.file_kind = nfc$generic_file
          jmp$open_qfile (system_file_name, open_access_level, nfc$qtf_namve_client_name,
                file_transfer_msg.qtf_file_descriptor.q_file_password, queue_file_identifier, status);
        IFEND;
        nfp$send_queue_file (control_block.path.network_file_id, queue_file_identifier,
              system_file_name, control_block.transfer_facilities, transfer_mode,
              control_block.data_block_size, control_block.time_out, control_block.protocol_in_use,
              control_block.path.network_type, control_block.protocol_trace,
              consistent_protocol_state, control_block.state_of_transfer, status);

{ If nfp$send_queue_file returns an abnormal status retry the file and
{ do NOT print an error listing for the user.

        IF (NOT status.normal) AND (NOT control_block.state_of_transfer.normal) THEN
          control_block.state_of_transfer.condition := nfe$sender_problem_retry;
        IFEND;
      IFEND;
      stop_transfer_protocol (file_transfer_msg.qtf_file_descriptor, control_block, stop_transfer_status);
      IF status.normal AND (NOT stop_transfer_status.normal) THEN

{ If NEGOTIATE_FILE_TRANSFER or NFP$SEND_QUEUE_FILE returns an abnormal status, that abnormal status should
{ override an abnormal status from STOP_TRANSFER_PROTOCOL.

        status := stop_transfer_status;
      IFEND
    IFEND;

{ Notify QTFC of the status by sending a file transfer status message.

    transfer_status_msg.kind := nfc$qtf_file_transfer_status;
    transfer_status_msg.qtf_system_file_name := system_file_name;
    transfer_status_msg.qtf_transfer_status := set_qtf_transfer_status
          (status, control_block.state_of_transfer);
    transfer_status_msg.remote_job_name := control_block.user_job_name;

{ Emit communications accounting statistic for all input and output file transfers.

    IF (file_transfer_msg.qtf_file_descriptor.file_kind = nfc$input_file) OR
          (file_transfer_msg.qtf_file_descriptor.file_kind = nfc$output_file) THEN
      generate_qtf_statistic( file_transfer_msg.qtf_file_descriptor,
           control_block.source_lid.value(1,control_block.source_lid.size),
           control_block.transfer_lid(1,control_block.transfer_lid_length));
    IFEND;

    transfer_status_msg.qtf_task_status := status;
    nfp$put_async_task_message (qtfc_task_id, ^transfer_status_msg, #SIZE (transfer_status_msg), status);

  PROCEND transfer_file;
?? TITLE := 'nfp$qtf_initiator', EJECT ??

{ PURPOSE:
{   This is the main procedure for QTFI.

  PROGRAM nfp$qtf_initiator
    (    parameters: pmt$program_parameters;
     VAR status: ost$status);

    VAR
      control_block: nft$control_block,
      control_block_needs_initialized: boolean,
      establish_descriptor: pmt$established_handler,
      exit_condition: [STATIC, READ] pmt$condition := [pmc$block_exit_processing,
            [pmc$block_exit, pmc$program_termination, pmc$program_abort]],
      intertask_message: nft$intertask_message,
      qtfc_task_id: pmt$task_id,
      queue_id: pmt$queue_connection,
      ready_index: integer,       { This has to be an integer for osp$i_await_activity_completion.
      transfer_count: nft$intertask_transfer_size,
      wait_list: ^ost$i_wait_list;

?? NEWTITLE := 'exit_condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that gets called whenever
{   QTFI aborts or exits on an abnormal status.

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status,
        intertask_message: nft$intertask_message,
        message_status: ost$status,
        retry_count: 0 .. 10,
        transfer_count: nft$intertask_transfer_size;


      pmp$log ('Queue file Transfer Facility Initiator is dropping', ignore_status);
      fsp$close_file (control_block.path.network_file_id, handler_status);

      intertask_message.kind := nfc$abnormal_child_task_abort;
      nfp$put_async_task_message (qtfc_task_id, ^intertask_message, #SIZE (intertask_message),
            message_status);

      IF message_status.normal THEN
        REPEAT
          nfp$get_async_task_message (qtfc_task_id, ^intertask_message, #SIZE (intertask_message), 0,
                transfer_count, message_status);
        UNTIL ((message_status.normal) AND (transfer_count = 0)) OR NOT message_status.normal;
      IFEND;

      nfp$end_async_communication (message_status.normal, handler_status);
      IF message_status.normal AND (NOT handler_status.normal) THEN
        retry_count := 0;
        REPEAT

{ QTFI should wait for 100 milliseconds.  This is done to insure that the
{ last message sent was picked up by QTFC.

          pmp$wait (qtfi_tenth_of_a_second, qtfi_tenth_of_a_second);
          nfp$end_async_communication (message_status.normal, handler_status);
          retry_count := retry_count + 1;
        UNTIL handler_status.normal OR (retry_count = 10);

{ This makes sure that QTFI will end communication with QTFC and terminate.
{ If QTFI can't end communications, this assumes that QTFC is going down and is
{ not able to talk to QTFI.

        IF retry_count = 10 THEN
          nfp$end_async_communication (FALSE, handler_status);
        IFEND;
      IFEND;

    PROCEND exit_condition_handler;
?? TITLE := 'initialize_control_block', EJECT ??

{ PURPOSE:
{   This procedure makes a call to initialize the control block
{   used by the protocol engine.

    PROCEDURE initialize_control_block
      (    parameter_rules: ^nft$parameter_rules_array;
       VAR control_block: nft$control_block;
       VAR control_block_needs_initialized: boolean;
       VAR status: ost$status);

      CONST
        application = nfc$application_qtf,
        data_declaration = nfc$p31_host_dependent_uh,
        initial_protocol = nfc$p00_a102,
        mode_of_access = nfc$take;

      VAR
        allowed_facilities: nft$parameter_03_value_set,
        requested_facilities: nft$parameter_03_value_set,
        required_facilities: nft$parameter_03_value_set;


      status.normal := TRUE;

      allowed_facilities := $nft$parameter_03_value_set [nfc$multiple_data_phase_params,
            nfc$collective_text_string, nfc$temporary_hold, nfc$go_command_parameters, nfc$later_resumption,
            nfc$restart_permitted, nfc$checkmark_ack_required, nfc$ss_ack_required, nfc$data_compression];
      requested_facilities := $nft$parameter_03_value_set [];
      required_facilities := $nft$parameter_03_value_set [];

      nfp$initialize_control_block (application, data_declaration, requested_facilities, required_facilities,
            allowed_facilities, initial_protocol, mode_of_access, parameter_rules, control_block);

      control_block.protocol_in_use := nfc$p00_a102;
      control_block.path.network_file := NIL;
      control_block.path.path_connected := FALSE;
      control_block.transfer_pid := osc$null_name;
      control_block.send_systems_routing_text.parameters := nfc$p32_cyber_id;
      control_block.send_systems_routing_text.size := nfc$p32_cyber_id_length;
      control_block.mode_of_access := nfc$take;
      control_block.mode_of_access_option := nfc$p21_make_only;
      control_block.local_host_type := nfc$p22_nos_ve_qtf;

      control_block_needs_initialized := FALSE;

    PROCEND initialize_control_block;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    control_block_needs_initialized := TRUE;

    nfp$begin_asynchronous_task (parameters, qtfc_task_id, queue_id, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^establish_descriptor, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    PUSH wait_list: [1 .. 1];
    wait_list^ [1].activity := pmc$i_await_local_queue_message;
    wait_list^ [1].qid := queue_id;

    WHILE TRUE DO
      osp$i_await_activity_completion (wait_list^, ready_index, status);
      IF NOT status.normal THEN
        osp$set_status_abnormal(nfc$status_id,nfe$bts_internal_error,
             'QTF controller - invalid local queue status',status);
        nfp$format_message_to_job_log( status );
        RETURN;
      IFEND;
      IF (wait_list^ [ready_index].activity = pmc$i_await_local_queue_message) THEN
        nfp$get_async_task_message (qtfc_task_id, ^intertask_message, #SIZE (intertask_message), 0,
              transfer_count, status);
        IF status.normal AND (transfer_count > 0) THEN
          CASE intertask_message.kind OF
          = nfc$qtf_file_transfer =
            IF control_block_needs_initialized THEN
              initialize_control_block (^nfv$qtf_parameter_rules, control_block,
                    control_block_needs_initialized, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
            IFEND;
            transfer_file (qtfc_task_id, intertask_message, control_block, status);

          = nfc$qtf_terminate_connection =
            terminate_connection (qtfc_task_id, intertask_message.connect_file_name, control_block);
            control_block_needs_initialized := TRUE;

          = nfc$qtf_terminate_task =
            ready_task_for_termination (qtfc_task_id, control_block);
            pmp$disestablish_cond_handler (exit_condition, status);
            RETURN; {----->

          = nfc$btf_file_transfer, nfc$btf_file_transfer_status, nfc$qtf_file_transfer_status,
                nfc$qtf_connection_terminated, nfc$qtf_task_terminated =

{ These message kinds should not be received.

            osp$set_status_abnormal(nfc$status_id,nfe$bts_internal_error,
               'QTF controller - invalid local queue message',status);
            nfp$format_message_to_job_log( status );
            RETURN;

          ELSE
            osp$set_status_abnormal(nfc$status_id,nfe$bts_internal_error,
               'QTF controller - invalid local queue message',status);
            nfp$format_message_to_job_log( status );
            RETURN;
          CASEND;
        IFEND;

      IFEND;
    WHILEND;

  PROCEND nfp$qtf_initiator;
MODEND nfm$qtf_initiator;
*DECK DECK=NFM$QTF_SERVER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'MODULE nfm$qtf_server' ??
MODULE nfm$qtf_server;

{  The following table describes the initialization of the job submission option values.
{  The hierarchy of the values are from top (highest) to bottom (lowest).  If the submission
{  option is not defined in any of the values for that option or blank, that submission
{  option is not specified for the submit_job interface.

*copyc nfh$qtf_subj_options

{  The following table describes the initialization of the output submission option values.
{  The hierarchy of the values are from top (highest) to bottom (lowest).  If the submission
{  option is not defined in any of the values for that option or blank, that submission
{  option is not specified for the print_file interface.

*copyc nfh$qtf_prif_options

?? NEWTITLE := 'Global References', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc jmt$qfile_attribute_keys
*copyc cld$parameter_list
*copyc cle$ecc_variable
*copyc clt$command_line_size
*copyc clt$file
*copyc fst$path
*copyc nfc$external_characteristic_a9
*copyc nfc$normal_string
*copyc nfc$parameter_00_definitions
*copyc nfc$parameter_01_definitions
*copyc nfc$parameter_02_definitions
*copyc nfc$parameter_03_definitions
*copyc nfc$parameter_04_definitions
*copyc nfc$parameter_05_definitions
*copyc nfc$parameter_06_definitions
*copyc nfc$parameter_07_definitions
*copyc nfc$parameter_08_definitions
*copyc nfc$parameter_09_definitions
*copyc nfc$parameter_10_definitions
*copyc nfc$parameter_11_definitions
*copyc nfc$parameter_12_definitions
*copyc nfc$parameter_13_definitions
*copyc nfc$parameter_16_definitions
*copyc nfc$parameter_17_definitions
*copyc nfc$parameter_20_definitions
*copyc nfc$parameter_21_definitions
*copyc nfc$parameter_22_definitions
*copyc nfc$parameter_24_definitions
*copyc nfc$parameter_25_definitions
*copyc nfc$parameter_26_definitions
*copyc nfc$parameter_27_definitions
*copyc nfc$parameter_28_definitions
*copyc nfc$parameter_29_definitions
*copyc nfc$parameter_30_definitions
*copyc nfc$parameter_31_definitions
*copyc nfc$parameter_32_definitions
*copyc nfc$parameter_33_definitions
*copyc nfc$parameter_90_definitions
*copyc nfc$parameter_91_definitions
*copyc nfc$parameter_92_definitions
*copyc nfc$parameter_93_definitions
*copyc nfc$parameter_94_definitions
*copyc nfc$parameter_95_definitions
*copyc nfc$parameter_96_definitions
*copyc nfc$parameter_97_definitions
*copyc nfc$parameter_98_definitions
*copyc nfc$parameter_99_definitions
*copyc nfc$qtf_name_constants
*copyc osc$queue_transfer_client
*copyc osc$queue_transfer_server
*copyc nfe$batch_transfer_services
*copyc nfe$queue_file_transfer_fac
*copyc nft$control_block
*copyc nft$lcn_application_names
*copyc nft$nam_application_names
*copyc nft$parameter_03_netvalues
*copyc nft$parameter_set
*copyc nft$qtf_input_accounting_data
*copyc nft$required_param_on_command
*copyc nft$store_forward_file_info
*copyc nft$task_queue
*copyc nft$transfer_modes
*copyc ost$name
*copyc ost$user_identification
*copyc osv$lower_to_upper
*copyc rfe$condition_codes
*copyc rft$external_interface
?? POP ??
*copyc amp$change_file_attributes
*copyc amp$return
*copyc clp$convert_string_to_integer
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc clp$pop_parameters
*copyc clp$push_parameters
*copyc clp$read_variable
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$copy_file
*copyc fsp$open_file
*copyc jmp$emit_communication_stat
*copyc jmp$get_attribute_defaults
*copyc jmp$print_file
*copyc jmp$submit_job
*copyc jmp$submit_qfile
*copyc nap$detach_server_application
*copyc nap$store_attributes
*copyc nfp$close_store_forward_file
*copyc nfp$create_wait_queue_file_name
*copyc nfp$deallocate_dirs_from_head
*copyc nfp$dequeue_directives_on_list
*copyc nfp$enqueue_status_directive
*copyc nfp$enqueue_task
*copyc nfp$format_message_to_job_log
*copyc nfp$get_new_application_name
*copyc nfp$get_new_destination_name
*copyc nfp$get_new_source_name
*copyc nfp$get_server_asynch_event
*copyc nfp$initialize_control_block
*copyc nfp$open_store_forward_file
*copyc nfp$receive_command
*copyc nfp$receive_queue_file
*copyc nfp$send_command
*copyc nfp$set_abnormal_if_normal
*copyc nfp$terminate_path
*copyc nfp$verify_family
*copyc nlp$end_title_translation
*copyc nlp$get_title_translation
*copyc nlp$translate_title
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$execute
*copyc pmp$get_program_description
*copyc pmp$get_program_size
*copyc pmp$get_unique_name
*copyc pmp$log
*copyc rfp$application_sign_off
*copyc rfp$get_local_host_physical_id
*copyc rfp$return_lid_type
*copyc rfp$store
*copyc nfv$lcn_application_names
*copyc nfv$nam_application_names
*copyc nfv$parameter_17_values
*copyc nfv$parameter_31_values
*copyc nfv$p04_values
*copyc nfv$qtf_parameter_rules
*copyc nfv$qtf_required_params_on_cmds
?? TITLE := 'Global Declarations', EJECT ??
  CONST
    maximum_size_qtfs_scl_command = 256,
    user_job_name_prefix = '#';

  TYPE
    nft$qtfs_task_switch_params = record
      path_info: nft$network_connection,
      network_file: ost$name,
      local_pid: host_pid_type,
      store_forward_file_name: amt$local_file_name,
      charge_prefix_character: string (1),
      project_prefix_character: string (1),
    recend;

  TYPE
    nft$queue_file_type = (nfc$print_queue_file, nfc$job_queue_file, nfc$generic_queue_file);

  TYPE
    nft$input_queue_attributes = (nfc$iqa_comment_banner, nfc$iqa_control_family, nfc$iqa_control_user,
          nfc$iqa_copies, nfc$iqa_cpu_time_limit, nfc$iqa_data_declaration, nfc$iqa_data_mode,
          nfc$iqa_default_login_family, nfc$iqa_device, nfc$iqa_disposition_code, nfc$iqa_earliest_print_time,
          nfc$iqa_earliest_run_time, nfc$iqa_external_characteristic, nfc$iqa_forms_code,
          nfc$iqa_implicit_routing_text, nfc$iqa_job_abort_disposition, nfc$iqa_job_class,
          nfc$iqa_job_deferred_by_user, nfc$iqa_job_destination, nfc$iqa_job_destination_usage,
          nfc$iqa_job_execution_ring, nfc$iqa_job_input_device, nfc$iqa_job_priority,
          nfc$iqa_job_qualifier_list, nfc$iqa_job_recovery_dispositon, nfc$iqa_latest_print_time,
          nfc$iqa_latest_run_time, nfc$iqa_login_account, nfc$iqa_login_command_supplied,
          nfc$iqa_login_family, nfc$iqa_login_password, nfc$iqa_login_project, nfc$iqa_login_user,
          nfc$iqa_magnetic_tape_limit, nfc$iqa_maximum_working_set, nfc$iqa_null_attribute,
          nfc$iqa_operator_family, nfc$iqa_operator_user, nfc$iqa_origin_application_name,
          nfc$iqa_output_destination, nfc$iqa_output_dest_usage, nfc$iqa_output_disposition,
          nfc$iqa_purge_delay, nfc$iqa_remote_host_directive, nfc$iqa_routing_banner,
          nfc$iqa_source_logical_id, nfc$iqa_sru_limit, nfc$iqa_station, nfc$iqa_system_job_name,
          nfc$iqa_system_routing_text, nfc$iqa_user_information, nfc$iqa_user_job_name,
          nfc$iqa_vertical_print_density, nfc$iqa_vfu_load_procedure);

  TYPE
    nft$input_queue_attributes_set = set of nft$input_queue_attributes;

  TYPE
    nft$output_queue_attributes = (nfc$oqa_comment_banner, nfc$oqa_control_family, nfc$oqa_control_user,
          nfc$oqa_copies, nfc$oqa_data_declaration, nfc$oqa_data_mode, nfc$oqa_device, nfc$oqa_device_type,
          nfc$oqa_disposition_code, nfc$oqa_earliest_print_time, nfc$oqa_external_characteristic,
          nfc$oqa_forms_code, nfc$oqa_implicit_routing_text, nfc$oqa_latest_print_time, nfc$oqa_login_account,
          nfc$oqa_login_family, nfc$oqa_login_project, nfc$oqa_login_user, nfc$oqa_null_attribute,
          nfc$oqa_operator_family, nfc$oqa_operator_user, nfc$oqa_origin_application_name,
          nfc$oqa_output_class, nfc$oqa_output_deferred_by_user, nfc$oqa_output_destination,
          nfc$oqa_output_dest_usage, nfc$oqa_output_disposition, nfc$oqa_output_priority,
          nfc$oqa_page_width,
          nfc$oqa_purge_delay, nfc$oqa_remote_host_directive, nfc$oqa_routing_banner,
          nfc$oqa_source_logical_id,
          nfc$oqa_station, nfc$oqa_system_file_name, nfc$oqa_system_routing_text, nfc$oqa_user_file_name,
          nfc$oqa_user_information, nfc$oqa_user_job_name, nfc$oqa_vertical_print_density,
          nfc$oqa_vfu_load_procedure);

  TYPE
    nft$output_queue_attributes_set = set of nft$output_queue_attributes;

  TYPE
    nft$generic_queue_attributes = (nfc$gqa_application_name, nfc$gqa_deferred_by_application,
          nfc$gqa_destination, nfc$gqa_earliest_run_time, nfc$gqa_latest_run_time, nfc$gqa_purge_delay,
          nfc$gqa_remote_host_directive);

  TYPE
    nft$generic_attributes_set = set of nft$generic_queue_attributes;

  TYPE
    nft$queue_submission_option = record
      case queue_file_type: nft$queue_file_type of
      = nfc$print_queue_file =
        output_submission_option: array [nft$output_queue_attributes] of jmt$output_submission_option,
      = nfc$job_queue_file =
        job_submission_option: array [nft$input_queue_attributes] of jmt$job_submission_option,
      = nfc$generic_queue_file =
        qfile_submission_option: array [nft$generic_queue_attributes] of jmt$qfile_submission_option,
      casend,
    recend;

  TYPE
    host_pid_type = record
      size: 0 .. osc$max_name_size,
      value: ost$name,
    recend;

  TYPE
    qtfs_input_accounting_data = record
      case boolean OF
      = FALSE =
        data_string: jmt$job_input_device,
      = TRUE =
        size: 0 .. jmc$job_input_device_size,
        data_block: nft$qtf_input_accounting_data,
      casend,
    recend;

  TYPE
    wait_queue_information = record
      case use_wait_queue: boolean OF
      = FALSE =
        ,
      = TRUE =
        wait_queue_file_name: amt$local_file_name,
      casend,
    recend;

  VAR
    nfv$qtf_send_p03_values: [STATIC, READ, XDCL] nft$parameter_03_netvalues :=
          [[], [nfc$ss_ack_required], []];

  VAR
    job_qualifier_list: [STATIC] array [1 .. jmc$maximum_job_qualifiers] of ost$name;

  VAR
    output_disposition_path: [STATIC] fst$path;

  VAR
    output_implicit_routing_text: [STATIC] jmt$implicit_routing_text;

  VAR
    output_purge_delay: [STATIC] jmt$time_increment;

  VAR
    output_remote_host_directive: [STATIC] jmt$remote_host_directive;

  VAR
    output_system_routing_text: [STATIC] jmt$system_routing_text;

  VAR
    output_user_information: [STATIC] jmt$user_information;

  VAR
    charge_prefix_character: [STATIC] string(1),
    project_prefix_character: [STATIC] string(1);

?? TITLE := 'nfp$qtfs_boot', EJECT ??

{ PURPOSE:
{   This is the starting procedure for the QTF server.
{   This procedure will receive all incoming QTFS connections for processing.
{   This processing is done by boot initiated tasks whose function is to
{   receive the queue files.  If for any reason the service task cannot be
{   executed, the connection will be terminated.

  PROCEDURE [XDCL] nfp$qtfs_boot
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE qtfs_boot_pdt (
{   host_physical_identifier, hpi: string 1..31 = $required
{   account_prefix_character, apc: (BY_NAME, ADVANCED) name 1..1 = A
{   project_prefix_character, ppc: (BY_NAME, ADVANCED) name 1..1 = P
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (1),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (1),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 8, 17, 15, 13, 19, 593],
    clc$command, 7, 4, 1, 2, 0, 0, 4, ''], [
    ['ACCOUNT_PREFIX_CHARACTER       ',clc$nominal_entry, 2],
    ['APC                            ',clc$abbreviation_entry, 2],
    ['HOST_PHYSICAL_IDENTIFIER       ',clc$nominal_entry, 1],
    ['HPI                            ',clc$abbreviation_entry, 1],
    ['PPC                            ',clc$abbreviation_entry, 3],
    ['PROJECT_PREFIX_CHARACTER       ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [1, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [6, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [1, 31, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, 1],
    'A'],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, 1],
    'P'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$host_physical_identifier = 1,
      p$account_prefix_character = 2,
      p$project_prefix_character = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      control_block: nft$control_block,
      host_pid: host_pid_type,
      ignore_status: ost$status,
      lcn_boot: boolean,
      nam_boot: boolean,
      network_file_name: ost$name,
      number_of_libraries: pmt$number_of_libraries,
      number_of_modules: pmt$number_of_modules,
      number_of_objects: pmt$number_of_object_files,
      parameter_block: SEQ (REP 1 of nft$qtfs_task_switch_params),
      parameter_pointer: ^nft$qtfs_task_switch_params,
      program_attributes: ^pmt$program_attributes,
      program_description: ^pmt$program_description,
      program_parameters: ^pmt$program_parameters,
      qtfs_conditions: pmt$condition,
      qtfs_condition_descriptor: pmt$established_handler,
      qtfs_task_queue: nft$task_queue,
      store_forward_file_info: nft$store_forward_file_info,
      task_id: pmt$task_id,
      task_status: pmt$task_status;

    VAR
      lcn_application_names: [STATIC, READ, XREF] nft$lcn_application_names;

    VAR
      nam_application_names: [STATIC, READ, XREF] nft$nam_application_names;

    VAR
      qtfs_parameter_rules: [STATIC, READ, XREF] nft$parameter_rules_array;

?? NEWTITLE := 'qtfs_boot_condition_handler', EJECT ??

    PROCEDURE qtfs_boot_condition_handler
      (    condition: pmt$condition;
           condition_desc: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR trap_status: ost$status);

      VAR
        condition_handler_status: ost$status,
        local_status: ost$status;

      IF store_forward_file_info.file_open THEN
        nfp$close_store_forward_file (store_forward_file_info, local_status);
      IFEND;

      IF control_block.path.path_connected THEN
        nfp$terminate_path (control_block.application, TRUE, control_block.path, condition_handler_status);
      IFEND;
      rfp$application_sign_off (nfv$lcn_application_names [control_block.application],
            condition_handler_status);
      nap$detach_server_application (nfv$nam_application_names [control_block.application],
            condition_handler_status);
      osp$set_status_from_condition (nfc$status_id, condition, save_area, local_status,
            condition_handler_status);
      IF condition_handler_status.normal THEN
        pmp$log ('QTFS boot task terminating', condition_handler_status);
        nfp$format_message_to_job_log (local_status);
      ELSE
        pmp$log ('QTFS boot task terminating', local_status);
        nfp$format_message_to_job_log (condition_handler_status);
      IFEND;

    PROCEND qtfs_boot_condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      nfp$format_message_to_job_log (status);
      RETURN;
    IFEND;

    #translate (osv$lower_to_upper, pvt [p$host_physical_identifier].value^.string_value^, host_pid.value);
    host_pid.size := strlength (host_pid.value);

    lcn_boot := FALSE;
    nam_boot := FALSE;
    qtfs_task_queue.head := NIL;
    qtfs_task_queue.tail := NIL;
    qtfs_task_queue.number_of_tasks := 0;
    store_forward_file_info.file_open := FALSE;
    nfp$initialize_control_block (nfc$application_qtfs, nfc$p31_unspecified,
          nfv$qtf_send_p03_values [nfc$network_nam], nfv$qtf_send_p03_values [nfc$network_nam],
          nfv$qtf_send_p03_values [nfc$network_nam], nfc$p00_a102, nfc$take, ^nfv$qtf_parameter_rules,
          control_block);
    control_block.local_host_type := nfc$p22_nos_ve_qtf;

    qtfs_conditions.selector := pmc$condition_combination;
    qtfs_conditions.combination := $pmt$condition_combination
          [mmc$segment_access_condition, pmc$block_exit_processing];
    pmp$establish_condition_handler (qtfs_conditions, ^qtfs_boot_condition_handler,
          ^qtfs_condition_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{     Get description of the QTFS service task.  This description will be
{     used every time the task is executed.

    pmp$get_program_size (number_of_objects, number_of_modules, number_of_libraries, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    PUSH program_description: [[REP (#SIZE (pmt$program_attributes) +
          (number_of_objects * #SIZE (amt$local_file_name)) + (number_of_modules *
          #SIZE (pmt$program_name)) + (number_of_libraries * #SIZE (amt$local_file_name))) OF cell]];
    pmp$get_program_description (program_description^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET program_description;
    NEXT program_attributes IN program_description;
    program_attributes^.contents := program_attributes^.contents +
          $pmt$prog_description_contents [pmc$starting_proc_specified, pmc$term_error_level_specified];
    program_attributes^.starting_procedure := 'NFP$QTFS_SERVICE_TASK';
    program_attributes^.termination_error_level := pmc$fatal_load_errors;
    ALLOCATE control_block.path.network_file: [STRLENGTH (network_file_name)];

{ attach the STORE_FORWARD_NETWORK file and if the returned status is bad ignore it
{ because the file probably does not exist therefore we will not use the store/forward information

    nfp$open_store_forward_file (TRUE, store_forward_file_info, ignore_status);

{     MAIN loop

  /get_incoming_connections/
    WHILE TRUE DO

{     Get network path name

      pmp$get_unique_name (network_file_name, status);
      IF NOT status.normal THEN
        IF store_forward_file_info.file_open THEN
          nfp$close_store_forward_file (store_forward_file_info, ignore_status);
        IFEND;
        RETURN;
      IFEND;
      control_block.path.network_file^ := network_file_name;
      control_block.path.application_sequence_number := control_block.path.application_sequence_number + 1;

{     Get network connection (and handle application sign on to RHFAM, NAM).

      nfp$get_server_asynch_event (control_block.application, control_block.path, lcn_boot, nam_boot,
            qtfs_task_queue, status);
      IF NOT status.normal THEN
        IF store_forward_file_info.file_open THEN
          nfp$close_store_forward_file (store_forward_file_info, ignore_status);
        IFEND;
        RETURN;
      IFEND;

{     Build parameters for service task

      program_parameters := ^parameter_block;
      RESET program_parameters;
      NEXT parameter_pointer IN program_parameters;
      parameter_pointer^.path_info := control_block.path;
      parameter_pointer^.network_file := control_block.path.network_file^;
      parameter_pointer^.local_pid := host_pid;
      parameter_pointer^.store_forward_file_name := store_forward_file_info.local_file_name;
      parameter_pointer^.charge_prefix_character := pvt [p$account_prefix_character].value^.name_value;
      parameter_pointer^.project_prefix_character := pvt [p$project_prefix_character].value^.name_value;
      RESET program_parameters;

{     Now we have a connection, execute the service task

      pmp$execute (program_description^, program_parameters^, osc$nowait, task_id, task_status, status);
      IF status.normal THEN
        nfp$enqueue_task (task_id, control_block.path, qtfs_task_queue);
        control_block.path.path_connected := FALSE;
      ELSE
        {** Disconnect path **}
        IF control_block.path.path_connected THEN
          nfp$terminate_path (control_block.application, FALSE, control_block.path, status);
        IFEND;
      IFEND;
    WHILEND /get_incoming_connections/;

    IF store_forward_file_info.file_open THEN
      nfp$close_store_forward_file (store_forward_file_info, ignore_status);
    IFEND;

  PROCEND nfp$qtfs_boot;
?? TITLE := 'nfp$qtfs_service_task', EJECT ??

{ PURPOSE:
{   This is the entry procedure for the QTFS job generation task.
{   This task is executed by the "BOOT" to build the user QTFS job.
{   The job is then submitted for batch execution.  If the user
{   job fails, this task completes the protocol.

  PROCEDURE [XDCL] nfp$qtfs_service_task
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? NEWTITLE := 'qtfs_condition_handler', EJECT ??

    PROCEDURE qtfs_condition_handler
      (    condition: pmt$condition;
           condition_desc: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR trap_status: ost$status);

      VAR
        condition_handler_status: ost$status,
        local_status: ost$status;

      amp$return (control_block.file_name, local_status);
      IF control_block.path.path_connected THEN
        nfp$terminate_path (control_block.application, FALSE, control_block.path, condition_handler_status);
      IFEND;

      osp$set_status_from_condition (nfc$status_id, condition, save_area, local_status,
            condition_handler_status);
      IF condition_handler_status.normal THEN
        pmp$log ('QTFS service task terminating', condition_handler_status);
        nfp$format_message_to_job_log (local_status);
      IFEND;

    PROCEND qtfs_condition_handler;
?? OLDTITLE, EJECT ??

    VAR
      control_block: nft$control_block,
      ignore_status: ost$status,
      host_pid: host_pid_type,
      initiated_job_system_name: jmt$system_supplied_name,
      nam_attributes: ^nat$change_attributes,
      network_file_name: ost$name,
      parameter_sequence: ^clt$parameter_list,
      parameter_value: ^nft$qtfs_task_switch_params,
      qtfs_conditions: pmt$condition,
      qtfs_condition_descriptor: pmt$established_handler,
      rhfam_attributes: ^rft$change_attributes,
      rhfam_physical_id: rft$physical_identifier,
      store_forward_file_name: amt$local_file_name;

    VAR
      qtf_parameter_rules: [STATIC, READ, XREF] nft$parameter_rules_array;

    status.normal := TRUE;
    nfp$initialize_control_block (nfc$application_qtfs, nfc$p31_unspecified,
          nfv$qtf_send_p03_values [nfc$network_nam], nfv$qtf_send_p03_values [nfc$network_nam],
          nfv$qtf_send_p03_values [nfc$network_nam], nfc$p00_a102, nfc$take, ^nfv$qtf_parameter_rules,
          control_block);
    control_block.local_host_type := nfc$p22_nos_ve_qtf;

{     Get task parameters and open connection

    parameter_sequence := ^parameter_list;
    RESET parameter_sequence;
    NEXT parameter_value IN parameter_sequence;
    control_block.path := parameter_value^.path_info;
    host_pid := parameter_value^.local_pid;
    store_forward_file_name := parameter_value^.store_forward_file_name;
    charge_prefix_character := parameter_value^.charge_prefix_character;
    project_prefix_character := parameter_value^.project_prefix_character;
    RESET parameter_sequence;
    PUSH control_block.path.network_file: [STRLENGTH (network_file_name)];
    control_block.path.network_file^ := parameter_value^.network_file;

{     Set up condition handler

    qtfs_conditions.selector := pmc$condition_combination;
    qtfs_conditions.combination := $pmt$condition_combination
          [mmc$segment_access_condition, pmc$block_exit_processing];
    pmp$establish_condition_handler (qtfs_conditions, ^qtfs_condition_handler, ^qtfs_condition_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$open_file (control_block.path.network_file^, amc$record, NIL, { File attachment options
    NIL, { Default creation opts
    NIL, { Mandated creation opts
    NIL, { Attribute validation
    NIL, { Attribute override
    control_block.path.network_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{     Set up default network time outs

    CASE control_block.path.network_type OF
    = nfc$network_nam =
      PUSH nam_attributes: [1 .. 1];
      nam_attributes^ [1].kind := nac$data_transfer_timeout;
      nam_attributes^ [1].data_transfer_timeout := control_block.time_out * nfc$milliseconds;
      nap$store_attributes (control_block.path.network_file_id, nam_attributes^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      control_block.transfer_pid_length := host_pid.size;
      control_block.transfer_pid := host_pid.value;
    = nfc$network_lcn =
      PUSH rhfam_attributes: [1 .. 1];
      rhfam_attributes^ [1].key := rfc$data_transfer_timeout;
      rhfam_attributes^ [1].data_transfer_timeout := control_block.time_out * nfc$milliseconds;
      rfp$store (control_block.path.network_file_id, rhfam_attributes^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      rfp$get_local_host_physical_id (rhfam_physical_id, status);
      IF status.normal THEN
        control_block.transfer_pid_length := STRLENGTH (rhfam_physical_id);
        control_block.transfer_pid := rhfam_physical_id;
      ELSE
        RETURN;
      IFEND;
      control_block.required_facilities := $nft$parameter_03_value_set [];
      control_block.transfer_facilities := $nft$parameter_03_value_set [];
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
            'nfp$qtfs_service_task - bad network type', status);
      RETURN;
    CASEND;

{     Begin A-A protocol }

    qtfs_a_to_a_protocol (store_forward_file_name, control_block, status);
    IF NOT status.normal THEN
      pmp$log ('QTFS A to A protocol phase returned an abnormal status of', ignore_status);
      nfp$format_message_to_job_log (status);
    IFEND;

    IF control_block.path.path_connected THEN
      nfp$terminate_path (control_block.application, FALSE, control_block.path, ignore_status);
    IFEND;
    pmp$disestablish_cond_handler (qtfs_conditions, ignore_status);

  PROCEND nfp$qtfs_service_task;
?? TITLE := 'analyze_received_rft', EJECT ??

{ PURPOSE:
{   This procedure will check the received RFT for protocol attributes
{   which require initialization or action.  Then it calls a procedure
{   to establish the attributes for the incoming queue file.

  PROCEDURE analyze_received_rft
    (    received_parameters: nft$parameter_set;
         store_forward_file_name: amt$local_file_name;
     VAR control_block: nft$control_block;
     VAR transfer_mode: nft$transfer_modes;
     VAR store_and_forward_queue_file: boolean;
     VAR rpos_parameters: nft$parameter_set;
     VAR queue_file_attributes: nft$queue_submission_option;
     VAR queue_file_type: nft$queue_file_type;
     VAR loop_back_transfer: boolean;
     VAR input_accounting_data: qtfs_input_accounting_data;
     VAR overridden_jad_odu: boolean;
     VAR queue_file_page_width: amt$page_width;
     VAR status: ost$status);

    VAR
      application_name_changed: boolean,
      current_source_name: nft$parameter_24_definition,
      destination_name: nft$parameter_24_definition,
      destination_name_changed: boolean,
      echo_text_data_mode: jmt$data_mode,
      echo_text_login_family: ost$name,
      file_is_qtfi_err_file: boolean,
      lid_is_local: boolean,
      new_application_name: ost$name,
      new_destination_name: nft$parameter_24_definition,
      new_source_name: nft$parameter_24_definition,
      parameter_list_index: nft$protocol_parameters,
      source_name_changed: boolean,
      store_forward_application_name: ost$name,
      store_forward_file_info: nft$store_forward_file_info,
      trace_string: string (nfc$trace_commands_width);

    status.normal := TRUE;
    rpos_parameters := nfv$qtf_required_params_on_cmds [nfc$rpos];
    overridden_jad_odu := FALSE;
    file_is_qtfi_err_file := FALSE;

{ attach the STORE_FORWARD_NETWORK file and if the returned status is bad ignore it
{ because the file probably does not exist therefore we will not use the store/forward information

    store_forward_file_info.local_file_name := store_forward_file_name;
    nfp$open_store_forward_file (FALSE, store_forward_file_info, status);

    destination_name.value := control_block.remote_lid;
    destination_name.size := control_block.remote_lid_length;
    current_source_name := control_block.source_lid;
    store_forward_application_name := jmc$qtf_usage;

    IF store_forward_file_info.file_open THEN
      nfp$get_new_destination_name (nfc$sf_qtf_server, store_forward_file_info, destination_name,
            destination_name_changed, new_destination_name, status);
      IF destination_name_changed THEN
        destination_name := new_destination_name;
        IF control_block.protocol_trace THEN
          trace_string := '** QTF SERVER changed 25 to ';
          trace_string (29,*) := destination_name.value;
          pmp$log (trace_string, status);
        IFEND;
      IFEND;

{   if applicable get the new source name from the Store_Forward_Network file

      nfp$get_new_source_name (nfc$sf_qtf_server, store_forward_file_info, current_source_name,
            destination_name, source_name_changed, new_source_name, status);
      IF source_name_changed THEN
        current_source_name := new_source_name;
        IF control_block.protocol_trace THEN
          trace_string := '** QTF SERVER changed 24 to ';
          trace_string (29,*) := current_source_name.value;
          pmp$log (trace_string, status);
        IFEND;
      IFEND;

{   if applicable get the new application name from the Store_Forward_Network file

      nfp$get_new_application_name (nfc$sf_qtf_server, store_forward_file_info, destination_name,
            application_name_changed, new_application_name, status);
      IF application_name_changed THEN
        store_forward_application_name := new_application_name;
        IF control_block.protocol_trace THEN
          trace_string := '** QTF SERVER chngd APPL to ';
          trace_string (29,*) := store_forward_application_name;
          pmp$log (trace_string, status);
        IFEND;
      IFEND;
    IFEND;

    check_if_family_is_local (destination_name.value, lid_is_local, status);
    IF NOT status.normal THEN
      RETURN;
    ELSE

{  if the application name (store_forward_application_name) is NOT QTF, the incoming queue
{  file MUST be a store and forward queue file.  However, if the application name is QTF,
{  the destination (lid_is_local) will determine if the incoming queue file is a store and
{  forward queue file or at its final destination (local).

      store_and_forward_queue_file := NOT (lid_is_local AND (store_forward_application_name =
            jmc$qtf_usage));
    IFEND;

    IF control_block.protocol_trace THEN
      IF store_and_forward_queue_file THEN
        pmp$log ('** QTF SERVER defines the queue file as a STORE and FORWARD file', status);
      ELSE
        pmp$log ('** QTF SERVER defines the queue file as a LOCAL file', status);
      IFEND;
    IFEND;

{     Check if loop back transfer

    IF (control_block.transfer_pid = control_block.remote_pid) THEN
      loop_back_transfer := TRUE;
    ELSE
      loop_back_transfer := FALSE;
    IFEND;

{     Is this an output file or a job file?

    IF (control_block.disposition_code = nfc$p17_input_return) OR
          (control_block.disposition_code = nfc$p17_input_no_return) THEN
      IF loop_back_transfer THEN
        osp$set_status_abnormal(nfc$status_id,nfe$qtf_no_loopback_jobs,
             '',status);
        RETURN;
      ELSE
        queue_file_type := nfc$job_queue_file;
      IFEND;
    ELSEIF control_block.disposition_code = nfc$p17_generic_queue THEN
      queue_file_type := nfc$generic_queue_file
    ELSE
      queue_file_type := nfc$print_queue_file;
    IFEND;

{  crack the echo text for the login_family and data_mode
{  login_family will only be specified if the job was received from a NOS/VE system
{  and the login_family was supplied by the user.  data_mode will only be specified
{  if the queue file originated on a NON-NOS/VE system, store-forwarded through a
{  NOS/VE system and the data_declaration was unspecified.

    echo_text_login_family := osc$null_name;
    echo_text_data_mode := jmc$coded_data;

    IF control_block.received_echo_text.first_text <> NIL THEN
      crack_job_echo_text (control_block.received_echo_text.first_text^.value (1, control_block.
            received_echo_text.first_text^.size), echo_text_login_family, echo_text_data_mode,
            file_is_qtfi_err_file);
    IFEND;

{     Figure out data declaration to send back (if any).  The data declaration
{     will be modified only if talking to another NOS/VE system.

    IF store_and_forward_queue_file THEN
      IF control_block.remote_host_type = nfc$p22_nos_ve_qtf THEN
        control_block.data_declaration := nfc$p31_host_dependent_uh;
        rpos_parameters := rpos_parameters + $nft$parameter_set [nfc$data_declaration];
      IFEND;
    ELSE
      IF control_block.remote_host_type = nfc$p22_nos_ve_qtf THEN
        CASE control_block.data_declaration OF
        = nfc$p31_undef_unstructured_uu =
          control_block.data_declaration := nfc$p31_host_dependent_uh;
          rpos_parameters := rpos_parameters + $nft$parameter_set [nfc$data_declaration];
        = nfc$p31_unspecified =
          IF echo_text_data_mode <> jmc$rhf_structure THEN
            control_block.data_declaration := nfc$p31_host_dependent_uh;
            rpos_parameters := rpos_parameters + $nft$parameter_set [nfc$data_declaration];
          IFEND;
        = nfc$p31_ascii_c6, nfc$p31_ascii_c8, nfc$p31_undefined_structured_us =
          ; { No action }
        CASEND;
      IFEND;
    IFEND;

{     Define data mode

    IF (control_block.remote_host_type <> nfc$p22_nos_ve) AND (control_block.remote_host_type <>
          nfc$p22_nos_ve_qtf) THEN
      IF store_and_forward_queue_file THEN
        IF control_block.data_declaration = nfc$p31_undef_unstructured_uu THEN
          transfer_mode := nfc$transparent_data_mode;
        ELSE
          transfer_mode := nfc$rhf_structured_mode;
        IFEND;
      ELSE
        CASE control_block.data_declaration OF
        = nfc$p31_host_dependent_uh =
          transfer_mode := nfc$ve_to_ve_mode;
        = nfc$p31_unspecified, nfc$p31_ascii_c6, nfc$p31_ascii_c8 =
          transfer_mode := nfc$coded_data_mode;
        = nfc$p31_undef_unstructured_uu =
          transfer_mode := nfc$transparent_data_mode;
        = nfc$p31_undefined_structured_us =
          IF queue_file_type = nfc$print_queue_file THEN
            transfer_mode := nfc$rhf_structured_mode;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$data_type_us_not_for_job, '', status);
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
                'QTFS case error DD analyze_received_rft', status);
          RETURN;
        CASEND;
      IFEND;
    ELSE { VE to VE transfer }
      CASE control_block.data_declaration OF
      = nfc$p31_unspecified, nfc$p31_ascii_c6, nfc$p31_ascii_c8 =
        transfer_mode := nfc$coded_data_mode;
      = nfc$p31_undef_unstructured_uu =
        osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'QTFS invalid UU transfer', status);
        RETURN;
      = nfc$p31_undefined_structured_us =
        transfer_mode := nfc$rhf_structured_mode;
      = nfc$p31_host_dependent_uh =
        transfer_mode := nfc$ve_to_ve_mode;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
              'QTFS case error DD analyze_received_rft', status);
        RETURN;
      CASEND;
    IFEND;

{     If necessary, set block size values

    IF NOT (nfc$max_block_size IN received_parameters) THEN
      CASE control_block.data_declaration OF
      = nfc$p31_unspecified, nfc$p31_ascii_c6, nfc$p31_ascii_c8 =
        control_block.data_block_size := nfc$p12_nos_ascii_size;
      = nfc$p31_undef_unstructured_uu, nfc$p31_undefined_structured_us =
        control_block.data_block_size := nfc$p12_nos_binary_size;
      = nfc$p31_host_dependent_uh =
        control_block.data_block_size := nfc$p12_lcn_default;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
              'QTFS analyze_received_rft - P12 invalid P31', status);
        RETURN;
      CASEND;
    IFEND;

{     If no source LID, use remote PID

    IF NOT(nfc$source_lid IN received_parameters) THEN
      IF (nfc$physical_id IN received_parameters) THEN
        control_block.source_lid.value := control_block.transfer_pid(1,control_block.
             transfer_pid_length);
        control_block.source_lid.size := control_block.transfer_pid_length;
      ELSE
        osp$set_status_abnormal(nfc$status_id,nfe$bts_internal_error,
             'QTFS source lid or transfer pid required!!!', status);
        return;
      IFEND;
    IFEND;

    create_queue_file_attributes (control_block.file_name, store_and_forward_queue_file,
          control_block.remote_host_type, control_block.data_declaration, control_block.disposition_code,
          destination_name.value (1, destination_name.size),
          current_source_name.value (1, current_source_name.size), store_forward_application_name,
          control_block.receive_systems_routing_text, control_block.receive_implicit_routing_text,
          control_block.received_directives, transfer_mode, control_block.receive_job_name.
          value (1, control_block.receive_job_name.size), control_block.receive_file_name.
          value (1, control_block.receive_file_name.size), queue_file_type, loop_back_transfer,
          echo_text_login_family, control_block.transfer_pid (1, control_block.transfer_pid_length),
          file_is_qtfi_err_file, input_accounting_data, queue_file_attributes, overridden_jad_odu,
          queue_file_page_width,status);

  PROCEND analyze_received_rft;

?? TITLE := 'change_page_width', EJECT ??

{ PURPOSE:
{   This procedure changes the file attribute page width of Queue file
{   to the value given by PAGE_WIDTH parameter in REMOTE_HOST_DIRECTIVE

  PROCEDURE  change_page_width
    (    file: amt$local_file_name;
         file_pw: amt$page_width;
     VAR status: ost$status);

    VAR
      attachment_options: ^fst$attachment_options,
      ignore_status: ost$status,
      transfer_file_attributes: ^fst$file_cycle_attributes,
      unique_fid: amt$file_identifier;

      PUSH transfer_file_attributes: [1..1];
      transfer_file_attributes^ [1].selector := fsc$page_width;
      transfer_file_attributes^ [1].page_width := file_pw;

    fsp$open_file ( file, amc$record, NIL, transfer_file_attributes,
                             NIL, NIL, NIL, unique_fid,ignore_status);

       IF NOT ignore_status.normal  THEN
         RETURN;
       IFEND;

    fsp$close_file (unique_fid,ignore_status);


  PROCEND  change_page_width;

?? TITLE := 'check_if_family_is_local', EJECT ??

{ PURPOSE:
{   This procedure must decide if a specified family (or LCN LID)
{   is served by this mainframe.  If this family is not served locally
{   then, the queue file will be store and forwarded.

  PROCEDURE check_if_family_is_local
    (    family_name: string (nfc$p24_max_param_size);
     VAR lid_is_local: boolean;
     VAR status: ost$status);

    CONST
      qtf_title_length = qtf_title_part_length + osc$max_name_size,
      qtf_title_part = 'QTFS$',
      qtf_title_part_length = 5;

    VAR
      local_status: ost$status,
      requested_cdcnet_title: string(qtf_title_length),
      requested_search_domain: nat$title_domain,
      title_request_id: nat$directory_search_identifier,
      translated_cdcnet_address: nat$osi_translation_address,
      translated_cdcnet_title: string(qtf_title_length),
      translated_identifier: nat$directory_entry_identifier,
      translated_priority: nat$directory_priority,
      translated_protocol: nat$protocol,
      translated_user_id: ost$name,
      translated_user_info: ^ array [1 .. nac$max_directory_data_length] of cell,
      translated_user_info_len: 0 .. nac$max_directory_data_length,
      type_of_transfer_lid: rft$type_of_lid,
      upper_case_family_name: string (nfc$p24_max_param_size);

    status.normal := TRUE;
    lid_is_local := FALSE;
    #translate (osv$lower_to_upper, family_name, upper_case_family_name);

    nfp$verify_family (upper_case_family_name, lid_is_local, status);

    IF NOT lid_is_local THEN
      rfp$return_lid_type (upper_case_family_name, type_of_transfer_lid, local_status);
      IF (type_of_transfer_lid = rfc$local_physical_id) OR (type_of_transfer_lid = rfc$local_logical_id) THEN
        lid_is_local := TRUE;
      ELSEIF (type_of_transfer_lid = rfc$remote_physical_id) OR (type_of_transfer_lid = rfc$remote_logical_id)
            THEN

{   the queue file destination is a remote systems logical identifier

        lid_is_local := FALSE;
      ELSE

{     check to see if the destination is a local CDCNET title

        requested_cdcnet_title := qtf_title_part;
        requested_cdcnet_title ((qtf_title_part_length + 1), * ) := upper_case_family_name;
        requested_search_domain.kind := nac$local_system_domain;
        nlp$translate_title (requested_cdcnet_title, FALSE, nac$cdna_session, FALSE, requested_search_domain,
              nac$cdna_external, title_request_id, local_status);
        IF local_status.normal THEN
          nlp$get_title_translation (title_request_id, translated_cdcnet_title, translated_cdcnet_address,
                translated_protocol, translated_user_info, translated_user_info_len, translated_priority,
                translated_user_id, translated_identifier, local_status);

{         if status is normal the CDCNET title was found as a local title
{         otherwise if the status is abnormal the CDCNET title was NOT found
{         and the title is for a remote system.

          lid_is_local := local_status.normal;
          nlp$end_title_translation (title_request_id, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND check_if_family_is_local;
?? TITLE := 'check_wait_queue_file', EJECT ??

{ PURPOSE:
{   This procedure will decide if the received queue file should be saved
{   as a permanent file, and if so, using what path name.

  PROCEDURE check_wait_queue_file
    (    output_submission_options: nft$queue_submission_option;
         remote_host_type: nft$parameter_22_values;
     VAR wait_queue: wait_queue_information);

    VAR
      local_status: ost$status,
      queue_file_name: amt$local_file_name;

    wait_queue.use_wait_queue := FALSE;

    IF (output_submission_options.output_submission_option [nfc$oqa_disposition_code].key <>
          jmc$null_attribute) AND (output_submission_options.output_submission_option
          [nfc$oqa_disposition_code].disposition_code = nfc$p17_wait_queue) AND
          (output_submission_options.output_submission_option [nfc$oqa_user_job_name].key <>
          jmc$null_attribute) AND (output_submission_options.output_submission_option [nfc$oqa_control_family]
          .key <> jmc$null_attribute) AND (output_submission_options.output_submission_option
          [nfc$oqa_control_user].key <> jmc$null_attribute) THEN
      nfp$create_wait_queue_file_name (output_submission_options.output_submission_option
            [nfc$oqa_control_family].control_family, output_submission_options.output_submission_option
            [nfc$oqa_control_user].control_user, output_submission_options.output_submission_option
            [nfc$oqa_user_job_name].user_job_name, queue_file_name, local_status);
      IF NOT local_status.normal THEN
        RETURN;
      ELSE
        wait_queue.use_wait_queue := TRUE;
        wait_queue.wait_queue_file_name := queue_file_name;
      IFEND;
    IFEND;

  PROCEND check_wait_queue_file;
?? TITLE := 'complete_qtfs_protocol', EJECT ??

{ PURPOSE:
{   This procedure will complete the ending of the A-A protocol.

  PROCEDURE complete_qtfs_protocol
    (VAR control_block: nft$control_block);

    VAR
      ignored_parameters: nft$parameter_set,
      local_status: ost$status,
      modified_parameters: nft$parameter_set,
      received_parameters: nft$parameter_set;

{     Send an ETPR

    nfp$send_command (nfc$etpr, $nft$parameter_set [],
      $nft$parameter_set[ ], $nft$parameter_set[],
      control_block, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

{     Receive FINI

    nfp$receive_command ($nft$command_set [nfc$fini], nfv$qtf_required_params_on_cmds, control_block,
          received_parameters, ignored_parameters, modified_parameters, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

{     Wait here for client to disconnect, if he forgets, time out and disconnect

    nfp$receive_command ($nft$command_set [], nfv$qtf_required_params_on_cmds, control_block,
          received_parameters, ignored_parameters, modified_parameters, local_status);
    IF control_block.path.path_connected THEN
      nfp$terminate_path (control_block.application, FALSE, control_block.path, local_status);
    IFEND;

  PROCEND complete_qtfs_protocol;
?? OLDTITLE ??
?? NEWTITLE := 'convert_string_to_ost$name', EJECT ??

{ PURPOSE:
{   The purpose of this function is to create a valid NOS/VE name by eliminating any invalid
{   characters from a string of characters.  If the string is empty or all blanks, the name
{   will be equal to the value osc$null_name.

  PROCEDURE convert_string_to_ost$name
    (    string_value: string ( * );
         prefix_character: string (1);
     VAR name_value: ost$name);

    TYPE
      set_of_char = set of char;

    VAR
      name_value_index: ost$non_negative_integers,
      ptr_string_value_upper_case: ^string( * ),
      string_index: ost$non_negative_integers,
      string_length: ost$non_negative_integers,
      valid_characters_for_name: [STATIC, READ] set_of_char := ['A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
            'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '#', '$',
            '@', '[', '\', ']', '^', '_', '`', '{', '|', '}', '~'],
      valid_number_for_name: [STATIC, READ] set_of_char := ['1', '2', '3', '4', '5', '6', '7', '8', '9', '0'];

    string_length := clp$trimmed_string_size (string_value);
    name_value := osc$null_name;
    IF string_length > 0 THEN
      PUSH ptr_string_value_upper_case : [string_length];

{ convert the string value into upper case, since a name value is not case dependent.

      #translate (osv$lower_to_upper, string_value, ptr_string_value_upper_case^);

      name_value_index := 0;

{ verify that the first character of the string value is a valid first character for a name.

      IF NOT (ptr_string_value_upper_case^ (1,1) IN valid_characters_for_name) THEN
        name_value := prefix_character;
        name_value_index := 1;
      IFEND;

    /eliminate_invalid_characters/
      FOR string_index := 1 TO string_length DO

{ eliminate any invalid characters from the string value when generating the new name

        IF (ptr_string_value_upper_case^ (string_index, 1) IN valid_characters_for_name) OR
              (ptr_string_value_upper_case^ (string_index, 1) IN valid_number_for_name) THEN
          name_value_index := name_value_index + 1;
          name_value (name_value_index, 1) := ptr_string_value_upper_case^ (string_index, 1);

{ determine if the new name has reached the maximum length for a ost$name

          IF name_value_index >= osc$max_name_size THEN
            EXIT /eliminate_invalid_characters/;
          IFEND;
        IFEND;
      FOREND /eliminate_invalid_characters/;
    IFEND;

  PROCEND convert_string_to_ost$name;
?? TITLE := 'crack_generic_command', EJECT ??

{ PURPOSE:
{   This procedure will crack the remote host directive for generic queue files into
{   queue file submission options.

  PROCEDURE crack_generic_command
    (    command: string ( * );
     VAR return_attributes: nft$queue_submission_option;
     VAR status: ost$status);

{ PROCEDURE gq (
{   application_name, an: name = $optional
{   deferred_by_application, dba: boolean = $optional
{   destination, d: name = $optional
{   earliest_run_time, ert: date_time = $optional
{   latest_run_time, lrt: date_time = $optional
{   purge_delay, pd: time_increment = $optional
{   remote_host_directive, rhd: string 0..256 = $optional
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 14] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$date_time_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$date_time_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
    recend := [
    [1,
    [91, 3, 27, 10, 7, 35, 915],
    clc$command, 14, 7, 0, 0, 0, 0, 0, ''], [
    ['AN                             ',clc$abbreviation_entry, 1],
    ['APPLICATION_NAME               ',clc$nominal_entry, 1],
    ['D                              ',clc$abbreviation_entry, 3],
    ['DBA                            ',clc$abbreviation_entry, 2],
    ['DEFERRED_BY_APPLICATION        ',clc$nominal_entry, 2],
    ['DESTINATION                    ',clc$nominal_entry, 3],
    ['EARLIEST_RUN_TIME              ',clc$nominal_entry, 4],
    ['ERT                            ',clc$abbreviation_entry, 4],
    ['LATEST_RUN_TIME                ',clc$nominal_entry, 5],
    ['LRT                            ',clc$abbreviation_entry, 5],
    ['PD                             ',clc$abbreviation_entry, 6],
    ['PURGE_DELAY                    ',clc$nominal_entry, 6],
    ['REMOTE_HOST_DIRECTIVE          ',clc$nominal_entry, 7],
    ['RHD                            ',clc$abbreviation_entry, 7]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 7
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$boolean_type]],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 4
    [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [clc$past
  , clc$present, clc$future]]],
{ PARAMETER 5
    [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [clc$past
  , clc$present, clc$future]]],
{ PARAMETER 6
    [[1, 0, clc$time_increment_type]],
{ PARAMETER 7
    [[1, 0, clc$string_type], [0, 256, FALSE]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$application_name = 1,
      p$deferred_by_application = 2,
      p$destination = 3,
      p$earliest_run_time = 4,
      p$latest_run_time = 5,
      p$purge_delay = 6,
      p$remote_host_directive = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

    VAR
      command_length: integer,
      command_line_size_ptr: ^clt$command_line_size,
      command_ptr: ^string ( * ),
      ignore_status: ost$status,
      scl_parameter_list_ptr: ^clt$parameter_list;

{ BEGIN crack_generic_command;

    command_length := clp$trimmed_string_size(command);

    IF command_length > 0 THEN

{ Create the necessary environment to call CLP$EVALUATE_PARAMETERS.

      clp$push_parameters (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      PUSH scl_parameter_list_ptr: [[REP (command_length + #SIZE (clt$command_line_size)) OF cell]];
      RESET scl_parameter_list_ptr;
      NEXT command_line_size_ptr IN scl_parameter_list_ptr;
      command_line_size_ptr^ := command_length;

      NEXT command_ptr: [command_length] IN scl_parameter_list_ptr;
      command_ptr^ := command (1, command_length);

      RESET scl_parameter_list_ptr;

      clp$evaluate_parameters (scl_parameter_list_ptr^, #SEQ (pdt), NIL, ^pvt, status);
      IF NOT status.normal THEN
        clp$pop_parameters (ignore_status);
        RETURN;
      IFEND;

      IF pvt [p$application_name].specified THEN

{ The subrecord DESTINATION is used in this entry in the array because APPLICATION_NAME is not a
{ qfile submission option. The value stored in this entry will be retrieved by SUBMIT_GENERIC_QUEUE_FILE
{ and passed to JMP$SUBMIT_QFILE as a parameter seperate from the qfile submission options.

        return_attributes.qfile_submission_option [nfc$gqa_application_name].key :=
              jmc$destination;
        return_attributes.qfile_submission_option [nfc$gqa_application_name].destination :=
              pvt [p$application_name].value^.name_value;
      IFEND;

      IF pvt [p$deferred_by_application].specified THEN
        return_attributes.qfile_submission_option [nfc$gqa_deferred_by_application].key :=
              jmc$deferred_by_application;
        return_attributes.qfile_submission_option [nfc$gqa_deferred_by_application].deferred_by_application :=
              pvt [p$deferred_by_application].value^.boolean_value.value;
      IFEND;

      IF pvt [p$destination].specified THEN
        return_attributes.qfile_submission_option [nfc$gqa_destination].key :=
              jmc$destination;
        return_attributes.qfile_submission_option [nfc$gqa_destination].destination :=
              pvt [p$destination].value^.name_value;
      IFEND;

      IF pvt [p$earliest_run_time].specified THEN
        return_attributes.qfile_submission_option [nfc$gqa_earliest_run_time].key :=
              jmc$earliest_run_time;
        return_attributes.qfile_submission_option [nfc$gqa_earliest_run_time].earliest_run_time.specified :=
              TRUE;
        return_attributes.qfile_submission_option [nfc$gqa_earliest_run_time].earliest_run_time.date_time :=
              pvt [p$earliest_run_time].value^.date_time_value.value;
      IFEND;

      IF pvt [p$latest_run_time].specified THEN
        return_attributes.qfile_submission_option [nfc$gqa_latest_run_time].key :=
              jmc$latest_run_time;
        return_attributes.qfile_submission_option [nfc$gqa_latest_run_time].latest_run_time.specified := TRUE;
        return_attributes.qfile_submission_option [nfc$gqa_latest_run_time].latest_run_time.date_time :=
              pvt [p$latest_run_time].value^.date_time_value.value;
      IFEND;

      IF pvt [p$purge_delay].specified THEN
        IF pvt [p$purge_delay].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
          output_purge_delay.specified := FALSE;
        ELSE
          output_purge_delay.specified := TRUE;
          output_purge_delay.time_increment := pvt [p$purge_delay].value^.time_increment_value^;
        IFEND;

        return_attributes.qfile_submission_option [nfc$gqa_purge_delay].key := jmc$purge_delay;
        return_attributes.qfile_submission_option [nfc$gqa_purge_delay].purge_delay := ^output_purge_delay;
      IFEND;

      IF pvt [p$remote_host_directive].specified THEN
        output_remote_host_directive.size := STRLENGTH (pvt [p$remote_host_directive].value^.string_value^);
        output_remote_host_directive.parameters := pvt [p$remote_host_directive].value^.string_value^;

        return_attributes.qfile_submission_option [nfc$gqa_remote_host_directive].key :=
              jmc$remote_host_directive;
        return_attributes.qfile_submission_option [nfc$gqa_remote_host_directive].remote_host_directive :=
              ^output_remote_host_directive;
      IFEND;

      clp$pop_parameters (ignore_status);
    IFEND;

  PROCEND crack_generic_command;
?? TITLE := 'crack_implicit_routing_text', EJECT ??

{ PURPOSE:
{   This procedure will crack the QTF implicit text into output submission options.
{   The implicit text is cracked by QTFS for non-store-and-forward output files.
{   This text is used with output files to build queue file attributes.

  PROCEDURE crack_implicit_routing_text
    (    implicit_text: jmt$implicit_routing_text;
     VAR nos_ve_text: boolean;
     VAR return_attributes: nft$queue_submission_option;
     VAR queue_file_page_width: amt$page_width;
     VAR status: ost$status);

    VAR
      index: nfc$p33_min_param_length .. nfc$p33_max_param_length,
      implicit_text_index: nfc$p33_min_param_length .. nfc$p33_max_param_length,
      initial_job_name: jmt$system_supplied_name,
      initial_job_name_size: 0..jmc$system_supplied_name_size,
      login_command: string (maximum_size_qtfs_scl_command),
      login_command_size: 0 .. maximum_size_qtfs_scl_command;

    status.normal := TRUE;
    nos_ve_text := FALSE;
    IF (implicit_text.size < nfc$p33_min_param_length) THEN
      osp$set_status_abnormal (nfc$status_id, nfe$invalid_implicit_text_value, implicit_text.
            text (1, implicit_text.size), status);
      RETURN;
    IFEND;

    IF NOT (implicit_text.text (1, nfc$p33_nos_ve_text_id_length) = nfc$p33_nos_ve_text_identifier) THEN
      RETURN; { Text of some other host, cannot process }
    IFEND;

{     Extract the job name that initiated this job

    nos_ve_text := TRUE;
    initial_job_name_size := 0;

  /extract_initial_job_name/
    FOR implicit_text_index := nfc$p33_nos_ve_text_id_length + 1 TO implicit_text.size DO
      IF implicit_text.text (implicit_text_index, 1) = nfc$p33_text_delimiter THEN
        EXIT /extract_initial_job_name/;
      ELSEIF initial_job_name_size >= UPPERVALUE (initial_job_name_size) THEN
        osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
              'QTFS crack_implicit_routing_text initial job_name overflow', status);
        RETURN;
      ELSE
        initial_job_name_size := initial_job_name_size + 1;
        initial_job_name (initial_job_name_size, 1) := implicit_text.text (implicit_text_index, 1);
      IFEND;
    FOREND /extract_initial_job_name/;

{     Extract the LOGIN command which is used to identify output
{     NOTE: this simple algorithm assumes no strings are valid in the
{     implicit text LOGIN command, should that change, work needs
{     to be done here.

    login_command_size := 0;
    implicit_text_index := implicit_text_index + 1; { Move past delimiter }

  /extract_implicit_login/
    FOR index := implicit_text_index TO implicit_text.size DO
      IF implicit_text.text (index, 1) = nfc$p33_text_delimiter THEN
        EXIT /extract_implicit_login/;
      ELSEIF login_command_size >= UPPERVALUE (login_command_size) THEN
        osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
              'QTFS crack_implicit_routing_text login_command overflow', status);
        RETURN;
      ELSE
        login_command_size := login_command_size + 1;
        login_command (login_command_size, 1) := implicit_text.text (index, 1);
      IFEND;
    FOREND /extract_implicit_login/;
    IF login_command_size > 0 THEN
      crack_output_login_command (login_command (1, login_command_size), return_attributes, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    implicit_text_index := index + 1; { Move past delimiter }
    IF implicit_text.size - implicit_text_index > 0 THEN
      crack_print_file_parameters (implicit_text.text (implicit_text_index,
             implicit_text.size - implicit_text_index + 1), return_attributes,
             queue_file_page_width, status);
    IFEND;

  PROCEND crack_implicit_routing_text;
?? TITLE := 'crack_job_echo_text', EJECT ??

{ PURPOSE:
{   This procedure will crack the echo text for VE -> VE job transfers.
{   The echo text contains job attributes.

  PROCEDURE crack_job_echo_text
    (    text: string(*<=nfc$p29_max_param_size);
     VAR login_family: ost$name;
     VAR data_mode: jmt$data_mode;
     VAR file_is_qtfi_err_file: boolean);

    TYPE
      set_of_char = set of char;

    VAR
      command_length: integer,
      echo_text_index: ost$non_negative_integers,
      parameter_position: ost$non_negative_integers,
      parameter_value_length: ost$non_negative_integers,
      parameter_value_position: ost$non_negative_integers,
      ptr_upper_case_echo_text: ^string (*),
      valid_characters_for_name: [STATIC, READ] set_of_char := ['A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
            'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '#', '$',
            '@', '[', '\', ']', '^', '_', '`', '{', '|', '}', '~'],
      valid_number_for_name: [STATIC, READ] set_of_char := ['1', '2', '3', '4', '5', '6', '7', '8', '9', '0'],
      valid_login_family: boolean;

?? NEWTITLE := 'find_delimiter_position', EJECT ??

{ PURPOSE:
{   This function will find the position for the first delimiter in the
{   string.  If the delimiter was not found, the position value will be
{   equal to the length of the command_string + 1.  If the command_string
{   length is 0 (zero), the position value will be 0 (zero).

  FUNCTION find_delimiter_position
    (    command_string: string ( * <=nfc$p29_max_param_size);
         starting_position_in_string: ost$non_negative_integers): ost$non_negative_integers;

    VAR
      command_length: integer,
      string_index: ost$non_negative_integers;

    command_length := STRLENGTH (command_string);
    IF command_length > 0 THEN
      IF starting_position_in_string <= command_length THEN
        FOR string_index := starting_position_in_string TO command_length DO
          IF (command_string (string_index, 1) = ' ') OR (command_string (string_index, 1) = ',') THEN
            find_delimiter_position := string_index;
            RETURN;
          IFEND;
        FOREND;
      IFEND;
      find_delimiter_position := command_length + 1;
    ELSE
      find_delimiter_position := 0;
    IFEND;

  FUNCEND find_delimiter_position;
?? OLDTITLE ??
?? NEWTITLE := 'find_parameter_position', EJECT ??

{ PURPOSE:
{   This function will find the position for the parameter_string specified
{   in the command_string.  If the parameter_string was not found a value of
{   0 (zero) will be returned.

  FUNCTION find_parameter_position
    (    parameter_string: string ( * <=nfc$p29_max_param_size);
         command_string: string ( * <=nfc$p29_max_param_size)): ost$non_negative_integers;

    VAR
      command_length: integer,
      parameter_length: integer,
      string_index: ost$non_negative_integers;

    command_length := STRLENGTH (command_string);
    IF command_length > 0 THEN
      parameter_length := STRLENGTH (parameter_string);
      IF (parameter_length > 0) AND (parameter_length <= command_length) THEN
        FOR string_index := 1 TO (command_length - parameter_length + 1) DO
          IF command_string (string_index, parameter_length) = parameter_string (1, parameter_length) THEN
            find_parameter_position := string_index;
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    IFEND;

    find_parameter_position := 0;

  FUNCEND find_parameter_position;
?? OLDTITLE, EJECT ??
    login_family := osc$null_name;
    data_mode := jmc$coded_data;
    file_is_qtfi_err_file := FALSE;

    command_length := STRLENGTH (text);
    IF command_length <= 0 THEN
      RETURN; { No parameters }
    IFEND;

    PUSH ptr_upper_case_echo_text : [command_length];
    #translate (osv$lower_to_upper, text, ptr_upper_case_echo_text^);

{ Find and process LOGIN_FAMILY

    parameter_position := find_parameter_position (nfc$p29_login_family_parameter, ptr_upper_case_echo_text^);

    IF parameter_position > 0 THEN
      parameter_value_position := parameter_position + nfc$p29_login_family_param_len;
      parameter_value_length :=  find_delimiter_position (ptr_upper_case_echo_text^, parameter_value_position)
             - parameter_value_position;

{ check to see if login family is a valid length

      IF parameter_value_length <= osc$max_name_size THEN
        IF ptr_upper_case_echo_text^ (parameter_value_position, 1) IN valid_characters_for_name THEN
          valid_login_family := TRUE;
        /validate_chars_in_login_family/
          FOR echo_text_index := parameter_value_position TO (parameter_value_position +
                parameter_value_length - 1) DO
            IF NOT ((ptr_upper_case_echo_text^ (echo_text_index, 1) IN valid_characters_for_name) OR
                  (ptr_upper_case_echo_text^ (echo_text_index, 1) IN valid_number_for_name)) THEN
              valid_login_family := FALSE;
              EXIT /validate_chars_in_login_family/;
            IFEND;
          FOREND /validate_chars_in_login_family/;
          IF valid_login_family THEN
            login_family := ptr_upper_case_echo_text^ (parameter_value_position, parameter_value_length);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

{ Find and process DATA_MODE

    parameter_position := find_parameter_position (nfc$p29_data_mode_parameter, ptr_upper_case_echo_text^);

    IF parameter_position > 0 THEN
      parameter_value_position := parameter_position + nfc$p29_data_mode_param_length;
      parameter_value_length := find_delimiter_position (ptr_upper_case_echo_text^, parameter_value_position)
             - parameter_value_position;

      IF (parameter_value_length = nfc$p29_rhf_structured_length) AND (ptr_upper_case_echo_text^
            (parameter_value_position, parameter_value_length) = nfc$p29_rhf_structured_value) THEN
        data_mode := jmc$rhf_structure;
      IFEND;
    IFEND;

{ Find and process the QTFI_INFORMATION parameter.

    parameter_position := find_parameter_position (nfc$p29_qtfi_info, ptr_upper_case_echo_text^);

    IF parameter_position > 0 THEN
      parameter_value_position := parameter_position + nfc$p29_qtfi_info_length;
      parameter_value_length := find_delimiter_position (ptr_upper_case_echo_text^, parameter_value_position)
             - parameter_value_position;

      IF parameter_value_length <= osc$max_name_size THEN
        IF ptr_upper_case_echo_text^ (parameter_value_position, parameter_value_length) =
            nfc$p29_qtfi_info_err_file THEN
          file_is_qtfi_err_file := TRUE;
        IFEND;
      IFEND;
    IFEND;
  PROCEND crack_job_echo_text;
?? TITLE := 'crack_output_login_command', EJECT ??

{ PURPOSE:
{   This procedure is called to convert a login command to output submission
{   options.  The procedure cracks the login command which exists in NOS/VE
{   implicit text.
{
{ NOTE:
{   The format of the QTFS LOGIN command is not the same as the standard NOS/VE
{   LOGIN command.  This command has a very limited number of parameters.

  PROCEDURE crack_output_login_command
    (    login_command: string ( * <= maximum_size_qtfs_scl_command);
     VAR return_attributes: nft$queue_submission_option;
     VAR status: ost$status);

{ PROCEDURE login_command_pdt(
{   user, u: name = $required
{   family_name, fn: name = $required
{   user_job_name, ujn: name = $optional
{   account, a: name = $optional
{   project, p: name = $optional)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
    recend := [
    [1,
    [89, 4, 26, 14, 11, 35, 319],
    clc$command, 10, 5, 2, 0, 0, 0, 0, ''], [
    ['A                              ',clc$abbreviation_entry, 4],
    ['ACCOUNT                        ',clc$nominal_entry, 4],
    ['FAMILY_NAME                    ',clc$nominal_entry, 2],
    ['FN                             ',clc$abbreviation_entry, 2],
    ['P                              ',clc$abbreviation_entry, 5],
    ['PROJECT                        ',clc$nominal_entry, 5],
    ['U                              ',clc$abbreviation_entry, 1],
    ['UJN                            ',clc$abbreviation_entry, 3],
    ['USER                           ',clc$nominal_entry, 1],
    ['USER_JOB_NAME                  ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 5
    [[1, 0, clc$name_type], [1, osc$max_name_size]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$user = 1,
      p$family_name = 2,
      p$user_job_name = 3,
      p$account = 4,
      p$project = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      command_line_size_ptr: ^clt$command_line_size,
      ignore_status: ost$status,
      length_parameter_list: integer,
      login_command_ptr: ^string ( * <= maximum_size_qtfs_scl_command),
      scl_parameter_list_ptr: ^clt$parameter_list;

    status.normal := TRUE;

    clp$push_parameters (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    length_parameter_list := STRLENGTH (login_command);
    PUSH scl_parameter_list_ptr: [[REP (length_parameter_list + #SIZE (clt$command_line_size)) OF cell]];
    RESET scl_parameter_list_ptr;
    NEXT command_line_size_ptr IN scl_parameter_list_ptr;
    command_line_size_ptr^ := length_parameter_list;
    NEXT login_command_ptr: [length_parameter_list] IN scl_parameter_list_ptr;
    login_command_ptr^ := login_command;
    RESET scl_parameter_list_ptr;

    clp$evaluate_parameters (scl_parameter_list_ptr^, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      clp$pop_parameters (ignore_status);
      RETURN;
    IFEND;

{ Get USER name parameter

    return_attributes.output_submission_option [nfc$oqa_control_user].key := jmc$control_user;
    return_attributes.output_submission_option [nfc$oqa_control_user].control_user :=
          pvt [p$user].value^.name_value;

{ Get FAMILY_NAME parameter

    return_attributes.output_submission_option [nfc$oqa_control_family].key := jmc$control_family;
    return_attributes.output_submission_option [nfc$oqa_control_family].control_family :=
          pvt [p$family_name].value^.name_value;

{ If specified get USER_JOB_NAME

    IF pvt [p$user_job_name].specified THEN
      return_attributes.output_submission_option [nfc$oqa_user_job_name].key := jmc$user_job_name;
      return_attributes.output_submission_option [nfc$oqa_user_job_name].user_job_name :=
            pvt [p$user_job_name].value^.name_value;
    IFEND;

{ If specified get ACCOUNT parameter

    IF pvt [p$account].specified THEN
      return_attributes.output_submission_option [nfc$oqa_login_account].key := jmc$login_account;
      return_attributes.output_submission_option [nfc$oqa_login_account].login_account :=
            pvt [p$account].value^.name_value;
    IFEND;

{ If specified get PROJECT parameter

    IF pvt [p$project].specified THEN
      return_attributes.output_submission_option [nfc$oqa_login_project].key := jmc$login_project;
      return_attributes.output_submission_option [nfc$oqa_login_project].login_project :=
            pvt [p$project].value^.name_value;
    IFEND;

    clp$pop_parameters (ignore_status);

  PROCEND crack_output_login_command;
?? TITLE := 'crack_print_file_command', EJECT ??

{ PURPOSE:
{   This procedure will crack the remote_host_direcitve for the print_file command.

  PROCEDURE crack_print_file_command
    (    command: string ( * );
     VAR return_attributes: nft$queue_submission_option;
     VAR queue_file_page_width: amt$page_width;
     VAR status: ost$status);

    VAR
      parameter_list_position: integer;

    status.normal := TRUE;

    find_position_parameter_list (command, 'PRIF', parameter_list_position, status);
    IF NOT status.normal THEN
      find_position_parameter_list (command, 'PRINT_FILE', parameter_list_position, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    crack_print_file_parameters (command (parameter_list_position, * ), return_attributes,
          queue_file_page_width, status);

  PROCEND crack_print_file_command;
?? TITLE := 'crack_print_file_parameters', EJECT ??

{ PURPOSE:
{   This procedure will crack the print_file command parameters from
{   the remote_host_directive.
{
{ NOTE:
{   The QTFS print_file command is different than the standard NOS/VE
{   print_file command in that all of the parameters are optional.
{   Therefore, the remote_host_directive will not override any output
{   attribute unless it is explicitly specified.  Also, the FILE parameter
{   is ignored during the processing of this command.  Last of all, there
{   is an additional parameter 'DISPOSITION_CODE' that is not on the
{   the standard NOS/VE print_file command.

  PROCEDURE crack_print_file_parameters
    (    parameters: string ( * );
     VAR return_attributes: nft$queue_submission_option;
     VAR queue_file_page_width: amt$page_width;
     VAR status: ost$status);

{ PROCEDURE print_file_pdt (
{   file, f: file = $optional
{   comment_banner, cb: string 0..jmc$output_comment_banner_size = $optional
{   copies, c: integer 1..jmc$output_copy_count_max = $optional
{   data_mode, dm: key
{       (coded, c)
{       (transparent, t)
{     keyend = $optional
{   device, d: any of
{       key
{         automatic
{       keyend
{       name
{     anyend = $optional
{   disposition_code, dc: key
{       lp, cp, p8, pb, sp, wt, tt
{     keyend = $optional
{   earliest_print_time, ept: any of
{       key
{         none
{       keyend
{       date_time
{     anyend = $optional
{   external_characteristics, ec: any of
{       key
{         normal
{       keyend
{       string 0..jmc$ext_characteristics_size
{     anyend = $optional
{   forms_code, fc: any of
{       key
{         normal
{       keyend
{       string 0..jmc$forms_code_size
{     anyend = $optional
{   latest_print_time, lpt: any of
{       key
{         none
{       keyend
{       date_time
{     anyend = $optional
{   operator_family, destination_family, df, of: name = $optional
{   operator_user, so, station_operator, ou: name = $optional
{   output_class, oc: key
{       normal
{     keyend = $optional
{   output_deferred_by_user, odbu: boolean = $optional
{   output_destination, ode: any of
{       name
{       string 0..osc$max_name_size
{     anyend = $optional
{   output_destination_usage, destination_usage, du, odu: any of
{       key
{         dual_state, ntf, private, public, qtf
{       keyend
{       name
{     anyend = $optional
{   output_priority, op: key
{       low, medium, high
{     keyend = $optional
{   page_width, pw: integer 10..255 = $optional
{   purge_delay, pd: any of
{       key
{         none
{       keyend
{       time_increment
{     anyend = $optional
{   remote_host_directive, dsrp, dual_state_route_parameters, rhd: string ..
{     0..jmc$remote_host_directive_size = $optional
{   routing_banner, rb: string 0..jmc$output_routing_banner_size = $optional
{   station, s: any of
{       key
{         automatic
{       keyend
{       name
{     anyend = $optional
{   user_file_name, user_file_names, ufn: name = $optional
{   user_information, ui: string 0..jmc$user_information_size = $optional
{   vertical_print_density, vpd: key
{       six, eight, none, file
{     keyend = $optional
{   vfu_load_procedure, vlp: any of
{       key
{         none
{       keyend
{       name
{     anyend = $optional
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 61] of clt$pdt_parameter_name,
      parameters: array [1 .. 26] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type5: 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$name_type_qualifier,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 7] of clt$keyword_specification,
      recend,
      type7: 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$date_time_type_qualifier,
        recend,
      recend,
      type8: 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$string_type_qualifier,
        recend,
      recend,
      type9: 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$string_type_qualifier,
        recend,
      recend,
      type10: 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$date_time_type_qualifier,
        recend,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type13: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 1] of clt$keyword_specification,
      recend,
      type14: record
        header: clt$type_specification_header,
      recend,
      type15: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type16: 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 .. 5] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type17: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      type18: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type19: 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,
        recend,
      recend,
      type20: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type21: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type22: 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$name_type_qualifier,
        recend,
      recend,
      type23: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type24: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type25: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type26: 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$name_type_qualifier,
        recend,
      recend,
    recend := [
    [1,
    [92, 10, 7, 14, 10, 17, 694],
    clc$command, 61, 26, 0, 0, 0, 0, 0, ''], [
    ['C                              ',clc$abbreviation_entry, 3],
    ['CB                             ',clc$abbreviation_entry, 2],
    ['COMMENT_BANNER                 ',clc$nominal_entry, 2],
    ['COPIES                         ',clc$nominal_entry, 3],
    ['D                              ',clc$abbreviation_entry, 5],
    ['DATA_MODE                      ',clc$nominal_entry, 4],
    ['DC                             ',clc$abbreviation_entry, 6],
    ['DESTINATION_FAMILY             ',clc$alias_entry, 11],
    ['DESTINATION_USAGE              ',clc$alias_entry, 16],
    ['DEVICE                         ',clc$nominal_entry, 5],
    ['DF                             ',clc$alias_entry, 11],
    ['DISPOSITION_CODE               ',clc$nominal_entry, 6],
    ['DM                             ',clc$abbreviation_entry, 4],
    ['DSRP                           ',clc$alias_entry, 20],
    ['DU                             ',clc$alias_entry, 16],
    ['DUAL_STATE_ROUTE_PARAMETERS    ',clc$alias_entry, 20],
    ['EARLIEST_PRINT_TIME            ',clc$nominal_entry, 7],
    ['EC                             ',clc$abbreviation_entry, 8],
    ['EPT                            ',clc$abbreviation_entry, 7],
    ['EXTERNAL_CHARACTERISTICS       ',clc$nominal_entry, 8],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FC                             ',clc$abbreviation_entry, 9],
    ['FILE                           ',clc$nominal_entry, 1],
    ['FORMS_CODE                     ',clc$nominal_entry, 9],
    ['LATEST_PRINT_TIME              ',clc$nominal_entry, 10],
    ['LPT                            ',clc$abbreviation_entry, 10],
    ['OC                             ',clc$abbreviation_entry, 13],
    ['ODBU                           ',clc$abbreviation_entry, 14],
    ['ODE                            ',clc$abbreviation_entry, 15],
    ['ODU                            ',clc$abbreviation_entry, 16],
    ['OF                             ',clc$abbreviation_entry, 11],
    ['OP                             ',clc$abbreviation_entry, 17],
    ['OPERATOR_FAMILY                ',clc$nominal_entry, 11],
    ['OPERATOR_USER                  ',clc$nominal_entry, 12],
    ['OU                             ',clc$abbreviation_entry, 12],
    ['OUTPUT_CLASS                   ',clc$nominal_entry, 13],
    ['OUTPUT_DEFERRED_BY_USER        ',clc$nominal_entry, 14],
    ['OUTPUT_DESTINATION             ',clc$nominal_entry, 15],
    ['OUTPUT_DESTINATION_USAGE       ',clc$nominal_entry, 16],
    ['OUTPUT_PRIORITY                ',clc$nominal_entry, 17],
    ['PAGE_WIDTH                     ',clc$nominal_entry, 18],
    ['PD                             ',clc$abbreviation_entry, 19],
    ['PURGE_DELAY                    ',clc$nominal_entry, 19],
    ['PW                             ',clc$abbreviation_entry, 18],
    ['RB                             ',clc$abbreviation_entry, 21],
    ['REMOTE_HOST_DIRECTIVE          ',clc$nominal_entry, 20],
    ['RHD                            ',clc$abbreviation_entry, 20],
    ['ROUTING_BANNER                 ',clc$nominal_entry, 21],
    ['S                              ',clc$abbreviation_entry, 22],
    ['SO                             ',clc$alias_entry, 12],
    ['STATION                        ',clc$nominal_entry, 22],
    ['STATION_OPERATOR               ',clc$alias_entry, 12],
    ['UFN                            ',clc$abbreviation_entry, 23],
    ['UI                             ',clc$abbreviation_entry, 24],
    ['USER_FILE_NAME                 ',clc$nominal_entry, 23],
    ['USER_FILE_NAMES                ',clc$alias_entry, 23],
    ['USER_INFORMATION               ',clc$nominal_entry, 24],
    ['VERTICAL_PRINT_DENSITY         ',clc$nominal_entry, 25],
    ['VFU_LOAD_PROCEDURE             ',clc$nominal_entry, 26],
    ['VLP                            ',clc$abbreviation_entry, 26],
    ['VPD                            ',clc$abbreviation_entry, 25]],
    [
{ PARAMETER 1
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 266,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 8
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 72, clc$optional_parameter,
  0, 0],
{ PARAMETER 9
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 72, clc$optional_parameter,
  0, 0],
{ PARAMETER 10
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 11
    [33, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 12
    [34, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 13
    [36, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 44, clc$optional_parameter,
  0, 0],
{ PARAMETER 14
    [37, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 15
    [38, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 33, clc$optional_parameter,
  0, 0],
{ PARAMETER 16
    [39, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 217,
  clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [40, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_parameter, 0, 0],
{ PARAMETER 18
    [41, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 19
    [43, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 67, clc$optional_parameter,
  0, 0],
{ PARAMETER 20
    [46, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 21
    [48, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 22
    [51, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 23
    [55, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 24
    [57, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 25
    [58, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 26
    [59, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [0, jmc$output_comment_banner_size, FALSE]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, jmc$output_copy_count_max, 10]],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [4], [
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CODED                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TRANSPARENT                    ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['AUTOMATIC                      ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [7], [
    ['CP                             ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['LP                             ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['P8                             ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['PB                             ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['SP                             ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['TT                             ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['WT                             ', clc$nominal_entry, clc$normal_usage_entry, 6]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$date_time_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [
  clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$string_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NORMAL                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [0, jmc$ext_characteristics_size, FALSE]]
    ],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$string_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NORMAL                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [0, jmc$forms_code_size, FALSE]]
    ],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$date_time_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [
  clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 11
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 12
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 13
    [[1, 0, clc$keyword_type], [1], [
    ['NORMAL                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 14
    [[1, 0, clc$boolean_type]],
{ PARAMETER 15
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    8, [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]]
    ],
{ PARAMETER 16
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    192, [[1, 0, clc$keyword_type], [5], [
      ['DUAL_STATE                     ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['NTF                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['PRIVATE                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['PUBLIC                         ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['QTF                            ', clc$nominal_entry, clc$normal_usage_entry, 5]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 17
    [[1, 0, clc$keyword_type], [3], [
    ['HIGH                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['LOW                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['MEDIUM                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 18
    [[1, 0, clc$integer_type], [10, 255, 10]],
{ PARAMETER 19
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$time_increment_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$time_increment_type]]
    ],
{ PARAMETER 20
    [[1, 0, clc$string_type], [0, jmc$remote_host_directive_size, FALSE]],
{ PARAMETER 21
    [[1, 0, clc$string_type], [0, jmc$output_routing_banner_size, FALSE]],
{ PARAMETER 22
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['AUTOMATIC                      ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 23
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 24
    [[1, 0, clc$string_type], [0, jmc$user_information_size, FALSE]],
{ PARAMETER 25
    [[1, 0, clc$keyword_type], [4], [
    ['EIGHT                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['FILE                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['SIX                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 26
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$comment_banner = 2,
      p$copies = 3,
      p$data_mode = 4,
      p$device = 5,
      p$disposition_code = 6,
      p$earliest_print_time = 7,
      p$external_characteristics = 8,
      p$forms_code = 9,
      p$latest_print_time = 10,
      p$operator_family = 11,
      p$operator_user = 12,
      p$output_class = 13,
      p$output_deferred_by_user = 14,
      p$output_destination = 15,
      p$output_destination_usage = 16,
      p$output_priority = 17,
      p$page_width = 18,
      p$purge_delay = 19,
      p$remote_host_directive = 20,
      p$routing_banner = 21,
      p$station = 22,
      p$user_file_name = 23,
      p$user_information = 24,
      p$vertical_print_density = 25,
      p$vfu_load_procedure = 26;

    VAR
      pvt: array [1 .. 26] of clt$parameter_value;

    VAR
      command_length: integer,
      command_line_size_ptr: ^clt$command_line_size,
      ignore_status: ost$status,
      prif_command_ptr: ^string ( * ),
      scl_parameter_list_ptr: ^clt$parameter_list;

    status.normal := TRUE;
    command_length := STRLENGTH (parameters);
    IF command_length <= 0 THEN
      RETURN; { No parameters }
    IFEND;

    clp$push_parameters (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH scl_parameter_list_ptr: [[REP (command_length + #SIZE (clt$command_line_size)) OF cell]];
    RESET scl_parameter_list_ptr;
    NEXT command_line_size_ptr IN scl_parameter_list_ptr;
    command_line_size_ptr^ := command_length;
    NEXT prif_command_ptr: [command_length] IN scl_parameter_list_ptr;
    prif_command_ptr^ := parameters;
    RESET scl_parameter_list_ptr;

    clp$evaluate_parameters (scl_parameter_list_ptr^, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      clp$pop_parameters (ignore_status);
      RETURN;
    IFEND;

{ The FILE parameter is ignored.
{ If specified process COMMENT_BANNER parameter.

    IF pvt [p$comment_banner].specified THEN
      return_attributes.output_submission_option [nfc$oqa_comment_banner].key := jmc$comment_banner;
      return_attributes.output_submission_option [nfc$oqa_comment_banner].comment_banner :=
            pvt [p$comment_banner].value^.string_value^;
    IFEND;

{ If specified process COPIES parameter.

    IF pvt [p$copies].specified THEN
      return_attributes.output_submission_option [nfc$oqa_copies].key := jmc$copies;
      return_attributes.output_submission_option [nfc$oqa_copies].copies :=
            pvt [p$copies].value^.integer_value.value;
    IFEND;

{ If specified process DATA_MODE parameter.

    IF pvt [p$data_mode].specified THEN
      return_attributes.output_submission_option [nfc$oqa_data_mode].key := jmc$data_mode;
      IF pvt [p$data_mode].value^.keyword_value = 'CODED' THEN
        return_attributes.output_submission_option [nfc$oqa_data_mode].data_mode := jmc$coded_data;
      ELSE { pvt [p$data_mode].value^.keyword_value = 'TRANSPARENT'.
        return_attributes.output_submission_option [nfc$oqa_data_mode].data_mode := jmc$transparent_data;
      IFEND;
    IFEND;

{ If specified process DEVICE parameter.

    IF pvt [p$device].specified THEN
      return_attributes.output_submission_option [nfc$oqa_device].key := jmc$device;
      IF pvt [p$device].value^.kind = clc$name THEN
        return_attributes.output_submission_option [nfc$oqa_device].device := pvt [p$device].value^
              .name_value;
      ELSE
        return_attributes.output_submission_option [nfc$oqa_device].device :=
              pvt [p$device].value^.keyword_value;
      IFEND;
    IFEND;

{ Get DISPOSITION_CODE if it was specified

    IF pvt [p$disposition_code].specified THEN
      return_attributes.output_submission_option [nfc$oqa_disposition_code].key := jmc$disposition_code;
      return_attributes.output_submission_option [nfc$oqa_disposition_code].disposition_code :=
            pvt [p$disposition_code].value^.keyword_value;
    IFEND;

{ If specified process EARLIEST_PRINT_TIME parameter.

    IF pvt [p$earliest_print_time].specified THEN
      return_attributes.output_submission_option [nfc$oqa_earliest_print_time].key := jmc$earliest_print_time;
      IF pvt [p$earliest_print_time].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        return_attributes.output_submission_option [nfc$oqa_earliest_print_time].earliest_print_time.specified
              := FALSE;
      ELSE
        return_attributes.output_submission_option [nfc$oqa_earliest_print_time].earliest_print_time.specified
              := TRUE;
        return_attributes.output_submission_option [nfc$oqa_earliest_print_time].
              earliest_print_time.date_time := pvt [p$earliest_print_time].value^.date_time_value.value;
      IFEND;
    IFEND;

{ If specified process EXTERNAL_CHARACTERISTICS parameter.

    IF pvt [p$external_characteristics].specified THEN
      return_attributes.output_submission_option [nfc$oqa_external_characteristic].key :=
            jmc$external_characteristics;
      IF pvt [p$external_characteristics].value^.kind = clc$keyword THEN { the only keyword is NORMAL. }
        return_attributes.output_submission_option [nfc$oqa_external_characteristic].
              external_characteristics := pvt [p$external_characteristics].value^.keyword_value;
      ELSE
        return_attributes.output_submission_option [nfc$oqa_external_characteristic].
              external_characteristics := pvt [p$external_characteristics].value^.string_value^;
      IFEND;
    IFEND;

{ If specified process FORMS_CODE parameter.

    IF pvt [p$forms_code].specified THEN
      return_attributes.output_submission_option [nfc$oqa_forms_code].key := jmc$forms_code;
      IF pvt [p$forms_code].value^.kind = clc$keyword THEN { the only keyword allowed is NORMAL. }
        return_attributes.output_submission_option [nfc$oqa_forms_code].forms_code := pvt [p$forms_code].
              value^.keyword_value;
      ELSE
        return_attributes.output_submission_option [nfc$oqa_forms_code].forms_code := pvt [p$forms_code].
              value^.string_value^;
      IFEND;
    IFEND;

{ If specified process LATEST_PRINT_TIME parameter.

    IF pvt [p$latest_print_time].specified THEN
      return_attributes.output_submission_option [nfc$oqa_latest_print_time].key := jmc$latest_print_time;
      IF pvt [p$latest_print_time].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        return_attributes.output_submission_option [nfc$oqa_latest_print_time].latest_print_time.specified :=
              FALSE;
      ELSE
        return_attributes.output_submission_option [nfc$oqa_latest_print_time].latest_print_time.specified :=
              TRUE;
        return_attributes.output_submission_option [nfc$oqa_latest_print_time].
              latest_print_time.date_time := pvt [p$latest_print_time].value^.date_time_value.value;
      IFEND;
    IFEND;

{ If specified process OPERATOR_FAMILY parameter.

    IF pvt [p$operator_family].specified THEN
      return_attributes.output_submission_option [nfc$oqa_operator_family].key :=
            jmc$output_destination_family;
      return_attributes.output_submission_option [nfc$oqa_operator_family].output_destination_family :=
            pvt [p$operator_family].value^.name_value;
    IFEND;

{ If specified process OPERATOR_USER parameter.

    IF pvt [p$operator_user].specified THEN
      return_attributes.output_submission_option [nfc$oqa_operator_user].key := jmc$station_operator;
      return_attributes.output_submission_option [nfc$oqa_operator_user].station_operator :=
            pvt [p$operator_user].value^.name_value;
    IFEND;

{ If specified process OUTPUT_CLASS parameter.

    IF pvt [p$output_class].specified THEN
      return_attributes.output_submission_option [nfc$oqa_output_class].key := jmc$output_class;
      return_attributes.output_submission_option [nfc$oqa_output_class].output_class :=
            pvt [p$output_class].value^.keyword_value;
    IFEND;

{ If specified process OUTPUT_DEFERRED_BY_USER parameter.

    IF pvt [p$output_deferred_by_user].specified THEN
      return_attributes.output_submission_option [nfc$oqa_output_deferred_by_user].key :=
            jmc$output_deferred_by_user;
      return_attributes.output_submission_option [nfc$oqa_output_deferred_by_user].output_deferred_by_user :=
            pvt [p$output_deferred_by_user].value^.boolean_value.value;
    IFEND;

{ If specified process OUTPUT_DESTINATION parameter.

    IF pvt [p$output_destination].specified THEN
      return_attributes.output_submission_option [nfc$oqa_output_destination].key := jmc$output_destination;
      IF pvt [p$output_destination].value^.kind = clc$name THEN
        return_attributes.output_submission_option [nfc$oqa_output_destination].output_destination :=
              pvt [p$output_destination].value^.name_value;
      ELSE
        return_attributes.output_submission_option [nfc$oqa_output_destination].output_destination :=
              pvt [p$output_destination].value^.string_value^;
      IFEND;
    IFEND;

{ If specified process OUTPUT_DESTINATION_USAGE parameter.

    IF pvt [p$output_destination_usage].specified THEN
      return_attributes.output_submission_option [nfc$oqa_output_dest_usage].key :=
            jmc$output_destination_usage;
      IF pvt [p$output_destination_usage].value^.kind = clc$name THEN
        return_attributes.output_submission_option [nfc$oqa_output_dest_usage].
              output_destination_usage := pvt [p$output_destination_usage].value^.name_value;
      ELSE
        return_attributes.output_submission_option [nfc$oqa_output_dest_usage].
              output_destination_usage := pvt [p$output_destination_usage].value^.keyword_value;
      IFEND;
    IFEND;

{ If specified process OUTPUT_PRIORITY parameter.

    IF pvt [p$output_priority].specified THEN
      return_attributes.output_submission_option [nfc$oqa_output_priority].key := jmc$output_priority;
      return_attributes.output_submission_option [nfc$oqa_output_priority].output_priority :=
            pvt [p$output_priority].value^.keyword_value;
    IFEND;

{ If specified process PAGE_WIDTH  parameter.

    IF pvt [p$page_width].specified THEN
      queue_file_page_width := pvt [p$page_width].value^.integer_value.value;
    IFEND;

{ If specified process PURGE_DELAY parameter.

    IF pvt [p$purge_delay].specified THEN
      IF pvt [p$purge_delay].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        output_purge_delay.specified := FALSE;
      ELSE
        output_purge_delay.specified := TRUE;
        output_purge_delay.time_increment := pvt [p$purge_delay].value^.time_increment_value^;
      IFEND;
      return_attributes.output_submission_option [nfc$oqa_purge_delay].key := jmc$purge_delay;
      return_attributes.output_submission_option [nfc$oqa_purge_delay].purge_delay := ^output_purge_delay;
    IFEND;

{ If specified process REMOTE_HOST_DIRECTIVE parameter.

    IF pvt [p$remote_host_directive].specified THEN
      output_remote_host_directive.size := STRLENGTH (pvt [p$remote_host_directive].value^.string_value^);
      output_remote_host_directive.parameters := pvt [p$remote_host_directive].value^.string_value^;
      return_attributes.output_submission_option [nfc$oqa_remote_host_directive].key :=
            jmc$remote_host_directive;
      return_attributes.output_submission_option [nfc$oqa_remote_host_directive].remote_host_directive :=
            ^output_remote_host_directive;
    IFEND;

{ If specified process ROUTING_BANNER parameter.

    IF pvt [p$routing_banner].specified THEN
      return_attributes.output_submission_option [nfc$oqa_routing_banner].key := jmc$routing_banner;
      return_attributes.output_submission_option [nfc$oqa_routing_banner].routing_banner :=
            pvt [p$routing_banner].value^.string_value^;
    IFEND;

{ If specified process STATION parameter.

    IF pvt [p$station].specified THEN
      return_attributes.output_submission_option [nfc$oqa_station].key := jmc$station;
      IF pvt [p$station].value^.kind = clc$keyword THEN
        return_attributes.output_submission_option [nfc$oqa_station].station :=
              pvt [p$station].value^.keyword_value;
      ELSE
        return_attributes.output_submission_option [nfc$oqa_station].station :=
              pvt [p$station].value^.name_value;
      IFEND;
    IFEND;

{ If specified process USER_FILE_NAME parameter.

    IF pvt [p$user_file_name].specified THEN
      return_attributes.output_submission_option [nfc$oqa_user_file_name].key := jmc$user_file_name;
      return_attributes.output_submission_option [nfc$oqa_user_file_name].user_file_name :=
            pvt [p$user_file_name].value^.name_value;
    IFEND;

{ If specified process USER_INFORMATION parameter.

    IF pvt [p$user_information].specified THEN
      output_user_information := pvt [p$user_information].value^.string_value^;
      return_attributes.output_submission_option [nfc$oqa_user_information].key := jmc$user_information;
      return_attributes.output_submission_option [nfc$oqa_user_information].user_information :=
            ^output_user_information;
    IFEND;

{ If specified process VERTICAL_PRINT_DENSITY parameter.

    IF pvt [p$vertical_print_density].specified THEN
      return_attributes.output_submission_option [nfc$oqa_vertical_print_density].key :=
            jmc$vertical_print_density;
      IF pvt [p$vertical_print_density].value^.keyword_value = 'FILE' THEN
        return_attributes.output_submission_option [nfc$oqa_vertical_print_density].vertical_print_density :=
              jmc$vertical_print_density_file;
      ELSEIF pvt [p$vertical_print_density].value^.keyword_value = 'NONE' THEN
        return_attributes.output_submission_option [nfc$oqa_vertical_print_density].vertical_print_density :=
              jmc$vertical_print_density_none;
      ELSEIF pvt [p$vertical_print_density].value^.keyword_value = 'SIX' THEN
        return_attributes.output_submission_option [nfc$oqa_vertical_print_density].vertical_print_density :=
              jmc$vertical_print_density_6;
      ELSE { pvt [p$vertical_print_density].value^.keyword_value = 'EIGHT'
        return_attributes.output_submission_option [nfc$oqa_vertical_print_density].vertical_print_density :=
              jmc$vertical_print_density_8;
      IFEND;
    IFEND;

{ If specified process VFU_LOAD_PROCEDURE parameter.

    IF pvt [p$vfu_load_procedure].specified THEN
      return_attributes.output_submission_option [nfc$oqa_vfu_load_procedure].key := jmc$vfu_load_procedure;
      IF pvt [p$vfu_load_procedure].value^.kind = clc$keyword THEN
        return_attributes.output_submission_option [nfc$oqa_vfu_load_procedure].vfu_load_procedure :=
              osc$null_name;
      ELSE
        return_attributes.output_submission_option [nfc$oqa_vfu_load_procedure].vfu_load_procedure :=
              pvt [p$vfu_load_procedure].value^.name_value;
      IFEND;
    IFEND;

    clp$pop_parameters (ignore_status);

  PROCEND crack_print_file_parameters;
?? TITLE := 'crack_submit_job_command', EJECT ??

{ PURPOSE:
{   This procedure will crack the QTFS submit_job command.
{
{ NOTE:
{   The QTFS submit_job command is different from the standard NOS/VE
{   submit_job command in that all of the parameters are optional.
{   Therefore, the remote_host_directive will not override any job
{   attribute unless it is explicitly specified.

  PROCEDURE crack_submit_job_command
    (    command: string ( * );
     VAR return_attributes: nft$queue_submission_option;
     VAR status: ost$status);

{ PROCEDURE submit_job_pdt (
{   file, f: file = $optional
{   cpu_time_limit, ctl: any of
{       key
{         system_default, unlimited, unspecified
{       keyend
{       integer jmc$lowest_cpu_time_limit..jmc$highest_cpu_time_limit
{     anyend = $optional
{   earliest_run_time, ert: any of
{       key
{         none
{       keyend
{       date_time
{     anyend = $optional
{   job_abort_disposition, jad: key
{       (restart, r)
{       (terminate, t)
{     keyend = $optional
{   job_class, jc: name = $optional
{   job_deferred_by_user, jdbu: boolean = $optional
{   job_destination, jd: any of
{       name
{       string 0..osc$max_name_size
{     anyend = $optional
{   job_destination_usage, jdu: any of
{       key
{         ntf, qtf, ve, ve_local, ve_qtf, ve_family
{       keyend
{       name
{     anyend = $optional
{   job_execution_ring, jer: integer osc$sj_ring_1..osc$user_ring_2 = $optional
{   job_qualifier, job_qualifiers, jq: any of
{       key
{         none, system_default
{       keyend
{       list 1..jmc$maximum_job_qualifiers of name
{     anyend = $optional
{   job_recovery_disposition, jrd: key
{       (continue, c)
{       (restart, r)
{       (terminate, t)
{     keyend = $optional
{   latest_run_time, lrt: any of
{       key
{         none
{       keyend
{       date_time
{     anyend = $optional
{   login_family, family_name, fn, lf: name = $optional
{   magnetic_tape_limit, mtl: any of
{       key
{         system_default, unlimited, unspecified
{       keyend
{       integer jmc$lowest_magnetic_tape_limit..jmc$highest_magnetic_tape_limit
{     anyend = $optional
{   maximum_working_set, maxws: any of
{       key
{         system_default, unlimited, unspecified
{       keyend
{       integer jmc$lowest_working_set_size..jmc$highest_working_set_size
{     anyend = $optional
{   operator_family, of: name = $optional
{   operator_user, ou: name = $optional
{   output_disposition, so, standard_output, odi: any of
{       key
{         (discard_all_output, dao)
{         (discard_standard_output, dso)
{         (local, l)
{         (printer, p)
{         (wait_queue, wt, wq)
{       keyend
{       file
{     anyend = $optional
{   remote_host_directive, rhd: string 0..jmc$remote_host_directive_size = $optional
{   sru_limit, sl: any of
{       key
{         system_default, unlimited, unspecified
{       keyend
{       integer jmc$lowest_sru_limit..jmc$highest_sru_limit
{     anyend = $optional
{   station, s: any of
{       key
{         automatic
{       keyend
{       name
{     anyend = $optional
{   user_information, ui: string 0..jmc$user_information_size = $optional
{   user_job_name, jn, job_name, ujn: name = $optional)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 53] of clt$pdt_parameter_name,
      parameters: array [1 .. 23] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type3: 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$date_time_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
      type7: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type8: 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 .. 6] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type10: 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 .. 2] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type12: 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$date_time_type_qualifier,
        recend,
      recend,
      type13: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type14: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type15: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type17: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type18: 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 .. 11] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type19: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type20: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type21: 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$name_type_qualifier,
        recend,
      recend,
      type22: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type23: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
    recend := [
    [1,
    [89, 7, 11, 9, 57, 18, 975],
    clc$command, 53, 23, 0, 0, 0, 0, 0, ''], [
    ['CPU_TIME_LIMIT                 ',clc$nominal_entry, 2],
    ['CTL                            ',clc$abbreviation_entry, 2],
    ['EARLIEST_RUN_TIME              ',clc$nominal_entry, 3],
    ['ERT                            ',clc$abbreviation_entry, 3],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FAMILY_NAME                    ',clc$alias_entry, 13],
    ['FILE                           ',clc$nominal_entry, 1],
    ['FN                             ',clc$alias_entry, 13],
    ['JAD                            ',clc$abbreviation_entry, 4],
    ['JC                             ',clc$abbreviation_entry, 5],
    ['JD                             ',clc$abbreviation_entry, 7],
    ['JDBU                           ',clc$abbreviation_entry, 6],
    ['JDU                            ',clc$abbreviation_entry, 8],
    ['JER                            ',clc$abbreviation_entry, 9],
    ['JN                             ',clc$alias_entry, 23],
    ['JOB_ABORT_DISPOSITION          ',clc$nominal_entry, 4],
    ['JOB_CLASS                      ',clc$nominal_entry, 5],
    ['JOB_DEFERRED_BY_USER           ',clc$nominal_entry, 6],
    ['JOB_DESTINATION                ',clc$nominal_entry, 7],
    ['JOB_DESTINATION_USAGE          ',clc$nominal_entry, 8],
    ['JOB_EXECUTION_RING             ',clc$nominal_entry, 9],
    ['JOB_NAME                       ',clc$alias_entry, 23],
    ['JOB_QUALIFIER                  ',clc$nominal_entry, 10],
    ['JOB_QUALIFIERS                 ',clc$alias_entry, 10],
    ['JOB_RECOVERY_DISPOSITION       ',clc$nominal_entry, 11],
    ['JQ                             ',clc$abbreviation_entry, 10],
    ['JRD                            ',clc$abbreviation_entry, 11],
    ['LATEST_RUN_TIME                ',clc$nominal_entry, 12],
    ['LF                             ',clc$abbreviation_entry, 13],
    ['LOGIN_FAMILY                   ',clc$nominal_entry, 13],
    ['LRT                            ',clc$abbreviation_entry, 12],
    ['MAGNETIC_TAPE_LIMIT            ',clc$nominal_entry, 14],
    ['MAXIMUM_WORKING_SET            ',clc$nominal_entry, 15],
    ['MAXWS                          ',clc$abbreviation_entry, 15],
    ['MTL                            ',clc$abbreviation_entry, 14],
    ['ODI                            ',clc$abbreviation_entry, 18],
    ['OF                             ',clc$abbreviation_entry, 16],
    ['OPERATOR_FAMILY                ',clc$nominal_entry, 16],
    ['OPERATOR_USER                  ',clc$nominal_entry, 17],
    ['OU                             ',clc$abbreviation_entry, 17],
    ['OUTPUT_DISPOSITION             ',clc$nominal_entry, 18],
    ['REMOTE_HOST_DIRECTIVE          ',clc$nominal_entry, 19],
    ['RHD                            ',clc$abbreviation_entry, 19],
    ['S                              ',clc$abbreviation_entry, 21],
    ['SL                             ',clc$abbreviation_entry, 20],
    ['SO                             ',clc$alias_entry, 18],
    ['SRU_LIMIT                      ',clc$nominal_entry, 20],
    ['STANDARD_OUTPUT                ',clc$alias_entry, 18],
    ['STATION                        ',clc$nominal_entry, 21],
    ['UI                             ',clc$abbreviation_entry, 22],
    ['UJN                            ',clc$abbreviation_entry, 23],
    ['USER_INFORMATION               ',clc$nominal_entry, 22],
    ['USER_JOB_NAME                  ',clc$nominal_entry, 23]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 158,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 6
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 7
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 33, clc$optional_parameter,
  0, 0],
{ PARAMETER 8
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 254,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 10
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 122,
  clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [28, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 13
    [30, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 14
    [32, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 158,
  clc$optional_parameter, 0, 0],
{ PARAMETER 15
    [33, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 158,
  clc$optional_parameter, 0, 0],
{ PARAMETER 16
    [38, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 17
    [39, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 18
    [41, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 437,
  clc$optional_parameter, 0, 0],
{ PARAMETER 19
    [42, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 20
    [47, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 158,
  clc$optional_parameter, 0, 0],
{ PARAMETER 21
    [49, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69, clc$optional_parameter,
  0, 0],
{ PARAMETER 22
    [52, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 23
    [53, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_cpu_time_limit, jmc$highest_cpu_time_limit, 10]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$date_time_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [
  clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [4], [
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['RESTART                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 5
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 6
    [[1, 0, clc$boolean_type]],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    8, [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]]
    ],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    229, [[1, 0, clc$keyword_type], [6], [
      ['NTF                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['QTF                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['VE                             ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['VE_FAMILY                      ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['VE_LOCAL                       ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['VE_QTF                         ', clc$nominal_entry, clc$normal_usage_entry, 5]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 9
    [[1, 0, clc$integer_type], [osc$sj_ring_1, osc$user_ring_2, 10]],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, jmc$maximum_job_qualifiers, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 11
    [[1, 0, clc$keyword_type], [6], [
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CONTINUE                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['RESTART                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['TERMINATE                      ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 12
    [[1, 0, clc$union_type], [[clc$date_time_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [
  clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 13
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 14
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_magnetic_tape_limit, jmc$highest_magnetic_tape_limit, 10]]
    ],
{ PARAMETER 15
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_working_set_size, jmc$highest_working_set_size, 10]]
    ],
{ PARAMETER 16
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 17
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 18
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    414, [[1, 0, clc$keyword_type], [11], [
      ['DAO                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['DISCARD_ALL_OUTPUT             ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['DISCARD_STANDARD_OUTPUT        ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['DSO                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['LOCAL                          ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['PRINTER                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['WAIT_QUEUE                     ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['WQ                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['WT                             ', clc$alias_entry, clc$normal_usage_entry, 5]]
      ],
    3, [[1, 0, clc$file_type]]
    ],
{ PARAMETER 19
    [[1, 0, clc$string_type], [0, jmc$remote_host_directive_size, FALSE]],
{ PARAMETER 20
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['SYSTEM_DEFAULT                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['UNLIMITED                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['UNSPECIFIED                    ', clc$nominal_entry, clc$normal_usage_entry, 3]]
      ],
    20, [[1, 0, clc$integer_type], [jmc$lowest_sru_limit, jmc$highest_sru_limit, 10]]
    ],
{ PARAMETER 21
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['AUTOMATIC                      ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 22
    [[1, 0, clc$string_type], [0, jmc$user_information_size, FALSE]],
{ PARAMETER 23
    [[1, 0, clc$name_type], [1, osc$max_name_size]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$cpu_time_limit = 2,
      p$earliest_run_time = 3,
      p$job_abort_disposition = 4,
      p$job_class = 5,
      p$job_deferred_by_user = 6,
      p$job_destination = 7,
      p$job_destination_usage = 8,
      p$job_execution_ring = 9,
      p$job_qualifier = 10,
      p$job_recovery_disposition = 11,
      p$latest_run_time = 12,
      p$login_family = 13,
      p$magnetic_tape_limit = 14,
      p$maximum_working_set = 15,
      p$operator_family = 16,
      p$operator_user = 17,
      p$output_disposition = 18,
      p$remote_host_directive = 19,
      p$sru_limit = 20,
      p$station = 21,
      p$user_information = 22,
      p$user_job_name = 23;

    VAR
      pvt: array [1 .. 23] of clt$parameter_value;

    VAR
      command_length: integer,
      command_line_size_ptr: ^clt$command_line_size,
      default_job_attributes_p: ^jmt$default_attribute_results,
      ignore_status: ost$status,
      job_qualifier_count: 0 .. clc$max_list_size,
      job_qualifier_index: 0 .. clc$max_list_size,
      job_qualifier_options: ^clt$data_value,
      parameter_list_position: integer,
      scl_parameter_list_ptr: ^clt$parameter_list,
      subj_command_ptr: ^string ( * );

?? NEWTITLE := 'change_implicit_text_wait_queue', EJECT ??

{ PURPOSE:
{   This procedure will modify a NOS/VE Implicit Routing Text to reflect the
{   OUTPUT_DISPOSITION as specified on the Remote Host Directive.  The only
{   changes that are allowed to occur are:
{     1.  If the Remote Host Directive has the parameter OUTPUT_DISPOSITION = WAIT_QUEUE,
{         then add or change the OD parameter to have a WQ value in the Implicit Routing Text.
{     2.  If the Remote Host Directive has the parameter OUTPUT_DISPOSITION = PRINTER,
{         then delete the OD=WQ parameter value from the Implicit Routing Text.
{
{ NOTE:
{   The disposition parameter is placed into a NOS/VE Implicit Routing Text by the
{   QTF Initiator as 'DC='.

    PROCEDURE change_implicit_text_wait_queue
      (    add_wait_queue_value: boolean);

      CONST
        disposition_code_parameter = 'DC=',
        disposition_code_param_length = 3,
        semicolon = ';';

      VAR
        disposition_code_index: ost$non_negative_integers,
        found_disposition_code: boolean,
        index: ost$non_negative_integers,
        temporary_implicit_text: jmt$implicit_routing_text;

      temporary_implicit_text := output_implicit_routing_text;

{ Only change implicit routing text generated by a NOS/VE system

      IF (temporary_implicit_text.size >= nfc$p33_nos_ve_text_id_length) AND
            (temporary_implicit_text.text (1, nfc$p33_nos_ve_text_id_length) =
            nfc$p33_nos_ve_text_identifier) THEN

        index := nfc$p33_nos_ve_text_id_length;

{ Position index past the system_supplied_job name in the implicit routing text

        REPEAT
          index := index + 1;
        UNTIL (index > temporary_implicit_text.size) OR (temporary_implicit_text.text (index, 1) =
              semicolon);

        index := index + 1;
        IF index <= temporary_implicit_text.size THEN

{ Position index past the login information of the originating job in the implicit routing text

          REPEAT
            index := index + 1;
          UNTIL (index > temporary_implicit_text.size) OR (temporary_implicit_text.text (index, 1) =
                semicolon);

          index := index + 1;
          IF index <= temporary_implicit_text.size THEN
            found_disposition_code := FALSE;

{ Check to see if the disposition_code parameter is in the implicit routing text

          /find_disposition_code/
            FOR disposition_code_index := index TO (temporary_implicit_text.size -
                  disposition_code_param_length) DO
              IF temporary_implicit_text.text (disposition_code_index, disposition_code_param_length) =
                    disposition_code_parameter THEN
                found_disposition_code := TRUE;
                EXIT /find_disposition_code/;
              IFEND;
            FOREND /find_disposition_code/;

            IF found_disposition_code THEN
              IF add_wait_queue_value THEN
                IF temporary_implicit_text.text ((disposition_code_index + disposition_code_param_length
                      + 1) , 2) <> nfc$p33_imp_wait_queue_value_wt THEN

{ change the DISPOSITION_CODE value to wait_queue in the implicit routing text

                  temporary_implicit_text.text ((disposition_code_index + disposition_code_param_length
                      + 1) , 2) := nfc$p33_imp_wait_queue_value_wt;

{ the DISPOSITION_CODE wait_queue value should be followed by a space

                  IF temporary_implicit_text.text ((disposition_code_index + disposition_code_param_length
                        + 2) , 1) <> ' ' THEN
                    temporary_implicit_text.text ((disposition_code_index + disposition_code_param_length
                        + 2) , 1) := ' ';
                  IFEND;
                IFEND;
              ELSE
                IF temporary_implicit_text.text ((disposition_code_index + disposition_code_param_length), 2)
                      = nfc$p33_imp_wait_queue_value_wt THEN

{ delete the DISPOSITION_CODE parameter and value of wait_queue from the implicit routing text

                  temporary_implicit_text.text (index, *) := output_implicit_routing_text.text
                        ((disposition_code_index + disposition_code_param_length + 3), *);
                  temporary_implicit_text.size := temporary_implicit_text.size - disposition_code_param_length
                    - 3;
                IFEND;
              IFEND;

{ Replace the global implicit routing text

              output_implicit_routing_text := temporary_implicit_text;
            ELSEIF add_wait_queue_value THEN

{ Add the DISPOSITION_CODE value of wait_queue to the implicit routing text

              temporary_implicit_text.text (index, *) := disposition_code_parameter;
              temporary_implicit_text.text ((index + disposition_code_param_length), *) :=
                    nfc$p33_imp_wait_queue_value_wt;
              temporary_implicit_text.text ((index + disposition_code_param_length + 2), *) := ' ';
              temporary_implicit_text.text ((index + disposition_code_param_length + 3), *) :=
                    output_implicit_routing_text.text (index, *);
              temporary_implicit_text.size := temporary_implicit_text.size + disposition_code_param_length
                    + 3;

{ If the new implicit text is too large, truncate the implicit routing text after the last valid parameter

              IF temporary_implicit_text.size > jmc$implicit_routing_text_size THEN
                index := jmc$implicit_routing_text_size;
                WHILE (index > 0) AND (temporary_implicit_text.text (index, 1) <> ' ') DO
                  index := index - 1;
                WHILEND;
                temporary_implicit_text.size := index;
                temporary_implicit_text.text (index, *) := ' ';
              IFEND;

{ Replace the global implicit routing text

              output_implicit_routing_text := temporary_implicit_text;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    PROCEND change_implicit_text_wait_queue;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    find_position_parameter_list (command, 'SUBJ', parameter_list_position, status);
    IF NOT status.normal THEN
      find_position_parameter_list (command, 'SUBMIT_JOB', parameter_list_position, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    command_length := STRLENGTH (command (parameter_list_position, * ));
    IF command_length <= 0 THEN
      RETURN; { No parameters }
    IFEND;

    clp$push_parameters (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH scl_parameter_list_ptr: [[REP (command_length + #SIZE (clt$command_line_size)) OF cell]];
    RESET scl_parameter_list_ptr;
    NEXT command_line_size_ptr IN scl_parameter_list_ptr;
    command_line_size_ptr^ := command_length;
    NEXT subj_command_ptr: [command_length] IN scl_parameter_list_ptr;
    subj_command_ptr^ := command (parameter_list_position, * );
    RESET scl_parameter_list_ptr;

    clp$evaluate_parameters (scl_parameter_list_ptr^, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      clp$pop_parameters (ignore_status);
      RETURN;
    IFEND;

{ The FILE parameter is ignored.
{ If specified process CPU_TIME_LIMIT parameter.

    IF pvt [p$cpu_time_limit].specified THEN
      return_attributes.job_submission_option [nfc$iqa_cpu_time_limit].key := jmc$cpu_time_limit;
      IF pvt [p$cpu_time_limit].value^.kind = clc$integer THEN
        return_attributes.job_submission_option [nfc$iqa_cpu_time_limit].cpu_time_limit :=
              pvt [p$cpu_time_limit].value^.integer_value.value;
      ELSE
        IF pvt [p$cpu_time_limit].value^.keyword_value = 'UNSPECIFIED' THEN
          return_attributes.job_submission_option [nfc$iqa_cpu_time_limit].cpu_time_limit :=
                jmc$unspecified_cpu_time_limit;
        ELSEIF pvt [p$cpu_time_limit].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
          return_attributes.job_submission_option [nfc$iqa_cpu_time_limit].cpu_time_limit :=
                jmc$system_default_cpu_time_lim;
        ELSE { pvt [p$cpu_time_limit].value^.keyword_value = 'UNLIMITED'.
          return_attributes.job_submission_option [nfc$iqa_cpu_time_limit].cpu_time_limit :=
                jmc$unlimited_cpu_time_limit;
        IFEND;
      IFEND;
    IFEND;

{ If specified process EARLIEST_RUN_TIME parameter.

    IF pvt [p$earliest_run_time].specified THEN
      return_attributes.job_submission_option [nfc$iqa_earliest_run_time].key := jmc$earliest_run_time;
      IF pvt [p$earliest_run_time].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        return_attributes.job_submission_option [nfc$iqa_earliest_run_time].earliest_run_time.specified :=
              FALSE;
      ELSE
        return_attributes.job_submission_option [nfc$iqa_earliest_run_time].earliest_run_time.specified :=
              TRUE;
        return_attributes.job_submission_option [nfc$iqa_earliest_run_time].earliest_run_time.date_time :=
              pvt [p$earliest_run_time].value^.date_time_value.value;
      IFEND;
    IFEND;

{ If specified process JOB_ABORT_DISPOSITION parameter.

    IF pvt [p$job_abort_disposition].specified THEN
      return_attributes.job_submission_option [nfc$iqa_job_abort_disposition].key :=
            jmc$job_abort_disposition;
      IF pvt [p$job_abort_disposition].value^.keyword_value = 'RESTART' THEN
        return_attributes.job_submission_option [nfc$iqa_job_abort_disposition].job_abort_disposition :=
              jmc$restart_on_abort;
      ELSE { TERMINATE is the only other choice. }
        return_attributes.job_submission_option [nfc$iqa_job_abort_disposition].job_abort_disposition :=
              jmc$terminate_on_abort;
      IFEND;
    IFEND;

{If specified process JOB_CLASS parameter.

    IF pvt [p$job_class].specified THEN
      return_attributes.job_submission_option [nfc$iqa_job_class].key := jmc$job_class;
      return_attributes.job_submission_option [nfc$iqa_job_class].job_class := pvt [p$job_class].value^
            .name_value;
    IFEND;

{ If specified process JOB_DEFERRED_BY_USER parameter.

    IF pvt [p$job_deferred_by_user].specified THEN
      return_attributes.job_submission_option [nfc$iqa_job_deferred_by_user].key := jmc$job_deferred_by_user;
      return_attributes.job_submission_option [nfc$iqa_job_deferred_by_user].job_deferred_by_user :=
            pvt [p$job_deferred_by_user].value^.boolean_value.value;
    IFEND;

{ If specified process JOB_DESTINATION parameter.

    IF pvt [p$job_destination].specified THEN
      return_attributes.job_submission_option [nfc$iqa_job_destination].key := jmc$job_destination_family;
      IF pvt [p$job_destination].value^.kind = clc$name THEN
        return_attributes.job_submission_option [nfc$iqa_job_destination].job_destination_family :=
              pvt [p$job_destination].value^.name_value;
      ELSE
        return_attributes.job_submission_option [nfc$iqa_job_destination].job_destination_family :=
              pvt [p$job_destination].value^.string_value^;
      IFEND;
    IFEND;

{ If specified process JOB_DESTINATION_USAGE parameter.

    IF pvt [p$job_destination_usage].specified THEN
      return_attributes.job_submission_option [nfc$iqa_job_destination_usage].key :=
            jmc$job_destination_usage;
      IF pvt [p$job_destination_usage].value^.kind = clc$name THEN
        return_attributes.job_submission_option [nfc$iqa_job_destination_usage].job_destination_usage :=
              pvt [p$job_destination_usage].value^.name_value;
      ELSE
        return_attributes.job_submission_option [nfc$iqa_job_destination_usage].job_destination_usage :=
              pvt [p$job_destination_usage].value^.keyword_value;
      IFEND;
    IFEND;

{ If specified process JOB_EXECUTION_RING parameter.

    IF pvt [p$job_execution_ring].specified THEN
      return_attributes.job_submission_option [nfc$iqa_job_execution_ring].key := jmc$job_execution_ring;
      return_attributes.job_submission_option [nfc$iqa_job_execution_ring].job_execution_ring :=
            pvt [p$job_execution_ring].value^.integer_value.value;
    IFEND;

{ If specified process JOB_QUALIFIER parameter.

    IF pvt [p$job_qualifier].specified THEN
      FOR job_qualifier_index := 1 TO jmc$maximum_job_qualifiers DO
        job_qualifier_list [job_qualifier_index] := osc$null_name;
      FOREND;

      IF pvt [p$job_qualifier].value^.kind = clc$keyword THEN
        IF pvt [p$job_qualifier].value^.keyword_value = 'NONE' THEN
          job_qualifier_list [1] := osc$null_name;
        ELSE { keyword_value = 'SYSTEM_DEFAULT'}
          PUSH default_job_attributes_p: [1 .. 1];
          default_job_attributes_p^ [1].key := jmc$job_qualifier_list;
          default_job_attributes_p^ [1].job_qualifier_list := ^job_qualifier_list;
          jmp$get_attribute_defaults (jmc$batch, default_job_attributes_p, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      ELSE
        job_qualifier_count := clp$count_list_elements (pvt [p$job_qualifier].value);
        job_qualifier_options := pvt [p$job_qualifier].value;
        FOR job_qualifier_index := 1 TO job_qualifier_count DO
          job_qualifier_list [job_qualifier_index] := job_qualifier_options^.element_value^.name_value;
          job_qualifier_options := job_qualifier_options^.link;
        FOREND;
      IFEND;
      return_attributes.job_submission_option [nfc$iqa_job_qualifier_list].key := jmc$job_qualifier_list;
      return_attributes.job_submission_option [nfc$iqa_job_qualifier_list].job_qualifier_list :=
            ^job_qualifier_list;
    IFEND;

{ If specified process JOB_RECOVERY_DISPOSITION parameter.

    IF pvt [p$job_recovery_disposition].specified THEN
      return_attributes.job_submission_option [nfc$iqa_job_recovery_dispositon].key :=
            jmc$job_recovery_disposition;
      IF pvt [p$job_recovery_disposition].value^.keyword_value = 'RESTART' THEN
        return_attributes.job_submission_option [nfc$iqa_job_recovery_dispositon].job_recovery_disposition :=
              jmc$restart_on_recovery;
      ELSEIF pvt [p$job_recovery_disposition].value^.keyword_value = 'CONTINUE' THEN
        return_attributes.job_submission_option [nfc$iqa_job_recovery_dispositon].job_recovery_disposition :=
              jmc$continue_on_recovery;
      ELSE { pvt [p$job_recovery_disposition].value^.keyword_value = 'TERMINATE'.
        return_attributes.job_submission_option [nfc$iqa_job_recovery_dispositon].job_recovery_disposition :=
              jmc$terminate_on_recovery;
      IFEND;
    IFEND;

{ If specified process LATEST_RUN_TIME parameter.

    IF pvt [p$latest_run_time].specified THEN
      return_attributes.job_submission_option [nfc$iqa_latest_run_time].key := jmc$latest_run_time;
      IF pvt [p$latest_run_time].value^.kind = clc$keyword THEN { the only keyword allowed is NONE. }
        return_attributes.job_submission_option [nfc$iqa_latest_run_time].latest_run_time.specified := FALSE;
      ELSE
        return_attributes.job_submission_option [nfc$iqa_latest_run_time].latest_run_time.specified := TRUE;
        return_attributes.job_submission_option [nfc$iqa_latest_run_time].latest_run_time.date_time :=
              pvt [p$latest_run_time].value^.date_time_value.value;
      IFEND;
    IFEND;

{ If specified process LOGIN_FAMILY parameter.

    IF pvt [p$login_family].specified THEN
      return_attributes.job_submission_option [nfc$iqa_login_family].key := jmc$login_family;
      return_attributes.job_submission_option [nfc$iqa_login_family].login_family :=
            pvt [p$login_family].value^.name_value;
    IFEND;

{ If specified process MAGNETIC_TAPE_LIMIT parameter.

    IF pvt [p$magnetic_tape_limit].specified THEN
      return_attributes.job_submission_option [nfc$iqa_magnetic_tape_limit].key := jmc$magnetic_tape_limit;
      IF pvt [p$magnetic_tape_limit].value^.kind = clc$integer THEN
        return_attributes.job_submission_option [nfc$iqa_magnetic_tape_limit].magnetic_tape_limit :=
              pvt [p$magnetic_tape_limit].value^.integer_value.value;
      ELSE
        IF pvt [p$magnetic_tape_limit].value^.keyword_value = 'UNSPECIFIED' THEN
          return_attributes.job_submission_option [nfc$iqa_magnetic_tape_limit].magnetic_tape_limit :=
                jmc$unspecified_mag_tape_limit;
        ELSEIF pvt [p$magnetic_tape_limit].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
          return_attributes.job_submission_option [nfc$iqa_magnetic_tape_limit].magnetic_tape_limit :=
                jmc$system_default_mag_tape_lim;
        ELSE { pvt [p$magnetic_tape_limit].value^.keyword_value = 'UNLIMITED'.
          return_attributes.job_submission_option [nfc$iqa_magnetic_tape_limit].magnetic_tape_limit :=
                jmc$unlimited_mag_tape_limit;
        IFEND;
      IFEND;
    IFEND;

{ If specified process MAXIMUM_WORKING_SET parameter.

    IF pvt [p$maximum_working_set].specified THEN
      return_attributes.job_submission_option [nfc$iqa_maximum_working_set].key := jmc$maximum_working_set;
      IF pvt [p$maximum_working_set].value^.kind = clc$integer THEN
        return_attributes.job_submission_option [nfc$iqa_maximum_working_set].maximum_working_set :=
              pvt [p$maximum_working_set].value^.integer_value.value;
      ELSE
        IF pvt [p$maximum_working_set].value^.keyword_value = 'UNSPECIFIED' THEN
          return_attributes.job_submission_option [nfc$iqa_maximum_working_set].maximum_working_set :=
                jmc$unspecified_work_set_size;
        ELSEIF pvt [p$maximum_working_set].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
          return_attributes.job_submission_option [nfc$iqa_maximum_working_set].maximum_working_set :=
                jmc$system_default_work_set_siz;
        ELSE { pvt [p$maximum_working_set].value^.keyword_value = 'UNLIMITED'.
          return_attributes.job_submission_option [nfc$iqa_maximum_working_set].maximum_working_set :=
                jmc$unlimited_working_set_size;
        IFEND;
      IFEND;
    IFEND;

{ If specified process OPERATOR_FAMILY parameter.

    IF pvt [p$operator_family].specified THEN
      return_attributes.job_submission_option [nfc$iqa_operator_family].key := jmc$output_destination_family;
      return_attributes.job_submission_option [nfc$iqa_operator_family].output_destination_family :=
            pvt [p$operator_family].value^.name_value;
    IFEND;

{ If specified process OPERATOR_USER parameter.

    IF pvt [p$operator_user].specified THEN
      return_attributes.job_submission_option [nfc$iqa_operator_user].key := jmc$station_operator;
      return_attributes.job_submission_option [nfc$iqa_operator_user].station_operator :=
            pvt [p$operator_user].value^.name_value;
    IFEND;

{ If specified process OUTPUT_DISPOSITION parameter.

    IF pvt [p$output_disposition].specified THEN
      return_attributes.job_submission_option [nfc$iqa_output_disposition].key := jmc$output_disposition;
      IF pvt [p$output_disposition].value^.kind = clc$file THEN
        output_disposition_path := pvt [p$output_disposition].value^.file_value^;
        return_attributes.job_submission_option [nfc$iqa_output_disposition].output_disposition.key :=
              jmc$standard_output_path;
        return_attributes.job_submission_option [nfc$iqa_output_disposition].output_disposition
              .standard_output_path := ^output_disposition_path;
      ELSE
        IF pvt [p$output_disposition].value^.keyword_value = 'PRINTER' THEN
          return_attributes.job_submission_option [nfc$iqa_output_disposition].output_disposition.key :=
                jmc$normal_output_disposition;
          change_implicit_text_wait_queue (FALSE);
        ELSEIF pvt [p$output_disposition].value^.keyword_value = 'DISCARD_ALL_OUTPUT' THEN
          return_attributes.job_submission_option [nfc$iqa_output_disposition].output_disposition.key :=
                jmc$discard_all_output;
        ELSEIF pvt [p$output_disposition].value^.keyword_value = 'DISCARD_STANDARD_OUTPUT' THEN
          return_attributes.job_submission_option [nfc$iqa_output_disposition].output_disposition.key :=
                jmc$discard_standard_output;
        ELSEIF pvt [p$output_disposition].value^.keyword_value = 'LOCAL' THEN
          return_attributes.job_submission_option [nfc$iqa_output_disposition].output_disposition.key :=
                jmc$local_output_disposition;
        ELSE { pvt [p$output_disposition].value^.keyword_value = 'WAIT_QUEUE'.
          return_attributes.job_submission_option [nfc$iqa_output_disposition].output_disposition.key :=
                jmc$wait_queue_path;
          return_attributes.job_submission_option [nfc$iqa_output_disposition].output_disposition
                .wait_queue_path := NIL;
          change_implicit_text_wait_queue (TRUE);
        IFEND;
      IFEND;
    IFEND;

{ If specified process REMOTE_HOST_DIRECTIVE parameter.

    IF pvt [p$remote_host_directive].specified THEN
      output_remote_host_directive.size := STRLENGTH (pvt [p$remote_host_directive].value^.string_value^);
      output_remote_host_directive.parameters := pvt [p$remote_host_directive].value^.string_value^;
      return_attributes.job_submission_option [nfc$iqa_remote_host_directive].key :=
            jmc$remote_host_directive;
      return_attributes.job_submission_option [nfc$iqa_remote_host_directive].remote_host_directive :=
            ^output_remote_host_directive;
    IFEND;

{ If specified process SRU_LIMIT parameter.

    IF pvt [p$sru_limit].specified THEN
      return_attributes.job_submission_option [nfc$iqa_sru_limit].key := jmc$sru_limit;
      IF pvt [p$sru_limit].value^.kind = clc$integer THEN
        return_attributes.job_submission_option [nfc$iqa_sru_limit].sru_limit :=
              pvt [p$sru_limit].value^.integer_value.value;
      ELSE
        IF pvt [p$sru_limit].value^.keyword_value = 'UNSPECIFIED' THEN
          return_attributes.job_submission_option [nfc$iqa_sru_limit].sru_limit := jmc$unspecified_sru_limit;
        ELSEIF pvt [p$sru_limit].value^.keyword_value = 'SYSTEM_DEFAULT' THEN
          return_attributes.job_submission_option [nfc$iqa_sru_limit].sru_limit :=
                jmc$system_default_sru_limit;
        ELSE { pvt [p$sru_limit].value^.keyword_value = 'UNLIMITED'.
          return_attributes.job_submission_option [nfc$iqa_sru_limit].sru_limit := jmc$unlimited_sru_limit;
        IFEND;
      IFEND;
    IFEND;

{ If specified process STATION parameter.

    IF pvt [p$station].specified THEN
      return_attributes.job_submission_option [nfc$iqa_station].key := jmc$station;
      IF pvt [p$station].value^.kind = clc$keyword THEN
        return_attributes.job_submission_option [nfc$iqa_station].station :=
              pvt [p$station].value^.keyword_value;
      ELSE
        return_attributes.job_submission_option [nfc$iqa_station].station := pvt [p$station].value^
              .name_value;
      IFEND;
    IFEND;

{ If specified process USER_INFORMATION parameter.

    IF pvt [p$user_information].specified THEN
      output_user_information := pvt [p$user_information].value^.string_value^;
      return_attributes.job_submission_option [nfc$iqa_user_information].key := jmc$user_information;
      return_attributes.job_submission_option [nfc$iqa_user_information].user_information :=
            ^output_user_information;
    IFEND;

{ Get USER_JOB_NAME if it was specified

    IF pvt [p$user_job_name].specified THEN
      return_attributes.job_submission_option [nfc$iqa_user_job_name].key := jmc$user_job_name;
      return_attributes.job_submission_option [nfc$iqa_user_job_name].user_job_name :=
            pvt [p$user_job_name].value^.name_value;
    IFEND;

  PROCEND crack_submit_job_command;
?? TITLE := 'crack_system_routing_text', EJECT ??

{ PURPOSE:
{   This procedure will take the systems routing text string and cracks it
{   into job/print attributes.  The systems routing text is not defined in any
{   document.  The format of the systems routing text is:
{     CYB keyword= value, keyword= value, ...
{   Spaces are ignored.

  PROCEDURE crack_system_routing_text
    (    system_routing_text: jmt$system_routing_text;
         queue_file_type: nft$queue_file_type;
         no_override_output_attribs: nft$output_queue_attributes_set;
         no_override_input_attribs: nft$input_queue_attributes_set;
     VAR return_attributes: nft$queue_submission_option;
     VAR status: ost$status);

    CONST
      keyword_minimum_length = 2,
      keyword_maximum_length = 3,
      keyword_terminator = '=',
      maximum_account_length = 2 * maximum_attribute_length,
      maximum_attribute_length = 7,
      maximum_project_length = 4 * maximum_attribute_length,
      number_srt_tokens = 30,
      skip_character = ' ',
      srt_header_position = 1,
      text_terminator = '.',
      value_terminator = ',';

    TYPE
      srt_parsing_table = record
        keyword_name: string (keyword_maximum_length),
        keyword_length: keyword_minimum_length .. keyword_maximum_length,
        input_attribute: nft$input_queue_attributes,
        output_attribute: nft$output_queue_attributes,
      recend;

    VAR
      account_length: 0 .. maximum_account_length,
      account_value: string (maximum_account_length),
      integer_record: clt$integer,
      keyword_error_text: [STATIC] string (23) := 'Invalid SRT keyword    ',
      keyword_index: integer,
      new_name_value: ost$name,
      project_length: 0 .. maximum_project_length,
      project_value: string (maximum_project_length),
      srt_tokens: [STATIC, READ] array [1 .. number_srt_tokens] of srt_parsing_table := [
            ['CFM', 3, nfc$iqa_control_family, nfc$oqa_control_family],
            ['CH1', 3, nfc$iqa_null_attribute, nfc$oqa_login_account],
            ['CH2', 3, nfc$iqa_null_attribute, nfc$oqa_login_account],
            ['CUN', 3, nfc$iqa_control_user, nfc$oqa_control_user],
            ['DAY', 3, nfc$iqa_null_attribute, nfc$oqa_null_attribute],
            ['DC', 2, nfc$iqa_disposition_code, nfc$oqa_disposition_code],
            ['DO', 2, nfc$iqa_null_attribute, nfc$oqa_null_attribute],
            ['EC', 2, nfc$iqa_external_characteristic, nfc$oqa_external_characteristic],
            ['FC', 2, nfc$iqa_forms_code, nfc$oqa_forms_code],
            ['FID', 3, nfc$iqa_null_attribute, nfc$oqa_null_attribute],
            ['FM', 2, nfc$iqa_operator_family, nfc$oqa_operator_family],
            ['IC', 2, nfc$iqa_null_attribute, nfc$oqa_null_attribute],
            ['ID', 2, nfc$iqa_null_attribute, nfc$oqa_null_attribute],
            ['OFM', 3, nfc$iqa_control_family, nfc$oqa_login_family],
            ['OT', 2, nfc$iqa_null_attribute, nfc$oqa_null_attribute],
            ['OUN', 3, nfc$iqa_control_user, nfc$oqa_login_user],
            ['PI', 2, nfc$iqa_null_attribute, nfc$oqa_null_attribute],
            ['PJ1', 3, nfc$iqa_null_attribute, nfc$oqa_login_project],
            ['PJ2', 3, nfc$iqa_null_attribute, nfc$oqa_login_project],
            ['PJ3', 3, nfc$iqa_null_attribute, nfc$oqa_login_project],
            ['PJ4', 3, nfc$iqa_null_attribute, nfc$oqa_login_project],
            ['PRI', 3, nfc$iqa_null_attribute, nfc$oqa_null_attribute],
            ['PW1', 3, nfc$iqa_null_attribute, nfc$oqa_null_attribute],
            ['PW2', 3, nfc$iqa_null_attribute, nfc$oqa_null_attribute],
            ['REP', 3, nfc$iqa_copies, nfc$oqa_copies],
            ['SC', 2, nfc$iqa_null_attribute, nfc$oqa_null_attribute],
            ['SCL', 3, nfc$iqa_null_attribute, nfc$oqa_output_class],
            ['TID', 3, nfc$iqa_null_attribute, nfc$oqa_null_attribute],
            ['UJN', 3, nfc$iqa_user_job_name, nfc$oqa_user_file_name],
            ['UN', 2, nfc$iqa_operator_user, nfc$oqa_operator_user]],
      text_position: 1 .. jmc$system_routing_text_size,
      token: string (maximum_attribute_length),
      token_index: 0 .. number_srt_tokens,
      token_length: 0 .. maximum_attribute_length;

    status.normal := TRUE;

{ The first three characters must be CYB, else I cannot crack it and
{ should pass it on to a possible next hop (application).

    IF system_routing_text.size < nfc$p32_cyber_id_length THEN
      RETURN; { Cannot process }
    IFEND;
    IF system_routing_text.parameters (srt_header_position, nfc$p32_cyber_id_length) <> nfc$p32_cyber_id THEN
      RETURN; { Cannot process }
    IFEND;

    text_position := nfc$p32_cyber_id_length + 1;
    account_length := 0;
    project_length := 0;

  /parse_system_routing_text_loop/
    WHILE text_position <= system_routing_text.size DO

{ Get the keyword.

      token_length := 0;
      token := '';

      WHILE (text_position <= system_routing_text.size) AND (system_routing_text.parameters (text_position, 1)
            <> keyword_terminator) DO

{ Eliminate any spaces, commas or periods before or during the keyword.

        IF NOT ((system_routing_text.parameters (text_position, 1) = skip_character) OR
              (system_routing_text.parameters (text_position, 1) = value_terminator) OR
              (system_routing_text.parameters (text_position, 1) = text_terminator)) THEN
          token_length := token_length + 1;
          token (token_length, 1) := system_routing_text.parameters (text_position, 1);
        IFEND;
        text_position := text_position + 1;
      WHILEND;

{ increment text_position to account for the keyword terminator

      text_position := text_position + 1;

{ An error has occurred if the system_routing_text has been exhausted while searching for a keyword.

      IF (text_position > system_routing_text.size) AND (token_length >0) THEN
        keyword_error_text (20, keyword_maximum_length) := token (1, token_length);
        osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, keyword_error_text, status);
        RETURN;
      ELSEIF (text_position > system_routing_text.size) THEN
        EXIT /parse_system_routing_text_loop/;
      IFEND;

      keyword_index := 0;
    /find_keyword/
      FOR token_index := LOWERBOUND (srt_tokens) TO UPPERBOUND (srt_tokens) DO
        IF (token_length = srt_tokens [token_index].keyword_length) AND
              (token (1, token_length) = srt_tokens [token_index].keyword_name) THEN
          keyword_index := token_index;
          EXIT /find_keyword/;
        IFEND;
      FOREND /find_keyword/;

      IF keyword_index = 0 THEN {** Unknown keyword **}
        keyword_error_text (20, keyword_maximum_length) := token (1, token_length);
        osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, keyword_error_text, status);
        RETURN;
      IFEND;

{ Get the keyword value.

      token_length := 0;
      token := '';

      WHILE (text_position <= system_routing_text.size) AND (NOT ((system_routing_text.parameters
            (text_position, 1) = value_terminator) OR (system_routing_text.parameters (text_position, 1) =
            text_terminator))) DO
        token_length := token_length + 1;
        token (token_length, 1) := system_routing_text.parameters (text_position, 1);
        text_position := text_position + 1;
      WHILEND;

      IF queue_file_type = nfc$print_queue_file THEN
        IF NOT (srt_tokens [keyword_index].output_attribute IN no_override_output_attribs) THEN
          CASE srt_tokens [keyword_index].output_attribute OF
          = nfc$oqa_control_family =
            convert_string_to_ost$name (token (1, token_length), user_job_name_prefix, new_name_value);
            return_attributes.output_submission_option [nfc$oqa_control_family].key := jmc$control_family;
            return_attributes.output_submission_option [nfc$oqa_control_family].control_family :=
                  new_name_value;

          = nfc$oqa_control_user =
            convert_string_to_ost$name (token (1, token_length), user_job_name_prefix, new_name_value);
            return_attributes.output_submission_option [nfc$oqa_control_user].key := jmc$control_user;
            return_attributes.output_submission_option [nfc$oqa_control_user].control_user := new_name_value;

          = nfc$oqa_copies =
            clp$convert_string_to_integer (token (1, token_length), integer_record, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            return_attributes.output_submission_option [nfc$oqa_copies].key := jmc$copies;
            return_attributes.output_submission_option [nfc$oqa_copies].copies := integer_record.value + 1;

          = nfc$oqa_disposition_code =
            IF (token (1, token_length) = nfc$p32_cyb_wait_queue_value_wt) OR
                  (token (1, token_length) = nfc$p32_cyb_wait_queue_value_tt) THEN
              osp$set_status_abnormal (nfc$status_id, nfe$prif_to_wait_queue_not_sup, '', status);
              RETURN;
            IFEND;
            return_attributes.output_submission_option [nfc$oqa_disposition_code].key := jmc$disposition_code;
            return_attributes.output_submission_option [nfc$oqa_disposition_code].disposition_code :=
                  token (1, token_length);

          = nfc$oqa_external_characteristic =
            return_attributes.output_submission_option [nfc$oqa_external_characteristic].key :=
                  jmc$external_characteristics;
            return_attributes.output_submission_option [nfc$oqa_external_characteristic]
                  .external_characteristics := token (1, token_length);

          = nfc$oqa_forms_code =
            return_attributes.output_submission_option [nfc$oqa_forms_code].key := jmc$forms_code;
            return_attributes.output_submission_option [nfc$oqa_forms_code].forms_code :=
                  token (1, token_length);

          = nfc$oqa_login_account =
            account_value ((account_length + 1), token_length) := token;
            account_length := account_length + token_length;

          = nfc$oqa_login_family =
            convert_string_to_ost$name (token (1, token_length), user_job_name_prefix, new_name_value);
            return_attributes.output_submission_option [nfc$oqa_login_family].key := jmc$login_family;
            return_attributes.output_submission_option [nfc$oqa_login_family].login_family :=
                  new_name_value;

          = nfc$oqa_login_project =
            project_value ((project_length + 1), token_length) := token;
            project_length := project_length + token_length;

          = nfc$oqa_login_user =
            convert_string_to_ost$name (token (1, token_length), user_job_name_prefix, new_name_value);
            return_attributes.output_submission_option [nfc$oqa_login_user].key := jmc$login_user;
            return_attributes.output_submission_option [nfc$oqa_login_user].login_user := new_name_value;

          = nfc$oqa_null_attribute =

          = nfc$oqa_operator_family =
            convert_string_to_ost$name (token (1, token_length), user_job_name_prefix, new_name_value);
            return_attributes.output_submission_option [nfc$oqa_operator_family].key :=
                  jmc$output_destination_family;
            return_attributes.output_submission_option [nfc$oqa_operator_family].output_destination_family :=
                  new_name_value;

          = nfc$oqa_operator_user =
            convert_string_to_ost$name (token (1, token_length), user_job_name_prefix, new_name_value);
            return_attributes.output_submission_option [nfc$oqa_operator_user].key := jmc$station_operator;
            return_attributes.output_submission_option [nfc$oqa_operator_user].station_operator :=
                  new_name_value;

          = nfc$oqa_output_class =
            convert_string_to_ost$name (token (1, token_length), user_job_name_prefix, new_name_value);

{ Convert all non-NOS/VE output classes to those known to NOS/VE.
{ Currently the only valid NOS/VE output class is 'NORMAL'.

            IF new_name_value <> nfc$normal_string THEN
              new_name_value := nfc$normal_string;
            IFEND;
            return_attributes.output_submission_option [nfc$oqa_output_class].key := jmc$output_class;
            return_attributes.output_submission_option [nfc$oqa_output_class].output_class :=
                  new_name_value;

          = nfc$oqa_user_file_name =
            convert_string_to_ost$name (token (1, token_length), user_job_name_prefix, new_name_value);
            return_attributes.output_submission_option [nfc$oqa_user_file_name].key := jmc$user_file_name;
            return_attributes.output_submission_option [nfc$oqa_user_file_name].user_file_name :=
                  new_name_value;
          ELSE
          CASEND;
        IFEND;
      ELSE
        IF NOT (srt_tokens [keyword_index].input_attribute IN no_override_input_attribs) THEN
          CASE srt_tokens [keyword_index].input_attribute OF
          = nfc$iqa_control_family =
            convert_string_to_ost$name (token (1, token_length), user_job_name_prefix, new_name_value);
            return_attributes.job_submission_option [nfc$iqa_control_family].key := jmc$control_family;
            return_attributes.job_submission_option [nfc$iqa_control_family].control_family :=
                  new_name_value;

          = nfc$iqa_control_user =
            convert_string_to_ost$name (token (1, token_length), user_job_name_prefix, new_name_value);
            return_attributes.job_submission_option [nfc$iqa_control_user].key := jmc$control_user;
            return_attributes.job_submission_option [nfc$iqa_control_user].control_user := new_name_value;

          = nfc$iqa_copies =
            clp$convert_string_to_integer (token (1, token_length), integer_record, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            return_attributes.job_submission_option [nfc$iqa_copies].key := jmc$copies;
            return_attributes.job_submission_option [nfc$iqa_copies].copies := integer_record.value + 1;

          = nfc$iqa_disposition_code =
            IF (token (1, token_length) = nfc$p32_cyb_input_wait_queue_to) THEN
              return_attributes.job_submission_option [nfc$iqa_output_disposition].key :=
                    jmc$output_disposition;
              return_attributes.job_submission_option [nfc$iqa_output_disposition].output_disposition.key :=
                    jmc$wait_queue_path;
            ELSEIF (token (1, token_length) = nfc$p32_cyb_input_no_return_no) THEN
              return_attributes.job_submission_option [nfc$iqa_output_disposition].key :=
                    jmc$output_disposition;
              return_attributes.job_submission_option [nfc$iqa_output_disposition].output_disposition.key :=
                    jmc$discard_standard_output;
            IFEND;
            return_attributes.job_submission_option [nfc$iqa_disposition_code].key := jmc$disposition_code;
            return_attributes.job_submission_option [nfc$iqa_disposition_code].disposition_code :=
                  token (1, token_length);

          = nfc$iqa_external_characteristic =
            return_attributes.job_submission_option [nfc$iqa_external_characteristic].key :=
                  jmc$external_characteristics;
            return_attributes.job_submission_option [nfc$iqa_external_characteristic]
                  .external_characteristics := token (1, token_length);

          = nfc$iqa_forms_code =
            return_attributes.job_submission_option [nfc$iqa_forms_code].key := jmc$forms_code;
            return_attributes.job_submission_option [nfc$iqa_forms_code].forms_code :=
                  token (1, token_length);

          = nfc$iqa_null_attribute =

          = nfc$iqa_operator_family =
            convert_string_to_ost$name (token (1, token_length), user_job_name_prefix, new_name_value);
            return_attributes.job_submission_option [nfc$iqa_operator_family].key :=
                  jmc$output_destination_family;
            return_attributes.job_submission_option [nfc$iqa_operator_family].output_destination_family :=
                 new_name_value;

          = nfc$iqa_operator_user =
            convert_string_to_ost$name (token (1, token_length), user_job_name_prefix, new_name_value);
            return_attributes.job_submission_option [nfc$iqa_operator_user].key := jmc$station_operator;
            return_attributes.job_submission_option [nfc$iqa_operator_user].station_operator :=
                  new_name_value;

          = nfc$iqa_user_job_name =
            convert_string_to_ost$name (token (1, token_length), user_job_name_prefix, new_name_value);
            return_attributes.job_submission_option [nfc$iqa_user_job_name].key := jmc$user_job_name;
            return_attributes.job_submission_option [nfc$iqa_user_job_name].user_job_name :=
                  new_name_value;
          ELSE
          CASEND;
        IFEND;
      IFEND;

{ increment text_position to account for the keyword value terminator

      text_position := text_position + 1;
    WHILEND /parse_system_routing_text_loop/;

    IF queue_file_type = nfc$print_queue_file THEN
      IF account_length > 0 THEN
        convert_string_to_ost$name (account_value (1, account_length), charge_prefix_character,
              new_name_value);
        return_attributes.output_submission_option [nfc$oqa_login_account].key := jmc$login_account;
        return_attributes.output_submission_option [nfc$oqa_login_account].login_account := new_name_value;
      IFEND;

      IF project_length > 0 THEN
        convert_string_to_ost$name (project_value (1, project_length), project_prefix_character,
              new_name_value);
        return_attributes.output_submission_option [nfc$oqa_login_project].key := jmc$login_project;
        return_attributes.output_submission_option [nfc$oqa_login_project].login_project := new_name_value;
      IFEND;

      IF return_attributes.output_submission_option [nfc$oqa_operator_family].key = jmc$null_attribute THEN
        return_attributes.output_submission_option [nfc$oqa_operator_family].key :=
              jmc$output_destination_family;
        IF return_attributes.output_submission_option [nfc$oqa_control_family].key <> jmc$null_attribute THEN
          return_attributes.output_submission_option [nfc$oqa_operator_family].output_destination_family :=
                return_attributes.output_submission_option [nfc$oqa_control_family].control_family;
        ELSE
          return_attributes.output_submission_option [nfc$oqa_operator_family].output_destination_family :=
                'NONE';
        IFEND;
      IFEND;

      IF return_attributes.output_submission_option [nfc$oqa_operator_user].key = jmc$null_attribute THEN
        return_attributes.output_submission_option [nfc$oqa_operator_user].key := jmc$station_operator;
        IF return_attributes.output_submission_option [nfc$oqa_control_user].key <> jmc$null_attribute THEN
          return_attributes.output_submission_option [nfc$oqa_operator_user].station_operator :=
                return_attributes.output_submission_option [nfc$oqa_control_user].control_user;
        ELSE
          return_attributes.output_submission_option [nfc$oqa_operator_user].station_operator := 'NONE';
        IFEND;
      IFEND;
    ELSE
      IF return_attributes.job_submission_option [nfc$iqa_operator_family].key = jmc$null_attribute THEN
        return_attributes.job_submission_option [nfc$iqa_operator_family].key :=
              jmc$output_destination_family;
        IF return_attributes.job_submission_option [nfc$iqa_control_family].key <> jmc$null_attribute THEN
          return_attributes.job_submission_option [nfc$iqa_operator_family].output_destination_family :=
                return_attributes.job_submission_option [nfc$iqa_control_family].control_family;
        ELSE
          return_attributes.job_submission_option [nfc$iqa_operator_family].output_destination_family :=
                'NONE';
        IFEND;
      IFEND;

      IF return_attributes.job_submission_option [nfc$iqa_operator_user].key = jmc$null_attribute THEN
        return_attributes.job_submission_option [nfc$iqa_operator_user].key :=
              jmc$output_destination_family;
        IF return_attributes.job_submission_option [nfc$iqa_control_user].key <> jmc$null_attribute THEN
          return_attributes.job_submission_option [nfc$iqa_operator_user].station_operator :=
                return_attributes.job_submission_option [nfc$iqa_control_user].control_user;
        ELSE
          return_attributes.job_submission_option [nfc$iqa_operator_user].station_operator := 'NONE';
        IFEND;
      IFEND;
    IFEND;
  PROCEND crack_system_routing_text;
?? TITLE := 'create_queue_file_attributes', EJECT ??

{ PURPOSE:
{   This procedure will create the attributes for a queue file based on A-A protocol.
{   This procedure will take the protocol elements sent by the client task and
{   creates the queue file attributes for the transfer.  The attributes are keyed
{   primarily off of the initiating host type, and received protocol elements.

  PROCEDURE create_queue_file_attributes
    (    file_name: amt$local_file_name;
         store_and_forward_queue_file: boolean;
         remote_host_type: nft$parameter_22_values;
         data_declaration: nft$parameter_31_type;
         disposition_code: nft$parameter_17_definition;
         destination_family: string ( * <= nfc$p25_max_param_size);
         source_lid: string ( * <= nfc$p24_max_param_size);
         store_forward_application_name: ost$name;
         system_routing_text: jmt$system_routing_text;
         implicit_routing_text: jmt$implicit_routing_text;
         explicit_routing_text: nft$directive_entry_list_head;
         transfer_mode: nft$transfer_modes;
         protocol_job_name: string ( * <= nfc$p26_max_param_length);
         system_supplied_name: string ( * <= nfc$p16_max_param_length);
         queue_file_type: nft$queue_file_type;
         loop_back_transfer: boolean;
         echo_text_login_family: ost$name;
         transfer_pid: string ( * <= nfc$p27_max_param_size);
         file_is_qtfi_err_file: boolean;
     VAR input_accounting_data: qtfs_input_accounting_data;
     VAR queue_file_attributes: nft$queue_submission_option;
     VAR overridden_jad_odu: boolean;
     VAR queue_file_page_width:amt$page_width;
     VAR status: ost$status);

    VAR
      attribute_results: ^jmt$default_attribute_results,
      generic_queue_attributes_index: nft$generic_queue_attributes,
      input_queue_attributes_index: nft$input_queue_attributes,
      new_name_value: ost$name,
      nos_ve_implicit_text: boolean,
      output_queue_attributes_index: nft$output_queue_attributes,
      srt_no_override_output_attribs: nft$output_queue_attributes_set;

{ Initialize variables

    status.normal := TRUE;
    overridden_jad_odu := FALSE;
    nos_ve_implicit_text := FALSE;

{ Set all attributes to null for input and output queue files. Set appropriate ORIGIN_APPLICATION_NAME.

    IF queue_file_type = nfc$job_queue_file THEN
      queue_file_attributes.queue_file_type := nfc$job_queue_file;
      FOR input_queue_attributes_index := LOWERVALUE (input_queue_attributes_index) TO
            UPPERVALUE (input_queue_attributes_index) DO
        queue_file_attributes.job_submission_option [input_queue_attributes_index].key := jmc$null_attribute;
      FOREND;

{ Set ORIGIN_APPLICATION_NAME to qtf_server

      queue_file_attributes.job_submission_option [nfc$iqa_origin_application_name].key :=
            jmc$origin_application_name;
      queue_file_attributes.job_submission_option [nfc$iqa_origin_application_name].origin_application_name :=
            osc$queue_transfer_server;
    ELSEIF queue_file_type = nfc$print_queue_file THEN
      queue_file_attributes.queue_file_type := nfc$print_queue_file;
      FOR output_queue_attributes_index := LOWERVALUE (output_queue_attributes_index)
            TO UPPERVALUE (output_queue_attributes_index) DO
        queue_file_attributes.output_submission_option [output_queue_attributes_index].key :=
              jmc$null_attribute;
      FOREND;

      IF file_is_qtfi_err_file THEN
        queue_file_attributes.output_submission_option [nfc$oqa_origin_application_name].key :=
              jmc$origin_application_name;
        queue_file_attributes.output_submission_option [nfc$oqa_origin_application_name]
              .origin_application_name := osc$queue_transfer_client;
      ELSE
        queue_file_attributes.output_submission_option [nfc$oqa_origin_application_name].key :=
              jmc$origin_application_name;
        queue_file_attributes.output_submission_option [nfc$oqa_origin_application_name]
              .origin_application_name := osc$queue_transfer_server;
      IFEND;
    ELSEIF queue_file_type = nfc$generic_queue_file THEN
      queue_file_attributes.queue_file_type := nfc$generic_queue_file;
      FOR generic_queue_attributes_index := LOWERVALUE (generic_queue_attributes_index) TO
            UPPERVALUE (generic_queue_attributes_index) DO
        queue_file_attributes.qfile_submission_option [generic_queue_attributes_index].key
              := jmc$null_attribute;
      FOREND;
    IFEND;

{ Set up default attributes

    PUSH attribute_results: [1 .. 2];
    attribute_results^ [1].key := jmc$output_destination_usage;
    attribute_results^ [2].key := jmc$login_family;
    jmp$get_attribute_defaults (jmc$batch, attribute_results, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF store_and_forward_queue_file THEN
      IF queue_file_type = nfc$job_queue_file THEN

        IF (remote_host_type <> nfc$p22_nos_ve) AND (remote_host_type <> nfc$p22_nos_ve_qtf) THEN

{ If job is from a non-NOS/VE system, set the CONTROL_FAMILY to NONE

          queue_file_attributes.job_submission_option [nfc$iqa_control_family].key := jmc$control_family;
          queue_file_attributes.job_submission_option [nfc$iqa_control_family].control_family := 'NONE';

{ If job is from a non-NOS/VE system, set the CONTROL_USER to NONE

          queue_file_attributes.job_submission_option [nfc$iqa_control_user].key := jmc$control_user;
          queue_file_attributes.job_submission_option [nfc$iqa_control_user].control_user := 'NONE';
        IFEND;

{ If specified set up the DATA_DECLARATION

        IF (data_declaration <> nfc$p31_unspecified) AND (data_declaration <> nfc$p31_host_dependent_uh) THEN
          queue_file_attributes.job_submission_option [nfc$iqa_data_declaration].key := jmc$data_declaration;
          queue_file_attributes.job_submission_option [nfc$iqa_data_declaration].data_declaration :=
                nfv$parameter_31_values [data_declaration];
        IFEND;

{ Set up the DATA_MODE if rhf_structure

        IF transfer_mode = nfc$rhf_structured_mode THEN
          queue_file_attributes.job_submission_option [nfc$iqa_data_mode].key := jmc$data_mode;
          queue_file_attributes.job_submission_option [nfc$iqa_data_mode].data_mode := jmc$rhf_structure;
        IFEND;

{ Set up the DISPOSITION_CODE

        queue_file_attributes.job_submission_option [nfc$iqa_disposition_code].key :=
              jmc$disposition_code;
        queue_file_attributes.job_submission_option [nfc$iqa_disposition_code].disposition_code :=
              nfv$parameter_17_values [disposition_code];

{ Set up the IMPLICIT_ROUTING_TEXT

        output_implicit_routing_text := implicit_routing_text;
        queue_file_attributes.job_submission_option [nfc$iqa_implicit_routing_text].key :=
              jmc$implicit_routing_text;
        queue_file_attributes.job_submission_option [nfc$iqa_implicit_routing_text].implicit_routing_text :=
              ^output_implicit_routing_text;

{ Set up the JOB_DESTINATION

        convert_string_to_ost$name (destination_family, user_job_name_prefix, new_name_value);
        queue_file_attributes.job_submission_option [nfc$iqa_job_destination].key :=
              jmc$job_destination_family;
        queue_file_attributes.job_submission_option [nfc$iqa_job_destination].job_destination_family :=
              new_name_value;

{ Set up the JOB_DESTINATION_USAGE

        convert_string_to_ost$name (store_forward_application_name, user_job_name_prefix, new_name_value);
        queue_file_attributes.job_submission_option [nfc$iqa_job_destination_usage].key :=
              jmc$job_destination_usage;
        queue_file_attributes.job_submission_option [nfc$iqa_job_destination_usage].job_destination_usage :=
              new_name_value;

{ Set up the LOGIN_COMMAND_SUPPLIED

        queue_file_attributes.job_submission_option [nfc$iqa_login_command_supplied].key :=
              jmc$login_command_supplied;
        queue_file_attributes.job_submission_option [nfc$iqa_login_command_supplied]
              .login_command_supplied := FALSE;

        IF (remote_host_type <> nfc$p22_nos_ve) AND (remote_host_type <> nfc$p22_nos_ve_qtf) THEN

{ If job is from a non-NOS/VE system, set the OPERATOR_FAMILY to NONE

          queue_file_attributes.job_submission_option [nfc$iqa_operator_family].key :=
                jmc$output_destination_family;
          queue_file_attributes.job_submission_option [nfc$iqa_operator_family].output_destination_family :=
                'NONE';

{ If job is from a non-NOS/VE system, set the OPERATOR_USER to NONE

          queue_file_attributes.job_submission_option [nfc$iqa_operator_user].key := jmc$station_operator;
          queue_file_attributes.job_submission_option [nfc$iqa_operator_user].station_operator := 'NONE';
        IFEND;

{ Set up the OUTPUT_DESTINATION

        convert_string_to_ost$name (source_lid, user_job_name_prefix, new_name_value);
        queue_file_attributes.job_submission_option [nfc$iqa_output_destination].key :=
              jmc$output_destination;
        queue_file_attributes.job_submission_option [nfc$iqa_output_destination].output_destination :=
              new_name_value;

{ If the output is to be returned to the originating user, set the OUTPUT_DESTIANTION_USAGE to QTF

        IF disposition_code = nfc$p17_input_return THEN
          queue_file_attributes.job_submission_option [nfc$iqa_output_dest_usage].key :=
                jmc$output_destination_usage;
          queue_file_attributes.job_submission_option [nfc$iqa_output_dest_usage]
                .output_destination_usage := jmc$qtf_usage;
        IFEND;

{ Set up the REMOTE_HOST_DIRECTIVE

        IF explicit_routing_text.head <> NIL THEN
          output_remote_host_directive.size := STRLENGTH (explicit_routing_text.head^.line);
          output_remote_host_directive.parameters := explicit_routing_text.head^.line;
          queue_file_attributes.job_submission_option [nfc$iqa_remote_host_directive].key :=
                jmc$remote_host_directive;
          queue_file_attributes.job_submission_option [nfc$iqa_remote_host_directive].remote_host_directive
                := ^output_remote_host_directive;
        IFEND;

{ Set up the SOURCE_LOGICAL_ID

        queue_file_attributes.job_submission_option [nfc$iqa_source_logical_id].key :=
              jmc$source_logical_id;
        queue_file_attributes.job_submission_option [nfc$iqa_source_logical_id].source_logical_id :=
              source_lid;

{ If the previous system was NOS/VE then save the previous SYSTEM_JOB_NAME

        IF ((remote_host_type = nfc$p22_nos_ve) OR (remote_host_type = nfc$p22_nos_ve_qtf)) AND
              (NOT loop_back_transfer) THEN
          queue_file_attributes.job_submission_option [nfc$iqa_system_job_name].key := jmc$system_job_name;
          queue_file_attributes.job_submission_option [nfc$iqa_system_job_name].system_job_name :=
                system_supplied_name;
        IFEND;

{ Set up the SYSTEM_ROUTING_TEXT

        output_system_routing_text := system_routing_text;
        queue_file_attributes.job_submission_option [nfc$iqa_system_routing_text].key :=
              jmc$system_routing_text;
        queue_file_attributes.job_submission_option [nfc$iqa_system_routing_text].system_routing_text :=
              ^output_system_routing_text;

{ Set up the USER_JOB_NAME

        IF protocol_job_name <> '' THEN
          convert_string_to_ost$name (protocol_job_name, user_job_name_prefix, new_name_value);
          queue_file_attributes.job_submission_option [nfc$iqa_user_job_name].key :=
                jmc$user_job_name;
          queue_file_attributes.job_submission_option [nfc$iqa_user_job_name].user_job_name :=
                new_name_value;
        IFEND;

      ELSEIF queue_file_type = nfc$print_queue_file THEN { Store/Forward Output file.

        IF (remote_host_type <> nfc$p22_nos_ve) AND (remote_host_type <> nfc$p22_nos_ve_qtf) THEN

{ If job is from a non-NOS/VE system, set the COMMENT_BANNER to the user_file_name

          IF protocol_job_name <> '' THEN
            convert_string_to_ost$name (protocol_job_name, user_job_name_prefix, new_name_value);
            queue_file_attributes.output_submission_option [nfc$oqa_comment_banner].key := jmc$comment_banner;
            queue_file_attributes.output_submission_option [nfc$oqa_comment_banner].comment_banner :=
                  new_name_value;
          IFEND;

{ If job is from a non-NOS/VE system, set the CONTROL_FAMILY to NONE

          queue_file_attributes.output_submission_option [nfc$oqa_control_family].key := jmc$control_family;
          queue_file_attributes.output_submission_option [nfc$oqa_control_family].control_family := 'NONE';

{ If job is from a non-NOS/VE system, set the CONTROL_USER to NONE

          queue_file_attributes.output_submission_option [nfc$oqa_control_user].key := jmc$control_user;
          queue_file_attributes.output_submission_option [nfc$oqa_control_user].control_user := 'NONE';
        IFEND;

{ If specified set up the DATA_DECLARATION

        IF (data_declaration <> nfc$p31_unspecified) AND (data_declaration <> nfc$p31_host_dependent_uh) THEN
          queue_file_attributes.output_submission_option [nfc$oqa_data_declaration].key :=
                jmc$data_declaration;
          queue_file_attributes.output_submission_option [nfc$oqa_data_declaration].data_declaration :=
                nfv$parameter_31_values [data_declaration];
        IFEND;

{ If rhf_structure set up the DATA_MODE

        IF transfer_mode = nfc$rhf_structured_mode THEN
          queue_file_attributes.output_submission_option [nfc$oqa_data_mode].key := jmc$data_mode;
          queue_file_attributes.output_submission_option [nfc$oqa_data_mode].data_mode := jmc$rhf_structure;
        IFEND;

{ Set up the DISPOSITION_CODE

        queue_file_attributes.output_submission_option [nfc$oqa_disposition_code].key :=
              jmc$disposition_code;
        queue_file_attributes.output_submission_option [nfc$oqa_disposition_code].disposition_code :=
              nfv$parameter_17_values [disposition_code];

{ Save the IMPLICIT_ROUTING_TEXT

        output_implicit_routing_text := implicit_routing_text;
        queue_file_attributes.output_submission_option [nfc$oqa_implicit_routing_text].key :=
              jmc$implicit_routing_text;
        queue_file_attributes.output_submission_option [nfc$oqa_implicit_routing_text].implicit_routing_text
              := ^output_implicit_routing_text;

        IF (remote_host_type <> nfc$p22_nos_ve) AND (remote_host_type <> nfc$p22_nos_ve_qtf) THEN

{ If job is from a non-NOS/VE system, set the LOGIN_ACCOUNT to NONE

          queue_file_attributes.output_submission_option [nfc$oqa_login_account].key := jmc$login_account;
          queue_file_attributes.output_submission_option [nfc$oqa_login_account].login_account := 'NONE';

{ If job is from a non-NOS/VE system, set the LOGIN_FAMILY to NONE

          queue_file_attributes.output_submission_option [nfc$oqa_login_family].key := jmc$login_family;
          queue_file_attributes.output_submission_option [nfc$oqa_login_family].login_family := 'NONE';

{ If job is from a non-NOS/VE system, set the LOGIN_PROJECT to NONE

          queue_file_attributes.output_submission_option [nfc$oqa_login_project].key := jmc$login_project;
          queue_file_attributes.output_submission_option [nfc$oqa_login_project].login_project := 'NONE';

{ If job is from a non-NOS/VE system, set the LOGIN_USER to NONE

          queue_file_attributes.output_submission_option [nfc$oqa_login_user].key := jmc$login_user;
          queue_file_attributes.output_submission_option [nfc$oqa_login_user].login_user := 'NONE';

{ If job is from a non-NOS/VE system, set the OPERATOR_FAMILY to NONE

          queue_file_attributes.output_submission_option [nfc$oqa_operator_family].key :=
                jmc$output_destination_family;
          queue_file_attributes.output_submission_option [nfc$oqa_operator_family].output_destination_family
                := 'NONE';

{ If job is from a non-NOS/VE system, set the OPERATOR_USER to NONE

          queue_file_attributes.output_submission_option [nfc$oqa_operator_user].key := jmc$station_operator;
          queue_file_attributes.output_submission_option [nfc$oqa_operator_user].station_operator := 'NONE';
        IFEND;

{ Set up the OUTPUT_DESTINATION

        convert_string_to_ost$name (destination_family, user_job_name_prefix, new_name_value);
        queue_file_attributes.output_submission_option [nfc$oqa_output_destination].key :=
              jmc$output_destination;
        queue_file_attributes.output_submission_option [nfc$oqa_output_destination].output_destination :=
              new_name_value;

{ Set up the OUTPUT_DESTINATION_USAGE

        convert_string_to_ost$name (store_forward_application_name, user_job_name_prefix, new_name_value);
        queue_file_attributes.output_submission_option [nfc$oqa_output_dest_usage].key :=
              jmc$output_destination_usage;
        queue_file_attributes.output_submission_option [nfc$oqa_output_dest_usage].output_destination_usage :=
              new_name_value;

{ Set up the REMOTE_HOST_DIRECTIVE

        IF explicit_routing_text.head <> NIL THEN
          output_remote_host_directive.size := STRLENGTH (explicit_routing_text.head^.line);
          output_remote_host_directive.parameters := explicit_routing_text.head^.line;
          queue_file_attributes.output_submission_option [nfc$oqa_remote_host_directive].key :=
                jmc$remote_host_directive;
          queue_file_attributes.output_submission_option [nfc$oqa_remote_host_directive].remote_host_directive
                := ^output_remote_host_directive;
        IFEND;

{ If job is from a non-NOS/VE system, set the ROUTING_BANNER to NONE

        IF (remote_host_type <> nfc$p22_nos_ve) AND (remote_host_type <> nfc$p22_nos_ve_qtf) THEN
          queue_file_attributes.output_submission_option [nfc$oqa_routing_banner].key := jmc$routing_banner;
          queue_file_attributes.output_submission_option [nfc$oqa_routing_banner].routing_banner := 'NONE';
        IFEND;

{ Set up the SOURCE_LOGICAL_ID

        queue_file_attributes.output_submission_option [nfc$oqa_source_logical_id].key :=
              jmc$source_logical_id;
        queue_file_attributes.output_submission_option [nfc$oqa_source_logical_id].source_logical_id :=
              source_lid;

{ If the previous system was NOS/VE, then save the previous SYSTEM_FILE_NAME

        IF ((remote_host_type = nfc$p22_nos_ve) OR (remote_host_type = nfc$p22_nos_ve_qtf)) AND
              (NOT loop_back_transfer) THEN
          queue_file_attributes.output_submission_option [nfc$oqa_system_file_name].key :=
                jmc$system_file_name;
          queue_file_attributes.output_submission_option [nfc$oqa_system_file_name].system_file_name :=
                system_supplied_name;
        IFEND;

{ Set up the SYSTEM_ROUTING_TEXT

        output_system_routing_text := system_routing_text;
        queue_file_attributes.output_submission_option [nfc$oqa_system_routing_text].key :=
              jmc$system_routing_text;
        queue_file_attributes.output_submission_option [nfc$oqa_system_routing_text].system_routing_text :=
              ^output_system_routing_text;

{ Set up the USER_FILE_NAME

        IF protocol_job_name <> '' THEN
          convert_string_to_ost$name (protocol_job_name, user_job_name_prefix, new_name_value);
          queue_file_attributes.output_submission_option [nfc$oqa_user_file_name].key :=
                jmc$user_file_name;
          queue_file_attributes.output_submission_option [nfc$oqa_user_file_name].user_file_name :=
                new_name_value;
        IFEND;

{ If job is from a non-NOS/VE system, set the USER_JOB_NAME to NONE

        IF (remote_host_type <> nfc$p22_nos_ve) AND (remote_host_type <> nfc$p22_nos_ve_qtf) THEN
          queue_file_attributes.output_submission_option [nfc$oqa_user_job_name].key := jmc$user_job_name;
          queue_file_attributes.output_submission_option [nfc$oqa_user_job_name].user_job_name := 'NONE';
        IFEND;

      ELSEIF queue_file_type = nfc$generic_queue_file THEN { Store/Forward generic queue file.
        convert_string_to_ost$name (destination_family, user_job_name_prefix, new_name_value);
        queue_file_attributes.qfile_submission_option [nfc$gqa_destination].key :=
              jmc$destination;
        queue_file_attributes.qfile_submission_option [nfc$gqa_destination].destination :=
              new_name_value;
      IFEND;

    ELSE { Not store and forward queue file }
      IF ((remote_host_type = nfc$p22_nos_ve) OR (remote_host_type = nfc$p22_nos_ve_qtf)) AND
            (queue_file_type = nfc$job_queue_file) THEN

{ Set communication accounting info in JOB_INPUT_DEVICE attribute for jobs.
{ Note that file size is set later - after the file has been received.

        input_accounting_data.size := #SIZE (nft$qtf_input_accounting_data);
        input_accounting_data.data_block.origin_mainframe_name := source_lid;
        input_accounting_data.data_block.dest_mainframe_name := transfer_pid;
        queue_file_attributes.job_submission_option [nfc$iqa_job_input_device].key := jmc$job_input_device;
        queue_file_attributes.job_submission_option [nfc$iqa_job_input_device].job_input_device :=
               ^input_accounting_data.data_string;
      IFEND;

      CASE disposition_code OF
      = nfc$p17_input_return, nfc$p17_input_no_return =

{ Force the DATA_MODE to CODED_DATA

        queue_file_attributes.job_submission_option [nfc$iqa_data_mode].key := jmc$data_mode;
        queue_file_attributes.job_submission_option [nfc$iqa_data_mode].data_mode := jmc$coded_data;

{ Set DEFAULT_LOGIN_FAMILY so if user did not specify on LOGIN card, it won't
{ default to where QTFS is running ($SYSTEM).

        IF (remote_host_type = nfc$p22_nos_ve) OR (remote_host_type = nfc$p22_nos_ve_qtf) THEN
          IF echo_text_login_family <> osc$null_name  THEN
            convert_string_to_ost$name (echo_text_login_family, user_job_name_prefix, new_name_value);
            queue_file_attributes.job_submission_option [nfc$iqa_default_login_family].key :=
                  jmc$default_login_family;
            queue_file_attributes.job_submission_option [nfc$iqa_default_login_family].default_login_family
                  := new_name_value;
          ELSE
            convert_string_to_ost$name (attribute_results^ [2].login_family, user_job_name_prefix,
                  new_name_value);
            queue_file_attributes.job_submission_option [nfc$iqa_default_login_family].key :=
                  jmc$default_login_family;
            queue_file_attributes.job_submission_option [nfc$iqa_default_login_family].default_login_family
                  := new_name_value;
          IFEND;
        IFEND;

{ Save the IMPLICIT_ROUTING_TEXT

        output_implicit_routing_text := implicit_routing_text;
        queue_file_attributes.job_submission_option [nfc$iqa_implicit_routing_text].key :=
              jmc$implicit_routing_text;
        queue_file_attributes.job_submission_option [nfc$iqa_implicit_routing_text].implicit_routing_text :=
              ^output_implicit_routing_text;

{ Ensure job is executed here by setting JOB_DESTINATION to NULL

        queue_file_attributes.job_submission_option [nfc$iqa_job_destination].key :=
              jmc$job_destination_family;
        queue_file_attributes.job_submission_option [nfc$iqa_job_destination].job_destination_family := ' ';

{ Ensure job is executed here by setting JOB_DESTINATION_USAGE

        queue_file_attributes.job_submission_option [nfc$iqa_job_destination_usage].key :=
              jmc$job_destination_usage;
        queue_file_attributes.job_submission_option [nfc$iqa_job_destination_usage].job_destination_usage
              := jmc$ve_qtf_usage;

{ Force the LOGIN_COMMAND_SUPPLIED to TRUE

        queue_file_attributes.job_submission_option [nfc$iqa_login_command_supplied].key :=
              jmc$login_command_supplied;
        queue_file_attributes.job_submission_option [nfc$iqa_login_command_supplied]
              .login_command_supplied := TRUE;

{ Clear out the REMOTE_HOST_DIRECTIVE so that it is NO longer associated with this job

        output_remote_host_directive.size := 0;
        output_remote_host_directive.parameters := '';
        queue_file_attributes.job_submission_option [nfc$iqa_remote_host_directive].key :=
              jmc$remote_host_directive;
        queue_file_attributes.job_submission_option [nfc$iqa_remote_host_directive].remote_host_directive
              := ^output_remote_host_directive;

{ If the previous system was NOS/VE then save the previous SYSTEM_JOB_NAME

        IF ((remote_host_type = nfc$p22_nos_ve) OR (remote_host_type = nfc$p22_nos_ve_qtf)) AND
              (NOT loop_back_transfer) THEN
          queue_file_attributes.job_submission_option [nfc$iqa_system_job_name].key := jmc$system_job_name;
          queue_file_attributes.job_submission_option [nfc$iqa_system_job_name].system_job_name :=
                system_supplied_name;
        IFEND;

{ Set up the USER_JOB_NAME

        IF protocol_job_name <> '' THEN
          convert_string_to_ost$name (protocol_job_name, user_job_name_prefix, new_name_value);
          queue_file_attributes.job_submission_option [nfc$iqa_user_job_name].key :=
                jmc$user_job_name;
          queue_file_attributes.job_submission_option [nfc$iqa_user_job_name].user_job_name
                := new_name_value;
        IFEND;

{ Job executes here and the job output is sent back to the initiating system

        IF disposition_code = nfc$p17_input_return THEN

{ Change the DISPOSITION_CODE to force QTF to set a new one (depending output/job)

          queue_file_attributes.job_submission_option [nfc$iqa_disposition_code].key :=
                jmc$disposition_code;
          queue_file_attributes.job_submission_option [nfc$iqa_disposition_code].disposition_code := '  ';

{ Set OUTPUT_DESTINATION to source logical identifier so initiating mainframe will get output

          queue_file_attributes.job_submission_option [nfc$iqa_output_destination].key :=
                jmc$output_destination;
          queue_file_attributes.job_submission_option [nfc$iqa_output_destination].output_destination :=
                source_lid;

{ Because output is returned, set OUTPUT_DESTINATION_USAGE to QTF

          queue_file_attributes.job_submission_option [nfc$iqa_output_dest_usage].key :=
                jmc$output_destination_usage;
          queue_file_attributes.job_submission_option [nfc$iqa_output_dest_usage]
                .output_destination_usage := jmc$qtf_usage;

{ Set the SOURCE_LOGICAL_ID

          queue_file_attributes.job_submission_option [nfc$iqa_source_logical_id].key :=
                jmc$source_logical_id;
          queue_file_attributes.job_submission_option [nfc$iqa_source_logical_id].source_logical_id :=
                source_lid;

{ Force the generation of a new SYSTEM_ROUTING_TEXT

          output_system_routing_text.size := 0;
          output_system_routing_text.parameters := '';
          queue_file_attributes.output_submission_option [nfc$oqa_system_routing_text].key :=
                jmc$system_routing_text;
          queue_file_attributes.output_submission_option [nfc$oqa_system_routing_text].system_routing_text :=
                ^output_system_routing_text;

{ Job executes here and the job output is printed (or handled here).

        ELSE

{ Force OUTPUT_DESTINATION_USAGE to have the system default destination usage (public,dual_state, etc)

          queue_file_attributes.output_submission_option [nfc$oqa_output_dest_usage].key :=
                jmc$output_destination_usage;
          IF attribute_results^ [1].output_destination_usage = jmc$qtf_usage THEN

{ disallow output_destination_usage of QTF for a output file at its final destination

            queue_file_attributes.output_submission_option [nfc$oqa_output_dest_usage]
                  .output_destination_usage := jmc$public_usage;
            overridden_jad_odu := TRUE;
          ELSE
            queue_file_attributes.output_submission_option [nfc$oqa_output_dest_usage]
                  .output_destination_usage := attribute_results^ [1].output_destination_usage;
          IFEND;

{ Force OUTPUT_DISPOSITION to printer to avoid problems with LOCAL

          queue_file_attributes.job_submission_option [nfc$iqa_output_disposition].key :=
                jmc$output_disposition;
          queue_file_attributes.job_submission_option [nfc$iqa_output_disposition]
                .output_disposition.key := jmc$normal_output_disposition;
        IFEND;

      = nfc$p17_line_printer, nfc$p17_hollerith_card_punch, nfc$p17_binary_checksummed_cp,
            nfc$p17_special_output =

{ If the output is from a non-NOS/VE system, use the protocol_job_name as the COMMENT_BANNER

        IF (remote_host_type <> nfc$p22_nos_ve) AND (remote_host_type <> nfc$p22_nos_ve_qtf) THEN
          convert_string_to_ost$name (protocol_job_name, user_job_name_prefix, new_name_value);
          queue_file_attributes.output_submission_option [nfc$oqa_comment_banner].key := jmc$comment_banner;
          queue_file_attributes.output_submission_option [nfc$oqa_comment_banner].comment_banner :=
                new_name_value;
        IFEND;

{ Set up the DATA_MODE

        IF remote_host_type <> nfc$p22_nos_ve_qtf THEN
          queue_file_attributes.output_submission_option [nfc$oqa_data_mode].key := jmc$data_mode;
          CASE transfer_mode OF
          = nfc$rhf_structured_mode, nfc$transparent_data_mode =
            queue_file_attributes.output_submission_option [nfc$oqa_data_mode].data_mode :=
                  jmc$transparent_data;
          = nfc$coded_data_mode, nfc$ve_to_ve_mode =
            queue_file_attributes.output_submission_option [nfc$oqa_data_mode].data_mode := jmc$coded_data;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
                  'QTFS bad DM case create_queue_file_attributes', status);
            RETURN;
          CASEND;
        IFEND;

{ Save the IMPLICIT_ROUTING_TEXT

        output_implicit_routing_text := implicit_routing_text;
        queue_file_attributes.output_submission_option [nfc$oqa_implicit_routing_text].key :=
              jmc$implicit_routing_text;
        queue_file_attributes.output_submission_option [nfc$oqa_implicit_routing_text].implicit_routing_text
              := ^output_implicit_routing_text;

{ If the output is from a non-NOS/VE system, use the transfer_pid as the OUTPUT_DESTINATION

        IF (remote_host_type <> nfc$p22_nos_ve) AND (remote_host_type <> nfc$p22_nos_ve_qtf) THEN
          convert_string_to_ost$name (transfer_pid, user_job_name_prefix, new_name_value);
          queue_file_attributes.output_submission_option [nfc$oqa_output_destination].key :=
                jmc$output_destination;
          queue_file_attributes.output_submission_option [nfc$oqa_output_destination].output_destination :=
                new_name_value;
        IFEND;

{ Force OUTPUT_DESTINATION_USAGE to have the system default destination usage (public,dual_state, etc)

        queue_file_attributes.output_submission_option [nfc$oqa_output_dest_usage].key :=
              jmc$output_destination_usage;
        IF attribute_results^ [1].output_destination_usage = jmc$qtf_usage THEN

{ disallow output_destination_usage of QTF for a output file at its final destination

          queue_file_attributes.output_submission_option  [nfc$oqa_output_dest_usage]
                .output_destination_usage := jmc$public_usage;
           overridden_jad_odu := TRUE;
         ELSE
          queue_file_attributes.output_submission_option [nfc$oqa_output_dest_usage]
                .output_destination_usage := attribute_results^ [1].output_destination_usage;
         IFEND;

{ If the output is from a non-NOS/VE system, force the OUTPUT_DISPOSITION to be PRINTER.
{ This is done to prevent JMP$PRINT_FILE from using the ODI job attribute from the $SYSTEM
{ job where QTF is executing. For NOS/VE queue files, JMP$PRINT_FILE will obtain the ODI
{ information from the queue file's system label.

        IF (remote_host_type <> nfc$p22_nos_ve) AND (remote_host_type <> nfc$p22_nos_ve_qtf) THEN
          queue_file_attributes.output_submission_option [nfc$oqa_output_disposition].key :=
                jmc$output_disposition;
          queue_file_attributes.output_submission_option [nfc$oqa_output_disposition]
                .output_disposition.key := jmc$normal_output_disposition;
        IFEND;

{ Clear out the REMOTE_HOST_DIRECTIVE so that it is NO longer associated with this output file

        output_remote_host_directive.size := 0;
        output_remote_host_directive.parameters := '';
        queue_file_attributes.output_submission_option [nfc$oqa_remote_host_directive].key :=
              jmc$remote_host_directive;
        queue_file_attributes.output_submission_option [nfc$oqa_remote_host_directive].remote_host_directive
              := ^output_remote_host_directive;

{ If the output is from a non-NOS/VE system, use the protocol_job_name as the ROUTING_BANNER

        IF (remote_host_type <> nfc$p22_nos_ve) AND (remote_host_type <> nfc$p22_nos_ve_qtf) THEN
            convert_string_to_ost$name (protocol_job_name, user_job_name_prefix, new_name_value);
            queue_file_attributes.output_submission_option [nfc$oqa_routing_banner].key := jmc$routing_banner;
            queue_file_attributes.output_submission_option [nfc$oqa_routing_banner].routing_banner :=
                  new_name_value;
          IFEND;

{ If the previous system was NOS/VE then save the previous SYSTEM_FILE_NAME

        IF ((remote_host_type = nfc$p22_nos_ve) OR (remote_host_type = nfc$p22_nos_ve_qtf)) AND
              (NOT loop_back_transfer) THEN
          queue_file_attributes.output_submission_option [nfc$oqa_system_file_name].key :=
                jmc$system_file_name;
          queue_file_attributes.output_submission_option [nfc$oqa_system_file_name].system_file_name :=
                system_supplied_name;
        IFEND;

{ Set up the USER_FILE_NAME

        IF protocol_job_name <> '' THEN
          convert_string_to_ost$name (protocol_job_name, user_job_name_prefix, new_name_value);
          queue_file_attributes.output_submission_option [nfc$oqa_user_file_name].key :=
                jmc$user_file_name;
          queue_file_attributes.output_submission_option [nfc$oqa_user_file_name].user_file_name :=
                new_name_value;
        IFEND;

{ If the output is from a non-NOS/VE system, use the protocol_job_name as the USER_JOB_NAME

        IF (remote_host_type <> nfc$p22_nos_ve) AND (remote_host_type <> nfc$p22_nos_ve_qtf) THEN
          convert_string_to_ost$name (protocol_job_name, user_job_name_prefix, new_name_value);
          queue_file_attributes.output_submission_option [nfc$oqa_user_job_name].key := jmc$user_job_name;
          queue_file_attributes.output_submission_option [nfc$oqa_user_job_name].user_job_name :=
                new_name_value;
        IFEND;
      = nfc$p17_generic_queue =

{ Clear out the REMOTE_HOST_DIRECTIVE so that it is NO longer associated with this generic queue file

        output_remote_host_directive.size := 0;
        output_remote_host_directive.parameters := '';
        queue_file_attributes.qfile_submission_option [nfc$gqa_remote_host_directive].key :=
              jmc$remote_host_directive;
        queue_file_attributes.qfile_submission_option [nfc$gqa_remote_host_directive].remote_host_directive
              := ^output_remote_host_directive;
      CASEND;
    IFEND;

{ Crack various texts to get queue attributes, then submit or print

    IF NOT store_and_forward_queue_file THEN
      IF (queue_file_type = nfc$job_queue_file) THEN
        IF (remote_host_type <> nfc$p22_nos_ve) AND (remote_host_type <> nfc$p22_nos_ve_qtf) THEN
          IF system_routing_text.size > 0 THEN
            crack_system_routing_text (system_routing_text, queue_file_type,
                  $nft$output_queue_attributes_set [], $nft$input_queue_attributes_set [],
                  queue_file_attributes, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;

        IF (explicit_routing_text.head <> NIL) AND (STRLENGTH (explicit_routing_text.head^.line) > 0) THEN
          crack_submit_job_command (explicit_routing_text.head^.line, queue_file_attributes, status);
        IFEND;
      ELSEIF queue_file_type = nfc$print_queue_file THEN
        IF implicit_routing_text.size > 0 THEN
          crack_implicit_routing_text (implicit_routing_text, nos_ve_implicit_text, queue_file_attributes,
                queue_file_page_width, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF (remote_host_type <> nfc$p22_nos_ve) AND (remote_host_type <> nfc$p22_nos_ve_qtf) THEN
          IF system_routing_text.size > 0 THEN
            srt_no_override_output_attribs := $nft$output_queue_attributes_set [nfc$oqa_user_file_name];

            IF queue_file_attributes.output_submission_option [nfc$oqa_control_family].key <>
                  jmc$null_attribute THEN
              srt_no_override_output_attribs := srt_no_override_output_attribs +
                      $nft$output_queue_attributes_set [nfc$oqa_control_family];
            IFEND;

            IF queue_file_attributes.output_submission_option [nfc$oqa_control_user].key <>
                  jmc$null_attribute THEN
              srt_no_override_output_attribs := srt_no_override_output_attribs +
                      $nft$output_queue_attributes_set [nfc$oqa_control_user];
            IFEND;

            IF queue_file_attributes.output_submission_option [nfc$oqa_login_account].key <>
                  jmc$null_attribute THEN
              srt_no_override_output_attribs := srt_no_override_output_attribs +
                      $nft$output_queue_attributes_set [nfc$oqa_login_account];
            IFEND;

            IF queue_file_attributes.output_submission_option [nfc$oqa_login_project].key <>
                  jmc$null_attribute THEN
              srt_no_override_output_attribs := srt_no_override_output_attribs +
                      $nft$output_queue_attributes_set [nfc$oqa_login_project];
            IFEND;

            IF (queue_file_attributes.output_submission_option [nfc$oqa_disposition_code].key <>
                  jmc$null_attribute) AND (queue_file_attributes.output_submission_option
                  [nfc$oqa_disposition_code].disposition_code = nfc$p17_wait_queue) THEN
              srt_no_override_output_attribs := srt_no_override_output_attribs +
                      $nft$output_queue_attributes_set [nfc$oqa_disposition_code];
            IFEND;

            crack_system_routing_text (system_routing_text, queue_file_type, srt_no_override_output_attribs,
                  $nft$input_queue_attributes_set [], queue_file_attributes, status);
            IF NOT status.normal THEN
              RETURN;
            ELSEIF (queue_file_attributes.output_submission_option [nfc$oqa_external_characteristic].key =
                  jmc$external_characteristics) AND (queue_file_attributes.output_submission_option
                  [nfc$oqa_external_characteristic].external_characteristics =
                  nfc$external_characteristic_a9) THEN
              queue_file_attributes.output_submission_option [nfc$oqa_external_characteristic]
                    .external_characteristics := nfc$normal_string;
            IFEND;
          IFEND;
        IFEND;

        IF (explicit_routing_text.head <> NIL) AND (STRLENGTH (explicit_routing_text.head^.line) > 0) THEN
          crack_print_file_command (explicit_routing_text.head^.line, queue_file_attributes,
                queue_file_page_width, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        IF (queue_file_attributes.output_submission_option [nfc$oqa_output_dest_usage].key =
              jmc$output_destination_usage) AND (queue_file_attributes.output_submission_option
              [nfc$oqa_output_dest_usage].output_destination_usage = jmc$qtf_usage) AND
              (nos_ve_implicit_text) THEN

{ Destroy the old implicit routing text to avoid infinite queue loop

          output_implicit_routing_text.text := '';
          output_implicit_routing_text.size := 0;
          queue_file_attributes.output_submission_option [nfc$oqa_implicit_routing_text].key :=
                jmc$implicit_routing_text;
          queue_file_attributes.output_submission_option [nfc$oqa_implicit_routing_text]
               .implicit_routing_text := ^output_implicit_routing_text;
        IFEND;

        IF (remote_host_type <> nfc$p22_nos_ve) AND (remote_host_type <> nfc$p22_nos_ve_qtf) THEN

{ If the output is from a non-NOS/VE system and the control_family is not defined,
{ then use the source_lid as the CONTROL_FAMILY

          IF queue_file_attributes.output_submission_option [nfc$oqa_control_family].key =
                jmc$null_attribute THEN
            convert_string_to_ost$name (source_lid, user_job_name_prefix, new_name_value);
            queue_file_attributes.output_submission_option [nfc$oqa_control_family].key := jmc$control_family;
            queue_file_attributes.output_submission_option [nfc$oqa_control_family].control_family :=
                  new_name_value;
          IFEND;

{ If the output is from a non-NOS/VE system and the control_user is not defined,
{ then use the protocol_job_name as the CONTROL_USER

          IF queue_file_attributes.output_submission_option [nfc$oqa_control_family].key =
                jmc$null_attribute THEN

            convert_string_to_ost$name (protocol_job_name, user_job_name_prefix, new_name_value);
            queue_file_attributes.output_submission_option [nfc$oqa_control_user].key := jmc$control_user;
            queue_file_attributes.output_submission_option [nfc$oqa_control_user].control_user :=
                  new_name_value;
          IFEND;

{ If the output is from a non-NOS system and the login_account is not defined,
{ use the value of 'NONE'.

          IF queue_file_attributes.output_submission_option [nfc$oqa_login_account].key =
                  jmc$null_attribute THEN
            queue_file_attributes.output_submission_option [nfc$oqa_login_account].key :=
                jmc$login_account;
            queue_file_attributes.output_submission_option [nfc$oqa_login_account].login_account :=
                'NONE';
          IFEND;

{ If the output is from a non-NOS system and the login_family is not defined,
{ use the value of 'NONE'.

          IF queue_file_attributes.output_submission_option [nfc$oqa_login_family].key =
                jmc$null_attribute THEN
            queue_file_attributes.output_submission_option [nfc$oqa_login_family].key :=
                jmc$login_family;
            queue_file_attributes.output_submission_option [nfc$oqa_login_family].login_family :=
                'NONE';
          IFEND;

{ If the output is from a non-NOS system and the login_project is not defined,
{ use the value of 'NONE'.

          IF queue_file_attributes.output_submission_option [nfc$oqa_login_project].key =
                jmc$null_attribute THEN
            queue_file_attributes.output_submission_option [nfc$oqa_login_project].key :=
                jmc$login_project;
            queue_file_attributes.output_submission_option [nfc$oqa_login_project].login_project :=
                'NONE';
          IFEND;

{ If the output is from a non-NOS system and the login_user is not defined,
{ use the value of 'NONE'.

          IF queue_file_attributes.output_submission_option [nfc$oqa_login_user].key =
                jmc$null_attribute THEN
            queue_file_attributes.output_submission_option [nfc$oqa_login_user].key :=
                jmc$login_user;
            queue_file_attributes.output_submission_option [nfc$oqa_login_user].login_user :=
                'NONE';
          IFEND;
        IFEND;
      ELSEIF queue_file_type = nfc$generic_queue_file THEN
        IF (explicit_routing_text.head <> NIL) AND (STRLENGTH (explicit_routing_text.head^.line) > 0) THEN
          crack_generic_command (explicit_routing_text.head^.line, queue_file_attributes, status);
        IFEND;
      IFEND;
    IFEND;

{ Handle loop back possibility, this should cause JM to produce a new system job name/file name

    IF loop_back_transfer THEN
      IF queue_file_type = nfc$job_queue_file THEN
        queue_file_attributes.job_submission_option [nfc$iqa_system_job_name].key := jmc$system_job_name;
        queue_file_attributes.job_submission_option [nfc$iqa_system_job_name].system_job_name :=
              jmc$blank_system_supplied_name;
      ELSEIF queue_file_type = nfc$print_queue_file THEN
        queue_file_attributes.output_submission_option [nfc$oqa_system_file_name].key := jmc$system_file_name;
        queue_file_attributes.output_submission_option [nfc$oqa_system_file_name].system_file_name :=
              jmc$blank_system_supplied_name;
      IFEND;
    IFEND;

  PROCEND create_queue_file_attributes;
?? TITLE := 'emit_qtfs_output_stat', EJECT ??

{ PURPOSE:
{   This procedure emits the destination queue file transfer communication
{   accounting statistic for output files.
{ DESIGN:
{   The statistic data is assembled and then Procedure
{   jmp$emit_communication_stat is called to emit the statistic.
{ NOTES:
{  The communication accounting statistic for jobs is emitted elsewhere,
{  at job begin.

  PROCEDURE emit_qtfs_output_stat
    (    output_file_name: amt$local_file_name;
         origin_mainframe_name: string ( * <= osc$max_name_size);
         dest_mainframe_name: string ( * <= osc$max_name_size);
         file_size: nft$parameter_06_values;
         system_job_name: jmt$system_supplied_name,
         queue_file_attributes: nft$queue_submission_option);

    VAR
     qtfs_statistic: jmt$qtf_dest_statistic_data,
     statistic_data: jmt$comm_acct_statistic_data;

    qtfs_statistic.kind := jmc$output_file;
    qtfs_statistic.output_file_name := output_file_name;
    qtfs_statistic.data.file_size := file_size;
    qtfs_statistic.data.user_identification.user := queue_file_attributes.output_submission_option
       [nfc$oqa_login_user].login_user;
    qtfs_statistic.data.user_identification.family := queue_file_attributes.output_submission_option
       [nfc$oqa_login_family].login_family;
    qtfs_statistic.data.account_name := queue_file_attributes.output_submission_option
       [nfc$oqa_login_account].login_account;
    qtfs_statistic.data.project_name := queue_file_attributes.output_submission_option
       [nfc$oqa_login_project].login_project;
    qtfs_statistic.data.system_job_name := system_job_name;
    qtfs_statistic.data.user_job_name := queue_file_attributes.output_submission_option
       [nfc$oqa_user_job_name].user_job_name;
    qtfs_statistic.data.origin_mainframe_name := origin_mainframe_name;
    qtfs_statistic.data.dest_mainframe_name := dest_mainframe_name;

    statistic_data.statistic_id := jmc$ca_dest_qf_transfer;
    statistic_data.dest_queue_file_transfer := ^qtfs_statistic;

    jmp$emit_communication_stat( statistic_data );

  PROCEND emit_qtfs_output_stat;
?? TITLE := 'find_position_parameter_list', EJECT ??

{ PURPOSE:
{   This procedure will search a string for a pattern(string) starting at the next
{   non-blank character.

  PROCEDURE find_position_parameter_list
    (    command_line: string ( * <= maximum_size_qtfs_scl_command);
         expected_command: string ( * <= maximum_size_qtfs_scl_command);
     VAR parameter_list_position: integer;
     VAR status: ost$status);

    VAR
      command_line_length: 0 .. maximum_size_qtfs_scl_command,
      expected_command_length: 0 .. maximum_size_qtfs_scl_command,
      position_start_command: 0 .. maximum_size_qtfs_scl_command,
      upper_case_command_line: string (maximum_size_qtfs_scl_command),
      upper_case_expected_command: string (maximum_size_qtfs_scl_command);

    status.normal := TRUE;
    command_line_length := STRLENGTH (command_line);
    expected_command_length := STRLENGTH (expected_command);
    IF (command_line_length < 1) OR (expected_command_length < 1) THEN
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
            'QTFS find_position_parameter_list length error', status);
      RETURN;
    IFEND;

  /skip_blank_characters/
    FOR position_start_command := 1 TO command_line_length DO
      IF (command_line (position_start_command, 1) <> ' ') THEN
        EXIT /skip_blank_characters/;
      IFEND;
    FOREND /skip_blank_characters/;

    IF STRLENGTH (command_line (position_start_command, * )) < expected_command_length THEN
      osp$set_status_abnormal (nfc$status_id, nfe$invalid_explicit_text, command_line, status);
      RETURN;
    IFEND;

    #translate (osv$lower_to_upper, command_line, upper_case_command_line);
    #translate (osv$lower_to_upper, expected_command, upper_case_expected_command);

    IF upper_case_command_line (position_start_command, expected_command_length) = upper_case_expected_command
          THEN
      parameter_list_position := position_start_command + expected_command_length;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$invalid_explicit_text, command_line, status);
    IFEND;

  PROCEND find_position_parameter_list;
?? TITLE := 'first_character_is_letter', EJECT ??

  FUNCTION first_character_is_letter
    (    value: string (1)): boolean;

    TYPE
      set_of_char = set of char;

    VAR
      compare_character: char,
      letter_set: [STATIC, READ] set_of_char := ['A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L',
            'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', 'e',
            'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x',
            'y', 'z'];

    compare_character := value (1);
    IF compare_character IN letter_set THEN
      first_character_is_letter := TRUE;
    ELSE
      first_character_is_letter := FALSE;
    IFEND;

  FUNCEND first_character_is_letter;
?? TITLE := 'initialize_rft_parameters', EJECT ??

{ PURPOSE:
{   This procedure initializes the control block before each RFT is received.

  PROCEDURE initialize_rft_parameters
    (VAR control_block: nft$control_block);

    VAR
      ignore_status: ost$status;

    control_block.data_xfer_complete := FALSE;
    control_block.state_of_transfer.normal := TRUE;
    control_block.remote_status.normal := TRUE;
    control_block.local_status.normal := TRUE;
    control_block.data_declaration := nfc$p31_unspecified;
    control_block.disposition_code := nfc$p17_line_printer;
    control_block.receive_systems_routing_text.size := 0;
    control_block.send_systems_routing_text.size := 0;
    control_block.receive_implicit_routing_text.size := 0;
    control_block.send_implicit_routing_text.size := 0;
    IF (control_block.received_directives.head <> NIL) THEN
      nfp$deallocate_dirs_from_head (control_block.received_directives, ignore_status);
    IFEND;
    IF (control_block.send_directives <> NIL) THEN
      nfp$dequeue_directives_on_list (control_block.send_directives, ignore_status);
    IFEND;
    IF (control_block.received_operator_messages.head <> NIL) THEN
      nfp$deallocate_dirs_from_head (control_block.received_operator_messages, ignore_status);
    IFEND;
    IF (control_block.send_operator_messages <> NIL) THEN
      nfp$dequeue_directives_on_list (control_block.send_operator_messages, ignore_status);
    IFEND;
    IF (control_block.received_user_messages.head <> NIL) THEN
      nfp$deallocate_dirs_from_head (control_block.received_user_messages, ignore_status);
    IFEND;
    IF (control_block.send_user_messages <> NIL) THEN
      nfp$dequeue_directives_on_list (control_block.send_user_messages, ignore_status);
    IFEND;
    IF (control_block.received_account_messages.head <> NIL) THEN
      nfp$deallocate_dirs_from_head (control_block.received_account_messages, ignore_status);
    IFEND;
    IF (control_block.send_account_messages <> NIL) THEN
      nfp$dequeue_directives_on_list (control_block.send_account_messages, ignore_status);
    IFEND;
    IF (control_block.received_errorlog_messages.head <> NIL) THEN
      nfp$deallocate_dirs_from_head (control_block.received_errorlog_messages, ignore_status);
    IFEND;
    IF (control_block.send_errorlog_messages <> NIL) THEN
      nfp$dequeue_directives_on_list (control_block.send_errorlog_messages, ignore_status);
    IFEND;

  PROCEND initialize_rft_parameters;
?? TITLE := 'print_queue_job', EJECT ??

{ PURPOSE:
{   This procedure will convert the queue_file_attributes to parameters for
{   jmp$print_file, and call jmp$print_file.

  PROCEDURE print_queue_job
    (    file_name: fst$file_reference;
         queue_file_attributes: nft$queue_submission_option;
     VAR job_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      array_index: integer,
      number_output_options: integer,
      output_submission_options: ^jmt$output_submission_options,
      option_index: nft$output_queue_attributes;

    status.normal := TRUE;

    number_output_options := $INTEGER (UPPERVALUE (nft$output_queue_attributes)) -
          $INTEGER (LOWERVALUE (nft$output_queue_attributes)) + 1;
    PUSH output_submission_options: [1 .. number_output_options];
    array_index := 1;
    FOR option_index := LOWERVALUE (nft$output_queue_attributes) TO UPPERVALUE (nft$output_queue_attributes)
          DO
      output_submission_options^ [array_index] := queue_file_attributes.output_submission_option
            [option_index];
      array_index := array_index + 1;
    FOREND;

    jmp$print_file (file_name, output_submission_options, job_name, status);

  PROCEND print_queue_job;
?? TITLE := 'qtfs_a_to_a_protocol', EJECT ??

{ PURPOSE:
{   This procedure is the protocol driver for QTFS.  It sequences the protocol
{   commands correctly for file transfers.  If a file is successfully sent,
{   the file is disposed to job management accordingly.

  PROCEDURE qtfs_a_to_a_protocol
    (    store_forward_file_name: amt$local_file_name;
     VAR control_block: nft$control_block;
     VAR status: ost$status);

    VAR
      additional_parameters: nft$parameter_set,
      change_file_attributes: ^amt$file_attributes,
      file_attributes: ^fst$attachment_options,
      file_size: amt$file_length,
      ignore_status: ost$status,
      ignored_parameters: nft$parameter_set,
      input_accounting_data: qtfs_input_accounting_data,
      loop_back_transfer: boolean,
      modified_parameters: nft$parameter_set,
      output_creation_attributes: ^fst$file_cycle_attributes,
      overridden_jad_odu: boolean,
      protocol_consistent: boolean,
      queue_file_attributes: nft$queue_submission_option,
      queue_file_page_width: amt$page_width,
      queue_file_type: nft$queue_file_type,
      received_parameters: nft$parameter_set,
      rft_parameters: nft$parameter_set,
      rpos_parameters: nft$parameter_set,
      store_and_forward_queue_file: boolean,
      system_supplied_name: jmt$system_supplied_name,
      transfer_mode: nft$transfer_modes,
      wait_queue: wait_queue_information;

{     Receive RFT
    status.normal := TRUE;
    queue_file_page_width := 1;
    overridden_jad_odu := FALSE;
    initialize_rft_parameters (control_block);
    nfp$receive_command ($nft$command_set [nfc$rft], nfv$qtf_required_params_on_cmds, control_block,
          rft_parameters, ignored_parameters, modified_parameters, status);
    IF NOT control_block.path.path_connected THEN
      RETURN;
    IFEND;
    IF (NOT status.normal) AND ((status.condition = nfe$invalid_protocol_command) OR
          (status.condition = nfe$invalid_param_count) OR
          (status.condition = nfe$invalid_command_code)) THEN
      RETURN;
    IFEND;

{     Main queue file transfer loop

  /receive_file_loop/
    WHILE TRUE DO
      IF status.normal THEN
        analyze_received_rft (rft_parameters, store_forward_file_name, control_block, transfer_mode,
              store_and_forward_queue_file, rpos_parameters, queue_file_attributes, queue_file_type,
              loop_back_transfer, input_accounting_data, overridden_jad_odu, queue_file_page_width, status);
      IFEND;

      nfp$set_abnormal_if_normal (status, control_block.local_status);
      IF status.normal THEN

{     Send RPOS to client application

        nfp$send_command (nfc$rpos, rpos_parameters,
             $nft$parameter_set[], $nft$parameter_set[],
             control_block, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{     Receive GO or STOP if problem with RPOS

        nfp$receive_command ($nft$command_set [nfc$go, nfc$stop], nfv$qtf_required_params_on_cmds,
              control_block, received_parameters, ignored_parameters, modified_parameters, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{     Receive the queue file

        IF control_block.last_command_received <> nfc$stop THEN
          pmp$get_unique_name (control_block.file_name, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{     The queue file page width is obtained in crack_print_file_parameters }

        IF  control_block.remote_host_type <>   nfc$p22_nos_ve_qtf  THEN
          IF (queue_file_page_width <> 1) AND (queue_file_page_width <> 132)  THEN
           change_page_width ( control_block.file_name,queue_file_page_width,status );
          IFEND;
        IFEND;

          nfp$receive_queue_file (control_block.path.network_file_id, control_block.file_name,
                control_block.transfer_facilities, transfer_mode, control_block.data_block_size,
                control_block.time_out, control_block.protocol_in_use, control_block.path.network_type,
                control_block.protocol_trace, file_size, protocol_consistent, control_block.state_of_transfer,
                status);
          IF NOT protocol_consistent THEN
            amp$return (control_block.file_name, ignore_status);
            RETURN;
          IFEND;
          nfp$set_abnormal_if_normal (status, control_block.local_status);
        ELSE
          IF control_block.state_of_transfer.normal THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sender_problem_no_retry, '', status);
          IFEND;
        IFEND;
      ELSE

{     Send an RNEG

        osp$set_status_abnormal (nfc$status_id, nfv$p04_values [nfc$p04_transfer_rejected_messa].condition,
              '', control_block.state_of_transfer);
        nfp$set_abnormal_if_normal (status, control_block.local_status);
        nfp$send_command (nfc$rneg, nfv$qtf_required_params_on_cmds [nfc$rneg],
             $nft$parameter_set[], $nft$parameter_set[ ],
             control_block, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

{     Receive the STOP if file was transferred

      IF control_block.last_command_received <> nfc$stop THEN
        nfp$receive_command ($nft$command_set [nfc$stop], nfv$qtf_required_params_on_cmds, control_block,
              received_parameters, ignored_parameters, modified_parameters, status);
        IF (NOT control_block.path.path_connected) THEN
          amp$return (control_block.file_name, ignore_status);
          RETURN;
        ELSEIF (NOT status.normal) AND ((status.condition = nfe$invalid_protocol_command) OR
              (status.condition = nfe$invalid_param_count) OR (status.condition = nfe$invalid_command_code))
              THEN
          amp$return (control_block.file_name, ignore_status);
          RETURN;
        ELSE
          IF (control_block.state_of_transfer.normal) AND (control_block.local_status.normal) AND
                (control_block.remote_status.normal) THEN

{     Transfer is o.k., try to submit/print queue file

            IF queue_file_type = nfc$job_queue_file THEN
              input_accounting_data.data_block.file_size := file_size;
              submit_queue_job (control_block.file_name, queue_file_attributes, system_supplied_name, status);

{ Note: Communication accounting statistic for input file is not emitted here.
{       It is emitted later, at job_begin time.

              IF NOT (status.normal) THEN
                IF (status.condition = jme$maximum_jobs) OR (status.condition = jme$no_space_for_file) THEN
                  osp$set_status_abnormal (nfc$status_id, nfv$p04_values [nfc$p04_receiver_problem_retry].
                        condition, '', control_block.state_of_transfer);
                ELSE
                  osp$set_status_abnormal (nfc$status_id, nfv$p04_values [nfc$p04_receiver_problem_noretr].
                        condition, '', control_block.state_of_transfer);
                IFEND;
              IFEND;
            ELSEIF queue_file_type = nfc$print_queue_file THEN
              IF (control_block.remote_host_type <> nfc$p22_nos_ve) AND (control_block.remote_host_type <>
                    nfc$p22_nos_ve_qtf) AND (transfer_mode <> nfc$transparent_data_mode) THEN
                PUSH change_file_attributes: [1 .. 1];
                change_file_attributes^ [1].key := amc$file_contents;
                change_file_attributes^ [1].file_contents := amc$list;
                amp$change_file_attributes (control_block.file_name, change_file_attributes, status);
              IFEND;

              check_wait_queue_file (queue_file_attributes, control_block.remote_host_type, wait_queue);
              IF wait_queue.use_wait_queue THEN
                PUSH output_creation_attributes: [1..1];
                output_creation_attributes^ [1].selector := fsc$ring_attributes;
                output_creation_attributes^ [1].ring_attributes.r1 := osc$user_ring;
                output_creation_attributes^ [1].ring_attributes.r2 := osc$user_ring;
                output_creation_attributes^ [1].ring_attributes.r3 := osc$user_ring;
                fsp$copy_file (control_block.file_name, wait_queue.wait_queue_file_name, NIL, NIL,
                      output_creation_attributes, status);
                IF status.normal THEN
                  IF control_block.protocol_in_use = nfc$p00_a101 THEN
                    system_supplied_name := '           $WAITQUE';
                  ELSE
                    system_supplied_name := '        $WAIT_QUEUE';
                  IFEND;
                ELSE
                  print_queue_job (control_block.file_name, queue_file_attributes, system_supplied_name,
                        status);
                IFEND;
                amp$return (wait_queue.wait_queue_file_name, ignore_status);
              ELSE  { print the output queue file }
                print_queue_job (control_block.file_name, queue_file_attributes, system_supplied_name,
                      status);
              IFEND;
              IF status.normal THEN
                emit_qtfs_output_stat (control_block.file_name, control_block.source_lid.value (1,
                      control_block.source_lid.size), control_block.transfer_pid (1, control_block.
                      transfer_pid_length), control_block.file_size, control_block.system_job_name,
                      queue_file_attributes);
              ELSE
                IF (status.condition = jme$maximum_output) OR (status.condition = jme$no_space_for_file) THEN
                  osp$set_status_abnormal (nfc$status_id, nfv$p04_values [nfc$p04_receiver_problem_retry].
                        condition, '', control_block.state_of_transfer);
                ELSE
                  osp$set_status_abnormal (nfc$status_id, nfv$p04_values [nfc$p04_receiver_problem_noretr].
                        condition, '', control_block.state_of_transfer);
                IFEND;
              IFEND;
            ELSE { queue_file_type = nfc$generic_queue_file
              submit_generic_queue_file(control_block.file_name, queue_file_attributes, system_supplied_name,
                    status);
            IFEND;
            nfp$set_abnormal_if_normal (status, control_block.local_status);
          IFEND;
        IFEND;
      IFEND;

{     Return the local version of the received queue file

      amp$return (control_block.file_name, ignore_status);

{ if the output_destination_usage was changed from the job_attribute_default of QTF to PUBLIC
{ then display an informative message into the system's job_log

      IF overridden_jad_odu THEN
        osp$set_status_abnormal (nfc$status_id, nfe$qtfs_chg_jad_qtf_to_public, system_supplied_name,
              ignore_status);
        nfp$format_message_to_job_log (ignore_status);
      IFEND;

{     if we are receiving a queue file from an A101 system send the significant part
{     of the system_supplied_name (last 8 characters) back to the A101 system

      IF control_block.protocol_in_use = nfc$p00_a101 THEN
        system_supplied_name := system_supplied_name (12, *);
      IFEND;

{ Send the STOPR

      qtfs_send_stopr (system_supplied_name, control_block, status);
      IF (NOT control_block.path.path_connected) THEN
        RETURN;
      IFEND;

{ Receive ETP or RFT (indicating receive another queue file)

      initialize_rft_parameters (control_block);

{ Reset page_width flag

      queue_file_page_width := 1;
      qtfs_receive_rft_or_etp (control_block, status);
      IF (NOT control_block.path.path_connected) THEN
        RETURN;
      IFEND;
      IF control_block.last_command_received = nfc$etp THEN
        EXIT /receive_file_loop/;
      IFEND;
    WHILEND /receive_file_loop/;

{     Disconnect path (standard normal termination)

    complete_qtfs_protocol (control_block);

  PROCEND qtfs_a_to_a_protocol;
?? TITLE := 'qtfs_receive_rft_or_etp', EJECT ??

{ PURPOSE:
{   This procedure receives the protocol command which indicates
{   if any more files are to be received on this connection.

  PROCEDURE qtfs_receive_rft_or_etp
    (VAR control_block: nft$control_block;
     VAR status: ost$status);

    VAR
      ignored_parameters: nft$parameter_set,
      modified_parameters: nft$parameter_set,
      received_parameters: nft$parameter_set;

    status.normal := TRUE;
    nfp$receive_command ($nft$command_set [nfc$rft, nfc$etp], nfv$qtf_required_params_on_cmds, control_block,
          received_parameters, ignored_parameters, modified_parameters, status);
    IF (NOT status.normal) AND ((status.condition = nfe$invalid_protocol_command) OR
          (status.condition = nfe$invalid_param_count) OR (status.condition = nfe$invalid_command_code)) THEN
      nfp$terminate_path (control_block.application, FALSE, control_block.path, status);
      RETURN;
    IFEND;

  PROCEND qtfs_receive_rft_or_etp;
?? TITLE := 'qtfs_send_stopr', EJECT ??

{ PURPOSE:
{   This procedure will send an appropriate STOPR command to the initiating application
{   (QTF).  The STOPR command indicates if the transfer was successfull, unsuccessfull
{   and retryable, or just unsuccessfull.  If the submit_job or print_file was sucessful,
{   the job name is returned.  If an error occurred, a text message describing the
{   error is returned.

  PROCEDURE qtfs_send_stopr
    (    system_supplied_name: jmt$system_supplied_name;
     VAR control_block: nft$control_block;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      status_list: nft$directive_entry_list_head,
      stopr_parameters: nft$parameter_set;

    status.normal := TRUE;
    stopr_parameters := nfv$qtf_required_params_on_cmds [nfc$stopr];

{     Force bad state of transfer if something wrong

    IF (control_block.state_of_transfer.normal) AND NOT (control_block.local_status.normal) THEN
      osp$set_status_abnormal (nfc$status_id, nfe$transfer_rejected_message, '',
            control_block.state_of_transfer);
    IFEND;

    IF control_block.state_of_transfer.normal THEN
      stopr_parameters := stopr_parameters + $nft$parameter_set [nfc$job_name];
      control_block.send_job_name.size := STRLENGTH (system_supplied_name);
      control_block.send_job_name.value := system_supplied_name;
    ELSE
      IF NOT (control_block.local_status.normal) THEN
        stopr_parameters := stopr_parameters + $nft$parameter_set [nfc$user_message];
        status_list.head := NIL;
        status_list.tail := NIL;
        nfp$enqueue_status_directive (control_block.local_status, status_list, status);
        control_block.send_user_messages := status_list.head;
      IFEND;
    IFEND;

    nfp$send_command (nfc$stopr, stopr_parameters,
      $nft$parameter_set[], $nft$parameter_set[],
      control_block, status);
    IF (control_block.send_user_messages <> NIL) THEN
      nfp$dequeue_directives_on_list (control_block.send_user_messages, ignore_status);
    IFEND;

  PROCEND qtfs_send_stopr;
?? TITLE := 'submit_generic_queue_file', EJECT ??

{ PURPOSE:
{   This procedure will convert the nft$queue_submission_option to the generic
{   queue file attributes for submitting a generic queue file.

  PROCEDURE submit_generic_queue_file
    (    file_name: fst$file_reference;
     VAR queue_file_attributes: nft$queue_submission_option;
     VAR system_file_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      array_index: integer,
      application_name: ost$name,
      number_generic_options: integer,
      option_index: nft$generic_queue_attributes,
      qfile_submission_options: ^jmt$qfile_submission_options;

    status.normal := TRUE;

    number_generic_options := $INTEGER (UPPERVALUE (nft$generic_queue_attributes)) -
          $INTEGER (LOWERVALUE (nft$generic_queue_attributes)) + 1;
    PUSH qfile_submission_options: [1 .. number_generic_options];

    IF queue_file_attributes.qfile_submission_option [nfc$gqa_application_name].key = jmc$destination THEN

{ The procedure CRACK_GENERIC_COMMAND used the subrecord DESTINATION to store the APPLICATION_NAME
{ for this queue file. Retrieve the APPLICATION_NAME and erase the data for the array entry to prevent
{ JMP$SUBMIT_QFILE from using the data as a DESTINATION name.

      application_name :=
            queue_file_attributes.qfile_submission_option [nfc$gqa_application_name].destination;

      queue_file_attributes.qfile_submission_option [nfc$gqa_application_name].destination := '';
      queue_file_attributes.qfile_submission_option [nfc$gqa_application_name].key := jmc$null_attribute;
    ELSE
      application_name := nfc$qtf_namve_client_name;
    IFEND;

{ Copy the array qfile submission options. Two indices are used to ensure against problems which
{ could ocurr if LOWERVALUE (nft$generic_queue_attributes) is not equal to one.

    array_index := 1;
    FOR option_index := LOWERVALUE (nft$generic_queue_attributes) TO
          UPPERVALUE (nft$generic_queue_attributes) DO
      qfile_submission_options^ [array_index] := queue_file_attributes.qfile_submission_option [option_index];
      array_index := array_index + 1;
    FOREND;

    jmp$submit_qfile (file_name, application_name, qfile_submission_options,
          system_file_name, status);
    IF NOT status.normal THEN
      nfp$format_message_to_job_log(status);
    IFEND;

  PROCEND submit_generic_queue_file;
?? TITLE := 'submit_queue_job', EJECT ??

{ PURPOSE:
{   This procedure will convert the nft$queue_submission_option to
{   the queue attribute form for submitting a job.  Then it submits the job.

  PROCEDURE submit_queue_job
    (    file_name: fst$file_reference;
         queue_file_attributes: nft$queue_submission_option;
     VAR job_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      array_index: integer,
      job_submission_options: ^jmt$job_submission_options,
      number_job_options: integer,
      option_index: nft$input_queue_attributes;

    status.normal := TRUE;
    number_job_options := $INTEGER (UPPERVALUE (nft$input_queue_attributes)) -
          $INTEGER (LOWERVALUE (nft$input_queue_attributes)) + 1;
    PUSH job_submission_options: [1 .. number_job_options];
    array_index := 1;
    FOR option_index := LOWERVALUE (nft$input_queue_attributes) TO UPPERVALUE (nft$input_queue_attributes) DO
      job_submission_options^ [array_index] := queue_file_attributes.job_submission_option [option_index];
      array_index := array_index + 1;
    FOREND;

    jmp$submit_job (file_name, job_submission_options, job_name, status);

  PROCEND submit_queue_job;
?? OLDTITLE ??
MODEND nfm$qtf_server;
*DECK DECK=NFM$REMOTE_FILE_ACCESS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE PTF Application : Remote File Access' ??

MODULE nfm$remote_file_access;

{
{ PURPOSE:
{   This module contains procedures to perform accesses to remote
{   permanent files.  Remote access is made implicitly by use of
{   certain SCL commands with references to files on remote families.
{   These procedures interface with the command processors.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amk$base_keypoint_values
*copyc clc$compiling_for_test_harness
*copyc clt$unbundled_pdt
*copyc clt$parameter_substitutions
*copyc clt$parameter_value_table
*copyc fsc$local
*copyc fst$file_reference
*copyc nfc$library_definitions
*copyc nfe$ptf_condition_codes
*copyc nfk$keypoints
*copyc nft$mode_of_access
*copyc nft$number_implicit_commands
*copyc ost$name_reference
*copyc ost$user_identification
*copyc ost$status
?? POP ??
*copyc amp$get_file_attributes
*copyc avp$get_capability
*copyc clp$convert_string_to_file
*copyc clp$internal_convert_to_string
*copyc clp$trimmed_string_size
*copyc i#current_sequence_position
*copyc jmp$system_job
*copyc nfp$verify_family
*copyc osp$set_status_abnormal
*copyc pmp$execute

?? TITLE := 'nfp$check_implicit_access', EJECT ??

  PROCEDURE [XDCL] nfp$check_implicit_access
    (    family_name: ost$family_name;
     VAR remote_access: boolean;
     VAR status: ost$status);

    VAR
      family_is_local: boolean,
      ignore_attributes: ^amt$get_attributes,
      ignore_contains_data: boolean,
      ignore_previously_opened: boolean,
      implicit_remote_file: boolean,
      ptf_library_exists: boolean;

    #KEYPOINT (osk$entry, 0, nfk$check_remote_access);

  /check_implicit_access/
    BEGIN
      ptf_library_exists := FALSE;
      remote_access := FALSE;
      status.normal := TRUE;

      IF family_name = fsc$local THEN
        EXIT /check_implicit_access/;
      IFEND;

      nfp$verify_family (family_name, family_is_local, status);
      IF (NOT status.normal) OR family_is_local THEN
        EXIT /check_implicit_access/;
      IFEND;

      IF NOT jmp$system_job () THEN
        avp$get_capability (avc$implicit_remote_file, avc$user, implicit_remote_file, status);
        IF NOT status.normal THEN
          EXIT /check_implicit_access/;
        IFEND;
        IF NOT implicit_remote_file THEN

{ User not validated for implicit remote file access, treat as local access - family not found.

          EXIT /check_implicit_access/;
        IFEND;
      IFEND;

      PUSH ignore_attributes: [1..1];
      ignore_attributes^ [1].key := amc$null_attribute;
      amp$get_file_attributes (nfc$system_library_name, ignore_attributes^, ptf_library_exists,
            ignore_previously_opened, ignore_contains_data, status);
      IF NOT (ptf_library_exists AND status.normal) THEN
        EXIT /check_implicit_access/;
      IFEND;

      remote_access := TRUE;

    END /check_implicit_access/;

    #KEYPOINT (osk$exit, 0, nfk$check_remote_access);

  PROCEND nfp$check_implicit_access;
?? TITLE := 'nfp$perform_implicit_access', EJECT ??

  PROCEDURE [XDCL] nfp$perform_implicit_access
    (    location: ost$name;
         local_file_path: fst$file_reference;
         remote_file_path: fst$file_reference;
         access_mode: nft$mode_of_access;
         command_name: ost$name_reference;
         pdt: ^clt$unbundled_pdt;
         pvt: ^clt$parameter_value_table;
         parameter_substitutions: ^clt$parameter_substitutions;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      access_mode_ptr: ^nft$mode_of_access,
      command_name_ptr: ^ost$name,
      file_name: clt$file,
      implicit_commands: ^clt$data_representation,
      local_file_ptr: ^amt$local_file_name,
      location_ptr: ^ost$name,
      object_lib_string: amt$local_file_name,
      object_library: ^amt$local_file_name,
      parameters_length: integer,
      program_attributes: ^pmt$program_attributes,
      program_description: ^pmt$program_description,
      program_parameters: ^pmt$program_parameters,
      remote_file_ptr: ^ost$string,
      request: clt$convert_to_string_request,
      task_id: pmt$task_id,
      task_status: pmt$task_status;

?? NEWTITLE := 'put_implicit_commands', EJECT ??

    PROCEDURE [INLINE] put_implicit_commands;

      VAR
        implicit_command: ^ost$string,
        implicit_command_count: ^nft$number_implicit_commands,
        representation: ^clt$data_representation,
        representation_line: ^clt$string_value,
        representation_line_count: ^clt$data_representation_count,
        representation_line_index: clt$data_representation_count,
        representation_line_size: ^clt$string_size;


      NEXT implicit_command_count IN work_area;

      IF implicit_commands = NIL THEN
        implicit_command_count^ := 0;

      ELSE
        representation := implicit_commands;
        RESET representation;
        NEXT representation_line_count IN representation;
        implicit_command_count^ := representation_line_count^;

        FOR representation_line_index := 1 TO representation_line_count^ DO
          NEXT representation_line_size IN representation;
          NEXT representation_line: [representation_line_size^] IN representation;

          NEXT implicit_command IN work_area;
          implicit_command^.size := representation_line_size^;
          implicit_command^.value := representation_line^;
        FOREND;
      IFEND;

    PROCEND put_implicit_commands;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    IF command_name = '' THEN
      implicit_commands := NIL;
    ELSE
      request.initial_indentation := 0;
      request.continuation_indentation := 0;
      request.max_string := osc$max_string_size;
      request.include_advanced_items := TRUE;
      request.include_hidden_items := TRUE;
      request.kind := clc$convert_parameters;
      request.initial_text := ^command_name;
      request.include_secure_parameters := TRUE;
      request.evaluated_pdt := pdt;
      request.evaluated_pvt := pvt;
      request.parameter_substitutions := parameter_substitutions;
      clp$internal_convert_to_string (request, work_area, implicit_commands, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;


  /execute_ptf_task/
    BEGIN
      PUSH program_description: [[REP (#SIZE (pmt$program_attributes) +
            (nfc$number_ptfi_libraries * #SIZE (object_lib_string))) OF cell]];
      RESET program_description;
      NEXT program_attributes IN program_description;

{
{     Build program description
{

      program_attributes^.contents := $pmt$prog_description_contents
            [pmc$library_list_specified, pmc$starting_proc_specified, pmc$term_error_level_specified,
            pmc$debug_mode_specified];
      program_attributes^.starting_procedure := nfc$ptfi_sp;
      program_attributes^.termination_error_level := pmc$fatal_load_errors;
      program_attributes^.debug_mode := pmc$debug_mode_off;
      program_attributes^.number_of_libraries := nfc$number_ptfi_libraries;
      NEXT object_library IN program_description;
      clp$convert_string_to_file (nfc$ptfi_library_name, file_name, status);
      IF NOT status.normal THEN
        EXIT /execute_ptf_task/;
      IFEND;
      object_library^ := file_name.local_file_name;

{
{     build parameters for task
{

      NEXT location_ptr IN work_area;
      location_ptr^ := location;
      NEXT local_file_ptr IN work_area;
      clp$convert_string_to_file (local_file_path, file_name, status);
      IF NOT status.normal THEN
        EXIT /execute_ptf_task/;
      IFEND;
      local_file_ptr^ := file_name.local_file_name;
      NEXT remote_file_ptr IN work_area;
      remote_file_ptr^.size := clp$trimmed_string_size (remote_file_path);
      IF remote_file_ptr^.size > osc$max_string_size THEN
        osp$set_status_abnormal ('CL', cle$file_reference_too_long, remote_file_path (1, osc$max_string_size),
              status);
        EXIT /execute_ptf_task/;
      IFEND;
      remote_file_ptr^.value := remote_file_path;
      NEXT access_mode_ptr IN work_area;
      access_mode_ptr^ := access_mode;
      NEXT command_name_ptr IN work_area;
      command_name_ptr^ := command_name;
      put_implicit_commands;

      parameters_length := i#current_sequence_position (work_area);
      RESET work_area TO location_ptr;
      parameters_length := parameters_length - i#current_sequence_position (work_area);
      NEXT program_parameters: [[REP parameters_length OF cell]] IN work_area;
      RESET program_parameters;

{
{     execute the task
{

      ?IF clc$compiling_for_test_harness THEN
        osp$set_status_abnormal ('CL', 999999, 'Remote file access not support in SCL test harness.', status);
      ?ELSE
        pmp$execute (program_description^, program_parameters^, osc$wait, task_id, task_status, status);
        IF status.normal AND (NOT task_status.status.normal) THEN
          status := task_status.status;
        IFEND;
      ?IFEND
    END /execute_ptf_task/;

  PROCEND nfp$perform_implicit_access;

MODEND nfm$remote_file_access;
*DECK DECK=NFM$REMOTE_VALIDATION EXPAND=TRUE
?? NEWTITLE := 'NOS/VE PTF Application: Remote Validation' ??

?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, INDENT := 2) ??
?? SET (LIST := ON, LISTCTS := OFF) ??

MODULE nfm$remote_validation;

{
{ PURPOSE:
{   This module contains procedures to save, delete, and read the
{   validation information to be used for permanent file access
{   on remote systems.
{

?? NEWTITLE := '  Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc nfe$ptf_condition_codes
*copyc nft$remote_validation
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc ost$caller_identifier
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc osp$clear_job_signature_lock
*copyc clp$close_display
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc osp$set_job_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osv$task_shared_heap

?? TITLE := '  Global Variables', EJECT ??

  TYPE
    remote_validation_control = record
      lock: ost$signature_lock,
      ptr: ^nft$remote_validation,
    recend;

  VAR
    nfv$remote_validation: [STATIC, oss$task_shared] remote_validation_control := [[0], NIL];


?? TITLE := '  [XDCL, #GATE] nfp$find_remote_validation', EJECT ??
{
{     The purpose of this request is to search the remote validation table for
{ an entry for the specified remote location.  The remote validation table is
{ located in the task shared heap and each entry contains one or more lines of
{ directives to be sent to a remote server application.  The requestor is
{ informed whether an entry exists, and how many lines it contains.
{
{       NFP$FIND_REMOTE_VALIDATION (LOCATION, VALIDATION_LINE_COUNT, STATUS)
{
{ LOCATION: (input)  This parameter specifies the remote location for which the
{       validation entry is sought.  If the remote system is NOS/VE, the loca-
{       tion is a family name.
{
{ VALIDATION_LINE_COUNT: (output)  This parameter specifies the number of lines
{       of directives contained in the remote validation entry.  If no entry
{       exists for the specified location, a value of zero will be returned.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: none.
{

  PROCEDURE [XDCL, #GATE] nfp$find_remote_validation
    (    location: ost$name;
     VAR validation_line_count: 0 .. nfc$max_validation_lines;
     VAR status: ost$status);

    VAR
      entry_p: ^nft$remote_validation;


    status.normal := TRUE;

    osp$set_job_signature_lock (nfv$remote_validation.lock);
    get_validation_entry (location, entry_p);

    IF entry_p = NIL THEN
      validation_line_count := 0;
    ELSE
      validation_line_count := UPPERBOUND (entry_p^.text);
    IFEND;

    osp$clear_job_signature_lock (nfv$remote_validation.lock);

  PROCEND nfp$find_remote_validation;

?? TITLE := '  [XDCL, #GATE] nfp$get_remote_validation', EJECT ??
{
{     The purpose of this request is to return the remote validation table
{ entry for the specified remote location.  The remote validation table is
{ located in the task shared heap and each entry contains one or more lines of
{ directives to be sent to a remote server application.  The requestor must
{ know the size of this entry in order to provide sufficient space to accept
{ it.  This is done via a prior call to nfp$find remote_validation.
{
{       NFP$GET_REMOTE_VALIDATION (LOCATION, VALIDATION, STATUS)
{
{ LOCATION: (input)  This parameter specifies the remote location for which the
{       validation entry is requested.  If the remote system is NOS/VE, the
{       location is a family name.
{
{ VALIDATION: (output)  This parameter specifies the array of directive lines
{       obtained from the remote validation entry.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: nfe$remote_val_undefined.
{       IDENTIFIER: nfc$status_id.
{

  PROCEDURE [XDCL, #GATE] nfp$get_remote_validation
    (    location: ost$name;
     VAR validation: ^array [1 .. * ] of string (osc$max_string_size);
     VAR status: ost$status);

    VAR
      entry_p: ^nft$remote_validation,
      line_count: 0 .. nfc$max_validation_lines,
      output_count: 0 .. nfc$max_validation_lines,
      i: 1 .. nfc$max_validation_lines;


    status.normal := TRUE;

    osp$set_job_signature_lock (nfv$remote_validation.lock);
    get_validation_entry (location, entry_p);

  /get/
    BEGIN
      IF entry_p = NIL THEN
        osp$set_status_abnormal (nfc$status_id, nfe$remote_val_undefined, location, status);
        EXIT /get/;
      IFEND;

      line_count := UPPERBOUND (entry_p^.text);
      output_count := UPPERBOUND (validation^);
      IF output_count < line_count THEN
        line_count := output_count;
      IFEND;

      FOR i := 1 TO line_count DO
        validation^ [i] := entry_p^.text [i];
      FOREND;
    END /get/;

    osp$clear_job_signature_lock (nfv$remote_validation.lock);

  PROCEND nfp$get_remote_validation;

?? TITLE := '  [XDCL, #GATE] nfp$set_remote_validation', EJECT ??
{
{     The purpose of this request is to create a remote validation table
{ entry for the specified remote location.  The remote validation table is
{ located in the task shared heap and each entry contains one or more lines of
{ directives to be sent to a remote server application.
{
{       NFP$SET_REMOTE_VALIDATION (LOCATION, VALIDATION, STATUS)
{
{ LOCATION: (input)  This parameter specifies the remote location for which the
{       validation entry is to be created.  If the remote system is NOS/VE, the
{       location is a family name.
{
{ VALIDATION: (input)  This parameter specifies the array of directive lines
{       to be stored in the remote validation entry.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: nfe$remote_val_defined.
{       IDENTIFIER: nfc$status_id.
{

  PROCEDURE [XDCL, #GATE] nfp$set_remote_validation
    (    location: ost$name;
         validation: ^array [1 .. * ] of string (osc$max_string_size);
     VAR status: ost$status);

    VAR
      entry_p: ^nft$remote_validation,
      last_entry_p: ^nft$remote_validation,
      line_count: 0 .. nfc$max_validation_lines,
      i: 1 .. nfc$max_validation_lines;


    status.normal := TRUE;

    osp$set_job_signature_lock (nfv$remote_validation.lock);
    get_validation_entry (location, entry_p);

    IF entry_p = NIL THEN
      line_count := UPPERBOUND (validation^);
      ALLOCATE entry_p: [1 .. line_count] IN osv$task_shared_heap^;
      entry_p^.next_entry := NIL;
      entry_p^.location := location;
      FOR i := 1 TO line_count DO
        entry_p^.text [i] := validation^ [i];
      FOREND;
      IF nfv$remote_validation.ptr = NIL THEN
        nfv$remote_validation.ptr := entry_p;
      ELSE
        last_entry_p := nfv$remote_validation.ptr;
        WHILE last_entry_p^.next_entry <> NIL DO
          last_entry_p := last_entry_p^.next_entry;
        WHILEND;
        last_entry_p^.next_entry := entry_p;
      IFEND;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$remote_val_defined, location, status);
    IFEND;

    osp$clear_job_signature_lock (nfv$remote_validation.lock);

  PROCEND nfp$set_remote_validation;

?? TITLE := '  [XDCL, #GATE] nfp$clear_remote_validation', EJECT ??
{
{     The purpose of this request is to delete the remote validation table
{ entry for the specified remote location.  The remote validation table is
{ located in the task shared heap and each entry contains one or more lines of
{ directives to be sent to a remote server application.
{
{       NFP$CLEAR_REMOTE_VALIDATION (LOCATION, VALIDATION, STATUS)
{
{ LOCATION: (input)  This parameter specifies the remote location for which the
{       validation entry is to be deleted.  If the remote system is NOS/VE, the
{       location is a family name.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: none.
{

  PROCEDURE [XDCL, #GATE] nfp$clear_remote_validation
    (    location: ost$name;
     VAR status: ost$status);

    VAR
      entry_p: ^nft$remote_validation,
      next_entry_p: ^nft$remote_validation;

    status.normal := TRUE;

    osp$set_job_signature_lock (nfv$remote_validation.lock);

    entry_p := nfv$remote_validation.ptr;

    IF location = 'ALL' THEN
      WHILE entry_p <> NIL DO
        next_entry_p := entry_p^.next_entry;
        FREE entry_p IN osv$task_shared_heap^;
        entry_p := next_entry_p;
      WHILEND;
      nfv$remote_validation.ptr := NIL;

    ELSEIF entry_p^.location = location THEN
      nfv$remote_validation.ptr := entry_p^.next_entry;
      FREE entry_p IN osv$task_shared_heap^;

    ELSE

    /clear_one_entry/
      WHILE entry_p <> NIL DO
        next_entry_p := entry_p^.next_entry;
        IF next_entry_p^.location = location THEN
          entry_p^.next_entry := next_entry_p^.next_entry;
          FREE next_entry_p IN osv$task_shared_heap^;

          EXIT /clear_one_entry/;
        IFEND;
        entry_p := next_entry_p;
      WHILEND /clear_one_entry/;
    IFEND;

    osp$clear_job_signature_lock (nfv$remote_validation.lock);

  PROCEND nfp$clear_remote_validation;

?? TITLE := '  [XDCL, #GATE] nfp$remote_validation_display', EJECT ??
{
{     The purpose of this request is to display the remote validation entries
{ for the specified remote location(s).  The remote validation table is located
{ in the task shared heap and each entry contains one or more lines of
{ directives to be sent to a remote server application.
{
{       NFP$REMOTE_VALIDATION_DISPLAY (LOCATIONS, OUTPUT_FILE, STATUS)
{
{ LOCATIONS: (input)  This parameter specifies an array of one or more names
{       of remote locations for which the validation display is requested.
{       If 'ALL' is specified, all validation entries will be displayed.
{
{ OUTPUT_FILE: (input)  This parameter specifies the file to which the display
{       output is to be written.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: nfe$remote_val_empty, nfe$remote_val_undefined.
{       IDENTIFIER: nfc$status_id
{

  PROCEDURE [XDCL, #GATE] nfp$remote_validation_display
    (    locations: ^array [1 .. * ] of ost$name;
         output_file: fst$file_reference;
     VAR status: ost$status);

?? NEWTITLE := '    abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF output_open THEN
        clp$close_display (display_control, ignore_status);
        output_open := FALSE;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??
    VAR
      caller_id: ost$caller_identifier,
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      loc_index: integer,
      local_status: ost$status,
      location_count: integer,
      output_open: boolean;


    status.normal := TRUE;
    output_open := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

    #CALLER_ID (caller_id);

    default_ring_attributes.r1 := caller_id.ring;
    default_ring_attributes.r2 := caller_id.ring;
    default_ring_attributes.r3 := caller_id.ring;

    clp$open_display_reference (output_file, NIL, fsc$list, default_ring_attributes, display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN
    IFEND;
    output_open := TRUE;
    location_count := UPPERBOUND (locations^);

  /display/
    BEGIN
      FOR loc_index := 1 TO location_count DO
        IF locations^ [loc_index] = 'ALL' THEN
          display_all_validations (display_control, status);
          EXIT /display/;
        ELSE
          display_validation_entry (display_control, locations^ [loc_index], status);
          IF NOT status.normal THEN
            EXIT /display/;
          IFEND;
        IFEND;
      FOREND;
    END /display/;

    clp$close_display (display_control, local_status);
    IF NOT local_status.normal AND (status.normal) THEN
      status := local_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND nfp$remote_validation_display;
?? TITLE := '    display_all_validations', EJECT ??

{
{    Procedure to display all remote validation entries defined for job.
{

  PROCEDURE display_all_validations
    (VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      display_line: string (2 * osc$max_name_size),
      entry_p: ^nft$remote_validation,
      location: ost$name,
      location_count: integer,
      loc_index: integer,
      location_list: ^array [1 .. * ] of ost$name;

    status.normal := TRUE;

    osp$set_job_signature_lock (nfv$remote_validation.lock);

    entry_p := nfv$remote_validation.ptr;
    IF entry_p = NIL THEN
      osp$set_status_abnormal (nfc$status_id, nfe$remote_val_empty, '', status);
      osp$clear_job_signature_lock (nfv$remote_validation.lock);
      RETURN;
    IFEND;

    location_count := 0;
    WHILE entry_p <> NIL DO
      entry_p := entry_p^.next_entry;
      location_count := location_count + 1;
    WHILEND;

    PUSH location_list: [1 .. location_count];
    entry_p := nfv$remote_validation.ptr;
    FOR loc_index := 1 TO location_count DO
      location_list^ [loc_index] := entry_p^.location;
      entry_p := entry_p^.next_entry;
    FOREND;

    osp$clear_job_signature_lock (nfv$remote_validation.lock);

    FOR loc_index := 1 TO location_count DO
      display_validation_entry (display_control, location_list^ [loc_index], status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND display_all_validations;

?? TITLE := '    display_validation_entry', EJECT ??

{
{    Procedure to display validation text for a location.
{

  PROCEDURE display_validation_entry
    (VAR display_control: clt$display_control;
         location: ost$name;
     VAR status: ost$status);

    VAR
      entry_p: ^nft$remote_validation,
      display_line: string (2 * osc$max_name_size);


    status.normal := TRUE;

    osp$set_job_signature_lock (nfv$remote_validation.lock);

  /display_entry/
    BEGIN
      get_validation_entry (location, entry_p);
      IF entry_p = NIL THEN
        osp$set_status_abnormal (nfc$status_id, nfe$remote_val_undefined, location, status);
        EXIT /display_entry/;
      IFEND;

      display_line := 'LOCATION: ';
      display_line (11, osc$max_name_size) := location;
      clp$put_display (display_control, display_line, clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_entry/;
      IFEND;

    END /display_entry/;

    osp$clear_job_signature_lock (nfv$remote_validation.lock);

  PROCEND display_validation_entry;

?? TITLE := '  get_validation_entry', EJECT ??

  PROCEDURE get_validation_entry
    (    location: ost$name;
     VAR entry_p: ^nft$remote_validation);


    entry_p := nfv$remote_validation.ptr;
    IF location <> 'ALL' THEN
      WHILE entry_p <> NIL DO
        IF entry_p^.location = location THEN
          RETURN;
        IFEND;
        entry_p := entry_p^.next_entry;
      WHILEND;
    IFEND;

  PROCEND get_validation_entry;

MODEND nfm$remote_validation;
*DECK DECK=NFM$REMOTE_VALIDATION_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE PTF Application : Remote Validation Commands' ??

MODULE nfm$remote_validation_commands;

{
{ PURPOSE:
{   This module contains processors for commands that manage system access
{   validation for remote permanent file access.
{

?? NEWTITLE := '  Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc nfe$ptf_condition_codes
*copyc ost$status
?? POP ??
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc nfp$clear_remote_validation
*copyc nfp$find_remote_validation
*copyc nfp$get_remote_validation
*copyc nfp$remote_validation_display
*copyc nfp$set_remote_validation
*copyc osp$set_status_abnormal

?? TITLE := '  [XDCL] nfp$_create_remote_validation', EJECT ??

{
{ PURPOSE:
{   This procedure is the command processor for the create_remote_validation
{   command.  Remote validation is in the form of one or more command lines
{   used to validate a user on a remote system.
{

  PROCEDURE [XDCL] nfp$_create_remote_validation
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$crerv) create_remote_validation, crerv (
{   location, l: name = $required
{   validation, v: (SECURE) list of string 1..osc$max_string_size = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 20, 14, 26, 55, 880], clc$command, 5, 3, 2, 0, 0, 0, 3, 'OSM$CRERV'],
            [['L                              ', clc$abbreviation_entry, 1],
            ['LOCATION                       ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 3],
            ['V                              ', clc$abbreviation_entry, 2],
            ['VALIDATION                     ', clc$nominal_entry, 2]], [
{ PARAMETER 1
      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [5, clc$normal_usage_entry, clc$secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 24, clc$required_parameter, 0, 0],
{ PARAMETER 3
      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
      [[1, 0, clc$list_type], [8, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$string_type], [1, osc$max_string_size, FALSE]]],
{ PARAMETER 3
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$location = 1,
      p$validation = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      i: clt$list_size,
      val_line_count: clt$list_size,
      validation_ptr: ^array [1 .. * ] of string (osc$max_string_size),
      validation_value: ^clt$data_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nfp$find_remote_validation (pvt [p$location].value^.name_value, val_line_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF val_line_count <> 0 THEN
      osp$set_status_abnormal (nfc$status_id, nfe$remote_val_defined, pvt [p$location].value^.name_value,
            status);
      RETURN;
    IFEND;

    validation_value := pvt [p$validation].value;
    val_line_count := clp$count_list_elements (pvt [p$validation].value);

    PUSH validation_ptr: [1 .. val_line_count];
    FOR i := 1 TO val_line_count DO
      validation_ptr^ [i] := validation_value^.element_value^.string_value^;
      validation_value := validation_value^.link;
    FOREND;

    nfp$set_remote_validation (pvt [p$location].value^.name_value, validation_ptr, status);

  PROCEND nfp$_create_remote_validation;


?? TITLE := '  [XDCL] nfp$_delete_remote_validation', EJECT ??

{
{ PURPOSE:
{   This procedure is the command processor for the delete_remote_validation
{   command, which removes a previously created validation for the
{   specified location.
{

  PROCEDURE [XDCL] nfp$_delete_remote_validation
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$delrv) delete_remote_validation, delrv (
{   location, l: list of any of
{       key
{         all
{       keyend
{       name
{     anyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: 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$name_type_qualifier,
            recend,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 20, 14, 29, 24, 546], clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$DELRV'],
            [['L                              ', clc$abbreviation_entry, 1],
            ['LOCATION                       ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 2]], [
{ PARAMETER 1
      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$list_type], [69, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]]]],
{ PARAMETER 2
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$location = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      location: ost$name,
      location_value: ^clt$data_value,
      val_line_count: 0 .. nfc$max_validation_lines,
      i: 1 .. clc$max_value_sets;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    location_value := pvt [p$location].value;

    WHILE location_value <> NIL DO
      IF location_value^.element_value^.kind = clc$keyword THEN
        location := 'ALL';
      ELSE
        location := location_value^.element_value^.name_value;
      IFEND;
      nfp$find_remote_validation (location, val_line_count, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF val_line_count = 0 THEN
        IF location = 'ALL' THEN
          osp$set_status_abnormal (nfc$status_id, nfe$remote_val_empty, '', status);
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$remote_val_undefined, location, status);
        IFEND;
        RETURN;
      IFEND;

      nfp$clear_remote_validation (location, status);
      IF (location = 'ALL') OR NOT status.normal THEN
        RETURN;
      IFEND;

      location_value := location_value^.link;
    WHILEND;

  PROCEND nfp$_delete_remote_validation;


?? TITLE := '  [XDCL] nfp$display_remote_validation', EJECT ??

{
{ PURPOSE:
{   This procedure is the command processor for the display_remote_validation
{   command.
{

  PROCEDURE [XDCL] nfp$display_remote_validation
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$disrv) display_remote_validation, disrv (
{   location, l: list of any of
{       key
{         all
{       keyend
{       name
{     anyend = ALL
{   output, o: file = OUTPUT
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: 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$name_type_qualifier,
            recend,
          recend,
          default_value: string (3),
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (6),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 20, 14, 24, 12, 964], clc$command, 5, 3, 0, 0, 0, 0, 3, 'OSM$DISRV'],
            [['L                              ', clc$abbreviation_entry, 1],
            ['LOCATION                       ', clc$nominal_entry, 1],
            ['O                              ', clc$abbreviation_entry, 2],
            ['OUTPUT                         ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3]], [
{ PARAMETER 1
      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 6],
{ PARAMETER 3
      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$list_type], [69, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]]], 'ALL'],
{ PARAMETER 2
      [[1, 0, clc$file_type], 'OUTPUT'],
{ PARAMETER 3
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$location = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      location_value: ^clt$data_value,
      locations: ^array [1 .. * ] of ost$name,
      location_count: 0 .. clc$max_value_sets,
      loc_index: 1 .. clc$max_value_sets;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    location_value := pvt [p$location].value;

    location_count := clp$count_list_elements (pvt [p$location].value);
    PUSH locations: [1 .. location_count];
    loc_index := 1;
    WHILE location_value <> NIL DO
      IF location_value^.element_value^.kind = clc$name THEN
        locations^ [loc_index] := location_value^.element_value^.name_value;
      ELSE {keyword = ALL}
        locations^ [1] := 'ALL';
      IFEND;
      location_value := location_value^.link;
      loc_index := loc_index + 1;
    WHILEND;

    nfp$remote_validation_display (locations, pvt [p$output].value^.file_value^, status);

  PROCEND nfp$display_remote_validation;

MODEND nfm$remote_validation_commands;

*DECK DECK=NFM$RHF_PROTOCOL_ENGINE EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, INDENT := 2) ??
?? SET (LIST := ON, LISTCTS := OFF) ??
MODULE nfm$rhf_protocol_engine;
{********************************************************************************}
{                                                                                }
{     MODULE:                                                                    }
{       NFM$PROTOCOL_ENGINE                                                      }
{                                                                                }
{     PURPOSE:                                                                   }
{                                                                                }
{       This module provides the external interfaces                             }
{       necessary for transfering files between peer applications. These         }
{       interfaces correspond to the functions of the outermost layer            }
{       (application layer - 7) of the basic model for open systems              }
{       interconnection (OSI). OSI is a standard for the exchange of data        }
{       between remote hosts, independent of the physical differences of         }
{       the hosts.                                                               }
{                                                                                }
{     DESCRIPTION:                                                               }
{                                                                                }
{       This code performs common A-A network protocol functions for
{       CDC applications.her the client or servicer application depending        }
{       on the BTS intefaces being used. The following diagram illustrates       }
{       the high level processing flow for batch transfers.                      }
{                                                                                }
{                                                                                }
{                 CLIENT                           SERVER                        }
{                                             (remote host or DI)                }
{                                                                                }
{            +------+  +------+               +------+  +------+                 }
{            | MANRF|  | BTF  |               | BOOT |  | PTFS |<---:            }
{            +------+  +------+               +------+  +------+    :            }
{               :         :                      :         :        :            }
{               :         :                      :         :        :            }
{               v         v                      v         v        :            }
{            +----------------+     +---+     +----------------+    :            }
{            | Protocol engine|<--->|   |<--->| Protocol engine|----:            }
{            +---------+------+     | N |     +------+---------+                 }
{            | send_file      |<--->| A |<--->| Receive_file   |                 }
{            +----------------+     | M |     +----------------+                 }
{            | receive_file   |<--->|   |<--->| Send_file      |                 }
{            +----------------+     +---+     +---------+------+                 }
{                                     ^                                          }
{                                     :       +----------------+                 }
{                                     ------->|    BTFS/DI     |                 }
{                                             +----------------+                 }
{                                                                                }
{       The permanent file client application for NOS/VE can be either           }
{       the manage remote files directive (MANRF) or one of the NOS/VE           }
{       directives which could cause an implicit file transfer. The client       }
{       application uses batch transfer services to establish a connection       }
{       with the server application on the remote mainframe and cause the        }
{       file transfer to occur.                                                  }
?? EJECT ??
{       The permanent file server application for NOS/VE is comprised of a       }
{       system task (BOOT) that accepts the connection request from the          }
{       client, and a job that is submitted on behalf of the user (PTFS)         }
{       and becomes the the users server application.                            }
{                                                                                }
{       The system task server application accepts the connection request        }
{       and receives the first data unit. If no errors are found, a job          }
{       file is created from the directives contained in the first data          }
{       unit, and the job is submitted on behalf of the user. If an error        }
{       is found in the first data unit, or when submitting the new server       }
{       job, the system task server will finish the termination protocol         }
{       processing with the client.                                              }
{                                                                                }
{                                                                                }
{                                                                                }
{********************************************************************************}
?? EJECT ??
  {========================================================================================}
  { command | mnemonic |         command name and function                                 }
  {========================================================================================}
  {   00    |   RFT    | Request_File_Transfer. Sent by the initiating process and is      }
  {         |          | accompanied by all of the parameters necessary to define the      }
  {         |          | details of the transfer and to identify the file.                 }
  {----------------------------------------------------------------------------------------}
  {   01    |   RPOS   | Reply_Positive. Sent by the receiving process to accept the       }
  {         |          | proposed file transfer, and is accompanied by the parameters      }
  {         |          | defining the receivers veiw of the file transfer.                 }
  {----------------------------------------------------------------------------------------}
  {   02    |   RNEG   | Reply_Negative. sent by the receiving process to indicate that    }
  {         |          | the proposed transfer may not take place. Parameters are provided }
  {         |          | giving sugested values for those attributes which contributed to  }
  {         |          | the failure. Additionally, the parameters include a value for an  }
  {         |          | attribute which gives an encoded reason for the difficulty.       }
  {----------------------------------------------------------------------------------------}
  {   03    |   GO     | Enter_Transfer_Phase. Indicates that the initiating process,      }
  {         |          | after considering the reply, is entering the data transfer        }
  {         |          | state.                                                            }
  {----------------------------------------------------------------------------------------}
  {   04    |   STOP   | Enter_Idle_Phase. Sent by the initiating process to indicate      }
  {         |          | the termination of the transfer. It may be accompanied by         }
  {         |          | parameters giving the final status of the transfer, messages,     }
  {         |          | and other information.                                            }
  {----------------------------------------------------------------------------------------}
  {   05    |   STOPR  | Enter_Idle_Reply. Sent by the receiving process to indicate the   }
  {         |          | servicer's final status of the transfer.                          }
  {----------------------------------------------------------------------------------------}
  {   60    |   ETP    | Enter_Termination_Phase. Sent by the initiating process and is    }
  {         |          | accompanied by all of the parameters necessary to define the      }
  {         |          | details of the termination process.                               }
  {----------------------------------------------------------------------------------------}
  {   61    |   ETPR   | Enter_Termination_Reply. Sent by the receiving process in reply to}
  {         |          | the ETP command. It is accompanied by the parameters defining the }
  {         |          | server's view of the details of the termination process.          }
  {----------------------------------------------------------------------------------------}
  {   62    |   FINI   | Initiate_Disconnect. Sent by the initiating process to indicate   }
  {         |          | completion of the application connection.                         }
  {========================================================================================}
?? EJECT ??
  {=======================================================================================}
  { attribute |        parameter name and function                                        }
  {=======================================================================================}
  {    00     | protocol identification. The protocol identification parameter gives the  }
  {           | protocol name, version, and implementation level of the A to A protocol   }
  {           | being used.                                                               }
  { --------------------------------------------------------------------------------------}
  {    01     | maximum transfer file size. This parameter specifies the maximum size in  }
  {           | kilobytes (1024 bytes) of data that may be transferred during the data    }
  {           | phase of the transfer.                                                    }
  { --------------------------------------------------------------------------------------}
  {    02     | transfer identifier. The transfer identifier allows the initiating        }
  {           | process to tag the particular file transfer.                              }
  { --------------------------------------------------------------------------------------}
  {    03     | facilities. The facilities parameter defines a set of A to A protocol     }
  {           | processing options which may be used in the data transfer phase. Each     }
  {           | character of the text string indicates a particular option to be used.    }
  {           |     C = Collective text string processing.                                }
  {           |     G = parameters allowed on the GO command.                             }
  {           |     H = Temporary hold.                                                   }
  {           |     L = Later resumption of this transfer in new transfer possible.       }
  {           |     M = Restart checkmark acknowledgment must occur.                     }
  {           |     N = No blocking of levels 40 and 50 interactive commands.             }
  {           |     R = Restart requests permitted within this transfer.                  }
  {           |     S = Send data acknowledgment must occur.                             }
  { --------------------------------------------------------------------------------------}
  {    04     | state of transfer. The state of transfer parameter is used to convey      }
  {           | information about the current state of the file transfer and to provide   }
  {           | additional explanation when the transfer has failed or is being rejected. }
  { --------------------------------------------------------------------------------------}
  {    05     | user text directive. The user text directives provide the receiving       }
  {           | process with the user operation to be performed.                          }
  { --------------------------------------------------------------------------------------}
  {    06     | file size. The file size parameter specifies the amount of storage        }
  {           | (in kilobytes) to be reserved for the file.                               }
  { --------------------------------------------------------------------------------------}
  {    07     | operator message. The operator message parameter allows a text message    }
  {           | to be conveyed with a command for disposition to the operator display.    }
  { --------------------------------------------------------------------------------------}
  {    08     | user message. The user message parameter allows a text message to be      }
  {           | conveyed with a command for output to the user log of the receiving       }
  {           | process.                                                                  }
  { --------------------------------------------------------------------------------------}
  {    09     | account message. The account message parameter allows for a text message  }
  {           | to be conveyed with a command for output to the account file of the       }
  {           | receiving process.                                                        }
  { --------------------------------------------------------------------------------------}
  {    10     | error log message. The error log message parameter allows a text message  }
  {           | to be conveyed with a command for output to the error log file of the     }
  {           | receiving process.                                                        }
  { --------------------------------------------------------------------------------------}
  {    11     | special options. The special options parameter allows for parameters      }
  {           | specifically undefined by the A to A protocol but known to the receiving  }
  {           | to be exchanged.                                                          }
  { --------------------------------------------------------------------------------------}
  {    12     | maximum transfer block size. The maximum transfer block size parameter    }
  {           | specifies the maximum size (in bytes) of the data block which may be      }
  {           | transfered during the data phase of the protocol. It includes only user   }
  {           | data and no more then one logical record.                                 }
  { --------------------------------------------------------------------------------------}
  {    13     | Accounting limit. For the Bxxx protocol only, this parameter specifies    }
  {           | the I/O station operators validation limit for the number of records in   }
  {           | a file transferred from an input or an output device. The file transfer   }
  {           | is terminated when this number of records has been transmitted and an     }
  {           | end of data has not been detected.                                        }
  { --------------------------------------------------------------------------------------}
  {   14-15   | reserved for CDC.                                                         }
  { --------------------------------------------------------------------------------------}
  {    16     | file name. The file name parameter specifies the file to be used as the   }
  {           | source or destination of the file transfer, if one is to takes place.     }
  {           | For NOS/VE, the file name is explicitly specified by both peer            }
  {           | applications through procedure calls to batch transfer services.          }
  {           | Because of this the parameter is not communicated through the protocol.   }
  { --------------------------------------------------------------------------------------}
  {    17     | file disposition code.                                                    }
  { --------------------------------------------------------------------------------------}
  {    18     | acknowledgment window. The acknowledgment window parameter defines      }
  {           | the maximum number of restart checkmarks and associated data transmitted  }
  {           | by the sender before receiving acknowledment from the receiver.           }
  { --------------------------------------------------------------------------------------}
  {    19     | initial restart checkmark. The Initial restart checkmark parameter        }
  {           | specifies the checkmark number at which the re-transfer is to start.      }
  { --------------------------------------------------------------------------------------}
  {    20     | minimum time-out interval. The minimum time_out interval parameter is     }
  {           | used to specify the amount of time (in wall clock seconds) that an        }
  {           | application will wait for no activity from the peer application. When     }
  {           | this threshold is reached, the file transfer will be unilaterally aborted }
  {           | and the connection will be broken.                                        }
  { --------------------------------------------------------------------------------------}
  {    21     | mode of access. The mode of access parameter specifies the direction of   }
  {           | the transfer and the access mode of the file.                             }
  { --------------------------------------------------------------------------------------}
  {    22     | host type. The host type parameter defines the host mainframe for the     }
  {           | peer application.                                                         }
  {           |     CDI = CDCNET TDI/URI.                                                 }
  {           |     CGW = CYBER gateway.                                                  }
  {           |     DEC = DEC.                                                            }
  {           |     IBM = IBM.                                                            }
  {           |     NOS = CYBER 17x with NOS/V1.                                          }
  {           |     NS2 = CYBER 17x with NOS/V2 (64 character set).                       }
  {           |     NS3 = CYBER 17x with NOS/V2 (63 character set).                       }
  {           |     NBE = CYBER 17x with NOS/BE (64 character set).                       }
  {           |     NBE = CYBER 17x with NOS/BE (64 character set).                       }
  {           |     NVE = CYBER 8xx with NOS/VE.                                          }
  {           |     SC2 = CYBER 7600 with SCOPE 2.                                        }
  {           |     VAX = VAX.                                                            }
  {           |     200 = CYBER 20x.                                                      }
  {           |     120 = CYBER 120.                                                      }
  { --------------------------------------------------------------------------------------}
  {    23     | command argument. The function and meaning of this parameter is dependent }
  {           | on the data transfer phase command that it is contained in.               }
  { --------------------------------------------------------------------------------------}
  {    24     | source logical identifier. This parameter contains the logical mainframe  }
  {           | identifier to the source computer.                                        }
  { --------------------------------------------------------------------------------------}
  {    25     | transfer logical identifier. This parameter contains the logical          }
  {           | identifier which corresponds to the connection used for the file transfer.}
  { --------------------------------------------------------------------------------------}
  {    26     | job name. For permanent file transfers the job name parameter represents  }
  {           | the name of the peer application job. This parameter should be logged in  }
  {           | system file for accounting and job tracking purposes.                     }
  { --------------------------------------------------------------------------------------}
  {    27     | physical identifier. The physical identifier parameter is exchanged       }
  {           | between peer applications for accounting purposes.                        }
  { --------------------------------------------------------------------------------------}
  {    28     | destination host type. The destination host type parameter specifies the  }
  {           | mainframe host type of the receiving host. The initiating process can     }
  {           | use this parameter insure that the receiving process is of a spacific     }
  {           | known type. For a list of legal parameters see parameter 22.              }
  {           |                                                                           }
  { --------------------------------------------------------------------------------------}
  {    29     | echo. The echo parameter may be used on a RFT command by any application. }
  {           | The application receiving the RFT command may return the echo parameter   }
  {           | and data on the RPOS command. This will allow the initiating application  }
  {           | to verify the data returned. Since the application sending the echo       }
  {           | parameter can not expect that it will be returned, this parameter has     }
  {           | limited usefulness and is retained primarily for compatibility with       }
  {           | earlier versions of the protocol.                                         }
  { --------------------------------------------------------------------------------------}
  {    30     | command attributes continued. This parameter indicates that all the       }
  {           | attributes (parameters) for a given command could not be contained in     }
  {           | one message block, and that subsequent block with the same command will   }
  {           | be sent.                                                                  }
  { --------------------------------------------------------------------------------------}
  {    31     | data declaration. The data declaration parameter identifies the format    }
  {           | of the data on the network. The internal format of the data on various    }
  {           | host mainframes is dependent on that mainframes file management schemes.  }
  {           |     AR = Archival data with initiator application dependent structure.    }
  {           |     AS = Archival data with server application dependent structure.       }
  {           |     C6 = ASCII-64 character set data.                                     }
  {           |     C8 = 8 bit extended ASCII character set data.                         }
  {           |     UH = Undefined host dependent data structure.                         }
  {           |     US = Undefined logical data structure.                                }
  {           |     UU = Undefined and unstructured file.                                 }
  { --------------------------------------------------------------------------------------}
  {    32     | system routing text. The system routing text parameter provides           }
  {           | additional queue file routing text for enhanced queue file routing        }
  {           | capabilities between similar operating systems. This parameter overrides  }
  {           | implitit text values.                                                     }
  { --------------------------------------------------------------------------------------}
  {    33     | Implicit routing text. The Implicit Routing Text parameter provides the   }
  {           | text which accompanies an input file of disposition code 'IN'. This text  }
  {           | string must be returned with output files of any disposition code.        }
  { --------------------------------------------------------------------------------------}
  {   34-39   | reserved for CDC.                                                         }
  { --------------------------------------------------------------------------------------}
  {   40-50   | interactive transfer facility only.                                       }
  { --------------------------------------------------------------------------------------}
  {    51     | User file name. This parameter specifies the user assigned name of the    }
  {           | file disposed to the output device.                                       }
  { --------------------------------------------------------------------------------------}
  {    52     | Banner date and time. This parameter specifies the date and time that     }
  {           | the file transfer to the output devive is being initiated.                }
  { --------------------------------------------------------------------------------------}
  {    53     | Banner routing text. This parameter specifies the physical location       }
  {           | identifier for the place that the public I/O station operator is to       }
  {           | send the output file hard copy.                                           }
  { --------------------------------------------------------------------------------------}
  {    54     | User banner text. This parameter contains the user provided text string   }
  {           | that the receiver is to use when constructing the output file banner.     }
  { --------------------------------------------------------------------------------------}
  {    55     | Installation banner text. This parameter contains the installation        }
  {           | provided text string that the receiver is to use when constructing the    }
  {           | output file banner.                                                       }
  { --------------------------------------------------------------------------------------}
  {    56     | Reposition output parameters. This parameter contains the output file     }
  {           | repositioning command parameters to be used by the sender to define the   }
  {           | new file position.                                                        }
  { --------------------------------------------------------------------------------------}
  {    57     | Current file position. This parameter contains the current file position  }
  {           | byte and record ordinal.                                                  }
  { --------------------------------------------------------------------------------------}
  {    58     | Default output file destination. This parameter conatins the identity of  }
  {           | the default destination I/O station for output files disposed by the job  }
  {           | being transfered from an input batch device.                              }
  { ======================================================================================}
?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmt$vertical_print_density
*copyc nae$application_interfaces
*copyc nfc$command_definitions
*copyc nfc$parameter_00_definitions
*copyc nfc$parameter_01_definitions
*copyc nfc$parameter_02_definitions
*copyc nfc$parameter_03_definitions
*copyc nfc$parameter_04_definitions
*copyc nfc$parameter_05_definitions
*copyc nfc$parameter_06_definitions
*copyc nfc$parameter_07_definitions
*copyc nfc$parameter_08_definitions
*copyc nfc$parameter_09_definitions
*copyc nfc$parameter_10_definitions
*copyc nfc$parameter_11_definitions
*copyc nfc$parameter_12_definitions
*copyc nfc$parameter_13_definitions
*copyc nfc$parameter_16_definitions
*copyc nfc$parameter_17_definitions
*copyc nfc$parameter_20_definitions
*copyc nfc$parameter_21_definitions
*copyc nfc$parameter_22_definitions
*copyc nfc$parameter_24_definitions
*copyc nfc$parameter_25_definitions
*copyc nfc$parameter_26_definitions
*copyc nfc$parameter_27_definitions
*copyc nfc$parameter_28_definitions
*copyc nfc$parameter_29_definitions
*copyc nfc$parameter_30_definitions
*copyc nfc$parameter_31_definitions
*copyc nfc$parameter_32_definitions
*copyc nfc$parameter_33_definitions
*copyc nfc$parameter_52_definitions
*copyc nfc$parameter_90_definitions
*copyc nfc$parameter_91_definitions
*copyc nfc$parameter_92_definitions
*copyc nfc$parameter_93_definitions
*copyc nfc$parameter_94_definitions
*copyc nfc$parameter_95_definitions
*copyc nfc$parameter_96_definitions
*copyc nfc$parameter_97_definitions
*copyc nfc$parameter_98_definitions
*copyc nfc$parameter_99_definitions
*copyc nfc$parameter_definitions
*copyc nfe$batch_transfer_services
*copyc nfs$protocol_engine_static
*copyc nft$application_values
*copyc nft$buffer_control_block
*copyc nft$command_pdu_size
*copyc nft$command_set
*copyc nft$command_values
*copyc nft$control_block
*copyc nft$crack_parameter_action
*copyc nft$directive_entry
*copyc nft$file_access_mode
*copyc nft$last_command_received
*copyc nft$last_command_sent
*copyc nft$lcn_application_names
*copyc nft$mode_of_access
*copyc nft$nam_application_names
*copyc nft$network_type
*copyc nft$number_pdu_param_range
*copyc nft$p00_values
*copyc nft$parameter_00_values
*copyc nft$parameter_01_values
*copyc nft$parameter_03_elements
*copyc nft$parameter_03_netvalues
*copyc nft$parameter_03_value_set
*copyc nft$parameter_04_values
*copyc nft$parameter_06_values
*copyc nft$parameter_11_options
*copyc nft$parameter_11_values
*copyc nft$parameter_12_range
*copyc nft$parameter_17_definition
*copyc nft$parameter_17_element
*copyc nft$parameter_17_values
*copyc nft$parameter_20_range
*copyc nft$parameter_21_options
*copyc nft$parameter_21_specifications
*copyc nft$parameter_21_values
*copyc nft$parameter_22_strings
*copyc nft$parameter_22_values
*copyc nft$parameter_24_definition
*copyc nft$parameter_25_definition
*copyc nft$parameter_25_length
*copyc nft$parameter_26_all_chars
*copyc nft$parameter_26_definition
*copyc nft$parameter_27_definition
*copyc nft$parameter_27_length
*copyc nft$parameter_31_definition
*copyc nft$parameter_59_values
*copyc nft$parameter_numbers
*copyc nft$parameter_qualifiers
*copyc nft$parameter_qualifier_values
*copyc nft$parameter_rules
*copyc nft$parameter_set
*copyc nft$parameter_values
*copyc nft$protocol_commands
*copyc nft$protocol_parameters
*copyc nft$ptf_protocol_states
*copyc nft$required_param_on_command
*copyc nft$task_queue
*copyc nft$transfer_declarations
*copyc nft$transfer_modes
*copyc nft$transfer_status
*copyc osd$default_pragmats
*copyc ost$status
*copyc osv$lower_to_upper
*copyc rfe$condition_codes
?? POP ??
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
*copyc amp$open
*copyc amp$return
*copyc clp$convert_string_to_integer
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$read_variable
*copyc fsp$close_file
*copyc fsp$open_file
*copyc mmp$create_scratch_segment
*copyc nap$accept_connection
*copyc nap$acquire_connection
*copyc nap$attach_server_application
*copyc nap$await_data_available
*copyc nap$begin_directory_search
*copyc nap$detach_server_application
*copyc nap$end_directory_search
*copyc nap$get_title_translation
*copyc nap$request_connection
*copyc nap$se_receive_data
*copyc nap$se_send_data
*copyc nap$se_synchronize
*copyc nap$store_attributes
*copyc nfp$set_abnormal_if_normal
*copyc nfp$send_file
*copyc nfp$receive_file
*copyc osp$i_await_activity_completion
*copyc osp$set_status_from_condition
*copyc osp$append_status_parameter
*copyc osp$format_message
*copyc osp$get_status_condition_string
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$exit
*copyc pmp$get_job_names
*copyc pmp$get_legible_date_time
*copyc pmp$get_microsecond_clock
*copyc pmp$generate_unique_name
*copyc pmp$log
*copyc rfp$accept_connect_request
*copyc rfp$acquire_connect_request
*copyc rfp$application_sign_off
*copyc rfp$application_sign_on
*copyc rfp$await_rhfam_event
*copyc rfp$await_server_response
*copyc rfp$find_available_service
*copyc rfp$get_attributes
*copyc rfp$receive_data
*copyc rfp$request_connection
*copyc rfp$send_data
*copyc rfp$store

?? OLDTITLE ??
?? NEWTITLE := 'nfp$specify_pdu_parameter', EJECT ??

  PROCEDURE nfp$specify_pdu_parameter
    (    parameter_number: nft$protocol_parameters;
         parameter_qualifier: nft$parameter_qualifiers;
         parameter_value: string ( * <= nfc$max_param_size);
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$specify_pdu_parameter                                        }
{                                                                             }
{ Purpose    To encode a protocol parameter into a command buffer for         }
{            eventual transmittal to the remote application.                  }
{                                                                             }
{ Description                                                                 }
{            This routine stores away network parameters, in command buffer   }
{            format.  The command being sent is not important here, it is     }
{            specified when the buffer is sent ( by calling nfp$send_command).}
{            This routine actually maintains a linked list of command buffers }
{            and handles command continuation via protocol parameter 30.      }
{                                                                             }
{ Input parameters                                                            }
{            Parameter_number     : Parameter to be specified                 }
{            Parameter_qualifier  : Protocol parameter qualifier (S,M,I)      }
{            Parameter_value      : String representing protocol parameter    }
{                                                                             }
{ Output parameters                                                           }
{            Status               : Only errors pertaining to running out     }
{                                   of virtual memory space.                  }
{                                                                             }
{ Algorithm                                                                   }
{            If no buffers on list then                                       }
{              Allocate buffer                                                }
{            Else                                                             }
{              While buffers on list do                                       }
{                If buffer not complete Then                                  }
{                  Use buffer                                                 }
{                Else                                                         }
{                  If last buffer on list, allocate new                       }
{                Ifend                                                        }
{              Whilend                                                        }
{            Ifend                                                            }
{            If parameter does not fit in space left in buffer then           }
{              Put continuation in buffer                                     }
{              Specify buffer complete                                        }
{              Call self to put in parameter                                  }
{            Else                                                             }
{              Put parameter in buffer                                        }
{            Ifend                                                            }
{                                                                             }
?? EJECT ??
{}

    VAR
      current_buffer: ^nft$buffer_control_block,
      done: boolean,
      parameter_length: integer,
      parameter_plus_continue: integer,
      parameter_identifier: string (nfc$num_param_id_digits),
      parameter_count: string (nfc$num_param_size_digits),
      scratch_buffer_control_block: ^nft$buffer_control_block;

    VAR
      nfv$p30_value: [XREF] string (nfc$p30_required_space),
      nfv$param_id_values: [XREF] nft$parameter_values,
      nfv$param_qualifier_values: [XREF] nft$parameter_qualifier_values;

{}
    status.normal := TRUE;
    done := FALSE;
    current_buffer := buffer_list.head;
    WHILE NOT done DO
      IF current_buffer = NIL THEN { Allocate a buffer }
        ALLOCATE scratch_buffer_control_block;
        IF scratch_buffer_control_block = NIL THEN
          nfp$set_internal_error ('nfp$specify_pdu_parameter no vm', status);
          RETURN;
        IFEND;
        IF buffer_list.head = NIL THEN
          buffer_list.head := scratch_buffer_control_block;
          buffer_list.tail := scratch_buffer_control_block;
        ELSE
          buffer_list.tail^.next_buffer := scratch_buffer_control_block;
          buffer_list.tail := scratch_buffer_control_block;
        IFEND;
        current_buffer := scratch_buffer_control_block;
        current_buffer^.buffer_complete := FALSE;
        current_buffer^.number_parameters := 0;
        current_buffer^.space_left := nfc$command_buffer_size - nfc$begin_params_pos;
        current_buffer^.next_position := nfc$begin_params_pos;
        current_buffer^.next_buffer := NIL;
        done := TRUE;
      ELSE { Check for use of existing buffer }
        IF NOT current_buffer^.buffer_complete THEN {** We use this one **}
          done := TRUE;
        ELSE {** Continue search down list **}
          current_buffer := current_buffer^.next_buffer;
        IFEND;
      IFEND;
    WHILEND;
{}
{ At this point, current_buffer points to an available buffer }
{}
    parameter_length := STRLENGTH (parameter_value);
    parameter_plus_continue := parameter_length + nfc$param_header_size + STRLENGTH (nfv$p30_value);
    IF (current_buffer^.space_left <= parameter_plus_continue) OR
          (current_buffer^.number_parameters = nfc$max_parameter_count - 1) THEN
{}
{ Potentially not enough space for next parameter, continue here }
{}
      current_buffer^.buffer (current_buffer^.next_position, nfc$param_header_size) := nfc$p30_param_value;
      current_buffer^.next_position := current_buffer^.next_position + nfc$param_header_size;
      current_buffer^.number_parameters := current_buffer^.number_parameters + 1;
      current_buffer^.buffer_complete := TRUE;
{}
{ Now call myself to specify the parameter in question }
{}
      nfp$specify_pdu_parameter (parameter_number, parameter_qualifier, parameter_value, buffer_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
{}
{ Enough space, stuff the parameter }
{}
      current_buffer^.buffer (current_buffer^.next_position, nfc$num_param_id_digits) :=
            nfv$param_id_values [parameter_number];
      current_buffer^.next_position := current_buffer^.next_position + nfc$num_param_id_digits;
      current_buffer^.buffer (current_buffer^.next_position,
            nfc$num_param_qual_digits) := nfv$param_qualifier_values [parameter_qualifier];
      current_buffer^.next_position := current_buffer^.next_position + nfc$num_param_qual_digits;
      clp$convert_integer_to_rjstring (STRLENGTH (parameter_value), nfc$parameter_length_radix, FALSE,
            nfc$parameter_fill_char, current_buffer^.buffer (current_buffer^.next_position,
            nfc$num_param_size_digits), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      current_buffer^.next_position := current_buffer^.next_position + nfc$num_param_size_digits;
      IF parameter_length > 0 THEN
        current_buffer^.buffer (current_buffer^.next_position, parameter_length) := parameter_value;
        current_buffer^.next_position := current_buffer^.next_position + parameter_length;
      IFEND;
      current_buffer^.space_left := current_buffer^.space_left - (nfc$param_header_size + parameter_length);
      current_buffer^.number_parameters := current_buffer^.number_parameters + 1;
    IFEND;
    {}
  PROCEND nfp$specify_pdu_parameter;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$send_command', EJECT ??

  PROCEDURE [XDCL] nfp$send_command
    (    command: nft$protocol_commands;
         select_parameters: nft$parameter_set;
         ignore_parameters: nft$parameter_set;
         modify_parameters: nft$parameter_set;
     VAR transfer_control: nft$control_block;
     VAR status: ost$status);

{
{ Procedure nfp$send_command
{
{ Purpose    Called to assemble zero or more parameters into a command
{            block and send it to the connected remote host.
{
{ Description
{            This routine is called specifying a set of parameters to be
{            placed in the command buffer(s).  A service routine will be
{            called for each parameter.  Note: parameters placed in the
{            command buffer ( via call to nfp$specify_pdu_parameter )
{            will ALSO be sent.  This provides a simple interface for
{            for modifying or ignoring parameters which are not critical
{            to a transfer ( in RFT -> RPOS negotiation ).
{
{ Input parameters
{            Command       : A-A protocol command
{            Select_Parameters    : Set of A-A protocol parameters to select
{            Ignore_Parameters    : Set of A-A protocol parameters to ignore
{            Modify_Parameters    : Set of A-A protocol parameters to modify
{
{ Output parameters
{            Status               : Return status
{
{ Input/Output parameters
{            Transfer_control     : Application control block
{
{ Algorithm
{            For all known parameters Do
{              If parameter to be specified Then
{                Case to parameter sent service routine
{              Ifend
{            Forend
{            Nfp$transmit_pdus_to_remote
{
?? EJECT ??

    VAR
      current_buffer: ^nft$buffer_control_block,
      current_buffer_address: ^nft$buffer_control_block,
      index: nft$protocol_parameters,
      qualifier: nft$parameter_qualifiers;
    {}
    status.normal := TRUE;
    /parameter_search_loop/
    FOR index := LOWERVALUE (index) TO UPPERVALUE (index) DO
      IF index IN select_parameters THEN
        qualifier := nfc$select;
      ELSEIF index  IN modify_parameters THEN
        qualifier := nfc$modify;
      ELSEIF index IN ignore_parameters THEN
        qualifier := nfc$ignore;
      ELSE
        CYCLE /parameter_search_loop/;
      IFEND;

{     Case to parameter service routine

        CASE index OF
        = nfc$protocol_id =
            nfp$send_protocol_parameter_00 (transfer_control.protocol_in_use, qualifier,
                transfer_control.network_buffer_list, status);
        = nfc$maximum_file_length =
            nfp$send_protocol_parameter_01 (transfer_control.maximum_file_size, qualifier,
                transfer_control.network_buffer_list, status);
        = nfc$transfer_id =
          ;
        = nfc$facilities =
            nfp$send_protocol_parameter_03 (qualifier, transfer_control.send_facilities,
                 transfer_control.network_buffer_list, status);
            IF status.normal THEN
              transfer_control.transfer_facilities := transfer_control.send_facilities;
            IFEND;
        = nfc$state_of_transfer =
            nfp$send_protocol_parameter_04 (transfer_control.state_of_transfer, qualifier,
                transfer_control.network_buffer_list, status);
        = nfc$user_text_directive =
            nfp$send_protocol_parameter_05 (transfer_control.send_directives, qualifier,
                transfer_control.network_buffer_list, status);
        = nfc$file_length =
            nfp$send_protocol_parameter_06 (transfer_control.file_size, qualifier,
                transfer_control.network_buffer_list, status);
        = nfc$operator_message =
            nfp$send_protocol_parameter_07 (transfer_control.send_operator_messages, qualifier,
                transfer_control.parameter_rules^ [nfc$operator_message]^ [transfer_control.protocol_in_use].
                maximum_parameter_length, transfer_control.network_buffer_list, status);
        = nfc$user_message =
            nfp$send_protocol_parameter_08 (transfer_control.protocol_in_use,
                transfer_control.send_user_messages, qualifier, transfer_control.
                parameter_rules^ [nfc$user_message]^ [transfer_control.protocol_in_use].
                maximum_parameter_length, transfer_control.network_buffer_list, status);
        = nfc$account_message =
            nfp$send_protocol_parameter_09 (transfer_control.protocol_in_use,
                transfer_control.send_account_messages, qualifier, transfer_control.
                parameter_rules^ [nfc$account_message]^ [transfer_control.protocol_in_use].
                maximum_parameter_length, transfer_control.network_buffer_list, status);
        = nfc$error_log_message =
            nfp$send_protocol_parameter_10 (transfer_control.protocol_in_use,
                transfer_control.send_errorlog_messages, qualifier, transfer_control.
                parameter_rules^ [nfc$error_log_message]^ [transfer_control.protocol_in_use].
                maximum_parameter_length, transfer_control.network_buffer_list, status);
        = nfc$special_options =
            nfp$send_protocol_parameter_11 (transfer_control.remote_host_type,
                transfer_control.send_special_options, qualifier, transfer_control.network_buffer_list,
                status);
        = nfc$max_block_size =
            nfp$send_protocol_parameter_12 (transfer_control.protocol_in_use,
                transfer_control.data_block_size,
                qualifier, transfer_control.network_buffer_list, status);
        = nfc$accounting_limit =
            nfp$send_protocol_parameter_13( transfer_control.accounting_limit,
                    qualifier, transfer_control.network_buffer_list, status);
        = nfc$file_name =
            nfp$send_protocol_parameter_16 (transfer_control.send_file_name.value
                (1, transfer_control.send_file_name.size),
                transfer_control.protocol_in_use,
                qualifier, transfer_control.parameter_rules^ [nfc$job_name]^
                [transfer_control.protocol_in_use].maximum_parameter_length,
                transfer_control.network_buffer_list,
                status);
        = nfc$file_disposition =
            nfp$send_protocol_parameter_17(transfer_control.disposition_code,
             qualifier, transfer_control.network_buffer_list, status);
        = nfc$acknowledgment_window =
            nfp$send_protocol_parameter_18(transfer_control.acknowledgment_window,
             qualifier, transfer_control.network_buffer_list, status);
        = nfc$initial_checkmark =
            nfp$send_protocol_parameter_19(transfer_control.initial_restart_checkmark,
             qualifier, transfer_control.network_buffer_list, status);
        = nfc$minimum_timeout_interval =
            nfp$send_protocol_parameter_20 (transfer_control.protocol_in_use, transfer_control.time_out,
                qualifier, transfer_control.parameter_rules^ [nfc$minimum_timeout_interval]^
                [transfer_control.protocol_in_use].maximum_parameter_length,
                transfer_control.network_buffer_list, status);
        = nfc$mode_of_access =
            nfp$send_protocol_parameter_21 (transfer_control.protocol_in_use, transfer_control.mode_of_access,
                transfer_control.mode_of_access_option, qualifier, transfer_control.
                parameter_rules^ [nfc$mode_of_access]^ [transfer_control.protocol_in_use].
                maximum_parameter_length, transfer_control.network_buffer_list, status);
        = nfc$host_type =
            nfp$send_protocol_parameter_22 (transfer_control.local_host_type, qualifier,
                transfer_control.network_buffer_list, status);
        = nfc$transfer_phase_attribute =
          ;
        = nfc$source_lid =
            nfp$send_protocol_parameter_24 (
                transfer_control.source_lid.value(1,transfer_control.source_lid.size), qualifier,
                transfer_control.parameter_rules^ [nfc$source_lid]^ [transfer_control.protocol_in_use].
                minimum_parameter_length, transfer_control.parameter_rules^ [nfc$source_lid]^
                [transfer_control.protocol_in_use].maximum_parameter_length,
                transfer_control.network_buffer_list, status);
        = nfc$transfer_lid =
            nfp$send_protocol_parameter_25 (transfer_control.protocol_in_use, transfer_control.
                transfer_lid (1, transfer_control.transfer_lid_length), qualifier,
                transfer_control.parameter_rules^ [nfc$transfer_lid]^ [transfer_control.protocol_in_use].
                maximum_parameter_length, transfer_control.network_buffer_list, status);
        = nfc$job_name =
            nfp$send_protocol_parameter_26 (transfer_control.protocol_in_use,
                transfer_control.application,
                transfer_control.send_job_name.value(1,transfer_control.
                send_job_name.size),
                qualifier, transfer_control.parameter_rules^ [nfc$job_name]^
                [transfer_control.protocol_in_use].maximum_parameter_length,
                transfer_control.network_buffer_list, status);
        = nfc$physical_id =
            nfp$send_protocol_parameter_27 (transfer_control.protocol_in_use, transfer_control.
                transfer_pid (1, transfer_control.transfer_pid_length), qualifier,
                transfer_control.parameter_rules^ [nfc$physical_id]^ [transfer_control.protocol_in_use].
                maximum_parameter_length, transfer_control.network_buffer_list, status);
        = nfc$destination_host_type =
            nfp$send_protocol_parameter_28 (transfer_control.expected_host_type, qualifier,
                transfer_control.network_buffer_list, status);
        = nfc$echo =
            nfp$send_protocol_parameter_29( transfer_control.send_echo_text, qualifier,
                transfer_control.network_buffer_list, status);
        = nfc$attribute_continued =
          ;
        = nfc$data_declaration =
            nfp$send_protocol_parameter_31 (transfer_control.data_declaration, qualifier,
                transfer_control.network_buffer_list, status);
        = nfc$system_routing_text =
            IF transfer_control.send_systems_routing_text.size < 1 THEN
              nfp$set_internal_error ('nfp$send_command no systems routing text', status);
            IFEND;
            nfp$send_protocol_parameter_32 (transfer_control.send_systems_routing_text.
                parameters(1, transfer_control.send_systems_routing_text.size), qualifier,
                transfer_control.network_buffer_list, status);
        = nfc$implicit_routing_text =
            IF transfer_control.send_implicit_routing_text.size < 1 THEN
              nfp$set_internal_error ('nfp$send_command no implicit routing text', status);
            IFEND;
            nfp$send_protocol_parameter_33 (transfer_control.send_implicit_routing_text.
                  text (1, transfer_control.send_implicit_routing_text.size), qualifier,
                  transfer_control.network_buffer_list, status);
        = nfc$user_file_name =
            nfp$send_protocol_parameter_51 (transfer_control.protocol_in_use, command,
                transfer_control.user_file_name.value (1, transfer_control.user_file_name.size), qualifier,
                transfer_control.network_buffer_list, status);
        = nfc$banner_date_and_time =
            nfp$send_protocol_parameter_52 ( qualifier,
                transfer_control.banner_date_and_time.value(1,
                transfer_control.banner_date_and_time.size),
                transfer_control.network_buffer_list, status);
        = nfc$banner_routing_text =
            nfp$send_protocol_parameter_53 (transfer_control.protocol_in_use, command,
                transfer_control.banner_routing_text.value (1, transfer_control.banner_routing_text.size),
                qualifier, transfer_control.network_buffer_list, status);
        = nfc$user_banner_text =
            nfp$send_protocol_parameter_54 (transfer_control.protocol_in_use, command,
                transfer_control.user_banner_message.value (1, transfer_control.user_banner_message.size),
                qualifier, transfer_control.network_buffer_list, status);
        = nfc$installation_banner_text =
            nfp$send_protocol_parameter_55 (transfer_control.protocol_in_use, command,
                transfer_control.installation_banner_message.value
                (1, transfer_control.installation_banner_message.size), qualifier,
                transfer_control.network_buffer_list, status);
        = nfc$reposition_output_params =
            nfp$send_protocol_parameter_56 (transfer_control.protocol_in_use, command,
                transfer_control.reposition_output_file.value (1,
                transfer_control.reposition_output_file.size), qualifier,
                transfer_control.network_buffer_list, status);
        = nfc$current_file_position =
            nfp$send_protocol_parameter_57 (transfer_control.protocol_in_use, command,
                transfer_control.current_file_position.value (1, transfer_control.current_file_position.size),
                qualifier, transfer_control.network_buffer_list, status);
        = nfc$output_file_destination =
            nfp$send_protocol_parameter_58 (transfer_control.protocol_in_use, command,
                transfer_control.default_output_file_destination.
                value (1, transfer_control.default_output_file_destination.size), qualifier,
                transfer_control.network_buffer_list, status);
        = nfc$vertical_print_density =
             nfp$send_protocol_parameter_59(
                    transfer_control.vertical_print_density, qualifier,
                    transfer_control.network_buffer_list, status);
        = nfc$vfu_load_procedure =
             IF transfer_control.vfu_load_procedure.size > 0 THEN
               nfp$send_protocol_parameter_60(
                    transfer_control.vfu_load_procedure.value(1,
                    transfer_control.vfu_load_procedure.size),
                    qualifier,
                    transfer_control.network_buffer_list, status);
             ELSE
               nfp$set_internal_error('vfu_load_procedure size = 0', status);
             IFEND;
          ;
        = nfc$reserved_for_site_90 =
          ;
        = nfc$reserved_for_site_91 =
          ;
        = nfc$reserved_for_site_92 =
          ;
        = nfc$reserved_for_site_93 =
          ;
        = nfc$reserved_for_site_94 =
          ;
        = nfc$reserved_for_site_95 =
          ;
        = nfc$reserved_for_site_96 =
          ;
        = nfc$reserved_for_site_97 =
          ;
        = nfc$reserved_for_site_98 =
          ;
        = nfc$reserved_for_site_99 =
          ;
        ELSE
          nfp$set_internal_error ('nfp$send_command', status);
        CASEND;
        IF NOT status.normal THEN

{         Release the protocol parameters on the network buffer list so that
{         they do not appear on the next SEND_COMMAND protocol parameter list

          current_buffer := transfer_control.network_buffer_list.head;
          WHILE current_buffer <> NIL DO
            current_buffer_address := current_buffer;
            current_buffer := current_buffer^ .next_buffer;
            FREE current_buffer_address;
          WHILEND;
          transfer_control.network_buffer_list.head := NIL;
          RETURN;
        IFEND;
    FOREND;
    {}
    {     PDU's for this command have been built and no errors have
    {     occured.  Send the PDU's on the network
    {}
    nfp$transmit_pdus_to_remote (command, transfer_control.application, transfer_control.protocol_trace,
          transfer_control.network_buffer_list, transfer_control.path, status);
    IF status.normal THEN
      transfer_control.last_command_sent := command;
    IFEND;
    {}
  PROCEND nfp$send_command;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$transmit_pdus_to_remote', EJECT ??

{ PURPOSE:
{   This procedure will send the buffer(s) encoded by nfp$send_command to the
{   remote host by encoding the command and number of parameters into the
{   command buffer(s) and sends them on the network.
{
{ NOTE:
{   If no parameters where specified for the command (e.g. GO) the buffer
{   needs to be allocated here.

  PROCEDURE nfp$transmit_pdus_to_remote
    (    command: nft$protocol_commands;
         application: nft$application_values;
         protocol_trace: boolean;
     VAR buffer_list: nft$network_buffer_list;
     VAR path: nft$network_connection;
     VAR status: ost$status);

    VAR
      address: ^nft$buffer_control_block,
      current_buffer: ^nft$buffer_control_block,
      terminate_status: ost$status;

    VAR
      nfv$command_values: [XREF] nft$command_values;

    status.normal := TRUE;
    IF buffer_list.head = NIL THEN
      ALLOCATE buffer_list.head;
      IF buffer_list.head = NIL THEN
        nfp$set_internal_error ('nfp$transmit_pdus_to_remote no vm', status);
        RETURN;
      IFEND;
      current_buffer := buffer_list.head;
      current_buffer^.buffer_complete := FALSE;
      current_buffer^.number_parameters := 0;
      current_buffer^.space_left := nfc$command_buffer_size;
      current_buffer^.next_position := nfc$begin_params_pos;
      current_buffer^.next_buffer := NIL;
    IFEND;

    current_buffer := buffer_list.head;
    WHILE current_buffer <> NIL DO
      current_buffer^.buffer (nfc$pdu_command_pos, nfc$pdu_command_len) := nfv$command_values [command];
      clp$convert_integer_to_rjstring (current_buffer^.number_parameters, nfc$command_radix,
            nfc$command_include_radix, nfc$command_fill_char, current_buffer^.
            buffer (nfc$pdu_nparams_pos, nfc$pdu_nparams_len), status);
      IF NOT status.normal THEN

{       delete the rest of the parameters from the link list

        WHILE current_buffer <> NIL DO
          address := current_buffer;
          current_buffer := current_buffer^ .next_buffer;
          FREE address;
        WHILEND;
        buffer_list.head := NIL;
        RETURN;
      IFEND;
      nfp$write_network_block (application, path.network_file_id, path.network_type, current_buffer^.
            buffer (1, current_buffer^.next_position - 1), protocol_trace, status);
      IF NOT status.normal THEN { Network error }
        nfp$terminate_path (application, FALSE, path, terminate_status);

{       delete the rest of the parameters from the link list

        WHILE current_buffer <> NIL DO
          address := current_buffer;
          current_buffer := current_buffer^ .next_buffer;
          FREE address;
        WHILEND;
        buffer_list.head := NIL;
        RETURN;
      IFEND;
      address := current_buffer;
      current_buffer := current_buffer^.next_buffer;
      FREE address;
    WHILEND;
    buffer_list.head := NIL;

  PROCEND nfp$transmit_pdus_to_remote;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$crack_command', EJECT ??

  PROCEDURE [XDCL] nfp$crack_command
    (    command_string: string (nfc$pdu_command_len);
     VAR command: nft$protocol_commands;
     VAR status: ost$status);

{                                                                             }
{ Procedure nfp$crack_command                                                 }
{                                                                             }
{ Purpose   To convert a string to a protocol command ordinal.                }
{                                                                             }
{ Description                                                                 }
{           This routine attempts to match a protocol command to a known      }
{           value.  If the received value does not match a known value,       }
{           a protocol error is returned                                      }
{                                                                             }
{ Input parameters                                                            }
{           Command_string       : Input command                              }
{                                                                             }
{ Output parameters                                                           }
{           Command              : Command ordinal                            }
{           Status               : NORMAL or                                  }
{                                  Nfe$invalid_protocol_command               }
{ Algorithm                                                                   }
{           If input commmand string length invalid then error                }
{           For i = 1 To number of known comman                               }
{             If input command = command list[i] Then                         }
{               Set valid                                                     }
{               Exit for loop                                                 }
{           Forend                                                            }
{           If valid then                                                     }
{             Set command ordinal                                             }
{           Else                                                              }
{             Set error                                                       }
{           Ifend                                                             }
{                                                                             }
?? EJECT ??

    VAR
      command_length: 0 .. nfc$command_buffer_size,
      found_it: boolean,
      index: nft$protocol_commands;

    VAR
      nfv$command_values: [XREF] nft$command_values;

{}
    status.normal := TRUE;
    command_length := STRLENGTH (command_string);
    IF (command_length <> nfc$pdu_command_len) THEN
      osp$set_status_abnormal (nfc$status_id, nfe$invalid_protocol_command, command_string, status);
      RETURN;
    IFEND;
{}
    found_it := FALSE;

  /command_search_loop/
    FOR index := LOWERVALUE (index) TO UPPERVALUE (index) DO
      IF nfv$command_values [index] = command_string THEN
        found_it := TRUE;
        EXIT /command_search_loop/;
      IFEND;
    FOREND /command_search_loop/;
{}
    IF found_it THEN
      command := index;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$invalid_protocol_command, command_string, status);
    IFEND;
{}
  PROCEND nfp$crack_command;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$crack_number_of_parameters', EJECT ??

  PROCEDURE [XDCL] nfp$crack_number_of_parameters
    (    number_string: string (nfc$pdu_nparams_len);
     VAR number_parameters: nft$number_pdu_param_range;
     VAR status: ost$status);

    {
    {
    { Procedure nfp$crack_number_of_parameters
    {
    {
    {
    { Purpose   To return the number of parameters in a command.
    {
    {
    {
    { Description
    {
    {           This routine cracks the number of parameters present in a
    {           protocol command.
    {
    { Input parameters
    {
    {           Number_string        : String representing # of parameters
    {
    {
    {
    { Output parameters
    {
    {           Number_of_parameters : Return # of parameters
    {           Status               : Normal or
    {                                    Nfe$invalid_param_count
    {
    {
    { Algorithm
    {
    {           Convert string to integer
    {           If convert o.k., check # params in valid range
    {
?? EJECT ??

    VAR
      length_record: clt$integer;

    {}
    status.normal := TRUE;
    clp$convert_string_to_integer (number_string, length_record, status);
    IF status.normal THEN
      IF ((length_record.value > nfc$max_parameter_count) OR
            (length_record.value < nfc$min_parameter_count) OR (length_record.radix_specified)) THEN
        status.normal := FALSE;
      IFEND;
    IFEND;
    {}
    IF status.normal THEN
      number_parameters := length_record.value;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$invalid_param_count, number_string, status);
    IFEND;
    {}
  PROCEND nfp$crack_number_of_parameters;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$get_and_crack_command', EJECT ??

{ PURPOSE:
{   This procedure reads a command from the network, cracks the command and
{   the number of parameters associated with the command.  The command is
{   validated against the expected command(s) of the application.
{
{ NOTE:
{   PTFS boot will use this routine for RFT/job file processing.

  PROCEDURE [XDCL] nfp$get_and_crack_command
    (    legal_commands: nft$command_set;
         input_buffer: ^string (nfc$command_buffer_size);
     VAR control_block: nft$control_block;
     VAR input_length: nft$command_pdu_size;
     VAR number_of_parameters: nft$number_pdu_param_range;
     VAR received_command: nft$protocol_commands;
     VAR command_in_process: nft$protocol_commands;
     VAR status: ost$status);

    VAR
      terminate_status: ost$status,
      trace_status: ost$status;

    status.normal := TRUE;
    nfp$read_network_block (control_block.application, control_block.path.network_file_id, control_block.path.
          network_type, control_block.time_out, control_block.protocol_trace, input_buffer^, input_length,
          status);
    IF NOT status.normal THEN

{   network error

      nfp$terminate_path (control_block.application, FALSE, control_block.path, terminate_status);
      RETURN;
    ELSE

{   crack parameters

      IF input_length < nfc$pdu_header_size THEN
        nfp$set_internal_error ('nfp$get_and_crack_command invalid length', status);
        RETURN;
      IFEND;
      nfp$crack_command (input_buffer^ (nfc$pdu_command_pos, nfc$pdu_command_len), received_command, status);
      IF NOT status.normal THEN
        RETURN;
      ELSE
        IF command_in_process <> nfc$unknown_command THEN
          IF received_command <> command_in_process THEN
            osp$set_status_condition ( nfe$invalid_command_code,  status);
            RETURN;
          IFEND;
        ELSE
          command_in_process := received_command;
          control_block.last_command_received := received_command;
          IF NOT (received_command IN legal_commands) THEN
            osp$set_status_condition ( nfe$invalid_command_code,  status);
            RETURN;
          IFEND;
        IFEND;
      IFEND;

      nfp$crack_number_of_parameters (input_buffer^ (nfc$pdu_nparams_pos, nfc$pdu_nparams_len),
            number_of_parameters, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND nfp$get_and_crack_command;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$crack_parameter', EJECT ??

{ PURPOSE:
{   This procedure will analyze a protocol parameter for validity and qualities.
{   The parameter context is checked, if it is valid for this command.  If it is
{   valid, its length and qualifier characteristics are checked.
{
{ NOTE:
{   The parameter ABORT_XFER means that an invalid parameter length was identified,
{   and that this command is invalid and therefore, this transfer should be terminated.

  PROCEDURE [XDCL] nfp$crack_parameter
    (    command: nft$protocol_commands;
         protocol: nft$parameter_00_values;
         parameter: string ( * <= nfc$max_qualified_param_size);
         param_rules: nft$parameter_rules_array;
     VAR buffer_list: nft$network_buffer_list;
     VAR length: nft$parameter_size;
     VAR value: string ( * <= nfc$max_param_size);
     VAR identifier: nft$protocol_parameters;
     VAR qualifier: nft$parameter_qualifiers;
     VAR action: nft$crack_parameter_action;
     VAR ignored_params: nft$parameter_set;
     VAR abort_xfer: boolean;
     VAR status: ost$status);

    VAR
      found_id: boolean,
      found_qual: boolean,
      index: nft$protocol_parameters,
      length_record: clt$integer,
      qualifier_index: nft$parameter_qualifiers,
      scratch: nft$parameter_rules,
      trace_status: ost$status;

    VAR
      nfv$param_id_values: [XREF] nft$parameter_values;

    VAR
      nfv$param_qualifier_values: [XREF] nft$parameter_qualifier_values;

{ Crack parameter identifier (number)

    status.normal := TRUE;
    found_id := FALSE;
    abort_xfer := FALSE;
    action := nfc$do_not_process;

  /forloop/
    FOR index := LOWERVALUE (index) TO UPPERVALUE (index) DO
      IF parameter (1, nfc$num_param_id_digits) = nfv$param_id_values [index] THEN
        identifier := index;
        found_id := TRUE;
        EXIT /forloop/
      IFEND;
    FOREND /forloop/;
    IF found_id THEN
      scratch := param_rules [identifier]^;
    IFEND;

{ Crack parameter qualifier

    found_qual := FALSE;

  /for_qual_loop/
    FOR qualifier_index := LOWERVALUE (qualifier_index) TO UPPERVALUE (qualifier_index) DO
      IF parameter (nfc$param_qual_pos, nfc$num_param_qual_digits) =
            nfv$param_qualifier_values [qualifier_index] THEN
        found_qual := TRUE;
        EXIT /for_qual_loop/;
      IFEND;
    FOREND /for_qual_loop/;
    IF found_qual THEN
      qualifier := qualifier_index;
    IFEND;

{     Crack parameter length

    clp$convert_string_to_integer (parameter (nfc$param_size_pos, nfc$num_param_size_digits), length_record,
          status);
    IF (NOT status.normal) OR (length_record.value < nfc$min_param_size) OR
          (length_record.value > nfc$max_param_size) THEN
      osp$set_status_abnormal (nfc$status_id, nfe$parameter_length_error,
            parameter (1, nfc$param_header_size), status);
      abort_xfer := TRUE;
      RETURN;
    ELSE
      length := length_record.value;
      value := parameter (nfc$param_value_pos, length);
    IFEND;

{ Check if the parameter is processed by application

    IF found_id AND found_qual THEN
      IF (NOT scratch [protocol].valid_for_protocol) THEN
      { Not valid for application/protocol, ignore }
        IF ((command = nfc$rft) OR (command = nfc$stop) OR (command = nfc$rneg) OR
              ((command = nfc$rpos) AND (abort_xfer))) THEN
          ignored_params := ignored_params + $nft$parameter_set [identifier];
          nfp$specify_pdu_parameter (identifier, nfc$ignore, value (1, length), buffer_list, status);
        ELSE
          ; { Parameter is not processed, pretend it was not there }
        IFEND;
      ELSE { Processable }

{ CHECK PARAMETER LENGTH

        IF ((length < scratch [protocol].minimum_parameter_length) OR
              (length > scratch [protocol].maximum_parameter_length)) THEN
          osp$set_status_abnormal (nfc$status_id, nfe$parameter_length_error,
                parameter (1, nfc$param_header_size), status);
        ELSE
          action := nfc$process;
        IFEND;
      IFEND;
    IFEND;

  PROCEND nfp$crack_parameter;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$receive_command', EJECT ??

  PROCEDURE [XDCL] nfp$receive_command
    (    legal_commands: nft$command_set;
         required_params: nft$required_param_on_command;
     VAR control_block: nft$control_block;
     VAR received_params: nft$parameter_set;
     VAR ignored_params: nft$parameter_set;
     VAR modified_params: nft$parameter_set;
     VAR status: ost$status);

{                                                                             }
{ Procedure nfp$receive_command                                        }
{                                                                             }
{ Purpose   Receive a command (in one or more network blocks).                }
{                                                                             }
{ Description                                                                 }
{            This routine reads all network blocks in a command.  Processable }
{            parameters in each block are sent to service routines for        }
{            analysis.  Required parameters for command processing is also    }
{            done here                                                        }
{                                                                             }
{ Input parameters                                                            }
{            Legal_commands       : Set of A-A commands the application will  }
{                                   accept at this juncture.                  }
{            Required_parms       : Structure defining parameters required    }
{                                   on each protocol command for the          }
{                                   application.                              }
{                                                                             }
{ Output parameters                                                           }
{            Status               : Values returned by                        }
{                                     nfp$get_and_crack_command               }
{                                     nfp$crack_parameter                     }
{                                     Parameter service routines              }
{                                   -or- nfe$required_parameter_missing       }
{                                                                             }
{ Input/Output parameters                                                     }
{            Control_block        : Application control block                 }
{                                                                             }
{ Algorithm                                                                   }
{            While not done do                                                }
{              Nfp$get_and_crack_command                                      }
{              If not status.normal then return                               }
{              For i = 1 to # of parameters do                                }
{                Crack parameter                                              }
{                If parameter processable then                                }
{                  Case to parameter service routine                          }
{                Ifend                                                        }
{              Forend                                                         }
{              If no continuation, done = true                                }
{            Whilend                                                          }
{            If received parameters < required then                           }
{              Set error, return                                              }
{            Ifend                                                            }
{                                                                             }
?? EJECT ??

    VAR
      automatic_ignored_params: nft$parameter_set,
      automatic_modified_params: nft$parameter_set,
      command_in_process: nft$protocol_commands,
      input_buffer: ^string (nfc$command_buffer_size),
      input_length: nft$command_pdu_size,
      message_string: string(osc$max_string_size),
      message_string_length: 0..osc$max_string_size,
      missing_parameters: nft$parameter_set,
      more_command_blocks: boolean,
      number_of_parameters: nft$number_pdu_param_range,
      protocol_parameter: nft$protocol_parameters,
      received_command: nft$protocol_commands,
      received_pdu_params: nft$parameter_set;

    VAR
      nfv$param_id_values: [XREF] nft$parameter_values;

    VAR
      nfv$command_values: [XREF] nft$command_values;
{}
    status.normal := TRUE;
    command_in_process := nfc$unknown_command;
    received_params := $nft$parameter_set [];
    ignored_params := $nft$parameter_set [];
    modified_params := $nft$parameter_set [];
    control_block.last_auto_modify_ignore := $nft$parameter_set [];
    PUSH input_buffer;

  /main_loop/
    REPEAT
      {}
      { read network block }
      {}
      nfp$get_and_crack_command (legal_commands, input_buffer, control_block, input_length,
            number_of_parameters, received_command, command_in_process, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      nfp$crack_pdu (received_command, input_buffer^ (1, input_length), number_of_parameters,
            more_command_blocks, received_pdu_params, automatic_ignored_params, automatic_modified_params,
            control_block, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      received_params := received_params + received_pdu_params;
      ignored_params := ignored_params + automatic_ignored_params;
      modified_params := modified_params + automatic_modified_params;
      {}
    UNTIL NOT more_command_blocks;
    control_block.last_auto_modify_ignore := ignored_params + modified_params;
    {}
    {     Check have all REQUIRED parameters }
    {}
    IF NOT (required_params [received_command] <= received_params) THEN
      missing_parameters := required_params[received_command] - received_params;
      message_string_length := 1;
      /build_missing_param_string/
      FOR protocol_parameter := lowervalue(nft$protocol_parameters) to
             uppervalue(nft$protocol_parameters) DO
        IF protocol_parameter IN missing_parameters THEN
          message_string(message_string_length,nfc$num_param_id_digits) :=
             nfv$param_id_values[protocol_parameter];
          message_string_length := message_string_length +
             nfc$num_param_id_digits;
          message_string(message_string_length,1) := ' ';
          message_string_length := message_string_length + 1;
          IF message_string_length + (nfc$num_param_id_digits + 1) >=
             osc$max_string_size THEN
            EXIT /build_missing_param_string/;
          IFEND;
        IFEND;
      FOREND;
      IF message_string_length > 1 THEN
        message_string_length := message_string_length - 1;
        osp$set_status_abnormal (nfc$status_id, nfe$required_parameter_missing,
             message_string(1,message_string_length), status);
      IFEND;
      osp$append_status_parameter(osc$status_parameter_delimiter,
             nfv$command_values[received_command], status);
    IFEND;
    {}
  PROCEND nfp$receive_command;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$crack_pdu', EJECT ??

{ PURPOSE:
{   This procedure will crack and process all the parameters from a PDU,
{   which is input to this procedure.  Each parameter in the PDU is cracked.
{   As each parameter is cracked, it may be processed by a service application
{   or ignored.

  PROCEDURE [XDCL] nfp$crack_pdu
    (    received_command: nft$protocol_commands;
         input_buffer: string ( * <= nfc$command_buffer_size);
         number_of_parameters: nft$number_pdu_param_range;
     VAR more_command_blocks: boolean;
     VAR received_params: nft$parameter_set;
     VAR ignored_params: nft$parameter_set;
     VAR modified_params: nft$parameter_set;
     VAR control_block: nft$control_block;
     VAR status: ost$status);

    VAR
      abort_xfer: boolean,
      action: nft$crack_parameter_action,
      buffer_position: 0 .. nfc$command_buffer_size,
      parameter_identifier: nft$protocol_parameters,
      parameter_index: nft$number_pdu_param_range,
      parameter_length: nft$parameter_size,
      parameter_modified: boolean,
      parameter_processed: boolean,
      parameter_qualifier: nft$parameter_qualifiers,
      parameter_value: string (nfc$max_param_size),
      procedure_status: ost$status,
      protocol_negotiation: boolean,
      p11_value: nft$parameter_11_options;

    status.normal := TRUE;
    procedure_status.normal := TRUE;
    more_command_blocks := FALSE;
    received_params := $nft$parameter_set [];
    ignored_params := $nft$parameter_set [];
    modified_params := $nft$parameter_set [];
    buffer_position := nfc$begin_params_pos;
    protocol_negotiation := (control_block.negotiate_protocol) AND (received_command = nfc$rneg);
    FOR parameter_index := 1 TO number_of_parameters DO
      parameter_modified := FALSE;
      nfp$crack_parameter (received_command, control_block.protocol_in_use,
            input_buffer (buffer_position, * ), control_block.parameter_rules^,
            control_block.network_buffer_list, parameter_length, parameter_value, parameter_identifier,
            parameter_qualifier, action, ignored_params, abort_xfer, status);
      IF  NOT status.normal THEN
        nfp$format_message_to_job_log (status);
        nfp$set_abnormal_if_normal(status,procedure_status);
        IF abort_xfer THEN
          RETURN;
        IFEND;
      ELSE
        IF action = nfc$process THEN
          received_params := received_params + $nft$parameter_set [parameter_identifier];
          CASE parameter_identifier OF
          = nfc$protocol_id =
            nfp$receive_parameter_00 (received_command, parameter_value (1, parameter_length),
                  parameter_qualifier, control_block.protocol_in_use, control_block.protocol_in_use,
                  control_block.negotiate_protocol, status);
            protocol_negotiation := (control_block.negotiate_protocol) AND (received_command = nfc$rneg);
          = nfc$maximum_file_length =
            nfp$receive_parameter_01 (parameter_value (1, parameter_length), control_block.maximum_file_size,
                  status);
          = nfc$transfer_id =
            ;
          = nfc$facilities =
            nfp$receive_parameter_03 (received_command, parameter_value (1, parameter_length),
                  parameter_qualifier, control_block.transfer_facilities, control_block.required_facilities,
                  control_block.allowed_facilities, parameter_modified, control_block.transfer_facilities,
                  control_block.network_buffer_list, status);
          = nfc$state_of_transfer =
            nfp$receive_parameter_04 (received_command, parameter_value (1, parameter_length),
                  parameter_qualifier, control_block.state_of_transfer, control_block.state_of_transfer,
                  status);
          = nfc$user_text_directive =
            nfp$receive_parameter_05 (received_command, parameter_value (1, parameter_length),
                  parameter_qualifier, control_block.received_directives, status);
          = nfc$file_length =
            nfp$receive_parameter_06 (parameter_value (1, parameter_length), control_block.file_size, status);
          = nfc$operator_message =
            nfp$receive_parameter_07 (received_command, parameter_value (1, parameter_length),
                  parameter_qualifier, control_block.received_operator_messages, status);
          = nfc$user_message =
            nfp$receive_parameter_08 (received_command, parameter_value (1, parameter_length),
                  parameter_qualifier, control_block.received_user_messages, status);
          = nfc$account_message =
            nfp$receive_parameter_09 (received_command, parameter_value (1, parameter_length),
                  parameter_qualifier, control_block.received_account_messages, status);
          = nfc$error_log_message =
            nfp$receive_parameter_10 (received_command, parameter_value (1, parameter_length),
                  parameter_qualifier, control_block.received_errorlog_messages, status);
          = nfc$special_options =
            nfp$receive_parameter_11 (parameter_value (1, parameter_length), parameter_qualifier,
                  control_block.receive_special_options, status);
          = nfc$max_block_size =
            nfp$receive_parameter_12 (parameter_value (1, parameter_length), parameter_qualifier,
                  control_block.data_declaration, control_block.data_block_size, status);
          = nfc$accounting_limit =
            nfp$receive_parameter_13( parameter_value(1,parameter_length),
                  parameter_qualifier, received_command, control_block.accounting_limit, status);
          = nfc$file_name =
            nfp$receive_parameter_16 (parameter_value (1, parameter_length), control_block.receive_file_name,
                  status);
          = nfc$file_disposition =
            nfp$receive_parameter_17(parameter_value(1,parameter_length), received_command,
                  parameter_qualifier, control_block.disposition_code, status);
          = nfc$acknowledgment_window =
            nfp$receive_parameter_18(parameter_value(1,parameter_length), parameter_qualifier,
                  control_block.acknowledgment_window, status);
          = nfc$initial_checkmark =
            nfp$receive_parameter_19(parameter_value(1,parameter_length), parameter_qualifier,
                  control_block.initial_restart_checkmark, status);
          = nfc$minimum_timeout_interval =
            nfp$receive_parameter_20 (parameter_value (1, parameter_length), parameter_qualifier,
                  control_block.path, control_block.time_out, status);
          = nfc$mode_of_access =
            nfp$receive_parameter_21 (parameter_value (1, parameter_length), parameter_qualifier,
                  control_block.mode_of_access, control_block.mode_of_access_option, status);
          = nfc$host_type =
            nfp$receive_parameter_22 (parameter_value (1, parameter_length), parameter_qualifier,
                  control_block.remote_host_type, status);
          = nfc$transfer_phase_attribute =
            ;
          = nfc$source_lid =
            nfp$receive_parameter_24 (parameter_value (1, parameter_length), parameter_qualifier,
                  control_block.source_lid, status);
          = nfc$transfer_lid =
            nfp$receive_parameter_25 (received_command, parameter_value (1, parameter_length),
                  parameter_qualifier, control_block.remote_lid, control_block.remote_lid_length, status);
          = nfc$job_name =
            nfp$receive_parameter_26 (received_command, control_block.protocol_in_use,
                  parameter_value (1, parameter_length), parameter_qualifier, protocol_negotiation,
                  control_block.receive_job_name, status);
          = nfc$physical_id =
            nfp$receive_parameter_27 (received_command, parameter_value (1, parameter_length),
                  parameter_qualifier, control_block.remote_pid, control_block.remote_pid_length, status);
          = nfc$destination_host_type =
            nfp$receive_parameter_28 (parameter_value (1, parameter_length), parameter_qualifier,
                  control_block.requested_host_type, status);
          = nfc$echo =
            nfp$receive_parameter_29(parameter_value(1,parameter_length), control_block.received_echo_text);
          = nfc$attribute_continued =
            more_command_blocks := TRUE;
          = nfc$data_declaration =
            nfp$receive_parameter_31 (control_block.application, parameter_value (1, parameter_length),
                   parameter_qualifier, control_block.data_declaration, status);
          = nfc$system_routing_text =
            nfp$receive_parameter_32 (parameter_value (1, parameter_length), parameter_qualifier,
                  control_block.receive_systems_routing_text, status);
          = nfc$implicit_routing_text =
            nfp$receive_parameter_33 (parameter_value(1, parameter_length), parameter_qualifier,
                  control_block.receive_implicit_routing_text, status );
          = nfc$user_file_name =
            nfp$receive_parameter_51 (control_block.protocol_in_use, received_command,
                  parameter_value (1, parameter_length), parameter_qualifier,
                  control_block.network_buffer_list, control_block.user_file_name, status);
          = nfc$banner_date_and_time =
            nfp$receive_parameter_52 (control_block.protocol_in_use, received_command,
                  parameter_value (1, parameter_length), parameter_qualifier,
                  control_block.network_buffer_list, control_block.banner_date_and_time, status);
          = nfc$banner_routing_text =
            nfp$receive_parameter_53 (control_block.protocol_in_use, received_command,
                  parameter_value (1, parameter_length), parameter_qualifier,
                  control_block.network_buffer_list, control_block.banner_routing_text, status);
          = nfc$user_banner_text =
            nfp$receive_parameter_54 (control_block.protocol_in_use, received_command,
                  parameter_value (1, parameter_length), parameter_qualifier,
                  control_block.network_buffer_list, control_block.user_banner_message, status);
          = nfc$installation_banner_text =
            nfp$receive_parameter_55 (control_block.protocol_in_use, received_command,
                  parameter_value (1, parameter_length), parameter_qualifier,
                  control_block.network_buffer_list, control_block.installation_banner_message, status);
          = nfc$reposition_output_params =
            nfp$receive_parameter_56 (control_block.protocol_in_use, received_command,
                  parameter_value (1, parameter_length), parameter_qualifier,
                  control_block.reposition_output_file, status);
          = nfc$current_file_position =
            nfp$receive_parameter_57 (control_block.protocol_in_use, received_command,
                  parameter_value (1, parameter_length), parameter_qualifier,
                  control_block.current_file_position, status);
          = nfc$output_file_destination =
            nfp$receive_parameter_58 (control_block.protocol_in_use, received_command,
                  parameter_value (1, parameter_length), parameter_qualifier,
                  control_block.default_output_file_destination, status);
          = nfc$vertical_print_density =
            nfp$receive_parameter_59(parameter_value(1,parameter_length),
                  parameter_qualifier, control_block.vertical_print_density, status);
          = nfc$vfu_load_procedure =
            nfp$receive_parameter_60(parameter_value(1,parameter_length),
                  parameter_qualifier, control_block.vfu_load_procedure, status);
          = nfc$reserved_for_site_90 =
            ;
          = nfc$reserved_for_site_91 =
            ;
          = nfc$reserved_for_site_92 =
            ;
          = nfc$reserved_for_site_93 =
            ;
          = nfc$reserved_for_site_94 =
            ;
          = nfc$reserved_for_site_95 =
            ;
          = nfc$reserved_for_site_96 =
            ;
          = nfc$reserved_for_site_97 =
            ;
          = nfc$reserved_for_site_98 =
            ;
          = nfc$reserved_for_site_99 =
            ;
          ELSE
            nfp$set_internal_error ('nfp$crack_pdu, main loop', status);
            RETURN;
          CASEND;
          IF NOT status.normal THEN
            nfp$format_message_to_job_log (status);
            nfp$set_abnormal_if_normal (status,procedure_status);
          IFEND;
        IFEND;
      IFEND;
      buffer_position := buffer_position + parameter_length + nfc$param_header_size;
      IF parameter_modified THEN
        modified_params := modified_params + $nft$parameter_set [parameter_identifier];
      IFEND;
    FOREND;
    IF NOT procedure_status.normal THEN
      status := procedure_status;
    IFEND;

  PROCEND nfp$crack_pdu;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_00', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_00
    (    protocol: nft$parameter_00_values;
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$send_protocol_parameter_00                                   }
{                                                                             }
{ Purpose    To send protocol parameter 00, the protocol identifier.          }
{                                                                             }
{ Description                                                                 }
{            This routine converts the protocol ID ordinal into a string      }
{            and puts it in the command buffer.                               }
{                                                                             }
{ Input parameters                                                            }
{            Protocol             : A-A protocol version                      }
{            Qualifier            : A-A protocol parameter qualifier          }
{            Buffer_list          : List of network buffers                   }
{                                                                             }
{ Output parameters                                                           }
{            Status               : Value returned by:                        }
{                                     nfp$specify_pdu_parameter               }
{                                                                             }
{ Algorithm                                                                   }
{            Convert protocol id ordinal to string                            }
{            nfp$specify_pdu_parameter(string)                                }
{                                                                             }
?? EJECT ??

    VAR
      nfv$p00_values: [XREF] nft$p00_values;

    {}
    status.normal := TRUE;
    nfp$specify_pdu_parameter (nfc$protocol_id, qualifier, nfv$p00_values [protocol].
          value (1, nfv$p00_values [protocol].length), buffer_list, status);
    {}
  PROCEND nfp$send_protocol_parameter_00;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_01', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_01
    (    file_size: nft$parameter_01_values;
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    VAR
      parameter_value: string (nfc$p01_max_size);

    {
    { Procedure nfp$send_protocol_parameter_01
    {
    { Purpose   Send parameter 01, maximum file transfer size.
    {
    { Description
    {           Parameter 01 may be specified by the sender or the receiver
    {           to inform the remote application what is the maximum size
    {           it can send or receive.  Note:  NOS/VE does not send
    {           the parameter at present.
    {
    { Input parameters
    {           File_size            : Maximum file size in kilobytes
    {           Qualifier            : A-A protocol parameter qualifier
    {           Buffer_list          : List of current network buffers
    {
    { Output parameters
    {           Buffer_list          : List of current network buffers
    {           Status               : Can be any returned by:
    {                                  Clp$convert_integer_to_rjstring - or -
    {                                  nfp$specify_pdu_parameter
    {
    { Algorithm  Convert file size to a string value.
    {            Nfp$specify_pdu_parameter( string )
    {
?? EJECT ??
    {}
    status.normal := TRUE;
    clp$convert_integer_to_rjstring (file_size, nfc$p01_radix, nfc$p01_include_radix, nfc$p01_fill_char,
          parameter_value, status);
    IF status.normal THEN
      nfp$specify_pdu_parameter (nfc$maximum_file_length, qualifier, parameter_value, buffer_list, status);
    IFEND;
    {}
  PROCEND nfp$send_protocol_parameter_01;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_03', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_03
    (    qualifier: nft$parameter_qualifiers;
         send_p03: nft$parameter_03_value_set;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$send_protocol_parameter_03                                   }
{                                                                             }
{ Purpose    To send protocol parameter 03, facilities.                       }
{                                                                             }
{ Description                                                                 }
{            This routine takes a set of facilities which it specifies        }
{            for the remote host.  If the facilities set is empty, this       }
{            parameter is not specified.                                      }
{                                                                             }
{ Input parameters                                                            }
{            Qualifier            : A-A protocol parameter qualifer           }
{                                                                             }
{ Output parameters                                                           }
{            Send_p03             : Value specified                           }
{            Buffer_list          : List of current network buffers           }
{            Status               : Value returned by                         }
{                                     nfp$specify_pdu_parameter               }
{                                                                             }
{ Algorithm                                                                   }
{            Convert facility set to a string                                 }
{            Nfp$specify_pdu_parameter( facility_string )                     }
{                                                                             }
?? EJECT ??

    VAR
      nfv$p03_values: [XREF] nft$parameter_03_elements;

    VAR
      parameter_value: string (nfc$p03_max_size),
      parameter_length: nft$parameter_size,
      index: nft$facility_types;

    {}
    { Build the string }
    {}
    status.normal := TRUE;
    parameter_length := 0;
    FOR index := LOWERVALUE (nft$facility_types) TO UPPERVALUE (nft$facility_types) DO
      IF index IN send_p03 THEN
        parameter_length := parameter_length + 1;
        parameter_value (parameter_length, nfc$p03_element_size) := nfv$p03_values [index];
      IFEND;
    FOREND;
    {}
    { If the string has non-zero length, send it }
    {}
    IF parameter_length > 0 THEN
      nfp$specify_pdu_parameter (nfc$facilities, qualifier, parameter_value (1, parameter_length),
            buffer_list, status);
    IFEND;
    {}
  PROCEND nfp$send_protocol_parameter_03;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_04', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_04
    (    state: ost$status;
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_protocol_parameter_04
    {
    { Purpose    Send parameter 04, state of transfer.
    {
    { Description
    {            The internal state of transfer is translated into the
    {            string A-A value.  This value is then placed in the next
    {            outgoing PDU by calling nfp$specify_pdu_parameter.
    {
    { Input parameters
    {            State         : Status variable
    {            Qualifier     : A-A protocol parameter qualifier
    {            Buffer_list   : List of current network buffers
    {
    { Output parameters
    {            Status        : Return status =
    {                              Any returned by nfp$specify_pdu_parameter.
    { Algorithm
    {            Loop through known State Codes
    {              If code matches internal status  then
    {                exit loop
    {              Ifend
    {            Loopend
    {            If known, nfp$specify_pdu_parameter
    {
?? EJECT ??
    {}

    VAR
      found_it: boolean,
      index: 1 .. nfc$p04_max_transfer_states,
      nfv$p04_values: [XREF] nft$parameter_04_values,
      parameter_value: string (nfc$p04_max_param_len);

    {}
    status.normal := TRUE;
    IF state.normal THEN
      parameter_value := nfv$p04_values [1].code;
    ELSE
      found_it := FALSE;

    /forloop/
      FOR index := LOWERVALUE (index) TO UPPERVALUE (index) DO

        IF (state.normal = nfv$p04_values [index].normal) AND
              (state.condition = nfv$p04_values [index].condition) THEN
          found_it := TRUE;
          EXIT /forloop/;
        IFEND;
      FOREND /forloop/;
      IF found_it THEN
        parameter_value := nfv$p04_values [index].code;
      ELSE
        nfp$set_internal_error ('nfp$send_protocol_parameter_04', status);
        RETURN;
      IFEND;
    IFEND;
    {}
    nfp$specify_pdu_parameter (nfc$state_of_transfer, qualifier, parameter_value, buffer_list, status);
    {}
  PROCEND nfp$send_protocol_parameter_04;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_05', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_05
    (    directive_list: ^nft$directive_entry;
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$send_protocol_parameter_05                                   }
{                                                                             }
{ Purpose    Send parameter 05, user text directives.                         }
{                                                                             }
{ Description                                                                 }
{            Initiator applications (i.e. ptfi,qtfi) must/may send text       }
{            to the remote servicer for processing.  A list of text is        }
{            passed to this module, and each list element is specified        }
{            as a separate parameter on the next out going pdu(s).            }
{                                                                             }
{ Input parameters                                                            }
{            Directive_list: Linked list of directives                        }
{            Qualifier     : A-A protocol parameter qualifier                 }
{            Buffer_list   : List of current network buffers                  }
{                                                                             }
{ Output parameters                                                           }
{            Status        : Return status =                                  }
{                                 Any returned by nfp$specify_pdu_parameter   }
{                                                                             }
{ Algorithm                                                                   }
{            While more directives do
{
{              Nfp$specify_pdu_parameter                                      }
{                If error, return                                             }
{            Whilend                                                          }
{                                                                             }
?? EJECT ??
{}

    VAR
      directive_pointer: ^nft$directive_entry;

{}
    status.normal := TRUE;
    directive_pointer := directive_list;
    WHILE directive_pointer <> NIL DO
      nfp$specify_pdu_parameter (nfc$user_text_directive, qualifier, directive_pointer^.line, buffer_list,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      directive_pointer := directive_pointer^.link;
    WHILEND;
{}
  PROCEND nfp$send_protocol_parameter_05;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$enqueue_directive_on_list', EJECT ??

  PROCEDURE [XDCL] nfp$enqueue_directive_on_list
    (    directive_value: string ( * <= nfc$max_param_size);
     VAR directive_list: nft$directive_entry_list_head;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$enqueue_directive_on_list                                    }
{                                                                             }
{ Purpose    To enqueue a string onto a directive list.                       }
{                                                                             }
{ Description                                                                 }
{            This routine allocates a directive entry for the input string,   }
{            then enqueues the directive entry on the specified list.         }
{                                                                             }
{ Input parameters                                                            }
{            Directive_value             : Input string                       }
{                                                                             }
{ Output parameters                                                           }
{            Directive_list              : List of directives + new one       }
{            Status                      : Return status                      }
{                                                                             }
{ Algorithm                                                                   }
{            Allocate directive entry                                         }
{            Copy input string into directive entry                           }
{            Enqueue directive entry                                          }
{                                                                             }
?? EJECT ??

    VAR
      check_entry: ^nft$directive_entry,
      current_entry: ^nft$directive_entry;

{}
    status.normal := TRUE;
    ALLOCATE current_entry: [#SIZE (directive_value)];
    IF current_entry = NIL THEN
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
            'nfp$enqueue_directive_on_list no space', status);
      RETURN;
    IFEND;
    current_entry^.line := directive_value;
    current_entry^.link := NIL;
    IF directive_list.head = NIL THEN
      directive_list.head := current_entry;
    ELSE
      check_entry := directive_list.head;
      WHILE check_entry^.link <> NIL DO
        check_entry := check_entry^.link;
      WHILEND;
      check_entry^.link := current_entry;
    IFEND;
    directive_list.tail := current_entry;
{}
  PROCEND nfp$enqueue_directive_on_list;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$enqueue_status_directive', EJECT ??

  PROCEDURE [XDCL] nfp$enqueue_status_directive
    (    send_status: ost$status;
     VAR directive_list: nft$directive_entry_list_head;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$enqueue_status_directive                                     }
{                                                                             }
{ Purpose    To convert a VE status message to a string and place that        }
{            string on a directive list.                                      }
{                                                                             }
{ Description                                                                 }
{            This routine converts the status into one or more messages       }
{            and places each message on the specified directive list.         }
{                                                                             }
{ Input parameters                                                            }
{            Send_status          : Input status                              }
{                                                                             }
{ Output parameters                                                           }
{            Directive_list       : List of directives + new ones             }
{            Status               : Return status                             }
{                                                                             }
{ Algorithm                                                                   }
{            osp$format_message                                               }
{            For index = 1 to number of lines                                 }
{              nfp$enqueue_directive_on_list line(index)                      }
{            Forend                                                           }
{                                                                             }
?? EJECT ??

    VAR
      index: 1 .. osc$max_status_message_lines,
      message: ost$status_message,
      msg_line_count: ^ost$status_message_line_count,
      msg_line_size: ^ost$status_message_line_size,
      msg_line_text: ^string ( * ),
      pointer: ^ost$status_message;

{}
    status.normal := TRUE;
    osp$format_message (send_status, osc$full_message_level, nfc$trace_commands_width, message, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pointer := ^message;
    RESET pointer;
    NEXT msg_line_count IN pointer;
    FOR index := 1 TO msg_line_count^ DO
      NEXT msg_line_size IN pointer;
      NEXT msg_line_text: [msg_line_size^] IN pointer;
      nfp$enqueue_directive_on_list (msg_line_text^, directive_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;
  PROCEND nfp$enqueue_status_directive;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$dequeue_directives_on_list', EJECT ??

  PROCEDURE [XDCL] nfp$dequeue_directives_on_list
    (VAR directive_head: ^nft$directive_entry;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$dequeue_directives_on_list                                   }
{                                                                             }
{ Purpose    To deallocate all directives on a directive list.                }
{            WARNING: directives must have been ALLOCATED onto list           }
{            using nfp$enqueue_directive_on_list or                           }
{            nfp$enqueue_status_directive.  Applications PUSHING directive    }
{            lists must NOT use this routine.                                 }
{                                                                             }
{ Description                                                                 }
{            Each directive on the list is dequeued and deallocated.  The     }
{            list header is returned NIL.  Any failure to deallocate space    }
{            will result in the local condition handler returning an error    }
{            to the caller (the application will not blow up!).               }
{                                                                             }
{ Input parameters                                                            }
{            None                                                             }
{                                                                             }
{ Output parameters                                                           }
{            Directive_head       : Head of directive list                    }
{            Status               : Returned status                           }
{                                                                             }
{ Algorithm                                                                   }
{            While directives on list DO                                      }
{              Dequeue directive                                              }
{              Deallocate directive                                           }
{            Whilend                                                          }
{            Directive header = NIL                                           }
{                                                                             }
?? EJECT ??

    PROCEDURE nfp$dequeue_directives_handler
      (    condition: pmt$condition;
           condition_desc: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR trap_status: ost$status);

{}

      VAR
        local_status: ost$status;

{}
      osp$set_status_from_condition (nfc$status_id, condition, save_area, status, local_status);
      IF NOT local_status.normal THEN
        status := local_status;
      IFEND;
      trap_status.normal := TRUE;
      EXIT nfp$dequeue_directives_on_list;
{}
    PROCEND nfp$dequeue_directives_handler;

    VAR
      condition_descriptor: pmt$established_handler,
      current_entry: ^nft$directive_entry,
      free_ptr: ^nft$directive_entry,
      handler_conditions: pmt$condition,
      ignore_status: ost$status;

{}
    status.normal := TRUE;
    current_entry := directive_head;
    handler_conditions.selector := pmc$condition_combination;
    handler_conditions.combination := $pmt$condition_combination [mmc$segment_access_condition];
    pmp$establish_condition_handler (handler_conditions, ^nfp$dequeue_directives_handler,
          ^condition_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    WHILE current_entry <> NIL DO
      free_ptr := current_entry;
      current_entry := current_entry^.link;
      FREE free_ptr;
    WHILEND;
    directive_head := NIL;
    pmp$disestablish_cond_handler (handler_conditions, ignore_status);
{}
  PROCEND nfp$dequeue_directives_on_list;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$deallocate_dirs_from_head', EJECT ??

  PROCEDURE [XDCL] nfp$deallocate_dirs_from_head
    (VAR directive_head: nft$directive_entry_list_head;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$deallocate_dirs_from_head                                    }
{                                                                             }
{ Purpose    To dequeue and deallocate directives from a list head of type    }
{            nft$directive_entry_list_head.                                   }
{                                                                             }
{ Description                                                                 }
{            This routine simply calls nfp$dequeue_directives_on_list and     }
{            sets the tail of the list to NIL.                                }
{                                                                             }
{ Input parameters                                                            }
{            None                                                             }
{                                                                             }
{ Output parameters                                                           }
{            Directive_head       : List head of directive list               }
{            Status               : Return status                             }
{                                                                             }
{ Algorithm                                                                   }
{            Call nfp$dequeue_directives_on_list to deallocate list           }
{            If o.k., set tail to NIL.                                        }
{                                                                             }
?? EJECT ??
    status.normal := TRUE;
    nfp$dequeue_directives_on_list (directive_head.head, status);
    IF status.normal THEN
      directive_head.tail := NIL;
    IFEND;
{}
  PROCEND nfp$deallocate_dirs_from_head;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_06', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_06
    (    file_size: nft$parameter_06_values;
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

{                                                                             }
{ Procedure nfp$send_protocol_parameter_06
{           }
{                                                                             }
{ Purpose   To send parameter 06, size of file to be transferred.             }
{                                                                             }
{ Description                                                                 }
{            The size of the file being transferred in converted into         }
{            kilobytes.  NOTE:  Since VE does not do file preallocation,      }
{            this parameter is only usefull when talking to non-VE            }
{            systems.                                                         }
{                                                                             }
{ Input parameters                                                            }
{            File_size     : Length of file in bytes                          }
{            Qualifier     : A-A protocol parameter qualifier                 }
{                                                                             }
{ Output parameters                                                           }
{            Buffer_list   : List of current network buffers                  }
{            Status        : Any returned by                                  }
{                                 Clp$convert_integer_to_rjstring             }
{                                 Nfp$specify_pdu_parameter                   }
{                                                                             }
{ Algorithm                                                                   }
{            Convert size to string                                           }
{            Nfp$specify_pdu_parameter(string)                                }
{                                                                             }
?? EJECT ??
{}

    VAR
      converted_file_size: nfc$p06_min_value..nfc$p06_max_value,
      parameter_value: string (nfc$p06_max_param_len);

{}
    status.normal := TRUE;

    converted_file_size := (file_size DIV nfc$p06_unit) + 1;
    IF converted_file_size > nfc$p06_max_value THEN
      converted_file_size := nfc$p06_max_value;
    IFEND;
    clp$convert_integer_to_rjstring (converted_file_size, nfc$p06_radix, nfc$p06_include_radix,
          nfc$p06_fill_char, parameter_value, status);
    IF status.normal THEN
      nfp$specify_pdu_parameter (nfc$file_length, qualifier, parameter_value, buffer_list, status);
    IFEND;
{}
  PROCEND nfp$send_protocol_parameter_06;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_07', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_07
    (    message_list: ^nft$directive_entry;
         qualifier: nft$parameter_qualifiers;
         maximum_message_length: nft$parameter_size;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

{                                                                             }
{ Procedure nfp$send_protocol_parameter_07
{
{                                                                             }
{ Purpose   To send parameter 07, operator system message.                    }
{                                                                             }
{ Description                                                                 }
{            This routine takes a list of strings and sends them as protocol  }
{            parameters.  If necessary, the individual strings are            }
{            "chopped" into pieces to fit in the protocol.                    }
{                                                                             }
{ Input parameters                                                            }
{            message_list         : Linked list of message strings            }
{            qualifier            : A-A protocol parameter qualifier          }
{            maximum_message_length: Max size of protocol parameter           }
{                                                                             }
{ Output parameters                                                           }
{            buffer_list          : List of protocol command buffers          }
{            status               : Return status                             }
{                                                                             }
{ Algorithm                                                                   }
{            While directives left do                                         }
{              Chop directive if neccessary                                   }
{              Nfp$specify_chopped pieces                                     }
{            Whilend                                                          }
{                                                                             }
?? EJECT ??

    VAR
      current_entry: ^nft$directive_entry,
      message_length: integer,
      message_index: integer;

{}
    status.normal := TRUE;
    current_entry := message_list;
    WHILE current_entry <> NIL DO
      message_length := STRLENGTH (current_entry^.line);
      message_index := 1;

    /send_07_loop/
      WHILE message_index <= message_length DO
        IF (message_length - message_index + 1) > maximum_message_length THEN
          nfp$specify_pdu_parameter (nfc$operator_message, qualifier, current_entry^.
                line (message_index, maximum_message_length), buffer_list, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          message_index := message_index + maximum_message_length;
        ELSE
          nfp$specify_pdu_parameter (nfc$operator_message, qualifier, current_entry^.line (message_index, * ),
                buffer_list, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          EXIT /send_07_loop/;
        IFEND;
      WHILEND /send_07_loop/;
      current_entry := current_entry^.link;
    WHILEND;
{}
  PROCEND nfp$send_protocol_parameter_07;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_08', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_08
    (    protocol: nft$parameter_00_values;
         message_list: ^nft$directive_entry;
         qualifier: nft$parameter_qualifiers;
         maximum_message_length: nft$parameter_size;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

{                                                                             }
{ Procedure nfp$send_protocol_parameter_08
{                                                                             }
{ Purpose   To send parameter 08, user message.                               }
{                                                                             }
{ Description                                                                 }
{            This routine takes a list of strings and sends them as protocol  }
{            parameters.  If necessary, the individual strings are            }
{            "chopped" into pieces to fit in the protocol.                    }
{                                                                             }
{ Input parameters                                                            }
{            message_list         : Linked list of message strings            }
{            qualifier            : A-A protocol parameter qualifier          }
{            maximum_message_length: Max size of protocol parameter           }
{                                                                             }
{ Output parameters                                                           }
{            buffer_list          : List of protocol command buffers          }
{            status               : Return status                             }
{                                                                             }
{ Algorithm                                                                   }
{            While directives left do                                         }
{              Chop directive if neccessary                                   }
{              Nfp$specify_chopped pieces                                     }
{            Whilend                                                          }
{                                                                             }
?? EJECT ??

    VAR
      current_entry: ^nft$directive_entry,
      message_length: integer,
      message_index: integer;

{}
    status.normal := TRUE;
    current_entry := message_list;
    WHILE current_entry <> NIL DO
      message_length := STRLENGTH (current_entry^.line);
      message_index := 1;

    /send_08_loop/
      WHILE message_index <= message_length DO
        IF (message_length - message_index + 1) > maximum_message_length THEN
          nfp$specify_pdu_parameter (nfc$user_message, qualifier, current_entry^.
                line (message_index, maximum_message_length), buffer_list, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          message_index := message_index + maximum_message_length;
        ELSE
          nfp$specify_pdu_parameter (nfc$user_message, qualifier, current_entry^.line (message_index, * ),
                buffer_list, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          EXIT /send_08_loop/;
        IFEND;
      WHILEND /send_08_loop/;
      current_entry := current_entry^.link;
    WHILEND;
{}
  PROCEND nfp$send_protocol_parameter_08;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_09', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_09
    (    protocol: nft$parameter_00_values;
         message_list: ^nft$directive_entry;
         qualifier: nft$parameter_qualifiers;
         maximum_message_length: nft$parameter_size;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure nfp$send_protocol_parameter_09
    {
    { Purpose   To send parameter 09, account message.
    {
    { Description
    {            This routine takes a list of strings and sends them as protocol  }
    {            parameters.  If necessary, the individual strings are            }
    {            "chopped" into pieces to fit in the protocol.                    }
    {                                                                             }
    { Input parameters
    {            message_list         : Linked list of message strings            }
    {            qualifier            : A-A protocol parameter qualifier          }
    {            maximum_message_length: Max size of protocol parameter           }
    {
    { Output parameters
    {            buffer_list          : List of protocol command buffers          }
    {            status               : Return status                             }
    {
    { Algorithm
    {            While directives left do
    {              Chop directive if neccessary
    {              Nfp$specify_chopped pieces
    {            Whilend
    {
?? EJECT ??

    VAR
      current_entry: ^nft$directive_entry,
      message_length: integer,
      message_index: integer;

{}
    status.normal := TRUE;
    current_entry := message_list;
    WHILE current_entry <> NIL DO
      message_length := STRLENGTH (current_entry^.line);
      message_index := 1;

    /send_09_loop/
      WHILE message_index <= message_length DO
        IF (message_length - message_index + 1) > maximum_message_length THEN
          nfp$specify_pdu_parameter (nfc$account_message, qualifier, current_entry^.
                line (message_index, maximum_message_length), buffer_list, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          message_index := message_index + maximum_message_length;
        ELSE
          nfp$specify_pdu_parameter (nfc$account_message, qualifier, current_entry^.line (message_index, * ),
                buffer_list, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          EXIT /send_09_loop/;
        IFEND;
      WHILEND /send_09_loop/;
      current_entry := current_entry^.link;
    WHILEND;
    {}
  PROCEND nfp$send_protocol_parameter_09;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_10', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_10
    (    protocol: nft$parameter_00_values;
         message_list: ^nft$directive_entry;
         qualifier: nft$parameter_qualifiers;
         maximum_message_length: nft$parameter_size;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure nfp$send_protocol_parameter_10
    {
    { Purpose   To send parameter 10, account message.
    {
    { Description
    {            This routine takes a list of strings and sends them as protocol  }
    {            parameters.  If necessary, the individual strings are            }
    {            "chopped" into pieces to fit in the protocol.                    }
    {                                                                             }
    { Input parameters
    {            message_list         : Linked list of message strings            }
    {            qualifier            : A-A protocol parameter qualifier          }
    {            maximum_message_length: Max size of protocol parameter           }
    {
    { Output parameters
    {            buffer_list          : List of protocol command buffers          }
    {            status               : Return status                             }
    {
    { Algorithm
    {            While directives left do
    {              Chop directive if neccessary
    {              Nfp$specify_chopped pieces
    {            Whilend
    {
?? EJECT ??

    VAR
      current_entry: ^nft$directive_entry,
      message_length: integer,
      message_index: integer;

{}
    status.normal := TRUE;
    current_entry := message_list;
    WHILE current_entry <> NIL DO
      message_length := STRLENGTH (current_entry^.line);
      message_index := 1;

    /send_10_loop/
      WHILE message_index <= message_length DO
        IF (message_length - message_index + 1) > maximum_message_length THEN
          nfp$specify_pdu_parameter (nfc$error_log_message, qualifier, current_entry^.
                line (message_index, maximum_message_length), buffer_list, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          message_index := message_index + maximum_message_length;
        ELSE
          nfp$specify_pdu_parameter (nfc$error_log_message, qualifier, current_entry^.
                line (message_index, * ), buffer_list, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          EXIT /send_10_loop/;
        IFEND;
      WHILEND /send_10_loop/;
      current_entry := current_entry^.link;
    WHILEND;
    {}
  PROCEND nfp$send_protocol_parameter_10;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_11', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_11
    (    remote_type: nft$parameter_22_values;
         special_options: nft$parameter_11_value;
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_protocol_parameter_11
    {
    { Purpose    To send protocol parameter 11, special options.
    {            The special options parameter is used in VE <-> VE
    {            transfers to pass NOS/VE status.
    {
    { Description
    {            The status variable is converted to a string and passed
    {            in a pdu.
    {
    { Input parameters
    {            Remote_type   : Remote host type (i.e. IBM)
    {            Special_options: The parameter string to send
    {            Qualifier     : A-A protocol parameter qualifier
    {
    { Output parameters
    {            Buffer_list   : List of current network buffers
    {            Status        : Any value returned by
    {                                 Clp$convert_integer_to_rjstring
    {                                 Nfp$specify_pdu_parameter
    {
    { Algorithm
    {            Nfp$specify_pdu_parameter
    {
?? EJECT ??
{}

{}
    status.normal := TRUE;
    nfp$specify_pdu_parameter (nfc$special_options, qualifier, special_options.
            value (1, special_options.size), buffer_list, status);
{}
  PROCEND nfp$send_protocol_parameter_11;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_12', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_12
    (    protocol_id: nft$parameter_00_values;
         block_size: nft$parameter_12_range;
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_protocol_parameter_12
    {
    { Purpose    To add protocol parameter 12, data block size, to the next
    {            send PDU.
    {
    { Description
    {            The block size is changed from nft$parameter_12_range to a
    {            string by Clp$convert_integer_to_rjstring.  The resulting
    {            string is then placed in the PDU by calling
    {            nfp$specify_pdu_parameter.
    {
    { Input parameters
    {               protocol_id:  A-A protocol version ordinal
    {               block_size:   Application requested block size
    {               qualifier:    A-A protocol parameter qualifier
    {
    { Output parameters
    {            buffer_list: List of current network buffers
    {            Status : normal or a result of:
    {                          clp$convert_integer_to_rjstring -or-
    {                          nfp$specify_pdu_parameter
    {
    { Algorithm
    {            Convert size to string
    {            Enter string in PDU
    {}
?? EJECT ??
    {}

    VAR
      parameter: ^string ( * );

    {}
    status.normal := TRUE;
    CASE protocol_id OF
    = nfc$p00_a102 =
      PUSH parameter: [nfc$p12_max_size_a102];
    = nfc$p00_a101 =
      PUSH parameter: [nfc$p12_max_size_a101];
    = nfc$p00_b101 =
      PUSH parameter: [nfc$p12_max_size_b101];
    ELSE
      nfp$set_internal_error ('nfp$send_protocol_parameter_12 Protid case', status);
      pmp$exit (status);
    CASEND;
    clp$convert_integer_to_rjstring (block_size, nfc$p12_radix, nfc$p12_include_radix, nfc$p12_fill_char,
          parameter^, status);
    IF status.normal THEN
      nfp$specify_pdu_parameter (nfc$max_block_size, qualifier, parameter^, buffer_list, status);
    IFEND;
    {}
  PROCEND nfp$send_protocol_parameter_12;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_13', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_13
    (    accounting_limit: nft$parameter_13_definition;
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);
{
{ Procedure  nfp$send_protocol_parameter_13
{
{ Purpose    This routine sends parameter 13, accounting limit
{
{ Description
{            The accounting limit is converted from an integer
{            to a string and placed in a PDU.
{
{ Input parameters
{            accounting_limit:    value of accounting limit
{            qualifier:           protocol parameter qualifier
{
{ Output parameters
{            buffer_list:         list of network buffers
{            status:              return status
{
{ Algorithm
{            clp$convert_integer_to_string
{            If ok nfp$specify_pdu_parameter
{
VAR
      output_string: ost$string;
{}
  status.normal := TRUE;
  clp$convert_integer_to_string( accounting_limit,
      nfc$p13_radix, nfc$p13_include_radix, output_string,
      status);
  IF status.normal THEN
    nfp$specify_pdu_parameter( nfc$accounting_limit, qualifier,
      output_string.value(1,output_string.size), buffer_list,
      status);
  IFEND;
{}
  PROCEND nfp$send_protocol_parameter_13;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_16', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_16
    (    file_name: string ( * <= nfc$p16_max_param_length);
         protocol: nft$parameter_00_values;
         qualifier: nft$parameter_qualifiers;
         maximum_parameter_length: nft$parameter_size;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

{
{ Procedure  nfp$send_protocol_parameter_16
{
{ Purpose    To send parameter 16, file name IO queue.
{            This parameter is used to exchange file-name/job-name
{            information between applications.
{
{ Description
{            The calling application must format P16 into a string
{            of correct length.
{
{ Input parameters
{            File_name     : Value to be sent
{            Qualifier     : A-A protocol parameter qualifier
{
{ Output parameters
{            Buffer_list   : List of A-A buffers to be sent
{            Status        : Return status
{
{ Algorithm
{            nfp$specify_pdu_parameter
{
?? EJECT ??
    CONST
{ This parameter specifies the system name for the queue file. It has the  }
{ format of $DDDD_DDDD_AAA_DDDD where D indicates a digit and A indicates  }
{ a alphabet. Set byte offset equal 11 will skip the digits that are in    }
{ front of the first alphabet and pick AAADDDD as the file name.           }
{}
      byte_offset = 11;

    VAR
      index: nft$parameter_size,
      input_parameter_length: nft$parameter_size,
      parameter_length: nft$parameter_size,
      scratch_index: nft$parameter_size,
      scratch_string: ^string ( * );

{}
    status.normal := TRUE;
    input_parameter_length := STRLENGTH (file_name);
    CASE protocol OF

    = nfc$p00_a101 =
      PUSH scratch_string: [maximum_parameter_length];
      parameter_length := 0;
      scratch_index := 1;

    /a101_for_loop/
      FOR index := 1+byte_offset TO input_parameter_length DO
        IF (($INTEGER (file_name (index)) >= $INTEGER (nfc$p16_1st_range1_a101)) AND
              ($INTEGER (file_name (index)) <= $INTEGER (nfc$p16_last_range1_a101))) OR
              (($INTEGER (file_name (index)) >= $INTEGER (nfc$p16_1st_range2_a101)) AND
              ($INTEGER (file_name (index)) <= $INTEGER (nfc$p16_last_range2_a101))) OR
              ($INTEGER (file_name (index)) = $INTEGER (nfc$p16_special1_a101)) OR
              ($INTEGER (file_name (index)) = $INTEGER (nfc$p16_special2_a101)) THEN
          scratch_string^ (scratch_index) := file_name (index);
          scratch_index := scratch_index + 1;
          parameter_length := parameter_length + 1;
          IF parameter_length = maximum_parameter_length THEN
            EXIT /a101_for_loop/;
          IFEND;
        IFEND;
      FOREND /a101_for_loop/;
      IF parameter_length < 0 THEN
        nfp$set_internal_error ('nfp$send_protocol_parameter_16 pl', status);
        RETURN;
      IFEND;

    = nfc$p00_a102, nfc$p00_b101 =

      IF maximum_parameter_length < input_parameter_length THEN
        parameter_length := maximum_parameter_length;
      ELSE
        parameter_length := input_parameter_length;
      IFEND;
      scratch_string := ^file_name;
    ELSE
      nfp$set_internal_error ('nfp$send_protocol_parameter_16 Protid case', status);
      pmp$exit (status);
    CASEND;

    nfp$specify_pdu_parameter (nfc$file_name, qualifier, scratch_string^ (1, parameter_length), buffer_list,
          status);


{}
  PROCEND nfp$send_protocol_parameter_16;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_17', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_17
    (    disposition: nft$parameter_17_definition;
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_protocol_parameter_17
    {
    { Purpose    To send protocol parameter 17, disposition code.
    {
    { Description
    {           The disposition code ordinal is changed to a string and
    {           sent as parameter 17.
    {
    { Input parameters
    {               Disposition:         Disposition code ordinal
    {               Qualifier:           A-A protocol parameter qualifier
    {
    { Output parameters
    {                   Buffer_list:  List of protocol command buffers.
    {                   Status:       As returned by nfp$specify_pdu_parameter.
    {
    { Algorithm  Call to nfp$specify_pdu_parameter.
    {
?? EJECT ??

    VAR
      nfv$parameter_17_values: [XREF] nft$parameter_17_values;

    {}
    status.normal := TRUE;
    nfp$specify_pdu_parameter (nfc$file_disposition, qualifier, nfv$parameter_17_values [disposition],
          buffer_list, status);
    {}
  PROCEND nfp$send_protocol_parameter_17;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_18', EJECT ??
  PROCEDURE nfp$send_protocol_parameter_18
    (    acknowledgment_window: nft$parameter_18_definition;
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);
{
{ Procedure  nfp$send_protocol_parameter_18
{
{ Purpose    To send protocol parameter 18, acknowledgment window
{
{ Description
{            This routine converts the p18 ordinal value to a string.
{
{ Input parameters
{            Acknowledgment_window:      Input value
{            Qualifier:                  A-A protocol parameter qualifier
{
{ Output parameters
{            Buffer_list:                List of active A-A buffers
{            Status:                     Return status
{
{ Algorithm
{            convert value to string
{            nfp$specify_pdu_parameter
{
VAR
      output_string: string(nfc$p18_maximum_parameter_size);
{}
  clp$convert_integer_to_rjstring( acknowledgment_window, nfc$p18_radix,
      nfc$p18_include_radix, nfc$p18_fill_character, output_string, status);
  IF status.normal THEN
   nfp$specify_pdu_parameter( nfc$acknowledgment_window, qualifier,
      output_string, buffer_list, status);
  IFEND;
{}
  PROCEND nfp$send_protocol_parameter_18;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_19', EJECT ??
  PROCEDURE nfp$send_protocol_parameter_19
    (    initial_restart_checkmark: nft$parameter_19_definition;
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);
{
{ Procedure  nfp$send_protocol_parameter_19
{
{ Purpose    To send protocol parameter 19, initial restart
{            checkmark.
{
{ Description
{            This routine converts the input subrange to a
{            string.  The string is then encoded into the
{            current (or next network buffer).
{
{ Input parameters
{            Initial_restart_checkmark:  Input value
{            Qualifier:                  A-A protocol parameter qualifier
{
{ Output parameters
{            Buffer_list:                List of current network buffers
{            Status:                     Return status
{
{ Algorithm
{            Convert value to string
{            nfp$specify_pdu_parameter
{
VAR
      output_string: string(nfc$p19_maximum_parameter_size);
{}
  clp$convert_integer_to_rjstring( initial_restart_checkmark, nfc$p19_radix,
      nfc$p19_include_radix, nfc$p19_fill_character, output_string, status);
  IF status.normal THEN
   nfp$specify_pdu_parameter( nfc$initial_checkmark, qualifier,
      output_string, buffer_list, status);
  IFEND;
{}
  PROCEND nfp$send_protocol_parameter_19;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_20', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_20
    (    protocol: nft$parameter_00_values;
         timeout_value: nft$parameter_20_range;
         qualifier: nft$parameter_qualifiers;
         parameter_length: nft$parameter_size;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_protocol_parameter_20
    {
    { Purpose    To send protocol parameter 20, minimum time out value.
    {
    { Description
    {            This parameter specifies to the remote application what
    {            should
    {            be considered the minimum time out value for the transfer.
    {
    {
    { Input parameters
    {            Protocol      : A-A protocol version
    {            Timeout       : Time out value in seconds
    {            Qualifier     : A-A protocol parameter qualifier
    {            Parameter_length : Maximum length of parameter
    {
    { Output parameters
    {            Buffer_list   : List of current network buffers
    {            Status        : Any status returned by :
    {                                 Clp$convert_integer_to_rjstring
    {                                 Nfp$specify_pdu_parameter
    {
    { Algorithm
    {            Convert time to string
    {            Nfp$specify_pdu_parameter(string)
    {
?? EJECT ??
    {}

    VAR
      parameter: ^string ( * );

    {}
    status.normal := TRUE;
    PUSH parameter: [parameter_length];
    clp$convert_integer_to_rjstring (timeout_value, nfc$p20_radix, nfc$p20_include_radix, nfc$p20_fill_char,
          parameter^, status);
    IF status.normal THEN
      nfp$specify_pdu_parameter (nfc$minimum_timeout_interval, qualifier, parameter^, buffer_list, status);
    IFEND;
    {}
  PROCEND nfp$send_protocol_parameter_20;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_21', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_21
    (    protocol: nft$parameter_00_values;
         mode: nft$mode_of_access;
         option: nft$parameter_21_options;
         qualifier: nft$parameter_qualifiers;
         parameter_length: nft$parameter_size;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_protocol_parameter_21
    {
    { Purpose    Send protocol parameter 21, mode of access.  This parameter
    {            is specified when the direction of the transfer in known.
    {
    { Description
    {            The state of transfer is ALWAYS given from the standpoint of
    {            the servicer.  For example, if the servicer is receiving the
    {            file, he returns TAKE.  If the initiator specifies the mode
    {            (as in QTF), and the mode is initiator sends file, he sends
    {            'TAKE'.  NOTE: NOS/VE does not process any mode option except
    {            0000, non-specific.
    {
    { Input parameters
    {            Protocol      : A-A Protocol version
    {            Mode          : Mode of access (GIVE,TAKE,NULL)
    {            Option        : Mode of access option
    {            Qualifier     : A-A Protocol parameter qualifier
    {            Parameter_length: Maximum length of this parameter
    {
    { Output parameters
    {            Buffer_list   : List of current network buffers
    {            Status        : Any value returned by
    {                                 nfp$specify_pdu_parameter
    {
    { Algorithm
    {            Convert parameter to string
    {            Nfp$specify_pdu_parameter(string)
    {
?? EJECT ??

    VAR
      parameter: ^string ( * );

    VAR
      nfv$p21_values: [XREF] nft$parameter_21_values;

    VAR
      nfv$p21_options: [XREF] nft$parameter_21_specifications;

    {}
    status.normal := TRUE;
    PUSH parameter: [parameter_length];
    parameter^ (nfc$p21_prefix_position, nfc$p21_prefix_length) := nfv$p21_values [mode];
    parameter^ (nfc$p21_opt_position, nfc$p21_opt_length) := nfv$p21_options [option];
    nfp$specify_pdu_parameter (nfc$mode_of_access, qualifier, parameter^, buffer_list, status);
    {}
  PROCEND nfp$send_protocol_parameter_21;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_22', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_22
    (    host_type: nft$parameter_22_values;
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$send_protocol_parameter_22                                   }
{                                                                             }
{ Purpose    Send protocol parameter 22, host type.  This parameter is        }
{            sent to a remote host identifying its host type for special      }
{            processing consideration.                                        }
{                                                                             }
{ Description                                                                 }
{            The host type parameter allows like systems (i.e. NOS/VE <->     }
{            NOS/VE) to do some special things.  For example, we pass a       }
{            NOS/VE status parameter in P11 allowing the remote system        }
{            additional information on a transfer.                            }
{                                                                             }
{            Host_type     : Host type value                                  }
{            Qualifier     : A-A Protocol parameter qualifier                 }
{            Host_type     : Local host type                                  }
{                                                                             }
{ Output parameters                                                           }
{            Buffer_list   : List of current network buffers                  }
{            Status        : Any value returned by                            }
{                                 nfp$specify_pdu_parameter                   }
{ Algorithm                                                                   }
{            Nfp$specify_pdu_parameter(type)                                  }
{                                                                             }
?? EJECT ??
    {}

    VAR
      nfv$p22_values: [XREF] nft$parameter_22_strings;

    {}
    status.normal := TRUE;
    nfp$specify_pdu_parameter (nfc$host_type, qualifier, nfv$p22_values [host_type], buffer_list, status);
    {}
  PROCEND nfp$send_protocol_parameter_22;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_24', EJECT ??

{ PURPOSE:
{   This procedure will send the protocol parameter 24, source lid.
{
{ NOTE:
{   This parameter may be truncated or extended to 3 characters for
{   the A101 protocol.

  PROCEDURE nfp$send_protocol_parameter_24
    (    source_lid: string ( * <= nfc$p24_max_param_size);
         qualifier: nft$parameter_qualifiers;
         minimum_parameter_length: nft$parameter_size;
         maximum_parameter_length: nft$parameter_size;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    VAR
      input_parameter_length: nft$parameter_size,
      parameter_length: nft$parameter_size,
      source_lid_value: string (nfc$p24_max_param_size);

    status.normal := TRUE;
    source_lid_value := source_lid;
    input_parameter_length := STRLENGTH(source_lid);
    IF input_parameter_length > maximum_parameter_length THEN
      parameter_length := maximum_parameter_length;
    ELSEIF input_parameter_length < minimum_parameter_length THEN
      parameter_length := minimum_parameter_length;
    ELSE
      parameter_length := input_parameter_length;
    IFEND;
    nfp$specify_pdu_parameter (nfc$source_lid, qualifier, source_lid_value (1, parameter_length),
          buffer_list, status);

  PROCEND nfp$send_protocol_parameter_24;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_25', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_25
    (    protocol: nft$parameter_00_values;
         transfer_lid: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
         maximum_parameter_length: nft$parameter_size;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$send_protocol_parameter_25                                   }
{                                                                             }
{ Purpose    To send protocol parameter 25, transfer logical identifier.      }
{                                                                             }
{ Description                                                                 }
{            The transfer logical identifier (LID) is exchanged between       }
{            hosts during protocol negotiation.  It is used for network       }
{            control (LID's may be turned off) and tracking (LID's should     }
{            be logged) information.                                          }
{                                                                             }
{ Input parameters                                                            }
{            Protocol      : A-A Protocol version                             }
{            Transfer_lid  : Name of the transfer LID                         }
{            Qualifier     : A-A Protocol parameter qualifier                 }
{            Host_type     : Local host type                                  }
{            Maximum_Parameter_length: Maximum length for parameter           }
{                                                                             }
{ Output parameters                                                           }
{            Buffer_list   : List of current network buffers                  }
{            Status        : Any status returned by                           }
{                             nfp$specify_pdu_parameter                       }
{ Algorithm                                                                   }
{            Truncate LID to protocol maximum (if necessary)                  }
{            Nfp$specify_pdu_parameter                                        }
{                                                                             }
?? EJECT ??

    VAR
      input_parameter_length: nft$parameter_size,
      parameter_length: nft$parameter_size;

    {}
    status.normal := TRUE;
    input_parameter_length := STRLENGTH (transfer_lid);
    IF (input_parameter_length > maximum_parameter_length) THEN
      parameter_length := maximum_parameter_length;
    ELSE
      parameter_length := input_parameter_length;
    IFEND;
    nfp$specify_pdu_parameter (nfc$transfer_lid, qualifier, transfer_lid (1, parameter_length), buffer_list,
          status);
    {}
  PROCEND nfp$send_protocol_parameter_25;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_26', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_26
    (    protocol: nft$parameter_00_values;
         application: nft$application_values;
         job_name: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
         maximum_parameter_length: nft$parameter_size;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$send_protocol_parameter_26                                   }
{                                                                             }
{ Purpose    To send protocol parameter 26, job name.                         }
{                                                                             }
{ Description                                                                 }
{            The job name parameter is exchanged between hosts for job        }
{            tracking.  NOTE: the protocol ID A101 forces NOS/VE to truncate  }
{            job names and fold characters.  Only allowed characters include  }
{                   A-Z, 0..9, $, #, and @.                                   }
{                                                                             }
{ Input parameters                                                            }
{            Protocol      : A-A Protocol version                             }
{            Job_name      : Name of the local job                            }
{            Qualifier     : A-A Protocol parameter qualifier                 }
{            Host_type     : Local host type                                  }
{            Maximum_parameter_length : Maximum size for parameter            }
{                                                                             }
{ Output parameters                                                           }
{            Buffer_list   : List of current network buffers                  }
{            Status        : Any status returned by                           }
{                             nfp$specify_pdu_parameter                       }
{ Algorithm                                                                   }
{            Case protocol ID of                                              }
{            =a101= Build a101 job name                                       }
{            =a102,b101= Build a102,b101 job name                             }
{            Nfp$specify_pdu_parameter                                        }
{                                                                             }
?? EJECT ??

    VAR
      byte_offset: 0 .. 11,
      index: nft$parameter_size,
      input_parameter_length: nft$parameter_size,
      parameter_length: nft$parameter_size,
      scratch_index: nft$parameter_size,
      scratch_string: ^string ( * );

{}
    status.normal := TRUE;
    input_parameter_length := STRLENGTH (job_name);
    CASE protocol OF

    = nfc$p00_a101 =
      PUSH scratch_string: [maximum_parameter_length];

{ For QTF, this parameter represents the user specified name of the job file. }
{ But for PTF, it represents the name of PTF/PTFS job which has the           }
{ format of $DDDD_DDDD_AAA_DDDD where D indicates a digit and A indicates     }
{ a alphabet. Set byte offset equal 11 will skip the digits that are in       }
{ front of the first alphabet and pick AAADDDD as the job name.               }
{}

      byte_offset := 0;
      IF ((application = nfc$application_ptf) OR
          (application = nfc$application_ptfs)) THEN
        byte_offset := 11;
      IFEND;
      parameter_length := 0;
      scratch_index := 1;

    /a101_for_loop/
      FOR index := 1+byte_offset TO input_parameter_length DO
        IF (($INTEGER (job_name (index)) >= $INTEGER (nfc$p26_1st_range1_a101)) AND
              ($INTEGER (job_name (index)) <= $INTEGER (nfc$p26_last_range1_a101))) OR
              (($INTEGER (job_name (index)) >= $INTEGER (nfc$p26_1st_range2_a101)) AND
              ($INTEGER (job_name (index)) <= $INTEGER (nfc$p26_last_range2_a101))) OR
              ($INTEGER (job_name (index)) = $INTEGER (nfc$p26_special1_a101)) OR
              ($INTEGER (job_name (index)) = $INTEGER (nfc$p26_special2_a101)) THEN
          scratch_string^ (scratch_index) := job_name (index);
          scratch_index := scratch_index + 1;
          parameter_length := parameter_length + 1;
          IF parameter_length = maximum_parameter_length THEN
            EXIT /a101_for_loop/;
          IFEND;
        IFEND;
      FOREND /a101_for_loop/;
      IF parameter_length < 0 THEN
        nfp$set_internal_error ('nfp$send_protocol_parameter_26 pl', status);
        RETURN;
      IFEND;

    = nfc$p00_a102, nfc$p00_b101 =

      IF maximum_parameter_length < input_parameter_length THEN
        parameter_length := maximum_parameter_length;
      ELSE
        parameter_length := input_parameter_length;
      IFEND;
      scratch_string := ^job_name;
    ELSE
      nfp$set_internal_error ('nfp$send_protocol_parameter_26 Protid case', status);
      pmp$exit (status);
    CASEND;

    nfp$specify_pdu_parameter (nfc$job_name, qualifier, scratch_string^ (1, parameter_length), buffer_list,
          status);

{}
  PROCEND nfp$send_protocol_parameter_26;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_27', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_27
    (    protocol: nft$parameter_00_values;
         physical_id: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
         maximum_parameter_length: nft$parameter_size;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

{                                                                             }
{ Procedure nfp$send_protocol_parameter_27
{           }
{                                                                             }
{ Purpose   Send parameter 27, physical id.                                   }
{                                                                             }
{ Description                                                                 }
{            The physical id parameter is exchanged between hosts for         }
{            network control and tracking purposes. Additionally, it is       }
{            used as the source LID is a store and forward environment if     }
{            no source lid is specified.                                      }
{                                                                             }
{ Input parameters                                                            }
{            Protocol      : A-A Protocol version                             }
{            Physical_id   : Input physical id                                }
{            Qualifier     : A-A Protocol parameter qualifier                 }
{            Maximum_parameter_length: Maximum # of characters in parameter   }
{                                                                             }
{ Output parameters                                                           }
{            Status        : Any status returned by                           }
{            Buffer_list   : List of current network buffers                  }
{                                 nfp$specify_pdu_parameter                   }
{ Algorithm                                                                   }
{            Format PID dependent on protocol varient                         }
{            Nfp$specify_pdu_parameter                                        }
{                                                                             }
?? EJECT ??

    VAR
      parameter_length: nft$parameter_size,
      input_parameter_length: integer;

    {}
    status.normal := TRUE;
    input_parameter_length := STRLENGTH (physical_id);
    IF input_parameter_length > maximum_parameter_length THEN
      parameter_length := maximum_parameter_length;
    ELSE
      parameter_length := input_parameter_length;
    IFEND;
    nfp$specify_pdu_parameter (nfc$physical_id, qualifier, physical_id (1, parameter_length), buffer_list,
          status);
    {}
  PROCEND nfp$send_protocol_parameter_27;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_28', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_28
    (    dest_host_type: nft$parameter_22_values;
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$send_protocol_parameter_28                                   }
{                                                                             }
{ Purpose    To send protocol parameter 28, destination host type.            }
{                                                                             }
{ Description                                                                 }
{            This parameter is specified when a host assumes its partner      }
{            is a given host type.  If that assumption is wrong, the          }
{            parameter should be returned modified.                           }
{                                                                             }
{ Input parameters                                                            }
{            Dest_host     : Type of the destination host                     }
{            Qualifier     : A-A Protocol parameter qualifier                 }
{                                                                             }
{ Output parameters                                                           }
{            Buffer_list   : List of current network buffers                  }
{            Status        : Any status returned by                           }
{                                 nfp$specify_pdu_parameter                   }
{                                                                             }
{ Algorithm                                                                   }
{            Nfp$specify_pdu_parameter( host-type-string )                    }
{                                                                             }
?? EJECT ??

    VAR
      nfv$p22_values: [XREF] nft$parameter_22_strings;

{}
    status.normal := TRUE;
    nfp$specify_pdu_parameter (nfc$destination_host_type, qualifier, nfv$p22_values [dest_host_type],
          buffer_list, status);
{}
  PROCEND nfp$send_protocol_parameter_28;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_29', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_29
    (    echo_text_list: nft$parameter_29_list_head;
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);
{
{ Procedure  nfp$send_protocol_parameter_29
{
{ Purpose    To send protocol parameter 29, echo text.
{
{ Description
{            This parameter may be sent to a remote host expecting the parameter
{            to be returned on the next protocol command (RFT -> RPOS).  For
{            VE -> VE applications, this parameter may be used to specify
{            VE specific information.
{
{ Input parameters
{            echo_text_list:      List of text of be sent
{            qualifier:           A-A protocol parameter qualifier
{
{ Output parameters
{            buffer_list:         List of current network buffers
{            status:              Return status
{
{ Algorithm
{            current_entry = first on list
{            While current_entry <> NIL Do
{              nfp$specify_pdu_parameter
{              If o.k., current_entry = next_entry
{              Else return
{            Whilend
{
?? EJECT ??
  VAR
      echo_text_ptr: ^nft$parameter_29_definition;

  status.normal := TRUE;
  echo_text_ptr := echo_text_list.first_text;
  WHILE (echo_text_ptr <> NIL) DO
    nfp$specify_pdu_parameter(nfc$echo, qualifier,
      echo_text_ptr^.value(1,echo_text_ptr^.size),
      buffer_list, status);
    IF status.normal THEN
      echo_text_ptr := echo_text_ptr^.link;
    ELSE
      RETURN;
    IFEND;
  WHILEND;

  PROCEND nfp$send_protocol_parameter_29;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_31', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_31
    (    data_declaration: nft$parameter_31_type;
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

{                                                                             }
{ Procedure nfp$send_protocol_parameter_31
{           }
{                                                                             }
{ Purpose    To send parameter 31, data declaration.                          }
{                                                                             }
{ Description                                                                 }
{            The data declaration parameter specifies what mode a file        }
{            transfer is to use.  For VE <-> VE transfers, mode UH should     }
{            be used.  For VE <-> non VE systems, types C6 , C8 , and UU      }
{            are valid.                                                       }
{                                                                             }
{ Input parameters                                                            }
{            Data_declar   : Data declaration to be used                      }
{            Qualifier     : A-A Protocol parameter qualifier                 }
{                                                                             }
{ Output parameters                                                           }
{            Buffer_list   : List of current network buffers                  }
{            Status        : Any status returned by                           }
{                                 nfp$specify_pdu_parameter                   }
{ Algorithm                                                                   }
{            Nfp$specify_pdu_parameter( data_type_string )                    }
{                                                                             }
?? EJECT ??

    VAR
      nfv$parameter_31_values: [XREF] nft$parameter_31_definition;

    {}
    status.normal := TRUE;
    nfp$specify_pdu_parameter (nfc$data_declaration, qualifier, nfv$parameter_31_values [data_declaration],
          buffer_list, status);
    {}
  PROCEND nfp$send_protocol_parameter_31;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_32', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_32
    (    systems_routing_text: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_protocol_parameter_32
    {
    { Purpose    Send parameter 32, system routing text.
    {
    { Description   Systems routing text is defined
    {               separately for various applications.
    {
    { Input parameters
    {               systems_routing_text:       string of text to send
    {
    { Output parameters
    {               buffer_list:                list of protocol to send buffers
    {               status:                     return status
    {
    { Algorithm
    {               call nfp$specify_pdu_parameter
    {
?? EJECT ??

    nfp$specify_pdu_parameter (nfc$system_routing_text, qualifier, systems_routing_text, buffer_list, status);
    {}
  PROCEND nfp$send_protocol_parameter_32;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_33', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_33
    (    implicit_routing_text: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_protocol_parameter_33
    {
    { Purpose    Send parameter 33, implicit routing text.
    {
    { Description  Implicit routing text is defined for
    {               separate applications.
    {
    { Input parameters
    {        implicit_routing_text:      routing text string
    {
    { Output parameters
    {        buffer_list:                list of protocol buffers to be sent
    {        status:                     return status
    {
    { Algorithm
    {        call nfp$specify_pdu_parameter
    {
?? EJECT ??

    nfp$specify_pdu_parameter (nfc$implicit_routing_text, qualifier, implicit_routing_text, buffer_list,
          status);
    {}
  PROCEND nfp$send_protocol_parameter_33;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_51', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_51
    (    protocol: nft$parameter_00_values;
         command: nft$protocol_commands;
         user_file_name: string ( * );
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_protocol_parameter_51
    {
    { Purpose    Send P51, user file name.
    {
    {
    {
    {
    {
    {
    { Description
    {
    {
    {
    {
    {
    {
    { Input parameters
    {
    {
    {
    {
    {
    { Output parameters
    {
    {
    {
    {
    {
    { Algorithm
    {
    {
    {
    {
    {
    {
    {
    {
    {
    {
?? EJECT ??
    status.normal := TRUE;
    IF STRLENGTH (user_file_name) > 0 THEN
      nfp$specify_pdu_parameter (nfc$user_file_name, qualifier, user_file_name, buffer_list, status);
    IFEND;
    {}
  PROCEND nfp$send_protocol_parameter_51;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_52', EJECT ??
  {}

  PROCEDURE nfp$send_protocol_parameter_52
    (    qualifier: nft$parameter_qualifiers;
         banner_date_and_time: string(* <= nfc$p52_max_param_length);
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_protocol_parameter_52
    {
    { Purpose    Send parameter 52, banner date and time.
    {
    { Description
    {            This routine sends the banner date and
    {            time specified by the application.
    {
    { Input parameters
    {               qualifier:                  A-A protocol parameter qualifier
    {               banner_date_and_time:       String for banner
    {
    { Output parameters
    {               buffer_list:                List of network buffers
    {               status:                     Return status
    {
    { Algorithm
    {               nfp$specify_pdu_parameter
    {
?? EJECT ??

    status.normal := TRUE;
    nfp$specify_pdu_parameter (nfc$banner_date_and_time, qualifier,
             banner_date_and_time, buffer_list, status);
    {}
  PROCEND nfp$send_protocol_parameter_52;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_53', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_53
    (    protocol: nft$parameter_00_values;
         command: nft$protocol_commands;
         banner_routing_text: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_protocol_parameter_53
    {
    { Purpose    Send parameter 53, banner routing text.
    {
    { Description
    {
    {
    {
    {
    {
    {
    { Input parameters
    {
    {
    {
    {
    {
    { Output parameters
    {
    {
    {
    {
    {
    { Algorithm
    {
    {
    {
    {
    {
    {
    {
    {
    {
    {
?? EJECT ??
    status.normal := TRUE;
    IF STRLENGTH (banner_routing_text) > 0 THEN
      nfp$specify_pdu_parameter (nfc$banner_routing_text, qualifier,
       banner_routing_text, buffer_list, status);
    IFEND;
    {}
  PROCEND nfp$send_protocol_parameter_53;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_54', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_54
    (    protocol: nft$parameter_00_values;
         command: nft$protocol_commands;
         user_banner_text: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_protocol_parameter_54
    {
    { Purpose    Send parameter 54, user banner text.
    {
    { Description
    {
    {
    {
    {
    {
    {
    { Input parameters
    {
    {
    {
    {
    {
    { Output parameters
    {
    {
    {
    {
    {
    { Algorithm
    {
    {
    {
    {
    {
    {
    {
    {
    {
    {
?? EJECT ??
    status.normal := TRUE;
    IF STRLENGTH (user_banner_text) > 0 THEN
      nfp$specify_pdu_parameter (nfc$user_banner_text, qualifier, user_banner_text,
        buffer_list, status);
    IFEND;
    {}
  PROCEND nfp$send_protocol_parameter_54;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_55', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_55
    (    protocol: nft$parameter_00_values;
         command: nft$protocol_commands;
         installation_banner_text: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_protocol_parameter_55
    {
    { Purpose    Send parameter 55, installation banner text.
    {
    { Description
    {
    {
    {
    {
    {
    {
    { Input parameters
    {
    {
    {
    {
    {
    { Output parameters
    {
    {
    {
    {
    {
    { Algorithm
    {               nfp$specify_pdu_parameter
    {
?? EJECT ??
    status.normal := TRUE;
    IF STRLENGTH(installation_banner_text) > 0 THEN
      nfp$specify_pdu_parameter (nfc$installation_banner_text, qualifier,
             installation_banner_text, buffer_list, status);
    IFEND;
  {}
  PROCEND nfp$send_protocol_parameter_55;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_56', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_56
    (    protocol: nft$parameter_00_values;
         command: nft$protocol_commands;
         repos_params: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_protocol_parameter_56
    {
    { Purpose    To send parameter 56, reposition output parameters.
    {
    {
    {
    {
    {
    {
    { Description
    {
    {
    {
    {
    {
    {
    { Input parameters
    {
    {
    {
    {
    {
    { Output parameters
    {
    {
    {
    {
    {
    { Algorithm
    {
    {
    {
    {
    {
    {
    {
    {
    {
?? EJECT ??
    status.normal := TRUE;
  PROCEND nfp$send_protocol_parameter_56;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_57', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_57
    (    protocol: nft$parameter_00_values;
         command: nft$protocol_commands;
         current_fpos: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
         buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_protocol_parameter_57
    {
    { Purpose    Send parameter 57, current file position.
    {
    {
    {
    {
    {
    {
    { Description
    {
    {
    {
    {
    {
    {
    { Input parameters
    {
    {
    {
    {
    {
    { Output parameters
    {
    {
    {
    {
    {
    { Algorithm
    {
    {
    {
    {
    {
    {
    {
    {
    {
    {
?? EJECT ??
    status.normal := TRUE;
  PROCEND nfp$send_protocol_parameter_57;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_58', EJECT ??

  PROCEDURE nfp$send_protocol_parameter_58
    (    protocol: nft$parameter_00_values;
         command: nft$protocol_commands;
         output_dest: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
         buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_protocol_parameter_58
    {
    { Purpose    To send parameter 58, output file destination.
    {
    {
    {
    {
    {
    {
    { Description
    {
    {
    {
    {
    {
    {
    { Input parameters
    {
    {
    {
    {
    {
    { Output parameters
    {
    {
    {
    {
    {
    { Algorithm
    {
    {
    {
    {
    {
    {
    {
    {
    {
    {
?? EJECT ??
    status.normal := TRUE;
  PROCEND nfp$send_protocol_parameter_58;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_59' , eject ??
  PROCEDURE nfp$send_protocol_parameter_59
    (               vertical_print_density: jmt$vertical_print_density;
                    qualifier: nft$parameter_qualifiers;
                VAR buffer_list: nft$network_buffer_list;
                VAR status: ost$status);
{
{ Procedure  nfp$send_protocol_parameter_59
{
{ Purpose    To send protocol parameter 59, vertical print density
{
{
{
{
{
{ Description
{
{
{
{
{
{ Input parameters
{
{
{ Output parameters
{
{
{ Algorithm
{
{
{
{
{
{
VAR
      nfv$p59_values: [XREF] nft$parameter_59_values;
{}
  IF nfv$p59_values[vertical_print_density] = 'XX' THEN
    nfp$set_internal_error('Invalid p59 value to send', status);
  ELSE
    nfp$specify_pdu_parameter(nfc$vertical_print_density, qualifier,
      nfv$p59_values[vertical_print_density], buffer_list, status);
  IFEND;
{}
  PROCEND nfp$send_protocol_parameter_59;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_protocol_parameter_60' , eject ??
  PROCEDURE nfp$send_protocol_parameter_60
    (               vfu_load_procedure: string(*<=nfc$p60_max_param_length);
                    qualifier: nft$parameter_qualifiers;
                VAR buffer_list: nft$network_buffer_list;
                VAR status: ost$status);
{
{ Procedure  nfp$send_protocol_parameter_60
{
{ Purpose    To send protocol parameter 60, vfu load procedure.
{
{ Description
{
{
{
{
{
{ Input parameters
{
{
{ Output parameters
{
{
{ Algorithm
{            nfp$specify_pdu_parameter for vfu_load_procedure
{
    nfp$specify_pdu_parameter(nfc$vfu_load_procedure, qualifier,
      vfu_load_procedure, buffer_list, status);
{}
  PROCEND nfp$send_protocol_parameter_60;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$qualifier_error', EJECT ??

  PROCEDURE nfp$qualifier_error
    (    qualifier: nft$parameter_qualifiers;
         parameter: nft$protocol_parameters;
         command: nft$protocol_commands;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$qualifier_error                                              }
{                                                                             }
{ Purpose    To set a status variable to protocol parameter qualifier error.  }
{                                                                             }
{ Description                                                                 }
{            The status variable is set using call information.               }
{                                                                             }
{ Input parameters                                                            }
{            Qualifier     : Received (bad) qualifier.                        }
{            Parameter     : Protocol parameter of qualifier                  }
{            Command       : A-A protocol command of parameter                }
{                                                                             }
{ Output parameters                                                           }
{            Status        : Return status value                              }
{                                                                             }
{ Algorithm                                                                   }
{            Osp$set_status_abnormal                                          }
{            Osp$append_status_parameter                                      }
{            Osp$append_status_parameter                                      }
{                                                                             }
{}

    VAR
      nfv$command_values: [XREF] nft$command_values;

    VAR
      nfv$param_id_values: [XREF] nft$parameter_values;

    VAR
      nfv$param_qualifier_values: [XREF] nft$parameter_qualifier_values;

{}
    osp$set_status_abnormal (nfc$status_id, nfe$qualifier_error, nfv$param_qualifier_values [qualifier],
          status);
    osp$append_status_parameter (osc$status_parameter_delimiter, nfv$param_id_values [parameter], status);
    osp$append_status_parameter (osc$status_parameter_delimiter, nfv$command_values [command], status);
{}
  PROCEND nfp$qualifier_error;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$set_internal_error', EJECT ??

  PROCEDURE nfp$set_internal_error
    (    message: string ( * );
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$set_internal_error                                           }
{                                                                             }
{ Purpose    To set a status variable to internal error.                      }
{                                                                             }
{ Description                                                                 }
{            The status variable is set to internal error with a data         }
{            field containing a string value.  The string value should        }
{            normally be the name of the calling routine.                     }
{                                                                             }
{ Input parameters                                                            }
{            Message       : String error message                             }
{                                                                             }
{ Output parameters                                                           }
{            Status        : Return status = nfe$bts_internal_error           }
{                                                                             }
{ Algorithm                                                                   }
{            Osp$set_status_abnormal                                          }
{                                                                             }
{}
    osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, message, status);
{}
  PROCEND nfp$set_internal_error;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$format_message_to_job_log', EJECT ??

  PROCEDURE [XDCL] nfp$format_message_to_job_log
    (    status: ost$status);

{                                                                             }
{ Procedure  nfp$format_message_to_job_log                                    }
{                                                                             }
{ Purpose    To translate a variable of type OST$STATUS and write the         }
{            value to the job log.                                            }
{                                                                             }
{ Description                                                                 }
{            If you think this routine looks a lot like an example in         }
{            CYBIL for NOS/VE System Interface, it is.                        }
{                                                                             }
{ Input parameters                                                            }
{            Status        : Input status value                               }
{                                                                             }
{ Output parameters                                                           }
{            NONE...                                                          }
{                                                                             }
{ Algorithm                                                                   }
{            Translate message to string                                      }
{            For i = 1 to # of message pieces Do                              }
{              Pmp$log( message piece)                                        }
{            Forend                                                           }
{                                                                             }
?? EJECT ??
{}

    VAR
      index: 1 .. osc$max_status_message_lines,
      message: ost$status_message,
      msg_line_count: ^ost$status_message_line_count,
      msg_line_size: ^ost$status_message_line_size,
      msg_line_text: ^string ( * ),
      pointer: ^ost$status_message,
      trace_status: ost$status;

{}
    osp$format_message (status, osc$full_message_level, nfc$trace_commands_width, message, trace_status);
    pointer := ^message;
    RESET pointer;
    NEXT msg_line_count IN pointer;
    FOR index := 1 TO msg_line_count^ DO
      NEXT msg_line_size IN pointer;
      NEXT msg_line_text: [msg_line_size^] IN pointer;
      pmp$log (msg_line_text^, trace_status);
    FOREND;
{}
  PROCEND nfp$format_message_to_job_log;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$receive_parameter_00', EJECT ??

  PROCEDURE [XDCL] nfp$receive_parameter_00
    (    command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
         current_value: nft$parameter_00_values;
     VAR new_value: nft$parameter_00_values;
     VAR negotiate_down: boolean;
     VAR status: ost$status);

    {
    { Procedure nfp$receive_parameter_00
    {
    { Purpose   Handle received parameter 00, protocol id.
    {
    { Description
    {           This routine is called to process received protocol
    {           identifiers.
    {           The protocol identifier should be received (in existing
    {           applications) on the commands (RFT,RPOS,RNEG).  These rules
    {           are enforced:
    {           1. If the received protocol ID is ignored, the lowest (A101)
    {              value is to be used.
    {           2. If the received value is selected or modified, this value
    {              cannot be greater than the applications current value.
    {              (i.e. the protocol ID can only be negotiated downward ).
    {
    { Input parameters
    {           Received_value       : Parameter value received (string)
    {           Qualifier            : A-A protocol parameter qualifier
    {           Current_value        : Value of current P00 (ordinal)
    {
    { Output parameters
    {           New_value            : Accepted new value
    {           Negotiate_down       : Boolean value informing the application
    {                                  to renegotiate the transfer with a new
    {                                  protocol ID.
    {           Status               : normal -or-
    {                                  nfe$invalid_protocol_negot
    {                                  nfe$invalid_protocol_value
    {
    { Algorithm
    {           If not legal protocol ID then
    {             Set error/return
    {           Ifend
    {           Case qualifier of
    {           =ignored= Prot_id = A101
    {           =select,modify=
    {                           If greater  than current value then
    {                             Error
    {                           Ifend
    {           Casend;
    {
?? EJECT ??

    VAR
      nfv$p00_values: [XREF] nft$p00_values;

    VAR
      index: nft$parameter_00_values,
      value_found: boolean,
      parameter_length: nft$parameter_size;

{}
    status.normal := TRUE;
    negotiate_down := FALSE;
    parameter_length := STRLENGTH (received_value);
    value_found := FALSE;

  /p00_search_loop/
    FOR index := LOWERVALUE (nft$parameter_00_values) TO UPPERVALUE (nft$parameter_00_values) DO
      IF ((parameter_length = nfv$p00_values [index].length) AND
            (received_value = nfv$p00_values [index].value)) THEN
        value_found := TRUE;
        EXIT /p00_search_loop/;
      IFEND;
    FOREND /p00_search_loop/;
{}
    IF NOT value_found THEN
      osp$set_status_abnormal (nfc$status_id, nfe$invalid_protocol_value, received_value, status);
      RETURN;
    IFEND;
{}
    CASE qualifier OF
    = nfc$ignore =
      new_value := nfc$p00_a101;
    = nfc$modify, nfc$select =
      IF index < current_value THEN {** Negoitiated downward, o.k. **}
        new_value := index;
        IF command = nfc$rneg THEN
          negotiate_down := TRUE;
        IFEND;
      ELSEIF index = current_value THEN {** protocol ID's match **}
        new_value := index;
      ELSE {** Illegal negotiation **}
        osp$set_status_abnormal (nfc$status_id, nfe$invalid_protocol_negot, received_value, status);
      IFEND;
    ELSE
      nfp$set_internal_error ('nfp$receive_parameter_00 qualifier case', status);
      pmp$exit (status);
    CASEND;

  PROCEND nfp$receive_parameter_00;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_01', EJECT ??

  PROCEDURE nfp$receive_parameter_01
    (    current_value: string ( * <= nfc$max_param_size);
     VAR new_value: nft$parameter_01_values;
     VAR status: ost$status);

    { Purpose   To process parameter 01, maximum transfer file size, as
    {           received from remote.

    VAR
      length_record: clt$integer;


    status.normal := TRUE;
    clp$convert_string_to_integer (current_value, length_record, status);
    IF (NOT status.normal) OR (length_record.radix_specified) THEN
      osp$set_status_abnormal (nfc$status_id, nfe$parameter_length_error, current_value, status);
    ELSE
      new_value := length_record.value;
    IFEND;

  PROCEND nfp$receive_parameter_01;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_03', EJECT ??

  PROCEDURE nfp$receive_parameter_03
    (    command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
         current_value: nft$parameter_03_value_set;
         required_facilities: nft$parameter_03_value_set;
         allowed_facilities: nft$parameter_03_value_set;
     VAR parameter_modified: boolean;
     VAR new_value: nft$parameter_03_value_set;
     VAR buffer_list: nft$network_buffer_list;
     VAR status: ost$status);

{ Procedure nfp$receive_parameter_03
{
{ Purpose    Process parameter 03, facilities, as received from remote
{            application.
{
{ Description
{            This routine cracks the received parameter value in a facilities
{            set.  This set is checked against the allowed facilities set
{            to ensure legality.
{
{ Input parameters
{            Command              : Received A-A protocol command
{            Received_value       : Received parameter string
{            Qualifier            : A-A protocol parameter qualifier
{            Current_value        : Current facility set
{            Network              : Type of network of connection
{            Required_facilities  : Application required facilities
{
{ Output parameters
{            Parameter_modified   : Flag indicating this process changed param
{            New_value            : Accepted protocol set
{            Buffer_list          : List of current network buffers
{            Status               : Return status
{                                     nfe$unknown_facility_option
{                                   from nfp$qualifier_error

    VAR
      facility_index: nft$facility_types,
      found_it: boolean,
      index: 0 .. nfc$p03_max_size,
      optional_facilities: nft$parameter_03_value_set,
      received_facilities: nft$parameter_03_value_set,
      trace_status: ost$status;

    VAR
      nfv$p03_values: [XREF] nft$parameter_03_elements;


    status.normal := TRUE;
    parameter_modified := FALSE;
    received_facilities := $nft$parameter_03_value_set [];

  /search_loop/
    FOR index := 1 TO STRLENGTH (received_value) DO
      found_it := FALSE;

    /facility_loop/
      FOR facility_index := LOWERVALUE (nft$facility_types) TO UPPERVALUE (nft$facility_types) DO
        IF received_value (index, 1) = nfv$p03_values [facility_index] THEN
          found_it := TRUE;
          EXIT /facility_loop/;
        IFEND;
      FOREND /facility_loop/;
      IF found_it THEN
        received_facilities := received_facilities + $nft$parameter_03_value_set [facility_index];
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$unknown_facility_option, received_value (index, 1),
              status);
        RETURN;
      IFEND;
    FOREND /search_loop/;

    CASE qualifier OF
    = nfc$select, nfc$modify =
      new_value := received_facilities;
    = nfc$ignore =
      new_value := current_value - received_facilities;
    ELSE
      nfp$set_internal_error ('nfp$receive_parameter_03 qualifier case', status);
      RETURN;
    CASEND;

{ Check required facilities are present

    IF NOT (required_facilities <= new_value) THEN { No, cannot continue
      osp$set_status_abnormal (nfc$status_id, nfe$dislike_parameter, 'Unacceptable facilities option set',
            status);
      new_value := current_value;
    ELSE { Required facilities are there, check any optional facilities
      optional_facilities := new_value - required_facilities;
      IF NOT (optional_facilities <= allowed_facilities) THEN { Try to modify
        new_value := required_facilities;
        FOR facility_index := LOWERVALUE (nft$facility_types) TO UPPERVALUE (nft$facility_types) DO
          IF (facility_index IN optional_facilities) AND (facility_index IN allowed_facilities) THEN
            new_value := new_value + $nft$parameter_03_value_set [facility_index];
          IFEND;
        FOREND;
        nfp$send_protocol_parameter_03 (nfc$modify, new_value, buffer_list, status);
        IF NOT status.normal THEN { Major disaster, cannot modify
          pmp$exit (status);
        ELSE
          parameter_modified := TRUE;
        IFEND;
      IFEND;
    IFEND;

  PROCEND nfp$receive_parameter_03;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_04', EJECT ??

  PROCEDURE nfp$receive_parameter_04
    (    command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
         current_value: ost$status;
     VAR new_value: ost$status;
     VAR status: ost$status);

    {
    { Procedure  nfp$receive_parameter_04
    {
    { Purpose    Handle received parameter 04, state of transfer.
    {
    { Description
    {           This routine receives a parameter 04 string and cracks it into
    {           internal (status) format.  If the severity of the received
    {           status
    {           is less than the current status, the new status will not be
    {           set.
    {
    { Input parameters
    {           Command              : Received A-A protocol command
    {           Received_value       : P04 string
    {           Qualifier            : A-A protocol parameter qualifier
    {           Current_value        : Current P04 (status) value
    {
    { Output parameters
    {           New_value            : New P04 (status) value
    {           Status               : Completion status
    {
    { Algorithm
    {           Loop known 04 values for match
    {           If no match, error
    {           Else
    {             If new 04 value more severe than current, set to new value
    {           Ifend
    {
?? EJECT ??

    VAR
      found_it: boolean,
      index: 1 .. nfc$p04_max_transfer_states;

    VAR
      nfv$param_id_values: [XREF] nft$parameter_values;

    VAR
      nfv$p04_values: [XREF] nft$parameter_04_values;

    {}
    status.normal := TRUE;
    CASE qualifier OF
    = nfc$select, nfc$modify =
      found_it := FALSE;

    /p04_search_loop/
      FOR index := LOWERVALUE (index) TO UPPERVALUE (index) DO
        IF (received_value = nfv$p04_values [index].code) THEN
          found_it := TRUE;
          EXIT /p04_search_loop/;
        IFEND;
      FOREND /p04_search_loop/;
      {}
      IF NOT found_it THEN {** Remote sent illegal sot **}
        osp$set_status_abnormal (nfc$status_id, nfe$unknown_transfer_state,
              nfv$param_id_values [nfc$state_of_transfer], status);
        osp$append_status_parameter (osc$status_parameter_delimiter, received_value, status);
      ELSE {** Sot is valid, check it against my known status **}
        IF (nfv$p04_values [index].normal) AND (NOT current_value.normal) THEN
          ; { He is out of touch, ignore remote status }
        ELSE
          new_value.normal := nfv$p04_values [index].normal;
          new_value.condition := nfv$p04_values [index].condition;
        IFEND;
      IFEND;

    = nfc$ignore =
      nfp$qualifier_error (qualifier, nfc$state_of_transfer, command, status);
    ELSE
      nfp$set_internal_error ('nfp$receive_parameter_04 qualifier case', status);
      pmp$exit (status);
    CASEND;
    {}
  PROCEND nfp$receive_parameter_04;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_05', EJECT ??

  PROCEDURE nfp$receive_parameter_05
    (    command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR directive_list: nft$directive_entry_list_head;
     VAR status: ost$status);

    {
    { Procedure nfp$receive_parameter_05
    {
    { Purpose   To process protocol parameter 05, user text directive
    {
    { Description
    {           This routine takes the input 05 string and enqueues it to a
    {           list.  Processing of 05 parameters is dependent upon the
    {           application, therefore it must check for received 05's.
    {
    { Input parameters
    {           Command              : Received A-A protocol command             }
    {           Received_value       : P05 string
    {           Qualifier            : A-A protocol parameter qualifier
    {
    { Output parameters
    {           Directive_list       : List head for received 05 parameters
    {           Status               : Return status
    {
    { Algorithm
    {           Allocate space for directive
    {           Enqueue directive
    {
?? EJECT ??

    VAR
      current_entry: ^nft$directive_entry;

    {}
    status.normal := TRUE;
    CASE qualifier OF
    = nfc$select =
      ALLOCATE current_entry: [#SIZE (received_value)];
      IF current_entry = NIL THEN
        nfp$set_internal_error ('nfp$receive_parameter_05 no vm', status);
        RETURN;
        RETURN;
      IFEND;
      current_entry^.line := received_value;
      current_entry^.link := NIL;
      IF directive_list.head = NIL THEN
        directive_list.tail := current_entry;
        directive_list.head := current_entry;
      ELSE
        directive_list.tail^.link := current_entry;
        directive_list.tail := current_entry;
      IFEND;
    = nfc$modify =
      nfp$qualifier_error (qualifier, nfc$user_text_directive, command, status);
    = nfc$ignore =
      IF command <> nfc$rneg THEN {** Remote will not execute some directives }
        nfp$qualifier_error (qualifier, nfc$user_text_directive, command, status);
      IFEND;
    ELSE
      nfp$set_internal_error ('nfp$receive_parameter_05 qualifier case', status);
      pmp$exit (status);
    CASEND;
    {}
  PROCEND nfp$receive_parameter_05;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_06', EJECT ??

  PROCEDURE nfp$receive_parameter_06
    (    received_value: string ( * <= nfc$max_param_size);
     VAR file_size: nft$parameter_06_values;
     VAR status: ost$status);

    {
    { Procedure nfp$receive_parameter_06
    {
    { Purpose   To process parameter 06, file size.
    {
    {
    {
    { Description
    {           The length of the file is decoded and returned to the calling
    {           application.
    {
    { Input parameters
    {           Command              : Received A-A protocol command
    {           Received_value       : Parameter value string
    {
    { Output parameters
    {           File_size            : Returned file size
    {           Status               : Returned status
    {
    { Algorithm
    {           Convert string to integer
    {           If not success, set error
    {
?? EJECT ??

    VAR
      integer_record: clt$integer;

    {}
    status.normal := TRUE;
    clp$convert_string_to_integer (received_value, integer_record, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (nfc$status_id, nfe$invalid_p06_value, received_value, status);
    ELSE
      file_size := (integer_record.value * nfc$p06_unit);
    IFEND;
    {}
  PROCEND nfp$receive_parameter_06;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_07', EJECT ??

  PROCEDURE nfp$receive_parameter_07
    (    command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR directive_list: nft$directive_entry_list_head;
     VAR status: ost$status);

    {
    { Procedure  nfp$receive_parameter_07
    {
    { Purpose    Receive parameter 07, operator message, from remote host.
    {
    { Description The operator message is queued to a list for the calling
    {             application.
    {
    { Input parameters
    {           Command              : A-A protocol command
    {           Received_value       : Received parameter 07 value
    {           Qualifier            : A-A protocol parameter qualifier
    {
    { Output parameters
    {           Directive_list       : List on which to place received value
    {           Status               : Return status
    {
    { Algorithm
    {            Pmp$log
    {            Return
    {
    status.normal := TRUE;
    CASE qualifier OF

    = nfc$select =

      nfp$enqueue_directive_on_list (received_value, directive_list, status);

    = nfc$ignore, nfc$modify =
      ;

      nfp$qualifier_error (qualifier, nfc$user_message, command, status);

    ELSE
      nfp$set_internal_error ('nfp$receive_parameter_07 qualifier case', status);
      pmp$exit (status);
    CASEND;
    {}
  PROCEND nfp$receive_parameter_07;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_08', EJECT ??

  PROCEDURE nfp$receive_parameter_08
    (    command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR directive_list: nft$directive_entry_list_head;
     VAR status: ost$status);

    {
    { Procedure  nfp$receive_parameter_08
    {
    { Purpose    Receive parameter 08, user message, from remote host.
    {            Warning***Warning : In the future, when non-NOS/VE systems
    {            are verified, these messages should be sent to $output
    {
    { Description The user message is queued to a list for processing by the
    {             calling application.
    {
    { Input parameters
    {           Command              : A-A protocol command
    {           Received_value       : Received parameter 07 value
    {           Qualifier            : A-A protocol parameter qualifier
    {
    { Output parameters
    {
    { Algorithm
    {            Pmp$log
    {            Return
    {
?? EJECT ??
    status.normal := TRUE;
    CASE qualifier OF

    = nfc$select =

      nfp$enqueue_directive_on_list (received_value, directive_list, status);

    = nfc$ignore, nfc$modify =
      ;

      nfp$qualifier_error (qualifier, nfc$user_message, command, status);

    ELSE
      nfp$set_internal_error ('nfp$receive_parameter_08 qualifier case', status);
      pmp$exit (status);
    CASEND;
    {}
  PROCEND nfp$receive_parameter_08;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$dispose_user_msg_to_log', EJECT ??

  PROCEDURE [XDCL] nfp$dispose_user_msg_to_log
    (VAR directive_list: nft$directive_entry_list_head);

{                                                                             }
{ Procedure  nfp$dispose_user_msg_to_log                                      }
{                                                                             }
{ Purpose    To put all directives on list into the job log.                  }
{                                                                             }
{ Description                                                                 }
{            This routine puts each directive into the job log and deallocates}
{            its storage.  When this routine is complete, the list is NIL.    }
{                                                                             }
{ Input parameters                                                            }
{            None                                                             }
{                                                                             }
{ Output parameters                                                           }
{            Directive_list: List of directives to log and deallocate         }
{                                                                             }
{ Algorithm                                                                   }
{            While directive exists Do                                        }
{              Log directive                                                  }
{              Deallocate directive                                           }
{              Next directive                                                 }
{            Whilend                                                          }
{            Set list header = NIL                                            }
{                                                                             }
?? EJECT ??

    VAR
      current_entry: ^nft$directive_entry,
      log_status: ost$status,
      next_entry: ^nft$directive_entry;

{}
    IF directive_list.head <> NIL THEN
      current_entry := directive_list.head;
      pmp$log ('RHF - Message(s) from remote host', log_status);
      WHILE current_entry <> NIL DO
        pmp$log (current_entry^.line, log_status);
        next_entry := current_entry^.link;
        FREE current_entry;
        current_entry := next_entry;
      WHILEND;
      pmp$log ('RHF - End of remote host message(s)', log_status);
      directive_list.head := NIL;
      directive_list.tail := NIL;
    IFEND;
{}
  PROCEND nfp$dispose_user_msg_to_log;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_09', EJECT ??

  PROCEDURE nfp$receive_parameter_09
    (    command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR directive_list: nft$directive_entry_list_head;
     VAR status: ost$status);

    {
    { Procedure  nfp$receive_parameter_09
    {
    { Purpose    Receive parameter 09, accouting message, from remote host.
    {
    { Description The account message is not processed by nos/ve
    {
    { Input parameters
    {           Command              : A-A protocol command
    {           Received_value       : Received parameter 07 value
    {           Qualifier            : A-A protocol parameter qualifier
    {
    { Output parameters
    {
    { Algorithm
    {            Return
    {
?? EJECT ??
    status.normal := TRUE;
    CASE qualifier OF

    = nfc$select =

      nfp$enqueue_directive_on_list (received_value, directive_list, status);

    = nfc$ignore, nfc$modify =
      ;

      nfp$qualifier_error (qualifier, nfc$user_message, command, status);

    ELSE
      nfp$set_internal_error ('nfp$receive_parameter_09 qualifier case', status);
      pmp$exit (status);
    CASEND;
    {}
  PROCEND nfp$receive_parameter_09;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_10', EJECT ??

  PROCEDURE nfp$receive_parameter_10
    (    command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR directive_list: nft$directive_entry_list_head;
     VAR status: ost$status);

    {
    { Procedure  nfp$receive_parameter_10
    {
    { Purpose    Receive parameter 10, error log message, from remote host.
    {
    { Description
    {
    { Input parameters
    {           Command              : A-A protocol command
    {           Received_value       : Received parameter 07 value
    {           Qualifier            : A-A protocol parameter qualifier
    {
    { Output parameters
    {
    { Algorithm
    {            Return
    {
?? EJECT ??
    status.normal := TRUE;
    CASE qualifier OF

    = nfc$select =

      nfp$enqueue_directive_on_list (received_value, directive_list, status);

    = nfc$ignore, nfc$modify =
      ;

      nfp$qualifier_error (qualifier, nfc$user_message, command, status);

    ELSE
      nfp$set_internal_error ('nfp$receive_parameter_10 qualifier case', status);
      pmp$exit (status);
    CASEND;
    {}
  PROCEND nfp$receive_parameter_10;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_11', EJECT ??

  PROCEDURE nfp$receive_parameter_11
    (    received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR special_options: nft$parameter_11_value;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$receive_parameter_11
{                                                                             }
{ Purpose    Receive parameter 11, special options.  The special options      }
{            parameter is used in NOS/VE <-> NOS/VE transfers to pass NOS/VE  }
{            specific status information.  The special options are used in    }
{            a rather application dependent context.                          }
{                                                                             }
{ Description                                                                 }
{            Parameter 11 is application specific, and must be                }
{            cracked there.                                                   }
{                                                                             }
{ Input parameters                                                            }
{            Received_value       Received parameter string                   }
{            Qualifier            A-A protocol qualifier                      }
{                                                                             }
{ Output parameters                                                           }
{            Special_options      Returned value                              }
{            Status               Return status                               }
{                                                                             }

    status.normal := TRUE;
    special_options.qualifier := qualifier;
    special_options.size := STRLENGTH (received_value);
    IF special_options.size > 0 THEN
      special_options.value := received_value;
    IFEND;

  PROCEND nfp$receive_parameter_11;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_12', EJECT ??

  PROCEDURE nfp$receive_parameter_12
    (    received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
         data_type: nft$parameter_31_type;
     VAR block_size: nft$parameter_12_range;
     VAR status: ost$status);

{
{ Purpose    Receive parameter 12, maximum data block size and converts it to
{            an integer value.  If the parameter was ignored by the remote
{            host, defaults are applied..
{
{ Input parameters
{           Command              : A-A protocol command
{           Received_value       : P12 string
{           Qualifier            : A-A protocol parameter qualifier
{           Data_type            : Current data type  P31
{           Current_value        : Current value for P12
{
{ Output parameters
{           Block_size           : New block size
{           Status               : Returned status
{

    VAR
      integer_record: clt$integer;


    status.normal := TRUE;
    CASE qualifier OF
    = nfc$select, nfc$modify =
      clp$convert_string_to_integer (received_value, integer_record, status);
      IF status.normal THEN
        block_size := integer_record.value;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$invalid_p12_value, received_value, status);
      IFEND;

    = nfc$ignore =
      CASE data_type OF
      = nfc$p31_unspecified, nfc$p31_ascii_c6, nfc$p31_ascii_c8 =
        block_size := nfc$p12_nos_ascii_size;

      = nfc$p31_undef_unstructured_uu =
        block_size := nfc$p12_nos_binary_size;

      = nfc$p31_undefined_structured_us =
        block_size := nfc$p12_nos_binary_size;

      ELSE
        nfp$set_internal_error ('nfp$receive_parameter_12 host type case', status);
        RETURN;
      CASEND;
    ELSE
      nfp$set_internal_error ('nfp$receive_parameter_12 qualifier case', status);
      RETURN;
    CASEND;

  PROCEND nfp$receive_parameter_12;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_13', EJECT ??

  PROCEDURE nfp$receive_parameter_13
    (    received_value: string( * <= nfc$p13_max_param_size);
         qualifier: nft$parameter_qualifiers;
         command: nft$protocol_commands;
     VAR accounting_limit: nft$parameter_13_definition;
     VAR status: ost$status);

{
{ Procedure  nfp$receive_parameter_13
{
{ Purpose    To receive protocol parameter 13, accounting limit.
{
{ Description
{            The accounting limit is converted to an integer value.
{
{ Input parameters
{            received_value:      Received parameter value
{            qualifier:           Protocol parameter qualifier
{            command:             Protocol command
{
{ Output parameters
{            accounting_limit:    Returned accounting limit
{            status:              Return status
{
{ Algorithm
{            CASE qualifier OF
{            =select,modify= convert string to value
{            =ignore= If not on RPOS or RNEG, then error
{            CASEND
{
?? EJECT ??
{}
VAR
      integer_record: clt$integer;
{}
  status.normal := TRUE;
  CASE qualifier OF
  =nfc$select, nfc$modify =
    clp$convert_string_to_integer( received_value, integer_record, status);
    IF status.normal THEN
      accounting_limit := integer_record.value;
    IFEND;
  =nfc$ignore=
    IF NOT((command = nfc$rpos) OR (command = nfc$rneg)) THEN
      nfp$qualifier_error( qualifier, nfc$accounting_limit,
             command, status);
    IFEND;
  ELSE
    nfp$set_internal_error('nfp$receive_parameter_13 case error', status);
  CASEND;
{}
  PROCEND nfp$receive_parameter_13;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_16', EJECT ??

  PROCEDURE nfp$receive_parameter_16
    (    received_value: string ( * <= nfc$p16_max_param_length);
     VAR file_name: nft$parameter_16_definition;
     VAR status: ost$status);

{
{ Procedure  nfp$receive_parameter_16
{
{ Purpose    To receive parameter 16, file-name/IO queue.
{            This parameter is used to exchange file-name and/or
{            IO queue information between applications.
{            This information is application specific.
{
{ Description
{            This parameter is treated as a string.
{
{ Input parameters
{            Received_value:      String value of P16
{
{ Output parameters
{            File_name:    Returned string value
{
{ Algorithm
{            Output = Input
{
?? EJECT ??
    IF (STRLENGTH(received_value) <=
      STRLENGTH(file_name.value)) THEN
      file_name.size := STRLENGTH(received_value);
      file_name.value := received_value;
    ELSE
      nfp$set_internal_error('nfm$rhf_protocol_engine invalid P16 size',status);
    IFEND;
{}
  PROCEND nfp$receive_parameter_16;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_17', EJECT ??

  PROCEDURE nfp$receive_parameter_17
    (    received_value: string ( * <= nfc$max_param_size);
         command: nft$protocol_commands;
         qualifier: nft$parameter_qualifiers;
     VAR disposition: nft$parameter_17_definition;
     VAR status: ost$status);
{
{ Procedure  nfp$receive_parameter_17
{
{ Purpose    Handle received parameter 17, disposition code.
{
{ Description
{            This routine receives a string representing a disposition code.
{            The string is then cracked into an ordinal disposition code value.
{
{ Input parameters
{            Received_value:      Received parameter value
{            Command:             Received A-A protocol command
{            Qualifier:           Received protocol parameter qualifier
{
{ Output parameters
{            Disposition:         Returned ordinal value
{            Status:              Completion status
{
{ Algorithm
{            Loop known P17 values
{            If match then return value
{            Else return error
{            Ifend;
{
?? EJECT ??
  VAR
      disposition_index: nft$parameter_17_definition,
      matched_disposition_code: BOOLEAN;

  VAR
      nfv$parameter_17_values: [XREF] nft$parameter_17_values;
{}
  CASE qualifier OF
  =nfc$select,nfc$modify=
    matched_disposition_code := FALSE;
    /disposition_search_loop/
    FOR disposition_index := LOWERBOUND(nfv$parameter_17_values) TO
                             UPPERBOUND(nfv$parameter_17_values) DO
      IF (nfv$parameter_17_values[disposition_index] = received_value) THEN
        matched_disposition_code := TRUE;
        EXIT /disposition_search_loop/;
      IFEND;
    FOREND;
    IF matched_disposition_code THEN
      disposition := disposition_index;
    ELSE
      osp$set_status_abnormal( nfc$status_id, nfe$invalid_p17_value,
               received_value, status);
    IFEND;
  =nfc$ignore=
    nfp$qualifier_error(qualifier, nfc$file_disposition, command, status);
  ELSE
    nfp$set_internal_error('nfp$receive_parameter_17 qualifier case error', status);
  CASEND;
{}
  PROCEND nfp$receive_parameter_17;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_18', EJECT ??

  PROCEDURE nfp$receive_parameter_18
    (    received_value: string ( * <= nfc$p18_maximum_parameter_size);
         qualifier: nft$parameter_qualifiers;
     VAR acknowledgment_window: nft$parameter_18_definition;
     VAR status: ost$status);
{
{ Procedure  nfp$receive_parameter_18
{
{ Purpose    To receive and process parameter 18, acknowledgment window.
{
{ Description
{            This routine takes the received value and places it the
{            the subrange defined for parameter 18.
{
{ Input parameters
{            received_value:      Input value
{            qualifier:           A-A protocol parameter qualifier
{
{ Output parameters
{            acknowledgment_window:      Returned value
{            status:                     Return status
{
{ Algorithm
{            Convert input value to string
{            If value fits, return it
{
  VAR
      integer_record: clt$integer;
{}
  CASE qualifier OF
  =nfc$select, nfc$modify =
    clp$convert_string_to_integer( received_value, integer_record, status);
    IF status.normal THEN
      IF (integer_record.value <= UPPERVALUE(acknowledgment_window)) AND
         (integer_record.value >= LOWERVALUE(acknowledgment_window)) THEN
        acknowledgment_window := integer_record.value;
      ELSE
        osp$set_status_abnormal(nfc$status_id, nfe$invalid_p18_value,
          received_value, status);
      IFEND;
    ELSE
      osp$set_status_abnormal(nfc$status_id, nfe$invalid_p18_value,
        received_value, status);
    IFEND;
  =nfc$ignore=
      ;      { No action }
  ELSE
    nfp$set_internal_error('nfp$receive_parameter_18 case error', status);
  CASEND;
{}
  PROCEND nfp$receive_parameter_18;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_19', EJECT ??

  PROCEDURE nfp$receive_parameter_19
    (    received_value: string ( * <= nfc$p19_maximum_parameter_size);
         qualifier: nft$parameter_qualifiers;
     VAR initial_restart_checkmark: nft$parameter_19_definition;
     VAR status: ost$status);
{
{ Procedure  nfp$receive_parameter_19
{
{ Purpose    To receive and process parameter 19, initial checkmark restart
{
{ Description
{            The received value is converted to the subrange type and returned
{            to the application.
{
{ Input parameters
{            Received_value:      Input value
{            Qualifier:           A-A protocol parameter qualifier
{
{ Output parameters
{            Initial_restart_checkmark:  Returned value
{            Status:                     Return status
{
{ Algorithm
{            Convert input value to integer
{            If value fits in range, then return it
{
  VAR
      integer_record: clt$integer;
{}
  CASE qualifier OF
  =nfc$select, nfc$modify =
    clp$convert_string_to_integer( received_value, integer_record, status);
    IF status.normal THEN
      IF (integer_record.value <= UPPERVALUE(initial_restart_checkmark)) AND
         (integer_record.value >= LOWERVALUE(initial_restart_checkmark)) THEN
        initial_restart_checkmark := integer_record.value;
      ELSE
        osp$set_status_abnormal(nfc$status_id, nfe$invalid_p19_value,
          received_value, status);
      IFEND;
    ELSE
      osp$set_status_abnormal(nfc$status_id, nfe$invalid_p19_value,
        received_value, status);
    IFEND;
  =nfc$ignore=
      ;      { No action }
  ELSE
    nfp$set_internal_error('nfp$receive_parameter_19 case error', status);
  CASEND;
{}
  PROCEND nfp$receive_parameter_19;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$receive_parameter_20', EJECT ??

  PROCEDURE [XDCL] nfp$receive_parameter_20
    (    received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
         path: nft$network_connection;
     VAR timeout_value: nft$parameter_20_range;
     VAR status: ost$status);

    {
    { Procedure  nfp$receive_parameter_20
    {
    { Purpose    Handle received parameter 20, minimum time out value.
    {
    { Description
    {           The input parameter string is cracked into an integer
    {           representing
    {           representing the time out value in seconds.
    {
    { Input parameters
    {           Received_value       : Input P20 string value
    {           Qualifier            : A-A protocol parameter qualifier
    {           Path                 : Path info, for changing network file attributes
    {
    { Output parameters
    {           Timeout_value        : Returned time out value in seconds
    {           Status               : Return status
    {
    { Algorithm
    {           Convert P20 value to integer
    {           If error, set error return
    {
?? EJECT ??

    VAR
      integer_record: clt$integer,
      nam_attributes: ^nat$change_attributes,
      rhfam_attributes: ^rft$change_attributes;
    {}
    status.normal := TRUE;
    CASE qualifier OF
    = nfc$select, nfc$modify =
      clp$convert_string_to_integer (received_value, integer_record, status);
      IF status.normal AND (integer_record.value > 0) THEN
        timeout_value := integer_record.value;
        CASE path.network_type OF
        =nfc$network_nam=
             PUSH nam_attributes: [1..1];
             nam_attributes^[1].kind := nac$data_transfer_timeout;
             nam_attributes^[1].data_transfer_timeout := timeout_value *
                    nfc$milliseconds;
             nap$store_attributes( path.network_file_id, nam_attributes^,
                    status);
        =nfc$network_lcn=
             PUSH rhfam_attributes: [1..1];
             rhfam_attributes^[1].key := rfc$data_transfer_timeout;
             rhfam_attributes^[1].data_transfer_timeout := timeout_value *
                    nfc$milliseconds;
             rfp$store( path.network_file_id, rhfam_attributes^,
                    status);
        ELSE
          nfp$set_internal_error('nfp$receive_parameter_20 invalid network type',
             status);
        CASEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$invalid_p20_value, received_value, status);
      IFEND;
    = nfc$ignore =
      timeout_value := nfc$p20_network_default;
    ELSE
      nfp$set_internal_error ('nfp$receive_parameter_20 case statement', status);
    CASEND;
    {}
  PROCEND nfp$receive_parameter_20;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$common_receive_21', EJECT ??

  PROCEDURE nfp$receive_parameter_21
    (    received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR mode: nft$mode_of_access;
     VAR option: nft$parameter_21_options;
     VAR status: ost$status);

    {
    { Procedure  nfp$receive_parameter_21
    {
    { Purpose    Receive parameter 21, mode of access.
    {
    { Description
    {           The received parameter 21 is cracked into the two components
    {           of the mode of access.  First, the mode part is cracked.
    {           Second, the option part is cracked.  NOS/VE RHF only uses
    {           the non-specific mode, others are processed as non-specific
    {           would be.
    {
    { Input parameters
    {           Received_value       : Received P21 value
    {           Qualifier            : A-A protocol parameter qualifier
    {
    { Output parameters
    {           Mode                 : Mode part of mode of access
    {           Option               : Option part of mode of access
    {           Status               : Return status
    {
    { Algorithm
    {
    {
    {
    {
    {
    {
    {
    {
    {
    {
?? EJECT ??

    VAR
      found_it: boolean;

    VAR
      nfv$p21_options: [XREF] nft$parameter_21_specifications;

    VAR
      nfv$p21_values: [XREF] nft$parameter_21_values;

    {}
    {     Search for mode }
    {}
    status.normal := TRUE;
    found_it := FALSE;

  /mode_loop/
    FOR mode := LOWERBOUND (nfv$p21_values) TO UPPERBOUND (nfv$p21_values) DO
      IF received_value (nfc$p21_prefix_position, nfc$p21_prefix_length) = nfv$p21_values [mode] THEN
        found_it := TRUE;
        EXIT /mode_loop/;
      IFEND;
    FOREND /mode_loop/;
    IF NOT found_it THEN
      osp$set_status_abnormal (nfc$status_id, nfe$invalid_p21_value, received_value, status);
      RETURN;
    IFEND;
    {}
    {     Search for mode option }
    {}
    found_it := FALSE;

  /option_loop/
    FOR option := LOWERBOUND (nfv$p21_options) TO UPPERBOUND (nfv$p21_options) DO
      IF received_value (nfc$p21_opt_position, nfc$p21_opt_length) = nfv$p21_options [option] THEN
        found_it := TRUE;
        EXIT /option_loop/;
      IFEND;
    FOREND /option_loop/;
    IF NOT found_it THEN
      osp$set_status_abnormal (nfc$status_id, nfe$invalid_p21_spec,
            received_value (nfc$p21_opt_position, nfc$p21_opt_length), status);
      RETURN;
    IFEND;
    {}
    IF (option = nfc$p21_make_only_too) THEN
      option := nfc$p21_make_only;
    IFEND;
    {}
  PROCEND nfp$receive_parameter_21;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$receive_parameter_22', EJECT ??

  PROCEDURE [XDCL] nfp$receive_parameter_22
    (    received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR host_type: nft$parameter_22_values;
     VAR status: ost$status);

    {
    { Procedure  nfp$receive_parameter_22
    {
    { Purpose    To receive and process parameter 22, remote host type.
    {
    { Description
    {           The input host type is converted to a host type ordinal.
    {
    { Input parameters
    {           Received_value       : Input P22 string
    {           Qualifier            : A-A protocol parameter qualifier
    {
    { Output parameters
    {           Host_type            : Returned NOS/VE host or UNKNOWN host type
    {           Status               : Return status
    {


    status.normal := TRUE;
    host_type := nfc$p22_unknown_host;
    CASE qualifier OF
    = nfc$select, nfc$modify =
      IF received_value = nfc$p22_value_cyber_nosve THEN
        host_type := nfc$p22_nos_ve;
      ELSEIF received_value = nfc$p22_value_cyber_nosve_qtf THEN
        host_type := nfc$p22_nos_ve_qtf;
      IFEND;
    = nfc$ignore =
      ;
    ELSE
      nfp$set_internal_error ('nfp$receive_parameter_22 qualifier case', status);
      pmp$exit (status);
    CASEND;

  PROCEND nfp$receive_parameter_22;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_24', EJECT ??

  PROCEDURE nfp$receive_parameter_24
    (    received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR source_lid: nft$parameter_24_definition;
     VAR status: ost$status);

    {
    { Procedure  nfp$receive_parameter_24
    {
    { Purpose    Receive and process parameter 24, source lid.
    {
    { Description
    {           This routine takes the parameter 24 string and
    {           places it in the proper type.
    {
    { Input parameters
    {        received_value:      Value of source LID
    {        qualifier:           A-A protocol parameter qualifier
    {
    { Output parameters
    {        source_lid:   Returned source LID value
    {        status:       Return status
    {
    { Algorithm
    {        IF qualifer is select or modify, set new value
    {        ELSE if qualifier is ignore, no action
    {        ELSE case error
    {
    status.normal := TRUE;
    CASE qualifier OF
    =nfc$select, nfc$modify =
      source_lid.size := STRLENGTH(received_value);
      source_lid.value := received_value;
    =nfc$ignore=
      ;      { No action }
    ELSE
      nfp$set_internal_error('nfp$receive_parameter_24 case error', status);
    CASEND;
    {}
  PROCEND nfp$receive_parameter_24;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_25', EJECT ??

  PROCEDURE nfp$receive_parameter_25
    (    command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR transfer_lid: nft$parameter_25_definition;
     VAR lid_length: nft$parameter_25_length;
     VAR status: ost$status);

    {
    { Procedure  nfp$receive_parameter_25
    {
    { Purpose    Receive and process parameter 25, transfer lid.
    {
    { Description
    {           The transfer lid is a name which is associated with a PID.
    {           This routine merely saves the transfer LID in the event the
    {           calling application is interested.
    {
    { Input parameters
    {           Received_value       : Received string
    {           Qualifier            : A-A protocol parameter qualifier
    {
    { Output parameters
    {           Buffer_list          : List of network send buffers
    {           Xfer_pid             : Returned LID name value
    {           Lid_length           : Length of returned LID
    {           Status               : Return status
    {
    { Algorithm
    {           Set LID value
    {           Set LID length
    {
?? EJECT ??
    status.normal := TRUE;
    CASE qualifier OF
    = nfc$select =
      transfer_lid := received_value;
      lid_length := STRLENGTH (received_value);
    = nfc$modify, nfc$ignore =
      nfp$qualifier_error (qualifier, nfc$transfer_lid, command, status);
    ELSE
      nfp$set_internal_error ('nfp$receive_parameter_25 case error', status);
    CASEND;
    {}
  PROCEND nfp$receive_parameter_25;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_26', EJECT ??

{ PURPOSE:
{   This procedure will process parameter 26, job name by validating the P26
{   value received was legal and returning the job name and job name length
{   to the caller.

  PROCEDURE nfp$receive_parameter_26
    (    command: nft$protocol_commands;
         protocol: nft$parameter_00_values;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
         negotiation_in_progress: boolean;
     VAR job_name: nft$parameter_26_definition;
     VAR status: ost$status);

    VAR
      job_name_index: integer,
      job_name_length: integer,
      search_index: integer,
      space_filled: boolean;

    status.normal := TRUE;
    CASE qualifier OF
    = nfc$select =
      CASE protocol OF
      = nfc$p00_a101 =
        space_filled := FALSE;

      /name_loop/
        FOR job_name_index := 1 TO STRLENGTH (received_value) DO
          IF (($INTEGER (received_value (job_name_index)) > $INTEGER (nfc$p26_1st_char_a102)) AND
                ($INTEGER (received_value (job_name_index)) <= $INTEGER (nfc$p26_last_char_a102))) THEN
            {      Character is o.k. }
          ELSEIF received_value (job_name_index) = ' ' THEN
            space_filled := TRUE;
            EXIT /name_loop/;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$invalid_p26_value, received_value (job_name_index),
                  status);
            RETURN;
          IFEND;
        FOREND /name_loop/;

        IF space_filled THEN
          job_name_index := job_name_index - 1;
        IFEND;
        job_name_length := job_name_index;
        IF job_name_length > STRLENGTH (job_name.value) THEN { Truncate job name }
          job_name_length := STRLENGTH (job_name.value);
        IFEND;
        job_name.value (1, job_name_length) := received_value;
        job_name.size := job_name_length;
      = nfc$p00_a102, nfc$p00_b101 =

        FOR job_name_index := 1 TO STRLENGTH (received_value) DO
          IF NOT (($INTEGER (received_value (job_name_index,
                1)) >= $INTEGER (nfc$p26_1st_char_a102)) AND ($INTEGER (received_value (job_name_index,
                1)) <= $INTEGER (nfc$p26_last_char_a102))) THEN
            osp$set_status_abnormal (nfc$status_id, nfe$invalid_p26_value, received_value (job_name_index),
                  status);
            RETURN;
          IFEND;
        FOREND;
        job_name_length := STRLENGTH (received_value);
        IF job_name_length > STRLENGTH (job_name.value) THEN { Truncate job name }
          job_name_length := STRLENGTH (job_name.value);
        IFEND;
        job_name.size := job_name_length;
        job_name.value(1, job_name_length) := received_value;
      ELSE
        nfp$set_internal_error ('nfp$receive_parameter_26 protocol case', status);
        pmp$exit (status);
      CASEND;
    = nfc$modify =
      IF NOT (negotiation_in_progress) THEN
        nfp$qualifier_error (qualifier, nfc$job_name, command, status);
      ELSE
        { Do not process, should get again }
      IFEND;
    = nfc$ignore =
      IF NOT (negotiation_in_progress) THEN
        nfp$qualifier_error (qualifier, nfc$job_name, command, status);
      ELSE
        { Do not process, should get again }
      IFEND;
    ELSE
      nfp$set_internal_error ('nfp$receive_parameter_26 qualifier case', status);
    CASEND;

  PROCEND nfp$receive_parameter_26;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_27', EJECT ??

  PROCEDURE nfp$receive_parameter_27
    (    command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR transfer_pid: nft$parameter_27_definition;
     VAR transfer_pid_length: nft$parameter_27_length;
     VAR status: ost$status);

    {
    { Procedure  nfp$receive_parameter_27
    {
    { Purpose    Receive and process parameter 27, transfer PID.
    {
    { Description
    {           The PID for NOS/VE to NOS/VE transfers should be a family
    {           name.  With other hosts, it may be an abstration.
    {
    { Input parameters
    {           Received_value       : Received string
    {           Qualifier            : A-A protocol parameter qualifier
    {
    { Output parameters
    {           Xfer_pid             : Returned PID name value
    {           Pid_length           : Length of returned PID
    {           Status               : Return status
    {
    { Algorithm
    {           Set PID name
    {           Set PID length
    {
?? EJECT ??
    status.normal := TRUE;
    CASE qualifier OF
    = nfc$select =
      transfer_pid := received_value;
      transfer_pid_length := STRLENGTH (received_value);
    = nfc$modify =
{     Do not process }
    = nfc$ignore =
      nfp$qualifier_error (qualifier, nfc$job_name, command, status);
    ELSE
      nfp$set_internal_error ('nfp$receive_parameter_27 case statement', status);
    CASEND;
    {}
  PROCEND nfp$receive_parameter_27;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_28', EJECT ??

  PROCEDURE nfp$receive_parameter_28
    (    received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR host_type: nft$parameter_22_values;
     VAR status: ost$status);

{
{ Procedure  nfp$receive_parameter_28
{
{ Purpose    To receive parameter 28, destination host type.
{
{ Description
{            The destination host type is sent by an initiator when it
{            thinks (hopes) it knows the type of the remote host.
{            If it is incorrect, the value should be modified or the
{            transfer RNEG'ed.
{
{ Input parameters
{            Received_value       : Input string
{            Qualifier            : A-A protocol parameter qualifier
{
{ Output parameters
{            Host_type            : Returned NOS/VE host or UNKNOWN host type
{            Status               : Return status
{


    status.normal := TRUE;
    host_type := nfc$p22_unknown_host;
    CASE qualifier OF
    = nfc$select, nfc$modify =
      IF received_value = nfc$p22_value_cyber_nosve THEN
        host_type := nfc$p22_nos_ve;
      ELSEIF received_value = nfc$p22_value_cyber_nosve_qtf THEN
        host_type := nfc$p22_nos_ve_qtf;
      IFEND;
    = nfc$ignore =
    ELSE
      nfp$set_internal_error ('nfp$receive_parameter_28 qualifier case', status);
      pmp$exit (status);
    CASEND;

  PROCEND nfp$receive_parameter_28;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_29', EJECT ??

  PROCEDURE nfp$receive_parameter_29
    (    received_value: string(*<=nfc$p29_max_param_size);
     VAR echo_text_list: nft$parameter_29_list_head);
{
{ Procedure  nfp$receive_parameter_29
{
{ Purpose    To receive protocol parameter 29, echo text.
{
{ Description
{            The received echo text is placed on a linked list
{            for application specific processing.
{
{ Input parameters
{            received_value:      Input echo text value
{
{ Output parameters
{            echo_text_list:      List of echo text values received
{
{ Algorithm
{
{
{
{
{
{
?? EJECT ??
  VAR current_entry: ^nft$parameter_29_definition;

  ALLOCATE current_entry;
  current_entry^.size := STRLENGTH(received_value);
  current_entry^.value := received_value;
  current_entry^.link := NIL;
  IF echo_text_list.first_text = NIL THEN
    echo_text_list.first_text := current_entry;
    echo_text_list.last_text := current_entry;
  ELSE
    echo_text_list.last_text^.link := current_entry;
    echo_text_list.last_text := current_entry;
  IFEND;

  PROCEND nfp$receive_parameter_29;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$convert_p31_to_ordinal', EJECT ??

{ PURPOSE:
{   To convert a string, if possible, to a data declaration ordinal.
{   This routine essentially just loops through the list of
{   known data declarations attempting to match the input value.

  PROCEDURE [XDCL] nfp$convert_p31_to_ordinal
    (    received_value: string ( * <= nfc$max_param_size);
     VAR data_type: nft$parameter_31_type;
     VAR status: ost$status);

    VAR
      found_it: boolean,
      index: nft$parameter_31_type;

    VAR
      nfv$parameter_31_values: [XREF] nft$parameter_31_definition;

    status.normal := TRUE;
    found_it := FALSE;

  /search_loop/
    FOR index := LOWERBOUND (nfv$parameter_31_values) TO UPPERBOUND (nfv$parameter_31_values) DO
      IF received_value = nfv$parameter_31_values [index] THEN
        found_it := TRUE;
        EXIT /search_loop/;
      IFEND;
    FOREND /search_loop/;

    IF found_it THEN
      data_type := index;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$unknown_data_format, received_value, status);
    IFEND;

  PROCEND nfp$convert_p31_to_ordinal;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_31', EJECT ??

{ PURPOSE:
{   To receive protocol parameter 31, data declaration.
{   The received data declaration is converted into our P31 ordinal type.

  PROCEDURE nfp$receive_parameter_31
    (    application: nft$application_values;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR data_type: nft$parameter_31_type;
     VAR status: ost$status);

    status.normal := TRUE;
    CASE qualifier OF
    = nfc$select, nfc$modify =
      nfp$convert_p31_to_ordinal (received_value, data_type, status);
      IF (status.normal) AND (data_type=nfc$p31_undefined_structured_us) AND
           (application <> nfc$application_ptf) AND (application <> nfc$application_ptfs) AND
           (application <> nfc$application_qtf) AND (application <> nfc$application_qtfs) THEN
        osp$set_status_abnormal(nfc$status_id,nfe$unknown_data_format,
            received_value,status);
      IFEND;
    = nfc$ignore =
    ELSE
      nfp$set_internal_error ('nfp$receive_parameter_31 qualifier case', status);
      pmp$exit (status);
    CASEND;

  PROCEND nfp$receive_parameter_31;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_32', EJECT ??

  PROCEDURE nfp$receive_parameter_32
    (    received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR systems_routing_text: jmt$system_routing_text;
     VAR status: ost$status);

{
{ Procedure  nfp$receive_parameter_32
{
{ Purpose    To receive parameter 32, systems routing text.
{
{ Description
{            This routine takes a received string value and
{            repackages it as systems routing text.  Note:
{            systems routing text is defined differently for various
{            applications.
{
{ Input parameters
{            received_value:      Implicit text value
{            qualifier:           A-A protocol parameter qualifier
{
{ Output parameters
{            systems_routing_text:       Systems routing text
{            status:                     Return status
{
{ Algorithm
{            systems_routing_text := received_value
{
?? EJECT ??
    status.normal := TRUE;
    CASE qualifier OF
    = nfc$select, nfc$modify =
      systems_routing_text.size := STRLENGTH (received_value);
      IF STRLENGTH (received_value) > 0 THEN
        systems_routing_text.parameters := received_value;
      IFEND;
    = nfc$ignore =
    ELSE
      nfp$set_internal_error ('nfp$receive_parameter_32 invalid case', status);
    CASEND;
{}
  PROCEND nfp$receive_parameter_32;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_33', EJECT ??

  PROCEDURE nfp$receive_parameter_33
    (    received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR implicit_routing_text: jmt$implicit_routing_text;
     VAR status: ost$status);

{
{ Procedure  nfp$receive_parameter_33
{
{ Purpose    Receive and process parameter 33, implicit routing text
{
{ Description
{            This routine takes a received string value and
{            repackages it as implicit routing text.  Note:
{            implicit routing text is defined differently for various
{            applications.
{
{ Input parameters
{            received_value:      Implicit text value
{            qualifier:           A-A protocol parameter qualifier
{
{ Output parameters
{            implicit_routing_text:      Systems routing text
{            status:                     Return status
{
{ Algorithm
{            implicit_routing_text := received_value
{
?? EJECT ??
    status.normal := TRUE;
    CASE qualifier OF
    = nfc$select, nfc$modify =
      implicit_routing_text.size := STRLENGTH (received_value);
      IF STRLENGTH (received_value) > 0 THEN
        implicit_routing_text.text := received_value;
      IFEND;
    = nfc$ignore =
      nfp$set_internal_error ('nfp$receive_parameter_33 invalid case', status);
    CASEND;
{}
  PROCEND nfp$receive_parameter_33;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_51', EJECT ??

  PROCEDURE nfp$receive_parameter_51
    (    protocol: nft$parameter_00_values;
         command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR user_file_name: ost$string;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$receive_parameter_51                                         }
{                                                                             }
{ Purpose    To receive and process parameter 51, user file name.  This       }
{            parameter is used only by BTF/BTFS at present.                   }
{                                                                             }
{ Description                                                                 }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{ Input parameters                                                            }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{ Output parameters                                                           }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{ Algorithm                                                                   }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
    status.normal := TRUE;
    user_file_name.value := received_value;
    user_file_name.size := STRLENGTH (received_value);
{}
  PROCEND nfp$receive_parameter_51;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_52', EJECT ??

  PROCEDURE nfp$receive_parameter_52
    (    protocol: nft$parameter_00_values;
         command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR banner_dtime: ost$string;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$receive_parameter_52                                         }
{                                                                             }
{ Purpose    To receive and process parameter 52, banner date and time.       }
{            Note: this parameter is used only by BTF/BTFS at present.        }
{                                                                             }
{ Description                                                                 }
{            This parameter specifies the date and time that the file         }
{            transfer to the output device is being initiated.  The           }
{            receiver uses this parameter value when constructing the         }
{            output file banner.                                              }
{                                                                             }
{ Input parameters                                                            }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{ Output parameters                                                           }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{ Algorithm                                                                   }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
    status.normal := TRUE;
    banner_dtime.value := received_value;
    banner_dtime.size := STRLENGTH (received_value);
{}
  PROCEND nfp$receive_parameter_52;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_53', EJECT ??

  PROCEDURE nfp$receive_parameter_53
    (    protocol: nft$parameter_00_values;
         command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR banner_routing_text: ost$string;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$receive_parameter_53                                         }
{                                                                             }
{ Purpose    To receive parameter 53, banner routing messages.                }
{                                                                             }
{ Description                                                                 }
{            This parameter specifies the physical location identifier        }
{            for the place that the public I/O station operator is to         }
{            send the output file hard copy.  This parameter is used by       }
{            the receiver when constructing the output file banner.           }
{                                                                             }
{ Input parameters                                                            }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{ Output parameters                                                           }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{ Algorithm                                                                   }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
?? EJECT ??
    status.normal := TRUE;
    banner_routing_text.value := received_value;
    banner_routing_text.size := STRLENGTH (received_value);
{}
  PROCEND nfp$receive_parameter_53;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_54', EJECT ??

  PROCEDURE nfp$receive_parameter_54
    (    protocol: nft$parameter_00_values;
         command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR user_banner_text: ost$string;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$receive_parameter_54                                         }
{                                                                             }
{ Purpose    To receive and process parameter 54, user banner message.        }
{                                                                             }
{ Description                                                                 }
{            This parameter contains the user provided text string that       }
{            the receiver is to employ when constructing the output file      }
{            banner.                                                          }
{                                                                             }
{ Input parameters                                                            }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{ Output parameters                                                           }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{ Algorithm                                                                   }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
?? EJECT ??
    status.normal := TRUE;
    user_banner_text.value := received_value;
    user_banner_text.size := STRLENGTH (received_value);
{}
  PROCEND nfp$receive_parameter_54;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_55', EJECT ??

  PROCEDURE nfp$receive_parameter_55
    (    protocol: nft$parameter_00_values;
         command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR buffer_list: nft$network_buffer_list;
     VAR installation_banner_message: ost$string;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$receive_parameter_55                                         }
{                                                                             }
{ Purpose    To receive and process parameter 55, installation banner message.}
{                                                                             }
{ Description                                                                 }
{            This parameter contains the installation provided text string    }
{            that the receiver is to employ when constructing the output      }
{            file banner.                                                     }
{                                                                             }
{ Input parameters                                                            }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{ Output parameters                                                           }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{ Algorithm                                                                   }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
?? EJECT ??
    status.normal := TRUE;
    installation_banner_message.value := received_value;
    installation_banner_message.size := STRLENGTH (received_value);
{}
  PROCEND nfp$receive_parameter_55;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_56', EJECT ??

  PROCEDURE nfp$receive_parameter_56
    (    protocol: nft$parameter_00_values;
         command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR reposition: ost$string;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$receive_parameter_56                                         }
{                                                                             }
{ Purpose    To receive and process parameter 56, reposition output file.     }
{                                                                             }
{ Description                                                                 }
{            This parameter contains the I/O station operator entered         }
{            output file repositioning command parameters to be used by       }
{            the sender to define the new file position.                      }
{                                                                             }
{ Input parameters                                                            }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{ Output parameters                                                           }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{ Algorithm                                                                   }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
?? EJECT ??
    status.normal := TRUE;
    reposition.value := received_value;
    reposition.size := STRLENGTH (received_value);
{}
  PROCEND nfp$receive_parameter_56;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_57', EJECT ??

  PROCEDURE nfp$receive_parameter_57
    (    protocol: nft$parameter_00_values;
         command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR current_pos: ost$string;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$receive_parameter_57                                         }
{                                                                             }
{ Purpose    To receive and process parameter 57, current file position.      }
{                                                                             }
{ Description                                                                 }
{            This parameter specifies the current file position byte and      }
{            record ordinal.  When this parameter is specified by the PR      }
{            command, this parameter contains the byte and record ordinal of  }
{            the last physical record transmitted to the output device.       }
{            When the data declaration parameter value is C8, the record      }
{            ordinal corresponds to the number of unit separator (US)         }
{            characters imbedded within the data sent or received.            }
{                                                                             }
{ Input parameters                                                            }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{ Output parameters                                                           }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{ Algorithm                                                                   }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
?? EJECT ??
    status.normal := TRUE;
    current_pos.value := received_value;
    current_pos.size := STRLENGTH (received_value);
{}
  PROCEND nfp$receive_parameter_57;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_58', EJECT ??

  PROCEDURE nfp$receive_parameter_58
    (    protocol: nft$parameter_00_values;
         command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR default_output_destination: ost$string;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$receive_parameter_58                                         }
{                                                                             }
{ Purpose    To receive and process parameter 58, default output file         }
{            destination.                                                     }
{                                                                             }
{ Description                                                                 }
{            This parameter specifies the identity of the default destination }
{            I/O station for output files disposed by the job being           }
{            transferred from an input batch device.                          }
{                                                                             }
{ Input parameters                                                            }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{ Output parameters                                                           }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{ Algorithm                                                                   }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
{                                                                             }
?? EJECT ??
    status.normal := TRUE;
    default_output_destination.value := received_value;
    default_output_destination.size := STRLENGTH (received_value);
{}
  PROCEND nfp$receive_parameter_58;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_59' , eject ??
  PROCEDURE nfp$receive_parameter_59
    (    received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
    VAR  vertical_print_density: jmt$vertical_print_density;
    VAR  status: ost$status);
{
{ Procedure  nfp$receive_parameter_59
{
{ Purpose    To receive protocol parameter 58, vertical print density.
{
{ Description
{            This routine converts a received vertical print density to
{            an ordinal.
{
{ Input parameters
{            Received_value:      Input vertical print density value
{            Qualifier:           A-A protocol parameter qualifier
{
{ Output parameters
{            Vertical_print_density:     Returned value
{            Status:                     Returned status
{ Algorithm
{            If parameter selected or modified, translate value
{
  VAR
      vertical_print_density_index: jmt$vertical_print_density,
      vpd_match: BOOLEAN;

  VAR
      nfv$p59_values: [XREF] nft$parameter_59_values;
{}
  CASE qualifier OF
  =nfc$select, nfc$modify=
   vpd_match := FALSE;
   /search_vpd_loop/
   FOR vertical_print_density_index := LOWERBOUND(nfv$p59_values) TO
                                       UPPERBOUND(nfv$p59_values) DO
     IF (received_value = nfv$p59_values[vertical_print_density_index]) THEN
       vpd_match := TRUE;
       EXIT /search_vpd_loop/;
     IFEND;
   FOREND;
   IF vpd_match THEN
     vertical_print_density := vertical_print_density_index;
   ELSE
     nfp$set_internal_error('Received bad P59 vpd', status);
   IFEND;
  =nfc$ignore=
   ;
  CASEND;
{}
  PROCEND nfp$receive_parameter_59;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$receive_parameter_60' , eject ??
  PROCEDURE nfp$receive_parameter_60
    (    received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
    VAR  vfu_load_procedure: nft$parameter_60_element;
    VAR  status: ost$status);
{
{ Procedure  nfp$receive_parameter_60
{
{ Purpose    To receive protocol parameter 60, vfu load procedure.
{
{ Description
{            This routine returns a vfu load procedure name.
{
{ Input parameters
{            Received_value:      VFU load procedure string
{            Qualifier:           A-A protocol parameter qualifier
{
{ Output parameters
{            Vfu_load_procedure:  Returned value
{            Status:              Return status
{
{ Algorithm
{            If param selected or modified, then set return value.
{
?? EJECT ??
CASE qualifier OF
=nfc$select, nfc$modify=
  vfu_load_procedure.size := STRLENGTH(received_value);
  vfu_load_procedure.value := received_value;
=nfc$ignore=
  ;
CASEND;
{}
  PROCEND nfp$receive_parameter_60;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$common_static_definitions', EJECT ??

  PROCEDURE nfp$common_static_definitions;


    VAR
      nfv$command_values: [STATIC, READ, XDCL, nfs$protocol_engine_static] nft$command_values :=
            [nfc$command_unknown, nfc$command_rft, nfc$command_rpos, nfc$command_rneg, nfc$command_go,
            nfc$command_stop, nfc$command_stopr, nfc$command_etp, nfc$command_etpr, nfc$command_fini];

    VAR
      nfv$param_qualifier_values: [STATIC, READ, XDCL, nfs$protocol_engine_static]
            nft$parameter_qualifier_values := [nfc$select_parameter, nfc$ignore_parameter,
            nfc$modify_parameter];

    VAR
      nfv$param_id_values: [STATIC, READ, XDCL, nfs$protocol_engine_static] nft$parameter_values :=
            [nfc$s_protocol_id, nfc$s_maximum_file_length, nfc$s_transfer_id, nfc$s_facilities,
            nfc$s_state_of_transfer, nfc$s_user_text_directive, nfc$s_file_length, nfc$s_operator_message,
            nfc$s_user_message, nfc$s_account_message, nfc$s_error_log_message, nfc$s_special_options,
            nfc$s_max_block_size, nfc$s_accounting_limit, nfc$s_file_name, nfc$s_file_disposition,
            nfc$s_acknowledgment_window, nfc$s_initial_checkmark, nfc$s_minimum_timeout_interval,
            nfc$s_mode_of_access, nfc$s_host_type, nfc$s_transfer_phase_attribute, nfc$s_source_lid,
            nfc$s_transfer_lid, nfc$s_job_name, nfc$s_physical_id, nfc$s_destination_host_type, nfc$s_echo,
            nfc$s_attribute_continued, nfc$s_data_declaration, nfc$s_system_routing_text,
            nfc$s_implicit_routing_text, nfc$s_user_file_name, nfc$s_banner_date_and_time,
            nfc$s_banner_routing_text, nfc$s_user_banner_text, nfc$s_installation_banner_text,
            nfc$s_reposition_output_params, nfc$s_current_file_position, nfc$s_output_file_destination,
            nfc$s_vertical_print_density, nfc$s_vfu_load_procedure,
            nfc$s_reserved_for_site_90, nfc$s_reserved_for_site_91, nfc$s_reserved_for_site_92,
            nfc$s_reserved_for_site_93, nfc$s_reserved_for_site_94, nfc$s_reserved_for_site_95,
            nfc$s_reserved_for_site_96, nfc$s_reserved_for_site_97, nfc$s_reserved_for_site_98,
            nfc$s_reserved_for_site_99];

    VAR
      nfv$param_id_numbers: [STATIC, READ, XDCL, nfs$protocol_engine_static] nft$parameter_numbers :=
            [nfc$i_protocol_id, nfc$i_maximum_file_length, nfc$i_transfer_id, nfc$i_facilities,
            nfc$i_state_of_transfer, nfc$i_user_text_directive, nfc$i_file_length, nfc$i_operator_message,
            nfc$i_user_message, nfc$i_account_message, nfc$i_error_log_message, nfc$i_special_options,
            nfc$i_max_block_size, nfc$i_accounting_limit, nfc$i_file_name, nfc$i_file_disposition,
            nfc$i_acknowledgment_window, nfc$i_initial_checkmark, nfc$i_minimum_timeout_interval,
            nfc$i_mode_of_access, nfc$i_host_type, nfc$i_transfer_phase_attribute, nfc$i_source_lid,
            nfc$i_transfer_lid, nfc$i_job_name, nfc$i_physical_id, nfc$i_destination_host_type, nfc$i_echo,
            nfc$i_attribute_continued, nfc$i_data_declaration, nfc$i_system_routing_text,
            nfc$i_implicit_routing_text, nfc$i_user_file_name, nfc$i_banner_date_and_time,
            nfc$i_banner_routing_text, nfc$i_user_banner_text, nfc$i_installation_banner_text,
            nfc$i_reposition_output_params, nfc$i_current_file_position, nfc$i_output_file_destination,
            nfc$i_vertical_print_density, nfc$i_vfu_load_procedure,
            nfc$i_reserved_for_site_90, nfc$i_reserved_for_site_91, nfc$i_reserved_for_site_92,
            nfc$i_reserved_for_site_93, nfc$i_reserved_for_site_94, nfc$i_reserved_for_site_95,
            nfc$i_reserved_for_site_96, nfc$i_reserved_for_site_97, nfc$i_reserved_for_site_98,
            nfc$i_reserved_for_site_99];

    VAR
      nfv$lcn_application_names: [STATIC, READ, XDCL] nft$lcn_application_names :=
            [nfc$lcn_appl_name_ptf, nfc$lcn_appl_name_ptfs, nfc$lcn_appl_name_qtf, nfc$lcn_appl_name_qtfs,
            nfc$lcn_appl_name_btf, nfc$lcn_appl_name_btfs];

    VAR
      nfv$nam_application_names: [STATIC, READ, XDCL] nft$nam_application_names :=
            [nfc$nam_appl_name_ptf, nfc$nam_appl_name_ptfs, nfc$nam_appl_name_qtf, nfc$nam_appl_name_qtfs,
            nfc$nam_appl_name_btf, nfc$nam_appl_name_btfs];

    VAR
      nfv$p00_values: [STATIC, READ, XDCL, nfs$protocol_engine_static] nft$p00_values :=
            [[nfc$p00_value_a101, nfc$p00_size_a101], [nfc$p00_value_a102, nfc$p00_size_a102],
            [nfc$p00_value_b101, nfc$p00_size_b101]];

    VAR
      nfv$p03_values: [STATIC, READ, XDCL, nfs$protocol_engine_static] nft$parameter_03_elements :=
            [nfc$p03_s_multiple_data_params, nfc$p03_s_collective_strings, nfc$p03_s_temporary_hold,
            nfc$p03_s_parameters_on_go, nfc$p03_s_later_resumption, nfc$p03_s_restart_permitted,
            nfc$p03_s_checkmark_ack_req, nfc$p03_s_send_data_ack_req, nfc$p03_s_data_compression];

    VAR
      nfv$p04_values: [READ, STATIC, XDCL, nfs$protocol_engine_static] nft$parameter_04_values :=
            [['000000', TRUE], ['000001', TRUE],

      ['011000', FALSE, nfe$unspecific_transfer, FALSE], ['011001', FALSE, nfe$transfer_rejected_message,
            FALSE], ['011002', FALSE, nfe$unacceptable_attributes, FALSE],
            ['011010', FALSE, nfe$unspecific_file_store, FALSE], ['011011', FALSE, nfe$file_not_found, FALSE],
            ['011012', FALSE, nfe$no_file_access, FALSE], ['011013', FALSE, nfe$wrong_file_type, FALSE],
            ['011014', FALSE, nfe$file_unavailable, FALSE], ['011015', FALSE, nfe$invalid_user, FALSE],
            ['011016', FALSE, nfe$invalid_password, FALSE], ['011017', FALSE, nfe$invalid_account, FALSE],
            ['011018', FALSE, nfe$invalid_account_pw, FALSE], ['011019', FALSE, nfe$no_money, FALSE],
            ['011020', FALSE, nfe$file_too_large, FALSE], ['011021', FALSE, nfe$wrong_device, FALSE],

      ['022000', TRUE], ['022001', FALSE, nfe$terminate_transfer_message, FALSE],
            ['022005', FALSE, nfe$accounting_limit_exceeded, FALSE],
            ['022006', FALSE, nfe$discard_input_file, FALSE],
            ['022007', FALSE, nfe$requeue_output_file, FALSE],
            ['022008', FALSE, nfe$requeue_at_current_priority, FALSE],
            ['022009', FALSE, nfe$requeue_not_eligible_file, FALSE],
            ['022010', FALSE, nfe$requeue_at_new_priority, FALSE],
            ['022011', FALSE, nfe$pm_message_time_out, FALSE],
            ['022012', FALSE, nfe$station_operator_terminate, FALSE],

      ['033000', FALSE, nfe$satisfactory_and_incomplete, FALSE],
            ['033001', FALSE, nfe$receiver_problem_retry, TRUE],
            ['033002', FALSE, nfe$receiver_problem_no_retry, FALSE],
            ['033003', FALSE, nfe$sender_problem_retry, TRUE],
            ['033004', FALSE, nfe$sender_problem_no_retry, FALSE],
            ['033005', FALSE, nfe$application_time_out, FALSE],
            ['033006', FALSE, nfe$protocol_anomaly, FALSE]];

    VAR
      nfv$parameter_17_values: [STATIC, READ, XDCL, nfs$protocol_engine_static] nft$parameter_17_values :=
            [ {nfc$p17_line_printer} 'LP',
              {nfc$p17_hollerith_card_punch} 'CP',
              {nfc$p17_binary_card_punch} 'PB',
              {nfc$p17_binary_checksummed_cp} 'P8',
              {nfc$p17_special_output} 'SP',
              {nfc$p17_input_return} 'IN',
              {nfc$input_no_return} 'IX',
              {nfc$generic_queue} 'GQ'];

    VAR
      nfv$p21_values: [STATIC, READ, XDCL, nfs$protocol_engine_static] nft$parameter_21_values :=
            [nfc$p21_prefix_value_give, nfc$p21_prefix_value_take, nfc$p21_prefix_value_null];

    VAR
      nfv$p21_options: [STATIC, READ, XDCL, nfs$protocol_engine_static] nft$parameter_21_specifications :=
            [nfc$p21_opt_non_specific, nfc$p21_opt_make_only, nfc$p21_opt_replace_only,
            nfc$p21_opt_replace_make, nfc$p21_opt_append_only, nfc$p21_opt_append_or_make,
            nfc$p21_opt_read_remove, nfc$p21_opt_read_only, nfc$p21_opt_destructive_read,
            nfc$p21_opt_make_only_too];
    VAR
      nfv$p22_values: [STATIC, READ, XDCL, nfs$protocol_engine_static] nft$parameter_22_strings :=
            [nfc$p22_value_unknown_host, nfc$p22_value_cyber_nosve, nfc$p22_value_cyber_nosve_qtf];

    VAR
      nfv$p30_value: [STATIC, READ, XDCL, nfs$protocol_engine_static] string (nfc$p30_required_space) :=
            nfc$p30_param_value;

    VAR
      nfv$parameter_31_values: [STATIC, READ, XDCL, nfs$protocol_engine_static] nft$parameter_31_definition :=
            [nfc$p31_unspecified_dd, nfc$p31_ascii_64, nfc$p31_ascii_extended, nfc$p31_host_dependent,
            nfc$p31_undefined_unstructured, nfc$p31_undefined_structured];

    VAR
      nfv$p59_values: [STATIC, READ, XDCL, nfs$protocol_engine_static] nft$parameter_59_values := ['XX', 'XX',
            '06', '07', '08', '09', '10', '11', '12' ];

  PROCEND nfp$common_static_definitions;
?? OLDTITLE ??
?? NEWTITLE := 'NAM/LCN interface routines' ??
?? NEWTITLE := '[XDCL] nfp$send_connect_request', EJECT ??

  PROCEDURE [XDCL] nfp$send_connect_request
    (    location: ost$name;
         server: nft$application_values;
         initiator: nft$application_values;
     VAR path: nft$network_connection;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_connect_request
    {
    { Purpose    This module is responsible for attempting to initiating the
    {            connect process to a client (server) application.  This
    {            function
    {            is complicated by the fact two access methods are (possibly)
    {            available, LCN and NAM.
    {
    { Description
    {           This routine requests connection to a remote host via both
    {           LCN and NAM.  LCN is asked first  because LCN is much, much
    {           faster.  If LCN can't do the trick (possibly because it is not
    {           there)  we try NAM. The trick here is to pass back a retryable
    {           error if one is discovered from either LCN or NAM.  Also note
    {           some clean up should be done, only logging errors to the
    {           dayfile if the access method is there.  Therefore, we need an
    {           error for NAM/LCN the implies access method not there.
    {
    { Input parameters
    {           location             : The name of the remote service
    {           server               : Ordinal of the remote server
    {                                  application
    {           initiator            : Ordinal of the local initiator
    {                                  application
    {
    { Output parameters
    {           path                 : Structure containing connect info
    {           status               : Return status value
    {
    { Algorithm
    {           nfp$send_lcn_connect_request
    {           if success then
    {             set access method type = lcn
    {           else
    {             nfp$send_nam_connect_request
    {             if success then
    {               set access method type = nam
    {             else
    {               return appropriate status
    {             ifend
    {           ifend
    {
?? EJECT ??

    VAR
      lcn_status: ost$status,
      nam_status: ost$status;

{}
    status.normal := TRUE;
    path.path_connected := FALSE;
    nfp$send_lcn_connect_request (server, initiator, location, path, lcn_status);
    IF lcn_status.normal THEN
      path.network_type := nfc$network_lcn;
      path.path_connected := TRUE;
      status.normal := TRUE;
    ELSE { Log message if unexpected result }
      IF (lcn_status.condition <> rfe$system_task_not_active) AND
            (lcn_status.condition <> rfe$destination_host_undefined) THEN
        pmp$log (' RHF - Error in RHFAM connection process', status);
        nfp$format_message_to_job_log (lcn_status);
      IFEND;
{}
{     Try to send a sensible error to initiating application }
{}
      IF (lcn_status.condition = rfe$destination_host_undefined) THEN
        osp$set_status_abnormal (nfc$status_id, nfe$service_not_found, location, status);
      ELSEIF (lcn_status.condition = rfe$remote_host_busy) OR
             (lcn_status.condition = rfe$server_busy) THEN
        osp$set_status_abnormal (nfc$status_id, nfe$recoverable_connect, location, status);
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$service_not_found, location, status);
      IFEND;
      nfp$send_nam_connect_request (path.network_file^, initiator, server, location, path.network_file_id,
            nam_status);
      IF nam_status.normal THEN
        path.network_type := nfc$network_nam;
        path.path_connected := TRUE;
        status.normal := TRUE;
      ELSE { ** cannot connect , log error if unexpected ** }
        IF (nam_status.condition <> nae$network_inactive) AND
              (nam_status.condition <> nfe$service_not_found) THEN
          pmp$log (' RHF - Error in NAM connection process', status);
          nfp$format_message_to_job_log (nam_status);
        IFEND;
{}
{     Try to send back sensible message to initiating application
{}
        IF (nam_status.condition = nae$connection_terminated) OR
              (nam_status.condition = nae$server_response_timeout) OR
              (nam_status.condition = nae$application_max_conn_limit) THEN
          osp$set_status_abnormal (nfc$status_id, nfe$recoverable_connect, location, status);
        ELSE
          IF status.condition <> nfe$recoverable_connect THEN
            osp$set_status_abnormal (nfc$status_id, nfe$service_not_found, location, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
{}
  PROCEND nfp$send_connect_request;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$read_network_block', EJECT ??

{ PURPOSE:
{   This procedure is used to synchronously read a pdu from the network.
{   This procedure is a 'bridge' to service procedures specific to NAM
{   and LCN. This procedure makes a network read request to the access
{   method which a path is connected to.
{
{ NOTE:
{   A lot of checking is done for odd NAM events.

  PROCEDURE nfp$read_network_block
    (    application: nft$application_values;
         path: amt$file_identifier;
         network: nft$network_type;
         timeout: nft$parameter_20_range;
         protocol_trace: boolean;
     VAR input_buffer: string ( * <= nfc$command_buffer_size);
     VAR input_length: nft$command_pdu_size;
     VAR status: ost$status);

    VAR
      activity_status: ost$activity_status,
      end_of_message: boolean,
      ignore_status: ost$status,
      lcn_data_area: rft$data_buffers,
      lcn_data_received: rft$bytes_transferred,
      nam_data_area: array [1 .. 1] of nat$data_fragment,
      network_event: nat$se_peer_operation,
      rhfam_event: rft$connection_events,
      rhfam_wait_time: rft$connection_timeout,
      synchronize_data: SEQ (REP 1 of cell);

    status.normal := TRUE;
    CASE network OF

    = nfc$network_nam =
      nap$await_data_available (path, { File id }
      timeout * nfc$milliseconds, { Time limit }
      0, { Expected time }
      status);
      IF NOT status.normal THEN
        IF status.condition = nae$no_data_available THEN
          osp$set_status_condition ( nfe$application_time_out,  status);
        IFEND;
        RETURN;
      IFEND;
      nam_data_area [1].address := ^input_buffer;
      nam_data_area [1].length := STRLENGTH (input_buffer);
      nap$se_receive_data (path, nam_data_area, osc$wait, network_event, activity_status, status);
      IF NOT status.normal THEN
        RETURN;
      ELSEIF (activity_status.complete) AND (NOT activity_status.status.normal) THEN
        status := activity_status.status;
        RETURN;
      ELSEIF (NOT activity_status.complete) THEN
        nfp$set_internal_error ('NFE$READ_NETWORK_BLOCK act_stat error', status);
        RETURN;
      IFEND;
      CASE network_event.kind OF
      = nac$se_send_data =

        IF (NOT network_event.end_of_message) OR (NOT network_event.qualified_data) THEN
          osp$set_status_condition ( nfe$protocol_anomaly,  status);
          RETURN;
        IFEND;
        input_length := network_event.data_length;

      = nac$se_synchronize =

        osp$set_status_condition ( nfe$protocol_anomaly,  status);
        RETURN;

      = nac$se_interrupt, nac$se_synchronize_confirm =

        osp$set_status_condition ( nfe$protocol_anomaly,  status);
        RETURN;

      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$illegal_event, 'NAP$SE_RECEIVE_DATA', status);
        RETURN;
      CASEND;

    = nfc$network_lcn =
      rhfam_event := rfc$input_available;
      rhfam_wait_time := nfc$p20_network_read_short_wait;
      rfp$await_rhfam_event (path, rhfam_event, rhfam_wait_time, status);
      IF NOT status.normal THEN
        IF status.condition = rfe$no_available_event THEN
          rhfam_wait_time := timeout * nfc$milliseconds -
                             nfc$p20_network_read_short_wait;
          IF rhfam_wait_time < 0 THEN
            nfp$set_internal_error('nfp$read_network_block minus timeout',
                    status);
             RETURN;
          ELSE
            rfp$await_rhfam_event (path, rhfam_event, rhfam_wait_time, status);
            IF NOT status.normal THEN
              IF status.condition = rfe$no_available_event THEN
                osp$set_status_condition ( nfe$application_time_out,  status);
              IFEND;
              RETURN;
            IFEND;
          IFEND;
        ELSE
          RETURN;
        IFEND;
      IFEND;
      PUSH lcn_data_area: [1 .. 1];
      lcn_data_area^ [1].address := ^input_buffer;
      lcn_data_area^ [1].length := STRLENGTH (input_buffer);
      rfp$receive_data (path, rfc$message_mode, lcn_data_area, osc$wait, activity_status, lcn_data_received,
            end_of_message, status);
      IF NOT status.normal THEN
        RETURN;
      ELSEIF (activity_status.complete) AND (NOT activity_status.status.normal) THEN
        status := activity_status.status;
        RETURN;
      ELSEIF (NOT activity_status.complete) THEN
        nfp$set_internal_error ('NFE$READ_NETWORK_BLOCK act_stat error', status);
        RETURN;
      ELSEIF (NOT end_of_message) THEN
        osp$set_status_condition ( nfe$protocol_anomaly,  status);
        RETURN;
      IFEND;
      input_length := lcn_data_received;
    ELSE
      nfp$set_internal_error ('nfp$read_network_block network case', status);
      pmp$exit (status);
    CASEND;

{     If trace commands

    IF protocol_trace AND status.normal THEN
      write_protocol_trace_to_log ('RECEIVE', application, input_buffer (1, input_length));
    IFEND;

  PROCEND nfp$read_network_block;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$write_network_block', EJECT ??

{ PURPOSE:
{   This procedure is used to send a pdu to the network.  This routine
{   acts as a 'bridge' to service routines specific to NAM and LCN.
{
{ NOTE:
{   This procedure does NOT terminate the path if the write fails.

  PROCEDURE nfp$write_network_block
    (    application: nft$application_values;
         path: amt$file_identifier;
         network_type: nft$network_type;
         output_buffer: string ( * <= nfc$command_buffer_size);
         protocol_trace: boolean;
     VAR status: ost$status);

    VAR
      activity_status: ost$activity_status,
      buffer_length: integer,
      end_of_message: boolean,
      error_text: string (osc$max_string_size),
      error_text_length: 1 .. osc$max_string_size,
      lcn_data_area: rft$data_buffers,
      lcn_data_sent: rft$bytes_transferred,
      nam_data_area: array [1 .. 1] of nat$data_fragment,
      string_length: integer,
      terminate_status: ost$status;

    status.normal := TRUE;
    buffer_length := STRLENGTH (output_buffer);
    IF protocol_trace THEN
      write_protocol_trace_to_log ('SEND', application, output_buffer (1, buffer_length));
    IFEND;

    CASE network_type OF

    = nfc$network_nam =
      nam_data_area [1].length := buffer_length;
      nam_data_area [1].address := ^output_buffer;
      nap$se_send_data (path, { Path
      nam_data_area, { Data fragments
      TRUE, { End of message
      TRUE, { Qualified data
      osc$wait, { Wait
      activity_status, status);
    = nfc$network_lcn =
      PUSH lcn_data_area: [1 .. 1];
      lcn_data_area^ [1].length := buffer_length;
      lcn_data_area^ [1].address := ^output_buffer;
      rfp$send_data (path, { Path name
      rfc$message_mode, { Mode
      lcn_data_area, { Data fragments
      TRUE, { Always EOM
      osc$wait, { Wait
      activity_status, lcn_data_sent, status);
      IF (activity_status.complete AND
         (lcn_data_sent <> lcn_data_area^ [1].length)) THEN
        error_text (1, 57) := 'NFP$WRITE_NETWORK_BLOCK, lcn send length error, expected ';
        STRINGREP (error_text (57, * ), string_length, lcn_data_area^ [1].length);
        error_text_length := 57 + string_length;
        error_text (error_text_length, 6) := ' sent ';
        error_text_length := error_text_length + 6;
        STRINGREP (error_text (error_text_length, * ), string_length, lcn_data_sent);
        error_text_length := error_text_length + string_length;
        nfp$set_internal_error (error_text (1, error_text_length), status);
        RETURN;
      IFEND;
    ELSE
      nfp$set_internal_error ('nfp$write_network_block network case', status);
      pmp$exit (status);
    CASEND;
    IF (activity_status.complete) AND (NOT activity_status.status.normal) THEN
      status := activity_status.status;
    IFEND;

  PROCEND nfp$write_network_block;
?? OLDTITLE ??
?? NEWTITLE := 'write_protocol_trace_to_log', EJECT ??

{ PURPOSE:
{   This procedure will write the protocol trace to the User's job_log.
{
{ NOTE:
{   This procedure will blank out any user supplied remote host directives for PTF.

  PROCEDURE write_protocol_trace_to_log
    (    transmission_type: string ( * <= 7);
         application: nft$application_values;
         trace_buffer: string ( * <= nfc$command_buffer_size));

    VAR
      ignore_status: ost$status,
      integer_string: ost$string,
      number_parameters: clt$integer,
      parameter_info_position: ost$non_negative_integers,
      parameter_length: clt$integer,
      parameter_offset: ost$non_negative_integers,
      trace_buffer_length: integer,
      trace_buffer_param_position: ost$non_negative_integers,
      trace_string: string (nfc$trace_commands_width),
      trace_string_position: integer;

    trace_buffer_length := STRLENGTH (trace_buffer);
    pmp$log ('************************************************************', ignore_status);
    trace_string := '** ';
    trace_string_position := 4;
    trace_string (trace_string_position, *) := transmission_type;
    trace_string_position := trace_string_position + 8;

{ determine the protocol command

    IF (trace_buffer (nfc$pdu_command_pos, nfc$pdu_command_len) = nfc$command_rft) THEN
          trace_string (trace_string_position, *) := 'RFT';
    ELSEIF (trace_buffer (nfc$pdu_command_pos, nfc$pdu_command_len) = nfc$command_rpos) THEN
          trace_string (trace_string_position, *) := 'RPOS';
    ELSEIF (trace_buffer (nfc$pdu_command_pos, nfc$pdu_command_len) = nfc$command_rneg) THEN
          trace_string (trace_string_position, *) := 'RNEG';
    ELSEIF (trace_buffer (nfc$pdu_command_pos, nfc$pdu_command_len) = nfc$command_go) THEN
          trace_string (trace_string_position, *) := 'GO';
    ELSEIF (trace_buffer (nfc$pdu_command_pos, nfc$pdu_command_len) = nfc$command_stop) THEN
          trace_string (trace_string_position, *) := 'STOP';
    ELSEIF (trace_buffer (nfc$pdu_command_pos, nfc$pdu_command_len) = nfc$command_stopr) THEN
          trace_string (trace_string_position, *) := 'STOPR';
    ELSEIF (trace_buffer (nfc$pdu_command_pos, nfc$pdu_command_len) = nfc$command_etp) THEN
          trace_string (trace_string_position, *) := 'ETP';
    ELSEIF (trace_buffer (nfc$pdu_command_pos, nfc$pdu_command_len) = nfc$command_etpr) THEN
          trace_string (trace_string_position, *) := 'ETPR';
    ELSEIF (trace_buffer (nfc$pdu_command_pos, nfc$pdu_command_len) = nfc$command_fini) THEN
          trace_string (trace_string_position, *) := 'FINI';
    ELSE
          trace_string (trace_string_position, nfc$pdu_command_len) := trace_buffer (nfc$pdu_command_pos,
                nfc$pdu_command_len);
    IFEND;

    trace_string_position := trace_string_position + 5;
    trace_string (trace_string_position, *) := ' COMMAND with ';
    trace_string_position := trace_string_position + 14;
    trace_string (trace_string_position, nfc$pdu_nparams_len) := trace_buffer (nfc$pdu_nparams_pos,
          nfc$pdu_nparams_len);
    trace_string_position := trace_string_position + nfc$pdu_nparams_len;
    trace_string (trace_string_position, *) := ' PARAMETERs & length ';
    trace_string_position := trace_string_position + 21;

    clp$convert_integer_to_string (trace_buffer_length, 10, FALSE, integer_string, ignore_status);
    trace_string (trace_string_position, 7) := integer_string.value;
    pmp$log (trace_string, ignore_status);

    clp$convert_string_to_integer (trace_buffer (nfc$pdu_nparams_pos, nfc$pdu_nparams_len),
          number_parameters, ignore_status);
    IF number_parameters.value > 0 THEN
      pmp$log ('**-no-q-len--value------------------------------------------', ignore_status);
    IFEND;

    trace_buffer_param_position := nfc$pdu_header_size;
    WHILE trace_buffer_param_position  < trace_buffer_length DO

{   determine the protocol parameter

      trace_string := '** ';
      trace_string_position := 4;
      trace_string (trace_string_position, nfc$num_param_id_digits) := trace_buffer
            ((trace_buffer_param_position + nfc$param_id_pos), nfc$num_param_id_digits);
      trace_string_position := trace_string_position + nfc$num_param_id_digits + 1;

{   determine how the protocol parameter is selected, ignored, or modified

      trace_string (trace_string_position, nfc$num_param_qual_digits) := trace_buffer
            ((trace_buffer_param_position + nfc$param_qual_pos), nfc$num_param_qual_digits);
      trace_string_position := trace_string_position + nfc$num_param_qual_digits + 1;

{   determine the length of the protocol parameter

      trace_string (trace_string_position, nfc$num_param_size_digits) := trace_buffer
            ((trace_buffer_param_position + nfc$param_size_pos), nfc$num_param_size_digits);
      trace_string_position := trace_string_position + nfc$num_param_size_digits;
      trace_string (trace_string_position, 2) := ' :';
      trace_string_position := trace_string_position + 2;

{   determine the protocol parameter length

      clp$convert_string_to_integer (trace_buffer ((trace_buffer_param_position + nfc$param_size_pos),
            nfc$num_param_size_digits), parameter_length, ignore_status);

      IF (trace_buffer ((trace_buffer_param_position + nfc$param_id_pos), nfc$num_param_id_digits)
            = nfc$s_user_text_directive) AND ((application = nfc$application_ptf) OR (application =
            nfc$application_ptfs)) THEN
        trace_string (trace_string_position, *) := 'SECURED PARAMETER WILL NOT BE DISPLAYED';
        pmp$log (trace_string, ignore_status);
      ELSE
        parameter_offset := 0;
        parameter_info_position := trace_buffer_param_position + nfc$param_header_size + 1;
        WHILE parameter_offset < parameter_length.value DO
          IF (parameter_length.value - parameter_offset) < (nfc$trace_commands_width - trace_string_position
                 + 1) THEN
            trace_string (trace_string_position, *) := trace_buffer ((parameter_info_position +
                 parameter_offset), (parameter_length.value - parameter_offset));
            parameter_offset := parameter_length.value;
          ELSE
            trace_string (trace_string_position, *) := trace_buffer ((parameter_info_position +
                  parameter_offset), (nfc$trace_commands_width - trace_string_position + 1));
            parameter_offset := parameter_offset + nfc$trace_commands_width - trace_string_position + 1;
          IFEND;
          pmp$log (trace_string, ignore_status);
          trace_string_position := 1;
        WHILEND;
      IFEND;

      trace_buffer_param_position := trace_buffer_param_position + nfc$param_header_size +
           parameter_length.value;
    WHILEND;
    pmp$log ('************************************************************', ignore_status);
    pmp$log ('  ', ignore_status);
  PROCEND write_protocol_trace_to_log;

?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_nam_connect_request', EJECT ??
{}

  PROCEDURE nfp$send_nam_connect_request
    (    network_file_name: fst$file_reference;
         initiator: nft$application_values;
         server: nft$application_values;
         remote_family: ost$name;
     VAR path: amt$file_identifier;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$send_nam_connect_request                                     }
{                                                                             }
{ Purpose This routine sends a connect request to a NAM node denoted          }
{            by a title.                                                      }
{                                                                             }
{ Description                                                                 }
{            This routine simply attempts to translate the remote title,      }
{            if successful it sends the                                       }
{            connect request.  If the connection is over NAM/VE and           }
{            to a system which does not support CDNA, the connection must     }
{            be gatewayed (not waylayed).  The mapping of a connect title     }
{            to whatever form of remote connect is done by CDCNET.  Here      }
{            is how it goes.  If user information is returned on the          }
{            title translation, we check the first byte (its VERSION) to see  }
{            if it implies gateway.  If so, the user data is mapped into      }
{            connection attributes.                                           }
{                                                                             }
{            User data version 1                Connect data version 1        }
{                                                                             }
{             --------------                     --------------               }
{     byte 1 | version = 1  |     |>     byte 1 | version = 2  |              }
{            |--------------|     | >            --------------               }
{     byte 2 | gateway type |  ------>   byte 2 |   key        |              }
{             --------------      | >    byte 3 |   field      |              }
{     byte 3 |    key       |     |>             --------------               }
{     byte 4 |    field     |                                                 }
{             --------------                                                  }
{                                                                             }
{                                                                             }
{ Input parameters                                                            }
{            Network_file_name           : Name of the network file           }
{            Initiator                   : Initiator application              }
{            Server                      : Server application                 }
{            Remote_family               : Unique part of remote title        }
{                                                                             }
{ Output parameters                                                           }
{            Path                        : File ID of successfull connect     }
{            Status                      : Output status -any from-           }
{                                               title translation             }
{                                               nap$request_connection        }
{                                                                             }
{ Algorithm                                                                   }
{            Nfp$translate_title                                              }
{            If success then                                                  }
{              Nap$request_connection                                         }
{            Ifend                                                            }
{                                                                             }
?? EJECT ??
{}


    TYPE
      gateway_connection_info = packed record
        version: 0 .. 255,
        key: string (2),
      recend;

{}
?? EJECT ??

    CONST
      nfc$nam_connect_non_cdna = 1,
      nfc$nam_connect_gateway = 2,
      nfc$connect_version_gateway = 1,
      nfc$minimum_size_gat_version_1 = 4,

      translation_wait_time = 0;

    VAR
      connection_attributes: ^nat$create_attributes,
      connection_protocol: nat$protocol,
      directory_data: ^nat$directory_data,
      directory_id: nat$directory_entry_identifier,
      gateway_connection_data: ^gateway_connection_info,
      get_title_status: ost$status,
      local_status: ost$status,
      network_address: nat$network_address,
      ready_index: integer,
      recurrent_search: boolean,
      search_id: nat$directory_search_identifier,
      title_pattern: ^nat$title_pattern,
      translation_attributes: ^nat$translation_attributes,
      user_info: ^string (nac$max_directory_data_length),
      wait_list: ^ost$i_wait_list;

    VAR
      nfv$nam_application_names: [XREF] nft$nam_application_names;

    BEGIN
      status.normal := TRUE;
      get_title_status.normal := TRUE;

      IF server <> nfc$application_ptfs THEN
        osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
              'Invalid application name given for NAM/VE connection_request.', status);
        RETURN;
      IFEND;

      PUSH title_pattern: [nfc$nam_title_prefix_length + osc$max_name_size];
      title_pattern^ (1, nfc$nam_title_prefix_length) := nfc$nam_ptfs_title_prefix;
      title_pattern^ (nfc$nam_title_prefix_length + 1, * ) := remote_family;

      recurrent_search := FALSE;
      nap$begin_directory_search (title_pattern^, nfc$nam_appl_name_ptf, recurrent_search, search_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      PUSH wait_list: [1 .. 2];
      wait_list^ [1].activity := nac$i_await_title_translation;
      wait_list^ [1].translation_request := search_id;
      wait_list^ [2].activity := osc$i_await_time;
      wait_list^ [2].milliseconds := 60 * nfc$milliseconds;

      osp$i_await_activity_completion (wait_list^, ready_index, status);
      IF NOT status.normal THEN
        nap$end_directory_search (search_id, local_status);
        RETURN;
      IFEND;

      IF wait_list^ [ready_index].activity = nac$i_await_title_translation THEN
        PUSH directory_data: [[REP nac$max_directory_data_length OF cell]];
        PUSH translation_attributes: [1 .. 1];
        translation_attributes^ [1].selector := nac$translation_data;
        translation_attributes^ [1].data := directory_data;

      /get_all_possible_titles/
        WHILE get_title_status.normal DO
          nap$get_title_translation (search_id, translation_wait_time, translation_attributes,
                network_address, get_title_status);
          IF get_title_status.normal THEN

{     Have a possible route, build call data }
            RESET directory_data;
            NEXT user_info IN directory_data;

            IF translation_attributes^ [1].data_length > 0 THEN
              IF $INTEGER (user_info^ (1, 1)) <> nfc$connect_version_gateway THEN
                osp$set_status_abnormal (nfc$status_id, nfe$incompatible_address_kind,
                      'user info version incorrect', status);
                nfp$format_message_to_job_log (status);
                RETURN;
              ELSE
                IF translation_attributes^ [1].data_length < nfc$minimum_size_gat_version_1 THEN
                  osp$set_status_abnormal (nfc$status_id, nfe$incompatible_address_kind,
                        'user info for version incorrect length', status);
                  nfp$format_message_to_job_log (status);
                  RETURN;
                ELSE
                  PUSH connection_attributes: [1 .. 1];
                  connection_attributes^ [1].kind := nac$connect_data;
                  PUSH connection_attributes^ [1].connect_data: [[REP 1 OF gateway_connection_info]];
                  RESET connection_attributes^ [1].connect_data;
                  NEXT gateway_connection_data IN connection_attributes^ [1].connect_data;
                  gateway_connection_data^.version := nfc$nam_connect_gateway;
                  gateway_connection_data^.key := user_info^ (3, 2);
                IFEND;
              IFEND;
            ELSE
              connection_attributes := NIL;
            IFEND;

            connection_protocol := nac$cdna_session;
            nap$request_connection (network_address, nfv$nam_application_names [initiator], network_file_name,
                  connection_protocol, connection_attributes, nfc$connection_timeout, status);
            IF status.normal THEN
              fsp$open_file (network_file_name, amc$record, NIL,
              { file attachment options }
              NIL, { default creation attributes }
              NIL, { mandated creation attributes }
              NIL, { attribute validation }
              NIL, { attribute override }
              path, status);
            IFEND;
            IF status.normal THEN
              EXIT /get_all_possible_titles/;
            IFEND;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$service_not_found, remote_family, status);
          IFEND;
        WHILEND /get_all_possible_titles/;
      ELSE {timer expired}
        osp$set_status_abnormal (nfc$status_id, nfe$service_not_found, remote_family, status);
      IFEND;

      nap$end_directory_search (search_id, local_status);

    END;

  PROCEND nfp$send_nam_connect_request;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$nam_request_connect', EJECT ??

  PROCEDURE [XDCL] nfp$nam_request_connect
    (    network_file_name: fst$file_reference;
         initiator: nft$application_values;
         server: nft$application_values;
         network_address: nat$network_address;
         application_version: 0..255;
         station_name: ost$name;
         device_name: ost$name;
     VAR path: amt$file_identifier;
     VAR status: ost$status);

    {
    { Procedure  nfp$send_nam_connect_request
    {
    { Purpose    This routine sends a connect request to a remote network
    {            address.  If the connect is accepted, the network file is
    {            opened for the requesting application.  NOTE:  This routine
    {            is XDCL'ed so that applications knowing the network address
    {            they want to connect to (i.e. BTF) can call here directly
    {            for connect purposes.
    {
    { Description
    {           This routine only works if the remote title has been correctly
    {           translated.  It simply calls nap$request_connection and
    {           fsp$open_file.
    {
    { Input parameters
    {           Network_file_name    : File name of path
    {           Initiator            : Initiator application value
    {           Server               : Server application value
    {           Network_address      : NAM network address
    {           Application_version  : Version of the application connect
    {           Station_name         : Name of the requested station
    {           Device_name          : Name of the requested device
    {
    { Output parameters
    {           Path                 : Returned file ID
    {           Status               : Return status
    {
    { Algorithm
    {           When connecting to BTFS, create connection data
    {           nap$request_connection
    {           If o.k., open network file
    {
?? EJECT ??
    TYPE
      btfs_connection_info = packed record
        application_version: 0 .. 255,
        station_name: ost$name,
        device_name: ost$name,
      recend;

    VAR
      connection_attributes: ^nat$create_attributes,
      connection_information: ^btfs_connection_info,
      connection_protocol: nat$protocol;

    VAR
      nfv$nam_application_names: [XREF] nft$nam_application_names;

    {}
    status.normal := TRUE;
    CASE initiator OF

    = nfc$application_btf =
      PUSH connection_attributes: [1..1];
      connection_attributes^[1].kind := nac$connect_data;
      PUSH connection_attributes^[1].connect_data: [[REP 1 of btfs_connection_info]];
      RESET connection_attributes^[1].connect_data;
      NEXT connection_information IN connection_attributes^[1].connect_data;
      connection_information^.application_version := application_version;
      connection_information^.station_name := station_name;
      connection_information^.device_name := device_name;

    ELSE
      nfp$set_internal_error ('nfp$nam_request_connect application case', status);
      pmp$exit (status);
    CASEND;

    connection_protocol := nac$cdna_session;
    nap$request_connection (network_address, nfv$nam_application_names [initiator], network_file_name,
          connection_protocol, connection_attributes, nfc$connection_timeout, status);
    IF status.normal THEN
      fsp$open_file (network_file_name, amc$record, NIL,
      { file attachment options }
      NIL, { default creation attributes }
      NIL, { mandated creation attributes }
      NIL, { attribute validation }
      NIL, { attribute override }
      path, status);
    IFEND;
    {}
  PROCEND nfp$nam_request_connect;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$terminate_path', EJECT ??

  PROCEDURE [XDCL] nfp$terminate_path
    (    application: nft$application_values;
         sign_off: boolean;
     VAR path: nft$network_connection;
     VAR status: ost$status);

    {
    { Procedure  nfp$terminate_path
    {
    { Purpose    This procedure is used to terminate the connection with the
    {            remote host.
    {
    { Description
    {            The routine method of terminating the connection is to
    {            close and return the network file.  If the connection was
    {            to LCN, the application is signed off.
    {
    { Input parameters
    {           Application    : The application type ( used for LCN sign off )
    {
    { Output parameters
    {            Status        : The close/return completion status.
    {            Path          : The network file data structure.
    {
    { Algorithm
    {            Close network file
    {            Return network file
    {            If LCN,
    {              Sign off application
    {              If error Then log to job log
    {
?? EJECT ??

    VAR
      ignore_status: ost$status;

    VAR
      nfv$lcn_application_names: [XREF] nft$lcn_application_names;

    {}
    status.normal := TRUE;
    fsp$close_file (path.network_file_id, status);
    amp$return (path.network_file^, status);

    CASE path.network_type OF

    = nfc$network_nam =
      ;
    = nfc$network_lcn =
      IF sign_off THEN
        rfp$application_sign_off (nfv$lcn_application_names [application], ignore_status);
      IFEND;
    ELSE
      nfp$set_internal_error ('nfp$terminate_path network case', status);
      RETURN;
    CASEND;
    path.path_connected := FALSE;
    {}
  PROCEND nfp$terminate_path;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$send_lcn_connect_request', EJECT ??

  PROCEDURE nfp$send_lcn_connect_request
    (    server: nft$application_values;
         initiator: nft$application_values;
         remote_family: ost$name;
     VAR path: nft$network_connection;
     VAR status: ost$status);

{                                                                             }
{ Procedure  nfp$send_lcn_connect_request                                     }
{                                                                             }
{ Purpose    Attempt to establish a connection to a remote host via RHFAM.    }
{                                                                             }
{ Description                                                                 }
{            This routine checks with RHFAM for all possible paths.           }
{            If one or more are possible, each is tried until one succeeds    }
{            or all have failed.  Note: Because this routine attempts         }
{            connects in the order presented by RHFAM, RHFAM should return    }
{            the least used (currently) path such that connection leveling    }
{            occurs.  If RHFAM does not do this, this routine should be       }
{            changed to pick the path attempt order randomly.                 }
{                                                                             }
{ Input parameters                                                            }
{            Server        : Name of Remote server application                }
{            Initiator     : Name of Local client application                 }
{            Remote_family : Name of the remote host                          }
{                                                                             }
{ Output parameters                                                           }
{            Path          : Record containing path data                      }
{            Status        : Return status any from                           }
{                             rfp$find_available_service                      }
{                             rfp$sign_on                                     }
{                             rfp$request_connection                          }
{                             rfp$await_server_respose                        }
{                             fsp$open_file                                   }
{                                                                             }
{ Algorithm                                                                   }
{            Find possible service paths (rfp$find_available_service)         }
{            If any Then                                                      }
{              For index := 1 to number of service paths do                   }
{                Request connection path(index)                               }
{                if success exit                                              }
{              forend                                                         }
{              If not success, return                                         }
{            Wait for server response                                         }
{            If not success, return                                           }
{            Open connection file                                             }
{                                                                             }
?? EJECT ??
{}

    VAR
      application_connects: rft$application_connections,
      destination_host: rft$host_identifier,
      host_identifiers: rft$destination_hosts,
      ignore_status: ost$status,
      index: integer,
      number_of_hosts: rft$number_of_hosts,
      rhfam_connection_attributes: array [1..1] of rft$get_attribute,
      server_response: rft$server_response,
      wait_time: rft$connection_timeout;

    VAR
      nfv$lcn_application_names: [XREF] nft$lcn_application_names;


{}
    status.normal := TRUE;
    destination_host.host_identifier_kind := rfc$logical_identifier;
    destination_host.logical_identifier := remote_family;
    rfp$find_available_service (nfv$lcn_application_names [server], destination_host, host_identifiers,
          number_of_hosts, status);
    IF (NOT status.normal) THEN
      RETURN;
    IFEND;
{}
{     Application sign on
{}
    application_connects := 1; {** PTF Client only needs 1 **}
    rfp$application_sign_on (nfv$lcn_application_names [initiator], rfc$client,
    { Application kind
    application_connects, { How many connects at a time
    status);
    IF (NOT status.normal) AND (status.condition <> rfe$already_signed_on) THEN
      RETURN;
    IFEND;
{}
{     Request connection }
{}

  /connect_loop/
    FOR index := 1 TO number_of_hosts DO
      rfp$request_connection (nfv$lcn_application_names [initiator], nfv$lcn_application_names [server],
            host_identifiers [index], { Target host }
            path.network_file^, { File name }
            NIL, { File attributes }
            status); { Return status }
      IF status.normal THEN
        EXIT /connect_loop/;
      ELSE
        amp$return (path.network_file^, ignore_status);
      IFEND;
    FOREND /connect_loop/;
    IF status.normal THEN

{ Get the CONNECTION_TIMEOUT value specified on the DEFINE_LOCAL_HOST command.

      rhfam_connection_attributes [1].key := rfc$connection_timeout;
      rfp$get_attributes (path.network_file^, rhfam_connection_attributes, status);
      IF status.normal THEN
        wait_time := rhfam_connection_attributes[1].connection_timeout;
      ELSE
        wait_time := nfc$connection_timeout;
      IFEND;

{}
{     Wait for connection completion
{}
      rfp$await_server_response (path.network_file^, wait_time, server_response, status);
      IF status.normal THEN
        fsp$open_file (path.network_file^, amc$record, NIL,
        { file attachment options
        NIL, { default creation attributes
        NIL, { mandated creation attributes
        NIL, { attribute validation
        NIL, { attribute override
        path.network_file_id, { returned file id
        status);
        IF NOT status.normal THEN
          amp$return (path.network_file^, ignore_status);
        IFEND;
      ELSE
        amp$return (path.network_file^, ignore_status);
      IFEND;
    IFEND;
{}
{     If this baby didn't connect up, sign off and try NAM
{}
    IF NOT status.normal THEN
      rfp$application_sign_off (nfv$lcn_application_names [initiator], ignore_status);
    IFEND;
{}
  PROCEND nfp$send_lcn_connect_request;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$get_server_asynch_event', EJECT ??

  PROCEDURE [XDCL] nfp$get_server_asynch_event
    (    application: nft$application_values;
     VAR path: nft$network_connection;
     VAR lcn_boot: boolean;
     VAR nam_boot: boolean;
     VAR task_queue: nft$task_queue;
     VAR status: ost$status);

{
{ Procedure  nfp$get_server_asynch_event
{
{ Purpose    This routine returns a network event.  The events it may
{            return include NAM connection available, LCN connection
{            available, and all access methods turned off.  This routine
{            also senses tasks which terminate, though these
{            events are never returned to the caller.  Rather, if a task
{            terminates, this routine continues to search for connect
{            requests.
{
{
{ Description
{            This routine senses access methods availability.  If one is
{            turned off, we will poll looking for it to return.
{            This procedure should not return error unless something
{            really hideous happens.  Received connections are returned to
{            the calling procedure for processing.
{
{ Input parameters
{            Application          : Application type ordinal
{
{ Output parameters
{            Lcn_boot             : Flag if server for LCN
{            Nam_boot             : Flag if server for NAM
{            Number_of_tasks      : Number current tasks
{            Task_queue           : List of current tasks
{            Status               : Return status
{                                                                             }
{ Input/output parameters                                                     }
{            Control_block        : Application control block                 }
{
{ Algorithm
{            Build wait list
{            Wait for event
{            Case event of
{            =task complete= Clean up task list
{            =LCN commect= Get LCN connection
{            =NAM commect= Get NAM connection
{            Casend
{
?? EJECT ??
{}

    CONST
      nfc$am_polling_time = 60000; { One minute }

    TYPE
      known_events = (lcn_connect, nam_connect, task_termination, poll_access_method);

{}

    VAR
      client_name: rft$application_name,
      connection_received: boolean,
      current_task: ^nft$task_list,
      current_time: integer,
      ignore_status: ost$status,
      index: integer,
      max_lcn_ptfs_connections: rft$application_connections,
      max_nam_ptfs_connections: nat$number_of_connections,
      number_of_events: integer,
      ready_index: integer,
      source_host_name: rft$host_identifier,
      task_index: integer,
      wait_action_list: ^array [ * ] of known_events,
      wait_list: ^ost$i_wait_list;

    VAR
      last_nam_am_check: [STATIC] integer := 0;

    VAR
      last_lcn_am_check: [STATIC] integer := 0;

    VAR
      nfv$lcn_application_names: [XREF] nft$lcn_application_names;

    VAR
      nfv$nam_application_names: [XREF] nft$nam_application_names;

{}
    status.normal := TRUE;
    connection_received := FALSE;
{}
{     First check last time we checked for access method availability.
{     This is done so if one AM is down, and connections are coming in
{     regularily on the other, the off one is checked.  If this were not
{     done and say RHFAM was down, and a connection came in every
{     nfc$am_poll_time-1, the timed wait would never go to AM check.
{
    pmp$get_microsecond_clock (current_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (NOT nam_boot) AND ((current_time - last_nam_am_check) > nfc$am_polling_time) THEN
      last_nam_am_check := current_time;
      max_nam_ptfs_connections := 0; {** Use all that are available **}
      nap$attach_server_application (nfv$nam_application_names [application], max_nam_ptfs_connections,
            status);
      IF status.normal OR ((NOT status.normal) AND (status.condition = nae$appl_already_attached)) THEN
        nam_boot := TRUE;
      IFEND;
    IFEND;

    IF (NOT lcn_boot) AND ((current_time - last_lcn_am_check) > nfc$am_polling_time) THEN
      last_lcn_am_check := current_time;
      max_lcn_ptfs_connections := 0; {** Use all that are available **}
      rfp$application_sign_on (nfv$lcn_application_names [application], rfc$server, max_lcn_ptfs_connections,
            status);
      IF status.normal OR ((NOT status.normal) AND (status.condition = rfe$already_signed_on)) THEN
        lcn_boot := TRUE;
      IFEND;
    IFEND;
{
{     MAIN loop, wait for incoming NAM or RHFAM connections, service task
{     termination, and poll for unavailable access methods.
{
    WHILE NOT connection_received DO
      number_of_events := 0;
      IF lcn_boot THEN
        number_of_events := number_of_events + 1;
      IFEND;
{}
      IF nam_boot THEN
        number_of_events := number_of_events + 1;
      IFEND;
{}
      IF ((NOT nam_boot) OR (NOT lcn_boot)) THEN
        number_of_events := number_of_events + 1;
      IFEND;
{}
      number_of_events := number_of_events + task_queue.number_of_tasks;
{}
      IF number_of_events < 1 THEN
        nfp$set_internal_error ('nfp$server_get_network_connect, no events', status);
        RETURN;
      IFEND;
      ALLOCATE wait_list: [1 .. number_of_events];
      ALLOCATE wait_action_list: [1 .. number_of_events];
      index := 1;
      IF lcn_boot THEN

        wait_list^ [index].activity := rfc$i_await_incoming_connect;
        wait_list^ [index].application_name := nfv$lcn_application_names [application];
        wait_action_list^ [index] := lcn_connect;
        index := index + 1;

      IFEND;
      IF nam_boot THEN
        wait_list^ [index].activity := nac$i_await_connection;
        wait_list^ [index].server := nfv$nam_application_names [application];
        wait_action_list^ [index] := nam_connect;
        index := index + 1;
      IFEND;
{}
      IF ((NOT nam_boot) OR (NOT lcn_boot)) THEN
        wait_list^ [index].activity := osc$i_await_time;
        wait_list^ [index].milliseconds := nfc$am_polling_time;
        wait_action_list^ [index] := poll_access_method;
        index := index + 1;
      IFEND;

{}
      current_task := task_queue.head;
      FOR task_index := index TO (task_queue.number_of_tasks + index - 1) DO
        wait_list^ [task_index].activity := pmc$i_await_task_termination;
        wait_list^ [task_index].task_id := current_task^.task_id;
        wait_action_list^ [task_index] := task_termination;
        current_task := current_task^.forward_pointer;
      FOREND;
{}
      osp$i_await_activity_completion (wait_list^, ready_index, status);
      IF NOT status.normal THEN
        nfp$format_message_to_job_log (status);
        IF (ready_index < 1) OR (ready_index > number_of_events) THEN
{            Ready index not valid, take down both networks }
          rfp$application_sign_off (nfv$lcn_application_names [application], ignore_status);
          lcn_boot := FALSE;
          nap$detach_server_application (nfv$nam_application_names [application], ignore_status);
          nam_boot := FALSE;
        ELSE { Ready index valid }
          CASE wait_action_list^ [ready_index] OF
          = lcn_connect =
            rfp$application_sign_off (nfv$lcn_application_names [application], ignore_status);
            lcn_boot := FALSE;
          = nam_connect =
            nap$detach_server_application (nfv$nam_application_names [application], ignore_status);
            nam_boot := FALSE;
          ELSE { Wait on non-network event }
            RETURN;
          CASEND;
        IFEND;
      IFEND;
{}
      CASE wait_action_list^ [ready_index] OF
      = lcn_connect =
        rfp$acquire_connect_request (nfv$lcn_application_names [application], path.network_file^, NIL,
              nfc$connection_timeout, client_name, source_host_name, status);
        IF NOT status.normal THEN
          IF NOT (status.condition = rfe$connection_not_available) THEN
            lcn_boot := FALSE;
            rfp$application_sign_off (nfv$lcn_application_names [application], ignore_status);
            nfp$format_message_to_job_log (status);
          IFEND;
        ELSE
          rfp$accept_connect_request (path.network_file^, status);
          IF NOT status.normal THEN
            amp$return (path.network_file^, ignore_status);
          ELSE
            path.path_connected := TRUE;
            path.network_type := nfc$network_lcn;
            connection_received := TRUE;
          IFEND;
        IFEND;
      = nam_connect =
        nap$acquire_connection (nfv$nam_application_names [application], path.network_file^, NIL,
              nfc$connection_timeout, status);
        IF (NOT status.normal) THEN
          IF NOT ((status.condition = nae$no_connection_available) OR
                (status.condition = nae$max_connections_acquired)) THEN
            nam_boot := FALSE;
            nap$detach_server_application (nfv$nam_application_names [application], ignore_status);
          IFEND;
        ELSE
          nap$accept_connection (path.network_file^, status);
          IF NOT status.normal THEN
            amp$return (path.network_file^, ignore_status);
            IF status.condition <> nae$connection_terminated THEN
              nap$detach_server_application (nfv$nam_application_names [application], ignore_status);
              nam_boot := FALSE;
            IFEND;
          ELSE
            path.path_connected := TRUE;
            path.network_type := nfc$network_nam;
            connection_received := TRUE;
          IFEND;
        IFEND;

      = task_termination =
        nfp$dequeue_task (wait_list^ [ready_index].task_id, task_queue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      = poll_access_method =
        IF NOT nam_boot THEN
          nap$attach_server_application (nfv$nam_application_names [application], max_nam_ptfs_connections,
                status);
          IF status.normal OR ((NOT status.normal) AND (status.condition = nae$appl_already_attached)) THEN
            nam_boot := TRUE;
          IFEND;
        IFEND;
        IF NOT lcn_boot THEN
          max_lcn_ptfs_connections := 0; {** Use all that are available **}
          rfp$application_sign_on (nfv$lcn_application_names [application], rfc$server,
                max_lcn_ptfs_connections, status);
          IF status.normal OR ((NOT status.normal) AND (status.condition = rfe$already_signed_on)) THEN
            lcn_boot := TRUE;
          IFEND;
        IFEND;
      ELSE
        nfp$set_internal_error ('nfp$server_get_network_connect wait case', status);
        RETURN;
      CASEND;
      FREE wait_list;
      FREE wait_action_list;
    WHILEND;
{}
  PROCEND nfp$get_server_asynch_event;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$enqueue_task', EJECT ??

  PROCEDURE [XDCL] nfp$enqueue_task
    (    task_id: pmt$task_id;
         path: nft$network_connection;
     VAR task_queue: nft$task_queue);

{
{ Procedure nfp$enqueue_task
{
{ Purpose    This procedure places a task ID (with some network info) on a
{            list.
{
{ Description
{            The new task is lined at the end of the task list.
{
{ Input parameters
{            task_id              : ID of task to link
{            path                 : Network information
{
{ Output parameters
{            task_queue           : List head of task queue
{
{ Algorithm
{            Allocate new element
{            If no tasks on list then
{              put at head of list
{            else
{              place at tail of list
{            ifend
{
?? EJECT ??

    VAR
      new_element: ^nft$task_list,
      old_element: ^nft$task_list,
      status: ost$status;

{}
    ALLOCATE new_element;
    IF new_element = NIL THEN
      nfp$set_internal_error ('nfp$enqueue_task no vm', status);
      pmp$exit (status);
    IFEND;
    task_queue.number_of_tasks := task_queue.number_of_tasks + 1;
    new_element^.task_id := task_id;
    new_element^.path := path;
    new_element^.forward_pointer := NIL;
    IF task_queue.head = NIL THEN
      task_queue.head := new_element;
      task_queue.tail := new_element;
      new_element^.backward_pointer := NIL;
    ELSE
      old_element := task_queue.tail;
      task_queue.tail^.forward_pointer := new_element;
      task_queue.tail := new_element;
      new_element^.backward_pointer := old_element;
    IFEND;
{}
  PROCEND nfp$enqueue_task;
?? OLDTITLE ??
?? NEWTITLE := 'nfp$dequeue_task', EJECT ??

  PROCEDURE nfp$dequeue_task
    (    task_id: pmt$task_id;
     VAR task_queue: nft$task_queue;
     VAR status: ost$status);

{
{ Procedure nfp$dequeue_task
{
{ Purpose    This procedure removes a task from
{            the task list.
{
{ Description
{            The task list is searched to find the element in question.
{            If its is not found, this is a major disaster.
{
{ Input parameters
{            task_id       : Identifier of the task in question
{
{ Output parameters
{            task_queue    : List of tasks
{
{ Algorithm
{            If task list is empty, error
{            for i = 1 to # of tasks
{              if task[i] is task in question then
{                dequeue task
{                update # of tasks
{              ifend
{            forend
{            if task was not found, error
{
?? EJECT ??

    VAR
      backward_link: ^nft$task_list,
      current_element: ^nft$task_list,
      done: boolean,
      forward_link: ^nft$task_list;

{}
    status.normal := TRUE;
    IF task_queue.head = NIL THEN
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'NFP$DEQUEUE_TASK, no task(s) on list',
            status);
      RETURN;
    ELSE
      current_element := task_queue.head;
      done := FALSE;

    /task_search_loop/
      WHILE NOT done DO
        IF current_element^.task_id = task_id THEN
          done := TRUE;
          IF current_element^.forward_pointer = NIL THEN
            IF current_element^.backward_pointer = NIL THEN { Single element }
              task_queue.head := NIL;
              task_queue.tail := NIL;
              EXIT /task_search_loop/;
            ELSE { Last element }
              backward_link := current_element^.backward_pointer;
              backward_link^.forward_pointer := NIL;
              task_queue.tail := backward_link;
              EXIT /task_search_loop/;
            IFEND;
          ELSE
            IF current_element^.backward_pointer = NIL THEN { First on list }
              forward_link := current_element^.forward_pointer;
              forward_link^.backward_pointer := NIL;
              task_queue.head := forward_link;
            ELSE { Middle of list }
              forward_link := current_element^.forward_pointer;
              backward_link := current_element^.backward_pointer;
              forward_link^.backward_pointer := backward_link;
              backward_link^.forward_pointer := forward_link;
            IFEND;
          IFEND;
        ELSE
          current_element := current_element^.forward_pointer;
          IF current_element = NIL THEN
            osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
                  'NFP$DEQUEUE_TASK, task not found on list', status);
            RETURN;
          IFEND;
        IFEND;
      WHILEND /task_search_loop/;
      task_queue.number_of_tasks := task_queue.number_of_tasks - 1;
      FREE current_element;
    IFEND;
{}
  PROCEND nfp$dequeue_task;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$initialize_control_block', EJECT ??

{ PURPOSE:
{   This procedure will initialize the control block structure for a given application.

  PROCEDURE [XDCL] nfp$initialize_control_block
    (    application: nft$application_values;
         data_declaration: nft$parameter_31_type;
         requested_facilities: nft$parameter_03_value_set;
         required_facilities: nft$parameter_03_value_set;
         allowed_facilities: nft$parameter_03_value_set;
         initial_protocol: nft$parameter_00_values;
         mode_of_access: nft$mode_of_access;
         parameter_rules: ^nft$parameter_rules_array;
     VAR control_block: nft$control_block);

*copy nfv$protocol_trace_info

    VAR
      locate_string: ost$string,
      protocol_trace: boolean,
      status: ost$status,
      string_variable: ^ ost$string,
      trace_variable: clt$variable_reference;

?? NEWTITLE := 'scan_trace_variable', EJECT ??
  FUNCTION scan_trace_variable
    (      locate_string: ost$string;
           search_string: ost$string): boolean;

    VAR
      found_correct_string: boolean,
      index: integer,
      ptr_translated_locate_string: ^ string(*),
      ptr_translated_search_string: ^ string(*);

    found_correct_string := FALSE;

    IF (search_string.size > 0) AND (locate_string.size > 0) AND
       (search_string.size >= locate_string.size) THEN

      ALLOCATE ptr_translated_locate_string: [locate_string.size];
      ALLOCATE ptr_translated_search_string: [search_string.size];

      IF (ptr_translated_locate_string <> NIL) AND (ptr_translated_search_string <> NIL) THEN

        #translate(osv$lower_to_upper, locate_string.value (1, locate_string.size),
           ptr_translated_locate_string^);
        #translate(osv$lower_to_upper, search_string.value (1, search_string.size),
           ptr_translated_search_string^);
        index := 1;

        REPEAT
          IF ptr_translated_search_string^ (index, locate_string.size) = ptr_translated_locate_string^ THEN
            IF (index+locate_string.size) <= search_string.size THEN
              IF ($INTEGER(ptr_translated_search_string^ ((index+locate_string.size), 1)) < $INTEGER('A'))
              OR ($INTEGER(ptr_translated_search_string^ ((index+locate_string.size), 1)) > $INTEGER('Z'))
              THEN
                found_correct_string := TRUE;
              IFEND;
            ELSEIF (index+locate_string.size-1) = search_string.size THEN
              found_correct_string := TRUE;
            IFEND;
          IFEND;
          index := index + 1;
        UNTIL found_correct_string OR (index > (search_string.size-locate_string.size+1));
      IFEND;

      IF ptr_translated_locate_string <> NIL THEN
        FREE ptr_translated_locate_string;
      IFEND;

      IF ptr_translated_search_string <> NIL THEN
        FREE ptr_translated_search_string;
      IFEND;
    IFEND;

    scan_trace_variable := found_correct_string;
  FUNCEND scan_trace_variable;
?? OLDTITLE, EJECT ??
    control_block.application := application;
    CASE application OF
    = nfc$application_ptf =
      control_block.application_server := nfc$application_ptfs;
    = nfc$application_qtf =
      control_block.application_server := nfc$application_qtfs;
    = nfc$application_btf =
      control_block.application_server := nfc$application_btfs;
    ELSE
      { Is server
    CASEND;
    pmp$get_job_names (control_block.user_job_name, control_block.system_job_name, status);
    IF NOT status.normal THEN
      pmp$exit (status);
    ELSE
      IF STRLENGTH(control_block.system_job_name) <=
         STRLENGTH(control_block.send_job_name.value) THEN
        control_block.send_job_name.size := STRLENGTH(control_block.system_job_name);
        control_block.send_job_name.value := control_block.system_job_name;
      IFEND;
    IFEND;

    clp$read_variable ('NFV$RHF_PROTOCOL_TRACE', trace_variable, status);
    IF status.normal AND (trace_variable.value.kind = clc$string_value) THEN
      string_variable := #LOC(trace_variable.value.string_value^);
      locate_string.value := 'ALL';
      locate_string.size := 3;
      protocol_trace := scan_trace_variable(locate_string, string_variable^);
      IF NOT protocol_trace THEN
        protocol_trace := scan_trace_variable(nfv$protocol_trace_info [application] .application_name,
          string_variable^);
        IF NOT protocol_trace THEN
          protocol_trace := scan_trace_variable(nfv$protocol_trace_info [application] .
            appl_client_or_server_name, string_variable^);
        IFEND;
      IFEND;
      control_block.protocol_trace := protocol_trace;
    ELSE
      control_block.protocol_trace := FALSE;
      status.normal := TRUE;
    IFEND;

    control_block.last_command_sent := nfc$unknown_command;
    control_block.last_command_received := nfc$unknown_command;
    control_block.last_auto_modify_ignore := $nft$parameter_set [];
    control_block.data_xfer_complete := FALSE;
    control_block.file_name := '';
    control_block.protocol_in_use := initial_protocol;
    control_block.maximum_file_size := nfc$p06_unlimited_value;
    control_block.file_size := nfc$p06_unlimited_value;
    control_block.send_facilities := requested_facilities;
    control_block.received_facilities := $nft$parameter_03_value_set [];
    control_block.required_facilities := required_facilities;
    control_block.allowed_facilities := allowed_facilities;
    control_block.transfer_facilities := requested_facilities;
    control_block.send_directives := NIL;
    control_block.received_directives.head := NIL;
    control_block.received_directives.tail := NIL;
    control_block.send_operator_messages := NIL;
    control_block.received_operator_messages.head := NIL;
    control_block.received_operator_messages.tail := NIL;
    control_block.send_user_messages := NIL;
    control_block.received_user_messages.head := NIL;
    control_block.received_user_messages.tail := NIL;
    control_block.send_account_messages := NIL;
    control_block.received_account_messages.head := NIL;
    control_block.received_account_messages.tail := NIL;
    control_block.send_errorlog_messages := NIL;
    control_block.received_errorlog_messages.head := NIL;
    control_block.received_errorlog_messages.tail := NIL;
    control_block.data_block_size := nfc$p12_max_value;
    control_block.accounting_limit := nfc$p13_default_value;
    control_block.acknowledgment_window := nfc$p18_default_value;
    control_block.initial_restart_checkmark := nfc$p19_default_value;
    control_block.time_out := nfc$p20_network_default;
    control_block.mode_of_access := mode_of_access;
    control_block.mode_of_access_option := nfc$p21_non_specific;
    control_block.local_host_type := nfc$p22_nos_ve;
    control_block.remote_host_type := nfc$p22_unknown_host;
    control_block.requested_host_type := nfc$p22_unknown_host;
    control_block.expected_host_type := nfc$p22_unknown_host;
    control_block.source_lid.size := nfc$p24_min_param_size;
    control_block.source_lid.value := '*';
    control_block.transfer_lid := '*';
    control_block.transfer_lid_length := nfc$p25_min_param_size;
    control_block.transfer_pid := '*';
    control_block.transfer_pid_length := nfc$p27_min_param_size;
    control_block.send_echo_text.first_text := NIL;
    control_block.send_echo_text.last_text := NIL;
    control_block.received_echo_text.first_text := NIL;
    control_block.received_echo_text.last_text := NIL;
    control_block.data_declaration := data_declaration;
    control_block.receive_job_name.size := 0;
    control_block.receive_file_name.size := 0;
    control_block.negotiate_protocol := FALSE;
    control_block.parameter_rules := parameter_rules;
    control_block.network_buffer_list.head := NIL;
    control_block.network_buffer_list.tail := NIL;
    control_block.path.network_file := NIL;
    control_block.path.path_connected := FALSE;
    control_block.path.application_sequence_number := 0;
    control_block.retry_count := 0;
    control_block.retry_limit := 0;
    control_block.retry_milliseconds := 0;
    control_block.state_of_transfer.normal := TRUE;
    control_block.remote_status.normal := TRUE;
    control_block.local_status.normal := TRUE;

    CASE application OF
    = nfc$application_ptf, nfc$application_ptfs =
      control_block.remote_ring.specified := FALSE;
      control_block.recovery_text := FALSE;
      control_block.transfer_file_size := 0;
      control_block.transfer_directives_length := 0;
      control_block.ptf_scl_directive.size := 0;
    = nfc$application_qtf, nfc$application_qtfs =
    = nfc$application_btf, nfc$application_btfs =
      control_block.user_file_name.size := 0;
      control_block.user_file_name.value := '';
      control_block.banner_date_and_time.size := 0;
      control_block.banner_date_and_time.value := '';
      control_block.banner_routing_text.size := 0;
      control_block.banner_routing_text.value := '';
      control_block.user_banner_message.size := 0;
      control_block.user_banner_message.value := '';
      control_block.installation_banner_message.size := 0;
      control_block.installation_banner_message.value := '';
      control_block.reposition_output_file.size := 0;
      control_block.reposition_output_file.value := '';
      control_block.current_file_position.size := 0;
      control_block.current_file_position.value := '';
      control_block.default_output_file_destination.size := 0;
      control_block.default_output_file_destination.value := '';
    ELSE
      nfp$set_internal_error ('nfp$initialize_control_block application case', status);
      pmp$exit (status);
    CASEND;

  PROCEND nfp$initialize_control_block;
?? OLDTITLE ??
MODEND nfm$rhf_protocol_engine;
*DECK DECK=NFM$RHF_PTF_QTF_PROCEDURES EXPAND=TRUE
?? NEWTITLE := 'NOS/VE FILE_TRANSFER : PTF QTF procedures' ??
?? RIGHT := 110 ??
MODULE nfm$rhf_ptf_qtf_procedures;

{     PURPOSE:
{            This module contains procedures which are used by PTF, PTFS,
{            QTF, and QTFS.  These procedures are not common to BTF.
{
{     DESIGN:
{            These modules may be independent of each other, they are
{            application specific in nature.

?? NEWTITLE := 'Global Declarations Referenced By This Module', ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_length
*copyc nfe$batch_transfer_services
*copyc nft$control_block
*copyc nft$transfer_modes
?? POP ??
*copyc jmp$emit_communication_stat
*copyc nfp$format_message_to_job_log
*copyc nfp$receive_file
*copyc nfp$send_file
*copyc nfp$set_abnormal_if_normal
*copyc nfp$terminate_path
*copyc osp$set_status_abnormal
*copyc pmp$compute_time_dif_in_seconds
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$generate_ptf_statistic', EJECT ??
*copyc nfh$generate_ptf_statistic

  PROCEDURE [XDCL] nfp$generate_ptf_statistic
    (    begin_connect_time: ost$date_time;
         end_connect_time: ost$date_time;
         file_size: amt$file_length,
         transfer_directives_length: ost$non_negative_integers;
         local_mainframe_system_name: string ( * <= nfc$p27_max_param_size);
         remote_mainframe_system_name: string ( * <= nfc$p25_max_param_size);
         application: nft$application_values;
         ptf_command: ost$string);

?? EJECT ??

    VAR
      connect_time_in_seconds: integer,
      local_status: ost$status,
      ptf_statistic: jmt$ptf_statistic_data,
      statistic_data: jmt$comm_acct_statistic_data;

    pmp$compute_time_dif_in_seconds (begin_connect_time, end_connect_time, connect_time_in_seconds,
          local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    CASE application OF
    = nfc$application_ptf =
      statistic_data.statistic_id := jmc$ca_request_pf_transfer;
      statistic_data.request_perm_file_transfer := ^ptf_statistic;
      ptf_statistic.requesting_mainframe_name := local_mainframe_system_name;
      ptf_statistic.target_mainframe_name := remote_mainframe_system_name;

    = nfc$application_ptfs =
      statistic_data.statistic_id := jmc$ca_target_pf_transfer;
      statistic_data.target_perm_file_transfer := ^ptf_statistic;
      ptf_statistic.requesting_mainframe_name := remote_mainframe_system_name;
      ptf_statistic.target_mainframe_name := local_mainframe_system_name;

    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
            'Case error in nfp$generate_ptf_statistic', local_status);
      nfp$format_message_to_job_log (local_status);
      RETURN;
    CASEND;

    ptf_statistic.connect_time := connect_time_in_seconds;
    ptf_statistic.file_size := file_size;
    ptf_statistic.bytes_transferred := transfer_directives_length;
    ptf_statistic.command_string := ptf_command;

    jmp$emit_communication_stat (statistic_data);

  PROCEND nfp$generate_ptf_statistic;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$transfer_file', EJECT ??
*copyc nfh$transfer_file

  PROCEDURE [XDCL] nfp$transfer_file
    (VAR control_block: nft$control_block;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      protocol_consistent: boolean,
      state_of_transfer: ost$status,
      transfer_mode: nft$transfer_modes;

    status.normal := TRUE;

    CASE control_block.data_declaration OF
    = nfc$p31_host_dependent_uh =
      transfer_mode := nfc$ve_to_ve_mode;
    = nfc$p31_unspecified, nfc$p31_ascii_c6, nfc$p31_ascii_c8 =
      transfer_mode := nfc$coded_data_mode;
    = nfc$p31_undefined_structured_us =
      transfer_mode := nfc$rhf_structured_mode;
    = nfc$p31_undef_unstructured_uu =
      transfer_mode := nfc$transparent_data_mode;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'nfp$transfer_file data type case',
            status);
      RETURN;
    CASEND;

    CASE control_block.application OF

    = nfc$application_ptf =

      CASE control_block.mode_of_access OF
      = nfc$give =
        nfp$receive_file (control_block.path.network_file_id, control_block.file_name,
              control_block.transfer_facilities, transfer_mode, control_block.data_block_size,
              control_block.time_out, control_block.protocol_in_use, control_block.path.network_type,
              control_block.remote_ring.value, control_block.protocol_trace,
              control_block.transfer_file_size, protocol_consistent, state_of_transfer, status);
      = nfc$take =
        nfp$send_file (control_block.path.network_file_id, control_block.file_name,
              control_block.transfer_facilities, transfer_mode, control_block.data_block_size,
              control_block.time_out, control_block.protocol_in_use, control_block.path.network_type,
              control_block.remote_ring.value, control_block.protocol_trace,
              control_block.transfer_file_size, protocol_consistent, state_of_transfer, status);
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
              'nfp$transfer_file client mode of access', status);
        RETURN;
      CASEND;

    = nfc$application_ptfs =

      CASE control_block.mode_of_access OF
      = nfc$give =
        nfp$send_file (control_block.path.network_file_id, control_block.file_name,
              control_block.transfer_facilities, transfer_mode, control_block.data_block_size,
              control_block.time_out, control_block.protocol_in_use, control_block.path.network_type,
              control_block.remote_ring.value, control_block.protocol_trace,
              control_block.transfer_file_size, protocol_consistent, state_of_transfer, status);
      = nfc$take =
        nfp$receive_file (control_block.path.network_file_id, control_block.file_name,
              control_block.transfer_facilities, transfer_mode, control_block.data_block_size,
              control_block.time_out, control_block.protocol_in_use, control_block.path.network_type,
              control_block.remote_ring.value, control_block.protocol_trace,
              control_block.transfer_file_size, protocol_consistent, state_of_transfer, status);
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
              'nfp$transfer_file server mode of access', status);
        RETURN;
      CASEND;

    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'nfp$transfer_file application case',
            status);
      RETURN;
    CASEND;

    IF NOT protocol_consistent THEN
      nfp$terminate_path (control_block.application, TRUE, control_block.path, local_status);
    IFEND;

    IF NOT status.normal THEN
      nfp$set_abnormal_if_normal (status, control_block.local_status);
    IFEND;
    IF (control_block.state_of_transfer.normal) AND (protocol_consistent) THEN
      control_block.state_of_transfer := state_of_transfer;
    IFEND;
{
  PROCEND nfp$transfer_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$count_directives_text', EJECT ??
*copyc nfh$count_directives_text

  FUNCTION [XDCL] nfp$count_directives_text
    (    directives_list_p: ^nft$directive_entry): ost$non_negative_integers;

    VAR
      current_directive_p: ^nft$directive_entry,
      text_count: ost$non_negative_integers;

    text_count := 0;
    current_directive_p := directives_list_p;
    WHILE (current_directive_p <> NIL) DO
      text_count := text_count + STRLENGTH (current_directive_p^.line);
      current_directive_p := current_directive_p^.link;
    WHILEND;
    nfp$count_directives_text := text_count;

  FUNCEND nfp$count_directives_text;
?? OLDTITLE ??
MODEND nfm$rhf_ptf_qtf_procedures;
*DECK DECK=NFM$RHF_RECEIVE_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NFM$RHF_RECEIVE_FILE' ??
MODULE nfm$rhf_receive_file;

{ PURPOSE:  This module contains procedures used to perform the data
{           transfer phase for files received via the RHF A-to-A file
{           transfer protocol.

?? NEWTITLE := 'GLOBAL DECLARATIONS REFERENCED', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$segment_pointer
*copyc fmt$file_label
*copyc fmt$static_label_header
*copyc ife$error_codes
*copyc nae$application_interfaces
*copyc nfd$transfer_declarations
*copyc nfe$batch_transfer_services
*copyc nfe$fts_condition_codes
*copyc nft$network_type
*copyc nft$parameter_00_values
*copyc nft$transfer_declarations
*copyc nft$transfer_modes
*copyc osd$virtual_address
*copyc pft$checksum
*copyc rfe$condition_codes
?? pop ??
*copyc amp$change_file_attributes
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc amp$put_partial
*copyc amp$return
*copyc amp$set_local_name_abnormal
*copyc amp$set_segment_eoi
*copyc amp$write_end_partition
*copyc fsp$close_file
*copyc fsp$copy_file
*copyc fsp$open_and_get_type_of_copy
*copyc fsp$open_file
*copyc mmp$set_access_selections
*copyc nap$await_data_available
*copyc nap$display_message
*copyc nap$se_receive_data
*copyc nap$se_send_data
*copyc nfp$ptf_format_message_to_out
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$establish_condition_handler
*copyc pmp$get_170_os_type
*copyc pmp$get_unique_name
*copyc pmp$log
*copyc rfp$await_rhfam_event
*copyc rfp$fetch
*copyc rfp$receive_data
*copyc rfp$send_data
*copyc rfp$store
*copyc srp$compute_label_checksum
*copyc srp$store_system_label

*copyc amv$nil_file_identifier
*copyc fsv$copf_input_file_attachment
*copyc fsv$copf_output_file_attachment
?? TITLE := 'GLOBAL DECLARATIONS DECLARED', EJECT ??

  TYPE
    command_buffer_1 = record
      command_id: string (2),
      parameter_count: string (2),
      parameter_id: string (2),
    recend,
    command_buffer_2 = record
      parameter_qualifier: string (1),
      parameter_length: string (3),
      condition_code: string (4),
    recend,
    lcn_command_area = SEQ (REP command_area_length + param_area_length of
          cell),
    level_seven_command = record
      command_area: SEQ (REP command_area_length of cell),
      param_area: SEQ (REP param_area_length of cell),
    recend,
    receiver_input_commands = (ss, ms, es),
    receiver_input_data_area = array [1 .. 2] of ^SEQ ( * ),
    receiver_states = (wait_start, restart_wait, sendr_pend, receive_data,
          end_ok_received, end_err_received, quit_ok_sent, quit_err_sent,
          wait_holdr, resume_pend, exit_receive);

  CONST
    command_area_length = 6,
    param_area_length = 64;

  VAR
    access_method: (nfc$am_nam, nfc$am_rhfam) := nfc$am_nam,
    active_receive_error_code: char,
    command: level_seven_command,
    command_area: SEQ (REP command_area_length of cell),
    copy_required: boolean,
    current_receive_state: receiver_states,
    label_buffer: ^SEQ (REP max_label_size of cell),
    lcn_command: lcn_command_area,
    param_area: SEQ (REP param_area_length of cell),
    processing_error: boolean,
    protocol_trace: boolean,
    queue_file: boolean := FALSE,
    receive_params: transfer_params,
    receive_transfer_progress: transfer_progress,
    receiver_file: amt$local_file_name,
    receiver_file_id: amt$file_identifier,
    receiver_file_open: boolean,
    start_of_rhf_struct_record: boolean,
    transfer_file_size: amt$file_length,
    working_storage: ^SEQ ( * );
?? TITLE := '[XDCL] nfp$receive_file', EJECT ??
*copyc nfh$receive_file

  PROCEDURE [XDCL] nfp$receive_file
    (    connection_fid: amt$file_identifier;
         file_name: amt$local_file_name;
         facilities: nft$facility_group;
         transfer_mode: nft$transfer_modes;
         block_size: nft$block_size;
         min_timeout: nft$timeout;
         protocol_version: nft$parameter_00_values;
         network_type: nft$network_type;
         validation_ring: ost$ring;
         activate_protocol_trace: boolean;
     VAR file_size: amt$file_length;
     VAR protocol_state_consistent: boolean;
     VAR transfer_status: ost$status;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      local_status: ost$status,
      receive_condition_descriptor: ^pmt$established_handler,
      receive_conditions: [STATIC, READ] pmt$condition :=
            [pmc$condition_combination, [pmc$system_conditions,
            pmc$block_exit_processing, jmc$job_resource_condition,
            mmc$segment_access_condition, ifc$interactive_condition]],
      rhfam_attributes: ^rft$change_attributes,
      save_rhfam_attrs: ^rft$get_attributes;
?? NEWTITLE := '  receive_condition_handler', EJECT ??

{ PURPOSE:  This is the condition handler for nfp$receive_file.

    PROCEDURE receive_condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status,
        local_status: ost$status,
        os_type: ost$170_os_type;

      IF (condition.selector = ifc$interactive_condition) THEN
        IF ((condition.interactive_condition = ifc$pause_break) OR
              (condition.interactive_condition = ifc$job_reconnect)) THEN

          pmp$get_170_os_type (os_type, local_status);
          IF (NOT local_status.normal) OR (os_type = osc$ot7_dual_state_nos_be) THEN

{ NOS/BE allows only one asynch interrupt which is mapped to a NOS/VE pause break. Respond to the pause
{ break as if it were a terminate break.

            osp$set_status_condition (ife$terminate_break_received, local_status);
            process_receive_system_error(local_status, processing_error, receive_params, ignore_status);
          ELSE

{ Generate message indicating pause break is ignored.

            osp$set_status_abnormal (nfc$status_id, nfe$user_interrupt_ignored, '', local_status);
            nfp$ptf_format_message_to_out (local_status);
          IFEND;
          RETURN;

        ELSEIF (condition.interactive_condition = ifc$terminate_break) THEN
          osp$set_status_condition (ife$terminate_break_received, local_status);
          process_receive_system_error(local_status, processing_error, receive_params, ignore_status);
          RETURN;
        IFEND;
      IFEND;

      IF receiver_file_open THEN
        fsp$close_file (receiver_file_id, ignore_status);
      IFEND;
      IF copy_required THEN
        amp$return (receiver_file, ignore_status);
      IFEND;

      IF condition.selector = pmc$block_exit_processing THEN
        IF (NOT processing_error) AND (current_receive_state <> end_ok_received) AND
              (current_receive_state <> end_err_received) AND (current_receive_state <> quit_ok_sent) AND
              (current_receive_state <> quit_err_sent) AND (current_receive_state <> exit_receive) THEN

{ local_status is used to pass a NORMAL status to PROCESS_RECEIVE_SYSTEM_ERROR

          local_status.normal := TRUE;
          process_receive_system_error (local_status, processing_error, receive_params, ignore_status);
          receive_connection_event (connection_fid, block_size, TRUE, ignore_status);
          pmp$continue_to_cause (pmc$execute_standard_procedure, status);
        IFEND;
      ELSE
        protocol_state_consistent := FALSE;
        pmp$continue_to_cause (pmc$execute_standard_procedure, status);
      IFEND;

    PROCEND receive_condition_handler;
?? OLDTITLE, EJECT ??
{   BEGIN nfp$receive_file

    status.normal := TRUE;
    copy_required := FALSE;
    local_status.normal := TRUE;
    processing_error := FALSE;
    protocol_state_consistent := TRUE;
    receiver_file_open := FALSE;
    start_of_rhf_struct_record := TRUE;
    transfer_file_size := 0;
    #SPOIL (copy_required, receiver_file_open);

    protocol_trace := activate_protocol_trace;
    IF protocol_trace THEN
      CASE network_type OF
      = nfc$network_lcn =
        pmp$log ('**** NFM$RHF_RECEIVE_FILE: Network type is LCN.', status);
      = nfc$network_nam =
        pmp$log ('**** NFM$RHF_RECEIVE_FILE: Network type is NAM.', status);
      = nfc$unknown_network =
        pmp$log ('**** NFM$RHF_RECEIVE_FILE: Network type is UNKNOWN.', status);
      ELSE
      CASEND;

      CASE transfer_mode OF
      = nfc$ve_to_ve_mode =
        pmp$log ('**** NFM$RHF_RECEIVE_FILE: Transfer mode is VE to VE.', status);
      = nfc$coded_data_mode =
        pmp$log ('**** NFM$RHF_RECEIVE_FILE: Transfer mode is CODED.', status);
      = nfc$transparent_data_mode =
        pmp$log ('**** NFM$RHF_RECEIVE_FILE: Transfer mode is TRANSPARENT.', status);
      = nfc$rhf_structured_mode =
        pmp$log ('**** NFM$RHF_RECEIVE_FILE: Transfer mode is RHF STRUCTURED.', status);
      ELSE
      CASEND;
      status.normal := TRUE;
    IFEND;

    CASE network_type OF
    = nfc$network_lcn =
      access_method := nfc$am_rhfam;
      IF  (protocol_version = nfc$p00_a101)  OR
          (protocol_version = nfc$p00_a102)  THEN
        PUSH save_rhfam_attrs: [1 .. 4];
        save_rhfam_attrs^ [1].key := rfc$record_block_size;
        save_rhfam_attrs^ [2].key := rfc$incoming_record_abn;
        save_rhfam_attrs^ [3].key := rfc$data_transfer_timeout;
        save_rhfam_attrs^ [4].key := rfc$receive_record_terminator;
        rfp$fetch (connection_fid, save_rhfam_attrs^, status);
        IF  NOT status.normal  THEN
          RETURN; {----->
        IFEND;

        IF  block_size > rfc$max_block_size  THEN
          receive_params.block_size := rfc$max_block_size;
        ELSE
          receive_params.block_size := block_size;
        IFEND;

        PUSH rhfam_attributes: [1 .. 3];
        rhfam_attributes^ [1].key := rfc$record_block_size;
        rhfam_attributes^ [1].record_block_size := receive_params.block_size;
        rhfam_attributes^ [2].key := rfc$incoming_record_abn;
        rhfam_attributes^ [2].incoming_record_abn := 0;
        rhfam_attributes^ [3].key := rfc$data_transfer_timeout;
        rhfam_attributes^ [3].data_transfer_timeout := min_timeout * 1000;

        rfp$store (connection_fid, rhfam_attributes^, status);
        IF  NOT status.normal  THEN
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$application_protocol_error,
            '', status);
        RETURN; {----->
      IFEND;
    = nfc$network_nam =
      access_method := nfc$am_nam;
      receive_params.block_size := block_size;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'nfp$receive_file network case',
            status);
      RETURN; {----->
    CASEND;

    receive_params.connection_fid := connection_fid;
    receive_params.file_name := file_name;
    receive_params.facilities := facilities;
    receive_params.transfer_mode := transfer_mode;
    receive_params.min_timeout := min_timeout;
    receive_params.validation_ring := validation_ring;
    receive_params.status.normal := TRUE;
    receive_params.transfer_status.normal := TRUE;
    receive_transfer_progress.general_position := not_started;
    current_receive_state := wait_start;
    #SPOIL (current_receive_state);

    ALLOCATE label_buffer;

    PUSH receive_condition_descriptor;
    pmp$establish_condition_handler (receive_conditions,
          ^receive_condition_handler, receive_condition_descriptor, status);
    IF NOT status.normal THEN
      pmp$log ('unable to allocate label buffer', local_status);
      osp$set_status_abnormal ('NF', nfe$receiver_problem_no_retry,
            '', local_status);
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;

    receive_connection_event (connection_fid, block_size, FALSE, status);
    IF NOT status.normal THEN
      set_status (receive_params, transfer_status, status);
      protocol_state_consistent := FALSE;
      RETURN; {----->
    IFEND;

    set_status (receive_params, transfer_status, status);

    file_size := transfer_file_size;

{   Reset LCN particulars.

    IF network_type = nfc$network_lcn THEN
      PUSH rhfam_attributes: [1 .. 4];
      rhfam_attributes^ [1].record_block_size :=
            save_rhfam_attrs^ [1].record_block_size;
      rhfam_attributes^ [2].incoming_record_abn :=
            save_rhfam_attrs^ [2].incoming_record_abn;
      rhfam_attributes^ [3].data_transfer_timeout :=
            save_rhfam_attrs^ [3].data_transfer_timeout;
      rhfam_attributes^ [4].receive_record_terminator :=
            save_rhfam_attrs^ [4].receive_record_terminator;
      rfp$store (connection_fid, rhfam_attributes^, ignore_status);
    IFEND;

  PROCEND nfp$receive_file;
?? TITLE := '[XDCL] nfp$receive_queue_file', EJECT ??
*copyc nfh$receive_queue_file

?? EJECT ??

  PROCEDURE [XDCL] nfp$receive_queue_file
    (    connection_fid: amt$file_identifier;
         queue_file_name: amt$local_file_name;
         facilities: nft$facility_group;
         transfer_mode:  nft$transfer_modes;
         block_size: nft$block_size;
         min_timeout: nft$timeout;
         protocol_version: nft$parameter_00_values;
         network_type: nft$network_type;
         activate_protocol_trace: boolean;
     VAR file_size: amt$file_length;
     VAR protocol_state_consistent: boolean;
     VAR transfer_status: ost$status;
     VAR status: ost$status);

    VAR
      dummy_pointer: ^cell,
      validation_ring: ost$ring;

    status.normal := TRUE;
    queue_file := TRUE;
    dummy_pointer := ^dummy_pointer;
    validation_ring := #ring(dummy_pointer);

    nfp$receive_file (connection_fid, queue_file_name, facilities,
          transfer_mode, block_size, min_timeout, protocol_version,
          network_type, validation_ring, activate_protocol_trace, file_size,
          protocol_state_consistent, transfer_status, status);

    queue_file := FALSE;

  PROCEND nfp$receive_queue_file;

?? TITLE := 'process_receive_protocol_error', EJECT ??

{ PURPOSE:  This procedure sets up an error QR command to the peer because of
{           a protocol anomaly.

  PROCEDURE process_receive_protocol_error
    (VAR processing_error: boolean;
     VAR receive_params: transfer_params;
     VAR status: ost$status);

    status.normal := TRUE;
    IF processing_error THEN
      osp$set_status_abnormal (nfc$status_id, nfe$application_protocol_error,
            '', status);
      RETURN; {----->
    IFEND;
    processing_error := TRUE;
    osp$set_status_abnormal (nfc$status_id, nfe$application_protocol_error, '',
          receive_params.status);
    osp$set_status_abnormal ('NF', nfe$protocol_anomaly,
          '', receive_params.transfer_status);

{   Send protocol command QR - quit transfer / error.

    send_qr_err (receive_detected_prot_err, status);

  PROCEND process_receive_protocol_error;
?? TITLE := 'process_receive_system_error', EJECT ??

{ PURPOSE:  This procedure sets up an error QR command to the peer because of
{           a system error.

  PROCEDURE process_receive_system_error
    (    local_status: ost$status;
     VAR processing_error: boolean;
     VAR receive_params: transfer_params;
     VAR status: ost$status);

    status.normal := TRUE;
    IF NOT local_status.normal THEN
      nap$display_message (local_status);
    IFEND;
    IF processing_error THEN
      IF local_status.normal THEN
        status.normal := TRUE;
      ELSE
        status := local_status;
      IFEND;
      RETURN; {----->
    IFEND;
    processing_error := TRUE;
    IF local_status.normal THEN
      receive_params.status.normal := TRUE;
    ELSE
      receive_params.status := local_status;
    IFEND;
    osp$set_status_abnormal ('NF', nfe$terminate_transfer_message,
          '', receive_params.transfer_status);

{   Send protocol command QR - quit transfer / error.

    send_qr_err (receive_err_no_retry, status);

  PROCEND process_receive_system_error;
?? TITLE := 'process_receiver_input', EJECT ??

{ PURPOSE:  This procedure processes receiver commands.

  PROCEDURE process_receiver_input
    (    peer_operation: nat$se_peer_operation;
     VAR data_area: receiver_input_data_area;
     VAR status: ost$status);

    CONST
      unique_char = 'A';

    VAR
      attachment_options: ^fst$attachment_options,
      byte_address: amt$file_byte_address,
      command: ^command_buffer_1,
      command_buffer: ^SEQ (REP command_area_length of cell),
      contains_data: boolean,
      control_info: fst$copy_control_information,
      convert_receiver_command: [STATIC, READ] array
            [receiver_input_commands] of string (2) :=
            [ss_command, ms_command, es_command],
      create_file: boolean,
      get_attributes_pointer: ^amt$get_attributes,
      id: receiver_input_commands,
      ignore_status: ost$status,
      input_fid: amt$file_identifier,
      lcn_command_buffer: ^lcn_command_area,
      local_file: boolean,
      local_status: ost$status,
      no_find: boolean,
      old_file: boolean,
      output_fid: amt$file_identifier,
      param: ^command_buffer_2,
      param_buffer: ^SEQ (REP param_area_length of cell),
      rhfam_attributes: ^rft$change_attributes,
      segment_cell: amt$segment_pointer,
      segment_pointer: amt$segment_pointer,
      trace_message: string(256),
      trace_size: integer,
      transfer_file_attributes: ^fst$file_cycle_attributes,
      unique_data: char,
      unique_fid: amt$file_identifier,
      unique_name: ost$name;

    local_status.normal := TRUE;
    status.normal := TRUE;
?? EJECT ??
{   Process data blocks

    IF NOT peer_operation.qualified_data THEN
      IF (current_receive_state = receive_data) OR
         (current_receive_state = wait_holdr) THEN

        IF (receive_transfer_progress.general_position = not_started) AND
           (receive_params.transfer_mode = nfc$ve_to_ve_mode) THEN

{         Process VE label

          IF queue_file THEN
            receive_queue_file_label (peer_operation, data_area, status);
          ELSE
            receive_file_label (peer_operation, data_area, status);
          IFEND;
        ELSEIF receive_transfer_progress.general_position <
              transfer_complete THEN

{         Process all other data blocks

          IF receive_params.transfer_mode <> nfc$rhf_structured_mode THEN
            receive_file_block (peer_operation, data_area, status);
          ELSE
            receive_rhf_file_block (peer_operation, data_area, status);
          IFEND;
        ELSE

 {        Error: Data has been received after the transfer was complete

          process_receive_protocol_error (processing_error, receive_params, status);
        IFEND;

      ELSEIF current_receive_state = quit_err_sent THEN

{          Ignore data received after a QR(err) has been sent

      ELSE

{       Data has been received at an unexpected time

        process_receive_protocol_error (processing_error, receive_params, status);
      IFEND;

      RETURN; {----->

    IFEND;
?? EJECT ??
{   Process command blocks

    IF  access_method = nfc$am_nam  THEN
      command_buffer := data_area [1];
      param_buffer := data_area [2];
      RESET param_buffer;
      NEXT param IN param_buffer;
      RESET command_buffer;
      NEXT command IN command_buffer;
    ELSE
      lcn_command_buffer := data_area [1];
      RESET lcn_command_buffer;
      NEXT command IN lcn_command_buffer;
      NEXT param IN lcn_command_buffer;
    IFEND;
    no_find := TRUE;

    IF protocol_trace THEN
      STRINGREP (trace_message, trace_size, '**** NFM$RHF_RECEIVE_FILE:',
            ' RCV Command: ', command^.command_id, ', ',
            command^.parameter_count, command^.parameter_id,
            param^.parameter_qualifier, param^.parameter_length,
            param^.condition_code);
      pmp$log (trace_message (1,trace_size), local_status);
      local_status.normal := TRUE;
    IFEND;

  /determine_id/
    FOR id := ss TO es DO
      IF command^.command_id = convert_receiver_command [id] THEN
        no_find := FALSE;
        EXIT /determine_id/; {----->
      IFEND;
    FOREND /determine_id/;
    IF no_find THEN
      process_receive_protocol_error (processing_error, receive_params, status);
      RETURN; {----->
    IFEND;

    CASE id OF
?? EJECT ??
{   SS command - Start of data

    = ss =
      PUSH get_attributes_pointer: [1 .. 1];
      get_attributes_pointer^ [1].key := amc$ring_attributes;
      amp$get_file_attributes (receive_params.file_name,
            get_attributes_pointer^, local_file, old_file, contains_data,
            local_status);
      IF NOT local_status.normal THEN
        process_receive_system_error (local_status, processing_error, receive_params, status);
        RETURN; {----->
      IFEND;
      IF (local_file OR old_file) THEN
        IF receive_params.validation_ring >
              get_attributes_pointer^ [1].ring_attributes.r1 THEN
          amp$set_local_name_abnormal (receive_params.file_name,
                ame$ring_validation_error, amc$open_req, '', local_status);
          process_receive_system_error (local_status, processing_error, receive_params, status);
          RETURN; {----->
        IFEND;
      IFEND;
      CASE receive_params.transfer_mode OF

      = nfc$ve_to_ve_mode =
        current_receive_state := sendr_pend;
        #SPOIL (current_receive_state);

{       Send protocol command SR - start of data acknowledge.

        send_sr (status);
        IF  access_method = nfc$am_nam  THEN
          data_area [2] := label_buffer;
        ELSE
          data_area [1] := label_buffer;
        IFEND;
        RETURN; {----->

      = nfc$coded_data_mode =
        create_file := TRUE;
        PUSH transfer_file_attributes: [1 .. 3];
        transfer_file_attributes^ [1].selector := fsc$record_type;
        transfer_file_attributes^ [1].record_type :=
              amc$trailing_char_delimited;
        transfer_file_attributes^ [2].selector := fsc$ring_attributes;
        transfer_file_attributes^ [2].ring_attributes.r1 :=
              receive_params.validation_ring;
        transfer_file_attributes^ [2].ring_attributes.r2 :=
              receive_params.validation_ring;
        transfer_file_attributes^ [2].ring_attributes.r3 :=
              receive_params.validation_ring;
        transfer_file_attributes^ [3].selector :=
              fsc$record_delimiting_character;
        transfer_file_attributes^ [3].record_delimiting_character :=
              $CHAR (1f(16)); { US character }
        IF local_file OR old_file THEN

          {  This is a kludge, which is required because file management does
          {  not allow inquiries about the t-type record delimiter.

          pmp$get_unique_name (unique_name, local_status);
          IF NOT local_status.normal THEN
            process_receive_system_error (local_status, processing_error, receive_params, status);
            RETURN; {----->
          IFEND;
          fsp$open_file (unique_name, amc$record, NIL,
                transfer_file_attributes, NIL, NIL, NIL, unique_fid,
                local_status);
          IF NOT local_status.normal THEN
            process_receive_system_error (local_status, processing_error, receive_params, status);
            RETURN; {----->
          IFEND;
          unique_data := unique_char;
          amp$put_next (unique_fid, ^unique_data, 1, byte_address,
                local_status);
          IF NOT local_status.normal THEN
            process_receive_system_error (local_status, processing_error, receive_params, status);
            RETURN; {----->
          IFEND;
          fsp$close_file (unique_fid, local_status);
          IF NOT local_status.normal THEN
            process_receive_system_error (local_status, processing_error, receive_params, status);
            RETURN; {----->
          IFEND;
          fsp$open_and_get_type_of_copy (unique_name,
                receive_params.file_name, ^fsv$copf_input_file_attachment, ^fsv$copf_output_file_attachment,
                NIL, NIL, NIL, input_fid, output_fid, control_info, local_status);
          create_file := FALSE;
          IF input_fid <> amv$nil_file_identifier THEN
            fsp$close_file (input_fid, ignore_status);
          IFEND;
          IF output_fid <> amv$nil_file_identifier THEN
            fsp$close_file (output_fid, ignore_status);
          IFEND;
          IF  NOT local_status.normal  THEN
            process_receive_system_error (local_status, processing_error, receive_params, status);
            RETURN; {----->
          IFEND;
          IF  control_info.type_of_copy = fsc$byte_move  THEN
            receiver_file := receive_params.file_name;
            copy_required := FALSE;
          ELSE
            receiver_file := unique_name;
            copy_required := TRUE;
          IFEND;
        ELSE
          receiver_file := receive_params.file_name;
          copy_required := FALSE;
        IFEND;
        #SPOIL (copy_required);

      = nfc$transparent_data_mode =
        create_file := TRUE;
        IF NOT (local_file OR old_file) THEN
          PUSH transfer_file_attributes: [1 .. 2];
          transfer_file_attributes^ [1].selector := fsc$record_type;
          transfer_file_attributes^ [1].record_type := amc$undefined;
          transfer_file_attributes^ [2].selector := fsc$ring_attributes;
          transfer_file_attributes^ [2].ring_attributes.r1 :=
                receive_params.validation_ring;
          transfer_file_attributes^ [2].ring_attributes.r2 :=
                receive_params.validation_ring;
          transfer_file_attributes^ [2].ring_attributes.r3 :=
                receive_params.validation_ring;
        ELSE
          transfer_file_attributes := NIL;
        IFEND;
        receiver_file := receive_params.file_name;
        copy_required := FALSE;
        #SPOIL (copy_required);

      = nfc$rhf_structured_mode =
        PUSH transfer_file_attributes: [1 .. 1];
        transfer_file_attributes^ [1].selector := fsc$record_type;
        transfer_file_attributes^ [1].record_type := amc$variable;
        receiver_file := receive_params.file_name;
        fsp$open_file (receiver_file, amc$record, NIL,
              transfer_file_attributes, NIL, NIL, NIL, receiver_file_id,
              local_status);
        IF NOT local_status.normal THEN
          process_receive_system_error (local_status, processing_error, receive_params, status);
          RETURN; {----->
        IFEND;
        receiver_file_open := TRUE;
        copy_required := FALSE;
        #SPOIL (receiver_file_open, copy_required);
        ALLOCATE working_storage: [[REP receive_params.block_size of cell]];
        IF working_storage = NIL THEN
          osp$set_status_abnormal ('NF', nfe$receiver_problem_no_retry,
                '', local_status);
          process_receive_system_error (local_status, processing_error, receive_params, status);
          RETURN; {----->
        IFEND;
        IF  access_method = nfc$am_nam  THEN
          data_area [2] := working_storage;
        ELSE
          data_area [1] := working_storage;
          PUSH rhfam_attributes: [1 .. 1];
          rhfam_attributes^ [1].key := rfc$receive_record_terminator;
          rhfam_attributes^ [1].receive_record_terminator := rfc$rm_eor;
          rfp$store (receive_params.connection_fid, rhfam_attributes^, status);
          IF NOT local_status.normal THEN
            process_receive_system_error (local_status, processing_error, receive_params, status);
            RETURN; {----->
          IFEND;
        IFEND;
        current_receive_state := sendr_pend;
        #SPOIL (current_receive_state);

{       Send protocol command SR - start of data acknowledge.

        send_sr (status);
        RETURN; {----->

      ELSE

        pmp$log ('process_receiver_input xfer mode CASE error', local_status);
        osp$set_status_abnormal ('NF', nfe$receiver_problem_no_retry,
              '', local_status);
        process_receive_system_error (local_status, processing_error, receive_params, status);
      CASEND;

      PUSH  attachment_options: [1 .. 2];
      attachment_options^ [1].selector := fsc$access_and_share_modes;
      attachment_options^ [1].access_modes.selector :=
            fsc$specific_access_modes;
      attachment_options^ [1].access_modes.value :=
            $fst$file_access_options [fsc$read, fsc$shorten, fsc$append];
      attachment_options^ [1].share_modes.selector := fsc$required_share_modes;
      attachment_options^ [2].selector := fsc$create_file;
      attachment_options^ [2].create_file := create_file;
      fsp$open_file (receiver_file, amc$segment, attachment_options,
            transfer_file_attributes, NIL, NIL, NIL, receiver_file_id,
            local_status);
      IF NOT local_status.normal THEN
        IF local_status.condition = pfe$usage_not_permitted THEN
          attachment_options^ [1].access_modes.value :=
                $fst$file_access_options [fsc$shorten, fsc$append];
          fsp$open_file (receiver_file, amc$segment, attachment_options,
                transfer_file_attributes, NIL, NIL, NIL, receiver_file_id,
                local_status);
          IF NOT local_status.normal THEN
            process_receive_system_error (local_status, processing_error, receive_params, status);
            RETURN; {----->
          IFEND;
        ELSE
          process_receive_system_error (local_status, processing_error, receive_params, status);
          RETURN; {----->
        IFEND;
      IFEND;
      receiver_file_open := TRUE;
      #SPOIL (receiver_file_open);
      amp$get_segment_pointer (receiver_file_id, amc$sequence_pointer,
            segment_pointer, local_status);
      IF NOT local_status.normal THEN
        process_receive_system_error (local_status, processing_error, receive_params, status);
        RETURN; {----->
      IFEND;
      amp$get_segment_pointer (receiver_file_id, amc$cell_pointer,
            segment_cell, local_status);
      IF NOT local_status.normal THEN
        process_receive_system_error (local_status, processing_error, receive_params, status);
        RETURN; {----->
      IFEND;
      mmp$set_access_selections (segment_cell.cell_pointer, mmc$as_sequential,
            local_status);
      IF NOT local_status.normal THEN
        process_receive_system_error (local_status, processing_error, receive_params, status);
        RETURN; {----->
      IFEND;
      receive_transfer_progress.file_byte_address :=
            segment_pointer.sequence_pointer;
      receive_transfer_progress.current_byte_address :=
            segment_pointer.sequence_pointer;
      RESET receive_transfer_progress.current_byte_address;
      IF  access_method = nfc$am_nam  THEN
        data_area [2] := receive_transfer_progress.current_byte_address;
      ELSE
        data_area [1] := receive_transfer_progress.current_byte_address;
      IFEND;
      current_receive_state := sendr_pend;
      #SPOIL (current_receive_state);

{     Send protocol command SR - start of data acknowledge.

      send_sr (status);
?? EJECT ??
{   ES command - End of data

    = es =
      IF param^.condition_code (3, 1) = ok_condition THEN

        IF current_receive_state = receive_data THEN
          current_receive_state := end_ok_received;
          #SPOIL (current_receive_state);

{ Get transfer file size

          PUSH get_attributes_pointer: [1 .. 1];
          get_attributes_pointer^ [1].key := amc$file_length;
          amp$get_file_attributes (receiver_file, get_attributes_pointer^,
                local_file, old_file, contains_data, local_status);
          IF NOT local_status.normal THEN
            process_receive_system_error (local_status, processing_error,
                receive_params, status);
            RETURN; {----->
          IFEND;
          transfer_file_size := get_attributes_pointer^ [1].file_length;

          IF copy_required THEN
            fsp$copy_file (receiver_file, receive_params.file_name, NIL, NIL,
                  NIL, local_status);
            IF NOT local_status.normal THEN
              process_receive_system_error (local_status, processing_error, receive_params, status);
              RETURN; {----->
            IFEND;
          IFEND;
          IF receiver_file_open THEN
            fsp$close_file (receiver_file_id, status);
            IF NOT local_status.normal THEN
              process_receive_system_error (local_status, processing_error, receive_params, status);
              RETURN; {----->
            IFEND;
            receiver_file_open := FALSE;
            #SPOIL (receiver_file_open);
          IFEND;

{         Send protocol command ER - end of data acknowledge / ok.

          send_er_ok (status);
        ELSEIF current_receive_state = quit_ok_sent THEN
          current_receive_state := end_ok_received;
          #SPOIL (current_receive_state);

{         Send protocol command ER - end of data acknowledge / ok.

          send_er_ok (status);
        ELSEIF current_receive_state = wait_start THEN
          process_receive_protocol_error (processing_error, receive_params, status);
        IFEND;

      ELSEIF param^.condition_code (3, 1) = hold_condition THEN

        process_receive_protocol_error (processing_error, receive_params, status);

      ELSEIF param^.condition_code (3, 1) = err_condition THEN

        IF current_receive_state = quit_err_sent THEN
          IF active_receive_error_code > param^.condition_code (4) THEN
            RETURN; {----->
          IFEND;
        ELSE
        osp$set_status_abnormal ('NF', nfe$transfer_rejected_message,
              '', receive_params.transfer_status);
        IFEND;
        active_receive_error_code := param^.condition_code (4);
        current_receive_state := end_err_received;
        #SPOIL (current_receive_state);

{       Send protocol command ER - end of data acknowledge / error.

        send_er_err (status);

      ELSE

        process_receive_protocol_error (processing_error, receive_params, status);

      IFEND;

    ELSE

{     Unknown command received

      process_receive_protocol_error (processing_error, receive_params, status);

    CASEND;

  PROCEND process_receiver_input;
?? TITLE := 'receive_connection_event', EJECT ??

{ PURPOSE:  This procedure receives data from the peer application.

  PROCEDURE receive_connection_event
    (    connection_fid: amt$file_identifier;
         block_size: nft$block_size;
         called_from_condition_handler: boolean;
     VAR status: ost$status);

    TYPE
      abort_buffer_type = record
        command_area: SEQ (REP command_area_length of cell),
        param_area_ptr: ^SEQ (*),
      recend;

    VAR
      abort_buffer: abort_buffer_type,
      abort_buffer_descriptor_nam: array [1 .. 1] of nat$data_fragment,
      activity_status: ost$activity_status,
      buffer_descriptor_nam: array [1 .. 2] of nat$data_fragment,
      buffer_descriptor_rhfam: array [1 .. 1] of rft$data_fragment,
      bytes_transferred: rft$bytes_transferred,
      data_area: receiver_input_data_area,
      ignore_status: ost$status,
      local_status: ost$status,
      peer_operation: nat$se_peer_operation,
      rhfam_xfer_mode: rft$transmission_modes,
      trace_data_block_size: integer,
      trace_message: string(256),
      trace_size: integer;

    status.normal := TRUE;
    local_status.normal := TRUE;

    IF access_method = nfc$am_rhfam THEN
      IF called_from_condition_handler THEN
        PUSH abort_buffer.param_area_ptr : [[REP (block_size * 10) of cell]];
        buffer_descriptor_rhfam [1].address := abort_buffer.param_area_ptr;
        buffer_descriptor_rhfam [1].length := block_size * 10;
        data_area [1] := abort_buffer.param_area_ptr;
      ELSE
        buffer_descriptor_rhfam [1].address := ^lcn_command;
        buffer_descriptor_rhfam [1].length := command_block_size;
        data_area [1] := ^lcn_command;
      IFEND;
    ELSE
      IF called_from_condition_handler THEN
        PUSH abort_buffer.param_area_ptr : [[REP (block_size + data_header_length + 1) of cell]];
        buffer_descriptor_nam [1].address := ^abort_buffer.command_area;
        buffer_descriptor_nam [1].length := command_area_length;
        buffer_descriptor_nam [2].address := abort_buffer.param_area_ptr;
        buffer_descriptor_nam [2].length := block_size + data_header_length + 1;
        data_area [1] := ^abort_buffer.command_area;
        data_area [2] := abort_buffer.param_area_ptr;
      ELSE
        buffer_descriptor_nam [1].address := ^command.command_area;
        buffer_descriptor_nam [1].length := command_area_length;
        buffer_descriptor_nam [2].address := ^command.param_area;
        buffer_descriptor_nam [2].length := param_area_length;
        data_area [1] := ^command.command_area;
        data_area [2] := ^command.param_area;
      IFEND;
    IFEND;

  /receive_event/
    WHILE current_receive_state <> exit_receive DO
      IF  access_method = nfc$am_nam  THEN
        nap$await_data_available (receive_params.connection_fid, initial_wait_time, 0, local_status);
        IF (NOT local_status.normal) AND (local_status.condition =  nae$multiple_waits_attempted) THEN

{ In a previous execution of this procedure, NAP$AWAIT_DATA was called and a condition handler took
{ control to process a condition before NAP$SE_RECEIVE_DATA was called. The condition handler then called
{ this routine and NAP$AWAIT_DATA_AVAILABLE was called again. Mask the abnormal status and continue.

          local_status.normal := called_from_condition_handler;
        IFEND;
        IF (NOT local_status.normal) AND (local_status.condition = nae$no_data_available)  THEN
          nap$await_data_available (receive_params.connection_fid, (receive_params.min_timeout * 1000 -
                 initial_wait_time), 0, local_status);
        IFEND;
      ELSE
        rfp$await_rhfam_event (receive_params.connection_fid, rfc$input_available, initial_wait_time,
              local_status);
        IF (NOT local_status.normal)  AND (local_status.condition = rfe$no_available_event)  THEN
          rfp$await_rhfam_event (receive_params.connection_fid, rfc$input_available,
                (receive_params.min_timeout * 1000 - initial_wait_time), local_status);
        IFEND;
      IFEND;
      IF NOT local_status.normal THEN
        IF (local_status.condition = nae$connection_terminated) OR
              (local_status.condition = rfe$connection_terminated)  THEN
          osp$set_status_abnormal ('NF', nfe$connection_closed_by_peer, '', status);
          receive_params.status := status;
          RETURN; {----->
        ELSEIF (local_status.condition = nae$no_data_available)  OR
              (local_status.condition = rfe$no_available_event)  THEN
          osp$set_status_abnormal ('NF', nfe$application_timeout, '', status);
          osp$set_status_abnormal ('NF', nfe$application_time_out, '', receive_params.transfer_status);
          receive_params.status := status;
          RETURN; {----->
        ELSE
          process_receive_system_error (local_status, processing_error, receive_params, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          CYCLE /receive_event/; {----->
        IFEND;
      IFEND;

      IF  access_method = nfc$am_nam  THEN
        nap$se_receive_data (connection_fid, buffer_descriptor_nam, osc$wait, peer_operation,
              activity_status, local_status);
      ELSE
        peer_operation.kind := nac$se_send_data;
        IF  (current_receive_state = receive_data) OR (current_receive_state = quit_err_sent) OR
              (current_receive_state = wait_holdr) THEN
          rhfam_xfer_mode := rfc$record_mode;
        ELSE
          rhfam_xfer_mode := rfc$message_mode;
        IFEND;
        peer_operation.qualified_data := rhfam_xfer_mode = rfc$message_mode;
        rfp$receive_data (connection_fid, rhfam_xfer_mode, ^buffer_descriptor_rhfam, osc$wait,
              activity_status, bytes_transferred, peer_operation.end_of_message, local_status);
        IF ((NOT local_status.normal) AND (local_status.condition = rfe$receive_mode_conflict)) OR
              (activity_status.complete AND (NOT activity_status.status.normal) AND
              (activity_status.status.condition = rfe$receive_mode_conflict)) THEN
          IF  (bytes_transferred = 0)  THEN

            {  If the block type does not match try the other mode.

            IF  rhfam_xfer_mode = rfc$message_mode  THEN
              rhfam_xfer_mode := rfc$record_mode;
            ELSE
              rhfam_xfer_mode := rfc$message_mode;
            IFEND;
            peer_operation.qualified_data := rhfam_xfer_mode = rfc$message_mode;
            rfp$receive_data (connection_fid, rhfam_xfer_mode, ^buffer_descriptor_rhfam, osc$wait,
                  activity_status, bytes_transferred, peer_operation.end_of_message, local_status);
            IF ((NOT local_status.normal) AND (local_status.condition = rfe$receive_mode_conflict)) OR
                  (activity_status.complete AND (NOT activity_status.status.normal) AND
                  (activity_status.status.condition = rfe$receive_mode_conflict)) AND
                  (bytes_transferred <> 0) THEN

              {  If data was received before the block change then ignore the error.

              local_status.normal := TRUE;
              activity_status.status.normal := TRUE;
            IFEND;
          ELSE

            {  If data was received before the block change then ignore the error.

            local_status.normal := TRUE;
            activity_status.status.normal := TRUE;
          IFEND;
        IFEND;
        peer_operation.data_length := bytes_transferred;
      IFEND;
      IF NOT local_status.normal THEN
        IF (local_status.condition = nae$connection_terminated) OR
              (local_status.condition = rfe$connection_terminated) THEN
          osp$set_status_abnormal ('NF', nfe$connection_closed_by_peer, '', status);
          receive_params.status := status;
          RETURN; {----->
        ELSEIF (local_status.condition = nae$data_transfer_timeout) OR
              (local_status. condition = rfe$transfer_timeout)  THEN
          osp$set_status_abnormal ('NF', nfe$access_method_timeout, '', status);
          receive_params.status := status;
          RETURN; {----->
        ELSEIF  local_status.condition <> nae$receive_outstanding  THEN
          process_receive_system_error (local_status, processing_error, receive_params, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          CYCLE /receive_event/; {----->
        IFEND;
      ELSEIF activity_status.complete AND (NOT activity_status.status.normal) THEN
        IF (activity_status.status.condition = nae$connection_terminated) OR
              (activity_status.status.condition = rfe$connection_terminated) THEN
          osp$set_status_abnormal ('NF', nfe$connection_closed_by_peer, '', status);
          receive_params.status := status;
          RETURN; {----->
        ELSEIF (activity_status.status.condition = nae$data_transfer_timeout) OR
              (activity_status.status. condition = rfe$transfer_timeout)  THEN
          osp$set_status_abnormal ('NF', nfe$access_method_timeout, '', status);
          receive_params.status := status;
          RETURN; {----->
        ELSEIF  activity_status.status.condition <> nae$receive_outstanding  THEN
          process_receive_system_error (activity_status.status, processing_error, receive_params, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          CYCLE /receive_event/; {----->
        IFEND;
      IFEND;

      IF protocol_trace AND (NOT peer_operation.qualified_data) THEN
        IF access_method = nfc$am_nam THEN
          trace_data_block_size := peer_operation.data_length - data_header_length;
        ELSE
          trace_data_block_size := peer_operation.data_length;
        IFEND;
        STRINGREP (trace_message, trace_size, '**** NFM$RHF_RECEIVE_FILE: RCV Data Block - Size:',
              trace_data_block_size);
        pmp$log (trace_message (1, trace_size), ignore_status);
      IFEND;

      IF peer_operation.kind <> nac$se_send_data THEN
        osp$set_status_abnormal (nfc$status_id, nfe$application_protocol_error, '', status);
        receive_params.status := status;
        RETURN; {----->
      IFEND;

      IF (access_method = nfc$am_nam) AND
            (peer_operation.data_length > (block_size + data_header_length)) THEN
        pmp$log ('Peer sent block larger than negotiated.', ignore_status);
        osp$set_status_abnormal (nfc$status_id, nfe$application_protocol_error,
              '', status);
        RETURN; {----->
      IFEND;

      process_receiver_input (peer_operation, data_area, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

      IF NOT called_from_condition_handler THEN
        IF  access_method = nfc$am_nam  THEN
          buffer_descriptor_nam [1].address := data_area [1];
          buffer_descriptor_nam [1].length := #SIZE (data_area [1]^);
          buffer_descriptor_nam [2].address := data_area [2];
          buffer_descriptor_nam [2].length := block_size + data_header_length + 1;
        ELSE
          buffer_descriptor_rhfam [1].address := data_area [1];
          buffer_descriptor_rhfam [1].length := #SIZE (data_area [1]^);
        IFEND;
      IFEND;

    WHILEND /receive_event/;
  PROCEND receive_connection_event;
?? TITLE := 'receive_file_block', EJECT ??

{ PURPOSE:  This procedure receives a file block.

  PROCEDURE receive_file_block
    (    peer_operation: nat$se_peer_operation;
     VAR data_area: receiver_input_data_area;
     VAR status: ost$status);

    VAR
      batch_header: ^batch_data_header,
      buffer_size: integer,
      data_length: integer,
      header_buffer:  ^SEQ ( * ),
      local_status: ost$status,
      segment_pointer: amt$segment_pointer;

    local_status.normal := TRUE;
    status.normal := TRUE;
    receive_transfer_progress.general_position := file_in_progress;
    IF  access_method = nfc$am_nam  THEN
      header_buffer  := data_area [1];
      RESET header_buffer;
      NEXT batch_header IN header_buffer;
      data_length := peer_operation.data_length - data_header_length;
    ELSE
      data_length := peer_operation.data_length;
    IFEND;
    receive_transfer_progress.current_byte_count :=
          receive_transfer_progress.current_byte_count + data_length;
    buffer_size := #SIZE (receive_transfer_progress.file_byte_address^) -
          receive_transfer_progress.current_byte_count;
    IF data_length > 0 THEN
      NEXT receive_transfer_progress.current_byte_address:
            [[REP data_length OF cell]] IN receive_transfer_progress.
            file_byte_address;
      NEXT receive_transfer_progress.current_byte_address:
            [[REP buffer_size OF cell]] IN receive_transfer_progress.
            file_byte_address;
      RESET receive_transfer_progress.file_byte_address TO
            receive_transfer_progress.current_byte_address;
    IFEND;
    IF  ((access_method = nfc$am_nam) AND
          (batch_header^.data_block_clarifier DIV nfc$dbc_eoi_bit MOD 2 = 1))
                OR
          ((access_method = nfc$am_rhfam) AND (peer_operation.end_of_message))
          THEN
      segment_pointer.kind := amc$sequence_pointer;
      segment_pointer.sequence_pointer := receive_transfer_progress.
            file_byte_address;
      amp$set_segment_eoi (receiver_file_id, segment_pointer, status);
      fsp$close_file (receiver_file_id, local_status);
      IF NOT local_status.normal THEN
        process_receive_system_error (local_status, processing_error, receive_params, status);
        RETURN; {----->
      IFEND;
      receiver_file_open := FALSE;
      #SPOIL (receiver_file_open);
      receive_transfer_progress.general_position := transfer_complete;
      receive_params.transfer_status.normal := TRUE;
      IF  access_method = nfc$am_nam  THEN
        data_area [2] := ^param_area;
      ELSE
        data_area [1] := ^lcn_command;
      IFEND;
    ELSE
      IF  access_method = nfc$am_nam  THEN
        data_area [2] := receive_transfer_progress.current_byte_address;
      ELSE
        data_area [1] := receive_transfer_progress.current_byte_address;
      IFEND;
    IFEND;
  PROCEND receive_file_block;
?? TITLE := 'receive_file_label', EJECT ??

{ PURPOSE:  This procedure receives the label of a NOS/VE file.
{
{ LOGIC: Create label_file
{        IF write NOT permitted on label_file THEN
{          Increase write bracket (1..Ring_Attribute_1)
{        IFEND
{        Store label in label_file
{        Get file attributes from label file
{
{        IF file_organization = indexed_sequential
{          Create ins_file using label_file attributes
{          Store label in ins_file
{          Delete label_file
{          label_file := ins_file
{        IFEND
{
{        fsp$open_and_get_type_of_copy of label_file
{        IF byte_move
{          receiver_file := receive_params.file_name
{          Delete label_file
{        ELSE
{          receiver_file := label_file
{          copy_required := TRUE
{        IFEND
{
{        Open receiver_file for segment access

  PROCEDURE receive_file_label
    (    peer_operation: nat$se_peer_operation;
     VAR data_area: receiver_input_data_area;
     VAR status: ost$status);

    CONST
      test_char = 'B';

    VAR
      attachment_options: ^fst$attachment_options,
      batch_header: ^batch_data_header,
      byte_address: amt$file_byte_address,
      check_data: char,
      computed_label_checksum: pft$checksum,
      contains_data: boolean,
      control_info: fst$copy_control_information,
      data_buffer: ^SEQ ( * ),
      data_length: integer,
      file_label: ^fmt$file_label,
      file_label_header: ^fmt$static_label_header,
      from_file_attributes: ^fst$file_cycle_attributes,
      get_attributes: ^amt$get_attributes,
      header_buffer: ^SEQ ( * ),
      input_close_status: ost$status,
      input_fid: amt$file_identifier,
      ins_file: amt$local_file_name,
      label_file: amt$local_file_name,
      label_length: 0 .. max_label_size,
      local_file: boolean,
      local_status: ost$status,
      old_file: boolean,
      open_position: ^amt$open_position,
      open_position_length: integer,
      output_attributes: ^fst$file_cycle_attributes,
      output_close_status: ost$status,
      output_fid: amt$file_identifier,
      override_attributes: ^fst$file_cycle_attributes,
      segment_cell: amt$segment_pointer,
      segment_pointer: amt$segment_pointer,
      stored_label_checksum: ^pft$checksum,
      unique_name: ost$name;

    local_status.normal := TRUE;
    status.normal := TRUE;
    receive_transfer_progress.general_position := label_in_progress;

    IF  access_method = nfc$am_nam  THEN
      header_buffer := data_area [1];
      RESET header_buffer;
      NEXT batch_header IN header_buffer;
      IF batch_header^.data_block_clarifier <> nfc$dbc_ve_label THEN
        process_receive_protocol_error (processing_error, receive_params, status);
        RETURN; {----->
      IFEND;
      data_buffer := data_area [2];
    ELSE
      data_buffer := data_area [1];
    IFEND;

    RESET data_buffer;
    NEXT open_position IN data_buffer;
    data_length := peer_operation.data_length;
    open_position_length := #SIZE (open_position^);

    IF  access_method = nfc$am_nam  THEN
      label_length := data_length - data_header_length - open_position_length;
    ELSE
      label_length := data_length - open_position_length;
    IFEND;
    NEXT file_label: [[REP label_length OF cell]] IN data_buffer;

    pmp$get_unique_name (unique_name, local_status);
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;
    label_file := unique_name;

    check_data := test_char;

{ Create a non-empty temporary file and stuff the received file label into it.
{ The temporary file will have the same file attributes as the original file
{ with the exception of the write bracket, which may be altered to include the
{ execution ring of this task.

    PUSH attachment_options: [1 .. 2];
    attachment_options^ [1].selector := fsc$open_position;
    attachment_options^ [1].open_position := open_position^;
    attachment_options^ [2].selector := fsc$access_and_share_modes;
    attachment_options^ [2].access_modes.selector := fsc$specific_access_modes;
    attachment_options^ [2].access_modes.value :=
          $fst$file_access_options [fsc$read, fsc$shorten, fsc$append];
    attachment_options^ [2].share_modes.selector := fsc$required_share_modes;
    fsp$open_file (label_file, amc$record, attachment_options, NIL, NIL, NIL,
          NIL, input_fid, local_status);
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;

    amp$put_next (input_fid, ^check_data, 1, byte_address, local_status);
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;

    fsp$close_file (input_fid, local_status);
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;

    RESET file_label;
    NEXT stored_label_checksum IN file_label;
    NEXT file_label_header IN file_label;

    IF file_label_header^.ring_attributes.r1 < receive_params.validation_ring THEN

{ Change the write bracket of the file to include the current execution ring of this
{ task. This will allow SRP$STORE_SYSTEM_LABEL to write the label file.

      file_label_header^.ring_attributes.r1 := receive_params.validation_ring;
      srp$compute_label_checksum(file_label_header, #size(file_label^) - #size(stored_label_checksum^),
         computed_label_checksum);
      stored_label_checksum^ := computed_label_checksum;
    IFEND;
    srp$store_system_label (label_file, file_label^, local_status);
    IF NOT local_status.normal THEN
      pmp$log('abnormal status from attempt to store the file label', status);
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;

    PUSH get_attributes: [1 .. 11];
    get_attributes^ [1].key := amc$ring_attributes;
    get_attributes^ [2].key := amc$file_organization;
    get_attributes^ [3].key := amc$data_padding;
    get_attributes^ [4].key := amc$embedded_key;
    get_attributes^ [5].key := amc$index_levels;
    get_attributes^ [6].key := amc$index_padding;
    get_attributes^ [7].key := amc$key_length;
    get_attributes^ [8].key := amc$key_position;
    get_attributes^ [9].key := amc$key_type;
    get_attributes^ [10].key := amc$max_record_length;
    get_attributes^ [11].key := amc$record_type;
    amp$get_file_attributes (label_file, get_attributes^, local_file, old_file,
          contains_data, local_status);
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;

{  Special processing for Indexed Sequential files.

    IF get_attributes^ [2].file_organization = amc$indexed_sequential THEN
      PUSH from_file_attributes: [1 .. 10];
      from_file_attributes^ [1].selector := fsc$file_organization;
      from_file_attributes^ [1].file_organization := amc$indexed_sequential;
      from_file_attributes^ [2].selector := fsc$data_padding;
      from_file_attributes^ [2].data_padding :=
            get_attributes^ [3].data_padding;
      from_file_attributes^ [3].selector := fsc$embedded_key;
      from_file_attributes^ [3].embedded_key :=
            get_attributes^ [4].embedded_key;
      from_file_attributes^ [4].selector := fsc$index_levels;
      from_file_attributes^ [4].index_levels :=
            get_attributes^ [5].index_levels;
      from_file_attributes^ [5].selector := fsc$index_padding;
      from_file_attributes^ [5].index_padding :=
            get_attributes^ [6].index_padding;
      from_file_attributes^ [6].selector := fsc$key_length;
      from_file_attributes^ [6].key_length := get_attributes^ [7].key_length;
      from_file_attributes^ [7].selector := fsc$key_position;
      from_file_attributes^ [7].key_position :=
            get_attributes^ [8].key_position;
      from_file_attributes^ [8].selector := fsc$key_type;
      from_file_attributes^ [8].key_type := get_attributes^ [9].key_type;
      from_file_attributes^ [9].selector := fsc$max_record_length;
      from_file_attributes^ [9].max_record_length :=
            get_attributes^ [10].max_record_length;
      from_file_attributes^ [10].selector := fsc$record_type;
      from_file_attributes^ [10].record_type :=
            get_attributes^ [11].record_type;

      pmp$get_unique_name (unique_name, local_status);
      IF NOT local_status.normal THEN
        process_receive_system_error (local_status, processing_error, receive_params, status);
        RETURN; {----->
      IFEND;
      ins_file := unique_name;

      fsp$open_file (ins_file, amc$record, attachment_options, NIL,
            from_file_attributes, NIL, NIL, input_fid, local_status);
      IF NOT local_status.normal THEN
        process_receive_system_error (local_status, processing_error, receive_params, status);
        RETURN; {----->
      IFEND;

      fsp$close_file (input_fid, local_status);
      IF NOT local_status.normal THEN
        process_receive_system_error (local_status, processing_error, receive_params, status);
        RETURN; {----->
      IFEND;

      srp$store_system_label (ins_file, file_label^, local_status);
      IF NOT local_status.normal THEN
        process_receive_system_error (local_status, processing_error, receive_params, status);
        RETURN; {----->
      IFEND;

      amp$return (label_file, local_status);
      IF NOT local_status.normal THEN
        process_receive_system_error (local_status, processing_error, receive_params, status);
        RETURN; {----->
      IFEND;
      label_file := ins_file;
    IFEND;  { ** End special processing for Indexed Sequential files.

    PUSH output_attributes: [1 .. 1];
    output_attributes^ [1].selector := fsc$ring_attributes;
    output_attributes^ [1].ring_attributes.r1 :=
          receive_params.validation_ring;
    output_attributes^ [1].ring_attributes.r2 :=
          receive_params.validation_ring;
    output_attributes^ [1].ring_attributes.r3 :=
          receive_params.validation_ring;

    fsp$open_and_get_type_of_copy (label_file, receive_params.file_name, ^fsv$copf_input_file_attachment,
          ^fsv$copf_output_file_attachment, NIL, NIL, output_attributes, input_fid, output_fid, control_info,
          local_status);
    IF input_fid <> amv$nil_file_identifier THEN
      fsp$close_file (input_fid, input_close_status);
    IFEND;
    IF output_fid <> amv$nil_file_identifier THEN
      fsp$close_file (output_fid, output_close_status);
    IFEND;
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;
    IF NOT input_close_status.normal THEN
      process_receive_system_error (input_close_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;
    IF NOT output_close_status.normal THEN
      process_receive_system_error (output_close_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;

    IF control_info.type_of_copy = fsc$byte_move THEN
      receiver_file := receive_params.file_name;
      copy_required := FALSE;
      #SPOIL (copy_required);
      amp$return (label_file, local_status);
      IF NOT local_status.normal THEN
        process_receive_system_error (local_status, processing_error, receive_params, status);
        RETURN; {----->
      IFEND;
    ELSE
      receiver_file := label_file;
      copy_required := TRUE;
      #SPOIL (copy_required);
    IFEND;

    attachment_options^ [1].selector := fsc$create_file;
    attachment_options^ [1].create_file := FALSE;
    PUSH override_attributes: [1 .. 3];
    override_attributes^ [1].selector := fsc$record_type;
    override_attributes^ [1].record_type := amc$undefined;
    override_attributes^ [2].selector := fsc$block_type;
    override_attributes^ [2].block_type := amc$system_specified;
    override_attributes^ [3].selector := fsc$file_organization;
    override_attributes^ [3].file_organization := amc$sequential;

    fsp$open_file (receiver_file, amc$segment, attachment_options, NIL, NIL,
          NIL, override_attributes, receiver_file_id, local_status);
    IF NOT local_status.normal THEN
      IF local_status.condition = pfe$usage_not_permitted THEN
        attachment_options^ [2].access_modes.value :=
              $fst$file_access_options [fsc$shorten, fsc$append];
        fsp$open_file (receiver_file, amc$segment, attachment_options, NIL,
              NIL, NIL, override_attributes, receiver_file_id, local_status);
        IF NOT local_status.normal THEN
          process_receive_system_error (local_status, processing_error, receive_params, status);
          RETURN; {----->
        IFEND;
      ELSE
        process_receive_system_error (local_status, processing_error, receive_params, status);
        RETURN; {----->
      IFEND;
    IFEND;
    receiver_file_open := TRUE;
    #SPOIL (receiver_file_open);

    amp$get_segment_pointer (receiver_file_id, amc$sequence_pointer,
          segment_pointer, local_status);
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;

    amp$get_segment_pointer (receiver_file_id, amc$cell_pointer, segment_cell,
          local_status);
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;

    mmp$set_access_selections (segment_cell.cell_pointer, mmc$as_sequential,
          local_status);
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;

    receive_transfer_progress.general_position := label_complete;
    receive_transfer_progress.file_byte_address :=
          segment_pointer.sequence_pointer;

    IF  access_method = nfc$am_nam  THEN
      data_area [2] := receive_transfer_progress.file_byte_address;
    ELSE
      data_area [1] := receive_transfer_progress.file_byte_address;
    IFEND;

    receive_transfer_progress.current_byte_count := 0;
    RESET receive_transfer_progress.file_byte_address;

  PROCEND  receive_file_label;
?? TITLE := 'receive_queue_file_label', EJECT ??

{ PURPOSE:  This procedure receives the label of a NOS/VE queue file.

  PROCEDURE receive_queue_file_label
    (    peer_operation: nat$se_peer_operation;
     VAR data_area: receiver_input_data_area;
     VAR status: ost$status);

    VAR
      attachment_options: ^fst$attachment_options,
      byte_address: amt$file_byte_address,
      change_ring_attributes: ^amt$file_attributes,
      data_buffer: ^SEQ ( * ),
      data_length: integer,
      file_label: ^SEQ ( * ),
      input_fid: amt$file_identifier,
      label_length: 0 .. max_label_size,
      local_status: ost$status,
      open_position: ^amt$open_position,
      open_position_length: integer,
      override_attributes: ^fst$file_cycle_attributes,
      segment_cell: amt$segment_pointer,
      segment_pointer: amt$segment_pointer;

    local_status.normal := TRUE;
    status.normal := TRUE;
    copy_required := FALSE;
    #SPOIL (copy_required);
    receiver_file := receive_params.file_name;
    receive_transfer_progress.general_position := label_in_progress;

    IF  access_method = nfc$am_nam  THEN
      data_buffer := data_area [2];
    ELSE
      data_buffer := data_area [1];
    IFEND;
    RESET data_buffer;
    NEXT open_position IN data_buffer;
    data_length := peer_operation.data_length;
    open_position_length := #SIZE (open_position^);
    IF  access_method = nfc$am_nam  THEN
      label_length := data_length - data_header_length - open_position_length;
    ELSE
      label_length := data_length - open_position_length;
    IFEND;
    NEXT file_label: [[REP label_length OF cell]] IN data_buffer;

    fsp$open_file (receiver_file, amc$record, NIL, NIL, NIL, NIL, NIL,
           input_fid, local_status);
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;
    fsp$close_file (input_fid, local_status);
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;

    srp$store_system_label (receiver_file, file_label^, local_status);
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;

    PUSH change_ring_attributes: [1 .. 1];
    change_ring_attributes^ [1].key := amc$ring_attributes;
    change_ring_attributes^ [1].ring_attributes.r1 :=
          receive_params.validation_ring;
    change_ring_attributes^ [1].ring_attributes.r2 :=
          receive_params.validation_ring;
    change_ring_attributes^ [1].ring_attributes.r3 :=
          receive_params.validation_ring;
    amp$change_file_attributes (receiver_file, change_ring_attributes,
          local_status);
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;

    PUSH attachment_options: [1 .. 1];
    attachment_options^ [1].selector := fsc$create_file;
    attachment_options^ [1].create_file := FALSE;
    PUSH override_attributes: [1 .. 3];
    override_attributes^ [1].selector := fsc$record_type;
    override_attributes^ [1].record_type := amc$undefined;
    override_attributes^ [2].selector := fsc$block_type;
    override_attributes^ [2].block_type := amc$system_specified;
    override_attributes^ [3].selector := fsc$file_organization;
    override_attributes^ [3].file_organization := amc$sequential;
    fsp$open_file (receiver_file, amc$segment, attachment_options, NIL, NIL,
          NIL, override_attributes, receiver_file_id, local_status);
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;
    receiver_file_open := TRUE;
    #SPOIL (receiver_file_open);

    amp$get_segment_pointer (receiver_file_id, amc$sequence_pointer,
          segment_pointer, local_status);
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;
    amp$get_segment_pointer (receiver_file_id, amc$cell_pointer, segment_cell,
          local_status);
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;
    mmp$set_access_selections (segment_cell.cell_pointer, mmc$as_sequential,
          local_status);
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;
    receive_transfer_progress.general_position := label_complete;
    receive_transfer_progress.file_byte_address :=
          segment_pointer.sequence_pointer;
    IF  access_method = nfc$am_nam  THEN
      data_area [2] := receive_transfer_progress.file_byte_address;
    ELSE
      data_area [1] := receive_transfer_progress.file_byte_address;
    IFEND;
    receive_transfer_progress.current_byte_count := 0;
    RESET receive_transfer_progress.file_byte_address;

  PROCEND  receive_queue_file_label;
?? TITLE := 'receive_rhf_file_block', EJECT ??

{ PURPOSE:  This procedure receives a file block to an RHF-structured file.
{
{ DESIGN:  Each file block received contains a header containing a data
{          block clarifier.  On NAM transfers this is part of the data,
{          on LCN transfers it is a connection file attribute.  This data
{          block clarifier contains bits indicating a NOS-type EOR (mapped
{          to a "V" record, NOS-type EOF (mapped to a partition mark), EOI
{          or no mark (meaning mid-EOR).

  PROCEDURE receive_rhf_file_block
    (    peer_operation: nat$se_peer_operation;
     VAR data_area: receiver_input_data_area;
     VAR status: ost$status);

   CONST
     dbc_pru_bit = 128,
     dbc_unused_bit = 16;

    VAR
      block_header: ^batch_data_header,
      buffer_size: integer,
      byte_address: amt$file_byte_address,
      data_length: integer,
      fetch_attributes: ^rft$get_attributes,
      header_buffer:  ^SEQ ( * ),
      local_status: ost$status,
      record_mark: (no_mark, eor_mark, eof_mark, eoi_mark),
      segment_pointer: amt$segment_pointer,
      terminate_option: amt$term_option;

    local_status.normal := TRUE;
    status.normal := TRUE;
    IF receive_transfer_progress.general_position <> file_in_progress THEN
      receive_transfer_progress.general_position := file_in_progress;
    IFEND;

    IF  access_method = nfc$am_nam  THEN
      header_buffer  := data_area [1];
      RESET header_buffer;
      NEXT block_header IN header_buffer;
      IF (block_header^.data_block_clarifier DIV nfc$dbc_eoi_bit MOD 2) = 1 THEN
        record_mark := eoi_mark;
      ELSE
        IF (block_header^.data_block_clarifier DIV dbc_pru_bit MOD 2) = 1 THEN
          block_header^.data_block_clarifier := block_header^.data_block_clarifier - dbc_pru_bit;
        IFEND;
        IF (block_header^.data_block_clarifier DIV dbc_unused_bit MOD 2) = 1 THEN
          block_header^.data_block_clarifier := block_header^.data_block_clarifier - dbc_unused_bit;
        IFEND;
        CASE block_header^.data_block_clarifier  OF
        = nfc$dbc_no_mark =
          record_mark := no_mark;
        = nfc$dbc_eor =
          record_mark := eor_mark;
        = nfc$dbc_eof =
          record_mark := eof_mark;
        ELSE
          pmp$log ('receive_rhf_file_block CASE error', local_status);
          osp$set_status_abnormal (nfc$status_id,
                nfe$receiver_problem_no_retry, '', local_status);
          process_receive_system_error (local_status, processing_error, receive_params, status);
          RETURN; {----->
        CASEND;
      IFEND;
      data_length := peer_operation.data_length - data_header_length;
    ELSE
      PUSH fetch_attributes: [1 .. 1];
      fetch_attributes^ [1].key := rfc$file_mark_received;
      rfp$fetch (receive_params.connection_fid, fetch_attributes^,
            local_status);
      IF NOT local_status.normal THEN
        process_receive_system_error (local_status, processing_error, receive_params, status);
        RETURN; {----->
      IFEND;
      IF peer_operation.end_of_message THEN
        CASE fetch_attributes^ [1].file_mark_received OF
        = rfc$rm_eor =
          record_mark := eor_mark;
        = rfc$rm_eof =
          record_mark := eof_mark;
        = rfc$rm_eoi =
          record_mark := eoi_mark;
        ELSE
          pmp$log ('receive_rhf_file_block mark 1 CASE error', local_status);
          osp$set_status_abnormal (nfc$status_id,
                nfe$receiver_problem_no_retry, '', local_status);
          process_receive_system_error (local_status, processing_error, receive_params, status);
          RETURN; {----->
        CASEND;
      ELSE
        record_mark := no_mark;
      IFEND;
      data_length := peer_operation.data_length;
    IFEND;

    local_status.normal := TRUE;
    CASE record_mark OF
    = no_mark =
      IF start_of_rhf_struct_record THEN
        terminate_option := amc$start;
      ELSE
        terminate_option := amc$continue;
      IFEND;
      amp$put_partial (receiver_file_id, working_storage, data_length,
            byte_address, terminate_option, local_status);
      start_of_rhf_struct_record := FALSE;
    = eor_mark =
      amp$put_partial (receiver_file_id, working_storage, data_length,
            byte_address, amc$terminate, local_status);
      start_of_rhf_struct_record := TRUE;
    = eof_mark =
      IF data_length > 0 THEN
        amp$put_partial (receiver_file_id, working_storage, data_length,
              byte_address, amc$terminate, local_status);
      IFEND;
      IF local_status.normal THEN
        amp$write_end_partition (receiver_file_id, local_status);
        start_of_rhf_struct_record := TRUE;
      IFEND;
    = eoi_mark =
      IF data_length > 0 THEN
        amp$put_partial (receiver_file_id, working_storage, data_length,
              byte_address, amc$terminate, local_status);
      IFEND;
      IF local_status.normal THEN
        fsp$close_file (receiver_file_id, local_status);
        IF local_status.normal THEN
          receiver_file_open := FALSE;
          #SPOIL (receiver_file_open);

          IF  access_method = nfc$am_nam  THEN
            data_area [2] := ^param_area;
          ELSE
            data_area [1] := ^lcn_command;
          IFEND;

          receive_transfer_progress.general_position := transfer_complete;
          receive_params.transfer_status.normal := TRUE;
        IFEND;
      IFEND;
    ELSE
      pmp$log ('receive_rhf_file_block mark 2 CASE error', local_status);
      osp$set_status_abnormal ('NF', nfe$receiver_problem_no_retry,
            '', local_status);
    CASEND;

    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;

  PROCEND receive_rhf_file_block;
?? TITLE := 'send_er_err', EJECT ??

{ PURPOSE:  This procedure sends an ER command with error.

  PROCEDURE send_er_err
    (VAR status: ost$status);

    VAR
      command_id: string (2),
      condition_code: string (4);

    status.normal := TRUE;
    command_id := er_command;
    condition_code := receive_err_retry;
    condition_code (4, 1) := active_receive_error_code;
    send_receiver_command (command_id, condition_code, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    current_receive_state := exit_receive;
    #SPOIL (current_receive_state);
  PROCEND send_er_err;
?? TITLE := 'send_er_ok', EJECT ??

{ PURPOSE:  This procedure sends an ER command with no error.

  PROCEDURE send_er_ok
    (VAR status: ost$status);

    VAR
      command_id: string (2),
      condition_code: string (4);

    status.normal := TRUE;
    command_id := er_command;
    condition_code := ok;
    send_receiver_command (command_id, condition_code, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    current_receive_state := exit_receive;
    #SPOIL (current_receive_state);
  PROCEND send_er_ok;
?? TITLE := 'send_qr_err', EJECT ??

{ PURPOSE:  This procedure sends a QR command with error.

  PROCEDURE send_qr_err
    (    condition_code: string (4);
     VAR status: ost$status);

    VAR
      command_id: string (2);

    status.normal := TRUE;
    command_id := qr_command;
    send_receiver_command (command_id, condition_code, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    active_receive_error_code := condition_code (4);
    current_receive_state := quit_err_sent;
    #SPOIL (current_receive_state);
  PROCEND send_qr_err;
?? TITLE := 'send_receiver_command', EJECT ??

{ PURPOSE:  This procedure sends a command.

  PROCEDURE send_receiver_command
    (    command_id: string (2);
         condition_code: string (4);
     VAR status: ost$status);

    CONST
      data_phase_parameter_count = '01',
      data_phase_parameter_prefix = '23S004';

    VAR
      activity_status: ost$activity_status,
      bytes_transferred: rft$bytes_transferred,
      command_block: data_phase_command,
      end_of_message: boolean,
      local_status: ost$status,
      message_content_nam: array [1 .. 1] of nat$data_fragment,
      message_content_rhfam: array [1 .. 1] of rft$data_fragment,
      qualified_data: boolean,
      trace_message: string(256),
      trace_size: integer;

    status.normal := TRUE;
    IF protocol_trace THEN
      STRINGREP (trace_message, trace_size, '**** NFM$RHF_RECEIVE_FILE:',
            ' SND Command: ', command_id, ', ',
            data_phase_parameter_count, data_phase_parameter_prefix,
            condition_code);
      pmp$log (trace_message (1,trace_size), local_status);
    IFEND;

    local_status.normal := TRUE;
    qualified_data := TRUE;
    end_of_message := TRUE;
    command_block.command_id := command_id;
    command_block.parameter_count := data_phase_parameter_count;
    command_block.parameter_prefix := data_phase_parameter_prefix;
    command_block.condition_code := condition_code;
    IF  access_method = nfc$am_nam  THEN
      message_content_nam [1].address := ^command_block;
      message_content_nam [1].length := command_block_size;
      nap$se_send_data (receive_params.connection_fid, message_content_nam, end_of_message, qualified_data,
            osc$wait, activity_status, local_status);
    ELSE
      message_content_rhfam [1].address := ^command_block;
      message_content_rhfam [1].length := command_block_size;
      rfp$send_data (receive_params.connection_fid, rfc$message_mode, ^message_content_rhfam, end_of_message,
            osc$wait, activity_status, bytes_transferred, local_status);
    IFEND;
    IF NOT local_status.normal THEN
      process_receive_system_error (local_status, processing_error, receive_params, status);
      RETURN; {----->
    ELSEIF activity_status.complete AND (NOT activity_status.status.normal) THEN
      process_receive_system_error (activity_status.status, processing_error, receive_params, status);
      RETURN; {----->
    IFEND;
  PROCEND send_receiver_command;
?? TITLE := 'send_sr', EJECT ??

{ PURPOSE:  This procedure sends an SR command.

  PROCEDURE send_sr
    (VAR status: ost$status);

    VAR
      command_id: string (2),
      condition_code: string (4);

    status.normal := TRUE;
    IF  nfc$ss_ack_required IN receive_params.facilities  THEN
      command_id := sr_command;
      condition_code := ok;
      send_receiver_command (command_id, condition_code, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    IFEND;
    current_receive_state := receive_data;
    #SPOIL (current_receive_state);
  PROCEND send_sr;
?? TITLE := '  set_status', EJECT ??

{ PURPOSE:  This procedure sets status in the different places the
{           caller expects to see it.

  PROCEDURE set_status
    (VAR receive_params: transfer_params;
     VAR transfer_status: ost$status;
     VAR proc_status: ost$status);

    IF receive_params.status.normal THEN
      proc_status.normal := TRUE;
    ELSE
      proc_status := receive_params.status;
    IFEND;

    IF receive_params.transfer_status.normal THEN
      transfer_status.normal := TRUE;
    ELSE
      transfer_status := receive_params.transfer_status;
    IFEND;

  PROCEND set_status;
?? OLDTITLE ??
MODEND nfm$rhf_receive_file;
*DECK DECK=NFM$RHF_SEND_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NFM$RHF_SEND_FILE' ??
MODULE nfm$rhf_send_file;

{ PURPOSE:  This module contains procedures used to perform the data
{           transfer phase for files sent via the RHF A-to-A file
{           transfer protocol.

?? NEWTITLE := 'GLOBAL DECLARATIONS REFERENCED', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc AMV$NIL_FILE_IDENTIFIER
*copyc AMT$SEGMENT_POINTER
*copyc IFE$ERROR_CODES
*copyc JMT$DESTINATION_USAGE
*copyc JMT$OUTPUT_FILE_POSITION
*copyc NAE$APPLICATION_INTERFACES
*copyc NFD$TRANSFER_DECLARATIONS
*copyc NFE$BATCH_TRANSFER_SERVICES
*copyc NFE$FTS_CONDITION_CODES
*copyc NFT$FILE_KIND
*copyc NFT$NETWORK_TYPE
*copyc NFT$PARAMETER_00_VALUES
*copyc NFT$PARAMETER_17_DEFINITION
*copyc NFT$TRANSFER_DECLARATIONS
*copyc NFT$TRANSFER_MODES
*copyc OSD$VIRTUAL_ADDRESS
*copyc RFE$CONDITION_CODES
?? POP ??
*copyc AMP$FILE
*copyc AMP$GET_FILE_ATTRIBUTES
*copyc AMP$GET_PARTIAL
*copyc AMP$GET_SEGMENT_POINTER
*copyc AMP$RETURN
*copyc AMP$SET_LOCAL_NAME_ABNORMAL
*copyc BAP$GET_PHN_VIA_FILE_ID
*copyc CLP$CONVERT_INTEGER_TO_RJSTRING
*copyc CLP$CONVERT_INTEGER_TO_STRING
*copyc CLP$CONVERT_STRING_TO_INTEGER
*copyc CLP$READ_VARIABLE
*copyc FSP$CLOSE_FILE
*copyc FSP$COPY_FILE
*copyc FSP$OPEN_AND_GET_TYPE_OF_COPY
*copyc FSP$OPEN_FILE
*copyc JMP$CLOSE_OUTPUT_FILE
*copyc JMP$OPEN_INPUT_FILE
*copyc JMP$OPEN_OUTPUT_FILE
*copyc MMP$SET_ACCESS_SELECTIONS
*copyc NAP$AWAIT_DATA_AVAILABLE
*copyc NAP$DISPLAY_MESSAGE
*copyc NAP$FETCH_ATTRIBUTES
*copyc NAP$SE_RECEIVE_DATA
*copyc NAP$SE_SEND_DATA
*copyc NAP$STORE_ATTRIBUTES
*copyc NFP$PTF_FORMAT_MESSAGE_TO_OUT
*copyc OSP$ESTABLISH_CONDITION_HANDLER
*copyc OSP$FORMAT_MESSAGE
*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSP$SET_STATUS_CONDITION
*copyc OSP$SYSTEM_ERROR
*copyc PMP$CONTINUE_TO_CAUSE
*copyc PMP$ESTABLISH_CONDITION_HANDLER
*copyc PMP$GET_170_OS_TYPE
*copyc PMP$GET_UNIQUE_NAME
*copyc PMP$LOG
*copyc RFP$AWAIT_RHFAM_EVENT
*copyc RFP$FETCH
*copyc RFP$RECEIVE_DATA
*copyc RFP$SEND_DATA
*copyc RFP$STORE
*copyc SRP$FETCH_SYSTEM_LABEL
*copyc SRP$FETCH_SYSTEM_LABEL_SIZE

*copyc AMV$NIL_FILE_IDENTIFIER
*copyc FSV$COPF_INPUT_FILE_ATTACHMENT
*copyc FSV$COPF_OUTPUT_FILE_ATTACHMENT
?? TITLE := 'GLOBAL DECLARATIONS DECLARED', EJECT ??

  TYPE
    positioning_grid = packed array [1 .. * ] of char,
    reposition_direction = (forward, backward),
    reposition_displacement = 0 .. 65535,
    reposition_preview_lines = 0 .. 10,
    reposition_preview_message = array [1 .. 3] of record
      message: ^string ( * ),
      length: 0 .. 2560,
    recend,
    reposition_start_position = (top, bottom, last_line_printed),
    reposition_string = string ( * <= 256),
    reposition_units = (lines, pages),
    repositioning_type = (no_repositioning, forward_string_search_to_line, forward_string_search_to_page,
          back_string_search_to_line, back_string_search_to_page, forward_ellipsis_search_to_line,
          forward_ellipsis_search_to_page, back_ellipsis_search_to_line, back_ellipsis_search_to_page,
          forward_line_displacement, backward_line_displacement, forward_page_absolute, forward_page_relative,
          backward_page_absolute, backward_page_relative, line_adjustment_forward, page_adjustment_forward,
          line_adjustment_backward, page_adjustment_backward),
    sender_input_commands = (sr, rr, mr, er, qr, pr),
    sender_input_data_area = array [1 .. 1] of ^SEQ ( * ),
    sender_positioning_attributes = (reposition_info, current_position),
    sender_states = (start_pend, restart_pend, wait_sendr, ss_ack_not_required, send_data, end_ok_sent,
          end_err_sent, quit_ok_received, quit_err_received, pos_pend, holdr_pend, wait_resume, exit_send);

  VAR
    access_method: (nfc$am_rhfam, nfc$am_nam) := nfc$am_nam,
    active_send_error_code: char,
    control_info: fst$copy_control_information,
    current_send_state: sender_states,
    header_buffer: batch_data_header,
    position_valid: boolean,
    processing_error: boolean,
    protocol_trace: boolean,
    queue_file: boolean,
    return_file: boolean,
    search_character_designator: [STATIC, READ] array [1 .. 4] of integer := [100000000(16), 0, 0, 0],
    send_params: transfer_params,
    send_transfer_progress: transfer_progress,
    sender_file_id: amt$file_identifier,
    transfer_file: amt$local_file_name,
    transfer_file_size: amt$file_length;

?? TITLE := '[XDCL] nfp$send_batch_file', EJECT ??
*copyc nfh$send_batch_file

  PROCEDURE [XDCL] nfp$send_batch_file
    (    connection_fid: amt$file_identifier;
         connection_file_name: fst$file_reference;
         file_name: jmt$system_supplied_name;
         local_file_name: amt$local_file_name;
         facilities: nft$facility_group;
         transfer_mode: nft$transfer_modes;
         block_size: nft$block_size;
         min_timeout: nft$timeout;
         protocol_version: nft$parameter_00_values;
         destination_usage: jmt$destination_usage;
         queue_file_password: jmt$queue_file_password;
         disposition_code: nft$parameter_17_definition;
         activate_protocol_trace: boolean;
     VAR file_position: jmt$output_file_position;
     VAR protocol_state_consistent: boolean;
     VAR transfer_status: ost$status;
     VAR status: ost$status);


    CONST
      b101_session_timeout = 0ffffffff(16);

    VAR
      attachment_options: ^fst$attachment_options,
      change_attributes: ^nat$change_attributes,
      command_buffer: ^SEQ ( * ),
      data_area: sender_input_data_area,
      get_attributes: ^nat$get_attributes,
      line_number: jmt$output_file_position,
      local_status: ost$status,
      saved_session_timeout: nat$wait_time,
      segment_pointer: amt$segment_pointer,
      send_condition_descriptor: ^pmt$established_handler,
      send_conditions: [STATIC, READ] pmt$condition := [pmc$condition_combination,
            [pmc$system_conditions, pmc$block_exit_processing, jmc$job_resource_condition,
            mmc$segment_access_condition, ifc$interactive_condition]],
      session_timeout_modified: boolean,
      transfer_file_attributes: ^fst$file_cycle_attributes;

?? NEWTITLE := '  process_abnormal_status', EJECT ??

{ PURPOSE:  This procedure handles an abnormal status, attempting to inform
{           the peer application of our troubles before dropping out.

    PROCEDURE process_abnormal_status
      (    bad_status: ost$status);

      VAR
        command_buffer: ^SEQ ( * ),
        data_area: sender_input_data_area,
        local_status: ost$status;

      process_send_system_error (bad_status, status);
      IF NOT status.normal THEN
        set_status (send_params, transfer_status, status);
        protocol_state_consistent := FALSE;
        RETURN; {----->
      IFEND;

      PUSH command_buffer: [[REP command_block_size OF cell]];
      data_area [1] := command_buffer;
      receive_connection_event (data_area, status);
      IF NOT status.normal THEN
        set_status (send_params, transfer_status, status);
        protocol_state_consistent := FALSE;
        RETURN; {----->
      IFEND;

      set_status (send_params, transfer_status, status);

    PROCEND process_abnormal_status;

?? OLDTITLE ??
?? NEWTITLE := '  send_condition_handler', EJECT ??

{ PURPOSE:  This is the condition handler for nfp$send_batch_file.

    PROCEDURE send_condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        change_attributes: ^nat$change_attributes,
        ignore_status: ost$status;

      IF (condition.selector = pmc$block_exit_processing) AND ((pmc$program_abort IN condition.reason) OR
            (pmc$program_termination IN condition.reason)) THEN
        IF protocol_trace THEN
          pmp$log('**** NFM$RHF_SEND_FILE: Sender terminating. Closing connection.', ignore_status);
        IFEND;

{ Closing the network connection file before closing the output file will prevent NAM/VE from
{ attempting to send data from the closed output file. NAM/VE would attempt to send the data if
{ NFP$SEND_BATCH_FILE had called NAP$SE_SEND_DATA just prior to the event which caused execution
{ of this condition handler.

        fsp$close_file (send_params.connection_fid, ignore_status);
        amp$return (connection_file_name, ignore_status);
      IFEND;

      IF sender_file_id <> amv$nil_file_identifier THEN
        IF local_file_name = osc$null_name THEN
          jmp$close_output_file (sender_file_id, local_status);
        ELSE
          fsp$close_file (sender_file_id, local_status);
        IFEND;
        sender_file_id := amv$nil_file_identifier;
        #SPOIL (sender_file_id);
      IFEND;
      IF session_timeout_modified AND (condition.selector <> pmc$block_exit_processing) THEN
        PUSH change_attributes: [1 .. 1];
        change_attributes^ [1].kind := nac$data_transfer_timeout;
        change_attributes^ [1].data_transfer_timeout := saved_session_timeout;
        nap$store_attributes (send_params.connection_fid, change_attributes^, status);
        IF NOT local_status.normal THEN
          status := local_status;
        IFEND;
        session_timeout_modified := FALSE;
      IFEND;

      file_position := 0;

      IF condition.selector <> pmc$block_exit_processing THEN
        protocol_state_consistent := FALSE;
        pmp$continue_to_cause (pmc$execute_standard_procedure, status);
        EXIT nfp$send_batch_file; {----->
      IFEND;
    PROCEND send_condition_handler;
?? OLDTITLE, EJECT ??
{   BEGIN nfp$send_batch_file

    status.normal := TRUE;
    local_status.normal := TRUE;
    sender_file_id := amv$nil_file_identifier;
    #SPOIL (sender_file_id);
    processing_error := FALSE;
    session_timeout_modified := FALSE;
    protocol_state_consistent := TRUE;
    position_valid := FALSE;
    queue_file := (local_file_name = osc$null_name);
    send_params.connection_fid := connection_fid;
    IF local_file_name = osc$null_name THEN
      send_params.file_name := file_name;
    ELSE
      send_params.file_name := local_file_name;
    IFEND;
    send_params.facilities := facilities;
    send_params.transfer_mode := transfer_mode;
    send_params.block_size := block_size;
    send_params.min_timeout := min_timeout;
    send_params.validation_ring := osc$sj_ring_3; {RING 6}
    send_params.protocol_version := protocol_version;
    send_params.status.normal := TRUE;
    current_send_state := start_pend;

    protocol_trace := activate_protocol_trace;

    PUSH send_condition_descriptor;
    pmp$establish_condition_handler (send_conditions, ^send_condition_handler, send_condition_descriptor,
          local_status);
    IF NOT local_status.normal THEN
      process_abnormal_status (local_status);
      RETURN; {----->
    IFEND;

    IF local_file_name = osc$null_name THEN
      IF (disposition_code = nfc$p17_input_return) OR
         (disposition_code = nfc$p17_input_no_return) THEN
        jmp$open_input_file (file_name, amc$segment, destination_usage, queue_file_password,
              sender_file_id, local_status);
      ELSE
        jmp$open_output_file (file_name, amc$segment, destination_usage, queue_file_password,
              sender_file_id, local_status);
      IFEND;
    ELSE
      PUSH attachment_options: [1 .. 1];
      attachment_options^ [1].selector := fsc$access_and_share_modes;
      attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options^ [1].access_modes.value := $fst$file_access_options [fsc$read];
      attachment_options^ [1].share_modes.selector := fsc$determine_from_access_modes;
      fsp$open_file (local_file_name, amc$segment, attachment_options, NIL, NIL, NIL, NIL,
            sender_file_id, local_status);
    IFEND;
    IF NOT local_status.normal THEN
      process_abnormal_status (local_status);
      RETURN; {----->
    IFEND;

    amp$get_segment_pointer (sender_file_id, amc$sequence_pointer, segment_pointer, local_status);
    IF NOT local_status.normal THEN
      process_abnormal_status (local_status);
      RETURN; {----->
    IFEND;

    transfer_file_size := #SIZE (segment_pointer.sequence_pointer^);
    send_transfer_progress.remaining_data := transfer_file_size;
    send_transfer_progress.general_position := file_in_progress;
    header_buffer.application_block_number := 0;
    send_transfer_progress.file_byte_address := segment_pointer.sequence_pointer;
    RESET send_transfer_progress.file_byte_address;

    line_number := 0;

    PUSH get_attributes: [1 .. 1];
    get_attributes^ [1].kind := nac$data_transfer_timeout;
    nap$fetch_attributes (send_params.connection_fid, get_attributes^, local_status);
    IF NOT local_status.normal THEN
      process_abnormal_status (local_status);
      RETURN; {----->
    IFEND;
    saved_session_timeout := get_attributes^ [1].data_transfer_timeout;
    PUSH change_attributes: [1 .. 1];
    change_attributes^ [1].kind := nac$data_transfer_timeout;
    change_attributes^ [1].data_transfer_timeout := b101_session_timeout;
    nap$store_attributes (send_params.connection_fid, change_attributes^, local_status);
    IF NOT local_status.normal THEN
      process_abnormal_status (local_status);
      RETURN; {----->
    IFEND;
    session_timeout_modified := TRUE;

    PUSH command_buffer: [[REP batch_command_size OF cell]];
    data_area [1] := command_buffer;

{   Send protocol command SS - start sender data.

    send_batch_ss (file_position, line_number, status);
    IF NOT status.normal THEN
      set_status (send_params, transfer_status, status);
      protocol_state_consistent := FALSE;
      RETURN; {----->
    IFEND;

    receive_connection_event (data_area, status);
    IF NOT status.normal THEN
      set_status (send_params, transfer_status, status);
      protocol_state_consistent := FALSE;
      RETURN; {----->
    IFEND;

    set_status (send_params, transfer_status, status);

  PROCEND nfp$send_batch_file;

?? TITLE := '[XDCL] nfp$send_file', EJECT ??
*copyc nfh$send_file

  PROCEDURE [XDCL] nfp$send_file
    (    connection_fid: amt$file_identifier;
         file_name: amt$local_file_name;
         facilities: nft$facility_group;
         transfer_mode: nft$transfer_modes;
         block_size: nft$block_size;
         min_timeout: nft$timeout;
         protocol_version: nft$parameter_00_values;
         network_type: nft$network_type;
         validation_ring: ost$ring;
         activate_protocol_trace: boolean;
     VAR file_size: amt$file_length;
     VAR protocol_state_consistent: boolean;
     VAR transfer_status: ost$status;
     VAR status: ost$status);

    VAR
      command_buffer: ^SEQ ( * ),
      data_area: sender_input_data_area,
      get_attributes: ^nat$get_attributes,
      ignore_status: ost$status,
      local_status: ost$status,
      output_close_status: ost$status,
      output_fid: amt$file_identifier,
      rhfam_attributes: ^rft$change_attributes,
      save_rhfam_attrs: ^rft$get_attributes,
      send_condition_descriptor: ^pmt$established_handler,
      send_conditions: [STATIC, READ] pmt$condition := [pmc$condition_combination,
            [pmc$system_conditions, pmc$block_exit_processing, jmc$job_resource_condition,
            mmc$segment_access_condition, ifc$interactive_condition]],
      transfer_file_attributes: ^fst$file_cycle_attributes,
      unique_name: ost$name;
?? NEWTITLE := '  process_abnormal_status', EJECT ??

{ PURPOSE:  This procedure handles an abnormal status, attempting to inform
{           the peer application of our troubles before dropping out.

    PROCEDURE process_abnormal_status
      (    bad_status: ost$status);

      VAR
        command_buffer: ^SEQ ( * ),
        data_area: sender_input_data_area,
        local_status: ost$status;

      process_send_system_error (bad_status, status);
      IF NOT status.normal THEN
        set_status (send_params, transfer_status, status);
        protocol_state_consistent := FALSE;
        RETURN; {----->
      IFEND;

      PUSH command_buffer: [[REP command_block_size OF cell]];
      data_area [1] := command_buffer;
      receive_connection_event (data_area, status);
      IF NOT status.normal THEN
        set_status (send_params, transfer_status, status);
        protocol_state_consistent := FALSE;
        RETURN; {----->
      IFEND;

      set_status (send_params, transfer_status, status);

    PROCEND process_abnormal_status;

?? OLDTITLE ??
?? NEWTITLE := '  send_condition_handler', EJECT ??

{ PURPOSE:  This is the condition handler for nfp$send_file.

    PROCEDURE send_condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        command_buffer: ^SEQ ( * ),
        data_area: sender_input_data_area,
        ignore_status: ost$status,
        local_status: ost$status,
        os_type: ost$170_os_type;

      IF (condition.selector = ifc$interactive_condition) THEN
        IF ((condition.interactive_condition = ifc$pause_break) OR
              (condition.interactive_condition = ifc$job_reconnect)) THEN

          pmp$get_170_os_type(os_type, local_status);
          IF (NOT local_status.normal) OR (os_type = osc$ot7_dual_state_nos_be) THEN

{ NOS/BE allows only one asynch interrupt which is mapped to a NOS/VE pause break. Respond to the pause
{ break as if it were a terminate break.

            osp$set_status_condition (ife$terminate_break_received, local_status);
            process_send_system_error(local_status, ignore_status);
          ELSE

{ Generate message indicating pause break is ignored.

            osp$set_status_abnormal (nfc$status_id, nfe$user_interrupt_ignored, '', local_status);
            nfp$ptf_format_message_to_out (local_status);
          IFEND;
          RETURN;

        ELSEIF (condition.interactive_condition = ifc$terminate_break) THEN
          osp$set_status_condition (ife$terminate_break_received, local_status);
          process_send_system_error(local_status, ignore_status);
          RETURN;
        IFEND;
      IFEND;

      IF sender_file_id <> amv$nil_file_identifier THEN
        fsp$close_file (sender_file_id, local_status);
      IFEND;
      IF return_file THEN
        amp$return (transfer_file, local_status);
      IFEND;
      IF condition.selector <> pmc$block_exit_processing THEN
        protocol_state_consistent := FALSE;
        pmp$continue_to_cause (pmc$execute_standard_procedure, status);
      ELSE
        IF (NOT processing_error) AND (current_send_state <> end_ok_sent) AND
             (current_send_state <> end_err_sent) AND (current_send_state <> exit_send) THEN
          PUSH command_buffer: [[REP command_block_size OF cell]];
          data_area [1] := command_buffer;
          ignore_status.normal := TRUE;
          process_send_system_error (ignore_status, ignore_status);
          receive_connection_event (data_area, ignore_status);
          pmp$continue_to_cause (pmc$execute_standard_procedure, status);
        IFEND;
      IFEND;
    PROCEND send_condition_handler;
?? OLDTITLE, EJECT ??
{   BEGIN nfp$send_file

    status.normal := TRUE;
    local_status.normal := TRUE;
    output_close_status.normal := TRUE;
    processing_error := FALSE;
    protocol_state_consistent := TRUE;
    queue_file := FALSE;
    sender_file_id := amv$nil_file_identifier;
    #SPOIL (sender_file_id);
    return_file := FALSE;
    transfer_file_size := 0;
    #SPOIL (return_file);

    protocol_trace := activate_protocol_trace;
    IF protocol_trace THEN
      CASE network_type OF
      = nfc$network_lcn =
        pmp$log ('**** NFM$RHF_SEND_FILE: Network type is LCN.', local_status);
      = nfc$network_nam =
        pmp$log ('**** NFM$RHF_SEND_FILE: Network type is NAM.', local_status);
      = nfc$unknown_network =
        pmp$log ('**** NFM$RHF_SEND_FILE: Network type is UNKNOWN.', local_status);
      ELSE
      CASEND;

      CASE transfer_mode OF
      = nfc$ve_to_ve_mode =
        pmp$log ('**** NFM$RHF_SEND_FILE: Transfer mode is VE to VE.', local_status);
      = nfc$coded_data_mode =
        pmp$log ('**** NFM$RHF_SEND_FILE: Transfer mode is CODED.', local_status);
      = nfc$transparent_data_mode =
        pmp$log ('**** NFM$RHF_SEND_FILE: Transfer mode is TRANSPARENT.', local_status);
      = nfc$rhf_structured_mode =
        pmp$log ('**** NFM$RHF_SEND_FILE: Transfer mode is RHF STRUCTURED.', local_status);
      ELSE
      CASEND;
      local_status.normal := TRUE;
    IFEND;

    CASE network_type OF
    = nfc$network_lcn =
      access_method := nfc$am_rhfam;
      IF  (protocol_version = nfc$p00_a101) OR (protocol_version = nfc$p00_a102)  THEN
        PUSH save_rhfam_attrs: [1 .. 3];
        save_rhfam_attrs^ [1].key := rfc$record_block_size;
        save_rhfam_attrs^ [2].key := rfc$outgoing_record_abn;
        save_rhfam_attrs^ [3].key := rfc$data_transfer_timeout;
        rfp$fetch (connection_fid, save_rhfam_attrs^, status);
        IF  NOT status.normal  THEN
          RETURN; {----->
        IFEND;

        IF  block_size > rfc$max_block_size  THEN
          send_params.block_size := rfc$max_block_size;
        ELSE
          send_params.block_size := block_size;
        IFEND;

        PUSH rhfam_attributes: [1 .. 3];
        rhfam_attributes^ [1].key := rfc$record_block_size;
        rhfam_attributes^ [1].record_block_size := send_params.block_size;
        rhfam_attributes^ [2].key := rfc$outgoing_record_abn;
        rhfam_attributes^ [2].outgoing_record_abn := 0;
        rhfam_attributes^ [3].key := rfc$data_transfer_timeout;
        rhfam_attributes^ [3].data_transfer_timeout := min_timeout * 1000;

        rfp$store (connection_fid, rhfam_attributes^, status);
        IF  NOT status.normal  THEN
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$application_protocol_error, '', status);
        RETURN; {----->
      IFEND;
    = nfc$network_nam =
      access_method := nfc$am_nam;
      send_params.block_size := block_size;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'nfp$send_file network case',
            status);
      RETURN; {----->
    CASEND;

    send_params.connection_fid := connection_fid;
    send_params.file_name := file_name;
    send_params.facilities := facilities;
    send_params.transfer_mode := transfer_mode;
    send_params.min_timeout := min_timeout;
    send_params.validation_ring := validation_ring;
    send_params.protocol_version := protocol_version;
    send_params.status.normal := TRUE;
    send_transfer_progress.general_position := not_started;
    current_send_state := start_pend;

    PUSH send_condition_descriptor;
    pmp$establish_condition_handler (send_conditions, ^send_condition_handler, send_condition_descriptor,
          local_status);
    IF NOT local_status.normal THEN
      process_abnormal_status (local_status);
      RETURN; {----->
    IFEND;

{   Send protocol command SS - Start sender data.

    send_ss (status);
    IF NOT status.normal THEN
      set_status (send_params, transfer_status, status);
      protocol_state_consistent := FALSE;
      RETURN; {----->
    IFEND;

    PUSH command_buffer: [[REP command_block_size OF cell]];
    data_area [1] := command_buffer;

    pmp$get_unique_name (unique_name, local_status);
    IF NOT local_status.normal THEN
      process_abnormal_status (local_status);
      RETURN; {----->
    IFEND;

    IF send_params.transfer_mode = nfc$coded_data_mode THEN
      PUSH transfer_file_attributes: [1 .. 3];
      transfer_file_attributes^ [1].selector := fsc$record_type;
      transfer_file_attributes^ [1].record_type := amc$trailing_char_delimited;
      transfer_file_attributes^ [2].selector := fsc$ring_attributes;
      transfer_file_attributes^ [2].ring_attributes.r1 := send_params.validation_ring;
      transfer_file_attributes^ [2].ring_attributes.r2 := send_params.validation_ring;
      transfer_file_attributes^ [2].ring_attributes.r3 := send_params.validation_ring;
      transfer_file_attributes^ [3].selector := fsc$record_delimiting_character;
      transfer_file_attributes^ [3].record_delimiting_character := $CHAR (1f(16)); { US character }
    ELSE
      transfer_file_attributes := NIL;
    IFEND;

    fsp$open_and_get_type_of_copy (send_params.file_name, unique_name, ^fsv$copf_input_file_attachment,
          ^fsv$copf_output_file_attachment, NIL, NIL, transfer_file_attributes, sender_file_id, output_fid,
          control_info, local_status);
    IF NOT local_status.normal THEN
      IF output_fid <> amv$nil_file_identifier THEN
        fsp$close_file (output_fid, output_close_status);
      IFEND;
      process_abnormal_status (local_status);
      RETURN; {----->
    IFEND;

    IF output_fid <> amv$nil_file_identifier THEN
      fsp$close_file (output_fid, output_close_status);
      IF NOT output_close_status.normal THEN
        process_abnormal_status (output_close_status);
        RETURN; {----->
      IFEND;
    IFEND;

    amp$return (unique_name, local_status);
    IF NOT local_status.normal THEN
      process_abnormal_status (local_status);
      RETURN; {----->
    IFEND;

    receive_connection_event (data_area, status);
    IF NOT status.normal THEN
      set_status (send_params, transfer_status, status);
      protocol_state_consistent := FALSE;
      RETURN; {----->
    IFEND;

    set_status (send_params, transfer_status, status);

    file_size := transfer_file_size;

{   Clean up LCN particulars.

    IF network_type = nfc$network_lcn THEN
      rhfam_attributes^ [1].record_block_size := save_rhfam_attrs^ [1].record_block_size;
      rhfam_attributes^ [2].outgoing_record_abn := save_rhfam_attrs^ [2].outgoing_record_abn;
      rhfam_attributes^ [3].data_transfer_timeout := save_rhfam_attrs^ [3].data_transfer_timeout;
      rfp$store (connection_fid, rhfam_attributes^, ignore_status);
    IFEND;

  PROCEND nfp$send_file;
?? TITLE := '[XDCL] nfp$send_queue_file', EJECT ??
*copyc nfh$send_queue_file

  PROCEDURE [XDCL] nfp$send_queue_file
    (    connection_fid: amt$file_identifier;
         queue_file_fid: amt$file_identifier;
         file_name: jmt$system_supplied_name;
         facilities: nft$facility_group;
         transfer_mode: nft$transfer_modes;
         block_size: nft$block_size;
         min_timeout: nft$timeout;
         protocol_version: nft$parameter_00_values;
         network_type: nft$network_type;
         activate_protocol_trace: boolean;
     VAR protocol_state_consistent: boolean;
     VAR transfer_status: ost$status;
     VAR status: ost$status);

    VAR
      command_buffer: ^SEQ ( * ),
      data_area: sender_input_data_area,
      ignore_status: ost$status,
      local_status: ost$status,
      rhfam_attributes: ^rft$change_attributes,
      save_rhfam_attrs: ^rft$get_attributes,
      send_conditions: [STATIC, READ] pmt$condition := [pmc$condition_combination,
            [pmc$system_conditions, pmc$block_exit_processing, jmc$job_resource_condition,
            mmc$segment_access_condition, ifc$interactive_condition]],
      send_condition_descriptor: ^pmt$established_handler;

?? NEWTITLE := '  process_abnormal_status', EJECT ??

{ PURPOSE:  This procedure handles an abnormal status, attempting to inform
{           the peer application of our troubles before dropping out.

    PROCEDURE process_abnormal_status
      (    bad_status: ost$status);

      VAR
        command_buffer: ^SEQ ( * ),
        data_area: sender_input_data_area,
        local_status: ost$status;

      process_send_system_error (bad_status, status);
      IF NOT status.normal THEN
        set_status (send_params, transfer_status, status);
        protocol_state_consistent := FALSE;
        RETURN; {----->
      IFEND;

      PUSH command_buffer: [[REP command_block_size OF cell]];
      data_area [1] := command_buffer;
      receive_connection_event (data_area, status);
      IF NOT status.normal THEN
        set_status (send_params, transfer_status, status);
        protocol_state_consistent := FALSE;
        RETURN; {----->
      IFEND;

      set_status (send_params, transfer_status, status);

    PROCEND process_abnormal_status;

?? OLDTITLE ??
?? NEWTITLE := '  send_condition_handler', EJECT ??

{ PURPOSE:  This is the condition handler for nfp$send_queue_file.

    PROCEDURE send_condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      IF sender_file_id <> amv$nil_file_identifier THEN
        fsp$close_file (sender_file_id, local_status);
      IFEND;

      IF return_file THEN
        amp$return (transfer_file, local_status);
      IFEND;

      IF condition.selector <> pmc$block_exit_processing THEN
        protocol_state_consistent := FALSE;
        pmp$continue_to_cause (pmc$execute_standard_procedure, status);
        EXIT nfp$send_queue_file; {----->
      IFEND;

    PROCEND send_condition_handler;
?? OLDTITLE, EJECT ??
{   BEGIN nfp$send_queue_file

    status.normal := TRUE;
    local_status.normal := TRUE;

    processing_error := FALSE;
    protocol_state_consistent := TRUE;
    queue_file := TRUE;
    return_file := FALSE;
    #SPOIL (return_file);

{ Initilize variables which are global to this module using the values provided by our caller.

    sender_file_id := queue_file_fid;
    #SPOIL (sender_file_id);
    protocol_trace := activate_protocol_trace;
    IF protocol_trace THEN
      CASE network_type OF
      = nfc$network_lcn =
        pmp$log ('**** NFM$RHF_SEND_FILE: Network type is LCN.', local_status);
      = nfc$network_nam =
        pmp$log ('**** NFM$RHF_SEND_FILE: Network type is NAM.', local_status);
      = nfc$unknown_network =
        pmp$log ('**** NFM$RHF_SEND_FILE: Network type is UNKNOWN.', local_status);
      CASEND;

      CASE transfer_mode OF
      = nfc$ve_to_ve_mode =
        pmp$log ('**** NFM$RHF_SEND_FILE: Transfer mode is VE to VE.', local_status);
      = nfc$coded_data_mode =
        pmp$log ('**** NFM$RHF_SEND_FILE: Transfer mode is CODED.', local_status);
      = nfc$transparent_data_mode =
        pmp$log ('**** NFM$RHF_SEND_FILE: Transfer mode is TRANSPARENT.', local_status);
      = nfc$rhf_structured_mode =
        pmp$log ('**** NFM$RHF_SEND_FILE: Transfer mode is RHF STRUCTURED.', local_status);
      CASEND;
      local_status.normal := TRUE;
    IFEND;

    CASE network_type OF
    = nfc$network_lcn =
      access_method := nfc$am_rhfam;
      IF  (protocol_version = nfc$p00_a101) OR (protocol_version = nfc$p00_a102)  THEN
        PUSH save_rhfam_attrs: [1 .. 4];
        save_rhfam_attrs^ [1].key := rfc$record_block_size;
        save_rhfam_attrs^ [2].key := rfc$outgoing_record_abn;
        save_rhfam_attrs^ [3].key := rfc$data_transfer_timeout;
        save_rhfam_attrs^ [4].key := rfc$send_record_terminator;
        rfp$fetch (connection_fid, save_rhfam_attrs^, status);
        IF  NOT status.normal  THEN
          RETURN; {----->
        IFEND;

        IF  block_size > rfc$max_block_size  THEN
          send_params.block_size := rfc$max_block_size;
        ELSE
          send_params.block_size := block_size;
        IFEND;

        PUSH rhfam_attributes: [1 .. 4];
        rhfam_attributes^ [1].key := rfc$record_block_size;
        rhfam_attributes^ [1].record_block_size := send_params.block_size;
        rhfam_attributes^ [2].key := rfc$outgoing_record_abn;
        rhfam_attributes^ [2].outgoing_record_abn := 0;
        rhfam_attributes^ [3].key := rfc$data_transfer_timeout;
        rhfam_attributes^ [3].data_transfer_timeout := min_timeout * 1000;
        rhfam_attributes^ [4].key := rfc$send_record_terminator;
        rhfam_attributes^ [4].send_record_terminator := rfc$rm_eoi;

        rfp$store (connection_fid, rhfam_attributes^, status);
        IF  NOT status.normal  THEN
          RETURN; {----->
        IFEND;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$application_protocol_error, '', status);
        RETURN; {----->
      IFEND;
    = nfc$network_nam =
      access_method := nfc$am_nam;
      send_params.block_size := block_size;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error, 'nfp$send_queue_file network case',
            status);
      RETURN; {----->
    CASEND;

    send_params.connection_fid := connection_fid;
    send_params.file_name := file_name;
    send_params.facilities := facilities;
    send_params.transfer_mode := transfer_mode;
    send_params.min_timeout := min_timeout;
    send_params.validation_ring := osc$tsrv_ring;
    send_params.protocol_version := protocol_version;
    send_params.status.normal := TRUE;

    current_send_state := start_pend;

{   Send protocol command SS - Start sender data.

    send_ss (status);
    IF NOT status.normal THEN
      set_status (send_params, transfer_status, status);
      protocol_state_consistent := FALSE;
      RETURN; {----->
    IFEND;

    PUSH send_condition_descriptor;
    pmp$establish_condition_handler (send_conditions, ^send_condition_handler, send_condition_descriptor,
          local_status);
    IF NOT local_status.normal THEN
      process_abnormal_status (local_status);
      RETURN; {----->
    IFEND;

    PUSH command_buffer: [[REP command_block_size OF cell]];
    data_area [1] := command_buffer;

    receive_connection_event (data_area, status);
    IF NOT status.normal THEN
      set_status (send_params, transfer_status, status);
      protocol_state_consistent := FALSE;
      RETURN; {----->
    IFEND;

{   Clean up LCN particulars.

    IF network_type = nfc$network_lcn THEN
      rhfam_attributes^ [1].record_block_size := save_rhfam_attrs^ [1].record_block_size;
      rhfam_attributes^ [2].outgoing_record_abn := save_rhfam_attrs^ [2].outgoing_record_abn;
      rhfam_attributes^ [3].data_transfer_timeout := save_rhfam_attrs^ [3].data_transfer_timeout;
      rhfam_attributes^ [4].send_record_terminator := save_rhfam_attrs^ [4].send_record_terminator;
      rfp$store (connection_fid, rhfam_attributes^, ignore_status);
    IFEND;

    set_status (send_params, transfer_status, status);

  PROCEND nfp$send_queue_file;
?? TITLE := '[INLINE] advance_one_line', EJECT ??

{ PURPOSE:  This inline procedure advances to the next line in an output file.

  PROCEDURE [INLINE] advance_one_line
    (VAR line_length: jmt$output_file_position;
     VAR end_of_file: boolean;
     VAR status: ost$status);

    VAR
      char_index: jmt$output_file_position,
      found: boolean,
      interim_line_length: jmt$output_file_position,
      line_string: ^string ( * <= 256),
      search_length: 1 .. 256,
      search_string: ^string ( * <= 256);

    status.normal := TRUE;
    found := FALSE;
    line_length := 0;
    end_of_file := FALSE;

  /find_end_of_line/
    WHILE NOT found DO
      IF send_transfer_progress.remaining_data >= 256 THEN
        search_length := 256;
      ELSE
        search_length := send_transfer_progress.remaining_data;
      IFEND;
      NEXT search_string: [search_length] IN send_transfer_progress.file_byte_address;
      #SCAN (search_character_designator, search_string^, char_index, found);
      IF found THEN
        RESET send_transfer_progress.file_byte_address TO search_string;
        NEXT line_string: [char_index] IN send_transfer_progress.file_byte_address;
        interim_line_length := char_index;
      ELSE
        interim_line_length := search_length;
      IFEND;
      line_length := line_length + interim_line_length;
      send_transfer_progress.remaining_data := send_transfer_progress.remaining_data - interim_line_length;
      end_of_file := (send_transfer_progress.remaining_data <= 0);
      IF end_of_file THEN
        EXIT /find_end_of_line/; {----->
      IFEND;
    WHILEND /find_end_of_line/;
  PROCEND advance_one_line;
?? TITLE := '[INLINE] find_last_line', EJECT ??

{ PURPOSE:  This inline procedure finds the previous line in an output file.

  PROCEDURE [INLINE] find_last_line
    (    backward_locator: ^positioning_grid;
     VAR index: jmt$output_file_position;
     VAR byte_count: jmt$output_file_position;
     VAR beginning_of_file: boolean;
     VAR status: ost$status);

    status.normal := TRUE;
    index := index - 1;
    byte_count := byte_count - 1;
    beginning_of_file := byte_count = 0;
    send_transfer_progress.remaining_data := send_transfer_progress.remaining_data + 1;

  /search_for_end_of_line/
    WHILE NOT beginning_of_file DO
      IF backward_locator^ [index] = $CHAR (31) THEN
        EXIT /search_for_end_of_line/; {----->
      IFEND;
      index := index - 1;
      byte_count := byte_count - 1;
      beginning_of_file := byte_count = 0;
      send_transfer_progress.remaining_data := send_transfer_progress.remaining_data + 1;
    WHILEND /search_for_end_of_line/;
  PROCEND find_last_line;
?? TITLE := 'move_back_pages', EJECT ??

{ PURPOSE:  This procedure positions an output file backwards by pages.

  PROCEDURE move_back_pages
    (    page_count: jmt$output_file_position;
     VAR line_number: jmt$output_file_position;
     VAR byte_position: jmt$output_file_position;
     VAR beginning_of_file: boolean;
     VAR status: ost$status);

    VAR
      backward_locator: ^positioning_grid,
      byte_count: jmt$output_file_position,
      i: jmt$output_file_position,
      index: jmt$output_file_position;

    status.normal := TRUE;
    byte_count := byte_position - 1;
    IF byte_count = 0 THEN
      RETURN; {----->
    IFEND;
    RESET send_transfer_progress.file_byte_address;
    NEXT backward_locator: [1 .. byte_count] IN send_transfer_progress.file_byte_address;
    beginning_of_file := FALSE;
    index := byte_count;
    FOR i := 1 TO page_count DO

    /find_page_boundary/
      WHILE NOT beginning_of_file DO
        find_last_line (backward_locator, index, byte_count, beginning_of_file, status);
        line_number := line_number - 1;
        IF backward_locator^ [index + 1] = '1' THEN
          EXIT /find_page_boundary/; {----->
        IFEND;
      WHILEND /find_page_boundary/;
    FOREND;
    RESET send_transfer_progress.file_byte_address;
    IF NOT beginning_of_file THEN
      NEXT backward_locator: [1 .. byte_count] IN send_transfer_progress.file_byte_address;
      send_transfer_progress.remaining_data := transfer_file_size - byte_count;
    IFEND;
    byte_position := byte_count + 1;

  PROCEND move_back_pages;
?? TITLE := 'output_debug_message', EJECT ??

{ PURPOSE:  This procedure displays a debug message in the job log.

  PROCEDURE output_debug_message
    (    message_description: string ( * ),
         stat: ost$status);

    CONST
      line_length = 60;

    VAR
      i: 1 .. osc$max_status_message_lines,
      ignore_status: ost$status,
      message: ost$status_message,
      message_pointer: ^ost$status_message,
      msg_line_count: ^ost$status_message_line_count,
      msg_line_size: ^ost$status_message_line_size,
      msg_line_text: ^string ( * );

    osp$format_message (stat, osc$full_message_level, line_length, message, ignore_status);
    message_pointer := ^message;
    RESET message_pointer;
    NEXT msg_line_count IN message_pointer;
    pmp$log (message_description, ignore_status);
    FOR i := 1 TO msg_line_count^ DO
      NEXT msg_line_size IN message_pointer;
      NEXT msg_line_text: [msg_line_size^] IN message_pointer;
      pmp$log (msg_line_text^, ignore_status);
    FOREND;
  PROCEND output_debug_message;
?? TITLE := 'process_pr_command', EJECT ??

{ PURPOSE:  This procedure processes the PR protocol command.

  PROCEDURE process_pr_command
    (VAR command_buffer: ^SEQ ( * );
     VAR status: ost$status);

    CONST
      boi_message = 'File is positioned at beginning.',
      current_file_position = '57',
      eoi_message = 'File is positioned at end.      ',
      not_found_message = 'String was not found.            ',
      reposition_file_parameters = '56',
      user_message_size = 35;

    VAR
      attribute_id: sender_positioning_attributes,
      attribute_number_string: ^string (2),
      attribute_size: clt$integer,
      attribute_size_string: ^string (3),
      beginning_of_file: boolean,
      command_id_string: ^string (2),
      convert_positioning_param: [STATIC, READ] array [sender_positioning_attributes] of string (2) :=
            [reposition_file_parameters, current_file_position],
      current_di_byte: jmt$output_file_position,
      current_tip_line: jmt$output_file_position,
      direction: reposition_direction,
      displacement: reposition_displacement,
      end_of_file: boolean,
      first_string: ^reposition_string,
      i: 1 .. 3,
      index: 1 .. 2,
      local_status: ost$status,
      new_byte_position: jmt$output_file_position,
      new_line_number: jmt$output_file_position,
      no_find: boolean,
      parameter_count: clt$integer,
      parameter_count_string: ^string (2),
      parameter_string: ^string ( * ),
      preview_bytes: jmt$output_file_position,
      preview_count: integer,
      preview_lines: reposition_preview_lines,
      preview_message: reposition_preview_message,
      qualifier_character: ^char,
      required_attribute_present: boolean,
      second_string: ^reposition_string,
      start_position: reposition_start_position,
      string_found: boolean,
      units: reposition_units,
      user_message: ^string ( * );

?? NEWTITLE := '  position_file', EJECT ??

{ PURPOSE:  This procedure is the main output file positioning routine.

    PROCEDURE position_file
      (    current_line_number: jmt$output_file_position;
           current_byte_count: jmt$output_file_position;
           displacement: reposition_displacement;
           first_string: ^reposition_string;
           second_string: ^reposition_string;
           units: reposition_units;
           direction: reposition_direction;
           start_position: reposition_start_position;
           preview_lines: reposition_preview_lines;
       VAR new_line_number: jmt$output_file_position;
       VAR new_byte_position: jmt$output_file_position;
       VAR preview_bytes: jmt$output_file_position;
       VAR string_found: boolean;
       VAR beginning_of_file: boolean;
       VAR end_of_file: boolean;
       VAR status: ost$status);

      CONST
        new_page_effector = '1';

      VAR
        bytes: jmt$output_file_position,
        current_candidate_string: ^SEQ ( * ),
        current_position: ^cell,
        current_remaining_data: jmt$output_file_position,
        i: 1 .. 10,
        target_line_number: jmt$output_file_position,
        type_of_repositioning: repositioning_type;

?? NEWTITLE := '    initialize_for_scan', EJECT ??

{ PURPOSE:  This procedure sets things up for file positioning.

      PROCEDURE initialize_for_scan
        (    current_line: integer;
             displacement: reposition_displacement;
             first_string: ^reposition_string;
             second_string: ^reposition_string;
             units: reposition_units;
             direction: reposition_direction;
             start_position: reposition_start_position;
         VAR type_of_positioning: repositioning_type;
         VAR target_line_number: jmt$output_file_position;
         VAR beginning_of_file: boolean;
         VAR end_of_file: boolean;
         VAR status: ost$status);

        status.normal := TRUE;
        target_line_number := 0;
        RESET send_transfer_progress.file_byte_address;
        send_transfer_progress.remaining_data := transfer_file_size;
        CASE direction OF
        = forward =
          CASE start_position OF
          = bottom =
            position_to_bottom (target_line_number, status);
            IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
              RETURN; {----->
            IFEND;
            end_of_file := TRUE;
            type_of_positioning := no_repositioning;
          = top =
            IF first_string <> NIL THEN
              target_line_number := 1;
              IF second_string = NIL THEN
                IF units = lines THEN
                  type_of_positioning := forward_string_search_to_line;
                ELSE
                  type_of_positioning := forward_string_search_to_page;
                IFEND;
              ELSE
                IF units = lines THEN
                  type_of_positioning := forward_ellipsis_search_to_line;
                ELSE
                  type_of_positioning := forward_ellipsis_search_to_page;
                IFEND;
              IFEND;
            ELSEIF displacement = 0 THEN
              type_of_positioning := no_repositioning;
              target_line_number := 1;
              beginning_of_file := TRUE;
            ELSEIF units = lines THEN
              type_of_positioning := forward_line_displacement;
              target_line_number := displacement + 1;
            ELSEIF units = pages THEN
              type_of_positioning := forward_page_absolute;
            IFEND;
          = last_line_printed =
            IF first_string <> NIL THEN
              target_line_number := current_line_number;
              IF second_string = NIL THEN
                IF units = lines THEN
                  type_of_positioning := forward_string_search_to_line;
                ELSE
                  type_of_positioning := forward_string_search_to_page;
                IFEND;
              ELSE
                IF units = lines THEN
                  type_of_positioning := forward_ellipsis_search_to_line;
                ELSE
                  type_of_positioning := forward_ellipsis_search_to_page;
                IFEND;
              IFEND;
            ELSEIF units = lines THEN
              IF NOT position_valid THEN
                type_of_positioning := forward_line_displacement;
              ELSE
                type_of_positioning := line_adjustment_forward;
              IFEND;
              target_line_number := current_line_number + displacement;
            ELSE
              IF displacement = 0 THEN
                IF NOT position_valid THEN
                  type_of_positioning := backward_page_relative;
                ELSE
                  type_of_positioning := page_adjustment_backward;
                IFEND;
              ELSE
                IF NOT position_valid THEN
                  type_of_positioning := forward_page_relative;
                ELSE
                  type_of_positioning := page_adjustment_forward;
                IFEND;
              IFEND;
            IFEND;
          CASEND;
        = backward =
          CASE start_position OF
          = top =
            type_of_positioning := no_repositioning;
            target_line_number := 1;
            beginning_of_file := TRUE;
          = bottom =
            IF first_string <> NIL THEN
              target_line_number := 0;
              IF second_string = NIL THEN
                IF units = lines THEN
                  type_of_positioning := back_string_search_to_line;
                ELSE
                  type_of_positioning := back_string_search_to_page;
                IFEND;
              ELSE
                IF units = lines THEN
                  type_of_positioning := back_ellipsis_search_to_line;
                ELSE
                  type_of_positioning := back_ellipsis_search_to_page;
                IFEND;
              IFEND;
            ELSEIF displacement = 0 THEN
              position_to_bottom (target_line_number, status);
              IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
                RETURN; {----->
              IFEND;
              end_of_file := TRUE;
              type_of_positioning := no_repositioning;
            ELSEIF units = lines THEN
              type_of_positioning := backward_line_displacement;
            ELSE
              type_of_positioning := backward_page_absolute;
            IFEND;
          = last_line_printed =
            IF first_string <> NIL THEN
              target_line_number := current_line_number;
              IF second_string = NIL THEN
                IF units = lines THEN
                  type_of_positioning := back_string_search_to_line;
                ELSE
                  type_of_positioning := back_string_search_to_page;
                IFEND;
              ELSE
                IF units = lines THEN
                  type_of_positioning := back_ellipsis_search_to_line;
                ELSE
                  type_of_positioning := back_ellipsis_search_to_page;
                IFEND;
              IFEND;
            ELSEIF units = lines THEN
              IF NOT position_valid THEN
                type_of_positioning := forward_line_displacement;
              ELSE
                type_of_positioning := line_adjustment_backward;
              IFEND;
              IF current_line > displacement THEN
                target_line_number := current_line - displacement;
              ELSE
                type_of_positioning := no_repositioning;
                target_line_number := 1;
                beginning_of_file := TRUE;
              IFEND;
            ELSE
              IF NOT position_valid THEN
                type_of_positioning := backward_page_relative;
              ELSE
                type_of_positioning := page_adjustment_backward;
              IFEND;
            IFEND;
          CASEND;
        CASEND;

      PROCEND initialize_for_scan;
?? OLDTITLE ??
?? NEWTITLE := '    move_back_lines', EJECT ??

{ PURPOSE:  This procedure positions an output file backwards by lines.

      PROCEDURE move_back_lines
        (    displacement: reposition_displacement;
         VAR new_line_number: jmt$output_file_position;
         VAR new_byte_position: jmt$output_file_position;
         VAR beginning_of_file: boolean;
         VAR status: ost$status);

        VAR
          backward_locator: ^positioning_grid,
          byte_count: jmt$output_file_position,
          current_line_index: jmt$output_file_position,
          locator_index: jmt$output_file_position;

        status.normal := TRUE;
        byte_count := new_byte_position - 1;
        IF byte_count = 0 THEN
          RETURN; {----->
        IFEND;
        RESET send_transfer_progress.file_byte_address;
        NEXT backward_locator: [1 .. byte_count] IN send_transfer_progress.file_byte_address;
        locator_index := byte_count;
        FOR current_line_index := 1 TO displacement DO
          find_last_line (backward_locator, locator_index, byte_count, beginning_of_file, status);
          new_line_number := new_line_number - 1;
        FOREND;
        RESET send_transfer_progress.file_byte_address;
        IF NOT beginning_of_file THEN
          NEXT backward_locator: [1 .. byte_count] IN send_transfer_progress.file_byte_address;
          send_transfer_progress.remaining_data := transfer_file_size - byte_count;
        IFEND;
        new_byte_position := byte_count + 1;

      PROCEND move_back_lines;
?? OLDTITLE ??
?? NEWTITLE := '    move_forward_lines', EJECT ??

{ PURPOSE:  This procedure positions an output file forward by lines.

      PROCEDURE move_forward_lines
        (    displacement: reposition_displacement;
         VAR new_line_number: jmt$output_file_position;
         VAR new_byte_position: jmt$output_file_position;
         VAR end_of_file: boolean;
         VAR status: ost$status);

        VAR
          byte_count: jmt$output_file_position,
          current_line_index: jmt$output_file_position,
          position_marker: ^string ( * );

        status.normal := TRUE;
        IF NOT (new_line_number = 1) THEN
          NEXT position_marker: [new_byte_position - 1] IN send_transfer_progress.file_byte_address;
          send_transfer_progress.remaining_data := send_transfer_progress.remaining_data - new_byte_position -
                1;
        IFEND;
        FOR current_line_index := 1 TO displacement DO
          advance_one_line (byte_count, end_of_file, status);
          new_line_number := new_line_number + 1;
          new_byte_position := new_byte_position + byte_count;
          IF end_of_file THEN
            RETURN; {----->
          IFEND;
        FOREND;
      PROCEND move_forward_lines;
?? OLDTITLE ??
?? NEWTITLE := '    move_forward_pages', EJECT ??

{ PURPOSE:  This procedure positions an output file forward by pages.

      PROCEDURE move_forward_pages
        (    displacement: reposition_displacement;
         VAR new_line_number: jmt$output_file_position;
         VAR new_byte_position: jmt$output_file_position;
         VAR end_of_file: boolean;
         VAR status: ost$status);

        VAR
          byte_count: jmt$output_file_position,
          current_page_index: jmt$output_file_position,
          first_char: ^char;

        status.normal := TRUE;

        FOR current_page_index := 1 TO displacement DO

        /find_next_page/
          WHILE TRUE DO
            IF end_of_file THEN
              RETURN; {----->
            IFEND;
            advance_one_line (byte_count, end_of_file, status);
            IF end_of_file THEN
              RETURN; {----->
            IFEND;
            new_line_number := new_line_number + 1;
            new_byte_position := new_byte_position + byte_count;
            NEXT first_char IN send_transfer_progress.file_byte_address;
            RESET send_transfer_progress.file_byte_address TO first_char;
            IF first_char^ = new_page_effector THEN
              EXIT /find_next_page/; {----->
            IFEND;
          WHILEND /find_next_page/;
        FOREND;
      PROCEND move_forward_pages;
?? OLDTITLE ??
?? NEWTITLE := '    page_backward_from_line', EJECT ??

{ PURPOSE:  This procedure positions an output file backwards a page from the
{           current line.

      PROCEDURE page_backward_from_line
        (    current_line_number: jmt$output_file_position;
             displacement: reposition_displacement;
         VAR new_line_number: jmt$output_file_position;
         VAR new_byte_position: jmt$output_file_position;
         VAR beginning_of_file: boolean;
         VAR status: ost$status);

        TYPE
          page_record = record
            address: ^cell,
            byte_position: jmt$output_file_position,
            line_number: jmt$output_file_position,
          recend;

        VAR
          bytes: jmt$output_file_position,
          current_page_index: 0 .. 65535,
          current_page_record: ^page_record,
          end_of_file: boolean,
          first_char: ^char,
          page_bytes: jmt$output_file_position,
          page_trace: ^array [0 .. * ] of page_record,
          temp_line_number: jmt$output_file_position;

        status.normal := TRUE;
        page_bytes := 0;
        PUSH current_page_record;
        current_page_record^.byte_position := 1;
        PUSH page_trace: [0 .. displacement];
        NEXT page_trace^ [0].address IN send_transfer_progress.file_byte_address;
        RESET send_transfer_progress.file_byte_address TO page_trace^ [0].address;
        FOR current_page_index := 0 TO displacement DO
          page_trace^ [current_page_index].address := NIL;
          page_trace^ [current_page_index].byte_position := 0;
          page_trace^ [current_page_index].line_number := current_page_index;
        FOREND;
        page_trace^ [0].byte_position := 1;
        page_trace^ [0].line_number := 1;
        current_page_index := 0;
        end_of_file := FALSE;
        FOR temp_line_number := 1 TO current_line_number DO
          NEXT first_char IN send_transfer_progress.file_byte_address;
          RESET send_transfer_progress.file_byte_address TO first_char;
          IF first_char^ = new_page_effector THEN
            current_page_index := current_page_index + 1;
            IF current_page_index = displacement + 1 THEN
              current_page_index := 0;
            IFEND;
            NEXT current_page_record^.address IN send_transfer_progress.file_byte_address;
            RESET send_transfer_progress.file_byte_address TO current_page_record^.address;
            current_page_record^.byte_position := current_page_record^.byte_position + page_bytes;
            current_page_record^.line_number := temp_line_number;
            page_trace^ [current_page_index] := current_page_record^;
            page_bytes := 0;
          IFEND;
          advance_one_line (bytes, end_of_file, status);
          IF end_of_file THEN
            RETURN; {----->
          IFEND;
          page_bytes := page_bytes + bytes;
        FOREND;
        IF page_trace^ [(current_page_index + 1) MOD (displacement + 1)].address <> NIL THEN
          new_line_number := page_trace^ [(current_page_index + 1) MOD (displacement + 1)].line_number;
          new_byte_position := page_trace^ [(current_page_index + 1) MOD (displacement + 1)].byte_position;
          RESET send_transfer_progress.file_byte_address TO page_trace^
                [(current_page_index + 1) MOD (displacement + 1)].address;
          send_transfer_progress.remaining_data := transfer_file_size - new_byte_position + 1;
        ELSE
          new_line_number := 1;
          new_byte_position := 1;
          RESET send_transfer_progress.file_byte_address;
          send_transfer_progress.remaining_data := transfer_file_size;
          beginning_of_file := TRUE;
        IFEND;
      PROCEND page_backward_from_line;
?? OLDTITLE ??
?? NEWTITLE := '    page_forward_from_line', EJECT ??

{ PURPOSE:  This procedure positions an output file forward a page from the
{           current line.

      PROCEDURE page_forward_from_line
        (    current_line_number: jmt$output_file_position;
             displacement: reposition_displacement;
         VAR new_line_number: jmt$output_file_position;
         VAR new_byte_position: jmt$output_file_position;
         VAR end_of_file: boolean;
         VAR status: ost$status);

        status.normal := TRUE;
        position_forward_to_line (current_line_number, new_line_number, new_byte_position, end_of_file,
              status);
        IF end_of_file THEN
          RETURN; {----->
        IFEND;
        move_forward_pages (displacement, new_line_number, new_byte_position, end_of_file, status);
      PROCEND page_forward_from_line;
?? OLDTITLE ??
?? NEWTITLE := '    page_forward_from_top', EJECT ??

{ PURPOSE:  This procedure positions an output file forward a page from the
{           beginning of the file.

      PROCEDURE page_forward_from_top
        (    displacement: reposition_displacement;
         VAR new_line_number: jmt$output_file_position;
         VAR new_byte_position: jmt$output_file_position;
         VAR end_of_file: boolean;
         VAR status: ost$status);

        VAR
          adjusted_displacement: reposition_displacement,
          current_line_number: jmt$output_file_position,
          first_char: ^char;

        status.normal := TRUE;
        NEXT first_char IN send_transfer_progress.file_byte_address;
        send_transfer_progress.remaining_data := send_transfer_progress.remaining_data - 1;
        adjusted_displacement := displacement;
        end_of_file := FALSE;
        IF first_char^ = new_page_effector THEN
          adjusted_displacement := adjusted_displacement - 1;
          IF adjusted_displacement = 0 THEN
            new_line_number := 1;
            new_byte_position := 2;
            RETURN; {----->
          IFEND;
        IFEND;
        current_line_number := 1;
        page_forward_from_line (current_line_number, adjusted_displacement, new_line_number,
              new_byte_position, end_of_file, status);
      PROCEND page_forward_from_top;
?? OLDTITLE ??
?? NEWTITLE := '    position_backward_to_page', EJECT ??

{ PURPOSE:  This procedure positions an output file backwards to the top
{           of a page.

      PROCEDURE position_backward_to_page
        (    displacement: reposition_displacement;
         VAR new_line_number: jmt$output_file_position;
         VAR new_byte_position: jmt$output_file_position;
         VAR beginning_of_file: boolean;
         VAR status: ost$status);

        TYPE
          page_record = record
            address: ^cell,
            byte_position: jmt$output_file_position,
            line_number: jmt$output_file_position,
          recend;

        VAR
          bytes: jmt$output_file_position,
          current_line_number: jmt$output_file_position,
          current_page_index: 0 .. 65535,
          current_page_record: ^page_record,
          end_of_file: boolean,
          first_char: ^char,
          page_bytes: jmt$output_file_position,
          page_trace: ^array [0 .. * ] of page_record;

        status.normal := TRUE;
        current_line_number := 1;
        page_bytes := 0;
        PUSH current_page_record;
        current_page_record^.byte_position := 1;
        PUSH page_trace: [0 .. (displacement - 1)];
        NEXT page_trace^ [0].address IN send_transfer_progress.file_byte_address;
        RESET send_transfer_progress.file_byte_address TO page_trace^ [0].address;
        FOR current_page_index := 0 TO (displacement - 1) DO
          page_trace^ [current_page_index].address := NIL;
          page_trace^ [current_page_index].byte_position := 0;
          page_trace^ [current_page_index].line_number := current_page_index;
        FOREND;
        page_trace^ [0].byte_position := 1;
        page_trace^ [0].line_number := 1;
        current_page_index := 0;
        end_of_file := FALSE;
        REPEAT
          NEXT first_char IN send_transfer_progress.file_byte_address;
          RESET send_transfer_progress.file_byte_address TO first_char;
          IF first_char^ = new_page_effector THEN
            current_page_index := current_page_index + 1;
            IF current_page_index = displacement THEN
              current_page_index := 0;
            IFEND;
            NEXT current_page_record^.address IN send_transfer_progress.file_byte_address;
            RESET send_transfer_progress.file_byte_address TO current_page_record^.address;
            current_page_record^.byte_position := current_page_record^.byte_position + page_bytes;
            current_page_record^.line_number := current_line_number;
            page_trace^ [current_page_index] := current_page_record^;
            page_bytes := 0;
          IFEND;
          advance_one_line (bytes, end_of_file, status);
          current_line_number := current_line_number + 1;
          page_bytes := page_bytes + bytes;
        UNTIL end_of_file;
        IF page_trace^ [(current_page_index + 1) MOD displacement].address <> NIL THEN
          new_line_number := page_trace^ [(current_page_index + 1) MOD displacement].line_number;
          new_byte_position := page_trace^ [(current_page_index + 1) MOD displacement].byte_position;
          RESET send_transfer_progress.file_byte_address TO page_trace^
                [(current_page_index + 1) MOD displacement].address;
          send_transfer_progress.remaining_data := transfer_file_size - new_byte_position + 1;
        ELSE
          new_line_number := 1;
          new_byte_position := 1;
          RESET send_transfer_progress.file_byte_address;
          send_transfer_progress.remaining_data := transfer_file_size;
          beginning_of_file := TRUE;
        IFEND;
      PROCEND position_backward_to_page;
?? OLDTITLE ??
?? NEWTITLE := '    position_forward_to_line', EJECT ??

{ PURPOSE:  This procedure positions an output file forward to a given line.

      PROCEDURE position_forward_to_line
        (    target_line_number: jmt$output_file_position;
         VAR new_line_number: jmt$output_file_position;
         VAR new_byte_position: jmt$output_file_position;
         VAR end_of_file: boolean;
         VAR status: ost$status);

        VAR
          byte_count: jmt$output_file_position;

        status.normal := TRUE;
        new_byte_position := 1;
        IF target_line_number <= 1 THEN
          new_line_number := 1;
          RETURN; {----->
        IFEND;
        FOR new_line_number := 2 TO target_line_number DO
          advance_one_line (byte_count, end_of_file, status);
          new_byte_position := new_byte_position + byte_count;
          IF end_of_file THEN
            RETURN; {----->
          IFEND;

        FOREND;
      PROCEND position_forward_to_line;
?? OLDTITLE ??
?? NEWTITLE := '    position_to_bottom', EJECT ??

{ PURPOSE:  This procedure positions an output file forward to the end of
{           the file

      PROCEDURE position_to_bottom
        (VAR line_number: jmt$output_file_position;
         VAR status: ost$status);

        VAR
          byte_count: jmt$output_file_position,
          end_of_file: boolean;

        status.normal := TRUE;
        line_number := 1;
        REPEAT
          advance_one_line (byte_count, end_of_file, status);
          line_number := line_number + 1;
        UNTIL end_of_file;

      PROCEND position_to_bottom;
?? OLDTITLE ??
?? NEWTITLE := '    position_to_line_from_bottom', EJECT ??

{ PURPOSE:  This procedure positions an output file backwards from the end of
{           the file.

      PROCEDURE position_to_line_from_bottom
        (    displacement: reposition_displacement;
         VAR new_line_number: jmt$output_file_position;
         VAR new_byte_position: jmt$output_file_position;
         VAR beginning_of_file: boolean;
         VAR status: ost$status);

        TYPE
          line_record = record
            address: ^cell,
            byte_position: jmt$output_file_position,
          recend;

        VAR
          bytes: jmt$output_file_position,
          current_line_index: 0 .. 65535,
          current_line_number: jmt$output_file_position,
          current_line_record: ^line_record,
          end_of_file: boolean,
          line_trace: ^array [0 .. * ] of line_record;

        status.normal := TRUE;
        current_line_number := 0;
        bytes := 0;
        PUSH current_line_record;
        current_line_record^.byte_position := 1;
        PUSH line_trace: [0 .. (displacement - 1)];
        FOR current_line_index := 0 TO (displacement - 1) DO
          line_trace^ [current_line_index].address := NIL;
          line_trace^ [current_line_index].byte_position := 1
        FOREND;

      /record_displacement_data/
        WHILE TRUE DO
          FOR current_line_index := 0 TO (displacement - 1) DO
            NEXT current_line_record^.address IN send_transfer_progress.file_byte_address;
            RESET send_transfer_progress.file_byte_address TO current_line_record^.address;
            current_line_number := current_line_number + 1;
            current_line_record^.byte_position := current_line_record^.byte_position + bytes;
            line_trace^ [current_line_index] := current_line_record^;
            advance_one_line (bytes, end_of_file, status);
            IF end_of_file THEN
              EXIT /record_displacement_data/; {----->
            IFEND;
          FOREND;
        WHILEND /record_displacement_data/;
        IF line_trace^ [(current_line_index + 1) MOD displacement].address <> NIL THEN
          new_line_number := current_line_number - displacement + 1;
          new_byte_position := line_trace^ [(current_line_index + 1) MOD displacement].byte_position;
          RESET send_transfer_progress.file_byte_address TO line_trace^
                [(current_line_index + 1) MOD displacement].address;
          send_transfer_progress.remaining_data := transfer_file_size - new_byte_position + 1;
        ELSE
          new_line_number := 1;
          new_byte_position := 1;
          RESET send_transfer_progress.file_byte_address;
          send_transfer_progress.remaining_data := transfer_file_size;
          beginning_of_file := TRUE;
        IFEND;
      PROCEND position_to_line_from_bottom;
?? OLDTITLE ??
?? NEWTITLE := '    search_backward_for_ellipsis', EJECT ??

{ PURPOSE:  This procedure positions an output file backwards by a range of
{           string.

      PROCEDURE search_backward_for_ellipsis
        (    first_string: ^string ( * );
             second_string: ^string ( * );
             target_line_number: jmt$output_file_position;
             current_line_number: jmt$output_file_position;
         VAR new_line_number: jmt$output_file_position;
         VAR new_byte_position: jmt$output_file_position;
         VAR string_found: boolean;
         VAR status: ost$status);

        VAR
          byte_count: jmt$output_file_position,
          current_line: ^string ( * ),
          end_of_file: boolean,
          found: boolean,
          last_occurance: record
            current_line: ^string ( * ),
            line_number: jmt$output_file_position,
            byte_address: jmt$output_file_position,
            remaining_data: jmt$output_file_position,
          recend,
          last_occurance_set: boolean,
          restore_line_number: jmt$output_file_position;

        status.normal := TRUE;
        string_found := FALSE;
        found := FALSE;
        last_occurance_set := FALSE;
        end_of_file := FALSE;
        new_line_number := 1;
        new_byte_position := 1;
        IF position_valid THEN
          restore_line_number := current_line_number + 1;
        ELSE
          restore_line_number := current_line_number;
        IFEND;

      /search_file/
        WHILE NOT end_of_file DO
          NEXT current_line: [1] IN send_transfer_progress.file_byte_address;
          RESET send_transfer_progress.file_byte_address TO current_line;
          advance_one_line (byte_count, end_of_file, status);
          RESET send_transfer_progress.file_byte_address TO current_line;
          NEXT current_line: [byte_count] IN send_transfer_progress.file_byte_address;
          search_for_string (first_string, second_string, current_line, byte_count, found, status);
          IF found THEN
            string_found := TRUE;
            last_occurance.current_line := current_line;
            last_occurance.line_number := new_line_number;
            last_occurance.byte_address := new_byte_position;
            last_occurance.remaining_data := send_transfer_progress.remaining_data + byte_count;
            last_occurance_set := TRUE;
          IFEND;
          new_byte_position := new_byte_position + byte_count;
          new_line_number := new_line_number + 1;
          IF (new_line_number = restore_line_number) AND (NOT string_found) THEN
            NEXT current_line: [1] IN send_transfer_progress.file_byte_address;
            RESET send_transfer_progress.file_byte_address TO current_line;
            last_occurance.current_line := current_line;
            last_occurance.line_number := new_line_number;
            last_occurance.byte_address := new_byte_position;
            last_occurance.remaining_data := send_transfer_progress.remaining_data;
            last_occurance_set := TRUE;
          IFEND;
          IF new_line_number = target_line_number THEN
            IF NOT last_occurance_set THEN
              advance_one_line (byte_count, end_of_file, status);
              NEXT current_line: [1] IN send_transfer_progress.file_byte_address;
              RESET send_transfer_progress.file_byte_address TO current_line;
              last_occurance.current_line := current_line;
              last_occurance.line_number := new_line_number + 1;
              last_occurance.byte_address := new_byte_position + byte_count;
              last_occurance.remaining_data := send_transfer_progress.remaining_data;
              last_occurance_set := TRUE;
            IFEND;
            EXIT /search_file/; {----->
          IFEND;
        WHILEND /search_file/;
        RESET send_transfer_progress.file_byte_address TO last_occurance.current_line;
        new_line_number := last_occurance.line_number;
        new_byte_position := last_occurance.byte_address;
        send_transfer_progress.remaining_data := last_occurance.remaining_data;
      PROCEND search_backward_for_ellipsis;
?? OLDTITLE ??
?? NEWTITLE := '    search_backward_for_string', EJECT ??

{ PURPOSE:  This procedure positions an output file backwards by a string.

      PROCEDURE search_backward_for_string
        (    first_string: ^string ( * );
             target_line_number: jmt$output_file_position;
             current_line_number: jmt$output_file_position;
         VAR new_line_number: jmt$output_file_position;
         VAR new_byte_position: jmt$output_file_position;
         VAR string_found: boolean;
         VAR status: ost$status);

        VAR
          byte_count: jmt$output_file_position,
          current_line: ^string ( * ),
          end_of_file: boolean,
          found: boolean,
          last_occurance: record
            current_line: ^string ( * ),
            line_number: jmt$output_file_position,
            byte_address: jmt$output_file_position,
            remaining_data: jmt$output_file_position,
          recend,
          last_occurance_set: boolean,
          restore_line_number: jmt$output_file_position;

        status.normal := TRUE;
        new_line_number := 1;
        new_byte_position := 1;
        string_found := FALSE;
        found := FALSE;
        last_occurance_set := FALSE;
        end_of_file := FALSE;
        IF position_valid THEN
          restore_line_number := current_line_number + 1;
        ELSE
          restore_line_number := current_line_number;
        IFEND;

      /search_file/
        WHILE NOT end_of_file DO
          NEXT current_line: [1] IN send_transfer_progress.file_byte_address;
          RESET send_transfer_progress.file_byte_address TO current_line;
          advance_one_line (byte_count, end_of_file, status);
          RESET send_transfer_progress.file_byte_address TO current_line;
          NEXT current_line: [byte_count] IN send_transfer_progress.file_byte_address;
          search_for_string (first_string, NIL, current_line, byte_count, found, status);
          IF found THEN
            string_found := TRUE;
            last_occurance.current_line := current_line;
            last_occurance.line_number := new_line_number;
            last_occurance.byte_address := new_byte_position;
            last_occurance.remaining_data := send_transfer_progress.remaining_data + byte_count;
            last_occurance_set := TRUE;
          IFEND;
          new_byte_position := new_byte_position + byte_count;
          new_line_number := new_line_number + 1;
          IF (new_line_number = restore_line_number) AND (NOT string_found) THEN
            NEXT current_line: [1] IN send_transfer_progress.file_byte_address;
            RESET send_transfer_progress.file_byte_address TO current_line;
            last_occurance.current_line := current_line;
            last_occurance.line_number := new_line_number;
            last_occurance.byte_address := new_byte_position;
            last_occurance.remaining_data := send_transfer_progress.remaining_data;
            last_occurance_set := TRUE;
          IFEND;
          IF new_line_number = target_line_number THEN
            IF NOT last_occurance_set THEN
              advance_one_line (byte_count, end_of_file, status);
              NEXT current_line: [1] IN send_transfer_progress.file_byte_address;
              RESET send_transfer_progress.file_byte_address TO current_line;
              last_occurance.current_line := current_line;
              last_occurance.line_number := new_line_number + 1;
              last_occurance.byte_address := new_byte_position + byte_count;
              last_occurance.remaining_data := send_transfer_progress.remaining_data;
              last_occurance_set := TRUE;
            IFEND;
            EXIT /search_file/; {----->
          IFEND;
        WHILEND /search_file/;
        RESET send_transfer_progress.file_byte_address TO last_occurance.current_line;
        new_line_number := last_occurance.line_number;
        new_byte_position := last_occurance.byte_address;
        send_transfer_progress.remaining_data := last_occurance.remaining_data;
      PROCEND search_backward_for_string;
?? OLDTITLE ??
?? NEWTITLE := '    search_for_string', EJECT ??

{ PURPOSE:  This procedure searches for a string in an output file.

      PROCEDURE search_for_string
        (    string1: ^string ( * );
             string2: ^string ( * );
             search_string: ^string ( * );
             search_string_size: 1 .. 256;
         VAR found: boolean;
         VAR status: ost$status);

        VAR
          column: 1 .. 256,
          index: 1 .. 256,
          last_pass: boolean,
          str: ^string ( * );

        status.normal := TRUE;
        str := string1;
        last_pass := string2 = NIL;
        index := 1;
        found := FALSE;

      /search_loop/
        FOR column := 1 TO search_string_size DO
          IF str^ (index) = search_string^ (column) THEN
            index := index + 1;
            found := index > STRLENGTH (str^);
            IF found THEN
              IF last_pass THEN
                RETURN; {----->
              IFEND;
              found := FALSE;
              last_pass := TRUE;
              str := string2;
              index := 1;
            IFEND;
            CYCLE /search_loop/; {----->
          IFEND;
          index := 1;
        FOREND /search_loop/;
      PROCEND search_for_string;
?? OLDTITLE ??
?? NEWTITLE := '    search_forward_for_ellipsis', EJECT ??

{ PURPOSE:  This procedure positions an output file forward by a range of
{           string.

      PROCEDURE search_forward_for_ellipsis
        (    first_string: ^string ( * );
             second_string: ^string ( * );
             current_line_number: jmt$output_file_position;
         VAR new_line_number: jmt$output_file_position;
         VAR new_byte_position: jmt$output_file_position;
         VAR string_found: boolean;
         VAR status: ost$status);

        VAR
          byte_count: jmt$output_file_position,
          current_line: ^string ( * ),
          end_of_file: boolean,
          found: boolean,
          original_position: record
            current_line: ^string ( * ),
            line_number: jmt$output_file_position,
            byte_address: jmt$output_file_position,
            remaining_data: jmt$output_file_position,
          recend,
          restore_line_number: jmt$output_file_position;

        status.normal := TRUE;
        string_found := FALSE;
        found := FALSE;
        end_of_file := FALSE;
        NEXT original_position.current_line: [1] IN send_transfer_progress.file_byte_address;
        RESET send_transfer_progress.file_byte_address TO original_position.current_line;
        original_position.remaining_data := send_transfer_progress.remaining_data;
        original_position.line_number := current_line_number;
        original_position.byte_address := new_byte_position;
        IF position_valid THEN
          restore_line_number := current_line_number + 1;
        ELSE
          restore_line_number := current_line_number;
        IFEND;

      /search_file/
        WHILE NOT end_of_file DO
          NEXT current_line: [1] IN send_transfer_progress.file_byte_address;
          RESET send_transfer_progress.file_byte_address TO current_line;
          advance_one_line (byte_count, end_of_file, status);
          RESET send_transfer_progress.file_byte_address TO current_line;
          NEXT current_line: [byte_count] IN send_transfer_progress.file_byte_address;
          search_for_string (first_string, second_string, current_line, byte_count, found, status);
          IF found THEN
            string_found := TRUE;
            RESET send_transfer_progress.file_byte_address TO current_line;
            end_of_file := FALSE;
            send_transfer_progress.remaining_data := send_transfer_progress.remaining_data + byte_count;
            RETURN; {----->
          IFEND;
          new_line_number := new_line_number + 1;
          new_byte_position := new_byte_position + byte_count;
          IF (new_line_number = restore_line_number) AND (NOT string_found) THEN
            NEXT current_line: [1] IN send_transfer_progress.file_byte_address;
            RESET send_transfer_progress.file_byte_address TO current_line;
            original_position.current_line := current_line;
            original_position.line_number := new_line_number;
            original_position.byte_address := new_byte_position;
            original_position.remaining_data := send_transfer_progress.remaining_data;
          IFEND;
        WHILEND /search_file/;
        RESET send_transfer_progress.file_byte_address TO original_position.current_line;
        new_line_number := original_position.line_number;
        new_byte_position := original_position.byte_address;
        send_transfer_progress.remaining_data := original_position.remaining_data;

      PROCEND search_forward_for_ellipsis;
?? OLDTITLE ??
?? NEWTITLE := '    search_forward_for_string', EJECT ??

{ PURPOSE:  This procedure positions an output file forward by a string.

      PROCEDURE search_forward_for_string
        (    first_string: ^string ( * );
             current_line_number: jmt$output_file_position;
         VAR new_line_number: jmt$output_file_position;
         VAR new_byte_position: jmt$output_file_position;
         VAR string_found: boolean;
         VAR status: ost$status);

        VAR
          byte_count: jmt$output_file_position,
          current_line: ^string ( * ),
          end_of_file: boolean,
          found: boolean,
          original_position: record
            current_line: ^string ( * ),
            line_number: jmt$output_file_position,
            byte_address: jmt$output_file_position,
            remaining_data: jmt$output_file_position,
          recend,
          restore_line_number: jmt$output_file_position;

        status.normal := TRUE;
        found := FALSE;
        string_found := FALSE;
        end_of_file := FALSE;
        NEXT original_position.current_line: [1] IN send_transfer_progress.file_byte_address;
        RESET send_transfer_progress.file_byte_address TO original_position.current_line;
        original_position.remaining_data := send_transfer_progress.remaining_data;
        original_position.line_number := current_line_number;
        original_position.byte_address := new_byte_position;
        IF position_valid THEN
          restore_line_number := current_line_number + 1;
        ELSE
          restore_line_number := current_line_number;
        IFEND;

      /search_file/
        WHILE NOT end_of_file DO
          NEXT current_line: [1] IN send_transfer_progress.file_byte_address;
          RESET send_transfer_progress.file_byte_address TO current_line;
          advance_one_line (byte_count, end_of_file, status);
          RESET send_transfer_progress.file_byte_address TO current_line;
          NEXT current_line: [byte_count] IN send_transfer_progress.file_byte_address;
          search_for_string (first_string, NIL, current_line, byte_count, found, status);
          IF found THEN
            string_found := TRUE;
            RESET send_transfer_progress.file_byte_address TO current_line;
            end_of_file := FALSE;
            send_transfer_progress.remaining_data := send_transfer_progress.remaining_data + byte_count;
            RETURN; {----->
          IFEND;
          new_line_number := new_line_number + 1;
          new_byte_position := new_byte_position + byte_count;
          IF (new_line_number = restore_line_number) AND (NOT string_found) THEN
            NEXT current_line: [1] IN send_transfer_progress.file_byte_address;
            RESET send_transfer_progress.file_byte_address TO current_line;
            original_position.current_line := current_line;
            original_position.line_number := new_line_number;
            original_position.byte_address := new_byte_position;
            original_position.remaining_data := send_transfer_progress.remaining_data;
          IFEND;
        WHILEND /search_file/;
        RESET send_transfer_progress.file_byte_address TO original_position.current_line;
        new_line_number := original_position.line_number;
        new_byte_position := original_position.byte_address;
        send_transfer_progress.remaining_data := original_position.remaining_data;

      PROCEND search_forward_for_string;
?? OLDTITLE, EJECT ??
      status.normal := TRUE;
      local_status.normal := TRUE;
      string_found := TRUE;
      beginning_of_file := FALSE;
      end_of_file := FALSE;
      initialize_for_scan (current_line_number, displacement, first_string, second_string, units, direction,
            start_position, type_of_repositioning, target_line_number, beginning_of_file, end_of_file,
            status);
      IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
        RETURN; {----->
      IFEND;
      CASE type_of_repositioning OF
      = forward_string_search_to_line =
        position_forward_to_line (target_line_number, new_line_number, new_byte_position, end_of_file,
              status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
        IF NOT end_of_file THEN
          search_forward_for_string (first_string, current_line_number, new_line_number, new_byte_position,
                string_found, status);
          IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
            RETURN; {----->
          IFEND;
        IFEND;
      = forward_string_search_to_page =
        position_forward_to_line (target_line_number, new_line_number, new_byte_position, end_of_file,
              status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
        IF NOT end_of_file THEN
          search_forward_for_string (first_string, current_line_number, new_line_number, new_byte_position,
                string_found, status);
          IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
            RETURN; {----->
          IFEND;
        IFEND;
        IF string_found THEN
          move_back_pages (1, new_line_number, new_byte_position, beginning_of_file, status);
          IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
            RETURN; {----->
          IFEND;
        IFEND;
      = back_string_search_to_line =
        search_backward_for_string (first_string, target_line_number, current_line_number, new_line_number,
              new_byte_position, string_found, status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
      = back_string_search_to_page =
        search_backward_for_string (first_string, target_line_number, current_line_number, new_line_number,
              new_byte_position, string_found, status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
        IF string_found THEN
          move_back_pages (1, new_line_number, new_byte_position, beginning_of_file, status);
          IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
            RETURN; {----->
          IFEND;
        IFEND;
      = forward_ellipsis_search_to_line =
        position_forward_to_line (target_line_number, new_line_number, new_byte_position, end_of_file,
              status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
        IF NOT end_of_file THEN
          search_forward_for_ellipsis (first_string, second_string, current_line_number, new_line_number,
                new_byte_position, string_found, status);
          IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
            RETURN; {----->
          IFEND;
        IFEND;
      = forward_ellipsis_search_to_page =
        position_forward_to_line (target_line_number, new_line_number, new_byte_position, end_of_file,
              status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
        IF NOT end_of_file THEN
          search_forward_for_ellipsis (first_string, second_string, current_line_number, new_line_number,
                new_byte_position, string_found, status);
          IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
            RETURN; {----->
          IFEND;
        IFEND;
        IF string_found THEN
          move_back_pages (1, new_line_number, new_byte_position, beginning_of_file, status);
          IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
            RETURN; {----->
          IFEND;
        IFEND;
      = back_ellipsis_search_to_line =
        search_backward_for_ellipsis (first_string, second_string, target_line_number, current_line_number,
              new_line_number, new_byte_position, string_found, status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
      = back_ellipsis_search_to_page =
        search_backward_for_ellipsis (first_string, second_string, target_line_number, current_line_number,
              new_line_number, new_byte_position, string_found, status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
        IF string_found THEN
          move_back_pages (1, new_line_number, new_byte_position, beginning_of_file, status);
          IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
            RETURN; {----->
          IFEND;
        IFEND;
      = forward_line_displacement =
        position_forward_to_line (target_line_number, new_line_number, new_byte_position, end_of_file,
              status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
      = backward_line_displacement =
        position_to_line_from_bottom (displacement, new_line_number, new_byte_position, beginning_of_file,
              status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
      = forward_page_absolute =
        page_forward_from_top (displacement, new_line_number, new_byte_position, end_of_file, status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
      = forward_page_relative =
        page_forward_from_line (current_line_number, displacement, new_line_number, new_byte_position,
              end_of_file, status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
      = backward_page_absolute =
        position_backward_to_page (displacement, new_line_number, new_byte_position, beginning_of_file,
              status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
      = backward_page_relative =
        page_backward_from_line (current_line_number, displacement, new_line_number, new_byte_position,
              beginning_of_file, status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
      = line_adjustment_forward =
        new_line_number := current_line_number + 1;
        new_byte_position := current_byte_count + 1;
        move_forward_lines (displacement, new_line_number, new_byte_position, end_of_file, status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
      = line_adjustment_backward =
        new_line_number := current_line_number + 1;
        new_byte_position := current_byte_count + 1;
        move_back_lines (displacement, new_line_number, new_byte_position, beginning_of_file, status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
      = page_adjustment_forward =

        move_forward_pages (displacement, new_line_number, new_byte_position, end_of_file, status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
      = page_adjustment_backward =
        new_line_number := current_line_number + 1;
        new_byte_position := current_byte_count + 1;
        move_back_pages (displacement, new_line_number, new_byte_position, beginning_of_file, status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
      = no_repositioning =
        new_line_number := target_line_number;
        IF end_of_file THEN
          new_byte_position := transfer_file_size;
        ELSE
          new_byte_position := 1;
        IFEND;
      CASEND;
      preview_bytes := 0;
      IF preview_lines > 0 THEN
        IF NOT beginning_of_file AND NOT end_of_file THEN
          NEXT current_position IN send_transfer_progress.file_byte_address;
          RESET send_transfer_progress.file_byte_address TO current_position;
          current_remaining_data := send_transfer_progress.remaining_data;

        /set_preview_bytes/
          FOR i := 1 TO preview_lines DO
            advance_one_line (bytes, end_of_file, status);
            preview_bytes := preview_bytes + bytes;
            IF end_of_file THEN
              EXIT /set_preview_bytes/; {----->
            IFEND;
          FOREND /set_preview_bytes/;
          RESET send_transfer_progress.file_byte_address TO current_position;
          send_transfer_progress.remaining_data := current_remaining_data;
        IFEND;
      IFEND;
    PROCEND position_file;
?? OLDTITLE ??
?? NEWTITLE := '  set_current_position', EJECT ??

{ PURPOSE:  This procedure establishes the current position of an output file.

    PROCEDURE set_current_position
      (    parameter_string: ^string ( * );
       VAR current_tip_line: jmt$output_file_position;
       VAR current_di_byte: jmt$output_file_position;
       VAR status: ost$status);

      VAR
        byte_number: clt$integer,
        index: 1 .. 999,
        line_number: clt$integer,
        local_status: ost$status,
        parameter_string_length: 0 .. 999,
        separator_not_found: boolean;

      status.normal := TRUE;
      local_status.normal := TRUE;
      parameter_string_length := STRLENGTH (parameter_string^);
      separator_not_found := TRUE;

    /search_for_separator/
      FOR index := 1 TO parameter_string_length DO
        IF parameter_string^ (index, 1) = ',' THEN
          separator_not_found := FALSE;
          EXIT /search_for_separator/; {----->
        IFEND;
      FOREND /search_for_separator/;
      IF separator_not_found THEN
        process_send_protocol_error (status);
        RETURN; {----->
      IFEND;
      clp$convert_string_to_integer (parameter_string^ (1, index - 1), byte_number, local_status);
      IF NOT local_status.normal THEN
        process_send_system_error (local_status, status);
        RETURN; {----->
      IFEND;
      clp$convert_string_to_integer (parameter_string^ (index + 1, parameter_string_length - index),
            line_number, local_status);
      IF NOT local_status.normal THEN
        process_send_system_error (local_status, status);
        RETURN; {----->
      IFEND;
      current_tip_line := line_number.value;
      current_di_byte := byte_number.value;
    PROCEND set_current_position;
?? OLDTITLE ??
?? NEWTITLE := '  set_repositioning_data', EJECT ??

{ PURPOSE:  This procedure sets up the data neede to position an output file.

    PROCEDURE set_repositioning_data
      (    parameter_string: ^string ( * );
       VAR displacement: reposition_displacement;
       VAR first_string: ^reposition_string;
       VAR second_string: ^reposition_string;
       VAR units: reposition_units;
       VAR direction: reposition_direction;
       VAR start_position: reposition_start_position;
       VAR preview_lines: reposition_preview_lines;
       VAR status: ost$status);

      CONST
        backward_direction = 'B',
        direction_id = '05',
        forward_direction = 'F',
        lines_units = 'L',
        location_count_id = '01',
        location_string_1_id = '02',
        location_string_2_id = '03',
        pages_units = 'P',
        preview_id = '07',
        start_at_beginning = 'B',
        start_at_current_line = 'L',
        start_at_end = 'E',
        start_position_id = '06',
        system_level_id = '001',
        units_id = '04';

      VAR
        command_format_id: string (3),
        direction_set: boolean,
        direction_string: char,
        displacement_integer: clt$integer,
        displacement_set: boolean,
        first_string_set: boolean,
        index: integer,
        local_status: ost$status,
        parameter_id: string (2),
        parameter_length: clt$integer,
        preview_lines_integer: clt$integer,
        preview_lines_set: boolean,
        preview_string: char,
        second_string_set: boolean,
        start_position_set: boolean,
        start_position_string: char,
        units_set: boolean,
        units_string: char;

      status.normal := TRUE;
      local_status.normal := TRUE;
      command_format_id := parameter_string^ (1, 3);
      IF command_format_id = system_level_id THEN
        index := 4;
        displacement_set := FALSE;
        first_string_set := FALSE;
        second_string_set := FALSE;
        units_set := FALSE;
        direction_set := FALSE;
        start_position_set := FALSE;
        preview_lines_set := FALSE;

      /process_parameters/
        REPEAT
          parameter_id := parameter_string^ (index, 2);
          index := index + 2;
          IF parameter_id = location_count_id THEN
            IF displacement_set THEN
              process_send_protocol_error (status);
              RETURN; {----->
            IFEND;
            clp$convert_string_to_integer (parameter_string^ (index, 3), parameter_length, local_status);
            IF NOT local_status.normal THEN
              process_send_system_error (local_status, status);
              RETURN; {----->
            IFEND;
            index := index + 3;
            clp$convert_string_to_integer (parameter_string^ (index, parameter_length.value),
                  displacement_integer, local_status);
            IF NOT local_status.normal THEN
              process_send_system_error (local_status, status);
              RETURN; {----->
            IFEND;
            displacement := displacement_integer.value;
            index := index + parameter_length.value;
            displacement_set := TRUE;
            CYCLE /process_parameters/; {----->
          ELSEIF parameter_id = location_string_1_id THEN
            IF first_string_set THEN
              process_send_protocol_error (status);
              RETURN; {----->
            IFEND;
            clp$convert_string_to_integer (parameter_string^ (index, 3), parameter_length, local_status);
            IF NOT local_status.normal THEN
              process_send_system_error (local_status, status);
              RETURN; {----->
            IFEND;
            index := index + 3;
            first_string := ^parameter_string^ (index, parameter_length.value);
            index := index + parameter_length.value;
            first_string_set := TRUE;
            CYCLE /process_parameters/; {----->
          ELSEIF parameter_id = location_string_2_id THEN
            IF second_string_set THEN
              process_send_protocol_error (status);
              RETURN; {----->
            IFEND;
            clp$convert_string_to_integer (parameter_string^ (index, 3), parameter_length, local_status);
            IF NOT local_status.normal THEN
              process_send_system_error (local_status, status);
              RETURN; {----->
            IFEND;
            index := index + 3;
            second_string := ^parameter_string^ (index, parameter_length.value);
            index := index + parameter_length.value;
            second_string_set := TRUE;
            CYCLE /process_parameters/; {----->
          ELSEIF parameter_id = units_id THEN
            IF units_set THEN
              process_send_protocol_error (status);
              RETURN; {----->
            IFEND;
            IF parameter_string^ (index + 3, 1) = lines_units THEN
              units := lines;
            ELSEIF parameter_string^ (index + 3, 1) = pages_units THEN
              units := pages;
            ELSE
              process_send_protocol_error (status);
              RETURN; {----->
            IFEND;
            index := index + 4;
            units_set := TRUE;
            CYCLE /process_parameters/; {----->
          ELSEIF parameter_id = direction_id THEN
            IF direction_set THEN
              process_send_protocol_error (status);
              RETURN; {----->
            IFEND;
            IF parameter_string^ (index + 3, 1) = forward_direction THEN
              direction := forward;
            ELSEIF parameter_string^ (index + 3, 1) = backward_direction THEN
              direction := backward;
            ELSE
              process_send_protocol_error (status);
              RETURN; {----->
            IFEND;
            index := index + 4;
            direction_set := TRUE;
            CYCLE /process_parameters/; {----->
          ELSEIF parameter_id = start_position_id THEN
            IF start_position_set THEN
              process_send_protocol_error (status);
              RETURN; {----->
            IFEND;
            IF parameter_string^ (index + 3, 1) = start_at_beginning THEN
              start_position := top;
            ELSEIF parameter_string^ (index + 3, 1) = start_at_end THEN
              start_position := bottom;
            ELSEIF parameter_string^ (index + 3, 1) = start_at_current_line THEN
              start_position := last_line_printed;
            ELSE
              process_send_protocol_error (status);
              RETURN; {----->
            IFEND;
            index := index + 4;
            start_position_set := TRUE;
            CYCLE /process_parameters/; {----->
          ELSEIF parameter_id = preview_id THEN
            IF preview_lines_set THEN
              process_send_protocol_error (status);
              RETURN; {----->
            IFEND;
            clp$convert_string_to_integer (parameter_string^ (index + 3, 1), preview_lines_integer,
                  local_status);
            IF NOT local_status.normal THEN
              process_send_system_error (local_status, status);
              RETURN; {----->
            IFEND;
            preview_lines := preview_lines_integer.value + 1;
            index := index + 4;
            preview_lines_set := TRUE;
            CYCLE /process_parameters/; {----->
          ELSE
            process_send_protocol_error (status);
            RETURN; {----->
          IFEND;
        UNTIL index > STRLENGTH (parameter_string^);
      ELSE
        process_send_protocol_error (status);
      IFEND;

    PROCEND set_repositioning_data;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    local_status.normal := TRUE;
    required_attribute_present := FALSE;
    RESET command_buffer;
    NEXT command_id_string IN command_buffer;
    NEXT parameter_count_string IN command_buffer;
    clp$convert_string_to_integer (parameter_count_string^, parameter_count, local_status);
    IF NOT local_status.normal THEN
      process_send_system_error (local_status, status);
      RETURN; {----->
    IFEND;
    displacement := 1;
    first_string := NIL;
    second_string := NIL;
    units := pages;
    direction := backward;
    start_position := last_line_printed;
    preview_lines := 0;

  /process_attributes/
    FOR index := 1 TO parameter_count.value DO
      NEXT attribute_number_string IN command_buffer;
      NEXT qualifier_character IN command_buffer;
      NEXT attribute_size_string IN command_buffer;
      clp$convert_string_to_integer (attribute_size_string^, attribute_size, local_status);
      IF NOT local_status.normal THEN
        process_send_system_error (local_status, status);
        RETURN; {----->
      IFEND;
      NEXT parameter_string: [attribute_size.value] IN command_buffer;
      no_find := TRUE;

    /determine_attribute/
      FOR attribute_id := reposition_info TO current_position DO
        IF attribute_number_string^ = convert_positioning_param [attribute_id] THEN
          no_find := FALSE;
          EXIT /determine_attribute/; {----->
        IFEND;
      FOREND /determine_attribute/;
      IF no_find THEN
        process_send_protocol_error (status);
        RETURN; {----->
      IFEND;
      CASE attribute_id OF
      = reposition_info =
        set_repositioning_data (parameter_string, displacement, first_string, second_string, units, direction,
              start_position, preview_lines, status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
      = current_position =
        required_attribute_present := TRUE;
        set_current_position (parameter_string, current_tip_line, current_di_byte, status);
        IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
          RETURN; {----->
        IFEND;
      CASEND;
    FOREND /process_attributes/;
    IF NOT required_attribute_present THEN
      process_send_protocol_error (status);
      RETURN; {----->
    IFEND;
    position_file (current_tip_line, current_di_byte, displacement, first_string, second_string, units,
          direction, start_position, preview_lines, new_line_number, new_byte_position, preview_bytes,
          string_found, beginning_of_file, end_of_file, status);
    IF (NOT status.normal) OR (NOT send_params.status.normal) THEN
      RETURN; {----->
    IFEND;
    user_message := NIL;
    preview_message [1].message := NIL;
    preview_message [2].message := NIL;
    preview_message [3].message := NIL;
    IF preview_lines <> 0 THEN
      IF NOT string_found THEN
        PUSH user_message: [user_message_size];
        user_message^ (1, user_message_size - 3) := not_found_message;
        user_message^ (user_message_size - 2, 1) := $CHAR (31);
        user_message^ (user_message_size - 1, 1) := ' ';
        user_message^ (user_message_size, 1) := $CHAR (31);
      IFEND;
      IF preview_bytes <> 0 THEN
        preview_count := preview_bytes;

      /set_preview_message/
        FOR i := 1 TO 3 DO
          preview_message [i].length := preview_count;
          IF preview_message [i].length > 999 THEN
            preview_message [i].length := 999;
            preview_count := preview_count - 999;
            IF preview_count <= 0 THEN
              preview_count := 0;
            IFEND;
          ELSE
            preview_count := 0;
          IFEND;
          IF (preview_message [i].length) <> 0 THEN
            NEXT preview_message [i].message: [preview_message [i].length] IN
                  send_transfer_progress.file_byte_address;
          ELSE
            preview_message [i].message := NIL;
            EXIT /set_preview_message/; {----->
          IFEND;
        FOREND /set_preview_message/;

        RESET send_transfer_progress.file_byte_address TO preview_message [1].message;
      ELSE
        preview_message [1].message := NIL;
        IF beginning_of_file THEN
          RESET send_transfer_progress.file_byte_address;
          send_transfer_progress.remaining_data := transfer_file_size;
          PUSH user_message: [user_message_size];
          user_message^ (1, user_message_size - 3) := boi_message;
          user_message^ (user_message_size - 2, 1) := $CHAR (31);
          user_message^ (user_message_size - 1, 1) := ' ';
          user_message^ (user_message_size, 1) := $CHAR (31);
        ELSEIF end_of_file THEN
          send_transfer_progress.remaining_data := 0;
          PUSH user_message: [user_message_size];
          user_message^ (1, user_message_size - 3) := eoi_message;
          user_message^ (user_message_size - 2, 1) := $CHAR (31);
          user_message^ (user_message_size - 1, 1) := ' ';
          user_message^ (user_message_size, 1) := $CHAR (31);
        IFEND;
      IFEND;
    IFEND;

{   Send protocol command PS - Position request acknowledge.

    send_ps_command (new_line_number, new_byte_position, user_message, preview_message, status);
  PROCEND process_pr_command;
?? TITLE := 'process_send_protocol_error', EJECT ??

{ PURPOSE:  This procedure sets up an error ES command to the peer because of
{           a protocol anomaly.

  PROCEDURE process_send_protocol_error
    (VAR status: ost$status);

    status.normal := TRUE;
    IF processing_error THEN
      osp$set_status_abnormal (nfc$status_id, nfe$application_protocol_error, '', status);
      RETURN; {----->
    IFEND;
    processing_error := TRUE;
    osp$set_status_abnormal (nfc$status_id, nfe$application_protocol_error, '', send_params.status);
    osp$set_status_abnormal (nfc$status_id, nfe$protocol_anomaly, '', send_params.transfer_status);

{   Send protocol command ES with error - end sender data.

    send_es_err (send_detected_prot_err, status);
  PROCEND process_send_protocol_error;
?? TITLE := 'process_send_system_error', EJECT ??

{ PURPOSE:  This procedure sets up an error ES command to the peer because of
{           a system error.

  PROCEDURE process_send_system_error
    (    local_status: ost$status;
     VAR status: ost$status);

    VAR
      command_buffer: ^SEQ ( * ),
      data_area: sender_input_data_area;

    IF NOT local_status.normal THEN
      nap$display_message (local_status);
    IFEND;
    IF processing_error THEN
      IF local_status.normal THEN
        status.normal := TRUE;
      ELSE
        status := local_status;
      IFEND;
      RETURN; {----->
    IFEND;
    processing_error := TRUE;
    IF local_status.normal THEN
      send_params.status.normal := TRUE;
    ELSE
      send_params.status := local_status;
    IFEND;
    osp$set_status_abnormal (nfc$status_id, nfe$terminate_transfer_message, '',
          send_params.transfer_status);
    IF current_send_state = wait_sendr THEN
      PUSH command_buffer: [[REP command_block_size OF cell]];
      data_area [1] := command_buffer;
      receive_connection_event (data_area, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    IFEND;

{   Send protocol command ES with error - end sender data.

    send_es_err (send_err_no_retry, status);
  PROCEND process_send_system_error;
?? TITLE := 'process_sender_input', EJECT ??

{ PURPOSE:  This procedure processes sender commands.

  PROCEDURE process_sender_input
    (    peer_operation: nat$se_peer_operation;
     VAR data_area: sender_input_data_area;
     VAR status: ost$status);

    VAR
      command: ^data_phase_command,
      command_buffer: ^SEQ ( * ),
      contains_data: boolean,
      convert_sender_command: [STATIC, READ] array [sender_input_commands] of string (2) :=
            [sr_command, rr_command, mr_command, er_command, qr_command, pr_command],
      get_attributes: ^amt$get_attributes,
      id: sender_input_commands,
      local_file: boolean,
      local_status: ost$status,
      no_find: boolean,
      old_file: boolean,
      trace_message: string(256),
      trace_size: integer,
      transfer_file_attributes: ^fst$file_cycle_attributes,
      unique_name: ost$name;

    status.normal := TRUE;
    local_status.normal := TRUE;
    IF  current_send_state <> ss_ack_not_required  THEN
      command_buffer := data_area [1];
      RESET command_buffer;
      NEXT command IN command_buffer;
      no_find := TRUE;

    IF protocol_trace THEN
      STRINGREP (trace_message, trace_size, '**** NFM$RHF_SEND_FILE:',
            ' RCV Command: ', command^.command_id, ', ',
            command^.parameter_count, command^.parameter_prefix,
            command^.condition_code);
      pmp$log (trace_message (1,trace_size), local_status);
      local_status.normal := TRUE;
    IFEND;

    /determine_id/
      FOR id := sr TO pr DO
        IF command^.command_id = convert_sender_command [id] THEN
          no_find := FALSE;
          EXIT /determine_id/; {----->
        IFEND;
      FOREND /determine_id/;
      IF no_find THEN
        process_send_protocol_error (status);
        RETURN; {----->
      IFEND;
    ELSE
      id := sr;
    IFEND;
    CASE id OF
?? EJECT ??
{   Process SR command - Start of data acknowledge

    = sr =
      IF processing_error THEN
        current_send_state := exit_send;
        RETURN; {----->
      IFEND;
      IF (current_send_state <> wait_sendr)  AND (current_send_state <> ss_ack_not_required)  THEN
        process_send_protocol_error (status);
        RETURN; {----->
      IFEND;
      current_send_state := send_data;

      CASE send_params.transfer_mode OF

      = nfc$ve_to_ve_mode =
        IF NOT queue_file THEN
          transfer_file := send_params.file_name;
        ELSE
          bap$get_phn_via_file_id (sender_file_id, transfer_file, local_status);
          IF NOT local_status.normal THEN
            process_send_system_error (local_status, status);
            RETURN; {----->
          IFEND;
        IFEND;
        send_file_label (status);
        IF (NOT status.normal)  OR (send_transfer_progress.general_position <> label_complete)  THEN
          RETURN; {----->
        IFEND;

      = nfc$coded_data_mode =
        IF NOT queue_file THEN
          IF  control_info.type_of_copy <> fsc$byte_move  THEN
            pmp$get_unique_name (unique_name, local_status);
            IF NOT local_status.normal THEN
              process_send_system_error (local_status, status);
              RETURN; {----->
            IFEND;
            transfer_file := unique_name;
            PUSH transfer_file_attributes: [1 .. 3];
            transfer_file_attributes^ [1].selector := fsc$record_type;
            transfer_file_attributes^ [1].record_type := amc$trailing_char_delimited;
            transfer_file_attributes^ [2].selector := fsc$ring_attributes;
            transfer_file_attributes^ [2].ring_attributes.r1 := send_params.validation_ring;
            transfer_file_attributes^ [2].ring_attributes.r2 := send_params.validation_ring;
            transfer_file_attributes^ [2].ring_attributes.r3 := send_params.validation_ring;
            transfer_file_attributes^ [3].selector := fsc$record_delimiting_character;
            transfer_file_attributes^ [3].record_delimiting_character := $CHAR (1f(16)); { US character }

            fsp$copy_file (send_params.file_name, transfer_file, NIL, NIL, transfer_file_attributes,
                  local_status);
            return_file := TRUE;
            #SPOIL (return_file);
            IF NOT local_status.normal THEN
              process_send_system_error (local_status, status);
              RETURN; {----->
            IFEND;
          ELSE
            transfer_file := send_params.file_name;
          IFEND;
        ELSE
          bap$get_phn_via_file_id (sender_file_id, transfer_file, local_status);
          IF NOT local_status.normal THEN
            process_send_system_error (local_status, status);
            RETURN; {----->
          IFEND;
        IFEND;

      = nfc$rhf_structured_mode =
        send_rhf_file_blocks (status);
        IF (NOT status.normal)  THEN
          RETURN; {----->
        IFEND;

      = nfc$transparent_data_mode =
        transfer_file := send_params.file_name;

      ELSE

        pmp$log ('process_sender_input sr mode CASE error', local_status);
        osp$set_status_abnormal (nfc$status_id, nfe$sender_problem_no_retry,
            '', local_status);
        process_send_system_error (local_status, status);
        RETURN; {----->

      CASEND;

      start_send_file (status);
      IF  status.normal  THEN
        IF  (current_send_state = send_data)  AND
            (send_transfer_progress.general_position = file_in_progress) THEN
          send_file_blocks (status);
        IFEND;
      IFEND;
?? EJECT ??
{   ER command - End of data acknowledge

    = er =
      IF command^.condition_code = ok THEN

        IF current_send_state <> end_ok_sent THEN
          process_send_protocol_error (status);
          RETURN; {----->
        IFEND;
        current_send_state := exit_send;
        RETURN; {----->

      ELSEIF command^.condition_code (3, 1) = hold_condition THEN

        IF (current_send_state <> wait_resume) AND (current_send_state <> end_err_sent) AND
              (current_send_state <> send_data) THEN
          process_send_protocol_error (status);
          RETURN; {----->
        IFEND;
        position_valid := FALSE;
        IF send_transfer_progress.general_position = not_started THEN
          current_send_state := send_data;
          IF send_params.transfer_mode = nfc$ve_to_ve_mode THEN
            send_file_label (status);
            IF send_transfer_progress.general_position <> label_complete THEN
              RETURN; {----->
            IFEND;
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;
          start_send_file (status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;
        IF send_transfer_progress.general_position = file_in_progress THEN
          current_send_state := send_data;
          send_file_blocks (status);
          RETURN; {----->
        IFEND;
        IF send_transfer_progress.general_position = transfer_complete THEN
          current_send_state := end_ok_sent;
          RETURN; {----->
        IFEND;

      ELSEIF command^.condition_code (3, 1) = err_condition THEN

        IF current_send_state <> end_err_sent THEN
          process_send_protocol_error (status);
          RETURN; {----->
        IFEND;
        current_send_state := exit_send;

      ELSE

        process_send_protocol_error (status);
        RETURN; {----->

      IFEND;
?? EJECT ??
{   QR command - Quit transfer

    = qr =
      IF command^.condition_code (3, 1) = ok_condition THEN

        IF current_send_state = send_data THEN
          current_send_state := quit_ok_received;
          send_params.transfer_status.normal := TRUE;

{         Send protocol command ES - end sender data ok.

          send_es_ok (status);
        ELSEIF (current_send_state <> end_ok_sent) AND (current_send_state <> end_err_sent) THEN
          process_send_protocol_error (status);
        IFEND;
        RETURN; {----->

      ELSEIF command^.condition_code (3, 1) = hold_condition THEN

        IF (current_send_state = send_data) THEN
          current_send_state := holdr_pend;

{         Send protocol command ES with hold - end sender data / hold.

          send_es_hold (command^.condition_code, status);
        ELSEIF (current_send_state <> end_err_sent) AND (current_send_state <> end_ok_sent) AND
              (current_send_state <> wait_resume) THEN
          process_send_protocol_error (status);
        IFEND;
        RETURN; {----->

      ELSEIF command^.condition_code (3, 1) = err_condition THEN

        IF current_send_state = end_err_sent THEN
          IF command^.condition_code (4, 1) < active_send_error_code THEN
            RETURN; {----->
          IFEND;
        IFEND;
        processing_error := TRUE;
        osp$set_status_abnormal (nfc$status_id, nfe$receiver_problem_no_retry, '',
              send_params.transfer_status);
        current_send_state := quit_err_received;

{       Send protocol command ES with error - end sender data.

        send_es_err (command^.condition_code, status);

      ELSE

        process_send_protocol_error (status);

      IFEND;
?? EJECT ??
{   PR command - Position file

    = pr =
      IF send_params.protocol_version <> nfc$p00_b101 THEN
        process_send_protocol_error (status);
        RETURN; {----->
      IFEND;
      IF current_send_state =  wait_sendr THEN
        process_send_protocol_error (status);
        RETURN; {----->
      IFEND;
      IF current_send_state = end_err_sent THEN
        RETURN; {----->
      IFEND;
      current_send_state := pos_pend;
      RESET command_buffer;
      process_pr_command (command_buffer, status);

    ELSE
      process_send_protocol_error (status);
    CASEND;

  PROCEND process_sender_input;
?? TITLE := 'receive_connection_event', EJECT ??

{ PURPOSE:  This procedure receives data from the peer application.

  PROCEDURE receive_connection_event
    (VAR data_area: sender_input_data_area;
     VAR status: ost$status);

    VAR
      activity_status: ost$activity_status,
      buffer_descriptor_nam: array [1 .. 1] of nat$data_fragment,
      buffer_descriptor_rhfam: array [1 .. 1] of rft$data_fragment,
      local_status: ost$status,
      peer_operation: nat$se_peer_operation,
      trace_message: string(256),
      trace_size: integer;

    status.normal := TRUE;
    local_status.normal := TRUE;
    activity_status.status.normal := TRUE;

  /receive_event/
    WHILE current_send_state <> exit_send DO
      IF  access_method = nfc$am_nam  THEN
        buffer_descriptor_nam [1].address := data_area [1];
        buffer_descriptor_nam [1].length := #SIZE (data_area [1]^);
      ELSE
        buffer_descriptor_rhfam [1].address := data_area [1];
        buffer_descriptor_rhfam [1].length := #SIZE (data_area [1]^);
      IFEND;
      IF  current_send_state <> ss_ack_not_required  THEN
        IF  access_method = nfc$am_nam  THEN
          nap$await_data_available (send_params.connection_fid, initial_wait_time, 0, local_status);
          IF (NOT local_status.normal) AND (local_status.condition = nae$no_data_available)  THEN
            IF send_params.min_timeout <> nfc$timeout_limit THEN
              nap$await_data_available (send_params.connection_fid,
                    send_params.min_timeout * 1000 - initial_wait_time, 0, local_status);
            ELSE
              nap$await_data_available (send_params.connection_fid, nac$max_wait_time, 0, local_status);
            IFEND;
          IFEND;
        ELSE
          rfp$await_rhfam_event (send_params.connection_fid, rfc$input_available, initial_wait_time,
                local_status);
          IF (NOT local_status.normal)  AND (local_status.condition = rfe$no_available_event)  THEN
            rfp$await_rhfam_event (send_params.connection_fid, rfc$input_available,
                  send_params.min_timeout * 1000 - initial_wait_time, local_status);
          IFEND;
        IFEND;
        IF NOT local_status.normal THEN
          IF (local_status.condition = nae$connection_terminated) OR
                (local_status.condition = rfe$connection_terminated)  THEN
            osp$set_status_abnormal ('NF', nfe$connection_closed_by_peer, '', status);
            send_params.status := status;
            osp$set_status_abnormal (nfc$status_id, nfe$receiver_problem_no_retry, '',
                  send_params.transfer_status);
            RETURN; {----->
          ELSEIF (local_status.condition = nae$no_data_available)  OR
                (local_status.condition = rfe$no_available_event)  THEN
            IF current_send_state = wait_resume THEN
              CYCLE /receive_event/; {----->
            IFEND;
            osp$set_status_abnormal ('NF', nfe$application_timeout, '', status);
            send_params.status := status;
            osp$set_status_abnormal (nfc$status_id, nfe$application_time_out, '',
                  send_params.transfer_status);
            RETURN; {----->
          ELSE
            process_send_system_error (local_status, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            CYCLE /receive_event/; {----->
          IFEND;
        IFEND;
        IF  access_method = nfc$am_nam  THEN
          nap$se_receive_data (send_params.connection_fid, buffer_descriptor_nam, osc$wait, peer_operation,
                activity_status, local_status);
        ELSE
          peer_operation.kind := nac$se_send_data;
          rfp$receive_data (send_params.connection_fid, rfc$message_mode, ^buffer_descriptor_rhfam, osc$wait,
                activity_status, peer_operation.data_length, peer_operation.end_of_message, local_status);
        IFEND;
        IF NOT local_status.normal THEN
          IF (local_status.condition = nae$connection_terminated)  OR
                (local_status.condition = rfe$connection_terminated) THEN
            osp$set_status_abnormal ('NF', nfe$connection_closed_by_peer, '', status);
            send_params.status := status;
            osp$set_status_abnormal (nfc$status_id, nfe$receiver_problem_no_retry, '',
                  send_params.transfer_status);
            RETURN; {----->
          ELSEIF (local_status.condition = nae$data_transfer_timeout) OR
                (local_status.condition = rfe$transfer_timeout) THEN
            osp$set_status_abnormal ('NF', nfe$access_method_timeout, '', status);
            send_params.status := status;
            osp$set_status_abnormal (nfc$status_id, nfe$application_time_out, '',
                  send_params.transfer_status);
            RETURN; {----->
          ELSE
            process_send_system_error (local_status, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            CYCLE /receive_event/; {----->
          IFEND;
        ELSEIF activity_status.complete AND (NOT activity_status.status.normal) THEN
          IF (activity_status.status.condition = nae$connection_terminated)  OR
                (activity_status.status.condition = rfe$connection_terminated) THEN
            osp$set_status_abnormal ('NF', nfe$connection_closed_by_peer, '', status);
            send_params.status := status;
            osp$set_status_abnormal (nfc$status_id, nfe$receiver_problem_no_retry, '',
                  send_params.transfer_status);
            RETURN; {----->
          ELSEIF (activity_status.status.condition = nae$data_transfer_timeout) OR
                (activity_status.status.condition = rfe$transfer_timeout) THEN
            osp$set_status_abnormal ('NF', nfe$access_method_timeout, '', status);
            send_params.status := status;
            osp$set_status_abnormal (nfc$status_id, nfe$application_time_out, '',
                  send_params.transfer_status);
            RETURN; {----->
          ELSE
            process_send_system_error (activity_status.status, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            CYCLE /receive_event/; {----->
          IFEND;
        IFEND;
        IF peer_operation.kind <> nac$se_send_data THEN
          IF peer_operation.kind = nac$se_synchronize THEN
            STRINGREP (trace_message, trace_size, '**** NFM$RHF_SEND_FILE:',
                  ' RCV Illegal Synchronize Message.');
            pmp$log (trace_message (1,trace_size), local_status);
          ELSEIF peer_operation.kind = nac$se_interrupt THEN
            STRINGREP (trace_message, trace_size, '**** NFM$RHF_SEND_FILE:',
                ' RCV Illegal Interrupt Message.');
            pmp$log (trace_message (1,trace_size), local_status);
          IFEND;
          osp$set_status_abnormal ('NF', nfe$application_protocol_error, '', status);
          send_params.status := status;
          RETURN; {----->
        IFEND;
      IFEND;
      process_sender_input (peer_operation, data_area, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    WHILEND /receive_event/;
  PROCEND receive_connection_event;
?? TITLE := 'send_batch_ss', EJECT ??

{ PURPOSE:  This procedure sends an SS command for output file transfers.

  PROCEDURE send_batch_ss
    (    byte_position: jmt$output_file_position;
         line_number: jmt$output_file_position;
     VAR status: ost$status);

    CONST
      basic_batch_ss_command = '300223S004000057S',
      basic_batch_ss_command_size = 17,
      comma = ',',
      size_string_size = 3;

    VAR
      activity_status: ost$activity_status,
      basic_command_ptr: ^string (basic_batch_ss_command_size),
      byte_string: ost$string,
      byte_string_ptr: ^string ( * <= 14),
      comma_string_ptr: ^string (1),
      command_string: ^SEQ ( * ),
      command_string_size: 1 .. 49,
      end_of_message: boolean,
      line_string: ost$string,
      line_string_ptr: ^string ( * <= 14),
      local_status: ost$status,
      message_content: array [1 .. 1] of nat$data_fragment,
      parameter_size: 3 .. 29,
      qualified_data: boolean,
      size_string_ptr: ^string (size_string_size),
      trace_message: ^string(256),
      trace_message_ptr: ^string ( * ),
      trace_size: integer;

    status.normal := TRUE;
    local_status.normal := TRUE;
    qualified_data := TRUE;
    end_of_message := TRUE;
    clp$convert_integer_to_string (byte_position, 10, FALSE, byte_string, local_status);
    IF NOT local_status.normal THEN
      process_send_system_error (local_status, status);
      RETURN; {----->
    IFEND;
    clp$convert_integer_to_string (line_number, 10, FALSE, line_string, local_status);
    IF NOT local_status.normal THEN
      process_send_system_error (local_status, status);
      RETURN; {----->
    IFEND;
    parameter_size := byte_string.size + line_string.size + 1;
    command_string_size := basic_batch_ss_command_size + size_string_size + parameter_size;
    PUSH command_string: [[REP command_string_size OF cell]];
    RESET command_string;
    NEXT basic_command_ptr IN command_string;
    NEXT size_string_ptr IN command_string;
    NEXT byte_string_ptr: [byte_string.size] IN command_string;
    NEXT comma_string_ptr IN command_string;
    NEXT line_string_ptr: [line_string.size] IN command_string;
    basic_command_ptr^ := basic_batch_ss_command;
    clp$convert_integer_to_rjstring (parameter_size, 10, FALSE, '0', size_string_ptr^, local_status);
    IF NOT local_status.normal THEN
      process_send_system_error (local_status, status);
      RETURN; {----->
    IFEND;
    byte_string_ptr^ := byte_string.value;
    comma_string_ptr^ := comma;
    line_string_ptr^ := line_string.value;

    IF protocol_trace THEN
      PUSH trace_message;
      RESET command_string;
      NEXT trace_message_ptr: [command_string_size] IN command_string;
      STRINGREP (trace_message^, trace_size, '**** NFM$RHF_SEND_FILE:',
            ' SND Command: 30, ', trace_message_ptr^ (1, command_string_size));
      pmp$log (trace_message^ (1,trace_size), local_status);
    IFEND;

    message_content [1].address := command_string;
    message_content [1].length := command_string_size;
    nap$se_send_data (send_params.connection_fid, message_content, end_of_message, qualified_data, osc$wait,
          activity_status, local_status);
    IF NOT local_status.normal THEN
      process_send_system_error (local_status, status);
    ELSEIF activity_status.complete AND (NOT activity_status.status.normal) THEN
      process_send_system_error (activity_status.status, status);
    IFEND;
    current_send_state := wait_sendr;
  PROCEND send_batch_ss;
?? TITLE := 'send_es_err', EJECT ??

{ PURPOSE:  This procedure sends an ES command with error.

  PROCEDURE send_es_err
    (    condition_code: string (4);
     VAR status: ost$status);

    VAR
      command_id: string (2);

    status.normal := TRUE;
    command_id := es_command;
    IF condition_code = receive_err_retry THEN
      osp$set_status_abnormal (nfc$status_id, nfe$receiver_problem_retry,
          '', send_params.transfer_status);
    ELSEIF condition_code = receive_err_no_retry THEN
      osp$set_status_abnormal (nfc$status_id, nfe$receiver_problem_no_retry,
          '', send_params.transfer_status);
    ELSEIF condition_code = receive_detected_prot_err THEN
      osp$set_status_abnormal (nfc$status_id, nfe$protocol_anomaly,
          '', send_params.transfer_status);
    ELSEIF condition_code = receive_nogo THEN
      osp$set_status_abnormal (nfc$status_id, nfe$protocol_anomaly,
          '', send_params.transfer_status);
    ELSEIF condition_code = send_err_retry THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sender_problem_retry,
          '', send_params.transfer_status);
    ELSEIF condition_code = send_err_no_retry THEN
      osp$set_status_abnormal (nfc$status_id, nfe$sender_problem_no_retry,
          '', send_params.transfer_status);
    ELSEIF condition_code = send_detected_prot_err THEN
      osp$set_status_abnormal (nfc$status_id, nfe$protocol_anomaly,
          '', send_params.transfer_status);
    ELSEIF condition_code = send_nogo THEN
      osp$set_status_abnormal (nfc$status_id, nfe$protocol_anomaly,
          '', send_params.transfer_status);
    IFEND;
    active_send_error_code := condition_code (4);
    send_sender_command (command_id, condition_code, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    current_send_state := end_err_sent;
  PROCEND send_es_err;
?? TITLE := 'send_es_hold', EJECT ??

{ PURPOSE:  This procedure sends an ES command with hold.

  PROCEDURE send_es_hold
    (    condition_code: string (4);
     VAR status: ost$status);

    VAR
      command_id: string (2);

    status.normal := TRUE;
    command_id := es_command;
    send_sender_command (command_id, condition_code, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    current_send_state := wait_resume;
  PROCEND send_es_hold;
?? TITLE := 'send_es_ok', EJECT ??

{ PURPOSE:  This procedure sends an ES command with no error.

  PROCEDURE send_es_ok
    (VAR status: ost$status);

    VAR
      command_id: string (2),
      condition_code: string (4);

    status.normal := TRUE;
    command_id := es_command;
    condition_code := ok;
    send_sender_command (command_id, condition_code, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    current_send_state := end_ok_sent;
  PROCEND send_es_ok;
?? TITLE := 'send_file_blocks', EJECT ??

{ PURPOSE:  This procedure transfers the file data in blocks.

  PROCEDURE send_file_blocks
    (VAR status: ost$status);

    CONST
      event_check_window = 1;

    VAR
      activity_status: ost$activity_status,
      block_count: integer,
      data_header: ^batch_data_header,
      end_of_message: boolean,
      ignore_status: ost$status,
      local_status: ost$status,
      message_content: array [1 .. 2] of nat$data_fragment,
      qualified_data: boolean,
      trace_message: string(256),
      trace_size: integer;

?? NEWTITLE := '  output_handler', EJECT ??

{ PURPOSE:  This is the condition handler for send_file_blocks.

    PROCEDURE output_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      activity_status.complete := ((condition.selector = pmc$system_conditions) OR
            (condition.selector = jmc$job_resource_condition) OR
            (condition.selector = mmc$segment_access_condition) OR
            (condition.selector = ifc$interactive_condition));
      pmp$continue_to_cause (pmc$execute_standard_procedure, status);

    PROCEND output_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    IF  access_method = nfc$am_rhfam  THEN
      osp$set_status_abnormal (nfc$status_id, nfe$application_protocol_error, '', status);
      RETURN; {----->
    IFEND;

    local_status.normal := TRUE;
    data_header := ^header_buffer;
    block_count := 0;
    message_content [1].address := data_header;
    message_content [1].length := data_header_length;
    osp$establish_condition_handler (^output_handler, FALSE);

  /repeat_send/
    WHILE send_transfer_progress.remaining_data > 0 DO
      IF send_params.block_size < send_transfer_progress.remaining_data THEN
        message_content [2].length := send_params.block_size;
        data_header^.data_block_clarifier := nfc$dbc_no_mark;
        data_header^.byte_count := send_params.block_size;
      ELSE
        message_content [2].length := send_transfer_progress.remaining_data;
        data_header^.data_block_clarifier := nfc$dbc_eoi_bit;
        data_header^.byte_count := send_transfer_progress.remaining_data;
      IFEND;
        data_header^.reserved := 0;
        data_header^.unused_bit_count := 0;
      NEXT send_transfer_progress.current_byte_address: [[REP message_content [2].length OF cell]] IN
            send_transfer_progress.file_byte_address;
      message_content [2].address := send_transfer_progress.current_byte_address;
      qualified_data := FALSE;
      end_of_message := TRUE;
      IF protocol_trace THEN
        STRINGREP (trace_message, trace_size, '**** NFM$RHF_SEND_FILE: SND Data Block - Size:',
              message_content [2].length);
        pmp$log (trace_message (1,trace_size), ignore_status);
      IFEND;
      nap$se_send_data (send_params.connection_fid, message_content, end_of_message, qualified_data, osc$wait,
            activity_status, local_status);
      IF NOT local_status.normal THEN
        IF (send_params.protocol_version = nfc$p00_b101) AND
              (local_status.condition = nae$data_transfer_timeout) THEN
          RETURN; {----->
        IFEND;
        output_debug_message (' ERROR - SE_send_data - status', local_status);
        process_send_system_error (local_status, status);
        RETURN; {----->
      ELSEIF activity_status.complete AND (NOT activity_status.status.normal) THEN
        IF (send_params.protocol_version = nfc$p00_b101) AND
              (activity_status.status.condition = nae$data_transfer_timeout) THEN
          RETURN; {----->
        IFEND;
        output_debug_message (' ERROR - SE_send_data - activity_status', activity_status.status);
        process_send_system_error (activity_status.status, status);
        RETURN; {----->
      IFEND;
      send_transfer_progress.remaining_data := send_transfer_progress.remaining_data -
            message_content [2].length;
      data_header^.application_block_number := data_header^.application_block_number + 1;
      block_count := block_count + 1;
      IF block_count = event_check_window THEN
        block_count := 0;
        IF send_transfer_progress.remaining_data > 0 THEN
          nap$await_data_available (send_params.connection_fid, 0, 0, local_status);
          IF NOT local_status.normal THEN
            IF local_status.condition = nae$no_data_available THEN
              CYCLE /repeat_send/; {----->
            ELSEIF local_status.condition = nae$connection_terminated THEN
              osp$set_status_abnormal (nfc$status_id, nfe$connection_closed_by_peer, '', status);
              send_params.status := status;
              RETURN; {----->
            ELSE
              output_debug_message (' ERROR - Await_data_available ', local_status);
              process_send_system_error (local_status, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
            IFEND;
          IFEND;
          RETURN; {----->
        IFEND;
      IFEND;
    WHILEND /repeat_send/;
    send_params.transfer_status.normal := TRUE;

{   Send protocol command ES - end sender data ok.

    send_es_ok (status);
    send_transfer_progress.general_position := transfer_complete;
  PROCEND send_file_blocks;
?? TITLE := 'send_file_label', EJECT ??

{ PURPOSE:  This procedure sends the file label.

  PROCEDURE send_file_label
    (VAR status: ost$status);

    VAR
      activity_status: ost$activity_status,
      contains_data: boolean,
      data_block: ^SEQ ( * ),
      data_block_size: 0 .. 8fffffff(16),
      data_header: ^batch_data_header,
      data_sent: rft$bytes_transferred,
      end_of_message: boolean,
      file_attributes: ^amt$get_attributes,
      file_label: ^SEQ ( * ),
      ignore_status: ost$status,
      label_size: 0 .. 7fffffff(16),
      local_file: boolean,
      local_status: ost$status,
      message_content_nam: array [1 .. 2] of nat$data_fragment,
      message_content_rhfam: array [1 .. 1] of rft$data_fragment,
      old_file: boolean,
      open_position: ^amt$open_position,
      qualified_data: boolean,
      trace_message: string(256),
      trace_size: integer;

    status.normal := TRUE;
    local_status.normal := TRUE;
    PUSH file_attributes: [1 .. 2];
    file_attributes^ [1].key := amc$open_position;
    file_attributes^ [2].key := amc$ring_attributes;
    amp$get_file_attributes (transfer_file, file_attributes^, local_file, old_file, contains_data,
          local_status);
    IF NOT local_status.normal THEN
      process_send_system_error (local_status, status);
      RETURN; {----->
    IFEND;
    IF send_params.validation_ring > file_attributes^ [2].ring_attributes.r2 THEN
      amp$set_local_name_abnormal (send_params.file_name, ame$ring_validation_error, amc$open_req, '',
            local_status);
      process_send_system_error (local_status, status);
      RETURN; {----->
    IFEND;
    srp$fetch_system_label_size (transfer_file, label_size, local_status);
    IF NOT local_status.normal THEN
      process_send_system_error (local_status, status);
      RETURN; {----->
    IFEND;
    open_position := ^file_attributes^ [1].open_position;
    data_block_size := #SIZE (open_position^) + label_size;
    PUSH data_block: [[REP data_block_size OF cell]];
    RESET data_block;
    NEXT open_position IN data_block;
    NEXT file_label: [[REP label_size OF cell]] IN data_block;
    open_position^ := file_attributes^ [1].open_position;
    srp$fetch_system_label (transfer_file, file_label^, local_status);
    IF NOT local_status.normal THEN
      process_send_system_error (local_status, status);
      RETURN; {----->
    IFEND;
    end_of_message := TRUE;
    IF  access_method = nfc$am_nam  THEN
      data_header := ^header_buffer;
      data_header^.data_block_clarifier := nfc$dbc_ve_label;
      data_header^.byte_count := data_block_size;
      data_header^.application_block_number := 0;
      data_header^.reserved := 0;
      data_header^.unused_bit_count := 0;
      message_content_nam [1].address := data_header;
      message_content_nam [1].length := data_header_length;
      message_content_nam [2].address := data_block;
      message_content_nam [2].length := data_block_size;
      qualified_data := FALSE;
      send_transfer_progress.general_position := label_in_progress;
      nap$se_send_data (send_params.connection_fid, message_content_nam, end_of_message, qualified_data,
            osc$wait, activity_status, local_status);
    ELSE
      message_content_rhfam [1].address := data_block;
      message_content_rhfam [1].length := data_block_size;
      rfp$send_data (send_params.connection_fid, rfc$record_mode, ^message_content_rhfam, end_of_message,
            osc$wait, activity_status, data_sent, local_status);
    IFEND;
    IF protocol_trace THEN
      STRINGREP (trace_message, trace_size, '**** NFM$RHF_SEND_FILE: SND File Label - Size:',
            data_block_size);
      pmp$log (trace_message (1,trace_size), ignore_status);
    IFEND;
    IF NOT local_status.normal THEN
      process_send_system_error (local_status, status);
      RETURN; {----->
    ELSEIF activity_status.complete AND (NOT activity_status.status.normal) THEN
      process_send_system_error (activity_status.status, status);
      RETURN; {----->
    IFEND;
    send_transfer_progress.general_position := label_complete;
  PROCEND send_file_label;
?? TITLE := 'send_ps_command', EJECT ??

{ PURPOSE:  This procedure sends a PS command.

  PROCEDURE send_ps_command
    (    new_line_number: jmt$output_file_position;
         new_byte_position: jmt$output_file_position;
         user_message: ^string ( * );
         preview_message: reposition_preview_message;
     VAR status: ost$status);

    CONST
      file_position_parameter_prefix = '57S',
      ps_command_id = '39',
      user_message_parameter_prefix = '08S';

    VAR
      activity_status: ost$activity_status,
      array_index: 1 .. 9,
      basic_ps_command: ^string ( * ),
      byte_string: ost$string,
      end_of_message: boolean,
      file_position_length: 3 .. 29,
      i: 1 .. 3,
      line_string: ost$string,
      local_status: ost$status,
      max_data_array_index: 1 .. 9,
      message_content_pointer: ^array [1 .. * ] of nat$data_fragment,
      message_length_string: string (3),
      parameter_count: 1 .. 5,
      parameter_count_string: string (2),
      position_length_string: string (3),
      preview_header: array [1 .. 3] of string (6),
      preview_length_string: array [1 .. 3] of string (3),
      qualified_data: boolean,
      string_index: 1 .. 1200,
      user_message_header: string (6),
      user_message_length: 0 .. 999;

    status.normal := TRUE;
    local_status.normal := TRUE;
    clp$convert_integer_to_string (new_line_number - 1, 10, FALSE, line_string, local_status);
    IF NOT local_status.normal THEN
      process_send_system_error (local_status, status);
      RETURN; {----->
    IFEND;
    clp$convert_integer_to_string (new_byte_position - 1, 10, FALSE, byte_string, local_status);
    IF NOT local_status.normal THEN
      process_send_system_error (local_status, status);
      RETURN; {----->
    IFEND;
    file_position_length := line_string.size + byte_string.size + 1;
    clp$convert_integer_to_rjstring (file_position_length, 10, FALSE, '0', position_length_string,
          local_status);
    IF NOT local_status.normal THEN
      process_send_system_error (local_status, status);
      RETURN; {----->
    IFEND;
    parameter_count := 1;
    max_data_array_index := 1;
    IF user_message <> NIL THEN
      parameter_count := parameter_count + 1;
      max_data_array_index := max_data_array_index + 2;
      user_message_length := STRLENGTH (user_message^);
      clp$convert_integer_to_rjstring (user_message_length, 10, FALSE, '0', message_length_string,
            local_status);
      IF NOT local_status.normal THEN
        process_send_system_error (local_status, status);
        RETURN; {----->
      IFEND;
    ELSE
      user_message_length := 0;
    IFEND;

  /set_preview_lengths/
    FOR i := 1 TO 3 DO
      IF preview_message [i].message <> NIL THEN
        parameter_count := parameter_count + 1;
        max_data_array_index := max_data_array_index + 2;
        clp$convert_integer_to_rjstring (preview_message [i].
              length, 10, FALSE, '0', preview_length_string [i], local_status);
        IF NOT local_status.normal THEN
          process_send_system_error (local_status, status);
          RETURN; {----->
        IFEND;
      ELSE
        EXIT /set_preview_lengths/; {----->
      IFEND;
    FOREND /set_preview_lengths/;
    clp$convert_integer_to_rjstring (parameter_count, 10, FALSE, '0', parameter_count_string, local_status);
    IF NOT local_status.normal THEN
      process_send_system_error (local_status, status);
      RETURN; {----->
    IFEND;
    PUSH message_content_pointer: [1 .. max_data_array_index];
    PUSH basic_ps_command: [file_position_length + 10];
    basic_ps_command^ (1, 2) := ps_command_id;
    basic_ps_command^ (3, 2) := parameter_count_string;
    basic_ps_command^ (5, 3) := file_position_parameter_prefix;
    basic_ps_command^ (8, 3) := position_length_string;
    basic_ps_command^ (11, byte_string.size) := byte_string.value (1, byte_string.size);
    string_index := 11 + byte_string.size;
    basic_ps_command^ (string_index, 1) := ',';
    string_index := string_index + 1;
    basic_ps_command^ (string_index, line_string.size) := line_string.value (1, line_string.size);
    string_index := string_index + line_string.size;
    message_content_pointer^ [1].address := basic_ps_command;
    message_content_pointer^ [1].length := string_index - 1;
    array_index := 2;
    IF user_message_length > 0 THEN
      user_message_header (1, 3) := user_message_parameter_prefix;
      user_message_header (4, 3) := message_length_string;
      message_content_pointer^ [array_index].address := ^user_message_header;
      message_content_pointer^ [array_index].length := 6;
      array_index := array_index + 1;
      message_content_pointer^ [array_index].address := user_message;
      message_content_pointer^ [array_index].length := user_message_length;
      array_index := array_index + 1;
    IFEND;

  /prepare_preview_message/
    FOR i := 1 TO 3 DO
      IF preview_message [i].message <> NIL THEN
        preview_header [i] (1, 3) := user_message_parameter_prefix;
        preview_header [i] (4, 3) := preview_length_string [i];
        message_content_pointer^ [array_index].address := ^preview_header [i];
        message_content_pointer^ [array_index].length := 6;
        array_index := array_index + 1;
        message_content_pointer^ [array_index].address := preview_message [i].message;
        message_content_pointer^ [array_index].length := preview_message [i].length;
        array_index := array_index + 1;
      ELSE
        EXIT /prepare_preview_message/; {----->
      IFEND;
    FOREND /prepare_preview_message/;
    qualified_data := TRUE;
    end_of_message := TRUE;
    nap$se_send_data (send_params.connection_fid, message_content_pointer^, end_of_message, qualified_data,
          osc$wait, activity_status, local_status);
    IF NOT local_status.normal THEN
      process_send_system_error (local_status, status);
    ELSEIF activity_status.complete AND (NOT activity_status.status.normal) THEN
      process_send_system_error (activity_status.status, status);
    IFEND;
    send_transfer_progress.general_position := file_in_progress;
    position_valid := TRUE;
    current_send_state := wait_resume;
  PROCEND send_ps_command;
?? TITLE := 'send_rhf_file_blocks', EJECT ??

{ PURPOSE:  This procedure transfers an RHF-structured file on a
{           record-by-record basis.

  PROCEDURE send_rhf_file_blocks
    (VAR status: ost$status);

    VAR
      activity_status: ost$activity_status,
      byte_address: amt$file_byte_address,
      data_header: ^batch_data_header,
      data_sent: rft$bytes_transferred,
      end_of_message: boolean,
      file_position: amt$file_position,
      ignore_status: ost$status,
      local_status: ost$status,
      message_content_nam: array [1 .. 2] of nat$data_fragment,
      message_content_rhfam: array [1 .. 1] of rft$data_fragment,
      record_area: ^SEQ ( * ),
      record_length: amt$max_record_length,
      rhfam_attributes: ^rft$change_attributes,
      trace_message: string(256),
      trace_size: integer,
      transfer_count: amt$transfer_count;

?? NEWTITLE := '  output_handler', EJECT ??

{ PURPOSE:  This is the condition handler for send_rhf_file_blocks.

    PROCEDURE output_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      activity_status.complete := ((condition.selector =
            pmc$system_conditions) OR (condition.selector =
            jmc$job_resource_condition) OR (condition.selector =
            mmc$segment_access_condition) OR (condition.selector =
            ifc$interactive_condition));
      pmp$continue_to_cause (pmc$execute_standard_procedure, status);

    PROCEND output_handler;
?? OLDTITLE, EJECT ??
{   Begin send_rhf_file_blocks

    status.normal := TRUE;
    local_status.normal := TRUE;
    file_position := amc$boi;
    PUSH record_area: [[REP send_params.block_size OF cell]];

    IF  access_method = nfc$am_nam  THEN
      data_header := ^header_buffer;
      message_content_nam [1].address := data_header;
      message_content_nam [1].length := data_header_length;
      message_content_nam [2].address := record_area;
    ELSE
      PUSH rhfam_attributes: [1 .. 1];
      rhfam_attributes^ [1].key := rfc$send_record_terminator;
      message_content_rhfam [1].address := record_area;
    IFEND;

    osp$establish_condition_handler (^output_handler, FALSE);

  /process_record/
    WHILE file_position <> amc$eoi DO

      amp$get_partial (sender_file_id, record_area, send_params.block_size,
            record_length, transfer_count, byte_address, file_position,
            amc$no_skip, local_status);
      IF NOT local_status.normal THEN
        process_send_system_error (local_status, status);
        RETURN; {----->
      IFEND;

      IF  access_method = nfc$am_nam  THEN

        CASE file_position OF
        = amc$mid_record =
          data_header^.data_block_clarifier := nfc$dbc_no_mark;
        = amc$eor =
          data_header^.data_block_clarifier := nfc$dbc_eor;
        = amc$eop =
          data_header^.data_block_clarifier := nfc$dbc_eof;
        = amc$eoi =
          data_header^.data_block_clarifier := nfc$dbc_eoi_bit;
        ELSE
          pmp$log ('send_rhf_file_blocks CASE', local_status);
          osp$set_status_abnormal (nfc$status_id, nfe$sender_problem_no_retry,
              '', local_status);
          process_send_system_error (local_status, status);
          RETURN; {----->
        CASEND;

        data_header^.byte_count := transfer_count;
        data_header^.reserved := 0;
        data_header^.unused_bit_count := 0;
        message_content_nam [2].length := transfer_count;

        IF protocol_trace THEN
          STRINGREP (trace_message, trace_size, '**** NFM$RHF_SEND_FILE: SND Data Block - Size:',
                transfer_count);
          pmp$log (trace_message (1,trace_size), ignore_status);
        IFEND;
        nap$se_send_data (send_params.connection_fid, message_content_nam, TRUE, FALSE, osc$wait,
              activity_status, local_status);
        IF NOT local_status.normal THEN
          output_debug_message (' ERROR - SE_send_data - status', local_status);
          process_send_system_error (local_status, status);
          RETURN; {----->
        ELSEIF activity_status.complete AND (NOT activity_status.status.normal) THEN
          output_debug_message (' ERROR - SE_send_data - activity_status', activity_status.status);
          process_send_system_error (activity_status.status, status);
          RETURN; {----->
        IFEND;
        data_header^.application_block_number := data_header^.application_block_number + 1;

{       Check for incoming commands.

        IF file_position <> amc$eoi THEN
          nap$await_data_available (send_params.connection_fid, 0, 0,
                local_status);
          IF local_status.normal THEN
            {  Peer application has sent a command - stop everything
            RETURN; {----->
          ELSE
            IF local_status.condition = nae$no_data_available THEN
              CYCLE /process_record/; {----->
            ELSEIF local_status.condition = nae$connection_terminated THEN
              osp$set_status_abnormal (nfc$status_id,
                    nfe$connection_closed_by_peer, '', status);
              send_params.status := status;
              RETURN; {----->
            ELSE
              output_debug_message (' ERROR - Await_data_available ',
                    local_status);
              process_send_system_error (local_status, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
            IFEND;
          IFEND;
        IFEND;

      ELSE { access_method = nfc$am_rhfam

        CASE file_position OF
        = amc$mid_record =
          end_of_message := FALSE;
        = amc$eor =
          rhfam_attributes^ [1].send_record_terminator := rfc$rm_eor;
          end_of_message := TRUE;
        = amc$eop =
          rhfam_attributes^ [1].send_record_terminator := rfc$rm_eof;
          end_of_message := TRUE;
        = amc$eoi =
          rhfam_attributes^ [1].send_record_terminator := rfc$rm_eoi;
          end_of_message := TRUE;
        ELSE
          pmp$log ('send_rhf_file_blocks CASE', local_status);
          osp$set_status_abnormal (nfc$status_id, nfe$sender_problem_no_retry, '', local_status);
          process_send_system_error (local_status, status);
          RETURN; {----->
        CASEND;

        IF end_of_message THEN
          rfp$store (send_params.connection_fid, rhfam_attributes^, local_status);
          IF NOT local_status.normal THEN
            output_debug_message (' ERROR - rfp$store', local_status);
            process_send_system_error (local_status, status);
            RETURN; {----->
          IFEND;
        IFEND;

        message_content_rhfam [1].length := transfer_count;

        IF protocol_trace THEN
          STRINGREP (trace_message, trace_size, '**** NFM$RHF_SEND_FILE: SND Data Block - Size:',
                transfer_count);
          pmp$log (trace_message (1,trace_size), ignore_status);
        IFEND;
        rfp$send_data (send_params.connection_fid, rfc$record_mode, ^message_content_rhfam, end_of_message,
              osc$wait, activity_status, data_sent, local_status);
        IF NOT local_status.normal THEN
          output_debug_message (' ERROR - rfp$send_data - status', local_status);
          process_send_system_error (local_status, status);
          RETURN; {----->
        ELSEIF activity_status.complete AND (NOT activity_status.status.normal) THEN
          output_debug_message (' ERROR - rfp$send_data - activity_status', activity_status.status);
          process_send_system_error (activity_status.status, status);
          RETURN; {----->
        IFEND;

      IFEND;

    WHILEND /process_record/;

    send_params.transfer_status.normal := TRUE;
    send_transfer_progress.general_position := transfer_complete;

{   Send protocol command ES - end sender data ok.

    send_es_ok (status);

  PROCEND send_rhf_file_blocks;
?? TITLE := 'send_sender_command', EJECT ??

{ PURPOSE:  This procedure sends data to the peer application.

  PROCEDURE send_sender_command
    (    command_id: string (2);
         condition_code: string (4);
     VAR status: ost$status);

    CONST
      data_phase_parameter_count = '01',
      data_phase_parameter_prefix = '23S004';

    VAR
      activity_status: ost$activity_status,
      command_block: data_phase_command,
      data_sent: rft$bytes_transferred,
      end_of_message: boolean,
      local_status: ost$status,
      message_content_nam: array [1 .. 1] of nat$data_fragment,
      message_content_rhfam: array [1 .. 1] of rft$data_fragment,
      qualified_data: boolean,
      trace_message: string(256),
      trace_size: integer;

    IF protocol_trace THEN
      STRINGREP (trace_message, trace_size, '**** NFM$RHF_SEND_FILE:',
            ' SND Command: ', command_id, ', ',
            data_phase_parameter_count, data_phase_parameter_prefix,
            condition_code);
      pmp$log (trace_message (1,trace_size), local_status);
    IFEND;

    status.normal := TRUE;
    local_status.normal := TRUE;
    qualified_data := TRUE;
    end_of_message := TRUE;
    command_block.command_id := command_id;
    command_block.parameter_count := data_phase_parameter_count;
    command_block.parameter_prefix := data_phase_parameter_prefix;
    command_block.condition_code := condition_code;
    IF  access_method = nfc$am_nam  THEN
      message_content_nam [1].address := ^command_block;
      message_content_nam [1].length := command_block_size;
      nap$se_send_data (send_params.connection_fid, message_content_nam, end_of_message, qualified_data,
            osc$wait, activity_status, local_status);
    ELSE
      message_content_rhfam [1].address := ^command_block;
      message_content_rhfam [1].length := command_block_size;
      rfp$send_data (send_params.connection_fid, rfc$message_mode, ^message_content_rhfam, end_of_message,
            osc$wait, activity_status, data_sent, local_status);
    IFEND;
    IF NOT local_status.normal THEN
      process_send_system_error (local_status, status);
    ELSEIF activity_status.complete AND (NOT activity_status.status.normal) THEN
      process_send_system_error (activity_status.status, status);
    IFEND;
  PROCEND send_sender_command;
?? TITLE := 'send_ss', EJECT ??

{ PURPOSE:  This procedure sends an SS command.

  PROCEDURE send_ss
    (VAR status: ost$status);

    VAR
      command_id: string (2),
      condition_code: string (4);

    status.normal := TRUE;
    command_id := ss_command;
    condition_code := ok;
    send_sender_command (command_id, condition_code, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    IF  nfc$ss_ack_required IN send_params.facilities  THEN
      current_send_state := wait_sendr;
    ELSE
      current_send_state := ss_ack_not_required;
    IFEND;
  PROCEND send_ss;
?? TITLE := '  set_status', EJECT ??

{ PURPOSE:  This procedure sets status in the different places the
{           caller expects to see it.

  PROCEDURE set_status
    (VAR send_params: transfer_params;
     VAR transfer_status: ost$status;
     VAR proc_status: ost$status);

    IF send_params.status.normal THEN
      proc_status.normal := TRUE;
    ELSE
      proc_status := send_params.status;
    IFEND;

    IF send_params.transfer_status.normal THEN
      transfer_status.normal := TRUE;
    ELSE
      transfer_status := send_params.transfer_status;
    IFEND;

  PROCEND set_status;
?? TITLE := 'start_send_file', EJECT ??

{ PURPOSE:  This procedure initializes the send_file process.

  PROCEDURE start_send_file
    (VAR status: ost$status);

    VAR
      access_selections_pointer: ^fst$attachment_options,
      activity_status: ost$activity_status,
      contains_data: boolean,
      data_header: ^batch_data_header,
      data_sent: rft$bytes_transferred,
      end_of_message: boolean,
      ignore_status: ost$status,
      local_file: boolean,
      local_status: ost$status,
      message_content_nam: array [1 .. 2] of nat$data_fragment,
      message_content_rhfam: array [1 .. 1] of rft$data_fragment,
      old_file: boolean,
      override_attributes: ^fst$file_cycle_attributes,
      qualified_data: boolean,
      segment_cell: amt$segment_pointer,
      segment_pointer: amt$segment_pointer,
      trace_message: string(256),
      trace_size: integer;

    status.normal := TRUE;
    IF (send_params.protocol_version = nfc$p00_b101) OR
       (send_params.transfer_mode = nfc$rhf_structured_mode) THEN
      RETURN; {----->
    IFEND;

    local_status.normal := TRUE;

    IF NOT queue_file THEN
      IF sender_file_id <> amv$nil_file_identifier THEN
        fsp$close_file (sender_file_id, local_status);
        IF NOT local_status.normal THEN
          process_send_system_error (local_status, status);
          RETURN; {----->
        IFEND;
        sender_file_id := amv$nil_file_identifier;
        #SPOIL (sender_file_id);
      IFEND;
      PUSH override_attributes: [1 .. 3];
      override_attributes^ [1].selector := fsc$record_type;
      override_attributes^ [1].record_type := amc$undefined;
      override_attributes^ [2].selector := fsc$block_type;
      override_attributes^ [2].block_type := amc$system_specified;
      override_attributes^ [3].selector := fsc$file_organization;
      override_attributes^ [3].file_organization := amc$sequential;

      PUSH access_selections_pointer: [1 .. 1];
      access_selections_pointer^ [1].selector := fsc$access_and_share_modes;
      access_selections_pointer^ [1].access_modes.selector := fsc$specific_access_modes;
      access_selections_pointer^ [1].access_modes.value := $fst$file_access_options [fsc$read];
      access_selections_pointer^ [1].share_modes.selector := fsc$determine_from_access_modes;

      fsp$open_file (transfer_file, amc$segment, access_selections_pointer, NIL, NIL, NIL,
            override_attributes, sender_file_id, local_status);
      IF NOT local_status.normal THEN
        process_send_system_error (local_status, status);
        RETURN; {----->
      IFEND;
    IFEND;

    amp$get_segment_pointer (sender_file_id, amc$sequence_pointer, segment_pointer, local_status);
    IF NOT local_status.normal THEN
      process_send_system_error (local_status, status);
      RETURN; {----->
    ELSE
      amp$get_segment_pointer (sender_file_id, amc$cell_pointer, segment_cell, local_status);
      IF NOT local_status.normal THEN
        process_send_system_error (local_status, status);
        RETURN; {----->
      ELSE
        mmp$set_access_selections (segment_cell.cell_pointer, mmc$as_sequential, local_status);
        IF NOT local_status.normal THEN
          process_send_system_error (local_status, status);
          RETURN; {----->
        IFEND;
      IFEND;
    IFEND;
    transfer_file_size := #SIZE (segment_pointer.sequence_pointer^);
    send_transfer_progress.remaining_data := transfer_file_size;
    send_transfer_progress.general_position := file_in_progress;

    IF  access_method = nfc$am_nam  THEN
      data_header := ^header_buffer;
      IF send_params.block_size = 99999999 THEN
        data_header^.data_block_clarifier := nfc$dbc_eoi_bit;
        data_header^.byte_count := 0;
        data_header^.application_block_number := 0;
        data_header^.reserved := 0;
        data_header^.unused_bit_count := 0;
        message_content_nam [1].address := data_header;
        message_content_nam [1].length := data_header_length;
        message_content_nam [2].address := segment_pointer.sequence_pointer;
        message_content_nam [2].length := send_transfer_progress.remaining_data;
        end_of_message := TRUE;
        qualified_data := FALSE;
        nap$se_send_data (send_params.connection_fid, message_content_nam, end_of_message, qualified_data,
              osc$wait, activity_status, local_status);
      IFEND;
    ELSE
      end_of_message := TRUE;
      message_content_rhfam [1].address := segment_pointer.sequence_pointer;
      message_content_rhfam [1].length := send_transfer_progress.remaining_data;
      rfp$send_data (send_params.connection_fid, rfc$record_mode, ^message_content_rhfam, end_of_message,
            osc$wait, activity_status, data_sent, local_status);
    IFEND;
    IF  (access_method = nfc$am_rhfam)  OR (send_params.block_size = 99999999) THEN
      IF protocol_trace THEN
        STRINGREP (trace_message, trace_size, '**** NFM$RHF_SEND_FILE: SND Data Block - Size:',
              send_transfer_progress.remaining_data);
        pmp$log (trace_message (1,trace_size), ignore_status);
      IFEND;
      IF NOT local_status.normal THEN
        process_send_system_error (local_status, status);
        RETURN; {----->
      ELSEIF activity_status.complete AND (NOT activity_status.status.normal) THEN
        process_send_system_error (activity_status.status, status);
        RETURN; {----->
      IFEND;
      send_transfer_progress.general_position := transfer_complete;
      send_params.transfer_status.normal := TRUE;

{     Send protocol command ES - end sender data ok.

      send_es_ok (status);
    ELSE
      data_header^.application_block_number := 0;
      send_transfer_progress.file_byte_address := segment_pointer.sequence_pointer;
      RESET send_transfer_progress.file_byte_address;
    IFEND;
  PROCEND start_send_file;
?? OLDTITLE ??
MODEND nfm$rhf_send_file;
*DECK DECK=NFM$SOU_ASYNCHRONOUS_TASK EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, INDENT := 2) ??
?? SET (LIST := ON, LISTCTS := OFF) ??
?? NEWTITLE := 'Batch I/O Station Operator Utility: Network Asynchronous Output Procesor' ??
MODULE nfm$sou_asynchronous_task;

{
{ PURPOSE:
{   This module runs as an asynchronous task for the Operate_Station
{   command utility.  Its purpose is to receive output from CDCNET and
{   SCFS, and manage display output to the station operator.
{

?? NEWTITLE := '  Global declarations' ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$path_display_chunks
*copyc clc$standard_file_names
*copyc nfd$sou_intertask_communication
*copyc nfe$sou_condition_codes
*copyc nft$device_control_resp_codes
*copyc nft$message_kind
*copyc nft$message_sequence
*copyc nft$parameter_value_length
*copyc nft$select_file_response
*copyc nft$sou_message_parameter_types
*copyc oss$job_paged_literal
*copyc ost$i_wait
*copyc ost$status
*copyc pmt$program_parameters
?? POP ??
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$new_display_line
*copyc clp$open_display
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc nap$se_receive_data
*copyc nfp$begin_asynchronous_task
*copyc nfp$end_async_communication
*copyc nfp$get_async_task_message
*copyc nfp$get_parameter_value_length
*copyc nfp$put_async_task_message
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_message
*copyc osp$i_await_activity_completion
*copyc osp$set_status_abnormal

?? EJECT ??
*copy clv$display_variables

?? TITLE := '  Global variables', EJECT ??

  TYPE
    nft$queued_operator_message = RECORD
      link: ^nft$queued_operator_message,
      station: ost$name,
      device: ost$name,
      text: STRING (* <= nfc$maximum_message_length),
    RECEND,

    nft$parameter_kind = 0 .. 07f(16),

    nft$parameter_type = PACKED RECORD
      length_indicated: BOOLEAN,
      param: nft$parameter_kind,
    RECEND;

  VAR
    message: ^nft$message_sequence,
    message_length: INTEGER,
    msg_byte_count: INTEGER,
    message_type: ^nft$message_kind;

  VAR
    operator_message_list: [STATIC] ^nft$queued_operator_message := NIL;

  VAR
    hold_display: BOOLEAN,
    network_file_open: BOOLEAN,
    network_file: ost$name,
    network_file_id: amt$file_identifier,
    parent_task_id: pmt$task_id,
    local_queue_id: pmt$queue_connection,
    transfer_count: 0 .. nfc$max_transfer_size;

  VAR
    peer_operations: [READ] ARRAY [nat$se_peer_operation_kind] OF STRING (peer_operation_size) :=
        [ {nac$se_send_data} '',
          {nac$se_interrupt} 'Interrupt',
          {nac$se_synchronize} 'Synchronize',
          {nac$se_synchronize_confirm} 'Synchronize Confirm'  ];

    CONST
      peer_operation_size = 19;

?? TITLE := '  [XDCL] nfp$sou_asynchronous_task', EJECT ??

  PROCEDURE [XDCL] nfp$sou_asynchronous_task (parameters: pmt$program_parameters;
    VAR status: ost$status);

?? NEWTITLE := '  abort_handler', EJECT ??

  PROCEDURE abort_handler (condition: pmt$condition;
        condition_descriptor: ^pmt$condition_information;
        save_area: ^ost$stack_frame_save_area;
    VAR handler_status: ost$status);

      end_async_task;
      handler_status.normal := TRUE;

    PROCEND abort_handler;

?? TITLE := '  end_async_task', EJECT ??

{
{   The purpose of this procedure is to clean up intertask
{   communication with the originating task, and end processing.
{

  PROCEDURE end_async_task;

    VAR
      req: nft$sou_intertask_request,
      end_status: ost$status;

    IF network_file_open THEN
      end_status.normal := TRUE;
      fsp$close_file (network_file_id, end_status);
      network_file_open := FALSE;
    IFEND;

    end_status.normal := TRUE;
    nfp$end_async_communication (FALSE, end_status);
    task_ended := TRUE;

    IF NOT status.normal THEN
      end_status.normal := TRUE;
      osp$generate_message (status, end_status);
    IFEND;

  PROCEND end_async_task;

?? OLDTITLE, EJECT ??

    VAR
      wait_list: ^ost$i_wait_list,
      ready_index: INTEGER,
      intertask_request: nft$sou_intertask_request,
      intertask_response: nft$sou_intertask_response,
      hold_task: BOOLEAN,
      task_ended: BOOLEAN,
      local_status: ost$status;


    network_file_open := FALSE;
    task_ended := FALSE;
    hold_task := FALSE;

    nfp$begin_asynchronous_task (parameters, parent_task_id, local_queue_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE message: [[REP nfc$maximum_message_length OF CELL]];
    PUSH wait_list: [1 .. 2];

    osp$establish_block_exit_hndlr (^abort_handler);

 /async_process/
    BEGIN
      wait_list^[1].activity := pmc$i_await_local_queue_message;
      wait_list^[1].qid := local_queue_id;
      wait_list^[2].activity := osc$i_null_activity;
      osp$i_await_activity_completion (wait_list^, ready_index, status);
      IF NOT status.normal THEN
        EXIT /async_process/;
      IFEND;

      nfp$get_async_task_message (parent_task_id, ^intertask_request, #SIZE (intertask_request), 0,
            transfer_count, status);
      IF status.normal AND ((intertask_request.request <> nfc$sou_start_task) OR (transfer_count = 0)) THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sou_invalid_intertask_req, '', status);
      IFEND;
      IF NOT status.normal THEN
        EXIT /async_process/;
      IFEND;

      network_file := intertask_request.file;
      fsp$open_file (network_file, amc$record, NIL, NIL, NIL, NIL, NIL, network_file_id, status);
      IF NOT status.normal THEN
        EXIT /async_process/;
      IFEND;

      intertask_response.response := nfc$sou_complete;
      nfp$put_async_task_message (parent_task_id, ^intertask_response, #SIZE (intertask_response), status);
      IF NOT status.normal THEN
        EXIT /async_process/;
      IFEND;

   /activity_loop/
      WHILE TRUE DO
        IF NOT hold_task THEN
          wait_list^[2].activity := nac$i_await_data_available;
          wait_list^[2].file_identifier := network_file_id;
        ELSE
          wait_list^[2].activity := osc$i_null_activity;
        IFEND;
        osp$i_await_activity_completion (wait_list^, ready_index, status);
        IF NOT status.normal THEN
          EXIT /async_process/;
        IFEND;

        IF ready_index = 1 THEN     {intertask message received}
          nfp$get_async_task_message (parent_task_id, ^intertask_request, #SIZE (intertask_request), 0,
                transfer_count, status);
          IF NOT status.normal THEN
            EXIT /async_process/;
          IFEND;
          IF transfer_count = 0  THEN
            CYCLE /activity_loop/;
          IFEND;

          IF intertask_request.request = nfc$sou_hold THEN
            hold_task := TRUE;
          ELSEIF intertask_request.request = nfc$sou_resume THEN
            hold_task := FALSE;
          ELSEIF intertask_request.request = nfc$sou_end_task THEN
            local_status.normal := TRUE;
            fsp$close_file (network_file_id, local_status);
            network_file_open := FALSE;
          ELSE {invalid request}
            osp$set_status_abnormal (nfc$status_id, nfe$sou_invalid_intertask_req, '', status);
            EXIT /async_process/;
          IFEND;

          intertask_response.response := nfc$sou_complete;
          nfp$put_async_task_message (parent_task_id, ^intertask_response,
                #SIZE (intertask_response), status);
          IF NOT status.normal THEN
            EXIT /async_process/;
          IFEND;

          IF intertask_request.request = nfc$sou_end_task THEN
            EXIT /async_process/;
          IFEND;

        ELSE     {data available on connection}
          IF NOT hold_task THEN
            get_unsolicited_output (status);
            IF NOT status.normal THEN
              EXIT /async_process/;
            IFEND;

            WHILE operator_message_list <> NIL DO
              display_operator_message (status);
              IF NOT status.normal THEN
                EXIT /async_process/;
              IFEND;
            WHILEND;
          IFEND;
        IFEND;

      WHILEND /activity_loop/;

    END /async_process/;

    end_async_task;
    osp$disestablish_cond_handler;

  PROCEND nfp$sou_asynchronous_task;

?? TITLE := '  get_unsolicited_output', EJECT ??

{
{   The purpose of this procedure is to receive a message from
{   SCFS/VE via CDCNET.
{

  PROCEDURE get_unsolicited_output (VAR status: ost$status);

    VAR
      message_received: BOOLEAN;


    get_network_message (message_received, status);
    IF NOT (status.normal AND message_received) THEN
      RETURN;
    IFEND;

    get_message_type;
    IF message_type^ = nfc$operator_message THEN
      queue_operator_message;
    IFEND;

  PROCEND get_unsolicited_output;

?? TITLE := '  get_network_message', EJECT ??

{
{   The purpose of this procedure is to get a the next message
{   from SCFS/VE via CDCNET.
{

  PROCEDURE get_network_message (VAR message_received: BOOLEAN;
    VAR status: ost$status);

    VAR
      data_area: ^nat$data_fragments,
      peer_operation: nat$se_peer_operation,
      activity_status: ost$activity_status;


    message_received := FALSE;

    PUSH data_area: [1 .. 1];
    data_area^ [1].address := message;
    data_area^ [1].length := #SIZE (message^);
    nap$se_receive_data (network_file_id, data_area^, osc$wait, peer_operation, activity_status, status);
    IF status.normal AND NOT activity_status.status.normal THEN
      status := activity_status.status;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF peer_operation.kind = nac$se_send_data THEN
      message_length := peer_operation.data_length;
      message_received := TRUE;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$sou_unexpected_network_req,
            peer_operations [peer_operation.kind], status);
    IFEND;

  PROCEND get_network_message;

?? TITLE := '  queue_operator_message', EJECT ??

{
{   The purpose of this procedure is to queue an operator
{   message from SCFS in a link list until it can be
{   displayed.
{

  PROCEDURE queue_operator_message;

*copy nft$operator_message

    VAR
      text_string: ^STRING (* <= nfc$maximum_message_length),
      name_string: ^STRING (* <= osc$max_name_size),
      device_name: ost$name,
      io_station_name: ost$name,
      parameter: ^nft$operator_message_parameter,
      value_length: INTEGER,
      queued_msg_pp: ^^nft$queued_operator_message;


    io_station_name := ' ';
    device_name := ' ';
    text_string := NIL;

    get_parameter_type (parameter);

    WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_byte_count > 0) DO
      get_parameter_length (parameter^.length_indicated, value_length);

      CASE parameter^.param OF

      = nfc$io_station_name =
        NEXT name_string: [value_length] IN message;
        io_station_name := name_string^;

      = nfc$device_name =
        NEXT name_string: [value_length] IN message;
        device_name := name_string^;

      = nfc$text =
        NEXT text_string: [value_length] IN message;

      ELSE

      CASEND;

      get_parameter_type (parameter);
    WHILEND;

    IF text_string = NIL THEN
    RETURN;
    IFEND;

    queued_msg_pp := ^operator_message_list;
    WHILE queued_msg_pp^ <> NIL DO
      queued_msg_pp := ^queued_msg_pp^^.link;
    WHILEND;
    ALLOCATE queued_msg_pp^: [STRLENGTH (text_string^)];
    queued_msg_pp^^.link := NIL;
    queued_msg_pp^^.station := io_station_name;
    queued_msg_pp^^.device := device_name;
    queued_msg_pp^^.text := text_string^;
    IF operator_message_list = NIL THEN
      operator_message_list := queued_msg_pp^;
    IFEND;

  PROCEND queue_operator_message;

?? TITLE := '  display_operator_message', EJECT ??

{
{   The purpose of this procedure is to display an unsolicited
{   message to the station operator from SCFS/VE.
{

  PROCEDURE display_operator_message (VAR status: ost$status);

*copy clv$display_variables
?? NEWTITLE := '    abort_handler', EJECT ??

    PROCEDURE abort_handler (condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      close_display;

    PROCEND abort_handler;

?? TITLE := '    close_display', EJECT ??

    PROCEDURE close_display;

      VAR
        ignore_status: ost$status;

      IF output_open THEN
        clp$close_display (display_control, ignore_status);
        output_open := FALSE;
      IFEND;

    PROCEND close_display;

?? TITLE := '    put_display_line', EJECT ??

    PROCEDURE put_display_line (label: STRING (*);
          value: STRING (*));

      VAR
        label_str: STRING (label_size);

      label_str := label;
      IF label <> ' ' THEN
        label_str (label_size - 2, 3) := ' : ';
      IFEND;

      clp$put_partial_display (display_control, label_str, clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        EXIT display_operator_message;
      IFEND;
      clp$put_partial_display (display_control, value, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        EXIT display_operator_message;
      IFEND;

    PROCEND put_display_line;


?? OLDTITLE, EJECT ??

    CONST
      device_label = 'Device   : ',
      device_label_size = 11,
      unit_separator = $CHAR (01f(16)),
      label_size = 31;

    VAR
      output_file: [READ] clt$file := [clc$standard_output],
      q_msg: ^nft$queued_operator_message,
      labl: ost$name,
      msg_size: 0 .. osc$max_string_size,
      line_size: 0 .. osc$max_string_size,
      i : 1 .. osc$max_string_size,
      display_control: clt$display_control,
      output_open: BOOLEAN,
      start_pos: 1..80,
      str_length: 0 .. osc$max_name_size,
      text: string (80),
      text_length: 0..80;


    IF operator_message_list <> NIL THEN

  /display/
    BEGIN
      output_open := FALSE;
      osp$establish_block_exit_hndlr (^abort_handler);
      clp$open_display (output_file, NIL, display_control, status);
      IF NOT status.normal THEN
        osp$disestablish_cond_handler;
        RETURN;
      IFEND;
      output_open := TRUE;
      IF display_control.page_width < clc$narrow_page_width THEN
        clv$page_width := clc$narrow_page_width;
      ELSEIF display_control.page_width > clc$wide_page_width THEN
        clv$page_width := clc$wide_page_width;
      ELSE
        clv$page_width := display_control.page_width;
      IFEND;

      q_msg := operator_message_list;

{  Format the line containing the device and the station name. }

      text (1, device_label_size) := device_label;
      text_length := device_label_size;

      start_pos := text_length + 1;
      str_length := clp$trimmed_string_size (q_msg^.device);
      text (start_pos, str_length) := q_msg^.device (1, str_length);
      text_length := text_length + str_length;

      start_pos := text_length + 1;
      text (start_pos, 4) := ' at ';
      text_length := text_length + 4;

      start_pos := text_length + 1;
      str_length := clp$trimmed_string_size (q_msg^.station);
      text (start_pos, str_length) := q_msg^.station (1, str_length);
      text_length := text_length + str_length;

      clp$put_display (display_control, text (1, text_length), clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display/;
      IFEND;

      line_size := clv$page_width - 1;
      msg_size := stringsize (q_msg^.text);

      WHILE msg_size > 0 DO
     /scan_msg/
        FOR i := 1 TO msg_size DO
          IF i >= line_size THEN
            EXIT /scan_msg/;
          ELSEIF q_msg^.text (i) = unit_separator THEN
            q_msg^.text (i) := ' ';
            EXIT /scan_msg/;
          IFEND;
        FOREND /scan_msg/;

        clp$put_display (display_control, q_msg^.text (1, i), clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display/
        IFEND;
        q_msg^.text := q_msg^.text (i+1, *);
        msg_size :=msg_size - i;
      WHILEND;

      operator_message_list := q_msg^.link;
      FREE q_msg;

      put_display_line (' ', ' ');
    END /display/;

      close_display;
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND display_operator_message;

?? TITLE := '  get_parameter_length', EJECT ??

{
{   This procedure obtains the length of the next parameter value
{   in the message buffer from SCFS.  The length field, if
{   indicated, should be the next element in the message sequence.
{

  PROCEDURE get_parameter_length (length_indicated: BOOLEAN;
    VAR length: INTEGER);

    VAR
      param_length: ^nft$parameter_value_length,
      ignore_status: ost$status;


    IF length_indicated THEN
      nfp$get_parameter_value_length (message, msg_byte_count, length, ignore_status);
    ELSE
      length := 1;
    IFEND;
    msg_byte_count := msg_byte_count - length;

  PROCEND get_parameter_length;

?? TITLE := '  [INLINE] get_message_type', EJECT ??

{
{   Inline code to get the message type from the beginning of a
{   message received from SCFS.
{

  PROCEDURE [INLINE] get_message_type;


    RESET message;
    NEXT message_type IN message;
    msg_byte_count := message_length - 1;

  PROCEND get_message_type;

?? TITLE := '  [INLINE] get_parameter_type', EJECT ??

{
{   Inline code to get the next parameter type from a
{   message received from SCFS.
{

  PROCEDURE [INLINE] get_parameter_type (VAR param: ^CELL);


    NEXT param IN message;
    msg_byte_count := msg_byte_count - 1;

  PROCEND get_parameter_type;

?? TITLE := '  stringsize', EJECT ??

{
{   Function to determine the length of a string, excluding trailing blanks.
{

  FUNCTION stringsize (str: string ( * )): integer;

    VAR
      str_length: ost$string_size;

    str_length := STRLENGTH (str);
    WHILE (str_length > 0) AND (str (str_length) = ' ') DO
      str_length := str_length - 1;
    WHILEND;
    stringsize := str_length;

  FUNCEND stringsize;


MODEND nfm$sou_asynchronous_task;


*DECK DECK=NFM$STATUS_AND_CONTROL_FACILITY EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NFM$STATUS_AND_CONTROL_FACILITY' ??
MODULE nfm$status_and_control_facility;

{  PURPOSE:
{    This module contains the procedures and functions that collectively
{    implement the host application known as SCF/VE.  This application runs
{    in all NOS/VE systems supporting batch output.
{
{    SCF/VE performs the following functions:
{
{     - interfaces with queue file manager to obtain all output files that
{       are new, modified or terminated
{
{     - processes file control commands and informs SCFS/VE of the
{       availability of output files
{
{     - initiates BTF/VE which is the task responsible for the transfer of
{       an output file from the host to the device

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nfc$wait_list_limit
*copyc nfe$exception_condition_codes
*copyc nft$application_file_descriptor
*copyc nft$available_file
*copyc nft$btf_task
*copyc nft$btfs_di_title
*copyc nft$byte_array
*copyc nft$control_facility
*copyc nft$copies
*copyc nft$destination
*copyc nft$device_attributes
*copyc nft$device_type
*copyc nft$file_assignment_response
*copyc nft$file_size
*copyc nft$file_vertical_print_density
*copyc nft$intertask_message
*copyc nft$io_station_usage
*copyc nft$linked_list_entry
*copyc nft$message_kind
*copyc nft$message_sequence
*copyc nft$network_address
*copyc nft$output_data_mode
*copyc nft$file_transfer_state
*copyc nft$page_format
*copyc nft$page_length
*copyc nft$page_width
*copyc nft$parameter_value_length
*copyc nft$priority
*copyc nft$scfs_client_identifier
*copyc nft$scf_pdt
*copyc nft$vfu_load_procedure
*copyc nft$wait_activity_list
*copyc osc$dual_state_interactive
*copyc osc$timesharing
*copyc osc$xterm_application_name
*copyc osd$integer_limits
*copyc ost$status
*copyc osv$lower_to_upper
*copyc pmd$local_queues
?? POP ??
*copyc amp$return
*copyc bap$validate_file_identifier
*copyc clp$create_environment_variable
*copyc clp$delete_variable
*copyc clp$get_value
*copyc clp$log_comment
*copyc clp$scan_parameter_list
*copyc fsp$close_file
*copyc fsp$open_file
*copyc jmp$acquire_modified_output
*copyc jmp$acquire_new_output
*copyc jmp$modified_output_exists
*copyc jmp$get_attribute_defaults
*copyc jmp$new_output_exists
*copyc jmp$register_output_application
*copyc jmp$set_output_completed
*copyc jmp$set_output_initiated
*copyc jmp$terminate_acquired_output
*copyc jmp$terminated_output_exists
*copyc nap$await_data_available
*copyc nap$await_server_response
*copyc nap$begin_directory_search
*copyc nap$end_directory_search
*copyc nap$display_message
*copyc nap$get_attributes
*copyc nap$get_title_translation
*copyc nap$request_connection
*copyc nap$se_receive_data
*copyc nap$se_send_data
*copyc nap$supported_protocol_stacks
*copyc nfp$add_to_wait_lists
*copyc nfp$btfs_di_match
*copyc nfp$crack_terqo_msg
*copyc nfp$crack_file_assignment_msg
*copyc nfp$create_appl_def_segment_var
*copyc nfp$delete_btf_task
*copyc nfp$end_async_communication
*copyc nfp$establish_cf_connection
*copyc nfp$get_async_task_message
*copyc nfp$get_btfs_di_address
*copyc nfp$get_connection_data
*copyc nfp$get_parameter_value_length
*copyc nfp$network_addresses_match
*copyc nfp$put_parameter_value_length
*copyc ofp$receive_operator_response
*copyc nfp$remove_from_wait_lists
*copyc nfp$send_add_file_available
*copyc nfp$send_btf_ve_status
*copyc nfp$send_delete_file_available
*copyc nfp$send_file_assignment_resp
*copyc nfp$send_message_on_connection
*copyc nfp$send_modify_file_available
*copyc nfp$send_terqo_response_msg
*copyc nfp$start_btf_ve_task
*copyc ofp$send_operator_message
*copyc osp$append_status_parameter
*copyc osp$i_await_activity_completion
*copyc osp$set_status_abnormal
*copyc pmp$establish_condition_handler
*copyc pmp$get_unique_name
*copyc pmp$log
*copyc pmp$terminate_task_without_wait
*copyc pmp$wait
?? OLDTITLE, EJECT ??

  CONST
    automatic_station_value = 'AUTOMATIC',
    start_of_scfs_title = 'SCF[SA]$',
    start_of_scfs_title_length = 8;


  VAR
    client_name: nat$application_name := 'OSA$STATUS_CONTROL_FAC_CLIENT',
    destination_list: ^nft$destination := NIL,
    local_status: ost$status,  {TEMP}
    nfv$wait_activity_list: ^nft$wait_activity_list := NIL,
    wait_activity_list_seq: ^SEQ ( * ),
    wait_list_seq: ^SEQ ( * );

*copyc nfs$appl_def_segment_variables
*copyc nfv$appl_def_segment_variables
?? NEWTITLE := '  acquire_all_output_files', EJECT ??

{  PURPOSE:
{    This procedure obtains all output from queue file manager.
{    It obtains all new output, output submitted via print_file,
{    all modified output, output changed via change_output_attributes,
{    and all terminated output, output terminated via terminate_output.
{    SCF/VE then sends a message to notify SCFS of the status of the new,
{    changed, or terminated output.

  PROCEDURE acquire_all_output_files (VAR message: ^nft$message_sequence;
    VAR wait_list: ^ost$i_wait_list;
    VAR wait_activity_list: ^nft$wait_activity_list;
    VAR destination_list: ^nft$destination;
    VAR status: ost$status);

?? NEWTITLE := '    add_to_file_list', EJECT ??

{}
{  PURPOSE:
{    This procedure adds the specified output descriptor to the destinations
{    file list.
{}

    PROCEDURE add_to_file_list (descriptor: jmt$output_descriptor;
      VAR destination: nft$destination);

      VAR
        current_file,
        new_file: ^nft$available_file;


      ALLOCATE new_file;
      new_file^.file_kind := nfc$output_file;
      new_file^.output_descriptor := descriptor;
      new_file^.transfer_initiated := FALSE;
      new_file^.transfer_state := nfc$eligible_for_transfer;
      new_file^.control_facility := NIL;
      new_file^.btf_task := NIL;
      new_file^.link := NIL;

      current_file := destination.file_list;

      IF current_file = NIL THEN
        destination.file_list := new_file;
        new_file^.back_link := NIL;
      ELSE

      /find_end_of_file_list/
        WHILE current_file^.link <> NIL DO
          current_file := current_file^.link;
        WHILEND /find_end_of_file_list/;

        current_file^.link := new_file;
        new_file^.back_link := current_file;
      IFEND;

    PROCEND add_to_file_list;
?? TITLE := '    get_default_station_name', EJECT ??

{}
{  PURPOSE:
{    This procedure gets the system wide default for the station name and places
{    that value into the descriptor.
{}

    PROCEDURE get_default_station_name (
          originating_application_name: ost$name;
      VAR station: ost$name);

      VAR
        default_attributes: ^jmt$default_attribute_results,
        local_status: ost$status;

      PUSH default_attributes: [1..1];
      default_attributes^[1].key := jmc$station;

      IF (originating_application_name = osc$timesharing) OR
           (originating_application_name = osc$dual_state_interactive) OR
           (originating_application_name = osc$xterm_application_name) THEN
        jmp$get_attribute_defaults (jmc$interactive_connected, default_attributes, local_status);
      ELSE
        jmp$get_attribute_defaults (jmc$batch, default_attributes, local_status);
      IFEND;
      IF local_status.normal THEN
        station := default_attributes^[1].station;
      IFEND;

    PROCEND get_default_station_name;
?? TITLE := '    get_modified_output', EJECT ??

  {}
  {  PURPOSE:
  {    Obtain all output from queue file manager that has been modified.
  {    Each control facility with the destination specified by the output
  {    file will be notified of the changes in the output file.  If the
  {    modifications change the destination for the output file, each of the
  {    control facilities with the previous output file values will be informed
  {    to delete the file and the file will be sent to each control facility
  {    with the new destination.
  {}

    PROCEDURE get_modified_output (destination_usage: jmt$destination_usage;
      VAR message: ^nft$message_sequence;
      VAR wait_list: ^ost$i_wait_list;
      VAR wait_activity_list: ^nft$wait_activity_list;
      VAR destination_list: ^nft$destination;
      VAR status: ost$status);

      VAR
        application_file: nft$application_file_descriptor,
        control_facility_entry: ^nft$linked_list_entry,
        current_file: ^nft$available_file,
        descriptor_found: boolean,
        destination: ^nft$destination,
        destination_found: boolean,
        local_status: ost$status,
        modified_application_file: nft$application_file_descriptor,
        modified_descriptor: jmt$output_descriptor,
        next_control_facility_entry: ^nft$linked_list_entry,
        old_descriptor: jmt$output_descriptor;

?? NEWTITLE := '      change_file_destination', EJECT ??

{}
{  PURPOSE:
{    This procedure is called when the user has made modifications that
{    affect where the output file will print.  The output file is removed
{    from the old destination list, put into the new destination list and
{    a delete file availability message is sent to all control facilities with
{    the old version of the output file.  The new version of the file is then
{    sent to each control facility with the new destination.
{}
      PROCEDURE change_file_destination (VAR message: ^nft$message_sequence;
            old_descriptor: jmt$output_descriptor;
            new_descriptor: jmt$output_descriptor;
        VAR wait_list: ^ost$i_wait_list;
        VAR wait_activity_list: ^nft$wait_activity_list;
        VAR destination_list: ^nft$destination;
        VAR status: ost$status);

        VAR
          new_destination: ^nft$destination,
          new_destination_found: boolean,
          old_destination: ^nft$destination,
          old_destination_found: boolean;


        status.normal := TRUE;

        find_destination (old_descriptor.station, destination_list, old_destination_found,
              old_destination);
        find_destination (new_descriptor.station, destination_list, new_destination_found,
              new_destination);

{  Remove the file from the old destination list and notify control facilities.

        IF old_destination_found THEN
          remove_file_from_list (old_descriptor.system_file_name, old_destination^);

{  Send a delete file available message to each of the control facilities }
{  with the old destination. }

          send_delete_file_to_ctrl_facs (old_destination^.control_facility_list,
                FALSE, old_descriptor, destination_list, wait_list, wait_activity_list,
                message,  status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

{ If the new destination is currently not known, get the control facilities that }
{ have a destination by that name. }

        IF NOT new_destination_found THEN
          get_destination_and_cntrl_fac (new_descriptor.station, wait_list, wait_activity_list,
                destination_list, new_destination, message, status);
          IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.
                condition = nae$unknown_application)) THEN
            RETURN;
          IFEND;
        IFEND;
        add_to_file_list (new_descriptor, new_destination^);

{ Send a message indicating a file is available for printing to each control  }
{ facility with the new destination.  }

        send_add_file_to_ctrl_facs (new_destination^.control_facility_list,
              new_descriptor, nfc$eligible_for_transfer, destination_list, wait_list, wait_activity_list,
              message,  status);

      PROCEND change_file_destination;
?? TITLE := '      destination_changed', EJECT ??

{}
{  PURPOSE:
{    This function determines if the modifications made to the output file
{    have changed where the file may print (the files destination).
{}
      FUNCTION destination_changed (descriptor: jmt$output_descriptor;
            modified_descriptor: jmt$output_descriptor): boolean;


        destination_changed :=

        (descriptor.station <> modified_descriptor.station) OR

        (descriptor.output_destination_family <> modified_descriptor.output_destination_family) OR

        (descriptor.station_operator <> modified_descriptor.station_operator);

      FUNCEND destination_changed;
?? OLDTITLE, EJECT ??

      status.normal := TRUE;

      application_file.file_kind := nfc$output_file;
      modified_application_file.file_kind := nfc$output_file;

{ Get all output from queue manager that has been changed.

    /acquire_modified_output/
      WHILE jmp$modified_output_exists (destination_usage) DO

        jmp$acquire_modified_output (destination_usage, modified_descriptor, status);
        IF status.normal THEN

{  This code is required because of the differences in page_width between NOS/VE and
{  CDCNET BTF/DI.  This will change the NOS/VE page width that is outside the range
{  of CDCNET BTF/DI allowable values to within that range.

          IF modified_descriptor.page_width < nfc$minimum_page_width THEN
            modified_descriptor.page_width := nfc$minimum_page_width;
          ELSEIF modified_descriptor.page_width > nfc$maximum_page_width THEN
            modified_descriptor.page_width := nfc$maximum_page_width;
          IFEND;
          IF (modified_descriptor.station = automatic_station_value) THEN
            get_default_station_name (modified_descriptor.originating_application_name,
                  modified_descriptor.station);
          IFEND;
          find_file_and_descriptor (modified_descriptor.system_file_name, destination_list,
                current_file, descriptor_found);
          IF descriptor_found THEN
            old_descriptor := current_file^.output_descriptor;
            current_file^.output_descriptor := modified_descriptor;
            IF NOT destination_changed (old_descriptor, current_file^.output_descriptor) THEN
              find_destination (current_file^.output_descriptor.station, destination_list, destination_found,
                    destination);
              IF destination_found THEN

{  Notify each control facility with that destination that a file has been modified.

                application_file.output_descriptor := old_descriptor;
                modified_application_file.output_descriptor := current_file^.output_descriptor;

                control_facility_entry := destination^.control_facility_list;

              /search_control_facility_list/
                WHILE control_facility_entry <> NIL DO

                  nfp$send_modify_file_available (modified_application_file, application_file,
                        control_facility_entry^.control_facility^.connection_id, message, status);
                  next_control_facility_entry := control_facility_entry^.link;
                  IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.
                        condition = nae$unknown_application)) THEN
                    RETURN;
                  ELSEIF NOT status.normal AND ((status.condition <> nae$no_data_available) AND
                        (status.condition <> nfe$invalid_descriptor_value)) THEN
                    remove_control_facility (destination_list, control_facility_entry^.control_facility,
                          wait_list, wait_activity_list, status);
                    IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.
                          condition = nae$unknown_application)) THEN
                      RETURN;
                    IFEND;
                  IFEND;
                  control_facility_entry := next_control_facility_entry;
                WHILEND /search_control_facility_list/;

              IFEND;
            ELSE

{ Notify control facilities that currently have the file to delete the file, }
{ and notify the control facilities with the new destination that there is   }
{ a file available for printing.  }

              change_file_destination (message, old_descriptor, current_file^.output_descriptor, wait_list,
                    wait_activity_list, destination_list, status);
              IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
                    nae$unknown_application)) THEN
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        ELSE
          pmp$log ('**** SCF - abnormal status returned on jmp$acquire_modified_output', local_status);
          nap$display_message (status);
          RETURN;
        IFEND;

      WHILEND /acquire_modified_output/;

    PROCEND get_modified_output;
?? TITLE := '    get_new_output', EJECT ??

{}
{  PURPOSE:
{    Obtain all output from queue file manager that the user has just
{    sent to print.  Each control facility with the destination specified by
{    the output file will be notified that there is an output file that is
{    available to print.
{}

    PROCEDURE get_new_output (destination_usage: jmt$destination_usage;
      VAR message: ^nft$message_sequence;
      VAR wait_list: ^ost$i_wait_list;
      VAR wait_activity_list: ^nft$wait_activity_list;
      VAR destination_list: ^nft$destination;
      VAR status: ost$status);

      VAR
        descriptor: jmt$output_descriptor,
        descriptor_found: boolean,
        destination: ^nft$destination,
        local_status: ost$status;


      status.normal := TRUE;
      destination := NIL;

{ Get all new output from queue manager.

    /acquire_new_output/
      WHILE jmp$new_output_exists (destination_usage) DO

        jmp$acquire_new_output (destination_usage, descriptor, status);
        IF status.normal THEN

{  This code is required because of the differences in page_width between NOS/VE and
{  CDCNET BTF/DI.  This will change the NOS/VE page width that is outside the range
{  of CDCNET BTF/DI allowable values to within that range.

          IF descriptor.page_width < nfc$minimum_page_width THEN
            descriptor.page_width := nfc$minimum_page_width;
          ELSEIF descriptor.page_width > nfc$maximum_page_width THEN
            descriptor.page_width := nfc$maximum_page_width;
          IFEND;
          IF (descriptor.station = automatic_station_value) THEN
            get_default_station_name (descriptor.originating_application_name, descriptor.station);
          IFEND;
          get_destination_and_cntrl_fac (descriptor.station, wait_list, wait_activity_list,
                destination_list, destination, message, status);
          IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.
                condition = nae$unknown_application)) THEN
            RETURN;
          IFEND;
          add_to_file_list (descriptor, destination^);

{  Send a message indicating a file is available to print to each control facility with that destination.

          send_add_file_to_ctrl_facs (destination^.control_facility_list,
                descriptor, nfc$eligible_for_transfer, destination_list, wait_list, wait_activity_list,
                message, status);
          IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
                nae$unknown_application)) THEN
            RETURN;
          IFEND;
        ELSE
          pmp$log ('**** SCF - abnormal status returned on jmp$acquire_new_output', local_status);
          nap$display_message (status);
          RETURN;
        IFEND;
      WHILEND /acquire_new_output/;

    PROCEND get_new_output;
?? TITLE := '    get_terminated_output', EJECT ??

{}
{  PURPOSE:
{    Obtain all output from queue file manager that has been terminated.
{    Each control facility with the destination specified by the output
{    file will be notified that the file should be deleted.  If the file
{    has already begun printing, the file transfer will not be terminated.
{}

    PROCEDURE get_terminated_output (destination_usage: jmt$destination_usage;
      VAR message: ^nft$message_sequence;
      VAR wait_list: ^ost$i_wait_list;
      VAR wait_activity_list: ^nft$wait_activity_list;
      VAR destination_list: ^nft$destination;
      VAR status: ost$status);

      VAR
        application_file: nft$application_file_descriptor,
        current_file: ^nft$available_file,
        descriptor: jmt$output_descriptor,
        descriptor_found: boolean,
        destination: ^nft$destination,
        destination_found: boolean,
        ignore_status: ost$status,
        system_file_name: jmt$system_supplied_name;


      status.normal := TRUE;

{ Get all output from queue manager that has been terminated.

    /acquire_terminated_output/
      WHILE jmp$terminated_output_exists (destination_usage) DO

        jmp$terminate_acquired_output (destination_usage, system_file_name, status);
        IF status.normal THEN
          find_file_and_descriptor (system_file_name, destination_list, current_file, descriptor_found);
          IF descriptor_found THEN
            descriptor := current_file^.output_descriptor;
            find_destination (descriptor.station, destination_list, destination_found, destination);
            IF destination_found THEN
              remove_file_from_list (system_file_name, destination^);
              IF current_file^.control_facility <> NIL THEN

                application_file.file_kind := nfc$output_file;
                application_file.output_descriptor := current_file^.output_descriptor;
                nfp$send_delete_file_available (application_file, {held} FALSE, {requeued} FALSE,
                      current_file^.control_facility^.connection_id, message, status);
                IF NOT status.normal AND ((status.condition <> nae$no_data_available) AND
                        (status.condition <> nfe$invalid_descriptor_value)) THEN
                  remove_control_facility (destination_list, current_file^.control_facility, wait_list,
                        wait_activity_list, status);
                  IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR
                       (status.condition = nae$unknown_application)) THEN
                    RETURN;
                  IFEND;
                IFEND;

{ If file is being processed by a BTF task, terminate that task.

                IF (current_file^.btf_task <> NIL) THEN
                  pmp$log ('**** SCF:  BTF terminated because file was terminated.', ignore_status);
                  pmp$terminate_task_without_wait (current_file^.btf_task^.id, ignore_status);
                IFEND;

{  Notify each control facility with that destination that the output
{  has been terminated.

              ELSE
                send_delete_file_to_ctrl_facs (destination^.control_facility_list,
                      FALSE, descriptor, destination_list, wait_list, wait_activity_list,
                      message,  status);
              IFEND;
            IFEND;
          IFEND;
        ELSE
          pmp$log ('**** SCF - abnormal status returned on jmp$terminate_acquired_output', ignore_status);
          nap$display_message (status);
          RETURN;
        IFEND;

      WHILEND /acquire_terminated_output/;

    PROCEND get_terminated_output;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

{ Get terminated output.

    get_terminated_output (jmc$public_usage, message, wait_list, wait_activity_list,
          destination_list, status);
    IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
          nae$unknown_application)) THEN
      RETURN;
    IFEND;

    get_terminated_output (jmc$private_usage, message, wait_list, wait_activity_list,
          destination_list, status);
    IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
          nae$unknown_application)) THEN
      RETURN;
    IFEND;

{ Get modified output.

    get_modified_output (jmc$public_usage, message, wait_list, wait_activity_list, destination_list, status);
    IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
          nae$unknown_application)) THEN
      RETURN;
    IFEND;

    get_modified_output (jmc$private_usage, message, wait_list, wait_activity_list, destination_list, status);
    IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
          nae$unknown_application)) THEN
      RETURN;
    IFEND;

{ Get new output.

    get_new_output (jmc$public_usage, message, wait_list, wait_activity_list, destination_list, status);
    IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
          nae$unknown_application)) THEN
      RETURN;
    IFEND;

    get_new_output (jmc$private_usage, message, wait_list, wait_activity_list, destination_list, status);
    IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
          nae$unknown_application)) THEN
      RETURN;
    IFEND;

  PROCEND acquire_all_output_files;
?? TITLE := '  add_await_title_translation', EJECT ??

{}
{  PURPOSE:
{    This procedure requests the translation of a title and adds
{    the title translation request to the wait lists.
{}

  PROCEDURE add_await_title_translation (VAR destination: nft$destination;
    VAR wait_list: ^ost$i_wait_list;
    VAR wait_activity_list: ^nft$wait_activity_list;
    VAR status: ost$status);

    VAR
      activity: nft$wait_activity,
      recurrent_search: boolean,
      title: ^nat$title_pattern;


    status.normal := TRUE;

    PUSH title: [start_of_scfs_title_length + osc$max_name_size];
    title^ (1, start_of_scfs_title_length) := start_of_scfs_title;
    title^ (1 + start_of_scfs_title_length, * ) := destination.name;

{  If a recurrent search is requested, distributed translations will continue }
{  to be examined and SCF will be notified of any new titles having the  }
{  specified characteristics. }

    recurrent_search := TRUE;
    nap$begin_directory_search (title^, client_name, recurrent_search, destination.title_search_id, status);
    IF status.normal THEN
      destination.translation_time_stamp := #FREE_RUNNING_CLOCK (0);
      activity.kind := nfc$title_translation_request;
      activity.dest := ^destination;
      nfp$add_to_wait_lists (activity, wait_list, wait_activity_list,
            wait_list_seq, wait_activity_list_seq);
      nfv$wait_activity_list := wait_activity_list;
    IFEND;

  PROCEND add_await_title_translation;
?? TITLE := '  add_cf_to_control_fac_list', EJECT ??

{}
{  PURPOSE:
{    Add the control facility entry to the control facility list.  The
{    control facility list contains entries that are doubly linked together
{    with each entry pointing to a control facility.
{}

    PROCEDURE add_cf_to_control_fac_list (VAR control_facility: ^nft$control_facility;
      VAR control_facility_list: ^nft$linked_list_entry);

      VAR
        current_cf_entry: ^nft$linked_list_entry;

      IF control_facility_list = NIL THEN
        add_linked_list_entry(control_facility_list, nfc$control_facility);
        control_facility_list^.control_facility := control_facility;
      ELSE
        current_cf_entry := control_facility_list;

      /find_last_link/
        WHILE current_cf_entry^.link <> NIL DO
          current_cf_entry := current_cf_entry^.link;
        WHILEND /find_last_link/;

        add_linked_list_entry(current_cf_entry, nfc$control_facility);
        current_cf_entry^.control_facility := control_facility;
      IFEND;

    PROCEND add_cf_to_control_fac_list;
?? TITLE := '  add_control_facility_to_lists', EJECT ??

{}
{  PURPOSE:
{    Add the control facility to the wait lists.  Adding the control facility
{    to the wait lists allows SCF/VE to be notified of data on the connection
{    with the control facility.
{}

  PROCEDURE add_control_facility_to_lists (name: ost$name;
        connection_file_name: ost$name;
        connection_id: amt$file_identifier;
        service_address: nat$network_address;
    VAR wait_list: ^ost$i_wait_list;
    VAR wait_activity_list: ^nft$wait_activity_list;
    VAR control_facility: ^nft$control_facility);

    VAR
      activity: nft$wait_activity;


    ALLOCATE control_facility;

    control_facility^.name := name;
    control_facility^.connection_file_name := connection_file_name;
    control_facility^.connection_id := connection_id;
    control_facility^.service_addr := service_address;

    activity.kind := nfc$control_facility_connection;
    activity.cf := control_facility;
    nfp$add_to_wait_lists (activity, wait_list, wait_activity_list,
          wait_list_seq, wait_activity_list_seq);
    nfv$wait_activity_list := wait_activity_list;

  PROCEND add_control_facility_to_lists;
?? TITLE := '  add_destination_to_list', EJECT ??

{}
{  PURPOSE:
{    A list of all the destinations known to this SCF/VE are kept in one list.
{    This procedure adds a new destination to that list.
{}

  PROCEDURE add_destination_to_list (name: ost$name;
    VAR first_destination: ^nft$destination;
    VAR destination: ^nft$destination);

    VAR
      current_destination: ^nft$destination;


    ALLOCATE destination;

    IF first_destination = NIL THEN
      first_destination := destination;
    ELSE
      current_destination := first_destination;

    /find_last_link/
      WHILE current_destination^.link <> NIL DO
        current_destination := current_destination^.link;
      WHILEND /find_last_link/;

      current_destination^.link := destination;
    IFEND;

    destination^.name := name;
    destination^.file_list := NIL;
    destination^.control_facility_list := NIL;
    destination^.link := NIL;
    destination^.translation_time_stamp := 0;

  PROCEND add_destination_to_list;
?? TITLE := '  add_linked_list_entry', EJECT ??

{}
{  PURPOSE:
{    This procedure adds a linked list entry of the specified kind to the end
{    of the list.
{  NOTE:
{    Current_link MUST point to the last entry in the linked list.
{}

  PROCEDURE add_linked_list_entry (VAR current_link: ^nft$linked_list_entry;
        link_kind: nft$link_kind);


    VAR
      new_link: ^nft$linked_list_entry;

    ALLOCATE new_link;

    IF current_link <> NIL THEN
      current_link^.link := new_link;
    IFEND;

    new_link^.back_link := current_link;
    current_link := new_link;
    current_link^.link := NIL;
    current_link^.kind := link_kind;

    CASE current_link^.kind OF
    = nfc$control_facility =
      current_link^.control_facility := NIL;
    CASEND;

  PROCEND add_linked_list_entry;
?? TITLE := '  cf_in_dest_control_fac_list', EJECT ??

    FUNCTION cf_in_dest_control_fac_list (control_facility: ^nft$control_facility;
          control_facility_list: ^nft$linked_list_entry): boolean;

      VAR
        control_facility_entry: ^nft$linked_list_entry,
        cf_found: boolean;

      cf_found := FALSE;
      control_facility_entry := control_facility_list;

    /search_for_cf_with_service_addr/
      WHILE (control_facility_entry <> NIL) AND (NOT cf_found) DO
        IF control_facility_entry^.control_facility <> NIL THEN
          IF nfp$network_addresses_match (control_facility_entry^.control_facility^.service_addr,
                control_facility^.service_addr) THEN
            cf_found := (control_facility_entry^.control_facility^.name = control_facility^.name);
          IFEND;
        IFEND;
        control_facility_entry := control_facility_entry^.link;
      WHILEND /search_for_cf_with_service_addr/;

      cf_in_dest_control_fac_list := cf_found;

    FUNCEND cf_in_dest_control_fac_list;
?? TITLE := '  check_for_btf_task_completion', EJECT ??

{}
{  PURPOSE:
{    For each BTF/VE task known to SCF/VE, if there is a message from the
{    task indicating the transfer is complete, or that the file should be
{    requeued, notify queue file manager that the transfer is complete,
{    notify the control facility that the file should be deleted, and delete
{    the file from the destinations file list.
{}
{  NOTE:
{    If the operator specified that the file should be held in the station queue,
{    there is currently no indication to the user that the file is in that
{    state.
{}

  PROCEDURE check_for_btf_task_completion
    (VAR message: ^nft$message_sequence;
         btf_task_index: integer;
     VAR outstanding_operator_messages: ost$non_negative_integers;
     VAR wait_list: ^ost$i_wait_list;
     VAR wait_activity_list: ^nft$wait_activity_list;
     VAR destination_list: ^nft$destination;
     VAR status: ost$status);

    VAR
      application_file: nft$application_file_descriptor,
      btf_task: ^nft$btf_task,
      destination: ^nft$destination,
      current_file: ^nft$available_file,
      ignore_status: ost$status,
      output_complete: boolean,
      remove_task: boolean,
      task_status: nft$intertask_message,
      task_status_size: nft$intertask_transfer_size,
      transfer_count: nft$intertask_transfer_size;

?? NEWTITLE := '    requeue_files_to_destination', EJECT ??

    PROCEDURE requeue_files_to_destination
      (    btf_task: ^nft$btf_task;
           destination_list: ^nft$destination;
       VAR wait_list: ^ost$i_wait_list;
       VAR wait_activity_list: ^nft$wait_activity_list;
       VAR message: ^nft$message_sequence;
       VAR status: ost$status);

      VAR
        application_file: nft$application_file_descriptor,
        current_file: ^nft$available_file,
        destination: ^nft$destination,
        ignore_status: ost$status;

      status.normal := TRUE;
      application_file.file_kind := nfc$output_file;

      destination := destination_list;

    /search_destination_list/
      WHILE destination <> NIL DO

        current_file := destination^.file_list;

      /search_file_list/
        WHILE current_file <> NIL DO

          IF current_file^.transfer_initiated AND
                (current_file^.btf_task <> NIL) THEN
            IF (current_file^.btf_task^.io_station = btf_task^.io_station) AND
               (current_file^.btf_task^.device = btf_task^.device) AND
               (current_file^.btf_task^.id = btf_task^.id) AND
               nfp$btfs_di_match (current_file^.btf_task^.btfs_di_title,
               current_file^.btf_task^.network_addr, btf_task^.btfs_di_title,
               btf_task^.network_addr)
                  THEN
              IF current_file^.control_facility <> NIL THEN

                application_file.output_descriptor := current_file^.output_descriptor;
                nfp$send_delete_file_available (application_file, {held} FALSE, {requeued} FALSE,
                      current_file^.control_facility^.connection_id, message, status);
                IF NOT status.normal AND ((status.condition <> nae$no_data_available) AND
                        (status.condition <> nfe$invalid_descriptor_value)) THEN
                  remove_control_facility (destination_list, current_file^.control_facility, wait_list,
                        wait_activity_list, status);
                  IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR
                       (status.condition = nae$unknown_application)) THEN
                    RETURN;
                  IFEND;
                IFEND;
              IFEND;
              jmp$set_output_completed (current_file^.output_descriptor.output_destination_usage,
                    current_file^.output_descriptor.system_file_name, FALSE, ignore_status);
              remove_file_from_list (current_file^.output_descriptor.system_file_name, destination^);
            IFEND;
          IFEND;
          current_file := current_file^.link;
        WHILEND /search_file_list/;
        destination := destination^.link;

      WHILEND /search_destination_list/;
    PROCEND requeue_files_to_destination;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    task_status_size := #SIZE (nft$intertask_message);
    btf_task := wait_activity_list^ [btf_task_index].btf_task_list;

  /check_btf_tasks_for_messages/
    WHILE btf_task <> NIL DO
      nfp$get_async_task_message (btf_task^.id, ^task_status, task_status_size, 0, transfer_count, status);
      IF NOT status.normal THEN
        nfp$delete_btf_task (btf_task_index, wait_activity_list, btf_task);
      ELSEIF (status.normal) AND (transfer_count > 0) THEN
        CASE task_status.kind OF

        = nfc$btf_file_transfer_status =

          nfp$delete_btf_task (btf_task_index, wait_activity_list, btf_task);

          IF (NOT task_status.btf_task_status.normal) AND
                ((task_status.btf_task_status.condition = nae$application_inactive) OR
                (task_status.btf_task_status.condition = nae$unknown_application)) THEN
            status := task_status.btf_task_status;
            RETURN;
          IFEND;

          find_file_in_list (task_status.btf_system_file_name, destination_list, current_file, destination);
          IF current_file <> NIL THEN

            current_file^.output_descriptor.copies_printed := task_status.copies_printed;
            output_complete := task_status.btf_transfer_status = nfc$transfer_complete_drop_file;

            IF task_status.filter_aborted THEN
              ofp$send_operator_message ('BATCH OUTPUT FILTER ABORTED - SEE SYSTEM LOG FOR DETAILS.',
                    ofc$system_operator, TRUE, ignore_status);
              outstanding_operator_messages := outstanding_operator_messages + 1;
            IFEND;

            CASE task_status.btf_transfer_status OF
            = nfc$operator_hold_file =
              current_file^.transfer_state := nfc$hold_transfer;

            = nfc$transfer_complete_drop_file, nfc$transfer_failed_re_q_file =

{ Notify queue file manager if the file transfer is complete and
{ notify the control facility that assigned the file to a device that the
{ file should be deleted from the station queue.

              current_file^.transfer_initiated := FALSE;
              jmp$set_output_completed (current_file^.output_descriptor.output_destination_usage,
                    current_file^.output_descriptor.system_file_name, output_complete, ignore_status);

              IF current_file^.control_facility <> NIL THEN
                application_file.file_kind := nfc$output_file;
                application_file.output_descriptor := current_file^.output_descriptor;

                nfp$send_delete_file_available (application_file, {held} FALSE,
                      {requeued} (NOT output_complete), current_file^.control_facility^.connection_id,
                      message, status);
                IF NOT status.normal AND ((status.condition <> nae$no_data_available) AND
                        (status.condition <> nfe$invalid_descriptor_value)) THEN
                  remove_control_facility (destination_list, current_file^.control_facility, wait_list,
                        wait_activity_list, status);
                  IF (NOT status.normal) AND ((status.condition =
                        nae$application_inactive) OR (status.condition
                        =  nae$unknown_application)) THEN
                    RETURN;
                  IFEND;
                IFEND;
              IFEND;
              remove_file_from_list (task_status.btf_system_file_name, destination^);

            = nfc$filter_hold_file =
              current_file^.transfer_state := nfc$hold_transfer;

              IF current_file^.control_facility <> NIL THEN
                application_file.file_kind := nfc$output_file;
                application_file.output_descriptor := current_file^.output_descriptor;

                nfp$send_delete_file_available (application_file, {held} TRUE, {requeued} FALSE,
                      current_file^.control_facility^.connection_id, message, status);
                IF NOT status.normal AND ((status.condition <> nae$no_data_available) AND
                      (status.condition <> nfe$invalid_descriptor_value)) THEN
                  remove_control_facility (destination_list, current_file^.control_facility, wait_list,
                        wait_activity_list, status);
                  IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR
                        (status.condition = nae$unknown_application)) THEN
                    RETURN;
                  IFEND;
                IFEND;
              IFEND;
            ELSE
              ;
            CASEND;
          IFEND;

        = nfc$abnormal_child_task_abort =
          requeue_files_to_destination( btf_task, destination_list, wait_list,
                wait_activity_list, message, status);
          nfp$delete_btf_task (btf_task_index, wait_activity_list, btf_task);
        ELSE
        CASEND;
      ELSE
        btf_task := btf_task^.link;
      IFEND;
    WHILEND /check_btf_tasks_for_messages/;

  PROCEND check_for_btf_task_completion;
?? TITLE := '  check_unknown_destination', EJECT ??

{  PURPOSE:
{    A title translation was received for a previous translation request
{    on a destination name, indicating the location of a control facility that
{    that has that destination.  The control facility list for the destination
{    is updated and if there are files in the destinations file list that
{    are not currently printing, an add file availability message will be
{    sent to those control facilities that weren't in the previous list of
{    known control facilities.

  PROCEDURE check_unknown_destination
    (VAR message: ^nft$message_sequence;
         activity_index: integer;
         destination_list: ^nft$destination;
     VAR wait_list: ^ost$i_wait_list;
     VAR wait_activity_list: ^nft$wait_activity_list;
     VAR status: ost$status);

    VAR
      application_file: nft$application_file_descriptor,
      control_facility_entry: ^nft$linked_list_entry,
      control_facility_list: ^nft$linked_list_entry,
      current_file: ^nft$available_file,
      destination: ^nft$destination,
      local_status: ost$status,
      next_control_facility_entry: ^nft$linked_list_entry;
?? EJECT ??

    status.normal := TRUE;
    application_file.file_kind := nfc$output_file;

{  A title translation was received for the destination.  Get the destination
{  and get a current list of the control facilities that have that destination.

    destination := wait_activity_list^ [activity_index].dest;
    get_control_facility (activity_index, wait_list, wait_activity_list, destination^, control_facility_list,
          message, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF control_facility_list <> NIL THEN
      control_facility_entry := control_facility_list;

    /search_control_facility_list/
      WHILE control_facility_entry <> NIL DO

{  If there are entries in the control facility list that are not in the
{  current control facility list for that destination, add them into the list.

        next_control_facility_entry := control_facility_entry^.link;
        IF NOT cf_in_dest_control_fac_list (control_facility_entry^.control_facility,
              destination^.control_facility_list) THEN
          add_cf_to_control_fac_list (control_facility_entry^.control_facility,
                destination^.control_facility_list);

{  Check each file in the destination file list.  If the file is
{  not printing, send a message to the additional control facility indicating
{  that there is a file that is a candidate for printing.

          current_file := destination^.file_list;
          IF current_file <> NIL THEN

          /search_output_file_list/
            REPEAT
              IF (NOT current_file^.transfer_initiated) OR (current_file^.transfer_initiated AND
                    (current_file^.transfer_state = nfc$hold_transfer)) THEN
                application_file.output_descriptor := current_file^.output_descriptor;
                nfp$send_add_file_available (application_file,  current_file^.transfer_state,
                      control_facility_entry^.control_facility^.connection_id, message, local_status);
                IF NOT local_status.normal AND ((local_status.condition <> nae$no_data_available) AND
                        (local_status.condition <> nfe$invalid_descriptor_value)) THEN
                  remove_control_facility (destination_list, control_facility_entry^.control_facility,
                        wait_list, wait_activity_list, status);
                  IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.
                        condition = nae$unknown_application)) THEN
                    RETURN;
                  IFEND;
                  control_facility_entry := next_control_facility_entry;
                  CYCLE /search_control_facility_list/;
                IFEND;
              IFEND;
              current_file := current_file^.link;
            UNTIL (current_file = NIL);

          IFEND;
        IFEND;
        control_facility_entry := next_control_facility_entry;
      WHILEND /search_control_facility_list/;
    IFEND;

  PROCEND check_unknown_destination;
?? TITLE := '  delete_destination_message', EJECT ??

{}
{  PURPOSE:
{    This procedure is executed when a delete destination message is received
{    from a control facility indicating an I/O station or alias has been
{    deleted from the control facility.  The control facility will be removed
{    from the destinations control facility list and further output files
{    will not be sent to that control facility until the destination returns.
{}

  PROCEDURE delete_destination_message (VAR message: ^nft$message_sequence;
        destination_list: ^nft$destination;
    VAR wait_list: ^ost$i_wait_list;
    VAR wait_activity_list: ^nft$wait_activity_list;
    VAR msg_length: integer;
    VAR status: ost$status);

*copy nft$delete_destination_msg

    VAR
      control_facility_entry: ^nft$linked_list_entry,
      control_facility_found_in_list: boolean,
      control_facility_name: ost$name,
      destination: ^nft$destination,
      destination_found: boolean,
      destination_name: ost$name;

?? NEWTITLE := '    crack_delete_destination_msg', EJECT ??

    PROCEDURE crack_delete_destination_msg (VAR message: ^nft$message_sequence;
      VAR msg_length: integer;
      VAR destination_name: ost$name;
      VAR control_facility_name: ost$name;
      VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        parameter: ^nft$delete_destination_param,
        value_length: integer;


      status.normal := TRUE;
      NEXT parameter IN message;

    /parse_protocol_message/
      WHILE (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$destination_name =
          NEXT ascii_string: [value_length] IN message;
          destination_name := ascii_string^;

        = nfc$control_facility_name =
          NEXT ascii_string: [value_length] IN message;
          control_facility_name := ascii_string^;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND /parse_protocol_message/;

    PROCEND crack_delete_destination_msg;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    crack_delete_destination_msg (message, msg_length, destination_name, control_facility_name,
          status);

    find_destination (destination_name, destination_list, destination_found, destination);

    IF destination_found  THEN
      control_facility_found_in_list := FALSE;
      control_facility_entry := destination^.control_facility_list;

    /search_control_facility_list/
      WHILE (control_facility_entry <> NIL) AND (NOT control_facility_found_in_list) DO
        IF control_facility_entry^.control_facility <> NIL THEN

{  A control facility name must be unique within the catenet, so the name is
{  enough to identify which control facility entry to delete from the
{  destinations list of control facilities.

          IF control_facility_name = control_facility_entry^.control_facility^.name THEN
            remove_linked_list_entry(control_facility_entry, destination^.control_facility_list);
            control_facility_found_in_list := TRUE;
            EXIT /search_control_facility_list/
          IFEND;
        IFEND;
        control_facility_entry := control_facility_entry^.link;
      WHILEND /search_control_facility_list/;

    IFEND;

  PROCEND delete_destination_message;
?? TITLE := '  file_assignment_message', EJECT ??

{  PURPOSE:
{    This procedure processes a file assignment message that was sent from
{    a control facility indicating an output file has been assigned to an
{    output device.  In the message is a list of the output file attributes
{    known to the control facility.   If this list of attributes matches
{    the current attributes known to SCF/VE, if another control facility
{    has not already assigned the output file to a device, or if the user
{    has not just recently modified or terminated the output file, a response
{    is sent to the control facility indicating the message was accepted.
{    Otherwise a response is sent indicating the message was rejected.
{
{  NOTE:
{    The checking of the output file attributes is done to cover the case
{    where the output file was sent to multiple control facilities, and the
{    user may have modified the output file.  There is no indication
{    if the control facilities file assignment is in response to the initial
{    file availability message, to an initial modification or to a second
{    modification.  The checking of the attributes ensures that the
{    control facility has the most recent information about the output file.

  PROCEDURE file_assignment_message
    (    connection_id: amt$file_identifier;
         first_destination: ^nft$destination;
         debug_async_task: pmt$debug_mode;
         public_queue_file_password: jmt$queue_file_password;
         private_queue_file_password: jmt$queue_file_password;
     VAR message: ^nft$message_sequence;
     VAR wait_list: ^ost$i_wait_list;
     VAR wait_activity_list: ^nft$wait_activity_list;
     VAR msg_length: integer;
     VAR status: ost$status);

*copyc nft$file_assignment_msg

    VAR
      application_file: nft$application_file_descriptor,
      btfs_di_network_address: nat$network_address,
      btfs_di_xns_address: nft$network_address,
      btfs_di_title: nft$btfs_di_title,
      btf_task: ^nft$btf_task,
      control_facility: ^nft$control_facility,
      control_facility_entry: ^nft$linked_list_entry,
      current_file: ^nft$available_file,
      descriptor_found: boolean,
      destination: ^nft$destination,
      destination_found: boolean,
      device_attributes: nft$device_attributes,
      device_attributes_variable: ost$name,
      device_name: ost$name,
      device_type: nft$device_type,
      ignore_status: ost$status,
      io_station_name: ost$name,
      last_parameter_sent: nft$file_assignment_params,
      message_response: nft$file_assignment_response,
      next_control_facility_entry: ^nft$linked_list_entry,
      protocol_stacks: nat$protocol_stack_integer,
      remote_system_protocol: nft$ntf_remote_system_protocol,
      remote_system_type: nft$ntf_remote_system_type,
      route_back_position: nft$ntf_route_back_position,
      scfs_values_match_descriptor: boolean,
      system_file_name: jmt$system_supplied_name;

?? NEWTITLE := 'create_device_attributes_var', EJECT ??

{ PURPOSE:
{   This procedure creates an SCL variable with the device attributes of the
{   assigned device.  This SCL variable is used by the $device_attributes
{   function which is used by batch output filters.
{
{ DESIGN:
{   A read-only, job-scope SCL variable of type RECORD is created and
{   initialized.
{
{ NOTES:
{   If SCFS has not provided device_attribute parameters on the file
{   assignment message (because it is an old SCFS) then the variable will
{   contain fields with uninitialized values.  DEVICE_NAME and STATION will
{   always be OK because SCFS has always sent these values.


    PROCEDURE create_device_attributes_var
      (    device_name: ost$name;
           device_type: nft$device_type;
           device_attributes: nft$device_attributes;
           io_station_name: ost$name;
       VAR variable_name: ost$name;
       VAR status: ost$status);

{ TYPE
{   device_attributes: record
{     banner_highlight_field: key
{         comment_banner, routing_banner, site_banner, user_file_name, user_name
{       keyend = $optional
{     banner_page_count: integer 0..3 = $optional
{     carriage_control_support: key
{         post_print, pre_and_post_print, pre_print
{       keyend = $optional
{     code_set: key
{         ascii, ascii_48, ascii_64, ascii_95, ascii_128, ascii_256, bcd, ebcdic, site_defined
{       keyend = $optional
{     device_alias_1: any of
{         key
{           none
{         keyend
{         name
{       anyend = $optional
{     device_alias_2: any of
{         key
{           none
{         keyend
{         name
{       anyend = $optional
{     device_alias_3: any of
{         key
{           none
{         keyend
{         name
{       anyend = $optional
{     device_name: name = $optional
{     device_type: key
{         console, plotter, printer, punch, reader
{       keyend = $optional
{     external_characteristics_1: string 0..6 = $optional
{     external_characteristics_2: string 0..6 = $optional
{     external_characteristics_3: string 0..6 = $optional
{     external_characteristics_4: string 0..6 = $optional
{     file_acknowledgement: boolean = $optional
{     forms_code_1: string 0..6 = $optional
{     forms_code_2: string 0..6 = $optional
{     forms_code_3: string 0..6 = $optional
{     forms_code_4: string 0..6 = $optional
{     forms_size: real 0.5..31.0 = $optional
{     maximum_file_size: integer 0..4294967295 = $optional
{     page_width: integer 10..255 = $optional
{     station: name = $optional
{     terminal_model: any of
{         key
{           none
{         keyend
{         name
{       anyend = $optional
{     tip_type: key
{         async, auto, bisync_3270, bisync_njef, hasp, internal, mode4, ntf, sna_3270, telnet
{         remote_term_emulator, uri, user1, user2, user3, user4, x25_async, xpc
{       keyend = $optional
{     transmission_block_size: integer 0..65535 = $optional
{     undefined_fe_action: key
{         discard_print_line, print_after_spacing, print_before_spacing
{       keyend = $optional
{     unsupported_fe_action: key
{         discard_print_line, print_after_spacing, print_before_spacing
{       keyend = $optional
{     vertical_print_density: key
{         eight_any, eight_only, six_any, six_only
{       keyend = $optional
{     vfu_load_option: key
{         changeable_by_operator, changeable_by_user, loaded_at_initialization, not_present_or_loadable
{       keyend = $optional
{     vfu_load_procedure: any of
{         key
{           none
{         keyend
{         name
{       anyend = $optional
{   recend
{ TYPEND

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    type_specification : [STATIC, READ, cls$declaration_section] record
      header: clt$type_specification_header,
      name: string (17),
      qualifier: clt$record_type_qualifier,
      field_spec_1: clt$field_specification,
      element_type_spec_1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
      recend,
      field_spec_2: clt$field_specification,
      element_type_spec_2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      field_spec_3: clt$field_specification,
      element_type_spec_3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      field_spec_4: clt$field_specification,
      element_type_spec_4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 9] of clt$keyword_specification,
      recend,
      field_spec_5: clt$field_specification,
      element_type_spec_5: 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$name_type_qualifier,
        recend,
      recend,
      field_spec_6: clt$field_specification,
      element_type_spec_6: 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$name_type_qualifier,
        recend,
      recend,
      field_spec_7: clt$field_specification,
      element_type_spec_7: 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$name_type_qualifier,
        recend,
      recend,
      field_spec_8: clt$field_specification,
      element_type_spec_8: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      field_spec_9: clt$field_specification,
      element_type_spec_9: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
      recend,
      field_spec_10: clt$field_specification,
      element_type_spec_10: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      field_spec_11: clt$field_specification,
      element_type_spec_11: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      field_spec_12: clt$field_specification,
      element_type_spec_12: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      field_spec_13: clt$field_specification,
      element_type_spec_13: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      field_spec_14: clt$field_specification,
      element_type_spec_14: record
        header: clt$type_specification_header,
      recend,
      field_spec_15: clt$field_specification,
      element_type_spec_15: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      field_spec_16: clt$field_specification,
      element_type_spec_16: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      field_spec_17: clt$field_specification,
      element_type_spec_17: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      field_spec_18: clt$field_specification,
      element_type_spec_18: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      field_spec_19: clt$field_specification,
      element_type_spec_19: record
        header: clt$type_specification_header,
        qualifier: clt$real_type_qualifier,
      recend,
      field_spec_20: clt$field_specification,
      element_type_spec_20: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      field_spec_21: clt$field_specification,
      element_type_spec_21: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      field_spec_22: clt$field_specification,
      element_type_spec_22: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      field_spec_23: clt$field_specification,
      element_type_spec_23: 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$name_type_qualifier,
        recend,
      recend,
      field_spec_24: clt$field_specification,
      element_type_spec_24: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 18] of clt$keyword_specification,
      recend,
      field_spec_25: clt$field_specification,
      element_type_spec_25: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      field_spec_26: clt$field_specification,
      element_type_spec_26: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      field_spec_27: clt$field_specification,
      element_type_spec_27: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      field_spec_28: clt$field_specification,
      element_type_spec_28: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      field_spec_29: clt$field_specification,
      element_type_spec_29: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      field_spec_30: clt$field_specification,
      element_type_spec_30: 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$name_type_qualifier,
        recend,
      recend,
    recend := [
      [1, 17, clc$record_type], 'DEVICE_ATTRIBUTES', [30],
      ['BANNER_HIGHLIGHT_FIELD         ', clc$optional_field, 192], [[1, 0, clc$keyword_type], [5], [
        ['COMMENT_BANNER                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['ROUTING_BANNER                 ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['SITE_BANNER                    ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['USER_FILE_NAME                 ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['USER_NAME                      ', clc$nominal_entry, clc$normal_usage_entry, 5]]
        ],
      ['BANNER_PAGE_COUNT              ', clc$optional_field, 20], [[1, 0, clc$integer_type], [0, 3, 10]],
      ['CARRIAGE_CONTROL_SUPPORT       ', clc$optional_field, 118], [[1, 0, clc$keyword_type], [3], [
        ['POST_PRINT                     ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['PRE_AND_POST_PRINT             ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['PRE_PRINT                      ', clc$nominal_entry, clc$normal_usage_entry, 3]]
        ],
      ['CODE_SET                       ', clc$optional_field, 340], [[1, 0, clc$keyword_type], [9], [
        ['ASCII                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['ASCII_128                      ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['ASCII_256                      ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['ASCII_48                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['ASCII_64                       ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['ASCII_95                       ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['BCD                            ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['EBCDIC                         ', clc$nominal_entry, clc$normal_usage_entry, 8],
        ['SITE_DEFINED                   ', clc$nominal_entry, clc$normal_usage_entry, 9]]
        ],
      ['DEVICE_ALIAS_1                 ', clc$optional_field, 69], [[1, 0, clc$union_type], [[
        clc$keyword_type, clc$name_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
          ],
        5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
        ],
      ['DEVICE_ALIAS_2                 ', clc$optional_field, 69], [[1, 0, clc$union_type], [[
        clc$keyword_type, clc$name_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
          ],
        5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
        ],
      ['DEVICE_ALIAS_3                 ', clc$optional_field, 69], [[1, 0, clc$union_type], [[
        clc$keyword_type, clc$name_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
          ],
        5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
        ],
      ['DEVICE_NAME                    ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['DEVICE_TYPE                    ', clc$optional_field, 192], [[1, 0, clc$keyword_type], [5], [
        ['CONSOLE                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['PLOTTER                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['PRINTER                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['PUNCH                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['READER                         ', clc$nominal_entry, clc$normal_usage_entry, 5]]
        ],
      ['EXTERNAL_CHARACTERISTICS_1     ', clc$optional_field, 8], [[1, 0, clc$string_type], [0, 6, FALSE]],
      ['EXTERNAL_CHARACTERISTICS_2     ', clc$optional_field, 8], [[1, 0, clc$string_type], [0, 6, FALSE]],
      ['EXTERNAL_CHARACTERISTICS_3     ', clc$optional_field, 8], [[1, 0, clc$string_type], [0, 6, FALSE]],
      ['EXTERNAL_CHARACTERISTICS_4     ', clc$optional_field, 8], [[1, 0, clc$string_type], [0, 6, FALSE]],
      ['FILE_ACKNOWLEDGEMENT           ', clc$optional_field, 3], [[1, 0, clc$boolean_type]],
      ['FORMS_CODE_1                   ', clc$optional_field, 8], [[1, 0, clc$string_type], [0, 6, FALSE]],
      ['FORMS_CODE_2                   ', clc$optional_field, 8], [[1, 0, clc$string_type], [0, 6, FALSE]],
      ['FORMS_CODE_3                   ', clc$optional_field, 8], [[1, 0, clc$string_type], [0, 6, FALSE]],
      ['FORMS_CODE_4                   ', clc$optional_field, 8], [[1, 0, clc$string_type], [0, 6, FALSE]],
      ['FORMS_SIZE                     ', clc$optional_field, 35], [[1, 0, clc$real_type],
        [[{0.5} 3, [[4000(16), 800000000000(16)], [4000(16), 0(16)]]],
        [{31.0} 3, [[4005(16), 0F80000000000(16)], [4005(16), 0(16)]]]]
        ],
      ['MAXIMUM_FILE_SIZE              ', clc$optional_field, 20], [[1, 0, clc$integer_type], [0, 4294967295
  , 10]],
      ['PAGE_WIDTH                     ', clc$optional_field, 20], [[1, 0, clc$integer_type], [10, 255, 10]],
      ['STATION                        ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['TERMINAL_MODEL                 ', clc$optional_field, 69], [[1, 0, clc$union_type], [[
        clc$keyword_type, clc$name_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
          ],
        5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
        ],
      ['TIP_TYPE                       ', clc$optional_field, 673], [[1, 0, clc$keyword_type], [18], [
        ['ASYNC                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['AUTO                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['BISYNC_3270                    ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['BISYNC_NJEF                    ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['HASP                           ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['INTERNAL                       ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['MODE4                          ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['NTF                            ', clc$nominal_entry, clc$normal_usage_entry, 8],
        ['REMOTE_TERM_EMULATOR           ', clc$nominal_entry, clc$normal_usage_entry, 11],
        ['SNA_3270                       ', clc$nominal_entry, clc$normal_usage_entry, 9],
        ['TELNET                         ', clc$nominal_entry, clc$normal_usage_entry, 10],
        ['URI                            ', clc$nominal_entry, clc$normal_usage_entry, 12],
        ['USER1                          ', clc$nominal_entry, clc$normal_usage_entry, 13],
        ['USER2                          ', clc$nominal_entry, clc$normal_usage_entry, 14],
        ['USER3                          ', clc$nominal_entry, clc$normal_usage_entry, 15],
        ['USER4                          ', clc$nominal_entry, clc$normal_usage_entry, 16],
        ['X25_ASYNC                      ', clc$nominal_entry, clc$normal_usage_entry, 17],
        ['XPC                            ', clc$nominal_entry, clc$normal_usage_entry, 18]]
        ],
      ['TRANSMISSION_BLOCK_SIZE        ', clc$optional_field, 20], [[1, 0, clc$integer_type], [0, 65535, 10]
  ],
      ['UNDEFINED_FE_ACTION            ', clc$optional_field, 118], [[1, 0, clc$keyword_type], [3], [
        ['DISCARD_PRINT_LINE             ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['PRINT_AFTER_SPACING            ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['PRINT_BEFORE_SPACING           ', clc$nominal_entry, clc$normal_usage_entry, 3]]
        ],
      ['UNSUPPORTED_FE_ACTION          ', clc$optional_field, 118], [[1, 0, clc$keyword_type], [3], [
        ['DISCARD_PRINT_LINE             ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['PRINT_AFTER_SPACING            ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['PRINT_BEFORE_SPACING           ', clc$nominal_entry, clc$normal_usage_entry, 3]]
        ],
      ['VERTICAL_PRINT_DENSITY         ', clc$optional_field, 155], [[1, 0, clc$keyword_type], [4], [
        ['EIGHT_ANY                      ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['EIGHT_ONLY                     ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['SIX_ANY                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['SIX_ONLY                       ', clc$nominal_entry, clc$normal_usage_entry, 4]]
        ],
      ['VFU_LOAD_OPTION                ', clc$optional_field, 155], [[1, 0, clc$keyword_type], [4], [
        ['CHANGEABLE_BY_OPERATOR         ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['CHANGEABLE_BY_USER             ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['LOADED_AT_INITIALIZATION       ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['NOT_PRESENT_OR_LOADABLE        ', clc$nominal_entry, clc$normal_usage_entry, 4]]
        ],
      ['VFU_LOAD_PROCEDURE             ', clc$optional_field, 69], [[1, 0, clc$union_type], [[
        clc$keyword_type, clc$name_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
          ],
        5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
        ]
      ];

?? FMT (FORMAT := ON) ??
?? POP ??

      CONST
        a$banner_highlight_field = 1,
        a$banner_page_count = 2,
        a$carriage_control_support = 3,
        a$code_set = 4,
        a$device_alias_1 = 5,
        a$device_alias_2 = 6,
        a$device_alias_3 = 7,
        a$device_name = 8,
        a$device_type = 9,
        a$external_characteristics_1 = 10,
        a$external_characteristics_2 = 11,
        a$external_characteristics_3 = 12,
        a$external_characteristics_4 = 13,
        a$file_acknowledgement = 14,
        a$forms_code_1 = 15,
        a$forms_code_2 = 16,
        a$forms_code_3 = 17,
        a$forms_code_4 = 18,
        a$forms_size = 19,
        a$maximum_file_size = 20,
        a$page_width = 21,
        a$station = 22,
        a$terminal_model = 23,
        a$tip_type = 24,
        a$transmission_block_size = 25,
        a$undefined_fe_action = 26,
        a$unsupported_fe_action = 27,
        a$vertical_print_density = 28,
        a$vfu_load_option = 29,
        a$vfu_load_procedure = 30,
        max_field_value = 30;

      VAR
        preset: clt$data_value;

      pmp$get_unique_name (variable_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      variable_name (1, 1) := 'V';

      preset.kind := clc$record;
      PUSH preset.field_values: [1 .. max_field_value];

      preset.field_values^ [a$banner_highlight_field].name := 'BANNER_HIGHLIGHT_FIELD';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$banner_highlight_field].value;
        preset.field_values^ [a$banner_highlight_field].value^.kind := clc$keyword;
        CASE device_attributes.banner_highlight_field OF
        = nfc$comment_banner =
          preset.field_values^ [a$banner_highlight_field].value^.keyword_value := 'COMMENT_BANNER';
        = nfc$routing_banner =
          preset.field_values^ [a$banner_highlight_field].value^.keyword_value := 'ROUTING_BANNER';
        = nfc$site_banner =
          preset.field_values^ [a$banner_highlight_field].value^.keyword_value := 'SITE_BANNER';
        = nfc$user_file_name =
          preset.field_values^ [a$banner_highlight_field].value^.keyword_value := 'USER_FILE_NAME';
        = nfc$user_name =
          preset.field_values^ [a$banner_highlight_field].value^.keyword_value := 'USER_NAME';
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$invalid_parameter_value, 'nfc$banner_highlight_field',
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'device_attributes in FILE_ASSIGNMENT',
                status);
          RETURN;
        CASEND;
      ELSE
        preset.field_values^ [a$banner_highlight_field].value := NIL;
      IFEND;

      preset.field_values^ [a$banner_page_count].name := 'BANNER_PAGE_COUNT';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$banner_page_count].value;
        preset.field_values^ [a$banner_page_count].value^.kind := clc$integer;
        preset.field_values^ [a$banner_page_count].value^.integer_value.radix_specified := FALSE;
        preset.field_values^ [a$banner_page_count].value^.integer_value.radix := 10;
        preset.field_values^ [a$banner_page_count].value^.integer_value.value :=
              device_attributes.banner_page_count;
      ELSE
        preset.field_values^ [a$banner_page_count].value := NIL;
      IFEND;

      preset.field_values^ [a$carriage_control_support].name := 'CARRIAGE_CONTROL_SUPPORT';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$carriage_control_support].value;
        preset.field_values^ [a$carriage_control_support].value^.kind := clc$keyword;
        CASE device_attributes.carriage_control_support OF
        = nfc$post_print =
          preset.field_values^ [a$carriage_control_support].value^.keyword_value := 'POST_PRINT';
        = nfc$pre_and_post_print =
          preset.field_values^ [a$carriage_control_support].value^.keyword_value := 'PRE_AND_POST_PRINT';
        = nfc$pre_print =
          preset.field_values^ [a$carriage_control_support].value^.keyword_value := 'PRE_PRINT';
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$invalid_parameter_value, 'nfc$carriage_control_support',
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'device_attributes in FILE_ASSIGNMENT',
                status);
          RETURN;
        CASEND;
      ELSE
        preset.field_values^ [a$carriage_control_support].value := NIL;
      IFEND;

      preset.field_values^ [a$code_set].name := 'CODE_SET';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$code_set].value;
        preset.field_values^ [a$code_set].value^.kind := clc$keyword;
        CASE device_attributes.code_set OF
        = nfc$ascii =
          preset.field_values^ [a$code_set].value^.keyword_value := 'ASCII';
        = nfc$ascii_48 =
          preset.field_values^ [a$code_set].value^.keyword_value := 'ASCII_48';
        = nfc$ascii_64 =
          preset.field_values^ [a$code_set].value^.keyword_value := 'ASCII_64';
        = nfc$ascii_95 =
          preset.field_values^ [a$code_set].value^.keyword_value := 'ASCII_95';
        = nfc$ascii_128 =
          preset.field_values^ [a$code_set].value^.keyword_value := 'ASCII_128';
        = nfc$ascii_256 =
          preset.field_values^ [a$code_set].value^.keyword_value := 'ASCII_256';
        = nfc$bcd =
          preset.field_values^ [a$code_set].value^.keyword_value := 'BCD';
        = nfc$ebcdic =
          preset.field_values^ [a$code_set].value^.keyword_value := 'EBCDIC';
        = nfc$site_defined =
          preset.field_values^ [a$code_set].value^.keyword_value := 'SITE_DEFINED';
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$invalid_parameter_value, 'nfc$code_set', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'device_attributes in FILE_ASSIGNMENT',
                status);
          RETURN;
        CASEND;
      ELSE
        preset.field_values^ [a$code_set].value := NIL;
      IFEND;

      preset.field_values^ [a$device_alias_1].name := 'DEVICE_ALIAS_1';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$device_alias_1].value;
        IF device_attributes.device_alias_1 <> osc$null_name THEN
          preset.field_values^ [a$device_alias_1].value^.kind := clc$name;
          preset.field_values^ [a$device_alias_1].value^.name_value := device_attributes.device_alias_1;
        ELSE
          preset.field_values^ [a$device_alias_1].value^.kind := clc$keyword;
          preset.field_values^ [a$device_alias_1].value^.keyword_value := 'NONE';
        IFEND;
      ELSE
        preset.field_values^ [a$device_alias_1].value := NIL;
      IFEND;

      preset.field_values^ [a$device_alias_2].name := 'DEVICE_ALIAS_2';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$device_alias_2].value;
        IF device_attributes.device_alias_2 <> osc$null_name THEN
          preset.field_values^ [a$device_alias_2].value^.kind := clc$name;
          preset.field_values^ [a$device_alias_2].value^.name_value := device_attributes.device_alias_2;
        ELSE
          preset.field_values^ [a$device_alias_2].value^.kind := clc$keyword;
          preset.field_values^ [a$device_alias_2].value^.keyword_value := 'NONE';
        IFEND;
      ELSE
        preset.field_values^ [a$device_alias_2].value := NIL;
      IFEND;

      preset.field_values^ [a$device_alias_3].name := 'DEVICE_ALIAS_3';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$device_alias_3].value;
        IF device_attributes.device_alias_3 <> osc$null_name THEN
          preset.field_values^ [a$device_alias_3].value^.kind := clc$name;
          preset.field_values^ [a$device_alias_3].value^.name_value := device_attributes.device_alias_3;
        ELSE
          preset.field_values^ [a$device_alias_3].value^.kind := clc$keyword;
          preset.field_values^ [a$device_alias_3].value^.keyword_value := 'NONE';
        IFEND;
      ELSE
        preset.field_values^ [a$device_alias_3].value := NIL;
      IFEND;

      preset.field_values^ [a$device_name].name := 'DEVICE_NAME';
      PUSH preset.field_values^ [a$device_name].value;
      preset.field_values^ [a$device_name].value^.kind := clc$name;
      preset.field_values^ [a$device_name].value^.name_value := device_name;

      preset.field_values^ [a$device_type].name := 'DEVICE_TYPE';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$device_type].value;
        preset.field_values^ [a$device_type].value^.kind := clc$keyword;
        CASE device_type OF
        = nfc$console =
          preset.field_values^ [a$device_type].value^.keyword_value := 'CONSOLE';
        = nfc$plotter =
          preset.field_values^ [a$device_type].value^.keyword_value := 'PLOTTER';
        = nfc$printer =
          preset.field_values^ [a$device_type].value^.keyword_value := 'PRINTER';
        = nfc$punch =
          preset.field_values^ [a$device_type].value^.keyword_value := 'PUNCH';
        = nfc$reader =
          preset.field_values^ [a$device_type].value^.keyword_value := 'READER';
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$invalid_parameter_value, 'nfc$device_type', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'device_attributes in FILE_ASSIGNMENT',
                status);
          RETURN;
        CASEND;
      ELSE
        preset.field_values^ [a$device_type].value := NIL;
      IFEND;

      preset.field_values^ [a$external_characteristics_1].name := 'EXTERNAL_CHARACTERISTICS_1';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$external_characteristics_1].value;
        preset.field_values^ [a$external_characteristics_1].value^.kind := clc$string;
        preset.field_values^ [a$external_characteristics_1].value^.string_value :=
              ^device_attributes.external_characteristics_1;
      ELSE
        preset.field_values^ [a$external_characteristics_1].value := NIL;
      IFEND;

      preset.field_values^ [a$external_characteristics_2].name := 'EXTERNAL_CHARACTERISTICS_2';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$external_characteristics_2].value;
        preset.field_values^ [a$external_characteristics_2].value^.kind := clc$string;
        preset.field_values^ [a$external_characteristics_2].value^.string_value :=
              ^device_attributes.external_characteristics_2;
      ELSE
        preset.field_values^ [a$external_characteristics_2].value := NIL;
      IFEND;

      preset.field_values^ [a$external_characteristics_3].name := 'EXTERNAL_CHARACTERISTICS_3';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$external_characteristics_3].value;
        preset.field_values^ [a$external_characteristics_3].value^.kind := clc$string;
        preset.field_values^ [a$external_characteristics_3].value^.string_value :=
              ^device_attributes.external_characteristics_3;
      ELSE
        preset.field_values^ [a$external_characteristics_3].value := NIL;
      IFEND;

      preset.field_values^ [a$external_characteristics_4].name := 'EXTERNAL_CHARACTERISTICS_4';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$external_characteristics_4].value;
        preset.field_values^ [a$external_characteristics_4].value^.kind := clc$string;
        preset.field_values^ [a$external_characteristics_4].value^.string_value :=
              ^device_attributes.external_characteristics_4;
      ELSE
        preset.field_values^ [a$external_characteristics_4].value := NIL;
      IFEND;

      preset.field_values^ [a$file_acknowledgement].name := 'FILE_ACKNOWLEDGEMENT';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$file_acknowledgement].value;
        preset.field_values^ [a$file_acknowledgement].value^.kind := clc$boolean;
        preset.field_values^ [a$file_acknowledgement].value^.boolean_value.kind := clc$true_false_boolean;
        preset.field_values^ [a$file_acknowledgement].value^.boolean_value.value :=
              device_attributes.file_acknowledgement;
      ELSE
        preset.field_values^ [a$file_acknowledgement].value := NIL;
      IFEND;

      preset.field_values^ [a$forms_code_1].name := 'FORMS_CODE_1';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$forms_code_1].value;
        preset.field_values^ [a$forms_code_1].value^.kind := clc$string;
        preset.field_values^ [a$forms_code_1].value^.string_value := ^device_attributes.forms_code_1;
      ELSE
        preset.field_values^ [a$forms_code_1].value := NIL;
      IFEND;

      preset.field_values^ [a$forms_code_2].name := 'FORMS_CODE_2';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$forms_code_2].value;
        preset.field_values^ [a$forms_code_2].value^.kind := clc$string;
        preset.field_values^ [a$forms_code_2].value^.string_value := ^device_attributes.forms_code_2;
      ELSE
        preset.field_values^ [a$forms_code_2].value := NIL;
      IFEND;

      preset.field_values^ [a$forms_code_3].name := 'FORMS_CODE_3';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$forms_code_3].value;
        preset.field_values^ [a$forms_code_3].value^.kind := clc$string;
        preset.field_values^ [a$forms_code_3].value^.string_value := ^device_attributes.forms_code_3;
      ELSE
        preset.field_values^ [a$forms_code_3].value := NIL;
      IFEND;

      preset.field_values^ [a$forms_code_4].name := 'FORMS_CODE_4';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$forms_code_4].value;
        preset.field_values^ [a$forms_code_4].value^.kind := clc$string;
        preset.field_values^ [a$forms_code_4].value^.string_value := ^device_attributes.forms_code_4;
      ELSE
        preset.field_values^ [a$forms_code_4].value := NIL;
      IFEND;

  { Special note about FORMS_SIZE:  the value provided by SCFS is in half-inches.
  { We divide this value by 2 to provide inches.

      preset.field_values^ [a$forms_size].name := 'FORMS_SIZE';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$forms_size].value;
        preset.field_values^ [a$forms_size].value^.kind := clc$real;
        preset.field_values^ [a$forms_size].value^.real_value.value :=
              $LONGREAL (device_attributes.forms_size) / 2.0D+0;
        preset.field_values^ [a$forms_size].value^.real_value.number_of_digits := 3;
      ELSE
        preset.field_values^ [a$forms_size].value := NIL;
      IFEND;

      preset.field_values^ [a$maximum_file_size].name := 'MAXIMUM_FILE_SIZE';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$maximum_file_size].value;
        preset.field_values^ [a$maximum_file_size].value^.kind := clc$integer;
        preset.field_values^ [a$maximum_file_size].value^.integer_value.radix_specified := FALSE;
        preset.field_values^ [a$maximum_file_size].value^.integer_value.radix := 10;
        preset.field_values^ [a$maximum_file_size].value^.integer_value.value :=
              device_attributes.maximum_file_size;
      ELSE
        preset.field_values^ [a$maximum_file_size].value := NIL;
      IFEND;

      preset.field_values^ [a$page_width].name := 'PAGE_WIDTH';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$page_width].value;
        preset.field_values^ [a$page_width].value^.kind := clc$integer;
        preset.field_values^ [a$page_width].value^.integer_value.radix_specified := FALSE;
        preset.field_values^ [a$page_width].value^.integer_value.radix := 10;
        preset.field_values^ [a$page_width].value^.integer_value.value := device_attributes.page_width;
      ELSE
        preset.field_values^ [a$page_width].value := NIL;
      IFEND;

      preset.field_values^ [a$station].name := 'STATION';
      PUSH preset.field_values^ [a$station].value;
      preset.field_values^ [a$station].value^.kind := clc$name;
      preset.field_values^ [a$station].value^.name_value := io_station_name;

      preset.field_values^ [a$terminal_model].name := 'TERMINAL_MODEL';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$terminal_model].value;
        IF device_attributes.terminal_model <> osc$null_name THEN
          preset.field_values^ [a$terminal_model].value^.kind := clc$name;
          preset.field_values^ [a$terminal_model].value^.name_value := device_attributes.terminal_model;
        ELSE
          preset.field_values^ [a$terminal_model].value^.kind := clc$keyword;
          preset.field_values^ [a$terminal_model].value^.keyword_value := 'NONE';
        IFEND;
      ELSE
        preset.field_values^ [a$terminal_model].value := NIL;
      IFEND;

      preset.field_values^ [a$tip_type].name := 'TIP_TYPE';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$tip_type].value;
        preset.field_values^ [a$tip_type].value^.kind := clc$keyword;
        CASE device_attributes.tip_type OF
        = nfc$async_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'ASYNC';
        = nfc$auto_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'AUTO';
        = nfc$bisync_3270_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'BISYNC_3270';
        = nfc$bisync_njef_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'BISYNC_NJEF';
        = nfc$hasp_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'HASP';
        = nfc$internal_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'INTERNAL';
        = nfc$mode4_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'MODE4';
        = nfc$ntf_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'NTF';
        = nfc$sna_3270_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'SNA_3270';
        = nfc$telnet_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'TELNET';
        = nfc$remote_term_emulator_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'REMOTE_TERM_EMULATOR';
        = nfc$uri_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'URI';
        = nfc$user1_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'USER1';
        = nfc$user2_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'USER2';
        = nfc$user3_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'USER3';
        = nfc$user4_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'USER4';
        = nfc$x25_async_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'X25_ASYNC';
        = nfc$xpc_tip =
          preset.field_values^ [a$tip_type].value^.keyword_value := 'XPC';
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$invalid_parameter_value, 'nfc$tip_type', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'device_attributes in FILE_ASSIGNMENT',
                status);
          RETURN;
        CASEND;
      ELSE
        preset.field_values^ [a$tip_type].value := NIL;
      IFEND;

      preset.field_values^ [a$transmission_block_size].name := 'TRANSMISSION_BLOCK_SIZE';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$transmission_block_size].value;
        preset.field_values^ [a$transmission_block_size].value^.kind := clc$integer;
        preset.field_values^ [a$transmission_block_size].value^.integer_value.radix_specified := FALSE;
        preset.field_values^ [a$transmission_block_size].value^.integer_value.radix := 10;
        preset.field_values^ [a$transmission_block_size].value^.integer_value.value :=
              device_attributes.transmission_block_size;
      ELSE
        preset.field_values^ [a$transmission_block_size].value := NIL;
      IFEND;

      preset.field_values^ [a$undefined_fe_action].name := 'UNDEFINED_FE_ACTION';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$undefined_fe_action].value;
        preset.field_values^ [a$undefined_fe_action].value^.kind := clc$keyword;
        CASE device_attributes.undefined_fe_action OF
        = nfc$discard_print_line =
          preset.field_values^ [a$undefined_fe_action].value^.keyword_value := 'DISCARD_PRINT_LINE';
        = nfc$print_after_spacing =
          preset.field_values^ [a$undefined_fe_action].value^.keyword_value := 'PRINT_AFTER_SPACING';
        = nfc$print_before_spacing =
          preset.field_values^ [a$undefined_fe_action].value^.keyword_value := 'PRINT_BEFORE_SPACING';
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$invalid_parameter_value, 'nfc$undefined_fe_action',
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'device_attributes in FILE_ASSIGNMENT',
                status);
          RETURN;
        CASEND;
      ELSE
        preset.field_values^ [a$undefined_fe_action].value := NIL;
      IFEND;

      preset.field_values^ [a$unsupported_fe_action].name := 'UNSUPPORTED_FE_ACTION';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$unsupported_fe_action].value;
        preset.field_values^ [a$unsupported_fe_action].value^.kind := clc$keyword;
        CASE device_attributes.unsupported_fe_action OF
        = nfc$discard_print_line =
          preset.field_values^ [a$unsupported_fe_action].value^.keyword_value := 'DISCARD_PRINT_LINE';
        = nfc$print_after_spacing =
          preset.field_values^ [a$unsupported_fe_action].value^.keyword_value := 'PRINT_AFTER_SPACING';
        = nfc$print_before_spacing =
          preset.field_values^ [a$unsupported_fe_action].value^.keyword_value := 'PRINT_BEFORE_SPACING';
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$invalid_parameter_value, 'nfc$unsupported_fe_action',
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'device_attributes in FILE_ASSIGNMENT',
                status);
          RETURN;
        CASEND;
      ELSE
        preset.field_values^ [a$unsupported_fe_action].value := NIL;
      IFEND;

      preset.field_values^ [a$vertical_print_density].name := 'VERTICAL_PRINT_DENSITY';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$vertical_print_density].value;
        preset.field_values^ [a$vertical_print_density].value^.kind := clc$keyword;
        CASE device_attributes.vertical_print_density OF
        = nfc$eight_any =
          preset.field_values^ [a$vertical_print_density].value^.keyword_value := 'EIGHT_ANY';
        = nfc$eight_only =
          preset.field_values^ [a$vertical_print_density].value^.keyword_value := 'EIGHT_ONLY';
        = nfc$six_any =
          preset.field_values^ [a$vertical_print_density].value^.keyword_value := 'SIX_ANY';
        = nfc$six_only =
          preset.field_values^ [a$vertical_print_density].value^.keyword_value := 'SIX_ONLY';
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$invalid_parameter_value, 'nfc$vertical_print_density',
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'device_attributes in FILE_ASSIGNMENT',
                status);
          RETURN;
        CASEND;
      ELSE
        preset.field_values^ [a$vertical_print_density].value := NIL;
      IFEND;

      preset.field_values^ [a$vfu_load_option].name := 'VFU_LOAD_OPTION';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$vfu_load_option].value;
        preset.field_values^ [a$vfu_load_option].value^.kind := clc$keyword;
        CASE device_attributes.vfu_load_option OF
        = nfc$vfu_changeable_by_operator =
          preset.field_values^ [a$vfu_load_option].value^.keyword_value := 'CHANGEABLE_BY_OPERATOR';
        = nfc$vfu_changeable_by_user =
          preset.field_values^ [a$vfu_load_option].value^.keyword_value := 'CHANGEABLE_BY_USER';
        = nfc$vfu_loaded_at_init =
          preset.field_values^ [a$vfu_load_option].value^.keyword_value := 'LOADED_AT_INITIALIZATION';
        = nfc$vfu_not_present_or_load =
          preset.field_values^ [a$vfu_load_option].value^.keyword_value := 'NOT_PRESENT_OR_LOADABLE';
        ELSE
          osp$set_status_abnormal (nfc$status_id, nfe$invalid_parameter_value, 'nfc$vfu_load_option', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'device_attributes in FILE_ASSIGNMENT',
                status);
          RETURN;
        CASEND;
      ELSE
        preset.field_values^ [a$vfu_load_option].value := NIL;
      IFEND;

      preset.field_values^ [a$vfu_load_procedure].name := 'VFU_LOAD_PROCEDURE';
      IF device_attributes.attributes_received THEN
        PUSH preset.field_values^ [a$vfu_load_procedure].value;
        IF device_attributes.vfu_load_procedure <> osc$null_name THEN
          preset.field_values^ [a$vfu_load_procedure].value^.kind := clc$name;
          preset.field_values^ [a$vfu_load_procedure].value^.name_value :=
                device_attributes.vfu_load_procedure;
        ELSE
          preset.field_values^ [a$vfu_load_procedure].value^.kind := clc$keyword;
          preset.field_values^ [a$vfu_load_procedure].value^.keyword_value := 'NONE';
        IFEND;
      ELSE
        preset.field_values^ [a$vfu_load_procedure].value := NIL;
      IFEND;

      clp$create_environment_variable (variable_name, clc$job_scope, clc$read_only,
            clc$immediate_evaluation, #SEQ (type_specification), ^preset, status);

    PROCEND create_device_attributes_var;

?? OLDTITLE ??
?? NEWTITLE := '    descriptor_values_match' , EJECT ??

{}
{  PURPOSE:
{    This procedure compares SCFS's values for the output file with SCF'S values for
{    the file.  If the values sent by SCFS match those of the descriptor, then SCFS
{    has the most recent output file information.  If the values sent by SCFS
{    do not match the descriptor, there are outstanding modifies to be processed.
{}

    FUNCTION descriptor_values_match (dummy_descriptor: jmt$output_descriptor;
          descriptor: jmt$output_descriptor;
          output_state: nft$file_transfer_state;
          last_parameter_sent: nft$file_assignment_params): boolean;

      VAR
        match: boolean;

      match := TRUE;

      IF last_parameter_sent > nfc$null_parameter THEN
        match := (dummy_descriptor.station = descriptor.station) AND
                (dummy_descriptor.device = descriptor.device) AND
                (dummy_descriptor.station_operator = descriptor.station_operator) AND
                (dummy_descriptor.output_destination_family = descriptor.output_destination_family) AND
                (dummy_descriptor.copies = descriptor.copies) AND
                (dummy_descriptor.external_characteristics = descriptor.external_characteristics)
                AND (dummy_descriptor.forms_code = descriptor.forms_code) AND
                (dummy_descriptor.vfu_load_procedure = descriptor.vfu_load_procedure) AND
                (dummy_descriptor.output_destination_usage = descriptor.output_destination_usage) AND
                (dummy_descriptor.vertical_print_density = descriptor.vertical_print_density);

{  If the file is in a hold state, the output priority isn't checked.  Since a file
{  assignment is coming in, the file has been selected and consequently,
{  the priority has been set to the maximum value.

        IF match AND (output_state <> nfc$hold_transfer) THEN
          match := match AND (dummy_descriptor.output_priority = descriptor.output_priority);
        IFEND;
      IFEND;

      descriptor_values_match := match;

    FUNCEND descriptor_values_match;
?? OLDTITLE, EJECT ??

   status.normal := TRUE;

   control_facility := NIL;
   scfs_values_match_descriptor := TRUE;

{  Get the parameters sent on the file assignment message and then verify
{  that the values sent from SCFS match those in SCF's copy of the file
{  descriptor.  If they do not, SCFS must process outstanding modifies and
{  the current file assignment message will be rejected.

    nfp$crack_file_assignment_msg (message, msg_length, io_station_name, device_name, device_type,
          device_attributes, btfs_di_xns_address, btfs_di_title, system_file_name, application_file,
          remote_system_protocol, remote_system_type, route_back_position, last_parameter_sent, status);

    message_response := nfc$file_assignment_rejected;

{ Set the appropriate BTFS/DI address:
{   - If there is a BTFS/DI title then get its network address.
{   - If there is no BTFS/DI title then use BTFS/DI XNS address (unless this
{     mainframe only supports OSI, which means SCF cannot support the transfer)

    IF status.normal AND (btfs_di_title.length > 0) THEN
      nfp$get_btfs_di_address (btfs_di_title, client_name, io_station_name, device_name,
            wait_list, wait_activity_list, btfs_di_network_address, status);
      IF (NOT status.normal) AND (status.condition = nae$no_translation_available) THEN
        message_response := nfc$btfsdi_title_not_translated;
      IFEND;
    ELSE
      protocol_stacks := nap$supported_protocol_stacks ();
      IF (((protocol_stacks DIV nac$xns_protocol_stack) DIV 2) * 2) <>
            (protocol_stacks DIV nac$xns_protocol_stack) THEN
        btfs_di_network_address.kind := nac$internet_address;
        btfs_di_network_address.internet_address := btfs_di_xns_address;
      ELSE
        osp$set_status_abnormal (nfc$status_id, nfe$incompatible_address_kind,
              ' ', status);
      IFEND;
    IFEND;

    IF status.normal THEN

      find_file_and_descriptor (system_file_name, first_destination, current_file, descriptor_found);
      IF descriptor_found THEN
        IF last_parameter_sent > nfc$null_parameter THEN
          scfs_values_match_descriptor := descriptor_values_match (application_file.output_descriptor,
                current_file^.output_descriptor, current_file^.transfer_state, last_parameter_sent);
        IFEND;

        IF (scfs_values_match_descriptor) AND ((NOT current_file^.transfer_initiated) OR
              ((current_file^.transfer_initiated) AND (current_file^.transfer_state = nfc$hold_transfer)))
              THEN

{ First control facility to respond to notification that a file was available for printing.

          application_file.output_descriptor := current_file^.output_descriptor;
          find_destination (application_file.output_descriptor.station, first_destination,
                destination_found, destination);
          IF destination_found THEN

{  Send a delete file available message to the control facilities with that
{  destination that haven't responded yet.

            control_facility_entry := destination^.control_facility_list;

          /search_control_facility_list/
            WHILE control_facility_entry <> NIL DO

              next_control_facility_entry := control_facility_entry^.link;
              IF control_facility_entry^.control_facility^.connection_id <> connection_id THEN
                nfp$send_delete_file_available (application_file, {held} FALSE, {requeued} FALSE,
                      control_facility_entry^.control_facility^.connection_id, message, status);
                IF (NOT status.normal) AND ((status.condition <> nae$no_data_available) AND
                        (status.condition <> nfe$invalid_descriptor_value)) THEN
                  remove_control_facility(first_destination, control_facility_entry^.control_facility ,
                        wait_list, wait_activity_list, status);
                  IF (NOT status.normal) AND ((status.condition = nae$application_inactive)
                        OR (status.condition = nae$unknown_application)) THEN
                    RETURN;
                  IFEND;
                IFEND;
              ELSE

{  Save the control facility which has the output file.  }

                control_facility := control_facility_entry^.control_facility;
              IFEND;
              control_facility_entry := next_control_facility_entry;
            WHILEND /search_control_facility_list/;
          IFEND;

{ Attempt to set the output status to 'printing'.  A status of abnormal indicates
{ that the file has been modified or terminated.  If the output has been
{ modified, it may not be set to 'printing' until the modify has been processed
{ If the file has been terminated, the file assignment message will be rejected.

          jmp$set_output_initiated (current_file^.output_descriptor.output_destination_usage,
                current_file^.output_descriptor.system_file_name, status);
          IF status.normal THEN
            current_file^.transfer_initiated := TRUE;
            current_file^.control_facility := control_facility;
            IF current_file^.output_descriptor.output_destination_usage = jmc$public_usage THEN
              application_file.q_file_password := public_queue_file_password;
            ELSE
              application_file.q_file_password := private_queue_file_password;
            IFEND;

            create_device_attributes_var (device_name, device_type, device_attributes, io_station_name,
                  device_attributes_variable, status);

            IF status.normal THEN
              nfp$start_btf_ve_task (btfs_di_network_address, btfs_di_title, io_station_name, device_name,
                    device_attributes_variable, device_attributes.attributes_received, application_file,
                    osc$null_name, debug_async_task, wait_list, wait_activity_list, wait_list_seq,
                    wait_activity_list_seq, btf_task, status);
              IF status.normal THEN
                current_file^.transfer_state := nfc$selected_for_transfer;
                current_file^.btf_task := btf_task;
                nfv$wait_activity_list := wait_activity_list;
                message_response := nfc$file_assignment_accepted;
              IFEND;
            IFEND;
          IFEND;

{ STATUS will be from JMP$SET_OUTPUT_INITIATED or CREATE_DEVICE_ATTRIBUTES_VAR or
{ NFP$START_BTF_VE_TASK.

          IF (NOT status.normal) AND current_file^.transfer_initiated THEN
            pmp$log ('**** SCF - Abnormal status (1) in file assignment message', local_status);
            nap$display_message (status);
            jmp$set_output_completed (current_file^.output_descriptor.output_destination_usage,
                  current_file^.output_descriptor.system_file_name, FALSE, ignore_status);
            current_file^.transfer_initiated := FALSE;
            current_file^.control_facility := NIL;
            remove_file_from_list (current_file^.output_descriptor.system_file_name,
                  destination^);
            nfp$send_delete_file_available (application_file, {held} FALSE, {requeued} FALSE,
                  connection_id, message, status);
          IFEND;

        IFEND;
      IFEND;
    ELSE
      pmp$log ('**** SCF - Abnormal status (2) in file assignment message', local_status);
      nap$display_message (status);
    IFEND;

    nfp$send_file_assignment_resp (io_station_name, device_name, system_file_name, message_response,
          connection_id, message, status);

  PROCEND file_assignment_message;
?? TITLE := '  find_destination', EJECT ??

{}
{  PURPOSE:
{    This procedure determines if the destination name is in SCF/VEs current
{    list of destinations.  If the destination was found, a pointer to
{    the destination is returned.
{}

  PROCEDURE find_destination (name: ost$name;
        first_destination: ^nft$destination;
    VAR destination_found: boolean;
    VAR destination: ^nft$destination);


    destination_found := FALSE;
    destination := first_destination;

  /search_destination_list/
    WHILE NOT destination_found AND (destination <> NIL) DO
      destination_found := name = destination^.name;
      IF NOT destination_found THEN
        destination := destination^.link;
      IFEND;
    WHILEND /search_destination_list/;

  PROCEND find_destination;
?? TITLE := '  find_file_and_descriptor', EJECT ??

{}
{  PURPOSE:
{    This procedure determines if the specified system file name is in
{    the list of files known to SCF/VE.
{}

  PROCEDURE find_file_and_descriptor (system_file_name: jmt$system_supplied_name;
        first_destination: ^nft$destination;
    VAR current_file: ^nft$available_file;
    VAR descriptor_found: boolean);

    VAR
      destination: ^nft$destination;


    destination := first_destination;
    descriptor_found := FALSE;

  /search_destination_list/
    WHILE NOT descriptor_found AND (destination <> NIL) DO
      current_file := destination^.file_list;

    /search_file_list/
      WHILE NOT descriptor_found AND (current_file <> NIL) DO

        descriptor_found := current_file^.output_descriptor.system_file_name = system_file_name;
        IF NOT descriptor_found THEN
          current_file := current_file^.link;
        IFEND;

      WHILEND /search_file_list/;

      destination := destination^.link;
    WHILEND /search_destination_list/;

  PROCEND find_file_and_descriptor;
?? TITLE := '  find_file_in_list', EJECT ??

{}
{  PURPOSE:
{    This procedure returns a pointer to the specified file.  If the file
{    was not found in the list of files known to SCF/VE, a nil pointer is
{    returned.
{}

  PROCEDURE find_file_in_list (system_file_name: jmt$system_supplied_name;
        first_destination: ^nft$destination;
    VAR requested_file: ^nft$available_file;
    VAR destination: ^nft$destination);

    VAR
      current_file: ^nft$available_file,
      file_found: boolean;


    destination := first_destination;
    file_found := FALSE;

  /search_destination_list/
    WHILE NOT file_found AND (destination <> NIL) DO
      current_file := destination^.file_list;

    /search_file_list/
      WHILE NOT file_found AND (current_file <> NIL) DO

        file_found := current_file^.output_descriptor.system_file_name = system_file_name;
        IF file_found THEN
          requested_file := current_file;
        ELSE
          current_file := current_file^.link;
        IFEND;

      WHILEND /search_file_list/;

      IF NOT file_found THEN
        destination := destination^.link;
      IFEND;

    WHILEND /search_destination_list/;

    IF NOT file_found THEN
      requested_file := NIL;
    IFEND;

  PROCEND find_file_in_list;
?? TITLE := '  get_control_facility', EJECT ??

{}
{  PURPOSE:
{    This procedure returns a list of control facility entries that
{    presently control a station with the destination name specified.
{}

  PROCEDURE get_control_facility (activity_index: integer;
    VAR wait_list: ^ost$i_wait_list;
    VAR wait_activity_list: ^nft$wait_activity_list;
    VAR destination: nft$destination;
    VAR control_facility_list: ^nft$linked_list_entry;
    VAR message: ^nft$message_sequence;
    VAR status: ost$status);

    VAR
      connection_file: ^fst$file_reference,
      connection_id: amt$file_identifier,
      control_facility: ^nft$control_facility,
      control_facility_name: ost$name,
      index: integer,
      known_control_facility: boolean,
      translation_address_array: ^ARRAY [1 .. * ] OF nat$network_address,
      translation_address_sequence: ^SEQ (*),
      unique_name: ost$name;

?? NEWTITLE := '    get_cf_with_service_address', EJECT ??

{}
{  PURPOSE:
{    Get the control facility that corresponds to an address returned
{    on the title translation for the destination name.
{}

    PROCEDURE get_cf_with_service_address (service: nat$network_address;
          wait_activity_list: ^nft$wait_activity_list;
      VAR control_facility: ^nft$control_facility;
      VAR control_facility_found: boolean);

      VAR
        i: integer,
        limit: integer;

      control_facility_found := FALSE;
      IF wait_activity_list <> NIL THEN
        limit := UPPERBOUND (wait_activity_list^);

      /search_wait_activity_list/
        FOR i := LOWERBOUND (wait_activity_list^) TO limit DO

          IF wait_activity_list^ [i].kind = nfc$control_facility_connection THEN
            IF wait_activity_list^ [i].cf <> NIL THEN
              IF nfp$network_addresses_match (service, wait_activity_list^ [i].cf^.service_addr) THEN
                IF service.kind = wait_activity_list^ [i].cf^.service_addr.kind THEN
                  IF service.kind = nac$osi_transport_address THEN
                    control_facility_found := service.osi_transport_address.
                          transport_sap_selector (1, service.osi_transport_address.
                          transport_sap_selector_length) = wait_activity_list^ [i].cf^.service_addr.
                          osi_transport_address.transport_sap_selector
                          (1, wait_activity_list^ [i].cf^.service_addr.osi_transport_address.
                          transport_sap_selector_length);
                  ELSEIF service.kind = nac$internet_address THEN
                    control_facility_found := service.internet_address.sap = wait_activity_list^ [i].
                          cf^.service_addr.internet_address.sap;
                  IFEND;
                IFEND;
              IFEND;
              IF control_facility_found THEN
                control_facility := wait_activity_list^ [i].cf;
                RETURN;
              IFEND;
            IFEND;
          IFEND;

        FOREND /search_wait_activity_list/;
      IFEND;

    PROCEND get_cf_with_service_address;
?? TITLE := '    get_title_translation_address', EJECT ??

{}
{  PURPOSE:
{    A translation request was made previously via nap$begin_directory_search.  This
{    procedure gets the title translations, obtaining the addresses which
{    correspond to the various locations of the title within the network.
{}

    PROCEDURE get_title_translation_address (activity_index: integer;
      VAR wait_list: ^ost$i_wait_list;
      VAR wait_activity_list: ^nft$wait_activity_list;
      VAR destination: nft$destination;
      VAR translation_address_sequence: ^SEQ (*);
      VAR translation_address_array: ^ARRAY [1 .. * ] OF nat$network_address;
      VAR status: ost$status);

      CONST
        max_addresses = 100,
        translation_wait_time = 0;

      VAR
        activity: nft$wait_activity,
        number_of_addresses: 0..max_addresses,
        recurrent_search: boolean,
        translation_address: nat$network_address,
        translation_address_ptr: ^nat$network_address,
        translation_attributes: ^nat$translation_attributes,
        translation_status: ost$status;


      status.normal := TRUE;
      number_of_addresses := 0;
      ALLOCATE translation_address_sequence: [[REP max_addresses of nat$network_address]];
      RESET translation_address_sequence;

{  Get all the addresses that correspond to the title translation.

      REPEAT
        translation_attributes := NIL;

        nap$get_title_translation (wait_list^ [activity_index].translation_request, translation_wait_time,
              translation_attributes, translation_address, translation_status);
        IF translation_status.normal THEN
          NEXT translation_address_ptr IN translation_address_sequence;
          translation_address_ptr^ := translation_address;
          number_of_addresses := number_of_addresses + 1;
        IFEND;

      UNTIL (NOT translation_status.normal);

{  Pass the translation addresses back to the calling procedure.

      IF number_of_addresses > 0 THEN
        RESET translation_address_sequence;
        NEXT translation_address_array: [1..number_of_addresses] IN translation_address_sequence;
      IFEND;

      IF translation_status.condition = nae$invalid_directory_search_id THEN
        reissue_translation_request (activity_index, wait_list, destination,
              status);
      IFEND;

    PROCEND get_title_translation_address;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    known_control_facility := FALSE;
    control_facility_list := NIL;
    control_facility := NIL;
    translation_address_array := NIL;
    translation_address_sequence := NIL;

    get_title_translation_address (activity_index, wait_list, wait_activity_list, destination,
          translation_address_sequence, translation_address_array, status);
    IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
          nae$unknown_application)) THEN
      RETURN;
    IFEND;

{ For each address returned on the title translation, add the corresponding
{ control facility to the wait lists if it isn't known, and add the
{ corresponding control facility to the control facility list.

    IF translation_address_array <> NIL THEN
      FOR index := 1 TO UPPERBOUND(translation_address_array^) DO

{  Get the control facility that corresponds to the particular address. }

        get_cf_with_service_address (translation_address_array^[index], wait_activity_list, control_facility,
              known_control_facility);
        IF NOT known_control_facility THEN
          pmp$get_unique_name (unique_name, status);
          connection_file := ^unique_name;

{  Establish a connection with the unknown control facility.

          nfp$establish_cf_connection (translation_address_array^[index], connection_file^,
                nfc$scfs_client_data_version, nfc$scf_ve_client, client_name, control_facility_name,
                connection_id, status);
          IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
                nae$unknown_application)) THEN
            RETURN;
          ELSEIF status.normal THEN

{ Send BTF/VE Status Message to the new control facility

            nfp$send_btf_ve_status (connection_id, message, status);

{  Add the control facility to the wait lists and to the control facility list.
            IF status.normal THEN
              add_control_facility_to_lists (control_facility_name, connection_file^, connection_id,
                    translation_address_array^[index], wait_list, wait_activity_list, control_facility);
              add_cf_to_control_fac_list(control_facility, control_facility_list);
            IFEND;
          IFEND;
        ELSE {control facility is currently known to SCFS}
          IF NOT cf_in_dest_control_fac_list (control_facility, control_facility_list) THEN
            add_cf_to_control_fac_list(control_facility, control_facility_list);
          IFEND;
        IFEND;
      FOREND;
    IFEND;

    FREE translation_address_sequence;

  PROCEND get_control_facility;
?? TITLE := '  get_destination_and_cntrl_fac', EJECT ??

{}
{  PURPOSE:
{    Check if the specified destination name is known, if it is not
{    known, add it to the destination list, add a title translation
{    for the destination and get the control facilities that have
{    a destination by that name.
{}

  PROCEDURE get_destination_and_cntrl_fac (destination_name: ost$name;
    VAR wait_list: ^ost$i_wait_list;
    VAR wait_activity_list: ^nft$wait_activity_list;
    VAR destination_list: ^nft$destination;
    VAR destination: ^nft$destination;
    VAR message: ^nft$message_sequence;
    VAR status: ost$status);

    VAR
      control_facility_list: ^nft$linked_list_entry,
      destination_found: boolean,
      local_status: ost$status;


    status.normal := TRUE;

    find_destination (destination_name, destination_list, destination_found, destination);

    IF NOT destination_found THEN
      add_destination_to_list (destination_name, destination_list, destination);

      add_await_title_translation(destination^, wait_list, wait_activity_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      get_control_facility (UPPERBOUND(wait_list^) , wait_list, wait_activity_list,
            destination^, control_facility_list, message, status);
      IF status.normal THEN
        destination^.control_facility_list := control_facility_list;
      IFEND;
    IFEND;

  PROCEND get_destination_and_cntrl_fac;
?? TITLE := '  initialize_scf_ve', EJECT ??

{}
{  PURPOSE:
{    Determine the "client name" for SCF/VE and
{    allocate space for messages sent and received on the network and
{    for the wait lists.
{}

  PROCEDURE initialize_scf_ve (parameter_list: clt$parameter_list;
    VAR public_queue_file_password: jmt$queue_file_password;
    VAR private_queue_file_password: jmt$queue_file_password;
    VAR wait_list: ^ost$i_wait_list;
    VAR message_area: ^nft$message_sequence;
    VAR status: ost$status);

    CONST
      eight_minutes = 8 * 60 * 1000, {milliseconds}
      max_wait_list_entries = 100;


    status.normal := TRUE;

    jmp$register_output_application (client_name, jmc$public_usage,
          public_queue_file_password, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    jmp$register_output_application (client_name, jmc$private_usage,
          private_queue_file_password, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, scf_command_pdt, status);
    IF status.normal THEN

      ALLOCATE message_area: [[REP nfc$maximum_message_length OF cell]];

      ALLOCATE wait_activity_list_seq: [[REP max_wait_list_entries OF nft$wait_activity]];

      ALLOCATE wait_list_seq: [[REP max_wait_list_entries OF ost$i_activity]];
      RESET wait_list_seq;
      NEXT wait_list: [1 .. 2] IN wait_list_seq;
      wait_list^ [1].activity := osc$i_await_unspecified_event;
      wait_list^ [2].activity := osc$i_await_time;
      wait_list^ [2].milliseconds := eight_minutes;

      nfp$create_appl_def_segment_var (nfc$appl_def_segment_for_scf, wait_list_seq);
    IFEND;

  PROCEND initialize_scf_ve;
?? OLDTITLE ??
?? NEWTITLE := 'reissue_translation_request', EJECT ??

{}
{  PURPOSE:
{    This procedure reissues a translation request that was previously
{    made via nap$begin_directory_search in the event that the translation
{    request becomes inactive.
{}

  PROCEDURE reissue_translation_request (index: integer;
    VAR wait_list: ^ost$i_wait_list;
    VAR destination: nft$destination;
    VAR status: ost$status);

    VAR
      recurrent_search: boolean,
      title: ^nat$title_pattern,
      translation_attributes: ^nat$translation_attributes;


    PUSH title: [start_of_scfs_title_length + osc$max_name_size];
    title^ (1, start_of_scfs_title_length) := start_of_scfs_title;
    title^ (1 + start_of_scfs_title_length, * ) := destination.name;

{  If a recurrent search is requested, distributed translations will continue }
{  to be examined and SCF will be notified of any new titles having the  }
{  specified characteristics. }

    recurrent_search := TRUE;
    nap$begin_directory_search (title^, client_name, recurrent_search, wait_list^ [index].
          translation_request, status);

    IF status.normal THEN
      destination.title_search_id := wait_list^ [index].translation_request;
      destination.translation_time_stamp := #FREE_RUNNING_CLOCK (0);
    IFEND;

  PROCEND reissue_translation_request;
?? TITLE := '  remove_control_facility', EJECT ??


{}
{  PURPOSE:
{    This procedure is called in the event that all reference to a specific
{    control facility should be removed.  The control facility is removed
{    from the destination lists and from the files.  The connection SCF/VE
{    has with the control facility is closed and the control facility is
{    removed from the wait lists.
{}

  PROCEDURE remove_control_facility (first_destination: ^nft$destination;
    VAR control_facility: ^nft$control_facility;
    VAR wait_list: ^ost$i_wait_list;
    VAR wait_activity_list: ^nft$wait_activity_list;
    VAR status: ost$status);

    VAR
      available_file: ^nft$available_file,
      cf_found_in_list: boolean,
      cf_list_entry: ^nft$linked_list_entry,
      destination: ^nft$destination,
      file_id: amt$file_identifier,
      file_name: amt$local_file_name,
      ignore_status: ost$status;

?? NEWTITLE := '    post_new_title_translation_req', EJECT ??

    PROCEDURE post_new_title_translation_req (destination: ^nft$destination;
      VAR wait_list: ^ost$i_wait_list;
      VAR wait_activity_list: ^nft$wait_activity_list;
      VAR status: ost$status);

      VAR
        high: integer,
        ignore_status: ost$status,
        index: integer,
        low: integer;


      status.normal := TRUE;

      low := LOWERBOUND (wait_activity_list^);
      high := UPPERBOUND (wait_activity_list^);

    /search_for_translation_request/
      FOR index := low TO high DO
        IF (wait_activity_list^[index].kind = nfc$title_translation_request) AND (wait_activity_list^[index].
              dest = destination) THEN
          nap$end_directory_search (destination^.title_search_id, ignore_status);
          reissue_translation_request (index, wait_list, destination^, status);
          IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
                nae$unknown_application)) THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND /search_for_translation_request/;

    PROCEND post_new_title_translation_req;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    destination := first_destination;
    IF control_facility <> NIL THEN
      file_id := control_facility^.connection_id;
      file_name := control_facility^.connection_file_name;
    IFEND;

    /search_destination_list/
    WHILE destination <> NIL DO

      cf_found_in_list := FALSE;
      cf_list_entry := destination^.control_facility_list;

      /remove_cf_from_destination/
      WHILE (cf_list_entry <> NIL) AND (NOT cf_found_in_list) DO
        IF cf_list_entry^.control_facility = control_facility THEN
          cf_found_in_list := TRUE;
          remove_linked_list_entry (cf_list_entry, destination^.control_facility_list);

          post_new_title_translation_req (destination, wait_list, wait_activity_list, status);

          IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
                nae$unknown_application)) THEN
            RETURN;
          IFEND;

          available_file := destination^.file_list;

          /remove_cf_from_file_list/
          WHILE available_file <> NIL DO
            IF available_file^.control_facility = control_facility THEN
              available_file^.control_facility := NIL;
            IFEND;
            available_file := available_file^.link;
          WHILEND /remove_cf_from_file_list/;
        IFEND;
        IF NOT cf_found_in_list THEN
          cf_list_entry := cf_list_entry^.link;
        IFEND;
      WHILEND /remove_cf_from_destination/;
      destination := destination^.link;
    WHILEND /search_destination_list/;

    fsp$close_file (file_id, ignore_status);
    amp$return (file_name, ignore_status);

    nfp$remove_from_wait_lists (control_facility^.wait_activity_index, wait_list, wait_activity_list,
          wait_list_seq, wait_activity_list_seq);

    control_facility := NIL;

  PROCEND remove_control_facility;
?? TITLE := '  remove_file_from_list', EJECT ??

{}
{  PURPOSE:
{    This procedure removes a file from the destinations file list.
{}

  PROCEDURE remove_file_from_list (system_file_name: jmt$system_supplied_name;
    VAR destination: nft$destination);

    VAR
      current_file: ^nft$available_file,
      file_found: boolean,
      status: ost$status;


    current_file := destination.file_list;

    IF current_file^.output_descriptor.system_file_name = system_file_name THEN
      destination.file_list := current_file^.link;
    ELSE
      file_found := FALSE;

    /search_file_list/
      WHILE (NOT file_found) AND (current_file <> NIL) DO
        file_found := current_file^.output_descriptor.system_file_name = system_file_name;
        IF file_found THEN
          current_file^.back_link^.link := current_file^.link;
        ELSE
          current_file := current_file^.link;
        IFEND;
      WHILEND /search_file_list/;
    IFEND;

    IF current_file^.link <> NIL THEN
      current_file^.link^.back_link := current_file^.back_link;
    IFEND;

    IF current_file <> NIL THEN
      FREE current_file;
    IFEND;

  PROCEND remove_file_from_list;
?? TITLE := '  remove_linked_list_entry', EJECT ??

{}
{  PURPOSE:
{    This procedure removes the specified link entry from the
{    doubly linked list.
{}

  PROCEDURE remove_linked_list_entry (VAR link_entry: ^nft$linked_list_entry;
        VAR linked_list: ^nft$linked_list_entry);

    VAR
      back_link: ^nft$linked_list_entry,
      current_link: ^nft$linked_list_entry,
      link: ^nft$linked_list_entry;

    current_link := link_entry;
    back_link := link_entry^.back_link;
    link := link_entry^.link;

    IF link <> NIL THEN
      link^.back_link := back_link;
    IFEND;

    IF back_link <> NIL THEN
      back_link^.link := link;
    IFEND;

    IF link_entry = linked_list THEN
      linked_list := link;
    IFEND;

    link_entry := link;

    FREE current_link;

  PROCEND remove_linked_list_entry;
?? TITLE := '  send_add_file_to_ctrl_facs', EJECT ??

{}
{  PURPOSE:
{    This procedure loops through the list of control facility entries and
{    sends an add file available message.
{}

  PROCEDURE send_add_file_to_ctrl_facs (VAR control_facility_list:  ^nft$linked_list_entry;
        output_descriptor:  jmt$output_descriptor;
        output_state: nft$file_transfer_state;
        destination_list:  ^nft$destination;
    VAR wait_list:  ^ost$i_wait_list;
    VAR wait_activity_list:  ^nft$wait_activity_list;
    VAR message:  ^nft$message_sequence;
    VAR status:  ost$status);

    VAR
      application_file: nft$application_file_descriptor,
      control_facility_entry: ^nft$linked_list_entry,
      next_control_facility_entry: ^nft$linked_list_entry;

    application_file.file_kind := nfc$output_file;
    application_file.output_descriptor := output_descriptor;

    control_facility_entry := control_facility_list;


  /search_control_facility_list/
    WHILE control_facility_entry <> NIL DO

      nfp$send_add_file_available (application_file, output_state,
            control_facility_entry^.control_facility^.connection_id, message, status);
      next_control_facility_entry := control_facility_entry^.link;
      IF NOT status.normal AND ((status.condition <> nae$no_data_available) AND
            (status.condition <> nfe$invalid_descriptor_value)) THEN
        remove_control_facility (destination_list, control_facility_entry^.control_facility,
              wait_list, wait_activity_list, status);
        IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
              nae$unknown_application)) THEN
          RETURN;
        IFEND;
      IFEND;
      control_facility_entry := next_control_facility_entry;

    WHILEND /search_control_facility_list/;

  PROCEND send_add_file_to_ctrl_facs;
?? TITLE := '  send_delete_file_to_ctrl_facs', EJECT ??

{}
{  PURPOSE:
{    This procedure loops through the list of control facility entries and
{    sends a delete file available message.
{}

  PROCEDURE send_delete_file_to_ctrl_facs (VAR control_facility_list:  ^nft$linked_list_entry;
        file_requeued:  boolean;
        output_descriptor:  jmt$output_descriptor;
        destination_list:  ^nft$destination;
    VAR wait_list:  ^ost$i_wait_list;
    VAR wait_activity_list:  ^nft$wait_activity_list;
    VAR message:  ^nft$message_sequence;
    VAR status:  ost$status);

    VAR
      application_file: nft$application_file_descriptor,
      control_facility_entry: ^nft$linked_list_entry,
      next_control_facility_entry: ^nft$linked_list_entry;

    application_file.file_kind := nfc$output_file;
    application_file.output_descriptor := output_descriptor;

    control_facility_entry := control_facility_list;

  /search_control_facility_list/
    WHILE control_facility_entry <> NIL DO

      nfp$send_delete_file_available (application_file, {held} FALSE, file_requeued,
            control_facility_entry^.control_facility^.connection_id, message, status);
      next_control_facility_entry := control_facility_entry^.link;
      IF NOT status.normal AND ((status.condition <> nae$no_data_available) AND
            (status.condition <> nfe$invalid_descriptor_value)) THEN
        remove_control_facility (destination_list, control_facility_entry^.control_facility,
              wait_list, wait_activity_list, status);
        IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
              nae$unknown_application)) THEN
          RETURN;
        IFEND;
      IFEND;
      control_facility_entry := next_control_facility_entry;

    WHILEND /search_control_facility_list/;

  PROCEND send_delete_file_to_ctrl_facs;
?? TITLE := '  terminate_scfs_queued_output', EJECT ??

{
{  PURPOSE:
{    This procedure deletes an output queue file from the queue if the file
{    specified in the message was controlled by the control facility that sent
{    the message.  A response is sent back to SCFS and then to OPES with the
{    result of the termination.
{

  PROCEDURE terminate_scfs_queued_output
     (    connection_id: amt$file_identifier;
          first_destination: ^nft$destination;
      VAR message: ^nft$message_sequence;
      VAR msg_length: integer;
      VAR wait_list: ^ost$i_wait_list;
      VAR wait_activity_list: ^nft$wait_activity_list;
      VAR status: ost$status);

    VAR
      current_file: ^nft$available_file,
      descriptor: jmt$output_descriptor,
      descriptor_found: boolean,
      destination: ^nft$destination,
      destination_found: boolean,
      file_name: ost$name,
      ignore_status: ost$status,
      io_station_name: ost$name,
      q_file: ^nft$available_file,
      response: nft$terqo_file_status_codes,
      system_file_name: jmt$system_supplied_name;

?? NEWTITLE := '    cf_connection_in_destination', EJECT ??

    FUNCTION cf_connection_in_destination
      (    connection_id: amt$file_identifier;
           destination: ^nft$destination): boolean;

      VAR
        connection_in_destination: boolean,
        control_facility_entry: ^nft$linked_list_entry,
        control_facility: ^nft$control_facility;


      connection_in_destination := FALSE;
      control_facility_entry := destination^.control_facility_list;

      WHILE (NOT connection_in_destination) AND (control_facility_entry <> NIL) DO
        connection_in_destination := (connection_id = control_facility_entry^.control_facility^.
              connection_id);
        IF NOT connection_in_destination THEN
          control_facility_entry := control_facility_entry^.link;
        IFEND;
      WHILEND;

    cf_connection_in_destination := connection_in_destination;

    FUNCEND cf_connection_in_destination;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    response := nfc$terqo_successful;

    nfp$crack_terqo_msg (message, msg_length, io_station_name, file_name, status);
    IF status.normal THEN
      system_file_name := file_name;

      find_file_and_descriptor (system_file_name, first_destination, current_file, descriptor_found);
      IF descriptor_found THEN
        descriptor := current_file^.output_descriptor;
        find_destination (descriptor.station, first_destination, destination_found, destination);
        IF destination_found AND cf_connection_in_destination (connection_id, destination) THEN
          jmp$set_output_initiated (descriptor.output_destination_usage, descriptor.system_file_name, status);
          IF status.normal THEN
            jmp$set_output_completed (descriptor.output_destination_usage, descriptor.system_file_name, TRUE,
                  ignore_status);

            remove_file_from_list (descriptor.system_file_name, destination^);

            send_delete_file_to_ctrl_facs (destination^.control_facility_list, FALSE, descriptor,
                  first_destination, wait_list, wait_activity_list, message, status);
          ELSE
            response := nfc$terqo_message_rejected;
          IFEND;
        ELSE
          response := nfc$terqo_message_rejected;
        IFEND;
      ELSE
        response := nfc$terqo_unknown_file_name;
      IFEND;
    ELSE
      response := nfc$terqo_message_rejected;
      pmp$log ('**** SCF - abnormal status returned on terminate queued output message', local_status);
      nap$display_message (status);
    IFEND;

    nfp$send_terqo_response_msg (io_station_name, file_name, response, connection_id, message, status);

  PROCEND terminate_scfs_queued_output;
?? TITLE := '  nfp$status_and_control_facility', EJECT ??

{}
{  PURPOSE:
{    This program implements the client application known as SCF/VE.
{    SCF/VE processes file control commands and informs SCFS/VE about
{    new output files, modified output files and terminated output files.
{    SCF/VE also initiates the task known as BTF/VE.  BTF/VE is the
{    host application which is responsible for the transfer of output
{    files from the host to the batch device.
{}
{  DESCRIPTION:
{    - establish condition handler
{    - initialize the application
{    - acquire all new, modified and terminated output
{}
{    LOOP
{      - process file assignment message from SCFS/VE
{      - process delete destination message from SCFS/VE
{      - process a title translation that was initially requested for an
{        unknown destination
{      - process message received from BTF/VE task (indication of transfer
{        complete)
{      - acquire all new, modified and terminated output
{    LOOPEND

  PROGRAM nfp$status_and_control_facility
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      activity_status: ost$activity_status,
      connection_id: amt$file_identifier,
      control_facility: ^nft$control_facility,
      debug_async_task: pmt$debug_mode,
      establish_descriptor: pmt$established_handler,
      exit_condition: [STATIC, READ] pmt$condition := [pmc$block_exit_processing, [pmc$block_exit,
        pmc$program_termination, pmc$program_abort]],
      local_status: ost$status,
      log_names: ARRAY [1..1] OF ost$name,
      message: ^nft$message_sequence,
      message_kind: ^nft$message_kind,
      message_length: integer,
      operator_message: ost$string,
      outstanding_operator_messages: ost$non_negative_integers,
      peer_operation: nat$se_peer_operation,
      private_queue_file_password: jmt$queue_file_password,
      public_queue_file_password: jmt$queue_file_password,
      ready_index: integer,
      wait_activity_list: ^nft$wait_activity_list,
      wait_list: ^ost$i_wait_list;

?? NEWTITLE := '    exit_condition_handler', EJECT ??

{  PURPOSE:
{    This procedure cleans up SCF/VEs environment in the event of a
{    termination.
{      - communication with all BTF/VE tasks will be terminated
{      - all connections will be closed
{      - title translation requests will be terminated
{      - queue file manager will be notified of output that has not
{        finished printing

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        current_file: ^nft$available_file,
        destination: ^nft$destination,
        file_id_is_valid: boolean,
        file_instance: ^bat$task_file_entry,
        file_name: amt$local_file_name,
        i: integer,
        ignore_status: ost$status,
        limit: integer;


      pmp$log ('Status Control Facility dropping', ignore_status);

      IF nfv$wait_activity_list <> NIL THEN
        limit := UPPERBOUND (nfv$wait_activity_list^);

      /clean_up_wait_activity_list/
        FOR i := LOWERBOUND (nfv$wait_activity_list^) TO limit DO
          IF nfv$wait_activity_list^ [i].kind = nfc$btfve_task_message THEN
            nfp$end_async_communication (FALSE, ignore_status);
          ELSEIF nfv$wait_activity_list^ [i].kind = nfc$control_facility_connection THEN
            IF nfv$wait_activity_list^ [i].cf <> NIL THEN
              bap$validate_file_identifier (nfv$wait_activity_list^ [i].cf^.connection_id,
                    file_instance, file_id_is_valid);
              IF file_id_is_valid THEN
                file_name := file_instance^.local_file_name;
                fsp$close_file (nfv$wait_activity_list^ [i].cf^.connection_id, ignore_status);
                amp$return (file_name, ignore_status);
              IFEND;
            IFEND;
          IFEND;
        FOREND /clean_up_wait_activity_list/;
      IFEND;

      destination := destination_list;

    /clean_up_destination_list/
      WHILE destination <> NIL DO
        nap$end_directory_search (destination^.title_search_id, ignore_status);
        current_file := destination^.file_list;

      /clean_up_file_list/
        WHILE current_file <> NIL DO
          jmp$set_output_completed (current_file^.output_descriptor.output_destination_usage,
                current_file^.output_descriptor.system_file_name, FALSE, ignore_status);
          current_file := current_file^.link;
        WHILEND /clean_up_file_list/;

        destination := destination^.link;
      WHILEND /clean_up_destination_list/;

      REPEAT
        clp$delete_variable (nfv$appl_def_segment_variables [nfc$appl_def_segment_for_scf], ignore_status);
      UNTIL NOT ignore_status.normal;

    PROCEND exit_condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    outstanding_operator_messages := 0;
    debug_async_task := FALSE;

    pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^establish_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    initialize_scf_ve (parameter_list, public_queue_file_password, private_queue_file_password,
         wait_list, message, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    acquire_all_output_files (message, wait_list, wait_activity_list, destination_list, status);
    IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
          nae$unknown_application)) THEN
      RETURN;
    IFEND;

    log_names [1] := 'JOB_MESSAGE';
    clp$log_comment ('Status and Control Facility', log_names, local_status);

  /main_program_loop/
    WHILE TRUE DO

      osp$i_await_activity_completion (wait_list^, ready_index, status);

      IF status.normal THEN
        IF outstanding_operator_messages > 0 THEN
          ofp$receive_operator_response (ofc$system_operator, osc$nowait, operator_message, local_status);
          IF local_status.normal THEN
            outstanding_operator_messages := outstanding_operator_messages - 1;
          IFEND;
        IFEND;

        CASE wait_list^ [ready_index].activity OF
        = nac$i_await_data_available =
          connection_id := wait_list^ [ready_index].file_identifier;
          nfp$get_connection_data (message, connection_id, peer_operation, activity_status, activity_status.
                status);
          IF activity_status.status.normal THEN
            IF peer_operation.kind = nac$se_send_data THEN
              message_length := peer_operation.data_length;

              RESET message;
              NEXT message_kind IN message;
              message_length := message_length - 1;
              CASE message_kind^ OF
              = nfc$file_assignment =
                file_assignment_message (connection_id, destination_list, debug_async_task,
                      public_queue_file_password, private_queue_file_password, message,
                      wait_list, wait_activity_list, message_length, status);

              = nfc$delete_destination =
                delete_destination_message (message, destination_list, wait_list, wait_activity_list,
                      message_length, status);

              = nfc$terminate_queue_output =
                terminate_scfs_queued_output (connection_id, destination_list, message, message_length,
                      wait_list, wait_activity_list,status);

              ELSE

{ SCF does not process any other kinds of messages that come in on the connection.

              CASEND;
            IFEND;
          ELSE
            control_facility := wait_activity_list^ [ready_index].cf;
            remove_control_facility (destination_list, control_facility, wait_list, wait_activity_list,
                  status);
            IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
                  nae$unknown_application)) THEN
              RETURN;
            IFEND;
          IFEND;

        = nac$i_await_title_translation =
          check_unknown_destination (message, ready_index, destination_list, wait_list, wait_activity_list,
                status);
          IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
                nae$unknown_application)) THEN
            RETURN;
          IFEND;

        = pmc$i_await_local_queue_message =
          check_for_btf_task_completion (message, ready_index, outstanding_operator_messages, wait_list,
                wait_activity_list, destination_list, status);
          IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
                nae$unknown_application)) THEN
            RETURN;
          IFEND;

        ELSE
          ;

        CASEND;

        acquire_all_output_files (message, wait_list, wait_activity_list, destination_list, status);
        IF (NOT status.normal) AND ((status.condition = nae$application_inactive) OR (status.condition =
              nae$unknown_application)) THEN
          RETURN;
        IFEND;

      ELSE
        pmp$log ('SCF received abnormal status from osp$i_await_activity_completion:', local_status);
        nap$display_message (status);
        RETURN;
      IFEND;

    WHILEND /main_program_loop/;

  PROCEND nfp$status_and_control_facility;
MODEND nfm$status_and_control_facility;
*DECK DECK=NFM$STATUS_CONTROL_FAC_SERVER EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Batch Device Support : Status and Control Facility Server' ??
MODULE nfm$status_control_fac_server;

{  DESCRIPTION:
{    This module contains the procedures and functions that collectively
{    implement the host application known as the control facility (SCFS/VE).
{
{  PURPOSE:
{    SCFS/VE is responsible for controlling the flow of output to batch devices, and
{    receiving batch device and file status and control commands.  The
{    station operator utility (operate_station) will make a connection to
{    the control facility (SCFS/VE) and pass along batch control commands.
{    SCFS/VE will process some of the commands itself, and relay others to the
{    proper SCF/VE or SCF/DI for processing.
{
{    SCFS/VE is also responsible for controlling the transfer of NTF files to
{    batch streams, and receiving batch stream and file status and control
{    commands.  The NTF operator utility (operate_ntf) will make a connection
{    to the control facility (SCFS/VE) and pass along batch control commands.
{    SCFS/VE will process some of the commands itself, and relay others to the
{    proper NTF/VE or SCF/DI for processing.

?? PUSH (LISTEXT := ON) ??
?? NEWTITLE := 'System Definitions', EJECT ??
*copyc nae$namve_conditions
*copyc nae$application_interfaces
*copyc nat$protocol_stack_integer
*copyc nfc$ntf_control_facility_prefix
*copyc nfe$status_control_fac_server
*copyc nft$accept_messages
*copyc nft$all_or_top_10_q_entries
*copyc nft$banner_highlight_field
*copyc nft$banner_page_count
*copyc nft$btfs_di_advanced_features
*copyc nft$btfs_di_title
*copyc nft$byte_array
*copyc nft$carriage_control_action
*copyc nft$code_set
*copyc nft$connection_address
*copyc nft$copies
*copyc nft$destination_unavail_actions
*copyc nft$device_control_resp_codes
*copyc nft$device_file_size
*copyc nft$device_max_page_length
*copyc nft$device_status
*copyc nft$device_status_data
*copyc nft$device_type
*copyc nft$display_status_resp_codes
*copyc nft$external_characteristics
*copyc nft$file_and_priority
*copyc nft$file_assignment_response
*copyc nft$file_count
*copyc nft$file_disposition
*copyc nft$file_position
*copyc nft$file_size
*copyc nft$file_transfer_state
*copyc nft$file_transfer_status
*copyc nft$file_vertical_print_density
*copyc nft$format_effector_actions
*copyc nft$forms_code
*copyc nft$forms_size
*copyc nft$input_job_size
*copyc nft$io_station_usage
*copyc nft$message_kind
*copyc nft$message_sequence
*copyc nft$network_address
*copyc nft$ntf_authority_level
*copyc nft$ntf_command_kind
*copyc nft$ntf_command_text
*copyc nft$ntf_inactivity_timer
*copyc nft$ntf_line_speed
*copyc nft$ntf_logical_line_data
*copyc nft$ntf_logical_line_number
*copyc nft$ntf_positive_acknowledge
*copyc nft$ntf_remote_system_count
*copyc nft$ntf_remote_system_data
*copyc nft$ntf_remote_system_kind
*copyc nft$ntf_remote_system_protocol
*copyc nft$ntf_remote_system_type
*copyc nft$ntf_remote_system_status
*copyc nft$ntf_route_back_position
*copyc nft$ntf_skip_punch_count
*copyc nft$ntf_system_identifier
*copyc nft$ntf_wait_a_bit
*copyc nft$optimize_list
*copyc nft$output_data_mode
*copyc nft$page_format
*copyc nft$page_length
*copyc nft$page_width
*copyc nft$parameter_value_length
*copyc nft$pm_message_actions
*copyc nft$priority
*copyc nft$priority_multiplier
*copyc nft$q_status_data
*copyc nft$scfs_client_identifier
*copyc nft$scfs_pdt
*copyc nft$select_file_response
*copyc nft$suppress_carriage_control
*copyc nft$terqo_file_status_codes
*copyc nft$terminal_model
*copyc nft$tip_type
*copyc nft$transmit_block_size
*copyc nft$unsolicited_device_msg
*copyc nft$vertical_print_density
*copyc nft$vfu_load_option
*copyc nft$vfu_load_procedure
*copyc ost$date_time
*copyc ost$name
*copyc ost$status
*copyc ost$time
*copyc osv$lower_to_upper
?? TITLE := 'XREF Procedures', EJECT ??
*copyc amp$get_segment_pointer
*copyc amp$get_next
*copyc amp$put_next
*copyc amp$return
*copyc bap$validate_file_identifier
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_integer
*copyc clp$convert_string_to_real
*copyc clp$delete_variable
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc jmp$print_file
*copyc nap$accept_connection
*copyc nap$acquire_connection
*copyc nap$add_server_title
*copyc nap$attach_server_application
*copyc nap$await_data_available
*copyc nap$begin_directory_search
*copyc nap$delete_server_title
*copyc nap$detach_server_application
*copyc nap$end_directory_search
*copyc nap$get_attributes
*copyc nap$get_title_translation
*copyc nap$se_receive_data
*copyc nap$se_send_data
*copyc nfp$crack_terqo_msg
*copyc nfp$create_appl_def_segment_var
*copyc nfp$get_connection_data
*copyc nfp$get_parameter_value_length
*copyc nfp$modify_param_value_length
*copyc nfp$network_addresses_match
*copyc nfp$put_parameter_value_length
*copyc nfp$send_message_on_connection
*copyc nfp$send_terqo_response_msg
*copyc osp$generate_log_message
*copyc osp$i_await_activity_completion
*copyc osp$set_status_abnormal
*copyc pfp$attach
*copyc pfp$define
*copyc pfp$define_catalog
*copyc pmp$compute_date_time_increment
*copyc pmp$establish_condition_handler
*copyc pmp$format_compact_date
*copyc pmp$get_compact_date_time
*copyc pmp$get_microsecond_clock
*copyc pmp$get_date
*copyc pmp$get_time
*copyc pmp$get_unique_name
*copyc pmp$log
*copyc pmp$wait
?? POP ??
?? TITLE := 'Global Definitions', EJECT ??

  TYPE
    nft$scfs_tables = record
      first_station_name_alias: ^nft$alias,
      first_io_station: ^nft$io_station,
      first_ntf_acc_remote_system: ^nft$alias,
      first_ntf_remote_system: ^nft$io_station,
      first_connection: ^nft$connection,
      first_ntf_operator: ^nft$connection,
      ntf_acc_remote_system_count: nft$ntf_remote_system_count,
      unknown_private_operators_q: ^nft$output_queue_file,
    recend;

  CONST
    nfc$ntf_remote_sys_seq_storage = 32;

  TYPE
    nft$io_station = record
      name: ost$name,
      required_operator_device: ost$name,
      file_acknowledgement: boolean,
      automatic_operator_control: boolean,
      operator_assigned: boolean,
      connected_operator: ^nft$connection,
      station_operational: boolean,
      batch_device_list: ^nft$batch_device,
      back_link: ^nft$io_station,
      link: ^nft$io_station,
      case usage: nft$io_station_usage of
      = nfc$public_io_station, nfc$private_io_station =
        alias_names: array [1 .. 3] of ost$name,
        check_ios_unique: boolean,
        default_job_destination: ost$name,
        destination_unavailable_action: nft$destination_unavail_actions,
        pm_message_action: nft$pm_message_actions,
        scfdi_connection_pointers: ^nft$pointer_list_entry,
        selected_files_queue: ^nft$selected_file,
        last_selected_file_in_q: ^nft$selected_file,
        alias_list: array [0 .. 3] of ^nft$alias,
      = nfc$ntf_remote_system =
        ntf_protocol: nft$ntf_remote_system_protocol,
        ntf_local_system_name: ost$name,
        ntf_authority_level: nft$ntf_authority_level,
        ntf_wait_a_bit: nft$ntf_wait_a_bit,
        ntf_inactivity_timer: nft$ntf_inactivity_timer,
        ntf_positive_acknowledge: nft$ntf_positive_acknowledge,
        ntf_remote_password: ost$name,
        ntf_local_password: ost$name,
        ntf_default_job_destination: ost$name,
        ntf_default_file_destination: ost$name,
        ntf_store_forward_destination: ost$name,
        ntf_remote_system_type: nft$ntf_remote_system_type,
        ntf_route_back_position: nft$ntf_route_back_position,
        ntf_request_permission_retry: boolean,
        ntf_logical_line_list: ^nft$ntf_logical_line,
        ntf_acc_remote_system_ptr_list: ^nft$pointer_list_entry,
      casend,
    recend;

  TYPE
    nft$selected_file = record
      back_link: ^nft$selected_file,
      link: ^nft$selected_file,
      output_file: ^nft$output_queue_file,
      device_selected: ost$name,
    recend;

  TYPE
    nft$ntf_logical_line = record
      logical_line_number: nft$ntf_logical_line_number,
      line_name: ost$name,
      line_speed: nft$ntf_line_speed,
      signon_status: nft$device_status,
      console_stream_name: ost$name,
      terminal_user_procedure: ost$name,
      scfdi_connection: ^nft$connection,
      back_link: ^nft$ntf_logical_line,
      link: ^nft$ntf_logical_line,
    recend;

  CONST
    nfc$max_di_response_msgs = 255;

  TYPE
    nft$di_response_messages = (nfc$start_bd, nfc$stop_bd, nfc$change_bd_attr, nfc$suppress_cc,
      nfc$terminate_xfer, nfc$position_file);

  TYPE
    nft$outstanding_di_responses = array [nft$di_response_messages] of 0 .. nfc$max_di_response_msgs;

  TYPE
    protocol_stacks = (xns_protocol_stack, osi_protocol_stack),
    protocol_stacks_set = set of protocol_stacks;

  TYPE
    nft$btfs_di_status_codes = (nfc$btfs_di_down, nfc$btfs_di_active);

  TYPE
    unreachable_btfs_di = record
      title: nft$btfs_di_title,
      timer: integer,
      link: ^unreachable_btfs_di,
    recend;

  TYPE
    nft$batch_device = record
      name: ost$name,
      device_status: nft$device_status,
      file_transfer_status: nft$file_transfer_status,
      alias_names: array [1 .. 3] of ost$name,
      device_type: nft$device_type,
      tip_type: nft$tip_type,
      terminal_model: nft$terminal_model,
      file_acknowledgement: boolean,
      transmission_block_size: nft$transmit_block_size,
      maximum_file_size: nft$device_file_size,
      maximum_page_length: nft$device_max_page_length,
      page_width: nft$page_width,
      page_length: nft$page_length,
      banner_page_count: nft$banner_page_count,
      banner_highlight_field: nft$banner_highlight_field,
      carriage_control_action: nft$carriage_control_action,
      external_characteristics: array [1 .. 4] of nft$external_characteristics,
      forms_code: array [1 .. 4] of nft$forms_code,
      suppress_carriage_control: nft$suppress_carriage_control,
      code_set: nft$code_set,
      vertical_print_density: nft$vertical_print_density,
      vfu_load_procedure: nft$vfu_load_procedure,
      forms_size: nft$forms_size,
      undefined_fe_action: nft$format_effector_actions,
      unsupported_fe_action: nft$format_effector_actions,
      vfu_load_option: nft$vfu_load_option,
      input_job: nft$input_job,
      btfs_di_protocol_stacks: protocol_stacks_set,
      btfs_di_status: nft$btfs_di_status_codes,
      btfs_di_address: nft$network_address,
      btfs_di_title: nft$btfs_di_title,
      device_timer_activated: boolean,
      timer_start_time: integer,
      number_of_files_requeued: 0 .. 1000,
      outstanding_di_responses: nft$outstanding_di_responses,
      last_unsolicited_msg_length: 0 .. nfc$max_unsolicited_msg_length,
      last_unsolicited_msg: nft$unsolicited_device_msg,
      transparent_mode: boolean,
      ntf_skip_punch_count: nft$ntf_skip_punch_count,
      ntf_logical_line_number: nft$ntf_logical_line_number,
      current_file: ^nft$output_queue_file,
      scfdi_connection: ^nft$connection,
      io_station: ^nft$io_station,
      back_link: ^nft$batch_device,
      link: ^nft$batch_device,
    recend;

  TYPE
    nft$input_job = record
      actual_destination: ost$name,
      requested_destination: ost$name,
      user_job_name: ost$name,
      system_job_name: ost$name,
      input_bytes_transferred: nft$input_job_size,
    recend;

  TYPE
    nft$queue_file_list = record
      queue_file: ^nft$output_queue_file,
      link: ^nft$queue_file_list,
    recend;

  TYPE
    nft$output_queue_file = record
      ios_name: ost$name,
      operator_name: ost$name,
      operator_family: ost$name,
      ios_usage: nft$io_station_usage,
      system_file_name: ost$name,
      system_job_name: ost$name,
      user_file_name: ost$name,
      user_job_name: ost$name,
      user_name: ost$name,
      family_name: ost$name,
      copies: nft$copies,
      device_name: ost$name,
      external_characteristics: nft$external_characteristics,
      file_size: nft$file_size,
      forms_code: nft$forms_code,
      output_data_mode: nft$output_data_mode,
      initial_priority: nft$priority,
      maximum_priority: nft$priority,
      priority_factor: nft$priority_multiplier,
      output_state: nft$file_transfer_state,
      time_stamp: ost$date_time,
      percent_complete: nft$file_position,
      page_width: nft$page_width,
      scfve_connection: ^nft$connection,
      assigned_device: ^nft$batch_device,
      next_scfve_queue: ^nft$output_queue_file,
      prior_scfve_queue: ^nft$output_queue_file,
      back_link: ^nft$output_queue_file,
      link: ^nft$output_queue_file,
      case device_type: nft$device_type of
      = nfc$null_device, nfc$console, nfc$reader =
        ,
      = nfc$printer =
        page_format: nft$page_format,
        page_length: nft$page_length,
        vertical_print_density: nft$file_vertical_print_density,
        vfu_load_procedure: nft$vfu_load_procedure,
      = nfc$punch, nfc$plotter =
        ,
      casend,
    recend;

  TYPE
    nft$connection_kind = (nfc$unknown_connection, nfc$scfdi_connection, nfc$scfve_connection,
      nfc$operator_connection, nfc$scfsve_connection, nfc$ntfve_connection, nfc$ntf_operator_connection);

  TYPE
    nft$connection = record
      file_name: amt$local_file_name,
      id: amt$file_identifier,
      back_link: ^nft$connection,
      link: ^nft$connection,
      peer_address: nat$network_address,
      wait_list_index: integer,
      case kind: nft$connection_kind of
      = nfc$scfdi_connection =
        btfs_di_status: nft$btfs_di_status_codes,
        btfs_di_address: nft$network_address,
        btfs_di_protocol_stacks: protocol_stacks_set,
        btfs_di_title: nft$btfs_di_title,
        btfs_di_advanced_features: nft$btfs_di_advanced_features,
      = nfc$scfve_connection, nfc$ntfve_connection =
        scfve_queue: ^nft$output_queue_file,
        ntf_system_identifier: nft$ntf_system_identifier,
        btf_ve_protocol_stacks: protocol_stacks_set,
        btf_ve_status_received: boolean,
        unreachable_btfs_di_list: ^unreachable_btfs_di,
      = nfc$operator_connection, nfc$ntf_operator_connection =
        user: ost$name,
        family: ost$name,
        ntf_operator_identifier: nft$ntf_system_identifier,
        operating_station: ^nft$io_station,
        accept_messages: boolean,
        prior_ntf_operator: ^nft$connection,
        next_ntf_operator: ^nft$connection,
      = nfc$scfsve_connection =
        ,
      casend,
    recend;

  TYPE
    nft$pointer_kind = (nfc$queue, nfc$io_station, nfc$batch_device, nfc$connection,
          nfc$ntf_acc_remote_system, nfc$ntf_remote_sys_logical_line);

  TYPE
    nft$pointer_list_entry = record
      back_link: ^nft$pointer_list_entry,
      link: ^nft$pointer_list_entry,
      case kind: nft$pointer_kind of
      = nfc$queue =
        queue: ^nft$output_queue_file,
      = nfc$io_station =
        io_station: ^nft$io_station,
      = nfc$batch_device =
        batch_device: ^nft$batch_device,
      = nfc$connection =
        connection: ^nft$connection,
      = nfc$ntf_acc_remote_system =
        ntf_acc_remote_system: ^nft$alias,
      = nfc$ntf_remote_sys_logical_line =
        ntf_remote_system: ^nft$io_station,
        ntf_logical_line_number: nft$ntf_logical_line_number,
      casend,
    recend;

  CONST
    nfc$max_alias_stations = 255;

  TYPE
    nft$title_kind = (nfc$station_title, nfc$alias_title);

  TYPE
    nft$number_of_alias_stations = 0 .. nfc$max_alias_stations,
    nft$alias_kind = (nfc$io_station_alias, nfc$batch_device_alias);

{ If TYPE nft$alias is modified, the following constant must be recalculated.

  CONST
    size_of_nft$alias = 53;

  TYPE
    nft$alias = record
      name: ost$name,
      back_link: ^nft$alias,
      link: ^nft$alias,
      case kind: nft$alias_kind of
      = nfc$io_station_alias =
        queue: ^nft$output_queue_file,
        station_list: ^nft$pointer_list_entry,
        station_title_registered: boolean,
        alias_title_registered: boolean,
        ntf_authority_level: nft$ntf_authority_level,
        ntf_remote_system_type: nft$ntf_remote_system_type,
        ntf_route_back_position: nft$ntf_route_back_position,
      = nfc$batch_device_alias =
        batch_device_pointer_list: ^nft$pointer_list_entry,
      casend,
    recend;

  TYPE
    nft$file_name_validation_result = (nfc$valid_file_name, nfc$duplicate_file_name,
          nfc$system_file_name_error);

  TYPE
    nft$wait_connection_list = array [wait_connection_list_lowest .. * ] of ^nft$connection;

  CONST
    automatic = 'AUTOMATIC                      ',
    long_scfs_timer = 0ffffffff(16),
    nfc$scf_ve_client_name = 'OSA$STATUS_CONTROL_FAC_CLIENT  ',
    nfc$wait_list_limit = 20,
    start_of_scfs_title = 'SCFS$',
    start_of_alias_title = 'SCFA$',
    start_of_title_length = 5,
    unreachable_btfs_di_wait_time = 60 * 1000,
    wait_connection_list_lowest = 3;

  TYPE
    file_status_transition_kind = (no_transition, file_transfer_begun, file_transfer_completed);

  TYPE
    file_acknowledge_msg = record
      message: string (25),
      msg_length: 0 .. 25,
    recend;

  VAR
    file_ack_messages: array [nft$file_transfer_status] of file_acknowledge_msg:=
          [['Finished', 9], ['Device disconnected', 19], ['VFU not loadable', 16],
          ['Transfer error', 14], ['Accounting limit exceded', 25], ['Dropped', 9],
          ['Requeued', 9], ['Held', 9], ['Started', 9], REP 7 OF * ];

  VAR
    ntf_signon_statuses: [READ, STATIC] array [nft$device_status] of string (20) := [REP 11 OF *,
          {nfc$ntf_waiting_signon} 'Waiting for signon',
          {nfc$ntf_signon_initiated} 'Signon initiated',
          {nfc$ntf_signed_on} 'Signed on',
          {nfc$ntf_signon_failed} 'Signon failed',
          {nfc$ntf_signed_off} 'Signed off'];

  VAR
    control_facility_name: ost$name := osc$null_name,
    scfs_event_logging: boolean := FALSE,
    scfs_log_file: ^fst$file_reference := NIL,
    scfs_log_file_identifier: amt$file_identifier,
    scfs_log_sequence: amt$segment_pointer,
    scfs_ntf_title: ^nat$title_pattern := NIL,
    scfs_tables: nft$scfs_tables,
    scfs_title: ^nat$title_pattern := NIL,
    server_name: nat$application_name,
    wait_connection_list_seq: ^SEQ ( * ) := NIL,
    wait_list_seq: ^SEQ ( * ) := NIL;

*copyc nfs$appl_def_segment_variables
*copyc nfv$appl_def_segment_variables
?? TITLE := 'add batch device msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from SCF/DI to
{    define a new batch device within an existing I/O station.  The request
{    is processed and a response is sent back to SCF/DI.  If a duplicate
{    device alias is specified, if the station name is not found, or if
{    the device name is a duplicate, a negative response is returned.
{
{    This procedure is also executed when a request is received from SCF/DI to
{    define a new batch stream within an existing NTF remote system.  The
{    request is processed and a response is sent back to SCF/DI.  If the remote
{    system name is not found or if the stream name is a duplicate, a negative
{    response is returned.

  PROCEDURE add_batch_device_msg
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      accept_add_ios_msg: boolean,
      batch_device: nft$batch_device,
      current_batch_device: ^nft$batch_device,
      device: ^nft$batch_device,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      message_response: nft$add_bd_responses,
      ntf_logical_line: ^nft$ntf_logical_line;

*copy nft$add_batch_device_message
*copy nft$add_bd_resp_codes

?? NEWTITLE := 'add batch device entry', EJECT ??

{  PURPOSE:
{    This procedure allocates space for a device entry and adds the entry
{    into the device list for the station.

    PROCEDURE add_batch_device_entry
      (    io_station: ^nft$io_station;
       VAR current_bd: ^nft$batch_device,
           bd_entry: nft$batch_device;
       VAR status: ost$status);

      VAR
        alias_index: 1 .. 3,
        new_batch_device: ^nft$batch_device;

      ALLOCATE new_batch_device;
      new_batch_device^ := bd_entry;

      IF io_station^.batch_device_list = NIL THEN
        io_station^.batch_device_list := new_batch_device;
        new_batch_device^.back_link := NIL;
      ELSE
        current_bd := io_station^.batch_device_list;
        WHILE current_bd^.link <> NIL DO
          current_bd := current_bd^.link;
        WHILEND;
        current_bd^.link := new_batch_device;
        new_batch_device^.back_link := current_bd;
      IFEND;

      current_bd := new_batch_device;
      current_bd^.link := NIL;

    PROCEND add_batch_device_entry;
?? TITLE := 'crack add batch device msg', EJECT ??

{  PURPOSE:
{    Determine the parameters and values sent by SCF/DI on the add batch
{    device message and set the attributes in the batch device entry
{    to those.

    PROCEDURE crack_add_batch_device_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR station_name: ost$name;
       VAR batch_device: nft$batch_device;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        banner_page_count: ^nft$banner_page_count,
        banner_highlight_field: ^nft$banner_highlight_field,
        boolean_parameter: ^boolean,
        calculated_page_length: 0 .. 2000,
        carriage_control_action: ^nft$carriage_control_action,
        code_set: ^nft$code_set,
        device_type: ^nft$device_type,
        device_status: ^nft$device_status,
        device_vpd_values: [STATIC] array [nft$vertical_print_density] OF 6..12 :=
             [{nfc$six_only} 6,       {nfc$eight_only} 8,
              {nfc$six_any}  6,       {nfc$eight_any}  8],
        file_ack: ^boolean,
        file_transfer_status: ^nft$file_transfer_status,
        forms_size: ^nft$forms_size,
        maximum_file_size: ^nft$device_file_size,
        maximum_page_length: ^nft$device_max_page_length,
        ntf_logical_line_number: ^nft$ntf_logical_line_number,
        ntf_skip_punch_count: ^nft$ntf_skip_punch_count,
        page_width: ^nft$page_width,
        page_length: ^nft$page_length,
        page_length_specified: boolean,
        parameter: ^nft$add_bd_message_parameter,
        suppress_carriage_control: ^nft$suppress_carriage_control,
        tip_type: ^nft$tip_type,
        transmission_block_size: ^nft$transmit_block_size,
        transparent_mode: ^boolean,
        undefined_fe_action: ^nft$format_effector_actions,
        unsupported_fe_action: ^nft$format_effector_actions,
        value_length: integer,
        vfu_load_option: ^nft$vfu_load_option,
        vertical_print_density: ^nft$vertical_print_density;

      page_length_specified := FALSE;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, station_name);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, batch_device.name);

        = nfc$device_status =
          NEXT device_status IN message;
          batch_device.device_status := device_status^;

        = nfc$file_transfer_status_param =
          NEXT file_transfer_status IN message;
          batch_device.file_transfer_status := file_transfer_status^;

        = nfc$device_alias_1 =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, batch_device.alias_names [1]);

        = nfc$device_alias_2 =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, batch_device.alias_names [2]);

        = nfc$device_alias_3 =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, batch_device.alias_names [3]);

        = nfc$device_type =
          NEXT device_type IN message;
          batch_device.device_type := device_type^;

        = nfc$tip_type =
          NEXT tip_type IN message;
          batch_device.tip_type := tip_type^;

        = nfc$terminal_model =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, batch_device.terminal_model);

        = nfc$file_acknowledgement =
          NEXT file_ack IN message;
          batch_device.file_acknowledgement := file_ack^;

        = nfc$transmission_block_size =
          NEXT transmission_block_size IN message;
          batch_device.transmission_block_size := transmission_block_size^;

        = nfc$maximum_file_size =
          NEXT maximum_file_size IN message;
          batch_device.maximum_file_size := maximum_file_size^;

        = nfc$page_width =
          NEXT page_width IN message;
          batch_device.page_width := page_width^;

        = nfc$page_length =
          NEXT page_length IN message;
          batch_device.page_length := page_length^;
          page_length_specified := TRUE;

        = nfc$banner_page_count =
          NEXT banner_page_count IN message;
          batch_device.banner_page_count := banner_page_count^;

        = nfc$banner_highlight_field =
          NEXT banner_highlight_field IN message;
          batch_device.banner_highlight_field := banner_highlight_field^;

        = nfc$carriage_control_action =
          NEXT carriage_control_action IN message;
          batch_device.carriage_control_action := carriage_control_action^;

        = nfc$forms_code_1 =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, batch_device.forms_code [1]);

        = nfc$forms_code_2 =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, batch_device.forms_code [2]);

        = nfc$forms_code_3 =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, batch_device.forms_code [3]);

        = nfc$forms_code_4 =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, batch_device.forms_code [4]);

        = nfc$external_characteristics_1 =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, batch_device.external_characteristics [1]);

        = nfc$external_characteristics_2 =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, batch_device.external_characteristics [2]);

        = nfc$external_characteristics_3 =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, batch_device.external_characteristics [3]);

        = nfc$external_characteristics_4 =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, batch_device.external_characteristics [4]);

        = nfc$suppress_carriage_control =
          NEXT suppress_carriage_control IN message;
          batch_device.suppress_carriage_control := suppress_carriage_control^;

        = nfc$code_set =
          NEXT code_set IN message;
          batch_device.code_set := code_set^;

        = nfc$vertical_print_density =
          NEXT vertical_print_density IN message;
          batch_device.vertical_print_density := vertical_print_density^;

        = nfc$vfu_load_procedure =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, batch_device.vfu_load_procedure);

        = nfc$forms_size =
          NEXT forms_size IN message;
          batch_device.forms_size := forms_size^;

        = nfc$undefined_fe_action =
          NEXT undefined_fe_action IN message;
          batch_device.undefined_fe_action := undefined_fe_action^;

        = nfc$unsupported_fe_action =
          NEXT unsupported_fe_action IN message;
          batch_device.unsupported_fe_action := unsupported_fe_action^;

        = nfc$vfu_load_option =
          NEXT vfu_load_option IN message;
          batch_device.vfu_load_option := vfu_load_option^;

        = nfc$device_maximum_page_length =
          NEXT maximum_page_length IN message;
          batch_device.maximum_page_length := maximum_page_length^;

        = nfc$ntf_skip_punch_count =
          NEXT ntf_skip_punch_count IN message;
          batch_device.ntf_skip_punch_count := ntf_skip_punch_count^;

        = nfc$transparent_mode =
          NEXT transparent_mode IN message;
          batch_device.transparent_mode := transparent_mode^;

        = nfc$ntf_logical_line_number =
          NEXT ntf_logical_line_number IN message;
          batch_device.ntf_logical_line_number := ntf_logical_line_number^;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

{  If the device is a printer and SCF/DI did not send up the page_length,
{  calculate the value based on the forms_size and vertical_print_density.
{  NOTE:  The calculated value may only be used if the value is less
{         than or equal to the maximum value allowed in the current protocol

      IF (batch_device.device_type = nfc$printer) AND (NOT page_length_specified) THEN
        calculated_page_length := (batch_device.forms_size*
              device_vpd_values[batch_device.vertical_print_density]) DIV 2;
        IF calculated_page_length <= nfc$maximum_page_length THEN
          batch_device.page_length := calculated_page_length;
        ELSE
{         use the default value set up at initialization
        IFEND;
      IFEND;

    PROCEND crack_add_batch_device_msg;
?? TITLE := 'duplicate device name found', EJECT ??

{  PURPOSE:
{    This function determines if the device name is already in the
{    specified device list.

    FUNCTION duplicate_device_name_found (device_name: ost$name;
          batch_device_list: ^nft$batch_device): boolean;

      VAR
        current_device: ^nft$batch_device,
        name_match: boolean;

      name_match := FALSE;
      current_device := batch_device_list;

      WHILE NOT name_match AND (current_device <> NIL) DO
        name_match := current_device^.name = device_name;
        IF NOT name_match THEN
          current_device := current_device^.link;
        IFEND;
      WHILEND;

      duplicate_device_name_found := name_match;

    FUNCEND duplicate_device_name_found;
?? TITLE := 'initialize batch device entry', EJECT ??

{  PURPOSE:
{    Initialize the fields in the structure used to contain information about
{    a batch device.  A batch device may be a printer, punch, plotter or a
{    reader.

    PROCEDURE initialize_batch_device_entry
      (VAR batch_device_entry: nft$batch_device);

      batch_device_entry.name := osc$null_name;
      batch_device_entry.device_status := nfc$device_not_ready;
      batch_device_entry.file_transfer_status := nfc$idle;
      batch_device_entry.alias_names [1] := osc$null_name;
      batch_device_entry.alias_names [2] := osc$null_name;
      batch_device_entry.alias_names [3] := osc$null_name;

      batch_device_entry.device_type := nfc$printer;
      batch_device_entry.tip_type := nfc$internal_tip;
      batch_device_entry.terminal_model := osc$null_name;
      batch_device_entry.file_acknowledgement := FALSE;
      batch_device_entry.transmission_block_size := nfc$max_transmit_block_size;

      batch_device_entry.maximum_file_size := nfc$max_file_size;
      batch_device_entry.page_width := nfc$minimum_page_width;
      batch_device_entry.page_length := nfc$maximum_page_length;
      batch_device_entry.maximum_page_length := nfc$device_max_page_length;
      batch_device_entry.banner_page_count := 1;
      batch_device_entry.banner_highlight_field := nfc$user_name;
      batch_device_entry.carriage_control_action := nfc$pre_print;

      batch_device_entry.forms_code [1] := 'NORMAL';
      batch_device_entry.forms_code [2] := '      ';
      batch_device_entry.forms_code [3] := '      ';
      batch_device_entry.forms_code [4] := '      ';

      batch_device_entry.external_characteristics [1] := 'NORMAL';
      batch_device_entry.external_characteristics [2] := '      ';
      batch_device_entry.external_characteristics [3] := '      ';
      batch_device_entry.external_characteristics [4] := '      ';

      batch_device_entry.suppress_carriage_control := FALSE;
      batch_device_entry.code_set := nfc$ascii;
      batch_device_entry.vertical_print_density := nfc$six_only;
      batch_device_entry.vfu_load_procedure := osc$null_name;

{ forms size is specified in multiples of 1/2 - so 22 stands for an 11 inch form

      batch_device_entry.forms_size := 22;
      batch_device_entry.undefined_fe_action := nfc$print_after_spacing;
      batch_device_entry.unsupported_fe_action := nfc$discard_print_line;
      batch_device_entry.vfu_load_option := nfc$vfu_not_present_or_load;
      batch_device_entry.last_unsolicited_msg_length := 0;
      batch_device_entry.last_unsolicited_msg := '';

      batch_device_entry.input_job.actual_destination := osc$null_name;
      batch_device_entry.input_job.requested_destination := osc$null_name;
      batch_device_entry.input_job.user_job_name := osc$null_name;
      batch_device_entry.input_job.system_job_name := osc$null_name;
      batch_device_entry.input_job.input_bytes_transferred := 0;

      batch_device_entry.device_timer_activated := FALSE;
      batch_device_entry.timer_start_time := 0;
      batch_device_entry.number_of_files_requeued := 0;

      batch_device_entry.ntf_skip_punch_count := 1;
      batch_device_entry.transparent_mode := TRUE;
      batch_device_entry.ntf_logical_line_number := 1;

      batch_device_entry.current_file := NIL;
      batch_device_entry.scfdi_connection := NIL;
      batch_device_entry.io_station := NIL;
      batch_device_entry.back_link := NIL;
      batch_device_entry.link := NIL;

      batch_device_entry.outstanding_di_responses [nfc$start_bd] := 0;
      batch_device_entry.outstanding_di_responses [nfc$stop_bd] := 0;
      batch_device_entry.outstanding_di_responses [nfc$change_bd_attr] := 0;
      batch_device_entry.outstanding_di_responses [nfc$suppress_cc] := 0;
      batch_device_entry.outstanding_di_responses [nfc$terminate_xfer] := 0;
      batch_device_entry.outstanding_di_responses [nfc$position_file] := 0;

    PROCEND initialize_batch_device_entry;
?? TITLE := 'send add bd response', EJECT ??

{  PURPOSE:
{    Build and send a message to SCF/DI containing SCFS's response
{    to the add batch device message.

    PROCEDURE send_add_bd_response
      (VAR message: ^nft$message_sequence;
           io_station_name: ost$name;
           device_name: ost$name;
           response_code: nft$add_bd_responses;
           connection: ^nft$connection;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        message_length: nft$message_length,
        message_type: ^nft$message_kind,
        parameter_kind: ^nft$add_del_bd_resp_parameter,
        parameter_kind_size: nft$message_length,
        param_length_size: nft$message_length,
        parameter_value_length: integer,
        response_param: ^nft$add_bd_responses;

*copy nft$add_del_device_response

      parameter_kind_size := #SIZE (nft$add_del_bd_resp_parameter);
      RESET message;

      NEXT message_type IN message;
      message_type^ := nfc$add_batch_device_resp;
      message_length := 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$io_station_name;
      parameter_value_length := clp$trimmed_string_size (io_station_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := io_station_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$device_name;
      parameter_value_length := clp$trimmed_string_size (device_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := device_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$response_code;
      NEXT response_param IN message;
      response_param^ := response_code;
      message_length := message_length + parameter_kind_size + 1;

      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;

    PROCEND send_add_bd_response;
?? OLDTITLE, EJECT ??

{  Initialize the batch device.  Determine the attribute values sent up on
{  the add batch device message, and put these values into the batch device
{  entry.

    initialize_batch_device_entry (batch_device);
    crack_add_batch_device_msg (message, msg_length, io_station_name, batch_device, status);

    message_response := nfc$message_accepted;

    IF duplicate_aliases (batch_device.alias_names) THEN
      message_response := nfc$duplicate_aliases_specified;
    ELSE
      find_io_station_or_remote_sys (io_station_name, connection, io_station, io_station_found);
      IF io_station_found AND (io_station^.usage = nfc$ntf_remote_system) THEN
        find_ntf_logical_line (batch_device.ntf_logical_line_number, io_station,
              ntf_logical_line, io_station_found);
      IFEND;

      IF io_station_found THEN
        IF duplicate_device_name_found (batch_device.name, io_station^.batch_device_list) THEN
          message_response := nfc$duplicate_device_name;
        ELSE

{  The add batch device message from SCF/DI will be accepted.  Update the
{  device information.

          batch_device.scfdi_connection := connection;
          batch_device.io_station := io_station;
          batch_device.btfs_di_status := connection^.btfs_di_status;
          batch_device.btfs_di_address := connection^.btfs_di_address;
          batch_device.btfs_di_protocol_stacks := connection^.btfs_di_protocol_stacks;
          batch_device.btfs_di_title := connection^.btfs_di_title;
          IF (io_station^.usage = nfc$ntf_remote_system) AND (batch_device.device_type = nfc$console)
                THEN
            ntf_logical_line^.signon_status := batch_device.device_status;
            ntf_logical_line^.console_stream_name := batch_device.name;
          IFEND;

          add_batch_device_entry (io_station, current_batch_device, batch_device, status);

{  If the device is an NTF console just signing in, check for files queued
{  for all known streams for this remote system.
{
{  If the device is an output device and the station is operational, find a
{  file to print at the device.
{
{  If the device is an NTF transmit stream and the the remote system is
{  operational, find a file to transfer on the stream.

          IF (io_station^.usage = nfc$ntf_remote_system) AND (batch_device.device_type = nfc$console) AND
                (ntf_logical_line^.signon_status = nfc$ntf_signed_on) AND
                (io_station^.batch_device_list <> NIL) THEN
            device := io_station^.batch_device_list;
            WHILE device <> NIL DO
              IF device_available_for_output (device) THEN
                find_file_for_device (device, message, status);
              IFEND;
              device := device^.link;
            WHILEND;
          ELSEIF (io_station^.station_operational) AND output_device_or_stream (^batch_device)
                AND (device_available_for_output (current_batch_device)) THEN
            find_file_for_device (current_batch_device, message, status);
          IFEND;
        IFEND;
      ELSE
        message_response := nfc$no_io_station_found;
      IFEND;
    IFEND;

{  Send the response to SCF/DI.

    send_add_bd_response (message, io_station_name, batch_device.name, message_response, connection, status);

  PROCEND add_batch_device_msg;
?? TITLE := 'add file availability msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a message is received from SCF/VE
{    requesting SCFS to add an output file entry to the output queue for
{    scheduling.  If the requested destination is known, the output file
{    is placed in the appropriate station queue.   If the destination is not
{    known to SCFS, the message is ignored.
{
{    This procedure is also executed when a message is received from NTF/VE
{    requesting SCFS to add an NTF file entry to the NTF queue for scheduling.
{    If the requested destination is known, the NTF file is placed in the
{    appropriate remote system queue.  If the destination is not known to SCFS,
{    the message is ignored.

  PROCEDURE add_file_availability_msg
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      alias_station_list: ^nft$pointer_list_entry,
      io_station: ^nft$io_station,
      new_file: nft$output_queue_file,
      q_found: boolean,
      queue_file: ^nft$output_queue_file,
      queue_pointer: ^^nft$output_queue_file;

*copy nft$file_availability_msg
?? NEWTITLE := 'add file to output queue', EJECT ??

{  PURPOSE:
{    This procedure allocates space for an output queue file entry and then
{    adds the new entry into the queue file list, which is a double-linked
{    list.

    PROCEDURE add_file_to_output_queue
      (    new_file: nft$output_queue_file;
       VAR q_list: ^^nft$output_queue_file;
       VAR queue_file: ^nft$output_queue_file;
       VAR status: ost$status);

      VAR
        new_q_file: ^nft$output_queue_file;

      ALLOCATE new_q_file;
      new_q_file^ := new_file;

      queue_file := q_list^;
      IF queue_file = NIL THEN
        q_list^ := new_q_file;
        new_q_file^.back_link := NIL;
      ELSE
        WHILE queue_file^.link <> NIL DO
          queue_file := queue_file^.link;
        WHILEND;
        queue_file^.link := new_q_file;
        new_q_file^.back_link := queue_file;
      IFEND;

      queue_file := new_q_file;

    PROCEND add_file_to_output_queue;
?? TITLE := 'add file to scfve queue', EJECT ??

{  PURPOSE:
{    This procedure links the output queue file into the SCF/VE queue.
{    The queue is determined by the connection the file availability
{    message came in on.

    PROCEDURE add_file_to_scfve_queue
      (    q_file: ^nft$output_queue_file;
           connection: ^nft$connection);

      VAR
        scfve_q_file: ^nft$output_queue_file;

      IF connection^.scfve_queue = NIL THEN
        connection^.scfve_queue := q_file;
        q_file^.prior_scfve_queue := NIL;
      ELSE
        scfve_q_file := connection^.scfve_queue;
        WHILE scfve_q_file^.next_scfve_queue <> NIL DO
          scfve_q_file := scfve_q_file^.next_scfve_queue;
        WHILEND;
        scfve_q_file^.next_scfve_queue := q_file;
        q_file^.prior_scfve_queue := scfve_q_file;
      IFEND;

    PROCEND add_file_to_scfve_queue;
?? TITLE := 'crack add file available msg', EJECT ??

{  PURPOSE:
{    Determine the parameters and values sent by SCF/VE on the file availability
{    message and set the output queue file attributes to those values.

    PROCEDURE crack_add_file_available_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR queue_entry: nft$output_queue_file;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        copies: ^nft$copies,
        device_type: ^nft$device_type,
        device_status: ^nft$device_status,
        file_size: ^nft$file_size,
        io_station_usage: ^nft$io_station_usage,
        output_data_mode: ^nft$output_data_mode,
        output_state: ^nft$file_transfer_state,
        page_format: ^amt$page_format,
        page_length: ^nft$page_length,
        page_width: ^nft$page_width,
        parameter: ^nft$file_available_msg_param,
        priority: ^nft$priority,
        priority_factor: ^nft$priority_multiplier,
        value_length: integer,
        vertical_print_density: ^nft$file_vertical_print_density;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$copies =
          NEXT copies IN message;
          queue_entry.copies := copies^;

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, queue_entry.device_name);

        = nfc$device_type =
          NEXT device_type IN message;
          queue_entry.device_type := device_type^;

        = nfc$external_characteristics =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, queue_entry.external_characteristics);

        = nfc$file_size =
          NEXT file_size IN message;
          queue_entry.file_size := file_size^;

        = nfc$forms_code =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, queue_entry.forms_code);

        = nfc$output_data_mode =
          NEXT output_data_mode IN message;
          queue_entry.output_data_mode := output_data_mode^;

        = nfc$output_initial_priority =
          NEXT priority IN message;
          queue_entry.initial_priority := priority^;

        = nfc$output_maximum_priority =
          NEXT priority IN message;
          queue_entry.maximum_priority := priority^;

        = nfc$output_priority_factor =
          NEXT priority_factor IN message;
          queue_entry.priority_factor := priority_factor^;

        = nfc$output_state =
          NEXT output_state IN message;
          queue_entry.output_state := output_state^;

        = nfc$page_format =
          NEXT page_format IN message;
          queue_entry.page_format := page_format^;

        = nfc$page_length =
          NEXT page_length IN message;
          queue_entry.page_length := page_length^;

        = nfc$page_width =
          NEXT page_width IN message;
          queue_entry.page_width := page_width^;

        = nfc$vertical_print_density =
          NEXT vertical_print_density IN message;
          queue_entry.vertical_print_density := vertical_print_density^;

        = nfc$vfu_load_procedure =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, queue_entry.vfu_load_procedure);

        ELSE
{         ERROR  ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_add_file_available_msg;
?? TITLE := 'initialize output queue entry', EJECT ??

    PROCEDURE initialize_output_queue_entry
      (VAR queue_entry: nft$output_queue_file);

      queue_entry.ios_name := osc$null_name;
      queue_entry.operator_name := osc$null_name;
      queue_entry.operator_family := osc$null_name;
      queue_entry.ios_usage := nfc$public_io_station;

      queue_entry.system_file_name := osc$null_name;
      queue_entry.system_job_name := osc$null_name;
      queue_entry.user_file_name := osc$null_name;
      queue_entry.user_job_name := osc$null_name;

      queue_entry.copies := 1;
      queue_entry.device_name := osc$null_name;
      queue_entry.external_characteristics := '';
      queue_entry.file_size := 0;
      queue_entry.forms_code := '';

      queue_entry.output_data_mode := nfc$coded_mode;
      queue_entry.initial_priority := 0;
      queue_entry.maximum_priority := 0;
      queue_entry.output_state := nfc$eligible_for_transfer;

      queue_entry.assigned_device := NIL;
      queue_entry.next_scfve_queue := NIL;
      queue_entry.prior_scfve_queue := NIL;
      queue_entry.back_link := NIL;
      queue_entry.link := NIL;

      queue_entry.device_type := nfc$printer;
      queue_entry.page_format := amc$burstable_form;
      queue_entry.page_length := nfc$maximum_page_length;
      queue_entry.page_width := nfc$maximum_page_width;
      queue_entry.vertical_print_density := nfc$vertical_print_density_none;
      queue_entry.vfu_load_procedure := osc$null_name;

    PROCEND initialize_output_queue_entry;
?? OLDTITLE, EJECT ??

    initialize_output_queue_entry (new_file);

    get_required_file_avail_params (message, msg_length, new_file, status);
    crack_add_file_available_msg (message, msg_length, new_file, status);

    pmp$get_compact_date_time (new_file.time_stamp, status);
    new_file.percent_complete := 0;
    new_file.scfve_connection := connection;

    q_found := FALSE;
    queue_pointer := NIL;
    IF new_file.ios_usage = nfc$public_io_station THEN
      find_public_queue (new_file.ios_name, queue_pointer, alias_station_list, q_found);

      IF q_found THEN
{       Check the first I/O station in the alias station list to see if it is a public station.
        io_station := alias_station_list^.io_station;
        q_found := io_station^.usage = nfc$public_io_station;
      IFEND;

{  A file sent to print at a private station must specify the "control facility"
{  for the station attribute.

    ELSEIF (new_file.ios_usage = nfc$private_io_station) AND (new_file.ios_name = control_facility_name) THEN
      find_private_queue (new_file.operator_name, new_file.operator_family, queue_pointer,
            alias_station_list, q_found);
      IF NOT q_found THEN
        q_found := NOT q_found;
        queue_pointer := ^scfs_tables.unknown_private_operators_q;
      IFEND;

    ELSEIF new_file.ios_usage = nfc$ntf_remote_system THEN
      find_ntf_remote_queue (new_file.ios_name, queue_pointer, alias_station_list);
      q_found := (queue_pointer <> NIL);
    IFEND;

    IF q_found THEN
      add_file_to_output_queue (new_file, queue_pointer, queue_file, status);

      add_file_to_scfve_queue (queue_file, connection);

      IF (queue_pointer <> ^scfs_tables.unknown_private_operators_q) AND
            (queue_file^.output_state = nfc$eligible_for_transfer) THEN
        output_file_assignment (queue_file, alias_station_list, message, connection, status);
      IFEND;
    IFEND;

  PROCEND add_file_availability_msg;
?? TITLE := 'add io station msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from SCF/DI to
{    define a new I/O station under control of this SCFS/VE copy.  The I/O
{    station name is checked against all I/O station definitions currently
{    known to SCFS/VE.  If it is a new station name, the definition is done.
{    If the station name already exists, a test is done on the "check io station
{    unique" parameter.  If this parameter is TRUE the definition is rejected.
{    If this parameter is FALSE, the definition is accepted if the existing
{    definition is found to be identical, and the current definition also has
{    "check io station unique" set to FALSE.  A response is sent back to
{    SCF/DI.
{
{    A negative response is also returned if the requested I/O station name or
{    alias conflicts with the name of an existing NTF remote system.

  PROCEDURE add_io_station_msg
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR wait_list: ^ost$i_wait_list;
     VAR wait_connection_list: ^nft$wait_connection_list;
     VAR status: ost$status);

    VAR
      alias_index: 1 .. 4,
      current_ios: ^nft$io_station,
      io_station: nft$io_station,
      last_ios: ^nft$io_station,
      message_response: nft$add_io_station_responses,
      ntf_acc_remote_system: ^nft$alias,
      operator_connection: ^nft$connection,
      operator_name: ost$name,
      station_found: boolean;

*copy nft$add_io_station_message
*copy nft$add_ios_resp_codes

?? NEWTITLE := 'add io station entry to table', EJECT ??

{  PURPOSE:
{    This procedure adds the I/O station entry to the SCFS tables.
{    The station entry is added to the I/O station list, to the
{    "station name-alias list" and to the station list(s) that
{    the station name-alias entries point to.
{  NOTE:
{    This routine assumes that LAST_IO_STATION^ is the last io station defined
{    in the list.  A new ios definition will be added to the end.

    PROCEDURE add_io_station_entry_to_table
      (VAR last_io_station: ^nft$io_station;
           new_ios_def: nft$io_station;
       VAR status: ost$status);

      VAR
        alias_found: boolean,
        alias_index: 1 .. 3,
        current_alias: ^nft$alias,
        new_io_station: ^nft$io_station,
        trailing_alias: ^nft$alias;

?? NEWTITLE := 'add ios to alias station list', EJECT ??

{  PURPOSE:
{    This procedure adds an entry to the station list that the station alias
{    name entries point to.

      PROCEDURE add_ios_to_alias_station_list
        (    alias_pt: ^nft$alias;
             current_ios: ^nft$io_station;
         VAR status: ost$status);

        VAR
          alias_station: ^nft$pointer_list_entry,
          trailing_alias: ^nft$pointer_list_entry;

        alias_station := alias_pt^.station_list;

        IF alias_station <> NIL THEN
          REPEAT
            IF alias_station^.io_station = current_ios THEN
              RETURN;
            IFEND;
            trailing_alias := alias_station;
            IF alias_station^.link <> NIL THEN
              alias_station := alias_station^.link;
            IFEND;
          UNTIL trailing_alias^.link = NIL;
        IFEND;

        add_pointer_list_entry (alias_station, nfc$io_station, status);
        IF alias_pt^.station_list = NIL THEN
          alias_pt^.station_list := alias_station;
        IFEND;

        alias_station^.io_station := current_ios;

      PROCEND add_ios_to_alias_station_list;
?? TITLE := 'add to station aliases', EJECT ??

{  PURPOSE:
{    This procedure adds an alias entry to the station name-alias list.  The
{    station alias list has an entry for each station value known to the
{    control facility (station names and alias station names).  Each
{    station alias entry has an output queue file list and an I/O
{    station list.  The station list contains a pointer to the station with
{    that name and to each station with a station alias of that name.
{  eg.  station name:   station1
{       aliases for station1:   station2, station3
{
{       station name:   station2
{       aliases for station2:   station3
{
{       station name:   station3
{       (no aliases defined for station3)
{
{  FIRST_STATION
{  NAME_ALIAS
{      |
{      |                      (each unit is a "pointer list entry")
{      |
{  name: station1            back link       back link      back link
{  back link           +---- link      ----- link      ---- link
{  link                |     ^ station1      ^station2      ^station3
{  station list -------+
{  queue list-------+
{      |            +--- list of queue files with destination of station1
{      |
{      |
{      |
{  name: station2            back link       back link
{  back link           +---- link      ----- link
{  link                |     ^ station2      ^station3
{  station list -------+
{  queue list-------+
{      |            +--- list of queue files with destination of station2
{      |
{      |
{      |
{  name: station3            back link
{  back link           +---- link
{  link                |     ^ station3
{  station list -------+
{  queue list-------+
{                   +---- list of queue files with destination of station3
{

      PROCEDURE add_to_station_aliases
        (    io_station_name: ost$name;
         VAR current_alias: ^nft$alias;
         VAR status: ost$status);

        VAR
          alias_found: boolean,
          trailing_alias: ^nft$alias;

        alias_found := FALSE;

        current_alias := scfs_tables.first_station_name_alias;
        trailing_alias := current_alias;

        IF (current_alias <> NIL) THEN
        /search_alias_list/
          REPEAT
            IF (current_alias^.name = io_station_name) THEN
              alias_found := TRUE;
            ELSE
              trailing_alias := current_alias;
              IF current_alias^.link <> NIL THEN
                current_alias := current_alias^.link;
              IFEND;
            IFEND;
          UNTIL alias_found OR (trailing_alias^.link = NIL);
        IFEND;

        IF NOT alias_found THEN
          add_new_alias_to_list (current_alias, io_station_name, nfc$io_station_alias, status);
        IFEND;

      PROCEND add_to_station_aliases;
?? OLDTITLE, EJECT ??

      ALLOCATE new_io_station;
      new_io_station^ := new_ios_def;

      IF scfs_tables.first_io_station = NIL THEN
        scfs_tables.first_io_station := new_io_station;
        new_io_station^.back_link := NIL;
      ELSE
        last_io_station^.link := new_io_station;
        new_io_station^.back_link := last_io_station;
      IFEND;

      last_io_station := new_io_station;
      last_io_station^.link := NIL;

{     The io station alias list is really a list of station and alias names.
      add_to_station_aliases (new_ios_def.name, current_alias, status);
      add_ios_to_alias_station_list (current_alias, last_io_station, status);

      IF scfs_tables.first_station_name_alias = NIL THEN
        scfs_tables.first_station_name_alias := current_alias;
      IFEND;

      last_io_station^.alias_list [0] := current_alias;

      FOR alias_index := 1 TO 3 DO
        IF (last_io_station^.alias_names [alias_index] <> osc$null_name) AND
              (last_io_station^.alias_names [alias_index] <> new_ios_def.name) THEN

{ Only add a station alias if the name is not null and is different from the name of the station.

          current_alias := scfs_tables.first_station_name_alias;
          trailing_alias := current_alias;
          alias_found := FALSE;

          IF (current_alias <> NIL) THEN
          /search_alias_list/
            REPEAT
              IF current_alias^.name = new_ios_def.alias_names [alias_index] THEN
                add_ios_to_alias_station_list (current_alias, last_io_station, status);
                alias_found := TRUE;
              ELSE
                trailing_alias := current_alias;
                IF current_alias^.link <> NIL THEN
                  current_alias := current_alias^.link;
                IFEND;
              IFEND;
            UNTIL alias_found OR (trailing_alias^.link = NIL);
          IFEND;

          IF NOT alias_found THEN
            add_new_alias_to_list (current_alias, new_ios_def.alias_names [alias_index], nfc$io_station_alias,
                   status);
            add_ios_to_alias_station_list (current_alias, last_io_station, status);
          IFEND;
          last_io_station^.alias_list [alias_index] := current_alias;
        IFEND;
      FOREND;

    PROCEND add_io_station_entry_to_table;
?? TITLE := 'add scf di connection', EJECT ??

{  PURPOSE:
{    Add the current SCF/DI connection to the list of SCF/DI connections
{    known for the I/O station.
{  NOTE:  An I/O station may be defined across multiple DI's, so a list
{    of the SCF/DI connections for a particular station must be maintained.

    PROCEDURE add_scf_di_connection
      (    io_station: ^nft$io_station;
           connection: ^nft$connection;
       VAR status: ost$status);

      VAR
        last_connect_pt: ^nft$pointer_list_entry;

      last_connect_pt := io_station^.scfdi_connection_pointers;

      IF io_station^.scfdi_connection_pointers <> NIL THEN
        WHILE last_connect_pt^.link <> NIL DO
          last_connect_pt := last_connect_pt^.link;
        WHILEND;
      IFEND;

{     Add pointer list entry for the connection pointer.
      add_pointer_list_entry (last_connect_pt, nfc$connection, status);

      last_connect_pt^.connection := connection;

      IF io_station^.scfdi_connection_pointers = NIL THEN
        io_station^.scfdi_connection_pointers := last_connect_pt;
      IFEND;

    PROCEND add_scf_di_connection;
?? TITLE := 'crack add io station msg', EJECT ??

{  PURPOSE:
{    Determine the parameters and values sent by SCF/DI on the add io station
{    message and set the I/O station attributes to those values.

    PROCEDURE crack_add_io_station_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR io_station: nft$io_station;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        boolean_parameter: ^boolean,
        destination_unavail_action: ^nft$destination_unavail_actions,
        file_ack: ^boolean,
        io_station_usage_param: ^nft$io_station_usage,
        parameter: ^nft$add_ios_message_parameter,
        pm_message_action: ^nft$pm_message_actions,
        value_length: integer;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, io_station.name);

        = nfc$io_station_alias_1 =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, io_station.alias_names [1]);

        = nfc$io_station_alias_2 =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, io_station.alias_names [2]);

        = nfc$io_station_alias_3 =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, io_station.alias_names [3]);

        = nfc$required_operator_device =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, io_station.required_operator_device);

        = nfc$station_usage =
          NEXT io_station_usage_param IN message;
          io_station.usage := io_station_usage_param^;

        = nfc$file_acknowledgement =
          NEXT file_ack IN message;
          io_station.file_acknowledgement := file_ack^;

        = nfc$check_station_unique =
          NEXT boolean_parameter IN message;
          io_station.check_ios_unique := boolean_parameter^;

        = nfc$auto_operator_control =
          NEXT boolean_parameter IN message;
          io_station.automatic_operator_control := boolean_parameter^;

        = nfc$default_job_destination =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, io_station.default_job_destination);

        = nfc$destination_unavail_action =
          NEXT destination_unavail_action IN message;
          io_station.destination_unavailable_action := destination_unavail_action^;

        = nfc$pm_message_action =
          NEXT pm_message_action IN message;
          io_station.pm_message_action := pm_message_action^;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_add_io_station_msg;
?? TITLE := 'io station match', EJECT ??

{  PURPOSE:
{    This function is used to determine if an I/O station definition with the
{    same station name as an existing station definition is valid.

    FUNCTION io_station_match (existing_io_station,
          new_io_station: nft$io_station): boolean;

      io_station_match :=

      (existing_io_station.alias_names [1] = new_io_station.alias_names [1]) AND

      (existing_io_station.alias_names [2] = new_io_station.alias_names [2]) AND

      (existing_io_station.alias_names [3] = new_io_station.alias_names [3]) AND

      (existing_io_station.check_ios_unique = new_io_station.check_ios_unique) AND

      (existing_io_station.required_operator_device = new_io_station.required_operator_device) AND

      (existing_io_station.usage = new_io_station.usage);

    FUNCEND io_station_match;
?? TITLE := 'get operator name', EJECT ??

    PROCEDURE get_operator_name
      (    station: ^nft$io_station;
       VAR operator_name: ost$name);

      VAR
        connection: ^nft$connection;

      IF station^.operator_assigned THEN
        connection := station^.connected_operator;
        operator_name := connection^.user;
      ELSE
        operator_name := osc$null_name;
      IFEND;

    PROCEND get_operator_name;
?? TITLE := 'register station alias titles', EJECT ??

{  PURPOSE:
{    Register the station name from the I/O station definition if the title
{    is not currently registered on the network.  Register the alias name if
{    SCFS/VE has not already done so.
{  NOTE:
{    The same destination may be known to two different control facilities.
{    Each one will register the title and a different network address will be
{    associated with each destination.

    PROCEDURE register_station_alias_titles
      (    io_station: ^nft$io_station;
       VAR message_response: nft$add_io_station_responses;
       VAR status: ost$status);

      VAR
        alias_pt: ^nft$alias,
        title: ^nat$title_pattern;

{  Register the station title on the network if it isn't currently known
{  on the network, and register the alias title if this SCFS hasn't already
{  done so.

      alias_pt := scfs_tables.first_station_name_alias;
      WHILE alias_pt <> NIL DO
        IF (io_station^.name = alias_pt^.name) THEN
          IF NOT alias_pt^.station_title_registered THEN
            register_new_title (alias_pt^.name, FALSE, status);
            IF NOT status.normal THEN
              message_response := nfc$not_unique_network_title;
            ELSE
              alias_pt^.station_title_registered := TRUE;
            IFEND;
          IFEND;
        ELSEIF (io_station^.alias_names [1] = alias_pt^.name) OR
              (io_station^.alias_names [2] = alias_pt^.name) OR
              (io_station^.alias_names [3] = alias_pt^.name) THEN
          IF NOT alias_pt^.alias_title_registered THEN
            PUSH title: [start_of_title_length + osc$max_name_size];
            title^ (1, start_of_title_length) := start_of_alias_title;
            title^ (1 + start_of_title_length, *) := alias_pt^.name;
            register_title (title^, status);
            IF status.normal THEN
              alias_pt^.alias_title_registered := TRUE;
            IFEND;
          IFEND;
        IFEND;

        alias_pt := alias_pt^.link;
      WHILEND;

    PROCEND register_station_alias_titles;
?? TITLE := 'send add io station response', EJECT ??

{  PURPOSE:
{    Build and send a message indicating SCFS's response to an
{    add io station message received from SCF/DI.

    PROCEDURE send_add_io_station_response
      (VAR message: ^nft$message_sequence;
           response_code: nft$add_io_station_responses;
           station_name: ost$name;
           connection: ^nft$connection;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        message_length: nft$message_length,
        message_type: ^nft$message_kind,
        parameter_kind: ^nft$add_ios_resp_msg_parameter,
        parameter_kind_size: nft$message_length,
        param_length_size: nft$message_length,
        parameter_value_length: integer,
        response_param: ^nft$add_io_station_responses;

*copy nft$add_io_station_response

      parameter_kind_size := #SIZE (nft$add_ios_resp_msg_parameter);
      RESET message;

      NEXT message_type IN message;
      message_type^ := nfc$add_io_station_resp;
      message_length := 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$io_station_name;
      parameter_value_length := clp$trimmed_string_size (station_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := station_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$response_code;
      NEXT response_param IN message;
      response_param^ := response_code;
      message_length := message_length + parameter_kind_size + 1;

      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;

    PROCEND send_add_io_station_response;
?? OLDTITLE, EJECT ??

    initialize_io_station (io_station);

    crack_add_io_station_msg (message, msg_length, io_station, status);

  {  A private I/O station is not allowed to have station aliases, set them to a null name. }

    IF io_station.usage = nfc$private_io_station THEN
      io_station.alias_names [1] := osc$null_name;
      io_station.alias_names [2] := osc$null_name;
      io_station.alias_names [3] := osc$null_name;
    IFEND;

    message_response := nfc$message_accepted;

    find_ntf_acc_remote_system (io_station.name, ntf_acc_remote_system);
    alias_index := 1;
    WHILE (ntf_acc_remote_system = NIL) AND
          (alias_index <= 3) DO
      find_ntf_acc_remote_system (io_station.alias_names [alias_index], ntf_acc_remote_system);
      alias_index := alias_index + 1;
    WHILEND;

    IF (ntf_acc_remote_system <> NIL) THEN
      message_response := nfc$duplicate_defs_do_not_match;
    ELSEIF duplicate_aliases (io_station.alias_names) THEN
      message_response := nfc$duplicate_alias_names;
    ELSE
      last_ios := NIL;
      current_ios := scfs_tables.first_io_station;
      station_found := FALSE;

    /search_for_station/
      WHILE NOT station_found AND (current_ios <> NIL) DO
        IF io_station.name = current_ios^.name THEN
          station_found := TRUE;

{  Since the IO station name is already known to SCFS, if the "check ios unique"
{  parameter on the known station is set to TRUE, the definition must be
{  rejected.

          IF current_ios^.check_ios_unique THEN
            message_response := nfc$duplicate_with_check_unique;
          ELSE
            add_scf_di_connection (current_ios, connection, status);
          IFEND;
        IFEND;
        IF NOT station_found THEN
          last_ios := current_ios;
          current_ios := current_ios^.link;
        IFEND;
      WHILEND /search_for_station/;

{  If the station is not currently known, add it to the tables. }

      IF NOT station_found THEN
        add_io_station_entry_to_table (last_ios, io_station, status);
        add_scf_di_connection (last_ios, connection, status);

        last_ios^.station_operational := (last_ios^.usage = nfc$public_io_station);

{  If the station is a public station, or a fixed-private station, register the
{  station name.

        IF (last_ios^.usage = nfc$public_io_station) OR ((last_ios^.usage = nfc$private_io_station) AND (NOT
              last_ios^.check_ios_unique)) THEN
          register_station_alias_titles (last_ios, message_response, status);
          IF message_response = nfc$not_unique_network_title THEN
            delete_io_station (connection, last_ios, message,
                  wait_list, wait_connection_list, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

{  Send a response back to SCF/DI.

    send_add_io_station_response (message, message_response, io_station.name, connection, status);

{  If the I/O station is already known and there is an operator assigned, send a start_io_station
{  message to SCF/DI.

    IF station_found AND status.normal AND (message_response = nfc$message_accepted) AND
          (current_ios^.usage <> nfc$ntf_remote_system) AND current_ios^.operator_assigned THEN
      operator_connection := current_ios^.connected_operator;
      send_start_io_station_msg (message, current_ios^.name, operator_connection^.user,
            operator_connection^.family, connection, status);
    IFEND;

  PROCEND add_io_station_msg;
?? TITLE := 'add new alias to list', EJECT ??
{  PURPOSE:
{    Allocate space for the specified alias type and initialize
{    the various fields.

  PROCEDURE add_new_alias_to_list
    (VAR alias_pt: ^nft$alias;
         alias_name: ost$name;
         alias_kind: nft$alias_kind;
     VAR status: ost$status);

    VAR
      new_alias: ^nft$alias;

    ALLOCATE new_alias;
    new_alias^.name := alias_name;
    new_alias^.kind := alias_kind;
    new_alias^.back_link := NIL;
    new_alias^.link := NIL;

    IF alias_pt <> NIL THEN
      alias_pt^.link := new_alias;
      new_alias^.back_link := alias_pt;
    IFEND;

    IF alias_kind = nfc$batch_device_alias THEN
      new_alias^.batch_device_pointer_list := NIL;
    ELSEIF alias_kind = nfc$io_station_alias THEN
      new_alias^.queue := NIL;
      new_alias^.station_list := NIL;
      new_alias^.station_title_registered := FALSE;
      new_alias^.alias_title_registered := FALSE;
      new_alias^.ntf_authority_level := nfc$ntf_none;
      new_alias^.ntf_remote_system_type := nfc$ntf_nos_ve;
      new_alias^.ntf_route_back_position := 0;
    IFEND;

    alias_pt := new_alias;

  PROCEND add_new_alias_to_list;
?? TITLE := 'add_ntf_acc_remote_system', EJECT ??

{  PURPOSE:
{    This procedure adds a specified accessible remote system to the SCFS
{    tables.

  PROCEDURE add_ntf_acc_remote_system
    (    acc_remote_system: ^nft$alias;
         remote_system: ^nft$io_station;
         logical_line: ^nft$ntf_logical_line);

    VAR
      acc_remote_system_ptr: ^nft$pointer_list_entry,
      acc_remote_system_ptr_entry: nft$pointer_list_entry,
      acc_remote_system_ptr_found: boolean,
      remote_system_ptr: ^nft$pointer_list_entry,
      remote_system_ptr_entry: nft$pointer_list_entry,
      remote_system_ptr_found: boolean;

    IF remote_system^.name = acc_remote_system^.name THEN
      acc_remote_system^.ntf_authority_level := remote_system^.ntf_authority_level;
      acc_remote_system^.ntf_remote_system_type := remote_system^.ntf_remote_system_type;
      acc_remote_system^.ntf_route_back_position := remote_system^.ntf_route_back_position;
    IFEND;

    find_ntf_remote_system_pointer (remote_system^.name, FALSE, 1, acc_remote_system,
          remote_system_ptr, acc_remote_system_ptr_found);
    find_ntf_remote_system_pointer (remote_system^.name, TRUE, logical_line^.logical_line_number,
          acc_remote_system, remote_system_ptr, remote_system_ptr_found);
    IF NOT remote_system_ptr_found THEN
      init_ntf_remote_sys_ptr_entry ( remote_system_ptr_entry);
      remote_system_ptr_entry.ntf_remote_system := remote_system;
      remote_system_ptr_entry.ntf_logical_line_number := logical_line^.logical_line_number;
      add_ntf_remote_system_pointer (remote_system_ptr_entry, remote_system_ptr, acc_remote_system,
             remote_system_ptr);
      IF NOT acc_remote_system_ptr_found THEN
        init_ntf_acc_rem_sys_ptr_entry ( acc_remote_system_ptr_entry);
        acc_remote_system_ptr_entry.ntf_acc_remote_system := acc_remote_system;
        ALLOCATE acc_remote_system_ptr;
        acc_remote_system_ptr^ := acc_remote_system_ptr_entry;
        acc_remote_system_ptr^.link := remote_system^.ntf_acc_remote_system_ptr_list;
        remote_system^.ntf_acc_remote_system_ptr_list := acc_remote_system_ptr;
      IFEND;
    IFEND;

  PROCEND add_ntf_acc_remote_system;
?? TITLE := 'add_ntf_acc_remote_system_msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from SCF/DI to
{    define a new NTF accessible remote system under control of this SCFS/VE
{    copy.  The NTF accessible remote system name is checked against all NTF
{    accessible remote system definitions currently known to SCFS/VE.  If it is
{    a new system name, the definition is done.  If the system name already
{    exists the definition is accepted if the existing definition is found to
{    be identical.  A response is sent back to SCF/DI.

  PROCEDURE add_ntf_acc_remote_system_msg
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      acc_remote_system: ^nft$alias,
      acc_remote_system_name: ost$name,
      authority_level: nft$ntf_authority_level,
      ios_alias: ^nft$alias,
      ios_alias_found: boolean,
      logical_line: ^nft$ntf_logical_line,
      logical_line_found: boolean,
      logical_line_number: nft$ntf_logical_line_number,
      message_response: nft$ntf_add_ars_response_codes,
      remote_system: ^nft$io_station,
      remote_system_found: boolean,
      remote_system_name: ost$name,
      remote_system_ptr: ^nft$pointer_list_entry,
      remote_system_ptr_found: boolean,
      remote_system_type: nft$ntf_remote_system_type,
      route_back_position: nft$ntf_route_back_position;

*copy nft$ntf_add_acc_rem_sys_msg
*copy nft$ntf_add_ars_response_codes
?? NEWTITLE := 'crack_add_acc_remote_system_msg', EJECT ??

    PROCEDURE crack_add_acc_remote_system_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR remote_system_name: ost$name;
       VAR logical_line_number: nft$ntf_logical_line_number;
       VAR acc_remote_system_name: ost$name;
       VAR authority_level: nft$ntf_authority_level;
       VAR remote_system_type: nft$ntf_remote_system_type;
       VAR route_back_position: nft$ntf_route_back_position;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        a_level: ^nft$ntf_authority_level,
        byte_array: ^nft$byte_array,
        line_number: ^nft$ntf_logical_line_number,
        parameter: ^nft$ntf_add_acc_rem_sys_msg,
        remote_sys_type: ^nft$ntf_remote_system_type,
        route_back: ^nft$ntf_route_back_position,
        value_length: integer;

      status.normal := TRUE;
      remote_system_type := nfc$ntf_nos_ve;
      route_back_position := 0;
      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$ntf_remote_system_name =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, remote_system_name);

        = nfc$ntf_logical_line_number =
          NEXT line_number IN message;
          logical_line_number := line_number^;

        = nfc$ntf_acc_remote_system_name =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, acc_remote_system_name);

        = nfc$ntf_authority_level =
          NEXT a_level IN message;
          authority_level := a_level^;

        = nfc$ntf_remote_system_type =
          NEXT remote_sys_type IN message;
          remote_system_type := remote_sys_type^;

        = nfc$ntf_route_back_position =
          NEXT route_back IN message;
          route_back_position := route_back^;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_add_acc_remote_system_msg;
?? TITLE := 'send_add_acc_remote_system_resp', EJECT ??

    PROCEDURE send_add_acc_remote_system_resp
      (VAR message: ^nft$message_sequence;
           response_code: nft$ntf_add_ars_response_codes;
           remote_system_name: ost$name;
           logical_line_number: nft$ntf_logical_line_number;
           acc_remote_system_name: ost$name;
           connection: ^nft$connection;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        line_number: ^nft$ntf_logical_line_number,
        message_length: nft$message_length,
        message_type: ^nft$message_kind,
        parameter_kind: ^nft$ntf_add_acc_rem_sys_resp,
        parameter_kind_size: nft$message_length,
        param_length_size: nft$message_length,
        parameter_value_length: integer,
        response_param: ^nft$ntf_add_ars_response_codes;

*copy nft$ntf_add_acc_rem_sys_resp

      status.normal := TRUE;
      parameter_kind_size := #SIZE (nft$ntf_add_acc_rem_sys_resp);
      RESET message;

      NEXT message_type IN message;
      message_type^ := nfc$add_ntf_acc_rem_sys_resp;
      message_length := 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$ntf_remote_system_name;
      parameter_value_length := clp$trimmed_string_size (remote_system_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := remote_system_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$ntf_logical_line_number;
      parameter_value_length := #SIZE (nft$ntf_logical_line_number);
      parameter_kind^.length_indicated := TRUE;
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      NEXT line_number IN message;
      line_number^ := logical_line_number;
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$ntf_acc_remote_system_name;
      parameter_value_length := clp$trimmed_string_size (acc_remote_system_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := acc_remote_system_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$response_code;
      NEXT response_param IN message;
      response_param^ := response_code;
      message_length := message_length + parameter_kind_size + 1;

      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;

    PROCEND send_add_acc_remote_system_resp;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    crack_add_acc_remote_system_msg (message, msg_length, remote_system_name, logical_line_number,
          acc_remote_system_name, authority_level, remote_system_type, route_back_position, status);
    message_response := nfc$message_accepted;

    find_io_station_alias (acc_remote_system_name, ios_alias, ios_alias_found);
    IF NOT ios_alias_found THEN
      find_ntf_acc_remote_system (acc_remote_system_name, acc_remote_system);
      IF (acc_remote_system <> NIL) THEN
        find_ntf_remote_system (remote_system_name, remote_system, remote_system_found);
        IF remote_system_found THEN
          find_ntf_logical_line (logical_line_number, remote_system, logical_line,
                logical_line_found);
          IF logical_line_found THEN
            find_ntf_remote_system_pointer (remote_system_name, TRUE, logical_line_number,
                  acc_remote_system, remote_system_ptr, remote_system_ptr_found);
            IF remote_system_ptr_found THEN
              message_response := nfc$ntf_dup_defs_do_not_match;
            IFEND;

            IF (message_response = nfc$message_accepted) AND (acc_remote_system^.station_list <>
                  NIL) AND ((acc_remote_system^.ntf_remote_system_type <>
                  remote_system_type) OR (acc_remote_system^.ntf_route_back_position <> route_back_position))
                  THEN
              message_response := nfc$ntf_dup_defs_do_not_match;
            IFEND;

            IF message_response = nfc$message_accepted THEN
              acc_remote_system^.ntf_remote_system_type := remote_system_type;
              acc_remote_system^.ntf_route_back_position := route_back_position;
              add_ntf_acc_remote_system (acc_remote_system, remote_system, logical_line);
            IFEND;
          ELSE
            message_response := nfc$ntf_logical_line_not_found;
          IFEND;
        ELSE
          message_response := nfc$ntf_remote_system_not_found;
        IFEND;
      ELSE
        message_response := nfc$ntf_remote_sys_not_listed;
      IFEND;
    ELSE
      message_response := nfc$ntf_dup_defs_do_not_match;
    IFEND;

    send_add_acc_remote_system_resp (message, message_response, remote_system_name, logical_line_number,
          acc_remote_system_name, connection, status);

    IF message_response = nfc$message_accepted THEN
      find_files_for_ntf_logical_line (remote_system, logical_line_number, message, status);
    IFEND;
  PROCEND add_ntf_acc_remote_system_msg;
?? TITLE := 'add_ntf_logical_line_entry', EJECT ??

{  PURPOSE:
{    This procedure adds a logical line to the end of the list of logical lines
{    known to a remote system.

  PROCEDURE add_ntf_logical_line_entry
    (    logical_line_entry: nft$ntf_logical_line;
         last_logical_line: ^nft$ntf_logical_line;
         remote_system: ^nft$io_station;
     VAR logical_line: ^nft$ntf_logical_line);

    ALLOCATE logical_line;
    logical_line^ := logical_line_entry;
    IF last_logical_line <> NIL THEN
      logical_line^.back_link := last_logical_line;
      last_logical_line^.link := logical_line;
    ELSE
      remote_system^.ntf_logical_line_list := logical_line;
    IFEND;

  PROCEND add_ntf_logical_line_entry;
?? TITLE := 'add_ntf_remote_system_entry', EJECT ??

{  PURPOSE:
{    This procedure adds a remote system to the end of the list of remote
{    systems known to SCFS.

  PROCEDURE add_ntf_remote_system_entry
    (    remote_system_entry: nft$io_station;
         last_remote_system: ^nft$io_station;
     VAR remote_system: ^nft$io_station);

    ALLOCATE remote_system;
    remote_system^ := remote_system_entry;
    IF last_remote_system <> NIL THEN
      remote_system^.back_link := last_remote_system;
      last_remote_system^.link := remote_system;
    ELSE
      scfs_tables.first_ntf_remote_system := remote_system;
    IFEND;

  PROCEND add_ntf_remote_system_entry;
?? TITLE := 'add_ntf_remote_system_message', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from SCF/DI to
{    define a new NTF remote system under control of this SCFS/VE copy.  The
{    NTF remote system name is checked against all NTF remote system
{    definitions currently known to SCFS/VE.  If it is a new system name, the
{    definition is done.  If the system name already exists the definition is
{    accepted if the existing definition is found to be identical.  A response
{    is sent back to SCF/DI.

  PROCEDURE add_ntf_remote_system_message
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      acc_remote_system: ^nft$alias,
      alias_found: boolean,
      ios_alias: ^nft$alias,
      logical_line: ^nft$ntf_logical_line,
      logical_line_entry: nft$ntf_logical_line,
      logical_line_found: boolean,
      logical_line_match: boolean,
      logical_line_ptr: ^nft$pointer_list_entry,
      logical_line_ptr_entry: nft$pointer_list_entry,
      message_response: nft$ntf_add_rs_response_codes,
      remote_system: ^nft$io_station,
      remote_system_entry: nft$io_station,
      remote_system_found: boolean,
      remote_system_match: boolean;

*copy nft$ntf_add_remote_sys_msg
*copy nft$ntf_add_rs_response_codes
?? NEWTITLE := 'crack_add_remote_system_message', EJECT ??

    PROCEDURE crack_add_remote_system_message
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR remote_system_entry: nft$io_station;
       VAR logical_line_entry: nft$ntf_logical_line;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        authority_level: ^nft$ntf_authority_level,
        byte_array: ^nft$byte_array,
        inactivity_timer: ^nft$ntf_inactivity_timer,
        line_speed: ^nft$ntf_line_speed,
        logical_line_number: ^nft$ntf_logical_line_number,
        parameter: ^nft$ntf_add_remote_sys_msg,
        positive_acknowledge: ^nft$ntf_positive_acknowledge,
        protocol: ^nft$ntf_remote_system_protocol,
        remote_system_type: ^nft$ntf_remote_system_type,
        request_permission_retry: ^boolean,
        route_back_position: ^nft$ntf_route_back_position,
        value_length: integer,
        wait_a_bit: ^nft$ntf_wait_a_bit;

      status.normal := TRUE;
      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$ntf_remote_system_name =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, remote_system_entry.name);

        = nfc$ntf_protocol =
          NEXT protocol IN message;
          remote_system_entry.ntf_protocol := protocol^;

        = nfc$ntf_logical_line_number =
          NEXT logical_line_number IN message;
          logical_line_entry.logical_line_number := logical_line_number^;

        = nfc$ntf_line_speed =
          NEXT line_speed IN message;
          logical_line_entry.line_speed := line_speed^;

        = nfc$ntf_line_name =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, logical_line_entry.line_name);

        = nfc$ntf_authority_level =
          NEXT authority_level IN message;
          remote_system_entry.ntf_authority_level := authority_level^;

        = nfc$ntf_terminal_user_procedure =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, logical_line_entry.terminal_user_procedure);

        = nfc$ntf_wait_a_bit =
          NEXT wait_a_bit IN message;
          remote_system_entry.ntf_wait_a_bit := wait_a_bit^;

        = nfc$ntf_inactivity_timer =
          NEXT inactivity_timer IN message;
          remote_system_entry.ntf_inactivity_timer := inactivity_timer^;

        = nfc$ntf_positive_acknowledge =
          NEXT positive_acknowledge IN message;
          remote_system_entry.ntf_positive_acknowledge := positive_acknowledge^;

        = nfc$ntf_default_job_destination =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, remote_system_entry.ntf_default_job_destination);

        = nfc$ntf_default_file_destin =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, remote_system_entry.ntf_default_file_destination);

        = nfc$ntf_store_forward_destin =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, remote_system_entry.ntf_store_forward_destination);

        = nfc$ntf_remote_system_type =
          NEXT remote_system_type IN message;
          remote_system_entry.ntf_remote_system_type := remote_system_type^;

        = nfc$ntf_route_back_position =
          NEXT route_back_position IN message;
          remote_system_entry.ntf_route_back_position := route_back_position^;

        = nfc$ntf_request_perm_retry =
          NEXT request_permission_retry IN message;
          remote_system_entry.ntf_request_permission_retry := request_permission_retry^;

        = nfc$ntf_local_system_name =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, remote_system_entry.ntf_local_system_name);

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_add_remote_system_message;
?? TITLE := 'send_add_remote_system_response', EJECT ??

    PROCEDURE send_add_remote_system_response
      (VAR message: ^nft$message_sequence;
           response_code: nft$ntf_add_rs_response_codes;
           remote_system_name: ost$name;
           logical_line_number: nft$ntf_logical_line_number;
           connection: ^nft$connection;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        line_number: ^nft$ntf_logical_line_number,
        message_length: nft$message_length,
        message_type: ^nft$message_kind,
        parameter_kind: ^nft$ntf_add_remote_sys_resp,
        parameter_kind_size: nft$message_length,
        param_length_size: nft$message_length,
        parameter_value_length: integer,
        response_param: ^nft$ntf_add_rs_response_codes;

*copy nft$ntf_add_remote_sys_resp

      status.normal := TRUE;
      parameter_kind_size := #SIZE (nft$ntf_add_remote_sys_resp);
      RESET message;

      NEXT message_type IN message;
      message_type^ := nfc$add_ntf_remote_sys_resp;
      message_length := 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$ntf_remote_system_name;
      parameter_value_length := clp$trimmed_string_size (remote_system_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := remote_system_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$ntf_logical_line_number;
      parameter_value_length := #SIZE (nft$ntf_logical_line_number);
      parameter_kind^.length_indicated := TRUE;
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      NEXT line_number IN message;
      line_number^ := logical_line_number;
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$response_code;
      NEXT response_param IN message;
      response_param^ := response_code;
      message_length := message_length + parameter_kind_size + 1;

      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;

    PROCEND send_add_remote_system_response;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    initialize_ntf_remote_system ( remote_system_entry);
    initialize_ntf_logical_line ( logical_line_entry);
    logical_line_entry.scfdi_connection := connection;
    crack_add_remote_system_message (message, msg_length, remote_system_entry, logical_line_entry,
          status);
    message_response := nfc$message_accepted;

    find_io_station_alias (remote_system_entry.name, ios_alias, alias_found);
    IF NOT alias_found THEN
      find_ntf_acc_remote_system (remote_system_entry.name, acc_remote_system);
      IF acc_remote_system <> NIL THEN
        find_ntf_remote_system (remote_system_entry.name, remote_system, remote_system_found);
        IF remote_system_found THEN
          compare_ntf_remote_systems (remote_system_entry, remote_system^, remote_system_match);
          IF remote_system_match THEN
            find_ntf_logical_line (logical_line_entry.logical_line_number, remote_system,
                  logical_line, logical_line_found);
            IF logical_line_found THEN
              message_response := nfc$ntf_dup_logical_line_number;
            IFEND;
          ELSE
            message_response := nfc$ntf_dup_defs_do_not_match;
          IFEND;
        IFEND;

        IF (message_response = nfc$message_accepted) AND (acc_remote_system^.station_list <>
              NIL) AND ((remote_system_entry.ntf_remote_system_type <>
              acc_remote_system^.ntf_remote_system_type) OR (remote_system_entry.ntf_route_back_position <>
              acc_remote_system^.ntf_route_back_position)) THEN
          message_response := nfc$ntf_dup_defs_do_not_match;
        IFEND;

        IF (message_response = nfc$message_accepted) AND (NOT remote_system_found) THEN
          add_ntf_remote_system_entry (remote_system_entry, remote_system, remote_system);
          logical_line := NIL;
        IFEND;

        IF message_response = nfc$message_accepted THEN
          add_ntf_logical_line_entry (logical_line_entry, logical_line, remote_system,
                logical_line);
          add_ntf_acc_remote_system (acc_remote_system, remote_system, logical_line);
        IFEND;
      ELSE
        message_response := nfc$ntf_remote_sys_not_listed;
      IFEND;
    ELSE
      message_response := nfc$ntf_dup_defs_do_not_match;
    IFEND;

    send_add_remote_system_response (message, message_response, remote_system_entry.name,
          logical_line_entry.logical_line_number, connection, status);

  PROCEND add_ntf_remote_system_message;
?? TITLE := 'add_ntf_remote_system_pointer', EJECT ??

{  PURPOSE:
{    This procedure adds a remote system pointer to the end of the list of
{    remote system pointers known to an accessible remote system.

  PROCEDURE add_ntf_remote_system_pointer
    (    remote_system_ptr_entry: nft$pointer_list_entry;
         last_remote_system_ptr: ^nft$pointer_list_entry;
         acc_remote_system: ^nft$alias;
     VAR remote_system_ptr: ^nft$pointer_list_entry);

    ALLOCATE remote_system_ptr;
    remote_system_ptr^ := remote_system_ptr_entry;
    IF last_remote_system_ptr <> NIL THEN
      remote_system_ptr^.back_link := last_remote_system_ptr;
      last_remote_system_ptr^.link := remote_system_ptr;
    ELSE
      acc_remote_system^.station_list := remote_system_ptr;
    IFEND;

  PROCEND add_ntf_remote_system_pointer;
?? TITLE := 'add pointer list entry', EJECT ??

{  PURPOSE:
{    Allocate space for the specified type of pointer list entry
{    and initialize the various fields.

  PROCEDURE add_pointer_list_entry
    (VAR current_pointer: ^nft$pointer_list_entry;
         pointer_kind: nft$pointer_kind;
     VAR status: ost$status);

    VAR
      new_pointer_entry: ^nft$pointer_list_entry;

    ALLOCATE new_pointer_entry;

    IF current_pointer <> NIL THEN
      current_pointer^.link := new_pointer_entry;
      new_pointer_entry^.back_link := current_pointer;
    ELSE
      new_pointer_entry^.back_link := NIL;
    IFEND;

    current_pointer := new_pointer_entry;
    current_pointer^.link := NIL;
    current_pointer^.kind := pointer_kind;

    CASE current_pointer^.kind OF
    = nfc$queue =
      current_pointer^.queue := NIL;
    = nfc$io_station =
      current_pointer^.io_station := NIL;
    = nfc$batch_device =
      current_pointer^.batch_device := NIL;
    = nfc$connection =
      current_pointer^.connection := NIL;
    CASEND;

  PROCEND add_pointer_list_entry;
?? OLDTITLE ??
?? NEWTITLE := 'add_unreachable_btfs_di', EJECT ??

{  PURPOSE:
{    Add an entry to the SCF/VE's list of unreachable BTFS/DI's.  No new
{    entry is created if the BTFS/DI title is already in the list.

  PROCEDURE add_unreachable_btfs_di
    (    title: nft$btfs_di_title;
         connection: ^nft$connection;
     VAR wait_list: ^ost$i_wait_list);

    VAR
      clock: integer,
      current_pointer: ^unreachable_btfs_di,
      ignore_status: ost$status,
      next_pointer: ^unreachable_btfs_di;

    current_pointer := connection^.unreachable_btfs_di_list;
    next_pointer := current_pointer;

    WHILE next_pointer <> NIL DO
      current_pointer := next_pointer;
      next_pointer := current_pointer^.link;
      IF current_pointer^.title = title THEN
        RETURN;
      IFEND;
    WHILEND;

    ALLOCATE next_pointer;
    IF connection^.unreachable_btfs_di_list = NIL THEN
      connection^.unreachable_btfs_di_list := next_pointer;
    ELSE
      current_pointer^.link := next_pointer;
    IFEND;
    next_pointer^.title := title;
    pmp$get_microsecond_clock (clock, ignore_status);
    clock := clock DIV 1000;
    next_pointer^.timer := clock + unreachable_btfs_di_wait_time;
    next_pointer^.link := NIL;

    wait_list^ [2].milliseconds := unreachable_btfs_di_wait_time;

  PROCEND add_unreachable_btfs_di;
?? OLDTITLE ??
?? NEWTITLE := 'add user msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from OPES to
{    register a user as an I/O station operator.   If another operator is
{    currently assigned to the station, or if the request for station control
{    was not entered at the required operator device(if there is one), the
{    request is rejected.  A response is sent to OPES, and if the message
{    was accepted by SCFS, SCF/DI is informed that an operator has been
{    assigned to this I/O station.  (The message sent to SCF/DI is required to
{    activate the batch devices for I/O stations which have the "check io
{    station unique" attribute set to TRUE.)
{
{    This procedure is also executed when a request is received from OPENTF to
{    register a user as an NTF remote system operator.  If another operator is
{    currently assigned to the remote system, the request is rejected.  A
{    response is sent to OPENTF.

  PROCEDURE add_user_msg
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      bd_connection: ^nft$connection,
      connection_ptr: ^nft$pointer_list_entry,
      control_device: ost$name,
      device: ^nft$batch_device,
      io_station: ^nft$io_station,
      ios_connection: ^nft$connection,
      message_response: nft$add_user_responses,
      station_found: boolean,
      station_or_control_facility: ost$name,
      station_usage: nft$io_station_usage;

*copyc nft$add_user_msg
*copyc nft$add_user_responses
?? NEWTITLE := 'crack add user msg', EJECT ??

{  PURPOSE:
{    Determine the parameters and values sent by OPES in the add
{    user message.

    PROCEDURE crack_add_user_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
           connection: ^nft$connection;
       VAR station_or_control_facility: ost$name;
       VAR control_device: ost$name;
       VAR station_usage: nft$io_station_usage;
       VAR status: ost$status);

      VAR
        accept_messages: ^nft$accept_messages,
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        io_station_usage_param: ^nft$io_station_usage,
        parameter: ^nft$add_user_message_parameter,
        value_length: integer;

      connection^.accept_messages := TRUE;
      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$station_or_control_facility =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, station_or_control_facility);

        = nfc$control_device_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, control_device);

        = nfc$family_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, connection^.family);

        = nfc$user_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, connection^.user);

        = nfc$station_usage =
          NEXT io_station_usage_param IN message;
          station_usage := io_station_usage_param^;

        = nfc$accept_messages =
          NEXT accept_messages IN message;
          connection^.accept_messages := (accept_messages^ = nfc$do_accept_messages);

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_add_user_msg;
?? TITLE := 'find private dynamic station', EJECT ??

    PROCEDURE find_private_dynamic_station
      (    control_device: ost$name;
           station_usage: nft$io_station_usage;
       VAR io_station: ^nft$io_station;
       VAR station_found: boolean;
       VAR status: ost$status);

      io_station := scfs_tables.first_io_station;
      station_found := FALSE;

      WHILE NOT station_found AND (io_station <> NIL) DO
        station_found :=

        (io_station^.usage = nfc$private_io_station) AND

        io_station^.check_ios_unique AND

        (NOT io_station^.operator_assigned);

        IF (station_found) AND (io_station^.required_operator_device <> osc$null_name) THEN
          station_found := (control_device = io_station^.required_operator_device);
        IFEND;

        IF NOT station_found THEN
          io_station := io_station^.link;
        IFEND;
      WHILEND;

    PROCEND find_private_dynamic_station;
?? TITLE := 'move files from unknown q', EJECT ??

{  PURPOSE:
{    This procedure moves files from the unknown queue to the appropriate
{    station queue.  The unknown private operators queue houses all files
{    destined for a private station, but for which there is no operator
{    currently operating the station the file(s) are intended to print at.
{    When an operator gains control of a private station, the files that
{    he is allowed to control are added to the station queue for that station.

    PROCEDURE move_files_from_unknown_q
      (    operator_name: ost$name;
           operator_family: ost$name;
           io_station: ^nft$io_station);

      VAR
        alias_pt: ^nft$alias,
        next_q_file: ^nft$output_queue_file,
        q_file: ^nft$output_queue_file,
        q_pointer: ^^nft$output_queue_file;

?? NEWTITLE := 'move file to station q', EJECT ??

      PROCEDURE move_file_to_station_q
        (    q_file: ^nft$output_queue_file;
         VAR station_q: ^^nft$output_queue_file);

        VAR
          last_q_file: ^nft$output_queue_file;

        last_q_file := station_q^;
        IF last_q_file = NIL THEN
          station_q^ := q_file;
          q_file^.back_link := NIL;
        ELSE
          WHILE last_q_file^.link <> NIL DO
            last_q_file := last_q_file^.link;
          WHILEND;
          last_q_file^.link := q_file;
          q_file^.back_link := last_q_file;
        IFEND;

        q_file^.link := NIL;

      PROCEND move_file_to_station_q;
?? TITLE := 'remove file from unknown q', EJECT ??

      PROCEDURE remove_file_from_unknown_q
        (    q_file: ^nft$output_queue_file);

        VAR
          back_link_q_file: ^nft$output_queue_file,
          link_q_file: ^nft$output_queue_file;

        back_link_q_file := q_file^.back_link;
        link_q_file := q_file^.link;
        IF q_file = scfs_tables.unknown_private_operators_q THEN
          scfs_tables.unknown_private_operators_q := q_file^.link;
          IF q_file^.link <> NIL THEN
            link_q_file^.back_link := NIL;
          IFEND;
        ELSE
          back_link_q_file^.link := q_file^.link;
          IF q_file^.link <> NIL THEN
            link_q_file^.back_link := q_file^.back_link;
          IFEND;
        IFEND;

      PROCEND remove_file_from_unknown_q;
?? OLDTITLE, EJECT ??

      q_file := scfs_tables.unknown_private_operators_q;
      q_pointer := NIL;
      WHILE q_file <> NIL DO
        next_q_file := q_file^.link;
        IF (q_file^.operator_name = operator_name) AND (q_file^.operator_family = operator_family) THEN
          remove_file_from_unknown_q (q_file);
          alias_pt := io_station^.alias_list [0];
          q_pointer := ^alias_pt^.queue;
          move_file_to_station_q (q_file, q_pointer);
        IFEND;
        q_file := next_q_file;
      WHILEND;

    PROCEND move_files_from_unknown_q;
?? TITLE := 'send add user response', EJECT ??

{  PURPOSE:
{    Build and send a message to OPES indicating SCFS's response
{    to an add user message.  The add user mssage indicated a
{    user wishes to gain control of a station.

    PROCEDURE send_add_user_response
      (VAR message: ^nft$message_sequence;
           response_code: nft$add_user_responses;
           station_or_control_facility: ost$name;
           connection: ^nft$connection;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        message_length: nft$message_length,
        message_type: ^nft$message_kind,
        parameter_kind: ^nft$add_user_resp_msg_parameter,
        parameter_kind_size: nft$message_length,
        param_length_size: nft$message_length,
        parameter_value_length: integer,
        response_param: ^nft$add_user_responses;

*copyc nft$add_user_resp_msg

      parameter_kind_size := #SIZE (nft$add_user_resp_msg_parameter);
      RESET message;

      NEXT message_type IN message;
      message_type^ := nfc$add_user_resp;
      message_length := 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$station_or_control_facility;
      parameter_value_length := clp$trimmed_string_size (station_or_control_facility);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := station_or_control_facility (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$response_code;
      NEXT response_param IN message;
      response_param^ := response_code;
      message_length := message_length + parameter_kind_size + 1;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$null_parameter;
      message_length := message_length + parameter_kind_size;

      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;

    PROCEND send_add_user_response;
?? OLDTITLE, EJECT ??

    IF connection^.kind <> nfc$ntf_operator_connection THEN
      connection^.kind := nfc$operator_connection;
    IFEND;

    message_response := nfc$message_accepted;

    crack_add_user_msg (message, msg_length, connection, station_or_control_facility,
          control_device, station_usage, status);

{  Station name specified - PUBLIC station or FIXED-PRIVATE station }
    IF (station_or_control_facility <> control_facility_name) OR (connection^.kind =
          nfc$ntf_operator_connection) THEN
      find_io_station_or_remote_sys (station_or_control_facility, connection, io_station,
            station_found);
      IF NOT station_found THEN
        message_response := nfc$no_io_station_found;
      IFEND;
{  Control facility name specified - DYNAMIC-PRIVATE station }
    ELSE
      find_private_dynamic_station (control_device, station_usage, io_station, station_found,
            status);
      IF NOT station_found THEN
        message_response := nfc$no_io_station_found;
      IFEND;
    IFEND;

    IF station_found AND io_station^.operator_assigned THEN
      message_response := nfc$operator_already_assigned;
    ELSEIF station_found AND (io_station^.required_operator_device <> osc$null_name) AND (io_station^.
          required_operator_device <> control_device) THEN
      message_response := nfc$operator_device_mismatch;
    IFEND;

    IF message_response = nfc$message_accepted THEN
      station_or_control_facility  := io_station^.name;
      connection^.operating_station := io_station;
      io_station^.connected_operator := connection;
      io_station^.operator_assigned := TRUE;
      io_station^.station_operational := TRUE;
      IF io_station^.usage = nfc$private_io_station THEN
        move_files_from_unknown_q (connection^.user, connection^.family, io_station);
      IFEND;

      IF io_station^.usage <> nfc$ntf_remote_system THEN
        connection_ptr := io_station^.scfdi_connection_pointers;
        WHILE connection_ptr <> NIL DO
          ios_connection := connection_ptr^.connection;
          send_start_io_station_msg (message, io_station^.name, connection^.user, connection^.family,
                ios_connection, status);
          connection_ptr := connection_ptr^.link;
        WHILEND;
      IFEND;

      IF io_station^.batch_device_list <> NIL THEN
        device := io_station^.batch_device_list;
        WHILE device <> NIL DO
          IF device_available_for_output (device) THEN
            find_file_for_device (device, message, status);
          IFEND;
          device := device^.link;
        WHILEND;
      IFEND;
    IFEND;

    send_add_user_response (message, message_response, station_or_control_facility, connection, status);

  PROCEND add_user_msg;
?? TITLE := 'any outstanding di responses', EJECT ??

{  Determine if the DI has not responded to commands that were sent
{  by SCFS.  If there are responses outstanding, set result to TRUE.

  FUNCTION any_outstanding_di_responses (di_responses: nft$outstanding_di_responses): boolean;

    any_outstanding_di_responses := (di_responses [nfc$start_bd] + di_responses [nfc$stop_bd] + di_responses
          [nfc$change_bd_attr] + di_responses [nfc$suppress_cc] + di_responses [nfc$terminate_xfer] +
          di_responses [nfc$position_file]) > 0;

  FUNCEND any_outstanding_di_responses;
?? TITLE := 'broadcast_ntf_message', EJECT ??

{  PURPOSE:
{    This procedure will send a message to every NTF operator or user known by
{    SCFS with the specified family name, user name, and/or operator identifier.
{    If the family name is null, SCFS will not check the family name of the
{    operator.  If the user name is null, SCFS will not check the user name of
{    the operator.  If the operator identifier is null, SCFS will not check the
{    operator identifier of the operator.

  PROCEDURE broadcast_ntf_message
    (    message_area: ^nft$message_sequence;
         length: nft$message_length;
         family_name: ost$name;
         user_name: ost$name;
         operator_identifier: nft$ntf_system_identifier;
     VAR messages_sent: boolean;
     VAR status: ost$status);

    VAR
      connection: ^nft$connection,
      message: ^nft$message_sequence;

    status.normal := TRUE;
    messages_sent := FALSE;
    connection := scfs_tables.first_ntf_operator;
    WHILE connection <> NIL DO
      IF ((user_name = osc$null_name) OR (user_name = connection^.user)) AND ((family_name = osc$null_name)
            OR (family_name = connection^.family)) AND ((operator_identifier =
            nfc$ntf_blank_system_identifier) OR (operator_identifier = connection^.ntf_operator_identifier))
            AND connection^.accept_messages THEN
        nfp$send_message_on_connection (message_area, length, connection^.id, status);
        IF scfs_event_logging THEN
          message := message_area;
          log_connection_message (connection^, length, message);
        IFEND;

        messages_sent := TRUE;
      IFEND;

      connection := connection^.next_ntf_operator;
    WHILEND;

  PROCEND broadcast_ntf_message;
?? TITLE := 'calculate priority', EJECT ??

  FUNCTION calculate_priority (q_file: ^nft$output_queue_file;
        current_time: ost$date_time): nft$priority;

    VAR
      priority: nft$priority;

{     Q File priority is the current time minus the q file time stamp (in seconds) times the
{         priority multiplier added to the initial priority.

    priority := time_in_scfs_queue (q_file^.time_stamp, current_time) * q_file^.priority_factor + q_file^.
          initial_priority;

    calculate_priority := priority;
    IF priority > q_file^.maximum_priority THEN
      calculate_priority := q_file^.maximum_priority;
    ELSEIF priority < 0 THEN
      calculate_priority := q_file^.initial_priority;
    IFEND;

  FUNCEND calculate_priority;
?? TITLE := 'change batch device attr resp', EJECT ??

{  PURPOSE:
{    This procedure is executed when a response to a change batch device
{    attributes operator command is received from SCF/DI.  SCFS tables are
{    updated accordingly and if the station operator is still assigned,
{    a response is forwarded to OPES.
{
{    This procedure is also executed when a response to a change batch stream
{    attributes operator command is received from SCF/DI.  SCFS tables are
{    updated accordingly and if the NTF remote system operator is still
{    assigned, a response is forwarded to OPENTF.

  PROCEDURE change_batch_device_attr_resp
      (VAR message: ^nft$message_sequence;
        message_length: integer;
        connection: ^nft$connection;
    VAR msg_length: integer;
    VAR status: ost$status);

    VAR
      alias_index: 1 .. 3,
      ascii_string: ^string ( * <= osc$max_name_size),
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      old_bd: nft$batch_device,
      operator_connection: ^nft$connection,
      response_code: nft$device_control_resp_codes;

*copyc nft$change_bd_attr_resp_msg
?? NEWTITLE := 'change batch device attrs', EJECT ??

{  PURPOSE:
{    This procedure updates the batch device attributes that were
{    just changed by an operator command.

    PROCEDURE change_batch_device_attrs
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR batch_device: nft$batch_device;
       VAR status: ost$status);

      CONST
        null_string = ' ';

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        banner_page_count: ^nft$banner_page_count,
        banner_highlight_field: ^nft$banner_highlight_field,
        boolean_parameter: ^boolean,
        carriage_control_action: ^nft$carriage_control_action,
        code_set: ^nft$code_set,
        empty_string: ost$name,
        file_ack: ^boolean,
        forms_size: ^nft$forms_size,
        maximum_file_size: ^nft$device_file_size,
        ntf_skip_punch_count: ^nft$ntf_skip_punch_count,
        page_length: ^nft$page_length,
        page_width: ^nft$page_width,
        parameter: ^nft$change_bd_attr_resp_param,
        transmission_block_size: ^nft$transmit_block_size,
        undefined_fe_action: ^nft$format_effector_actions,
        unsupported_fe_action: ^nft$format_effector_actions,
        value_length: integer,
        vertical_print_density: ^nft$vertical_print_density;

      status.normal := TRUE;
      empty_string := osc$null_name;
      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
          IF value_length = 0 THEN
            ascii_string := ^empty_string;
          IFEND;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$device_alias_1 =
          IF value_length <> 0 THEN
            NEXT ascii_string: [value_length] IN message;
            #translate (osv$lower_to_upper, ascii_string^, batch_device.alias_names [1]);
          ELSE
            batch_device.alias_names [1] := null_string;
          IFEND;

        = nfc$device_alias_2 =
          IF value_length <> 0 THEN
            NEXT ascii_string: [value_length] IN message;
            #translate (osv$lower_to_upper, ascii_string^, batch_device.alias_names [2]);
          ELSE
            batch_device.alias_names [2] := null_string;
          IFEND;

        = nfc$device_alias_3 =
          IF value_length <> 0 THEN
            NEXT ascii_string: [value_length] IN message;
            #translate (osv$lower_to_upper, ascii_string^, batch_device.alias_names [3]);
          ELSE
            batch_device.alias_names [3] := null_string;
          IFEND;

        = nfc$file_acknowledgement =
          NEXT file_ack IN message;
          batch_device.file_acknowledgement := file_ack^;

        = nfc$terminal_model =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, batch_device.terminal_model);

        = nfc$transmission_block_size =
          NEXT transmission_block_size IN message;
          batch_device.transmission_block_size := transmission_block_size^;

        = nfc$maximum_file_size =
          NEXT maximum_file_size IN message;
          batch_device.maximum_file_size := maximum_file_size^;

        = nfc$page_width =
          NEXT page_width IN message;
          batch_device.page_width := page_width^;

        = nfc$page_length =
          NEXT page_length IN message;
          batch_device.page_length := page_length^;

        = nfc$banner_page_count =
          NEXT banner_page_count IN message;
          batch_device.banner_page_count := banner_page_count^;

        = nfc$banner_highlight_field =
          NEXT banner_highlight_field IN message;
          batch_device.banner_highlight_field := banner_highlight_field^;

        = nfc$carriage_control_action =
          NEXT carriage_control_action IN message;
          batch_device.carriage_control_action := carriage_control_action^;

        = nfc$forms_code_1 =
          IF value_length <> 0 THEN
            NEXT ascii_string: [value_length] IN message;
            #translate (osv$lower_to_upper, ascii_string^, batch_device.forms_code [1]);
          ELSE
            batch_device.forms_code [1] := null_string;
          IFEND;

        = nfc$forms_code_2 =
          IF value_length <> 0 THEN
            NEXT ascii_string: [value_length] IN message;
            #translate (osv$lower_to_upper, ascii_string^, batch_device.forms_code [2]);
          ELSE
            batch_device.forms_code [2] := null_string;
          IFEND;

        = nfc$forms_code_3 =
          IF value_length <> 0 THEN
            NEXT ascii_string: [value_length] IN message;
            #translate (osv$lower_to_upper, ascii_string^, batch_device.forms_code [3]);
          ELSE
            batch_device.forms_code [3] := null_string;
          IFEND;

        = nfc$forms_code_4 =
          IF value_length <> 0 THEN
            NEXT ascii_string: [value_length] IN message;
            #translate (osv$lower_to_upper, ascii_string^, batch_device.forms_code [4]);
          ELSE
            batch_device.forms_code [4] := null_string;
          IFEND;

        = nfc$external_characteristics_1 =
          IF value_length <> 0 THEN
            NEXT ascii_string: [value_length] IN message;
            #translate (osv$lower_to_upper, ascii_string^, batch_device.external_characteristics [1]);
          ELSE
            batch_device.external_characteristics [1] := null_string;
          IFEND;

        = nfc$external_characteristics_2 =
          IF value_length <> 0 THEN
            NEXT ascii_string: [value_length] IN message;
            #translate (osv$lower_to_upper, ascii_string^, batch_device.external_characteristics [2]);
          ELSE
            batch_device.external_characteristics [2] := null_string;
          IFEND;

        = nfc$external_characteristics_3 =
          IF value_length <> 0 THEN
            NEXT ascii_string: [value_length] IN message;
            #translate (osv$lower_to_upper, ascii_string^, batch_device.external_characteristics [3]);
          ELSE
            batch_device.external_characteristics [3] := null_string;
          IFEND;

        = nfc$external_characteristics_4 =
          IF value_length <> 0 THEN
            NEXT ascii_string: [value_length] IN message;
            #translate (osv$lower_to_upper, ascii_string^, batch_device.external_characteristics [4]);
          ELSE
            batch_device.external_characteristics [4] := null_string;
          IFEND;

        = nfc$code_set =
          NEXT code_set IN message;
          batch_device.code_set := code_set^;

        = nfc$vertical_print_density =
          NEXT vertical_print_density IN message;
          batch_device.vertical_print_density := vertical_print_density^;

        = nfc$vfu_load_procedure =
          IF value_length <> 0 THEN
            NEXT ascii_string: [value_length] IN message;
            #translate (osv$lower_to_upper, ascii_string^, batch_device.vfu_load_procedure);
          ELSE
            batch_device.vfu_load_procedure := null_string;
          IFEND;

        = nfc$forms_size =
          NEXT forms_size IN message;
          batch_device.forms_size := forms_size^;

        = nfc$undefined_fe_action =
          NEXT undefined_fe_action IN message;
          batch_device.undefined_fe_action := undefined_fe_action^;

        = nfc$unsupported_fe_action =
          NEXT unsupported_fe_action IN message;
          batch_device.unsupported_fe_action := unsupported_fe_action^;

        = nfc$ntf_skip_punch_count =
          NEXT ntf_skip_punch_count IN message;
          batch_device.ntf_skip_punch_count := ntf_skip_punch_count^;

        = nfc$invalid_chg_request =
          osp$set_status_abnormal ('NF', nfe$invalid_chg_requ_by_oper, '', status);
          RETURN;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND change_batch_device_attrs;
?? OLDTITLE, EJECT ??

    crack_device_control_resp (message, msg_length, io_station_name, device_name, response_code, status);

    find_io_station_or_remote_sys (io_station_name, connection, io_station, io_station_found);
    IF io_station_found THEN
      find_batch_device (device_name, io_station, device, device_found);
      IF device_found THEN
        change_batch_device_attrs (message, msg_length, device^, status);
        IF status.normal AND (response_code = nfc$dc_msg_accepted) THEN
          old_bd := device^;
        IFEND;

        device^.outstanding_di_responses [nfc$change_bd_attr] := device^.outstanding_di_responses
              [nfc$change_bd_attr] - 1;

        IF io_station^.operator_assigned THEN
          operator_connection := io_station^.connected_operator;
          nfp$send_message_on_connection (message, message_length, operator_connection^.id, status);
          IF scfs_event_logging THEN
            log_connection_message (operator_connection^, message_length, message);
          IFEND;
        IFEND;

        IF device_available_for_output (device) THEN
          find_file_for_device (device, message, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND change_batch_device_attr_resp;
?? TITLE := 'change batch device attributes', EJECT ??

{  PURPOSE:
{    This procedure is executed when a change batch device attributes
{    operator command is received from OPES.  SCFS forwards the change
{    request to SCF/DI if the station and the device for which the request
{    was made are known, otherwise a negative response is sent to OPES.
{
{    This procedure is also executed when a change batch stream attributes
{    operator command is received from OPENTF.  SCFS forwards the change
{    request to SCF/DI if the NTF remote system and the stream for which the
{    request was made are known, otherwise a negative response is sent to
{    OPENTF.

  PROCEDURE change_batch_device_attributes
    (VAR message: ^nft$message_sequence;
         message_length: integer;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      changed_device_attrs: nft$batch_device,
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      di_connection: ^nft$connection,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      new_device_attributes: nft$batch_device,
      response: nft$device_control_resp_codes;

*copyc nft$change_bd_attributes_msg
?? NEWTITLE := 'get required parameters', EJECT ??

{  PURPOSE:
{    This procedure determines the values for the required parameters
{    on a change batch device attributes command.  The required parameters
{    identify which device on which station should be changed.

    PROCEDURE get_required_parameters
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR station_name: ost$name;
       VAR device_name: ost$name;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        parameter: ^nft$change_bd_attr_parameter,
        value_length: integer;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <= nfc$device_name) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, station_name);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, device_name);
        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

      RESET message TO parameter;

    PROCEND get_required_parameters;
?? OLDTITLE, EJECT ??

    get_required_parameters (message, msg_length, io_station_name, device_name, status);

    find_io_station_or_remote_sys (io_station_name, connection, io_station, io_station_found);
    IF NOT io_station_found THEN
      response := nfc$dc_msg_reject_unknown_ios;
    ELSE
      find_batch_device (device_name, io_station, device, device_found);
      IF NOT device_found THEN
        response := nfc$dc_msg_reject_unknown_dev;
      ELSE
        response := nfc$dc_msg_accepted;
        di_connection := device^.scfdi_connection;
        device^.outstanding_di_responses [nfc$change_bd_attr] := device^.outstanding_di_responses
              [nfc$change_bd_attr] + 1;
        nfp$send_message_on_connection (message, message_length, di_connection^.id, status);
        IF scfs_event_logging THEN
          log_connection_message (di_connection^, message_length, message);
        IFEND;
      IFEND;
    IFEND;

    IF response <> nfc$dc_msg_accepted THEN
      send_device_control_response (message, nfc$change_bat_device_attr_resp, io_station_name, device_name,
            response, connection, status);
    IFEND;

  PROCEND change_batch_device_attributes;
?? TITLE := 'change batch device status', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from SCF/DI informing
{    SCFS that the status of a device has changed.  SCFS tables are updated
{    accordingly.
{
{    This procedure is also executed when a request is received from SCF/DI
{    informing SCFS that the status of an NTF batch stream has changed.  SCFS
{    tables are updated accordingly.

  PROCEDURE change_batch_device_status
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      device_status: ^nft$device_status,
      file_transfer_status: ^nft$file_transfer_status,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      ntf_logical_line: ^nft$ntf_logical_line,
      ntf_logical_line_found: boolean;

*copy nft$batch_device_status_message

?? NEWTITLE := 'get required parameters', EJECT ??

{  PURPOSE:
{    This procedure gets the required parameters and their values
{    for a batch device status command sent by SCF/DI.

    PROCEDURE get_required_parameters
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR station_name: ost$name;
       VAR device_name: ost$name;
       VAR device_status: ^nft$device_status;
       VAR file_transfer_status: ^nft$file_transfer_status;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        parameter: ^nft$bd_status_message_parameter,
        value_length: integer;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, station_name);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, device_name);

        = nfc$device_status =
          NEXT device_status IN message;

        = nfc$file_transfer_status_param =
          NEXT file_transfer_status IN message;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND get_required_parameters;
?? OLDTITLE, EJECT ??

    get_required_parameters (message, msg_length, io_station_name, device_name, device_status,
          file_transfer_status, status);

    find_io_station_or_remote_sys (io_station_name, connection, io_station, io_station_found);
    IF io_station_found THEN
      find_batch_device (device_name, io_station, device, device_found);
      IF device_found THEN
        device^.device_status := device_status^;
        device^.file_transfer_status := file_transfer_status^;
        IF (io_station^.usage = nfc$ntf_remote_system) AND (device^.device_type = nfc$console) THEN
           find_ntf_logical_line (device^.ntf_logical_line_number, io_station, ntf_logical_line,
                 ntf_logical_line_found);
           ntf_logical_line^.signon_status := device_status^;
           ntf_logical_line^.console_stream_name := device^.name;
           IF ntf_logical_line^.signon_status = nfc$ntf_signed_on THEN
             find_files_for_ntf_logical_line (io_station, ntf_logical_line^.logical_line_number,
                   message, status);
           IFEND;

           send_ntf_signon_status_message (ntf_signon_statuses [ntf_logical_line^.signon_status], io_station,
                 ntf_logical_line, status);
        IFEND;

        IF device_available_for_output (device) THEN
          device^.current_file := NIL;
          find_file_for_device (device, message, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND change_batch_device_status;
?? TITLE := 'change_btf_ve_status', EJECT ??

{  PURPOSE:
{    This procedure is executed when a message is received from SCF/VE
{    informing SCFS of the status of BTF/VE.  This status indicates the
{    protocol stack(s) supported by BTF/VE.

  PROCEDURE change_btf_ve_status
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      btf_ve_protocol_stacks_integer: ^nat$protocol_stack_integer,
      byte_array: ^nft$byte_array,
      parameter: ^nft$btf_ve_status_parameter,
      value_length: integer;

*copy nft$btf_ve_status_message

    NEXT parameter IN message;

    WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND
          (msg_length > 0) DO
      msg_length := msg_length - 1;
      IF parameter^.length_indicated THEN
        nfp$get_parameter_value_length (message, msg_length, value_length,
              status);
        msg_length := msg_length - value_length;
      ELSE
        value_length := 1;
        msg_length := msg_length - 1;
      IFEND;

      IF parameter^.param = nfc$btf_ve_protocol_stacks THEN
        NEXT btf_ve_protocol_stacks_integer IN message;
      ELSE
{ ERROR ----   Ignore parameter value.
        NEXT byte_array: [1 .. value_length] IN message;
      IFEND;
      NEXT parameter IN message;
    WHILEND;

    IF (connection^.kind = nfc$scfve_connection) OR
          (connection^.kind = nfc$ntfve_connection) THEN
      connection^.btf_ve_status_received := TRUE;
      connection^.btf_ve_protocol_stacks := $protocol_stacks_set [];

{ Convert integer received from SCF/DI to set type:
{ - First check for XNS bit set

      IF (((btf_ve_protocol_stacks_integer^ DIV nac$xns_protocol_stack) DIV 2) * 2) <>
            (btf_ve_protocol_stacks_integer^ DIV nac$xns_protocol_stack) THEN
        connection^.btf_ve_protocol_stacks := connection^.btf_ve_protocol_stacks +
              $protocol_stacks_set [xns_protocol_stack];
      IFEND;

{ - Next check for OSI bit set

      IF (((btf_ve_protocol_stacks_integer^ DIV nac$osi_protocol_stack) DIV 2) * 2) <>
            (btf_ve_protocol_stacks_integer^ DIV nac$osi_protocol_stack) THEN
        connection^.btf_ve_protocol_stacks := connection^.btf_ve_protocol_stacks +
              $protocol_stacks_set [osi_protocol_stack];
      IFEND;
    IFEND;

  PROCEND change_btf_ve_status;
?? TITLE := 'change btfs di status', EJECT ??

{  PURPOSE:
{    This procedure is executed when a message is received from SCF/DI informing
{    SCFS that BTFS/DI service is available and the network address or title used
{    to access that service.  This message is usually sent after a new connection
{    is established between SCFS and SCF/DI.  This status message may also be
{    used to inform SCFS that the service has failed.

  PROCEDURE change_btfs_di_status
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      btfs_di_advanced_features: ^nft$btfs_di_advanced_features,
      btfs_di_network_address: ^nft$network_address,
      btfs_di_status_code: ^nft$btfs_di_status_codes,
      btfs_di_title: ^nft$btfs_di_title,
      btfs_di_title_string: ^nat$title_pattern,
      byte_array: ^nft$byte_array,
      parameter: ^nft$btfs_di_status_parameter,
      value_length: integer;

*copy nft$btfs_di_status_message

?? NEWTITLE := 'update_devices_btfs_di_statuses', EJECT ??

    PROCEDURE update_devices_btfs_di_statuses
      (    first_io_station: ^nft$io_station;
           connection: ^nft$connection;
           btfs_di_network_address: ^nft$network_address,
           btfs_di_status_code: ^nft$btfs_di_status_codes,
           btfs_di_title: ^nft$btfs_di_title;
           btfs_di_protocol_stacks: protocol_stacks_set);

      VAR
        device: ^nft$batch_device,
        io_station: ^nft$io_station;

      io_station := first_io_station;
      WHILE io_station <> NIL DO
        device := io_station^.batch_device_list;
        WHILE device <> NIL DO
          IF device^.scfdi_connection = connection THEN
            device^.btfs_di_status := btfs_di_status_code^;
            IF btfs_di_network_address <> NIL THEN
              device^.btfs_di_address := btfs_di_network_address^;
            IFEND;
            IF btfs_di_title <> NIL THEN
              device^.btfs_di_title := btfs_di_title^;
            IFEND;
            device^.btfs_di_protocol_stacks := btfs_di_protocol_stacks;
          IFEND;
          device := device^.link;
        WHILEND;
        io_station := io_station^.link;
      WHILEND;

    PROCEND update_devices_btfs_di_statuses;
?? OLDTITLE, EJECT ??

    btfs_di_advanced_features := NIL;
    btfs_di_network_address := NIL;
    btfs_di_title := NIL;
    NEXT parameter IN message;

    WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
      msg_length := msg_length - 1;
      IF parameter^.length_indicated THEN
        nfp$get_parameter_value_length (message, msg_length, value_length, status);
        msg_length := msg_length - value_length;
      ELSE
        value_length := 1;
        msg_length := msg_length - 1;
      IFEND;

      CASE parameter^.param OF
      = nfc$btfs_di_network_address =
        NEXT btfs_di_network_address IN message;

      = nfc$btfs_status_code =
        NEXT btfs_di_status_code IN message;

      = nfc$btfs_di_title =
        NEXT btfs_di_title_string: [value_length] IN message;
        PUSH btfs_di_title;
        btfs_di_title^.length := value_length;
        btfs_di_title^.title := btfs_di_title_string^;

      = nfc$btfs_di_advanced_features =
        NEXT btfs_di_advanced_features IN message;

      ELSE
{ ERROR ----   Ignore parameter value.
        NEXT byte_array: [1 .. value_length] IN message;
      CASEND;
      NEXT parameter IN message;
    WHILEND;

    IF connection^.kind = nfc$scfdi_connection THEN
      connection^.btfs_di_protocol_stacks := $protocol_stacks_set [];
      connection^.btfs_di_status := btfs_di_status_code^;
      IF btfs_di_network_address <> NIL THEN
        connection^.btfs_di_address := btfs_di_network_address^;
        connection^.btfs_di_protocol_stacks := connection^.btfs_di_protocol_stacks +
                  $protocol_stacks_set [xns_protocol_stack];
      IFEND;
      IF btfs_di_title <> NIL THEN
        connection^.btfs_di_title := btfs_di_title^;
        connection^.btfs_di_protocol_stacks := connection^.btfs_di_protocol_stacks +
                  $protocol_stacks_set [osi_protocol_stack];
      IFEND;
      IF btfs_di_advanced_features <> NIL THEN
        connection^.btfs_di_advanced_features := btfs_di_advanced_features^;
      IFEND;
      update_devices_btfs_di_statuses (scfs_tables.first_io_station, connection,
            btfs_di_network_address, btfs_di_status_code, btfs_di_title,
                  connection^.btfs_di_protocol_stacks);
      update_devices_btfs_di_statuses (scfs_tables.first_ntf_remote_system,
            connection, btfs_di_network_address, btfs_di_status_code, btfs_di_title,
                  connection^.btfs_di_protocol_stacks);
    IFEND;

  PROCEND change_btfs_di_status;
?? TITLE := 'change file transfer status', EJECT ??

{  PURPOSE:
{    This procedure is executed when a message is received from SCF/DI informing
{    SCFS that the "file transfer status" has changed (e.g. start or end of a
{    file transfer) for a particular device.  If file acknowledgement is turned
{    on for the station or device, and a file status message is received
{    indicating an output file started, an output file completed or an input
{    job completed, SCFS sends a message to the station operator (if one is
{    currently assigned).
{
{    This procedure is also executed when a message is received from SCF/DI
{    informing SCFS that the "file transfer status" has changed (e.g.  start or
{    end of a file transfer) for a particular NTF batch stream.

  PROCEDURE change_file_transfer_status
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      actual_destination: ost$name,
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      device_status: ^nft$device_status,
      bytes_transferred: integer,
      file_status_transition: file_status_transition_kind,
      file_position: nft$file_position,
      file_transfer_status: ^nft$file_transfer_status,
      ignore_status: ost$status,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      job_file_name: ost$name,
      old_file_xfer_status: nft$file_transfer_status,
      operator_connection: ^nft$connection,
      q_file: ^nft$output_queue_file,
      requested_destination: ost$name,
      system_family: ost$name,
      system_file_name: ost$name,
      system_job_name: ost$name,
      user_file_name: ost$name,
      user_job_name: ost$name,
      user_name: ost$name;

*copy nft$file_status_message

?? NEWTITLE := 'get input parameters', EJECT ??

{  PURPOSE:
{    Get the parameters and values sent by SCF/DI if the file
{    transfer status changed on an input device.

    PROCEDURE get_input_parameters
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR actual_destination: ost$name;
       VAR user_job_name: ost$name;
       VAR requested_destination: ost$name;
       VAR system_job_name: ost$name;
       VAR bytes_transferred: integer;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        bytes: ^nft$input_job_size,
        parameter: ^nft$file_status_message_param,
        value_length: integer;

      actual_destination := osc$null_name;
      user_job_name := osc$null_name;
      requested_destination := osc$null_name;
      system_job_name := osc$null_name;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$system_job_file_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, system_job_name);

        = nfc$user_job_file_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, user_job_name);

        = nfc$actual_destination =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, actual_destination);

        = nfc$requested_destination =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, requested_destination);

        = nfc$input_bytes_transferred =
          NEXT bytes IN message;
          bytes_transferred := bytes^;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;
        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND get_input_parameters;
?? TITLE := 'get required output parameters', EJECT ??

{  PURPOSE:
{    Get the parameters and values sent by SCF/DI if the file
{    transfer status changed on an output device.

    PROCEDURE get_required_output_parameters
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR system_file_name: ost$name;
       VAR system_family: ost$name;
       VAR user_file_name: ost$name;
       VAR file_position: nft$file_position;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        parameter: ^nft$file_status_message_param,
        percent_complete: ^nft$file_position,
        value_length: integer;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$system_job_file_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, system_file_name);

        = nfc$system_id_family =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, system_family);

        = nfc$user_job_file_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, user_file_name);

        = nfc$file_position =
          NEXT percent_complete IN message;
          file_position := percent_complete^;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND get_required_output_parameters;
?? TITLE := 'get required parameters', EJECT ??

{  PURPOSE:
{    Get the parameters and values sent by SCF/DI if the file
{    transfer status changed on either type of device, input
{    or output.

    PROCEDURE get_required_parameters
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR station_name: ost$name;
       VAR device_name: ost$name;
       VAR device_status: ^nft$device_status;
       VAR file_transfer_status: ^nft$file_transfer_status;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        parameter: ^nft$file_status_message_param,
        value_length: integer;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <= nfc$file_transfer_status_param) AND (msg_length > 0)
            DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, station_name);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, device_name);

        = nfc$device_status =
          NEXT device_status IN message;

        = nfc$file_transfer_status_param =
          NEXT file_transfer_status IN message;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

      RESET message TO parameter;

    PROCEND get_required_parameters;
?? OLDTITLE, EJECT ??

    bytes_transferred := 0;
    job_file_name := osc$null_name;
    user_name := osc$null_name;

    get_required_parameters (message, msg_length, io_station_name, device_name, device_status,
          file_transfer_status, status);

    find_io_station_or_remote_sys (io_station_name, connection, io_station, io_station_found);
    IF io_station_found THEN
      find_batch_device (device_name, io_station, device, device_found);
      IF device_found THEN
        device^.device_status := device_status^;
        old_file_xfer_status := device^.file_transfer_status;
        device^.file_transfer_status := file_transfer_status^;

        q_file := device^.current_file;
{       Modify file status
        IF output_device_or_stream (device) THEN
          IF msg_length > 0 THEN
            get_required_output_parameters (message, msg_length, system_file_name, system_family,
                  user_file_name, file_position, status);
            IF q_file <> NIL THEN
              q_file^.percent_complete := file_position;
            IFEND;
          IFEND;
        ELSEIF input_device_or_stream (device) THEN
          IF msg_length > 0 THEN
            get_input_parameters (message, msg_length, actual_destination, user_job_name,
                  requested_destination, system_job_name, bytes_transferred, status);
            device^.input_job.input_bytes_transferred := bytes_transferred;
          IFEND;
        IFEND;

        file_status_transition := no_transition;
        IF (old_file_xfer_status >= nfc$busy) AND (device^.file_transfer_status < nfc$busy) THEN
          file_status_transition := file_transfer_completed;
        ELSEIF (old_file_xfer_status < nfc$busy) AND (device^.file_transfer_status = nfc$busy) THEN
          file_status_transition := file_transfer_begun;
        IFEND;

{  Update the file transfer status information.

        IF (file_status_transition <> no_transition) THEN

          IF output_device_or_stream (device) THEN
            IF q_file <> NIL THEN
              job_file_name := q_file^.user_file_name;
              user_name := q_file^.user_name;
              IF (file_status_transition = file_transfer_begun) OR
                    (file_status_transition = file_transfer_completed) THEN
                bytes_transferred := q_file^.file_size;
              ELSE
                bytes_transferred := 0;
              IFEND;
            IFEND;
          ELSEIF input_device_or_stream (device) THEN

{  An input job has started.  Obtain the job information.

            IF (file_status_transition = file_transfer_begun) THEN
              IF user_job_name <> osc$null_name THEN
                device^.input_job.user_job_name := user_job_name;
              IFEND;
              IF system_job_name <> osc$null_name THEN
                device^.input_job.system_job_name := system_job_name;
              IFEND;
              IF requested_destination <> osc$null_name THEN
                device^.input_job.requested_destination := requested_destination;
              IFEND;
              IF actual_destination <> osc$null_name THEN
                device^.input_job.actual_destination := actual_destination;
              IFEND;

{  An input job has completed.  Delete the information for the input job
{  from the data structure.

            ELSEIF (file_status_transition = file_transfer_completed) THEN
              device^.input_job.user_job_name := osc$null_name;
              device^.input_job.system_job_name := osc$null_name;
              device^.input_job.requested_destination := osc$null_name;
              device^.input_job.actual_destination := osc$null_name;
              device^.input_job.input_bytes_transferred := 0;
              IF user_job_name <> osc$null_name THEN
                job_file_name := user_job_name;
              ELSEIF system_job_name <> osc$null_name THEN
                job_file_name := system_job_name;
              IFEND;
            IFEND;
          IFEND;

{  Send a file acknowledgement message if an output file transfer has
{  started or finished and if an input job has completed or if an NTF
{  file transfer has started or finished.

          IF (io_station^.usage = nfc$ntf_remote_system) OR (io_station^.operator_assigned AND
                (io_station^.file_acknowledgement OR device^.file_acknowledgement) AND
                (output_device_or_stream (device) OR (input_device_or_stream (device)
                AND (file_status_transition = file_transfer_completed)))) THEN
            operator_connection := io_station^.connected_operator;
            IF (job_file_name = osc$null_name) AND (io_station^.usage = nfc$ntf_remote_system) THEN
              IF input_device_or_stream (device) THEN
                job_file_name := 'NTF_RECEIVE_FILE';
              ELSE
                job_file_name := 'NTF_TRANSMIT_FILE';
              IFEND;
            IFEND;

            send_file_acknowledgement_msg (message, device, file_ack_messages [device^.file_transfer_status],
                  job_file_name, user_name, bytes_transferred, operator_connection,
                  ignore_status);
          IFEND;
        IFEND;

{ If the device is an output device, update the file transfer information. }

        IF output_device_or_stream (device) THEN
          IF (file_status_transition = file_transfer_completed) AND
                (device^.file_transfer_status <> nfc$idle_operator_hold_file) AND
                (q_file <> NIL) AND
                (q_file^.copies > 1) THEN
            q_file^.copies := q_file^.copies - 1;

{  Update the number of copies printed, and return so that another file is
{  not selected to print at that device.

            RETURN;
          ELSEIF file_status_transition = file_transfer_completed THEN
            device^.suppress_carriage_control := FALSE;
            device^.current_file := NIL;
            IF device^.file_transfer_status = nfc$idle_operator_hold_file THEN
              IF q_file <> NIL THEN
                q_file^.output_state := nfc$hold_transfer;
              IFEND;
            IFEND;
          IFEND;

          IF device_available_for_output (device) THEN
            find_file_for_device (device, message, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND change_file_transfer_status;
?? TITLE := 'check_for_ntf_signed_on_stream', EJECT ??

{  PURPOSE:
{    Check if the specified NTF batch stream is on a signed on logical line.

  PROCEDURE check_for_ntf_signed_on_stream
    (    remote_system: ^nft$io_station;
         batch_stream: ^nft$batch_device;
     VAR signed_on: boolean);

    VAR
      logical_line: ^nft$ntf_logical_line,
      logical_line_found: boolean;

    find_ntf_logical_line (batch_stream^.ntf_logical_line_number, remote_system, logical_line,
          logical_line_found);
    signed_on := logical_line_found AND (logical_line^.signon_status = nfc$ntf_signed_on);

  PROCEND check_for_ntf_signed_on_stream;
?? OLDTITLE ??
?? NEWTITLE := 'check_unreachable_btfs_di_lists', EJECT ??

{  PURPOSE:
{    Sweep through all the SCF/VE lists of unreachable BTFS/DI's looking for
{    expired timers.  When an expired timer is found then the entry in the list
{    of unreachable BTFS/DI's is removed and file assignents are attempted for
{    files queued for that DI.

  PROCEDURE check_unreachable_btfs_di_lists
    (VAR wait_list: ^ost$i_wait_list;
     VAR message: ^nft$message_sequence);

    VAR
      clock: integer,
      connection: ^nft$connection,
      current_unreachable_btfs_di: ^unreachable_btfs_di,
      ignore_status: ost$status,
      next_unreachable_btfs_di: ^unreachable_btfs_di,
      previous_unreachable_btfs_di: ^unreachable_btfs_di,
      timers_still_active: boolean;

?? NEWTITLE := 'retry_file_assignment', EJECT ??

{  PURPOSE:
{    Attempt to assign all eligible files in this SCF/VE connection's queue.

    PROCEDURE retry_file_assignment
      (    connection: ^nft$connection;
       VAR message: ^nft$message_sequence);

      VAR
        alias_station_list: ^nft$pointer_list_entry,
        ignore_status: ost$status,
        io_station: ^nft$io_station,
        q_found: boolean,
        queue_file: ^nft$output_queue_file,
        queue_pointer: ^ ^nft$output_queue_file; {!!}

      queue_file := connection^.scfve_queue;

      WHILE queue_file <> NIL DO
        IF queue_file^.output_state = nfc$eligible_for_transfer THEN
          q_found := FALSE;

          IF queue_file^.ios_usage = nfc$public_io_station THEN
            find_public_queue (queue_file^.ios_name, queue_pointer, alias_station_list, q_found);
            IF q_found THEN
              io_station := alias_station_list^.io_station;
              q_found := io_station^.usage = nfc$public_io_station;
            IFEND;

          ELSEIF (queue_file^.ios_usage = nfc$private_io_station) AND
                (queue_file^.ios_name = control_facility_name) THEN
            find_private_queue (queue_file^.operator_name, queue_file^.operator_family,
                  queue_pointer, alias_station_list, q_found);

          ELSEIF queue_file^.ios_usage = nfc$ntf_remote_system THEN
            find_ntf_remote_queue (queue_file^.ios_name, queue_pointer, alias_station_list);
            q_found := queue_pointer <> NIL;
          IFEND;

          IF q_found THEN
            output_file_assignment (queue_file, alias_station_list, message, connection,
                  ignore_status);
          IFEND;
        IFEND;

        queue_file := queue_file^.link;

      WHILEND;

    PROCEND retry_file_assignment;
?? OLDTITLE, EJECT ??

    pmp$get_microsecond_clock (clock, ignore_status);
    clock := clock DIV 1000;
    connection := scfs_tables.first_connection;
    timers_still_active := FALSE;

  /loop_thru_connections/
    WHILE connection <> NIL DO
      IF connection^.kind = nfc$scfve_connection THEN
        current_unreachable_btfs_di := connection^.unreachable_btfs_di_list;
        previous_unreachable_btfs_di := NIL;

      /loop_thru_unreachable_list/
        WHILE current_unreachable_btfs_di <> NIL DO
          next_unreachable_btfs_di := current_unreachable_btfs_di^.link;
          IF clock >= current_unreachable_btfs_di^.timer THEN
            IF previous_unreachable_btfs_di = NIL THEN
              connection^.unreachable_btfs_di_list := current_unreachable_btfs_di^.link;
            ELSE
              previous_unreachable_btfs_di^.link := current_unreachable_btfs_di^.link;
            IFEND;
            FREE current_unreachable_btfs_di;
            retry_file_assignment (connection, message);
          ELSE
            timers_still_active := TRUE;
            previous_unreachable_btfs_di := current_unreachable_btfs_di;
          IFEND;
          current_unreachable_btfs_di := next_unreachable_btfs_di;
        WHILEND /loop_thru_unreachable_list/;

      IFEND;
      connection := connection^.link;
    WHILEND /loop_thru_connections/;

    IF NOT timers_still_active THEN
      wait_list^ [2].milliseconds := long_scfs_timer;
    IFEND;

  PROCEND check_unreachable_btfs_di_lists;
?? OLDTITLE ??
?? NEWTITLE := 'clear_unreachable_btfs_di_list', EJECT ??

{  PURPOSE:
{    Delete all entries in the SCF/VE's list of unreachable BTFS/DI's.

  PROCEDURE clear_unreachable_btfs_di_list
    (    connection: ^nft$connection);

    VAR
      current_pointer: ^unreachable_btfs_di,
      next_pointer: ^unreachable_btfs_di;

    current_pointer := connection^.unreachable_btfs_di_list;
    next_pointer := current_pointer;

    WHILE next_pointer <> NIL DO
      current_pointer := next_pointer;
      next_pointer := current_pointer^.link;
      FREE current_pointer;
    WHILEND;

    connection^.unreachable_btfs_di_list := NIL;

  PROCEND clear_unreachable_btfs_di_list;
?? OLDTITLE ??
?? NEWTITLE := 'compare_ntf_logical_lines', EJECT ??

{  PURPOSE:
{    This procedure compares logical lines to verify that all fields except
{    pointers are identical to each other.

  PROCEDURE compare_ntf_logical_lines
    (    logical_line_entry_1: nft$ntf_logical_line;
         logical_line_entry_2: nft$ntf_logical_line;
     VAR logical_line_match: boolean);

    logical_line_match := (logical_line_entry_1.logical_line_number =
          logical_line_entry_2.logical_line_number) AND (logical_line_entry_1.line_name =
          logical_line_entry_2.line_name) AND (logical_line_entry_1.line_speed =
          logical_line_entry_2.line_speed) AND (logical_line_entry_1.signon_status =
          logical_line_entry_2.signon_status) AND (logical_line_entry_1.terminal_user_procedure =
          logical_line_entry_2.terminal_user_procedure) AND
          (logical_line_entry_1.scfdi_connection = logical_line_entry_2.scfdi_connection);

  PROCEND compare_ntf_logical_lines;
?? TITLE := 'compare_ntf_remote_systems', EJECT ??

{  PURPOSE:
{    This procedure compares two remote systems to verify that all fields
{    except pointers are identical to each other.

  PROCEDURE compare_ntf_remote_systems
    (    remote_system_entry_1: nft$io_station;
         remote_system_entry_2: nft$io_station;
     VAR remote_system_match: boolean);

    remote_system_match := (remote_system_entry_1.name = remote_system_entry_2.name) AND
          (remote_system_entry_1.usage = remote_system_entry_2.usage) AND
          (remote_system_entry_1.ntf_protocol = remote_system_entry_2.ntf_protocol) AND
          (remote_system_entry_1.ntf_local_system_name = remote_system_entry_2.ntf_local_system_name) AND
          (remote_system_entry_1.ntf_authority_level = remote_system_entry_2.ntf_authority_level) AND
          (remote_system_entry_1.ntf_wait_a_bit = remote_system_entry_2.ntf_wait_a_bit) AND
          (remote_system_entry_1.ntf_inactivity_timer = remote_system_entry_2.ntf_inactivity_timer) AND
          (remote_system_entry_1.ntf_positive_acknowledge =
          remote_system_entry_2.ntf_positive_acknowledge) AND
          (remote_system_entry_1.ntf_remote_password = remote_system_entry_2.ntf_remote_password) AND
          (remote_system_entry_1.ntf_local_password = remote_system_entry_2.ntf_local_password) AND
          (remote_system_entry_1.ntf_default_job_destination =
          remote_system_entry_2.ntf_default_job_destination) AND
          (remote_system_entry_1.ntf_default_file_destination =
          remote_system_entry_2.ntf_default_file_destination) AND
          (remote_system_entry_1.ntf_store_forward_destination =
          remote_system_entry_2.ntf_store_forward_destination) AND
          (remote_system_entry_1.ntf_remote_system_type = remote_system_entry_2.ntf_remote_system_type) AND
          (remote_system_entry_1.ntf_route_back_position = remote_system_entry_2.ntf_route_back_position) AND
          (remote_system_entry_1.ntf_request_permission_retry =
          remote_system_entry_2.ntf_request_permission_retry);

  PROCEND compare_ntf_remote_systems;
?? TITLE := 'count of files for station', EJECT ??

  FUNCTION count_of_files_for_station (io_station: ^nft$io_station): integer;

    VAR
      alias_entry: ^nft$alias,
      count: integer,
      i: 0 .. 3,
      q_file: ^nft$output_queue_file,
      selected_file: ^nft$selected_file;

    count := 0;

    IF (io_station^.usage <> nfc$ntf_remote_system) AND (io_station^.selected_files_queue <> NIL) THEN
      selected_file := io_station^.selected_files_queue;
      WHILE selected_file <> NIL DO
        count := count + 1;
        selected_file := selected_file^.link;
      WHILEND;
    IFEND;

    FOR i := 0 TO 3 DO
      IF io_station^.alias_list [i] <> NIL THEN
        alias_entry := io_station^.alias_list [i];
        IF alias_entry^.queue <> NIL THEN
          q_file := alias_entry^.queue;
          WHILE q_file <> NIL DO
            count := count + 1;
            q_file := q_file^.link;
          WHILEND;
        IFEND;
      IFEND;
    FOREND;

    count_of_files_for_station := count;

  FUNCEND count_of_files_for_station;
?? TITLE := 'crack device control resp', EJECT ??

{  PURPOSE:
{    This procedure obtains the required parameters from SCF/DI's
{    response to the following operator commands:
{      -  change_batch_device_attributes
{      -  position_file
{      -  start_batch_device
{      -  stop_batch_device
{      -  suppress_carraige_control
{      -  terminate_transfer

  PROCEDURE crack_device_control_resp
    (VAR message: ^nft$message_sequence;
     VAR msg_length: integer;
     VAR io_station_name: ost$name;
     VAR device_name: ost$name;
     VAR response_code: nft$device_control_resp_codes;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      byte_array: ^nft$byte_array,
      parameter: ^nft$device_control_resp_param,
      resp_code: ^nft$device_control_resp_codes,
      value_length: integer;

*copy nft$device_control_resp_msg

    NEXT parameter IN message;

    WHILE (parameter <> NIL) AND (parameter^.param <= nfc$response_code) AND (msg_length > 0) DO
      msg_length := msg_length - 1;
      IF parameter^.length_indicated THEN
        nfp$get_parameter_value_length (message, msg_length, value_length, status);
        msg_length := msg_length - value_length;
      ELSE
        value_length := 1;
        msg_length := msg_length - 1;
      IFEND;

      CASE parameter^.param OF
      = nfc$io_station_name =
        NEXT ascii_string: [value_length] IN message;
        #translate (osv$lower_to_upper, ascii_string^, io_station_name);

      = nfc$device_name =
        NEXT ascii_string: [value_length] IN message;
        #translate (osv$lower_to_upper, ascii_string^, device_name);

      = nfc$response_code =
        NEXT resp_code IN message;
        response_code := resp_code^;

      ELSE
{       ERROR ----   Ignore parameter value.
        NEXT byte_array: [1 .. value_length] IN message;

      CASEND;
      NEXT parameter IN message;
    WHILEND;

    RESET message TO parameter;

  PROCEND crack_device_control_resp;
?? TITLE := 'create_fake_io_station_for_ntf', EJECT ??

{  PURPOSE:
{     This procedure initializes an IO station entry using an NTF accessible
{     remote system name as the IO station name.  If the accessible remote
{     system exists, the IO station entry will be set up so that its only alias
{     is the accessible remote system.  This is needed so that NTF operators
{     can status files that are queued for only one accessible remote system.

  PROCEDURE create_fake_io_station_for_ntf
    (    ntf_acc_remote_system_name: ost$name;
     VAR fake_io_station_entry: nft$io_station;
     VAR ntf_acc_remote_system_found: boolean);

    VAR
      acc_remote_system: ^nft$alias;

    initialize_io_station (fake_io_station_entry);
    fake_io_station_entry.name := ntf_acc_remote_system_name;
    find_ntf_acc_remote_system (ntf_acc_remote_system_name, acc_remote_system);
    ntf_acc_remote_system_found := (acc_remote_system <> NIL);
    IF ntf_acc_remote_system_found THEN
      fake_io_station_entry.alias_list [0] := acc_remote_system;
    IFEND;

  PROCEND create_fake_io_station_for_ntf;
?? OLDTITLE ??
?? NEWTITLE := 'delete_all_unreachable_btfs_di', EJECT ??

{  PURPOSE:
{    Delete the entry in all SCF/VE lists of unreachable BTFS/DI's that
{    corresponds to the specified BTFS/DI title.

  PROCEDURE delete_all_unreachable_btfs_di
    (    title: nft$btfs_di_title);

    VAR
      connection: ^nft$connection,
      current_unreachable_btfs_di: ^unreachable_btfs_di,
      previous_unreachable_btfs_di: ^unreachable_btfs_di,
      title_found: boolean;

    connection := scfs_tables.first_connection;

  /loop_thru_connections/
    WHILE connection <> NIL DO
      IF connection^.kind = nfc$scfve_connection THEN
        current_unreachable_btfs_di := connection^.unreachable_btfs_di_list;
        previous_unreachable_btfs_di := NIL;
        title_found := FALSE;

      /loop_thru_unreachable_list/
        WHILE (current_unreachable_btfs_di <> NIL) AND (NOT title_found) DO
          IF current_unreachable_btfs_di^.title = title THEN
            title_found := TRUE;
            IF previous_unreachable_btfs_di = NIL THEN
              connection^.unreachable_btfs_di_list := current_unreachable_btfs_di^.link;
            ELSE
              previous_unreachable_btfs_di^.link := current_unreachable_btfs_di^.link;
            IFEND;
            FREE current_unreachable_btfs_di;
          ELSE
            previous_unreachable_btfs_di := current_unreachable_btfs_di;
            current_unreachable_btfs_di := current_unreachable_btfs_di^.link;
          IFEND;
        WHILEND /loop_thru_unreachable_list/;

      IFEND;
      connection := connection^.link;
    WHILEND /loop_thru_connections/;

  PROCEND delete_all_unreachable_btfs_di;
?? OLDTITLE ??
?? NEWTITLE := 'delete batch device msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from SCF/DI to
{    delete the definition of an existing batch device within an existing I/O
{    station.  If the station and the device specified are found, the device
{    entry is deleted, otherwise a response is sent to SCF/DI indicating
{    the station or device specified is unknown.
{
{    This procedure is also executed when a request is received from SCF/DI to
{    delete the definition of an existing batch stream within an existing NTF
{    remote system.  If the remote system and the stream specified are found,
{    the stream entry is deleted, otherwise a response is sent to SCF/DI
{    indicating the remote system or stream specified is unknown.

  PROCEDURE delete_batch_device_msg
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      message_response: nft$delete_bd_responses;

*copy nft$delete_batch_device_message
*copy nft$delete_bd_resp_codes

?? NEWTITLE := 'crack delete batch device msg', EJECT ??

{  PURPOSE:
{    Determine the parameters and values sent by SCF/DI on a
{    delete batch device message.

    PROCEDURE crack_delete_batch_device_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR station_name: ost$name;
       VAR device_name: ost$name;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        parameter: ^nft$del_bd_message_parameter,
        value_length: integer;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, station_name);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, device_name);

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_delete_batch_device_msg;
?? TITLE := 'send delete bd response', EJECT ??

{  PURPOSE:
{    Send a message to SCF/DI indicating SCFS's response to a
{    previous delete batch device message.

    PROCEDURE send_delete_bd_response
      (VAR message: ^nft$message_sequence;
           io_station_name: ost$name;
           device_name: ost$name;
           response_code: nft$delete_bd_responses;
           connection: ^nft$connection;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        message_length: nft$message_length,
        message_type: ^nft$message_kind,
        parameter_kind: ^nft$add_del_bd_resp_parameter,
        parameter_kind_size: nft$message_length,
        param_length_size: nft$message_length,
        parameter_value_length: integer,
        response_param: ^nft$delete_bd_responses;

*copy nft$add_del_device_response

      parameter_kind_size := #SIZE (nft$add_del_bd_resp_parameter);
      RESET message;

      NEXT message_type IN message;
      message_type^ := nfc$delete_batch_device_resp;
      message_length := 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$io_station_name;
      parameter_value_length := clp$trimmed_string_size (io_station_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := io_station_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$device_name;
      parameter_value_length := clp$trimmed_string_size (device_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := device_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$response_code;
      NEXT response_param IN message;
      response_param^ := response_code;
      message_length := message_length + parameter_kind_size + 1;

      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;

    PROCEND send_delete_bd_response;
?? OLDTITLE, EJECT ??

    message_response := nfc$message_accepted;

    crack_delete_batch_device_msg (message, msg_length, io_station_name, device_name, status);

    find_io_station_or_remote_sys (io_station_name, connection, io_station, io_station_found);
    IF io_station_found THEN
      find_batch_device (device_name, io_station, device, device_found);
      IF device_found THEN
        delete_batch_device_entry (device, io_station);
      ELSE
        message_response := nfc$no_device_found;
      IFEND;
    ELSE
      message_response := nfc$no_io_station_found;
    IFEND;

    send_delete_bd_response (message, io_station_name, device_name, message_response, connection, status);

  PROCEND delete_batch_device_msg;
?? TITLE := 'delete batch device entry', EJECT ??

{  PURPOSE:
{    Delete a batch device entry out of an I/O station's list of associated
{    batch devices or delete a batch stream entry out of an NTF remote system's
{    list of associated batch streams.

  PROCEDURE delete_batch_device_entry
    (VAR device: ^nft$batch_device;
         io_station: ^nft$io_station);

    VAR
      alias_index: 1 .. 3,
      back_link_device: ^nft$batch_device,
      current_file: ^nft$output_queue_file,
      link_device: ^nft$batch_device;

{ If a file is currently being transferred then disassociate it from this device - and hold the file

    current_file := device^.current_file;
    IF (current_file <> NIL) AND (current_file^.assigned_device = device) THEN
      current_file^.assigned_device := NIL;
      current_file^.output_state := nfc$hold_transfer;
    IFEND;

    IF device = io_station^.batch_device_list THEN
      io_station^.batch_device_list := device^.link;
      link_device := io_station^.batch_device_list;
      IF link_device <> NIL THEN
        link_device^.back_link := NIL;
      IFEND;
    ELSE
      back_link_device := device^.back_link;
      back_link_device^.link := device^.link;
      link_device := device^.link;
      IF link_device <> NIL THEN;
        link_device^.back_link := device^.back_link;
      IFEND;
    IFEND;

    FREE device;

  PROCEND delete_batch_device_entry;
?? TITLE := 'delete connection from tables', EJECT ??

{  PURPOSE:
{    This procedure deletes a connection out of a list of
{    connections known to SCFS.

  PROCEDURE delete_connection_from_tables
    (    connection: ^nft$connection);

    VAR
      next_connection: ^nft$connection,
      prior_connection: ^nft$connection;

    next_connection := connection^.link;
    IF connection = scfs_tables.first_connection THEN
      scfs_tables.first_connection := connection^.link;
      IF next_connection <> NIL THEN
        next_connection^.back_link := NIL;
      IFEND;
    ELSE
      prior_connection := connection^.back_link;
      prior_connection^.link := connection^.link;
      IF next_connection <> NIL THEN
        next_connection^.back_link := connection^.back_link;
      IFEND;
    IFEND;

  PROCEND delete_connection_from_tables;
?? TITLE := 'delete file availability msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from SCF/VE to
{    delete an output file entry in the output file scheduling queue(s).
{
{    This procedure is also executed when a request is received from NTF/VE to
{    delete an NTF file entry in the NTF file scheduling queue(s).

  PROCEDURE delete_file_availability_msg
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      device: ^nft$batch_device,
      file_held_by_filter: boolean,
      file_requeued: boolean,
      io_station: ^nft$io_station,
      io_station_name: ost$name,
      q_found: boolean,
      q_file: ^nft$output_queue_file,
      queue_file: nft$output_queue_file,
      queue_pointer: ^^nft$output_queue_file,
      selected_file: ^nft$selected_file,
      station_list: ^nft$pointer_list_entry;

?? NEWTITLE := 'delete file from q', EJECT ??

{  PURPOSE:
{    Delete the queue file from the station queue list,
{    from the SCF/VE connection queue list and from the device.

    PROCEDURE delete_file_from_q
      (    q_pointer: ^^nft$output_queue_file;
           connection: ^nft$connection;
       VAR q_file: ^nft$output_queue_file);

      VAR
        back_link_file: ^nft$output_queue_file,
        link_file: ^nft$output_queue_file;

      back_link_file := q_file^.back_link;
      link_file := q_file^.link;
      IF q_file = q_pointer^ THEN
        q_pointer^ := q_file^.link;
      IFEND;
      IF q_file^.back_link <> NIL THEN
        back_link_file^.link := q_file^.link;
      IFEND;
      IF q_file^.link <> NIL THEN
        link_file^.back_link := q_file^.back_link;
      IFEND;

      delete_from_scfve_q_and_device (q_file, connection);

      FREE q_file;

    PROCEND delete_file_from_q;
?? TITLE := 'delete_file_from_selected_q', EJECT ??

{  PURPOSE:
{    Delete a file that had been placed in the station's selected file queue.

    PROCEDURE delete_file_from_selected_q
      (    io_station: ^nft$io_station;
           connection: ^nft$connection;
       VAR selected_file: ^nft$selected_file);

      VAR
        q_file: ^nft$output_queue_file;

      q_file := selected_file^.output_file;

      remove_selected_file (io_station, selected_file);

      delete_from_scfve_q_and_device (q_file, connection);

      FREE q_file;

    PROCEND delete_file_from_selected_q;
?? TITLE := 'delete_from_scfve_q_and_device', EJECT ??

    PROCEDURE delete_from_scfve_q_and_device
      (    q_file: ^nft$output_queue_file;
           connection: ^nft$connection);

      VAR
        device: ^nft$batch_device,
        next_scfve_file: ^nft$output_queue_file,
        prior_scfve_file: ^nft$output_queue_file;

      prior_scfve_file := q_file^.prior_scfve_queue;
      next_scfve_file := q_file^.next_scfve_queue;
      IF q_file = connection^.scfve_queue THEN
        connection^.scfve_queue := q_file^.next_scfve_queue;
      IFEND;
      IF q_file^.prior_scfve_queue <> NIL THEN
        prior_scfve_file^.next_scfve_queue := q_file^.next_scfve_queue;
      IFEND;
      IF q_file^.next_scfve_queue <> NIL THEN
        next_scfve_file^.prior_scfve_queue := q_file^.prior_scfve_queue;
      IFEND;

      device := q_file^.assigned_device;
      IF device <> NIL THEN
        IF device^.current_file <> NIL THEN
          IF device^.current_file^.system_file_name = q_file^.system_file_name THEN
            device^.current_file := NIL;
          IFEND;
        IFEND;
      IFEND;

    PROCEND delete_from_scfve_q_and_device;

?? TITLE := 'get_requeue_and_held_params', EJECT ??

{  PURPOSE:
{    Get the parameter and value sent by SCF/DI if the file
{    transfer was held by a filter or requeued.

    PROCEDURE get_requeue_and_held_params
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR file_requeued: boolean;
       VAR file_held_by_filter: boolean;
       VAR status: ost$status);

*copy nft$file_availability_msg

      VAR
        byte_array: ^nft$byte_array,
        held: ^boolean,
        parameter: ^nft$file_available_msg_param,
        requeued: ^boolean,
        value_length: integer;

      status.normal := TRUE;
      file_held_by_filter := FALSE;
      file_requeued := FALSE;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;

        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$file_requeued =
          NEXT requeued IN message;
          file_requeued := requeued^;

        = nfc$file_held_by_filter =
          NEXT held IN message;
          file_held_by_filter := held^;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND get_requeue_and_held_params;
?? TITLE := 'send_terminate_transfer_msg', EJECT ??

{  PURPOSE:
{    Send a terminate transfer message because the owner of the file has issued
{    a terminate_output request on the file.  This makes the DI think that OPES
{    sent the terminate_transfer request.  SCFS will send the response to an
{    operator even though the operator is not expecting the response.

    PROCEDURE send_terminate_transfer_msg
      (    device: ^nft$batch_device;
           io_station_name: ost$name;
       VAR message: ^nft$message_sequence;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        connection: ^nft$connection,
        file_disposition: ^nft$file_disposition,
        message_length: nft$message_length,
        message_type: ^nft$message_kind,
        parameter_kind: ^nft$terminate_xfer_msg_param,
        parameter_kind_size: nft$message_length,
        param_length_size: nft$message_length,
        parameter_value_length: integer;

*copyc nft$terminate_transfer_msg

      parameter_kind_size := #SIZE (nft$terminate_xfer_msg_param);
      RESET message;

      NEXT message_type IN message;
      message_type^ := nfc$terminate_transfer;
      message_length := 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$io_station_name;
      parameter_value_length := clp$trimmed_string_size (io_station_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := io_station_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$device_name;
      parameter_value_length := clp$trimmed_string_size (device^.name);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := device^.name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$file_disposition;
      NEXT file_disposition IN message;
      file_disposition^ := nfc$drop_file_from_q;
      message_length := message_length + parameter_kind_size + 1;

      connection := device^.scfdi_connection;
      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;

    PROCEND send_terminate_transfer_msg;
?? TITLE := 'update number of requeues', EJECT ??

{  PURPOSE:
{    Update the number of requeues to the specified device.  If the number
{    of requeues per minute exceeds the defined threshold value, down the
{    device so that files are not assigned to print at that device.

    PROCEDURE update_number_of_requeues
      (    q_file: ^nft$output_queue_file;
       VAR message: ^nft$message_sequence;
       VAR status: ost$status);

      CONST
        maximum_requeues_allowed = 10,
        operator_message = 'Device rejecting file transfers, start device later.',
        requeue_timer_interval = 60;

      VAR
        device: ^nft$batch_device,
        elapsed_time: integer,
        io_station: ^nft$io_station,
        operator_connection: ^nft$connection,
        time: integer;

      pmp$get_microsecond_clock (time, status);

      device := q_file^.assigned_device;

{ The device associated with this queue file may have been deleted from SCFS's tables if
{ SCF/DI had recently sent a DELETE_BATCH_DEVICE message for the device.

      IF device <> NIL THEN
        IF NOT device^.device_timer_activated THEN
          device^.device_timer_activated := TRUE;
          device^.timer_start_time := time;
          device^.number_of_files_requeued := 1;
        ELSE
          elapsed_time := (time - device^.timer_start_time) DIV 1000000;
          IF elapsed_time < 0 THEN
            device^.timer_start_time := time;
            device^.number_of_files_requeued := 1;
          ELSEIF elapsed_time <= requeue_timer_interval THEN
            device^.number_of_files_requeued := device^.number_of_files_requeued + 1;
            IF (device^.number_of_files_requeued >= maximum_requeues_allowed) THEN
              device^.device_status := nfc$device_stopped_by_system;
              io_station := device^.io_station;
              IF io_station^.operator_assigned OR (io_station^.usage = nfc$ntf_remote_system) THEN
                operator_connection :=  io_station^.connected_operator;
                send_operator_message (message, device, operator_message, operator_connection,
                      status);
              IFEND;
            IFEND;
          ELSE
            device^.device_timer_activated := FALSE;
            device^.timer_start_time := 0;
            device^.number_of_files_requeued := 0;
         IFEND;
       IFEND;
     IFEND;

    PROCEND update_number_of_requeues;
?? OLDTITLE, EJECT ??
    device := NIL;
    file_held_by_filter := FALSE;
    q_file := NIL;
    q_found := FALSE;
    queue_pointer := NIL;
    selected_file := NIL;

    get_required_file_avail_params (message, msg_length, queue_file, status);
    get_requeue_and_held_params (message, msg_length, file_requeued, file_held_by_filter, status);

    CASE queue_file.ios_usage OF
    = nfc$private_io_station =
      find_private_queue (queue_file.operator_name, queue_file.operator_family, queue_pointer,
            station_list, q_found);
      IF NOT q_found THEN
        q_found := NOT q_found;
        queue_pointer := ^scfs_tables.unknown_private_operators_q;
      IFEND;
    = nfc$public_io_station =
      find_public_queue (queue_file.ios_name, queue_pointer, station_list, q_found);
    = nfc$ntf_remote_system =
      find_ntf_remote_queue (queue_file.ios_name, queue_pointer, station_list);
      q_found := (queue_pointer <> NIL);
    CASEND;

    IF q_found THEN
      find_q_file (queue_file.system_file_name, queue_pointer^, q_file);
      IF q_file <> NIL THEN
        IF file_requeued THEN
          update_number_of_requeues (q_file, message, status);
        IFEND;
        device := q_file^.assigned_device;

{ If the device is receiving the file in question, then send a terminate_transfer
{ message (the user terminated the output).  Then delete the file from the queue.

        IF (q_file^.output_state = nfc$selected_for_transfer) AND (device <> NIL) AND (device^.current_file =
              q_file) AND (device^.file_transfer_status >= nfc$busy) THEN
          io_station := device^.io_station;
          send_terminate_transfer_msg (device, io_station^.name, message, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        IF file_held_by_filter THEN
          q_file^.output_state := nfc$hold_transfer;
          IF (device <> NIL) THEN
            device^.current_file := NIL;
          IFEND;
        ELSE
          delete_file_from_q (queue_pointer, connection, q_file);
        IFEND;
      ELSE
        find_station_and_selected_file (queue_file.system_file_name, io_station, selected_file);
        IF (selected_file <> NIL) THEN
          q_file := selected_file^.output_file;
          IF (q_file <> NIL) THEN
            device := q_file^.assigned_device;
          IFEND;
        IFEND;

{ Selected_file is a file that has been selected for transfer by the station operator.

        IF (selected_file <> NIL) THEN
          IF (device <> NIL) THEN
            IF (q_file^.output_state = nfc$selected_for_transfer) AND (device^.current_file =
                  q_file) AND (device^.file_transfer_status >= nfc$busy) THEN
              send_terminate_transfer_msg (device, io_station^.name, message, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          IFEND;
          IF file_held_by_filter THEN
            q_file^.output_state := nfc$hold_transfer;
            IF (device <> NIL) THEN
              device^.current_file := NIL;
            IFEND;
          ELSE
            delete_file_from_selected_q (io_station, connection, selected_file);
          IFEND;
        IFEND;
      IFEND;
      IF (device <> NIL) AND device_available_for_output (device) THEN
        find_file_for_device (device, message, status);
      IFEND;
    IFEND;

  PROCEND delete_file_availability_msg;
?? TITLE := 'delete io station', EJECT ??

{  PURPOSE:
{    This procedure does the actually deleting of an io station
{    from the tables maintained by SCFS.  The SCF/DI connection
{    is deleted, the operator connection is deleted (if there
{    currently is an operator connected), the station is removed
{    from the lists and a message is sent to each SCF/VE that
{    sent files to this destination and control facility.  If the
{    station being deleted is a private station, all files are
{    returned to the "unknown station queue".

  PROCEDURE delete_io_station
    (    connection: ^nft$connection;
     VAR io_station: ^nft$io_station;
     VAR message: ^nft$message_sequence;
     VAR wait_list: ^ost$i_wait_list;
     VAR wait_connection_list: ^nft$wait_connection_list;
     VAR status: ost$status);

    VAR
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      file_name: amt$local_file_name,
      ignore_status: ost$status,
      operator_connection: ^nft$connection;

?? NEWTITLE := 'delete dest msg to all scfves', EJECT ??

{  PURPOSE:
{    Send a message to each SCF/VE that sent files to the station
{    currently being deleted.

    PROCEDURE delete_dest_msg_to_all_scfves
      (    destination_name: ost$name;
       VAR message: ^nft$message_sequence;
       VAR status: ost$status);

      VAR
        connection: ^nft$connection;

      connection := scfs_tables.first_connection;
      WHILE connection <> NIL DO
        IF connection^.kind = nfc$scfve_connection THEN
          send_delete_destination_msg (message, destination_name, control_facility_name, connection, status);
        IFEND;
        connection := connection^.link;
      WHILEND;

    PROCEND delete_dest_msg_to_all_scfves;
?? TITLE := 'delete io station connection', EJECT ??

    PROCEDURE delete_io_station_connection
      (    io_station: ^nft$io_station;
           connection: ^nft$connection);

      VAR
        pointer_to_connection: ^nft$pointer_list_entry;

?? NEWTITLE := 'delete bds on same connection', EJECT ??

      PROCEDURE delete_bds_on_same_connection
        (    io_station: ^nft$io_station;
             connection: ^nft$connection);

        VAR
          current_bd: ^nft$batch_device,
          device: ^nft$batch_device;

        IF io_station^.batch_device_list <> NIL THEN
          current_bd := io_station^.batch_device_list;

          WHILE current_bd <> NIL DO
            device := current_bd;
            current_bd := current_bd^.link;
            IF device^.scfdi_connection = connection THEN
              delete_batch_device_entry (device, io_station);
            IFEND;
          WHILEND;
        IFEND;

      PROCEND delete_bds_on_same_connection;
?? OLDTITLE, EJECT ??

      delete_bds_on_same_connection (io_station, connection);

      pointer_to_connection := io_station^.scfdi_connection_pointers;

      IF pointer_to_connection^.connection = connection THEN
        io_station^.scfdi_connection_pointers := pointer_to_connection^.link;
      ELSE

      /find_connection/
        WHILE pointer_to_connection <> NIL DO
          IF pointer_to_connection^.connection = connection THEN
            EXIT /find_connection/;
          IFEND;
          pointer_to_connection := pointer_to_connection^.link;
        WHILEND /find_connection/;
      IFEND;

      IF pointer_to_connection <> NIL THEN
        delete_pointer_list_entry (pointer_to_connection);
      IFEND;

    PROCEND delete_io_station_connection;
?? TITLE := 'delete io station entry', EJECT ??

    PROCEDURE delete_io_station_entry
      (VAR io_station: ^nft$io_station;
       VAR status: ost$status);

      VAR
        back_link_station,
        link_station: ^nft$io_station;

      back_link_station := io_station^.back_link;
      link_station := io_station^.link;

      IF io_station = scfs_tables.first_io_station THEN
        scfs_tables.first_io_station := io_station^.link;
        IF io_station^.link <> NIL THEN
          link_station^.back_link := NIL;
        IFEND;
      ELSE
        back_link_station^.link := io_station^.link;
        IF io_station^.link <> NIL THEN
          link_station^.back_link := io_station^.back_link;
        IFEND;
      IFEND;

      FREE io_station;

    PROCEND delete_io_station_entry;
?? TITLE := 'free all queue files', EJECT ??

    PROCEDURE free_all_queue_files
      (    current_alias: ^nft$alias);

      VAR
        current_q_entry: ^nft$output_queue_file,
        queue_entry: ^nft$output_queue_file;

      current_q_entry := current_alias^.queue;

      IF current_q_entry = NIL THEN
        WHILE current_q_entry <> NIL DO
          remove_file_from_scf_ve_q (current_q_entry);
          queue_entry := current_q_entry;
          current_q_entry := current_q_entry^.link;
          FREE queue_entry;
        WHILEND;
      IFEND;

    PROCEND free_all_queue_files;
?? TITLE := 'free_selected_files_queue', EJECT ??

    PROCEDURE free_selected_files_queue
      (    io_station: ^nft$io_station);

      VAR
        current_q_entry: ^nft$output_queue_file,
        old_selected_queue_entry: ^nft$selected_file,
        selected_queue_entry: ^nft$selected_file;

      selected_queue_entry := io_station^.selected_files_queue;
      WHILE selected_queue_entry <> NIL DO
        current_q_entry := selected_queue_entry^.output_file;
        remove_file_from_scf_ve_q (current_q_entry);
        old_selected_queue_entry := selected_queue_entry;
        selected_queue_entry := selected_queue_entry^.link;
        FREE old_selected_queue_entry;
      WHILEND;

      io_station^.selected_files_queue := NIL;
      io_station^.last_selected_file_in_q := NIL;

    PROCEND free_selected_files_queue;
?? TITLE := 'remove_file_from_scf_ve_q', EJECT ??

    PROCEDURE remove_file_from_scf_ve_q
      (    current_file: ^nft$output_queue_file);

      VAR
        next_scfve_queue: ^nft$output_queue_file,
        prior_scfve_queue: ^nft$output_queue_file,
        scfve_connection: ^nft$connection;

?? NEWTITLE := 'get_scfve_connection', EJECT ??

      PROCEDURE get_scfve_connection
        (    q_file: ^nft$output_queue_file;
         VAR connection: ^nft$connection);

        VAR
          connection_found: boolean;

        connection_found := FALSE;
        connection := scfs_tables.first_connection;
        WHILE (NOT connection_found) AND (connection <> scfs_tables.first_connection) DO
          connection_found := (connection^.kind = nfc$scfve_connection) AND (connection^.scfve_queue =
                q_file);
          IF NOT connection_found THEN
            connection := connection^.link;
          IFEND;
        WHILEND;

      PROCEND get_scfve_connection;
?? OLDTITLE, EJECT ??
      get_scfve_connection (current_file, scfve_connection);

      IF current_file^.prior_scfve_queue = NIL THEN
        scfve_connection^.scfve_queue := current_file^.next_scfve_queue;
      ELSE
        prior_scfve_queue := current_file^.prior_scfve_queue;
        prior_scfve_queue^.next_scfve_queue := current_file^.next_scfve_queue;
        next_scfve_queue := current_file^.next_scfve_queue;
        IF (next_scfve_queue <> NIL) THEN
          next_scfve_queue^.prior_scfve_queue := current_file^.prior_scfve_queue;
        IFEND;
      IFEND;

    PROCEND remove_file_from_scf_ve_q;
?? TITLE := 'remove station from alias list', EJECT ??

{  PURPOSE:
{    Remove the station from the station list pointed to by the
{    station name-alias entry and remove the station from the
{    station name-alias list.  Removal of the station also
{    entails deleting the title registration from the network.

    PROCEDURE remove_station_from_alias_list
      (    io_station: ^nft$io_station;
       VAR message: ^nft$message_sequence);

      VAR
        alias_station: ^nft$pointer_list_entry,
        current_alias: ^nft$alias,
        station: ^nft$io_station;

?? NEWTITLE := 'delete ios in alias list', EJECT ??

      PROCEDURE delete_ios_in_alias_list
        (    alias_pt: ^nft$alias;
             io_station: ^nft$io_station);

        VAR
          pointer_list_entry: ^nft$pointer_list_entry;

        pointer_list_entry := alias_pt^.station_list;

      /find_last_station_pointer/
        WHILE pointer_list_entry <> NIL DO
          IF pointer_list_entry^.io_station = io_station THEN
            IF pointer_list_entry = alias_pt^.station_list THEN
              alias_pt^.station_list := pointer_list_entry^.link;
            IFEND;
            delete_pointer_list_entry (pointer_list_entry);
            EXIT /find_last_station_pointer/;
          IFEND;
          pointer_list_entry := pointer_list_entry^.link;
        WHILEND /find_last_station_pointer/;

      PROCEND delete_ios_in_alias_list;
?? TITLE := 'remove name from alias list', EJECT ??

      PROCEDURE remove_entry_from_alias_list
        (VAR alias_pt: ^nft$alias);

        VAR
          back_link: ^nft$alias,
          current_alias: ^nft$alias,
          link: ^nft$alias,
          status: ost$status;

        current_alias := alias_pt;
        back_link := current_alias^.back_link;
        link := current_alias^.link;

        IF current_alias = scfs_tables.first_station_name_alias THEN
          scfs_tables.first_station_name_alias := current_alias^.link;
          IF current_alias^.link <> NIL THEN
            link^.back_link := NIL;
          IFEND;
        ELSE
          back_link^.link := current_alias^.link;
          IF current_alias^.link <> NIL THEN
            link^.back_link := current_alias^.back_link;
          IFEND;
        IFEND;

        free_all_queue_files (current_alias);

        FREE current_alias;

        alias_pt := link;

      PROCEND remove_entry_from_alias_list;
?? OLDTITLE, EJECT ??

      current_alias := scfs_tables.first_station_name_alias;

    /search_station_alias_list/
      WHILE current_alias <> NIL DO
        IF (current_alias^.name = io_station^.name) OR (current_alias^.name = io_station^.alias_names [1]) OR
              (current_alias^.name = io_station^.alias_names [2]) OR (current_alias^.name = io_station^.
              alias_names [3]) THEN

          delete_ios_in_alias_list (current_alias, io_station);

{  No stations in the station list, delete alias and station title.
          IF current_alias^.station_list = NIL THEN
            IF current_alias^.station_title_registered THEN
              delete_station_alias_title (current_alias^.name, nfc$station_title, status);
              IF status.normal THEN
                current_alias^.station_title_registered := FALSE;
              IFEND;
            IFEND;

            IF current_alias^.alias_title_registered THEN
              delete_station_alias_title (current_alias^.name, nfc$alias_title, status);
              IF status.normal THEN
                current_alias^.alias_title_registered := FALSE;
              IFEND;
            IFEND;
            delete_dest_msg_to_all_scfves (current_alias^.name, message, status);
            remove_entry_from_alias_list ( current_alias);
            CYCLE /search_station_alias_list/;

{  Delete station title.
          ELSEIF (current_alias^.name = io_station^.name) THEN
            IF current_alias^.station_title_registered THEN
              delete_station_alias_title (current_alias^.name, nfc$station_title, status);
              IF status.normal THEN
                current_alias^.station_title_registered := FALSE;
              IFEND;
            IFEND;

{  Delete alias title, if there is only one entry in the station list and that
{  entry is pointing to a station with the same name as the station_alias entry.
          ELSE  {current_alias^.name = one of the io_station's alias names}
            alias_station := current_alias^.station_list;
            station := alias_station^.io_station;
            IF (alias_station^.link = NIL) AND
                  (station^.name = current_alias^.name) AND
                  current_alias^.alias_title_registered THEN
              delete_station_alias_title (current_alias^.name, nfc$alias_title, status);
              IF status.normal THEN
                current_alias^.alias_title_registered := FALSE;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
        IF current_alias <> NIL THEN
          current_alias := current_alias^.link;
        IFEND;
      WHILEND /search_station_alias_list/;

    PROCEND remove_station_from_alias_list;
?? OLDTITLE, EJECT ??

    delete_io_station_connection (io_station, connection);
    IF io_station^.scfdi_connection_pointers = NIL THEN
      IF io_station^.connected_operator <> NIL THEN
        operator_connection := io_station^.connected_operator;
        operator_connection^.operating_station := NIL;
        bap$validate_file_identifier (operator_connection^.id, file_instance, file_id_is_valid);
        IF file_id_is_valid THEN
          file_name := file_instance^.local_file_name;
          fsp$close_file (operator_connection^.id, status);
          amp$return (file_name, ignore_status);
        IFEND;
        delete_connection_from_tables (operator_connection);
        remove_from_wait_lists (operator_connection^.wait_list_index, wait_list, wait_connection_list);
      IFEND;
      IF io_station^.usage = nfc$private_io_station THEN
        move_files_back_to_unknown_q (io_station);
      IFEND;
      IF io_station^.selected_files_queue <> NIL THEN
        free_selected_files_queue (io_station);
      IFEND;
      remove_station_from_alias_list (io_station, message);
      delete_io_station_entry (io_station, status);
    IFEND;

  PROCEND delete_io_station;
?? TITLE := 'delete io station msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from SCF/DI to
{    delete access to the I/O station for the specified SCF/DI connection.
{    Any batch devices defined for the requesting DI that are defined for
{    the I/O station are deleted.  When all SCF/DI connections are deleted, the
{    complete I/O station is deleted.  A response to the request is sent
{    to SCF/DI.

  PROCEDURE delete_io_station_msg
    (VAR message: ^nft$message_sequence;
     VAR connection: ^nft$connection;
     VAR msg_length: integer;
     VAR wait_list: ^ost$i_wait_list;
     VAR wait_connection_list: ^nft$wait_connection_list;
     VAR status: ost$status);

    VAR
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      operator_connection: ^nft$connection,
      message_response: nft$delete_io_station_responses;

*copy nft$delete_io_station_message
*copy nft$delete_ios_resp_codes

?? NEWTITLE := 'crack delete io station msg', EJECT ??

    PROCEDURE crack_delete_io_station_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR station_name: ost$name;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        parameter: ^nft$del_ios_message_parameter,
        value_length: integer;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        IF parameter^.param = nfc$io_station_name THEN
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, station_name);
        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        IFEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_delete_io_station_msg;
?? TITLE := 'send delete io station response', EJECT ??

{  PURPOSE:
{    Send a message to SCF/DI indicating SCFS's response to a
{    previous delete I/O station message.

    PROCEDURE send_delete_io_station_response
      (VAR message: ^nft$message_sequence;
           response_code: nft$delete_io_station_responses;
           station_name: ost$name;
           connection: ^nft$connection;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        message_length: nft$message_length,
        message_type: ^nft$message_kind,
        parameter_kind: ^nft$del_ios_resp_msg_parameter,
        parameter_kind_size: nft$message_length,
        param_length_size: nft$message_length,
        parameter_value_length: integer,
        response_param: ^nft$delete_io_station_responses;

*copy nft$delete_io_station_response

      parameter_kind_size := #SIZE (nft$del_ios_resp_msg_parameter);
      RESET message;

      NEXT message_type IN message;
      message_type^ := nfc$delete_io_station_resp;
      message_length := 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$io_station_name;
      parameter_value_length := clp$trimmed_string_size (station_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := station_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$response_code;
      NEXT response_param IN message;
      response_param^ := response_code;
      message_length := message_length + parameter_kind_size + 1;

      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;

    PROCEND send_delete_io_station_response;
?? OLDTITLE, EJECT ??

    crack_delete_io_station_msg (message, msg_length, io_station_name, status);

    message_response := nfc$message_accepted;

    find_io_station (io_station_name, io_station, io_station_found);
    IF NOT io_station_found THEN
      message_response := nfc$no_io_station;
    ELSE
      delete_io_station (connection, io_station, message, wait_list, wait_connection_list,
            status);
    IFEND;

    send_delete_io_station_response (message, message_response, io_station_name, connection, status);

  PROCEND delete_io_station_msg;

?? TITLE := 'delete station alias title', EJECT ??

{  PURPOSE:
{    Delete the specified title from the network.
{    Now when a client requests a title translation with
{    this name, the address for this control facility will
{    not be returned.

  PROCEDURE delete_station_alias_title
    (    title_part: ost$name;
         title_kind: nft$title_kind;
     VAR status: ost$status);

    VAR
      title: ^nat$title_pattern;

    status.normal := TRUE;

    PUSH title: [start_of_title_length + osc$max_name_size];
    IF title_kind = nfc$station_title THEN
      title^ (1, start_of_title_length) := start_of_scfs_title;
    ELSEIF title_kind = nfc$alias_title THEN
      title^ (1, start_of_title_length) := start_of_alias_title;
    IFEND;
    title^ (1 + start_of_title_length, * ) := title_part;

    nap$delete_server_title (server_name, title^, status);

  PROCEND delete_station_alias_title;
?? TITLE := 'delete_ntf_acc_remote_sys_ptr', EJECT ??

{  PURPOSE:
{    This procedure deletes an accessible remote system pointer from the list
{    of accessible remote system pointers known to a logical line.

  PROCEDURE delete_ntf_acc_remote_sys_ptr
    (VAR acc_remote_system_ptr: ^nft$pointer_list_entry;
         remote_system: ^nft$io_station);

    VAR
      prev_acc_remote_system_ptr: ^nft$pointer_list_entry,
      next_acc_remote_system_ptr: ^nft$pointer_list_entry;

    prev_acc_remote_system_ptr := acc_remote_system_ptr^.back_link;
    IF prev_acc_remote_system_ptr <> NIL THEN
      prev_acc_remote_system_ptr^.link := acc_remote_system_ptr^.link;
    ELSE
      remote_system^.ntf_acc_remote_system_ptr_list := acc_remote_system_ptr^.link;
    IFEND;

    next_acc_remote_system_ptr := acc_remote_system_ptr^.link;
    IF next_acc_remote_system_ptr <> NIL THEN
      next_acc_remote_system_ptr^.back_link := acc_remote_system_ptr^.back_link;
    IFEND;

    FREE acc_remote_system_ptr;

  PROCEND delete_ntf_acc_remote_sys_ptr;
?? TITLE := 'delete_ntf_logical_line_entry', EJECT ??

{  PURPOSE:
{    This procedure deletes a logical line from the list of logical lines known
{    to a remote system.

  PROCEDURE delete_ntf_logical_line_entry
    (VAR logical_line: ^nft$ntf_logical_line;
         remote_system: ^nft$io_station);

    VAR
      ignore_status: ost$status,
      prev_logical_line: ^nft$ntf_logical_line,
      next_logical_line: ^nft$ntf_logical_line;

    prev_logical_line := logical_line^.back_link;
    IF prev_logical_line <> NIL THEN
      prev_logical_line^.link := logical_line^.link;
    ELSE
      remote_system^.ntf_logical_line_list := logical_line^.link;
    IFEND;

    next_logical_line := logical_line^.link;
    IF next_logical_line <> NIL THEN
      next_logical_line^.back_link := logical_line^.back_link;
    IFEND;

    send_ntf_signon_status_message ('Deleted             ', remote_system, logical_line,
          ignore_status);
    FREE logical_line;

  PROCEND delete_ntf_logical_line_entry;
?? TITLE := 'delete_ntf_remote_system', EJECT ??

{  PURPOSE:
{    This procedure deletes a specified connection from a remote system.  As
{    an option, the deletion can be restricted to a specific logical line on
{    the connection.  If all logical lines for the remote system are deleted,
{    the remote system will be deleted from SCFS tables.

  PROCEDURE delete_ntf_remote_system
    (VAR remote_system: ^nft$io_station;
         connection: ^nft$connection;
         check_logical_line_number: boolean;
         logical_line_number: nft$ntf_logical_line_number);

    VAR
      batch_stream: ^nft$batch_device,
      last_batch_stream: ^nft$batch_device,
      last_logical_line: ^nft$ntf_logical_line,
      logical_line: ^nft$ntf_logical_line,
      next_remote_system: ^nft$io_station,
      operator_connection: ^nft$connection,
      previous_remote_system: ^nft$io_station;

?? NEWTITLE := 'delete_logical_line', EJECT ??

    PROCEDURE delete_logical_line
      (VAR logical_line: ^nft$ntf_logical_line;
           remote_system: ^nft$io_station);

      VAR
        acc_remote_system: ^nft$alias,
        acc_remote_system_ptr: ^nft$pointer_list_entry,
        last_acc_remote_system_ptr: ^nft$pointer_list_entry,
        remote_system_ptr: ^nft$pointer_list_entry,
        remote_system_ptr_found: boolean;

      acc_remote_system_ptr := remote_system^.ntf_acc_remote_system_ptr_list;
      WHILE acc_remote_system_ptr <> NIL DO
        acc_remote_system := acc_remote_system_ptr^.ntf_acc_remote_system;
        last_acc_remote_system_ptr := acc_remote_system_ptr;
        acc_remote_system_ptr := last_acc_remote_system_ptr^.link;
        find_ntf_remote_system_pointer (remote_system^.name, TRUE, logical_line^.logical_line_number,
              acc_remote_system, remote_system_ptr, remote_system_ptr_found);
        IF remote_system_ptr_found THEN
          delete_ntf_remote_system_ptr (remote_system_ptr, acc_remote_system);
          IF acc_remote_system^.station_list = NIL THEN
            acc_remote_system^.ntf_authority_level := nfc$ntf_none;
            delete_ntf_acc_remote_sys_ptr (last_acc_remote_system_ptr, remote_system);
          ELSE
            find_ntf_remote_system_pointer (remote_system^.name, FALSE, 1, acc_remote_system,
                  remote_system_ptr, remote_system_ptr_found);
            IF NOT remote_system_ptr_found THEN
              delete_ntf_acc_remote_sys_ptr (last_acc_remote_system_ptr, remote_system);
            IFEND;
          IFEND;
        IFEND;
      WHILEND;

      delete_ntf_logical_line_entry (logical_line, remote_system);

    PROCEND delete_logical_line;
?? OLDTITLE, EJECT ??

    batch_stream := remote_system^.batch_device_list;
    WHILE batch_stream <> NIL DO
      last_batch_stream := batch_stream;
      batch_stream := last_batch_stream^.link;
      IF (last_batch_stream^.scfdi_connection = connection) AND
            ((NOT check_logical_line_number) OR (last_batch_stream^.ntf_logical_line_number =
            logical_line_number)) THEN
        delete_batch_device_entry (last_batch_stream, remote_system);
      IFEND;
    WHILEND;

    logical_line := remote_system^.ntf_logical_line_list;
    WHILE logical_line <> NIL DO
      last_logical_line := logical_line;
      logical_line := last_logical_line^.link;
      IF (last_logical_line^.scfdi_connection = connection) AND
            ((NOT check_logical_line_number) OR (last_logical_line^.logical_line_number =
            logical_line_number)) THEN
        delete_logical_line (last_logical_line, remote_system);
      IFEND;
    WHILEND;

    IF remote_system^.ntf_logical_line_list = NIL THEN
      previous_remote_system := remote_system^.back_link;
      IF previous_remote_system <> NIL THEN
        previous_remote_system^.link := remote_system^.link;
      ELSE
        scfs_tables.first_ntf_remote_system := remote_system^.link;
      IFEND;

      next_remote_system := remote_system^.link;
      IF next_remote_system <> NIL THEN
        next_remote_system^.back_link := remote_system^.back_link;
      IFEND;

      IF remote_system^.connected_operator <> NIL THEN
        operator_connection := remote_system^.connected_operator;
        operator_connection^.operating_station := NIL;
      IFEND;

      FREE remote_system;
    IFEND;

  PROCEND delete_ntf_remote_system;
?? TITLE := 'delete_ntf_remote_system_msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from SCF/DI to
{    delete access to the NTF remote system for the specified logical line.
{    Any batch streams for the logical line are deleted.  When all logical
{    lines are deleted, the complete NTF remote system is deleted.  A response
{    to the request is sent to SCF/DI.

  PROCEDURE delete_ntf_remote_system_msg
    (VAR message: ^nft$message_sequence;
     VAR connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      logical_line: ^nft$ntf_logical_line,
      logical_line_found: boolean,
      logical_line_number: nft$ntf_logical_line_number,
      remote_system: ^nft$io_station,
      remote_system_found: boolean,
      remote_system_name: ost$name,
      message_response: nft$ntf_del_rs_response_codes;

*copy nft$ntf_del_remote_sys_msg
*copy nft$ntf_del_rs_response_codes
?? NEWTITLE := 'crack_delete_remote_system_msg', EJECT ??

    PROCEDURE crack_delete_remote_system_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR remote_system_name: ost$name;
       VAR logical_line_number: nft$ntf_logical_line_number;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        line_number: ^nft$ntf_logical_line_number,
        parameter: ^nft$ntf_del_remote_sys_msg,
        value_length: integer;

      status.normal := TRUE;
      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$ntf_remote_system_name =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, remote_system_name);

        = nfc$ntf_logical_line_number =
          NEXT line_number IN message;
          logical_line_number := line_number^;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_delete_remote_system_msg;
?? TITLE := 'send_delete_remote_system_resp', EJECT ??

    PROCEDURE send_delete_remote_system_resp
      (VAR message: ^nft$message_sequence;
           response_code: nft$ntf_del_rs_response_codes;
           remote_system_name: ost$name;
           logical_line_number: nft$ntf_logical_line_number;
           connection: ^nft$connection;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        line_number: ^nft$ntf_logical_line_number,
        message_length: nft$message_length,
        message_type: ^nft$message_kind,
        parameter_kind: ^nft$ntf_del_remote_sys_resp,
        parameter_kind_size: nft$message_length,
        param_length_size: nft$message_length,
        parameter_value_length: integer,
        response_param: ^nft$ntf_del_rs_response_codes;

*copy nft$ntf_del_remote_sys_resp

      status.normal := TRUE;
      parameter_kind_size := #SIZE (nft$ntf_del_remote_sys_resp);
      RESET message;

      NEXT message_type IN message;
      message_type^ := nfc$delete_ntf_remote_sys_resp;
      message_length := 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$ntf_remote_system_name;
      parameter_value_length := clp$trimmed_string_size (remote_system_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := remote_system_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$ntf_logical_line_number;
      parameter_value_length := #SIZE (nft$ntf_logical_line_number);
      parameter_kind^.length_indicated := TRUE;
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      NEXT line_number IN message;
      line_number^ := logical_line_number;
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$response_code;
      NEXT response_param IN message;
      response_param^ := response_code;
      message_length := message_length + parameter_kind_size + 1;

      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;

    PROCEND send_delete_remote_system_resp;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    crack_delete_remote_system_msg (message, msg_length, remote_system_name, logical_line_number, status);
    message_response := nfc$message_accepted;
    find_ntf_remote_system (remote_system_name, remote_system, remote_system_found);
    IF remote_system_found THEN
      find_ntf_logical_line (logical_line_number, remote_system, logical_line,
            logical_line_found);
      IF logical_line_found THEN
        delete_ntf_remote_system (remote_system, connection, TRUE, logical_line_number);
      ELSE
        message_response := nfc$ntf_remote_system_not_found;
      IFEND;
    ELSE
      message_response := nfc$ntf_remote_system_not_found;
    IFEND;

    send_delete_remote_system_resp (message, message_response, remote_system_name, logical_line_number,
          connection, status);

  PROCEND delete_ntf_remote_system_msg;
?? TITLE := 'delete_ntf_remote_system_ptr', EJECT ??

{  PURPOSE:
{    This procedure deletes a remote system pointer from the list of remote
{    system pointers known to accessible remote system.

  PROCEDURE delete_ntf_remote_system_ptr
    (VAR remote_system_ptr: ^nft$pointer_list_entry;
         acc_remote_system: ^nft$alias);

    VAR
      prev_remote_system_ptr: ^nft$pointer_list_entry,
      next_remote_system_ptr: ^nft$pointer_list_entry;

    prev_remote_system_ptr := remote_system_ptr^.back_link;
    IF prev_remote_system_ptr <> NIL THEN
      prev_remote_system_ptr^.link := remote_system_ptr^.link;
    ELSE
      acc_remote_system^.station_list := remote_system_ptr^.link;
    IFEND;

    next_remote_system_ptr := remote_system_ptr^.link;
    IF next_remote_system_ptr <> NIL THEN
      next_remote_system_ptr^.back_link := remote_system_ptr^.back_link;
    IFEND;

    FREE remote_system_ptr;

  PROCEND delete_ntf_remote_system_ptr;
?? TITLE := 'delete_ntf_user_message', EJECT ??

{    This procedure is executed when a request is received from OPENTF to
{    remove operator control of a remote system.  A negative response is sent
{    to OPENTF if the remote system is not found or if the specified operator
{    is not in control of the remote system.  This message is accepted if the
{    remote system is not under control of an operator.

  PROCEDURE delete_ntf_user_message
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      family_name: ost$name,
      message_response: nft$ntf_delete_user_resp_codes,
      operator_connection: ^nft$connection,
      remote_system: ^nft$io_station,
      remote_system_found: boolean,
      remote_system_name: ost$name,
      user_name: ost$name;

*copy nft$ntf_delete_user_msg
*copy nft$ntf_delete_user_resp_codes
?? NEWTITLE := 'crack_delete_user_message', EJECT ??

    PROCEDURE crack_delete_user_message
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR remote_system_name: ost$name;
       VAR family_name: ost$name;
       VAR user_name: ost$name;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        parameter: ^nft$ntf_delete_user_msg,
        value_length: integer;

      status.normal := TRUE;
      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$ntf_remote_system_name =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, remote_system_name);

        = nfc$ntf_family_name =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, family_name);

        = nfc$ntf_user_name =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, user_name);

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_delete_user_message;

?? TITLE := 'send_delete_user_response', EJECT ??

    PROCEDURE send_delete_user_response
      (VAR message: ^nft$message_sequence;
           response_code: nft$ntf_delete_user_resp_codes;
           remote_system_name: ost$name;
           connection: ^nft$connection;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        message_length: nft$message_length,
        message_type: ^nft$message_kind,
        parameter_kind: ^nft$ntf_delete_user_resp,
        parameter_kind_size: nft$message_length,
        param_length_size: nft$message_length,
        parameter_value_length: integer,
        response_param: ^nft$ntf_delete_user_resp_codes;

*copy nft$ntf_delete_user_resp

      status.normal := TRUE;
      parameter_kind_size := #SIZE (nft$ntf_delete_user_resp);
      RESET message;

      NEXT message_type IN message;
      message_type^ := nfc$delete_ntf_user_resp;
      message_length := 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$ntf_remote_system_name;
      parameter_value_length := clp$trimmed_string_size (remote_system_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := remote_system_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$response_code;
      NEXT response_param IN message;
      response_param^ := response_code;
      message_length := message_length + parameter_kind_size + 1;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$null_parameter;
      message_length := message_length + parameter_kind_size;

      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;

    PROCEND send_delete_user_response;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    crack_delete_user_message (message, msg_length, remote_system_name, family_name, user_name, status);
    message_response := nfc$message_accepted;
    find_ntf_remote_system (remote_system_name, remote_system, remote_system_found);
    IF NOT remote_system_found THEN
      message_response := nfc$ntf_remote_system_not_found;
    ELSEIF remote_system^.operator_assigned THEN
      IF remote_system^.connected_operator <> NIL THEN
        operator_connection := remote_system^.connected_operator;
        IF (operator_connection^.family <> family_name) OR (operator_connection^.user <> user_name) THEN
          message_response := nfc$ntf_operator_not_connected;
        IFEND;
      IFEND;
    IFEND;

    IF message_response = nfc$message_accepted THEN
      IF remote_system^.connected_operator <> NIL THEN
        operator_connection := remote_system^.connected_operator;
        operator_connection^.operating_station := NIL;
      IFEND;

      remote_system^.connected_operator := NIL;
      remote_system^.operator_assigned := FALSE;
      remote_system^.station_operational := TRUE;
    IFEND;

    send_delete_user_response (message, message_response, remote_system_name, connection, status);

  PROCEND delete_ntf_user_message;
?? TITLE := 'duplicate aliases', EJECT ??

  FUNCTION duplicate_aliases (alias_names: array [1 .. 3] OF ost$name): boolean;

    duplicate_aliases :=

    ((alias_names [1] <> osc$null_name) AND ((alias_names [1] = alias_names [2]) OR (alias_names [1] =
          alias_names [3])))

    OR

    ((alias_names [2] <> osc$null_name) AND (alias_names [2] = alias_names [3]));

  FUNCEND duplicate_aliases;
?? TITLE := 'delete pointer list entry', EJECT ??

{  PURPOSE:
{    This procedure deletes the pointer list entry from the
{    list in which it is currently linked.

  PROCEDURE delete_pointer_list_entry
    (VAR pointer_list_entry: ^nft$pointer_list_entry);

    VAR
      pointer_list_entry_back_link: ^nft$pointer_list_entry,
      pointer_list_entry_link: ^nft$pointer_list_entry;

    pointer_list_entry_back_link := pointer_list_entry^.back_link;
    pointer_list_entry_link := pointer_list_entry^.link;

    IF pointer_list_entry^.back_link <> NIL THEN
      pointer_list_entry_back_link^.link := pointer_list_entry^.link;
    IFEND;
    IF pointer_list_entry^.link <> NIL THEN
      pointer_list_entry_link^.back_link := pointer_list_entry^.back_link;
    IFEND;

    FREE pointer_list_entry;

    pointer_list_entry := pointer_list_entry_link;

  PROCEND delete_pointer_list_entry;
?? TITLE := 'device_available_for_output', EJECT ??

  FUNCTION device_available_for_output
    (    device: ^nft$batch_device): boolean;

    device_available_for_output := (device^.btfs_di_status = nfc$btfs_di_active) AND

    output_device_or_stream (device) AND

    (device^.file_transfer_status < nfc$busy) AND

    (device^.device_status = nfc$device_active) AND

    (device^.current_file = NIL) AND

    (NOT any_outstanding_di_responses (device^.outstanding_di_responses));

  FUNCEND device_available_for_output;
?? TITLE := 'file and device match', EJECT ??

{  PURPOSE:
{    This procedure determines if the attributes of the output queue file
{    and the attributes of the device are such that the file should be
{    allowed to print at that device.
{    For the file to be assigned to the device, the following rules must be met:
{      - device type of the file = device type
{      - external characteristics of the file = ONE of the external characteristics of the device
{      - forms code of the file = ONE of the forms codes of the device
{      - file size <= maximum file size allowed for the device
{      - at least 1 common protocol stack between SCF/VE and BTFS/DI
{    If the device is a printer, then the following rules must also be met:
{         -  page width of the file  <=  page width of the device
{         -  page length of the file/print density <= forms size of the device
{         -  page length of the file/print density <= maximum page length of the device
{      If the file specifies a VFU load procedure, then:
{         - the VLO for the device must be changeable by the user
{    If the file is queued for NTF, this request is forwarded to the function
{    ntf_file_and_stream_match.

  FUNCTION file_and_device_match
    (    q_file: ^nft$output_queue_file;
         device: ^nft$batch_device): boolean;

    CONST
      divisor = 2;

*copy amt$vertical_print_density

    VAR
      bd_connection: ^nft$connection,
      current_unreachable_btfs_di: ^unreachable_btfs_di,
      device_forms_size: real,
      device_match: boolean,
      device_max_page_length: real,
      device_vpd_values: [STATIC] array [nft$vertical_print_density] OF 6..12 :=
           [{nfc$six_only} 6,       {nfc$eight_only} 8,
            {nfc$six_any}  6,       {nfc$eight_any}  8],
      file_vpd_values: [STATIC] array [nfc$vertical_print_density_6 .. nfc$vertical_print_density_12] OF
            6..12 := [{nfc$vertical_print_density_6} 6, {nfc$vertical_print_density_7} 7,
            {nfc$vertical_print_density_8} 8,           {nfc$vertical_print_density_9} 9,
            {nfc$vertical_print_density_10} 10,         {nfc$vertical_print_density_11} 11,
            {nfc$vertical_print_density_12} 12],
      scfve_connection: ^nft$connection,
      vertical_print_density: amt$vertical_print_density;

    IF q_file^.ios_usage = nfc$ntf_remote_system THEN
      file_and_device_match := ntf_file_and_stream_match (q_file, device);
      RETURN;
    IFEND;

    device_match := (q_file^.device_type = device^.device_type) AND

      ((q_file^.external_characteristics = device^.external_characteristics [1]) OR

      (q_file^.external_characteristics = device^.external_characteristics [2]) OR

      (q_file^.external_characteristics = device^.external_characteristics [3]) OR

      (q_file^.external_characteristics = device^.external_characteristics [4])) AND

      ((q_file^.forms_code = device^.forms_code [1]) OR (q_file^.forms_code = device^.forms_code [2]) OR

      (q_file^.forms_code = device^.forms_code [3]) OR (q_file^.forms_code = device^.forms_code [4]));

    IF device_match AND (device^.maximum_file_size > 0) THEN
      device_match := q_file^.file_size <= device^.maximum_file_size;
    IFEND;

    IF device_match AND (q_file^.output_data_mode = nfc$transparent_mode) THEN
      bd_connection := device^.scfdi_connection;
      device_match := (device^.tip_type = nfc$async_tip) OR
            (device^.tip_type = nfc$hasp_tip) OR (device^.tip_type = nfc$x25_async_tip) OR
            ((device^.tip_type = nfc$uri_tip) AND (bd_connection^.btfs_di_advanced_features = 1));
    IFEND;

    scfve_connection := q_file^.scfve_connection;

    IF device_match THEN
      device_match := ((xns_protocol_stack IN scfve_connection^.btf_ve_protocol_stacks) AND
            (xns_protocol_stack IN device^.btfs_di_protocol_stacks)) OR
            ((osi_protocol_stack IN scfve_connection^.btf_ve_protocol_stacks) AND
            (osi_protocol_stack IN device^.btfs_di_protocol_stacks));
    IFEND;

    IF device_match AND (device^.btfs_di_title.length > 0) THEN
      current_unreachable_btfs_di := scfve_connection^.unreachable_btfs_di_list;
      WHILE device_match AND (current_unreachable_btfs_di <> NIL) DO
        device_match := device^.btfs_di_title <> current_unreachable_btfs_di^.title;
        current_unreachable_btfs_di := current_unreachable_btfs_di^.link;
      WHILEND;
    IFEND;

    IF device_match AND (device^.device_type = nfc$printer) THEN

      device_forms_size := $REAL (device^.forms_size)/$REAL (divisor);
      device_max_page_length := $REAL (device^.maximum_page_length);

      IF (q_file^.vertical_print_density <> nfc$vertical_print_density_none) THEN
        vertical_print_density := file_vpd_values [q_file^.vertical_print_density];
      ELSE  {user wishes file to print at the device's print density}
        vertical_print_density := device_vpd_values [device^.vertical_print_density];
      IFEND;

      device_match := (q_file^.page_width <= device^.page_width) AND
            ($REAL(q_file^.page_length)/$REAL(vertical_print_density) <= device_forms_size);
      device_match := device_match AND ($REAL(q_file^.page_length)/$REAL(vertical_print_density)
             <= device_max_page_length);

      IF device_match THEN
        IF (vertical_print_density = 6) THEN
          device_match := (device^.vertical_print_density = nfc$six_only) OR
                (device^.vertical_print_density = nfc$six_any) OR
                (device^.vertical_print_density = nfc$eight_any);
        ELSEIF(vertical_print_density = 8) THEN
          device_match := (device^.vertical_print_density = nfc$eight_only) OR
                (device^.vertical_print_density = nfc$six_any) OR
                (device^.vertical_print_density = nfc$eight_any);
        ELSE
          device_match := FALSE;
        IFEND;
      IFEND;

      IF device_match AND (q_file^.vfu_load_procedure <> osc$null_name) THEN
        device_match := (device^.vfu_load_option = nfc$vfu_changeable_by_user);
      IFEND;

    IFEND;
    file_and_device_match := device_match;

  FUNCEND file_and_device_match;
?? TITLE := 'file assignment response', EJECT ??

{  PURPOSE:
{    This procedure is executed when a response is received from SCF/VE to
{    a file assignment message sent by SCFS.  If the response indicates a
{    rejection to the file assignment, SCFS removes the file assignment and
{    attempts to assign another file to the device.
{
{    This procedure is also executed when a response is received from NTF/VE to
{    a file assignment message sent by SCFS.  If the response indicates a
{    rejection to the file assignment, SCFS removes the file assignment and
{    attempts to assign another file to the NTF batch stream.

  PROCEDURE file_assignment_response
    (VAR message: ^nft$message_sequence;
     VAR wait_list: ^ost$i_wait_list;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      file_name: ost$name,
      queue_pointer: ^nft$output_queue_file,
      queue_file: ^nft$output_queue_file,
      response_code: nft$file_assignment_response,
      scfve_connection: ^nft$connection;

*copyc nft$file_assignment_resp_msg
?? NEWTITLE := 'crack file assignment response', EJECT ??

    PROCEDURE crack_file_assignment_response
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR io_station_name: ost$name;
       VAR file_name: ost$name;
       VAR response_code: nft$file_assignment_response;
       VAR device_name: ost$name;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        parameter: ^nft$file_assign_resp_parameter,
        resp_code: ^nft$file_assignment_response,
        value_length: integer;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, io_station_name);

        = nfc$system_file_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, file_name);

        = nfc$response_code =
          NEXT resp_code IN message;
          response_code := resp_code^;

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, device_name);

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_file_assignment_response;
?? OLDTITLE, EJECT ??

    crack_file_assignment_response (message, msg_length, io_station_name, file_name, response_code,
          device_name, status);

    IF response_code <> nfc$file_assignment_accepted THEN
      find_io_station (io_station_name, io_station, io_station_found);
      IF NOT io_station_found THEN
        find_ntf_remote_system (io_station_name, io_station, io_station_found);
      IFEND;

      IF io_station_found THEN
        find_batch_device (device_name, io_station, device, device_found);
        IF device_found THEN
          queue_file := device^.current_file;
          IF queue_file <> NIL THEN
            queue_file^.assigned_device := NIL;
            device^.current_file := NIL;

            IF response_code = nfc$btfsdi_title_not_translated THEN
              queue_file^.output_state := nfc$eligible_for_transfer;
              scfve_connection := queue_file^.scfve_connection;
              add_unreachable_btfs_di (device^.btfs_di_title, scfve_connection, wait_list);
            ELSE
              queue_file^.output_state := nfc$not_eligible_for_transfer;
            IFEND;

            IF device_available_for_output (device) THEN
              find_file_for_device (device, message, status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND file_assignment_response;
?? TITLE := 'find batch device', EJECT ??

  PROCEDURE find_batch_device
    (    device_name: ost$name;
         io_station: ^nft$io_station;
     VAR device: ^nft$batch_device;
     VAR device_found: boolean);

    device := io_station^.batch_device_list;
    device_found := FALSE;

    WHILE NOT device_found AND (device <> NIL) DO
      device_found := device^.name = device_name;
      IF NOT device_found THEN
        device := device^.link;
      IFEND;
    WHILEND;

  PROCEND find_batch_device;
?? TITLE := 'find file for device', EJECT ??

{  PURPOSE:
{    This procedure determines if the attributes of the output queue file
{    and the attributes of the device are such that the file should be
{    allowed to print at that device.
{
{    This procedure also determines if the attributes of the NTF queue file and
{    the attributes of the batch stream are such that the file should be sent
{    to that batch stream.

  PROCEDURE find_file_for_device
    (    device: ^nft$batch_device;
     VAR message: ^nft$message_sequence;
     VAR status: ost$status);

    VAR
      alias_entry: ^nft$alias,
      connection: ^nft$connection,
      current_file_priority: nft$priority,
      current_time: ost$date_time,
      index: 0 .. 4,
      io_station: ^nft$io_station,
      matching_file_priority: nft$priority,
      matching_q_file: ^nft$output_queue_file,
      more_aliases: boolean,
      ntf_acc_remote_system_ptr: ^nft$pointer_list_entry,
      null_alias: boolean,
      q_file: ^nft$output_queue_file,
      use_intial_priority: boolean;

?? NEWTITLE := 'check_selected_files_q_for_file', EJECT ??

    PROCEDURE check_selected_files_q_for_file
      (    io_station: ^nft$io_station;
           device: ^nft$batch_device;
       VAR matching_q_file: ^nft$output_queue_file);

      VAR
        q_file: ^nft$output_queue_file,
        selected_file: ^nft$selected_file;

      matching_q_file := NIL;

      q_file := NIL;
      selected_file := io_station^.selected_files_queue;
      WHILE selected_file <> NIL DO
        q_file := selected_file^.output_file;
        IF (q_file^.output_state = nfc$eligible_for_transfer) AND
              ((selected_file^.device_selected = device^.name) OR
              (((q_file^.device_name = osc$null_name) OR (q_file^.device_name = automatic) OR
              (q_file^.device_name = device^.name) OR (q_file^.device_name = device^.alias_names [1]) OR
              (q_file^.device_name = device^.alias_names [2]) OR
              (q_file^.device_name = device^.alias_names [3])) AND
              file_and_device_match (q_file, device))) THEN
          matching_q_file := q_file;
          RETURN;
        IFEND;
        selected_file := selected_file^.link;
      WHILEND;

    PROCEND check_selected_files_q_for_file;
?? OLDTITLE, EJECT ??
    IF NOT any_outstanding_di_responses (device^.outstanding_di_responses) THEN
      matching_file_priority := 0;
      matching_q_file := NIL;
      io_station := device^.io_station;
      pmp$get_compact_date_time (current_time, status);
      use_intial_priority := NOT status.normal;
      IF io_station^.usage <> nfc$ntf_remote_system THEN
        IF io_station^.selected_files_queue <> NIL THEN
          check_selected_files_q_for_file (io_station, device, matching_q_file);
        IFEND;
        IF matching_q_file <> NIL THEN
          more_aliases := FALSE;
        ELSE
          index := 0;
          more_aliases := TRUE;
        IFEND;
      ELSE
        ntf_acc_remote_system_ptr := io_station^.ntf_acc_remote_system_ptr_list;
        check_for_ntf_signed_on_stream (io_station, device, more_aliases);
        more_aliases := more_aliases AND (ntf_acc_remote_system_ptr <> NIL);
      IFEND;

      WHILE more_aliases DO
        IF io_station^.usage <> nfc$ntf_remote_system THEN
          null_alias := io_station^.alias_list [index] = NIL;
        ELSE
          null_alias := FALSE;
        IFEND;

        IF NOT null_alias THEN
          IF io_station^.usage <> nfc$ntf_remote_system THEN
            alias_entry := io_station^.alias_list [index];
          ELSE
            alias_entry := ntf_acc_remote_system_ptr^.ntf_acc_remote_system;
          IFEND;

          IF alias_entry^.queue <> NIL THEN
            q_file := alias_entry^.queue;
            WHILE q_file <> NIL DO
              IF (q_file^.output_state = nfc$eligible_for_transfer) AND ((q_file^.device_name = osc$null_name)
                    OR (q_file^.device_name = automatic) OR (q_file^.device_name = device^.name) OR (q_file^.
                    device_name = device^.alias_names [1]) OR (q_file^.device_name = device^.alias_names [2])
                    OR (q_file^.device_name = device^.alias_names [3])) AND (file_and_device_match (q_file,
                    device)) THEN
                IF use_intial_priority THEN
                  current_file_priority := q_file^.initial_priority;
                ELSE
                  current_file_priority := calculate_priority (q_file, current_time);
                IFEND;
                IF current_file_priority > matching_file_priority THEN
                  matching_q_file := q_file;
                  matching_file_priority := current_file_priority;
                IFEND;
              IFEND;
              q_file := q_file^.link;
            WHILEND;
          IFEND;
        IFEND;

        IF io_station^.usage <> nfc$ntf_remote_system THEN
          index := index + 1;
          more_aliases := index <= 3;
        ELSE
          ntf_acc_remote_system_ptr := ntf_acc_remote_system_ptr^.link;
          more_aliases := ntf_acc_remote_system_ptr <> NIL;
        IFEND;
      WHILEND;

      IF matching_q_file <> NIL THEN
        matching_q_file^.output_state := nfc$selected_for_transfer;
        matching_q_file^.assigned_device := device;
        device^.current_file := matching_q_file;
        connection := matching_q_file^.scfve_connection;
        send_file_assignment_msg (message, io_station^.name, matching_q_file^, device, connection,
               status);
      IFEND;
    IFEND;

  PROCEND find_file_for_device;
?? TITLE := 'find_files_for_ntf_logical_line', EJECT ??

{  PURPOSE:
{    This procedure checks each batch stream on an NTF logical line to see if
{    if the attributes of an NTF queue file and the attributes of the batch
{    stream are such that the file should be sent to that batch stream.

  PROCEDURE find_files_for_ntf_logical_line
    (    remote_system: ^nft$io_station;
         logical_line_number: nft$ntf_logical_line_number;
     VAR message: ^nft$message_sequence;
     VAR status: ost$status);

    VAR
      batch_stream: ^nft$batch_device;

    status.normal := TRUE;
    batch_stream := remote_system^.batch_device_list;
    WHILE batch_stream <> NIL DO
      IF batch_stream^.ntf_logical_line_number = logical_line_number THEN
        IF device_available_for_output (batch_stream) THEN
          find_file_for_device (batch_stream, message, status);
        IFEND;
      IFEND;

      batch_stream := batch_stream^.link;
    WHILEND;
  PROCEND find_files_for_ntf_logical_line;
?? TITLE := 'find io station', EJECT ??

{  PURPOSE:
{    This procedure finds a station name within the list of IO stations.
{    A pointer to the I/O station is returned if the station name is found.

  PROCEDURE find_io_station
    (    io_station_name: ost$name;
     VAR station: ^nft$io_station;
     VAR station_found: boolean);

    station := scfs_tables.first_io_station;
    station_found := FALSE;

    WHILE NOT station_found AND (station <> NIL) DO
      station_found := station^.name = io_station_name;
      IF NOT station_found THEN
        station := station^.link;
      IFEND;
    WHILEND;

  PROCEND find_io_station;
?? TITLE := 'find_io_station_alias', EJECT ??

{  PURPOSE:
{    This procedure finds a station name within the list of IO station aliases.
{    A pointer to the station alias is returned if the station name is found.

  PROCEDURE find_io_station_alias
    (    io_station_name: ost$name;
     VAR ios_alias: ^nft$alias;
     VAR alias_found: boolean);

    ios_alias := scfs_tables.first_station_name_alias;
    alias_found := FALSE;
    WHILE NOT alias_found AND (ios_alias <> NIL) DO
      alias_found := ios_alias^.name = io_station_name;
      IF NOT alias_found THEN
        ios_alias := ios_alias^.link;
      IFEND;
    WHILEND;

  PROCEND find_io_station_alias;
?? TITLE := 'find_io_station_or_remote_system', EJECT ??

{  PURPOSE:
{    This procedure finds a station name within the list of IO stations or
{    within the list of NTF remote systems.  A pointer to the station or remote
{    system is returned if the station name is found.

  PROCEDURE find_io_station_or_remote_sys
    (    io_station_name: ost$name;
         connection: ^nft$connection;
     VAR station: ^nft$io_station;
     VAR station_found: boolean);

{ Do not search for an IO station if the request comes from a connection that
{ is only used by NTF such as NTF/VE or OPERATE_NTF.

    IF (connection^.kind <> nfc$ntfve_connection) AND (connection^.kind <> nfc$ntf_operator_connection) THEN
      find_io_station (io_station_name, station, station_found);
      IF station_found THEN
        RETURN;
      IFEND;
    IFEND;

{ Do not search for an NTF remote system if the request comes from a connection
{ that is never used by NTF such as SCF/VE or OPERATE_STATION.

    IF (connection^.kind <> nfc$scfve_connection) AND (connection^.kind <> nfc$operator_connection) THEN
      find_ntf_remote_system (io_station_name, station, station_found);
    IFEND;

  PROCEND find_io_station_or_remote_sys;
?? TITLE := 'find_ntf_acc_remote_system', EJECT ??

{  PURPOSE:
{    This procedure finds an accessible remote system in the list of accessible
{    remote systems known to SCFS.  If the specified accessible remote system
{    is not found, a pointer to the null alias is returned.

  PROCEDURE find_ntf_acc_remote_system
    (    acc_remote_system_name: ost$name;
     VAR acc_remote_system: ^nft$alias);

?? NEWTITLE := 'search_acc_remote_system_list', EJECT ??

    PROCEDURE search_acc_remote_system_list
      (    acc_remote_system_name: ost$name;
           first_acc_remote_system: ^cell;
       VAR acc_remote_system: ^nft$alias);

      VAR
        temp: integer,
        acc_remote_system_found: boolean,
        acc_remote_system_list: ^array [1 .. nfc$ntf_max_remote_systems] of nft$alias,
        current: nft$ntf_remote_system_count,
        first: nft$ntf_remote_system_count,
        last: nft$ntf_remote_system_count;

      acc_remote_system_list := first_acc_remote_system;
      first := 1;
      last := scfs_tables.ntf_acc_remote_system_count;
      acc_remote_system_found := FALSE;
      WHILE (first <= last) AND (NOT acc_remote_system_found) DO
        temp := first + last;
        current := temp DIV 2;
        IF acc_remote_system_name < acc_remote_system_list^ [current].name THEN
          last := current - 1;
        ELSEIF acc_remote_system_name > acc_remote_system_list^ [current].name THEN
          first := current + 1;
        ELSE
          acc_remote_system_found := TRUE;
        IFEND;
      WHILEND;

      IF acc_remote_system_found THEN
        acc_remote_system := ^acc_remote_system_list^ [current];
      ELSE
        acc_remote_system := NIL;
      IFEND;

    PROCEND search_acc_remote_system_list;

?? OLDTITLE, EJECT ??

    search_acc_remote_system_list (acc_remote_system_name, scfs_tables.first_ntf_acc_remote_system,
          acc_remote_system);

  PROCEND find_ntf_acc_remote_system;
?? TITLE := 'find_ntf_client_connection', EJECT ??

{  PURPOSE:
{    This procedure finds an NTF client connection based on the NTF system
{    identifier.  If the specified client connection is not found, a null
{    pointer is returned.

  PROCEDURE find_ntf_client_connection
    (    ntf_system_identifier: nft$ntf_system_identifier;
     VAR connection: ^nft$connection);

    VAR
      connection_found: boolean;

    connection_found := FALSE;
    connection := scfs_tables.first_connection;
    WHILE (NOT connection_found) AND (connection <> NIL)
          DO
      connection_found := ((connection^.kind = nfc$ntfve_connection) AND (ntf_system_identifier (1,
            nfc$ntf_model_and_sn_size) = connection^.ntf_system_identifier (1, nfc$ntf_model_and_sn_size)));
      IF NOT connection_found THEN
        connection := connection^.link;
      IFEND;
    WHILEND;

  PROCEND find_ntf_client_connection;
?? TITLE := 'find_ntf_logical_line', EJECT ??

{  PURPOSE:
{    This procedure finds a logical line in the list of logical lines known to
{    a remote system.  If the specified logical line is not found, a pointer to
{    the last logical line in the list is returned.

  PROCEDURE find_ntf_logical_line
    (    logical_line_number: nft$ntf_logical_line_number;
         remote_system: ^nft$io_station;
     VAR logical_line: ^nft$ntf_logical_line;
     VAR logical_line_found: boolean);

    VAR
      last_logical_line: ^nft$ntf_logical_line;

    logical_line := remote_system^.ntf_logical_line_list;
    last_logical_line := logical_line;
    logical_line_found := FALSE;
    WHILE (NOT logical_line_found) AND (logical_line <> NIL) DO
      logical_line_found := logical_line_number = logical_line^.logical_line_number;
      IF NOT logical_line_found THEN
        last_logical_line := logical_line;
        logical_line := logical_line^.link;
      IFEND;
    WHILEND;

    IF NOT logical_line_found THEN
      logical_line := last_logical_line;
    IFEND;

  PROCEND find_ntf_logical_line;
?? TITLE := 'find_ntf_remote_queue', EJECT ??

{  PURPOSE:
{    This procedure searches the accessible remote system list for the
{    specified destination name.  If it is found, pointers to the queue file
{    and the queue list are returned.  If it is not found, the pointers are set
{    to null.

  PROCEDURE find_ntf_remote_queue
    (    destination_name: ost$name;
     VAR queue_pointer: ^^nft$output_queue_file; {!!}
     VAR remote_system_list: ^nft$pointer_list_entry);

    VAR
      destination: ^nft$alias,
      q_found: boolean;

    q_found := FALSE;
    queue_pointer := NIL;
    remote_system_list := NIL;
    destination := scfs_tables.first_ntf_acc_remote_system;
    WHILE (NOT q_found) AND (destination <> NIL) DO
      q_found := (destination^.name = destination_name);
      IF q_found THEN
        queue_pointer := ^destination^.queue;
        remote_system_list := destination^.station_list;
      ELSE
        destination := destination^.link;
      IFEND;
    WHILEND;

  PROCEND find_ntf_remote_queue;
?? TITLE := 'find_ntf_remote_system', EJECT ??

{  PURPOSE:
{    This procedure finds a remote system in the list of remote systems known
{    to SCFS.  If the specified remote system is not found, a pointer to the
{    last remote system in the list is returned.

  PROCEDURE find_ntf_remote_system
    (    remote_system_name: ost$name;
     VAR remote_system: ^nft$io_station;
     VAR remote_system_found: boolean);

    VAR
      last_remote_system: ^nft$io_station;

    remote_system := scfs_tables.first_ntf_remote_system;
    last_remote_system := remote_system;
    remote_system_found := FALSE;
    WHILE (NOT remote_system_found) AND (remote_system <> NIL) DO
      remote_system_found := remote_system_name = remote_system^.name;
      IF NOT remote_system_found THEN
        last_remote_system := remote_system;
        remote_system := remote_system^.link;
      IFEND;
    WHILEND;

    IF NOT remote_system_found THEN
      remote_system := last_remote_system;
    IFEND;

  PROCEND find_ntf_remote_system;
?? TITLE := 'find_ntf_remote_system_pointer', EJECT ??

{  PURPOSE:
{    This procedure finds a remote system pointer in the list of remote system
{    pointers known to an accessible remote system.  A specific logical line of
{    the remote system can be optionally specified.  If the specified remote
{    system pointer is not found, a pointer to the last remote system pointer
{    in the list is returned.

  PROCEDURE find_ntf_remote_system_pointer
    (    remote_system_name: ost$name;
         check_logical_line_number: boolean;
         logical_line_number: nft$ntf_logical_line_number;
         acc_remote_system: ^nft$alias;
     VAR remote_system_ptr: ^nft$pointer_list_entry;
     VAR remote_system_ptr_found: boolean);

    VAR
      last_remote_system_ptr: ^nft$pointer_list_entry,
      remote_system: ^nft$io_station;

    remote_system_ptr := acc_remote_system^.station_list;
    last_remote_system_ptr := remote_system_ptr;
    remote_system_ptr_found := FALSE;
    WHILE (NOT remote_system_ptr_found) AND (remote_system_ptr <> NIL) DO
      remote_system := remote_system_ptr^.ntf_remote_system;
      remote_system_ptr_found := remote_system_name = remote_system^.name;
      IF check_logical_line_number AND remote_system_ptr_found THEN
        remote_system_ptr_found := (logical_line_number = remote_system_ptr^.ntf_logical_line_number);
      IFEND;

      IF NOT remote_system_ptr_found THEN
        last_remote_system_ptr := remote_system_ptr;
        remote_system_ptr := remote_system_ptr^.link;
      IFEND;
    WHILEND;

    IF NOT remote_system_ptr_found THEN
      remote_system_ptr := last_remote_system_ptr;
    IFEND;

  PROCEND find_ntf_remote_system_pointer;
?? TITLE := 'find private queue', EJECT ??

{  PURPOSE:
{    This procedure finds a private queue.  The "private queue" is said
{    to be found when an operator is currently in control of the station,
{    the specified operator name matches the operator currently in control
{    and the specified operator family matches the family of the operator
{    currently in control of the station.

  PROCEDURE find_private_queue
   (    operator_name: ost$name;
        operator_family: ost$name;
    VAR queue_pointer: ^^nft$output_queue_file;
    VAR station_list: ^nft$pointer_list_entry;
    VAR q_found: boolean);

    VAR
      alias_entry: ^nft$alias,
      alias_found: boolean,
      connection: ^nft$connection,
      io_station: ^nft$io_station;

    connection := scfs_tables.first_connection;

    q_found := FALSE;
    WHILE (NOT q_found) AND (connection <> NIL) DO
      q_found := (connection^.kind = nfc$operator_connection) AND (connection^.user = operator_name) AND
            (connection^.family = operator_family);
      IF q_found THEN
        io_station := connection^.operating_station;
        q_found := io_station^.usage = nfc$private_io_station;
      IFEND;
      IF q_found THEN
        alias_entry := io_station^.alias_list [0];
        queue_pointer := ^alias_entry^.queue;
        station_list := alias_entry^.station_list;
      ELSE
        connection := connection^.link;
      IFEND;
    WHILEND;

  PROCEND find_private_queue;
?? TITLE := 'find public queue', EJECT ??

{  PURPOSE:
{    This procedure searches the station name alias list for the specified
{    destination name.  If it is found, a pointer to the queue list is returned.

  PROCEDURE find_public_queue
    (    destination_name: ost$name;
     VAR queue_pointer: ^^nft$output_queue_file;
     VAR station_list: ^nft$pointer_list_entry;
     VAR q_found: boolean);

    VAR
      destination: ^nft$alias;

    q_found := FALSE;
    destination := scfs_tables.first_station_name_alias;
    WHILE NOT q_found AND (destination <> NIL) DO
      q_found := destination^.name = destination_name;
      IF q_found THEN
        queue_pointer := ^destination^.queue;
        station_list := destination^.station_list;
      ELSE
        destination := destination^.link;
      IFEND;
    WHILEND;

  PROCEND find_public_queue;
?? TITLE := 'find q file', EJECT ??

{  PURPOSE:
{    This procedure searches the specified queue list for the given queue
{    file name.  If the file name is found, a pointer to the queue file is
{    returned.

  PROCEDURE find_q_file
    (    file_name: ost$name;
         queue_list:^ nft$output_queue_file;
     VAR q_file: ^nft$output_queue_file);

    VAR
      file_found: boolean;

    file_found := FALSE;
    q_file := queue_list;
    WHILE NOT file_found AND (q_file <> NIL) DO
      file_found := file_name = q_file^.system_file_name;
      IF NOT file_found THEN
        q_file := q_file^.link;
      IFEND;
    WHILEND;

  PROCEND find_q_file;
?? TITLE := 'find_station_and_selected_file', EJECT ??

{  PURPOSE:
{    This procedure finds the station that has the desired file in its selected
{    files queue.  It returns the station and the selected file.

  PROCEDURE find_station_and_selected_file
    (    file_name: ost$name;
     VAR io_station: ^nft$io_station;
     VAR selected_file: ^nft$selected_file);

    VAR
      output_file: ^nft$output_queue_file;

    selected_file := NIL;
    io_station := scfs_tables.first_io_station;

  /io_station_loop/
    WHILE io_station <> NIL DO
      IF io_station^.selected_files_queue <> NIL THEN
        selected_file := io_station^.selected_files_queue;

      /selected_files_queue_loop/
        WHILE selected_file <> NIL DO
          output_file := selected_file^.output_file;
          IF file_name = output_file^.system_file_name THEN
            EXIT /io_station_loop/;
          IFEND;
          selected_file := selected_file^.link;
        WHILEND /selected_files_queue_loop/ ;
      IFEND;
      io_station := io_station^.link;
    WHILEND /io_station_loop/;

  PROCEND find_station_and_selected_file;
?? TITLE := 'get device status msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from OPES for
{    detailed status information on a specified device.  If the station and
{    device specified are found, the device information is sent back in the
{    response message, otherwise a negative response code is sent back to OPES.
{
{    This procedure is also executed when a request is received from OPENTF for
{    detailed status information on a specified batch stream.  If the remote
{    system and batch stream specified are found, the stream information is
{    sent back in the response message, otherwise a negative response code is
{    sent back to OPENTF.

  PROCEDURE get_device_status_msg
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      fake_device: nft$batch_device,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      msg_length: integer,
      parameter: ^nft$get_device_status_param,
      response: nft$display_status_resp_codes,
      value_length: integer;

*copy nft$get_device_status_msg

    msg_length := 0;
    response := nfc$disp_msg_accepted;

{   Since Get Device Status has only 2 parameters, this is all that is needed.
    NEXT parameter IN message;
    IF parameter^.length_indicated THEN
      nfp$get_parameter_value_length (message, msg_length, value_length, status);
    ELSE
      value_length := 1;
    IFEND;
    NEXT ascii_string: [value_length] IN message;
    #translate (osv$lower_to_upper, ascii_string^, io_station_name);

    NEXT parameter IN message;
    IF parameter^.length_indicated THEN
      nfp$get_parameter_value_length (message, msg_length, value_length, status);
    ELSE
      value_length := 1;
    IFEND;
    NEXT ascii_string: [value_length] IN message;
    #translate (osv$lower_to_upper, ascii_string^, device_name);

    find_io_station_or_remote_sys (io_station_name, connection, io_station, io_station_found);
    IF io_station_found THEN
      find_batch_device (device_name, io_station, device, device_found);
      IF NOT device_found THEN
        response := nfc$disp_no_batch_device;
      IFEND;
    ELSE
      response := nfc$disp_no_io_station;
    IFEND;

    IF response <> nfc$disp_msg_accepted THEN
      fake_device.name := device_name;
      device := ^fake_device;
    IFEND;

    send_device_status_msg (message, response, io_station, device, connection, {optimize} FALSE,
         status);

  PROCEND get_device_status_msg;
?? TITLE := 'get new connection', EJECT ??

{  PURPOSE:
{    This procedure is executed in response to a connection request by another
{    process executing within the CDNA system (e.g. SCF/DI, SCF/VE , NTF/VE,
{    OPES, or OPENTF).

  PROCEDURE get_new_connection
   (VAR wait_list: ^ost$i_wait_list;
    VAR wait_connection_list: ^nft$wait_connection_list;
    VAR message: ^nft$message_sequence;
    VAR status: ost$status);

    VAR
      attributes: ^nat$create_attributes,
      cf: ^ost$name,
      connect_file: ^fst$file_reference,
      connect_file_identifier: amt$file_identifier,
      connection: ^nft$connection,
      ignore_status: ost$status,
      index: integer,
      known_connection: boolean,
      mandated_attributes: [STATIC, READ] array [1 .. 1] of fst$file_cycle_attribute :=
            [[fsc$file_organization, amc$sequential]],
      temporary_connection: nft$connection,
      unique_name: ost$name,
      wait_time: 0 .. 0ffffffff(16);

?? NEWTITLE := 'add connection to list', EJECT ??

    PROCEDURE add_connection_to_list
      (    connect_file: string ( * );
           connect_file_identifier: amt$file_identifier;
           connection: nft$connection;
       VAR current_connection: ^nft$connection);

      VAR
        new_connection: ^nft$connection,
        next_ntf_operator: ^nft$connection;

      ALLOCATE new_connection;
      new_connection^ := connection;

      current_connection := scfs_tables.first_connection;
      IF scfs_tables.first_connection <> NIL THEN

      /find_last_connection/
        WHILE current_connection^.link <> NIL DO
          current_connection := current_connection^.link;
        WHILEND /find_last_connection/;
      IFEND;

      IF scfs_tables.first_connection = NIL THEN
        scfs_tables.first_connection := new_connection;
        new_connection^.back_link := NIL;
      ELSE
        current_connection^.link := new_connection;
        new_connection^.back_link := current_connection;
      IFEND;

      current_connection := new_connection;
      current_connection^.file_name := connect_file;
      current_connection^.id := connect_file_identifier;
      current_connection^.link := NIL;
      IF current_connection^.kind = nfc$ntf_operator_connection THEN
        scfs_tables.first_ntf_operator := current_connection;
        IF current_connection^.next_ntf_operator <> NIL THEN
          next_ntf_operator := current_connection^.next_ntf_operator;
          next_ntf_operator^.prior_ntf_operator := current_connection;
        IFEND;
      IFEND;

    PROCEND add_connection_to_list;
?? TITLE := 'add to wait list', EJECT ??

    PROCEDURE add_to_wait_list
      (    connection: ^nft$connection;
       VAR wait_list: ^ost$i_wait_list;
       VAR wait_connection_list: ^nft$wait_connection_list);

      VAR
        i: integer,
        temp_seq: ^SEQ ( * ),
        temp_wait_list: ^ost$i_wait_list,
        temp_wait_connection_list: ^nft$wait_connection_list,
        wait_list_limit: integer;

      wait_list_limit := UPPERBOUND (wait_list^);
      IF (wait_list_limit MOD nfc$wait_list_limit) <> 0 THEN
        RESET wait_list_seq;
        NEXT wait_list: [1 .. (wait_list_limit + 1)] IN wait_list_seq;
        RESET wait_connection_list_seq;
        NEXT wait_connection_list: [wait_connection_list_lowest .. (wait_list_limit + 1)]
              IN wait_connection_list_seq;
      ELSE
        ALLOCATE temp_seq: [[REP (wait_list_limit + nfc$wait_list_limit) OF ost$i_activity]];
        RESET temp_seq;
        NEXT temp_wait_list: [1 .. (wait_list_limit + 1)] IN temp_seq;
        FOR i := 1 TO wait_list_limit DO
          temp_wait_list^ [i] := wait_list^ [i];
        FOREND;
        FREE wait_list_seq;
        wait_list_seq := temp_seq;
        wait_list := temp_wait_list;

        ALLOCATE temp_seq: [[REP (wait_list_limit + nfc$wait_list_limit) OF ost$i_activity]];
        RESET temp_seq;
        NEXT temp_wait_connection_list: [wait_connection_list_lowest .. (wait_list_limit + 1)] IN temp_seq;
        FOR i := wait_connection_list_lowest TO wait_list_limit DO
          temp_wait_connection_list^ [i] := wait_connection_list^ [i];
        FOREND;
        FREE wait_connection_list_seq;
        wait_connection_list_seq := temp_seq;
        wait_connection_list := temp_wait_connection_list;
      IFEND;

      wait_list^ [wait_list_limit + 1].activity := nac$i_await_data_available;
      wait_list^ [wait_list_limit + 1].file_identifier := connection^.id;
      wait_connection_list^ [wait_list_limit + 1] := connection;
      connection^.wait_list_index := wait_list_limit + 1;

    PROCEND add_to_wait_list;
?? TITLE := 'get client call data', EJECT ??

    PROCEDURE get_client_call_data
      (    connect_file: string ( * );
       VAR connection: nft$connection;
       VAR status: ost$status);

      VAR
        client_identifier: ^nft$scfs_client_identifier,
        peer_attributes: ^nat$get_attributes;

      status.normal := TRUE;

      PUSH peer_attributes: [1 .. 2];
      peer_attributes^ [1].kind := nac$peer_address;
      peer_attributes^ [2].kind := nac$peer_connect_data;
      PUSH peer_attributes^ [2].peer_connect_data: [[REP 512 OF cell]];

      nap$get_attributes (connect_file, peer_attributes^, status);
      IF status.normal THEN
        IF (peer_attributes^ [1].peer_address.kind = nac$internet_address) OR
              (peer_attributes^ [1].peer_address.kind = nac$osi_transport_address) THEN
          connection.peer_address := peer_attributes^ [1].peer_address;
        IFEND;
        RESET peer_attributes^ [2].peer_connect_data;
        NEXT client_identifier: [peer_attributes^ [2].peer_connect_data_length - 1] IN peer_attributes^ [2].
              peer_connect_data;

        IF client_identifier^.data_version <> nfc$scfs_client_data_version THEN
          status.normal := FALSE;
        ELSEIF client_identifier^.identifier = nfc$scf_di_client THEN
          connection.kind := nfc$scfdi_connection;
          connection.btfs_di_status := nfc$btfs_di_down;
          connection.btfs_di_title.length := 0;
          connection.btfs_di_title.title := ' ';
          connection.btfs_di_protocol_stacks := $protocol_stacks_set [xns_protocol_stack];
          connection.btfs_di_advanced_features := 0;
        ELSEIF client_identifier^.identifier = nfc$scf_ve_client THEN
          connection.kind := nfc$scfve_connection;
          connection.scfve_queue := NIL;
          connection.ntf_system_identifier := nfc$ntf_blank_system_identifier;
          connection.btf_ve_protocol_stacks := $protocol_stacks_set [xns_protocol_stack];
          connection.btf_ve_status_received := FALSE;
          connection.unreachable_btfs_di_list := NIL;
        ELSEIF client_identifier^.identifier = nfc$opes_ve_client THEN
          connection.kind := nfc$operator_connection;
          connection.user := osc$null_name;
          connection.family := osc$null_name;
          connection.ntf_operator_identifier := nfc$ntf_blank_system_identifier;
          connection.operating_station := NIL;
          connection.accept_messages := FALSE;
          connection.prior_ntf_operator := NIL;
          connection.next_ntf_operator := NIL;
        ELSEIF client_identifier^.identifier = nfc$scfs_ve_client THEN
          connection.kind := nfc$scfsve_connection;
        ELSEIF client_identifier^.identifier (1, nfc$opentf_ve_client_length) = nfc$opentf_ve_client THEN
          connection.kind := nfc$ntf_operator_connection;
          connection.user := osc$null_name;
          connection.family := osc$null_name;
          connection.ntf_operator_identifier := client_identifier^.identifier (nfc$opentf_ve_client_length +
                1, nfc$ntf_system_identifier_size);
          connection.operating_station := NIL;
          connection.accept_messages := FALSE;
          connection.prior_ntf_operator := NIL;
          connection.next_ntf_operator := scfs_tables.first_ntf_operator;
        ELSEIF client_identifier^.identifier (1, nfc$ntf_ve_client_length) = nfc$ntf_ve_client THEN
          connection.kind := nfc$ntfve_connection;
          connection.scfve_queue := NIL;
          connection.ntf_system_identifier := client_identifier^.identifier (nfc$ntf_ve_client_length + 1,
                nfc$ntf_system_identifier_size);
          connection.btf_ve_protocol_stacks := $protocol_stacks_set [xns_protocol_stack];
          connection.btf_ve_status_received := FALSE;
          connection.unreachable_btfs_di_list := NIL;
        ELSE
          status.normal := FALSE;
        IFEND;
      IFEND;

    PROCEND get_client_call_data;
?? TITLE := 'search connection list', EJECT ??

    PROCEDURE search_connection_list
     (    connection: nft$connection;
      VAR known_connection: boolean;
      VAR connection_index: integer);

      VAR
        current_connection: ^nft$connection;

      known_connection := FALSE;

      IF (connection.kind <> nfc$operator_connection) AND (connection.kind <> nfc$ntf_operator_connection)
            THEN
        current_connection := scfs_tables.first_connection;

      /search_for_connection/
        WHILE (current_connection <> NIL)
              AND (NOT known_connection) DO

          known_connection := ((connection.kind = current_connection^.kind) AND
                nfp$network_addresses_match (connection.peer_address, current_connection^.peer_address));

          IF known_connection THEN
            connection_index := current_connection^.wait_list_index;
          ELSE
            current_connection := current_connection^.link;
          IFEND;

        WHILEND;

      IFEND;

    PROCEND search_connection_list;

?? OLDTITLE, EJECT ??

{   If there is no connection the SCFS can wait for a connection.

    IF scfs_tables.first_connection = NIL THEN
      wait_time := 0fff(16);
    ELSE
      wait_time := 0;
    IFEND;

    pmp$get_unique_name (unique_name, status);
    connect_file := ^unique_name;

    PUSH attributes: [1 .. 1];
    attributes^ [1].kind := nac$connect_data;
    PUSH attributes^ [1].connect_data: [[REP osc$max_name_size OF cell]];
    RESET attributes^ [1].connect_data;
    NEXT cf IN attributes^ [1].connect_data;
    cf^ := control_facility_name;

{  Request ownership of the connections which have been assigned to the
{  server application.

    nap$acquire_connection (server_name, connect_file^, attributes, wait_time, status);
    IF status.normal THEN

{  Open the file which will identify the connection end point.  }

      fsp$open_file (unique_name, amc$record, NIL, NIL, NIL, ^mandated_attributes, NIL,
            connect_file_identifier, status);
      IF status.normal THEN
        get_client_call_data (connect_file^, temporary_connection, status);
        IF scfs_event_logging THEN
          log_receive_connection_event (connect_file^, temporary_connection, status.normal);
        IFEND;
        search_connection_list (temporary_connection, known_connection, index);
        IF status.normal THEN

{  Accept the request to establish a connection with SCFS. }

          IF known_connection THEN
            remove_connection_from_list ( index, wait_list, wait_connection_list,
                  message, status);
          IFEND;
          nap$accept_connection (connect_file^, status);
          IF status.normal THEN
            add_connection_to_list (connect_file^, connect_file_identifier, temporary_connection,
                   connection);
            add_to_wait_list (connection, wait_list, wait_connection_list);
          ELSEIF (status.condition = nae$invalid_request) THEN
            RETURN;
          ELSE
            fsp$close_file (connect_file_identifier, ignore_status);
            amp$return (unique_name, ignore_status);
          IFEND;
        ELSE
          fsp$close_file (connect_file_identifier, ignore_status);
          amp$return (unique_name, ignore_status);
        IFEND;
      ELSE { unable to open connection file
        amp$return (unique_name, ignore_status);
      IFEND;
    ELSEIF (status.condition = nae$application_inactive) OR
         (status.condition = nae$server_not_attached) OR
         (status.condition = nae$invalid_connect_data_change) THEN
      RETURN;
    IFEND;

  PROCEND get_new_connection;
?? TITLE := 'get_ntf_remote_system_names_msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from OPENTF for
{    remote system names information.  If the remote system is unknown, a
{    negative response is sent to OPENTF, otherwise the remote system
{    information is returned.

  PROCEDURE get_ntf_remote_system_names_msg
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      logical_line_number: nft$ntf_logical_line_number,
      logical_line_number_specified: boolean,
      remote_system_kind_set: set of nft$ntf_remote_system_kind,
      remote_system_name: ost$name,
      remote_system_name_specified: boolean,
      message_response: nft$display_status_resp_codes;

*copy nft$ntf_get_rem_sys_names_msg
?? NEWTITLE := 'crack_get_remote_sys_names_msg', EJECT ??

    PROCEDURE crack_get_remote_sys_names_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR remote_system_name_specified: boolean;
       VAR remote_system_name: ost$name;
       VAR logical_line_number_specified: boolean;
       VAR logical_line_number: nft$ntf_logical_line_number;
       VAR remote_system_kind_set: set of nft$ntf_remote_system_kind;
       VAR status: ost$status);

      TYPE
        kind_set = set of nft$ntf_remote_system_kind;

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        line_number: ^nft$ntf_logical_line_number,
        parameter: ^nft$ntf_get_rem_sys_names_msg,
        remote_sys_kind_set: ^kind_set,
        value_length: integer;

      status.normal := TRUE;
      NEXT parameter IN message;
      logical_line_number_specified := FALSE;
      remote_system_name_specified := FALSE;
      remote_system_kind_set := - $kind_set [ ];

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$ntf_remote_system_name =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, remote_system_name);
          remote_system_name_specified := TRUE;

        = nfc$ntf_logical_line_number =
          NEXT line_number IN message;
          logical_line_number := line_number^;
          logical_line_number_specified := TRUE;

        = nfc$ntf_remote_system_kind =
          NEXT remote_sys_kind_set IN message;
          remote_system_kind_set := remote_sys_kind_set^;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_get_remote_sys_names_msg;
?? TITLE := 'send_remote_system_names_data', EJECT ??

    PROCEDURE send_remote_system_names_data
      (    response_code: nft$display_status_resp_codes;
           remote_system_name_specified: boolean;
           remote_system_name: ost$name;
           logical_line_number_specified: boolean;
           logical_line_number: nft$ntf_logical_line_number;
           remote_system_kind_set: set of nft$ntf_remote_system_kind;
           connection: ^nft$connection;
       VAR status: ost$status);

      VAR
        acc_remote_system: ^nft$alias,
        ascii_string: ^string ( * <= osc$max_name_size),
        message: ^nft$message_sequence,
        message_length: nft$message_length,
        message_type: ^nft$message_kind,
        name_length: 0 .. osc$max_name_size,
        parameter_kind: ^nft$ntf_get_rem_sys_names_data,
        parameter_kind_size: nft$message_length,
        param_length_size: nft$message_length,
        parameter_value_length: integer,
        remote_system_data: ^nft$ntf_remote_system_data,
        remote_system_kind: nft$ntf_remote_system_kind,
        remote_system_name_count: ^integer,
        remote_system_ptr: ^nft$pointer_list_entry,
        remote_system_ptr_found: boolean,
        response_param: ^nft$display_status_resp_codes,
        send_data: boolean;

*copy nft$ntf_get_rem_sys_names_data

      status.normal := TRUE;
      parameter_kind_size := #SIZE (nft$ntf_get_rem_sys_names_data);
      PUSH message: [[REP nfc$maximum_message_length + (nfc$ntf_remote_sys_seq_storage *
            scfs_tables.ntf_acc_remote_system_count) OF cell]];
      RESET message;

      NEXT message_type IN message;
      message_type^ := nfc$get_ntf_rem_sys_names_data;
      message_length := 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$response_code;
      parameter_kind^.length_indicated := FALSE;
      NEXT response_param IN message;
      response_param^ := response_code;
      message_length := message_length + parameter_kind_size + 1;

      IF response_code = nfc$disp_msg_accepted THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$ntf_remote_system_count;
        parameter_value_length := #SIZE (integer);
        parameter_kind^.length_indicated := TRUE;
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        NEXT remote_system_name_count IN message;
        remote_system_name_count^ := 0;
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        acc_remote_system := scfs_tables.first_ntf_acc_remote_system;
        WHILE acc_remote_system <> NIL DO
          IF acc_remote_system^.station_list = NIL THEN
            remote_system_kind := nfc$ntf_not_configured;
            send_data := ((nfc$ntf_not_configured IN remote_system_kind_set) AND ((NOT
                  remote_system_name_specified) OR (remote_system_name = acc_remote_system^.name)));
          ELSE
            find_ntf_remote_system_pointer (acc_remote_system^.name, FALSE, 1, acc_remote_system,
                   remote_system_ptr, remote_system_ptr_found);
            IF remote_system_ptr_found THEN
              remote_system_kind := nfc$ntf_directly_connected;
            ELSE
              remote_system_kind := nfc$ntf_accessible;
            IFEND;

            send_data := (remote_system_kind IN remote_system_kind_set);
            IF send_data AND remote_system_name_specified THEN
              find_ntf_remote_system_pointer (remote_system_name, logical_line_number_specified,
                    logical_line_number, acc_remote_system, remote_system_ptr,
                    remote_system_ptr_found);
              send_data := (remote_system_ptr_found OR ((NOT logical_line_number_specified) AND
                    (remote_system_name = acc_remote_system^.name)));
            IFEND;
          IFEND;

          IF send_data THEN
            remote_system_name_count^ := remote_system_name_count^ +1;

            NEXT parameter_kind IN message;
            parameter_kind^.param := nfc$ntf_remote_system_data;
            name_length := clp$trimmed_string_size (acc_remote_system^.name);
            parameter_value_length := #SIZE (nft$ntf_remote_system_data: [0]) + name_length;
            parameter_kind^.length_indicated := TRUE;
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
            NEXT remote_system_data: [name_length] IN message;
            remote_system_data^.remote_system_type := acc_remote_system^.ntf_remote_system_type;
            remote_system_data^.kind := remote_system_kind;
            remote_system_data^.route_back_position := acc_remote_system^.ntf_route_back_position;
            remote_system_data^.authority_level := acc_remote_system^.ntf_authority_level;
            remote_system_data^.name := acc_remote_system^.name (1, name_length);
            message_length := message_length + parameter_kind_size + param_length_size +
                  parameter_value_length;
          IFEND;

          acc_remote_system := acc_remote_system^.link;
        WHILEND;
      IFEND;

      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;

    PROCEND send_remote_system_names_data;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    crack_get_remote_sys_names_msg (message, msg_length, remote_system_name_specified, remote_system_name,
          logical_line_number_specified, logical_line_number, remote_system_kind_set, status);

    message_response := nfc$disp_msg_accepted;
    send_remote_system_names_data (message_response, remote_system_name_specified, remote_system_name,
          logical_line_number_specified, logical_line_number, remote_system_kind_set, connection,
           status);

  PROCEND get_ntf_remote_system_names_msg;
?? TITLE := 'get_ntf_remote_system_opts_msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from OPENTF for
{    remote system options information.  If the remote system is unknown, a
{    negative response is sent to OPENTF, otherwise the remote system
{    information is returned.

  PROCEDURE get_ntf_remote_system_opts_msg
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      fake_remote_system: nft$io_station,
      remote_system: ^nft$io_station,
      remote_system_found: boolean,
      remote_system_name: ost$name,
      message_response: nft$display_status_resp_codes;

*copy nft$ntf_get_rem_sys_opts_msg
?? NEWTITLE := 'crack_get_remote_sys_opts_msg', EJECT ??

    PROCEDURE crack_get_remote_sys_opts_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR remote_system_name: ost$name;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        parameter: ^nft$ntf_get_rem_sys_opts_msg,
        value_length: integer;

      status.normal := TRUE;
      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$ntf_remote_system_name =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, remote_system_name);

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_get_remote_sys_opts_msg;
?? TITLE := 'send_remote_system_options_data', EJECT ??

    PROCEDURE send_remote_system_options_data
      (VAR message: ^nft$message_sequence;
           response_code: nft$display_status_resp_codes;
           remote_system: ^nft$io_station;
           connection: ^nft$connection;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        authority_level: ^nft$ntf_authority_level,
        batch_stream: ^nft$batch_device,
        count: ^integer,
        inactivity_timer: ^nft$ntf_inactivity_timer,
        logical_line: ^nft$ntf_logical_line,
        logical_line_data: ^nft$ntf_logical_line_data,
        message_length: nft$message_length,
        message_type: ^nft$message_kind,
        name_length: 0 .. osc$max_name_size,
        parameter_kind: ^nft$ntf_get_rem_sys_opts_data,
        parameter_kind_size: nft$message_length,
        param_length_size: nft$message_length,
        parameter_value_length: integer,
        positive_acknowledge: ^nft$ntf_positive_acknowledge,
        protocol: ^nft$ntf_remote_system_protocol,
        remote_system_type: ^nft$ntf_remote_system_type,
        request_permission_retry: ^boolean,
        response_param: ^nft$display_status_resp_codes,
        route_back_position: ^nft$ntf_route_back_position,
        wait_a_bit: ^nft$ntf_wait_a_bit;

*copy nft$ntf_get_rem_sys_opts_data

      status.normal := TRUE;
      parameter_kind_size := #SIZE (nft$ntf_get_rem_sys_opts_data);
      RESET message;

      NEXT message_type IN message;
      message_type^ := nfc$get_ntf_rem_sys_opts_data;
      message_length := 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$ntf_remote_system_name;
      parameter_value_length := clp$trimmed_string_size (remote_system^.name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := remote_system^.name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$response_code;
      parameter_kind^.length_indicated := FALSE;
      NEXT response_param IN message;
      response_param^ := response_code;
      message_length := message_length + parameter_kind_size + 1;

      IF response_code = nfc$disp_msg_accepted THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$ntf_control_facility_name;
        parameter_value_length := clp$trimmed_string_size (control_facility_name);
        nfp$modify_param_value_length (parameter_value_length);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := control_facility_name (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$ntf_protocol;
        parameter_kind^.length_indicated := FALSE;
        NEXT protocol IN message;
        protocol^ := remote_system^.ntf_protocol;
        message_length := message_length + parameter_kind_size + 1;

        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$ntf_authority_level;
        parameter_kind^.length_indicated := FALSE;
        NEXT authority_level IN message;
        authority_level^ := remote_system^.ntf_authority_level;
        message_length := message_length + parameter_kind_size + 1;

        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$ntf_wait_a_bit;
        parameter_kind^.length_indicated := FALSE;
        NEXT wait_a_bit IN message;
        wait_a_bit^ := remote_system^.ntf_wait_a_bit;
        message_length := message_length + parameter_kind_size + 1;

        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$ntf_inactivity_timer;
        parameter_value_length := #SIZE (nft$ntf_inactivity_timer);
        parameter_kind^.length_indicated := TRUE;
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        NEXT inactivity_timer IN message;
        inactivity_timer^ := remote_system^.ntf_inactivity_timer;
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$ntf_positive_acknowledge;
        parameter_kind^.length_indicated := FALSE;
        NEXT positive_acknowledge IN message;
        positive_acknowledge^ := remote_system^.ntf_positive_acknowledge;
        message_length := message_length + parameter_kind_size + 1;

        IF remote_system^.ntf_default_job_destination <> osc$null_name THEN
          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$ntf_default_job_destination;
          parameter_value_length := clp$trimmed_string_size (remote_system^.ntf_default_job_destination);
          nfp$modify_param_value_length (parameter_value_length);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := remote_system^.ntf_default_job_destination (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;
        IFEND;

        IF remote_system^.ntf_default_file_destination <> osc$null_name THEN
          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$ntf_default_file_destin;
          parameter_value_length := clp$trimmed_string_size (remote_system^.ntf_default_file_destination);
          nfp$modify_param_value_length (parameter_value_length);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := remote_system^.ntf_default_file_destination (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;
        IFEND;

        IF remote_system^.ntf_store_forward_destination <> osc$null_name THEN
          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$ntf_store_forward_destin;
          parameter_value_length := clp$trimmed_string_size (remote_system^.ntf_store_forward_destination);
          nfp$modify_param_value_length (parameter_value_length);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := remote_system^.ntf_store_forward_destination (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;
        IFEND;

        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$ntf_remote_system_type;
        parameter_kind^.length_indicated := FALSE;
        NEXT remote_system_type IN message;
        remote_system_type^ := remote_system^.ntf_remote_system_type;
        message_length := message_length + parameter_kind_size + 1;

        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$ntf_route_back_position;
        parameter_kind^.length_indicated := FALSE;
        NEXT route_back_position IN message;
        route_back_position^ := remote_system^.ntf_route_back_position;
        message_length := message_length + parameter_kind_size + 1;

        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$ntf_request_perm_retry;
        parameter_kind^.length_indicated := FALSE;
        NEXT request_permission_retry IN message;
        request_permission_retry^ := remote_system^.ntf_request_permission_retry;
        message_length := message_length + parameter_kind_size + 1;

        IF remote_system^.ntf_local_system_name <> osc$null_name THEN
          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$ntf_local_system_name;
          parameter_value_length := clp$trimmed_string_size (remote_system^.ntf_local_system_name);
          nfp$modify_param_value_length (parameter_value_length);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := remote_system^.ntf_local_system_name (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;
        IFEND;

        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$ntf_logical_line_count;
        parameter_value_length := #SIZE (integer);
        parameter_kind^.length_indicated := TRUE;
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        NEXT count IN message;
        count^ := 0;
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        logical_line := remote_system^.ntf_logical_line_list;
        WHILE logical_line <> NIL DO
          count^ := count^ +1;

          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$ntf_logical_line_data;
          name_length := clp$trimmed_string_size (logical_line^.line_name);
          parameter_value_length := #SIZE (nft$ntf_logical_line_data: [0]) + name_length;
          parameter_kind^.length_indicated := TRUE;
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          NEXT logical_line_data: [name_length] IN message;
          logical_line_data^.number := logical_line^.logical_line_number;
          logical_line_data^.terminal_user_procedure := logical_line^.terminal_user_procedure;
          logical_line_data^.name := logical_line^.line_name (1, name_length);
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;

          logical_line := logical_line^.link;
        WHILEND;

        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$ntf_batch_stream_count;
        parameter_value_length := #SIZE (integer);
        parameter_kind^.length_indicated := TRUE;
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        NEXT count IN message;
        count^ := 0;
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        batch_stream := remote_system^.batch_device_list;
        WHILE batch_stream <> NIL DO
          count^ := count^ +1;

          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$ntf_batch_stream_names;
          parameter_value_length := clp$trimmed_string_size (batch_stream^.name);
          nfp$modify_param_value_length (parameter_value_length);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := batch_stream^.name (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;

          batch_stream := batch_stream^.link;
        WHILEND;
      IFEND;

      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;

    PROCEND send_remote_system_options_data;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    crack_get_remote_sys_opts_msg (message, msg_length, remote_system_name, status);
    message_response := nfc$disp_msg_accepted;
    find_ntf_remote_system (remote_system_name, remote_system, remote_system_found);
    IF NOT remote_system_found THEN
      message_response := nfc$disp_no_io_station;

{     Initialize a remote system entry so that a remote system name can be passed in the response.

      fake_remote_system.name := remote_system_name;
      remote_system := ^fake_remote_system;
    IFEND;

    send_remote_system_options_data (message, message_response, remote_system, connection,
          status);

  PROCEND get_ntf_remote_system_opts_msg;
?? TITLE := 'get_ntf_remote_system_stat_msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from OPENTF for
{    remote system status information.  If the remote system is unknown, a
{    negative response is sent to OPENTF, otherwise the remote system
{    information is returned.

  PROCEDURE get_ntf_remote_system_stat_msg
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      fake_remote_system: nft$io_station,
      logical_line_number: nft$ntf_logical_line_number,
      logical_line_number_specified: boolean,
      remote_system: ^nft$io_station,
      remote_system_found: boolean,
      remote_system_name: ost$name,
      message_response: nft$display_status_resp_codes,
      signon_status: nft$device_status,
      signon_status_specified: boolean;

*copy nft$ntf_get_rem_sys_stat_msg
?? NEWTITLE := 'crack_get_remote_sys_status_msg', EJECT ??

    PROCEDURE crack_get_remote_sys_status_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR remote_system_name: ost$name;
       VAR logical_line_number_specified: boolean;
       VAR logical_line_number: nft$ntf_logical_line_number;
       VAR signon_status_specified: boolean;
       VAR signon_status: nft$device_status;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        line_number: ^nft$ntf_logical_line_number,
        parameter: ^nft$ntf_get_rem_sys_stat_msg,
        signon_stat: ^nft$device_status,
        value_length: integer;

      status.normal := TRUE;
      NEXT parameter IN message;
      logical_line_number_specified := FALSE;
      signon_status_specified := FALSE;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$ntf_remote_system_name =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, remote_system_name);

        = nfc$ntf_logical_line_number =
          NEXT line_number IN message;
          logical_line_number := line_number^;
          logical_line_number_specified := TRUE;

        = nfc$ntf_signon_status =
          NEXT signon_stat IN message;
          signon_status := signon_stat^;
          signon_status_specified := TRUE;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_get_remote_sys_status_msg;
?? TITLE := 'send_remote_system_status_data', EJECT ??

    PROCEDURE send_remote_system_status_data
      (VAR message: ^nft$message_sequence;
           response_code: nft$display_status_resp_codes;
           remote_system: ^nft$io_station;
           logical_line_number_specified: boolean;
           logical_line_number: nft$ntf_logical_line_number;
           signon_status_specified: boolean;
           signon_status: nft$device_status;
           connection: ^nft$connection;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        count: ^integer,
        logical_line: ^nft$ntf_logical_line,
        logical_line_found: boolean,
        message_length: nft$message_length,
        message_type: ^nft$message_kind,
        name_length: 0 .. osc$max_name_size,
        parameter_kind: ^nft$ntf_get_rem_sys_stat_data,
        parameter_kind_size: nft$message_length,
        param_length_size: nft$message_length,
        parameter_value_length: integer,
        remote_system_status: ^nft$ntf_remote_system_status,
        response_param: ^nft$display_status_resp_codes;

*copy nft$ntf_get_rem_sys_stat_data

      status.normal := TRUE;
      parameter_kind_size := #SIZE (nft$ntf_get_rem_sys_stat_data);
      RESET message;

      NEXT message_type IN message;
      message_type^ := nfc$get_ntf_rem_sys_stat_data;
      message_length := 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$ntf_remote_system_name;
      parameter_value_length := clp$trimmed_string_size (remote_system^.name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := remote_system^.name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$response_code;
      parameter_kind^.length_indicated := FALSE;
      NEXT response_param IN message;
      response_param^ := response_code;
      message_length := message_length + parameter_kind_size + 1;

      IF response_code = nfc$disp_msg_accepted THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$ntf_logical_line_count;
        parameter_value_length := #SIZE (integer);
        parameter_kind^.length_indicated := TRUE;
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        NEXT count IN message;
        count^ := 0;
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        logical_line := remote_system^.ntf_logical_line_list;
        logical_line_found := FALSE;
        WHILE (NOT logical_line_found) AND (logical_line <> NIL) DO
          IF NOT logical_line_number_specified OR (logical_line^.logical_line_number = logical_line_number)
                THEN
            IF NOT signon_status_specified OR (logical_line^.signon_status = signon_status) THEN
              count^ := count^ +1;
              logical_line_found := logical_line_number_specified;

              NEXT parameter_kind IN message;
              parameter_kind^.param := nfc$ntf_remote_system_status;
              name_length := clp$trimmed_string_size (logical_line^.line_name);
              parameter_value_length := #SIZE (nft$ntf_remote_system_status: [0]) + name_length;
              parameter_kind^.length_indicated := TRUE;
              nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
              NEXT remote_system_status: [name_length] IN message;
              remote_system_status^.logical_line_number := logical_line^.logical_line_number;
              remote_system_status^.line_speed := logical_line^.line_speed;
              remote_system_status^.signon_status := logical_line^.signon_status;
              remote_system_status^.name := logical_line^.line_name (1, name_length);
              message_length := message_length + parameter_kind_size + param_length_size +
                    parameter_value_length;
            IFEND;
          IFEND;

          logical_line := logical_line^.link;
        WHILEND;
      IFEND;

      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;

    PROCEND send_remote_system_status_data;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    crack_get_remote_sys_status_msg (message, msg_length, remote_system_name, logical_line_number_specified,
          logical_line_number, signon_status_specified, signon_status, status);
    message_response := nfc$disp_msg_accepted;
    find_ntf_remote_system (remote_system_name, remote_system, remote_system_found);
    IF NOT remote_system_found THEN
      message_response := nfc$disp_no_io_station;

{     Initialize a remote system entry so that a remote system name can be passed in the response.

      fake_remote_system.name := remote_system_name;
      remote_system := ^fake_remote_system;
    IFEND;

    send_remote_system_status_data (message, message_response, remote_system, logical_line_number_specified,
          logical_line_number, signon_status_specified, signon_status, connection, status);

  PROCEND get_ntf_remote_system_stat_msg;
?? TITLE := 'get queue entry msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from OPES for
{    detailed information about a specific queue file entry.  If a user
{    file name is specified and there is more than one entry with that name,
{    the information for each of the entries is sent up to OPES.
{
{    This procedure is also executed when a request is received from OPENTF for
{    detailed information about a specific NTF queue file entry.  If a user
{    file name is specified and there is more than one entry with that name,
{    the information for each of the entries is sent up to OPENTF.

  PROCEDURE get_queue_entry_msg
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      current_ptr: ^nft$queue_file_list,
      fake_file: nft$output_queue_file,
      fake_station: nft$io_station,
      file_name: ost$name,
      ignore_status: ost$status,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      msg_length: integer,
      parameter: ^nft$get_queue_entry_parameter,
      q_file: ^nft$output_queue_file,
      q_file_list: ^nft$queue_file_list,
      q_file_ptr: ^nft$queue_file_list,
      response: nft$display_status_resp_codes,
      value_length: integer;

*copy nft$get_queue_entry_msg

?? NEWTITLE := 'build queue file list', EJECT ??

{  PURPOSE:
{    Build a queue file list containing each queue entry matching the specified
{    file name.  The file name will be compared with the queue file's
{    system file name and user file name.

    PROCEDURE build_queue_file_list
      (    file_name: ost$name;
           io_station: ^nft$io_station;
       VAR fake_file: nft$output_queue_file;
       VAR q_file_list: ^nft$queue_file_list;
       VAR response: nft$display_status_resp_codes);

      VAR
        alias_pt: ^nft$alias,
        current_pointer: ^nft$queue_file_list,
        file_found: boolean,
        file_match: boolean,
        i: 0..3,
        q_file: ^nft$output_queue_file,
        q_file_ptr: ^nft$queue_file_list,
        selected_file: ^nft$selected_file;
?? NEWTITLE := 'add_q_file_ptr_to_list', EJECT ??

      PROCEDURE add_q_file_ptr_to_list
        (    q_file: ^nft$output_queue_file;
         VAR q_file_list: ^nft$queue_file_list;
         VAR current_ptr: ^nft$queue_file_list);

        VAR
          q_file_ptr: ^nft$queue_file_list;

        ALLOCATE q_file_ptr;
        q_file_ptr^.queue_file := q_file;
        q_file_ptr^.link := NIL;
        IF q_file_list = NIL THEN
          q_file_list := q_file_ptr;
        ELSE
          current_ptr^.link := q_file_ptr;
        IFEND;
        current_ptr := q_file_ptr;

      PROCEND add_q_file_ptr_to_list;
?? OLDTITLE, EJECT ??
      file_found := FALSE;
      file_match := FALSE;
      current_pointer := NIL;
      q_file := NIL;
      q_file_ptr := NIL;

      IF io_station^.usage <> nfc$ntf_remote_system THEN
        selected_file := io_station^.selected_files_queue;
        WHILE selected_file <> NIL DO
          q_file := selected_file^.output_file;
          file_match := (file_name = q_file^.system_file_name) OR (file_name = q_file^.user_file_name);
          IF file_match THEN
            file_found := TRUE;
            add_q_file_ptr_to_list (q_file, q_file_list, current_pointer);
          IFEND;
          selected_file := selected_file^.link;
        WHILEND;
      IFEND;

    /find_file/
      FOR i := LOWERBOUND (io_station^.alias_list) TO UPPERBOUND (io_station^.alias_list)  DO
        alias_pt := io_station^.alias_list [i];
        IF (alias_pt <> NIL) AND (alias_pt^.queue <> NIL) THEN

          q_file := alias_pt^.queue;
          WHILE (q_file <> NIL) DO

            file_match := (file_name = q_file^.system_file_name) OR (file_name = q_file^.user_file_name);
            IF file_match THEN
              file_found := TRUE;
              add_q_file_ptr_to_list (q_file, q_file_list, current_pointer);
            IFEND;
            q_file := q_file^.link;
          WHILEND;
        IFEND;
      FOREND /find_file/;

      IF NOT file_found THEN
        fake_file.system_file_name := file_name;
        q_file := ^fake_file;
        response := nfc$disp_unknown_file_name;

        ALLOCATE q_file_ptr;
        q_file_ptr^.queue_file := q_file;
        q_file_ptr^.link := NIL;
        q_file_list := q_file_ptr;
      IFEND;

    PROCEND build_queue_file_list;
?? OLDTITLE, EJECT ??
    response := nfc$disp_msg_accepted;
    msg_length := 0;
    current_ptr := NIL;
    q_file_list := NIL;
    q_file_ptr := NIL;

{   Since Get Queue Entry has only 2 parameters, this is all that is needed.

    NEXT parameter IN message;
    IF parameter^.length_indicated THEN
      nfp$get_parameter_value_length (message, msg_length, value_length, status);
    ELSE
      value_length := 1;
    IFEND;
    NEXT ascii_string: [value_length] IN message;
    #translate (osv$lower_to_upper, ascii_string^, io_station_name);

    NEXT parameter IN message;
    IF parameter^.length_indicated THEN
      nfp$get_parameter_value_length (message, msg_length, value_length, status);
    ELSE
      value_length := 1;
    IFEND;
    NEXT ascii_string: [value_length] IN message;
    #translate (osv$lower_to_upper, ascii_string^, file_name);

    q_file := NIL;
    IF connection^.kind = nfc$ntf_operator_connection THEN
      create_fake_io_station_for_ntf (io_station_name, fake_station, io_station_found);
      io_station := ^fake_station;
    ELSE
      find_io_station (io_station_name, io_station, io_station_found);
    IFEND;

    IF io_station_found THEN
     build_queue_file_list (file_name, io_station, fake_file,
           q_file_list, response);
    ELSE
      fake_station.name := io_station_name;
      io_station := ^fake_station;
      fake_file.system_file_name := file_name;
      q_file := ^fake_file;
      response := nfc$disp_no_io_station;

      ALLOCATE q_file_ptr;
      q_file_ptr^.queue_file := q_file;
      q_file_ptr^.link := NIL;
      q_file_list := q_file_ptr;
    IFEND;

    send_queue_entry_msg (message, response, io_station, q_file_list, connection,
          {optimized} FALSE, ignore_status);

{  Delete the queue file list. }

    WHILE (q_file_list <> NIL) DO
      current_ptr := q_file_list;
      q_file_list := current_ptr^.link;
      FREE current_ptr;
    WHILEND;

  PROCEND get_queue_entry_msg;
?? TITLE := 'get queue entry list msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from OPES for
{    information about files in an output queue.  If the request requires an
{    optimized response then full information about the files is returned,
{    otherwise only a list of all system file names and current priorities
{    is returned.
{
{    This procedure is also executed when a request is received from OPENTF for
{    a list of all system file names and current priorities for files in an NTF
{    queue.

  PROCEDURE get_queue_entry_list_msg
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      all_or_top_10: nft$all_or_top_10_q_entries,
      ascii_string: ^string ( * <= osc$max_name_size),
      byte_array: ^nft$byte_array,
      entries: ^nft$all_or_top_10_q_entries,
      fake_station: nft$io_station,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      optimize_queue_list: boolean,
      optimize_queue_list_param: ^nft$optimize_list,
      parameter: ^nft$get_q_entry_list_msg_param,
      response: nft$display_status_resp_codes,
      value_length: integer;

*copyc nft$get_q_entry_list_msg

    optimize_queue_list := FALSE;
    response := nfc$disp_msg_accepted;

    NEXT parameter IN message;

    WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
      msg_length := msg_length - 1;
      IF parameter^.length_indicated THEN
        nfp$get_parameter_value_length (message, msg_length, value_length, status);
        msg_length := msg_length - value_length;
      ELSE
        value_length := 1;
        msg_length := msg_length - 1;
      IFEND;

      CASE parameter^.param OF
      = nfc$io_station_name =
        NEXT ascii_string: [value_length] IN message;
        #translate (osv$lower_to_upper, ascii_string^, io_station_name);

      = nfc$all_or_top_ten =
        NEXT entries IN message;
        all_or_top_10 := entries^;

      = nfc$optimize_queue_list =
        NEXT optimize_queue_list_param IN message;
        optimize_queue_list := (optimize_queue_list_param^ = nfc$do_optimize);

      ELSE

{ ERROR ----   Ignore parameter value.

        NEXT byte_array: [1 .. value_length] IN message;
      CASEND;

      NEXT parameter IN message;
    WHILEND;

    IF connection^.kind = nfc$ntf_operator_connection THEN
      create_fake_io_station_for_ntf (io_station_name, fake_station, io_station_found);
      io_station := ^fake_station;
    ELSE
      find_io_station (io_station_name, io_station, io_station_found);
    IFEND;

    IF NOT io_station_found THEN
      fake_station.name := io_station_name;
      io_station := ^fake_station;
      response := nfc$disp_no_io_station;
    IFEND;

    IF optimize_queue_list THEN
     send_queue_entry_msg_optimized (connection, io_station, all_or_top_10, message, status);
    ELSE
      send_queue_entry_list_msg (response, io_station, all_or_top_10, connection, status);
    IFEND;

  PROCEND get_queue_entry_list_msg;
?? TITLE := 'get queue status msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from OPES for
{    information about the output queue for an I/O station.
{
{    This procedure is also executed when a request is received from OPENTF for
{    information about the NTF queue for a remote system.

  PROCEDURE get_queue_status_msg
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      fake_station: nft$io_station,
      file_count: integer,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      msg_length: integer,
      parameter: ^nft$get_station_status_param,
      response: nft$display_status_resp_codes,
      value_length: integer;

{    NOTE:  The parameters for the Get Queue Status message are identical to
{    the parameters for the Get Station Status message.  That is why the types
{    defined in nft$get_station_status_msg are used for this message.

*copy nft$get_station_status_msg

    msg_length := 0;
    response := nfc$disp_msg_accepted;

{   Since Get Queue Status has only 1 parameter, this is all that is needed.
    NEXT parameter IN message;
    IF parameter^.length_indicated THEN
      nfp$get_parameter_value_length (message, msg_length, value_length, status);
    ELSE
      value_length := 1;
    IFEND;
    NEXT ascii_string: [value_length] IN message;
    #translate (osv$lower_to_upper, ascii_string^, io_station_name);

    IF connection^.kind = nfc$ntf_operator_connection THEN
      create_fake_io_station_for_ntf (io_station_name, fake_station, io_station_found);
      io_station := ^fake_station;
    ELSE
      find_io_station (io_station_name, io_station, io_station_found);
    IFEND;

    IF NOT io_station_found THEN
      fake_station.name := io_station_name;
      io_station := ^fake_station;
      response := nfc$disp_no_io_station;
    IFEND;

    send_queue_status_msg (message, response, io_station, connection, status);

  PROCEND get_queue_status_msg;
?? TITLE := 'get required file avail params', EJECT ??

  PROCEDURE get_required_file_avail_params
    (VAR message: ^nft$message_sequence;
     VAR msg_length: integer;
     VAR q_file: nft$output_queue_file;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      byte_array: ^nft$byte_array,
      io_station_usage: ^nft$io_station_usage,
      parameter: ^nft$file_available_msg_param,
      value_length: integer;

*copy nft$file_availability_msg

    NEXT parameter IN message;

    WHILE (parameter <> NIL) AND (parameter^.param <= nfc$user_family) AND (parameter^.param <>
          nfc$null_parameter) AND (msg_length > 0) DO
      msg_length := msg_length - 1;
      IF parameter^.length_indicated THEN
        nfp$get_parameter_value_length (message, msg_length, value_length, status);
        msg_length := msg_length - value_length;
      ELSE
        value_length := 1;
        msg_length := msg_length - 1;
      IFEND;

      CASE parameter^.param OF
      = nfc$io_station_name =
        NEXT ascii_string: [value_length] IN message;
        #translate (osv$lower_to_upper, ascii_string^, q_file.ios_name);

      = nfc$operator_name =
        NEXT ascii_string: [value_length] IN message;
        #translate (osv$lower_to_upper, ascii_string^, q_file.operator_name);

      = nfc$operator_family =
        NEXT ascii_string: [value_length] IN message;
        #translate (osv$lower_to_upper, ascii_string^, q_file.operator_family);

      = nfc$station_usage =
        NEXT io_station_usage IN message;
        q_file.ios_usage := io_station_usage^;

      = nfc$system_file_name =
        NEXT ascii_string: [value_length] IN message;
        #translate (osv$lower_to_upper, ascii_string^, q_file.system_file_name);

      = nfc$system_job_name =
        NEXT ascii_string: [value_length] IN message;
        #translate (osv$lower_to_upper, ascii_string^, q_file.system_job_name);

      = nfc$user_file_name =
        NEXT ascii_string: [value_length] IN message;
        #translate (osv$lower_to_upper, ascii_string^, q_file.user_file_name);

      = nfc$user_job_name =
        NEXT ascii_string: [value_length] IN message;
        #translate (osv$lower_to_upper, ascii_string^, q_file.user_job_name);

      = nfc$user_name =
        NEXT ascii_string: [value_length] IN message;
        #translate (osv$lower_to_upper, ascii_string^, q_file.user_name);

      = nfc$user_family =
        NEXT ascii_string: [value_length] IN message;
        #translate (osv$lower_to_upper, ascii_string^, q_file.family_name);

      ELSE
{       ERROR ----   Ignore parameter value.
        NEXT byte_array: [1 .. value_length] IN message;

      CASEND;
      NEXT parameter IN message;
    WHILEND;

    RESET message TO parameter;

  PROCEND get_required_file_avail_params;
?? TITLE := 'get station status msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from OPES for
{    I/O station status information.  If the station is unknown, a negative
{    response is sent to OPES, otherwise the station information is returned.

  PROCEDURE get_station_status_msg
    (VAR message: ^nft$message_sequence;
     VAR msg_length: integer;
         connection: ^nft$connection;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      byte_array: ^nft$byte_array,
      fake_station: nft$io_station,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      message_area: ^nft$message_sequence,
      optimize_device_list: boolean,
      optimize_device_list_param: ^nft$optimize_list,
      parameter: ^nft$get_station_status_param,
      response: nft$display_status_resp_codes,
      value_length: integer;

*copy nft$get_station_status_msg

    optimize_device_list := FALSE;
    response := nfc$disp_msg_accepted;

    NEXT parameter in message;

    WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
      msg_length := msg_length - 1;
      IF parameter^.length_indicated THEN
        nfp$get_parameter_value_length (message, msg_length, value_length, status);
        msg_length := msg_length - value_length;
      ELSE
        value_length := 1;
        msg_length := msg_length - 1;
      IFEND;

      CASE parameter^.param OF
      = nfc$io_station_name =
        NEXT ascii_string: [value_length] IN message;
        #translate (osv$lower_to_upper, ascii_string^, io_station_name);

      = nfc$optimize_device_list =
        NEXT optimize_device_list_param IN message;
        optimize_device_list := (optimize_device_list_param^ = nfc$do_optimize);

      ELSE

{ ERROR ----   Ignore parameter value.

        NEXT byte_array: [1 .. value_length] IN message;
      CASEND;

      NEXT parameter IN message;
    WHILEND;

    find_io_station (io_station_name, io_station, io_station_found);
    IF NOT io_station_found THEN
      fake_station.name := io_station_name;
      io_station := ^fake_station;
      response := nfc$disp_no_io_station;
    IFEND;

    IF optimize_device_list THEN
      PUSH message_area: [[REP nfc$maximum_send_message_length OF cell]];
      send_device_status_msg (message_area, response, io_station, NIL, connection, optimize_device_list,
            status);
    ELSE
      send_station_status_msg (message, response, io_station, connection, status);
    IFEND;

  PROCEND get_station_status_msg;
?? TITLE := 'initialize_io_station', EJECT ??

  PROCEDURE initialize_io_station
    (VAR io_station_entry: nft$io_station);

    io_station_entry.name := osc$null_name;
    io_station_entry.alias_names [1] := osc$null_name;
    io_station_entry.alias_names [2] := osc$null_name;
    io_station_entry.alias_names [3] := osc$null_name;

    io_station_entry.required_operator_device := osc$null_name;
    io_station_entry.usage := nfc$public_io_station;
    io_station_entry.file_acknowledgement := FALSE;
    io_station_entry.check_ios_unique := FALSE;

    io_station_entry.automatic_operator_control := FALSE;
    io_station_entry.operator_assigned := FALSE;
    io_station_entry.connected_operator := NIL;
    io_station_entry.station_operational := FALSE;

    io_station_entry.default_job_destination := osc$null_name;
    io_station_entry.destination_unavailable_action := nfc$stop_input_device;
    io_station_entry.pm_message_action := nfc$print_pm_message;

    io_station_entry.scfdi_connection_pointers := NIL;
    io_station_entry.batch_device_list := NIL;
    io_station_entry.selected_files_queue := NIL;
    io_station_entry.last_selected_file_in_q := NIL;

    io_station_entry.alias_list [0] := NIL;
    io_station_entry.alias_list [1] := NIL;
    io_station_entry.alias_list [2] := NIL;
    io_station_entry.alias_list [3] := NIL;

  PROCEND initialize_io_station;
?? TITLE := 'initialize_ntf_logical_line', EJECT ??

{  PURPOSE:
{    This procedure initializes all fields of a logical line entry.

  PROCEDURE initialize_ntf_logical_line
    (VAR logical_line_entry: nft$ntf_logical_line);

    logical_line_entry.logical_line_number := 1;
    logical_line_entry.line_name := osc$null_name;
    logical_line_entry.line_speed := 9600;
    logical_line_entry.signon_status := nfc$ntf_waiting_signon;
    logical_line_entry.console_stream_name := osc$null_name;
    logical_line_entry.terminal_user_procedure := osc$null_name;
    logical_line_entry.scfdi_connection := NIL;
    logical_line_entry.back_link := NIL;
    logical_line_entry.link := NIL;

  PROCEND initialize_ntf_logical_line;
?? TITLE := 'initialize_ntf_remote_system', EJECT ??

{  PURPOSE:
{    This procedure initializes all fields of a remote system entry.

  PROCEDURE initialize_ntf_remote_system
    (VAR remote_system_entry: nft$io_station);

    remote_system_entry.name := osc$null_name;
    remote_system_entry.required_operator_device := osc$null_name;
    remote_system_entry.usage := nfc$ntf_remote_system;
    remote_system_entry.file_acknowledgement := TRUE;
    remote_system_entry.automatic_operator_control := FALSE;
    remote_system_entry.operator_assigned := FALSE;
    remote_system_entry.connected_operator := NIL;
    remote_system_entry.station_operational := TRUE;
    remote_system_entry.batch_device_list := NIL;
    remote_system_entry.back_link := NIL;
    remote_system_entry.link := NIL;
    remote_system_entry.ntf_protocol := nfc$ntf_nje;
    remote_system_entry.ntf_local_system_name := osc$null_name;
    remote_system_entry.ntf_authority_level := nfc$ntf_none;
    remote_system_entry.ntf_wait_a_bit := nfc$ntf_acknowledge;
    remote_system_entry.ntf_inactivity_timer := 0;
    remote_system_entry.ntf_positive_acknowledge := nfc$ntf_ack;
    remote_system_entry.ntf_remote_password := osc$null_name;
    remote_system_entry.ntf_local_password := osc$null_name;
    remote_system_entry.ntf_default_job_destination := osc$null_name;
    remote_system_entry.ntf_default_file_destination := osc$null_name;
    remote_system_entry.ntf_store_forward_destination := osc$null_name;
    remote_system_entry.ntf_remote_system_type := nfc$ntf_nos_ve;
    remote_system_entry.ntf_route_back_position := 0;
    remote_system_entry.ntf_request_permission_retry := FALSE;
    remote_system_entry.ntf_logical_line_list := NIL;
    remote_system_entry.ntf_acc_remote_system_ptr_list := NIL;

  PROCEND initialize_ntf_remote_system;
?? TITLE := 'initialize scfs', EJECT ??

{  PURPOSE:
{    This procedure does the following:
{      1.  obtains the parameters specified when SCFS was initiated
{      2.  attaches the server job
{      3.  initializes SCFS's tables
{      4.  sets up logging (if specified on parameters)
{      5.  allocates space for the wait lists

  PROCEDURE initialize_scfs
    (    parameter_list: clt$parameter_list;
     VAR event_logging: boolean;
     VAR wait_list: ^ost$i_wait_list;
     VAR message_area: ^nft$message_sequence;
     VAR status: ost$status);

    TYPE
      connection_pt = ^nft$connection;

    VAR
      ntf_remote_system_count: nft$ntf_remote_system_count,
      ntf_remote_system_list_file: amt$local_file_name;

?? NEWTITLE := 'get control facility parameters', EJECT ??

    PROCEDURE get_control_facility_parameters
      (    parameter_list: clt$parameter_list;
           scfs_command_pdt: clt$parameter_descriptor_table;
       VAR control_name: ost$name;
       VAR server_name: ost$name;
       VAR event_logging: boolean;
       VAR ntf_remote_system_list_file: amt$local_file_name;
       VAR status: ost$status);

      VAR
        list_file_specified: boolean,
        logging_specified: boolean,
        value: clt$value;

      list_file_specified := FALSE;
      ntf_remote_system_list_file := osc$null_name;
      logging_specified := FALSE;
      clp$scan_parameter_list (parameter_list, scfs_command_pdt, status);
      IF status.normal THEN
        clp$get_value ('CONTROL_FACILITY', 1, 1, clc$low, value, status);
        IF status.normal THEN
          control_name := value.name.value;

          clp$get_value ('SERVER', 1, 1, clc$low, value, status);
          IF status.normal THEN
            server_name := value.name.value;

{  If the logging is specified, message coming into SCFS and
{  sent by SCFS will be written to a file.

            clp$test_parameter ('LOGGING', logging_specified, status);
            IF logging_specified THEN
              clp$get_value ('LOGGING', 1, 1, clc$low, value, status);
              IF status.normal THEN
                event_logging := value.bool.value;
              IFEND;
            IFEND;

            IF status.normal THEN
              clp$test_parameter ('NTF_SYSTEM_LIST', list_file_specified, status);
              IF status.normal AND list_file_specified THEN
                clp$get_value ('NTF_SYSTEM_LIST', 1, 1, clc$low, value, status);
                IF status.normal THEN
                  ntf_remote_system_list_file := value.file.local_file_name;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

    PROCEND get_control_facility_parameters;
?? TITLE := 'initialize_ntf_acc_rem_sys_list', EJECT ??

    PROCEDURE initialize_ntf_acc_rem_sys_list
      (    ntf_remote_system_list_file: amt$local_file_name;
       VAR remote_system_count: nft$ntf_remote_system_count;
       VAR status: ost$status);

      VAR
        acc_remote_system: ^nft$alias,
        acc_remote_system_list: ^array [1 .. *] of nft$alias,
        actual_count: nft$ntf_remote_system_count,
        byte_address: amt$file_byte_address,
        count_string: string (osc$max_string_size),
        count_integer: clt$integer,
        file_position: amt$file_position,
        ignore_status: ost$status,
        last_acc_remote_system: ^nft$alias,
        remote_system_list_fid: amt$file_identifier,
        remote_system_name: ost$name,
        transfer_count: amt$transfer_count;

      status.normal := TRUE;
      remote_system_count := 0;

      fsp$open_file (ntf_remote_system_list_file, amc$record, NIL, NIL, NIL, NIL, NIL,
            remote_system_list_fid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$get_next (remote_system_list_fid, ^count_string, #SIZE (count_string), transfer_count, byte_address,
            file_position, status);
      IF status.normal THEN
        IF file_position <> amc$eoi THEN
          clp$convert_string_to_integer (count_string (1, transfer_count), count_integer, status);
          IF status.normal THEN
            remote_system_count := count_integer.value;
          ELSE
            osp$set_status_abnormal (nfc$status_id, nfe$ntf_system_list_file_error, ' ', status);
            fsp$close_file (remote_system_list_fid, ignore_status);
            RETURN;
          IFEND;
        IFEND;
      IFEND;

      IF remote_system_count > nfc$ntf_max_remote_systems THEN
        pmp$log ('NTF_System_List contains more than 3000 remote systems.', status);
        pmp$log ('Only the first 3000 remote systems will be used.', status);
        remote_system_count := nfc$ntf_max_remote_systems;
      IFEND;

      IF (remote_system_count > 0) AND (file_position <> amc$eoi) THEN
        ALLOCATE acc_remote_system_list: [1 .. remote_system_count];
      IFEND;

      actual_count := 0;
      last_acc_remote_system := NIL;
      WHILE (actual_count < remote_system_count) AND (file_position <> amc$eoi) DO
        amp$get_next (remote_system_list_fid, ^remote_system_name, #SIZE (remote_system_name),
              transfer_count, byte_address, file_position, status);
        IF NOT status.normal THEN
          fsp$close_file (remote_system_list_fid, ignore_status);
          RETURN;
        IFEND;

        actual_count := actual_count + 1;
        acc_remote_system := ^acc_remote_system_list^ [actual_count];
        acc_remote_system^.name := remote_system_name (1, transfer_count);
        acc_remote_system^.back_link := last_acc_remote_system;
        acc_remote_system^.link := NIL;
        acc_remote_system^.kind := nfc$io_station_alias;
        acc_remote_system^.queue := NIL;
        acc_remote_system^.station_list := NIL;
        acc_remote_system^.station_title_registered := FALSE;
        acc_remote_system^.alias_title_registered := FALSE;
        acc_remote_system^.ntf_authority_level := nfc$ntf_none;
        acc_remote_system^.ntf_remote_system_type := nfc$ntf_nos_ve;
        acc_remote_system^.ntf_route_back_position := 0;
        IF last_acc_remote_system <> NIL THEN
          IF last_acc_remote_system^.name >= acc_remote_system^.name THEN
            fsp$close_file (remote_system_list_fid, ignore_status);
            osp$set_status_abnormal (nfc$status_id, nfe$ntf_system_list_file_error, ' ', status);
            RETURN;
          IFEND;

          last_acc_remote_system^.link := acc_remote_system;
        IFEND;

        last_acc_remote_system := acc_remote_system;
      WHILEND;

      remote_system_count := actual_count;
      IF remote_system_count > 0 THEN
        acc_remote_system := ^acc_remote_system_list^ [1];
        scfs_tables.first_ntf_acc_remote_system := acc_remote_system;
      IFEND;

      fsp$close_file (remote_system_list_fid, status);
    PROCEND initialize_ntf_acc_rem_sys_list;

?? TITLE := 'initialize title', EJECT ??

    PROCEDURE initialize_title
      (    server: nat$application_name;
       VAR control_facility_name: ost$name;
           register_ntf: boolean;
       VAR status: ost$status);

      CONST
        maximum_connections = 0;

      VAR
        ignore_status: ost$status;

{  Attach the current job to the server application.  This must be done
{  before connections may be acquired.

      nap$attach_server_application (server, maximum_connections, status);
      IF status.normal THEN
        register_new_title (control_facility_name, FALSE, status);
        IF status.normal THEN
          ALLOCATE scfs_title: [start_of_title_length + osc$max_name_size];
          scfs_title^ (1, start_of_title_length) := start_of_scfs_title;
          scfs_title^ (1 + start_of_title_length, * ) := control_facility_name;
          IF register_ntf AND (control_facility_name (1, nfc$ntf_control_fac_prefix_size) <>
                nfc$ntf_control_facility_prefix) THEN
            register_new_title (control_facility_name, TRUE, status);
            IF status.normal THEN
              ALLOCATE scfs_ntf_title: [start_of_title_length + nfc$ntf_control_fac_prefix_size +
                    osc$max_name_size];
              scfs_ntf_title^ (1, start_of_title_length) := start_of_scfs_title;
              scfs_ntf_title^ (1 + start_of_title_length, nfc$ntf_control_fac_prefix_size) :=
                    nfc$ntf_control_facility_prefix;
              scfs_ntf_title^ (1 + start_of_title_length + nfc$ntf_control_fac_prefix_size, * ) :=
                    control_facility_name;
            IFEND;
          IFEND;
        ELSE
          nap$detach_server_application (server, ignore_status);
          control_facility_name := osc$null_name;
        IFEND;
      IFEND;

    PROCEND initialize_title;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    scfs_tables.first_connection := NIL;
    scfs_tables.first_io_station := NIL;
    scfs_tables.first_ntf_acc_remote_system := NIL;
    scfs_tables.first_ntf_operator := NIL;
    scfs_tables.first_ntf_remote_system := NIL;
    scfs_tables.first_station_name_alias := NIL;
    scfs_tables.ntf_acc_remote_system_count := 0;
    scfs_tables.unknown_private_operators_q := NIL;

    get_control_facility_parameters (parameter_list, scfs_command_pdt, control_facility_name, server_name,
          event_logging, ntf_remote_system_list_file, status);
    IF status.normal THEN
      initialize_title (server_name, control_facility_name, (ntf_remote_system_list_file <> osc$null_name),
            status);
      IF status.normal THEN
        IF ntf_remote_system_list_file <> osc$null_name THEN
          ntf_remote_system_count := 0;
          initialize_ntf_acc_rem_sys_list (ntf_remote_system_list_file, ntf_remote_system_count,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          scfs_tables.ntf_acc_remote_system_count := ntf_remote_system_count;
        IFEND;
        IF status.normal THEN
          IF event_logging THEN
            initialize_scfs_event_logging (status);
          IFEND;
          IF status.normal THEN
            ALLOCATE message_area: [[REP nfc$maximum_message_length OF cell]];

            ALLOCATE wait_connection_list_seq: [[REP (nfc$wait_list_limit-wait_connection_list_lowest+1)
                  OF connection_pt]];

            ALLOCATE wait_list_seq: [[REP nfc$wait_list_limit OF ost$i_activity]];
            RESET wait_list_seq;
            NEXT wait_list: [1 .. 2] IN wait_list_seq;
            wait_list^ [1].activity := nac$i_await_connection;
            wait_list^ [1].server := server_name;
            wait_list^ [2].activity := osc$i_await_time;
            wait_list^ [2].milliseconds := long_scfs_timer;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND initialize_scfs;
?? TITLE := 'initialize scfs event logging', EJECT ??

  PROCEDURE initialize_scfs_event_logging
    (VAR status: ost$status);

    VAR
      catalog_path: ^pft$path,
      cycle_selector: pft$cycle_selector,
      file_path: ^pft$path,
      ignore_status: ost$status,
      log_file_attachment_options: ^fst$attachment_options,
      path: ^SEQ ( * ),
      usage_selections: pft$usage_selections,
      share_selections: pft$share_selections;

    ALLOCATE scfs_log_file: [osc$max_name_size];
    PUSH path: [[REP 5 of pft$name]];

    RESET path;
    NEXT file_path: [1 .. 5] IN path;
    file_path^ [1] := '$SYSTEM';
    file_path^ [2] := '$SYSTEM';
    file_path^ [3] := 'BATCH_DEVICE_SUPPORT';
    file_path^ [4] := 'SCFS_LOG';
    file_path^ [5] := control_facility_name;
    scfs_log_file^ := control_facility_name;

    RESET path;
    NEXT catalog_path: [1 .. 4] IN path;

    pfp$define_catalog (catalog_path^, status);

    cycle_selector.cycle_option := pfc$highest_cycle;
    amp$return (file_path^ [5], ignore_status);
    pfp$define (file_path^ [5], file_path^, cycle_selector, osc$null_name, pfc$maximum_retention,
          pfc$no_log, status);
    IF status.normal THEN
      PUSH log_file_attachment_options: [1 .. 2];
      log_file_attachment_options^ [1].selector := fsc$access_and_share_modes;
      log_file_attachment_options^ [1].access_modes.selector :=
            fsc$specific_access_modes;
      log_file_attachment_options^ [1].access_modes.value :=
            -$fst$file_access_options [];
      log_file_attachment_options^ [1].share_modes.selector :=
            fsc$specific_share_modes;
      log_file_attachment_options^ [1].share_modes.value :=
            $fst$file_access_options [fsc$read, fsc$execute];
      log_file_attachment_options^ [2].selector :=
            fsc$open_share_modes;
      log_file_attachment_options^ [2].open_share_modes :=
            $fst$file_access_options [fsc$read, fsc$execute];
      fsp$open_file (scfs_log_file^, amc$segment, log_file_attachment_options, NIL, NIL, NIL, NIL,
            scfs_log_file_identifier, status);
      IF status.normal THEN
        amp$get_segment_pointer (scfs_log_file_identifier, amc$sequence_pointer, scfs_log_sequence, status);
        RESET scfs_log_sequence.sequence_pointer;
      IFEND;
    IFEND;

  PROCEND initialize_scfs_event_logging;
?? TITLE := 'init_ntf_acc_rem_sys_ptr_entry', EJECT ??

{  PURPOSE:
{    This procedure initializes all fields of an accessible remote system
{    pointer.

  PROCEDURE init_ntf_acc_rem_sys_ptr_entry
    (VAR acc_remote_system_ptr_entry: nft$pointer_list_entry);

    acc_remote_system_ptr_entry.back_link := NIL;
    acc_remote_system_ptr_entry.link := NIL;
    acc_remote_system_ptr_entry.kind := nfc$ntf_acc_remote_system;
    acc_remote_system_ptr_entry.ntf_acc_remote_system := NIL;

  PROCEND init_ntf_acc_rem_sys_ptr_entry;
?? TITLE := 'init_ntf_remote_sys_ptr_entry', EJECT ??

{  PURPOSE:
{    This procedure initializes all fields of a remote system pointer.

  PROCEDURE init_ntf_remote_sys_ptr_entry
    (VAR remote_system_ptr_entry: nft$pointer_list_entry);

    remote_system_ptr_entry.back_link := NIL;
    remote_system_ptr_entry.link := NIL;
    remote_system_ptr_entry.kind := nfc$ntf_remote_sys_logical_line;
    remote_system_ptr_entry.ntf_remote_system := NIL;
    remote_system_ptr_entry.ntf_logical_line_number := 1;

  PROCEND init_ntf_remote_sys_ptr_entry;
?? TITLE := 'input_device_or_stream', EJECT ??

{  PURPOSE:
{    This function identifies whether a batch device or an NTF batch stream
{    is an input device or stream.

  FUNCTION input_device_or_stream
    (    device: ^nft$batch_device): boolean;

    VAR
      station: ^nft$io_station;

    station := device^.io_station;
    CASE device^.device_type OF
    = nfc$reader =
      input_device_or_stream := (station^.usage <> nfc$ntf_remote_system);
    = nfc$printer, nfc$punch, nfc$plotter, nfc$ntf_remote_system_input, nfc$ntf_job_receiver,
          nfc$ntf_sysout_receiver =
      input_device_or_stream := (station^.usage = nfc$ntf_remote_system);
    ELSE
      input_device_or_stream := FALSE;
    CASEND;

  FUNCEND input_device_or_stream;
?? TITLE := 'log receive connection event', EJECT ??

  PROCEDURE log_receive_connection_event
    (    connection_file: fst$file_reference;
         connection: nft$connection;
         connection_established: boolean);

    CONST
      accepted = 'ACC',
      rejected = 'REJ';

    VAR
      address: ^nft$connection_address,
      connection_accepted: ^string (3),
      connection_kind: ^nft$connection_kind,
      date: ost$date,
      local_status: ost$status,
      log_date: ^ost$date,
      log_time: ^ost$time,
      time: ost$time;

    NEXT connection_accepted IN scfs_log_sequence.sequence_pointer;
    IF connection_established THEN
      connection_accepted^ := accepted;
    ELSE
      connection_accepted^ := rejected;
    IFEND;

    NEXT connection_kind IN scfs_log_sequence.sequence_pointer;
    connection_kind^ := connection.kind;

    NEXT address IN scfs_log_sequence.sequence_pointer;
    address^.kind := connection.peer_address.kind;
    CASE connection.peer_address.kind OF
    = nac$internet_address =
      address^.internet_address := connection.peer_address.internet_address;
    = nac$osi_transport_address =
      address^.network_address_length := connection.peer_address.osi_transport_address.network_address_length;
      address^.network_address := connection.peer_address.osi_transport_address.network_address;
    ELSE
      ;
    CASEND;

    pmp$get_time (osc$millisecond_time, time, local_status);
    NEXT log_time IN scfs_log_sequence.sequence_pointer;
    log_time^ := time;

    IF connection_established THEN
      pmp$get_date (osc$iso_date, date, local_status);
      NEXT log_date IN scfs_log_sequence.sequence_pointer;
      log_date^ := date;
    IFEND;

  PROCEND log_receive_connection_event;
?? TITLE := 'log connection message', EJECT ??

  PROCEDURE log_connection_message
    (    connection: nft$connection;
         msg_length: integer;
     VAR message: ^nft$message_sequence);

    CONST
      msg = 'MSG';

    VAR
      array_length: ^integer,
      byte_array: ^nft$byte_array,
      connection_addr: ^nft$connection_address,
      connection_kind: ^nft$connection_kind,
      connection_message: ^string (3),
      i: integer,
      local_status: ost$status,
      log_time: ^ost$time,
      message_bytes: ^nft$byte_array,
      time: ost$time;

    NEXT connection_message IN scfs_log_sequence.sequence_pointer;
    connection_message^ := msg;

    NEXT connection_kind IN scfs_log_sequence.sequence_pointer;
    connection_kind^ := connection.kind;

    NEXT connection_addr IN scfs_log_sequence.sequence_pointer;
    connection_addr^.kind := connection.peer_address.kind;
    CASE connection.peer_address.kind OF
    = nac$internet_address =
      connection_addr^.internet_address := connection.peer_address.internet_address;
    = nac$osi_transport_address =
      connection_addr^.network_address_length :=
            connection.peer_address.osi_transport_address.network_address_length;
      connection_addr^.network_address := connection.peer_address.osi_transport_address.network_address;
    ELSE
      ;
    CASEND;

    pmp$get_time (osc$millisecond_time, time, local_status);
    NEXT log_time IN scfs_log_sequence.sequence_pointer;
    log_time^ := time;

    NEXT array_length IN scfs_log_sequence.sequence_pointer;
    array_length^ := msg_length;

    NEXT byte_array: [1 .. msg_length] IN scfs_log_sequence.sequence_pointer;
    RESET message;
    NEXT message_bytes: [1 .. msg_length] IN message;
    FOR i := 1 TO msg_length DO
      byte_array^ [i] := message_bytes^ [i];
    FOREND;

  PROCEND log_connection_message;
?? TITLE := 'log terminated connection', EJECT ??

  PROCEDURE log_terminated_connection
    (    connection: nft$connection);

    CONST
      terminated = 'TER';

    VAR
      address: ^nft$connection_address,
      connection_action: ^string (3),
      connection_kind: ^nft$connection_kind,
      local_status: ost$status,
      log_time: ^ost$time,
      time: ost$time;

    NEXT connection_action IN scfs_log_sequence.sequence_pointer;
    connection_action^ := terminated;

    NEXT connection_kind IN scfs_log_sequence.sequence_pointer;
    connection_kind^ := connection.kind;

    NEXT address IN scfs_log_sequence.sequence_pointer;
    address^.kind := connection.peer_address.kind;
    CASE connection.peer_address.kind OF
    = nac$internet_address =
      address^.internet_address := connection.peer_address.internet_address;
    = nac$osi_transport_address =
      address^.network_address_length := connection.peer_address.osi_transport_address.network_address_length;
      address^.network_address := connection.peer_address.osi_transport_address.network_address;
    ELSE
      ;
    CASEND;

    pmp$get_time (osc$millisecond_time, time, local_status);
    NEXT log_time IN scfs_log_sequence.sequence_pointer;
    log_time^ := time;

  PROCEND log_terminated_connection;
?? TITLE := 'modify file availability msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a message is received from SCF/VE
{    informing SCFS that an output queue file entry has been modified by
{    the user.  Changes are made accordingly and the file is made allowed
{    to be selected.
{
{    This procedure is also executed when a message is received from NTF/VE
{    informing SCFS that an NTF queue file entry has been modified by the user.
{    Changes are made accordingly and the file is allowed to be selected.

  PROCEDURE modify_file_availability_msg
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      alias_station_list: ^nft$pointer_list_entry,
      io_station: ^nft$io_station,
      modify_file: nft$output_queue_file,
      q_found: boolean,
      queue_file: ^nft$output_queue_file,
      queue_pointer: ^^nft$output_queue_file,
      selected_file: ^nft$selected_file;

*copy nft$file_availability_msg
?? NEWTITLE := 'change modify optional_fields', EJECT ??

{  Update the attributes of the queue file entry according to }
{  what the user has changed via change_output_attributes. }

    PROCEDURE change_modify_optional_fields
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR queue_entry: nft$output_queue_file;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        copies: ^nft$copies,
        parameter: ^nft$file_available_msg_param,
        parameter_length: ^nft$parameter_value_length,
        priority: ^nft$priority,
        priority_factor: ^nft$priority_multiplier,
        value_length: integer,
        vertical_print_density: ^nft$file_vertical_print_density;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$copies =
          NEXT copies IN message;
          queue_entry.copies := copies^;

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, queue_entry.device_name);

        = nfc$external_characteristics =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, queue_entry.external_characteristics);

        = nfc$forms_code =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, queue_entry.forms_code);

        = nfc$output_initial_priority =
          NEXT priority IN message;
          queue_entry.initial_priority := priority^;

        = nfc$vfu_load_procedure =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, queue_entry.vfu_load_procedure);

        = nfc$vertical_print_density =
          NEXT vertical_print_density IN message;
          queue_entry.vertical_print_density := vertical_print_density^;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND change_modify_optional_fields;
?? OLDTITLE, EJECT ??
    queue_pointer := NIL;
    get_required_file_avail_params (message, msg_length, modify_file, status);

    CASE modify_file.ios_usage OF
    = nfc$public_io_station =
      find_public_queue (modify_file.ios_name, queue_pointer, alias_station_list, q_found);
    = nfc$private_io_station =
      find_private_queue (modify_file.operator_name, modify_file.operator_family, queue_pointer,
            alias_station_list, q_found);
      IF NOT q_found THEN
        q_found := TRUE;
        queue_pointer := ^scfs_tables.unknown_private_operators_q;
      IFEND;
    = nfc$ntf_remote_system =
      find_ntf_remote_queue (modify_file.ios_name, queue_pointer, alias_station_list);
      q_found := (queue_pointer <> NIL);
    CASEND;

    IF q_found THEN
      find_q_file (modify_file.system_file_name, queue_pointer^, queue_file);
      IF queue_file = NIL THEN
        find_station_and_selected_file (modify_file.system_file_name, io_station, selected_file);
        IF selected_file <> NIL THEN
          queue_file := selected_file^.output_file;

          alias_station_list := NIL;
          PUSH alias_station_list;
          alias_station_list^.back_link := NIL;
          alias_station_list^.link := NIL;
          alias_station_list^.kind := nfc$io_station;
          alias_station_list^.io_station := io_station;
        IFEND;
      IFEND;

      IF queue_file <> NIL THEN
        change_modify_optional_fields (message, msg_length, queue_file^, status);

        queue_file^.output_state := nfc$eligible_for_transfer;

        IF queue_pointer <> ^scfs_tables.unknown_private_operators_q THEN
          output_file_assignment (queue_file, alias_station_list, message, connection, status);
          IF NOT status.normal THEN
            status.normal := TRUE;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND modify_file_availability_msg;
?? TITLE := 'move files back to unknown q', EJECT ??

  PROCEDURE move_files_back_to_unknown_q
    (    io_station: ^nft$io_station);

    VAR
      alias_entry: ^nft$alias,
      last_q_file: ^nft$output_queue_file,
      private_q_file: ^nft$output_queue_file;

?? NEWTITLE := 'move_select_files_to_unknown_q', EJECT ??

    PROCEDURE move_select_files_to_unknown_q
      (    io_station: ^nft$io_station;
       VAR last_file_in_unknown_op_q: ^nft$output_queue_file;
       VAR unknown_private_operators_q: ^nft$output_queue_file);

      VAR
        last_output_file: ^nft$output_queue_file,
        new_output_q: ^nft$output_queue_file,
        old_selected_file: ^nft$selected_file,
        output_file: ^nft$output_queue_file,
        selected_file: ^nft$selected_file;

      selected_file := io_station^.selected_files_queue;
      new_output_q := NIL;
      WHILE selected_file <> NIL DO
        IF new_output_q = NIL THEN
          new_output_q := selected_file^.output_file;
          last_output_file := new_output_q;
        ELSE
          last_output_file^.link := selected_file^.output_file;
          output_file := selected_file^.output_file;
          output_file^.back_link := last_output_file;
          last_output_file := output_file;
        IFEND;
        old_selected_file := selected_file;
        selected_file := selected_file^.link;
        FREE old_selected_file;
      WHILEND;

      io_station^.selected_files_queue := NIL;
      io_station^.last_selected_file_in_q := NIL;

      IF unknown_private_operators_q = NIL THEN
        unknown_private_operators_q := new_output_q;
      ELSE
        last_file_in_unknown_op_q^.link := new_output_q;
      IFEND;
      last_file_in_unknown_op_q := last_output_file;

    PROCEND move_select_files_to_unknown_q;
?? OLDTITLE, EJECT ??
    alias_entry := io_station^.alias_list [0];
    IF (io_station^.selected_files_queue <> NIL) OR (alias_entry^.queue <> NIL) THEN
      last_q_file := scfs_tables.unknown_private_operators_q;
      IF last_q_file <> NIL THEN
        WHILE last_q_file^.link <> NIL DO
          last_q_file := last_q_file^.link;
        WHILEND;
      IFEND;

      IF io_station^.selected_files_queue <> NIL THEN
        move_select_files_to_unknown_q (io_station, last_q_file,
              scfs_tables.unknown_private_operators_q);
      IFEND;

      IF last_q_file <> NIL THEN
        last_q_file^.link := alias_entry^.queue;
        private_q_file := alias_entry^.queue;
        private_q_file^.back_link := last_q_file;
      ELSE
        scfs_tables.unknown_private_operators_q := alias_entry^.queue;
      IFEND;
      alias_entry^.queue := NIL;
    IFEND;

  PROCEND move_files_back_to_unknown_q;
?? OLDTITLE ??
?? NEWTITLE := 'ntf_file_and_stream_match', EJECT ??

{  PURPOSE:
{    This procedure determines if the attributes of the output queue file
{    and the attributes of the stream are such that the file should be
{    sent to that stream.
{
{    If the protocol for the remote system is not NJE, the device type of the
{    queue file will be assumed to be card reader.

  FUNCTION ntf_file_and_stream_match
    (    q_file: ^nft$output_queue_file;
         stream: ^nft$batch_device): boolean;

    VAR
      remote_system: ^nft$io_station,
      stream_match: boolean;

    remote_system := stream^.io_station;
    IF stream^.maximum_file_size > 0 THEN
      stream_match := q_file^.file_size <= stream^.maximum_file_size;
    ELSE
      stream_match := TRUE;
    IFEND;

    IF remote_system^.ntf_protocol <> nfc$ntf_nje THEN
      stream_match := stream_match AND (stream^.device_type = nfc$reader);
      stream_match := stream_match AND (q_file^.page_width <= stream^.page_width);
    ELSE
      stream_match := stream_match AND (stream^.device_type = q_file^.device_type);
    IFEND;

    ntf_file_and_stream_match := stream_match;

  FUNCEND ntf_file_and_stream_match;
?? TITLE := 'operator message', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from SCF/DI to
{    send a message to the I/O station operator.  This message would be sent
{    if a print file message is encounted "PM message", upon detection of an
{    error condition (e.g. bad route job command) or to send preview data when
{    positioning a file.  This message is only forwarded if an operator is
{    currently assigned to the specified I/O station.

  PROCEDURE operator_message
    (VAR message: ^nft$message_sequence;
         message_length: integer;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      msg_text: string (255),
      msg_text_length: 0 .. 255,
      operator_connection: ^nft$connection;

*copy nft$operator_message
?? NEWTITLE := 'crack operator msg', EJECT ??

    PROCEDURE crack_operator_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR io_station_name: ost$name;
       VAR device_name: ost$name;
       VAR msg_text: string (255);
       VAR msg_text_length: 0 .. 255;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        parameter: ^nft$operator_message_parameter,
        text: ^string ( * ),
        value_length: integer;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, io_station_name);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, device_name);

        = nfc$text =
          NEXT text: [value_length] IN message;
          IF value_length < 255 THEN
            msg_text (1, value_length) := text^ (1, value_length);
            msg_text_length := value_length;
          ELSE
            msg_text := text^ (1, 255);
            msg_text_length := 255;
          IFEND;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_operator_msg;

?? TITLE := 'print error listing', EJECT ??

    PROCEDURE print_error_listing
      (    msg_text: string(255);
           msg_text_length: 0..255;
           io_station: ^nft$io_station;
           device_name: ost$name);

      CONST
        comment_banner = '**** ERROR ****',
        device_label = 'Device   : ',
        device_label_size = 11,
        routing_banner = 'STATION   OPERATOR';

      VAR
        attachment_options: [STATIC, READ] array [1..1] of fst$attachment_option :=
              [[fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$read, fsc$modify,
              fsc$append, fsc$execute]], *]],
        byte_addr: amt$file_byte_address,
        file_id: amt$file_identifier,
        file_name: ost$name,
        operator_connection: ^nft$connection,
        start_pos: 1..80,
        status: ost$status,
        str_length: 0 .. osc$max_name_size,
        submission_options: ^jmt$output_submission_options,
        system_supplied_name: jmt$system_supplied_name,
        text: string (80),
        text_length: 0..80;

      submission_options := NIL;

{  Create the error listing file, using the operator text sent up from SCF/DI. }

      pmp$get_unique_name (file_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fsp$open_file (file_name, amc$record, ^attachment_options, NIL, NIL, NIL, NIL, file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{  Format the line containing the device and the station name. }

      text (1, device_label_size) := device_label;
      text_length := device_label_size;

      start_pos := text_length + 1;
      str_length := clp$trimmed_string_size (device_name);
      text (start_pos, str_length) := device_name (1, str_length);
      text_length := text_length + str_length;

      start_pos := text_length + 1;
      text (start_pos, 4) := ' at ';
      text_length := text_length + 4;

      start_pos := text_length + 1;
      str_length := clp$trimmed_string_size (io_station^.name);
      text (start_pos, str_length) := io_station^.name (1, str_length);
      text_length := text_length + str_length;

{  Write the station information and the text message to the file.

      amp$put_next (file_id, ^text, text_length, byte_addr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$put_next (file_id, ^msg_text, msg_text_length, byte_addr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fsp$close_file (file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{  Set up the submission options necessary to print the listing at the same  }
{  station the input job was read in from.  }

      IF (io_station^.usage = nfc$public_io_station) THEN

        PUSH submission_options: [1..4];
        submission_options^[1].key := jmc$comment_banner;
        submission_options^[1].comment_banner := comment_banner;
        submission_options^[2].key := jmc$routing_banner;
        submission_options^[2].routing_banner := routing_banner;
        submission_options^[3].key := jmc$station;
        submission_options^[3].station := io_station^.name;
        submission_options^[4].key := jmc$output_destination_usage;
        submission_options^[4].output_destination_usage := jmc$public_usage;

      ELSE {io_station^.usage = nfc$private_io_station}

        IF (io_station^.connected_operator <> NIL) THEN
          PUSH submission_options: [1..6];
          operator_connection := io_station^.connected_operator;
          submission_options^[1].key := jmc$comment_banner;
          submission_options^[1].comment_banner := comment_banner;
          submission_options^[2].key := jmc$routing_banner;
          submission_options^[2].routing_banner := routing_banner;
          submission_options^[3].key := jmc$station;
          submission_options^[3].station := control_facility_name;
          submission_options^[4].key := jmc$output_destination_usage;
          submission_options^[4].output_destination_usage := jmc$private_usage;
          submission_options^[5].key := jmc$station_operator;
          submission_options^[5].station_operator := operator_connection^.user;
          submission_options^[6].key := jmc$output_destination_family;
          submission_options^[6].output_destination_family := operator_connection^.family;
        IFEND;

      IFEND;

{  Send the error listing to print.  }

      jmp$print_file (file_name, submission_options, system_supplied_name, status);

    PROCEND print_error_listing;

?? OLDTITLE, EJECT ??

    crack_operator_msg (message, msg_length, io_station_name, device_name, msg_text, msg_text_length, status);

    find_io_station (io_station_name, io_station, io_station_found);
    IF io_station_found THEN
      find_batch_device (device_name, io_station, device, device_found);
      IF device_found THEN

{  If the operator message came from an input device, the message is an error  }
{  message and an output listing should be generated.  }

        IF (device^.device_type = nfc$reader) THEN
          print_error_listing (msg_text, msg_text_length, io_station, device_name);
        IFEND;

        device^.last_unsolicited_msg_length := msg_text_length;
        device^.last_unsolicited_msg (1, msg_text_length) := msg_text (1, msg_text_length);

        IF io_station^.connected_operator <> NIL THEN
          operator_connection := io_station^.connected_operator;
          nfp$send_message_on_connection (message, message_length, operator_connection^.id, status);
          IF scfs_event_logging THEN
            log_connection_message (operator_connection^, message_length, message);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND operator_message;
?? TITLE := 'output_device_or_stream', EJECT ??

{  PURPOSE:
{    This function identifies whether a batch device or an NTF batch stream
{    is an output device or stream.

  FUNCTION output_device_or_stream
    (    device: ^nft$batch_device): boolean;

    VAR
      station: ^nft$io_station;

    station := device^.io_station;
    CASE device^.device_type OF
    = nfc$reader, nfc$ntf_job_transmitter, nfc$ntf_sysout_transmitter =
      output_device_or_stream := (station^.usage = nfc$ntf_remote_system);
    = nfc$printer, nfc$punch, nfc$plotter =
      output_device_or_stream := (station^.usage <> nfc$ntf_remote_system);
    ELSE
      output_device_or_stream := FALSE;
    CASEND;

  FUNCEND output_device_or_stream;
?? TITLE := 'output file assignment', EJECT ??

  PROCEDURE output_file_assignment
    (    q_file: ^nft$output_queue_file;
         alias_station_list: ^nft$pointer_list_entry;
     VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR status: ost$status);

    VAR
      device: ^nft$batch_device,
      device_found: boolean,
      signed_on: boolean,
      station: ^nft$io_station,
      station_list: ^nft$pointer_list_entry;

    device_found := FALSE;
    station_list := alias_station_list;

    WHILE NOT device_found AND (station_list <> NIL) DO
      IF station_list^.kind <> nfc$ntf_remote_sys_logical_line THEN
        station := station_list^.io_station;
      ELSE
        station := station_list^.ntf_remote_system;
      IFEND;

      IF station^.usage = q_file^.ios_usage THEN
        device := station^.batch_device_list;
        WHILE NOT device_found AND (device <> NIL) DO
          IF station^.usage = nfc$ntf_remote_system THEN
            check_for_ntf_signed_on_stream (station, device, signed_on);
          ELSE
            signed_on := TRUE;
          IFEND;

          IF ((q_file^.device_name = osc$null_name) OR (q_file^.device_name = automatic) OR (q_file^.
                device_name = device^.name) OR (q_file^.device_name = device^.alias_names [1]) OR (q_file^.
                device_name = device^.alias_names [2]) OR (q_file^.device_name = device^.alias_names [3]))
                AND signed_on THEN
            IF device_available_for_output (device) THEN
              device_found := file_and_device_match (q_file, device);
              IF device_found THEN
                q_file^.output_state := nfc$selected_for_transfer;
                q_file^.assigned_device := device;
                device^.current_file := q_file;
              IFEND;
            IFEND;
          IFEND;
          IF NOT device_found THEN
            device := device^.link;
          IFEND;
        WHILEND;
      IFEND;
      IF NOT device_found THEN
        station_list := station_list^.link;
      IFEND;
    WHILEND;

    IF device_found THEN
      send_file_assignment_msg (message, station^.name, q_file^, device, connection, status);
    ELSE
      status.normal := FALSE;
    IFEND;

  PROCEND output_file_assignment;
?? TITLE := 'position file msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from OPES to
{    position an output file transfer that is active on an output device.
{    The information is forwarded to SCF/DI for processing if the station and
{    device are found, the device is an output device and there is a file
{    currently being printed, otherwise the request is rejected.

  PROCEDURE position_file_msg
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      current_file: ^nft$output_queue_file,
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      parameter_block: ^string ( * ),
      param_block_str_length: 0 .. 999,
      posf_direction: nft$position_file_direction,
      posf_loc_count: nft$position_file_locate_count,
      posf_loc_string_1: string (nfc$posf_max_string_length),
      posf_loc_string_2: string (nfc$posf_max_string_length),
      posf_preview_count: nft$position_file_preview_count,
      posf_start_position: nft$position_file_from_position,
      posf_string_1_length: 0 .. nfc$posf_max_string_length,
      posf_string_2_length: 0 .. nfc$posf_max_string_length,
      posf_units: nft$position_file_units,
      response: nft$device_control_resp_codes,
      scf_di_connection: ^nft$connection;

*copyc nft$position_file_param_types
?? NEWTITLE := 'build parameter block', EJECT ??

    PROCEDURE build_parameter_block
      (VAR parameter_block: ^string ( * );
       VAR str_length: 0 .. 999;
       VAR status: ost$status);

      CONST
        zero_fill = '0',
        parameter_block_fixed_length = 32,
        one = '001',
        zero = '000',

        location_count_param = '01',
        location_string_1_param = '02',
        location_string_2_param = '03',
        units_param = '04',
        direction_param = '05',
        start_position_param = '06',
        preview_count_param = '07';

      VAR
        count_length: integer,
        int: integer,
        posf_loc_count_size: integer,
        posf_loc_count_size_string: string(3),
        posf_string_size: string(3),
        second_count_length: integer;

      str_length := parameter_block_fixed_length;
      IF posf_string_1_length > 0 THEN
        str_length := str_length + posf_string_1_length;
        IF posf_loc_string_2 <> osc$null_name THEN
          str_length := str_length + posf_string_2_length;
        IFEND;
      ELSE
        IF (posf_loc_count >= 0) AND (posf_loc_count <= 9) THEN
          posf_loc_count_size := 1;
          posf_loc_count_size_string := one;
        ELSEIF (posf_loc_count >= 10) AND (posf_loc_count <= 99) THEN
          posf_loc_count_size := 2;
          posf_loc_count_size_string := '002';
        ELSEIF (posf_loc_count >= 100) AND (posf_loc_count <= 999) THEN
          posf_loc_count_size := 3;
          posf_loc_count_size_string := '003';
        ELSEIF (posf_loc_count >= 1000) AND (posf_loc_count <= 9999) THEN
          posf_loc_count_size := 4;
          posf_loc_count_size_string := '004';
        ELSEIF (posf_loc_count >= 10000) AND (posf_loc_count <= nfc$posf_max_locate_count) THEN
          posf_loc_count_size := 5;
          posf_loc_count_size_string := '005';
        IFEND;
        str_length := str_length + posf_loc_count_size;
      IFEND;
      ALLOCATE parameter_block: [str_length];

      parameter_block^ := one;
      str_length := 3;

      IF posf_loc_string_1 <> osc$null_name THEN
        parameter_block^ (str_length + 1, 2) := location_string_1_param;
        int := posf_string_1_length;
        clp$convert_integer_to_rjstring (int, 10, false, zero_fill,
              posf_string_size, status);
        parameter_block^ (str_length + 3, 3) := posf_string_size;
        parameter_block^ (str_length + 6, posf_string_1_length) := posf_loc_string_1;
        str_length := str_length + 5 + posf_string_1_length;
        IF posf_loc_string_2 <> osc$null_name THEN
          parameter_block^ (str_length + 1, 2) := location_string_2_param;
          int := posf_string_2_length;
          clp$convert_integer_to_rjstring (int, 10, false, zero_fill,
                posf_string_size, status);
          parameter_block^ (str_length + 3, 3) := posf_string_size;
          parameter_block^ (str_length + 6, posf_string_2_length) := posf_loc_string_2;
          str_length := str_length + 5 + posf_string_2_length;
        IFEND;
      ELSE
        parameter_block^ (str_length + 1, 2) := location_count_param;
        parameter_block^ (str_length + 3, 3) := posf_loc_count_size_string;
        clp$convert_integer_to_rjstring (posf_loc_count, 10, FALSE, ' ', parameter_block^ (str_length + 6,
              posf_loc_count_size), status);
        str_length := str_length + 5 + posf_loc_count_size;
      IFEND;

      parameter_block^ (str_length + 1, 2) := units_param;
      parameter_block^ (str_length + 3, 3) := one;
      IF posf_units = nfc$position_file_page THEN
        parameter_block^ (str_length + 6) := 'P';
      ELSEIF posf_units = nfc$position_file_line THEN
        parameter_block^ (str_length + 6) := 'L';
      IFEND;
      str_length := str_length + 6;

      parameter_block^ (str_length + 1, 2) := direction_param;
      parameter_block^ (str_length + 3, 3) := one;
      IF posf_direction = nfc$position_file_backwards THEN
        parameter_block^ (str_length + 6) := 'B';
      ELSEIF posf_direction = nfc$position_file_forwards THEN
        parameter_block^ (str_length + 6) := 'F';
      IFEND;
      str_length := str_length + 6;

      parameter_block^ (str_length + 1, 2) := start_position_param;
      parameter_block^ (str_length + 3, 3) := one;
      IF posf_start_position = nfc$end_of_file THEN
        parameter_block^ (str_length + 6) := 'E';
      ELSEIF posf_start_position = nfc$beginning_of_file THEN
        parameter_block^ (str_length + 6) := 'B';
      ELSEIF posf_start_position = nfc$last_line_printed THEN
        parameter_block^ (str_length + 6) := 'L';
      IFEND;
      str_length := str_length + 6;

{  The preview count value sent from OPES can range from 1 .. 10.  The value
{  sent to the DI will be mapped into values 0 .. 9.

      IF (posf_preview_count >= 1) THEN
        parameter_block^ (str_length + 1, 2) := preview_count_param;
        parameter_block^ (str_length + 3, 3) := one;
        parameter_block^ (str_length + 6) := $CHAR ((posf_preview_count-1) + 30(16));
        str_length := str_length + 6;
      IFEND;

    PROCEND build_parameter_block;
?? TITLE := 'crack position file msg', EJECT ??

    PROCEDURE crack_position_file_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR io_station_name: ost$name;
       VAR device_name: ost$name;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= nfc$posf_max_string_length),
        byte_array: ^nft$byte_array,
        direction: ^nft$position_file_direction,
        location_count: ^nft$position_file_locate_count,
        parameter: ^nft$position_file_msg_parameter,
        preview_count: ^nft$position_file_preview_count,
        start_position: ^nft$position_file_from_position,
        units: ^nft$position_file_units,
        value_length: integer;

*copyc nft$position_file_msg

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, io_station_name);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, device_name);

        = nfc$location_integer =
          NEXT location_count IN message;
          posf_loc_count := location_count^;

        = nfc$location_string_1 =
          NEXT ascii_string: [value_length] IN message;
          posf_loc_string_1 := ascii_string^;
          posf_string_1_length := value_length;

        = nfc$location_string_2 =
          NEXT ascii_string: [value_length] IN message;
          posf_loc_string_2 := ascii_string^;
          posf_string_2_length := value_length;

        = nfc$units =
          NEXT units IN message;
          posf_units := units^;

        = nfc$direction =
          NEXT direction IN message;
          posf_direction := direction^;

        = nfc$starting_position =
          NEXT start_position IN message;
          posf_start_position := start_position^;

        = nfc$preview_line_count =
          NEXT preview_count IN message;
          posf_preview_count := preview_count^;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_position_file_msg;
?? OLDTITLE, EJECT ??

    posf_loc_count := 0;
    posf_preview_count := 0;
    posf_loc_string_1 := osc$null_name;
    posf_loc_string_2 := osc$null_name;
    posf_string_1_length := 0;
    posf_string_2_length := 0;

    crack_position_file_msg (message, msg_length, io_station_name, device_name, status);

    find_io_station (io_station_name, io_station, io_station_found);
    IF NOT io_station_found THEN
      response := nfc$dc_msg_reject_unknown_ios;
    ELSE
      find_batch_device (device_name, io_station, device, device_found);
      IF NOT device_found THEN
        response := nfc$dc_msg_reject_unknown_dev;

{  If the device is an input device, a position file command is not valid.  }

      ELSEIF device^.device_type = nfc$reader THEN
        response := nfc$dc_msg_reject_bad_dev_type;
      ELSEIF device^.btfs_di_status <> nfc$btfs_di_active THEN
        response := nfc$dc_msg_reject_btfsdi_down;
      ELSE
        response := nfc$dc_msg_accepted;
        current_file := device^.current_file;

{  Send the position file command to SCF/DI for processing if it is accepted. }

        IF response = nfc$dc_msg_accepted THEN
          build_parameter_block (parameter_block, param_block_str_length, status);
          scf_di_connection := device^.scfdi_connection;
          send_position_file_di_msg (message, io_station_name, device_name, parameter_block^ (1,
                param_block_str_length), scf_di_connection, status);
          device^.outstanding_di_responses [nfc$position_file] := device^.outstanding_di_responses
                [nfc$position_file] + 1;
          FREE parameter_block;
        IFEND;
      IFEND;
    IFEND;

{  Send a reject response if the message is not accepted.  }

    IF response > nfc$dc_msg_accepted THEN
      send_device_control_response (message, nfc$position_file_resp, io_station_name, device_name, response,
            connection, status);
    IFEND;

  PROCEND position_file_msg;
?? TITLE := 'position file resp', EJECT ??

{  PURPOSE:
{    This procedure is executed when a response is received from SCF/DI to
{    an operator position file command.  If an operator is assigned to the
{    station for which the device is defined, the response is forwarded to
{    the station operator.

  PROCEDURE position_file_resp
    (VAR message: ^nft$message_sequence;
         message_length: integer;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      operator_connection: ^nft$connection,
      response_code: nft$device_control_resp_codes;

    crack_device_control_resp (message, msg_length, io_station_name, device_name, response_code, status);

    find_io_station (io_station_name, io_station, io_station_found);
    IF io_station_found THEN
      find_batch_device (device_name, io_station, device, device_found);
      IF device_found THEN
        device^.outstanding_di_responses [nfc$position_file] := device^.outstanding_di_responses
              [nfc$position_file] - 1;

        IF io_station^.operator_assigned THEN
          operator_connection := io_station^.connected_operator;
          nfp$send_message_on_connection (message, message_length, operator_connection^.id, status);
          IF scfs_event_logging THEN
            log_connection_message (operator_connection^, message_length, message);
         IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND position_file_resp;
?? TITLE := 'register new title', EJECT ??

  PROCEDURE register_new_title
    (    title_part: ost$name;
         ntf_title: boolean;
     VAR status: ost$status);

    VAR
      next_character: integer,
      title: ^nat$title_pattern;

?? TITLE := 'title already registered', EJECT ??

    FUNCTION title_already_registered (title: nat$title_pattern): boolean;

      CONST
        translation_wait_time = 0;

      VAR
        recurrent_search: boolean,
        search_id: nat$directory_search_identifier,
        translation_address: nat$network_address,
        translation_attributes: ^nat$translation_attributes;

      recurrent_search := FALSE;

      nap$begin_directory_search (title, nfc$scf_ve_client_name, recurrent_search, search_id, status);

      translation_attributes := NIL;

      REPEAT
        nap$get_title_translation (search_id, translation_wait_time, translation_attributes,
              translation_address, status);
        IF NOT status.normal AND (status.condition = nae$no_translation_available) THEN
          pmp$wait (1500, 1500);
        IFEND;
      UNTIL status.normal OR (status.condition <> nae$no_translation_available);

      title_already_registered := status.normal;

      nap$end_directory_search (search_id, status);

    FUNCEND title_already_registered;
?? OLDTITLE, EJECT ??

    PUSH title: [start_of_title_length + nfc$ntf_control_fac_prefix_size + osc$max_name_size];
    next_character := 1;
    title^ (next_character, start_of_title_length) := start_of_scfs_title;
    next_character := next_character + start_of_title_length;
    IF ntf_title THEN
      title^ (next_character, nfc$ntf_control_fac_prefix_size) := nfc$ntf_control_facility_prefix;
      next_character := next_character + nfc$ntf_control_fac_prefix_size;
    IFEND;

    title^ (next_character, * ) := title_part;

    IF title_already_registered (title^) THEN
      osp$set_status_abnormal ('NF', nfe$cf_title_already_registered, title^, status);
    ELSE
      register_title (title^, status);
    IFEND;

  PROCEND register_new_title;

?? NEWTITLE := 'register title', EJECT ??

    PROCEDURE register_title
      (    title: nat$title_pattern;
       VAR status: ost$status);

      VAR
        distribute_title: boolean;

      distribute_title := TRUE;

      nap$add_server_title (server_name, title, NIL, distribute_title, status);

    PROCEND register_title;

?? TITLE := 'remove connection from list', EJECT ??

  PROCEDURE remove_connection_from_list
   (    connection_index: integer;
    VAR wait_list: ^ost$i_wait_list;
    VAR wait_connection_list: ^nft$wait_connection_list;
    VAR message: ^nft$message_sequence;
    VAR status: ost$status);

    VAR
      current_connection: ^nft$connection,
      connection_found: boolean,
      file_id_is_valid: boolean,
      file_instance: ^bat$task_file_entry,
      file_name: amt$local_file_name,
      ignore_status: ost$status,
      io_station: ^nft$io_station,
      next_io_station: ^nft$io_station,
      ntf_operator: ^nft$connection;

?? NEWTITLE := 'clean up operated station', EJECT ??

    PROCEDURE clean_up_operated_station
      (    connection: ^nft$connection;
       VAR message: ^nft$message_sequence;
       VAR status: ost$status);

      VAR
        connection_pt: ^nft$pointer_list_entry,
        di_connection: ^nft$connection,
        io_station: ^nft$io_station;

      io_station := connection^.operating_station;
      IF io_station^.usage <> nfc$ntf_remote_system THEN
        connection_pt := io_station^.scfdi_connection_pointers;

        WHILE connection_pt <> NIL DO
          di_connection := connection_pt^.connection;
          send_stop_io_station_msg (message, io_station^.name, di_connection, status);
          connection_pt := connection_pt^.link;
        WHILEND;
      IFEND;

      IF io_station^.usage = nfc$private_io_station THEN
        move_files_back_to_unknown_q (io_station);
      IFEND;

      io_station^.operator_assigned := FALSE;
      io_station^.connected_operator := NIL;
      IF io_station^.usage <> nfc$ntf_remote_system THEN
        io_station^.station_operational := (io_station^.usage = nfc$public_io_station);
      IFEND;

    PROCEND clean_up_operated_station;
?? TITLE := 'find connection in io station', EJECT ??

    PROCEDURE find_connection_in_io_station
      (    io_station: ^nft$io_station;
           connection: ^nft$connection;
       VAR connection_found: boolean);

      VAR
        connection_pointer: ^nft$pointer_list_entry,
        di_connection: ^nft$connection;

      connection_pointer := io_station^.scfdi_connection_pointers;
      connection_found := FALSE;
      WHILE (connection_pointer <> NIL) AND
            (NOT connection_found) DO
        di_connection := connection_pointer^.connection;
        connection_found := di_connection = connection;
        connection_pointer := connection_pointer^.link;
      WHILEND;

    PROCEND find_connection_in_io_station;
?? TITLE := 'remove_ve_client_queue_files', EJECT ??

    PROCEDURE remove_ve_client_queue_files
      (    connection: ^nft$connection);

      VAR
        back_link: ^nft$output_queue_file,
        current_file: ^nft$output_queue_file,
        device: ^nft$batch_device,
        file_was_not_in_selected_q: boolean,
        io_station: ^nft$io_station,
        link: ^nft$output_queue_file,
        prior_ve_client_file: ^nft$output_queue_file,
        pointer_to_q: ^^nft$output_queue_file,
        pointer_to_q_found: boolean,
        selected_file: ^nft$selected_file;

?? NEWTITLE := 'get pointer to q', EJECT ??

      PROCEDURE get_pointer_to_q
        (    q_file: ^nft$output_queue_file;
         VAR q_pointer_found: boolean;
         VAR q_pointer: ^^nft$output_queue_file);

        VAR
          alias_pt: ^nft$alias,
          connection: ^nft$connection,
          io_station: ^nft$io_station,
          station_list: ^nft$pointer_list_entry;

        q_pointer_found := FALSE;
        IF q_file^.ios_usage <> nfc$ntf_remote_system THEN
          alias_pt := scfs_tables.first_station_name_alias;
        ELSE
          alias_pt := scfs_tables.first_ntf_acc_remote_system;
        IFEND;

        WHILE (NOT q_pointer_found) AND (alias_pt <> NIL) DO
          CASE q_file^.ios_usage OF
          = nfc$public_io_station, nfc$ntf_remote_system =
            q_pointer_found := q_file^.ios_name = alias_pt^.name;

          = nfc$private_io_station =
            station_list := alias_pt^.station_list;
            io_station := station_list^.io_station;
            IF io_station^.operator_assigned THEN
              connection := io_station^.connected_operator;
              q_pointer_found := (q_file^.operator_name = connection^.user) AND (q_file^.operator_family =
                    connection^.family) AND (io_station^.usage = nfc$private_io_station);
            IFEND;
          CASEND;
          IF q_pointer_found THEN
            q_pointer := ^alias_pt^.queue;
          ELSE
            alias_pt := alias_pt^.link;
          IFEND;
        WHILEND;

        IF (q_file^.ios_usage = nfc$private_io_station) AND
              (NOT q_pointer_found) AND (q_file =
              scfs_tables.unknown_private_operators_q) THEN
          q_pointer := ^scfs_tables.unknown_private_operators_q;
          q_pointer_found := TRUE;
       IFEND;

      PROCEND get_pointer_to_q;
?? OLDTITLE, EJECT ??
      pointer_to_q := NIL;
      current_file := connection^.scfve_queue;
      WHILE current_file <> NIL DO
        selected_file := NIL;
        file_was_not_in_selected_q := TRUE;
        IF current_file^.ios_usage <> nfc$ntf_remote_system THEN
          find_station_and_selected_file (current_file^.system_file_name, io_station,
                selected_file);
          file_was_not_in_selected_q := (selected_file = NIL);
          IF selected_file <> NIL THEN
            remove_selected_file (io_station, selected_file);
          IFEND;
        IFEND;

        IF file_was_not_in_selected_q THEN
          back_link := current_file^.back_link;
          link := current_file^.link;

          IF current_file^.back_link = NIL THEN
            get_pointer_to_q (current_file, pointer_to_q_found, pointer_to_q);
            IF pointer_to_q_found THEN
              pointer_to_q^ := current_file^.link;
            IFEND;
            IF link <> NIL THEN
              link^.back_link := NIL;
            IFEND;
          ELSE
            back_link^.link := current_file^.link;
            IF link <> NIL THEN
              link^.back_link := current_file^.back_link;
            IFEND;
          IFEND;
        IFEND;

        device := current_file^.assigned_device;
        IF device <> NIL THEN
          device^.current_file := NIL;
        IFEND;

        prior_ve_client_file := current_file;
        current_file := current_file^.next_scfve_queue;

        FREE prior_ve_client_file;
      WHILEND;

    PROCEND remove_ve_client_queue_files;
?? OLDTITLE, EJECT ??

    current_connection := wait_connection_list^ [connection_index];

    delete_connection_from_tables (current_connection);
    remove_from_wait_lists (connection_index, wait_list, wait_connection_list);
    IF scfs_event_logging THEN
      log_terminated_connection (current_connection^);
    IFEND;

    CASE current_connection^.kind OF
    = nfc$scfdi_connection =
      io_station := scfs_tables.first_io_station;
      WHILE io_station <> NIL DO
        find_connection_in_io_station (io_station, current_connection, connection_found);
        IF connection_found THEN
          next_io_station := io_station^.link;
          delete_io_station (current_connection, io_station, message, wait_list,
                wait_connection_list, status);
          io_station := next_io_station;
        ELSE
          io_station := io_station^.link;
        IFEND;
      WHILEND;

      io_station := scfs_tables.first_ntf_remote_system;
      WHILE io_station <> NIL DO
        next_io_station := io_station^.link;
        delete_ntf_remote_system (io_station, current_connection, FALSE, 1);
        io_station := next_io_station;
      WHILEND;

      delete_all_unreachable_btfs_di (current_connection^.btfs_di_title);

    = nfc$scfve_connection, nfc$ntfve_connection =
      remove_ve_client_queue_files (current_connection);
      clear_unreachable_btfs_di_list (current_connection);

    = nfc$operator_connection, nfc$ntf_operator_connection =
      IF current_connection^.operating_station <> NIL THEN
        clean_up_operated_station (current_connection, message, status);
      IFEND;

      IF current_connection^.kind = nfc$ntf_operator_connection THEN
        IF current_connection^.next_ntf_operator <> NIL THEN
          ntf_operator := current_connection^.next_ntf_operator;
          ntf_operator^.prior_ntf_operator := current_connection^.prior_ntf_operator;
        IFEND;

        IF current_connection^.prior_ntf_operator <> NIL THEN
          ntf_operator := current_connection^.prior_ntf_operator;
          ntf_operator^.next_ntf_operator := current_connection^.next_ntf_operator;
        ELSE
          scfs_tables.first_ntf_operator := current_connection^.next_ntf_operator;
        IFEND;
      IFEND;
    ELSE
      ;
    CASEND;

    bap$validate_file_identifier (current_connection^.id, file_instance, file_id_is_valid);
    IF file_id_is_valid THEN
      file_name := file_instance^.local_file_name;
      fsp$close_file (current_connection^.id, status);
      amp$return (file_name, ignore_status);
    IFEND;

    FREE current_connection;

  PROCEND remove_connection_from_list;
?? TITLE := 'remove from wait lists', EJECT ??

  PROCEDURE remove_from_wait_lists
    (    index: integer;
     VAR wait_list: ^ost$i_wait_list;
     VAR wait_connection_list: ^nft$wait_connection_list);

    VAR
      last_index: integer;

    last_index := UPPERBOUND (wait_list^);
    IF (last_index >= 3) AND (last_index <> index) THEN
      wait_list^ [index] := wait_list^ [last_index];
      wait_connection_list^ [index] := wait_connection_list^ [last_index];
      wait_connection_list^ [index]^.wait_list_index := index;
    IFEND;

    RESET wait_list_seq;
    NEXT wait_list: [1 .. (last_index - 1)] IN wait_list_seq;

    RESET wait_connection_list_seq;
    NEXT wait_connection_list: [wait_connection_list_lowest .. (last_index - 1)] IN wait_connection_list_seq;

  PROCEND remove_from_wait_lists;
?? TITLE := 'remove_selected_file', EJECT ??

  PROCEDURE remove_selected_file
    (    io_station: ^nft$io_station;
     VAR selected_file: ^nft$selected_file);

    VAR
      back_link: ^nft$selected_file,
      link: ^nft$selected_file,
      top_selected_file_in_q: ^nft$selected_file;

    IF selected_file = io_station^.selected_files_queue THEN
      io_station^.selected_files_queue := selected_file^.link;
      IF io_station^.selected_files_queue <> NIL THEN
        top_selected_file_in_q := io_station^.selected_files_queue;
        top_selected_file_in_q^.back_link := NIL;
      IFEND;
    ELSE
      back_link := selected_file^.back_link;
      back_link^.link := selected_file^.link;

      IF selected_file^.link <> NIL THEN
        link := selected_file^.link;
        link^.back_link := selected_file^.back_link;
      IFEND;
    IFEND;

    IF selected_file = io_station^.last_selected_file_in_q THEN
      io_station^.last_selected_file_in_q := selected_file^.back_link;
    IFEND;

    FREE selected_file;

  PROCEND remove_selected_file;
?? TITLE := 'search_alias_list_for_file_name', EJECT ??

  PROCEDURE search_alias_list_for_file_name
    (    io_station: ^nft$io_station;
         file_name: ost$name;
     VAR matching_alias_entry: ^nft$alias;
     VAR matching_q_file: ^nft$output_queue_file;
     VAR duplicate_file_name: boolean);

    VAR
      alias_entry: ^nft$alias,
      file_found: boolean,
      file_match: boolean,
      index: 0 .. 4,
      local_status: ost$status,
      more_aliases: boolean,
      ntf_acc_remote_system_ptr: ^nft$pointer_list_entry,
      q_file: ^nft$output_queue_file;

    duplicate_file_name := FALSE;
    file_found := FALSE;
    file_match := FALSE;
    index := 0;

    q_file := NIL;
    matching_q_file := NIL;
    matching_alias_entry := NIL;
    IF io_station^.usage <> nfc$ntf_remote_system THEN
      more_aliases := TRUE;
    ELSE
      ntf_acc_remote_system_ptr := io_station^.ntf_acc_remote_system_ptr_list;
      more_aliases := ntf_acc_remote_system_ptr <> NIL;
    IFEND;

  /search_alias_list/
    WHILE more_aliases AND (NOT duplicate_file_name) DO
      IF io_station^.usage <> nfc$ntf_remote_system THEN
        alias_entry := io_station^.alias_list [index];
      ELSE
        alias_entry := ntf_acc_remote_system_ptr^.ntf_acc_remote_system;
      IFEND;

      IF (alias_entry <> NIL) AND (alias_entry^.queue <> NIL) THEN
        q_file := alias_entry^.queue;

      /search_queue_file_list/
        WHILE (q_file <> NIL) AND (NOT duplicate_file_name) DO

          file_match := (file_name = q_file^.system_file_name) OR
                (file_name = q_file^.user_file_name);
          IF file_match THEN

{ The following logic causes MATCHING_Q_FILE and MATCHING_ALIAS_ENTRY to be set once and only once.

            duplicate_file_name := file_found AND file_match;
            IF (NOT duplicate_file_name) THEN
              file_found := file_match;
              matching_q_file := q_file;
              matching_alias_entry := alias_entry;
            IFEND;
          IFEND;

          IF NOT duplicate_file_name THEN
            q_file := q_file^.link;
          IFEND;
        WHILEND /search_queue_file_list/;
      IFEND;

      IF io_station^.usage <> nfc$ntf_remote_system THEN
        index := index + 1;
        more_aliases := index <= 3;
      ELSE
        ntf_acc_remote_system_ptr := ntf_acc_remote_system_ptr^.link;
        more_aliases := ntf_acc_remote_system_ptr <> NIL;
      IFEND;
    WHILEND /search_alias_list/;

    IF duplicate_file_name THEN
      matching_q_file := NIL;
    IFEND;

  PROCEND search_alias_list_for_file_name;
?? TITLE := 'search_selected_q_for_file', EJECT ??

  PROCEDURE search_selected_q_for_file
    (    io_station: ^nft$io_station;
         file_name: ost$name;
     VAR q_file: ^nft$output_queue_file;
     VAR selected_file: ^nft$selected_file;
     VAR file_in_selected_q: boolean;
     VAR duplicate_file_name: boolean);

    VAR
      file_match: boolean,
      selected_queue_file: ^nft$selected_file;

    duplicate_file_name := FALSE;
    file_in_selected_q := FALSE;
    file_match := FALSE;
    q_file := NIL;
    selected_file := NIL;

    selected_queue_file := io_station^.selected_files_queue;
    WHILE selected_queue_file <> NIL DO
      q_file := selected_queue_file^.output_file;
      file_match := (file_name = q_file^.system_file_name) OR
            (file_name = q_file^.user_file_name);
      IF file_match THEN
        duplicate_file_name := file_in_selected_q AND file_match;
        IF (NOT duplicate_file_name) THEN
          file_in_selected_q := file_match;
          selected_file := selected_queue_file;
        IFEND;
      IFEND;
      selected_queue_file := selected_queue_file^.link;
    WHILEND;

    IF file_in_selected_q AND (NOT duplicate_file_name) THEN
      q_file := selected_file^.output_file;
    ELSEIF duplicate_file_name THEN
      selected_file := NIL;
    IFEND;

  PROCEND search_selected_q_for_file;
?? TITLE := 'select file message msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from OPES to
{    select an output file for immediate processing.  If a device name is
{    specified, the output file is forced to that device.  The select file
{    message is rejected if the station, device or file is unknown, if the file
{    is already printing, if there is more than one file with that name in the
{    queue, or if the device is an input device.  If there are no devices
{    currently available for printing of files, the priority of the queue
{    file entry is raised to the maximum priority value.  If SCFS is able
{    to assign the file to a device, a file assignment message is sent to SCF/VE.
{
{    This procedure is also executed when a request is received from OPENTF to
{    select an NTF file for immediate processing.  If a batch stream name is
{    specified, the NTF file is forced to that stream.  The select file message
{    is rejected if the remote system, batch stream or file is unknown, if the
{    file is already being transferred, if there is more than one file with
{    that name in the queue, or if the stream is an input stream.  If there are
{    no streams currently available for transferring of files, the priority of
{    the queue file entry is raised to the maximum priority value.  If SCFS is
{    able to assign the file to a stream, a file assignment message is sent to
{    NTF/VE.

  PROCEDURE select_file_msg
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      alias_entry: ^nft$alias,
      device: ^nft$batch_device,
      device_found: boolean,
      device_alias_found: boolean,
      device_name: ost$name,
      duplicate_file_name: boolean,
      fake_station: nft$io_station,
      file_in_selected_q: boolean,
      file_name: ost$name,
      i: 0 .. 3,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      q_file: ^nft$output_queue_file,
      response_code: nft$select_file_response,
      scfve_connection: ^nft$connection,
      selected_file: ^nft$selected_file,
      unable_to_assign_file: boolean;

?? NEWTITLE := 'assign file to device', EJECT ??

    PROCEDURE assign_file_to_device
      (    q_file: ^nft$output_queue_file;
           io_station: ^nft$io_station;
       VAR message: ^nft$message_sequence;
           connection: ^nft$connection;
       VAR status: ost$status);

      VAR
        device: ^nft$batch_device,
        device_found: boolean,
        signed_on: boolean;

      device_found := FALSE;

      device := io_station^.batch_device_list;
      WHILE NOT device_found AND (device <> NIL) DO
        IF io_station^.usage = nfc$ntf_remote_system THEN
          check_for_ntf_signed_on_stream (io_station, device, signed_on);
        ELSE
          signed_on := TRUE;
        IFEND;

        IF ((q_file^.device_name = osc$null_name) OR (q_file^.device_name = automatic) OR (q_file^.device_name
              = device^.name) OR (q_file^.device_name = device^.alias_names [1]) OR (q_file^.device_name =
              device^.alias_names [2]) OR (q_file^.device_name = device^.alias_names [3])) AND signed_on THEN
          IF device_available_for_output (device) THEN
            device_found := file_and_device_match (q_file, device);
            IF device_found THEN
              q_file^.output_state := nfc$selected_for_transfer;
              q_file^.assigned_device := device;
              device^.current_file := q_file;
            IFEND;
          IFEND;
        IFEND;
        IF NOT device_found THEN
          device := device^.link;
        IFEND;
      WHILEND;

      IF device_found THEN
        send_file_assignment_msg (message, io_station^.name, q_file^, device, connection,
              status);
      ELSE
        status.normal := FALSE;
      IFEND;

    PROCEND assign_file_to_device;
?? TITLE := 'assign file to device alias', EJECT ??

    PROCEDURE assign_file_to_device_alias
      (    q_file: ^nft$output_queue_file;
           alias_name: ost$name;
           io_station: ^nft$io_station;
       VAR message: ^nft$message_sequence;
           connection: ^nft$connection;
       VAR status: ost$status);

      VAR
        device: ^nft$batch_device,
        device_found: boolean;

      device_found := FALSE;

      device := io_station^.batch_device_list;
      WHILE NOT device_found AND (device <> NIL) DO
        IF (alias_name = device^.name) OR (q_file^.device_name = device^.alias_names [1]) OR (q_file^.
              device_name = device^.alias_names [2]) OR (q_file^.device_name = device^.alias_names [3]) THEN
          device_found := device_available_for_output (device);
          IF device_found THEN
            q_file^.output_state := nfc$selected_for_transfer;
            q_file^.assigned_device := device;
            device^.current_file := q_file;
          IFEND;
        IFEND;
        IF NOT device_found THEN
          device := device^.link;
        IFEND;
      WHILEND;

      IF device_found THEN
        send_file_assignment_msg (message, io_station^.name, q_file^, device, connection,
              status);
      ELSE
        status.normal := FALSE;
      IFEND;

    PROCEND assign_file_to_device_alias;
?? TITLE := 'crack select file msg', EJECT ??

    PROCEDURE crack_select_file_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR io_station_name: ost$name;
       VAR file_name: ost$name;
       VAR device_name: ost$name;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        parameter: ^nft$select_file_parameter,
        value_length: integer;

*copyc nft$select_file_msg

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, io_station_name);

        = nfc$system_file_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, file_name);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, device_name);

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_select_file_msg;
?? TITLE := 'find device alias name', EJECT ??

    PROCEDURE find_device_alias_name
      (    device_name: ost$name;
           io_station: ^nft$io_station;
       VAR device_alias_found: boolean);

      VAR
        device: ^nft$batch_device;

      device_alias_found := FALSE;
      device := io_station^.batch_device_list;
      WHILE (NOT device_alias_found) AND (device <> NIL) DO
        device_alias_found := (device_name = device^.name) OR (device_name = device^.alias_names [1]) OR
              (device_name = device^.alias_names [2]) OR (device_name = device^.alias_names[3]);
        IF NOT device_alias_found THEN
          device := device^.link;
        IFEND;
      WHILEND;

    PROCEND find_device_alias_name;
?? TITLE := 'move_file_to_selected_queue', EJECT ??

    PROCEDURE move_file_to_selected_queue
      (    q_file: ^nft$output_queue_file;
           device_name: ost$name;
           alias_entry: ^nft$alias,
           io_station: ^nft$io_station);

      VAR
        back_link_q_file: ^nft$output_queue_file,
        last_selected: ^nft$selected_file,
        link_q_file: ^nft$output_queue_file,
        selected_file: ^nft$selected_file;

      ALLOCATE selected_file;
      selected_file^.output_file := q_file;
      selected_file^.device_selected := device_name;
      selected_file^.back_link := NIL;
      selected_file^.link := NIL;

      IF io_station^.selected_files_queue = NIL THEN
        io_station^.selected_files_queue := selected_file;
      ELSE
        selected_file^.back_link := io_station^.last_selected_file_in_q;

        last_selected := io_station^.last_selected_file_in_q;
        last_selected^.link := selected_file;
      IFEND;
      io_station^.last_selected_file_in_q := selected_file;

      IF q_file = alias_entry^.queue THEN
        alias_entry^.queue := q_file^.link;

        IF q_file^.link <> NIL THEN
          link_q_file := q_file^.link;
          link_q_file^.back_link := q_file^.back_link;
        IFEND;
      ELSE
        IF q_file^.back_link <> NIL THEN
          back_link_q_file := q_file^.back_link;
          back_link_q_file^.link := q_file^.link;
        IFEND;

        IF q_file^.link <> NIL THEN
          link_q_file := q_file^.link;
          link_q_file^.back_link := q_file^.back_link;
        IFEND;
      IFEND;

      q_file^.back_link := NIL;
      q_file^.link := NIL;

    PROCEND move_file_to_selected_queue;
?? TITLE := 'move file to top of queue', EJECT ??

    PROCEDURE move_file_to_top_of_queue
      (    alias_entry: ^nft$alias,
           q_file: ^nft$output_queue_file);

      VAR
        back_link_q_file: ^nft$output_queue_file,
        link_q_file: ^nft$output_queue_file,
        top_q_file: ^nft$output_queue_file;

      top_q_file := alias_entry^.queue;
      IF q_file <> top_q_file THEN
        IF q_file^.back_link <> NIL THEN
          back_link_q_file := q_file^.back_link;
          back_link_q_file^.link := q_file^.link;
        IFEND;

        IF q_file^.link <> NIL THEN
          link_q_file := q_file^.link;
          link_q_file^.back_link := q_file^.back_link;
        IFEND;

        q_file^.back_link := NIL;
        q_file^.link := alias_entry^.queue;

        alias_entry^.queue := q_file;
        top_q_file^.back_link := alias_entry^.queue;
      IFEND;

    PROCEND move_file_to_top_of_queue;
?? TITLE := 'move_file_to_top_of_selected_q', EJECT ??

    PROCEDURE move_file_to_top_of_selected_q
      (    selected_q_file: ^nft$selected_file;
           device_name: ost$name;
           io_station: ^nft$io_station);

      VAR
        back_link_q_file: ^nft$selected_file,
        link_q_file: ^nft$selected_file,
        top_of_selected_queue: ^nft$selected_file;

      top_of_selected_queue := io_station^.selected_files_queue;
      IF selected_q_file <> top_of_selected_queue THEN
        IF selected_q_file^.back_link  <> NIL THEN
          back_link_q_file := selected_q_file^.back_link;
          back_link_q_file^.link := selected_q_file^.link;
        IFEND;

        IF selected_q_file^.link  <> NIL THEN
          link_q_file := selected_q_file^.link;
          link_q_file^.back_link := selected_q_file^.back_link;
        IFEND;

        IF selected_q_file = io_station^.last_selected_file_in_q THEN
          io_station^.last_selected_file_in_q := selected_q_file^.back_link;
        IFEND;

        selected_q_file^.back_link := NIL;
        selected_q_file^.link := io_station^.selected_files_queue;
        top_of_selected_queue^.back_link := selected_q_file;
        io_station^.selected_files_queue := selected_q_file;
      IFEND;

    PROCEND move_file_to_top_of_selected_q ;
?? OLDTITLE, EJECT ??
    device_name := osc$null_name;

    crack_select_file_msg (message, msg_length, io_station_name, file_name, device_name, status);

    response_code := nfc$self_msg_accepted;

    find_io_station_or_remote_sys (io_station_name, connection, io_station, io_station_found);
    IF (NOT io_station_found) AND (connection^.kind = nfc$ntf_operator_connection) THEN
      create_fake_io_station_for_ntf (io_station_name, fake_station, io_station_found);
      io_station := ^fake_station;
    IFEND;

    IF NOT io_station_found THEN
      response_code := nfc$self_msg_unknown_ios;
    ELSE
      IF connection^.kind <> nfc$ntf_operator_connection THEN
        search_selected_q_for_file (io_station, file_name, q_file, selected_file,
              file_in_selected_q, duplicate_file_name);
      ELSE
        file_in_selected_q := FALSE;
      IFEND;
      IF NOT file_in_selected_q THEN
        search_alias_list_for_file_name (io_station, file_name,
              alias_entry, q_file, duplicate_file_name);
      IFEND;

      unable_to_assign_file := FALSE;
      IF duplicate_file_name THEN
        response_code := nfc$self_duplicate_file_name;
      ELSEIF q_file = NIL THEN
        response_code := nfc$self_msg_unknown_file;
      ELSEIF q_file^.output_state = nfc$selected_for_transfer THEN
        response_code := nfc$self_file_already_printing;
      ELSEIF device_name <> osc$null_name THEN
        scfve_connection := q_file^.scfve_connection;
        find_batch_device (device_name, io_station, device, device_found);
        IF NOT device_found THEN
          find_device_alias_name (device_name, io_station, device_alias_found);
          IF NOT device_alias_found THEN
            response_code := nfc$self_msg_unknown_device;
          ELSE
            assign_file_to_device_alias (q_file, device_name, io_station, message,
                  scfve_connection, status);
            IF NOT status.normal THEN
              status.normal := TRUE;
              unable_to_assign_file := TRUE;
            IFEND;
          IFEND;
        ELSEIF device_available_for_output (device) THEN
          device^.current_file := q_file;
          q_file^.output_state := nfc$selected_for_transfer;
          q_file^.assigned_device := device;
          send_file_assignment_msg (message, io_station^.name, q_file^, device, scfve_connection,
                status);
        ELSE
          IF input_device_or_stream (device) THEN
            response_code := nfc$self_wrong_device_type;
          ELSE
            unable_to_assign_file := TRUE;
          IFEND;
        IFEND;
      ELSE
        scfve_connection := q_file^.scfve_connection;
        assign_file_to_device (q_file, io_station, message, scfve_connection, status);
        IF NOT status.normal THEN
          status.normal := TRUE;
          unable_to_assign_file := TRUE;
        IFEND;
      IFEND;
    IFEND;

    IF unable_to_assign_file AND (response_code = nfc$self_msg_accepted) THEN
      q_file^.output_state := nfc$eligible_for_transfer;
      IF connection^.kind = nfc$ntf_operator_connection THEN
        q_file^.initial_priority := nfc$maximum_priority;
        q_file^.device_name := device_name;
        move_file_to_top_of_queue (alias_entry, q_file);
      ELSEIF file_in_selected_q THEN
        move_file_to_top_of_selected_q (selected_file, device_name, io_station);
      ELSE
        move_file_to_selected_queue (q_file, device_name, alias_entry, io_station);
      IFEND;
    IFEND;

    send_select_file_response_msg (message, io_station_name, device_name, file_name, response_code,
          connection, status);

  PROCEND select_file_msg;
?? TITLE := 'send delete destination msg', EJECT ??

{  PURPOSE:
{    This procedure sends a message to SCF/VE when an I/O station or alias
{    has been deleted from the control facility.  SCF/VE should not send
{    file availability messages to this SCFS until the destination returns.

  PROCEDURE send_delete_destination_msg
    (VAR message: ^nft$message_sequence;
         destination: ost$name;
         control_facility: ost$name;
         connection: ^nft$connection;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      message_length: nft$message_length,
      message_type: ^nft$message_kind,
      parameter_kind: ^nft$delete_destination_param,
      parameter_kind_size: nft$message_length,
      param_length_size: nft$message_length,
      parameter_value_length: integer;

*copy nft$delete_destination_msg

    parameter_kind_size := #SIZE (nft$delete_destination_param);
    RESET message;

    NEXT message_type IN message;
    message_type^ := nfc$delete_destination;
    message_length := 1;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$destination_name;
    parameter_value_length := clp$trimmed_string_size (destination);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := destination (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$control_facility_name;
    parameter_value_length := clp$trimmed_string_size (control_facility);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := control_facility (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$null_parameter;
    message_length := message_length + parameter_kind_size;

    nfp$send_message_on_connection (message, message_length, connection^.id, status);
    IF scfs_event_logging THEN
      log_connection_message (connection^, message_length, message);
    IFEND;

  PROCEND send_delete_destination_msg;
?? TITLE := 'send device control response', EJECT ??

{  PURPOSE:
{    This procedure builds/sends a message to OPES indicating the response to
{    the following operate station commands:
{      -  change_batch_device_attributes
{      -  position_file
{      -  start_batch_device
{      -  stop_batch_device
{      -  suppress_carraige_control
{      -  terminate_transfer
{
{    This procedure also builds/sends a message to OPENTF indicating the
{    response to the following operate NTF commands:
{      -  change_batch_stream_attributes
{      -  start_batch_stream
{      -  stop_batch_stream
{      -  terminate_transfer

  PROCEDURE send_device_control_response
    (VAR message: ^nft$message_sequence;
         msg_kind: nft$message_kind;
         io_station: ost$name;
         device: ost$name;
         response: nft$device_control_resp_codes;
         connection: ^nft$connection;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      message_length: nft$message_length,
      message_type: ^nft$message_kind,
      parameter_kind: ^nft$device_control_resp_param,
      parameter_kind_size: nft$message_length,
      param_length_size: nft$message_length,
      parameter_value_length: integer,
      response_code: ^nft$device_control_resp_codes;

*copy nft$device_control_resp_msg

    parameter_kind_size := #SIZE (nft$device_control_resp_param);
    RESET message;

    NEXT message_type IN message;
    message_type^ := msg_kind;
    message_length := 1;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$io_station_name;
    parameter_value_length := clp$trimmed_string_size (io_station);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := io_station (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$device_name;
    parameter_value_length := clp$trimmed_string_size (device);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := device (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$response_code;
    NEXT response_code IN message;
    response_code^ := response;
    message_length := message_length + parameter_kind_size + 1;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$null_parameter;
    message_length := message_length + parameter_kind_size;

    nfp$send_message_on_connection (message, message_length, connection^.id, status);
    IF scfs_event_logging THEN
      log_connection_message (connection^, message_length, message);
    IFEND;

  PROCEND send_device_control_response;
?? TITLE := 'send device status msg', EJECT ??

{  PURPOSE:
{    This procedure builds/sends a message to OPES containing the device
{    status information.  Information is sent to OPES based on device type.
{
{    This procedure also builds/sends a message to OPENTF containing the batch
{    stream status information.  Information is sent to OPENTF based on stream
{    type.

  PROCEDURE send_device_status_msg
    (VAR message: ^nft$message_sequence;
         response: nft$display_status_resp_codes;
         io_station: ^nft$io_station;
         desired_device: ^nft$batch_device;
         connection: ^nft$connection;
         optimize: boolean;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      banner_page_count: ^nft$banner_page_count,
      banner_highlight_field: ^nft$banner_highlight_field,
      bytes_transferred: ^nft$input_job_size,
      carriage_control_action: ^nft$carriage_control_action,
      code_set: ^nft$code_set,
      destination_name: ost$name,
      device: ^nft$batch_device,
      device_status: ^nft$device_status,
      device_type: ^nft$device_type,
      file_ack: ^boolean,
      file_transfer_status: ^nft$file_transfer_status,
      forms_size: ^nft$forms_size,
      maximum_file_size: ^nft$device_file_size,
      message_length: nft$message_length,
      message_type: ^nft$message_kind,
      ntf_logical_line_number: ^nft$ntf_logical_line_number,
      ntf_remote_system: ^nft$io_station,
      ntf_skip_punch_count: ^nft$ntf_skip_punch_count,
      transparent_mode: ^boolean,
      page_width: ^nft$page_width,
      page_length: ^nft$page_length,
      parameter_kind: ^nft$device_sd_msg_param,
      parameter_kind_size: nft$message_length,
      param_length_size: nft$message_length,
      parameter_value_length: integer,
      percent_complete: ^nft$file_position,
      q_file: ^nft$output_queue_file,
      response_code: ^nft$display_status_resp_codes,
      suppress_carriage_control: ^nft$suppress_carriage_control,
      transmission_block_size: ^nft$transmit_block_size,
      undefined_fe_action: ^nft$format_effector_actions,
      unsupported_fe_action: ^nft$format_effector_actions,
      vfu_load_option: ^nft$vfu_load_option,
      vertical_print_density: ^nft$vertical_print_density;

*copyc nft$device_status_data_msg

    parameter_kind_size := #SIZE (nft$device_sd_msg_param);
    RESET message;

    IF optimize THEN
      device := io_station^.batch_device_list;
    ELSE
      device := desired_device;
    IFEND;

    NEXT message_type IN message;
    message_type^ := nfc$device_status_data;
    message_length := 1;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$io_station_name;
    parameter_value_length := clp$trimmed_string_size (io_station^.name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := io_station^.name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$response_code;
    NEXT response_code IN message;
    IF (device <> NIL) THEN
      response_code^ := response;
    ELSE
      response_code^ := nfc$disp_no_batch_device;
    IFEND;
    message_length := message_length + parameter_kind_size + 1;

    REPEAT
      IF (device <> NIL) THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$device_name;
        parameter_value_length := clp$trimmed_string_size (device^.name);
        parameter_value_length := clp$trimmed_string_size (device^.name);
        nfp$modify_param_value_length (parameter_value_length);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := device^.name (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size +
              parameter_value_length;
      IFEND;

      IF response_code^ = nfc$disp_msg_accepted THEN
        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$device_status;
        NEXT device_status IN message;
        device_status^ := device^.device_status;
        message_length := message_length + parameter_kind_size + 1;

        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$device_type;
        NEXT device_type IN message;
        device_type^ := device^.device_type;
        message_length := message_length + parameter_kind_size + 1;

        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$file_transfer_status_param;
        NEXT file_transfer_status IN message;
        file_transfer_status^ := device^.file_transfer_status;
        message_length := message_length + parameter_kind_size + 1;

        IF device^.terminal_model <> osc$null_name THEN
          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$terminal_model;
          parameter_value_length := clp$trimmed_string_size (device^.terminal_model);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := device^.terminal_model (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;
        IFEND;

        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$file_acknowledgement;
        NEXT file_ack IN message;
        file_ack^ := device^.file_acknowledgement;
        message_length := message_length + parameter_kind_size + 1;

        IF device^.external_characteristics [1] <> osc$null_name THEN
          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$external_characteristics_1;
          parameter_value_length := clp$trimmed_string_size (device^.external_characteristics [1]);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := device^.external_characteristics [1] (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;
        IFEND;

        IF device^.external_characteristics [2] <> osc$null_name THEN
          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$external_characteristics_2;
          parameter_value_length := clp$trimmed_string_size (device^.external_characteristics [2]);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := device^.external_characteristics [2] (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;
        IFEND;

        IF device^.external_characteristics [3] <> osc$null_name THEN
          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$external_characteristics_3;
          parameter_value_length := clp$trimmed_string_size (device^.external_characteristics [3]);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := device^.external_characteristics [3] (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;
        IFEND;

        IF device^.external_characteristics [4] <> osc$null_name THEN
          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$external_characteristics_4;
          parameter_value_length := clp$trimmed_string_size (device^.external_characteristics [4]);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := device^.external_characteristics [4] (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;
        IFEND;

        IF device^.last_unsolicited_msg_length > 0 THEN
          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$last_unsolicited_msg;
          parameter_value_length := device^.last_unsolicited_msg_length;
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := device^.last_unsolicited_msg;
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;
        IFEND;

        IF output_device_or_stream (device) THEN
          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := TRUE;
          parameter_kind^.param := nfc$maximum_file_size;
          parameter_value_length := #SIZE (nft$device_file_size);
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          NEXT maximum_file_size IN message;
          maximum_file_size^ := device^.maximum_file_size;
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$banner_page_count;
          NEXT banner_page_count IN message;
          banner_page_count^ := device^.banner_page_count;
          message_length := message_length + parameter_kind_size + 1;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$banner_highlight_field;
          NEXT banner_highlight_field IN message;
          banner_highlight_field^ := device^.banner_highlight_field;
          message_length := message_length + parameter_kind_size + 1;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$carriage_control_action;
          NEXT carriage_control_action IN message;
          carriage_control_action^ := device^.carriage_control_action;
          message_length := message_length + parameter_kind_size + 1;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$page_length;
          NEXT page_length IN message;
          page_length^ := device^.page_length;
          message_length := message_length + parameter_kind_size + 1;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$page_width;
          NEXT page_width IN message;
          page_width^ := device^.page_width;
          message_length := message_length + parameter_kind_size + 1;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := TRUE;
          parameter_kind^.param := nfc$transmission_block_size;
          parameter_value_length := #SIZE (nft$transmit_block_size);
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          NEXT transmission_block_size IN message;
          transmission_block_size^ := device^.transmission_block_size;
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;

          IF device^.alias_names [1] <> osc$null_name THEN
            NEXT parameter_kind IN message;
            parameter_kind^.param := nfc$device_alias_1;
            parameter_value_length := clp$trimmed_string_size (device^.alias_names [1]);
            parameter_kind^.length_indicated := parameter_value_length > 1;
            IF parameter_kind^.length_indicated THEN
              nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
            ELSE
              param_length_size := 0;
            IFEND;
            NEXT ascii_string: [parameter_value_length] IN message;
            ascii_string^ := device^.alias_names [1] (1, parameter_value_length);
            message_length := message_length + parameter_kind_size + param_length_size +
                  parameter_value_length;
          IFEND;

          IF device^.alias_names [2] <> osc$null_name THEN
            NEXT parameter_kind IN message;
            parameter_kind^.param := nfc$device_alias_2;
            parameter_value_length := clp$trimmed_string_size (device^.alias_names [2]);
            parameter_kind^.length_indicated := parameter_value_length > 1;
            IF parameter_kind^.length_indicated THEN
              nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
            ELSE
              param_length_size := 0;
            IFEND;
            NEXT ascii_string: [parameter_value_length] IN message;
            ascii_string^ := device^.alias_names [2] (1, parameter_value_length);
            message_length := message_length + parameter_kind_size + param_length_size +
                  parameter_value_length;
          IFEND;

          IF device^.alias_names [3] <> osc$null_name THEN
            NEXT parameter_kind IN message;
            parameter_kind^.param := nfc$device_alias_3;
            parameter_value_length := clp$trimmed_string_size (device^.alias_names [3]);
            parameter_kind^.length_indicated := parameter_value_length > 1;
            IF parameter_kind^.length_indicated THEN
              nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
            ELSE
              param_length_size := 0;
            IFEND;
            NEXT ascii_string: [parameter_value_length] IN message;
            ascii_string^ := device^.alias_names [3] (1, parameter_value_length);
            message_length := message_length + parameter_kind_size + param_length_size +
                  parameter_value_length;
          IFEND;

          IF device^.forms_code [1] <> osc$null_name THEN
            NEXT parameter_kind IN message;
            parameter_kind^.param := nfc$forms_code_1;
            parameter_value_length := clp$trimmed_string_size (device^.forms_code [1]);
            parameter_kind^.length_indicated := parameter_value_length > 1;
            IF parameter_kind^.length_indicated THEN
              nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
            ELSE
              param_length_size := 0;
            IFEND;
            NEXT ascii_string: [parameter_value_length] IN message;
            ascii_string^ := device^.forms_code [1] (1, parameter_value_length);
            message_length := message_length + parameter_kind_size + param_length_size +
                  parameter_value_length;
          IFEND;

          IF device^.forms_code [2] <> osc$null_name THEN
            NEXT parameter_kind IN message;
            parameter_kind^.param := nfc$forms_code_2;
            parameter_value_length := clp$trimmed_string_size (device^.forms_code [2]);
            parameter_kind^.length_indicated := parameter_value_length > 1;
            IF parameter_kind^.length_indicated THEN
              nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
            ELSE
              param_length_size := 0;
            IFEND;
            NEXT ascii_string: [parameter_value_length] IN message;
            ascii_string^ := device^.forms_code [2] (1, parameter_value_length);
            message_length := message_length + parameter_kind_size + param_length_size +
                  parameter_value_length;
          IFEND;

          IF device^.forms_code [3] <> osc$null_name THEN
            NEXT parameter_kind IN message;
            parameter_kind^.param := nfc$forms_code_3;
            parameter_value_length := clp$trimmed_string_size (device^.forms_code [3]);
            parameter_kind^.length_indicated := parameter_value_length > 1;
            IF parameter_kind^.length_indicated THEN
              nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
            ELSE
              param_length_size := 0;
            IFEND;
            NEXT ascii_string: [parameter_value_length] IN message;
            ascii_string^ := device^.forms_code [3] (1, parameter_value_length);
            message_length := message_length + parameter_kind_size + param_length_size +
                  parameter_value_length;
          IFEND;

          IF device^.forms_code [4] <> osc$null_name THEN
            NEXT parameter_kind IN message;
            parameter_kind^.param := nfc$forms_code_4;
            parameter_value_length := clp$trimmed_string_size (device^.forms_code [4]);
            parameter_kind^.length_indicated := parameter_value_length > 1;
            IF parameter_kind^.length_indicated THEN
              nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
            ELSE
              param_length_size := 0;
            IFEND;
            NEXT ascii_string: [parameter_value_length] IN message;
            ascii_string^ := device^.forms_code [4] (1, parameter_value_length);
            message_length := message_length + parameter_kind_size + param_length_size +
                  parameter_value_length;
          IFEND;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$suppress_carriage_control;
          NEXT suppress_carriage_control IN message;
          suppress_carriage_control^ := device^.suppress_carriage_control;
          message_length := message_length + parameter_kind_size + 1;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$code_set;
          NEXT code_set IN message;
          code_set^ := device^.code_set;
          message_length := message_length + parameter_kind_size + 1;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$vertical_print_density;
          NEXT vertical_print_density IN message;
          vertical_print_density^ := device^.vertical_print_density;
          message_length := message_length + parameter_kind_size + 1;

          IF device^.vfu_load_procedure <> osc$null_name THEN
            NEXT parameter_kind IN message;
            parameter_kind^.param := nfc$vfu_load_procedure;
            parameter_value_length := clp$trimmed_string_size (device^.vfu_load_procedure);
            parameter_kind^.length_indicated := parameter_value_length > 1;
            IF parameter_kind^.length_indicated THEN
              nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
            ELSE
              param_length_size := 0;
            IFEND;
            NEXT ascii_string: [parameter_value_length] IN message;
            ascii_string^ := device^.vfu_load_procedure (1, parameter_value_length);
            message_length := message_length + parameter_kind_size + param_length_size +
                  parameter_value_length;
          IFEND;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$forms_size;
          NEXT forms_size IN message;
          forms_size^ := device^.forms_size;
          message_length := message_length + parameter_kind_size + 1;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$undefined_fe_action;
          NEXT undefined_fe_action IN message;
          undefined_fe_action^ := device^.undefined_fe_action;
          message_length := message_length + parameter_kind_size + 1;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$unsupported_fe_action;
          NEXT unsupported_fe_action IN message;
          unsupported_fe_action^ := device^.unsupported_fe_action;
          message_length := message_length + parameter_kind_size + 1;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$vfu_load_option;
          NEXT vfu_load_option IN message;
          vfu_load_option^ := device^.vfu_load_option;
          message_length := message_length + parameter_kind_size + 1;

        ELSEIF input_device_or_stream (device) THEN
          IF device^.input_job.user_job_name <> osc$null_name THEN
            NEXT parameter_kind IN message;
            parameter_kind^.param := nfc$user_job_name;
            parameter_value_length := clp$trimmed_string_size (device^.input_job.user_job_name);
            parameter_kind^.length_indicated := parameter_value_length > 1;
            IF parameter_kind^.length_indicated THEN
              nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
            ELSE
              param_length_size := 0;
            IFEND;
            NEXT ascii_string: [parameter_value_length] IN message;
            ascii_string^ := device^.input_job.user_job_name (1, parameter_value_length);
            message_length := message_length + parameter_kind_size + param_length_size +
                  parameter_value_length;
          IFEND;

          IF device^.input_job.requested_destination <> osc$null_name THEN
            destination_name := device^.input_job.requested_destination;
          ELSE
            destination_name := device^.input_job.actual_destination;
          IFEND;
          IF destination_name <> osc$null_name THEN
            NEXT parameter_kind IN message;
            parameter_kind^.param := nfc$destination_name;
            parameter_value_length := clp$trimmed_string_size (destination_name);
            parameter_kind^.length_indicated := parameter_value_length > 1;
            IF parameter_kind^.length_indicated THEN
              nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
            ELSE
              param_length_size := 0;
            IFEND;
            NEXT ascii_string: [parameter_value_length] IN message;
            ascii_string^ := destination_name (1, parameter_value_length);
            message_length := message_length + parameter_kind_size + param_length_size +
                  parameter_value_length;
          IFEND;

{ Send up input bytes transferred only if an input job is currently being read in.

          IF (device^.input_job.input_bytes_transferred > 0) OR
                ((device^.input_job.input_bytes_transferred = 0) AND
                ((destination_name <> osc$null_name) OR (destination_name <> osc$null_name))) THEN
            NEXT parameter_kind IN message;
            parameter_kind^.length_indicated := TRUE;
            parameter_kind^.param := nfc$input_bytes_transferred;
            parameter_value_length := #SIZE (nft$input_job_size);
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
            NEXT bytes_transferred IN message;
            bytes_transferred^ := device^.input_job.input_bytes_transferred;
            message_length := message_length + parameter_kind_size + param_length_size +
                  parameter_value_length;
          IFEND;

        IFEND;

        IF (device^.current_file <> NIL) AND output_device_or_stream (device) THEN
          q_file := device^.current_file;

          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$system_file_name;
          parameter_value_length := clp$trimmed_string_size (q_file^.system_file_name);
          nfp$modify_param_value_length (parameter_value_length);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := q_file^.system_file_name (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;

          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$user_file_name;
          parameter_value_length := clp$trimmed_string_size (q_file^.user_file_name);
          nfp$modify_param_value_length (parameter_value_length);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := q_file^.user_file_name (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;

          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$system_job_name;
          parameter_value_length := clp$trimmed_string_size (q_file^.system_job_name);
          nfp$modify_param_value_length (parameter_value_length);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := q_file^.system_job_name (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;

          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$user_job_name;
          parameter_value_length := clp$trimmed_string_size (q_file^.user_job_name);
          nfp$modify_param_value_length (parameter_value_length);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := q_file^.user_job_name (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;

          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$user_name;
          parameter_value_length := clp$trimmed_string_size (q_file^.user_name);
          nfp$modify_param_value_length (parameter_value_length);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := q_file^.user_name (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;

          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$family_name;
          parameter_value_length := clp$trimmed_string_size (q_file^.family_name);
          nfp$modify_param_value_length (parameter_value_length);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := q_file^.family_name (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$percent_complete;
          NEXT percent_complete IN message;
          percent_complete^ := q_file^.percent_complete;
          message_length := message_length + parameter_kind_size + 1;
        IFEND;

        ntf_remote_system := device^.io_station;
        IF ntf_remote_system^.usage = nfc$ntf_remote_system THEN
          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := TRUE;
          parameter_kind^.param := nfc$ntf_logical_line_number;
          parameter_value_length := #SIZE (nft$ntf_logical_line_number);
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          NEXT ntf_logical_line_number IN message;
          ntf_logical_line_number^ := device^.ntf_logical_line_number;
          message_length := message_length + parameter_kind_size + param_length_size +
                parameter_value_length;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$transparent_mode;
          NEXT transparent_mode IN message;
          transparent_mode^ := device^.transparent_mode;
          message_length := message_length + parameter_kind_size + 1;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$ntf_skip_punch_count;
          NEXT ntf_skip_punch_count IN message;
          ntf_skip_punch_count^ := device^.ntf_skip_punch_count;
          message_length := message_length + parameter_kind_size + 1;
        IFEND;

        IF (optimize AND (device <> NIL)) THEN
          device := device^.link;
          IF (device <> NIL) THEN
            NEXT parameter_kind IN message;
            parameter_kind^.length_indicated := FALSE;
            parameter_kind^.param := nfc$null_parameter;
            message_length := message_length + parameter_kind_size;
          IFEND;
        IFEND;
      IFEND;
    UNTIL (NOT optimize) OR (device = NIL);

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$null_parameter;
    message_length := message_length + parameter_kind_size;

    nfp$send_message_on_connection (message, message_length, connection^.id, status);
    IF scfs_event_logging THEN
      log_connection_message (connection^, message_length, message);
    IFEND;

  PROCEND send_device_status_msg;
?? TITLE := 'send_file_acknowledgement_msg', EJECT ??

{  PURPOSE:
{    This procedure builds/sends a message to OPES containing file
{    acknowledgement information that is to be displayed to the station
{    operator.

  PROCEDURE send_file_acknowledgement_msg
    (VAR message: ^nft$message_sequence;
         device: ^nft$batch_device;
         ack_message: file_acknowledge_msg;
         job_file_name: ost$name;
         user_name: ost$name;
         file_size: integer;
         connection: ^nft$connection;
     VAR status: ost$status);

    CONST
      size_label = '   Size: ',
      size_label_length = 9,
      user_label = '   User: ',
      user_label_length = 9;

    VAR
      ascii_string: ^string ( * <= 80),
      io_station: ^nft$io_station,
      length: 0 .. osc$max_name_size,
      message_length: integer,
      message_type: ^nft$message_kind,
      messages_sent: boolean,
      parameter_kind: ^nft$operator_message_parameter,
      parameter_kind_size: nft$message_length,
      param_length_size: nft$message_length,
      parameter_value_length: integer,
      start_pos: 0 .. 256,
      str: ost$string,
      str_length: 0 .. 65535,
      text: string (256),
      text_length: 0 .. 80;

*copy nft$operator_message
?? EJECT ??

    io_station := device^.io_station;

    parameter_kind_size := #SIZE (nft$operator_message_parameter);
    RESET message;

    NEXT message_type IN message;
    message_type^ := nfc$operator_message;
    message_length := 1;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$io_station_name;
    parameter_value_length := clp$trimmed_string_size (io_station^.name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := io_station^.name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$device_name;
    parameter_value_length := clp$trimmed_string_size (device^.name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := device^.name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

{   BUILD text of file acknowledgment message.
    text := ack_message.message;
    text_length := ack_message.msg_length;

    IF (job_file_name <> osc$null_name) THEN
      start_pos := text_length + 1;
      text (start_pos, 2) := ': ';
      text_length := text_length + 2;

      start_pos := text_length + 1;
      str_length := clp$trimmed_string_size (job_file_name);
      text (start_pos, str_length) := job_file_name (1, str_length);
      text_length := text_length + str_length;

      IF (user_name <> osc$null_name) THEN
        start_pos := text_length + 1;
        text (start_pos, user_label_length) := user_label;
        text_length := text_length + user_label_length;

        start_pos := text_length + 1;
        str_length := clp$trimmed_string_size (user_name);
        text (start_pos, str_length) := user_name (1, str_length);
        text_length := text_length + str_length;
      IFEND;

      IF (file_size <> 0) THEN
        clp$convert_integer_to_string (file_size, 10, FALSE, str, status);
        IF status.normal THEN
          start_pos := text_length + 1;
          text (start_pos, size_label_length) := size_label;
          text_length := text_length + size_label_length;

          start_pos := text_length + 1;
          text (start_pos, str.size) := str.value (1, str.size);
          text_length := text_length + str.size;
        IFEND;
      IFEND;
    IFEND;
{   FILE ACKNOWLEDGEMENT text is built.

    device^.last_unsolicited_msg (1, * ) := text;
    device^.last_unsolicited_msg_length := text_length;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$text;
    parameter_value_length := text_length;
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [text_length] IN message;
    ascii_string^ := text (1, text_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$null_parameter;
    message_length := message_length + parameter_kind_size;

    IF (io_station^.usage <> nfc$ntf_remote_system) AND connection^.accept_messages THEN
      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;
    ELSEIF device^.device_type <> nfc$console THEN
      broadcast_ntf_message (message, message_length, osc$null_name, osc$null_name,
            nfc$ntf_blank_system_identifier, messages_sent, status);
    IFEND;

  PROCEND send_file_acknowledgement_msg;
?? TITLE := 'send_file_assignment_msg', EJECT ??

{  PURPOSE:
{    This procedure builds/sends a message to SCF/VE containing information
{    currently known to SCFS.  This information will be compared to SCF/VE's
{    current information on the output file.
{
{    This procedure also builds/sends a message to NTF/VE containing
{    information currently known to SCFS.  This information will be compared to
{    NTF/VE's current information on the NTF file.

  PROCEDURE send_file_assignment_msg
    (VAR message: ^nft$message_sequence;
         io_station_name: ost$name;
         q_file: nft$output_queue_file;
         device: ^nft$batch_device;
         connection: ^nft$connection;
     VAR status: ost$status);

*copyc nft$file_assignment_msg

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      banner_page_count: ^nft$banner_page_count,
      banner_highlight_field: ^nft$banner_highlight_field,
      btfs_di_title: ^nat$title_pattern,
      carriage_control_action: ^nft$carriage_control_action,
      code_set: ^nft$code_set,
      copies: ^nft$copies,
      device_type: ^nft$device_type,
      file_ack: ^boolean,
      forms_size: ^nft$forms_size,
      initial_priority: ^nft$priority,
      maximum_file_size: ^nft$device_file_size,
      message_length: nft$message_length,
      message_type: ^nft$message_kind,
      network_address: ^nft$network_address,
      ntf_acc_remote_system: ^nft$alias,
      ntf_protocol: ^nft$ntf_remote_system_protocol,
      ntf_remote_system: ^nft$io_station,
      ntf_remote_system_type: ^nft$ntf_remote_system_type,
      ntf_route_back_position: ^nft$ntf_route_back_position,
      output_initial_priority: ^nft$priority,
      page_width: ^nft$page_width,
      parameter_kind: ^nft$file_assign_msg_parameter,
      parameter_kind_size: nft$message_length,
      param_length_size: nft$message_length,
      parameter_value_length: integer,
      station_usage: ^nft$io_station_usage,
      tip_type: ^nft$tip_type,
      transmission_block_size: ^nft$transmit_block_size,
      undefined_fe_action: ^nft$format_effector_actions,
      unsupported_fe_action: ^nft$format_effector_actions,
      vertical_print_density: ^nft$file_vertical_print_density,
      vertical_print_density_dev: ^nft$vertical_print_density,
      vfu_load_option: ^nft$vfu_load_option;

?? EJECT ??

    parameter_kind_size := #SIZE (nft$file_assign_msg_parameter);
    RESET message;

    NEXT message_type IN message;
    message_type^ := nfc$file_assignment;
    message_length := 1;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$io_station_name;
    parameter_value_length := clp$trimmed_string_size (io_station_name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := io_station_name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$system_file_name;
    parameter_value_length := clp$trimmed_string_size (q_file.system_file_name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := q_file.system_file_name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$device_name;
    parameter_value_length := clp$trimmed_string_size (device^.name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := device^.name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$device_type;
    NEXT device_type IN message;
    device_type^ := q_file.device_type;
    message_length := message_length + parameter_kind_size + 1;

    IF (connection^.btf_ve_status_received AND (device^.btfs_di_title.length > 0)) THEN
      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := TRUE;
      parameter_kind^.param := nfc$btfs_di_title;
      parameter_value_length := device^.btfs_di_title.length;
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      NEXT btfs_di_title: [parameter_value_length] IN message;
      btfs_di_title^ := device^.btfs_di_title.title (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
    ELSE
      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := TRUE;
      parameter_kind^.param := nfc$btfsdi_address;
      parameter_value_length := #SIZE (nft$network_address);
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      NEXT network_address IN message;
      network_address^ := device^.btfs_di_address;
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
    IFEND;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$requested_io_station;
    parameter_value_length := clp$trimmed_string_size (q_file.ios_name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := q_file.ios_name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$requested_device;
    parameter_value_length := clp$trimmed_string_size (q_file.device_name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := q_file.device_name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$operator_name;
    parameter_value_length := clp$trimmed_string_size (q_file.operator_name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := q_file.operator_name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$operator_family;
    parameter_value_length := clp$trimmed_string_size (q_file.operator_family);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := q_file.operator_family (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$station_usage;
    NEXT station_usage IN message;
    station_usage^ := q_file.ios_usage;
    message_length := message_length + parameter_kind_size + 1;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := TRUE;
    parameter_kind^.param := nfc$copies;
    parameter_value_length := #SIZE (nft$copies);
    nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    NEXT copies IN message;
    copies^ := q_file.copies;
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    IF q_file.external_characteristics <> osc$null_name THEN
      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$external_characteristics;
      parameter_value_length := clp$trimmed_string_size (q_file.external_characteristics);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message,
              param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := q_file.external_characteristics (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
    IFEND;

    IF q_file.forms_code <> osc$null_name THEN
      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$forms_code;
      parameter_value_length := clp$trimmed_string_size (q_file.forms_code);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := q_file.forms_code (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
    IFEND;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := TRUE;
    parameter_kind^.param := nfc$output_initial_priority;
    parameter_value_length := #SIZE (nft$priority);
    nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    NEXT initial_priority IN message;
    initial_priority^ := q_file.initial_priority;
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    IF q_file.vfu_load_procedure <> osc$null_name THEN
      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$vfu_load_procedure;
      parameter_value_length := clp$trimmed_string_size (q_file.vfu_load_procedure);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := q_file.vfu_load_procedure (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
    IFEND;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$vertical_print_density;
    NEXT vertical_print_density IN message;
    vertical_print_density^ := q_file.vertical_print_density;
    message_length := message_length + parameter_kind_size + 1;

    IF q_file.ios_usage = nfc$ntf_remote_system THEN

      ntf_remote_system := device^.io_station;
      find_ntf_acc_remote_system (io_station_name, ntf_acc_remote_system);

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$ntf_remote_system_protocol;
      NEXT ntf_protocol IN message;
      ntf_protocol^ := ntf_remote_system^.ntf_protocol;
      message_length := message_length + parameter_kind_size + 1;

      IF ntf_protocol^ <> nfc$ntf_nje THEN
        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$ntf_remote_system_type;
        NEXT ntf_remote_system_type IN message;
        ntf_remote_system_type^ := ntf_acc_remote_system^.ntf_remote_system_type;
        message_length := message_length + parameter_kind_size + 1;

        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$ntf_route_back_position;
        NEXT ntf_route_back_position IN message;
        ntf_route_back_position^ := ntf_acc_remote_system^.ntf_route_back_position;
        message_length := message_length + parameter_kind_size + 1;
      IFEND;

    IFEND;

    IF connection^.kind = nfc$scfve_connection THEN
      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$banner_highlight_field;
      NEXT banner_highlight_field IN message;
      banner_highlight_field^ := device^.banner_highlight_field;
      message_length := message_length + parameter_kind_size + 1;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$banner_page_count;
      NEXT banner_page_count IN message;
      banner_page_count^ := device^.banner_page_count;
      message_length := message_length + parameter_kind_size + 1;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$carriage_control_support;
      NEXT carriage_control_action IN message;
      carriage_control_action^ := device^.carriage_control_action;
      message_length := message_length + parameter_kind_size + 1;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$code_set;
      NEXT code_set IN message;
      code_set^ := device^.code_set;
      message_length := message_length + parameter_kind_size + 1;

      IF device^.alias_names [1] <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$device_alias_1;
        parameter_value_length := clp$trimmed_string_size (device^.alias_names [1]);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := device^.alias_names [1] (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

      IF device^.alias_names [2] <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$device_alias_2;
        parameter_value_length := clp$trimmed_string_size (device^.alias_names [2]);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := device^.alias_names [2] (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

      IF device^.alias_names [3] <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$device_alias_3;
        parameter_value_length := clp$trimmed_string_size (device^.alias_names [3]);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := device^.alias_names [3] (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

      IF device^.external_characteristics [1] <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$external_characteristics_1;
        parameter_value_length := clp$trimmed_string_size (device^.external_characteristics [1]);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := device^.external_characteristics [1] (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

      IF device^.external_characteristics [2] <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$external_characteristics_2;
        parameter_value_length := clp$trimmed_string_size (device^.external_characteristics [2]);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := device^.external_characteristics [2] (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

      IF device^.external_characteristics [3] <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$external_characteristics_3;
        parameter_value_length := clp$trimmed_string_size (device^.external_characteristics [3]);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := device^.external_characteristics [3] (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

      IF device^.external_characteristics [4] <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$external_characteristics_4;
        parameter_value_length := clp$trimmed_string_size (device^.external_characteristics [4]);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := device^.external_characteristics [4] (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$file_acknowledgement;
      NEXT file_ack IN message;
      file_ack^ := device^.file_acknowledgement;
      message_length := message_length + parameter_kind_size + 1;

      IF device^.forms_code [1] <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$forms_code_1;
        parameter_value_length := clp$trimmed_string_size (device^.forms_code [1]);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := device^.forms_code [1] (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

      IF device^.forms_code [2] <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$forms_code_2;
        parameter_value_length := clp$trimmed_string_size (device^.forms_code [2]);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := device^.forms_code [2] (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

      IF device^.forms_code [3] <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$forms_code_3;
        parameter_value_length := clp$trimmed_string_size (device^.forms_code [3]);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := device^.forms_code [3] (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

      IF device^.forms_code [4] <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$forms_code_4;
        parameter_value_length := clp$trimmed_string_size (device^.forms_code [4]);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := device^.forms_code [4] (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$forms_size;
      NEXT forms_size IN message;
      forms_size^ := device^.forms_size;
      message_length := message_length + parameter_kind_size + 1;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := TRUE;
      parameter_kind^.param := nfc$maximum_file_size;
      parameter_value_length := #SIZE (nft$device_file_size);
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      NEXT maximum_file_size IN message;
      maximum_file_size^ := device^.maximum_file_size;
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$page_width;
      NEXT page_width IN message;
      page_width^ := device^.page_width;
      message_length := message_length + parameter_kind_size + 1;

      IF device^.terminal_model <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$terminal_model;
        parameter_value_length := clp$trimmed_string_size (device^.terminal_model);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := device^.terminal_model (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$tip_type;
      NEXT tip_type IN message;
      tip_type^ := device^.tip_type;
      message_length := message_length + parameter_kind_size + 1;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := TRUE;
      parameter_kind^.param := nfc$transmission_block_size;
      parameter_value_length := #SIZE (nft$transmit_block_size);
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      NEXT transmission_block_size IN message;
      transmission_block_size^ := device^.transmission_block_size;
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$undefined_fe_action;
      NEXT undefined_fe_action IN message;
      undefined_fe_action^ := device^.undefined_fe_action;
      message_length := message_length + parameter_kind_size + 1;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$unsupported_fe_action;
      NEXT unsupported_fe_action IN message;
      unsupported_fe_action^ := device^.unsupported_fe_action;
      message_length := message_length + parameter_kind_size + 1;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$dev_vertical_print_density;
      NEXT vertical_print_density_dev IN message;
      vertical_print_density_dev^ := device^.vertical_print_density;
      message_length := message_length + parameter_kind_size + 1;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$vfu_load_option;
      NEXT vfu_load_option IN message;
      vfu_load_option^ := device^.vfu_load_option;
      message_length := message_length + parameter_kind_size + 1;

      IF device^.vfu_load_procedure <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$dev_vfu_load_procedure;
        parameter_value_length := clp$trimmed_string_size (device^.vfu_load_procedure);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := device^.vfu_load_procedure (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;
    IFEND;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$null_parameter;
    message_length := message_length + parameter_kind_size;

    nfp$send_message_on_connection (message, message_length, connection^.id, status);
    IF scfs_event_logging THEN
      log_connection_message (connection^, message_length, message);
    IFEND;

  PROCEND send_file_assignment_msg;
?? TITLE := 'send_ntf_remote_command_message', EJECT ??

{  PURPOSE:
{    This procedure is executed when a message is received from OPENTF to send
{    a command to a remote system.  If the remote system can accept the
{    command, the command will be sent to the appropriate SCF/DI.  If the
{    remote system can not accept the command, a negative response will be
{    returned to OPENTF.
{
{    This procedure is also executed when a message is received from NTF/VE or
{    OPENTF to forward to NTF operators or users.  This procedure is also
{    executed when a message is received from OPENTF to forward to NTF/VE.

  PROCEDURE send_ntf_remote_command_message
    (VAR message: ^nft$message_sequence;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      client_connection: ^nft$connection,
      command_kind: nft$ntf_command_kind,
      command_text: nft$ntf_command_text,
      console_stream_name: ost$name,
      dir_conn_remote_system_name: ost$name,
      family_name: ost$name,
      logical_line: ^nft$ntf_logical_line,
      logical_line_found: boolean,
      logical_line_number: nft$ntf_logical_line_number,
      messages_sent: boolean,
      original_message: ^nft$message_sequence,
      original_msg_length: integer,
      remote_system: ^nft$io_station,
      remote_system_found: boolean,
      remote_system_name: ost$name,
      message_response: nft$ntf_send_rc_response_codes,
      operator_identifier: nft$ntf_system_identifier,
      scfdi_connection: ^nft$connection,
      signon_status: nft$device_status,
      system_identifier: nft$ntf_system_identifier,
      user_name: ost$name,
      wait_for_di_message: boolean;

*copy nft$ntf_send_remote_comm_msg
*copy nft$ntf_send_rc_response_codes
?? NEWTITLE := 'crack_send_remote_command_msg', EJECT ??

    PROCEDURE crack_send_remote_command_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR remote_system_name: ost$name;
       VAR logical_line_number: nft$ntf_logical_line_number;
       VAR command_kind: nft$ntf_command_kind;
       VAR command_text: nft$ntf_command_text;
       VAR system_identifier: nft$ntf_system_identifier;
       VAR family_name: ost$name;
       VAR user_name: ost$name;
       VAR operator_identifier: nft$ntf_system_identifier;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        kind: ^nft$ntf_command_kind,
        line_number: ^nft$ntf_logical_line_number,
        parameter: ^nft$ntf_send_remote_comm_msg,
        text: ^string ( * <= nfc$ntf_max_command_text_size),
        value_length: integer;

      status.normal := TRUE;
      remote_system_name := osc$null_name;
      family_name := osc$null_name;
      user_name := osc$null_name;
      operator_identifier := nfc$ntf_blank_system_identifier;
      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$ntf_remote_system_name =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, remote_system_name);

        = nfc$ntf_logical_line_number =
          NEXT line_number IN message;
          logical_line_number := line_number^;

        = nfc$ntf_command_kind =
          NEXT kind IN message;
          command_kind := kind^;

        = nfc$ntf_command_text =
          NEXT text: [value_length] IN message;
          command_text := text^ (1, value_length);

        = nfc$ntf_system_identifier =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, system_identifier);

        = nfc$ntf_family_name =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, family_name);

        = nfc$ntf_user_name =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, user_name);

        = nfc$ntf_operator_identifier =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, operator_identifier);

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_send_remote_command_msg;
?? TITLE := 'find_signed_on_logical_line', EJECT ??

{  PURPOSE:
{    This procedure finds a signed on logical line to an accessible remote
{    system.  The directly connected remote system name and logical line number
{    of a signed on logical line is returned.  If no signed on logical line is
{    found, a null directly connected remote system name is returned.

    PROCEDURE find_signed_on_logical_line
      (    remote_system_name: ost$name;
           connection: ^nft$connection;
       VAR dir_conn_remote_system_name: ost$name;
       VAR logical_line_number: nft$ntf_logical_line_number);

      VAR
        acc_remote_system: ^nft$alias,
        logical_line: ^nft$ntf_logical_line,
        remote_system: ^nft$io_station,
        remote_system_ptr: ^nft$pointer_list_entry;

      find_ntf_acc_remote_system (remote_system_name, acc_remote_system);
      IF acc_remote_system <> NIL THEN
        logical_line_found := FALSE;
        remote_system_ptr := acc_remote_system^.station_list;
        WHILE (NOT logical_line_found) AND (remote_system_ptr <> NIL) DO
          remote_system := remote_system_ptr^.ntf_remote_system;
          dir_conn_remote_system_name := remote_system^.name;
          logical_line_number := remote_system_ptr^.ntf_logical_line_number;
          find_ntf_logical_line (logical_line_number, remote_system, logical_line,
                logical_line_found);
          IF logical_line_found THEN
            logical_line_found := (logical_line^.signon_status = nfc$ntf_signed_on);
          IFEND;

          remote_system_ptr := remote_system_ptr^.link;
        WHILEND;

        IF NOT logical_line_found THEN
          dir_conn_remote_system_name := osc$null_name;
          logical_line_number := 1;
        IFEND;
      ELSE
        dir_conn_remote_system_name := osc$null_name;
        logical_line_number := 1;
      IFEND;

    PROCEND find_signed_on_logical_line;
?? TITLE := 'forward_send_remote_command_msg', EJECT ??

    PROCEDURE forward_send_remote_command_msg
      (VAR message: ^nft$message_sequence;
           remote_system_name: ost$name;
           console_stream_name: ost$name;
           command_kind: nft$ntf_command_kind;
           command_text: nft$ntf_command_text;
           family_name: ost$name;
           user_name: ost$name;
           connection: ^nft$connection;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        kind: ^nft$ntf_command_kind,
        message_length: integer,
        message_type: ^nft$message_kind,
        parameter_kind: ^nft$ntf_send_remote_comm_msg,
        parameter_kind_size: nft$message_length,
        param_length_size: nft$message_length,
        parameter_value_length: integer,
        text: ^string ( * <= nfc$ntf_max_command_text_size);

      parameter_kind_size := #SIZE (nft$ntf_send_remote_comm_msg);
      RESET message;

      NEXT message_type IN message;
      message_type^ := nfc$send_ntf_remote_comm_msg;
      message_length := 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$ntf_remote_system_name;
      parameter_value_length := clp$trimmed_string_size (remote_system_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := remote_system_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$ntf_console_stream_name;
      parameter_value_length := clp$trimmed_string_size (console_stream_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := console_stream_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$ntf_command_kind;
      NEXT kind IN message;
      kind^ := command_kind;
      message_length := message_length + parameter_kind_size + 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$ntf_command_text;
      parameter_value_length := clp$trimmed_string_size (command_text);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      IF parameter_value_length > 0 THEN
        NEXT text: [parameter_value_length] IN message;
        text^ := command_text (1, parameter_value_length);
      ELSE
        parameter_value_length := 1;
        NEXT text: [parameter_value_length] IN message;
        text^ := ' ';
      IFEND;
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$ntf_family_name;
      parameter_value_length := clp$trimmed_string_size (family_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := family_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$ntf_user_name;
      parameter_value_length := clp$trimmed_string_size (user_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := user_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$null_parameter;
      message_length := message_length + parameter_kind_size;

      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;

    PROCEND forward_send_remote_command_msg;
?? TITLE := 'send_remote_command_resp', EJECT ??

    PROCEDURE send_remote_command_resp
      (VAR message: ^nft$message_sequence;
           response_code: nft$ntf_send_rc_response_codes;
           remote_system_name: ost$name;
           command_kind: nft$ntf_command_kind;
           signon_status: nft$device_status;
           connection: ^nft$connection;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        kind: ^nft$ntf_command_kind,
        message_length: nft$message_length,
        message_type: ^nft$message_kind,
        parameter_kind: ^nft$ntf_send_remote_comm_resp,
        parameter_kind_size: nft$message_length,
        param_length_size: nft$message_length,
        parameter_value_length: integer,
        response_param: ^nft$ntf_send_rc_response_codes,
        signon_stat: ^nft$device_status;

*copy nft$ntf_send_remote_comm_resp

      status.normal := TRUE;
      parameter_kind_size := #SIZE (nft$ntf_send_remote_comm_resp);
      RESET message;

      NEXT message_type IN message;
      message_type^ := nfc$send_ntf_remote_comm_resp;
      message_length := 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$ntf_remote_system_name;
      parameter_value_length := clp$trimmed_string_size (remote_system_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := remote_system_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$ntf_command_kind;
      NEXT kind IN message;
      kind^ := command_kind;
      message_length := message_length + parameter_kind_size + 1;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$ntf_signon_status;
      NEXT signon_stat IN message;
      signon_stat^ := signon_status;
      message_length := message_length + parameter_kind_size + 1;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$response_code;
      NEXT response_param IN message;
      response_param^ := response_code;
      message_length := message_length + parameter_kind_size + 1;

      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;

    PROCEND send_remote_command_resp;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    original_message := message;
    original_msg_length := msg_length;
    crack_send_remote_command_msg (message, msg_length, remote_system_name, logical_line_number,
          command_kind, command_text, system_identifier, family_name, user_name, operator_identifier,
          status);
    message_response := nfc$message_accepted;
    signon_status := nfc$ntf_signed_off;
    wait_for_di_message := FALSE;
    CASE command_kind OF
    = nfc$ntf_operator_message, nfc$ntf_user_message =
      broadcast_ntf_message (original_message, original_msg_length, family_name, user_name,
            operator_identifier, messages_sent, status);
      IF NOT messages_sent THEN
        message_response := nfc$ntf_no_users_found;
      IFEND;
    = nfc$ntf_client_command =
      find_ntf_client_connection (system_identifier, client_connection);
      IF client_connection <> NIL THEN
        broadcast_ntf_message (original_message, original_msg_length, osc$null_name, osc$null_name,
              client_connection^.ntf_system_identifier, messages_sent, status);
        IF NOT messages_sent THEN
          message_response := nfc$ntf_client_not_found;
        IFEND;
      ELSE
        message_response := nfc$ntf_client_not_found;
      IFEND;
    ELSE
      IF (command_kind = nfc$ntf_command) OR (command_kind = nfc$ntf_message) THEN
        find_signed_on_logical_line (remote_system_name, connection,
              dir_conn_remote_system_name, logical_line_number);
      ELSE
        dir_conn_remote_system_name := remote_system_name;
        wait_for_di_message := TRUE;
      IFEND;

      find_ntf_remote_system (dir_conn_remote_system_name, remote_system, remote_system_found);
      IF remote_system_found THEN
        find_ntf_logical_line (logical_line_number, remote_system, logical_line,
              logical_line_found);
        IF logical_line_found THEN
          signon_status := logical_line^.signon_status;
          console_stream_name := logical_line^.console_stream_name;
          IF ((command_kind = nfc$ntf_command) OR (command_kind = nfc$ntf_message)) AND
                (signon_status <> nfc$ntf_signed_on) THEN
            message_response := nfc$ntf_incorrect_signon_status;
          ELSEIF (command_kind = nfc$ntf_signon) AND ((signon_status <> nfc$ntf_signon_failed) OR
                (signon_status <> nfc$ntf_signed_off)) THEN
            message_response := nfc$ntf_incorrect_signon_status;
          IFEND;

          IF message_response = nfc$message_accepted THEN
            scfdi_connection := logical_line^.scfdi_connection;
            forward_send_remote_command_msg (message, dir_conn_remote_system_name, console_stream_name,
                  command_kind, command_text, family_name, user_name, scfdi_connection, status);
          IFEND;
        ELSE
          message_response := nfc$ntf_remote_system_not_found;
        IFEND;
      ELSE
        message_response := nfc$ntf_remote_system_not_found;
      IFEND;
    CASEND;

    IF (NOT wait_for_di_message) OR (message_response <> nfc$message_accepted) THEN
      send_remote_command_resp (message, message_response, remote_system_name, command_kind,
              signon_status, connection, status);
    IFEND;

  PROCEND send_ntf_remote_command_message;
?? TITLE := 'send_ntf_remote_command_resp', EJECT ??

{  PURPOSE:
{    This procedure is executed when a response is received from SCF/DI for a
{    command sent to a remote system.  If an operator is connected to a remote
{    system, the response will be sent to the appropriate OPENTF.

  PROCEDURE send_ntf_remote_command_resp
    (VAR message: ^nft$message_sequence;
         message_length: integer;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      operator_connection: ^nft$connection,
      remote_system: ^nft$io_station,
      remote_system_found: boolean,
      remote_system_name: ost$name;

?? NEWTITLE := 'crack_send_remote_command_resp', EJECT ??

    PROCEDURE crack_send_remote_command_resp
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR remote_system_name: ost$name;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        parameter: ^nft$ntf_send_remote_comm_resp,
        value_length: integer;

*copy nft$ntf_send_remote_comm_resp

      status.normal := TRUE;
      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <= nfc$ntf_remote_system_name) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$ntf_remote_system_name =
          NEXT ascii_string: [value_length] IN message;
          #TRANSLATE (osv$lower_to_upper, ascii_string^, remote_system_name);

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

      RESET message TO parameter;

    PROCEND crack_send_remote_command_resp;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    crack_send_remote_command_resp (message, msg_length, remote_system_name, status);
    find_ntf_remote_system (remote_system_name, remote_system, remote_system_found);
    IF remote_system_found THEN
      IF remote_system^.operator_assigned THEN
        operator_connection := remote_system^.connected_operator;
        nfp$send_message_on_connection (message, message_length, operator_connection^.id, status);
        IF scfs_event_logging THEN
          log_connection_message (operator_connection^, message_length, message);
        IFEND;
      IFEND;
    IFEND;

  PROCEND send_ntf_remote_command_resp;
?? TITLE := 'send_ntf_signon_status_message', EJECT ??

{ PURPOSE:
{   Sends a message to all connected NTF operators when the signon status of an
{   NTF logical line changes.

  PROCEDURE send_ntf_signon_status_message
    (    description: string ( * );
         remote_system: ^nft$io_station;
         logical_line: ^nft$ntf_logical_line;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      command_text: nft$ntf_command_text,
      kind: ^nft$ntf_command_kind,
      logical_line_number: ^nft$ntf_logical_line_number,
      message: ^nft$message_sequence,
      message_length: integer,
      message_type: ^nft$message_kind,
      messages_sent: boolean,
      parameter_kind: ^nft$ntf_send_remote_comm_msg,
      parameter_kind_size: nft$message_length,
      param_length_size: nft$message_length,
      parameter_value_length: integer,
      text: ^string ( * <= nfc$ntf_max_command_text_size),
      text_length: integer;

*copy nft$ntf_send_remote_comm_msg

    status.normal := TRUE;
    PUSH message: [[REP nfc$maximum_message_length OF cell]];
    command_text := osc$null_name;
    command_text (osc$max_name_size + 1, * ) := description;
    text_length := clp$trimmed_string_size (command_text);
    command_text (text_length + 1, * ) := ' line_name=';
    text_length := text_length + 11;
    command_text (text_length + 1, * ) := logical_line^.line_name;
    parameter_kind_size := #SIZE (nft$ntf_send_remote_comm_msg);
    RESET message;

    NEXT message_type IN message;
    message_type^ := nfc$send_ntf_remote_comm_msg;
    message_length := 1;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$ntf_remote_system_name;
    parameter_value_length := clp$trimmed_string_size (remote_system^.name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;

    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := remote_system^.name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$ntf_logical_line_number;
    parameter_value_length := #SIZE (nft$ntf_logical_line_number);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;

    NEXT logical_line_number IN message;
    logical_line_number^ := logical_line^.logical_line_number;
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$ntf_command_kind;
    NEXT kind IN message;
    kind^ := nfc$ntf_operator_message;
    message_length := message_length + parameter_kind_size + 1;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$ntf_command_text;
    parameter_value_length := clp$trimmed_string_size (command_text);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;

    IF parameter_value_length > 0 THEN
      NEXT text: [parameter_value_length] IN message;
      text^ := command_text (1, parameter_value_length);
    ELSE
      parameter_value_length := 1;
      NEXT text: [parameter_value_length] IN message;
      text^ := ' ';
    IFEND;

    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$null_parameter;
    message_length := message_length + parameter_kind_size;
    broadcast_ntf_message (message, message_length, osc$null_name, osc$null_name,
          nfc$ntf_blank_system_identifier, messages_sent, status);
  PROCEND send_ntf_signon_status_message;
?? TITLE := 'send_operator_message', EJECT ??

{  PURPOSE:
{    This procedure sends a message to OPES containing information
{    for the operator to display.

  PROCEDURE send_operator_message
    (VAR message: ^nft$message_sequence;
         device: ^nft$batch_device;
         operator_message: string (*);
         connection: ^nft$connection;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * <= 80),
      io_station: ^nft$io_station,
      length: 0 .. osc$max_name_size,
      message_length: integer,
      message_type: ^nft$message_kind,
      messages_sent: boolean,
      parameter_kind: ^nft$operator_message_parameter,
      parameter_kind_size: nft$message_length,
      param_length_size: nft$message_length,
      parameter_value_length: integer;

*copy nft$operator_message
?? EJECT ??

    io_station := device^.io_station;

    parameter_kind_size := #SIZE (nft$operator_message_parameter);
    RESET message;

    NEXT message_type IN message;
    message_type^ := nfc$operator_message;
    message_length := 1;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$io_station_name;
    parameter_value_length := clp$trimmed_string_size (io_station^.name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := io_station^.name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$device_name;
    parameter_value_length := clp$trimmed_string_size (device^.name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := device^.name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

{   add on text of operator message

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$text;
    parameter_value_length := clp$trimmed_string_size (operator_message);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := operator_message (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$null_parameter;
    message_length := message_length + parameter_kind_size;

    IF io_station^.usage <> nfc$ntf_remote_system THEN
      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;
    ELSE
      broadcast_ntf_message (message, message_length, osc$null_name, osc$null_name,
            nfc$ntf_blank_system_identifier, messages_sent, status);
    IFEND;

  PROCEND send_operator_message;
?? TITLE := 'send position file di msg', EJECT ??

{  PURPOSE:
{    This procedure builds/sends a message to SCF/DI indicating the position
{    file values specified by the station operator.  These values will be
{    used to position the output file currently being transferred to the
{    device.

  PROCEDURE send_position_file_di_msg
    (VAR message: ^nft$message_sequence;
         io_station_name: ost$name;
         device_name: ost$name;
         parameter_block: string ( * );
         connection: ^nft$connection;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * ),
      message_length: nft$message_length,
      message_type: ^nft$message_kind,
      parameter_kind: ^nft$position_file_di_msg_param,
      parameter_kind_size: nft$message_length,
      param_length_size: nft$message_length,
      parameter_value_length: integer;

*copy nft$di_position_file_message

    parameter_kind_size := #SIZE (nft$position_file_di_msg_param);
    RESET message;

    NEXT message_type IN message;
    message_type^ := nfc$position_file_di;
    message_length := 1;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$io_station_name;
    parameter_value_length := clp$trimmed_string_size (io_station_name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := io_station_name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$device_name;
    parameter_value_length := clp$trimmed_string_size (device_name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := device_name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$position_parameters;
    parameter_value_length := clp$trimmed_string_size (parameter_block);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := parameter_block (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    nfp$send_message_on_connection (message, message_length, connection^.id, status);
    IF scfs_event_logging THEN
      log_connection_message (connection^, message_length, message);
    IFEND;

  PROCEND send_position_file_di_msg;
?? TITLE := 'send_queue_entry_msg', EJECT ??

{  PURPOSE:
{    This procedure builds/sends a message to OPES containing information
{    about the specified output file entry.  If there is more than one entry
{    with the file name, the information for each queue entry is returned
{    to OPES.  If optimized is true then a large number of files may be sent,
{    and the information may have to be split into more than one message.
{    For non-optimized only a small number of files are returned.
{
{    This procedure also builds/sends a message to OPENTF containing
{    information about the specified NTF file entry.  If there is more than one
{    entry with the file name, the information for each queue entry is returned
{    to OPENTF.

  PROCEDURE send_queue_entry_msg
    (VAR message: ^nft$message_sequence;
         response: nft$display_status_resp_codes;
         io_station: ^nft$io_station;
         q_file_list: ^nft$queue_file_list;
         connection: ^nft$connection;
         optimized: boolean;
     VAR status: ost$status);

    VAR
      ascii_string: ^string (* <= osc$max_name_size),
      message_length: nft$message_length,
      message_type: ^nft$message_kind,
      parameter_kind: ^nft$queue_entry_msg_parameter,
      parameter_kind_size: nft$message_length,
      param_length_size: nft$message_length,
      parameter_value_length: integer,
      q_ptr: ^nft$queue_file_list,
      response_code: ^nft$display_status_resp_codes,
      time_enqueued: ^ost$date_time;

*copyc nft$queue_entry_data_msg

?? NEWTITLE := 'build_queue_entry_msg', EJECT ??

    PROCEDURE build_queue_entry_msg
      (VAR message: ^nft$message_sequence;
       VAR message_length: nft$message_length;
           io_station: ^nft$io_station;
           parameter_kind_size: nft$message_length;
           response: nft$display_status_resp_codes;
           q_file_list: ^nft$queue_file_list;
           optimized: boolean;
       VAR q_ptr: ^nft$queue_file_list;
       VAR status: ost$status);

{ NOTE - Following constants must be kept small enough so message
{        does not exceed 65K.

      CONST
        max_queue_entries_non_opt = 10,
        max_queue_entries_opt = 128;

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        copies: ^nft$copies,
        current_date_time: ost$date_time,
        data_mode: ^nft$output_data_mode,
        destination: ost$name,
        device_type: ^nft$device_type,
        file_size: ^nft$file_size,
        local_status: ost$status,
        max_queue_entries: integer,
        number_of_queue_entries: 0 .. 10,
        output_state: ^nft$file_transfer_state,
        page_format: ^nft$page_format,
        page_length: ^nft$page_length,
        page_width: ^nft$page_width,
        parameter_kind: ^nft$queue_entry_msg_parameter,
        param_length_size: nft$message_length,
        parameter_value_length: integer,
        priority: ^nft$priority,
        q_file: ^nft$output_queue_file,
        q_position: ^integer,
        time_enqueued: ^ost$date_time,
        vertical_print_density: ^nft$file_vertical_print_density;

?? NEWTITLE := 'q_position_of_file', EJECT ??

    FUNCTION q_position_of_file
      (    q_file: ^nft$output_queue_file;
           io_station: ^nft$io_station): integer;

      VAR
        alias_entry: ^nft$alias,
        current_file: ^nft$output_queue_file,
        current_file_priority: nft$priority,
        found_q_file: boolean,
        i: 0 .. 3,
        position_in_q: integer,
        position_in_selected_q: integer,
        q_file_priority: nft$priority,
        selected_file: ^nft$selected_file;

      q_file_priority := calculate_priority (q_file, current_date_time);
      position_in_selected_q := 0;
      found_q_file := FALSE;

      selected_file := io_station^.selected_files_queue;
      WHILE (NOT found_q_file) AND (selected_file <> NIL) DO
        current_file := selected_file^.output_file;
        position_in_selected_q := position_in_selected_q + 1;
        found_q_file := current_file = q_file;
        IF found_q_file THEN
          position_in_q := position_in_selected_q;
        IFEND;
        selected_file := selected_file^.link;
      WHILEND;

      IF NOT found_q_file THEN
        position_in_q := position_in_selected_q + 1;
        FOR i := 0 TO 3 DO
          IF io_station^.alias_list [i] <> NIL THEN
            alias_entry := io_station^.alias_list [i];
            IF alias_entry^.queue <> NIL THEN
              current_file := alias_entry^.queue;
              WHILE current_file <> NIL DO
                found_q_file := found_q_file OR (current_file = q_file);
                IF current_file^.output_state = nfc$eligible_for_transfer THEN
                  current_file_priority := calculate_priority (current_file, current_date_time);
                  IF (found_q_file AND (current_file_priority > q_file_priority)) OR ((NOT found_q_file) AND
                        (current_file_priority >= q_file_priority)) THEN
                    position_in_q := position_in_q + 1;
                  IFEND;
                IFEND;

                current_file := current_file^.link;
              WHILEND;
            IFEND;
          IFEND;
        FOREND;
      IFEND;

      q_position_of_file := position_in_q;

    FUNCEND q_position_of_file;
?? OLDTITLE, EJECT ??

    pmp$get_compact_date_time (current_date_time, local_status);

    IF optimized THEN
      max_queue_entries := max_queue_entries_opt;
    ELSE
      max_queue_entries := max_queue_entries_non_opt;
    IFEND;
    number_of_queue_entries := 0;

{  The q file list contains each queue entry matching the specified file name.

  /send_info_for_each_q_entry/
    WHILE (q_ptr <> NIL) AND (number_of_queue_entries < max_queue_entries) DO
      number_of_queue_entries := number_of_queue_entries + 1;
      q_file := q_ptr^.queue_file;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$system_file_name;
      parameter_value_length := clp$trimmed_string_size (q_file^.system_file_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := q_file^.system_file_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      IF response = nfc$disp_msg_accepted THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$user_file_name;
        parameter_value_length := clp$trimmed_string_size (q_file^.user_file_name);
        nfp$modify_param_value_length (parameter_value_length);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := q_file^.user_file_name (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := TRUE;
        parameter_kind^.param := nfc$time_enqueued;
        parameter_value_length := #SIZE (ost$date_time);
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        NEXT time_enqueued IN message;
        time_enqueued^ := q_file^.time_stamp;
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := TRUE;
        parameter_kind^.param := nfc$position_in_queue;
        parameter_value_length := #SIZE (integer);
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        NEXT q_position IN message;
        IF NOT local_status.normal THEN
          q_position^ := 1;
        ELSE
          q_position^ := q_position_of_file (q_file, io_station);
        IFEND;
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := TRUE;
        parameter_kind^.param := nfc$priority;
        parameter_value_length := #SIZE (nft$priority);
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        NEXT priority IN message;
        priority^ := calculate_priority (q_file, current_date_time);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := TRUE;
        parameter_kind^.param := nfc$copies;
        parameter_value_length := #SIZE (nft$copies);
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        NEXT copies IN message;
        copies^ := q_file^.copies;
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$create_job_family_name;
        parameter_value_length := clp$trimmed_string_size (q_file^.family_name);
        nfp$modify_param_value_length (parameter_value_length);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := q_file^.family_name (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$create_system_job_name;
        parameter_value_length := clp$trimmed_string_size (q_file^.system_job_name);
        nfp$modify_param_value_length (parameter_value_length);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := q_file^.system_job_name (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$create_user_job_name;
        parameter_value_length := clp$trimmed_string_size (q_file^.user_job_name);
        nfp$modify_param_value_length (parameter_value_length);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := q_file^.user_job_name (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        IF io_station^.usage = nfc$public_io_station THEN
          destination := q_file^.ios_name;
        ELSEIF io_station^.usage = nfc$private_io_station THEN
          destination := control_facility_name;
        IFEND;

        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$destination_name;
        parameter_value_length := clp$trimmed_string_size (destination);
        nfp$modify_param_value_length (parameter_value_length);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := destination (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$device_type;
        NEXT device_type IN message;
        device_type^ := q_file^.device_type;
        message_length := message_length + parameter_kind_size + 1;

        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := TRUE;
        parameter_kind^.param := nfc$file_length;
        parameter_value_length := #SIZE (nft$file_size);
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        NEXT file_size IN message;
        file_size^ := q_file^.file_size;
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$output_data_mode;
        NEXT data_mode IN message;
        data_mode^ := q_file^.output_data_mode;
        message_length := message_length + parameter_kind_size + 1;

        IF q_file^.device_name <> osc$null_name THEN
          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$device_name;
          parameter_value_length := clp$trimmed_string_size (q_file^.device_name);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := q_file^.device_name (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
        IFEND;

        IF q_file^.external_characteristics <> osc$null_name THEN
          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$external_characteristics;
          parameter_value_length := clp$trimmed_string_size (q_file^.external_characteristics);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := q_file^.external_characteristics (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
        IFEND;

        IF q_file^.forms_code <> osc$null_name THEN
          NEXT parameter_kind IN message;
          parameter_kind^.param := nfc$forms_code;
          parameter_value_length := clp$trimmed_string_size (q_file^.forms_code);
          parameter_kind^.length_indicated := parameter_value_length > 1;
          IF parameter_kind^.length_indicated THEN
            nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          ELSE
            param_length_size := 0;
          IFEND;
          NEXT ascii_string: [parameter_value_length] IN message;
          ascii_string^ := q_file^.forms_code (1, parameter_value_length);
          message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
        IFEND;

        IF q_file^.device_type = nfc$printer THEN
          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$page_format;
          NEXT page_format IN message;
          page_format^ := q_file^.page_format;
          message_length := message_length + parameter_kind_size + 1;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$page_length;
          NEXT page_length IN message;
          page_length^ := q_file^.page_length;
          message_length := message_length + parameter_kind_size + 1;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$page_width;
          NEXT page_width IN message;
          page_width^ := q_file^.page_width;
          message_length := message_length + parameter_kind_size + 1;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$vertical_print_density;
          NEXT vertical_print_density IN message;
          vertical_print_density^ := q_file^.vertical_print_density;
          message_length := message_length + parameter_kind_size + 1;

          IF q_file^.vfu_load_procedure <> osc$null_name THEN
            NEXT parameter_kind IN message;
            parameter_kind^.param := nfc$vfu_load_procedure;
            parameter_value_length := clp$trimmed_string_size (q_file^.vfu_load_procedure);
            parameter_kind^.length_indicated := parameter_value_length > 1;
            IF parameter_kind^.length_indicated THEN
              nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
            ELSE
              param_length_size := 0;
            IFEND;
            NEXT ascii_string: [parameter_value_length] IN message;
            ascii_string^ := q_file^.vfu_load_procedure (1, parameter_value_length);
            message_length := message_length + parameter_kind_size + param_length_size +
                  parameter_value_length;
          IFEND;

          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := FALSE;
          parameter_kind^.param := nfc$scfs_output_status;
          NEXT output_state IN message;
          output_state^ := q_file^.output_state;
          message_length := message_length + parameter_kind_size + 1;
        IFEND;

        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$creating_user_name;
        parameter_value_length := clp$trimmed_string_size (q_file^.user_name);
        nfp$modify_param_value_length (parameter_value_length);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := q_file^.user_name (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

{  The null parameter is used to let OPES know when the data for each queue
{  entry terminates.  There may be more than one queue file entry in SCFS's
{  queues with the given name, so each entry with that name is returned.

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$null_parameter;
      message_length := message_length + parameter_kind_size;

     q_ptr := q_ptr^.link;
   WHILEND /send_info_for_each_q_entry/;

   IF (optimized) AND (q_ptr <> NIL) AND (number_of_queue_entries = max_queue_entries) THEN
     parameter_kind^.param := nfc$queue_entry_data_continues;
   IFEND

   PROCEND build_queue_entry_msg;
?? OLDTITLE, EJECT ??

    parameter_kind_size := #SIZE (nft$queue_entry_msg_parameter);
    q_ptr := q_file_list;

    REPEAT
      RESET message;

      NEXT message_type IN message;
      message_type^ := nfc$queue_entry_data;
      message_length := 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$io_station_name;
      parameter_value_length := clp$trimmed_string_size (io_station^.name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := io_station^.name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$response_code;
      NEXT response_code IN message;
      response_code^ := response;
      message_length := message_length + parameter_kind_size + 1;

      IF (q_file_list <> NIL) THEN
        build_queue_entry_msg (message, message_length, io_station,
              parameter_kind_size, response, q_file_list, optimized, q_ptr, status);
      ELSE
        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := FALSE;
        parameter_kind^.param := nfc$null_parameter;
        message_length := message_length + parameter_kind_size;
      IFEND;

      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;
    UNTIL (NOT optimized) OR (q_ptr = NIL);

  PROCEND send_queue_entry_msg;
?? TITLE := 'send queue entry list msg', EJECT ??

{  PURPOSE:
{    This procedure builds/sends a message to OPES containing a list of all
{    system file names and their current priority in the output queue.
{
{    This procedure also builds/sends a message to OPENTF containing a list of
{    all system file names and their current priority in the NTF queue.

  PROCEDURE send_queue_entry_list_msg
    (    response: nft$display_status_resp_codes;
         io_station: ^nft$io_station;
         all_or_top_10: nft$all_or_top_10_q_entries;
         connection: ^nft$connection;
     VAR status: ost$status);

    TYPE
      file_priority_list = record
        link: ^file_priority_list,
        file_priority: nft$file_and_priority,
      recend;

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      count: ^nft$file_count,
      count_size: 0 .. 255,
      f_p_l: ^file_priority_list,
      file_count: nft$file_count,
      file_list: ^file_priority_list,
      message: ^nft$message_sequence,
      message_length: nft$message_length,
      message_type: ^nft$message_kind,
      parameter_kind: ^nft$q_entry_list_data_msg_param,
      parameter_kind_size: nft$message_length,
      param_length_size: nft$message_length,
      parameter_value_length: integer,
      q_file_info: ^nft$file_and_priority,
      response_code: ^nft$display_status_resp_codes;

*copyc nft$q_entry_list_data_msg
?? NEWTITLE := 'get_top_10_q_entries', EJECT ??

    PROCEDURE get_top_10_q_entries
      (    io_station: ^nft$io_station;
       VAR file_list: ^file_priority_list;
       VAR file_count: nft$file_count;
       VAR status: ost$status);

      TYPE
        top_10_list = record
          priority: integer,
          name: ost$name,
        recend;

      VAR
        alias_entry: ^nft$alias,
        current_time: ost$date_time,
        file_priority: ^file_priority_list,
        i: nft$file_count,
        q_file: ^nft$output_queue_file,
        q_priority: nft$priority,
        selected_file: ^nft$selected_file,
        top_10: array [1 .. 10] of top_10_list;

?? NEWTITLE := 'put_file_in_top_10', EJECT ??

      PROCEDURE put_file_in_top_10
        (    system_file_name: ost$name;
             q_priority: nft$priority;
         VAR top_10: array [1 .. 10] OF top_10_list;
         VAR file_count: nft$file_count);

        VAR
          i: nft$file_count,
          priority_slot: nft$file_count;

        IF file_count = 0 THEN
          file_count := 1;
          top_10 [1].priority := q_priority;
          top_10 [1].name := system_file_name;

        ELSEIF (file_count = 10) AND (q_priority <= top_10 [file_count].priority) THEN
          ; { This file does not belong in  the top 10.

        ELSEIF (file_count < 10) AND (q_priority <= top_10 [file_count].priority) THEN
          file_count := file_count + 1;
          top_10 [file_count].priority := q_priority;
          top_10 [file_count].name := system_file_name;

        ELSE

        /find_priority_slot/
          FOR i := 1 TO file_count DO
            IF q_priority > top_10 [i].priority THEN
              EXIT /find_priority_slot/;
            IFEND;
          FOREND /find_priority_slot/;
          priority_slot := i;

          IF file_count < 10 THEN
            file_count := file_count + 1;
          IFEND;
          FOR i := file_count DOWNTO (priority_slot + 1) DO
            top_10 [i] := top_10 [i - 1];
          FOREND;
          top_10 [priority_slot].priority := q_priority;
          top_10 [priority_slot].name := system_file_name;
        IFEND;

      PROCEND put_file_in_top_10;
?? OLDTITLE, EJECT ??
      file_list := NIL;
      file_count := 0;
      pmp$get_compact_date_time (current_time, status);

      IF (io_station^.usage <> nfc$ntf_remote_system) AND (io_station^.selected_files_queue <> NIL) THEN
        q_priority := nfc$maximum_priority;
        selected_file := io_station^.selected_files_queue;
        WHILE selected_file <> NIL DO
          q_file := selected_file^.output_file;
          put_file_in_top_10 (q_file^.system_file_name, q_priority, top_10, file_count);
          selected_file := selected_file^.link;
        WHILEND;
      IFEND;

      FOR i := 0 TO 3 DO
        IF io_station^.alias_list [i] <> NIL THEN
          alias_entry := io_station^.alias_list [i];
          IF alias_entry^.queue <> NIL THEN
            q_file := alias_entry^.queue;
            WHILE q_file <> NIL DO
              q_priority := calculate_priority (q_file, current_time);
              put_file_in_top_10 (q_file^.system_file_name, q_priority, top_10, file_count);

              q_file := q_file^.link;
            WHILEND;
          IFEND;
        IFEND;
      FOREND;

      IF file_count > 0 THEN
        ALLOCATE file_list: [clp$trimmed_string_size (top_10 [1].name)];
        file_list^.link := NIL;
        file_list^.file_priority.priority := top_10 [1].priority;
        file_list^.file_priority.name := top_10 [1].name;
        file_priority := file_list;

        FOR i := 2 TO file_count DO
          ALLOCATE file_priority^.link: [clp$trimmed_string_size (top_10 [i].name)];
          file_priority := file_priority^.link;
          file_priority^.link := NIL;
          file_priority^.file_priority.priority := top_10 [i].priority;
          file_priority^.file_priority.name := top_10 [i].name;
        FOREND;
      IFEND;

    PROCEND get_top_10_q_entries;
?? TITLE := 'get all q entries', EJECT ??

    PROCEDURE get_all_q_entries
      (    io_station: ^nft$io_station;
       VAR file_list: ^file_priority_list;
       VAR file_count: nft$file_count;
       VAR status: ost$status);

      VAR
        alias_entry: ^nft$alias,
        current_time: ost$date_time,
        file_priority: ^file_priority_list,
        i: 0 .. 3,
        q_file: ^nft$output_queue_file,
        selected_file: ^nft$selected_file;

?? NEWTITLE := 'add_to_file_priority_list', EJECT ??

      PROCEDURE add_to_file_priority_list
        (    q_file: ^nft$output_queue_file;
         VAR file_count: nft$file_count;
         VAR file_list: ^file_priority_list;
         VAR file_priority: ^file_priority_list);

        VAR
          name_length: ost$name_size;

        name_length := clp$trimmed_string_size (q_file^.system_file_name);
        IF file_list = NIL THEN
          ALLOCATE file_list: [name_length];
          file_priority := file_list;
        ELSE
          ALLOCATE file_priority^.link: [name_length];
          file_priority := file_priority^.link;
        IFEND;
        file_priority^.link := NIL;

        file_priority^.file_priority.priority := calculate_priority (q_file, current_time);
        file_priority^.file_priority.name := q_file^.system_file_name (1, name_length);
        file_count := file_count + 1;

      PROCEND add_to_file_priority_list;
?? OLDTITLE, EJECT ??
      file_list := NIL;
      file_count := 0;
      pmp$get_compact_date_time (current_time, status);

      IF (io_station^.usage <> nfc$ntf_remote_system) AND (io_station^.selected_files_queue <> NIL) THEN
        selected_file := io_station^.selected_files_queue;
        WHILE selected_file <> NIL DO
          q_file := selected_file^.output_file;
          add_to_file_priority_list (q_file, file_count, file_list, file_priority);
          selected_file := selected_file^.link;
        WHILEND;
      IFEND;

      FOR i := 0 TO 3 DO
        IF io_station^.alias_list [i] <> NIL THEN
          alias_entry := io_station^.alias_list [i];
          IF alias_entry^.queue <> NIL THEN
            q_file := alias_entry^.queue;
            WHILE q_file <> NIL DO
              add_to_file_priority_list (q_file, file_count, file_list, file_priority);
              q_file := q_file^.link;
            WHILEND;
          IFEND;
        IFEND;
      FOREND;

    PROCEND get_all_q_entries;
?? OLDTITLE, EJECT ??
    count_size := #SIZE (nft$file_count);
    parameter_kind_size := #SIZE (nft$q_entry_list_data_msg_param);
    PUSH message: [[REP nfc$maximum_send_message_length OF cell]];
    RESET message;

    NEXT message_type IN message;
    message_type^ := nfc$queue_entry_list_data;
    message_length := 1;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$io_station_name;
    parameter_value_length := clp$trimmed_string_size (io_station^.name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := io_station^.name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$response_code;
    NEXT response_code IN message;
    response_code^ := response;
    message_length := message_length + parameter_kind_size + 1;

    IF response = nfc$disp_msg_accepted THEN
      IF all_or_top_10 = nfc$top_10_q_entries THEN
        get_top_10_q_entries (io_station, file_list, file_count, status);
      ELSEIF all_or_top_10 = nfc$all_q_entries THEN
        get_all_q_entries (io_station, file_list, file_count, status);
      IFEND;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := TRUE;
      parameter_kind^.param := nfc$number_of_files;
      parameter_value_length := count_size;
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      NEXT count IN message;
      count^ := file_count;
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      WHILE file_list <> NIL DO
        f_p_l := file_list;
        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := TRUE;
        parameter_kind^.param := nfc$sys_file_and_priority;
        parameter_value_length := #SIZE (f_p_l^.file_priority);
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        NEXT q_file_info: [STRLENGTH (f_p_l^.file_priority.name)] IN message;
        q_file_info^ := f_p_l^.file_priority;
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        file_list := file_list^.link;
        FREE f_p_l;
      WHILEND;
    IFEND;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$null_parameter;
    message_length := message_length + parameter_kind_size;

    nfp$send_message_on_connection (message, message_length, connection^.id, status);
    IF scfs_event_logging THEN
      log_connection_message (connection^, message_length, message);
    IFEND;

  PROCEND send_queue_entry_list_msg;

?? NEWTITLE := 'send_queue_entry_msg_optimized', EJECT ??

{  PURPOSE:
{    This procedure is executed when a request is received from OPES for
{    detailed information about queue file entries.

  PROCEDURE send_queue_entry_msg_optimized
    (    connection: ^nft$connection;
         io_station: ^nft$io_station;
         all_or_top_10: nft$all_or_top_10_q_entries;
     VAR message: ^nft$message_sequence;
     VAR status: ost$status);

    VAR
      current_ptr: ^nft$queue_file_list,
      file_count: integer,
      ignore_status: ost$status,
      message_area: ^nft$message_sequence,
      q_file: ^nft$output_queue_file,
      q_file_list: ^nft$queue_file_list,
      q_file_ptr: ^nft$queue_file_list,
      response: nft$display_status_resp_codes;

?? NEWTITLE := 'build queue file list', EJECT ??

{  PURPOSE:
{    Build a queue file list containing each queue entry queued for the station.

    PROCEDURE build_queue_file_list
      (    io_station: ^nft$io_station;
           all_or_top_10: nft$all_or_top_10_q_entries;
       VAR q_file_list: ^nft$queue_file_list);

      VAR
        alias_pt: ^nft$alias,
        current_pointer: ^nft$queue_file_list,
        i: 0 .. 3,
        q_file: ^nft$output_queue_file,
        q_file_ptr: ^nft$queue_file_list,
        selected_file: ^nft$selected_file;

?? NEWTITLE := 'add_q_file_ptr_to_list', EJECT ??

      PROCEDURE add_q_file_ptr_to_list
        (    q_file: ^nft$output_queue_file;
         VAR q_file_list: ^nft$queue_file_list;
         VAR current_ptr: ^nft$queue_file_list);

        VAR
          q_file_ptr: ^nft$queue_file_list;

        ALLOCATE q_file_ptr;
        q_file_ptr^.queue_file := q_file;
        q_file_ptr^.link := NIL;
        IF q_file_list = NIL THEN
          q_file_list := q_file_ptr;
        ELSE
          current_ptr^.link := q_file_ptr;
        IFEND;
        current_ptr := q_file_ptr;

      PROCEND add_q_file_ptr_to_list;

?? OLDTITLE, EJECT ??

      current_pointer := NIL;
      file_count := 0;
      q_file := NIL;
      q_file_ptr := NIL;

      IF io_station^.usage <> nfc$ntf_remote_system THEN
        selected_file := io_station^.selected_files_queue;
        WHILE selected_file <> NIL DO
          q_file := selected_file^.output_file;
          add_q_file_ptr_to_list (q_file, q_file_list, current_pointer);
          file_count := file_count+1;
          IF (all_or_top_10 = nfc$top_10_q_entries) AND (file_count = 10) THEN
            RETURN;
          IFEND;
          selected_file := selected_file^.link;
        WHILEND;
      IFEND;

      FOR i := LOWERBOUND (io_station^.alias_list) TO UPPERBOUND (io_station^.alias_list) DO
        alias_pt := io_station^.alias_list [i];
        IF (alias_pt <> NIL) AND (alias_pt^.queue <> NIL) THEN
          q_file := alias_pt^.queue;
          WHILE (q_file <> NIL) DO
            add_q_file_ptr_to_list (q_file, q_file_list, current_pointer);
            file_count := file_count+1;
            IF (all_or_top_10 = nfc$top_10_q_entries) AND (file_count = 10) THEN
              RETURN;
            IFEND;
            q_file := q_file^.link;
          WHILEND;
        IFEND;
      FOREND;

    PROCEND build_queue_file_list;

?? OLDTITLE, EJECT ??

    current_ptr := NIL;
    response := nfc$disp_msg_accepted;
    q_file_list := NIL;
    q_file_ptr := NIL;

    build_queue_file_list (io_station, all_or_top_10, q_file_list);

    IF (q_file_list = NIL) THEN
      response := nfc$disp_unknown_file_name;
      message_area := message;
    ELSE
      PUSH message_area: [[REP nfc$maximum_send_message_length OF cell]];
    IFEND;

    send_queue_entry_msg (message_area, response, io_station, q_file_list, connection,
          {OPTIMIZED} TRUE, ignore_status);

{  Delete the queue file list.

    WHILE (q_file_list <> NIL) DO
      current_ptr := q_file_list;
      q_file_list := current_ptr^.link;
      FREE current_ptr;
    WHILEND;

  PROCEND send_queue_entry_msg_optimized;

?? OLDTITLE ??
?? TITLE := 'send queue status msg', EJECT ??

{  PURPOSE:
{    This procedure builds/sends a message to OPES containing information
{    on the number of files for selector(e.g. particular ec value),
{    total byte length of files for selector, age of oldest file for
{    selector and the average age of files for selector.
{
{    This procedure also builds/sends a message to OPENTF containing
{    information on the number of files for selector (e.g.  particular stream
{    type value), total byte length of files for selector, age of oldest file
{    for selector and the average age of files for selector.

  PROCEDURE send_queue_status_msg
    (VAR message: ^nft$message_sequence;
         response: nft$display_status_resp_codes;
         io_station: ^nft$io_station;
         connection: ^nft$connection;
     VAR status: ost$status);

    TYPE
      list_array = array [0 .. 3] of ^nft$q_status_data,

      q_status_list = record
        link: ^q_status_list,
        status: nft$q_status_data,
      recend;

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      count: ^nft$file_count,
      count_size: 0 .. 255,
      destination_list: list_array,
      device_name_list: ^q_status_list,
      device_type_list: ^q_status_list,
      external_characteristic_list: ^q_status_list,
      forms_code_list: ^q_status_list,
      i: 0 .. 3,
      message_length: nft$message_length,
      message_type: ^nft$message_kind,
      parameter_kind: ^nft$queue_status_msg_parameter,
      parameter_kind_size: nft$message_length,
      param_length_size: nft$message_length,
      parameter_value_length: integer,
      q_s_l: ^q_status_list,
      q_status: ^nft$q_status_data,
      response_code: ^nft$display_status_resp_codes;

*copyc nft$queue_status_data_msg
?? NEWTITLE := 'find q status info', EJECT ??

    PROCEDURE find_q_status_info
      (    io_station: ^nft$io_station;
       VAR ext_char_list: ^q_status_list;
       VAR forms_code_list: ^q_status_list;
       VAR device_name_list: ^q_status_list;
       VAR destination_list: list_array;
       VAR device_type_list: ^q_status_list);

      VAR
        alias_entry: ^nft$alias,
        current_date_time: ost$date_time,
        destination_file_age_sum: integer,
        destination_name: ost$name,
        device_name: ^q_status_list,
        device_name_file_age_sum: integer,
        device_type: ^q_status_list,
        device_type_file_age_sum: integer,
        ext_char: ^q_status_list,
        ext_char_file_age_sum: integer,
        file_age: nft$priority,
        forms_code: ^q_status_list,
        forms_code_file_age_sum: integer,
        i: 0 .. 3,
        q_file: ^nft$output_queue_file,
        selected_file: ^nft$selected_file;

?? NEWTITLE := 'add_info_to_q_status_list', EJECT ??

      PROCEDURE add_info_to_q_status_list
        (    q_file_time_stamp: ost$date_time;
             current_date_time: ost$date_time;
             q_file_file_size: nft$file_size;
         VAR file_age_sum: integer;
         VAR q_status: nft$q_status_data);

        VAR
          file_age: nft$priority;

        q_status.file_count := q_status.file_count + 1;
        q_status.total_size := q_status.total_size + q_file_file_size;
        file_age := time_in_scfs_queue (q_file_time_stamp, current_date_time);
        file_age_sum := file_age_sum + file_age;
        q_status.average_age := $INTEGER ($REAL (file_age_sum) / $REAL (q_status.file_count));
        IF file_age > q_status.oldest_age THEN
          q_status.oldest_age := file_age;
        IFEND;

      PROCEND add_info_to_q_status_list;
?? TITLE := 'add to destination list', EJECT ??

      PROCEDURE add_to_destination_list
        (    index: 0 .. 3;
             io_station: ^nft$io_station;
         VAR dest_list_array: list_array;
         VAR destination_name: ost$name);

        VAR
          operator_connection: ^nft$connection;

        IF index = 0 THEN
          IF io_station^.usage = nfc$public_io_station THEN
            destination_name := io_station^.name;
          ELSE
            destination_name := control_facility_name;
          IFEND;
        ELSE
          destination_name := io_station^.alias_names [index];
        IFEND;

        IF destination_name <> osc$null_name THEN
          ALLOCATE dest_list_array [index]: [clp$trimmed_string_size (destination_name)];

          dest_list_array [index]^.name := destination_name;
          dest_list_array [index]^.file_count := 0;
          dest_list_array [index]^.total_size := 0;
          dest_list_array [index]^.oldest_age := 0;
          dest_list_array [index]^.average_age := 0;
          IF destination_name = control_facility_name THEN
            operator_connection := io_station^.connected_operator;
            dest_list_array [index]^.operator_name := operator_connection^.user;
            dest_list_array [index]^.operator_family := operator_connection^.family;
          ELSE
            dest_list_array [index]^.operator_name := '';
            dest_list_array [index]^.operator_family := '';
          IFEND;
        IFEND;

      PROCEND add_to_destination_list;
?? TITLE := 'find device name match', EJECT ??

      PROCEDURE find_device_name_match
        (    device_name_str: ost$name;
         VAR first_device_name_list: ^q_status_list;
         VAR device_name_list: ^q_status_list);

        VAR
          last_device_name_list: ^q_status_list;

        last_device_name_list := NIL;
        device_name_list := first_device_name_list;
        WHILE device_name_list <> NIL DO
          IF device_name_list^.status.name = device_name_str THEN
            RETURN;
          IFEND;
          last_device_name_list := device_name_list;
          device_name_list := device_name_list^.link;
        WHILEND;

        ALLOCATE device_name_list: [clp$trimmed_string_size (device_name_str)];
        IF last_device_name_list <> NIL THEN
          last_device_name_list^.link := device_name_list;
        ELSE
          first_device_name_list := device_name_list;
        IFEND;

        device_name_list^.status.name := device_name_str;
        device_name_list^.status.file_count := 0;
        device_name_list^.status.total_size := 0;
        device_name_list^.status.oldest_age := 0;
        device_name_list^.status.average_age := 0;
        device_name_list^.status.operator_name := '';
        device_name_list^.status.operator_family := '';
        device_name_list^.link := NIL;

      PROCEND find_device_name_match;
?? TITLE := 'find device type match', EJECT ??

      PROCEDURE find_device_type_match
        (    device_type: nft$device_type;
         VAR first_device_type_list: ^q_status_list;
         VAR device_type_list: ^q_status_list);

        VAR
          device_type_str: ost$name,
          last_device_type_list: ^q_status_list;

        CASE device_type OF
        = nfc$reader =
          device_type_str := 'HASP READER';
        = nfc$printer =
          device_type_str := 'PRINTER';
        = nfc$punch =
          device_type_str := 'PUNCH';
        = nfc$plotter =
          device_type_str := 'PLOTTER';
        = nfc$ntf_job_transmitter =
          device_type_str := 'JOB_TRANSMITTER';
        = nfc$ntf_sysout_transmitter =
          device_type_str := 'SYSOUT_TRANSMITTER';
        ELSE
          RETURN;
        CASEND;

        last_device_type_list := NIL;
        device_type_list := first_device_type_list;
        WHILE device_type_list <> NIL DO
          IF device_type_list^.status.name = device_type_str THEN
            RETURN;
          IFEND;
          last_device_type_list := device_type_list;
          device_type_list := device_type_list^.link;
        WHILEND;

        ALLOCATE device_type_list: [clp$trimmed_string_size (device_type_str)];
        IF last_device_type_list <> NIL THEN
          last_device_type_list^.link := device_type_list;
        ELSE
          first_device_type_list := device_type_list;
        IFEND;

        device_type_list^.status.name := device_type_str;
        device_type_list^.status.file_count := 0;
        device_type_list^.status.total_size := 0;
        device_type_list^.status.oldest_age := 0;
        device_type_list^.status.average_age := 0;
        device_type_list^.status.operator_name := '';
        device_type_list^.status.operator_family := '';
        device_type_list^.link := NIL;

      PROCEND find_device_type_match;
?? TITLE := 'find ext characteristic match', EJECT ??

      PROCEDURE find_ext_characteristic_match
        (    external_characteristics: nft$external_characteristics;
         VAR first_ext_char: ^q_status_list;
         VAR ext_char: ^q_status_list);

        VAR
          last_ext_char: ^q_status_list;

        last_ext_char := NIL;
        ext_char := first_ext_char;
        WHILE ext_char <> NIL DO
          IF ext_char^.status.name = external_characteristics THEN
            RETURN;
          IFEND;
          last_ext_char := ext_char;
          ext_char := ext_char^.link;
        WHILEND;

        ALLOCATE ext_char: [clp$trimmed_string_size (external_characteristics)];
        IF last_ext_char <> NIL THEN
          last_ext_char^.link := ext_char;
        ELSE
          first_ext_char := ext_char;
        IFEND;

        ext_char^.status.name := external_characteristics;
        ext_char^.status.file_count := 0;
        ext_char^.status.total_size := 0;
        ext_char^.status.oldest_age := 0;
        ext_char^.status.average_age := 0;
        ext_char^.status.operator_name := '';
        ext_char^.status.operator_family := '';
        ext_char^.link := NIL;

      PROCEND find_ext_characteristic_match;
?? TITLE := 'find forms code match', EJECT ??

      PROCEDURE find_forms_code_match
        (    forms_code_str: nft$forms_code;
         VAR first_forms_code: ^q_status_list;
         VAR forms_code: ^q_status_list);

        VAR
          last_forms_code: ^q_status_list;

        last_forms_code := NIL;
        forms_code := first_forms_code;
        WHILE forms_code <> NIL DO
          IF forms_code^.status.name = forms_code_str THEN
            RETURN;
          IFEND;
          last_forms_code := forms_code;
          forms_code := forms_code^.link;
        WHILEND;

        ALLOCATE forms_code: [clp$trimmed_string_size (forms_code_str)];
        IF last_forms_code <> NIL THEN
          last_forms_code^.link := forms_code;
        ELSE
          first_forms_code := forms_code;
        IFEND;

        forms_code^.status.name := forms_code_str;
        forms_code^.status.file_count := 0;
        forms_code^.status.total_size := 0;
        forms_code^.status.oldest_age := 0;
        forms_code^.status.average_age := 0;
        forms_code^.status.operator_name := '';
        forms_code^.status.operator_family := '';
        forms_code^.link := NIL;

      PROCEND find_forms_code_match;
?? OLDTITLE, EJECT ??

      pmp$get_compact_date_time (current_date_time, status);
      ext_char_file_age_sum := 0;
      forms_code_file_age_sum := 0;
      destination_file_age_sum := 0;
      device_name_file_age_sum := 0;
      device_type_file_age_sum := 0;

      add_to_destination_list (0, io_station, destination_list, destination_name);

      IF (io_station^.usage <> nfc$ntf_remote_system) AND (io_station^.selected_files_queue <> NIL) THEN
        selected_file := io_station^.selected_files_queue;
        WHILE selected_file <> NIL DO
          q_file := selected_file^.output_file;
          add_info_to_q_status_list (q_file^.time_stamp, current_date_time, q_file^.file_size,
                destination_file_age_sum, destination_list [0]^);

          find_device_type_match (q_file^.device_type, device_type_list, device_type);
          add_info_to_q_status_list (q_file^.time_stamp, current_date_time, q_file^.file_size,
                device_type_file_age_sum, device_type^.status);

          IF q_file^.external_characteristics <> osc$null_name THEN
            find_ext_characteristic_match (q_file^.external_characteristics, ext_char_list, ext_char);
            add_info_to_q_status_list (q_file^.time_stamp, current_date_time, q_file^.file_size,
                  ext_char_file_age_sum, ext_char^.status);
          IFEND;

          IF q_file^.forms_code <> osc$null_name THEN
            find_forms_code_match (q_file^.forms_code, forms_code_list, forms_code);
            add_info_to_q_status_list (q_file^.time_stamp, current_date_time, q_file^.file_size,
                  forms_code_file_age_sum, forms_code^.status);
          IFEND;

          IF q_file^.device_name <> osc$null_name THEN
            find_device_name_match (q_file^.device_name, device_name_list, device_name);
            add_info_to_q_status_list (q_file^.time_stamp, current_date_time, q_file^.file_size,
                  device_name_file_age_sum, device_name^.status);
          IFEND;
          selected_file := selected_file^.link;
        WHILEND;
      IFEND;

      FOR i := 0 TO 3 DO
        IF io_station^.alias_list [i] <> NIL THEN
          alias_entry := io_station^.alias_list [i];
          IF alias_entry^.queue <> NIL THEN
            IF i <> 0 THEN
              add_to_destination_list (i, io_station, destination_list, destination_name);
            ELSE
              destination_name := destination_list [0]^.name;
            IFEND;
            q_file := alias_entry^.queue;
            WHILE q_file <> NIL DO
              IF destination_name <> osc$null_name THEN
                add_info_to_q_status_list (q_file^.time_stamp, current_date_time, q_file^.file_size,
                      destination_file_age_sum, destination_list [i]^);
              IFEND;

              find_device_type_match (q_file^.device_type, device_type_list, device_type);
              add_info_to_q_status_list (q_file^.time_stamp, current_date_time, q_file^.file_size,
                    device_type_file_age_sum, device_type^.status);

              IF q_file^.external_characteristics <> osc$null_name THEN
                find_ext_characteristic_match (q_file^.external_characteristics, ext_char_list, ext_char);
                add_info_to_q_status_list (q_file^.time_stamp, current_date_time, q_file^.file_size,
                      ext_char_file_age_sum, ext_char^.status);
              IFEND;

              IF q_file^.forms_code <> osc$null_name THEN
                find_forms_code_match (q_file^.forms_code, forms_code_list, forms_code);
                add_info_to_q_status_list (q_file^.time_stamp, current_date_time, q_file^.file_size,
                      forms_code_file_age_sum, forms_code^.status);
              IFEND;

              IF q_file^.device_name <> osc$null_name THEN
                find_device_name_match (q_file^.device_name, device_name_list, device_name);
                add_info_to_q_status_list (q_file^.time_stamp, current_date_time, q_file^.file_size,
                      device_name_file_age_sum, device_name^.status);
              IFEND;

              q_file := q_file^.link;
            WHILEND;
          IFEND;
        IFEND;
      FOREND;

    PROCEND find_q_status_info;
?? OLDTITLE, EJECT ??

    parameter_kind_size := #SIZE (nft$queue_status_msg_parameter);
    count_size := #SIZE (nft$file_count);
    RESET message;

    NEXT message_type IN message;
    message_type^ := nfc$queue_status_data;
    message_length := 1;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$io_station_name;
    parameter_value_length := clp$trimmed_string_size (io_station^.name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := io_station^.name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$response_code;
    NEXT response_code IN message;
    response_code^ := response;
    message_length := message_length + parameter_kind_size + 1;

    IF response = nfc$disp_msg_accepted THEN
      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := TRUE;
      parameter_kind^.param := nfc$file_count;
      parameter_value_length := count_size;
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      NEXT count IN message;
      count^ := count_of_files_for_station (io_station);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      external_characteristic_list := NIL;
      forms_code_list := NIL;
      device_name_list := NIL;
      destination_list [0] := NIL;
      destination_list [1] := NIL;
      destination_list [2] := NIL;
      destination_list [3] := NIL;
      device_type_list := NIL;
      find_q_status_info (io_station, external_characteristic_list, forms_code_list,
            device_name_list, destination_list, device_type_list);

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := TRUE;
      parameter_kind^.param := nfc$ext_chars_count;
      parameter_value_length := count_size;
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      NEXT count IN message;
      count^ := 0;
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      WHILE external_characteristic_list <> NIL DO
        count^ := count^ + 1;
        q_s_l := external_characteristic_list;
        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := TRUE;
        parameter_kind^.param := nfc$ext_char_and_files;
        parameter_value_length := #SIZE (q_s_l^.status);
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        NEXT q_status: [STRLENGTH (q_s_l^.status.name)] IN message;
        q_status^ := q_s_l^.status;
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        external_characteristic_list := external_characteristic_list^.link;
        FREE q_s_l;
      WHILEND;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := TRUE;
      parameter_kind^.param := nfc$forms_code_count;
      parameter_value_length := count_size;
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      NEXT count IN message;
      count^ := 0;
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      WHILE forms_code_list <> NIL DO
        count^ := count^ + 1;
        q_s_l := forms_code_list;
        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := TRUE;
        parameter_kind^.param := nfc$forms_code_and_files;
        parameter_value_length := #SIZE (q_s_l^.status);
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        NEXT q_status: [STRLENGTH (q_s_l^.status.name)] IN message;
        q_status^ := q_s_l^.status;
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        forms_code_list := forms_code_list^.link;
        FREE q_s_l;
      WHILEND;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := TRUE;
      parameter_kind^.param := nfc$device_count;
      parameter_value_length := count_size;
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      NEXT count IN message;
      count^ := 0;
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      WHILE device_name_list <> NIL DO
        count^ := count^ + 1;
        q_s_l := device_name_list;
        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := TRUE;
        parameter_kind^.param := nfc$device_names_and_files;
        parameter_value_length := #SIZE (q_s_l^.status);
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        NEXT q_status: [STRLENGTH (q_s_l^.status.name)] IN message;
        q_status^ := q_s_l^.status;
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        device_name_list := device_name_list^.link;
        FREE q_s_l;
      WHILEND;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := TRUE;
      parameter_kind^.param := nfc$destination_count;
      parameter_value_length := count_size;
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      NEXT count IN message;
      count^ := 0;
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      FOR i := 0 TO 3 DO
        IF destination_list [i] <> NIL THEN
          count^ := count^ + 1;
          NEXT parameter_kind IN message;
          parameter_kind^.length_indicated := TRUE;
          parameter_kind^.param := nfc$destinations_and_files;
          parameter_value_length := #SIZE (destination_list [i]^);
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
          NEXT q_status: [STRLENGTH (destination_list [i]^.name)] IN message;
          q_status^ := destination_list [i]^;
          message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

          FREE destination_list [i];
        IFEND;
      FOREND;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := TRUE;
      parameter_kind^.param := nfc$device_type_count;
      parameter_value_length := count_size;
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      NEXT count IN message;
      count^ := 0;
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      WHILE device_type_list <> NIL DO
        count^ := count^ + 1;
        q_s_l := device_type_list;
        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := TRUE;
        parameter_kind^.param := nfc$device_types_and_files;
        parameter_value_length := #SIZE (q_s_l^.status);
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        NEXT q_status: [STRLENGTH (q_s_l^.status.name)] IN message;
        q_status^ := q_s_l^.status;
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        device_type_list := device_type_list^.link;
        FREE q_s_l;
      WHILEND;
    IFEND;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$null_parameter;
    message_length := message_length + parameter_kind_size;

    nfp$send_message_on_connection (message, message_length, connection^.id, status);
    IF scfs_event_logging THEN
      log_connection_message (connection^, message_length, message);
    IFEND;

  PROCEND send_queue_status_msg;
?? TITLE := 'send select file response msg', EJECT ??

{  PURPOSE:
{    This procedure builds/sends a message to OPES indicating the response
{    to a previous select file operator command.
{
{    This procedure also builds/sends a message to OPENTF indicating the
{    response to a previous select file operator command.

  PROCEDURE send_select_file_response_msg
    (VAR message: ^nft$message_sequence;
         io_station_name: ost$name;
         device_name: ost$name;
         file_name: ost$name;
         response_code: nft$select_file_response;
         connection: ^nft$connection;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      message_length: nft$message_length,
      message_type: ^nft$message_kind,
      parameter_kind: ^nft$select_file_resp_parameter,
      parameter_kind_size: nft$message_length,
      param_length_size: nft$message_length,
      parameter_value_length: integer,
      resp_code: ^nft$select_file_response;

*copyc nft$select_file_response_msg

    parameter_kind_size := #SIZE (nft$select_file_resp_parameter);
    RESET message;

    NEXT message_type IN message;
    message_type^ := nfc$select_file_response;
    message_length := 1;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$io_station_name;
    parameter_value_length := clp$trimmed_string_size (io_station_name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := io_station_name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$system_file_name;
    parameter_value_length := clp$trimmed_string_size (file_name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := file_name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$response_code;
    NEXT resp_code IN message;
    resp_code^ := response_code;
    message_length := message_length + parameter_kind_size + 1;

    IF device_name <> osc$null_name THEN
      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$device_name;
      parameter_value_length := clp$trimmed_string_size (device_name);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := device_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
    IFEND;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$null_parameter;
    message_length := message_length + parameter_kind_size;

    nfp$send_message_on_connection (message, message_length, connection^.id, status);
    IF scfs_event_logging THEN
      log_connection_message (connection^, message_length, message);
    IFEND;

  PROCEND send_select_file_response_msg;
?? TITLE := 'send start io station msg', EJECT ??

{  PURPOSE:
{    This procedure builds/sends a message informing SCF/DI that an operator
{    has now been assigned to the I/O station.

  PROCEDURE send_start_io_station_msg
    (VAR message: ^nft$message_sequence;
         station_name: ost$name;
         operator_name: ost$name;
         operator_family: ost$name;
         connection: ^nft$connection;
     VAR status: ost$status);

*copyc nft$start_io_station_msg

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      message_length: nft$message_length,
      message_type: ^nft$message_kind,
      parameter_kind: ^nft$start_ios_message_parameter,
      parameter_kind_size: nft$message_length,
      param_length_size: nft$message_length,
      parameter_value_length: integer;

    parameter_kind_size := #SIZE (nft$start_ios_message_parameter);
    RESET message;

    NEXT message_type IN message;
    message_type^ := nfc$start_io_station;
    message_length := 1;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$io_station_name;
    parameter_value_length := clp$trimmed_string_size (station_name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := station_name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := TRUE;
    parameter_kind^.param := nfc$user_identity;
    parameter_value_length := osc$max_name_size * 2;
    nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    NEXT ascii_string: [osc$max_name_size] IN message;
    ascii_string^ := operator_name;
    NEXT ascii_string: [osc$max_name_size] IN message;
    ascii_string^ := operator_family;
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    nfp$send_message_on_connection (message, message_length, connection^.id, status);
    IF scfs_event_logging THEN
      log_connection_message (connection^, message_length, message);
    IFEND;

  PROCEND send_start_io_station_msg;
?? TITLE := 'send station status msg', EJECT ??

{  PURPOSE:
{    This procedure builds/sends a message to OPES containing the station
{    information if the response is normal.

  PROCEDURE send_station_status_msg
    (VAR message: ^nft$message_sequence;
         response: nft$display_status_resp_codes;
         io_station: ^nft$io_station;
         connection: ^nft$connection;
     VAR status: ost$status);

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      destination_unavail_action: ^nft$destination_unavail_actions,
      device: ^nft$batch_device,
      device_count: ^integer,
      file_ack: ^boolean,
      file_count: ^integer,
      message_length: nft$message_length,
      message_type: ^nft$message_kind,
      name_and_status: ^nft$device_status_data,
      parameter_kind: ^nft$station_status_msg_param,
      parameter_kind_size: nft$message_length,
      param_length_size: nft$message_length,
      parameter_value_length: integer,
      pm_message_action: ^nft$pm_message_actions,
      response_code: ^nft$display_status_resp_codes,
      station_usage: ^nft$io_station_usage;

*copyc nft$station_status_msg

    parameter_kind_size := #SIZE (nft$station_status_msg_param);
    RESET message;

    NEXT message_type IN message;
    message_type^ := nfc$station_status_data;
    message_length := 1;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$io_station_name;
    parameter_value_length := clp$trimmed_string_size (io_station^.name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := io_station^.name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$response_code;
    NEXT response_code IN message;
    response_code^ := response;
    message_length := message_length + parameter_kind_size + 1;

    IF response = nfc$disp_msg_accepted THEN
      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$control_facility;
      parameter_value_length := clp$trimmed_string_size (control_facility_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := control_facility_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := TRUE;
      parameter_kind^.param := nfc$number_of_files_queued;
      parameter_value_length := #SIZE (integer);
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      NEXT file_count IN message;
      file_count^ := count_of_files_for_station (io_station);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$station_usage;
      NEXT station_usage IN message;
      station_usage^ := io_station^.usage;
      message_length := message_length + parameter_kind_size + 1;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$file_acknowledgement;
      NEXT file_ack IN message;
      file_ack^ := io_station^.file_acknowledgement;
      message_length := message_length + parameter_kind_size + 1;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := TRUE;
      parameter_kind^.param := nfc$count_of_devices;
      parameter_value_length := #SIZE (integer);
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      NEXT device_count IN message;
{   DEVICE_COUNT^ will be filled in later when the device count is known.
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      device_count^ := 0;
      device := io_station^.batch_device_list;
      WHILE device <> NIL DO
        device_count^ := device_count^ + 1;

        NEXT parameter_kind IN message;
        parameter_kind^.length_indicated := TRUE;
        parameter_kind^.param := nfc$device_name_status;
        parameter_value_length := #SIZE (nft$device_status) + #SIZE (nft$file_transfer_status) + #SIZE
              (nft$device_type) + clp$trimmed_string_size (device^.name);
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        NEXT name_and_status: [clp$trimmed_string_size (device^.name)] IN message;
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

        name_and_status^.device_status := device^.device_status;
        name_and_status^.file_xfer_status := device^.file_transfer_status;
        name_and_status^.device_type := device^.device_type;
        name_and_status^.name := device^.name;

        device := device^.link;
      WHILEND;

      IF io_station^.required_operator_device <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$req_console_device;
        parameter_value_length := clp$trimmed_string_size (io_station^.required_operator_device);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := io_station^.required_operator_device (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

      IF io_station^.alias_names [1] <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$io_station_alias_1;
        parameter_value_length := clp$trimmed_string_size (io_station^.alias_names [1]);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := io_station^.alias_names [1] (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

      IF io_station^.alias_names [2] <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$io_station_alias_2;
        parameter_value_length := clp$trimmed_string_size (io_station^.alias_names [2]);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := io_station^.alias_names [2] (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

      IF io_station^.alias_names [3] <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$io_station_alias_3;
        parameter_value_length := clp$trimmed_string_size (io_station^.alias_names [3]);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := io_station^.alias_names [3] (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

      IF io_station^.default_job_destination <> osc$null_name THEN
        NEXT parameter_kind IN message;
        parameter_kind^.param := nfc$default_job_destination;
        parameter_value_length := clp$trimmed_string_size (io_station^.default_job_destination);
        parameter_kind^.length_indicated := parameter_value_length > 1;
        IF parameter_kind^.length_indicated THEN
          nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
        ELSE
          param_length_size := 0;
        IFEND;
        NEXT ascii_string: [parameter_value_length] IN message;
        ascii_string^ := io_station^.default_job_destination (1, parameter_value_length);
        message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;
      IFEND;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$destination_unavail_action;
      NEXT destination_unavail_action IN message;
      destination_unavail_action^ := io_station^.destination_unavailable_action;
      message_length := message_length + parameter_kind_size + 1;

      NEXT parameter_kind IN message;
      parameter_kind^.length_indicated := FALSE;
      parameter_kind^.param := nfc$pm_message_action;
      NEXT pm_message_action IN message;
      pm_message_action^ := io_station^.pm_message_action;
      message_length := message_length + parameter_kind_size + 1;

    IFEND;

    NEXT parameter_kind IN message;
    parameter_kind^.length_indicated := FALSE;
    parameter_kind^.param := nfc$null_parameter;
    message_length := message_length + parameter_kind_size;

    nfp$send_message_on_connection (message, message_length, connection^.id, status);
    IF scfs_event_logging THEN
      log_connection_message (connection^, message_length, message);
    IFEND;

  PROCEND send_station_status_msg;
?? TITLE := 'send stop io station msg', EJECT ??

  PROCEDURE send_stop_io_station_msg
    (VAR message: ^nft$message_sequence;
         station_name: ost$name;
         connection: ^nft$connection;
     VAR status: ost$status);

*copyc nft$stop_io_station_msg

    VAR
      ascii_string: ^string ( * <= osc$max_name_size),
      message_length: nft$message_length,
      message_type: ^nft$message_kind,
      parameter_kind: ^nft$stop_ios_message_parameter,
      parameter_kind_size: nft$message_length,
      param_length_size: nft$message_length,
      parameter_value_length: integer;

    parameter_kind_size := #SIZE (nft$stop_ios_message_parameter);
    RESET message;

    NEXT message_type IN message;
    message_type^ := nfc$stop_io_station;
    message_length := 1;

    NEXT parameter_kind IN message;
    parameter_kind^.param := nfc$io_station_name;
    parameter_value_length := clp$trimmed_string_size (station_name);
    nfp$modify_param_value_length (parameter_value_length);
    parameter_kind^.length_indicated := parameter_value_length > 1;
    IF parameter_kind^.length_indicated THEN
      nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
    ELSE
      param_length_size := 0;
    IFEND;
    NEXT ascii_string: [parameter_value_length] IN message;
    ascii_string^ := station_name (1, parameter_value_length);
    message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

    nfp$send_message_on_connection (message, message_length, connection^.id, status);
    IF scfs_event_logging THEN
      log_connection_message (connection^, message_length, message);
    IFEND;

  PROCEND send_stop_io_station_msg;
?? TITLE := 'start batch device msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a message is received from OPES
{    indicating the operator entered a start batch device command.
{    A maintained file transfer will restart at its suspended position
{    when the device was stopped.  This command reinstates a device for
{    selection.
{
{    This procedure is also executed when a message is received from OPENTF
{    indicating the operator entered a start batch stream command.  This
{    command reinstates a stream for selection.

  PROCEDURE start_batch_device_msg
    (VAR message: ^nft$message_sequence;
         message_length: integer;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      bd_connection: ^nft$connection,
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      response: nft$device_control_resp_codes;

*copy nft$start_batch_device_msg
?? NEWTITLE := 'crack start batch device msg', EJECT ??

    PROCEDURE crack_start_batch_device_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR io_station_name: ost$name;
       VAR device_name: ost$name;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        parameter: ^nft$start_bd_message_parameter,
        value_length: integer;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, io_station_name);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, device_name);

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_start_batch_device_msg;
?? OLDTITLE, EJECT ??

    crack_start_batch_device_msg (message, msg_length, io_station_name, device_name, status);

    find_io_station_or_remote_sys (io_station_name, connection, io_station, io_station_found);
    IF NOT io_station_found THEN
      response := nfc$dc_msg_reject_unknown_ios;
    ELSE
      find_batch_device (device_name, io_station, device, device_found);
      IF NOT device_found THEN
        response := nfc$dc_msg_reject_unknown_dev;
      ELSE
        response := nfc$dc_msg_accepted;
        bd_connection := device^.scfdi_connection;
        nfp$send_message_on_connection (message, message_length, bd_connection^.id, status);
        IF scfs_event_logging THEN
          log_connection_message (bd_connection^, message_length, message);
        IFEND;
        device^.outstanding_di_responses [nfc$start_bd] := device^.outstanding_di_responses [nfc$start_bd] +
              1;
      IFEND;
    IFEND;

    IF response > nfc$dc_msg_accepted THEN
      send_device_control_response (message, nfc$start_batch_device_resp, io_station_name, device_name,
            response, connection, status);
    IFEND;

  PROCEND start_batch_device_msg;
?? TITLE := 'start batch device resp', EJECT ??

{  PURPOSE:
{    This procedure is executed when a response is received from SCF/DI in
{    response to a start batch device command that was forwarded from OPES.
{
{    This procedure is also executed when a response is received from SCF/DI in
{    response to a start batch stream command that was forwarded from OPENTF.

  PROCEDURE start_batch_device_resp
    (VAR message: ^nft$message_sequence;
         message_length: integer;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      operator_connection: ^nft$connection,
      response_code: nft$device_control_resp_codes;

    crack_device_control_resp (message, msg_length, io_station_name, device_name, response_code, status);

    find_io_station_or_remote_sys (io_station_name, connection, io_station, io_station_found);
    IF io_station_found THEN
      find_batch_device (device_name, io_station, device, device_found);
      IF device_found THEN
        device^.outstanding_di_responses [nfc$start_bd] := device^.outstanding_di_responses [nfc$start_bd] -
              1;

        device^.device_status := nfc$device_active;
        device^.device_timer_activated := FALSE;
        device^.timer_start_time := 0;
        device^.number_of_files_requeued := 0;

        IF io_station^.operator_assigned THEN
          operator_connection := io_station^.connected_operator;
          nfp$send_message_on_connection (message, message_length, operator_connection^.id, status);
          IF scfs_event_logging THEN
            log_connection_message (operator_connection^, message_length, message);
          IFEND;
        IFEND;

        IF device_available_for_output (device) THEN
          find_file_for_device (device, message, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND start_batch_device_resp;
?? TITLE := 'stop batch device msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a message is received from OPES
{    indicating a stop batch device command was entered by the
{    station operator.  The device is removed from service
{    immediatedly if the file disposition = drop, requeue or hold.  If the
{    file disposition = finish, the file transfer continues until it is
{    complete.
{
{    This procedure is also executed when a message is received from OPENTF
{    indicating a stop batch stream command was entered by the NTF operator.
{    The stream is removed from service immediatedly if the file disposition =
{    drop, requeue or hold.  If the file disposition = finish, the file
{    transfer continues until it is complete.

  PROCEDURE stop_batch_device_msg
    (VAR message: ^nft$message_sequence;
         message_length: integer;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      bd_connection: ^nft$connection,
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      file_disposition: nft$file_disposition,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      response: nft$device_control_resp_codes;

*copy nft$stop_batch_device_msg
?? NEWTITLE := 'crack stop batch device msg', EJECT ??

    PROCEDURE crack_stop_batch_device_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR io_station_name: ost$name;
       VAR device_name: ost$name;
       VAR file_disposition: nft$file_disposition;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        disposition: ^nft$file_disposition,
        parameter: ^nft$stop_bd_message_parameter,
        value_length: integer;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, io_station_name);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, device_name);

        = nfc$file_disposition =
          NEXT disposition IN message;
          file_disposition := disposition^;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_stop_batch_device_msg;
?? OLDTITLE, EJECT ??
{   Crack Stop Batch Device msg.
    crack_stop_batch_device_msg (message, msg_length, io_station_name, device_name, file_disposition, status);

    find_io_station_or_remote_sys (io_station_name, connection, io_station, io_station_found);
    IF NOT io_station_found THEN
      response := nfc$dc_msg_reject_unknown_ios;
    ELSE
      find_batch_device (device_name, io_station, device, device_found);
      IF NOT device_found THEN
        response := nfc$dc_msg_reject_unknown_dev;
      ELSE
        response := nfc$dc_msg_accepted;
        bd_connection := device^.scfdi_connection;
        nfp$send_message_on_connection (message, message_length, bd_connection^.id, status);
        IF scfs_event_logging THEN
          log_connection_message (bd_connection^, message_length, message);
        IFEND;
        device^.outstanding_di_responses [nfc$stop_bd] := device^.outstanding_di_responses [nfc$stop_bd] + 1;
      IFEND;
    IFEND;

    IF response > nfc$dc_msg_accepted THEN
      send_device_control_response (message, nfc$stop_batch_device_resp, io_station_name, device_name,
            response, connection, status);
    IFEND;

  PROCEND stop_batch_device_msg;
?? TITLE := 'stop batch device resp', EJECT ??

{  PURPOSE:
{    This procedure is executed when a message is received from SCF/DI
{    in response to a station operator stop batch device command that was
{    forwarded from OPES.
{
{    This procedure is also executed when a message is received from SCF/DI in
{    response to a NTF operator stop batch stream command that was forwarded
{    from OPENTF.

  PROCEDURE stop_batch_device_resp
    (VAR message: ^nft$message_sequence;
         message_length: integer;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      operator_connection: ^nft$connection,
      response_code: nft$device_control_resp_codes;

    crack_device_control_resp (message, msg_length, io_station_name, device_name, response_code, status);

    find_io_station_or_remote_sys (io_station_name, connection, io_station, io_station_found);
    IF io_station_found THEN
      find_batch_device (device_name, io_station, device, device_found);
      IF device_found THEN
        device^.outstanding_di_responses [nfc$stop_bd] := device^.outstanding_di_responses [nfc$stop_bd] - 1;
        IF response_code = nfc$dc_msg_accepted THEN
          device^.device_status := nfc$device_stopped;
        IFEND;

        IF io_station^.operator_assigned THEN
          operator_connection := io_station^.connected_operator;
          nfp$send_message_on_connection (message, message_length, operator_connection^.id, status);
          IF scfs_event_logging THEN
            log_connection_message (operator_connection^, message_length, message);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND stop_batch_device_resp;
?? TITLE := 'suppress carriage control msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a message is received from OPES
{    indicating a suppress carriage control command was entered by the
{    station operator.  The interpretation of carriage control characters
{    is suppressed or not suppressed by this command.

  PROCEDURE suppress_carriage_control_msg
    (VAR message: ^nft$message_sequence;
         message_length: integer;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      bd_connection: ^nft$connection,
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      response: nft$device_control_resp_codes;

*copy nft$suppress_carriage_cntrl_msg
?? NEWTITLE := 'crack suppress cc msg', EJECT ??

    PROCEDURE crack_suppress_cc_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR io_station_name: ost$name;
       VAR device_name: ost$name;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        format_cntrl: ^nft$suppress_carriage_control,
        format_control: nft$suppress_carriage_control,
        parameter: ^nft$suppress_cc_msg_parameter,
        value_length: integer;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, io_station_name);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, device_name);

        = nfc$suppress_format_control =
          NEXT format_cntrl IN message;
          format_control := format_cntrl^;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_suppress_cc_msg;
?? OLDTITLE, EJECT ??

    crack_suppress_cc_msg (message, msg_length, io_station_name, device_name, status);

    find_io_station (io_station_name, io_station, io_station_found);
    IF NOT io_station_found THEN
      response := nfc$dc_msg_reject_unknown_ios;
    ELSE
      find_batch_device (device_name, io_station, device, device_found);
      IF NOT device_found THEN
        response := nfc$dc_msg_reject_unknown_dev;
      ELSE
        IF device^.device_type = nfc$reader THEN
          response := nfc$dc_msg_reject_bad_dev_type;
        ELSE
          response := nfc$dc_msg_accepted;
          bd_connection := device^.scfdi_connection;
          nfp$send_message_on_connection (message, message_length, bd_connection^.id, status);
          IF scfs_event_logging THEN
            log_connection_message (bd_connection^, message_length, message);
          IFEND;
          device^.outstanding_di_responses [nfc$suppress_cc] := device^.outstanding_di_responses
                [nfc$suppress_cc] + 1;
        IFEND;
      IFEND;
    IFEND;

    IF response > nfc$dc_msg_accepted THEN
      send_device_control_response (message, nfc$suppress_carriage_cntrl_rsp, io_station_name, device_name,
            response, connection, status);
    IFEND;

  PROCEND suppress_carriage_control_msg;
?? TITLE := 'suppress carriage control resp', EJECT ??

{  PURPOSE:
{    This procedure is executed when a message is received from SCF/DI
{    in response to a suppress carriage control command that was forwarded
{    from OPES.

  PROCEDURE suppress_carriage_control_resp
    (VAR message: ^nft$message_sequence;
         message_length: integer;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      operator_connection: ^nft$connection,
      response_code: nft$device_control_resp_codes;

    crack_device_control_resp (message, msg_length, io_station_name, device_name, response_code, status);

    find_io_station (io_station_name, io_station, io_station_found);
    IF io_station_found THEN
      find_batch_device (device_name, io_station, device, device_found);
      IF device_found THEN
        device^.suppress_carriage_control := TRUE;
        device^.outstanding_di_responses [nfc$suppress_cc] := device^.outstanding_di_responses
              [nfc$suppress_cc] - 1;

        IF io_station^.operator_assigned THEN
          operator_connection := io_station^.connected_operator;
          nfp$send_message_on_connection (message, message_length, operator_connection^.id, status);
          IF scfs_event_logging THEN
            log_connection_message (operator_connection^, message_length, message);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND suppress_carriage_control_resp;
?? TITLE := 'time in scfs queue', EJECT ??

  FUNCTION time_in_scfs_queue (time_stamp: ost$date_time;
        current_time: ost$date_time): integer;

    CONST
      seconds_in_day = 86400;

    VAR
      days: integer,
      local_status: ost$status,
      new_date: ost$date,
      old_date: ost$date,
      time_increment: pmt$time_increment;

?? NEWTITLE := 'compute ordinal date difference', EJECT ??

    FUNCTION compute_ordinal_date_difference (late_date: ost$date;
          early_date: ost$date): integer;

      VAR
        early_days: clt$integer,
        early_years: clt$integer,
        late_days: clt$integer,
        late_years: clt$integer,
        local_status: ost$status;

      clp$convert_string_to_integer (late_date.ordinal (1, 4), late_years, local_status);
      clp$convert_string_to_integer (early_date.ordinal (1, 4), early_years, local_status);
      clp$convert_string_to_integer (late_date.ordinal (5, 3), late_days, local_status);
      clp$convert_string_to_integer (early_date.ordinal (5, 3), early_days, local_status);

      compute_ordinal_date_difference := (late_days.value - early_days.value) + (late_years.value -
            early_years.value) * 365;

    FUNCEND compute_ordinal_date_difference;
?? OLDTITLE, EJECT ??

    pmp$compute_date_time_increment (time_stamp, current_time, time_increment, local_status);

    days := 0;
    IF time_increment.day > 0 THEN
      pmp$format_compact_date (current_time, osc$ordinal_date, new_date, local_status);
      pmp$format_compact_date (time_stamp, osc$ordinal_date, old_date, local_status);
      days := compute_ordinal_date_difference (new_date, old_date);
    IFEND;

    time_in_scfs_queue := days * seconds_in_day + time_increment.hour * 3600 + time_increment.minute * 60 +
          time_increment.second;

  FUNCEND time_in_scfs_queue;
?? TITLE := 'terminate_queued_output', EJECT ??

{
{  PURPOSE:
{    This procedure is executed when a message is received from OPES
{    indicating a terminate queued output command was entered by the
{    station operator.  The requested file should be removed from the output
{    queue as a result of this command.
{

  PROCEDURE terminate_queued_output
    (    message_length: integer;
         connection: ^nft$connection;
     VAR message: ^nft$message_sequence;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      alias_entry: ^nft$alias,
      duplicate_file_name: boolean,
      file_in_selected_q: boolean,
      file_name: ost$name,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      q_file: ^nft$output_queue_file,
      response: nft$terqo_file_status_codes,
      scfve_connection: ^nft$connection,
      selected_file: ^nft$selected_file;

*copy nft$terminate_queued_output_msg
?? NEWTITLE := 'send_terqo_to_scfve', EJECT ??

    PROCEDURE send_terqo_to_scfve
      (    file_name: ost$name;
           io_station_name: ost$name;
           connection: ^nft$connection;
       VAR message: ^nft$message_sequence;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        message_length: nft$message_length,
        message_type: ^nft$message_kind,
        parameter_kind: ^nft$term_queue_output_parameter,
        parameter_kind_size: nft$message_length,
        param_length_size: nft$message_length,
        parameter_value_length: integer;

      parameter_kind_size := #SIZE (nft$term_queue_output_parameter);
      RESET message;

      NEXT message_type IN message;
      message_type^ := nfc$terminate_queue_output;
      message_length := 1;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$io_station_name;
      parameter_value_length := clp$trimmed_string_size (io_station_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := io_station_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      NEXT parameter_kind IN message;
      parameter_kind^.param := nfc$system_user_file_name;
      parameter_value_length := clp$trimmed_string_size (file_name);
      nfp$modify_param_value_length (parameter_value_length);
      parameter_kind^.length_indicated := parameter_value_length > 1;
      IF parameter_kind^.length_indicated THEN
        nfp$put_parameter_value_length (parameter_value_length, message, param_length_size, status);
      ELSE
        param_length_size := 0;
      IFEND;
      NEXT ascii_string: [parameter_value_length] IN message;
      ascii_string^ := file_name (1, parameter_value_length);
      message_length := message_length + parameter_kind_size + param_length_size + parameter_value_length;

      nfp$send_message_on_connection (message, message_length, connection^.id, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;

    PROCEND send_terqo_to_scfve;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    response := nfc$terqo_message_rejected;

    nfp$crack_terqo_msg (message, msg_length, io_station_name, file_name, status);

    IF status.normal THEN
      find_io_station_or_remote_sys (io_station_name, connection, io_station, io_station_found);
      IF NOT io_station_found THEN
        response := nfc$terqo_unknown_ios;
      ELSE
        search_selected_q_for_file (io_station, file_name, q_file, selected_file,
              file_in_selected_q, duplicate_file_name);
        IF NOT file_in_selected_q THEN
          search_alias_list_for_file_name (io_station, file_name,
                alias_entry, q_file, duplicate_file_name);
        IFEND;

        response := nfc$terqo_successful;
        IF duplicate_file_name THEN
          response := nfc$terqo_duplicate_file_names;
        ELSEIF q_file = NIL THEN
          response := nfc$terqo_unknown_file_name;
        ELSEIF q_file^.output_state = nfc$selected_for_transfer THEN
          response := nfc$terqo_file_in_transfer;
        ELSE
          scfve_connection := q_file^.scfve_connection;
          send_terqo_to_scfve (q_file^.system_file_name, io_station_name, scfve_connection, message,
                status);
        IFEND;
      IFEND;
    IFEND;

    IF response > nfc$terqo_successful THEN
      nfp$send_terqo_response_msg (io_station_name, file_name, response, connection^.id, message, status);
      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;
    IFEND;

  PROCEND terminate_queued_output;
?? TITLE := 'terminate_queue_output_response', EJECT ??

{
{  PURPOSE:
{    This procedure is executed when a message is received from SCF/VE
{    in response to a terminate queued output command that was forwarded
{    from OPES.  The response indicates whether the file could be terminated
{    from the output queue or not.
{

  PROCEDURE terminate_queue_output_response
    (    message_length: integer;
         connection: ^nft$connection;
     VAR message: ^nft$message_sequence;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      operator_connection: ^nft$connection;

?? NEWTITLE := 'crack_terqo_resp_msg', EJECT ??

    PROCEDURE crack_terqo_resp_msg
      (VAR io_station_name: ost$name;
       VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        parameter: ^nft$term_q_output_resp_param,
        value_length: integer;

*copy nft$terminate_q_output_resp_msg
?? EJECT ??
      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <= nfc$file_status_code) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        IF parameter^.param = nfc$io_station_name THEN
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, io_station_name);
        ELSE

{ All this routine cares about is the station name.  The rest of the parameters
{ do not have to be looked at.

          NEXT byte_array: [1 .. value_length] IN message;

        IFEND;
        NEXT parameter IN message;
      WHILEND;

      RESET message TO parameter;

    PROCEND crack_terqo_resp_msg;
?? OLDTITLE, EJECT ??
    crack_terqo_resp_msg (io_station_name, message, msg_length, status);

    IF status.normal THEN
      find_io_station_or_remote_sys (io_station_name, connection, io_station, io_station_found);
      IF io_station_found THEN
        IF io_station^.operator_assigned THEN
          operator_connection := io_station^.connected_operator;
          nfp$send_message_on_connection (message, message_length, operator_connection^.id, status);
          IF scfs_event_logging THEN
            log_connection_message (operator_connection^, message_length, message);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND terminate_queue_output_response;
?? TITLE := 'terminate transfer msg', EJECT ??

{  PURPOSE:
{    This procedure is executed when a message is received from OPES
{    indicating a terminate transfer command was entered by the
{    station operator.  The current file transfer is dropped,
{    requeued or held, and the device then becomes a candidate for
{    printing an output file.
{
{    This procedure is also executed when a message is received from OPENTF
{    indicating a terminate transfer command was entered by the NTF operator.
{    The current file transfer is dropped, requeued or held, and the batch
{    stream then becomes a candidate for transferring an NTF file.

  PROCEDURE terminate_transfer_msg
    (VAR message: ^nft$message_sequence;
         message_length: integer;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      bd_connection: ^nft$connection,
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      q_file: ^nft$output_queue_file,
      response: nft$device_control_resp_codes,
      transfer_action: nft$file_disposition;

*copy nft$terminate_transfer_msg
?? NEWTITLE := 'crack terminate transfer msg', EJECT ??

    PROCEDURE crack_terminate_transfer_msg
      (VAR message: ^nft$message_sequence;
       VAR msg_length: integer;
       VAR io_station_name: ost$name;
       VAR device_name: ost$name;
       VAR file_disposition: nft$file_disposition;
       VAR status: ost$status);

      VAR
        ascii_string: ^string ( * <= osc$max_name_size),
        byte_array: ^nft$byte_array,
        file_action: ^nft$file_disposition,
        parameter: ^nft$terminate_xfer_msg_param,
        value_length: integer;

      NEXT parameter IN message;

      WHILE (parameter <> NIL) AND (parameter^.param <> nfc$null_parameter) AND (msg_length > 0) DO
        msg_length := msg_length - 1;
        IF parameter^.length_indicated THEN
          nfp$get_parameter_value_length (message, msg_length, value_length, status);
          msg_length := msg_length - value_length;
        ELSE
          value_length := 1;
          msg_length := msg_length - 1;
        IFEND;

        CASE parameter^.param OF
        = nfc$io_station_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, io_station_name);

        = nfc$device_name =
          NEXT ascii_string: [value_length] IN message;
          #translate (osv$lower_to_upper, ascii_string^, device_name);

        = nfc$file_disposition =
          NEXT file_action IN message;
          file_disposition := file_action^;

        ELSE
{         ERROR ----   Ignore parameter value.
          NEXT byte_array: [1 .. value_length] IN message;

        CASEND;
        NEXT parameter IN message;
      WHILEND;

    PROCEND crack_terminate_transfer_msg;
?? OLDTITLE, EJECT ??

    crack_terminate_transfer_msg (message, msg_length, io_station_name, device_name, transfer_action, status);

    find_io_station_or_remote_sys (io_station_name, connection, io_station, io_station_found);
    IF NOT io_station_found THEN
      response := nfc$dc_msg_reject_unknown_ios;
    ELSE
      find_batch_device (device_name, io_station, device, device_found);
      IF NOT device_found THEN
        response := nfc$dc_msg_reject_unknown_dev;
      ELSE
        response := nfc$dc_msg_accepted;
        IF (transfer_action = nfc$hold_file_in_q) AND (device^.current_file <> NIL) AND
              output_device_or_stream (device) THEN
          q_file := device^.current_file;
          q_file^.output_state := nfc$hold_transfer;
        IFEND;

        bd_connection := device^.scfdi_connection;
        nfp$send_message_on_connection (message, message_length, bd_connection^.id, status);
        IF scfs_event_logging THEN
          log_connection_message (bd_connection^, message_length, message);
        IFEND;
        device^.outstanding_di_responses [nfc$terminate_xfer] := device^.outstanding_di_responses
              [nfc$terminate_xfer] + 1;
      IFEND;
    IFEND;

    IF response > nfc$dc_msg_accepted THEN
      send_device_control_response (message, nfc$terminate_transfer_resp, io_station_name, device_name,
            response, connection, status);
    IFEND;

  PROCEND terminate_transfer_msg;
?? TITLE := 'terminate_transfer_resp', EJECT ??

{  PURPOSE:
{    This procedure is executed when a message is received from SCF/DI
{    in response to a terminate transfer message that was forwarded from
{    OPES.  Also, the terminate transfer message may have been generated from
{    a delete file availability message.
{
{    This procedure is also executed when a message is received from SCF/DI in
{    response to a terminate transfer message that was forwarded from OPENTF.

  PROCEDURE terminate_transfer_resp
    (VAR message: ^nft$message_sequence;
         message_length: integer;
         connection: ^nft$connection;
     VAR msg_length: integer;
     VAR status: ost$status);

    VAR
      device: ^nft$batch_device,
      device_found: boolean,
      device_name: ost$name,
      io_station: ^nft$io_station,
      io_station_found: boolean,
      io_station_name: ost$name,
      operator_connection: ^nft$connection,
      response_code: nft$device_control_resp_codes;

    crack_device_control_resp (message, msg_length, io_station_name, device_name, response_code, status);

    find_io_station_or_remote_sys (io_station_name, connection, io_station, io_station_found);
    IF io_station_found THEN
      find_batch_device (device_name, io_station, device, device_found);
      IF device_found THEN
        IF device^.outstanding_di_responses [nfc$terminate_xfer] > 0 THEN
          device^.outstanding_di_responses [nfc$terminate_xfer] := device^.outstanding_di_responses
                [nfc$terminate_xfer] - 1;
        ELSE
{ Special case where SCFS sent a terminate_transfer (from delete_file_availability_msg) -
{ we do not want to inform operator.
          RETURN;
        IFEND;

        IF io_station^.operator_assigned THEN
          operator_connection := io_station^.connected_operator;
          nfp$send_message_on_connection (message, message_length, operator_connection^.id, status);
          IF scfs_event_logging THEN
            log_connection_message (operator_connection^, message_length, message);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND terminate_transfer_resp;
?? TITLE := 'determine and call message kind', EJECT ??

{  PURPOSE:
{    This procedure is executed when a message is received by SCFS.
{    The appropriate message is called based on the message type recieved.

  PROCEDURE determine_and_call_message_kind
    (    peer_operation: nat$se_peer_operation;
     VAR connection: ^nft$connection;
     VAR message: ^nft$message_sequence;
     VAR wait_list: ^ost$i_wait_list;
     VAR wait_connection_list: ^nft$wait_connection_list;
     VAR status: ost$status);

    VAR
      message_kind: ^nft$message_kind,
      message_length: integer;

    IF peer_operation.kind = nac$se_send_data THEN
      message_length := peer_operation.data_length;

      IF scfs_event_logging THEN
        log_connection_message (connection^, message_length, message);
      IFEND;

      RESET message;
{     Determine message type coming into SCFS/VE
      NEXT message_kind IN message;
      message_length := message_length - 1;

      CASE message_kind^ OF

{  The following message types are sent by SCF/DI.  }

      = nfc$add_io_station =
        add_io_station_msg (message, connection, message_length, wait_list, wait_connection_list,
              status);

      = nfc$delete_io_station =
        delete_io_station_msg (message, connection, message_length, wait_list,
              wait_connection_list, status);

      = nfc$add_batch_device =
        add_batch_device_msg (message, connection, message_length, status);

      = nfc$batch_device_status =
        change_batch_device_status (message, connection, message_length, status);

      = nfc$file_transfer_status =
        change_file_transfer_status (message, connection, message_length, status);

      = nfc$delete_batch_device =
        delete_batch_device_msg (message, connection, message_length, status);

      = nfc$btfs_di_status =
        change_btfs_di_status (message, connection, message_length, status);

      = nfc$operator_message =
        operator_message (message, peer_operation.data_length, connection, message_length,
              status);

      = nfc$suppress_carriage_cntrl_rsp =
        suppress_carriage_control_resp (message, peer_operation.data_length, connection,
              message_length, status);

      = nfc$change_bat_device_attr_resp =
        change_batch_device_attr_resp (message, peer_operation.data_length, connection,
              message_length, status);

      = nfc$start_batch_device_resp =
        start_batch_device_resp (message, peer_operation.data_length, connection, message_length,
              status);

      = nfc$stop_batch_device_resp =
        stop_batch_device_resp (message, peer_operation.data_length, connection, message_length,
              status);

      = nfc$position_file_resp =
        position_file_resp (message, peer_operation.data_length, connection, message_length,
              status);

      = nfc$terminate_transfer_resp =
        terminate_transfer_resp (message, peer_operation.data_length, connection, message_length,
              status);

      = nfc$add_ntf_remote_sys_msg =
        add_ntf_remote_system_message (message, connection, message_length, status);

      = nfc$delete_ntf_remote_sys_msg =
        delete_ntf_remote_system_msg (message, connection, message_length, status);

      = nfc$add_ntf_acc_rem_sys_msg =
        add_ntf_acc_remote_system_msg (message, connection, message_length, status);

      = nfc$send_ntf_remote_comm_resp =
        send_ntf_remote_command_resp (message, peer_operation.data_length, connection,
              message_length, status);

{  The following message type is used for automatic switching of control  }
{  facilities in the case that the higher priority control facility fails. }
{  (future enhancement) }

      = nfc$switch_control_facility =
        ;

{  The following message types are sent by SCF/VE.  }

      = nfc$add_file_availability =
        add_file_availability_msg (message, connection, message_length, status);

      = nfc$modify_file_availability =
        modify_file_availability_msg (message, connection, message_length, status);

      = nfc$delete_file_availability =
        delete_file_availability_msg (message, connection, message_length, status);

      = nfc$file_assignment_response =
        file_assignment_response (message, wait_list, message_length, status);

      = nfc$btf_ve_status =
        change_btf_ve_status (message, connection, message_length, status);

      = nfc$terminate_queue_output_resp =
        terminate_queue_output_response (peer_operation.data_length, connection, message,
              message_length, status);

{  The following message types are sent by OPES.  }

      = nfc$add_user =
        add_user_msg (message, connection, message_length, status);

      = nfc$start_batch_device =
        start_batch_device_msg (message, peer_operation.data_length, connection,
               message_length, status);

      = nfc$stop_batch_device =
        stop_batch_device_msg (message, peer_operation.data_length, connection,
               message_length, status);

      = nfc$terminate_transfer =
        terminate_transfer_msg (message, peer_operation.data_length, connection,
               message_length, status);

      = nfc$suppress_carriage_control =
        suppress_carriage_control_msg (message, peer_operation.data_length, connection,
               message_length, status);

      = nfc$select_file =
        select_file_msg (message, connection, message_length, status);

      = nfc$position_file_sou =
        position_file_msg (message, connection, message_length, status);

      = nfc$get_station_status =
        get_station_status_msg (message, message_length, connection, status);

      = nfc$get_device_status =
        get_device_status_msg (message, connection, status);

      = nfc$get_queue_status =
        get_queue_status_msg (message, connection, status);

      = nfc$get_queue_entry_list =
        get_queue_entry_list_msg (message, connection, message_length, status);

      = nfc$get_queue_entry =
        get_queue_entry_msg (message, connection, status);

      = nfc$change_batch_device_attr =
        change_batch_device_attributes (message, peer_operation.data_length, connection,
               message_length, status);

      = nfc$terminate_queue_output =
        terminate_queued_output (peer_operation.data_length, connection, message,
              message_length, status);

{  The following message types are sent by OPENTF.  }

      = nfc$delete_ntf_user_msg =
        delete_ntf_user_message (message, connection, message_length, status);

      = nfc$get_ntf_rem_sys_names_msg =
        get_ntf_remote_system_names_msg (message, connection, message_length, status);

      = nfc$get_ntf_rem_sys_opts_msg =
        get_ntf_remote_system_opts_msg (message, connection, message_length, status);

      = nfc$get_ntf_rem_sys_stat_msg =
        get_ntf_remote_system_stat_msg (message, connection, message_length, status);

      = nfc$send_ntf_remote_comm_msg =
        send_ntf_remote_command_message (message, connection, message_length, status);

      ELSE
        ;
      CASEND;
    IFEND;

  PROCEND determine_and_call_message_kind;
?? TITLE := 'nfp$status_control_fac_server', EJECT ??

{  PURPOSE:
{    This program implements the server application known as SCFS/VE.
{    SCFS is responsible for controlling the flow of output to devices.
{    SCFS/VE receives batch device status and control commands, and
{    SCFS/VE receives file status and control commands.  The staton
{    operator sends batch control commands to SCFS.  SCFS processes
{    some of these commands itself and sends others to the appropriate
{    SCF/VE or SCF/DI for processing.
{
{    SCFS is also responsible for controlling the transfer of NTF files to
{    batch streams.  SCFS/VE receives batch stream status and control commands,
{    and SCFS/VE receives file status and control commands.  The NTF operator
{    sends batch control commands to SCFS.  SCFS processes some of these
{    commands itself and sends others to the appropriate NTF/VE or SCF/DI for
{    processing.
{
{  DESCRIPTION:
{
{    - establish condition handler
{    - initialize SCFS application
{    LOOP
{      - get new connections
{      - determine the kind of incoming message and process the message
{      - remove a connection from the current list
{    LOOPEND

  PROGRAM nfp$status_control_fac_server
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      activity_status: ost$activity_status,
      connection: ^nft$connection,
      establish_descriptor: pmt$established_handler,
      exit_condition: [STATIC, READ] pmt$condition := [pmc$block_exit_processing, [pmc$block_exit,
        pmc$program_termination, pmc$program_abort]],
      message: ^nft$message_sequence,
      peer_operation: nat$se_peer_operation,
      ready_index: integer,
      wait_connection_list: ^nft$wait_connection_list,
      wait_list: ^ost$i_wait_list;

?? NEWTITLE := 'exit_condition_handler', EJECT ??

{  PURPOSE:
{    In the case of an abnormal termination, all registered titles
{    are be deleted, open connections are closed and the server
{    application is detached from the current job.

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        alias_pt: ^nft$alias,
        connection_pt: ^nft$connection,
        file_id_is_valid: boolean,
        file_instance: ^bat$task_file_entry,
        file_name: amt$local_file_name,
        ignore_status: ost$status,
        local_status: ost$status;

      local_status.normal := TRUE;

      pmp$log ('Status and Control Facility Server dropping', local_status);

{  If the control_facility_name is equal to a null name, then SCFS failed to
{  register the title for the control facility during initialization.  SCFS
{  will drop because of this error and there won't be any titles to delete.

      IF control_facility_name <> osc$null_name THEN
        IF scfs_title <> NIL THEN
          nap$delete_server_title (server_name, scfs_title^, local_status);
        IFEND;

        IF scfs_ntf_title <> NIL THEN
          nap$delete_server_title (server_name, scfs_ntf_title^, local_status);
        IFEND;

        alias_pt := scfs_tables.first_station_name_alias;
        WHILE (alias_pt <> NIL) DO
          IF alias_pt^.station_title_registered THEN
            delete_station_alias_title (alias_pt^.name, nfc$station_title, local_status);
          IFEND;
          IF alias_pt^.alias_title_registered THEN
            delete_station_alias_title (alias_pt^.name, nfc$alias_title, local_status);
          IFEND;
          alias_pt := alias_pt^.link;
        WHILEND;

{  Terminate all connections by closing and returning the connection files.

        connection_pt := scfs_tables.first_connection;
        WHILE connection_pt <> NIL DO
          bap$validate_file_identifier (connection_pt^.id, file_instance, file_id_is_valid);
          IF file_id_is_valid THEN
            file_name := file_instance^.local_file_name;
            fsp$close_file (connection_pt^.id, local_status);
            amp$return (file_name, ignore_status);
          IFEND;
          connection_pt := connection_pt^.link;
        WHILEND;
      IFEND;

{  Detach the server job.

      IF scfs_title <> NIL THEN
        nap$detach_server_application (server_name, local_status);
      IFEND;

{  Cleanup the binary log file if logging was activated.

      IF scfs_event_logging AND (scfs_log_file <> NIL) THEN
        fsp$close_file (scfs_log_file_identifier, local_status);
        amp$return (scfs_log_file^, local_status);
      IFEND;

{ Status is from nfp$status_control_fac_server.  If the status is abnormal, then
{ is should be written to the system job log and the system log.

      IF NOT status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$system_log, pmc$job_log], status, local_status);
      IFEND;

      REPEAT
        clp$delete_variable (nfv$appl_def_segment_variables [nfc$appl_def_segment_for_scfs], ignore_status);
      UNTIL NOT ignore_status.normal;

    PROCEND exit_condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    pmp$establish_condition_handler (exit_condition, ^exit_condition_handler, ^establish_descriptor, status);

    initialize_scfs (parameter_list, scfs_event_logging, wait_list, message, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  The wait_list is used to keep track of the activites SCFS is waiting on.
{  The wait_connection_list contains more detailed information, with each entry
{  in the wait_connection_list corresonding to an entry in the wait_list.

    WHILE TRUE DO
      osp$i_await_activity_completion (wait_list^, ready_index, status);
      IF status.normal THEN
        CASE wait_list^ [ready_index].activity OF
        = nac$i_await_connection =
          get_new_connection ( wait_list, wait_connection_list, message, status);
          IF NOT status.normal THEN
            IF (status.condition = nae$invalid_request) OR
                  (status.condition = nae$server_not_attached) OR
                  (status.condition = nae$application_inactive) OR
                  (status.condition = nae$invalid_connect_data_change) THEN
              RETURN;
            IFEND;
          IFEND;

        = nac$i_await_data_available =
          connection := wait_connection_list^ [ready_index];
          nfp$get_connection_data (message, connection^.id, peer_operation, activity_status, activity_status.
                status);
          IF activity_status.status.normal THEN
            determine_and_call_message_kind (peer_operation, connection, message, wait_list,
                  wait_connection_list, status);
          ELSE
            remove_connection_from_list ( ready_index, wait_list, wait_connection_list, message,
                  status);
          IFEND;

        = osc$i_await_time =

{ Timer has expired.  Check for unreachable BTFS/DI titles done below.

        ELSE
          ;
        CASEND;

{ If wait_list await time is short this means there are timers running on
{ unreachable BTFS/DI titles, so check for expired ones before awaiting again.

        IF wait_list^ [2].milliseconds = unreachable_btfs_di_wait_time THEN
          check_unreachable_btfs_di_lists (wait_list, message);
        IFEND;

      IFEND;
    WHILEND;

  PROCEND nfp$status_control_fac_server;
?? OLDTITLE ??
MODEND nfm$status_control_fac_server;
*DECK DECK=NFM$STORE_FORWARD_UTILITIES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : nfm$store_forward_utilities' ??
MODULE nfm$store_forward_utilities;

{ PURPOSE:
{   This module is a collection of utility procedures to access
{   and process the System's Store/Forward Network FIle.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nfe$manage_store_forward_netwrk
*copyc nft$sf_application_name_info
*copyc nft$sf_group_name_information
*copyc nft$sf_source_name_information
*copyc nft$sf_target_name_information
*copyc nft$store_forward_file_info
*copyc nft$store_forward_file_pointers
*copyc osd$integer_limits
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$return
*copyc avp$get_capability
*copyc fsp$close_file
*copyc fsp$open_file
*copyc jmp$system_job
*copyc osp$set_status_abnormal
*copyc pfp$attach
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_unique_name
*copyc pmp$log
*copyc pmp$wait
?? OLDTITLE ??
?? NEWTITLE := 'Global Variables Referenced by This Module', EJECT ??
*copyc nfc$manage_store_forward_file
*copyc nfv$manage_sf_network
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$open_store_forward_file', EJECT ??

*copyc nfh$open_store_forward_file

  PROCEDURE [XDCL] nfp$open_store_forward_file
    (    attach_file: boolean;
     VAR store_forward_file_info: nft$store_forward_file_info;
     VAR status: ost$status);

    CONST
      delay_time_for_attach = 15 * 1000, { 15 seconds }
      max_attach_tries = 10;

    VAR
      attach_count: 0 .. max_attach_tries,
      establish_descriptor: pmt$established_handler,
      exit_condition: [STATIC, READ] pmt$condition := [pmc$condition_combination,
            [pmc$block_exit_processing, mmc$segment_access_condition]],
      ignore_status: ost$status,
      pf_access_mode: pft$usage_selections,
      pf_cycle_selection: pft$cycle_selector,
      pf_password: pft$password,
      pf_share_mode: pft$share_selections,
      pf_store_forward_file_path: ^pft$path,
      ptr_file_attachment_options: ^fst$attachment_options,
      ptr_store_forward_file_ptrs: ^nft$store_forward_file_pointers,
      read_error: boolean,
      user_capability_network_appl: boolean,
      user_capability_network_oper: boolean;

?? NEWTITLE := 'attach_sf_file_cond_handler', EJECT ??

{ PURPOSE:
{   This is the condition handler for the procedure READ_STORE_FORWARD_FILE.

    PROCEDURE attach_sf_file_cond_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR cond_handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      pmp$log (' Errors encountered while attaching the Systems Store/Forward Network File', ignore_status);
      fsp$close_file (store_forward_file_info.file_identifier, ignore_status);
      store_forward_file_info.file_open := FALSE;
      IF read_error THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sf_read_network_file_error, ' ', status);
      IFEND;
      amp$return (nfc$manage_store_forward_file, ignore_status);
    PROCEND attach_sf_file_cond_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;
    store_forward_file_info.file_open := FALSE;
    store_forward_file_info.pointers.ptr_application_name_list := NIL;
    store_forward_file_info.pointers.ptr_group_name_list := NIL;
    store_forward_file_info.pointers.ptr_source_name_list := NIL;
    store_forward_file_info.pointers.ptr_target_name_list := NIL;
    read_error := FALSE;

{ check to see if the user is a system job.  if the user is not a system job, then
{ check to see if the user has validation for either network_application_management or network
{ operation.  If the user does not have validation, return with caller not privileged error.

    IF NOT jmp$system_job () THEN
      avp$get_capability (avc$network_applic_management, avc$user, user_capability_network_appl, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      avp$get_capability (avc$network_operation, avc$user, user_capability_network_oper, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (NOT user_capability_network_appl) AND (NOT user_capability_network_oper) THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sf_caller_not_privileged, nfv$manage_sf_network, status);
        RETURN;
      IFEND;
    IFEND;

    IF attach_file THEN

{ if requested by the user, attach the store_forward_network file.

      PUSH pf_store_forward_file_path: [1 .. 4];
      pf_store_forward_file_path^ [1] := nfc$sf_family_name;
      pf_store_forward_file_path^ [2] := nfc$sf_user_name;
      pf_store_forward_file_path^ [3] := nfc$sf_subcatalog_name;
      pf_store_forward_file_path^ [4] := nfc$sf_permanent_file_name;
      pf_access_mode := $pft$usage_selections [pfc$read];
      pf_share_mode := $pft$usage_selections [pfc$read];
      pf_password := osc$null_name;
      pf_cycle_selection.cycle_option := pfc$highest_cycle;
      pmp$get_unique_name (store_forward_file_info.local_file_name, status);
      attach_count := 0;

{ pfp$attach is used to attach the System's Store/Forward Network file because
{ we want to ensure that each instance of fsp$open_file opens the same cycle of this file
{ which is accomplished by using the local file name.  The local file name is also needed
{ to allow different tasks within the same job to open the same file.  A file identifier
{ cannot be passed between the various tasks within the job.

      REPEAT
        pfp$attach (store_forward_file_info.local_file_name, pf_store_forward_file_path^, pf_cycle_selection,
              pf_password, pf_access_mode, pf_share_mode, pfc$no_wait, status);
        IF NOT status.normal THEN

{ If the store_forward_network file is busy wait 15 seconds and then retry again

          IF NOT (status.condition = pfe$cycle_busy) THEN
            store_forward_file_info.local_file_name := osc$null_name;
            RETURN;
          IFEND;
          attach_count := attach_count + 1;
          pmp$wait (delay_time_for_attach, 0);
        IFEND;
      UNTIL (status.normal) OR (attach_count >= max_attach_tries);

{ if the store_forward_network file is still busy after max_attach_tries return with the bad status

      IF (NOT status.normal) AND (attach_count >= max_attach_tries) THEN
        RETURN;
      IFEND;
    IFEND;

{ open the store_forward_network file with access and share modes of READ only.

    PUSH ptr_file_attachment_options: [1 .. 2];
    ptr_file_attachment_options^ [1].selector := fsc$access_and_share_modes;
    ptr_file_attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
    ptr_file_attachment_options^ [1].access_modes.value := $fst$file_access_options [fsc$read];
    ptr_file_attachment_options^ [1].share_modes.selector := fsc$specific_share_modes;
    ptr_file_attachment_options^ [1].share_modes.value := $fst$file_access_options [fsc$read];
    ptr_file_attachment_options^ [2].selector := fsc$open_position;
    ptr_file_attachment_options^ [2].open_position := amc$open_at_boi;

    fsp$open_file (store_forward_file_info.local_file_name, amc$segment, ptr_file_attachment_options, NIL,
          NIL, NIL, NIL, store_forward_file_info.file_identifier, status);

    store_forward_file_info.file_open := status.normal;
    IF NOT status.normal THEN
      IF attach_file THEN
        amp$return (store_forward_file_info.local_file_name, ignore_status);
        store_forward_file_info.local_file_name := osc$null_name;
      IFEND;

{ if the user did not request to attach the store_forward_network file and
{ this file was not previously attached the error return by fsp$open_file
{ will be ame$new_file_requires_append.

      IF status.condition = ame$new_file_requires_append THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sf_no_store_forward_network, ' ', status);
      IFEND;
      RETURN;
    IFEND;

    pmp$establish_condition_handler (exit_condition, ^attach_sf_file_cond_handler, ^establish_descriptor,
          status);
    IF NOT status.normal THEN
      fsp$close_file (store_forward_file_info.file_identifier, ignore_status);
      IF attach_file THEN
        amp$return (store_forward_file_info.local_file_name, ignore_status);
        store_forward_file_info.local_file_name := osc$null_name;
      IFEND;
      store_forward_file_info.file_open := FALSE;
      RETURN;
    IFEND;

{ get the relative pointers for the various lists from the first part of the file

    amp$get_segment_pointer (store_forward_file_info.file_identifier, amc$sequence_pointer,
          store_forward_file_info.segment_pointer, status);
    RESET store_forward_file_info.segment_pointer.sequence_pointer;
    NEXT ptr_store_forward_file_ptrs IN store_forward_file_info.segment_pointer.sequence_pointer;

{ if the initial pointer for the file is NIL then the file is bad

    IF ptr_store_forward_file_ptrs = NIL THEN
      read_error := TRUE;
    IFEND;

    pmp$disestablish_cond_handler (exit_condition, ignore_status);

    IF read_error THEN

{ if an error has occurred close the store_forward_file

      fsp$close_file (store_forward_file_info.file_identifier, ignore_status);
      IF attach_file THEN
        amp$return (store_forward_file_info.local_file_name, ignore_status);
        store_forward_file_info.local_file_name := osc$null_name;
      IFEND;
      store_forward_file_info.file_open := FALSE;
      store_forward_file_info.segment_pointer.sequence_pointer := NIL;
      osp$set_status_abnormal (nfc$status_id, nfe$sf_read_network_file_error, ' ', status);
    ELSE
      store_forward_file_info.pointers := ptr_store_forward_file_ptrs^;
    IFEND;
  PROCEND nfp$open_store_forward_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$close_store_forward_file', EJECT ??

*copyc nfh$close_store_forward_file

  PROCEDURE [XDCL] nfp$close_store_forward_file
    (VAR store_forward_file_info: nft$store_forward_file_info;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status;

    status.normal := TRUE;

{ set all pointers to the various lists to NIL and file_open to FALSE

    store_forward_file_info.file_open := FALSE;
    store_forward_file_info.segment_pointer.sequence_pointer := NIL;
    store_forward_file_info.pointers.ptr_application_name_list := NIL;
    store_forward_file_info.pointers.ptr_group_name_list := NIL;
    store_forward_file_info.pointers.ptr_source_name_list := NIL;
    store_forward_file_info.pointers.ptr_target_name_list := NIL;

    fsp$close_file (store_forward_file_info.file_identifier, status);

    amp$return (store_forward_file_info.local_file_name, ignore_status);
    store_forward_file_info.local_file_name := osc$null_name;
  PROCEND nfp$close_store_forward_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$get_new_application_name', EJECT ??

*copyc nfh$get_new_application_name

  PROCEDURE [XDCL] nfp$get_new_application_name
    (    application_qualifier: nft$sf_applications;
         store_forward_file_info: nft$store_forward_file_info;
         destination_name: nft$parameter_24_definition;
     VAR application_name_changed: boolean;
     VAR new_application_name: ost$name;
     VAR status: ost$status);

    VAR
      destination_names_index: ost$non_negative_integers,
      ptr_current_application_info: ^nft$sf_application_name_info,
      ptr_current_dest_names_info: ^nft$sf_destination_names_array,
      ptr_current_group_name_info: ^nft$sf_group_name_information;

    status.normal := TRUE;
    application_name_changed := FALSE;

{ pointer to the first entry in the application list

    ptr_current_application_info := #PTR (store_forward_file_info.pointers.ptr_application_name_list,
          store_forward_file_info.segment_pointer.sequence_pointer^);

  /find_new_application_name/
    WHILE ptr_current_application_info <> NIL DO
      IF NOT ptr_current_application_info^.link.relative_pointer THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_rptr,
              'NFP$GET_NEW_APPLICATION_NAME 1', status);
        RETURN;
      IFEND;

{ check to see if the requesting application is valid for this application entry

      IF application_qualifier IN ptr_current_application_info^.application_qualifier THEN
        ptr_current_group_name_info := #PTR (store_forward_file_info.pointers.ptr_group_name_list,
              store_forward_file_info.segment_pointer.sequence_pointer^);

{ find the destination group entry from the current application entry in the group name list

        WHILE ptr_current_group_name_info <> NIL DO
          IF NOT ptr_current_group_name_info^.link.relative_pointer THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_rptr,
                  'NFP$GET_NEW_APPLICATION_NAME 2', status);
            RETURN;
          IFEND;
          IF NOT ptr_current_group_name_info^.ptr_destination_names.relative_pointer THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_rptr,
                  'NFP$GET_NEW_APPLICATION_NAME 3', status);
            RETURN;
          IFEND;

{ check to see if this is the destination group qualifier from the current application entry

          IF ptr_current_application_info^.destination_group_qualifier =
                ptr_current_group_name_info^.group_name THEN

            ptr_current_dest_names_info := #PTR (ptr_current_group_name_info^.ptr_destination_names.
                  relative_ptr, store_forward_file_info.segment_pointer.sequence_pointer^);
            FOR destination_names_index := 1 TO ptr_current_group_name_info^.destination_name_count DO

{ check to see if the destination name is in the destination
{ group qualifier for this application entry

              IF destination_name = ptr_current_dest_names_info^ [destination_names_index] THEN
                new_application_name := ptr_current_application_info^.next_hop_application;
                application_name_changed := TRUE;
                EXIT /find_new_application_name/;
              IFEND;
            FOREND;
          IFEND;
          ptr_current_group_name_info := #PTR (ptr_current_group_name_info^.link.relative_ptr,
                store_forward_file_info.segment_pointer.sequence_pointer^);
        WHILEND;
      IFEND;
      ptr_current_application_info := #PTR (ptr_current_application_info^.link.relative_ptr,
            store_forward_file_info.segment_pointer.sequence_pointer^);
    WHILEND /find_new_application_name/;
  PROCEND nfp$get_new_application_name;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$get_new_destination_name', EJECT ??

*copyc nfh$get_new_destination_name

  PROCEDURE [XDCL] nfp$get_new_destination_name
    (    application_qualifier: nft$sf_applications;
         store_forward_file_info: nft$store_forward_file_info;
         current_target_name: nft$parameter_24_definition;
     VAR target_name_changed: boolean;
     VAR new_target_name: nft$parameter_24_definition;
     VAR status: ost$status);

    VAR
      ptr_current_group_name_info: ^nft$sf_group_name_information,
      ptr_current_target_name_info: ^nft$sf_target_name_information;

    status.normal := TRUE;
    target_name_changed := FALSE;

{ pointer to the first entry in the target name list

    ptr_current_target_name_info := #PTR (store_forward_file_info.pointers.ptr_target_name_list,
          store_forward_file_info.segment_pointer.sequence_pointer^);

  /find_new_target_name/
    WHILE ptr_current_target_name_info <> NIL DO
      IF NOT ptr_current_target_name_info^.link.relative_pointer THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_rptr,
              'NFP$GET_NEW_DESTINATION_NAME', status);
        RETURN;
      IFEND;

{ check to see if the requesting application is valid for this target name entry

      IF (application_qualifier IN ptr_current_target_name_info^.application_qualifier) AND
            (current_target_name = ptr_current_target_name_info^.target_name) THEN

        new_target_name := ptr_current_target_name_info^.next_hop_name;
        target_name_changed := TRUE;
        EXIT /find_new_target_name/;
      IFEND;
      ptr_current_target_name_info := #PTR (ptr_current_target_name_info^.link.relative_ptr,
            store_forward_file_info.segment_pointer.sequence_pointer^);
    WHILEND /find_new_target_name/;
  PROCEND nfp$get_new_destination_name;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$get_new_source_name', EJECT ??

*copyc nfh$get_new_source_name

  PROCEDURE [XDCL] nfp$get_new_source_name
    (    application_qualifier: nft$sf_applications;
         store_forward_file_info: nft$store_forward_file_info;
         current_source_name: nft$parameter_24_definition;
         destination_name: nft$parameter_24_definition;
     VAR source_name_changed: boolean;
     VAR new_source_name: nft$parameter_24_definition;
     VAR status: ost$status);

    VAR
      destination_names_index: ost$non_negative_integers,
      ptr_current_dest_names_info: ^nft$sf_destination_names_array,
      ptr_current_group_name_info: ^nft$sf_group_name_information,
      ptr_current_source_name_info: ^nft$sf_source_name_information;

    status.normal := TRUE;
    source_name_changed := FALSE;

{ pointer to the first entry in the source name list

    ptr_current_source_name_info := #PTR (store_forward_file_info.pointers.ptr_source_name_list,
          store_forward_file_info.segment_pointer.sequence_pointer^);

  /find_new_source_name/
    WHILE ptr_current_source_name_info <> NIL DO
      IF NOT ptr_current_source_name_info^.link.relative_pointer THEN
        osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_rptr, 'NFP$GET_NEW_SOURCE_NAME 1',
              status);
        RETURN;
      IFEND;

{ check to see if the requesting application is valid for this source name entry

      IF (application_qualifier IN ptr_current_source_name_info^.application_qualifier) AND
            (current_source_name = ptr_current_source_name_info^.source_name) THEN
        ptr_current_group_name_info := #PTR (store_forward_file_info.pointers.ptr_group_name_list,
              store_forward_file_info.segment_pointer.sequence_pointer^);

{ find the destination group entry from the current source name entry in the group name list

        WHILE ptr_current_group_name_info <> NIL DO
          IF NOT ptr_current_group_name_info^.link.relative_pointer THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_rptr,
                  'NFP$GET_NEW_SOURCE_NAME 2', status);
            RETURN;
          IFEND;
          IF NOT ptr_current_group_name_info^.ptr_destination_names.relative_pointer THEN
            osp$set_status_abnormal (nfc$status_id, nfe$sf_internal_error_bad_rptr,
                  'NFP$GET_NEW_SOURCE_NAME 3', status);
            RETURN;
          IFEND;

{ check to see if this is the destination group qualifier from the current source name entry

          IF ptr_current_source_name_info^.destination_group_qualifier =
                ptr_current_group_name_info^.group_name THEN

            ptr_current_dest_names_info := #PTR (ptr_current_group_name_info^.ptr_destination_names.
                  relative_ptr, store_forward_file_info.segment_pointer.sequence_pointer^);
            FOR destination_names_index := 1 TO ptr_current_group_name_info^.destination_name_count DO

{ check to see if the destination name is in the destination
{ group qualifier for this source name entry

              IF destination_name = ptr_current_dest_names_info^ [destination_names_index] THEN
                new_source_name := ptr_current_source_name_info^.next_hop_name;
                source_name_changed := TRUE;
                EXIT /find_new_source_name/;
              IFEND;
            FOREND;
          IFEND;
          ptr_current_group_name_info := #PTR (ptr_current_group_name_info^.link.relative_ptr,
                store_forward_file_info.segment_pointer.sequence_pointer^);
        WHILEND;
      IFEND;
      ptr_current_source_name_info := #PTR (ptr_current_source_name_info^.link.relative_ptr,
            store_forward_file_info.segment_pointer.sequence_pointer^);
    WHILEND /find_new_source_name/;
  PROCEND nfp$get_new_source_name;
?? OLDTITLE ??
MODEND nfm$store_forward_utilities;
*DECK DECK=NFM$SUBMIT_MULTI_RECORD_JOB EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network File Transfer : Submit Multi-Record Job' ??
MODULE nfm$submit_multi_record_job;

{ PURPOSE:
{   This module contains the procedure to create a RHF structured (multiple
{   records) job file.
{
{ DESIGN:
{   Create a job by taking each file (in the order specified) and making it
{   a Trailing_Character_Delimited file and then copy this temporary file as
{   a Variable record on the RHF structured job file.  Then submit this
{   RHF structured job file to the remote system as specified on the calling
{   command.
{
{ NOTES:
{   The job file created must NOT have an EMPTY file as the first record,
{   as this would be an empty command record.
{
{   When this RHF structured job is submitted to the system, it is required
{   that the job submission options have:
{     1. DATA_MODE set to RHF_STRUCTURED and
{     2. LOGIN_FAMILY_SUPPLIED set to FALSE, so that NOS/VE does not try to
{        crack the first record as a LOGIN command.
{
{   The last restriction for submitting of the RHF structured job is that the
{   job must be transferred by a Queue Transfer application to a remote system.
{   This is required so that when the job is received on the remote system the
{   variable record header is stripped off of each of the job records.  That is
{   why the JOB_DESTINATION_USAGE parameter has the keyword values of 'VE',
{   'LOCAL' and 'VE_QTF' as hidden keys.

?? NEWTITLE := 'Global References', EJECT ??
*copyc amp$get_file_attributes
*copyc amp$get_next
*copyc amp$put_next
*copyc amp$return
*copyc clp$change_variable
*copyc clp$evaluate_parameters
*copyc fsp$close_file
*copyc fsp$copy_file
*copyc fsp$open_file
*copyc jmp$submit_job
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pmp$get_unique_name
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nfp$_submit_multi_record_job', EJECT ??

{    The purpose of this command is to create a job that has multiple
{ records that can be submitted to a non-NOS/VE system.  However,
{ this does not prevent a user from creating a job for a NOS/VE
{ system, but this NOS/VE job must be transferred to a remote
{ system using a Queue Transfer application.
{
{ NOTES:
{   The block_exit_condition_handler is used to return all scratch
{   files and scratch segments that were created by this command procedure.

  PROCEDURE [XDCL] nfp$_submit_multi_record_job
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*copy nft$pdt_submit_multi_record_job

    CONST
      local_catalog_name = ':$LOCAL.',
      local_catalog_name_length = 8,
      max_submission_options = 7,
      record_delimiting_character = $CHAR(1f(16));

    VAR
      block_exit_condition_handler: pmt$condition_handler,
      existing_file: boolean,
      file_byte_address: amt$file_byte_address,
      file_contains_data: boolean,
      file_is_local: boolean,
      file_list_entry: ^clt$data_value,
      file_list_entry_number: integer,
      file_position: amt$file_position,
      file_transfer_count: amt$transfer_count,
      ignore_status: ost$status,
      job_file_creation_attributes: array [1 .. 1] of fst$file_cycle_attribute,
      job_file_identifier: amt$file_identifier,
      job_file_name: string (osc$max_name_size + local_catalog_name_length),
      job_submission_options: ^jmt$job_submission_options,
      ptr_scratch_segment: amt$segment_pointer,
      system_job_name: ^clt$data_value,
      system_supplied_name: jmt$system_supplied_name,
      t_record_file_attribute: ^fst$file_cycle_attributes,
      temporary_file_attach_options: array [1 .. 3] of fst$attachment_option,
      temporary_file_get_attributes: array [1 .. 1] of amt$get_item,
      temporary_file_identifier: amt$file_identifier,
      temporary_file_name: string (osc$max_name_size + local_catalog_name_length),
      temporary_file_override_attr: array [1 .. 2] of fst$file_cycle_attribute,
      unique_name: ost$name,
      working_storage_area: ^array [1 .. *] of char;

?? NEWTITLE := 'exit_condition_handler', EJECT ??

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

{  close and return all files created by this command

      fsp$close_file (job_file_identifier, ignore_status);
      amp$return (job_file_name, ignore_status);

      fsp$close_file (temporary_file_identifier, ignore_status);
      amp$return (temporary_file_name, ignore_status);

{  delete the scratch segment that was used as the working storage
{  area for the creation of the rhf structured file.

      mmp$delete_scratch_segment (ptr_scratch_segment, ignore_status);

   PROCEND exit_condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

{  the keyword values NTF or QTF are the only valid keyword options for the JOB_DESTINATION_USAGE parameter
{  in particular the keyword values VE, VE_LOCAL and VE_QTF are invalid because the job must be
{  transferred through a queue transfer application to convert the RHF_STRUCTURE job file to a standard file

    IF pvt [p$job_destination_usage].value^.kind = clc$keyword THEN
      IF NOT ((pvt [p$job_destination_usage].value^.keyword_value = jmc$ntf_usage) OR
            (pvt [p$job_destination_usage].value^.keyword_value = jmc$qtf_usage)) THEN
        osp$set_status_abnormal ('JM', jme$invalid_parameter, pvt [p$job_destination_usage].value^
              .keyword_value, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'JOB_DESTINATION_USAGE', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'SUBMIT_MULTI_RECORD_JOB', status);
        RETURN; {----->
      IFEND;
    IFEND;

    file_position := amc$boi;

{  define the record type for the rhf structured file that is to be submitted to the system.

    job_file_creation_attributes [1].selector := fsc$record_type;
    job_file_creation_attributes [1].record_type := amc$variable;

{  define the attach options for the temporary file that is a copy of the user's file.
{  these attach options are needed because the record type is being overridden when it is opened.

    temporary_file_attach_options [1].selector := fsc$access_and_share_modes;
    temporary_file_attach_options [1].access_modes.selector := fsc$specific_access_modes;
    temporary_file_attach_options [1].access_modes.value := $fst$file_access_options [fsc$read];
    temporary_file_attach_options [1].share_modes.selector := fsc$specific_share_modes;
    temporary_file_attach_options [1].share_modes.value := $fst$file_access_options [fsc$read];
    temporary_file_attach_options [2].selector := fsc$open_share_modes;
    temporary_file_attach_options [2].open_share_modes := $fst$file_access_options [fsc$read];
    temporary_file_attach_options [3].selector := fsc$open_position;
    temporary_file_attach_options [3].open_position := amc$open_at_boi;

{  define the file attributes that are needed to get from the temporary file.

    temporary_file_get_attributes [1].key := amc$file_length;

{  define the override attributes for the temporary file.

    temporary_file_override_attr [1].selector := fsc$block_type;
    temporary_file_override_attr [1].block_type := amc$system_specified;
    temporary_file_override_attr [2].selector := fsc$record_type;
    temporary_file_override_attr [2].record_type := amc$undefined;

{  define the record type for the temporary file that is a copy of the user's file.

    PUSH t_record_file_attribute: [1 .. 2];
    t_record_file_attribute^ [1].selector := fsc$record_type;
    t_record_file_attribute^ [1].record_type := amc$trailing_char_delimited;
    t_record_file_attribute^ [2].selector := fsc$record_delimiting_character;
    t_record_file_attribute^ [2].record_delimiting_character := record_delimiting_character;

{  create unique file names for the temporary file and the file that is to be submitted to the system.

    pmp$get_unique_name (unique_name, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    job_file_name := local_catalog_name;
    job_file_name ((local_catalog_name_length + 1), *) := unique_name;

    pmp$get_unique_name (unique_name, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    temporary_file_name := local_catalog_name;
    temporary_file_name ((local_catalog_name_length + 1), *) := unique_name;

    block_exit_condition_handler := ^exit_condition_handler;
    osp$establish_block_exit_hndlr (block_exit_condition_handler);

{  create a scratch segment that will be used as the working storage area
{  for the creation of the file that is to be submitted to the system.

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, ptr_scratch_segment, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

{  open the file that is to be submitted to the system.

    fsp$open_file (job_file_name, amc$record, NIL, NIL, ^job_file_creation_attributes, NIL, NIL,
          job_file_identifier, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

{  get the first user's file.

    file_list_entry_number := 1;
    file_list_entry := pvt [p$file].value;

  /use_scratch_segment/
    WHILE file_list_entry <> NIL DO

{  copy the user's file to a T record temporary file.

      fsp$copy_file (file_list_entry^.element_value^.file_value^, temporary_file_name, NIL, NIL,
            t_record_file_attribute, status);
      IF status.normal THEN

{  get the size of the temporary file.

        amp$get_file_attributes (temporary_file_name, temporary_file_get_attributes, file_is_local,
              existing_file, file_contains_data, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;

{  the check for file length of 1 is to determine if the file is empty because each T-record
{  file has at least one character in each record, the record_delimiting_character.

        IF temporary_file_get_attributes [1].file_length > 1 THEN

{  the temporary file is not empty so copy this file to the job file.

          RESET ptr_scratch_segment.sequence_pointer;
          NEXT working_storage_area: [1 .. temporary_file_get_attributes [1].file_length] IN
                ptr_scratch_segment.sequence_pointer;

{  open and write the temporary T record file as an UNDEFINED record.

          fsp$open_file (temporary_file_name, amc$record, ^temporary_file_attach_options, NIL, NIL, NIL,
                ^temporary_file_override_attr, temporary_file_identifier, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          amp$get_next (temporary_file_identifier, working_storage_area, #SIZE (working_storage_area^),
                file_transfer_count, file_byte_address, file_position, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          amp$put_next (job_file_identifier, working_storage_area, file_transfer_count, file_byte_address,
                status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

{  close the temporary version of the user's file.

          fsp$close_file (temporary_file_identifier, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        ELSEIF file_list_entry_number > 1 THEN

{  the temporary file is empty but it is not the first file to copy into the job file.
{  therefore, this will allow for an empty record within the job file.

          amp$put_next (job_file_identifier, working_storage_area, 0, file_byte_address, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        ELSE

{  the first temporary file is empty, therefore this would create an invalid job
{  (first record of the job would be empty).

          osp$set_status_abnormal ('FS', fse$empty_input_file, file_list_entry^.element_value^.file_value^,
                status);
          RETURN; {----->
        IFEND;

{  return the temporary version of the user's file.

        amp$return (temporary_file_name, ignore_status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      ELSEIF NOT status.normal AND (status.condition = fse$empty_input_file) AND (file_list_entry_number > 1)
            THEN
        amp$put_next (job_file_identifier, working_storage_area, 0, file_byte_address, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      ELSE
        RETURN; {----->
      IFEND;

{  get the next file in the list of user's files.

      file_list_entry := file_list_entry^.link;
      file_list_entry_number := file_list_entry_number + 1;
    WHILEND /use_scratch_segment/;

{ close the scratch segment that was used as the working storage area.

    mmp$delete_scratch_segment (ptr_scratch_segment, ignore_status);

{  close the file that is to be submitted to the system.

    fsp$close_file (job_file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  create the job submission options required to submit this file.

    PUSH job_submission_options: [1 .. max_submission_options];

    job_submission_options^ [1].key := jmc$data_mode;
    job_submission_options^ [1].data_mode := jmc$rhf_structure;

    job_submission_options^ [2].key := jmc$login_command_supplied;
    job_submission_options^ [2].login_command_supplied := FALSE;

{  get the rest of the job submission options from the parameters for this command.

    job_submission_options^ [3].key := jmc$job_destination_family;
    IF pvt [p$job_destination].value^.kind = clc$name THEN
      job_submission_options^ [3].job_destination_family := pvt [p$job_destination].value^.name_value;
    ELSE
      job_submission_options^ [3].job_destination_family := pvt [p$job_destination].value^.string_value^;
    IFEND;

    job_submission_options^ [4].key := jmc$job_destination_usage;
    IF pvt [p$job_destination_usage].value^.kind = clc$name THEN
      job_submission_options^ [4].job_destination_usage := pvt [p$job_destination_usage].value^.name_value;
    ELSE
      job_submission_options^ [4].job_destination_usage := pvt [p$job_destination_usage].value^.keyword_value;
    IFEND;

    job_submission_options^ [5].key := jmc$output_disposition;
    IF pvt [p$output_disposition].value^.keyword_value = 'DISCARD_ALL_OUTPUT' THEN
      job_submission_options^ [5].output_disposition.key := jmc$discard_all_output;
    ELSEIF pvt [p$output_disposition].value^.keyword_value = 'DISCARD_STANDARD_OUTPUT' THEN
      job_submission_options^ [5].output_disposition.key := jmc$discard_standard_output;
    ELSEIF pvt [p$output_disposition].value^.keyword_value = 'LOCAL' THEN
      job_submission_options^ [5].output_disposition.key := jmc$local_output_disposition;
    ELSEIF pvt [p$output_disposition].value^.keyword_value = 'PRINTER' THEN
      job_submission_options^ [5].output_disposition.key := jmc$normal_output_disposition;
    ELSEIF pvt [p$output_disposition].value^.keyword_value = 'WAIT_QUEUE' THEN
      job_submission_options^ [5].output_disposition.key := jmc$wait_queue_path;
      job_submission_options^ [5].output_disposition.wait_queue_path := NIL;
    IFEND;

    job_submission_options^ [6].key := jmc$remote_host_directive;
    PUSH job_submission_options^ [6].remote_host_directive;
    job_submission_options^ [6].remote_host_directive^.size := STRLENGTH (pvt [p$remote_host_directive]
          .value^.string_value^);
    job_submission_options^ [6].remote_host_directive^.parameters := pvt [p$remote_host_directive].value^
          .string_value^;

    IF pvt [p$user_job_name].specified THEN
      job_submission_options^ [7].key := jmc$user_job_name;
      job_submission_options^ [7].user_job_name := pvt [p$user_job_name].value^.name_value;
    ELSE
      job_submission_options^ [7].key := jmc$null_attribute;
    IFEND;

{  submit the rhf structured file to the system.

    jmp$submit_job (job_file_name, job_submission_options, system_supplied_name, status);

{  return the rhf structured file.

    amp$return (job_file_name, ignore_status);

    IF status.normal THEN

{  return the system_job_name to the user

      IF pvt [p$system_job_name].specified THEN
        PUSH system_job_name;
        system_job_name^.kind := clc$name;
        system_job_name^.name_value := system_supplied_name;
        clp$change_variable (pvt [p$system_job_name].variable^, system_job_name, status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND nfp$_submit_multi_record_job;
?? OLDTITLE ??
MODEND nfm$submit_multi_record_job;
*DECK DECK=NFM$VERIFY_DRJE_CONFIGURATION EXPAND=TRUE
create_program_description name=(VERIFY_DRJE_CONFIGURATION, VERDC) ..
    starting_procedure=nfp$verify_drje_configuration ..
    library=$system.network_transfer_facility.dynamic_remote_job_entry.drje_library ..
    load_map_options=none load_map=$null ..
    termination_error_level=warning ..
    preset_value=zero arithmetic_overflow=on ..
    arithmetic_loss_of_significance=on divide_fault=on ..
    exponent_overflow=on exponent_underflow=on fp_indefinite=on ..
    fp_loss_of_significance=off invalid_bdp_data=on ..
    debug_mode=off
*DECK DECK=NFM$VERIFY_FAMILY EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE PTF Application : Verify Family' ??

MODULE nfm$verify_family;

{
{ PURPOSE:
{   This module contains a procedure to check if a family
{   is registered on the local mainframe.
{

?? NEWTITLE := '  Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*copyc dfp$locate_served_family
*copyc osp$get_set_name

?? TITLE := '  [XDCL, #GATE] nfp$verify_family', EJECT ??
{
{     The purpose of this request is to determine if the specified family name
{ is an active family on the local NOS/VE mainframe.  For the purpose of this
{ routine a family served by the file server is viewed as local.
{
{       NFP$VERIFY_FAMILY (FAMILY_NAME, FAMILY_IS_LOCAL, STATUS)
{
{ FAMILY_NAME: (input)  This parameter specifies the name of the family being
{       checked.
{
{ FAMILY_IS_LOCAL: (output)  This parameter is a boolean value that specifies
{       whether the family is active on the local mainframe.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: none.
{

  PROCEDURE [XDCL, #GATE] nfp$verify_family (family_name: ost$family_name;
    VAR family_is_local: BOOLEAN;
    VAR status: ost$status);

    VAR
      file_server_family: boolean,
      served_family_table_index: dft$served_family_table_index,
      server_mainframe_id: pmt$binary_mainframe_id,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
      server_state: dft$server_state,

      local_status: ost$status,
      set_name: stt$set_name;


    status.normal := TRUE;
    dfp$locate_served_family (family_name, file_server_family, served_family_table_index,
           server_mainframe_id, p_queue_interface_table, queue_index, server_state);
    IF file_server_family THEN
      family_is_local := TRUE;
      RETURN;
    IFEND;

    local_status.normal := TRUE;
    osp$get_set_name (family_name, set_name, local_status);
    IF local_status.normal THEN
      family_is_local := TRUE;
    ELSEIF local_status.condition = pfe$unknown_family THEN
      family_is_local := FALSE;
    ELSE
      status := local_status;
    IFEND;

  PROCEND nfp$verify_family;

MODEND nfm$verify_family;

*DECK DECK=NFP$ADD_BTF_TASK_TO_LIST EXPAND=FALSE
  PROCEDURE [XREF] nfp$add_btf_task_to_list
    (    task_id: pmt$task_id;
         queue_id: pmt$queue_connection;
         network_address: nat$network_address;
         btfs_di_title: nft$btfs_di_title;
         station: ost$name;
         device: ost$name;
     VAR wait_list {input, output} : ^ost$i_wait_list;
     VAR wait_activity_list {input, output} : ^nft$wait_activity_list;
     VAR wait_list_sequence {input, output} : ^SEQ(*);
     VAR wait_activity_list_sequence {input, output} : ^SEQ(*);
     VAR new_btf_task: ^nft$btf_task);

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_address
*copyc nft$btf_task
*copyc nft$btfs_di_title
*copyc nft$wait_activity_list
*copyc ost$i_wait
*copyc pmd$local_queues
*copyc pmt$task_id
?? POP ??
*DECK DECK=NFP$ADD_TO_WAIT_LISTS EXPAND=FALSE
  PROCEDURE [XREF] nfp$add_to_wait_lists
    (    activity: nft$wait_activity;
     VAR wait_list {input, output} : ^ost$i_wait_list;
     VAR wait_activity_list {input, output} : ^nft$wait_activity_list;
     VAR wait_list_sequence {input, output} : ^SEQ(*);
     VAR wait_activity_list_sequence {input, output} : ^SEQ(*));

?? PUSH (LISTEXT := ON) ??
*copyc nft$wait_activity_list
*copyc ost$i_wait
?? POP ??
*DECK DECK=NFP$BEGIN_ASYNCHRONOUS_TASK EXPAND=FALSE
  PROCEDURE [XREF] nfp$begin_asynchronous_task
    (    parameters: pmt$program_parameters;
     VAR connected_task: pmt$task_id;
     VAR queue_id: pmt$queue_connection;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nfe$common_task_communication
*copyc pmd$local_queues
*copyc pmt$program_parameters
*copyc pmt$task_id
*copyc ost$status
?? POP ??
*DECK DECK=NFP$BTFS_DI_MATCH EXPAND=FALSE

  FUNCTION [XREF] nfp$btfs_di_match
    (    first_title: nft$btfs_di_title;
         first_address: nat$network_address;
         second_title: nft$btfs_di_title;
         second_address: nat$network_address): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_address
*copyc nft$btfs_di_title
?? POP ??
*DECK DECK=NFP$CHECK_IMPLICIT_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] nfp$check_implicit_access
    (    family_name: ost$family_name;
     VAR remote_access: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$user_identification
*copyc ost$status
?? POP ??
*DECK DECK=NFP$CHECK_REMOTE_ACCESS EXPAND=TRUE

  PROCEDURE [XREF] nfp$check_remote_access (
        file: amt$local_file_name;
    VAR remote_access: BOOLEAN;
    VAR remote_path: ost$string;
    VAR remote_family: ost$family_name;
    VAR status: ost$status);

?? PUSH (LISTEXT :=ON) ??
?? POP ??
*DECK DECK=NFP$CLEAR_REMOTE_VALIDATION EXPAND=TRUE

  PROCEDURE [XREF] nfp$clear_remote_validation (location: ost$name;
    VAR status: ost$status);

?? PUSH (LISTEXT :=ON) ??
*copyc nft$remote_validation
?? POP ??
*DECK DECK=NFP$CLOSE_STORE_FORWARD_FILE EXPAND=FALSE

  PROCEDURE [XREF] nfp$close_store_forward_file
    (VAR store_forward_file_info: nft$store_forward_file_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$store_forward_file_info
*copyc ost$status
?? POP ??
*DECK DECK=NFP$CONVERT_P31_TO_ORDINAL EXPAND=FALSE
  PROCEDURE [XREF] nfp$convert_p31_to_ordinal
    (    received_value: string ( * <= nfc$max_param_size);
     VAR data_declaration: nft$parameter_31_type;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nfc$parameter_definitions
*copyc nft$parameter_31_type
*copyc ost$status
?? POP ??
*DECK DECK=NFP$COUNT_DIRECTIVES_TEXT EXPAND=FALSE
  FUNCTION [XREF] nfp$count_directives_text
    (    directives_list: ^nft$directive_entry): ost$non_negative_integers;

?? PUSH (LISTEXT := ON) ??
*copyc nft$directive_entry
*copyc osd$integer_limits
?? POP ??
*DECK DECK=NFP$CRACK_COMMAND EXPAND=FALSE
  PROCEDURE [XREF] nfp$crack_command
    (    command_string: string (nfc$pdu_command_len);
     VAR command: nft$protocol_commands;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nfc$command_definitions
*copyc nft$protocol_commands
*copyc ost$status
?? POP ??
*DECK DECK=NFP$CRACK_FILE_ASSIGNMENT_MSG EXPAND=FALSE
  PROCEDURE [XREF] nfp$crack_file_assignment_msg
    (VAR message: ^nft$message_sequence;
     VAR message_length: integer;
     VAR station: ost$name;
     VAR device: ost$name;
     VAR device_type: nft$device_type;
     VAR device_attributes: nft$device_attributes;
     VAR btfs_address: nft$network_address;
     VAR btfs_di_title: nft$btfs_di_title;
     VAR file_name: jmt$system_supplied_name;
     VAR descriptor: nft$application_file_descriptor;
     VAR remote_system_protocol: nft$ntf_remote_system_protocol;
     VAR remote_system_type: nft$ntf_remote_system_type;
     VAR route_back_position: nft$ntf_route_back_position;
     VAR last_parameter_sent: nft$file_assignment_params;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$application_file_descriptor
*copyc nft$btfs_di_title
*copyc nft$device_type
*copyc nft$device_attributes
*copyc nft$file_assignment_msg
*copyc nft$message_sequence
*copyc nft$network_address
*copyc nft$ntf_remote_system_protocol
*copyc nft$ntf_remote_system_type
*copyc nft$ntf_route_back_position
*copyc ost$status
?? POP ??
*DECK DECK=NFP$CRACK_NUMBER_OF_PARAMETERS EXPAND=FALSE
  PROCEDURE [XREF] nfp$crack_number_of_parameters
    (    number_string: string (nfc$pdu_nparams_len);
     VAR number_parameters: nft$number_pdu_param_range;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nfc$command_definitions
*copyc nft$number_pdu_param_range
*copyc ost$status
?? POP ??
*DECK DECK=NFP$CRACK_PARAMETER EXPAND=FALSE
  PROCEDURE [XREF] nfp$crack_parameter
    (    command: nft$protocol_commands;
         protocol: nft$parameter_00_values;
         parameter: string ( * <= nfc$max_qualified_param_size);
         p_rules: nft$parameter_rules_array;
     VAR buffer_list: nft$network_buffer_list;
     VAR length: nft$parameter_size;
     VAR value: string ( * <= nfc$max_param_size);
     VAR identifier: nft$protocol_parameters;
     VAR qualifier: nft$parameter_qualifiers;
     VAR action: nft$crack_parameter_action;
     VAR ignored_params: nft$parameter_set;
     VAR abort_xfer: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$crack_parameter_action
*copyc nft$network_buffer_list
*copyc nfc$parameter_definitions
*copyc nft$protocol_commands
*copyc nft$parameter_00_values
*copyc nft$parameter_qualifiers
*copyc nft$parameter_rules_array
*copyc nft$parameter_set
*copyc nft$parameter_size
*copyc nft$protocol_parameters
*copyc ost$status
?? POP ??
*DECK DECK=NFP$CRACK_PDU EXPAND=FALSE
  PROCEDURE [XREF] nfp$crack_pdu
    (    received_command: nft$protocol_commands;
         input_buffer: string ( * <= nfc$command_buffer_size);
         number_of_parameters: nft$number_pdu_param_range;
     VAR more_command_blocks: boolean;
     VAR received_params: nft$parameter_set;
     VAR ignored_params: nft$parameter_set;
     VAR modified_params: nft$parameter_set;
     VAR control_block: nft$control_block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nfc$command_definitions
*copyc nft$control_block
*copyc nft$number_pdu_param_range
*copyc nft$parameter_set
*copyc nft$protocol_commands
*copyc ost$status
?? POP ??
*DECK DECK=NFP$CRACK_TERQO_MSG EXPAND=FALSE
  PROCEDURE [XREF] nfp$crack_terqo_msg
    (VAR message: ^nft$message_sequence;
     VAR message_length: integer;
     VAR io_station_name: ost$name;
     VAR system_file_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc nft$message_sequence
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=NFP$CREATE_APPL_DEF_SEGMENT_VAR EXPAND=FALSE

  PROCEDURE [XREF] nfp$create_appl_def_segment_var
    (application: nft$appl_def_segment_values;
     application_defined_segment: ^cell);

?? PUSH (LISTEXT := ON) ??
*copyc nft$appl_def_segment_values
?? POP ??
*DECK DECK=NFP$CREATE_WAIT_QUEUE_FILE_NAME EXPAND=FALSE
  PROCEDURE [XREF] nfp$create_wait_queue_file_name
    (    family_name: ost$name;
         user_name: ost$name;
         user_file_name: jmt$user_supplied_name;
     VAR wait_queue_file_name: amt$local_file_name;
     VAR status: ost$status);

*copyc amt$local_file_name
*copyc jmt$user_supplied_name
*copyc ost$name
*copyc ost$status
*DECK DECK=NFP$DEALLOCATE_DIRS_FROM_HEAD EXPAND=FALSE
  PROCEDURE [XREF] nfp$deallocate_dirs_from_head
    (VAR directive_head: nft$directive_entry_list_head;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$directive_entry_list_head
*copyc ost$status
?? POP ??
*DECK DECK=NFP$DELETE_BTF_TASK EXPAND=FALSE
  PROCEDURE [XREF] nfp$delete_btf_task
    (    list_index: integer;
         wait_activity_list {input, output} : ^nft$wait_activity_list;
     VAR btf_task {input, output} : ^nft$btf_task);

?? PUSH (LISTEXT := ON) ??
*copyc nft$wait_activity_list
?? POP ??
*DECK DECK=NFP$DEQUEUE_DIRECTIVES_ON_LIST EXPAND=FALSE
  PROCEDURE [XREF] nfp$dequeue_directives_on_list
    (VAR directive_list: ^nft$directive_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$directive_entry
*copyc ost$status
?? POP ??
*DECK DECK=NFP$DISPOSE_USER_MSG_TO_LOG EXPAND=FALSE
  PROCEDURE [XREF] nfp$dispose_user_msg_to_log
    (VAR directive_list: nft$directive_entry_list_head);

?? PUSH (LISTEXT := ON) ??
*copyc nft$directive_entry_list_head
?? POP ??
*DECK DECK=NFP$END_ASYNC_COMMUNICATION EXPAND=FALSE
  PROCEDURE [XREF] nfp$end_async_communication
    (    check_activity: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=NFP$ENQUEUE_DIRECTIVE_ON_LIST EXPAND=FALSE
  PROCEDURE [XREF] nfp$enqueue_directive_on_list
    (    directive_value: string ( * <= nfc$max_param_size);
     VAR directive_list: nft$directive_entry_list_head;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nfc$parameter_definitions
*copyc nft$directive_entry_list_head
*copyc ost$status
?? POP ??
*DECK DECK=NFP$ENQUEUE_STATUS_DIRECTIVE EXPAND=FALSE
  PROCEDURE [XREF] nfp$enqueue_status_directive
    (    send_status: ost$status;
     VAR directive_list: nft$directive_entry_list_head;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$directive_entry_list_head
*copyc ost$status
?? POP ??
*DECK DECK=NFP$ENQUEUE_TASK EXPAND=FALSE
  PROCEDURE [XREF] nfp$enqueue_task
    (    task_id: pmt$task_id;
         path: nft$network_connection;
     VAR task_queue: nft$task_queue);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$task_id
*copyc nft$task_queue
*copyc nft$network_connection
?? POP ??
*DECK DECK=NFP$ESTABLISH_CF_CONNECTION EXPAND=FALSE
  PROCEDURE [XREF] nfp$establish_cf_connection
    (    service_address: nat$network_address;
         connect_file: fst$file_reference;
         client_version: 0 .. 0ff(16);
         client_identifier: string (* <= nfc$max_scfs_client_id_length);
         client_name: nat$application_name;
     VAR control_facility_name: ost$name;
     VAR connection_identifier: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc fst$file_reference
*copyc nat$application_name
*copyc nat$network_address
*copyc nft$scfs_client_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NFP$FIND_DELIMITD_STRING_LENGTH EXPAND=FALSE
?? NEWTITLE := 'nfp$find_delimitd_string_length', EJECT ??

  PROCEDURE [INLINE] nfp$find_delimitd_string_length
    (    input_string: string ( * <= nfc$max_param_size);
     VAR length: integer;
     VAR status: ost$status);

{}

    TYPE
      set_of_char = set of char;

    VAR
      object_of_scan: set_of_char,
      scan_object_found: boolean,
      scan_index: ost$string_size;

{}
{}
    object_of_scan := $set_of_char [' '];
    #SCAN (object_of_scan, input_string, scan_index, scan_object_found);
    IF scan_object_found THEN
      status.normal := TRUE;
      length := scan_index - 1;
    ELSE
      osp$set_status_abnormal (nfc$status_id, nfe$bts_internal_error,
            'nfp$find_delimitd_string_length', status);
    IFEND;
{}
  PROCEND nfp$find_delimitd_string_length;
?? OLDTITLE ??
*DECK DECK=NFP$FIND_REMOTE_VALIDATION EXPAND=TRUE

  PROCEDURE [XREF] nfp$find_remote_validation (location: ost$name;
    VAR validation_line_count: 0 .. nfc$max_validation_lines;
    VAR status: ost$status);

?? PUSH (LISTEXT :=ON) ??
*copyc nft$remote_validation
?? POP ??
*DECK DECK=NFP$FORMAT_MESSAGE_TO_JOB_LOG EXPAND=FALSE
  PROCEDURE [XREF] nfp$format_message_to_job_log
    (    status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=NFP$GENERATE_PTF_STATISTIC EXPAND=FALSE
procedure [xref] nfp$generate_ptf_statistic(
      begin_connect_time: ost$date_time;
      end_connect_time: ost$date_time;
      file_size: amt$file_length;
      transfer_directives_length: ost$non_negative_integers;
      local_mainframe_system_name: string(*<=nfc$p27_max_param_size);
      remote_mainframe_system_name: string(*<=nfc$p25_max_param_size);
      application: nft$application_values;
      ptf_command: ost$string);
?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc amt$file_length
*copyc nfc$parameter_27_definitions
*copyc nfc$parameter_25_definitions
*copyc nft$application_values
*copyc osd$integer_limits
*copyc ost$string
?? POP ??
*DECK DECK=NFP$GET_AND_CRACK_COMMAND EXPAND=FALSE
  PROCEDURE [XREF] nfp$get_and_crack_command
    (    legal_commands: nft$command_set;
         input_buffer: ^string (nfc$command_buffer_size);
     VAR control_block: nft$control_block;
     VAR input_length: nft$command_pdu_size;
     VAR number_of_parameters: nft$number_pdu_param_range;
     VAR received_command: nft$protocol_commands;
     VAR command_in_process: nft$protocol_commands;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$command_set
*copyc nft$command_pdu_size
*copyc nft$control_block
*copyc nft$number_pdu_param_range
*copyc nft$protocol_commands
*copyc ost$status
?? POP ??
*DECK DECK=NFP$GET_ASYNC_TASK_MESSAGE EXPAND=FALSE
  PROCEDURE [XREF] nfp$get_async_task_message
    (    task_id: pmt$task_id;
         working_storage_area: ^CELL;
         working_storage_length: nft$intertask_transfer_size;
         wait_time: nft$intertask_wait_time;
     VAR transfer_count: nft$intertask_transfer_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nfe$common_task_communication
*copyc pmt$task_id
*copyc nft$intertask_transfer_size
*copyc nft$intertask_wait_time
*copyc ost$status
?? POP ??
*DECK DECK=NFP$GET_BTFS_DI_ADDRESS EXPAND=FALSE

  PROCEDURE [XREF] nfp$get_btfs_di_address
    (    title: nft$btfs_di_title;
         client: nat$application_name;
         station: ost$name;
         device: ost$name;
         wait_list: ^ost$i_wait_list;
         wait_activity_list: ^nft$wait_activity_list;
     VAR network_address: nat$network_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$network_address
*copyc nft$btfs_di_title
*copyc nft$wait_activity_list
*copyc ost$i_wait
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=NFP$GET_CONNECTION_DATA EXPAND=FALSE

  PROCEDURE [XREF] nfp$get_connection_data
    (    message_area: ^nft$message_sequence;
         connection_identifier: amt$file_identifier;
     VAR peer_operation: nat$se_peer_operation;
     VAR activity_status: ost$activity_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc nat$data_fragments
*copyc nat$se_peer_operation
*copyc nft$message_sequence
*copyc ost$activity_status
?? POP ??
*DECK DECK=NFP$GET_NEW_APPLICATION_NAME EXPAND=FALSE

  PROCEDURE [XREF] nfp$get_new_application_name
    (    application_qualifier: nft$sf_applications;
         store_forward_file_info: nft$store_forward_file_info;
         destination_name: nft$parameter_24_definition;
     VAR application_name_changed: boolean;
     VAR new_application_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$parameter_24_definition
*copyc nft$sf_applications
*copyc nft$store_forward_file_info
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=NFP$GET_NEW_DESTINATION_NAME EXPAND=FALSE

  PROCEDURE [XREF] nfp$get_new_destination_name
    (    application_qualifier: nft$sf_applications;
         store_forward_file_info: nft$store_forward_file_info;
         current_target_name: nft$parameter_24_definition;
     VAR target_name_changed: boolean;
     VAR new_target_name: nft$parameter_24_definition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$parameter_24_definition
*copyc nft$sf_applications
*copyc nft$store_forward_file_info
*copyc ost$status
?? POP ??
*DECK DECK=NFP$GET_NEW_SOURCE_NAME EXPAND=FALSE

  PROCEDURE [XREF] nfp$get_new_source_name
    (    application_qualifier: nft$sf_applications;
         store_forward_file_info: nft$store_forward_file_info;
         current_source_name: nft$parameter_24_definition;
         destination_name: nft$parameter_24_definition;
     VAR source_name_changed: boolean;
     VAR new_source_name: nft$parameter_24_definition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$parameter_24_definition
*copyc nft$sf_applications
*copyc nft$store_forward_file_info
*copyc ost$status
?? POP ??
*DECK DECK=NFP$GET_PARAMETER_VALUE_LENGTH EXPAND=FALSE

  PROCEDURE [XREF] nfp$get_parameter_value_length
    (VAR message {input} : ^nft$message_sequence;
     VAR message_length {input, output} : integer;
     VAR parameter_value_length: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$message_sequence
*copyc nft$parameter_value_length
*copyc ost$status
?? POP ??

*DECK DECK=NFP$GET_REMOTE_VALIDATION EXPAND=TRUE

  PROCEDURE [XREF] nfp$get_remote_validation (location: ost$name;
    VAR validation: ^ARRAY [1 .. *] OF STRING (osc$max_string_size);
    VAR status: ost$status);

?? PUSH (LISTEXT :=ON) ??
*copyc nft$remote_validation
?? POP ??
*DECK DECK=NFP$GET_SERVER_ASYNCH_EVENT EXPAND=FALSE
  PROCEDURE [XREF] nfp$get_server_asynch_event
    (    application: nft$application_values;
     VAR path: nft$network_connection;
     VAR lcn_boot: boolean;
     VAR nam_boot: boolean;
     VAR task_queue: nft$task_queue;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$application_values
*copyc nft$network_connection
*copyc nft$task_queue
*copyc ost$status
?? POP ??
*DECK DECK=NFP$INITIALIZE_CONTROL_BLOCK EXPAND=FALSE
  PROCEDURE [XREF] nfp$initialize_control_block
    (    application: nft$application_values;
         data_declaration: nft$parameter_31_type;
         requested_facilities: nft$parameter_03_value_set;
         required_facilities: nft$parameter_03_value_set;
         allowed_facilities: nft$parameter_03_value_set;
         initial_protocol: nft$parameter_00_values;
         mode_of_access: nft$mode_of_access;
         parameter_rules: ^nft$parameter_rules_array;
     VAR control_block: nft$control_block);

{}
?? PUSH (LISTEXT := ON) ??
*copyc nft$application_values
*copyc nft$transfer_declarations
*copyc nft$parameter_31_type
*copyc nft$parameter_03_value_set
*copyc nft$parameter_00_values
*copyc nft$mode_of_access
*copyc nft$parameter_rules_array
*copyc nft$control_block
?? POP ??
*DECK DECK=NFP$MODIFY_PARAM_VALUE_LENGTH EXPAND=FALSE
PROCEDURE [INLINE] nfp$modify_param_value_length
  (VAR parameter_value_length: integer);

  IF parameter_value_length = 0 THEN
    parameter_value_length := 1;
  IFEND;

PROCEND nfp$modify_param_value_length;
*DECK DECK=NFP$NAM_REQUEST_CONNECT EXPAND=FALSE
{ nfp$nam_request_connect }

  PROCEDURE [XREF] nfp$nam_request_connect
    (    network_file_name: fst$file_reference;
         initiator: nft$application_values;
         server: nft$application_values;
         network_address: nat$network_address;
         application_version: 0 .. 255;
         station_name: ost$name;
         device_name: ost$name;
     VAR path: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc fst$file_reference
*copyc nat$network_address
*copyc nft$application_values
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=NFP$NETWORK_ADDRESSES_MATCH EXPAND=FALSE

  FUNCTION [XREF] nfp$network_addresses_match
    (    first: nat$network_address;
         second: nat$network_address): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_address
?? POP ??
*DECK DECK=NFP$NTF_RECEIVE_FILE EXPAND=FALSE
  PROCEDURE [XREF] nfp$ntf_receive_file
    (VAR control_block: nft$control_block;
     VAR p17_param: nft$parameter_17_definition;
     VAR p32_params: nft$p32_b101_ntf_params;
     VAR p58_params: nft$p58_b101_ntf_params;
     VAR stopr_params: nft$parameter_set;
     VAR queue_status: ost$status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$control_block
*copyc nft$parameter_17_definition
*copyc nfc$parameter_32_definitions
*copyc nfc$parameter_58_definitions
*copyc nft$parameter_32_b101_text
*copyc nft$parameter_58_b101_text
*copyc nft$parameter_set
*copyc ost$status
?? POP ??


*DECK DECK=NFP$OPEN_STORE_FORWARD_FILE EXPAND=FALSE

  PROCEDURE [XREF] nfp$open_store_forward_file
    (    attach_file: boolean;
     VAR store_forward_file_info: nft$store_forward_file_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$store_forward_file_info
*copyc ost$status
?? POP ??
*DECK DECK=NFP$PERFORM_IMPLICIT_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] nfp$perform_implicit_access
    (    location: ost$name;
         local_file_path: fst$file_reference;
         remote_file_path: fst$file_reference;
         access_mode: nft$mode_of_access;
         command_name: ost$name_reference;
         pdt: ^clt$unbundled_pdt;
         pvt: ^clt$parameter_value_table;
         parameter_substitutions: ^clt$parameter_substitutions;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_substitutions
*copyc clt$parameter_value_table
*copyc clt$unbundled_pdt
*copyc clt$work_area
*copyc fst$file_reference
*copyc nft$mode_of_access
*copyc ost$name_reference
*copyc ost$status
?? POP ??
*DECK DECK=NFP$PTF_FORMAT_MESSAGE_TO_OUT EXPAND=FALSE
  PROCEDURE [XREF] nfp$ptf_format_message_to_out
    (    status: ost$status);
*DECK DECK=NFP$PUT_ASYNC_TASK_MESSAGE EXPAND=FALSE
  PROCEDURE [XREF] nfp$put_async_task_message
    (    task_id: pmt$task_id;
         working_storage_area: ^CELL;
         working_storage_length: nft$intertask_transfer_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nfe$common_task_communication
*copyc pmt$task_id
*copyc nft$intertask_transfer_size
*copyc nft$intertask_wait_time
*copyc ost$status
?? POP ??
*DECK DECK=NFP$PUT_PARAMETER_VALUE_LENGTH EXPAND=FALSE

  PROCEDURE [XREF] nfp$put_parameter_value_length
    (    parameter_value: integer;
     VAR message {input, output} : ^nft$message_sequence;
     VAR parameter_length_size: nft$message_length;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$message_sequence
*copyc nft$parameter_value_length
*copyc ost$status
?? POP ??
*DECK DECK=NFP$RECEIVE_COMMAND EXPAND=FALSE
  PROCEDURE [XREF] nfp$receive_command
    (    legal_commands: nft$command_set;
         required_params: nft$required_param_on_command;
     VAR transfer_control: nft$control_block;
     VAR received_parameters: nft$parameter_set;
     VAR ignored_parameters: nft$parameter_set;
     VAR modified_parameters: nft$parameter_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$command_set
*copyc nft$required_param_on_command
*copyc nft$parameter_set
*copyc nft$control_block
*copyc ost$status
?? POP ??
*DECK DECK=NFP$RECEIVE_FILE EXPAND=FALSE

  PROCEDURE [XREF] nfp$receive_file (
        connection_fid: amt$file_identifier;
        file_name: amt$local_file_name;
        facilities: nft$facility_group;
        transfer_mode: nft$transfer_modes;
        block_size: nft$block_size;
        min_timeout: nft$timeout;
        protocol_version: nft$parameter_00_values;
        network_type: nft$network_type;
        validation_ring: ost$ring;
        activate_protocol_trace: boolean;
    VAR file_size: amt$file_length;
    VAR protocol_state_consistent: boolean;
    VAR transfer_status: ost$status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$file_length
*copyc amt$local_file_name
*copyc nft$network_type
*copyc nft$parameter_00_values
*copyc nft$transfer_declarations
*copyc nft$transfer_modes
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=NFP$RECEIVE_PARAMETER_00 EXPAND=FALSE
  PROCEDURE [XREF] nfp$receive_parameter_00
    (    received_command: nft$protocol_commands;
         received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
         current_value: nft$parameter_00_values;
     VAR new_value: nft$parameter_00_values;
     VAR negotiate_down: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nfc$parameter_definitions
*copyc nft$protocol_commands
*copyc nft$parameter_qualifiers
*copyc nft$parameter_00_values
*copyc nft$parameter_set
*copyc ost$status
?? POP ??
*DECK DECK=NFP$RECEIVE_PARAMETER_20 EXPAND=FALSE
  PROCEDURE [XREF] nfp$receive_parameter_20
    (    received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
         path: nft$network_connection;
     VAR timeout_value: nft$parameter_20_range;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nfc$parameter_definitions
*copyc nft$parameter_qualifiers
*copyc nft$network_connection
*copyc nft$parameter_20_range
*copyc ost$status
?? POP ??
*DECK DECK=NFP$RECEIVE_PARAMETER_22 EXPAND=FALSE
  PROCEDURE [XREF] nfp$receive_parameter_22
    (    received_value: string ( * <= nfc$max_param_size);
         qualifier: nft$parameter_qualifiers;
     VAR host_type: nft$parameter_22_values;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nfc$parameter_definitions
*copyc nft$parameter_qualifiers
*copyc nft$parameter_22_values
*copyc ost$status
?? POP ??
*DECK DECK=NFP$RECEIVE_QUEUE_FILE EXPAND=FALSE

  PROCEDURE [XREF] nfp$receive_queue_file
    (    connection_identifier: amt$file_identifier;
         file_name: amt$local_file_name;
         facilities: nft$facility_group;
         transfer_mode:  nft$transfer_modes;
         block_size: nft$block_size;
         min_timeout: nft$timeout;
         protocol_version: nft$parameter_00_values;
         network_type: nft$network_type;
         activate_protocol_trace: boolean;
     VAR file_size: amt$file_length;
     VAR protocol_state_consistent: boolean;
     VAR transfer_status: ost$status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$file_length
*copyc amt$local_file_name
*copyc nft$network_type
*copyc nft$parameter_00_values
*copyc nft$transfer_declarations
*copyc nft$transfer_modes
*copyc ost$status
?? POP ??

*DECK DECK=NFP$REMOTE_VALIDATION_DISPLAY EXPAND=TRUE

  PROCEDURE [XREF] nfp$remote_validation_display (
        locations: ^ARRAY [1 .. *] OF ost$name;
        output_file: fst$file_reference;
    VAR status: ost$status);

?? PUSH (LISTEXT :=ON) ??
*copyc fst$file_reference
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=NFP$REMOVE_FROM_WAIT_LISTS EXPAND=FALSE
  PROCEDURE [XREF] nfp$remove_from_wait_lists
    (    index: integer;
     VAR wait_list {input, output} : ^ost$i_wait_list;
     VAR wait_activity_list {input, output}: ^nft$wait_activity_list;
     VAR wait_list_sequence {input, output} : ^SEQ(*);
     VAR wait_activity_list_sequence {input, output} : ^SEQ(*));

?? PUSH (LISTEXT := ON) ??
*copyc nft$wait_activity_list
*copyc ost$i_wait
?? POP ??
*DECK DECK=NFP$REQUEST_ASYNCHRONOUS_TASK EXPAND=FALSE
  PROCEDURE [XREF] nfp$request_asynchronous_task
    (    transfer_symbol: pmt$program_name;
         debug_mode: pmt$debug_mode;
     VAR connected_task: pmt$task_id;
     VAR queue_id: pmt$queue_connection;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nfe$common_task_communication
*copyc pmd$local_queues
*copyc pmt$debug_mode
*copyc pmt$program_name
*copyc pmt$task_id
*copyc ost$status
?? POP ??
*DECK DECK=NFP$SEND_ADD_FILE_AVAILABLE EXPAND=FALSE

  PROCEDURE [XREF] nfp$send_add_file_available
    (    descriptor: nft$application_file_descriptor;
         file_state: nft$file_transfer_state;
         connection_identifier: amt$file_identifier;
     VAR message: ^nft$message_sequence;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc nft$application_file_descriptor
*copyc nft$message_sequence
*copyc nft$file_transfer_state
*copyc ost$status
?? POP ??

*DECK DECK=NFP$SEND_BATCH_FILE EXPAND=FALSE

  PROCEDURE [XREF] nfp$send_batch_file (
        connection_fid: amt$file_identifier;
        connection_file_name: fst$file_reference;
        file_name: jmt$system_supplied_name;
        local_file_name: amt$local_file_name;
        facilities: nft$facility_group;
        transfer_mode: nft$transfer_modes;
        block_size: nft$block_size;
        min_timeout: nft$timeout;
        protocol_version: nft$parameter_00_values;
        destination_usage: jmt$destination_usage;
        queue_file_password: jmt$queue_file_password;
        disposition_code: nft$parameter_17_definition;
        activate_protocol_trace: boolean;
    VAR file_position: jmt$output_file_position;
    VAR protocol_state_consistent: boolean;
    VAR transfer_status: ost$status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc jmt$destination_usage
*copyc jmt$disposition_code
*copyc jmt$output_file_position
*copyc jmt$queue_file_password
*copyc jmt$system_supplied_name
*copyc nft$parameter_00_values
*copyc nft$parameter_17_definition
*copyc nft$transfer_declarations
*copyc nft$transfer_modes
*copyc ost$status
?? POP ??

*DECK DECK=NFP$SEND_BTF_VE_STATUS EXPAND=FALSE

  PROCEDURE [XREF] nfp$send_btf_ve_status
    (    connection_identifier: amt$file_identifier;
     VAR message: ^nft$message_sequence;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc nft$message_sequence
*copyc ost$status
?? POP ??
*DECK DECK=NFP$SEND_COMMAND EXPAND=FALSE
  PROCEDURE [XREF] nfp$send_command
    (    command: nft$protocol_commands;
         select_parameters: nft$parameter_set;
         ignore_parameters: nft$parameter_set;
         modify_parameters: nft$parameter_set;
     VAR transfer_control: nft$control_block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$protocol_commands
*copyc nft$parameter_set
*copyc nft$control_block
*copyc ost$status
?? POP ??
*DECK DECK=NFP$SEND_CONNECT_REQUEST EXPAND=FALSE
  PROCEDURE [XREF] nfp$send_connect_request
    (    location: ost$name;
         server: nft$application_values;
         initiator: nft$application_values;
     VAR path: nft$network_connection;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc nft$application_values
*copyc nft$network_connection
*copyc ost$status
?? POP ??
*DECK DECK=NFP$SEND_DELETE_FILE_AVAILABLE EXPAND=FALSE

  PROCEDURE [XREF] nfp$send_delete_file_available
    (    descriptor: nft$application_file_descriptor;
         file_held_by_filter: boolean;
         file_requeued: boolean;
         connection_identifier: amt$file_identifier;
     VAR message: ^nft$message_sequence;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc nft$application_file_descriptor
*copyc nft$message_sequence
*copyc ost$status
?? POP ??

*DECK DECK=NFP$SEND_FILE EXPAND=FALSE

  PROCEDURE [XREF] nfp$send_file (
        connection_fid: amt$file_identifier;
        file_name: amt$local_file_name;
        facilities: nft$facility_group;
        transfer_mode: nft$transfer_modes;
        block_size: nft$block_size;
        min_timeout: nft$timeout;
        protocol_version: nft$parameter_00_values;
        network_type: nft$network_type;
        validation_ring: ost$ring;
        activate_protocol_trace: boolean;
    VAR file_size: amt$file_length;
    VAR protocol_state_consistent: boolean;
    VAR transfer_status: ost$status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$file_length
*copyc amt$local_file_name
*copyc nft$network_type
*copyc nft$parameter_00_values
*copyc nft$transfer_declarations
*copyc nft$transfer_modes
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=NFP$SEND_FILE_ASSIGNMENT_RESP EXPAND=FALSE

  PROCEDURE [XREF] nfp$send_file_assignment_resp
    (    station_name: ost$name;
         device_name: ost$name;
         file_name: jmt$system_supplied_name;
         response_code: nft$file_assignment_response;
         connection_identifier: amt$file_identifier;
     VAR message: ^nft$message_sequence;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc jmt$system_supplied_name
*copyc nft$file_assignment_response
*copyc nft$message_sequence
*copyc ost$name
*copyc ost$status
?? POP ??

*DECK DECK=NFP$SEND_MESSAGE_ON_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nfp$send_message_on_connection
    (    message_area: ^nft$message_sequence;
         length: nft$message_length;
         connection_identifier: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc nat$data_fragments
*copyc nft$message_sequence
*copyc ost$activity_status
?? POP ??
*DECK DECK=NFP$SEND_MODIFY_FILE_AVAILABLE EXPAND=FALSE

  PROCEDURE [XREF] nfp$send_modify_file_available
    (    modified_descriptor: nft$application_file_descriptor;
         descriptor: nft$application_file_descriptor;
         connection_identifier: amt$file_identifier;
     VAR message: ^nft$message_sequence;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc nft$application_file_descriptor
*copyc nft$message_sequence
*copyc ost$status
?? POP ??
*DECK DECK=NFP$SEND_QUEUE_FILE EXPAND=FALSE

  PROCEDURE [XREF] nfp$send_queue_file
    (    connection_identifier: amt$file_identifier;
         queue_file_identifier: amt$file_identifier;
         file_name: jmt$system_supplied_name;
         facilities: nft$facility_group;
         transfer_mode: nft$transfer_modes;
         block_size: nft$block_size;
         min_timeout: nft$timeout;
         protocol_version: nft$parameter_00_values;
         network_type: nft$network_type;
         activate_protocol_trace: boolean;
     VAR protocol_state_consistent: boolean;
     VAR transfer_status: ost$status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc jmt$system_supplied_name
*copyc nft$network_type
*copyc nft$parameter_00_values
*copyc nft$transfer_declarations
*copyc nft$transfer_modes
*copyc ost$status
?? POP ??

*DECK DECK=NFP$SEND_TERQO_RESPONSE_MSG EXPAND=FALSE
  PROCEDURE [XREF] nfp$send_terqo_response_msg
    (    io_station_name: ost$name;
         file_name: ost$name;
         response: nft$terqo_file_status_codes;
         connection_id: amt$file_identifier;
     VAR message: ^nft$message_sequence;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc nft$message_sequence
*copyc nft$terqo_file_status_codes
*copyc ost$name
*copyc ost$status
?? POP ??

*DECK DECK=NFP$SET_ABNORMAL_IF_NORMAL EXPAND=FALSE
*copyc ost$status

  PROCEDURE [INLINE] nfp$set_abnormal_if_normal
    (    new_status: ost$status;
     VAR old_status: ost$status);

{}
    IF (old_status.normal) AND (NOT new_status.normal) THEN
      old_status := new_status;
    IFEND;
{}
  PROCEND nfp$set_abnormal_if_normal;
*DECK DECK=NFP$SET_REMOTE_VALIDATION EXPAND=TRUE

  PROCEDURE [XREF] nfp$set_remote_validation (location: ost$name;
        validation: ^ARRAY [1 .. *] OF STRING (osc$max_string_size);
    VAR status: ost$status);

?? PUSH (LISTEXT :=ON) ??
*copyc nft$remote_validation
?? POP ??
*DECK DECK=NFP$START_BTF_VE_TASK EXPAND=FALSE
  PROCEDURE [XREF] nfp$start_btf_ve_task
    (    btfs_di_network_address: nat$network_address;
         btfs_di_title: nft$btfs_di_title;
         station: ost$name;
         device: ost$name;
         device_environment_variable: ost$name;
         scfs_can_handle_filter_hold: boolean;
         file_descriptor: nft$application_file_descriptor;
         ntf_local_file_name: amt$local_file_name;
         debug_async_task: pmt$debug_mode;
     VAR wait_list {input, output} : ^ost$i_wait_list;
     VAR wait_activity_list {input, output}: ^nft$wait_activity_list;
     VAR wait_list_sequence {input, output} : ^SEQ(*);
     VAR wait_activity_list_sequence {input, output} : ^SEQ(*);
     VAR new_btf_task: ^nft$btf_task;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc nat$network_address
*copyc nft$application_file_descriptor
*copyc nft$btfs_di_title
*copyc nft$wait_activity_list
*copyc ost$i_wait
*copyc ost$status
*copyc pmt$debug_mode
?? POP ??
*DECK DECK=NFP$START_TIMER EXPAND=FALSE
  PROCEDURE [XREF] nfp$start_timer
    (    wait_time: nft$micro_second;
     VAR timer: nft$timer);

*copyc nfc$timer_values
*copyc nft$micro_second
*copyc nft$timer
*DECK DECK=NFP$STRING_LENGTH EXPAND=FALSE
*copyc ost$string

  FUNCTION nfp$string_length
    (    input_string: string ( * )): integer;

{}

    VAR
      string_length: ost$string_size;

{}
    string_length := STRLENGTH (input_string);
    WHILE (string_length > 0) AND (input_string (string_length) = ' ') DO
      string_length := string_length - 1;
    WHILEND;
    nfp$string_length := string_length;
{}
  FUNCEND nfp$string_length;
*DECK DECK=NFP$TERMINATE_PATH EXPAND=FALSE

  PROCEDURE [XREF] nfp$terminate_path
    (    application: nft$application_values;
         sign_off: boolean;
     VAR path: nft$network_connection;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$application_values
*copyc nft$network_connection
*copyc ost$status
?? POP ??
*DECK DECK=NFP$TIMER_EXPIRED EXPAND=FALSE
  FUNCTION [XREF] nfp$timer_expired
    (    timer: nft$timer;
         latest_time: nft$micro_second): boolean;

*copyc nft$micro_second
*copyc nft$timer
*DECK DECK=NFP$TRANSFER_FILE EXPAND=FALSE
  PROCEDURE [XREF] nfp$transfer_file
    (VAR control_block: nft$control_block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nft$control_block
*copyc ost$status
?? POP ??
*DECK DECK=NFP$VERIFY_FAMILY EXPAND=TRUE

  PROCEDURE [XREF] nfp$verify_family
    (    family_name: ost$family_name;
     VAR family_is_local: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$user_identification
?? POP ??

*DECK DECK=NFS$APPL_DEF_SEGMENT_VARIABLES EXPAND=FALSE

  SECTION
    nfs$appl_def_segment_variables: read;
*DECK DECK=NFS$PROTOCOL_ENGINE_STATIC EXPAND=FALSE
  SECTION
    nfs$protocol_engine_static: READ;

*DECK DECK=NFS$PTF_STATIC_DATA EXPAND=FALSE
  SECTION
    nfs$ptf_static_data: READ;

*DECK DECK=NFS$QTF_APPLICATION_DATA EXPAND=FALSE
  SECTION
    nfs$qtf_application_data: READ;

*DECK DECK=NFT$ACCEPT_MESSAGES EXPAND=FALSE
  TYPE
    nft$accept_messages = (nfc$do_accept_messages, nfc$dont_accept_messages);
*DECK DECK=NFT$ADD_BATCH_DEVICE_MESSAGE EXPAND=FALSE
  TYPE
    nft$add_bd_message_parameter = packed record
      length_indicated: boolean,
      param: nft$add_batch_device_parameters,
    recend,

    nft$add_batch_device_parameters = (nfc$null_parameter, nfc$io_station_name, nfc$device_name,
      nfc$device_status, nfc$file_transfer_status_param, nfc$device_alias_1, nfc$device_alias_2,
      nfc$device_alias_3, nfc$device_type, nfc$tip_type, nfc$terminal_model, nfc$file_acknowledgement,
      nfc$transmission_block_size, nfc$maximum_file_size, nfc$page_width, nfc$page_length,
      nfc$banner_page_count, nfc$banner_highlight_field, nfc$carriage_control_action, nfc$forms_code_1,
      nfc$forms_code_2, nfc$forms_code_3, nfc$forms_code_4, nfc$external_characteristics_1,
      nfc$external_characteristics_2, nfc$external_characteristics_3, nfc$external_characteristics_4,
      nfc$suppress_carriage_control, nfc$code_set, nfc$vertical_print_density,
      nfc$vfu_load_procedure, nfc$forms_size, nfc$undefined_fe_action,
      nfc$unsupported_fe_action, nfc$vfu_load_option, nfc$device_maximum_page_length,
      nfc$transparent_mode, nfc$ntf_skip_punch_count, nfc$ntf_logical_line_number, nfc$add_bd_reserved_39,
      nfc$add_bd_reserved_40, nfc$add_bd_reserved_41, nfc$add_bd_reserved_42, nfc$add_bd_reserved_43,
      nfc$add_bd_reserved_44, nfc$add_bd_reserved_45, nfc$add_bd_reserved_46, nfc$add_bd_reserved_47,
      nfc$add_bd_reserved_48, nfc$add_bd_reserved_49, nfc$add_bd_reserved_50, nfc$add_bd_reserved_51,
      nfc$add_bd_reserved_52, nfc$add_bd_reserved_53, nfc$add_bd_reserved_54, nfc$add_bd_reserved_55,
      nfc$add_bd_reserved_56, nfc$add_bd_reserved_57, nfc$add_bd_reserved_58, nfc$add_bd_reserved_59,
      nfc$add_bd_reserved_60, nfc$add_bd_reserved_61, nfc$add_bd_reserved_62, nfc$add_bd_reserved_63,
      nfc$add_bd_reserved_64, nfc$add_bd_reserved_65);


*DECK DECK=NFT$ADD_BD_RESP_CODES EXPAND=FALSE
  TYPE
    nft$add_bd_responses = (nfc$message_accepted, nfc$no_io_station_found, nfc$duplicate_device_name,
      nfc$duplicate_aliases_specified);
*DECK DECK=NFT$ADD_DEL_DEVICE_RESPONSE EXPAND=FALSE
  TYPE
    nft$add_del_bd_resp_parameter = packed record
      length_indicated: boolean,
      param: nft$add_del_bd_resp_parameters,
    recend,

    nft$add_del_bd_resp_parameters = (nfc$null_parameter, nfc$io_station_name, nfc$device_name,
      nfc$response_code, nfc$add_del_bd_reserved_4, nfc$add_del_bd_reserved_5, nfc$add_del_bd_reserved_6,
      nfc$add_del_bd_reserved_7, nfc$add_del_bd_reserved_8, nfc$add_del_bd_reserved_9,
      nfc$add_del_bd_reserved_10, nfc$add_del_bd_reserved_11, nfc$add_del_bd_reserved_12,
      nfc$add_del_bd_reserved_13, nfc$add_del_bd_reserved_14, nfc$add_del_bd_reserved_15,
      nfc$add_del_bd_reserved_16, nfc$add_del_bd_reserved_17, nfc$add_del_bd_reserved_18,
      nfc$add_del_bd_reserved_19, nfc$add_del_bd_reserved_20, nfc$add_del_bd_reserved_21,
      nfc$add_del_bd_reserved_22, nfc$add_del_bd_reserved_23, nfc$add_del_bd_reserved_24,
      nfc$add_del_bd_reserved_25, nfc$add_del_bd_reserved_26, nfc$add_del_bd_reserved_27,
      nfc$add_del_bd_reserved_28, nfc$add_del_bd_reserved_29, nfc$add_del_bd_reserved_30,
      nfc$add_del_bd_reserved_31, nfc$add_del_bd_reserved_32, nfc$add_del_bd_reserved_33,
      nfc$add_del_bd_reserved_34, nfc$add_del_bd_reserved_35, nfc$add_del_bd_reserved_36,
      nfc$add_del_bd_reserved_37, nfc$add_del_bd_reserved_38, nfc$add_del_bd_reserved_39,
      nfc$add_del_bd_reserved_40, nfc$add_del_bd_reserved_41, nfc$add_del_bd_reserved_42,
      nfc$add_del_bd_reserved_43, nfc$add_del_bd_reserved_44, nfc$add_del_bd_reserved_45,
      nfc$add_del_bd_reserved_46, nfc$add_del_bd_reserved_47, nfc$add_del_bd_reserved_48,
      nfc$add_del_bd_reserved_49, nfc$add_del_bd_reserved_50, nfc$add_del_bd_reserved_51,
      nfc$add_del_bd_reserved_52, nfc$add_del_bd_reserved_53, nfc$add_del_bd_reserved_54,
      nfc$add_del_bd_reserved_55, nfc$add_del_bd_reserved_56, nfc$add_del_bd_reserved_57,
      nfc$add_del_bd_reserved_58, nfc$add_del_bd_reserved_59, nfc$add_del_bd_reserved_60,
      nfc$add_del_bd_reserved_61, nfc$add_del_bd_reserved_62, nfc$add_del_bd_reserved_63,
      nfc$add_del_bd_reserved_64, nfc$add_del_bd_reserved_65);

*DECK DECK=NFT$ADD_IOS_RESP_CODES EXPAND=FALSE
  TYPE
    nft$add_io_station_responses = (nfc$message_accepted, nfc$duplicate_with_check_unique,
      nfc$duplicate_defs_do_not_match, nfc$duplicate_alias_names, nfc$not_unique_network_title);
*DECK DECK=NFT$ADD_IO_STATION_MESSAGE EXPAND=FALSE
  TYPE
    nft$add_ios_message_parameter = packed record
      length_indicated: boolean,
      param: nft$add_io_station_msg_params,
    recend,

    nft$add_io_station_msg_params = (nfc$null_parameter, nfc$io_station_name, nfc$io_station_alias_1,
      nfc$io_station_alias_2, nfc$io_station_alias_3, nfc$required_operator_device, nfc$station_usage,
      nfc$file_acknowledgement, nfc$check_station_unique, nfc$auto_operator_control,
      nfc$default_job_destination, nfc$destination_unavail_action, nfc$pm_message_action,
      nfc$add_ios_reserved_13, nfc$add_ios_reserved_14, nfc$add_ios_reserved_15, nfc$add_ios_reserved_16,
      nfc$add_ios_reserved_17, nfc$add_ios_reserved_18, nfc$add_ios_reserved_19, nfc$add_ios_reserved_20,
      nfc$add_ios_reserved_21, nfc$add_ios_reserved_22, nfc$add_ios_reserved_23, nfc$add_ios_reserved_24,
      nfc$add_ios_reserved_25, nfc$add_ios_reserved_26, nfc$add_ios_reserved_27, nfc$add_ios_reserved_28,
      nfc$add_ios_reserved_29, nfc$add_ios_reserved_30, nfc$add_ios_reserved_31, nfc$add_ios_reserved_32,
      nfc$add_ios_reserved_33, nfc$add_ios_reserved_34, nfc$add_ios_reserved_35, nfc$add_ios_reserved_36,
      nfc$add_ios_reserved_37, nfc$add_ios_reserved_38, nfc$add_ios_reserved_39, nfc$add_ios_reserved_40,
      nfc$add_ios_reserved_41, nfc$add_ios_reserved_42, nfc$add_ios_reserved_43, nfc$add_ios_reserved_44,
      nfc$add_ios_reserved_45, nfc$add_ios_reserved_46, nfc$add_ios_reserved_47, nfc$add_ios_reserved_48,
      nfc$add_ios_reserved_49, nfc$add_ios_reserved_50, nfc$add_ios_reserved_51, nfc$add_ios_reserved_52,
      nfc$add_ios_reserved_53, nfc$add_ios_reserved_54, nfc$add_ios_reserved_55, nfc$add_ios_reserved_56,
      nfc$add_ios_reserved_57, nfc$add_ios_reserved_58, nfc$add_ios_reserved_59, nfc$add_ios_reserved_60,
      nfc$add_ios_reserved_61, nfc$add_ios_reserved_62, nfc$add_ios_reserved_63, nfc$add_ios_reserved_64,
      nfc$add_ios_reserved_65);


*DECK DECK=NFT$ADD_IO_STATION_RESPONSE EXPAND=FALSE
  TYPE
    nft$add_ios_resp_msg_parameter = packed record
      length_indicated: boolean,
      param: nft$add_io_station_resp_params,
    recend,

    nft$add_io_station_resp_params = (nfc$null_parameter, nfc$io_station_name, nfc$response_code,
      nfc$add_ios_resp_reserved_3, nfc$add_ios_resp_reserved_4, nfc$add_ios_resp_reserved_5,
      nfc$add_ios_resp_reserved_6, nfc$add_ios_resp_reserved_7, nfc$add_ios_resp_reserved_8,
      nfc$add_ios_resp_reserved_9, nfc$add_ios_resp_reserved_10, nfc$add_ios_resp_reserved_11,
      nfc$add_ios_resp_reserved_12, nfc$add_ios_resp_reserved_13, nfc$add_ios_resp_reserved_14,
      nfc$add_ios_resp_reserved_15, nfc$add_ios_resp_reserved_16, nfc$add_ios_resp_reserved_17,
      nfc$add_ios_resp_reserved_18, nfc$add_ios_resp_reserved_19, nfc$add_ios_resp_reserved_20,
      nfc$add_ios_resp_reserved_21, nfc$add_ios_resp_reserved_22, nfc$add_ios_resp_reserved_23,
      nfc$add_ios_resp_reserved_24, nfc$add_ios_resp_reserved_25, nfc$add_ios_resp_reserved_26,
      nfc$add_ios_resp_reserved_27, nfc$add_ios_resp_reserved_28, nfc$add_ios_resp_reserved_29,
      nfc$add_ios_resp_reserved_30, nfc$add_ios_resp_reserved_31, nfc$add_ios_resp_reserved_32,
      nfc$add_ios_resp_reserved_33, nfc$add_ios_resp_reserved_34, nfc$add_ios_resp_reserved_35,
      nfc$add_ios_resp_reserved_36, nfc$add_ios_resp_reserved_37, nfc$add_ios_resp_reserved_38,
      nfc$add_ios_resp_reserved_39, nfc$add_ios_resp_reserved_40, nfc$add_ios_resp_reserved_41,
      nfc$add_ios_resp_reserved_42, nfc$add_ios_resp_reserved_43, nfc$add_ios_resp_reserved_44,
      nfc$add_ios_resp_reserved_45, nfc$add_ios_resp_reserved_46, nfc$add_ios_resp_reserved_47,
      nfc$add_ios_resp_reserved_48, nfc$add_ios_resp_reserved_49, nfc$add_ios_resp_reserved_50,
      nfc$add_ios_resp_reserved_51, nfc$add_ios_resp_reserved_52, nfc$add_ios_resp_reserved_53,
      nfc$add_ios_resp_reserved_54, nfc$add_ios_resp_reserved_55, nfc$add_ios_resp_reserved_56,
      nfc$add_ios_resp_reserved_57, nfc$add_ios_resp_reserved_58, nfc$add_ios_resp_reserved_59,
      nfc$add_ios_resp_reserved_60, nfc$add_ios_resp_reserved_61, nfc$add_ios_resp_reserved_62,
      nfc$add_ios_resp_reserved_63, nfc$add_ios_resp_reserved_64, nfc$add_ios_resp_reserved_65);

*DECK DECK=NFT$ADD_USER_MSG EXPAND=FALSE
  TYPE
    nft$add_user_message_parameter = packed record
      length_indicated: boolean,
      param: nft$add_user_parameters,
    recend;

  TYPE
    nft$add_user_parameters = (nfc$null_parameter, nfc$station_or_control_facility, nfc$control_device_name,
      nfc$family_name, nfc$user_name, nfc$station_usage, nfc$accept_messages, nfc$add_user_reserved_7,
      nfc$add_user_reserved_8, nfc$add_user_reserved_9, nfc$add_user_reserved_10, nfc$add_user_reserved_11,
      nfc$add_user_reserved_12, nfc$add_user_reserved_13, nfc$add_user_reserved_14, nfc$add_user_reserved_15,
      nfc$add_user_reserved_16, nfc$add_user_reserved_17, nfc$add_user_reserved_18, nfc$add_user_reserved_19,
      nfc$add_user_reserved_20, nfc$add_user_reserved_21, nfc$add_user_reserved_22, nfc$add_user_reserved_23,
      nfc$add_user_reserved_24, nfc$add_user_reserved_25, nfc$add_user_reserved_26, nfc$add_user_reserved_27,
      nfc$add_user_reserved_28, nfc$add_user_reserved_29, nfc$add_user_reserved_30, nfc$add_user_reserved_31,
      nfc$add_user_reserved_32, nfc$add_user_reserved_33, nfc$add_user_reserved_34, nfc$add_user_reserved_35,
      nfc$add_user_reserved_36, nfc$add_user_reserved_37, nfc$add_user_reserved_38, nfc$add_user_reserved_39,
      nfc$add_user_reserved_40, nfc$add_user_reserved_41, nfc$add_user_reserved_42, nfc$add_user_reserved_43,
      nfc$add_user_reserved_44, nfc$add_user_reserved_45, nfc$add_user_reserved_46, nfc$add_user_reserved_47,
      nfc$add_user_reserved_48, nfc$add_user_reserved_49, nfc$add_user_reserved_50, nfc$add_user_reserved_51,
      nfc$add_user_reserved_52, nfc$add_user_reserved_53, nfc$add_user_reserved_54, nfc$add_user_reserved_55,
      nfc$add_user_reserved_56, nfc$add_user_reserved_57, nfc$add_user_reserved_58, nfc$add_user_reserved_59,
      nfc$add_user_reserved_60, nfc$add_user_reserved_61, nfc$add_user_reserved_62, nfc$add_user_reserved_63,
      nfc$add_user_reserved_64, nfc$add_user_reserved_65);

*DECK DECK=NFT$ADD_USER_RESPONSES EXPAND=FALSE
  TYPE
    nft$add_user_responses = (nfc$message_accepted, nfc$no_io_station_found, nfc$operator_already_assigned,
      nfc$operator_device_mismatch);

*DECK DECK=NFT$ADD_USER_RESP_MSG EXPAND=FALSE
  TYPE
    nft$add_user_resp_msg_parameter = packed record
      length_indicated: boolean,
      param: nft$add_user_resp_parameters,
    recend;

  TYPE
    nft$add_user_resp_parameters = (nfc$null_parameter, nfc$station_or_control_facility, nfc$response_code,
      nfc$add_user_resp_reserved_3, nfc$add_user_resp_reserved_4, nfc$add_user_resp_reserved_5,
      nfc$add_user_resp_reserved_6, nfc$add_user_resp_reserved_7, nfc$add_user_resp_reserved_8,
      nfc$add_user_resp_reserved_9, nfc$add_user_resp_reserved_10, nfc$add_user_resp_reserved_11,
      nfc$add_user_resp_reserved_12, nfc$add_user_resp_reserved_13, nfc$add_user_resp_reserved_14,
      nfc$add_user_resp_reserved_15, nfc$add_user_resp_reserved_16, nfc$add_user_resp_reserved_17,
      nfc$add_user_resp_reserved_18, nfc$add_user_resp_reserved_19, nfc$add_user_resp_reserved_20,
      nfc$add_user_resp_reserved_21, nfc$add_user_resp_reserved_22, nfc$add_user_resp_reserved_23,
      nfc$add_user_resp_reserved_24, nfc$add_user_resp_reserved_25, nfc$add_user_resp_reserved_26,
      nfc$add_user_resp_reserved_27, nfc$add_user_resp_reserved_28, nfc$add_user_resp_reserved_29,
      nfc$add_user_resp_reserved_30, nfc$add_user_resp_reserved_31, nfc$add_user_resp_reserved_32,
      nfc$add_user_resp_reserved_33, nfc$add_user_resp_reserved_34, nfc$add_user_resp_reserved_35,
      nfc$add_user_resp_reserved_36, nfc$add_user_resp_reserved_37, nfc$add_user_resp_reserved_38,
      nfc$add_user_resp_reserved_39, nfc$add_user_resp_reserved_40, nfc$add_user_resp_reserved_41,
      nfc$add_user_resp_reserved_42, nfc$add_user_resp_reserved_43, nfc$add_user_resp_reserved_44,
      nfc$add_user_resp_reserved_45, nfc$add_user_resp_reserved_46, nfc$add_user_resp_reserved_47,
      nfc$add_user_resp_reserved_48, nfc$add_user_resp_reserved_49, nfc$add_user_resp_reserved_50,
      nfc$add_user_resp_reserved_51, nfc$add_user_resp_reserved_52, nfc$add_user_resp_reserved_53,
      nfc$add_user_resp_reserved_54, nfc$add_user_resp_reserved_55, nfc$add_user_resp_reserved_56,
      nfc$add_user_resp_reserved_57, nfc$add_user_resp_reserved_58, nfc$add_user_resp_reserved_59,
      nfc$add_user_resp_reserved_60, nfc$add_user_resp_reserved_61, nfc$add_user_resp_reserved_62,
      nfc$add_user_resp_reserved_63, nfc$add_user_resp_reserved_64, nfc$add_user_resp_reserved_65);


*DECK DECK=NFT$ALL_OR_TOP_10_Q_ENTRIES EXPAND=FALSE
  TYPE
    nft$all_or_top_10_q_entries = (nfc$all_q_entries, nfc$top_10_q_entries);

*DECK DECK=NFT$APPLICATION_FILE_DESCRIPTOR EXPAND=FALSE

{   This definition is used by QTF, SCF, BTF, and NTF.

  TYPE
    nft$application_file_descriptor = record
      q_file_password: jmt$queue_file_password,
      case file_kind: nft$file_kind of
      = nfc$output_file =
        output_descriptor: jmt$output_descriptor,
      = nfc$input_file =
        input_descriptor: jmt$input_descriptor,
      = nfc$generic_file =
        generic_descriptor: nft$generic_descriptor,
      casend,
    recend;

*copyc jmt$input_descriptor
*copyc jmt$output_descriptor
*copyc jmt$queue_file_password
*copyc nft$file_kind
*copyc nft$generic_descriptor
*DECK DECK=NFT$APPLICATION_VALUES EXPAND=FALSE
?? NEWTITLE := 'nft$application_values' ??

{ nft$application_values }

  TYPE
    nft$application_values = (nfc$application_ptf, nfc$application_ptfs,
          nfc$application_qtf, nfc$application_qtfs, nfc$application_btf,
          nfc$application_btfs);

?? OLDTITLE ??
*DECK DECK=NFT$APPL_DEF_SEGMENT_VALUES EXPAND=FALSE

  TYPE
    nft$appl_def_segment_values = (nfc$appl_def_segment_for_btf,
          nfc$appl_def_segment_for_ntf, nfc$appl_def_segment_for_qtf,
          nfc$appl_def_segment_for_qtfs, nfc$appl_def_segment_for_scf,
          nfc$appl_def_segment_for_scfs);
*DECK DECK=NFT$AVAILABLE_FILE EXPAND=FALSE

  TYPE
    nft$available_file = record
      transfer_initiated: boolean,
      transfer_state: nft$file_transfer_state,
      ntf_local_file_name: amt$local_file_name,
      control_facility: ^nft$control_facility,
      btf_task: ^nft$btf_task,
      back_link: ^nft$available_file,
      link: ^nft$available_file,
      case file_kind: nft$file_kind of
      = nfc$output_file =
       output_descriptor: jmt$output_descriptor,
      = nfc$input_file =
       input_descriptor: jmt$input_descriptor,
      casend,
    recend;

*copyc amt$local_file_name
*copyc jmt$input_descriptor
*copyc jmt$output_descriptor
*copyc nft$btf_task
*copyc nft$control_facility
*copyc nft$file_kind
*copyc nft$file_transfer_state
*DECK DECK=NFT$BANNER_HIGHLIGHT_FIELD EXPAND=FALSE
  TYPE
    nft$banner_highlight_field = (nfc$comment_banner, nfc$routing_banner, nfc$site_banner, nfc$user_file_name,
      nfc$user_name);

*DECK DECK=NFT$BANNER_PAGE_COUNT EXPAND=FALSE
  CONST
    nfc$max_banner_pages = 3;

  TYPE
    nft$banner_page_count = 0 .. nfc$max_banner_pages;

*DECK DECK=NFT$BATCH_DEVICE_STATUS_MESSAGE EXPAND=FALSE
  TYPE
    nft$bd_status_message_parameter = packed record
      length_indicated: boolean,
      param: nft$batch_dev_status_parameters,
    recend,

    nft$batch_dev_status_parameters = (nfc$null_parameter, nfc$io_station_name, nfc$device_name,
      nfc$device_status, nfc$file_transfer_status_param, nfc$bd_status_reserved_5, nfc$bd_status_reserved_6,
      nfc$bd_status_reserved_7, nfc$bd_status_reserved_8, nfc$bd_status_reserved_9,
      nfc$bd_status_reserved_10, nfc$bd_status_reserved_11, nfc$bd_status_reserved_12,
      nfc$bd_status_reserved_13, nfc$bd_status_reserved_14, nfc$bd_status_reserved_15,
      nfc$bd_status_reserved_16, nfc$bd_status_reserved_17, nfc$bd_status_reserved_18,
      nfc$bd_status_reserved_19, nfc$bd_status_reserved_20, nfc$bd_status_reserved_21,
      nfc$bd_status_reserved_22, nfc$bd_status_reserved_23, nfc$bd_status_reserved_24,
      nfc$bd_status_reserved_25, nfc$bd_status_reserved_26, nfc$bd_status_reserved_27,
      nfc$bd_status_reserved_28, nfc$bd_status_reserved_29, nfc$bd_status_reserved_30,
      nfc$bd_status_reserved_31, nfc$bd_status_reserved_32, nfc$bd_status_reserved_33,
      nfc$bd_status_reserved_34, nfc$bd_status_reserved_35, nfc$bd_status_reserved_36,
      nfc$bd_status_reserved_37, nfc$bd_status_reserved_38, nfc$bd_status_reserved_39,
      nfc$bd_status_reserved_40, nfc$bd_status_reserved_41, nfc$bd_status_reserved_42,
      nfc$bd_status_reserved_43, nfc$bd_status_reserved_44, nfc$bd_status_reserved_45,
      nfc$bd_status_reserved_46, nfc$bd_status_reserved_47, nfc$bd_status_reserved_48,
      nfc$bd_status_reserved_49, nfc$bd_status_reserved_50, nfc$bd_status_reserved_51,
      nfc$bd_status_reserved_52, nfc$bd_status_reserved_53, nfc$bd_status_reserved_54,
      nfc$bd_status_reserved_55, nfc$bd_status_reserved_56, nfc$bd_status_reserved_57,
      nfc$bd_status_reserved_58, nfc$bd_status_reserved_59, nfc$bd_status_reserved_60,
      nfc$bd_status_reserved_61, nfc$bd_status_reserved_62, nfc$bd_status_reserved_63,
      nfc$bd_status_reserved_64, nfc$bd_status_reserved_65);
*DECK DECK=NFT$BATCH_FILE_TRANSPORT_INFO EXPAND=FALSE
  TYPE
    nft$batch_file_transport_info = record
      network_address: nft$network_address,
      descriptor: jmt$output_descriptor,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc nft$network_address
*copyc jmt$output_descriptor
?? POP ??
*DECK DECK=NFT$BATCH_INPUT_ACCOUNTING_DATA EXPAND=FALSE

  TYPE
    nft$batch_input_accounting_data = record
      connect_time: ost$non_negative_integers,
      number_of_cards: ost$non_negative_integers,
      di_system_name: ost$name,
      line_name: ost$name,
      line_subtype: ost$name,
      line_speed: 0 .. 0ffff(16),
      i_o_station_name: ost$name,
      device_name: ost$name,
    recend;

*copyc osd$integer_limits
*copyc ost$name
*DECK DECK=NFT$BTFS_DI_ADVANCED_FEATURES EXPAND=FALSE

  TYPE
    nft$btfs_di_advanced_features = 0 .. 1;

*DECK DECK=NFT$BTFS_DI_STATUS_MESSAGE EXPAND=FALSE
  TYPE
    nft$btfs_di_status_parameter = packed record
      length_indicated: boolean,
      param: nft$btfs_di_status_parameters,
    recend,

    nft$btfs_di_status_parameters = (nfc$null_parameter, nfc$btfs_di_network_address, nfc$btfs_status_code,
      nfc$btfs_di_title, nfc$btfs_di_advanced_features, nfc$btfs_di_status_reserved_5,
      nfc$btfs_di_status_reserved_6, nfc$btfs_di_status_reserved_7, nfc$btfs_di_status_reserved_8,
      nfc$btfs_di_status_reserved_9, nfc$btfs_di_status_reserved_10, nfc$btfs_di_status_reserved_11,
      nfc$btfs_di_status_reserved_12, nfc$btfs_di_status_reserved_13, nfc$btfs_di_status_reserved_14,
      nfc$btfs_di_status_reserved_15, nfc$btfs_di_status_reserved_16, nfc$btfs_di_status_reserved_17,
      nfc$btfs_di_status_reserved_18, nfc$btfs_di_status_reserved_19, nfc$btfs_di_status_reserved_20,
      nfc$btfs_di_status_reserved_21, nfc$btfs_di_status_reserved_22, nfc$btfs_di_status_reserved_23,
      nfc$btfs_di_status_reserved_24, nfc$btfs_di_status_reserved_25, nfc$btfs_di_status_reserved_26,
      nfc$btfs_di_status_reserved_27, nfc$btfs_di_status_reserved_28, nfc$btfs_di_status_reserved_29,
      nfc$btfs_di_status_reserved_30, nfc$btfs_di_status_reserved_31, nfc$btfs_di_status_reserved_32,
      nfc$btfs_di_status_reserved_33, nfc$btfs_di_status_reserved_34, nfc$btfs_di_status_reserved_35,
      nfc$btfs_di_status_reserved_36, nfc$btfs_di_status_reserved_37, nfc$btfs_di_status_reserved_38,
      nfc$btfs_di_status_reserved_39, nfc$btfs_di_status_reserved_40, nfc$btfs_di_status_reserved_41,
      nfc$btfs_di_status_reserved_42, nfc$btfs_di_status_reserved_43, nfc$btfs_di_status_reserved_44,
      nfc$btfs_di_status_reserved_45, nfc$btfs_di_status_reserved_46, nfc$btfs_di_status_reserved_47,
      nfc$btfs_di_status_reserved_48, nfc$btfs_di_status_reserved_49, nfc$btfs_di_status_reserved_50,
      nfc$btfs_di_status_reserved_51, nfc$btfs_di_status_reserved_52, nfc$btfs_di_status_reserved_53,
      nfc$btfs_di_status_reserved_54, nfc$btfs_di_status_reserved_55, nfc$btfs_di_status_reserved_56,
      nfc$btfs_di_status_reserved_57, nfc$btfs_di_status_reserved_58, nfc$btfs_di_status_reserved_59,
      nfc$btfs_di_status_reserved_60, nfc$btfs_di_status_reserved_61, nfc$btfs_di_status_reserved_62,
      nfc$btfs_di_status_reserved_63, nfc$btfs_di_status_reserved_64, nfc$btfs_di_status_reserved_65);


*DECK DECK=NFT$BTFS_DI_TITLE EXPAND=FALSE

  TYPE
    nft$btfs_di_title = record
      length: 0 .. nac$max_title_pattern_length,
      title: string (nac$max_title_pattern_length),
    recend;

*copyc nat$title_pattern
*DECK DECK=NFT$BTF_TASK EXPAND=FALSE
  TYPE
    nft$btf_task = record
      id: pmt$task_id,
      qid: pmt$queue_connection,
      network_addr: nat$network_address,
      btfs_di_title: nft$btfs_di_title,
      io_station: ost$name,
      device: ost$name,
      back_link: ^nft$btf_task,
      link: ^nft$btf_task,
    recend;

*copyc nat$network_address
*copyc nft$btfs_di_title
*copyc pmd$local_queues
*copyc pmt$task_id
*copyc ost$name
*DECK DECK=NFT$BTF_TASK_STATUS EXPAND=FALSE
  TYPE
    nft$btf_task_status = record
      system_file_name: jmt$system_supplied_name,
      copies_printed: nft$copies,
      transfer_status: nft$btf_transfer_status,
      status: ost$status,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc nft$copies
*copyc nft$btf_transfer_status
*copyc ost$status
?? POP ??
*DECK DECK=NFT$BTF_TRANSFER_STATUS EXPAND=FALSE
  TYPE
    nft$btf_transfer_status = (nfc$transfer_complete_drop_file, nfc$transfer_failed_re_q_file,
      nfc$operator_hold_file, nfc$filter_hold_file);

*DECK DECK=NFT$BTF_VE_STATUS_MESSAGE EXPAND=FALSE

  TYPE
    nft$btf_ve_status_parameter = packed record
      length_indicated: boolean,
      param: nft$btf_ve_status_parameters,
    recend,

    nft$btf_ve_status_parameters = (nfc$null_parameter, nfc$btf_ve_protocol_stacks,
          nfc$btf_ve_status_reserved_2, nfc$btf_ve_status_reserved_3, nfc$btf_ve_status_reserved_4,
          nfc$btf_ve_status_reserved_5, nfc$btf_ve_status_reserved_6, nfc$btf_ve_status_reserved_7,
          nfc$btf_ve_status_reserved_8, nfc$btf_ve_status_reserved_9, nfc$btf_ve_status_reserved_10,
          nfc$btf_ve_status_reserved_11, nfc$btf_ve_status_reserved_12, nfc$btf_ve_status_reserved_13,
          nfc$btf_ve_status_reserved_14, nfc$btf_ve_status_reserved_15, nfc$btf_ve_status_reserved_16,
          nfc$btf_ve_status_reserved_17, nfc$btf_ve_status_reserved_18, nfc$btf_ve_status_reserved_19,
          nfc$btf_ve_status_reserved_20, nfc$btf_ve_status_reserved_21, nfc$btf_ve_status_reserved_22,
          nfc$btf_ve_status_reserved_23, nfc$btf_ve_status_reserved_24, nfc$btf_ve_status_reserved_25,
          nfc$btf_ve_status_reserved_26, nfc$btf_ve_status_reserved_27, nfc$btf_ve_status_reserved_28,
          nfc$btf_ve_status_reserved_29, nfc$btf_ve_status_reserved_30, nfc$btf_ve_status_reserved_31,
          nfc$btf_ve_status_reserved_32, nfc$btf_ve_status_reserved_33, nfc$btf_ve_status_reserved_34,
          nfc$btf_ve_status_reserved_35, nfc$btf_ve_status_reserved_36, nfc$btf_ve_status_reserved_37,
          nfc$btf_ve_status_reserved_38, nfc$btf_ve_status_reserved_39, nfc$btf_ve_status_reserved_40,
          nfc$btf_ve_status_reserved_41, nfc$btf_ve_status_reserved_42, nfc$btf_ve_status_reserved_43,
          nfc$btf_ve_status_reserved_44, nfc$btf_ve_status_reserved_45, nfc$btf_ve_status_reserved_46,
          nfc$btf_ve_status_reserved_47, nfc$btf_ve_status_reserved_48, nfc$btf_ve_status_reserved_49,
          nfc$btf_ve_status_reserved_50, nfc$btf_ve_status_reserved_51, nfc$btf_ve_status_reserved_52,
          nfc$btf_ve_status_reserved_53, nfc$btf_ve_status_reserved_54, nfc$btf_ve_status_reserved_55,
          nfc$btf_ve_status_reserved_56, nfc$btf_ve_status_reserved_57, nfc$btf_ve_status_reserved_58,
          nfc$btf_ve_status_reserved_59, nfc$btf_ve_status_reserved_60, nfc$btf_ve_status_reserved_61,
          nfc$btf_ve_status_reserved_62, nfc$btf_ve_status_reserved_63, nfc$btf_ve_status_reserved_64,
          nfc$btf_ve_status_reserved_65);
*DECK DECK=NFT$BUFFER_CONTROL_BLOCK EXPAND=FALSE
?? NEWTITLE := 'nft$buffer_control_block' ??

{ nft$buffer_control_block }

  TYPE
    nft$buffer_control_block = record
      buffer_complete: boolean,
      command: nft$protocol_commands,
      number_parameters: nft$number_pdu_param_range,
      buffer_size: nft$parameter_12_range,
      space_left: nft$parameter_12_range,
      next_position: 1 .. nfc$command_buffer_size,
      next_buffer: ^nft$buffer_control_block,
      buffer: string (nfc$command_buffer_size),
    recend;

*copyc nfc$command_definitions
*copyc nft$protocol_commands
*copyc nft$number_pdu_param_range
*copyc nft$parameter_12_range
?? OLDTITLE ??
*DECK DECK=NFT$BYTE_ARRAY EXPAND=FALSE

  TYPE
    nft$byte_array = array [1 .. * ] of 0 .. 0ff(16);

*DECK DECK=NFT$CARRIAGE_CONTROL_ACTION EXPAND=FALSE
  TYPE
    nft$carriage_control_action = (nfc$pre_print, nfc$post_print, nfc$pre_and_post_print);

*DECK DECK=NFT$CDT_MANAGE_SFN_DIRECTIVES EXPAND=FALSE
{ table mansfn_directive_list type=command    ..
{   section_name=oss$job_paged_literal scope=local
{ command name=(define_application_name_switch, defans)    ..
{   processor=cmd_define_application_switch    call_method=local      ..
{   availability=advertised
{ command name=(define_destination_group, defdg)    ..
{   processor=cmd_define_destination_group     call_method=local      ..
{   availability=advertised
{ command name=(define_destination_name_switch, defdns)    ..
{   processor=cmd_define_dest_name_switch    call_method=local      ..
{   availability=advertised
{ command name=(define_source_name_switch, defsns)    ..
{   processor=cmd_define_source_name_switch    call_method=local      ..
{   availability=advertised
{ command name=(quit, qui)   processor=cmd_quit_sf_directive    ..
{   call_method=local    availability=advertised
{ tablend

?? PUSH (LISTEXT := ON) ??
VAR
  mansfn_directive_list: [STATIC, READ, oss$job_paged_literal]
      ^clt$command_table := ^mansfn_directive_list_entries,

  mansfn_directive_list_entries: [STATIC, READ, oss$job_paged_literal]
      array [1 .. 10] of  clt$command_table_entry := [
  {} ['DEFANS                         ', clc$abbreviation_entry,
        clc$advertised_entry, 1, clc$automatically_log, clc$linked_call,
        ^cmd_define_application_switch],
  {} ['DEFDG                          ', clc$abbreviation_entry,
        clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
        ^cmd_define_destination_group],
  {} ['DEFDNS                         ', clc$abbreviation_entry,
        clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
        ^cmd_define_dest_name_switch],
  {} ['DEFINE_APPLICATION_NAME_SWITCH ', clc$nominal_entry,
        clc$advertised_entry, 1, clc$automatically_log, clc$linked_call,
        ^cmd_define_application_switch],
  {} ['DEFINE_DESTINATION_GROUP       ', clc$nominal_entry,
        clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
        ^cmd_define_destination_group],
  {} ['DEFINE_DESTINATION_NAME_SWITCH ', clc$nominal_entry,
        clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
        ^cmd_define_dest_name_switch],
  {} ['DEFINE_SOURCE_NAME_SWITCH      ', clc$nominal_entry,
        clc$advertised_entry, 4, clc$automatically_log, clc$linked_call,
        ^cmd_define_source_name_switch],
  {} ['DEFSNS                         ', clc$abbreviation_entry,
        clc$advertised_entry, 4, clc$automatically_log, clc$linked_call,
        ^cmd_define_source_name_switch],
  {} ['QUI                            ', clc$abbreviation_entry,
        clc$advertised_entry, 5, clc$automatically_log, clc$linked_call,
        ^cmd_quit_sf_directive],
  {} ['QUIT                           ', clc$nominal_entry,
        clc$advertised_entry, 5, clc$automatically_log, clc$linked_call,
        ^cmd_quit_sf_directive]];

?? POP ??

*DECK DECK=NFT$CDT_MANAGE_SF_NETWORK EXPAND=FALSE

{ table mansfn_command_list type=command ..
{   section_name=oss$job_paged_literal scope=local
{ command name=(display_store_forward_network, dissfn) ..
{   processor=cmd_display_sf_network ..
{   call_method=local   ..
{   availability=advertised
{ command name=(generate_store_forward_network, gensfn) ..
{   processor=cmd_generate_sf_network ..
{   call_method=local   ..
{   availability=advertised
{ command name=(install_store_forward_network, inssfn) ..
{   processor=cmd_install_sf_network ..
{   call_method=local   ..
{   availability=advertised
{ command name=(verify_store_forward_network, versfn) ..
{   processor=cmd_verify_sf_network ..
{   call_method=local   ..
{   availability=advertised
{ command name=(quit, qui) ..
{   processor=cmd_quit_sf_network ..
{   call_method=local  ..
{   availability=advertised
{ tablend

?? PUSH (LISTEXT := ON) ??
VAR
  mansfn_command_list: [STATIC, READ, oss$job_paged_literal]
      ^clt$command_table := ^mansfn_command_list_entries,

  mansfn_command_list_entries: [STATIC, READ, oss$job_paged_literal]
      array [1 .. 10] of  clt$command_table_entry := [
  {} ['DISPLAY_STORE_FORWARD_NETWORK  ', clc$nominal_entry,
        clc$advertised_entry, 1, clc$automatically_log, clc$linked_call,
        ^cmd_display_sf_network],
  {} ['DISSFN                         ', clc$abbreviation_entry,
        clc$advertised_entry, 1, clc$automatically_log, clc$linked_call,
        ^cmd_display_sf_network],
  {} ['GENERATE_STORE_FORWARD_NETWORK ', clc$nominal_entry,
        clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
        ^cmd_generate_sf_network],
  {} ['GENSFN                         ', clc$abbreviation_entry,
        clc$advertised_entry, 2, clc$automatically_log, clc$linked_call,
        ^cmd_generate_sf_network],
  {} ['INSSFN                         ', clc$abbreviation_entry,
        clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
        ^cmd_install_sf_network],
  {} ['INSTALL_STORE_FORWARD_NETWORK  ', clc$nominal_entry,
        clc$advertised_entry, 3, clc$automatically_log, clc$linked_call,
        ^cmd_install_sf_network],
  {} ['QUI                            ', clc$abbreviation_entry,
        clc$advertised_entry, 5, clc$automatically_log, clc$linked_call,
        ^cmd_quit_sf_network],
  {} ['QUIT                           ', clc$nominal_entry,
        clc$advertised_entry, 5, clc$automatically_log, clc$linked_call,
        ^cmd_quit_sf_network],
  {} ['VERIFY_STORE_FORWARD_NETWORK   ', clc$nominal_entry,
        clc$advertised_entry, 4, clc$automatically_log, clc$linked_call,
        ^cmd_verify_sf_network],
  {} ['VERSFN                         ', clc$abbreviation_entry,
        clc$advertised_entry, 4, clc$automatically_log, clc$linked_call,
        ^cmd_verify_sf_network]];

?? POP ??
*DECK DECK=NFT$CHANGE_BD_ATTRIBUTES_MSG EXPAND=FALSE
  TYPE
    nft$change_bd_attr_parameter = packed record
      length_indicated: boolean,
      param: nft$change_bd_attrs_parameters,
    recend;

  TYPE
    nft$change_bd_attrs_parameters = (nfc$null_parameter, nfc$io_station_name, nfc$device_name,
      nfc$device_alias_1, nfc$device_alias_2, nfc$device_alias_3, nfc$file_acknowledge, nfc$terminal_model,
      nfc$transmission_block_size, nfc$maximum_file_size, nfc$page_width, nfc$page_length,
      nfc$banner_page_count, nfc$banner_highlight_field, nfc$carriage_control_action, nfc$forms_code_1,
      nfc$forms_code_2, nfc$forms_code_3, nfc$forms_code_4, nfc$external_characteristics_1,
      nfc$external_characteristics_2, nfc$external_characteristics_3, nfc$external_characteristics_4,
      nfc$code_set, nfc$vertical_print_density, nfc$vfu_load_procedure, nfc$forms_size,
      nfc$undefined_fe_action, nfc$unsupported_fe_action, nfc$ntf_skip_punch_count, nfc$chabda_reserved_30,
      nfc$chabda_reserved_31, nfc$chabda_reserved_32, nfc$chabda_reserved_33, nfc$chabda_reserved_34,
      nfc$chabda_reserved_35, nfc$chabda_reserved_36, nfc$chabda_reserved_37, nfc$chabda_reserved_38,
      nfc$chabda_reserved_39, nfc$chabda_reserved_40, nfc$chabda_reserved_41, nfc$chabda_reserved_42,
      nfc$chabda_reserved_43, nfc$chabda_reserved_44, nfc$chabda_reserved_45, nfc$chabda_reserved_46,
      nfc$chabda_reserved_47, nfc$chabda_reserved_48, nfc$chabda_reserved_49, nfc$chabda_reserved_50,
      nfc$chabda_reserved_51, nfc$chabda_reserved_52, nfc$chabda_reserved_53, nfc$chabda_reserved_54,
      nfc$chabda_reserved_55, nfc$chabda_reserved_56, nfc$chabda_reserved_57, nfc$chabda_reserved_58,
      nfc$chabda_reserved_59, nfc$chabda_reserved_60, nfc$chabda_reserved_61, nfc$chabda_reserved_62,
      nfc$chabda_reserved_63, nfc$chabda_reserved_64, nfc$chabda_reserved_65);

*DECK DECK=NFT$CHANGE_BD_ATTR_RESP_MSG EXPAND=FALSE
  TYPE
    nft$change_bd_attr_resp_param = packed record
      length_indicated: boolean,
      param: nft$change_bda_resp_parameters,
    recend;

  TYPE
    nft$change_bda_resp_parameters = (nfc$null_parameter, nfc$io_station_name, nfc$device_name,
      nfc$response_code, nfc$device_alias_1, nfc$device_alias_2, nfc$device_alias_3, nfc$file_acknowledgement,
      nfc$terminal_model, nfc$transmission_block_size, nfc$maximum_file_size, nfc$page_width,
      nfc$page_length, nfc$banner_page_count, nfc$banner_highlight_field, nfc$carriage_control_action,
      nfc$forms_code_1, nfc$forms_code_2, nfc$forms_code_3, nfc$forms_code_4, nfc$external_characteristics_1,
      nfc$external_characteristics_2, nfc$external_characteristics_3, nfc$external_characteristics_4,
      nfc$code_set, nfc$vertical_print_density, nfc$vfu_load_procedure, nfc$forms_size,
      nfc$undefined_fe_action, nfc$unsupported_fe_action, nfc$invalid_chg_request, nfc$ntf_skip_punch_count,
      nfc$cha_bda_reserved_32, nfc$cha_bda_reserved_33, nfc$cha_bda_reserved_34, nfc$cha_bda_reserved_35,
      nfc$cha_bda_reserved_36, nfc$cha_bda_reserved_37, nfc$cha_bda_reserved_38, nfc$cha_bda_reserved_39,
      nfc$cha_bda_reserved_40, nfc$cha_bda_reserved_41, nfc$cha_bda_reserved_42, nfc$cha_bda_reserved_43,
      nfc$cha_bda_reserved_44, nfc$cha_bda_reserved_45, nfc$cha_bda_reserved_46, nfc$cha_bda_reserved_47,
      nfc$cha_bda_reserved_48, nfc$cha_bda_reserved_49, nfc$cha_bda_reserved_50, nfc$cha_bda_reserved_51,
      nfc$cha_bda_reserved_52, nfc$cha_bda_reserved_53, nfc$cha_bda_reserved_54, nfc$cha_bda_reserved_55,
      nfc$cha_bda_reserved_56, nfc$cha_bda_reserved_57, nfc$cha_bda_reserved_58, nfc$cha_bda_reserved_59,
      nfc$cha_bda_reserved_60, nfc$cha_bda_reserved_61, nfc$cha_bda_reserved_62, nfc$cha_bda_reserved_63,
      nfc$cha_bda_reserved_64, nfc$cha_bda_reserved_65);

*DECK DECK=NFT$CODE_SET EXPAND=FALSE
  TYPE
    nft$code_set = (nfc$ascii, nfc$ascii_48, nfc$ascii_64, nfc$ascii_95,
          nfc$ascii_128, nfc$ebcdic, nfc$ascii_256, nfc$bcd, nfc$site_defined);
*DECK DECK=NFT$COMMAND_PDU_SIZE EXPAND=FALSE
?? NEWTITLE := 'nft$command_pdu_size' ??

{ nft$command_pdu_size }

  TYPE
    nft$command_pdu_size = 0 .. nfc$command_buffer_size;

*copyc nfc$command_definitions

?? OLDTITLE ??
*DECK DECK=NFT$COMMAND_SET EXPAND=FALSE
?? NEWTITLE := 'nft$command_set' ??

{ nft$command_set }

  TYPE
    nft$command_set = set of nft$protocol_commands;

*copyc nft$protocol_commands
?? OLDTITLE ??
*DECK DECK=NFT$COMMAND_VALUES EXPAND=FALSE
?? NEWTITLE := 'nft$command_values' ??

{ nft$command_values }

  TYPE
    nft$command_values = array [nft$protocol_commands] of
          string (nfc$pdu_command_len);

*copyc nfc$command_definitions
*copyc nft$protocol_commands
?? OLDTITLE ??
*DECK DECK=NFT$CONNECTION_ADDRESS EXPAND=FALSE
  TYPE
    nft$connection_address = record
      case kind: nat$network_address_kind of
      = nac$internet_address =
        internet_address: nat$internet_address,
      = nac$osi_transport_address =
        network_address_length: nat$osi_network_address_length,
        network_address: SEQ (REP nac$osi_max_network_address_len OF cell),
      casend,
    recend;

*copyc nat$network_address
*DECK DECK=NFT$CONTROL_BLOCK EXPAND=FALSE
?? NEWTITLE := 'nft$control_block' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_length
*copyc amt$local_file_name
*copyc jmt$destination_usage
*copyc jmt$implicit_routing_text
*copyc jmt$output_file_position
*copyc jmt$queue_file_password
*copyc jmt$system_supplied_name
*copyc jmt$system_routing_text
*copyc jmt$user_supplied_name
*copyc jmt$vertical_print_density
*copyc nat$network_address

*copyc nfc$command_definitions
*copyc nfc$parameter_definitions
*copyc nfc$parameter_01_definitions
*copyc nfc$parameter_06_definitions
*copyc nfc$parameter_12_definitions
*copyc nfc$parameter_16_definitions
*copyc nfc$parameter_24_definitions
*copyc nfc$parameter_25_definitions
*copyc nfc$parameter_27_definitions


*copyc nft$application_values
*copyc nft$buffer_control_block
*copyc nft$command_set
*copyc nft$directive_entry
*copyc nft$directive_entry_list_head
*copyc nft$last_command_received
*copyc nft$last_command_sent
*copyc nft$mode_of_access
*copyc nft$network_connection
*copyc nft$network_buffer_list
*copyc nft$network_ring_information
*copyc nft$network_type
*copyc nft$parameter_rules
*copyc nft$parameter_rules_array
*copyc nft$parameter_set
*copyc nft$parameter_00_values
*copyc nft$parameter_01_values
*copyc nft$parameter_03_value_set
*copyc nft$parameter_06_values
*copyc nft$parameter_11_value
*copyc nft$parameter_12_range
*copyc nft$parameter_13_definition
*copyc nft$parameter_16_definition
*copyc nft$parameter_17_definition
*copyc nft$parameter_18_definition
*copyc nft$parameter_19_definition
*copyc nft$parameter_20_range
*copyc nft$parameter_21_options
*copyc nft$parameter_22_values
*copyc nft$parameter_24_definition
*copyc nft$parameter_25_definition
*copyc nft$parameter_25_length
*copyc nft$parameter_26_definition
*copyc nft$parameter_27_definition
*copyc nft$parameter_27_length
*copyc nft$parameter_29_list_head
*copyc nft$parameter_31_type
*copyc nft$parameter_60_element
*copyc nft$protocol_parameters
*copyc nft$transfer_declarations
*copyc nft$user_message_list
*copyc osd$integer_limits
?? POP ??

{ nft$control_block }

  TYPE
    nft$control_block = record
      application: nft$application_values,
      application_server: nft$application_values,
      last_command_sent: nft$last_command_sent,
      last_command_received: nft$last_command_received,
      last_auto_modify_ignore: nft$parameter_set,
      data_xfer_complete: boolean,
      file_name: amt$local_file_name,
      protocol_in_use: nft$parameter_00_values, { P00 }
      maximum_file_size: nft$parameter_01_values, { P01 }

      required_facilities: nft$parameter_03_value_set, { P03 }
      allowed_facilities: nft$parameter_03_value_set,
      send_facilities: nft$parameter_03_value_set,
      received_facilities: nft$parameter_03_value_set,
      transfer_facilities: nft$parameter_03_value_set,

      send_directives: ^nft$directive_entry, { P05 }
      received_directives: nft$directive_entry_list_head,

      send_operator_messages: ^nft$directive_entry, { P07 }
      received_operator_messages: nft$directive_entry_list_head,

      send_user_messages: ^nft$directive_entry, { P08 }
      received_user_messages: nft$directive_entry_list_head,

      send_account_messages: ^nft$directive_entry, { P09 }
      received_account_messages: nft$directive_entry_list_head,

      send_errorlog_messages: ^nft$directive_entry, { P10 }
      received_errorlog_messages: nft$directive_entry_list_head,

      file_size: nft$parameter_06_values, { P06 }
      send_special_options: nft$parameter_11_value, { P11 }
      receive_special_options: nft$parameter_11_value, { P11 }
      remote_ring: nft$network_ring_information,       { P11 PTF }
      data_block_size: nft$parameter_12_range, { P12 }
      accounting_limit: nft$parameter_13_definition, { P13 }
      disposition_code: nft$parameter_17_definition, { P17 }
      acknowledgment_window: nft$parameter_18_definition, { P18}
      initial_restart_checkmark: nft$parameter_19_definition, { P19 }
      time_out: nft$parameter_20_range, { P20 }
      mode_of_access: nft$mode_of_access, { P21 }
      mode_of_access_option: nft$parameter_21_options, { P21 }
      local_host_type: nft$parameter_22_values,
      remote_host_type: nft$parameter_22_values, { P22 }
      requested_host_type: nft$parameter_22_values, { Remote expected }
      expected_host_type: nft$parameter_22_values, { Local expected

      source_lid: nft$parameter_24_definition,  { P24 }

      transfer_lid: nft$parameter_25_definition, { P25 }
      transfer_lid_length: nft$parameter_25_length,
      remote_lid: nft$parameter_25_definition,
      remote_lid_length: nft$parameter_25_length,

      transfer_pid: nft$parameter_27_definition, { P27 }
      transfer_pid_length: nft$parameter_27_length,
      remote_pid: nft$parameter_27_definition,
      remote_pid_length: nft$parameter_27_length,

      received_echo_text: nft$parameter_29_list_head,  { P29 }
      send_echo_text: nft$parameter_29_list_head,

      data_declaration: nft$parameter_31_type, { P31 }

      user_job_name: jmt$user_supplied_name,    { P26 }
      system_job_name: jmt$system_supplied_name,
      send_job_name: nft$parameter_26_definition,
      receive_job_name: nft$parameter_26_definition,
      send_file_name: nft$parameter_16_definition,     { P16 }
      receive_file_name: nft$parameter_16_definition,
      negotiate_protocol: boolean,
      queue_file_password: jmt$queue_file_password,
      destination_usage: jmt$destination_usage,
      parameter_rules: ^nft$parameter_rules_array,
      retry_count: integer,
      retry_limit: integer,
      retry_milliseconds: integer,
      protocol_trace: boolean,
      send_systems_routing_text: jmt$system_routing_text,
      receive_systems_routing_text: jmt$system_routing_text,
      send_implicit_routing_text: jmt$implicit_routing_text,
      receive_implicit_routing_text: jmt$implicit_routing_text,
      network_buffer_list: nft$network_buffer_list,
      path: nft$network_connection,
{}
{     Status areas  }
{}
      state_of_transfer: ost$status, { P04 Local and Remote }
      remote_status: ost$status, { P11 }
      local_status: ost$status, { My status }

      case application_type: nft$application_values of

      = nfc$application_ptf, nfc$application_ptfs =
        recovery_text: boolean,
        transfer_file_size: amt$file_length,
        transfer_directives_length: ost$non_negative_integers,
        ptf_scl_directive: ost$string,
      = nfc$application_qtf, nfc$application_qtfs =
        space_holder: ^CELL,
      = nfc$application_btf, nfc$application_btfs =
        user_file_name: ost$string, { P51 }
        banner_date_and_time: ost$string, { P52 }
        banner_routing_text: ost$string, { P53 }
        user_banner_message: ost$string, { P54 }
        installation_banner_message: ost$string, { P55 }
        reposition_output_file: ost$string, { P56 }
        current_file_position: ost$string, { P57 }
        default_output_file_destination: ost$string, { P58 }
        vertical_print_density: jmt$vertical_print_density, { P59 }
        vfu_load_procedure: nft$parameter_60_element, { P60 }
        file_position: jmt$output_file_position,
      casend,

    recend;

?? OLDTITLE ??
*DECK DECK=NFT$CONTROL_FACILITY EXPAND=FALSE
  TYPE
    nft$control_facility = record
      name: ost$name,
      connection_file_name: amt$local_file_name,
      connection_id: amt$file_identifier,
      service_addr: nat$network_address,
      wait_activity_index: integer,
    recend;

*copyc amt$local_file_name
*copyc amt$file_identifier
*copyc nat$network_address
*copyc ost$name
*DECK DECK=NFT$COPIES EXPAND=FALSE
  TYPE
    nft$copies = integer;

*DECK DECK=NFT$CRACK_PARAMETER_ACTION EXPAND=FALSE
?? NEWTITLE := 'nft$crack_parameter_action' ??

{ nft$crack_parameter_action }

  TYPE
    nft$crack_parameter_action = (nfc$process, nfc$do_not_process);

?? OLDTITLE ??
*DECK DECK=NFT$DELETE_BATCH_DEVICE_MESSAGE EXPAND=FALSE
  TYPE
    nft$del_bd_message_parameter = packed record
      length_indicated: boolean,
      param: nft$delete_batch_device_params,
    recend,

    nft$delete_batch_device_params = (nfc$null_parameter, nfc$io_station_name, nfc$device_name,
      nfc$delbd_reserved_3, nfc$delbd_reserved_4, nfc$delbd_reserved_5, nfc$delbd_reserved_6,
      nfc$delbd_reserved_7, nfc$delbd_reserved_8, nfc$delbd_reserved_9, nfc$delbd_reserved_10,
      nfc$delbd_reserved_11, nfc$delbd_reserved_12, nfc$delbd_reserved_13, nfc$delbd_reserved_14,
      nfc$delbd_reserved_15, nfc$delbd_reserved_16, nfc$delbd_reserved_17, nfc$delbd_reserved_18,
      nfc$delbd_reserved_19, nfc$delbd_reserved_20, nfc$delbd_reserved_21, nfc$delbd_reserved_22,
      nfc$delbd_reserved_23, nfc$delbd_reserved_24, nfc$delbd_reserved_25, nfc$delbd_reserved_26,
      nfc$delbd_reserved_27, nfc$delbd_reserved_28, nfc$delbd_reserved_29, nfc$delbd_reserved_30,
      nfc$delbd_reserved_31, nfc$delbd_reserved_32, nfc$delbd_reserved_33, nfc$delbd_reserved_34,
      nfc$delbd_reserved_35, nfc$delbd_reserved_36, nfc$delbd_reserved_37, nfc$delbd_reserved_38,
      nfc$delbd_reserved_39, nfc$delbd_reserved_40, nfc$delbd_reserved_41, nfc$delbd_reserved_42,
      nfc$delbd_reserved_43, nfc$delbd_reserved_44, nfc$delbd_reserved_45, nfc$delbd_reserved_46,
      nfc$delbd_reserved_47, nfc$delbd_reserved_48, nfc$delbd_reserved_49, nfc$delbd_reserved_50,
      nfc$delbd_reserved_51, nfc$delbd_reserved_52, nfc$delbd_reserved_53, nfc$delbd_reserved_54,
      nfc$delbd_reserved_55, nfc$delbd_reserved_56, nfc$delbd_reserved_57, nfc$delbd_reserved_58,
      nfc$delbd_reserved_59, nfc$delbd_reserved_60, nfc$delbd_reserved_61, nfc$delbd_reserved_62,
      nfc$delbd_reserved_63, nfc$delbd_reserved_64, nfc$delbd_reserved_65);

*DECK DECK=NFT$DELETE_BD_RESP_CODES EXPAND=FALSE
TYPE
    nft$delete_bd_responses = (nfc$message_accepted, nfc$no_io_station_found, nfc$no_device_found);
*DECK DECK=NFT$DELETE_DESTINATION_MSG EXPAND=FALSE
  TYPE
    nft$delete_destination_param = packed record
      length_indicated: boolean,
      param: nft$delete_destination_params,
    recend;

  TYPE
    nft$delete_destination_params = (nfc$null_parameter, nfc$destination_name, nfc$control_facility_name,
      nfc$delete_dest_reserved_3, nfc$delete_dest_reserved_4, nfc$delete_dest_reserved_5,
      nfc$delete_dest_reserved_6, nfc$delete_dest_reserved_7, nfc$delete_dest_reserved_8,
      nfc$delete_dest_reserved_9,  nfc$delete_dest_reserved_10, nfc$delete_dest_reserved_11,
      nfc$delete_dest_reserved_12, nfc$delete_dest_reserved_13, nfc$delete_dest_reserved_14,
      nfc$delete_dest_reserved_15, nfc$delete_dest_reserved_16, nfc$delete_dest_reserved_17,
      nfc$delete_dest_reserved_18, nfc$delete_dest_reserved_19, nfc$delete_dest_reserved_20,
      nfc$delete_dest_reserved_21, nfc$delete_dest_reserved_22, nfc$delete_dest_reserved_23,
      nfc$delete_dest_reserved_24, nfc$delete_dest_reserved_25, nfc$delete_dest_reserved_26,
      nfc$delete_dest_reserved_27, nfc$delete_dest_reserved_28, nfc$delete_dest_reserved_29,
      nfc$delete_dest_reserved_30, nfc$delete_dest_reserved_31, nfc$delete_dest_reserved_32,
      nfc$delete_dest_reserved_33, nfc$delete_dest_reserved_34, nfc$delete_dest_reserved_35,
      nfc$delete_dest_reserved_36, nfc$delete_dest_reserved_37, nfc$delete_dest_reserved_38,
      nfc$delete_dest_reserved_39, nfc$delete_dest_reserved_40, nfc$delete_dest_reserved_41,
      nfc$delete_dest_reserved_42, nfc$delete_dest_reserved_43, nfc$delete_dest_reserved_44,
      nfc$delete_dest_reserved_45, nfc$delete_dest_reserved_46, nfc$delete_dest_reserved_47,
      nfc$delete_dest_reserved_48, nfc$delete_dest_reserved_49, nfc$delete_dest_reserved_50,
      nfc$delete_dest_reserved_51, nfc$delete_dest_reserved_52, nfc$delete_dest_reserved_53,
      nfc$delete_dest_reserved_54, nfc$delete_dest_reserved_55, nfc$delete_dest_reserved_56,
      nfc$delete_dest_reserved_57, nfc$delete_dest_reserved_58, nfc$delete_dest_reserved_59,
      nfc$delete_dest_reserved_60, nfc$delete_dest_reserved_61, nfc$delete_dest_reserved_62,
      nfc$delete_dest_reserved_63, nfc$delete_dest_reserved_64, nfc$delete_dest_reserved_65);

*DECK DECK=NFT$DELETE_IOS_RESP_CODES EXPAND=FALSE
TYPE
    nft$delete_io_station_responses = (nfc$message_accepted, nfc$no_io_station);
*DECK DECK=NFT$DELETE_IO_STATION_MESSAGE EXPAND=FALSE
  TYPE
    nft$del_ios_message_parameter = packed record
      length_indicated: boolean,
      param: nft$delete_io_station_params,
    recend,

    nft$delete_io_station_params = (nfc$null_parameter, nfc$io_station_name, nfc$del_ios_reserved_2,
      nfc$del_ios_reserved_3, nfc$del_ios_reserved_4, nfc$del_ios_reserved_5, nfc$del_ios_reserved_6,
      nfc$del_ios_reserved_7, nfc$del_ios_reserved_8, nfc$del_ios_reserved_9, nfc$del_ios_reserved_10,
      nfc$del_ios_reserved_11, nfc$del_ios_reserved_12, nfc$del_ios_reserved_13, nfc$del_ios_reserved_14,
      nfc$del_ios_reserved_15, nfc$del_ios_reserved_16, nfc$del_ios_reserved_17, nfc$del_ios_reserved_18,
      nfc$del_ios_reserved_19, nfc$del_ios_reserved_20, nfc$del_ios_reserved_21, nfc$del_ios_reserved_22,
      nfc$del_ios_reserved_23, nfc$del_ios_reserved_24, nfc$del_ios_reserved_25, nfc$del_ios_reserved_26,
      nfc$del_ios_reserved_27, nfc$del_ios_reserved_28, nfc$del_ios_reserved_29, nfc$del_ios_reserved_30,
      nfc$del_ios_reserved_31, nfc$del_ios_reserved_32, nfc$del_ios_reserved_33, nfc$del_ios_reserved_34,
      nfc$del_ios_reserved_35, nfc$del_ios_reserved_36, nfc$del_ios_reserved_37, nfc$del_ios_reserved_38,
      nfc$del_ios_reserved_39, nfc$del_ios_reserved_40, nfc$del_ios_reserved_41, nfc$del_ios_reserved_42,
      nfc$del_ios_reserved_43, nfc$del_ios_reserved_44, nfc$del_ios_reserved_45, nfc$del_ios_reserved_46,
      nfc$del_ios_reserved_47, nfc$del_ios_reserved_48, nfc$del_ios_reserved_49, nfc$del_ios_reserved_50,
      nfc$del_ios_reserved_51, nfc$del_ios_reserved_52, nfc$del_ios_reserved_53, nfc$del_ios_reserved_54,
      nfc$del_ios_reserved_55, nfc$del_ios_reserved_56, nfc$del_ios_reserved_57, nfc$del_ios_reserved_58,
      nfc$del_ios_reserved_59, nfc$del_ios_reserved_60, nfc$del_ios_reserved_61, nfc$del_ios_reserved_62,
      nfc$del_ios_reserved_63, nfc$del_ios_reserved_64, nfc$del_ios_reserved_65);

*DECK DECK=NFT$DELETE_IO_STATION_RESPONSE EXPAND=FALSE
  TYPE
    nft$del_ios_resp_msg_parameter = packed record
      length_indicated: boolean,
      param: nft$delete_ios_resp_params,
    recend,

    nft$delete_ios_resp_params = (nfc$null_parameter, nfc$io_station_name, nfc$response_code,
      nfc$del_ios_reserved_3, nfc$del_ios_reserved_4, nfc$del_ios_reserved_5, nfc$del_ios_reserved_6,
      nfc$del_ios_reserved_7, nfc$del_ios_reserved_8, nfc$del_ios_reserved_9, nfc$del_ios_reserved_10,
      nfc$del_ios_reserved_11, nfc$del_ios_reserved_12, nfc$del_ios_reserved_13, nfc$del_ios_reserved_14,
      nfc$del_ios_reserved_15, nfc$del_ios_reserved_16, nfc$del_ios_reserved_17, nfc$del_ios_reserved_18,
      nfc$del_ios_reserved_19, nfc$del_ios_reserved_20, nfc$del_ios_reserved_21, nfc$del_ios_reserved_22,
      nfc$del_ios_reserved_23, nfc$del_ios_reserved_24, nfc$del_ios_reserved_25, nfc$del_ios_reserved_26,
      nfc$del_ios_reserved_27, nfc$del_ios_reserved_28, nfc$del_ios_reserved_29, nfc$del_ios_reserved_30,
      nfc$del_ios_reserved_31, nfc$del_ios_reserved_32, nfc$del_ios_reserved_33, nfc$del_ios_reserved_34,
      nfc$del_ios_reserved_35, nfc$del_ios_reserved_36, nfc$del_ios_reserved_37, nfc$del_ios_reserved_38,
      nfc$del_ios_reserved_39, nfc$del_ios_reserved_40, nfc$del_ios_reserved_41, nfc$del_ios_reserved_42,
      nfc$del_ios_reserved_43, nfc$del_ios_reserved_44, nfc$del_ios_reserved_45, nfc$del_ios_reserved_46,
      nfc$del_ios_reserved_47, nfc$del_ios_reserved_48, nfc$del_ios_reserved_49, nfc$del_ios_reserved_50,
      nfc$del_ios_reserved_51, nfc$del_ios_reserved_52, nfc$del_ios_reserved_53, nfc$del_ios_reserved_54,
      nfc$del_ios_reserved_55, nfc$del_ios_reserved_56, nfc$del_ios_reserved_57, nfc$del_ios_reserved_58,
      nfc$del_ios_reserved_59, nfc$del_ios_reserved_60, nfc$del_ios_reserved_61, nfc$del_ios_reserved_62,
      nfc$del_ios_reserved_63, nfc$del_ios_reserved_64, nfc$del_ios_reserved_65);
*DECK DECK=NFT$DESTINATION EXPAND=FALSE
  TYPE
    nft$destination = record
      name: ost$name,
      file_list: ^nft$available_file,
      control_facility_list: ^nft$linked_list_entry,
      link: ^nft$destination,
      title_search_id: nat$directory_search_identifier,
      translation_time_stamp: integer,
    recend;

*copyc nat$directory_search_identifier
*copyc nft$available_file
*copyc nft$destination
*copyc nft$linked_list_entry
*DECK DECK=NFT$DESTINATION_UNAVAIL_ACTIONS EXPAND=FALSE
  TYPE
    nft$destination_unavail_actions = (nfc$stop_input_device, nfc$drop_input_job);

*DECK DECK=NFT$DEVICE_ATTRIBUTES EXPAND=FALSE

  TYPE
    nft$device_attributes = record
      attributes_received: boolean,
      banner_highlight_field: nft$banner_highlight_field,
      banner_page_count: nft$banner_page_count,
      carriage_control_support: nft$carriage_control_action,
      code_set: nft$code_set,
      device_alias_1: ost$name,
      device_alias_2: ost$name,
      device_alias_3: ost$name,
      external_characteristics_1: nft$external_characteristics,
      external_characteristics_2: nft$external_characteristics,
      external_characteristics_3: nft$external_characteristics,
      external_characteristics_4: nft$external_characteristics,
      file_acknowledgement: boolean,
      forms_code_1: nft$forms_code,
      forms_code_2: nft$forms_code,
      forms_code_3: nft$forms_code,
      forms_code_4: nft$forms_code,
      forms_size: nft$forms_size,
      maximum_file_size: nft$device_file_size,
      page_width: nft$page_width,
      terminal_model: nft$terminal_model,
      tip_type: nft$tip_type,
      transmission_block_size: nft$transmit_block_size,
      undefined_fe_action: nft$format_effector_actions,
      unsupported_fe_action: nft$format_effector_actions,
      vertical_print_density: nft$vertical_print_density,
      vfu_load_option: nft$vfu_load_option,
      vfu_load_procedure: nft$vfu_load_procedure,
    recend;

*copyc nft$banner_highlight_field
*copyc nft$banner_page_count
*copyc nft$carriage_control_action
*copyc nft$code_set
*copyc nft$device_file_size
*copyc nft$device_type
*copyc nft$external_characteristics
*copyc nft$format_effector_actions
*copyc nft$forms_code
*copyc nft$forms_size
*copyc nft$page_width
*copyc nft$terminal_model
*copyc nft$tip_type
*copyc nft$transmit_block_size
*copyc nft$vertical_print_density
*copyc nft$vfu_load_option
*copyc nft$vfu_load_procedure
*copyc ost$name
*DECK DECK=NFT$DEVICE_CONTROL_RESP_CODES EXPAND=FALSE
  TYPE
    nft$device_control_resp_codes = (nfc$dc_msg_accepted, nfc$dc_msg_reject_btfsdi_down,
      nfc$dc_msg_reject_unknown_ios, nfc$dc_msg_reject_unknown_dev,
      nfc$dc_msg_reject_bad_dev_type, nfc$dc_msg_reject_bad_data_mode,
      nfc$dc_msg_rej_unsupported_vfu, nfc$dc_msg_rej_vfu_ld_outstand,
      nfc$dc_msg_rej_image_not_found, nfc$dc_msg_rej_err_in_vfu_image,
      nfc$dc_msg_rej_vfu_not_change,  nfc$dc_msg_rej_trm_undefined,
      nfc$dc_msg_rej_vfu_not_allow, nfc$dc_msg_rej_low_di_memory,
      nfc$dc_msg_rej_tip_reject_attr);
*DECK DECK=NFT$DEVICE_CONTROL_RESP_MSG EXPAND=FALSE
  TYPE
    nft$device_control_resp_param = packed record
      length_indicated: boolean,
      param: nft$device_control_resp_params,
    recend;

  TYPE
    nft$device_control_resp_params = (nfc$null_parameter, nfc$io_station_name, nfc$device_name,
      nfc$response_code, nfc$device_cntrl_reserved_4, nfc$device_cntrl_reserved_5,
      nfc$device_cntrl_reserved_6, nfc$device_cntrl_reserved_7, nfc$device_cntrl_reserved_8,
      nfc$device_cntrl_reserved_9, nfc$device_cntrl_reserved_10, nfc$device_cntrl_reserved_11,
      nfc$device_cntrl_reserved_12, nfc$device_cntrl_reserved_13, nfc$device_cntrl_reserved_14,
      nfc$device_cntrl_reserved_15, nfc$device_cntrl_reserved_16, nfc$device_cntrl_reserved_17,
      nfc$device_cntrl_reserved_18, nfc$device_cntrl_reserved_19, nfc$device_cntrl_reserved_20,
      nfc$device_cntrl_reserved_21, nfc$device_cntrl_reserved_22, nfc$device_cntrl_reserved_23,
      nfc$device_cntrl_reserved_24, nfc$device_cntrl_reserved_25, nfc$device_cntrl_reserved_26,
      nfc$device_cntrl_reserved_27, nfc$device_cntrl_reserved_28, nfc$device_cntrl_reserved_29,
      nfc$device_cntrl_reserved_30, nfc$device_cntrl_reserved_31, nfc$device_cntrl_reserved_32,
      nfc$device_cntrl_reserved_33, nfc$device_cntrl_reserved_34, nfc$device_cntrl_reserved_35,
      nfc$device_cntrl_reserved_36, nfc$device_cntrl_reserved_37, nfc$device_cntrl_reserved_38,
      nfc$device_cntrl_reserved_39, nfc$device_cntrl_reserved_40, nfc$device_cntrl_reserved_41,
      nfc$device_cntrl_reserved_42, nfc$device_cntrl_reserved_43, nfc$device_cntrl_reserved_44,
      nfc$device_cntrl_reserved_45, nfc$device_cntrl_reserved_46, nfc$device_cntrl_reserved_47,
      nfc$device_cntrl_reserved_48, nfc$device_cntrl_reserved_49, nfc$device_cntrl_reserved_50,
      nfc$device_cntrl_reserved_51, nfc$device_cntrl_reserved_52, nfc$device_cntrl_reserved_53,
      nfc$device_cntrl_reserved_54, nfc$device_cntrl_reserved_55, nfc$device_cntrl_reserved_56,
      nfc$device_cntrl_reserved_57, nfc$device_cntrl_reserved_58, nfc$device_cntrl_reserved_59,
      nfc$device_cntrl_reserved_60, nfc$device_cntrl_reserved_61, nfc$device_cntrl_reserved_62,
      nfc$device_cntrl_reserved_63, nfc$device_cntrl_reserved_64, nfc$device_cntrl_reserved_65);

*DECK DECK=NFT$DEVICE_FILE_SIZE EXPAND=FALSE
*copyc nfc$max_file_size
  TYPE
    nft$device_file_size = 0 .. nfc$max_file_size;

*DECK DECK=NFT$DEVICE_MAX_PAGE_LENGTH EXPAND=FALSE
CONST
  nfc$device_max_page_length = 255;

TYPE
  nft$device_max_page_length = 0 .. nfc$device_max_page_length;
*DECK DECK=NFT$DEVICE_STATUS EXPAND=FALSE
  TYPE
    nft$device_status = (nfc$device_active, nfc$device_stopped, nfc$device_not_ready,
      nfc$device_down, nfc$device_loading_vfu, nfc$default_vfu_not_loadable,
      nfc$device_stopped_by_system, nfc$device_status_reserved_7,
      nfc$device_status_reserved_8, nfc$device_status_reserved_9,
      nfc$device_status_reserved_10, nfc$ntf_waiting_signon,
      nfc$ntf_signon_initiated, nfc$ntf_signed_on,
      nfc$ntf_signon_failed, nfc$ntf_signed_off);

*DECK DECK=NFT$DEVICE_STATUS_DATA EXPAND=FALSE
*copyc ost$name
*copyc nft$device_status
*copyc nft$device_type
*copyc nft$file_transfer_status
  TYPE
    nft$device_status_data = record
      device_status: nft$device_status,
      file_xfer_status: nft$file_transfer_status,
      device_type: nft$device_type,
      name: string ( * <= osc$max_name_size),
    recend;

*DECK DECK=NFT$DEVICE_STATUS_DATA_MSG EXPAND=FALSE
*copyc nft$display_status_resp_codes
  TYPE
    nft$device_sd_msg_param = packed record
      length_indicated: boolean,
      param: nft$device_status_data_params,
    recend,

    nft$device_status_data_params = (nfc$null_parameter, nfc$io_station_name, nfc$device_name,
      nfc$response_code, nfc$device_status, nfc$device_type, nfc$file_transfer_status_param,
      nfc$terminal_model, nfc$file_acknowledgement, nfc$maximum_file_size, nfc$page_width, nfc$page_length,
      nfc$banner_page_count, nfc$banner_highlight_field, nfc$transmission_block_size,
      nfc$carriage_control_action, nfc$forms_code_1, nfc$forms_code_2, nfc$forms_code_3, nfc$forms_code_4,
      nfc$external_characteristics_1, nfc$external_characteristics_2, nfc$external_characteristics_3,
      nfc$external_characteristics_4, nfc$suppress_carriage_control, nfc$device_alias_1, nfc$device_alias_2,
      nfc$device_alias_3, nfc$last_unsolicited_msg, nfc$system_file_name, nfc$user_file_name,
      nfc$system_job_name, nfc$user_job_name, nfc$user_name, nfc$family_name, nfc$percent_complete,
      nfc$code_set, nfc$vertical_print_density, nfc$vfu_load_procedure, nfc$forms_size,
      nfc$undefined_fe_action, nfc$unsupported_fe_action, nfc$vfu_load_option, nfc$destination_name,
      nfc$input_bytes_transferred, nfc$ntf_logical_line_number, nfc$transparent_mode,
      nfc$ntf_skip_punch_count, nfc$dsd_reserved_48, nfc$dsd_reserved_49, nfc$dsd_reserved_50,
      nfc$dsd_reserved_51, nfc$dsd_reserved_52, nfc$dsd_reserved_53, nfc$dsd_reserved_54, nfc$dsd_reserved_55,
      nfc$dsd_reserved_56, nfc$dsd_reserved_57, nfc$dsd_reserved_58, nfc$dsd_reserved_59, nfc$dsd_reserved_60,
      nfc$dsd_reserved_61, nfc$dsd_reserved_62, nfc$dsd_reserved_63, nfc$dsd_reserved_64,
      nfc$dsd_reserved_65);

*DECK DECK=NFT$DEVICE_TYPE EXPAND=FALSE
  TYPE
    nft$device_type = (nfc$null_device, nfc$console, nfc$reader, nfc$printer, nfc$punch, nfc$plotter,
    nfc$ntf_remote_system_input, nfc$ntf_job_receiver, nfc$ntf_sysout_receiver, nfc$ntf_job_transmitter,
    nfc$ntf_sysout_transmitter);

*DECK DECK=NFT$DIRECTIVE_ENTRY EXPAND=TRUE

  TYPE
    nft$directive_entry = RECORD
      link: ^nft$directive_entry,
      line: STRING (* <= osc$max_string_size),
    RECEND;
*DECK DECK=NFT$DIRECTIVE_ENTRY_LIST_HEAD EXPAND=FALSE
  TYPE
    nft$directive_entry_list_head = record
      head: ^nft$directive_entry,
      tail: ^nft$directive_entry,
    recend;

*copyc nft$directive_entry
*DECK DECK=NFT$DISPLAY_STATUS_RESP_CODES EXPAND=FALSE
  TYPE
    nft$display_status_resp_codes = (nfc$disp_msg_accepted, nfc$disp_no_io_station, nfc$disp_no_batch_device,
      nfc$disp_unknown_file_name);

*DECK DECK=NFT$DI_POSITION_FILE_MESSAGE EXPAND=FALSE
  TYPE
    nft$position_file_di_msg_param = packed record
      length_indicated: boolean,
      param: nft$posf_di_parameters,
    recend,

    nft$posf_di_parameters = (nfc$null_parameter, nfc$io_station_name, nfc$device_name,
      nfc$position_parameters, nfc$posf_reserved_4, nfc$posf_reserved_5, nfc$posf_reserved_6,
      nfc$posf_reserved_7, nfc$posf_reserved_8, nfc$posf_reserved_9, nfc$posf_reserved_10,
      nfc$posf_reserved_11, nfc$posf_reserved_12, nfc$posf_reserved_13, nfc$posf_reserved_14,
      nfc$posf_reserved_15, nfc$posf_reserved_16, nfc$posf_reserved_17, nfc$posf_reserved_18,
      nfc$posf_reserved_19, nfc$posf_reserved_20, nfc$posf_reserved_21, nfc$posf_reserved_22,
      nfc$posf_reserved_23, nfc$posf_reserved_24, nfc$posf_reserved_25, nfc$posf_reserved_26,
      nfc$posf_reserved_27, nfc$posf_reserved_28, nfc$posf_reserved_29, nfc$posf_reserved_30,
      nfc$posf_reserved_31, nfc$posf_reserved_32, nfc$posf_reserved_33, nfc$posf_reserved_34,
      nfc$posf_reserved_35, nfc$posf_reserved_36, nfc$posf_reserved_37, nfc$posf_reserved_38,
      nfc$posf_reserved_39, nfc$posf_reserved_40, nfc$posf_reserved_41, nfc$posf_reserved_42,
      nfc$posf_reserved_43, nfc$posf_reserved_44, nfc$posf_reserved_45, nfc$posf_reserved_46,
      nfc$posf_reserved_47, nfc$posf_reserved_48, nfc$posf_reserved_49, nfc$posf_reserved_50,
      nfc$posf_reserved_51, nfc$posf_reserved_52, nfc$posf_reserved_53, nfc$posf_reserved_54,
      nfc$posf_reserved_55, nfc$posf_reserved_56, nfc$posf_reserved_57, nfc$posf_reserved_58,
      nfc$posf_reserved_59, nfc$posf_reserved_60, nfc$posf_reserved_61, nfc$posf_reserved_62,
      nfc$posf_reserved_63, nfc$posf_reserved_64, nfc$posf_reserved_65);

*DECK DECK=NFT$EXTERNAL_CHARACTERISTICS EXPAND=FALSE
*copyc jmt$external_characteristics

  TYPE
    nft$external_characteristics = jmt$external_characteristics;

*DECK DECK=NFT$FILE_ACCESS_MODE EXPAND=TRUE

  TYPE
    nft$file_access_mode = RECORD
      CASE mode_known: BOOLEAN  OF
      = TRUE =
        mode: nft$mode_of_access,
      CASEND,
    RECEND;

*copyc nft$mode_of_access
*DECK DECK=NFT$FILE_AND_PRIORITY EXPAND=FALSE
*copyc ost$name
  TYPE
    nft$file_and_priority = record
      priority: integer,
      name: string ( * <= osc$max_name_size),
    recend;

*DECK DECK=NFT$FILE_ASSIGNMENT_MSG EXPAND=FALSE
  TYPE
    nft$file_assign_msg_parameter = packed record
      length_indicated: boolean,
      param: nft$file_assignment_params,
    recend;

  TYPE
    nft$file_assignment_params = (nfc$null_parameter, nfc$io_station_name, nfc$system_file_name,
          nfc$device_name, nfc$btfsdi_address, nfc$requested_io_station, nfc$requested_device,
          nfc$operator_name, nfc$operator_family, nfc$station_usage, nfc$copies, nfc$external_characteristics,
          nfc$forms_code, nfc$output_initial_priority, nfc$vfu_load_procedure, nfc$vertical_print_density,
          nfc$ntf_remote_system_protocol, nfc$device_type, nfc$ntf_remote_system_type,
          nfc$ntf_route_back_position, nfc$btfs_di_title, nfc$banner_highlight_field, nfc$banner_page_count,
          nfc$carriage_control_support, nfc$code_set, nfc$device_alias_1, nfc$device_alias_2,
          nfc$device_alias_3, nfc$external_characteristics_1, nfc$external_characteristics_2,
          nfc$external_characteristics_3, nfc$external_characteristics_4, nfc$file_acknowledgement,
          nfc$forms_code_1, nfc$forms_code_2, nfc$forms_code_3, nfc$forms_code_4, nfc$forms_size,
          nfc$maximum_file_size, nfc$page_width, nfc$terminal_model, nfc$tip_type,
          nfc$transmission_block_size, nfc$undefined_fe_action, nfc$unsupported_fe_action,
          nfc$dev_vertical_print_density, nfc$vfu_load_option, nfc$dev_vfu_load_procedure,
          nfc$file_assign_reserved_48, nfc$file_assign_reserved_49, nfc$file_assign_reserved_50,
          nfc$file_assign_reserved_51, nfc$file_assign_reserved_52, nfc$file_assign_reserved_53,
          nfc$file_assign_reserved_54, nfc$file_assign_reserved_55, nfc$file_assign_reserved_56,
          nfc$file_assign_reserved_57, nfc$file_assign_reserved_58, nfc$file_assign_reserved_59,
          nfc$file_assign_reserved_60, nfc$file_assign_reserved_61, nfc$file_assign_reserved_62,
          nfc$file_assign_reserved_63, nfc$file_assign_reserved_64, nfc$file_assign_reserved_65);

*DECK DECK=NFT$FILE_ASSIGNMENT_RESPONSE EXPAND=FALSE

  TYPE
    nft$file_assignment_response = (nfc$file_assignment_accepted, nfc$file_assignment_rejected,
          nfc$btfsdi_title_not_translated);
*DECK DECK=NFT$FILE_ASSIGNMENT_RESP_MSG EXPAND=FALSE
  TYPE
    nft$file_assign_resp_parameter = packed record
      length_indicated: boolean,
      param: nft$file_assignment_resp_params,
    recend;

  TYPE
    nft$file_assignment_resp_params = (nfc$null_parameter, nfc$io_station_name, nfc$system_file_name,
      nfc$device_name, nfc$response_code, nfc$file_assign_reserved_5, nfc$file_assign_reserved_6,
      nfc$file_assign_reserved_7, nfc$file_assign_reserved_8, nfc$file_assign_reserved_9,
      nfc$file_assign_reserved_10, nfc$file_assign_reserved_11, nfc$file_assign_reserved_12,
      nfc$file_assign_reserved_13, nfc$file_assign_reserved_14, nfc$file_assign_reserved_15,
      nfc$file_assign_reserved_16, nfc$file_assign_reserved_17, nfc$file_assign_reserved_18,
      nfc$file_assign_reserved_19, nfc$file_assign_reserved_20, nfc$file_assign_reserved_21,
      nfc$file_assign_reserved_22, nfc$file_assign_reserved_23, nfc$file_assign_reserved_24,
      nfc$file_assign_reserved_25, nfc$file_assign_reserved_26, nfc$file_assign_reserved_27,
      nfc$file_assign_reserved_28, nfc$file_assign_reserved_29, nfc$file_assign_reserved_30,
      nfc$file_assign_reserved_31, nfc$file_assign_reserved_32, nfc$file_assign_reserved_33,
      nfc$file_assign_reserved_34, nfc$file_assign_reserved_35, nfc$file_assign_reserved_36,
      nfc$file_assign_reserved_37, nfc$file_assign_reserved_38, nfc$file_assign_reserved_39,
      nfc$file_assign_reserved_40, nfc$file_assign_reserved_41, nfc$file_assign_reserved_42,
      nfc$file_assign_reserved_43, nfc$file_assign_reserved_44, nfc$file_assign_reserved_45,
      nfc$file_assign_reserved_46, nfc$file_assign_reserved_47, nfc$file_assign_reserved_48,
      nfc$file_assign_reserved_49, nfc$file_assign_reserved_50, nfc$file_assign_reserved_51,
      nfc$file_assign_reserved_52, nfc$file_assign_reserved_53, nfc$file_assign_reserved_54,
      nfc$file_assign_reserved_55, nfc$file_assign_reserved_56, nfc$file_assign_reserved_57,
      nfc$file_assign_reserved_58, nfc$file_assign_reserved_59, nfc$file_assign_reserved_60,
      nfc$file_assign_reserved_61, nfc$file_assign_reserved_62, nfc$file_assign_reserved_63,
      nfc$file_assign_reserved_64, nfc$file_assign_reserved_65);

*DECK DECK=NFT$FILE_AVAILABILITY_MSG EXPAND=FALSE
  TYPE
    nft$file_available_msg_param = packed record
      length_indicated: boolean,
      param: nft$file_available_parameters,
    recend;

  TYPE
    nft$file_available_parameters = (nfc$null_parameter, nfc$io_station_name, nfc$operator_name,
      nfc$operator_family, nfc$station_usage, nfc$system_file_name, nfc$system_job_name, nfc$user_file_name,
      nfc$user_job_name, nfc$user_name, nfc$user_family, nfc$copies, nfc$device_name, nfc$device_type,
      nfc$external_characteristics, nfc$file_size, nfc$forms_code, nfc$output_data_mode,
      nfc$output_initial_priority, nfc$output_maximum_priority, nfc$output_priority_factor, nfc$output_state,
      nfc$page_format, nfc$page_length, nfc$page_width, nfc$vertical_print_density, nfc$vfu_load_procedure,
      nfc$file_requeued, nfc$file_held_by_filter, nfc$add_fa_reserved_29, nfc$add_fa_reserved_30,
      nfc$add_fa_reserved_31, nfc$add_fa_reserved_32, nfc$add_fa_reserved_33, nfc$add_fa_reserved_34,
      nfc$add_fa_reserved_35, nfc$add_fa_reserved_36, nfc$add_fa_reserved_37, nfc$add_fa_reserved_38,
      nfc$add_fa_reserved_39, nfc$add_fa_reserved_40, nfc$add_fa_reserved_41, nfc$add_fa_reserved_42,
      nfc$add_fa_reserved_43, nfc$add_fa_reserved_44, nfc$add_fa_reserved_45, nfc$add_fa_reserved_46,
      nfc$add_fa_reserved_47, nfc$add_fa_reserved_48, nfc$add_fa_reserved_49, nfc$add_fa_reserved_50,
      nfc$add_fa_reserved_51, nfc$add_fa_reserved_52, nfc$add_fa_reserved_53, nfc$add_fa_reserved_54,
      nfc$add_fa_reserved_55, nfc$add_fa_reserved_56, nfc$add_fa_reserved_57, nfc$add_fa_reserved_58,
      nfc$add_fa_reserved_59, nfc$add_fa_reserved_60, nfc$add_fa_reserved_61, nfc$add_fa_reserved_62,
      nfc$add_fa_reserved_63, nfc$add_fa_reserved_64, nfc$add_fa_reserved_65);

*DECK DECK=NFT$FILE_COUNT EXPAND=FALSE
  TYPE
    nft$file_count = integer;

*DECK DECK=NFT$FILE_DISPOSITION EXPAND=FALSE
  TYPE
    nft$file_disposition = (nfc$requeue_file, nfc$drop_file_from_q, nfc$hold_file_in_q, nfc$complete_file,
      nfc$maintain_file_position);

*DECK DECK=NFT$FILE_KIND EXPAND=FALSE
  TYPE
    nft$file_kind = (nfc$output_file, nfc$input_file, nfc$generic_file);
*DECK DECK=NFT$FILE_POSITION EXPAND=FALSE
{       File Position is a percentage of how much of a file has been printed.
  TYPE
    nft$file_position = 0 .. 100;

*DECK DECK=NFT$FILE_SIZE EXPAND=FALSE
  TYPE
    nft$file_size = integer;

*DECK DECK=NFT$FILE_STATUS_MESSAGE EXPAND=FALSE
  TYPE
    nft$file_status_message_param = packed record
      length_indicated: boolean,
      param: nft$file_status_parameters,
    recend,

    nft$file_status_parameters = (nfc$null_parameter, nfc$io_station_name, nfc$device_name,
      nfc$device_status, nfc$file_transfer_status_param, nfc$file_position, nfc$system_job_file_name,
      nfc$system_id_family, nfc$user_job_file_name, nfc$actual_destination, nfc$requested_destination,
      nfc$input_bytes_transferred, nfc$file_status_reserved_12, nfc$file_status_reserved_13,
      nfc$file_status_reserved_14, nfc$file_status_reserved_15, nfc$file_status_reserved_16,
      nfc$file_status_reserved_17, nfc$file_status_reserved_18, nfc$file_status_reserved_19,
      nfc$file_status_reserved_20, nfc$file_status_reserved_21, nfc$file_status_reserved_22,
      nfc$file_status_reserved_23, nfc$file_status_reserved_24, nfc$file_status_reserved_25,
      nfc$file_status_reserved_26, nfc$file_status_reserved_27, nfc$file_status_reserved_28,
      nfc$file_status_reserved_29, nfc$file_status_reserved_30, nfc$file_status_reserved_31,
      nfc$file_status_reserved_32, nfc$file_status_reserved_33, nfc$file_status_reserved_34,
      nfc$file_status_reserved_35, nfc$file_status_reserved_36, nfc$file_status_reserved_37,
      nfc$file_status_reserved_38, nfc$file_status_reserved_39, nfc$file_status_reserved_40,
      nfc$file_status_reserved_41, nfc$file_status_reserved_42, nfc$file_status_reserved_43,
      nfc$file_status_reserved_44, nfc$file_status_reserved_45, nfc$file_status_reserved_46,
      nfc$file_status_reserved_47, nfc$file_status_reserved_48, nfc$file_status_reserved_49,
      nfc$file_status_reserved_50, nfc$file_status_reserved_51, nfc$file_status_reserved_52,
      nfc$file_status_reserved_53, nfc$file_status_reserved_54, nfc$file_status_reserved_55,
      nfc$file_status_reserved_56, nfc$file_status_reserved_57, nfc$file_status_reserved_58,
      nfc$file_status_reserved_59, nfc$file_status_reserved_60, nfc$file_status_reserved_61,
      nfc$file_status_reserved_62, nfc$file_status_reserved_63, nfc$file_status_reserved_64,
      nfc$file_status_reserved_65);
*DECK DECK=NFT$FILE_TRANSFER_STATE EXPAND=FALSE

  TYPE
    nft$file_transfer_state = (nfc$eligible_for_transfer, nfc$hold_transfer,
          nfc$not_eligible_for_transfer, nfc$selected_for_transfer);
*DECK DECK=NFT$FILE_TRANSFER_STATUS EXPAND=FALSE
  TYPE
    nft$file_transfer_status = (nfc$idle, nfc$idle_device_disconnect, nfc$idle_vfu_not_loadable,
      nfc$idle_transfer_error, nfc$idle_accounting_limit, nfc$idle_operator_drop_file,
      nfc$idle_operator_requeued_file, nfc$idle_operator_hold_file, nfc$busy,
      nfc$suspended_device_not_ready, nfc$suspended_pm_message, nfc$suspended_operator_command,
      nfc$suspended_operator_posf_cmd, nfc$suspended_vfu_being_loaded, nfc$busy_reserved_14,
      nfc$busy_reserved_15);

*DECK DECK=NFT$FILE_VERTICAL_PRINT_DENSITY EXPAND=FALSE
TYPE
  nft$file_vertical_print_density = (nfc$vertical_print_density_none,
        nfc$vertical_print_density_6, nfc$vertical_print_density_7,
        nfc$vertical_print_density_8, nfc$vertical_print_density_9,
        nfc$vertical_print_density_10, nfc$vertical_print_density_11,
        nfc$vertical_print_density_12);
*DECK DECK=NFT$FORMAT_EFFECTOR_ACTIONS EXPAND=FALSE
  TYPE
    nft$format_effector_actions = (nfc$print_after_spacing, nfc$print_before_spacing,
          nfc$discard_print_line);

*DECK DECK=NFT$FORMS_CODE EXPAND=FALSE
*copyc jmt$forms_code

  TYPE
    nft$forms_code = jmt$forms_code;

*DECK DECK=NFT$FORMS_SIZE EXPAND=FALSE
  CONST
    nfc$min_forms_size = 1,
    nfc$max_forms_size = 62;

  TYPE
    nft$forms_size = nfc$min_forms_size .. nfc$max_forms_size;
*DECK DECK=NFT$GENERIC_DESCRIPTOR EXPAND=FALSE
  TYPE
    nft$generic_descriptor = record
      destination: ost$name,
      remote_host_directive: jmt$remote_host_directive,
      system_file_name: jmt$system_supplied_name,
    recend;
*DECK DECK=NFT$GET_DEVICE_STATUS_MSG EXPAND=FALSE
  TYPE
    nft$get_device_status_param = packed record
      length_indicated: boolean,
      param: nft$get_device_status_params,
    recend,

    nft$get_device_status_params = (nfc$null_parameter, nfc$io_station_name, nfc$device_name,
      nfc$get_ds_reserved_3, nfc$get_ds_reserved_4, nfc$get_ds_reserved_5, nfc$get_ds_reserved_6,
      nfc$get_ds_reserved_7, nfc$get_ds_reserved_8, nfc$get_ds_reserved_9, nfc$get_ds_reserved_10,
      nfc$get_ds_reserved_11, nfc$get_ds_reserved_12, nfc$get_ds_reserved_13, nfc$get_ds_reserved_14,
      nfc$get_ds_reserved_15, nfc$get_ds_reserved_16, nfc$get_ds_reserved_17, nfc$get_ds_reserved_18,
      nfc$get_ds_reserved_19, nfc$get_ds_reserved_20, nfc$get_ds_reserved_21, nfc$get_ds_reserved_22,
      nfc$get_ds_reserved_23, nfc$get_ds_reserved_24, nfc$get_ds_reserved_25, nfc$get_ds_reserved_26,
      nfc$get_ds_reserved_27, nfc$get_ds_reserved_28, nfc$get_ds_reserved_29, nfc$get_ds_reserved_30,
      nfc$get_ds_reserved_31, nfc$get_ds_reserved_32, nfc$get_ds_reserved_33, nfc$get_ds_reserved_34,
      nfc$get_ds_reserved_35, nfc$get_ds_reserved_36, nfc$get_ds_reserved_37, nfc$get_ds_reserved_38,
      nfc$get_ds_reserved_39, nfc$get_ds_reserved_40, nfc$get_ds_reserved_41, nfc$get_ds_reserved_42,
      nfc$get_ds_reserved_43, nfc$get_ds_reserved_44, nfc$get_ds_reserved_45, nfc$get_ds_reserved_46,
      nfc$get_ds_reserved_47, nfc$get_ds_reserved_48, nfc$get_ds_reserved_49, nfc$get_ds_reserved_50,
      nfc$get_ds_reserved_51, nfc$get_ds_reserved_52, nfc$get_ds_reserved_53, nfc$get_ds_reserved_54,
      nfc$get_ds_reserved_55, nfc$get_ds_reserved_56, nfc$get_ds_reserved_57, nfc$get_ds_reserved_58,
      nfc$get_ds_reserved_59, nfc$get_ds_reserved_60, nfc$get_ds_reserved_61, nfc$get_ds_reserved_62,
      nfc$get_ds_reserved_63, nfc$get_ds_reserved_64, nfc$get_ds_reserved_65);

*DECK DECK=NFT$GET_QUEUE_ENTRY_MSG EXPAND=FALSE
  TYPE
    nft$get_queue_entry_parameter = packed record
      length_indicated: boolean,
      param: nft$get_queue_entry_parameters,
    recend,

    nft$get_queue_entry_parameters = (nfc$null_parameter, nfc$io_station_name, nfc$system_file_name,
      nfc$getqe_reserved_3, nfc$getqe_reserved_4, nfc$getqe_reserved_5, nfc$getqe_reserved_6,
      nfc$getqe_reserved_7, nfc$getqe_reserved_8, nfc$getqe_reserved_9, nfc$getqe_reserved_10,
      nfc$getqe_reserved_11, nfc$getqe_reserved_12, nfc$getqe_reserved_13, nfc$getqe_reserved_14,
      nfc$getqe_reserved_15, nfc$getqe_reserved_16, nfc$getqe_reserved_17, nfc$getqe_reserved_18,
      nfc$getqe_reserved_19, nfc$getqe_reserved_20, nfc$getqe_reserved_21, nfc$getqe_reserved_22,
      nfc$getqe_reserved_23, nfc$getqe_reserved_24, nfc$getqe_reserved_25, nfc$getqe_reserved_26,
      nfc$getqe_reserved_27, nfc$getqe_reserved_28, nfc$getqe_reserved_29, nfc$getqe_reserved_30,
      nfc$getqe_reserved_31, nfc$getqe_reserved_32, nfc$getqe_reserved_33, nfc$getqe_reserved_34,
      nfc$getqe_reserved_35, nfc$getqe_reserved_36, nfc$getqe_reserved_37, nfc$getqe_reserved_38,
      nfc$getqe_reserved_39, nfc$getqe_reserved_40, nfc$getqe_reserved_41, nfc$getqe_reserved_42,
      nfc$getqe_reserved_43, nfc$getqe_reserved_44, nfc$getqe_reserved_45, nfc$getqe_reserved_46,
      nfc$getqe_reserved_47, nfc$getqe_reserved_48, nfc$getqe_reserved_49, nfc$getqe_reserved_50,
      nfc$getqe_reserved_51, nfc$getqe_reserved_52, nfc$getqe_reserved_53, nfc$getqe_reserved_54,
      nfc$getqe_reserved_55, nfc$getqe_reserved_56, nfc$getqe_reserved_57, nfc$getqe_reserved_58,
      nfc$getqe_reserved_59, nfc$getqe_reserved_60, nfc$getqe_reserved_61, nfc$getqe_reserved_62,
      nfc$getqe_reserved_63, nfc$getqe_reserved_64, nfc$getqe_reserved_65);

*DECK DECK=NFT$GET_Q_ENTRY_LIST_MSG EXPAND=FALSE
  TYPE
    nft$get_q_entry_list_msg_param = packed record
      length_indicated: boolean,
      param: nft$get_q_entry_list_params,
    recend,

    nft$get_q_entry_list_params = (nfc$null_parameter, nfc$io_station_name, nfc$all_or_top_ten,
      nfc$optimize_queue_list, nfc$getqel_reserved_4, nfc$getqel_reserved_5, nfc$getqel_reserved_6,
      nfc$getqel_reserved_7, nfc$getqel_reserved_8, nfc$getqel_reserved_9, nfc$getqel_reserved_10,
      nfc$getqel_reserved_11, nfc$getqel_reserved_12, nfc$getqel_reserved_13, nfc$getqel_reserved_14,
      nfc$getqel_reserved_15, nfc$getqel_reserved_16, nfc$getqel_reserved_17, nfc$getqel_reserved_18,
      nfc$getqel_reserved_19, nfc$getqel_reserved_20, nfc$getqel_reserved_21, nfc$getqel_reserved_22,
      nfc$getqel_reserved_23, nfc$getqel_reserved_24, nfc$getqel_reserved_25, nfc$getqel_reserved_26,
      nfc$getqel_reserved_27, nfc$getqel_reserved_28, nfc$getqel_reserved_29, nfc$getqel_reserved_30,
      nfc$getqel_reserved_31, nfc$getqel_reserved_32, nfc$getqel_reserved_33, nfc$getqel_reserved_34,
      nfc$getqel_reserved_35, nfc$getqel_reserved_36, nfc$getqel_reserved_37, nfc$getqel_reserved_38,
      nfc$getqel_reserved_39, nfc$getqel_reserved_40, nfc$getqel_reserved_41, nfc$getqel_reserved_42,
      nfc$getqel_reserved_43, nfc$getqel_reserved_44, nfc$getqel_reserved_45, nfc$getqel_reserved_46,
      nfc$getqel_reserved_47, nfc$getqel_reserved_48, nfc$getqel_reserved_49, nfc$getqel_reserved_50,
      nfc$getqel_reserved_51, nfc$getqel_reserved_52, nfc$getqel_reserved_53, nfc$getqel_reserved_54,
      nfc$getqel_reserved_55, nfc$getqel_reserved_56, nfc$getqel_reserved_57, nfc$getqel_reserved_58,
      nfc$getqel_reserved_59, nfc$getqel_reserved_60, nfc$getqel_reserved_61, nfc$getqel_reserved_62,
      nfc$getqel_reserved_63, nfc$getqel_reserved_64, nfc$getqel_reserved_65);

*DECK DECK=NFT$GET_STATION_STATUS_MSG EXPAND=FALSE
  TYPE
    nft$get_station_status_param = packed record
      length_indicated: boolean,
      param: nft$get_station_status_params,
    recend,

    nft$get_station_status_params = (nfc$null_parameter, nfc$io_station_name, nfc$optimize_device_list,
      nfc$get_ss_reserved_3, nfc$get_ss_reserved_4, nfc$get_ss_reserved_5, nfc$get_ss_reserved_6,
      nfc$get_ss_reserved_7, nfc$get_ss_reserved_8, nfc$get_ss_reserved_9, nfc$get_ss_reserved_10,
      nfc$get_ss_reserved_11, nfc$get_ss_reserved_12, nfc$get_ss_reserved_13, nfc$get_ss_reserved_14,
      nfc$get_ss_reserved_15, nfc$get_ss_reserved_16, nfc$get_ss_reserved_17, nfc$get_ss_reserved_18,
      nfc$get_ss_reserved_19, nfc$get_ss_reserved_20, nfc$get_ss_reserved_21, nfc$get_ss_reserved_22,
      nfc$get_ss_reserved_23, nfc$get_ss_reserved_24, nfc$get_ss_reserved_25, nfc$get_ss_reserved_26,
      nfc$get_ss_reserved_27, nfc$get_ss_reserved_28, nfc$get_ss_reserved_29, nfc$get_ss_reserved_30,
      nfc$get_ss_reserved_31, nfc$get_ss_reserved_32, nfc$get_ss_reserved_33, nfc$get_ss_reserved_34,
      nfc$get_ss_reserved_35, nfc$get_ss_reserved_36, nfc$get_ss_reserved_37, nfc$get_ss_reserved_38,
      nfc$get_ss_reserved_39, nfc$get_ss_reserved_40, nfc$get_ss_reserved_41, nfc$get_ss_reserved_42,
      nfc$get_ss_reserved_43, nfc$get_ss_reserved_44, nfc$get_ss_reserved_45, nfc$get_ss_reserved_46,
      nfc$get_ss_reserved_47, nfc$get_ss_reserved_48, nfc$get_ss_reserved_49, nfc$get_ss_reserved_50,
      nfc$get_ss_reserved_51, nfc$get_ss_reserved_52, nfc$get_ss_reserved_53, nfc$get_ss_reserved_54,
      nfc$get_ss_reserved_55, nfc$get_ss_reserved_56, nfc$get_ss_reserved_57, nfc$get_ss_reserved_58,
      nfc$get_ss_reserved_59, nfc$get_ss_reserved_60, nfc$get_ss_reserved_61, nfc$get_ss_reserved_62,
      nfc$get_ss_reserved_63, nfc$get_ss_reserved_64, nfc$get_ss_reserved_65);

*DECK DECK=NFT$IMPLICIT_COMMAND EXPAND=FALSE
  TYPE
    nft$implicit_command = ost$string;

*copyc ost$string
*DECK DECK=NFT$INPUT_JOB_SIZE EXPAND=FALSE
*copyc nfc$max_input_job_size

TYPE
  nft$input_job_size = 0 .. nfc$max_input_job_size;
*DECK DECK=NFT$INTERTASK_MESSAGE EXPAND=FALSE

  {   This definition is used by QTF, SCF, BTF, and NTF.

  TYPE
    nft$intertask_message = record
      case kind: nft$intertask_message_kind of
      = nfc$btf_file_transfer =
        network_address: nat$network_address,
        btf_file_descriptor: nft$application_file_descriptor,
        ntf_local_file_name: amt$local_file_name,
        device_environment_variable: ost$name,
        scfs_can_handle_filter_hold: boolean,
      = nfc$qtf_file_transfer =
        connection_kind: nft$network_type,
        connection_file: amt$local_file_name,
        host_pid: ost$name,
        qtf_file_descriptor: nft$application_file_descriptor,
      = nfc$btf_file_transfer_status =
        btf_system_file_name: jmt$system_supplied_name,
        copies_printed: nft$copies,
        btf_transfer_status: nft$btf_transfer_status,
        btf_task_status: ost$status,
        filter_aborted: boolean,
      = nfc$qtf_file_transfer_status =
        qtf_system_file_name: jmt$system_supplied_name,
        qtf_transfer_status: nft$qtf_transfer_status,
        remote_job_name: jmt$system_supplied_name,
        qtf_task_status: ost$status,
      = nfc$qtf_terminate_connection =
        connect_file_name: amt$local_file_name,
      = nfc$abnormal_child_task_abort =
        task_status: ost$status,
      = nfc$btf_task_terminated, nfc$qtf_connection_terminated,
              nfc$qtf_task_terminated, nfc$qtf_terminate_task =
        ,
      casend,
    recend,

    nft$intertask_message_kind = (nfc$btf_file_transfer, nfc$qtf_file_transfer,
      nfc$btf_file_transfer_status, nfc$qtf_file_transfer_status,
      nfc$qtf_terminate_connection, nfc$qtf_connection_terminated,
      nfc$qtf_terminate_task, nfc$btf_task_terminated,
      nfc$qtf_task_terminated, nfc$abnormal_child_task_abort);

*copyc amt$local_file_name
*copyc jmt$queue_file_password
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
*copyc nat$network_address
*copyc nft$btf_transfer_status
*copyc nft$copies
*copyc nft$network_type
*copyc nft$application_file_descriptor
*copyc nft$qtf_transfer_status
*DECK DECK=NFT$INTERTASK_TRANSFER_SIZE EXPAND=FALSE
  TYPE
    nft$intertask_transfer_size = 0 .. nfc$max_transfer_size;

  CONST
    nfc$max_transfer_size = 4096 { bytes };

*DECK DECK=NFT$INTERTASK_WAIT_TIME EXPAND=FALSE
  TYPE
    nft$intertask_wait_time = 0 .. nfc$max_wait_time;

  CONST
    nfc$max_wait_time = 60 { seconds };

*DECK DECK=NFT$IO_STATION_USAGE EXPAND=FALSE
  TYPE
    nft$io_station_usage = (nfc$public_io_station, nfc$private_io_station,
          nfc$ntf_remote_system);

*DECK DECK=NFT$LAST_COMMAND_RECEIVED EXPAND=FALSE
?? NEWTITLE := 'nft$last_command_received' ??

{ nft$last_command_received }

  TYPE
    nft$last_command_received = nft$protocol_commands;

*copyc nft$protocol_commands
?? OLDTITLE ??
*DECK DECK=NFT$LAST_COMMAND_SENT EXPAND=FALSE

?? NEWTITLE := 'nft$last_command_sent' ??

{ nft$last_command_sent }

  TYPE
    nft$last_command_sent = nft$protocol_commands;

*copyc nft$protocol_commands
?? OLDTITLE ??
*DECK DECK=NFT$LCN_APPLICATION_NAMES EXPAND=FALSE
?? NEWTITLE := 'nft$lcn_application_names' ??

{ nft$lcn_application_names }

  TYPE
    nft$lcn_application_names = array [nft$application_values] of
          rft$application_name;

*copyc nft$application_values
*copyc rft$external_interface
?? OLDTITLE ??
*DECK DECK=NFT$LINKED_LIST_ENTRY EXPAND=FALSE
*copyc nft$link_kind

  TYPE
    nft$linked_list_entry = record
      back_link: ^nft$linked_list_entry,
      link: ^nft$linked_list_entry,
      case kind: nft$link_kind of
      = nfc$control_facility =
        control_facility: ^nft$control_facility,
      casend,
    recend;

*copyc nft$control_facility
*DECK DECK=NFT$LINK_KIND EXPAND=FALSE

  TYPE
    nft$link_kind = (nfc$control_facility, nfc$reserved_link_kind);

*DECK DECK=NFT$MESSAGE_KIND EXPAND=FALSE
  TYPE
    nft$message_kind = (nfc$reserved_msg_type_0, nfc$add_file_availability, nfc$modify_file_availability,
      nfc$delete_file_availability, nfc$file_assignment, nfc$file_assignment_response, nfc$delete_destination,
      nfc$btf_ve_status, nfc$reserved_msg_type_8, nfc$add_ntf_acc_rem_sys_resp,
      nfc$get_ntf_rem_sys_names_msg, nfc$get_ntf_rem_sys_names_data, nfc$get_ntf_rem_sys_opts_msg,
      nfc$get_ntf_rem_sys_opts_data, nfc$delete_ntf_user_msg, nfc$delete_ntf_user_resp,
      nfc$send_ntf_remote_comm_msg, nfc$send_ntf_remote_comm_resp, nfc$get_ntf_rem_sys_stat_msg,
      nfc$get_ntf_rem_sys_stat_data, nfc$add_io_station, nfc$delete_io_station, nfc$add_batch_device,
      nfc$batch_device_status, nfc$file_transfer_status, nfc$delete_batch_device, nfc$btfs_di_status,
      nfc$add_io_station_resp, nfc$delete_io_station_resp, nfc$start_io_station, nfc$stop_io_station,
      nfc$switch_io_station, nfc$position_file_di, nfc$add_batch_device_resp, nfc$delete_batch_device_resp,
      nfc$add_ntf_remote_sys_msg, nfc$add_ntf_acc_rem_sys_msg, nfc$delete_ntf_remote_sys_msg,
      nfc$add_ntf_remote_sys_resp, nfc$delete_ntf_remote_sys_resp, nfc$suppress_carriage_cntrl_rsp,
      nfc$start_batch_device, nfc$stop_batch_device, nfc$suppress_carriage_control, nfc$terminate_transfer,
      nfc$change_batch_device_attr, nfc$change_bat_device_attr_resp, nfc$start_batch_device_resp,
      nfc$stop_batch_device_resp, nfc$terminate_transfer_resp, nfc$position_file_resp, nfc$operator_message,
      nfc$reserved_msg_type_52, nfc$reserved_msg_type_53, nfc$reserved_msg_type_54, nfc$reserved_msg_type_55,
      nfc$reserved_msg_type_56, nfc$reserved_msg_type_57, nfc$reserved_msg_type_58, nfc$reserved_msg_type_59,
      nfc$add_user, nfc$add_user_resp, nfc$select_file, nfc$select_file_response, nfc$position_file_sou,
      nfc$get_station_status,nfc$station_status_data, nfc$get_device_status, nfc$device_status_data,
      nfc$get_queue_status, nfc$queue_status_data, nfc$get_queue_entry_list, nfc$queue_entry_list_data,
      nfc$get_queue_entry, nfc$queue_entry_data, nfc$terminate_queue_output, nfc$terminate_queue_output_resp,
      nfc$reserved_msg_type_77, nfc$reserved_msg_type_78, nfc$reserved_msg_type_79,
      nfc$switch_control_facility, nfc$reserved_msg_type_81, nfc$reserved_msg_type_82,
      nfc$reserved_msg_type_83, nfc$reserved_msg_type_84, nfc$reserved_msg_type_85, nfc$reserved_msg_type_86,
      nfc$reserved_msg_type_87, nfc$reserved_msg_type_88, nfc$reserved_msg_type_89, nfc$reserved_msg_type_90,
      nfc$reserved_msg_type_91, nfc$reserved_msg_type_92, nfc$reserved_msg_type_93, nfc$reserved_msg_type_94,
      nfc$reserved_msg_type_95);

*DECK DECK=NFT$MESSAGE_SEQUENCE EXPAND=FALSE
  {  nfc$maximum_message_length is the largest any message coming
  {      into SCFS/VE can be.  This could be subject to change.
  CONST
    nfc$maximum_message_length = 8192,
  {  nfc$maximum_send_message_length is the largest any message
  {      sent from SCFS/VE can be.  This could be subject to change.
    nfc$maximum_send_message_length = 65535;

  TYPE
    nft$message_length = 0 .. nfc$maximum_send_message_length;

  TYPE
    nft$message_sequence = SEQ ( * );

*DECK DECK=NFT$MICRO_SECOND EXPAND=FALSE
  TYPE
    nft$micro_second = integer;

*DECK DECK=NFT$MODE_OF_ACCESS EXPAND=TRUE

  TYPE
    nft$mode_of_access = (nfc$give, nfc$take, nfc$null);
*DECK DECK=NFT$NAM_APPLICATION_NAMES EXPAND=FALSE
?? NEWTITLE := 'nft$nam_application_names' ??

{ nft$nam_application_names }

  TYPE
    nft$nam_application_names = array [nft$application_values] of
          nat$application_name;

*copyc nat$application_name
*copyc nft$application_values
?? OLDTITLE ??
*DECK DECK=NFT$NETWORK_ADDRESS EXPAND=FALSE
*copyc nat$internet_address
  TYPE
    nft$network_address = nat$internet_address;

*DECK DECK=NFT$NETWORK_BUFFER_LIST EXPAND=FALSE
  TYPE
    nft$network_buffer_list = record
      head: ^nft$buffer_control_block,
      tail: ^nft$buffer_control_block,
    recend;

*copyc nft$buffer_control_block
*DECK DECK=NFT$NETWORK_CONNECTION EXPAND=FALSE
?? NEWTITLE := 'nft$network_connection' ??

{ nft$network_address }

  TYPE
    nft$network_connection = record
      network_file_id: amt$file_identifier,
      network_file: ^fst$file_reference,
      path_connected: boolean,
      application_sequence_number: integer,
      case network_type: nft$network_type of
      = nfc$unknown_network =
        ,
      = nfc$network_nam =
        nam_address: nat$network_address,
      = nfc$network_lcn =
        lcn_address: integer,
      casend,
    recend;

*copyc amt$file_identifier
*copyc fst$file_reference
*copyc nat$network_address
*copyc nft$network_type
?? OLDTITLE ??
*DECK DECK=NFT$NETWORK_RING_INFORMATION EXPAND=FALSE
  TYPE
    nft$network_ring_information = record
      specified: boolean,
      value: ost$ring,
    recend;

*copyc osd$virtual_address
*DECK DECK=NFT$NETWORK_TYPE EXPAND=FALSE
?? NEWTITLE := 'nft$network_type' ??

{ nft$network_type }

  TYPE
    nft$network_type = (nfc$unknown_network, nfc$network_nam, nfc$network_lcn);

?? OLDTITLE ??
*DECK DECK=NFT$NTF_ADD_ACC_REM_SYS_MSG EXPAND=FALSE

  TYPE
    nft$ntf_add_acc_rem_sys_msg = packed record
      length_indicated: boolean,
      param: nft$ntf_add_ars_msg_parameters,
    recend,

    nft$ntf_add_ars_msg_parameters = (nfc$null_parameter,
          nfc$ntf_remote_system_name, nfc$ntf_logical_line_number,
          nfc$ntf_acc_remote_system_name, nfc$ntf_authority_level,
          nfc$ntf_remote_system_type, nfc$ntf_route_back_position,
          nfc$ntf_addars_msg_reserved_7, nfc$ntf_addars_msg_reserved_8,
          nfc$ntf_addars_msg_reserved_9, nfc$ntf_addars_msg_reserved_10,
          nfc$ntf_addars_msg_reserved_11, nfc$ntf_addars_msg_reserved_12,
          nfc$ntf_addars_msg_reserved_13, nfc$ntf_addars_msg_reserved_14,
          nfc$ntf_addars_msg_reserved_15, nfc$ntf_addars_msg_reserved_16,
          nfc$ntf_addars_msg_reserved_17, nfc$ntf_addars_msg_reserved_18,
          nfc$ntf_addars_msg_reserved_19, nfc$ntf_addars_msg_reserved_20,
          nfc$ntf_addars_msg_reserved_21, nfc$ntf_addars_msg_reserved_22,
          nfc$ntf_addars_msg_reserved_23, nfc$ntf_addars_msg_reserved_24,
          nfc$ntf_addars_msg_reserved_25, nfc$ntf_addars_msg_reserved_26,
          nfc$ntf_addars_msg_reserved_27, nfc$ntf_addars_msg_reserved_28,
          nfc$ntf_addars_msg_reserved_29, nfc$ntf_addars_msg_reserved_30,
          nfc$ntf_addars_msg_reserved_31, nfc$ntf_addars_msg_reserved_32,
          nfc$ntf_addars_msg_reserved_33, nfc$ntf_addars_msg_reserved_34,
          nfc$ntf_addars_msg_reserved_35, nfc$ntf_addars_msg_reserved_36,
          nfc$ntf_addars_msg_reserved_37, nfc$ntf_addars_msg_reserved_38,
          nfc$ntf_addars_msg_reserved_39, nfc$ntf_addars_msg_reserved_40,
          nfc$ntf_addars_msg_reserved_41, nfc$ntf_addars_msg_reserved_42,
          nfc$ntf_addars_msg_reserved_43, nfc$ntf_addars_msg_reserved_44,
          nfc$ntf_addars_msg_reserved_45, nfc$ntf_addars_msg_reserved_46,
          nfc$ntf_addars_msg_reserved_47, nfc$ntf_addars_msg_reserved_48,
          nfc$ntf_addars_msg_reserved_49, nfc$ntf_addars_msg_reserved_50,
          nfc$ntf_addars_msg_reserved_51, nfc$ntf_addars_msg_reserved_52,
          nfc$ntf_addars_msg_reserved_53, nfc$ntf_addars_msg_reserved_54,
          nfc$ntf_addars_msg_reserved_55, nfc$ntf_addars_msg_reserved_56,
          nfc$ntf_addars_msg_reserved_57, nfc$ntf_addars_msg_reserved_58,
          nfc$ntf_addars_msg_reserved_59, nfc$ntf_addars_msg_reserved_60,
          nfc$ntf_addars_msg_reserved_61, nfc$ntf_addars_msg_reserved_62,
          nfc$ntf_addars_msg_reserved_63, nfc$ntf_addars_msg_reserved_64,
          nfc$ntf_addars_msg_reserved_65);
*DECK DECK=NFT$NTF_ADD_ACC_REM_SYS_RESP EXPAND=FALSE

  TYPE
    nft$ntf_add_acc_rem_sys_resp = packed record
      length_indicated: boolean,
      param: nft$ntf_add_ars_resp_parameters,
    recend,

    nft$ntf_add_ars_resp_parameters = (nfc$null_parameter,
          nfc$ntf_remote_system_name, nfc$ntf_logical_line_number,
          nfc$ntf_acc_remote_system_name, nfc$response_code,
          nfc$ntf_addars_resp_reserved_5, nfc$ntf_addars_resp_reserved_6,
          nfc$ntf_addars_resp_reserved_7, nfc$ntf_addars_resp_reserved_8,
          nfc$ntf_addars_resp_reserved_9, nfc$ntf_addars_resp_reserved_10,
          nfc$ntf_addars_resp_reserved_11, nfc$ntf_addars_resp_reserved_12,
          nfc$ntf_addars_resp_reserved_13, nfc$ntf_addars_resp_reserved_14,
          nfc$ntf_addars_resp_reserved_15, nfc$ntf_addars_resp_reserved_16,
          nfc$ntf_addars_resp_reserved_17, nfc$ntf_addars_resp_reserved_18,
          nfc$ntf_addars_resp_reserved_19, nfc$ntf_addars_resp_reserved_20,
          nfc$ntf_addars_resp_reserved_21, nfc$ntf_addars_resp_reserved_22,
          nfc$ntf_addars_resp_reserved_23, nfc$ntf_addars_resp_reserved_24,
          nfc$ntf_addars_resp_reserved_25, nfc$ntf_addars_resp_reserved_26,
          nfc$ntf_addars_resp_reserved_27, nfc$ntf_addars_resp_reserved_28,
          nfc$ntf_addars_resp_reserved_29, nfc$ntf_addars_resp_reserved_30,
          nfc$ntf_addars_resp_reserved_31, nfc$ntf_addars_resp_reserved_32,
          nfc$ntf_addars_resp_reserved_33, nfc$ntf_addars_resp_reserved_34,
          nfc$ntf_addars_resp_reserved_35, nfc$ntf_addars_resp_reserved_36,
          nfc$ntf_addars_resp_reserved_37, nfc$ntf_addars_resp_reserved_38,
          nfc$ntf_addars_resp_reserved_39, nfc$ntf_addars_resp_reserved_40,
          nfc$ntf_addars_resp_reserved_41, nfc$ntf_addars_resp_reserved_42,
          nfc$ntf_addars_resp_reserved_43, nfc$ntf_addars_resp_reserved_44,
          nfc$ntf_addars_resp_reserved_45, nfc$ntf_addars_resp_reserved_46,
          nfc$ntf_addars_resp_reserved_47, nfc$ntf_addars_resp_reserved_48,
          nfc$ntf_addars_resp_reserved_49, nfc$ntf_addars_resp_reserved_50,
          nfc$ntf_addars_resp_reserved_51, nfc$ntf_addars_resp_reserved_52,
          nfc$ntf_addars_resp_reserved_53, nfc$ntf_addars_resp_reserved_54,
          nfc$ntf_addars_resp_reserved_55, nfc$ntf_addars_resp_reserved_56,
          nfc$ntf_addars_resp_reserved_57, nfc$ntf_addars_resp_reserved_58,
          nfc$ntf_addars_resp_reserved_59, nfc$ntf_addars_resp_reserved_60,
          nfc$ntf_addars_resp_reserved_61, nfc$ntf_addars_resp_reserved_62,
          nfc$ntf_addars_resp_reserved_63, nfc$ntf_addars_resp_reserved_64,
          nfc$ntf_addars_resp_reserved_65);
*DECK DECK=NFT$NTF_ADD_ARS_RESPONSE_CODES EXPAND=FALSE

  TYPE
    nft$ntf_add_ars_response_codes = (nfc$message_accepted,
          nfc$ntf_remote_system_not_found, nfc$ntf_logical_line_not_found,
          nfc$ntf_dup_defs_do_not_match, nfc$ntf_remote_sys_not_listed);
*DECK DECK=NFT$NTF_ADD_REMOTE_SYS_MSG EXPAND=FALSE

  TYPE
    nft$ntf_add_remote_sys_msg = packed record
      length_indicated: boolean,
      param: nft$ntf_add_rs_msg_parameters,
    recend,

    nft$ntf_add_rs_msg_parameters = (nfc$null_parameter,
          nfc$ntf_remote_system_name, nfc$ntf_protocol,
          nfc$ntf_logical_line_number, nfc$ntf_line_speed, nfc$ntf_line_name,
          nfc$ntf_authority_level, nfc$ntf_terminal_user_procedure,
          nfc$ntf_wait_a_bit, nfc$ntf_inactivity_timer,
          nfc$ntf_positive_acknowledge, nfc$ntf_default_job_destination,
          nfc$ntf_default_file_destin, nfc$ntf_store_forward_destin,
          nfc$ntf_remote_system_type, nfc$ntf_route_back_position,
          nfc$ntf_request_perm_retry, nfc$ntf_local_system_name,
          nfc$ntf_addrs_msg_reserved_18, nfc$ntf_addrs_msg_reserved_19,
          nfc$ntf_addrs_msg_reserved_20, nfc$ntf_addrs_msg_reserved_21,
          nfc$ntf_addrs_msg_reserved_22, nfc$ntf_addrs_msg_reserved_23,
          nfc$ntf_addrs_msg_reserved_24, nfc$ntf_addrs_msg_reserved_25,
          nfc$ntf_addrs_msg_reserved_26, nfc$ntf_addrs_msg_reserved_27,
          nfc$ntf_addrs_msg_reserved_28, nfc$ntf_addrs_msg_reserved_29,
          nfc$ntf_addrs_msg_reserved_30, nfc$ntf_addrs_msg_reserved_31,
          nfc$ntf_addrs_msg_reserved_32, nfc$ntf_addrs_msg_reserved_33,
          nfc$ntf_addrs_msg_reserved_34, nfc$ntf_addrs_msg_reserved_35,
          nfc$ntf_addrs_msg_reserved_36, nfc$ntf_addrs_msg_reserved_37,
          nfc$ntf_addrs_msg_reserved_38, nfc$ntf_addrs_msg_reserved_39,
          nfc$ntf_addrs_msg_reserved_40, nfc$ntf_addrs_msg_reserved_41,
          nfc$ntf_addrs_msg_reserved_42, nfc$ntf_addrs_msg_reserved_43,
          nfc$ntf_addrs_msg_reserved_44, nfc$ntf_addrs_msg_reserved_45,
          nfc$ntf_addrs_msg_reserved_46, nfc$ntf_addrs_msg_reserved_47,
          nfc$ntf_addrs_msg_reserved_48, nfc$ntf_addrs_msg_reserved_49,
          nfc$ntf_addrs_msg_reserved_50, nfc$ntf_addrs_msg_reserved_51,
          nfc$ntf_addrs_msg_reserved_52, nfc$ntf_addrs_msg_reserved_53,
          nfc$ntf_addrs_msg_reserved_54, nfc$ntf_addrs_msg_reserved_55,
          nfc$ntf_addrs_msg_reserved_56, nfc$ntf_addrs_msg_reserved_57,
          nfc$ntf_addrs_msg_reserved_58, nfc$ntf_addrs_msg_reserved_59,
          nfc$ntf_addrs_msg_reserved_60, nfc$ntf_addrs_msg_reserved_61,
          nfc$ntf_addrs_msg_reserved_62, nfc$ntf_addrs_msg_reserved_63,
          nfc$ntf_addrs_msg_reserved_64, nfc$ntf_addrs_msg_reserved_65);
*DECK DECK=NFT$NTF_ADD_REMOTE_SYS_RESP EXPAND=FALSE

  TYPE
    nft$ntf_add_remote_sys_resp = packed record
      length_indicated: boolean,
      param: nft$ntf_add_rs_resp_parameters,
    recend,

    nft$ntf_add_rs_resp_parameters = (nfc$null_parameter,
          nfc$ntf_remote_system_name, nfc$ntf_logical_line_number,
          nfc$response_code, nfc$ntf_addrs_resp_reserved_4,
          nfc$ntf_addrs_resp_reserved_5, nfc$ntf_addrs_resp_reserved_6,
          nfc$ntf_addrs_resp_reserved_7, nfc$ntf_addrs_resp_reserved_8,
          nfc$ntf_addrs_resp_reserved_9, nfc$ntf_addrs_resp_reserved_10,
          nfc$ntf_addrs_resp_reserved_11, nfc$ntf_addrs_resp_reserved_12,
          nfc$ntf_addrs_resp_reserved_13, nfc$ntf_addrs_resp_reserved_14,
          nfc$ntf_addrs_resp_reserved_15, nfc$ntf_addrs_resp_reserved_16,
          nfc$ntf_addrs_resp_reserved_17, nfc$ntf_addrs_resp_reserved_18,
          nfc$ntf_addrs_resp_reserved_19, nfc$ntf_addrs_resp_reserved_20,
          nfc$ntf_addrs_resp_reserved_21, nfc$ntf_addrs_resp_reserved_22,
          nfc$ntf_addrs_resp_reserved_23, nfc$ntf_addrs_resp_reserved_24,
          nfc$ntf_addrs_resp_reserved_25, nfc$ntf_addrs_resp_reserved_26,
          nfc$ntf_addrs_resp_reserved_27, nfc$ntf_addrs_resp_reserved_28,
          nfc$ntf_addrs_resp_reserved_29, nfc$ntf_addrs_resp_reserved_30,
          nfc$ntf_addrs_resp_reserved_31, nfc$ntf_addrs_resp_reserved_32,
          nfc$ntf_addrs_resp_reserved_33, nfc$ntf_addrs_resp_reserved_34,
          nfc$ntf_addrs_resp_reserved_35, nfc$ntf_addrs_resp_reserved_36,
          nfc$ntf_addrs_resp_reserved_37, nfc$ntf_addrs_resp_reserved_38,
          nfc$ntf_addrs_resp_reserved_39, nfc$ntf_addrs_resp_reserved_40,
          nfc$ntf_addrs_resp_reserved_41, nfc$ntf_addrs_resp_reserved_42,
          nfc$ntf_addrs_resp_reserved_43, nfc$ntf_addrs_resp_reserved_44,
          nfc$ntf_addrs_resp_reserved_45, nfc$ntf_addrs_resp_reserved_46,
          nfc$ntf_addrs_resp_reserved_47, nfc$ntf_addrs_resp_reserved_48,
          nfc$ntf_addrs_resp_reserved_49, nfc$ntf_addrs_resp_reserved_50,
          nfc$ntf_addrs_resp_reserved_51, nfc$ntf_addrs_resp_reserved_52,
          nfc$ntf_addrs_resp_reserved_53, nfc$ntf_addrs_resp_reserved_54,
          nfc$ntf_addrs_resp_reserved_55, nfc$ntf_addrs_resp_reserved_56,
          nfc$ntf_addrs_resp_reserved_57, nfc$ntf_addrs_resp_reserved_58,
          nfc$ntf_addrs_resp_reserved_59, nfc$ntf_addrs_resp_reserved_60,
          nfc$ntf_addrs_resp_reserved_61, nfc$ntf_addrs_resp_reserved_62,
          nfc$ntf_addrs_resp_reserved_63, nfc$ntf_addrs_resp_reserved_64,
          nfc$ntf_addrs_resp_reserved_65);
*DECK DECK=NFT$NTF_ADD_RS_RESPONSE_CODES EXPAND=FALSE

  TYPE
    nft$ntf_add_rs_response_codes = (nfc$message_accepted,
          nfc$ntf_dup_defs_do_not_match, nfc$ntf_dup_logical_line_number,
          nfc$ntf_dup_rs_name_in_domain, nfc$ntf_remote_sys_not_listed);
*DECK DECK=NFT$NTF_AUTHORITY_LEVEL EXPAND=FALSE

  TYPE
    nft$ntf_authority_level = (nfc$ntf_none, nfc$ntf_network, nfc$ntf_job);
*DECK DECK=NFT$NTF_COMMAND_KIND EXPAND=FALSE

  TYPE
    nft$ntf_command_kind = (nfc$ntf_command, nfc$ntf_message, nfc$ntf_signon,
          nfc$ntf_signoff, nfc$ntf_change_tdp, nfc$ntf_operator_message,
          nfc$ntf_user_message, nfc$ntf_client_command);

*DECK DECK=NFT$NTF_COMMAND_TEXT EXPAND=FALSE

  CONST
    nfc$ntf_max_command_text_size = 255;

  TYPE
    nft$ntf_command_text = string (nfc$ntf_max_command_text_size);
*DECK DECK=NFT$NTF_DELETE_USER_MSG EXPAND=FALSE

  TYPE
    nft$ntf_delete_user_msg = packed record
      length_indicated: boolean,
      param: nft$ntf_delete_user_msg_params,
    recend,

    nft$ntf_delete_user_msg_params = (nfc$null_parameter,
          nfc$ntf_remote_system_name, nfc$ntf_family_name, nfc$ntf_user_name,
          nfc$ntf_delu_msg_reserved_4, nfc$ntf_delu_msg_reserved_5,
          nfc$ntf_delu_msg_reserved_6, nfc$ntf_delu_msg_reserved_7,
          nfc$ntf_delu_msg_reserved_8, nfc$ntf_delu_msg_reserved_9,
          nfc$ntf_delu_msg_reserved_10, nfc$ntf_delu_msg_reserved_11,
          nfc$ntf_delu_msg_reserved_12, nfc$ntf_delu_msg_reserved_13,
          nfc$ntf_delu_msg_reserved_14, nfc$ntf_delu_msg_reserved_15,
          nfc$ntf_delu_msg_reserved_16, nfc$ntf_delu_msg_reserved_17,
          nfc$ntf_delu_msg_reserved_18, nfc$ntf_delu_msg_reserved_19,
          nfc$ntf_delu_msg_reserved_20, nfc$ntf_delu_msg_reserved_21,
          nfc$ntf_delu_msg_reserved_22, nfc$ntf_delu_msg_reserved_23,
          nfc$ntf_delu_msg_reserved_24, nfc$ntf_delu_msg_reserved_25,
          nfc$ntf_delu_msg_reserved_26, nfc$ntf_delu_msg_reserved_27,
          nfc$ntf_delu_msg_reserved_28, nfc$ntf_delu_msg_reserved_29,
          nfc$ntf_delu_msg_reserved_30, nfc$ntf_delu_msg_reserved_31,
          nfc$ntf_delu_msg_reserved_32, nfc$ntf_delu_msg_reserved_33,
          nfc$ntf_delu_msg_reserved_34, nfc$ntf_delu_msg_reserved_35,
          nfc$ntf_delu_msg_reserved_36, nfc$ntf_delu_msg_reserved_37,
          nfc$ntf_delu_msg_reserved_38, nfc$ntf_delu_msg_reserved_39,
          nfc$ntf_delu_msg_reserved_40, nfc$ntf_delu_msg_reserved_41,
          nfc$ntf_delu_msg_reserved_42, nfc$ntf_delu_msg_reserved_43,
          nfc$ntf_delu_msg_reserved_44, nfc$ntf_delu_msg_reserved_45,
          nfc$ntf_delu_msg_reserved_46, nfc$ntf_delu_msg_reserved_47,
          nfc$ntf_delu_msg_reserved_48, nfc$ntf_delu_msg_reserved_49,
          nfc$ntf_delu_msg_reserved_50, nfc$ntf_delu_msg_reserved_51,
          nfc$ntf_delu_msg_reserved_52, nfc$ntf_delu_msg_reserved_53,
          nfc$ntf_delu_msg_reserved_54, nfc$ntf_delu_msg_reserved_55,
          nfc$ntf_delu_msg_reserved_56, nfc$ntf_delu_msg_reserved_57,
          nfc$ntf_delu_msg_reserved_58, nfc$ntf_delu_msg_reserved_59,
          nfc$ntf_delu_msg_reserved_60, nfc$ntf_delu_msg_reserved_61,
          nfc$ntf_delu_msg_reserved_62, nfc$ntf_delu_msg_reserved_63,
          nfc$ntf_delu_msg_reserved_64, nfc$ntf_delu_msg_reserved_65);
*DECK DECK=NFT$NTF_DELETE_USER_RESP EXPAND=FALSE

  TYPE
    nft$ntf_delete_user_resp = packed record
      length_indicated: boolean,
      param: nft$ntf_delete_user_resp_params,
    recend,

    nft$ntf_delete_user_resp_params = (nfc$null_parameter,
          nfc$ntf_remote_system_name, nfc$response_code,
          nfc$ntf_delu_reserved_3, nfc$ntf_delu_resp_reserved_4,
          nfc$ntf_delu_resp_reserved_5, nfc$ntf_delu_resp_reserved_6,
          nfc$ntf_delu_resp_reserved_7, nfc$ntf_delu_resp_reserved_8,
          nfc$ntf_delu_resp_reserved_9, nfc$ntf_delu_resp_reserved_10,
          nfc$ntf_delu_resp_reserved_11, nfc$ntf_delu_resp_reserved_12,
          nfc$ntf_delu_resp_reserved_13, nfc$ntf_delu_resp_reserved_14,
          nfc$ntf_delu_resp_reserved_15, nfc$ntf_delu_resp_reserved_16,
          nfc$ntf_delu_resp_reserved_17, nfc$ntf_delu_resp_reserved_18,
          nfc$ntf_delu_resp_reserved_19, nfc$ntf_delu_resp_reserved_20,
          nfc$ntf_delu_resp_reserved_21, nfc$ntf_delu_resp_reserved_22,
          nfc$ntf_delu_resp_reserved_23, nfc$ntf_delu_resp_reserved_24,
          nfc$ntf_delu_resp_reserved_25, nfc$ntf_delu_resp_reserved_26,
          nfc$ntf_delu_resp_reserved_27, nfc$ntf_delu_resp_reserved_28,
          nfc$ntf_delu_resp_reserved_29, nfc$ntf_delu_resp_reserved_30,
          nfc$ntf_delu_resp_reserved_31, nfc$ntf_delu_resp_reserved_32,
          nfc$ntf_delu_resp_reserved_33, nfc$ntf_delu_resp_reserved_34,
          nfc$ntf_delu_resp_reserved_35, nfc$ntf_delu_resp_reserved_36,
          nfc$ntf_delu_resp_reserved_37, nfc$ntf_delu_resp_reserved_38,
          nfc$ntf_delu_resp_reserved_39, nfc$ntf_delu_resp_reserved_40,
          nfc$ntf_delu_resp_reserved_41, nfc$ntf_delu_resp_reserved_42,
          nfc$ntf_delu_resp_reserved_43, nfc$ntf_delu_resp_reserved_44,
          nfc$ntf_delu_resp_reserved_45, nfc$ntf_delu_resp_reserved_46,
          nfc$ntf_delu_resp_reserved_47, nfc$ntf_delu_resp_reserved_48,
          nfc$ntf_delu_resp_reserved_49, nfc$ntf_delu_resp_reserved_50,
          nfc$ntf_delu_resp_reserved_51, nfc$ntf_delu_resp_reserved_52,
          nfc$ntf_delu_resp_reserved_53, nfc$ntf_delu_resp_reserved_54,
          nfc$ntf_delu_resp_reserved_55, nfc$ntf_delu_resp_reserved_56,
          nfc$ntf_delu_resp_reserved_57, nfc$ntf_delu_resp_reserved_58,
          nfc$ntf_delu_resp_reserved_59, nfc$ntf_delu_resp_reserved_60,
          nfc$ntf_delu_resp_reserved_61, nfc$ntf_delu_resp_reserved_62,
          nfc$ntf_delu_resp_reserved_63, nfc$ntf_delu_resp_reserved_64,
          nfc$ntf_delu_resp_reserved_65);
*DECK DECK=NFT$NTF_DELETE_USER_RESP_CODES EXPAND=FALSE

  TYPE
    nft$ntf_delete_user_resp_codes = (nfc$message_accepted,
          nfc$ntf_remote_system_not_found, nfc$ntf_operator_not_connected);
*DECK DECK=NFT$NTF_DEL_REMOTE_SYS_MSG EXPAND=FALSE

  TYPE
    nft$ntf_del_remote_sys_msg = packed record
      length_indicated: boolean,
      param: nft$ntf_del_rs_msg_parameters,
    recend,

    nft$ntf_del_rs_msg_parameters = (nfc$null_parameter,
          nfc$ntf_remote_system_name, nfc$ntf_logical_line_number,
          nfc$ntf_delrs_msg_reserved_3, nfc$ntf_delrs_msg_reserved_4,
          nfc$ntf_delrs_msg_reserved_5, nfc$ntf_delrs_msg_reserved_6,
          nfc$ntf_delrs_msg_reserved_7, nfc$ntf_delrs_msg_reserved_8,
          nfc$ntf_delrs_msg_reserved_9, nfc$ntf_delrs_msg_reserved_10,
          nfc$ntf_delrs_msg_reserved_11, nfc$ntf_delrs_msg_reserved_12,
          nfc$ntf_delrs_msg_reserved_13, nfc$ntf_delrs_msg_reserved_14,
          nfc$ntf_delrs_msg_reserved_15, nfc$ntf_delrs_msg_reserved_16,
          nfc$ntf_delrs_msg_reserved_17, nfc$ntf_delrs_msg_reserved_18,
          nfc$ntf_delrs_msg_reserved_19, nfc$ntf_delrs_msg_reserved_20,
          nfc$ntf_delrs_msg_reserved_21, nfc$ntf_delrs_msg_reserved_22,
          nfc$ntf_delrs_msg_reserved_23, nfc$ntf_delrs_msg_reserved_24,
          nfc$ntf_delrs_msg_reserved_25, nfc$ntf_delrs_msg_reserved_26,
          nfc$ntf_delrs_msg_reserved_27, nfc$ntf_delrs_msg_reserved_28,
          nfc$ntf_delrs_msg_reserved_29, nfc$ntf_delrs_msg_reserved_30,
          nfc$ntf_delrs_msg_reserved_31, nfc$ntf_delrs_msg_reserved_32,
          nfc$ntf_delrs_msg_reserved_33, nfc$ntf_delrs_msg_reserved_34,
          nfc$ntf_delrs_msg_reserved_35, nfc$ntf_delrs_msg_reserved_36,
          nfc$ntf_delrs_msg_reserved_37, nfc$ntf_delrs_msg_reserved_38,
          nfc$ntf_delrs_msg_reserved_39, nfc$ntf_delrs_msg_reserved_40,
          nfc$ntf_delrs_msg_reserved_41, nfc$ntf_delrs_msg_reserved_42,
          nfc$ntf_delrs_msg_reserved_43, nfc$ntf_delrs_msg_reserved_44,
          nfc$ntf_delrs_msg_reserved_45, nfc$ntf_delrs_msg_reserved_46,
          nfc$ntf_delrs_msg_reserved_47, nfc$ntf_delrs_msg_reserved_48,
          nfc$ntf_delrs_msg_reserved_49, nfc$ntf_delrs_msg_reserved_50,
          nfc$ntf_delrs_msg_reserved_51, nfc$ntf_delrs_msg_reserved_52,
          nfc$ntf_delrs_msg_reserved_53, nfc$ntf_delrs_msg_reserved_54,
          nfc$ntf_delrs_msg_reserved_55, nfc$ntf_delrs_msg_reserved_56,
          nfc$ntf_delrs_msg_reserved_57, nfc$ntf_delrs_msg_reserved_58,
          nfc$ntf_delrs_msg_reserved_59, nfc$ntf_delrs_msg_reserved_60,
          nfc$ntf_delrs_msg_reserved_61, nfc$ntf_delrs_msg_reserved_62,
          nfc$ntf_delrs_msg_reserved_63, nfc$ntf_delrs_msg_reserved_64,
          nfc$ntf_delrs_msg_reserved_65);
*DECK DECK=NFT$NTF_DEL_REMOTE_SYS_RESP EXPAND=FALSE

  TYPE
    nft$ntf_del_remote_sys_resp = packed record
      length_indicated: boolean,
      param: nft$ntf_del_rs_resp_parameters,
    recend,

    nft$ntf_del_rs_resp_parameters = (nfc$null_parameter,
          nfc$ntf_remote_system_name, nfc$ntf_logical_line_number,
          nfc$response_code, nfc$ntf_delrs_resp_reserved_4,
          nfc$ntf_delrs_resp_reserved_5, nfc$ntf_delrs_resp_reserved_6,
          nfc$ntf_delrs_resp_reserved_7, nfc$ntf_delrs_resp_reserved_8,
          nfc$ntf_delrs_resp_reserved_9, nfc$ntf_delrs_resp_reserved_10,
          nfc$ntf_delrs_resp_reserved_11, nfc$ntf_delrs_resp_reserved_12,
          nfc$ntf_delrs_resp_reserved_13, nfc$ntf_delrs_resp_reserved_14,
          nfc$ntf_delrs_resp_reserved_15, nfc$ntf_delrs_resp_reserved_16,
          nfc$ntf_delrs_resp_reserved_17, nfc$ntf_delrs_resp_reserved_18,
          nfc$ntf_delrs_resp_reserved_19, nfc$ntf_delrs_resp_reserved_20,
          nfc$ntf_delrs_resp_reserved_21, nfc$ntf_delrs_resp_reserved_22,
          nfc$ntf_delrs_resp_reserved_23, nfc$ntf_delrs_resp_reserved_24,
          nfc$ntf_delrs_resp_reserved_25, nfc$ntf_delrs_resp_reserved_26,
          nfc$ntf_delrs_resp_reserved_27, nfc$ntf_delrs_resp_reserved_28,
          nfc$ntf_delrs_resp_reserved_29, nfc$ntf_delrs_resp_reserved_30,
          nfc$ntf_delrs_resp_reserved_31, nfc$ntf_delrs_resp_reserved_32,
          nfc$ntf_delrs_resp_reserved_33, nfc$ntf_delrs_resp_reserved_34,
          nfc$ntf_delrs_resp_reserved_35, nfc$ntf_delrs_resp_reserved_36,
          nfc$ntf_delrs_resp_reserved_37, nfc$ntf_delrs_resp_reserved_38,
          nfc$ntf_delrs_resp_reserved_39, nfc$ntf_delrs_resp_reserved_40,
          nfc$ntf_delrs_resp_reserved_41, nfc$ntf_delrs_resp_reserved_42,
          nfc$ntf_delrs_resp_reserved_43, nfc$ntf_delrs_resp_reserved_44,
          nfc$ntf_delrs_resp_reserved_45, nfc$ntf_delrs_resp_reserved_46,
          nfc$ntf_delrs_resp_reserved_47, nfc$ntf_delrs_resp_reserved_48,
          nfc$ntf_delrs_resp_reserved_49, nfc$ntf_delrs_resp_reserved_50,
          nfc$ntf_delrs_resp_reserved_51, nfc$ntf_delrs_resp_reserved_52,
          nfc$ntf_delrs_resp_reserved_53, nfc$ntf_delrs_resp_reserved_54,
          nfc$ntf_delrs_resp_reserved_55, nfc$ntf_delrs_resp_reserved_56,
          nfc$ntf_delrs_resp_reserved_57, nfc$ntf_delrs_resp_reserved_58,
          nfc$ntf_delrs_resp_reserved_59, nfc$ntf_delrs_resp_reserved_60,
          nfc$ntf_delrs_resp_reserved_61, nfc$ntf_delrs_resp_reserved_62,
          nfc$ntf_delrs_resp_reserved_63, nfc$ntf_delrs_resp_reserved_64,
          nfc$ntf_delrs_resp_reserved_65);
*DECK DECK=NFT$NTF_DEL_RS_RESPONSE_CODES EXPAND=FALSE

  TYPE
    nft$ntf_del_rs_response_codes = (nfc$message_accepted,
          nfc$ntf_remote_system_not_found);
*DECK DECK=NFT$NTF_GET_REM_SYS_NAMES_DATA EXPAND=FALSE

  TYPE
    nft$ntf_get_rem_sys_names_data = packed record
      length_indicated: boolean,
      param: nft$ntf_get_rsn_data_parameters,
    recend,

    nft$ntf_get_rsn_data_parameters = (nfc$null_parameter, nfc$response_code,
          nfc$ntf_remote_system_count, nfc$ntf_remote_system_data,
          nfc$ntf_getrsn_data_reserved_4, nfc$ntf_getrsn_data_reserved_5,
          nfc$ntf_getrsn_data_reserved_6, nfc$ntf_getrsn_data_reserved_7,
          nfc$ntf_getrsn_data_reserved_8, nfc$ntf_getrsn_data_reserved_9,
          nfc$ntf_getrsn_data_reserved_10, nfc$ntf_getrsn_data_reserved_11,
          nfc$ntf_getrsn_data_reserved_12, nfc$ntf_getrsn_data_reserved_13,
          nfc$ntf_getrsn_data_reserved_14, nfc$ntf_getrsn_data_reserved_15,
          nfc$ntf_getrsn_data_reserved_16, nfc$ntf_getrsn_data_reserved_17,
          nfc$ntf_getrsn_data_reserved_18, nfc$ntf_getrsn_data_reserved_19,
          nfc$ntf_getrsn_data_reserved_20, nfc$ntf_getrsn_data_reserved_21,
          nfc$ntf_getrsn_data_reserved_22, nfc$ntf_getrsn_data_reserved_23,
          nfc$ntf_getrsn_data_reserved_24, nfc$ntf_getrsn_data_reserved_25,
          nfc$ntf_getrsn_data_reserved_26, nfc$ntf_getrsn_data_reserved_27,
          nfc$ntf_getrsn_data_reserved_28, nfc$ntf_getrsn_data_reserved_29,
          nfc$ntf_getrsn_data_reserved_30, nfc$ntf_getrsn_data_reserved_31,
          nfc$ntf_getrsn_data_reserved_32, nfc$ntf_getrsn_data_reserved_33,
          nfc$ntf_getrsn_data_reserved_34, nfc$ntf_getrsn_data_reserved_35,
          nfc$ntf_getrsn_data_reserved_36, nfc$ntf_getrsn_data_reserved_37,
          nfc$ntf_getrsn_data_reserved_38, nfc$ntf_getrsn_data_reserved_39,
          nfc$ntf_getrsn_data_reserved_40, nfc$ntf_getrsn_data_reserved_41,
          nfc$ntf_getrsn_data_reserved_42, nfc$ntf_getrsn_data_reserved_43,
          nfc$ntf_getrsn_data_reserved_44, nfc$ntf_getrsn_data_reserved_45,
          nfc$ntf_getrsn_data_reserved_46, nfc$ntf_getrsn_data_reserved_47,
          nfc$ntf_getrsn_data_reserved_48, nfc$ntf_getrsn_data_reserved_49,
          nfc$ntf_getrsn_data_reserved_50, nfc$ntf_getrsn_data_reserved_51,
          nfc$ntf_getrsn_data_reserved_52, nfc$ntf_getrsn_data_reserved_53,
          nfc$ntf_getrsn_data_reserved_54, nfc$ntf_getrsn_data_reserved_55,
          nfc$ntf_getrsn_data_reserved_56, nfc$ntf_getrsn_data_reserved_57,
          nfc$ntf_getrsn_data_reserved_58, nfc$ntf_getrsn_data_reserved_59,
          nfc$ntf_getrsn_data_reserved_60, nfc$ntf_getrsn_data_reserved_61,
          nfc$ntf_getrsn_data_reserved_62, nfc$ntf_getrsn_data_reserved_63,
          nfc$ntf_getrsn_data_reserved_64, nfc$ntf_getrsn_data_reserved_65);
*DECK DECK=NFT$NTF_GET_REM_SYS_NAMES_MSG EXPAND=FALSE

  TYPE
    nft$ntf_get_rem_sys_names_msg = packed record
      length_indicated: boolean,
      param: nft$ntf_get_rsn_msg_parameters,
    recend,

    nft$ntf_get_rsn_msg_parameters = (nfc$null_parameter,
          nfc$ntf_remote_system_name, nfc$ntf_logical_line_number,
          nfc$ntf_remote_system_kind, nfc$ntf_getrsn_msg_reserved_4,
          nfc$ntf_getrsn_msg_reserved_5, nfc$ntf_getrsn_msg_reserved_6,
          nfc$ntf_getrsn_msg_reserved_7, nfc$ntf_getrsn_msg_reserved_8,
          nfc$ntf_getrsn_msg_reserved_9, nfc$ntf_getrsn_msg_reserved_10,
          nfc$ntf_getrsn_msg_reserved_11, nfc$ntf_getrsn_msg_reserved_12,
          nfc$ntf_getrsn_msg_reserved_13, nfc$ntf_getrsn_msg_reserved_14,
          nfc$ntf_getrsn_msg_reserved_15, nfc$ntf_getrsn_msg_reserved_16,
          nfc$ntf_getrsn_msg_reserved_17, nfc$ntf_getrsn_msg_reserved_18,
          nfc$ntf_getrsn_msg_reserved_19, nfc$ntf_getrsn_msg_reserved_20,
          nfc$ntf_getrsn_msg_reserved_21, nfc$ntf_getrsn_msg_reserved_22,
          nfc$ntf_getrsn_msg_reserved_23, nfc$ntf_getrsn_msg_reserved_24,
          nfc$ntf_getrsn_msg_reserved_25, nfc$ntf_getrsn_msg_reserved_26,
          nfc$ntf_getrsn_msg_reserved_27, nfc$ntf_getrsn_msg_reserved_28,
          nfc$ntf_getrsn_msg_reserved_29, nfc$ntf_getrsn_msg_reserved_30,
          nfc$ntf_getrsn_msg_reserved_31, nfc$ntf_getrsn_msg_reserved_32,
          nfc$ntf_getrsn_msg_reserved_33, nfc$ntf_getrsn_msg_reserved_34,
          nfc$ntf_getrsn_msg_reserved_35, nfc$ntf_getrsn_msg_reserved_36,
          nfc$ntf_getrsn_msg_reserved_37, nfc$ntf_getrsn_msg_reserved_38,
          nfc$ntf_getrsn_msg_reserved_39, nfc$ntf_getrsn_msg_reserved_40,
          nfc$ntf_getrsn_msg_reserved_41, nfc$ntf_getrsn_msg_reserved_42,
          nfc$ntf_getrsn_msg_reserved_43, nfc$ntf_getrsn_msg_reserved_44,
          nfc$ntf_getrsn_msg_reserved_45, nfc$ntf_getrsn_msg_reserved_46,
          nfc$ntf_getrsn_msg_reserved_47, nfc$ntf_getrsn_msg_reserved_48,
          nfc$ntf_getrsn_msg_reserved_49, nfc$ntf_getrsn_msg_reserved_50,
          nfc$ntf_getrsn_msg_reserved_51, nfc$ntf_getrsn_msg_reserved_52,
          nfc$ntf_getrsn_msg_reserved_53, nfc$ntf_getrsn_msg_reserved_54,
          nfc$ntf_getrsn_msg_reserved_55, nfc$ntf_getrsn_msg_reserved_56,
          nfc$ntf_getrsn_msg_reserved_57, nfc$ntf_getrsn_msg_reserved_58,
          nfc$ntf_getrsn_msg_reserved_59, nfc$ntf_getrsn_msg_reserved_60,
          nfc$ntf_getrsn_msg_reserved_61, nfc$ntf_getrsn_msg_reserved_62,
          nfc$ntf_getrsn_msg_reserved_63, nfc$ntf_getrsn_msg_reserved_64,
          nfc$ntf_getrsn_msg_reserved_65);
*DECK DECK=NFT$NTF_GET_REM_SYS_OPTS_DATA EXPAND=FALSE

  TYPE
    nft$ntf_get_rem_sys_opts_data = packed record
      length_indicated: boolean,
      param: nft$ntf_get_rso_data_parameters,
    recend,

    nft$ntf_get_rso_data_parameters = (nfc$null_parameter,
          nfc$ntf_remote_system_name, nfc$response_code,
          nfc$ntf_control_facility_name, nfc$ntf_protocol,
          nfc$ntf_authority_level, nfc$ntf_wait_a_bit,
          nfc$ntf_inactivity_timer, nfc$ntf_positive_acknowledge,
          nfc$ntf_default_job_destination, nfc$ntf_default_file_destin,
          nfc$ntf_store_forward_destin, nfc$ntf_logical_line_count,
          nfc$ntf_logical_line_data, nfc$ntf_batch_stream_count,
          nfc$ntf_batch_stream_names, nfc$ntf_remote_system_type,
          nfc$ntf_route_back_position, nfc$ntf_request_perm_retry,
          nfc$ntf_local_system_name, nfc$ntf_getrso_data_reserved_20,
          nfc$ntf_getrso_data_reserved_21, nfc$ntf_getrso_data_reserved_22,
          nfc$ntf_getrso_data_reserved_23, nfc$ntf_getrso_data_reserved_24,
          nfc$ntf_getrso_data_reserved_25, nfc$ntf_getrso_data_reserved_26,
          nfc$ntf_getrso_data_reserved_27, nfc$ntf_getrso_data_reserved_28,
          nfc$ntf_getrso_data_reserved_29, nfc$ntf_getrso_data_reserved_30,
          nfc$ntf_getrso_data_reserved_31, nfc$ntf_getrso_data_reserved_32,
          nfc$ntf_getrso_data_reserved_33, nfc$ntf_getrso_data_reserved_34,
          nfc$ntf_getrso_data_reserved_35, nfc$ntf_getrso_data_reserved_36,
          nfc$ntf_getrso_data_reserved_37, nfc$ntf_getrso_data_reserved_38,
          nfc$ntf_getrso_data_reserved_39, nfc$ntf_getrso_data_reserved_40,
          nfc$ntf_getrso_data_reserved_41, nfc$ntf_getrso_data_reserved_42,
          nfc$ntf_getrso_data_reserved_43, nfc$ntf_getrso_data_reserved_44,
          nfc$ntf_getrso_data_reserved_45, nfc$ntf_getrso_data_reserved_46,
          nfc$ntf_getrso_data_reserved_47, nfc$ntf_getrso_data_reserved_48,
          nfc$ntf_getrso_data_reserved_49, nfc$ntf_getrso_data_reserved_50,
          nfc$ntf_getrso_data_reserved_51, nfc$ntf_getrso_data_reserved_52,
          nfc$ntf_getrso_data_reserved_53, nfc$ntf_getrso_data_reserved_54,
          nfc$ntf_getrso_data_reserved_55, nfc$ntf_getrso_data_reserved_56,
          nfc$ntf_getrso_data_reserved_57, nfc$ntf_getrso_data_reserved_58,
          nfc$ntf_getrso_data_reserved_59, nfc$ntf_getrso_data_reserved_60,
          nfc$ntf_getrso_data_reserved_61, nfc$ntf_getrso_data_reserved_62,
          nfc$ntf_getrso_data_reserved_63, nfc$ntf_getrso_data_reserved_64,
          nfc$ntf_getrso_data_reserved_65);
*DECK DECK=NFT$NTF_GET_REM_SYS_OPTS_MSG EXPAND=FALSE

  TYPE
    nft$ntf_get_rem_sys_opts_msg = packed record
      length_indicated: boolean,
      param: nft$ntf_get_rso_msg_parameters,
    recend,

    nft$ntf_get_rso_msg_parameters = (nfc$null_parameter,
          nfc$ntf_remote_system_name, nfc$ntf_getrso_msg_reserved_2,
          nfc$ntf_getrso_msg_reserved_3, nfc$ntf_getrso_msg_reserved_4,
          nfc$ntf_getrso_msg_reserved_5, nfc$ntf_getrso_msg_reserved_6,
          nfc$ntf_getrso_msg_reserved_7, nfc$ntf_getrso_msg_reserved_8,
          nfc$ntf_getrso_msg_reserved_9, nfc$ntf_getrso_msg_reserved_10,
          nfc$ntf_getrso_msg_reserved_11, nfc$ntf_getrso_msg_reserved_12,
          nfc$ntf_getrso_msg_reserved_13, nfc$ntf_getrso_msg_reserved_14,
          nfc$ntf_getrso_msg_reserved_15, nfc$ntf_getrso_msg_reserved_16,
          nfc$ntf_getrso_msg_reserved_17, nfc$ntf_getrso_msg_reserved_18,
          nfc$ntf_getrso_msg_reserved_19, nfc$ntf_getrso_msg_reserved_20,
          nfc$ntf_getrso_msg_reserved_21, nfc$ntf_getrso_msg_reserved_22,
          nfc$ntf_getrso_msg_reserved_23, nfc$ntf_getrso_msg_reserved_24,
          nfc$ntf_getrso_msg_reserved_25, nfc$ntf_getrso_msg_reserved_26,
          nfc$ntf_getrso_msg_reserved_27, nfc$ntf_getrso_msg_reserved_28,
          nfc$ntf_getrso_msg_reserved_29, nfc$ntf_getrso_msg_reserved_30,
          nfc$ntf_getrso_msg_reserved_31, nfc$ntf_getrso_msg_reserved_32,
          nfc$ntf_getrso_msg_reserved_33, nfc$ntf_getrso_msg_reserved_34,
          nfc$ntf_getrso_msg_reserved_35, nfc$ntf_getrso_msg_reserved_36,
          nfc$ntf_getrso_msg_reserved_37, nfc$ntf_getrso_msg_reserved_38,
          nfc$ntf_getrso_msg_reserved_39, nfc$ntf_getrso_msg_reserved_40,
          nfc$ntf_getrso_msg_reserved_41, nfc$ntf_getrso_msg_reserved_42,
          nfc$ntf_getrso_msg_reserved_43, nfc$ntf_getrso_msg_reserved_44,
          nfc$ntf_getrso_msg_reserved_45, nfc$ntf_getrso_msg_reserved_46,
          nfc$ntf_getrso_msg_reserved_47, nfc$ntf_getrso_msg_reserved_48,
          nfc$ntf_getrso_msg_reserved_49, nfc$ntf_getrso_msg_reserved_50,
          nfc$ntf_getrso_msg_reserved_51, nfc$ntf_getrso_msg_reserved_52,
          nfc$ntf_getrso_msg_reserved_53, nfc$ntf_getrso_msg_reserved_54,
          nfc$ntf_getrso_msg_reserved_55, nfc$ntf_getrso_msg_reserved_56,
          nfc$ntf_getrso_msg_reserved_57, nfc$ntf_getrso_msg_reserved_58,
          nfc$ntf_getrso_msg_reserved_59, nfc$ntf_getrso_msg_reserved_60,
          nfc$ntf_getrso_msg_reserved_61, nfc$ntf_getrso_msg_reserved_62,
          nfc$ntf_getrso_msg_reserved_63, nfc$ntf_getrso_msg_reserved_64,
          nfc$ntf_getrso_msg_reserved_65);
*DECK DECK=NFT$NTF_GET_REM_SYS_STAT_DATA EXPAND=FALSE

  TYPE
    nft$ntf_get_rem_sys_stat_data = packed record
      length_indicated: boolean,
      param: nft$ntf_get_rss_data_parameters,
    recend,

    nft$ntf_get_rss_data_parameters = (nfc$null_parameter,
          nfc$ntf_remote_system_name, nfc$response_code,
          nfc$ntf_logical_line_count, nfc$ntf_remote_system_status,
          nfc$ntf_getrss_data_reserved_5, nfc$ntf_getrss_data_reserved_6,
          nfc$ntf_getrss_data_reserved_7, nfc$ntf_getrss_data_reserved_8,
          nfc$ntf_getrss_data_reserved_9, nfc$ntf_getrss_data_reserved_10,
          nfc$ntf_getrss_data_reserved_11, nfc$ntf_getrss_data_reserved_12,
          nfc$ntf_getrss_data_reserved_13, nfc$ntf_getrss_data_reserved_14,
          nfc$ntf_getrss_data_reserved_15, nfc$ntf_getrss_data_reserved_16,
          nfc$ntf_getrss_data_reserved_17, nfc$ntf_getrss_data_reserved_18,
          nfc$ntf_getrss_data_reserved_19, nfc$ntf_getrss_data_reserved_20,
          nfc$ntf_getrss_data_reserved_21, nfc$ntf_getrss_data_reserved_22,
          nfc$ntf_getrss_data_reserved_23, nfc$ntf_getrss_data_reserved_24,
          nfc$ntf_getrss_data_reserved_25, nfc$ntf_getrss_data_reserved_26,
          nfc$ntf_getrss_data_reserved_27, nfc$ntf_getrss_data_reserved_28,
          nfc$ntf_getrss_data_reserved_29, nfc$ntf_getrss_data_reserved_30,
          nfc$ntf_getrss_data_reserved_31, nfc$ntf_getrss_data_reserved_32,
          nfc$ntf_getrss_data_reserved_33, nfc$ntf_getrss_data_reserved_34,
          nfc$ntf_getrss_data_reserved_35, nfc$ntf_getrss_data_reserved_36,
          nfc$ntf_getrss_data_reserved_37, nfc$ntf_getrss_data_reserved_38,
          nfc$ntf_getrss_data_reserved_39, nfc$ntf_getrss_data_reserved_40,
          nfc$ntf_getrss_data_reserved_41, nfc$ntf_getrss_data_reserved_42,
          nfc$ntf_getrss_data_reserved_43, nfc$ntf_getrss_data_reserved_44,
          nfc$ntf_getrss_data_reserved_45, nfc$ntf_getrss_data_reserved_46,
          nfc$ntf_getrss_data_reserved_47, nfc$ntf_getrss_data_reserved_48,
          nfc$ntf_getrss_data_reserved_49, nfc$ntf_getrss_data_reserved_50,
          nfc$ntf_getrss_data_reserved_51, nfc$ntf_getrss_data_reserved_52,
          nfc$ntf_getrss_data_reserved_53, nfc$ntf_getrss_data_reserved_54,
          nfc$ntf_getrss_data_reserved_55, nfc$ntf_getrss_data_reserved_56,
          nfc$ntf_getrss_data_reserved_57, nfc$ntf_getrss_data_reserved_58,
          nfc$ntf_getrss_data_reserved_59, nfc$ntf_getrss_data_reserved_60,
          nfc$ntf_getrss_data_reserved_61, nfc$ntf_getrss_data_reserved_62,
          nfc$ntf_getrss_data_reserved_63, nfc$ntf_getrss_data_reserved_64,
          nfc$ntf_getrss_data_reserved_65);
*DECK DECK=NFT$NTF_GET_REM_SYS_STAT_MSG EXPAND=FALSE

  TYPE
    nft$ntf_get_rem_sys_stat_msg = packed record
      length_indicated: boolean,
      param: nft$ntf_get_rss_msg_parameters,
    recend,

    nft$ntf_get_rss_msg_parameters = (nfc$null_parameter,
          nfc$ntf_remote_system_name, nfc$ntf_logical_line_number,
          nfc$ntf_signon_status, nfc$ntf_getrss_msg_reserved_4,
          nfc$ntf_getrss_msg_reserved_5, nfc$ntf_getrss_msg_reserved_6,
          nfc$ntf_getrss_msg_reserved_7, nfc$ntf_getrss_msg_reserved_8,
          nfc$ntf_getrss_msg_reserved_9, nfc$ntf_getrss_msg_reserved_10,
          nfc$ntf_getrss_msg_reserved_11, nfc$ntf_getrss_msg_reserved_12,
          nfc$ntf_getrss_msg_reserved_13, nfc$ntf_getrss_msg_reserved_14,
          nfc$ntf_getrss_msg_reserved_15, nfc$ntf_getrss_msg_reserved_16,
          nfc$ntf_getrss_msg_reserved_17, nfc$ntf_getrss_msg_reserved_18,
          nfc$ntf_getrss_msg_reserved_19, nfc$ntf_getrss_msg_reserved_20,
          nfc$ntf_getrss_msg_reserved_21, nfc$ntf_getrss_msg_reserved_22,
          nfc$ntf_getrss_msg_reserved_23, nfc$ntf_getrss_msg_reserved_24,
          nfc$ntf_getrss_msg_reserved_25, nfc$ntf_getrss_msg_reserved_26,
          nfc$ntf_getrss_msg_reserved_27, nfc$ntf_getrss_msg_reserved_28,
          nfc$ntf_getrss_msg_reserved_29, nfc$ntf_getrss_msg_reserved_30,
          nfc$ntf_getrss_msg_reserved_31, nfc$ntf_getrss_msg_reserved_32,
          nfc$ntf_getrss_msg_reserved_33, nfc$ntf_getrss_msg_reserved_34,
          nfc$ntf_getrss_msg_reserved_35, nfc$ntf_getrss_msg_reserved_36,
          nfc$ntf_getrss_msg_reserved_37, nfc$ntf_getrss_msg_reserved_38,
          nfc$ntf_getrss_msg_reserved_39, nfc$ntf_getrss_msg_reserved_40,
          nfc$ntf_getrss_msg_reserved_41, nfc$ntf_getrss_msg_reserved_42,
          nfc$ntf_getrss_msg_reserved_43, nfc$ntf_getrss_msg_reserved_44,
          nfc$ntf_getrss_msg_reserved_45, nfc$ntf_getrss_msg_reserved_46,
          nfc$ntf_getrss_msg_reserved_47, nfc$ntf_getrss_msg_reserved_48,
          nfc$ntf_getrss_msg_reserved_49, nfc$ntf_getrss_msg_reserved_50,
          nfc$ntf_getrss_msg_reserved_51, nfc$ntf_getrss_msg_reserved_52,
          nfc$ntf_getrss_msg_reserved_53, nfc$ntf_getrss_msg_reserved_54,
          nfc$ntf_getrss_msg_reserved_55, nfc$ntf_getrss_msg_reserved_56,
          nfc$ntf_getrss_msg_reserved_57, nfc$ntf_getrss_msg_reserved_58,
          nfc$ntf_getrss_msg_reserved_59, nfc$ntf_getrss_msg_reserved_60,
          nfc$ntf_getrss_msg_reserved_61, nfc$ntf_getrss_msg_reserved_62,
          nfc$ntf_getrss_msg_reserved_63, nfc$ntf_getrss_msg_reserved_64,
          nfc$ntf_getrss_msg_reserved_65);
*DECK DECK=NFT$NTF_INACTIVITY_TIMER EXPAND=FALSE

  CONST
    nfc$ntf_max_inactivity_timer = 600,
    nfc$ntf_min_inactivity_timer = 0;

  TYPE
    nft$ntf_inactivity_timer = nfc$ntf_min_inactivity_timer ..
          nfc$ntf_max_inactivity_timer;
*DECK DECK=NFT$NTF_LINE_SPEED EXPAND=FALSE

  CONST
    nfc$ntf_max_line_speed = 64000,
    nfc$ntf_min_line_speed = 50;

  TYPE
    nft$ntf_line_speed = nfc$ntf_min_line_speed .. nfc$ntf_max_line_speed;
*DECK DECK=NFT$NTF_LOGICAL_LINE_DATA EXPAND=FALSE

  TYPE
    nft$ntf_logical_line_data = record
      number: nft$ntf_logical_line_number,
      terminal_user_procedure: ost$name,
      name: string ( * <= 31),
    recend;

*copyc nft$ntf_logical_line_number
*copyc ost$name
*DECK DECK=NFT$NTF_LOGICAL_LINE_NUMBER EXPAND=FALSE

  CONST
    nfc$ntf_max_logical_line_number = 999,
    nfc$ntf_min_logical_line_number = 1;

  TYPE
    nft$ntf_logical_line_number = nfc$ntf_min_logical_line_number ..
          nfc$ntf_max_logical_line_number;
*DECK DECK=NFT$NTF_POSITIVE_ACKNOWLEDGE EXPAND=FALSE

  TYPE
    nft$ntf_positive_acknowledge = (nfc$ntf_ack, nfc$ntf_null);
*DECK DECK=NFT$NTF_REMOTE_SYSTEM_COUNT EXPAND=FALSE

  TYPE
    nft$ntf_remote_system_count = 0 .. nfc$ntf_max_remote_systems;

  CONST
    nfc$ntf_max_remote_systems = 65535;
*DECK DECK=NFT$NTF_REMOTE_SYSTEM_DATA EXPAND=FALSE

  TYPE
    nft$ntf_remote_system_data = record
      remote_system_type: nft$ntf_remote_system_type,
      kind: nft$ntf_remote_system_kind,
      route_back_position: nft$ntf_route_back_position,
      authority_level: nft$ntf_authority_level,
      name: string ( * <= 31),
    recend;

*copyc nft$ntf_authority_level
*copyc nft$ntf_remote_system_kind
*copyc nft$ntf_remote_system_type
*copyc nft$ntf_route_back_position
*DECK DECK=NFT$NTF_REMOTE_SYSTEM_KIND EXPAND=FALSE

  TYPE
    nft$ntf_remote_system_kind = (nfc$ntf_not_configured,
          nfc$ntf_directly_connected, nfc$ntf_accessible);
*DECK DECK=NFT$NTF_REMOTE_SYSTEM_PROTOCOL EXPAND=FALSE

  TYPE
    nft$ntf_remote_system_protocol = (nfc$ntf_nje, nfc$ntf_hasp);
*DECK DECK=NFT$NTF_REMOTE_SYSTEM_STATUS EXPAND=FALSE

  TYPE
    nft$ntf_remote_system_status = record
      logical_line_number: nft$ntf_logical_line_number,
      line_speed: nft$ntf_line_speed,
      signon_status: nft$device_status,
      name: string ( * <= 31),
    recend;

*copyc nft$device_status
*copyc nft$ntf_line_speed
*copyc nft$ntf_logical_line_number
*DECK DECK=NFT$NTF_REMOTE_SYSTEM_TYPE EXPAND=FALSE

  TYPE
    nft$ntf_remote_system_type = (nfc$ntf_nos_ve, nfc$ntf_nos, nfc$ntf_nos_be,
          nfc$ntf_ibm, nfc$ntf_dec, nfc$ntf_user, nfc$ntf_cyber_205, nfc$ntf_eta,
          nfc$ntf_cray);
*DECK DECK=NFT$NTF_ROUTE_BACK_POSITION EXPAND=FALSE

  TYPE
    nft$ntf_route_back_position = 0 .. 255;

*DECK DECK=NFT$NTF_SEND_RC_RESPONSE_CODES EXPAND=FALSE

  TYPE
    nft$ntf_send_rc_response_codes = (nfc$message_accepted,
          nfc$ntf_incorrect_signon_status, nfc$ntf_remote_system_not_found,
          nfc$ntf_batch_stream_not_found, nfc$ntf_client_not_found,
          nfc$ntf_no_users_found);

*DECK DECK=NFT$NTF_SEND_REMOTE_COMM_MSG EXPAND=FALSE

  TYPE
    nft$ntf_send_remote_comm_msg = packed record
      length_indicated: boolean,
      param: nft$ntf_send_rc_msg_parameters,
    recend,

    nft$ntf_send_rc_msg_parameters = (nfc$null_parameter,
          nfc$ntf_remote_system_name, nfc$ntf_console_stream_name,
          nfc$ntf_logical_line_number, nfc$ntf_command_kind,
          nfc$ntf_command_text, nfc$ntf_system_identifier,
          nfc$ntf_family_name, nfc$ntf_user_name,
          nfc$ntf_operator_identifier, nfc$ntf_senrc_msg_reserved_10,
          nfc$ntf_senrc_msg_reserved_11, nfc$ntf_senrc_msg_reserved_12,
          nfc$ntf_senrc_msg_reserved_13, nfc$ntf_senrc_msg_reserved_14,
          nfc$ntf_senrc_msg_reserved_15, nfc$ntf_senrc_msg_reserved_16,
          nfc$ntf_senrc_msg_reserved_17, nfc$ntf_senrc_msg_reserved_18,
          nfc$ntf_senrc_msg_reserved_19, nfc$ntf_senrc_msg_reserved_20,
          nfc$ntf_senrc_msg_reserved_21, nfc$ntf_senrc_msg_reserved_22,
          nfc$ntf_senrc_msg_reserved_23, nfc$ntf_senrc_msg_reserved_24,
          nfc$ntf_senrc_msg_reserved_25, nfc$ntf_senrc_msg_reserved_26,
          nfc$ntf_senrc_msg_reserved_27, nfc$ntf_senrc_msg_reserved_28,
          nfc$ntf_senrc_msg_reserved_29, nfc$ntf_senrc_msg_reserved_30,
          nfc$ntf_senrc_msg_reserved_31, nfc$ntf_senrc_msg_reserved_32,
          nfc$ntf_senrc_msg_reserved_33, nfc$ntf_senrc_msg_reserved_34,
          nfc$ntf_senrc_msg_reserved_35, nfc$ntf_senrc_msg_reserved_36,
          nfc$ntf_senrc_msg_reserved_37, nfc$ntf_senrc_msg_reserved_38,
          nfc$ntf_senrc_msg_reserved_39, nfc$ntf_senrc_msg_reserved_40,
          nfc$ntf_senrc_msg_reserved_41, nfc$ntf_senrc_msg_reserved_42,
          nfc$ntf_senrc_msg_reserved_43, nfc$ntf_senrc_msg_reserved_44,
          nfc$ntf_senrc_msg_reserved_45, nfc$ntf_senrc_msg_reserved_46,
          nfc$ntf_senrc_msg_reserved_47, nfc$ntf_senrc_msg_reserved_48,
          nfc$ntf_senrc_msg_reserved_49, nfc$ntf_senrc_msg_reserved_50,
          nfc$ntf_senrc_msg_reserved_51, nfc$ntf_senrc_msg_reserved_52,
          nfc$ntf_senrc_msg_reserved_53, nfc$ntf_senrc_msg_reserved_54,
          nfc$ntf_senrc_msg_reserved_55, nfc$ntf_senrc_msg_reserved_56,
          nfc$ntf_senrc_msg_reserved_57, nfc$ntf_senrc_msg_reserved_58,
          nfc$ntf_senrc_msg_reserved_59, nfc$ntf_senrc_msg_reserved_60,
          nfc$ntf_senrc_msg_reserved_61, nfc$ntf_senrc_msg_reserved_62,
          nfc$ntf_senrc_msg_reserved_63, nfc$ntf_senrc_msg_reserved_64,
          nfc$ntf_senrc_msg_reserved_65);
*DECK DECK=NFT$NTF_SEND_REMOTE_COMM_RESP EXPAND=FALSE

  TYPE
    nft$ntf_send_remote_comm_resp = packed record
      length_indicated: boolean,
      param: nft$ntf_send_rc_resp_parameters,
    recend,

    nft$ntf_send_rc_resp_parameters = (nfc$null_parameter,
          nfc$ntf_remote_system_name, nfc$ntf_console_stream_name,
          nfc$ntf_command_kind, nfc$ntf_signon_status, nfc$response_code,
          nfc$ntf_senrc_resp_reserved_6, nfc$ntf_senrc_resp_reserved_7,
          nfc$ntf_senrc_resp_reserved_8, nfc$ntf_senrc_resp_reserved_9,
          nfc$ntf_senrc_resp_reserved_10, nfc$ntf_senrc_resp_reserved_11,
          nfc$ntf_senrc_resp_reserved_12, nfc$ntf_senrc_resp_reserved_13,
          nfc$ntf_senrc_resp_reserved_14, nfc$ntf_senrc_resp_reserved_15,
          nfc$ntf_senrc_resp_reserved_16, nfc$ntf_senrc_resp_reserved_17,
          nfc$ntf_senrc_resp_reserved_18, nfc$ntf_senrc_resp_reserved_19,
          nfc$ntf_senrc_resp_reserved_20, nfc$ntf_senrc_resp_reserved_21,
          nfc$ntf_senrc_resp_reserved_22, nfc$ntf_senrc_resp_reserved_23,
          nfc$ntf_senrc_resp_reserved_24, nfc$ntf_senrc_resp_reserved_25,
          nfc$ntf_senrc_resp_reserved_26, nfc$ntf_senrc_resp_reserved_27,
          nfc$ntf_senrc_resp_reserved_28, nfc$ntf_senrc_resp_reserved_29,
          nfc$ntf_senrc_resp_reserved_30, nfc$ntf_senrc_resp_reserved_31,
          nfc$ntf_senrc_resp_reserved_32, nfc$ntf_senrc_resp_reserved_33,
          nfc$ntf_senrc_resp_reserved_34, nfc$ntf_senrc_resp_reserved_35,
          nfc$ntf_senrc_resp_reserved_36, nfc$ntf_senrc_resp_reserved_37,
          nfc$ntf_senrc_resp_reserved_38, nfc$ntf_senrc_resp_reserved_39,
          nfc$ntf_senrc_resp_reserved_40, nfc$ntf_senrc_resp_reserved_41,
          nfc$ntf_senrc_resp_reserved_42, nfc$ntf_senrc_resp_reserved_43,
          nfc$ntf_senrc_resp_reserved_44, nfc$ntf_senrc_resp_reserved_45,
          nfc$ntf_senrc_resp_reserved_46, nfc$ntf_senrc_resp_reserved_47,
          nfc$ntf_senrc_resp_reserved_48, nfc$ntf_senrc_resp_reserved_49,
          nfc$ntf_senrc_resp_reserved_50, nfc$ntf_senrc_resp_reserved_51,
          nfc$ntf_senrc_resp_reserved_52, nfc$ntf_senrc_resp_reserved_53,
          nfc$ntf_senrc_resp_reserved_54, nfc$ntf_senrc_resp_reserved_55,
          nfc$ntf_senrc_resp_reserved_56, nfc$ntf_senrc_resp_reserved_57,
          nfc$ntf_senrc_resp_reserved_58, nfc$ntf_senrc_resp_reserved_59,
          nfc$ntf_senrc_resp_reserved_60, nfc$ntf_senrc_resp_reserved_61,
          nfc$ntf_senrc_resp_reserved_62, nfc$ntf_senrc_resp_reserved_63,
          nfc$ntf_senrc_resp_reserved_64, nfc$ntf_senrc_resp_reserved_65);
*DECK DECK=NFT$NTF_SKIP_PUNCH_COUNT EXPAND=FALSE

  CONST
    nfc$ntf_max_skip_punch_count = 9,
    nfc$ntf_min_skip_punch_count = 0;

  TYPE
    nft$ntf_skip_punch_count = nfc$ntf_min_skip_punch_count ..
          nfc$ntf_max_skip_punch_count;
*DECK DECK=NFT$NTF_SYSTEM_IDENTIFIER EXPAND=FALSE

  TYPE
    nft$ntf_system_identifier = string (nfc$ntf_system_identifier_size);

  CONST
    nfc$ntf_blank_system_identifier = '                   ',
    nfc$ntf_model_and_sn_size = 10,
    nfc$ntf_system_identifier_size = jmc$system_supplied_name_size;

*copyc jmt$system_supplied_name
*DECK DECK=NFT$NTF_WAIT_A_BIT EXPAND=FALSE

  TYPE
    nft$ntf_wait_a_bit = (nfc$ntf_acknowledge, nfc$ntf_fcs);
*DECK DECK=NFT$NUMBER_IMPLICIT_COMMANDS EXPAND=FALSE
  TYPE
    nft$number_implicit_commands = 0 .. 25;

*DECK DECK=NFT$NUMBER_PDU_PARAM_RANGE EXPAND=FALSE
  TYPE
    nft$number_pdu_param_range = nfc$min_parameter_count ..
          nfc$max_parameter_count;

*copyc nfc$parameter_definitions
*DECK DECK=NFT$OPERATOR_MESSAGE EXPAND=FALSE

  TYPE
    nft$operator_message_parameter = packed record
      length_indicated: boolean,
      param: nft$operator_message_params,
    recend,

    nft$operator_message_params = (nfc$null_parameter, nfc$io_station_name,
          nfc$device_name, nfc$text, nfc$operator_msg_reserved_4,
          nfc$operator_msg_reserved_5, nfc$operator_msg_reserved_6,
          nfc$operator_msg_reserved_7, nfc$operator_msg_reserved_8,
          nfc$operator_msg_reserved_9, nfc$operator_msg_reserved_10,
          nfc$operator_msg_reserved_11, nfc$operator_msg_reserved_12,
          nfc$operator_msg_reserved_13, nfc$operator_msg_reserved_14,
          nfc$operator_msg_reserved_15, nfc$operator_msg_reserved_16,
          nfc$operator_msg_reserved_17, nfc$operator_msg_reserved_18,
          nfc$operator_msg_reserved_19, nfc$operator_msg_reserved_20,
          nfc$operator_msg_reserved_21, nfc$operator_msg_reserved_22,
          nfc$operator_msg_reserved_23, nfc$operator_msg_reserved_24,
          nfc$operator_msg_reserved_25, nfc$operator_msg_reserved_26,
          nfc$operator_msg_reserved_27, nfc$operator_msg_reserved_28,
          nfc$operator_msg_reserved_29, nfc$operator_msg_reserved_30,
          nfc$operator_msg_reserved_31, nfc$operator_msg_reserved_32,
          nfc$operator_msg_reserved_33, nfc$operator_msg_reserved_34,
          nfc$operator_msg_reserved_35, nfc$operator_msg_reserved_36,
          nfc$operator_msg_reserved_37, nfc$operator_msg_reserved_38,
          nfc$operator_msg_reserved_39, nfc$operator_msg_reserved_40,
          nfc$operator_msg_reserved_41, nfc$operator_msg_reserved_42,
          nfc$operator_msg_reserved_43, nfc$operator_msg_reserved_44,
          nfc$operator_msg_reserved_45, nfc$operator_msg_reserved_46,
          nfc$operator_msg_reserved_47, nfc$operator_msg_reserved_48,
          nfc$operator_msg_reserved_49, nfc$operator_msg_reserved_50,
          nfc$operator_msg_reserved_51, nfc$operator_msg_reserved_52,
          nfc$operator_msg_reserved_53, nfc$operator_msg_reserved_54,
          nfc$operator_msg_reserved_55, nfc$operator_msg_reserved_56,
          nfc$operator_msg_reserved_57, nfc$operator_msg_reserved_58,
          nfc$operator_msg_reserved_59, nfc$operator_msg_reserved_60,
          nfc$operator_msg_reserved_61, nfc$operator_msg_reserved_62,
          nfc$operator_msg_reserved_63, nfc$operator_msg_reserved_64,
          nfc$operator_msg_reserved_65, nfc$operator_msg_reserved_66,
          nfc$operator_msg_reserved_67, nfc$operator_msg_reserved_68,
          nfc$operator_msg_reserved_69, nfc$operator_msg_reserved_70,
          nfc$operator_msg_reserved_71, nfc$operator_msg_reserved_72,
          nfc$operator_msg_reserved_73, nfc$operator_msg_reserved_74,
          nfc$operator_msg_reserved_75, nfc$operator_msg_reserved_76,
          nfc$operator_msg_reserved_77, nfc$operator_msg_reserved_78,
          nfc$operator_msg_reserved_79, nfc$operator_msg_reserved_80,
          nfc$operator_msg_reserved_81, nfc$operator_msg_reserved_82,
          nfc$operator_msg_reserved_83, nfc$operator_msg_reserved_84,
          nfc$operator_msg_reserved_85, nfc$operator_msg_reserved_86,
          nfc$operator_msg_reserved_87, nfc$operator_msg_reserved_88,
          nfc$operator_msg_reserved_89, nfc$operator_msg_reserved_90,
          nfc$operator_msg_reserved_91, nfc$operator_msg_reserved_92,
          nfc$operator_msg_reserved_93, nfc$operator_msg_reserved_94,
          nfc$operator_msg_reserved_95);
*DECK DECK=NFT$OPTIMIZE_LIST EXPAND=FALSE
  TYPE
    nft$optimize_list = (nfc$do_not_optimize, nfc$do_optimize);
*DECK DECK=NFT$OUTPUT_DATA_MODE EXPAND=FALSE
  TYPE
    nft$output_data_mode = (nfc$coded_mode, nfc$transparent_mode);

*DECK DECK=NFT$P00_VALUES EXPAND=FALSE
  TYPE
    nft$p00_string = record
      value: string (nfc$p00_max_size),
      length: nfc$p00_min_size .. nfc$p00_max_size,
    recend;

  TYPE
    nft$p00_values = array [nft$parameter_00_values] of nft$p00_string;

*copyc nfc$parameter_00_definitions
*copyc nft$parameter_00_values
*DECK DECK=NFT$PAGE_FORMAT EXPAND=FALSE
*copyc amd$page_format_declarations
  TYPE
    nft$page_format = amt$page_format;

*DECK DECK=NFT$PAGE_LENGTH EXPAND=FALSE
  CONST
    nfc$maximum_page_length = 176;

  TYPE
    nft$page_length = 0 .. nfc$maximum_page_length;

*DECK DECK=NFT$PAGE_WIDTH EXPAND=FALSE
  CONST
    nfc$minimum_page_width = 10,
    nfc$maximum_page_width = 255;

  TYPE
    nft$page_width = nfc$minimum_page_width .. nfc$maximum_page_width;

*DECK DECK=NFT$PARAMETER_00_VALUES EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_00_values' ??

{ nft$parameter_00_values }

  TYPE
    nft$parameter_00_values = (nfc$p00_a101, nfc$p00_a102, nfc$p00_b101);

?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_01_VALUES EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_01_values' ??

{ nft$parameter_01_values }

  TYPE
    nft$parameter_01_values = nfc$p01_min_value .. nfc$p01_max_value;

*copyc nfc$parameter_01_definitions
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_03_ELEMENTS EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_03_elements' ??

{ nft$parameter_03_elements }

  TYPE
    nft$parameter_03_elements = array [nft$facility_types] of
          string (nfc$p03_element_size);

*copyc nft$transfer_declarations
*copyc nfc$parameter_03_definitions
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_03_NETVALUES EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_03_netvalues' ??

{ nft$parameter_03_netvalues }

  TYPE
    nft$parameter_03_netvalues = array [nft$network_type] of
          nft$parameter_03_value_set;

*copyc nft$network_type
*copyc nft$parameter_03_value_set
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_03_VALUES EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_03_values' ??

{ nft$parameter_03_values }

  TYPE
    nft$parameter_03_values = (nfc$p03_collective_strings,
          nfc$p03_temporary_hold, nfc$p03_parameters_on_go,
          nfc$p03_later_resumption, nfc$p03_restart_permitted,
          nfc$p03_checkmark_ack_req, nfc$p03_no_blocking_40_50,
          nfc$p03_send_data_ack_req);

?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_03_VALUE_SET EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_03_value_set' ??

{ nft$parameter_03_value_set }

  TYPE
    nft$parameter_03_value_set = set of nft$facility_types;

*copyc nft$transfer_declarations
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_04_VALUES EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_04_values' ??

{ nft$parameter_04_values }

  TYPE
    nft$parameter_04_values = array [1 .. nfc$p04_max_transfer_states] of
          record
      code: string (6),
      case normal: boolean of
      = FALSE =
        condition: ost$status_condition,
        retryable: boolean,
      casend,
    recend;

*copyc nfc$parameter_04_definitions
*copyc ost$status
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_06_VALUES EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_06_values' ??

{ nft$parameter_06_values }

  TYPE
    nft$parameter_06_values = nfc$p06_min_value .. amc$file_byte_limit;

*copyc amt$file_length
*copyc nfc$parameter_06_definitions
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_11_OPTIONS EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_11_options' ??

{ nft$parameter_11_options }

  TYPE
    nft$parameter_11_options = record
      case p11_option: nft$parameter_11_values of
      = nfc$p11_status =
        application_status: ost$status,
      = nfc$p11_ring =
        application_ring: ost$ring,
      casend,
    recend;

*copyc osd$virtual_address
*copyc nft$parameter_11_values
*copyc ost$status
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_11_VALUE EXPAND=FALSE
{ nft$parameter_11_value }

  TYPE
    nft$parameter_11_size = nfc$p11_min_param_len .. nfc$p11_max_param_len,
    nft$parameter_11_value = record
      qualifier: nft$parameter_qualifiers,
      size: nft$parameter_11_size,
      value: string (nfc$p11_max_param_len),
    recend;

*copyc nfc$parameter_11_definitions
*copyc nft$parameter_qualifiers
*DECK DECK=NFT$PARAMETER_11_VALUES EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_11_values' ??

{ nft$parameter_11_values }

  TYPE
    nft$parameter_11_values = (nfc$p11_status, nfc$p11_ring);

?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_12_RANGE EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_12_range' ??

{ nft$parameter_12_range }

  TYPE
    nft$parameter_12_range = 0 .. nfc$block_size_limit;

*copyc nfc$parameter_12_definitions
*copyc nft$transfer_declarations
?? OLDTITLE ??


*DECK DECK=NFT$PARAMETER_13_DEFINITION EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_13_definition' ??

{ nft$parameter_13_definition }

  TYPE
    nft$parameter_13_definition = nfc$p13_min_param_value ..
          nfc$p13_max_param_value;

*copyc nfc$parameter_13_definitions
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_16_DEFINITION EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_16_definition' ??

{ nft$parameter_16_definition }

  TYPE
    nft$parameter_16_definition = record
      size: 0 .. nfc$p16_max_param_length,
      value: string (nfc$p16_max_param_length),
    recend;

*copyc nfc$parameter_16_definitions
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_17_DEFINITION EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_17_defintion' ??

{ nft$parameter_17_definition }

  TYPE
    nft$parameter_17_definition = (nfc$p17_line_printer,
          nfc$p17_hollerith_card_punch, nfc$p17_binary_card_punch,
          nfc$p17_binary_checksummed_cp,
          nfc$p17_special_output, nfc$p17_input_return,
          nfc$p17_input_no_return,
          nfc$p17_generic_queue);

?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_17_ELEMENT EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_17_element' ??

{ nft$parameter_17_element }

  TYPE
    nft$parameter_17_element = string (nfc$p17_max_size);

*copyc nfc$parameter_17_definitions
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_17_VALUES EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_17_values' ??

{ nft$parameter_17_values }

  TYPE
    nft$parameter_17_values = array [nft$parameter_17_definition] of
          nft$parameter_17_element;

*copyc nft$parameter_17_definition
*copyc nft$parameter_17_element
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_18_DEFINITION EXPAND=FALSE
?? newtitle := 'nft$parameter_18_definition' ??

{ nft$parameter_18_definition }

TYPE
      nft$parameter_18_definition = nfc$p18_minimum_value ..
                    nfc$p18_maximum_value;

*copyc nfc$parameter_18_definitions

?? oldtitle ??
*DECK DECK=NFT$PARAMETER_19_DEFINITION EXPAND=FALSE
?? newtitle := 'nft$parameter_19_definition' ??

{ nft$parameter_19_definition }

TYPE
      nft$parameter_19_definition = nfc$p19_minimum_value ..
             nfc$p19_maximum_value;

*copyc nfc$parameter_19_definitions
?? oldtitle ??
*DECK DECK=NFT$PARAMETER_20_RANGE EXPAND=FALSE
?? NEWTITLE := 'nfc$parameter_20_range' ??

{ nfc$parameter_20_range }

  TYPE
    nft$parameter_20_range = 0 .. nfc$timeout_limit;

*copyc nfc$parameter_20_definitions
*copyc nft$transfer_declarations
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_21_OPTIONS EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_21_options' ??

{ nfc$parameter_21_options }

  TYPE
    nft$parameter_21_options = (nfc$p21_non_specific, nfc$p21_make_only,
          nfc$p21_replace_only, nfc$p21_replace_make, nfc$p21_append_only,
          nfc$p21_append_or_make, nfc$p21_read_remove, nfc$p21_read_only,
          nfc$p21_destructive_read, nfc$p21_make_only_too);

?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_21_SPECIFICATIONS EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_21_specifications' ??

{ nft$parameter_21_specifications }

  TYPE
    nft$parameter_21_specifications = array [nft$parameter_21_options] of
          string (nfc$p21_opt_length);

*copyc nfc$parameter_21_definitions
*copyc nft$parameter_21_options
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_21_VALUES EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_21_values' ??

{ nft$parameter_21_values }

  TYPE
    nft$parameter_21_values = array [nft$mode_of_access] of
          string (nfc$p21_prefix_length);

*copyc nfc$parameter_21_definitions
*copyc nft$mode_of_access
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_22_STRINGS EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_22_strings' ??

{ nft$parameter_22_strings }

  TYPE
    nft$parameter_22_strings = array [nft$parameter_22_values] of
          string (nfc$p22_max_size);

*copyc nfc$parameter_22_definitions
*copyc nft$parameter_22_values
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_22_VALUES EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_22_values' ??

{ nft$parameter_22_values }

  TYPE
    nft$parameter_22_values = (nfc$p22_unknown_host, nfc$p22_nos_ve,
          nfc$p22_nos_ve_qtf);

?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_24_DEFINITION EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_24_definition' ??

{ nft$parameter_24_definition }

  TYPE
    nft$parameter_24_definition = RECORD
      size: nfc$p24_min_param_size .. nfc$p24_max_param_size,
      value: string (nfc$p24_max_param_size),
      RECEND;

*copyc nfc$parameter_24_definitions
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_25_B101_TEXT EXPAND=FALSE

    TYPE
      nft$p25_b101_params = array [1 .. nfc$p25_input_params] of ost$name;

*copyc nfc$parameter_25_definitions
*DECK DECK=NFT$PARAMETER_25_DEFINITION EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_25_definition' ??

{ nft$parameter_25_definition }

  TYPE
    nft$parameter_25_definition = string (nfc$p25_max_param_size);

*copyc nfc$parameter_25_definitions
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_25_LENGTH EXPAND=FALSE
  TYPE
    nft$parameter_25_length = nfc$p25_min_param_size .. nfc$p25_max_param_size;

*copyc nfc$parameter_25_definitions

*DECK DECK=NFT$PARAMETER_26_ALL_CHARS EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_26_all_chars' ??

{ nft$parameter_26_all_chars }

  TYPE
    nft$parameter_26_all_chars = array [1 .. 39] of string (1);

?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_26_DEFINITION EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_26_definition' ??

{ nft$parameter_26_definition }

  TYPE
    nft$parameter_26_definition = RECORD
             size: 0 .. nfc$p26_max_param_length,
             value: string (nfc$p26_max_param_length),
             RECEND;

*copyc nfc$parameter_26_definitions
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_27_DEFINITION EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_27_definition' ??

{ nft$parameter_27_definition }

  TYPE
    nft$parameter_27_definition = string (nfc$p27_max_param_size);

*copyc nfc$parameter_27_definitions
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_27_LENGTH EXPAND=FALSE
  TYPE
    nft$parameter_27_length = nfc$p27_min_param_size .. nfc$p27_max_param_size;

*copyc nfc$parameter_27_definitions

*DECK DECK=NFT$PARAMETER_29_DEFINITION EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_29_definition' ??

  TYPE
    nft$parameter_29_definition = record
      size: nfc$p29_min_param_size .. nfc$p29_max_param_size,
      value: string (nfc$p29_max_param_size),
      link: ^nft$parameter_29_definition,
    recend;

*copyc nfc$parameter_29_definitions
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_29_LIST_HEAD EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_29_list_head' ??

  TYPE
    nft$parameter_29_list_head = record
      first_text: ^nft$parameter_29_definition,
      last_text: ^nft$parameter_29_definition,
    recend;

*copyc nft$parameter_29_definition
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_31_DEFINITION EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_31_definition' ??

{ nft$parameter_31_definition }

  TYPE
    nft$parameter_31_definition = array [nft$parameter_31_type] of
          string (nfc$p31_max_param_length);

*copyc nfc$parameter_31_definitions
*copyc nft$parameter_31_type
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_31_TYPE EXPAND=TRUE
{     nft$parameter_31_type }

TYPE nft$parameter_31_type = (
      nfc$p31_unspecified,
      nfc$p31_ascii_c6,
      nfc$p31_ascii_c8,
      nfc$p31_host_dependent_uh,
      nfc$p31_undef_unstructured_uu,
      nfc$p31_undefined_structured_us    );
*DECK DECK=NFT$PARAMETER_32_B101_TEXT EXPAND=FALSE

    TYPE
      nft$p32_b101_text = record
        variant: string (nfc$p32_variant_size),
        text: string (nfc$p32_max_param_length_b101 - nfc$p32_variant_size),
      recend,
      nft$p32_b101_ntf_params = array [1 .. nfc$p32_b101_ntf_params]
            of ost$name,
      nft$p32_b101_private_params = array [1 .. nfc$p32_b101_private_params]
            of ost$name,
      nft$p32_b101_public_params = array [1 .. nfc$p32_b101_public_params]
            of ost$name;

*copyc nfc$parameter_32_definitions
*DECK DECK=NFT$PARAMETER_52_DEFINITION EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_52_definition' ??

{ nft$parameter_52_definition }

  TYPE
    nft$parameter_52_definition = string (nfc$p52_max_param_length);

*copyc nfc$parameter_52_definitions
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_58_B101_TEXT EXPAND=FALSE

    TYPE
      nft$p58_b101_text = record
        variant: string (nfc$p58_variant_size),
        text: string (nfc$p58_max_param_size - nfc$p58_variant_size),
      recend,
      nft$p58_b101_ntf_params = array [1 .. nfc$p58_b101_ntf_params]
            of ost$name,
      nft$p58_b101_private_params = array [1 .. nfc$p58_b101_private_params]
            of ost$name,
      nft$p58_b101_public_params = array [1 .. nfc$p58_b101_public_params]
            of ost$name;

*copyc nfc$parameter_58_definitions
*DECK DECK=NFT$PARAMETER_59_VALUES EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_59_values' ??

{ nft$parameter_59_values }

  TYPE
    nft$parameter_59_values = array [jmt$vertical_print_density] of
          string (nfc$p59_max_param_length);

*copyc nfc$parameter_59_definitions
*copyc jmt$vertical_print_density
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_60_ELEMENT EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_60_element' ??

{ nft$parameter_60_element }

  TYPE
    nft$parameter_60_element = record
      size: 0 .. nfc$p60_max_param_length,
      value: string (nfc$p60_max_param_length),
    recend;

*copyc nfc$parameter_60_definitions
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_NUMBERS EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_numbers' ??

{ nft$parameter_numbers }

  TYPE
    nft$parameter_number_range = nfc$i_protocol_id ..
          nfc$i_reserved_for_site_99;

  TYPE
    nft$parameter_numbers = array [nft$protocol_parameters] of
          nft$parameter_number_range;

*copyc nfc$parameter_definitions
*copyc nft$protocol_parameters

?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_QUALIFIERS EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_qualifiers' ??

{ nft$parameter_qualifiers }

  TYPE
    nft$parameter_qualifiers = (nfc$select, nfc$ignore, nfc$modify);

?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_QUALIFIER_VALUES EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_qualifier_values' ??

{ nft$parameter_qualifier_values }

  TYPE
    nft$parameter_qualifier_values = array [nft$parameter_qualifiers] of
          string (nfc$num_param_qual_digits);

*copyc nfc$parameter_definitions
*copyc nft$parameter_qualifiers
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_RULES EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_rules' ??

{ nft$parameter_rules }

  TYPE
    nft$parameter_rule_block = record
      case valid_for_protocol: boolean of
      = FALSE =
        ,
      = TRUE =
        minimum_parameter_length: nft$parameter_size,
        maximum_parameter_length: nft$parameter_size,
        required_on_command: nft$command_set,
        prohibited_on_command: nft$command_set,
        ignorable_on_command: nft$command_set,
        discard_on_command: nft$command_set,
        allow_multiple_on_command: boolean,
      casend,
    recend;




  TYPE
    nft$parameter_rules = array [nft$parameter_00_values] of
          nft$parameter_rule_block;

*copyc nft$parameter_size
*copyc nft$command_set
*copyc nft$parameter_00_values

?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_RULES_ARRAY EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_rules_array' ??

{ nft$parameter_rules_array }

  TYPE
    nft$parameter_rules_array = array [nft$protocol_parameters] of
          ^nft$parameter_rules;

*copyc nft$protocol_parameters
*copyc nft$parameter_rules
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_SET EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_set' ??

{ nft$parameter_set }

  TYPE
    nft$parameter_set = set of nft$protocol_parameters;

*copyc nft$protocol_parameters
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_SIZE EXPAND=FALSE
  TYPE
    nft$parameter_size = nfc$min_param_size .. nfc$max_param_size;

*copyc nfc$parameter_definitions
*DECK DECK=NFT$PARAMETER_VALUES EXPAND=FALSE
?? NEWTITLE := 'nft$parameter_values', EJECT ??

{ nft$parameter_values }

  TYPE
    nft$parameter_values = array [nft$protocol_parameters] of
          string (nfc$num_param_id_digits);

*copyc nfc$parameter_definitions
*copyc nft$protocol_parameters
?? OLDTITLE ??
*DECK DECK=NFT$PARAMETER_VALUE_LENGTH EXPAND=FALSE
  CONST
    nfc$max_parameter_short_length = 7f(16);

  TYPE
    nft$parameter_value_length = packed record
      long_length: boolean,
      length: 0 .. nfc$max_parameter_short_length,
    recend;

*DECK DECK=NFT$PDT_DEF_APPLICATION_SWITCH EXPAND=FALSE

{ PROCEDURE define_application_name_switch (
{   next_hop_application, nha : name = $required
{   application_qualifier, application_qualifiers, aq : list of key
{       NTFS
{       QTFS
{     keyend = $required
{   destination_group_qualifier, dgq : name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 2] of clt$keyword_specification,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 5, 27, 14, 19, 41, 872],
    clc$command, 8, 4, 2, 0, 0, 0, 4, 'DEFINE_APPLICATION_NAME_SWITCH'], [
    ['APPLICATION_QUALIFIER          ',clc$nominal_entry, 2],
    ['APPLICATION_QUALIFIERS         ',clc$alias_entry, 2],
    ['AQ                             ',clc$abbreviation_entry, 2],
    ['DESTINATION_GROUP_QUALIFIER    ',clc$nominal_entry, 3],
    ['DGQ                            ',clc$abbreviation_entry, 3],
    ['NEXT_HOP_APPLICATION           ',clc$nominal_entry, 1],
    ['NHA                            ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 97, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [81, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [2], [
      ['NTFS                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['QTFS                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$next_hop_application = 1,
    p$application_qualifier = 2,
    p$destination_group_qualifier = 3,
    p$status = 4;

  VAR
    pvt: array [1 .. 4] of clt$parameter_value;
*DECK DECK=NFT$PDT_DEF_DESTINATION_GROUP EXPAND=FALSE

{ PROCEDURE define_destination_group (
{   group_name, gn : name = $required
{   destination_name, destination_names, dn : list of any of
{       name
{       string 1..31
{     anyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: 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$name_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 2, 16, 13, 23, 46, 824],
    clc$command, 6, 3, 2, 0, 0, 0, 3, ''], [
    ['DESTINATION_NAME               ',clc$nominal_entry, 2],
    ['DESTINATION_NAMES              ',clc$alias_entry, 2],
    ['DN                             ',clc$abbreviation_entry, 2],
    ['GN                             ',clc$abbreviation_entry, 1],
    ['GROUP_NAME                     ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 49, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$union_type], [[clc$name_type,
      clc$string_type],
      FALSE, 2],
      5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
      8, [[1, 0, clc$string_type], [1, 31, FALSE]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$group_name = 1,
      p$destination_name = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;
*DECK DECK=NFT$PDT_DEF_DEST_NAME_SWITCH EXPAND=FALSE

{ PROCEDURE define_destination_name_switch (
{   name, n : any of
{       name
{       string 1..31
{     anyend = $required
{   next_hop_name, nhn : any of
{       name
{       string 1..31
{     anyend = $required
{   application_qualifier, application_qualifiers, aq : list of key
{       NTFI
{       NTFS
{       QTFI
{       QTFS
{     keyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type2: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 2, 16, 13, 24, 4, 710],
    clc$command, 8, 4, 3, 0, 0, 0, 4, ''], [
    ['APPLICATION_QUALIFIER          ',clc$nominal_entry, 3],
    ['APPLICATION_QUALIFIERS         ',clc$alias_entry, 3],
    ['AQ                             ',clc$abbreviation_entry, 3],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NEXT_HOP_NAME                  ',clc$nominal_entry, 2],
    ['NHN                            ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 171, clc$required_parameter, 0, 0],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    8, [[1, 0, clc$string_type], [1, 31, FALSE]]
    ],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    8, [[1, 0, clc$string_type], [1, 31, FALSE]]
    ],
{ PARAMETER 3
    [[1, 0, clc$list_type], [155, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [4], [
      ['NTFI                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NTFS                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['QTFI                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['QTFS                           ', clc$nominal_entry,
  clc$normal_usage_entry, 4]]
      ]
    ],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$next_hop_name = 2,
      p$application_qualifier = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;
*DECK DECK=NFT$PDT_DEF_SOURCE_NAME_SWITCH EXPAND=FALSE

{ PROCEDURE def_source_name_switch (
{   name, n : any of
{       name
{       string 1..31
{     anyend = $required
{   next_hop_name, nhn : any of
{       name
{       string 1..31
{     anyend = $required
{   application_qualifier, application_qualifiers, aq : list of key
{       NTFI
{       NTFS
{       QTFI
{       QTFS
{     keyend = $required
{   destination_group_qualifier, dgq : name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type2: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 2, 16, 13, 24, 14, 393],
    clc$command, 10, 5, 3, 0, 0, 0, 5, ''], [
    ['APPLICATION_QUALIFIER          ',clc$nominal_entry, 3],
    ['APPLICATION_QUALIFIERS         ',clc$alias_entry, 3],
    ['AQ                             ',clc$abbreviation_entry, 3],
    ['DESTINATION_GROUP_QUALIFIER    ',clc$nominal_entry, 4],
    ['DGQ                            ',clc$abbreviation_entry, 4],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NEXT_HOP_NAME                  ',clc$nominal_entry, 2],
    ['NHN                            ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 171, clc$required_parameter, 0, 0],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    8, [[1, 0, clc$string_type], [1, 31, FALSE]]
    ],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    8, [[1, 0, clc$string_type], [1, 31, FALSE]]
    ],
{ PARAMETER 3
    [[1, 0, clc$list_type], [155, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [4], [
      ['NTFI                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NTFS                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['QTFI                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['QTFS                           ', clc$nominal_entry,
  clc$normal_usage_entry, 4]]
      ]
    ],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$next_hop_name = 2,
      p$application_qualifier = 3,
      p$destination_group_qualifier = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;
*DECK DECK=NFT$PDT_DISPLAY_SF_NETWORK EXPAND=FALSE

{ PROCEDURE display_store_forward_network (
{   name, n: any of
{       name
{       string 1..31
{     anyend = $optional
{   application_qualifier, aq: key
{       ntfi
{       ntfs
{       qtfi
{       qtfs
{     keyend = $optional
{   display_option, display_options, do: list of key
{       (application_name_switch ans)
{       (destination_group destination_groups dg)
{       (destination_name_switch dns)
{       (source_name_switch sns)
{       all
{     keyend = all
{   output, o : file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 10] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 5, 27, 16, 4, 22, 339],
    clc$command, 10, 5, 0, 0, 0, 0, 5, 'DISPLAY_STORE_FORWARD_NETWORK'], [
    ['APPLICATION_QUALIFIER          ',clc$nominal_entry, 2],
    ['AQ                             ',clc$abbreviation_entry, 2],
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 3],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 3],
    ['DO                             ',clc$abbreviation_entry, 3],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OUTPUT                         ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 393, clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    8, [[1, 0, clc$string_type], [1, 31, FALSE]]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['NTFI                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['NTFS                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['QTFI                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['QTFS                           ', clc$nominal_entry,
  clc$normal_usage_entry, 4]]
    ],
{ PARAMETER 3
    [[1, 0, clc$list_type], [377, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [10], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
      ['ANS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
      ['APPLICATION_NAME_SWITCH        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['DESTINATION_GROUP              ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['DESTINATION_GROUPS             ', clc$alias_entry,
  clc$normal_usage_entry, 2],
      ['DESTINATION_NAME_SWITCH        ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['DG                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
      ['DNS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
      ['SNS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
      ['SOURCE_NAME_SWITCH             ', clc$nominal_entry,
  clc$normal_usage_entry, 4]]
      ]
    ,
    'all'],
{ PARAMETER 4
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$name = 1,
    p$application_qualifier = 2,
    p$display_option = 3,
    p$output = 4,
    p$status = 5;

  VAR
    pvt: array [1 .. 5] of clt$parameter_value;
*DECK DECK=NFT$PDT_GENERATE_SF_NETWORK EXPAND=FALSE

{ PROCEDURE generate_store_forward_network (
{   output, o : file = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 5, 27, 14, 44, 38, 581],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'GENERATE_STORE_FORWARD_NETWORK'], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$output = 1,
    p$status = 2;

  VAR
    pvt: array [1 .. 2] of clt$parameter_value;
*DECK DECK=NFT$PDT_INSTALL_SF_NETWORK EXPAND=FALSE

{ PROCEDURE install_store_forward_network (
{   input, i : file = $required
{   error, e : file = $errors
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 5, 27, 14, 44, 49, 97],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'INSTALL_STORE_FORWARD_NETWORK'], [
    ['E                              ',clc$abbreviation_entry, 2],
    ['ERROR                          ',clc$nominal_entry, 2],
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$errors'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$input = 1,
    p$error = 2,
    p$status = 3;

  VAR
    pvt: array [1 .. 3] of clt$parameter_value;
*DECK DECK=NFT$PDT_MANAGE_SF_NETWORK EXPAND=FALSE

{ PROCEDURE manage_store_forward_network (
{   status)

?? PUSH (LISTEXT := ON) ??

  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,
      recend,
    recend := [
    [1,
    [88, 5, 27, 14, 46, 40, 113],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'MANAGE_STORE_FORWARD_NETWORK'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$status = 1;

  VAR
    pvt: array [1 .. 1] of clt$parameter_value;
*DECK DECK=NFT$PDT_QUIT_STORE_FORWARD EXPAND=FALSE

{ PROCEDURE quit_store_forward_network ()

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [88, 5, 27, 14, 48, 22, 908],
    clc$command, 0, 0, 0, 0, 0, 0, 0, 'QUIT_STORE_FORWARD_NETWORK']];

?? POP ??
*DECK DECK=NFT$PDT_SUBMIT_MULTI_RECORD_JOB EXPAND=FALSE

{ PROCEDURE (osm$submrj) submit_multi_record_job, submrj (
{   file, files, f: list of file = $required
{   job_destination, jd: any of
{       name
{       string 1..31
{     anyend = $required
{   job_destination_usage, jdu: any of
{       key
{         ntf, qtf
{         hidden_key
{           ve, ve_local, ve_qtf
{       keyend
{       name
{     anyend = qtf
{   output_disposition, odi: key
{       (discard_all_output, dao)
{       (discard_standard_output, dso)
{       (local, l)
{       (printer, p)
{       (wait_queue, wt, wq)
{     keyend = printer
{   remote_host_directive, rhd: string 0..256 = ''
{   user_job_name, ujn: name = $optional
{   system_job_name, sjn: (VAR) name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 16] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type3: 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 .. 5] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 11] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (2),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 1, 17, 14, 13, 51, 949],
    clc$command, 16, 8, 2, 0, 0, 1, 8, 'OSM$SUBMRJ'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['FILES                          ',clc$alias_entry, 1],
    ['JD                             ',clc$abbreviation_entry, 2],
    ['JDU                            ',clc$abbreviation_entry, 3],
    ['JOB_DESTINATION                ',clc$nominal_entry, 2],
    ['JOB_DESTINATION_USAGE          ',clc$nominal_entry, 3],
    ['ODI                            ',clc$abbreviation_entry, 4],
    ['OUTPUT_DISPOSITION             ',clc$nominal_entry, 4],
    ['REMOTE_HOST_DIRECTIVE          ',clc$nominal_entry, 5],
    ['RHD                            ',clc$abbreviation_entry, 5],
    ['SJN                            ',clc$abbreviation_entry, 7],
    ['STATUS                         ',clc$nominal_entry, 8],
    ['SYSTEM_JOB_NAME                ',clc$nominal_entry, 7],
    ['UJN                            ',clc$abbreviation_entry, 6],
    ['USER_JOB_NAME                  ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 19, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 217, clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 414, clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 2],
{ PARAMETER 6
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    8, [[1, 0, clc$string_type], [1, 31, FALSE]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    192, [[1, 0, clc$keyword_type], [5], [
      ['NTF                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['QTF                            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['VE                             ', clc$nominal_entry, clc$hidden_entry,
  3],
      ['VE_LOCAL                       ', clc$nominal_entry, clc$hidden_entry,
  4],
      ['VE_QTF                         ', clc$nominal_entry, clc$hidden_entry,
  5]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'qtf'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [11], [
    ['DAO                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['DISCARD_ALL_OUTPUT             ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['DISCARD_STANDARD_OUTPUT        ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['DSO                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['LOCAL                          ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['P                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
    ['PRINTER                        ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['WAIT_QUEUE                     ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
    ['WQ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
    ['WT                             ', clc$alias_entry,
  clc$normal_usage_entry, 5]]
    ,
    'printer'],
{ PARAMETER 5
    [[1, 0, clc$string_type], [0, 256, FALSE],
    ''''''],
{ PARAMETER 6
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 7
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$job_destination = 2,
      p$job_destination_usage = 3,
      p$output_disposition = 4,
      p$remote_host_directive = 5,
      p$user_job_name = 6,
      p$system_job_name = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;
*DECK DECK=NFT$PDT_VERIFY_SF_NETWORK EXPAND=FALSE

{ PROCEDURE verify_store_forward_network (
{   input, i : file = $required
{   output, o : file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 5, 27, 14, 49, 40, 671],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'VERIFY_STORE_FORWARD_NETWORK'], [
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$input = 1,
    p$output = 2,
    p$status = 3;

  VAR
    pvt: array [1 .. 3] of clt$parameter_value;
*DECK DECK=NFT$PM_MESSAGE_ACTIONS EXPAND=FALSE
  TYPE
    nft$pm_message_actions = (nfc$print_pm_message, nfc$display_message_to_operator,
          nfc$discard_pm_message_line);
*DECK DECK=NFT$POSITION_FILE_DIRECTION EXPAND=FALSE
  TYPE
    nft$position_file_direction = (nfc$position_file_backwards, nfc$position_file_forwards);

*DECK DECK=NFT$POSITION_FILE_FROM_POSITION EXPAND=FALSE
  TYPE
    nft$position_file_from_position = (nfc$last_line_printed, nfc$beginning_of_file, nfc$end_of_file);

*DECK DECK=NFT$POSITION_FILE_LOCATE_COUNT EXPAND=FALSE
  CONST
    nfc$posf_max_locate_count = 65535;

  TYPE
    nft$position_file_locate_count = 0 .. nfc$posf_max_locate_count;

*DECK DECK=NFT$POSITION_FILE_LOCATE_STRING EXPAND=FALSE
  CONST
    nfc$posf_max_string_length = 255;

  TYPE
    nft$position_file_locate_string = string ( * <= nfc$posf_max_string_length);

*DECK DECK=NFT$POSITION_FILE_MSG EXPAND=FALSE
  TYPE
    nft$position_file_msg_parameter = packed record
      length_indicated: boolean,
      param: nft$position_file_parameters,
    recend,

    nft$position_file_parameters = (nfc$null_parameter, nfc$io_station_name, nfc$device_name,
      nfc$location_integer, nfc$location_string_1, nfc$location_string_2, nfc$units, nfc$direction,
      nfc$starting_position, nfc$preview_line_count, nfc$posf_reserved_10, nfc$posf_reserved_11,
      nfc$posf_reserved_12, nfc$posf_reserved_13, nfc$posf_reserved_14, nfc$posf_reserved_15,
      nfc$posf_reserved_16, nfc$posf_reserved_17, nfc$posf_reserved_18, nfc$posf_reserved_19,
      nfc$posf_reserved_20, nfc$posf_reserved_21, nfc$posf_reserved_22, nfc$posf_reserved_23,
      nfc$posf_reserved_24, nfc$posf_reserved_25, nfc$posf_reserved_26, nfc$posf_reserved_27,
      nfc$posf_reserved_28, nfc$posf_reserved_29, nfc$posf_reserved_30, nfc$posf_reserved_31,
      nfc$posf_reserved_32, nfc$posf_reserved_33, nfc$posf_reserved_34, nfc$posf_reserved_35,
      nfc$posf_reserved_36, nfc$posf_reserved_37, nfc$posf_reserved_38, nfc$posf_reserved_39,
      nfc$posf_reserved_40, nfc$posf_reserved_41, nfc$posf_reserved_42, nfc$posf_reserved_43,
      nfc$posf_reserved_44, nfc$posf_reserved_45, nfc$posf_reserved_46, nfc$posf_reserved_47,
      nfc$posf_reserved_48, nfc$posf_reserved_49, nfc$posf_reserved_50, nfc$posf_reserved_51,
      nfc$posf_reserved_52, nfc$posf_reserved_53, nfc$posf_reserved_54, nfc$posf_reserved_55,
      nfc$posf_reserved_56, nfc$posf_reserved_57, nfc$posf_reserved_58, nfc$posf_reserved_59,
      nfc$posf_reserved_60, nfc$posf_reserved_61, nfc$posf_reserved_62, nfc$posf_reserved_63,
      nfc$posf_reserved_64, nfc$posf_reserved_65);

*DECK DECK=NFT$POSITION_FILE_PARAM_TYPES EXPAND=FALSE
*copyc nft$position_file_direction
*copyc nft$position_file_from_position
*copyc nft$position_file_locate_count
*copyc nft$position_file_locate_string
*copyc nft$position_file_preview_count
*copyc nft$position_file_units
*DECK DECK=NFT$POSITION_FILE_PREVIEW_COUNT EXPAND=FALSE
  CONST
    nfc$posf_max_preview_count = 10;

  TYPE
    nft$position_file_preview_count = 0 .. nfc$posf_max_preview_count;

*DECK DECK=NFT$POSITION_FILE_UNITS EXPAND=FALSE
  TYPE
    nft$position_file_units = (nfc$position_file_page, nfc$position_file_line);

*DECK DECK=NFT$PRIORITY EXPAND=FALSE
  CONST
    nfc$minimum_priority = 100,
    nfc$low_output_priority = 0,
    nfc$medium_output_priority = 1500,
    nfc$high_output_priority = 3000,
    nfc$maximum_priority = 3700;

  TYPE
    nft$priority = integer;

*DECK DECK=NFT$PRIORITY_MULTIPLIER EXPAND=FALSE
  TYPE
    nft$priority_multiplier = integer;

*DECK DECK=NFT$PROTOCOL_COMMANDS EXPAND=FALSE
?? NEWTITLE := 'nft$protocol_commands' ??

{ nft$protocol_commands }

  TYPE
    nft$protocol_commands = (nfc$unknown_command, nfc$rft, nfc$rpos, nfc$rneg,
          nfc$go, nfc$stop, nfc$stopr, nfc$etp, nfc$etpr, nfc$fini);

?? OLDTITLE ??
*DECK DECK=NFT$PROTOCOL_PARAMETERS EXPAND=FALSE

?? NEWTITLE := 'nft$protocol_parameters' ??

{ nft$protocol_parameters }

  TYPE
    nft$protocol_parameters = (nfc$protocol_id, nfc$maximum_file_length,
          nfc$transfer_id, nfc$facilities, nfc$state_of_transfer,
          nfc$user_text_directive, nfc$file_length, nfc$operator_message,
          nfc$user_message, nfc$account_message, nfc$error_log_message,
          nfc$special_options, nfc$max_block_size, nfc$accounting_limit,
          nfc$file_name, nfc$file_disposition, nfc$acknowledgment_window,
          nfc$initial_checkmark, nfc$minimum_timeout_interval,
          nfc$mode_of_access, nfc$host_type, nfc$transfer_phase_attribute,
          nfc$source_lid, nfc$transfer_lid, nfc$job_name, nfc$physical_id,
          nfc$destination_host_type, nfc$echo, nfc$attribute_continued,
          nfc$data_declaration, nfc$system_routing_text,
          nfc$implicit_routing_text, nfc$user_file_name,
          nfc$banner_date_and_time, nfc$banner_routing_text,
          nfc$user_banner_text, nfc$installation_banner_text,
          nfc$reposition_output_params, nfc$current_file_position,
          nfc$output_file_destination,
          nfc$vertical_print_density, nfc$vfu_load_procedure,
          nfc$reserved_for_site_90,
          nfc$reserved_for_site_91, nfc$reserved_for_site_92,
          nfc$reserved_for_site_93, nfc$reserved_for_site_94,
          nfc$reserved_for_site_95, nfc$reserved_for_site_96,
          nfc$reserved_for_site_97, nfc$reserved_for_site_98,
          nfc$reserved_for_site_99);

?? OLDTITLE ??
*DECK DECK=NFT$PROTOCOL_TRACE_INFO EXPAND=FALSE

  TYPE
    nft$protocol_trace_values = record
      application_name: ost$string,
      appl_client_or_server_name: ost$string,
    recend;

  TYPE
    nft$protocol_trace_info = array [nft$application_values]
      of nft$protocol_trace_values;

*copyc nft$application_values
*copyc ost$string
*DECK DECK=NFT$PTFS_JOB_SUBMIT_BLOCK EXPAND=FALSE
?? NEWTITLE := 'nft$ptfs_job_submit_block' ??

{ nft$ptfs_job_submit_block }

  TYPE
    nft$ptfs_job_submit_block = nft$network_address;

*copyc nft$network_address
?? OLDTITLE ??
*DECK DECK=NFT$PTF_PROTOCOL_STATES EXPAND=FALSE
?? NEWTITLE := 'nft$ptf_protocol_states' ??

{ nft$ptf_protocol_states }

  TYPE
    nft$protocol_actions = (nfc$ptf_send_command, nfc$ptf_start_transfer,
          nfc$ptf_receive_command, nfc$ptf_terminate);

  CONST
    nfc$ptf_number_pstates = 11;

  TYPE
    nft$ptfi_state_table = record
      last_command_sent: nft$last_command_sent,
      last_command_received: nft$last_command_received,
      data_xfer_complete: boolean,
      case action: nft$protocol_actions of
      = nfc$ptf_send_command =
        send_command: nft$protocol_commands,
        send_parameters: nft$parameter_set,
      = nfc$ptf_receive_command =
        legal_receive_commands: nft$command_set,
      = nfc$ptf_start_transfer =
        xfer_send_command: nft$protocol_commands,
        xfer_send_parameters: nft$parameter_set,
      = nfc$ptf_terminate =
      casend,
    recend;

  TYPE
    nft$ptf_protocol_states = array [1 .. nfc$ptf_number_pstates] of
          nft$ptfi_state_table;

*copyc nft$last_command_sent
*copyc nft$last_command_received
*copyc nft$parameter_set
*copyc nft$protocol_commands
*copyc nft$command_set

?? OLDTITLE ??
*DECK DECK=NFT$QTF_CONTROLLER_PDT EXPAND=FALSE
{ PROCEDURE qtfc_command_pdt (
{   host_physical_identifier, hpi: string 1..31 = $required
{   maximum_qtfi_subtasks, mqs: integer 0..20 = $optional
{   single_transfer_per_connection, stpc: boolean = false
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          recend,
          type3: record
            header: clt$type_specification_header,
            default_value: string (5),
            recend,
            type4: record
              header: clt$type_specification_header,
              recend,
    recend := [
    [1,
    [91, 2, 12, 15, 11, 19, 355],
    clc$command, 7, 4, 1, 0, 0, 0, 4, ''], [
    ['HOST_PHYSICAL_IDENTIFIER       ',clc$nominal_entry, 1],
    ['HPI                            ',clc$abbreviation_entry, 1],
    ['MAXIMUM_QTFI_SUBTASKS          ',clc$nominal_entry, 2],
    ['MQS                            ',clc$abbreviation_entry, 2],
    ['SINGLE_TRANSFER_PER_CONNECTION ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['STPC                           ',clc$abbreviation_entry, 3]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [1, 31, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, 20, 10]],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$host_physical_identifier = 1,
      p$maximum_qtfi_subtasks = 2,
      p$single_transfer_per_connectio = 3 {SINGLE_TRANSFER_PER_CONNECTION} ,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;
*DECK DECK=NFT$QTF_INPUT_ACCOUNTING_DATA EXPAND=FALSE

  TYPE
    nft$qtf_input_accounting_data = record
      origin_mainframe_name: ost$name,
      dest_mainframe_name: ost$name,
      file_size: amt$file_length,
    recend;

*copyc amt$file_length
*copyc ost$name
*DECK DECK=NFT$QTF_TRANSFER_STATUS EXPAND=FALSE
  TYPE
    nft$qtf_transfer_status = (nfc$qtf_transfer_complete,
      nfc$qtf_transfer_failed_retry, nfc$qtf_transfer_failed_noretry,
      nfc$qtf_transfer_network_failed, nfc$qtf_transfer_aborted);

*DECK DECK=NFT$QUEUE_ENTRY_DATA_MSG EXPAND=FALSE
*copyc nft$display_status_resp_codes
  TYPE
    nft$queue_entry_msg_parameter = packed record
      length_indicated: boolean,
      param: nft$queue_entry_parameters,
    recend,

    nft$queue_entry_parameters = (nfc$null_parameter, nfc$io_station_name,
      nfc$system_file_name, nfc$response_code, nfc$user_file_name,
      nfc$time_enqueued, nfc$position_in_queue, nfc$priority, nfc$copies,
      nfc$create_job_family_name, nfc$create_system_job_name,
      nfc$create_user_job_name, nfc$destination_name, nfc$device_type,
      nfc$file_length, nfc$output_data_mode, nfc$device_name,
      nfc$external_characteristics, nfc$forms_code, nfc$page_format,
      nfc$page_length, nfc$page_width,nfc$vertical_print_density,
      nfc$vfu_load_procedure, nfc$creating_user_name, nfc$scfs_output_status,
      nfc$queue_entry_data_continues, nfc$queue_entry_reserved_27,
      nfc$queue_entry_reserved_28, nfc$queue_entry_reserved_29,
      nfc$queue_entry_reserved_30, nfc$queue_entry_reserved_31,
      nfc$queue_entry_reserved_32, nfc$queue_entry_reserved_33,
      nfc$queue_entry_reserved_34, nfc$queue_entry_reserved_35,
      nfc$queue_entry_reserved_36, nfc$queue_entry_reserved_37,
      nfc$queue_entry_reserved_38, nfc$queue_entry_reserved_39,
      nfc$queue_entry_reserved_40, nfc$queue_entry_reserved_41,
      nfc$queue_entry_reserved_42, nfc$queue_entry_reserved_43,
      nfc$queue_entry_reserved_44, nfc$queue_entry_reserved_45,
      nfc$queue_entry_reserved_46, nfc$queue_entry_reserved_47,
      nfc$queue_entry_reserved_48, nfc$queue_entry_reserved_49,
      nfc$queue_entry_reserved_50, nfc$queue_entry_reserved_51,
      nfc$queue_entry_reserved_52, nfc$queue_entry_reserved_53,
      nfc$queue_entry_reserved_54, nfc$queue_entry_reserved_55,
      nfc$queue_entry_reserved_56, nfc$queue_entry_reserved_57,
      nfc$queue_entry_reserved_58, nfc$queue_entry_reserved_59,
      nfc$queue_entry_reserved_60, nfc$queue_entry_reserved_61,
      nfc$queue_entry_reserved_62, nfc$queue_entry_reserved_63,
      nfc$queue_entry_reserved_64, nfc$queue_entry_reserved_65);

*DECK DECK=NFT$QUEUE_STATUS_DATA_MSG EXPAND=FALSE
*copyc nft$display_status_resp_codes
  TYPE
    nft$queue_status_msg_parameter = packed record
      length_indicated: boolean,
      param: nft$queue_status_parameters,
    recend,

    nft$queue_status_parameters = (nfc$null_parameter, nfc$io_station_name, nfc$file_count, nfc$response_code,
      nfc$ext_chars_count, nfc$ext_char_and_files, nfc$forms_code_count, nfc$forms_code_and_files,
      nfc$device_count, nfc$device_names_and_files, nfc$destination_count, nfc$destinations_and_files,
      nfc$device_type_count, nfc$device_types_and_files, nfc$queue_status_reserved_14,
      nfc$queue_status_reserved_15, nfc$queue_status_reserved_16, nfc$queue_status_reserved_17,
      nfc$queue_status_reserved_18, nfc$queue_status_reserved_19, nfc$queue_status_reserved_20,
      nfc$queue_status_reserved_21, nfc$queue_status_reserved_22, nfc$queue_status_reserved_23,
      nfc$queue_status_reserved_24, nfc$queue_status_reserved_25, nfc$queue_status_reserved_26,
      nfc$queue_status_reserved_27, nfc$queue_status_reserved_28, nfc$queue_status_reserved_29,
      nfc$queue_status_reserved_30, nfc$queue_status_reserved_31, nfc$queue_status_reserved_32,
      nfc$queue_status_reserved_33, nfc$queue_status_reserved_34, nfc$queue_status_reserved_35,
      nfc$queue_status_reserved_36, nfc$queue_status_reserved_37, nfc$queue_status_reserved_38,
      nfc$queue_status_reserved_39, nfc$queue_status_reserved_40, nfc$queue_status_reserved_41,
      nfc$queue_status_reserved_42, nfc$queue_status_reserved_43, nfc$queue_status_reserved_44,
      nfc$queue_status_reserved_45, nfc$queue_status_reserved_46, nfc$queue_status_reserved_47,
      nfc$queue_status_reserved_48, nfc$queue_status_reserved_49, nfc$queue_status_reserved_50,
      nfc$queue_status_reserved_51, nfc$queue_status_reserved_52, nfc$queue_status_reserved_53,
      nfc$queue_status_reserved_54, nfc$queue_status_reserved_55, nfc$queue_status_reserved_56,
      nfc$queue_status_reserved_57, nfc$queue_status_reserved_58, nfc$queue_status_reserved_59,
      nfc$queue_status_reserved_60, nfc$queue_status_reserved_61, nfc$queue_status_reserved_62,
      nfc$queue_status_reserved_63, nfc$queue_status_reserved_64, nfc$queue_status_reserved_65);

*DECK DECK=NFT$Q_ENTRY_LIST_DATA_MSG EXPAND=FALSE
*copyc nft$display_status_resp_codes
  TYPE
    nft$q_entry_list_data_msg_param = packed record
      length_indicated: boolean,
      param: nft$q_entry_list_data_params,
    recend,

    nft$q_entry_list_data_params = (nfc$null_parameter, nfc$io_station_name, nfc$response_code,
      nfc$number_of_files, nfc$sys_file_and_priority, nfc$qeld_reserved_5, nfc$qeld_reserved_6,
      nfc$qeld_reserved_7, nfc$qeld_reserved_8, nfc$qeld_reserved_9, nfc$qeld_reserved_10,
      nfc$qeld_reserved_11, nfc$qeld_reserved_12, nfc$qeld_reserved_13, nfc$qeld_reserved_14,
      nfc$qeld_reserved_15, nfc$qeld_reserved_16, nfc$qeld_reserved_17, nfc$qeld_reserved_18,
      nfc$qeld_reserved_19, nfc$qeld_reserved_20, nfc$qeld_reserved_21, nfc$qeld_reserved_22,
      nfc$qeld_reserved_23, nfc$qeld_reserved_24, nfc$qeld_reserved_25, nfc$qeld_reserved_26,
      nfc$qeld_reserved_27, nfc$qeld_reserved_28, nfc$qeld_reserved_29, nfc$qeld_reserved_30,
      nfc$qeld_reserved_31, nfc$qeld_reserved_32, nfc$qeld_reserved_33, nfc$qeld_reserved_34,
      nfc$qeld_reserved_35, nfc$qeld_reserved_36, nfc$qeld_reserved_37, nfc$qeld_reserved_38,
      nfc$qeld_reserved_39, nfc$qeld_reserved_40, nfc$qeld_reserved_41, nfc$qeld_reserved_42,
      nfc$qeld_reserved_43, nfc$qeld_reserved_44, nfc$qeld_reserved_45, nfc$qeld_reserved_46,
      nfc$qeld_reserved_47, nfc$qeld_reserved_48, nfc$qeld_reserved_49, nfc$qeld_reserved_50,
      nfc$qeld_reserved_51, nfc$qeld_reserved_52, nfc$qeld_reserved_53, nfc$qeld_reserved_54,
      nfc$qeld_reserved_55, nfc$qeld_reserved_56, nfc$qeld_reserved_57, nfc$qeld_reserved_58,
      nfc$qeld_reserved_59, nfc$qeld_reserved_60, nfc$qeld_reserved_61, nfc$qeld_reserved_62,
      nfc$qeld_reserved_63, nfc$qeld_reserved_64, nfc$qeld_reserved_65);

*DECK DECK=NFT$Q_STATUS_DATA EXPAND=FALSE
*copyc ost$name
  CONST
    nfc$fixed_q_status_data_length = 32 + (2 * osc$max_name_size);

  TYPE
    nft$q_status_data = record
      file_count: integer,
      total_size: integer,
      oldest_age: integer,
      average_age: integer,
      operator_name: ost$name,
      operator_family: ost$name,
      name: string ( * <= osc$max_name_size),
    recend;

*DECK DECK=NFT$REMOTE_VALIDATION EXPAND=TRUE

  TYPE
    nft$remote_validation = RECORD
      next_entry: ^nft$remote_validation,
      location: ost$name,
      text: ARRAY [1 .. *] OF STRING (osc$max_string_size),
    RECEND;

  CONST
    nfc$max_validation_lines = 7fffffff(16);
*DECK DECK=NFT$REQUIRED_PARAM_ON_COMMAND EXPAND=FALSE
?? NEWTITLE := 'nft$required_param_on_command' ??

{ nft$required_param_on_command }

  TYPE
    nft$required_param_on_command = array [nft$protocol_commands] of
          nft$parameter_set;

*copyc nft$parameter_set
*copyc nft$protocol_commands
?? OLDTITLE ??
*DECK DECK=NFT$SCFS_CLIENT_IDENTIFIER EXPAND=FALSE
  TYPE
    nft$scfs_client_identifier = record
      data_version: 0 .. 0ff(16),
      identifier: string ( * <= nfc$max_scfs_client_id_length),
    recend;

  CONST
    nfc$scfs_client_data_version = 1,

    nfc$ntf_ve_client = 'NTFVE',     { NTF VE Client.
    nfc$ntf_ve_client_length = 5,
    nfc$opentf_ve_client = 'OPENTF', { Operate NTF VE Client.
    nfc$opentf_ve_client_length = 6,
    nfc$opes_ve_client = 'OPESVE',   { Operate Station VE Client.
    nfc$opes_ve_client_length = 6,
    nfc$scf_di_client = 'SCFDI',     { SCF DI Client.
    nfc$scf_di_client_length = 5,
    nfc$scf_ve_client = 'SCFVE',     { SCF VE Client.
    nfc$scf_ve_client_length = 5,
    nfc$scfs_ve_client = 'SCFSVE',   { SCFS VE with different priority.
    nfc$scfs_ve_client_length = 6,

    nfc$min_scfs_client_id_length = 5,
    nfc$max_scfs_client_id_length = 31;

*DECK DECK=NFT$SCFS_PDT EXPAND=FALSE
{ PDT scfs_command_pdt (
{   control_facility, cf : NAME = $REQUIRED
{   server, s : NAME = $REQUIRED
{   logging, l : BOOLEAN = off
{   ntf_system_list, nsl : FILE = $OPTIONAL
{   STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    scfs_command_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^scfs_command_pdt_names,
      ^scfs_command_pdt_params];

  VAR
    scfs_command_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 9] of
      clt$parameter_name_descriptor := [['CONTROL_FACILITY', 1], ['CF', 1], ['SERVER', 2], ['S', 2], [
      'LOGGING', 3], ['L', 3], ['NTF_SYSTEM_LIST', 4], ['NSL', 4], ['STATUS', 5]];

  VAR
    scfs_command_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of clt$parameter_descriptor
      := [

{ CONTROL_FACILITY CF }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ SERVER S }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ LOGGING L }
    [[clc$optional_with_default, ^scfs_command_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$boolean_value]],

{ NTF_SYSTEM_LIST NSL }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    scfs_command_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'off';

?? POP ??
*DECK DECK=NFT$SCF_PDT EXPAND=FALSE
{ PDT scf_command_pdt (
{   STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    scf_command_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^scf_command_pdt_names,
      ^scf_command_pdt_params];

  VAR
    scf_command_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
      clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    scf_command_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
*DECK DECK=NFT$SELECT_FILE_MSG EXPAND=FALSE
  TYPE
    nft$select_file_parameter = packed record
      length_indicated: boolean,
      param: nft$select_file_parameters,
    recend;

  TYPE
    nft$select_file_parameters = (nfc$null_parameter, nfc$io_station_name, nfc$system_file_name,
      nfc$device_name, nfc$self_reserved_4, nfc$self_reserved_5, nfc$self_reserved_6, nfc$self_reserved_7,
      nfc$self_reserved_8, nfc$self_reserved_9, nfc$self_reserved_10, nfc$self_reserved_11,
      nfc$self_reserved_12, nfc$self_reserved_13, nfc$self_reserved_14, nfc$self_reserved_15,
      nfc$self_reserved_16, nfc$self_reserved_17, nfc$self_reserved_18, nfc$self_reserved_19,
      nfc$self_reserved_20, nfc$self_reserved_21, nfc$self_reserved_22, nfc$self_reserved_23,
      nfc$self_reserved_24, nfc$self_reserved_25, nfc$self_reserved_26, nfc$self_reserved_27,
      nfc$self_reserved_28, nfc$self_reserved_29, nfc$self_reserved_30, nfc$self_reserved_31,
      nfc$self_reserved_32, nfc$self_reserved_33, nfc$self_reserved_34, nfc$self_reserved_35,
      nfc$self_reserved_36, nfc$self_reserved_37, nfc$self_reserved_38, nfc$self_reserved_39,
      nfc$self_reserved_40, nfc$self_reserved_41, nfc$self_reserved_42, nfc$self_reserved_43,
      nfc$self_reserved_44, nfc$self_reserved_45, nfc$self_reserved_46, nfc$self_reserved_47,
      nfc$self_reserved_48, nfc$self_reserved_49, nfc$self_reserved_50, nfc$self_reserved_51,
      nfc$self_reserved_52, nfc$self_reserved_53, nfc$self_reserved_54, nfc$self_reserved_55,
      nfc$self_reserved_56, nfc$self_reserved_57, nfc$self_reserved_58, nfc$self_reserved_59,
      nfc$self_reserved_60, nfc$self_reserved_61, nfc$self_reserved_62, nfc$self_reserved_63,
      nfc$self_reserved_64, nfc$self_reserved_65);

*DECK DECK=NFT$SELECT_FILE_RESPONSE EXPAND=FALSE
  TYPE
    nft$select_file_response = (nfc$self_msg_accepted, nfc$self_msg_unknown_ios, nfc$self_msg_unknown_device,
      nfc$self_msg_unknown_file, nfc$self_file_already_printing, nfc$self_wrong_device_type,
      nfc$self_duplicate_file_name);

*DECK DECK=NFT$SELECT_FILE_RESPONSE_MSG EXPAND=FALSE
  TYPE
    nft$select_file_resp_parameter = packed record
      length_indicated: boolean,
      param: nft$select_file_resp_params,
    recend;

  TYPE
    nft$select_file_resp_params = (nfc$null_parameter, nfc$io_station_name, nfc$system_file_name,
      nfc$response_code, nfc$device_name, nfc$selfr_reserved_5, nfc$selfr_reserved_6, nfc$selfr_reserved_7,
      nfc$selfr_reserved_8, nfc$selfr_reserved_9, nfc$selfr_reserved_10, nfc$selfr_reserved_11,
      nfc$selfr_reserved_12, nfc$selfr_reserved_13, nfc$selfr_reserved_14, nfc$selfr_reserved_15,
      nfc$selfr_reserved_16, nfc$selfr_reserved_17, nfc$selfr_reserved_18, nfc$selfr_reserved_19,
      nfc$selfr_reserved_20, nfc$selfr_reserved_21, nfc$selfr_reserved_22, nfc$selfr_reserved_23,
      nfc$selfr_reserved_24, nfc$selfr_reserved_25, nfc$selfr_reserved_26, nfc$selfr_reserved_27,
      nfc$selfr_reserved_28, nfc$selfr_reserved_29, nfc$selfr_reserved_30, nfc$selfr_reserved_31,
      nfc$selfr_reserved_32, nfc$selfr_reserved_33, nfc$selfr_reserved_34, nfc$selfr_reserved_35,
      nfc$selfr_reserved_36, nfc$selfr_reserved_37, nfc$selfr_reserved_38, nfc$selfr_reserved_39,
      nfc$selfr_reserved_40, nfc$selfr_reserved_41, nfc$selfr_reserved_42, nfc$selfr_reserved_43,
      nfc$selfr_reserved_44, nfc$selfr_reserved_45, nfc$selfr_reserved_46, nfc$selfr_reserved_47,
      nfc$selfr_reserved_48, nfc$selfr_reserved_49, nfc$selfr_reserved_50, nfc$selfr_reserved_51,
      nfc$selfr_reserved_52, nfc$selfr_reserved_53, nfc$selfr_reserved_54, nfc$selfr_reserved_55,
      nfc$selfr_reserved_56, nfc$selfr_reserved_57, nfc$selfr_reserved_58, nfc$selfr_reserved_59,
      nfc$selfr_reserved_60, nfc$selfr_reserved_61, nfc$selfr_reserved_62, nfc$selfr_reserved_63,
      nfc$selfr_reserved_64, nfc$selfr_reserved_65);


*DECK DECK=NFT$SF_APPLICATIONS EXPAND=FALSE

  TYPE
    nft$sf_applications = (nfc$sf_unknown_application, nfc$sf_ntf_initiator,
          nfc$sf_ntf_server, nfc$sf_qtf_initiator, nfc$sf_qtf_server);
*DECK DECK=NFT$SF_APPLICATION_NAMES EXPAND=FALSE

  TYPE
    nft$sf_application_names = array [nft$sf_applications] of ost$name;

*copyc nft$sf_applications
*copyc ost$name
*DECK DECK=NFT$SF_APPLICATION_NAME_INFO EXPAND=FALSE

  TYPE
    nft$sf_application_name_info = record
      link: nft$sf_application_name_link,
      next_hop_application: ost$name,
      application_qualifier: nft$sf_application_set,
      destination_group_qualifier: ost$name,
    recend;

*copyc ost$name
*copyc nft$sf_application_name_link
*copyc nft$sf_application_set
*DECK DECK=NFT$SF_APPLICATION_NAME_LINK EXPAND=FALSE

  TYPE
    nft$sf_application_name_link = record
      case relative_pointer: boolean of
      = TRUE =
        relative_ptr: nft$sf_rel_ptr_appl_name_info,
      = FALSE =
        ptr: ^nft$sf_application_name_info,
      casend,
    recend;

*copyc nft$sf_rel_ptr_appl_name_info
*copyc nft$sf_application_name_info
*DECK DECK=NFT$SF_APPLICATION_SET EXPAND=FALSE

  TYPE
    nft$sf_application_set = set of nft$sf_applications;

*copyc nft$sf_applications
*DECK DECK=NFT$SF_DESTINATION_NAMES_ARRAY EXPAND=FALSE

  TYPE
    nft$sf_destination_names_array = array [1 .. *] of
          nft$parameter_24_definition;

*copyc nft$parameter_24_definition
*DECK DECK=NFT$SF_DESTINATION_NAMES_LINK EXPAND=FALSE

  TYPE
    nft$sf_destination_names_link = record
      case relative_pointer: boolean of
      = TRUE =
        relative_ptr: nft$sf_rel_ptr_dest_name_info,
      = FALSE =
        ptr: ^nft$sf_destination_names_array,
      casend,
    recend;

*copyc nft$sf_rel_ptr_dest_name_info
*copyc nft$sf_destination_names_array
*DECK DECK=NFT$SF_DEST_GROUP_COMPARISION EXPAND=FALSE

  TYPE
    nft$sf_dest_group_comparision = (nfc$sf_dest_groups_identical,
          nfc$sf_dest_groups_subset, nfc$sf_dest_groups_overlap,
          nfc$sf_dest_groups_unique, nfc$sf_dest_groups_not_found);
*DECK DECK=NFT$SF_DISPLAY_NAME_VALUE EXPAND=FALSE

  TYPE
    nft$sf_display_name_value = record
      case value_specified: boolean of
      = TRUE =
        value: ost$name,
      = FALSE =
        ,
      casend,
    recend;

*copyc ost$name
*DECK DECK=NFT$SF_DISPLAY_OPTIONS_SET EXPAND=FALSE

  TYPE
    nft$sf_display_options = (nfc$sf_display_applications,
          nfc$sf_display_group_names, nfc$sf_display_source_names,
          nfc$sf_display_target_names);

   TYPE
     nft$sf_display_options_set = set of nft$sf_display_options;
*DECK DECK=NFT$SF_GROUP_NAME_INFORMATION EXPAND=FALSE

  TYPE
    nft$sf_group_name_information = record
      link: nft$sf_group_name_link,
      group_name: ost$name,
      destination_name_count: ost$non_negative_integers,
      ptr_destination_names: nft$sf_destination_names_link,
    recend;

*copyc nft$sf_destination_names_link
*copyc nft$sf_group_name_link
*copyc osd$integer_limits
*copyc ost$name
*DECK DECK=NFT$SF_GROUP_NAME_LINK EXPAND=FALSE

  TYPE
    nft$sf_group_name_link = record
      case relative_pointer: boolean of
      = TRUE =
        relative_ptr: nft$sf_rel_ptr_group_name_info,
      = FALSE =
        ptr: ^nft$sf_group_name_information,
      casend,
    recend;

*copyc nft$sf_rel_ptr_group_name_info
*copyc nft$sf_group_name_information
*DECK DECK=NFT$SF_REL_PTR_APPL_NAME_INFO EXPAND=FALSE

  TYPE
    nft$sf_rel_ptr_appl_name_info = REL (nft$store_forward_sequence)
          ^nft$sf_application_name_info;

*copyc nft$sf_application_name_info
*copyc nft$store_forward_sequence
*DECK DECK=NFT$SF_REL_PTR_DEST_NAME_INFO EXPAND=FALSE

  TYPE
    nft$sf_rel_ptr_dest_name_info = REL (nft$store_forward_sequence)
          ^nft$sf_destination_names_array;

*copyc nft$sf_destination_names_array
*copyc nft$store_forward_sequence
*DECK DECK=NFT$SF_REL_PTR_GROUP_NAME_INFO EXPAND=FALSE

  TYPE
    nft$sf_rel_ptr_group_name_info = REL (nft$store_forward_sequence)
          ^nft$sf_group_name_information;

*copyc nft$sf_group_name_information
*copyc nft$store_forward_sequence
*DECK DECK=NFT$SF_REL_PTR_SOURCE_NAME_INFO EXPAND=FALSE

  TYPE
    nft$sf_rel_ptr_source_name_info = REL (nft$store_forward_sequence)
          ^nft$sf_source_name_information;

*copyc nft$sf_source_name_information
*copyc nft$store_forward_sequence
*DECK DECK=NFT$SF_REL_PTR_TARGET_NAME_INFO EXPAND=FALSE

  TYPE
    nft$sf_rel_ptr_target_name_info = REL (nft$store_forward_sequence)
          ^nft$sf_target_name_information;

*copyc nft$sf_target_name_information
*copyc nft$store_forward_sequence
*DECK DECK=NFT$SF_SOURCE_NAME_INFORMATION EXPAND=FALSE

  TYPE
    nft$sf_source_name_information = record
      link: nft$sf_source_name_link,
      source_name: nft$parameter_24_definition,
      next_hop_name: nft$parameter_24_definition,
      application_qualifier: nft$sf_application_set,
      destination_group_qualifier: ost$name,
    recend;

*copyc nft$parameter_24_definition
*copyc nft$sf_application_set
*copyc nft$sf_source_name_link
*copyc ost$name
*DECK DECK=NFT$SF_SOURCE_NAME_LINK EXPAND=FALSE

  TYPE
    nft$sf_source_name_link = record
      case relative_pointer: boolean of
      = TRUE =
        relative_ptr: nft$sf_rel_ptr_source_name_info,
      = FALSE =
        ptr: ^nft$sf_source_name_information,
      casend,
    recend;

*copyc nft$sf_rel_ptr_source_name_info
*copyc nft$sf_source_name_information
*DECK DECK=NFT$SF_TARGET_NAME_INFORMATION EXPAND=FALSE

  TYPE
    nft$sf_target_name_information = record
      link: nft$sf_target_name_link,
      target_name: nft$parameter_24_definition,
      next_hop_name: nft$parameter_24_definition,
      application_qualifier: nft$sf_application_set,
    recend;

*copyc nft$parameter_24_definition
*copyc nft$sf_application_set
*copyc nft$sf_target_name_link
*DECK DECK=NFT$SF_TARGET_NAME_LINK EXPAND=FALSE

  TYPE
    nft$sf_target_name_link = record
      case relative_pointer: boolean of
      = TRUE =
        relative_ptr: nft$sf_rel_ptr_target_name_info,
      = FALSE =
        ptr: ^nft$sf_target_name_information,
      casend,
    recend;

*copyc nft$sf_rel_ptr_target_name_info
*copyc nft$sf_target_name_information
*DECK DECK=NFT$SL_ACCOUNTING_HEADER EXPAND=TRUE

  TYPE
    nft$sl_accounting_header = packed record
      protocol_id: 0 .. 0ffff(16),
      caller_id: 0 .. 255,
    recend;
*DECK DECK=NFT$SOU_MESSAGE_PARAMETER_TYPES EXPAND=TRUE
?? PUSH (LISTEXT := ON) ??

{   Parameter types:  change batch device attributes
*copyc nft$banner_page_count
*copyc nft$banner_highlight_field
*copyc nft$carriage_control_action
*copyc nft$external_characteristics
*copyc nft$forms_code
*copyc nft$device_file_size
*copyc nft$page_length
*copyc nft$page_width
*copyc nft$terminal_model
*copyc nft$transmit_block_size
*copyc nft$code_set
*copyc nft$forms_size
*copyc nft$format_effector_actions
*copyc nft$vfu_load_option
*copyc nft$vertical_print_density
*copyc nft$vfu_load_procedure

{   Parameter types:  position file
*copyc nft$position_file_locate_count
*copyc nft$position_file_locate_string
*copyc nft$position_file_units
*copyc nft$position_file_direction
*copyc nft$position_file_from_position
*copyc nft$position_file_preview_count

{   Parameter types:  suppress carriage control
*copyc nft$suppress_carriage_control

{   Parameter types:  terminate transfer
*copyc nft$file_disposition

{   Parameter types:  stop batch device
*copyc nft$file_disposition

{   Parameter types:  add user response
*copyc nft$add_user_responses

{   Parameter types:  select file response
*copyc nft$select_file_response

{   Parameter_types:  terminate queued output response
*copyc nft$terqo_file_status_codes

{   Parameter types:  device status data
*copyc nft$device_status
*copyc nft$device_type
*copyc nft$file_position
*copyc nft$file_transfer_status
*copyc nft$input_job_size

{   Parameter types:  station status data
*copyc nft$device_status_data
*copyc nft$io_station_usage
*copyc nft$destination_unavail_actions
*copyc nft$pm_message_actions

{   Parameter types:  queue status data
*copyc nft$q_status_data

{   Parameter types: queue entry data
*copyc nft$file_size
*copyc nft$output_data_mode
*copyc nft$page_format
*copyc ost$date_time
*copyc nft$priority
*copyc nft$file_vertical_print_density

{   Parameter types: get queue entry list
*copyc nft$all_or_top_10_q_entries
*copyc nft$optimize_list

{   Parameter types: queue entry list data
*copyc nft$file_and_priority

{  Parameter types: miscellaneous response/data messages
*copyc nft$device_control_resp_codes
*copyc nft$display_status_resp_codes

?? POP ??
*DECK DECK=NFT$START_BATCH_DEVICE_MSG EXPAND=FALSE
  TYPE
    nft$start_bd_message_parameter = packed record
      length_indicated: boolean,
      param: nft$start_batch_device_params,
    recend;

  TYPE
    nft$start_batch_device_params = (nfc$null_parameter, nfc$io_station_name, nfc$device_name,
      nfc$start_bd_reserved_3, nfc$start_bd_reserved_4, nfc$start_bd_reserved_5, nfc$start_bd_reserved_6,
      nfc$start_bd_reserved_7, nfc$start_bd_reserved_8, nfc$start_bd_reserved_9, nfc$start_bd_reserved_10,
      nfc$start_bd_reserved_11, nfc$start_bd_reserved_12, nfc$start_bd_reserved_13, nfc$start_bd_reserved_14,
      nfc$start_bd_reserved_15, nfc$start_bd_reserved_16, nfc$start_bd_reserved_17, nfc$start_bd_reserved_18,
      nfc$start_bd_reserved_19, nfc$start_bd_reserved_20, nfc$start_bd_reserved_21, nfc$start_bd_reserved_22,
      nfc$start_bd_reserved_23, nfc$start_bd_reserved_24, nfc$start_bd_reserved_25, nfc$start_bd_reserved_26,
      nfc$start_bd_reserved_27, nfc$start_bd_reserved_28, nfc$start_bd_reserved_29, nfc$start_bd_reserved_30,
      nfc$start_bd_reserved_31, nfc$start_bd_reserved_32, nfc$start_bd_reserved_33, nfc$start_bd_reserved_34,
      nfc$start_bd_reserved_35, nfc$start_bd_reserved_36, nfc$start_bd_reserved_37, nfc$start_bd_reserved_38,
      nfc$start_bd_reserved_39, nfc$start_bd_reserved_40, nfc$start_bd_reserved_41, nfc$start_bd_reserved_42,
      nfc$start_bd_reserved_43, nfc$start_bd_reserved_44, nfc$start_bd_reserved_45, nfc$start_bd_reserved_46,
      nfc$start_bd_reserved_47, nfc$start_bd_reserved_48, nfc$start_bd_reserved_49, nfc$start_bd_reserved_50,
      nfc$start_bd_reserved_51, nfc$start_bd_reserved_52, nfc$start_bd_reserved_53, nfc$start_bd_reserved_54,
      nfc$start_bd_reserved_55, nfc$start_bd_reserved_56, nfc$start_bd_reserved_57, nfc$start_bd_reserved_58,
      nfc$start_bd_reserved_59, nfc$start_bd_reserved_60, nfc$start_bd_reserved_61, nfc$start_bd_reserved_62,
      nfc$start_bd_reserved_63, nfc$start_bd_reserved_64, nfc$start_bd_reserved_65);

*DECK DECK=NFT$START_IO_STATION_MSG EXPAND=FALSE
  TYPE
    nft$start_ios_message_parameter = packed record
      length_indicated: boolean,
      param: nft$start_io_station_params,
    recend;

  TYPE
    nft$start_io_station_params = (nfc$null_parameter, nfc$io_station_name, nfc$user_identity,
      nfc$start_ios_reserved_3, nfc$start_ios_reserved_4, nfc$start_ios_reserved_5, nfc$start_ios_reserved_6,
      nfc$start_ios_reserved_7, nfc$start_ios_reserved_8, nfc$start_ios_reserved_9, nfc$start_ios_reserved_10,
      nfc$start_ios_reserved_11, nfc$start_ios_reserved_12, nfc$start_ios_reserved_13,
      nfc$start_ios_reserved_14, nfc$start_ios_reserved_15, nfc$start_ios_reserved_16,
      nfc$start_ios_reserved_17, nfc$start_ios_reserved_18, nfc$start_ios_reserved_19,
      nfc$start_ios_reserved_20, nfc$start_ios_reserved_21, nfc$start_ios_reserved_22,
      nfc$start_ios_reserved_23, nfc$start_ios_reserved_24, nfc$start_ios_reserved_25,
      nfc$start_ios_reserved_26, nfc$start_ios_reserved_27, nfc$start_ios_reserved_28,
      nfc$start_ios_reserved_29, nfc$start_ios_reserved_30, nfc$start_ios_reserved_31,
      nfc$start_ios_reserved_32, nfc$start_ios_reserved_33, nfc$start_ios_reserved_34,
      nfc$start_ios_reserved_35, nfc$start_ios_reserved_36, nfc$start_ios_reserved_37,
      nfc$start_ios_reserved_38, nfc$start_ios_reserved_39, nfc$start_ios_reserved_40,
      nfc$start_ios_reserved_41, nfc$start_ios_reserved_42, nfc$start_ios_reserved_43,
      nfc$start_ios_reserved_44, nfc$start_ios_reserved_45, nfc$start_ios_reserved_46,
      nfc$start_ios_reserved_47, nfc$start_ios_reserved_48, nfc$start_ios_reserved_49,
      nfc$start_ios_reserved_50, nfc$start_ios_reserved_51, nfc$start_ios_reserved_52,
      nfc$start_ios_reserved_53, nfc$start_ios_reserved_54, nfc$start_ios_reserved_55,
      nfc$start_ios_reserved_56, nfc$start_ios_reserved_57, nfc$start_ios_reserved_58,
      nfc$start_ios_reserved_59, nfc$start_ios_reserved_60, nfc$start_ios_reserved_61,
      nfc$start_ios_reserved_62, nfc$start_ios_reserved_63, nfc$start_ios_reserved_64,
      nfc$start_ios_reserved_65);

*DECK DECK=NFT$STATION_STATUS_MSG EXPAND=FALSE
*copyc nft$display_status_resp_codes
  TYPE
    nft$station_status_msg_param = packed record
      length_indicated: boolean,
      param: nft$station_status_parameters,
    recend;

  TYPE
    nft$station_status_parameters = (nfc$null_parameter, nfc$io_station_name, nfc$response_code,
      nfc$control_facility, nfc$number_of_files_queued, nfc$station_usage, nfc$file_acknowledgement,
      nfc$count_of_devices, nfc$device_name_status, nfc$req_console_device, nfc$io_station_alias_1,
      nfc$io_station_alias_2, nfc$io_station_alias_3, nfc$default_job_destination,
      nfc$destination_unavail_action, nfc$pm_message_action, nfc$station_status_reserved_16,
      nfc$station_status_reserved_17, nfc$station_status_reserved_18, nfc$station_status_reserved_19,
      nfc$station_status_reserved_20, nfc$station_status_reserved_21, nfc$station_status_reserved_22,
      nfc$station_status_reserved_23, nfc$station_status_reserved_24, nfc$station_status_reserved_25,
      nfc$station_status_reserved_26, nfc$station_status_reserved_27, nfc$station_status_reserved_28,
      nfc$station_status_reserved_29, nfc$station_status_reserved_30, nfc$station_status_reserved_31,
      nfc$station_status_reserved_32, nfc$station_status_reserved_33, nfc$station_status_reserved_34,
      nfc$station_status_reserved_35, nfc$station_status_reserved_36, nfc$station_status_reserved_37,
      nfc$station_status_reserved_38, nfc$station_status_reserved_39, nfc$station_status_reserved_40,
      nfc$station_status_reserved_41, nfc$station_status_reserved_42, nfc$station_status_reserved_43,
      nfc$station_status_reserved_44, nfc$station_status_reserved_45, nfc$station_status_reserved_46,
      nfc$station_status_reserved_47, nfc$station_status_reserved_48, nfc$station_status_reserved_49,
      nfc$station_status_reserved_50, nfc$station_status_reserved_51, nfc$station_status_reserved_52,
      nfc$station_status_reserved_53, nfc$station_status_reserved_54, nfc$station_status_reserved_55,
      nfc$station_status_reserved_56, nfc$station_status_reserved_57, nfc$station_status_reserved_58,
      nfc$station_status_reserved_59, nfc$station_status_reserved_60, nfc$station_status_reserved_61,
      nfc$station_status_reserved_62, nfc$station_status_reserved_63, nfc$station_status_reserved_64,
      nfc$station_status_reserved_65);

*DECK DECK=NFT$STOP_BATCH_DEVICE_MSG EXPAND=FALSE
  TYPE
    nft$stop_bd_message_parameter = packed record
      length_indicated: boolean,
      param: nft$stop_batch_device_params,
    recend;

  TYPE
    nft$stop_batch_device_params = (nfc$null_parameter, nfc$io_station_name, nfc$device_name,
      nfc$file_disposition, nfc$stop_bd_reserved_4,  nfc$stop_bd_reserved_5, nfc$stop_bd_reserved_6,
      nfc$stop_bd_reserved_7, nfc$stop_bd_reserved_8, nfc$stop_bd_reserved_9, nfc$stop_bd_reserved_10,
      nfc$stop_bd_reserved_11, nfc$stop_bd_reserved_12, nfc$stop_bd_reserved_13, nfc$stop_bd_reserved_14,
      nfc$stop_bd_reserved_15, nfc$stop_bd_reserved_16, nfc$stop_bd_reserved_17, nfc$stop_bd_reserved_18,
      nfc$stop_bd_reserved_19, nfc$stop_bd_reserved_20, nfc$stop_bd_reserved_21, nfc$stop_bd_reserved_22,
      nfc$stop_bd_reserved_23, nfc$stop_bd_reserved_24, nfc$stop_bd_reserved_25, nfc$stop_bd_reserved_26,
      nfc$stop_bd_reserved_27, nfc$stop_bd_reserved_28, nfc$stop_bd_reserved_29, nfc$stop_bd_reserved_30,
      nfc$stop_bd_reserved_31, nfc$stop_bd_reserved_32, nfc$stop_bd_reserved_33, nfc$stop_bd_reserved_34,
      nfc$stop_bd_reserved_35, nfc$stop_bd_reserved_36, nfc$stop_bd_reserved_37, nfc$stop_bd_reserved_38,
      nfc$stop_bd_reserved_39, nfc$stop_bd_reserved_40, nfc$stop_bd_reserved_41, nfc$stop_bd_reserved_42,
      nfc$stop_bd_reserved_43, nfc$stop_bd_reserved_44, nfc$stop_bd_reserved_45, nfc$stop_bd_reserved_46,
      nfc$stop_bd_reserved_47, nfc$stop_bd_reserved_48, nfc$stop_bd_reserved_49, nfc$stop_bd_reserved_50,
      nfc$stop_bd_reserved_51, nfc$stop_bd_reserved_52, nfc$stop_bd_reserved_53, nfc$stop_bd_reserved_54,
      nfc$stop_bd_reserved_55, nfc$stop_bd_reserved_56, nfc$stop_bd_reserved_57, nfc$stop_bd_reserved_58,
      nfc$stop_bd_reserved_59, nfc$stop_bd_reserved_60, nfc$stop_bd_reserved_61, nfc$stop_bd_reserved_62,
      nfc$stop_bd_reserved_63, nfc$stop_bd_reserved_64, nfc$stop_bd_reserved_65);

*DECK DECK=NFT$STOP_IO_STATION_MSG EXPAND=FALSE
  TYPE
    nft$stop_ios_message_parameter = packed record
      length_indicated: boolean,
      param: nft$stop_io_station_params,
    recend;

  TYPE
    nft$stop_io_station_params = (nfc$null_parameter, nfc$io_station_name, nfc$stop_ios_reserved_2,
      nfc$stop_ios_reserved_3, nfc$stop_ios_reserved_4, nfc$stop_ios_reserved_5, nfc$stop_ios_reserved_6,
      nfc$stop_ios_reserved_7, nfc$stop_ios_reserved_8, nfc$stop_ios_reserved_9, nfc$stop_ios_reserved_10,
      nfc$stop_ios_reserved_11, nfc$stop_ios_reserved_12, nfc$stop_ios_reserved_13, nfc$stop_ios_reserved_14,
      nfc$stop_ios_reserved_15, nfc$stop_ios_reserved_16, nfc$stop_ios_reserved_17, nfc$stop_ios_reserved_18,
      nfc$stop_ios_reserved_19, nfc$stop_ios_reserved_20, nfc$stop_ios_reserved_21, nfc$stop_ios_reserved_22,
      nfc$stop_ios_reserved_23, nfc$stop_ios_reserved_24, nfc$stop_ios_reserved_25, nfc$stop_ios_reserved_26,
      nfc$stop_ios_reserved_27, nfc$stop_ios_reserved_28, nfc$stop_ios_reserved_29, nfc$stop_ios_reserved_30,
      nfc$stop_ios_reserved_31, nfc$stop_ios_reserved_32, nfc$stop_ios_reserved_33, nfc$stop_ios_reserved_34,
      nfc$stop_ios_reserved_35, nfc$stop_ios_reserved_36, nfc$stop_ios_reserved_37, nfc$stop_ios_reserved_38,
      nfc$stop_ios_reserved_39, nfc$stop_ios_reserved_40, nfc$stop_ios_reserved_41, nfc$stop_ios_reserved_42,
      nfc$stop_ios_reserved_43, nfc$stop_ios_reserved_44, nfc$stop_ios_reserved_45, nfc$stop_ios_reserved_46,
      nfc$stop_ios_reserved_47, nfc$stop_ios_reserved_48, nfc$stop_ios_reserved_49, nfc$stop_ios_reserved_50,
      nfc$stop_ios_reserved_51, nfc$stop_ios_reserved_52, nfc$stop_ios_reserved_53, nfc$stop_ios_reserved_54,
      nfc$stop_ios_reserved_55, nfc$stop_ios_reserved_56, nfc$stop_ios_reserved_57, nfc$stop_ios_reserved_58,
      nfc$stop_ios_reserved_59, nfc$stop_ios_reserved_60, nfc$stop_ios_reserved_61, nfc$stop_ios_reserved_62,
      nfc$stop_ios_reserved_63, nfc$stop_ios_reserved_64, nfc$stop_ios_reserved_65);

*DECK DECK=NFT$STORE_FORWARD_FILE_INFO EXPAND=FALSE

  TYPE
    nft$store_forward_file_info = record
      local_file_name: amt$local_file_name,
      file_open: boolean,
      file_identifier: amt$file_identifier,
      segment_pointer: amt$segment_pointer,
      pointers: nft$store_forward_file_pointers,
    recend;

*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc amt$segment_pointer
*copyc nft$store_forward_file_pointers
*DECK DECK=NFT$STORE_FORWARD_FILE_POINTERS EXPAND=FALSE

  TYPE
    nft$store_forward_file_pointers = record
      ptr_application_name_list: nft$sf_rel_ptr_appl_name_info,
      ptr_group_name_list: nft$sf_rel_ptr_group_name_info,
      ptr_source_name_list: nft$sf_rel_ptr_source_name_info,
      ptr_target_name_list: nft$sf_rel_ptr_target_name_info,
    recend;

*copyc nft$sf_rel_ptr_appl_name_info
*copyc nft$sf_rel_ptr_group_name_info
*copyc nft$sf_rel_ptr_source_name_info
*copyc nft$sf_rel_ptr_target_name_info
*DECK DECK=NFT$STORE_FORWARD_SEQUENCE EXPAND=FALSE

  TYPE
    nft$store_forward_sequence = SEQ ( * );
*DECK DECK=NFT$SUPPRESS_CARRIAGE_CNTRL_MSG EXPAND=FALSE
  TYPE
    nft$suppress_cc_msg_parameter  = packed record
      length_indicated: boolean,
      param: nft$suppress_cc_parameters,
    recend;

  TYPE
    nft$suppress_cc_parameters = (nfc$null_parameter, nfc$io_station_name, nfc$device_name,
      nfc$suppress_format_control, nfc$supcc_reserved_4, nfc$supcc_reserved_5, nfc$supcc_reserved_6,
      nfc$supcc_reserved_7, nfc$supcc_reserved_8, nfc$supcc_reserved_9, nfc$supcc_reserved_10,
      nfc$supcc_reserved_11, nfc$supcc_reserved_12, nfc$supcc_reserved_13, nfc$supcc_reserved_14,
      nfc$supcc_reserved_15, nfc$supcc_reserved_16, nfc$supcc_reserved_17, nfc$supcc_reserved_18,
      nfc$supcc_reserved_19, nfc$supcc_reserved_20, nfc$supcc_reserved_21, nfc$supcc_reserved_22,
      nfc$supcc_reserved_23, nfc$supcc_reserved_24, nfc$supcc_reserved_25, nfc$supcc_reserved_26,
      nfc$supcc_reserved_27, nfc$supcc_reserved_28, nfc$supcc_reserved_29, nfc$supcc_reserved_30,
      nfc$supcc_reserved_31, nfc$supcc_reserved_32, nfc$supcc_reserved_33, nfc$supcc_reserved_34,
      nfc$supcc_reserved_35, nfc$supcc_reserved_36, nfc$supcc_reserved_37, nfc$supcc_reserved_38,
      nfc$supcc_reserved_39, nfc$supcc_reserved_40, nfc$supcc_reserved_41, nfc$supcc_reserved_42,
      nfc$supcc_reserved_43, nfc$supcc_reserved_44, nfc$supcc_reserved_45, nfc$supcc_reserved_46,
      nfc$supcc_reserved_47, nfc$supcc_reserved_48, nfc$supcc_reserved_49, nfc$supcc_reserved_50,
      nfc$supcc_reserved_51, nfc$supcc_reserved_52, nfc$supcc_reserved_53, nfc$supcc_reserved_54,
      nfc$supcc_reserved_55, nfc$supcc_reserved_56, nfc$supcc_reserved_57, nfc$supcc_reserved_58,
      nfc$supcc_reserved_59, nfc$supcc_reserved_60, nfc$supcc_reserved_61, nfc$supcc_reserved_62,
      nfc$supcc_reserved_63, nfc$supcc_reserved_64, nfc$supcc_reserved_65);

*DECK DECK=NFT$SUPPRESS_CARRIAGE_CONTROL EXPAND=FALSE
  TYPE
    nft$suppress_carriage_control = boolean;

*DECK DECK=NFT$TASK_LIST EXPAND=FALSE
  TYPE
    nft$task_list = record
      task_id: pmt$task_id,
      path: nft$network_connection,
      forward_pointer: ^nft$task_list,
      backward_pointer: ^nft$task_list,
    recend;
*copyc pmt$task_id
*copyc nft$network_connection
*DECK DECK=NFT$TASK_QUEUE EXPAND=FALSE
  TYPE
    nft$task_queue = record
      head: ^nft$task_list,
      tail: ^nft$task_list,
      number_of_tasks: integer,
    recend;

*copyc nft$task_list
*DECK DECK=NFT$TERMINAL_MODEL EXPAND=FALSE
  CONST
    nfc$max_terminal_model_size = 31;

  TYPE
    nft$terminal_model = string (nfc$max_terminal_model_size);

*DECK DECK=NFT$TERMINATE_QUEUED_OUTPUT_MSG EXPAND=FALSE
?? PUSH (LISTEXT := OFF) ??

  TYPE
    nft$term_queue_output_parameter = packed record
      length_indicated: boolean,
      param: nft$term_queue_output_params,
    recend,

    nft$term_queue_output_params = (nfc$null_parameter, nfc$io_station_name,
          nfc$system_user_file_name, nfc$terqo_reserved_3,
          nfc$terqo_reserved_4, nfc$terqo_reserved_5, nfc$terqo_reserved_6,
          nfc$terqo_reserved_7, nfc$terqo_reserved_8, nfc$terqo_reserved_9,
          nfc$terqo_reserved_10, nfc$terqo_reserved_11, nfc$terqo_reserved_12,
          nfc$terqo_reserved_13, nfc$terqo_reserved_14, nfc$terqo_reserved_15,
          nfc$terqo_reserved_16, nfc$terqo_reserved_17, nfc$terqo_reserved_18,
          nfc$terqo_reserved_19, nfc$terqo_reserved_20, nfc$terqo_reserved_21,
          nfc$terqo_reserved_22, nfc$terqo_reserved_23, nfc$terqo_reserved_24,
          nfc$terqo_reserved_25, nfc$terqo_reserved_26, nfc$terqo_reserved_27,
          nfc$terqo_reserved_28, nfc$terqo_reserved_29, nfc$terqo_reserved_30,
          nfc$terqo_reserved_31, nfc$terqo_reserved_32, nfc$terqo_reserved_33,
          nfc$terqo_reserved_34, nfc$terqo_reserved_35, nfc$terqo_reserved_36,
          nfc$terqo_reserved_37, nfc$terqo_reserved_38, nfc$terqo_reserved_39,
          nfc$terqo_reserved_40, nfc$terqo_reserved_41, nfc$terqo_reserved_42,
          nfc$terqo_reserved_43, nfc$terqo_reserved_44, nfc$terqo_reserved_45,
          nfc$terqo_reserved_46, nfc$terqo_reserved_47, nfc$terqo_reserved_48,
          nfc$terqo_reserved_49, nfc$terqo_reserved_50, nfc$terqo_reserved_51,
          nfc$terqo_reserved_52, nfc$terqo_reserved_53, nfc$terqo_reserved_54,
          nfc$terqo_reserved_55, nfc$terqo_reserved_56, nfc$terqo_reserved_57,
          nfc$terqo_reserved_58, nfc$terqo_reserved_59, nfc$terqo_reserved_60,
          nfc$terqo_reserved_61, nfc$terqo_reserved_62, nfc$terqo_reserved_63,
          nfc$terqo_reserved_64, nfc$terqo_reserved_65);

?? POP ??
*DECK DECK=NFT$TERMINATE_Q_OUTPUT_RESP_MSG EXPAND=FALSE
?? PUSH (LISTEXT := OFF) ??

  TYPE
    nft$term_q_output_resp_param = packed record
      length_indicated: boolean,
      param: nft$term_q_output_resp_params,
    recend,

    nft$term_q_output_resp_params = (nfc$null_parameter, nfc$io_station_name,
          nfc$system_user_file_name, nfc$file_status_code,
          nfc$terqo_resp_reserved_4, nfc$terqo_resp_reserved_5,
          nfc$terqo_resp_reserved_6, nfc$terqo_resp_reserved_7,
          nfc$terqo_resp_reserved_8, nfc$terqo_resp_reserved_9,
          nfc$terqo_resp_reserved_10, nfc$terqo_resp_reserved_11,
          nfc$terqo_resp_reserved_12, nfc$terqo_resp_reserved_13,
          nfc$terqo_resp_reserved_14, nfc$terqo_resp_reserved_15,
          nfc$terqo_resp_reserved_16, nfc$terqo_resp_reserved_17,
          nfc$terqo_resp_reserved_18, nfc$terqo_resp_reserved_19,
          nfc$terqo_resp_reserved_20, nfc$terqo_resp_reserved_21,
          nfc$terqo_resp_reserved_22, nfc$terqo_resp_reserved_23,
          nfc$terqo_resp_reserved_24, nfc$terqo_resp_reserved_25,
          nfc$terqo_resp_reserved_26, nfc$terqo_resp_reserved_27,
          nfc$terqo_resp_reserved_28, nfc$terqo_resp_reserved_29,
          nfc$terqo_resp_reserved_30, nfc$terqo_resp_reserved_31,
          nfc$terqo_resp_reserved_32, nfc$terqo_resp_reserved_33,
          nfc$terqo_resp_reserved_34, nfc$terqo_resp_reserved_35,
          nfc$terqo_resp_reserved_36, nfc$terqo_resp_reserved_37,
          nfc$terqo_resp_reserved_38, nfc$terqo_resp_reserved_39,
          nfc$terqo_resp_reserved_40, nfc$terqo_resp_reserved_41,
          nfc$terqo_resp_reserved_42, nfc$terqo_resp_reserved_43,
          nfc$terqo_resp_reserved_44, nfc$terqo_resp_reserved_45,
          nfc$terqo_resp_reserved_46, nfc$terqo_resp_reserved_47,
          nfc$terqo_resp_reserved_48, nfc$terqo_resp_reserved_49,
          nfc$terqo_resp_reserved_50, nfc$terqo_resp_reserved_51,
          nfc$terqo_resp_reserved_52, nfc$terqo_resp_reserved_53,
          nfc$terqo_resp_reserved_54, nfc$terqo_resp_reserved_55,
          nfc$terqo_resp_reserved_56, nfc$terqo_resp_reserved_57,
          nfc$terqo_resp_reserved_58, nfc$terqo_resp_reserved_59,
          nfc$terqo_resp_reserved_60, nfc$terqo_resp_reserved_61,
          nfc$terqo_resp_reserved_62, nfc$terqo_resp_reserved_63,
          nfc$terqo_resp_reserved_64, nfc$terqo_resp_reserved_65);

?? POP ??
*DECK DECK=NFT$TERMINATE_TRANSFER_MSG EXPAND=FALSE
  TYPE
    nft$terminate_xfer_msg_param = packed record
      length_indicated: boolean,
      param: nft$terminate_xfer_parameters,
    recend;

  TYPE
    nft$terminate_xfer_parameters = (nfc$null_parameter, nfc$io_station_name, nfc$device_name,
      nfc$file_disposition, nfc$term_xfer_reserved_4, nfc$term_xfer_reserved_5, nfc$term_xfer_reserved_6,
      nfc$term_xfer_reserved_7, nfc$term_xfer_reserved_8, nfc$term_xfer_reserved_9, nfc$term_xfer_reserved_10,
      nfc$term_xfer_reserved_11, nfc$term_xfer_reserved_12, nfc$term_xfer_reserved_13,
      nfc$term_xfer_reserved_14, nfc$term_xfer_reserved_15, nfc$term_xfer_reserved_16,
      nfc$term_xfer_reserved_17, nfc$term_xfer_reserved_18, nfc$term_xfer_reserved_19,
      nfc$term_xfer_reserved_20, nfc$term_xfer_reserved_21, nfc$term_xfer_reserved_22,
      nfc$term_xfer_reserved_23, nfc$term_xfer_reserved_24, nfc$term_xfer_reserved_25,
      nfc$term_xfer_reserved_26, nfc$term_xfer_reserved_27, nfc$term_xfer_reserved_28,
      nfc$term_xfer_reserved_29, nfc$term_xfer_reserved_30, nfc$term_xfer_reserved_31,
      nfc$term_xfer_reserved_32, nfc$term_xfer_reserved_33, nfc$term_xfer_reserved_34,
      nfc$term_xfer_reserved_35, nfc$term_xfer_reserved_36, nfc$term_xfer_reserved_37,
      nfc$term_xfer_reserved_38, nfc$term_xfer_reserved_39, nfc$term_xfer_reserved_40,
      nfc$term_xfer_reserved_41, nfc$term_xfer_reserved_42, nfc$term_xfer_reserved_43,
      nfc$term_xfer_reserved_44, nfc$term_xfer_reserved_45, nfc$term_xfer_reserved_46,
      nfc$term_xfer_reserved_47, nfc$term_xfer_reserved_48, nfc$term_xfer_reserved_49,
      nfc$term_xfer_reserved_50, nfc$term_xfer_reserved_51, nfc$term_xfer_reserved_52,
      nfc$term_xfer_reserved_53, nfc$term_xfer_reserved_54, nfc$term_xfer_reserved_55,
      nfc$term_xfer_reserved_56, nfc$term_xfer_reserved_57, nfc$term_xfer_reserved_58,
      nfc$term_xfer_reserved_59, nfc$term_xfer_reserved_60, nfc$term_xfer_reserved_61,
      nfc$term_xfer_reserved_62, nfc$term_xfer_reserved_63, nfc$term_xfer_reserved_64,
      nfc$term_xfer_reserved_65);

*DECK DECK=NFT$TERM_TO_APPLICATION_ACCTG EXPAND=TRUE

  TYPE
    nft$term_to_application_acctg = packed record
      header: nft$sl_accounting_header,
      id: 0 .. 255,
      destination_name: ALIGNED string (31),
      lim: 0 .. 255,
      port: 0 .. 255,
      tip_name: ALIGNED string (31),
      terminal_protocol: string (10),
      device_name: ALIGNED string (31),
      device_type: string (3),
      line_speed: ALIGNED 0 .. 0ffff(16),
    recend;

*copyc nft$sl_accounting_header
*DECK DECK=NFT$TERQO_FILE_STATUS_CODES EXPAND=FALSE
  TYPE
    nft$terqo_file_status_codes = (nfc$terqo_successful, nfc$terqo_unknown_ios,
          nfc$terqo_unknown_file_name, nfc$terqo_duplicate_file_names,
          nfc$terqo_file_in_transfer, nfc$terqo_message_rejected);

*DECK DECK=NFT$TIMER EXPAND=FALSE
  TYPE
    nft$timer = record
      timer_set: boolean,
      last_checked: nft$micro_second,
      time_interval: nft$micro_second,
    recend;

*copyc nft$micro_second
*DECK DECK=NFT$TIP_TYPE EXPAND=FALSE
  TYPE
    nft$tip_type = (nfc$internal_tip, nfc$auto_tip, nfc$async_tip,
          nfc$user1_tip, nfc$user2_tip, nfc$user3_tip, nfc$user4_tip,
          nfc$hasp_tip, nfc$x25_async_tip, nfc$bisync_3270_tip,
          nfc$bisync_njef_tip, nfc$remote_term_emulator_tip,
          nfc$uri_tip, nfc$xpc_tip, nfc$mode4_tip, nfc$ntf_tip,
          nfc$sna_3270_tip, nfc$telnet_tip);
*DECK DECK=NFT$TRANSFER_DECLARATIONS EXPAND=FALSE

  CONST
    nfc$block_size_limit = 99999999,
    nfc$timeout_limit = 9999;

  TYPE
    nft$block_size = 0 .. nfc$block_size_limit,
    nft$timeout = 0 .. nfc$timeout_limit,
    nft$facility_types = (nfc$multiple_data_phase_params,
      nfc$collective_text_string,
      nfc$temporary_hold, nfc$go_command_parameters,
      nfc$later_resumption, nfc$restart_permitted,
      nfc$checkmark_ack_required, nfc$ss_ack_required,
      nfc$data_compression),
    nft$facility_group = set of nft$facility_types;

*DECK DECK=NFT$TRANSFER_MODES EXPAND=FALSE
  TYPE
    nft$transfer_modes = (nfc$ve_to_ve_mode, nfc$coded_data_mode,
          nfc$transparent_data_mode, nfc$rhf_structured_mode);

*DECK DECK=NFT$TRANSFER_STATUS EXPAND=TRUE

  TYPE
    nft$transfer_status = RECORD
      CASE positive_reply: BOOLEAN OF
      = TRUE =
        file_name: amt$local_file_name,
        CASE access_mode: nft$mode_of_access OF
        = nfc$give =
          file_length: amt$file_length,
        CASEND,
      CASEND,
    RECEND;

*copyc amt$file_length
*copyc amt$local_file_name
*copyc nft$mode_of_access
*DECK DECK=NFT$TRANSMIT_BLOCK_SIZE EXPAND=FALSE
  CONST
    nfc$max_transmit_block_size = 0ffff(16);

  TYPE
    nft$transmit_block_size = 0 .. nfc$max_transmit_block_size;

*DECK DECK=NFT$UNSOLICITED_DEVICE_MSG EXPAND=FALSE
  CONST
    nfc$max_unsolicited_msg_length = 255;

  TYPE
    nft$unsolicited_device_msg = string (nfc$max_unsolicited_msg_length);

*DECK DECK=NFT$USER_MESSAGE_LIST EXPAND=FALSE
?? NEWTITLE := 'nft$user_message_list' ??

{ nft$user_message_list }

  TYPE
    nft$user_message_list = record
      next_message: ^nft$user_message_list,
      case ve_message: boolean of
      = TRUE =
        message: ost$status,
      = FALSE =
        message_string: ^string ( * ),
      casend,
    recend;

*copyc ost$status
?? OLDTITLE ??
*DECK DECK=NFT$VERTICAL_PRINT_DENSITY EXPAND=FALSE
  TYPE
    nft$vertical_print_density = (nfc$six_only, nfc$eight_only, nfc$six_any, nfc$eight_any);

*DECK DECK=NFT$VE_TO_VE_ACCESS EXPAND=TRUE

  TYPE
    nft$ve_to_ve_access = RECORD
      CASE ve_server: BOOLEAN OF
      = TRUE =
        execution_ring: ost$ring,
      CASEND,
    RECEND;

*copyc osd$virtual_address
*DECK DECK=NFT$VFU_LOAD_OPTION EXPAND=FALSE
  TYPE
    nft$vfu_load_option = (nfc$vfu_not_present_or_load, nfc$vfu_loaded_at_init,
          nfc$vfu_changeable_by_operator, nfc$vfu_changeable_by_user);
*DECK DECK=NFT$VFU_LOAD_PROCEDURE EXPAND=FALSE
  TYPE
    nft$vfu_load_procedure = ost$name;
*DECK DECK=NFT$WAIT_ACTIVITY EXPAND=FALSE
*copyc nft$wait_activity_kind

  TYPE
    nft$wait_activity = record
      case kind: nft$wait_activity_kind of
      = nfc$control_facility_connection =
        cf: ^nft$control_facility,
      = nfc$btfve_task_message =
        btf_task_list: ^nft$btf_task,
      = nfc$title_translation_request =
        dest: ^nft$destination,
      casend,
    recend;

*copyc nft$btf_task
*copyc nft$control_facility
*copyc nft$destination
*DECK DECK=NFT$WAIT_ACTIVITY_KIND EXPAND=FALSE
  TYPE
    nft$wait_activity_kind = (nfc$control_facility_connection,
          nfc$btfve_task_message, nfc$title_translation_request);
*DECK DECK=NFT$WAIT_ACTIVITY_LIST EXPAND=FALSE

  CONST
    nfc$wait_activity_list_lowest = 3;

  TYPE
    nft$wait_activity_list = array [nfc$wait_activity_list_lowest .. * ] of nft$wait_activity;

*copyc nft$wait_activity
*DECK DECK=NFT$WAIT_LIST_SIZE EXPAND=FALSE
{   NFT$WAIT_LIST_SIZE can be used by QTFC and SCF to set the maximum size of
{   the wait list each uses for calls to OSP$I_AWAIT_ACTIVITY_COMPLETION.
{   The maximum size of 4095 seems large enough so that neither QTF nor SCF
{   should ever excede that many elements in a wait list.

  CONST
    nfc$max_wait_list_size = 4095;

  TYPE
    nft$wait_list_size = 0 .. nfc$max_wait_list_size;

*DECK DECK=NFV$APPL_DEF_SEGMENT_VARIABLES EXPAND=FALSE

{  This variable is XDCL in the module NFM$FILE_TRANSFER_APPL_PROCS

  VAR
    nfv$appl_def_segment_variables: [XREF, READ, nfs$appl_def_segment_variables]
          ARRAY [nft$appl_def_segment_values] OF string (osc$max_name_size);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc nfs$appl_def_segment_variables
*copyc nft$appl_def_segment_values
?? POP ??
*DECK DECK=NFV$LCN_APPLICATION_NAMES EXPAND=FALSE
  VAR
    nfv$lcn_application_names: [STATIC, READ, XREF] nft$lcn_application_names;

*copyc nft$lcn_application_names

*DECK DECK=NFV$MANAGE_SFN_DIRECTIVES EXPAND=FALSE

  VAR
    nfv$manage_sfn_directives: [STATIC, READ] ost$name :=
          'MANAGE_SFN_DIRECTIVES';

*copyc ost$name
*DECK DECK=NFV$MANAGE_SF_NETWORK EXPAND=FALSE

  VAR
    nfv$manage_sf_network: [STATIC, READ] ost$name :=
          'MANAGE_STORE_FORWARD_NETWORK';

*copyc ost$name
*DECK DECK=NFV$NAM_APPLICATION_NAMES EXPAND=FALSE
  VAR
    nfv$nam_application_names: [STATIC, READ, XREF] nft$nam_application_names;

*copyc nft$nam_application_names

*DECK DECK=NFV$P04_VALUES EXPAND=FALSE
  VAR
    nfv$p04_values: [STATIC, READ, XREF] nft$parameter_04_values;

*copyc nft$parameter_04_values

*DECK DECK=NFV$PARAMETER_17_VALUES EXPAND=FALSE
?? newtitle := 'nfv$parameter_17_values' ??

{ nfv$parameter_17_values }

VAR nfv$parameter_17_values : [XREF] nft$parameter_17_values;

*copyc nft$parameter_17_values
?? oldtitle ??
*DECK DECK=NFV$PARAMETER_31_VALUES EXPAND=FALSE
?? newtitle := 'nfv$parameter_31_values' ??

{ nfv$parameter_31_values }

VAR
      nfv$parameter_31_values: [XREF] nft$parameter_31_definition;

*copyc nft$parameter_31_definition
?? oldtitle ??
*DECK DECK=NFV$PROTOCOL_TRACE_INFO EXPAND=FALSE

  VAR
    nfv$protocol_trace_info: [READ, STATIC] nft$protocol_trace_info :=
      [[[3, 'PTF'], [4, 'PTFC']], [[3, 'PTF'], [4, 'PTFS']],
       [[3, 'QTF'], [4, 'QTFC']], [[3, 'QTF'], [4, 'QTFS']],
       [[3, 'BTF'], [4, 'BTFC']], [[3, 'BTF'], [4, 'BTFS']]];

*copyc nft$protocol_trace_info
*DECK DECK=NFV$PTF_PARAMETER_RULES EXPAND=FALSE
  VAR
    nfv$ptf_parameter_rules: [STATIC, READ, XREF] nft$parameter_rules_array;

*copyc nft$parameter_rules_array

*DECK DECK=NFV$PTF_REQUIRED_PARAMS EXPAND=FALSE
  VAR
    nfv$ptf_required_params: [STATIC, READ, XREF]
          nft$required_param_on_command;

*copyc nft$required_param_on_command

*DECK DECK=NFV$PTF_SEND_P03_VALUES EXPAND=FALSE
  VAR
    nfv$ptf_send_p03_values: [STATIC, READ, XREF] nft$parameter_03_netvalues;

*copyc nft$parameter_03_netvalues
*DECK DECK=NFV$QTF_PARAMETER_RULES EXPAND=FALSE
  VAR
    nfv$qtf_parameter_rules: [XREF, READ, nfs$qtf_application_data] nft$parameter_rules_array;

*copyc nfs$qtf_application_data
*copyc nft$parameter_rules
*copyc nft$parameter_rules_array
*copyc nft$parameter_set
*DECK DECK=NFV$QTF_REQUIRED_PARAMS_ON_CMDS EXPAND=FALSE
  VAR
    nfv$qtf_required_params_on_cmds: [XREF, READ, nfs$qtf_application_data] nft$required_param_on_command;

*copyc nfs$qtf_application_data
*copyc nft$parameter_set
*copyc nft$required_param_on_command
*DECK DECK=NFV$SF_APPLICATION_NAMES EXPAND=FALSE

  VAR
    nfv$sf_application_names: [STATIC, READ] nft$sf_application_names :=
          ['UNKNOWN','NTFI','NTFS','QTFI','QTFS'];

*copyc nft$sf_application_names
*DECK DECK=NLC$BM_BUFFER_POOL_INDEX EXPAND=FALSE

  CONST
    nlc$bm_large_buffer_index = 2,
    nlc$bm_small_buffer_index = 1;

*DECK DECK=NLC$BM_MINIMUM_BUFFERS_FOR_CPU EXPAND=FALSE

  CONST
    nlc$bm_minimum_buffers_for_cpu = 25;

*DECK DECK=NLC$BM_SMALL_BUFFER_SIZE EXPAND=FALSE

  CONST
    nlc$bm_small_buffer_size = 512;
*DECK DECK=NLC$NAM_CONFIGURATION_CONSTANTS EXPAND=FALSE

  CONST
    nlc$default_maximum_connections = 256;

  CONST
    nlc$base_connection_array_size = 16,
    nlc$xi_open_sap_base = 64;
*DECK DECK=NLC$SK_MAX_ASSIGNED_PORT EXPAND=FALSE

  CONST
    nlc$sk_max_assigned_port = 65535;

*DECK DECK=NLC$SK_MAX_PRIV_RESERVED_PORT EXPAND=FALSE

  CONST
    nlc$sk_max_priv_reserved_port = 1023;

*DECK DECK=NLC$SK_MIN_ASSIGNED_PORT EXPAND=FALSE

  CONST
    nlc$sk_min_assigned_port = 1024;

*DECK DECK=NLC$SL_APPL_NAME_LENGTH EXPAND=FALSE

  CONST
    nlc$sl_min_appl_name_length = 0,
    nlc$sl_max_appl_name_length = 0FF(16);
*DECK DECK=NLC$SL_FAMILY_NAME_LENGTH EXPAND=FALSE

  CONST
    nlc$sl_min_family_name_length = 0,
    nlc$sl_max_family_name_length = 0FF(16);
*DECK DECK=NLC$SL_USER_NAME_LENGTH EXPAND=FALSE

  CONST
    nlc$sl_min_user_name_length = 0,
    nlc$sl_max_user_name_length = 0FF(16);
*DECK DECK=NLC$SL_VALIDATION_VERSION EXPAND=FALSE

  CONST
    nlc$sl_min_validation_version = 0,
    nlc$sl_max_validation_version = 0FFFF(16),
    nlc$sl_validation_version = 1;
*DECK DECK=NLC$SMAA_VERSIONS EXPAND=FALSE

CONST
  nlc$sm_version_1 = 1,
  nlc$sm_version_2 = 2;

*DECK DECK=NLC$SMALL_MACHINE_THRESHOLD EXPAND=FALSE

  CONST
    nlc$small_machine_threshold = 26000000 {This number is arbitrary. 16MB is small, 32MB is large};
*DECK DECK=NLC$SM_DEVICE_SERVICE_ATTRIBUTE EXPAND=FALSE

CONST
  nlc$sm_min_service_attrib        = 0,

  nlc$sm_transport_service_attrib  = 1,

  nlc$sm_max_service_attrib        = 255;

*DECK DECK=NLC$SM_DEVICE_SERVICE_VALUES EXPAND=FALSE

{  The following abbreviations have been used to define the various
{  transport protocol class variants (device service attribute value)
{
{      CLNS - Connectionless mode Network Service
{      CONS - Connection mode Network Service
{      TP0  - Transport Class 0
{      TP2  - Transport Class 2
{      TP4  - Transport Class 4

CONST
  nlc$sm_tp4_clns              = 0,  { Transport class 4 over CLNS
  nlc$sm_tp4_clns_tp0          = 1,  { Transport class 4 over CLNS and transport class 0
  nlc$sm_tp4_clns_tp2          = 2,  { Transport class 4 over CLNS and transport class 2
  nlc$sm_tp4_clns_tp0_tp2      = 3,  { Transport class 4 over CLNS and transport class 0 and 2
  nlc$sm_tp4_clns_and_cons     = 4,  { Transport class 4 over CLNS and over CONS
  nlc$sm_tp4_clns_cons_tp0_tp2 = 5;  { Transport class 4 over CLNS and over CONS and transport class 0 and 2
*DECK DECK=NLC$TA_DATA_LENGTHS EXPAND=FALSE

  CONST
    nlc$ta_maximum_accept_data_len = 32,
    nlc$ta_maximum_connect_data_len = 32,
    nlc$ta_max_disconnect_data_len = 64,
    nlc$ta_max_expedited_data_len = 16,
    nlc$ta_minimum_data_length = 1,
    nlc$ta_min_expedited_data_len = 1;
*DECK DECK=NLC$TA_SAP_RANGES EXPAND=FALSE

  CONST

{ OSI upper layer protocol

    nlc$ta_low_min_osi_sap = 0,
    nlc$ta_low_max_osi_sap = 999,

    nlc$ta_high_min_osi_sap = 3001,
    nlc$ta_high_max_osi_sap = 14649,

    nlc$ta_ftam_min_transport_sap = 3001,
    nlc$ta_ftam_max_transport_sap = 12335,

    nlc$ta_mhs_min_transport_sap = 12336,
    nlc$ta_mhs_max_transport_sap = 14649,

{ Reserved OSI and XNS transport saps associated with the Transport access
{ agent

    nlc$ta_min_rsvd_transport_sap = 1000,
    nlc$ta_max_rsvd_transport_sap = 1999,

{ Reserved CDNA session saps associated with the Transport access agent

    nlc$ta_min_rsvd_se_session_sap = 2000,
    nlc$ta_max_rsvd_se_session_sap = 3000,

{ Assignable OSI transport saps associated with the Transport access
{ agent

    nlc$ta_min_transport_sap = 14650,
    nlc$ta_max_transport_sap = 34268,

{ Assignable OSI and CDNA session saps associated with the Transport access
{ agent

    nlc$ta_min_se_session_sap = 34269,
    nlc$ta_max_se_session_sap = 65535;

*DECK DECK=NLC$TCP_MAX_POOL_SIZE EXPAND=FALSE

  CONST
    nlc$tcp_max_pool_size = 4;

*DECK DECK=NLC$TM_HASH_ELEMENTS EXPAND=FALSE

  CONST
    nlc$tm_hash_elements = 256;
*DECK DECK=NLC$UDP_MAX_POOL_SIZE EXPAND=FALSE

  CONST
    nlc$udp_max_pool_size = 4;

*DECK DECK=NLC$UDP_MAX_RESERVED_PORT EXPAND=FALSE

  CONST
    nlc$udp_max_reserved_port = 400(16);

*DECK DECK=NLC$UDP_MIN_ASSIGNED_PORT EXPAND=FALSE

  CONST
    nlc$udp_min_assigned_port = 401(16);

*DECK DECK=NLC$UDP_MIN_RESERVED_PORT EXPAND=FALSE

  CONST
    nlc$udp_min_reserved_port = 1;
*DECK DECK=NLC$UDP_NULL_GLOBAL_SOCKET_ID EXPAND=FALSE

  VAR
    nlc$udp_null_global_socket_id: nlt$udp_global_socket_id := [0, 0];

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_global_socket_id
?? POP ??
*DECK DECK=NLH$AL_DELIVER_DATA EXPAND=FALSE

{
{     The purpose of the request is to deliver data contained in the NAM/VE
{  message to an application's data area described by the buffer description.
{
{  ENTRY REQUIREMENT: the caller of this request must have a condition handler
{                     established to ensure that the buffer resources associated
{                     with 'message' are not lost if the description of the
{                     user's buffer is improper.
{
{       NLP$AL_DELIVER_DATA (MESSAGE, BUFFER_DESCRIPTION,
{           REMAINING_BUFFER_CAPACITY, SYSTEM_BUFFERS_RELEASED)
{
{  MESSAGE: (input, output) This parameter specifies the NAM/VE message which
{       contains the application destined data. If the data area capacity is
{       sufficient to hold all data, the message is released. Otherwise, the
{       undelivered data is returned in 'message'.
{
{  BUFFER_DESCRIPTION: (input, output) This parameter specifies the current
{       description of the application's data area. On output it describes the
{       the data area not filled by delivered data.
{
{  REMAINING_BUFFER_CAPACITY: (output) This parameter specifies the number of
{       bytes remaining in the application's buffer after the delivery process.
{
{  NAMVE_BUFFERS_RELEASED: (output) This parameter specifies the number of
{       NAMVE (system) buffers released as the result of this request.
{
*DECK DECK=NLH$AL_FRAGMENT_DATA EXPAND=FALSE

{
{     The purpose of the request is to fragment an the application's message
{  described by the data description into data fragments (message) acceptable
{  to the underlying network and a potential remainder.
{
{       NLP$AL_FRAGMENT_DATA (FRAGMENT_SIZE, DATA_DESCRIPTION,
{           REMAINING_DATA_LENGTH, MESSAGE)
{
{  FRAGMENT_SIZE: (input) This parameter specifies the size of the application's
{       message fragment which will become a portion of the NAM/VE message.
{
{  DATA_DESCRIPTION: (input, output) This parameter specifies the current
{       description of the application message data area (i.e., on input it
{       describes the data to be fragmented, on output it describes any
{       remainder).
{
{  REMAINING_DATA_LENGTH: (output) This parameter specifies the number of bytes
{       remaining in the application's message after the fragmentation process.
{
{  MESSAGE: (output) This parameter specifies the data fragments which resulted
{       from the request.
{
*DECK DECK=NLH$AL_GET_DATA_LENGTH EXPAND=FALSE

{
{     The purpose of the request is to obtain the data length (number of bytes)
{  of an application's message buffer.
{
{       NLP$AL_GET_DATA_LENGTH (DATA, DATA_LENGTH)
{
{  DATA: (input) This parameter specifies the application's message buffer.
{
{  DATA_LENGTH: (output) This parameter specifies the number of bytes in the
{       application's message buffer.
{
*DECK DECK=NLH$AL_GET_DATA_REQUIREMENTS EXPAND=FALSE

{
{     The purpose of the request is to obtain the data length (number of bytes)
{  of application's message buffer and the UPPERBOUND necessary to ALLOCATE OR
{  PUSH the data description which will describe the application's message
{  buffer.
{
{       NLP$AL_GET_DATA_REQUIREMENTS (DATA, DATA_LENGTH, DESCRIPTION_UPPERBOUND)
{
{  DATA: (input) This parameter specifies the application's message buffer.
{
{  DATA_LENGTH: (output) This parameter specifies the number of bytes in the
{       application's message buffer.
{
{  DESCRIPTION_UPPERBOUND: (output) This parameter specifies the upperbound of
{       required to push or allocate the data description prior to a create
{       data description request.
{
*DECK DECK=NLH$AL_INITIALIZE_DATA_DESCRIP EXPAND=FALSE
{
{
{    The purpose of the request is to initialize a data description which
{ describes an application's message buffer.  The resulting data description is
{ used to fragment the application's message into units acceptable to the
{ underlying network.
{
{       NLP$AL_INITIALIZE_DATA_DESCRIP (DATA, DATA_LENGTH, DATA_DESCRIPTION)
{
{  DATA: (input)  This parameter specifies the application's message buffer.
{
{  DATA_LENGTH: (input)  This parameter specifies the number of bytes in the
{        application's message buffer.
{
{  DATA_DESCRIPTION: (output)  This parameter specifies the data description to
{        be initialized.
{
*DECK DECK=NLH$BM_ADD_MESSAGE_PREFIX EXPAND=FALSE
{
{    The purpose of this request is to add a prefix to a message.
{
{   NOTE:  If the message identifier is invalid, prefix is NIL, or prefix
{         length is zero, a system error ('Buffer Manager Caller') will occur.
{
{       NLP$BM_ADD_MESSAGE_PREFIX (PREFIX, PREFIX_LENGTH, MESSAGE_ID)
{
{ PREFIX: (input)  This parameter specifies the address of the prefix to be
{       added to the message.
{
{ PREFIX_LENGTH: (input)  This parameter specifies the length of the prefix to
{       be added to the message.
{
{ MESSAGE_ID: (input, output)  This parameter specifies the identifier of the
{       message to which the prefix is added.
{
*DECK DECK=NLH$BM_BUILD_PVA_LIST EXPAND=FALSE
{
{    The purpose of this request is build an array of container pointers from a
{ valid non null message.
{
{       NLP$BM_BUILD_PVA_LIST (MESSAGE_ID, PVA_LIST)
{
{ MESSAGE_ID: (input)  This parameter specifies the message.
{
{ PVA_LIST: (output)  This parameter specifies the pva array.
{
*DECK DECK=NLH$BM_CONCATENATE_MESSAGES EXPAND=FALSE
{
{    The purpose of this request is to concatenate a list of messages.  The
{ individual messages are invalidated as a result of this request.
{
{    NOTE:  If a message identifier in the component list is invalid, a system
{          error ('Buffer Manager Caller') will occur.
{
{    WARNING:  DO NOT USE this interface to generate messages to be sent out
{          through the network.  The message may cause the pp to give
{          unpredicatable results.
{
{       NLP$BM_CONCATENATE_MESSAGES (COMPONENT_LIST, MESSAGE_ID)
{
{ COMPONENT_LIST: (input, output)  This parameter specifies a list of
{       identifiers of the messages to be concatenated.  These messages will be
{       invalidated as a result of this request.
{
{ MESSAGE_ID: (output)  This parameter specifies the identifier of the message
{       resulting from the concatenation.
{
{
*DECK DECK=NLH$BM_COPY_MESSAGE EXPAND=FALSE
{
{    The purpose of this request is to copy a message.
{
{    NOTE:  If the 'from' message identifier is invalid, a system error
{          ('Buffer Manager Caller') will occur.
{
{       NLP$BM_COPY_MESSAGE (FROM_MESSAGE_ID, TO_MESSAGE_ID)
{
{ FROM_MESSAGE_ID: (input)  This parameter specifies the identifier of the
{       message to be copied.
{
{ TO_MESSAGE_ID: (output)  This parameter specifies the identifier of the
{       message resulting from the copy.
{
*DECK DECK=NLH$BM_CREATE_MESSAGE EXPAND=FALSE
{
{    The purpose of this request is to create a message by moving the specified
{ data to system buffers.  Assuming a valid 'data' parameter, the request will
{ always be fulfilled.
{
{    An improper data description (data fragments) may be detected by either:
{ interrogating the status parameter or establishing a condition handler to
{ field conditions which may arise when accessing the described data.
{
{       NLP$BM_CREATE_MESSAGE (DATA, MESSAGE_ID, STATUS)
{
{ DATA: (input)  This parameter specifies the user data to be moved to system
{       buffers.
{
{ MESSAGE_ID: (output)  This parameter specifies the identifier of the created
{       message.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: condition codes reflect an improper data parameter.
{
*DECK DECK=NLH$BM_DELIVER_MESSAGE EXPAND=FALSE
{
{    The purpose of this request is to deliver message contents to a specified
{ data area and to release the delivered contents.
{
{    NOTE:  If the message identifier is invalid, a system error ('Buffer
{          Manager Caller') will occur.
{
{       NLP$BM_DELIVER_MESSAGE (DATA_AREA, MESSAGE_ID, DATA_LENGTH,
{             BUFFERS_RELEASED)
{
{ DATA_AREA: (input, output)  This parameter specifies a data area to receive
{       the content of the message on input.  On output it describes the data
{       area not filled by the delivered message.
{
{ MESSAGE_ID: (input, output)  This parameter specifies the identifier of the
{       message to be delivered.  If the data area capacity is sufficient to
{       hold the complete message, the message is released.  Otherwise, the
{       undelivered portion is returned.
{
{ DATA_LENGTH: (output)  This parameter specifies the number of bytes moved to
{       the data area.
{
{ BUFFERS_RELEASED: (output)  This parameter specifies the number of buffers
{       released as a result of this request.
{
*DECK DECK=NLH$BM_EXTRACT_MESSAGE_PREFIX EXPAND=FALSE
{
{    The purpose of this request is to extract a prefix from a message.  The
{ prefix may consist of the entire message.  The portion of the message which
{ is extracted will be released.
{
{    NOTE:  If the message identifier is invalid, prefix is NIL, or prefix
{          length is zero, a system error ('Buffer Manager Caller') will occur.
{
{       NLP$BM_EXTRACT_MESSAGE_PREFIX (PREFIX, PREFIX_LENGTH, MESSAGE_ID,
{             BYTES_MOVED)
{
{ PREFIX: (input)  This parameter specifies the address where the extracted
{       prefix is to be stored.  This address should be a pointer inside of the
{       NAM/VE segments i.e.  not a pointer into an external user's address
{       space.
{
{ PREFIX_LENGTH: (input)  This parameter specifies the length of the prefix to
{       be extracted.
{
{ MESSAGE_ID: (input, output)  This parameter specifies the identifier of the
{       message from which the prefix is extracted.  This message will be
{       released and an empty message identifier returned if the extracted
{       prefix consists of the entire message.
{
{ BYTES_MOVED: (output) This parameter specifies the amount of data actually
{       moved from the message to the prefix.  If the number of bytes in the
{       message is greater than or equal to the size of the prefix the parameters
{       bytes_moved and prefix_length will be equivalent.  If the number of bytes
{       in the message is less than the size of the prefix the bytes_moved
{       parameter will reflect the number of bytes that had actually been in the
{       message.
{
*DECK DECK=NLH$BM_FLUSH_MESSAGE EXPAND=FALSE
{
{    The purpose of this request is to move the contents of the message to a
{ specified data area and to release the message.
{
{    NOTE:  If the message identifier is invalid, a system error ('Buffer
{          Manager Caller') will occur.
{
{       NLP$BM_FLUSH_MESSAGE (DATA_AREA, MESSAGE_ID, MESSAGE_LENGTH, STATUS)
{
{ DATA_AREA: (input)  This parameter specifies a data area to receive the
{       message contents.
{
{ MESSAGE_ID: (input, output)  This parameter specifies the identifier of the
{       message to be flushed.  An invalid identifier will be returned if the
{       request completes successfully.
{
{ MESSAGE_LENGTH: (output)  This parameter specifies the length of the message
{       content moved to the data area.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$data_area_too_small
{
*DECK DECK=NLH$BM_FREE_BUFFER_POOLS EXPAND=FALSE
{
{    The purpose of this request is to free the data structures and buffers
{ which support the buffer manager services.  This request is intended solely
{ for use by the NAM/VE initialization process in the case of failure in that
{ process.
{
{    NLP$BM_FREE_BUFFER_POOLS
{
*DECK DECK=NLH$BM_GET_BUFFER_LIST EXPAND=FALSE
{
{    The purpose of this request is to obtain a set of message buffers for
{ messages received from the network.  This request is specific to the PPU /
{ CPU interface for received messages.
{
{       NLP$BM_GET_BUFFER_LIST (BUFFER_LIST, BUFFERS_ACQUIRED)
{
{ BUFFER_LIST: (input, output)  This parameter specifies the acquired buffers.
{       A nil value in the list indicates that buffers were not acquired for an
{       entry and all subsequent entries.
{
{ BUFFERS_ACQUIRED: (output)  This parameter specifies whether at least one
{       buffer has been acquired.
{
*DECK DECK=NLH$BM_GET_MESSAGE_CONTENTS EXPAND=FALSE
{
{    The purpose of this request is to obtain an image of the first n bytes of
{ a received message.  Only bytes of the first buffer of the message are
{ returned.
{
{     NOTE:  The procedure is not a general purpose function.  The procedure is
{           intended for use solely by the NAM/VE monitor mode module.
{
{       NLP$BM_GET_MESSAGE_CONTENTS (RECEIVED_MESSAGE, NUMBER_OF_BYTES,
{             CONTENTS)
{
{ RECEIVED_MESSAGE: (input)  This parameter specifies the message.
{
{ NUMBER_OF_BYTES: (input)  This parameter specifies the number of bytes
{       requested.  If the amount of data in the first message buffer is less
{       than the number of bytes requested then the size of 'contents' reflects
{       the number of bytes returned.
{
{ CONTENTS: (output)  This parameter specifies the message contents.
{
*DECK DECK=NLH$BM_GET_MESSAGE_HEADER EXPAND=FALSE
{
{    The purpose of this request is obtain an image of the first n bytes of a
{ message.  Only bytes of the first buffer of the message are returned.
{
{     NOTE:  The procedure is not for general use.  It is intended for use
{           solely by the module nlm$cc_network_event_manager.
{
{       NLP$BM_GET_MESSAGE_HEADER (MESSAGE, NUMBER_OF_BYTES, HEADER)
{
{ MESSAGE: (input)  This parameter specifies the message.
{
{ NUMBER_OF_BYTES: (input)  This parameter specifies the number of bytes
{       requested.  If the amaount of data in the first message buffer is less
{       than the number of bytes requested then the size of 'header' reflects
{       the number of bytes returned.
{
{ HEADER: (output)  This parameter specifies the message header.
{
*DECK DECK=NLH$BM_GET_MESSAGE_LENGTH EXPAND=FALSE
{
{    The purpose of this request is to return the length (in bytes) of a
{ message.
{
{    NOTE:  If the message identifier is invalid, a system error ('Buffer
{          Manager Caller') will occur.
{
{       NLP$BM_GET_MESSAGE_LENGTH (MESSAGE_ID, MESSAGE_LENGTH)
{
{ MESSAGE_ID: (input)  This parameter specifies the identifier of the message
{       whose length is to be returned.
{
{ MESSAGE_LENGTH: (output)  This parameter specifies the length of the message.
{
*DECK DECK=NLH$BM_GET_MESSAGE_PREFIX EXPAND=FALSE
{
{    The purpose of this request is to get a prefix from a message.  The prefix
{ may consist of the entire message.  This request does not change the message.
{
{    NOTE:  If the message identifier is invalid, prefix is NIL, or prefix
{          length is zero, a system error ('Buffer Manager Caller') will occur.
{
{       NLP$BM_GET_MESSAGE_PREFIX (PREFIX, PREFIX_LENGTH, MESSAGE_ID, STATUS)
{
{ PREFIX: (input)  This parameter specifies the address where the prefix is to
{       be stored.
{
{ PREFIX_LENGTH: (input)  This parameter specifies the length of the prefix to
{       be obtained.
{
{ MESSAGE_ID: (input)  This parameter specifies the identifier of the message
{       from which the prefix is to be obtained.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$insufficent_data
{
*DECK DECK=NLH$BM_GET_MESSAGE_RESOURCES EXPAND=FALSE
{
{    The purpose of this request is to obtain the length (in bytes) of a
{ message and the buffer resources consumed by the message.
{
{    NOTE:  If the message identifier is invalid, a system error ('Buffer
{          Manager Caller') will occur.
{
{       NLP$BM_GET_MESSAGE_RESOURCES (MESSAGE_ID, MESSAGE_LENGTH,
{             NUMBER_OF_BUFFERS)
{
{ MESSAGE_ID: (input)  This parameter specifies the identifier of the message
{       whose length is to be returned.
{
{ MESSAGE_LENGTH: (output)  This parameter specifies the length of the message.
{
{ NUMBER_OF_BUFFERS: (output)  This parameter specifies the number of buffers
{       consumed by the message.
{
*DECK DECK=NLH$BM_INITIALIZE_BUFFER_POOLS EXPAND=FALSE
{
{    The purpose of this request is to initialize the data structures and
{ buffers required to support the buffer manager services.
{
{       NLP$BM_INITIALIZE_BUFFER_POOLS (STATUS)
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$initialization_fatal
{
*DECK DECK=NLH$BM_RELEASE_MESSAGE EXPAND=FALSE
{
{    The purpose of this request is to release a message.  The contents of the
{ message is discarded.
{
{    NOTE:  If the message identifier is invalid, a system error ('Buffer
{          Manager Caller') will occur.
{
{       NLP$BM_RELEASE_MESSAGE (MESSAGE_ID)
{
{ MESSAGE_ID: (input, output)  This parameter specifies the identifier of the
{       message to be released.  An invalid message identifier will be
{       returned.
{
*DECK DECK=NLH$BM_RELEASE_MESSAGES EXPAND=FALSE
{
{    The purpose of this request is to release messages.  The contents of the
{ messages are discarded.
{
{    NOTE:  If a message identifier is invalid, a system error ('Buffer Manager
{          Caller') will occur.
{
{       NLP$BM_RELEASE_MESSAGES (MESSAGE_ID)
{
{ MESSAGE_ID: (input, output)  This parameter specifies the identifiers of the
{       messages to be released.  Invalid message identifiers will be returned.
{
*DECK DECK=NLH$BM_VALID_MESSAGE_ID EXPAND=FALSE
{
{    The purpose of this function is to verify the validity of a message
{ identifier.  This function is of interest since messages and their associated
{ identifiers have different lifetimes.  Some buffer manager interfaces return
{ invalid identifiers to indicate that the message being operated on has been
{ released.
{
{       NLP$BM_VALID_MESSAGE_ID (MESSAGE_ID)
{
{ MESSAGE_ID: (input)  This parameter specifies the message identifier whose
{       validity is to be verified.
{
*DECK DECK=NLH$CANCEL_TIMER EXPAND=FALSE

{
{     The purpose of this request is to cancel a NAM/VE timer.
{
{       NLP$CANCEL_TIMER (TIMER)
{
{  TIMER: (output) This parameter specifies the timer.
{
*DECK DECK=NLH$CC_ABORT_CONNECTION EXPAND=FALSE
{
{    The purpose of this request is to abort a Channel Connection (CC).  This
{ request will result in the "main" connection being closed, and a disconnect
{ event conditionally passed up to the CC user.
{
{  NOTE:  This request is intended for internal use by the Channel Connection
{        Entity and should NOT be called by users of the Channel Connection
{        service.
{
{       NLP$CC_ABORT_CONNECTION (REASON, CONNECTION, CL_CONNECTION)
{
{  REASON: (input)  This parameter specifies the reason the connection was
{        aborted.
{
{  CONNECTION: (input, output)  This parameter specifies the Channel Connection
{        description.
{
{  CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{        connection description.
{
{
*DECK DECK=NLH$CC_ACCEPT_CONNECTION EXPAND=FALSE
{
{    The purpose of this request is to accept a proposal to open a Channel
{ Connection (CC).  This request will result in the delivery of a "connect
{ confirm" event to the peer Channel Connection user residing in the CDCNET
{ device.  Upon successful completion of this request the connection is open
{ and may be used to communicate with the user who proposed the connection.
{
{       NLP$CC_ACCEPT_CONNECTION (CL_CONNECTION, CONNECTION_CLASS, DATA,
{             STATUS)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       connection that is associated with the proposed Channel Connection
{       which is to be accepted.
{
{ CONNECTION_CLASS: (input)  This parameter specifies the connection class that
{       the user has selected for this connection.  This value may or may not
{       be the same as that proposed by the peer user in the "connect request".
{
{ DATA: (input)  This parameter specifies the data to be included as part of
{       the "connect confirm" event.  The meaning of this data must be agreed
{       upon by the connection users.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             nae$connection_not_proposed
{             nae$max_data_length_exceeded
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$CC_DISCONNECT EXPAND=FALSE
{
{    The purpose of this request is to reject a proposal for Channel Connection
{ (CC) or to terminate an open connection.  Data which has been sent on the
{ connection but has not been delivered may be lost as a result of this
{ request.  This request will cause a "disconnect" event to be delivered to the
{ peer user.
{
{    For an orderly termination of a connection, the communicating users should
{ agree (thru normal communication) that no further communication is necessary
{ before either user makes this request.
{
{       NLP$CC_DISCONNECT (CL_CONNECTION, DATA, STATUS)
{
{ CL_CONNECTION: (input)  This parameter specifies the interlayer connection that
{       is associated with the Channel Connection that is to be disconnected.
{
{ DATA: (input)  This parameter specifies the data to be included as part of
{       the "disconnect" event.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             nae$max_data_length_exceeded
{             nae$connection_not_open
{       IDENTIFIER: 'NA'
{
{
*DECK DECK=NLH$CC_FIND_DUPLICATE_CONNECT EXPAND=FALSE
{
{    The purpose of this request is to determine if there is an existing
{ Channel Connection with the specified device whose peer reference number is
{ that specified in the request.
{
{       NLP$CC_FIND_DUPLICATE_CONNECT (DEVICE_ID, PEER_REFERENCE_NUMBER,
{             DUPLICATE)
{
{  DEVICE_ID: (input)  This parameter specifies the network device over which
{        the connect request was received.
{
{  PEER_REFERENCE_NUMBER: (input)  This parameter specifies reference number
{        used by the peer to identify the connection.
{
{  DUPLICATE: (output)  This parameter specifies whether such a connection
{        already exists.
{
*DECK DECK=NLH$CC_GET_DEVICE_SPECIFIC_ATTR EXPAND=FALSE
{
{    The purpose of this request is to obtain the device specific attributes
{ from the Channel Connection (CC) description for the specified device.  The
{ request also returns an indication whether the connection is the "main"
{ connection (TRUE) or a "sub" connection (FALSE).
{
{    NOTE:  This request assumes the attributes for the specified device are
{          present in the CC description.  This request is for use by the
{          Channel Connection Entity only; it is NOT to be used by users of the
{          Channel Connection service.
{
{       NLP$CC_GET_DEVICE_SPECIFIC_ATTR (DEVICE_ID, CONNECTION,
{             MAIN_CONNECTION, DEVICE_SPECIFIC_ATTRIBUTES)
{
{  DEVICE_ID: (input)  This parameter specifies the network device for which
{        the attributes are to be obtained.
{
{  CONNECTION: (input)  This parameter specifies the Channel Connection
{        description.
{
{  MAIN_CONNECTION: (output)  This parameter specifies whether the Channel
{        Connection is the "main" connection or not.
{
{  DEVICE_SPECIFIC_ATTRIBUTES: (output)  This parameter specifies the device
{        specific attributes.
{
*DECK DECK=NLH$CC_GET_EVENT_PROCESSOR EXPAND=FALSE
{
{    The purpose of this request is to obtain the connection event processor to
{ which the Channel Connection layer delivers events to.
{
{       NLP$CC_GET_EVENT_PROCESSOR (CC_ADDRESS, EVENT_PROCESSOR)
{
{  CC_ADDRESS: (input)  This parameter specifies the address of the
{        Channel Connection user.
{
{  EVENT_PROCESSOR: (output)  This parameter specifies the connection event
{        processor to which connection events are to be delivered.
{
*DECK DECK=NLH$CC_GET_EXCLUSIVE_VIA_CID EXPAND=FALSE
{
{    The purpose of this request is to gain exclusive access to a connection.
{ If exclusive access cannot be acquired, (assuming the connection exists)
{ control is returned immediately to the requestor.  If the access is acquired,
{ this request must be symmetrical with a subsequent release exclusive access
{ request.
{
{    This request is internal to the Channel Connection layer and is not to be
{ called by users of the Channel Connection layer.
{
{       NLP$CC_GET_EXCLUSIVE_VIA_CID (CONNECTION_ID, SYSTEM_INPUT_TASK,
{             CONNECTION_EXISTS, ACCESS_GAINED, CONNECTION,
{             CL_CONNECTION)
{
{  CONNECTION_ID: (input)  This parameter specifies the local connection
{        identifier of the connection to be accessed.
{
{  SYSTEM_INPUT_TASK: (input)  This parameter specifies if the requesting task
{        is the system input task.  If the requesting task is the system input
{        task and exclusive access cannot be acquired, the task is notified
{        when the the connection becomes available for access.
{
{  CONNECTION_EXISTS: (output)  This parameter specifies whether the connection
{        exists.
{
{  ACCESS_GAINED: (output)  This parameter specifies whether exclusive access
{        to the connection was acquired.
{
{  CONNECTION: (output)  This parameter specifies the Channel Connection
{        description.
{
{  CL_CONNECTION: (output)  This parameter specifies the interlayer connection
{        description.
{
*DECK DECK=NLH$CC_GET_EXCLUS_TO_UNACCEPTED EXPAND=FALSE
{
{    The purpose of this request is to acquire exclusive access to a Channel
{ Connection which apparently has not responded to a peer's connect request or
{ the response has not yet reached the peer.  Assuming such a connection
{ exists, if the access cannot be acquired, control is returned immediately and
{ the network system task is notified when the connection becomes available for
{ access.  Only the connection establishment task network event processor is to
{ utilize this request.
{
{    If the access is acquired, the request must be symmeterical with a
{ subsequent release exclusive access request.
{
{    This request is internal to the Channel Connection service and is not to
{ be called by users of the Channel Connection service.
{
{       NLP$CC_GET_EXCLUS_TO_UNACCEPTED (PEER_REFERENCE_NUMBER, DEVICE_ID,
{             SYSTEM_INPUT_TASK, CONNECTION_EXISTS,
{             ACCESS_GAINED, CONNECTION, CL_CONNECTION)
{
{  PEER_REFERENCE_NUMBER: (input)  This parameter specifies the peer's
{        connection identifier (reference number).
{
{  DEVICE_ID: (input)  This parameter specifies the network device over
{        which the message was received.
{
{  SYSTEM_INPUT_TASK: (input)  This parameter specifies if the request is being
{        made from the system input task.
{
{  CONNECTION_EXISTS: (output)  This parameter specifies whether such a
{        connection exists.
{
{  ACCESS_GAINED: (output)  This parameter specifies whether the access was
{        acquired.
{
{  CONNECTION: (output)  This parameter specifies the Channel Connection
{        description.
{
{  CL_CONNECTION: (output)  This parameter specifies the interlayer connection.
{
*DECK DECK=NLH$CC_GET_RECEIVED_MESSAGES EXPAND=FALSE
{
{    The purpose of this procedure is to dequeue all the messages from the
{ input queue on the given channel connection.  The messages in the queue are
{ in the LIFO order.
{
{       NLP$CC_GET_RECEIVED_MESSAGES (CL_CONNECTION, RECEIVED_MESSAGES)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       structure associated with the given channel connection.
{
{ RECEIVED_MESSAGES: (output)  This parameter specifies the list of received
{       messages.
{
*DECK DECK=NLH$CC_GRANT_CREDITS EXPAND=FALSE
{
{    The purpose of this request is to grant credits to the Channel Connection
{ peer.  Credits are granted via an explicit credit allocation PDU.
{
{       NLP$CC_GRANT_CREDITS (CONNECTION)
{
{  CONNECTION: (input, output)  This parameter specifies the Channel Connection
{        description.
{
*DECK DECK=NLH$CC_INITIALIZE_TEMPLATE EXPAND=FALSE
{
{     The purpose of this request is to initialize the Channel Connection layer
{  template for the path specified by the application layer.
{
{       NLP$CC_INITIALIZE_TEMPLATE (APPLICATION_LAYER)
{
{  APPLICATION_LAYER: (input) This parameter specifies the application
{       layer being utilized by an end user to interface to NAM/VE.
{
*DECK DECK=NLH$CC_MONITOR_TIMERS EXPAND=FALSE
{
{    The purpose of this request is to monitor all active Channel Connection
{ timers associated with a specified connection.  If an expired timer is found,
{ the actions implied by the expiration of that particular timer will be
{ performed.
{
{       NLP$CC_MONITOR_TIMERS (CURRENT_TIME, CL_CONNECTION)
{
{  CURRENT_TIME: (input)  This parameter_specifies the current time (i.e., the
{        time used to evaluate whether the timer has expired).
{
{  CL_CONNECTION: (input)  This parameter specifies the interlayer connection
{        description.
{
*DECK DECK=NLH$CC_OBTAIN_CREDITS EXPAND=FALSE
{
{    The purpose of this function is to return the number of additional credits
{ to be assigned to the specified connection.  If no additional credits can be
{ assigned and no credits are outstanding, then a one minute timer will be
{ selected to "wake up" the connection.
{
{   NOTE: This function is for use by the Channel Connection Entity only, and
{         is NOT intended for use by users of the Channel Connection service.
{
{       NLP$CC_OBTAIN_CREDITS (CONNECTION): INTEGER
{
{  CONNECTION: (input)  This parameter specifies the connection description.
{
*DECK DECK=NLH$CC_RECEIVE_DATA EXPAND=FALSE
{
{    The purpose of this procedure is to receive all CC PDU's queued on the
{ given channel connection and to process them one by one.  As a result of
{ this, each PDU is pushed up to the application layer.  This procedure should
{ be called only when network input is queued on the channel connection.
{
{       NLP$CC_RECEIVE_DATA (CL_CONNECTION);
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       structure asssociated with the channel connection.
{
*DECK DECK=NLH$CC_RECEIVE_EVENT EXPAND=FALSE
{
{    The purpose of this request is to receive incoming Channel Connection (CC)
{ PDU's.  This procedure may execute in the system input task or in a user
{ task.
{
{
{       NLP$CC_RECEIVE_EVENT (CC_PDU)
{
{  CC_PDU: (input, output)  This parameter specifies the message identifier
{        which describes the Channel Connection PDU.  The message identifier
{        also provides access to the received_message_descriptor which describes
{        input attributes specific to this message.
{
*DECK DECK=NLH$CC_REPORT_UNDELIVERED_DATA EXPAND=FALSE
{
{    The purpose of this request is to report to the Channel Connection layer
{ the number of undelivered message buffers accumulated at the application
{ interface on the specified connection.
{
{       NLP$CC_REPORT_UNDELIVERED_DATA (CL_CONNECTION,
{             ACCUMULATED_MESSAGE_BUFFERS)
{
{  CL_CONNECTION: (input)  This parameter specifies the interlayer connection
{        description.
{
{  ACCUMULATED_MESSAGE_BUFFERS: (input)  This parameter specifies the number of
{        undelivered message buffers.
{
{
*DECK DECK=NLH$CC_REQUEST_CONNECTION EXPAND=FALSE
{
{    The purpose of this request is to propose that a Channel Connection (CC)
{ to a specified address in the specified CDCNET device(s) be opened.  This
{ request will cause a "connect request" event to be delivered at the
{ destination address of the device(s) specified.  The peer user may accept the
{ proposed connection by sending a "connect confirm" or may reject it via a
{ "disconnect".
{
{ NOTE:  If multiple devices are specified, only the first "connect confirm"
{        will be accepted, with all other outstanding requests being terminated.
{        (i.e., the user of the Channel Connection service will only be able to
{        establish one connection per request)
{
{       NLP$CC_REQUEST_CONNECTION (CL_CONNECTION, DEVICE_AND_DATA_LIST,
{             DESTINATION_ADDRESS, CONNECTION_CLASS, STATUS)
{
{ CL_CONNECTION: (input)  This parameter specifies the interlayer connection to be
{       associated with the proposed Channel Connection.
{
{ DEVICE_AND_DATA_LIST: (input)  This parameter specifes a list of network
{       device(s) and the associated connect data. The connect request which
{       includes the connect data is sent to each specified device.
{
{ DESTINATION_ADDRESS: (input)  This parameter specifies the address within the
{       specified network device(s) to which the connection is to be made.
{
{ CONNECTION_CLASS: (input)  This parameter specifies the proposed connection
{       class for the connection.  The actual connection class selected for
{       this connection will be determined by the peer user and will be
{       communicated back to the user as part of the "connect confirm" event.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             nae$destination_not_reachable
{             nae$max_data_length_exceeded
{             nae$resources_unavailable
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$CC_REQUEUE_MSGS_ON_CONN EXPAND=FALSE
{
{    The purpose of this procedure is to requeue the given list of received
{ messages on the specified channel connection.  The messages in the list must
{ be in the LIFO order.  The list of messages is added to the tail of the input
{ queue.
{
{       NLP$CC_REQUEUE_MSGS_ON_CONN (CL_CONNECTION, RECEIVED_MESSAGES)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       structure associated with the given channel connection.
{
{ RECEIVED_MESSAGES: (input)  This parameter specifies the message list.
{
*DECK DECK=NLH$CC_RESET_DEVICE EXPAND=FALSE
{
{    The purpose of this request is to initiate the reset of the specified
{ network device.  A reset of the device will result in all connections
{ associated with the device being terminated.  This request is expected to be
{ used when a Channel Connection protocol error has been detected.
{
{   NOTE:  From NAM/VE's perspective, this request results in a device reset,
{          whether or not the entire device resets as a result is device
{          dependent.
{
{       NLP$CC_RESET_DEVICE (DEVICE_ID)
{
{  DEVICE_ID: (input)  This parameter specifies the network device to be reset.
{
*DECK DECK=NLH$CC_SEND_AGGREGATE_MESSAGE EXPAND=TRUE

{
{     The purpose of this request is to fulfill two requirements of a
{  non-application layer upper level protocol:
{     1. Send an aggregate of protocol data units as a single message on a
{        connection.  This request permits an upper level protocol to form
{        a sequence of Channel Connection (CC) protocol data units into a
{        single message to fulfill the upper level's protocol requirements.
{     2. Allow upper level protocol data unit(s) outside the interface flow
{        control imposed at an application layer to be dynamically queued
{        on the outbound send buffer.
{
{     An aggregate message may be sent outside the interface flow control
{  imposed at an application layer.  A CC data event sent as an aggregate
{  message consumes normal outbound capacity.
{
{     This request will cause delivery of expedited data and/or normal
{  data events to the peer at the other end of the connection.  Expedited
{  data is not subject to flow control and may be delivered at the other
{  end of the connection ahead of normal data which was sent earlier.
{
{     The following constaints are imposed on the usage of this request:
{       1.  Only "normal data" and "expedited data" protocol data units
{           are supported.
{       2.  The data length of a "normal data" protocol data unit is
{           restricted to the maximum data size allowed by the device
{           for which the data is to be sent.
{       3.  The data length of an "expedited data" protocol data unit is
{           restricted to the maximum data size allowed by the device
{           for which the data is to be sent.
{       4.  The connection's capacity must be sufficient to hold the entire
{           aggregate at the instance of the request.
{
{       NLP$CC_SEND_AGGREGATE_MESSAGE (CL_CONNECTION, MESSAGE, STATUS)
{
{  CL_CONNECTION: (input) This parameter specifies the interlayer connection
{       that is associated with the Channel Connection connection on which
{       the message data is to be sent.
{
{  MESSAGE: (input) This parameter specifies data to be included as part of
{       "expedited data" and/or "normal data" events.  The system buffers
{       containing the message will be released as a result of this request.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              nae$connection_not_open
{              nae$improper_aggregate_kind
{              nae$max_data_length_exceeded
{
*DECK DECK=NLH$CC_SEND_BUFFER_EMPTY EXPAND=FALSE
{
{     The purpose of this function is to determine if the send buffer
{  associated with the specified Channel Connection is empty.
{
{       NLP$CC_SEND_BUFFER_EMPTY (CONNECTION): BOOLEAN
{
{  CONNECTION: (input) This parameter specifies the  connection.
{
*DECK DECK=NLH$CC_SEND_DATA EXPAND=FALSE
{
{    The purpose of this request is to send data over an open Channel
{ Connection (CC).  This request will cause delivery of a "data" event to the
{ peer user.
{
{       NLP$CC_SEND_DATA (CL_CONNECTION, DATA, STATUS)
{
{ CL_CONNECTION: (input)  This parameter specifies the interlayer connection
{       that is associated with the Channel Connection on which data is to be
{       sent.
{
{ DATA: (input)  This parameter specifies the data to be sent.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             nae$connection_not_open
{             nae$max_data_length_exceeded
{       IDENTIFIER: 'NA'
{
{
*DECK DECK=NLH$CC_SEND_DATA_FRAGMENTS EXPAND=FALSE
{
{    The purpose of this request is to send data over an open Channel
{ Connection (CC).  This request will cause delivery of a "data" event to the
{ peer user.
{
{       NLP$CC_SEND_DATA_FRAGMENTS (CL_CONNECTION, DATA, STATUS)
{
{ CL_CONNECTION: (input)  This parameter specifies the interlayer connection
{       that is associated with the Channel Connection on which data is to be
{       sent.
{
{ DATA: (input)  This parameter specifies the data to be sent.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             nae$connection_not_open
{             nae$max_data_length_exceeded
{       IDENTIFIER: 'NA'
{
{
*DECK DECK=NLH$CC_SEND_EXPEDITED_DATA EXPAND=FALSE
{
{    The purpose of this request is to send expedited data over an open Channel
{ Connection (CC).  This request will cause delivery of an "expedited data"
{ event to the peer user.  Expedited data is not subject to connection flow
{ control and may be delivered to the peer user ahead of normal data which was
{ sent earlier.
{
{       NLP$CC_SEND_EXPEDITED_DATA (CL_CONNECTION, DATA, STATUS)
{
{ CL_CONNECTION: (input)  This parameter specifies the interlayer connection
{       that is associated with the Channel Connection on which expedited data
{       is to be sent.
{
{ DATA: (input)  This parameter specifies the expedited data to be sent.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             nae$connection_not_open
{             nae$max_data_length_exceeded
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$CC_SEND_PDU EXPAND=FALSE
{
{    The purpose of this request is to send a Channel Connection PDU to the
{ specified network device.  If the device is unavailable the PDU will be
{ discarded.
{
{   NOTE:  This is an internal request for use by the Channel Connection
{          Entity, it should NOT be used by users of the Channel Connection
{          service.
{
{       NLP$CC_SEND_PDU (DEVICE_ID, CLASS, CC_PDU)
{
{  DEVICE_ID: (input)  This parameter specifies the network device to which the
{        Channel Connection PDU is to be sent.
{
{  CLASS: (input)  This parameter specifies the connection class.
{
{  CC_PDU: (input)  This parameter specifies the Channel Connection PDU.
{
{
*DECK DECK=NLH$CC_SHUT_DOWN_CONNECTION EXPAND=FALSE
{
{    The purpose of this request is to determine whether the Channel Connection
{ layer for this connection can be deactivated.  The layer can be deactivated
{ only if the "main" Channel Connection and all "subconnections", if any, are
{ in the closed state, and if all PDU's received by monitor for this connection
{ have been processed.  This request should only be used when a Channel
{ Connection transitions to the closed state.
{
{   NOTE:  This request is for use by the Channel Connection Entity only.
{
{
{       NLP$CC_SHUT_DOWN_CONNECTION (CONNECTION, CL_CONNECTION, DEVICE_ID)
{
{  CONNECTION: (input)  This parameter specifies the Channel Connection.
{
{  CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{        connection.  The connection will be modified as a result of
{        deactivating the layer.
{
{  DEVICE_ID: (input)  This parameter specifies the identifier of the network
{        device associated with the channel connection.
{
*DECK DECK=NLH$CC_TERMINATE_CONNECTIONS EXPAND=FALSE
{
{    The purpose of this request is to terminate all Channel Connections that
{ are associated with the specified device.  This request is used when the OSI
{ communications device has reset/failed and all connections across that device
{ must be terminated.  This request will execute in the Intranet Layer Mgmt
{ task.
{
{   NOTE:  This request is intended for use by the Channel Connection service
{         only and is not to be used by users of the Channel Connection
{         service.
{
{       NLP$CC_TERMINATE_CONNECTIONS (DEVICE_ID)
{
{  DEVICE_ID: (input)  This parameter specifies the network device used to
{        determine which Channel Connections are to be terminated.
{
{
*DECK DECK=NLH$CC_WORK_LIST_PROCESSOR EXPAND=FALSE
{
{     The purpose of this request is to process packets contained in the
{  Channel Connection work list.
{
{       NLP$CC_WORK_LIST_PROCESSOR (FLAG_ID)
{
{  FLAG_ID: (input) This parameter specifies the NOS/VE system flag identifier.
{       This parameter is not significant to the processing.
{
*DECK DECK=NLH$CL_ACTIVATE_LAYER EXPAND=FALSE

{
{     The purpose of this request is to set the specified layer active in the
{  connection description.  A connection layer is active during its connection
{  establishment, data transfer, and connection disestablishment phases.  This
{  includes periods when the connection is not viable for peer communication,
{  but contains undelivered events or is maintaining timers to fulfill protocol
{  or system obligations.
{
{       NLP$CL_ACTIVATE_LAYER (LAYER, CL_CONNECTION)
{
{  LAYER: (input) This parameter specifies the connection layer.
{
{  CL_CONNECTION: (input) This parameter specifies the connection.
{
*DECK DECK=NLH$CL_ACTIVATE_RECEIVER EXPAND=FALSE

{
{     The purpose of this request is to identify the requesting task with an
{  unsatisified application receive request.  An application receive request
{  is unsatisified / active until a 'network' event has been deliverd to the
{  application.
{
{       NLP$CL_ACTIVATE_RECEIVER (CL_CONNECTION)
{
{  CL_CONNECTION: (input) This parameter specifies the connection.
{
*DECK DECK=NLH$CL_ACTIVATE_SENDER EXPAND=FALSE

{
{     The purpose of this request is to identify the requesting task with an
{  incomplete application send data request.  An application send data request
{  is incomplete / active until all application data has been transmitted via
{  the underlying network or until the connection is no longer viable for peer
{  communication.
{
{       NLP$CL_ACTIVATE_SENDER (CL_CONNECTION)
{
{  CL_CONNECTION: (input) This parameter specifies the connection.
{
*DECK DECK=NLH$CL_ACTIVE_CONNECTIONS EXPAND=FALSE

{
{     The purpose of this function is to obtain the number of active
{  connections.
{
{       NLP$CL_ACTIVE_CONNECTIONS
{
*DECK DECK=NLH$CL_ADD_DEVICE_TO_CONNECTION EXPAND=FALSE
{
{    The purpose of this request is to add a network device identifier to the
{ set of device identifiers contained in the interlayer connection structure.
{ This set of device ids is used to associate an incoming Channel Connection
{ PDU with a particular Channel Connection.
{
{       NLP$CL_ADD_DEVICE_TO_CONNECTION (DEVICE_ID, CL_CONNECTION)
{
{  DEVICE_ID: (input)  This parameter specifies the network device id to be
{        added to the interlayer connection structure.
{
{  CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{        connection structure.
{
*DECK DECK=NLH$CL_ASSIGN_CONNECTION EXPAND=FALSE

{
{     The purpose of this request is to create an interlayer connection
{  description and assign its connection identifier.  This request is to be
{  used solely by the interlayer connection manager.
{
{       NLP$CL_ASSIGN_CONNECTION (APPLICATION_LAYER, LAYER_CONECTIONS,
{           CL_CONNECTION)
{
{  APPLICATION_LAYER: (input) This parameter specifies the application layer
{       which is the ultimate user of the connection.
{
{  LAYER_CONNECTIONS: (input) This parameter specifies the set of layer
{       connection descriptions to be associated with the connection.
{
{  CL_CONNECTION: (output) This parameter specifies the assigned interlayer
{       connection.  If the assign request is unsuccessful the value is NIL.
{
*DECK DECK=NLH$CL_CLEAR_EXCLUSIVE_ACCESS EXPAND=FALSE

{
{     The purpose of this request is to clear a previously acquired exclusive
{  access to the specified connection.  If required, the network input task will
{  be notified when the access released.  This request is intended soley for use
{  by condition handlers where it may not be known if a previously acquired
{  exclusive access has been released.
{
{       NLP$CL_CLEAR_EXCLUSIVE_ACCESS (CL_CONNECTION)
{
{  CL_CONNECTION: (input, output) This parameter specifies the connection from
{       which access is to be cleared -- on output the value is NIL.
{
*DECK DECK=NLH$CL_CREATE_CONNECTION EXPAND=FALSE

{
{     The purpose of this request is to create an interlayer connection
{  description corresponding to the specified interface layer.  The requestor
{  has exclusive access to the connection upon successful complete of the
{  request.
{
{       NLP$CL_CREATE_CONNECTION (APPLICATION_LAYER, CL_CONNECTION)
{
{  APPLICATION_LAYER: (input) This parameter specifies application layer which
{       is associated with the connection.
{
{  CL_CONNECTION: (output) This parameter specifies the created connection
{       The value is NIL if the request is not successful.
{
*DECK DECK=NLH$CL_DEACTIVATE_LAYER EXPAND=FALSE

{
{     The purpose of this request is to set the specified layer inactive in the
{  connection description.  A connection layer is active during its connection
{  establishment, data transfer, and connection disestablishment phases.  This
{  includes periods when the connection is not viable for peer communication,
{  but contains undelivered events or is maintaining timers to fulfill protocol
{  or system obligations.
{
{       NLP$CL_DEACTIVATE_LAYER (LAYER, CL_CONNECTION)
{
{  LAYER: (input) This parameter specifies the connection layer.
{
{  CL_CONNECTION: (input) This parameter specifies the connection.
{
*DECK DECK=NLH$CL_DEACTIVATE_RECEIVER EXPAND=FALSE

{
{     The purpose of this request is to deactivate a previously activated
{  receiver.  A receiver becomes inactive when a 'network' event is delivered
{  to the application.
{
{       NLP$CL_DEACTIVATE_RECEIVER (CL_CONNECTION)
{
{  CL_CONNECTION: (input) This parameter specifies the connection.
{
*DECK DECK=NLH$CL_DEACTIVATE_SENDER EXPAND=FALSE

{
{     The purpose of this request is to deactivate a previously activated
{  sender.  A sender becomes inactive when an application send data request
{  is complete / inactive (i.e., all application data has been transmitted
{  via the underlying network or the connection is no longer viable for
{  application peer communication).
{
{       NLP$CL_DEACTIVATE_SENDER (CL_CONNECTION)
{
{  CL_CONNECTION: (input) This parameter specifies the connection.
{
*DECK DECK=NLH$CL_GET_CONNECTION_ACCESS EXPAND=FALSE
{
{    The purpose of this request is to gain exclusive access to a connection.
{ If exclusive access cannot be acquired, control is returned immediately to
{ the requestor.
{
{    If access is acquired, this request must be symmeterical with a subsequent
{ release exclusive access request.
{
{    NOTE:  This request is only to be used by the Timer Monitor and the
{          Channel Connection Manager.
{
{       NLP$CL_GET_CONNECTION_ACCESS (CL_CONNECTION, ACCESS_GAINED)
{
{  CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{        connection.
{
{  ACCESS_GAINED: (output)  This parameter specifies whether the exclusive
{        access was acquired.
{
*DECK DECK=NLH$CL_GET_CONNECTION_PROCESSOR EXPAND=FALSE

{
{     The purpose of this request is obtain the connection event processor
{  to which the layer delivers connection events on the path specified by
{  application layer.
{
{       NLP$CL_GET_CONNECTION_PROCESSOR (APPLICATION_LAYER, LAYER,
{           CONNECTION_PROCESSOR)
{
{  APPLICATION_LAYER: (input) This parameter specifies the application
{       layer being utilized by the end user to interface to NAM/VE.
{
{  LAYER: (input) This parameter specifies the requesting layer.
{
{  CONNECTION_PROCESSOR: (output) This parameter specifies the connection
{        event processor to which events of the layer are deliverd.
{
*DECK DECK=NLH$CL_GET_CONNECTION_TASKS EXPAND=FALSE

{
{     The purpose of this request is obtain the receiver and sender tasks
{  from a connection assuming the connection exists.
{
{     NOTE: The procedure is not a general purpose function.  The procedure
{           is intended for use solely by the NAM/VE monitor mode module.
{
{       NLP$CL_GET_CONNECTION_TASKS (REFERENCE_NUMBER, CONNECTION_FOUND,
{         RECEIVER, SENDER)
{
{  REFERENCE_NUMBER: (input) This parameter specifies the reference number
{       (i.e., abbreviated connection identifier) of the connection.
{
{  CONNECTION: (output) This parameter specifies whether the connection exists.
{       If the connection does not exist, the remaining output parameters are
{       meaningless.
{
{  RECEIVER: (output) This parameter specifies the last task recorded as a
{       receiver.
{
{  SENDER: (output) This parameter specifies the last task recorded as a
{       sender.
{
*DECK DECK=NLH$CL_GET_CONN_TIMER_EVALUATOR EXPAND=FALSE

{
{     The purpose of this request is obtain the connection timer evaluator
{  for the specified layer on the path specified by application layer.
{
{       NLP$CL_GET_CONN_TIMER_EVALUATOR (APPLICATION_LAYER, LAYER,
{           CONNECTION_TIMER_EVALUATOR)
{
{  APPLICATION_LAYER: (input) This parameter specifies the path from which
{       to obtain the layer's connection timer evaluator procedure.
{
{  LAYER: (input) This parameter specifies the layer on the path.
{
{  CONNECTION_TIMER_EVALUATOR: (output) This parameter specifies the layer's
{       connection timer evaluator procedure.  If the value is NIL, an
{       evaluator has not been defined for the layer or the layer is not
{       active.
{
*DECK DECK=NLH$CL_GET_EXCLUSIVE_ACCESS EXPAND=FALSE

{
{     The purpose of this request is to gain exclusive access to a connection.
{  Assuming the connection exists, if excluisve access cannot be acquired,
{  control is returned immediately to the requestor.
{
{      If the access is acquired, this request must be symmetrical with a
{  subsequent release exclusive access request.
{
{      ** THIS REQUEST IS NOT TO BE USED BY APPLICATION LAYERS. **
{
{       NLP$CL_GET_EXCLUSIVE_ACCESS (CONNECTION_ID, SYSTEM_INPUT_TASK,
{           CONNECTION_EXISTS, ACCESS_GAINED,
{           CL_CONNECTION)
{
{  CONNECTION_ID: (input) This parameter specifies the identifier
{       of connection to be accessed.
{
{  SYSTEM_INPUT_TASK: (input) This parameter specifies if the requesting task is
{       the system input task.  If the requesting task is the system input task
{       and exclusive access cannot be acquired, the task is notified when the
{       the connection becomes available for access.
{
{  CONNECTION_EXISTS: (output) This parameter specifies whether the connection
{       exists.
{
{  ACCESS_GAINED: (output) This parameter specifies whether the exclusive
{       access was gained.
{
{  CONNECTION: (output) This parameter specifies the accessed connection.
{
*DECK DECK=NLH$CL_GET_EXCLUSIVE_VIA_CID EXPAND=FALSE

{
{     The purpose of this request is to gain exclusive access to a connection.
{  Assuming the connection exists, control is returned when the exclusive access
{  is acquired.
{
{      This request must be symmeterical with a subsequent release exclusive
{  access request if the connection exists.
{
{       NLP$CL_GET_EXCLUSIVE_VIA_CID (CONNECTION_ID, CONNECTION_EXISTS,
{           CL_CONNECTION)
{
{  CONECTION_ID: (input) This parameter specifies the connection identifier of
{       the connection to be accessed.
{
{  CONNECTION_EXISTS: (output) This parameter specifies whether the connection
{       exists.  If the connection exists, the requestor has exclusive access
{       to the connection.
{
{  CL_CONNECTION: (output) This parameter specifies the accessed connection.
{
*DECK DECK=NLH$CL_GET_LAYER_CONNECTION EXPAND=FALSE

{
{     The purpose of the request is to obtain a pointer to a layer's connection
{  description within the interlayer connection.
{
{       NLP$CL_GET_LAYER_CONNECTION (LAYER, CL_CONNECTION, LAYER_ACTIVE,
{           CONNECTION)
{
{  LAYER: (input) This parameter specifies the requesting layer.
{
{  CL_CONNECTION: (input) This parameter specifies the interlayer connection.
{
{  LAYER_ACTIVE: (output) This parameter specifies whether the layer connection
{       has been previously set active.
{
{  CONNECTION: (output) This parameter specifies the layer's connection.
{
*DECK DECK=NLH$CL_GET_NONEXCLUSIVE_TO_ROOT EXPAND=FALSE

{
{     The purpose of this request is to gain nonexclusive access to the
{  specified connection root.  This request is to be used soley by the timer
{  monitor task.
{
{     This request must be symmeterical with a subsequent release nonexclusive
{  access request.
{
{       NLP$CL_GET_NONEXCLUSIV_TO_ROOT (ROOT)
{
{  ROOT: (input) This parameter specifies the connection root to be accessed.
{

*DECK DECK=NLH$CL_GET_SAP_PROCESSOR EXPAND=FALSE

{
{     The purpose of this request is obtain the Service Access Point event
{  processor to which the layer delivers SAP events on the connection path
{  specified by application layer.
{
{       NLP$CL_GET_SAP_PROCESSOR (APPLICATION_LAYER, LAYER, SAP_PROCESSOR)
{
{  APPLICATION_LAYER: (input) This parameter specifies the application
{       layer being utilized by the end user to interface to NAM/VE.
{
{  LAYER: (input) This parameter specifies the requesting layer.
{
{  SAP_PROCESSOR: (output) This parameter specifies the SAP event processor
{        to which events of the layer are deliverd.
{
*DECK DECK=NLH$CL_GET_SAP_TIMER_EVALUATOR EXPAND=FALSE

{
{     The purpose of this request is obtain the service access point timer
{  evaluator for the layer on the path specified by application layer.
{
{       NLP$CL_GET_SAP_TIMER_EVALUATOR (APPLICATION_LAYER, LAYER,
{           SAP_TIMER_EVALUATOR)
{
{  APPLICATION_LAYER: (input) This parameter specifies the path from which
{       to obtain the layer's service access point timer evaluator procedure.
{
{  LAYER: (input) This parameter specifies the layer on the path.
{
{  SAP_TIMER_EVALUATOR: (output) This parameter specifies the layer's service
{       access point timer evaluator procedure.  If the value is NIL, an
{       evaluator has not been defined for the layer.
{
*DECK DECK=NLH$CL_INITIALIZE_TEMPLATE EXPAND=FALSE

{
{     The purpose of this request is to initialize the connection layer
{  template for the specifed layer on a path defined by application layer.
{  This procedure is called by a layer each time a Service Access Point is
{  opened.  However, only the results of the first initialization are
{  retained.  Subsequent calls are assumed to duplicate the first call.
{  In other words a layer's template on a given connection path remains
{  static for the duration of an activation of NAM/VE.
{
{       NLP$CL_INITIALIZE_TEMPLATE (APPLICATION_LAYER, LAYER,
{           LAYER_CONNECTION_SIZE, MAXIMUM_PROTOCOL_HEADER_SIZE,
{           SAP_PROCESSOR, SAP_TIMER_EVALUATOR, CONNECTION_PROCESSOR,
{           CONNECTION_TIMER_EVALUATOR)
{
{  APPLICATION_LAYER: (input) This parameter specifies the application
{       layer being utilized by an end user to interface to NAM/VE.
{
{  LAYER: (input) This parameter specifies the layer template to be
{       initialized.
{
{  LAYER_CONNECTION_SIZE: (input) This parameter specifies the number of
{       bytes the layer requires for connection state information.
{
{  MAXIMUM_PROTOCOL_HEADER_SIZE: (input) This parameter specifies the
{       maximum number of bytes in the layer's protocol header.
{
{  SAP_PROCESSOR: (input) This parameter specifies the procedure the layer
{       calls to deliver SAP events (generally peer connect request
{       indications).  The SAP processor is a procedure of an upper layer
{       protocol.  The value may be NIL.  If a the values is non-NIL, the
{       procedure must exist all tasks.
{
{  SAP_TIMER_EVALUTATOR: (input) This parameter specifies the layer's
{       procedure which will be called periodically to evaluate SAP timers.
{       The value may be NIL. If a the values is non-NIL, the procedure
{       must exist all tasks.
{
{  CONNECTION_PROCESSOR: (input) This parameter specifies the procedure the
{       layer calls to deliver connection events.  The connection processor
{       is a procedure of an upper layer protocol. The value may be NIL.
{       If a the values is non-NIL, the procedure must exist all tasks.
{
{  CONNECTION_TIMER_EVALUTATOR: (input) This parameter specifies the layer's
{       procedure which will be called periodically to evaluate connection
{       timers.  The value may be NIL.  If a the values is non-NIL,
{       the procedure must exist all tasks.
{

*DECK DECK=NLH$CL_LAYER_ON_PATH EXPAND=FALSE

{
{     The purpose of this function is determine whether a layer is on the
{  path specified by application layer.
{
{       NLP$CL_LAYER_ON_PATH (APPLICATION_LAYER, LAYER)
{
{  APPLICATION_LAYER: (input) This parameter specifies the path.
{
{  LAYER: (input) This parameter specifies the layer.
{
*DECK DECK=NLH$CL_RECOVER_CID_SEED EXPAND=FALSE

{
{     The purpose of this request is to attempt to recover the connection
{  identifier seed from the image file prior to the point of commitment
{  during deadstart.
{
{       NLP$CL_RECOVER_CID_SEED
{
*DECK DECK=NLH$CL_RELEASE_CONNECTION EXPAND=FALSE

{
{     The purpose of this request is to release an existing connection layer connection
{  description.
{
{       NLP$CL_RELEASE_CONNECTION (CONNECTION_ID)
{
{  CONNECTION_ID: (input) This parameter specifies the connection to be released.
{

*DECK DECK=NLH$CL_RELEASE_EXCLUSIVE_ACCESS EXPAND=FALSE

{
{     The purpose of this request is to release a previously acquired exclusive
{  access to the specified connection.  If required, the network input task will
{  be notified when the access released.
{
{       NLP$CL_RELEASE_EXCLUSIVE_ACCESS (CL_CONNECTION)
{
{  CL_CONNECTION: (input, output) This parameter specifies the connection from
{       which access is to be released -- on output the value is NIL.
{
*DECK DECK=NLH$CL_RELEASE_NONEXCLU_TO_ROOT EXPAND=FALSE

{
{     The purpose of this request is to release a previously acquired
{  nonexclusive access from the specified connection root. This request is to
{  be used soley by the timer monitor task.
{
{       NLP$CL_RELEASE_NONEXCLU_TO_ROOT (ROOT)
{
{  ROOT: (input) This parameter specified the connection root.
{

*DECK DECK=NLH$CL_VALIDATE_AND_OPTIONAL_Q EXPAND=FALSE
{
{    The purpose of this procedure is to access the channel connection for
{ which the given message is destined.  The channel connection is accessed via
{ a non exclusive to the root.  The given reference number is used to find the
{ channel connection and the message is validated as belonging to the
{ referenced channel connection.  If the channel connection has the 'queue on
{ connection' attribute set and the message is other than a connect or a
{ disconnect PDU, it is queued on the channel connection and the cooresponding
{ receiver task is readied.  If the 'queue on connection' attribute is not set,
{ the requested information is returned from the channel connection.
{
{       NLP$CL_VALIDATE_AND_OPTIONAL_Q (MESSAGE_DESCRIPTOR, CC_PDU_KIND,
{             REFERENCE_NUMBER, CONSUME_SEQUENCE_NUMBER, VALIDATION_COMPLETE,
{             REFERENCE_NUMBER_VALID, MESSAGE_QUEUED, RECEIVER, SENDER)
{
{ MESSAGE_DESCRIPTOR: (input, output)  This parameter contains the pointer to
{       the message.
{
{ CC_PDU_KIND: (input) This parameter specifies the kind of the received
{       channel connection event.
{
{ RERERENCE_NUMBER: (input)  This parameter contains the reference number of
{       the channel connection for which the message is destined.
{
{ CONSUME_SEQUENCE_NUMBER: (input)  This parameter specifies whether or not a
{        Channel Connection sequence number should be consumed (i.e., whether
{        or not a unique sequence number should be assigned).  Note that only
{        data PDUs consume sequence numbers.  A disconnect or disconnect PDU
{        will not consume sequence numbers.
{
{ VALIDATION_COMPLETE: (output)  This parameter specifies whether validation
{        of the reference number was possible.  If the procedure was unable to
{        obtain access to the connection list, validation is not possible and
{        this parameter will be set to FALSE.
{
{ REFERENCE_NUMBER_VALID: (output)  This parameter specifies whether the
{        reference number is valid (i.e., whether the connection exists).  This
{        parameter is valid only if the value of the VALIDATION_COMPLETE
{        parameter is TRUE.
{
{ MESSAGE_QUEUED: (output)  This parameter is set to TRUE if the given message
{       was queued on the channel connection.  Note that if the message is not
{       going to consume sequence number it is not queued on the channel
{       connection.
{
{ RECEIVER: (output)  This parameter specifies the last task recorded as a
{        receiver.
{
{ SENDER: (output)  This parameter specifies the last task recorded as a
{        sender.
{
*DECK DECK=NLH$CL_ZERO_TERMINATED_CONNECTS EXPAND=FALSE
{
{   The purpose of this request is to clear / zero the number of terminated
{ connections.  The number of terminated connections is generally the number
{ that have been terminated since last 'running' of the timer monitor task.
{
{       NLP$CL_ZERO_TERMINATED_CONNECTS
{

*DECK DECK=NLH$CN_CLOSE_SAP EXPAND=FALSE
{
{   The purpose of this request is to terminate access to a previously opened
{ channelnet service access point.
{
{       NLP$CN_CLOSE_SAP (SAP, STATUS)
{
{ SAP: (input) This parameter specifies an open service access point to be
{       closed.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$sap_not_open
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$CN_OPEN_SAP EXPAND=FALSE
{
{   The purpose of this request is to establish access to a specific
{ channelnet service access point.  Channelnet datagrams may be sent and
{ received over the opened service access point.
{
{       NLP$CN_OPEN_SAP (SAP, EVENT_PROCESSOR, MAXIMUM_DATA_LENGTH, STATUS)
{
{ SAP: (input) This parameter specifies the service access point which is to
{       be opened.
{
{ EVENT_PROCESSOR: (input) This parameter specifies a procedure to be called
{       whenever a datagram arrives which is destined for the service access
{       point which is to be opened.  This procedure will always be called in
{       the NAM/VE system task.  If this is not an appropriate task for
{       processing the received datagram, then it is the responsibility of the
{       procedure to switch processing to an appropriate task.
{
{ MAXIMUM_DATA_LENGTH: (output) This parameter specifies the maximum length of
{       the data which may be sent over the opened service access point in a
{       single datagram.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$sap_already_open
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$CN_SEND_DATAGRAM EXPAND=FALSE
{
{    The purpose of this request is to send a channelnet datagram to a
{ specified address.  Reliable delivery of the datagram is not guaranteed.
{
{       NLP$CN_SEND_DATAGRAM (SAP, DEVICE, DESTINATION, DATA, STATUS)
{
{ SAP: (input)  This parameter specifies an open service access point from
{       which the datagram is to be sent.
{
{ DEVICE: (input)  This parameter specifies the network device thru which the
{       datagram is to be sent.
{
{ DESTINATION: (input)  This parameter specifies the system to which the
{       datagram is to be sent.  It identifies the channelnet over which the
{       datagram is to be sent and the address of the system on that
{       channelnet.
{
{ DATA: (input)  This parameter specifies the data to be delivered at the
{       destination.  The length of this data plus the upper layer protocol
{       header length may not exceed the maximum data length returned when the
{       SAP was opened.
{
{       The system buffers containing this data will be released as a result of
{       this request.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$sap_not_open
{             nae$unknown_channelnet
{             nae$max_data_length_exceeded
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$CONNECTION_QUEUED EXPAND=FALSE
{
{    The purpose of this function is to determine whether a channel connection
{ is currently in the receiving connections queue or the system input task's
{ work list.  The IN QUEUE flag is set for either of these situations.
{
{       NLP$CONNECTION_QUEUED (RECEIVING_CONNECTION): BOOLEAN
{
{ RECEIVING_CONNECTION: (input)  This parameter specifies the interlayer
{       structure associated with the given channel connection.
{
*DECK DECK=NLH$DELETE_REGISTERED_TITLE EXPAND=TRUE
{
{   The purpose of this request is to delete a registered title and associated
{ address from the directory. Client applications will no longer be given this
{ title and address in response to a translation request.
{
{        NLP$DELETE_REGISTERED_TITLE (TITLE, PASSWORD, IDENTIFIER, STATUS)
{
{ TITLE: (input) This parameter specifies the registered title to be deleted.
{
{ PASSWORD: (input) This parameter specifies the password that was given
{        on the associated nlp$register_title request.
{
{ IDENTIFIER: (input) This parameter specifies the directory entry identifier
{        assigned to uniquely identify this instance of the title registration.
{
{ STATUS: (output) This parameter specifies the request status.
{        CONDITIONS: nae$incorrect_password
{                    nae$title_id_not_found
{        IDENTIFIER: 'NA'
*DECK DECK=NLH$DELINK_RECEIVING_CONNECTION EXPAND=FALSE
{
{    The purpose of this procedure is to delink the given channel connection
{ from the list of receiving connections.  The IN QUEUE flag is not turned
{ off.  The connection id of the next connection in the list is returned to the
{ caller.
{
{       NLP$DELINK_RECEIVING_CONNECTION (RECEIVING_CONNECTION,
{             NEXT_RECEIVING_CONNECTION)
{
{ RECEIVING_CONNECTION: (input)  This parameter specifies the interlayer
{       structure associated with the given channel connection.
{
{ NEXT_RECEIVING_CONNECTION: (output)  This parameter contains the identifier
{       of the next channel connection in the list.
{
*DECK DECK=NLH$DEQUEUE_RECEIVING_CONECTION EXPAND=FALSE
{
{    The purpose of this procedure is to dequeue the given channel connection
{ from the list of receiving connections.  The IN QUEUE flag is also turned
{ off.  The connection id of the next connection in the list is returned to the
{ caller.
{
{       NLP$DEQUEUE_RECEIVING_CONECTION (RECEIVING_CONNECTION,
{             NEXT_CONNECTION_ID)
{
{ RECEIVING_CONNECTION: (input)  This parameter specifies the interlayer
{       structure associated with the given channel connection.
{
{ NEXT_RECEIVING_CONNECTION: (output)  This parameter contains the identifier
{       of the next channel connection in the list.
{
*DECK DECK=NLH$END_TITLE_TRANSLATION EXPAND=TRUE
{
{   The purpose of this request is to terminate a translation request.
{ A non-recurrent search will be terminated automatically after all
{ translations have been returned, or upon receipt of this request.
{ A recurrent search is terminated only by this request.
{
{        NLP$END_TITLE_TRANSLATION (REQUEST_ID, STATUS)
{
{ REQUEST_ID: (input) This parameter specifies the identifier assigned to
{        uniquely identify this translation request.
{
{ STATUS: (output) This parameter specifies the request status.
{        CONDITIONS: none
{        IDENTIFIER: 'NA'
*DECK DECK=NLH$FIND_DCN_ENTRY EXPAND=FALSE

{
{     The purpose of this request is to locate directly connected network
{  entry corresponding to logical unit number.
{
{  ENTRY REQUIREMENT: At least nonexclusive to the configured DCN list is
{                      required.
{
{       NLP$FIND_DCN_ENTRY (LOGICAL_UNIT_NUMBER,
{           CONFIGURED_DCN_ENTRY, ENTRY_FOUND)
{
{  LOGICAL_UNIT_NUMBER: (input) This parameter specifies the logical unit
{       number of an entry.
{
{  CONFIGURED_DCN_ENTRY: (output) This parameter specifies the DCN
{       entry.
{
{  ENTRY_FOUND: (output) This parameter specifies whether an entry
{       was located.
{
*DECK DECK=NLH$GET_LAYER_PROTOCOL_HEADER EXPAND=FALSE

{
{     The purpose of this request is to obtain a layer's protocol header
{  from the message header.  The message header and length are updated
{  as the result of the request.
{
{     If the protocol header length is greater than the message header
{  length, the result of the request is indeterminate.
{
{       NLP$GET_LAYER_PROTOCOL_HEADER (PROTOCOL_HEADER,
{             PROTOCOL_HEADER_LENGTH, MESSAGE_HEADER, MESSAGE_HEADER_LENGTH)
{
{  PROTOCOL_HEADER: (input) This parameter specifies the address of the
{       obtained protocol header.
{
{  PROTOCOL_HEADER_LENGTH: (input) This parameter specifies the length of
{       the protocol header.
{
{  MESSAGE_HEADER: (input, output) This parameter specifies the message
{       header address.
{
{  MESSAGE_HEADER_LENGTH: (input, output) This parameter specifies the length
{       of the message header.
{

*DECK DECK=NLH$GET_RECEIVING_CONNECTIONS EXPAND=FALSE
{
{    The purpose of this procedure is to get the list of connections in the
{ receiving connections queue.  This interface is meant to be called by the
{ system input task only.
{
{       NLP$GET_RECEIVING_CONNECTIONS (RECEIVING_CONNECTIONS)
{
{ RECEIVING_CONNECTIONS: (output)  This parameter contains the pointer to the
{       head of the receiving connections queue.
{
*DECK DECK=NLH$GET_TITLE_TRANSLATION EXPAND=TRUE
{
{   The purpose of this request is to obtain a title and associated
{ address of a network service for which a translation request was
{ previously made via a call to nlp$translate_title.
{
{        NLP$GET_TITLE_TRANSLATION (REQUEST_ID, TITLE, ADDRESS, PROTOCOL,
{              USER_INFORMATION, USER_INFORMATION_LENGTH, PRIORITY,
{              IDENTIFIER, STATUS)
{
{ REQUEST_ID: (input) This parameter specifies the identifier assigned to
{        uniquely identify this translation request.
{
{ TITLE: (output) This parameter specifies the registered title.
{
{ ADDRESS: (output) This parameter specifies the kind and the value of the
{        registered address.
{
{ PROTOCOL: (output) This parameter specifies the directly accessable service
{        (i.e. protocol) used by the server.
{
{ USER_INFORMATION: (input) This parameter specifies the address of a buffer
{        for up to 32 bytes of data specified by the server when the title was
{        registered.
{
{ USER_INFORMATION_LENGTH: (output) This parameter specifies the length of the
{        user information addressed by the user_information parameter.
{
{ PRIORITY: (output) This parameter specifies the priority of this instance of
{        the title registration. By convention, one is the highest priority.
{
{ USER_IDENTIFIER: (output) This parameter specifies the user identifier given
{        to this instance of the title registration by the user.
{
{ IDENTIFIER: (output) This parameter specifies the directory entry identifier
{        assigned to uniquely identify this instance of the title registration.
{
{ STATUS: (output) This parameter specifies the request status.
{        CONDITIONS: nae$no_translations_available
{                    nae$translation_req_not_active
{        IDENTIFIER: 'NA'
*DECK DECK=NLH$LA_CLOSE_SAP EXPAND=FALSE
{
{    The purpose of this request is to close the specified Link Access (LA)
{ SAP.  This will result in the termination of all LA connections associated
{ with the specified SAP.
{
{       NLP$LA_CLOSE_SAP (SAP_ID, STATUS)
{
{ SAP_ID: (input)  This parameter specifies the Link Access SAP to be closed.
{
{ STATUS: (output) This parameter specifies the request completion status.
{       CONDITIONS:
{             nae$sap_not_open
{      IDENTIFIER: 'NA'
{
*DECK DECK=NLH$LA_CONNECT_EVENT_PROCESSOR EXPAND=FALSE
{
{    The purpose of this procedure is to process the channel connection connect
{ event for the Link Access Agent (LAA).  It processes the connect event as a
{ protocol error and disconnects the channel connection.  Any data associated
{ with the connect event is released.
{
{       NLP$LA_CONNECT_EVENT_PROCESSOR (CL_CONNECTION, EVENT, INVENTORY_REPORT)
{
{ CL_CONNECTION: (input)  This parameter specifies the interlayer structure
{       associated with the channel connection connect event.
{
{ EVENT: (input)  This parameter specifies the channel connection connect
{       event.
{
{ INVENTORY_REPORT: (output)  This parameter specifies the number of message
{       buffers held on the connection at this layer.
{
*DECK DECK=NLH$LA_EVENT_PROCESSOR EXPAND=FALSE
{
{    The purpose of this request is to process incoming Link Access (LA) PDU's
{ on the specified connection.  The PDU's are processed according to the LA
{ protocol, with all valid PDU's delivered to the SAP user.  Appropriate
{ updates are also made to the layer connection structure.
{
{       NLP$LA_EVENT_PROCESSOR (CL_CONNECTION, EVENT, INVENTORY_REPORT);
{
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       connection structure associated with the channel connection over which
{       the event is delivered.
{
{ EVENT: (input)  This parameter specifies the incoming event.
{
{ INVENTORY_REPORT: (output)  This parameter specifies the number of message
{       buffers held on the connection at this layer.
{
{
*DECK DECK=NLH$LA_INITIALIZE EXPAND=FALSE
{
{    The purpose of this request is to initialize the connection template for
{ the Link Access (LA) layer.
{
{  NOTE:  This procedure should only be called during NAM/VE initialization.
{
{    NLP$LA_INITIALIZE
{
{
*DECK DECK=NLH$LA_OPEN_SAP EXPAND=FALSE
{
{    The purpose of this request is to open the specified link access SAP in
{ the specified devices.  This request will result in an open SAP request PDU
{ being sent to the Link Access Provider (LAP) residing in the OSI
{ communications device.  Communication with the LAP will take place over a
{ Channel Connection.
{
{
{       NLP$LA_OPEN_SAP (SAP_ID, DEVICE_COUNT, DEVICE_LIST, CONNECTION_CLASS,
{             EVENT_PROCESSOR, STATUS)
{
{ SAP_ID: (input)  This parameter specifies the Service Access Point (SAP) to
{       be opened.
{
{ DEVICE_COUNT: (input)  This parameter specifies the number of devices
{       specified in the DEVICE LIST.
{
{ DEVICE_LIST: (input)  This parameter specifies the devices in which the
{       specified SAP is to be opened.
{
{ CONNECTION_CLASS: (input)  This parameter specifies the requested connection
{       class for the Link Access Channel Connection.
{
{ EVENT_PROCESSOR: (input)  This parameter specifies the event processor which
{       will process incoming Link Access events.
{
{ STATUS: (output) This parameter specifies the request completion status.
{       CONDITIONS:
{             nae$allocation_failed
{             nae$la_sap_already_open
{       IDENTIFIER:
{             'NA'
{
*DECK DECK=NLH$LA_OPEN_SAPS EXPAND=FALSE
{
{    The purpose of this request is to notify the Link Access Agent (LAA) that
{ the specified device has become available and has access to the specified
{ directly connected subnets.  LAA will then determine which, if any, Link
{ Access (LA) SAPs need to be opened in the device and issue a Channel
{ Connection connect request to open a SAP on a specific subnet.
{
{  NOTE:  This procedure is only called by the System Management Access Agent
{        (SMAA).
{
{
{       NLP$LA_OPEN_SAPS (DEVICE_ID, SUBNET_COUNT, SUBNET_LIST)
{
{ DEVICE_ID: (input)  This parameter specifies the device which has become
{       available.
{
{ SUBNET_COUNT: (input)  This parameter specifies the number of subnets
{       specified in the SUBNET LIST.
{
{ SUBNET_LIST: (input)  This parameter specifies the directly connected subnets
{       to which the specified device is connected.
{
{
*DECK DECK=NLH$LA_RETRY_CONSTRAINED_SAPS EXPAND=FALSE
{
{    The purpose of this request is to attempt to open the Link Access (LA)
{ SAPs that could not be opened previously due to resource constraints.
{
{
{       NLP$LA_RETRY_CONSTRAINED_SAPS (CURRENT_TIME)
{
{ CURRENT_TIME: (input)  This parameter specifies the current time in
{       microseconds.
{
{
*DECK DECK=NLH$LA_SEND_DATA EXPAND=FALSE
{
{    The purpose of this request is to send data over the specified SAP and
{ subnet via the Link Access (LA) layer.
{
{
{       NLP$LA_SEND_DATA (SAP_ID, SUBNET_ID, DESTINATION_SUBNET_ADDRESS,
{             HEADER_FORMAT, PRIORITY, DATA, STATUS)
{
{
{ SAP_ID: (input)  This parameter specifies the Link Access SAP.
{
{ SUBNET_ID: (input)  This parameter specifies the subnet over which the data
{       is to be sent.
{
{ DESTINATION_SUBNET_ADDRESS: (input)  This parameter specifies the destination
{       subnet point of attachment address.
{
{ HEADER_FORMAT: (input)  This parameter specifies the link layer header
{       format.
{
{ PRIORITY: (input)  This parameter specifies the datagram priority.
{
{ DATA: (input)  This parameter specifies the user data.
{
{ STATUS: (output) This parameter specifies the request completion status.
{       CONDITIONS:
{             nae$sap_not_open
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$NA_BROADCAST_DATA EXPAND=FALSE
{
{    The purpose of this procedure is to broadcast the given user data over all
{ OSI subnetworks accessible via the given device.
{
{       NLP$NA_BROADCAST_DATA (DEVICE_ID, SOURCE_SAP_ID, DESTINATION_SAP_ID,
{             DATA, STATUS)
{
{ DEVICE_ID: (input)  This parameter specifies the identifier of the
{       communications device over which the data is to be broadcast.
{
{ SOURCE_SAP_ID: (input)  This parameter specifies the identifier of the source
{       network sap from which the data is to be broadcast.
{
{ DESTINATION_SAP_ID: (input)  This parameter specifies the identifier of the
{       destination network sap to which the data is to be broadcast.
{
{ DATA: (input)  This parameter specifies the user data. The maximum data
{       length is 1466 bytes.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$max_data_length_exceeded
{             nae$na_sap_not_open
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$NA_CLOSE_SAP EXPAND=FALSE
{
{    The purpose of this procedure is to close the specified network sap.  If
{ the network sap is open in the device i.e a channel connection exists between
{ the Network Access Agent (NAA) and the Network Access Provider (NAP), a
{ disconnect is sent to the NAP to close the network sap in the device.
{
{       NLP$NA_CLOSE_SAP (SAP_ID, STATUS)
{
{ SAP_ID: (input)  This parameter specifies the identifier of the network sap
{       to be closed.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$na_sap_not_open
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$NA_CONNECT_EVENT_PROCESSOR EXPAND=FALSE
{
{    The purpose of this procedure is to process the channel connection connect
{ events for the Network Access Agent.  It processes the connect event as a
{ protocol error and disconnects the channel connection.  Any data associated
{ with the connect event is released.
{
{       NLP$NA_CONNECT_EVENT_PROCESSOR (CL_CONNECTION, EVENT, INVENTORY_REPORT)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       structure associated with the channel connection connect event.
{
{ EVENT: (input)  This parameter specifies the channel connection connect
{       event.
{
{ INVENTORY_REPORT: (output)  This parameter specifies the number of message
{       buffers held on the connection at this layer.
{
*DECK DECK=NLH$NA_DISCONNECT_CONNECTIONS EXPAND=FALSE
{
{    The purpose of this procedure is to disconnect all network access
{ connections established to a given communications device. This procedure
{ is meant to be called by the System Management Access Agent whenever the
{ system management connection goes down.
{
{       NLP$NA_DISCONNECT_CONNECTIONS (DEVICE_ID)
{
{ DEVICE_ID: (input)  This parameter specifies the identifier of the given
{       device.
{

*DECK DECK=NLH$NA_EVENT_PROCESSOR EXPAND=FALSE
{
{   The purpose of this procedure is to process the events delivered to the
{ Network Access Agent over the specified channel connection. It can only
{ process the accept, data and the disconnect events.
{
{       NLP$NA_EVENT_PROCESSOR (CL_CONNECTION, EVENT, INVENTORY_REPORT)
{
{ CL_CONNECTION: (input, output) This parameter specifies the interlayer
{       structure associated with the channel connection over which the
{       event is delivered.
{
{ EVENT: (input) This parameter specifies the event to be delivered.
{
{ INVENTORY_REPORT: (output) This parameter specifies the number of message
{       buffers held on the connection at this layer.
{
*DECK DECK=NLH$NA_INITIALIZE EXPAND=FALSE
{
{   The purpose of this procedure is to initialize the template for
{ the Network Access connection. This procedure should be called
{ only once during NAM/VE initialization.
{
{       NLP$NA_INITIALIZE
{
*DECK DECK=NLH$NA_OPEN_SAP EXPAND=FALSE
{
{    The purpose of this procedure is to open the specified network sap.  The
{ open sap request is rejected if the specified sap is already open.  The open
{ network sap request is sent to the Network Access Provider in all the
{ directly connected communications devices that support the OSI protocol stack.
{ The process of opening the network sap in the communications device results
{ in establishing a channel connection between the Network Access Agent in the
{ host and the Network Access provider in the device.  This channel connection
{ represents the service access point to the OSI Connection Less Mode Network
{ layer.  All subsequent communication over the sap occurs over the channel
{ connection.  When the communications device becomes unavailable, the channel
{ connection is disconnected and no communication can occur over the sap.
{
{       NLP$NA_OPEN_SAP (PRIORITY, EVENT_PROCESSOR, SAP_ID, STATUS)
{
{ PRIORITY: (input)  This parameter specifies the network layer priority to be
{       associated with the data transferred over this sap.
{
{ EVENT_PROCESSOR: (input)  This parameter identifies the event processor to be
{       used to deliver the network events.
{
{ SAP_ID: (input)  This parameter specifies the identifier of the network layer
{       sap to be opened.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$allocation_failed
{             nae$na_sap_aready_open
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$NA_OPEN_SAPS EXPAND=FALSE
{
{    The purpose of this procedure is to send an open sap request for each
{ network sap that has been opened in the host to the specified communications
{ device.  It does not wait for the open sap confirm from the device.  The open
{ sap confirm is received by the Network Access channel connection event
{ processor.  This procedure is called by the System Management Access Agent
{ whenever a device becomes available.
{
{       NLP$NA_OPEN_SAPS (DEVICE_ID)
{
{ DEVICE_ID: (input)  This parameter specifies the identifier of the device to
{       which the open sap requests are to be sent.
{
*DECK DECK=NLH$NA_RETRY_CONSTRAINED_SAPS EXPAND=FALSE
{
{    The purpose of this procedure is to attempt to open the network layer saps
{ that had previously failed to open in the communications devices on account
{ of resource constraints.  This procedure searches the network layer sap list
{ for sap device entries that depict that the open sap processing had failed on
{ account of insufficient resources e.g.  max connections limit reached or
{ network segment heap full.  This procedure will then attempt to open these
{ saps in the appropriate devices.
{
{       NLP$NA_RETRY_CONSTRAINED_SAPS (CURRENT_TIME)
{
{ CURRENT_TIME: (input)  This parameter specifies the current time in micro
{       seconds.
{
*DECK DECK=NLH$NA_SEND_DATA EXPAND=FALSE
{
{    The purpose of this procedure is to send data over the specified
{ network sap to the given destination address via the given device.
{ This procedure sends the data over the Network Access channel connection
{ established with that device.
{
{       NLP$NA_SEND_DATA (SAP_ID, DEVICE_ID, DESTINATION, DATA, STATUS)
{
{ SAP_ID: (input)  This parameter specifies the identifier of the network sap.
{
{ DEVICE_ID: (input)  This parameter specifies the identifier of the device to
{       be used for sending the data.
{
{ DESTINATION: (input)  This parameter specifies the NSAP address of the
{       destination to which the data is to be sent.
{
{ DATA: (input)  This parameter specifies the user data.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$na_device_sap_not_open
{             nae$na_sap_not_open
{             nae$resources_unavailable
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$OSI_GET_OUTBOUND_CAPACITY EXPAND=FALSE
{
{    The purpose of this request is to obtain the current outbound capacity of
{ the connection.  The current outbound capacity is used to fragment an
{ application's message into units acceptable to the underlying network.
{
{       NLP$OSI_GET_OUTBOUND_CAPACITY (CL_CONNECTION,
{             CURRENT_CONNECTION_CAPACITY)
{
{  CL_CONNECTION: (input)  This parameter specifies the connection for which
{        the capacity is to be obtained.
{
{  CURRENT_CONNECTION_CAPACITY: (output)  This parameter specifies the maximum
{        number of bytes the underlying network is willing to accept in a
{        NAM/VE message.
{
{      NOTE:  The outbound capacity yielded will be either zero or a value
{            based on the maximum Channel Connection (CC) PDU size for the
{            network device the connection is associated with.
{
*DECK DECK=NLH$PROCESS_RECEIVING_CONECTION EXPAND=FALSE
{
{    The purpose of this procedure is to process the input messages queued on
{ the specified connection.  This procedure is setup to handle connections that
{ were queued in the receiving connections queue to be processed by the system
{ input task only.  If the given connection cannot be accessed, it will be put
{ back on the work list for later processing.
{
{   NOTE:  This process should execute in the system input task only.
{
{       NLP$PROCESS_RECEIVING_CONECTION (CONNECTION_ID)
{
{ CONNECTION_ID:  (input) This parameter specifies the identifier of the
{       connection to process.
{
*DECK DECK=NLH$REGISTER_TITLE EXPAND=TRUE
{
{   The purpose of this request is to register a title and associated
{ addresses of a network service. Client applications may then request a
{ translation of the title and receive the associated address.
{
{   A title remains registered until a call to nlp$delete_registered_title
{ is made.
{
{        NLP$REGISTER_TITLE (TITLE, OSI_ADDRESS, PROTOCOL,
{              USER_INFORMATION, USER_INFORMATION_LENGTH, PRIORITY, DOMAIN,
{              DISTRIBUTE, CLASS, PASSWORD, IDENTIFIER, STATUS)
{
{ TITLE: (input) This parameter specifies the title to be registered.
{
{ OSI_ADDRESS: (input) This parameter specifies the kind and the value of the
{        address to be registered for use of the OSI stack.
{
{ PROTOCOL: (input) This parameter specifies the directly accessable service
{        (i.e. protocol) used by the server.
{
{ USER_INFORMATION: (input) This parameter specifies the address of up to 32
{        bytes of data that is to be given to a client upon translation of
{        this title.
{
{ USER_INFORMATION_LENGTH: (input) This parameter specifies the length of the
{        user information addressed by the user_information parameter.
{
{ PRIORITY: (input) This parameter specifies the priority of this instance of
{        this title registration. By convention, one is the highest priority.
{
{ DOMAIN: (input) This parameter specifies the portion of the network that can
{        receive this title translation.
{
{ DISTRIBUTE: (input) This parameter specifies whether this translation should
{        be distributed gratuitously to all systems in it's domain upon regis-
{        tration or change. Distribution is intended to be used to notify
{        existing clients that issued a translation request with the
{        recurrent search option that a new server is present.
{
{ CLASS: (input) This parameter specifies the title class of
{        this title. Possible values are CDNA internal and CDNA external.
{        CDNA internal class is intended for use by network management
{        entities.
{
{ PASSWORD: (input) This parameter specifies a password that must be given
{        on an associated nlp$delete_registered_title or nlp$change_registered_title
{        request.
{
{ USER_IDENTIFIER: (input/output) This parameter specifies the user identifier given
{        to this instance of the title registration by the user. Note that if this
{        parameter is given the value OSC$NULL_NAME, the directory will assign a
{        unique value of the form NAI$integer on behalf of the user.
{
{ IDENTIFIER: (output) This parameter specifies the directory entry identifier
{        assigned to uniquely identify this instance of the title registration.
{
{ STATUS: (output) This parameter specifies the request status.
{        CONDITIONS: nae$duplicate_registration
{        IDENTIFIER: 'NA'
*DECK DECK=NLH$REQUEUE_MSGS_FOR_INPUT_TASK EXPAND=FALSE
{
{   The purpose of this procedure is to requeue the specified message list
{ on the queue for the system input task to process. The caller must ensure
{ that there is at least one message in the list. The system input task is
{ readied after the messages have been requeued.
{
{       NLP$REQUEUE_MSGS_FOR_INPUT_TASK (RECEIVED_MESSAGES)
{
{ RECEIVED_MESSAGES: (input) This parameter specifies the list of received
{       messages.
{
*DECK DECK=NLH$SELECT_TIMER EXPAND=FALSE

{
{     The purpose of this request is to select a NAM/VE timer.  A timer may be
{  canceled by reselecting the timer or by canceling the timer.
{
{       NLP$SELECT_TIMER (DURATION, COUNT, TIMER)
{
{  DURATION: (input) This parameter specifies the length of time (microseconds)
{       before the timer expires.
{
{  COUNT: (input) This parameter specifies a value that may reflect some
{       meaning to the requestor.
{
{  TIMER: (output) This parameter specifies the timer.
{
*DECK DECK=NLH$SE_INITIALIZE EXPAND=FALSE
{
{    The purpose of this procedure is to initialize the template for the
{ Session External Interface connection.  This procedure should be called only
{ once during NAM/VE initialization.
{
{    NLP$SE_INITIALIZE
{
*DECK DECK=NLH$SE_OPEN_SAP EXPAND=FALSE
{
{   The purpose of this request is to establish access to a service access
{ point.  Requests to open connections may be sent and received over the
{ opened service access point.
{
{       NLP$SE_OPEN_SAP (SAP_TIMER_EVALUATOR, ACCEPT_CONNECT_EVENTS,
{           MAXIMUM_ACTIVE_CONNECTIONS, SAP_PRIORITY, RESERVED_SAP, SAP,
{           STATUS)
{
{ SAP_TIMER_EVALUATOR: (input) This parameter specifies a procedure in the
{       requestor's layer to be called periodically to evaluate timers.
{
{   NOTE: SAP_TIMER_EVALUATOR must be invariant on a connection path.
{         That is, the requesting layer's timer procedure must be the
{         same for all open sap requests.
{
{ ACCEPT_CONNECT_EVENTS: (input) This parameter specifies whether the requestor
{       is willing to accept connect events from a peer.  If the requestor is
{       unwilling to accept connect events, the peer connect request is
{       rejected.
{
{ MAXIMUM_ACTIVE_CONNECTIONS: (input) This parameter specifies the maximum
{       number of connections that can be established on the service access
{       point.  Attempts to establish a connection which would cause this
{       value to be exceeded are rejected.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$sap_already_open,
{                   nae$maximum_saps_open, nae$max_active_connections_0,
{                   nae$max_active_conn_exceeded
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$SK_ACCEPT_SOCKET_OFFER EXPAND=FALSE
{
{   The purpose of this procedure is to find the socket offer made
{ to the current job from the given source job. If the socket offer
{ is found, it is accepted and the task that had offered the socket
{ is readied. However, if the socket offer is not found, the current
{ task is queued at the end of the wait for socket offer list only
{ if a non zero wait time is specified. This procedure will wait for
{ the specified time for the socket to be offered. If no socket is
{ offered and the wait time expires, the task is dequeued from the
{ wait list and an appropriate status is returned to the caller.
{ The caller must have the required validation attributes in order
{ to accept a socket offer. The validation attributes required are
{ specified by the application the offered socket belongs to.
{
{   Note that if the global socket (for UDP socket) or the channel
{ connection (for TCP socket) has been terminated via application
{ management, the terminated socket will be accepted. Subsequent
{ user requests on the accepted socket will recognize the terminated
{ status.
{
{       NLP$SK_ACCEPT_SOCKET_OFFER (SOURCE_JOB, SOCKET_ID, TIME_STAMP,
{             WAIT_TIME, SOCKET_TYPE, GLOBAL_SOCKET_ID, CONNECTION_ID,
{             TCP_SOCKET_TYPE, BOUND_ADDRESS, PORT, TRAFFIC_PATTERN,
{             APPLICATION, RING, CAPABILITY, STATUS)
{
{ SOURCE_JOB: (input) This parameter specifies the source job from which
{       the socket offer is to be accepted.
{
{ SOCKET_ID: (input) This parameter specifies the new socket identifier
{       to be associated with the offered socket. The offered socket
{       after being accepted will be known by this identifier.
{
{ TIME_STAMP: (input) This parameter specifies the time stamp to be stored
{       in the UDP global socket. This time stamp is used to validate the
{       global socket against the job socket.
{
{ WAIT_TIME: (input) This parameter specifies the time in milliseconds
{       for which the caller is willing to wait for the source job to
{       offer the socket.
{
{ SOCKET_TYPE: (output) This parameter specifies the type of socket
{       (TCP or UDP) being accepted.
{
{ GLOBAL_SOCKET_ID: (output) This parameter specifies the global socket
{       identifier associated with the accepted socket. This parameter
{       is returned only for a UDP socket.
{
{ CONNECTION_ID: (output) This parameter specifies the connection identifier
{       associated with the accepted socket. This parameter is returned
{       only for a TCP socket.
{
{ TCP_SOCKET_TYPE: (output) This parameter specifies the type (i.e. connect
{       or accept) of TCP socket.
{
{ BOUND_ADDRESS: (output) This parameter specifies the IP address to which
{       which the accepted socket is bound. An IP addess of 0 implies the socket
{       is bound to all known IP addresses.
{
{ PORT: (output) This parameter specifies the port number the accepted socket
{       is bound to.
{
{ TRAFFIC_PATTERN: (output) This parameter specifies the traffic pattern
{       attribute associated with the accepted socket.
{
{ APPLICATION: (output) This parameter specifies the name of the application
{       to which the accepted socket belongs.
{
{ RING: (output) This parameter specifies the highest ring number from which
{       the user can invoke socket layer interfaces. This request will fail
{       if the user is in a higher ring.
{
{ CAPABILITY: (output) This parameter specifies the name of the capability the
{       user must have in order to invoke socket layer interfaces. This request
{       will fail if the user does not have the required capability.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             ave$missing_required_capability
{             nae$sk_invalid_user
{             nae$sk_no_socket_offered
{
*DECK DECK=NLH$SK_ADD_JOB_SOCKET EXPAND=FALSE
{
{   The purpose of this procedure is to allocate the job socket
{ record in job pageable heap and to store the given job socket
{ attributes in the record. The pointer to the job socket is
{ stored in the array of job sockets. The corresponding entry in
{ the job socket array must have been locked by the caller.
{
{       NLP$SK_ADD_JOB_SOCKET (SOCKET_ID, JOB_SOCKET)
{
{ SOCKET_ID: (input) This parameter specifies the identifier of the
{       job socket to be added.
{
{ JOB_SOCKET: (input) This parameter contains the attributes of the
{       job socket.
{
*DECK DECK=NLH$SK_AWAIT_SOCKET_EVENTS EXPAND=FALSE
{
{    The purpose of this request is to check for the completion of the
{ specified events on the given sockets.  The list of completed events is
{ returned to the caller.  If none of the specified events has completed, the
{ execution of the current task is suspended until the completion of any one of
{ the specified events.
{    This is the internal interface that executes in ring 3 and is called by
{ the external (2DD) interface.
{
{       NLP$SK_AWAIT_SOCKET_EVENTS (SOCKET_EVENTS, COMPLETED_EVENTS, COUNT,
{             STATUS)
{
{ SOCKET_EVENTS: (input)  This parameter specifies an array of socket events to
{       be awaited.
{
{ COMPLETED_EVENTS: (output)  This parameter specifies the array of the
{       completed events.  This parameter is returned only on normal completion
{       of this request.
{
{ COUNT: (output)  This parameter specifies the count of completed events
{       returned via the COMPLETED_EVENTS parameter.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_invalid_event
{             nae$sk_null_list
{             nae$sk_unknown_socket
{
*DECK DECK=NLH$SK_AWAIT_SOCKET_OFFER EXPAND=FALSE
{
{   The purpose of this procedure is to wait for a socket to
{ be offered by the given source job to the curent job. If
{ no socket offer is found, the curent task is queued in the
{ wait for socket offer queue.
{
{       NLP$SK_AWAIT_SOCKET_OFFER (SOURCE_JOB, ACTIVITY_COMPLETE)
{
{ SOURCE_JOB: (input) This parameter identifies the source job from
{       which the socket offer is to be awaited.
{
{ ACTIVITY_COMPLETE: (output) This parameter is set to TRUE if a
{       socket offer is found from the given source job. Otherwise,
{       it is set to FALSE.
{

*DECK DECK=NLH$SK_CHECK_ACCEPT_SOCKET_AVAI EXPAND=FALSE
{
{   The purpose of this procedure is to check if a TCP socket
{ for the given application is available for the user to accept.
{ If the user specifies the wait option, the current task is queued
{ in the wait for accept socket queue.
{
{       NLP$SK_CHECK_ACCEPT_SOCKET_AVAI (APPLICATION, WAIT,
{             ACTIVITY_COMPLETE)
{
{ APPLICATION: (input) This parameter specifies the application
{       name.
{
{ WAIT: (input) This parameter is set to TRUE if the user wants to
{       wait for the socket.
{
{ ACTIVITY_COMPLETE: (output) This parameter is set to TRUE if a
{       socket is available to be accepted. Otherwise, it is set
{       to FALSE.
{

*DECK DECK=NLH$SK_CLEAR_JOB_SOCKET_LOCK EXPAND=FALSE
{
{   The purpose of this procedure is to unlock the entry
{ for the given socket identifier in the array of job sockets if it
{ is locked by this task.
{
{       NLP$SK_CLEAR_JOB_SOCKET_LOCK (SOCKET_ID)
{
{ SOCKET_ID: (input) This parameter specifies the socket identifier.
{

*DECK DECK=NLH$SK_DELETE_JOB_SOCKET EXPAND=FALSE
{
{   The purpose of this procedure is to free the job socket
{ record from the job pageable heap and to store a NIL pointer
{ in the corresponding entry for the given socket id in the array
{ of job sockets.
{
{       NLP$SK_DELETE_JOB_SOCKET (SOCKET_ID, JOB_SOCKET)
{
{ SOCKET_ID: (input) This parameter specifies the identifier of
{       the given job socket.
{
{ JOB_SOCKET: (input, output) This parameter contains the pointer
{       to the job socket record for the given socket id. On return
{       it is set to a NIL value.
{
*DECK DECK=NLH$SK_FRAGMENT_DATA EXPAND=FALSE
{
{   The purpose of the request is to extract a fragment of the specified size
{ from the given data (described via address, length pairs).  The remaining
{ data is represented by the updated address, length pairs.
{
{       NLP$SK_FRAGMENT_DATA (FRAGMENT_SIZE, CURRENT_LOWERBOUND, DATA,
{             NEW_LOWERBOUND, FRAGMENT)
{
{ FRAGMENT_SIZE: (input)  This parameter specifies the size of the fragment to
{       be extracted from the given data.
{
{ CURRENT_LOWERBOUND: (input)  This parameter specifies the starting fragment
{       in the given data.
{
{ DATA: (input)  This parameter specifies the list of address length pairs
{       describing the user data.
{
{ NEW_LOWERBOUND: (output)  This parameter specifies the starting fragment of
{       the remaining data.
{
{ FRAGMENT: (output)  This parameter specifies the list of address length pairs
{       describing the extracted fragment.
{
*DECK DECK=NLH$SK_FREE_SOCKET_ID EXPAND=FALSE
{
{   The purpose of this procedure is to free the given socket
{ identifier.
{
{       NLP$SK_FREE_SOCKET_ID (SOCKET_ID)
{
{ SOCKET_ID: (input) This parameter specifies the identifier of
{       the socket to be freed.
{
*DECK DECK=NLH$SK_GET_SOCKET_ID EXPAND=FALSE
{
{   The purpose of this procedure is to get the next assignable
{ socket identifier.
{
{       NLP$SK_GET_SOCKET_ID (SOCKET_ID)
{
{ SOCKET_ID: (output) This parameter contains the assigned socket
{       identifier. A zero value implies that all socket identifiers
{       are in use.
{
*DECK DECK=NLH$SK_LOCK_JOB_SOCKET EXPAND=FALSE
{
{   The purpose of this procedure is to lock the entry
{ for the given socket identifier in the array of job sockets.
{
{       NLP$SK_LOCK_JOB_SOCKET (SOCKET_ID, JOB_SOCKET)
{
{ SOCKET_ID: (input) This parameter specifies the socket identifier.
{
{ JOB_SOCKET: (output) This parameter contains the pointer to the
{       job socket record. Note that a NIL value will be returned
{       if the job socket has not been added yet.
{
*DECK DECK=NLH$SK_OFFER_SOCKET EXPAND=FALSE
{
{   The purpose of this procedure is to offer the given socket
{ along with the attributes to the given destination job. This
{ procedure will wait for the specified time for the socket
{ offer to be accepted by the destination job. If a task is
{ found in the wait list awaiting a socket offer from the
{ current job, it is readied and dequeued from the wait list.
{
{       NLP$SK_OFFER_SOCKET (SOCKET_ID, DESTINATION_JOB,
{             SOCKET_TYPE, GLOBAL_SOCKET_ID, CONNECTION_ID,
{             TCP_SOCKET_TYPE, PORT, BOUND_ADDRESS,
{             TRAFFIC_PATTERN, APPLICATION, RING,
{             CAPABILITY, WAIT_TIME, OFFER_ACCEPTED)
{
{ SOCKET_ID: (input) This parameter specifies the identifier of the
{       socket to be offered.
{
{ DESTINATION_JOB: (input) This parameter identifies the destination
{       job to which the socket is being offered.
{
{ SOCKET_TYPE: (input) This parameter specifies the type of socket
{       (UDP or TCP) being offered.
{
{ GLOBAL_SOCKET_ID: (input) This parameter specifies the global socket
{       identifier for the socket being offered. This parameter is
{       meaningful only when a UDP socket is being offered.
{
{ CONNECTION_ID: (input) This parameter specifies the identifier of the
{       channel connection representing a TCP socket. This parameter is
{       meaningful only if a TCP socket is being offered.
{
{ TCP_SOCKET_TYPE: (input) This parameter specifies the type (i.e. connect
{       or accept) of the TCP socket.
{
{ PORT: (input) This parameter specifies the port number to which the
{       given socket is bound.
{
{ BOUND_ADDRESS: (input) This parameter specifies the IP address to which
{       the given socket is bound. A zero IP address implies that the socket
{       is bound to all known IP addresses.
{
{ TRAFFIC_PATTERN: (input) This parameter specifies the anticipated flow of
{       data on the socket.
{
{ APPLICATION: (input) This parameter specifies the name of the application
{       to which the given socket belongs.
{
{ RING: (input) This parameter specifies the highest ring number from which
{       the user of the socket can invoke socket layer interfaces. The user
{       accepting the socket offer must meet this requirement.
{
{ CAPABILITY: (input) This parameter specifies the name of the capability
{       the user of the socket must have in the validation file in order to
{       invoke socket layer interfaces. The user accepting the socket offer
{       must meet this requirement.
{
{ WAIT_TIME: (input) This parameter specifies the number of milliseconds the
{       user is willing to wait for the socket offer to be accepted by the
{       destination job.
{
{ OFFER_ACCEPTED: (output) This parameter is set to TRUE if the socket offer
{       is accepted by the destination job in the given time.
{
*DECK DECK=NLH$SK_PROCESS_JOB_RECOVERY EXPAND=FALSE
{
{   The purpose of this procedure is to mark all job local socket
{ layer structures as being recovered. This procedure is meant to
{ to be called only during job recovery.
{
{       NLP$SK_PROCESS_JOB_RECOVERY
{
*DECK DECK=NLH$SK_REMOVE_WAIT_SOCKET_OFFER EXPAND=FALSE
{
{   The purpose of this procedure is to remove the current task
{ from the wait for socket offer queue.
{
{       NLP$SK_REMOVE_WAIT_SOCKET_OFFER (SOURCE_JOB)
{
{ SOURCE_JOB: (input) This parameter identifies the source job from
{       which the socket offer was being awaited.
{
*DECK DECK=NLH$SK_TCP_ACCEPT_SOCKET EXPAND=FALSE
{
{    The purpose of this procedure is to access the global structure for the
{ listen socket corresponding to the given port number/IP address pair and to
{ return the channel connection identifier of the next received socket.  If
{ there are no received sockets to be accepted and a non zero wait time has
{ been specified, the current task is queued in the "wait for socket" list and
{ the task is suspended for the specified time.  Otherwise an appropriate error
{ status is returned to the caller.
{
{       NLP$SK_TCP_ACCEPT_SOCKET (PORT, BOUND_ADDRESS, GRACEFUL_CLOSE,
{             TRAFFIC_PATTERN, WAIT_TIME, CONNECTION_ID, SOURCE_SOCKET,
{             LOCAL_IP_ADDRESS, STATUS)
{
{ PORT: (input)  This parameter specifies the port number associated with the
{       listen socket.
{
{ BOUND_ADDRESS: (input)  This parameter specifies the IP address to which
{       listen socket is bound.
{
{ GRACEFUL_CLOSE: (input)  This parameter specifies the graceful close option
{       for received socket.  This value is communicated to the TCP protocol
{       layer.
{
{ TRAFFIC_PATTERN: (input)  This parameter specifies the traffic pattern option
{       for the received socket.  This value is communicated to the TCP
{       protocol layer.
{
{ WAIT_TIME: (input)  This parameter specifies the time in milliseconds for
{       which the user is willing to wait.
{
{ CONNECTION_ID: (output)  This parameter contains the identifier of the
{       channel connection associated with the received socket.
{
{ SOURCE_SOCKET: (output)  This parameter contains the source address from
{       which the socket was received.
{
{ LOCAL_IP_ADDRESS: (output)  This parameter contains the local IP address over
{       which the socket was received.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_no_accept_socket
{             nae$sk_socket_terminated
{
*DECK DECK=NLH$SK_TCP_ACTIVATE_LISTEN EXPAND=FALSE
{
{    The purpose of this procedure is to insert the listen socket corresponding
{ to the given application name and the port/IP address pair in the list of
{ active listen sockets.  If the listen socket is bound to all known IP
{ addresses, the listen socket request is sent to each device supporting the
{ TCP protocol.  If the listen socket is bound to a specific IP address, the
{ listen socket request is sent to only the device supporting that IP address.
{
{       NLP$SK_TCP_ACTIVATE_LISTEN (SOCKET_ID, APPLICATION, PORT,
{             BOUND_ADDRESS, QUEUE_LIMIT, SELECTION_CRITERIA, STATUS)
{
{ SOCKET_ID: (input)  This parameter specifies the job local identifier of the
{       listen socket.
{
{ APPLICATION: (input)  This parameter specifies the application name
{       associated with the listen socket.
{
{ PORT: (input)  This parameter specifies the port number to which the listen
{       socket has been bound.
{
{ BOUND_ADDRESS: (input)  This parameter specifies the IP address to which the
{       listen socket has been bound.
{
{ QUEUE_LIMIT: (input)  This parameter specifies the limit on the number of
{       unaccepted sockets to be queued on the listen port.  This attribute is
{       communicated to the communications device via the listen request.
{
{ SELECTION_CRITERIA: (input)  This parameter specifies the port number and/or
{       IP address of the source from which the server application is willing
{       to accept sockets.  A value of 0 implies all ports/and or IP addresses.
{       This attribute is communicated to the communications device via the
{       listen request.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_insufficient_resources
{             nae$sk_no_device_configured
{             nae$sk_socket_terminated
{
*DECK DECK=NLH$SK_TCP_AWAIT_CLEAR_TO_SEND EXPAND=FALSE
{
{    The purpose of this procedure is to access the channel connection
{ coresponding to the given connection id to check if sufficient resources are
{ available to send data.  If other senders are active or resources are
{ unavailable, the current task is queued at the end of the send queue.  The
{ task is dequeued and readied whenever resources become available.
{
{       NLP$SK_TCP_AWAIT_CLEAR_TO_SEND (CONNECTION_ID, ACTIVITY_COMPLETE)
{
{ CONNECTION_ID: (input)  This parameter specifies the channel connection
{       identifier.
{
{ ACTIVITY_COMPLETE: (output)  This parameter is set to TRUE if the clear
{       to send condition is present.
{
*DECK DECK=NLH$SK_TCP_AWAIT_DATA_AVAILABLE EXPAND=FALSE
{
{    The purpose of this procedure is to access the channel connection
{ corresponding to the given connection id to check if there is data waiting
{ to be received.  If other receivers are active or there is no data to be
{ received, the current task is queued at the end of the receive queue.  The
{ task is readied whenever data is received.
{
{       NLP$SK_TCP_AWAIT_DATA_AVAILABLE (CONNECTION_ID, WAIT, ACTIVITY_COMPLETE)
{
{ CONNECTION_ID: (input)  This parameter specifies the channel connection
{       identifier.
{
{ WAIT: (input) This parameter is set to TRUE if the caller is willing to wait
{       for the arrival of data at the given socket.
{
{ ACTIVITY_COMPLETE: (output)  This parameter is set to TRUE if data is
{       available for receipt.
{
*DECK DECK=NLH$SK_TCP_CANCEL_SOCKET_OFFER EXPAND=FALSE
{
{    The purpose of this procedure is to access the channel connection for the
{ given connection id and to reset the state of the TCP socket interface layer.
{ However if the connection has been disconnected or terminated via application
{ mangement, the state is left unchanged, the TCP socket interface layer is
{ deactivated and an appropriate status is returned to the caller.
{
{       NLP$SK_TCP_CANCEL_SOCKET_OFFER (CONNECTION_ID, STATUS)
{
{ CONNECTION_ID: (input)  This parameter specifies the channel connection
{       identifier.
{
{ STATUS: (output) This parameter specifies the request status
{       CONDITION:
{             nae$sk_socket_disconnected
{             nae$sk_socket_terminated
{
*DECK DECK=NLH$SK_TCP_CHECK_ACCEPT_SOCKET EXPAND=FALSE
{
{    The purpose of this procedure is to access the global structure for the
{ listen socket corresponding to the given application name, port number and
{ the bound address to check if there is a received socket waiting to be
{ accepted.  If there are no received sockets and wait is TRUE, the current
{ task is queued in the wait for socket list.  The task is readied and dequeued
{ on receipt of an accept socket.
{
{       NLP$SK_TCP_CHECK_ACCEPT_SOCKET (APPLICATION, PORT, BOUND_ADDRESS,
{             WAIT, ACTIVITY_COMPLETE)
{
{ APPLICATION: (input)  This parameter specifies the application name.
{
{ PORT: (input)  This parameter specifies the port number to which the listen
{       socket is bound.
{
{ BOUND_ADDRESS: (input)  This parameter specifies the IP address to which the
{       listen socket is bound.
{
{ WAIT: (input)  This parameter specifies whether the caller would like to wait
{       for an accept socket.
{
{ ACTIVITY_COMPLETE: (output) This parameter is set to TRUE if an accept socket
{       is available.
{
*DECK DECK=NLH$SK_TCP_CLOSE_SOCKET EXPAND=FALSE
{
{    The purpose of this procedure is to close the channel connection
{ corresponding to the given connection id.  All active senders and receivers
{ are signalled and a release socket or flush release socket (graceful close =
{ true) request is sent to the peer.  The TCP socket interface layer connection
{ is deactivated if there are no active senders or receivers queued on the
{ connection.
{
{       NLP$SK_TCP_CLOSE_SOCKET (CONNECTION_ID, GRACEFUL_CLOSE)
{
{ CONNECTION_ID: (input)  This parameter specifies the channel connection
{       identifier.
{
{ GRACEFUL_CLOSE: (input)  This parameter is set to TRUE if graceful close has
{       been requested.
{
*DECK DECK=NLH$SK_TCP_CONN_EVENT_PROCESSOR EXPAND=FALSE
{
{    The purpose of this procedure is to process the connect event received
{ from the TCP access Agent.  The connect event is queued on the listen socket
{ corresponding to the destination socket address.
{
{       NLP$SK_TCP_CONN_EVENT_PROCESSOR (CL_CONNECTION, EVENT,
{             INVENTORY_REPORT)
{
{ CL_CONNECTION: (input, output) This parameter specifies the interlayer
{       structure associated with the TCP Access Agent connect event.
{
{ EVENT: (input) This parameter specifies the TCP Access Agent connect event.
{
{ INVENTORY_REPORT: (output) This parameter specifies the number of message
{       buffers held on the connection at this layer.
{
*DECK DECK=NLH$SK_TCP_DEACTIVATE_LAYER EXPAND=FALSE
{
{    The purpose of this procedure is to free the entries in all pools
{ maintained in the TCP interface layer connection in the given channel
{ connection.  The TCP interface layer is then deactivated.
{
{       NLP$SK_TCP_DEACTIVATE_LAYER (CL_CONNECTION, TCP_CONNECTION)
{
{ CL_CONNECTION: (input)  This parameter specifies the interlayer structure
{       associated with the channel connection connect event.
{
{ TCP_CONNECTION: (input)  This parameter specifies the pointer to the TCP
{       interface layer connection.
{
*DECK DECK=NLH$SK_TCP_DEVICE_AVAILABLE EXPAND=FALSE
{
{    The purpose of this procedure is to reopen the active listen sockets in the
{ given device that has just become available.  The list of active listen
{ sockets is scanned for the ones that are either bound to all known IP
{ addresses or to the given IP address.  For each such listen socket, a listen
{ socket request is sent to the given device.
{
{       NLP$SK_TCP_DEVICE_AVAILABLE (DEVICE_ID, IP_ADDRESS)
{
{ DEVICE_ID: (input)  This parameter specifies the identifier of the device
{       that has become available.
{
{ IP_ADDRESS: (input)  This parameter specifies the IP address associated with
{       the device.
{
*DECK DECK=NLH$SK_TCP_EVENT_PROCESSOR EXPAND=FALSE
{
{    The purpose of this procedure is to process the events delivered to the
{ TCP socket interface by the TCP Access Agent over the channel connection
{ associated with a socket.
{
{       NLP$SK_TCP_EVENT_PROCESSOR (CL_CONNECTION, EVENT, INVENTORY_REPORT)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       structure associated with the TCP Access Agent event.
{
{ EVENT: (input)  This parameter specifies the TCP Access Agent event.
{
{ INVENTORY_REPORT: (output)  This parameter specifies the number of message
{       buffers held on the connection at this layer.
{
*DECK DECK=NLH$SK_TCP_GET_LISTEN_ADDRESSES EXPAND=FALSE
{
{   The purpose of this procedure is to get the list of IP addresses
{ to which the given listen socket is currently bound.
{
{       NLP$SK_TCP_GET_LISTEN_ADDRESSES (APPLICATION, PORT,
{             BOUND_ADDRESS, LISTEN_ADDRESSES, COUNT, STATUS)
{
{ APPLICATION: (input) This parameter specifies the application name
{       associated with the listen socket.
{
{ PORT: (input) This parameter specifies the port number for the listen
{       socket.
{
{ BOUND_ADDRESS: (input) This parameter specifies that the listen socket
{       has been bound to all known IP addresses.
{
{ LISTEN_ADDRESSES: (output) This parameter contains all the IP addresses
{       to which the listen socket has been bound.
{
{ COUNT: (output) This parameter contains the count of IP addresses being
{       returned by the previous parameter.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_socket_terminated
{
*DECK DECK=NLH$SK_TCP_GET_REC_TASK_ENTRY EXPAND=FALSE
{
{   The purpose of this procedure is to get the receiver task entry
{ from the pool of receiver task entries. If the pool is empty, this
{ procedure allocates an entry.
{
{       NLP$SK_TCP_GET_REC_TASK_ENTRY (TCP_CONNECTION, RECEIVER_TASK)
{
{ TCP_CONNECTION: (input) This parameter contains the pointer to the
{       layer connection for TCP socket interface.
{
{ RECEIVER_TASK: (output) This parameter contains the pointer to the
{       receiver task entry.
{
*DECK DECK=NLH$SK_TCP_GET_SEND_TASK_ENTRY EXPAND=FALSE
{
{   The purpose of this procedure is to get the sender task entry
{ from the pool of sender task entries. If the pool is empty, this
{ procedure allocates an entry.
{
{       NLP$SK_TCP_GET_SEND_TASK_ENTRY (TCP_CONNECTION, SENDER_TASK)
{
{ TCP_CONNECTION: (input) This parameter contains the pointer to the
{       layer connection for TCP socket interface.
{
{ SENDER_TASK: (output) This parameter contains the pointer to the
{       sender task entry.
{
*DECK DECK=NLH$SK_TCP_GET_SOCKET_STATUS EXPAND=FALSE
{
{   The purpose of this procedure is to access the channel connection for
{ the given connection id to check if there are sufficient resources to
{ send data and to check if there is data to be received.
{
{       NLP$SK_TCP_GET_SOCKET_STATUS (CONNECTION_ID, CLEAR_TO_SEND,
{             DATA_PENDING_RECEIVE, STATUS)
{
{ CONNECTION_ID: (input) This parameter specifies the channel connection identifier.
{
{ CLEAR_TO_SEND: (OUTPUT) This parameter is set to TRUE if clear to send condition
{       exists on the connection.
{
{ DATA_PENDING_RECEIVE: (output) This parameter specifies the length of the data
{       available to be received.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_socket_disconnected
{             nae$sk_socket_terminated
{
*DECK DECK=NLH$SK_TCP_INITIALIZE EXPAND=FALSE
{
{   The purpose of this procedure is to initialize the template for the
{ TCP portion of the Socket Layer. This procedure should be called only
{ once during NAM/VE initialization.
{
{       NLP$SK_TCP_INITIALIZE
{
*DECK DECK=NLH$SK_TCP_INITIALIZE_POOLS EXPAND=FALSE
{
{    The purpose of this procedure is to initialize the pools of available
{ sender, receiver task entries and the pool of available received data
{ entries.
{
{       NLP$SK_TCP_INITIALIZE_POOLS (TCP_CONNECTION)
{
{ TCP_CONNECTION: (input, output)  This parameter contains the pointer to the
{       TCP interface layer connection.
{
*DECK DECK=NLH$SK_TCP_OFFER_SOCKET EXPAND=FALSE
{
{    The purpose of this procedure is to access the channel connection for the
{ given connection id to check if there are any senders or receivers active on
{ the connection.  If there are no active senders and receivers the state of
{ the TCP socket interface layer is marked as being offered.  If the TCP socket
{ interface layer is closed or terminated, the layer is deactivated if there is
{ no IO active and the appropriate status is returned to the caller.
{
{       NLP$SK_TCP_OFFER_SOCKET (CONNECTION_ID, STATUS)
{
{ CONNECTION_ID: (input) This parameter specifies the channel connection
{       identifier.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_io_pending
{             nae$sk_socket_disconnected
{             nae$sk_socket_terminated
{
*DECK DECK=NLH$SK_TCP_REMOVE_ACCEPT_SOCKET EXPAND=FALSE
{
{    The purpose of this procedure is to remove the entry for the current task
{ from the wait for socket list maintained on the listen socket for the given
{ application name, port number and bound address.
{
{       NLP$SK_TCP_REMOVE_ACCEPT_SOCKET (APPLICATION, PORT, BOUND_ADDRESS)
{
{ APPLICATION: (input)  This parameter specifies the application name
{       associated with the listen socket.
{
{ PORT: (input)  This parameter specifies the port number to which the listen
{       socket is bound.
{
{ BOUND_ADDRESS: (input)  This parameter specifies the IP address to which the
{       listen socket is bound.
{
*DECK DECK=NLH$SK_TCP_REMOVE_CLEAR_TO_SEND EXPAND=FALSE
{
{    The purpose of this procedure is to remove the entry for the current task
{ from the send queue maintained on the TCP socket interface layer in the given
{ channel connection.
{
{       NLP$SK_TCP_REMOVE_CLEAR_TO_SEND (CONNECTION_ID)
{
{ CONNECTION_ID: (input)  This parameter specifies the channel connection
{       identifier.
{
*DECK DECK=NLH$SK_TCP_REMOVE_DATA_AVAIL EXPAND=FALSE
{
{    The purpose of this procedure is to remove the entry for the current task
{ from the receive queue maintained on the TCP socket interface layer for the
{ given channel connection.
{
{       NLP$SK_TCP_REMOVE_DATA_AVAIL (CONNECTION_ID)
{
{ CONNECTION_ID: (input)  This parameter specifies the channel connection
{       identifier.
{
*DECK DECK=NLH$SK_TCP_RET_REC_DATA_ENTRY EXPAND=FALSE
{
{    The purpose of this procedure is to return the received data entry.  If
{ the TCP interface layer connection is open the received data entry is
{ returned to the pool of available received data entries only if the number of
{ entries in the pool is below the allowed maximum.  If the TCP interface layer
{ connection is closed or terminated or the number of entries in the pool is at
{ the allowed maximum, the received data entry is freed.
{
{       NLP$SK_TCP_RET_REC_DATA_ENTRY (TCP_CONNECTION, RECEIVED_DATA)
{
{ TCP_CONNECTION: (input, output)  This parameter contains the pointer to the
{       layer connection for TCP socket interface.
{
{ RECEIVED_DATA: (input)  This parameter contains the pointer to the received
{       data entry to be returned.
{
*DECK DECK=NLH$SK_TCP_RET_REC_TASK_ENTRY EXPAND=FALSE
{
{    The purpose of this procedure is to return the receiver task entry.  If
{ the TCP interface layer connection is open the receiver task entry is
{ returned to the pool of available receiver task entries only if the number of
{ entries in the pool is below the allowed maximum.  If the TCP interface layer
{ connection is closed or terminated or the number of entries in the pool is at
{ the allowed maximum, the receiver task entry is freed.
{
{       NLP$SK_TCP_RET_REC_TASK_ENTRY (TCP_CONNECTION, RECEIVER_TASK)
{
{ TCP_CONNECTION: (input, output)  This parameter contains the pointer to the
{       layer connection for TCP socket interface.
{
{ RECEIVER_TASK: (input)  This parameter contains the pointer to the receiver
{       task entry to be returned.
{
*DECK DECK=NLH$SK_TCP_RET_SEND_TASK_ENTRY EXPAND=FALSE
{
{    The purpose of this procedure is to return the sender task entry.  If the
{ TCP interface layer connection is open the sender task entry is returned to
{ the pool of available sender task entries only if the number of entries in
{ the pool is below the allowed maximum.  If the TCP interface layer connection
{ is closed or terminated or the number of entries in the pool is at the
{ allowed maximum, the sender task entry is freed.
{
{       NLP$SK_TCP_RET_SEND_TASK_ENTRY (TCP_CONNECTION, SENDER_TASK)
{
{ TCP_CONNECTION: (input, output)  This parameter contains the pointer to the
{       layer connection for TCP socket interface.
{
{ SENDER_TASK: (input)  This parameter contains the pointer to the sender task
{       entry to be returned.
{
*DECK DECK=NLH$SK_TCP_SEND_DATA EXPAND=FALSE
{
{    The purpose of this procedure is to send as much data as is allowed by
{ system and network resources on the given channel connection.  If all data is
{ not sent, the data fragments are updated and the remaining data is returned
{ to the caller.
{
{       NLP$SK_TCP_SEND_DATA (CL_CONNECTION, INITIAL_CAPACITY, DATA,
{             DATA_LENGTH, PUSH_FLAG, URGENT_FLAG, STARTING_FRAGMENT,
{             REMAINING_FRAGMENT, REMAINING_DATA_LENGTH)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       structure associated with the channel connection.
{
{ INITIAL_CAPACITY: (input)  This parameter specifies the initial capacity on
{       the channel connection.  A non zero capacity represents a clear to send
{       condition.  On input the capacity must be non-zero.
{
{ DATA: (input, output)  This parameter specifies the data fragments to be
{       sent.  On return, it contains the remaining data fragments.
{
{ DATA_LENGTH: (input)  This parameter specifies the length of the data to be
{       sent.
{
{ PUSH_FLAG: (input)  This parameter specifies the value of the PUSH flag to be
{       associated with the data.
{
{ URGENT_FLAG: (input)  This parameter specifies the value of the URGENT flag
{       to be associated with the data.
{
{ STARTING_FRAGMENT: (input)  This parameter specifies the next fragment from
{       which to start sending data.
{
{ REMAINING_FRAGMENT: (output)  This parameter contains the starting fragment
{       of the remaining data.
{
{ REMAINING_DATA_LENGTH: (output)  This parameter contains the length of the
{       remaining data
{
*DECK DECK=NLH$SK_TCP_SET_LISTEN_OPTIONS EXPAND=FALSE
{
{    The purpose of this procedure is to store the new selection criteria in
{ the listen socket for the given application name, port and bound address.
{ Note that the new selection criteria is not sent to the communications
{ device.  However, if a TCP device becomes available subsequent to this
{ request, the new selection criteria will be sent to that device.  It may
{ cause some confusion as the devices intialized before this request will be
{ working with the previous value of the selection criteria.
{
{       NLP$SK_TCP_SET_LISTEN_OPTIONS (APPLICATION, PORT, BOUND_ADDRESS,
{             SELECTION_CRITERIA, STATUS)
{
{ APPLICATION: (input)  This parameter specifies the application name
{       associated with the listen socket.
{
{ PORT: (input)  This parameter specifies the port number to which the listen
{       socket is bound.
{
{ BOUND_ADDRESS: (input)  This parameter specifies the IP address to which the
{       listen socket is bound.
{
{ SELECTION_CRITERIA: (input)  This parameter specifies the port number and or
{       IP address from which the server application is willing to accept
{       sockets.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_socket_terminated
{
*DECK DECK=NLH$SK_TCP_SET_SOCKET_OPTIONS EXPAND=FALSE
{
{    The purpose of this procedure is to store the specified socket options in
{ the TCP socket interface layer in the given channel connection.  This
{ procedure is meant for accept or connect sockets only.  The new socket
{ options are sent to the communications device.
{
{       NLP$SK_TCP_SET_SOCKET_OPTIONS (CONNECTION_ID, GRACEFUL_CLOSE,
{             TRAFFIC_PATTERN, STATUS)
{
{ CONNECTION_ID: (input)  This parameter specifies the channel connection
{       identifier.
{
{ GRACEFUL_CLOSE: (input)  This parameter specifies the graceful close option.
{
{ TRAFFIC_PATTERN: (input)  This parameter specifies the traffic pattern
{       option.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_socket_disconnected
{             nae$sk_socket_terminated
{
*DECK DECK=NLH$SK_TCP_TERMINATE_ALL_LISTEN EXPAND=FALSE
{
{    The purpose of this procedure is to terminate all the active listen
{ sockets for the given application. This procedure is called when an
{ application is deactivated via application management.
{
{       NLP$SK_TCP_TERMINATE_ALL_LISTEN (APPLICATION)
{
{ APPLICATION: (input) This parameter specifies the application name.
{
*DECK DECK=NLH$SK_TCP_TERMINATE_LISTEN EXPAND=FALSE
{
{    The purpose of this procedure is to terminate the listen socket
{ corresponding to the given application, port and bound address.
{
{       NLP$SK_TCP_TERMINATE_LISTEN (APPLICATION, PORT, BOUND_ADDRESS)
{
{ APPLICATION: (input)  This parameter specifies the application name
{       associated with the listen socket.
{
{ PORT: (input)  This parameter specifies the the port number to which the
{       listen socket is bound.
{
{ BOUND_ADDRESS: (input)  This parameter specifies the IP address to which the
{       listen socket is bound.
{
*DECK DECK=NLH$SK_TCP_TERMINATE_SOCKET EXPAND=FALSE
{
{   The purpose of this procedure is to terminate the given channel
{ connection. All active senders and receivers are signalled. If there
{ is no IO active on the TCP socket interface layer, the layer is
{ deactivated. This procedure should be called to terminate the channel
{ connections associated with accept or connect sockets only.
{
{        NLP$SK_TCP_TERMINATE_SOCKET (CONNECTION_ID)
{
{ CONNECTION_ID: (input) This parameter specifies the channel connection
{        identifier.
{
*DECK DECK=NLH$SK_UNLOCK_JOB_SOCKET EXPAND=FALSE
{
{   The purpose of this procedure is to unlock the entry
{ for the given socket identifier in the array of job sockets.
{
{       NLP$SK_UNLOCK_JOB_SOCKET (SOCKET_ID)
{
{ SOCKET_ID: (input) This parameter specifies the socket identifier.
{
*DECK DECK=NLH$SK_UPDATE_BOUND_ADDRESS EXPAND=FALSE
{
{   The purpose of this procedure is to store the given bound
{ address in the job socket record for the given socket identifier.
{
{       NLP$SK_UPDATE_BOUND_ADDRESS (SOCKET_ID, BOUND_ADDRESS)
{
{ SOCKET_ID: (input) This parameter specifies the socket identifier.
{
{ BOUND_ADDRESS: (input) This parameter specifies the IP address
{       to which the given socket is bound.
{
*DECK DECK=NLH$SK_UPDATE_CONNECT_SOCKET EXPAND=FALSE
{
{    The purpose of this procedure is to update the fields in the job socket
{ associated with a TCP connect socket.
{
{       NLP$SK_UPDATE_CONNECT_SOCKET (SOCKET_ID, CONNECTION_ID,
{             LOCAL_IP_ADDRESS)
{
{ SOCKET_ID: (input)  This parameter specifies the socket identifier.
{
{ CONNECTION_ID: (input)  This parameter specifies the identifier of the
{       channel connection associated with the connect socket.
{
{ LOCAL_IP_ADDRESS: (input)  This parameter specifies the local IP address over
{       which the channel connection is established.
{
*DECK DECK=NLH$SK_UPDATE_JOB_SOCKET EXPAND=FALSE
{
{    The purpose of this procedure is to store the given port number, bound
{ address and the socket status in the job socket record for the given socket
{ identifier.
{
{       NLP$SK_UPDATE_JOB_SOCKET (SOCKET_ID, PORT, BOUND_ADDRESS,
{             SOCKET_STATUS)
{
{ SOCKET_ID: (input)  This parameter specifies the socket identifier.
{
{ PORT: (input)  This parameter specifies the port number to which the given
{       socket is bound.
{
{ BOUND_ADDRESS: (input)  This parameter specifies the IP address to which the
{       given socket is bound.
{
{ SOCKET_STATUS: (input)  This parameter specifies the current status of the
{       socket.
{
*DECK DECK=NLH$SK_UPDATE_JOB_SOCKET_STATUS EXPAND=FALSE
{
{   The purpose of this procedure is to update the status of the
{ job socket. The job socket must be locked by the caller.
{
{       NLP$SK_UPDATE_JOB_SOCKET_STATUS (SOCKET_ID, STATUS)
{
{ SOCKET_ID: (input) This parameter specifies the socket identifier.
{
{ STATUS: (input) This parameter specifies the new status of the job
{       job socket.
{

*DECK DECK=NLH$SK_UPDATE_LISTEN_FLAG EXPAND=FALSE
{
{   The purpose of this procedure is to turn on the flag
{ that identifies the given socket to be listen socket. It
{ also stores the given port number in the job socket record.
{
{       NLP$SK_UPDATE_LISTEN_FLAG (SOCKET_ID, PORT)
{
{ SOCKET_ID: (input) This parameter specifies the socket identifier.
{
{ PORT: (input) This parameter specifies the port number to
{       which the given socket is bound.
{
*DECK DECK=NLH$SK_UPDATE_LISTEN_SOCKET EXPAND=FALSE
{
{   The purpose of this procedure is to update the port number in
{ job socket structure for the given socket id. The TCP socket type
{ is also initialized.
{
{       NLP$SK_UPDATE_LISTEN_SOCKET (SOCKET_ID, PORT)
{
{ SOCKET_ID: (input) This parameter specifies the socket identifier.
{
{ PORT: (input) This parameter specifies the port number to which the
{       listen socket is bound.
{
*DECK DECK=NLH$SK_UPDATE_SOCKET_OPTIONS EXPAND=FALSE
{
{   The purpose of this procedure is to store the given socket
{ options in the job socket record for the given socket identifier.
{ The socket options must have been validated by the caller. The
{ given job socket must be locked by the caller prior to calling
{ this procedure.
{
{       NLP$SK_UPDATE_SOCKET_OPTIONS (SOCKET_ID, OPTIONS)
{
{ SOCKET_ID: (input) This parameter specifies the socket identifier.
{
{ OPTIONS: (input) This parameter specifies the list of selected
{       socket options.
{
*DECK DECK=NLH$SL_CALL_REQUEST EXPAND=FALSE
{
{    The purpose of this request is to propose that a connection to a specified
{ address be opened.
{
{       NLP$SL_CALL_REQUEST (CL_CONNECTION, SAP, DESTINATION, DATA, STATUS)
{
{ CL_CONNECTION: (input)  This parameter specifies the interlayer connection
{       that is to be associated with the Session connection.
{
{ SAP: (input)  This parameter specifies an open service access point over
{       which the connection is to be opened.
{
{ DESTINATION: (input)  This parameter specifies the address to which the
{       connection is to be made.
{
{ DATA: (input)  This parameter specifies data to be delivered at the
{       destination address as part of the "connect" event.  The meaning of
{       this data must be agreed upon by the communicating users.  The length
{       of this data may not exceed 512 bytes.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$max_active_connections
{             nae$max_data_length_exceeded
{
*DECK DECK=NLH$SL_CALL_RESPONSE EXPAND=FALSE
{
{   The purpose of this request is to accept a proposal to open a connection.
{ This request will cause delivery of an "connect_confirm" event to the user
{ who proposed the connection.  Upon completion of this request the connection
{ is open and may be used to communicate with the user who proposed the
{ connection.
{
{       NLP$SL_CALL_RESPONSE (XNS_CONNECTION, DATA, STATUS)
{
{ XNS_CONNECTION: (input) This parameter specifies the proposed connection which
{       is to be accepted.
{
{ DATA: (input) This parameter specifies data to be included as part of the
{       "accept" event.  The meaning of this data must be agreed upon by the
{       communicating users.  The length of this data may not exceed 512 bytes.
{       The system buffers containing this data will be released as a result
{       of this request.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$SL_CLEAR_REQUEST EXPAND=FALSE
{
{    The purpose of this request is to terminate a connection.  This
{ request will cause the delivery of a "clear" event to the other
{ end of the connection.
{
{       NLP$SL_CLEAR_REQUEST (XNS_CONNECTION, DATA, STATUS);
{
{ XNS_CONNECTION: (input) This parameter specifies the XNS connection that is
{      to be terminated.
{
{ DATA: (input) This parameter specifies data to be included as part of
{      the "clear" event.  The length of this data may not exceed 512 bytes.
{
{ STATUS: (input) This parameter specifies the request status.
{      CONDITIONS:
{      IDENTIFIER: 'NA'
{
*DECK DECK=NLH$SL_CLOSE_SAP EXPAND=FALSE
{
{   The purpose of this request is to terminate access to a previously opened
{ service access point.
{
{       NAP$SL_CLOSE_SAP (SAP, STATUS)
{
{ SAP: (input) This parameter specifies an open service access point to be
{       closed.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$SL_DATA_REQUEST EXPAND=FALSE
{
{   The purpose of this request is to send data over an open connection.  This
{ request will cause delivery of a "data" event to the user at to other end of
{ the connection.
{
{ ENTRY REQUIREMENTS: The application layer is responsible for ensuring
{                     adequate outbound capacity, interface flow control,
{                     exists on the connection to hold all "data" (See:
{                     nlp$xns_get_outbound_capacity). Otherwise, there is
{                     the potential for a catastrophicsystem error.
{
{       NLP$SL_DATA_REQUEST (XNS_CONNECTION, QUALIFIED_DATA,
{         END_OF_MESSAGE, DATA, STATUS)
{
{ XNS_CONNECTION: (input) This parameter specifies the XNS connection on which
{       data is to be sent.
{
{ QUALIFIED_DATA: (input) This parameter specifies whether the DATA parameter
{      contains qualified data.  The significance of qualified data must be
{      agreed upon by the communicating users.
{
{ END_OF_MESSAGE: (input) This parameter specifies the end of the message
{      boundary.
{
{ DATA: (input) This parameter specifies data to be included as part of the
{      "data" event.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$connection_not_open, nae$protocol_error,
{                   nae$invalid_request
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$SL_INITIALIZE EXPAND=FALSE
{
{    The purpose of this procedure is to initialize the template for the
{ Session Internal Interface connection.  This procedure should be called only
{ once during NAM/VE initialization.
{
{       NLP$SL_INITIALIZE (SAP_PROCESSOR, CONNECTION_PROCESSOR,
{             APPLICATION_LAYER)
{
{ SAP_PROCESSOR: (input)  This parameter specifies a procedure in the
{       requestor's layer to be called to accept delivery of connect events
{       occurring on the service access point which is to be opened.  This
{       procedure will always be called in a NAM/VE system task.  If this is
{       not an appropriate task for processing the delivered event, then it is
{       the responsibility of the procedure to switch processing to an
{       appropriate task.
{
{ CONNECTION_PROCESSOR: (input)  This parameter specifies a procedure in the
{       requestor's layer to be called to accept delivery of connection events
{       occurring on the service access point.  This procedure may be called in
{       any task.  If the called task is not an appropriate task for processing
{       the delivered event, then it is the responsibility of the procedure to
{       switch processing to an appropriate task.
{
{ APPLICATION_LAYER: (input)  This parameter specifies the application layer
{       that is ultimate user of the service access ponit.
{
*DECK DECK=NLH$SL_INTERRUPT_REQUEST EXPAND=FALSE
{
{    The purpose of this request is to transmit data over a previously
{ opened connection and bypass the normal flow controls enforced on a
{ connection.  This request will cause the delivery of an "interrupt"
{ event to the user at the other end of the connection.
{
{    NOTE: outbound connection capacity need not be sufficient to hold
{          "data".  In other words an application layer is not required
{          to ensure adequate outbound capacity before issuing this request.
{          Resources beyond outbound capacity exist for interrupt
{          requests, but the resource is limited and hence the "supervisory
{          traffic limit" condition.  Generally, a "supervisory traffic
{          limit" condition will occur if the connection peers are not
{          responding according to protocol.
{
{       NLP$SL_INTERRUPT_REQUEST (XNS_CONNECTION, DATA, STATUS)
{
{ XNS_CONNECTION: (input) This parameter specifies the XNS connection on which
{       the interrupt is to be sent.
{
{ DATA: (input) This parameter specifies 1 to 14 bytes of data to be delivered
{       with the "interrupt" event.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$connection_not_open, nae$data_area_too_small,
{                   nae$invalid_request, nae$max_data_length_exceeded,
{                   nae$protoco_error, nae$supervisory_traffic_limit.
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$SL_OPEN_SAP EXPAND=FALSE

{
{   The purpose of this request is to establish access to a service access
{ point.  Requests to open connections may be sent and received over the
{ opened service access point.
{
{       NLP$SL_OPEN_SAP (SAP_PROCESSOR, CONNECTION_PROCESSOR, APPLICATION_LAYER,
{           ACCEPT_CONNECT_EVENTS, MAXIMUM_ACTIVE_CONNECTIONS, SAP_PRIORITY,
{           RESERVED_SAP, SAP, STATUS)
{
{ SAP_PROCESSOR: (input) This parameter specifies a procedure in the requestor's
{       layer to be called to accept delivery of connect events occurring on
{       the service access point which is to be opened.  This procedure will
{       always be called in a NAM/VE system task.  If this is not an appropriate
{       task for processing the delivered event, then it is the responsibility
{       of the procedure to switch processing to an appropriate task.
{
{ CONNECTION_PROCESSOR: (input) This parameter specifies a procedure in the
{       requestor's layer to be called to accept delivery of connection events
{       occurring on the service access point.  This procedure may be called in
{       any task.  If the called task is not an appropriate task for processing
{       the delivered event, then it is the responsibility of the procedure to
{       switch processing to an appropriate task.
{
{   NOTE: SAP_PROCESSOR and CONNECTION_PROCESSOR must be invariant on a
{         connection path defined by APPLICATION_LAYER.  That is, the
{         requesting layer's processor procedures must be the same for all
{         open sap requests.
{
{ APPLICATION_LAYER: (input) This parameter specifies the application layer
{       that is ultimate user of the service access ponit.
{
{ ACCEPT_CONNECT_EVENTS: (input) This parameter specifies whether the requestor
{       is willing to accept connect events from a peer.  If the requestor is
{       unwilling to accept connect events, the peer connect request is
{       rejected.
{
{ MAXIMUM_ACTIVE_CONNECTIONS: (input) This parameter specifies the maximum
{       number of connections that can be established on the service access
{       point.  Attempts to establish a connection which would cause this
{       value to be exceeded are rejected.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$sap_already_open, nae$invalid_reserved_sap,
{                   nae$maximum_saps_open, nae$max_active_connections_0,
{                   nae$max_active_conn_exceeded
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$SL_SYNCH_REQUEST EXPAND=FALSE

{
{    The purpose of this request is to reinitialize a connection.  This
{ request will cause the delivery of a "synch" event to the other
{ end of the connection.
{
{    NOTE: outbound connection capacity need not be sufficient to hold
{          "data".  In other words an application layer is not required
{          to ensure adequate outbound capacity before issuing this request.
{          Resources beyond outbound capacity exist for synchronization
{          requests, but the resource is limited and hence the "supervisory
{          traffic limit" condition.  Generally, a "supervisory traffic
{          limit" condition will occur if the connection peers are not
{          responding according to protocol.
{
{       NLP$SL_SYNCH_REQUEST (XNS_CONNECTION, DISCARD_OPTION, DATA, STATUS);
{
{ XNS_CONNECTION: (input) This parameter specifies the XNS connection that is
{      to be reinitialized.
{
{ DISCARD_OPTION: (input) This parameter specifies whether the connection
{      is to be reinitialized in both directions or just in the send
{      direction or just in the receive direction.
{
{ DATA: (input) This parameter specifies 1 to 14 bytes of data to be delivered
{      with the "synch" event.
{
{ STATUS: (input) This parameter specifies the request status.
{      CONDITIONS: nae$connection_not_open, nae$protocol_error,
{                  nae$max_data_length_exceeded, nae$data_area_too_small,
{                  nae$supervisory_traffic_limit.
{      IDENTIFIER: 'NA'
{
*DECK DECK=NLH$SL_SYNCH_RESPONSE EXPAND=FALSE

{
{    The purpose of this request is to confirm the arrival of the "synch"
{ event.  This request will cause the delivery of a "synch confirm" event
{ to the other end of the connection.
{
{    NOTE: An application layer may issue this request without regard to
{          outbound connection capacity.  Resources beyond outbound capacity
{          exist for synchronization responses, but the resource is limited
{          and hence the "supervisory traffic limit" condition.  Generally,
{          a "supervisory traffic limit" condition will occur if the connection
{          peers are not responding according to protocol.
{
{       NLP$SL_SYNCH_RESPONSE (XNS_CONNECTION, STATUS)
{
{ XNS_CONNECTION: (input) This parameter specifies the XNS connection on which
{       the confirm is to be sent.
{
{ STATUS: (input) This parameter specifies the request status.
{       CONDITION: nae$connection_not_open, nae$supervisory_traffic_limit.
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$SM_CONNECT_EVENT_PROCESSOR EXPAND=FALSE
{
{    The purpose of this procedure is to process the channel connection connect
{ event for the System Management Access Agent.
{
{       NLP$SM_CONNECT_EVENT_PROCESSOR (CL_CONNECTION, EVENT, INVENTORY_REPORT)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       structure associated with the channel connection connect event.
{
{ EVENT: (input)  This parameter specifies the channel connection connect
{       event.
{
{ INVENTORY_REPORT: (output)  This parameter specifies the number of message
{       buffers held on the connection at this layer.
{
*DECK DECK=NLH$SM_EVENT_PROCESSOR EXPAND=FALSE
{
{    The purpose of this procedure is to process the events delivered to the
{ System Management Access Agent over the specified channel connection.  It can
{ only process the data and the disconnect events.
{
{       NLP$SM_EVENT_PROCESSOR (CL_CONNECTION, EVENT, INVENTORY_REPORT)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       structure associated with the channel connection over which the event
{       is delivered.
{
{ EVENT: (input)  This parameter specifies the event to be delivered.
{
{ INVENTORY_REPORT: (output)  This parameter specifies the number of message
{       buffers held on the connection at this layer.
{
*DECK DECK=NLH$SM_INITIALIZE EXPAND=FALSE
{
{   The purpose of this procedure is to initialize the template for
{ the System Management connection. This procedure should be called
{ only once during NAM/VE initialization.
{
{       NLP$SM_INITIALIZE
{
*DECK DECK=NLH$SM_SELECT_DEVICE EXPAND=FALSE
{
{    The purpose of this procedure is to return the identifier of the device
{ most suitable for reaching the given destination address.  For a CDNA address
{ it first identifies the devices that support the prefix in the given
{ destination address.  The subnet attributes lists associated with these
{ devices are further searched to find the device with the best path to the
{ destination address.  The device selection algorithm load levels across the
{ directly connected devices. If the subnet is not found in the subnet list
{ or if the destination address is NON CDNA, the directly connected devices are
{ polled for routing information.  The procedure awaits the responses from
{ all the devices.  The device that can reach the destination and has the least
{ number of active connections is selected. In case none of the devices can
{ reach the given destination address, an abnormal status is returned to the
{ caller.  If the route to the given subnet is indeterminate, a list of
{ identifiers of the devices through which the given destination may be
{ accessible, is returned to the caller.
{
{       NLP$SM_SELECT_DEVICE (DESTINATION_ADDRESS, CDNA_ADDRESS, DEVICE_LIST,
{             COUNT, STATUS)
{
{ DESTINATION_ADDRESS: (input)  This parameter specifies the OSI destination
{       address.
{
{ CDNA_ADDRESS: (input)  This parameter has a value of TRUE if the given
{       destination address is a CDNA address and is FALSE otherwise.
{
{ DEVICE_LIST: (output)  This parameter specifies the identifier of the device
{       through which the given destination address is accessible or a list of
{       identifiers of all the devices through which the given destination
{       address may be accessible.  The upperbound of this array must be equal
{       to the number of configured network devices.
{
{ COUNT: (output)  This parameter specifies the count of the device identifiers
{       specified via the previous parameter (DEVICE LIST).
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$insufficient_resources
{             nae$sm_devices_inaccessible
{             nae$sm_no_device_configured
{             nae$sm_route_unknown
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLH$TA_ACCEPT_CONNECTION EXPAND=FALSE
{
{
{    The purpose of this request is to accept a proposal to open a connection.
{ This request will cause delivery of an "accept" event to the user who
{ proposed the connection.  Upon completion of this request the connection is
{ open and may be used to communicate with the user who proposed the
{ connection.
{
{       NLP$TA_ACCEPT_CONNECTION (CL_CONNECTION, CHECKSUM, DATA,
{             EXPEDITED_DATA, PRIORITY, QUALITY_OF_SERVICE, STATUS)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       connection that is associated with the transport access agent
{       connection to be accepted.
{
{ CHECKSUM: (input)  This parameter specifies that data sent and received by
{       transport in the communication device should be checksummed.
{
{ DATA: (input, output)  This parameter specifies data to be included as part
{       of the "accept" event.  The meaning of this data must be agreed upon by
{       the communicating users.  The length of this data may not exceed 32
{       bytes.  The system buffers containing this data will be released as a
{       result of this request.
{
{ EXPEDITED_DATA: (input)  This parameter specifies whether the transport
{       service provider should process expedited data requests and
{       indications.  Note expedited data can only be negotiated down i.e.  if
{       expedited data was proposed as TRUE on the connect indication expedited
{       data can be negotiated to FALSE.  Conversly, if expedited data was
{       proposed as FALSE it cannot be negotiated to TRUE.
{
{ PRIORITY: (input)  This parameter specifies the priority of the proposed
{       connection.  Zero is the lowest priority and 14 is the highest
{       priority.  A value outside of the zero to 14 range is interpreted as
{       zero.
{
{ QUALITY_OF_SERVICE: (input)  This parameter specifies the transport user's
{       requirements.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$ta_accept_conn_not_pending
{             nae$ta_accept_data_length_error
{             nae$ta_connection_terminated
{
*DECK DECK=NLH$TA_CLOSE_SAP EXPAND=FALSE
{
{    The purpose of this request is to terminate access to a previously opened
{ service access point.  Previously established connections will remain active.
{
{       NLP$TA_CLOSE_SAP (SAP, STATUS)
{
{ SAP: (input)  This parameter specifies an open service access point to be
{       closed.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=NLH$TA_CONNECT_EVENT_PROCESSOR EXPAND=FALSE
{
{
{    The purpose of this request is to process the connect events generated by
{ the channel connection.
{
{       NLP$TA_CONNECT_EVENT_PROCESSOR (CL_CONNECTION, EVENT, INVENTORY_REPORT)
{
{  CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{        connection description which was created by the channel connection.
{        The transport access agent will initialize its portion of the
{        connection.
{
{  EVENT: (input, output)  This parameter specifies the channel connection
{        event.
{
{  INVENTORY_REPORT: (output)  This parameter specifies the number of message
{        buffers being held on the connection at this and higher layers.
{
*DECK DECK=NLH$TA_DISCONNECT_CONNECTION EXPAND=FALSE
{
{
{    The purpose of this request is to disconnect an open connection.
{ Undelivered data on the connection may be lost as a result of this request.
{ This request will result in the delivery of a "disconnect" event to the user
{ at the other end of the connection.
{
{    For an orderly termination of a connection, the communicating users should
{ agree (thru normal communication) that no further communication is necessary
{ before issuing this request.
{
{       NLP$TA_DISCONNECT_CONNECTION (CL_CONNECTION, DATA, STATUS)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       connection that is associated with the transport access agent
{       connection to be disconnected.
{
{ DATA: (input, output)  This parameter specifies data to be included as part
{       of the "disconnect" event.  It may be used to communicate the reason
{       for the disconnect.  The length of this data may not exceed 64 bytes.
{       The system buffers containing this data will be released as a result of
{       this request.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$ta_connection_terminated
{             nae$ta_disconnect_data_len_err
{
*DECK DECK=NLH$TA_EVENT_PROCESSOR EXPAND=FALSE
{
{
{    The purpose of this request is to process all events delivered by the
{ channel connection after the transport access agent connection has been
{ established.
{
{       NLP$TA_EVENT_PROCESSOR (CL_CONNECTION, EVENT, INVENTORY_REPORT)
{
{  CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{        connection description which contains the transport access agent
{        connection description.
{
{  EVENT: (input, output)  This parameter specifies the channel connection
{        event.
{
{  INVENTORY_REPORT: (output)  This parameter specifies the number of message
{        buffers being held on the connection at this and higher layers.
{
*DECK DECK=NLH$TA_INITIALIZE EXPAND=FALSE
{
{    The purpose of this procedure is to initialize the template for the
{ Transport Acess Agent connection.  This procedure should be called only once
{ during NAM/VE initialization.
{
{       NLP$TA_INITIALIZE (APPLICATION_LAYER, CONNECT_EVENT_PROCESSOR,
{             EVENT_PROCESSOR)
{
{ APPLICATION_LAYER: (input)  This parameter specifies the application layer
{       that is the ultimate user of the given service access point.
{
{ CONNECT_EVENT_PROCESSOR: (input)  This parameter specifies a procedure in the
{       requestor's layer to be called to accept delivery of connect events
{       occurring on the service access point which is to be opened.  This
{       procedure will always be called in a NAM/VE system task.
{
{ EVENT_PROCESSOR: (input)  This parameter specifies a procedure in the
{       requestor's layer to be called to accept delivery of all events
{       delivered over an established connection.  This procedure can be called
{       in one of three different tasks:  the receiver's task, the sender's
{       task, or the system input task.  The receiver's task is the first
{       choice.  If the receiver is active and the job is not swapped out this
{       is the task the incoming event will be processed in.  If the receiver
{       is unavailable the sender's task is the second choice.  If the sender
{       is active and the job is not swapped out this is the task the incomming
{       event will be processed in.  IF neither the receiver nor the sender is
{       available the incoming event will be processed in the system input
{       task.  NOTE:  the exception is the "CLEAR_TO_SEND" where the first
{       choice for processing will be the sender's task, the second choice will
{       be the receiver's task, and the final choice is the system input task.
{
*DECK DECK=NLH$TA_OPEN_SAP EXPAND=FALSE
{
{    The purpose of this request is to setup the connection template to be used
{ on subsequent connect request and connect indications.
{
{       NLP$TA_OPEN_SAP (APPLICATION_LAYER, CONNECT_EVENT_PROCESSOR,
{             EVENT_PROCESSOR, SAP, STATUS)
{
{ APPLICATION_LAYER: (input)  This parameter specifies the application layer
{       that is the ultimate user of the given service access point.
{
{ CONNECT_EVENT_PROCESSOR: (input)  This parameter specifies a procedure in the
{       requestor's layer to be called to accept delivery of connect events
{       occurring on the service access point which is to be opened.  This
{       procedure will always be called in a NAM/VE system task.
{
{ EVENT_PROCESSOR: (input)  This parameter specifies a procedure in the
{       requestor's layer to be called to accept delivery of all events
{       delivered over an established connection.  This procedure can be called
{       in one of three different tasks:  the receiver's task, the sender's
{       task, or the system input task.  The receiver's task is the first
{       choice.  If the receiver is active and the job is not swapped out this
{       is the task the incoming event will be processed in.  If the receiver
{       is unavailable the sender's task is the second choice.  If the sender
{       is active and the job is not swapped out this is the task the incomming
{       event will be processed in.  IF neither the receiver nor the sender is
{       available the incoming event will be processed in the system input
{       task.  NOTE:  the exception is the "CLEAR_TO_SEND" where the first
{       choice for processing will be the sender's task, the second choice will
{       be the receiver's task, and the final choice is the system input task.
{
{   NOTE:  CONNECT_EVENT_PROCESSOR AND EVENT_PROCESSOR must be invariant on a
{         connection path defined by APPLICATION_LAYER.  That is, the
{         requesting layer's processor procedures must be the same for all open
{         sap requests.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=NLH$TA_REQUEST_CONNECTION EXPAND=FALSE
{
{
{    The purpose of this request is to propose that a connection to a specified
{ address be opened.  This request will cause delivery of a "connect" event at
{ the destination address.  The user at that address may accept the proposed
{ connection by calling NLP$TA_ACCEPT_CONNECTION.  This will result in an
{ "accept" event being delivered to the event processor specified on the open
{ sap request.  Delivery of the accept event signals that the connection is
{ open and may be used to communicate with the user at the destination address.
{
{    Alternatively, the user at the destination address may reject the proposed
{ connection by calling NLP$TA_DISCONNECT_CONNECTION.  This will result in a
{ "disconnect" event being delivered to the event_processor specified on the
{ open sap request.
{
{       NLP$TA_REQUEST_CONNECTION (CL_CONNECTION, SAP, CHECKSUM, DATA,
{             DESTINATION_TRANSPORT_SAP, DESTINATION_NETWORK_ADDRESS,
{             CDNA_DESTINATION_ADDRESS, EXPEDITED_DATA, PRIORITY,
{             PREFERRED_PROTOCOL_CLASS, ALTERNATE_PROTOCOL_CLASS,
{             QUALITY_OF_SERVICE, STATUS)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       connection that is to be associated with the transport access agent
{       connection.
{
{ SAP: (input)  This parameter specifies an open service access point over
{       which the connection is to be opened.
{
{ CHECKSUM: (input)  This parameter specifies that data sent and received by
{       transport in the communication device should be checksummed.
{
{ DATA: (input, output)  This parameter specifies data to be delivered at the
{       destination address as part of the "connect" event.  The meaning of
{       this data must be agreed upon by the communicating users.  The length
{       of this data may not exceed 32 bytes.  The system buffers containing
{       this data will be released as a result of this request.
{
{ DESTINATION_TRANSPORT_SAP: (input)  This parameter specifies the service
{       access point to which the connection is to made.
{
{ DESTINATION_NETWORK_ADDRESS: (input)  This parameter specifies the network
{       address to which the connection is to be made.
{
{ CDNA_DESTINATION_ADDRESS: (input)  This parameter specifies whether the
{       destination network address is CDNA or NONCDNA.
{
{ EXPEDITED_DATA: (input)  This parameter specifies whether the transport
{       service provider should allow expedited data requests and indications.
{
{ PRIORITY: (input)  This parameter specifies the priority of the proposed
{       connection.  Zero is the lowest priority and 14 is the highest
{       priority.  A value outside of the zero to 14 range is interpreted as
{       zero.
{
{ PREFERRED_PROTOCOL_CLASS: (input)  This parameter specifies the preferred type
{       of protocol class that is to be used over a transport connection.
{
{ ALTERNATE_PROTOCOL_CLASS: (input)  This parameter specifies the alternate protocol
{       class to be used over a transport connection when the preferred_protocol_class
{       is not available.
{
{       NOTE:  In version 2 of the Transport Protocol, the alternate_protocol_
{              class will ALWAYS be encoded by the Transport Access Agent to
{              be NONE.
{
{ QUALITY_OF_SERVICE (input) This parameter specifies the transport
{       user's requirements.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$ta_connect_data_len_error
{
*DECK DECK=NLH$TA_SEND_AGGREGATE_MESSAGE EXPAND=TRUE
{
{
{     This request will cause delivery of expedited data and/or normal
{  data events to the peer at the other end of the connection.  Expedited
{  data is not subject to flow control and may be delivered at the other
{  end of the connection ahead of normal data which was sent earlier.
{
{     The purpose of this request is to fulfill two requirements of a
{  non-application layer upper level protocol:
{     1. Send an aggregate of protocol data units as a single message on a
{        connection.  This request permits an upper level protocol to form
{        sequence of Transport Access Agent service or interface data units
{        into a single message to fulfill the upper level's protocol
{        requirements.
{     2. Send upper level protocol service or interface data unit(s)
{        outside the interface flow control imposed at an application
{        layer.
{
{     An aggregate message may be sent outside the interface flow control
{  imposed at an application layer, but is still restrained by total
{  connection capacity (i.e., total connection capacity = normal outbound
{  capacity + aggregate capacity).  A Transport Access data event sent as
{  an aggregate message may consume normal outbound capacity.  The maximum
{  number of unacknowledged expedited data events is constant without
{  regard to whether the expedited event is sent via "send expedited data"
{  or "send aggregate message".
{
{     The following constraints are imposed on the usage of this request:
{       1.  Only "normal data" and "expedited data" protocol data units
{           are supported.
{       2.  The data length of a "normal data" protocol data unit is
{           restricted to the maximum data size allowed by the device
{           by which the data is to be sent.
{       3.  The data length of an "expedited data" protocol data unit is
{           restricted to 16 bytes.
{       4.  The connection's capacity must be sufficient to hold the entire
{           aggregate at instance of request.
{
{       NLP$TA_SEND_AGGREGATE_MESSAGE (CL_CONNECTION, MESSAGE, STATUS)
{
{  CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{        connection associated with the Transport Access Agent connection
{        on which the message data is to be sent.
{
{  MESSAGE: (input, output)  This parameter specifies the data to be
{        included as part of "expedited data" and/or "normal data" events.
{        The system buffers containing the message will be released as a
{        result of this request.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$ta_connection_not_established
{             nae$ta_connection_terminated
{             nae$ta_data_length_error
{             nae$ta_expedited_data_not_supported
{             nae$ta_expedited_length_error
{             nae$ta_expedited_request_limit
{             nae$ta_improper_aggregate_kind
{
{
*DECK DECK=NLH$TA_SEND_DATA EXPAND=FALSE
{
{
{    The purpose of this request is to send data over an open connection.  This
{ request will cause delivery of a "data" event to the user at the other end of
{ the connection.  No attempt is made to "block" outbound data to maximize
{ transmitted packet size.  Each request will (subject to flow control)
{ initiate output on the underlying network.
{
{    ENTRY REQUIREMENTS:  The application layer is responsible for ensuring
{ adequate outbound capacity, interface flow control, exists on the connection
{ to hold all "data" (See:  nlp$get_outbound_capacity).  Otherwise, there is
{ the potential for a catastrophic system error.
{
{       NLP$TA_SEND_DATA (CL_CONNECTION, DATA, END_OF_MESSAGE, STATUS)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       connection that is associated with the transport access agent
{       connection on which data is to be sent.
{
{ DATA: (input, output)  This parameter specifies the data to be included as
{       part of the "data" event.  The length of this data must be at least 1
{       byte.  The system buffers containing this data will be released as a
{       result of this request.
{
{ END_OF_MESSAGE: (input)  This parameter specifies whether the data specified
{       by the DATA parameter is the last data before a message boundary.  The
{       meaning of message boundaries must be agreed upon by the communicating
{       users.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$ta_data_length_error
{
*DECK DECK=NLH$TA_SEND_DATA_FRAGMENTS EXPAND=FALSE
{
{    The purpose of this request is to send data over an open connection.  This
{ request will cause delivery of a "data" event to the user at the other end of
{ the connection.  No attempt is made to "block" outbound data to maximize
{ transmitted packet size.  Each request will (subject to flow control)
{ initiate output on the underlying network.
{
{    ENTRY REQUIREMENTS:  The application layer is responsible for ensuring
{ adequate outbound capacity, interface flow control, exists on the connection
{ to hold all "data" (See:  nlp$get_outbound_capacity).  Otherwise, there is
{ the potential for a catastrophic system error.
{
{       NLP$TA_SEND_DATA_FRAGMENTS (CL_CONNECTION, DATA, END_OF_MESSAGE, STATUS)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       connection that is associated with the transport access agent
{       connection on which data is to be sent.
{
{ DATA: (input, output)  This parameter specifies the data to be included as
{       part of the "data" event.  The length of this data must be at least 1
{       byte.  The data is provided as a list of data fragments.
{
{ END_OF_MESSAGE: (input)  This parameter specifies whether the data specified
{       by the DATA parameter is the last data before a message boundary.  The
{       meaning of message boundaries must be agreed upon by the communicating
{       users.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$ta_data_length_error
{
*DECK DECK=NLH$TA_SEND_EXPEDITED_DATA EXPAND=FALSE
{
{
{    The purpose of this request is to send expedited data over an open
{ connection.  This request will cause delivery of an "expedited data" event to
{ the user at the other end of the connection.  Expedited data is not subject
{ to flow control and may be delivered at the other end of the connection ahead
{ of normal data which was sent earlier.  The expedited data request must be
{ confirmed by the transport service provider in the communication device.  The
{ transport access agent will allow two unconfirmed expedited data requests to
{ be outstanding.  The assumption is that the communication device has
{ confirmed the requests but the actual confirmation pdu has not yet been
{ received.  The fact that a previous request has been confirmed is not
{ conveyed to the user.
{
{       NLP$TA_SEND_EXPEDITED_DATA (CL_CONNECTION, DATA, STATUS)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       connection that is associated with the transport access agent
{       connection on which the expedited data is to be sent.
{
{ DATA: (input, output)  This parameter specifies data to be included as part
{       of the "expedited data" event.  The length of this data may not exceed
{       16 bytes.  The system buffers containing this data will be released as
{       a result of this request.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$ta_connection_not_established
{             nae$ta_connection_terminated
{             nae$ta_expedited_data_not_supported
{             nae$ta_expedited_length_error
{             nae$ta_expedited_request_limit
{
*DECK DECK=NLH$TCPIP_DECREMENT_APPL_ACCESS EXPAND=FALSE
{
{    The purpose of this procedure is to decrement the number of active sockets
{ count for the application.  In addition the global socket identifier or
{ connection identifier is deleted from the applications attribute list entry.
{
{       NLP$TCPIP_DECREMENT_APPL_ACCESS (APPLICATION, GLOBAL_SOCKET_ID,
{             CONNECTION_ID, STATUS)
{
{ APPLICATION: (input)  This parameter specifies the name of the application to
{       which the socket belongs.
{
{ GLOBAL_SOCKET_ID: (input)  This parameter specifies the global socket
{       identifier if the application protocol is datagram socket.
{
{ CONNECTION_ID: (input)  This parameter specifies the connection identifier if
{       the application protocol is stream socket.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$unknown_application
{
*DECK DECK=NLH$TCPIP_INCREMENT_APPL_ACCESS EXPAND=FALSE
{
{    The purpose of this procedure is to increment the number of active sockets
{ count for the application.  In addition a list of global socket identifiers
{ or connection identifiers is maintained for udp or tcp applications
{ respectively.
{
{       NAP$TCPIP_INCREMENT_APPL_ACCESS (APPLICATION, SOCKET_ASSIGNED,
{             GLOBAL_SOCKET_ID, CONNECTION_ID, STATUS)
{
{ APPLICATION: (input)  This parameter specifies the identifier of the
{       application to which the socket belongs.
{
{ SOCKET_ASSIGNED: (input)  This parameter indicates that the socket has been
{       assigned to a job (TRUE) or received on the network and is awaiting
{       acceptance (FALSE).
{
{ GLOBAL_SOCKET_ID: (input)  This parameter specifies the global socket
{       identifier if the application protocol is datagram socket.
{
{ CONNECTION_ID: (input)  This parameter specifies the connection identifier if
{       the application protocol is stream socket.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$application_inactive
{             nae$maximum_sockets_exceeded
{             nae$unknown_application
{
*DECK DECK=NLH$TCPIP_SET_SOCKET_ASSIGNED EXPAND=FALSE
{
{    The purpose of this procedure is to mark a socket as assigned.
{ The caller is expected to inhibit job recovery before calling this routine.
{
{       NLP$TCPIP_SET_SOCKET_ASSIGNED (APPLICATION, CONNECTION_ID, STATUS)
{
{ APPLICATION: (input)  This parameter specifies the name of the application to
{       which the socket belongs.
{
{ CONNECTION_ID: (input)  This parameter specifies the connection identifier of
{       the socket.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$application_inactive
{             nae$unknown_application
{             nae$unknown_socket
{
*DECK DECK=NLH$TCP_ACCEPT_SOCKET EXPAND=FALSE
{
{    The purpose of this request is to accept a proposal to establish a new
{ connection.  This request will cause delivery of an "accept" event to the
{ remote user who proposed the connection.  Upon completion of this request the
{ connection is open and may be used to communicate with the remote user who
{ proposed the connection.
{
{       NLP$TCP_ACCEPT_SOCKET (CL_CONNECTION, GRACEFUL_CLOSE, TRAFFIC_PATTERN,
{             CLASS, STATUS)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       connection that is associated with the TCP Access Agent connection to
{       be accepted.
{
{ GRACEFUL_CLOSE: (input)  This parameter specifies whether the connection will
{       be closed semi-gracefully.  If the connection is to be closed
{       gracefully, all data sent before the connection is closed will be
{       delivered to the communicating peer.
{
{ TRAFFIC_PATTERN: (input)  This parameter specifies the anticipated flow of
{       data over the connection.
{
{ CLASS: (input)  This parameter specifies the proposed connection class for
{       the connection.
{
{ STATUS: (output) This parameter specifies the request status.
{     CONDITION:
{           nae$tcp_socket_already_accepted
{           nae$tcp_socket_terminated
{
*DECK DECK=NLH$TCP_CONNECT_EVENT_PROCESSOR EXPAND=FALSE
{
{    The purpose of this request is to process the connect events generated by
{ the channel connection.
{
{       NLP$TCP_CONNECT_EVENT_PROCESSOR (CL_CONNECTION, EVENT,
{             INVENTORY_REPORT)
{
{  CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{        connection description which was created by the channel connection.
{        The TCP access agent will initialize its portion of the connection.
{
{  EVENT: (input, output)  This parameter specifies the channel connection
{        event.
{
{  INVENTORY_REPORT: (output)  This parameter specifies the number of message
{        buffers being held on the connection at this and higher layers.
{
*DECK DECK=NLH$TCP_CONNECT_SOCKET EXPAND=FALSE
{
{    The purpose of this request is to establish a connection with the peer at
{ the given destination socket.
{
{       NLP$TCP_CONNECT_SOCKET (CL_CONNECTION, SOURCE_SOCKET,
{             DESTINATION_SOCKET, GRACEFUL_CLOSE, TRAFFIC_PATTERN, CLASS,
{             DEVICE_ID, STATUS)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       connection that is to be associated with the TCP Access Agent
{       connection.
{
{ SOURCE_SOCKET: (input)  This parameter specifies the port number and the IP
{       address of the initiator of this request.
{
{ DESTINATION_SOCKET: (input)  This parameter specifies the port number and the
{       IP address of the destination peer.
{
{ GRACEFUL_CLOSE: (input)  This parameter specifies whether the connection will
{       be closed semi-gracefully.  If the connection is to be closed
{       gracefully, all data sent before the connection is closed will be
{       delivered to the communicating peer.
{
{ TRAFFIC_PATTERN: (input)  This parameter specifies the anticipated flow of
{       data over the connection.
{
{ CLASS: (input)  This parameter specifies the proposed connection class for
{       the connection.
{
{ DEVICE_ID: (input)  This parameter specifies the device identifier through
{       which the connection is to be established.
{
{ STATUS: (output) This parameter specifies the request status.
{     CONDITION:
{
*DECK DECK=NLH$TCP_EVENT_PROCESSOR EXPAND=FALSE
{
{    The purpose of this request is to process all events delivered by the
{ channel connection after the TCP access agent connection has been
{ established.
{
{       NLP$TCP_EVENT_PROCESSOR (CL_CONNECTION, EVENT, INVENTORY_REPORT)
{
{  CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{        connection description which contains the TCP access agent connection
{        description.
{
{  EVENT: (input, output)  This parameter specifies the channel connection
{        event.
{
{  INVENTORY_REPORT: (output)  This parameter specifies the number of message
{        buffers being held on the connection at this and higher layers.
{
*DECK DECK=NLH$TCP_FLUSH_RELEASE_SOCKET EXPAND=FALSE
{
{    The purpose of this request is to semi-gracefully close the connection.
{
{       NLP$TCP_FLUSH_RELEASE_SOCKET (CL_CONNECTION, STATUS)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       connection associated with the TCP Access Agent connection which is to
{       be released.
{
{ STATUS: (output) This parameter specifies the request status.
{     CONDITION:
{           nae$tcp_socket_not_open
{           nae$tcp_socket_terminated
{
*DECK DECK=NLH$TCP_INITIALIZE EXPAND=FALSE
{
{    The purpose of this request is to initialize the TCP Access Agent template
{ for the path specified by the application layer.
{
{       NLP$TCP_INITIALIZE (APPLICATION_LAYER, CONNECT_EVENT_PROCESSOR,
{             EVENT_PROCESSOR)
{
{  APPLICATION_LAYER: (input)  This parameter specifies the application layer
{        being utilized by an end user to interface to NAM/VE.
{
{ CONNECT_EVENT_PROCESSOR: (input)  This parameter specifies the event
{       processor to be called by the TCP Access Agent to receive all incomming
{       connect events.
{
{ EVENT_PROCESSOR: (input)  This parameter specifies the event processor to be
{       called by the TCP Access Agent to receive all incomming events other
{       than connect events.
{
*DECK DECK=NLH$TCP_LISTEN_SOCKET EXPAND=FALSE
{    The purpose of this request is to establish a listen connection.
{
{       NLP$TCP_LISTEN_SOCKET (CL_CONNECTION, LOCAL_PORT, QUEUE_LIMIT,
{             SELECTION_CRITERIA, DEVICE_ID, CLASS, STATUS)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       connection that is to be associated with the TCP Access Agent
{       connection.
{
{ LOCAL_PORT: (input)  This parameter specifies the local port.
{
{ QUEUE_LIMIT: (input)  This parameter specifies the limit on the number of
{       pending connect requests which may be waiting to be accepted by the
{       TCP/IP user.
{
{ SELECTION_CRITERIA: (input)  This parameter specifies the port number and/or
{       the IP address from which the user is willing to receive connect
{       requests.  The TCP protocol layer will discard connect requests
{       received from any other source.  A port number of zero and/or a zero IP
{       address implies that data from all ports and/or IP addresses should be
{       received.
{
{ DEVICE_ID: (input)  This parameter specifies the device identifier through
{       which the connection is to be established.
{
{ CLASS: (input)  This parameter specifies the proposed connection class for
{       the connection.
{
{ STATUS: (output) This parameter specifies the request status.
{     CONDITION:
{
*DECK DECK=NLH$TCP_RELEASE_SOCKET EXPAND=FALSE
{
{    The purpose of this request is to release the connection.  The closing of
{ the connection will not be semi-graceful (i.e.  the data sent prior to the
{ request may be lost).
{
{       NLP$TCP_RELEASE_SOCKET (CL_CONNECTION, STATUS)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       connection that is associated with the TCP Access Agent connection
{       which is to be released.
{
{ STATUS: (output) This parameter specifies the request status.
{     CONDITION:
{           nae$tcp_socket_terminated
{
*DECK DECK=NLH$TCP_REPORT_UNDELIVERED_DATA EXPAND=FALSE
{
{    The purpose of this request is to report to the TCP access agent the
{ number of undelivered message buffers accumulated at the application
{ interface on the specified connection.
{
{       NLP$TCP_REPORT_UNDELIVERED_DATA (CL_CONNECTION,
{             ACCUMULATED_MESSAGE_BUFFERS)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       connection description.
{
{ ACCUMULATED_MESSAGE_BUFFERS: (input)  This parameter specifies the number of
{        undelivered message buffers.
{
{
*DECK DECK=NLH$TCP_SEND_DATA EXPAND=FALSE
{
{    The purpose of this request is to send data over an open connection.  This
{ request will cause delivery of a "data" event to the user at the other end of
{ the connection.  No attempt is made to "block" outbound data to maximize
{ transmitted packet size.  Each request will (subject to flow control)
{ initiate output on the underlying network.
{
{    NOTE the application layer is responsible for ensuring adequate outbound
{ capacity exists on the connection before issuing this request.
{
{       NLP$TCP_SEND_DATA (CL_CONNECTION, USER_DATA, PUSH_DATA, URGENT_DATA,
{             STATUS)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       connection that is associated with the TCP Access Agent connection on
{       which the data is to be sent.
{
{ USER_DATA: (input, output)  This parameter specifies the data to be included
{       as part of the "data" event.  The system buffers containing this data
{       will be released as a result of this request.
{
{ PUSH_DATA: (input)  This parameter specifies whether the push bit should be
{       sent when the last byte of the user data has been sent.
{
{ URGENT_DATA: (input)  This parameter specifies whether the user data is
{       urgent.
{
{ STATUS: (output) This parameter specifies the request status.
{     CONDITION:
{           nae$tcp_socket_not_open
{           nae$tcp_socket_terminated
{
*DECK DECK=NLH$TCP_SEND_DATA_FRAGMENTS EXPAND=FALSE
{
{    The purpose of this request is to send data over an open connection.  This
{ request will cause delivery of a "data" event to the user at the other end of
{ the connection.  No attempt is made to "block" outbound data to maximize
{ transmitted packet size.  Each request will (subject to flow control)
{ initiate output on the underlying network.
{
{    This procedure will accept data fragments from the caller.  It passes data
{ fragments down to the lower layer.
{
{    NOTE the application layer is responsible for ensuring adequate outbound
{ capacity exists on the connection before issuing this request.
{
{       NLP$TCP_SEND_DATA_FRAGMENTS (CL_CONNECTION, USER_DATA, PUSH_DATA,
{             URGENT_DATA, STATUS)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       connection that is associated with the TCP Access Agent connection on
{       which the data is to be sent.
{
{ USER_DATA: (input, output)  This parameter specifies the data to be included
{       as part of the "data" event.
{
{ PUSH_DATA: (input)  This parameter specifies whether the push bit should be
{       sent when the last byte of the user data has been sent.
{
{ URGENT_DATA: (input)  This parameter specifies whether the user data is
{       urgent.
{
{ STATUS: (output) This parameter specifies the request status.
{     CONDITION:
{           nae$tcp_socket_not_open
{           nae$tcp_socket_terminated
{
*DECK DECK=NLH$TCP_SET_SOCKET_OPTIONS EXPAND=FALSE
{
{    The purpose of this request is to change the profile of the corresponding
{ TCP socket.
{
{       NLP$TCP_SET_SOCKET_OPTIONS (CL_CONNECTION, GRACEFUL_CLOSE,
{             TRAFFIC_PATTERN, STATUS)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       connection that is associated with the transport access agent
{       connection on which the options are to be sent.
{
{ GRACEFUL_CLOSE: (input)  This parameter specifies whether the connection will
{       be closed semi-gracefully.  If the connection is to be closed
{       gracefully, all data sent before the connection is closed will be
{       delivered to the communicating peer.
{
{ TRAFFIC_PATTERN: (input)  This parameter specifies the anticipated flow of
{       data over the connection.
{
{ STATUS: (output) This parameter specifies the request status.
{     CONDITION:
{           nae$tcp_socket_not_open
{           nae$tcp_socket_terminated
{
*DECK DECK=NLH$TIMER_COUNT EXPAND=FALSE

{
{     The purpose of this function is to obtain a NAM/VE timer count.  A timer
{  count has some meaning to a requestor.
{
{       NLP$TIMER_COUNT (TIMER)
{
{  TIMER: (input) This parameter specifies the timer.
{
*DECK DECK=NLH$TIMER_EXPIRED EXPAND=FALSE

{
{     The purpose of this function is to determine if NAM/VE timer has expired.
{
{       NLP$TIMER_EXPIRED (CURRENT_TIME, TIMER)
{
{  CURRENT_TIME: (input) This parameter specifies the current time.  The
{       requestor is responsible for clock wrap around -- the timer task
{       deals with clock wrap around.
{
{  TIMER: (input) This parameter specifies the timer.
{
*DECK DECK=NLH$TM_CONNECT_EVENT_PROCESSOR EXPAND=FALSE
{
{    The purpose of this procedure is to process the channel connection connect
{ event for the TCP/IP Management Access Agent.
{
{       NLP$TM_CONNECT_EVENT_PROCESSOR (CL_CONNECTION, EVENT, INVENTORY_REPORT)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       structure associated with the channel connection connect event.
{
{ EVENT: (input, output)  This parameter specifies the channel connection
{       connect event.
{
{ INVENTORY_REPORT: (output)  This parameter specifies the number of message
{       buffers held on the connection at this layer.
{
*DECK DECK=NLH$TM_DEFINE_STATIC_ROUTING EXPAND=FALSE
{
{    The purpose of this procedure is build the static routing table.  The only
{ user of this request should be the install static routing utility.
{
{    Note TCP/IP must be initiallized by the procedure call to
{ nlp$tm_tcpip_host before a call to this procedure will be accepted.
{
{       NLP$TM_DEFINE_STATIC_ROUTING (STATIC_ROUTES, STATUS)
{
{ STATIC_ROUTES: (input)  This parameter specifies a linked list of static
{       route definitions to be used to build the static routing table.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$tm_resources_unavailable
{             nae$tm_tcpip_not_defined
{
*DECK DECK=NLH$TM_DEFINE_TCPIP_HOST EXPAND=FALSE
{
{    The purpose of this procedure is to initialize TCP/IP in the host.  This
{ procedure must be called to activate the TCP/IP communications device support
{ software.
{
{       NLP$TM_DEFINE_TCPIP_HOST (HOST_NAME, FORWARD_SEARCH_RANGE)
{
{ HOST_NAME: (input)  This parameter specifies the host's domain name.  The
{       domain name is a string of 255 bytes or less.  The domain name is
{       subdivided into domain labels.  The domain labels are seperated by
{       periods.  Domain labels can be up to 63 bytes in length.  Domain labels
{       must begin with a letter (A..Z or a..z) and may be followed with 0 to
{       62 more letters, digits, hyphens(-), or underscores (_) with the
{       exception of the last character which must be a letter or a digit.  For
{       example, arh.cdc.q---___5 is a valid host name.
{
{ FORWARD_SEARCH_RANGE: (input)  This parameter specifies the number of entries
{       to search beyond the hash point for a routing cache entry match.
{
*DECK DECK=NLH$TM_EVENT_PROCESSOR EXPAND=FALSE
{
{    The purpose of this procedure is to process the events delivered to the
{ TCP/IP Management Access Agent over the specified channel connection.  It can
{ only process the data and the disconnect events.
{
{       NLP$TM_EVENT_PROCESSOR (CL_CONNECTION, EVENT, INVENTORY_REPORT)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       structure associated with the channel connection over which the event
{       is delivered.
{
{ EVENT: (input, output)  This parameter specifies the event to be delivered.
{
{ INVENTORY_REPORT: (output)  This parameter specifies the number of message
{       buffers held on the connection at this layer.
{
*DECK DECK=NLH$TM_GET_DEVICE_BY_NAME EXPAND=FALSE
{
{    The purpose of this procedure is to find the device identifier of a
{ specific local device.
{
{       NLP$TM_GET_DEVICE_BY_NAME (LOCAL_DEVICE, DEVICE_ID, STATUS)
{
{ LOCAL_DEVICE: (input)  This parameter specifies the element name of the local
{       device for which the device list is to be searched.
{
{ DEVICE_ID: (output)  This parameter specifies the identifier of the local
{       device.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$tm_device_name_not_found
{
*DECK DECK=NLH$TM_GET_LOCAL_ADDRESSES EXPAND=FALSE
{
{    The purpose of this procedure is to return a list of all local UDP and/or
{ TCP addresses.
{
{       NLP$TM_GET_LOCAL_ADDRESSES (LOCAL_ADDRESSES, COUNT)
{
{ LOCAL_ADDRESSES: (output)  This parameter specifies the list of local
{       addresses and the supported protocol(s) for the directly connected UDP
{       and/or TCP devices.  The upperbound of this array must be equal to the
{       number of configured network devices.
{
{ COUNT: (output)  This parameter specifies the number of local addresses
{       returned via the LOCAL_ADDRESSES parameter.
{
*DECK DECK=NLH$TM_GET_LOCAL_TCP_DEVICES EXPAND=FALSE
{
{    The purpose of this procedure is to return a list of all local TCP
{ device/address pairs.
{
{       NLP$TM_GET_LOCAL_TCP_DEVICES (DEVICE_LIST, COUNT)
{
{ DEVICE_LIST: (output)  This parameter specifies the list of device/address
{       pairs for the directly connected TCP devices.  The upperbound of this
{       array must be equal to the number of configured network devices.
{
{ COUNT: (output)  This parameter specifies the number of device/address pairs
{       returned via the previous parameter (DEVICE_LIST).
{
{
{
*DECK DECK=NLH$TM_GET_LOCAL_UDP_DEVICES EXPAND=FALSE
{
{    The purpose of this procedure is to return a list of all local UDP
{ device/address pairs.
{
{       NLP$TM_GET_LOCAL_UDP_DEVICES (DEVICE_LIST, COUNT)
{
{ DEVICE_LIST: (output)  This parameter specifies the list of device/address
{       pairs for the directly connected UDP devices.  The upperbound of this
{       array must be equal to the number of configured network devices.
{
{ COUNT: (output)  This parameter specifies the number of device/address pairs
{       returned via the previous parameter (DEVICE_LIST).
{
*DECK DECK=NLH$TM_GET_STATIC_ROUTES EXPAND=FALSE
{
{    The purpose of this procedure is to get the list of the currently
{ installed static routes.
{
{       NLP$TM_GET_STATIC_ROUTES (STATIC_ROUTES, COUNT, STATUS)
{
{ STATIC_ROUTES: (input, output)  This parameter specifies an array of static
{       route definitions.  The size of the array must be equal to or greater
{       than the number of currently installed static route definitions.
{
{ COUNT: (output)  This parameter specifies the number of currently installed
{       static route definitions.  This parameter will be initialized even if
{       the array size of the previous parameter is too small.  The intent of
{       this parameter is to allow a caller to able to capture the installed
{       static routing table which may be dynamically changing.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$tm_route_list_too_small
{             ofe$sou_not_active
{
*DECK DECK=NLH$TM_GET_UDP_DEVICE EXPAND=FALSE
{
{    The purpose of this procedure is to search the TCP/IP configuration list
{ for a local address match.  If a match is found the local device identifier
{ is returned.  If a match is not found the device identifier will be zero.
{
{       NLP$TM_GET_UDP_DEVICE (LOCAL_ADDRESS, DEVICE_ID)
{
{ LOCAL_ADDRESS: (input)  This parameter specifies the local TCP/IP address to
{       be used in the address search to find the local device identifier.
{
{ DEVICE_ID: (input)  This parameter specifies the local device identifier
{       found in the address search.  Zero indicates a match has not been
{       found.
*DECK DECK=NLH$TM_GET_UDP_DEVICE_LIST EXPAND=FALSE
{
{    The purpose of this procedure is to return a list of device id and local
{ address pairs for all locally connected devices configured with the UDP
{ protocol stack.
{
{       NLP$TM_GET_UDP_DEVICE_LIST (DEVICE_LIST, DEVICE_LIST_COUNT)
{
{ DEVICE_LIST: (output)  This parameter specifies the list of device id and
{       local address pairs.  Device_list is only meaningful if the
{       device_list_count is nonzero.  This parameter is initialized internally
{       based on the current number of UDP devices.
{
{ DEVICE_LIST_COUNT: (output)  This parameter specifies the current number of
{       UDP device id and local address pairs contained on the device_list.
{
*DECK DECK=NLH$TM_INITIALIZE EXPAND=FALSE
{
{    The purpose of this procedure is to initialize the template for the TCP/IP
{ Management connection.  This procedure should be called only once during
{ NAM/VE initialization.
{
{    NLP$TM_INITIALIZE
{
*DECK DECK=NLH$TM_INITIALIZE_STATIC_ROUTES EXPAND=TRUE
{
{    The purpose of this procedure is to install a new static routing table.
{ The previous routing table will be released.
{
{       NLP$TM_INSTALL_STATIC_ROUTES (STATIC_ROUTES, STATUS)
{
{ STATIC_ROUTES: (input)  This parameter specifies a linked list of static
{       route definitions.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$tm_host_not_defined
{             nae$tm_resources_unavailable
{             ofe$sou_not_active
{
*DECK DECK=NLH$TM_INSTALL_STATIC_ROUTES EXPAND=FALSE
{
{    The purpose of this procedure is to install a new static routing table.
{ The previous routing table will be released.
{
{       NLP$TM_INSTALL_STATIC_ROUTES (STATIC_ROUTES, STATUS)
{
{ STATIC_ROUTES: (input)  This parameter specifies a linked list of static
{       route definitions.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$tm_host_not_defined
{             nae$tm_resources_unavailable
{             ofe$sou_not_active
{
*DECK DECK=NLH$TM_SELECT_BY_LOCAL_TCP_ADDR EXPAND=FALSE
{
{    The purpose of this procedure is to search for the local device which has
{ the desired local TCP address.
{
{       NLP$TM_SELECT_BY_LOCAL_TCP_ADDR (LOCAL_ADDRESS, DEVICE_ID, STATUS)
{
{ LOCAL_ADDRESS: (input)  This parameter specifies the IP address of the local
{       TCP device.
{
{ DEVICE_ID: (output)  This parameter specifies the identifier of the device
{       which is associated with the local TCP address.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$tm_addr_not_for_tcp_device
{             nae$tm_local_address_not_found
{
{
*DECK DECK=NLH$TM_SELECT_BY_LOCAL_UDP_ADDR EXPAND=FALSE
{
{    The purpose of this procedure is to search for the local device which has
{ the desired local UDP address.
{
{       NLP$TM_SELECT_BY_LOCAL_UDP_ADDR (LOCAL_ADDRESS, DEVICE_ID, STATUS)
{
{ LOCAL_ADDRESS: (input)  This parameter specifies the IP address of the local
{       UDP device.
{
{ DEVICE_ID: (output)  This parameter specifies the identifier of the device
{       which is associated with the local UDP address.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$tm_addr_not_for_udp_device
{             nae$tm_local_address_not_found
{
*DECK DECK=NLH$TM_TCP_SELECT_DEVICE EXPAND=FALSE
{
{    The purpose of this procedure is to return the identifier of the local
{ device most suitable for reaching the given TCP destination address.
{
{    Local routing tables are searched for the destination address.  If a match
{ is not found queries are sent to the locally connected devices.  If a local
{ device cannot match the destination address the lowest cost default route
{ will be used i.e.  if a default route has been configured (NOTE a default
{ route is configured with the "DEFINE_IP_NETWORK" command with the network
{ address parameter equal to zero).
{
{       NLP$TM_TCP_SELECT_DEVICE (DESTINATION_ADDRESS, DEVICE_ID, LOCAL_ADDRESS
{             STATUS)
{
{ DESTINATION_ADDRESS: (input)  This parameter specifies the TCP destination
{       address.
{
{ DEVICE_ID: (output)  This parameter specifies the identifier of the device
{       through which the given destination address is accessible.
{
{ LOCAL_ADDRESS: (output)  This parameter specifies the IP address of the local
{       device through which the given destination address is accessible.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$insufficient_resources
{             nae$tm_devices_inaccessible
{             nae$tm_no_tcp_device_configured
{             nae$tm_route_unknown
{
*DECK DECK=NLH$TM_UDP_SELECT_DEVICE EXPAND=FALSE
{
{    The purpose of this procedure is to return the identifier of the local
{ device most suitable for reaching the given UDP destination address.
{
{    Local routing tables are searched for the destination address if a match
{ is not found queries are sent to the locally connected devices.  If a local
{ device cannot match the destination address the lowest cost default route
{ will be used i.e.  if a default route has been configured (NOTE a default
{ route is configured with the "DEFINE_IP_NETWORK" command with the network
{ address parameter equal to zero).
{
{       NLP$TM_UDP_SELECT_DEVICE (DESTINATION_ADDRESS, DEVICE_ID, STATUS)
{
{ DESTINATION_ADDRESS: (input)  This parameter specifies the UDP destination
{       address.
{
{ DEVICE_ID: (output)  This parameter specifies the identifier of the device
{       through which the given destination address is accessible.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$insufficient_resources
{             nae$tm_devices_inaccessible
{             nae$tm_no_udp_device_configured
{             nae$tm_route_unknown
{
*DECK DECK=NLH$TRANSLATE_TITLE EXPAND=TRUE
{
{   The purpose of this request is to request the translation of a title
{ or title pattern. Translations are received by calling the procedure
{ nlp$get_title_translation. A translation request is terminated by calling
{ the procedure nlp$end_title_translation. A non-recurrent translation request
{ will also be terminated automatically after all translations have been
{ delivered, or a timer has expired indicating that the requestor no longer is
{ processing this request.
{
{
{        NLP$TRANSLATE_TITLE (TITLE, WILD_CARD, PROTOCOL, RECURRENT_SEARCH,
{              SEARCH_DOMAIN, CLASS, REQUEST_ID, STATUS)
{
{ TITLE: (input) This parameter specifies the title or title pattern to be
{        translated. Title patterns are specified as follows:
{
{     [ ... ]  any single character among those in brackets
{
{      a-z     within a bracketed group, a range of characters
{              is represented with a hyphen, i.e.:
{              "a-z", where "a" and "z" are any two characters for
{              which the expression a <= z or a >= z is accepted
{
{      *       any character string including the NULL string
{
{      ?       any single character
{
{      '       If the model contains any special characters,
{              those special characters (*, [, ?) must be surrounded
{              with single quotes.  If the model contains a single
{              quote, 2 single quotes must be in  the name.
{              example: the name string A'*'B  matches  the model
{              string A*B and the name string A''B matches the model
{              string A'B.
{
{         Special characters are not recgonized within a bracketed group.
{
{ WILD_CARD: (input) This parameter specifies whether the title value is a
{        title pattern.
{
{ PROTOCOL: (input) This parameter specifies the directly accessable service
{        (i.e. protocol) used by the client. If a value of nac$unknown_protocol
{        is specified, titles with any service specification will be returned.
{
{ RECURRENT_SEARCH: (input) This parameter specifies whether the search for
{        translations should be a recurrent one. Recurrent and non-recurrent
{        searches will attempt to find translations throughout the search
{        domain. When this search is completed, a non-recurrent search will
{        terminate. A recurrent search will continue to examine distributed
{        translations and will return any that meet the translation criteria.
{
{ SEARCH_DOMAIN: (input) This parameter specifies the portion of the
{        network from which translations will be accepted by this request.
{
{ CLASS: (input) This parameter specifies the class of title being
{        requested. Possible values are CDNA internal and CDNA external.
{        CDNA internal class is intended for use by network management
{        entities.
{
{ REQUEST_ID: (output) This parameter specifies the identifier assigned to
{        uniquely identify this translation request.
{
{ STATUS: (output) This parameter specifies the request status.
{        CONDITIONS: none
{        IDENTIFIER: 'NA'
*DECK DECK=NLH$UDP_ACTIVATE_RECEIVER EXPAND=FALSE
{
{    The purpose of this procedure is to compare swap the current task id in
{ the given active receiver record.
{
{       NLP$UDP_ACTIVATE_RECEIVER (ACTIVE_RECEIVER, ANOTHER_RECEIVER_ACTIVE)
{
{ ACTIVE_RECEIVER: (input)  This parameter contains the pointer to the active
{       receiver record.
{
{ ANOTHER_RECEIVER_ACTIVE: (output)  This parameter is set to TRUE if the
{       initial value of active receiver is non zero.
{
*DECK DECK=NLH$UDP_ALLOCATE_RECEIVER EXPAND=FALSE
{
{    The purpose of this procedure is to allocate and initialize the active
{ receiver record.
{
{       NLP$UDP_ALLOCATE_RECEIVER (ACTIVE_RECEIVER)
{
{ ACTIVE_RECEIVER: (output)  This parameter contains the pointer to the active
{       receiver record.
{
*DECK DECK=NLH$UDP_AWAIT_CLEAR_TO_SEND EXPAND=FALSE
{
{   The purpose of this procedure is to wait for a clear to
{ send condition on the given global socket. However, the
{ clear to send indication cannot be relied upon as the available
{ outbound capacity will be used by the next queued task waiting
{ to send data.
{
{       NLP$UDP_AWAIT_CLEAR_TO_SEND (GLOBAL_SOCKET_ID, ACTIVITY_COMPLETE)
{
{ GLOBAL_SOCKET_ID: (input) This parameter specifies the global
{       socket identifier.
{
{ ACTIVITY_COMPLETE: (output) This parameter is set to TRUE on the
{       arrival of the clear to send indication and when the current
{       task is at the head of the send queue.
{
*DECK DECK=NLH$UDP_AWAIT_DATA_AVAILABLE EXPAND=FALSE
{
{   The purpose of this procedure is to wait for the arrival
{ of data on the given global socket. However, this indication
{ cannot be relied upon as the data may be delivered to the
{ next queued task waiting to receive data.
{
{       NLP$UDP_AWAIT_DATA_AVAILABLE (GLOBAL_SOCKET_ID, WAIT,
{             ACTIVITY_COMPLETE)
{
{ GLOBAL_SOCKET_ID: (input) This parameter specifies the global
{       socket identifier.
{
{ WAIT: (input) This parameter is set to TRUE if the caller is
{       willing to wait for the arrival of data.
{
{ ACTIVITY_COMPLETE: (output) This parameter is set to TRUE on the
{       arrival of data and when the current task is at the head of
{       the receive queue.
{
*DECK DECK=NLH$UDP_BIND_SOCKET EXPAND=FALSE
{
{   The purpose of this procedure is to bind the given
{ global socket to the given port number and IP address.
{ If the IP address is 0, it implies that the socket is to
{ be bound to IP addresses of all known UDP devices. If a
{ non zero IP address is specified, the device supporting
{ the IP address is determined. The open socket requests
{ are sent to the corresponding device(s). This process
{ waits for the responses from the device(s).
{
{       NLP$UDP_BIND_SOCKET (GLOBAL_SOCKET_ID, PORT
{             TRAFFIC_PATTERN, IP_ADDRESS, STATUS)
{
{ GLOBAL_SOCKET_ID: (input) This parameter specifies the
{       global socket identifier.
{
{ PORT: (input) This parameter specifies the port number
{       to which the socket is to be bound.
{
{ TRAFFIC_PATTERN: (input) This parameter specifies the traffic
{       pattern option selected for the given socket.
{
{ IP_ADDRESS: (input) This parameter specifies the IP address
{       to which the socket is to be bound. A 0 value implies
{       that the socket is to be bound to IP addresses of all
{       known UDP devices.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_no_device_configured
{
*DECK DECK=NLH$UDP_CANCEL_SOCKET_OFFER EXPAND=FALSE
{
{   The purpose of this procedure is to restore the status of the
{ global socket. If the global socket has been terminated by application
{ management, appropriate status is returned to the caller.
{
{       NLP$UDP_CANCEL_SOCKET_OFFER (GLOBAL_SOCKET_ID, STATUS)
{
{ GLOBAL_SOCKET_ID: (input) This parameter specifies the global socket
{       identifier.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_socket_terminated
{
*DECK DECK=NLH$UDP_CLEAR_EXCLUSIVE_ACCESS EXPAND=FALSE
{
{    The purpose of this request is to clear a previously acquired exclusive
{ access to the specified global socket.  This request is intended soley for
{ use by condition handlers where it may not be known if a previously acquired
{ exclusive access has been released.
{
{       NLP$UDP_CLEAR_EXCLUSIVE_ACCESS (GLOBAL_SOCKET)
{
{  GLOBAL_SOCKET: (input, output)  This parameter specifies the global socket
{        from which access is to be cleared -- on output the value is NIL.
{
*DECK DECK=NLH$UDP_CLOSE_PORT EXPAND=FALSE
{
{   The purpose of this procedure is to close the specified
{ UDP port.
{
{       NLP$UDP_CLOSE_PORT (PORT)
{
{ PORT: (input) This parameter specifies the port number to
{       be closed.
{
*DECK DECK=NLH$UDP_CLOSE_SOCKET EXPAND=FALSE
{
{   The purpose of this procedure is to close the given
{ global socket. All queued senders and receivers are
{ signalled/readied and release socket request are sent to
{ all UDP devices that support IP address bound to the socket.
{ If there are no active senders and receivers, the global
{ socket is deleted. Otherwise, the last sender or receiver
{ will delete the global socket. This procedure is meant to
{ be called via NAM/VE socket layer and the application
{ management code.
{
{       NLP$UDP_CLOSE_SOCKET (GLOBAL_SOCKET_ID,
{             TERMINATE_VIA_APPLICATION_MGMT)
{
{ GLOBAL_SOCKET_ID: (input) This parameter specifies the
{       global socket identifier.
{
{ TERMINATE_VIA_APPLICATION_MGMT: (input) This parameter is
{       set to TRUE if the procedure is invoked via application
{       management.
{
*DECK DECK=NLH$UDP_CONNECT_EVENT_PROCESSOR EXPAND=FALSE
{
{   The purpose of this procedure is to process the channel
{ connection connect event. This procedure will treat the
{ connect event as a protocol error.
{
{       NLP$UDP_CONNECT_EVENT_PROCESSOR (CL_CONNECTION, EVENT,
{             INVENTORY_REPORT)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       structure associated with the channel connection connect event.
{
{ EVENT: (input)  This parameter specifies the channel connection connect
{       event.
{
{ INVENTORY_REPORT: (output)  This parameter specifies the number of message
{       buffers held on the connection at this layer.
{
*DECK DECK=NLH$UDP_CREATE_GLOBAL_SOCKET EXPAND=FALSE
{
{    The purpose of this request is to create a global socket description.  The
{ requestor has exclusive access to the global socket upon successful
{ completion of the request.
{
{       NLP$UDP_CREATE_GLOBAL_SOCKET (GLOBAL_SOCKET)
{
{  GLOBAL_SOCKET: (output)  This parameter specifies the created global socket.
{        The value is NIL if the request is not successful.
{
*DECK DECK=NLH$UDP_DEACTIVATE_RECEIVER EXPAND=FALSE
{
{    The purpose of this procedure is to compare swap zero for the task id in
{ the active receiver record.
{
{       NLP$UDP_DEACTIVATE_RECEIVER (ACTIVE_RECEIVER)
{
{ ACTIVE_RECEIVER: (input)  This parameter contains a pointer to the active
{       receiver record.
{
*DECK DECK=NLH$UDP_DEALLOCATE_RECEIVER EXPAND=FALSE
{
{    The purpose of this procedure is to deallocate the given active receiver
{ record.  The caller must ensure that there are no channel connections that
{ reference the given active receiver record.
{
{       NLP$UDP_DEALLOCATE_RECEIVER (ACTIVE_RECEIVER)
{
{ ACTIVE_RECEIVER: (input, output)  This parameter contains the pointer to the
{       active receiver record on input.  On output it is set to NIL.
{
*DECK DECK=NLH$UDP_DELETE_GLOBAL_SOCKET EXPAND=FALSE
{
{    The purpose of this request is to delete an existing global socket.
{
{       NLP$UDP_DELETE_GLOBAL_SOCKET (GLOBAL_SOCKET_ID)
{
{  GLOBAL_SOCKET_ID: (input)  This parameter specifies the global socket to be
{        deleted.
{
*DECK DECK=NLH$UDP_DEVICE_AVAILABLE EXPAND=FALSE
{
{   The purpose of this procedure is to scan all the global
{ sockets for the ones that are either bound to all known IP
{ addresses or have selected to bind to the given IP address.
{ Each one of these sockets is bound to the given IP address.
{ This procedure is meant to be called by the TCP/IP Management
{ Entity whenever a UDP devices becomes available.
{
{       NLP$UDP_DEVICE_AVAILABLE (DEVICE_ID, LOCAL_IP_ADDRESS)
{
{ DEVICE_ID: (input) This parameter specifies the identifier of
{       the UDP device that has become available.
{
{ LOCAL_IP_ADDRESS: (input) This parameter specifies the IP address
{       supported by the UDP device.
{
*DECK DECK=NLH$UDP_EVENT_PROCESSOR EXPAND=FALSE
{
{   The purpose of this procedure is to process the events
{ delivered to the UDP access agent over the specified channel
{ connection.
{
{       NLP$UDP_EVENT_PROCESSOR (CL_CONNECTION, EVENT,
{             INVENTORY_REPORT)
{
{ CL_CONNECTION: (input, output)  This parameter specifies the interlayer
{       structure associated with the channel connection.
{
{ EVENT: (input)  This parameter specifies the channel connection event.
{
{ INVENTORY_REPORT: (output)  This parameter specifies the number of message
{       buffers held on the connection at this layer.
{
*DECK DECK=NLH$UDP_FREE_EXCLUSIVE_ACCESS EXPAND=FALSE
{
{    The purpose of this request is to release a previously acquired exclusive
{ access to the specified global socket.
{
{       NLP$UDP_FREE_EXCLUSIVE_ACCESS (GLOBAL_SOCKET)
{
{  GLOBAL_SOCKET: (input, output)  This parameter specifies the global socket
{        from which access is to be released -- on output the value is NIL.
{
*DECK DECK=NLH$UDP_FREE_NONEXCLU_TO_ROOT EXPAND=FALSE
{
{    The purpose of this request is to release a previously acquired
{ nonexclusive access from the specified socket root.
{
{       NLP$UDP_FREE_NONEXCLU_TO_ROOT (ROOT)
{
{  ROOT: (input)  This parameter specified the socket root.
{
{
*DECK DECK=NLH$UDP_GET_BOUND_ADDRESSES EXPAND=FALSE
{
{   The purpose of this procedure is to get the IP addresses
{ to which the given global socket has been bound.
{
{       NLP$UDP_GET_BOUND_ADDRESSES (GLOBAL_SOCKET_ID,
{             LOCAL_ADDRESSES, COUNT, STATUS)
{
{ GLOBAL_SOCKET_ID: (input) This parameter specifies the global
{       socket identifier.
{
{ LOCAL_ADDRESSES: (output) This parameter contains all the IP
{       addresses to which the socket has been bound.
{
{ COUNT: (output) This parameter contains the count of the IP
{       addresses being returned by the previous parameter.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_socket_terminated
{
*DECK DECK=NLH$UDP_GET_EXCLUSIVE_ACCESS EXPAND=FALSE
{
{    The purpose of this request is to gain exclusive access to a global
{ socket.
{
{    This request must be symmeterical with a subsequent free exclusive access
{ request.
{
{       NLP$UDP_GET_EXCLUSIVE_ACCESS (LOCK)
{
{  GLOBAL_SOCKET: (output)  This parameter specifies the lock which is to be
{        locked exclusively.
{
*DECK DECK=NLH$UDP_GET_EXCLUSIVE_VIA_GSID EXPAND=FALSE
{
{    The purpose of this request is to gain exclusive access to a global
{ socket.  Assuming the global socket exists, control is returned when the
{ exclusive access is acquired.
{
{    This request must be symmeterical with a subsequent free exclusive access
{ request if the global socket exists.
{
{       NLP$UDP_GET_EXCLUSIVE_VIA_GSID (GLOBAL_SOCKET_ID, GLOBAL_SOCKET)
{
{  GLOBAL_SOCKET_ID: (input)  This parameter specifies the global socket
{        identifier of the global socket to be accessed.
{
{  GLOBAL_SOCKET: (output)  This parameter specifies the accessed global
{        socket.  The value is NIL if the global socket does not exist.
{
*DECK DECK=NLH$UDP_GET_NONEXCLU_TO_ROOT EXPAND=FALSE
{
{    The purpose of this request is to gain nonexclusive access to the
{ specified socket root.
{
{    This request must be symmeterical with a subsequent free nonexclusive
{ access request.
{
{       NLP$UDP_GET_NONEXCLU_TO_ROOT (ROOT)
{
{  ROOT: (input)  This parameter specifies the socket root to be accessed.
{
{
*DECK DECK=NLH$UDP_GET_SOCKET_STATUS EXPAND=FALSE
{
{   The purpose of this procedure is to get the current
{ status of the socket with respect to the ability to
{ send or receive data on the socket. The number of bytes
{ of data pending receive is returned. However, the caller
{ should not rely on the returned status as the next task
{ doing a send or receive may consume the available resources.
{
{       NLP$UDP_GET_SOCKET_STATUS (GLOBAL_SOCKET_ID,
{             CLEAR_TO_SEND, DATA_PENDING_RECEIVE, STATUS)
{
{ GLOBAL_SOCKET_ID: (input) This parameter specifies the
{       global socket identifier.
{
{ CLEAR_TO_SEND: (output) This parameter is set to TRUE
{       if there is non-zero outbound capacity present on
{       any channel connection associated with the socket.
{
{ DATA_PENDING_RECEIVE: (output) This parameter is set to TRUE
{       if there is a complete message pending receive and the
{       receive queue is empty.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             nae$sk_socket_terminated
{
*DECK DECK=NLH$UDP_INITIALIZE EXPAND=FALSE
{
{   The purpose of this procedure is to initialize the template for
{ the UDP portion of the Socket Layer. This procedure should be called
{ only once during NAM/VE initialization.
{
{       NLP$UDP_INITIALIZE
{
*DECK DECK=NLH$UDP_OFFER_SOCKET EXPAND=FALSE
{
{   The purpose of this procedure is to mark the given global
{ socket as being offered provided ther is no IO active on the
{ socket. However, if there is IO active, an appropriate status
{ is returned to the caller.
{
{       NLP$UDP_OFFER_SOCKET (GLOBAL_SOCKET_ID, STATUS)
{
{ GLOBAL_SOCKET_ID: (input) This parameter specifies the global
{       socket identifier.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             naed$sk_io_pending
{             nae$sk_socket_terminated
{
*DECK DECK=NLH$UDP_RECEIVE_DATA EXPAND=FALSE
{
{   The purpose of this procedure is to receive data on the
{ given global socket. If a non zero selection criteria is
{ specified, only data from the specified source will be received.
{ All other data will be discarded. If the receive queue is empty
{ all active UDP devices are scanned for a complete or partial message.
{ If a partial message is available
{ the current task will be suspended even if non-blocking interface
{ mode has been selected. The assumtion being that remaining data
{ will arrive soon.
{   If no data is available and the blocking interface mode has been
{ selected, the current task will be queued in  the receive queue.
{   If the receive queue is non empty, the current task will be
{ queued at the end of the receive queue only if blocking interface
{ mode has been selected. Otherwise, an appropriate error message will
{ be returned.
{   If the user cache has been enabled, the address of the source from
{ which the data was received and the associated device id is
{ stored in the user cache.
{
{       NLP$UDP_RECEIVE_DATA (GLOBAL_SOCKET_ID, TIME_STAMP, SELECTION_CRITERIA,
{             USER_CACHE_ENABLED, INTERFACE_MODE, INTERFACE_TIMEOUT, DATA,
{             FOREIGN_SOCKET, LOCAL_IP_ADDRESS, DATA_LENGTH, STATUS)
{
{ GLOBAL_SOCKET_ID: (input) This parameter specifies the global socket identifier.
{
{ TIME_STAMP: (input) This parameter specifies the value of the free running clock
{       at the time the job socket was created. This time stamp must match
{       the time stamp stored in the global socket.
{
{ SELECTION_CRITERIA: (input) This parameter specifies the port and IP adddress
{       of the source from which the data is to be received. A 0 port number
{       and/or IP address implies that data from all ports and/or IP addresses
{       should be received.
{
{ USER_CACHE_ENABLED: (input) This parameter specifies the user
{       cache enabled option for the socket.
{
{ INTERFACE_MODE: (input) This parameter specifies the interface
{       mode option for the given socket.
{
{ INTERFACE_TIMEOUT: (input) This parameter specifies the interface timeout option
{       for the given socket.
{
{ DATA: (input) This parameter specifies the user's data fragments to which the data
{       is to be delivered.
{
{ FOREIGN_SOCKET: (output) This parameter specifies the port number and IP address
{       of the source from which the data is received.
{
{ LOCAL_IP_ADDRESS: (output) This parameter specifies the IP address of the device
{       over which the data is received.
{
{ DATA_LENGTH: (output) This parameter specifies the length of the received data.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_data_area_too_small
{             nae$sk_no_data_available
{             nae$sk_receive_in_progress
{             nae$sk_socket_terminated
{             nae$sk_unknown_socket
{
*DECK DECK=NLH$UDP_REMOVE_CLEAR_TO_SEND EXPAND=FALSE
{
{    The purpose of this procedure is to remove the current task from the send
{ queue in each channel connection associated with the given global socket.
{
{       NLP$UDP_REMOVE_CLEAR_TO_SEND (GLOBAL_SOCKET_ID)
{
{ GLOBAL_SOCKET_ID: (input)  This parameter specifies the global socket
{       identifier.
{
*DECK DECK=NLH$UDP_REMOVE_DATA_AVAILABLE EXPAND=FALSE
{
{    The purpose of this procedure is to remove the current task from the
{ receive queue.
{
{       NLP$UDP_REMOVE_DATA_AVAILABLE (GLOBAL_SOCKET_ID)
{
{ GLOBAL_SOCKET_ID: (input)  This parameter specifies the global socket
{       identifier.
{
*DECK DECK=NLH$UDP_SEND_DATA EXPAND=FALSE
{
{   The purpose of this procedure is to send data over the
{ given global socket to the specified destination address.
{ This process first determines the device to use to reach the
{ given destination address. If the send queue on the channel
{ connection to the selected device is empty and there is enough
{ outbound capacity available, the user data is moved to system buffers
{ and sent to the device. If partial data is sent, the task is
{ queued in the send queue. The remaining data is sent as and when
{ outbound capacity becomes available.
{   If the send queue is non empty and the interface mode is blocking,
{ the current task is queued at the end of the send queue. Otherwise,
{ an appropriate status is returned to the user.
{
{       NLP$UDP_SEND_DATA (GLOBAL_SOCKET_ID, TIME_STAMP, LOCAL_IP_ADDRESS,
{             DESTINATION_SOCKET, DATA, DATA_LENGTH, CHECKSUM, INTERFACE_MODE,
{             INTERFACE_TIMEOUT, USER_CACHE_ENABLED, STATUS)
{
{ GLOBAL_SOCKET_ID: (input) This parameter specifies the global socket
{       identifier.
{
{ TIME_STAMP: (input) This parameter specifies the value of the free running
{       clock at the time of socket creation. This time stamp must match the
{       the time stamp in the global socket.
{
{ LOCAL_IP_ADDRESS: (input) This parameter specifies the IP address of the
{       local UDP device. If a non zero value is specified for this parameter,
{       the device supporting this IP address will be used to reach the
{       given destination address. A zero value implies that any device that can
{       reach the destination address can be used.
{
{ DESTINATION_SOCKET: (input) This parameter specifies the port and IP address
{       of the destination socket.
{
{ DATA: (input) This parameter specifies the data fragments.
{
{ DATA_LENGTH: (input) This parameter specifies the length of the data to be
{        sent.
{
{ CHECKSUM: (input) This parameter specifies the checksum option selected for the
{        socket.
{
{ INTERFACE_MODE: (input) This parameter specifies the interface mode option
{        selected for the socket.
{
{ INTERFACE_TIMEOUT: (input) This parameter specifies the interface timeout option
{        selected for the socket.
{
{ USER_CACHE_ENABLED: (input) This parameter specifies the user cache enabled option
{        selected for the socket.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             nae$sk_insufficient_resources
{             nae$sk_send_in_progress
{             nae$sk_send_timeout
{             nae$sk_socket_disconnected
{             nae$sk_socket_terminated
{
*DECK DECK=NLH$UDP_SET_SOCKET_OPTIONS EXPAND=FALSE
{
{   The purpose of this procedure is to store the given socket
{ options in the global socket and to send it to the UDP access
{ provider.
{
{       NLP$UDP_SET_SOCKET_OPTIONS (GLOBAL_SOCKET_ID, TRAFFIC_PATTERN,
{             BROADCAST_ENABLED, STATUS)
{
{ GLOBAL_SOCKET_ID: (input) This parameter specifies the global socket
{       identifier.
{
{ TRAFFIC_PATTERN: (input) This parameter specifies the traffic pattern
{       option selected for the socket.
{
{ BROADCAST_ENABLED: (input) This parameter specifies whether IP
{       broadcast is enabled for the given socket.
{
{ STATUS: (output) This parameter specifies the request status.
{      CONDITION:
{            nae$sk_socket_terminated
{
*DECK DECK=NLH$UDP_STORE_RECEIVER EXPAND=FALSE
{
{    The purpose of this procedure is to store the given pointer to the active
{ receiver in the given channel connection structure.  This request should be
{ made for each channel connection associated with a UDP global socket.
{
{       NLP$UDP_STORE_RECEIVER (ACTIVE_RECEIVER, CL_CONNECTION)
{
{ ACTIVE_RECEIVER: (input)  This parameter contains the pointer to the active
{       receiver record.
{
{ CL_CONNECTION: (input, output)  This parameter contains the pointer to the
{       interlayer structure associated with the channel connection.
{
*DECK DECK=NLH$XE_SEND_ERROR_MESSAGE EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

{
{   The purpose of this request is to send an error message (XNS Error Packet) to a
{ specified address in response to an offending datagram.  The XNS Internet layer will
{ attempt to deliver the message to the destination, but reliable delivery is not
{ guaranteed.  A fabricated  XNS Internet PDU header is prefixed to the specified data
{ to complete the image of an offending datagram.
{
{   This request is provided for direct users of the XNS Internet layer.
{
{       NLP$XE_SEND_ERROR_MESSAGE (SOURCE_SAP, DESTINATION, USER_PROTOCOL,
{         ERROR_NUMBER, ERROR_PARAMETER, OFFENDING_DATA, STATUS)
{
{ SOURCE_SAP: (input) This parameter specifies an open service access point sap
{       which the error message is to be sent.
{
{ DESTINATION: (input) This parameter specifies the XNS Internet address to which
{       the error message is to be sent.
{
{ USER_PROTOCOL: (input) This parameter specifies the user protocol value to be
{       placed in the fabricated XNS Internet header used to complete the XNS Error
{       Packet.  Nominally, this value is the user protocol from the offending
{       datagram which caused the error message to sent.
{
{ ERROR_NUMBER: (input) This parameter specifies the error number to placed in
{       error message.
{
{ ERROR_PARAMETER: (input) This parameter specifies the error parameter to be placed
{       in the error message.
{
{ OFFENDING_DATA: (input) This parameter specifies the offending data.  Upto 1440
{       bytes of data can be sent.  If the data specifed exceeds 1440 bytes, only the
{       first 1440 bytes will be transmitted.  Enough data should provided so that
{       the peer entity can return an appropriate response to its user (e.g., XNS
{       Transport provides 12 bytes -- the sequenced packet header).
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: nae$sap_not_open.
{       IDENTIFIER: 'NA'
{
*DECK DECK=NLI$IVB_DRIVER EXPAND=FALSE
          TITLE  MACRO DEFINITIONS.
*         LIST   -$
*copyc IODMAC1
*copyc IODMAC2
*copyc IODMAC4
*copyc DSI$PP_MACROS
          LIST   B,L,N,R
          TITLE  TABLE DEFINITIONS.
          SPACE  4,10
**        PP INTERFACE TABLE.
 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS (ALWAYS 1)

          ALIGN  0,64
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)

          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH (NOT USED)
 CBUF     RMA                COMMUNICATION BUFFER (RMA)(NOT USED)

 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER

          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)

          ALIGN  32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)

          ALIGN  16,64
 RSPVA    STRUCT 6           RESPONSE BUFFER (PVA)

          ALIGN  48,64
 RSLEN    PPWORD             RESPONSE BUFFER LENGTH

          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)

          ALIGN  48,64
 IN       PPWORD             IN POINTER

          ALIGN  48,64
 OUT      PPWORD             OUT POINTER

          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          SPACE  4,10
**        UNIT DESCRIPTORS.

 UD       RECORD PACKED

 LU       PPWORD             LOGICAL UNIT (ALWAYS SAME AS *PIT.FLU*)
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)

 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 PORT     SUBRANGE 0,3       CHANNEL PORT NUMBER
 CNTRLR   SUBRANGE 0,77B     CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 UD       RECEND
          SPACE  4,10
**        UNIT INTERFACE TABLE.

 UIT      RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 STATUS   BOOLEAN            UNIT STATUS (NOT USED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
 QCNT     PPWORD             QUEUE COUNT (NOT USED)

          ALIGN  16,64
 MBUFL    PPWORD             MASTER CONTROL TABLE LENGTH
 MBUF     RMA                MASTER CONTROL TABLE (RMA)

 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE (NOT USED)
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER (NOT USED)

 QLOCK    BOOLEAN            UNIT QUEUE LOCK (NOT USED)
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER (NOT USED)

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA) (NOT USED)

          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA) (NOT USED)

 UIT      RECEND
          SPACE  4,10
**        PP REQUESTS.

 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)

          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (NOT USED)
 INT      BOOLEAN            INTERRUPT CPU (SHOULD BE SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY (NOT USED)
 ALRT     PPWORD             ALERT MASK (NOT USED)

 SECADR   STRUCT 8           SECONDARY ADDRESS (NOT USED)

 REQCOD   SUBRANGE 0,377B    REQUEST CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 CMDLEN   PPWORD             LENGTH OF LENGTH/ADDRESS WORD PAIR LIST
 CMDRMA   RMA                ADDRESS OF CM AREA

          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$

 RQ       RECEND
          SPACE  4,10
**        UNIT REQUESTS.
*

 URQ      RECORD PACKED

          ALIGN  16,64
 THISPV   STRUCT 6           THIS REQUEST ON UNIT QUEUE (PVA)
          ALIGN  0,64
 NEXTLN   PPWORD             LENGTH OF NEXT UNIT REQUEST
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 URQLEN   PPWORD             UNIT REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
          ALIGN  0,128       SKIP 6 PP WORDS (128=64*2)
 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)

*         THERE CAN BE 0, 1, OR MORE LENGTH/ADDRESS PAIRS.

          ALIGN  0,64
 MBLEN    PPWORD             MESSAGE BUFFER LENGTH (LENGTH/ADDRESS PAIR LIST)
          ALIGN  32,64
 MBRMA    RMA                MESSAGE BUFFER ADDRESS (LENGTH/ADDRESS PAIR LIST)

 URQ      RECEND
          SPACE  4,10
**        TRACE - DEFINE TRACE MACRO.
*
*         TRACE  (LIST OF ADDRESSES OF DATA TO SAVE WITH TRACE DATA)


 TRACE    MACRO  D
          LOCAL  L
*.TR      IFEQ   DEBUG,1
          RJM    STD
 .T       IFC    EQ, D
          CON    0
 .T       ELSE
          CON    L
 TRACE    RMT
 L        BSS    0
          IRP    D
          CON    D
          IRP
          CON    0
          RMT
 .T       ENDIF
*.TR      ENDIF
 TRACE    ENDM
 SREC     SPACE  4,10
** SREC MACRO
** THIS MACRO WILL UPDATE THE RECOVERY AND RETRY FIELDS OF A LOG RESPONSE.
** THE ADDR PARAMETER IS THE ADDRESS OF THE LOG BLOCK.
** THE RTC PARAMETER IS THE ADDRESS OF THE RECOVERY COUNTER WHOSE VALUE
** IS ZERO IF THIS IS AN UNRECOVERED ERROR, 1 OR 2 IF A RECOVERED OR
** INTERMEDIATE ERROR.
** THE REC PARAMETER IS EITHER REC.R OR REC.I.


 SRU      MACRO  ADDR,RTC,REC
          LOCAL  SRU10
 A        IFLE   RTC,77B
          LDDL   RTC
          ELSE
          LDML   RTC
 A        ENDIF
          ZJN    SRU10
          LDN    REC
          STML   ADDR+/ILD/P.ERRK,T0
 SRU10    LDN    RRL
 B        IFLE   RTC,77B
          SBDL   RTC
          ELSE
          SBML   RTC
 B        ENDIF
          STML   ADDR+/ILD/P.RETCNT,T0
 SRU      ENDM
 DPM      SPACE  4,10
** DPM MACRO
** THIS MACRO WILL DECREMENT A PP MEMORY LOCATION BY ONE.
** CARE IN TAKEN TO ASSURE THAT 0 - 1 = 177777(8).
** THE ADDR PARAMETER IS THE ADDRESS OF THE PP LOCATION TO DECREMENT.

 DPM      MACRO  ADDR
          LOCAL  DPM10
          SOML   ADDR
          PJN    DPM10
          AOML   ADDR
 DPM10    BSS    0
 DPM      ENDM
 LOGRES   SPACE  4,10
 LOGRES   MACRO
*         WORD 6 - LOG MESSAGE (RESPONSE CODE 9)
          ALIGN  0,64
 SCODE    PPWORD             SYMPTOM CODE
 OPCD     PPWORD             OPERATION CODE
 MSTAT    PPWORD             MASTER STATUS
 SSTAT    PPWORD             SLAVE STATUS
*         WORD   7
 ERRK     PPWORD             ERROR KIND
*                            0 = RECOVERED ERROR
*                            1 = UNRECOVERED ERROR
*                            2 = INTERMEDIATE ERROR
*                            3 = INFORMATIVE MESSAGE
 RETCNT   PPWORD             RETRY COUNT
 LMS      BOOLEAN            MASTER STATUS INCLUDED
 LSS      BOOLEAN            SLAVE STATUS INCLUDED
 DIVB     BOOLEAN            DOWN IVB
 LREG     BOOLEAN            ADAPTOR REGISTERS INCLUDED
 P.FLAGS  EQU    P.LMS
          ALIGN  48,64
 PID      PPWORD             PARAMETER ID
*         WORDS  8 AND 9
 FHIST    STRUCT 16          FUNCTION HISTORY
*         WORD   10
 CR       PPWORD             CONTROL REGISTER
 OSR      PPWORD             OPERATIONAL STATUS REGISTER
 DMAER    PPWORD             DMA ERROR REGISTER
 STREG    PPWORD             IPI CHIP STATUS REGISTER
*         WORD   11
 ERREG    PPWORD             IPI CHIP ERROR REGISTER
 EDATA    PPWORD             EXPECTED DATA
 ADATA    PPWORD             ACTUAL DATA
 RES0     STRUCT 2           RESERVED FOR PP
*         WORD   12
          STRUCT 8           RESERVED FOR PP



*         OPERATION CODES.
*
*  NOTE:  THESE CODES FOLLOW A CONVENTION WHERE
*         READ OPERATIONS HAVE AN EVEN VALUE WHILE
*         WRITE OPERATIONS HAVE AN ODD VALUE.

 K.WRT    EQU    1           WRITE
 K.READ   EQU    2           READ
 K.WRTC   EQU    3           WRITE COMMAND
 K.RDR    EQU    4           READ RESPONSE
          MASKP  LMS
 K.LMS    EQU    MSK
          MASKP  LSS
 K.LSS    EQU    MSK
          MASKP  DIVB
 K.DIVB   EQU    MSK
          MASKP  LREG
 K.LREG   EQU    MSK
          ENDM


**        PP RESPONSE.
*

 RS       RECORD PACKED

*         WORD 1.
          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST

*         WORD 2.
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST  (NOT USED)

*         WORD 3.
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST) (NOT USED)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)  (NOT USED)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS  (NOT USED)
          ALIGN  40,64
 DEVID    SUBRANGE 0,377B    DEVICE INDENTIFIER
          ALIGN  48,64
 ALERT    PPWORD             ALERT MASK

*         WORD 4.
          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED  (NOT USED)
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (NOT USED)
 FORC     BOOLEAN            FORCED TERMINATION (NOT USED)
 CHERR    BOOLEAN            CHANNEL PARITY ERROR (NOT USED)
 DATOV    BOOLEAN            DATA OVERRUN. (NOT USED)
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR (NOT USED)
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION (NOT USED)
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR (NOT USED)
 FTO      BOOLEAN            FUNCTION TIMEOUT (NOT USED)
 CHERO    BOOLEAN            CHANNEL OUTPUT PARITY ERROR (NOT USED)
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO DETAILED STATUS
                               1 - DETAILED STATUS INCLUDED
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE  (NOT USED)
                               1 - UNIT CHANGED FROM READY TO NOT READY
                               2 - UNIT CHANGED FROM NOT READY TO READY
                               3 - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
                               8 - DEVICE ERROR
                               9 - LOG PP MESSAGE
                               13 - CHANNEL CONNECTION READ
                               14 - DEVICE OPERATIONAL
          ALIGN  49,64       ALERT CONDITIONS
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED (NOT USED)

*         WORD 5.
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)(NOT USED)

*         CONTENTS OF WORD 6 AND BEYOND ARE DEPENDENT ON THE
*         SPECIFIC RESPONSE BEING SENT.

*         WORD 6 - BUFFER RETURN (RESPONSE CODES 8 AND 13)
          ALIGN  0,64
 BP1ST    PPWORD             BUFFER POOL 1 STATUS
 BP2ST    PPWORD             BUFFER POOL 2 STATUS
 PSEND    PPWORD             PRIORITY SEND STATE (GLOBAL FLOW CONTROL)
 NSEND    PPWORD             NORMAL SEND STATE (GLOBAL FLOW CONTROL)

*         THERE CAN BE 0, 1 OR MORE LENGTH/ADDRESS PAIRS

          ALIGN  0,64
 DLEN     PPWORD             LENGTH OF DATA IN BUFFER
 BUFPVA   STRUCT 6           PVA OF DATA BUFFER

*         WORD 6 - DEVICE OPERATIONAL (RESPONSE CODE 14)
 BITC     SET    P.LASTC*16  WORD 6
          ALIGN  0,64
 PROV     PPWORD             CHANNEL PROTOCOL VERSION

          ALIGN  32,64
 MAXRS    STRUCT 4           MAXIMUM RECORD SIZE
 SYSID    STRUCT 6           SYSTEM ID
 BITC     SET    P.LASTC*16  WORD 6

          LOGRES

 RS       RECEND


**        INTERMEDIATE LOGGING DATA
*

 ILD      RECORD PACKED

          LOGRES

 ILD      RECEND
          SPACE  4,10
**        UNIT QUEUE DESCRIPTOR.
*

 UQD      RECORD PACKED

 LEN      PPWORD             LENGTH OF THE HEAD OF THE SEND QUEUE
          ALIGN  32,64
 HEAD     RMA                ADDRESS OF HEAD OF THE SEND QUEUE (RMA)
          ALIGN  32,64
 TAIL     RMA                ADDRESS OF TAIL POINTER OF THE SEND QUEUE (RMA)

 UQD      RECEND
*copyc nai$define_ipi_registers
          SPACE  4,15
**        IPI HEADER.

 IP       RECORD PACKED

 LEN      PPWORD             COMMAND/RESPONSE HEADER LENGTH

 REFNO    PPWORD             COMMAND REFERENCE NUMBER

 OPCODE   PPWORD             OPCODE AND MODIFIER

 ADDR     PPWORD             SLAVE AND FACILITY ADDRESSES

 IP       RECEND
          SPACE  4,10
**        IPI HEADER PARAMETERS
*
*         THE FOLLOWING RECORD DEFINITIONS ARE FOR THE
*         IPI HEADER PARAMETERS DEFINED FOR THE IVB.

*         DIAGNOSTICS PARAMETERS - 52(16)

 DIAGP    RECORD PACKED

 PARML    STRUCT 1           LENGTH OF THE REMAINDER OF THE PARAMETER
 PARMID   STRUCT 1           PARAMETER ID
 RPTCNT   PPWORD             OPERATION REPEAT COUNT
 FECODE   PPWORD             FORCE ERROR CODE
 DATLEN   PPWORD             DATA LENGTH

 DIAGP    RECEND

*         GLOBAL FLOW CONTROL STATUS - 56(16)

 STATP    RECORD PACKED

 PARML    STRUCT 1           LENGTH OF THE REMAINDER OF THE PARAMETER
 PARMID   STRUCT 1           PARAMETER ID
 STATUS   STRUCT 1           STATUS, GLOBAL FLOW CONTROL
 FILL     STRUCT 1           FILL

*         STATUS FIELD BIT DEFINITIONS.

 SUC      EQU    7           SUCCESS
*         BITS 4-6 ARE RESERVED FOR FUTURE USE.
 SNDOK    EQU    3           SEND OK
 INPOK    EQU    2           INPUT OK
*         BITS 0-1 ARE RESERVED FOR FUTURE USE.

          BMGEN  SUC
 K.SUC    EQU    MASK$
          BMGEN  SNDOK
 K.SNDOK  EQU    MASK$
          BMGEN  INPOK
 K.INPOK  EQU    MASK$

 STATP    RECEND

*         MASTER/SLAVE DATA STATUS - 53(16)

 MSDS     RECORD PACKED

 PARML    STRUCT 1           LENGTH OF THE REMAINDER OF THE PARAMETER
 PARMID   STRUCT 1           PARAMETER ID
 REFNO    PPWORD             REFERENCE NUMBER
 STATUS   STRUCT 1           STATUS
 FILL     STRUCT 1           FILL

 MSDS     RECEND

*         IVB VERSION PARAMETER - 55(16)

 VERP     RECORD PACKED

 PARML    STRUCT 1           LENGTH OF THE REMAINDER OF THE PARAMETER
 PARMID   STRUCT 1           PARAMETER ID
 IVBTYP   PPWORD             IVB TYPE
 SNO      BOOLEAN            SEND NOOP BIT
 IPIVER   SUBRANGE 0,77777B  REQUESTED IPI PROTOCOL VERSION
 CCVER    PPWORD             REQUESTED CC PROTOCOL VERSION
 MAXPDU   STRUCT 4           MAXIMUM CCPDU SIZE
 K.SNOB   EQU    15          SEND NOOP BIT
 K.SNOM   EQU    100000B     SEND NOOP MASK
 K.VERM   EQU    77777B      VERSION MASK

 VERP     RECEND

*         CHANNEL CONNECTION (CC) PARAMETER - 51(16)

 CCP      RECORD PACKED

 PARML    STRUCT 1           LENGTH OF THE REMAINDER OF THE PARAMETER
 PARMID   STRUCT 1           PARAMETER ID
 KIND     STRUCT 1           CCPDU KIND
 PAD      STRUCT 3           PAD TO 32 BIT OFFSET
 LEN1     PPWORD             UPPER 16 BITS OF PDU LENGTH
 LEN2     PPWORD             LOWER 16 BITS OF PDU LENGTH
 CCREM    STRUCT 8           REMAINDER OF CCPDU (KIND DEPENDENT)

 CCP      RECEND
          SPACE  4,15
**        MASTER CONTROL TABLE.

 MCT      RECORD PACKED

 FLAGS    PPWORD             FLAGS WORD
          ALIGN  48,64
 DEVID    PPWORD             DEVICE IDENTIFIER

 NOR      STRUCT B.UQD       NORMAL QUEUE
 PRI      STRUCT B.UQD       PRIORITY QUEUE

          ALIGN  32,64
 BPDESC   RMA                BUFFER POOL DESCRIPTOR POINTER (RMA)

 INIT     EQU    15          UNIT INITIALIZED (BIT POSITION IN 'FLAGS' FIELD)

 MCT      RECEND
          SPACE  4,10
**        BUFFER POOL DESCRIPTOR
*
 BPD      RECORD PACKED

          ALIGN  32,64
 BPRMA    RMA                RMA OF BUFFER POOL

          ALIGN  48,64
 IN       PPWORD             IN POINTER

          ALIGN  48,64
 CPUOUT   PPWORD             CPU OUT POINTER

          ALIGN  48,64
 PPOUT    PPWORD             PP OUT POINTER

 LEN      STRUCT 4           LENGTH OF EACH POOL BUFFER (CM BYTES)
 THRESH   PPWORD             BUFFER POOL THRESHOLD, CPU WILL BE NOTIFIED IF
*                            POOL SIZE GOES BELOW THIS VALUE
 LIMIT    PPWORD             LENGTH OF CIRCULAR BUFFER (CM BYTES)

 BPD      RECEND
          SPACE  4,10
**        BUFFER POOL.
*

 BP       RECORD PACKED

          ALIGN  16,64
 PVA      STRUCT 6           PVA OF BUFFER DESCRIPTOR (PVA)
          ALIGN  32,64
 RMA      RMA                RMA OF BUFFER (RMA)

 BP       RECEND
          SPACE  4,10
**        INTERNAL BUFFER CACHE
*
*         THE PP MAINTAINS A BUFFER CACHE INTERNALLY. THE
*         CACHE CONTAINS ENOUGH BUFFERS TO HOLD A MAXIMUM
*         SIZED CCPDU. THE CACHE IS STRUCTURED AS AN ARRAY
*         OF RECORDS OF THE FOLLOWING TYPE. THE RECORD IS
*         DEFINED TO BE EQUIVALENT TO NLT$PP_BUFFER_POOL_ENTRY.


 IBC      RECORD PACKED

          ALIGN  16,64
 PVA      STRUCT 6           BUFFER PVA

          ALIGN  32,64
 RMA      STRUCT 4           BUFFER RMA

 IBC      RECEND

          SPACE  4,10
**        BUFFER POOL RMA ARRAY
*
*         THIS RECORD CONSISTS OF AN ADDRESS/LENGTH PAIR
*         WHICH DESCRIBES THE NUMBER OF BYTES TO READ INTO
*         A BUFFER AT THE SPECIFIED ADDRESS. THE RECORD IS
*         DEFINED FOR EASY USE WHEN PERFORMING DMA'S ON AN I4.
*

 BPR      RECORD PACKED

 FILL     PPWORD
 LENGTH   PPWORD
 RMA      STRUCT 4

 BPR      RECEND
          TITLE  ASSEMBLY CONSTANTS.
          SPACE  4,10
**        INSTRUCTION CODES.


 RJMI     EQU    0200B
 LDCI     EQU    2000B
 ADCI     EQU    2100B
 LPCI     EQU    2200B
 LMCI     EQU    2300B
 IAMI     EQU    7100B
 OAMI     EQU    7300B
 FNCI     EQU    7700B
 LPMLI    EQU    102400B
 CRMLI    EQU    106100B
 CWMLI    EQU    106300B
 CHCMI    EQU    107000B
 CMCHI    EQU    107200B
          SPACE  4,10
**        PP STATES.

 PS.NRM   EQU    0           NORMAL
 PS.IDL   EQU    1           IDLE
 PS.HLT   EQU    2           HALTED
          SPACE  4,10
**        DEVICE STATES.

 DS.IS    EQU    0           IN SERVICE
 DS.NRDY  EQU    1           NOT READY
 DS.CV    EQU    2           CHANNEL VERIFICATION
 DS.WOA   EQU    3           WAITING FOR DEVICE OPERATIONAL ACK
 DS.WNR   EQU    4           WAITING FOR DEVICE NOT READY ACK
 DS.ILR   EQU    5           ISSUE LOGICAL RESET
          SPACE  4,10
**        INTERNAL BUFFER CACHE INDEXES.
*

 SMINDX   EQU    0           SMALL BUFFER CACHE INDEX
 LGINDX   EQU    1           LARGE BUFFER CACHE INDEX
          SPACE  4,10
**        IPI ADAPTER FUNCTIONS.

 H0000    EQU    0#0000      MASTER CLEAR ADAPTER
 H0009    EQU    0#0009      SET SELECT OUT
 H0022    EQU    0#0022      FORCE ERROR IN IPI ADAPTER
 H0029    EQU    0#0029      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H0039    EQU    0#0039      SELECT OUT, FULL WHEN SLAVE IN IS 1
 H005B    EQU    0#005B      SET SYNC OUT
 H0062    EQU    0#0062      PORT A SELECT
 H0069    EQU    0#0069      DROP SYNC OUT
 H0071    EQU    0#0071      FULL WHEN SLAVE IN IS 0
 H00E1    EQU    0#00E1      READ STATUS REGISTER
 H00F1    EQU    0#00F1      READ ERROR REGISTER
 H0100    EQU    0#0100      CLEAR DMA ERRORS
 H0111    EQU    0#0111      DROP MASTER OUT
 H0115    EQU    0#0115      REQUEST CLASS 1 INTERRUPTS
 H0122    EQU    0#0122      IPI BUS A OUTPUT PARITY ERROR
 H0200    EQU    0#0200      READ CONTROL REGISTER
 H0222    EQU    0#0222
 H0281    EQU    0#0281      STREAM, READ
 H0300    EQU    0#0300      WRITE CONTROL REGISTER
 H0322    EQU    0#0322      IPI BUS A INPUT PARITY ERROR
 H0381    EQU    0#0381      STREAM, WRITE
 H0422    EQU    0#0422
 H0600    EQU    0#0600      READ DMA ERROR REGISTER
 H0700    EQU    0#0700      READ OPERATIONAL STATUS
 H0800    EQU    0#0800      DMA TERMINATE
 H0A00    EQU    0#0A00      READ T REGISTER
 H0A81    EQU    0#0281      STREAM, READ
 H0B00    EQU    0#0B00      WRITE T PRIME REGISTER
 H0C00    EQU    0#0C00      DMA READ
 H0C22    EQU    0#0C22      ICI OUTPUT PARITY ERROR
 H0D00    EQU    0#0D00      DMA WRITE
 H7E42    EQU    0#7E42      IPI CHANNEL TRANSFER RATE
 H8025    EQU    0#8025      MASTER OUT, FULL WHEN SLAVE IN IS 1
 H8215    EQU    0#8215      SET MASTER OUT, LOGICAL RESET
 H8415    EQU    0#8415      SET MASTER OUT, PHYSICAL RESET
 H9211    EQU    0#9211      DROP SYNC OUT
 H9213    EQU    0#9213      SET SYNC OUT
          SPACE  4,10
**        MISCELLANEOUS EQUATES.

 CH       EQU    15B         CHANNEL NUMBER
 FHT      EQU    8           FUNTION HISTORY TABLE SIZE
 FTOLEN   EQU    100         FUNCTION TIMEOUT IN MILLSECONDS
 IDLD     EQU    4000        IDLE DELAY TIME
 IVBUT    EQU    519         IVB UNIT TYPE
 MAXBPD   EQU    2           MAXIMUM SUPPORTED BUFFER POOLS
 MAXLBUF  EQU    8           MAXIMUM NUMBER OF LARGE BUFFERS NEEDED

*         ALLOW FOR 9 BUFFERS PER MESSAGE. IF THIS IS CHANGED, A CORRESPONDING
*         CHANGE MUST BE MADE IN NAM$INTRANET_LAYER_MGMT_R3, PROCEDURE
*         PROCESS_UNSOLICITED_RESPONSE.

 MAXBUFS  EQU    MAXLBUF+1   MAXIMUM NUMBER OF BUFFERS USED FOR A SINGLE READ
 MAXPR    EQU    3           MAXIMUM CONSECUTIVE PRIORITY REQUESTS
 MAXURQ   EQU    14          MAXIMUM UNIT REQUEST SIZE
 MS50     EQU    777777B     TIMEOUT FOR CERTAIN LOOPS (WAS 50 MILLISECONDS)
 RRL      EQU    3           REQUEST RETRY LIMIT
 SRT      EQU    300         PHYISCAL RESET TIMEOUT (SECONDS)
 RLIE     EQU    49*8        RESPONSE LENGTH IF ERROR
 RPL      EQU    0#10        READ, WRITE COMMAND PACKET LENGTH
 MAXRS    EQU    5+1+MAXBUFS  MAX SIZE OF STANDARD RESPONSE (CM WORDS)
 .INPN    EQU    102600B     INTERRUPT INSTRUCTION
          SPACE  4,10
**        BUS CONTROL EQUATES.
*

 CMDOUT   EQU    0           COMMAND (OUT)
 RSPIN    EQU    1           RESPONSE (IN)
 DATAOUT  EQU    2           DATA OUT
 DATAIN   EQU    3           DATA IN
          SPACE  4,10
**        MASTER/SLAVE DATA STATUS BIT DEFINITIONS.
*

 S.INBUF  EQU    2           INPUT BUFFER AVAILABLE
 S.OUTBUF EQU    3           DATA READY TO SEND
 S.SUC    EQU    7           SUCCESS
          SPACE  4,10
**        IPI HEADER OPCODES.
*
*         THE FIRST 2 DIGITS ARE THE OPCODE. THE LAST 2 DIGITS ARE THE
*         MODIFIER. THE DEFINITIONS ARE THE VALUES FOR RESPONSES. THE
*         CORRESPONDING COMMAND IS THE RESPONSE VALUE + 80H.

 O.NOOP   EQU    0#0000      (CMD/RSP) NO-OP
 O.RSDS   EQU    0#0300      (CMD/RSP) REQUEST/REPORT SLAVE DATA STATUS
 O.RSTAT  EQU    0#0301      (CMD/RSP) REPORT STATUS
 O.ABRT   EQU    0#0800                ABORT OPERATION:
 O.ALC    EQU    0#0801      (CMD)     ABORT LAST COMMAND
 O.ACR    EQU    0#0802      (CMD)     ABORT CURRENT RESPONSE
 O.DIAG   EQU    0#8000                DIAGNOSTIC MESSAGES:
*         EQU    0#8000      (CMD/RSP) DIAGNOSTIC: ECHO RESPONSE
*         EQU    0#8001      (CMD/RSP) DIAGNOSTIC: READ DATA
*         EQU    0#8002      (CMD/RSP) DIAGNOSTIC: WRITE DATA
*         EQU    0#8003      (CMD/RSP) DIAGNOSTIC: LOOPBACK
 O.SL     EQU    0#A700      (CMD/RSP) SUSPEND LINK
 O.RL     EQU    0#A800      (CMD/RSP) RESUME LINK
 O.READ   EQU    0#B000      (RSP)     PACKET READ
 O.WR     EQU    0#B100      (CMD)     PACK WRITE


**        IPI COMMAND/RESPONSE PARAMETER IDS.
*

 PID.CC   EQU    0#51        CHANNEL CONNECTION
 PID.DIAG EQU    0#52        DIAGNOSTIC
 PID.MSDS EQU    0#53        MASTER/SLAVE DATA STATUS
 PID.VER  EQU    0#55        IVB VERSION
 PID.GFC  EQU    0#56        GLOBAL FLOW CONTROL STATUS


**        DIAGNOSTIC RESPONSES
*

 DR.ECHO  EQU    0           ECHO
 DR.READ  EQU    1           READ DATA
 DR.WRT   EQU    2           WRITE DATA
 DR.LOOP  EQU    3           READ/WRITE LOOPBACK
          SPACE  4,10
**        CPU COMMAND CODES.
*

 C.ACK    EQU    0           ACKNOWLEDGE REQUEST
 C.IDLE   EQU    4           STOP PROCESSING UIT REQUESTS
 C.RESUME EQU    5           START PROCESSING UIT REQUESTS
 C.RPM    EQU    6           READ PP MEMORY
 C.PPAD   EQU    9           SELECT PP ADDRESS
 C.WPM    EQU    10          WRITE PP MEMORY
 C.WRTR   EQU    81          WRITE CHANNEL CONNECTION RECORD
 C.DNRACK EQU    117         ACKNOWLEDGMENT OF DEVICE NOT READY STATUS
 C.GFC    EQU    119         CHANGE GLOBAL FLOW CONTROL STATUS
 C.DBUG   EQU    120         DEBUG MODE
 C.RESET  EQU    121         RESET THE LOGICAL LINK
          SPACE  4,10
**        CPU RESPONSE CODES.
*

 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    1           INTERMEDIATE RESPONSE
 R.NRM    EQU    2           NORMAL REQUEST TERMINATION
 R.ABN    EQU    3           ABNORMAL REQUEST TERMINATION
          SPACE  4,10
**        LOG RESPONSE TYPES
*
 REC.R    EQU    0           RECOVERED ERROR
 REC.U    EQU    1           UNRECOVERED ERROR
 REC.I    EQU    2           INTERMEDIATE ERROR
 REC.IM   EQU    3           INFORMATIVE MESSAGE
          SPACE  4,10
**        CPU RESPONSE CONDITION CODES.
*

 RC.NODS  EQU    0           NO DETAILED STATUS
 RC.DS    EQU    1           DETAILED STATUS INCLUDED
          SPACE  4,10
**        BUFFER POOL STATUS.
*

 BP.EMPTY EQU    0           BUFFER POOL EMPTY
 BP.THRSH EQU    1           BUFFER COUNT HAS FALLEN BELOW THRESHOLD
 BP.GOOD  EQU    2           BUFFER POOL STATUS GOOD
          SPACE  4,10
**        SEND STATUS (GLOBAL FLOW CONTROL).
*

 SS.CLOSE EQU    0           SEND GLOBAL FLOW CONTROL WINDW IS CLOSED (DATA CANNOT BE SENT)
 SS.OPEN  EQU    1           SEND GLOBAL FLOW CONTROL WINDOW IS OPEN  (DATA MAY BE SENT)
          SPACE  4,10
**        UNSOLICITED RESPONSE CODES
*

 URC.NRDY EQU    1           DEVICE HAS BECOME UNAVAILABLE FOR USE
 URC.RDY  EQU    2           DEVICE HAS BECOME AVAILABLE FOR USE
 URC.IE   EQU    3           INTERNAL OR INTERFACE ERROR
 URC.DE   EQU    8           DEVICE ERROR
 URC.LOG  EQU    9           LOG PP MESSAGE
 URC.CC   EQU    13          CHANNEL CONNECTION READ
 URC.OPER EQU    14          DEVICE OPERATIONAL


**        PROTOCOL VERSIONS SUPPORTED
*

 MAXCC    EQU    1           CHANNEL CONNECTION PROTOCOL
 MAXIPI   EQU    1           IPI CHANNEL PROTOCOL VERSION
 MINCC    EQU    1           CHANNEL CONNECTION PROTOCOL
 MINIPI   EQU    1           IPI CHANNEL PROTOCOL VERSION
          SPACE  4,10
**        SYMPTOM CODES.
*

 E00      EQU    0           CP MUST DECODE STATUS IN RESPONSE PACKET
 E01      EQU    1           FUNCTION TIMEOUT
 E02      EQU    2           CHANNEL EMPTY WHEN ACTIVATED
 E03      EQU    3           PERIOD COUNTER PARITY
 E04      EQU    4           UPPER ICI PARITY
 E05      EQU    5           LOWER ICI PARITY
 E06      EQU    6           IOU ERROR
 E07      EQU    7           INCOMPLETE TRANSFER
 E08      EQU    8           CHANNEL NOT EMPTY
 E09      EQU    9           CENTRAL MEMORY ERROR
 E10      EQU    10          INVALID CM RESPONSE CODE
 E11      EQU    11          CM RESPONSE CODE PARITY ERROR
 E12      EQU    12          CMI READ DATA PARITY ERROR
 E13      EQU    13          JY DATA ERROR
 E14      EQU    14          BAS PARITY ERROR
 E15      EQU    15          LZ ERROR
 E16      EQU    16          JY ERROR
 E17      EQU    17          LX ERROR
 E20      EQU    20          CANT SELECT
 E21      EQU    21          BIT SIGNIFICANT RESPONSE ERROR
 E22      EQU    22          NO SYNC IN
 E23      EQU    23          SYNC IN DID NOT DROP
 E24      EQU    24          IPI SEQUENCE ERROR
 E25      EQU    25          UPPER IPI CHANNEL PARITY
 E26      EQU    26          LOWER IPI CHANNEL PARITY
 E27      EQU    27          SLAVE IN NOT SET
 E28      EQU    28          SLAVE IN DID NOT DROP
 E29      EQU    29          CEF READING REGISTERS
 E30      EQU    30          CHANNEL STAYED ACTIVE
 E31      EQU    31          BUFFER COUNTER PARITY
 E32      EQU    32          SYNC COUNTER PARITY
 E33      EQU    33          LOST DATA
 E34      EQU    34          BUS PARITY
 E35      EQU    35          COMMAND REJECT
 E36      EQU    36          SYNC OUT NOT EQUAL SYNC INS
 E37      EQU    37          BUS B ACKNOWLEDGE INCORRECT
 E39      EQU    39          ENDING STATUS WRONG
 E40      EQU    40          DEVICE AVALIABLE
 E41      EQU    41          DEVICE RESET
 E70      EQU    70          INTERNAL ERROR
 E100     EQU    100         FORCED ERROR DID NOT OCCUR
          SPACE  4,20
**        PROTOCOL ERROR CODES.
*
*         THE FOLLOWING ERROR CODES ARE USED WHEN THE IVB DRIVER
*         DETECTS A PROTOCOL ERROR. PROTOCOL ERRORS ARE DETECTED
*         FOR BOTH THE IPI CHANNEL PROTOCOL AS WELL AS THE CPU-PP
*         INTERFACE PROTOCOL. ERROR CODES IN THE RANGE E200 - E299,
*         DENOTE IPI CHANNEL PROTOCOL ERRORS. THESE ERRORS WILL RESULT
*         IN THE IVB BEING RESET. ERROR CODES IN THE RANGE E300 - E399,
*         DENOTE CPU-PP INTERFACE PROTOCOL ERRORS AND WILL RESULT IN THE
*         PP/DEVICE BEING DOWNED. ERROR CODES GREATER THAN E399 DENOTE
*         CPU-PP INTERFACE TABLE ERRORS AND WILL RESULT IN THE PP HANGING.


*         IPI CHANNEL PROTOCOL ERROR CODES (E200 - E299)

 E200     EQU    200         INVALID IPI READ RESPONSE
 E201     EQU    201         INVALID IPI PARAMETER LENGTH
 E202     EQU    202         RESPONSE SEQUENCE NUMBERS OUT OF SYNC
 E203     EQU    203         MASTER/SLAVE STATUS MISMATCH
 E205     EQU    205         ILLEGAL IPI RESPONSE OPCODE
 E206     EQU    206         INVALID IPI RESPONSE LENGTH
 E207     EQU    207         ILLEGAL READ RESPONSE PARAMETER
 E221     EQU    221         INVALID DIAGNOSTIC SUB-RESPONSE
 E229     EQU    229         TRANSFER SIZE EXCEEDS MAX CCPDU SIZE
 E230     EQU    230         BUFFER REQUIREMENTS EXCEED MAXIMUM

*         CPU-PP INTERFACE PROTOCOL ERROR CODES (E300 - E399)

 E300     EQU    300         RMA NOT A WORD BOUNDARY
 E301     EQU    301         CCPDU LENGTH ERROR
 E302     EQU    302         INVALID UNIT REQUEST COMMAND
 E303     EQU    303         MAXIMUM BURST LENGTH EXCEEDED
 E320     EQU    320         IVB PROTOCOL NEGOTATION FAILED
 E321     EQU    321         INVALID PP REQUEST COMMAND CODE
 E322     EQU    322         CPU - PP ACK REQUEST UNEXPECTED
 E323     EQU    323         UNABLE TO CLEAR CHANNEL LOCK
 E324     EQU    324         INVALID BUFFER POOL DESCRIPTOR
 E325     EQU    325         UNSUPPORTED MAXIMUM CCPDU SIZE

*         CPU-PP INTERFACE TABLE ERROR CODES (E400 - E499)

 E400     EQU    400         PP COMMUNICATION BUFFER NOT A WORD BOUNDARY
 E401     EQU    401         PP COMMUNICATION BUFFER RMA ZERO
 E402     EQU    402         RESERVED FIELD OF THE PP REQUEST QUEUE
                              DESCRIPTOR IS NOT ZERO
 E404     EQU    404         LOGICAL UNIT OF UNIT DESCRIPTOR NOT
                              IN SEQUENCE OR NOT IN RANGE
 E405     EQU    405         RMA OF UNIT INTERFACE TABLE INVALID
 E406     EQU    406         INVALID CHANNEL NUMBER SPECIFIED
                              IN UNIT DESCRIPTOR
 E407     EQU    407         COMMUNICATION BUFFER LENGTH NOT A
                              MULTIPLE OF WORDS OR NOT LONG ENOUGH
 E411     EQU    411         RMA OF INTERRUPT WORD NOT A WORD
                              BOUNDARY
 E412     EQU    412         RMA OF CHANNEL TABLE NOT A WORD
                              BOUNDARY
 E413     EQU    413         LOGICAL UNIT NUMBER NOTEQUAL TO LOGICAL
                              UNIT OF UNIT DESCRIPTOR
 E414     EQU    414         RMA OF UNIT COMMUNICATION BUFFER
                              NOT A WORD BOUNDARY
 E417     EQU    417         RESERVED FIELD OF UNIT REQUEST QUEUE
                              DESCRIPTOR IS NOT ZERO
 E418     EQU    418         INVALID UNIT TYPE
 E419     EQU    419         MASTER CONTROL TABLE TOO SMALL
          TITLE  STORAGE LOCATIONS.
**        DIRECT CELLS.

 T0       CON    IPD-1
 T1       BSSZ   1
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1

*         BC AND RMA ARE T REGISTER PARAMETERS USED FOR DMA.

 BC       BSSZ   3           BYTE COUNT TO READ/WRITE
 RMA      EQU    BC+1        RMA FOR DMA TRANSFER

 BCSFC    BSSZ   1           FUNCTION CODE SAVE FOR BUS CONTROL
 BCSRC    BSSZ   1           BUS CONTROL RETRY COUNT
 BPINDX   BSSZ   1           BUFFER POOL INDEX
 BUFLEN   BSSZ   1           CM BUFFER LENGTH IN PP WORDS
 BYTS     BSSZ   1           BYTES TO MOVE
 CLCUR    BSSZ   1           CHANNEL 14 CLOCK CURRENT VALUE
 CLMCS    BSSZ   1           CLOCK, MICROSECOND
 CLMLS    BSSZ   1           CLOCK, MILLISECOND
 CLSEC    BSSZ   1           CLOCK, SECOND
 CMADR    BSSZ   3           CM ADDRESS
 CML      BSSZ   1           ORDINAL OF LENGTH/ADDRESS PAIRS
 CM.BPD   BSSZ   3           CM ADDRESS OF BUFFER POOL DESCRIPTOR (REFORMATTED)
 CM.MCT   BSSZ   1           A REGISTER OF REFORMATTED MASTER CONTROL TABLE ADDRESS
 CM.QT    BSSZ   3           CM ADDRESS OF UNIT QUEUE TAIL POINTER (REFORMATED)
 CM.RS    BSSZ   3           CM ADDRESS OF RESPONSE BUFFER (REFORMATTED)
 CM.URQ   BSSZ   3           CM ADDRESS OF UNIT REQUEST QUEUE (REFORMATTED)
 DSTATE   CON    DS.NRDY     DEVICE STATE
 FI       BSSZ   1           INDEX TO FUNCTION HISTORY BUFFER
 INN      BSSZ   1           RESPONSE BUFFER 'IN' POINTER
 INPNT    BSSZ   1           WORKING PPIT 'IN' POINTER
 INPOK    BSSZ   1           PP ABLE TO ACCEPT INPUT,0=FALSE
 IP       BSSZ   1           INPUT PENDING FLAG
 LF       BSSZ   1           LAST FUNCTION TO IPI ADAPTER
 LIM      BSSZ   1           LIMIT OF RESPONSE BUFFER (IN 8-BIT BYTES)
 PPNO     BSSZ   1           LOGICAL PP NUMBER
 PPSTATE  CON    PS.IDL      PP STATE

*         P1 AND P2 ARE MOVED TO LOCATION 100B AND 101B AT INITIALIZATION.

 P1       DATA   H*IV*
 IVB0     IF     DEF,IVB0
 P2       DATA   H*B0*
          ENDIF
 IVB4     IF     DEF,IVB4
 P2       DATA   H*B4*
          ENDIF
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 P6       BSSZ   1
 SNDOK    BSSZ   1           SEND OK, 0= GLOBAL FLOW CONTROL ON, 1=OFF
 STATUS   BSSZ   1           IPI CHANNEL STATUS
 TBYTS    BSSZ   1           TOTAL BYTES TO TRANSFER
 WC       BSSZ   1           WORD COUNT

          ORG    72B
 CM.PIT   BSSZ   3           ADDRESS OF PP INTERFACE TABLE
                             BEFORE INITIALIZATION, (72 - 73) = PPIT RMA
                             AFTER INITIALIZATION, (72 - 74) =
                                REFORMATTED PPIT ADDRESS
 TWO      CON    2           CONSTANT 2
          ORG    100B
 DRNAME   LJM    IPD         INITIALIZE PP DRIVER


 ADATA    BSSZ   1           ACTUAL DATA ACUMULATOR
 AVAIL    BSSZ   1           =0, IF CPU LAST TOLD DEVICE WAS UNAVAILABLE
 BPCNT    BSSZ   2           NUMBER OF BUFFERS NEEDED FROM EACH POOL (INDEXED VIA *BPINDX*)
 BPSIZE   BSSZ   2           BUFFER POOL LENGTHS (INDEXED VIA *BPINDX*)
 BUFCNT   BSSZ   1           BUFFER COUNT
 BYTCNT   BSSZ   1
 CACHE    BSSZ   1           PP INTERNAL BUFFER CACHE ADDRESS
 CCVER    BSSZ   1           CC PROTOCOL VERSION
 CHAN     BSSZ   1           CHANNEL NUMBER
 CHLOCK   BSSZ   1           <> 0, IF CHANNEL LOCKED
 CLOCK    BSSZ   1           CLOCK
 CMLISTL  BSSZ   1
 CM.INT   BSSZ   3           ADDRESS OF INTERRUPT WORD
 CM.CHAN  BSSZ   3           ADDRESS OF CHANNEL INTERLOCK TABLE
 DBUGM    CON    1           0 IF DEBUG MODE ON
*                            1 IF DEBUG MODE OFF
 DEVID    BSSZ   1           DEVICE IDENTIFIER
 EDATA    BSSZ   1           EXPECTED DATA
 EMPBUF   BSSZ   2           EMPTY BUFFER POOL COUNTER
 INTRRPT  BSSZ   1           CPU INTERRUPT INTERVAL
 IPIVER   BSSZ   1           IPI PROTOCOL VERSION
 MAXLRG   BSSZ   1           MAXIMUM NUMBER OF LARGE BUFFERS NEEDED FOR INPUT
 MAXPDU   BSSZ   1           MAXIMUM CCPDU SIZE (ONLY SUPPORT SIZE < 65K)
 MSTAT    BSSZ   1           MASTER STATUS SENT TO IVB
 NIL      VFD    48/0#FFFF80000000,16/0  CYBIL NIL POINTER
 NUMPRI   BSSZ   1           NUMBER OF CONSECUTIVE PRIORITY REQUESTS
 OPSTAT   BSSZ   1           DMA OPERATIONAL STATUS REGISTER
 RCON     BSSZ   1           RESPONSE CONDIION CODE
 RESPC    BSSZ   1           RESPONSE CODE
 RPSEQ    BSSZ   1           NEXT EXPECTED RESPONSE SEQUENCE NUMBER
 RPTCNT   BSSZ   1           DIAGNOSTIC REPEAT COUNT
 RSEQ     BSSZ   1           RECOVERING SEQUENCE NUMBER
 RSTAT    BSSZ   1           RECOVERY STATUS
 RTCNT    BSSZ   1           RETRY COUNT

*         SBUFC AND LBUFC MUST BE CONTIGUOUS
 SBUFC    BSSZ   P.IBC       SMALL BUFFER CACHE (HOLDS 1 BUFFER)
 LBUFC    BSSZ   P.IBC*8     LARGE BUFFER CACHE (HOLDS 8 BUFFERS - 32K)

 SLREC    BSSZ   1           =1, IF *SUSPEND LINK* RECEIVED
 STBI     BSSZ   1           KEY FOR TABLE SEARCH
 TIMEX    BSSZ   1           MULTIPLIER FOR TIMING LOOPS
 UNSC     BSSZ   1           UNSOLICITED RESPONSE CODE
          TITLE  MAIN ROUTINES.
          LIST   F
**        MCL - MAIN CONTROL LOOP.
*
*         THIS ROUTINE IS THE MAIN CONTROL LOOP FOR
*         THE PP. IT DETERMINES THE CURRENT STATE OF THE
*         PP AND CALLS THE CORRESPONDING PP STATE PROCESSOR.
*         THE PP CAN BE IN EITHER IDLE OR NORMAL STATES.
*         IF THE PP IS IN NORMAL STATE DEVICE PROCESSING
*         WILL BE INITIATED WITH A CALL TO THE APPROPRIATE
*         DEVICE STATE PROCESSOR.
*
*         CALLS  ISP, CPS, CVP, DIS, DNR.
*
*         USES   T1.


 MCL      BSS    0
          RJM    IML         INITIALIZE
          LDDL   PPSTATE     PP STATE
          ERRNZ  PS.NRM      NORMAL STATE NOT ZERO
          ZJN    MCL10       IF NOT IN IDLE STATE OR HALTED
          RJM    ISP         IDLE STATE PROCESSOR

*         PP IS IN NORMAL STATE

 MCL10    LDML   TDSP,DSTATE
          STDL   T1
          RJM    0,T1        CALL DEVICE STATE PROCESSOR
          UJN    MCL         LOOP
 TDSP     SPACE  4,10
**        TDSP - DEVICE STATE PROCESSOR TABLE.
*
*         THIS IS A TABLE OF DEVICE STATE PROCESSOR ADDRESSES,
*         INDEXED VIA DEVICE STATE.

 TDSP     BSS    0
          VFD    16/DIS      DEVICE IN SERVICE PROCESSOR
          VFD    16/DNR      DEVICE NOT READY PROCESSOR
          VFD    16/CVP      CHANNEL VERIFICATION PROCESSOR
          VFD    16/CPS      CPU TO PP SYNC PROCESSOR
          VFD    16/CPS      CPU TO PP SYNC PROCESSOR
          VFD    16/ILR      ISSUE LOGICAL RESET
 CPS      SPACE  4,10
**        CPS - CPU TO PP SYNCHRONIZATION.
*
*         THIS ROUTINE AWAITS A CPU TO PP SYNCHRONIZATION
*         REQUEST FROM THE CPU. THIS ROUTINE IS THE STATE
*         PROCESSOR FOR BOTH THE 'WAITING FOR NOT READY ACK'
*         AND THE 'WAITING FOR OPERATIONAL ACK' STATES.
*
*         ENTRY  (DSTATE) = EITHER DS.WOA OR DS.WNR.
*
*         EXIT   STATE CHANGE HAS OCCURRED.
*
*         CALLS  PPR
*

 CPS      SUBR               ENTRY/EXIT
          LDDL   DSTATE      INITIAL DEVICE STATE
          STML   CPSA
 CPS10    PAUSE  2000        PAUSE 2 MILLISECONDS
          RJM    PPR         PROCESS PP REQUESTS
          LDC    **          INITIAL STATE
 CPSA     EQU    *-1
          LMDL   DSTATE      CURRENT DEVICE STATE
          ZJN    CPS10       IF NO STATE CHANGE
          UJN    CPSX        EXIT
 CVP      SPACE  4,10
**        CVP - CHANNEL VERIFICATION PROCESSOR
*
*         THIS ROUTINE WILL RUN THE CHANNEL VERIFICATION
*         TESTS WITH THE IVB.


 CVP      SUBR               ENTRY/EXIT
 CVP10    RJM    PPR         PROCESS PP REQUESTS
          LDDL   PPSTATE     PP STATE
          LMN    PS.NRM
          NJN    CVPX        IF STATE CHANGE - EXIT
          LDDL   DSTATE      DEVICE STATE
          LMN    DS.CV
          NJN    CVPX        IF STATE CHANGE - EXIT
          LDDL   INPOK
          NJN    CVP30       IF BUFFERS ALREADY OBTAINED
          RJM    GRB         GET BUFFERS
          NJN    CVP30       IF ENOUGH BUFFERS OBTAINED
          RJM    RCB         RETURN BUFFERS
          RJM    SEL         SELECT IVB
          RJM    SNO         SEND *NO-OP* COMMAND
 CVP20    RJM    DCM         DESELECT DEVICE
          UJN    CVP10

 CVP30    RJM    CFI         CHECK FOR MESSAGE
          LDDL   IP
          ZJK    CVP10       IF NO INPUT
          RJM    SEL         SELECT IVB
          RJM    RRP         READ RESPONSE
          NJK    CVP150      IF ERROR OR *SUSPEND LINK* READ
          LDML   RPBF+/IP/P.OPCODE
          LMK    O.NOOP
          ZJN    CVP20       IF *NO-OP* RESPONSE
 CVP40    LMK    O.RL&O.NOOP
          ZJN    CVP60       IF *RESUME LINK* RESPONSE
          LMK    O.DIAG&O.RL
          SHN    -8
          ZJN    CVP80       IF *SLAVE DIAGNOSTIC* RESPONSE
          LDC    E205        ILLEGAL IPI RESPONSE
          STDL   T7
          LDML   RPBF+/IP/P.OPCODE
 CVP50    STML   LRS+/RS/P.OPCD  SAVE ERROR INFO IN LOG MESSAGE
          LDDL   T7          ERROR CODE
          RJM    PPE         PROCESS PROTOCOL ERROR (NO RETURN)

*         *RESUME LINK* RESPONSE RECEIVED

 CVP60    RJM    SRL         SEND *RESUME LINK* COMMAND
          NJK    CVP20       IF UNABLE TO SEND *RESUME LINK* COMMAND
          RJM    SRS         REPORT GLOBAL FLOW CONTROL WINDOW OPEN
          NJN    CVP70       IF ERRORS EXIT
          RJM    DCM         DESELECT IVB
          NJK    CVP10       IF ERRORS
          RJM    SDO         SEND DEVICE OPERATIONAL RESPONSE
 CVP70    RJM    RIC         RESET INTERNAL CACHE BUFFER COUNT
          UJK    CVPX        EXIT

*         PROCESS *SLAVE DIAGNOSTIC* RESPONSE

 CVP80    BSS    0
          LDML   RPBF+/IP/P.OPCODE  DETERMINE DIAGNOSTIC TYPE
          LPC    0#FF
          STDL   T1          DIAGNOSTIC SUB-RESPONSE
          SBN    TDSRL       NUMBER OF VALID DIAGNOSTIC SUB-RESPONSES
          MJN    CVP90       IF VALID DIAGNOSTIC
          LDC    E221        INVALID DIAGNOSTIC SUB-RESPONSE
          STDL   T7          SAVE ERROR CODE
          LDDL   T1          DIAGNOSTIC SUB-RESPONSE
          UJK    CVP50

 CVP90    LDML   RPBF+P.IP+/DIAGP/P.RPTCNT
          STML   RPTCNT      SAVE REPEAT COUNT
          LDML   TDSR,T1
          STDL   T2
          LJM    0,T2        PROCESS DIAGNOSTIC

*         ECHO RESPONSE.

 CVP100   RJM    RRP         READ RESPONSE PACKET
          NJK    CVP150      IF ERROR OR *SUSPEND LINK* RESPONSE
 CVP110   LDC    O.DIAG+DR.ECHO
          RJM    VDR         CHECK RESPONSE
          NJN    CVP130      IF RESPONSE BAD
          RJM    CRC         COPY RESPONSE TO COMMAND
          RJM    SCP         RETURN COMMAND
          NJK    CVP200      IF ERRORS
 CVP120   SOML   RPTCNT
          PJK    CVP100      IF MORE REPETITIONS
 CVP130   RJM    RIC         RESET INTERNAL CACHE BUFFER COUNT
          UJK    CVP20

*         READ DATA.

 CVP140   RJM    RRP
          ZJN    CVP160      IF NO ERRORS
 CVP150   LDDL   DSTATE
          LMN    DS.CV
          NJN    CVP130      IF STATE CHANGE
          LDN    DS.ILR
          STDL   DSTATE
          UJK    CVP70       EXIT

 CVP160   LDC    O.DIAG+DR.READ
          RJM    VDR         CHECK RESPONSE
          NJN    CVP130      IF RESPONSE BAD
          RJM    CDR         READ CHANNEL VERIFICATION DATA
          NJN    CVP170      IF ERROR DURING READ
          SOML   RPTCNT
          PJN    CVP140      IF MORE REPETITIONS
          RJM    CRC         COPY RESPONSE TO COMMAND
          RJM    SCP         RETURN COMMAND
          NJK    CVP200      IF ERRORS
 CVP170   UJK    CVP130

*         WRITE DATA.

 CVP180   LDC    O.DIAG+DR.WRT
          RJM    VDR         CHECK RESPONSE
          NJN    CVP170      IF RESPONSE BAD
          RJM    CRC         COPY RESPONSE TO COMMAND
 CVP190   RJM    SCP         RETURN COMMAND
          ZJN    CVP210      IF NO ERRORS
 CVP200   LDN    DS.ILR      RESET
          STDL   DSTATE
          UJK    CVP70       ERROR EXIT

 CVP210   LDML   RPBF+P.IP+/DIAGP/P.DATLEN  LENGTH OF TRANSFER
          RJM    CDW         WRITE THE DATA FROM CM
          NJN    CVP220      IF ERRORS
          SOML   RPTCNT
          PJN    CVP190      IF MORE REPETITIONS
 CVP220   UJK    CVP170

*         READ/WRITE LOOPBACK.

 CVP230   RJM    RRP         READ RESPONSE PACKET
          NJK    CVP150      IF ERROR OR *SUSPEND LINK* RESPONSE
 CVP240   LDC    O.DIAG+DR.LOOP  CHECK RESPONSE
          RJM    VDR         VALIDATE RESPONSE
          NJN    CVP220      IF RESPONSE BAD
          RJM    CDR         READ THE DATA TO CM
          NJN    CVP220      IF ERROR DURING READ
          RJM    CRC         COPY RESPONSE TO COMMAND
          RJM    SCP         RETURN COMMAND
          NJK    CVP200      IF ERRORS
          LDML   RPBF+P.IP+/DIAGP/P.DATLEN  LENGTH OF TRANSFER
          RJM    CDW         WRITE THE DATA FROM CM
          NJK    CVP220      IF ERRORS
          SOML   RPTCNT
          PJK    CVP230      IF MORE REPETITIONS
          UJK    CVP220

 TDSR     BSS    0           DIAGNOSTIC PROCESSORS
          LOC    0
          CON    CVP110      ECHO RESPONSE
          CON    CVP160      READ DATA
          CON    CVP180      WRITE DATA
          CON    CVP240      LOOPBACK
          LOC    *O
 TDSRL    EQU    *-TDSR      NUMBER OF DIAGNOSTICS
 DIS      SPACE  4,15
**        DIS - DEVICE IN SERVICE.
*
*         THIS ROUTINE IS ENTERED WHEN THE IVB IS
*         IN THE 'IN SERVICE' STATE. THIS ROUTINE
*         INITIATES ALL INPUT/OUTPUT FROM/TO THE IVB.
*         THIS ROUTINE ALSO ISSUES A *NOOP* COMMAND TO
*         THE IVB EVERY FIVE SECONDS IF NO OTHER I/O
*         HAS OCCURRED. UPON ENTRY THE PP INTERNAL BUFFER
*         CACHE IS FULL AND CAPABLE OF SUPPORTING AN
*         INPUT OF MAX CCPDU SIZE.
*
*         ENTRY  (DSTATE) = DS.IS (IN SERVICE),
*
*         EXIT   PP OR DEVICE STATE HAS CHANGED.
*

 DIS      SUBR               ENTRY/EXIT
 DIS10    RJM    PPR         PROCESS PP REQUESTS
          LDDL   PPSTATE
          LMK    PS.NRM
          NJN    DISX        EXIT - PP STATE HAS CHANGED
          LDDL   DSTATE      DEVICE STATE
          LMK    DS.IS
          NJN    DISX        EXIT - DEVICE NO LONGER IN SERVICE
          LDDL   IP
          NJN    DIS20       IF INPUT PENDING
          RJM    CFI         CHECK FOR INPUT
 DIS20    RJM    SEL         SELECT THE IVB
          RJM    URT         UPDATE REAL TIME CLOCK
          LDDL   INPOK
          NJN    DIS30       IF ENOUGH BUFFERS IN CACHE
          RJM    GRB         GET READ BUFFERS
          ZJN    DIS30       IF STILL UNABLE TO GET ENOUGH BUFFERS
          RJM    SRS         SEND REPORT STATUS COMMAND
          NJK    DISX        IF ERRORS
 DIS30    LDDL   IP
          ZJN    DIS40       IF NO INPUT PENDING
          RJM    PIM         PROCESS INPUT
          NJN    DIS70       IF ERROR
 DIS40    RJM    PUR         PROCESS UNIT REQUESTS
          LDD    CLSEC       CHECK TIME SINCE LAST MESSAGE
          SBML   CLOCK
          PJN    DIS50       IF CLOCK HAS NOT WRAPPED
          ADC    10000B
 DIS50    SBN    5           APPROXIMATELY 5 SECOND TIMEOUT
          MJN    DIS70       IF NOT TIME FOR NO-OP COMMAND
          LDC    0
 DISA     EQU    *-1
          NJN    DIS60       IF NOT SENDING NOOPS
          RJM    SNO         ISSUE NO-OP COMMAND
 DIS60    LDD    CLSEC
          STM    CLOCK
 DIS70    RJM    DCM         DESELECT IVB
          UJK    DIS10       LOOP
 DNR      SPACE  4,10
**        DNR - DEVICE NOT READY.
*
*         THIS ROUTINE IS THE 'DEVICE NOT READY' STATE
*         PROCESSOR. THIS ROUTINE IS ENTERED WHEN EITHER:
*         THE DRIVER HAS DETECTED THE IVB NOT RESPONDING,
*         THE DRIVER HAS ISSUED A LOGICAL RESET TO RESET
*         THE IVB, OR A *SUSPEND LINK* RESPONSE HAS BEEN
*         RECEIVED.
*
*         ENTRY  (DSTATE) = DS.NRDY
*                (SLREC) = 0, IF DRIVER NEEDS TO WAIT FOR *SUSPEND LINK*,
*                       <> 0, IF *SUSPEND LINK* HAS ALREADY BEEN
*                             RECEIVED.
*

 DNR      SUBR               ENTRY/EXIT
          LDN    0
          STML   DNRA
          STDL   SNDOK
          STDL   IP
 DNR10    PAUSE  IDLD        DELAY
          RJM    PPR         PROCESS PP REQUESTS
          LDDL   PPSTATE
          LMN    PS.NRM
          NJN    DNRX        EXIT - PP STATE HAS CHANGED
          LDDL   DSTATE
          LMN    DS.NRDY
          NJN    DNRX        EXIT IF DEVICE STATE CHANGED

*         CHECK FOR *SUSPEND LINK* RESPONSE.

          LDML   SLREC       SUSPEND LINK RECEIVED
          NJN    DNR30       IF SUSPEND LINK ALREADY RECEIVED
          RJM    CFI         CHECK FOR INPUT FROM IVB
          LDDL   IP
          ZJN    DNR10       IF NO INPUT READY
          RJM    SEL         SELECT THE IVB
          RJM    RRP         READ RESPONSE PACKET
          ZJN    DNR20       IF NOT SUSPEND LINK
          LDML   SLREC
          NJN    DNR40       IF SUSPEND LINK
          LDN    DS.ILR
          STDL   DSTATE
          UJK    DNRX        EXIT IF CANT READ RESPONSE
 DNR20    LDML   RPBF+/IP/P.OPCODE  IPI HEADER OPCODE/MODIFIER
          STML   LRS+/RS/P.OPCD  PLACE IN LOG MESSAGE
          LDC    E205        ILLEGAL RESPONSE
          RJM    PPE         PROCESS PROTOCOL ERROR

 DNR30    RJM    SEL         SELECT IVB
 DNR40    LDN    0
          STML   SLREC       CLEAR SUSPEND LINK RECEIVED FLAG
          LDML   RPBF+P.IP+/VERP/P.SNO  SEND NOOP FLAG
          SHN    -/VERP/K.SNOB
          STML   DISA        SET SWITCH
          LDML   RPBF+P.IP+/VERP/P.IPIVER  IPI CHANNEL PROTOCOL VERSION
          LPC    /VERP/K.VERM
          STML   IPIVER      SAVE IPI PROTOCOL VERSION
          SHN    8
          ADML   RPBF+P.IP+/VERP/P.CCVER  CC PROTOCOL VERSION
          STML   LRS+/RS/P.ADATA  PROTOCOL VERSIONS PROPOSED BY IVB
          LDML   IPIVER      PROPOSED IPI PROTOCOL
          ADC    -MINIPI
          MJN    DNR43       IF PROPOSED LESS THAN MINIMUM
          SBN    MAXIPI-MINIPI+1
          MJN    DNR47       IF PROPOSED PROTOCOL OK
          ZJN    DNR45       IF PROPOSED + 1 EQUAL MAXIPI
 DNR43    LDC    E320        ERROR CODE
          STM    DNRA
 DNR45    LDML   RPBF+P.IP+/VERP/P.IPIVER  IPI CHANNEL PROTOCOL VERSION
          LPC    /VERP/K.SNOM
          ADN    MAXIPI
          STML   RPBF+P.IP+/VERP/P.IPIVER  IPI CHANNEL PROTOCOL VERSION
          LDN    MAXIPI
          STML   IPIVER
 DNR47    LDML   RPBF+P.IP+/VERP/P.CCVER  CC PROTOCOL VERSION
          STML   CCVER       SAVE CC PROTOCOL VERSION
          ADC    -MINCC
          MJN    DNR50       IF PROPOSED LESS THAN MINIMUM
          SBN    MAXCC-MINCC+1
          MJN    DNR57       IF VERSION OK
          ZJN    DNR54       PROPOSED - 1 EQUALS MAXCC
 DNR50    LDC    E320
          STM    DNRA
 DNR54    LDN    MAXCC
          STML   RPBF+P.IP+/VERP/P.CCVER  CC PROTOCOL VERSION
          STML   CCVER
 DNR57    LDML   RPBF+P.IP+/VERP/P.MAXPDU
          ZJN    DNR60       IF CCPDU SIZE SUPPORTED
          LDC    E325        UNSUPPORTED MAX CCPDU SIZE
          STM    DNRA
          LCN    0
          STML   RPBF+P.IP+/VERP/P.MAXPDU+1
          LDN    0
          STML   RPBF+P.IP+/VERP/P.MAXPDU
          UJN    DNR65       SEND SUSPEND LINK


 DNR60    LDML   RPBF+P.IP+/VERP/P.MAXPDU+1
          STML   MAXPDU      SAVE MAXIMUM CCPDU SIZE (ONLY SUPPORT SIZE < 65K)
          RJM    IBC         INITIALIZE BUFFER CACHE
 DNR65    RJM    SSL         SEND *SUSPEND LINK* COMMAND
          LDML   DNRA
          NJN    DNR80       IF PROTOCOL ERROR
          RJM    DCM         DESELECT DEVICE
          LDML   DSTATE
          LMN    DS.NRDY
          NJN    DNR70       EXIT IF STATE CHANGING
          LDN    DS.CV       SET DEVICE STATE TO CHANNEL VERIFICATION
          STDL   DSTATE
 DNR70    UJK    DNRX        EXIT

 DNR80    LDN    MAXIPI      MAXIMUM SUPPORTED IPI PROTOCOL
          SHN    8
          ADN    MAXCC       MAXIMUM CC SUPPORTED PROTOCOL
          STML   LRS+/RS/P.EDATA  SUPPORTED PROTOCOL VERSIONS
          LDC    0           PROTOCOL NEGOTIATION FAILURE
 DNRA     EQU    *-1         SYMPTOM CODE IF ERROR
          RJM    PPE         PROCESS PROTOCOL ERROR (NO RETURN)
 ISP      SPACE  4,10
**        ISP - IDLE STATE PROCESSOR.
*
*         THIS ROUTINE IS ENTERED WHEN THE PP HAS
*         BEEN IDLED VIA A PP REQUEST.
*
*         ENTRY  (PPSTATE) = PS.IDL.
*
*         EXIT   (PPSTATE) <> PS.IDL.
*
*         CALLS  CCL, PPR, SCL.
*

 ISP      SUBR               ENTRY/EXIT
          LDML   CHLOCK
          ZJN    ISP10       IF CHANNEL NOT LOCKED
          RJM    CCL         CLEAR CHANNEL LOCK
 ISP10    RJM    PPR         PROCESS PP REQUESTS
          LDDL   PPSTATE     PP STATE
          ERRNZ  PS.NRM      NORMAL STATE NOT ZERO
          NJN    ISP10       IF STILL IDLE STATE OR HALTED
 ISP20    RJM    SCL         SET CHANNEL LOCK
          NJN    ISP20       IF NOT LOCKED, RETRY
          LCN    0
          STML   CHLOCK      SET CHANNEL LOCKED FLAG
          UJN    ISPX        EXIT
          TITLE  CHANNEL DIAGNOSTIC ROUTINES.
**        CDR - CHANNEL DIAGNOSTICS READ.
*
*         THIS ROUTINE PERFORMS ALL READ DATA OPERATIONS
*         DURING THE CHANNEL VERIFICATION STATE.
*
*         ENTRY  (RPBF) = DIAGNOSTIC READ OR READ/WRITE RESPONSE.
*
*         EXIT   (A) = 0, IF NO ERRORS,
*                   <> 0, IF ERRORS.
*


 CDR80    LDN    0           READ SUCCESSFUL

 CDR      SUBR               ENTRY/EXIT
          RJM    RIC         RESET INTERNAL CACHE BUFFER COUNT
          LDML   MAXPDU      MAXIMUM CCPDU SIZE
          SBML   RPBF+P.IP+/DIAGP/P.DATLEN  LENGTH OF TRANSFER
          MJK    CDR70       IF TRANSFER TOO LARGE
          LDML   RPBF+P.IP+/DIAGP/P.DATLEN  LENGTH OF TRANSFER
          RJM    SFR         SETUP FOR READ
          LDML   RPBF+P.IP+/DIAGP/P.DATLEN  LENGTH OF TRANSFER
          RJM    RDD         READ DATA DMA
          ZJN    CDR10       IF NO ERRORS DETECTED
          LDN    0           UNSUCCESSFUL STATUS
          UJN    CDR20

 CDR10    LDC    /STATP/K.SUC  SUCCESSFUL STATUS
          ADDL   INPOK       GLOBAL FLOW CONTROL
 CDR20    RJM    ESS         ENDING STATUS SEQUENCE
          NJK    CDR60       IF SLAVE STATUS NOT RECEIVED
          LDDL   STATUS      SLAVE STATUS
          SHN    17-/STATP/SUC
          MJK    CDR80       IF SUCCESSFUL
 CDR30    LDML   IOERR+/ILD/P.SCODE
          NJN    CDR50       IF HOST DETECTED ERROR
          RJM    ASS         ANALYZE SLAVE STATUS
 CDR40    STML   IOERR+/ILD/P.SCODE
 CDR50    LDC    IOERR
          RJM    CEP         LOG ERROR
 CDR60    LDN    DS.ILR
          STDL   DSTATE      RESET DEVICE
          UJK    CDRX        EXIT


 CDR70    LDML   RPBF+P.IP+/DIAGP/P.DATLEN  LENGTH OF TRANSFER
          STML   LRS+/RS/P.ADATA
          LDC    E229        TRANSFER SIZE TOO LARGE
          RJM    PPE         PROCESS PROTOCOL ERROR (NO RETURN)
 CDW      SPACE  4,10
**        CDW - CHANNEL DIAGNOSTICS WRITE.
*
*         THIS ROUTINE PROCESSES ALL WRITE OPERATIONS
*         DURING THE CHANNEL VERIFICATION STATE.
*
*         ENTRY  (A) = NUMBER OF BYTES TO TRANSFER.
*
*         EXIT   (A) = 0, IF NO ERRORS,
*                   <> 0, IF ERRORS.
*
*         USES   T1, T2.
*
*         CALLS  CEP, ESS

 CDW70    LDML   IOERR+/ILD/P.SCODE  NON-ZERO IF ERROR DETECTED
          ZJN    CDW80       IF NO ERRORS DETECTED
          LDN    0
          UJN    CDW90

 CDW80    LDC    /STATP/K.SUC  SUCCESSFUL STATUS
          ADDL   INPOK       GLOBAL FLOW CONTROL STATUS
 CDW90    RJM    ESS         ENDING STATUS SEQUENCE
          NJN    CDW130      IF SLAVE STATUS NOT RECEIVED
          LDDL   STATUS      SLAVE STATUS
          SHN    17-/STATP/SUC
          MJK    CDW140      IF SUCCESSFUL
 CDW100   LDML   IOERR+/ILD/P.SCODE
          NJN    CDW120      IF HOST DETECTED ERROR
          RJM    ASS         ANALYZE SLAVE STATUS
 CDW110   STML   IOERR+/ILD/P.SCODE
 CDW120   LDC    IOERR
          RJM    CEP         LOG ERROR
 CDW130   LDN    DS.ILR
          STDL   DSTATE      RESET DEVICE
          UJN    CDWX        EXIT

 CDW140   LDN    0           WRITE SUCCESSFUL


 CDW      SUBR
          STML   EDATA
          STDL   TBYTS       TOTAL BYTES TO TRANSFER
          LDN    0
          STML   ADATA
          STDL   CML         RESET OFFSET OF LENGTH/ADDRESS PAIRS
          LDN    DATAOUT     DATA, INFORMATION OUT
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0381       STREAM, WRITE
          RJM    ICF         RAISE MASTER OUT
 IVB0     IF     DEF,IVB0
          ACN    CH
 IVB0     ENDIF
 CDW10    LDML   RS+/RS/P.DLEN,CML  LENGTH OF BUFFER
          STDL   BUFLEN
          LDDL   TBYTS       BYTES TO TRANSFER
          SBDL   BUFLEN
          PJN    CDW20       IF ALL DATA IN BUFFER TO BE TRANSFERRED
          LDDL   TBYTS
          STDL   BUFLEN
 CDW20    LDDL   BUFLEN      BYTES TO TRANSFER FROM CURRENT BUFFER
 IVB0     IF     DEF,IVB0
          ADN    1           ROUND UP
          SHN    -1          CONVERT TO PP WORDS
          STDL   WC
          SHN    1           BYTE COUNT
          RAML   ADATA       INCREMENT ACTUAL DATA
          LRML   BPRMA+/BPR/P.RMA,CML
          LDML   BPRMA+/BPR/P.RMA+1,CML  DATA START ADDRESS
          SHN    -3
          CMCH   WC,CH
          LDDL   WC
          NJN    CDW30       IF INCOMPLETE TRANSFER
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          STDL   BC
          RAML   ADATA
          LDML   BPRMA+/BPR/P.RMA,CML
          STDL   RMA
          LDML   BPRMA+/BPR/P.RMA+1,CML
          STDL   RMA+1
          LDC    H0D00       DMA WRITE
          RJM    ICF
          ACN    CH
          LDN    3
          OAM    BC,CH       BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
          RJM    WTE         WAIT UNTIL T' REGISTER EMPTY
          NJK    CDW30
 IVB4     ENDIF
          ERRNZ  P.BPR-4
          LDN    P.BPR
          RADL   CML         INCREMENT LENGTH/ADDRESS PAIR OFFSET
          LDDL   TBYTS
          SBDL   BUFLEN
          STDL   TBYTS       BYTES LEFT TO TRANSFER
          ZJN    CDW40       IF ALL DATA SENT
          UJK    CDW10

 CDW30    LDN    E07         INCOMPLETE TRANSFER
          STML   IOERR+/ILD/P.SCODE  SAVE SYMPTOM CODE
          LDML   EDATA
          STML   IOERR+/ILD/P.EDATA
          LDML   ADATA       BYTES WRITTEN IF THIS OPERATION HAD COMPLETED
          SBDL   WC          WC IS PP WORDS NOT WRITTEN
          SBDL   WC
          STML   IOERR+/ILD/P.ADATA  ACTUAL BYTES WRITTEN
          UJN    CDW60       CONTINUE

 CDW40    BSS    0
 IVB0     IF     DEF,IVB0
          LDC    64          MULTIPLY LOOP TO 15 SECONDS
          STML   TIMEX
 CDW45    BSS    0
          LCN    0
 CDW50    IJM    CDW60,CH    IF SLAVE IN DROPPED
          SBN    1
          NJN    CDW50       IF NOT TIMED OUT
          SOML   TIMEX
          NJN    CDW45       IF NOT COMPLETE
          DCN    CH+40B
          LDN    E28         SLAVE IN DID NOT DROP
          STML   IOERR+/ILD/P.SCODE  SAVE SYMPTOM CODE
          UJK    CDW120      LOG ERROR
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          RJM    WTC         WAIT TRANSFER COMPLETE
          NJK    CDW30
 IVB4     ENDIF
 CDW60    CFM    CDW70,CH    IF CHANNEL ERROR FLAG CLEAR
          LDC    IOERR       ERROR INFO BUFFER
          RJM    EFP         ERROR FLAG PROCESSING
          UJK    CDW70
 CER      SPACE 4,10
**        CER - CLEAR ERROR REGISTERS
*         THIS ROUTINE WILL CLEAR THE IPI AND DMA
*         ERROR REGISTERS.
*
*         CALLS  SAF.


 CER      SUBR               ENTRY/EXIT
          LDC    H0022
          RJM    SAF         CLEAR IPI ERRORS
 IVB4     IF     DEF,IVB4
          LDC    H0100
          RJM    SAF         CLEAR DMA ERRORS
 IVB4     ENDIF
          UJK    CERX        EXIT
 CRC      SPACE  4,10
**        CRC - COPY RESPONSE TO COMMAND BUFFER.
*
*         THIS ROUTINE COPIES A RECEIVED RESPONSE TO THE COMMAND
*         BUFFER FOR SUBSEQUENT OUTPUT TO THE IVB.
*
*         ENTRY  (RPBF) = RESPONSE TO COPY.
*
*         EXIT   (CPBF) = COPIED RESPONSE.
*
*         USES   T1.


 CRC      SUBR
          LDML   RPBF+/IP/P.LEN  MOVE FIRST WORD (LENGTH)
          STML   CPBF+/IP/P.LEN
          SHN    -1          CONVERT BYTES TO PP WORDS
          SBN    /IP/B.REFNO  SKIP REFERENCE NUMBER
          STDL   T1
 CRC10    LDML   RPBF+/IP/P.OPCODE,T1  COPY FROM OPCODE ON
          STML   CPBF+/IP/P.OPCODE,T1
          SODL   T1
          PJN    CRC10       IF MORE TO COPY
          LDK    0#80        CONVERT THE RESPONSE INTO A COMMAND
          RAML   CPBF+/IP/P.OPCODE
          UJK    CRCX        EXIT
 RIC      SPACE  4,10
**        RIC - RESET INTERNAL CACHE.
*
*         THIS ROUTINE WILL RESET THE INTERNAL CACHE
*         BUFFER NEEDED COUNTS (*BPCNT*) TO INDICATE
*         THAT THE INTERNAL CACHE IS FULL. THIS IS DONE
*         ONLY DURING CHANNEL DIAGNOSTICS WHERE THE SAME
*         BUFFERS ARE USED FOR MULTIPLE READS.
*
*         EXIT   (BPCNT,SMINDX) = 0,
*                (BPCNT,LGINDX) = 0.
*
*

 RIC      SUBR               ENTRY/EXIT
          LDN    0
          STML   BPCNT+SMINDX
          STML   BPCNT+LGINDX
          UJN    RICX        EXIT

 VDR      SPACE  4,10
**        VDR - VALIDATE DIAGNOSTIC RESPONSE.
*
*         THIS ROUTINE VALIDATES THE RECEIVED DIAGNOSTIC
*         RESPONSE.
*
*         ENTRY  (A)= EXPECTED OPCODE AND MODIFIER.
*
*         EXIT   (A) = 0 IF RESPONSE VALID,
*
*         CALLS  PPE.


 VDR      SUBR
          LMML   RPBF+/IP/P.OPCODE
          NJN    VDR10       IF INCORRECT OPCODE/MODIFER
          LDML   RPBF+/IP/P.LEN  CHECK LENGTH
          SBN    B.IP+B.DIAGP-/IP/B.LEN
          NJN    VDR30       IF INCORRECT LENGTH
          LDML   RPBF+P.IP+/DIAGP/P.PARML  CHECK PARAMETER AND LENGTH
          LMK    0#0752
          ZJN    VDRX        IF CORRECT PARAMETER AND LENGTH
 VDR10    BSS    0
          LDC    E205        ILLEGAL DIAGNOSTIC RESPONSE
 VDR20    STDL   T6          SAVE ERROR CODE
          LDML   RPBF+/IP/P.OPCODE  RESPONSE OPCODE
          STML   LRS+/RS/P.OPCD  PLACE IN LOG MESSAGE
          LDDL   T6          ERROR CODE
          RJM    PPE         PROCESS PROTOCOL ERROR

 VDR30    LDML   RPBF+/IP/P.LEN  RESPONSE LENGTH
          STML   LRS+/RS/P.ADATA  PLACE IN LOG MESSAGE
          LDC    E206        INVALID DIAGNOSTIC RESPONSE LENGTH
          UJN    VDR20
          TITLE  PP REQUEST PROCESSING ROUTINES
 PPR      SPACE  4,10
**        PPR - PROCESS PP REQUESTS.
*
*         THIS ROUTINE WILL PROCESS ALL REQUESTS IN THE PP REQUEST
*         QUEUE ASSUMING THE QUEUE LOCK CAN BE OBTAINED.
*
*         NOTE: IT IS ASSUMED THAT THERE WILL BE ONLY ONE COMMAND
*               PER REQUEST.
*
*         ENTRY  (CM.PIT) = REFORMATED ADDRESS OF PP INTERFACE TABLE.
*
*         USES   P1 - P4, WC.
*
*         CALLS  SPL, SPR, STB.



 PPR      SUBR               ENTRY/EXIT
 PPR10    BSS    0
          LCN    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDC    0#7FFF
          STDL   P4
          LDN    1
          STDL   WC
 IVB0     IF     DEF,IVB0
          LRDL   CM.PIT
          LDDL   CM.PIT+1    CM ADDRESS OF PP INTERFACE TABLE
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
 IVB4     ENDIF
          RDCL   P1          CLEAR ACTIVE CHECK BIT
          ADN    /PIT/C.PPQ  CM ADDRESS OF PP REQUEST QUEUE POINTER
          CRML   P1,WC       READ PP QUEUE POINTER
          LDDL   P3          RMA OF NEXT QUEUED PP REQUEST
          ADDL   P4
          ZJN    PPRX        IF NO PP REQUESTS
          RJM    SPL         SET PP QUEUE LOCKWORD
          NJN    PPRX        IF LOCK WAS NOT SET
          STML   RS+/RS/P.XFER
          STML   RS+/RS/P.XFER+1  CLEAR TRANSFER COUNT
 IVB0     IF     DEF,IVB0
          LRDL   CM.PIT
          LDDL   CM.PIT+1    CM ADDRESS OF PP INTERFACE TABLE
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
 IVB4     ENDIF
          ADN    /PIT/C.PPQPVA
          CRML   RS,TWO      READ PVA AND RMA OF FIRST REQUEST IN CHAIN
          LDN    C.RQ
          STDL   WC
          LOADF  RS+/RS/P.REQ
          CRML   RQ,WC       READ PP REQUEST
 IVB0     IF     DEF,IVB0
          LRDL   CM.PIT
          LDDL   CM.PIT+1    CM ADDRESS OF PP INTERFACE TABLE
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
 IVB4     ENDIF
          ADN    /PIT/C.PPQPVA  CM ADDRESS OF PP QUEUE POINTER
          CWML   RQ,TWO      WRITE PVA AND RMA POINTERS OF NEXT REQUEST
          RJM    CPL         CLEAR PP QUEUE LOCKWORD
          LDML   RQ+/RQ/P.REQCOD  REQUEST CODE
          SHN    -16+/RQ/N.REQCOD+/RQ/L.REQCOD
          STML   STBI        SAVE SEARCH KEY
          LDC    TPPC-2      ADDRESS-2 OF PP COMMAND TABLE
          RJM    STB         SEARCH TABLE
          NJN    PPR20       IF MATCH FOUND

*         PROCESS INVALID COMMAND

          LDML   STBI        INVALID COMMAND CODE
          STML   LRS+/RS/P.OPCD  PLACE IN LOG MESSAGE
          LDC    E321        INVALID PP REQUEST COMMAND CODE
          RJM    PPE         PROCESS PROTOCOL ERROR (NO RETURN)

*         PROCESS VALID COMMAND.

 PPR20    STDL   P2
          RJM    0,P2        CALL COMMAND PROCESSOR
          LDN    R.NRM       NORMAL RESPONSE
          STML   RESPC
          LDN    /RS/C.XFER*8+8
          STML   RS+/RS/P.RESPL   BYTE LENGTH OF RESPONSE
          LDML   RQ+/RQ/P.RECOV   REQUEST R/I FIELD
          LPC    177400B
          LMML   DEVID
          STML   RS+/RS/P.RECOV   SETUP RESPONSE R/I FIELD
          LDML   RQ+/RQ/P.ALRT
          STML   RS+/RS/P.ALERT    SET UP ALERT MASK FIELD
          LDML   RS+/RS/P.REQ+1
          ADN    /RQ/C.CMDLEN*8
          STML   RS+/RS/P.LASTC+1  SET UP LAST COMMAND RMA
          SHN    -16
          ADML   RS+/RS/P.REQ
          STML   RS+/RS/P.LASTC
          RJM    PRB         PREPARE RESPONSE BUFFER
          LDC    RS          STANDARD RESPONSE BUFFER
          RJM    SPR         SEND PP RESPONSE
          UJK    PPR10       CHECK FOR ANOTHER REQUEST

**        TPPC - TABLE OF PP COMMANDS.
*
*         THE COMMAND TABLE CONTAINS TWO WORD ENTRIES OF THE FOLLOWING FORMAT:
*         BITS 32 - 47, PP COMMAND CODE
*         BITS 48 - 63, COMMAND PROCESSOR ADDRESS.

 TPPC     BSS    0
          VFD    16/C.IDLE,16/IDL     IDLE
          VFD    16/C.RESUME,16/RES   RESUME
          VFD    16/C.DNRACK,16/CPA   DEVICE NOT READY ACK
          VFD    16/C.DBUG,16/SDM     DEBUG MODE
          VFD    16/C.RESET,16/RST    RESET LINK
          VFD    16/C.PPAD,16/SPA     SELECT PP ADDRESS
          VFD    16/C.RPM,16/RPM      READ PP MEMORY
          VFD    16/C.WPM,16/WPM      WRITE PP MEMORY
          CON    0
 CPA      SPACE  4,10
**        CPA - CPU TO PP ACK.
*
*         THIS ROUTINE PROCESSES THE CPU TO PP SYNCHRONIZATION
*         PP COMMAND RECEIVED IN A PP REQUEST.
*
*         ENTRY  (RQ) = PP REQUEST.
*
*         EXIT   (DSTATE) = NEW DEVICE STATE.
*                           IF INITIAL STATE = DS.WNR, THEN NEW STATE = DS.NRDY
*                           IF INITIAL STATE = DS.WOA, THEN NEW STATE = DS.IS
*
*         CALLS  PPE


 CPA      SUBR               ENTRY/EXIT
          LDDL   DSTATE      CURRENT DEVICE STATE
          LMN    DS.WNR
          ZJN    CPA10       IF CURRENT DEVICE STATE = WAITING FOR NOT READY ACK
          LMN    DS.WOA&DS.WNR
          NJN    CPA30       IF INTERFACE PROTOCOL ERROR
          LDN    DS.IS       DEVICE IN SERVICE
          UJN    CPA20

 CPA10    LDN    DS.NRDY     DEVICE NOT READY
 CPA20    STDL   DSTATE      CHANGE DEVICE STATE
          UJN    CPAX        EXIT

 CPA30    LDC    E322        CPU-PP OUT OF SYNCH
          RJM    PPE         PROCESS PROTOCOL ERROR (NO RETURN)
 IDL      SPACE  4,10
**        IDL - IDLE COMMAND PROCESSOR
*
*         THIS ROUTINE PROCESSES THE PP IDLE COMMAND
*         RECEIVED IN A PP REQUEST. THIS ROUTINE ALSO
*         CALLS *RCB* TO RETURN ALL CM BUFFERS THE PP
*         IS HOLDING IN ITS INTERNAL BUFFER CACHE. IT
*         SHOULD BE NOTED THAT *RCB* ISSUES A PP RESPONSE
*         AS A PART OF RETURNING BUFFERS AND THAT THAT
*         RESPONSE MUST BE ISSUED BEFORE THE RESPONSE
*         FOR THIS IDLE REQUEST IS ISSUED.
*
*         ENTRY  (RQ) = PP REQUEST.
*
*         EXIT   (PPSTATE) = PS.IDL.
*
*         CALLS  RCB


 IDL      SUBR               ENTRY/EXIT
          RJM    RCB         RETURN CM BUFFERS
          LDN    PS.IDL
          STDL   PPSTATE     PLACE PP IN IDLE STATE
          UJN    IDLX        EXIT
 RES      SPACE  4,10
**        RES - RESUME COMMAND PROCESSOR.
*
*         THIS ROUTINE PROCESSES THE PP RESUME COMMAND
*         RECEIVED IN A PP REQUEST.
*
*         ENTRY  (RQ) = PP REQUEST.
*
*         EXIT   (PPSTATE) = PS.NRM.

 RES      SUBR               ENTRY/EXIT
          LDN    PS.NRM
          STDL   PPSTATE     PLACE PP IN NORMAL STATE
          UJN    RESX        EXIT
 RPM      SPACE  4,10
**        RPM - READ PP MEMORY.
*
*         THIS PP REQUEST READS PP MEMORY CHANGES.
*
*         ENTRY  (RQ) = PP REQUEST.
*
*         USES   T5.
          SPACE  2
 RPM      SUBR               ENTRY/EXIT
          LDML   RQ+/RQ/P.CMDLEN GET LENGTH OF OVERLAY
          ADK    7
          SHN    -3          CONVERT LENGTH TO LENGTH IN CM WORDS
          STDL   T5          SAVE OVERLAY LENGTH FOR TRANSFER
          LOADF  RQ+/RQ/P.CMDRMA  REFORMAT CM ADDRESS
          CRML   **,T5       READ IN CHANGES.
 RPMA     EQU    *-1
          UJN    RPMX        EXIT
 RST      SPACE  4,10
**        RST - RESET LINK.
*
*         THIS ROUTINE PROCESSES THE PP RESET LINK
*         COMMAND RECEIVED IN A PP REQUEST. THIS
*         ROUTINE DOES NOT PERFORM THE ACTUAL RESET,
*         RATHER IT CHANGES THE CURRENT DEVICE STATE
*         WHICH WILL RESULT IN A LINK RESET.
*
*         ENTRY  (RQ) = PP REQUEST.
*
*         EXIT   (DSTATE) = DS.ILR.
*

 RST      SUBR               ENTRY/EXIT
          LDN    DS.ILR      ISSUE LOGICAL RESET
          STDL   DSTATE
          UJN    RSTX        EXIT
 SDM      SPACE  4,10
**        SDM - SET DEBUG MODE.
*
*         THIS ROUTINE PROCESSES THE SET DEBUG MODE COMMAND.
*
*         CALLS  PPE


 SDM10    LDC    E321
          RJM    PPE         PROCESS PROTOCOL ERROR (NO RETURN)

 SDM      SUBR               ENTRY/EXIT
          LDML   RQ+/RQ/P.CMDRMA+1
          ZJN    SDM20       IF DEBUG MODE ON
          SBN    1
          NJN    SDM10       IF INVALID COMMAND
          LDN    1
 SDM20    STML   DBUGM
          UJN    SDMX        EXIT

 SPA      SPACE  4,10
**        SPA - SELECT PP MEMORY.
*
*         THIS PP REQUEST SAVES THE PP ADDRESS
*         FOR READ AND WRITE MEMORY REQUESTS.
*
*         ENTRY  (RQ) = PP REQUEST.
          SPACE  2
 SPA      SUBR               ENTRY/EXIT
          LDML   RQ+/RQ/P.CMDRMA+1  GET SECOND HALF OF PP MEM ADDR
          STML   RPMA        SAVE PP ADDRESS
          STML   WPMA
          UJN    SPAX        EXIT
 WPM      SPACE  4,10
**        WPM - WRITE PP MEMORY.
*
*         THIS PP REQUEST WRITES REQUESTED PP MEMORY
*         TO CENTRAL MEMORY.
*
*         ENTRY  (RQ) = PP REQUEST.
*
*         USES   T5, T6.


 WPM      SUBR               ENTRY/EXIT
          LDML   RQ+/RQ/P.CMDLEN GET BYTE COUNT
          ADK    1
          SHN    -1          GET PP WORD COUNT
          STDL   T6          SAVE PP WORD COUNT
 IVB0     IF     DEF,IVB0
          LDK    37777B      GET MAX PP MEMORY ADDRESS
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LDK    17777B      GET MAX PP MEMORY ADDRESS
 IVB4     ENDIF
          SBML   WPMA        SUBTRACT STARTING PT. OF COPY
          STDL   T5          SAVE MAX LENGTH OF COPY
          SBDL   T6          SUBTRACT REQUESTED LENGTH
          MJN    WPM10       IF REQUESTED LENGTH TOO LARGE, SKIP
          LDDL   T6          RESET TRANSFER LENGTH TO REQUESTED LENGTH
          STDL   T5
 WPM10    LDDL   T5          GET PP WORD LENGTH OF TRANSFER
          ADK    3
          SHN    -2          CONVERT PP WORD COUNT TO CPU WORD COUNT
          STDL   WC          SAVE CPU WORD COUNT FOR CM WRITE
          LOADF  RQ+/RQ/P.CMDRMA  REFORMAT CM ADDRESS
          CWML   **,WC       COPY PP MEMORY TO CM
 WPMA     EQU    *-1
          UJK    WPMX        EXIT
          TITLE  COMMAND SUBROUTINES.

 ACR      SPACE  4,10
**        ACR - ABORT CURRENT RESPONSE.
*
*         THIS ROUTINE WILL SEND A *ABORT CURRENT RESPONSE*
*         COMMAND TO THE IVB. THE IVB MUST HAVE ALREADY BEEN
*         SELECTED. THE SEQUENCE NUMBER OF THIS COMMAND AND
*         THE NEXT RESPONSE READ MUST BE EQUAL TO THE SEQUENCE
*         NUMBER OF THE RESPONSE BEING ABORTED.
*
*         EXIT   (A) = 0 IF NO ERRORS.
*                    <> 0 IF ERRORS.
*
*         CALLS  SCP.
*


 ACR10    LDML   ACRLC
          STML   CPBF+/IP/P.REFNO
          RJM    PFR         PAUSE FOR RECOVERY
          RJM    VBR         RESELECT BOARD
          LDN    0

 ACR      SUBR               ENTRY/EXIT
          LDML   CPBF+/IP/P.REFNO
          STML   ACRLC       SAVE LAST COMMAND SEQUENCE NUMBER
          LDML   RPSEQ
          STML   CPBF+/IP/P.REFNO
          DPM    CPBF+/IP/P.REFNO  DECREMENT REFERENCE NUMBER
          LDN    B.IP-/IP/B.LEN  SET LENGTH
          STML   CPBF+/IP/P.LEN
          LDK    O.ACR+0#80  SET ABORT LAST RESPONSE
          STML   CPBF+/IP/P.OPCODE
          RJM    SCP         SEND COMMAND PACKET
          ZJK    ACR10       EXIT IF NO ERRORS
          LDN    DS.ILR
          STDL   DSTATE      RESET IF ERROR
          UJK    ACRX        EXIT

 ACRLC    BSSZ   1           SAVE LAST COMMAND SEQUENCE NUMBER


 ALC      SPACE  4,10
**        ALC - ABORT LAST COMMAND.
*
*         THIS ROUTINE WILL SEND A *ABORT LAST COMMAND*
*         COMMAND TO THE IVB. THE IVB MUST HAVE ALREADY BEEN
*         SELECTED. THE SEQUENCE NUMBER OF THIS COMMAND AND
*         THE NEXT COMMAND SEND MUST BE EQUAL TO THE SEQUENCE
*         NUMBER OF THE COMMAND BEING ABORTED.
*
*         EXIT   (A) = 0 IF NO ERRORS.
*                    <> 0 IF ERRORS.
*
*         CALLS  SCP.
*


 ALC10    DPM    CPBF+/IP/P.REFNO  DECREMENT REFERENCE NUMBER
          RJM    PFR         PAUSE FOR RECOVERY
          RJM    VBR         RESELECT BOARD
          LDN    0

 ALC      SUBR               ENTRY/EXIT
          DPM    CPBF+/IP/P.REFNO  DECREMENT REFERENCE NUMBER
          LDN    B.IP-/IP/B.LEN  SET LENGTH
          STML   CPBF+/IP/P.LEN
          LDK    O.ALC+0#80  SET ABORT LAST COMMAND
          STML   CPBF+/IP/P.OPCODE
          RJM    SCP         SEND COMMAND PACKET
          ZJK    ALC10       EXIT IF NO ERRORS
          LDN    DS.ILR
          STDL   DSTATE      RESET IF ERROR
          UJK    ALCX        EXIT
 ASS      SPACE  4,16
**        ASS -  ANALYZE SLAVE STATUS.
*
*         THIS ROUTINE WILL ANALYZE THE SLAVE STATUS TO
*         DETERMINE THE APPROPRIATE SYMPTOM CODE.
*
*         ENTRY  (STATUS) = SLAVE STATUS.
*
*         EXIT   (A) = SYMPTOM CODE.


 ASS30    LDN    E39         ENDING STATUS WRONG

 ASS      SUBR               ENTRY/EXIT
          LDDL   STATUS
          SHN    11
          PJN    ASS10       IF NOT BUS PARITY
          LDK    E34
          UJN    ASSX        EXIT BUS PARITY ERROR

 ASS10    LDDL   STATUS
          LPN    17B
          ZJN    ASS30       IF REPORTING -ENDING STATUS WRONG-
          SBN    9
          NJN    ASS20       IF NOT -SYNC OUTS NOT EQUAL SYNC INS-
          LDK    E36
          UJN    ASSX        EXIT -SYNC OUTS NOT EQUAL SYNC INS-

 ASS20    PJN    ASS30       IF NOT COMMAND REJECT
          LDK    E35
          UJN    ASSX        EXIT COMMAND REJECT

 BCS      SPACE  4,10
**        BCS - BUS CONTROL SEQUENCE.
*
*         THIS ROUTINE PERFORMS THE BUS CONTROL SEQUENCE
*         ON THE IPI CHANNEL.
*
*         **************************************************************
*         * NOTE: THIS ROUTINE DOES NOT RETURN TO ITS CALLER IF        *
*         *       UNRECOVERED ERRORS OCCUR. RATHER THE DEVICE IS RESET *
*         *       AND EXIT IS TO THE MAIN LOOP.                        *
*         **************************************************************
*
*         ENTRY  (A, BIT 1) = 1 IF DATA.
*                (A, BIT 1) = 0 IF COMMAND/RESPONSE.
*                (A, BIT 0) = 1 IF MESSAGE IN.
*                (A, BIT 0) = 0 IF MESSAGE OUT.
*                (A, OTHER BITS) = 0.
*
*         CALLS  CEP, EFP, ICF.


 BCS      SUBR
          SHN    14
          ADC    H005B
          STDL   BCSFC
          LDN    RRL
          STDL   BCSRC
 BCS10    LDDL   BCSFC
          RJM    ICF         SET SYNC OUT
          ACN    CH
          LDN    77B
 BCS20    FJM    BCS30,CH     IF SYNC IN
          SBN    1
          NJN    BCS20       IF TIMEOUT NOT EXPIRED
          DCN    CH+40B
          LDN    E22         NO SYNC IN
          UJN    BCS50       PROCESS ERROR

 BCS30    IAN    CH          GET BUS ACKNOWLEDGE STATUS
          STDL   P5          BUS ACK STATUS
          SFM    BCS80,CH    IF ERROR FLAG SET
          LDDL   LF          LAST FUNCTION
          LMN    H0069&H005B
          RJM    ICF         DROP SYNC OUT
          ACN    CH
          LDN    77B
 BCS40    FJM    BCSX,CH     IF SYNC IN DROPPED
          SBN    1
          NJN    BCS40       IF TIMEOUT NOT EXPIRED
          DCN    CH+40B
          LDN    E23         SYNC IN DID NOT DROP
 BCS50    STML   OTHERR+/ILD/P.SCODE
 BCS60    BSS    0
          SODL   BCSRC
          NJN    BCS70       IF NOT UNRECOVERED
          LDN    DS.ILR      ISSUE LOGICAL RESET
          STDL   DSTATE      CHANGE DEVICE STATE
 BCS70    SRU    OTHERR,BCSRC,REC.I
          LDC    OTHERR
          RJM    CEP         COMMON ERROR PROCESSING  (NO RETURN IF RESET)
          RJM    VBR         VERIFY BOARD READY
          UJK    BCS10       RETRY BUS CONTROL

 BCS80    BSS
          LDC    OTHERR      'OTHER ERROR' INFO BUFFER
          RJM    EFP         ERROR FLAG PROCESSOR
          UJK    BCS60       LOG ERROR
 CCL      SPACE  4,10
**        CCL -  CLEAR CHANNEL LOCK.
*
*         THIS ROUTINE CLEARS THE CHANNEL LOCK IN THE CM
*         CHANNEL TABLE.
*
*         ENTRY  (CM.CHAN) = CHANNEL TABLE ADDRESS,
*                (CHAN) = CHANNEL NUMBER.
*
*         EXIT   CHANNEL IS UNLOCKED.
*
*         USES   T5, T7.
*
*         CALLS  CLK, PPE.


 CCL      SUBR
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDML   CHAN        CHANNEL NUMBER
          STDL   T5
          RJM    CLK         CLEAR CHANNEL LOCKWORD
          ZJN    CCLX        EXIT
          LDC    E323        UNABLE TO CLEAR CHANNEL LOCK
          RJM    PPE         PROCESS PROTOCOL ERROR (NO RETURN)
 CEP      SPACE  4,12
**        CEP - COMMON ERROR PROCESSING.
*
*         THIS ROUTINE IS CALLED TO COMPLETE PROCESSING OF CHANNEL
*         ERRORS. IF THE *FLAGS* FIELD OF THE LOG MESSAGE INDICATES THAT
*         THE IPI AND DMA REGISTERS HAVE NOT BEEN READ THEY ARE READ HERE.
*         THE FUNCTION HISTORY TABLE IS COPIED TO THE LOG MESSAGE BUFFER.
*         THE REMAINDER OF THE BUFFER IS EXPECTED TO BE SETUP BEFORE CEP
*         IS CALLED.
*
*         ***************************************************************
*         * NOTE: THIS ROUTINE DOES NOT RETURN TO ITS CALLER IF THE     *
*         *       DEVICE STATE IS RESET OR THE PP STATE IS HALTED.      *
*         ***************************************************************
*
*         ENTRY  (A) = PP ADDRESS OF ERROR INFO BUFFER.
*
*         CALLS  CEP, CFH, GAR, ILM, SLM.
*
*         USES   T2, T3.


 CEP      SUBR               ENTRY/EXIT
          STDL   T2
          LDML   /ILD/P.FLAGS,T2
          LPC    /ILD/K.LREG
          NJN    CEP10       IF REGISTERS ALREADY READ
          LDDL   T2
          RJM    GAR         READ REGISTERS
 CEP10    LDDL   T2
          RJM    CFH         COPY FUNCTION HISTORY TABLE
          LDML   CEP
          STML   /ILD/P.RES0,T2  SAVE CALLERS P REGISTER
          LDN    P.ILD-1
          STDL   T3
          RADL   T2

*         MOVE TO LRS

 CEP20    LDML   0,T2
          STML   LRS+/RS/P.SCODE,T3
          SODL   T2
          SODL   T3
          PJN    CEP20       IF NOT DONE
          AODL   T2
          LMC    LRS+/RS/P.SCODE
          ZJN    CEP30       IF USING LRS SLM WILL CLEAR
          LDDL   T2
          RJM    ILM         REINITIALIZE BUFFER
 CEP30    RJM    SLM         SEND LOG MESSAGE
          LDDL   PPSTATE
          LMN    PS.HLT
          ZJN    CEP40       IF PP HALTED
          LDDL   DSTATE
          LMN    DS.ILR
          NJK    CEPX        EXIT IF NOT HALTED OR RESET
 CEP40    LJM    MCL         JUMP TO MAIN LOOP
 CFH      SPACE  4,10
**        CFH - COPY FUNCTION HISTORY.
*
*         THIS ROUTINE WILL COPY THE FUNCTION HISTORY TABLE TO
*         A BUFFER DEFINED AS INTERMEDIATE LOGGING DATA.
*
*         ENTRY  A = ADDRESS OF LOGGING BUFFER.
*
*         USES   T7, T8.


 CFH      SUBR               ENTRY/EXIT
          ERRNZ  FHT-8       ERROR IF FHT NOT EQUAL 8
          ADN    FHT-1
          STDL   T7          SAVE BUFFER ADDRESS
          LDN    FHT-1
          STDL   T8          LENGTH OF LOOP
 CFH10    LDML   FBUF,FI     GET ONE ENTRY
          STML   /ILD/P.FHIST,T7  STORE IN BUFFER
          AODL   FI
          LPN    7
          STDL   FI          RESET INDEX
          SODL   T7
          SODL   T8
          MJN    CFHX        IF DONE EXIT
          UJN    CFH10       ELSE CONTINUE
 CFI      SPACE  4,10
**        CFI - CHECK FOR INTERRUPTS.
*
*         THIS ROUTINE WILL REQUEST CLASS 1 INTERRUPTS
*         FROM THE IVB.
*
*         EXIT   (IP) = 0, IF NO INPUT AVAILABLE,
*                     <> 0, IF INPUT AVAILABLE,
*
*         CALLS  CEP, EFP, ICF.


 CFI      SUBR
          LDC    H0115       REQUEST CLASS 1 INTERRUPT
          RJM    ICF         ISSUE CHANNEL FUNCTION
          PAUSE  100         ALLOW TIME FOR IVB TO SET ITS ADDRESS
          LDN    0
          ACN    CH
          EJM    CFI10,CH    IF CHANNEL NOT FULL
          IAN    CH
          LPC    **          CHECK FOR INTERRUPT
 CFIA     EQU    *-1         SLAVE ADDRESS MASK STORED AT INITIALIZATION
 CFI10    STDL   IP
          LDC    H0111       DROP MASTER OUT
          RJM    ICF         ISSUE CHANNEL FUNCTION
          UJK    CFIX        EXIT
 CLK      SPACE  4,10
**        CLK - CLEAR LOCK.
*
*         THIS ROUTINE CLEARS THE LOCK AT THE SPECIFIED
*         CM ADDRESS.
*
*         ENTRY  (T7) = CM TABLE ADDRESS.
*                (T5) = WORD OFFSET OF LOCKWORD.
*
*         EXIT   (A) = 0, IF LOCK CLEARED,
*                (A) <> 0, IF LOCK COULD NOT BE CLEARED.
*
*         USES   T1, T2, T3, T4, T5, T6, T7.
*
*         MACROS LOADR.


 CLK      SUBR               ENTRY/EXIT
 CLK10    LCN    0
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
 IVB0     IF     DEF,IVB0
          LRIL   T7
          LDML   1,T7        CHANNEL/PP INTERFACE TABLE ADDRESS
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADR  0,T7        CHANNEL/PP INTERFACE TABLE ADDRESS
 IVB4     ENDIF
          ADDL   T5          ADD LOCKWORD OFFSET
          STDL   T6
          RDSL   T1          SET UPPER 32 BITS OF LOCK WORD TO '1'S
          LDDL   T1
          ADDL   T2
          ADC    400001B
          ZJN    CLK10       IF ANOTHER INTERLOCK OPERATION IS IN PROGRESS
          AODL   T5          INSURE T5 NON ZERO
          LDDL   T1
          SHN    17-15
          PJN    CLK20       IF INTERLOCK LOST (RESTORE ORIGINAL CONTENTS)
          LDDL   T4
          LMDL   PPNO        PP NUMBER
          NJN    CLK20       IF SOMEONE ELSE HAS GRABBED THE INTERLOCK
*         LDN    0
          STDL   T1          CLEAR INTERLOCK WORD
          STDL   T2
          STDL   T3
          STDL   T4
          STDL   T5
 CLK20    LDDL   T6
          ADC    400000B
          CWDL   T1          UPDATE INTERLOCK WORD
          LDDL   T5
          UJK    CLKX        EXIT
 CPL      SPACE  4,10
**        CPL - CLEAR PP LOCKWORD.
*
*         THIS ROUTINE CLEARS THE PP REQUEST QUEUE LOCK
*         IN THE PP INTERFACE TABLE.
*
*         USES   T5, T7.
*
*         CALLS  CLK.


 CPL      SUBR
          LDN    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    CLK         CLEAR THE LOCKWORD
          UJK    CPLX        EXIT
 CSW      SPACE  4,28
**        CSW - COMPARE-SWAP ROUTINE.
*
*         THIS ROUTINE DOES A COMPARE-SWAP OF A SPECIFIED WORD.
*         A PSEUDO-LANGUAGE COMPARABLE CALL WOULD BE
*            CALL COMPARE-SWAP(CS_WORD, OLD, NEW, ACTUAL, STATUS)
*            WHERE
*                CS_WORD  = (T7) + (T5) = ADDRESS OF THE WORD TO BE COMPARE/SWAPPED,
*                OLD    = ((P5)) = EXPECTED VALUE OF THE C/S WORD,
*                NEW    = ((A)) UPON ENTRY = REPLACEMENT VALUE OF THE C/S WORD,
*                ACTUAL = (P1 - P4) RETURNED BY ROUTINE *SLR* = ORIGINAL VALUE
*                         OF THE C/S WORD,
*                STATUS = (A) UPON EXIT = SUCCESS/FAILURE OF THE COMPARE-SWAP
*
*         ENTRY  (A)  = ADDRESS OF NEW (REPLACEMENT) VALUE FOR C/S WORD,
*                (P5) = ADDRESS OF OLD (EXPECTED) VALUE IN C/S WORD,
*                (T5) = WORD OFFSET OF C/S WORD,
*                (T7) = CM ADDRESS OF TABLE.
*
*         EXIT   (A) = 0, IF THE COMPARE-SWAP WAS SUCCESSFUL.  (IF THE CONTENTS
*                         OF THE C/S WORD WAS REPLACED BY *NEW*).
*                (A) <> 0, IF THE COMPARE-SWAP FAILED.  (IF THE ORIGINAL
*                          CONTENTS REMAIN IN THE C/S WORD).
*                (P5) = UNDEFINED.
*
*         USES   P1 - P4, T2, T6.
*
*         CALLS  SLR.


*         OLD VALUE WAS NOT IN THE C/S WORD.  RESTORE ORIGINAL VALUE.

 CSW10    BSS    0
          LDDL   T6          OFFSET TO CM WORD
          ADC    400000B
          CWDL   P1          UPDATE INTERLOCK WORD WITH ORIGINAL VALUE

 CSW      SUBR               ENTRY/EXIT
          STML   CSWA        PLANT PP ADDRESS OF *NEW*
          RJM    SLR         SET LOCK RESERVATION

*         IF ACTUAL=OLD  (IF (P1) - (P1+2) = ((OLD)) - ((OLD+2))).

          LDML   0,P5
          LMDL   P1
          NJK    CSW10       IF DIFFERENT
          LDML   1,P5
          LMDL   P2
          NJK    CSW10       IF DIFFERENT
          LDML   2,P5
          LMDL   P3
          NJK    CSW10       IF DIFFERENT
          LDN    1           SIZE OF *NEW* (CM WORDS)
          STDL   WC
          LDDL   T6          OFFSET TO CM WORD
          ADC    400000B
          CWML   **,WC       UPDATE INTERLOCK WORD WITH *NEW*
 CSWA     EQU    *-1         PP ADDRESS OF *NEW*
          LDN    0           CM WORD CONTENTS WERE REPLACED BY *NEW*
          UJK    CSWX        EXIT
 DCM      SPACE  4,15
**        DCM - DESELECT CONTROL MODULE.
*
*         THIS ROUTINE WILL DESELECT THE IVB.
*
*         EXIT   (A) = 0, IF NO ERRORS,
*                   <> 0, IF ERRORS.
*
*         CALLS  ICF.


 DCM20    LDN    0

 DCM      SUBR
          LDC    H0071
          RJM    ICF         DROP SELECT OUT
          ACN    CH
          LDC    MS50
 DCM10    FJM    DCM20,CH     IF SLAVE IN DROPPED
          SBN    1
          NJN    DCM10       IF TIMEOUT NOT EXPIRED
          LDN    E28         SLAVE IN DID NOT DROP
          STML   LRS+/RS/P.SCODE
          LDN    DS.ILR
          STDL   DSTATE      RESET DEVICE
          LDC    LRS+/RS/P.SCODE
          RJM    CEP         COMMON ERROR PROCESSING
          UJN    DCMX        EXIT - (A) <> 0
 IVB4     IF     DEF,IVB4
 DCN      SPACE  4,10
**        DCN - DISCONNECT CHANNEL.
*
*         THIS ROUTINE IS TO BE USED IN CONJUNCTION
*         WITH A DMA READ OR WRITE FUNCTION. AFTER
*         ISSUING THE DMA FUNCTION, ACTIVATING THE
*         CHANNEL AND OUTPUTING THE BYTE COUNT AND
*         RMA THIS ROUTINE IS CALLED TO DISCONNECT
*         THE CHANNEL AND CHECK FOR ANY ERRORS DURING
*         THE 3 WORD TRANSFER.
*
*         NOTE: THIS ROUTINE IS NOT TO BE USED AS A
*               GENERAL PURPOSE CHANNEL DISCONNECT
*               ROUTINE.
*
*         ENTRY  THE 3 WORD OUTPUT TO START A DMA OPERATION
*                HAS COMPLETED.
*
*
*         USES   WC.
*
*         CALLS  CEP


 DCN50    BSS
          DCN    CH+40B      DISCONNECT THE CHANNEL
          LDN    0

 DCN      SUBR               ENTRY/EXIT
          STDL   WC          WORDS NOT TRANSFERRED
          SFM    DCN40,CH    IF ERROR FLAG SET
          NJN    DCN30       IF INCOMPLETE TRANSFER
          EJM    DCN50,CH    IF CHANNEL EMPTY
          LDN    E08         CHANNEL NOT EMPTY
 DCN10    BSS
          STML   IOERR+/ILD/P.SCODE
 DCN20    LDN    DS.ILR
          STDL   DSTATE
          LDC    IOERR
          RJM    CEP         COMMON ERROR PROCESSING (NO RETURN)

 DCN30    LDN    6
          STML   IOERR+/ILD/P.EDATA
          SBDL   WC
          SBDL   WC
          STML   IOERR+/ILD/P.ADATA
          LDN    E07         INCOMPLETE TRANSFER
          UJN    DCN10

 DCN40    BSS
          LDC    IOERR
          RJM    EFP         ERROR FLAG PROCESSING
          UJN    DCN20       LOG ERROR
 IVB4     ENDIF
 DGU      SPACE  4,10
**        DGU - DEVICE GONE UNAVAILABLE.
*
*         THIS ROUTINE IS CALLED WHEN THE IVB HAS
*         TRANSITIONED TO THE 'NOT READY' STATE. IF THE
*         IVB WAS IN SERVICE PRIOR TO BECOMING NOT READY,
*         AN UNSOLICITED RESPONSE WILL BE ISSUED AND THE
*         DEVICE STATE SET TO DS.WNR. IF THE IVB WAS NOT IN
*         SERVICE, THE DEVICE STATE WILL BE SET TO DS.NRDY.
*
*         EXIT   (DSTATE) = DS.WNR OR DS.NRDY.
*
*         CALLS  RCB, SUR.


 DGU      SUBR               ENTRY/EXIT
          LDML   AVAIL
          NJN    DGU10       IF DEVICE WAS AVAILABLE
          LDN    DS.NRDY
          STDL   DSTATE      SET DEVICE STATE TO 'NOT READY'
          UJN    DGUX        EXIT

 DGU10    LDN    /RS/C.XFER*8+8
          STML   RS+/RS/P.RESPL  RESPONSE LENGTH
          LDN    URC.NRDY    DEVICE OPERATIONAL RESPONSE
          RJM    SUR         SEND UNSOLICITED RESPONSE
          LDN    0
          STML   AVAIL       DEVICE UNAVAILABLE
          RJM    LAM         LOG AVAILABILITY
          RJM    RCB         RETURN CM BUFFERS
          LDN    DS.WNR
          STDL   DSTATE      WAIT FOR NOT READY ACK
          UJK    DGUX        EXIT
 DMW      SPACE  4,20
**        DMW - DIRECT MEMORY WRITE.
*
*         THIS ROUTINE WILL COMPLETE THE OUTPUT OF A CC PDU.
*
*         ENTRY  BYTCNT = BYTES SENT WITH COMMAND.
*                BYTS = NUMBER OF BYTES SENT FROM CURRENT BUFFER.
*                CML = CURRENT CM LIST INDEX.
*                CMLISTL = NUMBER OF CM LENGTH/ADDRESS PAIRS.
*                P6 = OFFSET TO CURRENT RMA/ADDRESS PAIR.
*                RQ = UNIT REQUEST.
*
*         EXIT   (A) = 0 IF NO ERRORS.
*                    <> 0 IF ERRORS.
*                BYTCNT = BYTES WRITTEN.
*                WC <> 0 IF TRANSFER NOT COMPLETE.
*
*         USES   P6, WC.
*
*         CALLS  PPE, SCP, USR.


 DMW50    BSS    0
 IVB0     IF     DEF,IVB0
          LDC    64          MULTIPLY LOOP TO 15 SECONDS
          STML   TIMEX
 DMW55    BSS    0
          LCN    0
 DMW60    IJM    DMW70,CH    IF SLAVE IN DROPED
          SBN    1
          NJN    DMW60       IF NOT TIMED OUT
          SOML   TIMEX
          NJN    DMW55       IF NOT COMPLETE
          DCN    CH+40B
          LDN    E28         SLAVE IN DID NOT DROP
          STML   IOERR+/ILD/P.SCODE  SAVE SYMPTOM CODE
          LDN    DS.ILR
          STDL   DSTATE
          LDC    IOERR
          RJM    CEP         LOG ERROR  (NO RETURN)

 DMW70    LDDL   WC
          ZJN    DMW90       IF NO ERRORS
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          RJM    WTC         WAIT TRANSFER COMPLETION
          ZJN    DMW90       IF NO ERRORS
 IVB4     ENDIF
 DMW80    LDML   BYTCNT
          ADDL   BC
          STML   IOERR+/ILD/P.EDATA
          SBDL   WC          WC IS IN PP WORDS
          SBDL   WC
          STML   IOERR+/ILD/P.ADATA
          LDN    E07
          STML   IOERR+/ILD/P.SCODE
 DMW90    CFM    DMW100,CH   IF ERROR FLAG CLEAR
          LDC    IOERR
          RJM    EFP
 DMW100   LDML   IOERR+/ILD/P.SCODE


 DMW      SUBR               ENTRY/EXIT
          LDN    0
          STDL   WC
          LDN    DATAOUT
          RJM    BCS         CONDITION BUS FOR DATA OUT
          LDC    H0381       STREAM, WRITE, DMA
          RJM    ICF         SEND FUNCTION
 IVB0     IF     DEF,IVB0
          ACN    CH
 IVB0     ENDIF
          LDML   RQ+/URQ/P.MBLEN,P6  TOTAL DATA LENGTH IN BUFFER
          SBML   BYTS        LESS BYTES SO FAR
          ZJK    DMW40       EXIT FOR NEXT BUFFER IF ALL FROM THIS ONE
 DMW10    STML   BC          NUMBER OF BYTES LEFT TO TRANSFER TO THE IVB
          ADML   BYTCNT      PLUS BYTES SO FAR
          SBML   MAXPDU      MAX BURST LENGTH OF IVB
          MJN    DMW20       IF NOT TOO MUCH FOR 1 DMA OPERATION
          LDK    E303
          RJM    PPE         LOG MAX LENGTH EXCEEDED  (NO RETURN)

 DMW20    BSS    0
 IVB4     IF     DEF,IVB4
          LDC    H0D00       DMA WRITE
          RJM    ICF         SEND FUNCTION
          LDML   BYTS
          ADML   RQ+/URQ/P.MBRMA+1,P6  LOWER PORTION OF BUFFER ADDRESS
          STDL   RMA+1
          SHN    -16
          ADML   RQ+/URQ/P.MBRMA,P6    UPPER PORTION OF BUFFER ADDRESS
          STDL   RMA
          ACN    CH
          LDN    3
          OAM    BC,CH       BYTE COUNT, RMA
          RJM    DCN         DISCONNECT THE CHANNEL
          RJM    WTE         WAIT T' REGISTER EMPTY
          NJK    DMW80       IF ERRORS
 IVB4     ENDIF
 IVB0     IF     DEF,IVB0
          LDML   BC          REMAINING BYTES TO BE TRANSFERRED
          SHN    -1          PP WORD COUNT
          STDL   WC          LENGTH OF BUFFER TO BE WRITTEN TO IVB
          LRML   RQ+/URQ/P.MBRMA,P6     UPPER PORTION OF ADDRESS OF DATA BUFFER
          LDML   RQ+/URQ/P.MBRMA+1,P6  LOWER PORTION OF BUFFER ADDRESS
          ADML   BYTS        PLUS BYTES TRANSFERRED SO FAR THIS BLOCK
          SHN    -3
          CMCH   WC,CH
          LDDL   WC
          NJK    DMW50       IF INCOMPLETE WRITE
 IVB0     ENDIF
 DMW30    LDML   BC          BYTES TRANSFERRED
          RAML   BYTCNT      BUMP PROGRESSIVE COUNT
 DMW40    AOML   CML
          SBML   CMLISTL
          ZJK    DMW50       IF NO MORE TO WRITE
          LDN    0
          STML   BYTS
          LDML   CML         CURRENT CM LIST INDEX
          SHN    2           CONVERT TO PP WORD OFFSET
          STDL   P6          OFFSET TO CM LENGTH/ADDRESS PAIR (PP WORDS)
          LDML   RQ+/URQ/P.MBLEN,P6   LENGTH OF DATA BUFFER
          UJK    DMW10       CONTINUE TO WRITE MORE
 DUR      SPACE  4,16
**        DUR - DELINK UNIT REQUEST FROM QUEUE.
*
*         THIS ROUTINE DELINKS THE CURRENT UNIT REQUEST
*         FROM THE APPROPRIATE QUEUE AND UPDATES THE UNIT QUEUE HEAD POINTER
*         TO POINT TO THE NEXT REQUEST IN THE QUEUE.
*
*         ENTRY  (CM.URQ) = REFORMATTED ADDRESS OF REQUEST QUEUE.
*
*         USES   P5, T1 - T4, T5, T7, WC.
*
*         CALLS  CSW.
*
*         MACROS LOADC.


 DUR      SUBR               ENTRY/EXIT
          LDN    1           SIZE OF UNIT QUEUE HEAD POINTER
          STDL   WC

*         UPDATE UNIT QUEUE HEAD POINTER.

 DUR10    BSS    0
 IVB4     IF     DEF,IVB4
          LOADC  CM.URQ      CM ADDRESS OF UNIT REQUEST QUEUE
 IVB4     ENDIF
 IVB0     IF     DEF,IVB0
          LRDL   CM.URQ      CM ADDRESS OF UNIT REQUEST QUEUE
          LDDL   CM.URQ+1
 IVB0     ENDIF
          ERRNZ  /UQD/C.HEAD OFFSET TO UNIT QUEUE HEAD POINTER IS NOT ZERO
          ADK    /UQD/C.HEAD OFFSET TO UNIT QUEUE HEAD POINTER
          CWML   RQ+/URQ/P.NEXTLN,WC   UPDATE UNIT QUEUE HEAD POINTER
          LDML   RQ+/URQ/P.NEXT     NEXT UNIT REQUEST (UPPER PART)
          ADML   RQ+/URQ/P.NEXT+1   NEXT UNIT REQUEST (LOWER PART)
          NJK    DURX        IF OTHER UNIT REQUESTS IN THIS QUEUE

*         CLEAR UNIT QUEUE TAIL POINTER TO SHOW THAT THERE ARE NO OTHER UNIT
*         REQUESTS IN THIS QUEUE.  IF A NEW UNIT REQUEST IS PLACED IN THE
*         QUEUE WHILE THIS IS BEING DONE, UNIT QUEUE HEAD POINTER WILL BE
*         UPDATED INSTEAD.

          LDK    CM.QT
          STDL   T7          UNIT QUEUE TAIL POINTER
          LDN    0
          STDL   T5          OFFSET TO UNIT QUEUE TAIL POINTER (NO OFFSET)
          LDK    RQ+/URQ/P.THISPV
          STDL   P5          ADDRESS OF WORD CONTAINING PVA OF CURRENT REQUEST
          LDK    NIL         NIL POINTER
          RJM    CSW         COMPARE-SWAP (UNIT QUEUE TAIL POINTER CONTENTS)
          ZJK    DURX        IF COMPARE-SWAP SUCCEEDED

*         COMPARE-SWAP FAILED (A NEW REQUEST CAME IN).
*         RE-READ NEXTLN/NEXT WORD OF REQUEST TO GET THE NEW REQUEST POINTER.

          LDN    1
          STDL   WC          SIZE OF NEXTLN/NEXT (CM WORD)
 IVB4     IF     DEF,IVB4
          LOADF  RS+/RS/P.REQ  RMA OF THE CURRENT REQUEST
 IVB4     ENDIF
 IVB0     IF     DEF,IVB0
          LRML   RS+/RS/P.REQ  RMA OF THE CURRENT REQUEST
          LDML   RS+/RS/P.REQ+1
          SHN    -3
 IVB0     ENDIF
          ADN    /URQ/C.NEXT OFFSET TO NEXTLN/NEXT WORD
          CRML   RQ+/URQ/P.NEXTLN,WC   READ UNIT REQUEST NEXTLN/NEXT WORD
          UJK    DUR10       UPDATE UNIT QUEUE HEAD POINTER
 EFP      SPACE  4,10
**        EFP - ERROR FLAG PROCESSOR.
*
*         THIS ROUTINE IS CALLED WHEN A CHANNEL ERROR WAS DETECTED.  IT
*         ANALYZES THE DMA AND IPI ERROR REGISTERS TO DETERMINE A SYMPTOM CODE
*         TO BE PLACED IN THE LOG MESSAGE.  THE *FLAGS* FIELD OF THE LOG
*         MESSAGE IS CHECKED TO DETERMINE IF THE ERROR REGISTERS WERE READ BY
*         THE CALLER.
*
*         ENTRY  (A) = ADDRESS OF ERROR INFORMATION BUFFER.
*
*         USES   T8.
*
*         CALLS  ICF, GAR.


 EFP      SUBR
          STDL   T8
 IVB4     IF     DEF,IVB4
          LDC    H0800       DMA TERMINATE
          RJM    ICF
 IVB4     ENDIF
          LDML   /ILD/P.FLAGS,T8
          LPC    /ILD/K.LREG
          NJN    EFP3        IF REGISTERS IN BUFFER
          LDDL   T8
          RJM    GAR         GET ALL REGISTERS
 EFP3     BSS    0
 IVB4     IF     DEF,IVB4
          LDML   /ILD/P.DMAER,T8
          SHN    9
          MJK    EFP60       IF IPI ERROR
          SHN    12
          MJK    EFP85       IF ILLEGAL FUNCTION
          SHN    1
          MJN    EFP5        IF UNCORRECTED CM ERROR
          SHN    1
          PJN    EFP10       IF NOT CM REJECT
 EFP5     BSS
          LDN    E09         CENTRAL MEMORY ERROR
          UJN    EFP40

 EFP10    BSS
          SHN    1
          PJN    EFP15       IF NOT INVALID CM RESPONSE CODE
          LDN    E10
          UJN    EFP40

 EFP15    BSS
          SHN    1
          PJN    EFP20       IF CM RESPONSE CODE PARITY ERROR
          LDN    E11
          UJN    EFP40

 EFP20    BSS
          SHN    1
          PJN    EFP25       IF NOT CMI READ DATA PARITY ERROR
          LDN    E12
          UJN    EFP40

 EFP25    BSS
          SHN    5
          PJN    EFP35       IF NOT JY DATA ERROR
          LDN    E13
          UJN    EFP40

 EFP35    BSS
          SHN    1
          PJN    EFP45       IF NOT BAS PARITY ERROR
          LDN    E14
 EFP40    BSS
          UJN    EFP75

 EFP45    BSS
          SHN    1
          PJN    EFP50       IF NOT LZ ERROR
          LDN    E15
          UJN    EFP75

 EFP50    BSS
          SHN    1
          PJN    EFP55       IF NOT JY ERROR
          LDN    E16
          UJN    EFP75

 EFP55    BSS
          SHN    1
          PJK    EFP130      IF NOT LX ERROR
          LDN    E17
          UJN    EFP75
 IVB4     ENDIF

 EFP60    BSS
          LDML   /ILD/P.ERREG,T8
          SHN    2
          PJN    EFP65       IF NOT BUFFER COUNTER PARITY
          LDN    E31
          UJN    EFP75

 EFP65    BSS
          SHN    2
          PJN    EFP70       IF NOT SYNC COUNTER PARITY
          LDN    E32
          UJN    EFP75

 EFP70    BSS
          SHN    1
          PJN    EFP80       IF NOT PERIOD COUNTER PARITY
          LDN    E03
 EFP75    BSS
          UJN    EFP120

 EFP80    BSS
          SHN    1
          MJN    EFP85       IF PARITY ERROR ON FUNCTION
          SHN    1
          PJN    EFP95       IF NOT PARITY ERROR ON FUNCTION
 EFP85    BSS
          LDN    E01         FUNCTION TIMEOUT
          UJN    EFP120

 EFP95    BSS
          SHN    3
          PJN    EFP100      IF NOT LOST DATA
          LDN    E33
          UJN    EFP150

 EFP100   BSS
          SHN    1
          PJN    EFP105      IF NOT UPPER ICI PARITY
          LDN    E04
          UJN    EFP150

 EFP105   BSS
          SHN    1
          PJN    EFP110      IF NOT LOWER ICI PARITY
          LDN    E05
          UJN    EFP150

 EFP110   BSS
          SHN    1
          PJN    EFP115      IF NOT IPI SEQUENCE ERROR
          LDN    E24
          UJN    EFP150

 EFP115   BSS
          SHN    1
          PJN    EFP125      IF NOT UPPER IPI CHANNEL PARITY
          LDN    E25
 EFP120   BSS
          UJN    EFP150

 EFP125   BSS
          SHN    1
          PJN    EFP130      IF NOT LOWER IPI CHANNEL PARITY
          LDN    E26
          UJN    EFP150

 EFP130   BSS
          LDN    E06         IOU ERROR
 EFP150   BSS
          STML   /ILD/P.SCODE,T8
          RJM    CER         CLEAR ERRORS
          UJK    EFPX        EXIT
 ESS      SPACE  4,10
**        ESS - ENDING STATUS SEQUENCE.
*
*         THIS ROUTINE EXECUTES THE ENDING STATUS SEQUENCE
*         AFTER BOTH COMMAND/RESPONSE AND READ/WRITE TRANSFERS.
*
*         ENTRY  (A) = MASTER STATUS TO SEND TO IVB.
*
*         EXIT   (A) = 0, IF ENDING STATUS RECEIVED,
*                   <> 0, IF ENDING STATUS NOT RECEIVED,
*                (STATUS) = SLAVE STATUS BYTE IF (A) = 0.
*
*         CALLS  EFP, ICF.
*

 ESS60    LDN    0

 ESS      SUBR               ENTRY/EXIT
          STML   MSTAT       SAVE MASTER STATUS
          SHN    8
          ADC    H0039       SETUP MASTER STATUS IN BUS A
          RJM    ICF         DROP MASTER OUT
          ACN    CH
          LDC    64          MULTIPLY LOOP TO 15 SECONDS
          STML   TIMEX
 ESS05    BSS    0
          LCN    0
 ESS10    FJM    ESS30,CH     IF SLAVE IN SET
          SBN    1
          NJN    ESS10       IF TIMEOUT NOT EXPIRED
          SOML   TIMEX
          NJN    ESS05       IF NOT COMPLETE
          LDN    DS.ILR
          STDL   DSTATE
          LDN    E27         SLAVE IN NOT SET
          STML   LRS+/RS/P.SCODE
 ESS20    LDC    LRS+/RS/P.SCODE
          RJM    CEP         LOG ERROR (NO RETURN IF RESET)
          RJM    VBR         MASTER CLEAR AND RESELECT
          LDN    1
          UJK    ESSX        EXIT - (A) <> 0

 ESS30    IAN    CH
          STDL   STATUS      SAVE ENDING STATUS
          TRACE  (ESS,STATUS)
          LDDL   STATUS
          SFM    ESS50,CH    IF ERROR FLAG SET
          SHN    17-/STATP/SUC
          MJK    ESS40       IF SUCCESSFUL
          RJM    PFR         PAUSE FOR RECOVERY
          RJM    VBR         MASTER CLEAR AND RESELECT
          UJK    ESS60       EXIT

*         VALIDATE THAT IF MASTER STATUS WAS UNSUCCESSFUL,
*         SLAVE STATUS IS ALSO UNSUCCESSFUL.

 ESS40    LDML   MSTAT       MASTER STATUS
          SHN    17-/STATP/SUC
          MJK    ESS60       IF MASTER STATUS ALSO SUCCESSFUL
          LDC    LRS+/RS/P.SCODE
          RJM    ISS         INCLUDE SLAVE STATUS
          LDC    LRS+/RS/P.SCODE
          RJM    IMS         INCLUDE MASTER STATUS
          LDC    E203        SLAVE/MASTER STATUS MISMATCH
          RJM    PPE         PROCESS PROTOCOL ERROR (NO RETURN)

 ESS50    LDC    LRS+/RS/P.SCODE
          RJM    EFP         ERROR FLAG PROCESSING
          UJK    ESS20       LOG ERROR
 FORMA    SPACE  4,10
**        FORMA - FORMAT ADDRESS.
*
*         ENTRY  (A) = ADDRESS OF 2-BYTE REAL MEMORY ADDRESS.
*
*         EXIT   (CMADR - CMADR+2) = REFORMATTED RMA,
*                -ADDRESS-, WORD 0, BITS 0-13 AND
*                           WORD 1, BITS 3-15, ARE REFORMATTED TO-
*                -CMADR-,   WORD 0, BITS 0-9,
*                           WORD 1, BITS 0-11,
*                           WORD 2, BITS 0-5.
*

 FOR10    LDIL   CMADR       CONVERT ADDRESS
          LPN    37B
          SHN    16
          LMML   1,CMADR
          SHN    9
          STD    CMADR+1
          SHN    6
          LPN    77B
          STD    CMADR+2
          LDIL   CMADR
          SHN    -5
          STD    CMADR
          LRD    CMADR       LOAD R-REGISTER
          LDDL   CMADR+2     LOAD A-REGISTER
          LMC    400000B

 FORMA    SUBR
          STDL   CMADR       SAVE POINTER TO ADDRESS
          LDML   1,CMADR     CHECK BYTE NUMBER
          LPN    7
          ZJN    FOR10       IF RMA IS ON WORD BOUNDARY
          LDC    E300        RMA NOT WORD BOUNDARY
          RJM    PPE         PROCESS PROTOCOL ERROR (NO RETURN)
 GAR      SPACE  4,18
**        GAR - GET ALL REGISTERS.
*
*         READ ALL IPI STATUS, ERROR, AND CONTROL REGISTERS.
*         REGISTERS ARE STORED IN A LOGGING DATA BUFFER WHOSE
*         ADDRESS IS PASSED IN THE A REGISTER.
*
*         ENTRY  A = ADDRESS OF LOGGING DATA BUFFER
*
*         USES   T7.
*
*         CALLS  RAR.


 GAR      SUBR               ENTRY/EXIT
          STDL   T7
          LDC    H00E1       IPI STATUS REGISTER
          RJM    RAR         READ REGISTER
          STML   /ILD/P.STREG,T7  SAVE REGISTER CONTENTS
          LDC    H00F1       IPI ERROR REGISTER
          RJM    RAR         READ REGISTER
          STML   /ILD/P.ERREG,T7  SAVE REGISTER CONTENTS
 IVB4     IF     DEF,IVB4
          LDC    H0700       DMA STATUS REGISTER
          RJM    RAR         READ REGISTER
          STML   /ILD/P.OSR,T7  SAVE REGISTER CONTENTS
          LDC    H0600       DMA ERROR REGISTER
          RJM    RAR         READ REGISTER
          STML   /ILD/P.DMAER,T7  SAVE REGISTER CONTENTS
          LDC    H0200       DMA CONTROL REGISTER
          RJM    RAR         READ REGISTER
          STML   /ILD/P.CR,T7  SAVE REGISTER CONTENTS
 IVB4     ENDIF
          LDC    /ILD/K.LREG
          RAML   /ILD/P.FLAGS,T7
          UJK    GARX        EXIT
 GCB      SPACE  4,16
**        GCB - GET CM BUFFERS.
*
*         THIS ROUTINE WILL INTERLOCK THE PP OUT POINTER WORD
*         AND REMOVE THE REQUESTED NUMBER OF BUFFERS FROM THE
*         SPECIFIED POOL AND UPDATE THE 'OUT' POINTERS.
*
*         ENTRY  (BPINDX) = BUFFER POOL INDEX.
*
*         EXIT   (BPCNT) = NUMBER OF BUFFERS STILL NEEDED FROM POOLS,
*                RESPONSE BUFFER POOL STATUS SET APPROPRIATELY IF POOL IS
*                          EMPTY OR BELOW THRESHOLD.
*
*         USES   T1 - T3, T8, P6.
*
*         CALLS  SBL.
          SPACE  4,10
*         BUFFER POOL DESCRIPTOR PP OUT POINTER

 PPOUT    EQU    P1+/BPD/P.PPOUT-/BPD/C.PPOUT*4

 GCB      SUBR               ENTRY/EXIT
          LDDL   BPINDX
          LMK    SMINDX
          NJN    GCB10       IF LARGE POOL INDEX
          LDC    SBUFC       SMALL BUFFER CACHE
          UJN    GCB20

 GCB10    LDC    LBUFC       LARGE BUFFER CACHE
 GCB20    STML   CACHE
          ERRNZ  C.BPD-5
          LDDL   BPINDX      INDEX INTO BUFFER POOL
          LMK    SMINDX
          ZJN    GCB30       IF FIRST BUFFER POOL
          LDN    C.BPD
 GCB30    STDL   P6          CM WORD OFFSET OF BUFFER POOL DESCRIPTOR
          ADN    /BPD/C.PPOUT   OFFSET TO BPD 'PP_OUT' POINTER
          RJM    SBL         INTERLOCK 'PP_OUT' POINTER

*         GET BUFFER POOL DESCRIPTOR.

          LDN    0
          STML   BUFCNT      NUMBER OF BUFFERS OBTAINED
          LDN    C.BPD
          STDL   WC          LENGTH OF POOL DESCRIPTOR
 IVB0     IF     DEF,IVB0
          LRDL   CM.BPD
          LDDL   CM.BPD+1
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADC  CM.BPD      ADDRESS OF FIRST POOL DESCRIPTOR
 IVB4     ENDIF
          ADDL   P6          CM WORD OFFSET OF BUFFER POOL DESCRIPTOR
          CRML   BPD,WC      READ BUFFER POOL DESCRIPTOR

*         VALIDATE BUFFER POOL DESCRIPTOR 'IN' POINTER.

          LDML   BPD+/BPD/P.IN   BUFFER POOL DESCRIPTOR 'IN' POINTER
          LPN    7           BYTE OFFSET
          NJN    GCB40       IF BPD 'IN' POINTER NOT ON A CM WORD BOUNDARY

*         VALIDATE BUFFER POOL DESCRIPTOR 'OUT' POINTER.

          LDDL   PPOUT       BUFFER POOL DESCRIPTOR PP 'OUT' POINTER
          LPN    7           BYTE OFFSET
          ZJN    GCB45       IF BPD 'OUT' POINTER ON A CM WORD BOUNDARY
 GCB40    LDC    E324        INVALID BUFFER POOL DESCRIPTOR
          RJM    PPE         PROCESS PROTOCOL ERROR (NO RETURN)

*         CHECK IF A BUFFER IS AVAILABLE.

 GCB45    LDML   BPD+/BPD/P.IN   BUFFER POOL DESCRIPTOR 'IN' POINTER
          SBDL   PPOUT       COMPARE WITH BPD 'PP_OUT' POINTER
          ZJK    GCB70       IF BUFFER POOL IS EMPTY
          LDN    C.BP
          STDL   WC          BUFFER POOL ENTRY SIZE (CM WORDS)
 GCB50    BSS    0
          LDDL   PPOUT       BUFFER POOL ENTRY OFFSET (CM BYTES)
          SHN    -3          CONVERT TO CM WORDS
          STDL   T2          BUFFER POOL ENTRY OFFSET

*         GET BUFFER POOL TABLE ENTRY.

          SOML   BPCNT,BPINDX  DECREMENT COUNT OF BUFFERS NEEDED
          ERRNZ  P.IBC-8
          SHN    3           8 PP WORDS PER ENTRY
          ADML   CACHE       BASE CACHE ADDRESS
          STML   GCBA        PLUG CACHE ENTRY ADDRESS
 IVB0     IF     DEF,IVB0
          LRML   BPD+/BPD/P.BPRMA
          LDML   BPD+/BPD/P.BPRMA+1
          SHN    -3
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADF  BPD+/BPD/P.BPRMA  BUFFER POOL ADDRESS
 IVB4     ENDIF
          ADDL   T2          BUFFER POOL ENTRY OFFSET (CM WORDS)
          CRML   **,WC       READ BUFFER PVA AND RMA INTO CACHE
 GCBA     EQU    *-1

*         DETERMINE NEW BUFFER POOL DESCRIPTOR 'PP_OUT' POINTER VALUE.

          LDDL   PPOUT       BUFFER POOL DESCRIPTOR 'PP_OUT' POINTER
          ADN    B.BP        NEXT BUFFER POOL TABLE ENTRY
          SBML   BPD+/BPD/P.LIMIT   COMPARE WITH LIMIT
          ZJN    GCB60       IF AT LIMIT
          ADML   BPD+/BPD/P.LIMIT   RESTORE GOOD VALUE OF NEW BPD PP OUT POINTER

 GCB60    BSS    0
          STDL   PPOUT       NEW BUFFER POOL DESCRIPTOR 'PP_OUT' POINTER
          AOML   BUFCNT      NUMBER OF BUFFERS OBTAINED

*         CHECK IF POOL HAS BEEN EMPTIED OR ALL BUFFERS OBTAINED.

          LDML   BPD+/BPD/P.IN   BUFFER POOL DESCRIPTOR 'IN' POINTER
          SBDL   PPOUT       COMPARE WITH BPD 'PP_OUT' POINTER
          ZJN    GCB70       IF BUFFER POOL IS EMPTY
          LDML   BPCNT,BPINDX  COUNT OF BUFFERS STILL NEEDED
          ZJN    GCB80       IF ALL BUFFERS OBTAINED
          UJK    GCB50


*         BUFFER POOL IS EMPTY.

 GCB70    BSS    0
          LDML   BUFCNT      NUMBER OF BUFFERS OBTAINED
          ZJN    GCB110      IF WE DID NOT EMPTY THE POOL (IF NO BUFFERS OBTAINED)
          AOML   EMPBUF,BPINDX     INCREMENT EMPTY POOL COUNT
          LDK    BP.EMPTY    EMPTY BUFFER POOL STATUS
          UJN    GCB100

*         CHECK IF BELOW THRESHOLD.

 GCB80    BSS    0
          LDML   BPD+/BPD/P.IN   BUFFER POOL DESCRIPTOR IN POINTER
          SBDL   PPOUT           COMPARE WITH BPD PP OUT POINTER
          PJN    GCB90       IF LIMIT NOT CROSSED OVER (IF NEXT BUFFER CONTIGUOUS)
          ADML   BPD+/BPD/P.LIMIT   RESTORE AVAILABLE BUFFERS (CM BYTES)

 GCB90    BSS    0
          ERRNZ  16-B.BP     BUFFER POOL ENTRY SIZE NOT 16 CM BYTES
          SHN    -B.BP/4     CONVERT ENTRY SIZE (CM BYTES) TO NUMBER OF BUFFERS
          SBML   BPD+/BPD/P.THRESH   COMPARE WITH THRESHOLD
          PJN    GCB110      IF AVAILABLE BUFFERS .GE. THRESHOLD
          ADML   BUFCNT      NUMBER OF BUFFERS OBTAINED
          MJN    GCB110      IF WE DID NOT VIOLATE THRESHOLD
          LDK    BP.THRSH    BUFFER POOL BELOW THRESHOLD STATUS

*         SET STATUS IN THE RESPONSE.

 GCB100   BSS    0
          STML   RS+/RS/P.BP1ST,BPINDX  SET STATUS

*         UPDATE BUFFER POOL DESCRIPTOR OUT POINTERS AND CLEAR THE BPD LOCK.

 GCB110   BSS    0
 IVB0     IF     DEF,IVB0
          LRDL   CM.BPD
          LDDL   CM.BPD+1
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADC  CM.BPD      ADDRESS OF FIRST POOL DESCRIPTOR
 IVB4     ENDIF
          ADDL   P6          CM WORD OFFSET OF BUFFER POOL DESCRIPTOR
          ADK    /BPD/C.CPUOUT   OFFSET TO BPD CPU OUT POINTER
          CWDL   PPOUT+/BPD/C.PPOUT*4-/BPD/P.PPOUT   NEW BPD CPU OUT POINTER
          ADK    /BPD/C.PPOUT-/BPD/C.CPUOUT   OFFSET TO BPD PP OUT POINTER
          CWDL   PPOUT+/BPD/C.PPOUT*4-/BPD/P.PPOUT   CLEAR THE BPD LOCK
          UJK    GCBX        EXIT
 GRB      SPACE  4,22
**        GRB - GET READ BUFFERS.
*
*         THIS ROUTINE OBTAINS ENOUGH CM BUFFERS FROM THE BUFFER POOLS TO READ
*         A MAXIMUM SIZED CHANNEL CONNECTION (CC) PDU. THE PVA'S AND RMA'S
*         OF THE BUFFERS ARE STORED IN THE PP INTERNAL CACHE (LBUFC AND SBUFC)
*         UNTIL NEEDED ON THE NEXT INPUT.
*
*         ENTRY  (BPCNT,SMINDX) = NUMBER OF SMALL BUFFERS NEEDED (0 OR 1),
*                (BPCNT,LGINDX) = NUMBER OF LARGE BUFFERS NEEDED.
*
*         EXIT   (A) <> 0, IF ENOUGH BUFFERS OBTAINED,
*                    = 0, IF NOT ENOUGH BUFFERS OBTAINED,
*                (INPOK) <> 0, IF ENOUGH BUFFERS OBTAINED,
*                       = 0, IF NOT ENOUGH BUFFERS OBTAINED.
*
*         CALLS  GCB.


 GRB      SUBR               ENTRY/EXIT
          LDN    SMINDX      SMALL BUFFER INDEX
          STDL   BPINDX
          LDML   BPCNT,BPINDX  NUMBER OF SMALL BUFFERS NEEDED (0 OR 1)
          ZJN    GRB10       IF NO SMALL BUFFER NEEDED
          RJM    GCB         GET CM BUFFER
 GRB10    AODL   BPINDX      LARGE BUFFER INDEX
          LDML   BPCNT,BPINDX  LARGE BUFFERS NEEDED
          ZJN    GRB20       IF NO LARGE BUFFERS NEEDED
          RJM    GCB         GET CM BUFFERS
          LDML   BPCNT+LGINDX  LARGE BUFFERS NEEDED
 GRB20    ADML   BPCNT+SMINDX  SMALL BUFFERS NEEDED
          ZJN    GRB30       IF ENOUGH BUFFERS OBTAINED
          LDN    0
          UJN    GRB40

 GRB30    LDN    /STATP/K.INPOK
 GRB40    STDL   INPOK       SET INPUT OK FLAG
          UJN    GRBX        EXIT
 GUR      SPACE  4,16
**        GUR - GET UNIT REQUEST.
*
*         THIS ROUTINE WILL GET THE NEXT REQUEST ON A
*         UNIT QUEUE.
*
*         ENTRY  (CM.URQ) = REFORMATTED ADDRESS OF UNIT
*                           QUEUE TO SEARCH.
*
*         EXIT   (A) = 0, IF NO REQUESTS TO PROCESS,
*                    <> 0, IF REQUEST TO PROCESS.
*                RQ = UNIT REQUEST.
*
*         USES   P1 - P4, T2, WC.
*


 GUR      SUBR               ENTRY/EXIT

*         GET THE FIRST WORD ADDRESS OF THE NEXT UNIT REQUEST.

 IVB0     IF     DEF,IVB0
          LRDL   CM.URQ      CM ADDRESS OF UNIT REQUEST QUEUE
          LDDL   CM.URQ+1
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADC  CM.URQ      CM ADDRESS OF UNIT REQUEST QUEUE
 IVB4     ENDIF
          ERRNZ  /UQD/C.HEAD OFFSET TO UNIT QUEUE HEAD POINTER IS NOT ZERO
*         ADN    /UQD/C.HEAD OFFSET TO UNIT QUEUE HEAD POINTER
          CRDL   P1          READ UNIT QUEUE HEAD POINTER
          LDDL   P1+/UQD/P.HEAD  RMA OF NEXT QUEUED UNIT REQUEST
          ADDL   P1+/UQD/P.HEAD+1
          ZJN    GURX        IF NO UNIT REQUESTS

*         CHECK THAT THE UNIT REQUEST WILL FIT IN PP MEMORY.

          LDDL   P1+/UQD/P.LEN  REQUEST LENGTH (CM BYTES)
          SHN    -3          REQUEST LENGTH (CM WORDS)
          STDL   WC
          SBN    MAXURQ+1    COMPARE WITH MAX UNIT REQUEST SIZE
          PJN    *           IF REQUEST TOO BIG FOR PP MEMORY  --HANG--

*         READ THE UNIT REQUEST.

 IVB0     IF     DEF,IVB0
          LRDL   P1+/UQD/P.HEAD
          LDDL   P1+/UQD/P.HEAD+1
          SHN    -3
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADF  P1+/UQD/P.HEAD  CM ADDRESS OF THE NEXT REQUEST
 IVB4     ENDIF
          CRML   RQ,WC       READ UNIT REQUEST

*         SAVE PVA OF UNIT REQUEST IN RESPONSE.

          LDML   RQ+/URQ/P.THISPV   PVA OF THE UNIT REQUEST
          STML   RS+/RS/P.PVA       PVA OF THE RESPONSE
          LDML   RQ+/URQ/P.THISPV+1  PVA OF THE UNIT REQUEST
          STML   RS+/RS/P.PVA+1     PVA OF THE RESPONSE
          LDML   RQ+/URQ/P.THISPV+2  PVA OF THE UNIT REQUEST
          STML   RS+/RS/P.PVA+2     PVA OF THE RESPONSE

*         SAVE RMA OF UNIT REQUEST IN RESPONSE.

          LDDL   P1+/UQD/P.HEAD  RMA OF THE UNIT REQUEST
          STML   RS+/RS/P.REQ  RMA OF THE RESPONSE
          LDDL   P1+/UQD/P.HEAD+1
          STML   RS+/RS/P.REQ+1
          LCN    0
          UJK    GURX        EXIT
          SPACE  4,10
**        IBC - INITIALIZE BUFFER CACHE.
*
*         THIS ROUTINE WILL DETERMINE THE NUMBER OF
*         BUFFERS THE PP NEEDS TO MAINTAIN IN ITS
*         CACHE. THIS NUMBER IS BASED ON THE MAXIMUM
*         CCPDU SIZE AND CM BUFFER SIZE.
*
*         ENTRY  (MAXPDU) = MAXIMUM CCPDU SIZE,
*                (BPSIZE) = ARRAY OF CM BUFFER SIZES.
*
*         EXIT   (BPCNT - BPCNT+1) = NUMBER OF BUFFERS NEEDED
*                                    IN CACHE.
*

 IBC      SUBR               ENTRY/EXIT
          LDN    0
          STML   BPCNT+LGINDX  INITIALIZE LARGE BUFFER COUNT
          LDML   MAXPDU
          SBN    1           MAX CCPDU SIZE - 1
          SBML   BPSIZE+SMINDX  SMALL BUFFER SIZE
          MJN    IBC20       IF ONLY 1 SMALL BUFFER NEEDED
 IBC10    STDL   T1
          AOML   BPCNT+LGINDX  INCREMENT LARGE BUFFER COUNT
          LDDL   T1
          SBML   BPSIZE+LGINDX  LARGE BUFFER SIZE
          PJN    IBC10       IF MORE LARGE BUFFERS NEEDED
 IBC20    LDML   BPCNT+LGINDX
          STML   MAXLRG      MAXIMUM NUMBER OF LARGE BUFFERS NEEDED FOR INPUT
          SBN    MAXLBUF+1   MAXIMUM NUMBER OF LARGE BUFFERS SUPPORTED +1
          PJN    IBC30       IF UNSUPPORTED
          LDN    1
          STML   BPCNT+SMINDX  ONE SMALL BUFFER
          UJN    IBCX        EXIT

 IBC30    LDN    MAXLBUF     MAXIMUM LARGE BUFFERS SUPPORTED
          STML   LRS+/RS/P.EDATA  PLACE IN LOG MESSAGE
          LDML   MAXLRG      MAXIMUM LARGE BUFFERS REQUIRED
          STML   LRS+/RS/P.ADATA  PLACE IN LOG MESSAGE
          LDC    E230        BUFFER REQUIREMENTS EXCEED MAXIMUM
          RJM    PPE         PROCESS PROTOCOL ERROR (NO RETURN)
 ICF      SPACE  4,20
**        ICF - ISSUE CHANNEL FUNCTION.
*
*         THE PURPOSE OF THIS ROUTINE IS TO FUNCTION THE IPI ADAPTOR
*         AND TIMEOUT THE ACTIVE CHANNEL.
*
*         *************************************************************
*         * NOTE: THIS ROUTINE DOES NOT RETURN TO ITS CALLER IF       *
*         *       AN UNRECOVERED ERROR OCCURS. RATHER IT RETURNS TO   *
*         *       THE MAIN LOOP.                                      *
*         *************************************************************
*
*         ERROR RECOVERY ON FUNCTION TIMEOUT IS HANDLED AS FOLLOWS.
*         1. ALL FUNCTIONS ARE RETRIED UP TO TWO MORE TIMES.
*         2. ALL FUNCTION TIMEOUTS ARE LOGGED.
*         3. IF THE FUNCTION FAILS, THE IVB IS DOWNED.
*
*         ENTRY  (A) = FUNCTION CODE.
*
*         USES T1.
*
*         CALLS  GAR, CFH.


 ICF      SUBR               ENTRY/EXIT
          STDL   LF          SAVE FUNCTION CODE
          STML   FBUF,FI     STORE IN TABLE
          AODL   FI          INDEX INTO FUNCTION HISTORY TABLE
          LPN    7
          STDL   FI
          LDN    RRL
          STDL   T1          RETRY COUNTER
          DCN    CH+40B      ENSURE CHANNEL IS INACTIVE
 ICF10    LDDL   LF
          FAN    CH          ISSUE FUNCTION
 ICF20    LDC    FTOLEN*1000 LOOP IS ONE MILLISECOND
 ICF30    IJM    ICF80,CH
          SBN    1
          SHN    18          NO OP TO LENGTHEN LOOP
          NJN    ICF30       IF TIMEOUT NOT EXPIRED
 ICF40    BSS    0
          DCN    CH+40B
          CFM    ICF70,CH    CLEAR CHANNEL ERROR FLAG
 ICF50    BSS    0
          LDDL   T1
          SBN    RRL
          NJN    ICF60       IF NOT FIRST ERROR
          LDC    ICFER
          RJM    GAR         READ REGISTERS
 ICF60    RJM    CER         CLEAR ERRORS
 ICF70    SODL   T1          DECREMENT RETRY COUNTER
          ZJK    ICF110      IF UNRECOVERED ERROR
          UJK    ICF10       RETRY FUNCTION

 ICF80    LDDL   T1
          SBN    RRL
          ZJN    ICF100      EXIT IF NO ERRORS
 ICF90    SRU    ICFER,T1,REC.R
          LDK    E01         FUNCTION TIMEOUT ERROR
          STML   ICFER+/ILD/P.SCODE  STORE ERROR ID
          LDC    ICFER
          RJM    CEP         COMMON ERROR PROCESSOR (NO RETURN IF DOWN)
 ICF100   UJK    ICFX        EXIT

 ICF110   LDN    PS.HLT      DOWN IVB
          STDL   PPSTATE
          UJK    ICF90       LOG ERROR
 IIR      SPACE  4,10
**        IIR - ISSUE INTERFACE RESET.
*
*         THIS ROUTINE WILL ISSUE EITHER A LOGICAL OR
*         PHYSICAL INTERFACE RESET TO THE IVB.
*
*         ENTRY  (A) = FUNCTION.
*                8215 FOR LOGICAL RESET.
*                8415 FOR PHYSICAL RESET.
*
*         USES   P2.
*
*         CALLS  ICF, MCC.
*
*         MACROS PAUSE.


 IIR      SUBR               ENTRY/EXIT
          STDL   P2
          RJM    MCC         MASTER CLEAR CHANNEL
          LDC    **          SLAVE ADDRESS
 IIRA     EQU    *-1
          SHN    12
          ADDL   P2
          RJM    ICF         SET MASTER OUT
          PAUSE  20
          LDDL   LF          LAST FUNCTION ISSUED
          LMN    0#15&0#17
          RJM    ICF         SET SYNC OUT
          PAUSE  10
          LDDL   LF
          LMN    0#17&0#15
          RJM    ICF         DROP SYNC OUT
          LDDL   LF
          LMN    0#15&0#11
          RJM    ICF         DROP MASTER OUT
          UJK    IIRX        EXIT
 ILM      SPACE  4,12
**        ILM - INITIALIZE LOG MESSAGE.
*
*         THIS ROUTINE IS CALLED TO INITIALIZE A LOG BUFFER.
*         THE BUFFER IS ZEROED AND THE KIND FIELD IS SET UNRECOVERED.
*
*         ENTRY  (A) = PP ADDRESS OF ERROR INFO BUFFER.
*
*         USES   T7, T8.


 ILM      SUBR               ENTRY/EXIT
          ADN    P.ILD-1
          STDL   T7
          LDN    P.ILD-1
          STDL   T8
 ILM10    LDN    0
          STML   0,T7        CLEAR LOG BUFFER
          SODL   T7
          SODL   T8
          PJN    ILM10       IF NOT DONE
          LDN    REC.U
          STML   /ILD/P.ERRK+1,T7  INITIALIZE TO UNRECOVERED
          UJK    ILMX        EXIT
 ILR      SPACE  4,10
**        ILR - ISSUE LOGICAL RESET.
*
*         THIS ROUTINE WILL ISSUE A LOGICAL RESET
*         TO THE DEVICE.
*
*         ENTRY  (DSTATE) = DS.ILR
*
*         EXIT   (DSTATE) = DS.NRDY OR DS.WNRA.
*
*         CALLS  IIR, DGU.


 ILR      SUBR
          RJM    PFR         PAUSE FOR RECOVERY
          LDC    H8215       LOGICAL INTERFACE RESET
          RJM    IIR         ISSUE RESET
          RJM    DGU         DEVICE GONE UNAVAILABLE
          LDN    0
          STML   SLREC
          UJK    ILRX        EXIT
 IML      SPACE  4,10
**        IML - INITIALIZE MAIN LOOP
*
*         THIS ROUTINE WILL INITIALIZE VARIABLES THAT
*         MAY NEED NITIALIZATION ON ENTRY TO THE MAIN LOOP.
*


 IML      SUBR
          LDC    C.RS*8
          STML   LRS+/RS/P.RESPL  SET LENGTH
          LDN    URC.LOG
          STML   LRS+/RS/P.URC  SET LOG MESSAGE
          LDC    LRS+/RS/P.SCODE
          RJM    ILM         INITIALIZE BUFFER
          LDC    OTHERR
          RJM    ILM         INITIALIZE BUFFER
          LDC    CRERR
          RJM    ILM         INITIALIZE BUFFER
          LDC    ICFER
          RJM    ILM         INITIALIZE BUFFER
          LDC    IOERR
          RJM    ILM         INITIALIZE BUFFER
          UJK    IMLX        EXIT
 IMS      SPACE  4,13
**        IMS - INCLUDE MASTER STATUS.
*
*         THIS ROUTINE SETS MASTER STATUS INTO THE
*         RESPONSE BUFFER AND SETS THE MASTER
*         STATUS INCLUDED BIT IN THE RESPONSE.
*
*         ENTRY  (A) = ADDRESS OF RESPONSE DATA BUFFER.
*                (MSTAT) = COPY OF MASTER STATUS.
*
*         USES   T6, T7, T8.


 IMS      SUBR               ENTRY/EXIT
          STDL   T8
          LDC    /ILD/K.LMS
          STDL   T6
          LMC    -0
          STDL   T7
          LDML   /ILD/P.LMS,T8  STATUS FLAGS
          LPDL   T7
          ADDL   T6          ADD MASTER STATUS
          STML   /ILD/P.LMS,T8
          LDML   MSTAT
          STML   /ILD/P.MSTAT,T8
          UJN    IMSX        EXIT
 IRC      SPACE  4,10
**        IRC - INITIALIZE RESPONSE CODES.
*
*         THIS ROUTINE INITIALIZES THE RESPONSE CODE
*         VARIABLES IN PREPERATION FOR THE NEXT RESPONSE.
*

 IRC      SUBR               ENTRY/EXIT
          LDN    0
          STML   UNSC        UNSOLICITED RESPONSE CODE
          STML   RESPC       RESPONSE CODE
          LDN    RC.NODS     NO DETAILED STATUS
          STML   RCON        RESPONSE CONDITION CODE
          UJN    IRCX        EXIT
 IRP      SPACE  4,10
**        IRP - INITIALIZE REQUEST PROCESSING.
*
*         INITIALIZES A PERIPHERAL RESPONSE TEMPLATE, AND ESTABLISHES
*         THE ENVIRONMENT FOR REQUEST PROCESSING.  TERMINATION MAY BE
*         REFLECTED THROUGH A PERIPHERAL RESPONSE AFTER THE RESPONSE
*         IS INITIALIZED.
*
*         ENTRY  (RQ) = PERIPHERAL REQUEST BEING PROCESSED.
*
*         EXIT   (RS) = RESPONSE AREA FOR RESPONSE.


 IRP      SUBR           ENTRY/EXIT
          LDML   RQ+/RQ/P.RECOV  RECOVER, INTERRUPT, PORT, PRIORITY
          LPC    177400B
          LMML   DEVID
          STML   RS+/RS/P.RECOV
          LDN    /RS/C.XFER*8+8  SET RESPONSE LENGTH FOR NORMAL RESPONSE
          STML   RS+/RS/P.RESPL
          LDN    R.NRM       SET RESPONSE CODE = NORMAL
          STML   RESPC
          UJK    IRPX        EXIT
 ISS      SPACE  4,13
**        ISS - INCLUDE SLAVE STATUS.
*
*         THIS ROUTINE SETS SLAVE STATUS INTO THE
*         RESPONSE BUFFER AND SETS THE SLAVE
*         STATUS INCLUDED BIT IN THE RESPONSE.
*
*         ENTRY  (A) = ADDRESS OF RESPONSE DATA BUFFER.
*                (STATUS) = COPY OF SLAVE STATUS.
*
*         USES   T6, T7, T8.


 ISS      SUBR               ENTRY/EXIT
          STDL   T8
          LDC    /ILD/K.LSS
          STDL   T6
          LMC    -0
          STDL   T7
          LDML   /ILD/P.LMS,T8  STATUS FLAGS
          LPDL   T7
          ADDL   T6          ADD MASTER STATUS
          STML   /ILD/P.LMS,T8
          LDDL   STATUS
          STML   /ILD/P.SSTAT,T8
          UJN    ISSX        EXIT
 LAM      SPACE  4,12
**        LAM - LOG AVAILABILITY MESSAGE.
*
*         THIS ROUTINE WILL LOG A MESSAGE INDICATING THE
*         AVAILABILITY OF THE IVB.
*
*         ENTRY  (AVAIL) = 0 IF DEVICE RESET.
*                        <> 0 IF DEVICE AVALABLE.
*
*         CALLS  SLM.


 LAM      SUBR               ENTRY/EXIT
          LDML   AVAIL
          ZJN    LAM10       IF NOT AVAILABLE
          LDML   IPIVER
          SHN    8
          ADML   CCVER
          STML   LRS+/RS/P.ADATA
          LDML   MAXPDU
          STML   LRS+/RS/P.EDATA
          LDN    E40
          UJN    LAM20       CONTINUE

 LAM10    LDN    E41
 LAM20    STML   LRS+/RS/P.SCODE
          LDN    REC.IM
          STML   LRS+/RS/P.ERRK
          RJM    SLM         SEND LOG MESSAGE
          UJN    LAMX        EXIT
 MCC      SPACE  4,10
**        MCC - MASTER CLEAR CHANNEL.
*
*         THIS ROUTINE RE-INITIALIZES THE CHANNEL BY ISSUING A MASTER CLEAR.
*         THE MASTER CLEAR IS ISSUED TWICE BECAUSE THE FIRST MASTER CLEAR
*         MAY RESULT IN A SEQUENCER ERROR IF ILLEGAL STATE CHANGES OCCUR AS
*         CONTROL LINES ARE DROPPED.
*
*         CALLS  ICF.
*
*         MACROS PAUSE.


 MCC      SUBR
 IVB0     IF     DEF,IVB0
          MCLR   CH
          PAUSE  100         ALLOW CONTROLLER TIME TO DROP LINES
          MCLR   CH
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LDN    H0000       MASTER CLEAR CHANNEL
          RJM    ICF
          PAUSE  100         ALLOW CONTROLLER TIME TO DROP LINES
          LDN    H0000       MASTER CLEAR CHANNEL
          RJM    ICF
 IVB4     ENDIF
          PAUSE  1
          LDC    H7E42       SET IPI CHANNEL TRANSFER RATE
          RJM    ICF
 IVB4     IF     DEF,IVB4
          LDC    H0062       SET PORT NUMBER
 MCCA     EQU    *-1         (PORT NUMBER)
          RJM    ICF
 IVB4     ENDIF
          UJK    MCCX        EXIT
 MCH      SPACE  4,16
**        MCH - MOVE CC HEADER.
*
*         THIS ROUTINE TRANSFERS THE CHANNEL CONNECTION (CC)
*         HEADER TO CM BUFFERS.
*
*         ENTRY  (A) = PP ADDRESS OF CC HEADER,
*                (CML) = 0, OFFSET TO FIRST BUFFER LENGTH/ADDRESS PAIR,
*                (BPRMA+/BPR/P.LENGTH) = NUMBER OF BYTES TO TRANSFER TO BUFFER.
*
*         EXIT   (CML) = OFFSET OF CURRENT BUFFER LENGTH/ADDRESS PAIR,
*                 CC HEADER TRANSFERRED TO CM BUFFER(S).
*
*         USES   T1, WC.
*


 MCH      SUBR               ENTRY/EXIT
          STML   MCHA
          LDN    B.CCP-/CCP/B.PARML-/CCP/B.PARMID  CC HEADER LENGTH
          STDL   BYTS        NUMBER OF BYTES TO TRANSFER TO CM
 MCH10    BSS    0
          LDML   BPRMA+/BPR/P.LENGTH,CML  LENGTH OF BUFFER
          STDL   BUFLEN
          SBDL   BYTS        BYTES TO TRANSFER TO CM
          PJN    MCH20       IF ROOM IN CM BUFFER FOR ALL
          LDDL   BUFLEN
          UJN    MCH30

 MCH20    BSS    0
          LDDL   BYTS

 MCH30    STDL   T1          BYTES TO TRANSFER
          SHN    -3          CONVERT TO CM WORDS
          STDL   WC
 IVB0     IF     DEF,IVB0
          LRML   BPRMA+/BPR/P.RMA,CML
          LDML   BPRMA+/BPR/P.RMA+1,CML  ADDRESS OF BUFFER
          SHN    -3
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADF  BPRMA+/BPR/P.RMA,CML  ADDRESS OF BUFFER
 IVB4     ENDIF
          CWML   **,WC
 MCHA     EQU    *-1
          LDDL   T1          BYTES TRANSFERRED
          RAML   BPRMA+/BPR/P.RMA+1,CML  UPDATE CM BUFFER ADDRESS
          SHN    -16
          RAML   BPRMA+/BPR/P.RMA,CML
          LDDL   BUFLEN      SPACE IN BUFFER
          SBDL   T1          BYTES TRANSFERRED
          STML   BPRMA+/BPR/P.LENGTH,CML  SPACE REMAINING IN BUFFER
          LDDL   BYTS
          SBDL   T1
          STDL   BYTS        UPDATE REMAINING BYTES IN PP
          ZJN    MCH50       IF ENTIRE CC HEADER TRANSFERRED

*         ONLY 8 OF THE 16 BYTES OF THE CC HEADER WERE TRANSFERRED
*         IN THE FIRST WRITE. SETUP TO TRANSFER THE REMAINING 8 BYTES.

          LDN    4
          RAML   MCHA        UPDATE PP TRANSFER ADDRESS
          LDN    P.BPR
          RADL   CML         NEXT LENGTH/ADDRESS PAIR
          UJK    MCH10       TRANSFER REMAINDER OF CC HEADER

 MCH50    BSS    0
          STML   RS+/RS/P.XFER
          LDN    B.CCP-/CCP/B.PARML-/CCP/B.PARMID
          STML   RS+/RS/P.XFER+1  SETUP TRANSFER COUNT IN RESPONSE
          UJK    MCHX        EXIT
 OWC      SPACE  4,20
**        OWC - OUTPUT WRITE COMMAND.
*
*         THIS ROUTINE WILL CREATE AND OUTPUT THE WRITE COMMAND PACKET.
*
*         ENTRY  RQ = UNIT REQUEST.
*
*         EXIT   (A) = 0 IF NO ERRORS.
*                    <> 0 IF ERRORS.
*                BYTCNT = BYTES SENT WITH COMMAND.
*                BYTS = NUMBER OF BYTES SENT FROM CURRENT BUFFER.
*                CML = CURRENT CM LIST INDEX.
*                CMLISTL = NUMBER OF CM LENGTH/ADDRESS PAIRS.
*                P6 = OFFSET TO CURRENT RMA/ADDRESS PAIR.
*
*         USES   P6.
*
*         CALLS  PPE, SCP, SUR.


 OWC      SUBR               ENTRY/EXIT
 OWC10    LDN    0
          STDL   CML         CURRENT CM LIST INDEX
          STML   BYTCNT
          LDML   RQ+/URQ/P.URQLEN  LENGTH OF REQUEST
          SBN    /URQ/C.MBRMA*8    MINUS FIXED LENGTH PART
          SHN    -3          TO CM WORDS
          STML   CMLISTL     NUMBER OF CM LENGTH/ADDRESS PAIRS

*         GENERATE IPI COMMAND PACKET.

          LDK    B.IP+B.CCP-/IP/B.LEN  PACKET WRITE CMD LENGTH
          STML   CPBF+/IP/P.LEN
          LDC    O.WR+0#80    PACKET WRITE COMMAND
          STML   CPBF+/IP/P.OPCODE
          LDK    B.CCP-/CCP/B.PARML  LENGTH OF THIS PARAMETER
          SHN    8           POSITION TO PARAMETER LENGTH
          LMC    PID.CC      MOVE IN PARAMETER ID
          STML   CPBF+P.IP+/CCP/P.PARML
          LDN    B.CCP-/CCP/B.PARML-/CCP/B.PARMID
          STDL   TBYTS       SET TOTAL TRANSFER SIZE FOR HEADER
 OWC20    LDDL   CML         CURRENT CM LIST INDEX
          SHN    2           CONVERT TO PP WORD OFFSET
          STDL   P6          OFFSET TO NEXT CM LENGTH/ADDRESS PAIR
          LDML   RQ+/URQ/P.MBLEN,P6  DATA LENGTH IN BUFFER
          SBDL   TBYTS       LESS BYTES REMAINING IN CCP HEADER
          PJN    OWC30       IF COMPLETE HEADER IN THIS FRAGMENT
          ADDL   TBYTS
          UJN    OWC40       MOVE PARTIAL HEADER FROM THIS BUFFER

 OWC30    LDDL   TBYTS       USE BYTES IN HEADER
 OWC40    STML   BYTS
          SHN    -3          CONVERT TO CM WORDS
          STDL   WC
          LDML   BYTCNT      PROGRESSIVE COUNT
          SHN    -1          CONVERT TO PP WORDS
          ADC    CPBF+P.IP+/CCP/P.KIND  CALCULATE NEXT POSITION
          STML   OWCA
 IVB4     IF     DEF,IVB4
          LOADF  RQ+/URQ/P.MBRMA,P6  REFORMAT CM ADDRESS
 IVB4     ENDIF
 IVB0     IF     DEF,IVB0
          LRML   RQ+/URQ/P.MBRMA,P6     UPPER PORTION OF ADDRESS OF BUFFER
          LDML   RQ+/URQ/P.MBRMA+1,P6   LOWER PORTION OF ADDRESS OF BUFFER
          SHN    -3          FORM WORD ADDRESS
 IVB0     ENDIF
          CRML   **,WC       READ CCP HEADER INTO COMMAND BUFFER
 OWCA     EQU    *-1
          LDML   BYTS        BYTES READ
          RAML   BYTCNT      BUMP PROGRESSIVE COUNT
          LDDL   TBYTS
          SBML   BYTS        DECREMENT BYTES READ
          ZJN    OWC50       IF HEADER READ
          STDL   TBYTS       SET REMAINING BYTES TO TRANSFER
          AODL   CML
          SBML   CMLISTL
          NJK    OWC20       CONTINUE IF MORE TO READ IN HEADER
          LDK    E301        CCPDU HEADER TOO SMALL
          RJM    PPE         PROCESS INTERFACE ERROR (NO RETURN)

 OWC50    RJM    SCP         SEND COMMAND PACKET TO SLAVE
          ZJK    OWCX        EXIT
          RJM    ALC         ABORT LAST COMMAND
          NJK    OWCX        IF ERRORS EXIT
          SOML   RTCNT
          NJK    OWC10       IF RETRIES REMAINING
          LDN    DS.ILR
          STDL   DSTATE
          UJK    OWCX        ERROR EXIT
 PAUS     SPACE  4,10
**        PAUS - WAIT FOR N MICROSECONDS.
*
*         ENTRY  (A) = NUMBER OF MICROSECONDS.
*
*         EXIT   (A) = 0.
*
*         USES   T1.


 PAUS     SUBR
 PAUS10   SBN    1           EACH ITERATION OF THIS LOOP
          STDL   T1           IS ONE MICROSECOND
 IVB0     IF     DEF,IVB0
          STDL   T1
          STDL   T1
 IVB0     ENDIF
          NJN    PAUS10
          UJK    PAUSX       EXIT
 PFR      SPACE  4,10
**        PFR - PAUSE FOR RECOVERY.
*
*         THIS ROUTINE WILL PAUSE THE REQUIRED AMOUNT
*         OF TIME NEEDED IN RECOVERY TO ALLOW THE IVB
*         TO RESET ANY HARDWARE.


 PFR      SUBR
          PAUSE  177777B
          PAUSE  177777B
          PAUSE  177777B
          PAUSE  177777B
          UJK    PFRX        EXIT
 PIM      SPACE  4,10
**        PIM - PROCESS INPUT MESSAGE.
*
*         THIS ROUTINE PROCESSES ALL INPUT WHEN THE IVB
*         IS IN SERVICE. THERE ARE THREE POSSIBLE RESPONSES
*         THAT MAY BE RECEIVED: NOOP, PACKET READ AND REPORT
*         STATUS.
*
*         ENTRY  (IP) <> 0, INPUT IS PENDING.
*
*         EXIT   (A) = 0 IF NO ERRORS.
*                    <> 0 IF ERRORS.
*
*         USES   P2.
*
*         CALLS  PNO, PPE, PRR, PRS, RRP.


 PIM      SUBR               ENTRY/EXIT
          LDN    RRL
          STML   RTCNT
 PIM10    RJM    RRP         READ RESPONSE PACKET
          ZJN    PIM30       IF NO ERRORS
          PJN    PIM20       IF IVB SAW ERROR
          RJM    ACR         ABORT CURRENT COMMAND
          NJN    PIMX        IF ERRORS EXIT
 PIM20    SOML   RTCNT
          NJK    PIM10       IF NOT UNRECOVERED
          LDN    DS.ILR
          STDL   DSTATE
          UJK    PIMX        EXIT

 PIM30    LDML   RPBF+/IP/P.OPCODE  RESPONSE OPCODE
          LMK    O.READ
          NJN    PIM40       IF NOT READ RESPONSE
          LDDL   INPOK
          ZJN    PIM70       IF GLOBAL FLOW CONTROL ON
          RJM    PRR         PROCESS READ RESPONSE
          ZJK    PIMX        EXIT IF NO ERRORS
          DPM    RPSEQ       DECREMENT SEQUENCE NUMBER
          UJK    PIM20       IF ERRORS

 PIM40    LMK    O.READ&O.RSTAT
          NJN    PIM60       IF NOT REPORT STATUS RESPONSE
          RJM    PRS         PROCESS REPORT STATUS RESPONSE
 PIM50    UJK    PIMX        EXIT

 PIM60    LMK    O.RSTAT&O.NOOP
          NJN    PIM70       IF INVALID RESPONSE
          RJM    PNO         PROCESS NO-OP RESPONSE
          UJN    PIM50

 PIM70    LDML   RPBF+/IP/P.OPCODE  RESPONSE OPCODE
          STML   LRS+/RS/P.OPCD  PLACE ILLEGAL OPCODE IN LOG MESSAGE
          LDC    E205        ILLEGAL IPI RESPONSE OPCODE
          RJM    PPE         PROCESS PROTOCOL ERROR (NO RETURN)

 PNO      SPACE  4,10
**        PNO - PROCESS NO-OP RESPONSE.
*
*         THERE IS NO PROCESSING INVOLVED WITH THE
*         NO-OP RESPONSE. THIS ROUTINE IS A NO-OP.
*
*         EXIT   (A) = 0.
*

 PNO      SUBR               ENTRY/EXIT
          LDN    0
          UJN    PNOX        EXIT
 PGS      SPACE  4,10
**        PGS - PROCESS GLOBAL STATUS.
*
*         THIS ROUTINE PROCESSES THE GLOBAL FLOW CONTROL STATUS
*         PARAMETER RECEIVED AS PART OF A 'REPORT STATUS' OR
*         'READ PACKET' RESPONSE.
*
*         ENTRY  (A) = OFFSET OF GLOBAL FLOW CONTROL PARAMETER ADDRESS
*                      IN RESPONSE BUFFER (RPBF).
*
*         EXIT   (IP) AND (SNDOK) UPDATED WITH CURRENT STATUS.
*
*         USES   T2.
*
*         CALLS  PPE, UGS.


 PGS      SUBR               ENTRY/EXIT
          STDL   T2          ADDRESS OF PARAMETER
          LDML   RPBF+/STATP/P.PARML,T2
          SHN    -8          PARAMETER LENGTH-1
          SBN    B.STATP-/STATP/B.PARML
          NJN    PGS10       IF INVALID PARAMETER LENGTH
          LDML   RPBF+/STATP/P.STATUS,T2  GLOBAL FLOW CONTROL STATUS
          SHN    -8          POSITION STATUS BYTE IN LOWER 8 BITS
          RJM    UGS         UPDATE GLOBAL FLOW CONTROL STATUS
          UJN    PGSX        EXIT

 PGS10    LDC    PID.GFC     GLOBAL FLOW CONTROL STATUS PARAMETER ID
          STML   LRS+/RS/P.PID  PLACE PARAMETER ID IN LOG MESSAGE
          LDML   RPBF+/STATP/P.PARML,T2
          STML   LRS+/RS/P.ADATA  PLACE INVALID PARAMETER LENGTH IN LOG MESSAGE
          LDC    E201        INVALID PARAMETER LENGTH
          RJM    PPE         PROCESS PROTOCOL ERROR (NO RETURN)
          SPACE  4,10
**        PPE - PROCESS PROTOCOL ERROR.
*
*         THIS ROUTINE IS TO BE CALLED WHEN A DEVICE OR CPU
*         PROTOCOL ERROR HAS BEEN DETECTED. THE ERROR IS LOGGED
*         AND THE DEVICE RESET OR DOWNED DEPENDING ON THE ERROR
*         ENCOUNTERED.
*
*       *********************************************************
*       * NOTE: THIS ROUTINE DOES NOT RETURN TO ITS CALLER,     *
*       *       RATHER THE MAIN CONTROL LOOP IS ENTERED.        *
*       *********************************************************
*
*         ENTRY  (A) = PROTOCOL ERROR CODE.
*
*         EXIT   PROCESSING RESUMES AT *MCL* (MAIN CONTROL LOOP).
*
*         CALLS  CFH, SLM.


 PPE      SUBR               ENTRY/EXIT
          STML   LRS+/RS/P.SCODE  PROTOCOL ERROR CODE
          ADC    -E300
          MJN    PPE10       IF IN RANGE (E200 - E299)
          LDN    PS.HLT
          STDL   PPSTATE     PP STATE = HALTED
 PPE10    LDC    LRS+/RS/P.SCODE
          RJM    CFH         COPY FUNCTION HISTORY
          LDML   PPE         P-ADDRESS OF WHERE CALLED FROM
          STML   LRS+/RS/P.RES0  RESERVED WORD 0
          RJM    SLM         SEND LOG MESSAGE
          LDN    DS.ILR      ISSUE LOGICAL RESET
          STDL   DSTATE      CHANGE DEVICE STATE
          LJM    MCL         ENTER MAIN CONTROL LOOP
 PRB      SPACE  4,10
**        PRB - PREPARE RESPONSE BUFFER.
*
*         THIS ROUTINE PREPARES THE PP RESPONSE BUFFER
*         FOR THE ISSUING OF A RESPONSE BY SETTING UP
*         SPECIFIC RESPONSE CODE FIELDS.
*
*         ENTRY  RS = PP RESPONSE BUFFER,
*


 PRB      SUBR
          LDML   RESPC       RESPONSE CODE
          SHN    /RS/L.RCON-/RS/L.RC+/RS/N.RCON-/RS/N.RC
          ADML   RCON        RESPONSE CONDITION
          SHN    /RS/L.URC-/RS/L.RCON+/RS/N.URC-/RS/N.RCON
          ERRNZ  /RS/P.URC-/RS/P.RCON
          ERRNZ  /RS/P.RC-/RS/P.URC
          ADML   UNSC        UNSOLICITED RESPONSE CODE
          STML   RS+/RS/P.URC
          UJK    PRBX        EXIT
 PRP      SPACE  4,15
**        PRP - PROCESS READ PACKET.
*
*         THIS ROUTINE WILL PROCESS THE CC PARAMETER
*         ASSOCIATED WITH THE READ PACKET RESPONSE AND
*         PERFORM A DATA READ IF REQUIRED. THE DATA WILL
*         BE PLACED IN CM BUFFERS AND A CPU RESPONSE
*         GENERATED UPON SUCCESSFUL COMPLETION.
*
*         ENTRY  (P1) = OFFSET OF CC PARAMETER IN RESPONSE BUFFER (RPBF).
*
*         EXIT   (A) = 0 IF NO ERRORS.
*                    <> 0 IF ERRORS.
*
*         CALLS  CEP, ESS, GRB, MCH, PPE, RDD, SFR, SRS, SUR, UGS.



 PRP      SUBR               ENTRY/EXIT
          LDML   RPBF+/CCP/P.PARML,P1
          SHN    -8          PARAMETER LENGTH-1
          SBN    B.CCP-/CCP/B.PARML
          ZJN    PRP10       IF VALID PARAMETER
          LDC    PID.CC      CC PARAMETER ID
          STML   LRS+/RS/P.PID  PLACE IN LOG MESSAGE
          LDML   RPBF+/CCP/P.PARML,P1  PARAMETER LENGTH-1
          STML   LRS+/RS/P.ADATA  PLACE IN LOG MESSAGE
          LDC    E201        INVALID PARAMETER
          RJM    PPE         PROCESS PROTOCOL ERROR (NO RETURN)

*         SET UP RESPONSE IN PREPARATION FOR RETURN OF BUFFERS.

 PRP10    LDN    BP.GOOD     BUFFER POOL CONTAINS A SUFFICIENT NUMBER OF BUFFERS
          STML   RS+/RS/P.BP1ST
          STML   RS+/RS/P.BP2ST
          LDDL   SNDOK       IVB GLOBAL FLOW CONTROL STATUS
          STML   RS+/RS/P.PSEND
          STML   RS+/RS/P.NSEND
          LDML   RPBF+/CCP/P.LEN2,P1
          STDL   TBYTS       TOTAL BYTES TO TRANSFER
          RJM    SFR         SETUP FOR READ
          LDDL   P1          ADDRESS OF CC HEADER
          ADC    RPBF+/CCP/P.KIND
          RJM    MCH         MOVE CC HEADER TO CM BUFFER
          LDDL   TBYTS
          SBN    B.CCP-/CCP/B.PARML-/CCP/B.PARMID  CC HEADER LENGTH
          ZJK    PRP60       IF NO MORE DATA TO TRANSFER
          RJM    RDD         READ DATA
          ZJN    PRP30       IF NO ERRORS
          LDN    0
          UJN    PRP40       SEND UNSUCCESSFUL

 PRP30    LDC    /STATP/K.SUC  SUCCESSFUL STATUS
 PRP40    ADDL   INPOK       GLOBAL FLOW CONTROL
          RJM    ESS         ENDING STATUS SEQUENCE
          ZJN    PRP50       IF STATUS READ WITHOUT ERRORS
          LDML   MSTAT
          STML   RSTAT
          LDML   RPBF+/IP/P.REFNO
          STML   RSEQ
          RJM    RSS         REQUEST SLAVE STATUS

 PRP50    LDDL   STATUS      SLAVE STATUS
          SHN    17-/STATP/SUC
          PJN    PRP90       IF UNSUCESSFUL TRANSFER
          LDDL   STATUS      SLAVE STATUS
          RJM    UGS         UPDATE GLOBAL FLOW CONTROL STATUS
 PRP60    LDN    RC.DS       DETAILED STATUS INCLUDED
          STML   RCON        RESPONSE CONDITION CODE
          RJM    GRB         REPLACE BUFFERS
          LDN    URC.CC      CC READ RESPONSE CODE
          RJM    SUR         SEND UNSOLICITED RESPONSE
          LDDL   INPOK
          ZJN    PRP70       IF INPUT NOT OK
          LDN    0
          UJN    PRP80       EXIT

 PRP70    RJM    SRS         REPORT SATUS

*         SEND TWO NOOP'S TO ASSURE IVB HAD TIME TO CLEAR BUFFER

          RJM    SNO         SEND NO_OP
          RJM    SNO         SEND NO_OP
          LDN    0
 PRP80    UJK    PRPX        EXIT - (A) = 0

 PRP90    SRU    IOERR,RTCNT,REC.I
          LDC    IOERR
          RJM    IMS         INCLUDE MASTER STATUS
          LDC    IOERR
          RJM    ISS         INCLUDE SLAVE STATUS
          LDML   IOERR+/ILD/P.SCODE
          NJN    PRP100      IF PP DETECTED ERROR
          RJM    ASS         ANALYZE SLAVE STATUS
 PRP100   LDC    IOERR
          RJM    CEP         LOG ERROR
          RJM    RIC         RETURN BUFFERS
          LDN    1
          UJK    PRPX        EXIT
 PRR      SPACE  4,10
**        PRR - PROCESS READ RESPONSE.
*
*         THIS ROUTINE PROCESSES READ RESPONSES RECEIVED
*         WHILE THE IVB IS IN SERVICE. A READ RESPONSE
*         WILL CONTAIN A CC PARAMETER (51(16)) AND MAY
*         ALSO CONTAIN A GLOBAL FLOW STATUS PARAMETER (56(16)).
*         ALTHOUGH THESE PARAMETERS MAY APPEAR IN ANY ORDER,
*         THE CC PARAMETER IS ALWAYS PROCESSED LAST.
*
*         ENTRY  (RPBF) = READ RESPONSE.
*
*         EXIT   (A) = 0 IF NO ERRORS.
*                    <> 0 IF ERRORS
*
*         USES   P1, T4.
*
*         CALLS  PGS, PPE, PRP
*

 PRR80    LDML   /CCP/P.PARMID,T4  PARAMETER ID
          STML   LRS+/RS/P.PID  PLACE ILLEGAL PARAMETER ID IN LOG MESSAGE
          LDML   RPBF+/IP/P.OPCODE
          STML   LRS+/RS/P.OPCD  PLACE RESPONSE OPCODE IN LOG MESSAGE
          LDC    E207        ILLEGAL PARAMETER
 PRR90    RJM    PPE         PROCESS PROTOCOL ERROR (NO RETURN)


 PRR      SUBR
          LDN    0
          STDL   P1          ADDRESS OF CC PARAMETER IN RESPONSE
          LDN    P.IP
          STDL   T4          OFFSET OF NEXT PARAMETER IN RESPONSE BUFFER
 PRR10    BSS    0
          SHN    1           CONVERT TO BYTES
          SBML   RPBF+/IP/P.LEN  LENGTH OF RESPONSE-2
          SBN    /IP/B.LEN
          PJN    PRR50       IF NO MORE PARAMETERS
          LDML   RPBF+/CCP/P.PARMID,T4  PARAMETER ID
          LPC    0#0FF
          LMK    PID.CC
          ZJN    PRR40       IF CC PARAMETER
          LMK    PID.GFC&PID.CC
          NJK    PRR80       IF ILLEGAL PARAMETER
          LDDL   T4
          RJM    PGS         PROCESS GLOBAL FLOW CONTROL STATUS PARAMETER
          LDN    P.STATP
 PRR30    RADL   T4          UPDATE TO NEXT PARAMETER
          UJN    PRR10

 PRR40    LDDL   T4
          STDL   P1          SAVE CC PARAMETER ADDRESS
          LDN    P.CCP
          UJN    PRR30

*         PROCESS CC PARAMETER

 PRR50    BSS    0
          LDDL   P1          CC PARAMETER ADDRESS
          ZJN    PRR70       IF CC PARAMETER NOT PRESENT
          RJM    PRP         PROCESS READ PACKET
          UJK    PRRX        EXIT

 PRR70    BSS    0
          LDML   RPBF+/IP/P.LEN  LENGTH OF RESPONSE-2
          STML   LRS+/RS/P.ADATA  PLACE RESPONSE LENGTH IN LOG MESSAGE
          LDC    E200        INVALID RESPONSE - NO CC PARAM ON READ
          UJK    PRR90
 PRS      SPACE  4,12
**        PRS - PROCESS REPORT STATUS.
*
*         THIS ROUTINE PROCESSES THE 'REPORT STATUS'
*         RESPONSE. THE 'REPORT STATUS' RESPONSE CONTAINS
*         ONE PARAMETER, NAMELY THE GLOBAL FLOW CONTROL
*         PARAMETER.
*
*         ENTRY  (RPBF) = REPORT STATUS RESPONSE.
*
*         CALLS  PGS, PPE.
*

 PRS      SUBR               ENTRY/EXIT
          LDML   RPBF+/IP/P.LEN
          SBN    B.IP+B.STATP-/IP/B.LEN  EXPECTED RESPONSE LENGTH
          NJN    PRS10       IF INVALID IPI RESPONSE
          LDN    P.IP        OFFSET OF GFC PARAMETER IN RESPONSE BUFFER
          RJM    PGS         PROCESS GLOBAL FLOW CONTROL PARAMETER
          UJN    PRSX        EXIT - (A) = 0

 PRS10    LDML   RPBF+/IP/P.OPCODE
          STML   LRS+/RS/P.OPCD  PLACE RESPONSE OPCODE IN LOG MESSAGE
          LDML   RPBF+/IP/P.LEN
          STML   LRS+/RS/P.ADATA  PLACE RESPONSE LENGTH IN LOG MESSAGE
          LDC    E206        INVALID IPI RESPONSE LENGTH
          RJM    PPE         PROCESS PROTOCOL ERROR (NO RETURN)
 PUC      SPACE  4,16
**        PUC - PROCESS UNIT COMMAND.
*
*         THIS ROUTINE PROCESSES A WRITE COMMAND.
*         MULTIPLE WRITE COMMANDS PER REQUEST ARE
*         NOT ALLOWED.
*
*         ENTRY  (RQ) = UNIT REQUEST.
*
*         EXIT   (A) = 0 IF NO ERRORS.
*                    > 0 IF ERRORS.
*                    < 0 IF DEVICE STATE CHANGE
*
*         CALLS  PPE, WRP.


 PUC      SUBR               ENTRY/EXIT
          LDML   RQ+/URQ/P.CODE  GET COMMAND CODE
          SHN    -16+/URQ/N.CODE+/URQ/L.CODE
          LMK    C.WRTR      COMPARE WITH WRITE RECORD
          NJN    PUC10       IF BAD COMMAND CODE

*         PROCESS VALID COMMAND.

          RJM    WRP         WRITE RECORD PROCESSOR
          UJK    PUCX        EXIT

*         PROCESS INVALID COMMAND.

 PUC10    BSS    0
          LDC    E302        INTERFACE ERROR CODE
          RJM    PPE         PROCESS INTERFACE ERROR
          UJK    PUCX        EXIT
 PUR      SPACE  4,20
**        PUR - PROCESS UNIT REQUEST.
*
*         THIS ROUTINE PROCESSES ONE UNIT REQUEST FROM A UNIT QUEUE.  IF NORMAL
*         FLOW CONTROL IS ON ONLY PRIORITY REQUESTS ARE PROCESSED.  IF NORMAL
*         FLOW CONTROL IS OFF THEN A PRIORITY REQUEST WILL BE SELECTED IF
*         AVAILABLE, IF NOT A NORMAL REQUEST WILL BE SELECTED.  NOT MORE THAN
*         *MAXPR* CONSECUTIVE PRIORITY REQUESTS WILL BE SELECTED WITHOUT A
*         NORMAL REQUEST BEING SELECTED IF NORMAL FLOW CONTROL IS OFF.
*
*         ENTRY  (CM.URQ) = REFORMATTED R REGISTER PORTION OF
*                           THE MASTER CONTROL TABLE ADDRESS.
*                (CM.MCT) = REFORMATTED A REGISTER PORTION OF THE
*                           MASTER CONTROL TABLE ADDRESS.
*                (NUMPRI) < OR = MAXPR IF FLOW CONTROL OFF,
*                         > MAXPR IF FLOW CONTROL ON.
*
*         EXIT   (A) = 0 IF NO ERRORS.
*                    <> 0 IF ERRORS.
*
*         CALLS  GUR, PUC.


 PUR100   LDN    0           EXIT NO ERRORS

 PUR      SUBR               ENTRY/EXIT
          LDML   SNDOK
          ZJN    PURX        IF GLOBAL FLOW CONTROL ON
          LDML   RTCNT
          LMN    RRL
          ZJN    PUR10       IF NOT IN RECOVERY
          LDML   NUMPRI
          ZJN    PUR50       IF NORMAL REQUEST
          UJN    PUR30       IF PRIORITY REQUEST

 PUR10    LDML   NUMPRI
          LMN    MAXPR
          ZJN    PUR40       IF TIME TO SERVICE NORMAL
 PUR20    LDDL   CM.MCT
          ADN    /MCT/C.PRI  PRIORITY QUEUE
 IVB0     IF     DEF,IVB0
          STDL   CM.URQ+1
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          STDL   CM.URQ+2
 IVB4     ENDIF
 PUR30    RJM    GUR         GET PRIORITY UNIT REQUEST
          NJN    PUR60       IF REQUEST FOUND
          LDN    MAXPR
          SBML   NUMPRI
          MJK    PUR100      IF ONLY PRIORITY ALLOWED
 PUR40    LDDL   CM.MCT
          ADN    /MCT/C.NOR  NORMAL QUEUE
 IVB0     IF     DEF,IVB0
          STDL   CM.URQ+1
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          STDL   CM.URQ+2    NORMAL REQUEST QUEUE
 IVB4     ENDIF
 PUR50    RJM    GUR         GET NORMAL UNIT REQUEST
          ZJN    PUR90       IF NO REQUESTS
          LDN    0
          STML   NUMPRI
 IVB0     IF     DEF,IVB0
          LRML   MCT+/MCT/P.NOR+/UQD/P.TAIL   UNIT NORMAL QUEUE TAIL POINTER
          LDML   MCT+/MCT/P.NOR+/UQD/P.TAIL+1
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADF  MCT+/MCT/P.NOR+/UQD/P.TAIL   UNIT NORMAL QUEUE TAIL POINTER
 IVB4     ENDIF
          UJN    PUR80       PROCESS UNIT REQUESTS

 PUR60    LDML   RTCNT
          LMN    RRL
          NJN    PUR70       IF IN RECOVERY
          AOML   NUMPRI
 PUR70    BSS    0
 IVB0     IF     DEF,IVB0
          LRML   MCT+/MCT/P.PRI+/UQD/P.TAIL   UNIT PRIORITY QUEUE TAIL PTR
          LDML   MCT+/MCT/P.PRI+/UQD/P.TAIL+1
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADF  MCT+/MCT/P.PRI+/UQD/P.TAIL   UNIT PRIORITY QUEUE TAIL PTR
 IVB4     ENDIF
 PUR80    BSS    0
 IVB0     IF     DEF,IVB0
          SRML   CM.QT
          SHN    -3
          STML   CM.QT+1     UNIT QUEUE TAIL POINTER
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          SRD    CM.QT
          STML   CM.QT+2     UNIT QUEUE TAIL POINTER
 IVB4     ENDIF
          RJM    PUC         PROCESS UNIT COMMAND
          UJK    PURX        EXIT

 PUR90    LDN    MAXPR
          SBML   NUMPRI
          NJK    PUR100      IF PRIORITY SEARCHED
          STML   NUMPRI
          UJK    PUR20       TRY PRIORITY
 RAR      SPACE  4,10
**        RAR - READ ADAPTER REGISTER.
*
*         READ AN IPI STATUS OR ERROR REGISTER.
*         ALL ERRORS ARE FATAL AND THE IPI IS DOWNED.
*
*         *********************************************************
*         * NOTE: THIS ROUTINE DOES NOT RETURN TO THE CALLER IF   *
*         *       ERRORS OCCUR, RATHER IT RETURNS TO THE MAIN LOOP*
*         *********************************************************
*
*         ENTRY  (A) = FUNCTION CODE
*
*         EXIT   (A) = REGISTER CONTENTS.
*
*         CALLS  CFH, SLM.


 RAR20    LDK    E02         CHANNEL NOT FULL
 RAR30    STML   LRS+/RS/P.SCODE
          LDDL   LF
          STML   FBUF,FI     INCLUDE FUNCTION CODE IS HISTORY LIST
          AODL   FI
          LPN    7
          STDL   FI          UPDATE INDEX INTO HISTORY TABLE
          LDC    LRS+/RS/P.SCODE
          RJM    CFH         GET FUNCTION HISTORY
          LDN    PS.HLT
          STDL   PPSTATE     DOWN DEVICE
          RJM    SLM         LOG ERROR
          LJM    MCL         EXIT TO MAIN LOOP

 RAR      SUBR
          RJM    SAF         SEND FUNCTION
 RAR50    ACN    CH+40B
          LDN    77B
 RAR60    FJM    RAR70,CH    IF CHANNEL FULL
          SBN    1
          NJN    RAR60
          UJK    RAR20       IF WORD COULD NOT BE READ

 RAR70    IAN    CH
          UJK    RARX        EXIT
 RCB      SPACE  4,10
**        RCB - RETURN CM BUFFERS.
*
*         THIS ROUTINE WILL RETURN THE CM BUFFERS THE PP HAS
*         IN ITS INTERNAL CACHE. AN UNSOLICITED DEVICE ERROR
*         RESPONSE WILL BE ISSUED TO RETURN THE BUFFERS.
*
*         ENTRY  (BPCNT) = ORDINAL INTO BUFFER CACHE,
*                (MAXLRG) = MAXIMUM NUMBER OF LARGE BUFFERS IN CACHE.
*
*         USES   T1 - T3, T5, T6.
*
*         CALLS  SUR.


 RCB      SUBR               ENTRY/EXIT
          LDN    0
          STDL   INPOK
          STDL   T5          OFFSET OF LENGTH/ADDRESS PAIR IN RESPONSE
          STDL   T1          NUMBER OF BUFFERS TO RETURN
          LDML   BPCNT+SMINDX
          NJN    RCB20       IF NO SMALL BUFFERS TO RETURN
          AODL   T1          BUFFERS TO RETURN
          LDN    1
          STML   BPCNT+SMINDX  INITIALIZE SMALL CACHE COUNT (BUFFERS NEEDED)
          LDN    2
          STDL   T2
 RCB10    LDML   SBUFC+/IBC/P.PVA,T2
          STML   RS+/RS/P.BUFPVA,T2  SETUP BUFFER PVA IN RESPONSE
          SODL   T2
          PJN    RCB10       IF MORE TO DO
          LDN    4
          RADL   T5          ADVANCE TO NEXT LENGTH/ADDRESS PAIR
 RCB20    LDML   MAXLRG      MAXIMUM NUMBER OF LARGE BUFFERS TO RETURN
          SBML   BPCNT+LGINDX
          ZJN    RCB30       IF NO MORE LARGE BUFFERS TO RETURN
          ERRNZ  P.IBC-8
          LDML   BPCNT+LGINDX
          SHN    3           MULTIPLY BY 8
          STDL   T3          OFFSET OF CACHE ENTRY PVA
          AODL   T1          BUFFERS TO RETURN
          LDML   LBUFC+/IBC/P.PVA,T3
          STML   RS+/RS/P.BUFPVA,T5
          LDML   LBUFC+/IBC/P.PVA+1,T3
          STML   RS+/RS/P.BUFPVA+1,T5
          LDML   LBUFC+/IBC/P.PVA+2,T3
          STML   RS+/RS/P.BUFPVA+2,T5  MOVE BUFFER PVA TO RESPONSE
          LDN    4
          RADL   T5          ADVANCE TO NEXT LENGTH/ADDRESS PAIR
          AOML   BPCNT+LGINDX  INCREMENT BUFFER NEEDED COUNT
          UJK    RCB20

 RCB30    LDDL   T1          BUFFERS TO RETURN
          ZJN    RCB40       IF NO BUFFERS TO RETURN
          SHN    3           ONE CM WORD PER RETURNED BUFFER
          ADN    /RS/C.BP1ST*8+8
          STML   RS+/RS/P.RESPL  SET RESPONSE LENGTH
          LDN    BP.GOOD     BUFFER POOL CONTAINS A SUFFICIENT NUMBER OF BUFFERS
          STML   RS+/RS/P.BP1ST
          STML   RS+/RS/P.BP2ST
          LDDL   SNDOK       IVB GLOBAL FLOW CONTROL STATUS
          STML   RS+/RS/P.PSEND
          STML   RS+/RS/P.NSEND
          LDN    RC.DS       DETAILED STATUS INCLUDED
          STML   RCON        RESPONSE CONDITION CODE
          LDN    URC.DE      UNSOLICITED RESPONSE CODE
          RJM    SUR         SEND UNSOLICITED RESPONSE
 RCB40    UJK    RCBX        EXIT
 RDD      SPACE  4,20
**        RDD - READ DATA.
*
*         THIS ROUTINE WILL PERFORM A DMA READ. THE *BPRMA*
*         ARRAY OF LENGTH/RMA ADDRESS PAIRS SPECIFIES THE BYTE
*         COUNTS AND BUFFER ADDRESSES FOR THE DMA(S).
*
*         ENTRY  (BPRMA) = LENGTH/RMA ADDRESS PAIRS FOR READ.
*                (CML) = OFFSET OF BUFFER LENGTH/ADDRESS PAIR.
*
*         EXIT   (A) = 0, IF NO ERRORS DETECTED DURING I/O,
*                    <> 0, IF ERRORS AND RECOVERY POSSIBLE,
*                (WC) = UNTRANSFERRED PP WORD COUNT,
*                (IOERR) = LOG RESPONSE IF ERROR.
*
*         USES   WC.
*
*         CALLS  BCS, EFP, ICF.
*


 RDD20    BSS    0
 IVB0     IF     DEF,IVB0
          LDC    MS50
 RDD30    IJM    RDD40,CH    IF SLAVE IN DROPPED
          SBN    1
          NJN    RDD30       IF NOT TIMED OUT
          DCN    CH+40B
          LDN    E30
          STML   IOERR+/ILD/P.SCODE  SYMPTOM CODE
          LDN    DS.ILR
          STDL   DSTATE
          LDC    IOERR
          RJM    CEP         LOG ERROR (NO RETURN)

 RDD40    LDDL   WC
          ZJN    RDD60       IF NO ERROR
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          RJM    WTC         WAIT TRANSFER COMPLETE
          ZJN    RDD60       IF NO ERROR
 IVB4     ENDIF
 RDD50    LDML   EDATA
          STML   IOERR+/ILD/P.EDATA
          LDML   RS+/RS/P.XFER+1
          SBDL   WC
          SBDL   WC
          STML   IOERR+/ILD/P.ADATA
          LDN    E07
          STML   IOERR+/ILD/P.SCODE
 RDD60    CFM    RDD70,CH    IF CHANNEL ERROR FLAG NOT SET
          LDC    IOERR       I/O ERROR INFO BUFFER
          RJM    EFP         ERROR FLAG PROCESSING
 RDD70    LDML   IOERR+/ILD/P.SCODE  SYMPTOM CODE


 RDD      SUBR               ENTRY/EXIT
          STML   EDATA
          STDL   TBYTS       TOTAL NUMBER OF BYTES TO TRANSFER
          LDN    DATAIN      DATA, INFORMATION IN
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0281       STREAM, READ
          RJM    ICF         RAISE MASTER OUT
 IVB0     IF     DEF,IVB0
          ACN    CH
 IVB0     ENDIF
 RDD10    LDML   BPRMA+/BPR/P.LENGTH,CML  BYTES TO TRANSFER
          STDL   BUFLEN
 IVB0     IF     DEF,IVB0
          SHN    -1          CHANNEL FRAMES TO READ
          STDL   WC          TRANSFER COUNT
          LRML   BPRMA+/BPR/P.RMA,CML  CM ADDRESS OF BUFFER
          LDML   BPRMA+/BPR/P.RMA+1,CML
          SHN    -3
          CHCM   WC,CH
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LDC    BPRMA+/BPR/P.LENGTH  BYTES TO TRANSFER
          ADDL   CML         OFFSET OF CURRENT LENGTH/ADDRESS PAIR
          STML   RDDA        BYTE COUNT/RMA TRIPLET FOR DMA
          LDC    H0C00       DMA READ
          RJM    ICF
          ACN    CH
          LDN    3
          OAM    **,CH       BYTE COUNT, RMA
 RDDA     EQU    *-1
          RJM    DCN         DISCONNECT THE CHANNEL
 IVB4     ENDIF
          LDDL   BUFLEN      BYTES TRANSFERRED IN LAST READ
          RAML   RS+/RS/P.XFER+1  UPDATE TRANSFER COUNT IN RESPONSE
          LDDL   TBYTS       BYTES TO READ
          SBDL   BUFLEN      BYTES READ
          STDL   TBYTS       BYTES LEFT TO READ
          ZJK    RDD20       IF ALL DATA READ
          ERRNZ  P.BPR-4
          LDN    P.BPR
          RADL   CML         USE NEXT LENGTH/ADDRESS PAIR
 IVB0     IF     DEF,IVB0
          LDDL   WC
          NJK    RDD20       IF INCOMPLETE TRANSFER
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          RJM    WTE         WAIT FOR T' REGISTER TO EMPTY
          NJK    RDD50       IF ERROR
 IVB4     ENDIF
          UJK    RDD10
 RRP      SPACE  4,10
**        RRP - READ RESPONSE PACKET.
*
*         THIS ROUTINE WILL INPUT A RESPONSE PACKET
*         FROM THE IVB.
*
*         EXIT   (A) = 0, IF NO ERROR,
*                         (RPBF) = RESPONSE PACKET,
*                   <> 0, IF UNSUCCESSFUL OR SUSPEND LINK.
*                   <  0, IF SLAVE STATUS NOT RECEIVED.
*
*         USES   WC
*
*         CALLS  BCS, CEP, EFP, ICF, DGU.


 RRP      SUBR
          LDN    RSPIN       BUS A FOR RESPONSE
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0281       STREAM, READ
          RJM    ICF         SET MASTER OUT
          ACN    CH
          LDN    P.IP        LENGTH OF BASIC RESPONSE
          IAM    RPBF,CH     INPUT REQUIRED WORDS
          ZJN    RRP10       IF TRANSFER COMPLETE
          SHN    1
          STML   CRERR+/ILD/P.ADATA
          LDN    B.IP
          UJN    RRP20       LOG ERROR

 RRP10    LDML   RPBF+/IP/P.LEN  BYTE COUNT MINUS 2
          SBN    B.IP-/IP/B.LEN  ALREADY READ
          SHN    -1          CONVERT BYTE COUNT TO WORD COUNT
          ZJN    RRP30       IF ALL WORDS TRANSFERRED
          SBN    RPBL-P.IP+1
          PJK    RRP230      IF RESPONSE TOO LONG
          ADN    RPBL-P.IP+1  INPUT EXACT LENGTH
          IAM    RPBF+P.IP+/CCP/P.PARML,CH   INPUT REMAINING WORDS
          ZJN    RRP30       IF TRANSFER COMPLETE
          SHN    1
          STML   CRERR+/ILD/P.ADATA
          LDML   RPBF+/IP/P.LEN  BYTE COUNT MINUS 2
          ADN    B.IP-/IP/B.LEN  INCLUDE LENGTH FIELD
 RRP20    STML   CRERR+/ILD/P.EDATA
          SBML   CRERR+/ILD/P.ADATA
          STML   CRERR+/ILD/P.ADATA
          LDN    E07         INCOMPLETE TRANSFER
          STML   CRERR+/ILD/P.SCODE  SAVE SYMPTOM CODE
 RRP30    STDL   IP          CLEAR INPUT PENDING FLAG
          LDC    MS50
 RRP40    BSS
          IJM    RRP50,CH    IF SLAVE IN DROPPED
          SBN    1
          NJN    RRP40       IF TIMEOUT NOT EXPIRED
          DCN    CH+40B
          LDN    E28         SLAVE IN DID NOT DROP
          STML   CRERR+/ILD/P.SCODE  SAVE SYMPTOM CODE
          LDN    DS.ILR
          STDL   DSTATE
          UJK    RRP100

 RRP50    BSS
          SFM    RRP70,CH    IF CHANNEL ERROR FLAG SET
          LDML   CRERR+/ILD/P.SCODE  NON-ZERO IF ERROR DETECTED
          ZJN    RRP80       IF NO ERRORS DETECTED
 RRP60    LDN    0           UNSUCCESSFUL STATUS
          UJN    RRP90

 RRP70    LDC    CRERR       ERROR INFO BUFFER
          RJM    EFP         ERROR FLAG PROCESSING
          UJN    RRP60

 RRP80    LDC    /STATP/K.SUC  SUCCESSFUL STATUS
 RRP90    RJM    ESS         ENDING STATUS SEQUENCE
          ZJN    RRP120      IF ABLE TO GET SLAVE STATUS
          LDML   CRERR+/ILD/P.SCODE
          ZJN    RRP110      IF NO ERROR TO REPORT
 RRP100   LDC    CRERR
          RJM    CEP         LOG ERROR
 RRP110   LDC    777776B
          UJK    RRPX        EXIT A <0


 RRP120   LDDL   STATUS      SLAVE STATUS
          SHN    17-/STATP/SUC
          MJK    RRP170      IF TRANSFER SUCCESSFUL
          LDC    CRERR+/ILD/P.SCODE
          RJM    ISS         INCLUDE SLAVE STATUS
          LDC    CRERR+/ILD/P.SCODE
          RJM    IMS         INCLUDE MASTER STATUS
          LDML   CRERR+/ILD/P.SCODE
          NJN    RRP140      IF HOST SAW ERROR
          RJM    ASS         ANALYZE SLAVE STATUS
          STML   CRERR+/ILD/P.SCODE
 RRP140   LDC    CRERR       ERROR INFO BUFFER
          RJM    CEP         COMMON ERROR PROCESSING
 RRP150   LDN    1
 RRP160   UJK    RRP180      EXIT - (A) <> 0

 RRP170   LDML   RPBF+/IP/P.OPCODE
          LMK    O.SL
          ZJN    RRP190      IF *SUSPEND LINK*
          LDML   RPBF+/IP/P.REFNO  RESPONSE SEQUENCE NUMBER
          SBML   RPSEQ       EXPECTED SEQUENCE NUMBER
          NJN    RRP210      IF SEQUENCE NUMBERS OUT OF SYNC
          AOML   RPSEQ       INCREMENT RESPONSE SEQUENCE NUMBER
          LDN    0
 RRP180   UJK    RRPX        EXIT

*         *SUSPEND LINK* RESPONSE RECEIVED

 RRP190   LDN    2
          STML   RPSEQ       RESET RESPONSE SEQUENCE NUMBER
          STML   SLREC       *SUSPEND LINK* RECEIVED
          RJM    DGU         DEVICE GONE UNAVAILABLE
 RRP400   LDN    1
          UJN    RRP180

 RRP210   BSS    0
          LDML   RPSEQ       EXPECTED SEQUENCE NUMBER
          STML   LRS+/RS/P.EDATA  PLACE IN LOG MESSAGE
          LDML   RPBF+/IP/P.REFNO  ACTUAL SEQUENCE NUMBER
          STML   LRS+/RS/P.ADATA  PLACE IN LOG MESSAGE
          LDC    E202        RESPONSE SEQUENCE NUMBERS OUT OF SYNC
 RRP220   RJM    PPE         PROCESS PROTOCOL ERROR (NO RETURN)

 RRP230   LDML   RPBF+/IP/P.LEN  RESPONSE LENGTH
          STML   LRS+/RS/P.ADATA  PLACE IN LOG MESSAGE
          LDML   RPBF+/IP/P.OPCODE  RESPONSE OPCODE
          STML   LRS+/RS/P.OPCD  PLACE IN LOG MESSAGE
          LDC    E206
          UJN    RRP220

 RSS      SPACE  4,10
**        RSS - REQUEST SLAVE STATUS.
*
*         THIS ROUTINE REQUESTS THAT THE IVB RETURN
*         STATUS OF THE PREVIOUS COMMAND OR RESPONSE.
*         THIS ROUTINE IS USED WHEN AN ERROR PREVENTED
*         DATA STATUS FROM BEING EXCHANGED WITH THE IVB.
*
*         ENTRY  (RSTAT) = MASTER STATUS TO BE SENT.
*                (RSEQ) = SEQUENCE NUMBER BEING RECOVERED.
*


 RSS40    LDML   RSSA
          STML   CPBF+/IP/P.REFNO
          LDML   RSSB
          STML   RPSEQ
          LDN    0

 RSS      SUBR               ENTRY/EXIT
          LDML   CPBF+/IP/P.REFNO
          STML   RSSA
          LDML   RPSEQ
          STML   RSSB
          LDML   RSEQ
          STML   RPSEQ
          STML   CPBF+P.IP+/MSDS/P.REFNO
          SBN    1
          STML   CPBF+/IP/P.REFNO
          LDK    B.IP-/IP/B.LEN+B.MSDS
          STML   CPBF+/IP/P.LEN
          LDK    O.RSDS+0#80  REQUEST SLAVE DATA STATUS
          STML   CPBF+/IP/P.OPCODE
          LDML   RSTAT
          STML   CPBF+P.IP+/MSDS/P.STATUS
          LDN    B.MSDS-/MSDS/B.PARML
          SHN    /MSDS/N.PARML
          ADK    PID.MSDS
          STML   CPBF+P.IP+/MSDS/P.PARML
          RJM    SCP         SEND COMMAND
          NJK    RSS30       IF ERRORS

*         WAIT FOR IVB TO RESPOND

          RJM    RRP         READ RESPONSE
          RJM    RRP         READ RESPONSE
          NJK    RSS30       IF ERRORS
          LDML   CPBF+P.IP+/MSDS/P.REFNO
          LMML   RPBF+P.IP+/MSDS/P.REFNO
          NJK    RSS20       IF NOT IN SEQUENCE LOG ERROR
          LDML   RPBF+P.IP+/MSDS/P.STATUS
          SHN    -8
          STDL   STATUS
          TRACE  (RSS,STATUS)
          LDDL   STATUS
          SHN    17-/STATP/SUC
          MJK    RSS10       IF SUCCESSFUL
          UJK    RSS40       EXIT A=0

*         IF IVB STATUS IS SUCCESSFUL MAKE SURE
*         MASTER STATUS WAS ALSO SUCCESSFUL

 RSS10    LDML   CPBF+P.IP+/MSDS/P.STATUS
          STML   MSTAT
          SHN    17-/STATP/SUC
          MJK    RSS40       IF MASTER SUCCESSFUL EXIT A=0
          LDC    LRS+/RS/P.SCODE
          RJM    ISS         INCLUDE SLAVE STATUS
          LDC    LRS+/RS/P.SCODE
          RJM    IMS         INCLUDE MASTER STATUS
          LDC    E203
          RJM    PPE         LOG ERROR (NO RETURN)

 RSS20    LDML   CPBF+P.IP+/MSDS/P.REFNO
          STML   LRS+/RS/P.EDATA
          LDML   RPBF+P.IP+/MSDS/P.REFNO
          STML   LRS+/RS/P.ADATA
          LDC    E202
          RJM    PPE         LOG ERROR (NO RETURN)

 RSS30    LDN    DS.ILR
          STDL   DSTATE      RESET IVB
          UJK    MCL         EXIT TO MAIN LOOP

 RSSA     BSSZ   1           SAVE COMMAND REFERENCE NUMBER
 RSSB     BSSZ   1           SAVE RESPONSE REFERENCE NUMBER
 SAF      SPACE  4,18
**        SAF - SEND ADAPTER FUNCTION.
*
*         SEND A FUNCTION TO THE IPI ADAPTER WITHOUT
*         INCLUDING IN THE FUNCTION HISTORY TABLE.
*         THIS ROUTINE IS USED TO READ AND CLEAR ADAPTOR
*         REGISTERS. NO RECOVERY IS PERFORMED.
*         ALL ERRORS ARE FATAL AND THE IPI IS DOWNED.
*
*         *********************************************************
*         * NOTE: THIS ROUTINE DOES NOT RETURN TO THE CALLER IF   *
*         *       ERRORS OCCUR, RATHER IT RETURNS TO THE MAIN LOOP*
*         *********************************************************
*
*         ENTRY  (A) = FUNCTION CODE.
*
*         EXIT   LF = FUNCTION CODE.
*
*         CALLS  CFH, SLM.


 SAF      SUBR
          STML   LF
          DCN    CH+40B      ENSURE CHANNEL IS INACTIVE
          FAN    CH          ISSUE THE FUNCTION
          LDN    77B
 SAF10    IJM    SAFX,CH     IF FUNCTION REPLY
          SBN    1
          NJN    SAF10       IF NOT TIMEOUT
          LDK    E01
          STML   LRS+/RS/P.SCODE
          LDDL   LF
          STML   FBUF,FI     INCLUDE FUNCTION CODE IS HISTORY LIST
          AODL   FI
          LPN    7
          STDL   FI          UPDATE INDEX INTO HISTORY TABLE
          LDC    LRS+/RS/P.SCODE
          RJM    CFH         GET FUNCTION HISTORY
          LDN    PS.HLT
          STDL   PPSTATE     DOWN DEVICE
          RJM    SLM         LOG ERROR
          LJM    MCL         EXIT TO MAIN LOOP
 SBL      SPACE  4,12
**        SBL - SET BUFFER POOL DESCRIPTOR LOCK.
*
*         THIS ROUTINE INTERLOCKS THE SPECIFIED WORD IN THE
*         BUFFER POOL DESCRIPTOR.
*
*         ENTRY  (A) = ARRAY INDEX OF POOL DESCRIPTOR TO LOCK.
*
*         EXIT   (A) = 0, TO SHOW THAT THE CM WORD IS INTERLOCKED.
*
*         USES   T5, T7.
*
*         CALLS  SLR.
          SPACE  4,10
 SBL      SUBR               ENTRY/EXIT
          STDL   T5
          LDK    CM.BPD      FIRST BUFFER POOL DESCRIPTOR
          STDL   T7
          RJM    SLR         SET LOCK RESERVATION
          UJK    SBLX
 SCL      SPACE  4,10
**        SCL - SET CHANNEL LOCK.
*
*         THIS ROUTINE SETS THE CHANNEL LOCK IN THE CM
*         CHANNEL TABLE.
*
*         ENTRY  (CM.CHAN) = CM ADDRESS OF CHANNEL TABLE,
*                (CHAN) = CHANNEL NUMBER.
*
*         EXIT   (A) = 0, IF LOCK COULD BE SET,
*                   <> 0, IF LOCK NOT SET.
*
*         USES   T5, T7.
*

 SCL      SUBR               ENTRY/EXIT
          LDC    CM.CHAN
          STDL   T7          CHANNEL TABLE
          LDML   CHAN
          STDL   T5          CHANNEL NUMBER
          RJM    SLR         SET LOCK RESERVATION
          RJM    SLW         SET LOCK WORD
          UJN    SCLX        EXIT
 SCP      SPACE  4,10
**        SCP - SEND COMMAND PACKET.
*
*         THIS ROUTINE WILL SEND THE PREVIOUSLY CONSTRUCTED
*         COMMAND PACKET TO THE IVB.
*
*         ENTRY  (CPBF) = COMMAND PACKET.
*
*         EXIT   (A) = 0, IF NO ERRORS,
*                   <> 0, IF UNSUCCESSFUL
*                   <  0, IF SLAVE STATUS NOT RECEIVED.
*
*         USES   WC
*
*         CALLS  BCS, CEP, EFP, ESS, ICF.


 SCP140   LDN    0

 SCP      SUBR
          AOML   CPBF+/IP/P.REFNO  INCREMENT COMMAND SEQUENCE NUMBER
          LDN    CMDOUT      BUS A FOR COMMAND
          RJM    BCS         BUS CONTROL SEQUENCE
          LDC    H0381       STREAM, WRITE
          RJM    ICF         RAISE MASTER OUT
          ACN    CH
          LDML   CPBF+/IP/P.LEN  LENGTH FIELD
          ADN    /IP/B.LEN+1  ADD SIZE OF LENGTH FIELD AND ROUND UP
          SHN    -1
          OAM    CPBF,CH     SEND COMMAND PACKET
          STDL   WC          WORDS NOT TRANSFERRED
          ZJN    SCP10       IF TRANSFER COMPLETE
          LDN    E07         INCOMPLETE TRANSFER
          STML   CRERR+/ILD/P.SCODE  SAVE SYMPTOM CODE
          LDML   CPBF+/IP/P.LEN  LENGTH FIELD
          ADN    /IP/B.LEN+1  ADD SIZE OF LENGTH FIELD AND ROUND UP
          SHN    -1
          STML   CRERR+/ILD/P.EDATA
          SBDL   WC
          STML   CRERR+/ILD/P.ADATA
 SCP10    LDC    MS50
 SCP20    IJM    SCP30,CH    IF SLAVE IN DROPPED
          IJM    SCP30,CH    (INCREASE LOOP TIME...IVB HAS HUNG HERE)
          IJM    SCP30,CH
          SBN    1
          NJN    SCP20       IF TIMEOUT NOT EXPIRED
          DCN    CH+40B
          LDN    E28         SLAVE IN DID NOT DROP
          STML   CRERR+/ILD/P.SCODE  SAVE SYMPTOM CODE
          LDN    DS.ILR
          STDL   DSTATE
          UJK    SCP70

 SCP30    CFM    SCP40,CH    IF NO CHANNEL ERROR
          LDC    CRERR       ERROR INFO BUFFER
          RJM    EFP         ERROR FLAG PROCESSING
 SCP40    LDML   CRERR+/ILD/P.SCODE  NON-ZERO IF ERROR DETECTED
          ZJN    SCP50       IF TRANSFER SUCCESSFUL
          LDN    0           UNSUCCESSFUL STATUS
          UJN    SCP60

 SCP50    LDC    /STATP/K.SUC  SUCCESSFUL STATUS
 SCP60    RJM    ESS         ENDING STATUS SEQUENCE
          ZJN    SCP90       IF ABLE TO GET SLAVE STATUS
          LDML   CRERR+/ILD/P.SCODE
          ZJN    SCP80       IF NO ERROR TO REPORT
 SCP70    LDC    CRERR
          RJM    CEP         LOG ERROR
 SCP80    LDC    777776B
          UJK    SCPX        EXIT A <0

 SCP90    LDDL   STATUS      SLAVE STATUS
          SHN    17-/STATP/SUC
          MJK    SCP140      IF TRANSFER SUCCESSFUL
          LDC    CRERR+/ILD/P.SCODE
          RJM    ISS         INCLUDE SLAVE STATUS
          LDC    CRERR+/ILD/P.SCODE
          RJM    IMS         INCLUDE MASTER STATUS
          LDML   CRERR+/ILD/P.SCODE
          NJN    SCP110      IF HOST SAW ERROR
          RJM    ASS         ANALYZE SLAVE STATUS
          STML   CRERR+/ILD/P.SCODE
 SCP110   LDC    CRERR       ERROR INFO BUFFER
          RJM    CEP         COMMON ERROR PROCESSING
 SCP120   LDN    1
          UJK    SCPX        EXIT - (A) <> 0
 SDO      SPACE  4,10
**        SDO - SEND DEVICE OPERATIONAL.
*
*         THIS ROUTINE SENDS A DEVICE OPERATIONAL
*         UNSOLICITED RESPONSE TO THE CPU TO NOTIFY
*         THE HOST THAT THE IVB IS IN SERVICE. THE
*         RESPONSE WILL CONTAIN THE MAXIMUM CCPDU SIZE
*         SUPPORTED BY THE IVB.
*
*         EXIT   (DSTATE) = DS.WOA.
*
*         CALLS  SUR.

 SDO      SUBR               ENTRY/EXIT
          LDN    /RS/C.SYSID*8+8
          STML   RS+/RS/P.RESPL  RESPONSE LENGTH
          LDML   IPIVER
          STML   RS+/RS/P.PROV  IPI PROTOCOL VERSION
          LDN    0
          STML   RS+/RS/P.MAXRS
          LDML   MAXPDU
          STML   RS+/RS/P.MAXRS+1  MAXIMUM CCPDU SIZE
          LDN    RC.DS       DEATAILED STATUS INCLUDED
          STML   RCON        RESPONSE CONDITION CODE
          LDN    URC.OPER    DEVICE OPERATIONAL RESPONSE
          RJM    SUR         SEND UNSOLICITED RESPONSE
          LCN    0
          STML   AVAIL       DEVICE AVAILABLE
          RJM    LAM         LOG AVAILABILITY
          LDN    DS.WOA
          STDL   DSTATE      WAIT FOR DEVICE OPERATIONAL ACK
          UJK    SDOX        EXIT
 SEL      SPACE  4,10
**        SEL - SELECT CONTROL MODULE.
*
*         THIS ROUTINE WILL SELECT THE IVB.
*
*         ***********************************************************
*         * NOTE: THIS ROUTINE ASSUMES THE DEVICE HAS RESET IF      *
*         *       THE SELECT FAILS. IN THIS CASE RETURN IS TO THE   *
*         *       MAIN LOOP                                         *
*         ***********************************************************
*
*         USES   P6.
*
*         CALLS  CEP, EFP, ICF.


 SEL      SUBR               ENTRY/EXIT
 SELA     LDC    H0029       SET SELECT OUT
          RJM    ICF
          ACN    CH
          LDN    77B
 SEL10    FJM    SEL20,CH    IF SLAVE IN
          SBN    1
          NJN    SEL10       IF TIMEOUT NOT EXPIRED
          LDN    DS.ILR
          STDL   DSTATE
          UJK    MCL         EXIT TO MAIL LOOP

 SEL20    IAN    CH
          SFM    SEL50,CH    IF CHANNEL ERROR
          LPC    377B
          LMC    **
 SELB     EQU    *-1
          ZJN    SELX        IF CORRECT BIT SIGNIFICANT RESPONSE - EXIT
          STDL   STATUS      SAVE BIT SIGNIFICANT RESPONSE
          LDC    OTHERR
          RJM    ISS         INCLUDE SLAVE STATUS
          LDN    E21         BIT SIGNIFICANT RESPONSE WRONG
 SEL30    BSS
          STML   OTHERR+/ILD/P.SCODE  SAVE SYMPTOM CODE
 SEL40    LDN    DS.ILR
          STDL   DSTATE
          LDC    OTHERR      ERROR INFO BUFFER ADDRESS
          RJM    CEP         COMMON ERROR PROCESSING ( NO RETURN )

 SEL50    LDC    OTHERR      ERROR INFO BUFFER ADDRESS
          RJM    EFP         ERROR FLAG PROCESSING
          UJN    SEL40
 SFR      SPACE  4,10
**        SFR - SETUP FOR READ.
*
*         THIS ROUTINE WILL SETUP THE RESPONSE BUFFER
*         LENGTH/ADDRESS PAIRS AND THE BUFFER RMA'S IN
*         *BPRMA* IN PREPARATION OF AN UPCOMING READ OF
*         THE SPECIFIED NUMBER OF BYTES.
*
*         ENTRY  (A) = TOTAL NUMBER OF BYTES TO READ,
*
*         EXIT   (BUFCNT) = NUMBER OF BUFFERS USED,
*                (CML) = 0 = OFFSET OF FIRST LENGTH/ADDRESS PAIR,
*                (BPRMA) = LENGTH/RMA ADDRESS PAIRS FOR READ BUFFERS.
*
*         USES   T2.


 SFR      SUBR               ENTRY/EXIT
          STDL   BYTS        TRANSFER SIZE
          LDN    0
          STDL   CML         LENGTH/ADDRESS PAIR OFFSET
          STML   BUFCNT
 SFR10    LDN    SMINDX
          STDL   BPINDX      BUFFER POOL INDEX
          LDML   BPSIZE,BPINDX  BUFFER SIZE
          SBML   BYTS
          PJN    SFR20       IF SMALL BUFFER LARGE ENOUGH
          AODL   BPINDX      USE LARGE BUFFER
          LDC    LBUFC
          UJN    SFR30

 SFR20    LDC    SBUFC
 SFR30    STML   CACHE       BASE BUFFER CACHE ADDRESS
          AOML   BUFCNT      NUMBER OF BUFFERS USED
          LDML   BPSIZE,BPINDX
          SBDL   BYTS
          MJN    SFR40       IF NOT FIRST BUFFER

*         INITIALIZE FOR FIRST BUFFER

          LDN    0
          STDL   CML         OFFSET INTO RESPONSE AND *BPRMA*
          UJN    SFR50

*         INITIALIZE FOR ALL OTHER BUFFERS

 SFR40    LDN    4
          RADL   CML         OFFSET INTO RESPONSE AND *BPRMA*

*         SETUP BUFFER PVA IN RESPONSE BUFFER

          ERRNZ  P.IBC-8     INTERNAL BUFFER CACHE ENTRY LENGTH = 8
 SFR50    LDML   BPCNT,BPINDX
          SHN    3
          ADML   CACHE       BASE CACHE ADDRESS
          STDL   T2          NEXT AVAILABLE BUFFER CACHE ENTRY ADDRESS

*         SETUP RESPONSE BUFFER PVA

          LDML   /IBC/P.PVA,T2
          STML   RS+/RS/P.BUFPVA,CML
          LDML   /IBC/P.PVA+1,T2
          STML   RS+/RS/P.BUFPVA+1,CML
          LDML   /IBC/P.PVA+2,T2
          STML   RS+/RS/P.BUFPVA+2,CML  MOVE PVA TO RESPONSE

*         SETUP BUFFER RMA

          LDML   /IBC/P.RMA,T2
          STML   BPRMA+/BPR/P.RMA,CML
          LDML   /IBC/P.RMA+1,T2
          STML   BPRMA+/BPR/P.RMA+1,CML  SETUP BUFFER RMA
          AOML   BPCNT,BPINDX  BUFFERS NEEDED TO FILL CACHE

*         SETUP LENGTH FIELD IN RESPONSE BUFFER

          LDML   BPSIZE,BPINDX  BUFFER SIZE
          STML   RS+/RS/P.DLEN,CML
          STML   BPRMA+/BPR/P.LENGTH,CML  TRANSFER SIZE FOR BUFFER
          LDDL   BYTS        REMAINING BYTES
          SBML   BPRMA+/BPR/P.LENGTH,CML
          PJN    SFR70       IF ENTIRE BUFFER NEEDED

*         SETUP CORRECT BYTE COUNT AND START ADDRESS FOR FIRST BUFFER

          LDDL   BYTS        REMAINING BYTES
          STML   RS+/RS/P.DLEN  BYTES TO BE WRITTEN INTO FIRST BUFFER
          STML   BPRMA+/BPR/P.LENGTH  TRANSFER SIZE FOR FIRST BUFFER
          LDML   BPSIZE,BPINDX  BUFFER SIZE
          SBML   RS+/RS/P.DLEN  BYTES TO BE WRITTEN INTO FIRST BUFFER
          RAML   BPRMA+/BPR/P.RMA+1  INCREMENT DATA START ADDRESS
          SHN    -16
          RAML   BPRMA+/BPR/P.RMA
          LDN    0

 SFR70    STDL   BYTS        REMAINING BYTES
          NJK    SFR10       IF MORE BUFFERS NEEDED
          LDML   BUFCNT
          SHN    3           LENGTH OF ALL LENGTH/ADDRESS PAIRS
          ADN    /RS/C.DLEN*8
          STML   RS+/RS/P.RESPL  SETUP RESPONSE LENGTH
          UJK    SFRX        EXIT
 SLM      SPACE  4,12
**        SLM - SEND LOG MESSAGE.
*
*         THIS ROUTINE IS CALLED TO SEND A LOG MESSAGE TO
*         THE HOST.
*
*         ENTRY  (LRS) = RESPONSE TO BE SENT.
*
*         CALLS  ILM, SPR.

 SLM      SUBR               ENTRY/EXIT
          LDDL   PPSTATE
          SBN    PS.HLT
          NJN    SLM10       IF NOT HALTED
          LDC    /RS/K.DIVB
          RAML   LRS+/RS/P.FLAGS  SET IVB DOWN
 SLM10    LDC    LRS
          RJM    SPR         SEND RESPONSE
          LDC    LRS+/RS/P.SCODE
          RJM    ILM         REINITIALIZE LOG RESPONSE
          UJN    SLMX        EXIT
 SLR      SPACE  4,16
**        SLR - SET LOCK RESERVATION.
*
*         THIS ROUTINE INTERLOCKS THE COMPARE/SWAP WORD AT THE SPECIFIED
*         CM ADDRESS.  IT PLACES 0FFFFFFFF(16) IN THE UPPER PORTION OF THE
*         WORD TO RESERVE IT.
*
*         ENTRY  (T5) = WORD OFFSET OF CM WORD TO INTERLOCK.
*                (T7) = CM ADDRESS OF TABLE.
*
*         EXIT   (A) = 0, INDICATES LOCK HAS BEEN RESERVED.
*                (P1 - P4) = ORIGINAL CONTENTS OF CM WORD.
*                (T6) = (A) PORTION OF ADDRESS OF CM WORD.
*
*         USES   P1 - P4, T5, T6, T7.
*
*         MACROS LOADR.


 SLR      SUBR               ENTRY/EXIT
 SLR10    LCN    0
          STDL   P1
          STDL   P2
          LDN    0
          STDL   P3
          STDL   P4
 IVB0     IF     DEF,IVB0
          LRIL   T7
          LDML   1,T7        UNIT/PP INTERFACE/ETC TABLE ADDRESS
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADR  0,T7        UNIT/PP INTERFACE/ETC TABLE ADDRESS
 IVB4     ENDIF
          ADDL   T5          ADD INTERLOCK WORD OFFSET
          STDL   T6
          RDSL   P1          SET UPPER 32 BITS OF LOCK WORD TO '1'S
          LDDL   P1
          ADDL   P2
          ADC    400001B
          ZJN    SLR10       IF ANOTHER INTERLOCK OPERATION IS IN PROGRESS

*         WORD HAS BEEN SUCCESSFULLY INTERLOCKED

          LDN    0           INTERLOCK RESERVED
          UJK    SLRX        EXIT, INTERLOCK RESERVED
 SLW      SPACE  4,10
**        SLW - SET LOCK WORD.
*
*         THIS ROUTINE SETS THE LOCK WORD AT THE SPECIFIED
*         CM ADDRESS.
*
*         ENTRY  (P1 - P4) = ORIGINAL CONTENTS OF LOCK,
*                (R) = R-REGISTER PORTION OF LOCK ADDRESS,
*                (T6) = A-REGISTER PORTION OF LOCK ADDRESS (LOCK OFFSET).
*
*         EXIT   (A) = 0, IF LOCK SET,
*                (A) <> 0, IF LOCK COULD NOT BE SET,
*                (P1 - P4) = NEW CONTENTS OF LOCKWORD.
*
*         USES   P1 - P4, T6.


 SLW      SUBR               ENTRY/EXIT
          LDDL   P1
          SHN    17-15
          MJN    SLW20       IF INTERLOCK ALREADY SET (RESTORE WORD)
          LDC    100000B
          RADL   P1          SET INTERLOCK BIT
          LDDL   PPNO        PP NUMBER
          STDL   P4

 SLW20    LDDL   T6
          ADC    400000B
          CWDL   P1          UPDATE INTERLOCK WORD
          LDDL   P4
          LMDL   PPNO        PP NUMBER

*         (A) = 0, IF THE INTERLOCK IS OWNED BY THIS PP

          UJK    SLWX        EXIT
 SNO      SPACE  4,10
**        SNO - SEND NO-OP.
*
*         THIS ROUTINE WILL SEND A *NO-OP* COMMAND TO
*         THE IVB. THE IVB MUST HAVE ALREADY BEEN
*         SELECTED
*
*         CALLS  SCP.
*

 SNO      SUBR               ENTRY/EXIT
          LDN    RRL
          STML   RTCNT
 SNO10    LDN    B.IP-/IP/B.LEN  SET LENGTH
          STML   CPBF+/IP/P.LEN
          LDK    O.NOOP+0#80 SET NO-OP COMMAND
          STML   CPBF+/IP/P.OPCODE
          RJM    SCP         SEND COMMAND PACKET
          ZJK    SNOX        IF NO ERRORS
          PJN    SNO20       IF STATUS RECEIVED
          RJM    ALC         ABORT LAST COMMAND
          NJK    SNOX        IF RESET
 SNO20    SOML   RTCNT       DECREMENT RETRY COUNT
          NJN    SNO10       IF RETRY'S REMAINING
          LDN    DS.ILR
          STML   DSTATE
          UJK    SNOX        EXIT
 SPL      SPACE  4,10
**        SPL - SET PP LOCK.
*
*         THIS ROUTINE SET THE PP REQUEST QUEUE LOCK IN
*         THE PP INTERFACE TABLE.
*
*         EXIT   (A) = 0, IF LOCK SET,
*                   <> 0, IF LOCK COULD NOT BE SET.
*
*         USES   T5, T7.
*
*         CALLS  SLR, SLW.


 SPL      SUBR
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    SLR         SET LOCK RESERVATION
          RJM    SLW         SET LOCK WORD
          UJK    SPLX        EXIT
 SPR      SPACE  4,10
**        SPR - SEND PP RESPONSE.
*
*         THIS ROUTINE WILL WRITE THE SPECIFIED RESPONSE TO
*         THE CM RESPONSE BUFFER, UPDATE THE 'IN' POINTER AND
*         OPTIONALLY INTERRUPT THE PROCESSOR.
*
*         ENTRY  (A) = PP RESPONSE BUFFER ADDRESS,
*                (INN) = CURRENT 'IN' POINTER,
*                (LIM) = RESPONSE BUFFER LIMIT.
*
*         EXIT   (INN) = NEW 'IN' POINTER.
*
*         USES   T2 - T8.
*
*         MACROS LOADC.


 SPR      SUBR               ENTRY/EXIT
          STDL   T8
          STML   SPRA        INSTRUCTION MODIFICATION FOR BUFFER
          RJM    PRB         PREPARE RESPONSE BUFFER

 SPR10    BSS
 IVB0     IF     DEF,IVB0
          LRDL   CM.PIT
          LDDL   CM.PIT+1    CM ADDRESS OF PP INTERFACE TABLE
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
 IVB4     ENDIF
          ADN    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   T4          READ OUT POINTER

*         CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDDL   INN         IN POINTER
          STDL   T1
          SBDL   T7          OUT POINTER
          MJN    SPR20       IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   T7
 SPR20    LDML   /RS/P.RESPL,T8  GET RESPONSE LENGTH
          STDL   INPNT
          LDN    0
          STDL   T2          CLEAR WRAP FLAG
          LDDL   INN
          RADL   INPNT       IN + RESPONSE LENGTH
          SBDL   T7          CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          PJN    SPR10       IF NOT ENOUGH ROOM IN BUFFER, LOOP
          LDDL   INPNT
          STDL   INN         UPDATE 'IN' POINTER
          SBDL   LIM
          MJN    SPR40       IF IN + RESPONSE LENGTH .LT. LIMIT
          STDL   INN         IN + RESPONSE LENGTH - LIMIT = NEW IN POINTER
          AODL   T2          2 BLOCK WRITES REQUIRED

*         WRITE RESPONSE TO CM.

 SPR40    LDDL   T1          ORIGINAL 'IN' POINTER
          SHN    -3
          STDL   T3          'IN' POINTER IN WORDS
          LDML   /RS/P.RESPL,T8  CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          STDL   T5
          LDDL   T2
          ZJN    SPR50       IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   T1          ORIGINAL 'IN' POINTER
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON FIRST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADDL   T8
          STML   SPRB        RESPONSE ADDRESS FOR SECOND BLOCK WRITE
 SPR50    LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD IN OFFSET
          CWML   **,T4       WRITE RESPONSE TO CM

*         CWML   (A),T4      ENTRY CONDITION SPECIFIES BUFFER ADDRESS

 SPRA     EQU    *-1
          LDDL   T5          RESPONSE LENGTH
          SBDL   T4
          ZJN    SPR70       IF ONLY 1 BLOCK WRITE REQUIRED
          STDL   T5          RESPONSE LENGTH - (LIMIT - IN)
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          LMC    400000B
          CWML   **,T5       WRITE SECOND PART OF RESPONSE TO CM
                             (BEGINNING OF RESPONSE BUFFER)
 SPRB     EQU    *-1

*         SET UP INTERRUPT PROCESSOR INSTRUCTION IF INTERRUPT IS SELECTED.

 SPR70    BSS
          LDML   RQ+/RQ/P.INT  CHECK IF INTERRUPT WAS SELECTED
          LPC    /RQ/K.INT
          ZJN    SPR80       IF INTERRUPT WAS NOT SELECTED

*         AFTER THE FIRST REQUEST SELECTING INTERRUPT IS PROCESSED,
*         ALL FOLLOWING RESPONSES WILL ALSO SEND AN INTERRUPT.

          LDML   RQ+/RQ/P.PORT  GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RQ/L.PORT+/RQ/N.PORT
          LPN    /RQ/M.PORT
          ADC    .INPN
          STML   INTPRC
 SPR80    BSS    0
          RJM    UIP         UPDATE 'IN' POINTER
          RJM    IRC         INITIALIZE RESPONSE CODES
          UJK    SPRX        EXIT
 SRL      SPACE  4,10
**        SRL - SEND RESUME LINK.
*
*         THIS ROUTINE WILL SEND A *RESUME LINK*
*         COMMAND TO THE IVB. THE IVB MUST HAVE ALREADY
*         BEEN SELECTED.
*
*         CALLS  SCP.
*

 SRL      SUBR               ENTRY/EXIT
          LDN    RRL
          STML   RTCNT
 SRL10    LDN    B.IP-/IP/B.LEN  SET LENGTH
          STML   CPBF+/IP/P.LEN
          LDK    O.RL+0#80   SET RESUME LINK COMMAND
          STML   CPBF+/IP/P.OPCODE
          RJM    SCP         SEND COMMAND PACKET
          ZJK    SRLX        IF NO ERRORS
          PJN    SRL20       IF STATUS RECEIVED
          RJM    ALC         ABORT LAST COMMAND
          NJK    SRLX        IF RESET
 SRL20    SOML   RTCNT       DECREMENT RETRY COUNT
          NJN    SRL10       IF RETRY'S REMAINING
          LDN    DS.ILR
          STML   DSTATE
          UJK    SRLX        EXIT
 SRS      SPACE  4,10
**        SRS - SEND REPORT STATUS.
*
*         THIS ROUTINE SENDS A REPORT STATUS COMMAND
*         TO THE IVB. THE COMMAND WILL REPORT THE
*         OPENING OR CLOSING OF THE SEND GLOBAL FLOW
*         CONTROL WINDOW.
*
*         ENTRY  (INPOK) = STATE OF SEND WINDOW.
*
*         EXIT   (A) = 0, IF COMMAND SENT SUCCESSFULLY,
*                   <> 0, IF UNABLE TO SEND COMMAND.
*

 SRS      SUBR               ENTRY/EXIT
          TRACE  (SRS,IP,STATUS,INPOK)
          LDN    RRL
          STML   RTCNT
 SRS10    LDDL   INPOK
          SHN    8
          STML   CPBF+P.IP+/STATP/P.STATUS  SETUP STATUS
          LDN    B.IP-/IP/B.LEN+B.STATP  SET LENGTH
          STML   CPBF+/IP/P.LEN
          LDK    O.RSTAT+0#80   SET REPORT STATUS COMMAND
          STML   CPBF+/IP/P.OPCODE

*         SETUP REST OF GLOBAL FLOW CONTROL STATUS PARAMETER

          LDN    B.STATP-/STATP/B.PARML
          SHN    /STATP/N.PARML
          ADK    PID.GFC
          STML   CPBF+P.IP+/STATP/P.PARML  SETUP LENGTH AND ID FIELDS

          RJM    SCP         SEND COMMAND PACKET
          ZJK    SRSX        IF NO ERRORS
          PJN    SRS20       IF STATUS RECEIVED
          RJM    ALC         ABORT LAST COMMAND
          NJK    SRSX        IF RESET
 SRS20    SOML   RTCNT       DECREMENT RETRY COUNT
          NJN    SRS10       IF RETRY'S REMAINING
          LDN    DS.ILR
          STML   DSTATE
          UJK    SRSX        EXIT

 SSL      SPACE  4,10
**        SSL - SEND SUSPEND LINK.
*
*         THIS ROUTINE SENDS A SUSPEND LINK COMMAND
*         TO THE IVB. THE IVB MUST HAVE ALREADY BEEN
*         SELECTED.
*
*         ENTRY  (RPBF) = *SUSPEND LINK* RESPONSE
*
*         EXIT   (A) = 0, IF SUCCESSFUL,
*                   <> 0, IF UNABLE TO SEND COMMAND.
*
*         CALLS  CRC, SCP.
*

 SSL      SUBR
          LDN    RRL
          STML   RTCNT
 SSL10    RJM    CRC         COPY RESPONSE TO COMMAND BUFFER
          LDN    0
          STML   CPBF+/IP/P.REFNO  INITIALIZE COMMAND REFERENCE NUMBER
          RJM    SCP         SEND COMMAND PACKET
          ZJK    SSLX        IF NO ERRORS
          PJN    SSL20       IF STATUS RECEIVED
          RJM    ALC         ABORT LAST COMMAND
          NJK    SSLX        IF RESET
 SSL20    SOML   RTCNT       DECREMENT RETRY COUNT
          NJN    SSL10       IF RETRY'S REMAINING
          LDN    DS.ILR
          STML   DSTATE
          UJK    SSLX        EXIT
 STB      SPACE  4,10
**        STB - SEARCH TABLE.
*
*         THIS ROUTINE WILL PERFORM A TABLE SEARCH ON
*         THE SPECIFIED TABLE.  THE TABLE MUST HAVE TWO
*         WORDS PER ENTRY.
*
*         ENTRY  (A) = ADDRESS - 2 OF TABLE TO SEARCH.
*                (STBI) = KEY FOR SEARCH.
*
*         EXIT   (A) = 0, IF NO MATCH FOUND.
*                (A) = ADDRESS OF PROCESSOR OR FUNCTION TO
*                      ISSUE TO MCI.
*
*         USES   T2.


 STB      SUBR               ENTRY/EXIT
          STDL   T2
 STB10    LDN    2
          RADL   T2
          LDIL   T2          GET NEXT ENTRY
          ZJN    STBX        IF END OF TABLE
          LMML   STBI
          NJN    STB10       IF NOT A MATCH
          AODL   T2
          LDIL   T2          GET FUNCTION CODE OR PROCESSOR ADDRESS
          UJK    STBX        EXIT WITH ADDRESS
 STD      SPACE  4,16
**        STD - SAVE TRACE DATA.
*
*         THIS ROUTINE IS USED FOR DEBUGGING PURPOSES AND IS USED IN
*         CONJUNCTION WITH THE TRACE MACRO. A CIRCULAR BUFFER IS KEPT
*         AT LOCATIONS 30000B THRU 37777B. LOCATION STDA CONTAINS THE
*         ADDRESS OF THE NEXT ENTRY IN THE BUFFER. EACH ENTRY IS 10B
*         WORDS LONG AND SAVES THE A REGISTER, CALLER ADDRESS, CLOCK,
*         PLUS UP TO FIVE VARIABLES.
*
*         EXIT   (3XXX0) = CALLER ADDRESS.
*                (3XXX1) = (A).
*                (3XXX2) = CLOCK.
*                (3XXX3 - 3XXX7) = VALUE OF VARIABLE LIST.
*
*         USES   LOC 0.


 STD      SUBR
          STDL   0           SAVE (A)
          LDC    15000B
*         LDC    30000B
 STDA     EQU    *-1
          STML   STDC
          ADN    1
          STML   STDB
          ADN    1
          STML   STDD
          ADN    1
          STML   STDF
          ADN    5
          STM    STDA
          LDDL   0           SAVE (A)            WORD 1
          STML   **
 STDB     EQU    *-1
          LDML   STD         SAVE CALL ADDRESS   WORD 0
          STML   **
 STDC     EQU    *-1
          STDL   0
          IAN.   14B
          STML   **          SAVE TIME           WORD 2
 STDD     EQU    *-1
          AOML   STD         ADJUST RETURN ADDRESS
          LDIL   0           GET PARAMETER LIST
          ZJN    STD20       IF NO PARAMETERS
          STDL   0
 STD10    LDIL   0
          ZJN    STD20       IF END OF PARAMETERS
          STML   STDE
          AODL   0
          LDML   **
 STDE     EQU    *-1
 STD20    STML   **
 STDF     EQU    *-1
          AOML   STDF
          LPN    7
          NJN    STD10       IF NOT COMPLETE
*
*
          LDM    STDA
          NJK    STDX
          LDC    5000B
          STM    STDA
*
*
          UJK    STDX
 STR      SPACE  4,10
**        STR - SEND TERMINATION RESPONSE.
*
*         THIS ROUTINE TERMINATES A PERIPHERAL REQUEST BY SENDING
*         A SOLICITED RESPONSE AND DELINKING THE REQUEST.
*
*         CALLS  DLR, PRC, UIP, WRB, ZRE.


 STR      SUBR               ENTRY/EXIT
          RJM    PRB         PUT RESPONSE CODES IN RESPONSE
          RJM    DUR         DELINK REQUEST
          LDC    RS          RESPONSE BUFFER
          RJM    SPR         WRITE RESPONSE BUFFER
          UJN    STRX        RETURN
 SUR      SPACE  4,10
**        SUR - SEND UNSOLICITED RESPONSE.
*
*         THIS ROUTINE SENDS AN UNSOLICITED RESPONSE
*         TO THE CPU.
*
*         ENTRY  (A) = UNSOLICITED RESPONSE CODE.
*
*         CALLS  PRB, SPR.


 SUR      SUBR
          STML   UNSC        UNSOLICITED RESPONSE CODE
          LDN    R.UNS
          STML   RESPC       UNSOLICITED RESPONSE
          RJM    PRB         PREPARE RESPONSE BUFFER
          LDC    RS
          RJM    SPR         SEND PP RESPONSE
          UJK    SURX        EXIT
 UGS      SPACE  4,10
**        UGS - UPDATE GLOBAL STATUS.
*
*         THIS ROUTINE WILL UPDATE THE PP'S INTERNAL
*         GLOBAL FLOW CONTROL STATUS VARIABLES BASED
*         ON THE STATUS RECEIVED FROM THE IVB.
*
*         ENTRY  (A) = STATUS BYTE.
*
*         EXIT   (SNDOK) AND (IP) UPDATED APPROPRIATELY.
*
*         USES   T1.


 UGS      SUBR               ENTRY/EXIT
          STDL   T1
          LPN    /STATP/K.INPOK
          STDL   IP          UPDATE INPUT PENDING FLAG
          LDDL   T1          GLOBAL FLOW CONTROL STATUS BYTE
          LPN    /STATP/K.SNDOK
          SHN    -/STATP/SNDOK
          STDL   SNDOK       UPDATE SEND OK FLAG
          TRACE  (UGS,T1)
          UJN    UGSX        EXIT
 UIP      SPACE  4,10
**        UIP - UPDATE IN POINTER.
*
*         THIS ROUTINE UPDATES THE 'IN' POINTER IN CM,
*         SETS THE CM INTERRUPT WORD NON-ZERO, AND
*         INTERRUPTS THE CPU.
*
*         ENTRY  (INN) = NEW 'IN' POINTER.
*
*         USES   P1, P2, P3, P4.
*
*         MACROS LOADC.


 UIP      SUBR               ENTRY/EXIT
          LDN    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDDL   INN         NEW 'IN' POINTER
          STDL   P4
 IVB0     IF     DEF,IVB0
          LRDL   CM.PIT
          LDDL   CM.PIT+1    CM ADDRESS OF PP INTERFACE TABLE
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
 IVB4     ENDIF
          ADN    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   P1          WRITE NEW 'IN' POINTER TO CM

*         SET CM INTERRUPT WORD NON-ZERO AND CONDITIONALLY INTERRUPT
*         THE CPU.

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   PPNO-3      SET LAST BYTE NONZERO
          ERRNZ  R.UNS
          LDML   RESPC       RESPONSE CODE
          ZJN    UIP10       IF UNSOLICITED RESPONSE
          SOML   INTRRPT
          PJN    UIP20       IF NOT TIME TO INTERRUPT
 UIP10    BSS    0
 IVB0     IF     DEF,IVB0
          LDN    0           I0 HARDWARE PROBLEM
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LDML   CM.INT+2    SET VALID ADDRESS IN A
          LMC    400000B     FOR I4 HARDWARE PROBLEM
 IVB4     ENDIF
 INTPRC   PSN    0           INTERRUPT OR PSN (MODIFIED)
          LDN    8
          STML   INTRRPT     RESET INTERRUPT INTERVAL
 UIP20    UJK    UIPX        EXIT
 URT      SPACE  4,10
**        URT - UPDATE REAL TIME CLOCK.
*
*         *******************************************************************
*         * NOTE: THIS ROUTINE WILL UPDATE THE CLOCK WHICH IS USED TO       *
*         * DETERMINE WHEN TO SEND NO-OPS TO THE IVB. DURING PERIODS        *
*         * WHEN LARGE BLOCKS (32K) ARE BEING TRANSFERED IT IS POSSIBLE     *
*         * THAT SOME ACCURACY COULD BE LOST. THIS SHOULD NOT BE A PROBLEM  *
*         * AS NO-OPS ARE NOT REQUIRED UNLESS THERE HAS BEEN NO ACTIVITY.   *
*         *******************************************************************
*
*         ENTRY  (CLCUR) = PREVIOUS SYSTEM CLOCK VALUE.
*
*         EXIT   (CLCUR) = NEW SYSTEM CLOCK VALUE.
*                CLMSC, CLMLS, AND CLSEC UPDATED.


 URT      SUBR
          LDDL   CLCUR       SAVE CURRENT CLOCK
          STDL   T0
          IAN    14B         GET NEW CLOCK VALUE
          STDL   CLCUR
          SBDL   T0
          PJN    URT10       IF CLOCK HASNT WRAPPED
          ADC    10000B
 URT10    RADL   CLMCS       UPDATE MICROSECOND PORTION OF CLOCK
          LDDL   CLMCS
          ADC    -2000
          MJN    URTX        IF LESS THAN 2 MILLISECONDS
          STDL   CLMCS
          LDN    2
          RADL   CLMLS       UPDATE MILLISECOND PORTION OF CLOCK
          ADC    -1000
          MJN    URTX        IF LESS THAN 1 SECOND
          STDL   CLMLS
          AODL   CLSEC       UPDATE SECOND PORTION OF CLOCK
          UJK    URTX        EXIT
 VBR      SPACE  4,13
**        VBR - VERIFY BOARD READY.
*
*         THIS ROUTINE WILL TRY TO DETERMINE IF THE IVB
*         IS STILL AVAILABLE. THIS IS ACCOMPLISHED BY MASTER
*         CLEARING THE BOARD AND VERIFYING THAT ALL LINES DROP.
*         THIS IS FOLLOWED BY ANOTHER SELECT.
*
*         *******************************************************************
*         * NOTE: THIS ROUTINE WILL EXIT TO THE MAIN LOOP IF THE IVB IS     *
*         *       NOT AVAILABLE.                                            *
*         *******************************************************************
*
*         CALLS  MCC, SEL, RAR.


VBR10     RJM    SEL         SELECT DEVICE
          LDN    0

 VBR      SUBR               ENTRY/EXIT
          RJM    MCC         MASTER CLEAR
          LDC    H00E1
          RJM    RAR         READ IPI STATUS REGISTER
          LPC    /IPISR/K.ALLIN
          ZJN    VBR10       IF ALL LINES DROPED
          LDN    DS.ILR
          STDL   DSTATE
          LJM    MCL         EXIT RESET BOARD
 IVB4     IF     DEF,IVB4
 WTC      SPACE  4,15
**        WTC - WAIT TRANSFER COMPLETE.
*
*         THIS ROUTINE WILL WAIT FOR A DMA TRANSFER TO COMPLETE.
*
*         EXIT   (A) = 0, IF TRANSFER COMPLETE,
*                    <> 0, IF RECOVERABLE ERROR.
*                (WC) = PP WORDS NOT TRANSFERED IF A <> 0.
*
*         USES   T8
*
*         CALLS  CEP, EFP, ICF, RAR.
*


 WTC50    BSS
          LDN    0

 WTC      SUBR
          LDC    64          MULTIPLY LOOP TO 15 SECONDS
          STML   TIMEX
 WTC05    BSS    0
          LDC    20000
          STDL   T8          T8 CONTROLS THE TIMEOUT
 WTC10    BSS
          LDC    H0700
          RJM    RAR         READ OPERATIONAL STATUS
          STML   OPSTAT      SAVE OPERATIONAL STATUS
          SHN    17-/DMAOSR/CHIN
          PJN    WTC50       IF TRANSFER COMPLETE
          SODL   T8
          NJN    WTC10       IF TIMEOUT NOT EXPIRED
          SOML   TIMEX
          NJN    WTC05       IF NOT COMPLETE
          LDC    H0A00       READ T REGISTER
          RJM    RAR
          SHN    -1
          STDL   WC          SAVE WORD COUNT
          LDC    H0800       DMA TERMINATE FUNCTION
          RJM    ICF         SEND THE FUNCTION
          LDC    H00E1       READ STATUS REGISTER FUNCTION
          RJM    RAR
*         STDL   STATUS
          SHN    17-/IPISR/SLAI
          PJN    WTC30       IF SLAVE IN DROPPED
          LDN    E30         SLAVE IN DID NOT DROP
          STML   IOERR+/ILD/P.SCODE
          LDN    DS.ILR
          STML   DSTATE
          LDC    IOERR
          RJM    CEP         LOG ERROR  (NO RETURN)

 WTC30    BSS
          LDN    E07         INCOMPLETE TRANSFER
          STML   IOERR+/ILD/P.SCODE  SYMPTOM CODE
          UJK    WTCX        EXIT
 WTE      SPACE  4,10
**        WTE - WAIT T-PRIME REGISTER EMPTY.
*
*         THIS ROUTINE WILL WAIT FOR THE T' REGISTER
*         TO EMPTY. THE T' REGISTER MUST BE EMPTY WHEN
*         STARTING OR CONTINUING A DMA I/O OPERATION OR
*         DATA LOSS/CORRUPTION WILL OCCUR.
*
*         EXIT   (A) = 0, IF T' REGISTER EMPTY,
*                    <> 0, IF ERROR OCCURRED.
*                (WC) = PP WORDS NOT TRANSFERED IF A <> 0.
*
*         USES   OPSTAT, STATUS, T8, P6.
*
*         CALLS  CEP, EFP, ICF, RAR.


 WTE60    LDN    0


 WTE      SUBR
          LDC    64          MULTIPLY LOOP TO 15 SECONDS
          STML   TIMEX
 WTE05    BSS    0
          LDC    20000
          STDL   T8          T8 CONTROLS THE TIMEOUT
 WTE10    BSS
          LDC    H0700
          RJM    RAR         READ OPERATIONAL STATUS
          STML   OPSTAT      SAVE OPERATIONAL STATUS
          SHN    17-/DMAOSR/TEMP
          MJN    WTE60       IF T PRIME REGISTER EMPTY
          SODL   T8
          NJN    WTE10       IF TIMEOUT NOT EXPIRED
          SOML   TIMEX
          NJN    WTE05       IF NOT COMPLETE
          LDC    H0A00       READ T REGISTER
          RJM    RAR
          SHN    -1
          STDL   WC          SAVE WORD COUNT
          LDC    H0800       DMA TERMINATE FUNCTION
          RJM    ICF         SEND THE FUNCTION
          LDC    H00E1       READ STATUS REGISTER FUNCTION
          RJM    RAR
*         STDL   STATUS
          SHN    17-/IPISR/SLAI
          PJN    WTE30       IF SLAVE IN DROPPED
          LDN    E30         SLAVE IN DID NOT DROP
          STML   IOERR+/ILD/P.SCODE
          LDN    DS.ILR
          STML   DSTATE
          LDC    IOERR
          RJM    CEP         LOG ERROR  (NO RETURN)

 WTE30    BSS
          LDN    E07         INCOMPLETE TRANSFER
          STML   IOERR+/ILD/P.SCODE  SYMPTOM CODE
          UJK    WTEX        ERROR EXIT
 IVB4     ENDIF
 WRP      SPACE  4,30
**        WRP - WRITE PROCESSOR
*
*         THIS ROUTINE PROCESSES THE WRITE BYTES COMMAND.  THE PROCESSING
*         IS DONE IN TWO PARTS.  FIRST THE CCP HEADER IS READ INTO THE PP
*         AND AN IPI LEVEL 3 COMMAND IS CREATED USING THE HEADER AND THIS
*         COMMAND IS SENT TO THE SLAVE.  IF THE HEADER INDICATES USER DATA,
*         THEN A DMA TRANSFER IS SET UP TO SEND THIS DATA.  THE TRANSFER
*         INCLUDES ANY MESSAGE PROPER (OTHER PROTOCOL HEADERS) INCLUDED IN
*         THE CCPDU.  RECORDS WRITTEN TO THE IVB MAY BE IN FRAGMENTS
*         SCATTERED THROUGHOUT MEMORY.  THE FIRST BYTE OF USER DATA
*         TRANSFERRED MUST BE WORD ALIGNED.  CONSEQUENTLY, IT IS NECESSARY
*         FOR USER DATA TO START AND END ON WORD BOUNDARYS EXCEPT THE LAST
*         BUFFER.  OTHERWISE THE PP WOULD NOT BE ABLE TO USE THE DMA
*         INSTRUCTIONS.  WITH WORD ALIGNMENT THEN, EACH FRAGMENT IS WRITTEN
*         IN A MULTIPLE OF 64 BIT CENTRAL MEMORY WORDS USING THE DIRECT
*         MEMORY ACCESS(DMA) CHANNEL INSTRUCTION ON THE I0, OR AN IPI
*         ADAPTOR FUNCTION ON THE I4A.
*
*         ENTRY  RQ = UNIT REQUEST.
*
*         USES   CML, CMLISTL, T1, T2, P6.
*
*         CALLS  DMW, ESS, OWC, STR, UGS.


 WRP      SUBR               ENTRY/EXIT
          LDN    RRL
          STML   RTCNT
 WRP10    RJM    OWC         SEND COMMAND PACKET
          NJN    WRPX        IF ERRORS
          LDML   CPBF+P.IP+/CCP/P.LEN2  CCPDU DATA LENGTH
          SBN    B.CCP-/CCP/B.PARML-/CCP/B.PARMID
          ZJK    WRP80       IF NO USER DATA
          RJM    DMW         COMPLETE DATA TRANSFER
          ZJN    WRP20       IF NO ERRORS
          LDN    0
          UJN    WRP30       SEND UNSUCCESSFUL

 WRP20    LDC    /STATP/K.SUC
 WRP30    ADML   INPOK
          RJM    ESS         GET ENDING STATUS
          ZJN    WRP40       IF NO  ERRORS GETTING STATUS
          LDML   MSTAT
          STML   RSTAT
          LDML   CPBF+/IP/P.REFNO
          STML   RSEQ
          RJM    RSS         REQUEST SLAVE STATUS

 WRP40    LDDL   STATUS
          SHN    17-/STATP/SUC
          MJK    WRP70       IF  SUCCESSFULL
          SOML   RTCNT
          SRU    IOERR,RTCNT,REC.I
          LDC    IOERR
          RJM    IMS         INCLUDE MASTER STATUS
          LDC    IOERR
          RJM    ISS         INCLUDE SLAVE STATUS
          LDML   IOERR+/ILD/P.SCODE
          NJN    WRP50       IF PP DETECTED ERROR
          RJM    ASS         ANALYZE SLAVE STATUS
 WRP50    LDC    IOERR
          RJM    CEP         LOG ERROR
          DPM    CPBF+/IP/P.REFNO  DECREMENT REFERENCE NUMBER
          LDML   RTCNT
          NJK    WRP10       RETRY REQUEST
 WRP60    LDN    DS.ILR
          STDL   DSTATE
          UJK    WRPX        EXIT

 WRP70    LDDL   STATUS
          RJM    UGS         UPDATE GLOBAL STATUS
 WRP80    LDML   BYTCNT
          STML   RS+/RS/P.XFER+1
          RJM    IRP         INITIALIZE RESPONSE BUFFER
          RJM    STR         SEND TERMINATION RESPONSE
          LDN    0
          UJK    WRPX        EXIT
          TITLE  INITIALIZATION.
 IPD      SPACE  4,10
**        IPD - INITIALIZE PP DRIVER.
*
*         THIS ROUTINE WILL ACCESS ALL PP CM TABLES
*         AND VALIDATE THEM. APPROPRIATE PP CELLS WILL
*         ALSO BE INITIALIZED.
*
*         ENTRY  (CM.PIT) = RMA ADDRESS OF PP INTERFACE TABLE (UNFORMATTED).
*
*         EXIT   PP TABLES VALIDATED AND PP IN IDLE STATE.

 IPD      BSS    0
          LDDL   P1
          STML   DRNAME
          LDDL   P2
          STML   DRNAME+1    STORE PP DRIVER NAME IN WORDS 100B AND 101B
          RJM    LPT         LOCATE PP INTERFACE TABLE
          RJM    LUT         LOCATE UNIT INTERFACE TABLE
          RJM    LMT         LOCATE MASTER CONTROL TABLE
          RJM    CHG         SET UP CHANNEL INSTRUCTIONS
          RJM    MCC         MASTER CLEAR CHANNEL
          LDN    1
          STML   BPCNT+SMINDX  INITIALIZE BUFFER NEEDED COUNT
          UJK    MCL         MAIN CONTROL LOOP
          EJECT
 LBP      SPACE  4,20
**        LBP - LOCATE BUFFER POOLS.
*
*         THIS ROUTINE ESTABLISHES ACCESS TO THE PP BUFFER
*         POOLS AND PERFORMS VALIDATION ON THE BUFFER POOL
*         DESCRIPTORS.
*
*         EXIT   (A) = 0, IF NO ERRORS,
*                   <> 0, IF ERRORS,
*                (BPSIZE) = SIZE OF BUFFER POOLS (SMALLEST TO LARGEST).
*
*         USES   P1, P2, P3.
*
*         MACROS LOADC, LOADF.

 LBP      SUBR               ENTRY/EXIT
          ERRNG  MAXBPD-1
          LDN    MAXBPD
          STDL   P3
          LDN    0
          STDL   P2          BUFFER POOL INDEX
          LDN    C.BPD
          STDL   WC          LENGTH OF BUFFER POOL DESCRIPTOR
 IVB0     IF     DEF,IVB0
          LRML   MCT+/MCT/P.BPDESC
          LDML   MCT+/MCT/P.BPDESC+1
          SHN    -3
          STDL   CM.BPD+1
          SRDL   CM.BPD
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADF  MCT+/MCT/P.BPDESC
          STDL   CM.BPD+2
          SRD    CM.BPD
 IVB4     ENDIF
 LBP10    CRML   BPD,WC      READ BUFFER POOL DESCRIPTOR
          STDL   P1
          LDML   BPD+/BPD/P.LEN
          NJN    LBP20       IF BUFFER LENGTH TOO LARGE
          LDML   BPD+/BPD/P.LEN+1
          ZJK    LBP50       IF INVALID BUFFER LENGTH
          STML   BPSIZE,P2    SAVE BUFFER LENGTH
          LDML   BPD+/BPD/P.IN
          LPN    7
          NJN    LBP20       IF INVALID 'IN' POINTER
          LDML   BPD+/BPD/P.PPOUT
          LPN    7
          NJN    LBP20       IF INVALID 'OUT' POINTER
          LDML   BPD+/BPD/P.LIMIT
          LPN    7
 LBP20    NJN    LBP50       IF INVALID LIMIT
          LDML   BPD+/BPD/P.BPRMA+1
          LPN    7
          NJN    LBP50       IF INVALID BUFFER POOL ADDRESS
          SODL   P3
          ZJN    LBP60       IF NO MORE POOLS
          AODL   P2
 IVB0     IF     DEF,IVB0
          LRDL   CM.BPD      CM ADDRESS OF NEXT DESCRIPTOR
          LDDL   P1
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADC  CM.BPD,P1   CM ADDRESS OF NEXT DESCRIPTOR
 IVB4     ENDIF
          UJK    LBP10

 LBP50    LDC    E324
 LBP60    UJK    LBPX        EXIT
 LMT      SPACE  4,15
**        LMT - LOCATE MASTER CONTROL TABLE.
*
*         ESTABLISHES ACCESS TO THE MASTER CONTROL TABLE.
*
*         ENTRY  (CM.URQ - CM.URQ+1) = (R) PART OF MASTER CONTROL TABLE FWA.
*                (CM.MCT) = (A) PORTION OF MASTER CONTROL TABLE FWA.
*
*         CALLS  CVM, DBP.
*
*         MACROS LOADC.


 LMT      SUBR               ENTRY/EXIT

*         VALIDATE MASTER CONTROL TABLE.

          RJM    CVM         CHECK FOR VALID MASTER CONTROL TABLE
          NJN    *           IF INVALID MASTER CONTROL TABLE  --HANG--

*         DEFINE AND VALIDATE BUFFER POOLS.

          RJM    LBP         LOCATE BUFFER POOLS
          ZJN    LMTX        IF VALID BUFFER POOLS  --EXIT--
          UJN    *           INVALID BUFER POOLS, SO  --HANG--
          EJECT
**        LPT - LOCATE PP INTERFACE TABLE.
*
*         ESTABLISHES ACCESS TO THE PP INTERFACE TABLE.
*
*         ENTRY  (CM.PIT) = CENTRAL MEMORY BYTE ADDRESS OF PP INTERFACE TABLE.
*
*         EXIT   (CM.PIT) = REFORMATTED PP INTERFACE TABLE ADDRESS.
*
*         USES   WC.
*
*         CALLS  CVI, CVR.
*
*         MACROS LOADC, REFAD.


 LPT      SUBR               ENTRY/EXIT
 IVB0     IF     DEF,IVB0
          LDDL   CM.PIT+1
          SHN    -3
          STDL   CM.PIT+1    REFORMAT PP INTERFACE TABLE ADDRESS
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          REFAD  CM.PIT,CM.PIT  REFORMAT PP INTERFACE TABLE ADDRESS
 IVB4     ENDIF

*         READ PP INTERFACE TABLE.

          LDN    C.PIT       LENGTH OF PP INTERFACE TABLE
          STDL   WC
 IVB0     IF     DEF,IVB0
          LRDL   CM.PIT
          LDDL   CM.PIT+1    CM ADDRESS OF PP INTERFACE TABLE
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
 IVB4     ENDIF
          CRML   IPIT,WC
          RJM    CVR         CHECK FOR VALID RESPONSE BUFFER
          NJN    *           IF INVALID RESPONSE BUFFER  --HANG--
          RJM    CVI         CHECK FOR VALID PP INTERFACE TABLE
          NJN    *           IF INVALID PP INTERFACE TABLE  --HANG--
          LDML   IPIT+/PIT/P.PPNO
          STDL   PPNO        PP NUMBER

*         REFORMAT CM ADDRESSES OF INTERRUPT WORD AND CHANNEL INTERLOCK TABLE.

 IVB0     IF     DEF,IVB0
          LDML   IPIT+/PIT/P.CHAN
          STML   CM.CHAN
          LDML   IPIT+/PIT/P.CHAN+1
          SHN    -3
          STML   CM.CHAN+1   REFORMAT CHANNEL TABLE ADDRESS
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          REFAD  IPIT+/PIT/P.CHAN,CM.CHAN  REFORMAT CHANNEL TABLE ADDRESS
 IVB4     ENDIF
          REFAD  IPIT+/PIT/P.INT,CM.INT  REFORMAT INTERRUPT WORD ADDRESS
          UJK    LPTX
          EJECT
 LUT      SPACE  4,15
**        LUT - LOCATE UNIT INTERFACE TABLE.
*
*         ESTABLISHES ACCESS TO THE UNIT INTERFACE TABLE.
*
*         ENTRY  (CM.PIT) = CM ADDRESS OF PP INTERFACE TABLE.
*
*         EXIT   (A) = 0.
*                (UD) = UNIT DESCRIPTOR ACCESSIBLE BY THIS PP.
*
*         USES   WC.
*
*         CALLS  CVD, CVU.
*
*         MACROS LOADC, LOADF.


 LUT      SUBR               ENTRY/EXIT
          LDN    C.UD        UNIT DESCRIPTOR LENGTH
          STDL   WC
 IVB0     IF     DEF,IVB0
          LRDL   CM.PIT
          LDDL   CM.PIT+1    CM ADDRESS OF PP INTERFACE TABLE
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
 IVB4     ENDIF
          ADN    C.PIT
          CRML   UD,WC       READ UNIT DESCRIPTOR
          RJM    CVD         CHECK FOR VALID UNIT DESCRIPTOR
          NJN    *           IF INVALID UNIT DESCRIPTOR  --HANG--
          LDML   UD+/UD/P.CHAN
          SHN    /UD/L.CHAN+/UD/N.CHAN+2
          LPN    37B
          STML   CHAN        CHANNEL NUMBER
          LDML   UD+/UD/P.LU
          STML   RS+/RS/P.LU  STORE LOGICAL UNIT NUMBER IN STD RESPONSE
          STML   LRS+/RS/P.LU STORE UNIT NUMBER IN LOG RESPONSE
          LDML   UD+/UD/P.CNTRLR
          LPN    7
          STDL   T1          SLAVE ADDRESS
          STML   IIRA        SETUP SLAVE ADDRESS FOR RESET
          RAML   SELA        SETUP SLAVE ADDRESS FOR SELECT
          LDDL   T1          SLAVE ADDRESS
          SHN    8
          ADC    0#FF        SET FACILITY ADDRESS
          STML   CPBF+/IP/P.ADDR  SET UP SLAVE AND FACILITY ADDR IN COMMAND
          LDM    SAM,T1      GET SLAVE ADDRESS MASK
          STM    CFIA
          STM    SELB
 IVB4     IF     DEF,IVB4
          LDML   UD+/UD/P.CHAN  GET PORT NUMBER
          LPC    100B
          SHN    5
          RAML   MCCA
 IVB4     ENDIF
          LDN    C.UIT       UNIT INTERFACE TABLE LENGTH
          STDL   WC
          LOADF  UD+/UD/P.UQT  REFORMAT CM ADDRESS OF UNIT INTERFACE TABLE
          CRML   UIT,WC      READ UNIT INTERFACE TABLE
          RJM    CVU         CHECK FOR VALID UNIT INTERFACE TABLE
          NJN    *           IF INVALID UNIT INTERFACE TABLE  --HANG--
          UJK    LUTX        EXIT

 SAM      DATA   1,2,4,8,16,32,64,128  SLAVE ADDRESS MASKS

 SAVAD    SPACE  4,10
**        SAVAD - SAVE REFORMATTED CM ADDRESSES.
*
*         THIS ROUTINE IS CALLED ONLY DURING INITIALIZATION
*         AND ONLY BY THE *REFAD* MACRO.
*
*         USES   T2.
          SPACE  2
 SAVAD    SUBR               ENTRY/EXIT
          STML   2,T2
          LDDL   CMADR
          STI    T2
          LDDL   CMADR+1
          STML   1,T2
          UJN    SAVADX      EXIT
 CVM      SPACE  4,10
**        CVM - CHECK FOR VALID MASTER CONTROL TABLE.
*
*         ENTRY  (CM.URQ - CM.URQ+1) = (R) PART OF MASTER CONTROL TABLE FWA.
*                (CM.MCT) = (A) PORTION OF MASTER CONTROL TABLE FWA.
*
*         EXIT   (A) = 0, IF VALID MASTER CONTROL TABLE.
*                    <> 0, IF INVALID.
*
*         USES   P1 - P4, T1, WC.


 CVM      SUBR               ENTRY/EXIT
          LDN    0
          STDL   T1          UNIT INTERFACE ERROR CODE

*         READ MASTER CONTROL TABLE.

          LDN    C.MCT       LENGTH OF MASTER CONTROL TABLE
          STDL   WC

 CVM20    BSS    0
 IVB0     IF     DEF,IVB0
          LRDL   CM.URQ      FWA OF MASTER CONTROL TABLE
          LDML   CM.MCT
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADC  CM.URQ,CM.MCT   FIRST WORD ADDRESS OF MASTER CONTROL TABLE
 IVB4     ENDIF
          CRML   MCT,WC
          LDML   MCT+/MCT/P.FLAGS   MASTER CONTROL TABLE INITIALIZED FLAG
          SHN    17-/MCT/INIT
          PJN    CVM20       IF MASTER CONTROL TABLE NOT INITIALIZED
          LDML   MCT+/MCT/P.DEVID   DEVICE ID
          STML   DEVID
          STML   RS+/RS/P.DEVID   STORE DEVICE IDENTIFIER IN STANDARD RESPONSE
          STML   LRS+/RS/P.DEVID  STORE DEVICE IDENTIFIER IN LOG RESPONSE

*         RESERVED FIELD OF UNIT REQUEST QUEUE DESCRIPTOR.

          LDML   UIT+/UIT/P.NEXTPV-1
          ADML   UIT+/UIT/P.NEXT-2
          ADML   UIT+/UIT/P.NEXT-1
          NJN    CVM80       IF RESERVED FIELD NOT ZERO
 CVM70    UJK    CVMX        EXIT

 CVM80    BSS
          LDML   TUEM,T1     INTERFACE ERROR CODE
          UJK    CVM70

**        TUEM - TABLE OF UNIT INTERFACE ERROR MESSAGES.

 TUEM     BSS    0
          LOC    0
          CON    E417        RESERVED FIELD OF UNIT REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
          LOC    *O
 CVD      SPACE  4,10
**        CVD - CHECK FOR VALID UNIT DESCRIPTOR.
*
*         EXIT   (A) = 0, IF VALID UNIT DESCRIPTOR.
*                    <> 0, IF INVALID.


 CVD      SUBR               ENTRY/EXIT
          LDML   UD+/UD/P.LU  LOGICAL UNIT
          SBML   IPIT+/PIT/P.FLU  FIRST LOGICAL UNIT
          PJN    CVD10
          LDC    E404        LOGICAL UNIT NOT IN RANGE
          UJK    CVD60

 CVD10    BSS
          LDML   UD+/UD/P.CHAN  CHANNEL NUMBER
          SHN    /UD/L.CHAN+/UD/N.CHAN+2
          LPN    37B
          SBN    14B         VALID CHANNELS ARE 0 - 13B AND 20B - 33B
          MJN    CVD40       IF CHANNEL OK
          SBN    20B-14B
          PJN    CVD30       IF CHANNEL OK
 CVD20    BSS
          LDC    E406        INVALID CHANNEL NUMBER
          UJN    CVD60

 CVD30    BSS
          SBN    34B-20B
          PJN    CVD20       IF INVALID CHANNEL
 CVD40    BSS
          LDML   UD+/UD/P.UQT  UNIT INTERFACE TABLE ADDRESS
          ADML   UD+/UD/P.UQT+1
          ZJN    CVD50       IF UIT RMA ZERO
          LDML   UD+/UD/P.UQT+1  UNIT INTERFACE TABLE ADDRESS
          LPN    7
          ZJN    CVD60
 CVD50    LDC    E405        UNIT INTERFACE TABLE NOT A WORD BOUNDARY
 CVD60    BSS
          UJK    CVDX        EXIT
 CVI      SPACE  4,10
**        CVI - CHECK FOR VALID PP INTERFACE TABLE.
*
*         EXIT   (A) = 0, IF VALID PP INTERFACE TABLE.
*                    <> 0, IF INVALID.
*
*         USES   T1.


 CVI      SUBR               ENTRY/EXIT
          LDN    0
          STDL   T1
          LDML   IPIT+/PIT/P.CBUFL  COMMUNICATION BUFFER LENGTH
          LPN    7
          NJK    CVI10       IF LENGTH NOT A MULTIPLE OF WORDS
          AODL   T1

*         CHECK PP COMMUNICATION BUFFER RMA

          LDML   IPIT+/PIT/P.CBUF
          ADML   IPIT+/PIT/P.CBUF+1  COMMUNICATION BUFFER (RMA)
          ZJN    CVI10       IF COMMUNICATION BUFFER RMA ZERO
          AODL   T1
          LDML   IPIT+/PIT/P.CBUF+1  COMMUNICATION BUFFER (RMA)
          LPN    7
          NJN    CVI10       IF PP COMMUNICATION BUFFER NOT A WORD BOUNDARY
          AODL   T1

*         RESERVED FIELD OF PP REQUEST QUEUE DESCRIPTOR

          LDML   IPIT+/PIT/P.PPQPVA-1
          ADML   IPIT+/PIT/P.PPQ-2
          ADML   IPIT+/PIT/P.PPQ-1
          NJN    CVI10       IF RESERVED FIELD NOT ZERO
          AODL   T1
          LDML   IPIT+/PIT/P.INT+1  INTERRUPT WORD (RMA)
          LPN    7
          NJN    CVI10       IF INTERRUPT WORD NOT A WORD BOUNDARY
          AODL   T1
          LDML   IPIT+/PIT/P.CHAN+1  CHANNEL INTERLOCK TABLE (RMA)
          LPN    7
          ZJN    CVI20       IF PP INTERFACE TABLE VALID
 CVI10    LDML   TPEC,T1     INTERFACE ERROR CODE
 CVI20    UJK    CVIX        EXIT

**        TPEC - TABLE OF PP INTERFACE ERROR CODES.

 TPEC     BSS    0
          LOC    0
          CON    E407        COMMUNICATION BUFFER LENGTH NOT A
                              MULTIPLE OF WORDS
          CON    E401        PP COMMUNICATION BUFFER RMA ZERO
          CON    E400        PP COMMUNICATION BUFFER NOT A WORD BOUNDARY
          CON    E402        RESERVED FIELD OF PP REQUEST QUEUE
                              DESCRIPTOR NOT ZERO
          CON    E411        RMA OF INTERRUPT WORD NOT A WORD BOUNDARY
          CON    E412        RMA OF CHANNEL INTERLOCK TABLE NOT A WORD BOUNDARY
          LOC    *O
 CVR      SPACE  4,10
**        CVR - CHECK FOR VALID RESPONSE BUFFER.
*
*         EXIT   (A) = 0, IF VALID RESPONSE BUFFER.
*                    <> 0, IF INVALID.
*                (CM.RS - CM.RS+2) = CM ADDRESS OF RESPONSE BUFFER.
*
*         MACROS LOADF.


 CVR      SUBR               ENTRY/EXIT

*         RESERVED WORD OF RESPONSE BUFFER DESCRIPTOR
          LDML   IPIT+/PIT/P.RSBUF-2
          ADML   IPIT+/PIT/P.RSBUF-1
          ADML   IPIT+/PIT/P.RSPVA-1
          NJN    CVR05       IF RESERVED FIELD NOT ZERO
          LDML   IPIT+/PIT/P.IN-3  RESERVED FIELD OF IN POINTER
          ADML   IPIT+/PIT/P.IN-2
          ADML   IPIT+/PIT/P.IN-1
 CVR05    NJN    CVR10       IF RESERVED FIELD NOT ZERO
          LDML   IPIT+/PIT/P.OUT-3  RESERVED FIELD OF OUT POINTER
          ADML   IPIT+/PIT/P.OUT-2
          ADML   IPIT+/PIT/P.OUT-1
          NJN    CVR10       IF RESERVED FIELD NOT ZERO
          LDML   IPIT+/PIT/P.LIMIT-3  RESERVED FIELD OF LIMIT POINTER
          ADML   IPIT+/PIT/P.LIMIT-2
          ADML   IPIT+/PIT/P.LIMIT-1
          NJN    CVR10       IF RESERVED FIELD NOT ZERO

*         RESPONSE BUFFER VALID - REFORMAT INTO CM.RS - CM.RS+2.

          LOADF  IPIT+/PIT/P.RSBUF REFORMAT ADDRESS OF RESPONSE BUFFER
          STDL   CM.RS+2
          SRD    CM.RS
          LDML   IPIT+/PIT/P.LIMIT
          STDL   LIM         LIMIT OF RESPONSE BUFFER
          LDN    0
 CVR10    UJK    CVRX        EXIT
 CVU      SPACE  4,10
**        CVU - CHECK FOR VALID UNIT INTERFACE TABLE.
*
*         EXIT   (A) = 0, IF VALID UNIT INTERFACE TABLE,
*                    <> 0, IF INVALID.
*                (CM.URQ - CM.URQ+1) = (R) PART OF MASTER CONTROL TABLE FWA.
*                (CM.MCT) = (A) PORTION OF MASTER CONTROL TABLE FWA.
*
*         USES   T1.


 CVU      SUBR               ENTRY/EXIT
          LDN    0
          STDL   T1
          LDML   UIT+/UIT/P.LU  LOGICAL UNIT NUMBER
          SBML   UD+/UD/P.LU
          NJN    CVU20       LOGICAL UNIT NUMBER MISMATCH
          AODL   T1
          LDML   UIT+/UIT/P.UTYPE  UNIT TYPE
          ADC    -IVBUT      IVB UNIT TYPE
          NJN    CVU20       IF INVALID UNIT TYPE
          AODL   T1

*         CHECK MASTER CONTROL TABLE DESCRIPTOR

          LDML   UIT+/UIT/P.MBUFL  MASTER CONTROL TABLE LENGTH
          ADC    -B.MCT      COMPARE WITH EXPECTED MASTER CONTROL TABLE LENGTH
          PJN    CVU30       IF BUFFER LONG ENOUGH
 CVU20    UJK    CVU40       INTERFACE ERROR

 CVU30    BSS
          AODL   T1
          LDML   UIT+/UIT/P.MBUF+1  MASTER CONTROL TABLE
          LPN    7
          NJN    CVU40       NOT A WORD BOUNDARY
 IVB0     IF     DEF,IVB0
          LRML   UIT+/UIT/P.MBUF
          LDML   UIT+/UIT/P.MBUF+1
          SHN    -3
          STDL   CM.URQ+1
          SRDL   CM.URQ
 IVB0     ENDIF
 IVB4     IF     DEF,IVB4
          LOADF  UIT+/UIT/P.MBUF
          STDL   CM.URQ+2
          SRD    CM.URQ
 IVB4     ENDIF
          STML   CM.MCT
          LDN    0           VALID UNIT INTERFACE TABLE
 CVU38    UJK    CVUX        EXIT

 CVU40    BSS
          LDML   TUEC,T1     INTERFACE ERROR CODE
          UJK    CVU38

**        TUEC - TABLE OF UNIT INTERFACE ERROR CODES.

 TUEC     BSS    0
          LOC    0
          CON    E413        LOGICAL UNIT NUMBER MISMATCH
          CON    E418        INVALID UNIT TYPE
          CON    E419        MASTER CONTROL TABLE NOT LARGE ENOUGH
          CON    E414        MASTER CONTROL TABLE NOT A WORD BOUNDARY
          LOC    *O
 CHG      SPACE  4,10
**        CHG - CHANGE CHANNEL INSTRUCTIONS.
*
*         CHANGE ALL CHANNEL INSTRUCTIONS TO USE THE SPECIFIED CHANNEL.
*
*         ENTRY  (CHAN) = NEW CHANNEL NUMBER TO BE USED.
*
*         USES   T1, T2.
          SPACE  2
 CHG      SUBR               ENTRY/EXIT
          LDN    0
          STDL   T1          CHANGE CHANNEL INSTRUCTIONS
 CHG10    LDML   CONCH,T1    ADDRESS OF CHANNEL INSTRUCTIONS
          ZJN    CHGX        IF END OF LIST
          STDL   T2
          LDIL   T2
          SCN    37B
          LMML   CHAN        CHANNEL NUMBER
          STIL   T2
          AODL   T1
          UJN    CHG10
          SPACE  4,10
 CONCH    BSS                CHANNEL REFERENCES
 TCH+40B  HERE
 T40B+CH  HERE
 TCH      HERE
          CON    0           END OF TABLE

          LIST   G
 TRACE    HERE
          LIST   *
          SPACE  4,10
 CPBF     BSSZ   P.IP+P.CCP+P.STATP  COMMAND PACKET BUFFER (SPACE FOR PARM 51 AND 56)
 RPBF     BSSZ   P.IP+P.CCP+P.STATP  RESPONSE PACKET BUFFER (SPACE FOR PARM 51 AND 56)
 RPBL     EQU    B.IP+B.CCP+B.STATP  RESPONSE BUFFER LENGTH IN BYTES
 RQ       BSSZ   P.RQ+MAXBUFS*4    REQUEST BUFFER + SPACE FOR 9 LENGTH/ADDRESS PAIRS
 RS       BSSZ   MAXRS*4     RESPONSE BUFFER
 LRS      BSSZ   P.RS        LOG RESPONSE BUFFER
 OTHERR   BSSZ   P.ILD       'OTHER ERROR' INFO BUFFER
 ICFER    BSSZ   P.ILD       FUNCTION PROCESSOR ERROR
 IOERR    BSSZ   P.ILD       'I/O ERROR' INFO BUFFER
 CRERR    BSSZ   P.ILD       'CMD/RESP ERROR' INFO BUFFER
 MCT      BSSZ   P.MCT       MASTER CONTROL TABLE
 BPD      BSSZ   P.BPD       BUFFER POOL DESCRIPTOR
 BPRMA    BSSZ   MAXBUFS*P.BPR  RMA'S OF CM POOL BUFFERS
 FBUF     BSSZ   FHT         FUNCTION HISTORY BUFFER
 IPIT     EQU    FBUF+FHT    PP INTERFACE TABLE
 UD       EQU    IPIT+P.PIT  UNIT DESCRIPTOR
 UIT      EQU    UD+P.UD     UNIT INTERFACE TABLE
 EOM      EQU    UIT+P.UIT
          ERRMI  17777B-EOM  IF NOT ENOUGH SPACE

*DECK DECK=NLM$AL_APPLICATION_DATA_SERVICE EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'NAM/VE: Application Layer Data Services' ??
?? NEWTITLE := '  Global Declarations' ??
MODULE nlm$al_application_data_service;
*copyc nlt$al_data_description
?? TITLE := '  External Procedures', EJECT ??
?? TITLE := '  [XDCL] nlp$al_fragment_data', EJECT ??

  PROCEDURE [XDCL] nlp$al_fragment_data (fragment_size: nat$data_length;
    VAR data_description {INPUT, OUTPUT} : nlt$al_data_description;
    VAR remaining_data_length: nat$data_length;
    VAR message: nat$data_fragments);
*copy nlh$al_fragment_data

    VAR
      i: integer,
      j: integer,
      scanned_data_length: nat$data_length;

    scanned_data_length := 0;
    i := data_description.current_lowerbound;
    j := 1;
    WHILE (scanned_data_length < fragment_size) DO
      IF ((data_description.fragment [i].length > 0) AND (data_description.fragment [i].address <> NIL)) THEN
        IF ((scanned_data_length + data_description.fragment [i].length) <= fragment_size) THEN
          message [j] := data_description.fragment [i];
          scanned_data_length := scanned_data_length + data_description.fragment [i].length;
          data_description.fragment [i].length := 0;
          j := j + 1;
          i := i + 1;
        ELSE { IF ((scanned_data_length + data_description.fragment [i].length) > fragment_size) THEN
          message [j].address := data_description.fragment [i].address;
          message [j].length := fragment_size - scanned_data_length;
          scanned_data_length := scanned_data_length + message [j].length;
          data_description.fragment [i].address := #ADDRESS (#RING (data_description.fragment [i].address),
                #SEGMENT (data_description.fragment [i].address), (#OFFSET (data_description.fragment [i].
                address) + message [j].length));
          data_description.fragment [i].length := data_description.fragment [i].length - message [j].
                length;
          j := j + 1;
        IFEND;
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;
    data_description.current_lowerbound := i;
    data_description.data_length := data_description.data_length - fragment_size;
    remaining_data_length := data_description.data_length;
    FOR i := j to UPPERBOUND (message) DO
      message [i].address := NIL;
      message [i].length := 0;
    FOREND;
  PROCEND nlp$al_fragment_data;
MODEND nlm$al_application_data_service;
*DECK DECK=NLM$BUFFER_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NAM/VE: Buffer Manager' ??
?? NEWTITLE := 'Global Declarations Referenced by This Module' ??
MODULE nlm$buffer_manager;

{ PURPOSE:
{   This module contains the procedures to create and manage NAM/VE's buffers.
{
{ DESIGN:
{   The procedures are grouped into two groups.  The first group contains the
{   XDCLed procedures.  The second group contains the internal procedures.
{   The procedures in each group are in alphabetical order.

?? PUSH (LISTEXT := ON) ??
*copyc cyd$cybil_structure_definitions
*copyc dmt$error_condition_codes
*copyc mme$condition_codes
*copyc nae$initialization_interfaces
*copyc nae$namve_conditions
*copyc nat$data_fragments
*copyc nlc$bm_buffer_pool_index
*copyc nlc$bm_minimum_buffers_for_cpu
*copyc nlc$bm_small_buffer_size
*copyc nlc$small_machine_threshold
*copyc nlt$bm_buffer_list_array
*copyc nlt$bm_message_descriptor
*copyc nlt$bm_message_id
*copyc nlt$bm_pool_index
*copyc osc$space_unavailable_condition
*copyc osc$volume_unavailable_cond
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc i#move
*copyc nap$namve_system_error
*copyc nlp$bm_get_message_length
*copyc nlp$bm_valid_message_id
*copyc osp$begin_subsystem_activity
*copyc osp$clear_job_signature_lock
*copyc osp$end_subsystem_activity
*copyc osp$establish_condition_handler
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$wait_on_condition
*copyc pmp$abort
*copyc pmp$continue_to_cause
*copyc syp$cycle
*copyc nav$global_statistics
*copyc nav$network_paged_heap
*copyc nav$network_wired_heap
*copyc nav$statistics_enabled
*copyc nlv$bm_allocat_buffer_threshold
*copyc nlv$bm_allocated_buffer_maximum
*copyc nlv$bm_allocated_buffer_pool
*copyc nlv$bm_buffer_manager_caller
*copyc nlv$bm_buffer_manager_control
*copyc nlv$bm_buffer_pool
*copyc nlv$bm_buffers_freed
*copyc nlv$bm_large_buffer_size
*copyc nlv$bm_nil_message_id
*copyc nlv$bm_null_message_id
*copyc nlv$cc_grant_credit_trigger
*copyc nlv$cc_maximum_receive_window
*copyc osv$180_memory_limits
*copyc osv$page_size
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST

{ Presentation expected data header size = 0
{ Session expected data header size = 5
{ Transport access agent expected data header size = 5
{ Channel Connection expected data header size = 16 + up to 7 pad bytes

    nlc$bm_expected_header_size = 33;

  CONST
    buffer_initialization = '#';

  TYPE
    aligned_2048 = record
      buffer: ALIGNED [0 MOD 2048] nlt$bm_allocated_memory,
    recend,

    aligned_4096 = record
      buffer: ALIGNED [0 MOD 4096] nlt$bm_allocated_memory,
    recend,

    aligned_8192 = record
      buffer: ALIGNED [0 MOD 8192] nlt$bm_allocated_memory,
    recend,

    aligned_16384 = record
      buffer: ALIGNED [0 MOD 16384] nlt$bm_allocated_memory,
    recend;

  TYPE
    build_container_pointer = record
      case boolean of
      = TRUE =
        pointer: ^nlt$bm_container,
      = FALSE =
        adaptable_string_pointer: cyt$adaptable_string_pointer,
      casend,
    recend;

  VAR
    buffer_sub_pool: record
      case ost$page_size of
      = 2048 =
        aligned_2048: ^aligned_2048,
      = 4096 =
        aligned_4096: ^aligned_4096,
      = 8192 =
        aligned_8192: ^aligned_8192,
      = 16384 =
        aligned_16384: ^aligned_16384,
      casend,
    recend;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_add_message_prefix', EJECT ??
*copy nlh$bm_add_message_prefix

  PROCEDURE [XDCL] nlp$bm_add_message_prefix
    (    prefix: ^cell;
         prefix_length: nat$data_length;
     VAR message_id { input, output } : nlt$bm_message_id);

?? NEWTITLE := 'create_message_appendage', EJECT ??

{ PURPOSE:
{   This procedure gets a message of length equal to the prefix_length.  The new message is appended
{   to the begining of the current message.  The prefix data is then moved into the new appendage.

    PROCEDURE create_message_appendage
      (    prefix: ^cell;
           prefix_length: nat$data_length;
       VAR message_id { input, output} : nlt$bm_message_id);

      VAR
        actual_data_length: nat$data_length,
        container_length: nlt$bm_buffer_length,
        current_container_capacity: nlt$bm_buffer_length,

{ This declaration exists solely to develop the address for the i#move which moves data from
{ the user's address space to the container.

        data_address: ^array [0 .. 0ffffff(16)] of cell,
        descriptor: ^nlt$bm_message_descriptor,
        first_descriptor: ^nlt$bm_message_descriptor,
        i: integer,
        prefix_data_start: nat$data_length,
        remaining_data_length: nat$data_length;

      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
      get_message (prefix_length, {future_data_requirements = } 0, descriptor);
      osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
      osp$end_subsystem_activity;

      prefix_data_start := 0;
      remaining_data_length := prefix_length;
      current_container_capacity := descriptor^.container_length - descriptor^.data_start;
      first_descriptor := descriptor;
      data_address := prefix;

    /create_appendage/
      WHILE remaining_data_length > 0 DO

      /move_data_to_container/
        BEGIN

{ Fill or partially fill the current container with the remainder of the data.

          IF remaining_data_length <= current_container_capacity THEN
            i#move (#LOC (data_address^ [prefix_data_start]),
                  #LOC (descriptor^.container^ (1 + descriptor^.data_start)), remaining_data_length);
            remaining_data_length := 0;

          ELSE { Fill current container.
            i#move (#LOC (data_address^ [prefix_data_start]),
                  #LOC (descriptor^.container^ (1 + descriptor^.data_start)), current_container_capacity);
            prefix_data_start := prefix_data_start + current_container_capacity;
            remaining_data_length := remaining_data_length - current_container_capacity;
            descriptor := descriptor^.link;
            current_container_capacity := descriptor^.container_length - descriptor^.data_start;
          IFEND;
        END /move_data_to_container/;

      WHILEND /create_appendage/;
      descriptor^.link := message_id.descriptor;
      message_id.descriptor := first_descriptor;
      message_id.sequence_number := first_descriptor^.sequence_number;
    PROCEND create_message_appendage;
?? OLDTITLE, EJECT ??

    VAR
      descriptor: ^nlt$bm_message_descriptor,
      move_length: nat$data_length,
      new_descriptor: ^nlt$bm_message_descriptor,

{ This declaration exists solely to develop the address for the i#move which moves the prefix
{ from the user's address space to the container.

      prefix_address: ^array [0 .. 0ffffff(16)] of cell,
      remaining_prefix_length: nat$data_length;

    IF (prefix <> NIL) AND (prefix_length > 0) AND nlp$bm_valid_message_id (message_id) THEN
      IF message_id <> nlv$bm_null_message_id THEN
        descriptor := message_id.descriptor;
        descriptor^.sequence_number := (descriptor^.sequence_number + 1) MOD nlc$bm_sequence_space;
        message_id.sequence_number := descriptor^.sequence_number;

{ Find last buffer in the message with space available.

        WHILE (descriptor^.link <> NIL) AND (descriptor^.data_start = descriptor^.container_length) AND
              (descriptor^.link^.data_start > 0) DO
          descriptor := descriptor^.link;
        WHILEND;

{ The complete prefix fits in the current buffer.

        IF descriptor^.data_start >= prefix_length THEN
          descriptor^.data_start := descriptor^.data_start - prefix_length;
          i#move (prefix, #LOC (descriptor^.container^ (1 + descriptor^.data_start)), prefix_length);
        ELSE
          remaining_prefix_length := prefix_length;

{ All or part of the prefix fits in the existing buffers.

          IF descriptor^.data_start > 0 THEN
            move_length := 0;
            prefix_address := prefix;
            WHILE (remaining_prefix_length > 0) AND (descriptor^.data_start > 0) DO
              IF remaining_prefix_length >= descriptor^.data_start THEN
                move_length := descriptor^.data_start;
                descriptor^.data_start := 0;
              ELSE
                move_length := remaining_prefix_length;
                descriptor^.data_start := descriptor^.data_start - remaining_prefix_length;
              IFEND;
              remaining_prefix_length := remaining_prefix_length - move_length;
              i#move (#LOC (prefix_address^ [remaining_prefix_length]),
                    #LOC (descriptor^.container^ (1 + descriptor^.data_start)), move_length);
              IF remaining_prefix_length > 0 THEN

{ Find last buffer in the message with space available.

                descriptor := message_id.descriptor;
                WHILE (descriptor^.link <> NIL) AND (descriptor^.data_start =
                      descriptor^.container_length) AND (descriptor^.link^.data_start > 0) DO
                  descriptor := descriptor^.link;
                WHILEND;
              IFEND;
            WHILEND;
          IFEND;

          IF remaining_prefix_length > 0 THEN
            create_message_appendage (prefix, remaining_prefix_length, message_id);
          IFEND;
        IFEND;

      ELSE { Create new message for prefix.
        create_message_appendage (prefix, prefix_length, message_id);
      IFEND;
    ELSE { Bad input parameters.
      nap$namve_system_error (FALSE, nlv$bm_buffer_manager_caller , NIL);
    IFEND;
  PROCEND nlp$bm_add_message_prefix;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_concatenate_messages', EJECT ??
*copy nlh$bm_concatenate_messages

  PROCEDURE [XDCL] nlp$bm_concatenate_messages
    (    component_list { input, output } : array [1 .. * ] of nlt$bm_message_id;
     VAR message_id: nlt$bm_message_id);

    VAR
      descriptor: ^nlt$bm_message_descriptor,
      i: integer,
      link: ^^nlt$bm_message_descriptor;


    message_id := nlv$bm_null_message_id;
    link := ^message_id.descriptor;

    FOR i := 1 TO UPPERBOUND (component_list) DO
      IF NOT nlp$bm_valid_message_id (component_list [i]) THEN
        nap$namve_system_error (FALSE, nlv$bm_buffer_manager_caller , NIL);
      IFEND;
      IF component_list [i] <> nlv$bm_null_message_id THEN
        descriptor := component_list [i].descriptor;
        descriptor^.sequence_number := (descriptor^.sequence_number + 1) MOD nlc$bm_sequence_space;
        link^ := descriptor;
        WHILE descriptor^.link <> NIL DO
          descriptor := descriptor^.link;
        WHILEND;
        link := ^descriptor^.link;
      IFEND;
    FOREND;

    IF message_id <> nlv$bm_null_message_id THEN
      message_id.sequence_number := message_id.descriptor^.sequence_number;
      link^ := NIL;
    IFEND;
  PROCEND nlp$bm_concatenate_messages;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_copy_message', EJECT ??
*copy nlh$bm_copy_message

  PROCEDURE [XDCL] nlp$bm_copy_message
    (    from_message_id: nlt$bm_message_id;
     VAR to_message_id: nlt$bm_message_id);

    VAR
      descriptor: ^nlt$bm_message_descriptor,
      from_container_capacity: nlt$bm_buffer_length,
      from_data_start: nlt$bm_buffer_length,
      from_descriptor: ^nlt$bm_message_descriptor,
      i: integer,
      remaining_data_length: integer,
      to_container_capacity: nlt$bm_buffer_length,
      to_data_start: nlt$bm_buffer_length,
      to_descriptor: ^nlt$bm_message_descriptor;


    nlp$bm_get_message_length (from_message_id, remaining_data_length);

    IF remaining_data_length > 0 THEN
      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
      get_message (remaining_data_length, {future_data_requirements = } 0, to_descriptor);
      osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
      osp$end_subsystem_activity;

{ Find the first buffer with data.

      from_descriptor := from_message_id.descriptor;
      WHILE from_descriptor^.container_length = from_descriptor^.data_start DO
        from_descriptor := from_descriptor^.link;
      WHILEND;

      to_message_id.descriptor := to_descriptor;
      to_message_id.sequence_number := to_descriptor^.sequence_number;
      from_container_capacity := from_descriptor^.container_length - from_descriptor^.data_start;
      to_container_capacity := to_descriptor^.container_length - to_descriptor^.data_start;

      IF (from_container_capacity = remaining_data_length) AND
            (remaining_data_length = to_container_capacity) THEN
        i#move (#LOC (from_descriptor^.container^ (1 + from_descriptor^.data_start)),
              #LOC (to_descriptor^.container^ (1 + to_descriptor^.data_start)), remaining_data_length);
      ELSE
        from_data_start := from_descriptor^.data_start;
        to_data_start := to_descriptor^.data_start;

      /copy_message/
        WHILE remaining_data_length > 0 DO

        /move_data_to_container/
          BEGIN

{ Fill the container.

            IF from_container_capacity >= to_container_capacity THEN
              i#move (#LOC (from_descriptor^.container^ (1 + from_data_start)),
                    #LOC (to_descriptor^.container^ (1 + to_data_start)), to_container_capacity);
              remaining_data_length := remaining_data_length - to_container_capacity;

 { Get the next to_descriptor.

              IF remaining_data_length > 0 THEN
                from_container_capacity := from_container_capacity - to_container_capacity;
                from_data_start := from_data_start + to_container_capacity;
                to_descriptor := to_descriptor^.link;
                to_data_start := to_descriptor^.data_start;
                to_container_capacity := to_descriptor^.container_length - to_data_start;
              ELSE { The message is complete.
                EXIT /copy_message/;
              IFEND;

            ELSE { Partially fill the container.
              i#move (#LOC (from_descriptor^.container^ (1 + from_data_start)),
                    #LOC (to_descriptor^.container^ (1 + to_data_start)), from_container_capacity);
              to_container_capacity := to_container_capacity - from_container_capacity;
              to_data_start := to_data_start + from_container_capacity;
              remaining_data_length := remaining_data_length - from_container_capacity;
              from_container_capacity := 0;
            IFEND;
          END /move_data_to_container/;

        /get_next_buffer/
          WHILE from_container_capacity = 0 DO
            from_descriptor := from_descriptor^.link;
            from_data_start := from_descriptor^.data_start;
            from_container_capacity := from_descriptor^.container_length - from_data_start;
          WHILEND /get_next_buffer/;

        WHILEND /copy_message/;
      IFEND;
    ELSE
      to_message_id := nlv$bm_null_message_id;
    IFEND;
  PROCEND nlp$bm_copy_message;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_create_message', EJECT ??
*copy nlh$bm_create_message

  PROCEDURE [XDCL] nlp$bm_create_message
    (    data: nat$data_fragments;
     VAR message_id: nlt$bm_message_id;
     VAR status: ost$status);

?? NEWTITLE := 'create_condition_handler', EJECT ??

{ NOTES:
{   Set the condition status to TRUE to prevent the task from terminating.  This deviates from
{   the coding standards.  The problem with this approach is that the condition is lost.  A
{   possible future solution might be to keep track of the conditions and restart the conditons
{   after leaving NAM/VE.

    PROCEDURE create_condition_handler
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_handler;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        osp$begin_subsystem_activity;
        osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        release_message (message_id.descriptor);
        osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        osp$end_subsystem_activity;
        pmp$continue_to_cause (pmc$inhibit_standard_procedure, condition_status);
        osp$set_status_from_condition (nac$status_id, condition, sa, status, ignore_status);
        EXIT nlp$bm_create_message;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$wait_on_condition (mme$volume_unavailable);
        ELSEIF condition.user_condition_name = osc$space_unavailable_condition THEN
          osp$wait_on_condition (dme$unable_to_alloc_all_space);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND create_condition_handler;
?? OLDTITLE, EJECT ??

    VAR
      current_container_capacity: nlt$bm_buffer_length,

{ Data address exists solely to develop the address for the i#move which moves data from
{ the user's address space to the container.

      data_address: ^array [0 .. 0ffffff(16)] of cell,
      data_start: nat$data_length,
      descriptor: ^nlt$bm_message_descriptor,
      fragment: integer,
      fragment_data_start: nat$data_length,
      i: integer,
      remaining_data_in_fragment: nat$data_length,
      remaining_data_length: integer;

    status.normal := TRUE;
    remaining_data_length := 0;

  /get_total_data_length/
    FOR i := 1 TO UPPERBOUND (data) DO
      IF (data [i].length > 0) AND (data [i].address <> NIL) THEN
        IF remaining_data_length = 0 THEN
          fragment := i; { First non zero fragment.
          remaining_data_in_fragment := data [i].length;
        IFEND;
        remaining_data_length := remaining_data_length + data [i].length;
      IFEND;
    FOREND /get_total_data_length/;

    IF remaining_data_length > 0 THEN
      osp$establish_condition_handler (^create_condition_handler, FALSE);
      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
      get_message (remaining_data_length, nlc$bm_expected_header_size, descriptor);
      osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
      osp$end_subsystem_activity;

      message_id.descriptor := descriptor;
      message_id.sequence_number := descriptor^.sequence_number;
      #SPOIL (message_id);

{ Find buffer to hold the first part of the new message.
{ NOTE the first buffers may be empty to allow for a future prefix.

      WHILE (descriptor^.link <> NIL) AND (descriptor^.data_start = descriptor^.container_length) DO
        descriptor := descriptor^.link;
      WHILEND;
      current_container_capacity := descriptor^.container_length - descriptor^.data_start;
      data_address := data [fragment].address;

{ The whole message is in one fragment and that fragment fits in to one buffer.

      IF (data [fragment].length = remaining_data_length) AND
            (remaining_data_length = current_container_capacity) THEN
        i#move (#LOC (data_address^ [0]), #LOC (descriptor^.container^ (1 + descriptor^.data_start)),
              remaining_data_length);

      ELSE
        data_start := descriptor^.data_start;
        fragment_data_start := 0;

      /create_message/
        WHILE remaining_data_length > 0 DO

        /move_data_to_container/
          BEGIN

{ Fill the container.

            IF remaining_data_in_fragment >= current_container_capacity THEN
              i#move (#LOC (data_address^ [fragment_data_start]),
                    #LOC (descriptor^.container^ (1 + data_start)), current_container_capacity);
              remaining_data_length := remaining_data_length - current_container_capacity;

{ Get the next descriptor.

              IF remaining_data_length > 0 THEN
                remaining_data_in_fragment := remaining_data_in_fragment - current_container_capacity;
                fragment_data_start := fragment_data_start + current_container_capacity;
                descriptor := descriptor^.link;
                data_start := descriptor^.data_start;
                current_container_capacity := descriptor^.container_length - data_start;
              ELSE { The message is complete.
                EXIT /create_message/;
              IFEND;

            ELSE { Partially fill the container.
              i#move (#LOC (data_address^ [fragment_data_start]),
                    #LOC (descriptor^.container^ (1 + data_start)), remaining_data_in_fragment);
              current_container_capacity := current_container_capacity - remaining_data_in_fragment;
              remaining_data_length := remaining_data_length - remaining_data_in_fragment;
              data_start := data_start + remaining_data_in_fragment;
              remaining_data_in_fragment := 0;
            IFEND;
          END /move_data_to_container/;

        /get_next_fragment/
          WHILE remaining_data_in_fragment = 0 DO
            fragment := fragment + 1;
            IF (data [fragment].length > 0) AND (data [fragment].address <> NIL) THEN
              remaining_data_in_fragment := data [fragment].length;
              fragment_data_start := 0;
              data_address := data [fragment].address;
            IFEND;
          WHILEND /get_next_fragment/;

        WHILEND /create_message/;
      IFEND;
    ELSE
      message_id := nlv$bm_null_message_id;
    IFEND;
  PROCEND nlp$bm_create_message;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_deliver_message', EJECT ??
*copy nlh$bm_deliver_message

  PROCEDURE [XDCL] nlp$bm_deliver_message
    (VAR data_area { input, output } : nat$data_fragments;
     VAR message_id { input, output } : nlt$bm_message_id;
     VAR data_length: integer;
     VAR buffers_released: nat$data_length);

?? NEWTITLE := 'deliver_condition_handler', EJECT ??

{ NOTES:
{   Set the condition status to TRUE to prevent the task from terminating.  This deviates from
{   the coding standards.  The problem with this approach is that the condition is lost.  A
{   possible future solution might be to keep track of the conditions and restart the conditons
{   after leaving NAM/VE.

    PROCEDURE deliver_condition_handler
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_handler;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        error_status: ost$status,
        ignore_status: ost$status;

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        osp$set_status_from_condition (nac$status_id, condition, sa, error_status,
              ignore_status);
        pmp$abort (error_status);
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$wait_on_condition (mme$volume_unavailable);
        ELSEIF condition.user_condition_name = osc$space_unavailable_condition THEN
          osp$wait_on_condition (dme$unable_to_alloc_all_space);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND deliver_condition_handler;
?? OLDTITLE, EJECT ??

    VAR
      data_area_length: integer,
      data_start: nlt$bm_buffer_length,
      descriptor: ^nlt$bm_message_descriptor,
      fragment: integer,
      i: integer,
      message_length: integer,
      release_descriptor: ^nlt$bm_message_descriptor,
      release_descriptor_link: ^^nlt$bm_message_descriptor,
      remaining_data_in_container: nlt$bm_buffer_length;

    buffers_released := 0;
    data_length := 0;
    data_area_length := 0;

  /get_total_data_area_length/
    FOR i := 1 TO UPPERBOUND (data_area) DO
      IF (data_area [i].length > 0) AND (data_area [i].address <> NIL) THEN
        IF data_area_length = 0 THEN
          fragment := i; { First non zero fragment.
        IFEND;
        data_area_length := data_area_length + data_area [i].length;
      IFEND;
    FOREND /get_total_data_area_length/;

    nlp$bm_get_message_length (message_id, message_length);
    IF (message_length > 0) AND (data_area_length > 0) THEN
      descriptor := message_id.descriptor;
      descriptor^.sequence_number := (descriptor^.sequence_number + 1) MOD nlc$bm_sequence_space;
      message_id.sequence_number := descriptor^.sequence_number;
      osp$establish_condition_handler (^deliver_condition_handler, FALSE);
      IF ((descriptor^.container_length - descriptor^.data_start) = message_length) AND
            (data_area [fragment].length >= message_length) THEN
        data_length := message_length;
        i#move (#LOC (descriptor^.container^ (1 + descriptor^.data_start)), data_area [fragment].
              address, message_length);
        release_descriptor := message_id.descriptor;
        message_id := nlv$bm_null_message_id;
        buffers_released := 1;
        data_area [fragment].length := data_area [fragment].length - message_length;
        data_area [fragment].address := #ADDRESS (#RING (data_area [fragment].address),
              #SEGMENT (data_area [fragment].address), (#OFFSET (data_area [fragment].address) +
              message_length));
      ELSE
        data_start := descriptor^.data_start;
        remaining_data_in_container := descriptor^.container_length - data_start;
        release_descriptor := message_id.descriptor;
        release_descriptor_link := ^release_descriptor;

      /deliver_message/
        WHILE (data_length < message_length) AND (data_length < data_area_length) DO

          WHILE (data_area [fragment].length = 0) OR (data_area [fragment].address = NIL) DO
            fragment := fragment + 1;
          WHILEND;

{ Fill the fragment.

          IF remaining_data_in_container > data_area [fragment].length THEN
            i#move (#LOC (descriptor^.container^ (1 + data_start)), data_area [fragment].
                  address, data_area [fragment].length);
            data_length := data_length + data_area [fragment].length;
            data_start := data_start + data_area [fragment].length;
            remaining_data_in_container := remaining_data_in_container - data_area [fragment].length;
            data_area [fragment].length := 0;

          ELSE { Partially fill fragment with the remainder of the current container.
            i#move (#LOC (descriptor^.container^ (1 + data_start)), data_area [fragment].
                  address, remaining_data_in_container);
            data_length := data_length + remaining_data_in_container;
            data_area [fragment].address := #ADDRESS (#RING (data_area [fragment].address),
                  #SEGMENT (data_area [fragment].address), #OFFSET (data_area [fragment].address) +
                  remaining_data_in_container);
            data_area [fragment].length := data_area [fragment].length - remaining_data_in_container;
            remaining_data_in_container := 0;
          IFEND;

          WHILE remaining_data_in_container = 0 DO
            buffers_released := buffers_released + 1;
            release_descriptor_link := ^descriptor^.link;
            descriptor := descriptor^.link;
            IF descriptor <> NIL THEN
              data_start := descriptor^.data_start;
              remaining_data_in_container := descriptor^.container_length - data_start;
            ELSE
              EXIT /deliver_message/;
            IFEND;
          WHILEND;
        WHILEND /deliver_message/;
        IF descriptor <> NIL THEN
          descriptor^.data_start := data_start;
          message_id.descriptor := descriptor;
          message_id.sequence_number := descriptor^.sequence_number;
        ELSE
          message_id := nlv$bm_null_message_id;
        IFEND;
        release_descriptor_link^ := NIL;
      IFEND;
      IF release_descriptor <> NIL THEN
        osp$begin_subsystem_activity;
        osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        release_message (release_descriptor);
        osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        osp$end_subsystem_activity;
      IFEND;
    IFEND;
  PROCEND nlp$bm_deliver_message;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_extract_message_prefix', EJECT ??
*copy nlh$bm_extract_message_prefix

  PROCEDURE [XDCL] nlp$bm_extract_message_prefix
    (    prefix: ^cell;
         prefix_length: nat$data_length;
     VAR message_id: nlt$bm_message_id;
     VAR bytes_moved: nat$data_length);

    VAR
      descriptor: ^nlt$bm_message_descriptor,
      move_length: nat$data_length,

{ This declaration exists solely to develop the address for the i#move which moves the prefix
{ from the container to the user's address space.

      prefix_address: ^array [0 .. 0ffffff(16)] of cell,
      prefix_data_start: nat$data_length,
      release_descriptor: ^nlt$bm_message_descriptor,
      release_descriptor_link: ^^nlt$bm_message_descriptor,
      remaining_prefix_length: nat$data_length;

    IF (prefix <> NIL) AND (prefix_length > 0) AND (message_id.descriptor <> NIL) AND
          (message_id.sequence_number = message_id.descriptor^.sequence_number) THEN
      descriptor := message_id.descriptor;
      descriptor^.sequence_number := (descriptor^.sequence_number + 1) MOD nlc$bm_sequence_space;
      message_id.sequence_number := descriptor^.sequence_number;
      remaining_prefix_length := prefix_length;
      release_descriptor := message_id.descriptor;
      release_descriptor_link := ^release_descriptor;
      prefix_address := prefix;
      prefix_data_start := 0;

      REPEAT

{ Fill the prefix with the current buffer.

        IF (descriptor^.container_length - descriptor^.data_start) >= remaining_prefix_length THEN
          move_length := remaining_prefix_length;
        ELSE { Partially fill the prefix.
          move_length := descriptor^.container_length - descriptor^.data_start;
        IFEND;

        i#move (#LOC (descriptor^.container^ (1 + descriptor^.data_start)),
              #LOC (prefix_address^ [prefix_data_start]), move_length);
        descriptor^.data_start := descriptor^.data_start + move_length;
        prefix_data_start := prefix_data_start + move_length;
        remaining_prefix_length := remaining_prefix_length - move_length;

        IF descriptor^.data_start = descriptor^.container_length THEN
          release_descriptor_link := ^descriptor^.link;
          descriptor := descriptor^.link;
        IFEND;
      UNTIL (remaining_prefix_length = 0) OR (descriptor = NIL);

      bytes_moved := prefix_length - remaining_prefix_length;

      IF descriptor <> NIL THEN
        message_id.descriptor := descriptor;
        message_id.sequence_number := descriptor^.sequence_number;
      ELSE
        message_id := nlv$bm_null_message_id;
      IFEND;
      release_descriptor_link^ := NIL;

      IF release_descriptor <> NIL THEN
        osp$begin_subsystem_activity;
        osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        release_message (release_descriptor);
        osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        osp$end_subsystem_activity;
      IFEND;
    ELSEIF message_id = nlv$bm_null_message_id THEN
      bytes_moved := 0;
    ELSE { Bad input parameters.
      nap$namve_system_error (FALSE, nlv$bm_buffer_manager_caller , NIL);
    IFEND;

  PROCEND nlp$bm_extract_message_prefix;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_flush_message', EJECT ??
*copy nlh$bm_flush_message

  PROCEDURE [XDCL] nlp$bm_flush_message
    (    data_area: nat$data_fragments;
     VAR message_id: nlt$bm_message_id;
     VAR data_length: integer;
     VAR status: ost$status);

?? NEWTITLE := 'flush_condition_handler', EJECT ??

{ NOTES:
{   Set the condition status to TRUE to prevent the task from terminating.  This deviates from
{   the coding standards.  The problem with this approach is that the condition is lost.  A
{   possible future solution might be to keep track of the conditions and restart the conditons
{   after leaving NAM/VE.

    PROCEDURE flush_condition_handler
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_handler;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        pmp$continue_to_cause (pmc$execute_standard_procedure, ignore_status);
        osp$set_status_from_condition (nac$status_id, condition, sa, status,
              ignore_status);
        pmp$abort (status);
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$wait_on_condition (mme$volume_unavailable);
        ELSEIF condition.user_condition_name = osc$space_unavailable_condition THEN
          osp$wait_on_condition (dme$unable_to_alloc_all_space);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND flush_condition_handler;
?? OLDTITLE, EJECT ??

    VAR
      current_data_area_capacity: nat$data_length,

{ This declaration exists solely to develop the address for the i#move which moves data from
{ the container to the user's address space.

      data_address: ^array [0 .. 0ffffff(16)] of cell,
      data_area_length: integer,
      data_start: nlt$bm_buffer_length,
      descriptor: ^nlt$bm_message_descriptor,
      fragment: nat$data_length,
      fragment_data_start: nat$data_length,
      i: integer,
      message_length: integer,
      remaining_data_in_container: nlt$bm_buffer_length;

    status.normal := TRUE;
    nlp$bm_get_message_length (message_id, message_length);
    data_area_length := 0;
    data_length := 0;

  /get_total_data_area_length/
    FOR i := 1 TO UPPERBOUND (data_area) DO
      IF (data_area [i].length > 0) AND (data_area [i].address <> NIL) THEN
        IF data_area_length = 0 THEN
          fragment := i; { First non empty fragment.
          current_data_area_capacity := data_area [i].length;
        IFEND;
        data_area_length := data_area_length + data_area [i].length;
      IFEND;
    FOREND /get_total_data_area_length/;

    IF message_length <= data_area_length THEN
      IF message_length > 0 THEN
        descriptor := message_id.descriptor;
        osp$establish_condition_handler (^flush_condition_handler, FALSE);

{ The whole message is contained in one buffer.  It fits into the first fragment.

        IF ((descriptor^.container_length - descriptor^.data_start) = message_length) AND
              (current_data_area_capacity >= message_length) THEN
          data_length := message_length;
          data_address := data_area [fragment].address;
          i#move (#LOC (descriptor^.container^ (1 + descriptor^.data_start)), #LOC (data_address^ [0]),
                message_length);
        ELSE
          data_start := descriptor^.data_start;
          fragment_data_start := 0;
          remaining_data_in_container := descriptor^.container_length - data_start;

        /flush_message/
          WHILE data_length < message_length DO

{ Find next non empty fragment if current is empty.

            WHILE current_data_area_capacity = 0 DO
              fragment := fragment + 1;
              IF (data_area [fragment].length > 0) AND (data_area [fragment].address <> NIL) THEN
                current_data_area_capacity := data_area [fragment].length;
                fragment_data_start := 0;
              IFEND;
            WHILEND;

{ Get next descriptor.

            IF remaining_data_in_container = 0 THEN
              descriptor := descriptor^.link;
              data_start := descriptor^.data_start;
              remaining_data_in_container := descriptor^.container_length - data_start;
            IFEND;
            data_address := data_area [fragment].address;

{ Fill the current fragment.

            IF remaining_data_in_container >= current_data_area_capacity THEN
              i#move (#LOC (descriptor^.container^ (1 + data_start)),
                    #LOC (data_address^ [fragment_data_start]), current_data_area_capacity);
              data_length := data_length + current_data_area_capacity;
              remaining_data_in_container := remaining_data_in_container - current_data_area_capacity;
              data_start := data_start + current_data_area_capacity;
              current_data_area_capacity := 0;

            ELSE { Partially fill current fragment with remainder of current container.
              i#move (#LOC (descriptor^.container^ (1 + data_start)),
                    #LOC (data_address^ [fragment_data_start]), remaining_data_in_container);
              data_length := data_length + remaining_data_in_container;
              current_data_area_capacity := current_data_area_capacity - remaining_data_in_container;
              fragment_data_start := fragment_data_start + remaining_data_in_container;
              remaining_data_in_container := 0;
            IFEND;
          WHILEND /flush_message/;
        IFEND;
        message_id.descriptor^.sequence_number := (message_id.descriptor^.sequence_number + 1) MOD
              nlc$bm_sequence_space;
        osp$begin_subsystem_activity;
        osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        release_message (message_id.descriptor);
        osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        osp$end_subsystem_activity;
        message_id := nlv$bm_nil_message_id;
      IFEND;
    ELSE { Data area too small.
      osp$set_status_condition (nae$data_area_too_small, status);
    IFEND;
  PROCEND nlp$bm_flush_message;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_free_buffer_pools', EJECT ??
*copy nlh$bm_free_buffer_pools

  PROCEDURE [XDCL] nlp$bm_free_buffer_pools;

    VAR
      i: integer,
      index: nlt$bm_sub_pool_index,
      pool: ^nlt$bm_allocated_pool_descr,
      sub_pool: ^nlt$bm_allocatd_buffer_sub_pool;

    FOR i := UPPERBOUND (nlv$bm_buffer_pool) DOWNTO LOWERBOUND (nlv$bm_buffer_pool) DO
      IF nlv$bm_buffer_pool [i].allocated_memory <> NIL THEN
        FREE nlv$bm_buffer_pool [i].allocated_memory IN nav$network_wired_heap^;
        nlv$bm_buffers_freed := TRUE;
        IF nav$statistics_enabled THEN
          nav$global_statistics.buffer_manager.containers_freed [i] :=
                nav$global_statistics.buffer_manager.containers_freed [i] + 1;
        IFEND;
      IFEND;

      pool := ^nlv$bm_allocated_buffer_pool [i];
      pool^.last_lowest_available_sub_pool := 1;
      pool^.highest_allocated_sub_pool := 1;

      FOR index := LOWERBOUND (pool^.sub_pool^) TO UPPERBOUND (pool^.sub_pool^) DO
        sub_pool := ^pool^.sub_pool^ [index];
        IF sub_pool^.allocated_memory <> NIL THEN
          FREE sub_pool^.allocated_memory IN nav$network_wired_heap^;
          sub_pool^.head := NIL;
          nlv$bm_buffers_freed := TRUE;
          IF nav$statistics_enabled THEN
            nav$global_statistics.buffer_manager.containers_freed [i] :=
                  nav$global_statistics.buffer_manager.containers_freed [i] + 1;
          IFEND;
        IFEND;
      FOREND;

      nlv$bm_buffer_pool [i].dynamic_buffers := 0;
      nlv$bm_buffer_pool [i].count := 0;

    FOREND;

  PROCEND nlp$bm_free_buffer_pools;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_get_buffer_list', EJECT ??
*copy nlh$bm_get_buffer_list

  PROCEDURE [XDCL] nlp$bm_get_buffer_list
    (VAR buffer_list { input, output } : nlt$bm_buffer_list_array;
     VAR buffers_acquired: boolean);

    VAR
      pool: nlt$bm_pool_index;

    buffers_acquired := FALSE;
    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
    FOR pool := nlc$bm_small_buffer_index TO nlc$bm_large_buffer_index DO
      IF buffer_list [pool].buffer_list <> NIL THEN
        get_buffer_list (pool, buffer_list [pool].count, buffer_list [pool].buffer_list^);
        IF buffer_list [pool].count > 0 THEN
          buffers_acquired := TRUE;
        IFEND;
      IFEND;
    FOREND;
    osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
    osp$end_subsystem_activity;
  PROCEND nlp$bm_get_buffer_list;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_get_message_prefix', EJECT ??
*copy nlh$bm_get_message_prefix

  PROCEDURE [XDCL] nlp$bm_get_message_prefix
    (    prefix: ^cell;
         prefix_length: nat$data_length;
         message_id: nlt$bm_message_id;
     VAR status: ost$status);

    VAR
      descriptor: ^nlt$bm_message_descriptor,
      message_length: integer,
      move_length: nat$data_length,
      prefix_address: ^array [0 .. 0ffffff(16)] of cell,
      prefix_data_start: nat$data_length,
      remaining_prefix_length: nat$data_length;

    status.normal := TRUE;

    IF (prefix <> NIL) AND (prefix_length > 0) THEN
      nlp$bm_get_message_length (message_id, message_length);

      IF prefix_length <= message_length THEN
        descriptor := message_id.descriptor;
        prefix_data_start := 0;
        remaining_prefix_length := prefix_length;
        prefix_address := prefix;

        REPEAT
          IF (descriptor^.container_length - descriptor^.data_start) >= remaining_prefix_length THEN
            move_length := remaining_prefix_length;
          ELSE
            move_length := descriptor^.container_length - descriptor^.data_start;
          IFEND;
          i#move (#LOC (descriptor^.container^ (1 + descriptor^.data_start)),
                #LOC (prefix_address^ [prefix_data_start]), move_length);
          remaining_prefix_length := remaining_prefix_length - move_length;
          IF remaining_prefix_length > 0 THEN
            descriptor := descriptor^.link;
            prefix_data_start := prefix_data_start + move_length;
          IFEND;
        UNTIL remaining_prefix_length = 0;

      ELSE { insufficient buffer size
        osp$set_status_condition (nae$insufficient_data, status);
      IFEND;
    ELSE { Bad input parameters.
      nap$namve_system_error (FALSE, nlv$bm_buffer_manager_caller , NIL);
    IFEND;

  PROCEND nlp$bm_get_message_prefix;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_initialize_buffer_pools', EJECT ??
*copy nlh$bm_initialize_buffer_pools

  PROCEDURE [XDCL] nlp$bm_initialize_buffer_pools
    (VAR status: ost$status);

    CONST
      heap_manager_overhead = 6 * 16,
      pp_buffer_preallocation = 16; {preallocated buffers to allow for PP buffer pool.

    VAR
      descriptor: ^^nlt$bm_message_descriptor,
      i: integer,
      large_buffer_count: integer,
      preallocated_buffers: integer,
      remaining_space: integer;

    status.normal := TRUE;
    CASE osv$page_size OF
    = 2048, 4096 =
      nlv$bm_large_buffer_size := osv$page_size;
    = 8192, 16384 =
      nlv$bm_large_buffer_size := 8192
    ELSE { Unsupported page size.
      osp$set_status_abnormal (nac$status_id, nae$initialization_fatal, 'unsupported page size', status);
      RETURN;
    CASEND;

{ Buffer counts, sizes and credits are smaller for small machines to reduce wired memory usage.

    IF (osv$180_memory_limits.upper - osv$180_memory_limits.lower) < nlc$small_machine_threshold THEN
      large_buffer_count := 44;
      nlv$cc_maximum_receive_window := 10;
      nlv$cc_grant_credit_trigger := 4;
      nlv$bm_large_buffer_size := 2048;
    ELSE
      large_buffer_count := 256;
    IFEND;

{ If the size of nlv$bm_buffer_pool is changed, the statistics nat$buffer_manager_statistics and
{ nat$pp_buffer_pool_statistics must also be changed.
{
{ The number of buffers allocated in each pool and subpool is calculated to make optimum use of wired
{ memory. Space is reserved for the buffers, descriptors and heap manager overhead. Minimum heap manager
{ space consists of 6 times the size of type ost$hp_heap_space_desc (6 * 16 bytes). Since this type is
{ defined internally within module osm$heap_manager, it cannot be referenced symbolically.

      remaining_space := osv$page_size - (((nlc$bm_small_buffer_size + #SIZE (nlt$bm_message_descriptor)) *
            (large_buffer_count * 2)) + heap_manager_overhead) MOD osv$page_size;
      nlv$bm_buffer_pool [nlc$bm_small_buffer_index].count := large_buffer_count * 2 +
            (remaining_space DIV (nlc$bm_small_buffer_size + #SIZE (nlt$bm_message_descriptor)));

      preallocated_buffers := large_buffer_count + pp_buffer_preallocation;
      remaining_space := osv$page_size - (((nlv$bm_large_buffer_size + #SIZE (nlt$bm_message_descriptor)) *
            preallocated_buffers) + heap_manager_overhead) MOD osv$page_size;
      nlv$bm_buffer_pool [nlc$bm_large_buffer_index].length := nlv$bm_large_buffer_size;
      nlv$bm_buffer_pool [nlc$bm_large_buffer_index].count := preallocated_buffers +
            (remaining_space DIV (nlv$bm_large_buffer_size + #SIZE (nlt$bm_message_descriptor)));

    /initialize_buffer_pool/
      FOR i := nlc$bm_small_buffer_index TO nlc$bm_large_buffer_index DO
        allocate_buffer_pool (nlv$bm_buffer_pool [i].length, nlv$bm_buffer_pool [i].count,
              {sub_pool_index =} 0, {touch_pages =} TRUE, nlv$bm_buffer_pool [i].head,
              nlv$bm_buffer_pool [i].allocated_memory);
        IF nlv$bm_buffer_pool [i].allocated_memory = NIL THEN
          osp$set_status_condition (nae$initialization_fatal, status);
          nlp$bm_free_buffer_pools;
          EXIT /initialize_buffer_pool/;
        IFEND;
        descriptor := ^nlv$bm_buffer_pool [i].head;
        WHILE descriptor^ <> NIL DO
          descriptor := ^descriptor^^.link;
        WHILEND;
        nlv$bm_buffer_pool [i].tail := descriptor;
      FOREND /initialize_buffer_pool/;

{ Initialize allocation buffer pool.

        remaining_space := osv$page_size - (((nlc$bm_small_buffer_size + #SIZE (nlt$bm_message_descriptor)) *
              large_buffer_count) + heap_manager_overhead) MOD osv$page_size;
        nlv$bm_allocated_buffer_pool [nlc$bm_small_buffer_index].sub_pool_allocation_size :=
              large_buffer_count + (remaining_space DIV (nlc$bm_small_buffer_size +
              #SIZE (nlt$bm_message_descriptor)));
        remaining_space := osv$page_size - (((nlv$bm_large_buffer_size + #SIZE (nlt$bm_message_descriptor)) *
              (large_buffer_count DIV 2)) + heap_manager_overhead) MOD osv$page_size;
        nlv$bm_allocated_buffer_pool [nlc$bm_large_buffer_index].buffer_length := nlv$bm_large_buffer_size;
        nlv$bm_allocated_buffer_pool [nlc$bm_large_buffer_index].sub_pool_allocation_size :=
              (large_buffer_count DIV 2) + (remaining_space DIV (nlv$bm_large_buffer_size +
              #SIZE (nlt$bm_message_descriptor)));

        IF nlv$bm_allocated_buffer_maximum > (nlv$bm_allocated_buffer_pool [nlc$bm_large_buffer_index].
              sub_pool_allocation_size * UPPERBOUND (nlv$bm_allocated_buffer_pool [nlc$bm_large_buffer_index].
              sub_pool^)) THEN
          nlv$bm_allocated_buffer_maximum := nlv$bm_allocated_buffer_pool [nlc$bm_large_buffer_index].
              sub_pool_allocation_size * UPPERBOUND (nlv$bm_allocated_buffer_pool [nlc$bm_large_buffer_index].
              sub_pool^);
          nlv$bm_allocat_buffer_threshold := nlv$bm_allocated_buffer_maximum - nlc$bm_minimum_buffers_for_cpu;
        IFEND;

  PROCEND nlp$bm_initialize_buffer_pools;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_release_message', EJECT ??
*copy nlh$bm_release_message

  PROCEDURE [XDCL] nlp$bm_release_message
    (VAR message_id {input, output} : nlt$bm_message_id);

    IF nlp$bm_valid_message_id (message_id) THEN
      IF message_id <> nlv$bm_null_message_id THEN
        osp$begin_subsystem_activity;
        osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        message_id.descriptor^.sequence_number := (message_id.descriptor^.sequence_number + 1) MOD
              nlc$bm_sequence_space;
        release_message (message_id.descriptor);
        osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        osp$end_subsystem_activity;
      IFEND;
      message_id := nlv$bm_nil_message_id;
    ELSE
      nap$namve_system_error (FALSE, nlv$bm_buffer_manager_caller , NIL);
    IFEND;
  PROCEND nlp$bm_release_message;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_release_messages', EJECT ??
*copy nlh$bm_release_messages

  PROCEDURE [XDCL] nlp$bm_release_messages
    (VAR message_id { input, output } : array [1 .. * ] of nlt$bm_message_id);

    VAR
      m: integer;

    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
    FOR m := 1 TO UPPERBOUND (message_id) DO
      IF nlp$bm_valid_message_id (message_id [m]) THEN
        IF message_id [m] <> nlv$bm_null_message_id THEN
          message_id [m].descriptor^.sequence_number := (message_id [m].descriptor^.sequence_number + 1) MOD
                nlc$bm_sequence_space;
          release_message (message_id [m].descriptor);
        IFEND;
        message_id [m] := nlv$bm_nil_message_id;
      ELSE
        nap$namve_system_error (FALSE, nlv$bm_buffer_manager_caller , NIL);
      IFEND;
    FOREND;
    osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
    osp$end_subsystem_activity;
  PROCEND nlp$bm_release_messages;
?? OLDTITLE ??
?? NEWTITLE := 'allocate_buffer', EJECT ??

{ PURPOSE:
{   This procedure checks for a buffer that has previously been allocated.  If a buffer is not found
{   Allocate Buffer Pool is called which allocates a block of buffers.
{ DESIGN:
{   The search for a previously allocated buffer is bounded by the current value of last_lowest_
{   available_sub_pool and highest_allocated_sub_pool.  The last_lowest_available_sub_pool represents
{   where the last available buffer was found.
{ NOTES:
{   The pool size must be at least 2.  The buffer manager operation lock must be locked before this
{   procedure is called.

  PROCEDURE allocate_buffer
    (    i: nlt$bm_pool_index;
     VAR descriptor: ^nlt$bm_message_descriptor);

    VAR
      index: nlt$bm_sub_pool_index,
      pool: ^nlt$bm_allocated_pool_descr,
      sub_pool: ^nlt$bm_allocatd_buffer_sub_pool;

    descriptor := NIL;
    pool := ^nlv$bm_allocated_buffer_pool [i];

{ Search nlv$bm_allocated_buffer_pool [i] for an available buffer.

    FOR index := pool^.last_lowest_available_sub_pool TO pool^.highest_allocated_sub_pool DO
      sub_pool := ^pool^.sub_pool^ [index];
      IF sub_pool^.head <> NIL THEN
        descriptor := sub_pool^.head;
        sub_pool^.head := descriptor^.link;
        descriptor^.link := NIL;
        sub_pool^.count := sub_pool^.count - 1;
        pool^.last_lowest_available_sub_pool := index;
        nlv$bm_buffer_pool [i].dynamic_buffers := nlv$bm_buffer_pool [i].dynamic_buffers + 1;

{ Touch container to ensure it is wired in memory.

        descriptor^.container^ (1) := buffer_initialization;
        RETURN;
      IFEND;
    FOREND;

{ Find unallocated sub pool.

    FOR index := LOWERBOUND (pool^.sub_pool^) TO UPPERBOUND (pool^.sub_pool^) DO
      sub_pool := ^pool^.sub_pool^ [index];
        IF sub_pool^.allocated_memory = NIL THEN
          allocate_buffer_pool (pool^.buffer_length, pool^.sub_pool_allocation_size, {sub_pool_index =} index,
                {touch_pages =} FALSE, sub_pool^.head, sub_pool^.allocated_memory);
          IF sub_pool^.allocated_memory <> NIL THEN
            descriptor := sub_pool^.head;
            sub_pool^.head := descriptor^.link;
            sub_pool^.count := pool^.sub_pool_allocation_size - 1;
            descriptor^.link := NIL;
            pool^.last_lowest_available_sub_pool := index;
            IF pool^.highest_allocated_sub_pool < index THEN
              pool^.highest_allocated_sub_pool := index;
            IFEND;
            nlv$bm_buffer_pool [i].dynamic_buffers := nlv$bm_buffer_pool [i].dynamic_buffers + 1;

{ Touch container to ensure it is wired in memory.

            descriptor^.container^ (1) := buffer_initialization;
          IFEND;
          RETURN;
        IFEND;
      FOREND;
      pool^.last_lowest_available_sub_pool := UPPERBOUND (pool^.sub_pool^);
  PROCEND allocate_buffer;
?? OLDTITLE ??
?? NEWTITLE := 'allocate_buffer_pool', EJECT ??

{ PURPOSE:
{   This procedure allocates a block of buffers.
{ DESIGN:
{   This procedure is designed to allocate a block of buffers to reduce the amount of memory fragmention.
{   Currently, memory manager stores control information before each allocated block.
{   If each buffer was allocated seperately each buffer would have the memory manager control information.
{   This problem is magnified when allocating page size buffers aligned on a page boundary because each buffer
{   allocation would use two pages.  One page for the buffer and another part of a page for the control
{   information.

  PROCEDURE allocate_buffer_pool
    (    buffer_length: nlt$bm_buffer_length;
         buffer_count: nlt$bm_buffer_count;
         sub_pool_index: nlt$bm_sub_pool_index;
         touch_pages: boolean;
     VAR first_descriptor: ^nlt$bm_message_descriptor;
     VAR allocated_memory: ^nlt$bm_allocated_memory);

    VAR
      container: build_container_pointer,
      container_index: integer,
      descriptor: ^nlt$bm_message_descriptor,
      descriptor_index: integer,
      i: integer,
      pool_index: nlt$bm_pool_index;

    CASE osv$page_size OF
    = 2048 =
      ALLOCATE buffer_sub_pool.aligned_2048: [1 .. ((buffer_length + #SIZE (nlt$bm_message_descriptor)) *
            buffer_count)] IN nav$network_wired_heap^;
      allocated_memory := ^buffer_sub_pool.aligned_2048^.buffer;
    = 4096 =
      ALLOCATE buffer_sub_pool.aligned_4096: [1 .. ((buffer_length + #SIZE (nlt$bm_message_descriptor)) *
            buffer_count)] IN nav$network_wired_heap^;
      allocated_memory := ^buffer_sub_pool.aligned_4096^.buffer;
    = 8192 =
      ALLOCATE buffer_sub_pool.aligned_8192: [1 .. ((buffer_length + #SIZE (nlt$bm_message_descriptor)) *
            buffer_count)] IN nav$network_wired_heap^;
      allocated_memory := ^buffer_sub_pool.aligned_8192^.buffer;
    = 16384 =
      ALLOCATE buffer_sub_pool.aligned_16384: [1 .. ((buffer_length + #SIZE (nlt$bm_message_descriptor)) *
            buffer_count)] IN nav$network_wired_heap^;
      allocated_memory := ^buffer_sub_pool.aligned_16384^.buffer;
    ELSE
      nap$namve_system_error (FALSE, 'Unsupported page size.', NIL);
    CASEND;

    IF allocated_memory <> NIL THEN
      container_index := 1;
      descriptor_index := buffer_length * buffer_count + 1;
      first_descriptor := #LOC (allocated_memory^ [descriptor_index]);
      descriptor := first_descriptor;
      IF buffer_length = nlc$bm_small_buffer_size THEN
        pool_index := nlc$bm_small_buffer_index;
      ELSE
        pool_index := nlc$bm_large_buffer_index;
      IFEND;
      container.adaptable_string_pointer.length := buffer_length;

      FOR i := 1 TO buffer_count - 1 DO
        container.adaptable_string_pointer.pva := #LOC (allocated_memory^ [container_index]);

        IF touch_pages THEN
          container.pointer^ (1) := buffer_initialization;
        IFEND;
        descriptor^.container := container.pointer;
        descriptor^.container_length := buffer_length;
        descriptor^.pool_index := pool_index;
        descriptor^.sub_pool_index := sub_pool_index;
        descriptor^.sequence_number := 0;
        descriptor_index := descriptor_index + #SIZE (nlt$bm_message_descriptor);
        descriptor^.link := #LOC (allocated_memory^ [descriptor_index]);
        descriptor := descriptor^.link;
        container_index := container_index + buffer_length;
      FOREND;
      container.adaptable_string_pointer.pva := #LOC (allocated_memory^ [container_index]);

      IF touch_pages THEN
        container.pointer^ (1) := buffer_initialization;
      IFEND;
      descriptor^.container := container.pointer;
      descriptor^.container_length := buffer_length;
      descriptor^.pool_index := pool_index;
      descriptor^.sub_pool_index := sub_pool_index;
      descriptor^.sequence_number := 0;
      descriptor^.link := NIL;
      IF nav$statistics_enabled THEN
        nav$global_statistics.buffer_manager.containers_allocated [pool_index] :=
              nav$global_statistics.buffer_manager.containers_allocated [pool_index] + 1;
      IFEND;
    IFEND;
  PROCEND allocate_buffer_pool;
?? OLDTITLE ??
?? NEWTITLE := 'free_buffer', EJECT ??

{ PURPOSE:
{   This procedure releases previously allocated buffers.
{ DESIGN:
{   Buffers will be requeued onto the allocated buffer sub pool unless the current buffer would
{   fill the queue, in which case whole sub pool is freed.

  PROCEDURE [INLINE] free_buffer
    (VAR buffer { input, output } : ^nlt$bm_message_descriptor);

    VAR
      pool: ^nlt$bm_allocated_pool_descr,
      pool_index: nlt$bm_pool_index,
      sub_pool: ^nlt$bm_allocatd_buffer_sub_pool,
      sub_pool_index: integer;

    pool_index := buffer^.pool_index;
    sub_pool_index := buffer^.sub_pool_index;
    pool := ^nlv$bm_allocated_buffer_pool [pool_index];
    sub_pool := ^pool^.sub_pool^ [sub_pool_index];

    sub_pool^.count := sub_pool^.count + 1;
    IF sub_pool^.count < pool^.sub_pool_allocation_size THEN {Allocated sub pool is not full.
      buffer^.link := sub_pool^.head;
      sub_pool^.head := buffer;
      IF pool^.last_lowest_available_sub_pool > sub_pool_index THEN
        pool^.last_lowest_available_sub_pool := sub_pool_index;
      IFEND;
    ELSE { Allocated buffer is full.
      IF (pool^.highest_allocated_sub_pool = sub_pool_index) AND (sub_pool_index >
            LOWERBOUND (pool^.sub_pool^)) THEN { Find highest allocated sub pool.
        sub_pool_index := sub_pool_index - 1;
        WHILE (sub_pool_index > LOWERBOUND (pool^.sub_pool^)) AND (pool^.sub_pool^ [sub_pool_index].
                allocated_memory = NIL) DO
          sub_pool_index := sub_pool_index - 1;
        WHILEND;
        pool^.highest_allocated_sub_pool := sub_pool_index;
      IFEND;
      sub_pool^.head := NIL;
      FREE sub_pool^.allocated_memory IN nav$network_wired_heap^;
      nlv$bm_buffers_freed := TRUE;
      IF nav$statistics_enabled THEN
        nav$global_statistics.buffer_manager.containers_freed [pool_index] :=
              nav$global_statistics.buffer_manager.containers_freed [pool_index] + 1;
      IFEND;
    IFEND;
    nlv$bm_buffer_pool [pool_index].dynamic_buffers := nlv$bm_buffer_pool [pool_index].dynamic_buffers - 1;
  PROCEND free_buffer;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_buffer', EJECT ??

{ DESIGN:
{   This procedure will always return a buffer.

  PROCEDURE [INLINE] get_buffer
    (    pool: nlt$bm_pool_index;
     VAR buffer: ^nlt$bm_message_descriptor);

    IF nlv$bm_buffer_pool [pool].head <> NIL THEN
      buffer := nlv$bm_buffer_pool [pool].head;
      nlv$bm_buffer_pool [pool].head := buffer^.link;
      buffer^.link := NIL;
      nlv$bm_buffer_pool [pool].count := nlv$bm_buffer_pool [pool].count - 1;
      IF nlv$bm_buffer_pool [pool].head = NIL THEN
        nlv$bm_buffer_pool [pool].tail := ^nlv$bm_buffer_pool [pool].head;
      IFEND;
    ELSE { No buffers are available.
      REPEAT
        allocate_buffer (pool, buffer);

{ Loop until a buffer is available.

        IF buffer = NIL THEN
          osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
          osp$end_subsystem_activity;
          syp$cycle;
          osp$begin_subsystem_activity;
          osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        IFEND
      UNTIL buffer <> NIL;
    IFEND;
  PROCEND get_buffer;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_buffer_list', EJECT ??

{ NOTES:
{   The buffer manager operation lock must be set before this procedure is called.

  PROCEDURE [INLINE] get_buffer_list
    (    pool: nlt$bm_pool_index;
     VAR count { input, output } : 0 .. 0ffff(16);
     VAR buffer_list: array [1 .. * ] of ^nlt$bm_message_descriptor);

    VAR
      available_buffers: integer,
      descriptor: ^nlt$bm_message_descriptor,
      i: integer,
      next_descriptor: ^nlt$bm_message_descriptor;

    IF pool = nlc$bm_large_buffer_index THEN
      available_buffers := (nlv$bm_buffer_pool [nlc$bm_large_buffer_index].count +
          (nlv$bm_allocat_buffer_threshold - nlv$bm_buffer_pool [nlc$bm_large_buffer_index].dynamic_buffers));

      IF available_buffers < count THEN
        IF available_buffers > 0 THEN
          count := available_buffers;
        ELSE
          count := 0;
        IFEND;
      IFEND;

    IFEND;

    descriptor := nlv$bm_buffer_pool [pool].head;
    next_descriptor := descriptor;

  /get_buffer/
    BEGIN
      i := 1;
      WHILE (i <= count) AND (descriptor <> NIL) DO
        next_descriptor := descriptor^.link;
        descriptor^.link := NIL;
        buffer_list [i] := descriptor;
        descriptor := next_descriptor;
        i := i + 1;
      WHILEND;
      WHILE i <= count DO
        allocate_buffer (pool, buffer_list [i]);
        IF buffer_list [i] <> NIL THEN
          buffer_list [i]^.link := NIL;
        ELSE
          EXIT /get_buffer/;
        IFEND;
        i := i + 1;
      WHILEND;
    END /get_buffer/;
    count := i - 1;
    nlv$bm_buffer_pool [pool].head := next_descriptor;
    IF nlv$bm_buffer_pool [pool].head <> NIL THEN
      nlv$bm_buffer_pool [pool].count := nlv$bm_buffer_pool [pool].count - count;
    ELSE
      nlv$bm_buffer_pool [pool].tail := ^nlv$bm_buffer_pool [pool].head;
      nlv$bm_buffer_pool [pool].count := 0;
    IFEND;
  PROCEND get_buffer_list;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_message', EJECT ??

{ PURPOSE:
{   This procedure returns a linked list of descriptor container pairs.
{
{ NOTES:
{   The number of buffers returned in the message will be based on the required_data_length plus
{   future_data_requirements.  Future_data_requirements is an estimate of the amount
{   of additional space that will be needed during the life time of the message.
{   The descriptor's data starts are initialized based on the required_data_length.
{   The buffer manager operation lock must be locked before this procedure is called.

  PROCEDURE [INLINE] get_message
    (    required_data_length: integer;
         future_data_requirements: nat$data_length;
     VAR message: ^nlt$bm_message_descriptor);

    VAR
      count: array [nlt$bm_pool_index] of nlt$bm_buffer_count,
      descriptor: ^nlt$bm_message_descriptor,
      empty_space: nat$data_length,
      i: integer,
      link: ^^nlt$bm_message_descriptor,
      pool: nlt$bm_pool_index,
      remaining_data: nat$data_length;

{ Determine the number of buffers needed.

    count [nlc$bm_large_buffer_index] := (required_data_length + future_data_requirements) DIV
          nlv$bm_large_buffer_size;
    remaining_data := (required_data_length + future_data_requirements) MOD nlv$bm_large_buffer_size;
    IF remaining_data > (3 * nlc$bm_small_buffer_size) THEN
      count [nlc$bm_large_buffer_index] := count [nlc$bm_large_buffer_index] + 1;
      count [nlc$bm_small_buffer_index] := 0;
    ELSE { Need small_buffers.
      count [nlc$bm_small_buffer_index] := remaining_data DIV nlc$bm_small_buffer_size;
      IF remaining_data MOD nlc$bm_small_buffer_size > 0 THEN
        count [nlc$bm_small_buffer_index] := count [nlc$bm_small_buffer_index] +1;
      IFEND;
    IFEND;

{ Get buffers.

    empty_space := (count [nlc$bm_large_buffer_index] * nlv$bm_large_buffer_size) +
          (count [nlc$bm_small_buffer_index] * nlc$bm_small_buffer_size) - required_data_length;
    link := ^message;
    FOR pool := nlc$bm_small_buffer_index TO nlc$bm_large_buffer_index DO
    FOR i := 1 TO count [pool] DO
      get_buffer (pool, descriptor);
      IF empty_space = 0 THEN
        descriptor^.data_start := 0;
      ELSEIF empty_space < nlv$bm_buffer_pool [pool].length THEN
        descriptor^.data_start := empty_space;
        empty_space := 0;
      ELSE
        descriptor^.data_start := nlv$bm_buffer_pool [pool].length;
        empty_space := empty_space - nlv$bm_buffer_pool [pool].length;
      IFEND;
      link^ := descriptor;
      link := ^descriptor^.link;
    FOREND;
    FOREND;
    link^ := NIL;
  PROCEND get_message;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] release_message', EJECT ??

{ DESIGN:
{   This procedure queues the static message buffers on the buffer pool. The
{   buffers in the last allocated block are freed more aggressively than those in the other
{   sub pools.
{   If buffer count is less than the threshold the dynamic message buffers are queued on the
{   buffer pool.

  PROCEDURE [INLINE] release_message
    (VAR buffer { input, output } : ^nlt$bm_message_descriptor);

    VAR
      count: nlt$bm_buffer_count,
      limit: nlt$bm_buffer_count,
      next_buffer: ^nlt$bm_message_descriptor,
      pool_index: nlt$bm_pool_index,
      sub_pool_index: integer;

    WHILE buffer <> NIL DO
      next_buffer := buffer^.link;
      pool_index := buffer^.pool_index;
      sub_pool_index := buffer^.sub_pool_index;
      count := nlv$bm_buffer_pool [pool_index].count;
      limit := nlv$bm_buffer_pool [pool_index].pool_limit;

{ Return buffer.

      IF (sub_pool_index = 0) OR (count < (limit DIV 4)) OR ((count < limit) AND
            (sub_pool_index < nlv$bm_allocated_buffer_pool [pool_index].highest_allocated_sub_pool)) THEN
        nlv$bm_buffer_pool [pool_index].count := count + 1;
        nlv$bm_buffer_pool [pool_index].tail^ := buffer;
        buffer^.link := NIL;
        nlv$bm_buffer_pool [pool_index].tail := ^buffer^.link;
      ELSE
        free_buffer (buffer);
      IFEND;
      buffer := next_buffer;
    WHILEND
  PROCEND release_message;
?? OLDTITLE ??
MODEND nlm$buffer_manager;
*DECK DECK=NLM$CC_GLOBAL_VARS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access : Channel Connection Global Vars' ??
MODULE nlm$cc_global_vars;

{ PURPOSE:
{   This module contains declarations for all global Channel Connection
{   variables.
{
{ DESIGN:
{   This module is designed to reside in the OSF$SYSTEM_CORE_133 library.
{
?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_connection
*copyc nlt$cc_work_list
*copyc nlt$device_identifier
?? POP ??
*copyc oss$network_paged
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    nlv$cc_work_list: [XDCL, #GATE, oss$network_paged] nlt$cc_work_list := [NIL, ^nlv$cc_work_list.first];

  VAR
    nlv$cc_initialize_connection: [XDCL, #GATE, oss$network_paged] nlt$cc_connection := [
            { accumulated_message_buffers }  0,
            { event_processor }              nac$nil,
            { connection_id }                [0, 0],
            { peer_reference_number }        0,
            { class }                        nlc$cc_normal_class,
            { device_specific_attributes }   [nlc$null_device_identifier, 0, nlc$cc_closed],
            { buffers_per_credit }           1,
            { next_deliverable_sequence# }   1,
            { receive_buffer }               NIL,
            { receive_credits }              0,
            { send_credits }                 0,
            { send_buffer }                  [0, 0, *, NIL],
            { sub_connection_count }         0,
            { sub_connections }              NIL,
            { no_buffers_for_peer_credit }   [FALSE],
            { no_buffers_for_user_capacity } [FALSE]];
?? OLDTITLE ??
MODEND nlm$cc_global_vars;
*DECK DECK=NLM$CC_NETWORK_EVENT_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access : Channel Connection Event Manager' ??
?? NEWTITLE := 'Global Declarations Referenced by this Module' ??
MODULE nlm$cc_network_event_manager;

{ PURPOSE:
{   The purpose of this module is to process all incoming Channel Connection
{   PDU's. The PDU is associated with the connection for which it is destined
{   and the CC protocol is applied. Any protocol violations result in discarding
{   the PDU and the reset of the network device which delivered the PDU.
{   Valid PDU's are processed as per the protocol, with the state machine being
{   updated and events delivered to the CC users.
{
{ DESIGN:
{   This module was designed to reside in the OSF$JOB_TEMPLATE_23D library and
{   execute in any task.
{
{ NOTES:
{   Procedures in this module are grouped by function, and order within each group
{   is based on the flow of control.

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_seq#_or_connect_time
*copyc oss$job_paged_literal
*copyc ost$system_flag
?? POP ??
*copyc nap$namve_system_error
*copyc nlp$bm_add_message_prefix
*copyc nlp$bm_create_message
*copyc nlp$bm_extract_message_prefix
*copyc nlp$bm_get_message_header
*copyc nlp$bm_get_message_length
*copyc nlp$bm_get_message_prefix
*copyc nlp$bm_release_message
*copyc nlp$cc_abort_connection
*copyc nlp$cc_decr_connection_count
*copyc nlp$cc_find_duplicate_connect
*copyc nlp$cc_get_device_specific_attr
*copyc nlp$cc_get_event_processor
*copyc nlp$cc_get_exclusive_via_cid
*copyc nlp$cc_get_exclus_to_unaccepted
*copyc nlp$cc_get_received_messages
*copyc nlp$cc_grant_credits
*copyc nlp$cc_incr_connection_count
*copyc nlp$cc_obtain_credits
*copyc nlp$cc_requeue_msgs_on_conn
*copyc nlp$cc_reset_device
*copyc nlp$cc_shut_down_connection
*copyc nlp$cc_send_buffer_empty
*copyc nlp$cc_send_pdu
*copyc nlp$cc_user_data_pad_size
*copyc nlp$cl_activate_layer
*copyc nlp$cl_add_device_to_connection
*copyc nlp$cl_clear_exclusive_access
*copyc nlp$cl_create_connection
*copyc nlp$cl_deactivate_layer
*copyc nlp$cl_decr_priority_connection
*copyc nlp$cl_get_layer_connection
*copyc nlp$cl_incr_priority_connection
*copyc nlp$cl_release_exclusive_access
*copyc nlp$connection_queued
*copyc nlp$get_nonexclusive_access
*copyc nlp$process_receiving_conection
*copyc nlp$release_nonexclusive_access
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
*copyc osp$decrement_locked_variable
*copyc osp$increment_locked_variable
*copyc osp$sub_from_locked_variable
*copyc osp$set_status_condition
*copyc pmp$get_executing_task_gtid
*copyc syp$cycle

*copyc nav$global_osi_statistics
*copyc nav$network_paged_heap
*copyc nav$network_procedures
*copyc nav$statistics_enabled
*copyc nav$system_id
*copyc nav$system_input_taskid
*copyc nlv$bm_large_buffer_size
*copyc nlv$bm_null_message_id
*copyc nlv$cc_grant_credit_trigger
*copyc nlv$cc_initialize_connection
*copyc nlv$cc_work_list
*copyc nlv$configured_network_devices
*copyc osv$task_private_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by this Module', EJECT ??

  VAR
    clear_to_send: [oss$job_paged_literal, READ] nlt$cc_event := [nlc$cc_clear_to_send_event];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$cc_receive_event', EJECT ??
*copy nlh$cc_receive_event

  PROCEDURE [XDCL] nlp$cc_receive_event
    (VAR cc_pdu { input, output } : nlt$bm_message_id);

    VAR
      actual: integer,
      cc_header: nlt$cc_protocol_header,
      connection_id: nlt$cl_connection_id,
      device_received_on: nlt$device_identifier,
      duplicate_connect_request: boolean,
      local_status: ost$status,
      sequence#_or_connect_timestamp: nlt$cc_seq#_or_connect_time;

{ The following received message attributes MUST be retreived from the message
{ descriptor BEFORE any extracts are attempted. This is because the received
{ message attributes are in the first message descriptor which may be released
{ as part of an extract.

    connection_id := cc_pdu.descriptor^.received_message.connection_id;
    device_received_on := cc_pdu.descriptor^.received_message.device_id;
    sequence#_or_connect_timestamp := cc_pdu.descriptor^.received_message.
          sequence#_or_connect_timestamp;

    extract_cc_header (cc_pdu, cc_header, local_status);
    IF local_status.normal THEN
      CASE cc_header.kind OF
      = nlc$cc_connect_request =
        nlp$cc_find_duplicate_connect (device_received_on, cc_header.connect_request.source_reference,
              duplicate_connect_request);
        IF NOT duplicate_connect_request THEN
          establish_new_connection (device_received_on, sequence#_or_connect_timestamp.
                time_connect_request_received, cc_header, cc_pdu);
        ELSE
{ 28. }

{! statistics begin}

          IF nav$statistics_enabled THEN
            osp$increment_locked_variable (nav$global_osi_statistics.
                  channel_connection_device^[device_received_on].duplicate_connect_indications, 0, actual);
          IFEND;

{! statistics end}

          nlp$cc_reset_device (device_received_on);
          nlp$bm_release_message (cc_pdu);
        IFEND;

      = nlc$cc_connect_confirm .. nlc$cc_expedited_data =
        process_cc_event (device_received_on, sequence#_or_connect_timestamp.sequence_number,
              connection_id, cc_header, cc_pdu);

      = nlc$cc_global_window =

{  Ignore global window PDU. Change in global flow control will
{  be communicated as part of channel protocol.

        nlp$bm_release_message (cc_pdu);
      ELSE { Protocol error - Invalid PDU kind.
        nlp$cc_reset_device (device_received_on);
        nlp$bm_release_message (cc_pdu);
      CASEND;
    ELSE
      nlp$cc_reset_device (device_received_on);
      nlp$bm_release_message (cc_pdu);
    IFEND;

  PROCEND nlp$cc_receive_event;
?? OLDTITLE ??
?? NEWTITLE := 'nlp$cc_receive_data' ??
?? NEWTITLE := 'terminate_input_processing -- Job Recovery / Task Termination', EJECT ??
*copy nlh$cc_receive_data
  PROCEDURE [XDCL] nlp$cc_receive_data
    (    cl_connection: ^nlt$cl_connection);

    PROCEDURE terminate_input_processing
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        i: integer;

      IF ((pmc$program_termination IN condition.reason) OR (pmc$program_abort IN condition.reason)) THEN
        IF next_message <> NIL THEN

{ Reverse the order of the remaining messages to LIFO.

          previous_message := NIL;
          current_message := next_message;
          REPEAT
            next_message := current_message^.received_message.next_received_message;
            current_message^.received_message.next_received_message := previous_message;
            previous_message := current_message;
            current_message := next_message;
          UNTIL (current_message = NIL);

          received_messages := previous_message;
          nlp$cc_requeue_msgs_on_conn (cl_connection, received_messages);
        IFEND;
      IFEND;
      condition_status.normal := TRUE;
    PROCEND terminate_input_processing;
?? OLDTITLE, EJECT ??

    VAR
      current_message,
      previous_message,
      next_message: ^nlt$bm_message_descriptor,
      ignore_status: ost$status,
      message_id: nlt$bm_message_id,
      received_messages: ^nlt$bm_message_descriptor;

{ If the connection is queued, the input must be processed by the system input task.
{ Problems occur if the received messages close the connection while the queued flag is set.

    IF nlp$connection_queued (cl_connection) THEN
      RETURN;
    IFEND;

    nlp$cc_get_received_messages (cl_connection, received_messages);
    IF received_messages <> NIL THEN
      osp$establish_block_exit_hndlr (^terminate_input_processing);

{ Relink the received message list in order to process the messages in FIFO order.
      previous_message := NIL;
      current_message := received_messages;
      REPEAT
        next_message := current_message^.received_message.next_received_message;
        current_message^.received_message.next_received_message := previous_message;
        previous_message := current_message;
        current_message := next_message;
      UNTIL (current_message = NIL);

      received_messages := previous_message;
      REPEAT
        next_message := received_messages^.received_message.next_received_message;
        message_id.descriptor := received_messages;
        message_id.sequence_number := received_messages^.sequence_number;
        process_received_message (cl_connection, message_id);
        received_messages := next_message;
      UNTIL (received_messages = NIL);
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND nlp$cc_receive_data;
?? OLDTITLE ??
?? NEWTITLE := 'establish_new_connection', EJECT ??
{
{ PURPOSE:
{   The purpose of this procedure is to process incoming connect requests.
{   This involves creating and initializing the connection structures and
{   delivering the connect event to the appropriate user. This procedure will
{   execute in the connection establishment task.

  PROCEDURE establish_new_connection
    (    device_received_on: nlt$device_identifier;
         time_connect_request_received: integer;
         cc_header: nlt$cc_protocol_header;
     VAR data { input, output } : nlt$bm_message_id);

?? NEWTITLE := 'get_application_layer', EJECT ??

    PROCEDURE get_application_layer
      (    address: nlt$cc_address;
           message_id: nlt$bm_message_id;
       VAR application_layer_found: boolean;
       VAR application_layer: nlt$cl_application_layer);

       VAR
         length: integer,
         local_status: ost$status,
         user_data: record
           fill: 0 .. 0ffffffff(16),
           sap_identifier: nlt$ta_sap_selector,
         recend;

      application_layer_found := TRUE;
      CASE address OF
      = nlc$network_access_address =
        application_layer := nlc$osi_network_access_agent;

      = nlc$transport_access_address =
        nlp$bm_get_message_length (message_id, length);
        IF length >= #SIZE (user_data) THEN
          nlp$bm_get_message_prefix(^user_data, #SIZE(user_data), message_id, local_status);
          IF ((user_data.sap_identifier >= nlc$ta_min_rsvd_transport_sap) AND
              (user_data.sap_identifier <= nlc$ta_max_rsvd_transport_sap)) OR
             ((user_data.sap_identifier >= nlc$ta_min_transport_sap) AND
              (user_data.sap_identifier <= nlc$ta_max_transport_sap)) OR
             ((user_data.sap_identifier >= nlc$ta_low_min_osi_sap) AND
              (user_data.sap_identifier <= nlc$ta_low_max_osi_sap)) OR
             ((user_data.sap_identifier >= nlc$ta_high_min_osi_sap) AND
              (user_data.sap_identifier <= nlc$ta_high_max_osi_sap)) THEN
            application_layer := nlc$osi_generic_xport_interface;
          ELSEIF ((user_data.sap_identifier >= nlc$ta_min_rsvd_se_session_sap) AND
              (user_data.sap_identifier <= nlc$ta_max_rsvd_se_session_sap)) OR
             ((user_data.sap_identifier >= nlc$ta_min_se_session_sap) AND
              (user_data.sap_identifier <= nlc$ta_max_se_session_sap)) THEN
            application_layer := nlc$osi_session_interface;
          ELSE
            application_layer_found := FALSE;
          IFEND;
        ELSE
          application_layer_found := FALSE;
        IFEND;

{  Currently, the only application layers for the transport access agent
{  are nlc$osi_generic_xport_interface and nlc$osi_session_interface.  Once the
{  address format has stabilized the address in the message will have to
{  be searched to determine the application layer.

      = nlc$tcp_access_address =
        application_layer := nlc$tcp_interface;
      = nlc$udp_access_address =
        application_layer := nlc$udp_interface;
      = nlc$tcpip_management_address =
        application_layer := nlc$tcpip_mgmt_access_agent;
      = nlc$link_access_address =
        application_layer := nlc$osi_link_access_agent;
      = nlc$system_management_address =
        application_layer := nlc$osi_sys_mgmt_access_agent;
      ELSE { invalid address
        application_layer_found := FALSE;
      CASEND;
    PROCEND get_application_layer;
?? OLDTITLE, EJECT ??
?? NEWTITLE := '9.  <nlc$cc_closed>  --->  <nlc$cc_connect_response_wait>' ??
?? NEWTITLE := '10.  <nlc$cc_closed>  --->  <nlc$cc_closed>' ??

    VAR
      application_layer: nlt$cl_application_layer,
      application_layer_found: boolean,
      cl_connection: ^nlt$cl_connection,
      connection: ^nlt$cc_connection,
      event: nlt$cc_event,
      event_processor: nat$network_procedure,
      ignore_accumulated_buffers: integer,
      ignore_layer_active: boolean,
      network_device_list: ^nlt$network_device_list,
      time_of_last_reset: integer;

    get_application_layer (cc_header.connect_request.destination_address, data, application_layer_found,
          application_layer);
    IF application_layer_found THEN
      nlp$cl_create_connection (application_layer, cl_connection);
      IF cl_connection <> NIL THEN
{ 9. }
        nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, ignore_layer_active,
              connection);
        connection^ := nlv$cc_initialize_connection;
        nlp$get_nonexclusive_access (nlv$configured_network_devices.access_control);
        network_device_list := nlv$configured_network_devices.network_device_list;
        time_of_last_reset := network_device_list^ [device_received_on].reset_timestamp;
        connection^.device_specific_attributes.maximum_data_length :=
              network_device_list^ [device_received_on].maximum_pdu_size - #SIZE (nlt$cc_protocol_header);
        connection^.buffers_per_credit := connection^.device_specific_attributes.maximum_data_length DIV
              nlv$bm_large_buffer_size;
        IF connection^.buffers_per_credit = 0 THEN
          connection^.buffers_per_credit := 1;
        IFEND;
        IF time_connect_request_received > time_of_last_reset THEN
          nlp$cc_incr_connection_count (device_received_on);
        IFEND;
        nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);
        IF time_connect_request_received > time_of_last_reset THEN
          nlp$cc_get_event_processor (cc_header.connect_request.destination_address,
                connection^.event_processor);
          connection^.device_specific_attributes.state := nlc$cc_connect_response_wait;
          connection^.peer_reference_number := cc_header.connect_request.source_reference;
          connection^.connection_id := cl_connection^.identifier;
          connection^.send_credits := cc_header.connect_request.initial_credit_allocation;
          connection^.device_specific_attributes.device_id := device_received_on;
          nlp$cl_add_device_to_connection (device_received_on, cl_connection);
          connection^.class := cc_header.connect_request.class;
          IF connection^.class = nlc$cc_priority_class THEN
            nlp$cl_incr_priority_connection;
          IFEND;
          nlp$cl_activate_layer (nlc$channel_connection_layer, cl_connection);

          event.kind := nlc$cc_connect_event;
          event.connect.device_id := device_received_on;
          event.connect.destination_address := cc_header.connect_request.destination_address;
          event.connect.class := cc_header.connect_request.class;
          event.connect.data := data;

          CASE cc_header.connect_request.destination_address OF
          = nlc$network_access_address =
            event_processor := nlc$na_connect_event_processor;

          = nlc$transport_access_address =
            event_processor := nlc$ta_connect_event_processor;

          = nlc$link_access_address =
            event_processor := nlc$la_connect_event_processor;

          = nlc$system_management_address =
            event_processor := nlc$sm_connect_event_processor;

          = nlc$tcp_access_address =
            event_processor := nlc$tcp_connect_event_processor;

          = nlc$udp_access_address =
            event_processor := nlc$udp_connect_event_processor;

          = nlc$tcpip_management_address =
            event_processor := nlc$tm_connect_event_processor;

          ELSE { Unknown destination address

{ This should never happen as get_application_layer was previously called and verified
{ that the destination address was valid.

            nap$namve_system_error (FALSE, 'Unknown CC connect request destination', NIL);
          CASEND;
          nav$network_procedures [event_processor].cc_event_processor^
                (cl_connection, event, ignore_accumulated_buffers);
        ELSE

{  This connect request was received before the device last reset, therefore it should not
{  be processed and the just created connection will be terminated. The connection structure
{  is created before the timestamp check in order to ensure that it will be found and
{  terminated if the device resets immediately after the check. The connection structure will
{  be released by the timer task since no layers are active.

          nlp$bm_release_message (data);
        IFEND;
        nlp$cl_release_exclusive_access (cl_connection);
      ELSE { cl_connection = NIL
{ 10. }
        nlp$bm_release_message (data);
        send_disconnect_to_peer (nlc$cc_disconnect_request, nlc$cc_dr_system_unaccomodating,
              device_received_on, cc_header.connect_request.source_reference, 0,
              cc_header.connect_request.class);
      IFEND;
    ELSE
      nlp$bm_release_message (data);
      send_disconnect_to_peer (nlc$cc_disconnect_request, nlc$cc_dr_unknown_address, device_received_on,
            cc_header.connect_request.source_reference, 0, cc_header.connect_request.class);
    IFEND;

  PROCEND establish_new_connection;
?? OLDTITLE, OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'process_cc_event', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to associate a particular CC event with
{   the corresponding connection structures. This procedure obtains and releases
{   exclusive access to the cl_connection structure. If the connection exists and
{   access is obtained the event is passed on for protocol application.

  PROCEDURE process_cc_event
    (    device_received_on: nlt$device_identifier;
         sequence_number: nlt$cc_sequence_number;
         connection_id: nlt$cl_connection_id;
         cc_header: nlt$cc_protocol_header;
     VAR data {INPUT, OUTPUT} : nlt$bm_message_id);

?? NEWTITLE := 'merge_event_in_receive_buffer', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to merge a Channel Connection event
{   into the connection receive buffer. The event is merged such that the
{   buffer contains events in order of increasing sequence numbers, i.e.
{   the first event has the lowest sequence number and the last the highest.
{   If system resources are not available this procedure will wait until
{   resources are available.


    PROCEDURE merge_event_in_receive_buffer
      (    device_id: nlt$device_identifier;
           sequence_number: nlt$cc_sequence_number;
           cc_header: nlt$cc_protocol_header;
           data: nlt$bm_message_id;
       VAR receive_buffer { input, output } : ^nlt$cc_received_pdu);

      VAR
        new_cc_pdu: ^nlt$cc_received_pdu,
        received_cc_pdu: ^^nlt$cc_received_pdu;

      REPEAT
        ALLOCATE new_cc_pdu IN nav$network_paged_heap^;
        IF new_cc_pdu = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL new_cc_pdu <> NIL;
      new_cc_pdu^.sequence_number := sequence_number;
      new_cc_pdu^.device_id := device_id;
      new_cc_pdu^.cc_header := cc_header;
      new_cc_pdu^.data := data;
      received_cc_pdu := ^receive_buffer;
      WHILE (received_cc_pdu^ <> NIL) AND (received_cc_pdu^^.sequence_number < sequence_number) DO
        received_cc_pdu := ^received_cc_pdu^^.next_cc_pdu;
      WHILEND;
      new_cc_pdu^.next_cc_pdu := received_cc_pdu^;
      received_cc_pdu^ := new_cc_pdu;

    PROCEND merge_event_in_receive_buffer;
?? OLDTITLE ??
?? NEWTITLE := 'release_connection_access', EJECT ??
  PROCEDURE release_connection_access
    (    condition: pmt$condition;
         ignore_condition_descriptor: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR condition_status: ost$status);

    IF ((pmc$program_termination IN condition.reason) OR (pmc$program_abort IN condition.reason)) THEN
      nlp$cl_clear_exclusive_access (cl_connection);
    IFEND;
    condition_status.normal := TRUE;
  PROCEND release_connection_access;
?? OLDTITLE, EJECT ??

    VAR
      access_gained: boolean,
      actual: integer,
      cl_connection: ^nlt$cl_connection,
      connection: ^nlt$cc_connection,
      connection_exists: boolean,
      device_specific_attributes: ^nlt$cc_device_specific_attr,
      executing_task_id: ost$global_task_id,
      main_connection: boolean,
      queued_cc_header: nlt$cc_protocol_header,
      queued_data: nlt$bm_message_id,
      received_cc_pdu: ^nlt$cc_received_pdu,
      system_input_task: boolean;

    pmp$get_executing_task_gtid (executing_task_id);
    system_input_task := (executing_task_id = nav$system_input_taskid);
    REPEAT

{  The 'destination_reference' field is always in the same location for all CCPDU kinds,
{  the template for a data PDU is used to reference the field.

      IF cc_header.data.destination_reference <> 0 THEN
        nlp$cc_get_exclusive_via_cid (connection_id, system_input_task,
              connection_exists, access_gained, connection, cl_connection);
      ELSEIF cc_header.kind = nlc$cc_disconnect_request THEN
        nlp$cc_get_exclus_to_unaccepted (cc_header.disconnect_request.source_reference, device_received_on,
              system_input_task, connection_exists, access_gained, connection,
              cl_connection);
      ELSE { Protocol error - Only disconnect PDU's may have destination reference number of zero.
        nlp$cc_reset_device (device_received_on);
        nlp$bm_release_message (data);
        RETURN;
      IFEND;

      IF connection_exists AND access_gained THEN
        osp$establish_block_exit_hndlr (^release_connection_access);

{ Disconnect request and confirm PDU's are processed immediately. (i.e., the CC sequence
{ numbers assigned to these PDU's are ignored)

        IF (sequence_number = connection^.next_deliverable_sequence#) OR
              (cc_header.kind = nlc$cc_disconnect_request) OR
              (cc_header.kind = nlc$cc_disconnect_confirm) THEN
          IF (cc_header.kind <> nlc$cc_disconnect_request) AND
            (cc_header.kind <> nlc$cc_disconnect_confirm) THEN
            connection^.next_deliverable_sequence# := connection^.next_deliverable_sequence# + 1;
          IFEND;
          nlp$cc_get_device_specific_attr (device_received_on, connection, main_connection,
                device_specific_attributes);
          apply_cc_protocol (cl_connection, cc_header, main_connection, device_specific_attributes,
                connection, data);
          WHILE ((connection^.receive_buffer <> NIL) AND (connection^.receive_buffer^.sequence_number =
                connection^.next_deliverable_sequence#)) DO
            received_cc_pdu := connection^.receive_buffer;
            queued_cc_header := received_cc_pdu^.cc_header;
            IF (queued_cc_header.kind <> nlc$cc_disconnect_request) AND
              (queued_cc_header.kind <> nlc$cc_disconnect_confirm) THEN
              connection^.next_deliverable_sequence# := connection^.next_deliverable_sequence# + 1;
            IFEND;
            queued_data := received_cc_pdu^.data;
            IF received_cc_pdu^.device_id <> device_specific_attributes^.device_id THEN
              nlp$cc_get_device_specific_attr (received_cc_pdu^.device_id, connection, main_connection,
                    device_specific_attributes);
            IFEND;
            connection^.receive_buffer := received_cc_pdu^.next_cc_pdu;
            FREE received_cc_pdu IN nav$network_paged_heap^;
            apply_cc_protocol (cl_connection, queued_cc_header, main_connection, device_specific_attributes,
                  connection, queued_data);
          WHILEND;
        ELSE { CCPDU received out of sequence
          merge_event_in_receive_buffer (device_received_on, sequence_number, cc_header, data,
                connection^.receive_buffer);

{! statistics begin}

          IF nav$statistics_enabled THEN
            osp$increment_locked_variable (nav$global_osi_statistics.
                  channel_connection_device^[device_received_on].pdus_processed_out_of_order, 0, actual);
          IFEND;

{! statistics end}

        IFEND;
        osp$disestablish_cond_handler;
        nlp$cl_release_exclusive_access (cl_connection);
      ELSEIF connection_exists THEN
        IF system_input_task THEN
          add_event_to_cc_work_list (device_received_on, sequence_number, connection_id,
                cc_header, data);
        ELSE
          syp$cycle;
        IFEND;
      ELSE { Connection does not exist.
        IF (cc_header.kind <> nlc$cc_disconnect_request) OR
              (cc_header.disconnect_request.destination_reference <> 0) THEN
          nlp$cc_reset_device (device_received_on);
        IFEND;
        nlp$bm_release_message (data);
      IFEND;
    UNTIL ((connection_exists AND (access_gained OR system_input_task)) OR NOT connection_exists);

  PROCEND process_cc_event;
?? OLDTITLE ??

?? NEWTITLE := 'apply_cc_protocol', EJECT ??

  PROCEDURE apply_cc_protocol
    (    cl_connection: ^nlt$cl_connection;
         cc_header: nlt$cc_protocol_header;
         main_connection: boolean;
         device_specific_attributes: ^nlt$cc_device_specific_attr;
         connection: ^nlt$cc_connection;
     VAR data { input, output } : nlt$bm_message_id);

?? NEWTITLE := '19, 20, 21. <nlc$cc_open>  --->  <nlc$cc_open>' ??
?? NEWTITLE := '23, 24, 26. <nlc$cc_open>  --->  <nlc$cc_closed>' ??

    VAR
      actual: integer,
      data_length: integer,
      event: nlt$cc_event,
      i: integer,
      ignore_accumulated_buffers: integer,
      ignore_error: boolean,
      statistic1: ^integer,
      statistic2: ^integer;

    CASE device_specific_attributes^.state OF
    = nlc$cc_open =
      CASE cc_header.kind OF
      = nlc$cc_data =

{! statistics begin}

        IF nav$statistics_enabled THEN
          nlp$bm_get_message_length (data, data_length);
          IF data_length > 0 THEN
            IF connection^.class = nlc$cc_normal_class THEN
              increment_receive_statistic (data_length, nav$global_osi_statistics.
                    channel_connection_device^[device_specific_attributes^.device_id].
                    receive);
            ELSE { IF connection^.class = nlc$cc_priority_class THEN
              increment_receive_statistic (data_length, nav$global_osi_statistics.
                    channel_connection_device^[device_specific_attributes^.device_id].
                    priority_receive);
            IFEND;
          IFEND;
        IFEND;

{! statistics end}

{ 19. }
        IF connection^.receive_credits > 0 THEN
          connection^.receive_credits := connection^.receive_credits - 1;
          connection^.send_credits := connection^.send_credits + cc_header.data.credits_granted;
          IF (connection^.send_credits > 0) AND (NOT nlp$cc_send_buffer_empty (connection)) THEN
            send_queued_data (connection);
            IF cl_connection^.message_sender.active THEN
              nav$network_procedures [connection^.event_processor].
                    cc_event_processor^ (cl_connection, clear_to_send,
                    connection^.accumulated_message_buffers);
            IFEND;
          IFEND;
          event.kind := nlc$cc_data_event;
          event.data.data := data;
          nav$network_procedures [connection^.event_processor].
                cc_event_processor^ (cl_connection, event, connection^.accumulated_message_buffers);
          IF ((device_specific_attributes^.state = nlc$cc_open) AND (connection^.receive_credits <=
                nlv$cc_grant_credit_trigger)) THEN
            nlp$cc_grant_credits (connection);
          IFEND;
        ELSE
{ 23. }

{! statistics begin}

          IF nav$statistics_enabled THEN
            IF connection^.class = nlc$cc_normal_class THEN
              statistic1 := ^nav$global_osi_statistics.
                    channel_connection_device^[device_specific_attributes^.device_id].
                    receive_pdus_discarded;
            ELSE { IF connection^.class = nlc$cc_priority_class THEN
              statistic1 := ^nav$global_osi_statistics.
                    channel_connection_device^[device_specific_attributes^.device_id].
                    priority_receive_pdus_discarded;
            IFEND;
            osp$increment_locked_variable (statistic1^, 0, actual);
          IFEND;

{! statistics end}

          nlp$cc_abort_connection (nlc$cc_dr_flow_cntrl_violation, connection, cl_connection);
          nlp$cc_reset_device (device_specific_attributes^.device_id);
          nlp$bm_release_message (data);
        IFEND;



      = nlc$cc_expedited_data =
{ 20. }
        event.kind := nlc$cc_expedited_data_event;
        event.expedited_data.data := data;
        nav$network_procedures [connection^.event_processor].
              cc_event_processor^ (cl_connection, event, connection^.accumulated_message_buffers);

{! statistics begin}

        IF nav$statistics_enabled THEN
          IF connection^.class = nlc$cc_normal_class THEN
            statistic1 := ^nav$global_osi_statistics.
                  channel_connection_device^[device_specific_attributes^.device_id].
                  received_expedited_pdus;
          ELSE { IF connection^.class = nlc$cc_priority_class THEN
            statistic1 := ^nav$global_osi_statistics.
                  channel_connection_device^[device_specific_attributes^.device_id].
                  priority_receive_expedited_pdus;
          IFEND;
          osp$increment_locked_variable (statistic1^, 0, actual);
        IFEND;

{! statistics end}

      = nlc$cc_credit_allocation =
{ 21. }
        connection^.send_credits := connection^.send_credits + cc_header.credit_allocation.credits_granted;
        IF (connection^.send_credits > 0) AND (NOT nlp$cc_send_buffer_empty (connection)) THEN
          send_queued_data (connection);
          IF cl_connection^.message_sender.active THEN
            nav$network_procedures [connection^.event_processor].
                  cc_event_processor^ (cl_connection, clear_to_send, connection^.accumulated_message_buffers);
          IFEND;
        IFEND;

{! statistics begin}

        IF nav$statistics_enabled THEN
          osp$increment_locked_variable (nav$global_osi_statistics.
                channel_connection_device^[device_specific_attributes^.device_id].
                credit_pdus_received, 0, actual);
        IFEND;

{! statistics end}

      = nlc$cc_disconnect_request =
{ 26. }
        send_disconnect_to_peer (nlc$cc_disconnect_confirm, 0, device_specific_attributes^.device_id,
              connection^.peer_reference_number, connection^.connection_id.reference_number,
              connection^.class);
        device_specific_attributes^.state := nlc$cc_closed;
        nlp$cc_shut_down_connection (connection, cl_connection, device_specific_attributes^.device_id);
        event.kind := nlc$cc_disconnect_event;
        event.disconnect.reason := cc_header.disconnect_request.reason;
        event.disconnect.data := data;
        nav$network_procedures [connection^.event_processor].
              cc_event_processor^ (cl_connection, event, ignore_accumulated_buffers);

{! statistics begin}

        IF nav$statistics_enabled THEN
          IF connection^.class = nlc$cc_normal_class THEN
            statistic1 := ^nav$global_osi_statistics.
                  channel_connection_device^[device_specific_attributes^.device_id].
                  current_normal_connections;
            statistic2 := ^nav$global_osi_statistics.channel_connection.
                  normal_connections;
          ELSE { IF connection^.class = nlc$cc_priority_class THEN
            statistic1 := ^nav$global_osi_statistics.
                  channel_connection_device^[device_specific_attributes^.device_id].
                  current_priority_connections;
            statistic2 := ^nav$global_osi_statistics.channel_connection.
                  priority_connections;
          IFEND;
          osp$decrement_locked_variable (statistic1^, 0, actual, ignore_error);
          osp$decrement_locked_variable (statistic2^, 0, actual, ignore_error);
        IFEND;

{! statistics end}

      ELSE
{ 24. }
        nlp$cc_abort_connection (nlc$cc_dr_invalid_state, connection, cl_connection);
        nlp$cc_reset_device (device_specific_attributes^.device_id);
        nlp$bm_release_message (data);
      CASEND;

?? OLDTITLE, OLDTITLE, EJECT ??
?? NEWTITLE := '14, 16. <nlc$cc_connect_response_wait>  --->  <nlc$cc_closed>' ??
?? NEWTITLE := '27. <nlc$cc_closing>  --->  <nlc$cc_closing>' ??
?? NEWTITLE := '29. <nlc$cc_closing>  --->  <nlc$cc_closed>' ??
    = nlc$cc_closing =
      IF (cc_header.kind = nlc$cc_disconnect_confirm) OR (cc_header.kind = nlc$cc_disconnect_request) THEN
{ 29. }
        IF cc_header.kind = nlc$cc_disconnect_request THEN
          nlp$bm_release_message (data);
        IFEND;
        device_specific_attributes^.state := nlc$cc_closed;

{  Determine if the "main" connection or a "subconnection" was closed. If a
{  "subconnection" was closed, decrement the subconnection count.

        IF NOT main_connection THEN
          connection^.sub_connection_count := connection^.sub_connection_count - 1;
        IFEND;
        nlp$cc_shut_down_connection (connection, cl_connection, device_specific_attributes^.device_id);
      ELSE { Discard all other PDU kinds
{ 27. }
        nlp$bm_release_message (data);

{! statistics begin}

        IF nav$statistics_enabled THEN
          IF cc_header.kind = nlc$cc_data THEN
            IF connection^.class = nlc$cc_normal_class THEN
              statistic1 := ^nav$global_osi_statistics.
                    channel_connection_device^[device_specific_attributes^.device_id].
                    receive_pdus_discarded;
            ELSE { IF connection^.class = nlc$cc_priority_class THEN
              statistic1 := ^nav$global_osi_statistics.
                    channel_connection_device^[device_specific_attributes^.device_id].
                    priority_receive_pdus_discarded;
            IFEND;
            osp$increment_locked_variable (statistic1^, 0, actual);
          IFEND;
        IFEND;

{! statistics end}

      IFEND;

    = nlc$cc_connect_response_wait =
      IF cc_header.kind = nlc$cc_disconnect_request THEN
{ 14. }
        send_disconnect_to_peer (nlc$cc_disconnect_confirm, 0, device_specific_attributes^.device_id,
              connection^.peer_reference_number, connection^.connection_id.reference_number,
              connection^.class);
        device_specific_attributes^.state := nlc$cc_closed;
        nlp$cc_shut_down_connection (connection, cl_connection, device_specific_attributes^.device_id);
        event.kind := nlc$cc_disconnect_event;
        event.disconnect.reason := cc_header.disconnect_request.reason;
        event.disconnect.data := data;
        nav$network_procedures [connection^.event_processor].
              cc_event_processor^ (cl_connection, event, ignore_accumulated_buffers);
      ELSE
{ 16. }
        nlp$cc_abort_connection (nlc$cc_dr_invalid_state, connection, cl_connection);
        nlp$cc_reset_device (device_specific_attributes^.device_id);
        nlp$bm_release_message (data);
      IFEND;

?? OLDTITLE, OLDTITLE, OLDTITLE, EJECT ??
?? NEWTITLE := '2. <nlc$cc_connect_confirm_wait>  --->  <nlc$cc_open>' ??
?? NEWTITLE := '4, 7. <nlc$cc_connect_confirm_wait>  --->  <nlc$cc_closed>' ??
    = nlc$cc_connect_confirm_wait =
      IF cc_header.kind = nlc$cc_connect_confirm THEN
{ 2. }
        connection^.peer_reference_number := cc_header.connect_confirm.source_reference;
        connection^.send_credits := cc_header.connect_confirm.initial_credit_allocation;
        IF cc_header.connect_confirm.class <> connection^.class THEN
          IF cc_header.connect_confirm.class = nlc$cc_normal_class THEN
            nlp$cl_decr_priority_connection;
          ELSE
            nlp$cl_incr_priority_connection;
          IFEND;
          connection^.class := cc_header.connect_confirm.class;
        IFEND;
        connection^.device_specific_attributes.state := nlc$cc_open;
        IF NOT main_connection THEN
          connection^.device_specific_attributes.maximum_data_length :=
                device_specific_attributes^.maximum_data_length;
          connection^.buffers_per_credit := connection^.device_specific_attributes.maximum_data_length DIV
                nlv$bm_large_buffer_size;
          IF connection^.buffers_per_credit = 0 THEN
            connection^.buffers_per_credit := 1;
          IFEND;
          device_specific_attributes^.state := nlc$cc_closed;
          connection^.device_specific_attributes.device_id := device_specific_attributes^.device_id;
          connection^.sub_connection_count := connection^.sub_connection_count - 1;
          IF connection^.sub_connection_count > 0 THEN
            FOR i := 1 TO UPPERBOUND (connection^.sub_connections^) DO
              IF connection^.sub_connections^ [i].state = nlc$cc_connect_confirm_wait THEN
                send_disconnect_to_peer (nlc$cc_disconnect_request, nlc$cc_dr_reason_not_specified,
                      connection^.sub_connections^ [i].device_id, 0,
                      connection^.connection_id.reference_number, connection^.class);
                connection^.sub_connections^ [i].state := nlc$cc_closing;
              IFEND;
            FOREND;
          IFEND;
        IFEND;
        event.kind := nlc$cc_accept_event;
        event.accept.class := cc_header.connect_confirm.class;
        event.accept.data := data;
        nav$network_procedures [connection^.event_processor].
              cc_event_processor^ (cl_connection, event, connection^.accumulated_message_buffers);

{! statistics begin}

        IF nav$statistics_enabled THEN
          IF connection^.class = nlc$cc_normal_class THEN
            statistic1 := ^nav$global_osi_statistics.
                  channel_connection_device^[device_specific_attributes^.device_id].
                  current_normal_connections;
            statistic2 := ^nav$global_osi_statistics.channel_connection.
                  normal_connections;
          ELSE { IF connection^.class = nlc$cc_priority_class THEN
            statistic1 := ^nav$global_osi_statistics.
                  channel_connection_device^[device_specific_attributes^.device_id].
                  current_priority_connections;
            statistic2 := ^nav$global_osi_statistics.channel_connection.
                  priority_connections;
          IFEND;
          osp$increment_locked_variable (statistic1^, 0, actual);
          osp$increment_locked_variable (statistic2^, 0, actual);
        IFEND;

{! statistics end}

      ELSEIF cc_header.kind = nlc$cc_disconnect_request THEN
{ 4. }
        device_specific_attributes^.state := nlc$cc_closed;
        IF NOT main_connection THEN
          connection^.sub_connection_count := connection^.sub_connection_count - 1;
        IFEND;
        IF connection^.sub_connection_count = 0 THEN
          connection^.device_specific_attributes.state := nlc$cc_closed;
          nlp$cc_shut_down_connection (connection, cl_connection, device_specific_attributes^.device_id);
          event.kind := nlc$cc_disconnect_event;
          event.disconnect.reason := cc_header.disconnect_request.reason;
          event.disconnect.data := data;
          nav$network_procedures [connection^.event_processor].
                cc_event_processor^ (cl_connection, event, ignore_accumulated_buffers);
        ELSE
          nlp$bm_release_message (data);
          nlp$cc_decr_connection_count (device_specific_attributes^.device_id);
        IFEND;
      ELSE
{ 7. }
        device_specific_attributes^.state := nlc$cc_closed;
        IF NOT main_connection THEN
          connection^.sub_connection_count := connection^.sub_connection_count - 1;
        IFEND;
        IF connection^.sub_connection_count = 0 THEN
          nlp$cc_abort_connection (nlc$cc_dr_invalid_state, connection, cl_connection);
        ELSE
          nlp$cc_decr_connection_count (device_specific_attributes^.device_id);
        IFEND;
        nlp$cc_reset_device (device_specific_attributes^.device_id);
        nlp$bm_release_message (data);
      IFEND;

    ELSE { nlc$cc_closed
      nlp$bm_release_message (data);
      IF (connection^.device_specific_attributes.state = nlc$cc_closed) AND
            (connection^.sub_connection_count = 0) AND
            (((cl_connection^.queue_on_connection) AND (NOT nlp$connection_queued(cl_connection))) OR
            ((NOT cl_connection^.queue_on_connection) AND
            (connection^.next_deliverable_sequence# = cl_connection^.next_assignable_cc_sequence#))) THEN

{ This connection is completely closed down (i.e., the main connection and all sub connections are closed)
{ and all PDU's associated with this connection have been processed; the CC layer can now be
{ deactivated and the connection identifier reused.

        nlp$cl_deactivate_layer (nlc$channel_connection_layer, cl_connection);
      IFEND;
    CASEND;

  PROCEND apply_cc_protocol;
?? OLDTITLE, OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'extract_cc_header', EJECT ??

{
{  PURPOSE:
{     The purpose of this procedure is to extract the entire Channel
{   Connection header including any user data pad bytes. The CC header
{   is returned to the caller with the pad bytes being discarded.
{

    PROCEDURE extract_cc_header
      (VAR cc_pdu { input, output } : nlt$bm_message_id;
       VAR cc_header: nlt$cc_protocol_header;
       VAR status: ost$status);

      VAR
        bytes_moved: nat$data_length,
        user_data_pad: 0 .. nlc$cc_max_user_data_pad,
        user_data_pad_size: 0 .. nlc$cc_max_user_data_pad_size;

      status.normal := TRUE;
      nlp$bm_extract_message_prefix (^cc_header, #SIZE (nlt$cc_protocol_header), cc_pdu, bytes_moved);
      IF bytes_moved = #SIZE (nlt$cc_protocol_header) THEN
        CASE cc_header.kind OF
        = nlc$cc_connect_request =
          user_data_pad_size := cc_header.connect_request.user_data_pad_size;

        = nlc$cc_connect_confirm =
          user_data_pad_size := cc_header.connect_confirm.user_data_pad_size;

        = nlc$cc_disconnect_request =
          user_data_pad_size := cc_header.disconnect_request.user_data_pad_size;

        = nlc$cc_data =
          user_data_pad_size := cc_header.data.user_data_pad_size;

        = nlc$cc_expedited_data =
          user_data_pad_size := cc_header.expedited_data.user_data_pad_size;
        ELSE
          user_data_pad_size := 0;
        CASEND;
        IF user_data_pad_size > 0 THEN
          nlp$bm_extract_message_prefix (^user_data_pad, user_data_pad_size, cc_pdu, bytes_moved);
          IF bytes_moved <> user_data_pad_size THEN
            osp$set_status_condition (nae$insufficient_data, status);
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (nae$insufficient_data, status);
      IFEND;

    PROCEND extract_cc_header;
?? OLDTITLE ??
?? NEWTITLE := 'process_received_message', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to process the message received
{ on the given channel connection. It is assumed that the channel
{ connection has been locked by the caller. This process will execute
{ in the user task that has initiated the receipt of network input.
{ All CC pdus besides a connect request, disconnect request, disconnect
{ confirm and a flow control PDU will be processed by this procedure.

  PROCEDURE process_received_message
    (    cl_connection: ^nlt$cl_connection;
     VAR cc_pdu { input, output } : nlt$bm_message_id);

    VAR
      cc_header: nlt$cc_protocol_header,
      connection: ^nlt$cc_connection,
      device_received_on: nlt$device_identifier,
      device_specific_attributes: ^nlt$cc_device_specific_attr,
      error_message: ^string (64),
      error_message_length: integer,
      layer_active: boolean,
      local_status: ost$status,
      main_connection: boolean;

{ The following received message attributes MUST be retreived from the message
{ descriptor BEFORE any extracts are attempted. This is because the received
{ message attributes are in the first message descriptor which may be released
{ as part of an extract.

    device_received_on := cc_pdu.descriptor^.received_message.device_id;

    extract_cc_header (cc_pdu, cc_header, local_status);
    IF local_status.normal THEN
      CASE cc_header.kind OF
      = nlc$cc_connect_confirm .. nlc$cc_expedited_data =
        nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, layer_active,
          connection);
        IF layer_active THEN
          nlp$cc_get_device_specific_attr (device_received_on, connection, main_connection,
            device_specific_attributes);
          apply_cc_protocol (cl_connection, cc_header, main_connection, device_specific_attributes,
            connection, cc_pdu);
        ELSE { Layer inactive
          PUSH error_message;
          STRINGREP (error_message^, error_message_length, 'Received a CC pdu on device ', device_received_on,
                ' when the cc layer is inactive.');
          nap$namve_system_error ({Recoverable_error=} TRUE, error_message^ (1, error_message_length), NIL);
          nlp$bm_release_message (cc_pdu);
        IFEND;
      ELSE { NAM/VE Internal error - invalid PDU for this process
        nlp$cc_reset_device (device_received_on);
        nlp$bm_release_message (cc_pdu);
      CASEND;
    ELSE
      nlp$cc_reset_device (device_received_on);
      nlp$bm_release_message (cc_pdu);
    IFEND;

  PROCEND process_received_message;
?? OLDTITLE ??
?? NEWTITLE := 'send_disconnect_to_peer', EJECT ??
{
{      The purpose of this request is to send a disconnect request or confirm
{   to the Channel Connection peer. This request is only used by the Channel
{   Connection Entity, it is not to be used by users of the Channel Connection
{   service.
{
{         SEND_DISCONNECT_TO_PEER (DISCONNECT_KIND, DISCONNECT_REASON,
{               DEVICE_ID, DESTINATION_REFERENCE, SOURCE_REFERENCE, CLASS)
{
{  DISCONNECT_KIND: (input) This paramter specifies whether a disconnect request
{      or a disconnect confirm is to be sent to the peer.
{
{  DISCONNECT_REASON: (input) This parameter specifies the disconnect reason that
{      is to be part of the disconnect request. This parameter is not valid if
{      DISCONNECT_KIND specifies a disconnect confirm.
{
{  DEVICE_ID: (input) This parameter specifies the network device to which the
{      disconnect is to be sent.
{
{  DESTINATION_REFERENCE: (input) This parameter specifies the destination
{      reference number.
{
{  SOURCE_REFERENCE: (input) This parameter specifies the source reference
{      number.
{
{  CLASS: (input) This parameter specifies the connection class.
{

  PROCEDURE send_disconnect_to_peer
    (    disconnect_kind: nlt$cc_pdu_kind;
         disconnect_reason: nlt$cc_disconnect_reason;
         device_id: nlt$device_identifier;
         destination_reference: nlt$cl_reference_number;
         source_reference: nlt$cl_reference_number;
         class: nlt$cc_connection_class);

    VAR
      cc_header: nlt$cc_protocol_header,
      cc_pdu: nlt$bm_message_id,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      ignore_status: ost$status;

    cc_header.length := #SIZE (nlt$cc_protocol_header);
    cc_header.kind := disconnect_kind;
    IF cc_header.kind = nlc$cc_disconnect_request THEN
      cc_header.disconnect_request.destination_reference := destination_reference;
      cc_header.disconnect_request.source_reference := source_reference;
      cc_header.disconnect_request.reason := disconnect_reason;
      cc_header.disconnect_request.user_data_pad_size := 0;
      cc_header.disconnect_request.class := class;
    ELSE { disconnect confirm
      cc_header.disconnect_confirm.destination_reference := destination_reference;
      cc_header.disconnect_confirm.source_reference := source_reference;
      cc_header.disconnect_confirm.class := class;
    IFEND;
    data_fragments [1].address := ^cc_header;
    data_fragments [1].length := cc_header.length;
    nlp$bm_create_message (data_fragments, cc_pdu, ignore_status);
    nlp$cc_send_pdu (device_id, class, cc_pdu);

  PROCEND send_disconnect_to_peer;
?? OLDTITLE ??
?? NEWTITLE := 'send_queued_data', EJECT ??
{
{ PURPOSE:
{   The purpose of this procedure is to send previously queued
{   Channel Connection PDU's. These PDU's were placed in the send queue
{   because there were no outstanding peer credits available at the time.
{   This procedure will send as many queued PDU's as possible, i.e., it will
{   send PDU's until the queue is empty or all outstanding credits have been
{   consumed.
{
{ NOTES: This procedure assumes that upon entry there are credits available
{        and PDU's to send.

    PROCEDURE send_queued_data
      (    connection {INPUT, OUTPUT} : ^nlt$cc_connection);

      VAR
        actual: integer,
        buffer_count: integer,
        cc_header: nlt$cc_protocol_header_with_pad,
        cc_header_and_pad_length: nlt$cc_pdu_size,
        data: nlt$bm_message_id,
        data_length: integer,
        extension: ^nlt$cc_send_buffer_extension,
        ignore_error: boolean,
        statistic: ^integer;

      buffer_count := 0;
      cc_header.kind := nlc$cc_data;
      cc_header.data.destination_reference := connection^.peer_reference_number;
      cc_header.data.credits_granted := nlp$cc_obtain_credits (connection);
      connection^.receive_credits := connection^.receive_credits + cc_header.data.credits_granted;

      REPEAT
        data := connection^.send_buffer.cc_pdu [connection^.send_buffer.out].data;
        nlp$bm_get_message_length (data, data_length);
        cc_header.data.user_data_pad_size := nlp$cc_user_data_pad_size (data_length);
        cc_header_and_pad_length := #SIZE (nlt$cc_protocol_header) + cc_header.data.user_data_pad_size;
        cc_header.length := data_length + cc_header_and_pad_length;
        nlp$bm_add_message_prefix (^cc_header, cc_header_and_pad_length, data);
        nlp$cc_send_pdu (connection^.device_specific_attributes.device_id, connection^.class, data);
        connection^.send_credits := connection^.send_credits - 1;
        cc_header.data.credits_granted := 0;
        connection^.send_buffer.out := (connection^.send_buffer.out + 1) MOD nlc$cc_send_buffer_limit;
        IF connection^.send_buffer.extension <> NIL THEN
          extension := connection^.send_buffer.extension;
          connection^.send_buffer.extension := extension^.nextt;
          connection^.send_buffer.cc_pdu [connection^.send_buffer.inn] := extension^.cc_pdu;
          connection^.send_buffer.inn := (connection^.send_buffer.inn + 1) MOD nlc$cc_send_buffer_limit;
          FREE extension IN nav$network_paged_heap^;
        IFEND;
        buffer_count := buffer_count + 1;
      UNTIL ((connection^.send_buffer.out = connection^.send_buffer.inn) OR (connection^.send_credits = 0));

{! statistics begin}

      IF nav$statistics_enabled THEN
        IF connection^.class = nlc$cc_normal_class THEN
          statistic := ^nav$global_osi_statistics.
                channel_connection_device^[connection^.device_specific_attributes.device_id].
                normal_send_pdus_queued;
        ELSE { IF connection^.class = nlc$cc_priority_class THEN
          statistic := ^nav$global_osi_statistics.
                channel_connection_device^[connection^.device_specific_attributes.device_id].
                priority_send_pdus_queued;
        IFEND;
        osp$sub_from_locked_variable (statistic^, buffer_count, buffer_count, actual, ignore_error);
      IFEND;

{! statistics end}

    PROCEND send_queued_data;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$cc_work_list_processor', EJECT ??
*copy nlh$cc_work_list_processor

  PROCEDURE [XDCL] nlp$cc_work_list_processor
    (    flag_id: ost$system_flag);


    VAR
      cc_header: nlt$cc_protocol_header,
      connection_id: nlt$cl_connection_id,
      current_last_work_unit: ^nlt$cc_work_unit,
      data: nlt$bm_message_id,
      device_received_on: nlt$device_identifier,
      last_work_unit: ^cell,
      pass_not_complete: boolean,
      sequence#: nlt$cc_sequence_number,
      work_unit: ^nlt$cc_work_unit;

{ Variable last_work_unit is used solely for type conversion.
{ This algorithm depends on the fact that next_work_unit is
{ the first field in the record.

    last_work_unit := nlv$cc_work_list.append;
    current_last_work_unit := last_work_unit;
    pass_not_complete := (nlv$cc_work_list.first <> NIL);
    WHILE pass_not_complete DO
      pass_not_complete := (nlv$cc_work_list.first <> current_last_work_unit);
      work_unit := nlv$cc_work_list.first;
      nlv$cc_work_list.first := nlv$cc_work_list.first^.next_work_unit;
      IF nlv$cc_work_list.first = NIL THEN
        nlv$cc_work_list.append := ^nlv$cc_work_list.first;
      IFEND;
      connection_id := work_unit^.connection_id;
      IF work_unit^.kind = nlc$cc_event_work_unit THEN
        device_received_on := work_unit^.device_received_on;
        sequence# := work_unit^.sequence#;
        cc_header := work_unit^.cc_header;
        data := work_unit^.data;
        FREE work_unit IN nav$network_paged_heap^;
        process_cc_event (device_received_on, sequence#, connection_id, cc_header, data);
      ELSE { nlc$cc_connection_work_unit
        FREE work_unit IN nav$network_paged_heap^;
        nlp$process_receiving_conection (connection_id);
      IFEND;
    WHILEND;

  PROCEND nlp$cc_work_list_processor;
?? OLDTITLE ??
?? NEWTITLE := 'add_event_to_cc_work_list', EJECT ??
{
{  PURPOSE:
{      The purpose of this procedure is to add an incoming Channel Connection
{   event into the Channel Connection work list for processing at a later time.
{   This procedure is only executed in the system input task.
{
{   NOTE: This procedure will not return until the event has been placed in the
{         work list. This may require a wait for system resources to free up.
{
{
{        ADD_EVENT_TO_CC_WORK_LIST (DEVICE_RECEIVED_ON, SEQUENCE#, CC_HEADER,
{              DATA);
{
{  DEVICE_RECEIVED_ON: (input) This parameter specifies the network device the
{       event was received on.
{
{  SEQUENCE#: (input) This parameter specifies the sequence number of the event.
{
{  CONNECTION_ID: (input) This parameter specifies the local connection identifier.
{       This identifier will be used to obtain access to the connection structure.
{
{  CC_HEADER: (input) This parameter specifies the Channel Connection header.
{
{  DATA: (input) This parameter specifies the user data of the event.
{

  PROCEDURE add_event_to_cc_work_list
    (    device_received_on: nlt$device_identifier;
         sequence#: nlt$cc_sequence_number;
         connection_id: nlt$cl_connection_id;
         cc_header: nlt$cc_protocol_header;
         data: nlt$bm_message_id);

    VAR
      cc_event: ^nlt$cc_work_unit;

    REPEAT
      ALLOCATE cc_event IN nav$network_paged_heap^;
      IF cc_event = NIL THEN
        syp$cycle;
      IFEND;
    UNTIL cc_event <> NIL;
    cc_event^.next_work_unit := NIL;
    cc_event^.kind := nlc$cc_event_work_unit;
    cc_event^.device_received_on := device_received_on;
    cc_event^.sequence# := sequence#;
    cc_event^.connection_id := connection_id;
    cc_event^.cc_header := cc_header;
    cc_event^.data := data;
    nlv$cc_work_list.append^ := cc_event;
    nlv$cc_work_list.append := ^cc_event^.next_work_unit;

  PROCEND add_event_to_cc_work_list;
?? OLDTITLE ??
?? NEWTITLE := ' increment_receive_statistic', EJECT ??

  PROCEDURE increment_receive_statistic
    (    pdu_size: integer;
     VAR statistic: osi_receive_pdu);

    VAR
      actual: osi_receive_pdu,
      compare_swap_status: osc$cs_successful .. osc$cs_variable_locked,
      expected: osi_receive_pdu,
      i: integer,
      new: osi_receive_pdu;

{ The expected_value is initialized to zero instead of the value of the
{ statistic.  If another cpu has contol of the word i.e. the left half of the
{ word would be all ones.

    expected.value := 0;
    new.pdu_total := 1;
    new.pdu_average := pdu_size;
    #SPOIL (new);

  /write_statistics/
    REPEAT
      #COMPARE_SWAP (statistic.value, expected.value, new.value, actual.value,
            compare_swap_status);
      IF compare_swap_status = osc$cs_successful THEN
        EXIT /write_statistics/;
      ELSEIF compare_swap_status = osc$cs_failed THEN

{ expected_value is different than the actual}

        #SPOIL (actual);
        expected.value := actual.value;
        new.pdu_total := actual.pdu_total + 1;
        new.pdu_average := ((actual.pdu_average * actual.pdu_total) +
              pdu_size) DIV new.pdu_total;
        #SPOIL (new);
      ELSE {another cpu has the word}
        syp$cycle;
      IFEND;
    UNTIL compare_swap_status = osc$cs_successful;
  PROCEND increment_receive_statistic;
?? OLDTITLE ??
MODEND nlm$cc_network_event_manager;
*DECK DECK=NLM$CC_TIMER_MONITOR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access : Channel Connection Timer Monitor' ??
MODULE nlm$cc_timer_monitor;

{ PURPOSE:
{   The purpose of this module is to monitor all Channel Connection timers
{   associated with a particular connection, and if an expired timer is found,
{   perform the actions necessary.
{
{ DESIGN:
{   This module is designed to reside in the OSF$JOB_TEMPLATE_23D library and
{   to execute in the NAM/VE timer task.
{
?? TITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_connection
*copyc nlt$cl_connection
?? POP ??
*copyc nlp$cancel_timer
*copyc nlp$cc_grant_credits
*copyc nlp$cl_get_layer_connection
*copyc nlp$osi_get_outbound_capacity
*copyc nlp$timer_expired
*copyc oss$job_paged_literal
*copyc nav$network_procedures
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    clear_to_send: [READ, oss$job_paged_literal] nlt$cc_event := [nlc$cc_clear_to_send_event];
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$cc_monitor_timers', EJECT ??
*copy nlh$cc_monitor_timers

  PROCEDURE [XDCL] nlp$cc_monitor_timers
    (    current_time: integer;
         cl_connection: ^nlt$cl_connection);

    VAR
      connection: ^nlt$cc_connection,
      current_capacity: nat$data_length,
      layer_active: boolean;

    nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, layer_active, connection);
    IF layer_active AND (connection^.device_specific_attributes.state = nlc$cc_open) THEN
      IF nlp$timer_expired (current_time, connection^.no_buffers_for_peer_credit) THEN
        nlp$cancel_timer (connection^.no_buffers_for_peer_credit);
        nlp$cc_grant_credits (connection);
      IFEND;
      IF nlp$timer_expired (current_time, connection^.no_buffers_for_user_capacity) THEN
        nlp$osi_get_outbound_capacity (cl_connection, current_capacity);
        IF (current_capacity > 0) AND cl_connection^.message_sender.active THEN
          nlp$cancel_timer (connection^.no_buffers_for_user_capacity);
          nav$network_procedures [connection^.event_processor].
                cc_event_processor^ (cl_connection, clear_to_send,
                connection^.accumulated_message_buffers);
        IFEND;
      IFEND;
    IFEND;

  PROCEND nlp$cc_monitor_timers;
MODEND nlm$cc_timer_monitor;
*DECK DECK=NLM$CHANNEL_CONNECTION_ENTITY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access : Channel Connection Entity' ??
MODULE nlm$channel_connection_entity;

{ PURPOSE:
{   The purpose of this module is to contain all NAM/VE Channel Connection
{   internal requests.
{
{ DESIGN:
{   This module is designed to be contained on the OSF$JOB_TEMPLATE_23D library
{   and may execute in any task.
{
{   The Channel Connection protocol multiplexes a set of independent connections
{   over a common physical channel. Each connection may be used by a pair of peer
{   processes (one residing in NOS/VE, and the other in an OSI communications device)
{   to exchange messages. Each Channel Connection provides a reliable data path,
{   ensuring both data integrity as well as proper data sequencing. Data transfer
{   on any one connection is regulated via flow control mechanisms to prevent any
{   one connection from consuming an inordinate amount of system resources. The
{   protocol also provides for two connection classes: 'normal' and 'priority', with
{   priority class connections receiving preferential treatment. The complete
{   Channel Connection protocol specification can be found in DCS document A7882.
{
{   The Channel Connection Entity performs the following services for its users:
{
{      - Connection Establishment
{
{      - Data Transfer
{
{      - Expedited Data Transfer
{
{      - Connection Termination
{
?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nlt$bm_message_id
*copyc nlt$cc_address
*copyc nlt$cc_aggregate_message
*copyc nlt$cc_connection
*copyc nlt$cc_connection_class
*copyc nlt$cc_device_and_data_list
*copyc nlt$cl_connection
*copyc nlt$device_list
*copyc ost$status
?? POP ??
*copyc nap$send_network_packet
*copyc nlp$bm_add_message_prefix
*copyc nlp$bm_build_pva_list
*copyc nlp$bm_copy_message
*copyc nlp$bm_create_message
*copyc nlp$bm_get_message_length
*copyc nlp$bm_release_message
*copyc nlp$cc_get_event_processor
*copyc nlp$cc_incr_connection_count
*copyc nlp$cc_obtain_credits
*copyc nlp$cc_shut_down_connection
*copyc nlp$cc_user_data_pad_size
*copyc nlp$cl_activate_layer
*copyc nlp$cl_add_device_to_connection
*copyc nlp$cl_deactivate_layer
*copyc nlp$cl_decr_priority_connection
*copyc nlp$cl_get_layer_connection
*copyc nlp$cl_incr_priority_connection
*copyc nlp$cl_initialize_template
*copyc nlp$get_nonexclusive_access
*copyc nlp$release_nonexclusive_access
*copyc osp$append_status_integer
*copyc osp$decrement_locked_variable
*copyc osp$increment_locked_variable
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc syp$cycle
*copyc oss$job_paged_literal
*copyc nav$global_osi_statistics
*copyc nav$network_paged_heap
*copyc nav$statistics_enabled
*copyc nlv$bm_large_buffer_size
*copyc nlv$configured_network_devices
*copyc nlv$cc_initialize_connection
?? TITLE := 'Global Declarations Declared by this Module', EJECT ??

  TYPE
    connection_states = set of nlt$cc_connection_state;

  CONST
    cc_max_send_buffer_size = 500;

  VAR
    channel_connection: [READ, oss$job_paged_literal] string (18) := 'Channel Connection';

?? TITLE := '[XDCL] nlp$cc_accept_connection', EJECT ??
?? NEWTITLE := '12.  <nlc$cc_connect_response_wait>  --->  <nlc$cc_open>' ??
*copy nlh$cc_accept_connection

  PROCEDURE [XDCL] nlp$cc_accept_connection
    (    cl_connection: ^nlt$cl_connection;
         connection_class: nlt$cc_connection_class;
         data: nlt$bm_message_id;
     VAR status: ost$status);

    VAR
      accept_data: nlt$bm_message_id,
      actual: integer,
      cc_header: nlt$cc_protocol_header_with_pad,
      cc_header_and_pad_length: nlt$cc_pdu_size,
      connection: ^nlt$cc_connection,
      data_length: integer,
      layer_active: boolean,
      statistic1: ^integer,
      statistic2: ^integer;

    status.normal := TRUE;
    accept_data := data;
    nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, layer_active, connection);
    IF (layer_active) AND (connection^.device_specific_attributes.state = nlc$cc_connect_response_wait) THEN
      nlp$bm_get_message_length (accept_data, data_length);
      IF data_length <= connection^.device_specific_attributes.maximum_data_length THEN
        IF connection_class <> connection^.class THEN
          IF connection_class = nlc$cc_normal_class THEN
            nlp$cl_decr_priority_connection;
          ELSE
            nlp$cl_incr_priority_connection;
          IFEND;
          connection^.class := connection_class;
        IFEND;
        connection^.receive_credits := nlp$cc_obtain_credits (connection);
        IF connection^.receive_credits = 0 THEN

{  Give at least one credit to the peer.

          connection^.receive_credits := 1;
        IFEND;
        connection^.device_specific_attributes.state := nlc$cc_open;
        cc_header.kind := nlc$cc_connect_confirm;
        cc_header.connect_confirm.user_data_pad_size := nlp$cc_user_data_pad_size (data_length);
        cc_header_and_pad_length := #SIZE (nlt$cc_protocol_header) +
              cc_header.connect_confirm.user_data_pad_size;
        cc_header.length := data_length + cc_header_and_pad_length;
        cc_header.connect_confirm.destination_reference := connection^.peer_reference_number;
        cc_header.connect_confirm.initial_credit_allocation := connection^.receive_credits;
        cc_header.connect_confirm.source_reference := connection^.connection_id.reference_number;
        cc_header.connect_confirm.header_pad := 0;
        cc_header.connect_confirm.class := connection_class;
        nlp$bm_add_message_prefix (^cc_header, cc_header_and_pad_length, accept_data);
        nlp$cc_send_pdu (connection^.device_specific_attributes.device_id, connection_class, accept_data);

{! statistics begin}

        IF nav$statistics_enabled THEN
          IF connection^.class = nlc$cc_normal_class THEN
            statistic1 := ^nav$global_osi_statistics.
                  channel_connection_device^[connection^.device_specific_attributes.device_id].
                  current_normal_connections;
            statistic2 := ^nav$global_osi_statistics.channel_connection.normal_connections;
          ELSE { IF connection^.class = nlc$cc_priority_class THEN
            statistic1 := ^nav$global_osi_statistics.
                  channel_connection_device^[connection^.device_specific_attributes.device_id].
                  current_priority_connections;
            statistic2 := ^nav$global_osi_statistics.channel_connection.priority_connections;
          IFEND;
          osp$increment_locked_variable (statistic1^, 0, actual);
          osp$increment_locked_variable (statistic2^, 0, actual);
        IFEND;

{! statistics end}

      ELSE
        nlp$bm_release_message (accept_data);
        osp$set_status_condition ( nae$max_data_length_exceeded,  status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              connection^.device_specific_attributes.maximum_data_length, 10, FALSE, status);
      IFEND;
    ELSE
      nlp$bm_release_message (accept_data);
      osp$set_status_abnormal (nac$status_id, nae$connection_not_proposed, channel_connection, status);
    IFEND;

  PROCEND nlp$cc_accept_connection;
?? OLDTITLE ??
?? TITLE := '[XDCL] nlp$cc_disconnect', EJECT ??
?? NEWTITLE := '5.  <nlc$cc_connect_confirm_wait>  --->  <nlc$cc_closing>' ??
?? NEWTITLE := '11.  <nlc$cc_connect_response_wait>  --->  <nlc$cc_closed>' ??
?? NEWTITLE := '25.  <nlc$cc_open>  --->  <nlc$cc_closing>' ??
*copy nlh$cc_disconnect

  PROCEDURE [XDCL] nlp$cc_disconnect
    (    cl_connection: ^nlt$cl_connection;
         data: nlt$bm_message_id;
     VAR status: ost$status);

    VAR
      actual: integer,
      cc_header: nlt$cc_protocol_header_with_pad,
      cc_header_and_pad_length: nlt$cc_pdu_size,
      connection: ^nlt$cc_connection,
      data_length: integer,
      disconnect_data: nlt$bm_message_id,
      disconnect_pdu: nlt$bm_message_id,
      i: integer,
      ignore_error: boolean,
      layer_active: boolean,
      statistic1: ^integer,
      statistic2: ^integer;

    status.normal := TRUE;
    disconnect_data := data;
    nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, layer_active, connection);
    IF (layer_active) AND (connection^.device_specific_attributes.state IN
          $connection_states [nlc$cc_connect_confirm_wait, nlc$cc_connect_response_wait, nlc$cc_open]) THEN
      nlp$bm_get_message_length (disconnect_data, data_length);
      IF data_length <= connection^.device_specific_attributes.maximum_data_length THEN
        cc_header.kind := nlc$cc_disconnect_request;
        cc_header.disconnect_request.class := connection^.class;
        cc_header.disconnect_request.user_data_pad_size := nlp$cc_user_data_pad_size (data_length);
        cc_header_and_pad_length := #SIZE (nlt$cc_protocol_header) +
              cc_header.disconnect_request.user_data_pad_size;
        cc_header.length := data_length + cc_header_and_pad_length;
        cc_header.disconnect_request.destination_reference := connection^.peer_reference_number;
        cc_header.disconnect_request.reason := nlc$cc_dr_normal_disconnect;
        cc_header.disconnect_request.source_reference := connection^.connection_id.reference_number;
        nlp$bm_add_message_prefix (^cc_header, cc_header_and_pad_length, disconnect_data);
        CASE connection^.device_specific_attributes.state OF
        = nlc$cc_open =
          nlp$cc_send_pdu (connection^.device_specific_attributes.device_id, connection^.class,
                disconnect_data);
          connection^.device_specific_attributes.state := nlc$cc_closing;

{! statistics begin}

          IF nav$statistics_enabled THEN
            IF connection^.class = nlc$cc_normal_class THEN
              statistic1 := ^nav$global_osi_statistics.
                    channel_connection_device^[connection^.device_specific_attributes.device_id].
                    current_normal_connections;
              statistic2 := ^nav$global_osi_statistics.channel_connection.normal_connections;
            ELSE { IF connection^.class = nlc$cc_priority_class THEN
              statistic1 := ^nav$global_osi_statistics.
                    channel_connection_device^[connection^.device_specific_attributes.device_id].
                    current_priority_connections;
              statistic2 := ^nav$global_osi_statistics.channel_connection.priority_connections;
            IFEND;
            osp$decrement_locked_variable (statistic1^, 1, actual, ignore_error);
            osp$decrement_locked_variable (statistic2^, 1, actual, ignore_error);
          IFEND;

{! statistics end}

        = nlc$cc_connect_response_wait =
          connection^.device_specific_attributes.state := nlc$cc_closed;
          nlp$cc_send_pdu (connection^.device_specific_attributes.device_id, connection^.class,
                disconnect_data);
          nlp$cc_shut_down_connection (connection, cl_connection, connection^.
                device_specific_attributes.device_id);

        = nlc$cc_connect_confirm_wait =
          IF connection^.sub_connection_count = 0 THEN
            nlp$cc_send_pdu (connection^.device_specific_attributes.device_id, connection^.class,
                  disconnect_data);
            connection^.device_specific_attributes.state := nlc$cc_closing;
          ELSE

{  The sub_connection_count is non-zero, therefore the "main" connection is not in use
{  and will be marked as CLOSED. All waiting "subconnections" will be disconnected.

            connection^.device_specific_attributes.state := nlc$cc_closed;
            FOR i := 1 TO UPPERBOUND (connection^.sub_connections^) DO
              IF connection^.sub_connections^ [i].state = nlc$cc_connect_confirm_wait THEN
                nlp$bm_copy_message (disconnect_data, disconnect_pdu);
                nlp$cc_send_pdu (connection^.sub_connections^ [i].device_id, connection^.class,
                      disconnect_pdu);
                connection^.sub_connections^ [i].state := nlc$cc_closing;
              IFEND;
            FOREND;
            nlp$bm_release_message (disconnect_data);
          IFEND;
        ELSE
        CASEND;
      ELSE
        nlp$bm_release_message (disconnect_data);
        osp$set_status_condition ( nae$max_data_length_exceeded,  status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              connection^.device_specific_attributes.maximum_data_length, 10, FALSE, status);
      IFEND;
    ELSE
      nlp$bm_release_message (disconnect_data);
      osp$set_status_abnormal (nac$status_id, nae$connection_not_open, channel_connection, status);
    IFEND;

  PROCEND nlp$cc_disconnect;
?? OLDTITLE, OLDTITLE, OLDTITLE ??
?? TITLE := '[XDCL] nlp$cc_initialize_template', EJECT ??
*copy nlh$cc_initialize_template

  PROCEDURE [XDCL] nlp$cc_initialize_template
    (    application_layer: nlt$cl_application_layer);

    VAR
      nil_event_processor: nlt$cl_event_processor;

    nil_event_processor.layer := nlc$channel_connection_layer;
    nil_event_processor.cc := nac$nil;
    nlp$cl_initialize_template (application_layer, nlc$channel_connection_layer, #SIZE (nlt$cc_connection), 0,
          nil_event_processor, nac$nil, nil_event_processor, nlc$cc_monitor_timers);

  PROCEND nlp$cc_initialize_template;
?? TITLE := '[XDCL] nlp$cc_request_connection', EJECT ??
?? NEWTITLE := '1.  <nlc$cc_closed>  --->  <nlc$cc_connect_confirm_wait>' ??
*copy nlh$cc_request_connection

  PROCEDURE [XDCL] nlp$cc_request_connection
    (    cl_connection: ^nlt$cl_connection;
         device_and_data_list: nlt$cc_device_and_data_list;
         destination_address: nlt$cc_address;
         connection_class: nlt$cc_connection_class;
     VAR status: ost$status);

    VAR
      actual: integer,
      cc_header: nlt$cc_protocol_header_with_pad,
      cc_header_and_pad_length: nlt$cc_pdu_size,
      connection: ^nlt$cc_connection,
      connect_data: nlt$bm_message_id,
      data_length: integer,
      data_lengths: ^array [1 .. *] of integer,
      device_count: nlt$device_count,
      i: integer,
      ignore_layer_active: boolean,
      minimum_device_max_data_length: nlt$cc_pdu_size,
      network_device_list: ^nlt$network_device_list;

    status.normal := TRUE;
    device_count := UPPERBOUND (device_and_data_list);
    nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, ignore_layer_active,
          connection);
    connection^ := nlv$cc_initialize_connection;
    connection^.class := connection_class;
    connection^.receive_credits := nlp$cc_obtain_credits (connection);
    IF connection^.receive_credits > 0 THEN
      connection^.connection_id := cl_connection^.identifier;
      nlp$cc_get_event_processor (destination_address, connection^.event_processor);
      cc_header.kind := nlc$cc_connect_request;
      cc_header.connect_request.destination_address := destination_address;
      cc_header.connect_request.initial_credit_allocation := connection^.receive_credits;
      cc_header.connect_request.source_reference := connection^.connection_id.reference_number;
      cc_header.connect_request.header_pad := 0;
      cc_header.connect_request.class := connection_class;
      IF device_count = 1 THEN
        connect_data := device_and_data_list [1].data;
        nlp$bm_get_message_length (connect_data, data_length);
        cc_header.connect_request.user_data_pad_size := nlp$cc_user_data_pad_size (data_length);
        cc_header_and_pad_length := #SIZE (nlt$cc_protocol_header) +
              cc_header.connect_request.user_data_pad_size;
        cc_header.length := data_length + cc_header_and_pad_length;
        nlp$bm_add_message_prefix (^cc_header, cc_header_and_pad_length, connect_data);

        nlp$get_nonexclusive_access (nlv$configured_network_devices.access_control);
        network_device_list := nlv$configured_network_devices.network_device_list;
        connection^.device_specific_attributes.maximum_data_length :=
              network_device_list^ [device_and_data_list [1].device_id].
              maximum_pdu_size - #SIZE (nlt$cc_protocol_header);
        connection^.buffers_per_credit := connection^.device_specific_attributes.maximum_data_length DIV
              nlv$bm_large_buffer_size;
        IF (data_length <= connection^.device_specific_attributes.maximum_data_length) AND
              (network_device_list^ [device_and_data_list [1].device_id].path_status =
              nlc$path_available) THEN
          connection^.device_specific_attributes.state := nlc$cc_connect_confirm_wait;
          connection^.device_specific_attributes.device_id := device_and_data_list [1].device_id;
          nlp$cl_add_device_to_connection (device_and_data_list [1].device_id, cl_connection);
          nlp$cc_incr_connection_count (device_and_data_list [1].device_id);
          nlp$cl_activate_layer (nlc$channel_connection_layer, cl_connection);
          send_cc_connect_request (device_and_data_list [1].device_id, connection_class, connect_data);
        ELSEIF (network_device_list^[device_and_data_list[1].device_id].path_status <>
              nlc$path_available) THEN
          nlp$bm_release_message (connect_data);
          osp$set_status_condition (nae$destination_not_reachable, status);
        ELSE
          nlp$bm_release_message (connect_data);
          osp$set_status_condition ( nae$max_data_length_exceeded,  status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                connection^.device_specific_attributes.maximum_data_length, 10, FALSE, status);
        IFEND;
        nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);
      ELSE { Broadcast connect request.
        ALLOCATE connection^.sub_connections: [1 .. device_count] IN nav$network_paged_heap^;
        IF connection^.sub_connections <> NIL THEN
          PUSH data_lengths: [1 .. device_count];
          nlp$get_nonexclusive_access (nlv$configured_network_devices.access_control);
          network_device_list := nlv$configured_network_devices.network_device_list;

{   Before any connect requests are sent, each device's maximum CCPDU size must
{   be checked to ensure the connect request does not exceed the maximum. If the
{   outgoing connect request is larger than ANY one device's maximum, then the request
{   will be aborted and no connect requests will be sent.

      /check_device_pdu_maximum/
          FOR i := 1 TO device_count DO
            connection^.sub_connections^ [i].maximum_data_length :=
                  network_device_list^ [device_and_data_list [i].device_id].
                  maximum_pdu_size - #SIZE (nlt$cc_protocol_header);
            connection^.sub_connections^ [i].state := nlc$cc_closed;
            nlp$bm_get_message_length (device_and_data_list [i].data, data_lengths^[i]);
            IF data_lengths^[i] > connection^.sub_connections^ [i].maximum_data_length THEN
              FREE connection^.sub_connections IN nav$network_paged_heap^;
              osp$set_status_condition ( nae$max_data_length_exceeded,  status);
              osp$append_status_integer (osc$status_parameter_delimiter,
                    connection^.sub_connections^ [i].maximum_data_length, 10, FALSE, status);
              EXIT /check_device_pdu_maximum/;
            IFEND;
          FOREND /check_device_pdu_maximum/;

          IF status.normal THEN
            nlp$cl_activate_layer (nlc$channel_connection_layer, cl_connection);
            minimum_device_max_data_length := nlc$cc_max_pdu_size;
            FOR i := 1 TO device_count DO
              connect_data := device_and_data_list [i].data;
              cc_header.connect_request.user_data_pad_size := nlp$cc_user_data_pad_size
                (data_lengths^[i]);
              cc_header_and_pad_length := #SIZE (nlt$cc_protocol_header) +
                cc_header.connect_request.user_data_pad_size;
              cc_header.length := data_lengths^[i] + cc_header_and_pad_length;
              nlp$bm_add_message_prefix (^cc_header, cc_header_and_pad_length, connect_data);
              IF (network_device_list^ [device_and_data_list [i].device_id].path_status =
                    nlc$path_available) THEN
                connection^.sub_connections^ [i].state := nlc$cc_connect_confirm_wait;
                connection^.sub_connections^ [i].device_id := device_and_data_list [i].device_id;
                nlp$cl_add_device_to_connection (device_and_data_list [i].device_id, cl_connection);
                connection^.sub_connection_count := connection^.sub_connection_count + 1;
                IF connection^.sub_connections^ [i].maximum_data_length < minimum_device_max_data_length THEN
                  minimum_device_max_data_length := connection^.sub_connections^ [i].maximum_data_length;
                IFEND;
                nlp$cc_incr_connection_count (device_and_data_list [i].device_id);
                send_cc_connect_request (device_and_data_list [i].device_id, connection_class, connect_data);
              ELSE
                nlp$bm_release_message (connect_data);
                osp$set_status_condition (nae$destination_not_reachable, status);
              IFEND;
            FOREND;
            IF connection^.sub_connection_count > 0 THEN
              connection^.device_specific_attributes.state := nlc$cc_connect_confirm_wait;
              connection^.device_specific_attributes.maximum_data_length := minimum_device_max_data_length;
              status.normal := TRUE;

{! statistics begin}

              IF nav$statistics_enabled THEN
                osp$increment_locked_variable (nav$global_osi_statistics.channel_connection.
                      broadcast_connect_requests, 0, actual);
              IFEND;

{! statistics end}

            ELSE
              nlp$cl_deactivate_layer (nlc$channel_connection_layer, cl_connection);
              FREE connection^.sub_connections IN nav$network_paged_heap^;
            IFEND;
          ELSE
            FOR i := 1 to device_count DO
              connect_data := device_and_data_list [i].data;
              nlp$bm_release_message (connect_data);
            FOREND;
          IFEND;
          nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);
        ELSE  { connection^.sub_connections = NIL }
          FOR i := 1 to device_count DO
            connect_data := device_and_data_list [i].data;
            nlp$bm_release_message (connect_data);
          FOREND;
          osp$set_status_condition ( nae$resources_unavailable,  status);
        IFEND;
      IFEND;
      IF status.normal AND (connection_class = nlc$cc_priority_class) THEN
          nlp$cl_incr_priority_connection;
      IFEND;
    ELSE { No credits available for peer. }
      FOR i := 1 to device_count DO
        connect_data := device_and_data_list [i].data;
        nlp$bm_release_message (connect_data);
      FOREND;
      osp$set_status_condition ( nae$resources_unavailable,  status);
    IFEND;

  PROCEND nlp$cc_request_connection;
?? OLDTITLE ??
?? TITLE := '[XDCL] nlp$cc_send_data', EJECT ??
?? NEWTITLE := '17.  <nlc$cc_open>  --->  <nlc$cc_open>' ??
*copy nlh$cc_send_data

  PROCEDURE [XDCL] nlp$cc_send_data
    (    cl_connection: ^nlt$cl_connection;
         data: nlt$bm_message_id;
     VAR status: ost$status);

    VAR
      actual: integer,
      cc_header: nlt$cc_protocol_header_with_pad,
      cc_header_and_pad_length: nlt$cc_pdu_size,
      connection: ^nlt$cc_connection,
      data_length: integer,
      layer_active: boolean,
      send_data: nlt$bm_message_id,
      statistic: ^integer;

    status.normal := TRUE;
    send_data := data;
    nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, layer_active, connection);
    IF (layer_active) AND (connection^.device_specific_attributes.state = nlc$cc_open) THEN
      nlp$bm_get_message_length (send_data, data_length);
      IF data_length <= connection^.device_specific_attributes.maximum_data_length THEN
        IF connection^.send_credits > 0 THEN
          cc_header.kind := nlc$cc_data;
          cc_header.data.user_data_pad_size := nlp$cc_user_data_pad_size (data_length);
          cc_header_and_pad_length := #SIZE (nlt$cc_protocol_header) + cc_header.data.user_data_pad_size;
          cc_header.length := data_length + cc_header_and_pad_length;
          cc_header.data.destination_reference := connection^.peer_reference_number;
          cc_header.data.class := connection^.class;
          cc_header.data.credits_granted := nlp$cc_obtain_credits (connection);
          connection^.receive_credits := connection^.receive_credits + cc_header.data.credits_granted;

{ Store the current send credits value in the CC header, this is NOT part of the CC protocol and is done
{ ONLY to provide more information in the event of a peer detected flow control violation.

          cc_header.data.header_pad := connection^.send_credits;

          nlp$bm_add_message_prefix (^cc_header, cc_header_and_pad_length, send_data);
          nlp$cc_send_pdu (connection^.device_specific_attributes.device_id, connection^.class, send_data);
          connection^.send_credits := connection^.send_credits - 1;
        ELSE
          store_cc_pdu (cl_connection^.layers_active, send_data, connection^.send_buffer);

{! statistics begin}

          IF nav$statistics_enabled THEN
            IF connection^.class = nlc$cc_normal_class THEN
              statistic := ^nav$global_osi_statistics.
                    channel_connection_device^[connection^.device_specific_attributes.device_id].
                    normal_send_pdus_queued;
            ELSE { IF connection^.class = nlc$cc_priority_class THEN
              statistic := ^nav$global_osi_statistics.
                    channel_connection_device^[connection^.device_specific_attributes.device_id].
                    priority_send_pdus_queued;
            IFEND;
            osp$increment_locked_variable (statistic^, 0, actual);
          IFEND;

{! statistics end}

        IFEND;
      ELSE
        nlp$bm_release_message (send_data);
        osp$set_status_condition ( nae$max_data_length_exceeded,  status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              connection^.device_specific_attributes.maximum_data_length, 10, FALSE, status);
      IFEND;
    ELSE
      nlp$bm_release_message (send_data);
      osp$set_status_abnormal (nac$status_id, nae$connection_not_open, channel_connection, status);
    IFEND;

  PROCEND nlp$cc_send_data;
?? OLDTITLE ??
?? TITLE := '[XDCL] nlp$cc_send_data_fragments', EJECT ??
?? NEWTITLE := '17.  <nlc$cc_open>  --->  <nlc$cc_open>' ??
*copy nlh$cc_send_data_fragments

  PROCEDURE [XDCL] nlp$cc_send_data_fragments
    (    cl_connection: ^nlt$cl_connection;
         data: nat$data_fragments;
     VAR status: ost$status);

    VAR
      actual: integer,
      cc_header: nlt$cc_protocol_header_with_pad,
      cc_header_and_pad_length: nlt$cc_pdu_size,
      connection: ^nlt$cc_connection,
      data_length: integer,
      i: integer,
      layer_active: boolean,
      output_message: ^nat$data_fragments,
      send_data: nlt$bm_message_id,
      statistic: ^integer;

    status.normal := TRUE;
    nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, layer_active, connection);
    IF (layer_active) AND (connection^.device_specific_attributes.state = nlc$cc_open) THEN
      data_length := 0;
      FOR i := LOWERBOUND (data) TO UPPERBOUND (data) DO
        IF (data [i].address <> NIL) THEN
          data_length := data_length + data[i].length;
        IFEND;
      FOREND;
      IF data_length <= connection^.device_specific_attributes.maximum_data_length THEN
        IF connection^.send_credits > 0 THEN
          cc_header.kind := nlc$cc_data;
          cc_header.data.user_data_pad_size := nlp$cc_user_data_pad_size (data_length);
          cc_header_and_pad_length := #SIZE (nlt$cc_protocol_header) + cc_header.data.user_data_pad_size;
          cc_header.length := data_length + cc_header_and_pad_length;
          cc_header.data.destination_reference := connection^.peer_reference_number;
          cc_header.data.class := connection^.class;
          cc_header.data.credits_granted := nlp$cc_obtain_credits (connection);
          connection^.receive_credits := connection^.receive_credits + cc_header.data.credits_granted;

{ Store the current send credits value in the CC header, this is NOT part of the CC protocol and is done
{ ONLY to provide more information in the event of a peer detected flow control violation.

          cc_header.data.header_pad := connection^.send_credits;

          PUSH output_message: [1 .. (UPPERBOUND (data) + 1)];
          output_message^ [1].address := ^cc_header;
          output_message^ [1].length := cc_header_and_pad_length;
          FOR i := 2 TO UPPERBOUND (output_message^) DO
            output_message^ [i] := data [i - 1];
          FOREND;
          nlp$bm_create_message (output_message^, send_data, status);
          nlp$cc_send_pdu (connection^.device_specific_attributes.device_id, connection^.class, send_data);
          connection^.send_credits := connection^.send_credits - 1;
        ELSE
          nlp$bm_create_message (data, send_data, status);
          store_cc_pdu (cl_connection^.layers_active, send_data, connection^.send_buffer);

{! statistics begin}

          IF nav$statistics_enabled THEN
            IF connection^.class = nlc$cc_normal_class THEN
              statistic := ^nav$global_osi_statistics.
                    channel_connection_device^[connection^.device_specific_attributes.device_id].
                    normal_send_pdus_queued;
            ELSE { IF connection^.class = nlc$cc_priority_class THEN
              statistic := ^nav$global_osi_statistics.
                    channel_connection_device^[connection^.device_specific_attributes.device_id].
                    priority_send_pdus_queued;
            IFEND;
            osp$increment_locked_variable (statistic^, 0, actual);
          IFEND;

{! statistics end}

        IFEND;
      ELSE
        osp$set_status_condition ( nae$max_data_length_exceeded,  status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              connection^.device_specific_attributes.maximum_data_length, 10, FALSE, status);
      IFEND;
    ELSE
      osp$set_status_abnormal (nac$status_id, nae$connection_not_open, channel_connection, status);
    IFEND;

  PROCEND nlp$cc_send_data_fragments;
?? OLDTITLE ??

?? TITLE := '[XDCL] nlp$cc_send_aggregate_message', EJECT ??

  PROCEDURE [XDCL] nlp$cc_send_aggregate_message
   (    cl_connection: ^nlt$cl_connection;
        message: nlt$cc_aggregate_message;
    VAR status: ost$status);
*copy nlh$cc_send_aggregate_message
?? NEWTITLE := 'release_aggregates', EJECT ??

    PROCEDURE release_aggregates
     (    message: nlt$cc_aggregate_message);
      VAR
        i: integer,
        release_message: nlt$bm_message_id;

      FOR i := LOWERBOUND (message) TO UPPERBOUND (message) DO
        CASE message [i].kind OF
        = nlc$cc_data_event =
          release_message := message [i].data;
          nlp$bm_release_message (release_message);
        = nlc$cc_expedited_data_event =
          release_message := message [i].expedited_data;
          nlp$bm_release_message (release_message);
        ELSE
          ;
        CASEND;
      FOREND;
    PROCEND release_aggregates;
?? OLDTITLE, EJECT ??

    VAR
      actual: integer,
      cc_header: nlt$cc_protocol_header_with_pad,
      cc_header_and_pad_length: nlt$cc_pdu_size,
      connection: ^nlt$cc_connection,
      data: nlt$bm_message_id,
      data_length: integer,
      i: integer,
      layer_active: boolean,
      statistic: ^integer;

    status.normal := TRUE;
    nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, layer_active, connection);
    IF (layer_active) AND (connection^.device_specific_attributes.state = nlc$cc_open) THEN
      i := 1;
      WHILE (status.normal AND (i <= UPPERBOUND (message))) DO
        CASE message [i].kind OF
        = nlc$cc_data_event =
          nlp$bm_get_message_length (message [i].data, data_length);
          IF data_length > connection^.device_specific_attributes.maximum_data_length THEN
            osp$set_status_condition ( nae$max_data_length_exceeded,  status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  connection^.device_specific_attributes.maximum_data_length, 10, FALSE, status);
          IFEND;
        = nlc$cc_expedited_data_event =
          nlp$bm_get_message_length (message [i].expedited_data, data_length);
          IF data_length > connection^.device_specific_attributes.maximum_data_length THEN
            osp$set_status_condition ( nae$max_data_length_exceeded,  status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  connection^.device_specific_attributes.maximum_data_length, 10, FALSE, status);
          IFEND;
        ELSE
          osp$set_status_condition ( nae$improper_aggregate_kind,  status);
        CASEND;
        i := i + 1;
      WHILEND;

      IF status.normal THEN
        FOR i := 1 TO UPPERBOUND (message) DO
          CASE message [i].kind OF
          = nlc$cc_data_event =
            data := message [i].data;
            IF connection^.send_credits > 0 THEN
              nlp$bm_get_message_length (message [i].data, data_length);
              cc_header.kind := nlc$cc_data;
              cc_header.data.user_data_pad_size := nlp$cc_user_data_pad_size (data_length);
              cc_header_and_pad_length := #SIZE (nlt$cc_protocol_header) +
                                                         cc_header.data.user_data_pad_size;
              cc_header.length := data_length + cc_header_and_pad_length;
              cc_header.data.destination_reference := connection^.peer_reference_number;
              cc_header.data.class := connection^.class;
              cc_header.data.credits_granted := nlp$cc_obtain_credits (connection);
              connection^.receive_credits := connection^.receive_credits + cc_header.data.credits_granted;

{ Store the current send credits value in the CC header, this is NOT part of the CC protocol and is done
{ ONLY to provide more information in the event of a peer detected flow control violation.

              cc_header.data.header_pad := connection^.send_credits;

              nlp$bm_add_message_prefix (^cc_header, cc_header_and_pad_length, data);
              nlp$cc_send_pdu (connection^.device_specific_attributes.device_id, connection^.class,
                       data);
              connection^.send_credits := connection^.send_credits - 1;
            ELSE
              store_cc_pdu (cl_connection^.layers_active, data, connection^.send_buffer);

{! statistics begin}

              IF nav$statistics_enabled THEN
                IF connection^.class = nlc$cc_normal_class THEN
                  statistic := ^nav$global_osi_statistics.
                        channel_connection_device^[connection^.device_specific_attributes.device_id].
                        normal_send_pdus_queued;
                ELSE { IF connection^.class = nlc$cc_priority_class THEN
                  statistic := ^nav$global_osi_statistics.
                        channel_connection_device^[connection^.device_specific_attributes.device_id].
                        priority_send_pdus_queued;
                IFEND;
                osp$increment_locked_variable (statistic^, 0, actual);
              IFEND;

{! statistics end}

            IFEND;
          = nlc$cc_expedited_data_event =
            nlp$cc_send_expedited_data (cl_connection, message [i].expedited_data, status);

{! statistics begin}

            IF nav$statistics_enabled THEN
              IF connection^.class = nlc$cc_normal_class THEN
                statistic := ^nav$global_osi_statistics.
                      channel_connection_device^[connection^.device_specific_attributes.device_id].
                      send_expedited_pdus;
              ELSE { IF connection^.class = nlc$cc_priority_class THEN
                statistic := ^nav$global_osi_statistics.
                      channel_connection_device^[connection^.device_specific_attributes.device_id].
                      priority_send_expedited_pdus;
              IFEND;
              osp$increment_locked_variable (statistic^, 0, actual);
            IFEND;

{! statistics end}

          CASEND;
        FOREND;
      ELSE
        release_aggregates (message);
      IFEND;
    ELSE
      release_aggregates (message);
      osp$set_status_condition ( nae$connection_not_open,  status);
    IFEND;
  PROCEND nlp$cc_send_aggregate_message;
?? TITLE := '[XDCL] nlp$cc_send_expedited_data', EJECT ??
?? NEWTITLE := '18.  <nlc$cc_open>  --->  <nlc$cc_open>' ??
*copy nlh$cc_send_expedited_data

  PROCEDURE [XDCL] nlp$cc_send_expedited_data
    (    cl_connection: ^nlt$cl_connection;
         data: nlt$bm_message_id;
     VAR status: ost$status);

    VAR
      actual: integer,
      cc_header: nlt$cc_protocol_header_with_pad,
      cc_header_and_pad_length: nlt$cc_pdu_size,
      connection: ^nlt$cc_connection,
      data_length: integer,
      expedited_data: nlt$bm_message_id,
      layer_active: boolean,
      statistic: ^integer;

    status.normal := TRUE;
    expedited_data := data;
    nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, layer_active, connection);
    IF (layer_active) AND (connection^.device_specific_attributes.state = nlc$cc_open) THEN
      nlp$bm_get_message_length (expedited_data, data_length);
      IF data_length <= connection^.device_specific_attributes.maximum_data_length THEN
        cc_header.kind := nlc$cc_expedited_data;
        cc_header.expedited_data.user_data_pad_size := nlp$cc_user_data_pad_size (data_length);
        cc_header_and_pad_length := #SIZE (nlt$cc_protocol_header) +
              cc_header.expedited_data.user_data_pad_size;
        cc_header.length := data_length + cc_header_and_pad_length;
        cc_header.expedited_data.destination_reference := connection^.peer_reference_number;
        cc_header.expedited_data.class := connection^.class;
        nlp$bm_add_message_prefix (^cc_header, cc_header_and_pad_length, expedited_data);
        nlp$cc_send_pdu (connection^.device_specific_attributes.device_id, connection^.class, expedited_data);

{! statistics begin}

        IF nav$statistics_enabled THEN
          IF connection^.class = nlc$cc_normal_class THEN
            statistic := ^nav$global_osi_statistics.
                  channel_connection_device^[connection^.device_specific_attributes.device_id].
                  send_expedited_pdus;
          ELSE { IF connection^.class = nlc$cc_priority_class THEN
            statistic := ^nav$global_osi_statistics.
                  channel_connection_device^[connection^.device_specific_attributes.device_id].
                  priority_send_expedited_pdus;
          IFEND;
          osp$increment_locked_variable (statistic^, 0, actual);
        IFEND;

{! statistics end}

      ELSE
        nlp$bm_release_message (expedited_data);
        osp$set_status_condition ( nae$max_data_length_exceeded,  status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              connection^.device_specific_attributes.maximum_data_length, 10, FALSE, status);
      IFEND;
    ELSE
      nlp$bm_release_message (expedited_data);
      osp$set_status_abnormal (nac$status_id, nae$connection_not_open, channel_connection, status);
    IFEND;

  PROCEND nlp$cc_send_expedited_data;
?? OLDTITLE ??
?? TITLE := '[XDCL] nlp$cc_send_pdu', EJECT ??
*copy nlh$cc_send_pdu

  PROCEDURE [XDCL] nlp$cc_send_pdu
    (    device_id: nlt$device_identifier;
         class: nlt$cc_connection_class;
     VAR cc_pdu {INPUT,OUTPUT} : nlt$bm_message_id);

    VAR
      data_length: integer,
      network_device_list: ^nlt$network_device_list,
      pva_list: ^nat$data_fragments;

    nlp$get_nonexclusive_access (nlv$configured_network_devices.access_control);
    network_device_list := nlv$configured_network_devices.network_device_list;
    IF network_device_list^ [device_id].path_status = nlc$path_available THEN
      nlp$bm_build_pva_list (cc_pdu, pva_list);

{! statistics begin}

      IF nav$statistics_enabled THEN
        nlp$bm_get_message_length (cc_pdu, data_length);
        IF data_length > 0 THEN
          IF class = nlc$cc_normal_class THEN
            increment_send_statistic (data_length, nav$global_osi_statistics.
                  channel_connection_device^[device_id].send);
          ELSE { IF class = nlc$cc_priority_class THEN
            increment_send_statistic (data_length, nav$global_osi_statistics.
                  channel_connection_device^[device_id].priority_send);
          IFEND;
        IFEND;
      IFEND;

{! statistics end}

      nap$send_network_packet (class, device_id, cc_pdu,
            network_device_list^ [device_id].logical_unit, pva_list);
    ELSE
      nlp$bm_release_message (cc_pdu);
    IFEND;
    nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);

  PROCEND nlp$cc_send_pdu;
?? TITLE := ' increment_send_statistic', EJECT ??

  PROCEDURE increment_send_statistic
    (    pdu_size: integer;
     VAR statistic: osi_send_pdu);

    VAR
      actual: osi_send_pdu,
      compare_swap_status: osc$cs_successful .. osc$cs_variable_locked,
      expected: osi_send_pdu,
      i: integer,
      new: osi_send_pdu;

{ The expected_value is initialized to zero instead of the value of the
{ statistic.  If another cpu has contol of the word i.e. the left half of the word would
{ be all ones.

    expected.value := 0;
    new.pdu_total := 1;
    new.pdu_average := pdu_size;
    #SPOIL (new);

  /write_statistics/
    REPEAT
      #COMPARE_SWAP (statistic.value, expected.value, new.value, actual.value,
            compare_swap_status);
      IF compare_swap_status = osc$cs_successful THEN
        EXIT /write_statistics/;
      ELSEIF compare_swap_status = osc$cs_failed THEN
            {expected_value is different than the actual}
        #SPOIL (actual);
        expected.value := actual.value;
        new.pdu_total := actual.pdu_total + 1;
        new.pdu_average := ((actual.pdu_average * actual.pdu_total) +
              pdu_size) DIV new.pdu_total;
        #SPOIL (new);
      ELSE {another cpu has the word}
        syp$cycle;
      IFEND;
    UNTIL compare_swap_status = osc$cs_successful;
  PROCEND increment_send_statistic;
?? TITLE := '[INLINE] send_cc_connect_request', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to send a Channel Connection
{   Connect request to the specified network device.
{
{ NOTES: This procedure assumes that the network_device_list has been locked
{        by the caller.
{

  PROCEDURE [INLINE] send_cc_connect_request
    (    device_id: nlt$device_identifier;
         class: nlt$cc_connection_class;
     VAR data {INPUT, OUTPUT} : nlt$bm_message_id);

    VAR
      network_device_list: ^nlt$network_device_list,
      pva_list: ^nat$data_fragments;

    network_device_list := nlv$configured_network_devices.network_device_list;
      nlp$bm_build_pva_list (data, pva_list);
    nap$send_network_packet (class, device_id, data,
          network_device_list^ [device_id].logical_unit, pva_list);

  PROCEND send_cc_connect_request;
?? TITLE := '[INLINE] store_cc_pdu', EJECT ??

  PROCEDURE [INLINE] store_cc_pdu
    (    layers_active: nlt$cl_layers;
     VAR data: nlt$bm_message_id;
     VAR send_buffer: nlt$cc_send_buffer);

    VAR
      data_extension: ^nlt$cc_send_buffer_extension,
      extension: ^^nlt$cc_send_buffer_extension,
      message_count: integer;

    IF NOT (((send_buffer.out + (nlc$cc_send_buffer_limit - 1)) MOD nlc$cc_send_buffer_limit) =
          send_buffer.inn) THEN

{ Space is available in the send buffer.

      send_buffer.cc_pdu [send_buffer.inn].data := data;
      send_buffer.inn := (send_buffer.inn + 1) MOD nlc$cc_send_buffer_limit;
    ELSE { send buffer full
      message_count := 0;
      extension := ^send_buffer.extension;
      WHILE (extension^ <> NIL) DO
        message_count := message_count + 1;
        extension := ^extension^^.nextt;
      WHILEND;
      IF (message_count < cc_max_send_buffer_size) OR NOT ((nlc$osi_network_access_agent IN layers_active) OR
            (nlc$osi_link_access_agent IN layers_active)) THEN
        REPEAT
          ALLOCATE data_extension IN nav$network_paged_heap^;
          IF (data_extension = NIL) THEN
            syp$cycle;
          IFEND;
        UNTIL (data_extension <> NIL);
        data_extension^.cc_pdu.data := data;
        data_extension^.nextt := NIL;
        extension^ := data_extension;
      ELSE
        nlp$bm_release_message (data);
      IFEND;
    IFEND;

  PROCEND store_cc_pdu;
?? OLDTITLE ??
MODEND nlm$channel_connection_entity;
*DECK DECK=NLM$CHANNEL_CONNECTION_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access : Channel Connection Manager' ??
MODULE nlm$channel_connection_manager;

{ PURPOSE:
{   The purpose of this module is to isolate the knowledge of the structures
{   required to gain access to a Channel Connection. This module also contains
{   the procedures used to: initiate a device reset, shut down a connection,
{   abort a connection and terminate all connections associated with a particular
{   device.
{
{ DESIGN:
{   This module was designed to reside on the OSF$JOB_TEMPLATE_23D library.
{
?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nac$null_connection_id
*copyc nlt$cc_connection
*copyc nlt$cc_connection_class
?? POP ??
*copyc nap$issue_pp_request
*copyc nap$namve_system_error
*copyc nlp$bm_release_message
*copyc nlp$cc_decr_connection_count
*copyc nlp$cc_get_device_specific_attr
*copyc nlp$cc_get_received_messages
*copyc nlp$cc_grant_credits
*copyc nlp$cl_deactivate_layer
*copyc nlp$cl_decr_priority_connection
*copyc nlp$cl_get_connection_access
*copyc nlp$cl_get_exclusive_via_cid
*copyc nlp$cl_get_layer_connection
*copyc nlp$cl_get_nonexclusive_to_root
*copyc nlp$cl_release_exclusive_access
*copyc nlp$cl_release_nonexclu_to_root
*copyc nlp$connection_queued
*copyc nlp$get_exclusive_access
*copyc nlp$get_nonexclusive_access
*copyc nlp$release_exclusive_access
*copyc osp$add_to_locked_variable
*copyc nlp$release_nonexclusive_access
*copyc osp$decrement_locked_variable
*copyc osp$increment_locked_variable
*copyc osp$sub_from_locked_variable
*copyc nav$global_osi_statistics
*copyc nav$network_paged_heap
*copyc nav$network_procedures
*copyc nav$statistics_enabled
*copyc nlv$bm_null_message_id
*copyc nlv$cc_grant_credit_trigger
*copyc nlv$cl_connections
*copyc nlv$configured_network_devices
*copyc nlv$sm_devices
?? TITLE := '[XDCL] nlp$cc_abort_connection', EJECT ??
*copy nlh$cc_abort_connection

  PROCEDURE [XDCL] nlp$cc_abort_connection
    (    reason: nlt$cc_disconnect_reason;
         connection { input, output } : ^nlt$cc_connection;
         cl_connection { input, output } : ^nlt$cl_connection);

    VAR
      event: nlt$cc_event,
      ignore_accumulated_messages: integer,
      initial_state: nlt$cc_connection_state;

    initial_state := connection^.device_specific_attributes.state;
    connection^.device_specific_attributes.state := nlc$cc_closed;
    nlp$cc_shut_down_connection (connection, cl_connection, connection^.
      device_specific_attributes.device_id);
    IF initial_state <> nlc$cc_closing THEN
      event.kind := nlc$cc_disconnect_event;
      event.disconnect.reason := reason;
      event.disconnect.data := nlv$bm_null_message_id;
      nav$network_procedures [connection^.event_processor].
            cc_event_processor^ (cl_connection, event, ignore_accumulated_messages);
    IFEND;

  PROCEND nlp$cc_abort_connection;
?? TITLE := '[XDCL] nlp$cc_report_undelivered_data', EJECT ??
*copy nlh$cc_report_undelivered_data

  PROCEDURE [XDCL] nlp$cc_report_undelivered_data
    (    cl_connection: ^nlt$cl_connection;
         accumulated_message_buffers: integer);

    VAR
      connection: ^nlt$cc_connection,
      layer_active: boolean;

    nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, layer_active, connection);
    IF layer_active AND (connection^.device_specific_attributes.state = nlc$cc_open) THEN
      connection^.accumulated_message_buffers := accumulated_message_buffers;
      IF connection^.receive_credits <= nlv$cc_grant_credit_trigger THEN
        nlp$cc_grant_credits (connection);
      IFEND;
    IFEND;

  PROCEND nlp$cc_report_undelivered_data;
?? TITLE := '[XDCL] nlp$cc_reset_device', EJECT ??
*copy nlh$cc_reset_device

  PROCEDURE [XDCL] nlp$cc_reset_device
    (    device_id: nlt$device_identifier);

    VAR
      command: iot$command,
      network_device_list: ^nlt$network_device_list;

    nlp$get_exclusive_access (nlv$configured_network_devices.access_control);
    network_device_list := nlv$configured_network_devices.network_device_list;

    IF network_device_list^ [device_id].path_status = nlc$path_available THEN
      network_device_list^ [device_id].path_status := nlc$path_unavailable;
      command.flags.store_response := TRUE;
      command.flags.indirect_address := FALSE;
      command.length := 0;
      command.address := 0;
      command.command_code := ioc$cc_reset_device;
      nap$issue_pp_request (network_device_list^ [device_id].pp_number, command, NIL);
      nap$namve_system_error (TRUE, 'Device reset requested', NIL);
    IFEND;
    nlp$release_exclusive_access (nlv$configured_network_devices.access_control);
  PROCEND nlp$cc_reset_device;
?? TITLE := '[XDCL] nlp$cc_shut_down_connection', EJECT ??
*copy nlh$cc_shut_down_connection

  PROCEDURE [XDCL] nlp$cc_shut_down_connection
    (    connection: ^nlt$cc_connection;
         cl_connection: ^nlt$cl_connection;
         device_id: nlt$device_identifier);

    VAR
      message_id: nlt$bm_message_id,
      next_received_message: ^nlt$bm_message_descriptor,
      received_messages: ^nlt$bm_message_descriptor;

    IF (connection^.device_specific_attributes.state = nlc$cc_closed) THEN
      release_send_buffer (connection);
      IF ((cl_connection^.queue_on_connection) AND (NOT nlp$connection_queued(cl_connection))) THEN

{ Discard queued input.

        nlp$cc_get_received_messages (cl_connection, received_messages);
        IF received_messages <> NIL THEN
          WHILE received_messages <> NIL DO
            next_received_message := received_messages^.received_message.next_received_message;
            message_id.descriptor := received_messages;
            message_id.sequence_number := received_messages^.sequence_number;
            nlp$bm_release_message (message_id);
            received_messages := next_received_message;
          WHILEND;
        IFEND;
      IFEND;
      IF connection^.sub_connection_count = 0 THEN
        IF connection^.sub_connections <> NIL THEN
          FREE connection^.sub_connections IN nav$network_paged_heap^;
        IFEND;
        IF ((cl_connection^.queue_on_connection) AND (NOT nlp$connection_queued(cl_connection))) OR
              ((NOT cl_connection^.queue_on_connection) AND
              (connection^.next_deliverable_sequence# = cl_connection^.next_assignable_cc_sequence#)) THEN
          nlp$cl_deactivate_layer (nlc$channel_connection_layer, cl_connection);
        IFEND;
        IF connection^.class = nlc$cc_priority_class THEN
          nlp$cl_decr_priority_connection;
        IFEND;
      IFEND;
    IFEND;
    nlp$cc_decr_connection_count (device_id);

  PROCEND nlp$cc_shut_down_connection;
?? TITLE := '[XDCL] nlp$cc_terminate_connections', EJECT ??
*copy nlh$cc_terminate_connections

  PROCEDURE [XDCL] nlp$cc_terminate_connections
    (    device_id: nlt$device_identifier);

    VAR
      access_gained: boolean,
      actual: integer,
      cl_connection: ^nlt$cl_connection,
      connection: ^nlt$cc_connection,
      connection_exists: boolean,
      device_specific_attributes: ^nlt$cc_device_specific_attr,
      ignore_error: boolean,
      initial_state: nlt$cc_connection_state,
      layer_active: boolean,
      main_connection: boolean,
      next_connection: ^nlt$cl_connection,
      root: nlt$cl_reference_number,
      statistic1: ^integer,
      statistic2: ^integer,
      sm_connection_id: nat$connection_id;

{! statistics begin}

    IF nav$statistics_enabled THEN
      osp$increment_locked_variable (nav$global_osi_statistics.
            channel_connection_device^[device_id].device_resets, 0, actual);
    IFEND;

{! statistics end}

{ Terminate the system mgmt connection first.

    nlp$get_nonexclusive_access (nlv$sm_devices.access_control);
    IF nlv$sm_devices.list^[device_id].state <> nlc$sm_uninitialized THEN
      sm_connection_id := nlv$sm_devices.list^[device_id].connection_id;
    ELSE
      sm_connection_id := nac$null_connection_id;
    IFEND;
    nlp$release_nonexclusive_access (nlv$sm_devices.access_control);
    IF sm_connection_id <> nac$null_connection_id THEN
      nlp$cl_get_exclusive_via_cid (sm_connection_id, connection_exists, cl_connection);
      IF cl_connection <> NIL THEN
        nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, layer_active,
          connection);
        IF layer_active THEN
          IF connection^.device_specific_attributes.state <> nlc$cc_closed THEN
            nlp$cc_abort_connection (nlc$cc_dr_link_down, connection, cl_connection);

{! statistics begin}

            IF nav$statistics_enabled THEN
              IF connection^.device_specific_attributes.state = nlc$cc_open THEN
                IF connection^.class = nlc$cc_normal_class THEN
                  statistic1 := ^nav$global_osi_statistics.
                        channel_connection_device^[device_id].current_normal_connections;
                  statistic2 := ^nav$global_osi_statistics.channel_connection.normal_connections;
                ELSE { IF connection^.class = nlc$cc_priority_class THEN
                  statistic1 := ^nav$global_osi_statistics.
                        channel_connection_device^[device_id].current_priority_connections;
                  statistic2 := ^nav$global_osi_statistics.channel_connection.priority_connections;
                IFEND;
                osp$decrement_locked_variable (statistic1^, 1, actual, ignore_error);
                osp$decrement_locked_variable (statistic2^, 1, actual, ignore_error);
              IFEND;
            IFEND;

{! statistics end}

          IFEND;
        IFEND;
        nlp$cl_release_exclusive_access (cl_connection);
      IFEND;
    IFEND;

{ Terminate remaining connections.

    IF nlv$cl_connections.list <> NIL THEN

    /traverse_roots/
      FOR root := LOWERBOUND (nlv$cl_connections.list^) TO UPPERBOUND (nlv$cl_connections.list^) DO
        nlp$cl_get_nonexclusive_to_root (root);
        cl_connection := nlv$cl_connections.list^ [root].first;

      /traverse_stem/
        WHILE cl_connection <> NIL DO
          next_connection := cl_connection^.nextt;
          IF device_id IN cl_connection^.device_ids THEN
            REPEAT
              nlp$cl_get_connection_access (cl_connection, access_gained);
              IF NOT access_gained THEN
                syp$cycle;
              IFEND;
            UNTIL access_gained;
            nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, layer_active,
                  connection);
            IF layer_active THEN
              nlp$cc_get_device_specific_attr (device_id, connection, main_connection,
                    device_specific_attributes);
              IF main_connection THEN
                IF device_specific_attributes^.state <> nlc$cc_closed THEN
                  nlp$cc_abort_connection (nlc$cc_dr_link_down, connection, cl_connection);

{! statistics begin}

                  IF nav$statistics_enabled THEN
                    IF device_specific_attributes^.state = nlc$cc_open THEN
                      IF connection^.class = nlc$cc_normal_class THEN
                        statistic1 := ^nav$global_osi_statistics.
                              channel_connection_device^[device_id].current_normal_connections;
                        statistic2 := ^nav$global_osi_statistics.channel_connection.normal_connections;
                      ELSE { IF connection^.class = nlc$cc_priority_class THEN
                        statistic1 := ^nav$global_osi_statistics.
                              channel_connection_device^[device_id].current_priority_connections;
                        statistic2 := ^nav$global_osi_statistics.channel_connection.priority_connections;
                      IFEND;
                      osp$decrement_locked_variable (statistic1^, 1, actual, ignore_error);
                      osp$decrement_locked_variable (statistic2^, 1, actual, ignore_error);
                    IFEND;
                  IFEND;

{! statistics end}

                IFEND;
              ELSE { subconnection
                IF device_specific_attributes^.state <> nlc$cc_closed THEN
                  initial_state := device_specific_attributes^.state;
                  device_specific_attributes^.state := nlc$cc_closed;
                  connection^.sub_connection_count := connection^.sub_connection_count - 1;
                  IF connection^.sub_connection_count = 0 THEN

{  The state of a "subconnection" that is not CLOSED, is either: nlc$cc_connect_confirm_wait
{  or nlc$cc_closing.

                    IF initial_state = nlc$cc_connect_confirm_wait THEN

{ Setup the device_id field in the "main" connection for call to nlp$cc_abort_connection.
{ This is needed because nlp$cc_abort_connection expects all fields in the "main" connection
{ device specific attributes field to be valid; and at this point the "main" connection has
{ never been established and therefore not initialized.

                      connection^.device_specific_attributes.device_id :=
                            device_specific_attributes^.device_id;
                      nlp$cc_abort_connection (nlc$cc_dr_link_down, connection, cl_connection);
                    ELSE { nlc$cc_closing
                      nlp$cc_shut_down_connection (connection, cl_connection,
                        device_specific_attributes^.device_id);
                    IFEND;
                  ELSE { sub_connection_count > 0
                    nlp$cc_decr_connection_count (device_specific_attributes^.device_id);
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
            nlp$cl_release_exclusive_access (cl_connection);
          IFEND;
          cl_connection := next_connection;
        WHILEND /traverse_stem/;
        nlp$cl_release_nonexclu_to_root (root);
      FOREND /traverse_roots/;
    IFEND;

  PROCEND nlp$cc_terminate_connections;
?? TITLE := 'release_send_buffer', EJECT ??
{
{  PURPOSE:
{    The purpose of this request is to release all queued outbound
{  Channel Connection messages.
{

  PROCEDURE release_send_buffer
    (    connection { input, output } : ^nlt$cc_connection);

    VAR
      actual: integer,
      extension: ^nlt$cc_send_buffer_extension,
      ignore_error: boolean,
      message_count: integer,
      statistic1: ^integer,
      statistic2: ^integer;

    message_count := 0;
    WHILE (connection^.send_buffer.out <> connection^.send_buffer.inn) DO
      nlp$bm_release_message (connection^.send_buffer.cc_pdu [connection^.send_buffer.out].data);
      connection^.send_buffer.out := ((connection^.send_buffer.out + 1) MOD nlc$cc_send_buffer_limit);
      message_count := message_count + 1;
    WHILEND;
    WHILE connection^.send_buffer.extension <> NIL DO
      nlp$bm_release_message (connection^.send_buffer.extension^.cc_pdu.data);
      extension := connection^.send_buffer.extension;
      connection^.send_buffer.extension := extension^.nextt;
      FREE extension IN nav$network_paged_heap^;
      message_count := message_count + 1;
    WHILEND;

{! statistics begin}

    IF nav$statistics_enabled AND (message_count <> 0) THEN
      IF connection^.class = nlc$cc_normal_class THEN
        statistic1 := ^nav$global_osi_statistics.
              channel_connection_device^[connection^.device_specific_attributes.device_id].
              send_pdus_discarded;
        statistic2 := ^nav$global_osi_statistics.
              channel_connection_device^[connection^.device_specific_attributes.device_id].
              normal_send_pdus_queued;
      ELSE { IF connection^.class = nlc$cc_priority_class THEN
        statistic1 := ^nav$global_osi_statistics.
              channel_connection_device^[connection^.device_specific_attributes.device_id].
              priority_send_pdus_discarded;
        statistic2 := ^nav$global_osi_statistics.
              channel_connection_device^[connection^.device_specific_attributes.device_id].
              priority_send_pdus_queued;
      IFEND;
      osp$add_to_locked_variable (statistic1^, 0, message_count, actual);
      osp$sub_from_locked_variable (statistic2^, message_count, message_count, actual, ignore_error);
    IFEND;

{! statistics end}

  PROCEND release_send_buffer;

?? OLDTITLE ??
MODEND nlm$channel_connection_manager;
*DECK DECK=NLM$CHANNEL_CONNECTION_RING1 EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access: Channel Connection Procedures Ring 1' ??
?? NEWTITLE := 'Global Declarations Referenced by This Module' ??
MODULE nlm$channel_connection_ring1;
{ PURPOSE:
{   This module contains miscellaneous procedures needed by the Channel Connection Entity.
{   These procedures execute in ring 1 and are callable from ring 3.
?? PUSH (LISTEXT := ON) ??
*copyc nac$null_connection_id
*copyc nat$received_message_list
*copyc nlt$bm_message_descriptor
*copyc nlt$cl_connection
*copyc nlt$connection_queue
*copyc nlt$receiving_connections
*copyc osd$virtual_address
*copyc ost$signature_lock_status
*copyc ost$status
?? POP ??
*copyc pmp$ready_task
?? TITLE := 'Global Variables Referenced by This Module', EJECT ??
*copyc nav$si_received_message_list
*copyc nav$network_wired_heap
*copyc nav$system_input_taskid
*copyc nlv$receiving_connections
?? TITLE := '[XDCL, #GATE] nlp$cc_get_received_messages', EJECT ??
*copy nlh$cc_get_received_messages

  PROCEDURE [XDCL, #GATE] nlp$cc_get_received_messages
    (cl_connection: {input, output} ^nlt$cl_connection;
     VAR received_messages: ^nlt$bm_message_descriptor);

    VAR
      actual_input_queue: nat$received_message_list,
      cl_connection_r1: ^nlt$cl_connection,
      initial_input_queue: nat$received_message_list,
      new_input_queue: nat$received_message_list,
      result: osc$cs_successful .. osc$cs_variable_locked;

    received_messages := NIL;
    new_input_queue.next_received_message := NIL;
    new_input_queue.fill := 0;
    initial_input_queue := new_input_queue;
    cl_connection_r1 := #ADDRESS (1, #SEGMENT(cl_connection), #OFFSET(cl_connection));

    REPEAT
      #COMPARE_SWAP (cl_connection_r1^.input_queue, initial_input_queue, new_input_queue,
         actual_input_queue, result);
      IF result = osc$cs_failed THEN
        initial_input_queue.next_received_message := actual_input_queue.next_received_message;
        received_messages := actual_input_queue.next_received_message;
      IFEND;
    UNTIL result = osc$cs_successful;

  PROCEND nlp$cc_get_received_messages;
?? TITLE := '[XDCL, #GATE] nlp$cc_requeue_msgs_on_conn', EJECT ??
*copy nlh$cc_requeue_msgs_on_conn

  PROCEDURE [XDCL, #GATE] nlp$cc_requeue_msgs_on_conn
    (    cl_connection: ^nlt$cl_connection;
         received_messages: ^nlt$bm_message_descriptor);

    VAR
      actual_input_queue: nat$received_message_list,
      cl_connection_r1: ^nlt$cl_connection,
      initial_input_queue: nat$received_message_list,
      new_input_queue: nat$received_message_list,
      queued_message: ^nlt$bm_message_descriptor,
      result: osc$cs_successful .. osc$cs_variable_locked;

    initial_input_queue.next_received_message := NIL;
    initial_input_queue.fill := 0;
    new_input_queue.next_received_message := received_messages;
    new_input_queue.fill := 0;
    cl_connection_r1 := #ADDRESS (1, #SEGMENT(cl_connection), #OFFSET(cl_connection));

    /queue_message/
    REPEAT
      #COMPARE_SWAP (cl_connection_r1^.input_queue, initial_input_queue, new_input_queue,
         actual_input_queue, result);
      IF result = osc$cs_failed THEN
        initial_input_queue := actual_input_queue;
        IF actual_input_queue.next_received_message <> NIL THEN

{ The input queue is not empty.

          queued_message := actual_input_queue.next_received_message;

{ Find the last message in the queue.

          WHILE queued_message^.received_message.next_received_message <> NIL DO
            queued_message := queued_message^.received_message.next_received_message;
          WHILEND;

{ Link the received messages at the end of the queue.

          queued_message^.received_message.next_received_message := received_messages;
          EXIT /queue_message/;
        IFEND;
      IFEND;
    UNTIL result = osc$cs_successful;

  PROCEND nlp$cc_requeue_msgs_on_conn;
?? TITLE := '[XDCL, #GATE] nlp$connection_queued', EJECT ??
*copy nlh$connection_queued

  FUNCTION [XDCL, #GATE] nlp$connection_queued
    (    receiving_connection: ^nlt$cl_connection): boolean;

    VAR
      actual_connection_queue: nlt$connection_queue,
      cl_connection_r1: ^nlt$cl_connection,
      initial_connection_queue: nlt$connection_queue,
      new_connection_queue: nlt$connection_queue,
      cs_status: osc$cs_successful .. osc$cs_variable_locked;

    cl_connection_r1 := #ADDRESS (1, #SEGMENT(receiving_connection),
      #OFFSET(receiving_connection));
    initial_connection_queue.in_queue := FALSE;
    initial_connection_queue.fill := 0;
    initial_connection_queue.next_connection := NIL;
    new_connection_queue := initial_connection_queue;
    REPEAT
      #COMPARE_SWAP (cl_connection_r1^.connection_queue, initial_connection_queue,
        new_connection_queue, actual_connection_queue, cs_status);
    UNTIL cs_status <> osc$cs_variable_locked;

    nlp$connection_queued := actual_connection_queue.in_queue;

  FUNCEND nlp$connection_queued;
?? TITLE := '[XDCL, #GATE] nlp$delink_receiving_connection', EJECT ??
*copy nlh$delink_receiving_connection

  PROCEDURE [XDCL, #GATE] nlp$delink_receiving_connection
    (    receiving_connection: ^nlt$cl_connection;
     VAR next_receiving_connection: nlt$cl_connection_id);

    VAR
      actual_connection_queue: nlt$connection_queue,
      cl_connection_r1: ^nlt$cl_connection,
      initial_connection_queue: nlt$connection_queue,
      new_connection_queue: nlt$connection_queue,
      cs_status: osc$cs_successful .. osc$cs_variable_locked;

    cl_connection_r1 := #ADDRESS (1, #SEGMENT(receiving_connection),
      #OFFSET(receiving_connection));
    initial_connection_queue.in_queue := TRUE;
    initial_connection_queue.fill := 0;
    initial_connection_queue.next_connection := NIL;
    new_connection_queue := initial_connection_queue;
    REPEAT
      #COMPARE_SWAP (cl_connection_r1^.connection_queue, initial_connection_queue,
        new_connection_queue, actual_connection_queue, cs_status);
      IF cs_status = osc$cs_failed THEN
        initial_connection_queue.next_connection := actual_connection_queue.next_connection;
      IFEND;
    UNTIL cs_status = osc$cs_successful;
    IF actual_connection_queue.next_connection <> NIL THEN
      next_receiving_connection := actual_connection_queue.next_connection^.identifier;
    ELSE
      next_receiving_connection := nac$null_connection_id;
    IFEND;

  PROCEND nlp$delink_receiving_connection;
?? TITLE := '[XDCL, #GATE] nlp$dequeue_receiving_conection', EJECT ??
*copy nlh$dequeue_receiving_conection

  PROCEDURE [XDCL, #GATE] nlp$dequeue_receiving_conection
    (    receiving_connection: ^nlt$cl_connection;
     VAR next_receiving_connection: nlt$cl_connection_id);

    VAR
      actual_connection_queue: nlt$connection_queue,
      cl_connection_r1: ^nlt$cl_connection,
      initial_connection_queue: nlt$connection_queue,
      new_connection_queue: nlt$connection_queue,
      cs_status: osc$cs_successful .. osc$cs_variable_locked;

    cl_connection_r1 := #ADDRESS (1, #SEGMENT(receiving_connection),
      #OFFSET(receiving_connection));
    initial_connection_queue.in_queue := TRUE;
    initial_connection_queue.fill := 0;
    initial_connection_queue.next_connection := NIL;
    new_connection_queue.in_queue := FALSE;
    new_connection_queue.fill := 0;
    new_connection_queue.next_connection := NIL;
    REPEAT
      #COMPARE_SWAP (cl_connection_r1^.connection_queue, initial_connection_queue,
        new_connection_queue, actual_connection_queue, cs_status);
      IF cs_status = osc$cs_failed THEN
        initial_connection_queue.next_connection := actual_connection_queue.next_connection;
      IFEND;
    UNTIL cs_status = osc$cs_successful;
    IF actual_connection_queue.next_connection <> NIL THEN
      next_receiving_connection := actual_connection_queue.next_connection^.identifier;
    ELSE
      next_receiving_connection := nac$null_connection_id;
    IFEND;

  PROCEND nlp$dequeue_receiving_conection;
?? TITLE := '[XDCL, #GATE] nlp$get_receiving_connections', EJECT ??
*copy nlh$get_receiving_connections

  PROCEDURE [XDCL, #GATE] nlp$get_receiving_connections
    (VAR receiving_connections: ^nlt$cl_connection);

    VAR
      actual: nlt$receiving_connections,
      initial: nlt$receiving_connections,
      new: nlt$receiving_connections,
      result: osc$cs_successful .. osc$cs_variable_locked;

    new.fill := 0;
    new.next_connection := NIL;
    initial := new;
    REPEAT
      #COMPARE_SWAP (nlv$receiving_connections, initial, new, actual, result);
      IF result = osc$cs_failed THEN
        initial.next_connection := actual.next_connection;
      IFEND;
    UNTIL result = osc$cs_successful;

    receiving_connections := actual.next_connection;

  PROCEND nlp$get_receiving_connections;
?? TITLE := '[XDCL, #GATE] nlp$requeue_msgs_for_input_task', EJECT ??
*copy nlh$requeue_msgs_for_input_task

  PROCEDURE [XDCL, #GATE] nlp$requeue_msgs_for_input_task
    (    received_messages: ^nlt$bm_message_descriptor);

    VAR
      actual: nat$received_message_list,
      initial: nat$received_message_list,
      last_received_message: ^nlt$bm_message_descriptor,
      new: nat$received_message_list,
      result: osc$cs_successful .. osc$cs_variable_locked,
      status: ost$status;

{ Find the last message in the list.

    last_received_message := received_messages;
    WHILE last_received_message^.received_message.next_received_message <> NIL DO
      last_received_message := last_received_message^.received_message.next_received_message;
    WHILEND;

    new.next_received_message := received_messages;
    new.fill := 0;
    initial.fill := 0;
    initial.next_received_message := NIL;

    REPEAT
      #compare_swap (nav$si_received_message_list, initial, new, actual, result);
      IF result = osc$cs_failed THEN
        initial := actual;
        last_received_message^.received_message.next_received_message := initial.next_received_message;
      IFEND;
    UNTIL result = osc$cs_successful;
    IF initial.next_received_message = NIL THEN
      pmp$ready_task (nav$system_input_taskid, {ignore} status);
    IFEND;
  PROCEND nlp$requeue_msgs_for_input_task;
MODEND nlm$channel_connection_ring1;
*DECK DECK=NLM$CL_CONNECTION_LAYER_TEMPLAT EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'NAM/VE: Connection Layer Template' ??
?? NEWTITLE := '  Global Declarations' ??
MODULE nlm$cl_connection_layer_templat;
*copyc oss$network_paged
*copyc nlt$cl_connection_layer_templat
?? TITLE := '  Connection Template Declarations', EJECT ??

  CONST
    application_layers = 8, { Represents the number of layers in nlt$cl_application_layer. }
    all_layers = 12; { Represents the number of layers in nlt$cl_layer_name. }

{
{  PURPOSE:
{     The purpose of this structure is to describe the attributes of a layer on
{     a connection layer path defined by application layer.  The values of a
{     layer's entry are used to control the processing of network input and
{     output.
{
{  DESIGN:
{     The structure is maintained in the network paged segment.
{
{     A layer's entry is initilized each time a Service Access Point is opened
{     but only the values of the first initialization are retained for the
{     duration NAM/VE execution.  Values contained in the structure are used to:
{       1.  construct a connection layer connection description;
{       2.  locate a specific layer's connection state information;
{       3.  determine a connection's outbound capacity;
{       4.  deliver SAP events (network input) to an upper layer protocol;
{       5.  deliver conection events (network input) to an upper layer protocol;
{       6.  periodically call a layer's procedure to evaluate SAP timers; and
{       7.  periodically call a layer's procedure to evaluate connection timers.
{
{    The values associated with processes 1 - 3 are directly addressed by the
{    processes.  However, procedures within the processes shield layers from
{    the actual structure of the template.
{
{    The values associated with processes 4 - 7 are retrieved via functions which
{    shield layers from the knowledged of the actual structure of the template.
{

  VAR
    nlv$cl_connection_layer_templat: [XDCL, #GATE, oss$network_paged] array [nlt$cl_application_layer] of
          nlt$cl_connection_layer_templat := [REP application_layers OF [nlc$cl_path_unlocked, 0,
     [REP all_layers OF FALSE], * ,  * ]];
MODEND nlm$cl_connection_layer_templat;
*DECK DECK=NLM$CL_CONNECTION_MANAGER_R1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NAM/VE: Connection Manager' ??
?? NEWTITLE := 'Global Declarations Referenced by this Module' ??
MODULE nlm$cl_connection_manager_r1;

{
{   PURPOSE:
{     The prime purpose of this module is to isolate the knowledge of the structures required
{     to access a specific connection.  Secondarily, the module contains service procedures to
{     support the connection establishment and disestablishment phases.
{
{     NOTE: the module which constitutes the timer task, the
{           and the channel connection manager are knowledgeable of the access structure.
{           Therefore, modifications to the access structure must be reflected there also.
{
{           Procedures, other than 'release exclusive access', are to be called only by the
{           connection manager which resides in OSF$JOB_TEMPLATE_23D, the timer task, and the
{           Channel connection manager.
{
{   DESIGN:
{     This module is designed to reside in the OSF$SYSTEM_CORE_113 library.
{
{     The access scheme is basically two leveled -- nonexclusive access to a connection root is
{     acquired before exclusive access is attempted to a specific connection.  The two level
{     access along with the specific algorithms is unknown to the users of the get/release access
{     procedures contained in this module.
{
{     The module contains procedures used by the network input task, timer monitor task, and user
{     tasks to acquire exclusive access to a specific connection.  A single procedure exists to
{     release exclusive access in any case.
{
{     The service procedure for connection establishment, assign connection, enhances the isolation
{     of the two level access structure and at the same time restrict the knowledge of the
{     mechanics of the internal connection structure.
{
{     The service procedure for connection disestablishment, release connection, basically restrict
{     the knowledge of the mechanics of the internal connection structure and are not involved in
{     the access structure.
{
?? PUSH (LISTEXT := ON) ??
*copyc nlc$nam_configuration_constants
*copyc nlt$cc_connection
*copyc nlt$cl_connections
*copyc oss$mainframe_paged_literal
*copyc oss$mainframe_pageable
*copyc oss$network_paged
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc dsp$get_nve_image_description
*copyc nlp$cl_get_layer_connection
*copyc osp$system_error
*copyc osp$begin_subsystem_activity
*copyc osp$clear_locked_variable
*copyc osp$end_subsystem_activity
*copyc osp$increment_locked_variable
*copyc pmp$get_executing_task_gtid
*copyc pmp$ready_task
*copyc syp$cycle
*copyc jmv$system_core_id
*copyc nav$network_paged_heap
*copyc nlv$cl_connections
*copyc nlv$cl_active_connections
*copyc nlv$maximum_system_connections
*copy nlv$timer_monitor_task
*copyc osv$mainframe_wired_heap
*copyc osv$page_size
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    successful = 0,
    failed = 1,
    locked = 2;

  VAR
    cl_terminated_connections: [oss$mainframe_pageable] integer := 0,

    unlocked_connection_access: [READ, oss$mainframe_paged_literal] nlt$cl_connection_access := [FALSE,
          0, [0, 0]],

    exclusive_root_access: [READ, oss$mainframe_paged_literal] nlt$cl_connection_root_access := [ 0, TRUE, 0],

    unlocked_root_access: [READ, oss$mainframe_paged_literal] nlt$cl_connection_root_access := [ 0, FALSE, 0],

    null_cl_connection: [READ, oss$mainframe_paged_literal] nlt$cl_connection := [NIL, [FALSE, 0, [0, 0]],
       FALSE, *, [FALSE, *], [FALSE, *], *, $nlt$cl_layers [], NIL, $nlt$device_ids [], FALSE, 1];

?? OLDTITLE ??
?? TITLE := '[XDCL, #GATE] nlp$cc_find_duplicate_connect', EJECT ??
*copy nlh$cc_find_duplicate_connect

{ NOTE: This routine resides in this module so it can access the connection structures directly and can gain
{       access to the roots without many ring crossing calls to the access routines.

  PROCEDURE [XDCL, #GATE] nlp$cc_find_duplicate_connect
    (    device_id: nlt$device_identifier;
         peer_reference_number: nlt$cl_reference_number;
     VAR duplicate: boolean);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nlt$cc_connection,
      layer_active: boolean,
      root: nlt$cl_reference_number;

    duplicate := FALSE;
    IF (nlv$cl_connections.list <> NIL) THEN

    /search_roots/
      FOR root := LOWERBOUND (nlv$cl_connections.list^) TO UPPERBOUND (nlv$cl_connections.list^) DO
        IF nlv$cl_connections.list^ [root].first <> NIL THEN
          get_nonexclusive_to_root (root);
          cl_connection := nlv$cl_connections.list^ [root].first;

        /search_stem/
          WHILE (cl_connection <> NIL) DO
            nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, layer_active,
                  connection);
            IF layer_active THEN
              IF (peer_reference_number = connection^.peer_reference_number) AND
                    (device_id = connection^.device_specific_attributes.device_id) AND
                    (connection^.device_specific_attributes.state <> nlc$cc_closed) THEN
                release_nonexclusive_to_root (root);
                duplicate := TRUE;
                EXIT /search_roots/;
              IFEND;
            IFEND;
            cl_connection := cl_connection^.nextt;
          WHILEND /search_stem/;
          release_nonexclusive_to_root (root);
        IFEND;
      FOREND /search_roots/;
    IFEND;
  PROCEND nlp$cc_find_duplicate_connect;
?? TITLE := '[XDCL, #GATE] nlp$cc_get_exclus_to_unaccepted {connection}', EJECT ??
*copy nlh$cc_get_exclus_to_unaccepted

{ NOTE: This routine resides in this module so it can access the connection structures directly and can gain
{       access to the roots without many ring crossing calls to the access routines.

  PROCEDURE [XDCL, #GATE] nlp$cc_get_exclus_to_unaccepted
    (    peer_reference_number: nlt$cl_reference_number;
         device_id: nlt$device_identifier;
         system_input_task: boolean;
     VAR connection_exists: boolean;
     VAR access_gained: boolean;
     VAR connection: ^nlt$cc_connection;
     VAR cl_connection: ^nlt$cl_connection);

    VAR
      layer_active: boolean,
      root: nlt$cl_reference_number;

    access_gained := FALSE;
    connection_exists := FALSE;
    IF (nlv$cl_connections.list <> NIL) THEN

    /search_roots/
      FOR root := LOWERBOUND (nlv$cl_connections.list^) TO UPPERBOUND (nlv$cl_connections.list^) DO
        IF nlv$cl_connections.list^ [root].first <> NIL THEN
          get_nonexclusive_to_root (root);
          cl_connection := nlv$cl_connections.list^ [root].first;

        /search_stem/
          WHILE (cl_connection <> NIL) DO
            nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, layer_active,
                  connection);
            IF layer_active THEN
              IF (peer_reference_number = connection^.peer_reference_number) AND
                    (device_id = connection^.device_specific_attributes.device_id) AND
                    (connection^.device_specific_attributes.state <> nlc$cc_closed) THEN
                nlp$cl_get_exclusive_access (cl_connection^.identifier, system_input_task,
                      connection_exists, access_gained, cl_connection);
                release_nonexclusive_to_root (root);
                EXIT /search_roots/;
              IFEND;
            IFEND;
            cl_connection := cl_connection^.nextt;
          WHILEND /search_stem/;
          release_nonexclusive_to_root (root);
        IFEND;
      FOREND /search_roots/;
    IFEND;

  PROCEND nlp$cc_get_exclus_to_unaccepted;

?? TITLE := '  [XDCL, #GATE] nlp$cl_get_exclusive_access', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$cl_get_exclusive_access (connection_id: nlt$cl_connection_id;
        system_input_task: boolean;
    VAR connection_exists: boolean;
    VAR access_gained: boolean;
    VAR cl_connection: ^nlt$cl_connection);

*copy nlh$cl_get_exclusive_access

    VAR
      actual_value: nlt$cl_connection_access,
      connection: ^nlt$cl_connection,
      cs_status: successful .. locked,
      global_task_id: ost$global_task_id,
      initial_value: nlt$cl_connection_access,
      new_value: nlt$cl_connection_access,
      root: nlt$cl_reference_number;

    connection_exists := FALSE;
    access_gained := FALSE;
    IF (nlv$cl_connections.list <> NIL) THEN
      root := (connection_id.reference_number MOD (UPPERBOUND (nlv$cl_connections.list^) + 1));
      get_nonexclusive_to_root (root);
      connection := nlv$cl_connections.list^ [root].first;

    /search_stem/
      WHILE (connection <> NIL) DO
        IF ((connection^.identifier = connection_id) AND (connection^.layer_connections <> NIL)) THEN
            connection_exists := TRUE;
            pmp$get_executing_task_gtid (global_task_id);
            osp$begin_subsystem_activity;
            REPEAT
              new_value.notify_system_task := FALSE;
              new_value.fill := 0;
              new_value.task_id := global_task_id;
              REPEAT
                #compare_swap (connection^.access_control, unlocked_connection_access, new_value,
                      actual_value, cs_status);
              UNTIL cs_status <> locked;
              IF cs_status = successful THEN
                access_gained := TRUE;
              ELSEIF actual_value.task_id <> new_value.task_id THEN  { cs_status = failed }
                IF system_input_task THEN

{ The connection is currently locked by some other task. Update the notify_system_task
{ field in the access_control word so that the system input task work list process will
{ be invoked when access to the connection is released.

                  initial_value := actual_value;
                  new_value := actual_value;
                  new_value.notify_system_task := TRUE;
                  REPEAT
                    #compare_swap (connection^.access_control, initial_value, new_value,
                          actual_value, cs_status);
                  UNTIL cs_status <> locked;
                IFEND;
              ELSE
                osp$system_error ('NAM/VE - lock already set by current task', NIL);
              IFEND;
            UNTIL (cs_status = successful) OR NOT system_input_task;
            cl_connection := connection;
            IF NOT access_gained THEN
              osp$end_subsystem_activity;
            IFEND;
          EXIT /search_stem/;
        ELSE
          connection := connection^.nextt;
        IFEND;
      WHILEND /search_stem/;
      release_nonexclusive_to_root (root);
    ELSE
      cl_connection := NIL;
    IFEND;
  PROCEND nlp$cl_get_exclusive_access;
?? OLDTITLE ??
?? TITLE := '  [XDCL, #GATE] nlp$cl_get_exclusive_via_cid', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$cl_get_exclusive_via_cid (connection_id: nlt$cl_connection_id;
    VAR connection_exists: boolean;
    VAR cl_connection: ^nlt$cl_connection);

*copy nlh$cl_get_exclusive_via_cid

    VAR
      actual_value: nlt$cl_connection_access,
      connection: ^nlt$cl_connection,
      cs_status: successful .. locked,
      new_value: nlt$cl_connection_access,
      root: nlt$cl_reference_number;

    connection_exists := FALSE;
    cl_connection := NIL;

    IF (nlv$cl_connections.list <> NIL) THEN
      root := (connection_id.reference_number MOD (UPPERBOUND (nlv$cl_connections.list^) + 1));
      get_nonexclusive_to_root (root);
      connection := nlv$cl_connections.list^ [root].first;

    /search_stem/
      WHILE (connection <> NIL) DO
        IF ((connection^.identifier = connection_id) AND
            (connection^.layer_connections <> NIL)) THEN
          connection_exists := TRUE;
          pmp$get_executing_task_gtid (new_value.task_id);
          new_value.notify_system_task := FALSE;
          new_value.fill := 0;
          osp$begin_subsystem_activity;
          REPEAT
            #compare_swap (connection^.access_control, unlocked_connection_access, new_value,
                  actual_value, cs_status);
            IF cs_status = failed THEN
              IF actual_value.task_id <> new_value.task_id THEN
                osp$end_subsystem_activity;
                syp$cycle;
                osp$begin_subsystem_activity;
              ELSE
                osp$system_error ('NAM/VE - lock already set by current task', NIL);
              IFEND;
            IFEND;
          UNTIL cs_status = successful;
          cl_connection := connection;
          EXIT /search_stem/;
        ELSE
          connection := connection^.nextt;
        IFEND;
      WHILEND /search_stem/;
      release_nonexclusive_to_root (root);
    IFEND;
  PROCEND nlp$cl_get_exclusive_via_cid;
?? TITLE := '  [XDCL, #GATE] nlp$cl_release_exclusive_access', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$cl_release_exclusive_access (VAR cl_connection {INPUT, OUTPUT} :
    ^nlt$cl_connection);

*copy nlh$cl_release_exclusive_access

    VAR
      actual_value: nlt$cl_connection_access,
      connection: ^nlt$cl_connection,
      cs_status: successful .. locked,
      initial_value: nlt$cl_connection_access;


    connection := #address (1, #segment (cl_connection), #offset (cl_connection));
    pmp$get_executing_task_gtid (initial_value.task_id);
    initial_value.fill := 0;
    initial_value.notify_system_task := FALSE;
    REPEAT
      #compare_swap (connection^.access_control, initial_value, unlocked_connection_access,
            actual_value, cs_status);
      IF cs_status = failed THEN
        IF actual_value.task_id = initial_value.task_id THEN
          initial_value := actual_value;
        ELSE
          osp$system_error ('NAM/VE - lock not locked by current task', NIL);
        IFEND;
      IFEND;
    UNTIL cs_status = successful;

    osp$end_subsystem_activity;
    IF actual_value.notify_system_task THEN
      notify_system_task;
    IFEND;
    cl_connection := NIL;
  PROCEND nlp$cl_release_exclusive_access;
?? TITLE := '  [XDCL, #GATE] nlp$cl_clear_exclusive_access', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$cl_clear_exclusive_access (VAR cl_connection {INPUT, OUTPUT} :
    ^nlt$cl_connection);

*copy nlh$cl_clear_exclusive_access

    VAR
      actual_value: nlt$cl_connection_access,
      connection: ^nlt$cl_connection,
      cs_status: successful .. locked,
      initial_value: nlt$cl_connection_access;

    IF (cl_connection <> NIL) THEN
      connection := #address (1, #segment (cl_connection), #offset (cl_connection));
      pmp$get_executing_task_gtid (initial_value.task_id);
      initial_value.fill := 0;
      initial_value.notify_system_task := FALSE;
      REPEAT
        #compare_swap (connection^.access_control, initial_value, unlocked_connection_access,
              actual_value, cs_status);
        IF cs_status = failed THEN
          IF actual_value.task_id = initial_value.task_id THEN
            initial_value := actual_value;
          ELSE { Connection not locked by current task }
            cl_connection := NIL;
            RETURN;
          IFEND;
        IFEND;
      UNTIL cs_status = successful;

      osp$end_subsystem_activity;
      IF actual_value.notify_system_task THEN
        notify_system_task;
      IFEND;
      cl_connection := NIL;
    IFEND;
  PROCEND nlp$cl_clear_exclusive_access;
?? TITLE := '  [INLINE] notify_system_task', EJECT ??

  PROCEDURE [INLINE] notify_system_task;

*copyc pmp$set_system_flag
*copyc nav$system_input_taskid

    VAR
      status: ost$status;

    REPEAT
      syp$cycle;  {Pause, in case event is not yet on work list}
      pmp$set_system_flag (nlc$cc_work_list_flag, nav$system_input_taskid, status);
      IF NOT status.normal THEN
        IF (status.condition <> pme$unknown_recipient_task) THEN
          osp$system_error ('CANNOT SET SYSTEM FLAG', ^status);
        IFEND;
      IFEND;
    UNTIL status.normal;
  PROCEND notify_system_task;
?? TITLE := '[XDCL, #GATE] nlp$cl_add_device_to_connection', EJECT ??
*copy nlh$cl_add_device_to_connection
  PROCEDURE [XDCL, #GATE] nlp$cl_add_device_to_connection
    (    device_id: nlt$device_identifier;
         cl_connection {INPUT, OUTPUT} : ^nlt$cl_connection);

    VAR
      connection: ^nlt$cl_connection;

    connection := #address (1, #segment (cl_connection), #offset (cl_connection));
    connection^.device_ids := connection^.device_ids + $nlt$device_ids [device_id];

  PROCEND nlp$cl_add_device_to_connection;
?? TITLE := '  [XDCL, #GATE] nlp$cl_activate_layer', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$cl_activate_layer (layer: nlt$cl_layer_name;
        cl_connection: ^nlt$cl_connection);
*copy nlh$cl_activate_layer

    VAR
      connection: ^nlt$cl_connection;

    connection := #address (1, #segment (cl_connection), #offset (cl_connection));
    connection^.layers_active := connection^.layers_active + $nlt$cl_layers [layer];
  PROCEND nlp$cl_activate_layer;
?? TITLE := '  [XDCL, #GATE] nlp$cl_deactivate_layer', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$cl_deactivate_layer (layer: nlt$cl_layer_name;
        cl_connection: ^nlt$cl_connection);
*copy nlh$cl_deactivate_layer

    VAR
      available_connections: integer,
      connection: ^nlt$cl_connection,
      ignore_status: ost$status,
      terminated_connections: integer;

    connection := #address (1, #segment (cl_connection), #offset (cl_connection));
    connection^.layers_active := connection^.layers_active - $nlt$cl_layers [layer];
    IF connection^.layers_active = $nlt$cl_layers [] THEN
      available_connections := nlv$maximum_system_connections - nlv$cl_active_connections;
      IF available_connections <= (nlv$maximum_system_connections DIV 4) THEN
        IF available_connections <= (nlv$maximum_system_connections DIV 16) THEN
          pmp$ready_task (nlv$timer_monitor_task, ignore_status);
        ELSE
          osp$increment_locked_variable (cl_terminated_connections, 0, terminated_connections);
          IF terminated_connections >= (nlv$maximum_system_connections DIV 8) THEN
            pmp$ready_task (nlv$timer_monitor_task, ignore_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND nlp$cl_deactivate_layer;
?? TITLE := '  [XDCL, #GATE] nlp$cl_zero_terminated_connects', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$cl_zero_terminated_connects;
*copy nlh$cl_zero_terminated_connects

    osp$clear_locked_variable (cl_terminated_connections, 0);
  PROCEND nlp$cl_zero_terminated_connects;
?? TITLE := '  [XDCL, #GATE] nlp$cl_activate_sender', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$cl_activate_sender (cl_connection: ^nlt$cl_connection);
*copy nlh$cl_activate_sender

    VAR
      executing_task_id: ost$global_task_id,
      connection: ^nlt$cl_connection;

    pmp$get_executing_task_gtid (executing_task_id);
    connection := #address (1, #segment (cl_connection), #offset (cl_connection));
    connection^.message_sender.task := executing_task_id;
    connection^.message_sender.active := TRUE;
  PROCEND nlp$cl_activate_sender;
?? TITLE := '  [XDCL, #GATE] nlp$cl_deactivate_sender', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$cl_deactivate_sender (cl_connection: ^nlt$cl_connection);
*copy nlh$cl_deactivate_sender

    VAR
      connection: ^nlt$cl_connection;

    connection := #address (1, #segment (cl_connection), #offset (cl_connection));
    connection^.message_sender.active := FALSE;
  PROCEND nlp$cl_deactivate_sender;
?? TITLE := '  [XDCL, #GATE] nlp$cl_activate_receiver', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$cl_activate_receiver (cl_connection: ^nlt$cl_connection);
*copy nlh$cl_activate_receiver

    VAR
      executing_task_id: ost$global_task_id,
      connection: ^nlt$cl_connection;

    pmp$get_executing_task_gtid (executing_task_id);
    connection := #address (1, #segment (cl_connection), #offset (cl_connection));
    connection^.message_receiver.task := executing_task_id;
    connection^.message_receiver.active := TRUE;
  PROCEND nlp$cl_activate_receiver;
?? TITLE := '  [XDCL, #GATE] nlp$cl_deactivate_receiver', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$cl_deactivate_receiver (cl_connection: ^nlt$cl_connection);
*copy nlh$cl_deactivate_receiver

    VAR
      connection: ^nlt$cl_connection;

    connection := #address (1, #segment (cl_connection), #offset (cl_connection));
    connection^.message_receiver.active := FALSE;
  PROCEND nlp$cl_deactivate_receiver;
?? TITLE := '  [XDCL, #GATE] nlp$cl_assign_connection', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$cl_assign_connection (application_layer: nlt$cl_application_layer;
        layer_connections: ^nlt$cl_layer_connections;
    VAR cl_connection: ^nlt$cl_connection);
*copy nlh$cl_assign_connection
?? NEWTITLE := '    initialize_connection_list', EJECT ??

    PROCEDURE initialize_connection_list;

      VAR
        actual_lock: string (8),
        connections: ^array [0 .. * ] of nlt$cl_connection_root,
        locked_connection: [READ, oss$mainframe_paged_literal] string (8) := nlc$cl_connections_locked,
        number_of_entries: integer,
        null_connection_root: [READ, oss$mainframe_paged_literal] nlt$cl_connection_root := [[0, FALSE, 0],
          NIL],
        result: successful .. locked,
        root: nlt$cl_reference_number,
        unlocked_connection: [READ, oss$mainframe_paged_literal] string (8) := nlc$cl_connections_unlocked;

      osp$begin_subsystem_activity;
      REPEAT
        #compare_swap (nlv$cl_connections_control.lock, unlocked_connection, locked_connection, actual_lock,
              result);
        IF (result = failed) THEN
          osp$end_subsystem_activity;
          syp$cycle;
          osp$begin_subsystem_activity;
        IFEND;
      UNTIL (result = successful);

      IF (nlv$cl_connections.list = NIL) THEN
        number_of_entries := nlc$base_connection_array_size;
        WHILE (number_of_entries * 4) < nlv$maximum_system_connections DO
          number_of_entries := number_of_entries * 2;
        WHILEND;
        ALLOCATE connections: [0 .. (number_of_entries - 1)] IN osv$mainframe_wired_heap^;
        IF (nlv$cl_connections.cid_seed = 0) THEN
          nlv$cl_connections.cid_seed := (#free_running_clock (0) MOD (UPPERVALUE (nlt$cl_reference_number) +
                1));
        IFEND;
        FOR root := 0 TO (number_of_entries - 1) DO
          connections^ [root] := null_connection_root;
        FOREND;
        nlv$cl_connections.list := connections;
      IFEND;

      REPEAT
        #compare_swap (nlv$cl_connections_control.lock, locked_connection, unlocked_connection, actual_lock,
              result);
      UNTIL (result = successful);
      osp$end_subsystem_activity;
    PROCEND initialize_connection_list;
?? TITLE := '    assign_connection_id' ??
?? NEWTITLE := '      decrement_active_connections', EJECT ??

    PROCEDURE assign_connection_id (connection: ^nlt$cl_connection;
      VAR connection_id_assigned: boolean;
      VAR connection_id: nlt$cl_connection_id);

      PROCEDURE [INLINE] decrement_active_connections (VAR actual_active {INPUT, OUTPUT} : integer);

      VAR
        result: successful .. locked,
        new_active: integer;

        new_active := actual_active - 1;
        REPEAT
          #compare_swap (nlv$cl_connections.active, actual_active, new_active, actual_active, result);
          IF (result = failed) THEN
            new_active := actual_active - 1;
          IFEND;
        UNTIL (result = successful);
        nlv$cl_active_connections := new_active;
        actual_active := new_active;
      PROCEND decrement_active_connections;
?? TITLE := '      [INLINE] get_connection_id', EJECT ??

      PROCEDURE [INLINE] get_connection_id (VAR connection_id: nlt$cl_connection_id);

      VAR
        result: successful .. locked,
        initial_seed,
        new_seed: integer;

        initial_seed := 0;
        new_seed := 1;
        REPEAT
          #compare_swap (nlv$cl_connections.cid_seed, initial_seed, new_seed, initial_seed, result);
          CASE result OF
          = successful =
            connection_id.sequence := (new_seed DIV (UPPERVALUE (nlt$cl_reference_number) + 1));
            connection_id.reference_number := (new_seed MOD (UPPERVALUE (nlt$cl_reference_number) + 1));
          = failed =
            IF (((initial_seed + 1) MOD (UPPERVALUE (nlt$cl_reference_number) + 1)) <> 0) THEN
              new_seed := initial_seed + 1;
            ELSE
              new_seed := initial_seed + 2;
            IFEND;
          = locked =
            ;
          CASEND;
        UNTIL (result = successful);
      PROCEND get_connection_id;
?? OLDTITLE, EJECT ??

      VAR
        root: nlt$cl_reference_number,
        number_of_roots: nlt$cl_connections_per_system,
        result: successful .. locked,
        initial_active,
        new_active,
        actual_active: integer,
        first_connection,
        stem: ^nlt$cl_connection,
        stem_length: nlt$cl_reference_number,
        ignore_status: ost$status;

      number_of_roots := UPPERBOUND (nlv$cl_connections.list^) + 1;
      connection^.nextt := NIL;
      connection_id_assigned := FALSE;

      REPEAT
        #compare_swap (nlv$cl_connections.active, 0, 0, actual_active, result);
        IF (result = successful) THEN
          actual_active := 0;
        IFEND;
      UNTIL (result <> locked);

    /assign_id/
      WHILE (NOT connection_id_assigned AND (actual_active < nlv$maximum_system_connections)) DO
        initial_active := actual_active;
        get_connection_id (connection_id);
        root := (connection_id.reference_number MOD number_of_roots);
        new_active := initial_active + 1;

      /assign_connection/
        WHILE NOT connection_id_assigned DO
          #compare_swap (nlv$cl_connections.active, initial_active, new_active, actual_active, result);
          CASE result OF
          = successful =
            nlv$cl_active_connections := new_active;
            get_exclusive_to_root (root);
            first_connection := nlv$cl_connections.list^ [root].first;

            IF (first_connection = NIL) THEN
              { Place connection at root. }
              nlv$cl_connections.list^ [root].first := connection;
              release_exclusive_to_root (root);
              connection_id_assigned := TRUE;
            ELSE
              stem := first_connection;
              stem_length := 1;

            /add_connection_to_stem/
              WHILE NOT connection_id_assigned DO
                IF (stem^.identifier.reference_number <> connection_id.reference_number) THEN
                  IF (stem^.nextt = NIL) THEN
                    IF (stem_length < ((actual_active DIV number_of_roots) + 1)) THEN
                      stem^.nextt := connection;
                      release_exclusive_to_root (root);
                      connection_id_assigned := TRUE;
                      IF (initial_active = 0) THEN
                        pmp$ready_task (nlv$timer_monitor_task, ignore_status);
                      IFEND;
                    ELSE
                      release_exclusive_to_root (root);
                      decrement_active_connections (actual_active);
                      CYCLE /assign_id/;
                    IFEND;
                  ELSE
                    stem_length := stem_length + 1;
                    stem := stem^.nextt;
                  IFEND;
                ELSE
                  release_exclusive_to_root (root);
                  decrement_active_connections (actual_active);
                  CYCLE /assign_id/;
                IFEND;
              WHILEND /add_connection_to_stem/;
            IFEND;

          = failed =
            initial_active := actual_active;
            new_active := initial_active + 1;
          = locked =
            ;
          CASEND;
        WHILEND /assign_connection/;
      WHILEND /assign_id/;
    PROCEND assign_connection_id;
?? OLDTITLE, EJECT ??

    VAR
      actual_value: nlt$cl_connection_access,
      connection: ^nlt$cl_connection,
      connection_id_assigned: boolean,
      cs_status: successful .. locked,
      new_value: nlt$cl_connection_access;

    IF nlv$maximum_system_connections > 0 THEN
      IF (nlv$cl_connections.list = NIL) THEN
        initialize_connection_list;
      IFEND;

      ALLOCATE connection IN osv$mainframe_wired_heap^;
      connection^ := null_cl_connection;
      pmp$get_executing_task_gtid (new_value.task_id);
      new_value.fill := 0;
      new_value.notify_system_task := FALSE;
      connection^.access_control := new_value;
      osp$begin_subsystem_activity;
      assign_connection_id (connection, connection_id_assigned, connection^.identifier);
      IF connection_id_assigned THEN
        connection^.application_layer := application_layer;
        IF (application_layer = nlc$tcp_interface) OR
          (application_layer = nlc$udp_interface) THEN
          connection^.queue_on_connection := TRUE;
          connection^.connection_queue.fill := 0;
          connection^.connection_queue.in_queue := FALSE;
          connection^.connection_queue.next_connection := NIL;
          connection^.input_queue.next_received_message := NIL;
          connection^.input_queue.fill := 0;
          connection^.active_receiver := NIL;
        IFEND;
        connection^.layer_connections := layer_connections;
        cl_connection := connection;
      ELSE
        FREE connection IN osv$mainframe_wired_heap^;
        osp$end_subsystem_activity;
        cl_connection := NIL;
      IFEND;
    ELSE
      cl_connection := NIL;
    IFEND;
  PROCEND nlp$cl_assign_connection;
?? TITLE := '  [INLINE] get_exclusive_to_root', EJECT ??

  PROCEDURE [INLINE] get_exclusive_to_root (root: nlt$cl_reference_number);

    VAR
      result: successful .. locked,
      initial_root,
      new_root,
      actual_root: nlt$cl_connection_root_access;

    initial_root.nonexclusive_accessors := 0;
    initial_root.exclusive := FALSE;
    initial_root.fill := 0;
    new_root := initial_root;
    new_root.exclusive := TRUE;

    osp$begin_subsystem_activity;
    REPEAT
      #compare_swap (nlv$cl_connections.list^ [root].access_control, initial_root, new_root, actual_root,
            result);
      IF (result = failed) THEN
        osp$end_subsystem_activity;
        syp$cycle;
        osp$begin_subsystem_activity;
      IFEND;
    UNTIL (result = successful);
  PROCEND get_exclusive_to_root;
?? TITLE := '  [INLINE] get_nonexclusive_to_root', EJECT ??

  PROCEDURE [INLINE] get_nonexclusive_to_root (root: nlt$cl_reference_number);

    VAR
      result: successful .. locked,
      new_root,
      actual_root: nlt$cl_connection_root_access;

    actual_root.nonexclusive_accessors := 0;
    actual_root.exclusive := FALSE;
    actual_root.fill := 0;
    new_root := actual_root;
    new_root.nonexclusive_accessors := 1;

    REPEAT
      #compare_swap (nlv$cl_connections.list^ [root].access_control, actual_root, new_root, actual_root,
            result);
      IF (result = failed) THEN
        IF actual_root.exclusive THEN
          syp$cycle;
          actual_root.exclusive := FALSE;
        IFEND;
        new_root.nonexclusive_accessors := actual_root.nonexclusive_accessors + 1;
      IFEND;
    UNTIL (result = successful);
  PROCEND get_nonexclusive_to_root;
?? TITLE := '  [XDCL, #GATE] nlp$cl_get_nonexclusive_to_root', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$cl_get_nonexclusive_to_root (root: nlt$cl_reference_number);
*copy nlh$cl_get_nonexclusive_to_root

    get_nonexclusive_to_root (root);
  PROCEND nlp$cl_get_nonexclusive_to_root;
?? TITLE := '  [INLINE] release_exclusive_to_root', EJECT ??

  PROCEDURE [INLINE] release_exclusive_to_root (root: nlt$cl_reference_number);

    VAR
      result: successful .. locked,
      initial_root,
      new_root,
      actual_root: nlt$cl_connection_root_access;

    initial_root.nonexclusive_accessors := 0;
    initial_root.exclusive := TRUE;
    initial_root.fill := 0;
    new_root := initial_root;
    new_root.exclusive := FALSE;

    REPEAT
      #compare_swap (nlv$cl_connections.list^ [root].access_control, initial_root, new_root, actual_root,
            result);
    UNTIL (result = successful);
    osp$end_subsystem_activity;
  PROCEND release_exclusive_to_root;
?? TITLE := '  [INLINE] release_nonexclusive_to_root', EJECT ??

  PROCEDURE [INLINE] release_nonexclusive_to_root (root: nlt$cl_reference_number);

    VAR
      result: successful .. locked,
      new_root,
      actual_root: nlt$cl_connection_root_access;

    actual_root.nonexclusive_accessors := 1;
    actual_root.exclusive := FALSE;
    actual_root.fill := 0;
    new_root := actual_root;
    new_root.nonexclusive_accessors := 0;

  /release_root/
    REPEAT
      #compare_swap (nlv$cl_connections.list^ [root].access_control, actual_root, new_root, actual_root,
            result);
      IF (result = failed) THEN
        new_root.nonexclusive_accessors := actual_root.nonexclusive_accessors - 1;
      IFEND;
    UNTIL (result = successful);
  PROCEND release_nonexclusive_to_root;
?? TITLE := '  [XDCL, #GATE] nlp$cl_release_nonexclu_to_root', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$cl_release_nonexclu_to_root (root: nlt$cl_reference_number);
*copy nlh$cl_release_nonexclu_to_root

    release_nonexclusive_to_root (root);
  PROCEND nlp$cl_release_nonexclu_to_root;
?? TITLE := '  [XDCL, #GATE] nlp$cl_get_connection_access', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$cl_get_connection_access (cl_connection: ^nlt$cl_connection;
    VAR access_gained: boolean);

*copy nlh$cl_get_connection_access

    VAR
      actual_value: nlt$cl_connection_access,
      connection: ^nlt$cl_connection,
      cs_status: successful .. locked,
      new_value: nlt$cl_connection_access;

    connection := #address (1, #segment (cl_connection), #offset (cl_connection));
    pmp$get_executing_task_gtid (new_value.task_id);
    new_value.fill := 0;
    new_value.notify_system_task := FALSE;
    osp$begin_subsystem_activity;
    REPEAT
      #compare_swap (connection^.access_control, unlocked_connection_access, new_value,
            actual_value, cs_status);
    UNTIL cs_status <> locked;
    access_gained := (cs_status = successful);
    IF NOT access_gained THEN
      IF (actual_value.task_id <> new_value.task_id) THEN
        osp$end_subsystem_activity;
      ELSE
        osp$system_error ('NAM/VE - lock already set by current task', NIL);
      IFEND;
    IFEND;
  PROCEND nlp$cl_get_connection_access;
?? TITLE := '  [XDCL, #GATE] nlp$cl_release_connection', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$cl_release_connection (connection_id: nlt$cl_connection_id);
*copy nlh$cl_release_connection

    VAR
      actual_cl_access: nlt$cl_connection_access,
      root: nlt$cl_reference_number,
      connection: ^^nlt$cl_connection,
      connection_to_free: ^nlt$cl_connection,
      connection_exists: boolean,
      initial_cl_access: nlt$cl_connection_access,
      new_cl_access: nlt$cl_connection_access,
      result: successful .. locked,
      initial_active,
      new_active,
      actual_active: integer;

    root := (connection_id.reference_number MOD (UPPERBOUND (nlv$cl_connections.list^) + 1));
    get_exclusive_to_root (root);
    connection := ^nlv$cl_connections.list^ [root].first;
    connection_exists := FALSE;

    WHILE (NOT connection_exists AND (connection^ <> NIL)) DO
      IF (connection^^.identifier = connection_id) THEN
        connection_exists := TRUE;
        pmp$get_executing_task_gtid (new_cl_access.task_id);
        new_cl_access.fill := 0;
        new_cl_access.notify_system_task := FALSE;
        REPEAT
          #compare_swap (connection^^.access_control, unlocked_connection_access,
                new_cl_access, actual_cl_access, result);
        UNTIL result <> locked;
        IF result = successful THEN
          IF connection^^.layers_active = $nlt$cl_layers [] THEN
          connection_to_free := connection^;
          connection^ := connection^^.nextt;
          FREE connection_to_free^.layer_connections IN nav$network_paged_heap^;
          FREE connection_to_free IN osv$mainframe_wired_heap^;
          release_exclusive_to_root (root);

          initial_active := 1;
          new_active := 0;

        /decrement_active_connections/
          REPEAT
            #compare_swap (nlv$cl_connections.active, initial_active, new_active, initial_active, result);
            IF (result = failed) THEN
              new_active := initial_active - 1;
            IFEND;
          UNTIL (result = successful);
          nlv$cl_active_connections := new_active;
          ELSE { layers active

{ Unlock the connection.

            initial_cl_access := new_cl_access;
            REPEAT
              #compare_swap (connection^^.access_control, initial_cl_access, unlocked_connection_access,
                actual_cl_access, result);
              IF result = failed THEN
                IF actual_cl_access.task_id = initial_cl_access.task_id THEN
                  initial_cl_access := actual_cl_access;
                ELSE
                 osp$system_error ('NAM/VE - lock not locked by current task', NIL);
                IFEND;
              IFEND;
            UNTIL result = successful;

            IF actual_cl_access.notify_system_task THEN
              notify_system_task;
            IFEND;
            release_exclusive_to_root (root);
          IFEND;
        ELSEIF actual_cl_access.task_id <> new_cl_access.task_id THEN
          release_exclusive_to_root (root);
        ELSE
          osp$system_error ('NAM/VE - lock already set by current task', NIL);
        IFEND;
      ELSE
        connection := ^connection^^.nextt;
      IFEND;
    WHILEND;
  PROCEND nlp$cl_release_connection;
?? TITLE := '  [XDCL, #GATE] nlp$cl_recover_cid_seed', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$cl_recover_cid_seed;
*copy nlh$cl_recover_cid_seed

    VAR
      image_descriptor: dst$nve_image_descriptor,
      rmfwsn: ost$segment, {recoverd mainframe wired segment number}
      system_core_id: ^ost$name,
      cid_seed: ^integer;

    dsp$get_nve_image_description (image_descriptor);
    IF (image_descriptor.rcv_mainframe_wired_segment <> NIL) THEN
      rmfwsn := #segment (image_descriptor.rcv_mainframe_wired_segment);
      IF (image_descriptor.rcv_page_size = osv$page_size) THEN

        { Image file required from this point on !!!!!

        system_core_id := #address (1, rmfwsn, #offset (^jmv$system_core_id));
        IF (system_core_id^ = jmv$system_core_id) THEN
          cid_seed := #address (1, rmfwsn, #offset (^nlv$cl_connections.cid_seed));
          nlv$cl_connections.cid_seed := (cid_seed^ MOD (UPPERVALUE (nlt$cl_reference_number) + 1));
        IFEND;
      IFEND;
    IFEND;
  PROCEND nlp$cl_recover_cid_seed;
MODEND nlm$cl_connection_manager_r1;
*DECK DECK=NLM$CL_CONNECTION_MANAGER_R3 EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'NAM/VE: Connection Manager' ??
MODULE nlm$cl_connection_manager_r3;

{
{   PURPOSE:
{     The prime purpose of this module is to isolate the knowledge of the structures required
{     to access a specific connection.  Secondarily, the module contains service procedures to
{     support the connection establishment phase.
{
{     This module utilizes services provided by the system core connection manager to fulfill
{     its obligations.
{
{   DESIGN:
{     This module is designed to reside on the  OSF$JOB_TEMPLATE_23D library.
{
{     The service procedure for connection establishment, create connection, restrict the knowledge
{     of the mechanics of the internal connection structure.
{
?? NEWTITLE := '  Global Declarations', EJECT ??
*copyc nlt$cl_connection
?? TITLE := '  External Procedures', EJECT ??
*copyc nlp$cl_assign_connection
?? TITLE := '  Internal Declarations', EJECT ??
?? TITLE := '  Global Variables', EJECT ??
*copyc nav$network_paged_heap
*copyc nlv$cl_connection_layer_templat
?? TITLE := '  [XDCL] nlp$cl_create_connection', EJECT ??

  PROCEDURE [XDCL] nlp$cl_create_connection (application_layer: nlt$cl_application_layer;
    VAR cl_connection: ^nlt$cl_connection);
*copy nlh$cl_create_connection

    VAR
      required_space: integer,
      layer: nlt$cl_layer_name,
      layer_name: ^nlt$cl_layer_name,
      layer_connection: ^array [1 .. * ] of cell,
      layer_connections: ^nlt$cl_layer_connections;

    required_space := 0;
    FOR layer := application_layer TO UPPERVALUE (nlt$cl_layer_name) DO
      IF nlv$cl_connection_layer_templat [application_layer].path [layer] THEN
        required_space := required_space + nlv$cl_connection_layer_templat [application_layer].connection
              [layer].description_size + #SIZE (nlt$cl_layer_name);
      IFEND;
    FOREND;

    ALLOCATE layer_connections: [[REP required_space OF cell]] IN nav$network_paged_heap^;
    IF (layer_connections <> NIL) THEN
      nlp$cl_assign_connection (application_layer, layer_connections, cl_connection);
      IF (cl_connection <> NIL) THEN
        RESET layer_connections;
        FOR layer := application_layer TO UPPERVALUE (nlt$cl_layer_name) DO
          IF nlv$cl_connection_layer_templat [application_layer].path [layer] THEN
            NEXT layer_name IN layer_connections;
            layer_name^ := layer;
            NEXT layer_connection: [1 .. nlv$cl_connection_layer_templat [application_layer].connection
                  [layer].description_size] IN layer_connections;
          IFEND;
        FOREND;
      ELSE
        FREE layer_connections IN nav$network_paged_heap^;
      IFEND;
    ELSE
      cl_connection := NIL;
    IFEND;
  PROCEND nlp$cl_create_connection;
MODEND nlm$cl_connection_manager_r3;
*DECK DECK=NLM$DIRECTORY_MANAGEMENT_ENTITY EXPAND=TRUE
MODULE nlm$directory_management_entity;
?? LEFT := 1, RIGHT := 110 ??

{ PURPOSE:
{       1.   Register  a title and corresponding address over a
{       specified translation domain.
{
{       2.   Translate  a  title.  Return one or more addresses
{       for valid translations of the title over a specified
{       search domain.
{
{ EXTERNAL INTERFACES:
{
{       Directory uses the OSI NETWORK layer.
{
{  DIRECTORY COMPONENTS:
{
{       The  Directory  M-E  is  contained in one module called
{       nlm$directory_management_entity.  There are 3 basic parts
{       to the module.
{
{       1.  Directory management.
{       Receives directory data units from other Directory M-Es.
{       Periodically distributes registered titles and translation
{       requests. Deletes expired cache entries.
{
{       2.  Registration.  The registration section consists of
{       user  called procedures which create, change, or delete
{       a directory  entry.   The  Registration  Data Store, RDS,
{       holds  these  titles.  The create  and  delete
{       primitives only  search  the  RDS  table.
{       The registration procedures are:
{
{         . nlp$register_title
{         . nlp$delete_registered_title
{
{       3.  Translation.  The translation section consists of a
{       user   called   procedure   which   requests   a  title
{       translation.    The   user  can  also  request  that  a
{       translation   request   be   terminated.    Outstanding
{       translation  requests  are  put  into  the  Translation
{       Request Data Store, TRDS.   Translations are obtained by
{       calling another procedure. The translation procedures are:
{
{         . nlp$translate_title
{         . nap$check_title_translation
{         . nlp$get_title_translation
{         . nlp$end_title_translation
{
{       The possible PDUs are:
{
{       A.   Translation  Data Unit.  The Translation Data unit
{       may be broadcast over the  distribution   domain  after
{       registration or change. The algorithm for  broadcasting
{       Translation   Data   Units  is: distribute  n times at
{       time1 intervals, then continue indefinitely at time2
{       intervals. Current  value for time1 is 1 minute and
{       current value for n is 3. time2 is currently set to 15 minutes.
{       A Translation Data Unit is also returned to the requesting
{       system in response to a Translation Request Data Unit.
{
{       B.    Delete   Translation  Data  Unit.   This  PDU  is
{       broadcast  over  the  title  domain  after  the RDS
{       entry is deleted when distribution was requested on
{       registration.
{
{       C.   Translation  Request  Data  Unit.  The Translation
{       Request  Data Unit is periodically broadcast  over  the
{       search  domain.  The time delay for broadcasting  these
{       data  units  is 5 seconds. Since directory data units are
{       sent at system priority, network traffic levels should not
{       delay them significantly.
{
{       D.   Start-up Data Unit.  Directory M-E broadcasts this
{       PDU to  remote  Directory  M-E's  in the catenet during
{       Directory  M-E  initialization.  It causes  the  remote
{       Directory  M-E's to  delete  old  entries  out  of  the
{       Translation Data Store. The start-up data unit is sent
{       out 5 times at one minute intervals to allow for loading
{       MDIs and NDIs to gain access to the entire catenet.
{
{  DATA STORES:
{
{       1.   Registration  Data  Store,  RDS.   This  store
{       contains  all  the  currently registered titles.  These
{       titles were created by  a primitive.  Duplicate entries
{       are rejected.  There  is no maximum set for the
{       number of RDS entries.  The data  store is allocated in
{       the network paged heap and entries are allocated
{       dynamically  until the  heap is full.
{
{       2.   Translation  Data  Store,  TDS.   This  data store
{       contains  a  list  of the most recent translation  data
{       units received from other  systems. The TDS  data  store
{       is also allocated  in  the  network paged heap. The  TDS
{       data structure  is  the  same as the RDS data structure.
{       Entries are retained in the TDS only for a specified time
{       period after receipt (currently 1 minute) or until a
{       delete translation  data unit is received. Only maximum
{       priority translations are saved in the cache.
{
{       3.   Translation  Request Data Store, TRDS.  This store
{       contains all the currently active translation requests.
{       There is no maximum set for the number of TRDS entries.
{       The data store is allocated  in  the network paged heap.
{       A translation request entry will be deleted after a fixed
{       delay after completion of the search for a non-recurrent
{       search (currently 10 minutes) or when terminated by the
{       requestor. A recurrent search will be deleted when the
{       requestor is no longer present or when the status of the
{       request is not checked periodically (at least once every
{       ten minutes).

?? NEWTITLE := 'Directory Tuning Options', EJECT ??

  CONST

{ * * * PERIODIC TIMES IN SECONDS FOR DISTRIBUTION OF THE REGISTERED
{       TITLE IF DISTRIBUTION IS REQUESTED.

    nac$title_distribution_delay = 60000000 {microseconds} ,
    nac$title_redistribute_delay = 900000000 {microseconds} ,
    nac$title_distribution_count = 3,

{       INCREMENTAL DELAY USED FOR SENDING TRANSLATION REQUEST PDUS

    nac$translation_request_delay = 5000000 {microseconds} ,
    nac$max_request_broadcast_count = 3,

{       TRANSLATION CACHE AGING TIME AFTER RECEIPT (nac$cache_timeout)

    nac$cache_timeout = 60000000 {microseconds} ,

{       DIRECTORY MANAGER MAX CYCLE TIME (must be less than 48 bits)

    nac$very_long_time = 03fffffffffff(16),

{       TIMEOUT FOR DELIVERY OF TRANSLATIONS FOR AN ACTIVE SEARCH

    nac$max_request_hold_time = 600000000 {microseconds} ,

{       NUMBER AND INTERVAL FOR STARTUP DATA UNIT TRANSMISSION AT STARTUP

    nac$max_startup_pdu_count = 5,
    nac$startup_pdu_interval = 60000000 {microseconds; one minute} ;

{       PREFIX FOR DIRECTORY ASSIGNED USER IDENTIFIER VALUES

  CONST
    nac$default_user_identifier = 'NAI$';

?? OLDTITLE ??
?? NEWTITLE := 'directory type declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc nac$reserved_saps
*copyc nae$application_interfaces
*copyc nae$directory_me_conditions
*copyc nae$namve_conditions
*copyc nat$community_title
*copyc nat$directory_data
*copyc nat$directory_entry_identifier
*copyc nat$directory_search_identifier
*copyc nat$directory_interfaces
*copyc nat$directory_priority
*copyc nat$network_address_kind
*copyc nat$network_selector
*copyc nat$osi_address_length
*copyc nat$osi_network_address
*copyc nat$osi_presentation_address
*copyc nat$osi_session_address
*copyc nat$osi_transport_address
*copyc nat$protocol
*copyc nat$subnet_identifier
*copyc nat$system_identifier
*copyc nat$title
*copyc nat$title_pattern
*copyc nlt$device_identifier
*copyc nlt$network_device
*copyc nlt$system_management
*copyc nlt$ta_sap_selector
*copyc ost$name
*copyc ost$string
*copyc pmt$condition
*copyc pmt$established_handler
?? POP ??

{ * * * MAXIMUM PROTOCOL DATA UNIT SIZE AND CURRENT VERSION NUMBER.

  CONST
    nac$max_directory_pdu_size = 1400,
    nac$osi_directory_version = 2,
    nac$directory_version_3 = 3;

{ * * * DIRECTORY ME PROTOCOL DATA UNIT ID VALUES.

  CONST
    nac$translation_req_data_unit = 1,
    nac$translation_data_unit = 2,
    nac$del_translation_data_unit = 3,
    nac$startup_data_unit = 4,
    nac$v3_translation_rq_data_unit = 5,
    nac$v3_translation_data_unit = 6,
    nac$v3_dl_translation_data_unit = 7,
    nac$v3_startup_data_unit = 8;

{ * * * MINIMUM RING VALIDATION FOR USING THE NETWORK_OPERATOR_UTILITY

  CONST
    minimum_ring_allowed = 6;

{ * * * PROTOCOL DATA UNIT DEFINITION

  CONST
    nac$initial_pdu_lifetime = 64;

  TYPE
    pdu_header = record
      id: 0 .. 0ff(16),
      version: 0 .. 0ff(16),
    recend;

  TYPE
    translation_request_pdu = record
      id: 0 .. 0ff(16),
      version: 0 .. 0ff(16),
      title_size: nat$title_length,
      protocol: nat$protocol,
      info: packed record
        wild_card: boolean,
        class: nat$title_class,
      recend,
      community_count: 0 .. 0ff(16),
      {communities: array [ community_count ] of nat$community_title,
      {title: string (title_size),
    recend;

  TYPE
    translation_request_pdu_v3 = record
      id: 0 .. 0ff(16),
      version: 0 .. 0ff(16),
      sequence: 0 .. 0ffff(16),
      lifetime: 0 .. 0ffff(16),
      title_size: nat$title_length,
      source_nsap_length: 0 .. 0ff(16),
      protocol: nat$protocol,
      info: packed record
        wild_card: boolean,
        class: nat$title_class,
      recend,
      {title: string (title_size),
      {source_nsap_address: string (source_nsap_length),
    recend;

  TYPE
    translation_pdu = record
      id: 0 .. 0ff(16),
      version: 0 .. 0ff(16),
      identifier: nat$directory_entry_identifier,
      change_count: 0 .. 0ffff(16),
      title_size: nat$title_length,
      address: record
        kind: nat$network_address_kind,
        filler: SEQ (REP 14 of cell) {formerly used for XNS addresses} ,
      recend,
      protocol: nat$protocol,
      priority: 1 .. 0ff(16),
      info: packed record
        class: nat$title_class,
        response: boolean,
        userinfo_size: 0 .. 03f(16),
      recend,
      community_count: 0 .. 0ff(16),
      {communities: array [ community_count ] of nat$community_title,
      {title: string (title_size),
      {user_info: string (userinfo_size),
      {osi_address: nat$translation_address,
    recend;

  TYPE
    translation_pdu_v3 = record
      id: 0 .. 0ff(16),
      version: 0 .. 0ff(16),
      sequence: 0 .. 0ffff(16),
      lifetime: 0 .. 0ffff(16),
      identifier: nat$directory_entry_identifier,
      change_count: 0 .. 0ffff(16),
      title_size: nat$title_length,
      address_kind: nat$network_address_kind,
      protocol: nat$protocol,
      priority: 1 .. 0ff(16),
      info: packed record
        class: nat$title_class,
        response: boolean,
        userinfo_size: 0 .. 03f(16),
      recend,
      reserved: 0 .. 0ff(16),
      {title: string (title_size),
      {user_info: string (userinfo_size),
      {osi_address: nat$translation_address,
    recend;

  TYPE
    delete_translation_pdu = record
      id: 0 .. 0ff(16),
      version: 0 .. 0ff(16),
      identifier: nat$directory_entry_identifier,
      title_size: nat$title_length,
      {title: string (title_size),
    recend;

  TYPE
    delete_translation_pdu_v3 = record
      id: 0 .. 0ff(16),
      version: 0 .. 0ff(16),
      sequence: 0 .. 0ffff(16),
      lifetime: 0 .. 0ffff(16),
      identifier: nat$directory_entry_identifier,
      title_size: nat$title_length,
      {title: string (title_size),
    recend;

  TYPE
    startup_pdu = record
      id: 0 .. 0ff(16),
      version: 0 .. 0ff(16),
      identifier: nat$directory_entry_identifier,
    recend;

  TYPE
    startup_pdu_v3 = record
      id: 0 .. 0ff(16),
      version: 0 .. 0ff(16),
      sequence: 0 .. 0ffff(16),
      lifetime: 0 .. 0ffff(16),
      identifier: nat$directory_entry_identifier,
    recend;

  TYPE
    generate_reason = (distribution, response);

  VAR
    nlv$log_broadcast_requests: [XREF] boolean,
    nlv$log_broadcast_translations: [XREF] boolean;

*copyc nat$network_layer_address
*copyc nat$translation_request
*copyc nat$translation
*copyc nav$cdna_multicast_address
*copyc nav$global_statistics
*copyc nav$host_subnet_id
*copyc nav$network_paged_heap
*copyc nav$namve_active
*copyc nav$registered_titles
*copyc nav$statistics_enabled
*copyc nav$system_id
*copyc nav$translation_cache
*copyc nav$translation_requests
*copyc nav$unique_directory_identifier
*copyc nlv$configured_network_devices
*copyc nlv$directory_lock
*copyc nlv$directory_id_seq_number
*copyc nlv$directory_pdu_seq_number
*copyc nlv$directory_version
*copyc nlv$sm_devices
*copyc nlv$transport_network_selector
*copyc ost$caller_identifier
?? OLDTITLE ??
?? NEWTITLE := 'XREF procedures', EJECT ??
*copyc avp$get_capability
*copyc clp$convert_integer_to_string
*copyc i#move
*copyc jmv$executing_within_system_job
*copyc nap$receive_network_data
*copyc nap$record_directory_me
*copyc nap$send_network_data
*copyc nap$system_id
*copyc nap$user_network_id
*copyc nlp$get_nonexclusive_access
*copyc nlp$na_broadcast_data
*copyc nlp$release_nonexclusive_access
*copyc osp$begin_subsystem_activity
*copyc osp$end_subsystem_activity
*copyc osp$clear_job_signature_lock
*copyc osp$increment_locked_variable
*copyc osp$pop_inhibit_job_recovery
*copyc osp$push_inhibit_job_recovery
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$test_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc pmp$get_compact_date_time
*copyc pmp$get_executing_task_gtid
*copyc pmp$log
*copyc pmp$ready_task
?? OLDTITLE ??
?? NEWTITLE := 'nlp$directory_manager', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$directory_manager
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{     PURPOSE:
{       This  routine  opens the directory SAP and processes all
{       received directory data units.
{
{    DESIGN:
{       Data units are validated to be in CDNA Directory protocol from
{       another system. Valid packets are then processed.

    VAR
      current_time: integer,
      data_buffer: ^SEQ (REP nac$max_directory_pdu_size of cell),
      data_length: integer,
      data_unit: ^SEQ ( * ),
      delete_time: integer,
      device_id: nlt$device_identifier,
      directory_data_unit: array [1 .. 1] of nat$data_fragment,
      input_buffer: SEQ (REP nac$max_directory_pdu_size of cell),
      local_system: nat$system_identifier,
      network_address: ^SEQ ( * ),
      network_device_list: ^nlt$network_device_list,
      next_maintenance_time: integer,
      next_request: ^nat$translation_request,
      next_translation: ^nat$translation,
      prefix: ^SEQ ( * ),
      sequence_number: integer,
      source: nat$network_layer_address,
      startup_count: 0 .. nac$max_startup_pdu_count,
      startup_data_unit: array [1 .. 1] of nat$data_fragment,
      startup_data: startup_pdu,
      startup_data_v3: startup_pdu_v3,
      startup_timer: integer,
      system_identifier: ^nat$system_identifier,
      translation: ^nat$translation,
      translation_request: ^nat$translation_request,
      wait_time: 0 .. 0ffffffff(16);

?? NEWTITLE := '  exit_condition_handler', EJECT ??

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status,
        lock_status: ost$signature_lock_status;

      handler_status.normal := TRUE;
      local_status.normal := TRUE;
      osp$test_signature_lock (nlv$directory_lock, lock_status, local_status);
      IF local_status.normal AND (lock_status = osc$sls_locked_by_current_task) THEN
        osp$clear_job_signature_lock (nlv$directory_lock);
      IFEND;

    PROCEND exit_condition_handler;
?? OLDTITLE, EJECT ??
    IF NOT jmv$executing_within_system_job THEN
      osp$set_status_abnormal ('NA', nae$insufficient_privilege, 'nlp$directory_manager', status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    osp$establish_block_exit_hndlr (^exit_condition_handler);
    nap$record_directory_me {task identifier} ;
    local_system := nap$system_id ();

    startup_data.id := nac$startup_data_unit;
    startup_data.version := nac$osi_directory_version;
    assign_directory_identifier (startup_data.identifier);
    startup_data_v3.id := nac$v3_startup_data_unit;
    startup_data_v3.version := nac$directory_version_3;
    startup_data_v3.lifetime := nac$initial_pdu_lifetime;
    startup_data_v3.identifier := startup_data.identifier;
    startup_timer := 0;
    startup_count := 0;

    network_device_list := nlv$configured_network_devices.network_device_list;

    data_buffer := ^input_buffer;
    directory_data_unit [1].address := data_buffer;
    directory_data_unit [1].length := #SIZE (data_buffer^);
    wait_time := 0;

  /main_loop/
    WHILE TRUE DO

{ Process a directory data unit if one is available.

      nap$receive_network_data (nac$xi_cdna_directory_sap, directory_data_unit, wait_time, source,
            data_length, status);

      IF status.normal THEN
        network_address := ^source.network_address;
        RESET network_address;
        NEXT prefix: [[REP (source.network_address_length - #SIZE (nat$network_selector) -
              #SIZE (nat$system_identifier)) OF cell]] IN network_address;
        NEXT system_identifier IN network_address;
        IF system_identifier^ <> local_system THEN
          RESET data_buffer;
          NEXT data_unit: [[REP data_length OF cell]] IN data_buffer;
          process_data_unit (source, system_identifier^, data_unit);
        IFEND;
      IFEND;

      current_time := #FREE_RUNNING_CLOCK (0);

{ Broadcast startup pdu if necessary.

      IF current_time >= startup_timer THEN
        IF startup_count < nac$max_startup_pdu_count THEN
          IF nlv$directory_version = nac$osi_directory_version THEN
            startup_data_unit [1].address := ^startup_data;
            startup_data_unit [1].length := #SIZE (startup_data);
            FOR device_id := LOWERBOUND (network_device_list^) TO UPPERBOUND (network_device_list^) DO
              nlp$na_broadcast_data (device_id, nac$xi_cdna_directory_sap, nac$xi_cdna_directory_sap,
                    startup_data_unit, status);
            FOREND;
          ELSE {nac$directory_version_3
            startup_data_unit [1].address := ^startup_data_v3;
            startup_data_unit [1].length := #SIZE (startup_data_v3);
            get_pdu_sequence_number (sequence_number);
            startup_data_v3.sequence := sequence_number;
            nlp$get_nonexclusive_access (nlv$sm_devices.access_control);
            FOR device_id := LOWERBOUND (network_device_list^) TO UPPERBOUND (network_device_list^) DO
              send_distributed_pdu (device_id, startup_data_unit);
            FOREND;
            nlp$release_nonexclusive_access (nlv$sm_devices.access_control);
          IFEND;
          startup_count := startup_count + 1;
          startup_timer := current_time + nac$startup_pdu_interval;
        ELSE
          startup_timer := current_time + nac$very_long_time;
        IFEND;
      IFEND;

      next_maintenance_time := startup_timer;
      osp$set_job_signature_lock (nlv$directory_lock);

{ Rebroadcast any translation requests that have not been satisfied.
{ Delete any translation requests that have expired.

      IF current_time >= nav$translation_requests.next_broadcast_time THEN
        nav$translation_requests.next_broadcast_time := current_time + nac$very_long_time;
        translation_request := nav$translation_requests.first;
        WHILE (translation_request <> NIL) DO
          next_request := translation_request^.link;
          IF (translation_request^.time_stamp <= current_time) THEN
            IF translation_request^.broadcast_counter >= nac$max_request_broadcast_count THEN
              delete_time := translation_request^.time_stamp + nac$max_request_hold_time;
              pmp$ready_task (translation_request^.requestor, {ignore} status);
              IF delete_time <= current_time THEN
                delete_request (translation_request);
              ELSEIF delete_time < nav$translation_requests.next_broadcast_time THEN
                nav$translation_requests.next_broadcast_time := delete_time;
              IFEND;
            ELSE {time to redistribute the translation request}
              distribute_translation_request (translation_request);
              IF translation_request^.recurrent_search AND (translation_request^.broadcast_counter >=
                    nac$max_request_broadcast_count) THEN {no more searches...go into recurrent search mode}
                translation_request^.time_stamp := current_time + nac$max_request_hold_time;
              IFEND;
              IF translation_request^.time_stamp < nav$translation_requests.next_broadcast_time THEN
                nav$translation_requests.next_broadcast_time := translation_request^.time_stamp;
              IFEND;
            IFEND;
          ELSEIF translation_request^.time_stamp < nav$translation_requests.next_broadcast_time THEN
            nav$translation_requests.next_broadcast_time := translation_request^.time_stamp;
          IFEND;
          translation_request := next_request;
        WHILEND;
      IFEND;
      IF nav$translation_requests.next_broadcast_time < next_maintenance_time THEN
        next_maintenance_time := nav$translation_requests.next_broadcast_time;
      IFEND;

{ Periodically distribute registered titles as requested.

      IF current_time >= nav$registered_titles.next_timer THEN
        nav$registered_titles.next_timer := current_time + nac$very_long_time;
        translation := nav$registered_titles.first;
        WHILE (translation <> NIL) DO
          IF (translation^.time_stamp <= current_time) THEN
            distribute_translation (translation);
          IFEND;
          IF translation^.time_stamp < nav$registered_titles.next_timer THEN
            nav$registered_titles.next_timer := translation^.time_stamp;
          IFEND;
          translation := translation^.link;
        WHILEND;
      IFEND;
      IF nav$registered_titles.next_timer < next_maintenance_time THEN
        next_maintenance_time := nav$registered_titles.next_timer;
      IFEND;

{ Delete any expired cache entries.

      IF current_time >= nav$translation_cache.next_timer THEN
        nav$translation_cache.next_timer := current_time + nac$very_long_time;
        translation := nav$translation_cache.first;
        WHILE (translation <> NIL) DO
          next_translation := translation^.link;
          IF translation^.time_stamp <= current_time THEN
            delete_translation (translation, nav$translation_cache.first);
            IF nav$statistics_enabled AND (nav$global_statistics.directory.current_cache_entries > 0) THEN
              nav$global_statistics.directory.current_cache_entries :=
                    nav$global_statistics.directory.current_cache_entries - 1;
            IFEND;
          ELSEIF translation^.time_stamp < nav$translation_cache.next_timer THEN
            nav$translation_cache.next_timer := translation^.time_stamp;
          IFEND;
          translation := next_translation;
        WHILEND;
      IFEND;
      IF nav$translation_cache.next_timer < next_maintenance_time THEN
        next_maintenance_time := nav$translation_cache.next_timer;
      IFEND;

      osp$clear_job_signature_lock (nlv$directory_lock);
      current_time := #FREE_RUNNING_CLOCK (0);
      IF next_maintenance_time > current_time THEN
        wait_time := (next_maintenance_time - current_time) DIV 1000;
      ELSE
        wait_time := 0;
      IFEND;
    WHILEND;

  PROCEND nlp$directory_manager;
?? OLDTITLE ??
?? NEWTITLE := 'Directory Primitives' ??
?? NEWTITLE := 'nlp$register_title', EJECT ??

  PROCEDURE [#GATE, XDCL] nlp$register_title
    (    title: string ( * <= nac$max_title_length);
         osi_address: nat$osi_registration_address;
         protocol: nat$protocol;
         user_information: ^cell;
         user_information_length: 0 .. nac$max_directory_data_length;
         priority: nat$directory_priority;
         domain: nat$title_domain;
         distribute: boolean;
         class: nat$title_class;
         password: nat$directory_password;
     VAR user_identifier: ost$name;
     VAR identifier: nat$directory_entry_identifier;
     VAR status: ost$status);

*copy nlh$register_title

    VAR
      caller_id: ost$caller_identifier,
      detail: ^SEQ ( * ),
      detail_size: integer,
      network_application_management: boolean,
      osi_address_length: nat$osi_address_length,
      str: ost$string,
      title_length: nat$title_length,
      translation: ^nat$translation;

    status.normal := TRUE;

    #CALLER_ID (caller_id);
    IF (caller_id.ring > minimum_ring_allowed) THEN
      avp$get_capability (avc$network_applic_management, avc$user, network_application_management, status);
      IF  status.normal THEN
        IF (NOT network_application_management) THEN
          osp$set_status_abnormal (nac$status_id, nae$insufficient_privilege, 'nlp$register_titles', status);
          RETURN;
        IFEND;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    IF NOT nav$namve_active THEN
      osp$set_status_condition (nae$network_inactive, status);
      RETURN;
    IFEND;

    title_length := STRLENGTH (title);
    WHILE (title_length > 1) AND (title (title_length) = ' ') DO
      title_length := title_length - 1;
    WHILEND;
    IF title_length = 0 THEN
      osp$set_status_abnormal (nac$status_id, nae$title_too_short, 'NLP$REGISTER_TITLE', status);
      RETURN;
    IFEND;

    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    osp$establish_block_exit_hndlr (^exit_condition_handler);
    osp$set_job_signature_lock (nlv$directory_lock);

{ Validate registration parameters.

    find_title_address (title (1, title_length), osi_address, nav$registered_titles.first, translation);
    IF translation <> NIL THEN {currently registered}
      osp$set_status_condition (nae$duplicate_registration, status);
    IFEND;

{ Create translation entry for registered title.

    IF status.normal THEN
      CASE osi_address.kind OF
      = nac$osi_non_cdna_session_addr, nac$osi_non_cdna_present_addr =
        osi_address_length := #SIZE (osi_address.osi_address^);
      ELSE
        osi_address_length := 0;
      CASEND;

      detail_size := title_length + user_information_length + osi_address_length;
      ALLOCATE translation: [[REP detail_size OF char]] IN nav$network_paged_heap^;
      IF translation <> NIL THEN
        detail := ^translation^.detail;
        RESET detail;
        NEXT translation^.title: [title_length] IN detail;
        translation^.title^ := title;
        translation^.protocol := protocol;
        IF user_information_length > 0 THEN
          NEXT translation^.user_information: [user_information_length] IN detail;
          i#move (user_information, translation^.user_information, user_information_length);
        ELSE
          translation^.user_information := NIL;
        IFEND;
        IF osi_address_length = 0 THEN
          translation^.osi_address_kind := registration_address;
          translation^.registered_address := osi_address;
        ELSE {save the non_cdna address as though it came from the non_cdna system}
          translation^.osi_address_kind := translation_address;
          NEXT translation^.osi_address: [[REP osi_address_length OF cell]] IN detail;
          translation^.osi_address^ := osi_address.osi_address^;
          translation^.registered_address.osi_address := translation^.osi_address;
        IFEND;
        translation^.priority := priority;
        translation^.domain.kind := domain.kind;
        translation^.distribute := distribute;
        translation^.class := class;
        translation^.password := password;
        assign_directory_identifier (translation^.identifier);
        identifier := translation^.identifier;
        translation^.change_count := 0;
        translation^.broadcast_counter := 1;
        translation^.time_stamp := #FREE_RUNNING_CLOCK (0) + nac$very_long_time;
        IF user_identifier = osc$null_name THEN
          translation^.user_identifier := nac$default_user_identifier;
          nav$unique_directory_identifier := nav$unique_directory_identifier + 1;
          clp$convert_integer_to_string (nav$unique_directory_identifier, 10, FALSE, str, status);
          translation^.user_identifier (STRLENGTH (nac$default_user_identifier) + 1, * ) :=
                str.value (1, str.size);
        ELSE
          translation^.user_identifier := user_identifier;
        IFEND;

        add_translation (translation, nav$registered_titles.first);
        IF nav$statistics_enabled THEN
          nav$global_statistics.directory.current_registered_titles :=
                nav$global_statistics.directory.current_registered_titles + 1;
        IFEND;

        IF distribute THEN
          distribute_translation (translation);
          IF translation^.time_stamp < nav$registered_titles.next_timer THEN
            nav$registered_titles.next_timer := translation^.time_stamp;
          IFEND;
        IFEND;

        satisfy_translation_requests (translation);
      ELSE
        osp$set_status_abnormal (nac$status_id, nae$insufficient_resources, 'title registration', status);
      IFEND;
    IFEND;

    osp$clear_job_signature_lock (nlv$directory_lock);
    osp$end_subsystem_activity;
    osp$disestablish_cond_handler;
    osp$pop_inhibit_job_recovery;

  PROCEND nlp$register_title;
?? OLDTITLE ??
?? NEWTITLE := 'nlp$delete_registered_title', EJECT ??

  PROCEDURE [#GATE, XDCL] nlp$delete_registered_title
    (    title: string ( * <= nac$max_title_length);
         password: nat$directory_password;
         identifier: nat$directory_entry_identifier;
     VAR status: ost$status);

*copy nlh$delete_registered_title

    VAR
      caller_id: ost$caller_identifier,
      network_application_management: boolean,
      title_length: nat$title_length,
      translation: ^nat$translation;

    status.normal := TRUE;

    #CALLER_ID (caller_id);
    IF (caller_id.ring > minimum_ring_allowed) THEN
      avp$get_capability (avc$network_applic_management, avc$user, network_application_management, status);
      IF  status.normal THEN
        IF (NOT network_application_management) THEN
          osp$set_status_abnormal (nac$status_id, nae$insufficient_privilege, 'nlp$delete_registered_titles',
                status);
          RETURN;
        IFEND;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    title_length := STRLENGTH (title);
    WHILE (title_length > 1) AND (title (title_length) = ' ') DO
      title_length := title_length - 1;
    WHILEND;

    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    osp$establish_block_exit_hndlr (^exit_condition_handler);
    osp$set_job_signature_lock (nlv$directory_lock);

    find_title (title (1, title_length), identifier, nav$registered_titles.first, translation);
    IF translation <> NIL THEN
      IF password = translation^.password THEN
        IF translation^.distribute THEN
          distribute_delete_translation (translation);
        IFEND;
        delete_translation (translation, nav$registered_titles.first);
        IF nav$statistics_enabled AND (nav$global_statistics.directory.current_registered_titles > 0) THEN
          nav$global_statistics.directory.current_registered_titles :=
                nav$global_statistics.directory.current_registered_titles - 1;
        IFEND;
      ELSE
        osp$set_status_condition (nae$incorrect_password, status);
      IFEND;
    ELSE
      osp$set_status_condition (nae$title_id_not_found, status);
    IFEND;

    osp$clear_job_signature_lock (nlv$directory_lock);
    osp$end_subsystem_activity;
    osp$disestablish_cond_handler;
    osp$pop_inhibit_job_recovery;

  PROCEND nlp$delete_registered_title;
?? OLDTITLE ??
?? NEWTITLE := 'nlp$translate_title', EJECT ??

  PROCEDURE [#GATE, XDCL] nlp$translate_title
    (    title: string ( * <= nac$max_title_length);
         wild_card: boolean;
         protocol: nat$protocol;
         recurrent_search: boolean;
         search_domain: nat$title_domain;
         class: nat$title_class;
     VAR request_id: nat$directory_search_identifier;
     VAR status: ost$status);

*copy nlh$translate_title

    VAR
      actual: integer,
      duplicate_id: ^nat$translation_request,
      local_translation_found: boolean,
      title_length: nat$title_length,
      translation: ^nat$translation,
      request: ^nat$translation_request;

    IF nav$statistics_enabled THEN
      osp$increment_locked_variable (nav$global_statistics.directory.directory_searches_initiated, 0, actual);
    IFEND;

    IF NOT nav$namve_active THEN
      osp$set_status_condition (nae$network_inactive, status);
      RETURN;
    IFEND;

{ Validate request parameters.

    title_length := STRLENGTH (title);
    WHILE (title_length > 1) AND (title (title_length) = ' ') DO
      title_length := title_length - 1;
    WHILEND;
    IF title_length = 0 THEN
      osp$set_status_abnormal (nac$status_id, nae$title_too_short, 'NLP$TRANSLATE_TITLE', status);
      RETURN;
    IFEND;

{ Create a translation request entry.

    ALLOCATE request: [title_length] IN nav$network_paged_heap^;
    IF request = NIL THEN
      osp$set_status_abnormal (nac$status_id, nae$insufficient_resources, 'translation request', status);
      RETURN;
    IFEND;
    request^.title := title;
    request^.wild_card := wild_card;
    request^.protocol := protocol;
    request^.class := class;
    request^.recurrent_search := recurrent_search;
    request^.domain.kind := search_domain.kind;
    request^.time_stamp := #FREE_RUNNING_CLOCK (0) + nac$max_request_hold_time;
    request^.search_required := search_domain.kind > nac$local_system_domain;
    IF search_domain.kind > nac$local_system_domain THEN
      request^.broadcast_counter := 0;
    ELSE
      request^.broadcast_counter := nac$max_request_broadcast_count;
    IFEND;
    pmp$get_executing_task_gtid (request^.requestor);
    request^.first_translation := NIL;

{ Look for local registrations that satisfy this request.

    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    osp$establish_block_exit_hndlr (^exit_condition_handler);
    osp$set_job_signature_lock (nlv$directory_lock);
    REPEAT { Assign a unique identifier
      assign_directory_identifier (request^.identifier); { Must be done with directory lock set
      request_id := request^.identifier;
      find_request (request_id, duplicate_id);
    UNTIL duplicate_id = NIL;
    local_translation_found := FALSE;
    translation := nav$registered_titles.first;

    WHILE translation <> NIL DO
      IF valid_translation (translation, request) THEN
        IF (translation^.osi_address_kind = translation_address) THEN
          save_valid_translation (translation, request);
        ELSE
          local_translation_found := TRUE;
          save_local_translation (translation, request);
        IFEND;
        IF nav$statistics_enabled THEN
          nav$global_statistics.directory.translations_found_in_local_dir :=
                nav$global_statistics.directory.translations_found_in_local_dir + 1;
        IFEND;
        IF translation^.priority = nac$max_directory_priority THEN

{ Search of network is always performed for wild card or recurrent search requests with catenet domain.
{ Search may be delayed if a maximum priority translation is found locally for any other request.

          request^.search_required := (wild_card OR recurrent_search) AND
                (request^.domain.kind > nac$local_system_domain);
        IFEND;
      IFEND;
      translation := translation^.link;
    WHILEND;

{ If a local translation was found but no translation was recorded, no device is active. The list will have
{ to be rescanned later on the chance that a device becomes available.

    request^.repeat_local_search := local_translation_found AND (request^.first_translation = NIL);

{ Look for translation cache entries that satisfy this request.

    IF request^.domain.kind > nac$local_system_domain THEN
      translation := nav$translation_cache.first;

      WHILE translation <> NIL DO
        IF valid_translation (translation, request) THEN
          save_valid_translation (translation, request);
          IF nav$statistics_enabled THEN
            nav$global_statistics.directory.translations_found_in_cache :=
                  nav$global_statistics.directory.translations_found_in_cache + 1;
          IFEND;
          IF translation^.priority = nac$max_directory_priority THEN

{ Search of network is always performed for wild card or recurrent search requests.
{ Search may be delayed if a maximum priority translation is found locally for any other request.

            request^.search_required := wild_card OR recurrent_search;
          IFEND;
        IFEND;
        translation := translation^.link;
      WHILEND;
    IFEND;

{ Add this request to the list of outstanding translation requests.

    add_request (request, nav$translation_requests);

{ A translation request will be broadcast immediately if no maximum priority
{ translations are found locally, if a wild card search is requested,
{ or if a recurrent search is requested.
{ The assumption is that a wild card search or recurrent search will want to
{ receive all available translations, while the normal request will only want
{ one translation. If more translations are requested and the translation request
{ has not been broadcast, then it will be broadcast at that time.

    IF request^.search_required THEN
      distribute_translation_request (request);
    IFEND;

    IF request^.time_stamp < nav$translation_requests.next_broadcast_time THEN
      nav$translation_requests.next_broadcast_time := request^.time_stamp;
    IFEND;

    osp$clear_job_signature_lock (nlv$directory_lock);
    osp$end_subsystem_activity;
    osp$disestablish_cond_handler;
    osp$pop_inhibit_job_recovery;

  PROCEND nlp$translate_title;
?? OLDTITLE ??
?? NEWTITLE := 'nap$check_title_translation', EJECT ??

  PROCEDURE [XDCL] nap$check_title_translation
    (    translation_request: nat$directory_search_identifier;
     VAR activity_complete: boolean;
     VAR status: ost$status);

    VAR
      current_time: integer,
      local_translation_found: boolean,
      request: ^nat$translation_request,
      translation: ^nat$translation;

    status.normal := TRUE;
    activity_complete := FALSE;
    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    osp$establish_block_exit_hndlr (^exit_condition_handler);
    osp$set_job_signature_lock (nlv$directory_lock);

    find_request (translation_request, request);
    IF request <> NIL THEN
      current_time := #FREE_RUNNING_CLOCK (0);
      IF request^.recurrent_search AND (request^.broadcast_counter >= nac$max_request_broadcast_count) THEN

{update time of last inquiry

        request^.time_stamp := current_time + nac$max_request_hold_time;
      IFEND;

      IF request^.repeat_local_search THEN
        local_translation_found := FALSE;
        translation := nav$registered_titles.first;

        WHILE translation <> NIL DO
          IF valid_translation (translation, request) THEN
            IF (translation^.osi_address_kind = registration_address) THEN
              local_translation_found := TRUE;
              save_local_translation (translation, request);
            IFEND;
          IFEND;
          translation := translation^.link;
        WHILEND;

{ If a local translation was found but no translation was recorded, no device is active. The list will have
{ to be rescanned later on the chance that a device becomes available.

        request^.repeat_local_search := local_translation_found AND (request^.first_translation = NIL);
      IFEND;

      translation := request^.first_translation;
      activity_complete := (request^.broadcast_counter >= nac$max_request_broadcast_count) AND
            (request^.time_stamp <= current_time);

      WHILE (translation <> NIL) AND (NOT activity_complete) DO
        activity_complete := (NOT translation^.reported) AND
              ((translation^.priority = nac$max_directory_priority) OR
              (request^.broadcast_counter >= nac$max_request_broadcast_count));
        translation := translation^.link;
      WHILEND;
      IF (NOT activity_complete) AND (NOT request^.search_required) AND
            (request^.domain.kind > nac$local_system_domain) THEN {search now required}
        request^.search_required := TRUE;
        distribute_translation_request (request);
        IF request^.time_stamp < nav$translation_requests.next_broadcast_time THEN
          nav$translation_requests.next_broadcast_time := request^.time_stamp;
        IFEND;
      IFEND;
    ELSE
      activity_complete := TRUE;
    IFEND;

    osp$clear_job_signature_lock (nlv$directory_lock);
    osp$end_subsystem_activity;
    osp$disestablish_cond_handler;
    osp$pop_inhibit_job_recovery;

  PROCEND nap$check_title_translation;
?? OLDTITLE ??
?? NEWTITLE := 'nlp$get_title_translation', EJECT ??

  PROCEDURE [#GATE, XDCL] nlp$get_title_translation
    (    request_id: nat$directory_search_identifier;
     VAR title: nat$title;
     VAR address: nat$osi_translation_address;
     VAR protocol: nat$protocol;
         user_information: ^cell;
     VAR user_info_length: 0 .. nac$max_directory_data_length;
     VAR priority: nat$directory_priority;
     VAR user_identifier: ost$name;
     VAR identifier: nat$directory_entry_identifier;
     VAR status: ost$status);

*copy nlh$get_title_translation

    VAR
      best_translation: ^nat$translation,
      current_time: integer,
      local_translation_found: boolean,
      network_address: ^SEQ ( * ),
      network_selector: ^nat$network_selector,
      nsap_address: ^SEQ ( * ),
      nsap_address_size: ^nat$osi_network_address_length,
      osi_address: ^SEQ ( * ),
      osi_address_kind: ^nat$translation_address_kind,
      osi_address_length: ^nat$osi_address_length,
      request: ^nat$translation_request,
      presentation_selector: ^string ( * ),
      presentation_selector_length: ^nat$osi_psap_selector_length,
      session_selector: ^string ( * ),
      session_selector_length: ^nat$osi_ssap_selector_length,
      translation: ^nat$translation,
      transport_selector: ^string ( * ),
      transport_selector_length: ^nat$osi_tsap_selector_length;


    status.normal := TRUE;

    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    osp$establish_block_exit_hndlr (^exit_condition_handler);
    osp$set_job_signature_lock (nlv$directory_lock);

    find_request (request_id, request);
    IF request <> NIL THEN
      IF request^.recurrent_search AND (request^.broadcast_counter >= nac$max_request_broadcast_count) THEN

{update time of last inquiry

        request^.time_stamp := #FREE_RUNNING_CLOCK (0) + nac$max_request_hold_time;
      IFEND;

      IF request^.repeat_local_search THEN
        local_translation_found := FALSE;
        translation := nav$registered_titles.first;

        WHILE translation <> NIL DO
          IF valid_translation (translation, request) THEN
            IF (translation^.osi_address_kind = registration_address) THEN
              local_translation_found := TRUE;
              save_local_translation (translation, request);
            IFEND;
          IFEND;
          translation := translation^.link;
        WHILEND;

{ If a local translation was found but no translation was recorded, no device is active. The list will have
{ to be rescanned later on the chance that a device becomes available.

        request^.repeat_local_search := local_translation_found AND (request^.first_translation = NIL);
      IFEND;

      translation := request^.first_translation;
      best_translation := NIL;

{     NOTE: The first translation received is the last one in the list ... return them in order received.

    /search_for_best/
      WHILE translation <> NIL DO
        IF NOT translation^.reported THEN
          IF (best_translation = NIL) OR (translation^.priority <= best_translation^.priority) THEN
            best_translation := translation;
          IFEND;
        IFEND;
        translation := translation^.link;
      WHILEND /search_for_best/;

{ A non-maximum priority translation cannot be returned until the network search is completed, since
{ translations are returned in priority order and a higher priority translation may be found later.

      IF (best_translation <> NIL) AND ((best_translation^.priority = nac$max_directory_priority) OR
            (request^.broadcast_counter >= nac$max_request_broadcast_count)) THEN
        title := best_translation^.title^;
        osi_address := best_translation^.osi_address;
        RESET osi_address;
        NEXT osi_address_kind IN osi_address;
        address.kind := osi_address_kind^;
        NEXT osi_address_length IN osi_address;
        CASE osi_address_kind^ OF
        = nac$osi_transport_address =
          NEXT transport_selector_length IN osi_address;
          address.osi_transport_address.transport_sap_selector_length := transport_selector_length^;
          NEXT transport_selector: [transport_selector_length^] IN osi_address;
          address.osi_transport_address.transport_sap_selector := transport_selector^;
          NEXT nsap_address_size IN osi_address;
          address.osi_transport_address.network_address_length := nsap_address_size^;
          NEXT nsap_address: [[REP nsap_address_size^ OF cell]] IN osi_address;
          i#move (nsap_address, ^address.osi_transport_address.network_address, nsap_address_size^);

        = nac$osi_session_address, nac$osi_non_cdna_session_addr =
          NEXT session_selector_length IN osi_address;
          address.osi_session_address.session_selector_length := session_selector_length^;
          NEXT session_selector: [session_selector_length^] IN osi_address;
          address.osi_session_address.session_selector := session_selector^;
          NEXT transport_selector_length IN osi_address;
          address.osi_session_address.transport_selector_length := transport_selector_length^;
          NEXT transport_selector: [transport_selector_length^] IN osi_address;
          address.osi_session_address.transport_selector := transport_selector^;
          NEXT nsap_address_size IN osi_address;
          address.osi_session_address.network_address_length := nsap_address_size^;
          NEXT nsap_address: [[REP nsap_address_size^ OF cell]] IN osi_address;
          i#move (nsap_address, ^address.osi_session_address.network_address, nsap_address_size^);

        = nac$osi_presentation_address, nac$osi_non_cdna_present_addr =
          NEXT presentation_selector_length IN osi_address;
          address.osi_presentation_address.presentation_selector_length := presentation_selector_length^;
          NEXT presentation_selector: [presentation_selector_length^] IN osi_address;
          address.osi_presentation_address.presentation_selector := presentation_selector^;
          NEXT session_selector_length IN osi_address;
          address.osi_presentation_address.session_selector_length := session_selector_length^;
          NEXT session_selector: [session_selector_length^] IN osi_address;
          address.osi_presentation_address.session_selector := session_selector^;
          NEXT transport_selector_length IN osi_address;
          address.osi_presentation_address.transport_selector_length := transport_selector_length^;
          NEXT transport_selector: [transport_selector_length^] IN osi_address;
          address.osi_presentation_address.transport_selector := transport_selector^;
          NEXT nsap_address_size IN osi_address;
          address.osi_presentation_address.network_address_length := nsap_address_size^;
          NEXT nsap_address: [[REP nsap_address_size^ OF cell]] IN osi_address;
          i#move (nsap_address, ^address.osi_presentation_address.network_address, nsap_address_size^);
        ELSE
        CASEND;

        protocol := best_translation^.protocol;
        IF best_translation^.user_information <> NIL THEN
          user_info_length := STRLENGTH (best_translation^.user_information^);
          IF user_information <> NIL THEN
            i#move (best_translation^.user_information, user_information, user_info_length);
          IFEND;
        ELSE
          user_info_length := 0;
        IFEND;
        priority := best_translation^.priority;
        identifier := best_translation^.identifier;
        user_identifier := best_translation^.user_identifier;
        best_translation^.reported := TRUE;
        IF nav$statistics_enabled THEN
          nav$global_statistics.directory.translations_delivered :=
                nav$global_statistics.directory.translations_delivered + 1;
        IFEND;
      ELSE {no translations to deliver}
        osp$set_status_condition (nae$no_translation_available, status);
        current_time := #FREE_RUNNING_CLOCK (0);
        IF (NOT request^.search_required) AND (request^.domain.kind > nac$local_system_domain) THEN
              {search now required}
          request^.search_required := TRUE;
          distribute_translation_request (request);
          IF request^.time_stamp < nav$translation_requests.next_broadcast_time THEN
            nav$translation_requests.next_broadcast_time := request^.time_stamp;
          IFEND;
        ELSEIF (request^.broadcast_counter >= nac$max_request_broadcast_count) AND
              (request^.time_stamp <= current_time) THEN
          IF request^.recurrent_search THEN
            request^.time_stamp := current_time + nac$max_request_hold_time;
            osp$set_status_condition (nae$wait_for_distributed_title, status);
          ELSE
            delete_request (request);
            osp$set_status_condition (nae$directory_search_complete, status);
          IFEND;
        ELSEIF request^.domain.kind = nac$local_system_domain THEN {prepare request for auto deletion}
          request^.broadcast_counter := nac$max_request_broadcast_count;
          request^.time_stamp := current_time;
        IFEND;
      IFEND;
    ELSE
      osp$set_status_condition (nae$translation_req_not_active, status);
    IFEND;

    osp$clear_job_signature_lock (nlv$directory_lock);
    osp$end_subsystem_activity;
    osp$disestablish_cond_handler;
    osp$pop_inhibit_job_recovery;

  PROCEND nlp$get_title_translation;
?? OLDTITLE ??
?? NEWTITLE := 'nlp$end_title_translation', EJECT ??

  PROCEDURE [#GATE, XDCL] nlp$end_title_translation
    (    request_id: nat$directory_search_identifier;
     VAR status: ost$status);

*copy nlh$end_title_translation

    VAR
      translation_request: ^nat$translation_request;

    status.normal := TRUE;

    osp$push_inhibit_job_recovery;
    osp$begin_subsystem_activity;
    osp$establish_block_exit_hndlr (^exit_condition_handler);
    osp$set_job_signature_lock (nlv$directory_lock);

    find_request (request_id, translation_request);
    IF translation_request <> NIL THEN
      delete_request (translation_request);
    ELSE
      osp$set_status_condition (nae$translation_req_not_active, status);
    IFEND;

    osp$clear_job_signature_lock (nlv$directory_lock);
    osp$end_subsystem_activity;
    osp$disestablish_cond_handler;
    osp$pop_inhibit_job_recovery;

  PROCEND nlp$end_title_translation;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'Miscellaneous utility routines' ??
?? NEWTITLE := 'add_request', EJECT ??

  PROCEDURE [INLINE] add_request
    (    request: ^nat$translation_request;
     VAR translation_request_list: nat$translation_request_list);

{     PURPOSE:
{       This  routine is called by directory routines to add an
{       entry to a list of requests.

    request^.link := translation_request_list.first;
    translation_request_list.first := request;
    IF nav$statistics_enabled THEN
      nav$global_statistics.directory.directory_searches_active :=
            nav$global_statistics.directory.directory_searches_active + 1;
    IFEND;

  PROCEND add_request;
?? OLDTITLE ??
?? NEWTITLE := 'add_translation', EJECT ??

  PROCEDURE [INLINE] add_translation
    (    translation: ^nat$translation;
     VAR first_translation: ^nat$translation);

{     PURPOSE:
{       This  routine is called by directory routines to add an
{       entry to a list of translations.

    translation^.link := first_translation;
    first_translation := translation;

  PROCEND add_translation;
?? OLDTITLE ??
?? NEWTITLE := 'assign_directory_identifier', EJECT ??

  PROCEDURE assign_directory_identifier
    (VAR identifier: nat$directory_entry_identifier);

{ PURPOSE: Assign a unique directory identifier value.
{          NOTE: The directory lock must be set by the caller to guarantee uniqueness.

    VAR
      date_time: ost$date_time,
      ignore_status: ost$status;

    identifier.system.network := nap$user_network_id ();
    identifier.system.system := nap$system_id ();

    pmp$get_compact_date_time (date_time, ignore_status);

    identifier.time_stamp.date.year1 := (date_time.year MOD 100) DIV 10;
    identifier.time_stamp.date.year2 := date_time.year MOD 10;
    identifier.time_stamp.date.month1 := date_time.month DIV 10;
    identifier.time_stamp.date.month2 := date_time.month MOD 10;
    identifier.time_stamp.date.day1 := date_time.day DIV 10;
    identifier.time_stamp.date.day2 := date_time.day MOD 10;
    identifier.time_stamp.time.hours1 := date_time.hour DIV 10;
    identifier.time_stamp.time.hours2 := date_time.hour MOD 10;
    identifier.time_stamp.time.minutes1 := date_time.minute DIV 10;
    identifier.time_stamp.time.minutes2 := date_time.minute MOD 10;
    identifier.time_stamp.time.seconds1 := date_time.second DIV 10;
    identifier.time_stamp.time.seconds2 := date_time.second MOD 10;
    identifier.time_stamp.time.milliseconds1 := date_time.millisecond DIV 100;
    identifier.time_stamp.time.milliseconds2 := (date_time.millisecond MOD 100) DIV 10;
    identifier.time_stamp.time.milliseconds3 := date_time.millisecond MOD 10;
    nlv$directory_id_seq_number := (nlv$directory_id_seq_number + 1) MOD 10;
    identifier.time_stamp.time.fill := nlv$directory_id_seq_number;

  PROCEND assign_directory_identifier;
?? OLDTITLE ??
?? NEWTITLE := 'delete_request', EJECT ??

  PROCEDURE delete_request
    (VAR request: ^nat$translation_request);

{     PURPOSE:
{       This  routine  is  called  by the directory routines to
{       locate an existing translation request and remove it from
{       the table.

    VAR
      link: ^^nat$translation_request,
      next_translation: ^nat$translation,
      translation: ^nat$translation;

    translation := request^.first_translation;
    WHILE translation <> NIL DO
      next_translation := translation^.link;
      FREE translation IN nav$network_paged_heap^;
      translation := next_translation;
    WHILEND;

    link := ^nav$translation_requests.first;
    WHILE link^ <> NIL DO
      IF link^ = request THEN
        link^ := request^.link;
        FREE request IN nav$network_paged_heap^;
        IF nav$statistics_enabled AND (nav$global_statistics.directory.directory_searches_active > 0) THEN
          nav$global_statistics.directory.directory_searches_active :=
                nav$global_statistics.directory.directory_searches_active - 1;
        IFEND;
        RETURN;
      IFEND;
      link := ^link^^.link;
    WHILEND;

  PROCEND delete_request;
?? OLDTITLE ??
?? NEWTITLE := 'delete_translation', EJECT ??

  PROCEDURE [INLINE]delete_translation
    (VAR translation: ^nat$translation;
     VAR first_translation: ^nat$translation);

{     PURPOSE:
{       This  routine  is  called  by the directory routines to
{       locate an existing translation and remove it from
{       the table.

    VAR
      link: ^^nat$translation;

    link := ^first_translation;
    WHILE link^ <> NIL DO
      IF link^ = translation THEN
        link^ := translation^.link;
        FREE translation IN nav$network_paged_heap^;
        RETURN;
      IFEND;
      link := ^link^^.link;
    WHILEND;

  PROCEND delete_translation;
?? OLDTITLE ??
?? NEWTITLE := 'distribute_delete_translation', EJECT ??

  PROCEDURE distribute_delete_translation
    (    translation: ^nat$translation);

{     PURPOSE:
{       This  routine  is  called  by the directory routines to send out a delete translation data unit.

    VAR
      delete_translation: delete_translation_pdu,
      delete_translation_v3: delete_translation_pdu_v3,
      device_id: nlt$device_identifier,
      network_device_list: ^nlt$network_device_list,
      pdu: array [1 .. 2] of nat$data_fragment,
      sequence_number: integer,
      status: ost$status;

    IF nlv$directory_version = nac$osi_directory_version THEN
      delete_translation.id := nac$del_translation_data_unit;
      delete_translation.version := nac$osi_directory_version;
      delete_translation.identifier := translation^.identifier;
      delete_translation.title_size := STRLENGTH (translation^.title^);

      pdu [1].address := ^delete_translation;
      pdu [1].length := #SIZE (delete_translation);
      pdu [2].address := translation^.title;
      pdu [2].length := delete_translation.title_size;

      network_device_list := nlv$configured_network_devices.network_device_list;
      FOR device_id := LOWERBOUND (network_device_list^) TO UPPERBOUND (network_device_list^) DO
        nlp$na_broadcast_data (device_id, nac$xi_cdna_directory_sap, nac$xi_cdna_directory_sap, pdu, status);
      FOREND;
    ELSE {nac$directory_version_3
      delete_translation_v3.id := nac$v3_dl_translation_data_unit;
      delete_translation_v3.version := nac$directory_version_3;
      delete_translation_v3.lifetime := nac$initial_pdu_lifetime;
      delete_translation_v3.identifier := translation^.identifier;
      delete_translation_v3.title_size := STRLENGTH (translation^.title^);
      get_pdu_sequence_number (sequence_number);
      delete_translation_v3.sequence := sequence_number;

      pdu [1].address := ^delete_translation_v3;
      pdu [1].length := #SIZE (delete_translation_v3);
      pdu [2].address := translation^.title;
      pdu [2].length := delete_translation_v3.title_size;

      network_device_list := nlv$configured_network_devices.network_device_list;
      nlp$get_nonexclusive_access (nlv$sm_devices.access_control);
      FOR device_id := LOWERBOUND (network_device_list^) TO UPPERBOUND (network_device_list^) DO
        send_distributed_pdu (device_id, pdu);
      FOREND;
      nlp$release_nonexclusive_access (nlv$sm_devices.access_control);
    IFEND;
  PROCEND distribute_delete_translation;
?? OLDTITLE ??
?? NEWTITLE := 'distribute_translation', EJECT ??

  PROCEDURE distribute_translation
    (    translation: ^nat$translation);

{     PURPOSE:
{       This  routine  is  called  by the directory routines to send out a translation data unit.

    VAR
      device_id: nlt$device_identifier,
      ignore_status: ost$status,
      network_device_list: ^nlt$network_device_list,
      osi_address: SEQ (REP nac$max_osi_address_length of cell),
      pdu: array [1 .. 4] of nat$data_fragment,
      translation_pdu_header: translation_pdu,
      translation_pdu_header_v3: translation_pdu_v3,
      work_space: ^SEQ ( * );

{ A data unit is generated for every active network device, then broadcast over that device.

    IF nlv$directory_version = nac$osi_directory_version THEN
      network_device_list := nlv$configured_network_devices.network_device_list;
      FOR device_id := LOWERBOUND (network_device_list^) TO UPPERBOUND (network_device_list^) DO
        work_space := ^osi_address;
        generate_translation_data_unit (translation, device_id, distribution, work_space,
              translation_pdu_header, pdu);
        IF work_space <> NIL THEN
          nlp$na_broadcast_data (device_id, nac$xi_cdna_directory_sap, nac$xi_cdna_directory_sap, pdu,
                ignore_status);
        IFEND;
      FOREND;
    ELSE {nac$directory_version_3
      network_device_list := nlv$configured_network_devices.network_device_list;
      FOR device_id := LOWERBOUND (network_device_list^) TO UPPERBOUND (network_device_list^) DO
        work_space := ^osi_address;
        generate_v3_trans_data_unit (translation, device_id, distribution, work_space,
              translation_pdu_header_v3, pdu);
        IF work_space <> NIL THEN
          nlp$get_nonexclusive_access (nlv$sm_devices.access_control);
          send_distributed_pdu (device_id, pdu);
          nlp$release_nonexclusive_access (nlv$sm_devices.access_control);
        IFEND;
      FOREND;
    IFEND;

    IF translation^.broadcast_counter < nac$title_distribution_count THEN
      translation^.broadcast_counter := translation^.broadcast_counter + 1;
      translation^.time_stamp := #FREE_RUNNING_CLOCK (0) + nac$title_distribution_delay;
    ELSE
      translation^.time_stamp := #FREE_RUNNING_CLOCK (0) + nac$title_redistribute_delay;
    IFEND;
    IF nav$statistics_enabled THEN
      nav$global_statistics.directory.translations_broadcast :=
            nav$global_statistics.directory.translations_broadcast + 1;
    IFEND;

  PROCEND distribute_translation;
?? OLDTITLE ??
?? NEWTITLE := 'distribute_translation_request', EJECT ??

  PROCEDURE distribute_translation_request
    (    request: ^nat$translation_request);

{     PURPOSE:
{       This  routine  is  called  by the directory routines to send out a translation request data unit.

    VAR
      device_id: nlt$device_identifier,
      ignore_status: ost$status,
      network_device_list: ^nlt$network_device_list,
      network_selector: nat$network_selector,
      pdu: array [1 .. 4] of nat$data_fragment,
      request_data_unit: translation_request_pdu,
      request_data_unit_v3: translation_request_pdu_v3,
      sequence_number: integer;

    IF nlv$directory_version = nac$osi_directory_version THEN
      request_data_unit.id := nac$translation_req_data_unit;
      request_data_unit.version := nac$osi_directory_version;
      request_data_unit.title_size := STRLENGTH (request^.title);
      request_data_unit.protocol := request^.protocol;
      request_data_unit.info.wild_card := request^.wild_card;
      request_data_unit.info.class := request^.class;

      pdu [1].address := ^request_data_unit;
      pdu [1].length := #SIZE (request_data_unit);
      request_data_unit.community_count := 0;
      pdu [2].address := ^request^.title;
      pdu [2].length := request_data_unit.title_size;
      pdu [3].address := NIL;
      pdu [3].length := 0;
      pdu [4].address := NIL;
      pdu [4].length := 0;

      network_device_list := nlv$configured_network_devices.network_device_list;
      FOR device_id := LOWERBOUND (network_device_list^) TO UPPERBOUND (network_device_list^) DO
        nlp$na_broadcast_data (device_id, nac$xi_cdna_directory_sap, nac$xi_cdna_directory_sap, pdu,
              ignore_status);
      FOREND;
    ELSE {nac$directory_version_3
      request_data_unit_v3.id := nac$v3_translation_rq_data_unit;
      request_data_unit_v3.version := nac$directory_version_3;
      request_data_unit_v3.lifetime := nac$initial_pdu_lifetime;
      request_data_unit_v3.title_size := STRLENGTH (request^.title);
      request_data_unit_v3.protocol := request^.protocol;
      request_data_unit_v3.info.wild_card := request^.wild_card;
      request_data_unit_v3.info.class := request^.class;
      get_pdu_sequence_number (sequence_number);
      request_data_unit_v3.sequence := sequence_number;

      pdu [1].address := ^request_data_unit_v3;
      pdu [1].length := #SIZE (request_data_unit_v3);
      pdu [2].address := ^request^.title;
      pdu [2].length := request_data_unit_v3.title_size;
      pdu [4].address := ^network_selector;
      pdu [4].length := #SIZE (nat$network_selector);
      network_selector := nac$xi_cdna_directory_sap;

      nlp$get_nonexclusive_access (nlv$sm_devices.access_control);
      FOR device_id := LOWERBOUND (nlv$sm_devices.list^) TO UPPERBOUND (nlv$sm_devices.list^) DO
        pdu [3].address := ^nlv$sm_devices.list^ [device_id].generic_host_address;
        pdu [3].length := nlv$sm_devices.list^ [device_id].network_address_length
              - #SIZE (nat$network_selector);
        request_data_unit_v3.source_nsap_length := nlv$sm_devices.list^ [device_id].network_address_length;
        send_distributed_pdu (device_id, pdu);
      FOREND;
      nlp$release_nonexclusive_access (nlv$sm_devices.access_control);
    IFEND;

    request^.broadcast_counter := request^.broadcast_counter + 1;
    request^.time_stamp := #FREE_RUNNING_CLOCK (0) + nac$translation_request_delay;

    IF nav$statistics_enabled THEN
      nav$global_statistics.directory.translation_requests_broadcast :=
            nav$global_statistics.directory.translation_requests_broadcast + 1;
    IFEND;

  PROCEND distribute_translation_request;
?? OLDTITLE ??
?? NEWTITLE := '  exit_condition_handler', EJECT ??

    PROCEDURE exit_condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status,
        lock_status: ost$signature_lock_status;

      handler_status.normal := TRUE;
      local_status.normal := TRUE;
      osp$test_signature_lock (nlv$directory_lock, lock_status, local_status);
      IF local_status.normal AND (lock_status = osc$sls_locked_by_current_task) THEN
        osp$clear_job_signature_lock (nlv$directory_lock);
      IFEND;
      osp$end_subsystem_activity;
      osp$pop_inhibit_job_recovery;

    PROCEND exit_condition_handler;
?? NEWTITLE := 'find_request', EJECT ??

  PROCEDURE [INLINE] find_request
    (    request_id: nat$directory_search_identifier;
     VAR request: ^nat$translation_request);

{     PURPOSE:
{       This procedure locates a translation request in a list with a given
{       user identifier.

    request := nav$translation_requests.first;
    WHILE (request <> NIL) AND (request^.identifier <> request_id) DO
      request := request^.link;
    WHILEND;

  PROCEND find_request;
?? OLDTITLE ??
?? NEWTITLE := 'find_title', EJECT ??

  PROCEDURE [INLINE] find_title
    (    title: string ( * <= nac$max_title_length);
         identifier: nat$directory_entry_identifier;
         first_translation: ^nat$translation;
     VAR translation: ^nat$translation);

{     PURPOSE:
{       This procedure locates a translation in a list with a given
{       title and identifier.

    translation := first_translation;
    WHILE (translation <> NIL) AND ((translation^.title^ <> title) OR (translation^.identifier <> identifier))
          DO
      translation := translation^.link;
    WHILEND;

  PROCEND find_title;
?? OLDTITLE ??
?? NEWTITLE := 'find_title_address', EJECT ??

  PROCEDURE [INLINE] find_title_address
    (    title: string ( * <= nac$max_title_length);
         osi_address: nat$osi_registration_address;
         first_translation: ^nat$translation;
     VAR translation: ^nat$translation);

{     PURPOSE:
{       This procedure locates a translation in a list with a given title and address.

    translation := first_translation;
    WHILE (translation <> NIL) AND ((translation^.title^ <> title) OR NOT same_address
          (translation^.registered_address, osi_address)) DO
      translation := translation^.link;
    WHILEND;

  PROCEND find_title_address;
?? OLDTITLE ??
?? NEWTITLE := 'generate_osi_address', EJECT ??

  PROCEDURE generate_osi_address
    (    translation: ^nat$translation;
         osi_device: nlt$device_identifier;
     VAR osi_address: ^SEQ ( * );
     VAR osi_address_length: nat$osi_address_length);

{     PURPOSE:
{       This procedure generates an OSI address given a translation entry and an OSI device.

    TYPE
      osi_address_header = record
        kind: nat$network_address_kind,
        length: nat$osi_address_length,
      recend,

      osi_presentation_selector = record
        length: nat$osi_psap_selector_length,
        value: nat$osi_presentation_selector,
      recend,

      osi_session_selector = record
        length: nat$osi_ssap_selector_length,
        value: nat$osi_session_selector,
      recend,

      osi_transport_address = record
        tsap_length: nat$osi_tsap_selector_length,
        tsap: nlt$ta_sap_selector,
        network_address_length: nat$osi_network_address_length,
        network_address: nat$osi_network_address,
      recend;

    VAR
      address_header: ^osi_address_header,
      device_attributes: ^nlt$system_management,
      i: integer,
      network_address: ^SEQ ( * ),
      network_address_prefix: ^nat$osi_network_address_prefix,
      network_selector: ^nat$network_selector,
      psap_selector: ^osi_presentation_selector,
      psap_selector_length: nat$osi_psap_selector_length,
      ssap_selector: ^osi_session_selector,
      ssap_selector_length: nat$osi_ssap_selector_length,
      subnet_identifier: ^nat$subnet_identifier,
      system_identifier: ^nat$system_identifier,
      transport_address: ^osi_transport_address,
      unused_byte_count: integer,
      unused_space: ^array [1 .. * ] of 0 .. 0ff(16);

    RESET osi_address;
    nlp$get_nonexclusive_access (nlv$sm_devices.access_control);
    device_attributes := ^nlv$sm_devices.list^ [osi_device];
    IF (device_attributes^.network_address_length > 0) AND
          (device_attributes^.network_address_prefix <> NIL) THEN
      NEXT address_header IN osi_address;
      address_header^.kind := translation^.registered_address.kind;
      address_header^.length := 0;
      IF address_header^.kind = nac$osi_presentation_address THEN
        psap_selector_length := translation^.registered_address.presentation_selector_length;
        NEXT psap_selector: [psap_selector_length] IN osi_address;
        address_header^.length := address_header^.length + #SIZE (psap_selector^);
        psap_selector^.length := psap_selector_length;
        psap_selector^.value := translation^.registered_address.presentation_selector;
      IFEND;
      IF (address_header^.kind = nac$osi_presentation_address) OR
            (address_header^.kind = nac$osi_session_address) THEN
        ssap_selector_length := translation^.registered_address.session_selector_length;
        NEXT ssap_selector: [ssap_selector_length] IN osi_address;
        address_header^.length := address_header^.length + #SIZE (ssap_selector^);
        ssap_selector^.length := ssap_selector_length;
        ssap_selector^.value := translation^.registered_address.session_selector;
      IFEND;

      NEXT transport_address: [[REP device_attributes^.network_address_length OF cell]] IN osi_address;
      address_header^.length := address_header^.length + #SIZE (transport_address^);
      transport_address^.tsap_length := #SIZE (nlt$ta_sap_selector);
      transport_address^.tsap := translation^.registered_address.transport_selector;
      transport_address^.network_address_length := device_attributes^.network_address_length;
      i#move (^device_attributes^.generic_host_address, ^transport_address^.network_address,
            device_attributes^.network_address_length);
      osi_address_length := address_header^.length + #SIZE (address_header^);
    ELSE { OSI stack not configured in the device
      osi_address := NIL;
    IFEND;
    nlp$release_nonexclusive_access (nlv$sm_devices.access_control);

  PROCEND generate_osi_address;
?? OLDTITLE ??
?? NEWTITLE := 'generate_translation_data_unit', EJECT ??

  PROCEDURE generate_translation_data_unit
    (    translation: ^nat$translation;
         osi_device: nlt$device_identifier;
         reason: generate_reason;
     VAR osi_address: ^SEQ ( * );
     VAR data_unit_header: translation_pdu;
     VAR translation_data_unit: array [1 .. 4] of nat$data_fragment);

{     PURPOSE:
{       This procedure generates a translation data unit given a translation entry.

    VAR
      osi_address_length: nat$osi_address_length;

    data_unit_header.id := nac$translation_data_unit;
    data_unit_header.version := nac$osi_directory_version;
    data_unit_header.identifier := translation^.identifier;
    data_unit_header.change_count := translation^.change_count;
    data_unit_header.address.kind := translation^.registered_address.kind;
    data_unit_header.title_size := STRLENGTH (translation^.title^);
    data_unit_header.protocol := translation^.protocol;
    data_unit_header.priority := translation^.priority;
    data_unit_header.info.class := translation^.class;
    data_unit_header.info.response := reason = response;
    data_unit_header.community_count := 0;

    translation_data_unit [1].address := ^data_unit_header;
    translation_data_unit [1].length := #SIZE (data_unit_header);
    translation_data_unit [2].address := translation^.title;
    translation_data_unit [2].length := data_unit_header.title_size;
    translation_data_unit [3].address := translation^.user_information;
    IF translation^.user_information <> NIL THEN
      translation_data_unit [3].length := STRLENGTH (translation^.user_information^);
      data_unit_header.info.userinfo_size := STRLENGTH (translation^.user_information^);
    ELSE
      translation_data_unit [3].length := 0;
      data_unit_header.info.userinfo_size := 0;
    IFEND;

    generate_osi_address (translation, osi_device, osi_address, osi_address_length);
    translation_data_unit [4].address := osi_address;
    translation_data_unit [4].length := osi_address_length;

  PROCEND generate_translation_data_unit;
?? OLDTITLE ??
?? NEWTITLE := 'generate_v3_trans_data_unit', EJECT ??

  PROCEDURE generate_v3_trans_data_unit
    (    translation: ^nat$translation;
         osi_device: nlt$device_identifier;
         reason: generate_reason;
     VAR osi_address: ^SEQ ( * );
     VAR data_unit_header: translation_pdu_v3;
     VAR translation_data_unit: array [1 .. 4] of nat$data_fragment);

{     PURPOSE:
{       This procedure generates a translation data unit given a translation entry.

    VAR
      sequence_number: integer,
      osi_address_length: nat$osi_address_length;

    data_unit_header.id := nac$v3_translation_data_unit;
    data_unit_header.version := nac$directory_version_3;
    data_unit_header.identifier := translation^.identifier;
    data_unit_header.lifetime := nac$initial_pdu_lifetime;
    get_pdu_sequence_number (sequence_number);
    data_unit_header.sequence := sequence_number;
    data_unit_header.change_count := translation^.change_count;
    data_unit_header.address_kind := translation^.registered_address.kind;
    data_unit_header.title_size := STRLENGTH (translation^.title^);
    data_unit_header.protocol := translation^.protocol;
    data_unit_header.priority := translation^.priority;
    data_unit_header.info.class := translation^.class;
    data_unit_header.info.response := reason = response;

    translation_data_unit [1].address := ^data_unit_header;
    translation_data_unit [1].length := #SIZE (data_unit_header);
    translation_data_unit [2].address := translation^.title;
    translation_data_unit [2].length := data_unit_header.title_size;
    translation_data_unit [3].address := translation^.user_information;
    IF translation^.user_information <> NIL THEN
      translation_data_unit [3].length := STRLENGTH (translation^.user_information^);
      data_unit_header.info.userinfo_size := STRLENGTH (translation^.user_information^);
    ELSE
      translation_data_unit [3].length := 0;
      data_unit_header.info.userinfo_size := 0;
    IFEND;

    generate_osi_address (translation, osi_device, osi_address, osi_address_length);
    translation_data_unit [4].address := osi_address;
    translation_data_unit [4].length := osi_address_length;

  PROCEND generate_v3_trans_data_unit;
?? TITLE := 'get_pdu_sequence_number', EJECT  ??

  PROCEDURE get_pdu_sequence_number
    (VAR sequence_number: integer);

{     PURPOSE:
{       This procedure manages the directory protocol sequence number.

    VAR
      cs_status: osc$cs_successful .. osc$cs_variable_locked,
      new_sequence_number: integer,
      pdu_sequence_number: [STATIC] integer := 0; { This variable is used to optimize
{                           managing the directory protocol sequence number.

    sequence_number := 0;
    new_sequence_number := pdu_sequence_number + 1;
    REPEAT
      #compare_swap (nlv$directory_pdu_seq_number, pdu_sequence_number,
            new_sequence_number, pdu_sequence_number, cs_status);
      CASE cs_status OF
      = osc$cs_successful =
        IF new_sequence_number <= 0ffff(16) THEN
          pdu_sequence_number := new_sequence_number;
          sequence_number := new_sequence_number;
        ELSE
          new_sequence_number := 1;
        IFEND;
      = osc$cs_failed =
        new_sequence_number := pdu_sequence_number + 1;
        IF new_sequence_number > 0ffff(16) THEN
          new_sequence_number := 1;
        IFEND;
      = osc$cs_variable_locked =
        ;
      CASEND;
    UNTIL (cs_status = osc$cs_successful) AND (sequence_number > 0);

  PROCEND get_pdu_sequence_number;
?? OLDTITLE ??
?? NEWTITLE := 'nlp$name_match - wild card comparison function', EJECT ??

  FUNCTION [XDCL, #GATE] nlp$name_match
    (    name: nat$title_pattern;
         model: nat$title): boolean;

{ PURPOSE:
{   Compare the two strings entered by checking for model conformity.
{
{ CALL FORMAT:
{   result := nlp$name_match(name,model);
{
{ DESCRIPTION:
{   This function compares the two strings entered, name and model.
{   The name string may contain wild card attributes, the model string
{   is used to compare against the name string.  If the two strings
{   conform (match) the function returns a TRUE value; oherwise, it
{   returns FALSE.
{
{   Inputs:
{     name   string(*)   the name to be compared
{     model  string(*)   the model to compare against
{
{   The following characters have special meaning.  These characters
{   may be used in the name string as wild card entries.
{
{     [ ... ]  any single character among those in brackets
{
{      a-z     within a bracketed group, a range of characters
{              is represented with a dash, i.e.:
{              "a-z", where "a" and "z" are any two characters for
{              which the expression a <= z or a >= z is accepted
{
{      *       any character string including the NULL string
{
{      ?       any single character
{
{      '       If the model contains any special characters,
{              those special characters (*, [, ?) must be surrounded
{              with single quotes.  If the model contains a single
{              quote, 2 single quotes must be in  the name.
{              example: the name string A'*'B  matches  the model
{              string A*B and the name string A''B matches the model
{              string A'B.
{
{         Special characters are not recognized within a bracketed group.

    VAR
      name_index, { indexes to name string
      max_name,

      model_index, { indexes to model string
      max_model,
      special_index,
      asterisk_index: integer, { asterisk index in name string
      closing_bracket_processed, { closing bracket found ']'
      char_in_range, { bracket character in range flag
      char_in_bracket, { character found in bracket
      special_restart,
      asterisk_found: boolean; { asterisk detected in name string

    max_name := STRLENGTH (name);
    max_model := STRLENGTH (model);

    WHILE (max_name > 1) AND (name (max_name) = ' ') DO
      max_name := max_name - 1;
    WHILEND;

    WHILE (max_model > 1) AND (model (max_model) = ' ') DO
      max_model := max_model - 1;
    WHILEND;

    nlp$name_match := FALSE;
    asterisk_found := FALSE;
    special_restart := FALSE;
    name_index := 1;
    model_index := 1;

  /next_special/
    WHILE (model_index <= max_model) AND (name_index <= max_name) DO

    /special_case/
      BEGIN
        CASE name (name_index) OF
        = '*' =
          WHILE (name_index < max_name) AND (name (name_index) = '*') DO
            name_index := name_index + 1;
          WHILEND;
          asterisk_index := name_index - 1;

          IF name (name_index) = '*' THEN { last character *
            nlp$name_match := TRUE;
            RETURN;
          IFEND;

          special_index := model_index;
          asterisk_found := TRUE;

        = '?' =
          name_index := name_index + 1;
          model_index := model_index + 1;

        = '[' =
          closing_bracket_processed := FALSE;
          char_in_range := FALSE;
          char_in_bracket := FALSE;
          name_index := name_index + 1;

          IF name (name_index + 1) = '-' THEN
            name_index := name_index + 1;
          IFEND;

          WHILE (name_index <= max_name) AND (NOT closing_bracket_processed) DO
            CASE name (name_index) OF
            = ']' =
              IF NOT char_in_bracket THEN
                IF asterisk_found THEN
                  special_restart := TRUE;
                  EXIT /special_case/;
                ELSE
                  RETURN;
                IFEND;
              IFEND;

              closing_bracket_processed := TRUE;
              name_index := name_index + 1;
              model_index := model_index + 1;

            = '-' =
              IF name_index + 1 <= max_name THEN
                char_in_bracket := ((model (model_index) >= name (name_index - 1)) AND
                      (model (model_index) <= name (name_index + 1))) OR
                      ((model (model_index) <= name (name_index - 1)) AND
                      (model (model_index) >= name (name_index + 1)));
                name_index := name_index + 2;
              ELSE
                RETURN;
              IFEND;
            ELSE
              char_in_bracket := name (name_index) = model (model_index);
              name_index := name_index + 1;
            CASEND;
            WHILE char_in_bracket AND NOT closing_bracket_processed AND
                  (name_index <= max_name) AND (name (name_index) <> ']') DO
              name_index := name_index + 1;
            WHILEND;
          WHILEND;

        = '''' =
          IF (name_index < max_name) AND (name (name_index + 1) = '''') AND (model (model_index) = '''') THEN
            name_index := name_index + 2;
            model_index := model_index + 1;
          ELSE
            name_index := name_index + 1;
            WHILE (name_index <= max_name) AND (name (name_index) <> '''') AND (model_index <= max_model) DO
              IF name (name_index) <> model (model_index) THEN
                IF asterisk_found THEN
                  special_restart := TRUE;
                  EXIT /special_case/;
                ELSE
                  RETURN;
                IFEND;
              IFEND;
              name_index := name_index + 1;
              model_index := model_index + 1;
            WHILEND;
            IF (name_index > max_name) OR (name (name_index) <> '''') THEN
              RETURN; { missing end quote
            IFEND;
            name_index := name_index + 1;
          IFEND;

        ELSE { compare characters

          IF name (name_index) <> model (model_index) THEN
            IF asterisk_found THEN
              special_restart := TRUE;
              EXIT /special_case/;
            ELSE
              RETURN;
            IFEND;
          ELSE
            name_index := name_index + 1;
            model_index := model_index + 1;
          IFEND;
        CASEND;
      END /special_case/;

      IF (special_restart) OR ((asterisk_found) AND (name_index > max_name) AND (model_index <= max_model))
            THEN
        special_restart := FALSE;
        special_index := special_index + 1;
        model_index := special_index;
        name_index := asterisk_index + 1;
      IFEND;
    WHILEND /next_special/;

    nlp$name_match := (model_index > max_model) AND ((name_index > max_name) OR
          ((name_index = max_name) AND (name (max_name) = '*')));

{ check for * after name that exactly matches model

  FUNCEND nlp$name_match;
?? OLDTITLE ??
?? NEWTITLE := 'process_data_unit', EJECT ??

  PROCEDURE process_data_unit
    (    source_address: nat$network_layer_address;
         system_identifier: nat$system_identifier;
     VAR data_unit: ^SEQ ( * ));

{     PURPOSE:
{       This routine processes a directory data unit received over the network.
{
{     DESCRIPTION:
{       Data units processed are the Translation Data Unit, the
{       Delete Translation Data Unit, the Translation Request Data Unit,
{       and the Startup Data Unit.

    VAR
      actual: integer,
      community_count: 0 .. 0ff(16),
      delete_translation_data_unit: ^delete_translation_pdu,
      delete_translation_data_unit_v3: ^delete_translation_pdu_v3,
      detail: ^SEQ ( * ),
      detail_size: integer,
      expired_translation: ^nat$translation,
      header: ^pdu_header,
      identifier: nat$directory_entry_identifier,
      log_message: string (150),
      log_message_length: integer,
      old_translation: ^nat$translation,
      osi_address: ^SEQ ( * ),
      osi_address_buffer: SEQ (REP nac$max_osi_address_length of cell),
      osi_address_kind: ^nat$translation_address_kind,
      osi_address_length: ^nat$osi_address_length,
      osi_address_present: boolean,
      pdu: array [1 .. 4] of nat$data_fragment,
      registration_communities: ^array [1 .. * ] of nat$community_title,
      request: ^nat$translation_request,
      requestor: nat$network_layer_address,
      requestor_id: ^nat$system_identifier,
      requestor_nsap: ^nat$osi_network_address,
      startup_data_unit: ^startup_pdu,
      startup_data_unit_v3: ^startup_pdu_v3,
      statistic: ^integer,
      status: ost$status,
      till_system_id: ^string ( * ),
      title: ^string ( * ),
      title_length: nat$title_length,
      translation: ^nat$translation,
      translation_data_unit: ^translation_pdu,
      translation_data_unit_v3: ^translation_pdu_v3,
      translation_data_unit_header: translation_pdu,
      trans_data_unit_header_v3: translation_pdu_v3,
      translation_request_data_unit: ^translation_request_pdu,
      translation_req_data_unit_v3: ^translation_request_pdu_v3,
      user_info: ^string ( * ),
      userinfo_length: 0 .. 07f(16);

    status.normal := TRUE;

    RESET data_unit;
    NEXT header IN data_unit;
    RESET data_unit;

    IF header^.version = nac$osi_directory_version THEN
      CASE header^.id OF
      = nac$translation_req_data_unit =
        NEXT translation_request_data_unit IN data_unit;
        IF (translation_request_data_unit <> NIL) AND (translation_request_data_unit^.title_size > 0) THEN
          PUSH request: [translation_request_data_unit^.title_size];
          request^.wild_card := translation_request_data_unit^.info.wild_card;
          request^.protocol := translation_request_data_unit^.protocol;
          request^.class := translation_request_data_unit^.info.class;
          IF translation_request_data_unit^.community_count > 0 THEN
            NEXT registration_communities: [1 .. translation_request_data_unit^.community_count] IN
                  data_unit;
          IFEND;
          NEXT title: [translation_request_data_unit^.title_size] IN data_unit;
          request^.title := title^;
        ELSE
          RETURN;
        IFEND;
        IF nlv$log_broadcast_requests THEN
          STRINGREP (log_message, log_message_length, title^, ' requested by ', system_identifier: #(16));
          pmp$log (log_message (1, log_message_length), status);
        IFEND;

        osp$set_job_signature_lock (nlv$directory_lock);
        IF nav$statistics_enabled THEN
          nav$global_statistics.directory.translation_requests_received :=
                nav$global_statistics.directory.translation_requests_received + 1;
        IFEND;
        translation := nav$registered_titles.first;

        WHILE translation <> NIL DO
          IF (translation^.domain.kind = nac$catenet_domain) THEN
            IF valid_translation (translation, request) THEN
              osi_address := ^osi_address_buffer;
              generate_translation_data_unit (translation, source_address.device_id, response, osi_address,
                    translation_data_unit_header, pdu);
              IF (osi_address <> NIL) THEN
                nap$send_network_data (nac$xi_cdna_directory_sap, source_address, pdu, status);
                IF nav$statistics_enabled THEN
                  nav$global_statistics.directory.translations_sent :=
                        nav$global_statistics.directory.translations_sent + 1;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
          translation := translation^.link;
        WHILEND;
        osp$clear_job_signature_lock (nlv$directory_lock);

      = nac$translation_data_unit =
        NEXT translation_data_unit IN data_unit;
        IF (translation_data_unit <> NIL) AND (translation_data_unit^.title_size > 0) THEN
          IF nav$statistics_enabled THEN
            IF translation_data_unit^.info.response THEN
              statistic := ^nav$global_statistics.directory.translations_received;
            ELSE
              statistic := ^nav$global_statistics.directory.broadcast_translations_received;
            IFEND;
            osp$increment_locked_variable (statistic^, 0, actual);
          IFEND;
          title_length := translation_data_unit^.title_size;
          userinfo_length := translation_data_unit^.info.userinfo_size;
          community_count := translation_data_unit^.community_count;
          detail_size := title_length + userinfo_length;
          IF community_count > 0 THEN
            NEXT registration_communities: [1 .. community_count] IN data_unit;
          IFEND;
          NEXT title: [title_length] IN data_unit;
          IF nlv$log_broadcast_translations AND NOT translation_data_unit^.info.response THEN
            STRINGREP (log_message, log_message_length, title^, ' broadcast by ',
                  translation_data_unit^.identifier.system.system: #(16));
            pmp$log (log_message (1, log_message_length), status);
          IFEND;
          IF userinfo_length > 0 THEN
            NEXT user_info: [userinfo_length] IN data_unit;
          IFEND;
          osi_address_present := (translation_data_unit^.address.kind >= nac$osi_network_address) AND
                (translation_data_unit^.address.kind <= nac$osi_non_cdna_present_addr);
          IF osi_address_present THEN
            NEXT osi_address_kind IN data_unit;
            NEXT osi_address_length IN data_unit;
            IF osi_address_length <> NIL THEN
              detail_size := detail_size + osi_address_length^ + #SIZE (osi_address_kind^) +
                    #SIZE (osi_address_length^);
              RESET data_unit TO osi_address_kind;
              NEXT osi_address: [[REP osi_address_length^ + #SIZE (osi_address_kind^) +
                    #SIZE (osi_address_length^) OF cell]] IN data_unit;
              IF osi_address = NIL THEN
                RETURN;
              IFEND;
            ELSE
              RETURN;
            IFEND;
          IFEND;
          ALLOCATE translation: [[REP detail_size OF char]] IN nav$network_paged_heap^;
          IF translation <> NIL THEN
            translation^.identifier := translation_data_unit^.identifier;
            translation^.user_identifier := osc$null_name;
            translation^.change_count := translation_data_unit^.change_count;
            translation^.protocol := translation_data_unit^.protocol;
            translation^.priority := translation_data_unit^.priority;
            translation^.class := translation_data_unit^.info.class;
            detail := ^translation^.detail;
            RESET detail;
            translation^.domain.kind := nac$catenet_domain;
            NEXT translation^.title: [title_length] IN detail;
            translation^.title^ := title^;
            IF userinfo_length > 0 THEN
              NEXT translation^.user_information: [userinfo_length] IN detail;
              translation^.user_information^ := user_info^;
            ELSE
              translation^.user_information := NIL;
            IFEND;
            IF osi_address_present THEN
              translation^.osi_address_kind := translation_address;
              NEXT translation^.osi_address: [[REP #SIZE (osi_address^) OF cell]] IN detail;
              translation^.osi_address^ := osi_address^;
            ELSE
              translation^.osi_address_kind := undefined_address;
              translation^.osi_address := NIL;
            IFEND;
            translation^.time_stamp := #FREE_RUNNING_CLOCK (0) + nac$cache_timeout;

            osp$set_job_signature_lock (nlv$directory_lock);
            find_title (title^, translation^.identifier, nav$translation_cache.first, old_translation);
            IF (old_translation = NIL) THEN
              satisfy_translation_requests (translation);
              IF (translation^.priority = nac$max_directory_priority) THEN
                add_translation (translation, nav$translation_cache.first);
                IF nav$statistics_enabled THEN
                  nav$global_statistics.directory.current_cache_entries :=
                        nav$global_statistics.directory.current_cache_entries + 1;
                IFEND;
                IF translation^.time_stamp < nav$translation_cache.next_timer THEN
                  nav$translation_cache.next_timer := translation^.time_stamp;
                IFEND;
              ELSE
                FREE translation IN nav$network_paged_heap^;
              IFEND;
            ELSEIF old_translation^.change_count = translation^.change_count THEN
              old_translation^.time_stamp := translation^.time_stamp;
              FREE translation IN nav$network_paged_heap^;
            ELSEIF old_translation^.change_count < translation^.change_count THEN
              satisfy_translation_requests (translation);
              delete_translation (old_translation, nav$translation_cache.first);
              IF (translation^.priority = nac$max_directory_priority) THEN
                add_translation (translation, nav$translation_cache.first);
                IF translation^.time_stamp < nav$translation_cache.next_timer THEN
                  nav$translation_cache.next_timer := translation^.time_stamp;
                IFEND;
              ELSE
                IF nav$statistics_enabled AND (nav$global_statistics.directory.current_cache_entries > 0) THEN
                  nav$global_statistics.directory.current_cache_entries :=
                        nav$global_statistics.directory.current_cache_entries - 1;
                IFEND;
                FREE translation IN nav$network_paged_heap^;
              IFEND;
            ELSE {old_translation^.change_count > translation^.change_count}
              FREE translation IN nav$network_paged_heap^;
            IFEND;
            osp$clear_job_signature_lock (nlv$directory_lock);
          IFEND;
        IFEND;

      = nac$del_translation_data_unit =
        NEXT delete_translation_data_unit IN data_unit;
        IF (delete_translation_data_unit <> NIL) AND (delete_translation_data_unit^.title_size > 0) THEN
          identifier := delete_translation_data_unit^.identifier;
          title_length := delete_translation_data_unit^.title_size;
          NEXT title: [title_length] IN data_unit;

          osp$set_job_signature_lock (nlv$directory_lock);
          find_title (title^, identifier, nav$translation_cache.first, translation);
          IF translation <> NIL THEN
            delete_translation (translation, nav$translation_cache.first);
            IF nav$statistics_enabled AND (nav$global_statistics.directory.current_cache_entries > 0) THEN
              nav$global_statistics.directory.current_cache_entries :=
                    nav$global_statistics.directory.current_cache_entries - 1;
            IFEND;
          IFEND;

{ A delete indication would be returned to appropriate requestors now.

          osp$clear_job_signature_lock (nlv$directory_lock);
        IFEND;

      = nac$startup_data_unit =
        NEXT startup_data_unit IN data_unit;
        IF startup_data_unit <> NIL THEN
          osp$set_job_signature_lock (nlv$directory_lock);
          translation := nav$translation_cache.first;
          WHILE translation <> NIL DO
            IF (startup_data_unit^.identifier.system = translation^.identifier.system) AND
                  time1_less_than_time2 (translation^.identifier.time_stamp,
                  startup_data_unit^.identifier.time_stamp) THEN
              expired_translation := translation;
              translation := translation^.link;
              delete_translation (expired_translation, nav$translation_cache.first);
              IF nav$statistics_enabled AND (nav$global_statistics.directory.current_cache_entries > 0) THEN
                nav$global_statistics.directory.current_cache_entries :=
                      nav$global_statistics.directory.current_cache_entries - 1;
              IFEND;
            ELSE
              translation := translation^.link;
            IFEND;
          WHILEND;
          osp$clear_job_signature_lock (nlv$directory_lock);
        IFEND;

      ELSE
        ;
      CASEND;

    ELSEIF header^.version = nac$directory_version_3 THEN

      CASE header^.id OF
      = nac$v3_translation_rq_data_unit =
        NEXT translation_req_data_unit_v3 IN data_unit;
        IF (translation_req_data_unit_v3 <> NIL) AND (translation_req_data_unit_v3^.title_size > 0) THEN
          PUSH request: [translation_req_data_unit_v3^.title_size];
          request^.wild_card := translation_req_data_unit_v3^.info.wild_card;
          request^.protocol := translation_req_data_unit_v3^.protocol;
          request^.class := translation_req_data_unit_v3^.info.class;
          NEXT title: [translation_req_data_unit_v3^.title_size] IN data_unit;
          request^.title := title^;
        ELSE
          RETURN;
        IFEND;
        requestor.kind := nac$osi_network_address;
        requestor.device_id := source_address.device_id;
        requestor.network_address_length := translation_req_data_unit_v3^.source_nsap_length;
        NEXT requestor_nsap: [[ REP requestor.network_address_length OF cell]] IN data_unit;
        IF requestor_nsap <> NIL THEN
          i#move (requestor_nsap, ^requestor.network_address, requestor.network_address_length);
        ELSE
          RETURN;
        IFEND;
        RESET requestor_nsap;
        NEXT till_system_id: [requestor.network_address_length - #SIZE (nat$system_identifier) -
              #SIZE (nat$network_selector)] IN requestor_nsap;
        NEXT requestor_id IN requestor_nsap;
        IF requestor_id^ =  nav$system_id THEN {This is our own request ... ignore it.
          RETURN;
        IFEND;
        IF nlv$log_broadcast_requests THEN
          STRINGREP (log_message, log_message_length, title^, ' requested by ', requestor_id^: #(16));
          pmp$log (log_message (1, log_message_length), status);
        IFEND;

        osp$set_job_signature_lock (nlv$directory_lock);
        IF nav$statistics_enabled THEN
          nav$global_statistics.directory.translation_requests_received :=
                nav$global_statistics.directory.translation_requests_received + 1;
        IFEND;
        translation := nav$registered_titles.first;

        WHILE translation <> NIL DO
          IF (translation^.domain.kind = nac$catenet_domain) THEN
            IF valid_translation (translation, request) THEN
              osi_address := ^osi_address_buffer;
              generate_v3_trans_data_unit (translation, source_address.device_id, response, osi_address,
                    trans_data_unit_header_v3, pdu);
              IF (osi_address <> NIL) THEN
                nap$send_network_data (nac$xi_cdna_directory_sap, requestor, pdu, status);
                IF nav$statistics_enabled THEN
                  nav$global_statistics.directory.translations_sent :=
                        nav$global_statistics.directory.translations_sent + 1;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
          translation := translation^.link;
        WHILEND;
        osp$clear_job_signature_lock (nlv$directory_lock);

      = nac$v3_translation_data_unit =
        NEXT translation_data_unit_v3 IN data_unit;
        IF (translation_data_unit_v3 <> NIL) AND (translation_data_unit_v3^.title_size > 0) THEN
          IF nav$statistics_enabled THEN
            IF translation_data_unit_v3^.info.response THEN
              statistic := ^nav$global_statistics.directory.translations_received;
            ELSE
              statistic := ^nav$global_statistics.directory.broadcast_translations_received;
            IFEND;
            osp$increment_locked_variable (statistic^, 0, actual);
          IFEND;
          title_length := translation_data_unit_v3^.title_size;
          userinfo_length := translation_data_unit_v3^.info.userinfo_size;
          detail_size := title_length + userinfo_length;
          NEXT title: [title_length] IN data_unit;
          IF nlv$log_broadcast_translations AND NOT translation_data_unit_v3^.info.response THEN
            STRINGREP (log_message, log_message_length, title^, ' broadcast by ',
                  translation_data_unit_v3^.identifier.system.system: #(16));
            pmp$log (log_message (1, log_message_length), status);
          IFEND;
          IF userinfo_length > 0 THEN
            NEXT user_info: [userinfo_length] IN data_unit;
          IFEND;
          osi_address_present := (translation_data_unit_v3^.address_kind >= nac$osi_network_address) AND
                (translation_data_unit_v3^.address_kind <= nac$osi_non_cdna_present_addr);
          IF osi_address_present THEN
            NEXT osi_address_kind IN data_unit;
            NEXT osi_address_length IN data_unit;
            IF osi_address_length <> NIL THEN
              detail_size := detail_size + osi_address_length^ + #SIZE (osi_address_kind^) +
                    #SIZE (osi_address_length^);
              RESET data_unit TO osi_address_kind;
              NEXT osi_address: [[REP osi_address_length^ + #SIZE (osi_address_kind^) +
                    #SIZE (osi_address_length^) OF cell]] IN data_unit;
              IF osi_address = NIL THEN
                RETURN;
              IFEND;
            ELSE
              RETURN;
            IFEND;
          IFEND;
          ALLOCATE translation: [[REP detail_size OF char]] IN nav$network_paged_heap^;
          IF translation <> NIL THEN
            translation^.identifier := translation_data_unit_v3^.identifier;
            translation^.user_identifier := osc$null_name;
            translation^.change_count := translation_data_unit_v3^.change_count;
            translation^.protocol := translation_data_unit_v3^.protocol;
            translation^.priority := translation_data_unit_v3^.priority;
            translation^.class := translation_data_unit_v3^.info.class;
            detail := ^translation^.detail;
            RESET detail;
            translation^.domain.kind := nac$catenet_domain;
            NEXT translation^.title: [title_length] IN detail;
            translation^.title^ := title^;
            IF userinfo_length > 0 THEN
              NEXT translation^.user_information: [userinfo_length] IN detail;
              translation^.user_information^ := user_info^;
            ELSE
              translation^.user_information := NIL;
            IFEND;
            IF osi_address_present THEN
              translation^.osi_address_kind := translation_address;
              NEXT translation^.osi_address: [[REP #SIZE (osi_address^) OF cell]] IN detail;
              translation^.osi_address^ := osi_address^;
            ELSE
              translation^.osi_address_kind := undefined_address;
              translation^.osi_address := NIL;
            IFEND;
            translation^.time_stamp := #FREE_RUNNING_CLOCK (0) + nac$cache_timeout;

            osp$set_job_signature_lock (nlv$directory_lock);
            find_title (title^, translation^.identifier, nav$translation_cache.first, old_translation);
            IF (old_translation = NIL) THEN
              satisfy_translation_requests (translation);
              IF (translation^.priority = nac$max_directory_priority) THEN
                add_translation (translation, nav$translation_cache.first);
                IF nav$statistics_enabled THEN
                  nav$global_statistics.directory.current_cache_entries :=
                        nav$global_statistics.directory.current_cache_entries + 1;
                IFEND;
                IF translation^.time_stamp < nav$translation_cache.next_timer THEN
                  nav$translation_cache.next_timer := translation^.time_stamp;
                IFEND;
              ELSE
                FREE translation IN nav$network_paged_heap^;
              IFEND;
            ELSEIF old_translation^.change_count = translation^.change_count THEN
              old_translation^.time_stamp := translation^.time_stamp;
              FREE translation IN nav$network_paged_heap^;
            ELSEIF old_translation^.change_count < translation^.change_count THEN
              satisfy_translation_requests (translation);
              delete_translation (old_translation, nav$translation_cache.first);
              IF (translation^.priority = nac$max_directory_priority) THEN
                add_translation (translation, nav$translation_cache.first);
                IF translation^.time_stamp < nav$translation_cache.next_timer THEN
                  nav$translation_cache.next_timer := translation^.time_stamp;
                IFEND;
              ELSE
                IF nav$statistics_enabled AND (nav$global_statistics.directory.current_cache_entries > 0) THEN
                  nav$global_statistics.directory.current_cache_entries :=
                        nav$global_statistics.directory.current_cache_entries - 1;
                IFEND;
                FREE translation IN nav$network_paged_heap^;
              IFEND;
            ELSE {old_translation^.change_count > translation^.change_count}
              FREE translation IN nav$network_paged_heap^;
            IFEND;
            osp$clear_job_signature_lock (nlv$directory_lock);
          IFEND;
        IFEND;

      = nac$v3_dl_translation_data_unit =
        NEXT delete_translation_data_unit_v3 IN data_unit;
        IF (delete_translation_data_unit_v3 <> NIL) AND (delete_translation_data_unit_v3^.title_size > 0) THEN
          identifier := delete_translation_data_unit_v3^.identifier;
          title_length := delete_translation_data_unit_v3^.title_size;
          NEXT title: [title_length] IN data_unit;
          IF title <> NIL THEN
            osp$set_job_signature_lock (nlv$directory_lock);
            find_title (title^, identifier, nav$translation_cache.first, translation);
            IF translation <> NIL THEN
              delete_translation (translation, nav$translation_cache.first);
              IF nav$statistics_enabled AND (nav$global_statistics.directory.current_cache_entries > 0) THEN
                nav$global_statistics.directory.current_cache_entries :=
                      nav$global_statistics.directory.current_cache_entries - 1;
              IFEND;
            IFEND;

{ A delete indication would be returned to appropriate requestors now.

            osp$clear_job_signature_lock (nlv$directory_lock);
          IFEND;
        IFEND;

      = nac$v3_startup_data_unit =
        NEXT startup_data_unit_v3 IN data_unit;
        IF startup_data_unit_v3 <> NIL THEN
          osp$set_job_signature_lock (nlv$directory_lock);
          translation := nav$translation_cache.first;
          WHILE translation <> NIL DO
            IF (startup_data_unit_v3^.identifier.system = translation^.identifier.system) AND
                  time1_less_than_time2 (translation^.identifier.time_stamp,
                  startup_data_unit_v3^.identifier.time_stamp) THEN
              expired_translation := translation;
              translation := translation^.link;
              delete_translation (expired_translation, nav$translation_cache.first);
              IF nav$statistics_enabled AND (nav$global_statistics.directory.current_cache_entries > 0) THEN
                nav$global_statistics.directory.current_cache_entries :=
                      nav$global_statistics.directory.current_cache_entries - 1;
              IFEND;
            ELSE
              translation := translation^.link;
            IFEND;
          WHILEND;
          osp$clear_job_signature_lock (nlv$directory_lock);
        IFEND;
      ELSE
        ;
      CASEND;
    IFEND;

  PROCEND process_data_unit;
?? OLDTITLE ??
?? NEWTITLE := 'same_address', EJECT ??

  FUNCTION same_address
    (    address_3: nat$osi_registration_address;
         address_4: nat$osi_registration_address): boolean;

{     PURPOSE:
{       This function compares two registered addresses and determines
{       whether they are equivalent or not.

    VAR
      sequence: ^SEQ ( * ),
      string_1: ^string ( * ),
      string_2: ^string ( * );

    IF address_3.kind = address_4.kind THEN
      CASE address_3.kind OF
      = nac$osi_transport_address =
        same_address := (address_3.transport_selector = address_4.transport_selector);

      = nac$osi_session_address =
        same_address := (address_3.transport_selector = address_4.transport_selector) AND
              (address_3.session_selector = address_4.session_selector);

      = nac$osi_presentation_address =
        same_address := (address_3.transport_selector = address_4.transport_selector) AND
              (address_3.session_selector = address_4.session_selector) AND
              (address_3.presentation_selector = address_4.presentation_selector);

      = nac$osi_non_cdna_session_addr, nac$osi_non_cdna_present_addr =
        sequence := address_3.osi_address;
        RESET sequence;
        NEXT string_1: [#SIZE (sequence^)] IN sequence;
        sequence := address_4.osi_address;
        RESET sequence;
        NEXT string_2: [#SIZE (sequence^)] IN sequence;
        same_address := string_1 = string_2;

      ELSE
        same_address := FALSE;
      CASEND;
    ELSE
      same_address := FALSE;
    IFEND;

  FUNCEND same_address;
?? OLDTITLE ??
?? NEWTITLE := 'satisfy_translation_requests', EJECT ??

  PROCEDURE satisfy_translation_requests
    (    translation: ^nat$translation);

{     PURPOSE:
{       This  routine  is called by directory routines to check
{       if the given translation matches  any  outstanding TRDS
{       request.
{
{     DESCRIPTION:
{       This  routine  scans  the  outstanding TRDS entries to
{       check if the given translation satisfies  any translation
{       request. The requesting task is notified when one is found.

    VAR
      ready_status: ost$status,
      next_request: ^nat$translation_request,
      request: ^nat$translation_request;

    request := nav$translation_requests.first;

    WHILE request <> NIL DO
      next_request := request^.link;
      IF valid_translation (translation, request) THEN
        IF (translation^.osi_address_kind = translation_address) THEN
          save_valid_translation (translation, request);
        ELSE
          save_local_translation (translation, request);
        IFEND;
        ready_status.normal := TRUE;
        pmp$ready_task (request^.requestor, ready_status);
        IF NOT ready_status.normal THEN {requesting task is gone..delete request}
          delete_request (request);
        IFEND;
      IFEND;
      request := next_request;
    WHILEND;

  PROCEND satisfy_translation_requests;
?? OLDTITLE ??
?? NEWTITLE := 'save_local_translation', EJECT ??

  PROCEDURE save_local_translation
    (    translation: ^nat$translation;
         request: ^nat$translation_request);

{     PURPOSE:
{       This routine is called by directory routines to save a
{      local translation for a translation request primitive.
{
{     DESCRIPTION:
{       The translation is copied to the chain of valid translations
{       for the request, once for each active OSI device. The OSI address
{       for the device is placed in the corresponding translation.
{       The translation will be returned to the requestor by nlp$get_title_translation.

    VAR
      detail: ^SEQ ( * ),
      detail_length: integer,
      new_translation: ^nat$translation,
      osi_address: ^SEQ ( * ),
      osi_address_buffer: SEQ (REP nac$max_osi_address_length of cell),
      osi_address_length: nat$osi_address_length,
      osi_device: nlt$device_identifier;

    FOR osi_device := LOWERBOUND (nlv$configured_network_devices.network_device_list^)
          TO UPPERBOUND (nlv$configured_network_devices.network_device_list^) DO
      osi_address := ^osi_address_buffer;
      generate_osi_address (translation, osi_device, osi_address, osi_address_length);
      IF osi_address <> NIL THEN
        detail_length := STRLENGTH (translation^.title^) + osi_address_length;
        IF translation^.user_information <> NIL THEN
          detail_length := detail_length + STRLENGTH (translation^.user_information^);
        IFEND;
        ALLOCATE new_translation: [[REP detail_length OF char]] IN nav$network_paged_heap^;
        IF new_translation <> NIL THEN
          detail := ^new_translation^.detail;
          RESET detail;
          NEXT new_translation^.title: [STRLENGTH (translation^.title^)] IN detail;
          new_translation^.title^ := translation^.title^;
          new_translation^.identifier := translation^.identifier;
          new_translation^.user_identifier := translation^.user_identifier;
          new_translation^.change_count := translation^.change_count;
          new_translation^.protocol := translation^.protocol;
          IF translation^.user_information <> NIL THEN
            NEXT new_translation^.user_information: [STRLENGTH (translation^.user_information^)] IN detail;
            new_translation^.user_information^ := translation^.user_information^;
          ELSE
            new_translation^.user_information := NIL;
          IFEND;
          new_translation^.osi_address_kind := translation_address;
          NEXT new_translation^.osi_address: [[REP osi_address_length OF cell]] IN detail;
          i#move (osi_address, new_translation^.osi_address, osi_address_length);
          new_translation^.priority := translation^.priority;
          new_translation^.reported := FALSE;
          add_translation (new_translation, request^.first_translation);
        IFEND;
      IFEND;
    FOREND;

  PROCEND save_local_translation;
?? OLDTITLE ??
?? NEWTITLE := 'save_valid_translation', EJECT ??

  PROCEDURE save_valid_translation
    (    translation: ^nat$translation;
         request: ^nat$translation_request);

{     PURPOSE:
{       This routine is called by directory routines to save a
{      valid translation for a translation request primitive.
{
{     DESCRIPTION:
{       The translation is copied to the chain of valid translations
{       for the request. The translation will be returned to the
{       requestor by nlp$get_title_translation.

    VAR
      detail: ^SEQ ( * ),
      new_translation: ^nat$translation,
      old_translation: ^nat$translation,
      osi_address_length: 0 .. 0ff(16);

    find_title (translation^.title^, translation^.identifier, request^.first_translation, old_translation);

{ See if this translation is a new translation or an old one that has changed.

    IF (old_translation = NIL) OR (old_translation^.change_count < translation^.change_count) THEN
      ALLOCATE new_translation: [[REP #SIZE (translation^.detail) OF char]] IN nav$network_paged_heap^;
      IF new_translation <> NIL THEN
        detail := ^new_translation^.detail;
        RESET detail;
        NEXT new_translation^.title: [STRLENGTH (translation^.title^)] IN detail;
        new_translation^.title^ := translation^.title^;
        new_translation^.identifier := translation^.identifier;
        new_translation^.user_identifier := translation^.user_identifier;
        new_translation^.change_count := translation^.change_count;
        new_translation^.protocol := translation^.protocol;
        new_translation^.osi_address_kind := translation^.osi_address_kind;
        new_translation^.registered_address := translation^.registered_address;
        IF translation^.user_information <> NIL THEN
          NEXT new_translation^.user_information: [STRLENGTH (translation^.user_information^)] IN detail;
          new_translation^.user_information^ := translation^.user_information^;
        ELSE
          new_translation^.user_information := NIL;
        IFEND;
        IF translation^.osi_address_kind = translation_address THEN
          NEXT new_translation^.osi_address: [[REP #SIZE (translation^.osi_address^) OF cell]] IN detail;
          new_translation^.osi_address^ := translation^.osi_address^;
        ELSEIF (translation^.osi_address_kind = registration_address) AND
              ((translation^.registered_address.kind = nac$osi_non_cdna_session_addr) OR
              (translation^.registered_address.kind = nac$osi_non_cdna_present_addr)) THEN
          NEXT new_translation^.registered_address.osi_address:
                [[REP #SIZE (translation^.registered_address.osi_address^) OF cell]] IN detail;
          new_translation^.registered_address.osi_address^ := translation^.registered_address.osi_address^;
        IFEND;
        new_translation^.priority := translation^.priority;
        new_translation^.reported := FALSE;
        add_translation (new_translation, request^.first_translation);
        IF old_translation <> NIL THEN
          delete_translation (old_translation, request^.first_translation);
        IFEND;
      IFEND;
    IFEND;

  PROCEND save_valid_translation;
?? OLDTITLE ??
?? NEWTITLE := 'send_distributed_pdu', EJECT ??

  PROCEDURE send_distributed_pdu
    (    device_id: nlt$device_identifier;
         pdu: array [1 .. * ] of nat$data_fragment);

    VAR
      broadcast_address: nat$network_layer_address,
      device_attributes: ^nlt$system_management,
      ignore_status: ost$status,
      network_address: ^SEQ ( * ),
      network_selector: ^nat$network_selector,
      system_id: ^nat$system_identifier,
      till_system_id: ^string ( * );

    device_attributes := ^nlv$sm_devices.list^ [device_id];
    IF (device_attributes^.network_address_length > 0) AND (device_attributes^.network_address_prefix <> NIL)
          THEN
      broadcast_address.kind := nac$osi_network_address;
      broadcast_address.device_id := device_id;
      broadcast_address.network_address_length := device_attributes^.network_address_length;
      i#move (^device_attributes^.generic_host_address, ^broadcast_address.network_address,
            broadcast_address.network_address_length);
      network_address := ^broadcast_address.network_address;
      RESET network_address;
      NEXT till_system_id: [broadcast_address.network_address_length - #SIZE (nat$system_identifier) -
            #SIZE (nat$network_selector)] IN network_address;
      NEXT system_id IN network_address;
      system_id^ := nav$cdna_multicast_address;
      NEXT network_selector IN network_address;
      network_selector^ := nac$xi_cdna_directory_sap;
      nap$send_network_data (nac$xi_cdna_directory_sap, broadcast_address, pdu, ignore_status);
    IFEND;

  PROCEND send_distributed_pdu;
?? OLDTITLE ??
?? NEWTITLE := 'time1_less_than_time2', EJECT ??

  FUNCTION time1_less_than_time2
    (    time1: nat$bcd_time;
         time2: nat$bcd_time): boolean;

{     PURPOSE:
{       This routine is called by directory routines to compare
{       two bcd date times.
{
{     DESCRIPTION:
{       This  routine  is  called  with  two  bcd  dates.  This
{       routine determines if the first time is less  than  the
{       second time.  The boolean result is returned.

    VAR
      date_1: 0 .. 0ffffff(16),
      date_2: 0 .. 0ffffff(16),
      time_1: 0 .. 0ffffffffff(16),
      time_2: 0 .. 0ffffffffff(16);

    #UNCHECKED_CONVERSION (time1.date, date_1);
    #UNCHECKED_CONVERSION (time2.date, date_2);
    #UNCHECKED_CONVERSION (time1.time, time_1);
    #UNCHECKED_CONVERSION (time2.time, time_2);

    time1_less_than_time2 := (date_1 < date_2) OR ((date_1 = date_2) AND (time_1 < time_2));

  FUNCEND time1_less_than_time2;
?? OLDTITLE ??
?? NEWTITLE := 'valid_translation', EJECT ??

  FUNCTION [INLINE] valid_translation
    (    translation: ^nat$translation;
         request: ^nat$translation_request): boolean;

{     PURPOSE:
{       This  routine  is  called  by the directory routines to
{       verify  a title translation meets the requested criteria.
{
{     DESCRIPTION:
{       Given  a  RDS/TDS entry and a Translation request, this
{       routine  verifies   the  title  matches  the  requested
{       criteria.
{       1.  Title  match  (may  be  wild  card)
{       2.  Directly Accessible  Service  layers match
{       3.  User Classification match

    valid_translation :=

    ((request^.protocol = nac$unknown_protocol) OR (request^.protocol = translation^.protocol))

    AND

    (request^.class = translation^.class)

    AND

    ((request^.wild_card AND nlp$name_match (request^.title, translation^.title^))

    OR

    (NOT (request^.wild_card) AND (translation^.title^ = request^.title)));

  FUNCEND valid_translation;
?? OLDTITLE ??
MODEND nlm$directory_management_entity;
*DECK DECK=NLM$IVB_I0_DRIVER EXPAND=TRUE
          IDENT  IVB0
          CIPPU
          MEMSEL 16
          TITLE  NLM$IVB I0 DRIVER - NOS/VE IVB DRIVER FOR I0 (IVB0).
          COMMENT *SMD* LVL=01
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4,10
***       THIS IS THE PP DRIVER FOR THE IPI CHANNEL THAT SUPPORTS THE
*         IVB BOARD.
          SPACE  4,10
 IVB0     EQU    0           ASSEMBLE CODE FOR THE I0
*copyc nli$ivb_driver

          END    IVB0
/EOR
*DECK DECK=NLM$IVB_I4_DRIVER EXPAND=TRUE
          IDENT  IVB4
          CIPPU
          MEMSEL 8
          TITLE  NLM$IVB I4 DRIVER - NOS/VE IVB DRIVER FOR I4 (IVB4).
          COMMENT *SMD* LVL=01
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4,10
***       THIS IS THE PP DRIVER FOR THE IPI CHANNEL THAT SUPPORTS THE
*         IVB BOARD.
          SPACE  4,10
 IVB4     EQU    0           ASSEMBLE CODE FOR THE I4.
*copyc nli$ivb_driver

          END    IVB4
/EOR
*DECK DECK=NLM$LINK_ACCESS_AGENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access : Link Access Agent' ??
?? NEWTITLE := 'Global Declarations Referenced by this Module' ??
MODULE nlm$link_access_agent;
{
{   PURPOSE:
{  This module contains the procedures which allow a NOS/VE user
{ entity access to the services of an OSI Link entity residing
{ in an OSI communications device. These procedures are collectively
{ referred to as the Link Access Agent (LAA).
{
{ DESIGN:
{  The Link Access protocol is exchanged over a channel connection between
{ the Link Access Agent (LAA) residing in NOS/VE and a Link Access Provider
{ (LAP) residing in an OSI communications device. The LAP serves as a
{ "gateway" between a channel connection and a Link Layer.
{

?? PUSH (LISTEXT := ON) ??
*copyc nac$null_connection_id
*copyc nae$link_access_agent
*copyc nae$namve_conditions
*copyc nlt$cc_device_and_data_list
*copyc nlt$cc_interface
*copyc nlt$device_count
*copyc nlt$device_ids
*copyc nlt$la_connection
*copyc nlt$la_protocol_data_unit
*copyc nlt$la_sap_descriptor
?? POP ??
*copyc nap$namve_system_error
*copyc nlp$bm_add_message_prefix
*copyc nlp$bm_create_message
*copyc nlp$bm_extract_message_prefix
*copyc nlp$bm_flush_message
*copyc nlp$bm_get_message_length
*copyc nlp$bm_release_message
*copyc nlp$cc_disconnect
*copyc nlp$cc_initialize_template
*copyc nlp$cc_request_connection
*copyc nlp$cc_send_data
*copyc nlp$cl_activate_layer
*copyc nlp$cl_create_connection
*copyc nlp$cl_deactivate_layer
*copyc nlp$cl_get_exclusive_via_cid
*copyc nlp$cl_get_layer_connection
*copyc nlp$cl_initialize_template
*copyc nlp$cl_release_exclusive_access
*copyc nlp$get_nonexclusive_access
*copyc nlp$release_nonexclusive_access
*copyc osp$add_to_locked_variable
*copyc osp$append_status_integer
*copyc osp$clear_job_signature_lock
*copyc osp$decrement_locked_variable
*copyc osp$increment_locked_variable
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc syp$cycle

*copyc nav$global_osi_statistics
*copyc nav$network_paged_heap
*copyc nav$network_procedures
*copyc nav$statistics_enabled
*copyc nav$system_id
*copyc nlv$configured_network_devices
*copyc nlv$la_open_sap_list
*copyc nlv$sm_devices
*copyc oss$task_private
*copyc osv$task_private_heap
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$la_close_sap', EJECT ??

*copy nlh$la_close_sap

  PROCEDURE [XDCL] nlp$la_close_sap
    (    sap_id: nat$cn_sap_id;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nlt$la_connection,
      connection_exists: boolean,
      current_subnet_entry: ^nlt$la_subnet_entry,
      layer_active: boolean,
      previous_sap_descriptor: ^^nlt$la_sap_descriptor,
      sap_descriptor: ^nlt$la_sap_descriptor,
      subnet_entry: ^nlt$la_subnet_entry;

    status.normal := TRUE;
    osp$set_job_signature_lock (nlv$la_open_sap_list.lock);
    previous_sap_descriptor := ^nlv$la_open_sap_list.sap_list;
    WHILE (previous_sap_descriptor^ <> NIL) AND (previous_sap_descriptor^^.sap_id <> sap_id) DO
      previous_sap_descriptor := ^previous_sap_descriptor^^.nextt;
    WHILEND;
    IF previous_sap_descriptor^ <> NIL THEN
      sap_descriptor := previous_sap_descriptor^;
      previous_sap_descriptor^ := sap_descriptor^.nextt;
      osp$clear_job_signature_lock (nlv$la_open_sap_list.lock);
      subnet_entry := sap_descriptor^.subnet_list;
      FREE sap_descriptor IN nav$network_paged_heap^;
      WHILE subnet_entry <> NIL DO
        IF (subnet_entry^.status = nlc$la_sap_open) OR (subnet_entry^.status = nlc$la_open_sap_confirm_wait)
              THEN
          nlp$cl_get_exclusive_via_cid (subnet_entry^.connection_id, connection_exists, cl_connection);
          IF connection_exists THEN
            nlp$cl_get_layer_connection (nlc$osi_link_access_agent, cl_connection, layer_active, connection);
            IF layer_active THEN
              disconnect_la_connection (cl_connection, sap_id, subnet_entry^.subnet_id, nlc$la_user_request);
            IFEND;
            nlp$cl_release_exclusive_access (cl_connection);
          IFEND;
        IFEND;
        current_subnet_entry := subnet_entry;
        subnet_entry := subnet_entry^.nextt;
        FREE current_subnet_entry IN nav$network_paged_heap^;
      WHILEND;
    ELSE
      osp$clear_job_signature_lock (nlv$la_open_sap_list.lock);
      osp$set_status_condition ( nae$la_sap_not_open,  status);
      osp$append_status_integer (osc$status_parameter_delimiter, sap_id, 10, TRUE, status);
    IFEND;

  PROCEND nlp$la_close_sap;

?? TITLE := '[XDCL] nlp$la_connect_event_processor', EJECT ??

*copy nlh$la_connect_event_processor

  PROCEDURE [XDCL] nlp$la_connect_event_processor
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

    VAR
      data: nlt$bm_message_id,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      disconnect_request: nlt$la_close_sap_request,
      ignore_status: ost$status;

    inventory_report := 0;
    data := event.connect.data;
    nlp$bm_release_message (data);
    disconnect_request.header.length := #SIZE (disconnect_request);
    disconnect_request.header.kind := nlc$la_close_sap_request;
    disconnect_request.reason := nlc$la_laa_detects_protocol_err;
    data_fragment [1].address := ^disconnect_request;
    data_fragment [1].length := disconnect_request.header.length;
    nlp$bm_create_message (data_fragment, data, ignore_status);
    nlp$cc_disconnect (cl_connection, data, ignore_status);

  PROCEND nlp$la_connect_event_processor;

?? TITLE := '[XDCL] nlp$la_event_processor', EJECT ??

*copy nlh$la_event_processor

  PROCEDURE [XDCL] nlp$la_event_processor
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

    VAR
      actual: integer,
      close_sap_pdu_received: boolean,
      connection: ^nlt$la_connection,
      data: nlt$bm_message_id,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      data_indication: nlt$la_data_indication,
      data_length: integer,
      device: nlt$device_identifier,
      disconnect_indication: nlt$la_disconnect_indication,
      ignore_bytes_moved: nat$data_length,
      ignore_error: boolean,
      layer_active: boolean,
      local_status: ost$status,
      log_message: string (70),
      message_length: integer,
      system_management_list: ^nlt$sm_device_list,
      open_sap_confirm: nlt$la_open_sap_confirm,
      sap_descriptor: ^nlt$la_sap_descriptor,
      source_address: nat$system_address,
      subnet_entry: ^nlt$la_subnet_entry;

    inventory_report := 0;
    nlp$cl_get_layer_connection (nlc$osi_link_access_agent, cl_connection, layer_active, connection);
    IF layer_active THEN
      CASE event.kind OF
      = nlc$cc_data_event =
        data := event.data.data;
        nlp$bm_get_message_length (data, data_length);
        IF data_length >= #SIZE (data_indication) THEN
          nlp$bm_extract_message_prefix (^data_indication, #SIZE (data_indication), data,
                ignore_bytes_moved);
          IF ((data_indication.header.length = data_length) AND
                (data_indication.header.kind = nlc$la_data_indication) AND
                (data_indication.priority_length = 0) AND (data_indication.header_format_length = 1) AND
                (data_indication.header_format = nlc$la_standard_header) AND
                (data_indication.source_subnet_addr_length = #SIZE (nat$system_identifier)) AND
                (data_indication.destination_subnet_addr_length = #SIZE (nat$system_identifier))) THEN
            source_address.network := connection^.subnet_id;
            source_address.system := data_indication.source_subnet_address;
            nav$network_procedures [connection^.event_processor].
                  cn_event_processor^ (connection^.sap_id, connection^.device_id, source_address, data);

{! statistics begin}

            IF nav$statistics_enabled THEN
              osp$increment_locked_variable (nav$global_osi_statistics.link_access_agent.pdus_received, 0,
                    actual);
              osp$add_to_locked_variable (nav$global_osi_statistics.link_access_agent.total_bytes_received, 0,
                    data_length, actual);
            IFEND;

{! statistics end}

          ELSE { LAP protocol error }
            nlp$bm_release_message (data);
            disconnect_la_connection (cl_connection, connection^.sap_id, connection^.subnet_id,
                  nlc$la_laa_detects_protocol_err);
          IFEND;
        ELSE { insufficient data }
          nlp$bm_release_message (data);
          disconnect_la_connection (cl_connection, connection^.sap_id, connection^.subnet_id,
                nlc$la_laa_detects_protocol_err);
        IFEND;

      = nlc$cc_accept_event =
        data := event.accept.data;
        nlp$bm_get_message_length (data, data_length);
        IF data_length = #SIZE (open_sap_confirm) THEN
          data_fragment [1].address := ^open_sap_confirm;
          data_fragment [1].length := #SIZE (open_sap_confirm);
          nlp$bm_flush_message (data_fragment, data, data_length, {ignore} local_status);
          IF (open_sap_confirm.header.length = data_length) AND
                (open_sap_confirm.header.kind = nlc$la_open_sap_confirm) THEN
            connection^.state := nlc$la_open;
            osp$set_job_signature_lock (nlv$la_open_sap_list.lock);
            get_sap_and_subnet_info (connection^.sap_id, connection^.subnet_id, sap_descriptor, subnet_entry);
            IF (subnet_entry <> NIL) AND (subnet_entry^.status = nlc$la_open_sap_confirm_wait) THEN
              subnet_entry^.status := nlc$la_sap_open;
              osp$clear_job_signature_lock (nlv$la_open_sap_list.lock);

{! statistics begin}

              IF nav$statistics_enabled THEN
                osp$increment_locked_variable (nav$global_osi_statistics.link_access_agent.current_saps_open,
                      0, actual);
              IFEND;

{! statistics end}

            ELSE { SAP not open }
              osp$clear_job_signature_lock (nlv$la_open_sap_list.lock);
              disconnect_la_connection (cl_connection, connection^.sap_id, connection^.subnet_id,
                    nlc$la_laa_detects_protocol_err);
            IFEND;
          ELSE { Length mismatch or invalid PDU kind }
            disconnect_la_connection (cl_connection, connection^.sap_id, connection^.subnet_id,
                  nlc$la_laa_detects_protocol_err);
          IFEND;
        ELSE { Insufficient data }
          nlp$bm_release_message (data);
          disconnect_la_connection (cl_connection, connection^.sap_id, connection^.subnet_id,
                nlc$la_laa_detects_protocol_err);
        IFEND;

      = nlc$cc_disconnect_event =
        close_sap_pdu_received := FALSE;
        IF event.disconnect.reason = nlc$cc_dr_normal_disconnect THEN
          data := event.disconnect.data;
          nlp$bm_get_message_length (data, data_length);
          IF data_length = #SIZE (disconnect_indication) THEN
            data_fragment [1].address := ^disconnect_indication;
            data_fragment [1].length := #SIZE (disconnect_indication);
            nlp$bm_flush_message (data_fragment, data, data_length, {ignore} local_status);
            IF disconnect_indication.header.length = data_length THEN
              IF disconnect_indication.header.kind = nlc$la_close_sap_indication THEN
                close_sap_pdu_received := TRUE;
              ELSEIF disconnect_indication.header.kind = nlc$la_open_sap_reject THEN
                IF NOT (disconnect_indication.reason = nlc$la_invalid_sap_id) THEN
                  nap$namve_system_error (TRUE, 'LAA - Unexpected reject reason', NIL);
                IFEND;
              ELSE
                nap$namve_system_error (TRUE, 'LAA - Unknown PDU kind on disconnect indication', NIL);
              IFEND;
            ELSE { Length mismatch }
              nap$namve_system_error (TRUE, 'LAA - Length mismatch on disconnect indication', NIL);
            IFEND;
          ELSE { Insufficient length }
            nap$namve_system_error (TRUE, 'LAA - Invalid length on disconnect indication', NIL);
            nlp$bm_release_message (data);
          IFEND;
        IFEND;
        osp$set_job_signature_lock (nlv$la_open_sap_list.lock);
        get_sap_and_subnet_info (connection^.sap_id, connection^.subnet_id, sap_descriptor, subnet_entry);
        IF subnet_entry <> NIL THEN

{! statistics begin}

          IF (nav$statistics_enabled) AND (subnet_entry^.status = nlc$la_sap_open) THEN
            osp$decrement_locked_variable (nav$global_osi_statistics.link_access_agent.current_saps_open, 1,
                  actual, ignore_error);
          IFEND;

{! statistics end}

          subnet_entry^.status := nlc$la_sap_closed;
          subnet_entry^.connection_id := nac$null_connection_id;

          IF close_sap_pdu_received THEN
            subnet_entry^.status := nlc$la_resource_constraint;
          IFEND;

        IFEND;
        osp$clear_job_signature_lock (nlv$la_open_sap_list.lock);
        nlp$cl_deactivate_layer (nlc$osi_link_access_agent, cl_connection);
      ELSE
        nap$namve_system_error (TRUE, 'LAA - Unexpected CC event', NIL);
        disconnect_la_connection (cl_connection, connection^.sap_id, connection^.subnet_id,
              nlc$la_laa_detects_protocol_err);
      CASEND;
    ELSE
      nap$namve_system_error (TRUE, 'LAA - Event received when layer inactive', NIL);
    IFEND;

  PROCEND nlp$la_event_processor;

?? TITLE := '[XDCL] nlp$la_initialize', EJECT ??

*copy nlh$la_initialize

  PROCEDURE [XDCL] nlp$la_initialize;


    VAR
      nil_event_processor: nlt$cl_event_processor;

    nlp$cl_initialize_template (nlc$osi_link_access_agent, nlc$osi_link_access_agent,
          #SIZE (nlt$la_connection), 0, nil_event_processor, nlc$la_retry_constrained_saps,
          nil_event_processor, nac$nil);
    nlp$cc_initialize_template (nlc$osi_link_access_agent);

  PROCEND nlp$la_initialize;

?? TITLE := '[XDCL] nlp$la_open_sap', EJECT ??

*copy nlh$la_open_sap

  PROCEDURE [XDCL] nlp$la_open_sap
    (    sap_id: nat$cn_sap_id;
         device_count: nlt$device_identifier;
         device_list: ^array [1 .. * ] of nlt$device_identifier;
         connection_class: nlt$cc_connection_class;
         event_processor: nat$network_procedure;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      device: nlt$device_identifier,
      system_management_list: ^nlt$sm_device_list,
      request_issued: boolean,
      sap_descriptor: ^nlt$la_sap_descriptor,
      subnet: nat$subnet_identifier,
      subnet_attribute: ^nlt$subnet_attributes,
      subnet_entry: ^nlt$la_subnet_entry;

    status.normal := TRUE;

    osp$set_job_signature_lock (nlv$la_open_sap_list.lock);
    sap_descriptor := nlv$la_open_sap_list.sap_list;
    WHILE sap_descriptor <> NIL DO
      IF sap_descriptor^.sap_id = sap_id THEN
        osp$set_status_condition ( nae$la_sap_already_open,  status);
        osp$append_status_integer (osc$status_parameter_delimiter, sap_id, 10, TRUE, status);
        osp$clear_job_signature_lock (nlv$la_open_sap_list.lock);
        RETURN;
      IFEND;
      sap_descriptor := sap_descriptor^.nextt;
    WHILEND;

    ALLOCATE sap_descriptor IN nav$network_paged_heap^;
    IF sap_descriptor <> NIL THEN
      sap_descriptor^.subnet_list := NIL;
      sap_descriptor^.sap_id := sap_id;
      sap_descriptor^.event_processor := event_processor;
      sap_descriptor^.connection_class := connection_class;
      sap_descriptor^.devices := $nlt$device_ids [];
      nlp$get_nonexclusive_access (nlv$sm_devices.access_control);
      system_management_list := nlv$sm_devices.list;

      /open_device_sap/
        FOR device := LOWERBOUND (system_management_list^) TO UPPERBOUND (system_management_list^) DO
          sap_descriptor^.devices := sap_descriptor^.devices +
                $nlt$device_ids [device_list^ [device]];
          IF (nlv$configured_network_devices.network_device_list^ [device].kind = nac$ica_2) AND
                (system_management_list^ [device].state = nlc$sm_initialized) THEN
            subnet_attribute := system_management_list^ [device].subnet_list;

          /find_subnet/
            WHILE subnet_attribute <> NIL DO
              IF (subnet_attribute^.directly_connected) THEN
                get_subnet_entry (subnet_attribute^.subnet_id, ^sap_descriptor^.subnet_list, subnet_entry);
                IF (subnet_entry^.status = nlc$la_sap_closed) OR (subnet_entry^.status =
                      nlc$la_resource_constraint) THEN
                  issue_open_sap_request (sap_descriptor, device, subnet_entry, request_issued);
                IFEND;
              IFEND;
              subnet_attribute := subnet_attribute^.next_entry;
            WHILEND /find_subnet/;
          IFEND;
        FOREND /open_device_sap/;

      nlp$release_nonexclusive_access (nlv$sm_devices.access_control);

{ Link new SAP descriptor into open SAP list.

      sap_descriptor^.nextt := nlv$la_open_sap_list.sap_list;
      nlv$la_open_sap_list.sap_list := sap_descriptor;
    ELSE { sap_descriptor = NIL }
      osp$set_status_abnormal (nac$status_id, nae$allocation_failed, 'Link Access SAP', status);
    IFEND;

    osp$clear_job_signature_lock (nlv$la_open_sap_list.lock);

  PROCEND nlp$la_open_sap;

?? TITLE := '[XDCL] nlp$la_open_saps', EJECT ??

*copy nlh$la_open_saps

  PROCEDURE [XDCL] nlp$la_open_saps
    (    device_id: nlt$device_identifier;
         subnet_count: nat$subnet_identifier;
         subnet_list: ^array [1 .. * ] of nat$subnet_identifier);

    VAR
      cl_connection: ^nlt$cl_connection,
      ignore_request_issued: boolean,
      ignore_status: ost$status,
      sap_descriptor: ^nlt$la_sap_descriptor,
      subnet: nat$subnet_identifier,
      subnet_entry: ^nlt$la_subnet_entry;


    osp$set_job_signature_lock (nlv$la_open_sap_list.lock);
    sap_descriptor := nlv$la_open_sap_list.sap_list;
    WHILE sap_descriptor <> NIL DO
      IF device_id IN sap_descriptor^.devices THEN

      /find_subnet/
        FOR subnet := 1 TO subnet_count DO
          get_subnet_entry (subnet_list^ [subnet], ^sap_descriptor^.subnet_list, subnet_entry);
          IF (subnet_entry^.status = nlc$la_sap_closed) OR (subnet_entry^.status =
                  nlc$la_resource_constraint) THEN
              issue_open_sap_request (sap_descriptor, device_id, subnet_entry, ignore_request_issued);
          IFEND;
        FOREND /find_subnet/;
      IFEND;
      sap_descriptor := sap_descriptor^.nextt;
    WHILEND;
    osp$clear_job_signature_lock (nlv$la_open_sap_list.lock);

  PROCEND nlp$la_open_saps;

?? TITLE := '[XDCL] nlp$la_retry_constrained_saps', EJECT ??

*copy nlh$la_retry_constrained_saps

  PROCEDURE [XDCL] nlp$la_retry_constrained_saps
    (    current_time: integer);

    VAR
      cl_connection: ^nlt$cl_connection,
      device: nlt$device_identifier,
      ignore_status: ost$status,
      system_management_list: ^nlt$sm_device_list,
      request_issued: boolean,
      sap_descriptor: ^nlt$la_sap_descriptor,
      subnet: nat$subnet_identifier,
      subnet_attribute: ^nlt$subnet_attributes,
      subnet_entry: ^nlt$la_subnet_entry;


    osp$set_job_signature_lock (nlv$la_open_sap_list.lock);
    sap_descriptor := nlv$la_open_sap_list.sap_list;
    nlp$get_nonexclusive_access (nlv$sm_devices.access_control);
    system_management_list := nlv$sm_devices.list;
    WHILE sap_descriptor <> NIL DO
      subnet_entry := sap_descriptor^.subnet_list;
      WHILE subnet_entry <> NIL DO
        IF subnet_entry^.status = nlc$la_resource_constraint THEN
          subnet_entry^.status := nlc$la_sap_closed;

        /open_device_sap/
          FOR device := LOWERBOUND (system_management_list^) TO UPPERBOUND (system_management_list^) DO
            IF (nlv$configured_network_devices.network_device_list^ [device].kind = nac$ica_2) AND
                  (system_management_list^ [device].device_id IN sap_descriptor^.devices) AND
                  (system_management_list^ [device].state = nlc$sm_initialized) THEN
              subnet_attribute := system_management_list^ [device].subnet_list;

            /find_subnet/
              WHILE subnet_attribute <> NIL DO
                IF (subnet_attribute^.directly_connected) AND (subnet_attribute^.subnet_id =
                      subnet_entry^.subnet_id) THEN
                  issue_open_sap_request (sap_descriptor, device, subnet_entry, request_issued);
                  IF request_issued THEN
                    EXIT /open_device_sap/;
                  ELSE
                    EXIT /find_subnet/;
                  IFEND;
                IFEND;
                subnet_attribute := subnet_attribute^.next_entry;
              WHILEND /find_subnet/;
            IFEND;
          FOREND /open_device_sap/;
        IFEND;
        subnet_entry := subnet_entry^.nextt;
      WHILEND;
      sap_descriptor := sap_descriptor^.nextt;
    WHILEND;
    nlp$release_nonexclusive_access (nlv$sm_devices.access_control);
    osp$clear_job_signature_lock (nlv$la_open_sap_list.lock);

  PROCEND nlp$la_retry_constrained_saps;

?? TITLE := '[XDCL] nlp$la_send_data', EJECT ??

*copy nlh$la_send_data

  PROCEDURE [XDCL] nlp$la_send_data
    (    sap_id: nat$cn_sap_id;
         subnet_id: nat$subnet_identifier;
         destination_subnet_address: nat$system_identifier;
         header_format: nlt$la_header_format;
         priority: nlt$la_priority;
         data: nlt$bm_message_id;
     VAR status: ost$status);

    VAR
      actual: integer,
      cl_connection: ^nlt$cl_connection,
      connection: ^nlt$la_connection,
      connection_exists: boolean,
      data_length: integer,
      data_request: nlt$la_data_request,
      layer_active: boolean,
      local_status: ost$status,
      release_message: boolean,
      sap_descriptor: ^nlt$la_sap_descriptor,
      send_data: nlt$bm_message_id,
      subnet_entry: ^nlt$la_subnet_entry;

    status.normal := TRUE;
    release_message := TRUE;
    send_data := data;

    osp$set_job_signature_lock (nlv$la_open_sap_list.lock);
    get_sap_and_subnet_info (sap_id, subnet_id, sap_descriptor, subnet_entry);
    IF subnet_entry <> NIL THEN
      IF subnet_entry^.status = nlc$la_sap_open THEN
        osp$clear_job_signature_lock (nlv$la_open_sap_list.lock);
        nlp$cl_get_exclusive_via_cid (subnet_entry^.connection_id, connection_exists, cl_connection);
        IF connection_exists THEN
          nlp$bm_get_message_length (send_data, data_length);
          data_request.header.length := data_length + #SIZE (data_request);
          nlp$cl_get_layer_connection (nlc$osi_link_access_agent, cl_connection, layer_active, connection);
          IF layer_active THEN
            data_request.header.kind := nlc$la_data_request;
            data_request.priority_length := 1;
            data_request.priority := priority;
            data_request.header_format_length := 1;
            data_request.header_format := header_format;
            data_request.destination_sap := sap_id;
            data_request.destination_subnet_addr_length := #SIZE (destination_subnet_address);
            data_request.destination_subnet_address := destination_subnet_address;
            nlp$bm_add_message_prefix (^data_request, #SIZE (data_request), send_data);
            nlp$cc_send_data (cl_connection, send_data, {ignore} status);
            release_message := FALSE;

{! statistics begin}

              IF nav$statistics_enabled THEN
                osp$increment_locked_variable (nav$global_osi_statistics.link_access_agent.pdus_sent, 0,
                      actual);
                osp$add_to_locked_variable (nav$global_osi_statistics.link_access_agent.total_bytes_sent, 0,
                      #SIZE(data_request), actual);
              IFEND;

{! statistics end}

          IFEND;
          nlp$cl_release_exclusive_access (cl_connection);
        IFEND;
      ELSE { subnet_entry^.status <> nlc$la_sap_open }
        osp$clear_job_signature_lock (nlv$la_open_sap_list.lock);
      IFEND;
    ELSE { SAP not open }
      osp$clear_job_signature_lock (nlv$la_open_sap_list.lock);
      osp$set_status_condition ( nae$la_sap_not_open,  status);
      osp$append_status_integer (osc$status_parameter_delimiter, sap_id, 10, TRUE, status);
    IFEND;
    IF release_message THEN
      nlp$bm_release_message (send_data);
    IFEND;

  PROCEND nlp$la_send_data;

?? TITLE := 'disconnect_la_connection', EJECT ??

{
{ PURPOSE:
{   The purpose of this request is to disconnect the specified
{   Link Access (LA) connection, deactivate the LAA layer, and
{   close the device SAP.
{

  PROCEDURE disconnect_la_connection
    (    cl_connection: ^nlt$cl_connection;
         sap_id: nat$cn_sap_id;
         subnet_id: nat$subnet_identifier;
         close_sap_reason: nlt$la_close_request_reason);

    VAR
      actual: integer,
      close_sap_request: nlt$la_close_sap_request,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      data: nlt$bm_message_id,
      ignore_error: boolean,
      ignore_status: ost$status,
      sap_descriptor: ^nlt$la_sap_descriptor,
      subnet_entry: ^nlt$la_subnet_entry;


    osp$set_job_signature_lock (nlv$la_open_sap_list.lock);
    get_sap_and_subnet_info (sap_id, subnet_id, sap_descriptor, subnet_entry);
    IF subnet_entry <> NIL THEN

{! statistics begin}

      IF (nav$statistics_enabled) AND (subnet_entry^.status = nlc$la_sap_open) THEN
        osp$decrement_locked_variable (nav$global_osi_statistics.link_access_agent.current_saps_open, 1,
              actual, ignore_error);
      IFEND;

{! statistics end}

      subnet_entry^.status := nlc$la_sap_closed;
      subnet_entry^.connection_id := nac$null_connection_id;
    IFEND;
    osp$clear_job_signature_lock (nlv$la_open_sap_list.lock);
    close_sap_request.header.length := #SIZE (close_sap_request);
    close_sap_request.header.kind := nlc$la_close_sap_request;
    close_sap_request.reason := close_sap_reason;
    data_fragment [1].address := ^close_sap_request;
    data_fragment [1].length := close_sap_request.header.length;
    nlp$bm_create_message (data_fragment, data, ignore_status);
    nlp$cc_disconnect (cl_connection, data, ignore_status);
    nlp$cl_deactivate_layer (nlc$osi_link_access_agent, cl_connection);

  PROCEND disconnect_la_connection;

?? TITLE := 'get_sap_and_subnet_info', EJECT ??

{
{ PURPOSE:
{   The purpose of this request is to find and return the Link Access (LA)
{   SAP descriptor and the subnet entry.
{
{  NOTE: At least non-exclusive access to NLV$LA_OPEN_SAP_LIST is required upon entry.
{



  PROCEDURE [INLINE] get_sap_and_subnet_info
    (    sap_id: nat$cn_sap_id;
         subnet_id: nat$subnet_identifier;
     VAR sap_descriptor: ^nlt$la_sap_descriptor;
     VAR subnet_entry: ^nlt$la_subnet_entry);


    sap_descriptor := nlv$la_open_sap_list.sap_list;
    WHILE (sap_descriptor <> NIL) AND (sap_descriptor^.sap_id <> sap_id) DO
      sap_descriptor := sap_descriptor^.nextt;
    WHILEND;
    IF sap_descriptor <> NIL THEN
      subnet_entry := sap_descriptor^.subnet_list;
      WHILE (subnet_entry <> NIL) AND (subnet_entry^.subnet_id <> subnet_id) DO
        subnet_entry := subnet_entry^.nextt;
      WHILEND;
    ELSE
      subnet_entry := NIL;
    IFEND;

  PROCEND get_sap_and_subnet_info;
?? OLDTITLE ??
?? NEWTITLE := 'get_subnet_entry', EJECT ??
  PROCEDURE get_subnet_entry
    (    subnet_id: nat$subnet_identifier;
         subnet_list {input, output} : ^^nlt$la_subnet_entry;
     VAR subnet_entry: ^nlt$la_subnet_entry);

{ PURPOSE:
{   The purpose of this procedure is to return the subnet entry
{   corresponding to the specified subnet identifier. If the
{   requested subnet entry does not exists it will be allocated.

    VAR
      current_subnet_entry: ^^nlt$la_subnet_entry;

    current_subnet_entry := subnet_list;
    WHILE (current_subnet_entry^ <> NIL) AND (current_subnet_entry^^.subnet_id <> subnet_id) DO
      current_subnet_entry := ^current_subnet_entry^^.nextt;
    WHILEND;

    IF current_subnet_entry^ <> NIL THEN
      subnet_entry := current_subnet_entry^;
    ELSE
      REPEAT
        ALLOCATE subnet_entry IN nav$network_paged_heap^;
        IF subnet_entry = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL subnet_entry <> NIL;
      subnet_entry^.status := nlc$la_sap_closed;
      subnet_entry^.subnet_id := subnet_id;
      subnet_entry^.connection_id := nac$null_connection_id;
      subnet_entry^.nextt := NIL;
      current_subnet_entry^ := subnet_entry;
    IFEND;

  PROCEND get_subnet_entry;
?? OLDTITLE ??
?? NEWTITLE := 'issue_open_sap_request', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to send a Link Access (LA) open SAP
{   request over a Channel Connection to the Link Access Provider (LAP) in the
{   specified device. This procedure only issues the request (or at least attempts
{   to issue a request), it does not wait for an accept or reject from LAP.
{

  PROCEDURE issue_open_sap_request
    (    sap_descriptor: ^nlt$la_sap_descriptor;
         device_id: nlt$device_identifier;
         subnet_entry: ^nlt$la_subnet_entry;
     VAR request_issued: boolean);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nlt$la_connection,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      device_and_data_list: ^nlt$cc_device_and_data_list,
      ignore_layer_active: boolean,
      local_status: ost$status,
      open_sap_request: nlt$la_open_sap_request;

    local_status.normal := TRUE;
    request_issued := FALSE;
    nlp$cl_create_connection (nlc$osi_link_access_agent, cl_connection);
    IF cl_connection <> NIL THEN
      open_sap_request.header.length := #SIZE (open_sap_request);
      open_sap_request.header.kind := nlc$la_open_sap_request;
      open_sap_request.sap_id := sap_descriptor^.sap_id;
      open_sap_request.subnet_id := subnet_entry^.subnet_id;
      data_fragment [1].address := ^open_sap_request;
      data_fragment [1].length := open_sap_request.header.length;
      PUSH device_and_data_list: [ 1 .. 1];
      device_and_data_list^ [1].device_id := device_id;
      nlp$bm_create_message (data_fragment, device_and_data_list^ [1].data, {ignore} local_status);
      nlp$cc_request_connection (cl_connection, device_and_data_list^, nlc$link_access_address,
            sap_descriptor^.connection_class, local_status);
      IF local_status.normal THEN
        request_issued := TRUE;
        nlp$cl_activate_layer (nlc$osi_link_access_agent, cl_connection);
        nlp$cl_get_layer_connection (nlc$osi_link_access_agent, cl_connection, ignore_layer_active,
              connection);
        subnet_entry^.status := nlc$la_open_sap_confirm_wait;
        subnet_entry^.connection_id := cl_connection^.identifier;
        connection^.sap_id := sap_descriptor^.sap_id;
        connection^.subnet_id := subnet_entry^.subnet_id;
        connection^.device_id := device_id;
        connection^.state := nlc$la_connect_confirm_wait;
        connection^.event_processor := sap_descriptor^.event_processor;
      ELSEIF local_status.condition = nae$resources_unavailable THEN
        subnet_entry^.status := nlc$la_resource_constraint;
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE { cl_connection = NIL }
      subnet_entry^.status := nlc$la_resource_constraint;
    IFEND;
  PROCEND issue_open_sap_request;

MODEND nlm$link_access_agent;
*DECK DECK=NLM$NETWORK_ACCESS_AGENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access: Network Access Agent' ??
MODULE nlm$network_access_agent;

{ PURPOSE:
{   This module contains procedures necessary to communicate with the Network Access
{   Provider (NAP) in the OSI communications device. These procedures provide the OSI
{   Network Access Agent (NAA) in the host.
{ DESIGN:
{   The NAA and the NAP together enable a user in the host to obtain the services of
{   the OSI Connection Less Mode Network Layer in the device. The network layer user
{   in the host can open a network sap via the NAA/NAP. The NAA sends the open sap
{   request to all the devices directly connected to the host. Each open sap request
{   establishes a channel connection between the NAA and the NAP. The subsequent data
{   requests and indications sent and received over a network sap are sent and received
{   over the channel connection.
{   The NAA provides interfaces to open/close network layer saps and to send and receive
{   data over these saps. A single open sap request results in opening the sap over all the
{   directy connected devices that have been initialized via System Management Access Agent.
{   The NAA also provides a broadcast capability.
{   When a directly connected network device becomes unavailable, all network saps opened
{   across the device are closed. When the device becomes available again, the System
{   Management Access Agent will send open sap requests to the NAP for all network layer
{   saps that have been opened in the host.
{   This module contains code that executes in ring 3. It resides on OSF$JOB_TEMPLATE_23D.
{   The XDCL'd procedures have been grouped in alphabetical order followed by the internal
{   procedures. The internal procedures are also in alphabetical order.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nac$null_connection_id
*copyc nac$xi_maximum_data_length
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nae$network_access_agent
*copyc nat$connection_id
*copyc nat$network_message_priority
*copyc nat$network_procedures
*copyc nat$osi_network_address
*copyc nat$osi_network_address_prefix
*copyc nlt$cc_address
*copyc nlt$cc_connection_class
*copyc nlt$cc_device_and_data_list
*copyc nlt$cc_disconnect_reason
*copyc nlt$cc_interface
*copyc nlt$cl_connection
*copyc nlt$cl_connection_layer_templat
*copyc nlt$cl_layer_name
*copyc nlt$device_count
*copyc nlt$device_identifier
*copyc nlt$device_list
*copyc nlt$na_disconnect_reason
*copyc nlt$na_layer_connection
*copyc nlt$na_protocol_data_unit
*copyc nlt$na_sap_attributes
*copyc nlt$network_device
*copyc nlt$sm_devices
*copyc ost$signature_lock_status
*copyc ost$status
?? POP ??
*copyc nap$display_message
*copyc nap$namve_system_error
*copyc nlp$al_get_data_length
*copyc nlp$bm_create_message
*copyc nlp$bm_extract_message_prefix
*copyc nlp$bm_flush_message
*copyc nlp$bm_get_message_length
*copyc nlp$bm_release_message
*copyc nlp$cc_disconnect
*copyc nlp$cc_initialize_template
*copyc nlp$cc_request_connection
*copyc nlp$cc_send_data
*copyc nlp$cl_activate_layer
*copyc nlp$cl_create_connection
*copyc nlp$cl_deactivate_layer
*copyc nlp$cl_get_exclusive_via_cid
*copyc nlp$cl_get_layer_connection
*copyc nlp$cl_initialize_template
*copyc nlp$cl_release_exclusive_access
*copyc nlp$get_exclusive_access
*copyc nlp$get_nonexclusive_access
*copyc nlp$release_exclusive_access
*copyc nlp$release_nonexclusive_access
*copyc osp$add_to_locked_variable
*copyc osp$append_status_integer
*copyc osp$clear_job_signature_lock
*copyc osp$decrement_locked_variable
*copyc osp$increment_locked_variable
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$log
*copyc nav$cdna_multicast_address
*copyc nav$global_osi_statistics
*copyc nav$network_paged_heap
*copyc nav$network_procedures
*copyc nav$statistics_enabled
*copyc nlv$configured_network_devices
*copyc nlv$na_sap_list
*copyc nlv$sm_devices
*copyc nlv$transport_network_selector
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$na_broadcast_data', EJECT ??
*copy nlh$na_broadcast_data

  PROCEDURE [XDCL] nlp$na_broadcast_data
    (    device_id: nlt$device_identifier;
         source_sap_id: nat$network_selector;
         destination_sap_id: nat$network_selector;
         data: nat$data_fragments;
     VAR status: ost$status);

    VAR
      actual: integer,
      address_prefix: ^nat$osi_network_address_prefix,
      cl_connection: ^nlt$cl_connection,
      connection: ^nlt$na_layer_connection,
      connection_exists: boolean,
      connection_id: nat$connection_id,
      data_fragments: ^nat$data_fragments,
      data_length: nat$data_length,
      data_request_fixed: nlt$na_data_request_fixed,
      destination_address: ^SEQ ( * ),
      destination_address_seq: ^SEQ ( * ),
      i: integer,
      ignore_status: ost$status,
      layer_active: boolean,
      log_message: ^string (132),
      log_message_length: integer,
      system_management_list: ^nlt$sm_device_list,
      sap_attributes: ^nlt$na_sap_attributes,
      subnet_attributes: ^nlt$subnet_attributes,
      subnet_id: ^nat$subnet_identifier,
      system_id: ^nat$system_identifier,
      total_bytes_sent: integer,
      unused_byte_count: 0 .. 0ff(16),
      unused_portion: ^array [ * ] of 0 .. 0ff(16),
      user_data: nlt$bm_message_id;

    status.normal := TRUE;
    nlp$al_get_data_length (data, data_length);
    IF data_length <= nac$xi_maximum_data_length THEN
      data_request_fixed.header.kind := nlc$na_data_request;

{ Setup the data fragments with the first three entries for the fixed sized
{ NA header and the variable sized destination address.

      PUSH data_fragments: [1 .. (UPPERBOUND (data) + 3)];
      data_fragments^ [1].address := ^data_request_fixed;
      data_fragments^ [1].length := #SIZE (data_request_fixed);

{ Reserve the second entry for the variable sized destination address (without the
{ network selector) and the third entry for the network selector.
{ Move the remaining entries for the user data.

      data_fragments^ [3].address := ^destination_sap_id;
      data_fragments^ [3].length := #SIZE (destination_sap_id);
      FOR i := 1 TO UPPERBOUND (data) DO
        data_fragments^ [i + 3] := data [i];
      FOREND;


{ Verify that the source sap is open.

      osp$set_job_signature_lock (nlv$na_sap_list.lock);
      find_sap_attributes (source_sap_id, sap_attributes);
      IF (sap_attributes <> NIL) AND (sap_attributes^.sap_device_list [device_id].status =
            nlc$na_sap_open) THEN
        connection_id := sap_attributes^.sap_device_list [device_id].connection_id;
        data_request_fixed.priority := sap_attributes^.priority;
        osp$clear_job_signature_lock (nlv$na_sap_list.lock);

        PUSH destination_address_seq: [[REP nac$osi_max_network_address_len OF cell]];
        RESET destination_address_seq;

{ Broadcast the data on each subnet accessible via the given device.

        data_length := data_length + #SIZE (data_request_fixed) + #SIZE (destination_sap_id);
        total_bytes_sent := 0;
        nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
        IF connection_exists THEN
          nlp$cl_get_layer_connection (nlc$osi_network_access_agent, cl_connection, layer_active, connection);
          IF layer_active THEN
            nlp$get_nonexclusive_access (nlv$sm_devices.access_control);
            system_management_list := nlv$sm_devices.list;

{ Verify that the device has been initialized via system mgmt protocol.

            IF system_management_list^ [device_id].state = nlc$sm_initialized THEN

{ Initialize the default destination address. This address will be used to broadcast
{ over subnets that do not have an associated multicast address.
{ Note that the network selector is being setup as a separate fragment.

            NEXT destination_address: [[REP (system_management_list^ [device_id].
                  network_address_length - #SIZE (destination_sap_id)) OF cell]] IN destination_address_seq;
            RESET destination_address;
            NEXT address_prefix: [#SIZE (system_management_list^ [device_id].
                  network_address_prefix^)] IN destination_address;
            address_prefix^ := system_management_list^ [device_id].network_address_prefix^;
            unused_byte_count := (#SIZE (destination_address^) - #SIZE (address_prefix^) -
                  #SIZE (nat$subnet_identifier) - #SIZE (nat$system_identifier));
            IF unused_byte_count > 0 THEN
              NEXT unused_portion: [1 .. unused_byte_count] IN destination_address;
              FOR i := 1 TO UPPERBOUND (unused_portion^) DO
                unused_portion^ [i] := 0;
              FOREND;
            IFEND;

{ The following pointers should not be changed after they have been initialized.

            NEXT subnet_id IN destination_address;
            NEXT system_id IN destination_address;

{ Broadcast over each subnet accessible via this device.

            subnet_attributes := system_management_list^ [device_id].subnet_list;

          /broadcast_loop/
            WHILE subnet_attributes <> NIL DO
              IF subnet_attributes^.multicast_address <> NIL THEN
                data_fragments^ [2].address := subnet_attributes^.multicast_address;
                data_fragments^ [2].length := #SIZE (subnet_attributes^.multicast_address^) -
                      #SIZE (destination_sap_id);
              ELSE

{ Setup the multicast address using the CDNA multicast address.

                subnet_id^ := subnet_attributes^.subnet_id;
                system_id^ := nav$cdna_multicast_address;
                data_fragments^ [2].address := destination_address;
                data_fragments^ [2].length := #SIZE (destination_address^);
              IFEND;

              data_request_fixed.header.length := data_length + data_fragments^ [2].length;
              data_request_fixed.destination_address_length := data_fragments^ [2].
                    length + #SIZE (destination_sap_id);
              nlp$bm_create_message (data_fragments^, user_data, ignore_status);
              nlp$cc_send_data (cl_connection, user_data, ignore_status);
              total_bytes_sent := total_bytes_sent + data_request_fixed.header.length;
              subnet_attributes := subnet_attributes^.next_entry;
            WHILEND /broadcast_loop/;
            IFEND;
            nlp$release_nonexclusive_access (nlv$sm_devices.access_control);
          IFEND;
          nlp$cl_release_exclusive_access (cl_connection);

{! statistics begin

          IF nav$statistics_enabled THEN
            osp$increment_locked_variable (nav$global_osi_statistics.network_access_agent.broadcasts_sent, 0,
                  actual);
            IF total_bytes_sent > 0 THEN
              osp$add_to_locked_variable (nav$global_osi_statistics.network_access_agent.total_bytes_sent, 0,
                    total_bytes_sent, actual);
            IFEND;
          IFEND;

{! statistics end
        IFEND;

      ELSE { Sap not open
        osp$clear_job_signature_lock (nlv$na_sap_list.lock);
        osp$set_status_condition ( nae$na_sap_not_open,  status);
        osp$append_status_integer (osc$status_parameter_delimiter, source_sap_id, 10, TRUE, status);
      IFEND;
    ELSE { Max data length exceeded
      osp$set_status_condition ( nae$max_data_length_exceeded,  status);
      osp$append_status_integer (osc$status_parameter_delimiter, data_length, 10, TRUE, status);
    IFEND;

  PROCEND nlp$na_broadcast_data;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$na_close_sap', EJECT ??
*copy nlh$na_close_sap

  PROCEDURE [XDCL] nlp$na_close_sap
    (    sap_id: nat$network_selector;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      i: integer,
      previous_sap_attributes: ^^nlt$na_sap_attributes,
      sap_attributes: ^nlt$na_sap_attributes,
      sap_device_list: ^nlt$na_sap_device_list;

    status.normal := TRUE;
    osp$set_job_signature_lock (nlv$na_sap_list.lock);
    IF nlv$na_sap_list.open_saps [sap_id] THEN
      nlv$na_sap_list.open_saps [sap_id] := FALSE;

{ Find the sap attributes entry for the given sap_id.

      previous_sap_attributes := ^nlv$na_sap_list.sap_attributes;
      WHILE (previous_sap_attributes^ <> NIL) AND (previous_sap_attributes^^.sap_id <> sap_id) DO
        previous_sap_attributes := ^previous_sap_attributes^^.next_entry;
      WHILEND;
      IF previous_sap_attributes^ <> NIL THEN

{ Delink the sap attributes entry from the sap list.

        sap_attributes := previous_sap_attributes^;
        previous_sap_attributes^ := sap_attributes^.next_entry;
        osp$clear_job_signature_lock (nlv$na_sap_list.lock);

{ Close the sap in the devices.

        sap_device_list := ^sap_attributes^.sap_device_list;
        FOR i := LOWERBOUND (sap_device_list^) TO UPPERBOUND (sap_device_list^) DO
          IF (sap_device_list^ [i].status = nlc$na_sap_open) OR
                (sap_device_list^ [i].status = nlc$na_await_open_sap_confirm) THEN
            nlp$cl_get_exclusive_via_cid (sap_device_list^ [i].connection_id, connection_exists,
                  cl_connection);
            IF connection_exists THEN
              disconnect_na_connection (cl_connection, nlc$na_dr_user_request);
              nlp$cl_release_exclusive_access (cl_connection);
            IFEND;
          IFEND;
        FOREND;
        FREE sap_attributes IN nav$network_paged_heap^;
      ELSE {Lost the sap attributes entry
        osp$clear_job_signature_lock (nlv$na_sap_list.lock);
        osp$set_status_condition ( nae$na_sap_not_open,  status);
        osp$append_status_integer (osc$status_parameter_delimiter, sap_id, 10, TRUE, status);
        nap$namve_system_error (FALSE, 'NAA - Lost an open sap entry.', ^status);
      IFEND;
    ELSE { Sap not open
      osp$clear_job_signature_lock (nlv$na_sap_list.lock);
      osp$set_status_condition ( nae$na_sap_not_open,  status);
      osp$append_status_integer (osc$status_parameter_delimiter, sap_id, 10, TRUE, status);
    IFEND;

  PROCEND nlp$na_close_sap;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$na_connect_event_processor', EJECT ??
*copy nlh$na_connect_event_processor

  PROCEDURE [XDCL] nlp$na_connect_event_processor
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

    VAR
      data: nlt$bm_message_id,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      disconnect_request: nlt$na_close_sap_request,
      ignore_status: ost$status;

    inventory_report := 0;
    disconnect_request.header.kind := nlc$na_close_sap_request;
    disconnect_request.header.length := #SIZE (disconnect_request);
    disconnect_request.reason := nlc$na_dr_unexpected_event;
    data_fragment [1].address := ^disconnect_request;
    data_fragment [1].length := disconnect_request.header.length;
    nlp$bm_create_message (data_fragment, data, ignore_status);
    nlp$cc_disconnect (cl_connection, data, ignore_status);

{ Release connect data.

    data := event.connect.data;
    nlp$bm_release_message (data);

  PROCEND nlp$na_connect_event_processor;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$na_disconnect_connections', EJECT ??
*copy nlh$na_disconnect_connections

  PROCEDURE [XDCL] nlp$na_disconnect_connections (device_id: nlt$device_identifier);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nlt$na_layer_connection,
      connection_count:  integer,
      connection_exists: boolean,
      connection_list: ^array [1..*] of nat$connection_id,
      i: integer,
      layer_active: boolean,
      local_status: ost$status,
      sap_attributes: ^nlt$na_sap_attributes,
      sap_count: integer;

    connection_count := 0;
    sap_count := 0;

{ Get the list of all active network access connections.

    osp$set_job_signature_lock (nlv$na_sap_list.lock);
    sap_attributes := nlv$na_sap_list.sap_attributes;
    WHILE sap_attributes <> NIL DO
      sap_count := sap_count + 1;
      sap_attributes := sap_attributes^.next_entry;
    WHILEND;

    IF sap_count > 0 THEN
      PUSH connection_list : [1 .. sap_count];
      sap_attributes := nlv$na_sap_list.sap_attributes;
      WHILE sap_attributes <> NIL DO
        IF (sap_attributes^.sap_device_list [device_id].status = nlc$na_sap_open) OR
          (sap_attributes^.sap_device_list [device_id].status =
           nlc$na_await_open_sap_confirm) THEN
          connection_count := connection_count + 1;
          connection_list^[connection_count] := sap_attributes^.sap_device_list[device_id].
            connection_id;
        IFEND;
        sap_attributes := sap_attributes^.next_entry;
      WHILEND;
    IFEND;
    osp$clear_job_signature_lock (nlv$na_sap_list.lock);

{ Disconnect all network access connections.

    IF connection_count > 0 THEN
      FOR i := 1 TO connection_count DO
        nlp$cl_get_exclusive_via_cid (connection_list^[i], connection_exists, cl_connection);
        IF connection_exists THEN
          nlp$cl_get_layer_connection (nlc$osi_network_access_agent, cl_connection, layer_active, connection);
          IF layer_active THEN
            disconnect_na_connection (cl_connection, nlc$na_dr_sme_disconnect);;
          IFEND;
          nlp$cl_release_exclusive_access (cl_connection);
        IFEND;
      FOREND;

{ Clear the connection ids and update sap status in the sap list.
{ Note that in the meantime while the sap list was unlocked,
{ no additional saps could have been opened across the device
{ on account of the system mgmt initialization status in the
{ network device list entry.

      osp$set_job_signature_lock (nlv$na_sap_list.lock);
      sap_attributes := nlv$na_sap_list.sap_attributes;
      WHILE sap_attributes <> NIL DO
        sap_attributes^.sap_device_list [device_id].status := nlc$na_sap_closed;
        sap_attributes^.sap_device_list [device_id].connection_id := nac$null_connection_id;
        sap_attributes := sap_attributes^.next_entry;
      WHILEND;
      osp$clear_job_signature_lock (nlv$na_sap_list.lock);
    IFEND;

  PROCEND nlp$na_disconnect_connections;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$na_event_processor', EJECT ??
*copy nlh$na_event_processor

  PROCEDURE [XDCL] nlp$na_event_processor
    (    cl_connection { input, output }: ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);


    VAR
      accept_indication: nlt$na_pdu_header,
      actual: integer,
      connection: ^nlt$na_layer_connection,
      data: nlt$bm_message_id,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      data_indication_fixed: nlt$na_data_indication_fixed,
      data_length: integer,
      disconnect_indication: nlt$na_disconnect_indication,
      error_message: ^string (132),
      error_message_length: integer,
      ignore_bytes_moved: nat$data_length,
      layer_active: boolean,
      local_status: ost$status,
      sap_attributes: ^nlt$na_sap_attributes,
      source_address: ^nat$osi_network_address;

    inventory_report := 0;
    nlp$cl_get_layer_connection (nlc$osi_network_access_agent, cl_connection, layer_active, connection);
    IF layer_active THEN
      CASE event.kind OF
?? NEWTITLE := 'nlc$cc_data_event', EJECT ??
      = nlc$cc_data_event =
        data := event.data.data;
        nlp$bm_get_message_length (data, data_length);
        IF data_length > #SIZE (data_indication_fixed) THEN
          nlp$bm_extract_message_prefix (^data_indication_fixed, #SIZE (data_indication_fixed), data,
                ignore_bytes_moved);
          IF data_indication_fixed.header.kind = nlc$na_data_indication THEN
            IF (data_indication_fixed.header.length = data_length) AND
                  (data_indication_fixed.source_address_length > 0) AND
                  (data_length > (#SIZE (data_indication_fixed) +
                  data_indication_fixed.source_address_length)) THEN
              PUSH source_address: [[REP data_indication_fixed.source_address_length OF cell]];
              nlp$bm_extract_message_prefix (source_address, #SIZE (source_address^), data,
                    ignore_bytes_moved);

{ Call the event handler to deliver the user data.

              nav$network_procedures [connection^.event_processor].
                    network_event_processor^ (connection^.sap_id, source_address^, connection^.device_id,
                    data);

{! statistics begin

              IF nav$statistics_enabled THEN
                osp$increment_locked_variable (nav$global_osi_statistics.network_access_agent.pdus_received,
                      0, actual);
                osp$add_to_locked_variable (nav$global_osi_statistics.network_access_agent.
                      total_bytes_received, 0, data_length, actual);
              IFEND;

{! statistics end

            ELSE { Unexpected length
              nlp$bm_release_message (data);
              disconnect_na_connection (cl_connection, nlc$na_dr_unexpected_length);
              update_sap_status (connection^.sap_id, connection^.device_id);
            IFEND;
          ELSE { Invalid NA event kind
            nlp$bm_release_message (data);
            disconnect_na_connection (cl_connection, nlc$na_dr_unexpected_event);
            update_sap_status (connection^.sap_id, connection^.device_id);
          IFEND;
        ELSE { Insufficient data
          nlp$bm_release_message (data);
          disconnect_na_connection (cl_connection, nlc$na_dr_insufficient_data);
          update_sap_status (connection^.sap_id, connection^.device_id);
        IFEND;
?? OLDTITLE ??
?? NEWTITLE := 'nlc$cc_accept_event', EJECT ??
      = nlc$cc_accept_event =
        data := event.accept.data;
        nlp$bm_get_message_length (data, data_length);
        IF data_length = #SIZE (accept_indication) THEN
          data_fragment [1].address := ^accept_indication;
          data_fragment [1].length := #SIZE (accept_indication);
          nlp$bm_flush_message (data_fragment, data, data_length, {ignore} local_status);
          IF data_length = accept_indication.length THEN
            IF accept_indication.kind = nlc$na_open_sap_confirm THEN
              osp$set_job_signature_lock (nlv$na_sap_list.lock);
              find_sap_attributes (connection^.sap_id, sap_attributes);
              IF sap_attributes <> NIL THEN
                IF sap_attributes^.sap_device_list [connection^.device_id].status =
                      nlc$na_await_open_sap_confirm THEN
                  sap_attributes^.sap_device_list [connection^.device_id].status := nlc$na_sap_open;
                  osp$clear_job_signature_lock (nlv$na_sap_list.lock);
                  connection^.state := nlc$na_connection_open;
                ELSE { Unexpected NA event
                  osp$clear_job_signature_lock (nlv$na_sap_list.lock);
                  disconnect_na_connection (cl_connection, nlc$na_dr_unexpected_event);
                  update_sap_status (connection^.sap_id, connection^.device_id);
                IFEND;
              ELSE

{ Sap must have been closed in the meantime.

                osp$clear_job_signature_lock (nlv$na_sap_list.lock);
              IFEND;
            ELSE { Unexpected NA event
              disconnect_na_connection (cl_connection, nlc$na_dr_unexpected_event);
              update_sap_status (connection^.sap_id, connection^.device_id);
            IFEND;
          ELSE { Length mismatch
            disconnect_na_connection (cl_connection, nlc$na_dr_length_mismatch);
            update_sap_status (connection^.sap_id, connection^.device_id);
          IFEND;
        ELSE { Unexpected length
          nlp$bm_release_message (data);
          disconnect_na_connection (cl_connection, nlc$na_dr_unexpected_length);
          update_sap_status (connection^.sap_id, connection^.device_id);
        IFEND;
?? OLDTITLE ??
?? NEWTITLE := 'nlc$cc_disconnect_event', EJECT ??
      = nlc$cc_disconnect_event =
        osp$set_job_signature_lock (nlv$na_sap_list.lock);

{ Ignore if sap entry not found. The sap may have been closed in the meantime.

        find_sap_attributes (connection^.sap_id, sap_attributes);
        IF sap_attributes <> NIL THEN
          sap_attributes^.sap_device_list [connection^.device_id].status := nlc$na_sap_closed;
        IFEND;
        osp$clear_job_signature_lock (nlv$na_sap_list.lock);

        nlp$cl_deactivate_layer (nlc$osi_network_access_agent, cl_connection);
        IF event.disconnect.reason = nlc$cc_dr_normal_disconnect THEN
          data := event.disconnect.data;
          nlp$bm_get_message_length (data, data_length);
          IF data_length = #SIZE (nlt$na_disconnect_indication) THEN
            data_fragment [1].address := ^disconnect_indication;
            data_fragment [1].length := #SIZE (disconnect_indication);
            nlp$bm_flush_message (data_fragment, data, data_length, {ignore} local_status);
            IF disconnect_indication.header.length = data_length THEN

{ Log the disconnect reason code.

              IF (disconnect_indication.header.kind = nlc$na_close_sap_indication) THEN
                osp$set_status_abnormal (nac$status_id, nae$na_peer_disconnect, 'CLOSE SAP INDICATION',
                      local_status);
                osp$append_status_integer (osc$status_parameter_delimiter, disconnect_indication.reason, 10,
                      FALSE, local_status);
                nap$display_message (local_status);
              ELSEIF (disconnect_indication.header.kind = nlc$na_open_sap_reject) THEN
                osp$set_status_abnormal (nac$status_id, nae$na_peer_disconnect, 'OPEN SAP REJECT',
                      local_status);
                osp$append_status_integer (osc$status_parameter_delimiter, disconnect_indication.reason, 10,
                      FALSE, local_status);
                nap$display_message (local_status);
              ELSE { Unexpected PDU kind
                PUSH error_message;
                STRINGREP (error_message^, error_message_length, 'Unexpected PDU kind of ',
                      disconnect_indication.header.kind, ' on a NAA disconnect indication.');
                nap$namve_system_error (TRUE, error_message^ (1, error_message_length), NIL);
              IFEND;
            ELSE { Length in the header does not match the PDU length
              PUSH error_message;
              STRINGREP (error_message^, error_message_length, 'The length of NAA disconnect ',
                    'PDU is ', data_length, ' but length in the PDU header is ', disconnect_indication.
                    header.length, ' .');
              nap$namve_system_error (TRUE, error_message^ (1, error_message_length), NIL);
            IFEND;
          ELSE { Unexpected PDU length
            PUSH error_message;
            STRINGREP (error_message^, error_message_length, 'Unexpected PDU length of ',
                  disconnect_indication.header.length, ' on a NAA disconnect indication.');
            nap$namve_system_error (TRUE, error_message^ (1, error_message_length), NIL);
            nlp$bm_release_message (data);
          IFEND;
        ELSE { CC disconnect
          pmp$log ('NAA - CC disconnect', {ignore} local_status);
        IFEND;
      ELSE { Unexpected CC event
        PUSH error_message;
        STRINGREP (error_message^, error_message_length, 'Unexpected CC event kind ',
              event.kind, ' received by network access event processor.');
        nap$namve_system_error (TRUE, error_message^ (1, error_message_length), NIL);
        disconnect_na_connection (cl_connection, nlc$na_dr_namve_error);
        update_sap_status (connection^.sap_id, connection^.device_id);
      CASEND;
    ELSE { Layer inactive

{ Send disconnect with NAM/VE error.

      PUSH error_message;
      STRINGREP (error_message^, error_message_length, 'Detected an inactive NAA layer ',
            'connection on receipt of a CC event kind of ', event.kind, '.');
      nap$namve_system_error (TRUE, error_message^ (1, error_message_length), NIL);
      disconnect_na_connection (cl_connection, nlc$na_dr_namve_error);
    IFEND;

  PROCEND nlp$na_event_processor;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$na_initialize', EJECT ??
*copy nlh$na_initialize

  PROCEDURE [XDCL] nlp$na_initialize;

    VAR
      null_connect_event_processor: nlt$cl_event_processor,
      sap_processor: nlt$cl_event_processor;

    null_connect_event_processor.layer := nlc$osi_network_access_agent;
    sap_processor.layer := nlc$osi_network_access_agent;

    nlp$cl_initialize_template (nlc$osi_network_access_agent, nlc$osi_network_access_agent,
          #SIZE (nlt$na_layer_connection), 0, sap_processor, nlc$na_retry_constrained_saps,
          null_connect_event_processor, nac$nil);
    nlp$cc_initialize_template (nlc$osi_network_access_agent);

  PROCEND nlp$na_initialize;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$na_open_sap', EJECT ??
*copy nlh$na_open_sap

  PROCEDURE [XDCL] nlp$na_open_sap
    (    priority: nlt$na_priority;
         event_processor: nat$network_procedure;
         sap_id: nat$network_selector;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nlt$na_layer_connection,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      device_and_data_list: array [1 .. 1] of nlt$cc_device_and_data_record,
      i: integer,
      ignore_layer_active: boolean,
      system_management_list: ^nlt$sm_device_list,
      open_sap_request: nlt$na_open_sap_request,
      previous_sap_attributes: ^^nlt$na_sap_attributes,
      sap_attributes: ^nlt$na_sap_attributes;

    status.normal := TRUE;

{ Setup the open sap request.

    data_fragment [1].address := ^open_sap_request;
    data_fragment [1].length := #SIZE (open_sap_request);
    open_sap_request.header.kind := nlc$na_open_sap_request;
    open_sap_request.header.length := data_fragment [1].length;
    open_sap_request.network_selector := sap_id;

    osp$set_job_signature_lock (nlv$na_sap_list.lock);

{ Verify that the specified sap is not already open. Note that the network selector used
{ by OSI transport layer is reserved.

    IF (NOT nlv$na_sap_list.open_saps [sap_id]) AND (sap_id <> nlv$transport_network_selector) THEN
      nlv$na_sap_list.open_saps [sap_id] := TRUE;

{ Setup sap_attributes entry.

      ALLOCATE sap_attributes: [1 .. UPPERBOUND (nlv$sm_devices.list^)] IN
            nav$network_paged_heap^;
      IF sap_attributes <> NIL THEN
        sap_attributes^.next_entry := NIL;
        sap_attributes^.sap_id := sap_id;
        sap_attributes^.priority := priority;
        sap_attributes^.event_processor := event_processor;
        sap_attributes^.connection_class := nlc$cc_normal_class;

{ Send open sap request to each configured network device.

        nlp$get_nonexclusive_access (nlv$sm_devices.access_control);
        system_management_list := nlv$sm_devices.list;
        FOR i := 1 TO UPPERBOUND (system_management_list^) DO
          sap_attributes^.sap_device_list [i].device_id := system_management_list^ [i].device_id;
          sap_attributes^.sap_device_list [i].status := nlc$na_sap_closed;
          sap_attributes^.sap_device_list [i].connection_id := nac$null_connection_id;
          IF system_management_list^ [i].state >= nlc$sm_initialization_phase2 THEN
            nlp$cl_create_connection (nlc$osi_network_access_agent, cl_connection);
            IF cl_connection <> NIL THEN
              nlp$cl_get_layer_connection (nlc$osi_network_access_agent, cl_connection, ignore_layer_active,
                    connection);
              device_and_data_list [1].device_id := sap_attributes^.sap_device_list [i].device_id;
              nlp$bm_create_message (data_fragment, device_and_data_list [1].data, {ignore} status);
              nlp$cc_request_connection (cl_connection, device_and_data_list, nlc$network_access_address,
                    sap_attributes^.connection_class, status);
              IF status.normal THEN
                nlp$cl_activate_layer (nlc$osi_network_access_agent, cl_connection);
                connection^.state := nlc$na_await_connection_confirm;
                connection^.device_id := device_and_data_list [1].device_id;
                connection^.sap_id := sap_id;
                connection^.event_processor := event_processor;
                sap_attributes^.sap_device_list [i].connection_id := cl_connection^.identifier;
                sap_attributes^.sap_device_list [i].status := nlc$na_await_open_sap_confirm;
              ELSE
                IF status.condition = nae$resources_unavailable THEN
                  sap_attributes^.sap_device_list [i].status := nlc$na_resource_constraint;
                IFEND;
              IFEND;
              nlp$cl_release_exclusive_access (cl_connection);
            ELSE

{ Mark the sap device entry as being in resource constraint, the timer task will periodically
{ try to open the sap across this device.

              sap_attributes^.sap_device_list [i].status := nlc$na_resource_constraint;
            IFEND;
          IFEND;
        FOREND;
        nlp$release_nonexclusive_access (nlv$sm_devices.access_control);

{ Link sap_attributes at the end of the sap list.

        previous_sap_attributes := ^nlv$na_sap_list.sap_attributes;
        WHILE previous_sap_attributes^ <> NIL DO
          previous_sap_attributes := ^previous_sap_attributes^^.next_entry;
        WHILEND;
        previous_sap_attributes^ := sap_attributes;
      ELSE { Insufficient resources
        osp$set_status_abnormal (nac$status_id, nae$allocation_failed, 'Open OSI Network Sap', status);
      IFEND;
    ELSE { Sap already open
      osp$set_status_condition ( nae$na_sap_already_open,  status);
      osp$append_status_integer (osc$status_parameter_delimiter, sap_id, 10, TRUE, status);
    IFEND;

    osp$clear_job_signature_lock (nlv$na_sap_list.lock);

  PROCEND nlp$na_open_sap;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$na_open_saps', EJECT ??
*copy nlh$na_open_saps

  PROCEDURE [XDCL] nlp$na_open_saps
    (    device_id: nlt$device_identifier);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nlt$na_layer_connection,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      device_and_data_list: array [1 .. 1] of nlt$cc_device_and_data_record,
      error_message: ^string (132),
      error_message_length: integer,
      ignore_layer_active: boolean,
      local_status: ost$status,
      open_sap_request: nlt$na_open_sap_request,
      sap_attributes: ^nlt$na_sap_attributes;

    data_fragment [1].address := ^open_sap_request;
    data_fragment [1].length := #SIZE (open_sap_request);
    open_sap_request.header.kind := nlc$na_open_sap_request;
    open_sap_request.header.length := data_fragment [1].length;
    device_and_data_list [1].device_id := device_id;
    osp$set_job_signature_lock (nlv$na_sap_list.lock);

    sap_attributes := nlv$na_sap_list.sap_attributes;
    WHILE sap_attributes <> NIL DO

{ The order of the sap device list is the same as the configured network devices
{ list. Hence, the device id can be used to index the sap device list directly.

      IF (sap_attributes^.sap_device_list [device_id].status = nlc$na_sap_closed) OR
            (sap_attributes^.sap_device_list [device_id].status = nlc$na_resource_constraint) THEN
        nlp$cl_create_connection (nlc$osi_network_access_agent, cl_connection);
        IF cl_connection <> NIL THEN
          nlp$cl_activate_layer (nlc$osi_network_access_agent, cl_connection);
          nlp$cl_get_layer_connection (nlc$osi_network_access_agent, cl_connection, ignore_layer_active,
                connection);
          open_sap_request.network_selector := sap_attributes^.sap_id;
          nlp$bm_create_message (data_fragment, device_and_data_list [1].data, {ignore} local_status);
          nlp$cc_request_connection (cl_connection, device_and_data_list, nlc$network_access_address,
                sap_attributes^.connection_class, local_status);
          IF local_status.normal THEN
            connection^.state := nlc$na_await_connection_confirm;
            connection^.device_id := device_id;
            connection^.sap_id := sap_attributes^.sap_id;
            connection^.event_processor := sap_attributes^.event_processor;
            sap_attributes^.sap_device_list [device_id].connection_id := cl_connection^.identifier;
            sap_attributes^.sap_device_list [device_id].status := nlc$na_await_open_sap_confirm;
          ELSE
            nlp$cl_deactivate_layer (nlc$osi_network_access_agent, cl_connection);
            IF local_status.condition = nae$resources_unavailable THEN
              sap_attributes^.sap_device_list [device_id].status := nlc$na_resource_constraint;
            IFEND;
          IFEND;
          nlp$cl_release_exclusive_access (cl_connection);
        ELSE { Max connections limit reached
          sap_attributes^.sap_device_list [device_id].status := nlc$na_resource_constraint;
        IFEND;
      ELSE { Sap is already open in the device
        PUSH error_message;
        STRINGREP (error_message^, error_message_length, ' NAM/VE: The network layer sap ',
              sap_attributes^.sap_id, ' is already open in the device ', device_id, ' .');
        pmp$log (error_message^ (1, error_message_length), local_status);
      IFEND;

      sap_attributes := sap_attributes^.next_entry;
    WHILEND;

    osp$clear_job_signature_lock (nlv$na_sap_list.lock);

  PROCEND nlp$na_open_saps;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$na_retry_constrained_saps', EJECT ??
*copy nlh$na_retry_constrained_saps

  PROCEDURE [XDCL] nlp$na_retry_constrained_saps
    (    current_time: integer);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nlt$na_layer_connection,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      device_and_data_list: array [1 .. 1] of nlt$cc_device_and_data_record,
      i: integer,
      ignore_layer_active: boolean,
      local_status: ost$status,
      open_sap_request: nlt$na_open_sap_request,
      sap_attributes: ^nlt$na_sap_attributes;

    data_fragment [1].address := ^open_sap_request;
    data_fragment [1].length := #SIZE (open_sap_request);
    open_sap_request.header.kind := nlc$na_open_sap_request;
    open_sap_request.header.length := data_fragment [1].length;
    osp$set_job_signature_lock (nlv$na_sap_list.lock);
    sap_attributes := nlv$na_sap_list.sap_attributes;
    WHILE sap_attributes <> NIL DO
      FOR i := 1 TO UPPERBOUND (sap_attributes^.sap_device_list) DO
        IF sap_attributes^.sap_device_list [i].status = nlc$na_resource_constraint THEN
          nlp$cl_create_connection (nlc$osi_network_access_agent, cl_connection);
          IF cl_connection <> NIL THEN
            nlp$cl_get_layer_connection (nlc$osi_network_access_agent, cl_connection, ignore_layer_active,
                  connection);
            open_sap_request.network_selector := sap_attributes^.sap_id;
            device_and_data_list [1].device_id := sap_attributes^.sap_device_list [i].device_id;
            nlp$bm_create_message (data_fragment, device_and_data_list [1].data, {ignore} local_status);
            nlp$cc_request_connection (cl_connection, device_and_data_list, nlc$network_access_address,
                  sap_attributes^.connection_class, local_status);
            IF local_status.normal THEN
              nlp$cl_activate_layer (nlc$osi_network_access_agent, cl_connection);
              connection^.state := nlc$na_await_connection_confirm;
              connection^.device_id := device_and_data_list [1].device_id;
              connection^.sap_id := sap_attributes^.sap_id;
              connection^.event_processor := sap_attributes^.event_processor;
              sap_attributes^.sap_device_list [i].connection_id := cl_connection^.identifier;
              sap_attributes^.sap_device_list [i].status := nlc$na_await_open_sap_confirm;
            ELSE
              IF local_status.condition <> nae$resources_unavailable THEN
                sap_attributes^.sap_device_list [i].status := nlc$na_sap_closed;
              IFEND;
            IFEND;
            nlp$cl_release_exclusive_access (cl_connection);
          IFEND;
        IFEND;
      FOREND;
      sap_attributes := sap_attributes^.next_entry;
    WHILEND;
    osp$clear_job_signature_lock (nlv$na_sap_list.lock);

  PROCEND nlp$na_retry_constrained_saps;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$na_send_data', EJECT ??
*copy nlh$na_send_data

  PROCEDURE [XDCL] nlp$na_send_data
    (    sap_id: nat$network_selector;
         device_id: nlt$device_identifier;
         destination: nat$osi_network_address;
         data: nat$data_fragments;
     VAR status: ost$status);

    VAR
      actual: integer,
      cl_connection: ^nlt$cl_connection,
      connection: ^nlt$na_layer_connection,
      connection_exists: boolean,
      connection_id: nat$connection_id,
      data_fragments: ^nat$data_fragments,
      data_length: nat$data_length,
      data_request_fixed: nlt$na_data_request_fixed,
      i: integer,
      layer_active: boolean,
      sap_attributes: ^nlt$na_sap_attributes,
      user_data: nlt$bm_message_id;

    status.normal := TRUE;

{ Setup the data fragments. The first entry is for the fixed sized NAA header and
{ the second entry is for the variable sized destination address.

    PUSH data_fragments: [1 .. (UPPERBOUND (data) + 2)];
    data_fragments^ [1].address := ^data_request_fixed;
    data_fragments^ [1].length := #SIZE (data_request_fixed);
    data_fragments^ [2].address := ^destination;
    data_fragments^ [2].length := #SIZE (destination);

{ Move the remaining user data fragments.

    FOR i := 1 TO UPPERBOUND (data) DO
      data_fragments^ [i + 2] := data [i];
    FOREND;

    nlp$al_get_data_length (data_fragments^, data_length);
    data_request_fixed.header.kind := nlc$na_data_request;
    data_request_fixed.header.length := data_length;
    data_request_fixed.destination_address_length := #SIZE (destination);

{ Verify that the sap over which the data is being sent is open.

    osp$set_job_signature_lock (nlv$na_sap_list.lock);
    find_sap_attributes (sap_id, sap_attributes);
    IF sap_attributes <> NIL THEN

{ Find the channel connection to the device through which the destination
{ is accessible.

      IF sap_attributes^.sap_device_list [device_id].status = nlc$na_sap_open THEN
        connection_id := sap_attributes^.sap_device_list [device_id].connection_id;
        data_request_fixed.priority := sap_attributes^.priority;
        osp$clear_job_signature_lock (nlv$na_sap_list.lock);
        nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
        IF connection_exists THEN
          nlp$cl_get_layer_connection (nlc$osi_network_access_agent, cl_connection, layer_active,
                connection);
          IF layer_active THEN
            nlp$bm_create_message (data_fragments^, user_data, {ignore} status);
            nlp$cc_send_data (cl_connection, user_data, status);

{! statistics begin

            IF nav$statistics_enabled THEN
              osp$increment_locked_variable (nav$global_osi_statistics.network_access_agent.pdus_sent, 0,
                    actual);
              osp$add_to_locked_variable (nav$global_osi_statistics.network_access_agent.
                    total_bytes_sent, 0, data_length, actual);
            IFEND;

{! statistics end

          IFEND;

          nlp$cl_release_exclusive_access (cl_connection);
        IFEND;
      ELSE
        osp$clear_job_signature_lock (nlv$na_sap_list.lock);
        osp$set_status_condition ( nae$na_device_sap_not_open,  status);
        osp$append_status_integer (osc$status_parameter_delimiter, sap_id, 10, TRUE, status);
      IFEND;
    ELSE
      osp$clear_job_signature_lock (nlv$na_sap_list.lock);
      osp$set_status_condition ( nae$na_sap_not_open,  status);
      osp$append_status_integer (osc$status_parameter_delimiter, sap_id, 10, TRUE, status);
    IFEND;

  PROCEND nlp$na_send_data;
?? OLDTITLE ??
?? NEWTITLE := 'disconnect_na_connection', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to format and send a disconnect
{   request to the peer entity. It also deactivates the layer connection.

  PROCEDURE disconnect_na_connection
    (    cl_connection { input, output } : ^nlt$cl_connection;
         disconnect_reason: nlt$na_disconnect_reason);

    VAR
      close_sap_request: nlt$na_close_sap_request,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      disconnect_data: nlt$bm_message_id,
      ignore_status: ost$status;

    close_sap_request.header.kind := nlc$na_close_sap_request;
    close_sap_request.header.length := #SIZE (close_sap_request);
    close_sap_request.reason := disconnect_reason;
    data_fragment [1].address := ^close_sap_request;
    data_fragment [1].length := #SIZE (close_sap_request);
    nlp$bm_create_message (data_fragment, disconnect_data, ignore_status);
    nlp$cc_disconnect (cl_connection, disconnect_data, ignore_status);
    nlp$cl_deactivate_layer (nlc$osi_network_access_agent, cl_connection);

  PROCEND disconnect_na_connection;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] find_sap_attributes', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to find the sap attributes
{   entry corresponding to the specified sap identifier.
{ NOTES:
{   The sap list must be locked by the caller.

  PROCEDURE [INLINE] find_sap_attributes
    (    sap_id: nat$network_selector;
     VAR sap_attributes: ^nlt$na_sap_attributes);

    sap_attributes := nlv$na_sap_list.sap_attributes;
    WHILE (sap_attributes <> NIL) AND (sap_attributes^.sap_id <> sap_id) DO
      sap_attributes := sap_attributes^.next_entry;
    WHILEND;

  PROCEND find_sap_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'update_sap_status', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to set the status of the given sap for
{   the specified device to closed.

  PROCEDURE update_sap_status
    (    sap_id: nat$network_selector;
         device_id: nlt$device_identifier);

    VAR
      sap_attributes: ^nlt$na_sap_attributes;

    osp$set_job_signature_lock (nlv$na_sap_list.lock);
    find_sap_attributes (sap_id, sap_attributes);
    IF sap_attributes <> NIL THEN
      sap_attributes^.sap_device_list [device_id].status := nlc$na_sap_closed;
    IFEND;
    osp$clear_job_signature_lock (nlv$na_sap_list.lock);

  PROCEND update_sap_status;
?? OLDTITLE ??
MODEND nlm$network_access_agent;
*DECK DECK=NLM$SK_AWAIT_SOCKET_EVENTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access: Socket Layer Internal Interface In 23D' ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
MODULE nlm$sk_await_socket_events;

{ PURPOSE:
{   This module contains the Socket Layer internal interface that provides the ability
{   to await events on more than one socket.
{ DESIGN:
{   This module contains code that has an execution bracket of 2, 3. It resides on
{   OSF$JOB_TEMPLATE_23D.

?? PUSH (LISTEXT := ON) ??
*copyc nac$null_connection_id
*copyc nae$sk_socket_layer
*copyc nat$sk_job_socket
*copyc nat$sk_socket_events
*copyc ost$free_running_clock
*copyc ost$status
?? POP ??
*copyc nap$namve_system_error
*copyc nlp$sk_await_socket_offer
*copyc nlp$sk_clear_job_socket_lock
*copyc nlp$sk_lock_job_socket
*copyc nlp$sk_remove_wait_socket_offer
*copyc nlp$sk_tcp_await_clear_to_send
*copyc nlp$sk_tcp_await_data_available
*copyc nlp$sk_tcp_check_accept_socket
*copyc nlp$sk_tcp_remove_accept_socket
*copyc nlp$sk_tcp_remove_clear_to_send
*copyc nlp$sk_tcp_remove_data_avail
*copyc nlp$sk_unlock_job_socket
*copyc nlp$udp_await_clear_to_send
*copyc nlp$udp_await_data_available
*copyc nlp$udp_remove_clear_to_send
*copyc nlp$udp_remove_data_available
*copyc osp$append_status_integer
*copyc osp$establish_condition_handler
*copyc osp$disestablish_cond_handler
*copyc osp$pop_inhibit_job_recovery
*copyc osp$push_inhibit_job_recovery
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$long_term_wait
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$sk_await_socket_events', EJECT ??
*copy nlh$sk_await_socket_events

  PROCEDURE [XDCL, #GATE] nlp$sk_await_socket_events
    (    socket_events: nat$sk_socket_events;
     VAR completed_events: nat$sk_socket_events;
     VAR count: integer;
     VAR status: ost$status);

?? NEWTITLE := 'terminate_await', EJECT ??

    PROCEDURE terminate_await
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF
      = ifc$interactive_condition, jmc$job_resource_condition =
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        EXIT nlp$sk_await_socket_events;
      = pmc$block_exit_processing =
        remove_task_from_wait_lists (socket_events, completed_events, count);
        osp$pop_inhibit_job_recovery;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND terminate_await;
?? OLDTITLE, EJECT ??

    VAR
      activity_complete: boolean,
      current_time: ost$free_running_clock,
      i: integer,
      job_socket: ^nat$sk_job_socket,
      null_events_specified: boolean,
      remaining_time: integer,
      start_time: ost$free_running_clock,
      wait: boolean;

    start_time := #FREE_RUNNING_CLOCK (0);
    remaining_time := UPPERVALUE (ost$free_running_clock);
    status.normal := TRUE;
    null_events_specified := TRUE;
    count := 0;
    osp$push_inhibit_job_recovery;
    osp$establish_condition_handler (^terminate_await, {block_exit} TRUE);

{ Process socket events. Make the first pass to check for completed events
{ without wait.

    wait := FALSE;
    REPEAT

    /await_events/
      FOR i := 1 TO UPPERBOUND (socket_events) DO
        CASE socket_events [i].event_kind OF
        = nac$sk_await_data_available =
          null_events_specified := FALSE;
          IF socket_events [i].socket_id > 0 THEN
            nlp$sk_lock_job_socket (socket_events [i].socket_id, job_socket);
            IF job_socket <> NIL THEN
              IF job_socket^.status = nac$sk_socket_open THEN
                IF job_socket^.socket_type = nac$sk_udp_socket THEN
                  nlp$udp_await_data_available (job_socket^.global_socket_id, wait, activity_complete);
                  IF activity_complete THEN
                    count := count + 1;
                    completed_events [count] := socket_events [i];
                    IF count >= UPPERBOUND (completed_events) THEN
                      nlp$sk_unlock_job_socket (socket_events [i].socket_id);
                      EXIT /await_events/;
                    IFEND;
                  IFEND;
                ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
                  IF (job_socket^.tcp_socket_type = nlc$tcp_connect_socket) OR
                        (job_socket^.tcp_socket_type = nlc$tcp_accept_socket) THEN
                    nlp$sk_tcp_await_data_available (job_socket^.connection_id, wait, activity_complete);
                    IF activity_complete THEN
                      count := count + 1;
                      completed_events [count] := socket_events [i];
                      IF count >= UPPERBOUND (completed_events) THEN
                        nlp$sk_unlock_job_socket (socket_events [i].socket_id);
                        EXIT /await_events/;
                      IFEND;
                    IFEND;
                  ELSEIF job_socket^.tcp_socket_type = nlc$tcp_listen_socket THEN
                    nlp$sk_tcp_check_accept_socket (job_socket^.application, job_socket^.port,
                          job_socket^.bound_address, wait, activity_complete);
                    IF activity_complete THEN
                      count := count + 1;
                      completed_events [count] := socket_events [i];
                      IF count >= UPPERBOUND (completed_events) THEN
                        nlp$sk_unlock_job_socket (socket_events [i].socket_id);
                        EXIT /await_events/;
                      IFEND;
                    IFEND;
                  ELSEIF job_socket^.tcp_socket_type = nlc$tcp_null_socket THEN
                    activity_complete := TRUE;
                    count := count + 1;
                    completed_events [count] := socket_events [i];
                    IF count >= UPPERBOUND (completed_events) THEN
                      nlp$sk_unlock_job_socket (socket_events [i].socket_id);
                      EXIT /await_events/;
                    IFEND;
                  IFEND;
                IFEND;
              ELSE { Socket closed or terminated
                count := count + 1;
                activity_complete := TRUE;
                completed_events [count] := socket_events [i];
                IF count >= UPPERBOUND (completed_events) THEN
                  nlp$sk_unlock_job_socket (socket_events [i].socket_id);
                  EXIT /await_events/;
                IFEND;
              IFEND;
              nlp$sk_unlock_job_socket (socket_events [i].socket_id);
            ELSE { Unknown socket
              nlp$sk_unlock_job_socket (socket_events [i].socket_id);
              osp$set_status_condition (nae$sk_unknown_socket, status);
              osp$append_status_integer (osc$status_parameter_delimiter, socket_events [i].socket_id, 10,
                    TRUE, status);
              EXIT /await_events/;
            IFEND;
          ELSE { socket_events [i].socket_id = 0
            osp$set_status_condition (nae$sk_unknown_socket, status);
            osp$append_status_integer (osc$status_parameter_delimiter, socket_events [i].socket_id, 10, TRUE,
                  status);
            EXIT /await_events/;
          IFEND;

        = nac$sk_await_clear_to_send =
          null_events_specified := FALSE;
          IF socket_events [i].socket_id > 0 THEN
            nlp$sk_lock_job_socket (socket_events [i].socket_id, job_socket);
            IF job_socket <> NIL THEN
              IF job_socket^.status = nac$sk_socket_open THEN
                IF job_socket^.socket_type = nac$sk_udp_socket THEN
                  nlp$udp_await_clear_to_send (job_socket^.global_socket_id, wait, activity_complete);
                  IF activity_complete THEN
                    count := count + 1;
                    completed_events [count] := socket_events [i];
                    IF count >= UPPERBOUND (completed_events) THEN
                      nlp$sk_unlock_job_socket (socket_events [i].socket_id);
                      EXIT /await_events/;
                    IFEND;
                  IFEND;
                ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
                  IF (job_socket^.tcp_socket_type = nlc$tcp_connect_socket) OR
                        (job_socket^.tcp_socket_type = nlc$tcp_accept_socket) THEN
                    nlp$sk_tcp_await_clear_to_send (job_socket^.connection_id, wait, activity_complete);
                    IF activity_complete THEN
                      count := count + 1;
                      completed_events [count] := socket_events [i];
                      IF count >= UPPERBOUND (completed_events) THEN
                        nlp$sk_unlock_job_socket (socket_events [i].socket_id);
                        EXIT /await_events/;
                      IFEND;
                    IFEND;
                  ELSE { Either connect not done or a listen socket

{ Should it give a reject instead ???

                    activity_complete := TRUE;
                    count := count + 1;
                    completed_events [count] := socket_events [i];
                    IF count >= UPPERBOUND (completed_events) THEN
                      nlp$sk_unlock_job_socket (socket_events [i].socket_id);
                      EXIT /await_events/;
                    IFEND;
                  IFEND;
                IFEND;
              ELSE { Socket closed or terminated
                activity_complete := TRUE;
                count := count + 1;
                completed_events [count] := socket_events [i];
                IF count >= UPPERBOUND (completed_events) THEN
                  nlp$sk_unlock_job_socket (socket_events [i].socket_id);
                  EXIT /await_events/;
                IFEND;
              IFEND;
              nlp$sk_unlock_job_socket (socket_events [i].socket_id);
            ELSE { Unknown socket
              nlp$sk_unlock_job_socket (socket_events [i].socket_id);
              osp$set_status_condition (nae$sk_unknown_socket, status);
              osp$append_status_integer (osc$status_parameter_delimiter, socket_events [i].socket_id, 10,
                    TRUE, status);
              EXIT /await_events/;
            IFEND;
          ELSE { socket_events [i].socket_id = 0
            osp$set_status_condition (nae$sk_unknown_socket, status);
            osp$append_status_integer (osc$status_parameter_delimiter, socket_events [i].socket_id, 10, TRUE,
                  status);
            EXIT /await_events/;
          IFEND;

        = nac$sk_await_socket_offer =
          null_events_specified := FALSE;
          nlp$sk_await_socket_offer (socket_events [i].source_job, wait, activity_complete);
          IF activity_complete THEN
            count := count + 1;
            completed_events [count] := socket_events [i];
            IF count >= UPPERBOUND (completed_events) THEN
              EXIT /await_events/;
            IFEND;
          IFEND;

        = nac$sk_await_time =
          null_events_specified := FALSE;
          current_time := #FREE_RUNNING_CLOCK (0);
          remaining_time := start_time + socket_events [i].wait_time * 1000 - current_time;
          IF remaining_time <= 0 THEN
            count := count + 1;
            completed_events [count] := socket_events [i];
            IF count >= UPPERBOUND (completed_events) THEN
              EXIT /await_events/;
            IFEND;
          IFEND;
        = nac$sk_null_event =

        ELSE { Invalid event
          osp$set_status_condition (nae$sk_invalid_event, status);
          osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (socket_events [i].event_kind),
                10, TRUE, status);
          EXIT /await_events/;
        CASEND;
      FOREND /await_events/;

      IF null_events_specified THEN
        osp$set_status_abnormal (nac$status_id, nae$sk_null_list, 'NAP$SK_AWAIT_SOCKET_EVENTS', status);
      IFEND;

      IF status.normal THEN
        IF count = 0 THEN
          IF wait THEN
            IF remaining_time > 0 THEN
              remaining_time := remaining_time DIV 1000;
              pmp$long_term_wait (remaining_time, remaining_time);
            IFEND;
          ELSE { wait = false

{ Make a second pass to queue the task on the wait lists.

            wait := TRUE;
          IFEND;
        IFEND;
      IFEND;
    UNTIL (NOT status.normal) OR (count > 0);

    IF wait THEN
      remove_task_from_wait_lists (socket_events, completed_events, count);
    IFEND;
    osp$disestablish_cond_handler;
    osp$pop_inhibit_job_recovery;

  PROCEND nlp$sk_await_socket_events;
?? OLDTITLE ??
?? NEWTITLE := 'remove_task_from_wait_lists', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to remove the currently
{ executing task from the wait lists for the specified events.
{ For each socket event, the completed events list is searched
{ and if the event is incomplete, it is removed from the
{ corresponding wait list. The completed events are dequeued at
{ event completion time.

  PROCEDURE remove_task_from_wait_lists
    (    socket_events: nat$sk_socket_events;
         completed_events: nat$sk_socket_events;
         count: integer);

    VAR
      i: integer,
      j: integer,
      job_socket: ^nat$sk_job_socket,
      socket_id:  0 .. nac$sk_max_socket_identifier;

?? NEWTITLE := 'terminate_remove', EJECT ??

    PROCEDURE terminate_remove
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF
      = pmc$block_exit_processing =
        IF socket_id > 0 THEN
          nlp$sk_clear_job_socket_lock (socket_id);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND terminate_remove;
?? OLDTITLE, EJECT ??

    socket_id := 0;
    #SPOIL (socket_id);
    osp$establish_condition_handler (^terminate_remove, {block_exit} TRUE);

{ Remove the task from all the queues.

  /outer_loop/
    FOR i := 1 TO UPPERBOUND (socket_events) DO

{ Compare it with the completed events.

      FOR j := 1 TO count DO
        IF socket_events [i].event_kind = completed_events [j].event_kind THEN
          CASE socket_events [i].event_kind OF
          = nac$sk_await_data_available, nac$sk_await_clear_to_send =
            IF socket_events [i].socket_id = completed_events [j].socket_id THEN
              CYCLE /outer_loop/;
            IFEND;
          = nac$sk_await_socket_offer =
            IF socket_events [i].source_job = completed_events [j].source_job THEN
              CYCLE /outer_loop/;
            IFEND;
          ELSE
          CASEND;
        IFEND;
      FOREND;

{ Dequeue the task from the appropriate list.

      CASE socket_events [i].event_kind OF
      = nac$sk_await_data_available =
        socket_id := socket_events [i].socket_id;
        #SPOIL (socket_id);
        nlp$sk_lock_job_socket (socket_id, job_socket);
        IF job_socket <> NIL THEN
          IF job_socket^.status = nac$sk_socket_open THEN
            IF job_socket^.socket_type = nac$sk_udp_socket THEN
              nlp$udp_remove_data_available (job_socket^.global_socket_id);
            ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
              IF (job_socket^.tcp_socket_type = nlc$tcp_connect_socket) OR
                    (job_socket^.tcp_socket_type = nlc$tcp_accept_socket) THEN
                nlp$sk_tcp_remove_data_avail (job_socket^.connection_id);
              ELSEIF job_socket^.tcp_socket_type = nlc$tcp_listen_socket THEN
                nlp$sk_tcp_remove_accept_socket (job_socket^.application, job_socket^.port,
                      job_socket^.bound_address);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
        nlp$sk_unlock_job_socket (socket_events [i].socket_id);
        socket_id := 0;
        #SPOIL (socket_id);

      = nac$sk_await_clear_to_send =
        socket_id := socket_events [i].socket_id;
        #SPOIL (socket_id);
        nlp$sk_lock_job_socket (socket_id, job_socket);
        IF job_socket <> NIL THEN
          IF job_socket^.status = nac$sk_socket_open THEN
            IF job_socket^.socket_type = nac$sk_udp_socket THEN
              nlp$udp_remove_clear_to_send (job_socket^.global_socket_id);
            ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
              IF job_socket^.connection_id <> nac$null_connection_id THEN
                nlp$sk_tcp_remove_clear_to_send (job_socket^.connection_id);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
        nlp$sk_unlock_job_socket (socket_events [i].socket_id);
        socket_id := 0;
        #SPOIL (socket_id);

      = nac$sk_await_socket_offer =
        nlp$sk_remove_wait_socket_offer (socket_events [i].source_job);

      = nac$sk_await_time =

{ Do nothing.

      = nac$sk_null_event =

      ELSE { Unknown event
        nap$namve_system_error ({Recoverable_error=} TRUE, 'Unknown event in event list.', NIL);
      CASEND;
    FOREND /outer_loop/;

    osp$disestablish_cond_handler;

  PROCEND remove_task_from_wait_lists;
?? OLDTITLE ??
MODEND nlm$sk_await_socket_events;
*DECK DECK=NLM$SK_SERVICE_ROUTINES_R2 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access: Ring 2 Service Routines For Socket Layer' ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
MODULE nlm$sk_service_routines_r2;

{ PURPOSE:
{   This module contains procedures needed by the NAM/VE socket layer that execute
{ in ring 2.
{ DESIGN:
{   These procedures are called by the socket layer external interface code.
{   These procedures service both the UDP and the TCP portions of the socket layer.
{   This module contains procedures that manipulate socket layer data structures
{   in job paged segment which is writable from ring 2.
{   The access to the list of reusable ports is controlled via the lock to the
{   global list of TCP ports.
{   The XDCL'd procedures have been grouped in alphabetical order
{   followed by the internal procedures. The internal procedures are also in alphabetical
{   order.
{   This module contains code that executes in ring 2. It resides on OSF$JOB_TEMPLATE_223.
{
{ NOTES:
{   The following abbreviations have been used in this module:
{          TCP - Transmission Control Protocol
{          UDP - User Datagram Protocol

?? PUSH (LISTEXT := ON) ??
*copyc nae$sk_socket_layer
*copyc nat$connection_id
*copyc nat$sk_job_socket
*copyc nat$sk_job_socket_assignment
*copyc nat$sk_job_socket_list
*copyc nat$sk_socket_identifier
*copyc nat$sk_socket_options
*copyc oss$job_pageable
*copyc ost$status
?? POP ??
*copyc nap$namve_system_error
*copyc osp$append_status_integer
*copyc osp$clear_job_signature_lock
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$test_signature_lock
*copyc syp$cycle

*copyc osv$job_pageable_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    nav$sk_job_socket_assignment: [XDCL, #GATE, oss$job_pageable]
      nat$sk_job_socket_assignment := [[0], NIL],
    nav$sk_job_socket_list: [XDCL, #GATE, oss$job_pageable] ^nat$sk_job_socket_list := NIL;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$sk_add_job_socket', EJECT ??
*copy nlh$sk_add_job_socket

  PROCEDURE [XDCL, #GATE] nlp$sk_add_job_socket
    (    socket_id: nat$sk_socket_identifier;
         job_socket: nat$sk_job_socket);

    VAR
      new_job_socket: ^nat$sk_job_socket;

{ It is assumed that the job socket has been locked by the caller.

    REPEAT
      ALLOCATE new_job_socket IN osv$job_pageable_heap^;
    UNTIL new_job_socket <> NIL;

    new_job_socket^ := job_socket;
    nav$sk_job_socket_list^ [socket_id].job_socket := new_job_socket;

  PROCEND nlp$sk_add_job_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$sk_clear_job_socket_lock', EJECT ??
*copy nlh$sk_clear_job_socket_lock

  PROCEDURE [XDCL, #GATE] nlp$sk_clear_job_socket_lock
    (    socket_id: nat$sk_socket_identifier);

    VAR
      local_status: ost$status,
      lock_status: ost$signature_lock_status;

    IF nav$sk_job_socket_list <> NIL THEN
      osp$test_signature_lock (nav$sk_job_socket_list^ [socket_id].lock, lock_status, local_status);
      IF local_status.normal AND (lock_status = osc$sls_locked_by_current_task) THEN
        osp$clear_job_signature_lock (nav$sk_job_socket_list^ [socket_id].lock);
      IFEND;
    IFEND;

  PROCEND nlp$sk_clear_job_socket_lock;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$sk_delete_job_socket', EJECT ??
*copy nlh$sk_delete_job_socket

  PROCEDURE [XDCL, #GATE] nlp$sk_delete_job_socket
    (    socket_id: nat$sk_socket_identifier;
     VAR job_socket: ^nat$sk_job_socket);

{ It is assumed that the job socket has been locked by the caller.

    IF job_socket = nav$sk_job_socket_list^ [socket_id].job_socket THEN
      FREE job_socket IN osv$job_pageable_heap^;
      nav$sk_job_socket_list^ [socket_id].job_socket := NIL;
    ELSE
      nap$namve_system_error ( {Recoverable_error=} TRUE, 'Job socket mismatch during delete.', NIL);
    IFEND;

  PROCEND nlp$sk_delete_job_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$sk_free_socket_id', EJECT ??
*copy nlh$sk_free_socket_id

  PROCEDURE [XDCL, #GATE] nlp$sk_free_socket_id
    (    socket_id: nat$sk_socket_identifier);

    osp$set_job_signature_lock (nav$sk_job_socket_assignment.lock);
    IF nav$sk_job_socket_assignment.assigned_sockets^ [socket_id] THEN
      nav$sk_job_socket_assignment.assigned_sockets^ [socket_id] := FALSE;
    ELSE
      nap$namve_system_error ( {Recoverable_error=} TRUE, 'Free of unassigned socket id.', NIL);
    IFEND;
    osp$clear_job_signature_lock (nav$sk_job_socket_assignment.lock);

  PROCEND nlp$sk_free_socket_id;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$sk_get_socket_id', EJECT ??
*copy nlh$sk_get_socket_id

  PROCEDURE [XDCL, #GATE] nlp$sk_get_socket_id
    (VAR socket_id: nat$sk_socket_identifier;
     VAR status: ost$status);

    VAR
      i: integer,
      job_socket_list: ^nat$sk_job_socket_list,
      socket_assigned: boolean;

    status.normal := TRUE;
    osp$set_job_signature_lock (nav$sk_job_socket_assignment.lock);

    IF nav$sk_job_socket_assignment.assigned_sockets = NIL THEN

{ Initialize job socket assignment.

      REPEAT
        ALLOCATE nav$sk_job_socket_assignment.assigned_sockets
          IN osv$job_pageable_heap^;
        IF nav$sk_job_socket_assignment.assigned_sockets = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL nav$sk_job_socket_assignment.assigned_sockets <> NIL;
      FOR i := 1 TO UPPERBOUND (nav$sk_job_socket_assignment.assigned_sockets^) DO
        nav$sk_job_socket_assignment.assigned_sockets^ [i] := FALSE;
      FOREND;

{ Initialize job socket list.

      REPEAT
        ALLOCATE job_socket_list IN osv$job_pageable_heap^;
        IF job_socket_list = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL job_socket_list <> NIL;
      FOR i := 1 TO UPPERBOUND (job_socket_list^) DO
        job_socket_list^ [i].lock.lock_id := 0;
        job_socket_list^ [i].job_socket := NIL;
      FOREND;
      nav$sk_job_socket_list := job_socket_list;
    IFEND;

{ Assign socket id.

      socket_assigned := FALSE;
      /assign_socket_id/
      FOR i := 1 TO UPPERBOUND (nav$sk_job_socket_assignment.assigned_sockets^) DO
        IF NOT nav$sk_job_socket_assignment.assigned_sockets^ [i] THEN
          nav$sk_job_socket_assignment.assigned_sockets^[i] := TRUE;
          socket_id := i;
          socket_assigned := TRUE;
          EXIT /assign_socket_id/;
        IFEND;
      FOREND /assign_socket_id/;
      osp$clear_job_signature_lock (nav$sk_job_socket_assignment.lock);
      IF NOT socket_assigned THEN
        osp$set_status_condition ( nae$sk_max_sockets_limit,  status);
      IFEND;

  PROCEND nlp$sk_get_socket_id;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$sk_lock_job_socket', EJECT ??
*copy nlh$sk_lock_job_socket

  PROCEDURE [XDCL, #GATE] nlp$sk_lock_job_socket
    (    socket_id: nat$sk_socket_identifier;
     VAR job_socket: ^nat$sk_job_socket);

    IF nav$sk_job_socket_list <> NIL THEN
      osp$set_job_signature_lock (nav$sk_job_socket_list^ [socket_id].lock);
      job_socket := nav$sk_job_socket_list^ [socket_id].job_socket;
    ELSE

{ Get socket not done.

      job_socket := NIL;
    IFEND;

  PROCEND nlp$sk_lock_job_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$sk_process_job_recovery', EJECT ??
*copy nlh$sk_process_job_recovery

  PROCEDURE [XDCL, #GATE] nlp$sk_process_job_recovery;

    VAR
      socket_id: nat$sk_socket_identifier;

{ There is no need to lock the job socket list as no other task should
{ be executing when this procedure is invoked.

    IF nav$sk_job_socket_list <> NIL THEN
      FOR socket_id := 1 TO UPPERBOUND (nav$sk_job_socket_list^) DO
        IF nav$sk_job_socket_list^ [socket_id].job_socket <> NIL THEN
          nav$sk_job_socket_list^ [socket_id].job_socket^.status := nac$sk_job_recovery;
        IFEND;
      FOREND;
    IFEND;

  PROCEND nlp$sk_process_job_recovery;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$sk_unlock_job_socket', EJECT ??
*copy nlh$sk_unlock_job_socket

  PROCEDURE [XDCL, #GATE] nlp$sk_unlock_job_socket
    (    socket_id: nat$sk_socket_identifier);

    IF nav$sk_job_socket_list <> NIL THEN
      osp$clear_job_signature_lock (nav$sk_job_socket_list^ [socket_id].lock);
    IFEND;

  PROCEND nlp$sk_unlock_job_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$sk_update_bound_address', EJECT ??
*copy nlh$sk_update_bound_address

  PROCEDURE [XDCL, #GATE] nlp$sk_update_bound_address
    (    socket_id: nat$sk_socket_identifier;
         bound_address: nat$sk_ip_address);

{ It is assumed that the job socket has been locked by the caller.

    nav$sk_job_socket_list^ [socket_id].job_socket^.bound_address := bound_address;

  PROCEND nlp$sk_update_bound_address;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$sk_update_connect_socket', EJECT ??
*copy nlh$sk_update_connect_socket

  PROCEDURE [XDCL, #GATE] nlp$sk_update_connect_socket
    (    socket_id: nat$sk_socket_identifier;
         connection_id: nat$connection_id;
         local_ip_address: nat$sk_ip_address);

    VAR
      job_socket: ^nat$sk_job_socket;

{ It is assumed that the job socket has been locked by the caller.

    job_socket := nav$sk_job_socket_list^ [socket_id].job_socket;
    job_socket^.connection_id := connection_id;
    job_socket^.tcp_socket_type := nlc$tcp_connect_socket;
    job_socket^.local_ip_address := local_ip_address;

  PROCEND nlp$sk_update_connect_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$sk_update_job_socket', EJECT ??
*copy nlh$sk_update_job_socket

  PROCEDURE [XDCL, #GATE] nlp$sk_update_job_socket
    (    socket_id: nat$sk_socket_identifier;
         port: nat$sk_port_number;
         bound_address: nat$sk_ip_address;
         socket_status: nat$sk_job_socket_status);

    VAR
      job_socket: ^nat$sk_job_socket;

{ It is assumed that the job socket has been locked by the caller.

    job_socket := nav$sk_job_socket_list^ [socket_id].job_socket;
    job_socket^.port := port;
    job_socket^.bound_address := bound_address;
    job_socket^.status := socket_status;

  PROCEND nlp$sk_update_job_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$sk_update_job_socket_status', EJECT ??
*copy nlh$sk_update_job_socket_status

  PROCEDURE [XDCL, #GATE] nlp$sk_update_job_socket_status
    (    socket_id: nat$sk_socket_identifier;
         status: nat$sk_job_socket_status);

    VAR
      job_socket: ^nat$sk_job_socket;

{ It is assumed that the job socket has been locked by the caller.

    job_socket := nav$sk_job_socket_list^ [socket_id].job_socket;
    job_socket^.status := status;

  PROCEND nlp$sk_update_job_socket_status;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$sk_update_listen_socket', EJECT ??
*copy nlh$sk_update_listen_socket

  PROCEDURE [XDCL, #GATE] nlp$sk_update_listen_socket
    (    socket_id: nat$sk_socket_identifier;
         port: nat$sk_port_number);

    VAR
      job_socket: ^nat$sk_job_socket;

{ It is assumed that the job socket has been locked by the caller.

    job_socket := nav$sk_job_socket_list^ [socket_id].job_socket;
    job_socket^.port := port;
    job_socket^.tcp_socket_type := nlc$tcp_listen_socket;

  PROCEND nlp$sk_update_listen_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$sk_update_socket_options', EJECT ??
*copy nlh$sk_update_socket_options

  PROCEDURE [XDCL, #GATE] nlp$sk_update_socket_options
    (    socket_id: nat$sk_socket_identifier;
         options: nat$sk_socket_options);

    VAR
      i: integer,
      job_socket: ^nat$sk_job_socket;

{ It is assumed that the job socket has been locked by the caller and the
{ socket options have been verified by the caller.

    job_socket := nav$sk_job_socket_list^ [socket_id].job_socket;
    FOR i := 1 TO UPPERBOUND (options) DO
      CASE options [i].option_kind OF
      = nac$sk_interface_mode_opt =
        job_socket^.interface_mode := options [i].interface_mode;

      = nac$sk_interface_timeout_opt =
        job_socket^.interface_timeout := options [i].interface_timeout;

      = nac$sk_checksum_opt =
        job_socket^.checksum := options [i].checksum;

      = nac$sk_traffic_pattern_opt =
        job_socket^.traffic_pattern := options [i].traffic_pattern;

      = nac$sk_graceful_close_opt =
        job_socket^.graceful_close := options [i].graceful_close;

      = nac$sk_selection_criteria_opt =
        job_socket^.selection_criteria.port := options [i].port;
        job_socket^.selection_criteria.ip_address := options [i].ip_address;

      = nac$sk_local_addr_enabled_opt =
        job_socket^.local_ip_address_enabled := options [i].local_ip_address_enabled;

      = nac$sk_user_cache_enabled_opt =
        job_socket^.user_cache_enabled := options [i].user_cache_enabled;

      = nac$sk_reuse_address_opt =
        job_socket^.reuse_address := options [i].reuse_address;

      = nac$sk_broadcast_enabled_opt =
        job_socket^.broadcast_enabled := options [i].broadcast_enabled;
      ELSE { Invalid socket option
        nap$namve_system_error ( {Recoverable_error=} TRUE, 'Detected invalid socket options.', NIL);
      CASEND;
    FOREND;

  PROCEND nlp$sk_update_socket_options;
?? OLDTITLE ??
MODEND nlm$sk_service_routines_r2;

*DECK DECK=NLM$SK_SERVICE_ROUTINES_R3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access: Ring 3 Service Routines For Socket Layer' ??
MODULE nlm$sk_service_routines_r3;

{ PURPOSE:
{   This module contains procedures that execute in ring 3 and are needed to service
{   the NAM/VE Socket Layer.
{ DESIGN:
{   These procedures are called by the socket layer external interface code.
{   The XDCL'd procedures have been grouped in alphabetical order
{   followed by the internal procedures. The internal procedures are also in alphabetical
{   order.
{   This module contains code that resides on OSF$JOB_TEMPLATE_23D.
{
{ NOTES:
{   The following abbreviations have been used in this module:
{          TCP - Transmission Control Protocol
{          UDP - User Datagram Protocol

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc nae$sk_socket_layer
*copyc nat$connection_id
*copyc nat$wait_time
*copyc nlt$sk_offered_socket
*copyc nlt$sk_offered_sockets_list
*copyc nlt$tcp_socket_layer
*copyc nlt$tcp_socket_type
*copyc nlt$udp_global_socket
*copyc nlt$udp_global_socket_id
*copyc ost$caller_identifier
*copyc ost$global_task_id
*copyc ost$signature_lock_status
*copyc ost$status
?? POP ??
*copyc avp$get_capability
*copyc jmp$job_exists
*copyc nap$namve_system_error
*copyc nlp$cl_get_exclusive_via_cid
*copyc nlp$cl_get_layer_connection
*copyc nlp$cl_release_exclusive_access
*copyc nlp$udp_free_exclusive_access
*copyc nlp$udp_get_exclusive_via_gsid
*copyc osp$clear_job_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$test_signature_lock
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_job_names
*copyc pmp$ready_task
*copyc pmp$wait
*copyc syp$cycle
*copyc nav$network_paged_heap
*copyc nlv$sk_offered_sockets_list

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_accept_socket_offer', EJECT ??
*copy nlh$sk_accept_socket_offer

  PROCEDURE [XDCL] nlp$sk_accept_socket_offer
    (    source_job: jmt$system_supplied_name;
         socket_id: nat$sk_socket_identifier;
         time_stamp: ost$free_running_clock;
         wait_time: nat$wait_time;
     VAR socket_type: nat$sk_socket_type;
     VAR global_socket_id: nlt$udp_global_socket_id;
     VAR connection_id: nat$connection_id;
     VAR tcp_socket_type: nlt$tcp_socket_type;
     VAR bound_address: nat$sk_ip_address;
     VAR port: nat$sk_port_number;
     VAR traffic_pattern: nat$sk_traffic_pattern;
     VAR application: nat$application_name;
     VAR ring: ost$ring;
     VAR capability: ost$name;
     VAR status: ost$status);

?? NEWTITLE := 'terminate_accept_socket_offer', EJECT ??

    PROCEDURE terminate_accept_socket_offer
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

    VAR
      lock_status: ost$signature_lock_status;

      osp$test_signature_lock (nlv$sk_offered_sockets_list.lock, lock_status, handler_status);
      IF (handler_status.normal) AND (lock_status <> osc$sls_locked_by_another_task) THEN
        IF lock_status = osc$sls_not_locked THEN
          osp$set_job_signature_lock (nlv$sk_offered_sockets_list.lock);
        IFEND;
        remove_wait_for_socket_offer (current_task_id, source_job);
        osp$clear_job_signature_lock (nlv$sk_offered_sockets_list.lock);
      IFEND;
      handler_status.normal := TRUE;

    PROCEND terminate_accept_socket_offer;
?? OLDTITLE, EJECT ??

    VAR
      caller_id: ost$caller_identifier,
      capability_required: boolean,
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      current_job_name: jmt$system_supplied_name,
      current_task_id: ost$global_task_id,
      current_time: ost$free_running_clock,
      end_time: integer,
      global_socket: ^nlt$udp_global_socket,
      layer_active: boolean,
      offered_socket: ^nlt$sk_offered_socket,
      previous_wait_for_socket_offer: ^^nlt$sk_wait_for_socket_offer,
      remaining_time: integer,
      task_queued: boolean,
      tcp_connection: ^nlt$tcp_socket_layer,
      user_supplied_name: jmt$user_supplied_name,
      wait_for_socket_offer: ^nlt$sk_wait_for_socket_offer;

    pmp$get_job_names (user_supplied_name, current_job_name, {ignore} status);
    pmp$get_executing_task_gtid (current_task_id);
    status.normal := TRUE;
    #CALLER_ID (caller_id);
    task_queued := FALSE;
    end_time := #FREE_RUNNING_CLOCK (0) + wait_time*1000;
    remaining_time := wait_time;
    osp$establish_block_exit_hndlr (^terminate_accept_socket_offer);

  /accept_socket_offer/
    REPEAT
      osp$set_job_signature_lock (nlv$sk_offered_sockets_list.lock);

{ Search for socket offer from the given source job to the current job.

      offered_socket := nlv$sk_offered_sockets_list.offered_socket;
      WHILE (offered_socket <> NIL) AND ((offered_socket^.source_job <> source_job) OR
            (offered_socket^.destination_job <> current_job_name) OR
            (offered_socket^.status <> nlc$sk_offer_pending)) DO
        offered_socket := offered_socket^.next_entry;
      WHILEND;

      IF offered_socket <> NIL THEN

{ Validate caller's ring.

        IF caller_id.ring <= offered_socket^.ring THEN
          IF offered_socket^.capability <> osc$null_name THEN
            offered_socket^.status := nlc$sk_offer_being_validated;
            capability := offered_socket^.capability;
            osp$clear_job_signature_lock (nlv$sk_offered_sockets_list.lock);
            avp$get_capability (capability, avc$user, capability_required, status);
            IF NOT capability_required THEN
              osp$set_status_abnormal ('AV', ave$missing_required_capability, capability, status);
            IFEND;
            IF NOT status.normal THEN
              IF task_queued THEN
                osp$set_job_signature_lock (nlv$sk_offered_sockets_list.lock);
                remove_wait_for_socket_offer (current_task_id, source_job);
                osp$clear_job_signature_lock (nlv$sk_offered_sockets_list.lock);
              IFEND;
              EXIT /accept_socket_offer/;
            ELSE  { valid user
              osp$set_job_signature_lock (nlv$sk_offered_sockets_list.lock);

{ Search the offered socket from the given source job and with status of
{ nlc$sk_offer_being_validated. This is necessary because the socket
{ offer could have been canceled in the meantime.

              offered_socket := nlv$sk_offered_sockets_list.offered_socket;
              WHILE (offered_socket <> NIL) AND ((offered_socket^.source_job <> source_job) OR
                    (offered_socket^.destination_job <> current_job_name) OR
                    (offered_socket^.status <> nlc$sk_offer_being_validated)) DO
                offered_socket := offered_socket^.next_entry;
              WHILEND;
            IFEND;
          IFEND;
        ELSE { invalid user
          IF task_queued THEN
            remove_wait_for_socket_offer (current_task_id, source_job);
          IFEND;
          osp$set_status_abnormal (nac$status_id, nae$sk_invalid_user, 'NAP$SK_ACCEPT_SOCKET_OFFER',
                status);
          osp$clear_job_signature_lock (nlv$sk_offered_sockets_list.lock);
          EXIT /accept_socket_offer/;
        IFEND;
      IFEND;
        IF offered_socket <> NIL THEN
           offered_socket^.status := nlc$sk_offer_accepted;
           socket_type := offered_socket^.socket_type;
           bound_address := offered_socket^.bound_address;
           traffic_pattern := offered_socket^.traffic_pattern;
           port := offered_socket^.port;
           application := offered_socket^.application;
           ring := offered_socket^.ring;
           capability := offered_socket^.capability;
           IF socket_type = nac$sk_udp_socket THEN
             global_socket_id := offered_socket^.global_socket_id;
             nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
             IF global_socket <> NIL THEN

{ Just reuse the existing global socket.
{ Store the new job socket id and the time stamp in the global socket structure.
{ Note that if the global socket has been terminated, it will be switched to the
{ accepting job.

                IF global_socket^.status = nlc$udp_global_socket_offered THEN
                  global_socket^.status := nlc$udp_global_socket_open;
                IFEND;
                global_socket^.local_socket_id := socket_id;
                global_socket^.time_stamp := time_stamp;
                nlp$udp_free_exclusive_access (global_socket);
              IFEND;
            ELSE
             connection_id := offered_socket^.connection_id;
             tcp_socket_type := offered_socket^.tcp_socket_type;
             nlp$cl_get_exclusive_via_cid (offered_socket^.connection_id, connection_exists,
                    cl_connection);
             IF cl_connection <> NIL THEN
               nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active,
                      tcp_connection);
               IF layer_active THEN
                 IF tcp_connection^.state = nlc$tcp_conn_offered THEN
                   tcp_connection^.state := nlc$tcp_conn_open;
                   tcp_connection^.socket_id := socket_id;
                 ELSEIF (tcp_connection^.state = nlc$tcp_conn_closed) OR
                   (tcp_connection^.state = nlc$tcp_conn_closing) OR
                   (tcp_connection^.state = nlc$tcp_conn_terminated) THEN

{ Do not update the state of the connection.

                      tcp_connection^.socket_id := socket_id;
                  IFEND;
                ELSE { Layer inactive
{ The connection is assumed to have been terminated via application mangement.
{ Note a terminated connection is being switched.
                  IFEND;
                  nlp$cl_release_exclusive_access (cl_connection);
                ELSE { cl_connection = NIL
{ The connection is assumed to have been terminated via application mangement.
{ Note a terminated connection is being switched.
                IFEND;
              IFEND;

            IF offered_socket^.waiting_task.index <> 0 THEN
              pmp$ready_task (offered_socket^.waiting_task, {ignore} status);
              status.normal := TRUE;
            IFEND;

{ The task offering the socket will dequeue the task from the wait for socket offer queue.

            osp$clear_job_signature_lock (nlv$sk_offered_sockets_list.lock);
            EXIT /accept_socket_offer/;
      ELSE { No socket offer
        IF remaining_time > 0 THEN

{ Queue the task in the wait for socket offer queue (if not already queued).

          IF NOT task_queued THEN
            REPEAT
              ALLOCATE wait_for_socket_offer IN nav$network_paged_heap^;
              IF wait_for_socket_offer = NIL THEN
                syp$cycle;
              IFEND;
            UNTIL wait_for_socket_offer <> NIL;
            wait_for_socket_offer^.next_entry := NIL;
            wait_for_socket_offer^.waiting_task_id := current_task_id;
            wait_for_socket_offer^.waiting_job := current_job_name;
            wait_for_socket_offer^.source_job := source_job;
            previous_wait_for_socket_offer := ^nlv$sk_offered_sockets_list.wait_for_socket_offer;
            WHILE (previous_wait_for_socket_offer^ <> NIL) DO
              previous_wait_for_socket_offer := ^previous_wait_for_socket_offer^^.next_entry;
            WHILEND;
            previous_wait_for_socket_offer^ := wait_for_socket_offer;
            task_queued := TRUE;
          IFEND;
          osp$clear_job_signature_lock (nlv$sk_offered_sockets_list.lock);
          pmp$wait (remaining_time, remaining_time);
          current_time := #FREE_RUNNING_CLOCK (0);
          IF current_time < end_time THEN
            remaining_time := (end_time - current_time) DIV 1000;
          ELSE
            remaining_time := 0;
          IFEND;
        ELSE { Remaining_time = 0

{ Dequeue the task from the wait for socket offer queue (if queued).

          IF task_queued THEN
            task_queued := FALSE;
            remove_wait_for_socket_offer (current_task_id, source_job);
          IFEND;
          osp$clear_job_signature_lock (nlv$sk_offered_sockets_list.lock);
          osp$set_status_abnormal (nac$status_id, nae$sk_no_socket_offered, source_job, status);
        IFEND;
      IFEND;
    UNTIL (NOT status.normal);

    osp$disestablish_cond_handler;

  PROCEND nlp$sk_accept_socket_offer;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_await_socket_offer', EJECT ??
*copy nlh$sk_await_socket_offer

  PROCEDURE [XDCL] nlp$sk_await_socket_offer
    (    source_job: jmt$system_supplied_name;
         wait: boolean;
     VAR activity_complete: boolean);

    VAR
      current_job_name: jmt$system_supplied_name,
      current_task_id: ost$global_task_id,
      ignore_status: ost$status,
      offered_socket: ^nlt$sk_offered_socket,
      previous_offered_socket: ^^nlt$sk_offered_socket,
      previous_wait_for_socket_offer: ^^nlt$sk_wait_for_socket_offer,
      user_supplied_name: jmt$user_supplied_name,
      wait_for_socket_offer: ^nlt$sk_wait_for_socket_offer;

    activity_complete := FALSE;
    pmp$get_executing_task_gtid (current_task_id);
    pmp$get_job_names (user_supplied_name, current_job_name, ignore_status);
    osp$set_job_signature_lock (nlv$sk_offered_sockets_list.lock);

{ Check if a socket offer has been made by the source job.

    offered_socket := nlv$sk_offered_sockets_list.offered_socket;
    WHILE (offered_socket <> NIL) AND ((offered_socket^.source_job <> source_job) OR
          (offered_socket^.destination_job <> current_job_name)) DO
      offered_socket := offered_socket^.next_entry;
    WHILEND;
    IF offered_socket <> NIL THEN
      activity_complete := TRUE;
    ELSEIF wait THEN

{ Queue the task in the wait for socket offer list (if not already queued).

      previous_wait_for_socket_offer := ^nlv$sk_offered_sockets_list.wait_for_socket_offer;
      WHILE (previous_wait_for_socket_offer^ <> NIL) AND (previous_wait_for_socket_offer^^.
            waiting_task_id <> current_task_id) DO
        previous_wait_for_socket_offer := ^previous_wait_for_socket_offer^^.next_entry;
      WHILEND;
      IF previous_wait_for_socket_offer^ = NIL THEN
        REPEAT
          ALLOCATE wait_for_socket_offer IN nav$network_paged_heap^;
          IF wait_for_socket_offer = NIL THEN
            syp$cycle;
          IFEND;
        UNTIL wait_for_socket_offer <> NIL;
        wait_for_socket_offer^.next_entry := NIL;
        wait_for_socket_offer^.waiting_task_id := current_task_id;
        wait_for_socket_offer^.waiting_job := current_job_name;
        wait_for_socket_offer^.source_job := source_job;
        previous_wait_for_socket_offer^ := wait_for_socket_offer;
      IFEND;
    IFEND;

    osp$clear_job_signature_lock (nlv$sk_offered_sockets_list.lock);

  PROCEND nlp$sk_await_socket_offer;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_offer_socket', EJECT ??
*copy nlh$sk_offer_socket

  PROCEDURE [XDCL] nlp$sk_offer_socket
    (    socket_id: nat$sk_socket_identifier;
         destination_job: jmt$system_supplied_name;
         socket_type: nat$sk_socket_type;
         global_socket_id: nlt$udp_global_socket_id;
         connection_id: nat$connection_id;
         tcp_socket_type: nlt$tcp_socket_type;
         port: nat$sk_port_number;
         bound_address: nat$sk_ip_address;
         traffic_pattern: nat$sk_traffic_pattern;
         application: nat$application_name;
         ring: ost$ring;
         capability: ost$name;
         wait_time: nat$wait_time;
     VAR offer_accepted: boolean);

?? NEWTITLE := 'terminate_offer_socket', EJECT ??

    PROCEDURE terminate_offer_socket
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

    VAR
      lock_status: ost$signature_lock_status;

      osp$test_signature_lock (nlv$sk_offered_sockets_list.lock, lock_status, handler_status);
      IF (handler_status.normal) AND (lock_status <> osc$sls_locked_by_another_task) THEN
        IF lock_status = osc$sls_not_locked THEN
          osp$set_job_signature_lock (nlv$sk_offered_sockets_list.lock);
        IFEND;

{ Remove the offered socket.

        offered_socket := nlv$sk_offered_sockets_list.offered_socket;
        previous_offered_socket := ^nlv$sk_offered_sockets_list.offered_socket;
        WHILE (offered_socket <> NIL) AND ((offered_socket^.socket_id <> socket_id) OR
              (offered_socket^.source_job <> current_job_name)) DO
          previous_offered_socket := ^offered_socket^.next_entry;
          offered_socket := offered_socket^.next_entry;
        WHILEND;

        IF offered_socket <> NIL THEN
          offer_accepted := offered_socket^.status = nlc$sk_offer_accepted;

{ Remove the offered socket entry from the list.

          previous_offered_socket^ := offered_socket^.next_entry;
          FREE offered_socket IN nav$network_paged_heap^;
        IFEND;
        osp$clear_job_signature_lock (nlv$sk_offered_sockets_list.lock);
      IFEND;
      handler_status.normal := TRUE;

    PROCEND terminate_offer_socket;
?? OLDTITLE, EJECT ??

    CONST
      poll_time = 5000;

    VAR
      current_job_name: jmt$system_supplied_name,
      current_task_id: ost$global_task_id,
      current_time: ost$free_running_clock,
      destination_job_exists: boolean,
      end_time: integer,
      ignore_status: ost$status,
      offered_socket: ^nlt$sk_offered_socket,
      previous_offered_socket: ^^nlt$sk_offered_socket,
      previous_wait_for_socket_offer: ^^nlt$sk_wait_for_socket_offer,
      remaining_time: integer,
      user_supplied_name: jmt$user_supplied_name,
      wait_for_socket_offer: ^nlt$sk_wait_for_socket_offer;

    offer_accepted := FALSE;

{ If the destination job does not exist, there is no point in proceeding.

    jmp$job_exists (destination_job, $jmt$job_state_set [jmc$queued_job, jmc$initiated_job],
          destination_job_exists, ignore_status);
    IF NOT destination_job_exists THEN
      RETURN;
    IFEND;

    pmp$get_job_names (user_supplied_name, current_job_name, ignore_status);
    pmp$get_executing_task_gtid (current_task_id);
    REPEAT
      ALLOCATE offered_socket IN nav$network_paged_heap^;
      IF offered_socket = NIL THEN
        syp$cycle;
      IFEND;
    UNTIL offered_socket <> NIL;
    offered_socket^.next_entry := NIL;
    offered_socket^.socket_id := socket_id;
    offered_socket^.status := nlc$sk_offer_pending;
    offered_socket^.source_job := current_job_name;
    offered_socket^.application := application;
    offered_socket^.ring := ring;
    offered_socket^.capability := capability;
    offered_socket^.system_privilege := FALSE;
    offered_socket^.port := port;
    offered_socket^.bound_address := bound_address;
    offered_socket^.traffic_pattern := traffic_pattern;
    offered_socket^.socket_type := socket_type;
    IF socket_type = nac$sk_udp_socket THEN
      offered_socket^.global_socket_id := global_socket_id;
    ELSE
      offered_socket^.connection_id := connection_id;
      offered_socket^.tcp_socket_type := tcp_socket_type;
    IFEND;

    offered_socket^.destination_job := destination_job;
    IF wait_time > 0 THEN
      offered_socket^.waiting_task := current_task_id;
    ELSE
      offered_socket^.waiting_task.index := 0;
    IFEND;

    osp$establish_block_exit_hndlr (^terminate_offer_socket);
    osp$set_job_signature_lock (nlv$sk_offered_sockets_list.lock);

{ Add the offered socket entry at the end of the list.

    previous_offered_socket := ^nlv$sk_offered_sockets_list.offered_socket;
    WHILE previous_offered_socket^ <> NIL DO
      previous_offered_socket := ^previous_offered_socket^^.next_entry;
    WHILEND;
    previous_offered_socket^ := offered_socket;

{ Search the wait for socket offer list for a task waiting for a socket offer
{ from the current job.

    previous_wait_for_socket_offer := ^nlv$sk_offered_sockets_list.wait_for_socket_offer;
    wait_for_socket_offer := nlv$sk_offered_sockets_list.wait_for_socket_offer;
    WHILE (wait_for_socket_offer <> NIL) AND ((wait_for_socket_offer^.source_job <>
      current_job_name) OR (wait_for_socket_offer^.waiting_job <> destination_job)) DO
      previous_wait_for_socket_offer := ^wait_for_socket_offer^.next_entry;
      wait_for_socket_offer := wait_for_socket_offer^.next_entry;
    WHILEND;

    IF wait_for_socket_offer <> NIL THEN
      pmp$ready_task (wait_for_socket_offer^.waiting_task_id, ignore_status);

{ Delink the wait for socket offer entry.

      previous_wait_for_socket_offer^ := wait_for_socket_offer^.next_entry;
      FREE wait_for_socket_offer IN nav$network_paged_heap^;
    IFEND;

    osp$clear_job_signature_lock (nlv$sk_offered_sockets_list.lock);

{ Wait for the socket offer to be accepted.

    end_time := #FREE_RUNNING_CLOCK (0) + wait_time*1000;
    remaining_time := wait_time;
    IF remaining_time > poll_time THEN
      remaining_time := poll_time;
    IFEND;
    REPEAT
      IF remaining_time > 0 THEN
        pmp$wait (remaining_time, remaining_time);
        current_time := #FREE_RUNNING_CLOCK (0);
        IF current_time < end_time THEN
          remaining_time := (end_time - current_time) DIV 1000;
          IF remaining_time > poll_time THEN
            remaining_time := poll_time;
          IFEND;
        ELSE
          remaining_time := 0;
        IFEND;
      IFEND;

{ Check if the socket offer has been accepted.

      osp$set_job_signature_lock (nlv$sk_offered_sockets_list.lock);

{ Find the offered socket matching the given socket id and the destination job name.

      offered_socket := nlv$sk_offered_sockets_list.offered_socket;
      previous_offered_socket := ^nlv$sk_offered_sockets_list.offered_socket;
      WHILE (offered_socket <> NIL) AND ((offered_socket^.socket_id <> socket_id) OR
            (offered_socket^.source_job <> current_job_name)) DO
        previous_offered_socket := ^offered_socket^.next_entry;
        offered_socket := offered_socket^.next_entry;
      WHILEND;

      IF offered_socket <> NIL THEN
        jmp$job_exists (destination_job, $jmt$job_state_set [jmc$queued_job, jmc$initiated_job],
              destination_job_exists, ignore_status);
        IF (offered_socket^.status = nlc$sk_offer_accepted) OR (remaining_time = 0) OR
              (NOT destination_job_exists) THEN
          offer_accepted := offered_socket^.status = nlc$sk_offer_accepted;

{ Remove the offered socket entry from the list.

          previous_offered_socket^ := offered_socket^.next_entry;
          FREE offered_socket IN nav$network_paged_heap^;
        IFEND;
      ELSE
        nap$namve_system_error ( {Recoverable_error=} TRUE, 'Lost offered socket entry for the current job.',
              NIL);
        remaining_time := 0; { Terminate request }
      IFEND;
      osp$clear_job_signature_lock (nlv$sk_offered_sockets_list.lock);
    UNTIL (offer_accepted) OR (remaining_time <= 0) OR (NOT destination_job_exists);

    osp$disestablish_cond_handler;

  PROCEND nlp$sk_offer_socket;
?? OLDTITLE ??
?? NEWTITLE := 'nlp$sk_remove_wait_socket_offer', EJECT ??
*copy nlh$sk_remove_wait_socket_offer

  PROCEDURE [XDCL] nlp$sk_remove_wait_socket_offer
    (    source_job: jmt$system_supplied_name);

    VAR
      current_task_id: ost$global_task_id;

    pmp$get_executing_task_gtid (current_task_id);
    osp$set_job_signature_lock (nlv$sk_offered_sockets_list.lock);
    remove_wait_for_socket_offer (current_task_id, source_job);
    osp$clear_job_signature_lock (nlv$sk_offered_sockets_list.lock);

  PROCEND nlp$sk_remove_wait_socket_offer;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] remove_wait_for_socket_offer', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to remove the given task from
{   the queue of tasks waiting for socket offer from specified jobs.

  PROCEDURE [INLINE] remove_wait_for_socket_offer (
    current_task_id: ost$global_task_id;
    source_job: jmt$system_supplied_name);

    VAR
      previous_wait_for_socket_offer: ^^nlt$sk_wait_for_socket_offer,
      wait_for_socket_offer: ^nlt$sk_wait_for_socket_offer;

    previous_wait_for_socket_offer := ^nlv$sk_offered_sockets_list.wait_for_socket_offer;
    wait_for_socket_offer := nlv$sk_offered_sockets_list.wait_for_socket_offer;
    WHILE (wait_for_socket_offer <> NIL) AND ((wait_for_socket_offer^.waiting_task_id <>
          current_task_id) OR (wait_for_socket_offer^.source_job <> source_job)) DO
      previous_wait_for_socket_offer := ^wait_for_socket_offer^.next_entry;
      wait_for_socket_offer := wait_for_socket_offer^.next_entry;
    WHILEND;
    IF wait_for_socket_offer <> NIL THEN
      previous_wait_for_socket_offer^ := wait_for_socket_offer^.next_entry;
      FREE wait_for_socket_offer IN nav$network_paged_heap^;
    IFEND;

  PROCEND remove_wait_for_socket_offer;
?? OLDTITLE ??
MODEND nlm$sk_service_routines_r3;
*DECK DECK=NLM$SK_STATIC_DATA EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'NAM/VE: Socket Layer Static Data - oss$network_paged' ??
MODULE nlm$sk_static_data;

{ PURPOSE:
{   This module contains all the static data refereced by the Socket Layer
{ code for both UDP and TCP.

?? PUSH (LISTEXT := ON) ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc nlc$sk_min_assigned_port
*copyc nlt$sk_offered_sockets_list
*copyc nlt$tcp_listen_sockets
*copyc nlt$tcp_ports
*copyc nlt$tm_addr_access_req_queue
*copyc nlt$tm_device_configuration
*copyc nlt$tm_local_host_name
*copyc nlt$tm_route_cache
*copyc nlt$tm_static_routing_table
*copyc nlt$tm_subnet_list
*copyc nlt$udp_ports
*copyc nlt$udp_global_sockets
*copyc nlt$udp_reference_number
*copyc oss$network_paged
?? POP ??
?? OLDTITLE ??
?? NEWTITLE := '  NAM/VE Socket Layer Global Variables', EJECT ??

  VAR
    nav$sk_socket_layer_active: [XDCL, #GATE, oss$network_paged] boolean := FALSE,
    nlv$sk_offered_sockets_list: [XDCL, #GATE, oss$network_paged] nlt$sk_offered_sockets_list :=
      [[0], NIL, NIL],
    nlv$udp_active_global_sockets: [XDCL, #GATE, oss$network_paged] nlt$udp_reference_number := 0,
    nlv$tcp_listen_sockets: [XDCL, #GATE, oss$network_paged] nlt$tcp_listen_sockets := [[0, FALSE,
      0], NIL],
    nlv$tcp_ports: [XDCL, #GATE, oss$network_paged] nlt$tcp_ports :=
      [[0], nlc$sk_min_assigned_port, NIL],
    nlv$udp_ports: [XDCL, #GATE, oss$network_paged] nlt$udp_ports :=
      [[0], nlc$sk_min_assigned_port, NIL],
    nlv$udp_global_sockets: [XDCL, #GATE, oss$network_paged] nlt$udp_global_sockets :=
      [0, 0, nil],
    nlv$udp_global_sockets_control: [XDCL, #GATE, oss$network_paged] nlt$udp_global_sockets_control :=
      [nlc$udp_global_sockets_unlocked];

?? OLDTITLE ??
?? NEWTITLE := 'NAM/VE TCP/IP Management Global Variables', EJECT ??
{
{ PURPOSE:
{   This variable contains all of the outstanding address accessible requests.
{   A request is queued when all of the configured devices are queried for a
{   specific destination address.  As each device responds the request is updated.
{   After the last device responds the request is removed from the queue.  The
{   requestor will be readied and informed which device if any is the best route
{   to the destination address.
{

  VAR
    nlv$tm_address_accessible: [XDCL, #GATE, oss$network_paged] nlt$tm_addr_access_req_queue :=
          [[0] ,NIL];
{ NOTE:
{   The intent of this variable is to hold information about each configured device.

  VAR
    nlv$tm_device_configuration: [XDCL, #GATE, oss$network_paged] ^nlt$tm_device_configuration := NIL;

{ NOTE:
{   nlv$tm_host is initiallized by the DEFINE_TCPIP_HOST command.

  VAR
    nlv$tm_host: [XDCL, #GATE, oss$network_paged] nlt$tm_local_host_name := [0, *];

{ NOTE:
{   The route cache is enabled with the DEFINE_TCPIP_HOST command.

  VAR
    nlv$tm_route_cache: [XDCL, #GATE, oss$network_paged] nlt$tm_route_cache := [
       [REP nlc$tm_hash_elements of [[0], NIL]], 4, 60000, 60000];
{ NOTE:
{   The static routing table is built with the DEFINE_STATIC_ROUTE command.

  VAR
    nlv$tm_static_routing_table: [XDCL, #GATE, oss$network_paged] nlt$tm_static_routing_table :=
          [[0, FALSE, 0],NIL];

{ NOTE:
{   The subnet list is enabled with the DEFINE_TCPIP_HOST command.

  VAR
    nlv$tm_subnet_list: [XDCL, #GATE, oss$network_paged] nlt$tm_subnet_list := [[0, FALSE, 0], NIL];
?? OLDTITLE ??
MODEND nlm$sk_static_data;
*DECK DECK=NLM$SK_TCP_SOCKET_LAYER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access: Internal TCP Portion Of The Socket Layer' ??
MODULE nlm$sk_tcp_socket_layer;

{ PURPOSE:
{   This module contains procedures neccesary to support the TCP portion of the
{   socket layer.
{ DESIGN:
{   These procedures are called by the socket layer external interface code and in turn
{   interface to the TCP Access Agent.
{   The XDCL'd procedures have been grouped in alphabetical order
{   followed by the internal procedures. The internal procedures are also in alphabetical
{   order.
{   This module contains code that executes in ring 3. It resides on OSF$JOB_TEMPLATE_23D.
{
{ NOTES:
{   The following abbreviations have been used in this module:
{          TCP - Transmission Control Protocol

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nac$null_connection_id
*copyc nac$sk_all_ip_addresses
*copyc nae$sk_socket_layer
*copyc nat$application_name
*copyc nat$connection_id
*copyc nat$data_fragments
*copyc nat$sk_interface_mode
*copyc nat$sk_listen_queue_limit
*copyc nat$sk_socket_identifier
*copyc nat$sk_traffic_pattern
*copyc nat$wait_time
*copyc nlc$udp_null_global_socket_id
*copyc nlt$bm_message_id
*copyc nlt$cl_connection
*copyc nlt$cl_layer_name
*copyc nlt$device_count
*copyc nlt$device_identifier
*copyc nlt$tcp_listen_socket
*copyc nlt$tcp_listen_sockets
*copyc nlt$tcp_sender_task
*copyc nlt$tcp_received_data
*copyc nlt$tcp_received_socket
*copyc nlt$tcp_receiver_task
*copyc nlt$tcp_socket_layer
*copyc nlt$tcp_wait_for_socket
*copyc nlt$tcpaa_event
*copyc nlt$tm_device_address_list
*copyc ost$free_running_clock
*copyc ost$global_task_id
*copyc ost$signature_lock_status
*copyc ost$status
?? POP ??
*copyc nap$namve_system_error
*copyc nlp$bm_concatenate_messages
*copyc nlp$bm_create_message
*copyc nlp$bm_deliver_message
*copyc nlp$bm_get_message_resources
*copyc nlp$bm_release_message
*copyc nlp$cc_receive_data
*copyc nlp$cc_report_undelivered_data
*copyc nlp$cl_activate_layer
*copyc nlp$cl_activate_receiver
*copyc nlp$cl_activate_sender
*copyc nlp$cl_create_connection
*copyc nlp$cl_deactivate_layer
*copyc nlp$cl_deactivate_receiver
*copyc nlp$cl_deactivate_sender
*copyc nlp$cl_get_exclusive_via_cid
*copyc nlp$cl_get_layer_connection
*copyc nlp$cl_initialize_template
*copyc nlp$cl_release_exclusive_access
*copyc nlp$get_exclusive_access
*copyc nlp$get_nonexclusive_access
*copyc nlp$osi_get_outbound_capacity
*copyc nlp$release_exclusive_access
*copyc nlp$release_nonexclusive_access
*copyc nlp$sk_fragment_data
*copyc nlp$sk_tcp_deactivate_layer
*copyc nlp$sk_tcp_get_rec_task_entry
*copyc nlp$sk_tcp_get_send_task_entry
*copyc nlp$sk_tcp_ret_rec_data_entry
*copyc nlp$sk_tcp_ret_rec_task_entry
*copyc nlp$sk_tcp_ret_send_task_entry
*copyc nlp$tcp_accept_socket
*copyc nlp$tcp_flush_release_socket
*copyc nlp$tcp_initialize
*copyc nlp$tcp_listen_socket
*copyc nlp$tcp_release_socket
*copyc nlp$tcp_send_data_fragments
*copyc nlp$tcp_set_socket_options
*copyc nlp$tcpip_decrement_appl_access
*copyc nlp$tcpip_increment_appl_access
*copyc nlp$tcpip_set_socket_assigned
*copyc nlp$tm_get_local_tcp_devices
*copyc nlp$tm_select_by_local_tcp_addr
*copyc osp$append_status_integer
*copyc osp$clear_job_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc pmp$continue_to_cause
*copyc pmp$get_executing_task_gtid
*copyc pmp$ready_task
*copyc pmp$wait
*copyc syp$cycle

*copyc nav$network_paged_heap
*copyc nlv$bm_null_message_id
*copyc nlv$configured_network_devices
*copyc nlv$tcp_listen_sockets
*copyc nav$network_paged_heap
*copyc oss$job_paged_literal

  VAR
    unexpected_state: [STATIC, READ, oss$job_paged_literal] string (17) := 'Unexpected state.';

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_accept_socket', EJECT ??
*copy nlh$sk_tcp_accept_socket

  PROCEDURE [XDCL] nlp$sk_tcp_accept_socket
    (    port: nat$sk_port_number;
         bound_address: nat$sk_ip_address;
         graceful_close: boolean;
         traffic_pattern: nat$sk_traffic_pattern;
         wait_time: nat$wait_time;
     VAR connection_id: nat$connection_id;
     VAR source_socket: nat$sk_socket_address;
     VAR local_ip_address: nat$sk_ip_address;
     VAR status: ost$status);

?? NEWTITLE := 'terminate_accept_socket', EJECT ??

    PROCEDURE terminate_accept_socket
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

{ Dequeue the task from the wait list.

      nlp$get_nonexclusive_access (nlv$tcp_listen_sockets.access_control);
      listen_socket := nlv$tcp_listen_sockets.list;
      WHILE (listen_socket <> NIL) AND ((listen_socket^.port <> port) OR
            (listen_socket^.bound_address <> bound_address)) DO
        listen_socket := listen_socket^.next_entry;
      WHILEND;
      IF listen_socket <> NIL THEN
        nlp$get_exclusive_access (listen_socket^.access_control);
        previous_wait_for_socket := ^listen_socket^.wait_for_socket_list;
        WHILE (previous_wait_for_socket^ <> NIL) AND (previous_wait_for_socket^^.task_id <> current_task_id)
              DO
          previous_wait_for_socket := ^previous_wait_for_socket^^.next_entry;
        WHILEND;
        IF previous_wait_for_socket^ <> NIL THEN
          wait_for_socket := previous_wait_for_socket^;
          previous_wait_for_socket^ := wait_for_socket^.next_entry;
          FREE wait_for_socket IN nav$network_paged_heap^;
        IFEND;
        nlp$release_exclusive_access (listen_socket^.access_control);
      IFEND;
      nlp$release_nonexclusive_access (nlv$tcp_listen_sockets.access_control);

    PROCEND terminate_accept_socket;
?? OLDTITLE, EJECT ??

    VAR
      application: nat$application_name,
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      current_task_id: ost$global_task_id,
      current_time: ost$free_running_clock,
      end_time: integer,
      layer_active: boolean,
      listen_socket: ^nlt$tcp_listen_socket,
      previous_wait_for_socket: ^^nlt$tcp_wait_for_socket,
      received_socket: ^nlt$tcp_received_socket,
      remaining_time: integer,
      tcp_connection: ^nlt$tcp_socket_layer,
      wait_for_socket: ^nlt$tcp_wait_for_socket;

    status.normal := TRUE;
    pmp$get_executing_task_gtid (current_task_id);
    remaining_time := wait_time;
    end_time := #FREE_RUNNING_CLOCK (0) + remaining_time * 1000;
    osp$establish_block_exit_hndlr (^terminate_accept_socket);

  /accept_socket/
    REPEAT
      nlp$get_nonexclusive_access (nlv$tcp_listen_sockets.access_control);

{ Find the listen socket corresponding to the given listen socket id.

      listen_socket := nlv$tcp_listen_sockets.list;
      WHILE (listen_socket <> NIL) AND ((listen_socket^.port <> port) OR
            (listen_socket^.bound_address <> bound_address)) DO
        listen_socket := listen_socket^.next_entry;
      WHILEND;
      IF listen_socket <> NIL THEN
        nlp$get_exclusive_access (listen_socket^.access_control);
        IF listen_socket^.received_sockets <> NIL THEN
          received_socket := listen_socket^.received_sockets;

          IF received_socket^.connected OR (received_socket^.release_reason = nlc$tcpaa_ri_user_termination)
                THEN
          application := listen_socket^.application;
          connection_id := received_socket^.connection_id;
          source_socket := received_socket^.source_socket;
          local_ip_address := received_socket^.destination_socket.ip_address;
          listen_socket^.received_sockets := received_socket^.next_entry;
          FREE received_socket IN nav$network_paged_heap^;

{ Dequeue the task from the wait for socket list.

          previous_wait_for_socket := ^listen_socket^.wait_for_socket_list;
          WHILE (previous_wait_for_socket^ <> NIL) AND (previous_wait_for_socket^^.task_id <> current_task_id)
                DO
            previous_wait_for_socket := ^previous_wait_for_socket^^.next_entry;
          WHILEND;
          IF previous_wait_for_socket^ <> NIL THEN
            wait_for_socket := previous_wait_for_socket^;
            previous_wait_for_socket^ := wait_for_socket^.next_entry;
            FREE wait_for_socket IN nav$network_paged_heap^;
          IFEND;
          nlp$release_exclusive_access (listen_socket^.access_control);
          nlp$release_nonexclusive_access (nlv$tcp_listen_sockets.access_control);

{ Send an accept socket request to the peer.

          cl_connection := NIL;
          layer_active := FALSE;
          IF connection_id <> nac$null_connection_id THEN
            nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
            IF cl_connection <> NIL THEN
              nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active, tcp_connection);
            IFEND;
          IFEND;
          IF (cl_connection <> NIL) AND (layer_active) THEN
            IF tcp_connection^.state = nlc$tcp_conn_await_accept THEN
              nlp$tcp_accept_socket (cl_connection, graceful_close, traffic_pattern, nlc$cc_normal_class,
                    {ignore} status);
              status.normal := TRUE;
              tcp_connection^.state := nlc$tcp_conn_open;
              nlp$cl_release_exclusive_access (cl_connection);

{ Request application management to update the socket status.

              nlp$tcpip_set_socket_assigned (application, connection_id, {ignore} status);
              status.normal := TRUE;
              EXIT /accept_socket/;
            ELSE { Connection closed
              nlp$cl_deactivate_layer (nlc$tcp_interface, cl_connection);
              nlp$cl_release_exclusive_access (cl_connection);
              nlp$tcpip_decrement_appl_access (application, nlc$udp_null_global_socket_id, connection_id,
                    {ignore} status);

{ Return the disconnected connection.

              connection_id := nac$null_connection_id;
              EXIT /accept_socket/;
            IFEND;
          ELSE { cl_connection = NIL or NOT layer_active

{ Return the disconnected connection.

            connection_id := nac$null_connection_id;
            IF cl_connection <> NIL THEN
              nlp$cl_release_exclusive_access (cl_connection);
            IFEND;
            EXIT /accept_socket/;
          IFEND;

          ELSE { Network disconnect

{ On network disconnects (assumed be anything except 'user termination') the received socket is discarded
{ with no notification to the calling procedure.

            listen_socket^.received_sockets := received_socket^.next_entry;
            FREE received_socket IN nav$network_paged_heap^;
            nlp$release_exclusive_access (listen_socket^.access_control);
            nlp$release_nonexclusive_access (nlv$tcp_listen_sockets.access_control);
            CYCLE /accept_socket/;
          IFEND;
        ELSE { No received sockets

{ Check if task already queued in the wait for socket list.

          previous_wait_for_socket := ^listen_socket^.wait_for_socket_list;
          WHILE (previous_wait_for_socket^ <> NIL) AND (previous_wait_for_socket^^.task_id <> current_task_id)
                DO
            previous_wait_for_socket := ^previous_wait_for_socket^^.next_entry;
          WHILEND;
          IF remaining_time > 0 THEN
            IF previous_wait_for_socket^ = NIL THEN

{ Queue the task.

              REPEAT
                ALLOCATE wait_for_socket IN nav$network_paged_heap^;
                IF wait_for_socket = NIL THEN
                  syp$cycle;
                IFEND;
              UNTIL wait_for_socket <> NIL;
              wait_for_socket^.next_entry := NIL;
              wait_for_socket^.task_id := current_task_id;
              previous_wait_for_socket^ := wait_for_socket;
            IFEND;

            nlp$release_exclusive_access (listen_socket^.access_control);
            nlp$release_nonexclusive_access (nlv$tcp_listen_sockets.access_control);
            pmp$wait (remaining_time, remaining_time);
            current_time := #FREE_RUNNING_CLOCK (0);
            IF end_time > current_time THEN
              remaining_time := (end_time - current_time) DIV 1000;
            ELSE
              remaining_time := 0;
            IFEND;
            CYCLE /accept_socket/;
          ELSE { wait_time = 0
            IF previous_wait_for_socket^ <> NIL THEN

{ Dequeue the task.

              wait_for_socket := previous_wait_for_socket^;
              previous_wait_for_socket^ := wait_for_socket^.next_entry;
              FREE wait_for_socket IN nav$network_paged_heap^;
            IFEND;
            osp$set_status_condition (nae$sk_no_accept_socket, status);
            nlp$release_exclusive_access (listen_socket^.access_control);
            nlp$release_nonexclusive_access (nlv$tcp_listen_sockets.access_control);
          IFEND;
        IFEND;
      ELSE { listen_socket = NIL
        nlp$release_nonexclusive_access (nlv$tcp_listen_sockets.access_control);
        osp$set_status_condition (nae$sk_socket_terminated, status);
      IFEND;
    UNTIL NOT status.normal;

    osp$disestablish_cond_handler;

  PROCEND nlp$sk_tcp_accept_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_activate_listen', EJECT ??
*copy nlh$sk_tcp_activate_listen

  PROCEDURE [XDCL] nlp$sk_tcp_activate_listen
    (    socket_id: nat$sk_socket_identifier;
         application: nat$application_name;
         port: nat$sk_port_number;
         bound_address: nat$sk_ip_address;
         queue_limit: nat$sk_listen_queue_limit;
         selection_criteria: nat$sk_socket_address;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      count: nlt$device_count,
      device_id: nlt$device_identifier,
      i: integer,
      ignore_layer_active: boolean,
      layer_active: boolean,
      listen_socket: ^nlt$tcp_listen_socket,
      tcp_connection: ^nlt$tcp_socket_layer,
      tcp_devices: ^nlt$tm_device_address_list;

    status.normal := TRUE;
    count := 0;
    PUSH tcp_devices: [1 .. nlv$configured_network_devices.network_device_count];
    IF bound_address <> nac$sk_all_ip_addresses THEN
      nlp$tm_select_by_local_tcp_addr (bound_address, tcp_devices^ [1].device_id, status);
      IF status.normal THEN
        tcp_devices^ [1].address := bound_address;
        count := 1;
      IFEND;
    ELSE

{ This procedure will return the list of TCP devices and the associated IP addresses.

      nlp$tm_get_local_tcp_devices (tcp_devices^, count);
      IF count = 0 THEN
        osp$set_status_abnormal (nac$status_id, nae$sk_no_device_configured, 'TCP', status);
      IFEND;
    IFEND;

    IF status.normal THEN

      REPEAT
        ALLOCATE listen_socket: [1 .. nlv$configured_network_devices.network_device_count] IN
              nav$network_paged_heap^;
        IF listen_socket = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL listen_socket <> NIL;

      listen_socket^.access_control.nonexclusive_accessors := 0;
      listen_socket^.access_control.exclusive := FALSE;
      listen_socket^.access_control.fill := 0;
      listen_socket^.identifier := socket_id;
      listen_socket^.application := application;
      listen_socket^.port := port;
      listen_socket^.bound_address := bound_address;
      listen_socket^.selection_criteria := selection_criteria;
      listen_socket^.queue_limit := queue_limit;
      listen_socket^.received_sockets := NIL;
      listen_socket^.wait_for_socket_list := NIL;

{ Initialize the device list.

      FOR i := 1 TO UPPERBOUND (listen_socket^.device_list) DO
        listen_socket^.device_list [i].device_id := 0;
        listen_socket^.device_list [i].ip_address := 0;
        listen_socket^.device_list [i].connection_id := nac$null_connection_id;
        listen_socket^.device_list [i].status := nlc$tcp_device_closed;
      FOREND;

{ Add the listen socket to the list.

      nlp$get_exclusive_access (nlv$tcp_listen_sockets.access_control);
      listen_socket^.next_entry := nlv$tcp_listen_sockets.list;
      nlv$tcp_listen_sockets.list := listen_socket;
      nlp$release_exclusive_access (nlv$tcp_listen_sockets.access_control);
      nlp$get_nonexclusive_access (nlv$tcp_listen_sockets.access_control);
      listen_socket := nlv$tcp_listen_sockets.list;

{ The listen socket can be terminated via application management while the lock
{ is being changed from exclusive to nonexclusive.

      WHILE (listen_socket <> NIL) AND ((listen_socket^.port <> port) OR
            (listen_socket^.bound_address <> bound_address)) DO
        listen_socket := listen_socket^.next_entry;
      WHILEND;

{ The listen socket should be there in the list.

      IF listen_socket <> NIL THEN
        nlp$get_exclusive_access (listen_socket^.access_control);
      /open_connections/
        FOR i := 1 TO count DO
          device_id := tcp_devices^ [i].device_id;
          listen_socket^.device_list [device_id].device_id := device_id;
          listen_socket^.device_list [device_id].ip_address := tcp_devices^ [i].address;
          nlp$cl_create_connection (nlc$tcp_interface, cl_connection);
          IF cl_connection <> NIL THEN
            nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, {ignore} layer_active,
                  tcp_connection);
            tcp_connection^.device_id := device_id;
            tcp_connection^.disconnect_reason := 0;
            tcp_connection^.user_initiated_close := FALSE;
            tcp_connection^.socket_id := socket_id;
            tcp_connection^.socket_type := nlc$tcp_listen_socket;
            tcp_connection^.inventory_report := 0;
            tcp_connection^.send_queue := NIL;
            tcp_connection^.receive_queue := NIL;
            tcp_connection^.received_data := NIL;
            tcp_connection^.available_sender_pool := NIL;
            tcp_connection^.available_receiver_pool := NIL;
            tcp_connection^.available_data_pool := NIL;
            tcp_connection^.source_socket.port := port;
            tcp_connection^.source_socket.ip_address := tcp_devices^ [i].address;
            tcp_connection^.destination_socket.port := 0;
            tcp_connection^.destination_socket.ip_address := 0;
            tcp_connection^.waiting_task_id.index := 0;
            nlp$tcp_listen_socket (cl_connection, port, queue_limit, selection_criteria, device_id,
                  nlc$cc_normal_class, status);
            IF status.normal THEN
              nlp$cl_activate_layer (nlc$tcp_interface, cl_connection);
              tcp_connection^.state := nlc$tcp_conn_await_confirm;
              listen_socket^.device_list [device_id].connection_id := cl_connection^.identifier;
              listen_socket^.device_list [device_id].status := nlc$tcp_device_await_confirm;
            ELSE { Resource constraint
              listen_socket^.device_list [device_id].status := nlc$tcp_device_res_constraint;
            IFEND;
            nlp$cl_release_exclusive_access (cl_connection);
          ELSE { cl_connection = NIL
            osp$set_status_condition (nae$sk_insufficient_resources, status);
            EXIT /open_connections/;
          IFEND;
        FOREND /open_connections/;
        nlp$release_exclusive_access (listen_socket^.access_control);
      ELSE { listen socket has been terminated
        osp$set_status_condition (nae$sk_socket_terminated, status);
      IFEND;
      nlp$release_nonexclusive_access (nlv$tcp_listen_sockets.access_control);
    IFEND;

{ **** NOTE - This procedure does not wait for the responses from the devices. (???)

  PROCEND nlp$sk_tcp_activate_listen;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_await_clear_to_send', EJECT ??
*copy nlh$sk_tcp_await_clear_to_send

  PROCEDURE [XDCL] nlp$sk_tcp_await_clear_to_send
    (    connection_id: nat$connection_id;
         wait: boolean;
     VAR activity_complete: boolean);

    VAR
      capacity: nat$data_length,
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      current_task_id: ost$global_task_id,
      ignore_status: ost$status,
      layer_active: boolean,
      previous_sender_task: ^^nlt$tcp_sender_task,
      sender_task: ^nlt$tcp_sender_task,
      tcp_connection: ^nlt$tcp_socket_layer;

    activity_complete := FALSE;
    pmp$get_executing_task_gtid (current_task_id);
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF cl_connection <> NIL THEN
      nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active, tcp_connection);
      IF layer_active THEN
        IF tcp_connection^.state = nlc$tcp_conn_open THEN
          IF tcp_connection^.send_queue = NIL THEN
            nlp$osi_get_outbound_capacity (cl_connection, capacity);
            IF capacity <= 0 THEN
              nlp$cc_receive_data (cl_connection);
              nlp$osi_get_outbound_capacity (cl_connection, capacity);
            IFEND;
            IF (capacity > 0) OR (tcp_connection^.state <> nlc$tcp_conn_open) THEN
              activity_complete := TRUE;
            ELSEIF wait THEN

{ Queue the task on the send queue.

              nlp$sk_tcp_get_send_task_entry (tcp_connection, sender_task);
              sender_task^.next_entry := NIL;
              sender_task^.task_id := current_task_id;
              sender_task^.send_type := nlc$tcp_await_clear_to_send;
              tcp_connection^.send_queue := sender_task;
              nlp$cl_activate_sender (cl_connection);
            IFEND;
          ELSE { tcp_connection^.send_queue <> NIL
            sender_task := tcp_connection^.send_queue;
            IF sender_task^.task_id = current_task_id THEN

{ Current task is at the head of the queue.

              nlp$osi_get_outbound_capacity (cl_connection, capacity);
              IF capacity <= 0 THEN
                nlp$cc_receive_data (cl_connection);

{ A release event may be received, which would result in the connection being closed.

                nlp$osi_get_outbound_capacity (cl_connection, capacity);
              IFEND;
              IF (capacity > 0) OR (tcp_connection^.state <> nlc$tcp_conn_open) THEN
                activity_complete := TRUE;
                IF tcp_connection^.state = nlc$tcp_conn_open THEN
                  tcp_connection^.send_queue := sender_task^.next_entry;
                  nlp$sk_tcp_ret_send_task_entry (tcp_connection, sender_task);
                  IF tcp_connection^.send_queue <> NIL THEN
                    pmp$ready_task (tcp_connection^.send_queue^.task_id, ignore_status);
                  IFEND;
                IFEND;
              ELSEIF NOT wait THEN

{ Dequeue the sender task.

                tcp_connection^.send_queue := sender_task^.next_entry;
                nlp$sk_tcp_ret_send_task_entry (tcp_connection, sender_task);
                nlp$cl_deactivate_sender (cl_connection);
                IF tcp_connection^.send_queue <> NIL THEN
                  pmp$ready_task (tcp_connection^.send_queue^.task_id, ignore_status);
                IFEND;
              ELSE { wait
                nlp$cl_activate_sender (cl_connection);
              IFEND;
            ELSE { current task not at the head of the queue

{ Queue the task at the end of the send queue if not already queued.

              previous_sender_task := ^tcp_connection^.send_queue;
              WHILE (previous_sender_task^ <> NIL) AND (previous_sender_task^^.task_id <> current_task_id) DO
                previous_sender_task := ^previous_sender_task^^.next_entry;
              WHILEND;
              IF wait THEN
                IF previous_sender_task^ = NIL THEN
                  nlp$sk_tcp_get_send_task_entry (tcp_connection, sender_task);
                  sender_task^.next_entry := NIL;
                  sender_task^.task_id := current_task_id;
                  sender_task^.send_type := nlc$tcp_await_clear_to_send;
                  previous_sender_task^ := sender_task;
                IFEND;
              ELSE { NOT wait
                IF previous_sender_task^ <> NIL THEN
                  sender_task := previous_sender_task^;
                  previous_sender_task^ := sender_task^.next_entry;
                  nlp$sk_tcp_ret_send_task_entry (tcp_connection, sender_task);
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        ELSE { tcp_connection^.state <> nlc$tcp_conn_open
          activity_complete := TRUE;
        IFEND;
      ELSE { Layer inactive
        activity_complete := TRUE;
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE { cl_connection = NIL
      activity_complete := TRUE;
    IFEND;

  PROCEND nlp$sk_tcp_await_clear_to_send;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_await_data_available', EJECT ??
*copy nlh$sk_tcp_await_data_available

  PROCEDURE [XDCL] nlp$sk_tcp_await_data_available
    (    connection_id: nat$connection_id;
         wait: boolean;
     VAR activity_complete: boolean);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      current_task_id: ost$global_task_id,
      ignore_status: ost$status,
      layer_active: boolean,
      previous_receiver_task: ^^nlt$tcp_receiver_task,
      receiver_active: boolean,
      receiver_task: ^nlt$tcp_receiver_task,
      tcp_connection: ^nlt$tcp_socket_layer;

    activity_complete := FALSE;
    pmp$get_executing_task_gtid (current_task_id);
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF cl_connection <> NIL THEN
      nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active, tcp_connection);
      IF layer_active THEN
        IF tcp_connection^.state = nlc$tcp_conn_open THEN
          IF tcp_connection^.receive_queue = NIL THEN
            IF tcp_connection^.received_data <> NIL THEN
              activity_complete := TRUE;
            ELSE
              nlp$cc_receive_data (cl_connection);
              activity_complete := (tcp_connection^.received_data <> NIL) OR (tcp_connection^.state <>
                    nlc$tcp_conn_open);
              IF (NOT activity_complete) AND wait THEN

{ Queue the task on the receive queue.

                nlp$sk_tcp_get_rec_task_entry (tcp_connection, receiver_task);
                receiver_task^.next_entry := NIL;
                receiver_task^.task_id := current_task_id;
                receiver_task^.receive_type := nlc$tcp_await_data_available;
                tcp_connection^.receive_queue := receiver_task;
                nlp$cl_activate_receiver (cl_connection);
                receiver_task^.receiver_active := TRUE;
              IFEND;
            IFEND;
          ELSE { tcp_connection^.receive_queue <> NIL
            receiver_task := tcp_connection^.receive_queue;
            IF receiver_task^.task_id = current_task_id THEN

{ Current task is at the head of the queue.

              activity_complete := tcp_connection^.received_data <> NIL;
              receiver_active := receiver_task^.receiver_active;
              IF NOT activity_complete THEN
                nlp$cc_receive_data (cl_connection);

{ A release event may be received, which would result in the connection being closed.

                activity_complete := (tcp_connection^.received_data <> NIL) OR (tcp_connection^.state <>
                      nlc$tcp_conn_open);
              IFEND;
              IF activity_complete OR NOT wait THEN
                IF receiver_active THEN
                  nlp$cl_deactivate_receiver (cl_connection);
                IFEND;
                IF tcp_connection^.state = nlc$tcp_conn_open THEN
                  tcp_connection^.receive_queue := receiver_task^.next_entry;
                  nlp$sk_tcp_ret_rec_task_entry (tcp_connection, receiver_task);
                  IF tcp_connection^.receive_queue <> NIL THEN
                    pmp$ready_task (tcp_connection^.receive_queue^.task_id, ignore_status);
                  IFEND;
                IFEND;
              ELSEIF NOT receiver_task^.receiver_active THEN
                nlp$cl_activate_receiver (cl_connection);
                receiver_task^.receiver_active := TRUE;
              IFEND;
            ELSE { current task is not at the head of the receive queue
              previous_receiver_task := ^tcp_connection^.receive_queue;
              WHILE (previous_receiver_task^ <> NIL) AND (previous_receiver_task^^.task_id <> current_task_id)
                    DO
                previous_receiver_task := ^previous_receiver_task^^.next_entry;
              WHILEND;
              IF (previous_receiver_task^ = NIL) AND wait THEN

{ Queue the task at the end of the receive queue.

                nlp$sk_tcp_get_rec_task_entry (tcp_connection, receiver_task);
                receiver_task^.next_entry := NIL;
                receiver_task^.task_id := current_task_id;
                receiver_task^.receive_type := nlc$tcp_await_data_available;
                receiver_task^.receiver_active := FALSE;
                previous_receiver_task^ := receiver_task;
              ELSEIF NOT wait THEN
                IF previous_receiver_task^ <> NIL THEN

{ Dequeue the task from the receive queue.

                  receiver_task := previous_receiver_task^;
                  previous_receiver_task^ := receiver_task^.next_entry;
                  nlp$sk_tcp_ret_rec_task_entry (tcp_connection, receiver_task);
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        ELSE { tcp_connection^.state <> nlc$tcp_conn_open
          activity_complete := TRUE;
        IFEND;
      ELSE { Layer inactive
        activity_complete := TRUE;
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE { cl_connection = NIL
      activity_complete := TRUE;
    IFEND;

  PROCEND nlp$sk_tcp_await_data_available;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_cancel_socket_offer', EJECT ??
*copy nlh$sk_tcp_cancel_socket_offer

  PROCEDURE [XDCL] nlp$sk_tcp_cancel_socket_offer
    (    connection_id: nat$connection_id;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      layer_active: boolean,
      tcp_connection: ^nlt$tcp_socket_layer;

    status.normal := TRUE;
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF cl_connection <> NIL THEN
      nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active, tcp_connection);
      IF layer_active THEN
        IF tcp_connection^.state = nlc$tcp_conn_offered THEN
          tcp_connection^.state := nlc$tcp_conn_open;
        ELSEIF tcp_connection^.state = nlc$tcp_conn_closed THEN
          IF tcp_connection^.disconnect_reason = nlc$tcpaa_ri_user_termination THEN
            osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
          ELSE
            osp$set_status_condition (nae$sk_socket_disconnected, status);
          IFEND;
          osp$append_status_integer (osc$status_parameter_delimiter, tcp_connection^.socket_id, 10, TRUE,
                status);
          IF tcp_connection^.state = nlc$tcp_conn_closed THEN
            nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
          IFEND;
        ELSEIF tcp_connection^.state = nlc$tcp_conn_terminated THEN
          nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
          osp$set_status_condition (nae$sk_socket_terminated, status);
        ELSE { closing state

{ Ignore the closing state.

        IFEND;
      ELSE { Layer inactive

{ The connection is assumed to be terminated via application management.

        osp$set_status_condition (nae$sk_socket_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE { cl_connection = NIL

{ The connection is assumed to be terminated via application management.

      osp$set_status_condition (nae$sk_socket_terminated, status);
    IFEND;

  PROCEND nlp$sk_tcp_cancel_socket_offer;
?? OLDTITLE ??
?? NEWTITLE := 'nlp$sk_tcp_check_accept_socket', EJECT ??
*copyc nlh$sk_tcp_check_accept_socket

  PROCEDURE [XDCL] nlp$sk_tcp_check_accept_socket
    (    application: nat$application_name;
         port: nat$sk_port_number;
         bound_address: nat$sk_ip_address;
         wait: boolean;
     VAR activity_complete: boolean);

    VAR
      current_task_id: ost$global_task_id,
      listen_socket: ^nlt$tcp_listen_socket,
      previous_wait_for_socket: ^^nlt$tcp_wait_for_socket,
      wait_for_socket: ^nlt$tcp_wait_for_socket;

    activity_complete := FALSE;
    pmp$get_executing_task_gtid (current_task_id);
    nlp$get_nonexclusive_access (nlv$tcp_listen_sockets.access_control);
    listen_socket := nlv$tcp_listen_sockets.list;
    WHILE (listen_socket <> NIL) AND ((listen_socket^.application <> application) OR
          (listen_socket^.port <> port) OR (listen_socket^.bound_address <> bound_address)) DO
      listen_socket := listen_socket^.next_entry;
    WHILEND;

    IF listen_socket <> NIL THEN
      nlp$get_exclusive_access (listen_socket^.access_control);
      IF listen_socket^.wait_for_socket_list = NIL THEN
        IF listen_socket^.received_sockets <> NIL THEN
          activity_complete := TRUE;
        ELSEIF wait THEN

{ Queue the task.

          REPEAT
            ALLOCATE wait_for_socket IN nav$network_paged_heap^;
            IF wait_for_socket = NIL THEN
              syp$cycle;
            IFEND;
          UNTIL wait_for_socket <> NIL;
          wait_for_socket^.next_entry := NIL;
          wait_for_socket^.task_id := current_task_id;
          listen_socket^.wait_for_socket_list := wait_for_socket;
        IFEND;
      ELSE { listen_socket^.wait_for_socket_list <> NIL

{ Check if the task is already queued.

        previous_wait_for_socket := ^listen_socket^.wait_for_socket_list;
        WHILE (previous_wait_for_socket^ <> NIL) AND (previous_wait_for_socket^^.task_id <> current_task_id)
              DO
          previous_wait_for_socket := ^previous_wait_for_socket^^.next_entry;
        WHILEND;
        IF previous_wait_for_socket^ = NIL THEN
          IF wait THEN

{ Queue the task.

            REPEAT
              ALLOCATE wait_for_socket IN nav$network_paged_heap^;
              IF wait_for_socket = NIL THEN
                syp$cycle;
              IFEND;
            UNTIL wait_for_socket <> NIL;
            wait_for_socket^.next_entry := NIL;
            wait_for_socket^.task_id := current_task_id;
            previous_wait_for_socket^ := wait_for_socket;
          IFEND;
        ELSEIF NOT wait THEN

{ Dequeue the task.

          wait_for_socket := previous_wait_for_socket^;
          previous_wait_for_socket^ := wait_for_socket^.next_entry;
          FREE wait_for_socket IN nav$network_paged_heap^;
        IFEND;
      IFEND;
      nlp$release_exclusive_access (listen_socket^.access_control);
    ELSE
      activity_complete := TRUE;
    IFEND;

    nlp$release_nonexclusive_access (nlv$tcp_listen_sockets.access_control);

  PROCEND nlp$sk_tcp_check_accept_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_close_socket', EJECT ??
*copy nlh$sk_tcp_close_socket

  PROCEDURE [XDCL] nlp$sk_tcp_close_socket
    (    connection_id: nat$connection_id;
         graceful_close: boolean);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      ignore_status: ost$status,
      layer_active: boolean,
      tcp_connection: ^nlt$tcp_socket_layer;

    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF cl_connection <> NIL THEN
      nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active, tcp_connection);
      IF layer_active THEN
        CASE tcp_connection^.state OF
        = nlc$tcp_conn_closed =
          IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
            nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
          IFEND;

        = nlc$tcp_conn_closing =
          IF (tcp_connection^.received_data <> NIL) AND (tcp_connection^.receive_queue = NIL) THEN
            discard_received_data (tcp_connection);
          IFEND;

          tcp_connection^.state := nlc$tcp_conn_closed;
          IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
            nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
          IFEND;

        = nlc$tcp_conn_open =
          terminate_io (cl_connection, tcp_connection);
          IF graceful_close THEN

{ Send a flush release request to the TCPAP.

            nlp$tcp_flush_release_socket (cl_connection, ignore_status);
          ELSE {non_graceful close
            nlp$tcp_release_socket (cl_connection, ignore_status);
          IFEND;

          IF tcp_connection^.receive_queue = NIL THEN
            discard_received_data (tcp_connection);
          IFEND;
          tcp_connection^.state := nlc$tcp_conn_closed;

          IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
            nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
          ELSE
            tcp_connection^.user_initiated_close := TRUE;
          IFEND;

        = nlc$tcp_conn_await_confirm =

{ Cannot happen as the job socket is kept locked while the connect is in progress.

          nap$namve_system_error ({Recoverable_error=} TRUE, unexpected_state, NIL);

        = nlc$tcp_conn_await_accept =

{ Cannot happen as the user cannot close a socket that has not been accepted.

          nap$namve_system_error ({Recoverable_error=} TRUE, unexpected_state, NIL);

        = nlc$tcp_conn_terminated =

{ Connection has been terminated via application management.

          IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
            nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
          IFEND;
        ELSE { Unexpected state
          nap$namve_system_error ({Recoverable_error=} TRUE, unexpected_state, NIL);
        CASEND;
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    IFEND;

  PROCEND nlp$sk_tcp_close_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_conn_event_processor', EJECT ??
*copy nlh$sk_tcp_conn_event_processor

  PROCEDURE [XDCL] nlp$sk_tcp_conn_event_processor
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$tcpaa_event;
     VAR inventory_report: integer);

    VAR
      ignore_layer_active: boolean,
      local_status: ost$status,
      tcp_connection: ^nlt$tcp_socket_layer;

    IF event.kind = nlc$tcpaa_connect_event THEN
      nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, ignore_layer_active, tcp_connection);
      assign_socket (event.connect.destination_socket, event.connect.source_socket, cl_connection^.identifier,
            local_status);
      IF local_status.normal THEN
        nlp$cl_activate_layer (nlc$tcp_interface, cl_connection);
        tcp_connection^.state := nlc$tcp_conn_await_accept;
        tcp_connection^.device_id := event.connect.device_id;
        tcp_connection^.socket_type := nlc$tcp_accept_socket;
        tcp_connection^.disconnect_reason := 0;
        tcp_connection^.user_initiated_close := FALSE;
        tcp_connection^.inventory_report := 0;
        tcp_connection^.send_queue := NIL;
        tcp_connection^.receive_queue := NIL;
        tcp_connection^.received_data := NIL;
        tcp_connection^.source_socket := event.connect.source_socket;
        tcp_connection^.destination_socket := event.connect.destination_socket;
        tcp_connection^.waiting_task_id.index := 0;

{ These pools will be initialized when the socket is accepted.

        tcp_connection^.available_receiver_pool := NIL;
        tcp_connection^.available_sender_pool := NIL;
        tcp_connection^.available_data_pool := NIL;
      ELSE { application inactive/unknown or max connections limit
        nlp$tcp_release_socket (cl_connection, {ignore} local_status);
      IFEND;
    ELSE { Invalid event
      nap$namve_system_error ({Recoverable_error=} TRUE, 'Invalid TCPAA event received.', NIL);
    IFEND;

  PROCEND nlp$sk_tcp_conn_event_processor;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_device_available', EJECT ??
*copy nlh$sk_tcp_device_available

  PROCEDURE [XDCL] nlp$sk_tcp_device_available
    (    device_id: nlt$device_identifier;
         ip_address: nat$sk_ip_address);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      ignore_layer_active: boolean,
      listen_socket: ^nlt$tcp_listen_socket,
      local_status: ost$status,
      tcp_connection: ^nlt$tcp_socket_layer;

{ Scan all listen sockets bound to the given device.

    nlp$get_nonexclusive_access (nlv$tcp_listen_sockets.access_control);
    listen_socket := nlv$tcp_listen_sockets.list;
    WHILE listen_socket <> NIL DO
      nlp$get_exclusive_access (listen_socket^.access_control);
      IF ((listen_socket^.bound_address = nac$sk_all_ip_addresses) OR
            (listen_socket^.bound_address = ip_address)) AND ((listen_socket^.device_list [device_id].status =
            nlc$tcp_device_closed) OR (listen_socket^.device_list [device_id].status =
            nlc$tcp_device_res_constraint)) THEN
        listen_socket^.device_list [device_id].device_id := device_id;
        listen_socket^.device_list [device_id].ip_address := ip_address;
        nlp$cl_create_connection (nlc$tcp_interface, cl_connection);
        IF cl_connection <> NIL THEN
          nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, ignore_layer_active, tcp_connection);
          tcp_connection^.device_id := device_id;
          tcp_connection^.disconnect_reason := 0;
          tcp_connection^.user_initiated_close := FALSE;
          tcp_connection^.socket_id := listen_socket^.identifier;
          tcp_connection^.socket_type := nlc$tcp_listen_socket;
          tcp_connection^.inventory_report := 0;
          tcp_connection^.send_queue := NIL;
          tcp_connection^.receive_queue := NIL;
          tcp_connection^.received_data := NIL;
          tcp_connection^.available_sender_pool := NIL;
          tcp_connection^.available_receiver_pool := NIL;
          tcp_connection^.available_data_pool := NIL;
          tcp_connection^.source_socket.port := listen_socket^.port;
          tcp_connection^.source_socket.ip_address := ip_address;
          tcp_connection^.destination_socket.port := 0;
          tcp_connection^.destination_socket.ip_address := 0;
          tcp_connection^.waiting_task_id.index := 0;
          nlp$tcp_listen_socket (cl_connection, listen_socket^.port, listen_socket^.queue_limit,
                listen_socket^.selection_criteria, device_id, nlc$cc_normal_class, local_status);
          IF local_status.normal THEN
            nlp$cl_activate_layer (nlc$tcp_interface, cl_connection);
            tcp_connection^.state := nlc$tcp_conn_await_confirm;
            listen_socket^.device_list [device_id].connection_id := cl_connection^.identifier;
            listen_socket^.device_list [device_id].status := nlc$tcp_device_await_confirm;
          ELSE { Resource constraint
            listen_socket^.device_list [device_id].status := nlc$tcp_device_res_constraint;
          IFEND;
          nlp$cl_release_exclusive_access (cl_connection);
        ELSE { cl_connection = NIL
          listen_socket^.device_list [device_id].status := nlc$tcp_device_res_constraint;
        IFEND;
      IFEND;

      nlp$release_exclusive_access (listen_socket^.access_control);
      listen_socket := listen_socket^.next_entry;
    WHILEND;
    nlp$release_nonexclusive_access (nlv$tcp_listen_sockets.access_control);

  PROCEND nlp$sk_tcp_device_available;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_event_processor', EJECT ??
*copy nlh$sk_tcp_event_processor

  PROCEDURE [XDCL] nlp$sk_tcp_event_processor
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$tcpaa_event;
     VAR inventory_report: integer);

    VAR
      buffers_freed: nat$data_length,
      current_task_id: ost$global_task_id,
      data: nlt$bm_message_id,
      data_length: integer,
      ignore_status: ost$status,
      layer_active: boolean,
      listen_socket: ^nlt$tcp_listen_socket,
      new_received_data: ^nlt$tcp_received_data,
      number_of_buffers_received: integer,
      partial_fragments: array [1 .. 2] of nlt$bm_message_id,
      previous_receiver_task: ^^nlt$tcp_receiver_task,
      previous_sender_task: ^^nlt$tcp_sender_task,
      received_data: ^nlt$tcp_received_data,
      receiver_task: ^nlt$tcp_receiver_task,
      sender_task: ^nlt$tcp_sender_task,
      tcp_connection: ^nlt$tcp_socket_layer;

    inventory_report := 0;
    pmp$get_executing_task_gtid (current_task_id);
    nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active, tcp_connection);
    IF layer_active THEN
      CASE event.kind OF
      = nlc$tcpaa_data_event =
        data := event.data.data;
        IF (tcp_connection^.state = nlc$tcp_conn_open) OR (tcp_connection^.state = nlc$tcp_conn_offered) THEN
          nlp$bm_get_message_resources (data, data_length, number_of_buffers_received);
          buffers_freed := 0;
          IF tcp_connection^.received_data <> NIL THEN

{ Find the last received data.

            received_data := tcp_connection^.received_data;
            WHILE received_data^.next_entry <> NIL DO
              received_data := received_data^.next_entry;
            WHILEND;

            IF (event.data.urgent_data) OR (event.data.urgent_data = received_data^.urgent_flag) THEN

{ Merge the incoming message with the queued data.
{ The receipt of urgent data will make all preceeding data urgent.

              partial_fragments [1] := received_data^.message_id;
              partial_fragments [2] := data;
              nlp$bm_concatenate_messages (partial_fragments, received_data^.message_id);
              received_data^.urgent_flag := event.data.urgent_data;
              received_data^.push_flag := event.data.push_data;
              received_data^.length := received_data^.length + data_length;
              received_data^.buffer_count := received_data^.buffer_count + number_of_buffers_received;
            ELSE { queue it as a separate fragment
              IF tcp_connection^.available_data_pool <> NIL THEN
                new_received_data := tcp_connection^.available_data_pool;
                tcp_connection^.available_data_pool := new_received_data^.next_entry;
              ELSE
                REPEAT
                  ALLOCATE new_received_data IN nav$network_paged_heap^;
                  IF new_received_data = NIL THEN
                    syp$cycle;
                  IFEND;
                UNTIL new_received_data <> NIL;
              IFEND;
              new_received_data^.next_entry := NIL;
              new_received_data^.message_id := data;
              new_received_data^.push_flag := event.data.push_data;
              new_received_data^.urgent_flag := event.data.urgent_data;
              new_received_data^.length := data_length;
              new_received_data^.buffer_count := number_of_buffers_received;
              received_data^.next_entry := new_received_data;
            IFEND;
          ELSE { tcp_connection^.received_data = NIL
            IF tcp_connection^.receive_queue <> NIL THEN
              IF tcp_connection^.receive_queue^.task_id = current_task_id THEN
                IF tcp_connection^.receive_queue^.receive_type = nlc$tcp_receive_data THEN
                  continue_to_receive (cl_connection, tcp_connection, data, data_length, event.data.push_data,
                        event.data.urgent_data, buffers_freed);
                IFEND;
              ELSE
                pmp$ready_task (tcp_connection^.receive_queue^.task_id, ignore_status);
              IFEND;
            IFEND;
            IF data_length > 0 THEN

{ Queue the remaining message.

              IF tcp_connection^.available_data_pool <> NIL THEN
                new_received_data := tcp_connection^.available_data_pool;
                tcp_connection^.available_data_pool := new_received_data^.next_entry;
              ELSE
                REPEAT
                  ALLOCATE new_received_data IN nav$network_paged_heap^;
                  IF new_received_data = NIL THEN
                    syp$cycle;
                  IFEND;
                UNTIL new_received_data <> NIL;
              IFEND;
              new_received_data^.next_entry := NIL;
              new_received_data^.message_id := data;
              new_received_data^.push_flag := event.data.push_data;
              new_received_data^.urgent_flag := event.data.urgent_data;
              new_received_data^.length := data_length;
              new_received_data^.buffer_count := number_of_buffers_received - buffers_freed;
              tcp_connection^.received_data := new_received_data;
            IFEND;
          IFEND;
          tcp_connection^.inventory_report := tcp_connection^.inventory_report + number_of_buffers_received -
                buffers_freed;
          inventory_report := tcp_connection^.inventory_report;
        ELSE { unexpected state
          nlp$bm_release_message (data);
          issue_disconnect (cl_connection, tcp_connection);
        IFEND;

      = nlc$tcpaa_release_event =
        IF (tcp_connection^.state <> nlc$tcp_conn_closed) AND
              (tcp_connection^.state <> nlc$tcp_conn_closing) AND
              (tcp_connection^.state <> nlc$tcp_conn_terminated) THEN
          tcp_connection^.disconnect_reason := event.release.reason;
          IF tcp_connection^.socket_type = nlc$tcp_listen_socket THEN
            nlp$get_nonexclusive_access (nlv$tcp_listen_sockets.access_control);
            listen_socket := nlv$tcp_listen_sockets.list;

{ Find the listen socket.

            WHILE (listen_socket <> NIL) AND ((listen_socket^.port <> tcp_connection^.source_socket.port) OR
                  ((listen_socket^.bound_address <> nac$sk_all_ip_addresses) AND
                  (listen_socket^.bound_address <> tcp_connection^.source_socket.ip_address))) DO
              listen_socket := listen_socket^.next_entry;
            WHILEND;
            IF listen_socket <> NIL THEN
              nlp$get_exclusive_access (listen_socket^.access_control);
              listen_socket^.device_list [tcp_connection^.device_id].status := nlc$tcp_device_closed;
              listen_socket^.device_list [tcp_connection^.device_id].connection_id := nac$null_connection_id;
              nlp$release_exclusive_access (listen_socket^.access_control);
            ELSE

{ Ignore it. The listen socket is being terminated.

            IFEND;
            nlp$release_nonexclusive_access (nlv$tcp_listen_sockets.access_control);
            tcp_connection^.state := nlc$tcp_conn_closed;
            nlp$cl_deactivate_layer (nlc$tcp_interface, cl_connection);
          ELSEIF (tcp_connection^.socket_type = nlc$tcp_accept_socket) AND
                (tcp_connection^.state = nlc$tcp_conn_await_accept) THEN
            disconnect_unaccepted_socket (cl_connection, tcp_connection, event.release.reason);
          ELSEIF (tcp_connection^.socket_type = nlc$tcp_connect_socket) AND
                (tcp_connection^.state = nlc$tcp_conn_await_confirm) THEN
            tcp_connection^.state := nlc$tcp_conn_closed;
            inventory_report := 0;
            pmp$ready_task (tcp_connection^.waiting_task_id, ignore_status);
          ELSE { Connect socket or accept socket that has been accepted

{ Ready all tasks waiting for the data available indication and signal all tasks waiting to receive data.

            terminate_io (cl_connection, tcp_connection);

{ Discard queued data only if there is no active receiver.

            IF (tcp_connection^.received_data = NIL) THEN
              inventory_report := 0;
            ELSE
              inventory_report := tcp_connection^.inventory_report;
            IFEND;
            tcp_connection^.state := nlc$tcp_conn_closing;
          IFEND;
        ELSE { tcp_connection^.state = closed , closing or terminated
          nap$namve_system_error ({Recoverable_error=} TRUE,
                'Received a TCPAA release event in closed state.', NIL);
        IFEND;

      = nlc$tcpaa_listen_confirm_event =
        IF (tcp_connection^.state = nlc$tcp_conn_await_confirm) AND
              (tcp_connection^.socket_type = nlc$tcp_listen_socket) THEN
          tcp_connection^.state := nlc$tcp_conn_open;
          nlp$get_nonexclusive_access (nlv$tcp_listen_sockets.access_control);
          listen_socket := nlv$tcp_listen_sockets.list;

{ Find the listen socket for the given listen port.

          WHILE (listen_socket <> NIL) AND ((listen_socket^.port <> tcp_connection^.source_socket.port) OR
                ((listen_socket^.bound_address <> nac$sk_all_ip_addresses) AND
                (listen_socket^.bound_address <> tcp_connection^.source_socket.ip_address))) DO
            listen_socket := listen_socket^.next_entry;
          WHILEND;
          IF listen_socket <> NIL THEN
            nlp$get_exclusive_access (listen_socket^.access_control);
            listen_socket^.device_list [tcp_connection^.device_id].status := nlc$tcp_device_open;
            nlp$release_exclusive_access (listen_socket^.access_control);
          ELSE

{ Ignore, the listen has been terminated.

          IFEND;
          nlp$release_nonexclusive_access (nlv$tcp_listen_sockets.access_control);
        ELSE { Unexpected state
          issue_disconnect (cl_connection, tcp_connection);
        IFEND;

      = nlc$tcpaa_connect_confirm_event =
        IF (tcp_connection^.state = nlc$tcp_conn_await_confirm) AND
              (tcp_connection^.socket_type = nlc$tcp_connect_socket) THEN
          tcp_connection^.state := nlc$tcp_conn_open;
          IF tcp_connection^.waiting_task_id.index > 0 THEN
            pmp$ready_task (tcp_connection^.waiting_task_id, ignore_status);
          IFEND;
        ELSE { Protocol error
          issue_disconnect (cl_connection, tcp_connection);
        IFEND;

      = nlc$tcpaa_clear_to_send_event =
        IF (tcp_connection^.send_queue <> NIL) AND (tcp_connection^.send_queue^.task_id <> current_task_id)
              THEN
          activate_next_sender (tcp_connection);
        IFEND;

      = nlc$tcpaa_listen_reject_event =
        IF (tcp_connection^.state = nlc$tcp_conn_await_confirm) AND
              (tcp_connection^.socket_type = nlc$tcp_listen_socket) THEN
          tcp_connection^.disconnect_reason := event.listen_reject.reason;
          nlp$get_nonexclusive_access (nlv$tcp_listen_sockets.access_control);
          listen_socket := nlv$tcp_listen_sockets.list;

{ Find the listen socket.

          WHILE (listen_socket <> NIL) AND ((listen_socket^.port <> tcp_connection^.source_socket.port) OR
                ((listen_socket^.bound_address <> nac$sk_all_ip_addresses) AND
                (listen_socket^.bound_address <> tcp_connection^.source_socket.ip_address))) DO
            listen_socket := listen_socket^.next_entry;
          WHILEND;
          IF listen_socket <> NIL THEN
            nlp$get_exclusive_access (listen_socket^.access_control);
            listen_socket^.device_list [tcp_connection^.device_id].status := nlc$tcp_device_closed;
            listen_socket^.device_list [tcp_connection^.device_id].connection_id := nac$null_connection_id;
            nlp$release_exclusive_access (listen_socket^.access_control);
          ELSE

{ Ignore it. The listen socket is being terminated.

          IFEND;
          nlp$release_nonexclusive_access (nlv$tcp_listen_sockets.access_control);
          tcp_connection^.state := nlc$tcp_conn_closed;
          nlp$cl_deactivate_layer (nlc$tcp_interface, cl_connection);
        ELSE { protocol error
          issue_disconnect (cl_connection, tcp_connection);
        IFEND;

      ELSE { Invalid event
        nap$namve_system_error ({Recoverable_error=} TRUE, 'Received an invalid TCPAA event', NIL);
      CASEND;
    ELSE { Layer inactive
      nap$namve_system_error ({Recoverable_error=} TRUE,
            'Received a TCPAA event and the TCP socket layer is inactive.', NIL);
      IF event.kind = nlc$tcpaa_data_event THEN
        data := event.data.data;
        nlp$bm_release_message (data);
      IFEND;
    IFEND;

  PROCEND nlp$sk_tcp_event_processor;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_get_listen_addresses', EJECT ??
*copy nlh$sk_tcp_get_listen_addresses

  PROCEDURE [XDCL] nlp$sk_tcp_get_listen_addresses
    (    application: nat$application_name;
         port: nat$sk_port_number;
         bound_address: nat$sk_ip_address;
     VAR listen_addresses: array [1 .. * ] of nat$sk_ip_address;
     VAR count: nlt$device_count;
     VAR status: ost$status);

    VAR
      device_id: integer,
      listen_socket: ^nlt$tcp_listen_socket;

    count := 0;
    status.normal := TRUE;
    nlp$get_nonexclusive_access (nlv$tcp_listen_sockets.access_control);

{ Find the listen socket corresponding to the given application name, port
{ number and IP address.

    listen_socket := nlv$tcp_listen_sockets.list;
    WHILE (listen_socket <> NIL) AND ((listen_socket^.application <> application) OR
          (listen_socket^.port <> port) OR (listen_socket^.bound_address <> bound_address)) DO
      listen_socket := listen_socket^.next_entry;
    WHILEND;
    IF listen_socket <> NIL THEN
      nlp$get_nonexclusive_access (listen_socket^.access_control);

    /get_addresses/
      FOR device_id := 1 TO UPPERBOUND (listen_socket^.device_list) DO
        IF (listen_socket^.device_list [device_id].status <> nlc$tcp_device_closed) AND
              (listen_socket^.device_list [device_id].status <> nlc$tcp_device_res_constraint) THEN
          count := count + 1;
          listen_addresses [count] := listen_socket^.device_list [device_id].ip_address;
          IF count = UPPERBOUND (listen_addresses) THEN
            EXIT /get_addresses/;
          IFEND;
        IFEND;
      FOREND /get_addresses/;
      nlp$release_nonexclusive_access (listen_socket^.access_control);
    ELSE { listen_socket = NIL

{ The listen socket is assumed to be terminated via application management.

      osp$set_status_condition (nae$sk_socket_terminated, status);
    IFEND;
    nlp$release_nonexclusive_access (nlv$tcp_listen_sockets.access_control);

  PROCEND nlp$sk_tcp_get_listen_addresses;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_get_socket_status', EJECT ??
*copy nlh$sk_tcp_get_socket_status

  PROCEDURE [XDCL] nlp$sk_tcp_get_socket_status
    (    connection_id: nat$connection_id;
     VAR clear_to_send: boolean;
     VAR data_pending_receive: integer;
     VAR status: ost$status);

    VAR
      capacity: nat$data_length,
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      layer_active: boolean,
      tcp_connection: ^nlt$tcp_socket_layer;

    status.normal := TRUE;
    clear_to_send := FALSE;
    data_pending_receive := 0;
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF cl_connection <> NIL THEN
      nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active, tcp_connection);
      IF layer_active THEN
        IF tcp_connection^.state = nlc$tcp_conn_open THEN
          IF (tcp_connection^.receive_queue = NIL) AND (tcp_connection^.received_data <> NIL) THEN
            data_pending_receive := tcp_connection^.received_data^.length;
          IFEND;
          IF tcp_connection^.send_queue = NIL THEN
            nlp$osi_get_outbound_capacity (cl_connection, capacity);
            clear_to_send := (capacity > 0);
          IFEND;
        ELSEIF tcp_connection^.state = nlc$tcp_conn_closing THEN
          IF (tcp_connection^.receive_queue = NIL) AND (tcp_connection^.received_data <> NIL) THEN
            data_pending_receive := tcp_connection^.received_data^.length;
          ELSE
            IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
              tcp_connection^.state := nlc$tcp_conn_closed;
              nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
            IFEND;
            IF tcp_connection^.disconnect_reason = nlc$tcpaa_ri_user_termination THEN
              osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
            ELSE
              osp$set_status_condition (nae$sk_socket_disconnected, status);
            IFEND;
          IFEND;
        ELSEIF tcp_connection^.state = nlc$tcp_conn_closed THEN
          IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
            nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
          IFEND;
          IF tcp_connection^.disconnect_reason = nlc$tcpaa_ri_user_termination THEN
            osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
          ELSE
            osp$set_status_condition (nae$sk_socket_disconnected, status);
          IFEND;
        ELSEIF tcp_connection^.state = nlc$tcp_conn_terminated THEN
          IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
            nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
          IFEND;
          osp$set_status_condition (nae$sk_socket_terminated, status);
        IFEND;
      ELSE { layer_active = FALSE

{ The connection is assumed to be terminated via application management.

        osp$set_status_condition (nae$sk_socket_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE { cl_connection = NIL

{ The connection is assumed to be terminated via application management.

      osp$set_status_condition (nae$sk_socket_terminated, status);
    IFEND;

  PROCEND nlp$sk_tcp_get_socket_status;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_initialize', EJECT ??
*copy nlh$sk_tcp_initialize

  PROCEDURE [XDCL] nlp$sk_tcp_initialize;

    VAR
      null_connect_event_processor: nlt$cl_event_processor,
      null_sap_event_processor: nlt$cl_event_processor;

    null_connect_event_processor.layer := nlc$tcp_interface;
    null_sap_event_processor.layer := nlc$tcp_interface;
    nlp$cl_initialize_template (nlc$tcp_interface, nlc$tcp_interface, #SIZE (nlt$tcp_socket_layer),
          {maximum_protocol_header_size =} 0, null_sap_event_processor, nac$nil, null_connect_event_processor,
          nac$nil);
    nlp$tcp_initialize (nlc$tcp_interface, nlc$sk_tcp_conn_event_processor, nlc$sk_tcp_event_processor);

  PROCEND nlp$sk_tcp_initialize;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_offer_socket', EJECT ??
*copy nlh$sk_tcp_offer_socket

  PROCEDURE [XDCL] nlp$sk_tcp_offer_socket
    (    connection_id: nat$connection_id;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      layer_active: boolean,
      tcp_connection: ^nlt$tcp_socket_layer;

    status.normal := TRUE;
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF cl_connection <> NIL THEN
      nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active, tcp_connection);
      IF layer_active THEN
        IF tcp_connection^.state = nlc$tcp_conn_open THEN
          IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
            tcp_connection^.state := nlc$tcp_conn_offered;
          ELSE { Io pending
            osp$set_status_condition (nae$sk_io_pending, status);
            osp$append_status_integer (osc$status_parameter_delimiter, tcp_connection^.socket_id, 10, TRUE,
                  status);
          IFEND;
        ELSEIF tcp_connection^.state = nlc$tcp_conn_closing THEN
          IF (tcp_connection^.receive_queue <> NIL) OR (tcp_connection^.send_queue <> NIL) THEN
            osp$set_status_condition (nae$sk_io_pending, status);
            osp$append_status_integer (osc$status_parameter_delimiter, tcp_connection^.socket_id, 10, TRUE,
                  status);
          ELSE

{ Leave the state unchanged but allow the offer socket request to complete.

          IFEND;
        ELSEIF tcp_connection^.state = nlc$tcp_conn_closed THEN
          IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
            nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
          IFEND;
          IF tcp_connection^.disconnect_reason = nlc$tcpaa_ri_user_termination THEN
            osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
          ELSE
            osp$set_status_condition (nae$sk_socket_disconnected, status);
          IFEND;
          osp$append_status_integer (osc$status_parameter_delimiter, tcp_connection^.socket_id, 10, TRUE,
                status);
        ELSEIF tcp_connection^.state = nlc$tcp_conn_terminated THEN
          IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
            nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
          IFEND;
          osp$set_status_condition (nae$sk_socket_terminated, status);
        IFEND;
      ELSE { Layer inactive

{ The connection is assumed to be terminated via application management.

        osp$set_status_condition (nae$sk_socket_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE { cl_connection = NIL

{ The connection is assumed to be terminated via application management.

      osp$set_status_condition (nae$sk_socket_terminated, status);
    IFEND;

  PROCEND nlp$sk_tcp_offer_socket;
?? OLDTITLE ??
?? NEWTITLE := 'nlp$sk_tcp_remove_accept_socket', EJECT ??
*copyc nlh$sk_tcp_remove_accept_socket

  PROCEDURE [XDCL] nlp$sk_tcp_remove_accept_socket
    (    application: nat$application_name;
         port: nat$sk_port_number;
         bound_address: nat$sk_ip_address);

    VAR
      current_task_id: ost$global_task_id,
      listen_socket: ^nlt$tcp_listen_socket,
      previous_wait_for_socket: ^^nlt$tcp_wait_for_socket,
      wait_for_socket: ^nlt$tcp_wait_for_socket;

    pmp$get_executing_task_gtid (current_task_id);
    nlp$get_nonexclusive_access (nlv$tcp_listen_sockets.access_control);
    listen_socket := nlv$tcp_listen_sockets.list;
    WHILE (listen_socket <> NIL) AND ((listen_socket^.application <> application) OR
          (listen_socket^.port <> port) OR (listen_socket^.bound_address <> bound_address)) DO
      listen_socket := listen_socket^.next_entry;
    WHILEND;

    IF listen_socket <> NIL THEN
      nlp$get_exclusive_access (listen_socket^.access_control);
      IF listen_socket^.wait_for_socket_list <> NIL THEN
        previous_wait_for_socket := ^listen_socket^.wait_for_socket_list;
        wait_for_socket := listen_socket^.wait_for_socket_list;
        WHILE (wait_for_socket <> NIL) AND (wait_for_socket^.task_id <> current_task_id) DO
          previous_wait_for_socket := ^wait_for_socket^.next_entry;
          wait_for_socket := wait_for_socket^.next_entry;
        WHILEND;
        IF wait_for_socket <> NIL THEN
          previous_wait_for_socket^ := wait_for_socket^.next_entry;
          FREE wait_for_socket IN nav$network_paged_heap^;
        IFEND;
      IFEND;
      nlp$release_exclusive_access (listen_socket^.access_control);
    IFEND;
    nlp$release_nonexclusive_access (nlv$tcp_listen_sockets.access_control);

  PROCEND nlp$sk_tcp_remove_accept_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_remove_clear_to_send', EJECT ??
*copyc nlh$sk_tcp_remove_clear_to_send

  PROCEDURE [XDCL] nlp$sk_tcp_remove_clear_to_send
    (    connection_id: nat$connection_id);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      current_task_id: ost$global_task_id,
      layer_active: boolean,
      previous_sender_task: ^^nlt$tcp_sender_task,
      sender_task: ^nlt$tcp_sender_task,
      tcp_connection: ^nlt$tcp_socket_layer;

    pmp$get_executing_task_gtid (current_task_id);
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF cl_connection <> NIL THEN
      nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active, tcp_connection);
      IF (layer_active) AND (tcp_connection^.state = nlc$tcp_conn_open) AND
            (tcp_connection^.send_queue <> NIL) THEN
        sender_task := tcp_connection^.send_queue;
        IF sender_task^.task_id = current_task_id THEN

{ Current task queued at the head of the receive queue.

          nlp$cl_deactivate_sender (cl_connection);
          tcp_connection^.send_queue := sender_task^.next_entry;
          nlp$sk_tcp_ret_send_task_entry (tcp_connection, sender_task);
        ELSE
          previous_sender_task := ^tcp_connection^.send_queue;
          WHILE (sender_task <> NIL) AND (sender_task^.task_id <> current_task_id) DO
            previous_sender_task := ^sender_task^.next_entry;
            sender_task := sender_task^.next_entry;
          WHILEND;
          IF sender_task <> NIL THEN
            previous_sender_task^ := sender_task^.next_entry;
            nlp$sk_tcp_ret_send_task_entry (tcp_connection, sender_task);
          IFEND;
        IFEND;
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    IFEND;

  PROCEND nlp$sk_tcp_remove_clear_to_send;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_remove_data_avail', EJECT ??
*copyc nlh$sk_tcp_remove_data_avail

  PROCEDURE [XDCL] nlp$sk_tcp_remove_data_avail
    (    connection_id: nat$connection_id);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      current_task_id: ost$global_task_id,
      ignore_status: ost$status,
      layer_active: boolean,
      previous_receiver_task: ^^nlt$tcp_receiver_task,
      receiver_task: ^nlt$tcp_receiver_task,
      tcp_connection: ^nlt$tcp_socket_layer;

    pmp$get_executing_task_gtid (current_task_id);
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF cl_connection <> NIL THEN
      nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active, tcp_connection);
      IF (layer_active) AND (tcp_connection^.state = nlc$tcp_conn_open) AND
            (tcp_connection^.receive_queue <> NIL) THEN
        previous_receiver_task := ^tcp_connection^.receive_queue;
        receiver_task := tcp_connection^.receive_queue;
        WHILE (receiver_task <> NIL) AND (receiver_task^.task_id <> current_task_id) DO
          previous_receiver_task := ^receiver_task^.next_entry;
          receiver_task := receiver_task^.next_entry;
        WHILEND;
        IF receiver_task <> NIL THEN
          previous_receiver_task^ := receiver_task^.next_entry;
          IF receiver_task^.receiver_active THEN
            nlp$cl_deactivate_receiver (cl_connection);
          IFEND;
          nlp$sk_tcp_ret_rec_task_entry (tcp_connection, receiver_task);
          IF tcp_connection^.receive_queue <> NIL THEN
            pmp$ready_task (tcp_connection^.receive_queue^.task_id, ignore_status);
          IFEND;
        IFEND;
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    IFEND;

  PROCEND nlp$sk_tcp_remove_data_avail;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_send_data', EJECT ??
*copy nlh$sk_tcp_send_data

  PROCEDURE [XDCL] nlp$sk_tcp_send_data
    (    cl_connection: ^nlt$cl_connection;
         initial_capacity: nat$data_length;
     VAR data: nat$data_fragments;
         data_length: nat$data_length;
         push_flag: boolean;
         urgent_flag: boolean;
         starting_fragment: nat$data_fragment_count;
     VAR remaining_fragment: nat$data_fragment_count;
     VAR remaining_data_length: integer);

    VAR
      capacity: nat$data_length,
      current_fragment: nat$data_fragment_count,
      fragment: ^nat$data_fragments,
      fragment_size: integer,
      ignore_status: ost$status;

    capacity := initial_capacity;
    IF capacity >= data_length THEN
      nlp$tcp_send_data_fragments (cl_connection, data, push_flag, urgent_flag, ignore_status);
      remaining_data_length := 0;
    ELSE { Insufficient outbound capacity
      PUSH fragment: [1 .. UPPERBOUND (data)];
      current_fragment := starting_fragment;
      remaining_data_length := data_length;
      REPEAT
        fragment_size := capacity;
        nlp$sk_fragment_data (fragment_size, current_fragment, data, remaining_fragment, fragment^);
        nlp$tcp_send_data_fragments (cl_connection, fragment^, push_flag, urgent_flag, ignore_status);
        remaining_data_length := remaining_data_length - fragment_size;
        IF remaining_data_length > 0 THEN
          nlp$osi_get_outbound_capacity (cl_connection, capacity);
          IF capacity > 0 THEN
            IF capacity > remaining_data_length THEN
              capacity := remaining_data_length;
            IFEND;
            current_fragment := remaining_fragment;
          IFEND;
        IFEND;
      UNTIL (capacity = 0) OR (remaining_data_length = 0);
    IFEND;

  PROCEND nlp$sk_tcp_send_data;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_set_socket_options', EJECT ??
*copy nlh$sk_tcp_set_socket_options

  PROCEDURE [XDCL] nlp$sk_tcp_set_socket_options
    (    connection_id: nat$connection_id;
         graceful_close: boolean;
         traffic_pattern: nat$sk_traffic_pattern;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      layer_active: boolean,
      tcp_connection: ^nlt$tcp_socket_layer;

    status.normal := TRUE;
    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF cl_connection <> NIL THEN
      nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active, tcp_connection);
      IF layer_active THEN
        IF tcp_connection^.state = nlc$tcp_conn_open THEN

{ Should it by pass all queued senders and receivers?

          nlp$tcp_set_socket_options (cl_connection, graceful_close, traffic_pattern, {ignore} status);
          status.normal := TRUE;
        ELSEIF tcp_connection^.state = nlc$tcp_conn_closing THEN

{ Do nothing.

        ELSEIF tcp_connection^.state = nlc$tcp_conn_closed THEN
          IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
            nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
          IFEND;
          IF tcp_connection^.disconnect_reason = nlc$tcpaa_ri_user_termination THEN
            osp$set_status_condition (nae$sk_socket_closed_via_peer, status);
          ELSE
            osp$set_status_condition (nae$sk_socket_disconnected, status);
          IFEND;
          osp$append_status_integer (osc$status_parameter_delimiter, tcp_connection^.socket_id, 10, TRUE,
                status);
        ELSEIF tcp_connection^.state = nlc$tcp_conn_terminated THEN
          IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
            nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
          IFEND;
          osp$set_status_condition (nae$sk_socket_terminated, status);
        IFEND;
      ELSE { layer_active = FALSE

{ The connection is assumed to be terminated via application management.

        osp$set_status_condition (nae$sk_socket_terminated, status);
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    ELSE { cl_connection = NIL

{ The connection is assumed to be terminated via application management.

      osp$set_status_condition (nae$sk_socket_terminated, status);
    IFEND;

  PROCEND nlp$sk_tcp_set_socket_options;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_terminate_all_listen', EJECT ??
*copy nlh$sk_tcp_terminate_all_listen

  PROCEDURE [XDCL] nlp$sk_tcp_terminate_all_listen
    (    application: nat$application_name);

    VAR
      listen_socket: ^nlt$tcp_listen_socket,
      previous_listen_socket: ^^nlt$tcp_listen_socket;


{ Find all listen sockets corresponding to the given application name.

  /terminate_listen/
    REPEAT
      nlp$get_exclusive_access (nlv$tcp_listen_sockets.access_control);
      listen_socket := nlv$tcp_listen_sockets.list;
      previous_listen_socket := ^nlv$tcp_listen_sockets.list;
      WHILE (listen_socket <> NIL) AND (listen_socket^.application <> application) DO
        previous_listen_socket := ^listen_socket^.next_entry;
        listen_socket := listen_socket^.next_entry;
      WHILEND;
      IF listen_socket <> NIL THEN
        previous_listen_socket^ := listen_socket^.next_entry;
        nlp$release_exclusive_access (nlv$tcp_listen_sockets.access_control);
        terminate_listen_socket (listen_socket);
        CYCLE /terminate_listen/;
      ELSE
        nlp$release_exclusive_access (nlv$tcp_listen_sockets.access_control);
      IFEND;
    UNTIL listen_socket = NIL;

  PROCEND nlp$sk_tcp_terminate_all_listen;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_terminate_listen', EJECT ??
*copy nlh$sk_tcp_terminate_listen

  PROCEDURE [XDCL] nlp$sk_tcp_terminate_listen
    (    application: nat$application_name;
         port: nat$sk_port_number;
         bound_address: nat$sk_ip_address);

    VAR
      listen_socket: ^nlt$tcp_listen_socket,
      previous_listen_socket: ^^nlt$tcp_listen_socket;

    nlp$get_exclusive_access (nlv$tcp_listen_sockets.access_control);

{ Find the listen socket corresponding to the given application name, port
{ number and IP address.

    listen_socket := nlv$tcp_listen_sockets.list;
    previous_listen_socket := ^nlv$tcp_listen_sockets.list;
    WHILE (listen_socket <> NIL) AND ((listen_socket^.application <> application) OR
          (listen_socket^.port <> port) OR (listen_socket^.bound_address <> bound_address)) DO
      previous_listen_socket := ^listen_socket^.next_entry;
      listen_socket := listen_socket^.next_entry;
    WHILEND;

{ If listen_socket = NIL, it is assumed that the listen socket must have been terminated
{ via application management.

    IF listen_socket <> NIL THEN

{ Delink the listen socket from the list.

      previous_listen_socket^ := listen_socket^.next_entry;
      nlp$release_exclusive_access (nlv$tcp_listen_sockets.access_control);
      terminate_listen_socket (listen_socket);
    ELSE
      nlp$release_exclusive_access (nlv$tcp_listen_sockets.access_control);
    IFEND;

  PROCEND nlp$sk_tcp_terminate_listen;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sk_tcp_terminate_socket', EJECT ??
*copy nlh$sk_tcp_terminate_socket

  PROCEDURE [XDCL] nlp$sk_tcp_terminate_socket
    (    connection_id: nat$connection_id);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      ignore_status: ost$status,
      layer_active: boolean,
      tcp_connection: ^nlt$tcp_socket_layer;

    nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
    IF cl_connection <> NIL THEN
      nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active, tcp_connection);
      IF layer_active THEN
        CASE tcp_connection^.state OF
        = nlc$tcp_conn_closed =
          IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
            nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
          IFEND;

        = nlc$tcp_conn_closing =
          IF (tcp_connection^.received_data <> NIL) AND (tcp_connection^.receive_queue = NIL) THEN
            discard_received_data (tcp_connection);
          IFEND;
          tcp_connection^.state := nlc$tcp_conn_terminated;
          IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
            nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
          IFEND;

        = nlc$tcp_conn_open =
          nlp$tcp_release_socket (cl_connection, ignore_status);
          terminate_io (cl_connection, tcp_connection);
          discard_received_data (tcp_connection);
          tcp_connection^.state := nlc$tcp_conn_terminated;
          IF (tcp_connection^.send_queue = NIL) AND (tcp_connection^.receive_queue = NIL) THEN
            nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
          IFEND;

        = nlc$tcp_conn_await_confirm =
          nlp$tcp_release_socket (cl_connection, ignore_status);
          pmp$ready_task (tcp_connection^.waiting_task_id, ignore_status);
          tcp_connection^.state := nlc$tcp_conn_terminated;
          nlp$cl_deactivate_layer (nlc$tcp_interface, cl_connection);

        = nlc$tcp_conn_await_accept =
          nlp$tcp_release_socket (cl_connection, ignore_status);
          tcp_connection^.state := nlc$tcp_conn_terminated;
          nlp$cl_deactivate_layer (nlc$tcp_interface, cl_connection);

        = nlc$tcp_conn_offered =
          nlp$tcp_release_socket (cl_connection, ignore_status);
          tcp_connection^.state := nlc$tcp_conn_terminated;
          nlp$sk_tcp_deactivate_layer (cl_connection, tcp_connection);
        ELSE { unexpected state
          nap$namve_system_error ({Recoverable_error=} TRUE, unexpected_state, NIL);
          tcp_connection^.state := nlc$tcp_conn_terminated;
        CASEND;
      IFEND;
      nlp$cl_release_exclusive_access (cl_connection);
    IFEND;

  PROCEND nlp$sk_tcp_terminate_socket;
?? OLDTITLE ??
?? NEWTITLE := 'activate_next_sender', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to scan the send queue and
{ ready the next task queued to send data. All intermediate tasks
{ that are awaitng a clear to send indication and are queued ahead
{ of the task waiting to send data are readied and dequeued.

  PROCEDURE activate_next_sender
    (VAR tcp_connection: ^nlt$tcp_socket_layer);

    VAR
      ignore_status: ost$status,
      previous_sender_task: ^^nlt$tcp_sender_task,
      sender_task: ^nlt$tcp_sender_task;

    sender_task := tcp_connection^.send_queue;
    previous_sender_task := ^tcp_connection^.send_queue;

  /activate_sender/
    WHILE sender_task <> NIL DO
      pmp$ready_task (sender_task^.task_id, ignore_status);
      IF sender_task^.send_type = nlc$tcp_await_clear_to_send THEN
        previous_sender_task^ := sender_task^.next_entry;
        nlp$sk_tcp_ret_send_task_entry (tcp_connection, sender_task);
        sender_task := previous_sender_task^;
      ELSE
        EXIT /activate_sender/;
      IFEND;
    WHILEND /activate_sender/;

  PROCEND activate_next_sender;
?? OLDTITLE ??
?? NEWTITLE := 'assign_socket', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to queue the incoming channel connection on the
{   listen socket for the given destination socket address.

  PROCEDURE assign_socket
    (    destination_socket: nat$sk_socket_address;
         source_socket: nat$sk_socket_address;
         connection_id: nat$connection_id;
     VAR status: ost$status);

    VAR
      listen_socket: ^nlt$tcp_listen_socket,
      previous_received_socket: ^^nlt$tcp_received_socket,
      received_socket: ^nlt$tcp_received_socket,
      wait_for_socket: ^nlt$tcp_wait_for_socket;

    status.normal := TRUE;
    nlp$get_nonexclusive_access (nlv$tcp_listen_sockets.access_control);

{ Find the listen socket corresponding to the given destination socket address.

    listen_socket := nlv$tcp_listen_sockets.list;

  /find_listen_socket/
    WHILE listen_socket <> NIL DO
      IF listen_socket^.port = destination_socket.port THEN
        IF (listen_socket^.bound_address = nac$sk_all_ip_addresses) OR
              (listen_socket^.bound_address = destination_socket.ip_address) THEN
          EXIT /find_listen_socket/;
        IFEND;
      IFEND;
      listen_socket := listen_socket^.next_entry;
    WHILEND /find_listen_socket/;

    IF listen_socket <> NIL THEN
      nlp$get_exclusive_access (listen_socket^.access_control);

{ Increment application management count of maximum sockets.

      nlp$tcpip_increment_appl_access (listen_socket^.application, {assigned} FALSE,
            nlc$udp_null_global_socket_id, connection_id, status);
      IF status.normal THEN
        REPEAT
          ALLOCATE received_socket IN nav$network_paged_heap^;
          IF received_socket = NIL THEN
            syp$cycle;
          IFEND;
        UNTIL received_socket <> NIL;
        received_socket^.next_entry := NIL;
        received_socket^.destination_socket := destination_socket;
        received_socket^.source_socket := source_socket;
        received_socket^.connected := TRUE;
        received_socket^.connection_id := connection_id;

{ Queue the received socket at the end of the received sockets queue.

        previous_received_socket := ^listen_socket^.received_sockets;
        WHILE previous_received_socket^ <> NIL DO
          previous_received_socket := ^previous_received_socket^^.next_entry;
        WHILEND;
        previous_received_socket^ := received_socket;

{ Ready a waiting task.  Dequeue the task from the wait for socket list
{ so another task will be readied if another connect request is received.

        IF listen_socket^.wait_for_socket_list <> NIL THEN
          wait_for_socket := listen_socket^.wait_for_socket_list;
          listen_socket^.wait_for_socket_list := wait_for_socket^.next_entry;
          pmp$ready_task (wait_for_socket^.task_id, {ignore} status);
          status.normal := TRUE;
          FREE wait_for_socket IN nav$network_paged_heap^;
        IFEND;
      IFEND;
      nlp$release_exclusive_access (listen_socket^.access_control);
    ELSE { listen_socket = NIL
      osp$set_status_condition (nae$sk_socket_terminated, status);
    IFEND;
    nlp$release_nonexclusive_access (nlv$tcp_listen_sockets.access_control);

  PROCEND assign_socket;
?? OLDTITLE ??
?? NEWTITLE := 'continue_to_receive', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deliver data to the task at the
{   head of the receive queue. If receive is complete, the receiver is
{   deactivated and the next receiver is readied.

  PROCEDURE continue_to_receive
    (    cl_connection: ^nlt$cl_connection;
     VAR tcp_connection: ^nlt$tcp_socket_layer;
     VAR data { input, output } : nlt$bm_message_id;
     VAR data_length { input, output } : integer;
         push_flag: boolean;
         urgent_flag: boolean;
     VAR buffers_freed: nat$data_length);

?? NEWTITLE := 'terminate_receive', EJECT ??

    PROCEDURE terminate_receive
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        IF receiver_task <> NIL THEN

{ Mark receive complete.

          receiver_task^.activity_status^.complete := TRUE;
          osp$set_status_from_condition (nac$status_id, condition, sa, receiver_task^.activity_status^.status,
                condition_status);

{ Dequeue the receiver task.

          tcp_connection^.receive_queue := receiver_task^.next_entry;
          nlp$cl_deactivate_receiver (cl_connection);
          IF tcp_connection^.receive_queue <> NIL THEN
            pmp$ready_task (tcp_connection^.receive_queue^.task_id, ignore_status);
          IFEND;
        IFEND;

        EXIT continue_to_receive;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'osc$job_recovery' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;

    PROCEND terminate_receive;
?? OLDTITLE ??
?? EJECT ??

    VAR
      delivered_data_length: integer,
      ignore_status: ost$status,
      receiver_task: ^nlt$tcp_receiver_task;

    buffers_freed := 0;
    osp$establish_condition_handler (^terminate_receive, FALSE);
    receiver_task := tcp_connection^.receive_queue;
    #SPOIL (receiver_task);

{ Deliver the data to the users buffer.

    nlp$bm_deliver_message (receiver_task^.data_buffer^, data, delivered_data_length, buffers_freed);
    receiver_task^.received_data_length^ := receiver_task^.received_data_length^ +delivered_data_length;
    receiver_task^.urgent_flag^ := urgent_flag;
    receiver_task^.remaining_buffer_capacity := receiver_task^.remaining_buffer_capacity -
          delivered_data_length;
    data_length := data_length - delivered_data_length;
    IF (receiver_task^.remaining_buffer_capacity = 0) OR (push_flag) OR (urgent_flag) THEN

{ Receive is complete, dequeue receiver task.

      tcp_connection^.receive_queue := receiver_task^.next_entry;
      receiver_task^.activity_status^.complete := TRUE;
      nlp$sk_tcp_ret_rec_task_entry (tcp_connection, receiver_task);
      nlp$cl_deactivate_receiver (cl_connection);

{ Ready the next task in the receive queue.

      IF tcp_connection^.receive_queue <> NIL THEN
        pmp$ready_task (tcp_connection^.receive_queue^.task_id, ignore_status);
      IFEND;
    IFEND;

  PROCEND continue_to_receive;
?? OLDTITLE ??
?? NEWTITLE := 'discard_received_data', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to discard all
{ received data queued on the TCP socket layer.

  PROCEDURE discard_received_data
    (VAR tcp_connection: ^nlt$tcp_socket_layer);

    VAR
      next_received_data: ^nlt$tcp_received_data,
      received_data: ^nlt$tcp_received_data;

    received_data := tcp_connection^.received_data;
    WHILE received_data <> NIL DO
      nlp$bm_release_message (received_data^.message_id);
      next_received_data := received_data^.next_entry;
      nlp$sk_tcp_ret_rec_data_entry (tcp_connection, received_data);
      received_data := next_received_data;
    WHILEND;
    tcp_connection^.received_data := NIL;
    tcp_connection^.inventory_report := 0;

  PROCEND discard_received_data;
?? OLDTITLE ??
?? NEWTITLE := 'disconnect_unaccepted_socket', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to find the accept socket queued on the corresponding
{   listen socket for the given channel connection and to mark i as disconnected. The accept
{   process will recognize the disconnected socket via the 'connected' state variable.

  PROCEDURE disconnect_unaccepted_socket
    (    cl_connection: ^nlt$cl_connection;
         tcp_connection: ^nlt$tcp_socket_layer;
         release_reason: nlt$tcpaa_release_ind_reason);

    VAR
      ignore_status: ost$status,
      listen_socket: ^nlt$tcp_listen_socket,
      received_socket: ^nlt$tcp_received_socket;

    nlp$get_nonexclusive_access (nlv$tcp_listen_sockets.access_control);

{ Find the listen socket corresponding to the given destination socket address.

    listen_socket := nlv$tcp_listen_sockets.list;

  /find_listen_socket/
    WHILE listen_socket <> NIL DO
      IF listen_socket^.port = tcp_connection^.destination_socket.port THEN
        IF (listen_socket^.bound_address = nac$sk_all_ip_addresses) OR
              (listen_socket^.bound_address = tcp_connection^.destination_socket.ip_address) THEN
          EXIT /find_listen_socket/;
        IFEND;
      IFEND;
      listen_socket := listen_socket^.next_entry;
    WHILEND /find_listen_socket/;

    IF listen_socket <> NIL THEN
      nlp$get_exclusive_access (listen_socket^.access_control);
      received_socket := listen_socket^.received_sockets;
      WHILE (received_socket <> NIL) AND (received_socket^.connection_id <> cl_connection^.identifier) DO
        received_socket := received_socket^.next_entry;
      WHILEND;
      IF received_socket <> NIL THEN
        received_socket^.connection_id := nac$null_connection_id;
        received_socket^.connected := FALSE;
        received_socket^.release_reason := release_reason;
        nlp$tcpip_decrement_appl_access (listen_socket^.application, nlc$udp_null_global_socket_id,
              cl_connection^.identifier, ignore_status);
      IFEND;
      nlp$release_exclusive_access (listen_socket^.access_control);
    IFEND;
    nlp$release_nonexclusive_access (nlv$tcp_listen_sockets.access_control);

    tcp_connection^.state := nlc$tcp_conn_closed;
    nlp$cl_deactivate_layer (nlc$tcp_interface, cl_connection);

  PROCEND disconnect_unaccepted_socket;
?? OLDTITLE ??
?? NEWTITLE := 'issue_disconnect', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to send a disconnect to the TCP access
{ provider.

  PROCEDURE issue_disconnect
    (    cl_connection: ^nlt$cl_connection;
     VAR tcp_connection: ^nlt$tcp_socket_layer);

    VAR
      ignore_status: ost$status;

    IF (tcp_connection^.state <> nlc$tcp_conn_closed) AND
          (tcp_connection^.state <> nlc$tcp_conn_terminated) AND
          (tcp_connection^.state <> nlc$tcp_conn_closing) THEN
      nlp$tcp_release_socket (cl_connection, ignore_status);
      terminate_io (cl_connection, tcp_connection);

      IF tcp_connection^.receive_queue = NIL THEN
        discard_received_data (tcp_connection);
      IFEND;
      tcp_connection^.state := nlc$tcp_conn_closed;
    IFEND;

  PROCEND issue_disconnect;
?? OLDTITLE ??
?? NEWTITLE := 'terminate_io', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to cause all senders and
{ receivers to terminate. All tasks awaiting data or the clear
{ to send indication are readied and dequeued. All tasks waiting
{ to send or receive data are readied so they can terminate.

  PROCEDURE terminate_io
    (    cl_connection: ^nlt$cl_connection;
     VAR tcp_connection: ^nlt$tcp_socket_layer);

    VAR
      ignore_status: ost$status,
      previous_receiver_task: ^^nlt$tcp_receiver_task,
      previous_sender_task: ^^nlt$tcp_sender_task,
      receiver_task: ^nlt$tcp_receiver_task,
      sender_task: ^nlt$tcp_sender_task;

    IF tcp_connection^.send_queue <> NIL THEN
      sender_task := tcp_connection^.send_queue;
      previous_sender_task := ^tcp_connection^.send_queue;
      WHILE sender_task <> NIL DO
        pmp$ready_task (sender_task^.task_id, ignore_status);
        IF sender_task^.send_type = nlc$tcp_await_clear_to_send THEN
          previous_sender_task^ := sender_task^.next_entry;
          FREE sender_task IN nav$network_paged_heap^;
          sender_task := previous_sender_task^;
        ELSE
          previous_sender_task := ^sender_task^.next_entry;
          sender_task := sender_task^.next_entry;
        IFEND;
      WHILEND;
    IFEND;
    IF tcp_connection^.receive_queue <> NIL THEN
      receiver_task := tcp_connection^.receive_queue;
      previous_receiver_task := ^tcp_connection^.receive_queue;
      WHILE receiver_task <> NIL DO
        pmp$ready_task (receiver_task^.task_id, ignore_status);
        IF receiver_task^.receive_type = nlc$tcp_await_data_available THEN
          previous_receiver_task^ := receiver_task^.next_entry;
          FREE receiver_task IN nav$network_paged_heap^;
          receiver_task := previous_receiver_task^;
        ELSE
          previous_receiver_task := ^receiver_task^.next_entry;
          receiver_task := receiver_task^.next_entry;
        IFEND;
      WHILEND;
    IFEND;

  PROCEND terminate_io;
?? OLDTITLE ??
?? NEWTITLE := 'terminate_listen', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to disconnect the
{ channel connections associated with the given listen socket.
{ The listen socket is freed.

  PROCEDURE terminate_listen_socket
    (VAR listen_socket: ^nlt$tcp_listen_socket);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      device_id: integer,
      layer_active: boolean,
      ignore_status: ost$status,
      next_received_socket: ^nlt$tcp_received_socket,
      next_wait_for_socket: ^nlt$tcp_wait_for_socket,
      received_socket: ^nlt$tcp_received_socket,
      tcp_connection: ^nlt$tcp_socket_layer,
      wait_for_socket: ^nlt$tcp_wait_for_socket;

{ Free all received socket and wait for socket list entries.
{ The connection associated with the received socket is terminated.

    received_socket := listen_socket^.received_sockets;
    WHILE received_socket <> NIL DO
      IF received_socket^.connected THEN
        nlp$sk_tcp_terminate_socket (received_socket^.connection_id);
        nlp$tcpip_decrement_appl_access (listen_socket^.application, nlc$udp_null_global_socket_id,
              received_socket^.connection_id, ignore_status);
      IFEND;
      next_received_socket := received_socket^.next_entry;
      FREE received_socket IN nav$network_paged_heap^;
      received_socket := next_received_socket;
    WHILEND;

{ Ready all tasks waiting for a socket and dequeue the entries.

    wait_for_socket := listen_socket^.wait_for_socket_list;
    WHILE wait_for_socket <> NIL DO
      pmp$ready_task (wait_for_socket^.task_id, ignore_status);
      next_wait_for_socket := wait_for_socket^.next_entry;
      FREE wait_for_socket IN nav$network_paged_heap^;
      wait_for_socket := next_wait_for_socket;
    WHILEND;

    FOR device_id := 1 TO UPPERBOUND (listen_socket^.device_list) DO
      IF (listen_socket^.device_list [device_id].status <> nlc$tcp_device_closed) AND
            (listen_socket^.device_list [device_id].status <> nlc$tcp_device_res_constraint) THEN
        nlp$cl_get_exclusive_via_cid (listen_socket^.device_list [device_id].connection_id, connection_exists,
              cl_connection);
        IF cl_connection <> NIL THEN
          nlp$cl_get_layer_connection (nlc$tcp_interface, cl_connection, layer_active, tcp_connection);
          IF layer_active THEN
            IF tcp_connection^.state <> nlc$tcp_conn_closed THEN
              nlp$tcp_release_socket (cl_connection, ignore_status);
              tcp_connection^.state := nlc$tcp_conn_closed;
            IFEND;
            nlp$cl_deactivate_layer (nlc$tcp_interface, cl_connection);
          IFEND;
          nlp$cl_release_exclusive_access (cl_connection);
        IFEND;
      IFEND;
    FOREND;

    FREE listen_socket IN nav$network_paged_heap^;

  PROCEND terminate_listen_socket;
?? OLDTITLE ??
MODEND nlm$sk_tcp_socket_layer;

*DECK DECK=NLM$SL_INTERNAL_INTERFACE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access : XNS Session Protocol Layer' ??
?? NEWTITLE := 'Global Declarations Referenced by This Module' ??
MODULE nlm$sl_internal_interface;
?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nat$application_name
*copyc nat$data_fragments
*copyc nat$generic_destination_address
*copyc nat$generic_sap_identifier
*copyc nat$network_address
*copyc nat$network_message_priority
*copyc nat$ta_alternate_protocol_class
*copyc nat$ta_preferred_protocol_class
*copyc nlt$sl_application_name_length
*copyc nlt$sl_clear_reason
*copyc nlt$sl_connection_descriptor
*copyc nlt$sl_discard_options
*copyc nlt$sl_event
*copyc nlt$sl_family_name_length
*copyc nlt$sl_interface
*copyc nlt$sl_machine_state
*copyc nlt$sl_max_active_connections
*copyc nlt$sl_pdu_header
*copyc nlt$sl_user_name_length
*copyc nlt$sl_validation_version
*copyc nlt$ta_event
*copyc oss$job_paged_literal
*copyc ost$wait
?? POP ??
*copyc clp$trimmed_string_size
*copyc jmp$get_job_attributes
*copyc nap$find_sap_priority
*copyc nap$namve_system_error
*copyc nlp$al_get_data_length
*copyc nlp$bm_add_message_prefix
*copyc nlp$bm_create_message
*copyc nlp$bm_extract_message_prefix
*copyc nlp$bm_flush_message
*copyc nlp$bm_get_message_length
*copyc nlp$bm_release_message
*copyc nlp$bm_valid_message_id
*copyc nlp$cancel_timer
*copyc nlp$cl_activate_layer
*copyc nlp$cl_activate_receiver
*copyc nlp$cl_deactivate_layer
*copyc nlp$cl_deactivate_receiver
*copyc nlp$cl_initialize_template
*copyc nlp$cl_get_connection_processor
*copyc nlp$cl_get_layer_connection
*copyc nlp$cl_get_sap_processor
*copyc nlp$osi_get_outbound_capacity
*copyc nlp$select_timer
*copyc nlp$ta_accept_connection
*copyc nlp$ta_close_sap
*copyc nlp$ta_disconnect_connection
*copyc nlp$ta_initialize
*copyc nlp$ta_open_sap
*copyc nlp$ta_request_connection
*copyc nlp$ta_send_aggregate_message
*copyc nlp$ta_send_data
*copyc nlp$ta_send_data_fragments
*copyc nlp$ta_send_expedited_data
*copyc nlp$timer_expired
*copyc osp$append_status_integer
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$log
*copyc nav$network_procedures
*copyc nlv$bm_nil_message_id
*copyc nlv$bm_null_message_id
?? OLDTITLE ??
?? NEWTITLE := 'Glocal Declarations Declared by This Module', EJECT ??

  VAR
    session_layer: [STATIC, READ, oss$job_paged_literal] string (13) := 'SESSION LAYER',
    nlv$sl_initialized_connection: [STATIC, READ, oss$job_paged_literal] nlt$sl_connection_descriptor :=
          [nlc$sl_closed, FALSE, FALSE, FALSE, FALSE, * , 0, * , * , TRUE, * , TRUE, nac$nil];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sl_sap_event_processor'??
?? NEWTITLE := '<call_wait> <--- <closed> [connect_indication]', EJECT ??

  PROCEDURE [XDCL] nlp$sl_sap_event_processor
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$ta_event;
     VAR accumulated_message_buffers: nlt$ta_inventory_report);

    VAR
      connection: ^nlt$sl_connection_descriptor,
      event_processor: nlt$cl_event_processor,
      layer_active: boolean,
      message_id: nlt$bm_message_id,
      message_length: integer,
      sap_priority: nat$network_message_priority,
      status: ost$status;

    IF event.kind = nlc$ta_connect_event THEN
      accumulated_message_buffers.changed := FALSE;
      nlp$cl_get_layer_connection (nlc$xns_session_layer, cl_connection, layer_active, connection);
      connection^ := nlv$sl_initialized_connection;
      nlp$bm_get_message_length (event.osi_connect.data, message_length);
      IF (message_length = 0) THEN
        connection^.source.kind := nac$osi_transport_address;
        connection^.source.osi_transport_address := event.osi_connect.source_address;
        connection^.sap.kind := nac$osi_sap_identifier;
        connection^.sap.identifier := event.osi_connect.destination_transport_sap;
        nap$find_sap_priority (connection^.sap, sap_priority);
        nlp$ta_accept_connection (cl_connection, {checksum =} FALSE, nlv$bm_null_message_id,
              {expedited_data =} TRUE, sap_priority, {quality_of_service = } NIL, status);
        IF status.normal THEN
          nlp$cl_activate_layer (nlc$xns_session_layer, cl_connection);
          nlp$cancel_timer (connection^.clear_timer);
          connection^.current_state := nlc$sl_call_wait;
          connection^.call_pdu_message_id := nlv$bm_nil_message_id;
          nlp$cl_get_connection_processor (cl_connection^.application_layer, nlc$xns_session_layer,
                event_processor);
          connection^.event_processor := event_processor.se;
          nlp$cl_activate_receiver (cl_connection);
        ELSE
          nap$namve_system_error (TRUE, 'Session accept connection failed.', ^status);
        IFEND;
      ELSE { IF message_length > 0 THEN
        nlp$ta_disconnect_connection (cl_connection, nlv$bm_null_message_id, status);
        message_id := event.osi_connect.data;
        nlp$bm_release_message (message_id);
      IFEND;
    ELSE { IF event.kind <> nlc$ta_connect_event THEN
      nap$namve_system_error (TRUE, 'Session fsm error:  Unexpected event received.', NIL);
    IFEND;
  PROCEND nlp$sl_sap_event_processor;

?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sl_connect_event_processor', EJECT ??

  PROCEDURE [XDCL] nlp$sl_connect_event_processor
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$ta_event;
     VAR accumulated_message_buffers: nlt$ta_inventory_report);

    VAR
      accounting_validation_length: packed record
        accounting: 0 .. 0ffff(16),
        validation: 0 .. 0ffff(16),
      recend,
      accounting_data: ^array [1 .. * ] of cell,
      bytes_moved: nat$data_length,
      call_message: ^array [1 .. * ] of cell,
      call_pdu_message: array [1 .. 1] of nat$data_fragment,
      connection: ^nlt$sl_connection_descriptor,
      end_of_message: boolean,
      event_processor: nlt$cl_event_processor,
      layer_active: boolean,
      message_id: nlt$bm_message_id,
      message_length: integer,
      pdu_header: nlt$sl_pdu_header,
      user_event: nlt$sl_event,
      validation_data: ^string ( * <= 512 {nlc$sl_max_validation_length} ),
      status: ost$status;

    accumulated_message_buffers.changed := FALSE;
    nlp$cl_get_layer_connection (nlc$xns_session_layer, cl_connection, layer_active, connection);

    CASE event.kind OF
?? NEWTITLE := 'data_indication', EJECT ??
?? NEWTITLE := 'pdu_header.pdu_type = nlc$sl_data_type'??

    = nlc$ta_data_event =

      message_id := event.osi_data.data;
      end_of_message := event.osi_data.end_of_message;
      IF connection^.transport_end_of_message THEN
        nlp$bm_extract_message_prefix (^pdu_header, #SIZE (pdu_header), message_id, bytes_moved);
        IF #SIZE(pdu_header) <> bytes_moved THEN
          process_error_indication (cl_connection, connection, accumulated_message_buffers);
          EXIT nlp$sl_connect_event_processor;
        IFEND;
      IFEND;

    /data_indication/
      BEGIN
        IF (NOT connection^.transport_end_of_message) OR (pdu_header.pdu_type = nlc$sl_data_type) THEN
          CASE connection^.current_state OF
          = nlc$sl_data_transfer, nlc$sl_synch_response_wait =
            user_event.kind := nlc$sl_data_event;
            user_event.data.message_id := message_id;
            IF NOT connection^.transport_end_of_message THEN
              user_event.data.qualified_data := connection^.qbit_receive_sequence;
              IF end_of_message THEN
                user_event.data.end_of_message := NOT connection^.receive_sequence_active;
                connection^.transport_end_of_message := TRUE;
              ELSE
                user_event.data.end_of_message := FALSE;
              IFEND;
              nav$network_procedures [connection^.event_processor].
                    sl_event_processor^ (cl_connection, user_event, accumulated_message_buffers);
            ELSEIF connection^.receive_sequence_active THEN
              IF pdu_header.qualified_data = connection^.qbit_receive_sequence THEN
                user_event.data.qualified_data := pdu_header.qualified_data;
                IF pdu_header.more_data THEN

{ 23

                  user_event.data.end_of_message := FALSE;
                  connection^.transport_end_of_message := end_of_message;
                  nav$network_procedures [connection^.event_processor].
                        sl_event_processor^ (cl_connection, user_event, accumulated_message_buffers);
                ELSE

{ 24

                  user_event.data.end_of_message := end_of_message;
                  connection^.transport_end_of_message := end_of_message;
                  connection^.receive_sequence_active := FALSE;
                  nav$network_procedures [connection^.event_processor].
                        sl_event_processor^ (cl_connection, user_event, accumulated_message_buffers);
                IFEND;
              ELSE

{ ERROR 61

                process_error_indication (cl_connection, connection, accumulated_message_buffers);
                nlp$bm_release_message (message_id);
              IFEND;
            ELSE
              user_event.data.qualified_data := pdu_header.qualified_data;
              IF pdu_header.more_data THEN

{ 22

                user_event.data.end_of_message := FALSE;
                connection^.transport_end_of_message := end_of_message;
                connection^.receive_sequence_active := TRUE;
                connection^.qbit_receive_sequence := pdu_header.qualified_data;
                nav$network_procedures [connection^.event_processor].
                      sl_event_processor^ (cl_connection, user_event, accumulated_message_buffers);
              ELSE

{ 21

                IF end_of_message THEN
                  user_event.data.end_of_message := TRUE;
                ELSE
                  user_event.data.end_of_message := FALSE;
                  connection^.transport_end_of_message := FALSE;
                  connection^.qbit_receive_sequence := pdu_header.qualified_data;
                IFEND;
                nav$network_procedures [connection^.event_processor].
                      sl_event_processor^ (cl_connection, user_event, accumulated_message_buffers);
              IFEND;
            IFEND;
          = nlc$sl_m_r_fr_wait, nlc$sl_fwd_mark_wait, nlc$sl_rev_mark_wait, nlc$sl_synch_collision_fr,
                nlc$sl_disconnect_wait =

{ 25

            nlp$bm_release_message (message_id);
            connection^.transport_end_of_message := end_of_message;
          ELSE

{ ERROR 55,57,59

            process_error_indication (cl_connection, connection, accumulated_message_buffers);
            nlp$bm_release_message (message_id);
          CASEND;
?? OLDTITLE ??
?? NEWTITLE := 'pdu_header.pdu_type = nlc$sl_mark_type', EJECT ??

        ELSE
          nlp$bm_get_message_length (message_id, message_length);
          IF pdu_header.pdu_type = nlc$sl_mark_type THEN
            IF message_length = 0 THEN
              IF connection^.mark_count > 1 THEN
                IF (connection^.current_state = nlc$sl_m_r_fr_wait) OR
                      (connection^.current_state = nlc$sl_fwd_mark_wait) OR
                      (connection^.current_state = nlc$sl_rev_mark_wait) OR
                      (connection^.current_state = nlc$sl_synch_collision_fr) THEN

{ 47

                  connection^.mark_count := connection^.mark_count - 1;
                ELSEIF connection^.current_state <> nlc$sl_disconnect_wait THEN

{ ERROR 55,57,59,61

                  process_error_indication (cl_connection, connection, accumulated_message_buffers);
                IFEND;
              ELSEIF connection^.mark_count = 1 THEN
                IF connection^.current_state = nlc$sl_m_r_fr_wait THEN

{ 48

                  connection^.current_state := nlc$sl_synch_response_wait;
                  connection^.mark_count := 0;
                ELSEIF connection^.current_state = nlc$sl_fwd_mark_wait THEN

{ 49

                  connection^.current_state := nlc$sl_data_transfer;
                  connection^.mark_count := 0;
                ELSEIF connection^.current_state <> nlc$sl_disconnect_wait THEN
                  IF connection^.current_state = nlc$sl_rev_mark_wait THEN

{ 50

                    user_event.kind := nlc$sl_synch_confirm_event;
                    connection^.current_state := nlc$sl_data_transfer;
                    connection^.mark_count := 0;
                    nav$network_procedures [connection^.event_processor].
                          sl_event_processor^ (cl_connection, user_event, accumulated_message_buffers);
                  ELSEIF connection^.current_state = nlc$sl_synch_collision_fr THEN

{ 51
{ make synch_confirm_event

                    user_event.kind := nlc$sl_synch_confirm_event;
                    connection^.mark_count := 0;
                    connection^.current_state := nlc$sl_synch_response_wait;
                    nav$network_procedures [connection^.event_processor].
                          sl_event_processor^ (cl_connection, user_event, accumulated_message_buffers);
                  ELSE

{ ERROR 55,57,59,61

                    process_error_indication (cl_connection, connection, accumulated_message_buffers);
                  IFEND;
                IFEND;
              ELSE { IF connection^.mark_count = 0 THEN

{ Ignore marks received after the connection has been terminated by a clear request.

                IF connection^.current_state <> nlc$sl_disconnect_wait THEN

{ FSM ERROR

                  nap$namve_system_error (TRUE, 'Session fsm error:  Unexpected mark received.', NIL);
                IFEND;
              IFEND;
            ELSE
              process_error_indication (cl_connection, connection, accumulated_message_buffers);
              nlp$bm_release_message (message_id);
            IFEND;
?? OLDTITLE ??
?? NEWTITLE := 'pdu_header.pdu_type = nlc$sl_clear_type', EJECT ??
          ELSEIF pdu_header.pdu_type = nlc$sl_clear_type THEN
            CASE connection^.current_state OF
            = nlc$sl_call_ok_wait, nlc$sl_call_response_wait, nlc$sl_data_transfer, nlc$sl_m_r_fr_wait,
                  nlc$sl_fwd_mark_wait, nlc$sl_synch_response_wait, nlc$sl_rev_mark_wait,
                  nlc$sl_synch_collision_fr =

{ 9
{ Make clear_event and send disconnect_request.

              user_event.kind := nlc$sl_clear_event;
              user_event.clear.reason := nlc$sl_user_clear;
              user_event.clear.message_id := message_id;
              connection^.current_state := nlc$sl_closed;
              nav$network_procedures [connection^.event_processor].
                    sl_event_processor^ (cl_connection, user_event, accumulated_message_buffers);
              nlp$ta_disconnect_connection (cl_connection, nlv$bm_null_message_id, status);
              nlp$cl_deactivate_layer (nlc$xns_session_layer, cl_connection);
              IF (connection^.current_state = nlc$sl_call_ok_wait) AND
                    (cl_connection^.message_receiver.active) THEN
                nlp$cl_deactivate_receiver (cl_connection);
              IFEND;
            = nlc$sl_disconnect_wait =

{ 15
{ Send disconnect_request.

              nlp$bm_release_message (message_id);
              connection^.current_state := nlc$sl_closed;
              nlp$ta_disconnect_connection (cl_connection, nlv$bm_null_message_id, status);
              nlp$cl_deactivate_layer (nlc$xns_session_layer, cl_connection);
            ELSE

{ ERROR 55

              process_error_indication (cl_connection, connection, accumulated_message_buffers);
              nlp$bm_release_message (message_id);
            CASEND;
?? OLDTITLE ??
?? NEWTITLE := 'pdu_header.pdu_type = nlc$sl_call_type', EJECT ??
          ELSEIF (pdu_header.pdu_type = nlc$sl_call_type) AND
                (connection^.current_state = nlc$sl_call_wait) THEN

{ 5

            IF cl_connection^.message_receiver.active THEN
              nlp$cl_deactivate_receiver (cl_connection);
            IFEND;
            IF pdu_header.version_no = nlc$sl_version_no THEN

{ Validate pdu_header.call.validation.

              IF message_length >= #SIZE (accounting_validation_length) THEN
                nlp$bm_extract_message_prefix (^accounting_validation_length,
                      #SIZE (accounting_validation_length), message_id, {ignore} bytes_moved);
                message_length := message_length - #SIZE (accounting_validation_length);
                IF message_length >= (accounting_validation_length.accounting +
                      accounting_validation_length.validation) THEN
                  IF accounting_validation_length.accounting > 0 THEN
                    PUSH accounting_data: [1 .. accounting_validation_length.accounting];
                    nlp$bm_extract_message_prefix (accounting_data, accounting_validation_length.accounting,
                          message_id, {ignore} bytes_moved);
                    message_length := message_length - accounting_validation_length.accounting;
                  IFEND;

                  IF accounting_validation_length.validation > 0 THEN
                    PUSH validation_data: [accounting_validation_length.validation];
                    nlp$bm_extract_message_prefix (validation_data, accounting_validation_length.validation,
                          message_id, {ignore} bytes_moved);
                    message_length := message_length - accounting_validation_length.validation;
                  IFEND;
                  IF message_length <= nlc$sl_max_call_message THEN
                    user_event.kind := nlc$sl_call_event;
                    user_event.call.source := connection^.source;
                    user_event.call.sap := connection^.sap;
                    user_event.call.message_id := message_id;
                    user_event.call.accounting_length := accounting_validation_length.accounting;
                    IF accounting_validation_length.accounting > 0 THEN
                      user_event.call.accounting_info := accounting_data;
                    ELSE
                      user_event.call.accounting_info := NIL;
                    IFEND;
                    connection^.current_state := nlc$sl_call_response_wait;

{ Deliver the event on the  SAP.

                    nlp$cl_get_sap_processor (cl_connection^.application_layer, nlc$xns_session_layer,
                          event_processor);
                    nav$network_procedures [event_processor.se].sl_event_processor^
                          (cl_connection, user_event, accumulated_message_buffers);
                  ELSE
                    process_error_indication (cl_connection, connection, accumulated_message_buffers);
                    nlp$bm_release_message (message_id);
                  IFEND;
                ELSE
                  process_error_indication (cl_connection, connection, accumulated_message_buffers);
                  nlp$bm_release_message (message_id);
                IFEND;
              ELSE
                process_error_indication (cl_connection, connection, accumulated_message_buffers);
                nlp$bm_release_message (message_id);
              IFEND;
            ELSE
              process_error_indication (cl_connection, connection, accumulated_message_buffers);
              nlp$bm_release_message (message_id);
            IFEND;
?? OLDTITLE ??
?? NEWTITLE := 'pdu_header.pdu_type = nlc$sl_call_ok_type', EJECT ??
          ELSEIF (pdu_header.pdu_type = nlc$sl_call_ok_type) AND
                (connection^.current_state = nlc$sl_call_ok_wait) THEN

{ 3

            IF cl_connection^.message_receiver.active THEN
              nlp$cl_deactivate_receiver (cl_connection);
            IFEND;
            IF pdu_header.version_no = nlc$sl_version_no THEN

{ Validate pdu_header.pdu_type of nlc$sl_call_ok_type.

              IF message_length >= #SIZE (accounting_validation_length) THEN
                nlp$bm_extract_message_prefix (^accounting_validation_length,
                      #SIZE (accounting_validation_length), message_id, {ignore} bytes_moved);
                message_length := message_length - #SIZE (accounting_validation_length);
                IF message_length >= (accounting_validation_length.accounting +
                      accounting_validation_length.validation) THEN
                  IF accounting_validation_length.accounting > 0 THEN
                    PUSH accounting_data: [1 .. accounting_validation_length.accounting];
                    nlp$bm_extract_message_prefix (accounting_data, accounting_validation_length.accounting,
                          message_id, {ignore} bytes_moved);
                    message_length := message_length - accounting_validation_length.accounting;
                  IFEND;

                  IF accounting_validation_length.validation > 0 THEN
                    PUSH validation_data: [accounting_validation_length.validation];
                    nlp$bm_extract_message_prefix (validation_data, accounting_validation_length.validation,
                          message_id, {ignore} bytes_moved);
                    message_length := message_length - accounting_validation_length.validation;
                  IFEND;

                  IF message_length <= nlc$sl_max_call_message THEN
                    connection^.current_state := nlc$sl_data_transfer;
                    user_event.kind := nlc$sl_confirm_event;
                    user_event.confirm.message_id := message_id;
                    IF accounting_validation_length.accounting > 0 THEN
                      user_event.confirm.accounting_info := accounting_data;
                    ELSE
                      user_event.confirm.accounting_info := NIL;
                    IFEND;
                    user_event.confirm.accounting_length := accounting_validation_length.accounting;
                    connection^.current_state := nlc$sl_data_transfer;
                    nav$network_procedures [connection^.event_processor].
                          sl_event_processor^ (cl_connection, user_event, accumulated_message_buffers);
                  ELSE
                    process_error_indication (cl_connection, connection, accumulated_message_buffers);
                    nlp$bm_release_message (message_id);
                  IFEND;
                ELSE
                  process_error_indication (cl_connection, connection, accumulated_message_buffers);
                  nlp$bm_release_message (message_id);
                IFEND;
              ELSE
                process_error_indication (cl_connection, connection, accumulated_message_buffers);
                nlp$bm_release_message (message_id);
              IFEND;
            ELSE
              process_error_indication (cl_connection, connection, accumulated_message_buffers);
              nlp$bm_release_message (message_id);
            IFEND;
          ELSEIF (pdu_header.pdu_type = nlc$sl_call_ok_type) AND
                (connection^.current_state = nlc$sl_disconnect_wait) THEN
            nlp$bm_release_message (message_id);
          ELSE
            process_error_indication (cl_connection, connection, accumulated_message_buffers);
            nlp$bm_release_message (message_id);
          IFEND;
        IFEND;
      END /data_indication/;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'clear_to_send_event', EJECT ??

    = nlc$ta_clear_to_send_event =
      CASE connection^.current_state OF
      = nlc$sl_data_transfer, nlc$sl_fwd_mark_wait, nlc$sl_rev_mark_wait =
        user_event.kind := nlc$sl_clear_to_send_event;
        nav$network_procedures [connection^.event_processor].
              sl_event_processor^ (cl_connection, user_event, accumulated_message_buffers);
      = nlc$sl_m_r_fr_wait, nlc$sl_synch_response_wait, nlc$sl_synch_collision_fr =
        ;

{ 21
{ Do nothing.

      ELSE

{ Is it possible for this event to occur.

      CASEND;
?? OLDTITLE ??
?? NEWTITLE := 'expedited_data_indication', EJECT ??

    = nlc$ta_expedited_data_event =

      message_id := event.osi_expedited_data.data;
      nlp$bm_extract_message_prefix (^pdu_header, #SIZE (pdu_header), message_id, bytes_moved);
      IF #SIZE(pdu_header) <> bytes_moved THEN
        process_error_indication (cl_connection, connection, accumulated_message_buffers);
        EXIT nlp$sl_connect_event_processor;
      IFEND;


    /expedited_data_indication/
      BEGIN
        nlp$bm_get_message_length (message_id, message_length);
        IF message_length > nlc$sl_max_interrupt_message THEN
          nlp$bm_release_message (message_id);
          process_error_indication (cl_connection, connection, accumulated_message_buffers);
          EXIT /expedited_data_indication/;
        ELSEIF message_length < nlc$sl_min_interrupt_message THEN
          nlp$bm_release_message (message_id);
          process_error_indication (cl_connection, connection, accumulated_message_buffers);
          EXIT /expedited_data_indication/;
        IFEND;
?? NEWTITLE := 'pdu_header.pdu_type = nlc$sl_interrupt_type', EJECT ??
        IF pdu_header.pdu_type = nlc$sl_interrupt_type THEN
          CASE connection^.current_state OF
          = nlc$sl_data_transfer, nlc$sl_m_r_fr_wait, nlc$sl_fwd_mark_wait, nlc$sl_synch_response_wait,
                nlc$sl_rev_mark_wait, nlc$sl_synch_collision_fr =

{ 28
{ Make interrupt_event.

            user_event.kind := nlc$sl_interrupt_event;
            user_event.interrupt.message_id := message_id;
            nav$network_procedures [connection^.event_processor].
                  sl_event_processor^ (cl_connection, user_event, accumulated_message_buffers);
          = nlc$sl_disconnect_wait =
            nlp$bm_release_message (message_id);
          ELSE

{ ERROR 56,58,60

            process_error_indication (cl_connection, connection, accumulated_message_buffers);
            nlp$bm_release_message (message_id);
          CASEND;
?? OLDTITLE ??
?? NEWTITLE := 'pdu_header.pdu_type = nlc$sl_synch_request_type'??
?? NEWTITLE := 'pdu_header.discard_option = nlc$sl_discard_send', EJECT ??
        ELSEIF pdu_header.pdu_type = nlc$sl_synch_request_type THEN
          IF pdu_header.discard_option = nlc$sl_discard_send THEN
            CASE connection^.current_state OF
            = nlc$sl_data_transfer, nlc$sl_m_r_fr_wait, nlc$sl_fwd_mark_wait, nlc$sl_rev_mark_wait,
                  nlc$sl_synch_collision_fr, nlc$sl_synch_response_wait =

{ 41,42,43

              IF connection^.current_state = nlc$sl_data_transfer THEN
                connection^.current_state := nlc$sl_fwd_mark_wait;
              ELSEIF connection^.current_state = nlc$sl_synch_response_wait THEN
                connection^.current_state := nlc$sl_m_r_fr_wait;
              IFEND;
              connection^.receive_sequence_active := FALSE;
              connection^.mark_count := connection^.mark_count + 1;

{ Make synch_indication_event.

              user_event.kind := nlc$sl_synch_event;
              user_event.synch.discard_option := nlc$sl_discard_send;
              user_event.synch.message_id := message_id;
              nav$network_procedures [connection^.event_processor].
                    sl_event_processor^ (cl_connection, user_event, accumulated_message_buffers);
            = nlc$sl_disconnect_wait =
              nlp$bm_release_message (message_id);
            ELSE

{ ERROR 56,58,60

              nlp$bm_release_message (message_id);
              process_error_indication (cl_connection, connection, accumulated_message_buffers);
            CASEND;
?? OLDTITLE ??
?? NEWTITLE := 'pdu_header.discard_option = nlc$sl_discard_send_receive', EJECT ??
          ELSEIF pdu_header.discard_option = nlc$sl_discard_send_receive THEN
            CASE connection^.current_state OF
            = nlc$sl_data_transfer, nlc$sl_fwd_mark_wait, nlc$sl_rev_mark_wait =

{ 38,39,40

              IF connection^.current_state = nlc$sl_rev_mark_wait THEN
                connection^.current_state := nlc$sl_synch_collision_fr;
              ELSE
                connection^.current_state := nlc$sl_m_r_fr_wait;
              IFEND;
              connection^.send_sequence_active := FALSE;
              connection^.receive_sequence_active := FALSE;
              connection^.mark_count := connection^.mark_count + 1;

{ Make synch_indication_event.

              user_event.kind := nlc$sl_synch_event;
              user_event.synch.discard_option := nlc$sl_discard_send_receive;
              user_event.synch.message_id := message_id;
              nav$network_procedures [connection^.event_processor].
                    sl_event_processor^ (cl_connection, user_event, accumulated_message_buffers);
            = nlc$sl_disconnect_wait =
              nlp$bm_release_message (message_id);
            ELSE

{ 56,58,60,64

              process_error_indication (cl_connection, connection, accumulated_message_buffers);
              nlp$bm_release_message (message_id);
            CASEND;
?? OLDTITLE ??
?? NEWTITLE := 'pdu_header.discard_option = nlc$sl_discard_receive', EJECT ??
          ELSEIF pdu_header.discard_option = nlc$sl_discard_receive THEN
            CASE connection^.current_state OF
            = nlc$sl_data_transfer, nlc$sl_fwd_mark_wait, nlc$sl_rev_mark_wait =
              IF connection^.current_state = nlc$sl_data_transfer THEN

{ 44

                connection^.current_state := nlc$sl_synch_response_wait;
              ELSEIF connection^.current_state = nlc$sl_fwd_mark_wait THEN

{ 45

                connection^.current_state := nlc$sl_m_r_fr_wait;
              ELSEIF connection^.current_state = nlc$sl_rev_mark_wait THEN

{ 46

                connection^.current_state := nlc$sl_synch_collision_fr;
              IFEND;
              connection^.send_sequence_active := FALSE;

{ Make synch_indication_event.

              user_event.kind := nlc$sl_synch_event;
              user_event.synch.discard_option := nlc$sl_discard_receive;
              user_event.synch.message_id := message_id;
              nav$network_procedures [connection^.event_processor].
                    sl_event_processor^ (cl_connection, user_event, accumulated_message_buffers);
            = nlc$sl_disconnect_wait =
              nlp$bm_release_message (message_id);
            ELSE

{ 56,58,60,64

              nlp$bm_release_message (message_id);
              process_error_indication (cl_connection, connection, accumulated_message_buffers);
            CASEND;
          ELSE { Invalid discard option received.

{ FSM ERROR

            nap$namve_system_error (TRUE, 'Session fsm error:  Invalid discard option received.', NIL);
            nlp$bm_release_message (message_id);
          IFEND;
        ELSE

{ 56,58,60,63,64,66

          nlp$bm_release_message (message_id);
          process_error_indication (cl_connection, connection, accumulated_message_buffers);
        IFEND;
      END /expedited_data_indication/;
?? OLDTITLE ??
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'accept_event_indication', EJECT ??

    = nlc$ta_connect_confirm_event =

      nlp$bm_get_message_length (event.osi_connect_confirm.data, message_length);
      IF message_length = 0 THEN
        IF connection^.current_state = nlc$sl_connect_confirm_wait THEN
          connection^.current_state := nlc$sl_call_ok_wait;
          nlp$ta_send_data (cl_connection, connection^.call_pdu_message_id, TRUE, status);
          IF status.normal THEN
            connection^.call_pdu_message_id := nlv$bm_nil_message_id;
          ELSE
            process_error_indication (cl_connection, connection, accumulated_message_buffers);
          IFEND;
        ELSE
          process_error_indication (cl_connection, connection, accumulated_message_buffers);
        IFEND;
      ELSE { IF message_length > 0 THEN
        message_id := event.osi_connect_confirm.data;
        nlp$bm_release_message (message_id);
      IFEND;
?? OLDTITLE ??
?? NEWTITLE := 'disconnect_indication', EJECT ??

    = nlc$ta_disconnect_event =

    /disconnect_indication/
      BEGIN
        IF ((connection^.current_state = nlc$sl_call_wait) OR
              (connection^.current_state = nlc$sl_connect_confirm_wait)) AND
              (cl_connection^.message_receiver.active) THEN

{ Deactivate the receiver in the connection establishment phase only.  During connection
{ establishment is the only time nlm$sl_internal_interface should have a receiver active.

          nlp$cl_deactivate_receiver (cl_connection);
        IFEND;

        message_id := event.osi_disconnect.data;
        nlp$bm_get_message_length (message_id, message_length);

        IF message_length = 0 THEN
?? NEWTITLE := 'current state of:'??
?? NEWTITLE := 'nlc$sl_call_wait or nlc$sl_disconnect_wait', EJECT ??
          CASE connection^.current_state OF
          = nlc$sl_call_wait, nlc$sl_disconnect_wait =

{ 8,14

            delete_connection (connection, cl_connection);
?? OLDTITLE ??
?? NEWTITLE := 'nlc$sl_call_ok_wait, nlc$sl_call_response_wait, nlc$sl_data_transfer,', EJECT ??
?? NEWTITLE := 'nlc$sl_m_r_fr_wait, nlc$sl_fwd_mark_wait, nlc$sl_synch_response_wait,'??
?? NEWTITLE := 'nlc$sl_rev_mark_wait, nlc$sl_synch_collision_fr, nlc$sl_connect_confirm_wait'??

          = nlc$sl_call_ok_wait, nlc$sl_call_response_wait, nlc$sl_data_transfer, nlc$sl_m_r_fr_wait,
                nlc$sl_fwd_mark_wait, nlc$sl_synch_response_wait, nlc$sl_rev_mark_wait,
                nlc$sl_synch_collision_fr, nlc$sl_connect_confirm_wait =

{ 7, 13

            user_event.kind := nlc$sl_clear_event;
            user_event.clear.reason := nlc$sl_layer_clear;
            user_event.clear.message_id := message_id;
            connection^.current_state := nlc$sl_closed;
            nav$network_procedures [connection^.event_processor].
                  sl_event_processor^ (cl_connection, user_event, accumulated_message_buffers);
            delete_connection (connection, cl_connection);

          = nlc$sl_closed =
            ;
          ELSE
            nap$namve_system_error (TRUE, 'Session fsm error:  Unexpected disconnect event received.', NIL);
          CASEND;
        ELSE
          nlp$bm_release_message (message_id);
        IFEND;
      END /disconnect_indication/;
?? OLDTITLE ??
?? OLDTITLE ??
?? OLDTITLE ??
?? OLDTITLE ??
?? EJECT ??
    ELSE
      nap$namve_system_error (TRUE, 'Invalid transport event received by Session. ', NIL);
    CASEND;
  PROCEND nlp$sl_connect_event_processor;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sl_initialize', EJECT ??

  PROCEDURE [XDCL] nlp$sl_initialize (sap_processor: nat$network_procedure;
        connection_processor: nat$network_procedure;
        application_layer: nlt$cl_application_layer);

*copy nlh$sl_initialize

    VAR
      cl_sap_processor: nlt$cl_event_processor,
      cl_connection_processor: nlt$cl_event_processor;

    cl_sap_processor.layer := nlc$xns_session_layer;
    cl_sap_processor.se := sap_processor;
    cl_connection_processor.layer := nlc$xns_session_layer;
    cl_connection_processor.se := connection_processor;
    nlp$cl_initialize_template (application_layer, nlc$xns_session_layer, #SIZE
          (nlt$sl_connection_descriptor), #size(nlt$sl_pdu_header), cl_sap_processor, nac$nil,
          cl_connection_processor, nlc$sl_clear_request_timer);
    nlp$ta_initialize (application_layer, nlc$osi_sl_sap_event_processor,
           nlc$osi_sl_conn_event_processor);
  PROCEND nlp$sl_initialize;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sl_open_sap', EJECT ??
*copy nlh$sl_open_sap

  PROCEDURE [XDCL] nlp$sl_open_sap
    (    sap_processor: nat$network_procedure;
         connection_processor: nat$network_procedure;
         osi_application_layer: nlt$cl_application_layer;
         accept_connect_events: boolean;
         maximum_active_connections: nlt$sl_max_active_connections;
     VAR status: ost$status);

    VAR
      cl_sap_processor: nlt$cl_event_processor,
      cl_connection_processor: nlt$cl_event_processor,
      local_status: ost$status;

    IF ((maximum_active_connections > 0) AND (maximum_active_connections <=
          UPPERVALUE (nlt$sl_max_active_connections))) THEN
      cl_sap_processor.layer := nlc$xns_session_layer;
      cl_sap_processor.se := sap_processor;
      cl_connection_processor.layer := nlc$xns_session_layer;
      cl_connection_processor.se := connection_processor;
      nlp$cl_initialize_template (osi_application_layer, nlc$xns_session_layer,
            #SIZE (nlt$sl_connection_descriptor), #SIZE (nlt$sl_pdu_header), cl_sap_processor, nac$nil,
            cl_connection_processor, nlc$sl_clear_request_timer);
      nlp$ta_open_sap (osi_application_layer, nlc$osi_sl_sap_event_processor, nlc$osi_sl_conn_event_processor,
            status);
    ELSEIF (maximum_active_connections = 0) THEN
      osp$set_status_condition ( nae$max_active_connections_0,  status);
    ELSE
      osp$set_status_condition ( nae$max_active_conn_exceeded,  status);
    IFEND;
  PROCEND nlp$sl_open_sap;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sl_close_sap', EJECT ??
*copy nlh$sl_close_sap

  PROCEDURE [XDCL] nlp$sl_close_sap
    (    sap: nat$generic_sap_identifier;
     VAR status: ost$status);

    VAR
      local_status: ost$status;

    nlp$ta_close_sap (sap.osi_sap_identifier, status);
  PROCEND nlp$sl_close_sap;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sl_call_request', EJECT ??
*copy nlh$sl_call_request

  PROCEDURE [XDCL] nlp$sl_call_request
    (    cl_connection: ^nlt$cl_connection;
         sap: nat$generic_sap_identifier;
         destination: nat$network_address;
         application_name: nat$application_name;
         data: nat$data_fragment;
         sap_priority: nat$network_message_priority;
     VAR status: ost$status);

    VAR
      accounting_length: nlc$sl_min_accounting_length .. nlc$sl_max_accounting_length,
      actual_destination_address: ^SEQ ( * ),
      application_name_ptr: ^STRING ( * ),
      application_name_length: nlt$sl_application_name_length,
      application_name_length_ptr: ^nlt$sl_application_name_length,
      connection: ^nlt$sl_connection_descriptor,
      data_fragments: array [1 .. 6] of nat$data_fragment,
      destination_address: ^SEQ ( * ),
      event_processor: nlt$cl_event_processor,
      family_name_ptr: ^STRING ( * ),
      family_name_length: nlt$sl_family_name_length,
      family_name_length_ptr: ^nlt$sl_family_name_length,
      i: integer,
      job_attribute_results: ^array [1 .. *] of jmt$job_attribute_result,
      layer_active: boolean,
      message_id: nlt$bm_message_id,
      pdu_header: nlt$sl_pdu_header,
      user_name_ptr: ^STRING ( * ),
      user_name_length: nlt$sl_user_name_length,
      user_name_length_ptr: ^nlt$sl_user_name_length,
      validation_data_length: nlc$sl_min_validation_length .. nlc$sl_max_validation_length,
      validation_data_ptr: ^SEQ ( * ),
      validation_version_ptr: ^nlt$sl_validation_version;

    IF (data.length <= nlc$sl_max_call_message) THEN
      PUSH job_attribute_results: [1 .. 2];
      job_attribute_results^[1].key := jmc$login_user;
      job_attribute_results^[2].key := jmc$login_family;

      jmp$get_job_attributes(job_attribute_results, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      user_name_length := clp$trimmed_string_size (job_attribute_results^[1].login_user);
      family_name_length := clp$trimmed_string_size (job_attribute_results^[2].login_family);
      application_name_length := clp$trimmed_string_size (application_name);

      validation_data_length := #SIZE (nlt$sl_validation_version) + #SIZE (nlt$sl_user_name_length) +
            #SIZE (nlt$sl_family_name_length) + #SIZE (nlt$sl_application_name_length) + user_name_length +
            family_name_length + application_name_length;

      PUSH validation_data_ptr: [[REP validation_data_length OF cell]];
      RESET validation_data_ptr;

{  Build the validation record

      NEXT validation_version_ptr IN validation_data_ptr;
      validation_version_ptr^ := nlc$sl_validation_version;
      NEXT user_name_length_ptr IN validation_data_ptr;
      user_name_length_ptr^ := user_name_length;
      NEXT family_name_length_ptr IN validation_data_ptr;
      family_name_length_ptr^ := family_name_length;
      NEXT application_name_length_ptr IN validation_data_ptr;
      application_name_length_ptr^ := application_name_length;
      NEXT user_name_ptr: [ user_name_length ] IN validation_data_ptr;
      user_name_ptr^ := job_attribute_results^[1].login_user;
      NEXT family_name_ptr: [ family_name_length ] IN validation_data_ptr;
      family_name_ptr^ := job_attribute_results^[2].login_family;
      NEXT application_name_ptr: [ application_name_length ] IN validation_data_ptr;
      application_name_ptr^ := application_name;

      pdu_header.version_no := nlc$sl_version_no;
      pdu_header.pdu_type := nlc$sl_call_type;
      accounting_length := 0;
      data_fragments [1].address := ^pdu_header;
      data_fragments [1].length := #SIZE (pdu_header);
      data_fragments [2].address := ^accounting_length;
      data_fragments [2].length := #SIZE (accounting_length);
      data_fragments [3].address := ^validation_data_length;
      data_fragments [3].length := #SIZE (validation_data_length);
      data_fragments [4].address := NIL; {^accounting_data;}
      data_fragments [4].length := accounting_length;
      data_fragments [5].address := validation_data_ptr;
      data_fragments [5].length := validation_data_length;
      data_fragments [6] := data;
      nlp$bm_create_message (data_fragments, message_id, status);
      IF status.normal THEN
        nlp$cl_get_layer_connection (nlc$xns_session_layer, cl_connection, layer_active, connection);
        connection^ := nlv$sl_initialized_connection;
        nlp$cancel_timer (connection^.clear_timer);
        connection^.current_state := nlc$sl_connect_confirm_wait;
        connection^.call_pdu_message_id := message_id;
        nlp$cl_get_connection_processor (cl_connection^.application_layer, nlc$xns_session_layer,
              event_processor);
        connection^.event_processor := event_processor.se;
        destination_address := ^destination.osi_transport_address.network_address;
        RESET destination_address;
        NEXT actual_destination_address: [[REP destination.osi_transport_address.network_address_length OF
              cell]] IN destination_address;

        nlp$ta_request_connection (cl_connection, sap.osi_sap_identifier, {checksum =} FALSE,
              nlv$bm_null_message_id, destination.osi_transport_address.
              transport_sap_selector (1, destination.osi_transport_address.transport_sap_selector_length),
              actual_destination_address^, {cdna_destination_address =} TRUE, {expedited_data =} TRUE,
              sap_priority, nac$ta_preferred_class_4_clns, nac$ta_no_alternate_protocol,
              {quality_of_service =} NIL, status);
        IF status.normal THEN
          nlp$cl_activate_layer (nlc$xns_session_layer, cl_connection);
          nlp$cl_activate_receiver (cl_connection);
        ELSE
          nlp$bm_release_message (connection^.call_pdu_message_id);
        IFEND;
      IFEND;
    ELSE
      osp$set_status_condition ( nae$max_data_length_exceeded,  status);
      osp$append_status_integer (osc$status_parameter_delimiter, nlc$sl_max_call_message, 10, TRUE, status);
    IFEND;
  PROCEND nlp$sl_call_request;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sl_call_response', EJECT ??
*copy nlh$sl_call_response

  PROCEDURE [XDCL] nlp$sl_call_response
    (    cl_connection: ^nlt$cl_connection;
         data: nat$data_fragments;
     VAR status: ost$status);

    VAR
      accounting_length: nlc$sl_min_accounting_length .. nlc$sl_max_accounting_length,
      connection: ^nlt$sl_connection_descriptor,
      data_fragments: ^array [1 .. * ] of nat$data_fragment,
      data_length: nat$data_length,
      i,
      j: integer,
      layer_active: boolean,
      message_id: nlt$bm_message_id,
      pdu_header: nlt$sl_pdu_header,
      validation_length: nlc$sl_min_validation_length .. nlc$sl_max_validation_length;

    nlp$al_get_data_length (data, data_length);
    IF (data_length <= nlc$sl_max_call_message) THEN
      pdu_header.version_no := nlc$sl_version_no;
      pdu_header.pdu_type := nlc$sl_call_ok_type;
      accounting_length := 0;
      validation_length := 0;
      PUSH data_fragments: [1 .. (5 + UPPERBOUND (data))];
      data_fragments^ [1].address := ^pdu_header;
      data_fragments^ [1].length := #SIZE (pdu_header);
      data_fragments^ [2].address := ^accounting_length;
      data_fragments^ [2].length := #SIZE (accounting_length);
      data_fragments^ [3].address := ^validation_length;
      data_fragments^ [3].length := #SIZE (validation_length);
      data_fragments^ [4].address := NIL; {^accounting_data;}
      data_fragments^ [4].length := accounting_length;
      data_fragments^ [5].address := NIL; {^validation_data;}
      data_fragments^ [5].length := validation_length;
      j := 1;
      FOR i := 6 TO UPPERBOUND (data_fragments^) DO
        data_fragments^ [i] := data [j];
        j := j + 1;
      FOREND;
      nlp$cl_get_layer_connection (nlc$xns_session_layer, cl_connection, layer_active, connection);
      IF (layer_active) AND (connection^.current_state = nlc$sl_call_response_wait) THEN
        nlp$ta_send_data_fragments (cl_connection, data_fragments^, TRUE, status);
        IF status.normal THEN
          connection^.current_state := nlc$sl_data_transfer;
        IFEND;
      ELSE
        osp$set_status_condition ( nae$connection_not_proposed,  status);
      IFEND;
    ELSE
      osp$set_status_condition ( nae$max_data_length_exceeded,  status);
      osp$append_status_integer (osc$status_parameter_delimiter, nlc$sl_max_call_message, 10, FALSE, status);
    IFEND;
  PROCEND nlp$sl_call_response;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sl_data_request', EJECT ??
*copy nlh$sl_data_request

  PROCEDURE [XDCL] nlp$sl_data_request
    (    cl_connection: ^nlt$cl_connection;
         qualified_data: boolean,
         end_of_message: boolean,
         data: nat$data_fragments;
     VAR status: ost$status);

    VAR
      connection: ^nlt$sl_connection_descriptor,
      layer_active: boolean,
      i: integer,
      message: ^array [1 .. * ] of nat$data_fragment,
      message_id: nlt$bm_message_id,
      pdu_header: nlt$sl_pdu_header;

    nlp$cl_get_layer_connection (nlc$xns_session_layer, cl_connection, layer_active, connection);
    IF layer_active THEN
?? NEWTITLE := 'current state of:'??
?? NEWTITLE := 'nlc$sl_data_transfer, nlc$sl_fwd_mark_wait, or nlc$sl_rev_mark_wait', EJECT ??
      CASE connection^.current_state OF
      = nlc$sl_data_transfer, nlc$sl_fwd_mark_wait, nlc$sl_rev_mark_wait =
        IF (connection^.send_sequence_active) AND (connection^.qbit_send_sequence <> qualified_data) THEN
          osp$set_status_condition ( nae$inconsistent_qualified_data,  status);
        ELSE
          PUSH message: [1 .. (UPPERBOUND (data) + 1)];
          pdu_header.qualified_data := qualified_data;
          pdu_header.more_data := NOT end_of_message;
          pdu_header.pdu_type := nlc$sl_data_type;
          message^ [1].address := ^pdu_header;
          message^ [1].length := #SIZE (pdu_header);
          FOR i := 2 TO UPPERBOUND (message^) DO
            message^ [i] := data [i - 1];
          FOREND;
          nlp$ta_send_data_fragments (cl_connection, message^, TRUE, status);
          IF status.normal THEN
            IF connection^.send_sequence_active THEN

{ 19, 20

              connection^.send_sequence_active := NOT end_of_message;
            ELSE
              IF NOT end_of_message THEN

{ 18

                connection^.send_sequence_active := TRUE;
                connection^.qbit_send_sequence := qualified_data;
              ELSE

{ 17

              IFEND;
            IFEND;
          IFEND;
        IFEND;
?? OLDTITLE ??
?? NEWTITLE := 'nlc$sl_m_r_fr_wait, nlc$sl_synch_response_wait, or nlc$sl_synch_collision_fr', EJECT ??

      = nlc$sl_m_r_fr_wait, nlc$sl_synch_response_wait, nlc$sl_synch_collision_fr =
        osp$set_status_condition ( nae$se_synchronize_in_progress,  status);
      ELSE
        osp$set_status_abnormal ('NA', nae$invalid_request, session_layer, status);
      CASEND;
    ELSE
      osp$set_status_condition ( nae$connection_not_open,  status);
    IFEND;
  PROCEND nlp$sl_data_request;
?? OLDTITLE ??
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sl_clear_request', EJECT ??
*copy nlh$sl_clear_request

  PROCEDURE [XDCL] nlp$sl_clear_request
    (    cl_connection: ^nlt$cl_connection;
         data: nat$data_fragments;
     VAR status: ost$status);

    VAR
      capacity: nat$data_length,
      connection: ^nlt$sl_connection_descriptor,
      data_length: nat$data_length,
      i: integer,
      layer_active: boolean,
      message: ^array [1 .. * ] of nat$data_fragment,
      message_id: nlt$bm_message_id,
      old_state: nlt$sl_machine_state,
      pdu_header: nlt$sl_pdu_header;

    nlp$al_get_data_length (data, data_length);
    IF data_length <= nlc$sl_max_clear_message THEN
      pdu_header.pdu_type := nlc$sl_clear_type;
      PUSH message: [1 .. (UPPERBOUND (data) + 1)];
      message^ [1].address := ^pdu_header;
      message^ [1].length := #SIZE (pdu_header);
      FOR i := 2 TO UPPERBOUND (message^) DO
        message^ [i] := data [i - 1];
      FOREND;
      nlp$cl_get_layer_connection (nlc$xns_session_layer, cl_connection, layer_active, connection);
      IF layer_active THEN
?? NEWTITLE := 'current state of:'??
?? NEWTITLE := 'nlc$sl_call_ok_wait, nlc$sl_call_response_wait, nlc$sl_data_transfer,'??
?? NEWTITLE := 'nlc$sl_m_r_fr_wait, nlc$sl_fwd_mark_wait, nlc$sl_synch_response_wait,'??
?? NEWTITLE := 'nlc$sl_rev_mark_wait, or nlc$sl_synch_collision_fr', EJECT ??
        CASE connection^.current_state OF
        = nlc$sl_call_ok_wait, nlc$sl_call_response_wait, nlc$sl_data_transfer, nlc$sl_m_r_fr_wait,
              nlc$sl_fwd_mark_wait, nlc$sl_synch_response_wait, nlc$sl_rev_mark_wait,
              nlc$sl_synch_collision_fr =
          nlp$osi_get_outbound_capacity (cl_connection, capacity);
          IF (capacity >= (data_length + #SIZE (pdu_header))) THEN
            old_state := connection^.current_state;
            connection^.current_state := nlc$sl_disconnect_wait;
            nlp$ta_send_data_fragments (cl_connection, message^, TRUE, status);
            IF NOT status.normal THEN
              connection^.current_state := old_state;
            ELSE

{ Start the timer task.

              nlp$select_timer (nlc$sl_max_clear_wait, 0, connection^.clear_timer);
              IF (connection^.current_state = nlc$sl_call_ok_wait) AND
                    (cl_connection^.message_receiver.active) THEN
                nlp$cl_deactivate_receiver (cl_connection);
              IFEND;
            IFEND;
          ELSE

{  No network capacity to send clear, so disconnect.

            nlp$ta_disconnect_connection (cl_connection, nlv$bm_null_message_id, status);
            delete_connection (connection, cl_connection);
          IFEND;
?? OLDTITLE ??
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'nlc$sl_connect_confirm_wait', EJECT ??

        = nlc$sl_connect_confirm_wait =
          IF cl_connection^.message_receiver.active THEN
            nlp$cl_deactivate_receiver (cl_connection);
          IFEND;
          nlp$ta_disconnect_connection (cl_connection, nlv$bm_null_message_id, status);
          delete_connection (connection, cl_connection);
?? OLDTITLE ??
?? NEWTITLE := 'nlc$sl_closed', EJECT ??

        = nlc$sl_closed =
          delete_connection (connection, cl_connection);
        ELSE
          osp$set_status_abnormal ('NA', nae$protocol_error, session_layer, status);
        CASEND;
      ELSE
        osp$set_status_condition ( nae$connection_not_open,  status);
      IFEND;
    ELSE
      osp$set_status_abnormal ('NA', nae$max_data_length_exceeded, session_layer, status);
      osp$append_status_integer (osc$status_parameter_delimiter, nlc$sl_max_clear_message, 10, FALSE, status);
    IFEND;
  PROCEND nlp$sl_clear_request;
?? OLDTITLE ??
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sl_synch_request', EJECT ??
*copy nlh$sl_synch_request

  PROCEDURE [XDCL] nlp$sl_synch_request
    (    cl_connection: ^nlt$cl_connection;
         discard_option: nlt$sl_discard_options,
         data: nlt$bm_message_id;
     VAR status: ost$status);

    VAR
      connection: ^nlt$sl_connection_descriptor,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      data_length: integer,
      layer_active: boolean,
      message_id: nlt$bm_message_id,
      pdu_header: nlt$sl_pdu_header,
      save_current_state: nlt$sl_machine_state,
      save_receive_sequence_active: boolean,
      save_send_sequence_active: boolean,
      synchronize: ^nlt$ta_aggregate_message;

    message_id := data;
    nlp$cl_get_layer_connection (nlc$xns_session_layer, cl_connection, layer_active, connection);
    IF layer_active THEN
?? NEWTITLE := 'pdu_header.discard_option = nlc$sl_discard_send', EJECT ??
      IF discard_option = nlc$sl_discard_send THEN
        CASE connection^.current_state OF
        = nlc$sl_data_transfer, nlc$sl_m_r_fr_wait, nlc$sl_fwd_mark_wait, nlc$sl_synch_response_wait,
              nlc$sl_rev_mark_wait, nlc$sl_synch_collision_fr =

{ 29

          save_send_sequence_active := connection^.send_sequence_active;
          connection^.send_sequence_active := FALSE;
        ELSE
          nlp$bm_release_message (message_id);
          osp$set_status_abnormal ('NA', nae$protocol_error, session_layer, status);
        CASEND;
?? OLDTITLE ??
?? NEWTITLE := 'pdu_header.discard_option = nlc$sl_discard_send_receive', EJECT ??

      ELSEIF discard_option = nlc$sl_discard_send_receive THEN
        IF (connection^.current_state = nlc$sl_data_transfer) OR
              (connection^.current_state = nlc$sl_fwd_mark_wait) THEN

{ 30,34

          save_current_state := connection^.current_state;
          save_send_sequence_active := connection^.send_sequence_active;
          save_receive_sequence_active := connection^.receive_sequence_active;
          connection^.current_state := nlc$sl_rev_mark_wait;
          connection^.send_sequence_active := FALSE;
          connection^.receive_sequence_active := FALSE;
          connection^.mark_count := connection^.mark_count + 1;
        ELSEIF (connection^.current_state = nlc$sl_m_r_fr_wait) OR
              (connection^.current_state = nlc$sl_synch_response_wait) THEN

{ 32,36

          save_current_state := connection^.current_state;
          save_send_sequence_active := connection^.send_sequence_active;
          save_receive_sequence_active := connection^.receive_sequence_active;
          connection^.current_state := nlc$sl_synch_collision_fr;
          connection^.send_sequence_active := FALSE;
          connection^.receive_sequence_active := FALSE;
          connection^.mark_count := connection^.mark_count + 1;
        ELSE
          nlp$bm_release_message (message_id);
          osp$set_status_condition ( nae$se_synch_confirm_pending,  status);
        IFEND;
?? OLDTITLE ??
?? NEWTITLE := 'pdu_header.discard_option = nlc$sl_discard_receive', EJECT ??

      ELSE {discard_option = nlc$sl_discard_receive THEN
        IF (connection^.current_state = nlc$sl_data_transfer) OR
              (connection^.current_state = nlc$sl_fwd_mark_wait) THEN

{ 31,35

          save_current_state := connection^.current_state;
          save_receive_sequence_active := connection^.receive_sequence_active;
          connection^.current_state := nlc$sl_rev_mark_wait;
          connection^.receive_sequence_active := FALSE;
          connection^.mark_count := connection^.mark_count + 1;
        ELSEIF (connection^.current_state = nlc$sl_m_r_fr_wait) OR
              (connection^.current_state = nlc$sl_synch_response_wait) THEN

{ 33,37

          save_current_state := connection^.current_state;
          save_receive_sequence_active := connection^.receive_sequence_active;
          connection^.current_state := nlc$sl_synch_collision_fr;
          connection^.receive_sequence_active := FALSE;
          connection^.mark_count := connection^.mark_count + 1;
        ELSE
          nlp$bm_release_message (message_id);
          osp$set_status_condition ( nae$se_synch_confirm_pending,  status);
        IFEND;
      IFEND;
?? OLDTITLE ??
?? EJECT ??

      IF status.normal THEN

{ Interrupt_request.

        nlp$bm_get_message_length (data, data_length);
        IF (data_length <= nlc$sl_max_interrupt_message) AND
              (data_length >= nlc$sl_min_interrupt_message) THEN
          pdu_header.discard_option := discard_option;
          pdu_header.pdu_type := nlc$sl_synch_request_type;
          nlp$bm_add_message_prefix (^pdu_header, #SIZE (pdu_header), message_id);
          IF discard_option = nlc$sl_discard_receive THEN
            nlp$ta_send_expedited_data (cl_connection, message_id, status);
            IF NOT status.normal AND ((status.condition = nae$max_expedited_exceeded) OR
                  (status.condition = nae$connection_full)) THEN
              osp$set_status_abnormal (nac$status_id, nae$supervisory_traffic_limit, 'SYNCH REQUEST', status);
            IFEND;

{ ELSEIF (discard_option = nlc$sl_discard_send) OR
{    (discard_option = nlc$sl_discard_send_receive) THEN

          ELSE
            pdu_header.pdu_type := nlc$sl_mark_type;
            data_fragments [1].address := ^pdu_header;
            data_fragments [1].length := #SIZE (pdu_header);
            PUSH synchronize: [1 .. 2];
            synchronize^ [1].kind := nlc$ta_expedited_data_event;
            synchronize^ [1].expedited_data := message_id;
            synchronize^ [2].kind := nlc$ta_data_event;
            synchronize^ [2].end_of_message := TRUE;
            nlp$bm_create_message (data_fragments, synchronize^ [2].data, status);
            nlp$ta_send_aggregate_message (cl_connection, synchronize^, status);
            IF NOT status.normal AND ((status.condition = nae$max_expedited_exceeded) OR
                  (status.condition = nae$connection_full) OR (status.condition =
                  nae$ta_expedited_request_limit)) THEN
              osp$set_status_abnormal (nac$status_id, nae$supervisory_traffic_limit, 'SYNCH REQUEST', status);
            IFEND;
          IFEND;
        ELSE
          nlp$bm_release_message (message_id);
          osp$set_status_condition ( nae$se_synchronize_length_error,  status);
          osp$append_status_integer (osc$status_parameter_delimiter, nlc$sl_max_interrupt_message, 10, FALSE,
                status);
          osp$append_status_integer (osc$status_parameter_delimiter, nlc$sl_min_interrupt_message, 10, FALSE,
                status);
        IFEND;
        IF NOT status.normal THEN
          IF discard_option = nlc$sl_discard_send THEN
            connection^.send_sequence_active := save_send_sequence_active;
          ELSE
            connection^.mark_count := connection^.mark_count - 1;
            connection^.current_state := save_current_state;
            connection^.send_sequence_active := save_send_sequence_active;
            IF discard_option = nlc$sl_discard_send_receive THEN
              connection^.receive_sequence_active := save_receive_sequence_active;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    ELSE
      nlp$bm_release_message (message_id);
      osp$set_status_condition ( nae$connection_not_open,  status);
    IFEND;
  PROCEND nlp$sl_synch_request;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sl_synch_response', EJECT ??
*copy nlh$sl_synch_response

  PROCEDURE [XDCL] nlp$sl_synch_response
    (    cl_connection: ^nlt$cl_connection;
     VAR status: ost$status);

    VAR
      connection: ^nlt$sl_connection_descriptor,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      layer_active: boolean,
      old_state: nlt$sl_machine_state,
      pdu_header: nlt$sl_pdu_header,
      synchronize_response: array [1 .. 1] of nlt$ta_aggregate;

    nlp$cl_get_layer_connection (nlc$xns_session_layer, cl_connection, layer_active, connection);
    IF layer_active THEN
      status.normal := TRUE;
      IF connection^.current_state = nlc$sl_m_r_fr_wait THEN
        old_state := connection^.current_state;
        connection^.current_state := nlc$sl_fwd_mark_wait;
      ELSEIF connection^.current_state = nlc$sl_synch_response_wait THEN
        old_state := connection^.current_state;
        connection^.current_state := nlc$sl_data_transfer;
      ELSEIF connection^.current_state = nlc$sl_synch_collision_fr THEN
        old_state := connection^.current_state;
        connection^.current_state := nlc$sl_rev_mark_wait;
      ELSE
        osp$set_status_condition ( nae$se_no_synch_in_progress,  status);
      IFEND;
      IF status.normal THEN
        pdu_header.pdu_type := nlc$sl_mark_type;
        data_fragments [1].address := ^pdu_header;
        data_fragments [1].length := #SIZE (pdu_header);
        synchronize_response [1].kind := nlc$ta_data_event;
        synchronize_response [1].end_of_message := TRUE;
        nlp$bm_create_message (data_fragments, synchronize_response [1].data, status);
        nlp$ta_send_aggregate_message (cl_connection, synchronize_response, status);
        IF NOT status.normal THEN
          connection^.current_state := old_state;
          IF status.condition = nae$connection_full THEN
            osp$set_status_abnormal (nac$status_id, nae$supervisory_traffic_limit, 'SYNCH RESPONSE', status);
          IFEND;
        IFEND;
      IFEND;
    ELSE
      osp$set_status_condition ( nae$connection_not_open,  status);
    IFEND;
  PROCEND nlp$sl_synch_response;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sl_interrupt_request', EJECT ??
*copy nlh$sl_interrupt_request

  PROCEDURE [XDCL] nlp$sl_interrupt_request
    (    cl_connection: ^nlt$cl_connection;
         data: nlt$bm_message_id;
     VAR status: ost$status);

    VAR
      connection: ^nlt$sl_connection_descriptor,
      data_length: integer,
      layer_active: boolean,
      message_id: nlt$bm_message_id,
      pdu_header: nlt$sl_pdu_header;

    status.normal := TRUE;
    message_id := data;
    nlp$cl_get_layer_connection (nlc$xns_session_layer, cl_connection, layer_active, connection);
    IF layer_active THEN
      CASE connection^.current_state OF
      = nlc$sl_data_transfer, nlc$sl_fwd_mark_wait, nlc$sl_rev_mark_wait, nlc$sl_m_r_fr_wait,
            nlc$sl_synch_response_wait, nlc$sl_synch_collision_fr =
        nlp$bm_get_message_length (data, data_length);
        IF (data_length <= nlc$sl_max_interrupt_message) AND
              (data_length >= nlc$sl_min_interrupt_message) THEN
          pdu_header.pdu_type := nlc$sl_interrupt_type;
          nlp$bm_add_message_prefix (^pdu_header, #SIZE (pdu_header), message_id);
          nlp$ta_send_expedited_data (cl_connection, message_id, status);
          IF NOT status.normal AND ((status.condition = nae$max_expedited_exceeded) OR
                (status.condition = nae$connection_full)) THEN
            osp$set_status_abnormal (nac$status_id, nae$supervisory_traffic_limit, 'INTERRUPT REQUEST',
                  status);
          IFEND;
        ELSE
          nlp$bm_release_message (message_id);
          osp$set_status_condition ( nae$se_interrupt_length_error,  status);
          osp$append_status_integer (osc$status_parameter_delimiter, nlc$sl_max_interrupt_message, 10, FALSE,
                status);
          osp$append_status_integer (osc$status_parameter_delimiter, nlc$sl_min_interrupt_message, 10, FALSE,
                status);
        IFEND;
      ELSE
        nlp$bm_release_message (message_id);
        osp$set_status_abnormal ('NA', nae$protocol_error, session_layer, status);
      CASEND;
    ELSE
      nlp$bm_release_message (message_id);
      osp$set_status_condition ( nae$connection_not_open,  status);
    IFEND;
  PROCEND nlp$sl_interrupt_request;
?? OLDTITLE ??
?? NEWTITLE := 'process_error_indication', EJECT ??

  PROCEDURE process_error_indication
    (    cl_connection: ^nlt$cl_connection;
     VAR connection: ^nlt$sl_connection_descriptor;
     VAR accumulated_message_buffers: nlt$ta_inventory_report);

    VAR
      event: nlt$sl_event,
      local_status: ost$status;

    CASE connection^.current_state OF
    = nlc$sl_call_wait, nlc$sl_disconnect_wait =
      nlp$ta_disconnect_connection (cl_connection, nlv$bm_null_message_id, local_status);
      nlp$cl_deactivate_layer (nlc$xns_session_layer, cl_connection);
      display_current_state (connection^.current_state);
      connection^.current_state := nlc$sl_closed;
    = nlc$sl_call_ok_wait, nlc$sl_call_response_wait, nlc$sl_data_transfer, nlc$sl_synch_response_wait,
          nlc$sl_m_r_fr_wait, nlc$sl_fwd_mark_wait, nlc$sl_rev_mark_wait, nlc$sl_synch_collision_fr =
      display_current_state (connection^.current_state);
      connection^.current_state := nlc$sl_closed;
      nlp$ta_disconnect_connection (cl_connection, nlv$bm_null_message_id, local_status);
      nlp$cl_deactivate_layer (nlc$xns_session_layer, cl_connection);
      event.kind := nlc$sl_clear_event;
      event.clear.reason := nlc$sl_layer_clear;
      event.clear.message_id := nlv$bm_null_message_id;
      nav$network_procedures [connection^.event_processor].
            sl_event_processor^ (cl_connection, event, accumulated_message_buffers);
    ELSE
    CASEND;
  PROCEND process_error_indication;

?? OLDTITLE ??
?? NEWTITLE := 'delete_connection', EJECT ??

  PROCEDURE delete_connection
    (VAR connection: ^nlt$sl_connection_descriptor;
         cl_connection: ^nlt$cl_connection);

    IF nlp$bm_valid_message_id (connection^.call_pdu_message_id) THEN
      nlp$bm_release_message (connection^.call_pdu_message_id);
    IFEND;
    nlp$cl_deactivate_layer (nlc$xns_session_layer, cl_connection);
  PROCEND delete_connection;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sl_clear_request_timer', EJECT ??

  PROCEDURE [XDCL] nlp$sl_clear_request_timer
    (    current_time: integer;
         cl_connection: ^nlt$cl_connection);

    VAR
      layer_active: boolean,
      connection: ^nlt$sl_connection_descriptor,
      ignore_status: ost$status;

    nlp$cl_get_layer_connection (nlc$xns_session_layer, cl_connection, layer_active, connection);
    IF layer_active THEN
      IF nlp$timer_expired (current_time, connection^.clear_timer) THEN
        nlp$ta_disconnect_connection (cl_connection, nlv$bm_null_message_id, ignore_status);
        delete_connection (connection, cl_connection);
      IFEND;
    IFEND;
  PROCEND nlp$sl_clear_request_timer;
?? OLDTITLE ??
?? NEWTITLE := 'display_current_state', EJECT ??

  PROCEDURE display_current_state
    (    current_state: nlt$sl_machine_state);

    VAR
      message_string: string (80),
      length: integer,
      status: ost$status;

    STRINGREP (message_string, length, 'CURRENT_STATE=', current_state);
    pmp$log (message_string (1, length), status);
  PROCEND display_current_state;
?? OLDTITLE ??
MODEND nlm$sl_internal_interface;
*DECK DECK=NLM$SYSTEM_MGMT_ACCESS_AGENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access: System Management Access Agent' ??
MODULE nlm$system_mgmt_access_agent;

{ PURPOSE:
{   This module contains procedures neccesary to communicate with the System Management Access
{   Provider (SMAP) in the OSI communications device. These procedures provide the OSI System
{   Management Access Agent (SMAA) in the host.
{ DESIGN:
{   The SMAA and the SMAP communicate over a channel connection. After a device is loaded,
{   the SMAP initiates the channel connection connect request. The SMAA and the SMAP exchange
{   initialization information over the channel connection. After the initialization of the
{   SMAA/SMAP is complete, the SMAA will allow the users in the host to obtain routing
{   information and will also process DEFINE OSI SUBNET PDUs from the SMAP. Any protocol
{   error encountered will result in disconnecting the channel connection.
{   The XDCL'd procedures have been grouped in alphabetical order followed by the internal
{   procedures. The internal procedures are also in alphabetical order. The following Finite
{   State Machine describes the states and the associated events. Please refer to the System
{   Management Access Agent Protocol Specification (A7998) and the System Management Access
{   Provider Protocol Specification (A7999) for more information.
{   This module contains code that executes in ring 3. It resides on OSF$JOB_TEMPLATE_23D.
{ NOTES:
{   The CONFIGURED NETWORK DEVICE list is referenced by both the SMAA and the Channel Connection
{   Entity. The SMAA code has to ensure that this list is unlocked before calling the Channel
{   Connection Entity interfaces and vice versa. The following abreviations have been used in
{   this module.
{        PDU = Protocol Data Unit
{        ID  = Identifier

?? NEWTITLE := 'Finite State Machine', EJECT ??

{ ------------+------------+------------+------------+------------+------------+------------+
{ STATE --->  |            |   AWAIT    | AWAIT INT  | AWAIT DEV  |            |   AWAIT    |
{             |   CLOSED   |  VERSION   | ATTRIBUTE  | SPEC HOST  |   OPEN     |  SUBNET    |
{ CC EVENT |  |            |  CONFIRM   |  CONFIRM   |  ADDRESS   |            | DEFINITION |
{          V  |    (1)     |    (2)     |    (3)     |    (4)     |    (5)     |    (6)     |
{ ------------+------------+------------+------------+------------+------------+------------+
{   CONNECT   |            |  PROTOCOL  |  PROTOCOL  |  PROTOCOL  |  PROTOCOL  |  PROTOCOL  |
{  INDICATION | (1)--->(2) |  ERROR     |  ERROR     |  ERROR     |  ERROR     |  ERROR     |
{(DEF VERSION)|            |            |            |            |            |            |
{ ------------+------------+------------+------------+------------+------------+------------+
{   DATA EVENT|   SYSTEM   |            |  PROTOCOL  |  PROTOCOL  |  PROTOCOL  |  PROTOCOL  |
{  (VERSION   |   ERROR    | (2)--->(3) |  ERROR     |  ERROR     |  ERROR     |  ERROR     |
{   CONFIRM)  |            |            |            |            |            |            |
{ ------------+------------+------------+------------+------------+------------+------------+
{   DATA EVENT|   SYSTEM   |  PROTOCOL  |            |  PROTOCOL  |  PROTOCOL  |  PROTOCOL  |
{ (INT ATTRIB |   ERROR    |  ERROR     | (3)--->(4) |  ERROR     |  ERROR     |  ERROR     |
{   CONFIRM)  |            |            |            |            |            |            |
{ ------------+------------+------------+------------+------------+------------+------------+
{   DATA EVENT|   SYSTEM   |  PROTOCOL  |  PROTOCOL  |            |  PROTOCOL  |  PROTOCOL  |
{  (DEFINE DEV|   ERROR    |  ERROR     |  ERROR     | (4)--->(5) |  ERROR     |  ERROR     |
{   SPEC ADDR |            |            |            |            |            |            |
{ ------------+------------+------------+------------+------------+------------+------------+
{   DATA EVENT|   SYSTEM   |  PROTOCOL  |  PROTOCOL  |  PROTOCOL  |            |            |
{  (DEFINE    |   ERROR    |  ERROR     |  ERROR     |  ERROR     | (5)--->(6) | (6)--->(6) |
{   SUBNETS)  |            |            |            |            |            |            |
{ ------------+------------+------------+------------+------------+------------+------------+
{   DATA EVENT|   SYSTEM   |  PROTOCOL  |  PROTOCOL  |  PROTOCOL  |  PROTOCOL  |            |
{  (END SUBNET|   ERROR    |  ERROR     |  ERROR     |  ERROR     |  ERROR     | (6)--->(5) |
{   DEFN)     |            |            |            |            |            |            |
{ ------------+------------+------------+------------+------------+------------+------------+
{   DATA EVENT|   SYSTEM   |  PROTOCOL  |  PROTOCOL  |  PROTOCOL  |            |            |
{  (DESTN ACC |   ERROR    |  ERROR     |  ERROR     |  ERROR     | (5)--->(5) | (6)--->(6) |
{   RESPONSE) |            |            |            |            |            |            |
{ ------------+------------+------------+------------+------------+------------+------------+
{   DATA EVENT|   SYSTEM   |  PROTOCOL  |  PROTOCOL  |  PROTOCOL  |            |            |
{  (DEFINE DEV|   ERROR    |  ERROR     |  ERROR     |  ERROR     | (5)--->(5) | (6)--->(6) |
{   SERV ATTR)|            |            |            |            |            |            |
{ ------------+------------+------------+------------+------------+------------+------------+
{   DISCONNECT|   SYSTEM   |            |            |            |            |            |
{   EVENT     |   ERROR    | (2)--->(1) | (3)--->(1) | (4)--->(1) | (5)--->(1) | (6)--->(1) |
{             |            |            |            |            |            |            |
{-------------+------------+------------+------------+------------+------------+------------+

?? OLDTITLE ??
?? NEWTITLE := 'User Interface', EJECT ??

{ ------------+------------+------------+------------+------------+------------+------------+
{ STATE --->  |            |   AWAIT    | AWAIT INT  | AWAIT DEV  |            |   AWAIT    |
{             |   CLOSED   |  VERSION   | ATTRIBUTE  | SPEC HOST  |   OPEN     |  SUBNET    |
{ USER REQ |  |            |  CONFIRM   |  CONFIRM   |  ADDRESS   |            | DEFINITION |
{          V  |    (1)     |    (2)     |    (3)     |    (4)     |    (5)     |   (6)      |
{ ------------+------------+------------+------------+------------+------------+------------+
{  DESTN ACC  |            |            |            |            |            |            |
{  REQUEST    |   REJECT   |   REJECT   |   REJECT   |   REJECT   | (5)--->(5) | (6)--->(6) |
{             |            |            |            |            |            |            |
{ ------------+------------+------------+------------+------------+------------+------------+

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nac$null_connection_id
*copyc nae$application_interfaces
*copyc nae$system_mgmt_access_agent
*copyc nat$connection_id
*copyc nat$network_procedure
*copyc nat$osi_network_address
*copyc nat$ta_alternate_protocol_class
*copyc nat$ta_preferred_protocol_class
*copyc nlc$smaa_versions
*copyc nlt$cc_disconnect_reason
*copyc nlt$cc_interface
*copyc nlt$cl_connection
*copyc nlt$cl_connection_layer_templat
*copyc nlt$cl_layer_name
*copyc nlt$device_count
*copyc nlt$device_identifier
*copyc nlt$device_list
*copyc nlt$network_device
*copyc nlt$network_device_list
*copyc nlt$sm_await_routing_query
*copyc nlt$sm_device_attributes_list
*copyc nlt$sm_device_information
*copyc nlt$sm_device_service_attribute
*copyc nlt$sm_device_service_values
*copyc nlt$sm_device_version_list
*copyc nlt$sm_layer_connection
*copyc nlt$sm_protocol_data_unit
*copyc nlt$sm_route_status
*copyc nlt$subnet_attributes
*copyc ost$signature_lock_status
*copyc ost$status
?? POP ??
*copyc nap$display_message
*copyc nap$namve_system_error
*copyc nap$system_id
*copyc nlp$bm_create_message
*copyc nlp$bm_flush_message
*copyc nlp$bm_get_message_length
*copyc nlp$bm_release_message
*copyc nlp$cc_accept_connection
*copyc nlp$cc_disconnect
*copyc nlp$cc_initialize_template
*copyc nlp$cc_send_data
*copyc nlp$cl_activate_layer
*copyc nlp$cl_activate_receiver
*copyc nlp$cl_deactivate_layer
*copyc nlp$cl_get_exclusive_via_cid
*copyc nlp$cl_get_layer_connection
*copyc nlp$cl_initialize_template
*copyc nlp$cl_release_exclusive_access
*copyc nlp$get_exclusive_access
*copyc nlp$get_nonexclusive_access
*copyc nlp$la_open_saps
*copyc nlp$na_disconnect_connections
*copyc nlp$na_open_saps
*copyc nlp$release_exclusive_access
*copyc nlp$release_nonexclusive_access
*copyc osp$add_to_locked_variable
*copyc osp$append_status_integer
*copyc osp$clear_job_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$increment_locked_variable
*copyc osp$set_job_signature_lock
*copyc osp$set_status_condition
*copyc osp$set_status_abnormal
*copyc pmp$get_compact_date_time
*copyc pmp$get_executing_task_gtid
{*copyc pmp$log
*copyc pmp$ready_task
*copyc pmp$wait
*copyc syp$cycle
*copyc nav$global_osi_statistics
*copyc nav$host_subnet_id
*copyc nav$network_paged_heap
*copyc nav$statistics_enabled
*copyc nlv$configured_network_devices
*copyc nlv$sm_await_routing_queries
*copyc nlv$sm_devices
*copyc nlv$transport_network_selector
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    sm_protocol_class_set = SET OF nlt$sm_device_service_values,
    sm_device_selection_status = (sm_route_known, sm_route_unknown, sm_subnet_unknown);

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sm_connect_event_processor', EJECT ??
*copy nlh$sm_connect_event_processor

  PROCEDURE [XDCL] nlp$sm_connect_event_processor
    (    cl_connection {input, output} : ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

    VAR
      connection: ^nlt$sm_layer_connection,
      data: nlt$bm_message_id,
      data_fragments: array [1 .. 2] of nat$data_fragment,
      error_message_length: integer,
      error_message: ^string (132),
      ignore_layer_active: boolean,
      ignore_status: ost$status,
      length: integer,
      sm_pdu_header: nlt$sm_pdu_header,
      smap_version: nlt$sm_version,
      system_management: ^nlt$system_management,
      version_response: nlt$sm_version_response;

    inventory_report := 0;
    nlp$cl_activate_layer (nlc$osi_sys_mgmt_access_agent, cl_connection);
    nlp$cl_get_layer_connection (nlc$osi_sys_mgmt_access_agent, cl_connection, ignore_layer_active,
          connection);

{ Validate incoming event and PDU. Note that the connect event is received in the connection
{ establishment task.

    IF event.kind = nlc$cc_connect_event THEN
      nlp$get_exclusive_access (nlv$sm_devices.access_control);
      system_management := ^nlv$sm_devices.list^ [event.connect.device_id];
      data := event.connect.data;
      IF system_management^.state = nlc$sm_uninitialized THEN
        nlp$bm_get_message_length (event.connect.data, length);
        IF length = (#SIZE (nlt$sm_pdu_header) + #SIZE (nlt$sm_version)) THEN
          data_fragments [1].address := ^sm_pdu_header;
          data_fragments [1].length := #SIZE (sm_pdu_header);
          data_fragments [2].address := ^smap_version;
          data_fragments [2].length := #SIZE (smap_version);
          nlp$bm_flush_message (data_fragments, data, length, ignore_status);
          IF length = sm_pdu_header.length THEN
            IF sm_pdu_header.kind = nlc$sm_define_version THEN

{ Save connection attributes.

              system_management^.connection_id := cl_connection^.identifier;
              system_management^.state := nlc$sm_initialization_phase1;

{ Send a connect response PDU with the common version.

              version_response.header.length := #SIZE (version_response);
              version_response.header.kind := nlc$sm_version_response;
              IF (smap_version <= nlc$sm_version_1) THEN
                version_response.common_version := nlc$sm_version_1;
              ELSE
                version_response.common_version := nlc$sm_version_2;
              IFEND;
              system_management^.device_version := version_response.common_version;
              system_management^.supported_protocol_class := nlc$sm_tp4_clns;
              nlp$release_exclusive_access (nlv$sm_devices.access_control);
              data_fragments [1].address := ^version_response;
              data_fragments [1].length := version_response.header.length;
              data_fragments [2].address := NIL;
              data_fragments [2].length := 0;
              nlp$bm_create_message (data_fragments, data, ignore_status);
              nlp$cc_accept_connection (cl_connection, event.connect.class, data, ignore_status);
              connection^.state := nlc$sm_await_version_confirm;
              connection^.device_id := event.connect.device_id;

{ Activate receiver so that all system mgmt events are received in the current task.

              nlp$cl_activate_receiver (cl_connection);
            ELSE { System Management event other than DEFINE_VERSION
              nlp$release_exclusive_access (nlv$sm_devices.access_control);
              disconnect_sm_connection (cl_connection, nlc$sm_dr_unexpected_event);
            IFEND;
          ELSE { Length in the header does not match the pdu length
            nlp$release_exclusive_access (nlv$sm_devices.access_control);
            disconnect_sm_connection (cl_connection, nlc$sm_dr_length_mismatch);
          IFEND;
        ELSE { Unexpected PDU length
          nlp$release_exclusive_access (nlv$sm_devices.access_control);
          disconnect_sm_connection (cl_connection, nlc$sm_dr_unexpected_length);
          nlp$bm_release_message (data);
        IFEND;
      ELSE { System Management connection already exists
        nlp$release_exclusive_access (nlv$sm_devices.access_control);
        disconnect_sm_connection (cl_connection, nlc$sm_dr_dup_connect_event);
        nlp$bm_release_message (data);
      IFEND;
    ELSE { Unexpected CC event
      PUSH error_message;
      STRINGREP (error_message^, error_message_length,
          'Invalid CC event received by SME. Expecting a CC connect event but received event ', event.kind);
      nap$namve_system_error (TRUE, error_message^ (1, error_message_length), NIL);
      disconnect_sm_connection (cl_connection, nlc$sm_dr_namve_error);
    IFEND;

  PROCEND nlp$sm_connect_event_processor;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sm_event_processor', EJECT ??
*copy nlh$sm_event_processor

  PROCEDURE [XDCL] nlp$sm_event_processor
    (    cl_connection {input, output} : ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

    VAR
      actual: integer,
      address_ok: boolean,
      await_routing_query: ^nlt$sm_await_routing_query,
      confirm_dev_spec_host_address: nlt$sm_confrm_dev_spec_host_add,
      connection: ^nlt$sm_layer_connection,
      data: nlt$bm_message_id,
      data_fragments: array [1 .. 2] of nat$data_fragment,
      define_interface_attributes: nlt$sm_define_interface_attrib,
      dest_acc_fixed_response: ^nlt$sm_dest_acc_fixed_response,
      device_attribute_code: ^ 0 .. 0FF(16),
      device_attribute_length: ^ 0 .. 0FF(16),
      device_attribute_value: ^nlt$sm_device_service_attribute,
      disconnect_reason: nlt$sm_disconnect_reason,
      disconnect_reason_code: nlt$sm_disconnect_reason,
      duplicate_subnet: boolean,
      element: cmt$element_name,
      error_message_length: integer,
      error_message: ^string (132),
      generic_host_address: ^nat$osi_network_address,
      i: integer,
      ignore_status: ost$status,
      layer_active: boolean,
      length: integer,
      network_address_length: ^nat$osi_network_address_length,
      network_address_prefix: ^nat$osi_network_address_prefix,
      network_selector: ^nat$network_selector,
      old_subnet_list: ^nlt$subnet_attributes,
      pdu_ok: boolean,
      sm_data: ^SEQ ( * ),
      sm_pdu_header: nlt$sm_pdu_header,
      status: ost$status,
      subnet_attributes_list: ^nlt$subnet_attributes,
      subnet_count: nat$subnet_identifier,
      subnet_id: ^nat$subnet_identifier,
      subnet_list: ^array [1 .. * ] of nat$subnet_identifier,
      system_id: ^nat$system_identifier,
      system_management: ^nlt$system_management,
      system_management_list: ^nlt$sm_device_list,
      unused_byte_count: integer,
      unused_space: ^array [1 .. *] of 0 .. 0ff(16);

    inventory_report := 0;
    nlp$cl_get_layer_connection (nlc$osi_sys_mgmt_access_agent, cl_connection, layer_active, connection);
    IF layer_active THEN
      data_fragments [1].address := ^sm_pdu_header;
      data_fragments [1].length := #SIZE (sm_pdu_header);
      CASE event.kind OF
      = nlc$cc_data_event =
        data := event.data.data;
        nlp$bm_get_message_length (data, length);
        IF length >= #SIZE (nlt$sm_pdu_header) THEN
          IF length > #SIZE (nlt$sm_pdu_header) THEN
            PUSH sm_data: [[REP (length - #SIZE (nlt$sm_pdu_header)) OF cell]];
            RESET sm_data;
            data_fragments [2].address := sm_data;
            data_fragments [2].length := #SIZE (sm_data^);
          ELSE
            data_fragments [2].address := NIL;
            data_fragments [2].length := 0;
          IFEND;
          nlp$bm_flush_message (data_fragments, data, length, {ignore} status);
          IF sm_pdu_header.length = length THEN

{ Process data events.

            CASE sm_pdu_header.kind OF
?? NEWTITLE := 'nlc$cc_data_event' ??
?? NEWTITLE := 'nlc$sm_version_confirm', EJECT ??
            = nlc$sm_version_confirm =
              IF connection^.state = nlc$sm_await_version_confirm THEN
                IF length = #SIZE (nlt$sm_pdu_header) THEN

{ Send the Define_interface_attributes PDU to the SMAP.

                  define_interface_attributes.header.kind := nlc$sm_define_interface_attrib;
                  define_interface_attributes.header.length := #SIZE (define_interface_attributes);
                  define_interface_attributes.transport_network_selector := nlv$transport_network_selector;
                  define_interface_attributes.subnet_id := nav$host_subnet_id;
                  define_interface_attributes.system_id := nap$system_id ();
                  pmp$get_compact_date_time (define_interface_attributes.date_and_time, {ignore} status);
                  data_fragments [1].address := ^define_interface_attributes;
                  data_fragments [1].length := define_interface_attributes.header.length;
                  data_fragments [2].address := NIL;
                  data_fragments [2].length := 0;
                  nlp$bm_create_message (data_fragments, data, {ignore} status);
                  nlp$cc_send_data (cl_connection, data, {ignore} status);
                  connection^.state := nlc$sm_await_int_attrib_confirm;
                ELSE { Unexpected length
                  delete_sm_connection (connection^.device_id);
                  disconnect_sm_connection (cl_connection, nlc$sm_dr_unexpected_length);
                IFEND;
              ELSE { Unexpected event
                delete_await_routing_query (connection^.device_id);
                delete_sm_connection (connection^.device_id);
                disconnect_sm_connection (cl_connection, nlc$sm_dr_unexpected_event);
              IFEND;

?? OLDTITLE ??
?? NEWTITLE := 'nlc$sm_confirm_interface_attrib', EJECT ??
            = nlc$sm_confirm_interface_attrib =
              IF connection^.state = nlc$sm_await_int_attrib_confirm THEN
                IF (length >= (#SIZE (nlt$sm_confirm_int_attrib_fixed) + nac$osi_minimum_prefix_length)) AND
                      (length <= (#SIZE (nlt$sm_confirm_int_attrib_fixed) + nac$osi_maximum_prefix_length))
                      THEN
                  NEXT network_address_length IN sm_data;
                  IF (network_address_length^ > 0) AND (network_address_length^ <=
                        nac$osi_max_network_address_len) THEN
                    NEXT network_address_prefix: [(length - #SIZE (nlt$sm_confirm_int_attrib_fixed))] IN
                          sm_data;
                    connection^.state := nlc$sm_await_dev_spec_host_addr;
                    nlp$get_exclusive_access (nlv$sm_devices.access_control);
                    system_management := ^nlv$sm_devices.list^ [connection^.device_id];
                    system_management^.state := nlc$sm_initialization_phase2;
                    system_management^.network_address_length := network_address_length^;
                    generic_host_address := ^system_management^.generic_host_address;
                    RESET generic_host_address;
                    NEXT system_management^.network_address_prefix: [#SIZE (network_address_prefix^)] IN
                          generic_host_address;
                    system_management^.network_address_prefix^ := network_address_prefix^;
                    unused_byte_count := network_address_length^ - #SIZE (network_address_prefix^) -
                          #SIZE (nat$subnet_identifier) - #SIZE (nat$system_identifier) -
                          #SIZE (nat$network_selector);
                    IF unused_byte_count > 0 THEN
                      NEXT unused_space: [1 .. unused_byte_count] IN generic_host_address;
                      FOR i := 1 TO unused_byte_count DO
                        unused_space^ [i] := 0;
                      FOREND;
                    IFEND;
                    NEXT subnet_id IN generic_host_address;
                    subnet_id^ := nav$host_subnet_id;
                    NEXT system_id IN generic_host_address;
                    system_id^ := nav$system_id;
                    NEXT network_selector IN generic_host_address;
                    network_selector^ := nlv$transport_network_selector;
                    nlp$release_exclusive_access (nlv$sm_devices.access_control);

{ Open network layer saps in the device.

                    nlp$na_open_saps (connection^.device_id);
                  ELSE { Unexpected network address length
                    delete_sm_connection (connection^.device_id);
                    disconnect_sm_connection (cl_connection, nlc$sm_dr_incorrect_addr_length);
                  IFEND;
                ELSE { Unexpected length
                  delete_sm_connection (connection^.device_id);
                  disconnect_sm_connection (cl_connection, nlc$sm_dr_unexpected_length);
                IFEND;
              ELSE { Unexpected event
                delete_await_routing_query (connection^.device_id);
                delete_sm_connection (connection^.device_id);
                disconnect_sm_connection (cl_connection, nlc$sm_dr_unexpected_event);
              IFEND;

?? OLDTITLE ??
?? NEWTITLE := 'nlc$sm_define_dev_spec_host_add', EJECT ??
            = nlc$sm_define_dev_spec_host_add =
              IF connection^.state = nlc$sm_await_dev_spec_host_addr THEN
                IF length > #SIZE (nlt$sm_pdu_header) THEN
                  define_device_spec_host_address (sm_data^, connection^.device_id, address_ok);
                  IF address_ok THEN

{ Send a Confirm_device_specific_host_address PDU to the SMAP.

                    confirm_dev_spec_host_address.header.kind := nlc$sm_confrm_dev_spec_host_add;
                    confirm_dev_spec_host_address.header.length := #SIZE (confirm_dev_spec_host_address);
                    data_fragments [1].address := ^confirm_dev_spec_host_address;
                    data_fragments [1].length := confirm_dev_spec_host_address.header.length;
                    data_fragments [2].address := NIL;
                    data_fragments [2].length := 0;
                    nlp$bm_create_message (data_fragments, data, {ignore} status);
                    nlp$cc_send_data (cl_connection, data, {ignore} status);
                    connection^.state := nlc$sm_open;
                    nlp$get_exclusive_access (nlv$sm_devices.access_control);
                    nlv$sm_devices.list^ [connection^.device_id].state := nlc$sm_initialized;
                    nlp$release_exclusive_access (nlv$sm_devices.access_control);
                  ELSE { Incorrect device specific host address
                    osp$set_status_abnormal (nac$status_id, nae$sm_dshnet_error,
                          nlv$configured_network_devices.network_device_list^ [connection^.device_id].element,
                          status);
                    nap$display_message (status);
                    delete_sm_connection (connection^.device_id);
                    disconnect_sm_connection (cl_connection, nlc$sm_dr_incorrect_dev_address);
                  IFEND;
                ELSE { Unexpected length
                  delete_sm_connection (connection^.device_id);
                  disconnect_sm_connection (cl_connection, nlc$sm_dr_unexpected_length);
                IFEND;
              ELSE { Unexpected event
                delete_await_routing_query (connection^.device_id);
                delete_sm_connection (connection^.device_id);
                disconnect_sm_connection (cl_connection, nlc$sm_dr_unexpected_event);
              IFEND;

?? OLDTITLE ??
?? NEWTITLE := 'nlc$sm_define_subnets', EJECT ??
            = nlc$sm_define_subnets =
              IF (connection^.state = nlc$sm_open) OR (connection^.state = nlc$sm_await_subnet_definition)
                    THEN
                IF length > #SIZE (nlt$sm_pdu_header) THEN
                  extract_subnet_attributes (sm_data, subnet_attributes_list, pdu_ok);
                  IF pdu_ok THEN
                    add_subnet_attributes (connection^.device_id, subnet_attributes_list, duplicate_subnet);
                    IF NOT duplicate_subnet THEN
                      connection^.state := nlc$sm_await_subnet_definition;
                    ELSE

{ Send disconnect with reason code of duplicate subnet definition.

                      delete_await_routing_query (connection^.device_id);
                      delete_sm_connection (connection^.device_id);
                      disconnect_sm_connection (cl_connection, nlc$sm_dr_dup_subnet);
                    IFEND;
                  ELSE { Ill formed PDU
                    delete_await_routing_query (connection^.device_id);
                    delete_sm_connection (connection^.device_id);
                    disconnect_sm_connection (cl_connection, nlc$sm_dr_ill_formed_pdu);
                  IFEND;
                ELSE { Unexpected length
                  delete_await_routing_query (connection^.device_id);
                  delete_sm_connection (connection^.device_id);
                  disconnect_sm_connection (cl_connection, nlc$sm_dr_unexpected_length);
                IFEND;
              ELSE { Unexpected event
                delete_await_routing_query (connection^.device_id);
                delete_sm_connection (connection^.device_id);
                disconnect_sm_connection (cl_connection, nlc$sm_dr_unexpected_event);
              IFEND;

?? OLDTITLE ??
?? NEWTITLE := 'nlc$sm_end_subnet_definition', EJECT ??
            = nlc$sm_end_subnet_definition =
              IF connection^.state = nlc$sm_await_subnet_definition THEN
                IF length = #SIZE (nlt$sm_pdu_header) THEN

{ Switch the subnet lists.

                  nlp$get_exclusive_access (nlv$sm_devices.access_control);
                  system_management_list := nlv$sm_devices.list;
                  old_subnet_list := system_management_list^ [connection^.device_id].subnet_list;
                  system_management_list^ [connection^.device_id].subnet_list :=
                        system_management_list^ [connection^.device_id].new_subnet_list;
                  system_management_list^ [connection^.device_id].new_subnet_list := NIL;

{ If the device is an ICA-II notify Link Access (LA) of the directly connected subnet connected
{ to this device.
{     NOTE: This code assumes that only one directly connected subnet will be defined.

                  subnet_count := 0;
                  IF nlv$configured_network_devices.network_device_list^ [connection^.device_id].
                         kind = nac$ica_2 THEN
                    subnet_attributes_list := system_management_list^ [connection^.device_id].
                          subnet_list;
                    PUSH subnet_list: [1 .. 1];
                    /loop/
                    WHILE (subnet_attributes_list <> NIL) AND (subnet_count = 0) DO
                      IF subnet_attributes_list^.directly_connected THEN
                        subnet_count := 1;
                        subnet_list^ [1] := subnet_attributes_list^.subnet_id;
                        EXIT /loop/;
                      IFEND;
                      subnet_attributes_list := subnet_attributes_list^.next_entry;
                    WHILEND /loop/;
                  IFEND;
                  nlp$release_exclusive_access (nlv$sm_devices.access_control);
                  IF subnet_count > 0 THEN
                    nlp$la_open_saps (connection^.device_id, subnet_count, subnet_list);
                  IFEND;
                  free_subnet_list (old_subnet_list);
                  connection^.state := nlc$sm_open;

{! statistics begin

                  IF nav$statistics_enabled THEN
                    osp$increment_locked_variable (nav$global_osi_statistics.system_management_entity.
                          subnet_attribute_updates_rcvd, 0, actual);
                  IFEND;

{! statistics end

                ELSE { Unexpected length
                  delete_await_routing_query (connection^.device_id);
                  delete_sm_connection (connection^.device_id);
                  disconnect_sm_connection (cl_connection, nlc$sm_dr_unexpected_length);
                IFEND;
              ELSE { Unexpected event
                delete_await_routing_query (connection^.device_id);
                delete_sm_connection (connection^.device_id);
                disconnect_sm_connection (cl_connection, nlc$sm_dr_unexpected_event);
              IFEND;

?? OLDTITLE ??
?? NEWTITLE := 'nlc$sm_dest_accessible_response', EJECT ??
            = nlc$sm_dest_accessible_response =
              IF (connection^.state = nlc$sm_open) OR
                    (connection^.state = nlc$sm_await_subnet_definition) THEN
                IF length >= (#SIZE (nlt$sm_pdu_header) + #SIZE (nlt$sm_dest_acc_fixed_response)) THEN
                  NEXT dest_acc_fixed_response IN sm_data;
                  osp$set_job_signature_lock (nlv$sm_await_routing_queries.lock);

{ Find the await_routing_query for the given dest_accessible_response.request_id.
{ If the matching await_routing_query entry is not found, ignore the PDU as the
{ task awaiting the response could have timed out.

                  await_routing_query := nlv$sm_await_routing_queries.await_routing_query;
                  WHILE (await_routing_query <> NIL) AND (await_routing_query^.request_id <>
                        dest_acc_fixed_response^.request_id) DO
                    await_routing_query := await_routing_query^.next_entry;
                  WHILEND;

                  IF await_routing_query <> NIL THEN

                  /search/
                    FOR i := 1 TO UPPERBOUND (await_routing_query^.device_information_list) DO
                      IF await_routing_query^.device_information_list [i].device_id =
                            connection^.device_id THEN
                        IF NOT await_routing_query^.device_information_list [i].response_received THEN
                          await_routing_query^.response_count := await_routing_query^.response_count
                                + 1;
                          await_routing_query^.device_information_list [i].response_received := TRUE;
                          await_routing_query^.device_information_list [i].route_status :=
                                dest_acc_fixed_response^.route_status;

{ This code will have to be changed whenever the QOS attributes associated with a
{ route is defined. It will have to save the QOS attribute with each route and the
{ nlp$sm_select_device will have to analyze the QOS attribute.

                        ELSE
                          PUSH error_message;
                          STRINGREP (error_message^, error_message_length,
                                'Duplicate destination accessible response received from network device id ',
                                connection^.device_id);
                          nap$namve_system_error (TRUE, error_message^ (1, error_message_length), NIL);
                        IFEND;
                        EXIT /search/;
                      IFEND;
                    FOREND /search/;

{ Ready the task if all responses have been received.

                    IF (await_routing_query^.response_count = await_routing_query^.query_count) OR
                      ((await_routing_query^.ready_on_route_known_response) AND
                       (dest_acc_fixed_response^.route_status = nlc$sm_route_known)) THEN
                      pmp$ready_task (await_routing_query^.task_id, {ignore} status);
                    IFEND;
                  IFEND;
                  osp$clear_job_signature_lock (nlv$sm_await_routing_queries.lock);
                ELSE { Unexpected length
                  delete_await_routing_query (connection^.device_id);
                  delete_sm_connection (connection^.device_id);
                  disconnect_sm_connection (cl_connection, nlc$sm_dr_unexpected_length);
                IFEND;
              ELSE { Unexpected event
                delete_sm_connection (connection^.device_id);
                disconnect_sm_connection (cl_connection, nlc$sm_dr_unexpected_event);
              IFEND;

?? OLDTITLE ??
?? NEWTITLE := 'nlc$sm_device_service_attribute', EJECT ??
            = nlc$sm_device_service_attribute =
              IF (connection^.state=nlc$sm_open) OR (connection^.state=nlc$sm_await_subnet_definition) THEN
                IF length > #SIZE (nlt$sm_pdu_header) THEN
                  nlp$get_exclusive_access (nlv$sm_devices.access_control);
                  system_management := ^nlv$sm_devices.list^ [connection^.device_id];
                  IF system_management^.device_version >= nlc$sm_version_2 THEN
                    NEXT device_attribute_code in sm_data;
                    IF device_attribute_code <> NIL THEN
                      CASE device_attribute_code^ OF
                        = nlc$sm_transport_service_attrib =
                          NEXT device_attribute_length in sm_data;
                          IF device_attribute_length <> NIL THEN
                            IF device_attribute_length^ = #SIZE (nlt$sm_device_service_attribute) THEN
                              NEXT device_attribute_value in sm_data;
                              system_management^.supported_protocol_class := device_attribute_value^;
                              nlp$release_exclusive_access (nlv$sm_devices.access_control);
                            ELSE { Invalid length sent by SMAP
                              nlp$release_exclusive_access (nlv$sm_devices.access_control);
                              delete_sm_connection (connection^.device_id);
                              disconnect_sm_connection (cl_connection, nlc$sm_dr_unexpected_length);
                            IFEND;
                          ELSE { Nil pointer
                            nlp$release_exclusive_access (nlv$sm_devices.access_control);
                            delete_sm_connection (connection^.device_id);
                            disconnect_sm_connection (cl_connection, nlc$sm_dr_unknown_pdu_kind);
                          IFEND;
                        ELSE { Unknown define device attributes code
                          nlp$release_exclusive_access (nlv$sm_devices.access_control);
                          delete_sm_connection (connection^.device_id);
                          disconnect_sm_connection (cl_connection, nlc$sm_dr_invalid_service_attr);
                      CASEND;
                    ELSE { Nil pointer
                      nlp$release_exclusive_access (nlv$sm_devices.access_control);
                      delete_sm_connection (connection^.device_id);
                      disconnect_sm_connection (cl_connection, nlc$sm_dr_unknown_pdu_kind);
                    IFEND;
                  ELSE  { Invalid PDU kind sent by SMAP
                    nlp$release_exclusive_access (nlv$sm_devices.access_control);
                    delete_sm_connection (connection^.device_id);
                    disconnect_sm_connection (cl_connection, nlc$sm_dr_unknown_pdu_kind);
                  IFEND;
                IFEND;
              IFEND;

            ELSE { Unknown system management PDU kind
              delete_await_routing_query (connection^.device_id);
              delete_sm_connection (connection^.device_id);
              disconnect_sm_connection (cl_connection, nlc$sm_dr_unknown_pdu_kind);
            CASEND;
          ELSE { Length in the header does not match PDU length
            delete_await_routing_query (connection^.device_id);
            delete_sm_connection (connection^.device_id);
            disconnect_sm_connection (cl_connection, nlc$sm_dr_length_mismatch);
          IFEND;
        ELSE { PDU is too small, even the header is not present
          nlp$bm_release_message (data);
          delete_await_routing_query (connection^.device_id);
          delete_sm_connection (connection^.device_id);
          disconnect_sm_connection (cl_connection, nlc$sm_dr_pdu_too_small);
        IFEND;

?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'nlc$cc_disconnect_event', EJECT ??
      = nlc$cc_disconnect_event =
        nlp$cl_deactivate_layer (nlc$osi_sys_mgmt_access_agent, cl_connection);
        delete_await_routing_query (connection^.device_id);
        delete_sm_connection (connection^.device_id);
        IF event.disconnect.reason = nlc$cc_dr_normal_disconnect THEN
          nlp$bm_get_message_length (event.disconnect.data, length);
          IF length = (#SIZE (nlt$sm_pdu_header) + #SIZE (nlt$sm_disconnect_reason)) THEN
            data_fragments [2].address := ^disconnect_reason;
            data_fragments [2].length := #SIZE (disconnect_reason);
            data := event.disconnect.data;
            nlp$bm_flush_message (data_fragments, data, length, {ignore} status);
            IF sm_pdu_header.kind = nlc$sm_disconnect_indication THEN
              IF sm_pdu_header.length = length THEN

{ Log the disconnect reason code.

                osp$set_status_condition ( nae$sm_peer_disconnect,  status);
                osp$append_status_integer (osc$status_parameter_delimiter, disconnect_reason, 16, FALSE,
                      status);
                nap$display_message (status);

{ If disconnect is due to duplicate host network address, then display the message in the job log.

                IF disconnect_reason = nlc$sm_dr_dup_host_address THEN
                  element := nlv$configured_network_devices.network_device_list^ [connection^.
                    device_id].element;

                  osp$set_status_abnormal (nac$status_id, nae$sm_dup_host_address_reject, element,
                    status);
                  nap$display_message (status);
                IFEND;
              ELSE { Length in the header does not match the PDU length
                PUSH error_message;
                STRINGREP (error_message^, error_message_length,
                      'The length of SME disconnect PDU is ', length, ' but length in the PDU header is ',
                      sm_pdu_header.length);
                nap$namve_system_error (TRUE, error_message^ (1, error_message_length), NIL);
              IFEND;
            ELSE { Unexpected PDU kind
              PUSH error_message;
              STRINGREP (error_message^, error_message_length, 'Unexpected PDU kind of ',
                    sm_pdu_header.kind, ' on a SME disconnect indication.');
              nap$namve_system_error (TRUE, error_message^ (1, error_message_length), NIL);
            IFEND;
          ELSE { Unexpected PDU length
            PUSH error_message;
            STRINGREP (error_message^, error_message_length, 'Unexpected PDU length of ',
                  length, ' on a SME disconnect event.');
            nap$namve_system_error (TRUE, error_message^ (1, error_message_length), NIL);
            data := event.disconnect.data;
            nlp$bm_release_message (data);
          IFEND;
        ELSE { CC disconnect
{         pmp$log ('SME - CC disconnect', status);
        IFEND;
      ELSE { Unexpected CC event
        PUSH error_message;
        STRINGREP (error_message^, error_message_length, 'Unexpected CC event kind ',
             event.kind, ' received by system management event processor.');
        nap$namve_system_error (TRUE, error_message^ (1, error_message_length), NIL);
        delete_await_routing_query (connection^.device_id);
        delete_sm_connection (connection^.device_id);
        disconnect_sm_connection (cl_connection, nlc$sm_dr_unexpected_cc_event);
      CASEND;
    ELSE { Layer inactive

{ Send disconnect with NAM/VE error.

      PUSH error_message;
      STRINGREP (error_message^, error_message_length,
           'Detected an inactive SME layer connection on receipt of a CC event kind of ', event.kind);
      nap$namve_system_error (TRUE, error_message^ (1, error_message_length), NIL);
      delete_await_routing_query (connection^.device_id);
      delete_sm_connection (connection^.device_id);
      disconnect_sm_connection (cl_connection, nlc$sm_dr_namve_error);
    IFEND;

  PROCEND nlp$sm_event_processor;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sm_initialize', EJECT ??
*copy nlh$sm_initialize

  PROCEDURE [XDCL] nlp$sm_initialize;

    VAR
      null_connect_event_processor: nlt$cl_event_processor,
      null_sap_event_processor: nlt$cl_event_processor;

    null_connect_event_processor.layer := nlc$osi_sys_mgmt_access_agent;
    null_sap_event_processor.layer := nlc$osi_sys_mgmt_access_agent;

    nlp$cl_initialize_template (nlc$osi_sys_mgmt_access_agent, nlc$osi_sys_mgmt_access_agent,
          #SIZE (nlt$sm_layer_connection), 0, null_sap_event_processor, nac$nil, null_connect_event_processor,
          nac$nil);
    nlp$cc_initialize_template (nlc$osi_sys_mgmt_access_agent);

  PROCEND nlp$sm_initialize;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$sm_select_device', EJECT ??
*copy nlh$sm_select_device

  PROCEDURE [XDCL] nlp$sm_select_device
    (    destination_address: nat$osi_network_address;
         cdna_address: boolean;
         preferred_protocol_class: nat$ta_preferred_protocol_class;
     VAR device_list: nlt$device_list;
     VAR version_list: nlt$sm_device_version_list;
     VAR count: nlt$device_count;
     VAR status: ost$status);

    VAR
      actual: integer,
      connection_list: ^array [1 .. *] of nlt$cl_connection_id,
      device_selection_status: sm_device_selection_status,
      ignore_status: ost$status,
      min_required_version: nlt$sm_version,
      network_address: ^nat$osi_network_address,
      required_protocol_class: sm_protocol_class_set,
      selected_version: nlt$sm_version,
      statistic: ^integer,
      subnet_id: ^nat$subnet_identifier,
      system_id: ^nat$system_identifier,
      till_subnet_id: ^SEQ ( * );

    status.normal := TRUE;
    count := 0;

    IF preferred_protocol_class = nac$ta_preferred_class_0 THEN
      min_required_version := nlc$sm_version_2;
      required_protocol_class := $sm_protocol_class_set[nlc$sm_tp4_clns_tp0, nlc$sm_tp4_clns_tp0_tp2,
            nlc$sm_tp4_clns_cons_tp0_tp2];
    ELSEIF  preferred_protocol_class = nac$ta_preferred_class_4_clns THEN
      min_required_version := nlc$sm_version_1;
      required_protocol_class := -$sm_protocol_class_set[];
    ELSE  {  A protocol class that SMAA doesn't support was requested.  Return count=0.
      RETURN;
    IFEND;

    PUSH connection_list: [1 .. UPPERBOUND (device_list)];

    IF cdna_address THEN

{ Extract the subnet id from the destination address.

      network_address := ^destination_address;
      RESET network_address;
      NEXT till_subnet_id: [[REP (#SIZE (destination_address) - #SIZE (nat$subnet_identifier) -
            #SIZE (nat$system_identifier) - #SIZE (nat$network_selector)) OF cell]] IN network_address;
      NEXT subnet_id IN network_address;
      NEXT system_id IN network_address;
      nlp$get_nonexclusive_access (nlv$sm_devices.access_control);

{ Find the list of devices that support the prefix in the destination address and that support the
{ preferred_protocol_class.  If only one device is found, it will be selected without further checks.

      match_prefix (destination_address, required_protocol_class, min_required_version, device_list,
            version_list, connection_list^, count);
      IF count > 1 THEN

{ Search the local cache of OSI subnet attributes.

        select_device (subnet_id^, system_id^, device_list, version_list, count, device_selection_status);
        nlp$release_nonexclusive_access (nlv$sm_devices.access_control);
        CASE device_selection_status OF
        = sm_route_known =
          status.normal := TRUE;

        = sm_route_unknown =
          osp$set_status_condition ( nae$sm_route_unknown,  status);

        = sm_subnet_unknown =
          poll_devices_for_routing_info (destination_address, connection_list^, device_list, version_list,
                count, status);

        ELSE
        CASEND;

{! statistics begin

        IF nav$statistics_enabled THEN
          IF status.normal THEN
            statistic := ^nav$global_osi_statistics.system_management_entity.cdna_address_select_device_reqs;
          ELSEIF status.condition = nae$sm_route_unknown THEN
            statistic := ^nav$global_osi_statistics.system_management_entity.cdna_address_route_unknown;
          IFEND;
          osp$increment_locked_variable (statistic^, 0, actual);
        IFEND;

{! statistics end

      ELSE { count = 0 or count = 1
        nlp$release_nonexclusive_access (nlv$sm_devices.access_control);
        IF count = 0 THEN
          osp$set_status_condition ( nae$sm_route_unknown,  status);

{! statistics begin

          IF nav$statistics_enabled THEN
            osp$increment_locked_variable (nav$global_osi_statistics.system_management_entity.
                  cdna_address_route_unknown, 0, actual);
          IFEND;
        IFEND;

{! statistics end

      IFEND;
    ELSE { Non CDNA address
      get_sm_connections_and_devices (required_protocol_class, min_required_version, connection_list^,
            device_list, version_list, count);

{ NOTE: A count of 1 implies that there is only one device configured (or available)
{       and so there is no need to poll. The only configured device is returned as
{       the selected device.

      IF count > 1 THEN
        poll_devices_for_routing_info (destination_address, connection_list^, device_list, version_list,
              count, status);
        IF nav$statistics_enabled THEN
          IF status.normal THEN
            statistic := ^nav$global_osi_statistics.system_management_entity.noncdna_addr_select_device_reqs;
          ELSE
            statistic := ^nav$global_osi_statistics.system_management_entity.noncdna_address_route_unknown;
          IFEND;
          osp$increment_locked_variable (statistic^, 0, actual);
        IFEND;
      ELSEIF count = 0 THEN
        osp$set_status_condition ( nae$sm_no_device_configured,  status);
      ELSEIF count = 1 THEN

{! statistics begin

        IF nav$statistics_enabled THEN
          osp$increment_locked_variable (nav$global_osi_statistics.system_management_entity.
                noncdna_addr_select_device_reqs, 0, actual);
        IFEND;

{! statistics end

      IFEND;
    IFEND;

  PROCEND nlp$sm_select_device;
?? OLDTITLE ??
?? NEWTITLE := 'add_subnet_attributes', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to add the given subnet attributes
{   to the network device entry for the specified device. It also verifies
{   that the subnet attributes being added are for unique subnets. In case
{   of an error, the subnet attributes list is freed. The new list being built
{   is not used for device selection. The current list in use is replaced
{   by this new list after the end subnet PDU is received.

  PROCEDURE add_subnet_attributes
    (    device_id: nlt$device_identifier;
     VAR subnet_attributes_list {input, output} : ^nlt$subnet_attributes;
     VAR duplicate_subnet: boolean);

    VAR
      new_subnet_attributes: ^nlt$subnet_attributes,
      previous_subnet_attributes: ^^nlt$subnet_attributes,
      remaining_subnet_attributes: ^nlt$subnet_attributes,
      system_management: ^nlt$system_management;

    duplicate_subnet := FALSE;
  /verify_subnet/
    BEGIN

{ Verify that the new subnet list contains unique subnets.

    new_subnet_attributes := subnet_attributes_list;
    WHILE new_subnet_attributes^.next_entry <> NIL DO
      remaining_subnet_attributes := new_subnet_attributes^.next_entry;
      REPEAT
        IF remaining_subnet_attributes^.subnet_id = new_subnet_attributes^.subnet_id THEN
          duplicate_subnet := TRUE;
          EXIT /verify_subnet/;
        IFEND;
        remaining_subnet_attributes := remaining_subnet_attributes^.next_entry;
      UNTIL remaining_subnet_attributes = NIL;
      new_subnet_attributes := new_subnet_attributes^.next_entry;
    WHILEND;

    nlp$get_nonexclusive_access (nlv$sm_devices.access_control);
    system_management := ^nlv$sm_devices.list^ [device_id];
    previous_subnet_attributes := ^system_management^.new_subnet_list;

    WHILE previous_subnet_attributes^ <> NIL DO

{ Verify that the new subnets being added are unique with respect to all new subnets
{ added on previous define subnet requests for the current update.

      new_subnet_attributes := subnet_attributes_list;
      WHILE new_subnet_attributes <> NIL DO
        IF new_subnet_attributes^.subnet_id = previous_subnet_attributes^^.subnet_id THEN
          duplicate_subnet := TRUE;
          nlp$release_nonexclusive_access (nlv$sm_devices.access_control);
          EXIT /verify_subnet/;
        IFEND;
        new_subnet_attributes := new_subnet_attributes^.next_entry;
      WHILEND;
      previous_subnet_attributes := ^previous_subnet_attributes^^.next_entry;
    WHILEND;

{ Add the subnet attributes.

    previous_subnet_attributes^ := subnet_attributes_list;
    nlp$release_nonexclusive_access (nlv$sm_devices.access_control);
    END /verify_subnet/;

    IF duplicate_subnet THEN
      free_subnet_list (subnet_attributes_list);
    IFEND;

  PROCEND add_subnet_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'await_query_responses' ??
?? NEWTITLE := '    release_routing_query', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to wait for the response to the routing
{   queries sent to the devices. This procedure will wait for two intervals.
{   During the first wait interval it waits for all the devices to respond.
{   Out of all the 'route known' responses received it selects the device
{   with the minimum active connection count. However, if no 'route known'
{   response is received in the first wait interval, then this procedure will
{   wait for a longer second interval. In the second wait interval it waits
{   for the first 'route known' response.

  PROCEDURE  await_query_responses (executing_taskid: ost$global_task_id;
    VAR device_list: nlt$device_list;
    VAR version_list: nlt$sm_device_version_list;
    VAR count: nlt$device_count;
    VAR status: ost$status);


    PROCEDURE release_routing_query (
           ignore_condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           ignore_sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

     VAR
       routing_query: ^nlt$sm_await_routing_query,
       previous_routing_query: ^^nlt$sm_await_routing_query;

      condition_status.normal := TRUE;
      osp$set_job_signature_lock (nlv$sm_await_routing_queries.lock);
      previous_routing_query := ^nlv$sm_await_routing_queries.await_routing_query;
      WHILE (previous_routing_query^ <> NIL) AND (previous_routing_query^^.task_id <>
           executing_taskid) DO
        previous_routing_query := ^previous_routing_query^^.next_entry;
      WHILEND;
      routing_query := previous_routing_query^;
      IF routing_query <> NIL THEN
        previous_routing_query^ := routing_query^.next_entry;
        osp$clear_job_signature_lock (nlv$sm_await_routing_queries.lock);
        FREE routing_query IN nav$network_paged_heap^;
      IFEND;

   PROCEND release_routing_query;
?? OLDTITLE, EJECT ??

    VAR
      await_routing_query: ^nlt$sm_await_routing_query,
      current_time: integer,
      expiration_time: integer,
      i: integer,
      j: integer,
      previous_await_routing_query: ^^nlt$sm_await_routing_query,
      remaining_time: integer,
      route_known: boolean,
      route_known_count: integer;

    status.normal := TRUE;
    current_time := #free_running_clock (0) DIV 1000;
    remaining_time := 500*count;
    expiration_time := current_time + remaining_time;
    osp$establish_block_exit_hndlr (^release_routing_query);

   /wait_loop/
    FOR i := 1 TO 2 DO
    WHILE remaining_time > 0 DO
      pmp$wait (remaining_time, 0);

{ Find the await routing query entry.

      count := 0;
      osp$set_job_signature_lock (nlv$sm_await_routing_queries.lock);
      previous_await_routing_query := ^nlv$sm_await_routing_queries.await_routing_query;
      WHILE (previous_await_routing_query^ <> NIL) AND (previous_await_routing_query^^.task_id <>
           executing_taskid) DO
        previous_await_routing_query := ^previous_await_routing_query^^.next_entry;
      WHILEND;
      await_routing_query := previous_await_routing_query^;

{ Check the responses to the routing queries.

      IF await_routing_query^.query_count > 0 THEN
        route_known := FALSE;
        route_known_count := 0;

        FOR j := 1 TO UPPERBOUND (await_routing_query^.device_information_list) DO
          IF await_routing_query^.device_information_list [j].route_status = nlc$sm_route_known THEN
            route_known := TRUE;
            route_known_count := route_known_count + 1;
            device_list [route_known_count] := await_routing_query^.device_information_list [j].device_id;
            version_list [route_known_count] := await_routing_query^.device_information_list [j]
                  .device_version;

{ It is the second wait interval. Select the first device that knowns the route.

            IF i = 2 THEN
              previous_await_routing_query^ := await_routing_query^.next_entry;
              osp$clear_job_signature_lock (nlv$sm_await_routing_queries.lock);
              FREE await_routing_query IN nav$network_paged_heap^;
              count := 1;
              EXIT /wait_loop/;
            IFEND;
          ELSEIF (NOT route_known) AND (await_routing_query^.device_information_list [j].route_status =
              nlc$sm_route_indeterminate) THEN
            count := count + 1;
          device_list [count] := await_routing_query^.device_information_list [j].device_id;
          version_list [count] := await_routing_query^.device_information_list [j]
                .device_version;
        IFEND;
      FOREND;

      IF await_routing_query^.response_count = await_routing_query^.query_count THEN

{ All devices have responded.

        previous_await_routing_query^ := await_routing_query^.next_entry;
        osp$clear_job_signature_lock (nlv$sm_await_routing_queries.lock);
        FREE await_routing_query IN nav$network_paged_heap^;
        IF route_known THEN
          select_device_with_min_load (route_known_count, device_list, version_list);
          count := 1;
        ELSEIF count = 0 THEN
          osp$set_status_condition ( nae$sm_route_unknown,  status);
        IFEND;
        EXIT /wait_loop/;
      ELSE { Await remaining responses
        current_time := #free_running_clock (0) DIV 1000;
        IF current_time >= expiration_time THEN
          IF i = 1 THEN

{ If the first wait interval has expired, select the device from the subset that
{ have responded with 'route known'.

            IF route_known THEN
              previous_await_routing_query^ := await_routing_query^.next_entry;
              osp$clear_job_signature_lock (nlv$sm_await_routing_queries.lock);
              FREE await_routing_query IN nav$network_paged_heap^;
              select_device_with_min_load (route_known_count, device_list, version_list);
              count := 1;
              EXIT /wait_loop/;
            IFEND;

{ If no 'route known' response has been received then wait for a longer interval for
{ the first 'route known' response.

            await_routing_query^.ready_on_route_known_response := TRUE;
            osp$clear_job_signature_lock (nlv$sm_await_routing_queries.lock);
            current_time := #free_running_clock (0) DIV 1000;

            remaining_time := 2*500*(await_routing_query^.query_count -
              await_routing_query^.response_count);
            expiration_time := current_time + remaining_time;
            CYCLE /wait_loop/;
          ELSE { Second wait interval has expired
            previous_await_routing_query^ := await_routing_query^.next_entry;
            osp$clear_job_signature_lock (nlv$sm_await_routing_queries.lock);
            FREE await_routing_query IN nav$network_paged_heap^;
            IF count = 0 THEN
              osp$set_status_condition ( nae$sm_route_unknown,  status);
            IFEND;
            EXIT /wait_loop/;
          IFEND;
        ELSE { Wait for the remaining time
          osp$clear_job_signature_lock (nlv$sm_await_routing_queries.lock);
          remaining_time := expiration_time - current_time;
        IFEND;
      IFEND;

      ELSE { query count = 0; devices went down
        previous_await_routing_query^ := await_routing_query^.next_entry;
        osp$clear_job_signature_lock (nlv$sm_await_routing_queries.lock);
        FREE await_routing_query IN nav$network_paged_heap^;
        osp$set_status_condition ( nae$sm_route_unknown,  status);
        EXIT /wait_loop/;
      IFEND;
    WHILEND;
    FOREND /wait_loop/;
    osp$disestablish_cond_handler;

  PROCEND await_query_responses;
?? OLDTITLE ??
?? NEWTITLE := 'define_device_spec_host_address', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to verify that the given device
{   specific host address is valid and is unique across all configured
{   network devices. If the address is valid and unique, it is saved
{   in the network device entry for the given device.

  PROCEDURE define_device_spec_host_address
    (    device_specific_host_address: nat$osi_network_address;
         device_id: nlt$device_identifier;
     VAR address_ok: boolean);

    VAR
      configured_device_id: nlt$device_identifier,
      current_device_address: ^nat$osi_network_address,
      current_subnet_id: ^nat$subnet_identifier,
      current_system_id: ^nat$system_identifier,
      device_address: ^nat$osi_network_address,
      prefix: ^nat$osi_network_address_prefix,
      save_device_spec_host_address: ^nat$osi_network_address,
      subnet_id: ^nat$subnet_identifier,
      system_id: ^nat$system_identifier,
      system_management_list: ^nlt$sm_device_list,
      till_subnet_id: ^string ( * ),
      unused_byte_count: 0 .. 0ff(16),
      unused_bytes: ^string ( * );

    nlp$get_exclusive_access (nlv$sm_devices.access_control);
    system_management_list := nlv$sm_devices.list;

    address_ok := #SIZE (device_specific_host_address) = system_management_list^ [device_id].
          network_address_length;
    IF address_ok THEN
      device_address := ^device_specific_host_address;
      RESET device_address;
      NEXT prefix: [#SIZE (system_management_list^ [device_id].network_address_prefix^)] IN
            device_address;
      address_ok := prefix^ = system_management_list^ [device_id].network_address_prefix^;
      IF address_ok THEN
        unused_byte_count := #SIZE (device_address^) - #SIZE (prefix^) - #SIZE (nat$subnet_identifier) -
              #SIZE (nat$system_identifier) - #SIZE (nat$network_selector);
        IF unused_byte_count > 0 THEN
          NEXT unused_bytes: [unused_byte_count] IN device_address;
        IFEND;
        NEXT subnet_id IN device_address;
        NEXT system_id IN device_address;

{ If more than one device is configured, verify that the device specific host address is not the
{ same as the generic host address.

        address_ok := NOT((UPPERBOUND (system_management_list^) > 1) AND
          (subnet_id^ = nav$host_subnet_id) AND
          (system_id^ = nap$system_id ()));
        IF address_ok THEN
      /verify_and_define/
        BEGIN
          FOR configured_device_id := LOWERBOUND (system_management_list^)
                TO UPPERBOUND (system_management_list^) DO
            IF configured_device_id <> device_id THEN
              IF (system_management_list^ [configured_device_id].state =
                    nlc$sm_initialized) AND (system_management_list^ [configured_device_id].
                    network_address_length = #SIZE (device_specific_host_address)) THEN
                current_device_address := ^system_management_list^ [configured_device_id].
                      device_specific_host_address;
                RESET current_device_address;
                NEXT till_subnet_id: [system_management_list^ [configured_device_id].network_address_length -
                      #SIZE (nat$subnet_identifier) - #SIZE (nat$system_identifier) -
                      #SIZE (nat$network_selector)] IN current_device_address;
                NEXT current_subnet_id IN current_device_address;
                NEXT current_system_id IN current_device_address;
                IF (subnet_id^ = current_subnet_id^) AND (system_id^ = current_system_id^) THEN
                  address_ok := FALSE;
                  EXIT /verify_and_define/;
                IFEND;
              IFEND;
            IFEND;
          FOREND;

          device_address := ^system_management_list^ [device_id].device_specific_host_address;
          RESET device_address;
          NEXT save_device_spec_host_address: [[REP #SIZE (device_specific_host_address) OF cell]] IN
                device_address;
          save_device_spec_host_address^ := device_specific_host_address;
        END /verify_and_define/;
      IFEND;
      IFEND;
    IFEND;

    nlp$release_exclusive_access (nlv$sm_devices.access_control);

  PROCEND define_device_spec_host_address;
?? OLDTITLE ??
?? NEWTITLE := 'delete_await_routing_query', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to delete the await routing query for
{   the specified device from the await routing queries list.
{ DESIGN:
{   The await routing queries list is locked and searched for entries for
{   the specified device. If a response has been received from the device,
{   the response is reset to route not known. If the device has not responded
{   yet, the device identifier is cleared from the entry and the query count
{   is decremented.

  PROCEDURE delete_await_routing_query
    (    device_id: iot$logical_unit);

    VAR
      await_routing_query: ^nlt$sm_await_routing_query,
      device_information_list: ^nlt$sm_device_information_list,
      i: integer,
      ignore_status: ost$status;

    osp$set_job_signature_lock (nlv$sm_await_routing_queries.lock);
    await_routing_query := nlv$sm_await_routing_queries.await_routing_query;
    WHILE await_routing_query <> NIL DO
      device_information_list := ^await_routing_query^.device_information_list;

    /search/
      FOR i := LOWERBOUND (device_information_list^) TO UPPERBOUND (device_information_list^) DO
        IF device_information_list^ [i].device_id = device_id THEN
          device_information_list^ [i].device_id := nlc$null_device_identifier;
          IF device_information_list^ [i].response_received THEN
            device_information_list^ [i].route_status := nlc$sm_route_unknown;
          ELSE { Response has not been received
            await_routing_query^.query_count := await_routing_query^.query_count - 1;
            IF await_routing_query^.query_count = await_routing_query^.response_count THEN
              pmp$ready_task (await_routing_query^.task_id, ignore_status);
            IFEND;
          IFEND;
          EXIT /search/;
        IFEND;
      FOREND /search/;
      await_routing_query := await_routing_query^.next_entry;
    WHILEND;

    osp$clear_job_signature_lock (nlv$sm_await_routing_queries.lock);

  PROCEND delete_await_routing_query;
?? OLDTITLE ??
?? NEWTITLE := 'delete_sm_connection', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to delete the system management connection id
{   from the network device attributes entry for the given device. This procedure
{   also frees the allocated structures for the given device. All the network access
{   connections are also disconnected.

  PROCEDURE delete_sm_connection
    (    device_id: nlt$device_identifier);

    VAR
      system_management: ^nlt$system_management;

    nlp$get_exclusive_access (nlv$sm_devices.access_control);
    system_management := ^nlv$sm_devices.list^ [device_id];
    system_management^.state := nlc$sm_uninitialized;
    system_management^.connection_id := nac$null_connection_id;
    system_management^.network_address_length := 0;
    system_management^.network_address_prefix := NIL;

    free_subnet_list (system_management^.subnet_list);

    IF system_management^.new_subnet_list <> NIL THEN
      free_subnet_list (system_management^.new_subnet_list);
    IFEND;
    nlp$release_exclusive_access (nlv$sm_devices.access_control);
    nlp$na_disconnect_connections (device_id);

  PROCEND delete_sm_connection;
?? OLDTITLE ??
?? NEWTITLE := 'disconnect_sm_connection', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to format and send the disconnect request
{   to the peer entity. It also deactivates the layer connection.

  PROCEDURE disconnect_sm_connection
    (    cl_connection { input, output } : ^nlt$cl_connection;
         disconnect_reason: nlt$sm_disconnect_reason);

    VAR
      data_fragments: array [1 .. 1] of nat$data_fragment,
      disconnect_data: nlt$bm_message_id,
      disconnect_pdu: nlt$sm_disconnect_request,
      ignore_status: ost$status;

    disconnect_pdu.header.kind := nlc$sm_disconnect_request;
    disconnect_pdu.header.length := #SIZE (nlt$sm_disconnect_request);
    disconnect_pdu.reason := disconnect_reason;
    data_fragments [1].address := ^disconnect_pdu;
    data_fragments [1].length := disconnect_pdu.header.length;
    nlp$bm_create_message (data_fragments, disconnect_data, ignore_status);
    nlp$cc_disconnect (cl_connection, disconnect_data, ignore_status);
    nlp$cl_deactivate_layer (nlc$osi_sys_mgmt_access_agent, cl_connection);

  PROCEND disconnect_sm_connection;
?? OLDTITLE ??
?? NEWTITLE := 'extract_subnet_attributes', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to extract the OSI subnet attributes
{   from the raw data and return a list of OSI subnet attributes to the
{   caller.

  PROCEDURE extract_subnet_attributes
    (VAR raw_data {input} : ^SEQ ( * );
     VAR subnet_attributes_list: ^nlt$subnet_attributes;
     VAR pdu_ok: boolean);

    VAR
      calculated_size: integer,
      fixed_subnet_attributes: ^nlt$sm_fixed_subnet_attributes,
      previous_subnet_attributes: ^^nlt$subnet_attributes,
      quality_of_service: ^nlt$quality_of_service,
      raw_multicast_address: ^SEQ ( * ),
      subnet_attributes: ^nlt$subnet_attributes;

    pdu_ok := TRUE;
    calculated_size := 0;
    subnet_attributes_list := NIL;
    previous_subnet_attributes := ^subnet_attributes_list;

  /extract/
    BEGIN

      REPEAT
        NEXT fixed_subnet_attributes IN raw_data;
        IF fixed_subnet_attributes <> NIL THEN
          REPEAT
            ALLOCATE subnet_attributes IN nav$network_paged_heap^;
            IF subnet_attributes = NIL THEN
              syp$cycle;
            IFEND;
          UNTIL subnet_attributes <> NIL;
          subnet_attributes^.next_entry := NIL;
          subnet_attributes^.subnet_id := fixed_subnet_attributes^.subnet_id;
          subnet_attributes^.multicast_address := NIL;
          subnet_attributes^.quality_of_service := NIL;
          subnet_attributes^.directly_connected := fixed_subnet_attributes^.directly_connected;
          IF subnet_attributes^.directly_connected THEN
            subnet_attributes^.subnet_status := fixed_subnet_attributes^.subnet_status;
            subnet_attributes^.subnet_type := fixed_subnet_attributes^.subnet_type;
            subnet_attributes^.max_link_sdu_size := fixed_subnet_attributes^.max_link_sdu_size;
          IFEND;

          calculated_size := calculated_size + #SIZE (fixed_subnet_attributes^);
          previous_subnet_attributes^ := subnet_attributes;
          previous_subnet_attributes := ^subnet_attributes^.next_entry;

{ Extract the multicast address if present.

          IF fixed_subnet_attributes^.multicast_address_length > 0 THEN
            NEXT raw_multicast_address: [[REP fixed_subnet_attributes^.multicast_address_length OF cell]] IN
                  raw_data;
            IF raw_multicast_address = NIL THEN
              pdu_ok := FALSE;
              EXIT /extract/;
            IFEND;
            REPEAT
              ALLOCATE subnet_attributes^.multicast_address: [[REP fixed_subnet_attributes^.
                    multicast_address_length OF cell]] IN nav$network_paged_heap^;
              IF subnet_attributes^.multicast_address = NIL THEN
                syp$cycle;
              IFEND;
            UNTIL subnet_attributes^.multicast_address <> NIL;
            subnet_attributes^.multicast_address^ := raw_multicast_address^;
            calculated_size := calculated_size + fixed_subnet_attributes^.multicast_address_length;
          IFEND;

{ Extract and save the quality of service record if present.

          IF fixed_subnet_attributes^.quality_of_service_size > 0 THEN
            NEXT quality_of_service: [[REP fixed_subnet_attributes^.quality_of_service_size OF cell]] IN
                  raw_data;
            IF quality_of_service = NIL THEN
              pdu_ok := FALSE;
              EXIT /extract/;
            IFEND;
            REPEAT
              ALLOCATE subnet_attributes^.quality_of_service: [[REP fixed_subnet_attributes^.
                    quality_of_service_size OF cell]] IN nav$network_paged_heap^;
              IF subnet_attributes^.quality_of_service = NIL THEN
                syp$cycle;
              IFEND;
            UNTIL subnet_attributes^.quality_of_service <> NIL;
            subnet_attributes^.quality_of_service^ := quality_of_service^;
            calculated_size := calculated_size + fixed_subnet_attributes^.quality_of_service_size;
          IFEND;
        IFEND;
      UNTIL fixed_subnet_attributes = NIL;

      pdu_ok := (calculated_size = #SIZE (raw_data^)) AND (subnet_attributes_list <> NIL);
    END /extract/;

    IF NOT pdu_ok THEN
      free_subnet_list (subnet_attributes_list);
    IFEND;

  PROCEND extract_subnet_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'free_subnet_list', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to free the given subnet
{   attributes list.
{ NOTES:
{   If the subnet attributes list is linked off of the network
{   device list, it is assumed that the network device list has
{   been locked by the caller.

  PROCEDURE free_subnet_list
    (VAR subnet_attributes_list: ^nlt$subnet_attributes);

    VAR
      subnet_attributes: ^nlt$subnet_attributes;

    WHILE subnet_attributes_list <> NIL DO
      IF subnet_attributes_list^.multicast_address <> NIL THEN
        FREE subnet_attributes_list^.multicast_address IN nav$network_paged_heap^;
      IFEND;
      IF subnet_attributes_list^.quality_of_service <> NIL THEN
        FREE subnet_attributes_list^.quality_of_service IN nav$network_paged_heap^;
      IFEND;
      subnet_attributes := subnet_attributes_list;
      subnet_attributes_list := subnet_attributes_list^.next_entry;
      FREE subnet_attributes IN nav$network_paged_heap^;
    WHILEND;

  PROCEND free_subnet_list;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_sm_connections_and_devices', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to return the System Management connection
{   and device identifiers of all the configured network devices.
{ DESIGN:
{   This procedure searches the configured network device list with a non
{   exclusive lock.

  PROCEDURE [INLINE] get_sm_connections_and_devices
    (    required_protocol_class: sm_protocol_class_set,
         min_required_version: nlt$sm_version;
     VAR sm_connection_ids: array [1 .. * ] of nlt$cl_connection_id;
     VAR device_list: nlt$device_list;
     VAR version_list: nlt$sm_device_version_list;
     VAR count: nlt$device_count);

    VAR
      device: nlt$device_identifier,
      system_management_list: ^nlt$sm_device_list;

    nlp$get_nonexclusive_access (nlv$sm_devices.access_control);
    system_management_list := nlv$sm_devices.list;
    count := 0;

    FOR device := LOWERBOUND (system_management_list^) TO UPPERBOUND (system_management_list^) DO
      IF (system_management_list^ [device].state = nlc$sm_initialized) AND
         (system_management_list^ [device].device_version >= min_required_version) AND
         (system_management_list^ [device].supported_protocol_class IN required_protocol_class) THEN
        count := count + 1;
        sm_connection_ids [count] := system_management_list^ [device].connection_id;
        device_list [count] := device;
        version_list [count] := system_management_list^ [device].device_version;
      IFEND;
    FOREND;

    nlp$release_nonexclusive_access (nlv$sm_devices.access_control);

  PROCEND get_sm_connections_and_devices;
?? OLDTITLE ??
?? NEWTITLE := 'match_prefix', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to return the list of devices that support
{   the prefix and the preferred protocol class in the given OSI network address.
{ DESIGN:
{   The prefix in the give OSI network address is extracted and matched with
{   prefix configured in each device. A list of the identifiers of the devices
{   with matching prefixes and which support the preferred protocol class is
{   returned to the caller. However, if a match is not found, the prefix is
{   compared with the default prefix. If it matches the default prefix, then the
{   identifiers of all the devices is returned.  If no match is found, the
{   destination is not reachable.
{ NOTES:
{   The network device list must be locked by the caller for non exclusive
{   access.

  PROCEDURE match_prefix
    (    network_address: nat$osi_network_address;
         required_protocol_class: sm_protocol_class_set;
         min_required_version: nlt$sm_version;
     VAR device_list: nlt$device_list;
     VAR version_list: nlt$sm_device_version_list;
     VAR connection_list: array [1 .. *] of nlt$cl_connection_id;
     VAR count: nlt$device_count);

    VAR
      device_id: nlt$device_identifier,
      ignore_status: ost$status,
      network_address_seq: ^nat$osi_network_address,
      next_device: nlt$device_count,
      prefix: ^nat$osi_network_address_prefix,
      system_management_list: ^nlt$sm_device_list;

    next_device := LOWERBOUND (device_list);
    count := 0;
    network_address_seq := ^network_address;
    system_management_list := nlv$sm_devices.list;

    FOR device_id := LOWERBOUND (system_management_list^) TO UPPERBOUND (system_management_list^) DO
      IF (system_management_list^ [device_id].state = nlc$sm_initialized) AND
            (system_management_list^ [device_id].network_address_length =
            #SIZE (network_address)) THEN
        RESET network_address_seq;
        NEXT prefix: [#SIZE (system_management_list^ [device_id].network_address_prefix^)] IN
              network_address_seq;
        IF (prefix^ = system_management_list^ [device_id].network_address_prefix^) AND
           (system_management_list^ [device_id].device_version >= min_required_version) AND
           (system_management_list^ [device_id].supported_protocol_class IN required_protocol_class) THEN
          device_list [next_device] := device_id;
          version_list [next_device] := system_management_list^ [device_id].device_version;
          connection_list [next_device] := system_management_list^ [device_id].connection_id;
          count := count + 1;
          next_device := next_device + 1;
        IFEND;
      IFEND;
    FOREND;

    IF count = 0 THEN

{ Compare the prefix against the default prefix. If it matches the default prefix
{ return the device identifiers of all the available devices.

    IFEND;

  PROCEND match_prefix;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'poll_devices_for_routing_info', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to send the routing queries to all the
{   configured devices and to await the responses from the devices.

  PROCEDURE poll_devices_for_routing_info
    (    destination_address: nat$osi_network_address;
         connection_list: array [1 .. * ] of nlt$cl_connection_id;
     VAR device_list { input, output } : nlt$device_list;
     VAR version_list { input, output } : nlt$sm_device_version_list;
     VAR count { input, output } : nlt$device_count;
     VAR status: ost$status);

    VAR
      actual: integer,
      await_routing_query: ^nlt$sm_await_routing_query,
      cl_connection: ^nlt$cl_connection,
      connection: ^nlt$sm_layer_connection,
      connection_exists: boolean,
      data: nlt$bm_message_id,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      dest_accessible_request_pdu: ^nlt$sm_dest_accessible_request,
      destination_address_contents: ^nat$osi_network_address,
      destination_address_seq: ^SEQ ( * ),
      executing_taskid: ost$global_task_id,
      i: integer,
      layer_active: boolean,
      previous_await_routing_query: ^^nlt$sm_await_routing_query,
      query_count: nlt$device_count,
      query_sent: boolean;

    status.normal := TRUE;

    pmp$get_executing_task_gtid (executing_taskid);
    PUSH dest_accessible_request_pdu: [[REP #SIZE (destination_address) OF
          cell]];
    dest_accessible_request_pdu^.header.kind := nlc$sm_dest_accessible_request;
    dest_accessible_request_pdu^.header.length :=
          #SIZE (dest_accessible_request_pdu^);
    dest_accessible_request_pdu^.destination_address := destination_address;
    dest_accessible_request_pdu^.request_id := executing_taskid.index;
    data_fragment [1].address := dest_accessible_request_pdu;
    data_fragment [1].length := dest_accessible_request_pdu^.header.length;

{ Poll the devices for routing information.

    ALLOCATE await_routing_query: [1 .. count] IN nav$network_paged_heap^;
    IF await_routing_query <> NIL THEN

{ Initialize await routing query.

      await_routing_query^.request_id := executing_taskid.index;
      await_routing_query^.task_id := executing_taskid;
      await_routing_query^.next_entry := NIL;
      await_routing_query^.ready_on_route_known_response := FALSE;
      await_routing_query^.response_count := 0;

{ **** DEBUG BEGIN.
{ The following lines of code must be deleted after JIT.
{ The destination_address does not have to be saved in the await_routing_query.

      destination_address_seq := ^await_routing_query^.destination_address;
      RESET destination_address_seq;
      NEXT destination_address_contents: [[REP #SIZE (destination_address) OF
            cell]] IN destination_address_seq;
      destination_address_contents^ := destination_address;

{ **** DEBUG END.

      await_routing_query^.query_count := count;
      FOR i := 1 TO count DO
        await_routing_query^.device_information_list [i].device_id := device_list [i];
        await_routing_query^.device_information_list [i].device_version := version_list [i];
        await_routing_query^.device_information_list [i].route_status := nlc$sm_route_unknown;
        await_routing_query^.device_information_list [i].response_received := FALSE;
      FOREND;

{ Add the entry to the end of the await routing queries list.

      osp$set_job_signature_lock (nlv$sm_await_routing_queries.lock);
      previous_await_routing_query := ^nlv$sm_await_routing_queries.
            await_routing_query;
      WHILE previous_await_routing_query^ <> NIL DO
        previous_await_routing_query := ^previous_await_routing_query^^.
              next_entry;
      WHILEND;
      previous_await_routing_query^ := await_routing_query;
      osp$clear_job_signature_lock (nlv$sm_await_routing_queries.lock);

{ Send the routing queries.

      query_count := 0;
      FOR i := 1 TO count DO
        query_sent := FALSE;
        nlp$cl_get_exclusive_via_cid (connection_list [i], connection_exists,
              cl_connection);
        IF connection_exists THEN
          nlp$cl_get_layer_connection (nlc$osi_sys_mgmt_access_agent,
                cl_connection, layer_active, connection);
          IF (layer_active) AND (connection^.state >= nlc$sm_open) THEN
            query_sent := TRUE;
            query_count := query_count + 1;
            nlp$bm_create_message (data_fragment, data, {ignore} status);
            nlp$cc_send_data (cl_connection, data, {ignore} status);
          IFEND;
          nlp$cl_release_exclusive_access (cl_connection);
        IFEND;

        IF NOT query_sent THEN
          osp$set_job_signature_lock (nlv$sm_await_routing_queries.lock);
          await_routing_query := nlv$sm_await_routing_queries.
                await_routing_query;
          WHILE await_routing_query^.task_id <> executing_taskid DO
            await_routing_query := await_routing_query^.next_entry;
          WHILEND;

{ Update the device id in device information list. Note that the device could
{ have gone down in the mean time.

          IF await_routing_query^.device_information_list [i].device_id <>
                0 THEN
            await_routing_query^.device_information_list [i].device_id :=
                  nlc$null_device_identifier;
            await_routing_query^.query_count :=
                  await_routing_query^.query_count - 1;
          IFEND;
          osp$clear_job_signature_lock (nlv$sm_await_routing_queries.lock);
        IFEND;
      FOREND;

      IF query_count > 0 THEN

{! statistics begin

        IF nav$statistics_enabled THEN
          osp$add_to_locked_variable (nav$global_osi_statistics.system_management_entity.
                device_routing_queries, 0, query_count, actual);
        IFEND;

{! statistics end

        await_query_responses (executing_taskid, device_list,
          version_list, count, status);
      ELSE { Devices are inaccessible, remove the routing query from the list
        osp$set_job_signature_lock (nlv$sm_await_routing_queries.lock);
        previous_await_routing_query := ^nlv$sm_await_routing_queries.
              await_routing_query;
        WHILE (previous_await_routing_query^ <> NIL) AND
              (previous_await_routing_query^^.task_id <> executing_taskid) DO
          previous_await_routing_query := ^previous_await_routing_query^^.
                next_entry;
        WHILEND;
        await_routing_query := previous_await_routing_query^;
        previous_await_routing_query^ := await_routing_query^.next_entry;
        osp$clear_job_signature_lock (nlv$sm_await_routing_queries.lock);
        FREE await_routing_query IN nav$network_paged_heap^;
        osp$set_status_condition ( nae$sm_devices_inaccessible,
               status);
      IFEND;
    ELSE { Heap full
      osp$set_status_condition ( nae$insufficient_resources,
            status);
    IFEND;

  PROCEND poll_devices_for_routing_info;
?? OLDTITLE ??
?? NEWTITLE := 'select_device', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to return the identifier of the device
{   with the best path to the given subnet.
{ DESIGN:
{   This procedure searches the subnet attributes associated with the given
{   network devices for the given subnet id. If more than one device has
{   a path to the given subnet, this procedure attempts to load level the
{   traffic across the directly connected devices by selecting the device
{   with minimum active connections.
{ NOTES:
{   Whenever the quality of service attribute is defined, this code must be
{   changed to examine this attribute to determine the best path to the given
{   subnet. The network device list must be locked by the caller for non
{   exclusive access.

  PROCEDURE select_device
    (    subnet_id: nat$subnet_identifier;
         system_id: nat$system_identifier;
     VAR device_list { input, output } : nlt$device_list;
     VAR version_list { input, output } : nlt$sm_device_version_list;
     VAR count {input,output} : nlt$device_count;
     VAR status: sm_device_selection_status);

    VAR
      actual_count: integer,
      compare_swap_status: osc$cs_successful .. osc$cs_variable_locked,
      device_id: nlt$device_identifier,
      device_selected: boolean,
      i: integer,
      new_count: integer,
      old_count: integer,
      selected_device: nlt$device_identifier,
      selected_version: nlt$sm_version,
      selection_count: integer,
      subnet_attributes: ^nlt$subnet_attributes,
      subnet_known: boolean,
      system_management_list: ^nlt$sm_device_list;

    subnet_known := FALSE;
    system_management_list := nlv$sm_devices.list;
    device_selected := FALSE;

{   Check to see whether the device is directly connected.  If so, select this device.

    nlp$get_nonexclusive_access (nlv$configured_network_devices.access_control);

    /match_system_id/
    FOR i:=1 to count DO
      device_id := device_list [i];
      IF (nlv$configured_network_devices.network_device_list^ [device_id].path_status = nlc$path_available)
         AND (nlv$configured_network_devices.network_device_list^ [device_id].system_id = system_id) THEN
        device_selected := TRUE;
        selected_device := device_id;
        selected_version := system_management_list^ [device_id].device_version;
        EXIT /match_system_id/
      IFEND;

    FOREND /match_system_id/;

    nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);

    IF NOT device_selected THEN
    /main_loop/
      FOR i := 1 TO count DO
        device_id := device_list [i];

{ Search for a matching subnet attributes entry.

        subnet_attributes := system_management_list^ [device_id].subnet_list;
        WHILE (subnet_attributes <> NIL) AND (subnet_attributes^.subnet_id <> subnet_id) DO
          subnet_attributes := subnet_attributes^.next_entry;
        WHILEND;

{ Note: This code needs to be changed to evaluate the QOS attribute associated with
{       the subnet attributes entry to determine the best path to the given destination
{       address. At present, this code selects the device with the least number of
{       active connections.

        IF (subnet_attributes <> NIL) THEN
          subnet_known := TRUE;
          IF ((subnet_attributes^.directly_connected) AND (subnet_attributes^.subnet_status = nlc$subnet_up))
                OR (NOT subnet_attributes^.directly_connected) THEN

{ Retrieve the selection count.

            old_count := 0;
            new_count := old_count;
            REPEAT
              #COMPARE_SWAP (system_management_list^ [device_id].active_connection_count,
                    old_count, new_count, actual_count, compare_swap_status);
            UNTIL compare_swap_status <> osc$cs_variable_locked;

            IF (NOT device_selected) OR ((device_selected) AND (actual_count < selection_count)) THEN
              selected_device := device_list [i];
              selected_version := version_list [i];
              selection_count := actual_count;
            IFEND;
            device_selected := TRUE;
          IFEND;
        IFEND;
      FOREND /main_loop/;
    IFEND;

    IF device_selected THEN
      count := 1;
      device_list [1] := selected_device;
      version_list [1] := selected_version;
      status := sm_route_known;
    ELSE
      IF subnet_known THEN
        status := sm_route_unknown;
      ELSE
        status := sm_subnet_unknown;
      IFEND;
    IFEND;

  PROCEND select_device;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] select_device_with_min_load', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to select from the given list of devices, the
{   device with the least no of active connections.

  PROCEDURE [INLINE] select_device_with_min_load (count: nlt$device_count;
    VAR device_list { input, output } : nlt$device_list;
    VAR version_list { input, output } : nlt$sm_device_version_list);

    VAR
      active_connection_count: integer,
      actual_count: integer,
      compare_swap_status: osc$cs_successful .. osc$cs_variable_locked,
      j: integer,
      new_count: integer,
      old_count: integer,
      selected_device: nlt$device_identifier,
      selected_version: nlt$sm_version,
      system_management_list: ^nlt$sm_device_list;

    IF count > 1 THEN

{ Select the device with minimum active connections.

      nlp$get_nonexclusive_access (nlv$sm_devices.access_control);
      system_management_list := nlv$sm_devices.list;
      FOR j := 1 TO count DO
        old_count := 0;
        REPEAT
          new_count := old_count;
          #COMPARE_SWAP (system_management_list^ [device_list[j]].active_connection_count,
                old_count, new_count, actual_count, compare_swap_status);
        UNTIL compare_swap_status <> osc$cs_variable_locked;

        IF (j = 1) OR (actual_count < active_connection_count) THEN
          selected_device := device_list [j];
          selected_version := version_list [j];
          active_connection_count := actual_count;
        IFEND;
      FOREND;

      nlp$release_nonexclusive_access (nlv$sm_devices.access_control);
      device_list [1] := selected_device;
      version_list [1] := selected_version;
    IFEND;

  PROCEND select_device_with_min_load;
?? OLDTITLE ??
MODEND nlm$system_mgmt_access_agent;
*DECK DECK=NLM$TCPIP_MGMT_ACCESS_AGENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE NETWORK ACCESS: TCP/IP Management Access Agent' ??
MODULE nlm$tcpip_mgmt_access_agent;

{ PURPOSE:
{   This module contains procedures neccesary to communicate with the TCP/IP Management Access
{   Provider (TMAP) in the TCP/IP communications device. These procedures provide the TCP/IP
{   Management Access Agent (TMAA) in the host.
{ DESIGN:
{   The TMAA and the TMAP communicate over a channel connection. After a device is loaded,
{   the TMAP initiates the channel connection connect request. The TMAA and the TMAP exchange
{   initialization information over the channel connection.
{   TMAA initialization begins with a CC connect indication - a negotiate protocol request - from
{   TMAP.  TMAA responds with a CC connect confirm - a negotiate protocol response.  After the
{   device receives the confirm the CC connection is established and all subsequent requests
{   will use the CC data service with the exception of breaking the connection which uses a
{   a CC disconnect request.  Once the connection is established TMAP sends a device configure
{   request which contains the local device IP address and which protocol(s), TCP and/or UDP, are
{   supported.  TMAA responds with a device confirm.  After the initialization of the
{   TMAA/TMAP is complete, the TMAA will allow the users in the host to obtain routing
{   information and will also process subnet available indications from the TMAP.
{   Any protocol errors encountered will result in disconnecting the channel connection.
{
{   The XDCL'd procedures have been grouped in alphabetical order followed by the internal
{   procedures. The internal procedures are also in alphabetical order.
{
{   The following Finite
{   State Machine describes the states and the associated events. Please refer to the TCP/IP
{   Management Access Agent Protocol Specification (A8551),the TCP/IP Management Access
{   Provider Protocol Specification (A8552), and TCP/IP Host Routing DAP (A8608) for more
{   information.
{
{   This module contains code that executes in ring 3. It resides on OSF$JOB_TEMPLATE_23D.
{
{ NOTES:
{   The following abreviations have been used in this module.
{        ID  = Identifier
{        IP  = Internet Protocol
{        PDU = Protocol Data Unit
{        TCP = Transport Class Protocol
{        UDP = User Datagram Protocol

?? NEWTITLE := 'Finite State Machine', EJECT ??

{ It was decided by GSA that host routing would always be enabled.

{----------------+----------------+----------------+----------------+----------------+
{                |     (a)        |     (b)        |     (d)        |     (e)        |
{                | nlc$tm_closed  | nlc$tm_        | nlc$tm_        | nlc$tm_closed  |
{                |  (initial)     | configuration_ | enable_host_   |                |
{                |                | ind_wait       | routing        |                |
{----------------+----------------+----------------+----------------+----------------+
{                |                |                |                |                |
{ CC connect     |     (1)        |                |                |                |
{   indication   |     a->b       |      -         |      -         |      -         |
{ nlc$tm_        |                |                |                |                |
{ negotiate_     |                |                |                |                |
{ protocol_req   |                |                |                |                |
{----------------+----------------+----------------+----------------+----------------+
{                |                |                |                |                |
{ CC disconnect  |                |     (5)        |     (21)       |                |
{   indication   |      -         |     b->e       |     d->e       |      -         |
{                |                |                |                |                |
{                |                |                |                |                |
{                |                |                |                |                |
{----------------+----------------+----------------+----------------+----------------+
{ NOT host       |                |                |                |                |
{ routing enabled|                |                |                |                |
{ CC data        |                |     (6)        |     (20)       |                |
{   indication   |      -         |     b->c       |     d->e       |      -         |
{ nlc$tm_        |                |                |                |                |
{ device_config_ |                |                |                |                |
{ req            |                |                |                |                |
{----------------+----------------+----------------+----------------+----------------+
{     host       |                |                |                |                |
{ routing enabled|                |                |                |                |
{ CC data        |                |     (6)        |     (20)       |                |
{   indication   |      -         |     b->d       |     d->e       |      -         |
{ nlc$tm_        |                |                |                |                |
{ device_config_ |                |                |                |                |
{ req            |                |                |                |                |
{----------------+----------------+----------------+----------------+----------------+
{                |                |                |                |                |
{ CC data        |                |                |                |                |
{   indication   |                |     (7)        |     (15)       |                |
{ nlc$tm_        |      -         |     b->e       |     d->d       |      -         |
{ address_       |                |                |                |                |
{ accessible_res |                |                |                |                |
{----------------+----------------+----------------+----------------+----------------+
{                |                |                |                |                |
{ CC data        |                |                |                |                |
{   indication   |                |     (7)        |     (16)       |                |
{ nlc$tm_        |      -         |     b->e       |     d->d       |      -         |
{ subnet_        |                |                |                |                |
{ available_ind  |                |                |                |                |
{----------------+----------------+----------------+----------------+----------------+
{                |                |                |                |                |
{ CC data        |                |                |                |                |
{   indication   |                |     (7)        |     (17)       |                |
{ nlc$tm_        |      -         |     b->e       |     d->d       |      -         |
{ subnet_        |                |                |                |                |
{ unavailable_ind|                |                |                |                |
{----------------+----------------+----------------+----------------+----------------+
{                |                |                |                |                |
{ CC data        |                |                |                |                |
{   indication   |                |     (7)        |     (18)       |                |
{ nlc$tm_        |      -         |     b->e       |     d->d       |      -         |
{ route_         |                |                |                |                |
{ unavailable_ind|                |                |                |                |
{----------------+----------------+----------------+----------------+----------------+

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nae$tcpip_mgmt_condition_codes
*copyc nlt$cc_interface
*copyc nlt$device_ids
*copyc nlt$device_list
*copyc nlt$tm_connection
*copyc nlt$tm_device_list
*copyc nlt$tm_pdu
*copyc nlt$tm_protocol
*copyc nlt$tm_static_route_definitions
*copyc ofe$error_codes
*copyc ost$status
?? POP ??

*copyc avp$configuration_administrator
*copyc avp$system_displays
*copyc nap$display_message
*copyc nap$namve_system_error
*copyc nlp$bm_create_message
*copyc nlp$bm_extract_message_prefix
*copyc nlp$bm_flush_message
*copyc nlp$bm_get_message_length
*copyc nlp$bm_release_message
*copyc nlp$cc_accept_connection
*copyc nlp$cc_disconnect
*copyc nlp$cc_initialize_template
*copyc nlp$cc_send_data_fragments
*copyc nlp$cl_activate_layer
*copyc nlp$cl_activate_receiver
*copyc nlp$cl_deactivate_layer
*copyc nlp$cl_get_exclusive_via_cid
*copyc nlp$cl_get_layer_connection
*copyc nlp$cl_initialize_template
*copyc nlp$cl_release_exclusive_access
*copyc nlp$get_exclusive_access
*copyc nlp$get_nonexclusive_access
*copyc nlp$release_exclusive_access
*copyc nlp$release_nonexclusive_access
*copyc nlp$sk_tcp_device_available
*copyc nlp$udp_device_available
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$clear_job_signature_lock
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$get_executing_task_gtid
*copyc pmp$log_ascii
*copyc pmp$ready_task
*copyc pmp$wait
*copyc syp$cycle
*copyc nav$network_paged_heap
*copyc nav$sk_socket_layer_active
*copyc nlv$configured_network_devices
*copyc nlv$tm_address_accessible
*copyc nlv$tm_device_configuration
*copyc nlv$tm_host
*copyc nlv$tm_route_cache
*copyc nlv$tm_static_routing_table
*copyc nlv$tm_subnet_list
*copyc oss$job_paged_literal

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    one_minute = 60000, { Milliseconds
    ten_minutes = 600000, { Milliseconds
    mics_to_mills = 1024, { approximate conversion to milliseconds - faster than using 1000
    nlc$tm_version = 1;

  TYPE
    local_route_cost = 0 .. nlc$tm_maximum_route_cost + 1;

  VAR
    initial_connection: nlt$tm_connection := [ * , nlc$tm_closed, nlc$tm_version],
    nlv$log_tcpip_device_select: [XREF] boolean,
    nlv$tm_class_a_network_mask: 0 .. 0ffffffff(16) := 0ff000000(16),
    nlv$tm_class_b_network_mask: 0 .. 0ffffffff(16) := 0ffff0000(16),
    nlv$tm_class_c_network_mask: 0 .. 0ffffffff(16) := 0ffffff00(16),

{ PURPOSE:
{   This variable is initialized to its index's mirror image.  For example,
{   01(16) or 00000001(2) has a mirror image of 80(16) or 10000000(2), 83(16)
{   or 10000011(2) has a mirror image of C1(16) or 11000001(2).

    inverse_table: [READ, oss$job_paged_literal] array [0 .. 0ff(16)] of 0 .. 0ff(16) := [
?? FMT (FORMAT := OFF) ??
{ 00(16)} 00(16), 80(16), 40(16), 0C0(16), 20(16), 0A0(16), 60(16), 0E0(16),
          10(16), 90(16), 50(16), 0D0(16), 30(16), 0B0(16), 70(16), 0F0(16),
{ 10(16)} 08(16), 88(16), 48(16), 0C8(16), 28(16), 0A8(16), 68(16), 0E8(16),
          18(16), 98(16), 58(16), 0D8(16), 38(16), 0B8(16), 78(16), 0F8(16),
{ 20(16)} 04(16), 84(16), 44(16), 0C4(16), 24(16), 0A4(16), 64(16), 0E4(16),
          14(16), 94(16), 54(16), 0D4(16), 34(16), 0B4(16), 74(16), 0F4(16),
{ 30(16)} 0C(16), 8C(16), 4C(16), 0CC(16), 2C(16), 0AC(16), 6C(16), 0EC(16),
          1C(16), 9C(16), 5C(16), 0DC(16), 3C(16), 0BC(16), 7C(16), 0FC(16),
{ 40(16)} 02(16), 82(16), 42(16), 0C2(16), 22(16), 0A2(16), 62(16), 0E2(16),
          12(16), 92(16), 52(16), 0D2(16), 32(16), 0B2(16), 72(16), 0F2(16),
{ 50(16)} 0A(16), 8A(16), 4A(16), 0CA(16), 2A(16), 0AA(16), 6A(16), 0EA(16),
          1A(16), 9A(16), 5A(16), 0DA(16), 3A(16), 0BA(16), 7A(16), 0FA(16),
{ 60(16)} 06(16), 86(16), 46(16), 0C6(16), 26(16), 0A6(16), 66(16), 0E6(16),
          16(16), 96(16), 56(16), 0D6(16), 36(16), 0B6(16), 76(16), 0F6(16),
{ 70(16)} 0E(16), 8E(16), 4E(16), 0CE(16), 2E(16), 0AE(16), 6E(16), 0EE(16),
          1E(16), 9E(16), 5E(16), 0DE(16), 3E(16), 0BE(16), 7E(16), 0FE(16),
{ 80(16)} 01(16), 81(16), 41(16), 0C1(16), 21(16), 0A1(16), 61(16), 0E1(16),
          11(16), 91(16), 51(16), 0D1(16), 31(16), 0B1(16), 71(16), 0F1(16),
{ 90(16)} 09(16), 89(16), 49(16), 0C9(16), 29(16), 0A9(16), 69(16), 0E9(16),
          19(16), 99(16), 59(16), 0D9(16), 39(16), 0B9(16), 79(16), 0F9(16),
{ A0(16)} 05(16), 85(16), 45(16), 0C5(16), 25(16), 0A5(16), 65(16), 0E5(16),
          15(16), 95(16), 55(16), 0D5(16), 35(16), 0B5(16), 75(16), 0F5(16),
{ B0(16)} 0D(16), 8D(16), 4D(16), 0CD(16), 2D(16), 0AD(16), 6D(16), 0ED(16),
          1D(16), 9D(16), 5D(16), 0DD(16), 3D(16), 0BD(16), 7D(16), 0FD(16),
{ C0(16)} 03(16), 83(16), 43(16), 0C3(16), 23(16), 0A3(16), 63(16), 0E3(16),
          13(16), 93(16), 53(16), 0D3(16), 33(16), 0B3(16), 73(16), 0F3(16),
{ D0(16)} 0B(16), 8B(16), 4B(16), 0CB(16), 2B(16), 0AB(16), 6B(16), 0EB(16),
          1B(16), 9B(16), 5B(16), 0DB(16), 3B(16), 0BB(16), 7B(16), 0FB(16),
{ E0(16)} 07(16), 87(16), 47(16), 0C7(16), 27(16), 0A7(16), 67(16), 0E7(16),
          17(16), 97(16), 57(16), 0D7(16), 37(16), 0B7(16), 77(16), 0F7(16),
{ F0(16)} 0F(16), 8F(16), 4F(16), 0CF(16), 2F(16), 0AF(16), 6F(16), 0EF(16),
          1F(16), 9F(16), 5F(16), 0DF(16), 3F(16), 0BF(16), 7F(16), 0FF(16)];

?? FMT (FORMAT := ON) ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tm_connect_event_processor' ??
?? NEWTITLE := '  disconnect', EJECT ??
*copy nlh$tm_connect_event_processor

  PROCEDURE [XDCL] nlp$tm_connect_event_processor
    (    cl_connection { input, output } : ^nlt$cl_connection;
         event { input, output } : nlt$cc_event;
     VAR inventory_report: integer);


    PROCEDURE disconnect
      (    disconnect_reason: nlt$tm_release_reason);

      VAR
        data_fragment: array [1 .. 1] of nat$data_fragment,
        message_id: nlt$bm_message_id,
        release_pdu: nlt$tm_release_request;

      release_pdu.header.kind := nlc$tm_release_request;
      release_pdu.header.length := #SIZE (nlt$tm_release_request);
      release_pdu.reason := disconnect_reason;
      data_fragment [1].address := ^release_pdu;
      data_fragment [1].length := release_pdu.header.length;
      nlp$bm_create_message (data_fragment, message_id, {ignore} status);
      nlp$cc_disconnect (cl_connection, message_id, {ignore} status);
    PROCEND disconnect;
?? OLDTITLE, EJECT ??

    VAR
      connection: ^nlt$tm_connection,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      data_length: integer,
      layer_active: boolean,
      message_id: nlt$bm_message_id,
      negotiate_protocol_req_pdu: nlt$tm_negotiate_protocol_req,
      negotiate_protocol_res_pdu: nlt$tm_negotiate_protocol_res,
      status: ost$status;

    inventory_report := 0;

    IF event.kind = nlc$cc_connect_event THEN
      message_id := event.connect.data;

{ FSM #1.

      IF nlv$tm_host.name_length > 0 THEN
        nlp$bm_get_message_length (message_id, data_length);
        IF data_length = #SIZE (nlt$tm_negotiate_protocol_req) THEN
          data_fragment [1].address := ^negotiate_protocol_req_pdu;
          data_fragment [1].length := #SIZE (nlt$tm_negotiate_protocol_req);
          nlp$bm_flush_message (data_fragment, message_id, data_length, status);
          IF status.normal THEN
            IF negotiate_protocol_req_pdu.header.kind = nlc$tm_negotiate_protocol_req THEN
              negotiate_protocol_res_pdu.header.kind := nlc$tm_negotiate_protocol_res;
              negotiate_protocol_res_pdu.header.length := #SIZE (nlt$tm_negotiate_protocol_res);
              negotiate_protocol_res_pdu.version := nlc$tm_version;
              data_fragment [1].address := ^negotiate_protocol_res_pdu;
              data_fragment [1].length := negotiate_protocol_res_pdu.header.length;
              nlp$bm_create_message (data_fragment, message_id, {ignore} status);
              nlp$cc_accept_connection (cl_connection, event.connect.class, message_id, {ignore} status);
              nlp$cl_activate_layer (nlc$tcpip_mgmt_access_agent, cl_connection);
              nlp$cl_get_layer_connection (nlc$tcpip_mgmt_access_agent, cl_connection, {ignore} layer_active,
                    connection);
              connection^.device_id := event.connect.device_id;
              connection^.state := nlc$tm_configuration_ind_wait;
              connection^.version := negotiate_protocol_res_pdu.version;

{ Activate receiver so that all events are received in the current task.

              nlp$cl_activate_receiver (cl_connection);
            ELSE { Pdu.kind <> nlc$tm_negotiate_protocol_req
              disconnect (nlc$tm_invalid_encoding);
            IFEND;
          ELSE { The incoming pdu contains extra bytes of data.
            nlp$bm_release_message (message_id);
            disconnect (nlc$tm_header_length_incorrect);
          IFEND;
        ELSE { The pdu was incorrect.
          nlp$bm_release_message (message_id);
          disconnect (nlc$tm_header_indicernible);
        IFEND;
      ELSE { TCP/IP has not been configured.
        osp$set_status_abnormal (nac$status_id, nae$tm_tcpip_not_configured,
              nlv$configured_network_devices.network_device_list^ [event.connect.device_id].element, status);
        nap$display_message (status);
        nlp$bm_release_message (message_id);
        disconnect (nlc$tm_host_not_configured);
      IFEND;
    ELSE { Unsupported CC event.
      nap$namve_system_error ( {Recoverable_error=} TRUE,
            'Invalid CC connect event received by TCP/IP Management.', NIL);
    IFEND;
  PROCEND nlp$tm_connect_event_processor;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tm_define_tcpip_host', EJECT ??
*copy nlh$tm_define_tcpip_host

  PROCEDURE [XDCL] nlp$tm_define_tcpip_host
    (    host_name: string ( * );
         forward_search_range: nlt$tm_search_range);

    VAR
      device_count: integer,
      i: integer,
      j: integer,
      k: integer,
      route_seq: ^SEQ ( * );

    nlv$tm_host.name := host_name;
    nlv$tm_host.name_length := #SIZE (host_name);
    device_count := UPPERBOUND (nlv$configured_network_devices.network_device_list^);

    REPEAT
      ALLOCATE nlv$tm_device_configuration: [1 .. device_count] IN nav$network_paged_heap^;
      IF nlv$tm_device_configuration = NIL THEN
        syp$cycle;
      IFEND;
    UNTIL nlv$tm_device_configuration <> NIL;
    nlv$tm_device_configuration^.lock.lock_id := 0;
    nlv$tm_device_configuration^.count := device_count;
    nlv$tm_device_configuration^.tcp.count := 0;
    nlv$tm_device_configuration^.tcp.identifier := 1;
    nlv$tm_device_configuration^.udp.count := 0;
    nlv$tm_device_configuration^.udp.identifier := 1;

    FOR i := 1 TO device_count DO
      nlv$tm_device_configuration^.list [i].protocol := nlc$tm_null;
      nlv$tm_device_configuration^.list [i].local_device_address.full := 0;
    FOREND;

{ Initialize routing tables.

    REPEAT
      ALLOCATE route_seq: [[REP (nlc$tm_hash_elements * (#SIZE (nlt$tm_cache_entry) +
            (#SIZE (nlt$tm_cache_device) * device_count)) * forward_search_range) OF cell]]
           IN nav$network_paged_heap^;
      IF route_seq = NIL THEN
        syp$cycle;
      IFEND;
    UNTIL route_seq <> NIL;
    nav$sk_socket_layer_active := TRUE;
    RESET route_seq;
    nlv$tm_route_cache.forward_search_range := forward_search_range;
    nlv$tm_route_cache.refresh_interval := one_minute;
    nlv$tm_route_cache.stale_release_interval := ten_minutes;
    FOR i := 0 TO nlc$tm_hash_elements - 1 DO
      nlv$tm_route_cache.element_list [i].lock.lock_id := 0;
      NEXT nlv$tm_route_cache.element_list [i].entry_list: [1 .. forward_search_range] IN route_seq;
      FOR j := 1 TO forward_search_range DO
        nlv$tm_route_cache.element_list [i].entry_list^ [j].destination_address.full := 0;
        nlv$tm_route_cache.element_list [i].entry_list^ [j].refresh_timestamp := 0;
        nlv$tm_route_cache.element_list [i].entry_list^ [j].last_used_timestamp := 0;
        nlv$tm_route_cache.element_list [i].entry_list^ [j].device_count := 0;
        nlv$tm_route_cache.element_list [i].entry_list^ [j].unavailable_routes :=
              $nlt$device_ids [];
        NEXT nlv$tm_route_cache.element_list [i].entry_list^ [j].device_list: [1 .. device_count] IN
              route_seq;
        FOR k := 1 TO device_count DO
          nlv$tm_route_cache.element_list [i].entry_list^ [j].device_list^ [k].device_id := 0;
          nlv$tm_route_cache.element_list [i].entry_list^ [j].device_list^ [k].
                usage_count := nlc$tm_maximum_usage_count;
        FOREND;
      FOREND;
    FOREND;
  PROCEND nlp$tm_define_tcpip_host;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tm_event_processor', EJECT ??
*copy nlh$tm_event_processor

  PROCEDURE [XDCL] nlp$tm_event_processor
    (    cl_connection { input, output } : ^nlt$cl_connection;
         event { input, output } : nlt$cc_event;
     VAR inventory_report: integer);

?? NEWTITLE := '  deactivate_device' ??
?? NEWTITLE := '    find_tcp_device' ??
?? NEWTITLE := '    find_udp_device', EJECT ??

    PROCEDURE deactivate_device
      (    device_id: nlt$device_identifier);

{ NOTES:
{   The intent is to change the device id only if a TCP device is found.
{   The device id should never be zero because it is used to index into
{   an array with the smallest index of 1.

      PROCEDURE [INLINE] find_tcp_device
        (VAR device_id: nlt$device_identifier);

        VAR
          i: integer;

      /find_tcp_device_loop/
        FOR i := 1 TO nlv$tm_device_configuration^.count DO
          IF (nlv$tm_device_configuration^.list [i].protocol = nlc$tm_tcp_udp) OR
                (nlv$tm_device_configuration^.list [i].protocol = nlc$tm_tcp) THEN
            device_id := i;
            EXIT /find_tcp_device_loop/;
          IFEND;
        FOREND /find_tcp_device_loop/;
      PROCEND find_tcp_device;
?? OLDTITLE ??

{ NOTES:
{   The intent is to change the device id only if a UDP device is found.
{   The device id should never be zero because it is used to index into
{   an array with the smallest index of 1.

      PROCEDURE [INLINE] find_udp_device
        (VAR device_id: nlt$device_identifier);

        VAR
          i: integer;

      /find_udp_device_loop/
        FOR i := 1 TO nlv$tm_device_configuration^.count DO
          IF (nlv$tm_device_configuration^.list [i].protocol = nlc$tm_tcp_udp) OR
                (nlv$tm_device_configuration^.list [i].protocol = nlc$tm_udp) THEN
            device_id := i;
            EXIT /find_udp_device_loop/;
          IFEND;
        FOREND /find_udp_device_loop/;
      PROCEND find_udp_device;
?? OLDTITLE, EJECT ??
      VAR
        previous_request: ^^nlt$tm_addr_access_req_entry,
        request: ^nlt$tm_addr_access_req_entry,
        tcp_device: boolean,
        udp_device: boolean;

{ Update nlv$tm_device_configuration.

      osp$set_job_signature_lock (nlv$tm_device_configuration^.lock);
      nlv$tm_device_configuration^.list [device_id].local_device_address.full := 0;
      tcp_device := (nlv$tm_device_configuration^.list [device_id].protocol = nlc$tm_tcp_udp) OR
            (nlv$tm_device_configuration^.list [device_id].protocol = nlc$tm_tcp);
      udp_device := (nlv$tm_device_configuration^.list [device_id].protocol = nlc$tm_tcp_udp) OR
            (nlv$tm_device_configuration^.list [device_id].protocol = nlc$tm_udp);
      nlv$tm_device_configuration^.list [device_id].protocol := nlc$tm_null;
      IF tcp_device THEN
        nlv$tm_device_configuration^.tcp.count := nlv$tm_device_configuration^.tcp.count - 1;
        IF nlv$tm_device_configuration^.tcp.count >= 1 THEN
          find_tcp_device (nlv$tm_device_configuration^.tcp.identifier);
        IFEND;
      IFEND;
      IF udp_device THEN
        nlv$tm_device_configuration^.udp.count := nlv$tm_device_configuration^.udp.count - 1;
        IF nlv$tm_device_configuration^.udp.count >= 1 THEN
          find_udp_device (nlv$tm_device_configuration^.udp.identifier);
        IFEND;
      IFEND;
      osp$clear_job_signature_lock (nlv$tm_device_configuration^.lock);

{ Update nlv$tm_address_accessible.

      osp$set_job_signature_lock (nlv$tm_address_accessible.lock);
      previous_request := ^nlv$tm_address_accessible.first_request;
      WHILE previous_request^ <> NIL DO

{ If the response has already been processed (i.e., the route state is not equal to
{ nlc$tm_await_route_status) just leave it.

        request := previous_request^;
        IF request^.response_queue [device_id].route_status = nlc$tm_await_route_status THEN
          request^.response_count := request^.response_count + 1;
          request^.response_queue [device_id].route_status := nlc$tm_route_unknown;
        IFEND;

        IF request^.request_count = request^.response_count THEN
          IF request^.refresh THEN
            update_route_cache (request^);
            previous_request^ := request^.nextt;
            FREE request IN nav$network_paged_heap^;
          ELSE { NOT refresh.
            pmp$ready_task (request^.task_id, {ignore} status);
            previous_request := ^request^.nextt;
          IFEND;
        ELSE
          previous_request := ^request^.nextt;
        IFEND;
      WHILEND;
      osp$clear_job_signature_lock (nlv$tm_address_accessible.lock);

{ Remove any subnet entries.

      nlp$get_exclusive_access (nlv$tm_subnet_list.lock);
      previous_subnet := ^nlv$tm_subnet_list.root;
      WHILE previous_subnet^ <> NIL DO
        IF device_id = previous_subnet^^.local_device THEN
          subnet := previous_subnet^;
          previous_subnet^ := subnet^.nextt;
          FREE subnet IN nav$network_paged_heap^;
        ELSE
          previous_subnet := ^previous_subnet^^.nextt;
        IFEND;
      WHILEND;
      nlp$release_exclusive_access (nlv$tm_subnet_list.lock);
    PROCEND deactivate_device;
?? OLDTITLE ??
?? NEWTITLE := 'disconnect', EJECT ??

    PROCEDURE disconnect
      (    disconnect_reason: nlt$tm_release_reason);

      VAR
        data_fragment: array [1 .. 1] of nat$data_fragment,
        message_id: nlt$bm_message_id,
        release_pdu: nlt$tm_release_request;

      nap$namve_system_error ( {Recoverable_error=} TRUE, 'TMAA disconnect', NIL);
      release_pdu.header.kind := nlc$tm_release_request;
      release_pdu.header.length := #SIZE (nlt$tm_release_request);
      release_pdu.reason := disconnect_reason;
      data_fragment [1].address := ^release_pdu;
      data_fragment [1].length := release_pdu.header.length;
      nlp$bm_create_message (data_fragment, message_id, {ignore} status);
      nlp$cc_disconnect (cl_connection, message_id, {ignore} status);
      deactivate_device (connection^.device_id);
      nlp$cl_deactivate_layer (nlc$tcpip_mgmt_access_agent, cl_connection);
    PROCEND disconnect;
?? OLDTITLE, EJECT ??

    VAR
      address_accessible_req_pdu: nlt$tm_address_accessible_req,
      address_accessible_res_pdu: ^nlt$tm_address_accessible_res,
      bytes_moved: nat$data_length,
      cache_entry: ^nlt$tm_cache_entry,
      connection: ^nlt$tm_connection,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      data_length: integer,
      device_config_confirm_pdu: nlt$tm_device_config_confirm,
      device_config_request_pdu: ^nlt$tm_device_config_request,
      device_index: nlt$device_identifier,
      enable_host_routing_req_pdu: nlt$tm_enable_host_routing_req,
      error_string: ^string (80),
      hash: nlt$tm_hash_range,
      i: integer,
      index: 0 .. 255,
      layer_active: boolean,
      length: integer,
      message_id: nlt$bm_message_id,
      pdu_header: ^nlt$tm_pdu_header,
      pdu_seq: ^SEQ ( * ),
      previous_request: ^^nlt$tm_addr_access_req_entry,
      previous_subnet: ^^nlt$tm_subnet_entry,
      release_indication_pdu: nlt$tm_release_indication,
      release_request_pdu: nlt$tm_release_request,
      request: ^nlt$tm_addr_access_req_entry,
      response_entry: ^nlt$tm_addr_access_res_entry,
      route_unavailable_ind_pdu: ^nlt$tm_route_unavailable_ind,
      status: ost$status,
      subnet: ^nlt$tm_subnet_entry,
      subnet_available_ind_pdu: ^nlt$tm_subnet_available_ind,
      subnet_unavailable_ind_pdu: ^nlt$tm_subnet_unavailable_ind;

    inventory_report := 0;
    nlp$cl_get_layer_connection (nlc$tcpip_mgmt_access_agent, cl_connection, layer_active, connection);
    IF layer_active THEN
      CASE event.kind OF

?? NEWTITLE := 'nlc$cc_data_event', EJECT ??
?? NEWTITLE := 'nlc$tm_device_config_request', EJECT ??

      = nlc$cc_data_event =

        message_id := event.data.data;
        nlp$bm_get_message_length (message_id, data_length);
        IF data_length > #SIZE (nlt$tm_pdu_header) THEN
          PUSH pdu_seq: [[REP data_length OF cell]];
          data_fragment [1].address := pdu_seq;
          data_fragment [1].length := data_length;
          nlp$bm_flush_message (data_fragment, message_id, data_length, {ignore} status);
          RESET pdu_seq;
          NEXT pdu_header IN pdu_seq;
          CASE pdu_header^.kind OF
          = nlc$tm_device_config_request =
            IF connection^.state = nlc$tm_configuration_ind_wait THEN
              NEXT device_config_request_pdu IN pdu_seq;
              IF device_config_request_pdu <> NIL THEN
                device_config_confirm_pdu.header.kind := nlc$tm_device_config_confirm;
                device_config_confirm_pdu.header.length := #SIZE (nlt$tm_device_config_confirm);
                data_fragment [1].address := ^device_config_confirm_pdu;
                data_fragment [1].length := device_config_confirm_pdu.header.length;
                nlp$cc_send_data_fragments (cl_connection, data_fragment, {ignore} status);

                enable_host_routing_req_pdu.header.kind := nlc$tm_enable_host_routing_req;
                enable_host_routing_req_pdu.header.length := #SIZE (nlt$tm_enable_host_routing_req);
                data_fragment [1].address := ^enable_host_routing_req_pdu;
                data_fragment [1].length := enable_host_routing_req_pdu.header.length;
                nlp$cc_send_data_fragments (cl_connection, data_fragment, {ignore} status);
                connection^.state := nlc$tm_enable_host_routing;
                osp$set_job_signature_lock (nlv$tm_device_configuration^.lock);
                nlv$tm_device_configuration^.list [connection^.device_id].connection_id :=
                      cl_connection^.identifier;
                nlv$tm_device_configuration^.list [connection^.device_id].local_device_address :=
                      device_config_request_pdu^.host_internet_address;
                IF device_config_request_pdu^.tcp_access_enabled THEN
                  nlv$tm_device_configuration^.list [connection^.device_id].protocol := nlc$tm_tcp;
                  IF nlv$tm_device_configuration^.tcp.count = 0 THEN
                    nlv$tm_device_configuration^.tcp.identifier := connection^.device_id;
                  IFEND;
                  nlv$tm_device_configuration^.tcp.count := nlv$tm_device_configuration^.tcp.count + 1;

                  nlp$sk_tcp_device_available (connection^.device_id,
                        device_config_request_pdu^.host_internet_address.full);
                IFEND;

                IF device_config_request_pdu^.udp_access_enabled THEN
                  nlv$tm_device_configuration^.list [connection^.device_id].protocol := nlc$tm_udp;
                  IF nlv$tm_device_configuration^.udp.count = 0 THEN
                    nlv$tm_device_configuration^.udp.identifier := connection^.device_id;
                  IFEND;
                  nlv$tm_device_configuration^.udp.count := nlv$tm_device_configuration^.udp.count + 1;

                  nlp$udp_device_available (connection^.device_id,
                        device_config_request_pdu^.host_internet_address.full);
                IFEND;

                IF (device_config_request_pdu^.udp_access_enabled) AND
                      (device_config_request_pdu^.tcp_access_enabled) THEN
                  nlv$tm_device_configuration^.list [connection^.device_id].protocol := nlc$tm_tcp_udp;
                IFEND;
                osp$clear_job_signature_lock (nlv$tm_device_configuration^.lock);
              ELSE { The incoming pdu too small.
                disconnect (nlc$tm_header_indicernible);
              IFEND;
            ELSE { IF connection^.state <> nlc$tm_config_ind_wait THEN
              disconnect (nlc$tm_invalid_encoding);
            IFEND;
?? OLDTITLE ??
?? NEWTITLE := 'nlc$tm_address_accessible_res', EJECT ??

          = nlc$tm_address_accessible_res =
            CASE connection^.state OF
            = nlc$tm_enable_host_routing =
              NEXT address_accessible_res_pdu IN pdu_seq;
              IF address_accessible_res_pdu <> NIL THEN
                osp$set_job_signature_lock (nlv$tm_address_accessible.lock);
                previous_request := ^nlv$tm_address_accessible.first_request;

              /find_request/
                WHILE (previous_request^ <> NIL) AND
                      (previous_request^^.request_id <> address_accessible_res_pdu^.request_id) DO
                  previous_request := ^previous_request^^.nextt;
                WHILEND /find_request/;

                request := previous_request^;
                IF (request <> NIL) AND (request^.response_queue [connection^.device_id].route_status =
                     nlc$tm_await_route_status) THEN
                  IF nlv$log_tcpip_device_select THEN
                    PUSH error_string;
                    STRINGREP (error_string^, length, 'TCPIP: response, device', connection^.device_id,
                          ': cost', address_accessible_res_pdu^.route_cost, ', status',
                          $INTEGER(address_accessible_res_pdu^.route_status), ' for address',
                          request^.destination_address.full : #(16));
                    pmp$log_ascii (error_string^ (1, length), $pmt$ascii_logset [pmc$system_log],
                          pmc$msg_origin_program, {ignore} status);
                    status.normal := TRUE;
                  IFEND;
                  request^.response_count := request^.response_count + 1;
                  response_entry := ^request^.response_queue [connection^.device_id];

                  IF (NOT (connection^.device_id IN request^.unavailable_routes)) AND
                        (address_accessible_res_pdu^.route_status <> nlc$tm_route_unknown) THEN
                    IF address_accessible_res_pdu^.route_status = request^.
                          response_queue [request^.first_device_index].route_status THEN
                      IF address_accessible_res_pdu^.route_cost = request^.
                            response_queue [request^.first_device_index].route_cost THEN
                        response_entry^.route_status := address_accessible_res_pdu^.route_status;
                        response_entry^.route_cost := address_accessible_res_pdu^.route_cost;
                        request^.save_count := request^.save_count + 1;
                      ELSEIF address_accessible_res_pdu^.route_cost < request^.
                            response_queue [request^.first_device_index].route_cost THEN
                        response_entry^.route_cost := address_accessible_res_pdu^.route_cost;
                        response_entry^.route_status := address_accessible_res_pdu^.route_status;
                        request^.save_count := 1;
                        request^.first_device_index := connection^.device_id;
                      IFEND;

                    ELSEIF address_accessible_res_pdu^.route_status = nlc$tm_route_known THEN
                      response_entry^.route_cost := address_accessible_res_pdu^.route_cost;
                      response_entry^.route_status := nlc$tm_route_known;
                      request^.save_count := 1;
                      request^.first_device_index := connection^.device_id;
                    ELSEIF (request^.response_queue [request^.first_device_index].route_status <>
                          nlc$tm_route_known) AND (address_accessible_res_pdu^.route_status =
                          nlc$tm_route_indeterminate) THEN
                      response_entry^.route_cost := address_accessible_res_pdu^.route_cost;
                      response_entry^.route_status := nlc$tm_route_indeterminate;
                      request^.save_count := 1;
                      request^.first_device_index := connection^.device_id;
                    IFEND;
                  IFEND;
                  IF (request^.request_count = request^.response_count) OR
                        ((request^.response_queue [request^.first_device_index].route_status =
                        nlc$tm_route_known) AND (request^.ready_on_first_route_known)) THEN
                    IF request^.refresh THEN
                      update_route_cache (request^);
                      previous_request^ := request^.nextt;
                      FREE request IN nav$network_paged_heap^;
                    ELSE
                      pmp$ready_task (request^.task_id, {ignore} status);
                    IFEND;
                  IFEND;
                ELSE { Request not found.

{ If a select device request times out, the request is removed from the queue.
{ So it is possible to get to this point.

                  IF nlv$log_tcpip_device_select THEN
                    PUSH error_string;
                    STRINGREP (error_string^, length, 'TCPIP: response (late), device', connection^.device_id,
                          ': cost', address_accessible_res_pdu^.route_cost, ', status',
                          address_accessible_res_pdu^.route_status);
                    pmp$log_ascii (error_string^ (1, length), $pmt$ascii_logset [pmc$system_log],
                          pmc$msg_origin_program, {ignore} status);
                    status.normal := TRUE;
                  IFEND;

                IFEND;
                osp$clear_job_signature_lock (nlv$tm_address_accessible.lock);
              ELSE { The incoming pdu too small.
                disconnect (nlc$tm_header_indicernible);
              IFEND;
            ELSE { connection^.state <> nlc$tm_enable_host_routing
              disconnect (nlc$tm_invalid_encoding);
            CASEND;
?? OLDTITLE ??
?? NEWTITLE := 'nlc$tm_route_unavailable_ind', EJECT ??

          = nlc$tm_route_unavailable_ind =
            CASE connection^.state OF
            = nlc$tm_enable_host_routing =
              NEXT route_unavailable_ind_pdu IN pdu_seq;
              IF route_unavailable_ind_pdu <> NIL THEN
                hash := hash_address (route_unavailable_ind_pdu^.internet_address);
                osp$set_job_signature_lock (nlv$tm_route_cache.element_list [hash].lock);
                index := destination_address_index (route_unavailable_ind_pdu^.internet_address,
                      nlv$tm_route_cache.element_list [hash].entry_list);
                IF nlv$log_tcpip_device_select THEN
                  PUSH error_string;
                  STRINGREP (error_string^, length, 'TCPIP: response, device', connection^.device_id,
                        ': route unavail for', route_unavailable_ind_pdu^.internet_address.full : #(16));
                  pmp$log_ascii (error_string^ (1, length), $pmt$ascii_logset [pmc$system_log],
                        pmc$msg_origin_program, {ignore} status);
                  status.normal := TRUE;
                IFEND;
                IF index > 0 THEN { Address found.
                  cache_entry := ^nlv$tm_route_cache.element_list [hash].entry_list^ [index];
                  IF (cache_entry^.device_count > 0) AND
                     (NOT (connection^.device_id IN cache_entry^.unavailable_routes)) THEN
                    cache_entry^.unavailable_routes := cache_entry^.unavailable_routes +
                          $nlt$device_ids [connection^.device_id];

                  /remove_cache_entry_loop/
                    FOR i := 1 TO cache_entry^.device_count DO
                      IF cache_entry^.device_list^ [i].device_id = connection^.device_id THEN
                        IF cache_entry^.device_count > i THEN  { Compress device list.
                          cache_entry^.device_list^ [i] := cache_entry^.
                                device_list^ [cache_entry^.device_count];
                        IFEND;
                        cache_entry^.device_count := cache_entry^.device_count - 1;
                        EXIT /remove_cache_entry_loop/;
                      IFEND;
                    FOREND /remove_cache_entry_loop/;

                  IFEND;
                IFEND;
                osp$clear_job_signature_lock (nlv$tm_route_cache.element_list [hash].lock);
              ELSE { The incoming pdu too small.
                disconnect (nlc$tm_header_indicernible);
              IFEND;
            ELSE { connection^.state <> nlc$tm_enable_host_routing
              disconnect (nlc$tm_invalid_encoding);
            CASEND;
?? OLDTITLE ??
?? NEWTITLE := 'nlc$tm_subnet_available_ind', EJECT ??

          = nlc$tm_subnet_available_ind =
            IF connection^.state = nlc$tm_enable_host_routing THEN
              NEXT subnet_available_ind_pdu IN pdu_seq;
              IF subnet_available_ind_pdu <> NIL THEN
                IF (subnet_available_ind_pdu^.internet_address.class < 0) OR
                     (subnet_available_ind_pdu^.internet_address.class > 3) THEN { Invalid address.
                  nap$namve_system_error ( {Recoverable_error=} TRUE, 'Invalid TCP/IP address class TMAA.',
                        NIL);
                  RETURN;
                IFEND;

                REPEAT
                  ALLOCATE subnet IN nav$network_paged_heap^;
                  IF subnet = NIL THEN
                    syp$cycle;
                  IFEND;
                UNTIL subnet <> NIL;

                subnet^.nextt := NIL;
                subnet^.destination_address := subnet_available_ind_pdu^.internet_address;
                subnet^.local_device := connection^.device_id;
                subnet^.protocol := nlv$tm_device_configuration^.list [connection^.device_id].protocol;
                subnet^.mask := subnet_available_ind_pdu^.subnet_mask;
                subnet^.subnet_id := subnet_available_ind_pdu^.subnet_id;
                subnet^.route_cost := subnet_available_ind_pdu^.route_cost;
                CASE subnet_available_ind_pdu^.internet_address.class OF
                = 0, 1 = { Class a.
                  subnet^.network_mask.value := nlv$tm_class_a_network_mask;
                = 2 = { Class b.
                  subnet^.network_mask.value := nlv$tm_class_b_network_mask;
                = 3 = { Class c.
                  subnet^.network_mask.value := nlv$tm_class_c_network_mask;
                ELSE { Invalid address - already verified to be valid above.
                CASEND;

                nlp$get_exclusive_access (nlv$tm_subnet_list.lock);
                previous_subnet := ^nlv$tm_subnet_list.root;

              /duplicate_subnet_search/
                WHILE (previous_subnet^ <> NIL) AND NOT ((previous_subnet^^.subnet_id =
                      subnet_available_ind_pdu^.subnet_id) AND (connection^.device_id =
                      previous_subnet^^.local_device)) DO
                  previous_subnet := ^previous_subnet^^.nextt;
                WHILEND /duplicate_subnet_search/;
                IF previous_subnet^ = NIL THEN
                  previous_subnet^ := subnet;
                ELSE { Duplicate subnet found.
                  FREE subnet IN nav$network_paged_heap^;
                  nap$namve_system_error ( {Recoverable_error=} TRUE, 'Duplicate subnet found in TMAA.', NIL);
                IFEND;
                nlp$release_exclusive_access (nlv$tm_subnet_list.lock);
              ELSE { The incoming pdu too small.
                disconnect (nlc$tm_header_indicernible);
              IFEND;
            ELSE { connection^.state <> nlc$tm_enable_host_routing
              disconnect (nlc$tm_invalid_encoding);
            IFEND;
?? OLDTITLE ??
?? NEWTITLE := 'nlc$tm_subnet_unavailable_ind', EJECT ??

          = nlc$tm_subnet_unavailable_ind =
            IF connection^.state = nlc$tm_enable_host_routing THEN
              NEXT subnet_unavailable_ind_pdu IN pdu_seq;
              IF subnet_unavailable_ind_pdu <> NIL THEN
                nlp$get_exclusive_access (nlv$tm_subnet_list.lock);
                previous_subnet := ^nlv$tm_subnet_list.root;
                WHILE (previous_subnet^ <> NIL) AND ((connection^.device_id <>
                      previous_subnet^^.local_device) OR (previous_subnet^^.subnet_id <>
                      subnet_unavailable_ind_pdu^.subnet_id)) DO
                  previous_subnet := ^previous_subnet^^.nextt;
                WHILEND;
                IF previous_subnet^ <> NIL THEN
                  subnet := previous_subnet^;
                  previous_subnet^ := subnet^.nextt;
                  FREE subnet IN nav$network_paged_heap^;
                ELSE { Subnet not found.
                  PUSH error_string;
                  STRINGREP (error_string^, length, 'Subnet', subnet_unavailable_ind_pdu^.subnet_id,
                        ' NOT found for device', connection^.device_id);
                  nap$namve_system_error ( {Recoverable_error=} TRUE, error_string^ (1, length), NIL);
                IFEND;
                nlp$release_exclusive_access (nlv$tm_subnet_list.lock);
              ELSE { The incoming pdu too small.
                disconnect (nlc$tm_header_indicernible);
              IFEND;
            ELSE { connection^.state <> nlc$tm_enable_host_routing
              disconnect (nlc$tm_invalid_encoding);
            IFEND;
          ELSE { Unexpected pdu.kind.
            disconnect (nlc$tm_invalid_encoding);
          CASEND;
        ELSE { The pdu was incorrect.
          nlp$bm_release_message (message_id);
          disconnect (nlc$tm_header_indicernible);
        IFEND;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'nlc$cc_disconnect_event', EJECT ??
      = nlc$cc_disconnect_event =

{ Validate pdu.

{       IF event.disconnect.reason = nlc$cc_dr_normal_disconnect THEN

{ FSM #5, #21.

          message_id := event.disconnect.data;
{         nlp$bm_extract_message_prefix (^release_indication_pdu, #SIZE (nlt$tm_release_indication),
{               message_id, bytes_moved);
          nlp$bm_release_message (message_id);
{       ELSE { NOT nlc$cc_dr_normal_disconnect.

{ Log message - layer disconnect.

{       IFEND;

{ Process disconnect

        deactivate_device (connection^.device_id);
        nlp$cl_deactivate_layer (nlc$tcpip_mgmt_access_agent, cl_connection);
      ELSE { Unknown CC event kind.
        PUSH error_string;
        STRINGREP (error_string^, length, 'Invalid CC event received:', event.kind);
        nap$namve_system_error ( {Recoverable_error=} TRUE, error_string^ (1, length), NIL);
        nlp$bm_release_message (message_id);
      CASEND;
    ELSE { NOT layer active.
      PUSH error_string;
      STRINGREP (error_string^, length, 'CC event received while inactive:', event.kind);
      nap$namve_system_error ( {Recoverable_error=} TRUE, error_string^ (1, length), NIL);
      nlp$bm_release_message (message_id);
    IFEND;
  PROCEND nlp$tm_event_processor;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$tm_get_device_by_name', EJECT ??
*copy nlh$tm_get_device_by_name

  PROCEDURE [XDCL, #GATE] nlp$tm_get_device_by_name
    (    local_device_name: cmt$element_name;
     VAR local_device_id: nlt$device_identifier;
     VAR status: ost$status);

    VAR
      i: integer;

    status.normal := TRUE;
    FOR i := 1 TO UPPERBOUND (nlv$configured_network_devices.network_device_list^) DO
      IF nlv$configured_network_devices.network_device_list^ [i].element = local_device_name THEN
        local_device_id := i;
        RETURN;
      IFEND;
    FOREND;
    osp$set_status_abnormal (nac$status_id, nae$tm_device_name_not_found, local_device_name, status);
  PROCEND nlp$tm_get_device_by_name;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$tm_get_static_routes', EJECT ??
*copy nlh$tm_get_static_routes

  PROCEDURE [XDCL, #GATE] nlp$tm_get_static_routes
    (    static_routes: ^nlt$tm_static_route_definitions;
     VAR count: integer;
     VAR status: ost$status);

    VAR
      i: integer;

    status.normal := TRUE;
    count := 0;
    IF NOT (avp$configuration_administrator () OR avp$system_displays ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration OR system_displays',
            status);
      RETURN;
    IFEND;

    nlp$get_exclusive_access (nlv$tm_static_routing_table.lock);
    IF nlv$tm_static_routing_table.routes <> NIL THEN
      count := UPPERBOUND (nlv$tm_static_routing_table.routes^);
      IF (static_routes <> NIL) AND (UPPERBOUND (static_routes^) >= count) THEN
        FOR i := 1 TO count DO
          static_routes^ [i].local_device_name := nlv$tm_static_routing_table.routes^ [i].local_device_name;
          static_routes^ [i].local_device_id := nlv$tm_static_routing_table.routes^ [i].local_device_id;
          static_routes^ [i].destination_address := nlv$tm_static_routing_table.routes^ [i].
                destination_address.full;
          static_routes^ [i].destination_address_mask := nlv$tm_static_routing_table.routes^ [i].mask.value;
          static_routes^ [i].strict_route := nlv$tm_static_routing_table.routes^ [i].strict_route;
        FOREND;
      ELSE { IF (static_routes = NIL) OR (UPPERBOUND (static_routes^) < count) THEN
        osp$set_status_condition (nae$tm_route_list_too_small, status);
      IFEND;
    ELSE
      count := 0;
    IFEND;
    nlp$release_exclusive_access (nlv$tm_static_routing_table.lock);
  PROCEND nlp$tm_get_static_routes;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tm_initialize', EJECT ??
*copy nlh$tm_initialize

  PROCEDURE [XDCL] nlp$tm_initialize;

    VAR
      null_connect_event_processor: nlt$cl_event_processor,
      null_sap_event_processor: nlt$cl_event_processor;

    null_connect_event_processor.layer := nlc$tcpip_mgmt_access_agent;
    null_sap_event_processor.layer := nlc$tcpip_mgmt_access_agent;

    nlp$cl_initialize_template (nlc$tcpip_mgmt_access_agent, nlc$tcpip_mgmt_access_agent,
          #SIZE (nlt$tm_connection), 0, null_sap_event_processor, nac$nil, null_connect_event_processor,
          nac$nil);
    nlp$cc_initialize_template (nlc$tcpip_mgmt_access_agent);

  PROCEND nlp$tm_initialize;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$tm_install_static_routes', EJECT ??
*copy nlh$tm_install_static_routes

  PROCEDURE [XDCL, #GATE] nlp$tm_install_static_routes
    (    static_routes: ^nlt$tm_static_route_definition;
     VAR status: ost$status);

    VAR
      count: integer,
      i: integer,
      static_route: ^nlt$tm_static_route_definition,
      static_routing_table: ^nlt$tm_static_routes;

    status.normal := TRUE;
    IF NOT avp$configuration_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      RETURN;
    IFEND;

    IF nlv$tm_host.name_length > 0 THEN
      count := 0;
      static_route := static_routes;
      WHILE static_route <> NIL DO
        static_route := static_route^.nextt;
        count := count + 1;
      WHILEND;

{ Allocate the new static routing table before freeing the old table.  This
{ will allow going back to the old table if the allocate for the new table fails.

      ALLOCATE static_routing_table: [1 .. count] IN nav$network_paged_heap^;
      IF static_routing_table <> NIL THEN
        nlp$get_exclusive_access (nlv$tm_static_routing_table.lock);
        IF nlv$tm_static_routing_table.routes <> NIL THEN
          FREE nlv$tm_static_routing_table.routes IN nav$network_paged_heap^;
        IFEND;
        nlv$tm_static_routing_table.routes := static_routing_table;

        static_route := static_routes;
        FOR i := 1 TO count DO
          nlv$tm_static_routing_table.routes^ [i].local_device_name := static_route^.local_device_name;
          nlv$tm_static_routing_table.routes^ [i].local_device_id := static_route^.local_device_id;
          nlv$tm_static_routing_table.routes^ [i].destination_address.full :=
                static_route^.destination_address;
          nlv$tm_static_routing_table.routes^ [i].mask.value := static_route^.destination_address_mask;
          nlv$tm_static_routing_table.routes^ [i].strict_route := static_route^.strict_route;
          static_route := static_route^.nextt;
        FOREND;
        nlp$release_exclusive_access (nlv$tm_static_routing_table.lock);
      ELSE { IF static_routing_table = NIL THEN
        osp$set_status_condition (nae$tm_resources_unavailable, status);
      IFEND;
    ELSE
      osp$set_status_condition (nae$tm_host_not_defined, status);
    IFEND;
  PROCEND nlp$tm_install_static_routes;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tm_tcp_select_device', EJECT ??
*copy nlh$tm_tcp_select_device

  PROCEDURE [XDCL] nlp$tm_tcp_select_device
    (    destination_address: nat$sk_ip_address;
     VAR device_id: nlt$device_identifier;
     VAR local_address: nat$sk_ip_address;
     VAR status: ost$status);

    VAR
      device: nlt$tm_device_list,
      local_destination_address: nlt$tcpip_address,
      tcp_device: nlt$tm_device_information;

    status.normal := TRUE;
    tcp_device := nlv$tm_device_configuration^.tcp;
    IF (tcp_device.count = 1) AND (nlv$tm_static_routing_table.routes = NIL) THEN
      device_id := tcp_device.identifier;
      local_address := nlv$tm_device_configuration^.list [device_id].local_device_address.full;
    ELSEIF tcp_device.count > 0 THEN
      local_destination_address.full := destination_address;
      find_best_local_device (local_destination_address, tcp_device, nlc$tm_tcp, device_id, status);
      IF status.normal THEN
        local_address := nlv$tm_device_configuration^.list [device_id].local_device_address.full;
      IFEND;
    ELSE { TCP device count is zero.
      osp$set_status_condition (nae$tm_no_tcp_device_available, status);
    IFEND;

  PROCEND nlp$tm_tcp_select_device;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$tm_udp_select_device', EJECT ??
*copy nlh$tm_udp_select_device

  PROCEDURE [XDCL, #GATE] nlp$tm_udp_select_device
    (    destination_address: nat$sk_ip_address;
     VAR device_id: nlt$device_identifier;
     VAR status: ost$status);


    VAR
      device: nlt$tm_device_list,
      local_destination_address: nlt$tcpip_address,
      udp_device: nlt$tm_device_information;

    status.normal := TRUE;
    udp_device := nlv$tm_device_configuration^.udp;
    IF (udp_device.count = 1) AND (nlv$tm_static_routing_table.routes = NIL) THEN
      device_id := udp_device.identifier;
    ELSEIF udp_device.count > 0 THEN
      local_destination_address.full := destination_address;
      find_best_local_device (local_destination_address, udp_device, nlc$tm_udp, device_id, status);
    ELSE { UDP device count is zero.
      osp$set_status_condition (nae$tm_no_udp_device_available, status);
    IFEND;

  PROCEND nlp$tm_udp_select_device;
?? OLDTITLE ??
?? NEWTITLE := 'await_query_responses', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to wait for the response to the routing
{   queries sent to the devices. This procedure may wait for two intervals.
{   In the first interval, all devices must respond to complete the request.
{   In the second (longer) interval, the first route known response will complete
{   the request.

  PROCEDURE await_query_responses
    (    executing_taskid: ost$global_task_id;
     VAR address_accessible_req_entry { input, output } : nlt$tm_addr_access_req_entry);

    VAR
      current_time: integer,
      expiration_time: integer,
      remaining_time: integer,
      wait_for_all_responses: boolean;

    IF address_accessible_req_entry.request_count <= address_accessible_req_entry.response_count THEN
      RETURN; { All devices have responded.
    IFEND;

    remaining_time := 1000;
    expiration_time := (#FREE_RUNNING_CLOCK (0) DIV 1000) + remaining_time;
    wait_for_all_responses := TRUE;

  /wait_loop/
    REPEAT
      pmp$wait (remaining_time, remaining_time);
      #SPOIL (address_accessible_req_entry);

      IF address_accessible_req_entry.request_count <= address_accessible_req_entry.response_count THEN
        EXIT /wait_loop/; { All devices have responded.
      IFEND;

      current_time := #FREE_RUNNING_CLOCK (0) DIV 1000;
      remaining_time := (expiration_time - current_time);
      IF (remaining_time <= 0) AND (wait_for_all_responses) THEN
        address_accessible_req_entry.ready_on_first_route_known := TRUE;
        #SPOIL (address_accessible_req_entry);
        remaining_time := 2 * (500 * (address_accessible_req_entry.request_count -
              address_accessible_req_entry.response_count));
        expiration_time := current_time + remaining_time;
        wait_for_all_responses := FALSE;
      IFEND;

      IF (NOT wait_for_all_responses) AND (address_accessible_req_entry.response_queue
             [address_accessible_req_entry.first_device_index].route_status = nlc$tm_route_known) THEN
        EXIT /wait_loop/;
      IFEND;
    UNTIL remaining_time <= 0;{/wait_loop/}

  PROCEND await_query_responses;
?? OLDTITLE ??
?? NEWTITLE := '  destination_address_index', EJECT ??

{ PURPOSE:
{   This function returns the array index of the specified destination
{   address, if found.  If the destination address is not found or the
{   destination address entry is stale an index of zero is returned.
{   In addition, the stale entry is invalidated i.e., the destination
{   address and the last used timestamp are zeroed out.

  FUNCTION destination_address_index
    (    destination_address: nlt$tcpip_address;
         cache_entry_list: ^nlt$tm_route_cache_entry_list): 0 .. 0ff(16);

    VAR
      current_time: integer,
      i: 0 .. 0ff(16);

    current_time := #FREE_RUNNING_CLOCK (0) DIV mics_to_mills;
    FOR i := 1 TO UPPERBOUND (cache_entry_list^) DO
      IF destination_address.full = cache_entry_list^ [i].destination_address.full THEN

        IF (cache_entry_list^ [i].last_used_timestamp + nlv$tm_route_cache.stale_release_interval) >
              current_time THEN
          destination_address_index := i;

        ELSE { Stale cache entry.
          destination_address_index := 0;
          cache_entry_list^ [i].destination_address.full := 0;
          cache_entry_list^ [i].last_used_timestamp := 0;
        IFEND;
        RETURN;
      IFEND;
    FOREND;
    destination_address_index := 0;
  FUNCEND destination_address_index;
?? OLDTITLE ??
?? NEWTITLE := '  device_available', EJECT ??

  FUNCTION device_available
    (    device_id: nlt$device_identifier;
         protocol: nlt$tm_protocol): boolean;

    device_available := (nlv$tm_device_configuration^.list [device_id].protocol = protocol) OR
          (nlv$tm_device_configuration^.list [device_id].protocol = nlc$tm_tcp_udp);
  FUNCEND device_available;
?? OLDTITLE ??
?? NEWTITLE := '  find_best_local_device', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to choose a device identifier with the lowest usage count
{   from the cache entry's device list from among those that support the requested protocol.
{   If a device identifier is found, the device's usage
{   count will be incremented and the cache entry's usage timestamp will be updated.  If a
{   device identifier is not found, the return parameter 'found' will be set to FALSE.
{   A cache refresh will be initiated if the refresh time has been reached.
{
{   If no cache entry is found, the static route table and the subnet and network lists will
{   be searched. If the destination address still has not been found, all active devices
{   supporting the requested protocol will be polled.

  PROCEDURE find_best_local_device
    (    destination_address: nlt$tcpip_address;
         tm_device_information: nlt$tm_device_information;
         protocol: nlt$tm_protocol;
     VAR device_id: nlt$device_identifier;
     VAR status: ost$status);

    VAR
      cache_entry_list: ^nlt$tm_route_cache_entry_list,
      cache_entry: ^nlt$tm_cache_entry,
      device: nlt$tm_device_list,
      device_index: integer,
      device_protocol: nlt$tm_protocol,
      found: boolean,
      hash: nlt$tm_hash_range,
      i: integer,
      index: 0 .. 255,
      len: integer,
      msg: string (80),
      refresh: boolean,
      unavailable_routes: nlt$device_ids,
      usage_count: nlt$tm_usage_count;

    found := FALSE;
    refresh := FALSE;
    unavailable_routes := $nlt$device_ids [];
    hash := hash_address (destination_address);
    cache_entry_list := nlv$tm_route_cache.element_list [hash].entry_list;
    index := destination_address_index (destination_address, cache_entry_list);
    IF index > 0 THEN { Address found.
      usage_count := nlc$tm_maximum_usage_count;
      cache_entry := ^cache_entry_list^ [index];

    /find_least_used/
      FOR i := 1 TO cache_entry^.device_count DO
        device_protocol := nlv$tm_device_configuration^.list [cache_entry^.device_list^ [i].device_id]
              .protocol;
        IF (cache_entry^.device_list^ [i].usage_count < usage_count) AND ((device_protocol = nlc$tm_tcp_udp)
              OR (device_protocol = protocol)) THEN
          usage_count := cache_entry^.device_list^ [i].usage_count;
          device_index := i;
          device_id := cache_entry^.device_list^ [i].device_id;
          found := TRUE;
        IFEND;
      FOREND /find_least_used/;

      IF found THEN
        IF cache_entry^.device_list^ [device_index].usage_count = nlc$tm_maximum_usage_count - 1 THEN

{ Reset the usage counts to zero.

          FOR i := 1 TO cache_entry^.device_count DO
            cache_entry^.device_list^ [i].usage_count := 0;
          FOREND;
        IFEND;
        cache_entry^.device_list^ [device_index].usage_count :=
              cache_entry^.device_list^ [device_index].usage_count + 1;
        cache_entry^.last_used_timestamp := #FREE_RUNNING_CLOCK (0) DIV mics_to_mills;
        IF cache_entry^.last_used_timestamp > (cache_entry^.refresh_timestamp +
              nlv$tm_route_cache.refresh_interval) THEN
          refresh := TRUE;
          cache_entry^.unavailable_routes := $nlt$device_ids [];
        ELSE { Do not refresh.
          IF NOT (device_id IN cache_entry^.unavailable_routes) THEN
            IF nlv$log_tcpip_device_select THEN
              STRINGREP (msg, len, 'TCPIP: selected device', device_id, ' for address',
                    destination_address.full : #(16));
              pmp$log_ascii (msg (1, len), $pmt$ascii_logset [pmc$system_log], pmc$msg_origin_program,
                    {ignore} status);
              status.normal := TRUE;
            IFEND;
            RETURN;
          ELSE
            unavailable_routes := cache_entry^.unavailable_routes;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF nlv$log_tcpip_device_select THEN
      STRINGREP (msg, len, 'TCPIP: search parameters:', index, ' ', found, ' ', refresh, ' for address',
            destination_address.full : #(16));
      pmp$log_ascii (msg (1, len), $pmt$ascii_logset [pmc$system_log], pmc$msg_origin_program,
            {ignore} status);
      status.normal := TRUE;
    IFEND;

    PUSH device.list: [1 .. tm_device_information.count];
    device.count := 0;
    search_static_table (destination_address, protocol, unavailable_routes, device, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF device.count > 0 THEN {device found - cache it now.
      refresh := FALSE;
    ELSEIF tm_device_information.count = 1 THEN
      device.count := 1;
      device.list^ [1].identifier := tm_device_information.identifier;
    ELSE { IF device.count = 0 THEN
      search_subnet_list (destination_address, protocol, unavailable_routes, device, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF device.count > 0 THEN {device found - cache it now.
        refresh := FALSE;
      IFEND;
    IFEND;

    IF device.count = 0 THEN
      poll_devices_for_routing_info (destination_address, unavailable_routes, protocol, refresh,
            { network_search_refresh = } FALSE, device, status);
      IF (NOT status.normal) OR (refresh) THEN
        RETURN;
      IFEND;
    ELSE
      IF nlv$log_tcpip_device_select THEN
        STRINGREP (msg, len, 'TCPIP: device count', device.count, ', refresh ', refresh, ', for address',
              destination_address.full : #(16));
        pmp$log_ascii (msg (1, len), $pmt$ascii_logset [pmc$system_log], pmc$msg_origin_program,
              {ignore} status);
        status.normal := TRUE;
      IFEND;
    IFEND;

    IF (device.count > 0) THEN
      IF (NOT refresh) THEN
        osp$set_job_signature_lock (nlv$tm_route_cache.element_list [hash].lock);
        index := find_new_address_index (destination_address, cache_entry_list);
        cache_entry := ^cache_entry_list^ [index];
        cache_entry^.last_used_timestamp := #FREE_RUNNING_CLOCK (0) DIV mics_to_mills;
        cache_entry^.refresh_timestamp := cache_entry^.last_used_timestamp;

      /update_route_cache/
        BEGIN
          IF (cache_entry^.destination_address.full = destination_address.full) AND
                (cache_entry^.device_count = device.count) THEN
          /check_for_config_changes/
            BEGIN
              FOR i := 1 TO device.count DO
                IF cache_entry^.device_list^ [i].device_id <> device.list^ [i].identifier THEN
                  IF nlv$log_tcpip_device_select THEN
                    STRINGREP (msg, len, 'TCPIP: configuration changed ... reinitialize cache for address',
                          destination_address.full : #(16), i);
                    pmp$log_ascii (msg (1, len), $pmt$ascii_logset [pmc$system_log], pmc$msg_origin_program,
                          {ignore} status);
                    status.normal := TRUE;
                  IFEND;
                  EXIT /check_for_config_changes/; {configuration has changed  ... reinitialize cache.
                IFEND;
              FOREND;
              EXIT /update_route_cache/; {no change in configuration: cache was used and is still valid.
            END /check_for_config_changes/;
          IFEND;
          cache_entry^.destination_address := destination_address;
          cache_entry^.device_count := device.count;
          cache_entry^.unavailable_routes := $nlt$device_ids[];

          FOR i := 1 TO device.count DO
            cache_entry^.device_list^ [i].device_id := device.list^ [i].identifier;
            cache_entry^.device_list^ [i].usage_count := 0;
          FOREND;
          device_id := cache_entry^.device_list^ [1].device_id;
          cache_entry^.device_list^ [1].usage_count := 1;
          found := TRUE;
        END /update_route_cache/;

        osp$clear_job_signature_lock (nlv$tm_route_cache.element_list [hash].lock);
      IFEND;
    IFEND;
    IF NOT found THEN
      IF protocol = nlc$tm_tcp THEN
        set_status_with_address (nae$tm_no_tcp_routes_known, destination_address, status);
      ELSE
        set_status_with_address (nae$tm_no_udp_routes_known, destination_address, status);
      IFEND;
    IFEND;

  PROCEND find_best_local_device;
?? OLDTITLE ??
?? NEWTITLE := '  find_new_address_index', EJECT ??

{ PURPOSE:
{   This function returns the array index for a new cache entry.  The
{   index returned will be the smallest index possible.  The intent is
{   to keep the entries as close as possible to the front of the queue.
{   The array is searched for a matching destination address, the first empty
{   entry or the first stale entry.  If an empty or stale entry is found the
{   remainder of the queue will be searched for a duplicate destination address
{   entry.  If a duplicate is found it will be moved to the earlier slot.
{   If neither a duplicate, an empty, nor a stale entry is found the least recently used
{   entry will be returned. If the destination address in the entry returned matches
{   the reqested destination address, then this is an existing cache entry.

  FUNCTION find_new_address_index
    (    destination_address: nlt$tcpip_address;
         cache_entry_list: ^nlt$tm_route_cache_entry_list): 1 .. 0ff(16);

    VAR
      current_time: integer,
      duplicate: boolean,
      i: 0 .. 0ff(16),
      index: 0 .. 0ff(16),
      least_recently_used: 1 .. 0ff(16);

    current_time := #FREE_RUNNING_CLOCK (0) DIV mics_to_mills;
    least_recently_used := 1;
    index := 0;

  /search/
    FOR i := 1 TO UPPERBOUND (cache_entry_list^) DO
      duplicate := destination_address.full = cache_entry_list^ [i].destination_address.full;
      IF (duplicate) OR (cache_entry_list^ [i].destination_address.full = 0) OR
            ((cache_entry_list^ [i].last_used_timestamp + nlv$tm_route_cache.stale_release_interval) <
            current_time) THEN
        IF index = 0 THEN
          index := i;
          IF duplicate THEN
            EXIT /search/;
          IFEND;
        ELSEIF duplicate THEN { replace expired entry.
          cache_entry_list^ [index] := cache_entry_list^ [i];
          cache_entry_list^ [i].destination_address.full := 0;
          cache_entry_list^ [i].last_used_timestamp := 0;
          EXIT /search/;
        IFEND;
      ELSEIF cache_entry_list^ [i].last_used_timestamp < cache_entry_list^ [least_recently_used].
            last_used_timestamp THEN
        least_recently_used := i;
      IFEND;
    FOREND /search/;
    IF index > 0 THEN
      find_new_address_index := index;
    ELSE
      find_new_address_index := least_recently_used;
    IFEND;
  FUNCEND find_new_address_index;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] hash_address', EJECT ??

{ PURPOSE:
{   The purpose of this function is to change one 32 bit address into a hash point
{   with a value of 0 to 255.

  FUNCTION [INLINE] hash_address
    (    address: nlt$tcpip_address): 0 .. 0ff(16);

    hash_address := (address.sub_part [1] + inverse_table [address.sub_part [2]] +
          inverse_table [address.sub_part [3]] + address.sub_part [4]) MOD 256;
  FUNCEND hash_address;
?? OLDTITLE ??
?? NEWTITLE := 'poll_devices_for_routing_info', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to send the routing queries to all the
{   configured devices and to await the responses from the devices.
{   The exception is if this is a request to refresh the routing cache;
{   in which case, the requests are issued but task does not wait for the
{   responses.
{
{ INTERFACE REQUIREMENTS:
{   The caller must not have exclusive or nonexclusive access to the
{   nlv$tm_sublist_list lock if 'refresh' is FALSE.
{
{ NOTE:
{   The parameter network_search_refresh specifies that this request is being
{   called because the destination address matched with multiple networks in
{   the subnet list.  The devices are being polled to determine the route costs
{   to be associated with the destination address.  In case no device returns with
{   a route known response continue to use the old routes cached.  This feature
{   is a result of discussions with GSA.
{   The parameter device.count will in most cases be zero.  The exception is if
{   network_search_refresh then the device.count will indicate the number of
{   network matches found in the subnet search.  In the case where the device count
{   is nonzero, only the devices on the device list will be polled.

  PROCEDURE poll_devices_for_routing_info
    (    destination_address: nlt$tcpip_address;
         unavailable_routes: nlt$device_ids;
         protocol: nlt$tm_protocol;
         refresh: boolean;
         network_search_refresh: boolean;
     VAR device { input, output } : nlt$tm_device_list;
     VAR status: ost$status);

?? NEWTITLE :='  send_routing_query', EJECT ??

   PROCEDURE send_routing_query
     (    device_id: nlt$device_identifier;
          request: array [1 .. 1] of nat$data_fragment;
          protocol: nlt$tm_protocol;
      VAR addr_access_req_entry: {input, output} nlt$tm_addr_access_req_entry;
      VAR query_count: {input, output} nlt$device_count);


    VAR
      cl_connection: ^nlt$cl_connection,
      connection: ^nlt$tm_connection,
      connection_exists: boolean,
      ignore_status: ost$status,
      layer_active: boolean,
      len: integer,
      msg: string (80);

{ Send only to protocol specific devices.

      IF (nlv$tm_device_configuration^.list [device_id].protocol = nlc$tm_tcp_udp) OR
            (nlv$tm_device_configuration^.list [device_id].protocol = protocol) THEN
        IF nlv$log_tcpip_device_select THEN
          STRINGREP (msg, len, 'TCPIP: poll device', device_id, ' for address',
                destination_address.full : #(16));
          pmp$log_ascii (msg (1, len), $pmt$ascii_logset [pmc$system_log], pmc$msg_origin_program,
                {ignore} status);
          status.normal := TRUE;
        IFEND;
        nlp$cl_get_exclusive_via_cid (nlv$tm_device_configuration^.list [device_id].connection_id,
              connection_exists, cl_connection);
        IF connection_exists THEN
          nlp$cl_get_layer_connection (nlc$tcpip_mgmt_access_agent, cl_connection, layer_active,
                connection);
          IF (layer_active) AND (connection^.state = nlc$tm_enable_host_routing) THEN
            nlp$cc_send_data_fragments (cl_connection, data_fragment, ignore_status);
            addr_access_req_entry.response_queue [device_id].route_status :=
                  nlc$tm_await_route_status;
            query_count := query_count + 1;
          IFEND;
          nlp$cl_release_exclusive_access (cl_connection);
        IFEND;
      ELSE
        IF nlv$log_tcpip_device_select THEN
          STRINGREP (msg, len, 'TCPIP: skip device', device_id, ' for address',
                destination_address.full : #(16));
          pmp$log_ascii (msg (1, len), $pmt$ascii_logset [pmc$system_log], pmc$msg_origin_program,
                {ignore} status);
          status.normal := TRUE;
        IFEND;
      IFEND;

    PROCEND send_routing_query;
 ?? OLDTITLE, EJECT ??

    VAR
      addr_accessible_request_entry: ^nlt$tm_addr_access_req_entry,
      address_accessible_task: ^nlt$tm_address_accessible_task,
      best_cost: nlt$tm_route_cost,
      best_status: nlt$tm_route_status,
      cl_connection: ^nlt$cl_connection,
      connection: ^nlt$tm_connection,
      connection_exists: boolean,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      device_id: nlt$device_identifier,
      device_index: integer,
      executing_task_id: ost$global_task_id,
      i: integer,
      ignore_status: ost$status,
      message_id: nlt$bm_message_id,
      pdu: nlt$tm_address_accessible_req,
      previous_addr_access_req_entry: ^^nlt$tm_addr_access_req_entry,
      query_count: nlt$device_count,
      request_count: nlt$device_count;

    status.normal := TRUE;

    pmp$get_executing_task_gtid (executing_task_id);
    osp$set_job_signature_lock (nlv$tm_address_accessible.lock);
    addr_accessible_request_entry := nlv$tm_address_accessible.first_request;

  /check_for_destination_address/
    WHILE (addr_accessible_request_entry <> NIL) AND (addr_accessible_request_entry^.request_id <>
          destination_address.full) DO
      addr_accessible_request_entry := addr_accessible_request_entry^.nextt;
    WHILEND /check_for_destination_address/;

    IF addr_accessible_request_entry <> NIL THEN { Destination address found.
      addr_accessible_request_entry^.unavailable_routes := unavailable_routes;
      IF refresh THEN { The outstanding request will update the cache.
        osp$clear_job_signature_lock (nlv$tm_address_accessible.lock);
        RETURN;
      ELSE { NOT refresh.
        query_count := 1;

        IF addr_accessible_request_entry^.refresh THEN
          addr_accessible_request_entry^.refresh := FALSE;
          addr_accessible_request_entry^.task_id := executing_task_id;

        ELSE { Queue the task id on the outstanding request.
          ALLOCATE address_accessible_task IN nav$network_paged_heap^;
          IF address_accessible_task <> NIL THEN
            address_accessible_task^.task_id := executing_task_id;
            address_accessible_task^.nextt := addr_accessible_request_entry^.task_queue;
            addr_accessible_request_entry^.task_queue := address_accessible_task;
            addr_accessible_request_entry^.task_queue_count :=
                  addr_accessible_request_entry^.task_queue_count + 1;
          ELSE { Heap full
            osp$clear_job_signature_lock (nlv$tm_address_accessible.lock);
            osp$set_status_condition (nae$tm_resources_unavailable, status);
            RETURN;
          IFEND;
        IFEND;
        osp$clear_job_signature_lock (nlv$tm_address_accessible.lock);
      IFEND;

    ELSE { Destination address is not currently queued.
      pdu.header.kind := nlc$tm_address_accessible_req;
      pdu.header.length := #SIZE (nlt$tm_address_accessible_req);
      pdu.request_id := destination_address.full;
      pdu.internet_address := destination_address;

      data_fragment [1].address := ^pdu;
      data_fragment [1].length := pdu.header.length;

{ Poll the devices for routing information.

      ALLOCATE addr_accessible_request_entry: [1 .. nlv$tm_device_configuration^.count] IN
            nav$network_paged_heap^;

{ Initialize request queue.

      IF addr_accessible_request_entry <> NIL THEN
        addr_accessible_request_entry^.request_id := destination_address.full;
        addr_accessible_request_entry^.task_id := executing_task_id;
        addr_accessible_request_entry^.destination_address := destination_address;
        IF device.count = 0 THEN
          addr_accessible_request_entry^.request_count := UPPERBOUND (device.list^);
        ELSE { device.count > 0 THEN
          addr_accessible_request_entry^.request_count := device.count;
        IFEND;
        addr_accessible_request_entry^.response_count := 0;
        addr_accessible_request_entry^.save_count := 0;

{ The first device index is initialized to 1.  This was just an arbitrary choice.  It just needed to
{ be a value that was within the size of the response queue.  The route cost is initialized to a value
{ greater than is possible to be received over the network so the first route known or route indeterminate
{ regardless of the cost will become the first device index.  This allowed the code to not have to check
{ whether the response received was the first.

        addr_accessible_request_entry^.first_device_index := 1;
        addr_accessible_request_entry^.task_queue_count := 0;
        addr_accessible_request_entry^.ready_on_first_route_known := FALSE;
        addr_accessible_request_entry^.refresh := refresh;
        addr_accessible_request_entry^.unavailable_routes := unavailable_routes;
        addr_accessible_request_entry^.network_search_refresh := network_search_refresh;
        addr_accessible_request_entry^.task_queue := NIL;
        FOR i := 1 TO nlv$tm_device_configuration^.count DO
          addr_accessible_request_entry^.response_queue [i].route_status := nlc$tm_route_unknown;
          addr_accessible_request_entry^.response_queue [i].route_cost := nlc$tm_maximum_route_cost;
        FOREND;

        addr_accessible_request_entry^.nextt := nlv$tm_address_accessible.first_request;
        nlv$tm_address_accessible.first_request := addr_accessible_request_entry;
        osp$clear_job_signature_lock (nlv$tm_address_accessible.lock);
      ELSE { Heap full
        osp$clear_job_signature_lock (nlv$tm_address_accessible.lock);
        osp$set_status_condition (nae$tm_resources_unavailable, status);
        RETURN;
      IFEND;

{ Send the routing queries.

      IF device.count = 0 THEN
        query_count := 0;
        device_id := 1;
        request_count := UPPERBOUND (device.list^);
        WHILE (device_id <= nlv$tm_device_configuration^.count) AND (query_count < request_count) DO
          IF NOT (device_id IN unavailable_routes) THEN
            send_routing_query (device_id, data_fragment, protocol, addr_accessible_request_entry^,
                  query_count);
          IFEND;
          device_id := device_id + 1;
        WHILEND;
      ELSE { IF device.count > 0 THEN
        query_count := 0;
        request_count := device.count;
        FOR i := 1 to device.count DO
          IF NOT (device.list^[i].identifier IN unavailable_routes) THEN
            send_routing_query (device.list^[i].identifier, data_fragment, protocol,
                  addr_accessible_request_entry^, query_count);
          IFEND;
        FOREND;
      IFEND;

      IF query_count < request_count THEN
        osp$set_job_signature_lock (nlv$tm_address_accessible.lock);
        previous_addr_access_req_entry := ^nlv$tm_address_accessible.first_request;

      /find_addr_accessible_request/
        WHILE (previous_addr_access_req_entry^ <> NIL) AND
              (previous_addr_access_req_entry^^.request_id <> destination_address.full) DO
          previous_addr_access_req_entry := ^previous_addr_access_req_entry^^.nextt;
        WHILEND /find_addr_accessible_request/;

{ Note it is possible to not find the entry if the request was for a refresh because
{ the refresh requests are removed in the event processor.

        addr_accessible_request_entry := previous_addr_access_req_entry^;
        IF addr_accessible_request_entry <> NIL THEN
          addr_accessible_request_entry^.request_count := query_count;
          IF query_count <= addr_accessible_request_entry^.response_count THEN
            IF (addr_accessible_request_entry^.refresh) OR (query_count = 0) THEN
              update_route_cache (addr_accessible_request_entry^);
              previous_addr_access_req_entry^ := addr_accessible_request_entry^.nextt;
              FREE addr_accessible_request_entry IN nav$network_paged_heap^;
            IFEND;
          IFEND;
        IFEND;
        osp$clear_job_signature_lock (nlv$tm_address_accessible.lock);
      IFEND;
    IFEND;

    IF query_count > 0 THEN
      IF refresh THEN
        RETURN;
      ELSE
        await_query_responses (executing_task_id, addr_accessible_request_entry^);
      IFEND;
    ELSE { Devices are inaccessible
      IF protocol = nlc$tm_tcp THEN
        osp$set_status_condition (nae$tm_no_tcp_device_available, status);
      ELSE { IF protocol = nlc$tm_udp THEN
        osp$set_status_condition (nae$tm_no_udp_device_available, status);
      IFEND;
    IFEND;

    osp$set_job_signature_lock (nlv$tm_address_accessible.lock);
    previous_addr_access_req_entry := ^nlv$tm_address_accessible.first_request;
    WHILE (previous_addr_access_req_entry^ <> NIL) AND (previous_addr_access_req_entry^^.request_id <>
          destination_address.full) DO
      previous_addr_access_req_entry := ^previous_addr_access_req_entry^^.nextt;
    WHILEND;
    addr_accessible_request_entry := previous_addr_access_req_entry^;

{ Fill in device_list.

    IF addr_accessible_request_entry <> NIL THEN
      IF addr_accessible_request_entry^.save_count > 0 THEN
        device_index := 1;
        best_cost := addr_accessible_request_entry^.response_queue
              [addr_accessible_request_entry^.first_device_index].route_cost;
        best_status := addr_accessible_request_entry^.response_queue
              [addr_accessible_request_entry^.first_device_index].route_status;
        FOR i := 1 TO UPPERBOUND (addr_accessible_request_entry^.response_queue) DO
          IF (addr_accessible_request_entry^.response_queue [i].route_status = best_status)
                AND (addr_accessible_request_entry^.response_queue [i].route_cost = best_cost) THEN
            device.list^ [device_index].identifier := i;
            device_index := device_index + 1;
          IFEND;
        FOREND;
      IFEND;
      device.count := addr_accessible_request_entry^.save_count;

{ Ready all tasks queued on the request.

      IF addr_accessible_request_entry^.task_queue_count > 0 THEN
        addr_accessible_request_entry^.task_queue_count := addr_accessible_request_entry^.task_queue_count -1;
        WHILE addr_accessible_request_entry^.task_queue <> NIL DO
          pmp$ready_task (addr_accessible_request_entry^.task_queue^.task_id, ignore_status);
          address_accessible_task := addr_accessible_request_entry^.task_queue;
          addr_accessible_request_entry^.task_queue := address_accessible_task^.nextt;
          FREE address_accessible_task IN nav$network_paged_heap^;
        WHILEND;
      ELSE { Last task to process the request.  Discard the request.
        previous_addr_access_req_entry^ := addr_accessible_request_entry^.nextt;
        FREE addr_accessible_request_entry IN nav$network_paged_heap^;
      IFEND;
    IFEND;
    osp$clear_job_signature_lock (nlv$tm_address_accessible.lock);

  PROCEND poll_devices_for_routing_info;
?? OLDTITLE ??
?? NEWTITLE := '  search_static_table', EJECT ??

{ PURPOSE:
{   The purpose of this request is to search the static routing table for an address
{   match.  The search will continue until either a match is found to an available device
{   or a match is found to a strict static route (which may or may not be available) or the
{   complete table has been searched.  If a match is found either the device list will be updated
{   or an abnormal status will be generated.  The abnormal status will be generated if the
{   match is for a device that is unavailable and the route has been defined as a strict
{   route.

    PROCEDURE search_static_table
      (    destination_address: nlt$tcpip_address;
           protocol: nlt$tm_protocol;
           unavailable_routes: nlt$device_ids;
       VAR device: nlt$tm_device_list;
       VAR status: ost$status);

      VAR
      i: integer;

      status.normal := TRUE;
      device.count := 0;
      nlp$get_nonexclusive_access (nlv$tm_static_routing_table.lock);
      IF nlv$tm_static_routing_table.routes <> NIL THEN

      /static_search/
        FOR i := 1 TO UPPERBOUND (nlv$tm_static_routing_table.routes^) DO

          IF (destination_address.set_value * nlv$tm_static_routing_table.routes^ [i].mask.set_value) =
                (nlv$tm_static_routing_table.routes^ [i].destination_address.set_value *
                nlv$tm_static_routing_table.routes^ [i].mask.set_value) THEN

            IF (device_available (nlv$tm_static_routing_table.routes^ [i].local_device_id, protocol)) AND
                  NOT (nlv$tm_static_routing_table.routes^ [i].local_device_id IN unavailable_routes) THEN
              device.count := 1;
              device.list^ [1].identifier := nlv$tm_static_routing_table.routes^ [i].local_device_id;
              EXIT /static_search/;
            ELSE { The device is not available or it is an unavailable route.
              IF nlv$tm_static_routing_table.routes^ [i].strict_route THEN
                set_status_with_address (nae$tm_strict_device_unavailabl, nlv$tm_static_routing_table.routes^
                      [i].destination_address, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      nlv$configured_network_devices.network_device_list^
                      [nlv$tm_static_routing_table.routes^ [i].local_device_id].element, status);
                EXIT /static_search/;
              IFEND;
            IFEND;
          IFEND;
        FOREND /static_search/;
      IFEND;
      nlp$release_nonexclusive_access (nlv$tm_static_routing_table.lock);
    PROCEND search_static_table;

?? OLDTITLE ??
?? NEWTITLE := '  search_subnet_list', EJECT ??

{ PURPOSE:
{   The purpose of this request is to search the subnet list.  The subnet list may be
{   searched twice: once using the subnet mask and again using the network mask.
{   The network search will only be done if a match is not found with the subnet search.
{   If more than one network match is found, the devices will be polled to determine
{   which path(s) have the least cost but the current list is queued until the devices
{   respond.
{
{   On return the device list contains only those devices which can reach the destination.
{
{ NOTE:
{   There may be more than one subnet for each device.  The variable used_routes is used
{   keep track of which devices have already been saved on the device list.

    PROCEDURE search_subnet_list
      (    destination_address: nlt$tcpip_address;
           protocol: nlt$tm_protocol;
           unavailable_routes: nlt$device_ids;
       VAR device: nlt$tm_device_list;
       VAR status: ost$status);

      VAR
        route_cost: local_route_cost,
        subnet: ^nlt$tm_subnet_entry,
        used_routes: nlt$device_ids;

      status.normal := TRUE;
      route_cost := nlc$tm_maximum_route_cost + 1;
      device.count := 0;
      nlp$get_nonexclusive_access (nlv$tm_subnet_list.lock);
      subnet := nlv$tm_subnet_list.root;

{ Search the complete subnet list.

    /subnet_search/
      WHILE subnet <> NIL DO
        IF ((destination_address.set_value * subnet^.mask.set_value) =
              (subnet^.destination_address.set_value * subnet^.mask.set_value)) AND
              ((subnet^.protocol = nlc$tm_tcp_udp) OR (subnet^.protocol = protocol)) AND
              (NOT (subnet^.local_device IN unavailable_routes)) THEN
          IF (device.count = 0) OR (route_cost > subnet^.route_cost) THEN
            device.count := 1;
            device.list^ [1].identifier := subnet^.local_device;
            route_cost := subnet^.route_cost;
            used_routes := $nlt$device_ids [subnet^.local_device];
          ELSEIF (route_cost = subnet^.route_cost) AND (device.count < UPPERBOUND (device.list^)) THEN
            IF NOT (subnet^.local_device IN used_routes) THEN
              device.count := device.count + 1;
              device.list^ [device.count].identifier := subnet^.local_device;
              used_routes := used_routes + $nlt$device_ids [subnet^.local_device];
            IFEND;
          IFEND;
        IFEND;
        subnet := subnet^.nextt;
      WHILEND /subnet_search/;

      IF device.count = 0 THEN
        used_routes := $nlt$device_ids [];
        subnet := nlv$tm_subnet_list.root;

      /network_search/
        WHILE (subnet <> NIL) AND (device.count < UPPERBOUND (device.list^)) DO

{ If a match is found in the network search, the devices need to be polled to get
{ the costs associated with the routes.  It is possible to get a device unavailable
{ from all of the devices.  If that occurs leave the routes as they are.

          IF ((destination_address.set_value * subnet^.network_mask.set_value) =
                (subnet^.destination_address.set_value * subnet^.network_mask.set_value)) AND
                ((subnet^.protocol = nlc$tm_tcp_udp) OR (subnet^.protocol = protocol)) AND
                (NOT (subnet^.local_device IN unavailable_routes)) THEN
            IF NOT (subnet^.local_device IN used_routes) THEN
              device.count := device.count + 1;
              device.list^ [device.count].identifier := subnet^.local_device;
              used_routes := used_routes + $nlt$device_ids [subnet^.local_device];
            IFEND;
          IFEND;
          subnet := subnet^.nextt;
        WHILEND /network_search/;
        nlp$release_nonexclusive_access (nlv$tm_subnet_list.lock);

{ If all of the active devices can access this network, suppress the network poll and just let the
{ full device poll cover it.

        IF (device.count > 1) AND (device.count < UPPERBOUND (device.list^)) THEN
          poll_devices_for_routing_info (destination_address, unavailable_routes, protocol,
                { refresh = } FALSE, { network_search_refresh = } TRUE, device, status);
        ELSE
          device.count := 0;
        IFEND;
      ELSE
        nlp$release_nonexclusive_access (nlv$tm_subnet_list.lock);
      IFEND;
    PROCEND search_subnet_list;
?? OLDTITLE ??
?? NEWTITLE := '  set_status_with_address', EJECT ??

  PROCEDURE set_status_with_address
    (    condition: ost$status_condition_code;
         address: nlt$tcpip_address;
     VAR status: ost$status);

{ Format the address into the 255.255.255.255 format.

     VAR
       error_length: integer,
       error_string: string (20);

       STRINGREP (error_string, error_length, address.sub_part [1], '.', address.sub_part [2], '.',
             address.sub_part [3], '.', address.sub_part [4]);
       osp$set_status_abnormal (nac$status_id, condition, error_string (1, error_length), status);

  PROCEND set_status_with_address;
?? OLDTITLE ??
?? NEWTITLE := 'update_route_cache', EJECT ??

{ PURPOSE:
{   The purpose of this request is to update the host routing cache.  This procedure
{   is to be called when the last refresh route query response has been received.

    PROCEDURE update_route_cache
      (VAR request: nlt$tm_addr_access_req_entry);

      VAR
        best_cost: nlt$tm_route_cost,
        best_status: nlt$tm_route_status,
        cache_entry: ^nlt$tm_cache_entry,
        device_id: nlt$device_identifier,
        device_index: nlt$device_identifier,
        hash: nlt$tm_hash_range,
        i: integer,
        index: 0 .. 255;

      hash := hash_address (request.destination_address);
      osp$set_job_signature_lock (nlv$tm_route_cache.element_list [hash].lock);
      index := find_new_address_index (request.destination_address,
            nlv$tm_route_cache.element_list [hash].entry_list);
      cache_entry := ^nlv$tm_route_cache.element_list [hash].entry_list^ [index];

      IF request.save_count > 0 THEN
        cache_entry^.last_used_timestamp := #FREE_RUNNING_CLOCK (0) DIV mics_to_mills;
        cache_entry^.refresh_timestamp := cache_entry^.last_used_timestamp;
        best_cost := request.response_queue [request.first_device_index].route_cost;
        best_status := request.response_queue [request.first_device_index].route_status;

      /update_cache/
        BEGIN
          IF (cache_entry^.destination_address.full = request.destination_address.full) AND
                (cache_entry^.device_count = request.save_count) THEN
          /check_for_config_changes/
            BEGIN
              FOR i := 1 TO cache_entry^.device_count DO
                device_id := cache_entry^.device_list^ [i].device_id;
                IF (request.response_queue [device_id].route_status <> best_status ) OR
                      (request.response_queue [device_id].route_cost <> best_cost) THEN
                  EXIT /check_for_config_changes/; {configuration has changed  ... reinitialize cache.
                IFEND;
              FOREND;
              EXIT /update_cache/; {no change in configuration ... keep cache entry intact.
            END /check_for_config_changes/;
          IFEND;

{ Initialize cache entry

          cache_entry^.destination_address := request.destination_address;
          cache_entry^.device_count := request.save_count;
          cache_entry^.unavailable_routes := $nlt$device_ids[];
          device_index := 1;

          FOR i := 1 TO UPPERBOUND (request.response_queue) DO
            IF (request.response_queue [i].route_status = best_status ) AND
                  (request.response_queue [i].route_cost = best_cost) THEN
              cache_entry^.device_list^ [device_index].device_id := i;
              cache_entry^.device_list^ [device_index].usage_count := 0;
              device_index := device_index + 1;
            IFEND;
          FOREND;
        END /update_cache/;

      ELSEIF NOT request.network_search_refresh THEN

{ If none of the devices polled returned a route known and the request was a network search refresh
{ then leave the routes found on the network search of the subnet table cached.  This is how GSA
{ has designed the network search to work. Otherwise, invalidate destination address.

        cache_entry^.destination_address.full := 0;
        cache_entry^.last_used_timestamp := 0;
      IFEND;
      osp$clear_job_signature_lock (nlv$tm_route_cache.element_list [hash].lock);

    PROCEND update_route_cache;
?? OLDTITLE ??

MODEND nlm$tcpip_mgmt_access_agent;
*DECK DECK=NLM$TCP_ACCESS_AGENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access: TCP Access Agent' ??
MODULE nlm$tcp_access_agent;

{ PURPOSE:
{   This module contains procedures neccesary to support the TCP Access Agent.
{ DESIGN:
{   These procedures are called by the socket layer external interface code and in turn
{   access the channel connections. These procedures process the events received over
{   the TCP channel connections from the TCP Access Provider in the device.
{   The XDCL'd procedures have been grouped in alphabetical order.
{   This module contains code that executes in ring 3. It resides on OSF$JOB_TEMPLATE_23D.
{
{ NOTES:
{   The following abbreviations have been used in this module:
{          TCP - Transmission Control Protocol

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nac$null_connection_id
*copyc nae$tcp_condition_codes
*copyc nat$connection_id
*copyc nat$sk_listen_queue_limit
*copyc nat$sk_socket_address
*copyc nlt$cc_device_and_data_record
*copyc nlt$cl_connection
*copyc nlt$cl_layer_name
*copyc nlt$tcpaa_connection
*copyc nlt$tcpaa_event
*copyc nlt$tcpaa_protocol_data_unit
*copyc nlt$tcpaa_release_req_reason
*copyc ost$signature_lock_status
*copyc ost$status
?? POP ??
*copyc nap$namve_system_error
*copyc nlp$bm_add_message_prefix
*copyc nlp$bm_create_message
*copyc nlp$bm_extract_message_prefix
*copyc nlp$bm_flush_message
*copyc nlp$bm_get_message_length
*copyc nlp$bm_release_message
*copyc nlp$cancel_timer
*copyc nlp$cc_accept_connection
*copyc nlp$cc_disconnect
*copyc nlp$cc_initialize_template
*copyc nlp$cc_report_undelivered_data
*copyc nlp$cc_request_connection
*copyc nlp$cc_send_data
*copyc nlp$cc_send_data_fragments
*copyc nlp$cl_activate_layer
*copyc nlp$cl_deactivate_layer
*copyc nlp$cl_get_connection_processor
*copyc nlp$cl_get_layer_connection
*copyc nlp$cl_get_sap_processor
*copyc nlp$cl_initialize_template
*copyc nlp$cl_release_exclusive_access
*copyc nlp$get_exclusive_access
*copyc nlp$get_nonexclusive_access
*copyc nlp$release_exclusive_access
*copyc nlp$release_nonexclusive_access
*copyc nlp$select_timer
*copyc nlp$timer_expired
*copyc osp$clear_job_signature_lock
*copyc osp$set_job_signature_lock
*copyc osp$set_status_condition
*copyc nav$network_paged_heap
*copyc nav$network_procedures
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    nlc$tcp_ack_delay_time = 300, { Five minutes in seconds.
    nlc$tcp_max_flush_release_wait = 600000000; { Ten minutes.

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tcp_accept_socket', EJECT ??
*copy nlh$tcp_accept_socket

  PROCEDURE [XDCL] nlp$tcp_accept_socket
    (    cl_connection { input, output } : ^nlt$cl_connection;
         graceful_close: boolean;
         traffic_pattern: nat$sk_traffic_pattern;
         class: nlt$cc_connection_class;
     VAR status: ost$status);

    VAR
      accept_socket_pdu: nlt$tcpaa_accept_request_pdu,
      connection: ^nlt$tcpaa_connection,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      ignore_status: ost$status,
      layer_active: boolean,
      message_id: nlt$bm_message_id;

    nlp$cl_get_layer_connection (nlc$tcp_access_agent, cl_connection, layer_active, connection);
    IF layer_active THEN
      IF connection^.state = nlc$tcpaa_conn_await_accept THEN
        accept_socket_pdu.header.kind := nlc$tcpaa_accept_connect_req;
        accept_socket_pdu.header.length := #SIZE (nlt$tcpaa_accept_request_pdu);
        accept_socket_pdu.graceful_close := graceful_close;
        accept_socket_pdu.traffic_pattern := traffic_pattern;
        data_fragments [1].address := ^accept_socket_pdu;
        data_fragments [1].length := accept_socket_pdu.header.length;
        nlp$bm_create_message (data_fragments, message_id, ignore_status);
        nlp$cc_accept_connection (cl_connection, class, message_id, status);
        IF status.normal THEN

{ FSM Transition #14.

          connection^.state := nlc$tcpaa_conn_open;
        IFEND;
      ELSE { Unexpected state
        IF connection^.state = nlc$tcpaa_conn_open THEN
          osp$set_status_condition (nae$tcp_socket_already_accepted, status);
        ELSE
          osp$set_status_condition (nae$tcp_socket_terminated, status);
        IFEND;
      IFEND;
    ELSE { Layer not active
      osp$set_status_condition (nae$tcp_socket_terminated, status);
    IFEND;

  PROCEND nlp$tcp_accept_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tcp_connect_event_processor', EJECT ??
*copy nlh$tcp_connect_event_processor

  PROCEDURE [XDCL] nlp$tcp_connect_event_processor
    (    cl_connection { input, output } : ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

?? NEWTITLE := 'disconnect', EJECT ??

    PROCEDURE disconnect
      (    reason: nlt$tcpaa_release_req_reason);

      VAR
        data_fragment: array [1 .. 1] of nat$data_fragment,
        message_id: nlt$bm_message_id,
        release_pdu: nlt$tcpaa_release_request_pdu;

      nap$namve_system_error ({Recoverable_error=} TRUE, 'TCP Connect Event Processor DISCONNECT', NIL);
      release_pdu.header.kind := nlc$tcpaa_release_req;
      release_pdu.header.length := #SIZE (nlt$tcpaa_release_request_pdu);
      release_pdu.reason := reason;
      data_fragment [1].address := ^release_pdu;
      data_fragment [1].length := release_pdu.header.length;
      nlp$bm_create_message (data_fragment, message_id, local_status);
      nlp$cc_disconnect (cl_connection, message_id, local_status);
    PROCEND disconnect;
?? OLDTITLE, EJECT ??

    VAR
      bytes_moved: nat$data_length,
      connect_indication_pdu: nlt$tcpaa_connect_ind_pdu,
      connection: ^nlt$tcpaa_connection,
      data_length: integer,
      error_string: ^string (80),
      event_processor: nlt$cl_event_processor,
      ignore_layer_active: boolean,
      length: integer,
      local_status: ost$status,
      message_id: nlt$bm_message_id,
      user_event: nlt$tcpaa_event;

{ This procedure processes only connect indications. Other indications
{ will be an error.

    IF event.kind = nlc$cc_connect_event THEN
      message_id := event.connect.data;
      nlp$bm_get_message_length (message_id, data_length);
      IF data_length = #SIZE (nlt$tcpaa_connect_ind_pdu) THEN
        nlp$bm_extract_message_prefix (^connect_indication_pdu, data_length, message_id,
              {ignore} bytes_moved);
        IF connect_indication_pdu.header.length = data_length THEN
          IF connect_indication_pdu.header.kind = nlc$tcpaa_connect_ind THEN

{ FSM Transition #12.

            user_event.kind := nlc$tcpaa_connect_event;
            user_event.connect.destination_socket.port := connect_indication_pdu.destination_port;
            user_event.connect.destination_socket.ip_address := connect_indication_pdu.destination_ip_address;
            user_event.connect.source_socket.port := connect_indication_pdu.source_port;
            user_event.connect.source_socket.ip_address := connect_indication_pdu.source_ip_address;
            user_event.connect.device_id := event.connect.device_id;
            nlp$cl_activate_layer (nlc$tcp_access_agent, cl_connection);
            nlp$cl_get_layer_connection (nlc$tcp_access_agent, cl_connection, ignore_layer_active,
                  connection);
            connection^.device_id := event.connect.device_id;
            connection^.listen_active := FALSE;
            connection^.state := nlc$tcpaa_conn_await_accept;
            nlp$cancel_timer (connection^.flush_release_timer);
            nlp$cl_get_sap_processor (cl_connection^.application_layer, nlc$tcp_access_agent,
                  event_processor);
            nav$network_procedures [event_processor.tcpaa].tcpaa_event_processor^
                  (cl_connection, user_event, inventory_report);
            nlp$cl_get_connection_processor (cl_connection^.application_layer, nlc$tcp_access_agent,
                  event_processor);
            connection^.event_processor := event_processor.tcpaa;
          ELSE { IF connect_indication_pdu.header.kind <> nlc$tcpaa_connect_ind THEN

{ FSM Transition #13.

            disconnect (nlc$tcpaa_rr_invalid_encoding);
          IFEND;
        ELSE { IF connect_indication_pdu.header.length <> data_length THEN

{ FSM Transition #13.

          disconnect (nlc$tcpaa_rr_header_length_in);
        IFEND;
      ELSE { IF data_length <> #SIZE (nlt$tcpaa_connect_ind_pdu) THEN

{ FSM Transition #13.

        nlp$bm_release_message (message_id);
        disconnect (nlc$tcpaa_rr_header_indiscern);
      IFEND;
    ELSE { Invalid event kind
      PUSH error_string;
      STRINGREP (error_string^, length, 'Invalid channel connection event received by the TCP access agent. ',
            '  Expecting a CC connect event but a ', event.kind, ' event was received.');
      nap$namve_system_error ({Recoverable_error=} TRUE, error_string^ (1, length), NIL);
    IFEND;
  PROCEND nlp$tcp_connect_event_processor;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tcp_connect_socket', EJECT ??
*copy nlh$tcp_connect_socket

  PROCEDURE [XDCL] nlp$tcp_connect_socket
    (    cl_connection { input, output } : ^nlt$cl_connection;
         source_socket: nat$sk_socket_address;
         destination_socket: nat$sk_socket_address;
         graceful_close: boolean;
         traffic_pattern: nat$sk_traffic_pattern;
         class: nlt$cc_connection_class;
         device_id: nlt$device_identifier;
     VAR status: ost$status);

    VAR
      connection: ^nlt$tcpaa_connection,
      connect_request_pdu: nlt$tcpaa_connect_request_pdu,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      device_and_data_list: array [1 .. 1] of nlt$cc_device_and_data_record,
      event_processor: nlt$cl_event_processor,
      ignore_layer_active: boolean,
      message_id: nlt$bm_message_id;

    nlp$cl_get_layer_connection (nlc$tcp_access_agent, cl_connection, ignore_layer_active, connection);

    connect_request_pdu.header.kind := nlc$tcpaa_connect_req;
    connect_request_pdu.header.length := #SIZE (nlt$tcpaa_connect_request_pdu);
    connect_request_pdu.source_port := source_socket.port;
    connect_request_pdu.destination_port := destination_socket.port;
    connect_request_pdu.source_ip_address := source_socket.ip_address;
    connect_request_pdu.destination_ip_address := destination_socket.ip_address;
    connect_request_pdu.ack_delay_time := nlc$tcp_ack_delay_time;
    connect_request_pdu.graceful_close := graceful_close;
    connect_request_pdu.traffic_pattern := traffic_pattern;
    data_fragments [1].address := ^connect_request_pdu;
    data_fragments [1].length := connect_request_pdu.header.length;
    nlp$bm_create_message (data_fragments, message_id, {ignore} status);
    device_and_data_list [1].device_id := device_id;
    device_and_data_list [1].data := message_id;
    nlp$cc_request_connection (cl_connection, device_and_data_list, nlc$tcp_access_address, class, status);
    IF status.normal THEN

{ FSM Transition #7.

      nlp$cl_activate_layer (nlc$tcp_access_agent, cl_connection);
      connection^.device_id := device_id;
      connection^.listen_active := FALSE;
      connection^.state := nlc$tcpaa_conn_await_confirm;
      nlp$cancel_timer (connection^.flush_release_timer);
      nlp$cl_get_connection_processor (cl_connection^.application_layer, nlc$tcp_access_agent,
            event_processor);
      connection^.event_processor := event_processor.tcpaa;
    IFEND;
  PROCEND nlp$tcp_connect_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tcp_event_processor', EJECT ??
*copy nlh$tcp_event_processor

  PROCEDURE [XDCL] nlp$tcp_event_processor
    (    cl_connection { input, output } : ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

?? NEWTITLE := 'disconnect' ??
?? NEWTITLE := 'send_disconnect_indication', EJECT ??

    PROCEDURE disconnect
      (    reason: nlt$tcpaa_release_req_reason);

      VAR
        data_fragment: array [1 .. 1] of nat$data_fragment,
        message_id: nlt$bm_message_id,
        release_pdu: nlt$tcpaa_release_request_pdu;

      nap$namve_system_error ({Recoverable_error=} TRUE, 'TCP Event Processor DISCONNECT', NIL);
      release_pdu.header.kind := nlc$tcpaa_release_req;
      release_pdu.header.length := #SIZE (nlt$tcpaa_release_request_pdu);
      release_pdu.reason := reason;
      data_fragment [1].address := ^release_pdu;
      data_fragment [1].length := release_pdu.header.length;
      nlp$bm_create_message (data_fragment, message_id, local_status);
      nlp$cc_disconnect (cl_connection, message_id, local_status);
      send_disconnect_indication;
      connection^.state := nlc$tcpaa_conn_closed;
      nlp$cl_deactivate_layer (nlc$tcp_access_agent, cl_connection);
    PROCEND disconnect;

    PROCEDURE send_disconnect_indication;

{ Build TCP event.

      user_event.kind := nlc$tcpaa_release_event;
      user_event.release.reason := nlc$tcpaa_ri_protocol_error;
      nav$network_procedures [connection^.event_processor].
            tcpaa_event_processor^ (cl_connection, user_event, inventory_report);
    PROCEND send_disconnect_indication;
?? OLDTITLE ??
?? OLDTITLE, EJECT ??

    VAR
      bytes_moved: nat$data_length,
      connect_confirm_pdu: nlt$tcpaa_conn_confirm_ind_pdu,
      connection: ^nlt$tcpaa_connection,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      data_indication_pdu: nlt$tcpaa_data_ind_pdu,
      data_length: integer,
      error_string: ^string (80),
      flush_release_ind_pdu: nlt$tcpaa_flush_release_ind_pdu,
      ignore_data_length: integer,
      layer_active: boolean,
      length: integer,
      local_status: ost$status,
      message_id: nlt$bm_message_id,
      release_indication_pdu: nlt$tcpaa_release_ind_pdu,
      release_request_pdu: nlt$tcpaa_release_request_pdu,
      user_event: nlt$tcpaa_event;

    inventory_report := 0;
    nlp$cl_get_layer_connection (nlc$tcp_access_agent, cl_connection, layer_active, connection);
    IF layer_active THEN
      CASE event.kind OF
?? NEWTITLE := 'nlc$cc_data_event', EJECT ??
      = nlc$cc_data_event =
        message_id := event.data.data;
        nlp$bm_get_message_length (message_id, data_length);
        IF data_length >= #SIZE (nlt$tcpaa_data_ind_pdu) THEN
          nlp$bm_extract_message_prefix (^data_indication_pdu, #SIZE (nlt$tcpaa_data_ind_pdu), message_id,
                {ignore} bytes_moved);
          IF data_indication_pdu.header.kind = nlc$tcpaa_data_ind THEN
            IF connection^.state = nlc$tcpaa_conn_open THEN
              IF data_indication_pdu.header.length = data_length THEN

{ FSM Transition #18.

                user_event.kind := nlc$tcpaa_data_event;
                user_event.data.push_data := data_indication_pdu.push_data;
                user_event.data.urgent_data := data_indication_pdu.urgent_data;
                user_event.data.data := message_id;
                nav$network_procedures [connection^.event_processor].
                      tcpaa_event_processor^ (cl_connection, user_event, inventory_report);
              ELSE { IF data_indication_pdu.header.length <> data_length THEN

{ FSM Transition #20.

                nlp$bm_release_message (message_id);
                disconnect (nlc$tcpaa_rr_header_length_in);
              IFEND;
            ELSEIF connection^.state = nlc$tcpaa_conn_closing THEN

{ FSM Transition #27.

              nlp$bm_release_message (message_id);
            ELSE { Invalid state
              nap$namve_system_error ({Recoverable_error=} TRUE,
                    'TCPAA receive a CC event while NOT in the open state.', NIL);
              nlp$bm_release_message (message_id);
            IFEND;
          ELSE { Invalid PDU kind

{ FSM Transition #20, #29.

            nlp$bm_release_message (message_id);
            disconnect (nlc$tcpaa_rr_invalid_encoding);
          IFEND;
        ELSEIF data_length = #SIZE (nlt$tcpaa_flush_release_ind_pdu) THEN
          nlp$bm_extract_message_prefix (^flush_release_ind_pdu, #SIZE (nlt$tcpaa_flush_release_ind_pdu),
                message_id, {ignore} bytes_moved);
          IF flush_release_ind_pdu.header.kind = nlc$tcpaa_flush_release_ind THEN
            IF connection^.state = nlc$tcpaa_conn_open THEN
              IF flush_release_ind_pdu.header.length = data_length THEN

{ FSM Transition #26.

                user_event.kind := nlc$tcpaa_release_event;
                user_event.release.reason := nlc$tcpaa_ri_user_termination;
                nav$network_procedures [connection^.event_processor].
                      tcpaa_event_processor^ (cl_connection, user_event, inventory_report);
                release_request_pdu.header.kind := nlc$tcpaa_release_req;
                release_request_pdu.header.length := #SIZE (nlt$tcpaa_release_request_pdu);
                release_request_pdu.reason := nlc$tcpaa_rr_flush_confirm;
                data_fragments [1].address := ^release_request_pdu;
                data_fragments [1].length := release_request_pdu.header.length;
                nlp$bm_create_message (data_fragments, message_id, {ignore} local_status);
                nlp$cc_disconnect (cl_connection, message_id, {ignore} local_status);
                connection^.state := nlc$tcpaa_conn_closed;
                nlp$cl_deactivate_layer (nlc$tcp_access_agent, cl_connection);
              ELSE { IF flush_release_ind_pdu.header.length <> data_length THEN
                disconnect (nlc$tcpaa_rr_header_length_in);
              IFEND;
            ELSEIF connection^.state = nlc$tcpaa_conn_closing THEN
              IF flush_release_ind_pdu.header.length = data_length THEN

{ FSM Transition #28.

                release_request_pdu.header.kind := nlc$tcpaa_release_req;
                release_request_pdu.header.length := #SIZE (nlt$tcpaa_release_request_pdu);
                release_request_pdu.reason := nlc$tcpaa_rr_flush_confirm;
                data_fragments [1].address := ^release_request_pdu;
                data_fragments [1].length := release_request_pdu.header.length;
                nlp$bm_create_message (data_fragments, message_id, {ignore} local_status);
                nlp$cc_disconnect (cl_connection, message_id, {ignore} local_status);
                connection^.state := nlc$tcpaa_conn_closed;
                nlp$cl_deactivate_layer (nlc$tcp_access_agent, cl_connection);
              ELSE { IF flush_release_ind_pdu.header.length <> data_length THEN

{ FSM Transition #29.

                disconnect (nlc$tcpaa_rr_header_length_in);
              IFEND;
            ELSE { Invalid state
              nap$namve_system_error ({Recoverable_error=} TRUE,
                    'TCPAA receive a CC event while NOT in the open state.', NIL);
            IFEND;
          ELSE { Invalid PDU kind

{ FSM Transition #20, #29.

            disconnect (nlc$tcpaa_rr_invalid_encoding);
          IFEND;
        ELSE { Invalid data length.

{ FSM Transition #20, #29.

          nlp$bm_release_message (message_id);
          disconnect (nlc$tcpaa_rr_header_length_in);
        IFEND;
?? OLDTITLE ??
?? NEWTITLE := 'nlc$cc_accept_event', EJECT ??
      = nlc$cc_accept_event =
        message_id := event.accept.data;
        IF connection^.state = nlc$tcpaa_conn_await_confirm THEN
          nlp$bm_get_message_length (message_id, data_length);
          IF data_length = #SIZE (nlt$tcpaa_conn_confirm_ind_pdu) THEN
            nlp$bm_extract_message_prefix (^connect_confirm_pdu, data_length, message_id,
                  {ignore} bytes_moved);
            IF connect_confirm_pdu.header.length = data_length THEN
              IF connect_confirm_pdu.header.kind = nlc$tcpaa_connect_confirm_ind THEN
                IF NOT connection^.listen_active THEN

{ FSM Transition #9.

                  user_event.kind := nlc$tcpaa_connect_confirm_event;
                  user_event.connect_confirm.local_port := connect_confirm_pdu.local_port;
                  nav$network_procedures [connection^.event_processor].
                        tcpaa_event_processor^ (cl_connection, user_event, inventory_report);
                  connection^.state := nlc$tcpaa_conn_open;
                ELSE { listen active

{ FSM Transition #3.

                  disconnect (nlc$tcpaa_rr_invalid_encoding);
                IFEND;
              ELSEIF connect_confirm_pdu.header.kind = nlc$tcpaa_listen_confirm_ind THEN
                IF connection^.listen_active THEN

{ FSM Transition #2.

                  user_event.kind := nlc$tcpaa_listen_confirm_event;
                  user_event.listen_confirm.local_port := connect_confirm_pdu.local_port;
                  nav$network_procedures [connection^.event_processor].
                        tcpaa_event_processor^ (cl_connection, user_event, inventory_report);
                  connection^.state := nlc$tcpaa_conn_open;
                ELSE { Listen not active

{ FSM Transition #9.

                  disconnect (nlc$tcpaa_rr_invalid_encoding);
                IFEND;
              ELSE { Invalid pdu kind

{ FSM Transition #3, #9.

                disconnect (nlc$tcpaa_rr_invalid_encoding);
              IFEND;
            ELSE { IF connect_confirm_pdu.header.length <> data_length THEN

{ FSM Transition #3, #9.

              disconnect (nlc$tcpaa_rr_header_length_in);
            IFEND;
          ELSE { IF data_length <> #SIZE (nlt$tcpaa_conn_confirm_ind_pdu) THEN

{ FSM Transition #3, #9.

            nlp$bm_release_message (message_id);
            disconnect (nlc$tcpaa_rr_header_indiscern);
          IFEND;
        ELSE { IF connection^.state <> nlc$tcpaa_conn_await_confirm THEN

{ FSM Transition #3, #9.

          nlp$bm_release_message (message_id);
          disconnect (nlc$tcpaa_rr_invalid_encoding);
        IFEND;
?? OLDTITLE ??
?? NEWTITLE := 'nlc$cc_clear_to_send_event', EJECT ??
      = nlc$cc_clear_to_send_event =
        user_event.kind := nlc$tcpaa_clear_to_send_event;
        nav$network_procedures [connection^.event_processor].
              tcpaa_event_processor^ (cl_connection, user_event, inventory_report);

?? OLDTITLE ??
?? NEWTITLE := 'nlc$cc_disconnect_event', EJECT ??
      = nlc$cc_disconnect_event =
        message_id := event.disconnect.data;
        IF event.disconnect.reason = nlc$cc_dr_normal_disconnect THEN
          IF (connection^.state <> nlc$tcpaa_conn_closing) AND
                (connection^.state <> nlc$tcpaa_conn_closed) THEN
            nlp$bm_get_message_length (message_id, data_length);
            IF data_length = #SIZE (nlt$tcpaa_release_ind_pdu) THEN
              nlp$bm_extract_message_prefix (^release_indication_pdu, data_length, message_id,
                    {ignore} bytes_moved);
              IF release_indication_pdu.header.length = data_length THEN
                IF release_indication_pdu.header.kind = nlc$tcpaa_release_ind THEN
                  IF NOT connection^.listen_active THEN

{ FSM Transition #11, #16.

                    user_event.kind := nlc$tcpaa_release_event;
                    user_event.release.reason := release_indication_pdu.reason;
                    nav$network_procedures [connection^.event_processor].
                          tcpaa_event_processor^ (cl_connection, user_event, inventory_report);
                    connection^.state := nlc$tcpaa_conn_closed;
                  ELSE { listen active

{ FSM Transition #5.

                    send_disconnect_indication;
                  IFEND;
                ELSEIF release_indication_pdu.header.kind = nlc$tcpaa_listen_reject_ind THEN
                  IF connection^.listen_active THEN

{ FSM Transition #4.

                    user_event.kind := nlc$tcpaa_listen_reject_event;
                    user_event.listen_reject.reason := release_indication_pdu.reason;
                    nav$network_procedures [connection^.event_processor].
                          tcpaa_event_processor^ (cl_connection, user_event, inventory_report);
                    connection^.state := nlc$tcpaa_conn_closed;
                  ELSE { listen not active

{ FSM Transition #5.

                    send_disconnect_indication;
                  IFEND;
                ELSE { Invalid pdu kind.

{ FSM Transition #5.

                  send_disconnect_indication;
                IFEND;
              ELSE { IF release_indication_pdu.header.length <> data_length THEN

{ FSM Transition #5.

                send_disconnect_indication;
              IFEND;
            ELSE { IF data_length <> #SIZE (nlt$tcpaa_release_ind_pdu) THEN

{ FSM Transition #5.

              send_disconnect_indication;
              nlp$bm_release_message (message_id);
            IFEND;
          ELSE { IF connection^.state = nlc$tcpaa_conn_closing or nlc$tcpaa_conn_closed THEN

{ FSM Transition #30.

            nlp$bm_release_message (message_id);
          IFEND;
        ELSE { Not a normal disconnect
          IF (connection^.state <> nlc$tcpaa_conn_closing) AND
                (connection^.state <> nlc$tcpaa_conn_closed) THEN

{ FSM Transition #4, #10, #15, #22, #24.

            user_event.kind := nlc$tcpaa_release_event;
            user_event.release.reason := nlc$tcpaa_ri_network_disconnect;
            user_event.release.cc_disconnect_reason := event.disconnect.reason;
            nav$network_procedures [connection^.event_processor].
                  tcpaa_event_processor^ (cl_connection, user_event, inventory_report);
            connection^.state := nlc$tcpaa_conn_closed;
          IFEND;

{ FSM Transition #30.

          nlp$bm_release_message (message_id);
        IFEND;
        nlp$cl_deactivate_layer (nlc$tcp_access_agent, cl_connection);
      ELSE { Invalid event
        PUSH error_string;
        STRINGREP (error_string^, length,
              'Invalid channel connection event received by the TCP access agent.  A ', event.kind,
              ' event was received.');
        nap$namve_system_error ({Recoverable_error=} TRUE, error_string^ (1, length), NIL);
        IF event.kind = nlc$cc_connect_event THEN
          message_id := event.connect.data;
          nlp$bm_release_message (message_id);
        IFEND;
      CASEND;
    ELSE { Layer inactive
      nap$namve_system_error ({Recoverable_error=} TRUE, 'TCP Access Agent layer is inactive.', NIL);
      CASE event.kind OF
      = nlc$cc_connect_event =
        message_id := event.connect.data;
      = nlc$cc_accept_event =
        message_id := event.accept.data;
      = nlc$cc_data_event =
        message_id := event.data.data;
      = nlc$cc_expedited_data_event =
        message_id := event.expedited_data.data;
      = nlc$cc_disconnect_event =
        message_id := event.disconnect.data;
      ELSE
        message_id := nlv$bm_null_message_id;
      CASEND;
      nlp$bm_release_message (message_id);
    IFEND;
  PROCEND nlp$tcp_event_processor;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tcp_flush_release_socket', EJECT ??
*copy nlh$tcp_flush_release_socket

  PROCEDURE [XDCL] nlp$tcp_flush_release_socket
    (    cl_connection { input, output } : ^nlt$cl_connection;
     VAR status: ost$status);

    VAR
      connection: ^nlt$tcpaa_connection,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      flush_release_request_pdu: nlt$tcpaa_flush_release_req_pdu,
      ignore_status: ost$status,
      layer_active: boolean,
      message_id: nlt$bm_message_id;

    nlp$cl_get_layer_connection (nlc$tcp_access_agent, cl_connection, layer_active, connection);
    IF layer_active THEN
      IF connection^.state = nlc$tcpaa_conn_open THEN

{ FSM Transition #25.

        flush_release_request_pdu.header.kind := nlc$tcpaa_flush_release_req;
        flush_release_request_pdu.header.length := #SIZE (nlt$tcpaa_flush_release_req_pdu);
        data_fragments [1].address := ^flush_release_request_pdu;
        data_fragments [1].length := flush_release_request_pdu.header.length;
        nlp$bm_create_message (data_fragments, message_id, ignore_status);
        nlp$cc_send_data (cl_connection, message_id, status);
        IF status.normal THEN
          connection^.state := nlc$tcpaa_conn_closing;

{ Start the timer task.

          nlp$select_timer (nlc$tcp_max_flush_release_wait, 0, connection^.flush_release_timer);
        IFEND;
      ELSE { Unexpected state
        IF (connection^.state = nlc$tcpaa_conn_closed) OR (connection^.state = nlc$tcpaa_conn_closing) THEN
          osp$set_status_condition (nae$tcp_socket_terminated, status);
        ELSE
          osp$set_status_condition (nae$tcp_socket_not_open, status);
        IFEND;
      IFEND;
    ELSE { Layer inactive
      osp$set_status_condition (nae$tcp_socket_terminated, status);
    IFEND;

  PROCEND nlp$tcp_flush_release_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tcp_flush_release_timer', EJECT ??

  PROCEDURE [XDCL] nlp$tcp_flush_release_timer
    (    current_time: integer;
         cl_connection: ^nlt$cl_connection);

    VAR
      connection: ^nlt$tcpaa_connection,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      ignore_status: ost$status,
      layer_active: boolean,
      message_id: nlt$bm_message_id,
      release_request_pdu: nlt$tcpaa_release_request_pdu;

    nlp$cl_get_layer_connection (nlc$tcp_access_agent, cl_connection, layer_active, connection);
    IF layer_active THEN
      IF connection^.state = nlc$tcpaa_conn_closing THEN
        IF nlp$timer_expired (current_time, connection^.flush_release_timer) THEN
          release_request_pdu.header.kind := nlc$tcpaa_release_req;
          release_request_pdu.header.length := #SIZE (nlt$tcpaa_release_request_pdu);
          release_request_pdu.reason := nlc$tcpaa_rr_user_request;
          data_fragments [1].address := ^release_request_pdu;
          data_fragments [1].length := release_request_pdu.header.length;
          nlp$bm_create_message (data_fragments, message_id, ignore_status);
          nlp$cc_disconnect (cl_connection, message_id, ignore_status);
          connection^.state := nlc$tcpaa_conn_closed;
          nlp$cl_deactivate_layer (nlc$tcp_access_agent, cl_connection);
        IFEND;
      IFEND;
    IFEND;
  PROCEND nlp$tcp_flush_release_timer;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tcp_initialize', EJECT ??
*copy nlh$tcp_initialize

  PROCEDURE [XDCL] nlp$tcp_initialize
    (    application_layer: nlt$cl_application_layer;
         connect_event_processor: nat$network_procedure;
         event_processor: nat$network_procedure);

    VAR
      connection_processor: nlt$cl_event_processor,
      sap_processor: nlt$cl_event_processor;

    sap_processor.layer := nlc$tcp_access_agent;
    sap_processor.tcpaa := connect_event_processor;
    connection_processor.layer := nlc$tcp_access_agent;
    connection_processor.tcpaa := event_processor;
    nlp$cl_initialize_template (application_layer, nlc$tcp_access_agent, #SIZE (nlt$tcpaa_connection),
          {maximum_protocol_header_size =} 0, sap_processor, nac$nil, connection_processor,
          nlc$tcp_flush_release_timer);
    nlp$cc_initialize_template (application_layer);
  PROCEND nlp$tcp_initialize;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tcp_listen_socket', EJECT ??
*copy nlh$tcp_listen_socket

  PROCEDURE [XDCL] nlp$tcp_listen_socket
    (    cl_connection { input, output } : ^nlt$cl_connection;
         local_port: nat$sk_port_number;
         queue_limit: nat$sk_listen_queue_limit;
         selection_criteria: nat$sk_socket_address;
         device_id: nlt$device_identifier;
         class: nlt$cc_connection_class;
     VAR status: ost$status);

    VAR
      connection: ^nlt$tcpaa_connection,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      device_and_data_list: array [1 .. 1] of nlt$cc_device_and_data_record,
      event_processor: nlt$cl_event_processor,
      ignore_layer_active: boolean,
      ignore_status: ost$status,
      listen_request_pdu: nlt$tcpaa_listen_request_pdu,
      message_id: nlt$bm_message_id;


{ FSM Transition #1.

    nlp$cl_get_layer_connection (nlc$tcp_access_agent, cl_connection, ignore_layer_active, connection);
    listen_request_pdu.header.kind := nlc$tcpaa_listen_req;
    listen_request_pdu.header.length := #SIZE (nlt$tcpaa_listen_request_pdu);
    listen_request_pdu.local_port := local_port;
    listen_request_pdu.queue_limit := queue_limit;
    listen_request_pdu.source_port := selection_criteria.port;
    listen_request_pdu.ack_delay_time := nlc$tcp_ack_delay_time;
    listen_request_pdu.source_ip_address := selection_criteria.ip_address;
    data_fragments [1].address := ^listen_request_pdu;
    data_fragments [1].length := listen_request_pdu.header.length;
    nlp$bm_create_message (data_fragments, message_id, ignore_status);
    device_and_data_list [1].device_id := device_id;
    device_and_data_list [1].data := message_id;
    nlp$cc_request_connection (cl_connection, device_and_data_list, nlc$tcp_access_address, class, status);
    IF status.normal THEN
      nlp$cl_activate_layer (nlc$tcp_access_agent, cl_connection);
      connection^.device_id := device_id;
      connection^.listen_active := TRUE;
      connection^.state := nlc$tcpaa_conn_await_confirm;
      nlp$cl_get_connection_processor (cl_connection^.application_layer, nlc$tcp_access_agent,
            event_processor);
      connection^.event_processor := event_processor.tcpaa;
    IFEND;

  PROCEND nlp$tcp_listen_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tcp_release_socket', EJECT ??
*copy nlh$tcp_release_socket

  PROCEDURE [XDCL] nlp$tcp_release_socket
    (    cl_connection { input, output } : ^nlt$cl_connection;
     VAR status: ost$status);

    VAR
      connection: ^nlt$tcpaa_connection,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      ignore_status: ost$status,
      layer_active: boolean,
      message_id: nlt$bm_message_id,
      release_request_pdu: nlt$tcpaa_release_request_pdu;

    nlp$cl_get_layer_connection (nlc$tcp_access_agent, cl_connection, layer_active, connection);
    IF layer_active THEN
      IF connection^.state <> nlc$tcpaa_conn_closed THEN

{ FSM Transition #6, #21, #23, #31.

        release_request_pdu.header.kind := nlc$tcpaa_release_req;
        release_request_pdu.header.length := #SIZE (nlt$tcpaa_release_request_pdu);
        release_request_pdu.reason := nlc$tcpaa_rr_user_request;
        data_fragments [1].address := ^release_request_pdu;
        data_fragments [1].length := release_request_pdu.header.length;
        nlp$bm_create_message (data_fragments, message_id, ignore_status);
        nlp$cc_disconnect (cl_connection, message_id, ignore_status);
        connection^.state := nlc$tcpaa_conn_closed;
        nlp$cl_deactivate_layer (nlc$tcp_access_agent, cl_connection);
      ELSE
        osp$set_status_condition (nae$tcp_socket_terminated, status);
      IFEND;
    ELSE { layer inactive
      osp$set_status_condition (nae$tcp_socket_terminated, status);
    IFEND;

  PROCEND nlp$tcp_release_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tcp_report_undelivered_data', EJECT ??
*copy nlh$tcp_report_undelivered_data

  PROCEDURE [XDCL] nlp$tcp_report_undelivered_data
    (    cl_connection { input, output } : ^nlt$cl_connection;
         accumulated_message_buffers: integer);

    VAR
      connection: ^nlt$tcpaa_connection,
      layer_active: boolean;

    nlp$cl_get_layer_connection (nlc$tcp_access_agent, cl_connection, layer_active, connection);
    IF layer_active THEN
      nlp$cc_report_undelivered_data (cl_connection, accumulated_message_buffers);
    IFEND;
  PROCEND nlp$tcp_report_undelivered_data;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tcp_send_data', EJECT ??
*copy nlh$tcp_send_data

  PROCEDURE [XDCL] nlp$tcp_send_data
    (    cl_connection { input, output } : ^nlt$cl_connection;
         user_data: nlt$bm_message_id;
         push_data: boolean;
         urgent_data: boolean;
     VAR status: ost$status);

    VAR
      connection: ^nlt$tcpaa_connection,
      data_length: integer,
      data_request_pdu: nlt$tcpaa_data_request_pdu,
      layer_active: boolean,
      message_id: nlt$bm_message_id;

    nlp$cl_get_layer_connection (nlc$tcp_access_agent, cl_connection, layer_active, connection);
    IF layer_active THEN
      IF connection^.state = nlc$tcpaa_conn_open THEN

{ FSM Transition #17.

        data_request_pdu.header.kind := nlc$tcpaa_data_req;
        nlp$bm_get_message_length (user_data, data_length);
        data_request_pdu.header.length := #SIZE (nlt$tcpaa_data_request_pdu) + data_length;
        data_request_pdu.urgent_data := urgent_data;
        data_request_pdu.push_data := push_data;
        message_id := user_data;
        nlp$bm_add_message_prefix (^data_request_pdu, #SIZE (nlt$tcpaa_data_request_pdu), message_id);
        nlp$cc_send_data (cl_connection, message_id, status);
      ELSE
        IF (connection^.state = nlc$tcpaa_conn_closed) OR (connection^.state = nlc$tcpaa_conn_closing) THEN
          osp$set_status_condition (nae$tcp_socket_terminated, status);
        ELSE
          osp$set_status_condition (nae$tcp_socket_not_open, status);
        IFEND;
      IFEND;
    ELSE { Layer not active
      osp$set_status_condition (nae$tcp_socket_terminated, status);
    IFEND;

  PROCEND nlp$tcp_send_data;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tcp_send_data_fragments', EJECT ??
*copy nlh$tcp_send_data_fragments

  PROCEDURE [XDCL] nlp$tcp_send_data_fragments
    (    cl_connection { input, output } : ^nlt$cl_connection;
         user_data: nat$data_fragments;
         push_data: boolean;
         urgent_data: boolean;
     VAR status: ost$status);

    VAR
      connection: ^nlt$tcpaa_connection,
      data_length: integer,
      data_request_pdu: nlt$tcpaa_data_request_pdu,
      i: integer,
      layer_active: boolean,
      tcpaa_pdu: ^nat$data_fragments;

    nlp$cl_get_layer_connection (nlc$tcp_access_agent, cl_connection, layer_active, connection);
    IF layer_active THEN
      IF connection^.state = nlc$tcpaa_conn_open THEN

{ FSM Transition #17.

        data_request_pdu.header.kind := nlc$tcpaa_data_req;

        data_length := 0;
        FOR i := LOWERBOUND (user_data) TO UPPERBOUND (user_data) DO
          IF user_data [i].address <> NIL THEN
            data_length := data_length + user_data [i].length;
          IFEND;
        FOREND;

        data_request_pdu.header.length := #SIZE (nlt$tcpaa_data_request_pdu) + data_length;
        data_request_pdu.urgent_data := urgent_data;
        data_request_pdu.push_data := push_data;

        PUSH tcpaa_pdu: [1 .. (UPPERBOUND (user_data) + 1)];
        tcpaa_pdu^ [1].address := ^data_request_pdu;
        tcpaa_pdu^ [1].length := #SIZE (data_request_pdu);
        FOR i := 2 TO UPPERBOUND (tcpaa_pdu^) DO
          tcpaa_pdu^ [i] := user_data [i - 1];
        FOREND;
        nlp$cc_send_data_fragments (cl_connection, tcpaa_pdu^, status);
      ELSE
        IF (connection^.state = nlc$tcpaa_conn_closed) OR (connection^.state = nlc$tcpaa_conn_closing) THEN
          osp$set_status_condition (nae$tcp_socket_terminated, status);
        ELSE
          osp$set_status_condition (nae$tcp_socket_not_open, status);
        IFEND;
      IFEND;
    ELSE { Layer not active
      osp$set_status_condition (nae$tcp_socket_terminated, status);
    IFEND;

  PROCEND nlp$tcp_send_data_fragments;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$tcp_set_socket_options', EJECT ??
*copy nlh$tcp_set_socket_options

  PROCEDURE [XDCL] nlp$tcp_set_socket_options
    (    cl_connection { input, output } : ^nlt$cl_connection;
         graceful_close: boolean;
         traffic_pattern: nat$sk_traffic_pattern;
     VAR status: ost$status);

    VAR
      connection: ^nlt$tcpaa_connection,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      ignore_status: ost$status,
      layer_active: boolean,
      message_id: nlt$bm_message_id,
      set_options_request_pdu: nlt$tcpaa_set_options_req_pdu;

    nlp$cl_get_layer_connection (nlc$tcp_access_agent, cl_connection, layer_active, connection);
    IF layer_active THEN
      IF connection^.state = nlc$tcpaa_conn_open THEN

{ FSM Transition #19.

        set_options_request_pdu.header.kind := nlc$tcpaa_set_options_req;
        set_options_request_pdu.header.length := #SIZE (nlt$tcpaa_set_options_req_pdu);
        set_options_request_pdu.graceful_close := graceful_close;
        set_options_request_pdu.traffic_pattern := traffic_pattern;
        set_options_request_pdu.ack_delay_time := nlc$tcp_ack_delay_time;
        data_fragments [1].address := ^set_options_request_pdu;
        data_fragments [1].length := set_options_request_pdu.header.length;
        nlp$bm_create_message (data_fragments, message_id, ignore_status);
        nlp$cc_send_data (cl_connection, message_id, status);
      ELSE
        IF (connection^.state = nlc$tcpaa_conn_closed) OR (connection^.state = nlc$tcpaa_conn_closing) THEN
          osp$set_status_condition (nae$tcp_socket_terminated, status);
        ELSE
          osp$set_status_condition (nae$tcp_socket_not_open, status);
        IFEND;
      IFEND;
    ELSE { Layer not active
      osp$set_status_condition (nae$tcp_socket_terminated, status);
    IFEND;

  PROCEND nlp$tcp_set_socket_options;
?? OLDTITLE ??
MODEND nlm$tcp_access_agent;
*DECK DECK=NLM$TIMER_MONITOR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access : Timer Monitor Task' ??
MODULE nlm$timer_monitor;

{    PURPOSE:
{      The purpose of this module/task is to call all connection layer's connection timer
{      evaluator for active connections and the service access point timer evaluator for
{      all layers on a connection layer path.
{
{      This module shares the knowledge of the connection list with the connection layer
{      connection manager.
{
{    DESIGN:
{      This module is designed to be contained in the OSF$JOB_TEMPLATE_23D library and to execute
{      in the network job environemnt.
{
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nlt$cl_connections
*copyc nlt$timer
*copyc oss$network_paged
*copyc oss$mainframe_wired
*copyc ost$status
*copyc pmt$program_parameters
?? POP ??
*copyc nlp$cl_zero_terminated_connects
*copyc nlp$cl_get_nonexclusive_to_root
*copyc nlp$cl_release_nonexclu_to_root
*copyc nlp$cl_get_connection_access
*copyc nlp$cl_release_exclusive_access
*copyc nlp$cl_release_connection
*copyc nlp$cl_get_conn_timer_evaluator
*copyc nlp$cl_get_sap_timer_evaluator
*copyc nlp$cl_layer_on_path
*copyc nlp$select_timer
*copyc nlp$timer_expired
*copyc osp$free_heap_pages
*copyc pmp$get_executing_task_gtid
*copyc pmp$wait
*copyc jmv$executing_within_system_job
*copyc nav$network_wired_heap
*copyc nlv$bm_buffers_freed
*copyc nlv$cl_connections
*copyc nlv$timer_monitor_task
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$monitor_timers', EJECT ??

  PROCEDURE [XDCL, #GATE] nlp$monitor_timers (parameters: pmt$program_parameters;
    VAR status: ost$status);

    CONST
      free_page_timer_duration = 90 * 1000 * 1000;

    VAR
      free_page_timer: nlt$timer,
      last_time,
      time_to_monitor,
      current_time: integer;

    status.normal := TRUE;
    IF NOT jmv$executing_within_system_job THEN
      RETURN;
    IFEND;
    pmp$get_executing_task_gtid (nlv$timer_monitor_task);
    nlp$select_timer (free_page_timer_duration, 0, free_page_timer);
    last_time := #free_running_clock (0);
    WHILE TRUE DO
      current_time := #free_running_clock (0);
      IF ((current_time - last_time) > (nlc$sap_timer_duration DIV 2)) THEN
        IF ((nlv$cl_connections.list <> NIL) AND (nlv$cl_connections.active > 0)) THEN
          last_time := current_time;
          evaluate_connection_timers (current_time);
          evaluate_sap_timers (current_time);
        ELSE
          IF ((current_time - last_time) > (nlc$sap_timer_duration - 100000)) THEN
            last_time := current_time;
            evaluate_sap_timers (current_time);
          IFEND;
        IFEND;
      ELSE
        IF ((nlv$cl_connections.list <> NIL) AND (nlv$cl_connections.active > 0)) THEN
          release_terminated_connections;
        IFEND;
      IFEND;

      IF nlp$timer_expired (current_time, free_page_timer) THEN
        IF nlv$bm_buffers_freed THEN
          nlv$bm_buffers_freed := FALSE;
          osp$free_heap_pages (nav$network_wired_heap);
        IFEND;
        nlp$select_timer (free_page_timer_duration, 0, free_page_timer);
      IFEND;

      time_to_monitor := (#free_running_clock (0) - last_time);
      IF (time_to_monitor < (nlc$sap_timer_duration - 100000)) THEN
        pmp$wait (((nlc$sap_timer_duration - time_to_monitor) DIV 1000), (nlc$sap_timer_duration DIV
              1000));
      IFEND;
    WHILEND;
  PROCEND nlp$monitor_timers;
?? OLDTITLE ??
?? NEWTITLE := 'evaluate_connection_timers', EJECT ??

  PROCEDURE evaluate_connection_timers (current_time: ost$free_running_clock);

    VAR
      root: nlt$cl_reference_number,
      connection: ^nlt$cl_connection,
      next_connection: ^nlt$cl_connection,
      access_gained: boolean,
      layer: nlt$cl_layer_name,
      timer_evaluator: nlt$cl_evaluat_connection_timer,
      layer_connections: ^nlt$cl_layer_connections,
      inactive_connection_found: boolean,
      inactive_connection_entry,
      last_inactive_connection_entry: nlt$cl_reference_number,
      inactive_connection_roots: ^array [0 .. * ] of nlt$cl_reference_number;

    inactive_connection_found := FALSE;

  /scan_roots/
    FOR root := LOWERBOUND (nlv$cl_connections.list^) TO UPPERBOUND (nlv$cl_connections.list^) DO
      IF nlv$cl_connections.list^ [root].first <> NIL THEN
      nlp$cl_get_nonexclusive_to_root (root);
      connection := nlv$cl_connections.list^ [root].first;

    /scan_stem/
      WHILE (connection <> NIL) DO
        next_connection := connection^.nextt;
        nlp$cl_get_connection_access (connection, access_gained);
        IF access_gained THEN
          FOR layer := UPPERVALUE (nlt$cl_layer_name) DOWNTO connection^.application_layer DO
            IF (nlp$cl_layer_on_path (connection^.application_layer, layer) AND (layer IN connection^.
                  layers_active)) THEN
              nlp$cl_get_conn_timer_evaluator (connection^.application_layer, layer, timer_evaluator);
              IF (timer_evaluator <> NIL) THEN
                timer_evaluator^ (current_time, connection);
              IFEND;
            IFEND;
          FOREND;
          IF (connection^.layers_active = $nlt$cl_layers []) THEN
            IF inactive_connection_found THEN
              IF (root <> inactive_connection_roots^ [last_inactive_connection_entry]) THEN
                last_inactive_connection_entry := last_inactive_connection_entry + 1;
                inactive_connection_roots^ [last_inactive_connection_entry] := root;
              IFEND;
            ELSE
              PUSH inactive_connection_roots: [LOWERBOUND (nlv$cl_connections.list^) .. UPPERBOUND
                    (nlv$cl_connections.list^)];
              last_inactive_connection_entry := LOWERBOUND (nlv$cl_connections.list^);
              inactive_connection_roots^ [last_inactive_connection_entry] := root;
              inactive_connection_found := TRUE;
            IFEND;
          IFEND;
          nlp$cl_release_exclusive_access (connection);
        IFEND;
        connection := next_connection;
      WHILEND /scan_stem/;
      nlp$cl_release_nonexclu_to_root (root);
      IFEND;
    FOREND /scan_roots/;

    IF inactive_connection_found THEN
      nlp$cl_zero_terminated_connects;

    /scan_roots_for_inactive/
      FOR inactive_connection_entry := LOWERBOUND (nlv$cl_connections.list^) TO last_inactive_connection_entry
            DO
        root := inactive_connection_roots^ [inactive_connection_entry];
        nlp$cl_get_nonexclusive_to_root (root);
        connection := nlv$cl_connections.list^ [root].first;

      /scan_stem_for_inactive/
        WHILE (connection <> NIL) DO
          IF (connection^.layers_active = $nlt$cl_layers []) THEN
            next_connection := connection^.nextt;
            nlp$cl_release_nonexclu_to_root (root);
            nlp$cl_release_connection (connection^.identifier);
            nlp$cl_get_nonexclusive_to_root (root);

{ The assumption is that an inactive connection is released from the root only by the timer task.

            connection := next_connection;
          ELSE
            connection := connection^.nextt;
          IFEND;
        WHILEND /scan_stem_for_inactive/;
        nlp$cl_release_nonexclu_to_root (root);
      FOREND /scan_roots_for_inactive/;
    IFEND;
  PROCEND evaluate_connection_timers;
?? OLDTITLE ??
?? NEWTITLE := 'evaluate_sap_timers', EJECT ??

  PROCEDURE evaluate_sap_timers (current_time: ost$free_running_clock);

    VAR
      layer: nlt$cl_layer_name,
      application_layer: nlt$cl_application_layer,
      timer_evaluator: nlt$cl_evaluate_sap_timer;

    FOR application_layer := LOWERVALUE (nlt$cl_application_layer) TO UPPERVALUE (nlt$cl_application_layer) DO
      FOR layer := LOWERVALUE (nlt$cl_layer_name) TO UPPERVALUE (nlt$cl_layer_name) DO
        IF nlp$cl_layer_on_path (application_layer, layer) THEN
          nlp$cl_get_sap_timer_evaluator (application_layer, layer, timer_evaluator);
          IF (timer_evaluator <> NIL) THEN
            timer_evaluator^ (current_time);
          IFEND;
        IFEND;
      FOREND;
    FOREND;
  PROCEND evaluate_sap_timers;
?? OLDTITLE ??
?? NEWTITLE := 'release_terminated_connections', EJECT ??

  PROCEDURE release_terminated_connections;

    VAR
      root: nlt$cl_reference_number,
      connection: ^nlt$cl_connection,
      next_connection: ^nlt$cl_connection;

    nlp$cl_zero_terminated_connects;

  /scan_roots_for_inactive/
    FOR root := LOWERBOUND (nlv$cl_connections.list^) TO UPPERBOUND (nlv$cl_connections.list^) DO
      IF nlv$cl_connections.list^ [root].first <> NIL THEN
        nlp$cl_get_nonexclusive_to_root (root);
        connection := nlv$cl_connections.list^ [root].first;

      /scan_stem_for_inactive/
        WHILE (connection <> NIL) DO
          IF (connection^.layers_active = $nlt$cl_layers []) THEN
            next_connection := connection^.nextt;
            nlp$cl_release_nonexclu_to_root (root);
            nlp$cl_release_connection (connection^.identifier);
            nlp$cl_get_nonexclusive_to_root (root);

{ The assumption is that an inactive connection is released from the root only by the timer task.

            connection := next_connection;
          ELSE
            connection := connection^.nextt;
          IFEND;
        WHILEND /scan_stem_for_inactive/;
        nlp$cl_release_nonexclu_to_root (root);
      IFEND;
    FOREND /scan_roots_for_inactive/;
  PROCEND release_terminated_connections;
?? OLDTITLE ??
MODEND nlm$timer_monitor;
*DECK DECK=NLM$TRANSPORT_ACCESS_AGENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE NETWORK ACCESS: Transport Access Agent' ??
MODULE nlm$transport_access_agent;

{ PURPOSE:
{   This module contains the procedures necessary to communicate with an OSI transport layer
{   that exists in a connected communications device.  This module contains the complete
{   transport access agent (TAA) with the exception of nlp$ta_send_data which is an inline
{   procedure.
{
{ DESIGN:
{   The transport access agent is an interface to the osi transport layer which
{   resides in a connected communications device.  Requests can be sent from the TAA
{   to the device and the device in turn can send requests (indications) to the TAA.
{
{   The main function of the transport access agent (TAA) is to send data to a
{   communication device and receive data from the communication device.  To establish
{   communications with the communications device the first step is to issue a connect
{   request or wait to receive a connect indication from the device.  After the connect
{   request has been received the receiver (the peer) can accept the connection with a
{   connect confirm.  Once the connect confirm has been issued or received the
{   the communication path (connection) is open and ready to process data requests and
{   data indications.
{
{   There are two types of data: normal data (data) and expedited data.
{   Data is subject to flow control whereas expedited data is not.  Although,
{   an expedited data request may be rejected if the current number of outstanding
{   expedited data requests equals the maximum unconfirmed expedited data requests.
{
{   The communication path is broken when the user issues a disconnect request
{   or a disconnect indication is received.
{
{ NOTES:
{   If the transport access agent detects an error on any request or any indication
{   it will release all data associated with the erroneous request or indication.
{   The procedures are in a modified alphabetical order.  The first two procedures
{   are the event processors.  The following procedures are in alphabetical order.
{   The design document for this module is A7947.

?? NEWTITLE := 'Finite State Machine Requests', EJECT ??
{
{ \--------------+------------------+------------------+------------------+------------------+---------------+
{  ----\   STATE | nlc$ta_closed    | nlc$ta_connect_  | nlc$ta_connect_  | nlc$ta_open &    | nlc$ta_open & |
{        ----\   |                  | confirm_wait     | response_wait    |  count < max     |  count = max  |
{  REQUEST   ----|        (1)       |        (2)       |        (3)       |    *   (4) **    |    * (4) **   |
{ ---------------+------------------+------------------+------------------+------------------+---------------+
{ nlp$ta_        |      (1)->(2)*** |                  |                  |                  |               |
{ request_       |                  |         -        |         -        |         -        |         -     |
{ connection     |                  |                  |                  |                  |               |
{ ---------------+------------------+------------------+------------------+------------------+---------------+
{ nlp$ta_        | NAE$TA_          | NAE$TA_ACCEPT_   |      (3)->(4)    | NAE$TA_ACCEPT_   | NAE$TA_ACCEPT_|
{ accept_        | CONNECTION_      | CONN_NOT_        |                  | CONN_NOT_        | CONN_NOT_     |
{ connection     | TERMINATED ****  | PENDING          |                  | PENDING          | PENDING       |
{ ---------------+------------------+------------------+------------------+------------------+---------------+
{ nlp$ta_        | NAE$TA_          |      (2)->(1)    |      (3)->(1)    |      (4)->(1)    |      (4)->(1) |
{ disconnect     | CONNECTION_      |                  |                  |                  |               |
{ connection     | TERMINATED       |                  |                  |                  |               |
{ ---------------+------------------+------------------+------------------+------------------+---------------+
{ nlp$ta_        | NAE$TA_          | NAE$TA_          | NAE$TA_          |      (4)->(4)    |      (4)->(4) |
{ send_data      | CONNECTION_      | CONNECTION_NOT_  | CONNECTION_NOT_  |                  |               |
{                | TERMINATED       | ESTABLISHED      | ESTABLISHED      |                  |               |
{ ---------------+------------------+------------------+------------------+------------------+---------------+
{ nlp$ta_        | NAE$TA_          | NAE$TA_          | NAE$TA_          |                  | NAE$TA_       |
{ send_          | CONNECTION_      | CONNECTION_NOT_  | CONNECTION_NOT_  | count = count + 1| EXPEDITED_    |
{ expedited_     | TERMINATED       | ESTABLISHED      | ESTABLISHED      |   *       *      | REQUEST_LIMIT |
{ data           |                  |                  |                  |                  |               |
{ ---------------+------------------+------------------+------------------+------------------+---------------+
?? OLDTITLE ??
?? NEWTITLE := 'Finite State Machine Indications', EJECT ??
{ \--------------+------------------+------------------+------------------+------------------+---------------+
{  ----\ STATE   | nlc$ta_closed    | nlc$ta_connect_  | nlc$ta_connect_  | nlc$ta_open      | nlc$ta_open   |
{      ----\     |                  | confirm_wait     | response_wait    | count = 0        | count > 0     |
{  INDICATION----|        (1)       |        (2)       |        (3)       |        (4)       |       (4)     |
{ ---------------+------------------+------------------+------------------+------------------+---------------+
{ connect_       |      (1)->(3)    | PROTOCOL_ERROR   | PROTOCOL_ERROR   | PROTOCOL_ERROR   | PROTOCOL_ERROR|
{ indication     |                  |     *****        |                  |                  |               |
{ ---------------+------------------+------------------+------------------+------------------+---------------+
{ connect_       | PROTOCOL_ERROR   |      (2)->(4)    | PROTOCOL_ERROR   | PROTOCOL_ERROR   | PROTOCOL_ERROR|
{ confirm        |                  |                  |                  |                  |               |
{ ---------------+------------------+------------------+------------------+------------------+---------------+
{ disconnect_    | PROTOCOL_ERROR   |      (2)->(1)    |      (3)->(1)    |      (4)->(1)    |      (4)->(1) |
{ indication     |                  |                  |                  |                  |               |
{ ---------------+------------------+------------------+------------------+------------------+---------------+
{ data_          | PROTOCOL_ERROR   | PROTOCOL_ERROR   | PROTOCOL_ERROR   |      (4)->(4)    |      (4)->(4) |
{ indication     |                  |                  |                  |                  |               |
{ ---------------+------------------+------------------+------------------+------------------+---------------+
{ expedited_data | PROTOCOL_ERROR   | PROTOCOL_ERROR   | PROTOCOL_ERROR   |      (4)->(4)    |      (4)->(4) |
{ indication     |                  |                  |                  |                  |               |
{ ---------------+------------------+------------------+------------------+------------------+---------------+
{ expedited_data | PROTOCOL_ERROR   | PROTOCOL_ERROR   | PROTOCOL_ERROR   | PROTOCOL_ERROR   | count=count-1 |
{ confirm        |                  |                  |                  |                  |               |
{ ---------------+------------------+------------------+------------------+------------------+---------------+
{ *     count is the abreviation for unconfirmed_expedited_requests.
{ **    max is the abreviation for max_unconfirmed_expedited_reqs.
{ ***   indicates (the current state of the fsm)->(the state the fsm will become after processing the request
{             or the indication)
{ ****  indicates an error condition on a request.  No state change occurs.
{ ***** indicates that the peer has responded unexpectedly.  The transport access agent will break the
{             connection.  The state will effectivly become nlc$ta_closed.

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nae$osi_internal_interfaces
*copyc nat$data_length
*copyc nat$osi_network_address
*copyc nat$osi_transport_address
*copyc nat$osi_transport_sap_selector
*copyc nat$ta_alternate_protocol_class
*copyc nat$ta_preferred_protocol_class
*copyc nlc$smaa_versions
*copyc nlc$ta_data_lengths
*copyc nlt$sm_protocol_data_unit
*copyc nlt$cc_interface
*copyc nlt$ta_aggregate_message
*copyc nlt$ta_connection
*copyc nlt$ta_event
*copyc nlt$ta_inventory_report
*copyc nlt$ta_protocol_data_unit
*copyc nlt$ta_sap_selector
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc i#move
*copyc nap$namve_system_error
*copyc nlp$bm_add_message_prefix
*copyc nlp$bm_create_message
*copyc nlp$bm_extract_message_prefix
*copyc nlp$bm_copy_message
*copyc nlp$bm_get_message_length
*copyc nlp$bm_release_message
*copyc nlp$cc_accept_connection
*copyc nlp$cc_disconnect
*copyc nlp$cc_initialize_template
*copyc nlp$cc_report_undelivered_data
*copyc nlp$cc_request_connection
*copyc nlp$cc_send_aggregate_message
*copyc nlp$cc_send_expedited_data
*copyc nlp$cl_activate_layer
*copyc nlp$cl_deactivate_layer
*copyc nlp$cl_get_connection_processor
*copyc nlp$cl_get_layer_connection
*copyc nlp$cl_get_sap_processor
*copyc nlp$cl_initialize_template
*copyc nlp$get_nonexclusive_access
*copyc nlp$release_nonexclusive_access
*copyc nlp$sm_select_device
*copyc osp$add_to_locked_variable
*copyc osp$append_status_integer
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$increment_locked_variable
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$log
*copyc nav$global_osi_statistics
*copyc nav$network_procedures
*copyc nav$statistics_enabled
*copyc nlv$bm_null_message_id
*copyc nlv$configured_network_devices
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST

{ Max_unconfirmed_expedited_reqs is the number of unconfirmed expedited data requests
{ that the transport access agent will allow to be outstanding.

    max_unconfirmed_expedited_reqs = 1,
    null_osi_8073_disconnect_reason = 0;

  VAR
    initial_connection: [STATIC, READ, oss$job_paged_literal] nlt$ta_connection := [
          {accumulated_message_buffers =} 0,
          {event_processor =} nac$nil,
          {state =} nlc$ta_closed,
          {unconfirmed_expedited_requests =} 0,
          {process_expedited_data =} TRUE,
          {expedited_data_allowed =} FALSE
           ];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$ta_accept_connection', EJECT ??
*copy nlh$ta_accept_connection

  PROCEDURE [XDCL] nlp$ta_accept_connection
    (    cl_connection { input, output } : ^nlt$cl_connection;
         checksum: boolean;
         data { input, output } : nlt$bm_message_id;
         expedited_data: boolean;
         priority: nlt$ta_priority;
         quality_of_service: ^nlt$ta_quality_of_service;
     VAR status: ost$status);

    VAR
      accept_data: nlt$bm_message_id,
      connection: ^nlt$ta_connection,
      data_length: integer,
      i: integer,
      layer_active: boolean,
      pdu_header: nlt$ta_connect_response_pdu,
      quality_of_service_length: nlt$ta_quality_of_service_len;

    status.normal := TRUE;
    accept_data := data;

{ Validate data.

    nlp$bm_get_message_length (accept_data, data_length);
    IF data_length <= nlc$ta_maximum_accept_data_len THEN
      nlp$cl_get_layer_connection (nlc$osi_transport_access_agent, cl_connection, layer_active, connection);
      IF layer_active THEN
        IF connection^.state = nlc$ta_connect_response_wait THEN

{ Quality of service has not been defined for the COS EVENT.
{ Calculate quality of service length.

          quality_of_service_length := 0;
{         IF quality_of_service <> NIL THEN
{           FOR i := LOWERBOUND (quality_of_service^) TO UPPERBOUND (quality_of_service^) DO
{             quality_of_service_length := quality_of_service_length +
{                   #SIZE (nlt$ta_quality_of_service_code) + #SIZE (nlt$ta_qual_of_serv_value_len) +
{                   quality_of_service^ [i].length;
{           FOREND;
{         IFEND;

{ Build connect response pdu.

          pdu_header.kind := nlc$ta_connect_response;
          pdu_header.length := #SIZE (nlt$ta_connect_response_pdu) + quality_of_service_length;
          pdu_header.checksum := checksum;
          pdu_header.expedited_data := expedited_data;
          pdu_header.priority := priority;
          pdu_header.quality_of_service_length := quality_of_service_length;

{ Add quality of service when it is defined.

          nlp$bm_add_message_prefix (^pdu_header, pdu_header.length, accept_data);

{ A priority greater than nlc$ta_highest_priority will be be given the lowest priority.

          IF (priority > 8) AND (priority <= nlc$ta_highest_priority) THEN
            nlp$cc_accept_connection (cl_connection, nlc$cc_priority_class, accept_data, status);
          ELSE
            nlp$cc_accept_connection (cl_connection, nlc$cc_normal_class, accept_data, status);
          IFEND;
          IF status.normal THEN
            connection^.state := nlc$ta_open;

{ If the connect indication previously received had expedited data equal to FALSE
{ the expedited data on this request is ignored.

            IF connection^.expedited_data_allowed THEN
              connection^.expedited_data_allowed := expedited_data;
            IFEND;
          IFEND;

{ NOTE it is up to the lower layer to release message buffers if the request fails.

        ELSE { Nlp$ta_accept_connection request not expected.
          nlp$bm_release_message (accept_data);
          osp$set_status_condition ( nae$ta_accept_conn_not_pending,  status);
        IFEND;
      ELSE { NOT layer_active.
        nlp$bm_release_message (accept_data);
        osp$set_status_condition ( nae$ta_connection_terminated,  status);
      IFEND;
    ELSE { Invalid data.
      nlp$bm_release_message (accept_data);
      osp$set_status_condition ( nae$ta_accept_data_length_error,  status);
    IFEND;
  PROCEND nlp$ta_accept_connection;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$ta_close_sap', EJECT ??
*copy nlh$ta_close_sap

  PROCEDURE [XDCL] nlp$ta_close_sap
    (    sap: nlt$ta_sap_selector;
     VAR status: ost$status);

    status.normal := TRUE;

{ Note this request is a noop.  This requests exists for symmetry i.e. there is an open
{ request so for symmetry there should be a close.

  PROCEND nlp$ta_close_sap;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$ta_connect_event_processor', EJECT ??
*copy nlh$ta_connect_event_processor

  PROCEDURE [XDCL] nlp$ta_connect_event_processor
    (    cl_connection { input, output } : ^nlt$cl_connection;
         event { input, output } : nlt$cc_event;
     VAR inventory_report: integer);

    VAR
      bytes_extracted: 0 .. 0ffff(16),
      connection: ^nlt$ta_connection,
      data_length: integer,
      event_processor: nlt$cl_event_processor,
      ignore_bytes_moved: nat$data_length,
      ignore_layer_active: boolean,
      ignore_status: ost$status,
      network_address: ^nat$osi_network_address,
      network_address_length: ^nat$osi_network_address_length,
      pdu: ^SEQ ( * ),
      pdu_header: nlt$ta_connect_indication_pdu,
      quality_of_service_length: ^nlt$ta_quality_of_service_len,
      ta_inventory_report: nlt$ta_inventory_report,
      transport_event: nlt$ta_event,
      transport_sap_selector: ^nat$osi_transport_sap_selector;

?? NEWTITLE := 'disconnect' ??

    PROCEDURE disconnect
      (    reason: nlt$ta_disconnect_reason);

      VAR
        data: array [1 .. 1] of nat$data_fragment,
        message: nlt$bm_message_id,
        pdu_header: nlt$ta_disconnect_request_pdu;

      pdu_header.length := #SIZE (nlt$ta_disconnect_request_pdu);
      pdu_header.kind := nlc$ta_disconnect_request;
      pdu_header.proprietary_reason := reason;
      data [1].address := ^pdu_header;
      data [1].length := #SIZE (pdu_header);
      nlp$bm_create_message (data, message, ignore_status);
      nlp$cc_disconnect (cl_connection, message, ignore_status);
      nlp$bm_release_message (transport_event.osi_connect.data);
    PROCEND disconnect;
?? OLDTITLE, EJECT ??

{ This procedure will process only cc connect events.

    IF event.kind = nlc$cc_connect_event THEN

{ Validate pdu.

      transport_event.kind := nlc$ta_connect_event;
      transport_event.osi_connect.data := event.connect.data;
      nlp$bm_get_message_length (transport_event.osi_connect.data, data_length);
      IF data_length >= #SIZE (nlt$ta_connect_indication_pdu) THEN

{ Extract the fixed portion of the pdu header.

        nlp$bm_extract_message_prefix (^pdu_header, #SIZE (pdu_header), transport_event.osi_connect.data,
              ignore_bytes_moved);
        IF pdu_header.kind = nlc$ta_connect_indication THEN
          IF (data_length >= pdu_header.length) AND (pdu_header.length >
                (#SIZE (nlt$ta_connect_indication_pdu) + pdu_header.source_transport_sap_length)) THEN
            bytes_extracted := #SIZE (nlt$ta_connect_indication_pdu);
            PUSH pdu: [[REP (pdu_header.length - bytes_extracted) OF cell]];
            RESET pdu;

{ Extract the variable portion of the pdu header.

            nlp$bm_extract_message_prefix (pdu, #SIZE (pdu^), transport_event.osi_connect.data,
                  ignore_bytes_moved);

{ Zero source transport sap length is OK.

            IF pdu_header.source_transport_sap_length > 0 THEN
              bytes_extracted := bytes_extracted + pdu_header.source_transport_sap_length;
              NEXT transport_sap_selector: [pdu_header.source_transport_sap_length] IN pdu;
              transport_event.osi_connect.source_address.transport_sap_selector := transport_sap_selector^;
              transport_event.osi_connect.source_address.transport_sap_selector_length :=
                    pdu_header.source_transport_sap_length;
            ELSE
              transport_event.osi_connect.source_address.transport_sap_selector_length := 0;
            IFEND;
            IF pdu_header.length > (bytes_extracted + #SIZE (nat$osi_network_address_length)) THEN
              bytes_extracted := bytes_extracted + #SIZE (nat$osi_network_address_length);
              NEXT network_address_length IN pdu;
              IF (network_address_length^ > 0) AND
                    (network_address_length^ <= nac$osi_max_network_address_len) AND
                    (pdu_header.length > (bytes_extracted + network_address_length^)) THEN
                bytes_extracted := bytes_extracted + network_address_length^;
                NEXT network_address: [[REP network_address_length^ OF cell]] IN pdu;
                i#move (network_address, ^transport_event.osi_connect.source_address.network_address,
                      network_address_length^);
                transport_event.osi_connect.source_address.network_address_length :=
                      network_address_length^;
                IF pdu_header.length >= (bytes_extracted + #SIZE (nlt$ta_quality_of_service_len)) THEN
                  bytes_extracted := bytes_extracted + #SIZE (nlt$ta_quality_of_service_len);
                  NEXT quality_of_service_length IN pdu;
                  IF pdu_header.length = (bytes_extracted + quality_of_service_length^) THEN
                    IF quality_of_service_length^ > 0 THEN
                      bytes_extracted := bytes_extracted + quality_of_service_length^;

{TEMPORARY}
{ Currently if there is anything in for quality of service it is ignored.

                      transport_event.osi_connect.quality_of_service := NIL
{                     NEXT transport_event.osi_connect.quality_of_service:
{                           [1 .. quality_of_service_length^] IN pdu;
                    ELSE
                      transport_event.osi_connect.quality_of_service := NIL
                    IFEND;
                    nlp$cl_activate_layer (nlc$osi_transport_access_agent, cl_connection);
                    nlp$cl_get_layer_connection (nlc$osi_transport_access_agent, cl_connection,
                          ignore_layer_active, connection);
                    connection^ := initial_connection;
                    connection^.state := nlc$ta_connect_response_wait;
                    transport_event.osi_connect.checksum := pdu_header.checksum;
                    transport_event.osi_connect.destination_transport_sap :=
                          pdu_header.destination_transport_sap;
                    transport_event.osi_connect.expedited_data := pdu_header.expedited_data;
                    connection^.expedited_data_allowed := pdu_header.expedited_data;

{ Send event to user.

                    nlp$cl_get_sap_processor (cl_connection^.application_layer,
                          nlc$osi_transport_access_agent, event_processor);
                    ta_inventory_report.changed := FALSE;
                    nav$network_procedures [event_processor.ta].ta_event_processor^
                          (cl_connection, transport_event, ta_inventory_report);
                    IF ta_inventory_report.changed THEN
                      connection^.accumulated_message_buffers := ta_inventory_report.
                            accumulated_message_buffers;
                    IFEND;
                    inventory_report := connection^.accumulated_message_buffers;
                    nlp$cl_get_connection_processor (cl_connection^.application_layer,
                          nlc$osi_transport_access_agent, event_processor);
                    connection^.event_processor := event_processor.ta;
                  ELSE { Invalid quality of service length.
                    disconnect (nlc$ta_header_length_incorrect);
                  IFEND;
                ELSE { The pdu does not contain a quality of service length.
                  disconnect (nlc$ta_header_length_incorrect);
                IFEND;
              ELSE { Invalid network address length.
                disconnect (nlc$ta_header_length_incorrect);
              IFEND;
            ELSE { The pdu does not contain all required fields.
              disconnect (nlc$ta_header_length_incorrect);
            IFEND;
          ELSE { The pdu length is greater than the actual data.
            disconnect (nlc$ta_header_length_incorrect);
          IFEND;
        ELSE { Invalid pdu header kind.
          disconnect (nlc$ta_invalid_encoding);
        IFEND;
      ELSE { Invalid pdu.  Data smaller than the connect indication pdu header.
        disconnect (nlc$ta_header_indiscernible);
      IFEND;
    ELSE { event.kind <> nlc$cc_connect_event
      nap$namve_system_error (TRUE, 'Invalid channel connection event received. ', NIL);
    IFEND;
  PROCEND nlp$ta_connect_event_processor;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$ta_disconnect_connection', EJECT ??
*copy nlh$ta_disconnect_connection

  PROCEDURE [XDCL] nlp$ta_disconnect_connection
    (    cl_connection { input, output } : ^nlt$cl_connection;
         data { input, output } : nlt$bm_message_id;
     VAR status: ost$status);

    VAR
      connection: ^nlt$ta_connection,
      data_length: integer,
      disconnect_data: nlt$bm_message_id,
      layer_active: boolean,
      pdu_header: nlt$ta_disconnect_request_pdu;

    status.normal := TRUE;
    disconnect_data := data;

{ Validate data.

    nlp$bm_get_message_length (disconnect_data, data_length);
    IF data_length <= nlc$ta_max_disconnect_data_len THEN
      nlp$cl_get_layer_connection (nlc$osi_transport_access_agent, cl_connection, layer_active, connection);
      IF layer_active THEN

{ Build pdu_header.

        pdu_header.length := #SIZE (nlt$ta_disconnect_request_pdu);
        pdu_header.kind := nlc$ta_disconnect_request;
        pdu_header.proprietary_reason := nlc$ta_user_disconnect_request;
        nlp$bm_add_message_prefix (^pdu_header, pdu_header.length, disconnect_data);
        nlp$cc_disconnect (cl_connection, disconnect_data, status);
        nlp$cl_deactivate_layer (nlc$osi_transport_access_agent, cl_connection);
      ELSE { NOT layer active.
        nlp$bm_release_message (disconnect_data);
        osp$set_status_condition ( nae$ta_connection_terminated,  status);
      IFEND;
    ELSE { Invalid data.
      nlp$bm_release_message (disconnect_data);
      osp$set_status_condition ( nae$ta_disconnect_data_len_err,  status);
    IFEND;
  PROCEND nlp$ta_disconnect_connection;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$ta_event_processor', EJECT ??
*copy nlh$ta_event_processor

  PROCEDURE [XDCL] nlp$ta_event_processor
    (    cl_connection { input, output } : ^nlt$cl_connection;
         event { input, output } : nlt$cc_event;
     VAR inventory_report: integer);

    VAR
      actual: integer,
      connect_confirm_pdu: nlt$ta_connect_confirm_pdu,
      connection: ^nlt$ta_connection,
      data: nlt$bm_message_id,
      data_length: integer,
      data_pdu: nlt$ta_data_pdu,
      disconnect_pdu: nlt$ta_disconnect_indicat_pdu,
      expedited_data_pdu: nlt$ta_expedited_data_pdu,
      layer_active: boolean,
      ignore_bytes_moved: nat$data_length,
      ignore_status: ost$status,
      quality_of_service: ^SEQ ( * ),
      ta_inventory_report: nlt$ta_inventory_report,
      transport_event: nlt$ta_event;

?? NEWTITLE := 'disconnect' ??

    PROCEDURE disconnect
      (    reason: nlt$ta_disconnect_reason;
       VAR discard_message: nlt$bm_message_id);

      VAR
        data: array [1 .. 1] of nat$data_fragment,
        message: nlt$bm_message_id,
        pdu_header: nlt$ta_disconnect_request_pdu;

      pdu_header.length := #SIZE (nlt$ta_disconnect_request_pdu);
      pdu_header.kind := nlc$ta_disconnect_request;
      pdu_header.proprietary_reason := reason;
      data [1].address := ^pdu_header;
      data [1].length := #SIZE (pdu_header);
      nlp$bm_create_message (data, message, ignore_status);
      nlp$cc_disconnect (cl_connection, message, ignore_status);
      nlp$bm_release_message (discard_message);

{ Build TAA event.

      transport_event.kind := nlc$ta_disconnect_event;
      transport_event.osi_disconnect.data := nlv$bm_null_message_id;
      transport_event.osi_disconnect.proprietary_reason := reason;
      transport_event.osi_disconnect.osi_8073_reason := null_osi_8073_disconnect_reason;

{ Send event to user.

      nav$network_procedures [connection^.event_processor].
            ta_event_processor^ (cl_connection, transport_event, ta_inventory_report);
      nlp$cl_deactivate_layer (nlc$osi_transport_access_agent, cl_connection);
    PROCEND disconnect;
?? OLDTITLE, EJECT ??

    nlp$cl_get_layer_connection (nlc$osi_transport_access_agent, cl_connection, layer_active, connection);
    IF layer_active THEN
      ta_inventory_report.changed := FALSE;
      CASE event.kind OF

{ ***  AFTER JIT CONSIDER REMOVING THE STATE CHECKS.  THE STATE SHOULD BE CONSISTENT WITH CC'S.

?? NEWTITLE := 'nlc$cc_data_event', EJECT ??

      = nlc$cc_data_event =

{ Validate pdu.

        transport_event.kind := nlc$ta_data_event;
        transport_event.osi_data.data := event.data.data;
        nlp$bm_get_message_length (transport_event.osi_data.data, data_length);
        IF data_length >= #SIZE (nlt$ta_data_pdu) THEN
          nlp$bm_extract_message_prefix (^data_pdu, #SIZE (data_pdu), transport_event.osi_data.data,
                ignore_bytes_moved);
          IF data_pdu.kind = nlc$ta_data_indication THEN
            IF (data_pdu.length = #SIZE (nlt$ta_data_pdu)) AND
                  (data_length >= (data_pdu.length + nlc$ta_minimum_data_length)) THEN
              IF connection^.state = nlc$ta_open THEN

{ Build a TAA event.

                transport_event.osi_data.end_of_message := data_pdu.end_of_message;

{ Send event to user.

                nav$network_procedures [connection^.event_processor].
                      ta_event_processor^ (cl_connection, transport_event, ta_inventory_report);
              ELSE { NOT valid state - inconsistency between TAA and cc.
{               SYSTEM_ERROR OR WHAT?
              IFEND;
            ELSE { Invalid pdu length.
              disconnect (nlc$ta_header_length_incorrect, transport_event.osi_data.data);
            IFEND;
          ELSE { Invalid pdu kind.
            disconnect (nlc$ta_invalid_encoding, transport_event.osi_data.data);
          IFEND;
        ELSE { Invalid pdu.
          disconnect (nlc$ta_header_indiscernible, transport_event.osi_data.data);
        IFEND;

{! statistics begin}

        IF nav$statistics_enabled THEN
          osp$increment_locked_variable (nav$global_osi_statistics.transport_access_agent.data_pdus_received,
                0, actual);
          osp$add_to_locked_variable (nav$global_osi_statistics.transport_access_agent.total_bytes_received,
                0, data_length, actual);
        IFEND;

{! statistics end}

?? OLDTITLE ??
?? NEWTITLE := 'nlc$cc_clear_to_send_event', EJECT ??

{ Nlc$cc_clear_to_send_event is local to NAM/VE i.e. initiated by the channel
{  connection entity.

      = nlc$cc_clear_to_send_event =

{ Build a TAA event.

        transport_event.kind := nlc$ta_clear_to_send_event;

{ Send event to user.

        nav$network_procedures [connection^.event_processor].
              ta_event_processor^ (cl_connection, transport_event, ta_inventory_report);

?? OLDTITLE ??
?? NEWTITLE := 'nlc$cc_expedited_data_event', EJECT ??

      = nlc$cc_expedited_data_event =

{ Validate pdu.

        data := event.expedited_data.data;
        IF connection^.expedited_data_allowed THEN
          nlp$bm_get_message_length (data, data_length);
          IF data_length >= #SIZE (nlt$ta_expedited_data_pdu) THEN
            nlp$bm_extract_message_prefix (^expedited_data_pdu, #SIZE (expedited_data_pdu), data,
                  ignore_bytes_moved);
            IF expedited_data_pdu.kind = nlc$ta_expedited_indication THEN
              IF (expedited_data_pdu.length = #SIZE (nlt$ta_expedited_data_pdu)) AND
                    (data_length >= (expedited_data_pdu.length + nlc$ta_min_expedited_data_len)) AND
                    (data_length <= (expedited_data_pdu.length + nlc$ta_max_expedited_data_len)) THEN
                IF connection^.state = nlc$ta_open THEN

{ Build a TAA event.

                  transport_event.kind := nlc$ta_expedited_data_event;
                  transport_event.osi_expedited_data.data := data;

{ Send event to user.

                  nav$network_procedures [connection^.event_processor].
                        ta_event_processor^ (cl_connection, transport_event, ta_inventory_report);
                ELSE { Invalid state - inconsistency between TAA and cc
{                 SYSTEM_ERROR OR WHAT?
                IFEND;
              ELSE { Invalid pdu length.
                disconnect (nlc$ta_header_length_incorrect, data);
              IFEND;
            ELSEIF expedited_data_pdu.kind = nlc$ta_expedited_confirmation THEN
              IF (data_length = expedited_data_pdu.length) AND (expedited_data_pdu.length =
                    #SIZE (nlt$ta_expedited_data_pdu)) THEN
                IF (connection^.state = nlc$ta_open) AND (connection^.unconfirmed_expedited_requests > 0) THEN
                  connection^.unconfirmed_expedited_requests :=
                                                          connection^.unconfirmed_expedited_requests - 1;

{ Expedited data requests will be allowed until max_unconfirmed_expedited_reqs is reached.  Once the max is
{ reached the unconfirmed expedited request must go to zero before additional requests will be accepted.

                  IF NOT connection^.process_expedited_data AND
                        (connection^.unconfirmed_expedited_requests = 0) THEN
                    connection^.process_expedited_data := TRUE;
                  IFEND;
                ELSEIF (connection^.state = nlc$ta_open) AND (connection^.unconfirmed_expedited_requests = 0)
                      THEN
                  disconnect (nlc$ta_expedited_not_pending, data);
                ELSE { Invalid state - inconsistency between TAA and cc.
{                 SYSTEM_ERROR OR WHAT?
                IFEND;
              ELSE { Invalid pdu length.
                disconnect (nlc$ta_header_length_incorrect, data);
              IFEND;
            ELSE { Invalid pdu header kind.
              disconnect (nlc$ta_invalid_encoding, data);
            IFEND;
          ELSE { Invalid pdu.
            disconnect (nlc$ta_header_indiscernible, data);
          IFEND;
        ELSE { IF NOT connection^.expedited_data_allowed THEN
          disconnect (nlc$ta_expedited_not_selected, data);
        IFEND;

{! statistics begin}

        IF nav$statistics_enabled THEN
          osp$increment_locked_variable (nav$global_osi_statistics.transport_access_agent.
                expedited_pdus_received, 0, actual);
        IFEND;

{! statistics end}

?? OLDTITLE ??
?? NEWTITLE := 'nlc$cc_accept_event', EJECT ??

      = nlc$cc_accept_event =

{ Validate pdu.

        transport_event.kind := nlc$ta_connect_confirm_event;
        transport_event.osi_connect_confirm.data := event.accept.data;
        nlp$bm_get_message_length (transport_event.osi_connect_confirm.data, data_length);
        IF data_length >= #SIZE (nlt$ta_connect_confirm_pdu) THEN
          nlp$bm_extract_message_prefix (^connect_confirm_pdu, #SIZE (connect_confirm_pdu),
                transport_event.osi_connect_confirm.data, ignore_bytes_moved);
          IF connect_confirm_pdu.kind = nlc$ta_connect_confirmation THEN
            IF (connect_confirm_pdu.length = (#SIZE (nlt$ta_connect_confirm_pdu) +
                  connect_confirm_pdu.quality_of_service_length)) AND
                  (data_length >= (connect_confirm_pdu.length)) AND
                  (data_length <= (connect_confirm_pdu.length + nlc$ta_maximum_accept_data_len)) THEN
              IF connection^.state = nlc$ta_connect_confirm_wait THEN
                connection^.state := nlc$ta_open;

{ Build a TAA event.

                transport_event.osi_connect_confirm.checksum := connect_confirm_pdu.checksum;
                transport_event.osi_connect_confirm.expedited_data := connect_confirm_pdu.expedited_data;
                connection^.expedited_data_allowed := connect_confirm_pdu.expedited_data;
                IF connect_confirm_pdu.quality_of_service_length > 0 THEN
                  PUSH quality_of_service: [[REP connect_confirm_pdu.quality_of_service_length OF cell]];
                  RESET quality_of_service;
                  nlp$bm_extract_message_prefix (quality_of_service,
                        connect_confirm_pdu.quality_of_service_length,
                        transport_event.osi_connect_confirm.data, ignore_bytes_moved);

{ Get quality of service.
{ TEMPORARY:  quality of service is not defined.

                  transport_event.osi_connect_confirm.quality_of_service := NIL;
                ELSE
                  transport_event.osi_connect_confirm.quality_of_service := NIL;
                IFEND;

{ Send event to user.

                nav$network_procedures [connection^.event_processor].
                      ta_event_processor^ (cl_connection, transport_event, ta_inventory_report);
              ELSE { Invalid state - inconsistency between TAA and cc.
{               SYSTEM_ERROR OR WHAT?
              IFEND;
            ELSE { Pdu length mismatch.
              disconnect (nlc$ta_header_length_incorrect, transport_event.osi_connect_confirm.data);
            IFEND;
          ELSE { Invalid pdu kind.
            disconnect (nlc$ta_invalid_encoding, transport_event.osi_connect_confirm.data);
          IFEND;
        ELSE { Invalid pdu.
          disconnect (nlc$ta_header_indiscernible, transport_event.osi_connect_confirm.data);
        IFEND;
?? OLDTITLE ??
?? NEWTITLE := 'nlc$cc_disconnect_event', EJECT ??

      = nlc$cc_disconnect_event =

{ Validate pdu.

        transport_event.kind := nlc$ta_disconnect_event;
        transport_event.osi_disconnect.data := event.disconnect.data;
        IF event.disconnect.reason = nlc$cc_dr_normal_disconnect THEN
          nlp$bm_get_message_length (transport_event.osi_disconnect.data, data_length);
          IF data_length >= #SIZE (nlt$ta_disconnect_indicat_pdu) THEN
            nlp$bm_extract_message_prefix (^disconnect_pdu, #SIZE (disconnect_pdu),
                  transport_event.osi_disconnect.data, ignore_bytes_moved);
            IF disconnect_pdu.kind = nlc$ta_disconnect_indication THEN
              IF (disconnect_pdu.length = #SIZE (nlt$ta_disconnect_indicat_pdu)) AND
                    (data_length <= #SIZE (nlt$ta_disconnect_indicat_pdu) +
                    nlc$ta_max_disconnect_data_len) THEN

{ Build a TAA event.

                transport_event.osi_disconnect.proprietary_reason := disconnect_pdu.proprietary_reason;
                transport_event.osi_disconnect.osi_8073_reason := disconnect_pdu.osi_8073_reason;
              ELSE { Invalid pdu length.

{ Build a TAA event.

                transport_event.osi_disconnect.proprietary_reason := nlc$ta_header_length_incorrect;
                transport_event.osi_disconnect.osi_8073_reason := null_osi_8073_disconnect_reason;
                nlp$bm_release_message (transport_event.osi_disconnect.data);
                transport_event.osi_disconnect.data := nlv$bm_null_message_id;
              IFEND;
            ELSE { Invalid pdu.

{ Build a TAA event.

              transport_event.osi_disconnect.proprietary_reason := nlc$ta_invalid_encoding;
              transport_event.osi_disconnect.osi_8073_reason := null_osi_8073_disconnect_reason;
              nlp$bm_release_message (transport_event.osi_disconnect.data);
              transport_event.osi_disconnect.data := nlv$bm_null_message_id;
            IFEND;
          ELSE { Invalid pdu length.

{ Build a TAA event.

            transport_event.osi_disconnect.proprietary_reason := nlc$ta_header_indiscernible;
            transport_event.osi_disconnect.osi_8073_reason := null_osi_8073_disconnect_reason;
            nlp$bm_release_message (transport_event.osi_disconnect.data);
            transport_event.osi_disconnect.data := nlv$bm_null_message_id;
          IFEND;
        ELSE { NOT nlc$cc_dr_normal_disconnect.

{ Build a TAA event.

          transport_event.osi_disconnect.proprietary_reason := event.disconnect.reason;
          transport_event.osi_disconnect.osi_8073_reason := null_osi_8073_disconnect_reason;
          nlp$bm_release_message (transport_event.osi_disconnect.data);
          transport_event.osi_disconnect.data := nlv$bm_null_message_id;
        IFEND;

{ Send event to user.

        nav$network_procedures [connection^.event_processor].
              ta_event_processor^ (cl_connection, transport_event, ta_inventory_report);
        nlp$cl_deactivate_layer (nlc$osi_transport_access_agent, cl_connection);
      ELSE { Unknown event kind.
        nap$namve_system_error (TRUE, 'Invalid channel connection event.', NIL);
      CASEND;
      IF ta_inventory_report.changed THEN
        connection^.accumulated_message_buffers := ta_inventory_report.accumulated_message_buffers;
      IFEND;
      inventory_report := connection^.accumulated_message_buffers;
    ELSE { NOT layer active.
      nap$namve_system_error (TRUE, 'Transport access agent inactive.', NIL);
    IFEND;
  PROCEND nlp$ta_event_processor;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$ta_initialize', EJECT ??
*copy nlh$ta_initialize

  PROCEDURE [XDCL] nlp$ta_initialize
    (    application_layer: nlt$cl_application_layer;
         connect_event_processor: nat$network_procedure;
         event_processor: nat$network_procedure);

    VAR
      cl_connection_processor: nlt$cl_event_processor,
      osi_sap_processor: nlt$cl_event_processor;

    osi_sap_processor.layer := nlc$osi_transport_access_agent;
    osi_sap_processor.ta := connect_event_processor;
    cl_connection_processor.layer := nlc$osi_transport_access_agent;
    cl_connection_processor.ta := event_processor;
    nlp$cl_initialize_template (application_layer, nlc$osi_transport_access_agent,
          #SIZE (nlt$ta_connection), {maximum_protocol_header_size =}0, osi_sap_processor,
          nac$nil, cl_connection_processor, nac$nil);
    nlp$cc_initialize_template (application_layer);
  PROCEND nlp$ta_initialize;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$ta_open_sap', EJECT ??
*copy nlh$ta_open_sap

  PROCEDURE [XDCL] nlp$ta_open_sap
    (    application_layer: nlt$cl_application_layer;
         connect_event_processor: nat$network_procedure;
         event_processor: nat$network_procedure;
     VAR status: ost$status);

    VAR
      cl_connection_processor: nlt$cl_event_processor,
      osi_sap_processor: nlt$cl_event_processor;

    status.normal := TRUE;
    osi_sap_processor.layer := nlc$osi_transport_access_agent;
    osi_sap_processor.ta := connect_event_processor;
    cl_connection_processor.layer := nlc$osi_transport_access_agent;
    cl_connection_processor.ta := event_processor;
    nlp$cl_initialize_template (application_layer, nlc$osi_transport_access_agent,
          #SIZE (nlt$ta_connection), {maximum_protocol_header_size =}0, osi_sap_processor,
          nac$nil, cl_connection_processor, nac$nil);
    nlp$cc_initialize_template (application_layer);
  PROCEND nlp$ta_open_sap;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$ta_report_undelivered_data', EJECT ??

{ PURPOSE:
{   The purpose of this request is to notify the channel connection entity of the
{   amount of data stored at the application layer.

  PROCEDURE [XDCL] nlp$ta_report_undelivered_data
    (    cl_connection { input, output } : ^nlt$cl_connection;
         accumulated_message_buffers: integer);

    VAR
      connection: ^nlt$ta_connection,
      layer_active: boolean;

    nlp$cl_get_layer_connection (nlc$osi_transport_access_agent, cl_connection, layer_active, connection);
    IF layer_active THEN
      nlp$cc_report_undelivered_data (cl_connection, accumulated_message_buffers);
      connection^.accumulated_message_buffers := accumulated_message_buffers;
    IFEND;
  PROCEND nlp$ta_report_undelivered_data;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$ta_request_connection' ??
?? NEWTITLE := '    release_request_data', EJECT ??
*copy nlh$ta_request_connection

  PROCEDURE [XDCL] nlp$ta_request_connection
    (    cl_connection { input, output } : ^nlt$cl_connection;
         sap: nlt$ta_sap_selector;
         checksum: boolean;
         data { input, output } : nlt$bm_message_id;
         destination_transport_sap: nat$osi_transport_sap_selector;
         destination_network_address: nat$osi_network_address;
         cdna_destination_address: boolean;
         expedited_data: boolean;
         priority: nlt$ta_priority;
         preferred_protocol_class: nat$ta_preferred_protocol_class;
         alternate_protocol_class: nat$ta_alternate_protocol_class;
         quality_of_service: ^nlt$ta_quality_of_service;
     VAR status: ost$status);

    PROCEDURE release_request_data (
           ignore_condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           ignore_sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      condition_status.normal := TRUE;
      nlp$bm_release_message (request_data);

   PROCEND release_request_data;
?? OLDTITLE, EJECT ??

    VAR
      connect_data: nlt$bm_message_id,
      connection: ^nlt$ta_connection,
      data_length: integer,
      destination_device: ^nlt$device_list,
      destination_device_count: nlt$device_count,
      destination_device_version_list: ^nlt$sm_device_version_list,
      device_and_data_list: ^nlt$cc_device_and_data_list,
      device_version: nlt$sm_version,
      event_processor: nlt$cl_event_processor,
      i: integer,
      ignore_layer_active: boolean,
      ignore_status: ost$status,
      network_address: ^nat$osi_network_address,
      network_address_length: ^nat$osi_network_address_length,
      protocol_data_unit: ^SEQ ( * ),
      protocol_data_unit_size: 0 .. 0ffff(16),
      pdu_header: ^nlt$ta_connect_request_pdu,
      pdu_header_v2: ^nlt$ta_connect_request_pdu_v2,
      quality_of_service_length: ^nlt$ta_quality_of_service_len,
      quality_of_service_size: nlt$ta_quality_of_service_len,
      request_data: nlt$bm_message_id,
      transport_sap_selector: ^nat$osi_transport_sap_selector;

    status.normal := TRUE;
    request_data := data;

    IF (preferred_protocol_class <> nac$ta_preferred_class_0) AND
       (preferred_protocol_class <> nac$ta_preferred_class_4_CLNS) THEN
      nlp$bm_release_message (request_data);
      osp$set_status_condition ( nae$ta_protocol_not_supported,  status);
      RETURN;
    IFEND;

{ Validate data.

    nlp$bm_get_message_length (request_data, data_length);
    IF data_length <= nlc$ta_maximum_connect_data_len THEN
      PUSH destination_device: [1 .. nlv$configured_network_devices.network_device_count];
      PUSH destination_device_version_list: [1 .. nlv$configured_network_devices.network_device_count];

      osp$establish_block_exit_hndlr (^release_request_data);
      nlp$sm_select_device (destination_network_address, cdna_destination_address, preferred_protocol_class,
            destination_device^, destination_device_version_list^, destination_device_count, status);
      osp$disestablish_cond_handler;
      IF status.normal THEN
        nlp$cl_activate_layer (nlc$osi_transport_access_agent, cl_connection);
        nlp$cl_get_layer_connection (nlc$osi_transport_access_agent, cl_connection, ignore_layer_active,
              connection);

{ Determine the size of the quality of service.
{ Quality of service is currently undefined.

        quality_of_service_size := 0;
{       IF quality_of_service <> NIL THEN
{         FOR i := LOWERBOUND (quality_of_service^) TO UPPERBOUND (quality_of_service^) DO
{           quality_of_service_size := quality_of_service_size + #SIZE (nlt$ta_quality_of_service_code) +
{                 #SIZE (nlt$ta_qual_of_serv_value_len) + quality_of_service^ [i].length;
{         FOREND;
{       IFEND;

        PUSH device_and_data_list: [1..destination_device_count];

        FOR i := 1 to destination_device_count DO

          IF i < destination_device_count THEN
            nlp$bm_copy_message (request_data, device_and_data_list^ [i].data);
          ELSE
            device_and_data_list^ [i].data := request_data;
          IFEND;
          device_and_data_list^ [i].device_id := destination_device^ [i];

          IF destination_device_version_list^ [i] >= nlc$sm_version_2 THEN

{ Determine the size of the request pdu for version 2 (or higher) of the TAA protocol.
            protocol_data_unit_size:=#SIZE(nlt$ta_connect_request_pdu_v2)+#SIZE(destination_transport_sap)
                  + #SIZE (nat$osi_network_address_length) + #SIZE (destination_network_address) +
                  #SIZE (nlt$ta_quality_of_service_len) + quality_of_service_size;

{ Build the pdu header for version 2 (or higher) of the TAA protocol.

            PUSH protocol_data_unit: [[REP protocol_data_unit_size OF cell]];
            RESET protocol_data_unit;
            NEXT pdu_header_v2 IN protocol_data_unit;
            pdu_header_v2^.kind := nlc$ta_connect_request;
            pdu_header_v2^.length := protocol_data_unit_size;
            pdu_header_v2^.source_transport_sap := sap;
            pdu_header_v2^.checksum := checksum;
            pdu_header_v2^.expedited_data := expedited_data;
            pdu_header_v2^.priority := priority;
            pdu_header_v2^.preferred_protocol_class := preferred_protocol_class;
            pdu_header_v2^.alternate_protocol_class := alternate_protocol_class;
            pdu_header_v2^.destination_transport_sap_len := #SIZE (destination_transport_sap);
            IF #SIZE (destination_transport_sap) > 0 THEN
              NEXT transport_sap_selector: [#SIZE (destination_transport_sap)] IN protocol_data_unit;
              transport_sap_selector^ := destination_transport_sap;
            IFEND;
            NEXT network_address_length IN protocol_data_unit;
            network_address_length^ := #SIZE (destination_network_address);
            NEXT network_address: [[REP network_address_length^ OF cell]] IN protocol_data_unit;
            network_address^ := destination_network_address;
            NEXT quality_of_service_length IN protocol_data_unit;
            quality_of_service_length^ := quality_of_service_size;

{ Add quality of service when it is defined.

          ELSE  { the version of the device we are talking to is less than 2

{ Determine the size of the request pdu for the previous protocol version.

            protocol_data_unit_size := #SIZE (nlt$ta_connect_request_pdu) + #SIZE(destination_transport_sap)+
                  #SIZE (nat$osi_network_address_length) + #SIZE (destination_network_address) +
                  #SIZE (nlt$ta_quality_of_service_len) + quality_of_service_size;

{ Build the pdu header for the previous protocol version.

            PUSH protocol_data_unit: [[REP protocol_data_unit_size OF cell]];
            RESET protocol_data_unit;
            NEXT pdu_header IN protocol_data_unit;
            pdu_header^.kind := nlc$ta_connect_request;
            pdu_header^.length := protocol_data_unit_size;
            pdu_header^.source_transport_sap := sap;
            pdu_header^.checksum := checksum;
            pdu_header^.expedited_data := expedited_data;
            pdu_header^.priority := priority;
            pdu_header^.destination_transport_sap_len := #SIZE (destination_transport_sap);
            IF #SIZE (destination_transport_sap) > 0 THEN
              NEXT transport_sap_selector: [#SIZE (destination_transport_sap)] IN protocol_data_unit;
              transport_sap_selector^ := destination_transport_sap;
            IFEND;
            NEXT network_address_length IN protocol_data_unit;
            network_address_length^ := #SIZE (destination_network_address);
            NEXT network_address: [[REP network_address_length^ OF cell]] IN protocol_data_unit;
            network_address^ := destination_network_address;
            NEXT quality_of_service_length IN protocol_data_unit;
            quality_of_service_length^ := quality_of_service_size;

{ Add quality of service when it is defined.

          IFEND;

{ Merge the pdu header with the user's data

          nlp$bm_add_message_prefix (protocol_data_unit, protocol_data_unit_size,
                device_and_data_list^ [i].data);

        FOREND;

{ A priority greater than nlc$ta_highest_priority will be be given the lowest priority.

        IF (priority > 8) AND (priority <= nlc$ta_highest_priority) THEN
          nlp$cc_request_connection (cl_connection, device_and_data_list^, nlc$transport_access_address,
                nlc$cc_priority_class, status);
        ELSE { Normal priority.
          nlp$cc_request_connection (cl_connection, device_and_data_list^, nlc$transport_access_address,
                nlc$cc_normal_class, status);
        IFEND;
        IF status.normal THEN
          connection^ := initial_connection;
          connection^.state := nlc$ta_connect_confirm_wait;
          nlp$cl_get_connection_processor (cl_connection^.application_layer, nlc$osi_transport_access_agent,
                event_processor);
          connection^.event_processor := event_processor.ta;
          connection^.expedited_data_allowed := expedited_data;
        ELSE { Nlp$cc_request_connection failed.

{ NOTE: the data is released by the layer detecting the error.

          nlp$cl_deactivate_layer (nlc$osi_transport_access_agent, cl_connection);
        IFEND;
      ELSE { NOT sme status.normal.
        nlp$bm_release_message (request_data);
      IFEND;
    ELSE { Invalid data.
      nlp$bm_release_message (request_data);
      osp$set_status_condition ( nae$ta_connect_data_len_error,  status);
    IFEND;

  PROCEND nlp$ta_request_connection;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$ta_send_aggregate_message', EJECT ??
*copy nlh$ta_send_aggregate_message

  PROCEDURE [XDCL] nlp$ta_send_aggregate_message
   (    cl_connection { input, output } : ^nlt$cl_connection;
        message { input, output } : nlt$ta_aggregate_message;
    VAR status: ost$status);
?? NEWTITLE := 'release_aggregates', EJECT ??

    PROCEDURE release_aggregates (message: nlt$ta_aggregate_message);

      VAR
        release_message: nlt$bm_message_id,
        i: integer;

      FOR i := 1 TO UPPERBOUND (message) DO
        CASE message [i].kind OF
        = nlc$ta_data_event =
          release_message := message [i].data;
          nlp$bm_release_message (release_message);
        = nlc$ta_expedited_data_event =
          release_message := message [i].expedited_data;
          nlp$bm_release_message (release_message);
        ELSE
          ;
        CASEND;
      FOREND;
    PROCEND release_aggregates;
?? OLDTITLE, EJECT ??

    VAR
      actual: integer,
      aggregate_message: ^nlt$cc_aggregate_message,
      connection: ^nlt$ta_connection,
      data_count: integer,
      data_length: integer,
      expedited_data_count: integer,
      i: integer,
      layer_active: boolean,
      pdu_header: nlt$ta_data_pdu,
      total_data_length: integer;

    status.normal := TRUE;
    nlp$cl_get_layer_connection (nlc$osi_transport_access_agent, cl_connection, layer_active, connection);
    IF layer_active THEN
      IF connection^.state = nlc$ta_open THEN
        PUSH aggregate_message: [1 .. UPPERBOUND (message)];
        i := 1;
        data_count := 0;
        total_data_length := 0;
        expedited_data_count := 0;

{ Need to add the pdu header.

        WHILE (status.normal AND (i <= UPPERBOUND (message))) DO
          CASE message [i].kind OF
          = nlc$ta_data_event =
            nlp$bm_get_message_length (message [i].data, data_length);
            IF data_length >= nlc$ta_minimum_data_length THEN

{ Build data pdu.

              pdu_header.length := #SIZE (nlt$ta_data_pdu);
              pdu_header.kind := nlc$ta_data_request;
              pdu_header.end_of_message := message [i].end_of_message;

{ Merge data and pdu.

              aggregate_message^ [i].kind := nlc$cc_data_event;
              aggregate_message^ [i].data := message [i].data;
              nlp$bm_add_message_prefix (^pdu_header, pdu_header.length, aggregate_message^ [i].data);
              data_count := data_count + 1;
              total_data_length := total_data_length + pdu_header.length + data_length;
            ELSE
              osp$set_status_condition ( nae$ta_data_length_error,
                    status);
              osp$append_status_integer (osc$status_parameter_delimiter,
                    nlc$ta_minimum_data_length, 10, TRUE, status);
            IFEND;
          = nlc$ta_expedited_data_event =
            nlp$bm_get_message_length (message [i].expedited_data, data_length);
            IF (data_length >= nlc$ta_min_expedited_data_len) AND
               (data_length <= nlc$ta_max_expedited_data_len) THEN

{ Build data pdu.

              pdu_header.length := #SIZE (nlt$ta_expedited_data_pdu);
              pdu_header.kind := nlc$ta_expedited_request;

{ Merge data and pdu.

              aggregate_message^ [i].kind := nlc$cc_expedited_data_event;
              aggregate_message^ [i].expedited_data := message [i].expedited_data;
              nlp$bm_add_message_prefix (^pdu_header, pdu_header.length, aggregate_message^ [i].
                    expedited_data);
              expedited_data_count := expedited_data_count + 1;
            ELSE
              osp$set_status_condition ( nae$ta_expedited_length_error,  status);
            IFEND;
          ELSE
            osp$set_status_condition ( nae$ta_improper_aggregate_kind,  status);
          CASEND;
          i := i + 1;
        WHILEND;
        IF (status.normal) AND (expedited_data_count > 0) THEN
          IF connection^.expedited_data_allowed THEN
            IF ((connection^.unconfirmed_expedited_requests + expedited_data_count) >
                  max_unconfirmed_expedited_reqs) OR (NOT connection^.process_expedited_data) THEN
              osp$set_status_condition ( nae$ta_expedited_request_limit,  status);
            IFEND;
          ELSE { IF NOT connection^.expedited_data_allowed THEN
            osp$set_status_condition ( nae$ta_expedited_not_supported,  status);
          IFEND;
        IFEND;
        IF status.normal THEN
          nlp$cc_send_aggregate_message (cl_connection, aggregate_message^, status);
          IF status.normal THEN

{! statistics begin}

            IF nav$statistics_enabled THEN
              IF data_count > 0 THEN
                osp$add_to_locked_variable (nav$global_osi_statistics.transport_access_agent.data_pdus_sent,
                      0, data_count, actual);
                osp$add_to_locked_variable (nav$global_osi_statistics.transport_access_agent.total_bytes_sent,
                      0, total_data_length, actual);
              IFEND;
              IF expedited_data_count > 0 THEN
                osp$add_to_locked_variable (nav$global_osi_statistics.transport_access_agent.
                      expedited_pdus_sent, 0, expedited_data_count, actual);
              IFEND;
            IFEND;

{! statistics end}

            IF expedited_data_count > 0 THEN
              connection^.unconfirmed_expedited_requests :=
                              connection^.unconfirmed_expedited_requests + expedited_data_count;
              IF connection^.unconfirmed_expedited_requests = max_unconfirmed_expedited_reqs THEN
                connection^.process_expedited_data := FALSE;
              IFEND;
            IFEND;
          IFEND;
        ELSE
          release_aggregates (message);
        IFEND;
      ELSE { Invalid state.
        release_aggregates (message);
      osp$set_status_condition ( nae$ta_connect_not_established,  status);
      IFEND;
    ELSE { NOT layer_active.
      release_aggregates (message);
      osp$set_status_condition ( nae$ta_connection_terminated,  status);
    IFEND;
  PROCEND nlp$ta_send_aggregate_message;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$ta_send_expedited_data', EJECT ??
*copy nlh$ta_send_expedited_data

  PROCEDURE [XDCL] nlp$ta_send_expedited_data
    (    cl_connection { input, output } : ^nlt$cl_connection;
         data { input, output } : nlt$bm_message_id;
     VAR status: ost$status);

    VAR
      actual: integer,
      connection: ^nlt$ta_connection,
      data_length: integer,
      expedited_data: nlt$bm_message_id,
      layer_active: boolean,
      pdu_header: nlt$ta_expedited_data_pdu;

    status.normal := TRUE;
    expedited_data := data;

{ Validate data.

    nlp$bm_get_message_length (data, data_length);
    IF (data_length >= nlc$ta_min_expedited_data_len) AND (data_length <= nlc$ta_max_expedited_data_len) THEN
      nlp$cl_get_layer_connection (nlc$osi_transport_access_agent, cl_connection, layer_active, connection);
      IF layer_active THEN
        IF connection^.state = nlc$ta_open THEN
          IF connection^.expedited_data_allowed THEN

{ An expedited data request (under one condition) will be sent even though a previous expedited data
{ request has not been confirmed.  The data will be sent if the number of unconfirmed requests is less than
{ max_unconfirmed_expedited_reqs and the count of unconfirmed requests has gone to zero since the last time
{ the count has been equal to max_unconfirmed_expedited_reqs.  In other words, once the count has been equal
{ to max_unconfirmed_expedited_reqs the count must decremented to zero before another expedited data request
{ will be processed.

            IF (connection^.unconfirmed_expedited_requests < max_unconfirmed_expedited_reqs) AND
               (connection^.process_expedited_data) THEN

{ Build data pdu.

              pdu_header.length := #SIZE (nlt$ta_expedited_data_pdu);
              pdu_header.kind := nlc$ta_expedited_request;

{ Merge data and pdu.

              nlp$bm_add_message_prefix (^pdu_header, pdu_header.length, expedited_data);
              nlp$cc_send_expedited_data (cl_connection, expedited_data, status);
              IF status.normal THEN
                connection^.unconfirmed_expedited_requests := connection^.unconfirmed_expedited_requests + 1;
                IF connection^.unconfirmed_expedited_requests = max_unconfirmed_expedited_reqs THEN
                  connection^.process_expedited_data := FALSE;
                IFEND;

{! statistics begin}

                IF nav$statistics_enabled THEN
                  osp$increment_locked_variable (nav$global_osi_statistics.transport_access_agent.
                        expedited_pdus_sent, 0, actual);
                IFEND;

{! statistics end}

              IFEND;

{ ELSEIF (connection^.unconfirmed_expedited_requests = max_unconfirmed_expedited_reqs) OR
{    (NOT connection^.process_expedited_data) THEN

            ELSE
              nlp$bm_release_message (expedited_data);
              osp$set_status_condition ( nae$ta_expedited_request_limit,  status);
            IFEND;
          ELSE { IF NOT connection^.expedited_data_allowed THEN
            nlp$bm_release_message (expedited_data);
            osp$set_status_condition ( nae$ta_expedited_not_supported,  status);
          IFEND;
        ELSE { Invalid state.
          nlp$bm_release_message (expedited_data);
          osp$set_status_condition ( nae$ta_connect_not_established,  status);
        IFEND;
      ELSE { NOT layer_active.
        nlp$bm_release_message (expedited_data);
        osp$set_status_condition ( nae$ta_connection_terminated,  status);
      IFEND;
    ELSE { Invalid data.
      nlp$bm_release_message (expedited_data);
      osp$set_status_condition ( nae$ta_expedited_length_error,  status);
    IFEND;
  PROCEND nlp$ta_send_expedited_data;
?? OLDTITLE ??
MODEND nlm$transport_access_agent;
*DECK DECK=NLM$UDP_ACCESS_AGENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access: UDP Access Agent' ??
MODULE nlm$udp_access_agent;

{ PURPOSE:
{   This module contains procedures neccesary to support the UDP Access Agent.
{ DESIGN:
{   These procedures are called by the socket layer external interface code and in turn
{   access the channel connections. These procedures support the user requests issued
{   over user datagram sockets as well as the indications received over the channel
{   connections from the UDP Access Provider in the device.
{   There is a unique global socket for each datagram socket
{   created by the user. These procedures translate the user requests issued over a datagram
{   sockets to the actual channel connection requests.
{   The XDCL'd procedures have been grouped in alphabetical order
{   followed by the internal procedures. The internal procedures are also in alphabetical
{   order.
{   This module contains code that executes in ring 3. It resides on OSF$JOB_TEMPLATE_23D.
{
{ NOTES:
{   The following abbreviations have been used in this module:
{          UDP - User Datagram Protocol

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nac$null_connection_id
*copyc nac$sk_all_ip_addresses
*copyc nae$sk_socket_layer
*copyc nat$connection_id
*copyc nat$data_fragments
*copyc nat$data_length
*copyc nat$sk_interface_mode
*copyc nat$sk_socket_identifier
*copyc nat$sk_traffic_pattern
*copyc nat$wait_time
*copyc nlc$udp_max_pool_size
*copyc nlt$bm_message_id
*copyc nlt$cc_address
*copyc nlt$cc_device_and_data_record
*copyc nlt$cc_interface
*copyc nlt$cl_connection
*copyc nlt$cl_layer_name
*copyc nlt$device_count
*copyc nlt$device_identifier
*copyc nlt$tcpip_address
*copyc nlt$tm_device_address_list
*copyc nlt$udpaa_protocol_data_unit
*copyc nlt$udp_global_socket
*copyc nlt$udp_local_routing_cache
*copyc nlt$udp_receive_data_signal
*copyc nlt$udp_socket_inventory
*copyc nlt$udp_socket_layer
*copyc ost$free_running_clock
*copyc ost$activity_status
*copyc ost$status
?? POP ??
*copyc nap$namve_system_error
*copyc nlp$al_get_data_length
*copyc nlp$bm_concatenate_messages
*copyc nlp$bm_create_message
*copyc nlp$bm_deliver_message
*copyc nlp$bm_extract_message_prefix
*copyc nlp$bm_flush_message
*copyc nlp$bm_get_message_length
*copyc nlp$bm_get_message_resources
*copyc nlp$bm_release_message
*copyc nlp$cc_disconnect
*copyc nlp$cc_initialize_template
*copyc nlp$cc_receive_data
*copyc nlp$cc_report_undelivered_data
*copyc nlp$cc_request_connection
*copyc nlp$cc_send_data_fragments
*copyc nlp$cl_activate_layer
*copyc nlp$cl_activate_receiver
*copyc nlp$cl_activate_sender
*copyc nlp$cl_create_connection
*copyc nlp$cl_deactivate_layer
*copyc nlp$cl_deactivate_receiver
*copyc nlp$cl_deactivate_sender
*copyc nlp$cl_get_exclusive_via_cid
*copyc nlp$cl_get_layer_connection
*copyc nlp$cl_initialize_template
*copyc nlp$cl_release_exclusive_access
*copyc nlp$get_nonexclusive_access
*copyc nlp$osi_get_outbound_capacity
*copyc nlp$release_nonexclusive_access
*copyc nlp$sk_fragment_data
*copyc nlp$tm_get_local_udp_devices
*copyc nlp$tm_select_by_local_udp_addr
*copyc nlp$tm_udp_select_device
*copyc nlp$udp_activate_receiver
*copyc nlp$udp_deactivate_receiver
*copyc nlp$udp_delete_global_socket
*copyc nlp$udp_free_exclusive_access
*copyc nlp$udp_free_nonexclu_to_root
*copyc nlp$udp_get_exclusive_access
*copyc nlp$udp_get_exclusive_via_gsid
*copyc nlp$udp_get_nonexclu_to_root
*copyc nlp$udp_store_receiver
*copyc osp$append_status_integer
*copyc osp$clear_job_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$set_status_from_condition
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$get_executing_task_gtid
*copyc pmp$log_ascii
*copyc pmp$long_term_wait
*copyc pmp$ready_task
*copyc pmp$wait
*copyc syp$cycle
*copyc nav$network_paged_heap
*copyc nlv$configured_network_devices
*copyc nlv$udp_global_sockets
*copyc oss$job_paged_literal
*copyc oss$task_private
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    udpaa_cc_disconnect = 'UDPAA - CC disconnect',
    udpaa_open_reject = 'UDPAA - open reject',
    udpaa_release = 'UDPAA - release indication';

  VAR
    null_socket_address: [READ, oss$job_paged_literal] nat$sk_socket_address := [0, 0],
    nlv$udp_local_routing_cache: [XDCL, oss$task_private] nlt$udp_local_routing_cache :=
          [[0, 0, 0], [0, 0, 0]];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_await_clear_to_send', EJECT ??
*copy nlh$udp_await_clear_to_send

  PROCEDURE [XDCL] nlp$udp_await_clear_to_send
    (    global_socket_id: nlt$udp_global_socket_id;
         wait: boolean;
     VAR activity_complete: boolean);

    VAR
      active_connection_count: nlt$device_count,
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      connection_list: ^array [1 .. * ] of nat$connection_id,
      current_task_id: ost$global_task_id,
      device_id: nlt$device_identifier,
      global_socket: ^nlt$udp_global_socket,
      ignore_status: ost$status,
      layer_active: boolean,
      outbound_capacity: nat$data_length,
      previous_sender_task: ^^nlt$udp_sender_task,
      queue_count: nlt$device_count,
      root: nlt$udp_reference_number,
      sender_task: ^nlt$udp_sender_task,
      socket_device_list: ^nlt$udp_socket_device_list,
      udp_connection: ^nlt$udp_socket_layer;

    activity_complete := FALSE;
    queue_count := 0;
    pmp$get_executing_task_gtid (current_task_id);
    IF NOT wait THEN
      root := global_socket_id.reference_number MOD (UPPERBOUND (nlv$udp_global_sockets.list^) + 1);
      nlp$udp_get_nonexclu_to_root (root);
      global_socket := nlv$udp_global_sockets.list^ [root].first;
      WHILE (global_socket <> NIL) AND (global_socket^.identifier <> global_socket_id) DO
        global_socket := global_socket^.next_entry;
      WHILEND;
    ELSE { wait = TRUE
      nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
    IFEND;

    IF (global_socket <> NIL) THEN
      IF global_socket^.status = nlc$udp_global_socket_open THEN

{ Build a list of connection ids.

        socket_device_list := ^global_socket^.device_list;
        PUSH connection_list: [1 .. UPPERBOUND (socket_device_list^)];
        FOR device_id := 1 TO UPPERBOUND (socket_device_list^) DO
          IF socket_device_list^ [device_id].status <> nlc$udp_device_closed THEN
            connection_list^ [device_id] := socket_device_list^ [device_id].connection_id;
          ELSE
            connection_list^ [device_id] := nac$null_connection_id;
          IFEND;
        FOREND;
        IF NOT wait THEN
          nlp$udp_free_nonexclu_to_root (root);
        ELSE
          nlp$udp_free_exclusive_access (global_socket);
        IFEND;

{ Check outbound capacity of each connection.

      /check_clear_to_send/
        FOR device_id := 1 TO UPPERBOUND (connection_list^) DO
          IF connection_list^ [device_id] <> nac$null_connection_id THEN
            nlp$cl_get_exclusive_via_cid (connection_list^ [device_id], connection_exists, cl_connection);
            IF cl_connection <> NIL THEN
              nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, layer_active, udp_connection);
              IF (layer_active) AND (udp_connection^.state = nlc$udp_conn_open) THEN
                IF udp_connection^.send_queue = NIL THEN
                  nlp$osi_get_outbound_capacity (cl_connection, outbound_capacity);
                  IF outbound_capacity <= 0 THEN
                    nlp$cc_receive_data (cl_connection);
                    nlp$osi_get_outbound_capacity (cl_connection, outbound_capacity);
                  IFEND;
                  IF outbound_capacity > 0 THEN
                    activity_complete := TRUE;
                    nlp$cl_release_exclusive_access (cl_connection);
                    EXIT /check_clear_to_send/;
                  ELSEIF wait THEN

{ Queue the task in the send queue.

                    get_sender_task_entry (udp_connection, sender_task);
                    sender_task^.next_entry := NIL;
                    sender_task^.task_id := current_task_id;
                    sender_task^.send_type := nlc$udp_await_clear_to_send;
                    udp_connection^.send_queue := sender_task;
                  IFEND;
                ELSE { udp_connection^.send_queue <> NIL
                  IF udp_connection^.send_queue^.task_id = current_task_id THEN

{ Current task is already queued and is at the head of the queue.

                    nlp$osi_get_outbound_capacity (cl_connection, outbound_capacity);
                    IF outbound_capacity <= 0 THEN
                      nlp$cc_receive_data (cl_connection);
                      nlp$osi_get_outbound_capacity (cl_connection, outbound_capacity);
                    IFEND;
                    IF outbound_capacity > 0 THEN
                      activity_complete := TRUE;
                      sender_task := udp_connection^.send_queue;
                      udp_connection^.send_queue := sender_task^.next_entry;
                      return_sender_task_entry (udp_connection, sender_task);
                      IF udp_connection^.send_queue <> NIL THEN
                        pmp$ready_task (udp_connection^.send_queue^.task_id, ignore_status);
                      IFEND;
                      nlp$cl_release_exclusive_access (cl_connection);
                      EXIT /check_clear_to_send/;
                    ELSEIF NOT wait THEN

{ Dequeue the task.

                      sender_task := udp_connection^.send_queue;
                      udp_connection^.send_queue := sender_task^.next_entry;
                      return_sender_task_entry (udp_connection, sender_task);
                      nlp$cl_release_exclusive_access (cl_connection);
                      CYCLE /check_clear_to_send/;
                    IFEND;
                  ELSE { task not at the head of the send queue

{ Queue the task if not already queued.

                    previous_sender_task := ^udp_connection^.send_queue;
                    WHILE (previous_sender_task^ <> NIL) AND (previous_sender_task^^.task_id <>
                          current_task_id) DO
                      previous_sender_task := ^previous_sender_task^^.next_entry;
                    WHILEND;
                    IF wait THEN
                      IF previous_sender_task^ = NIL THEN

{ The task is not already queued.

                        get_sender_task_entry (udp_connection, sender_task);
                        sender_task^.next_entry := NIL;
                        sender_task^.task_id := current_task_id;
                        sender_task^.send_type := nlc$udp_await_clear_to_send;
                        previous_sender_task^ := sender_task;
                      IFEND;
                    ELSE { NOT wait
                      IF previous_sender_task^ <> NIL THEN
                        sender_task := previous_sender_task^;
                        previous_sender_task^ := sender_task^.next_entry;
                        return_sender_task_entry (udp_connection, sender_task);
                        nlp$cl_release_exclusive_access (cl_connection);
                      IFEND;
                      CYCLE /check_clear_to_send/;
                    IFEND;
                  IFEND;
                IFEND;
                queue_count := queue_count + 1;
              IFEND;
              nlp$cl_release_exclusive_access (cl_connection);
            IFEND;
          IFEND;
        FOREND /check_clear_to_send/;

        IF activity_complete THEN

{ Dequeue the task from the send queue on all the connections.

          FOR device_id := 1 TO UPPERBOUND (connection_list^) DO
            IF connection_list^ [device_id] <> nac$null_connection_id THEN
              nlp$cl_get_exclusive_via_cid (connection_list^ [device_id], connection_exists, cl_connection);
              IF cl_connection <> NIL THEN
                nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, layer_active, udp_connection);
                IF (layer_active) AND (udp_connection^.state = nlc$udp_conn_open) THEN
                  IF udp_connection^.send_queue <> NIL THEN
                    sender_task := udp_connection^.send_queue;
                    previous_sender_task := ^udp_connection^.send_queue;

                  /dequeue_sender/
                    REPEAT
                      IF sender_task^.task_id = current_task_id THEN
                        previous_sender_task^ := sender_task^.next_entry;
                        return_sender_task_entry (udp_connection, sender_task);
                      ELSE
                        previous_sender_task := ^sender_task^.next_entry;
                        sender_task := sender_task^.next_entry;
                      IFEND;
                    UNTIL (sender_task = NIL);
                  IFEND;
                IFEND;
                nlp$cl_release_exclusive_access (cl_connection);
              IFEND;
            IFEND;
          FOREND;
        IFEND;
        IF (queue_count = 0) AND (NOT activity_complete) THEN

{ No device available. Is it ok to return with activity complete = TRUE ?????

          activity_complete := TRUE;
        IFEND;
      ELSE { global_socket^.status <> nlc$udp_global_socket_open

{ Socket terminated via application mgmt.

        activity_complete := TRUE;
        IF NOT wait THEN
          nlp$udp_free_nonexclu_to_root (root);
        ELSE
          nlp$udp_free_exclusive_access (global_socket);
        IFEND;
      IFEND;
    ELSE { global_socket = NIL

{ Socket is assumed to be terminated via application management.

      activity_complete := TRUE;
      IF NOT wait THEN
        nlp$udp_free_nonexclu_to_root (root);
      IFEND;
    IFEND;

  PROCEND nlp$udp_await_clear_to_send;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_await_data_available', EJECT ??
*copy nlh$udp_await_data_available

  PROCEDURE [XDCL] nlp$udp_await_data_available
    (    global_socket_id: nlt$udp_global_socket_id;
         wait: boolean;
     VAR activity_complete: boolean);

    VAR
      another_receiver_active: boolean,
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      connection_list: ^array [1 .. * ] of nat$connection_id,
      current_task_id: ost$global_task_id,
      device_id: nlt$device_identifier,
      global_socket: ^nlt$udp_global_socket,
      ignore_status: ost$status,
      layer_active: boolean,
      previous_receiver_task: ^^nlt$udp_receiver_task,
      receiver_task: ^nlt$udp_receiver_task,
      scan_connections: boolean,
      socket_device_list: ^nlt$udp_socket_device_list,
      udp_connection: ^nlt$udp_socket_layer;

    activity_complete := FALSE;
    another_receiver_active := FALSE;
    scan_connections := FALSE;
    pmp$get_executing_task_gtid (current_task_id);
    nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);

    IF global_socket <> NIL THEN
      IF global_socket^.status = nlc$udp_global_socket_open THEN
        IF global_socket^.receive_wait_queue = NIL THEN
          nlp$udp_activate_receiver (global_socket^.active_receiver, another_receiver_active);
        IFEND;

        IF (global_socket^.receive_wait_queue = NIL) AND (NOT another_receiver_active) THEN
          PUSH connection_list: [1 .. UPPERBOUND (global_socket^.device_list)];

{ Scan the devices for queued messages.

          socket_device_list := ^global_socket^.device_list;

        /scan_devices_1/
          FOR device_id := 1 TO UPPERBOUND (socket_device_list^) DO
            IF socket_device_list^ [device_id].received_messages <> NIL THEN
              activity_complete := TRUE;
              nlp$udp_deactivate_receiver (global_socket^.active_receiver);
              EXIT /scan_devices_1/;
            IFEND;
            IF (socket_device_list^ [device_id].status = nlc$udp_device_open) OR
                  (socket_device_list^ [device_id].status = nlc$udp_device_await_confirm) THEN
              connection_list^ [device_id] := socket_device_list^ [device_id].connection_id;
            ELSE
              connection_list^ [device_id] := nac$null_connection_id;
            IFEND;
          FOREND /scan_devices_1/;
          IF NOT activity_complete THEN

{ Queue the task.

            scan_connections := TRUE;
            get_receiver_task_entry (global_socket, receiver_task);
            receiver_task^.next_entry := NIL;
            receiver_task^.task_id := current_task_id;
            receiver_task^.receive_type := nlc$udp_await_data_available;
            receiver_task^.activity_complete := ^activity_complete;
            receiver_task^.receiver_active := TRUE;
            global_socket^.receive_wait_queue := receiver_task;
          IFEND;
        ELSE

{ Find the task in the receive queue. If task is already queued and wait is not selected,
{ dequeue the task. If wait is selected, queue the task at the end of the receive queue
{ if not already queued.

          previous_receiver_task := ^global_socket^.receive_wait_queue;
          WHILE (previous_receiver_task^ <> NIL) AND (previous_receiver_task^^.task_id <> current_task_id) DO
            previous_receiver_task := ^previous_receiver_task^^.next_entry;
          WHILEND;
          IF previous_receiver_task^ = NIL THEN
            IF wait THEN

{ Queue the curent task as it is not in the receive queue.

              get_receiver_task_entry (global_socket, receiver_task);
              receiver_task^.next_entry := NIL;
              receiver_task^.task_id := current_task_id;
              receiver_task^.receive_type := nlc$udp_await_data_available;
              receiver_task^.activity_complete := ^activity_complete;
              receiver_task^.receiver_active := FALSE;
              previous_receiver_task^ := receiver_task;
            IFEND;
          ELSE { task already queued
            IF global_socket^.receive_wait_queue^.task_id = current_task_id THEN

{ Task is at the head of the receive wait queue.

              receiver_task := global_socket^.receive_wait_queue;
              IF NOT receiver_task^.receiver_active THEN
                nlp$udp_activate_receiver (global_socket^.active_receiver, another_receiver_active);
                receiver_task^.receiver_active := NOT another_receiver_active;
              IFEND;

              IF receiver_task^.receiver_active THEN
                PUSH connection_list: [1 .. UPPERBOUND (global_socket^.device_list)];

{ Scan the devices for queued messages.

                socket_device_list := ^global_socket^.device_list;

              /scan_devices_2/
                FOR device_id := 1 TO UPPERBOUND (socket_device_list^) DO
                  IF socket_device_list^ [device_id].received_messages <> NIL THEN
                    activity_complete := TRUE;
                    global_socket^.receive_wait_queue := receiver_task^.next_entry;
                    return_receiver_task_entry (global_socket, receiver_task);
                    nlp$udp_deactivate_receiver (global_socket^.active_receiver);
                    IF global_socket^.receive_wait_queue <> NIL THEN
                      pmp$ready_task (global_socket^.receive_wait_queue^.task_id, ignore_status);
                    IFEND;
                    EXIT /scan_devices_2/;
                  IFEND;
                  IF (socket_device_list^ [device_id].status = nlc$udp_device_open) OR
                        (socket_device_list^ [device_id].status = nlc$udp_device_await_confirm) THEN
                    connection_list^ [device_id] := socket_device_list^ [device_id].connection_id;
                  ELSE
                    connection_list^ [device_id] := nac$null_connection_id;
                  IFEND;
                FOREND /scan_devices_2/;
                scan_connections := NOT activity_complete;
              IFEND;
            ELSE { task is not at the head of the queue
              IF NOT wait THEN

{ Dequeue the task.

                receiver_task := previous_receiver_task^;
                previous_receiver_task^ := receiver_task^.next_entry;
                return_receiver_task_entry (global_socket, receiver_task);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      ELSE { global_socket^.status <> nlc$udp_global_socket_open

{ The socket has been terminated via application management.

        activity_complete := TRUE;
      IFEND;
      nlp$udp_free_exclusive_access (global_socket);
    ELSE { global_socket = NIL

{ The socket is assumed to have been terminated via application management.

      activity_complete := TRUE;
    IFEND;

    IF NOT activity_complete AND scan_connections THEN

{ Scan the connections for data.

    /scan_connections_for_data/
      FOR device_id := 1 TO UPPERBOUND (connection_list^) DO
        IF connection_list^ [device_id] <> nac$null_connection_id THEN
          nlp$cl_get_exclusive_via_cid (connection_list^ [device_id], connection_exists, cl_connection);
          IF cl_connection <> NIL THEN
            nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, layer_active, udp_connection);
            IF (layer_active) AND ((udp_connection^.state = nlc$udp_conn_open) OR
                  (udp_connection^.state = nlc$udp_conn_await_confirm)) THEN
              nlp$cc_receive_data (cl_connection);
              #SPOIL (activity_complete);
              IF activity_complete THEN
                nlp$cl_release_exclusive_access (cl_connection);
                EXIT /scan_connections_for_data/;
              IFEND;
            IFEND;
            nlp$cl_release_exclusive_access (cl_connection);
          IFEND;
        IFEND;
      FOREND /scan_connections_for_data/;

      IF (NOT activity_complete) AND (NOT wait) THEN
        nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
        IF (global_socket <> NIL) AND (global_socket^.status = nlc$udp_global_socket_open) THEN
          receiver_task := global_socket^.receive_wait_queue;
          global_socket^.receive_wait_queue := receiver_task^.next_entry;
          return_receiver_task_entry (global_socket, receiver_task);
          nlp$udp_deactivate_receiver (global_socket^.active_receiver);
          IF global_socket^.receive_wait_queue <> NIL THEN
            pmp$ready_task (global_socket^.receive_wait_queue^.task_id, ignore_status);
          IFEND;
          nlp$udp_free_exclusive_access (global_socket);
        IFEND;
      IFEND;
    IFEND;

  PROCEND nlp$udp_await_data_available;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_bind_socket', EJECT ??
*copy nlh$udp_bind_socket

  PROCEDURE [XDCL] nlp$udp_bind_socket
    (    global_socket_id: nlt$udp_global_socket_id;
         port: nat$sk_port_number;
         traffic_pattern: nat$sk_traffic_pattern;
         ip_address: nat$sk_ip_address;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      connection_id: nat$connection_id,
      count: nlt$device_count,
      current_time: integer,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      device_and_data_list: array [1 .. 1] of nlt$cc_device_and_data_record,
      device_id: nlt$device_identifier,
      end_time: integer,
      global_socket: ^nlt$udp_global_socket,
      i: integer,
      ignore_layer_active: boolean,
      j: integer,
      next_sender_pool_entry: ^nlt$udp_sender_task,
      open_socket_request: nlt$udpaa_open_request,
      open_socket_pdus: ^array [1 .. * ] of nlt$bm_message_id,
      previous_pool_entry: ^^nlt$udp_sender_task,
      remaining_time: integer,
      request_count: nlt$device_count,
      response_count: nlt$device_count,
      sender_pool_entry: ^nlt$udp_sender_task,
      udp_connection: ^nlt$udp_socket_layer,
      udp_devices: ^nlt$tm_device_address_list;

    count := 0;
    PUSH udp_devices: [1 .. UPPERBOUND (nlv$configured_network_devices.network_device_list^)];
    IF ip_address <> nac$sk_all_ip_addresses THEN
      nlp$tm_select_by_local_udp_addr (ip_address, udp_devices^ [1].device_id, status);
      IF status.normal THEN
        udp_devices^ [1].address := ip_address;
        count := 1;
      IFEND;
    ELSE

{ This procedure will return the list of UDP devices and the associated
{ IP addresses.

      nlp$tm_get_local_udp_devices (udp_devices^, count);
      IF count = 0 THEN
        osp$set_status_abnormal (nac$status_id, nae$sk_no_device_configured, 'UDP', status);
      IFEND;
    IFEND;

{ Send open socket requests to all the devices configured with UDP.

    IF status.normal THEN
      PUSH open_socket_pdus: [1 .. count];
      open_socket_request.header.kind := nlc$udpaa_open_req;
      open_socket_request.header.length := #SIZE (open_socket_request);
      open_socket_request.port := port;
      open_socket_request.traffic_pattern := traffic_pattern;
      data_fragment [1].address := ^open_socket_request;
      data_fragment [1].length := open_socket_request.header.length;

      request_count := 0;
      nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
      IF global_socket <> NIL THEN
        IF global_socket^.status = nlc$udp_global_socket_unbound THEN
          FOR i := 1 TO count DO
            nlp$bm_create_message (data_fragment, open_socket_pdus^ [i], {ignore} status);
          FOREND;

          global_socket^.port := port;
          global_socket^.status := nlc$udp_global_socket_open;

{ Initialize all entries in the socket device list.

          FOR i := 1 TO count DO
            device_id := udp_devices^ [i].device_id;
            device_and_data_list [1].device_id := device_id;
            device_and_data_list [1].data := open_socket_pdus^ [i];
            global_socket^.device_list [device_id].ip_address := udp_devices^ [i].address;
            nlp$cl_create_connection (nlc$udp_interface, cl_connection);
            IF cl_connection <> NIL THEN
              nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, ignore_layer_active,
                    udp_connection);
              nlp$cc_request_connection (cl_connection, device_and_data_list, nlc$udp_access_address,
                    nlc$cc_normal_class {?} , status);
              IF status.normal THEN
                nlp$udp_store_receiver (global_socket^.active_receiver, cl_connection);
                nlp$cl_activate_layer (nlc$udp_interface, cl_connection);
                global_socket^.device_list [device_id].connection_id := cl_connection^.identifier;
                global_socket^.device_list [device_id].status := nlc$udp_device_await_confirm;
                global_socket^.active_device_count := global_socket^.active_device_count + 1;

{ Setup the remaining fields in the UDP socket layer connection.

                udp_connection^.state := nlc$udp_conn_await_confirm;
                udp_connection^.device_id := device_id;
                udp_connection^.local_ip_address := udp_devices^ [i].address;
                udp_connection^.global_socket_id := global_socket_id;
                udp_connection^.inventory_report := 0;
                udp_connection^.send_queue := NIL;
                udp_connection^.available_sender_pool := NIL;
                request_count := request_count + 1;
              ELSE { Unable to request CC connection
                global_socket^.device_list [device_id].status := nlc$udp_device_res_constraint;
                status.normal := TRUE;

{ Note all other abnormal status codes are being treated as resource constraint.

              IFEND;
              nlp$cl_release_exclusive_access (cl_connection);
            ELSE

{ Mark the device as being in resource contraint and the timer task will periodically
{ try to open the connection.

              global_socket^.device_list [device_id].status := nlc$udp_device_res_constraint;
              nlp$bm_release_message (open_socket_pdus^ [i]);
            IFEND;
          FOREND;
          IF request_count > 0 THEN
            pmp$get_executing_task_gtid (global_socket^.waiting_task_id);
          IFEND;
        ELSE { all other states unaccepted
          nap$namve_system_error ({Recoverable_error=} TRUE, 'Encountered unexpected global socket status ',
                NIL);
          osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'BIND SOCKET', status);
        IFEND;
        nlp$udp_free_exclusive_access (global_socket);
      ELSE { global_socket = NIL

{ The socket is assumed to be terminated via application management.

        osp$set_status_condition (nae$sk_socket_terminated, status);
      IFEND;

{ Wait for (1/2 to 1 sec) responses from the devices.

      IF request_count > 0 THEN
        IF request_count = 1 THEN
          remaining_time := 500000;
        ELSE
          remaining_time := 1000000;
        IFEND;
        end_time := #FREE_RUNNING_CLOCK (0) + remaining_time;

      /wait_loop/
        REPEAT
          pmp$wait (remaining_time, 0);
          current_time := #FREE_RUNNING_CLOCK (0);
          IF current_time < end_time THEN
            remaining_time := (end_time - current_time);
          ELSE
            remaining_time := 0;
          IFEND;

          nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
          IF global_socket <> NIL THEN
            IF global_socket^.status = nlc$udp_global_socket_open THEN

{ Check the socket status with respect to each device.

              response_count := 0;

            /await_response/
              FOR i := 1 TO UPPERBOUND (global_socket^.device_list) DO
                IF global_socket^.device_list [i].status = nlc$udp_device_await_confirm THEN
                  connection_id := global_socket^.device_list [i].connection_id;
                  nlp$udp_free_exclusive_access (global_socket);
                  nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
                  IF connection_exists THEN
                    nlp$cc_receive_data (cl_connection);
                    nlp$cl_release_exclusive_access (cl_connection);
                  IFEND;
                  nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
                  IF global_socket = NIL THEN
                    nap$namve_system_error ({Recoverable_error=} TRUE,
                          'Encountered unexpected global socket status ', NIL);
                    osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'BIND SOCKET', status);
                    EXIT /wait_loop/;
                  ELSEIF global_socket^.status <> nlc$udp_global_socket_open THEN
                    osp$set_status_condition (nae$sk_socket_terminated, status);
                    EXIT /wait_loop/;
                  IFEND;
                IFEND;
                IF global_socket^.device_list [i].status = nlc$udp_device_open THEN
                  response_count := response_count + 1;
                ELSEIF (global_socket^.device_list [i].status = nlc$udp_device_closed) AND
                      (global_socket^.device_list [i].ip_address <> nac$sk_all_ip_addresses) THEN
                  response_count := response_count + 1;
                IFEND;
              FOREND /await_response/;
            ELSE { all other states are unaccepted
              nap$namve_system_error ({Recoverable_error=} TRUE,
                    'Encountered unexpected global socket status ', NIL);
              osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'BIND SOCKET', status);
            IFEND;
            IF (response_count = request_count) OR (remaining_time = 0) OR (NOT status.normal) THEN
              global_socket^.waiting_task_id.index := 0;
            IFEND;
            nlp$udp_free_exclusive_access (global_socket);
          ELSE { global_socket = NIL

{ The socket is assumed to be terminated via application management.

            osp$set_status_condition (nae$sk_socket_terminated, status);
          IFEND;
        UNTIL (response_count = request_count) OR (remaining_time = 0) OR (NOT status.normal);
      IFEND;
    IFEND;

  PROCEND nlp$udp_bind_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_cancel_socket_offer', EJECT ??
*copy nlh$udp_cancel_socket_offer

  PROCEDURE [XDCL] nlp$udp_cancel_socket_offer
    (    global_socket_id: nlt$udp_global_socket_id;
     VAR status: ost$status);

    VAR
      global_socket: ^nlt$udp_global_socket;

    nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
    IF global_socket <> NIL THEN
      IF global_socket^.status = nlc$udp_global_socket_offered THEN
        global_socket^.status := nlc$udp_global_socket_open;
      ELSE { unexpected status
        nap$namve_system_error ({Recoverable_error=} TRUE,
              'Encountered unexpected global socket status ', NIL);
        osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'CANCEL SOCKET OFFER', status);
      IFEND;
      nlp$udp_free_exclusive_access (global_socket);
    ELSE { global_socket = NIL

{ The socket is assumed to be terminated via application management.

      osp$set_status_condition (nae$sk_socket_terminated, status);
    IFEND;

  PROCEND nlp$udp_cancel_socket_offer;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_close_socket', EJECT ??
*copy nlh$udp_close_socket

  PROCEDURE [XDCL] nlp$udp_close_socket
    (    global_socket_id: nlt$udp_global_socket_id;
         close_via_application_mgmt: boolean);

    VAR
      active_connection_count: integer,
      cl_connection: ^nlt$cl_connection,
      closed_connection_count: integer,
      connection_exists: boolean,
      connection_list: ^array [1 .. * ] of nat$connection_id,
      delete_global_socket: boolean,
      device_id: nlt$device_identifier,
      global_socket: ^nlt$udp_global_socket,
      ignore_status: ost$status,
      layer_active: boolean,
      new_status: nlt$udp_global_socket_status,
      next_received_message: ^nlt$udp_received_message,
      previous_receiver_task: ^^nlt$udp_receiver_task,
      previous_sender_task: ^^nlt$udp_sender_task,
      received_message: ^nlt$udp_received_message,
      receiver_task: ^nlt$udp_receiver_task,
      sender_task: ^nlt$udp_sender_task,
      socket_device_list: ^nlt$udp_socket_device_list,
      udp_connection: ^nlt$udp_socket_layer;

    closed_connection_count := 0;
    IF close_via_application_mgmt THEN
      new_status := nlc$udp_global_socket_term;
    ELSE
      new_status := nlc$udp_global_socket_closed;
    IFEND;

    nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
    IF global_socket <> NIL THEN
      IF (global_socket^.status = nlc$udp_global_socket_open) OR
            (global_socket^.status = nlc$udp_global_socket_offered) THEN
        global_socket^.status := new_status;
        socket_device_list := ^global_socket^.device_list;
        PUSH connection_list: [1 .. UPPERBOUND (socket_device_list^)];

{ Update the status of each device to closed. Ready all active
{ receivers and discard all queued messages.

        FOR device_id := 1 TO UPPERBOUND (socket_device_list^) DO
          IF socket_device_list^ [device_id].status <> nlc$udp_device_closed THEN
            connection_list^ [device_id] := socket_device_list^ [device_id].connection_id;
            IF socket_device_list^ [device_id].received_messages <> NIL THEN
              received_message := socket_device_list^ [device_id].received_messages;
              socket_device_list^ [device_id].received_messages := NIL;
              WHILE received_message <> NIL DO
                IF received_message^.data <> nlv$bm_null_message_id THEN
                  nlp$bm_release_message (received_message^.data);
                IFEND;
                next_received_message := received_message^.next_entry;
                FREE received_message IN nav$network_paged_heap^;
                received_message := next_received_message;
              WHILEND;
            IFEND;
            IF socket_device_list^ [device_id].receiver_task <> NIL THEN

{ Requeue and ready the receiver task.

              receiver_task := socket_device_list^ [device_id].receiver_task;
              socket_device_list^ [device_id].receiver_task := NIL;
              receiver_task^.next_entry := global_socket^.receive_wait_queue;
              global_socket^.receive_wait_queue := receiver_task;
              pmp$ready_task (receiver_task^.task_id, ignore_status);
            IFEND;
          ELSE
            connection_list^ [device_id] := nac$null_connection_id;
          IFEND;
        FOREND;

{ Ready all tasks in the receive queue.

        IF global_socket^.receive_wait_queue <> NIL THEN
          previous_receiver_task := ^global_socket^.receive_wait_queue;
          receiver_task := global_socket^.receive_wait_queue;
          WHILE receiver_task <> NIL DO
            pmp$ready_task (receiver_task^.task_id, ignore_status);
            IF receiver_task^.receive_type = nlc$udp_await_data_available THEN
              previous_receiver_task^ := receiver_task^.next_entry;
              FREE receiver_task IN nav$network_paged_heap^;
              receiver_task := previous_receiver_task^;
            ELSE
              previous_receiver_task := ^receiver_task^.next_entry;
              receiver_task := receiver_task^.next_entry;
            IFEND;
          WHILEND;
        IFEND;

        nlp$udp_free_exclusive_access (global_socket);

{ Terminate all active connections.

        FOR device_id := 1 TO UPPERBOUND (connection_list^) DO
          IF connection_list^ [device_id] <> nac$null_connection_id THEN
            nlp$cl_get_exclusive_via_cid (connection_list^ [device_id], connection_exists, cl_connection);
            IF connection_exists THEN
              nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, layer_active, udp_connection);
              IF layer_active THEN
                IF udp_connection^.state <> nlc$udp_conn_closed THEN
                  udp_connection^.state := nlc$udp_conn_closed;
                  issue_disconnect (cl_connection, nlc$udpaa_rr_user_request);
                  IF udp_connection^.send_queue <> NIL THEN
                    previous_sender_task := ^udp_connection^.send_queue;
                    sender_task := udp_connection^.send_queue;

{ Ready each task awaiting clear to send and dequeue its entry.
{ Send a signal to each task waiting to send data.

                    WHILE sender_task <> NIL DO
                      pmp$ready_task (sender_task^.task_id, ignore_status);
                      IF sender_task^.send_type = nlc$udp_await_clear_to_send THEN
                        previous_sender_task^ := sender_task^.next_entry;
                        FREE sender_task IN nav$network_paged_heap^;
                        sender_task := previous_sender_task^;
                      ELSE
                        previous_sender_task := ^sender_task^.next_entry;
                        sender_task := sender_task^.next_entry;
                      IFEND;
                    WHILEND;
                  IFEND;
                  IF udp_connection^.send_queue = NIL THEN
                    deactivate_udp_layer (cl_connection, udp_connection);
                    closed_connection_count := closed_connection_count + 1;
                  IFEND;
                IFEND;
              IFEND;
              nlp$cl_release_exclusive_access (cl_connection);
            IFEND;
          IFEND;
        FOREND;

{ Determine if the global socket can be deleted.

        nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
        IF global_socket <> NIL THEN
          global_socket^.active_device_count := global_socket^.active_device_count - closed_connection_count;
          delete_global_socket := (global_socket^.receive_wait_queue = NIL) AND
                (global_socket^.active_device_count = 0);
          nlp$udp_free_exclusive_access (global_socket);
          IF delete_global_socket THEN
            nlp$udp_delete_global_socket (global_socket_id);
          IFEND;
        IFEND;
      ELSE { global_socket^.status = unbound, terminated
        global_socket^.status := new_status;
        nlp$udp_free_exclusive_access (global_socket);
        nlp$udp_delete_global_socket (global_socket_id);
      IFEND;
    IFEND;

  PROCEND nlp$udp_close_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_connect_event_processor', EJECT ??
*copy nlh$udp_connect_event_processor

  PROCEDURE [XDCL] nlp$udp_connect_event_processor
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);


{ A connect event is treated as a protocol error and results in a
{ disconnect being sent to the peer.

    issue_disconnect (cl_connection, nlc$udpaa_rr_protocol_error);

  PROCEND nlp$udp_connect_event_processor;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_device_available', EJECT ??
*copy nlh$udp_device_available

  PROCEDURE [XDCL] nlp$udp_device_available
    (    device_id: nlt$device_identifier;
         local_ip_address: nat$sk_ip_address);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      device_and_data_list: array [1 .. 1] of nlt$cc_device_and_data_record,
      global_socket: ^nlt$udp_global_socket,
      ignore_layer_active: boolean,
      local_status: ost$status,
      next_global_socket: ^nlt$udp_global_socket,
      open_socket_request: nlt$udpaa_open_request,
      root: nlt$udp_reference_number,
      udp_connection: ^nlt$udp_socket_layer;

    IF nlv$udp_global_sockets.list <> NIL THEN
      open_socket_request.header.kind := nlc$udpaa_open_req;
      open_socket_request.header.length := #SIZE (open_socket_request);
      data_fragment [1].address := ^open_socket_request;
      data_fragment [1].length := open_socket_request.header.length;

    /traverse_roots/
      FOR root := LOWERBOUND (nlv$udp_global_sockets.list^) TO UPPERBOUND (nlv$udp_global_sockets.list^) DO
        nlp$udp_get_nonexclu_to_root (root);
        global_socket := nlv$udp_global_sockets.list^ [root].first;

      /traverse_stem/
        WHILE global_socket <> NIL DO
          nlp$udp_get_exclusive_access (global_socket^.lock);
          IF (global_socket^.status = nlc$udp_global_socket_open) AND
                ((global_socket^.bound_address = nac$sk_all_ip_addresses) OR
                (global_socket^.bound_address = local_ip_address)) THEN
            IF global_socket^.device_list [device_id].status = nlc$udp_device_closed THEN

{ Setup the open socket pdu.

              open_socket_request.port := global_socket^.port;
              open_socket_request.traffic_pattern := global_socket^.traffic_pattern;
              nlp$bm_create_message (data_fragment, device_and_data_list [1].data, local_status);
              global_socket^.device_list [device_id].ip_address := local_ip_address;
              device_and_data_list [1].device_id := device_id;
              nlp$cl_create_connection (nlc$udp_interface, cl_connection);
              IF cl_connection <> NIL THEN
                nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, ignore_layer_active,
                      udp_connection);
                nlp$cc_request_connection (cl_connection, device_and_data_list, nlc$udp_access_address,
                      nlc$cc_normal_class {?} , local_status);
                IF local_status.normal THEN
                  nlp$udp_store_receiver (global_socket^.active_receiver, cl_connection);
                  nlp$cl_activate_layer (nlc$udp_interface, cl_connection);
                  global_socket^.device_list [device_id].connection_id := cl_connection^.identifier;
                  global_socket^.device_list [device_id].status := nlc$udp_device_await_confirm;
                  global_socket^.active_device_count := global_socket^.active_device_count + 1;

{ Setup the remaining fields in the UDP socket layer connection.

                  udp_connection^.state := nlc$udp_conn_await_confirm;
                  udp_connection^.device_id := device_id;
                  udp_connection^.local_ip_address := local_ip_address;
                  udp_connection^.global_socket_id := global_socket^.identifier;
                  udp_connection^.inventory_report := 0;
                  udp_connection^.send_queue := NIL;
                  udp_connection^.available_sender_pool := NIL;
                  udp_connection^.device_id := device_id;
                ELSE { Unable to request CC connection
                  global_socket^.device_list [device_id].status := nlc$udp_device_res_constraint;
                  local_status.normal := TRUE;

{ Note all other abnormal status codes are being treated as resource constraint.

                IFEND;
                nlp$cl_release_exclusive_access (cl_connection);
              ELSE

{ Mark the connection as being in resource contraint and the timer task will periodically
{ try to open the connection.

                global_socket^.device_list [device_id].status := nlc$udp_device_res_constraint;
                nlp$bm_release_message (device_and_data_list [1].data);
              IFEND;
            IFEND;
          IFEND;
          next_global_socket := global_socket^.next_entry;
          nlp$udp_free_exclusive_access (global_socket);
          global_socket := next_global_socket;
        WHILEND /traverse_stem/;
        nlp$udp_free_nonexclu_to_root (root);
      FOREND /traverse_roots/;
    IFEND;

  PROCEND nlp$udp_device_available;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_event_processor', EJECT ??
*copy nlh$udp_event_processor

  PROCEDURE [XDCL] nlp$udp_event_processor
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

    VAR
      broadcast_enabled: boolean,
      buffers_freed: nat$data_length,
      bytes_moved: nat$data_length,
      connection_exists: boolean,
      current_task_id: ost$global_task_id,
      data: nlt$bm_message_id,
      data_fragment: array [1 .. 1] of nat$data_fragment,
      data_length: integer,
      global_socket: ^nlt$udp_global_socket,
      ignore_delete_global_socket: boolean,
      layer_active: boolean,
      local_status: ost$status,
      new_received_message: ^nlt$udp_received_message,
      number_of_buffers_received: integer,
      only_one_message_queued: boolean,
      partial_messages: array [1 .. 2] of nlt$bm_message_id,
      previous_received_message: ^^nlt$udp_received_message,
      previous_sender_task: ^^nlt$udp_sender_task,
      received_message: ^nlt$udp_received_message,
      remaining_length: integer,
      sender_task: ^nlt$udp_sender_task,
      socket_inventory: ^nlt$udp_socket_inventory,
      status: ost$status,
      traffic_pattern: nat$sk_traffic_pattern,
      udp_connection: ^nlt$udp_socket_layer,
      udpaa_clear_send_ind: nlt$udpaa_clear_send_ind,
      udpaa_data_ind: nlt$udpaa_data_ind,
      udpaa_disconnect_ind: nlt$udpaa_release_ind,
      udpaa_open_confirm_ind: nlt$udpaa_open_confirm_ind,
      udpaa_set_options_request: nlt$udpaa_set_options_request;

    inventory_report := 0;
    pmp$get_executing_task_gtid (current_task_id);
    nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, layer_active, udp_connection);
    IF layer_active THEN
      CASE event.kind OF
      = nlc$cc_data_event =
        data := event.data.data;
        IF udp_connection^.state = nlc$udp_conn_open THEN
          nlp$bm_get_message_length (data, data_length);
          IF data_length >= #SIZE (udpaa_data_ind) THEN
            nlp$bm_extract_message_prefix (^udpaa_data_ind, #SIZE (udpaa_data_ind), data,
                  {ignore} bytes_moved);
            nlp$bm_get_message_resources (data, remaining_length, number_of_buffers_received);
            IF (udpaa_data_ind.header.kind = nlc$udpaa_data_ind) AND
                  (udpaa_data_ind.header.length = data_length) THEN
              nlp$udp_get_exclusive_via_gsid (udp_connection^.global_socket_id, global_socket);
              IF global_socket <> NIL THEN
                IF (global_socket^.status <> nlc$udp_global_socket_closed) AND
                      (global_socket^.status <> nlc$udp_global_socket_term) THEN

{ The incoming data will be queued for all socket states execpt closed.

                  IF NOT global_socket^.device_list [udp_connection^.device_id].discard_data THEN
                    only_one_message_queued := FALSE;

{ Queue the data on the socket device entry.
{ Merge the data with any previous fragment or queue it as a separate fragment.

                    received_message := global_socket^.device_list [udp_connection^.device_id].
                          received_messages;
                    previous_received_message := ^global_socket^.device_list [udp_connection^.device_id].
                          received_messages;


                    IF received_message <> NIL THEN
                      WHILE received_message^.next_entry <> NIL DO
                        previous_received_message := ^received_message^.next_entry;
                        received_message := received_message^.next_entry;
                      WHILEND;
                    IFEND;
                    IF (received_message = NIL) OR (received_message^.end_of_message) OR
                          (received_message^.abort_receive) THEN

{ Add the new message.

                      IF global_socket^.available_message_pool <> NIL THEN
                        new_received_message := global_socket^.available_message_pool;
                        global_socket^.available_message_pool := new_received_message^.next_entry;
                        global_socket^.available_message_pool_size :=
                              global_socket^.available_message_pool_size - 1;
                      ELSE { pool empty
                        REPEAT
                          ALLOCATE new_received_message IN nav$network_paged_heap^;
                          IF new_received_message = NIL THEN
                            syp$cycle;
                          IFEND;
                        UNTIL new_received_message <> NIL;
                      IFEND;
                      new_received_message^.next_entry := NIL;
                      new_received_message^.abort_receive := FALSE;
                      new_received_message^.source_socket.port := udpaa_data_ind.source_port;
                      new_received_message^.source_socket.ip_address := udpaa_data_ind.source_ip_address;
                      new_received_message^.destination_ip_address := udpaa_data_ind.destination_ip_address;
                      new_received_message^.end_of_message := udpaa_data_ind.end_of_message;
                      new_received_message^.data := data;
                      new_received_message^.data_length := data_length - #SIZE (udpaa_data_ind);
                      new_received_message^.buffer_count := number_of_buffers_received;
                      IF received_message = NIL THEN
                        previous_received_message^ := new_received_message;
                        only_one_message_queued := TRUE;
                      ELSE { link at the end of the queue
                        received_message^.next_entry := new_received_message;
                      IFEND;
                    ELSE { partial message

{ Verify that the incoming fragment matches the queued data fragment.

                      IF (received_message^.source_socket.port = udpaa_data_ind.source_port) AND
                            (received_message^.source_socket.ip_address =
                            udpaa_data_ind.source_ip_address) AND (received_message^.destination_ip_address =
                            udpaa_data_ind.destination_ip_address) THEN
                        partial_messages [1] := received_message^.data;
                        partial_messages [2] := data;
                        nlp$bm_concatenate_messages (partial_messages, received_message^.data);
                        received_message^.end_of_message := udpaa_data_ind.end_of_message;
                        received_message^.data_length := received_message^.data_length + data_length -
                              #SIZE (udpaa_data_ind);
                        received_message^.buffer_count := received_message^.buffer_count +
                              number_of_buffers_received;
                      ELSE { protocol error
                        nlp$bm_release_message (data);
                        nlp$bm_release_message (received_message^.data);
                        previous_received_message^ := received_message^.next_entry;
                        return_received_message_entry (global_socket, received_message);
                        issue_protocol_error (cl_connection, global_socket, udp_connection);
                      IFEND;
                    IFEND;
                    buffers_freed := 0;
                    IF global_socket^.device_list [udp_connection^.device_id].receiver_task <> NIL THEN
                      IF global_socket^.device_list [udp_connection^.device_id].receiver_task^.task_id =
                            current_task_id THEN
                        receive_data (global_socket, udp_connection^.device_id, buffers_freed);
                      ELSE { current task not the receiver
                        pmp$ready_task (global_socket^.device_list [udp_connection^.device_id].receiver_task^.
                              task_id, {ignore} local_status);
                      IFEND;
                    ELSEIF global_socket^.receive_wait_queue <> NIL THEN
                      IF global_socket^.receive_wait_queue^.task_id = current_task_id THEN
                        activate_next_receiver_task (global_socket, udp_connection^.device_id, buffers_freed);
                      ELSEIF only_one_message_queued THEN
                        pmp$ready_task (global_socket^.receive_wait_queue^.task_id, {ignore} local_status);
                      IFEND;
                    IFEND;
                    udp_connection^.inventory_report := udp_connection^.inventory_report +
                          number_of_buffers_received - buffers_freed;
                  ELSE { discard data
                    IF udpaa_data_ind.end_of_message THEN

{ Clear the discard data flag.

                      global_socket^.device_list [udp_connection^.device_id].discard_data := FALSE;
                    IFEND;
                    nlp$bm_release_message (data);
                  IFEND;
                ELSE { global socket is closed or terminated

{ Discard the data.

                  nlp$bm_release_message (data);
                IFEND;
                inventory_report := udp_connection^.inventory_report;
                nlp$udp_free_exclusive_access (global_socket);
              ELSE {global_socket = NIL

{ Global socket cannot be deleted until all connections have been disconnected.

                nlp$bm_release_message (data);
                inventory_report := udp_connection^.inventory_report;
                nap$namve_system_error ({Recoverable_error=} TRUE,
                      'Encountered a NIL global socket while processing a UDPAA data event.', NIL);
              IFEND;
            ELSE { Invalid event
              nlp$bm_release_message (data);
              inventory_report := udp_connection^.inventory_report;
              process_protocol_error (cl_connection, udp_connection);
            IFEND;
          ELSEIF (data_length = #SIZE (udpaa_clear_send_ind)) THEN
            data_fragment [1].address := ^udpaa_clear_send_ind;
            data_fragment [1].length := #SIZE (udpaa_clear_send_ind);
            nlp$bm_flush_message (data_fragment, data, data_length, {ignore} local_status);
            IF (udpaa_clear_send_ind.header.length = data_length) AND
                  (udpaa_clear_send_ind.header.kind = nlc$udpaa_clear_send_ind) THEN
              process_clear_send_indication (udp_connection, buffers_freed);
              udp_connection^.inventory_report := udp_connection^.inventory_report - buffers_freed;
              inventory_report := udp_connection^.inventory_report;
            ELSE { invalid pdu
              process_protocol_error (cl_connection, udp_connection);
            IFEND;
          ELSE { invalid pdu
            nlp$bm_release_message (data);
            inventory_report := udp_connection^.inventory_report;
            process_protocol_error (cl_connection, udp_connection);
          IFEND;
        ELSE { udp_connection^.state <> nlc$udp_conn_open
          IF udp_connection^.state <> nlc$udp_conn_closed THEN
            process_protocol_error (cl_connection, udp_connection);
          ELSE
            nap$namve_system_error ({Recoverable_error=} TRUE,
                  'Received a data event when the UDP socket layer is closed.', NIL);
          IFEND;
        IFEND;

      = nlc$cc_accept_event =
        IF udp_connection^.state = nlc$udp_conn_await_confirm THEN
          data := event.accept.data;
          nlp$bm_get_message_length (data, data_length);
          IF data_length = #SIZE (udpaa_open_confirm_ind) THEN
            data_fragment [1].address := ^udpaa_open_confirm_ind;
            data_fragment [1].length := data_length;
            nlp$bm_flush_message (data_fragment, data, data_length, {ignore} local_status);
            IF (udpaa_open_confirm_ind.header.kind = nlc$udpaa_open_confirm_ind) AND
                  (udpaa_open_confirm_ind.header.length = data_length) THEN

              udp_connection^.state := nlc$udp_conn_open;
              nlp$udp_get_exclusive_via_gsid (udp_connection^.global_socket_id, global_socket);
              IF global_socket <> NIL THEN

{ Update the status of the socket with respect to the device.

                traffic_pattern := 0;
                broadcast_enabled := FALSE;
                IF global_socket^.device_list [udp_connection^.device_id].status =
                      nlc$udp_device_await_confirm THEN
                  global_socket^.device_list [udp_connection^.device_id].status := nlc$udp_device_open;
                  traffic_pattern := global_socket^.traffic_pattern;
                  broadcast_enabled := global_socket^.broadcast_enabled;
                  IF global_socket^.waiting_task_id.index > 0 THEN
                    pmp$ready_task (global_socket^.waiting_task_id, {ignore} local_status);
                  IFEND;
                IFEND;
                nlp$udp_free_exclusive_access (global_socket);
                IF (traffic_pattern > 0) OR (broadcast_enabled) THEN

{ Send the set socket options request to UDPAP.

                  udpaa_set_options_request.header.kind := nlc$udpaa_set_options_req;
                  udpaa_set_options_request.header.length := #SIZE (udpaa_set_options_request);
                  udpaa_set_options_request.traffic_pattern := traffic_pattern;
                  udpaa_set_options_request.broadcast_enabled := broadcast_enabled;
                  data_fragment [1].address := ^udpaa_set_options_request;
                  data_fragment [1].length := udpaa_set_options_request.header.length;

                  nlp$cc_send_data_fragments (cl_connection, data_fragment, {ignore} local_status);
                  local_status.normal := TRUE;
                IFEND;
              IFEND;
            ELSE
              process_protocol_error (cl_connection, udp_connection);
            IFEND;
          ELSE
            process_protocol_error (cl_connection, udp_connection);
          IFEND;
        ELSE
          nap$namve_system_error ({Recoverable_error=} TRUE, 'Received an unexpected CC accept event', NIL);
        IFEND;

      = nlc$cc_clear_to_send_event =

        IF (udp_connection^.send_queue <> NIL) AND (udp_connection^.send_queue^.task_id <> current_task_id)
              THEN
          activate_next_sender_task (udp_connection);
        IFEND;

      = nlc$cc_disconnect_event =
        IF event.disconnect.reason = nlc$cc_dr_normal_disconnect THEN
          data := event.disconnect.data;
          nlp$bm_get_message_length (event.disconnect.data, data_length);
          IF data_length = #SIZE (udpaa_disconnect_ind) THEN
            data_fragment [1].address := ^udpaa_disconnect_ind;
            data_fragment [1].length := #SIZE (udpaa_disconnect_ind);
            nlp$bm_flush_message (data_fragment, data, data_length, {ignore} local_status);
            IF udp_connection^.state = nlc$udp_conn_open THEN
              IF udpaa_disconnect_ind.header.kind = nlc$udpaa_release_ind THEN
                log_disconnect (udpaa_release, udp_connection^.global_socket_id, udp_connection^.device_id);
                process_disconnect_indication (cl_connection, udp_connection);
              ELSE { Unexpected UDPAA event kind
                nap$namve_system_error ({Recoverable_error=} TRUE, 'Unexpected PDU kind in disconnect event.',
                      NIL);
              IFEND;
            ELSEIF udp_connection^.state = nlc$udp_conn_await_confirm THEN
              IF (udpaa_disconnect_ind.header.kind = nlc$udpaa_open_reject_ind) OR
                    (udpaa_disconnect_ind.header.kind = nlc$udpaa_release_ind) THEN
                deactivate_udp_layer (cl_connection, udp_connection);
                log_disconnect (udpaa_open_reject, udp_connection^.global_socket_id,
                      udp_connection^.device_id);

{ Update the socket device status in the global socket entry and
{ decrement the active device count if the state is closed.

                nlp$udp_get_exclusive_via_gsid (udp_connection^.global_socket_id, global_socket);
                IF global_socket <> NIL THEN
                  global_socket^.device_list [udp_connection^.device_id].status := nlc$udp_device_closed;
                  global_socket^.active_device_count := global_socket^.active_device_count - 1;
                  IF global_socket^.waiting_task_id.index <> 0 THEN
                    pmp$ready_task (global_socket^.waiting_task_id, {ignore} local_status);
                  IFEND;
                  nlp$udp_free_exclusive_access (global_socket);
                IFEND;
              ELSE { Unexpected UDPAA event kind
                nap$namve_system_error ({Recoverable_error=} TRUE, 'Unexpected PDU kind in disconnect event.',
                      NIL);
              IFEND;
            ELSE { Unexpected state
              nap$namve_system_error ({Recoverable_error=} TRUE, 'Unexpected UDP layer connection state.',
                    NIL);
            IFEND;
          ELSE { unexpected length
            nap$namve_system_error ({Recoverable_error=} TRUE, 'Unexpected UDPAA disconnect PDU length', NIL);
          IFEND;
        ELSE { CC disconnect
          IF udp_connection^.state = nlc$udp_conn_open THEN
            log_disconnect (udpaa_cc_disconnect, udp_connection^.global_socket_id, udp_connection^.device_id);
            process_disconnect_indication (cl_connection, udp_connection);
          ELSEIF udp_connection^.state = nlc$udp_conn_await_confirm THEN
            deactivate_udp_layer (cl_connection, udp_connection);
            log_disconnect (udpaa_open_reject, udp_connection^.global_socket_id, udp_connection^.device_id);

{ Update the socket device status in the global socket entry and decrement the active device count
{ if the state is closed.

            nlp$udp_get_exclusive_via_gsid (udp_connection^.global_socket_id, global_socket);
            IF global_socket <> NIL THEN
              global_socket^.device_list [udp_connection^.device_id].status := nlc$udp_device_closed;
              global_socket^.active_device_count := global_socket^.active_device_count - 1;
              IF global_socket^.waiting_task_id.index <> 0 THEN
                pmp$ready_task (global_socket^.waiting_task_id, {ignore} local_status);
              IFEND;
              nlp$udp_free_exclusive_access (global_socket);
            IFEND;
          ELSE { Unexpected state
            nap$namve_system_error ({Recoverable_error=} TRUE, 'Unexpected UDP layer connection state', NIL);
          IFEND;
        IFEND;
      ELSE { Invalid event
        nap$namve_system_error ({Recoverable_error=} TRUE, 'Unexpected CC event', NIL);
      CASEND;
    ELSE { Layer inactive
      nap$namve_system_error ({Recoverable_error=} TRUE,
            'A CC event was delivered when UDP socket layer is inactive.', NIL);
    IFEND;

  PROCEND nlp$udp_event_processor;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_get_bound_addresses', EJECT ??
*copy nlh$udp_get_bound_addresses

  PROCEDURE [XDCL] nlp$udp_get_bound_addresses
    (    global_socket_id: nlt$udp_global_socket_id;
     VAR local_addresses: array [1 .. * ] of nat$sk_ip_address;
     VAR count: nlt$device_count;
     VAR status: ost$status);

    VAR
      device_id: nlt$device_identifier,
      global_socket: ^nlt$udp_global_socket;

    count := 0;
    nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
    IF global_socket <> NIL THEN
      IF global_socket^.status = nlc$udp_global_socket_open THEN

      /get_addresses/
        FOR device_id := 1 TO UPPERBOUND (global_socket^.device_list) DO
          IF global_socket^.device_list [device_id].status <> nlc$udp_device_closed THEN
            count := count + 1;
            local_addresses [count] := global_socket^.device_list [device_id].ip_address;
            IF count = UPPERBOUND (local_addresses) THEN
              EXIT /get_addresses/;
            IFEND;
          IFEND;
        FOREND /get_addresses/;
      ELSEIF global_socket^.status = nlc$udp_global_socket_term THEN

{ The socket has been terminated via application management.

        osp$set_status_condition (nae$sk_socket_terminated, status);
      ELSE { unexpected status
        nap$namve_system_error ({Recoverable_error=} TRUE, 'Encountered unexpected global socket status',
              NIL);
        osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'GET BOUND ADDRESSES', status);
      IFEND;
      nlp$udp_free_exclusive_access (global_socket);
    ELSE { global_socket = NIL

{ The socket is assumed to be terminated via application management.

      osp$set_status_condition (nae$sk_socket_terminated, status);
    IFEND;

  PROCEND nlp$udp_get_bound_addresses;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_get_socket_status', EJECT ??
*copy nlh$udp_get_socket_status

  PROCEDURE [XDCL] nlp$udp_get_socket_status
    (    global_socket_id: nlt$udp_global_socket_id;
     VAR clear_to_send: boolean;
     VAR data_pending_receive: integer;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection_list: ^array [1 .. * ] of nat$connection_id,
      connection_exists: boolean,
      device_id: nlt$device_identifier,
      global_socket: ^nlt$udp_global_socket,
      layer_active: boolean,
      outbound_capacity: nat$data_length,
      socket_device_list: ^nlt$udp_socket_device_list,
      udp_connection: ^nlt$udp_socket_layer;

    clear_to_send := FALSE;
    data_pending_receive := 0;
    nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
    IF global_socket <> NIL THEN
      IF global_socket^.status = nlc$udp_global_socket_open THEN
        socket_device_list := ^global_socket^.device_list;
        PUSH connection_list: [1 .. UPPERBOUND (socket_device_list^)];
        IF global_socket^.receive_wait_queue = NIL THEN

{ Scan the devices for queued messages.

          FOR device_id := 1 TO UPPERBOUND (socket_device_list^) DO
            IF socket_device_list^ [device_id].status = nlc$udp_device_open THEN
              IF (data_pending_receive = 0) AND (socket_device_list^ [device_id].received_messages <> NIL) AND
                    (socket_device_list^ [device_id].receiver_task = NIL) AND
                    (socket_device_list^ [device_id].received_messages^.end_of_message) THEN
                data_pending_receive := socket_device_list^ [device_id].received_messages^.data_length;

                IF data_pending_receive = 0 THEN { These three lines are intended to be temporary and be }
                  data_pending_receive := 1; { replaced when this interface is modified to indicate a that }
                IFEND; {datagram is available even if it is zero length. }

              IFEND;
              connection_list^ [device_id] := socket_device_list^ [device_id].connection_id;
            ELSE
              connection_list^ [device_id] := nac$null_connection_id;
            IFEND;
          FOREND;
        ELSE { receive_queue <> NIL

{ Build a list of connection ids.

          FOR device_id := 1 TO UPPERBOUND (socket_device_list^) DO
            IF socket_device_list^ [device_id].status = nlc$udp_device_open THEN
              connection_list^ [device_id] := socket_device_list^ [device_id].connection_id;
            ELSE
              connection_list^ [device_id] := nac$null_connection_id;
            IFEND;
          FOREND;
        IFEND;

        nlp$udp_free_exclusive_access (global_socket);

{ Check the outbound capacity on each active connection.

      /check_connection_capacity/
        FOR device_id := 1 TO UPPERBOUND (connection_list^) DO
          IF connection_list^ [device_id] <> nac$null_connection_id THEN
            nlp$cl_get_exclusive_via_cid (connection_list^ [device_id], connection_exists, cl_connection);
            IF cl_connection <> NIL THEN
              nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, layer_active, udp_connection);
              IF (layer_active) AND (udp_connection^.state = nlc$udp_conn_open) AND
                    (udp_connection^.send_queue = NIL) THEN
                nlp$osi_get_outbound_capacity (cl_connection, outbound_capacity);
                IF outbound_capacity <= 0 THEN
                  nlp$cc_receive_data (cl_connection);
                  nlp$osi_get_outbound_capacity (cl_connection, outbound_capacity);
                IFEND;
                IF outbound_capacity > 0 THEN
                  clear_to_send := TRUE;
                  nlp$cl_release_exclusive_access (cl_connection);
                  EXIT /check_connection_capacity/;
                IFEND;
              IFEND;
              nlp$cl_release_exclusive_access (cl_connection);
            IFEND;
          IFEND;
        FOREND /check_connection_capacity/;
      ELSEIF global_socket^.status = nlc$udp_global_socket_term THEN

{ The socket has been terminated via application management.

        osp$set_status_condition (nae$sk_socket_terminated, status);
        nlp$udp_free_exclusive_access (global_socket);
      ELSE { unexpected status
        nap$namve_system_error ({Recoverable_error=} TRUE, 'Encountered unexpected global socket status',
              NIL);
        osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'GET SOCKET STATUS', status);
        nlp$udp_free_exclusive_access (global_socket);
      IFEND;
    ELSE { global_socket = NIL

{ The socket has been terminated via application management.

      osp$set_status_condition (nae$sk_socket_terminated, status);
    IFEND;

  PROCEND nlp$udp_get_socket_status;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_initialize', EJECT ??
*copy nlh$udp_initialize

  PROCEDURE [XDCL] nlp$udp_initialize;

    VAR
      null_connect_event_processor: nlt$cl_event_processor,
      null_sap_event_processor: nlt$cl_event_processor;

    null_connect_event_processor.layer := nlc$udp_interface;
    null_sap_event_processor.layer := nlc$udp_interface;

    nlp$cl_initialize_template (nlc$udp_interface, nlc$udp_interface, #SIZE (nlt$udp_socket_layer), 0,
          null_sap_event_processor, nac$nil, null_connect_event_processor, nac$nil);
    nlp$cc_initialize_template (nlc$udp_interface);

  PROCEND nlp$udp_initialize;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_offer_socket', EJECT ??
*copy nlh$udp_offer_socket

  PROCEDURE [XDCL] nlp$udp_offer_socket
    (    global_socket_id: nlt$udp_global_socket_id;
     VAR status: ost$status);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      connection_list: ^array [1 .. * ] of nat$connection_id,
      device_id: nlt$device_identifier,
      global_socket: ^nlt$udp_global_socket,
      layer_active: boolean,
      local_socket_id: nat$sk_socket_identifier,
      socket_device_list: ^nlt$udp_socket_device_list,
      udp_connection: ^nlt$udp_socket_layer;

    status.normal := TRUE;
    nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
    IF global_socket <> NIL THEN
      IF global_socket^.status = nlc$udp_global_socket_open THEN
        local_socket_id := global_socket^.local_socket_id;
        IF global_socket^.receive_wait_queue <> NIL THEN
          osp$set_status_condition (nae$sk_io_pending, status);
          osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE, status);
        ELSE
          socket_device_list := ^global_socket^.device_list;
          PUSH connection_list: [1 .. UPPERBOUND (socket_device_list^)];

        /check_for_receivers/
          FOR device_id := 1 TO UPPERBOUND (socket_device_list^) DO
            IF socket_device_list^ [device_id].status = nlc$udp_device_open THEN
              connection_list^ [device_id] := socket_device_list^ [device_id].connection_id;
              IF socket_device_list^ [device_id].receiver_task <> NIL THEN
                osp$set_status_condition (nae$sk_io_pending, status);
                osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE, status);
                EXIT /check_for_receivers/;
              IFEND;
            ELSE
              connection_list^ [device_id] := nac$null_connection_id;
            IFEND;
          FOREND /check_for_receivers/;
        IFEND;

        nlp$udp_free_exclusive_access (global_socket);

        IF status.normal THEN

        /check_for_senders/
          FOR device_id := 1 TO UPPERBOUND (connection_list^) DO
            IF connection_list^ [device_id] <> nac$null_connection_id THEN
              nlp$cl_get_exclusive_via_cid (connection_list^ [device_id], connection_exists, cl_connection);
              IF cl_connection <> NIL THEN
                nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, layer_active, udp_connection);
                IF (layer_active) AND (udp_connection^.send_queue <> NIL) THEN
                  osp$set_status_condition (nae$sk_io_pending, status);
                  osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE,
                        status);
                  nlp$cl_release_exclusive_access (cl_connection);
                  EXIT /check_for_senders/;
                IFEND;
                nlp$cl_release_exclusive_access (cl_connection);
              IFEND;
            IFEND;
          FOREND /check_for_senders/;
        IFEND;
        IF status.normal THEN

{ No io active , update the status of the global socket.

          nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
          IF global_socket <> NIL THEN
            IF global_socket^.status = nlc$udp_global_socket_open THEN
              global_socket^.status := nlc$udp_global_socket_offered;
            ELSEIF global_socket^.status = nlc$udp_global_socket_term THEN

{ The socket has been terminated via application management.

              osp$set_status_condition (nae$sk_socket_terminated, status);
            ELSE { unexpected status
              nap$namve_system_error ({Recoverable_error=} TRUE,
                    'Encountered unexpected global socket status', NIL);
              osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'OFFER SOCKET', status);
            IFEND;
            nlp$udp_free_exclusive_access (global_socket);
          ELSE { global_socket = NIL

{ The socket has been terminated via application management.

            osp$set_status_condition (nae$sk_socket_terminated, status);
          IFEND;
        IFEND;
      ELSE { global socket terminated

{ The socket is assumed to be closed by application mgmt request.

        osp$set_status_condition (nae$sk_socket_terminated, status);
        nlp$udp_free_exclusive_access (global_socket);
      IFEND;
    ELSE { global_socket = NIL
      osp$set_status_condition (nae$sk_socket_terminated, status);
    IFEND;

  PROCEND nlp$udp_offer_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_receive_data', EJECT ??
*copy nlh$udp_receive_data

  PROCEDURE [XDCL] nlp$udp_receive_data
    (    global_socket_id: nlt$udp_global_socket_id;
         time_stamp: ost$free_running_clock;
         selection_criteria: nat$sk_socket_address;
         user_cache_enabled: boolean;
         interface_mode: nat$sk_interface_mode;
         interface_timeout: nat$wait_time;
         data: nat$data_fragments;
     VAR foreign_socket: nat$sk_socket_address;
     VAR local_ip_address: nat$sk_ip_address;
     VAR data_length: integer;
     VAR status: ost$status);

?? NEWTITLE := 'terminate_receive', EJECT ??

    PROCEDURE terminate_receive
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        delete_global_socket: boolean;

      delete_global_socket := FALSE;
      IF received_data_length > 0 THEN

{ IF receive has been initiated, then try and complete the receive
{ by data queued on the global socket. However if there is no data
{ queued, set the discard data flag on the socket device entry and
{ terminate receive.

        nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
        IF global_socket <> NIL THEN
          IF global_socket^.status = nlc$udp_global_socket_open THEN
            IF global_socket^.device_list [selected_device].status = nlc$udp_device_open THEN
              IF global_socket^.device_list [selected_device].received_messages <> NIL THEN
                received_message := global_socket^.device_list [selected_device].received_messages;
                IF NOT received_message^.abort_receive THEN
                  IF received_message^.end_of_message THEN
                    receive_data (global_socket, selected_device, buffers_freed);
                    IF activity_status.status.normal THEN
                      foreign_socket := foreign_address;
                      local_ip_address := local_address;
                      data_length := received_data_length;
                    ELSE
                      status := activity_status.status;
                    IFEND;
                  ELSE { only partial fragment queued
                    nlp$bm_release_message (received_message^.data);
                    global_socket^.device_list [selected_device].received_messages := NIL;
                    return_received_message_entry (global_socket, received_message);
                    global_socket^.device_list [selected_device].discard_data := TRUE;
                    osp$set_status_condition (nae$sk_no_data_available, status);
                    osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE,
                          status);
                  IFEND;
                ELSE { abort receive
                  global_socket^.device_list [selected_device].receiver_task := NIL;
                  global_socket^.device_list [selected_device].received_messages := NIL;
                  return_received_message_entry (global_socket, received_message);
                  return_receiver_task_entry (global_socket, receiver_task);
                  osp$set_status_condition (nae$sk_no_data_available, status);
                  osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE,
                        status);
                IFEND;
              ELSE { received_message = NIL

{ Abort receive.

                global_socket^.device_list [selected_device].discard_data := TRUE;
                osp$set_status_condition (nae$sk_no_data_available, status);
                osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE, status);
              IFEND;
            ELSE { device closed
              receiver_task := global_socket^.receive_wait_queue;
              global_socket^.receive_wait_queue := receiver_task^.next_entry;
              return_receiver_task_entry (global_socket, receiver_task);
              osp$set_status_condition (nae$sk_no_data_available, status);
              osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE, status);
            IFEND;
            IF global_socket^.receive_wait_queue <> NIL THEN
              pmp$ready_task (global_socket^.receive_wait_queue^.task_id, ignore_status);
            IFEND;
          ELSE { global_socket^.status <> nlc$udp_global_socket_open
            receiver_task := global_socket^.receive_wait_queue;
            global_socket^.receive_wait_queue := receiver_task^.next_entry;
            FREE receiver_task IN nav$network_paged_heap^;
            IF (global_socket^.status = nlc$udp_global_socket_closed) OR
                  (global_socket^.status = nlc$udp_global_socket_term) THEN
              delete_global_socket := (global_socket^.receive_wait_queue = NIL) AND
                    (global_socket^.active_device_count = 0);
            IFEND;
            osp$set_status_condition (nae$sk_unknown_socket, status);
            osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE, status);
          IFEND;
          nlp$udp_deactivate_receiver (global_socket^.active_receiver);
          nlp$udp_free_exclusive_access (global_socket);
          IF delete_global_socket THEN
            nlp$udp_delete_global_socket (global_socket_id);
          IFEND;
        IFEND;
      ELSE { received_data_length = 0
        nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
        IF global_socket <> NIL THEN
          previous_receiver_task := ^global_socket^.receive_wait_queue;
          WHILE (previous_receiver_task^ <> NIL) AND (previous_receiver_task^^.task_id <> current_task_id) DO
            previous_receiver_task := ^previous_receiver_task^^.next_entry;
          WHILEND;
          receiver_task := previous_receiver_task^;
          previous_receiver_task^ := receiver_task^.next_entry;
          return_receiver_task_entry (global_socket, receiver_task);
          IF (global_socket^.status = nlc$udp_global_socket_closed) OR
                (global_socket^.status = nlc$udp_global_socket_term) THEN
            delete_global_socket := (global_socket^.receive_wait_queue = NIL) AND
                  (global_socket^.active_device_count = 0);
          IFEND;
          osp$set_status_condition (nae$sk_interface_timeout, status);
          osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE, status);
          IF current_receiver_active THEN
            nlp$udp_deactivate_receiver (global_socket^.active_receiver);
          IFEND;
          nlp$udp_free_exclusive_access (global_socket);
          IF delete_global_socket THEN
            nlp$udp_delete_global_socket (global_socket_id);
          IFEND;
        IFEND;
      IFEND;
    PROCEND terminate_receive;
?? OLDTITLE, EJECT ??

    VAR
      activity_status: ost$activity_status,
      another_receiver_active: boolean,
      buffer_length: nat$data_length,
      buffers_freed: nat$data_length,
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      current_receiver_active: boolean,
      current_task_id: ost$global_task_id,
      current_time: ost$free_running_clock,
      delete_global_socket: boolean,
      device_id: nlt$device_identifier,
      end_time: integer,
      foreign_address: nat$sk_socket_address,
      global_socket: ^nlt$udp_global_socket,
      i: integer,
      ignore_status: ost$status,
      layer_active: boolean,
      local_address: nat$sk_ip_address,
      local_socket_id: nat$sk_socket_identifier,
      previous_receiver_task: ^^nlt$udp_receiver_task,
      receive_buffer: ^nat$data_fragments,
      received_message: ^nlt$udp_received_message,
      received_data_length: integer,
      receiver_task: ^nlt$udp_receiver_task,
      remaining_buffer_length: integer,
      remaining_time: integer,
      restart_receive: boolean,
      selected_device: nlt$device_identifier,
      socket_inventory: ^nlt$udp_socket_inventory,
      socket_device_list: ^nlt$udp_socket_device_list,
      udp_connection: ^nlt$udp_socket_layer;

    status.normal := TRUE;
    activity_status.complete := FALSE;
    activity_status.status.normal := TRUE;
    received_data_length := 0;

    pmp$get_executing_task_gtid (current_task_id);
    nlp$al_get_data_length (data, buffer_length);
    PUSH socket_inventory: [1 .. UPPERBOUND (nlv$configured_network_devices.network_device_list^)];
    PUSH receive_buffer: [1 .. UPPERBOUND (data)];
    current_receiver_active := FALSE;
    another_receiver_active := FALSE;
    delete_global_socket := FALSE;

    nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
    IF global_socket <> NIL THEN
      local_socket_id := global_socket^.local_socket_id;
      #SPOIL (local_socket_id);
      socket_device_list := ^global_socket^.device_list;
      IF global_socket^.status = nlc$udp_global_socket_open THEN

{ Save initial buffer attributes.

        receive_buffer^ := data;
        IF global_socket^.time_stamp = time_stamp THEN
          nlp$udp_activate_receiver (global_socket^.active_receiver, another_receiver_active);
          current_receiver_active := NOT another_receiver_active;

          IF current_receiver_active THEN

{ Receive data queued on the global socket.

            remaining_buffer_length := buffer_length;
            scan_global_socket_for_data (global_socket, receive_buffer^, remaining_buffer_length,
                  received_data_length, selection_criteria, foreign_address, local_address, socket_inventory^,
                  selected_device, activity_status);
            IF activity_status.complete THEN
              IF activity_status.status.normal THEN
                data_length := received_data_length;
                foreign_socket := foreign_address;
                local_ip_address := local_address;
              ELSE
                status := activity_status.status;
              IFEND;
            ELSE { Not activity complete
              IF received_data_length > 0 THEN

{ Queue the current task as the receiver on the socket device.

                initialize_receiver_task_entry (global_socket, current_task_id, nlc$udp_receive_data, ^data,
                      buffer_length, receive_buffer, remaining_buffer_length, ^received_data_length,
                      selection_criteria, ^foreign_address, ^local_address, ^selected_device,
                      socket_device_list^ [selected_device].connection_id, interface_mode, ^activity_status,
                      receiver_task);
                socket_device_list^ [selected_device].receiver_task := receiver_task;
              ELSE {  received_data_length = 0
                IF interface_mode = nac$sk_blocking_mode THEN

{ Queue the current task on the receive wait queue (with the receiving connection =
{ nac$null_connection_id)

                  initialize_receiver_task_entry (global_socket, current_task_id, nlc$udp_receive_data, ^data,
                        buffer_length, receive_buffer, buffer_length, ^received_data_length,
                        selection_criteria, ^foreign_address, ^local_address, ^selected_device,
                        nac$null_connection_id, interface_mode, ^activity_status, receiver_task);
                  receiver_task^.next_entry := global_socket^.receive_wait_queue;
                  global_socket^.receive_wait_queue := receiver_task;
                ELSE { Non-blocking mode
                  activity_status.complete := TRUE;
                  osp$set_status_condition (nae$sk_no_data_available, status);
                  osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE,
                        status);
                IFEND;
              IFEND;
            IFEND;
            IF activity_status.complete THEN
              nlp$udp_deactivate_receiver (global_socket^.active_receiver);
            IFEND;
            nlp$udp_free_exclusive_access (global_socket);
            IF activity_status.complete THEN
              update_inventory (socket_inventory);
            ELSE

{ Access the channel connections to update the inventory report. Scan the channel
{ connection over which receive was initiated to cause the data to be pulled
{ up to the global socket. If data is available, the receive will complete.

              scan_connections_for_data (socket_inventory, receiver_task);
              IF activity_status.complete THEN
                IF activity_status.status.normal THEN
                  data_length := received_data_length;
                  foreign_socket := foreign_address;
                  local_ip_address := local_address;
                ELSE
                  status := activity_status.status;
                IFEND;
              IFEND;
            IFEND;
          ELSE { another_receiver_active

{ Other receivers are active.

            IF interface_mode = nac$sk_blocking_mode THEN
              initialize_receiver_task_entry (global_socket, current_task_id, nlc$udp_receive_data, ^data,
                    buffer_length, receive_buffer, buffer_length, ^received_data_length, selection_criteria,
                    ^foreign_address, ^local_address, ^selected_device, nac$null_connection_id,
                    interface_mode, ^activity_status, receiver_task);

{ Queue the task at the end of the receive queue.

              previous_receiver_task := ^global_socket^.receive_wait_queue;
              WHILE previous_receiver_task^ <> NIL DO
                previous_receiver_task := ^previous_receiver_task^^.next_entry;
              WHILEND;
              previous_receiver_task^ := receiver_task;
            ELSE { non-blocking mode
              activity_status.complete := TRUE;
              osp$set_status_condition (nae$sk_receive_in_progress, status);
              osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE, status);
            IFEND;
            nlp$udp_free_exclusive_access (global_socket);
          IFEND;

          IF NOT activity_status.complete THEN
            #SPOIL (receiver_task);
            #SPOIL (current_task_id);

            osp$establish_block_exit_hndlr (^terminate_receive);
            IF interface_mode = nac$sk_non_blocking_mode THEN
              remaining_time := 500;
            ELSE { interface_mode = nac$sk_blocking_mode
              remaining_time := interface_timeout;
            IFEND;
            end_time := #FREE_RUNNING_CLOCK (0) + remaining_time * 1000;
            restart_receive := FALSE;

            REPEAT
              #SPOIL (received_data_length);
              #SPOIL (current_receiver_active);
              IF NOT restart_receive THEN
                pmp$wait (remaining_time, 0);
              ELSE
                restart_receive := FALSE;
              IFEND;
              current_time := #FREE_RUNNING_CLOCK (0);
              IF current_time < end_time THEN
                remaining_time := (end_time - current_time) DIV 1000;
              ELSE
                remaining_time := 0;
              IFEND;
              #SPOIL (remaining_time);

              IF received_data_length > 0 THEN

{ Receive had been initiated. Check for data on the global socket.

                buffers_freed := 0;
                nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
                IF global_socket <> NIL THEN
                  IF global_socket^.status = nlc$udp_global_socket_open THEN
                    IF global_socket^.device_list [selected_device].status = nlc$udp_device_open THEN
                      IF global_socket^.device_list [selected_device].received_messages <> NIL THEN
                        receive_data (global_socket, selected_device, buffers_freed);
                        IF activity_status.complete THEN
                          IF activity_status.status.normal THEN
                            foreign_socket := foreign_address;
                            local_ip_address := local_address;
                            data_length := received_data_length;
                          ELSE
                            status := activity_status.status;
                          IFEND;
                        ELSE { NOT activity_status.complete
                          IF received_data_length > 0 THEN

{ Extend wait time as remaining data should arrive soon.

                            IF remaining_time = 0 THEN
                              remaining_time := 500;
                            IFEND;
                          ELSE { received_data_length = 0

{ Receive has been aborted via a clear send request. This will happen
{ only for a blocked receive. A non blocked receiver is terminated
{ and marked as complete (with an abnormal status).

                            IF remaining_time > 0 THEN
                              restart_receive := TRUE;
                            ELSE { remaining_time = 0 THEN

{ Terminate receive.

                              global_socket^.receive_wait_queue := receiver_task^.next_entry;
                              return_receiver_task_entry (global_socket, receiver_task);
                              nlp$udp_deactivate_receiver (global_socket^.active_receiver);
                              IF global_socket^.receive_wait_queue <> NIL THEN
                                pmp$ready_task (global_socket^.receive_wait_queue^.task_id, ignore_status);
                              IFEND;
                              osp$set_status_condition (nae$sk_interface_timeout, status);
                              osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10,
                                    TRUE, status);
                              activity_status.complete := TRUE;
                            IFEND;
                          IFEND;
                        IFEND;
                      IFEND;
                    ELSE { device status <> open

{ Terminate receive.

                      global_socket^.receive_wait_queue := receiver_task^.next_entry;
                      return_receiver_task_entry (global_socket, receiver_task);
                      nlp$udp_deactivate_receiver (global_socket^.active_receiver);
                      IF global_socket^.receive_wait_queue <> NIL THEN
                        pmp$ready_task (global_socket^.receive_wait_queue^.task_id, ignore_status);
                      IFEND;
                      osp$set_status_condition (nae$sk_interface_timeout, status);
                      osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE,
                            status);
                      activity_status.complete := TRUE;
                    IFEND;
                    nlp$udp_free_exclusive_access (global_socket);
                  ELSE { global_socket^.status <> nlc$udp_global_socket_open
                    receiver_task := global_socket^.receive_wait_queue;
                    global_socket^.receive_wait_queue := receiver_task^.next_entry;
                    return_receiver_task_entry (global_socket, receiver_task);
                    nlp$udp_deactivate_receiver (global_socket^.active_receiver);
                    delete_global_socket := (global_socket^.receive_wait_queue = NIL) AND
                          (global_socket^.active_device_count = 0);
                    nlp$udp_free_exclusive_access (global_socket);
                    IF delete_global_socket THEN
                      nlp$udp_delete_global_socket (global_socket_id);
                    IFEND;
                    activity_status.complete := TRUE;
                  IFEND;
                ELSE {global_socket = NIL (this should not happen)
                  osp$set_status_condition (nae$sk_unknown_socket, status);
                IFEND;
                IF (buffers_freed > 0) AND (activity_status.complete) THEN
                  nlp$cl_get_exclusive_via_cid (receiver_task^.connection_id, connection_exists,
                        cl_connection);
                  IF cl_connection <> NIL THEN
                    nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, layer_active,
                          udp_connection);
                    IF (layer_active) AND (udp_connection^.state = nlc$udp_conn_open) THEN
                      udp_connection^.inventory_report := udp_connection^.inventory_report - buffers_freed;
                      nlp$cc_report_undelivered_data (cl_connection, udp_connection^.inventory_report);
                    IFEND;
                    nlp$cl_release_exclusive_access (cl_connection);
                  IFEND;
                ELSEIF (NOT restart_receive) AND (NOT activity_status.complete) THEN
                  nlp$cl_get_exclusive_via_cid (receiver_task^.connection_id, connection_exists,
                        cl_connection);
                  IF cl_connection <> NIL THEN
                    nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, layer_active,
                          udp_connection);
                  IFEND;
                  IF (cl_connection <> NIL) AND (layer_active) AND
                        (udp_connection^.state = nlc$udp_conn_open) THEN
                    IF buffers_freed > 0 THEN
                      udp_connection^.inventory_report := udp_connection^.inventory_report - buffers_freed;
                      nlp$cc_report_undelivered_data (cl_connection, udp_connection^.inventory_report);
                    IFEND;
                    nlp$cc_receive_data (cl_connection);
                    IF activity_status.complete THEN
                      IF activity_status.status.normal THEN
                        foreign_socket := foreign_address;
                        local_ip_address := local_address;
                        data_length := received_data_length;
                      ELSE
                        status := activity_status.status;
                      IFEND;
                    ELSE { NOT activity_status.complete
                      IF received_data_length > 0 THEN

{ Extend wait time as remaining data should arrive soon.

                        IF remaining_time = 0 THEN
                          remaining_time := 500;
                        IFEND;
                      ELSE { received_data_length = 0

{ Receive has been aborted via a clear send request. This will happen
{ only for a blocked receive. A non blocked receiver is terminated
{ and marked as complete (with an abnormal status).

                        IF remaining_time = 0 THEN
                          nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
                          IF global_socket <> NIL THEN

{ Find the receiver task. It must be at the head of the receive wait queue.

                            receiver_task := global_socket^.receive_wait_queue;
                            global_socket^.receive_wait_queue := receiver_task^.next_entry;
                            return_receiver_task_entry (global_socket, receiver_task);
                            nlp$udp_deactivate_receiver (global_socket^.active_receiver);
                            IF global_socket^.receive_wait_queue <> NIL THEN
                              pmp$ready_task (global_socket^.receive_wait_queue^.task_id, ignore_status);
                            IFEND;
                            nlp$udp_free_exclusive_access (global_socket);
                          IFEND;
                          osp$set_status_condition (nae$sk_interface_timeout, status);
                          osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10,
                                TRUE, status);
                          activity_status.complete := TRUE;
                        ELSE { remaining_time > 0
                          restart_receive := TRUE;
                        IFEND;
                      IFEND;
                    IFEND;
                    nlp$cl_release_exclusive_access (cl_connection);
                  ELSE { layer inactive or udp_connection not open or cl_connection = nil
                    IF cl_connection <> NIL THEN
                      nlp$cl_release_exclusive_access (cl_connection);
                    IFEND;

{ Terminate receive if remaining_time = 0 or if the receiver is non blocking.
{ Otherwise, restart receive.

                    IF (interface_mode = nac$sk_non_blocking_mode) OR (remaining_time = 0) THEN
                      nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
                      IF global_socket <> NIL THEN

{ Find the receiver task. It must be at the head of the queue.

                        receiver_task := global_socket^.receive_wait_queue;
                        global_socket^.receive_wait_queue := receiver_task^.next_entry;
                        return_receiver_task_entry (global_socket, receiver_task);
                        IF (global_socket^.status = nlc$udp_global_socket_closed) OR
                              (global_socket^.status = nlc$udp_global_socket_term) THEN
                          delete_global_socket := (global_socket^.receive_wait_queue = NIL) AND
                                (global_socket^.active_device_count = 0);
                        IFEND;
                        nlp$udp_deactivate_receiver (global_socket^.active_receiver);
                        nlp$udp_free_exclusive_access (global_socket);
                        IF delete_global_socket THEN
                          nlp$udp_delete_global_socket (global_socket_id);
                        IFEND;
                      IFEND;
                      IF remaining_time = 0 THEN
                        osp$set_status_condition (nae$sk_interface_timeout, status);
                      ELSE
                        osp$set_status_condition (nae$sk_no_data_available, status);
                      IFEND;
                      osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE,
                            status);
                      activity_status.complete := TRUE;
                    ELSE { blocking mode and remaining_time > 0
                      restart_receive := TRUE;
                      received_data_length := 0;
                    IFEND;
                  IFEND;
                IFEND;
              ELSE { received_data_length = 0

{ Receive has not been initiated.

                nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
                IF global_socket <> NIL THEN
                  IF global_socket^.status = nlc$udp_global_socket_open THEN
                    IF global_socket^.receive_wait_queue^.task_id = current_task_id THEN

{ Current task is at the head of the receive wait queue and is the next
{ receiving task.

                      IF remaining_time > 0 THEN
                        IF NOT current_receiver_active THEN
                          nlp$udp_activate_receiver (global_socket^.active_receiver, another_receiver_active);
                          current_receiver_active := NOT another_receiver_active;
                        IFEND;
                        IF current_receiver_active THEN
                          scan_global_socket_for_data (global_socket, receiver_task^.receive_buffer^,
                                receiver_task^.buffer_length, receiver_task^.received_data_length^,
                                receiver_task^.selection_criteria, receiver_task^.foreign_socket^,
                                receiver_task^.local_ip_address^, socket_inventory^, selected_device,
                                activity_status);
                          IF activity_status.complete THEN
                            IF activity_status.status.normal THEN
                              foreign_socket := foreign_address;
                              local_ip_address := local_address;
                              data_length := received_data_length;
                            ELSE
                              status := activity_status.status;
                            IFEND;
                            global_socket^.receive_wait_queue := receiver_task^.next_entry;
                            return_receiver_task_entry (global_socket, receiver_task);
                            nlp$udp_deactivate_receiver (global_socket^.active_receiver);
                            IF global_socket^.receive_wait_queue <> NIL THEN
                              pmp$ready_task (global_socket^.receive_wait_queue^.task_id, ignore_status);
                            IFEND;
                            nlp$udp_free_exclusive_access (global_socket);
                            update_inventory (socket_inventory);
                          ELSE { scan connections for data
                            IF received_data_length > 0 THEN

{ Receive has been initiated. Queue the receiver on the socket device.

                              receiver_task^.connection_id := global_socket^.device_list [selected_device].
                                    connection_id;
                              global_socket^.receive_wait_queue := receiver_task^.next_entry;
                              receiver_task^.next_entry := NIL;
                              global_socket^.device_list [selected_device].receiver_task := receiver_task;
                            IFEND;
                            nlp$udp_free_exclusive_access (global_socket);
                            scan_connections_for_data (socket_inventory, receiver_task);
                            IF activity_status.complete THEN
                              IF activity_status.status.normal THEN
                                foreign_socket := foreign_address;
                                local_ip_address := local_address;
                                data_length := received_data_length;
                              ELSE
                                status := activity_status.status;
                              IFEND;
                            IFEND;
                          IFEND;
                        ELSE { another receiver is active
                          nlp$udp_free_exclusive_access (global_socket);
                        IFEND;
                      ELSE { remaining_time = 0

{ Terminate receive.

                        global_socket^.receive_wait_queue := receiver_task^.next_entry;
                        return_receiver_task_entry (global_socket, receiver_task);
                        IF current_receiver_active THEN
                          nlp$udp_deactivate_receiver (global_socket^.active_receiver);
                        IFEND;
                        IF global_socket^.receive_wait_queue <> NIL THEN
                          pmp$ready_task (global_socket^.receive_wait_queue^.task_id, ignore_status);
                        IFEND;
                        osp$set_status_condition (nae$sk_interface_timeout, status);
                        osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE,
                              status);
                        activity_status.complete := TRUE;
                        nlp$udp_free_exclusive_access (global_socket);
                      IFEND;
                    ELSE { current task is not at the head of the wait queue
                      IF remaining_time = 0 THEN

{ Find the receiver task entry for the current task and terminate receive.

                        previous_receiver_task := ^global_socket^.receive_wait_queue;
                        WHILE (previous_receiver_task^ <> NIL) AND (previous_receiver_task^^.task_id <>
                              current_task_id) DO
                          previous_receiver_task := ^previous_receiver_task^^.next_entry;
                        WHILEND;
                        receiver_task := previous_receiver_task^;
                        IF receiver_task <> NIL THEN

{ Dequeue the receiver task and return the entry.

                          previous_receiver_task^ := receiver_task^.next_entry;
                          return_receiver_task_entry (global_socket, receiver_task);
                          osp$set_status_condition (nae$sk_interface_timeout, status);
                          osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10,
                                TRUE, status);
                          activity_status.complete := TRUE;
                        IFEND;
                      IFEND;
                      nlp$udp_free_exclusive_access (global_socket);
                    IFEND;
                  ELSE { global_socket not open
                    previous_receiver_task := ^global_socket^.receive_wait_queue;
                    WHILE (previous_receiver_task^ <> NIL) AND (previous_receiver_task^^.task_id <>
                          current_task_id) DO
                      previous_receiver_task := ^previous_receiver_task^^.next_entry;
                    WHILEND;
                    receiver_task := previous_receiver_task^;
                    IF receiver_task <> NIL THEN

{ Dequeue the receiver task and return the entry.

                      previous_receiver_task^ := receiver_task^.next_entry;
                      FREE receiver_task IN nav$network_paged_heap^;
                    IFEND;
                    IF global_socket^.status = nlc$udp_global_socket_closed THEN
                      osp$set_status_condition (nae$sk_unknown_socket, status);
                    ELSE
                      osp$set_status_condition (nae$sk_socket_terminated, status);
                    IFEND;
                    osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE,
                          status);
                    activity_status.complete := TRUE;
                    delete_global_socket := (global_socket^.receive_wait_queue = NIL) AND
                          (global_socket^.active_device_count = 0);
                    nlp$udp_free_exclusive_access (global_socket);
                    IF delete_global_socket THEN
                      nlp$udp_delete_global_socket (global_socket_id);
                    IFEND;
                  IFEND;
                ELSE { global_socket = NIL
                  osp$set_status_condition (nae$sk_unknown_socket, status);
                  osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE,
                        status);
                  activity_status.complete := TRUE;
                IFEND;
              IFEND;
            UNTIL (activity_status.complete) OR (NOT status.normal);
            osp$disestablish_cond_handler;
          IFEND;

          IF status.normal AND user_cache_enabled THEN
            nlv$udp_local_routing_cache.last_receive.source_ip_address := foreign_socket.ip_address;
            nlv$udp_local_routing_cache.last_receive.destination_ip_address := local_ip_address;
            nlv$udp_local_routing_cache.last_receive.device_id := selected_device;
          IFEND;
        ELSE { time stamps do not match
          osp$set_status_condition (nae$sk_unknown_socket, status);
          osp$append_status_integer (osc$status_parameter_delimiter, global_socket^.local_socket_id, 10, TRUE,
                status);
          nlp$udp_free_exclusive_access (global_socket);
        IFEND;
      ELSEIF global_socket^.status = nlc$udp_global_socket_term THEN
        osp$set_status_condition (nae$sk_socket_terminated, status);
        osp$append_status_integer (osc$status_parameter_delimiter, global_socket^.local_socket_id, 10, TRUE,
              status);
        nlp$udp_free_exclusive_access (global_socket);
      ELSE { socket closed
        osp$set_status_condition (nae$sk_unknown_socket, status);
        osp$append_status_integer (osc$status_parameter_delimiter, global_socket^.local_socket_id, 10, TRUE,
              status);
        nlp$udp_free_exclusive_access (global_socket);
      IFEND;
    ELSE { global_socket = NIL
      osp$set_status_condition (nae$sk_unknown_socket, status);
    IFEND;

  PROCEND nlp$udp_receive_data;
?? OLDTITLE ??
?? NEWTITLE := 'nlp$udp_remove_clear_to_send', EJECT ??
*copy nlh$udp_remove_clear_to_send

  PROCEDURE [XDCL] nlp$udp_remove_clear_to_send
    (    global_socket_id: nlt$udp_global_socket_id);

    VAR
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      connection_list: ^array [1 .. * ] of nat$connection_id,
      current_task_id: ost$global_task_id,
      device_id: nlt$device_identifier,
      global_socket: ^nlt$udp_global_socket,
      layer_active: boolean,
      previous_sender_task: ^^nlt$udp_sender_task,
      sender_task: ^nlt$udp_sender_task,
      udp_connection: ^nlt$udp_socket_layer;

    pmp$get_executing_task_gtid (current_task_id);
    nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
    IF (global_socket <> NIL) THEN
      IF (global_socket^.status = nlc$udp_global_socket_open) THEN

{ Build a list of all active connection ids.

        PUSH connection_list: [1 .. UPPERBOUND (global_socket^.device_list)];
        FOR device_id := 1 TO UPPERBOUND (global_socket^.device_list) DO
          IF global_socket^.device_list [device_id].status = nlc$udp_device_open THEN
            connection_list^ [device_id] := global_socket^.device_list [device_id].connection_id;
          ELSE
            connection_list^ [device_id] := nac$null_connection_id;
          IFEND;
        FOREND;

        nlp$udp_free_exclusive_access (global_socket);

{ Dequeue the current task from the send queue in each active connection.

        FOR device_id := 1 TO UPPERBOUND (connection_list^) DO
          IF connection_list^ [device_id] <> nac$null_connection_id THEN
            nlp$cl_get_exclusive_via_cid (connection_list^ [device_id], connection_exists, cl_connection);
            IF cl_connection <> NIL THEN
              nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, layer_active, udp_connection);
              IF (layer_active) AND (udp_connection^.state = nlc$udp_conn_open) AND
                    (udp_connection^.send_queue <> NIL) THEN
                previous_sender_task := ^udp_connection^.send_queue;
                sender_task := udp_connection^.send_queue;
                WHILE (sender_task <> NIL) AND (sender_task^.task_id <> current_task_id) DO
                  previous_sender_task := ^sender_task^.next_entry;
                  sender_task := sender_task^.next_entry;
                WHILEND;
                IF sender_task <> NIL THEN
                  previous_sender_task^ := sender_task^.next_entry;
                  return_sender_task_entry (udp_connection, sender_task);
                IFEND;
              IFEND;
              nlp$cl_release_exclusive_access (cl_connection);
            IFEND;
          IFEND;
        FOREND;
      ELSE
        nlp$udp_free_exclusive_access (global_socket);
      IFEND;
    IFEND;

  PROCEND nlp$udp_remove_clear_to_send;
?? OLDTITLE ??
?? NEWTITLE := 'nlp$udp_remove_data_available', EJECT ??
*copy nlh$udp_remove_data_available

  PROCEDURE [XDCL] nlp$udp_remove_data_available
    (    global_socket_id: nlt$udp_global_socket_id);

    VAR
      current_task_id: ost$global_task_id,
      global_socket: ^nlt$udp_global_socket,
      ignore_status: ost$status,
      previous_receiver_task: ^^nlt$udp_receiver_task,
      receiver_task: ^nlt$udp_receiver_task;

    pmp$get_executing_task_gtid (current_task_id);
    nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
    IF (global_socket <> NIL) THEN
      IF (global_socket^.status = nlc$udp_global_socket_open) AND
            (global_socket^.receive_wait_queue <> NIL) THEN
        IF global_socket^.receive_wait_queue^.task_id = current_task_id THEN

{ Task is at the head of the queue.

          receiver_task := global_socket^.receive_wait_queue;
          global_socket^.receive_wait_queue := receiver_task^.next_entry;
          IF receiver_task^.receiver_active THEN
            nlp$udp_deactivate_receiver (global_socket^.active_receiver);
          IFEND;
          IF global_socket^.receive_wait_queue <> NIL THEN
            pmp$ready_task (global_socket^.receive_wait_queue^.task_id, ignore_status);
          IFEND;
          return_receiver_task_entry (global_socket, receiver_task);
        ELSE { task not at the head of the queue
          previous_receiver_task := ^global_socket^.receive_wait_queue;
          receiver_task := global_socket^.receive_wait_queue;
          WHILE (receiver_task <> NIL) AND (receiver_task^.task_id <> current_task_id) DO
            previous_receiver_task := ^receiver_task^.next_entry;
            receiver_task := receiver_task^.next_entry;
          WHILEND;
          IF receiver_task <> NIL THEN
            previous_receiver_task^ := receiver_task^.next_entry;
            return_receiver_task_entry (global_socket, receiver_task);
          IFEND;
        IFEND;
      IFEND;
      nlp$udp_free_exclusive_access (global_socket);
    IFEND;

  PROCEND nlp$udp_remove_data_available;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_send_data', EJECT ??
*copy nlh$udp_send_data

  PROCEDURE [XDCL] nlp$udp_send_data
    (    global_socket_id: nlt$udp_global_socket_id;
         time_stamp: ost$free_running_clock;
         local_ip_address: nat$sk_ip_address;
         destination_socket: nat$sk_socket_address;
         data: nat$data_fragments;
         data_length: integer;
         checksum: boolean;
         interface_mode: nat$sk_interface_mode;
         interface_timeout: nat$wait_time;
         user_cache_enabled: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'broadcast_address', EJECT ??

    FUNCTION broadcast_address
      (    destination_address: nlt$tcpip_address): boolean;

      CONST
        local_broadcast_address = 0ffffffff(16);

      broadcast_address := (destination_address.full = local_broadcast_address) OR

{Class B network broadcast

      ((destination_address.class = 2) AND (destination_address.host_id_class_b = 0ffff(16))) OR

{Class A network broadcast

      (((destination_address.class = 0) OR (destination_address.class = 1)) AND
            (destination_address.host_id_class_a = 0ffffff(16))) OR

{Class C network broadcast

      ((destination_address.class = 3) AND (destination_address.host_id_class_c = 0ff(16)));

    FUNCEND broadcast_address;

?? OLDTITLE ??
?? NEWTITLE := 'terminate_send', EJECT ??

    PROCEDURE terminate_send
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        activity_complete := TRUE;
        osp$set_status_from_condition (nac$status_id, condition, sa, status, condition_status);
        condition_status.normal := TRUE;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'osc$job_recovery' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND;
        condition_status.normal := TRUE;

      = pmc$block_exit_processing =

{ Task termination during pmp$wait.

        IF NOT activity_complete THEN
          nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
          IF connection_exists THEN
            nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, layer_active, udp_connection);
            IF layer_active THEN
              IF udp_connection^.state = nlc$udp_conn_open THEN

{ Find the current task on the send queue.

                sender_task := udp_connection^.send_queue;
                IF sender_task^.task_id = current_task_id THEN
                  udp_connection^.send_queue := sender_task^.next_entry;
                  nlp$cl_deactivate_sender (cl_connection);
                  IF remaining_data_length_to_send < data_length THEN
                    abort_send (cl_connection);
                  IFEND;
                  return_sender_task_entry (udp_connection, sender_task);
                  IF udp_connection^.send_queue <> NIL THEN
                    pmp$ready_task (udp_connection^.send_queue^.task_id, ignore_status);
                  IFEND;
                ELSE { find the sender task
                  previous_sender_task := ^udp_connection^.send_queue;
                  WHILE (sender_task <> NIL) AND (sender_task^.task_id <> current_task_id) DO
                    previous_sender_task := ^sender_task^.next_entry;
                    sender_task := sender_task^.next_entry;
                  WHILEND;
                  IF sender_task <> NIL THEN
                    previous_sender_task^ := sender_task^.next_entry;
                    return_sender_task_entry (udp_connection, sender_task);
                  IFEND;
                IFEND;
              ELSEIF udp_connection^.state = nlc$udp_conn_closed THEN
                previous_sender_task := ^udp_connection^.send_queue;
                WHILE (sender_task <> NIL) AND (sender_task^.task_id <> current_task_id) DO
                  previous_sender_task := ^sender_task^.next_entry;
                  sender_task := sender_task^.next_entry;
                WHILEND;
                IF sender_task <> NIL THEN
                  previous_sender_task^ := sender_task^.next_entry;
                IFEND;
                FREE sender_task IN nav$network_paged_heap^;
              IFEND;
            IFEND;
            nlp$cl_release_exclusive_access (cl_connection);
          IFEND;
        IFEND;
      ELSE

{ Note: Interactive condition is being ignored.

        condition_status.normal := TRUE;
      CASEND;

    PROCEND terminate_send;
?? OLDTITLE, EJECT ??

    VAR
      activity_complete: boolean,
      broadcast: boolean,
      capacity: nat$data_length,
      cl_connection: ^nlt$cl_connection,
      connection_exists: boolean,
      connection_count: integer,
      connection_id: nat$connection_id,
      connections: ^array [1 .. * ] of nat$connection_id,
      count: integer,
      current_lowerbound: nat$data_fragment_count,
      current_task_id: ost$global_task_id,
      current_time: ost$free_running_clock,
      data_fragments: ^nat$data_fragments,
      delete_global_socket: boolean,
      destination_address: nlt$tcpip_address,
      device_id: nlt$device_identifier,
      end_time: integer,
      global_socket: ^nlt$udp_global_socket,
      i: integer,
      initial_send: boolean,
      j: integer,
      layer_active: boolean,
      local_socket_id: nat$sk_socket_identifier,
      new_lowerbound: nat$data_fragment_count,
      previous_sender_task: ^^nlt$udp_sender_task,
      remaining_data_length: integer,
      remaining_data_length_to_send: integer,
      remaining_time: integer,
      send_queue: ^nlt$udp_sender_task,
      sender_active: boolean,
      sender_task: ^nlt$udp_sender_task,
      udp_connection: ^nlt$udp_socket_layer,
      udpaa_data_header: nlt$udpaa_data_request;

{ Select the appropriate device.

    status.normal := TRUE;

    destination_address.full := destination_socket.ip_address;
    broadcast := broadcast_address (destination_address);

    IF local_ip_address <> nac$sk_all_ip_addresses THEN
      nlp$tm_select_by_local_udp_addr (local_ip_address, device_id, status);
    ELSEIF user_cache_enabled AND NOT broadcast THEN

{ Search local cache (in task private segment) for a match on the
{ ip address portion of the destination socket address and use the
{ corresponding device id.

      IF nlv$udp_local_routing_cache.last_send.destination_ip_address = destination_socket.ip_address THEN
        device_id := nlv$udp_local_routing_cache.last_send.device_id;
      ELSEIF nlv$udp_local_routing_cache.last_receive.source_ip_address = destination_socket.ip_address THEN
        device_id := nlv$udp_local_routing_cache.last_receive.device_id;
      ELSE

{ Invoke TCP/IP Management provided device selection.

        nlp$tm_udp_select_device (destination_socket.ip_address, device_id, status);
      IFEND;
    ELSEIF NOT broadcast THEN
      nlp$tm_udp_select_device (destination_socket.ip_address, device_id, status);
    ELSE
      device_id := 0;
    IFEND;

{ Access the global socket entry.

    IF status.normal THEN
      sender_active := FALSE;
      activity_complete := FALSE;
      #SPOIL (activity_complete);
      osp$establish_condition_handler (^terminate_send, TRUE);
      nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
      IF global_socket <> NIL THEN
        IF global_socket^.status = nlc$udp_global_socket_open THEN
          IF global_socket^.time_stamp = time_stamp THEN
            local_socket_id := global_socket^.local_socket_id;
            IF (NOT broadcast) OR (global_socket^.broadcast_enabled) THEN
              connections := NIL;
              IF device_id = 0 THEN { broadcast message via all devices
                PUSH connections: [1 .. UPPERBOUND (global_socket^.device_list)];
                connection_count := 0;
                FOR i := 1 TO UPPERBOUND (global_socket^.device_list) DO
                  IF global_socket^.device_list [i].status = nlc$udp_device_open THEN
                    connection_count := connection_count + 1;
                    connections^ [connection_count] := global_socket^.device_list [i].connection_id;
                  IFEND;
                FOREND;
              ELSEIF global_socket^.device_list [device_id].status = nlc$udp_device_open THEN
                PUSH connections: [1 .. 1];
                connection_count := 1;
                connections^ [1] := global_socket^.device_list [device_id].connection_id;
              IFEND;
              nlp$udp_free_exclusive_access (global_socket);
              IF connections <> NIL THEN
                data_fragments := NIL;
                FOR j := 1 TO connection_count DO
                  status.normal := TRUE;
                  connection_id := connections^ [j];
                  #SPOIL (connection_id);
                  nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
                  IF connection_exists THEN
                    nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, layer_active,
                          udp_connection);
                    IF layer_active THEN
                      IF udp_connection^.state = nlc$udp_conn_open THEN
                        IF data_fragments = NIL THEN

{ Set up the data fragments with the first entry pointing to the PDU header.

                          udpaa_data_header.header.kind := nlc$udpaa_data_req;

{ Length will be set up as each fragment is sent.

                          udpaa_data_header.checksum := checksum;
                          udpaa_data_header.destination_port := destination_socket.port;
                          udpaa_data_header.destination_ip_address := destination_socket.ip_address;
                          udpaa_data_header.end_of_message := FALSE;
                          PUSH data_fragments: [1 .. (1 + UPPERBOUND (data))];
                          data_fragments^ [1].address := ^udpaa_data_header;
                          data_fragments^ [1].length := #SIZE (udpaa_data_header);

{ Move the remaining fragments.

                          FOR i := 1 TO UPPERBOUND (data) DO
                            data_fragments^ [i + 1] := data [i];
                          FOREND;
                          pmp$get_executing_task_gtid (current_task_id);
                          #SPOIL (current_task_id);
                        IFEND;
                        udpaa_data_header.source_ip_address := udp_connection^.local_ip_address;
                        IF udp_connection^.send_queue = NIL THEN

{ No sender queued. Send data.

                          nlp$osi_get_outbound_capacity (cl_connection, capacity);
                          IF capacity <= 0 THEN
                            nlp$cc_receive_data (cl_connection);
                            nlp$osi_get_outbound_capacity (cl_connection, capacity);
                          IFEND;

                          IF capacity > 0 THEN
                            send_data (cl_connection, capacity, {initial_send} TRUE, data_fragments^,
                                  data_length, interface_mode, 1, new_lowerbound, remaining_data_length);
                            activity_complete := remaining_data_length = 0;
                            #SPOIL (activity_complete);
                            IF NOT activity_complete THEN
                              IF interface_mode = nac$sk_blocking_mode THEN

{ Queue the sender task.

                                get_sender_task_entry (udp_connection, sender_task);

{ Queue the current task on the send queue.

                                sender_task^.next_entry := NIL;
                                sender_task^.task_id := current_task_id;
                                sender_task^.send_type := nlc$udp_send_data;
                                remaining_data_length_to_send := remaining_data_length;
                                current_lowerbound := new_lowerbound;
                                udp_connection^.send_queue := sender_task;
                                nlp$cl_activate_sender (cl_connection);
                                sender_active := TRUE;
                              ELSE { non blocking mode

{ Should never end up here.

                                nap$namve_system_error ({Recoverable_error=} TRUE,
                                      'Unable to send non blocked data.', NIL);
                                osp$set_status_abnormal (nac$status_id, nae$sk_internal_error,
                                      'SEND TO SOCKET', status);
                              IFEND;
                            IFEND;
                          ELSE { No outbound capacity
                            IF interface_mode = nac$sk_blocking_mode THEN
                              get_sender_task_entry (udp_connection, sender_task);

{ Queue the current task on the send queue.

                              sender_task^.next_entry := NIL;
                              sender_task^.task_id := current_task_id;
                              sender_task^.send_type := nlc$udp_send_data;
                              remaining_data_length_to_send := data_length;
                              current_lowerbound := 1;
                              udp_connection^.send_queue := sender_task;
                              nlp$cl_activate_sender (cl_connection);
                              sender_active := TRUE;
                            ELSE { Non blocking interface mode
                              osp$set_status_abnormal (nac$status_id, nae$sk_insufficient_resources,
                                    'UDP Send', status);
                            IFEND;
                          IFEND;
                        ELSE { udp_connection^.send_queue <> NIL

                          IF interface_mode = nac$sk_blocking_mode THEN
                            get_sender_task_entry (udp_connection, sender_task);

{ Queue the current task at the end of the send queue.

                            sender_task^.next_entry := NIL;
                            sender_task^.task_id := current_task_id;
                            sender_task^.send_type := nlc$udp_send_data;
                            remaining_data_length_to_send := data_length;
                            current_lowerbound := 1;
                            send_queue := udp_connection^.send_queue;

                            WHILE (send_queue^.next_entry <> NIL) DO
                              send_queue := send_queue^.next_entry;
                            WHILEND;
                            send_queue^.next_entry := sender_task;
                          ELSE { non blocking mode
                            osp$set_status_condition (nae$sk_send_in_progress, status);
                            osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10,
                                  TRUE, status);
                          IFEND;
                        IFEND;
                      ELSE { UDP layer closed
                        osp$set_status_condition (nae$sk_socket_disconnected, status);
                        osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE,
                              status);
                      IFEND;
                    ELSE { UDP layer inactive
                      osp$set_status_condition (nae$sk_socket_disconnected, status);
                      osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE,
                            status);
                    IFEND;
                    nlp$cl_release_exclusive_access (cl_connection);
                  ELSE { Connection does not exist
                    osp$set_status_condition (nae$sk_socket_disconnected, status);
                    osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE,
                          status);
                  IFEND;

                  IF status.normal AND NOT activity_complete THEN
                    #SPOIL (activity_complete);
                    end_time := #FREE_RUNNING_CLOCK (0) + interface_timeout * 1000;
                    remaining_time := interface_timeout;
                    delete_global_socket := FALSE;
                    REPEAT
                      #SPOIL (remaining_data_length_to_send);
                      pmp$wait (remaining_time, 0);
                      current_time := #FREE_RUNNING_CLOCK (0);
                      IF current_time < end_time THEN
                        remaining_time := (end_time - current_time) DIV 1000;
                      ELSE
                        remaining_time := 0;
                      IFEND;

                      nlp$cl_get_exclusive_via_cid (connection_id, connection_exists, cl_connection);
                      IF cl_connection <> NIL THEN
                        nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, layer_active,
                              udp_connection);
                        IF layer_active THEN
                          IF udp_connection^.state = nlc$udp_conn_open THEN

{ Find the current task on the send queue.

                            sender_task := udp_connection^.send_queue;
                            IF sender_task^.task_id = current_task_id THEN

{ Current task is at the head of the queue.

                              IF NOT sender_active THEN
                                nlp$cl_activate_sender (cl_connection);
                                sender_active := TRUE;
                              IFEND;
                              nlp$cc_receive_data (cl_connection);
                              nlp$osi_get_outbound_capacity (cl_connection, capacity);
                              IF capacity > 0 THEN
                                initial_send := (data_length = remaining_data_length_to_send);
                                send_data (cl_connection, capacity, initial_send, data_fragments^,
                                      remaining_data_length_to_send, nac$sk_blocking_mode, current_lowerbound,
                                      new_lowerbound, remaining_data_length);
                                IF remaining_data_length = 0 THEN
                                  activity_complete := TRUE;
                                  nlp$cl_deactivate_sender (cl_connection);

{ The following needs to be done to process the clear to send indication that may have
{ been queued on the connection.

                                  nlp$cc_receive_data (cl_connection);

{ Dequeue the sender task from the send queue.
{ Return the sender task entry.

                                  udp_connection^.send_queue := sender_task^.next_entry;
                                  return_sender_task_entry (udp_connection, sender_task);
                                  IF udp_connection^.send_queue <> NIL THEN
                                    pmp$ready_task (udp_connection^.send_queue^.task_id, {ignore} status);
                                 status.normal := TRUE;
                               IFEND;
                             ELSE { remaining_data_length > 0
                               remaining_data_length_to_send := remaining_data_length;
                               current_lowerbound := new_lowerbound;
                             IFEND;
                           IFEND;
                           IF NOT activity_complete THEN
                             IF remaining_time = 0 THEN
                               udp_connection^.send_queue := sender_task^.next_entry;
                               nlp$cl_deactivate_sender (cl_connection);

{ The following needs to be done to process the clear to send indication that may have
{ been queued on the connection.

                               nlp$cc_receive_data (cl_connection);
                               IF remaining_data_length_to_send < data_length THEN

{ Partial data has been sent.
{ Send a Clear Send Request to the UDPAP.

                                 abort_send (cl_connection);
                               IFEND;

{ Queue the sender task in the available pool.

                               return_sender_task_entry (udp_connection, sender_task);
                               IF udp_connection^.send_queue <> NIL THEN
                                 pmp$ready_task (udp_connection^.send_queue^.task_id, {ignore} status);
                                 status.normal := TRUE;
                               IFEND;
                               osp$set_status_condition (nae$sk_interface_timeout, status);
                               osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10,
                                     TRUE, status);
                             IFEND;
                           IFEND;
                         ELSE { current task not at the head of the queue
                           IF remaining_time = 0 THEN
                             previous_sender_task := ^udp_connection^.send_queue;
                             WHILE (sender_task <> NIL) AND (sender_task^.task_id <> current_task_id) DO
                               previous_sender_task := ^sender_task^.next_entry;
                               sender_task := sender_task^.next_entry;
                             WHILEND;
                             IF sender_task <> NIL THEN

{ If the task is not at the head of the queue, it couldn't have sent
{ data. Dequeue the sender task from the send queue.

                               previous_sender_task^ := sender_task^.next_entry;
                               return_sender_task_entry (udp_connection, sender_task);
                             IFEND;
                             osp$set_status_condition (nae$sk_interface_timeout, status);
                             osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10,
                                   TRUE, status);
                           IFEND;
                         IFEND;
                       ELSEIF udp_connection^.state = nlc$udp_conn_closed THEN

{ Find the sender task.

                         previous_sender_task := ^udp_connection^.send_queue;
                         WHILE (sender_task <> NIL) AND (sender_task^.task_id <> current_task_id) DO
                           previous_sender_task := ^sender_task^.next_entry;
                           sender_task := sender_task^.next_entry;
                         WHILEND;
                         IF sender_task <> NIL THEN

{ Dequeue the sender task from the send queue.

                           previous_sender_task^ := sender_task^.next_entry;
                           FREE sender_task IN nav$network_paged_heap^;
                         IFEND;
                         osp$set_status_condition (nae$sk_socket_disconnected, status);
                         osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE,
                               status);
                         IF udp_connection^.send_queue = NIL THEN
                           close_udp_socket_device (global_socket_id, udp_connection^.device_id,
                                 delete_global_socket);
                           deactivate_udp_layer (cl_connection, udp_connection);
                         IFEND;
                       ELSE { Unexpected state
                         nap$namve_system_error ({Recoverable_error=} TRUE,
                               'Encountered an unexpected UDP layer state', NIL);
                         osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'SEND TO SOCKET',
                               status);
                       IFEND;
                     ELSE { Layer inactive
                       nap$namve_system_error ({Recoverable_error=} TRUE,
                             'Encountered  an inactive UDP layer.', NIL);
                       osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'SEND TO SOCKET',
                             status);
                     IFEND;
                     nlp$cl_release_exclusive_access (cl_connection);
                     IF delete_global_socket THEN
                       nlp$udp_delete_global_socket (global_socket_id);
                     IFEND;
                   ELSE { Connection terminated
                     nap$namve_system_error ({Recoverable_error=} TRUE,
                           'UDP connection teminated while IO was active.', NIL);
                     osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'SEND TO SOCKET', status);
                   IFEND;
                 UNTIL (activity_complete) OR (NOT status.normal);
               IFEND;
             FOREND;
           ELSE { No channel connection to the device
             osp$set_status_condition (nae$sk_socket_disconnected, status);
             osp$append_status_integer (osc$status_parameter_delimiter, local_socket_id, 10, TRUE, status);
           IFEND;

{ Update local routing cache.

           IF user_cache_enabled AND NOT broadcast THEN
             IF status.normal THEN
               nlv$udp_local_routing_cache.last_send.destination_ip_address := destination_socket.ip_address;
               nlv$udp_local_routing_cache.last_send.source_ip_address := udpaa_data_header.source_ip_address;
               nlv$udp_local_routing_cache.last_send.device_id := device_id;
             ELSE { Remove the entry
               IF nlv$udp_local_routing_cache.last_send.destination_ip_address =
                     destination_socket.ip_address THEN
                 nlv$udp_local_routing_cache.last_send.destination_ip_address := 0;
                 nlv$udp_local_routing_cache.last_send.source_ip_address := 0;
                 nlv$udp_local_routing_cache.last_send.device_id := 0;
               IFEND;
               IF nlv$udp_local_routing_cache.last_receive.source_ip_address =
                     destination_socket.ip_address THEN
                 nlv$udp_local_routing_cache.last_receive.source_ip_address := 0;
                 nlv$udp_local_routing_cache.last_receive.destination_ip_address := 0;
                 nlv$udp_local_routing_cache.last_receive.device_id := 0;
               IFEND;
             IFEND;
           IFEND;
         ELSE { invalid broadcast attempt
           osp$set_status_condition (nae$sk_broadcast_not_enabled, status);
           nlp$udp_free_exclusive_access (global_socket);
         IFEND;
       ELSE { time stamps do not match
         osp$set_status_condition (nae$sk_unknown_socket, status);
         nlp$udp_free_exclusive_access (global_socket);
       IFEND;
     ELSEIF global_socket^.status = nlc$udp_global_socket_term THEN
       osp$set_status_condition (nae$sk_socket_terminated, status);
       osp$append_status_integer (osc$status_parameter_delimiter, global_socket^.local_socket_id, 10, TRUE,
             status);
       nlp$udp_free_exclusive_access (global_socket);
     ELSE { socket closed
       osp$set_status_condition (nae$sk_unknown_socket, status);
       nlp$udp_free_exclusive_access (global_socket);
     IFEND;
   ELSE { global_socket = NIL
     osp$set_status_condition (nae$sk_unknown_socket, status);
   IFEND;
   osp$disestablish_cond_handler;
 IFEND;

 PROCEND nlp$udp_send_data;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_set_socket_options', EJECT ??

 PROCEDURE [XDCL] nlp$udp_set_socket_options
   (    global_socket_id: nlt$udp_global_socket_id;
        traffic_pattern: nat$sk_traffic_pattern;
        broadcast_enabled: boolean;
    VAR status: ost$status);

   VAR
     cl_connection: ^nlt$cl_connection,
     connection_exists: boolean,
     connection_list: ^array [1 .. * ] of nat$connection_id,
     data_fragment: array [1 .. 1] of nat$data_fragment,
     device_id: nlt$device_identifier,
     global_socket: ^nlt$udp_global_socket,
     ignore_status: ost$status,
     layer_active: boolean,
     udp_connection: ^nlt$udp_socket_layer,
     udpaa_set_options_request: nlt$udpaa_set_options_request;

   nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
   IF global_socket <> NIL THEN
     IF global_socket^.status = nlc$udp_global_socket_open THEN
       global_socket^.traffic_pattern := traffic_pattern;
       global_socket^.broadcast_enabled := broadcast_enabled;
       PUSH connection_list: [1 .. UPPERBOUND (global_socket^.device_list)];
       FOR device_id := 1 TO UPPERBOUND (global_socket^.device_list) DO
         IF global_socket^.device_list [device_id].status = nlc$udp_device_open THEN
           connection_list^ [device_id] := global_socket^.device_list [device_id].connection_id;
         ELSE
           connection_list^ [device_id] := nac$null_connection_id;
         IFEND;
       FOREND;

       nlp$udp_free_exclusive_access (global_socket);
       udpaa_set_options_request.header.kind := nlc$udpaa_set_options_req;
       udpaa_set_options_request.header.length := #SIZE (udpaa_set_options_request);
       udpaa_set_options_request.traffic_pattern := traffic_pattern;
       udpaa_set_options_request.broadcast_enabled := broadcast_enabled;
       data_fragment [1].address := ^udpaa_set_options_request;
       data_fragment [1].length := udpaa_set_options_request.header.length;

       FOR device_id := 1 TO UPPERBOUND (connection_list^) DO
         IF connection_list^ [device_id] <> nac$null_connection_id THEN
           nlp$cl_get_exclusive_via_cid (connection_list^ [device_id], connection_exists, cl_connection);
           IF cl_connection <> NIL THEN
             nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, layer_active, udp_connection);
             IF layer_active THEN
               nlp$cc_send_data_fragments (cl_connection, data_fragment, ignore_status);
             IFEND;
             nlp$cl_release_exclusive_access (cl_connection);
           IFEND;
         IFEND;
       FOREND;
     ELSEIF global_socket^.status = nlc$udp_global_socket_term THEN

{ The socket has been terminated via application management.

       osp$set_status_condition (nae$sk_socket_terminated, status);
       nlp$udp_free_exclusive_access (global_socket);
     ELSEIF global_socket^.status = nlc$udp_global_socket_unbound THEN
       global_socket^.traffic_pattern := traffic_pattern;
       global_socket^.broadcast_enabled := broadcast_enabled;
       nlp$udp_free_exclusive_access (global_socket);
     ELSE { unexpected status
       nap$namve_system_error ({Recoverable_error=} TRUE,
             'Encountered unexpected global socket status', NIL);
       osp$set_status_abnormal (nac$status_id, nae$sk_internal_error, 'SET SOCKET OPTIONS', status);
       nlp$udp_free_exclusive_access (global_socket);
     IFEND;
   ELSE { global_socket = NIL

{ The socket has been terminated via application management.

     osp$set_status_condition (nae$sk_socket_terminated, status);
   IFEND;

 PROCEND nlp$udp_set_socket_options;
?? OLDTITLE ??
?? NEWTITLE := 'abort_send', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to send a clear send request
{ to the UDP Access Provider. This request is sent whenever  partial
{ data has been sent to the UDPAP and the remaining data is not going
{ to be sent.

 PROCEDURE abort_send
   (    cl_connection: ^nlt$cl_connection);

   VAR
     data_fragment: array [1 .. 1] of nat$data_fragment,
     ignore_status: ost$status,
     udpaa_clear_send_request: nlt$udpaa_clear_send_request;

   udpaa_clear_send_request.header.kind := nlc$udpaa_clear_send_req;
   udpaa_clear_send_request.header.length := #SIZE (udpaa_clear_send_request);
   data_fragment [1].address := ^udpaa_clear_send_request;
   data_fragment [1].length := udpaa_clear_send_request.header.length;
   nlp$cc_send_data_fragments (cl_connection, data_fragment, ignore_status);

 PROCEND abort_send;
?? OLDTITLE ??
?? NEWTITLE := 'activate_next_receiver_task', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to activate the next receiver in the
{ receive wait queue. The task at the head of the queue is assumed
{ to be the current task. If the next receiver task is awaiting the data
{ available indication, the activity is marked as complete and the receiver
{ is dequeued. If the task is awaiting data, the attributes of the queued
{ data are matched against the selection criteria specified by the receiver.
{ If the attributes match, data is delivered to the receiver. Otherwise the
{ data is discarded.

 PROCEDURE activate_next_receiver_task
   (VAR global_socket: ^nlt$udp_global_socket;
        device_id: nlt$device_identifier;
    VAR buffers_freed: nat$data_length);

   VAR
     ignore_status: ost$status,
     received_message: ^nlt$udp_received_message,
     receiver_task: ^nlt$udp_receiver_task;

   receiver_task := global_socket^.receive_wait_queue;
   IF receiver_task^.receive_type = nlc$udp_receive_data THEN
     received_message := global_socket^.device_list [device_id].received_messages;
     IF ((receiver_task^.selection_criteria.ip_address = 0) OR
           (receiver_task^.selection_criteria.ip_address = received_message^.source_socket.ip_address)) AND
           ((receiver_task^.selection_criteria.port = 0) OR (receiver_task^.selection_criteria.port =
           received_message^.source_socket.port)) THEN
       global_socket^.receive_wait_queue := receiver_task^.next_entry;
       receiver_task^.next_entry := NIL;
       global_socket^.device_list [device_id].receiver_task := receiver_task;
       receiver_task^.connection_id := global_socket^.device_list [device_id].connection_id;
       receiver_task^.device_id^ := device_id;
       receive_data (global_socket, device_id, buffers_freed);
     ELSE { discard received message
       nlp$bm_release_message (received_message^.data);
       buffers_freed := received_message^.buffer_count;
       global_socket^.device_list [device_id].received_messages := received_message^.next_entry;
       return_received_message_entry (global_socket, received_message);
     IFEND;
   ELSE { await data available
     receiver_task^.activity_complete^ := TRUE;
     global_socket^.receive_wait_queue := receiver_task^.next_entry;
     IF receiver_task^.receiver_active THEN
       nlp$udp_deactivate_receiver (global_socket^.active_receiver);
     IFEND;
     return_receiver_task_entry (global_socket, receiver_task);
     IF global_socket^.receive_wait_queue <> NIL THEN
       pmp$ready_task (global_socket^.receive_wait_queue^.task_id, ignore_status);
     IFEND;
   IFEND;

 PROCEND activate_next_receiver_task;
?? OLDTITLE ??
?? NEWTITLE := 'activate_next_sender_task', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to ready the next task
{ waiting to send data. All the tasks awaiting a clear to
{ send indication and queued ahead of the task waiting to send
{ data are readied and dequeued.

 PROCEDURE activate_next_sender_task
   (VAR udp_connection: ^nlt$udp_socket_layer);

   VAR
     ignore_status: ost$status,
     previous_sender_task: ^^nlt$udp_sender_task,
     sender_task: ^nlt$udp_sender_task;

{ Find the next task waiting to send data.

   sender_task := udp_connection^.send_queue;
   previous_sender_task := ^udp_connection^.send_queue;

 /activate_sender/
   WHILE sender_task <> NIL DO
     IF sender_task^.send_type = nlc$udp_await_clear_to_send THEN
       previous_sender_task^ := sender_task^.next_entry;
       pmp$ready_task (sender_task^.task_id, ignore_status);
       return_sender_task_entry (udp_connection, sender_task);
       sender_task := previous_sender_task^;
     ELSE
       pmp$ready_task (sender_task^.task_id, ignore_status);
       EXIT /activate_sender/;
     IFEND;
   WHILEND /activate_sender/;

 PROCEND activate_next_sender_task;
?? OLDTITLE ??
?? NEWTITLE := 'close_udp_socket_device', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to update the status of
{ the given device to "closed" in the socket device list. It also
{ decrements the active device count. An active receiver on the
{ device is also readied.  This procedure is meant to be called
{ when the last sender on a UDP channel connection is dequeued.
{ If the global socket is closed or terminated (via appl mgmt),
{ an appropriate flag is returned to the caller so it can delete
{ the global socket.

 PROCEDURE close_udp_socket_device
   (    global_socket_id: nlt$udp_global_socket_id;
        device_id: nlt$device_identifier;
    VAR delete_global_socket: boolean);

   VAR
     global_socket: ^nlt$udp_global_socket,
     ignore_status: ost$status,
     receiver_task: ^nlt$udp_receiver_task;

   delete_global_socket := FALSE;
   nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
   IF global_socket <> NIL THEN
     global_socket^.device_list [device_id].status := nlc$udp_device_closed;
     global_socket^.device_list [device_id].connection_id := nac$null_connection_id;
     global_socket^.active_device_count := global_socket^.active_device_count - 1;
     discard_received_messages (device_id, global_socket);
     IF global_socket^.device_list [device_id].receiver_task <> NIL THEN
       receiver_task := global_socket^.device_list [device_id].receiver_task;
       global_socket^.device_list [device_id].receiver_task := NIL;
       pmp$ready_task (receiver_task^.task_id, ignore_status);
       receiver_task^.next_entry := global_socket^.receive_wait_queue;
       global_socket^.receive_wait_queue := receiver_task;
     IFEND;
     delete_global_socket := (global_socket^.status = nlc$udp_global_socket_closed) AND
           (global_socket^.receive_wait_queue = NIL) AND (global_socket^.active_device_count = 0);
     nlp$udp_free_exclusive_access (global_socket);
   IFEND;

 PROCEND close_udp_socket_device;
?? OLDTITLE ??
?? NEWTITLE := 'deactivate_udp_layer', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to free all allocated structures
{   associated with the layer connection and to deactivate the layer.

 PROCEDURE [INLINE] deactivate_udp_layer
   (    cl_connection: ^nlt$cl_connection;
    VAR udp_connection: ^nlt$udp_socket_layer);

   VAR
     next_pool_entry: ^nlt$udp_sender_task,
     pool_entry: ^nlt$udp_sender_task;

   pool_entry := udp_connection^.available_sender_pool;
   WHILE pool_entry <> NIL DO
     next_pool_entry := pool_entry^.next_entry;
     FREE pool_entry IN nav$network_paged_heap^;
     pool_entry := next_pool_entry;
   WHILEND;
   nlp$cl_deactivate_layer (nlc$udp_interface, cl_connection);

 PROCEND deactivate_udp_layer;
?? OLDTITLE ??
?? NEWTITLE := 'discard_received_messages', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to discard the received messages
{ queued on the given device. This procedure is meant to be called when
{ the channel connection to a given device breaks.
{
{ The global socket must be locked by the caller.

 PROCEDURE discard_received_messages
   (    device_id: nlt$device_identifier;
    VAR global_socket: ^nlt$udp_global_socket);

   VAR
     next_received_message: ^nlt$udp_received_message,
     received_message: ^nlt$udp_received_message;

   IF global_socket^.device_list [device_id].received_messages <> NIL THEN
     received_message := global_socket^.device_list [device_id].received_messages;
     global_socket^.device_list [device_id].received_messages := NIL;

     WHILE (received_message <> NIL) DO
       IF received_message^.data <> nlv$bm_null_message_id THEN
         nlp$bm_release_message (received_message^.data);
       IFEND;
       next_received_message := received_message^.next_entry;
       return_received_message_entry (global_socket, received_message);
       received_message := next_received_message;
     WHILEND;
   IFEND;

 PROCEND discard_received_messages;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_receiver_task_entry', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to get a receiver task entry
{ from the pool of available entries. If the pool is empty, the
{ entry is allocated. The pool of available receiver task entries is
{ maintained in the global socket.

 PROCEDURE [INLINE] get_receiver_task_entry
   (VAR global_socket: ^nlt$udp_global_socket;
    VAR receiver_task: ^nlt$udp_receiver_task);

   IF global_socket^.available_receiver_pool <> NIL THEN
     receiver_task := global_socket^.available_receiver_pool;
     global_socket^.available_receiver_pool := receiver_task^.next_entry;
   ELSE
     REPEAT
       ALLOCATE receiver_task IN nav$network_paged_heap^;
       IF receiver_task = NIL THEN
         syp$cycle;
       IFEND;
     UNTIL receiver_task <> NIL;
   IFEND;

 PROCEND get_receiver_task_entry;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_sender_task_entry', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to find a sender task entry
{ in the pool of available entries. If the pool is empty, the
{ entry is allocated.

 PROCEDURE [INLINE] get_sender_task_entry
   (VAR udp_connection: ^nlt$udp_socket_layer;
    VAR sender_task: ^nlt$udp_sender_task);

   IF udp_connection^.available_sender_pool <> NIL THEN
     sender_task := udp_connection^.available_sender_pool;
     udp_connection^.available_sender_pool := sender_task^.next_entry;
   ELSE { Allocate sender task entry
     REPEAT
       ALLOCATE sender_task IN nav$network_paged_heap^;
       IF sender_task = NIL THEN
         syp$cycle;
       IFEND;
     UNTIL sender_task <> NIL;
   IFEND;

 PROCEND get_sender_task_entry;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_receiver_task_entry', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to get a receiver task
{ entry and initialize all the fields to the specified values.

 PROCEDURE [INLINE] initialize_receiver_task_entry
   (VAR global_socket: ^nlt$udp_global_socket;
        current_task_id: ost$global_task_id;
        receive_type: nlt$udp_receive_type;
        original_receive_buffer: ^nat$data_fragments;
        original_buffer_length: integer;
        receive_buffer: ^nat$data_fragments;
        buffer_length: integer;
        received_data_length: ^integer;
        selection_criteria: nat$sk_socket_address;
        foreign_socket: ^nat$sk_socket_address;
        local_ip_address: ^nat$sk_ip_address;
        device_id: ^nlt$device_identifier;
        connection_id: nat$connection_id;
        interface_mode: nat$sk_interface_mode;
        activity_status: ^ost$activity_status;
    VAR receiver_task: ^nlt$udp_receiver_task);


   get_receiver_task_entry (global_socket, receiver_task);
   receiver_task^.next_entry := NIL;
   receiver_task^.task_id := current_task_id;
   receiver_task^.end_of_message := FALSE;
   receiver_task^.receive_type := receive_type;
   receiver_task^.original_receive_buffer := original_receive_buffer;
   receiver_task^.original_buffer_length := original_buffer_length;
   receiver_task^.receive_buffer := receive_buffer;
   receiver_task^.buffer_length := buffer_length;
   receiver_task^.received_data_length := received_data_length;
   receiver_task^.selection_criteria := selection_criteria;
   receiver_task^.foreign_socket := foreign_socket;
   receiver_task^.local_ip_address := local_ip_address;
   receiver_task^.device_id := device_id;
   receiver_task^.connection_id := connection_id;
   receiver_task^.interface_mode := interface_mode;
   receiver_task^.activity_status := activity_status;

 PROCEND initialize_receiver_task_entry;
?? OLDTITLE ??
?? NEWTITLE := 'issue_disconnect', EJECT ??

{ PUROSE:
{   The purpose of this procedure is to format the release request
{ PDU and send it to the UDP Access Provider via a channel connection
{ disconnect request.

 PROCEDURE issue_disconnect
   (    cl_connection: ^nlt$cl_connection;
        disconnect_reason: nlt$udpaa_release_req_reason);

   VAR
     data_fragment: array [1 .. 1] of nat$data_fragment,
     ignore_status: ost$status,
     release_request: nlt$udpaa_release_request,
     udpaa_pdu: nlt$bm_message_id;

   release_request.header.kind := nlc$udpaa_release_req;
   release_request.header.length := #SIZE (release_request);
   release_request.reason := disconnect_reason;
   data_fragment [1].address := ^release_request;
   data_fragment [1].length := release_request.header.length;
   nlp$bm_create_message (data_fragment, udpaa_pdu, ignore_status);
   nlp$cc_disconnect (cl_connection, udpaa_pdu, ignore_status);

 PROCEND issue_disconnect;
?? OLDTITLE ??
?? NEWTITLE := 'issue_protocol_error', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to issue a protocol
{ error to the UDP Access Provider. It is assumed that the
{ global socket is locked by the caller. All active senders
{ on the connection will be readied and if no IO is active
{ on the connection the socket device list will be updated.
{ The only difference between this routine and the 'PROCESS
{ PROTOCOL ERROR' routine is that the latter will explicitly
{ lock the global socket.

 PROCEDURE issue_protocol_error
   (    cl_connection: ^nlt$cl_connection;
    VAR global_socket: ^nlt$udp_global_socket;
    VAR udp_connection: ^nlt$udp_socket_layer);

   VAR
     current_task_id: ost$global_task_id,
     ignore_status: ost$status,
     previous_sender_task: ^^nlt$udp_sender_task,
     receiver_task: ^nlt$udp_receiver_task,
     sender_task: ^nlt$udp_sender_task;

   IF udp_connection^.send_queue <> NIL THEN
     sender_task := udp_connection^.send_queue;
     previous_sender_task := ^udp_connection^.send_queue;

     WHILE sender_task <> NIL DO
       pmp$ready_task (sender_task^.task_id, ignore_status);
       IF sender_task^.send_type = nlc$udp_await_clear_to_send THEN
         previous_sender_task^ := sender_task^.next_entry;
         FREE sender_task IN nav$network_paged_heap^;
         sender_task := previous_sender_task^;
       ELSE
         previous_sender_task := ^sender_task^.next_entry;
         sender_task := sender_task^.next_entry;
       IFEND;
     WHILEND;
   IFEND;

   IF global_socket^.device_list [udp_connection^.device_id].receiver_task <> NIL THEN
     pmp$get_executing_task_gtid (current_task_id);
     receiver_task := global_socket^.device_list [udp_connection^.device_id].receiver_task;
     IF receiver_task^.task_id = current_task_id THEN
       receiver_task^.received_data_length^ := 0;
       IF receiver_task^.interface_mode = nac$sk_blocking_mode THEN

{ Queue the receiver back in the receive queue.

         receiver_task^.next_entry := global_socket^.receive_wait_queue;
         global_socket^.receive_wait_queue := receiver_task;
       ELSE { non blocking mode
         receiver_task^.activity_status^.complete := TRUE;
         osp$set_status_condition (nae$sk_no_data_available, receiver_task^.activity_status^.status);
         osp$append_status_integer (osc$status_parameter_delimiter, global_socket^.local_socket_id, 10, TRUE,
               receiver_task^.activity_status^.status);
         return_receiver_task_entry (global_socket, receiver_task);
         nlp$udp_deactivate_receiver (global_socket^.active_receiver);
         IF global_socket^.receive_wait_queue <> NIL THEN
           pmp$ready_task (global_socket^.receive_wait_queue^.task_id, ignore_status);
         IFEND;
       IFEND;
     IFEND;
   IFEND;

   discard_received_messages (udp_connection^.device_id, global_socket);
   issue_disconnect (cl_connection, nlc$udpaa_rr_protocol_error);

{ Update the device status in the global socket.

   IF udp_connection^.send_queue = NIL THEN
     global_socket^.device_list [udp_connection^.device_id].status := nlc$udp_device_closed;
     global_socket^.active_device_count := global_socket^.active_device_count - 1;
     deactivate_udp_layer (cl_connection, udp_connection);
   ELSE
     global_socket^.device_list [udp_connection^.device_id].status := nlc$udp_device_closed;
   IFEND;

 PROCEND issue_protocol_error;
?? OLDTITLE ??
?? NEWTITLE := 'log_disconnect', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to record the occurance of an UDP
{ release or Channel Connection disconnect indication on the system and
{ job logs.

 PROCEDURE [INLINE] log_disconnect
   (    indication: string ( * );
        global_socket_id: nlt$udp_global_socket_id;
        device_id: nlt$device_identifier);

{   VAR
{     element: cmt$element_name,
{     global_socket: ^nlt$udp_global_socket,
{     ignore_status: ost$status,
{     local_socket: integer,
{     message: string (132),
{     message_length: integer,
{     port: nat$sk_port_number;
{
{   nlp$udp_get_exclusive_via_gsid (global_socket_id, global_socket);
{   IF global_socket <> NIL THEN
{     local_socket := global_socket^.local_socket_id;
{     port := global_socket^.port;
{     nlp$udp_free_exclusive_access (global_socket);
{   ELSE
{     port := 0;
{     local_socket := 0;
{   IFEND;
{   nlp$get_nonexclusive_access (nlv$configured_network_devices.access_control);
{   element := nlv$configured_network_devices.network_device_list^ [device_id].element;
{   nlp$release_nonexclusive_access (nlv$configured_network_devices.access_control);
{   STRINGREP (message, message_length, indication, ' from device = ', element, ', for local socket = ',
{         local_socket, ', port = ', port);
{   pmp$log_ascii (message (1, message_length), $pmt$ascii_logset [pmc$system_log, pmc$job_log],
{         pmc$msg_origin_system, ignore_status);
{

 PROCEND log_disconnect;
?? OLDTITLE ??
?? NEWTITLE := 'process_clear_send_indication', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to process the clear send
{ indication received from the UDP Access Provider. If there is a
{ task receiving data over the specified device, the receive is
{ terminated.
{ If there is more than one message queued, the partial fragment
{ (which should be at the end of the list) is discarded.
{ Note that if a receiver is active on the device, there will be
{ no data queued.

 PROCEDURE process_clear_send_indication
   (    udp_connection: ^nlt$udp_socket_layer;
    VAR buffers_freed: nat$data_length);


   VAR
     current_task_id: ost$global_task_id,
     global_socket: ^nlt$udp_global_socket,
     ignore_status: ost$status,
     previous_received_message: ^^nlt$udp_received_message,
     received_message: ^nlt$udp_received_message,
     receiver_task: ^nlt$udp_receiver_task,
     socket_device_list: ^nlt$udp_socket_device_list;

   buffers_freed := 0;
   pmp$get_executing_task_gtid (current_task_id);
   nlp$udp_get_exclusive_via_gsid (udp_connection^.global_socket_id, global_socket);
   IF global_socket <> NIL THEN
     IF (global_socket^.status <> nlc$udp_global_socket_closed) AND
           (global_socket^.status <> nlc$udp_global_socket_term) THEN
       socket_device_list := ^global_socket^.device_list;
       IF NOT socket_device_list^ [udp_connection^.device_id].discard_data THEN
         IF socket_device_list^ [udp_connection^.device_id].receiver_task <> NIL THEN
           receiver_task := socket_device_list^ [udp_connection^.device_id].receiver_task;
           IF receiver_task^.task_id = current_task_id THEN

{ Abort the receive.
{ Initialize all buffer attributes.

             receiver_task^.receive_buffer^ := receiver_task^.original_receive_buffer^;
             receiver_task^.buffer_length := receiver_task^.original_buffer_length;
             receiver_task^.received_data_length^ := 0;
             receiver_task^.device_id^ := 0;

{ Dequeue the receiver task. Terminate the receive if the receiver is
{ non blocking. For a blocking receive the nlp$udp_receive_data process
{ will decide if receive is to be terminated or restarted.

             socket_device_list^ [udp_connection^.device_id].receiver_task := NIL;
             IF receiver_task^.interface_mode = nac$sk_non_blocking_mode THEN
               receiver_task^.activity_status^.complete := TRUE;
               osp$set_status_condition (nae$sk_no_data_available, receiver_task^.activity_status^.status);
               osp$append_status_integer (osc$status_parameter_delimiter, global_socket^.local_socket_id, 10,
                     TRUE, receiver_task^.activity_status^.status);
               return_receiver_task_entry (global_socket, receiver_task);
             IFEND;
           ELSE { not the right task.

{ Queue the abort receive indication on the connection.

             IF global_socket^.device_list [udp_connection^.device_id].received_messages <> NIL THEN
               received_message := global_socket^.device_list [udp_connection^.device_id].received_messages;
               nlp$bm_release_message (received_message^.data);
               buffers_freed := received_message^.buffer_count;
               received_message^.abort_receive := TRUE;
               received_message^.buffer_count := 0;
             ELSE
               IF global_socket^.available_message_pool <> NIL THEN
                 received_message := global_socket^.available_message_pool;
                 global_socket^.available_message_pool := received_message^.next_entry;
                 global_socket^.available_message_pool_size := global_socket^.available_message_pool_size - 1;
               ELSE { pool empty
                 REPEAT
                   ALLOCATE received_message IN nav$network_paged_heap^;
                   IF received_message = NIL THEN
                     syp$cycle;
                   IFEND;
                 UNTIL received_message <> NIL;
               IFEND;
               received_message^.abort_receive := TRUE;
               received_message^.buffer_count := 0;
               received_message^.data := nlv$bm_null_message_id;
             IFEND;
             pmp$ready_task (receiver_task^.task_id, ignore_status);
           IFEND;
         ELSE { no receiver task

{ Dequeue the received message and return it to the pool.
{ Find the partial fragment.

           received_message := global_socket^.device_list [udp_connection^.device_id].received_messages;
           previous_received_message := ^global_socket^.device_list [udp_connection^.device_id].
                 received_messages;
           WHILE (received_message <> NIL) AND (received_message^.end_of_message) DO
             previous_received_message := ^received_message^.next_entry;
             received_message := received_message^.next_entry;
           WHILEND;
           IF received_message <> NIL THEN

{ Dequeue the partial fragment. The partial fragment should be the last fragment in
{ the queue.

             previous_received_message^ := NIL;
             buffers_freed := received_message^.buffer_count;
             nlp$bm_release_message (received_message^.data);
             return_received_message_entry (global_socket, received_message);
           ELSE { no partial fragment
             nap$namve_system_error ({Recoverable_error=} TRUE,
                   'Clear send indication received and no partial fragment found.', NIL);
           IFEND;
         IFEND;
       ELSE { discard data
         socket_device_list^ [udp_connection^.device_id].discard_data := FALSE;
       IFEND;
     IFEND;
     nlp$udp_free_exclusive_access (global_socket);
   IFEND;

 PROCEND process_clear_send_indication;
?? OLDTITLE ??
?? NEWTITLE := 'process_protocol_error', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to disconnect the channel
{ connection to the device. All senders and receivers are signalled
{ or readied. If no IO is active on the connection, the layer is
{ deactivated. The device status in the global socket is updated
{ to closed.

 PROCEDURE process_protocol_error
   (    cl_connection: ^nlt$cl_connection;
    VAR udp_connection: ^nlt$udp_socket_layer);

   VAR
     global_socket: ^nlt$udp_global_socket,
     ignore_status: ost$status,
     previous_sender_task: ^^nlt$udp_sender_task,
     receiver_task: ^nlt$udp_receiver_task,
     sender_task: ^nlt$udp_sender_task;

   IF udp_connection^.send_queue <> NIL THEN
     sender_task := udp_connection^.send_queue;
     previous_sender_task := ^udp_connection^.send_queue;

     WHILE sender_task <> NIL DO
       pmp$ready_task (sender_task^.task_id, ignore_status);
       IF sender_task^.send_type = nlc$udp_await_clear_to_send THEN
         previous_sender_task^ := sender_task^.next_entry;
         FREE sender_task IN nav$network_paged_heap^;
         sender_task := previous_sender_task^;
       ELSE
         previous_sender_task := ^sender_task^.next_entry;
         sender_task := sender_task^.next_entry;
       IFEND;
     WHILEND;
   IFEND;

   issue_disconnect (cl_connection, nlc$udpaa_rr_protocol_error);

{ Update the device status in the global socket.

   nlp$udp_get_exclusive_via_gsid (udp_connection^.global_socket_id, global_socket);
   IF global_socket <> NIL THEN
     global_socket^.device_list [udp_connection^.device_id].status := nlc$udp_device_closed;
     IF udp_connection^.send_queue = NIL THEN
       global_socket^.active_device_count := global_socket^.active_device_count - 1;
       deactivate_udp_layer (cl_connection, udp_connection);
     IFEND;
     IF global_socket^.device_list [udp_connection^.device_id].receiver_task <> NIL THEN
       receiver_task := global_socket^.device_list [udp_connection^.device_id].receiver_task;
       global_socket^.device_list [udp_connection^.device_id].receiver_task := NIL;

{ The receiver_task must be for the current task.

       receiver_task^.received_data_length^ := 0;
       IF receiver_task^.interface_mode = nac$sk_non_blocking_mode THEN
         receiver_task^.activity_status^.complete := TRUE;
         osp$set_status_condition (nae$sk_no_data_available, receiver_task^.activity_status^.status);
         osp$append_status_integer (osc$status_parameter_delimiter, global_socket^.local_socket_id, 10, TRUE,
               receiver_task^.activity_status^.status);
         return_receiver_task_entry (global_socket, receiver_task);
       ELSE

{ Requeue the task in the receive wait queue.

         receiver_task^.next_entry := global_socket^.receive_wait_queue;
         global_socket^.receive_wait_queue := receiver_task;
       IFEND;
     IFEND;
     discard_received_messages (udp_connection^.device_id, global_socket);
     nlp$udp_free_exclusive_access (global_socket);
   ELSE
     nap$namve_system_error ({Recoverable_error=} TRUE,
           'Encountered a NIL global socket while processing a UDPAA protocol error.', NIL);
   IFEND;

 PROCEND process_protocol_error;
?? OLDTITLE ??
?? NEWTITLE := 'process_disconnect_indication', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to process the disconnect indication received when
{ the channel connection to the device is in the open state. All senders are idled
{ and partial received data is discarded. If no senders are active on the connection,
{ the layer connection is deactivated. Any receiver active on the device is dequeued
{ and readied.

 PROCEDURE process_disconnect_indication
   (    cl_connection: ^nlt$cl_connection;
    VAR udp_connection: ^nlt$udp_socket_layer);

   VAR
     global_socket: ^nlt$udp_global_socket,
     ignore_delete_global_socket: boolean,
     ignore_status: ost$status,
     previous_sender_task: ^^nlt$udp_sender_task,
     receiver_task: ^nlt$udp_receiver_task,
     sender_task: ^nlt$udp_sender_task;

   IF udp_connection^.send_queue <> NIL THEN
     sender_task := udp_connection^.send_queue;
     previous_sender_task := ^udp_connection^.send_queue;
     WHILE sender_task <> NIL DO
       pmp$ready_task (sender_task^.task_id, ignore_status);
       IF sender_task^.send_type = nlc$udp_await_clear_to_send THEN

{ Dequeue tasks waiting for a clear to send indication.

         previous_sender_task^ := sender_task^.next_entry;
         FREE sender_task IN nav$network_paged_heap^;
         sender_task := previous_sender_task^;
       ELSEIF sender_task^.send_type = nlc$udp_send_data THEN
         previous_sender_task := ^sender_task^.next_entry;
         sender_task := sender_task^.next_entry;
       IFEND;
     WHILEND;
   IFEND;

{ If no sender active then deactivate the layer.

   IF udp_connection^.send_queue = NIL THEN
     deactivate_udp_layer (cl_connection, udp_connection);

{ Update the socket device status in the global socket entry and
{ decrement the active device count.

     close_udp_socket_device (udp_connection^.global_socket_id, udp_connection^.device_id,
           ignore_delete_global_socket);
   ELSE
     nlp$udp_get_exclusive_via_gsid (udp_connection^.global_socket_id, global_socket);
     IF global_socket <> NIL THEN
       global_socket^.device_list [udp_connection^.device_id].status := nlc$udp_device_closed;
       IF global_socket^.device_list [udp_connection^.device_id].receiver_task <> NIL THEN

{ Requeue the receiver in the receive wait queue.

         receiver_task := global_socket^.device_list [udp_connection^.device_id].receiver_task;
         global_socket^.device_list [udp_connection^.device_id].receiver_task := NIL;
         pmp$ready_task (receiver_task^.task_id, ignore_status);
         receiver_task^.next_entry := global_socket^.receive_wait_queue;
         global_socket^.receive_wait_queue := receiver_task;
         discard_received_messages (udp_connection^.device_id, global_socket);
       IFEND;
       nlp$udp_free_exclusive_access (global_socket);
     IFEND;
   IFEND;
   udp_connection^.state := nlc$udp_conn_closed;

 PROCEND process_disconnect_indication;
?? OLDTITLE ??
?? NEWTITLE := 'receive_data', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to deliver the next queued
{ messages to the receiver task queued on the specified device.
{ If the receive is to be terminated on account of an abort
{ request, the receiver task is queued back in the receive
{ queue on the global socket. It is assumed that this procedure
{ is called when there is a message queued on the device and a
{ receiver active on the device.

 PROCEDURE receive_data
   (VAR global_socket: ^nlt$udp_global_socket;
        device_id: nlt$device_identifier;
    VAR buffers_freed: nat$data_length);

?? NEWTITLE := 'terminate_receive', EJECT ??

   PROCEDURE terminate_receive
     (    condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

     CASE condition.selector OF
     = pmc$system_conditions, mmc$segment_access_condition =
       IF receiver_task <> NIL THEN

{ Mark receive complete.

         receiver_task^.activity_status^.complete := TRUE;
         nlp$udp_deactivate_receiver (global_socket^.active_receiver);
         osp$set_status_from_condition (nac$status_id, condition, sa, receiver_task^.activity_status^.status,
               condition_status);
         condition_status.normal := TRUE;

{ Dequeue the receiver task.

         socket_device_list^ [device_id].receiver_task := NIL;
         IF NOT received_message^.end_of_message THEN
           buffers_freed := received_message^.buffer_count;
           socket_device_list^ [device_id].discard_data := TRUE;
         ELSEIF global_socket^.receive_wait_queue <> NIL THEN
           pmp$ready_task (global_socket^.receive_wait_queue^.task_id, ignore_status);
         IFEND;

         return_received_message_entry (global_socket, received_message);
         return_receiver_task_entry (global_socket, receiver_task);
       IFEND;

       EXIT receive_data;
     = pmc$user_defined_condition =
       IF condition.user_condition_name = 'osc$job_recovery' THEN
         pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
       IFEND;
       condition_status.normal := TRUE;
     ELSE
       condition_status.normal := TRUE;
     CASEND;

   PROCEND terminate_receive;
?? OLDTITLE ??
?? EJECT ??

   VAR
     delivered_data_length: integer,
     ignore_status: ost$status,
     previous_received_message: ^nlt$udp_received_message,
     received_message: ^nlt$udp_received_message,
     receiver_task: ^nlt$udp_receiver_task,
     socket_device_list: ^nlt$udp_socket_device_list;

   buffers_freed := 0;
   socket_device_list := ^global_socket^.device_list;
   #SPOIL (socket_device_list);

{ Dequeue received message.

   receiver_task := socket_device_list^ [device_id].receiver_task;
   #SPOIL (receiver_task);
   received_message := socket_device_list^ [device_id].received_messages;
   #SPOIL (received_message);
   socket_device_list^ [device_id].received_messages := received_message^.next_entry;
   osp$establish_condition_handler (^terminate_receive, FALSE);

   IF NOT received_message^.abort_receive THEN

{ Here it is assumed that the data meets the receiver's selection criteria.
{ The receiver task is queued on the socket device entry only after the selection
{ criteria is matched.

     IF ((received_message^.data_length < receiver_task^.buffer_length) AND
           (NOT received_message^.end_of_message)) OR ((received_message^.data_length <=
           receiver_task^.buffer_length) AND (received_message^.end_of_message)) THEN
       nlp$bm_deliver_message (receiver_task^.receive_buffer^, received_message^.data, delivered_data_length,
             buffers_freed);
       receiver_task^.end_of_message := received_message^.end_of_message;
       receiver_task^.received_data_length^ := receiver_task^.received_data_length^ +delivered_data_length;
       receiver_task^.buffer_length := receiver_task^.buffer_length - delivered_data_length;
       receiver_task^.foreign_socket^ := received_message^.source_socket;
       receiver_task^.local_ip_address^ := received_message^.destination_ip_address;
       IF receiver_task^.end_of_message THEN
         receiver_task^.activity_status^.complete := TRUE;

{ Dequeue and return the receiver task.

         socket_device_list^ [device_id].receiver_task := NIL;
         return_receiver_task_entry (global_socket, receiver_task);
         nlp$udp_deactivate_receiver (global_socket^.active_receiver);

{ Activate the next receiver.

         IF global_socket^.receive_wait_queue <> NIL THEN
           pmp$ready_task (global_socket^.receive_wait_queue^.task_id, ignore_status);
         IFEND;
       IFEND;
     ELSE { data area too small

{ Discard the data and terminate receive.

       nlp$bm_release_message (received_message^.data);
       buffers_freed := received_message^.buffer_count;
       IF NOT received_message^.end_of_message THEN
         socket_device_list^ [device_id].discard_data := TRUE;
       IFEND;
       receiver_task^.activity_status^.complete := TRUE;

{ Dequeue the receiver task.

       socket_device_list^ [device_id].receiver_task := NIL;
       osp$set_status_condition (nae$sk_data_area_too_small, receiver_task^.activity_status^.status);
       osp$append_status_integer (osc$status_parameter_delimiter, global_socket^.local_socket_id, 10, TRUE,
             receiver_task^.activity_status^.status);
       return_receiver_task_entry (global_socket, receiver_task);
       IF global_socket^.receive_wait_queue <> NIL THEN
         pmp$ready_task (global_socket^.receive_wait_queue^.task_id, ignore_status);
       IFEND;
     IFEND;
   ELSE { abort receive

{ Abort the current receive.
{ Reset the buffer area.

     receiver_task^.receive_buffer^ := receiver_task^.original_receive_buffer^;
     receiver_task^.buffer_length := receiver_task^.original_buffer_length;
     receiver_task^.received_data_length^ := 0;
     receiver_task^.device_id^ := 0;
     receiver_task^.connection_id := nac$null_connection_id;

{ Dequeue the receiver task.

     socket_device_list^ [device_id].receiver_task := NIL;

{ The global socket is assumed to be open.

     IF receiver_task^.interface_mode = nac$sk_blocking_mode THEN

{ Queue the receiver back in the receive queue.

       receiver_task^.next_entry := global_socket^.receive_wait_queue;
       global_socket^.receive_wait_queue := receiver_task;
     ELSE { non blocking mode
       receiver_task^.activity_status^.complete := TRUE;
       osp$set_status_condition (nae$sk_no_data_available, receiver_task^.activity_status^.status);
       osp$append_status_integer (osc$status_parameter_delimiter, global_socket^.local_socket_id, 10, TRUE,
             receiver_task^.activity_status^.status);
       return_receiver_task_entry (global_socket, receiver_task);
       nlp$udp_deactivate_receiver (global_socket^.active_receiver);
       IF global_socket^.receive_wait_queue <> NIL THEN
         pmp$ready_task (global_socket^.receive_wait_queue^.task_id, ignore_status);
       IFEND;
     IFEND;
   IFEND;
   return_received_message_entry (global_socket, received_message);

 PROCEND receive_data;
?? OLDTITLE ??
?? NEWTITLE := 'return_received_message_entry', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to return the given received
{ message entry. It is either added to the pool of received message
{ entries or is freed.

 PROCEDURE [INLINE] return_received_message_entry
   (VAR global_socket: ^nlt$udp_global_socket;
    VAR received_message: ^nlt$udp_received_message);

   IF (global_socket^.status <> nlc$udp_global_socket_closed) AND
         (global_socket^.status <> nlc$udp_global_socket_term) THEN
     IF global_socket^.available_message_pool_size < (nlc$udp_max_pool_size) *
           UPPERBOUND (global_socket^.device_list) THEN
       received_message^.next_entry := global_socket^.available_message_pool;
       global_socket^.available_message_pool := received_message;
       global_socket^.available_message_pool_size := global_socket^.available_message_pool_size + 1;
     ELSE { max pool size
       FREE received_message IN nav$network_paged_heap^;
     IFEND;
   ELSE { global_socket closed or terminated
     FREE received_message IN nav$network_paged_heap^;
   IFEND;
   received_message := NIL;

 PROCEND return_received_message_entry;
?? OLDTITLE ??
?? NEWTITLE := 'return_receiver_task_entry', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to return the given receiver
{ task entry. It is either added to the pool of receiver task
{ entries or is freed via the heap manager FREE call.

 PROCEDURE [INLINE] return_receiver_task_entry
   (VAR global_socket: ^nlt$udp_global_socket;
    VAR receiver_task: ^nlt$udp_receiver_task);

   VAR
     pool_entry: ^nlt$udp_receiver_task,
     pool_size: integer;

   IF (global_socket^.status <> nlc$udp_global_socket_closed) AND
         (global_socket^.status <> nlc$udp_global_socket_term) THEN
     receiver_task^.next_entry := NIL;
     IF global_socket^.available_receiver_pool = NIL THEN
       global_socket^.available_receiver_pool := receiver_task;
     ELSE { calculate the queue size
       pool_size := 1;
       pool_entry := global_socket^.available_receiver_pool;
       WHILE pool_entry^.next_entry <> NIL DO
         pool_entry := pool_entry^.next_entry;
         pool_size := pool_size + 1;
       WHILEND;
       IF pool_size < nlc$udp_max_pool_size THEN
         pool_entry^.next_entry := receiver_task;
       ELSE
         FREE receiver_task IN nav$network_paged_heap^;
       IFEND;
     IFEND;
     receiver_task := NIL;
   ELSE { global socket closed or terminated
     FREE receiver_task IN nav$network_paged_heap^;
   IFEND;

 PROCEND return_receiver_task_entry;
?? OLDTITLE ??
?? NEWTITLE := 'return_sender_task_entry', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to return the given sender
{ task entry. It is either added to the pool of sender task
{ entries or is freed via the heap manager FREE call.

 PROCEDURE [INLINE] return_sender_task_entry
   (VAR udp_connection: ^nlt$udp_socket_layer;
    VAR sender_task: ^nlt$udp_sender_task);

   VAR
     pool_entry: ^nlt$udp_sender_task,
     pool_size: integer;

   IF udp_connection^.state <> nlc$udp_conn_closed THEN
     sender_task^.next_entry := NIL;
     IF udp_connection^.available_sender_pool = NIL THEN
       udp_connection^.available_sender_pool := sender_task;
     ELSE { calculate the queue size
       pool_size := 1;
       pool_entry := udp_connection^.available_sender_pool;
       WHILE pool_entry^.next_entry <> NIL DO
         pool_entry := pool_entry^.next_entry;
         pool_size := pool_size + 1;
       WHILEND;
       IF pool_size < nlc$udp_max_pool_size THEN
         pool_entry^.next_entry := sender_task;
       ELSE
         FREE sender_task IN nav$network_paged_heap^;
       IFEND;
     IFEND;
     sender_task := NIL;
   ELSE { udp_connection^.state = nlc$udp_conn_closed
     FREE sender_task IN nav$network_paged_heap^;
   IFEND;

 PROCEND return_sender_task_entry;
?? OLDTITLE ??
?? NEWTITLE := 'scan_connections_for_data', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to access the specified connections,
{ update the inventory and to pull up any data that may have been queued
{ on it.

 PROCEDURE scan_connections_for_data
   (    socket_inventory: ^nlt$udp_socket_inventory;
        receiver_task: ^nlt$udp_receiver_task);


   VAR
     cl_connection: ^nlt$cl_connection,
     connection_exists: boolean,
     device_id: nlt$device_identifier,
     i: integer,
     layer_active: boolean,
     udp_connection: ^nlt$udp_socket_layer;

   IF receiver_task^.received_data_length^ > 0 THEN

{ Receive has been initiated as a result of scanning the global socket.

     FOR device_id := 1 TO UPPERBOUND (socket_inventory^) DO
       IF socket_inventory^ [device_id].buffers_freed > 0 THEN

{ It is assumed that buffers must have been freed in order to initiate receive.

         nlp$cl_get_exclusive_via_cid (socket_inventory^ [device_id].connection_id, connection_exists,
               cl_connection);
         IF cl_connection <> NIL THEN
           nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, layer_active, udp_connection);
           IF (layer_active) AND (udp_connection^.state = nlc$udp_conn_open) THEN
             udp_connection^.inventory_report := udp_connection^.inventory_report -
                   socket_inventory^ [device_id].buffers_freed;
             nlp$cc_report_undelivered_data (cl_connection, udp_connection^.inventory_report);
             IF socket_inventory^ [device_id].connection_id = receiver_task^.connection_id THEN

{ This is the receiving connection.

               nlp$cc_receive_data (cl_connection);
             IFEND;
           IFEND;
           nlp$cl_release_exclusive_access (cl_connection);
         IFEND;
       IFEND;
     FOREND;
   ELSE { received_data_length = 0

{ Receive has not been initiated on scanning the global socket.

     FOR device_id := 1 TO UPPERBOUND (socket_inventory^) DO
       IF socket_inventory^ [device_id].connection_id <> nac$null_connection_id THEN
         nlp$cl_get_exclusive_via_cid (socket_inventory^ [device_id].connection_id, connection_exists,
               cl_connection);
         IF cl_connection <> NIL THEN
           nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, layer_active, udp_connection);
           IF (layer_active) AND ((udp_connection^.state = nlc$udp_conn_open) OR
                 (udp_connection^.state = nlc$udp_conn_await_confirm)) THEN
             IF socket_inventory^ [device_id].buffers_freed > 0 THEN
               udp_connection^.inventory_report := udp_connection^.inventory_report -
                     socket_inventory^ [device_id].buffers_freed;
               nlp$cc_report_undelivered_data (cl_connection, udp_connection^.inventory_report);
             IFEND;

{ The following code must be executed only if receive has not been initiated on any
{ connection.

             IF (NOT receiver_task^.activity_status^.complete) AND
                   (receiver_task^.received_data_length^ = 0) THEN
               nlp$cc_receive_data (cl_connection);
             IFEND;
           IFEND;
           nlp$cl_release_exclusive_access (cl_connection);
         IFEND;
       IFEND;
     FOREND;
   IFEND;

 PROCEND scan_connections_for_data;
?? OLDTITLE ??
?? NEWTITLE := 'scan_global_socket_for_data', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to scan the UDP devices
{ in the global socket for complete or partial messages. If a
{ complete message is found and the selection criteria is met,
{ the messages is moved to the user's buffer and the receive
{ is marked as complete. If the selection criteria is not met
{ the message is discarded. If a partial message is dicarded,
{ a discard data flag is set on the device entry so that the
{ remaining fragments for the message can be discarded. The flag
{ is cleared when the last fragment is received for the message.
{ If a partial message is found it is also moved to the user's
{ buffer and the receive is marked as incomplete. It is the
{ caller's responsibility to queue the receiver task on the
{ device entry.
{   If the user's buffer is not large enough to hold the message
{ (complete or partial) the message is discarded and an abnormal
{ status is returned to the caller. The discard data flag is set
{ if the partial message is discarded

 PROCEDURE scan_global_socket_for_data
   (VAR global_socket: ^nlt$udp_global_socket;
    VAR receive_buffer: nat$data_fragments;
    VAR remaining_buffer_length { input, output } : integer;
    VAR received_data_length: integer;
        selection_criteria: nat$sk_socket_address;
    VAR foreign_socket: nat$sk_socket_address;
    VAR local_ip_address: nat$sk_ip_address;
    VAR socket_inventory: nlt$udp_socket_inventory;
    VAR receiving_device_id: nlt$device_identifier;
    VAR activity_status: ost$activity_status);

?? NEWTITLE := 'terminate_scan', EJECT ??

   PROCEDURE terminate_scan
     (    condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

     CASE condition.selector OF
     = pmc$system_conditions, mmc$segment_access_condition =
       activity_status.complete := TRUE;
       IF received_message <> NIL THEN
         IF NOT received_message^.end_of_message THEN
           socket_device_list^ [device_id].discard_data := TRUE;
         IFEND;
         socket_device_list^ [device_id].received_messages := received_message^.next_entry;
         osp$set_status_from_condition (nac$status_id, condition, sa, activity_status.status,
               condition_status);
         condition_status.normal := TRUE;
         return_received_message_entry (global_socket, received_message);
       IFEND;

       EXIT scan_global_socket_for_data;
     = pmc$user_defined_condition =
       IF condition.user_condition_name = 'osc$job_recovery' THEN
         pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
       IFEND;
       condition_status.normal := TRUE;
     ELSE
       condition_status.normal := TRUE;
     CASEND;

   PROCEND terminate_scan;
?? OLDTITLE ??
?? EJECT ??

   VAR
     buffers_freed: nat$data_length,
     device_id: nlt$device_identifier,
     received_message: ^nlt$udp_received_message,
     socket_device_list: ^nlt$udp_socket_device_list;

   activity_status.complete := FALSE;
   activity_status.status.normal := TRUE;
   received_data_length := 0;
   received_message := NIL;
   #SPOIL (received_message);

{ Search for a complete message. Start from next to the last device data was
{ received over.

   socket_device_list := ^global_socket^.device_list;
   #SPOIL (socket_device_list);
   FOR device_id := 1 TO UPPERBOUND (socket_inventory) DO
     socket_inventory [device_id].buffers_freed := 0;
     socket_inventory [device_id].connection_id := nac$null_connection_id;
   FOREND;
   device_id := global_socket^.last_receiving_device;
   osp$establish_condition_handler (^terminate_scan, FALSE);

 /examine_complete_messages/
   REPEAT
     IF device_id < UPPERBOUND (socket_device_list^) THEN
       device_id := device_id + 1;
     ELSE
       device_id := 1;
     IFEND;
     #SPOIL (device_id);
     IF (socket_device_list^ [device_id].status = nlc$udp_device_open) OR
           (socket_device_list^ [device_id].status = nlc$udp_device_await_confirm) THEN
       socket_inventory [device_id].connection_id := socket_device_list^ [device_id].connection_id;
     IFEND;

     IF (socket_device_list^ [device_id].receiver_task = NIL) AND
           (socket_device_list^ [device_id].received_messages <> NIL) THEN
       received_message := socket_device_list^ [device_id].received_messages;
       #SPOIL (received_message);
       WHILE (received_message <> NIL) AND (received_message^.end_of_message) DO

{ Verify selection criteria.

         IF ((selection_criteria.ip_address = 0) OR (selection_criteria.ip_address =
               received_message^.source_socket.ip_address)) AND
               ((selection_criteria.port = 0) OR (selection_criteria.port =
               received_message^.source_socket.port)) THEN
           IF received_message^.data_length <= remaining_buffer_length THEN
             nlp$bm_deliver_message (receive_buffer, received_message^.data, received_data_length,
                   buffers_freed);
             remaining_buffer_length := remaining_buffer_length - received_data_length;
             socket_inventory [device_id].buffers_freed := socket_inventory [device_id].buffers_freed +
                   buffers_freed;
             global_socket^.last_receiving_device := device_id;
             foreign_socket := received_message^.source_socket;
             local_ip_address := received_message^.destination_ip_address;
             receiving_device_id := device_id;
           ELSE { buffer length too small

{ Discard the complete message.

             nlp$bm_release_message (received_message^.data);
             socket_inventory [device_id].buffers_freed := socket_inventory [device_id].buffers_freed +
                   received_message^.buffer_count;
             osp$set_status_condition (nae$sk_data_area_too_small, activity_status.status);
             osp$append_status_integer (osc$status_parameter_delimiter, global_socket^.local_socket_id, 10,
                   TRUE, activity_status.status);
           IFEND;

{ Dequeue the received message.

           activity_status.complete := TRUE;
           socket_device_list^ [device_id].received_messages := received_message^.next_entry;
           return_received_message_entry (global_socket, received_message);
           EXIT /examine_complete_messages/;
         ELSE { selection criteria not met

{ Discard received message.

           nlp$bm_release_message (received_message^.data);
           socket_inventory [device_id].buffers_freed := socket_inventory [device_id].buffers_freed +
                 received_message^.buffer_count;
           socket_device_list^ [device_id].received_messages := received_message^.next_entry;
           return_received_message_entry (global_socket, received_message);
           received_message := socket_device_list^ [device_id].received_messages;
           #SPOIL (received_message);
         IFEND;
       WHILEND
     IFEND;
   UNTIL device_id = global_socket^.last_receiving_device;

   IF NOT activity_status.complete THEN

{ Make a second pass over the devices to see if there is a partial message available.

     device_id := global_socket^.last_receiving_device;

   /examine_partial_messages/
     REPEAT
       IF device_id < UPPERBOUND (socket_device_list^) THEN
         device_id := device_id + 1;
       ELSE
         device_id := 1;
       IFEND;
       #SPOIL (device_id);

{ There shouldn't be any partial messages queued on a device that is down.

       IF socket_device_list^ [device_id].status = nlc$udp_device_open THEN
         IF (socket_device_list^ [device_id].receiver_task = NIL) AND
               (socket_device_list^ [device_id].received_messages <> NIL) THEN
           received_message := socket_device_list^ [device_id].received_messages;
           #SPOIL (received_message);
           IF ((selection_criteria.ip_address = 0) OR (selection_criteria.ip_address =
                 received_message^.source_socket.ip_address)) AND
                 ((selection_criteria.port = 0) OR (selection_criteria.port =
                 received_message^.source_socket.port)) THEN
             IF received_message^.data_length < remaining_buffer_length THEN
               nlp$bm_deliver_message (receive_buffer, received_message^.data, received_data_length,
                     buffers_freed);
               remaining_buffer_length := remaining_buffer_length - received_data_length;
               socket_inventory [device_id].buffers_freed := socket_inventory [device_id].buffers_freed +
                     buffers_freed;
               receiving_device_id := device_id;
               global_socket^.last_receiving_device := device_id;
               foreign_socket := received_message^.source_socket;
               local_ip_address := received_message^.destination_ip_address;
             ELSE { buffer area too small

{ Discard the partial message.

               nlp$bm_release_message (received_message^.data);
               socket_inventory [device_id].buffers_freed := socket_inventory [device_id].buffers_freed +
                     received_message^.buffer_count;
               osp$set_status_condition (nae$sk_data_area_too_small, activity_status.status);
               osp$append_status_integer (osc$status_parameter_delimiter, global_socket^.local_socket_id, 10,
                     TRUE, activity_status.status);
               socket_device_list^ [device_id].discard_data := TRUE;
               activity_status.complete := TRUE;
             IFEND;

{ Dequeue the received message.

             socket_device_list^ [device_id].received_messages := received_message^.next_entry;
             return_received_message_entry (global_socket, received_message);
             EXIT /examine_partial_messages/;
           ELSE { selection criteria not met

{ Discard the partial message.

             nlp$bm_release_message (received_message^.data);
             socket_inventory [device_id].buffers_freed := socket_inventory [device_id].buffers_freed +
                   received_message^.buffer_count;

{ Dequeue partial received message. Note that only one partial message can be queued
{ on the socket device.

             socket_device_list^ [device_id].received_messages := received_message^.next_entry;
             return_received_message_entry (global_socket, received_message);
             socket_device_list^ [device_id].discard_data := TRUE;
           IFEND;
         IFEND;
       IFEND;
     UNTIL device_id = global_socket^.last_receiving_device;
   IFEND;

 PROCEND scan_global_socket_for_data;
?? OLDTITLE ??
?? NEWTITLE := 'send_data', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to fragment and send data
{ over the given channel connection. IF the interface mode is
{ non blocking, all data is pushed to the channel connection
{ interface event if there is no outbound capacity. It is
{ assumed that this procedure will be called only if there is
{ outbound capacity to begin with.
{   It is assumed that on entry, the first data fragment points
{ to the protocol header and the current lowerbound is the index
{ of the next user data fragment to be sent. If all data is not
{ sent, on output, the new lowerbound will point to the first
{ fragment in the remaining data.

 PROCEDURE send_data
   (    cl_connection: ^nlt$cl_connection;
        initial_capacity: nat$data_length;
        initial_send: boolean;
    VAR data_fragments: nat$data_fragments;
        data_length: integer;
        interface_mode: nat$sk_interface_mode;
        starting_fragment: nat$data_fragment_count;
    VAR remaining_fragment: nat$data_fragment_count;
    VAR remaining_data_length: integer);

?? NEWTITLE := 'terminate_internal_send', EJECT ??

   PROCEDURE terminate_internal_send
     (    condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

     CASE condition.selector OF
     = pmc$system_conditions, mmc$segment_access_condition =
       IF (NOT initial_send) OR (remaining_data_length < data_length) THEN
         abort_send (cl_connection);
       IFEND;
       pmp$continue_to_cause (pmc$inhibit_standard_procedure, condition_status);
       remaining_data_length := 0;
       condition_status.normal := TRUE;
       EXIT send_data;

     = pmc$user_defined_condition =
       IF condition.user_condition_name = 'osc$job_recovery' THEN
         pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
       IFEND;
       condition_status.normal := TRUE;

     ELSE

{ Note: Interactive condition is being ignored.

       condition_status.normal := TRUE;
     CASEND;

   PROCEND terminate_internal_send;
?? OLDTITLE, EJECT ??

   VAR
     actual_fragment_size: integer,
     capacity: nat$data_length,
     current_lowerbound: nat$data_fragment_count,
     fragment: ^nat$data_fragments,
     fragment_size: integer,
     ignore_status: ost$status,
     new_lowerbound: nat$data_fragment_count,
     udpaa_data_header: ^nlt$udpaa_data_request;


   capacity := initial_capacity;
   udpaa_data_header := data_fragments [1].address;
   osp$establish_condition_handler (^terminate_internal_send, FALSE);
   IF capacity >= data_length THEN
     udpaa_data_header^.header.length := data_length + #SIZE (udpaa_data_header^);
     udpaa_data_header^.end_of_message := TRUE;
     nlp$cc_send_data_fragments (cl_connection, data_fragments, ignore_status);
     remaining_data_length := 0;
   ELSE { Insufficient outbound capacity
     current_lowerbound := starting_fragment;
     remaining_data_length := data_length;
     #SPOIL (remaining_data_length);
     new_lowerbound := current_lowerbound;
     PUSH fragment: [1 .. UPPERBOUND (data_fragments)];
     REPEAT

{ Move the protocol header such that it is the first fragment in the
{ next data block to be sent.

       IF new_lowerbound > 2 THEN
         current_lowerbound := new_lowerbound - 1;

{ Initialize the previous entry to point to the TCPAA pdu header.

         data_fragments [current_lowerbound] := data_fragments [1];
       IFEND;
       IF remaining_data_length > capacity THEN
         fragment_size := capacity;
       ELSE
         fragment_size := remaining_data_length;
         udpaa_data_header^.end_of_message := TRUE;
       IFEND;

{ The actual fragment must include the protocol header.

       actual_fragment_size := fragment_size + #SIZE (udpaa_data_header^);
       nlp$sk_fragment_data (actual_fragment_size, current_lowerbound, data_fragments, new_lowerbound,
             fragment^);

{ Reset the length of the PDU header fragment.

       data_fragments [1].length := #SIZE (udpaa_data_header^);
       udpaa_data_header^.header.length := actual_fragment_size;
       nlp$cc_send_data_fragments (cl_connection, fragment^, ignore_status);
       remaining_data_length := remaining_data_length - fragment_size;
       #SPOIL (remaining_data_length);
       IF remaining_data_length > 0 THEN
         nlp$osi_get_outbound_capacity (cl_connection, capacity);

{ If the interface mode is non blocking push all the data to the channel connection
{ interface.

         IF (capacity = 0) AND (interface_mode = nac$sk_non_blocking_mode) THEN
           capacity := initial_capacity;
         IFEND;
       IFEND;
     UNTIL (remaining_data_length = 0) OR (capacity = 0);
   IFEND;
   remaining_fragment := new_lowerbound;

 PROCEND send_data;
?? OLDTITLE ??
?? NEWTITLE := 'update_inventory', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to update the inventory
{ report on the active connections for a socket.

 PROCEDURE update_inventory
   (    socket_inventory: ^nlt$udp_socket_inventory);

   VAR
     cl_connection: ^nlt$cl_connection,
     connection_exists: boolean,
     device_id: nlt$device_identifier,
     layer_active: boolean,
     udp_connection: ^nlt$udp_socket_layer;

   FOR device_id := 1 TO UPPERBOUND (socket_inventory^) DO
     IF (socket_inventory^ [device_id].connection_id <> nac$null_connection_id) AND
           (socket_inventory^ [device_id].buffers_freed > 0) THEN
       nlp$cl_get_exclusive_via_cid (socket_inventory^ [device_id].connection_id, connection_exists,
             cl_connection);
       IF cl_connection <> NIL THEN
         nlp$cl_get_layer_connection (nlc$udp_interface, cl_connection, layer_active, udp_connection);
         IF layer_active THEN
           udp_connection^.inventory_report := udp_connection^.inventory_report -
                 socket_inventory^ [device_id].buffers_freed;
           nlp$cc_report_undelivered_data (cl_connection, udp_connection^.inventory_report);
         IFEND;
         nlp$cl_release_exclusive_access (cl_connection);
       IFEND;
     IFEND;
   FOREND;

 PROCEND update_inventory;
?? OLDTITLE ??
 MODEND nlm$udp_access_agent;
*DECK DECK=NLM$UDP_GLOBAL_SOCKET_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: UDP Global Socket Manager' ??
?? NEWTITLE := 'Global Declarations Referenced by This Module' ??
MODULE nlm$udp_global_socket_manager;

{ PURPOSE:
{   The prime purpose of this module is to isolate the knowledge of the structures required
{   to access a specific global_socket.  Secondarily, the module contains service procedures to
{   support the global_socket.
{ DESIGN:
{   This module is designed to reside on the  OSF$JOB_TEMPLATE_23D library.
{   The module contains a procedure to create a global socket, to delete a specific global socket,
{   to acquire exclusive access to a specific global socket, and to release exclusive access to a
{   specific global socket.

?? PUSH (LISTEXT := ON) ??
*copyc nlc$nam_configuration_constants
*copyc nlc$udp_max_pool_size
*copyc nlt$udp_global_sockets
*copyc nlt$udp_received_message
*copyc nlt$udp_receiver_task
?? POP ??
*copyc nlp$udp_allocate_receiver
*copyc nlp$udp_deallocate_receiver
*copyc nlp$udp_free_exclusive_access
*copyc osp$clear_job_signature_lock
*copyc osp$initialize_signature_lock
*copyc osp$set_job_signature_lock
*copyc osp$test_signature_lock
*copyc oss$mainframe_paged_literal
*copyc oss$network_paged
*copyc osp$begin_subsystem_activity
*copyc osp$end_subsystem_activity
*copyc syp$cycle
*copyc nav$network_paged_heap
*copyc nlv$configured_network_devices
*copyc nlv$maximum_system_connections
*copyc nlv$udp_active_global_sockets
*copyc nlv$udp_global_sockets

  CONST
    successful = 0,
    failed = 1,
    locked = 2;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_clear_exclusive_access', EJECT ??
*copy nlh$udp_clear_exclusive_access

  PROCEDURE [XDCL] nlp$udp_clear_exclusive_access
    (VAR global_socket {INPUT, OUTPUT} : ^nlt$udp_global_socket);

    VAR
      ignore_status: ost$status,
      lock_status: ost$signature_lock_status;

    IF global_socket <> NIL THEN
      osp$test_signature_lock (global_socket^.lock, lock_status, ignore_status);
      IF lock_status = osc$sls_locked_by_current_task THEN
        osp$clear_job_signature_lock (global_socket^.lock);
        osp$end_subsystem_activity;
      IFEND;
      global_socket := NIL;
    IFEND;
  PROCEND nlp$udp_clear_exclusive_access;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_create_global_socket', EJECT ??
*copy nlh$udp_create_global_socket

  PROCEDURE [XDCL] nlp$udp_create_global_socket
    (VAR global_socket: ^nlt$udp_global_socket);

?? NEWTITLE := 'initialize_global_socket_list' ??

    PROCEDURE initialize_global_socket_list;

      VAR
        actual_lock: string (8),
        global_sockets: ^array [0 .. * ] of nlt$udp_global_socket_root,
        initial_lock: string (8),
        new_lock: string (8),
        null_global_socket_root: [READ, oss$mainframe_paged_literal] nlt$udp_global_socket_root :=
              [[0, FALSE, 0], NIL],
        number_of_entries: integer,
        result: successful .. locked,
        root: nlt$udp_reference_number;

      initial_lock := nlc$udp_global_sockets_unlocked;
      new_lock := nlc$udp_global_sockets_locked;
      osp$begin_subsystem_activity;
      REPEAT
        #COMPARE_SWAP (nlv$udp_global_sockets_control.lock, initial_lock, new_lock, actual_lock, result);
        IF (result = failed) THEN
          osp$end_subsystem_activity;
          syp$cycle;
          osp$begin_subsystem_activity;
        IFEND;
      UNTIL (result = successful);

      IF (nlv$udp_global_sockets.list = NIL) THEN
        number_of_entries := nlc$base_connection_array_size;
        WHILE (number_of_entries * 4) < nlv$maximum_system_connections DO
          number_of_entries := number_of_entries * 2;
        WHILEND;
        ALLOCATE global_sockets: [0 .. (number_of_entries - 1)] IN nav$network_paged_heap^;
        IF (nlv$udp_global_sockets.socket_seed = 0) THEN
          nlv$udp_global_sockets.socket_seed := (#FREE_RUNNING_CLOCK (0) MOD
                (UPPERVALUE (nlt$udp_reference_number) + 1));
        IFEND;
        FOR root := 0 TO (number_of_entries - 1) DO
          global_sockets^ [root] := null_global_socket_root;
        FOREND;
        nlv$udp_global_sockets.list := global_sockets;
      IFEND;

      initial_lock := nlc$udp_global_sockets_locked;
      new_lock := nlc$udp_global_sockets_unlocked;
      REPEAT
        #COMPARE_SWAP (nlv$udp_global_sockets_control.lock, initial_lock, new_lock, actual_lock, result);
      UNTIL (result = successful);
      osp$end_subsystem_activity;
    PROCEND initialize_global_socket_list;
?? OLDTITLE ??
?? NEWTITLE := 'assign_global_socket_identifier' ??
?? NEWTITLE := '[INLINE] get_global_socket_id', EJECT ??

    PROCEDURE assign_global_socket_identifier
      (    global_socket: ^nlt$udp_global_socket;
       VAR socket_id_assigned: boolean;
       VAR global_socket_id: nlt$udp_global_socket_id);


      PROCEDURE [INLINE] get_global_socket_id
        (VAR global_socket_id: nlt$udp_global_socket_id);

        VAR
          initial_seed: integer,
          new_seed: integer,
          result: successful .. locked;

        initial_seed := 0;
        new_seed := 1;
        REPEAT
          #COMPARE_SWAP (nlv$udp_global_sockets.socket_seed, initial_seed, new_seed, initial_seed, result);
          CASE result OF
          = successful =
            global_socket_id.sequence := (new_seed DIV (UPPERVALUE (nlt$udp_reference_number) + 1));
            global_socket_id.reference_number := (new_seed MOD (UPPERVALUE (nlt$udp_reference_number) + 1));
          = failed =
            IF (((initial_seed + 1) MOD (UPPERVALUE (nlt$udp_reference_number) + 1)) > 0) THEN
              new_seed := initial_seed + 1;
            ELSE
              new_seed := initial_seed + 2;
            IFEND;
          = locked =
            ;
          CASEND;
        UNTIL (result = successful);
      PROCEND get_global_socket_id;
?? OLDTITLE, EJECT ??

      VAR
        actual_active: integer,
        first_global_socket: ^nlt$udp_global_socket,
        new_active: integer,
        number_of_roots: nlt$udp_global_sckts_per_system,
        result: successful .. locked,
        root: nlt$udp_reference_number,
        stem: ^nlt$udp_global_socket,
        stem_length: nlt$udp_reference_number;

      number_of_roots := UPPERBOUND (nlv$udp_global_sockets.list^) + 1;
      global_socket^.next_entry := NIL;
      socket_id_assigned := FALSE;

      actual_active := 0;
      new_active := 1;

    /assign_id/
      WHILE (NOT socket_id_assigned AND (actual_active < nlv$maximum_system_connections)) DO
        #COMPARE_SWAP (nlv$udp_global_sockets.active, actual_active, new_active, actual_active, result);
        CASE result OF
        = successful =
          nlv$udp_active_global_sockets := new_active;

        /assign_global_socket/
          REPEAT
            get_global_socket_id (global_socket_id);
            root := (global_socket_id.reference_number MOD number_of_roots);
            get_exclusive_to_root (root);
            first_global_socket := nlv$udp_global_sockets.list^ [root].first;

            IF (first_global_socket = NIL) THEN
              { Place global_socket at root. }
              nlv$udp_global_sockets.list^ [root].first := global_socket;
              release_exclusive_to_root (root);
              socket_id_assigned := TRUE;
            ELSE
              stem := first_global_socket;
              stem_length := 1;

            /add_global_socket_to_stem/
              REPEAT
                IF (stem^.identifier.reference_number <> global_socket_id.reference_number) THEN
                  IF (stem^.next_entry = NIL) THEN
                    IF (stem_length < ((actual_active DIV number_of_roots) + 1)) THEN
                      stem^.next_entry := global_socket;
                      release_exclusive_to_root (root);
                      socket_id_assigned := TRUE;
                    ELSE
                      release_exclusive_to_root (root);
                      CYCLE /assign_global_socket/;
                    IFEND;
                  ELSE
                    stem_length := stem_length + 1;
                    stem := stem^.next_entry;
                  IFEND;
                ELSE
                  release_exclusive_to_root (root);
                  CYCLE /assign_global_socket/;
                IFEND;
              UNTIL socket_id_assigned {add_global_socket_to_stem};
            IFEND;
          UNTIL socket_id_assigned {assign_global_socket};

        = failed =
          new_active := actual_active + 1;

        = locked =
          ;
        CASEND;
      WHILEND /assign_id/;

    PROCEND assign_global_socket_identifier;
?? OLDTITLE, EJECT ??

    VAR
      ignore_status: ost$status,
      received_message: ^nlt$udp_received_message,
      receiver_task: ^nlt$udp_receiver_task,
      socket: ^nlt$udp_global_socket,
      socket_id_assigned: boolean;

    IF (nlv$udp_global_sockets.list = NIL) THEN
      initialize_global_socket_list;
    IFEND;

    ALLOCATE socket: [1 .. UPPERBOUND (nlv$configured_network_devices.network_device_list^)] IN
          nav$network_paged_heap^;
    IF socket <> NIL THEN
      socket^.next_entry := NIL;
      osp$initialize_signature_lock (socket^.lock, ignore_status);

{ Initialize the available receiver pool.

      REPEAT
        ALLOCATE receiver_task IN nav$network_paged_heap^;
        IF receiver_task = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL receiver_task <> NIL;
      socket^.available_receiver_pool := receiver_task;
      receiver_task^.next_entry := NIL;

{ Initialize the available message pool.

      socket^.available_message_pool_size := 1;
      REPEAT
        ALLOCATE received_message IN nav$network_paged_heap^;
        IF received_message = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL received_message <> NIL;
      socket^.available_message_pool := received_message;
      received_message^.next_entry := NIL;

{ Allocate active receiver.

      nlp$udp_allocate_receiver (socket^.active_receiver);

{ Remaining fields are initialized by the socket layer code.

      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (socket^.lock);
      assign_global_socket_identifier (socket, socket_id_assigned, socket^.identifier);
      IF NOT socket_id_assigned THEN
        FREE socket^.available_receiver_pool IN nav$network_paged_heap^;
        FREE socket^.available_message_pool IN nav$network_paged_heap^;
        nlp$udp_deallocate_receiver (socket^.active_receiver);
        FREE socket IN nav$network_paged_heap^;
        osp$end_subsystem_activity;
      IFEND;
    IFEND;

    global_socket := socket;

  PROCEND nlp$udp_create_global_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_delete_global_socket', EJECT ??
*copy nlh$udp_delete_global_socket

  PROCEDURE [XDCL] nlp$udp_delete_global_socket
    (    global_socket_id: nlt$udp_global_socket_id);

    VAR
      global_socket: ^^nlt$udp_global_socket,
      global_socket_to_free: ^nlt$udp_global_socket,
      initial_active: integer,
      new_active: integer,
      next_received_message: ^nlt$udp_received_message,
      next_receiver_task: ^nlt$udp_receiver_task,
      received_message: ^nlt$udp_received_message,
      receiver_task: ^nlt$udp_receiver_task,
      result: successful .. locked,
      root: nlt$udp_reference_number;

    root := (global_socket_id.reference_number MOD (UPPERBOUND (nlv$udp_global_sockets.list^) + 1));
    get_exclusive_to_root (root);
    global_socket := ^nlv$udp_global_sockets.list^ [root].first;

    WHILE (global_socket^ <> NIL) AND (global_socket^^.identifier <> global_socket_id) DO
      global_socket := ^global_socket^^.next_entry;
    WHILEND;
    IF global_socket^ <> NIL THEN
      osp$set_job_signature_lock (global_socket^^.lock);
      global_socket_to_free := global_socket^;
      global_socket^ := global_socket^^.next_entry;
      release_exclusive_to_root (root);

{ Free the allocated structures associated with the global socket.

      receiver_task := global_Socket_to_free^.available_receiver_pool;
      WHILE receiver_task <> NIL DO
        next_receiver_task := receiver_task^.next_entry;
        FREE receiver_task IN nav$network_paged_heap^;
        receiver_task := next_receiver_task;
      WHILEND;

      received_message := global_Socket_to_free^.available_message_pool;
      WHILE received_message <> NIL DO
        next_received_message := received_message^.next_entry;
        FREE received_message IN nav$network_paged_heap^;
        received_message := next_received_message;
      WHILEND;

{ Free the active receiver.

      nlp$udp_deallocate_receiver (global_socket_to_free^.active_receiver);
      FREE global_socket_to_free IN nav$network_paged_heap^;

      initial_active := 1;
      new_active := 0;

    /decrement_active_global_sockets/
      REPEAT
        #COMPARE_SWAP (nlv$udp_global_sockets.active, initial_active, new_active, initial_active, result);
        IF (result = failed) THEN
          new_active := initial_active - 1;
        IFEND;
      UNTIL (result = successful);
      nlv$udp_active_global_sockets := new_active;
    ELSE { global_socket = NIL
      release_exclusive_to_root (root);
    IFEND;
  PROCEND nlp$udp_delete_global_socket;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_free_nonexclu_to_root', EJECT ??
*copy nlh$udp_free_nonexclu_to_root

  PROCEDURE [XDCL] nlp$udp_free_nonexclu_to_root
    (    root: nlt$udp_reference_number);
    release_nonexclusive_to_root (root);
  PROCEND nlp$udp_free_nonexclu_to_root;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_get_nonexclu_to_root', EJECT ??
*copy nlh$udp_get_nonexclu_to_root

  PROCEDURE [XDCL] nlp$udp_get_nonexclu_to_root
    (    root: nlt$udp_reference_number);
    get_nonexclusive_to_root (root);
  PROCEND nlp$udp_get_nonexclu_to_root;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$udp_get_exclusive_via_gsid', EJECT ??
*copy nlh$udp_get_exclusive_via_gsid

  PROCEDURE [XDCL] nlp$udp_get_exclusive_via_gsid
    (    global_socket_id: nlt$udp_global_socket_id;
     VAR global_socket: ^nlt$udp_global_socket);

    VAR
      root: nlt$udp_reference_number,
      socket: ^nlt$udp_global_socket;

    IF nlv$udp_global_sockets.list <> NIL THEN
      root := (global_socket_id.reference_number MOD (UPPERBOUND (nlv$udp_global_sockets.list^) + 1));
      get_nonexclusive_to_root (root);
      socket := nlv$udp_global_sockets.list^ [root].first;

    /search_stem/
      WHILE (socket <> NIL) AND (socket^.identifier.reference_number <> global_socket_id.reference_number) DO
        socket := socket^.next_entry;
      WHILEND /search_stem/;
      IF socket <> NIL THEN
        osp$begin_subsystem_activity;
        osp$set_job_signature_lock (socket^.lock);
      IFEND;
      global_socket := socket;
      release_nonexclusive_to_root (root);
    ELSE
      global_socket := NIL;
    IFEND;
  PROCEND nlp$udp_get_exclusive_via_gsid;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_exclusive_to_root', EJECT ??

  PROCEDURE [INLINE] get_exclusive_to_root
    (    root: nlt$udp_reference_number);

    VAR
      actual_root: nlt$udp_global_sckt_root_access,
      initial_root: nlt$udp_global_sckt_root_access,
      new_root: nlt$udp_global_sckt_root_access,
      result: successful .. locked;

    initial_root.nonexclusive_accessors := 0;
    initial_root.exclusive := FALSE;
    initial_root.fill := 0;
    new_root := initial_root;
    new_root.exclusive := TRUE;

    osp$begin_subsystem_activity;
    REPEAT
      #COMPARE_SWAP (nlv$udp_global_sockets.list^ [root].access_control, initial_root, new_root, actual_root,
            result);
      IF (result = failed) THEN
        osp$end_subsystem_activity;
        syp$cycle;
        osp$begin_subsystem_activity;
      IFEND;
    UNTIL (result = successful);
  PROCEND get_exclusive_to_root;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_nonexclusive_to_root', EJECT ??

  PROCEDURE [INLINE] get_nonexclusive_to_root
    (    root: nlt$udp_reference_number);

    VAR
      initial_root: nlt$udp_global_sckt_root_access,
      new_root: nlt$udp_global_sckt_root_access,
      result: successful .. locked;

    initial_root.nonexclusive_accessors := 0;
    initial_root.exclusive := FALSE;
    initial_root.fill := 0;
    new_root := initial_root;
    new_root.nonexclusive_accessors := 1;

    REPEAT
      #COMPARE_SWAP (nlv$udp_global_sockets.list^ [root].access_control, initial_root, new_root, initial_root,
            result);
      IF (result = failed) THEN
        IF initial_root.exclusive THEN
          syp$cycle;
          initial_root.exclusive := FALSE;
        IFEND;
        new_root.nonexclusive_accessors := initial_root.nonexclusive_accessors + 1;
      IFEND;
    UNTIL (result = successful);
  PROCEND get_nonexclusive_to_root;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] release_exclusive_to_root', EJECT ??

  PROCEDURE [INLINE] release_exclusive_to_root
    (    root: nlt$udp_reference_number);

    VAR
      actual_root: nlt$udp_global_sckt_root_access,
      initial_root: nlt$udp_global_sckt_root_access,
      new_root: nlt$udp_global_sckt_root_access,
      result: successful .. locked;

    initial_root.nonexclusive_accessors := 0;
    initial_root.exclusive := TRUE;
    initial_root.fill := 0;
    new_root := initial_root;
    new_root.exclusive := FALSE;

    REPEAT
      #COMPARE_SWAP (nlv$udp_global_sockets.list^ [root].access_control, initial_root, new_root, actual_root,
            result);
    UNTIL (result = successful);
    osp$end_subsystem_activity;
  PROCEND release_exclusive_to_root;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] release_nonexclusive_to_root', EJECT ??

  PROCEDURE [INLINE] release_nonexclusive_to_root
    (    root: nlt$udp_reference_number);

    VAR
      initial_root: nlt$udp_global_sckt_root_access,
      new_root: nlt$udp_global_sckt_root_access,
      result: successful .. locked;

    initial_root.nonexclusive_accessors := 1;
    initial_root.exclusive := FALSE;
    initial_root.fill := 0;
    new_root := initial_root;
    new_root.nonexclusive_accessors := 0;

  /release_root/
    REPEAT
      #COMPARE_SWAP (nlv$udp_global_sockets.list^ [root].access_control, initial_root, new_root, initial_root,
            result);
      IF (result = failed) THEN
        new_root.nonexclusive_accessors := initial_root.nonexclusive_accessors - 1;
      IFEND;
    UNTIL (result = successful);
  PROCEND release_nonexclusive_to_root;
?? OLDTITLE ??
MODEND nlm$udp_global_socket_manager;
*DECK DECK=NLM$UDP_SERVICE_ROUTINES_R1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Network Access: UDP Service Routines Ring 1' ??
MODULE nlm$udp_service_routines_r1;

{ PURPOSE:
{   This module contains service routines that execute in Ring 1 and are called
{   by the UDP Access Agent.
{ DESIGN:
{   These procedures update fields in tables that can be written from ring 1 only.
{   It contains procedures to activate and deactivate receiver for a UDP socket.
{   This module contains code that executes in ring 1. It resides on OSF$SYSTEM_CORE_113.
{
{ NOTES:
{   The following abbreviations have been used in this module:
{          UDP - User Datagram Protocol

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nlt$udp_active_receiver
*copyc ost$signature_lock_status
?? POP ??
*copyc pmp$get_executing_task_gtid
*copyc syp$cycle
*copyc osv$mainframe_wired_heap

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$udp_activate_receiver', EJECT ??
*copy nlh$udp_activate_receiver

  PROCEDURE [XDCL, #GATE] nlp$udp_activate_receiver
    (    active_receiver: ^nlt$udp_active_receiver;
     VAR another_receiver_active: boolean);

    VAR
      active_receiver_ring1: ^nlt$udp_active_receiver,
      actual_active_receiver: nlt$udp_active_receiver,
      current_task_id: ost$global_task_id,
      initial_active_receiver: nlt$udp_active_receiver,
      new_active_receiver: nlt$udp_active_receiver,
      result: osc$cs_successful .. osc$cs_variable_locked;

    another_receiver_active := FALSE;
    pmp$get_executing_task_gtid (current_task_id);
    active_receiver_ring1 := #ADDRESS (1, #segment (active_receiver), #offset (active_receiver));

    initial_active_receiver.task_id.index := 0;
    initial_active_receiver.task_id.seqno := 0;
    initial_active_receiver.fill := 0;
    new_active_receiver.task_id := current_task_id;
    new_active_receiver.fill := 0;
    REPEAT
      #COMPARE_SWAP (active_receiver_ring1^, initial_active_receiver, new_active_receiver,
        actual_active_receiver, result);
      IF result = osc$cs_failed THEN
        another_receiver_active := TRUE;
      IFEND;
    UNTIL result <> osc$cs_variable_locked;

  PROCEND nlp$udp_activate_receiver;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$udp_allocate_receiver', EJECT ??
*copy nlh$udp_allocate_receiver

  PROCEDURE [XDCL, #GATE] nlp$udp_allocate_receiver
    (VAR  active_receiver: ^nlt$udp_active_receiver);

    VAR
      active_receiver_ring1: ^nlt$udp_active_receiver;

    REPEAT
      ALLOCATE active_receiver_ring1 IN osv$mainframe_wired_heap^;
      IF active_receiver_ring1 = NIL THEN
        syp$cycle;
      IFEND;
    UNTIL active_receiver_ring1 <> NIL;
    active_receiver_ring1^.task_id.index := 0;
    active_receiver_ring1^.task_id.seqno := 0;
    active_receiver_ring1^.fill := 0;
    active_receiver := active_receiver_ring1;

  PROCEND nlp$udp_allocate_receiver;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$udp_deactivate_receiver', EJECT ??
*copy nlh$udp_deactivate_receiver

  PROCEDURE [XDCL, #GATE] nlp$udp_deactivate_receiver
    (    active_receiver: ^nlt$udp_active_receiver);

    VAR
      active_receiver_ring1: ^nlt$udp_active_receiver,
      actual_active_receiver: nlt$udp_active_receiver,
      initial_active_receiver: nlt$udp_active_receiver,
      new_active_receiver: nlt$udp_active_receiver,
      result: osc$cs_successful .. osc$cs_variable_locked;

    active_receiver_ring1 := #ADDRESS (1, #SEGMENT(active_receiver), #OFFSET(active_receiver));
    pmp$get_executing_task_gtid (initial_active_receiver.task_id);
    initial_active_receiver.fill := 0;
    new_active_receiver.task_id.index := 0;
    new_active_receiver.task_id.seqno := 0;
    new_active_receiver.fill := 0;
    REPEAT
      #COMPARE_SWAP (active_receiver_ring1^, initial_active_receiver, new_active_receiver,
        actual_active_receiver, result);
    UNTIL result = osc$cs_successful;

  PROCEND nlp$udp_deactivate_receiver;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$udp_deallocate_receiver', EJECT ??
*copy nlh$udp_deallocate_receiver

  PROCEDURE [XDCL, #GATE] nlp$udp_deallocate_receiver
    (VAR  active_receiver: ^nlt$udp_active_receiver);

    VAR
      active_receiver_ring1: ^nlt$udp_active_receiver;

    active_receiver_ring1 := #ADDRESS (1, #segment (active_receiver), #offset (active_receiver));
    FREE active_receiver_ring1 IN osv$mainframe_wired_heap^;

  PROCEND nlp$udp_deallocate_receiver;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] nlp$udp_store_receiver', EJECT ??
*copy nlh$udp_store_receiver

  PROCEDURE [XDCL, #GATE] nlp$udp_store_receiver
    (    active_receiver: ^nlt$udp_active_receiver;
         cl_connection: ^nlt$cl_connection);

    VAR
      active_receiver_ring1: ^nlt$udp_active_receiver,
      cl_connection_ring1: ^nlt$cl_connection;

    active_receiver_ring1 := #ADDRESS (1, #SEGMENT(active_receiver), #OFFSET(active_receiver));
    cl_connection_ring1 := #ADDRESS (1, #SEGMENT(cl_connection), #OFFSET(cl_connection));
    cl_connection_ring1^.active_receiver := active_receiver_ring1;

  PROCEND nlp$udp_store_receiver;
?? OLDTITLE ??
  MODEND nlm$udp_service_routines_r1;
*DECK DECK=NLP$ACCEPT_SWITCH_OFFER EXPAND=FALSE
  PROCEDURE [XREF] nlp$accept_switch_offer (file: fst$file_reference;
        source: jmt$system_supplied_name;
        attributes: ^nat$create_attributes;
        timesharing_connection_switch: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jmt$system_supplied_name
*copyc nat$create_attributes
*copyc ost$status
?? POP ??
*DECK DECK=NLP$ACQUIRE_CONNECTION EXPAND=FALSE
  PROCEDURE [XREF] nlp$acquire_connection (server: nat$application_name;
        file: fst$file_reference;
        file_exists: boolean;
        attributes: ^nat$create_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc nat$application_name
*copyc nat$create_attributes
*copyc ost$status
?? POP ??
*DECK DECK=NLP$ACQUIRE_SPECIFIC_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nlp$acquire_specific_connection
    (    system_job_name: jmt$system_supplied_name;
         server: nat$application_name;
         file: fst$file_reference;
         file_exists: boolean;
         attributes: ^nat$create_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jmt$system_supplied_name
*copyc nat$application_name
*copyc nat$create_attributes
*copyc ost$status
?? POP ??
*DECK DECK=NLP$AL_DELIVER_DATA EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
*copyc nlt$al_data_description
*copyc nlt$bm_message_id
*copyc nlp$bm_deliver_message
?? POP ??

  PROCEDURE [INLINE] nlp$al_deliver_data (VAR message {INPUT, OUTPUT} : nlt$bm_message_id;
    VAR buffer_description {INPUT, OUTPUT} : nlt$al_data_description;
    VAR remaining_buffer_capacity: nat$data_length;
    VAR namve_buffers_released: nat$data_length);

?? PUSH (LISTEXT := ON) ??
*copy nlh$al_deliver_data

    VAR
      delivered_length: integer;

    nlp$bm_deliver_message (buffer_description.fragment, message, delivered_length, namve_buffers_released);
    buffer_description.data_length := buffer_description.data_length - delivered_length;
    remaining_buffer_capacity := buffer_description.data_length;
  PROCEND nlp$al_deliver_data;
?? POP ??
*DECK DECK=NLP$AL_FRAGMENT_DATA EXPAND=FALSE

  PROCEDURE [XREF] nlp$al_fragment_data
    (    fragment_size: nat$data_length;
     VAR data_description {INPUT, OUTPUT} : nlt$al_data_description;
     VAR remaining_data_length: nat$data_length;
     VAR message: nat$data_fragments);

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
*copyc nlt$al_data_description
?? POP ??
*DECK DECK=NLP$AL_GET_DATA_LENGTH EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
?? POP ??

  PROCEDURE [INLINE] nlp$al_get_data_length (data: nat$data_fragments;
    VAR data_length: nat$data_length);

?? PUSH (LISTEXT := ON) ??
*copy nlh$al_get_data_length

    VAR
      i: integer;

    data_length := 0;
    FOR i := LOWERBOUND (data) TO UPPERBOUND (data) DO
      IF ((data [i].length > 0) AND (data [i].address <> NIL)) THEN
        data_length := data_length + data [i].length;
      IFEND;
    FOREND;
  PROCEND nlp$al_get_data_length;
?? POP ??
*DECK DECK=NLP$AL_GET_DATA_REQUIREMENTS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
?? POP ??

  PROCEDURE [INLINE] nlp$al_get_data_requirements (data: nat$data_fragments;
    VAR data_length: integer;
    VAR description_upperbound: integer);
?? PUSH (LISTEXT := ON) ??
*copy nlh$al_get_data_requirements

    VAR
      i: integer;

    data_length := 0;
    description_upperbound := 0;
    FOR i := LOWERBOUND (data) TO UPPERBOUND (data) DO
      IF ((data [i].length > 0) AND (data [i].address <> NIL)) THEN
        data_length := data_length + data [i].length;
        description_upperbound := description_upperbound + 1;
      IFEND;
    FOREND;
  PROCEND nlp$al_get_data_requirements;
?? POP ??
*DECK DECK=NLP$AL_INITIALIZE_DATA_DESCRIP EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc nlt$al_data_description
?? POP ??

  PROCEDURE [INLINE] nlp$al_initialize_data_descrip (data: nat$data_fragments;
        data_length: nat$data_length;
    VAR data_description: nlt$al_data_description);
?? PUSH (LISTEXT := ON) ??
*copy nlh$al_initialize_data_descrip

    VAR
      i: integer,
      j: integer;

    data_description.data_length := data_length;
    data_description.current_lowerbound := 1;
    j := 0;
    FOR i := LOWERBOUND (data) TO UPPERBOUND (data) DO
      IF ((data [i].length > 0) AND (data [i].address <> NIL)) THEN
        j := j + 1;
        data_description.fragment [j] := data [i];
      IFEND;
    FOREND;
    FOR i := (j + 1) TO UPPERBOUND (data_description.fragment) DO
      data_description.fragment [i].length := 0;
    FOREND;
  PROCEND nlp$al_initialize_data_descrip;
?? POP ??
*DECK DECK=NLP$BM_ADD_MESSAGE_PREFIX EXPAND=FALSE

  PROCEDURE [XREF] nlp$bm_add_message_prefix
    (    prefix: ^cell;
         prefix_length: nat$data_length;
     VAR message_id { input, output } : nlt$bm_message_id);

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_length
*copyc nlt$bm_message_id
?? POP ??
*DECK DECK=NLP$BM_BUILD_PVA_LIST EXPAND=FALSE

  PROCEDURE [INLINE] nlp$bm_build_pva_list
    (    message_id: nlt$bm_message_id;
     VAR pva_list: ^nat$data_fragments);

?? PUSH (LISTEXT := ON) ??

    VAR
      descriptor: ^nlt$bm_message_descriptor,
      i: integer,
      number_of_messages: integer,
      ring: 1 .. 15,
      segment: 0 .. 0fff(16);

    descriptor := message_id.descriptor;
    number_of_messages := 0;

    REPEAT
      IF (descriptor^.container_length - descriptor^.data_start) > 0 THEN
        number_of_messages := number_of_messages + 1;
      IFEND;
      descriptor := descriptor^.link;
    UNTIL descriptor = NIL;

    PUSH pva_list: [1 .. number_of_messages];
    descriptor := message_id.descriptor;
    ring := #RING (descriptor^.container);
    segment := #SEGMENT (descriptor^.container);
    i := 1;
    REPEAT
      IF (descriptor^.container_length - descriptor^.data_start) > 0 THEN
        pva_list^ [i].length := descriptor^.container_length -
              descriptor^.data_start;
        pva_list^ [i].address := #ADDRESS (ring, segment, #OFFSET (descriptor^.container) +
              descriptor^.data_start);
        i := i + 1;
      IFEND;
      descriptor := descriptor^.link;
    UNTIL (i > number_of_messages);
  PROCEND nlp$bm_build_pva_list;

*copyc nlh$bm_build_pva_list

*copyc nat$data_fragments
*copyc nlt$bm_message_id
?? POP ??
*DECK DECK=NLP$BM_CONCATENATE_MESSAGES EXPAND=FALSE

  PROCEDURE [XREF] nlp$bm_concatenate_messages
    (    component_list { input, output } : array [1 .. * ] of nlt$bm_message_id;
     VAR message_id: nlt$bm_message_id);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_id
?? POP ??
*DECK DECK=NLP$BM_COPY_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] nlp$bm_copy_message
    (    from_message_id: nlt$bm_message_id;
     VAR to_message_id: nlt$bm_message_id);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_id
?? POP ??
*DECK DECK=NLP$BM_CREATE_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] nlp$bm_create_message
    (    data: nat$data_fragments;
     VAR message_id: nlt$bm_message_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
*copyc nlt$bm_message_id
*copyc ost$status
?? POP ??
*DECK DECK=NLP$BM_DELIVER_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] nlp$bm_deliver_message
    (VAR data_area { input, output } : nat$data_fragments;
     VAR message_id { input, output } : nlt$bm_message_id;
     VAR data_length: integer;
     VAR buffers_released: nat$data_length);

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
*copyc nlt$bm_message_id
?? POP ??
*DECK DECK=NLP$BM_EXTRACT_MESSAGE_PREFIX EXPAND=FALSE

  PROCEDURE [XREF] nlp$bm_extract_message_prefix
    (    prefix: ^cell;
         prefix_length: nat$data_length;
     VAR message_id { input, output } : nlt$bm_message_id;
     VAR bytes_moved: nat$data_length);

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_length
*copyc nlt$bm_message_id
?? POP ??
*DECK DECK=NLP$BM_FLUSH_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] nlp$bm_flush_message
    (    data_area: nat$data_fragments;
     VAR message_id: nlt$bm_message_id;
     VAR message_length: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$namve_conditions
*copyc nat$data_fragments
*copyc nlt$bm_message_id
*copyc ost$status
?? POP ??
*DECK DECK=NLP$BM_FREE_BUFFER_POOLS EXPAND=FALSE

  PROCEDURE [XREF] nlp$bm_free_buffer_pools;

*DECK DECK=NLP$BM_GET_BUFFER_LIST EXPAND=FALSE

  PROCEDURE [XREF] nlp$bm_get_buffer_list
    (VAR buffer_list { input, output } : nlt$bm_buffer_list_array;
     VAR buffers_acquired: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_buffer_list_array
?? POP ??
*DECK DECK=NLP$BM_GET_MESSAGE_CONTENTS EXPAND=FALSE

  PROCEDURE [INLINE] nlp$bm_get_message_contents
    (    received_message: ^nlt$bm_message_descriptor;
         number_of_bytes: nat$data_length;
     VAR contents: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??


    VAR
      length: nat$data_length;

    IF number_of_bytes <= (received_message^.container_length - received_message^.data_start) THEN
      length := number_of_bytes;
    ELSE
      length := received_message^.container_length - received_message^.data_start;
    IFEND;
    i#build_adaptable_seq_pointer (1, #SEGMENT (received_message^.container),
          #OFFSET (received_message^.container) + received_message^.data_start,
          length, 0, contents);
  PROCEND nlp$bm_get_message_contents;

*copyc nlh$bm_get_message_contents

*copyc nat$data_length
*copyc nlt$bm_message_descriptor
*copyc i#build_adaptable_seq_pointer
?? POP ??
*DECK DECK=NLP$BM_GET_MESSAGE_HEADER EXPAND=FALSE

  PROCEDURE [INLINE] nlp$bm_get_message_header
    (    message: nlt$bm_message_id;
         number_of_bytes: nat$data_length;
     VAR header: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??

    VAR
      length: nat$data_length;

    IF number_of_bytes <= (message.descriptor^.container_length - message.descriptor^.data_start) THEN
      length := number_of_bytes;
    ELSE
      length := message.descriptor^.container_length - message.descriptor^.data_start;
    IFEND;
    i#build_adaptable_seq_pointer (1, #SEGMENT (message.descriptor^.container),
          #OFFSET (message.descriptor^.container) + message.descriptor^.data_start, length,
          0, header);
  PROCEND nlp$bm_get_message_header;

*copyc nlh$bm_get_message_header

*copyc nat$data_length
*copyc nlt$bm_message_id
*copyc i#build_adaptable_seq_pointer
?? POP ??
*DECK DECK=NLP$BM_GET_MESSAGE_LENGTH EXPAND=FALSE

  PROCEDURE [INLINE] nlp$bm_get_message_length
    (    message_id: nlt$bm_message_id;
     VAR message_length: integer);

?? PUSH (LISTEXT := ON) ??

    VAR
      descriptor: ^nlt$bm_message_descriptor;

    message_length := 0;

    IF (message_id.descriptor <> NIL) AND
       (message_id.sequence_number = message_id.descriptor^.sequence_number) THEN
      descriptor := message_id.descriptor;
      REPEAT
        message_length := message_length + descriptor^.container_length -
              descriptor^.data_start;
        descriptor := descriptor^.link;
      UNTIL descriptor = NIL;
    ELSEIF message_id <> nlv$bm_null_message_id THEN { Invalid message_id.
      nap$namve_system_error (FALSE, nlv$bm_buffer_manager_caller, NIL);
    IFEND;
  PROCEND nlp$bm_get_message_length;

*copyc nlh$bm_get_message_length

*copyc nlt$bm_message_id
*copyc nap$namve_system_error
*copyc nlv$bm_buffer_manager_caller
*copyc nlv$bm_null_message_id
?? POP ??
*DECK DECK=NLP$BM_GET_MESSAGE_PREFIX EXPAND=FALSE

  PROCEDURE [XREF] nlp$bm_get_message_prefix
    (    prefix: ^cell;
         prefix_length: nat$data_length;
         message_id: nlt$bm_message_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$namve_conditions
*copyc nat$data_length
*copyc nlt$bm_message_id
*copyc ost$status
?? POP ??
*DECK DECK=NLP$BM_GET_MESSAGE_RESOURCES EXPAND=FALSE

  PROCEDURE [INLINE] nlp$bm_get_message_resources
    (    message_id: nlt$bm_message_id;
     VAR message_length: integer;
     VAR number_of_buffers: integer);

?? PUSH (LISTEXT := ON) ??

    VAR
      descriptor: ^nlt$bm_message_descriptor;

    IF nlp$bm_valid_message_id (message_id) THEN
      message_length := 0;
      number_of_buffers := 0;
      IF message_id <> nlv$bm_null_message_id THEN
        descriptor := message_id.descriptor;
        REPEAT
          message_length := message_length + descriptor^.container_length - descriptor^.data_start;
          number_of_buffers := number_of_buffers + 1;
          descriptor := descriptor^.link;
        UNTIL descriptor = NIL;
      IFEND;
    ELSE { Invalid message_id.
      nap$namve_system_error (FALSE, nlv$bm_buffer_manager_caller, NIL);
    IFEND;
  PROCEND nlp$bm_get_message_resources;

*copyc nlh$bm_get_message_resources

*copyc nlt$bm_message_id
*copyc nap$namve_system_error
*copyc nlp$bm_valid_message_id
*copyc nlv$bm_buffer_manager_caller
*copyc nlv$bm_null_message_id
?? POP ??
*DECK DECK=NLP$BM_INITIALIZE_BUFFER_POOLS EXPAND=FALSE

  PROCEDURE [XREF] nlp$bm_initialize_buffer_pools
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$initialization_interfaces
*copyc ost$status
?? POP ??
*DECK DECK=NLP$BM_RELEASE_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] nlp$bm_release_message
    (VAR message_id { input, output } : nlt$bm_message_id);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_id
?? POP ??
*DECK DECK=NLP$BM_RELEASE_MESSAGES EXPAND=FALSE

  PROCEDURE [XREF] nlp$bm_release_messages
    (VAR message_id { input, output } : array [1 .. * ] of nlt$bm_message_id);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_id
?? POP ??
*DECK DECK=NLP$BM_VALID_MESSAGE_ID EXPAND=FALSE

  FUNCTION [INLINE] nlp$bm_valid_message_id
    (    message_id: nlt$bm_message_id): boolean;

?? PUSH (LISTEXT := ON) ??

    IF (message_id.descriptor <> NIL) THEN
      nlp$bm_valid_message_id := (message_id.descriptor^.sequence_number = message_id.sequence_number);
    ELSE
      nlp$bm_valid_message_id := message_id = nlv$bm_null_message_id;
    IFEND;
  FUNCEND nlp$bm_valid_message_id;

*copyc nlh$bm_valid_message_id

*copyc nlt$bm_message_id
*copyc nlv$bm_null_message_id
?? POP ??
*DECK DECK=NLP$CANCEL_SWITCH_OFFER EXPAND=FALSE
  PROCEDURE [XREF] nlp$cancel_switch_offer (connection_id: nat$connection_id;
    VAR switch_complete: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc ost$status
?? POP ??
*DECK DECK=NLP$CANCEL_TIMER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc nlt$timer
?? POP ??

  PROCEDURE [INLINE] nlp$cancel_timer (VAR timer: nlt$timer);

?? PUSH (LISTEXT := ON) ??
*copy nlh$cancel_timer
    timer.selected := FALSE;
  PROCEND nlp$cancel_timer;
?? POP ??
*DECK DECK=NLP$CC_ABORT_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_abort_connection
    (    reason: nlt$cc_disconnect_reason;
         connection {INPUT, OUTPUT} : ^nlt$cc_connection;
         cl_connection {INPUT, OUTPUT} : ^nlt$cl_connection);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_connection
*copyc nlt$cc_disconnect_reason
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CC_ACCEPT_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_accept_connection
    (    cl_connection: ^nlt$cl_connection;
         connection_class: nlt$cc_connection_class;
         data: nlt$bm_message_id;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_id
*copyc nlt$cc_connection_class
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??
*DECK DECK=NLP$CC_DECR_CONNECTION_COUNT EXPAND=FALSE
  PROCEDURE [INLINE] nlp$cc_decr_connection_count (device_id: nlt$device_identifier);
?? PUSH (LISTEXT := ON) ??
{
{  PURPOSE:
{     The purpose of this request is to decrement the count of
{   active connections for the specified device.
{
{   NOTE: This request is intended for use solely by the Channel
{         Connection Entity.
{

    VAR
      actual_count: integer,
      new_count: integer,
      old_count: integer,
      result: osc$cs_successful .. osc$cs_variable_locked;

    old_count := 1;
    new_count := 0;
    REPEAT
      #compare_swap (nlv$sm_devices.list^ [device_id].active_connection_count,
             old_count, new_count, actual_count, result);
      IF result = osc$cs_failed THEN
        old_count := actual_count;
        new_count := old_count - 1;
      IFEND;
    UNTIL result = osc$cs_successful;

  PROCEND nlp$cc_decr_connection_count;

*copyc ost$signature_lock_status
*copyc nlv$sm_devices
?? POP ??

*DECK DECK=NLP$CC_DISCONNECT EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_disconnect
    (    cl_connection: ^nlt$cl_connection;
         data: nlt$bm_message_id;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_id
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??
*DECK DECK=NLP$CC_FIND_DUPLICATE_CONNECT EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_find_duplicate_connect
    (    device_id: nlt$device_identifier;
         peer_reference_number: nlt$cl_reference_number;
     VAR duplicate: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_reference_number
*copyc nlt$device_identifier
?? POP ??
*DECK DECK=NLP$CC_GET_DEVICE_SPECIFIC_ATTR EXPAND=FALSE

  PROCEDURE [INLINE] nlp$cc_get_device_specific_attr
    (    device_id: nlt$device_identifier;
         connection: ^nlt$cc_connection;
     VAR main_connection: boolean;
     VAR device_specific_attributes: ^nlt$cc_device_specific_attr);

?? PUSH (LISTEXT := ON) ??
*copy nlh$cc_get_device_specific_attr

      VAR
        i: integer;

      IF device_id = connection^.device_specific_attributes.device_id THEN
        main_connection := TRUE;
        device_specific_attributes := ^connection^.device_specific_attributes;
      ELSE
        main_connection := FALSE;
        i := 1;
        WHILE device_id <> connection^.sub_connections^ [i].device_id DO
          i := i + 1;
        WHILEND;
        device_specific_attributes := ^connection^.sub_connections^ [i];
      IFEND;

  PROCEND nlp$cc_get_device_specific_attr;

*copyc nlt$cc_connection
*copyc nlt$device_identifier
?? POP ??

*DECK DECK=NLP$CC_GET_EVENT_PROCESSOR EXPAND=FALSE

  PROCEDURE [INLINE] nlp$cc_get_event_processor
    (    cc_address: nlt$cc_address;
     VAR event_processor: nat$network_procedure);

?? PUSH (LISTEXT := ON) ??
*copy nlh$cc_get_event_processor

    CASE cc_address OF
    = nlc$network_access_address =
      event_processor := nlc$na_event_processor;

    = nlc$transport_access_address =
      event_processor := nlc$ta_event_processor;

    = nlc$link_access_address =
      event_processor := nlc$la_event_processor;

    = nlc$system_management_address =
      event_processor := nlc$sm_event_processor;

    = nlc$udp_access_address =
      event_processor := nlc$udp_event_processor;

    = nlc$tcp_access_address =
      event_processor := nlc$tcp_event_processor;

    = nlc$tcpip_management_address =
      event_processor := nlc$tm_event_processor;
    ELSE { Unknown address
      nap$namve_system_error (FALSE, 'Unknown CC address', NIL);
    CASEND;

  PROCEND nlp$cc_get_event_processor;

*copyc nat$network_procedure
*copyc nlt$cc_address
*copyc nap$namve_system_error
?? POP ??
*DECK DECK=NLP$CC_GET_EXCLUSIVE_VIA_CID EXPAND=FALSE

  PROCEDURE [INLINE] nlp$cc_get_exclusive_via_cid
    (    connection_id: nlt$cl_connection_id;
         system_input_task: boolean;
     VAR connection_exists: boolean;
     VAR access_gained: boolean;
     VAR connection: ^nlt$cc_connection;
     VAR cl_connection: ^nlt$cl_connection);

?? PUSH (LISTEXT := ON) ??

    VAR
      layer_active: boolean;

    nlp$cl_get_exclusive_access (connection_id, system_input_task,
          connection_exists, access_gained, cl_connection);
    IF (connection_exists AND access_gained) THEN
      nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, layer_active, connection);
      IF NOT layer_active THEN
        nlp$cl_release_exclusive_access (cl_connection);
        connection_exists := FALSE;
        access_gained := FALSE;
      IFEND;
    IFEND;
  PROCEND nlp$cc_get_exclusive_via_cid;

*copy nlh$cc_get_exclusive_via_cid
*copyc nlt$cc_connection
*copyc nlt$cl_connection
*copyc nlp$cl_get_exclusive_access
*copyc nlp$cl_get_layer_connection
*copyc nlp$cl_release_exclusive_access
?? POP ??
*DECK DECK=NLP$CC_GET_EXCLUS_TO_UNACCEPTED EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_get_exclus_to_unaccepted
    (    peer_reference_number: nlt$cl_reference_number;
         device_id: nlt$device_identifier;
         system_input_task: boolean;
     VAR connection_exists: boolean;
     VAR access_gained: boolean;
     VAR connection: ^nlt$cc_connection;
     VAR cl_connection: ^nlt$cl_connection);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_connection
*copyc nlt$cl_connection
*copyc nlt$cl_reference_number
*copyc nlt$device_identifier
?? POP ??
*DECK DECK=NLP$CC_GET_RECEIVED_MESSAGES EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_get_received_messages
    (cl_connection: {input, output} ^nlt$cl_connection;
     VAR received_messages: ^nlt$bm_message_descriptor);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_descriptor
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CC_GRANT_CREDITS EXPAND=FALSE

  PROCEDURE [INLINE] nlp$cc_grant_credits
    (    connection { input, output } : ^nlt$cc_connection);

?? PUSH (LISTEXT := ON) ??
*copy nlh$cc_grant_credits

    VAR
      actual: integer,
      cc_header: nlt$cc_protocol_header,
      cc_pdu: nlt$bm_message_id,
      data_fragments: array [1 .. 1] of nat$data_fragment,
      ignore_status: ost$status;

    cc_header.credit_allocation.credits_granted := nlp$cc_obtain_credits (connection);
    IF cc_header.credit_allocation.credits_granted > 0 THEN
      connection^.receive_credits := connection^.receive_credits + cc_header.credit_allocation.
            credits_granted;
      cc_header.kind := nlc$cc_credit_allocation;
      cc_header.length := #SIZE (nlt$cc_protocol_header);
      cc_header.credit_allocation.destination_reference := connection^.peer_reference_number;
      cc_header.credit_allocation.class := nlc$cc_priority_class;
      data_fragments [1].address := ^cc_header;
      data_fragments [1].length := #SIZE (nlt$cc_protocol_header);
      nlp$bm_create_message (data_fragments, cc_pdu, ignore_status);
      nlp$cc_send_pdu (connection^.device_specific_attributes.device_id, nlc$cc_priority_class, cc_pdu);

{! statistics begin}

      IF nav$statistics_enabled THEN
        osp$increment_locked_variable (nav$global_osi_statistics.
              channel_connection_device^[connection^.device_specific_attributes.device_id].
              credit_pdus_sent, 0, actual);
      IFEND;

{! statistics end}

    IFEND;

  PROCEND nlp$cc_grant_credits;

*copyc nat$data_fragments
*copyc nlt$bm_message_id
*copyc nlt$cc_protocol_data_unit
*copyc ost$status
*copyc nlp$bm_create_message
*copyc nlp$cc_obtain_credits
*copyc nlp$cc_send_pdu
*copyc osp$increment_locked_variable
*copyc nav$global_osi_statistics
*copyc nav$statistics_enabled
?? POP ??
*DECK DECK=NLP$CC_INCR_CONNECTION_COUNT EXPAND=TRUE
  PROCEDURE [INLINE] nlp$cc_incr_connection_count (device_id: nlt$device_identifier);
?? PUSH (LISTEXT := ON) ??
{
{  PURPOSE:
{     The purpose of this request is to increment the count of
{   active connections for the specified device.
{
{   NOTE: This request is intended for use solely by the Channel
{         Connection Entity.
{

    VAR
      actual_count: integer,
      new_count: integer,
      old_count: integer,
      result: osc$cs_successful .. osc$cs_variable_locked;

    old_count := 0;
    new_count := 1;
    REPEAT
      #compare_swap (nlv$sm_devices.list^ [device_id].active_connection_count,
             old_count, new_count, actual_count, result);
      IF result = osc$cs_failed THEN
        old_count := actual_count;
        new_count := old_count + 1;
      IFEND;
    UNTIL result = osc$cs_successful;

  PROCEND nlp$cc_incr_connection_count;

*copyc ost$signature_lock_status
*copyc nlv$sm_devices
?? POP ??

*DECK DECK=NLP$CC_INITIALIZE_TEMPLATE EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_initialize_template
    (    application_layer: nlt$cl_application_layer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_layer_name
?? POP ??
*DECK DECK=NLP$CC_MONITOR_TIMERS EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_monitor_timers
    (    current_time: integer;
         cl_connection: ^nlt$cl_connection);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??

*DECK DECK=NLP$CC_OBTAIN_CREDITS EXPAND=FALSE

  FUNCTION [INLINE] nlp$cc_obtain_credits
    (    connection: ^nlt$cc_connection): nlt$cc_credits;
?? PUSH (LISTEXT := ON) ??
*copy nlh$cc_obtain_credits

{ This function will return the number of additional credits to be assigned to
{ the specified connection. If no additional credits can be assigned and no
{ credits are outstanding, then a one minute timer will be selected to "wake up"
{ the connection. If credits are available a credit allocation PDU will be sent
{ to the peer process; if credits are still unavailable the timer will be reset.

    CONST
      sixty_seconds = 60000000; { Time in microseconds.

    VAR
      allocated_buffer_threshold: integer,
      available_buffers: integer,
      connection_limit: integer,
      credits: nlt$cc_credits,
      system_limit: integer;

    credits := 0;
    connection_limit := (nlv$cc_maximum_receive_window - connection^.accumulated_message_buffers);
    IF connection_limit > connection^.receive_credits THEN
      allocated_buffer_threshold := nlv$bm_allocat_buffer_threshold;
      available_buffers := nlv$bm_buffer_pool [nlc$bm_large_buffer_index].count +
            (allocated_buffer_threshold - nlv$bm_buffer_pool [nlc$bm_large_buffer_index].dynamic_buffers);

{ One buffer is reserved for each priority connection.
{ Note: Active connections include both normal and priority connections.

      IF connection^.class = nlc$cc_normal_class THEN
        available_buffers := available_buffers - nlv$cl_priority_connect_count;
      IFEND;

{ If at least half of the allowed buffers are available, no system limit will be imposed.

      IF available_buffers > (allocated_buffer_threshold DIV 2) THEN
        credits := connection_limit;
      ELSE

{ When the number of available network buffers becomes less than the number reserved for priority
{ connections the normal flow control window is closed.
{ If buffers are available, reserve some based on number of active connections to allow for
{ over commitment. Ensure that at least one credit is available of buffers are available.

        IF available_buffers >= connection^.buffers_per_credit THEN
          system_limit := ((available_buffers - (nlp$cl_active_connections () DIV 2)) DIV
                connection^.buffers_per_credit);
          IF system_limit <= 0 THEN
            system_limit := 1;
          IFEND;
          IF (connection_limit > system_limit) THEN
            credits := system_limit;
          ELSE
            credits := connection_limit;
          IFEND;
        IFEND;
      IFEND;
      IF credits > connection^.receive_credits THEN
        credits := credits - connection^.receive_credits;
      ELSE
        credits := 0;
        IF connection^.receive_credits = 0 THEN
          nlp$select_timer (sixty_seconds, 0, connection^.no_buffers_for_peer_credit);
        IFEND;
      IFEND;
    IFEND;
    nlp$cc_obtain_credits := credits;
  FUNCEND nlp$cc_obtain_credits;

*copyc nlc$bm_buffer_pool_index
*copyc nlv$cc_maximum_receive_window
*copyc nlt$bm_buffer_count
*copyc nlt$cc_connection
*copyc nlt$cc_credits
*copyc nlp$cl_active_connections
*copyc nlp$select_timer
*copyc nlv$bm_allocat_buffer_threshold
*copyc nlv$bm_buffer_pool
*copyc nlv$cl_priority_connect_count
?? POP ??
*DECK DECK=NLP$CC_RECEIVE_DATA EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_receive_data
    (    cl_connection: ^nlt$cl_connection);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CC_RECEIVE_EVENT EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_receive_event
    (VAR cc_pdu {input, output} : nlt$bm_message_id);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_id
?? POP ??
*DECK DECK=NLP$CC_REPORT_UNDELIVERED_DATA EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_report_undelivered_data
    (    cl_connection: ^nlt$cl_connection;
         accumulated_message_buffers: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CC_REQUEST_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_request_connection
    (    cl_connection: ^nlt$cl_connection;
         device_and_data_list: nlt$cc_device_and_data_list;
         destination_address: nlt$cc_address;
         connection_class: nlt$cc_connection_class;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_id
*copyc nlt$cc_address
*copyc nlt$cc_connection_class
*copyc nlt$cc_device_and_data_list
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??
*DECK DECK=NLP$CC_REQUEUE_MSGS_ON_CONN EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_requeue_msgs_on_conn
    (    cl_connection: ^nlt$cl_connection;
         received_messages: ^nlt$bm_message_descriptor);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_descriptor
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CC_RESET_DEVICE EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_reset_device (device_id: nlt$device_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$device_identifier
?? POP ??
*DECK DECK=NLP$CC_SEND_AGGREGATE_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_send_aggregate_message
    (    cl_connection: ^nlt$cl_connection;
         message: nlt$cc_aggregate_message;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_aggregate_message
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??
*DECK DECK=NLP$CC_SEND_BUFFER_EMPTY EXPAND=FALSE

  FUNCTION [INLINE] nlp$cc_send_buffer_empty
    (    connection: ^nlt$cc_connection): boolean;

?? PUSH (LISTEXT := ON) ??
*copy nlh$cc_send_buffer_empty

    nlp$cc_send_buffer_empty := (connection^.send_buffer.out = connection^.send_buffer.inn);

  FUNCEND nlp$cc_send_buffer_empty;

*copyc nlt$cc_connection
?? POP ??
*DECK DECK=NLP$CC_SEND_DATA EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_send_data
    (    cl_connection: ^nlt$cl_connection;
         data: nlt$bm_message_id;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_id
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??
*DECK DECK=NLP$CC_SEND_DATA_FRAGMENTS EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_send_data_fragments
    (    cl_connection: ^nlt$cl_connection;
         data: nat$data_fragments;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??
*DECK DECK=NLP$CC_SEND_EXPEDITED_DATA EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_send_expedited_data
    (    cl_connection: ^nlt$cl_connection;
         data: nlt$bm_message_id;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_id
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??
*DECK DECK=NLP$CC_SEND_PDU EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_send_pdu
    (    device_id: nlt$device_identifier;
         class: nlt$cc_connection_class;
     VAR cc_pdu: nlt$bm_message_id);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_id
*copyc nlt$cc_connection_class
*copyc nlt$device_identifier
?? POP ??
*DECK DECK=NLP$CC_SHUT_DOWN_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_shut_down_connection
    (    connection { input, output } : ^nlt$cc_connection;
         cl_connection { input, output } : ^nlt$cl_connection;
         device_id : nlt$device_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_connection
*copyc nlt$cl_connection
*copyc nlt$device_identifier
?? POP ??
*DECK DECK=NLP$CC_TERMINATE_CONNECTIONS EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_terminate_connections (device_id: nlt$device_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$device_identifier
?? POP ??
*DECK DECK=NLP$CC_USER_DATA_PAD_SIZE EXPAND=FALSE

  FUNCTION [INLINE] nlp$cc_user_data_pad_size (data_length: nat$data_length): nlt$cc_user_data_pad_size;

?? PUSH (LISTEXT := ON) ??
{ PURPOSE:
{   This procedure calculates the number of pad bytes needed to align the CC header
{   on a word boundary. The algorithm assumes that the data length represents a block
{   of data where only the first word may not be completely filled (i.e., all words
{   in the block, except possibly the first, are full).
{

  VAR
    pad_bytes: nlt$cc_user_data_pad_size;

    pad_bytes := 8 - (data_length MOD 8);
    IF pad_bytes = 8 THEN
      pad_bytes := 0;
    IFEND;
    nlp$cc_user_data_pad_size := pad_bytes;

  FUNCEND nlp$cc_user_data_pad_size;

*copyc nat$data_length
*copyc nlt$cc_user_data_pad_size
?? POP ??
*DECK DECK=NLP$CC_WORK_LIST_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] nlp$cc_work_list_processor (flag_id: ost$system_flag);

?? PUSH (LISTEXT := ON) ??
*copyc ost$system_flag
?? POP ??
*DECK DECK=NLP$CL_ACTIVATE_LAYER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nlp$cl_activate_layer (layer: nlt$cl_layer_name;
        cl_connection: ^nlt$cl_connection);
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CL_ACTIVATE_RECEIVER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nlp$cl_activate_receiver (cl_connection: ^nlt$cl_connection);
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CL_ACTIVATE_SENDER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nlp$cl_activate_sender (cl_connection: ^nlt$cl_connection);
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CL_ACTIVE_CONNECTIONS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_reference_number
*copyc nlv$cl_active_connections
?? POP ??

  FUNCTION [INLINE] nlp$cl_active_connections: nlt$cl_reference_number;
?? PUSH (LISTEXT := ON) ??
*copy nlh$cl_active_connections

    nlp$cl_active_connections := nlv$cl_active_connections;
  FUNCEND nlp$cl_active_connections;
?? POP ??
*DECK DECK=NLP$CL_ADD_DEVICE_TO_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nlp$cl_add_device_to_connection
    (    device_id: nlt$device_identifier;
         cl_connection { input, output } : ^nlt$cl_connection);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nlt$device_identifier
?? POP ??
*DECK DECK=NLP$CL_ASSIGN_CONNECTION EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nlp$cl_assign_connection (application_layer: nlt$cl_application_layer;
        layer_connections: ^nlt$cl_layer_connections;
    VAR cl_connection: ^nlt$cl_connection);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CL_CLEAR_EXCLUSIVE_ACCESS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nlp$cl_clear_exclusive_access (VAR cl_connection {INPUT, OUTPUT} :
         ^nlt$cl_connection);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CL_CREATE_CONNECTION EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nlp$cl_create_connection (application_layer: nlt$cl_application_layer;
    VAR cl_connection: ^nlt$cl_connection);
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??

*DECK DECK=NLP$CL_DEACTIVATE_LAYER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nlp$cl_deactivate_layer (layer: nlt$cl_layer_name;
        cl_connection: ^nlt$cl_connection);
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CL_DEACTIVATE_RECEIVER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nlp$cl_deactivate_receiver (cl_connection: ^nlt$cl_connection);
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CL_DEACTIVATE_SENDER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nlp$cl_deactivate_sender (cl_connection: ^nlt$cl_connection);
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CL_DECR_PRIORITY_CONNECTION EXPAND=FALSE

  PROCEDURE [INLINE] nlp$cl_decr_priority_connection;
?? PUSH (LISTEXT := ON) ??
{
{  PURPOSE:
{     The purpose of this request is to decrement the count of
{   active priority connections.
{
{   NOTE: This request is intended for use solely by the Channel
{         Connection Entity.
{

    VAR
      actual_priority_count: integer,
      initial_priority_count: integer,
      new_priority_count: integer,
      result: osc$cs_successful .. osc$cs_variable_locked;

    initial_priority_count := 1;
    new_priority_count := 0;

    REPEAT
      #compare_swap (nlv$cl_priority_connections, initial_priority_count, new_priority_count,
             actual_priority_count, result);
      IF result = osc$cs_failed THEN
        initial_priority_count := actual_priority_count;
        new_priority_count := initial_priority_count - 1;
      IFEND;
    UNTIL result = osc$cs_successful;
    nlv$cl_priority_connect_count := new_priority_count;

  PROCEND nlp$cl_decr_priority_connection;

*copyc ost$signature_lock_status
*copyc nlv$cl_priority_connections
*copyc nlv$cl_priority_connect_count
?? POP ??

*DECK DECK=NLP$CL_GET_CONNECTION_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] nlp$cl_get_connection_access
    (    cl_connection { input, output } : ^nlt$cl_connection;
     VAR access_gained: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CL_GET_CONNECTION_PROCESSOR EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc nlv$cl_connection_layer_templat
?? POP ??

  PROCEDURE [INLINE] nlp$cl_get_connection_processor (application_layer: nlt$cl_application_layer;
        layer: nlt$cl_layer_name;
    VAR connection_processor: nlt$cl_event_processor);
?? PUSH (LISTEXT := ON) ??
*copy nlh$cl_get_connection_processor

    IF nlv$cl_connection_layer_templat [application_layer].path [layer] THEN
      connection_processor := nlv$cl_connection_layer_templat [application_layer].connection [layer].
            event_processor;
    ELSE
      connection_processor.layer := layer;
      CASE layer OF
      = nlc$xns_session_layer =
        connection_processor.se := nac$nil;
      = nlc$channel_connection_layer =
        connection_processor.cc := nac$nil;
      = nlc$osi_transport_access_agent =
        connection_processor.ta := nac$nil;
      = nlc$tcp_access_agent =
        connection_processor.tcpaa := nac$nil;
      ELSE
        ;
      CASEND;
    IFEND;
  PROCEND nlp$cl_get_connection_processor;
?? POP ??
*DECK DECK=NLP$CL_GET_CONNECTION_TASKS EXPAND=FALSE
?? TITLE := '  [INLINE] nlp$cl_get_connection_tasks', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??

  PROCEDURE [INLINE] nlp$cl_get_connection_tasks (reference_number: nlt$cl_reference_number;
    VAR connection_found: boolean;
    VAR receiver: nlt$cl_requestor;
    VAR sender: nlt$cl_requestor);
?? PUSH (LISTEXT := ON) ??
*copy nlh$cl_get_connection_tasks

    VAR
      root: nlt$cl_reference_number,
      result: osc$cs_successful .. osc$cs_variable_locked,
      initial_root,
      new_root,
      actual_root: nlt$cl_connection_root_access,
      connection: ^^nlt$cl_connection;

    connection_found := FALSE;
    IF (nlv$cl_connections.list <> NIL) THEN
      initial_root.nonexclusive_accessors := 0;
      initial_root.exclusive := FALSE;
      initial_root.fill := 0;
      new_root := initial_root;
      new_root.nonexclusive_accessors := 1;
      root := (reference_number MOD (UPPERBOUND (nlv$cl_connections.list^) + 1));

      REPEAT
        #compare_swap (nlv$cl_connections.list^ [root].access_control, initial_root, new_root, actual_root,
              result);
        IF (result = osc$cs_successful) THEN
          connection := ^nlv$cl_connections.list^ [root].first;
          WHILE (NOT connection_found AND (connection^ <> NIL)) DO
            IF (reference_number = connection^^.identifier.reference_number) THEN
              receiver := connection^^.message_receiver;
              sender := connection^^.message_sender;
              connection_found := TRUE;
            ELSE
              connection := ^connection^^.nextt;
            IFEND;
          WHILEND;

          initial_root := new_root;
          new_root.nonexclusive_accessors := new_root.nonexclusive_accessors - 1;

        /release_root/
          REPEAT
            #compare_swap (nlv$cl_connections.list^ [root].access_control, initial_root, new_root,
                  actual_root, result);
            IF (result = osc$cs_failed) THEN
              initial_root.nonexclusive_accessors := actual_root.nonexclusive_accessors;
              new_root.nonexclusive_accessors := initial_root.nonexclusive_accessors - 1;
            IFEND;
          UNTIL (result = osc$cs_successful);

        ELSEIF (result = osc$cs_failed) THEN
          IF NOT actual_root.exclusive THEN
            initial_root := actual_root;
            new_root := initial_root;
            new_root.nonexclusive_accessors := new_root.nonexclusive_accessors + 1;
          IFEND;
        IFEND;
      UNTIL ((result = osc$cs_successful) OR ((result = osc$cs_failed) AND actual_root.exclusive));
    IFEND;
  PROCEND nlp$cl_get_connection_tasks;
?? POP ??
*DECK DECK=NLP$CL_GET_CONN_TIMER_EVALUATOR EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc nlv$cl_connection_layer_templat
*copyc nav$network_procedures
?? POP ??

  PROCEDURE [INLINE] nlp$cl_get_conn_timer_evaluator (application_layer: nlt$cl_application_layer;
        layer: nlt$cl_layer_name;
    VAR connection_timer_evaluator: nlt$cl_evaluat_connection_timer);
?? PUSH (LISTEXT := ON) ??
*copy nlh$cl_get_conn_timer_evaluator

    IF nlv$cl_connection_layer_templat [application_layer].path [layer] THEN
      connection_timer_evaluator := nav$network_procedures [
          nlv$cl_connection_layer_templat [application_layer].connection [layer].
            timer_evaluator].cl_connection_timer;
    ELSE
      connection_timer_evaluator := NIL;
    IFEND;
  PROCEND nlp$cl_get_conn_timer_evaluator;
?? POP ??
*DECK DECK=NLP$CL_GET_EXCLUSIVE_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] nlp$cl_get_exclusive_access
    (connection_id: nlt$cl_connection_id;
         system_input_task: boolean;
     VAR connection_exists: boolean;
     VAR access_gained: boolean;
     VAR cl_connection: ^nlt$cl_connection);
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CL_GET_EXCLUSIVE_VIA_CID EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nlp$cl_get_exclusive_via_cid (connection_id: nlt$cl_connection_id;
    VAR connection_exists: boolean;
    VAR cl_connection: ^nlt$cl_connection);
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CL_GET_LAYER_CONNECTION EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nlv$cl_connection_layer_templat
?? POP ??

  PROCEDURE [INLINE] nlp$cl_get_layer_connection (layer: nlt$cl_layer_name;
        cl_connection: ^nlt$cl_connection;
    VAR layer_active: boolean;
    VAR connection: ^cell);

?? PUSH (LISTEXT := ON) ??
*copy nlh$cl_get_layer_connection

{   VAR
{     connections: ^nlt$cl_layer_connections,
{     layer_connection: ^array [1 .. * ] of cell;

{   connections := cl_connection^.layer_connections;
{   RESET connections;
{   NEXT layer_connection: [1 .. nlv$cl_connection_layer_templat [cl_connection^.application_layer].
{         connection [layer].description_offset] IN connections;
{   NEXT layer_connection: [1 .. nlv$cl_connection_layer_templat [cl_connection^.application_layer].
{         connection [layer].description_size] IN connections;
{   connection := layer_connection;

{   The #ADDRESS expression, which follows, is an optimization of the preceding commented statements. }

    connection := #ADDRESS (#RING (#LOC (cl_connection^.layer_connections^)), #SEGMENT (#LOC (cl_connection^.
          layer_connections^)), (#OFFSET (#LOC (cl_connection^.layer_connections^)) +
          nlv$cl_connection_layer_templat [cl_connection^.application_layer].connection [layer].
          description_offset));

    layer_active := (layer IN cl_connection^.layers_active);
  PROCEND nlp$cl_get_layer_connection;
?? POP ??

*DECK DECK=NLP$CL_GET_NONEXCLUSIVE_TO_ROOT EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nlp$cl_get_nonexclusive_to_root (root: nlt$cl_reference_number);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_reference_number
?? POP ??
*DECK DECK=NLP$CL_GET_SAP_PROCESSOR EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc nlv$cl_connection_layer_templat
?? POP ??

  PROCEDURE [INLINE] nlp$cl_get_sap_processor (application_layer: nlt$cl_application_layer;
        layer: nlt$cl_layer_name;
    VAR sap_processor: nlt$cl_event_processor);
?? PUSH (LISTEXT := ON) ??
*copy nlh$cl_get_sap_processor

    IF nlv$cl_connection_layer_templat [application_layer].path [layer] THEN
      sap_processor := nlv$cl_connection_layer_templat [application_layer].sap [layer].event_processor;
    ELSE
      sap_processor.layer := layer;
      CASE layer OF
      = nlc$xns_session_layer =
        sap_processor.se := nac$nil;
      = nlc$channel_connection_layer =
        sap_processor.cc := nac$nil;
      = nlc$osi_transport_access_agent =
        sap_processor.ta := nac$nil;
      = nlc$tcp_access_agent =
        sap_processor.tcpaa := nac$nil;
      ELSE
        ;
      CASEND;
    IFEND;
  PROCEND nlp$cl_get_sap_processor;
?? POP ??
*DECK DECK=NLP$CL_GET_SAP_TIMER_EVALUATOR EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc nlv$cl_connection_layer_templat
*copyc nav$network_procedures
?? POP ??

  PROCEDURE [INLINE] nlp$cl_get_sap_timer_evaluator (application_layer: nlt$cl_application_layer;
        layer: nlt$cl_layer_name;
    VAR sap_timer_evaluator: nlt$cl_evaluate_sap_timer);
?? PUSH (LISTEXT := ON) ??
*copy nlh$cl_get_sap_timer_evaluator

    IF nlv$cl_connection_layer_templat [application_layer].path [layer] THEN
      sap_timer_evaluator := nav$network_procedures [
          nlv$cl_connection_layer_templat [application_layer].sap [layer].timer_evaluator].
            cl_sap_timer;
    ELSE
      sap_timer_evaluator := NIL;
    IFEND;
  PROCEND nlp$cl_get_sap_timer_evaluator;
?? POP ??
*DECK DECK=NLP$CL_INCR_PRIORITY_CONNECTION EXPAND=FALSE

  PROCEDURE [INLINE] nlp$cl_incr_priority_connection;

?? PUSH (LISTEXT := ON) ??

{ PURPOSE:
{   The purpose of this request is to increment the count of
{   active priority connections.
{
{ NOTES: This request is intended for use solely by the Channel
{        Connection Entity.
{

    VAR
      actual_priority_count: integer,
      initial_priority_count: integer,
      new_priority_count: integer,
      result: osc$cs_successful .. osc$cs_variable_locked;

    initial_priority_count := 0;
    new_priority_count := 1;

    REPEAT
      #compare_swap (nlv$cl_priority_connections, initial_priority_count, new_priority_count,
             actual_priority_count, result);
      IF result = osc$cs_failed THEN
        initial_priority_count := actual_priority_count;
        new_priority_count := initial_priority_count + 1;
      IFEND;
    UNTIL result = osc$cs_successful;
    nlv$cl_priority_connect_count := new_priority_count;

  PROCEND nlp$cl_incr_priority_connection;

*copyc ost$signature_lock_status
*copyc nlv$cl_priority_connections
*copyc nlv$cl_priority_connect_count
?? POP ??
*DECK DECK=NLP$CL_INITIALIZE_TEMPLATE EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc nlv$cl_connection_layer_templat
?? POP ??

  PROCEDURE [INLINE] nlp$cl_initialize_template (application_layer: nlt$cl_application_layer;
        layer: nlt$cl_layer_name;
        layer_connection_size: nlt$cl_layer_connection_size;
        maximum_protocol_header_size: nat$data_length;
        sap_processor: nlt$cl_event_processor;
        sap_timer_evaluator: nat$network_procedure;
        connection_processor: nlt$cl_event_processor;
        connection_timer_evaluator: nat$network_procedure);
?? PUSH (LISTEXT := ON) ??
*copy nlh$cl_initialize_template

    CONST
      successful = 0,
      failed = 1,
      locked = 2;

    VAR
      l: nlt$cl_layer_name,
      result: successful .. locked,
      initial,
      new,
      actual: string (8);

    IF NOT nlv$cl_connection_layer_templat [application_layer].path [layer] THEN
      initial := nlc$cl_path_unlocked;
      new := nlc$cl_path_locked;
      REPEAT
        #compare_swap (nlv$cl_connection_layer_templat [application_layer].initialization_lock, initial,
              new, actual, result);
        IF (result = successful) THEN
          IF NOT nlv$cl_connection_layer_templat [application_layer].path [layer] THEN
            nlv$cl_connection_layer_templat [application_layer].sap [layer].event_processor.layer := layer;
            nlv$cl_connection_layer_templat [application_layer].connection [layer].event_processor.layer :=
                  layer;
            CASE layer OF
            = nlc$xns_session_layer =
              nlv$cl_connection_layer_templat [application_layer].sap [layer].event_processor.se :=
                    sap_processor.se;
              nlv$cl_connection_layer_templat [application_layer].connection [layer].event_processor.se :=
                    connection_processor.se;
            = nlc$channel_connection_layer =
              nlv$cl_connection_layer_templat [application_layer].sap [layer].event_processor.cc :=
                    sap_processor.cc;
              nlv$cl_connection_layer_templat [application_layer].connection [layer].event_processor.cc :=
                    connection_processor.cc;
            = nlc$osi_transport_access_agent =
              nlv$cl_connection_layer_templat [application_layer].sap [layer].event_processor.ta :=
                    sap_processor.ta;
              nlv$cl_connection_layer_templat [application_layer].connection [layer].event_processor.ta :=
                    connection_processor.ta;
            = nlc$tcp_access_agent =
              nlv$cl_connection_layer_templat [application_layer].sap [layer].event_processor.tcpaa :=
                    sap_processor.tcpaa;
              nlv$cl_connection_layer_templat [application_layer].connection [layer].event_processor.tcpaa :=
                    connection_processor.tcpaa;
            ELSE
              ;
            CASEND;
            nlv$cl_connection_layer_templat [application_layer].sap [layer].timer_evaluator :=
                  sap_timer_evaluator;
            nlv$cl_connection_layer_templat [application_layer].connection [layer].description_size :=
                  layer_connection_size;
            nlv$cl_connection_layer_templat [application_layer].connection [layer].
                  maximum_protocol_header_size := maximum_protocol_header_size;
            nlv$cl_connection_layer_templat [application_layer].path_header_size :=
                  nlv$cl_connection_layer_templat [application_layer].path_header_size +
                  maximum_protocol_header_size;
            nlv$cl_connection_layer_templat [application_layer].connection [layer].timer_evaluator :=
                  connection_timer_evaluator;
            nlv$cl_connection_layer_templat [application_layer].connection [layer].description_offset :=
                  #SIZE (nlt$cl_layer_name);
            IF (layer <> application_layer) THEN
              FOR l := application_layer TO PRED (layer) DO
                IF nlv$cl_connection_layer_templat [application_layer].path [l] THEN
                  nlv$cl_connection_layer_templat [application_layer].connection [layer].description_offset :=
                        nlv$cl_connection_layer_templat [application_layer].connection [layer].
                        description_offset + nlv$cl_connection_layer_templat [application_layer].connection
                        [l].description_size + #SIZE (nlt$cl_layer_name);
                IFEND;
              FOREND;
            IFEND;
            nlv$cl_connection_layer_templat [application_layer].path [layer] := TRUE;
          IFEND;
          initial := nlc$cl_path_locked;
          new := nlc$cl_path_unlocked;
          REPEAT
            #compare_swap (nlv$cl_connection_layer_templat [application_layer].initialization_lock, initial,
                  new, actual, result);
          UNTIL (result = successful);
        IFEND;
      UNTIL (result = successful);
    IFEND;
  PROCEND nlp$cl_initialize_template;
?? POP ??
*DECK DECK=NLP$CL_LAYER_ON_PATH EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc nlv$cl_connection_layer_templat
?? POP ??

  FUNCTION [INLINE] nlp$cl_layer_on_path (application_layer: nlt$cl_application_layer;
        layer: nlt$cl_layer_name): boolean;
?? PUSH (LISTEXT := ON) ??
*copy nlh$cl_layer_on_path

    nlp$cl_layer_on_path := nlv$cl_connection_layer_templat [application_layer].path [layer];
  FUNCEND nlp$cl_layer_on_path;
?? POP ??
*DECK DECK=NLP$CL_RECOVER_CID_SEED EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nlp$cl_recover_cid_seed;
*DECK DECK=NLP$CL_RELEASE_CONNECTION EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

    PROCEDURE [XREF] nlp$cl_release_connection (connection_id: nlt$cl_connection_id);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CL_RELEASE_EXCLUSIVE_ACCESS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nlp$cl_release_exclusive_access (VAR cl_connection {INPUT, OUTPUT} :
         ^nlt$cl_connection);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$CL_RELEASE_NONEXCLU_TO_ROOT EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  PROCEDURE [XREF] nlp$cl_release_nonexclu_to_root (root: nlt$cl_reference_number);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_reference_number
?? POP ??
*DECK DECK=NLP$CL_ZERO_TERMINATED_CONNECTS EXPAND=FALSE

  PROCEDURE [XREF] nlp$cl_zero_terminated_connects;
*DECK DECK=NLP$CN_CLOSE_SAP EXPAND=FALSE
 PROCEDURE [XREF] nlp$cn_close_sap (sap: nat$cn_sap_id;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$cn_interface
*copyc ost$status
?? POP ??
*DECK DECK=NLP$CN_OPEN_SAP EXPAND=FALSE
 PROCEDURE [XREF] nlp$cn_open_sap (sap: nat$cn_sap_id;
        event_processor: nat$network_procedure;
    VAR maximum_data_length: nat$data_length;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$cn_interface
*copyc nlt$cn_event_processor
*copyc nat$data_fragments
*copyc ost$status
*copyc nat$network_procedure
?? POP ??
*DECK DECK=NLP$CN_SEND_DATAGRAM EXPAND=FALSE

  PROCEDURE [XREF] nlp$cn_send_datagram (sap: nat$cn_sap_id;
        device: nlt$device_identifier;
        destination: nat$system_address;
        data: nlt$bm_message_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$cn_interface
*copyc nat$network_address
*copyc nlt$device_identifier
*copyc nlt$bm_message_id
*copyc ost$status
?? POP ??
*DECK DECK=NLP$CONNECTION_QUEUED EXPAND=FALSE

  FUNCTION [XREF] nlp$connection_queued
    (    connection: ^nlt$cl_connection): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??

*DECK DECK=NLP$CONNECTION_SIMULATED_BROKEN EXPAND=FALSE

  PROCEDURE [XREF] nlp$connection_simulated_broken (
        connection_id: nat$connection_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc OST$STATUS
?? POP ??
*DECK DECK=NLP$CONNECT_UNSIMULATED_BROKEN EXPAND=FALSE

  PROCEDURE [XREF] nlp$connect_unsimulated_broken (
        connection_id: nat$connection_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc OST$STATUS
?? POP ??
*DECK DECK=NLP$DELETE_REGISTERED_TITLE EXPAND=FALSE
 PROCEDURE [XREF] nlp$delete_registered_title (title: string ( * <=
  nac$max_title_length);
        password: nat$directory_password;
        identifier: nat$directory_entry_identifier;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$directory_entry_identifier
*copyc nat$directory_interfaces
*copyc nat$title
*copyc ost$status
?? POP ??
*DECK DECK=NLP$DELINK_RECEIVING_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nlp$delink_receiving_connection
    (    receiving_connection: ^nlt$cl_connection;
     VAR next_receiving_connection: nlt$cl_connection_id);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$DEQUEUE_RECEIVING_CONECTION EXPAND=FALSE

  PROCEDURE [XREF] nlp$dequeue_receiving_conection
    (    receiving_connection: ^nlt$cl_connection;
     VAR next_receiving_connection: nlt$cl_connection_id);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$END_TITLE_TRANSLATION EXPAND=FALSE
 PROCEDURE [XREF] nlp$end_title_translation (request_id:
  nat$directory_search_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$directory_me_conditions
*copyc nat$directory_search_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NLP$FETCH_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] nlp$fetch_attributes (file_identifier: amt$file_identifier;
        layer: amt$fap_layer_number;
        call_block: amt$call_block;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
*copyc nae$namve_conditions
?? POP ??
*DECK DECK=NLP$GET_EXCLUSIVE_ACCESS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? TITLE := '  [INLINE] nlp$get_exclusive_access', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nlt$access_control
*copyc osp$begin_subsystem_activity
*copyc osp$end_subsystem_activity
*copyc ost$signature_lock
*copyc syp$cycle
?? POP ??

  PROCEDURE [INLINE] nlp$get_exclusive_access (VAR access_control: nlt$access_control);

    VAR
      old_access,
      new_access,
      actual_access: nlt$access_control,
      cs_status: osc$cs_successful .. osc$cs_variable_locked;

    old_access.nonexclusive_accessors := 0;
    old_access.exclusive := FALSE;
    old_access.fill := 0;
    new_access := old_access;
    new_access.exclusive := TRUE;

    osp$begin_subsystem_activity;
    REPEAT
      #compare_swap (access_control, old_access, new_access, actual_access, cs_status);
      IF (cs_status = osc$cs_failed) THEN
        osp$end_subsystem_activity;
        syp$cycle;
        osp$begin_subsystem_activity;
      IFEND;
    UNTIL (cs_status = osc$cs_successful);
  PROCEND nlp$get_exclusive_access;
*DECK DECK=NLP$GET_LAYER_PROTOCOL_HEADER EXPAND=FALSE

  PROCEDURE [INLINE] nlp$get_layer_protocol_header
    (    protocol_header: ^cell;
         protocol_header_length: nat$data_length;
     VAR message_header {INPUT, OUTPUT} : ^cell;
     VAR message_header_length {INPUT, OUTPUT} : nat$data_length);
?? PUSH (LISTEXT := ON) ??
*copy nlh$get_layer_protocol_header

    IF (protocol_header_length > message_header_length) THEN
{     osp$system_error ('GET LAYER PROTOCOL HEADER', NIL);
    IFEND;

    i#move (message_header, protocol_header, protocol_header_length);
    message_header_length := message_header_length - protocol_header_length;
    IF (message_header_length > 0) THEN
      message_header := #ADDRESS (1, #SEGMENT (#LOC (message_header^)),
            (#OFFSET (#LOC (message_header^)) + protocol_header_length));
    ELSE
      message_header := NIL;
    IFEND;
  PROCEND nlp$get_layer_protocol_header;
*copyc nat$data_length
{*COPYC OSP$SYSTEM_ERROR
*copyc i#move
?? POP ??
*DECK DECK=NLP$GET_NONEXCLUSIVE_ACCESS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? TITLE := '  [INLINE] nlp$get_nonexclusive_access', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nlt$access_control
*copyc ost$signature_lock
*copyc syp$cycle
?? POP ??

  PROCEDURE [INLINE] nlp$get_nonexclusive_access (VAR access_control: nlt$access_control);

    VAR
      old_access,
      new_access: nlt$access_control,
      cs_status: osc$cs_successful .. osc$cs_variable_locked;

    old_access.nonexclusive_accessors := 0;
    old_access.exclusive := FALSE;
    old_access.fill := 0;
    new_access := old_access;
    new_access.nonexclusive_accessors := 1;

    REPEAT
      #compare_swap (access_control, old_access, new_access, old_access, cs_status);
      IF (cs_status = osc$cs_failed) THEN
        IF old_access.exclusive THEN
          syp$cycle;
          old_access.exclusive := FALSE;
        IFEND;
        new_access.nonexclusive_accessors := old_access.nonexclusive_accessors + 1;
      IFEND;
    UNTIL (cs_status = osc$cs_successful);
  PROCEND nlp$get_nonexclusive_access;
*DECK DECK=NLP$GET_RECEIVING_CONNECTIONS EXPAND=FALSE

  PROCEDURE [XREF] nlp$get_receiving_connections
    (VAR receiving_connections: ^nlt$cl_connection);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$GET_TITLE_TRANSLATION EXPAND=FALSE
 PROCEDURE [XREF] nlp$get_title_translation (request_id:
  nat$directory_search_identifier;
    VAR title: nat$title;
    VAR address: nat$osi_translation_address;
    VAR protocol: nat$protocol;
        user_information: ^cell;
    VAR user_info_length: 0 .. nac$max_directory_data_length;
    VAR priority: nat$directory_priority;
    VAR user_identifier: ost$name;
    VAR identifier: nat$directory_entry_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$directory_me_conditions
*copyc nat$directory_data
*copyc nat$directory_entry_identifier
*copyc nat$directory_interfaces
*copyc nat$directory_priority
*copyc nat$directory_search_identifier
*copyc nat$protocol
*copyc nat$title
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=NLP$LA_CLOSE_SAP EXPAND=FALSE

  PROCEDURE [XREF] nlp$la_close_sap
    (    sap_id: nat$cn_sap_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$cn_interface
*copyc ost$status
?? POP ??
*DECK DECK=NLP$LA_CONNECT_EVENT_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] nlp$la_connect_event_processor
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_interface
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$LA_EVENT_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] nlp$la_event_processor
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_interface
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$LA_INITIALIZE EXPAND=FALSE

  PROCEDURE [XREF] nlp$la_initialize;

*DECK DECK=NLP$LA_OPEN_SAP EXPAND=FALSE

  PROCEDURE [XREF] nlp$la_open_sap
    (    sap_id: nat$cn_sap_id;
         device_count: nlt$device_identifier;
         device_list: ^array [1 .. *] of nlt$device_identifier;
         class: nlt$cc_connection_class;
         event_processor: nat$network_procedure;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$cn_interface
*copyc nat$network_procedure
*copyc nlt$cc_connection_class
*copyc nlt$device_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NLP$LA_OPEN_SAPS EXPAND=FALSE

  PROCEDURE [XREF] nlp$la_open_saps
    (    device_id: nlt$device_identifier;
         subnet_count: nat$subnet_identifier;
         subnet_list: ^array [1 .. *] of nat$subnet_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc nat$subnet_identifier
*copyc nlt$device_identifier
?? POP ??
*DECK DECK=NLP$LA_RETRY_CONSTRAINED_SAPS EXPAND=FALSE

  PROCEDURE [XREF] nlp$la_retry_constrained_saps
    (    current_time: integer);

*DECK DECK=NLP$LA_SEND_DATA EXPAND=FALSE

  PROCEDURE [XREF] nlp$la_send_data
    (    sap_id: nat$cn_sap_id;
         subnet_id: nat$subnet_identifier;
         destination_subnet_address: nat$system_identifier;
         header_format: nlt$la_header_format;
         priority: nlt$la_priority;
         data: nlt$bm_message_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$cn_interface
*copyc nat$subnet_identifier
*copyc nat$system_identifier
*copyc nlt$bm_message_id
*copyc nlt$la_header_format
*copyc nlt$la_priority
?? POP ??
*DECK DECK=NLP$NAME_MATCH EXPAND=FALSE

  FUNCTION [XREF] nlp$name_match (
        name: nat$title_pattern;
        model: nat$title): boolean;

 ?? PUSH (LISTEXT:=ON) ??
*copyc nat$title
*copyc nat$title_pattern
?? POP ??
*DECK DECK=NLP$NA_BROADCAST_DATA EXPAND=FALSE

  PROCEDURE [XREF] nlp$na_broadcast_data
    (    device_id: nlt$device_identifier;
         source_sap_id: nat$network_selector;
         destination_sap_id: nat$network_selector;
         data: nat$data_fragments;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$network_access_agent
*copyc nat$data_fragments
*copyc nat$network_selector
*copyc nlt$device_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NLP$NA_CLOSE_SAP EXPAND=FALSE

  PROCEDURE [XREF] nlp$na_close_sap
    (    sap_id: nat$network_selector;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$network_access_agent
*copyc nat$network_selector
*copyc ost$status
?? POP ??
*DECK DECK=NLP$NA_CONNECT_EVENT_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] nlp$na_connect_event_processor
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_interface
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$NA_DISCONNECT_CONNECTIONS EXPAND=FALSE

  PROCEDURE [XREF] nlp$na_disconnect_connections (device_id: nlt$device_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$device_identifier
?? POP ??
*DECK DECK=NLP$NA_EVENT_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] nlp$na_event_processor
    (    cl_connection { input, output } : ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_interface
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$NA_INITIALIZE EXPAND=FALSE

  PROCEDURE [XREF] nlp$na_initialize;
*DECK DECK=NLP$NA_OPEN_SAP EXPAND=FALSE

  PROCEDURE [XREF] nlp$na_open_sap
    (    priority: nlt$na_priority;
         event_processor: nat$network_procedure;
         sap_id: nat$network_selector;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$namve_conditions
*copyc nae$network_access_agent
*copyc nat$network_procedure
*copyc nat$network_selector
*copyc nlt$na_priority
*copyc ost$status
?? POP ??
*DECK DECK=NLP$NA_OPEN_SAPS EXPAND=FALSE

  PROCEDURE [XREF] nlp$na_open_saps
    (    device_id: nlt$device_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$device_identifier
?? POP ??
*DECK DECK=NLP$NA_RETRY_CONSTRAINED_SAPS EXPAND=FALSE

  PROCEDURE [XREF] nlp$na_retry_constrained_saps
    (    current_time: integer);

*DECK DECK=NLP$NA_SEND_DATA EXPAND=FALSE

  PROCEDURE [XREF] nlp$na_send_data
    (    sap_id: nat$network_selector;
         device_id: nlt$device_identifier;
         destination: nat$osi_network_address;
         data: nat$data_fragments;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$network_access_agent
*copyc nat$data_fragments
*copyc nat$network_selector
*copyc nat$osi_network_address
*copyc nlt$device_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NLP$NOMINAL_CONN_REGISTRATION EXPAND=FALSE

  PROCEDURE [XREF] nlp$nominal_conn_registration (
        connection_id: nat$connection_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc OST$STATUS
?? POP ??
*DECK DECK=NLP$NOMINAL_DISCONNECT_RECORD EXPAND=FALSE

  PROCEDURE [XREF] nlp$nominal_disconnect_record (
        connection_id: nat$connection_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc OST$STATUS
?? POP ??
*DECK DECK=NLP$OFFER_CONNECTION_SWITCH EXPAND=FALSE
  PROCEDURE [XREF] nlp$offer_connection_switch (file: fst$file_reference;
        destination: jmt$system_supplied_name;
        timesharing_connection_switch: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=NLP$OPEN_FILE EXPAND=FALSE

  PROCEDURE [XREF] nlp$open_file (
        connection_id: nat$connection_id;
        file_identifier: amt$file_identifier;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc amt$file_identifier
*copyc ost$status
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NLP$OSI_GET_OUTBOUND_CAPACITY EXPAND=FALSE

  PROCEDURE [INLINE] nlp$osi_get_outbound_capacity
    (    cl_connection: ^nlt$cl_connection;
     VAR current_connection_capacity: nat$data_length);

?? PUSH (LISTEXT := ON) ??
*copy nlh$osi_get_outbound_capacity

{ This procedure determines the outbound capacity for the specified connection
{ using an algorithm that takes into account connection class, number of active priority
{ connections and maximum CCPDU size. The capacity returned is either zero or the maximum
{ TA user PDU size. If no capacity is available due to insufficient buffer resouces, a
{ timer will be started. If capacity is available when the timer expires and the sender is
{ waiting, a 'clear to send' will be sent to the sender; if capacity is still unavailable due to
{ insufficient buffers the timer will be reset.

{ When the number of available network buffers becomes less than the number reserved for priority
{ connections the normal flow control window is closed.  The number of buffers reserved for priority
{ connections is equivalent to the number of active priority connections.

{ When the number of available network buffers becomes less than half the number of active connections,
{ capacity will be allocated only if the connection has credits outstanding from the device.

    CONST
      sixty_seconds = 60000000; { Sixty seconds in microseconds 60*1000*1000.

    VAR
      available_buffers: integer,
      connection: ^nlt$cc_connection,
      layer_active: boolean;

    current_connection_capacity := 0;
    nlp$cl_get_layer_connection (nlc$channel_connection_layer, cl_connection, layer_active, connection);
    IF layer_active THEN
      IF (connection^.send_credits > 0) OR ((((connection^.send_buffer.out + (nlc$cc_send_buffer_limit - 1)) -
            connection^.send_buffer.inn) MOD nlc$cc_send_buffer_limit) > 0) THEN
        available_buffers := (nlv$bm_buffer_pool [nlc$bm_large_buffer_index].count +
              (nlv$bm_allocat_buffer_threshold - nlv$bm_buffer_pool [nlc$bm_large_buffer_index].
              dynamic_buffers));
        IF connection^.class = nlc$cc_normal_class THEN
          available_buffers := available_buffers - nlv$cl_priority_connect_count
                - (nlp$cl_active_connections () DIV 2);
        IFEND;
        IF connection^.send_credits = 0 THEN
          available_buffers := available_buffers - (nlp$cl_active_connections () DIV 2);
        IFEND;
        IF available_buffers >= connection^.buffers_per_credit THEN
          current_connection_capacity := connection^.device_specific_attributes.maximum_data_length -
                nlc$lower_layer_overhead;
        IFEND;
        IF current_connection_capacity = 0 THEN
          nlp$select_timer ( sixty_seconds, 0, connection^.no_buffers_for_user_capacity);
        IFEND;
      IFEND;
    IFEND;
  PROCEND nlp$osi_get_outbound_capacity;

*copyc nat$data_fragments
*copyc nlc$bm_buffer_pool_index
*copyc nlt$bm_buffer_count
*copyc nlt$cc_connection
*copyc nlt$cl_connection
*copyc nlp$cl_active_connections
*copyc nlp$cl_get_layer_connection
*copyc nlp$select_timer
*copyc nlv$bm_allocat_buffer_threshold
*copyc nlv$bm_buffer_pool
*copyc nlv$cl_priority_connect_count
?? POP ??
*DECK DECK=NLP$PROCESS_RECEIVING_CONECTION EXPAND=FALSE

  PROCEDURE [XREF] nlp$process_receiving_conection
    (    connection_id: nlt$cl_connection_id);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$RECEIVE_CHANNELNET_DATAGRAM EXPAND=FALSE

  PROCEDURE [XREF] nlp$receive_channelnet_datagram
    (sap_id: nat$cn_sap_id;
         source: nat$system_address;
         multicast: boolean;
     VAR protocol_header {INPUT, OUTPUT} : ^cell;
     VAR protocol_header_length {INPUT, OUTPUT} : nat$data_length;
         datagram: nlt$bm_message_id);

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_address
*copyc nat$data_length
*copyc nat$cn_interface
*copyc nlt$bm_message_id
?? POP ??
*DECK DECK=NLP$RECORD_NOMINAL_DISCONNECT EXPAND=FALSE

  PROCEDURE [XREF] nlp$record_nominal_disconnect (
        file: fst$file_reference;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc FST$FILE_REFERENCE
*copyc OST$STATUS
?? POP ??
*DECK DECK=NLP$RECOVER_TASK_ACTIVITY EXPAND=FALSE

  PROCEDURE [XREF] nlp$recover_task_activity (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=NLP$REGISTER_NOMINAL_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nlp$register_nominal_connection (
        file: fst$file_reference;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc FST$FILE_REFERENCE
*copyc OST$STATUS
?? POP ??
*DECK DECK=NLP$REGISTER_TITLE EXPAND=FALSE
 PROCEDURE [XREF] nlp$register_title
   (    title: string ( * <= nac$max_title_length);
        osi_address: nat$osi_registration_address;
        protocol: nat$protocol;
        user_information: ^cell;
        user_information_length: 0 .. nac$max_directory_data_length;
        priority: nat$directory_priority;
        domain: nat$title_domain;
        distribute: boolean;
        class: nat$title_class;
        password: nat$directory_password;
    VAR user_identifier: ost$name;
    VAR identifier: nat$directory_entry_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$directory_data
*copyc nat$directory_entry_identifier
*copyc nat$directory_interfaces
*copyc nat$directory_priority
*copyc nat$protocol
*copyc nat$title
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=NLP$RELEASE_EXCLUSIVE_ACCESS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? TITLE := '  [INLINE] nlp$release_exclusive_access', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nlt$access_control
*copyc ost$signature_lock
*copyc osp$end_subsystem_activity
?? POP ??

  PROCEDURE [INLINE] nlp$release_exclusive_access (VAR access_control: nlt$access_control);

    VAR
      old_access,
      new_access,
      actual_access: nlt$access_control,
      cs_status: osc$cs_successful .. osc$cs_variable_locked;

    old_access.nonexclusive_accessors := 0;
    old_access.exclusive := TRUE;
    old_access.fill := 0;
    new_access := old_access;
    new_access.exclusive := FALSE;

    REPEAT
      #compare_swap (access_control, old_access, new_access, actual_access, cs_status);
    UNTIL (cs_status = osc$cs_successful);
    osp$end_subsystem_activity;
  PROCEND nlp$release_exclusive_access;
*DECK DECK=NLP$RELEASE_NONEXCLUSIVE_ACCESS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? TITLE := '  [INLINE] nlp$release_nonexclusive_access', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nlt$access_control
*copyc ost$signature_lock
?? POP ??

  PROCEDURE [INLINE] nlp$release_nonexclusive_access (VAR access_control: nlt$access_control);

    VAR
      old_access,
      new_access: nlt$access_control,
      cs_status: osc$cs_successful .. osc$cs_variable_locked;

    old_access.nonexclusive_accessors := 1;
    old_access.exclusive := FALSE;
    old_access.fill := 0;
    new_access := old_access;
    new_access.nonexclusive_accessors := 0;

    REPEAT
      #compare_swap (access_control, old_access, new_access, old_access, cs_status);
      IF (cs_status = osc$cs_failed) THEN
        new_access.nonexclusive_accessors := old_access.nonexclusive_accessors - 1;
      IFEND;
    UNTIL (cs_status = osc$cs_successful);
  PROCEND nlp$release_nonexclusive_access;
*DECK DECK=NLP$REQUEST_CONNECTION EXPAND=FALSE
  PROCEDURE [XREF] nlp$request_connection (server: nat$network_address;
        client_application_name: nat$application_name;
        file: fst$file_reference;
        protocol: nat$protocol;
        attributes: ^nat$create_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc nat$application_name
*copyc nat$create_attributes
*copyc nat$network_address
*copyc nat$protocol
*copyc ost$status
?? POP ??
*DECK DECK=NLP$REQUEUE_MSGS_FOR_INPUT_TASK EXPAND=FALSE

  PROCEDURE [XREF] nlp$requeue_msgs_for_input_task (
     received_messages: ^nlt$bm_message_descriptor);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_descriptor
?? POP ??
*DECK DECK=NLP$SELECT_TIMER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc nlt$timer
?? POP ??

  PROCEDURE [INLINE] nlp$select_timer (duration: integer;
        count: nlt$timer_count;
    VAR timer: nlt$timer);

?? PUSH (LISTEXT := ON) ??
*copy nlh$select_timer

    timer.expiration_time := (#free_running_clock (0) + duration);
    timer.count := count;
    timer.selected := TRUE;
  PROCEND nlp$select_timer;
?? POP ??
*DECK DECK=NLP$SE_ACCEPT_CONNECTION EXPAND=FALSE

 PROCEDURE [XREF] nlp$se_accept_connection (
        xns_connection: ^nlt$cl_connection;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??

*DECK DECK=NLP$SE_CLOSE_SAP EXPAND=FALSE

 PROCEDURE [XREF] nlp$se_close_sap (sap: nat$generic_sap_identifier;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nat$generic_sap_identifier
*copyc ost$status
?? POP ??

*DECK DECK=NLP$SE_GET_AVAILABLE_BYTE_COUNT EXPAND=FALSE

  PROCEDURE [XREF] nlp$se_get_available_byte_count
    (    file_identifier: amt$file_identifier;
         layer: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc amt$file_identifier
*copyc nae$internal_interactive_appl
*copyc ost$status
?? POP ??
*DECK DECK=NLP$SE_INITIALIZE EXPAND=FALSE

  PROCEDURE [XREF] nlp$se_initialize;
*DECK DECK=NLP$SE_OPEN_SAP EXPAND=FALSE

  PROCEDURE [XREF] nlp$se_open_sap
    (    sap_timer_evaluator: nat$network_procedure;
         accept_connect_events: boolean;
         maximum_active_connections: nlt$se_max_active_connections;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_procedure
*copyc nlt$cl_connection_layer_templat
*copyc nlt$se_max_active_connections
*copyc ost$status
?? POP ??
*DECK DECK=NLP$SE_RECEIVE_DATA EXPAND=FALSE

  PROCEDURE [XREF] nlp$se_receive_data (file_identifier: amt$file_identifier;
        layer: amt$fap_layer_number;
        call_block: amt$call_block;
        start_time: integer;
    VAR request_started: boolean;
    VAR wait_time: nat$wait_time;
    VAR receive_wait_swapout: boolean;
    VAR activity_status: ^ost$activity_status;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc nat$wait_time
*copyc ost$activity_status
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
*copyc nae$internal_interactive_appl
?? POP ??
*DECK DECK=NLP$SE_SEND_DATA EXPAND=FALSE

  PROCEDURE [XREF] nlp$se_send_data (file_identifier: amt$file_identifier;
        layer: amt$fap_layer_number;
        call_block: amt$call_block;
        start_time: integer;
    VAR request_started: boolean;
    VAR wait_time: nat$wait_time;
    VAR activity_status: ^ost$activity_status;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc nat$wait_time
*copyc ost$activity_status
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
*copyc nae$internal_interactive_appl
?? POP ??
*DECK DECK=NLP$SE_SEND_INTERRUPT EXPAND=FALSE

  PROCEDURE [XREF] nlp$se_send_interrupt (file_identifier: amt$file_identifier;
        layer: amt$fap_layer_number;
        call_block: amt$call_block;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NLP$SE_SYNCHRONIZE EXPAND=FALSE

  PROCEDURE [XREF] nlp$se_synchronize (file_identifier: amt$file_identifier;
        layer: amt$fap_layer_number;
        call_block: amt$call_block;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NLP$SE_SYNCHRONIZE_CONFIRM EXPAND=FALSE

  PROCEDURE [XREF] nlp$se_synchronize_confirm (file_identifier: amt$file_identifier;
        layer: amt$fap_layer_number;
        call_block: amt$call_block;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NLP$SIMULATE_CONNECTION_BROKEN EXPAND=FALSE

  PROCEDURE [XREF] nlp$simulate_connection_broken (
        file: fst$file_reference;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc FST$FILE_REFERENCE
*copyc OST$STATUS
?? POP ??
*DECK DECK=NLP$SK_ACCEPT_SOCKET_OFFER EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_accept_socket_offer
    (    source_job: jmt$system_supplied_name;
         socket_id: nat$sk_socket_identifier;
         time_stamp: ost$free_running_clock;
         wait_time: nat$wait_time;
     VAR socket_type: nat$sk_socket_type;
     VAR global_socket_id: nlt$udp_global_socket_id;
     VAR connection_id: nat$connection_id;
     VAR tcp_socket_type: nlt$tcp_socket_type;
     VAR bound_address: nat$sk_ip_address;
     VAR port: nat$sk_port_number;
     VAR traffic_pattern: nat$sk_traffic_pattern;
     VAR application: nat$application_name;
     VAR ring: ost$ring;
     VAR capability: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc nat$application_name
*copyc nat$connection_id
*copyc nat$sk_ip_address
*copyc nat$sk_port_number
*copyc nat$sk_socket_identifier
*copyc nat$sk_socket_type
*copyc nat$sk_traffic_pattern
*copyc nat$wait_time
*copyc nlt$tcp_socket_type
*copyc nlt$udp_global_socket_id
*copyc osd$virtual_address
*copyc ost$free_running_clock
*copyc ost$name
*copyc ost$status
?? POP ??

*DECK DECK=NLP$SK_ACQUIRE_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_acquire_socket
    (    application: nat$application_name;
         application_type: nat$application_type;
         interface_mode: nat$sk_interface_mode;
         wait_time: integer;
     VAR connection_id: nat$connection_id;
     VAR source_socket: nat$sk_socket_address;
     VAR local_ip_address: nat$sk_ip_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$application_type
*copyc nat$connection_id
*copyc nat$sk_interface_mode
*copyc nat$sk_ip_address
*copyc nat$sk_socket_address
*copyc ost$status
?? POP ??
*DECK DECK=NLP$SK_ADD_JOB_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_add_job_socket
    (    socket_id: nat$sk_socket_identifier;
         job_socket: nat$sk_job_socket);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_job_socket
*copyc nat$sk_socket_identifier
?? POP ??
*DECK DECK=NLP$SK_AWAIT_SOCKET_EVENTS EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_await_socket_events
    (    socket_events: nat$sk_socket_events;
     VAR completed_events: nat$sk_socket_events;
     VAR count: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_socket_events
*copyc ost$status
?? POP ??
*DECK DECK=NLP$SK_AWAIT_SOCKET_OFFER EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_await_socket_offer
    (    source_job: jmt$system_supplied_name;
         wait: boolean;
     VAR activity_complete: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
?? POP ??
*DECK DECK=NLP$SK_AWAIT_TCP_CLEAR_TO_SEND EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_await_tcp_clear_to_send
    (    connection_id: nat$connection_id;
     VAR activity_complete: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
?? POP ??
*DECK DECK=NLP$SK_AWAIT_TCP_DATA_AVAILABLE EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_await_tcp_data_available
    (    connection_id: nat$connection_id;
     VAR activity_complete: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
?? POP ??
*DECK DECK=NLP$SK_CHECK_ACCEPT_SOCKET_AVAI EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_check_accept_socket_avai
    (    application: nat$application_name;
         wait: boolean;
     VAR activity_complete: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
?? POP ??
*DECK DECK=NLP$SK_CLEAR_JOB_SOCKET_LOCK EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_clear_job_socket_lock
    (    socket_id: nat$sk_socket_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_socket_identifier
?? POP ??

*DECK DECK=NLP$SK_DELETE_JOB_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_delete_job_socket
    (socket_id: nat$sk_socket_identifier;
     VAR job_socket: ^nat$sk_job_socket);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_job_socket
*copyc nat$sk_socket_identifier
?? POP ??
*DECK DECK=NLP$SK_FRAGMENT_DATA EXPAND=FALSE

  PROCEDURE [INLINE] nlp$sk_fragment_data
    (    fragment_size: nat$data_length;
         current_lowerbound: nat$data_fragment_count;
     VAR data: nat$data_fragments;
     VAR new_lowerbound: nat$data_fragment_count;
     VAR fragment: nat$data_fragments);

?? PUSH (LISTEXT := ON) ??


    VAR
      i: integer,
      j: integer,
      scanned_data_length: nat$data_length;

    scanned_data_length := 0;
    i := current_lowerbound;
    j := 1;
    WHILE (scanned_data_length < fragment_size) DO
      IF ((data [i].length > 0) AND (data [i].address <> NIL)) THEN
        IF ((scanned_data_length + data [i].length) <= fragment_size) THEN
          fragment [j] := data [i];
          scanned_data_length := scanned_data_length + data [i].length;
          data [i].length := 0;
          j := j + 1;
          i := i + 1;
        ELSE { IF ((scanned_data_length + data [i].length) > fragment_size)
              {THEN
          fragment [j].address := data [i].address;
          fragment [j].length := fragment_size - scanned_data_length;
          scanned_data_length := scanned_data_length + fragment [j].length;
          data [i].address := #ADDRESS (#RING (data [i].address),
                #SEGMENT (data [i].address), (#OFFSET (data [i].address) +
                fragment [j].length));
          data [i].length := data [i].length - fragment [j].length;
          j := j + 1;
        IFEND;
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;
    new_lowerbound := i;
    FOR i := j TO UPPERBOUND (fragment) DO
      fragment [i].address := NIL;
      fragment [i].length := 0;
    FOREND;
  PROCEND nlp$sk_fragment_data;

*copy nlh$sk_fragment_data

*copyc nat$data_fragments
*copyc nat$data_length
?? POP ??
*DECK DECK=NLP$SK_FREE_SOCKET_ID EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_free_socket_id
    (socket_id: nat$sk_socket_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_socket_identifier
?? POP ??
*DECK DECK=NLP$SK_GET_SOCKET_ID EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_get_socket_id
    (VAR socket_id: nat$sk_socket_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_socket_identifier
*copyc ost$status
?? POP ??

*DECK DECK=NLP$SK_LOCK_JOB_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_lock_job_socket
    (    socket_id: nat$sk_socket_identifier;
     VAR job_socket: ^nat$sk_job_socket);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_job_socket
*copyc nat$sk_socket_identifier
?? POP ??
*DECK DECK=NLP$SK_OFFER_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_offer_socket
    (    socket_id: nat$sk_socket_identifier;
         destination_job: jmt$system_supplied_name;
         socket_type: nat$sk_socket_type;
         global_socket_id: nlt$udp_global_socket_id;
         connection_id: nat$connection_id;
         tcp_socket_type: nlt$tcp_socket_type;
         port: nat$sk_port_number;
         bound_address: nat$sk_ip_address;
         traffic_pattern: nat$sk_traffic_pattern;
         application: nat$application_name;
         ring: ost$ring;
         capability: ost$name;
         wait_time: nat$wait_time;
     VAR offer_accepted: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc nat$application_name
*copyc nat$connection_id
*copyc nat$sk_ip_address
*copyc nat$sk_port_number
*copyc nat$sk_socket_identifier
*copyc nat$sk_socket_type
*copyc nat$sk_traffic_pattern
*copyc nat$wait_time
*copyc nlt$tcp_socket_type
*copyc nlt$udp_global_socket_id
*copyc osd$virtual_address
*copyc ost$name
?? POP ??
*DECK DECK=NLP$SK_PROCESS_JOB_RECOVERY EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_process_job_recovery;
*DECK DECK=NLP$SK_REMOVE_WAIT_SOCKET_OFFER EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_remove_wait_socket_offer
    (source_job: jmt$system_supplied_name);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
?? POP ??

*DECK DECK=NLP$SK_TCP_ACCEPT_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_accept_socket
    (    port: nat$sk_port_number;
         bound_address: nat$sk_ip_address;
         graceful_close: boolean;
         traffic_pattern: nat$sk_traffic_pattern;
         wait_time: nat$wait_time;
     VAR connection_id: nat$connection_id;
     VAR source_socket: nat$sk_socket_address;
     VAR local_ip_address: nat$sk_ip_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc nat$sk_ip_address
*copyc nat$sk_port_number
*copyc nat$sk_socket_address
*copyc nat$sk_traffic_pattern
*copyc nat$wait_time
*copyc ost$status
?? POP ??
*DECK DECK=NLP$SK_TCP_ACTIVATE_LISTEN EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_activate_listen
    (    socket_id: nat$sk_socket_identifier;
         application: nat$application_name;
         port: nat$sk_port_number;
         bound_address: nat$sk_ip_address;
         queue_limit: nat$sk_listen_queue_limit;
         selection_criteria: nat$sk_socket_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$sk_ip_address
*copyc nat$sk_listen_queue_limit
*copyc nat$sk_port_number
*copyc nat$sk_socket_address
*copyc nat$sk_socket_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NLP$SK_TCP_AWAIT_CLEAR_TO_SEND EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_await_clear_to_send
    (    connection_id: nat$connection_id;
         wait: boolean;
     VAR activity_complete: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
?? POP ??
*DECK DECK=NLP$SK_TCP_AWAIT_DATA_AVAILABLE EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_await_data_available
    (    connection_id: nat$connection_id;
         wait: boolean;
     VAR activity_complete: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
?? POP ??
*DECK DECK=NLP$SK_TCP_CANCEL_SOCKET_OFFER EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_cancel_socket_offer
    (    connection_id: nat$connection_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc ost$status
?? POP ??
*DECK DECK=NLP$SK_TCP_CHECK_ACCEPT_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_check_accept_socket
    (    application: nat$application_name;
         port: nat$sk_port_number;
         bound_address: nat$sk_ip_address;
         wait: boolean;
     VAR activity_complete: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$sk_ip_address
*copyc nat$sk_port_number
?? POP ??
*DECK DECK=NLP$SK_TCP_CLOSE_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_close_socket
    (    connection_id: nat$connection_id;
         graceful_close: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
?? POP ??
*DECK DECK=NLP$SK_TCP_CONN_EVENT_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_conn_event_processor
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$tcpaa_event;
     VAR inventory_report: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nlt$tcpaa_event
?? POP ??
*DECK DECK=NLP$SK_TCP_DEACTIVATE_LAYER EXPAND=FALSE

  PROCEDURE [INLINE] nlp$sk_tcp_deactivate_layer
    (    cl_connection: ^nlt$cl_connection;
         tcp_connection: ^nlt$tcp_socket_layer);

?? PUSH (LISTEXT := ON) ??


    VAR
      next_received_data: ^nlt$tcp_received_data,
      next_receiver_task: ^nlt$tcp_receiver_task,
      next_sender_task: ^nlt$tcp_sender_task,
      received_data: ^nlt$tcp_received_data,
      receiver_task: ^nlt$tcp_receiver_task,
      sender_task: ^nlt$tcp_sender_task;

{ Free the pool of received data entries.

    received_data := tcp_connection^.available_data_pool;
    WHILE received_data <> NIL DO
      next_received_data := received_data^.next_entry;
      FREE received_data IN nav$network_paged_heap^;
      received_data := next_received_data;
    WHILEND;

{ Free the pool of receiver task entries.

    receiver_task := tcp_connection^.available_receiver_pool;
    WHILE receiver_task <> NIL DO
      next_receiver_task := receiver_task^.next_entry;
      FREE receiver_task IN nav$network_paged_heap^;
      receiver_task := next_receiver_task;
    WHILEND;

{ Free the pool of sender task entries.

    sender_task := tcp_connection^.available_sender_pool;
    WHILE sender_task <> NIL DO
      next_sender_task := sender_task^.next_entry;
      FREE sender_task IN nav$network_paged_heap^;
      sender_task := next_sender_task;
    WHILEND;

    nlp$cl_deactivate_layer (nlc$tcp_interface, cl_connection);

  PROCEND nlp$sk_tcp_deactivate_layer;

*copy nlh$sk_tcp_deactivate_layer
*copyc nlp$cl_deactivate_layer

*copyc nlt$cl_connection
*copyc nlt$tcp_received_data
*copyc nlt$tcp_receiver_task
*copyc nlt$tcp_sender_task
*copyc nlt$tcp_socket_layer
*copyc nav$network_paged_heap
?? POP ??
*DECK DECK=NLP$SK_TCP_DEVICE_AVAILABLE EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_device_available
    (device_id: nlt$device_identifier;
     ip_address: nat$sk_ip_address);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_ip_address
*copyc nlt$device_identifier
?? POP ??
*DECK DECK=NLP$SK_TCP_EVENT_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_event_processor
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$tcpaa_event;
     VAR inventory_report: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nlt$tcpaa_event
?? POP ??
*DECK DECK=NLP$SK_TCP_GET_LISTEN_ADDRESSES EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_get_listen_addresses
    (    application: nat$application_name;
         port: nat$sk_port_number;
         bound_address: nat$sk_ip_address;
     VAR listen_addresses: array  [1..*] of nat$sk_ip_address;
     VAR count: nlt$device_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$sk_ip_address
*copyc nat$sk_port_number
*copyc nlt$device_count
*copyc ost$status
?? POP ??
*DECK DECK=NLP$SK_TCP_GET_REC_TASK_ENTRY EXPAND=FALSE

  PROCEDURE [INLINE] nlp$sk_tcp_get_rec_task_entry
    (VAR tcp_connection: ^nlt$tcp_socket_layer;
     VAR receiver_task: ^nlt$tcp_receiver_task);

?? PUSH (LISTEXT := ON) ??

    IF tcp_connection^.available_receiver_pool <> NIL THEN
      receiver_task := tcp_connection^.available_receiver_pool;
      tcp_connection^.available_receiver_pool := receiver_task^.next_entry;
    ELSE
      REPEAT
        ALLOCATE receiver_task IN nav$network_paged_heap^;
        IF receiver_task = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL receiver_task <> NIL;
    IFEND;
    receiver_task^.next_entry := NIL;

  PROCEND nlp$sk_tcp_get_rec_task_entry;

*copy nlh$sk_tcp_get_rec_task_entry

*copyc syp$cycle
*copyc nav$network_paged_heap
*copyc nlt$tcp_receiver_task
*copyc nlt$tcp_socket_layer
?? POP ??
*DECK DECK=NLP$SK_TCP_GET_SEND_TASK_ENTRY EXPAND=FALSE

  PROCEDURE [INLINE] nlp$sk_tcp_get_send_task_entry
    (VAR tcp_connection: ^nlt$tcp_socket_layer;
     VAR sender_task: ^nlt$tcp_sender_task);

?? PUSH (LISTEXT := ON) ??

    IF tcp_connection^.available_sender_pool <> NIL THEN
      sender_task := tcp_connection^.available_sender_pool;
      tcp_connection^.available_sender_pool := sender_task^.next_entry;
    ELSE
      REPEAT
        ALLOCATE sender_task IN nav$network_paged_heap^;
        IF sender_task = NIL THEN
          syp$cycle;
        IFEND;
      UNTIL sender_task <> NIL;
    IFEND;
    sender_task^.next_entry := NIL;

  PROCEND nlp$sk_tcp_get_send_task_entry;

*copy nlh$sk_tcp_get_send_task_entry

*copyc syp$cycle
*copyc nav$network_paged_heap
*copyc nlt$tcp_sender_task
*copyc nlt$tcp_socket_layer
?? POP ??
*DECK DECK=NLP$SK_TCP_GET_SOCKET_STATUS EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_get_socket_status
    (    connection_id: nat$connection_id;
     VAR clear_to_send: boolean;
     VAR data_pending_receive: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc ost$status
?? POP ??
*DECK DECK=NLP$SK_TCP_INITIALIZE EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_initialize;

*DECK DECK=NLP$SK_TCP_INITIALIZE_POOLS EXPAND=FALSE
*DECK DECK=NLP$SK_TCP_OFFER_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_offer_socket
    (    connection_id: nat$connection_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc ost$status
?? POP ??
*DECK DECK=NLP$SK_TCP_REMOVE_ACCEPT_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_remove_accept_socket
    (application: nat$application_name;
     port: nat$sk_port_number;
     bound_address: nat$sk_ip_address);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$sk_ip_address
*copyc nat$sk_port_number
?? POP ??
*DECK DECK=NLP$SK_TCP_REMOVE_CLEAR_TO_SEND EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_remove_clear_to_send
    (    connection_id: nat$connection_id);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
?? POP ??
*DECK DECK=NLP$SK_TCP_REMOVE_DATA_AVAIL EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_remove_data_avail
    (    connection_id: nat$connection_id);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
?? POP ??
*DECK DECK=NLP$SK_TCP_RET_REC_DATA_ENTRY EXPAND=FALSE

  PROCEDURE [INLINE] nlp$sk_tcp_ret_rec_data_entry
    (VAR tcp_connection: ^nlt$tcp_socket_layer;
     VAR received_data: ^nlt$tcp_received_data);

?? PUSH (LISTEXT := ON) ??

    VAR
      pool_entry: ^nlt$tcp_received_data,
      pool_size: integer;

    IF (tcp_connection^.state <> nlc$tcp_conn_closed) AND
      (tcp_connection^.state <> nlc$tcp_conn_terminated) THEN
      received_data^.next_entry := NIL;
      IF tcp_connection^.available_data_pool = NIL THEN
        tcp_connection^.available_data_pool := received_data;
      ELSE { calculate pool size
        pool_size := 1;
        pool_entry := tcp_connection^.available_data_pool;
        WHILE pool_entry^.next_entry <> NIL DO
          pool_entry := pool_entry^.next_entry;
          pool_size := pool_size + 1;
        WHILEND;
        IF pool_size < nlc$tcp_max_pool_size THEN
          pool_entry^.next_entry := received_data;
        ELSE
          FREE received_data IN nav$network_paged_heap^;
        IFEND;
      IFEND;
      received_data := NIL;
    ELSE { tcp connection closed or terminated
      FREE received_data IN nav$network_paged_heap^;
    IFEND;

  PROCEND nlp$sk_tcp_ret_rec_data_entry;

*copy nlh$sk_tcp_ret_rec_data_entry

*copyc nav$network_paged_heap
*copyc nlc$tcp_max_pool_size
*copyc nlt$tcp_received_data
*copyc nlt$tcp_socket_layer
?? POP ??
*DECK DECK=NLP$SK_TCP_RET_REC_TASK_ENTRY EXPAND=FALSE

  PROCEDURE [INLINE] nlp$sk_tcp_ret_rec_task_entry
    (VAR tcp_connection: ^nlt$tcp_socket_layer;
     VAR receiver_task: ^nlt$tcp_receiver_task);

?? PUSH (LISTEXT := ON) ??

    VAR
      pool_entry: ^nlt$tcp_receiver_task,
      pool_size: integer;

    IF tcp_connection^.state = nlc$tcp_conn_open THEN
      receiver_task^.next_entry := NIL;
      IF tcp_connection^.available_receiver_pool = NIL THEN
        tcp_connection^.available_receiver_pool := receiver_task;
      ELSE { calculate pool size
        pool_size := 1;
        pool_entry := tcp_connection^.available_receiver_pool;
        WHILE pool_entry^.next_entry <> NIL DO
          pool_entry := pool_entry^.next_entry;
          pool_size := pool_size + 1;
        WHILEND;
        IF pool_size < nlc$tcp_max_pool_size THEN
          pool_entry^.next_entry := receiver_task;
        ELSE
          FREE receiver_task IN nav$network_paged_heap^;
        IFEND;
      IFEND;
      receiver_task := NIL;
    ELSE { tcp connection closed or terminated
      FREE receiver_task IN nav$network_paged_heap^;
    IFEND;

  PROCEND nlp$sk_tcp_ret_rec_task_entry;

*copy nlh$sk_tcp_ret_rec_task_entry

*copyc nav$network_paged_heap
*copyc nlc$tcp_max_pool_size
*copyc nlt$tcp_receiver_task
*copyc nlt$tcp_socket_layer
?? POP ??
*DECK DECK=NLP$SK_TCP_RET_SEND_TASK_ENTRY EXPAND=FALSE

  PROCEDURE [INLINE] nlp$sk_tcp_ret_send_task_entry
    (VAR tcp_connection: ^nlt$tcp_socket_layer;
     VAR sender_task: ^nlt$tcp_sender_task);

?? PUSH (LISTEXT := ON) ??

    VAR
      pool_entry: ^nlt$tcp_sender_task,
      pool_size: integer;

    IF tcp_connection^.state = nlc$tcp_conn_open THEN
      sender_task^.next_entry := NIL;
      IF tcp_connection^.available_sender_pool = NIL THEN
        tcp_connection^.available_sender_pool := sender_task;
      ELSE { calculate pool size
        pool_size := 1;
        pool_entry := tcp_connection^.available_sender_pool;
        WHILE pool_entry^.next_entry <> NIL DO
          pool_entry := pool_entry^.next_entry;
          pool_size := pool_size + 1;
        WHILEND;
        IF pool_size < nlc$tcp_max_pool_size THEN
          pool_entry^.next_entry := sender_task;
        ELSE
          FREE sender_task IN nav$network_paged_heap^;
        IFEND;
      IFEND;
      sender_task := NIL;
    ELSE { tcp connection closed or terminated
      FREE sender_task IN nav$network_paged_heap^;
    IFEND;

  PROCEND nlp$sk_tcp_ret_send_task_entry;

*copy nlh$sk_tcp_ret_send_task_entry

*copyc nav$network_paged_heap
*copyc nlc$tcp_max_pool_size
*copyc nlt$tcp_sender_task
*copyc nlt$tcp_socket_layer
?? POP ??
*DECK DECK=NLP$SK_TCP_SEND_DATA EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_send_data
    (    cl_connection: ^nlt$cl_connection;
         initial_capacity: nat$data_length;
     VAR data: nat$data_fragments;
         data_length: nat$data_length;
         push_flag: boolean;
         urgent_flag: boolean;
         starting_fragment: nat$data_fragment_count;
     VAR remaining_fragment: nat$data_fragment_count;
     VAR remaining_data_length: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
*copyc nat$data_length
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$SK_TCP_SET_LISTEN_OPTIONS EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_set_listen_options
    (    application: nat$application_name;
         port: nat$sk_port_number;
         bound_address: nat$sk_ip_address;
         selection_criteria: nat$sk_socket_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$sk_ip_address
*copyc nat$sk_port_number
*copyc nat$sk_socket_address
*copyc ost$status
?? POP ??
*DECK DECK=NLP$SK_TCP_SET_SOCKET_OPTIONS EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_set_socket_options
    (    connection_id: nat$connection_id;
         graceful_close: boolean;
         traffic_pattern: nat$sk_traffic_pattern;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc nat$sk_traffic_pattern
*copyc ost$status
?? POP ??
*DECK DECK=NLP$SK_TCP_TERMINATE_ALL_LISTEN EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_terminate_all_listen
    (    application: nat$application_name);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
?? POP ??
*DECK DECK=NLP$SK_TCP_TERMINATE_LISTEN EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_terminate_listen
    (    application: nat$application_name;
         port: nat$sk_port_number;
         bound_address: nat$sk_ip_address);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$sk_ip_address
*copyc nat$sk_port_number
?? POP ??
*DECK DECK=NLP$SK_TCP_TERMINATE_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_tcp_terminate_socket
    ( connection_id: nat$connection_id);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
?? POP ??
*DECK DECK=NLP$SK_UNLOCK_JOB_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_unlock_job_socket
    (    socket_id: nat$sk_socket_identifier);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_socket_identifier
?? POP ??
*DECK DECK=NLP$SK_UPDATE_BOUND_ADDRESS EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_update_bound_address
    (    socket_id: nat$sk_socket_identifier;
     bound_address: nat$sk_ip_address);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_ip_address
*copyc nat$sk_socket_identifier
?? POP ??
*DECK DECK=NLP$SK_UPDATE_CONNECT_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_update_connect_socket
    (    socket_id: nat$sk_socket_identifier;
         connection_id: nat$connection_id;
         local_ip_address: nat$sk_ip_address);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc nat$sk_ip_address
*copyc nat$sk_socket_identifier
?? POP ??

*DECK DECK=NLP$SK_UPDATE_JOB_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_update_job_socket
    (    socket_id: nat$sk_socket_identifier;
         port: nat$sk_port_number;
         bound_address: nat$sk_ip_address;
         socket_status: nat$sk_job_socket_status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_ip_address
*copyc nat$sk_job_socket_status
*copyc nat$sk_port_number
*copyc nat$sk_socket_identifier
?? POP ??
*DECK DECK=NLP$SK_UPDATE_JOB_SOCKET_STATUS EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_update_job_socket_status
    (    socket_id: nat$sk_socket_identifier;
         status: nat$sk_job_socket_status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_job_socket_status
*copyc nat$sk_socket_identifier
?? POP ??

*DECK DECK=NLP$SK_UPDATE_LISTEN_FLAG EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_update_listen_flag
    (    socket_id: nat$sk_socket_identifier;
         port: nat$sk_port_number);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_port_number
*copyc nat$sk_socket_identifier
?? POP ??
*DECK DECK=NLP$SK_UPDATE_LISTEN_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_update_listen_socket
    (    socket_id: nat$sk_socket_identifier;
         port: nat$sk_port_number);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_port_number
*copyc nat$sk_socket_identifier
?? POP ??
*DECK DECK=NLP$SK_UPDATE_SOCKET_OPTIONS EXPAND=FALSE

  PROCEDURE [XREF] nlp$sk_update_socket_options
    (    socket_id: nat$sk_socket_identifier;
         options: nat$sk_socket_options);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_socket_identifier
*copyc nat$sk_socket_options
?? POP ??
*DECK DECK=NLP$SL_CALL_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] nlp$sl_call_request
   (    cl_connection: ^nlt$cl_connection;
        sap: nat$generic_sap_identifier;
        destination: nat$network_address;
        application_name: nat$application_name;
        data: nat$data_fragment;
        sap_priority: nat$network_message_priority;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nat$application_name
*copyc nat$data_fragments
*copyc nat$generic_sap_identifier
*copyc nat$network_address
*copyc nat$network_message_priority
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??

*DECK DECK=NLP$SL_CALL_RESPONSE EXPAND=FALSE

  PROCEDURE [XREF] nlp$sl_call_response (xns_connection: ^nlt$cl_connection;
        data: nat$data_fragments;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nat$data_fragments
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc ost$status
?? POP ??

*DECK DECK=NLP$SL_CLEAR_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] nlp$sl_clear_request (xns_connection: ^nlt$cl_connection;
        data: nat$data_fragments;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nat$data_fragments
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc ost$status
?? POP ??

*DECK DECK=NLP$SL_CLEAR_REQUEST_TIMER EXPAND=FALSE
  PROCEDURE [XREF] nlp$sl_clear_request_timer (current_time: integer;
      cl_connection: ^nlt$cl_connection);
*DECK DECK=NLP$SL_CLOSE_SAP EXPAND=FALSE

 PROCEDURE [XREF] nlp$sl_close_sap (sap: nat$generic_sap_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$generic_sap_identifier
*copyc ost$status
?? POP ??

*DECK DECK=NLP$SL_CONNECT_EVENT_PROCESSOR EXPAND=FALSE
  PROCEDURE [XREF] nlp$sl_connect_event_processor
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$ta_event;
     VAR inventory_report: nlt$ta_inventory_report);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nlt$ta_event
*copyc nlt$ta_inventory_report
?? POP ??
*DECK DECK=NLP$SL_DATA_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] nlp$sl_data_request (xns_connection: ^nlt$cl_connection;
        qualified_data: boolean;
        end_of_message: boolean;
        data: nat$data_fragments;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nat$data_fragments
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc ost$status
?? POP ??

*DECK DECK=NLP$SL_INITIALIZE EXPAND=FALSE

  PROCEDURE [XREF] nlp$sl_initialize
    (    sap_processor: nat$network_procedure;
         connection_processor: nat$network_procedure;
         application_layer: nlt$cl_application_layer);

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_procedure
*copyc nlt$cl_layer_name
?? POP ??
*DECK DECK=NLP$SL_INTERRUPT_REQUEST EXPAND=FALSE

 PROCEDURE [XREF] nlp$sl_interrupt_request (xns_connection: ^nlt$cl_connection;
        data: nlt$bm_message_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nlt$bm_message_id
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??

*DECK DECK=NLP$SL_OPEN_SAP EXPAND=FALSE

  PROCEDURE [XREF] nlp$sl_open_sap
    (    sap_processor: nat$network_procedure;
         connection_processor: nat$network_procedure;
         osi_application_layer: nlt$cl_application_layer;
         accept_connect_events: boolean;
         maximum_active_connections: nlt$sl_max_active_connections;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$namve_conditions
*copyc nat$network_message_priority
*copyc nat$network_procedure
*copyc nlt$cl_layer_name
*copyc nlt$sl_max_active_connections
*copyc ost$status
?? POP ??

*DECK DECK=NLP$SL_SAP_EVENT_PROCESSOR EXPAND=FALSE
  PROCEDURE [XREF] nlp$sl_sap_event_processor
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$ta_event;
     VAR inventory_report: nlt$ta_inventory_report);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nlt$ta_event
*copyc nlt$ta_inventory_report
?? POP ??
*DECK DECK=NLP$SL_SYNCH_REQUEST EXPAND=FALSE

 PROCEDURE [XREF] nlp$sl_synch_request (xns_connection: ^nlt$cl_connection;
        discard_option: nlt$sl_discard_options;
        data: nlt$bm_message_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nlt$bm_message_id
*copyc nlt$cl_connection
*copyc nlt$sl_discard_options
*copyc ost$status
?? POP ??

*DECK DECK=NLP$SL_SYNCH_RESPONSE EXPAND=FALSE

 PROCEDURE [XREF] nlp$sl_synch_response (xns_connection: ^nlt$cl_connection;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc ost$status
?? POP ??

*DECK DECK=NLP$SM_CONNECT_EVENT_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] nlp$sm_connect_event_processor
    (    cl_connection { input, output } : ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_interface
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$SM_EVENT_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] nlp$sm_event_processor
    (    cl_connection { input, output } : ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_interface
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$SM_INITIALIZE EXPAND=FALSE
  PROCEDURE [XREF] nlp$sm_initialize;
*DECK DECK=NLP$SM_SELECT_DEVICE EXPAND=FALSE

  PROCEDURE [XREF] nlp$sm_select_device
    (    destination_address: nat$osi_network_address;
         cdna_address: boolean;
         preferred_protocol_class: nat$ta_preferred_protocol_class;
     VAR device_list: nlt$device_list;
     VAR version_list: nlt$sm_device_version_list;
     VAR count: nlt$device_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$system_mgmt_access_agent
*copyc nat$osi_network_address
*copyc nat$ta_alternate_protocol_class
*copyc nat$ta_preferred_protocol_class
*copyc nlt$device_count
*copyc nlt$device_list
*copyc nlt$sm_device_version_list
*copyc ost$status
?? POP ??
*DECK DECK=NLP$STORE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] nlp$store_attributes (file_identifier: amt$file_identifier;
        layer: amt$fap_layer_number;
        call_block: amt$call_block;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc nae$application_interfaces
?? POP ??
*DECK DECK=NLP$SWITCH_OFFER_SET EXPAND=FALSE

  PROCEDURE [XREF] nlp$switch_offer_set (
        connection_id: nat$connection_id;
    VAR application_name: nat$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$connection_id
*copyc nat$application_name
*copyc OST$STATUS
?? POP ??
*DECK DECK=NLP$TA_ACCEPT_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nlp$ta_accept_connection
   (    cl_connection { input, output } : ^nlt$cl_connection;
        checksum: boolean;
        data { input, output} : nlt$bm_message_id;
        expedited_data: boolean;
        priority: nlt$ta_priority;
        quality_of_service: ^nlt$ta_quality_of_service;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nlt$bm_message_id
*copyc nlt$cl_connection
*copyc nlt$ta_priority
*copyc nlt$ta_quality_of_service
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TA_CLOSE_SAP EXPAND=FALSE

  PROCEDURE [XREF] nlp$ta_close_sap
    (    sap: nlt$ta_sap_selector;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nlt$ta_sap_selector
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TA_CONNECT_EVENT_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] nlp$ta_connect_event_processor
    (    cl_connection { input, output } : ^nlt$cl_connection;
         event { input, output } : nlt$cc_event;
     VAR inventory_report: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_interface
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$TA_DISCONNECT_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nlp$ta_disconnect_connection
    (    cl_connection { input, output } : ^nlt$cl_connection;
         data { input, output } : nlt$bm_message_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nlt$bm_message_id
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TA_EVENT_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] nlp$ta_event_processor
    (    cl_connection { input, output } : ^nlt$cl_connection;
         event { input, output } : nlt$cc_event;
     VAR inventory_report: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_interface
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$TA_GET_LAYER_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nlp$ta_event_processor
    (    cl_connection: ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: nlt$ta_inventory_report);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_interface
*copyc nlt$cl_connection
*copyc nlt$ta_inventory_report
?? POP ??
*DECK DECK=NLP$TA_INITIALIZE EXPAND=FALSE

  PROCEDURE [XREF] nlp$ta_initialize
    (    application_layer: nlt$cl_application_layer;
         connect_event_processor: nat$network_procedure;
         event_processor: nat$network_procedure);

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_procedure
*copyc nlt$cl_layer_name
?? POP ??
*DECK DECK=NLP$TA_OPEN_SAP EXPAND=FALSE

  PROCEDURE [XREF] nlp$ta_open_sap
    (    application_layer: nlt$cl_application_layer;
         connect_event_processor: nat$network_procedure;
         event_processor: nat$network_procedure;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nat$network_procedure
*copyc nlt$cl_layer_name
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TA_REPORT_UNDELIVERED_DATA EXPAND=FALSE

  PROCEDURE [XREF] nlp$ta_report_undelivered_data
    (    cl_connection { input, output } : ^nlt$cl_connection;
         accumulated_message_buffers: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$TA_REQUEST_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] nlp$ta_request_connection
    (    cl_connection { input, output } : ^nlt$cl_connection;
         sap: nlt$ta_sap_selector;
         checksum: boolean;
         data { input, output } : nlt$bm_message_id;
         destination_transport_sap: nat$osi_transport_sap_selector;
         destination_network_address: nat$osi_network_address;
         cdna_destination_address: boolean;
         expedited_data: boolean;
         priority: nlt$ta_priority;
         preferred_protocol_class: nat$ta_preferred_protocol_class,
         alternate_protocol_class: nat$ta_alternate_protocol_class,
         quality_of_service: ^nlt$ta_quality_of_service;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nat$osi_network_address
*copyc nat$osi_transport_sap_selector
*copyc nat$ta_alternate_protocol_class
*copyc nat$ta_preferred_protocol_class
*copyc nlt$bm_message_id
*copyc nlt$cl_connection
*copyc nlt$ta_priority
*copyc nlt$ta_quality_of_service
*copyc nlt$ta_sap_selector
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TA_SEND_AGGREGATE_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] nlp$ta_send_aggregate_message
    (    cl_connection { input, output } : ^nlt$cl_connection;
         message { input, output } : nlt$ta_aggregate_message;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nlt$ta_aggregate_message
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TA_SEND_DATA EXPAND=FALSE

  PROCEDURE [INLINE] nlp$ta_send_data
    (    cl_connection { input, output } : ^nlt$cl_connection;
         data { input, output } : nlt$bm_message_id;
         end_of_message: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      data_length: integer,
      actual: integer,
      message: nlt$bm_message_id,
      pdu_header: nlt$ta_data_pdu;

    status.normal := TRUE;
    message := data;

{ Validate data.

    nlp$bm_get_message_length (message, data_length);
    IF data_length >= nlc$ta_minimum_data_length THEN

{ Build data pdu.

      pdu_header.length := #SIZE (nlt$ta_data_pdu);
      pdu_header.kind := nlc$ta_data_request;
      pdu_header.end_of_message := end_of_message;

{ Merge data and pdu.

      nlp$bm_add_message_prefix (^pdu_header, pdu_header.length, message);
      nlp$cc_send_data (cl_connection, message, status);

{! statistics begin}

      IF (nav$statistics_enabled) AND (status.normal) THEN
        osp$increment_locked_variable (nav$global_osi_statistics.transport_access_agent.data_pdus_sent, 0,
              actual);
        osp$add_to_locked_variable (nav$global_osi_statistics.
              transport_access_agent.total_bytes_sent, 0, data_length + pdu_header.length, actual);
      IFEND;

{! statistics end}

    ELSE
      nlp$bm_release_message (message);
      osp$set_status_condition (nae$ta_data_length_error, status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            nlc$ta_minimum_data_length, 10, TRUE, status);
    IFEND;
  PROCEND nlp$ta_send_data;

*copy nlh$ta_send_data

*copyc nae$osi_internal_interfaces
*copyc nat$data_length
*copyc nlc$ta_data_lengths
*copyc nlt$bm_message_id
*copyc nlt$cl_connection
*copyc nlt$ta_protocol_data_unit
*copyc ost$status
*copyc nlp$bm_add_message_prefix
*copyc nlp$bm_get_message_length
*copyc nlp$bm_release_message
*copyc nlp$cc_send_data
*copyc osp$add_to_locked_variable
*copyc osp$append_status_integer
*copyc osp$increment_locked_variable
*copyc osp$set_status_condition
*copyc nav$global_osi_statistics
*copyc nav$statistics_enabled
?? POP ??
*DECK DECK=NLP$TA_SEND_DATA_FRAGMENTS EXPAND=FALSE

  PROCEDURE [INLINE] nlp$ta_send_data_fragments
    (    cl_connection { input, output } : ^nlt$cl_connection;
         data: nat$data_fragments;
         end_of_message: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      actual: integer,
      data_length: integer,
      i: integer,
      output_message: ^nat$data_fragments,
      pdu_header: nlt$ta_data_pdu;

    status.normal := TRUE;

  /validate_data/
    BEGIN
      data_length := 0;
      FOR i := LOWERBOUND (data) TO UPPERBOUND (data) DO
        IF (data [i].address <> NIL) THEN
          data_length := data_length + data[i].length;
          IF data_length >= nlc$ta_minimum_data_length THEN
            EXIT /validate_data/;
          IFEND;
        IFEND;
      FOREND;
      osp$set_status_condition (nae$ta_data_length_error, status);
      osp$append_status_integer (osc$status_parameter_delimiter, nlc$ta_minimum_data_length, 10, TRUE,status);
      RETURN;
    END /validate_data/;

{ Build data pdu.

    pdu_header.length := #SIZE (nlt$ta_data_pdu);
    pdu_header.kind := nlc$ta_data_request;
    pdu_header.end_of_message := end_of_message;

    PUSH output_message: [1 .. (UPPERBOUND (data) + 1)];
    output_message^ [1].address := ^pdu_header;
    output_message^ [1].length := #SIZE (pdu_header);
    FOR i := 2 TO UPPERBOUND (output_message^) DO
      output_message^ [i] := data [i - 1];
    FOREND;

    nlp$cc_send_data_fragments (cl_connection, output_message^, status);

{! statistics begin}

    IF (nav$statistics_enabled) AND (status.normal) THEN
      osp$increment_locked_variable (nav$global_osi_statistics.transport_access_agent.data_pdus_sent, 0,
            actual);
      osp$add_to_locked_variable (nav$global_osi_statistics.
            transport_access_agent.total_bytes_sent, 0, data_length + pdu_header.length, actual);
    IFEND;

{! statistics end}

  PROCEND nlp$ta_send_data_fragments;

*copy nlh$ta_send_data_fragments

*copyc nae$osi_internal_interfaces
*copyc nat$data_length
*copyc nlc$ta_data_lengths
*copyc nlt$cl_connection
*copyc nlt$ta_protocol_data_unit
*copyc ost$status
*copyc nlp$cc_send_data_fragments
*copyc osp$add_to_locked_variable
*copyc osp$append_status_integer
*copyc osp$increment_locked_variable
*copyc osp$set_status_condition
*copyc nav$global_osi_statistics
*copyc nav$statistics_enabled
?? POP ??
*DECK DECK=NLP$TA_SEND_EXPEDITED_DATA EXPAND=FALSE

  PROCEDURE [XREF] nlp$ta_send_expedited_data
    (    cl_connection { input, output } : ^nlt$cl_connection;
         data { input, output } : nlt$bm_message_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$namve_conditions
*copyc nlt$bm_message_id
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TCPIP_DECREMENT_APPL_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] nlp$tcpip_decrement_appl_access
     (   application: nat$application_name;
         global_socket_id: nlt$udp_global_socket_id;
         connection_id: nat$connection_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$connection_id
*copyc nlt$udp_global_socket_id
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TCPIP_INCREMENT_APPL_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] nlp$tcpip_increment_appl_access
     (   application: nat$application_name;
         socket_assigned: boolean;
         global_socket_id: nlt$udp_global_socket_id;
         connection_id: nat$connection_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$connection_id
*copyc nlt$udp_global_socket_id
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TCPIP_SET_SOCKET_ASSIGNED EXPAND=FALSE

  PROCEDURE [XREF] nlp$tcpip_set_socket_assigned
    (    application: nat$application_name;
         connection_id: nat$connection_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$application_name
*copyc nat$connection_id
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TCP_ACCEPT_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$tcp_accept_socket
    (    cl_connection { input, output } : ^nlt$cl_connection;
         graceful_close: boolean;
         traffic_pattern: nat$sk_traffic_pattern;
         class: nlt$cc_connection_class;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_traffic_pattern
*copyc nlt$cc_connection_class
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TCP_CONNECT_EVENT_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] nlp$tcp_connect_event_processor
    (    cl_connection { input, output } : ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_interface
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$TCP_CONNECT_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$tcp_connect_socket
    (    cl_connection { input, output } : ^nlt$cl_connection;
         source_socket: nat$sk_socket_address;
         destination_socket: nat$sk_socket_address;
         graceful_close: boolean;
         traffic_pattern: nat$sk_traffic_pattern;
         class: nlt$cc_connection_class;
         device_id: nlt$device_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_socket_address
*copyc nat$sk_traffic_pattern
*copyc nlt$cc_connection_class
*copyc nlt$cl_connection
*copyc nlt$device_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TCP_EVENT_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] nlp$tcp_event_processor
    (    cl_connection { input, output } : ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_interface
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$TCP_FLUSH_RELEASE_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$tcp_flush_release_socket
    (    cl_connection { input, output } : ^nlt$cl_connection;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TCP_FLUSH_RELEASE_TIMER EXPAND=FALSE

  PROCEDURE [XREF] nlp$tcp_flush_release_timer
    (    current_time: integer;
         cl_connection: ^nlt$cl_connection);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$TCP_INITIALIZE EXPAND=FALSE

  PROCEDURE [XREF] nlp$tcp_initialize
    (    application_layer: nlt$cl_application_layer;
         connect_event_processor: nat$network_procedure;
         event_processor: nat$network_procedure);

?? PUSH (LISTEXT := ON) ??
*copyc nat$network_procedure
*copyc nlt$cl_layer_name
?? POP ??
*DECK DECK=NLP$TCP_LISTEN_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$tcp_listen_socket
    (    cl_connection { input, output } : ^nlt$cl_connection;
         local_port: nat$sk_port_number;
         queue_limit: nat$sk_listen_queue_limit;
         selection_criteria: nat$sk_socket_address;
         device_id: nlt$device_identifier;
         class: nlt$cc_connection_class;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_listen_queue_limit
*copyc nat$sk_socket_address
*copyc nlt$cc_connection_class
*copyc nlt$cl_connection
*copyc nlt$device_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TCP_RELEASE_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$tcp_release_socket
    (    cl_connection { input, output } : ^nlt$cl_connection;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TCP_REPORT_UNDELIVERED_DATA EXPAND=FALSE

  PROCEDURE [XREF] nlp$tcp_report_undelivered_data
    (    cl_connection { input, output } : ^nlt$cl_connection;
         accumulated_message_buffers: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$TCP_SEND_DATA EXPAND=FALSE

  PROCEDURE [XREF] nlp$tcp_send_data
    (    cl_connection { input, output } : ^nlt$cl_connection;
         user_data: nlt$bm_message_id;
         push_data: boolean;
         urgent_data: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_id
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TCP_SEND_DATA_FRAGMENTS EXPAND=FALSE

  PROCEDURE [XREF] nlp$tcp_send_data_fragments
    (    cl_connection { input, output } : ^nlt$cl_connection;
         user_data: nat$data_fragments;
         push_data: boolean;
         urgent_data: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TCP_SET_SOCKET_OPTIONS EXPAND=FALSE

  PROCEDURE [XREF] nlp$tcp_set_socket_options
    (    cl_connection { input, output } : ^nlt$cl_connection;
         graceful_close: boolean;
         traffic_pattern: nat$sk_traffic_pattern;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_traffic_pattern
*copyc nlt$cl_connection
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TIMER_COUNT EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc nlt$timer
?? POP ??

  FUNCTION [INLINE] nlp$timer_count (timer: nlt$timer): nlt$timer_count;

?? PUSH (LISTEXT := ON) ??
*copy nlh$timer_count
    IF timer.selected THEN
      nlp$timer_count := timer.count;
    ELSE
      nlp$timer_count := 0;
    IFEND;
  FUNCEND nlp$timer_count;
?? POP ??
*DECK DECK=NLP$TIMER_EXPIRED EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc nlt$timer
?? POP ??

  FUNCTION [INLINE] nlp$timer_expired (current_time: integer;
        timer: nlt$timer): boolean;

?? PUSH (LISTEXT := ON) ??
*copy nlh$timer_expired
    nlp$timer_expired := (timer.selected AND (current_time > timer.expiration_time));
  FUNCEND nlp$timer_expired;
?? POP ??
*DECK DECK=NLP$TM_CONNECT_EVENT_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] nlp$tm_connect_event_processor
    (    cl_connection { input, output } : ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_interface
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$TM_DEFINE_TCPIP_HOST EXPAND=FALSE

  PROCEDURE [XREF] nlp$tm_define_tcpip_host
   (    host_name: string (*);
        forward_search_range: nlt$tm_search_range);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$tm_search_range
?? POP ??
*DECK DECK=NLP$TM_EVENT_PROCESSOR EXPAND=FALSE

  PROCEDURE [XREF] nlp$tm_event_processor
    (    cl_connection { input, output } : ^nlt$cl_connection;
         event: nlt$cc_event;
     VAR inventory_report: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_interface
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$TM_GET_DEVICE_BY_NAME EXPAND=FALSE

  PROCEDURE [XREF] nlp$tm_get_device_by_name
   (    local_device_name: cmt$element_name;
    VAR local_device_id: nlt$device_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc nlt$device_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TM_GET_LOCAL_ADDRESSES EXPAND=FALSE

  PROCEDURE [INLINE] nlp$tm_get_local_addresses
    (VAR local_addresses: nat$sk_local_addresses;
     VAR count: integer);

?? PUSH (LISTEXT := ON) ??

    VAR
      i: integer;

    count := 0;
    FOR i := 1 TO nlv$tm_device_configuration^.count DO
      CASE nlv$tm_device_configuration^.list [i].protocol of
      = nlc$tm_udp =
        count := count + 1;
        local_addresses [count].local_address := nlv$tm_device_configuration^.list [i].local_device_address.
              full;
        local_addresses [count].supported_protocol := nac$sk_udp;
      = nlc$tm_tcp =
        count := count + 1;
        local_addresses [count].local_address := nlv$tm_device_configuration^.list [i].local_device_address.
              full;
        local_addresses [count].supported_protocol := nac$sk_tcp;
      = nlc$tm_tcp_udp =
        count := count + 1;
        local_addresses [count].local_address := nlv$tm_device_configuration^.list [i].local_device_address.
              full;
        local_addresses [count].supported_protocol := nac$sk_udp_and_tcp;
      ELSE
      CASEND;
      IF count >= UPPERBOUND (local_addresses) THEN
        RETURN;
      IFEND;
    FOREND;
  PROCEND nlp$tm_get_local_addresses;
*copy nlh$tm_get_local_addresses

*copyc nat$sk_local_addresses
*copyc nlv$tm_device_configuration
?? POP ??

*DECK DECK=NLP$TM_GET_LOCAL_TCP_DEVICES EXPAND=FALSE

  PROCEDURE [INLINE] nlp$tm_get_local_tcp_devices
    (VAR device_list: nlt$tm_device_address_list;
     VAR count: nlt$device_count);

?? PUSH (LISTEXT := ON) ??

    VAR
      i: integer;

    count := 0;

  /tcp_device_loop/
    FOR i := 1 TO nlv$tm_device_configuration^.count DO
      CASE nlv$tm_device_configuration^.list [i].protocol OF
      = nlc$tm_tcp_udp, nlc$tm_tcp =
        count := count + 1;
        device_list [count].address := nlv$tm_device_configuration^.
              list [i].local_device_address.full;
        device_list [count].device_id := i;
        IF count = UPPERBOUND (device_list) THEN
          EXIT /tcp_device_loop/;
        IFEND;
      ELSE
        ;
      CASEND;
    FOREND /tcp_device_loop/;
  PROCEND nlp$tm_get_local_tcp_devices;
*copy nlh$tm_get_local_tcp_devices

*copyc nlt$device_count
*copyc nlt$tm_device_address_list
*copyc nlv$tm_device_configuration
?? POP ??

*DECK DECK=NLP$TM_GET_LOCAL_UDP_DEVICES EXPAND=FALSE

  PROCEDURE [INLINE] nlp$tm_get_local_udp_devices
    (VAR device_list: nlt$tm_device_address_list;
     VAR count: nlt$device_count);

?? PUSH (LISTEXT := ON) ??

    VAR
      i: integer;

    count := 0;

  /udp_device_loop/
    FOR i := 1 TO nlv$tm_device_configuration^.count DO
      CASE nlv$tm_device_configuration^.list [i].protocol OF
      = nlc$tm_tcp_udp, nlc$tm_udp =
        count := count + 1;
        device_list [count].address := nlv$tm_device_configuration^.
              list [i].local_device_address.full;
        device_list [count].device_id := i;
        IF count = UPPERBOUND (device_list) THEN
          EXIT /udp_device_loop/;
        IFEND;
      ELSE
        ;
      CASEND;
    FOREND /udp_device_loop/;
  PROCEND nlp$tm_get_local_udp_devices;
*copy nlh$tm_get_local_udp_devices

*copyc nlt$device_count
*copyc nlt$tm_device_address_list
*copyc nlv$tm_device_configuration
?? POP ??
*DECK DECK=NLP$TM_GET_STATIC_ROUTES EXPAND=FALSE

  PROCEDURE [XREF] nlp$tm_get_static_routes
     (    static_routes: ^nlt$tm_static_route_definitions;
      VAR count: integer;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$tm_static_route_definitions
*copyc ost$status
?? POP ??

*DECK DECK=NLP$TM_GET_TCPIP_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] nlp$tm_get_tcpip_attributes
   (VAR forward_search_range: nlt$tm_search_range;
    VAR refresh_interval: nlt$tm_cache_interval;
    VAR stale_release_interval: nlt$tm_cache_interval;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$tm_cache_interval
*copyc nlt$tm_search_range
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TM_GET_UDP_DEVICE EXPAND=FALSE

  PROCEDURE [INLINE] nlp$tm_get_udp_device
    (    local_address: nlt$tcpip_address;
     VAR device_id: nlt$device_identifier);

?? PUSH (LISTEXT := ON) ??

    VAR
      i: nlt$device_identifier;

    device_id := 0;

  /udp_device_search/
    FOR i := 1 TO nlv$tm_device_configuration^.count DO
      IF nlv$tm_device_configuration^.list [i].local_device_address.full =
            local_address.full THEN
        device_id := i;
        EXIT /udp_device_search/;
      IFEND;
    FOREND /udp_device_search/;
  PROCEND nlp$tm_get_udp_device;

*copyc nlh$tm_get_udp_device

*copyc nlt$device_identifier
*copyc nlt$tcpip_address
*copyc nlv$tm_device_configuration
?? POP ??
*DECK DECK=NLP$TM_GET_UDP_DEVICE_LIST EXPAND=FALSE

  PROCEDURE [INLINE] nlp$tm_get_udp_device_list
    (VAR device_list: ^nlt$tm_udp_device_list;
     VAR device_list_count: nlt$device_count);

?? PUSH (LISTEXT := ON) ??

    VAR
      i: nlt$device_identifier,
      index: nlt$device_identifier;

    device_list_count := nlv$tm_device_configuration^.udp.count;
    IF device_list_count > 0 THEN

      PUSH device_list: [1 .. device_list_count];
      index := 0;
    /udp_device_search/
      FOR i := 1 TO nlv$tm_device_configuration^.count DO
        CASE nlv$tm_device_configuration^.list [i].protocol OF
        = nlc$tm_tcp_udp, nlc$tm_udp =
          index := index + 1;
          device_list^ [index].identifier := i;
          device_list^ [index].local_address :=
                nlv$tm_device_configuration^.list [i].local_device_address;
          IF index = device_list_count THEN
            EXIT /udp_device_search/;
          IFEND;
        ELSE
        CASEND;
      FOREND /udp_device_search/;
      device_list_count := index;
    IFEND;
  PROCEND nlp$tm_get_udp_device_list;

*copyc nlh$tm_get_udp_device_list

*copyc nlt$device_count
*copyc nlt$device_identifier
*copyc nlt$tm_udp_device_list
*copyc nlv$tm_device_configuration
?? POP ??
*DECK DECK=NLP$TM_INITIALIZE EXPAND=FALSE

  PROCEDURE [XREF] nlp$tm_initialize;
*DECK DECK=NLP$TM_INSTALL_STATIC_ROUTES EXPAND=FALSE

  PROCEDURE [XREF] nlp$tm_install_static_routes
     (    static_routes: ^nlt$tm_static_route_definition;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$tm_static_route_definition
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TM_SELECT_BY_LOCAL_TCP_ADDR EXPAND=FALSE

  PROCEDURE [INLINE] nlp$tm_select_by_local_tcp_addr
    (    local_address: nat$sk_ip_address;
     VAR device_id: nlt$device_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      address: nlt$tcpip_address,
      error_length: integer,
      error_string: string (20),
      i: integer;

    status.normal := TRUE;
  /tcp_device_search_loop/
    FOR i := 1 TO nlv$tm_device_configuration^.count DO
      IF nlv$tm_device_configuration^.list [i].local_device_address.full = local_address THEN
        CASE nlv$tm_device_configuration^.list [i].protocol OF
        = nlc$tm_tcp_udp, nlc$tm_tcp =
          device_id := i;
        ELSE
          address.full := local_address;
          STRINGREP (error_string, error_length, address.sub_part [1], '.', address.sub_part [2], '.',
                address.sub_part [3], '.', address.sub_part [4]);
          osp$set_status_abnormal (nac$status_id, nae$tm_addr_not_for_tcp_device,
                error_string (1, error_length), status);
        CASEND;
        RETURN;
      IFEND;
    FOREND /tcp_device_search_loop/;
    address.full := local_address;
    STRINGREP (error_string, error_length, address.sub_part [1], '.', address.sub_part [2], '.',
          address.sub_part [3], '.', address.sub_part [4]);
    osp$set_status_abnormal (nac$status_id, nae$tm_local_address_not_found,
                error_string (1, error_length), status);
  PROCEND nlp$tm_select_by_local_tcp_addr;

*copyc nlh$tm_select_by_local_tcp_addr

*copyc nae$tcpip_mgmt_condition_codes
*copyc nat$sk_ip_address
*copyc nlt$device_identifier
*copyc nlt$tcpip_address
*copyc nlv$tm_device_configuration
*copyc ost$status
*copyc osp$set_status_abnormal
?? POP ??

*DECK DECK=NLP$TM_SELECT_BY_LOCAL_UDP_ADDR EXPAND=FALSE

  PROCEDURE [INLINE] nlp$tm_select_by_local_udp_addr
    (    local_address: nat$sk_ip_address;
     VAR device_id: nlt$device_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      address: nlt$tcpip_address,
      error_length: integer,
      error_string: string (20),
      i: integer;

    status.normal := TRUE;
  /udp_device_search_loop/
    FOR i := 1 TO nlv$tm_device_configuration^.count DO
      IF nlv$tm_device_configuration^.list [i].local_device_address.full = local_address THEN
        CASE nlv$tm_device_configuration^.list [i].protocol OF
        = nlc$tm_tcp_udp, nlc$tm_udp =
          device_id := i;
        ELSE
          address.full := local_address;
          STRINGREP (error_string, error_length, address.sub_part [1], '.', address.sub_part [2], '.',
                address.sub_part [3], '.', address.sub_part [4]);
          osp$set_status_abnormal (nac$status_id, nae$tm_addr_not_for_udp_device,
                error_string (1, error_length), status);
        CASEND;
        RETURN;
      IFEND;
    FOREND /udp_device_search_loop/;
    address.full := local_address;
    STRINGREP (error_string, error_length, address.sub_part [1], '.', address.sub_part [2], '.',
          address.sub_part [3], '.', address.sub_part [4]);
    osp$set_status_abnormal (nac$status_id, nae$tm_local_address_not_found,
                error_string (1, error_length), status);
  PROCEND nlp$tm_select_by_local_udp_addr;

*copyc nlh$tm_select_by_local_udp_addr

*copyc nae$tcpip_mgmt_condition_codes
*copyc nat$sk_ip_address
*copyc nlt$device_identifier
*copyc nlt$tcpip_address
*copyc nlv$tm_device_configuration
*copyc ost$status
*copyc osp$set_status_abnormal
?? POP ??
*DECK DECK=NLP$TM_TCP_SELECT_DEVICE EXPAND=FALSE

  PROCEDURE [XREF] nlp$tm_tcp_select_device
    (    destination_address: nat$sk_ip_address;
     VAR device_id: nlt$device_identifier;
     VAR local_address: nat$sk_ip_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$tcpip_mgmt_condition_codes
*copyc nat$sk_ip_address
*copyc nlt$device_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TM_UDP_SELECT_DEVICE EXPAND=FALSE

  PROCEDURE [XREF] nlp$tm_udp_select_device
    (    destination_address: nat$sk_ip_address;
     VAR device_id: nlt$device_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$tcpip_mgmt_condition_codes
*copyc nat$sk_ip_address
*copyc nlt$device_identifier
*copyc ost$status
?? POP ??
*DECK DECK=NLP$TRANSLATE_TITLE EXPAND=FALSE
 PROCEDURE [XREF] nlp$translate_title (title: string ( * <=
  nac$max_title_length);
        wild_card: boolean;
        protocol: nat$protocol;
        recurrent_search: boolean;
        search_domain: nat$title_domain;
        class: nat$title_class;
    VAR request_id: nat$directory_search_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nae$application_interfaces
*copyc nae$directory_me_conditions
*copyc nat$directory_search_identifier
*copyc nat$directory_interfaces
*copyc nat$protocol
*copyc nat$title
*copyc ost$status
?? POP ??
*DECK DECK=NLP$UDP_ACTIVATE_RECEIVER EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_activate_receiver
    (    active_receiver: ^nlt$udp_active_receiver;
     VAR another_receiver_active: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_active_receiver
?? POP ??
*DECK DECK=NLP$UDP_ALLOCATE_RECEIVER EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_allocate_receiver
    (VAR  active_receiver: ^nlt$udp_active_receiver);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_active_receiver
?? POP ??
*DECK DECK=NLP$UDP_AWAIT_CLEAR_TO_SEND EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_await_clear_to_send
    (    global_socket_id: nlt$udp_global_socket_id;
         wait: boolean;
     VAR activity_complete: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_global_socket_id
?? POP ??
*DECK DECK=NLP$UDP_AWAIT_DATA_AVAILABLE EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_await_data_available
    (    global_socket_id: nlt$udp_global_socket_id;
         wait: boolean;
     VAR activity_complete: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_global_socket_id
?? POP ??
*DECK DECK=NLP$UDP_BIND_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_bind_socket
    (    global_socket_id: nlt$udp_global_socket_id;
         port: nat$sk_port_number;
         traffic_pattern: nat$sk_traffic_pattern,
         ip_address: nat$sk_ip_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_ip_address
*copyc nat$sk_port_number
*copyc nat$sk_traffic_pattern
*copyc nlt$udp_global_socket_id
*copyc ost$status
?? POP ??

*DECK DECK=NLP$UDP_CANCEL_SOCKET_OFFER EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_cancel_socket_offer
    (    global_socket_id: nlt$udp_global_socket_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_global_socket_id
*copyc ost$status
?? POP ??
*DECK DECK=NLP$UDP_CLEAR_EXCLUSIVE_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_clear_exclusive_access
    (VAR global_socket {INPUT, OUTPUT} : ^nlt$udp_global_socket);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_global_socket
?? POP ??
*DECK DECK=NLP$UDP_CLOSE_SOCKET EXPAND=FALSE

    PROCEDURE [XREF] nlp$udp_close_socket
      (    global_socket_id: nlt$udp_global_socket_id;
           terminate_via_application_mgmt: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_global_socket_id
?? POP ??
*DECK DECK=NLP$UDP_CONNECT_EVENT_PROCESSOR EXPAND=FALSE

    PROCEDURE [XREF] nlp$udp_connect_event_processor
      (    cl_connection: ^nlt$cl_connection;
           event: nlt$cc_event;
       VAR inventory_report: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_interface
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$UDP_CREATE_GLOBAL_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_create_global_socket
    (VAR global_socket: ^nlt$udp_global_socket);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_global_socket
?? POP ??

*DECK DECK=NLP$UDP_DEACTIVATE_RECEIVER EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_deactivate_receiver
    (    active_receiver: ^nlt$udp_active_receiver);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_active_receiver
?? POP ??
*DECK DECK=NLP$UDP_DEALLOCATE_RECEIVER EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_deallocate_receiver
    (VAR  active_receiver: ^nlt$udp_active_receiver);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_active_receiver
?? POP ??
*DECK DECK=NLP$UDP_DELETE_GLOBAL_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_delete_global_socket
    (    global_socket_id: nlt$udp_global_socket_id);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_global_socket_id
?? POP ??
*DECK DECK=NLP$UDP_DEVICE_AVAILABLE EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_device_available
    (    device_id: nlt$device_identifier;
         local_ip_address: nat$sk_ip_address);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_ip_address
*copyc nlt$device_identifier
?? POP ??
*DECK DECK=NLP$UDP_EVENT_PROCESSOR EXPAND=FALSE

    PROCEDURE [XREF] nlp$udp_event_processor
      (    cl_connection: ^nlt$cl_connection;
           event: nlt$cc_event;
       VAR inventory_report: integer);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_interface
*copyc nlt$cl_connection
?? POP ??
*DECK DECK=NLP$UDP_FREE_EXCLUSIVE_ACCESS EXPAND=FALSE

  PROCEDURE [INLINE] nlp$udp_free_exclusive_access
    (VAR global_socket {INPUT, OUTPUT} : ^nlt$udp_global_socket);

?? PUSH (LISTEXT := ON) ??

    osp$clear_job_signature_lock (global_socket^.lock);
    osp$end_subsystem_activity;
    global_socket := NIL;

  PROCEND nlp$udp_free_exclusive_access;

*copy nlh$udp_free_exclusive_access

*copyc nlt$udp_global_socket
*copyc osp$clear_job_signature_lock
*copyc osp$end_subsystem_activity
?? POP ??
*DECK DECK=NLP$UDP_FREE_NONEXCLU_TO_ROOT EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_free_nonexclu_to_root
    (    root: nlt$udp_reference_number);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_reference_number
?? POP ??
*DECK DECK=NLP$UDP_GET_BOUND_ADDRESSES EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_get_bound_addresses
    (    global_socket_id: nlt$udp_global_socket_id;
     VAR local_addresses: array [1 .. * ] of nat$sk_ip_address;
     VAR count: nlt$device_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_ip_address
*copyc nlt$device_count
*copyc nlt$udp_global_socket_id
*copyc ost$status
?? POP ??
*DECK DECK=NLP$UDP_GET_EXCLUSIVE_ACCESS EXPAND=FALSE

  PROCEDURE [INLINE] nlp$udp_get_exclusive_access
    (VAR lock: ost$signature_lock);

?? PUSH (LISTEXT := ON) ??
    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (lock);
  PROCEND nlp$udp_get_exclusive_access;

*copy nlh$udp_get_exclusive_access

*copyc osp$begin_subsystem_activity
*copyc osp$set_job_signature_lock
?? POP ??
*DECK DECK=NLP$UDP_GET_EXCLUSIVE_VIA_GSID EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_get_exclusive_via_gsid
    (    global_socket_id: nlt$udp_global_socket_id;
     VAR global_socket: ^nlt$udp_global_socket);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_global_socket
*copyc nlt$udp_global_socket_id
?? POP ??
*DECK DECK=NLP$UDP_GET_NONEXCLU_TO_ROOT EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_get_nonexclu_to_root
    (    root: nlt$udp_reference_number);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_reference_number
?? POP ??
*DECK DECK=NLP$UDP_GET_SOCKET_STATUS EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_get_socket_status
    (    global_socket_id: nlt$udp_global_socket_id;
     VAR clear_to_send: boolean;
     VAR data_pending_receive: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_global_socket_id
*copyc ost$status
?? POP ??
*DECK DECK=NLP$UDP_INITIALIZE EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_initialize;
*DECK DECK=NLP$UDP_OFFER_SOCKET EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_offer_socket
    (    global_socket_id: nlt$udp_global_socket_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_global_socket_id
*copyc ost$status
?? POP ??
*DECK DECK=NLP$UDP_RECEIVE_DATA EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_receive_data
    (    global_socket_id: nlt$udp_global_socket_id;
         time_stamp: ost$free_running_clock;
         selection_criteria: nat$sk_socket_address;
         user_cache_enabled: boolean;
         interface_mode: nat$sk_interface_mode;
         interface_timeout: nat$wait_time;
         data: nat$data_fragments;
     VAR foreign_socket: nat$sk_socket_address;
     VAR local_ip_address: nat$sk_ip_address;
     VAR data_length: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
*copyc nat$sk_interface_mode
*copyc nat$sk_ip_address
*copyc nat$sk_socket_address
*copyc nat$wait_time
*copyc nlt$udp_global_socket_id
*copyc ost$free_running_clock
*copyc ost$status
?? POP ??
*DECK DECK=NLP$UDP_REMOVE_CLEAR_TO_SEND EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_remove_clear_to_send
      (    global_socket_id: nlt$udp_global_socket_id);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_global_socket_id
?? POP ??
*DECK DECK=NLP$UDP_REMOVE_DATA_AVAILABLE EXPAND=FALSE

    PROCEDURE [XREF] nlp$udp_remove_data_available
      (    global_socket_id: nlt$udp_global_socket_id);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_global_socket_id
?? POP ??
*DECK DECK=NLP$UDP_SEND_DATA EXPAND=FALSE

    PROCEDURE [XREF] nlp$udp_send_data
      (    global_socket_id: nlt$udp_global_socket_id;
           time_stamp: ost$free_running_clock;
           local_ip_address: nat$sk_ip_address;
           destination_socket: nat$sk_socket_address;
           data: nat$data_fragments;
           data_length: integer;
           checksum: boolean;
           interface_mode: nat$sk_interface_mode;
           interface_timeout: nat$wait_time;
           user_cache_enabled: boolean;
       VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$data_fragments
*copyc nat$sk_interface_mode
*copyc nat$sk_ip_address
*copyc nat$sk_socket_address
*copyc nat$wait_time
*copyc nlt$udp_global_socket_id
*copyc ost$free_running_clock
*copyc ost$status
?? POP ??
*DECK DECK=NLP$UDP_SET_SOCKET_OPTIONS EXPAND=FALSE

    PROCEDURE [XREF] nlp$udp_set_socket_options
      (    global_socket_id: nlt$udp_global_socket_id;
           traffic_pattern: nat$sk_traffic_pattern;
           broadcast_enabled: boolean;
       VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc nat$sk_traffic_pattern
*copyc nlt$udp_global_socket_id
*copyc ost$status
?? POP ??
*DECK DECK=NLP$UDP_STORE_RECEIVER EXPAND=FALSE

  PROCEDURE [XREF] nlp$udp_store_receiver
    (     active_receiver: ^nlt$udp_active_receiver;
          cl_connection: ^nlt$cl_connection);

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nlt$udp_active_receiver
?? POP ??
*DECK DECK=NLP$UNSIMULATE_CONNECTION_BROKE EXPAND=FALSE

  PROCEDURE [XREF] nlp$unsimulate_connection_broke (
        file: fst$file_reference;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc FST$FILE_REFERENCE
*copyc OST$STATUS
?? POP ??
*DECK DECK=NLT$ACCESS_CONTROL EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  { The access control record provides the vehicle by which exclusive and nonexclusive
  { access to structures is controlled.  Get and release exclusive/nonexclusive access
  { procedures  are  provided  to support the control mechanics.  In general exclusive
  { access permits an accessor to modify a structure.  Nonexclusive access permits  an
  { accessor to interogate a structure.

  TYPE
    nlt$access_control = record
      nonexclusive_accessors: ALIGNED [0 MOD 8] 0 .. 0ffffffff(16),
      exclusive: boolean,
      fill: 0 .. 0ffffff(16),
    recend;
*DECK DECK=NLT$AL_DATA_DESCRIPTION EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  TYPE
    nlt$al_data_description = record
      current_lowerbound: 0 .. nac$max_data_fragment_count * nac$max_data_fragment_count,
      data_length: nat$data_length,
      fragment: nat$data_fragments,
    recend;

*copyc nat$data_fragments
*DECK DECK=NLT$BM_ALLOCATED_BUFFER_POOL EXPAND=FALSE

  TYPE
    nlt$bm_allocated_buffer_pool = array [ nlt$bm_pool_index ] of nlt$bm_allocated_pool_descr,

    nlt$bm_allocated_pool_descr = record
      last_lowest_available_sub_pool: 1 .. 0ffff(16), { Indicates the search starting point.
      highest_allocated_sub_pool: 1 .. 0ffff(16), { Indicates the ending point.
      buffer_length: nlt$bm_buffer_length,
      sub_pool_allocation_size: nlt$bm_buffer_count, { Number of buffers per sub pool.
      sub_pool: ^array [1 .. * ] of nlt$bm_allocatd_buffer_sub_pool, { 100 large and 200 small sub pools.
    recend,

    nlt$bm_allocatd_buffer_sub_pool = record
      head: ^nlt$bm_message_descriptor,            { Points to the first buffer.
      allocated_memory: ^nlt$bm_allocated_memory,   { Points to the allocated memory block.
      count: 0 .. 0ff(16),                          { Number of available descriptors queued.
    recend;

*copyc nlt$bm_allocated_memory
*copyc nlt$bm_buffer_count
*copyc nlt$bm_message_descriptor
*copyc nlt$bm_pool_index

*DECK DECK=NLT$BM_ALLOCATED_MEMORY EXPAND=FALSE

  TYPE
    nlt$bm_allocated_memory = array [1 .. * ] of cell;

*DECK DECK=NLT$BM_BUFFER_COUNT EXPAND=FALSE

  TYPE
    nlt$bm_buffer_count = 0 .. 0ffff(16);
*DECK DECK=NLT$BM_BUFFER_LENGTH EXPAND=FALSE

  TYPE
    nlt$bm_buffer_length = 0 .. 0ffff(16);
*DECK DECK=NLT$BM_BUFFER_LIST_ARRAY EXPAND=FALSE

 TYPE
    nlt$bm_buffer_list_array = array [nlt$bm_pool_index] of nlt$bm_buffer_list,

    nlt$bm_buffer_list = record
      count: nlt$bm_buffer_count,
      buffer_list: ^array [1 .. * ] of ^nlt$bm_message_descriptor,
    recend;

*copyc nlt$bm_buffer_count
*copyc nlt$bm_message_descriptor
*copyc nlt$bm_pool_index

*DECK DECK=NLT$BM_BUFFER_MANAGER_CONTROL EXPAND=FALSE

  TYPE
    nlt$bm_buffer_manager_control = record
      lock: ALIGNED [0 MOD 8] ost$signature_lock,
    recend;

*copyc ost$signature_lock
*DECK DECK=NLT$BM_BUFFER_POOL EXPAND=FALSE

  TYPE
    nlt$bm_buffer_pool = array [nlt$bm_pool_index] of nlt$bm_buffer_pool_descriptor,

    nlt$bm_buffer_pool_descriptor = record
      length: nlt$bm_buffer_length,        { The size of the buffers.
      count: nlt$bm_buffer_count,          { Number of buffers queued including dynamic.
      pool_limit: nlt$bm_buffer_count,     { Target limit of buffers queued.
      head: ^nlt$bm_message_descriptor,    { Points to the first buffer.
      tail: ^^nlt$bm_message_descriptor,   { Points to the link field of the last buffer.
      allocated_memory: ^nlt$bm_allocated_memory, {Points to the allocated memory block.
      dynamic_buffers: nlt$bm_buffer_count,{ Number of dynamic buffers is initially zero.
    recend;

*copyc nlt$bm_allocated_memory
*copyc nlt$bm_buffer_count
*copyc nlt$bm_message_descriptor
*copyc nlt$bm_pool_index
*DECK DECK=NLT$BM_MESSAGE_DESCRIPTOR EXPAND=FALSE

  TYPE
    nlt$bm_message_descriptor = record
      link: ^nlt$bm_message_descriptor,       { Pointer to the next descriptor.
      container: ^nlt$bm_container,            { Pointer to a container, should never change.
      container_length: nlt$bm_buffer_length , { Length of the container.
      data_start: nlt$bm_buffer_length,        { data_start + 1 indexes to the first byte of data.
      pool_index: nlt$bm_pool_index,           { Indexes the buffer pools.  Determines whether large or small.
      sub_pool_index: nlt$bm_sub_pool_index,   { 0 represents a static buffer non zero indexes the sub pool.
      sequence_number: nlt$bm_sequence_number, { Updated each time the message is changed.
      received_message: nlt$received_message_descriptor, { Additional info on received data.
    recend,

    nlt$bm_container = string (*),

    nlt$bm_sub_pool_index = 0 .. 0ffff(16);

*copyc nlt$bm_buffer_length
*copyc nlt$bm_pool_index
*copyc nlt$bm_sequence_number
*copyc nlt$received_message_descriptor
*DECK DECK=NLT$BM_MESSAGE_ID EXPAND=FALSE
{
{  PURPOSE:
{    Nlt$bm_message_id is the record used to uniquely identify buffer manager
{    messages.
{
{  FIELDS:
{    descriptor - pointer to the actual message.
{    sequence_number - value used to validate the message.  The sequence number
{          of the message_id  must match the sequence number of the first
{          message descriptor. This is to prevent releasing a stale message id.
{          The sequence number is changed whenever the message is changed
{

  TYPE
    nlt$bm_message_id = record
      descriptor: ^nlt$bm_message_descriptor,
      sequence_number: nlt$bm_sequence_number,
    recend;

*copyc nlt$bm_message_descriptor
*copyc nlt$bm_sequence_number
*DECK DECK=NLT$BM_POOL_INDEX EXPAND=TRUE

  TYPE
    nlt$bm_pool_index = nlc$bm_small_buffer_index .. nlc$bm_large_buffer_index;

*copyc nlc$bm_buffer_pool_index
*DECK DECK=NLT$BM_SEQUENCE_NUMBER EXPAND=FALSE

  CONST
    nlc$bm_maximum_sequence_number = 0ffff(16),

    nlc$bm_sequence_space = nlc$bm_maximum_sequence_number + 1;

  TYPE
    nlt$bm_sequence_number = 0 .. nlc$bm_maximum_sequence_number;
*DECK DECK=NLT$BUFFER_POOL_STATUS EXPAND=FALSE

  TYPE
   nlt$buffer_pool_status = (nlc$buffer_pool_empty, nlc$buffer_pool_below_threshold, nlc$buffer_pool_ok);
*DECK DECK=NLT$CC_ADDRESS EXPAND=FALSE
{  NLT$CC_ADDRESS  }

CONST
  nlc$network_access_address = 1,
  nlc$transport_access_address = 2,
  nlc$link_access_address = 3,
  nlc$system_management_address = 4,
  nlc$udp_access_address = 5,
  nlc$tcp_access_address = 6,
  nlc$tcpip_management_address = 7;

TYPE
  nlt$cc_address = 0 .. 0ff(16);

*DECK DECK=NLT$CC_AGGREGATE_MESSAGE EXPAND=FALSE

  TYPE
    nlt$cc_aggregate_message = array [1 .. * ] of nlt$cc_aggregate,

    nlt$cc_aggregate = record
      case kind: nlt$cc_event_kind of
      = nlc$cc_data_event =
        data: nlt$bm_message_id,
      = nlc$cc_expedited_data_event =
        expedited_data: nlt$bm_message_id,
      casend,
    recend;

*copyc nlt$bm_message_id
*copyc nlt$cc_interface
*DECK DECK=NLT$CC_CONNECTION EXPAND=FALSE
{ NLT$CC_CONNECTION }

TYPE
  nlt$cc_connection_state = (nlc$cc_closed, nlc$cc_connect_confirm_wait,
    nlc$cc_connect_response_wait, nlc$cc_open, nlc$cc_closing),

  nlt$cc_connection = record
    accumulated_message_buffers: integer,
    event_processor: nat$network_procedure,
    connection_id: nlt$cl_connection_id,
    peer_reference_number: nlt$cl_reference_number,
    class: nlt$cc_connection_class,
    device_specific_attributes: nlt$cc_device_specific_attr,
    buffers_per_credit: nlt$bm_buffer_count,
    next_deliverable_sequence#: nlt$cc_sequence_number,
    receive_buffer: ^nlt$cc_received_pdu,
    receive_credits: nlt$cc_credits,
    send_credits: nlt$cc_credits,
    send_buffer: nlt$cc_send_buffer,
    sub_connection_count: 0 .. 0ff(16),
    sub_connections: ^array [1 .. *] of nlt$cc_device_specific_attr,
    no_buffers_for_peer_credit: nlt$timer,
    no_buffers_for_user_capacity: nlt$timer,
  recend,

  nlt$cc_device_specific_attr = record
    device_id: nlt$device_identifier,
    maximum_data_length: nlt$cc_pdu_size,
    state: nlt$cc_connection_state,
  recend,

  nlt$cc_received_pdu = record
    next_cc_pdu: ^nlt$cc_received_pdu,
    device_id: nlt$device_identifier,
    sequence_number: nlt$cc_sequence_number,
    cc_header: nlt$cc_protocol_header,
    data: nlt$bm_message_id,
  recend,

  nlt$cc_send_buffer = record
    inn: nlt$cc_send_buffer_limit,
    out: nlt$cc_send_buffer_limit,
    cc_pdu: array [0 .. (nlc$cc_send_buffer_limit - 1)] of nlt$cc_outgoing_pdu,
    extension: ^nlt$cc_send_buffer_extension,
  recend,

  nlt$cc_send_buffer_extension = record
    nextt: ^nlt$cc_send_buffer_extension,
    cc_pdu: nlt$cc_outgoing_pdu,
  recend,

  nlt$cc_outgoing_pdu = record
    data: nlt$bm_message_id,
  recend,

  nlt$cc_send_buffer_limit = 0 .. nlc$cc_send_buffer_limit;

CONST
  nlc$cc_send_buffer_limit = 8,
  nlc$lower_layer_overhead = 24; {Max TAA, TCPAA, UDPAA PDU header size.

*copyc nat$network_procedure
*copyc nlt$bm_buffer_count
*copyc nlt$bm_message_id
*copyc nlt$cc_connection_class
*copyc nlt$cc_credits
*copyc nlt$cc_pdu_size
*copyc nlt$cc_protocol_data_unit
*copyc nlt$cc_sequence_number
*copyc nlt$cl_connection
*copyc nlt$device_identifier
*copyc nlt$timer
*DECK DECK=NLT$CC_CONNECTION_CLASS EXPAND=FALSE
{  NLT$CC_CONNECTION_CLASS  }

CONST
  nlc$cc_normal_class = 0,
  nlc$cc_priority_class = 1;

TYPE
  nlt$cc_connection_class = 0 .. 0ff(16);
*DECK DECK=NLT$CC_CREDITS EXPAND=FALSE

TYPE
  nlt$cc_credits = 0 .. 0ff(16);
*DECK DECK=NLT$CC_DEVICE_AND_DATA_LIST EXPAND=FALSE

TYPE
  nlt$cc_device_and_data_list = ARRAY [ 1 .. * ] of nlt$cc_device_and_data_record;

*copyc nlt$cc_device_and_data_record
*DECK DECK=NLT$CC_DEVICE_AND_DATA_RECORD EXPAND=FALSE

  TYPE
    nlt$cc_device_and_data_record = record
      device_id: nlt$device_identifier,
      data: nlt$bm_message_id,
    recend;

*copyc nlt$bm_message_id
*copyc nlt$device_identifier
*DECK DECK=NLT$CC_DISCONNECT_REASON EXPAND=FALSE
{  NLT$CC_DISCONNECT_REASON  }

CONST
  nlc$cc_dr_normal_disconnect = 1,
  nlc$cc_dr_reason_not_specified = 2,
  nlc$cc_dr_reason_not_recognized = 3,
  nlc$cc_dr_conn_negotiate_failed = 4,
  nlc$cc_dr_connection_failure = 5,
  nlc$cc_dr_link_down = 6,
  nlc$cc_dr_host_congested = 7,
  nlc$cc_dr_remote_congested = 8,
  nlc$cc_dr_local_detct_prtcl_err = 9,
  nlc$cc_dr_remote_detct_ptcl_err = 10,
  nlc$cc_dr_unknown_address = 11,
  nlc$cc_dr_system_unaccomodating = 12,
  nlc$cc_dr_invalid_state = 13,
  nlc$cc_dr_flow_cntrl_violation = 14;

TYPE
  nlt$cc_disconnect_reason = 0 .. 0ff(16);
*DECK DECK=NLT$CC_EVENT_PROCESSOR EXPAND=FALSE

  TYPE
    nlt$cc_event_processor = ^procedure (osi_connection: ^nlt$cl_connection;
          event: nlt$cc_event;
      VAR inventory_report: integer);

*copyc nlt$cc_interface
*copyc nlt$cl_connection
*DECK DECK=NLT$CC_INTERFACE EXPAND=FALSE
{  NLT$CC_INTERFACE  }

  TYPE
    nlt$cc_event_kind = (nlc$cc_connect_event, nlc$cc_accept_event,
          nlc$cc_data_event, nlc$cc_expedited_data_event,
          nlc$cc_disconnect_event,nlc$cc_clear_to_send_event),

    nlt$cc_event = record
      case kind: nlt$cc_event_kind of
      = nlc$cc_connect_event =
        connect: nlt$cc_connect_event,
      = nlc$cc_accept_event =
        accept: nlt$cc_accept_event,
      = nlc$cc_data_event =
        data: nlt$cc_data_event,
      = nlc$cc_expedited_data_event =
        expedited_data: nlt$cc_expedited_data_event,
      = nlc$cc_disconnect_event =
        disconnect: nlt$cc_disconnect_event,
      casend,
    recend,

    nlt$cc_connect_event = record
      device_id: nlt$device_identifier,
      destination_address: nlt$cc_address,
      class: nlt$cc_connection_class,
      data: nlt$bm_message_id,
    recend,

    nlt$cc_accept_event = record
      class: nlt$cc_connection_class,
      data: nlt$bm_message_id,
    recend,

    nlt$cc_data_event = record
      data: nlt$bm_message_id,
    recend,

    nlt$cc_expedited_data_event = record
      data: nlt$bm_message_id,
    recend,

    nlt$cc_disconnect_event = record
      reason: nlt$cc_disconnect_reason,
      data: nlt$bm_message_id,
    recend;

*copyc nlt$bm_message_id
*copyc nlt$cc_address
*copyc nlt$cc_connection_class
*copyc nlt$cc_disconnect_reason
*copyc nlt$device_identifier
*DECK DECK=NLT$CC_PDU_KIND EXPAND=FALSE
{  NLT$CC_PDU_KIND }

CONST
  nlc$cc_connect_request = 1,
  nlc$cc_connect_confirm = 2,
  nlc$cc_disconnect_request = 3,
  nlc$cc_disconnect_confirm = 4,
  nlc$cc_credit_allocation = 5,
  nlc$cc_data = 6,
  nlc$cc_expedited_data = 7,
  nlc$cc_global_window = 8,
  nlc$cc_max_pdu_kind = 0ff(16);

TYPE
  nlt$cc_pdu_kind = 0 .. nlc$cc_max_pdu_kind;
*DECK DECK=NLT$CC_PDU_SIZE EXPAND=FALSE
{  NLT$CC_PDU_SIZE }

CONST
  nlc$cc_max_pdu_size = 0ffffffff(16);

TYPE
  nlt$cc_pdu_size = 0 .. nlc$cc_max_pdu_size;
*DECK DECK=NLT$CC_PROTOCOL_DATA_UNIT EXPAND=FALSE
{  NLT$CC_PROTOCOL_DATA_UNIT }

CONST
  nlc$cc_max_user_data_pad = 0ffffffffffffff(16),
  nlc$cc_max_user_data_pad_size = 7;

TYPE

{  NLT$CC_PROTOCOL_HEADER defines the fixed size portion of the Channel
{  Connection PDU header (i.e., does not include the variable sized user
{  data pad.

  nlt$cc_protocol_header = record
    kind: nlt$cc_pdu_kind,
    pad_to_32_bit_offset: 0 .. 0ffffff(16),
    length: nlt$cc_pdu_size,
    CASE nlt$cc_pdu_kind OF
    = nlc$cc_connect_request =
      connect_request: nlt$cc_connect_request,

    = nlc$cc_connect_confirm =
      connect_confirm: nlt$cc_connect_confirm,

    = nlc$cc_disconnect_request =
      disconnect_request: nlt$cc_disconnect_request,

    = nlc$cc_disconnect_confirm =
      disconnect_confirm: nlt$cc_disconnect_confirm,

    = nlc$cc_credit_allocation =
      credit_allocation: nlt$cc_credit_allocation,

    = nlc$cc_data =
      data: nlt$cc_data,

    = nlc$cc_expedited_data =
      expedited_data: nlt$cc_expedited_data,

    = nlc$cc_global_window =
      global_window: nlt$cc_global_window,
    CASEND,
  recend,

{  NLT$CC_PROTOCOL_HEADER_WITH_PAD defines the Channel Connection PDU header
{  including up to seven bytes of user data pad.

  nlt$cc_protocol_header_with_pad = record
    kind: nlt$cc_pdu_kind,
    pad_to_32_bit_offset: 0 .. 0ffffff(16),
    length: nlt$cc_pdu_size,
    CASE nlt$cc_pdu_kind OF
    = nlc$cc_connect_request =
    connect_request: nlt$cc_connect_request,
    connect_request_user_data_pad: 0 .. nlc$cc_max_user_data_pad,

    = nlc$cc_connect_confirm =
    connect_confirm: nlt$cc_connect_confirm,
    connect_confirm_user_data_pad: 0 .. nlc$cc_max_user_data_pad,

    = nlc$cc_disconnect_request =
    disconnect_request: nlt$cc_disconnect_request,
    disconnect_req_user_data_pad: 0 .. nlc$cc_max_user_data_pad,

    = nlc$cc_disconnect_confirm =
    disconnect_confirm: nlt$cc_disconnect_confirm,

    = nlc$cc_credit_allocation =
    credit_allocation: nlt$cc_credit_allocation,

    = nlc$cc_data =
    data: nlt$cc_data,
    data_request_user_data_pad: 0 .. nlc$cc_max_user_data_pad,

    = nlc$cc_expedited_data =
    expedited_data: nlt$cc_expedited_data,
    expedited_request_user_data_pad: 0 .. nlc$cc_max_user_data_pad,

    = nlc$cc_global_window =
    global_window: nlt$cc_global_window,
    CASEND,
  recend;

TYPE
  nlt$cc_connect_request = record
    destination_address: nlt$cc_address,
    initial_credit_allocation: nlt$cc_credits,
    source_reference: nlt$cl_reference_number,
    user_data_pad_size: nlt$cc_user_data_pad_size,
    header_pad: 0 .. 0ffff(16),
    class: nlt$cc_connection_class,
  recend,

  nlt$cc_connect_confirm = record
    destination_reference: nlt$cl_reference_number,
    source_reference: nlt$cl_reference_number,
    initial_credit_allocation: 0 .. 0ff(16),
    user_data_pad_size: nlt$cc_user_data_pad_size,
    header_pad: 0 .. 0ff(16),
    class: nlt$cc_connection_class,
  recend,

  nlt$cc_disconnect_request = record
    destination_reference: nlt$cl_reference_number,
    source_reference: nlt$cl_reference_number,
    reason: nlt$cc_disconnect_reason,
    user_data_pad_size: nlt$cc_user_data_pad_size,
    header_pad: 0 .. 0ff(16),
    class: nlt$cc_connection_class,
  recend,

  nlt$cc_disconnect_confirm = record
    destination_reference: nlt$cl_reference_number,
    source_reference: nlt$cl_reference_number,
    header_pad: 0 .. 0ffffff(16),
    class: nlt$cc_connection_class,
  recend,

  nlt$cc_credit_allocation = record
    destination_reference: nlt$cl_reference_number,
    credits_granted: nlt$cc_credits,
    header_pad: 0 .. 0ffffffff(16),
    class: nlt$cc_connection_class,
  recend,

  nlt$cc_data = record
    destination_reference: nlt$cl_reference_number,
    credits_granted: nlt$cc_credits,
    user_data_pad_size: nlt$cc_user_data_pad_size,
    header_pad: 0 .. 0ffffff(16),
    class: nlt$cc_connection_class,
  recend,

  nlt$cc_expedited_data = record
    destination_reference: nlt$cl_reference_number,
    user_data_pad_size: nlt$cc_user_data_pad_size,
    header_pad: 0 .. 0ffffffff(16),
    class: nlt$cc_connection_class,
  recend,

  nlt$cc_global_window = record
    window_open: boolean,
    header_pad: 0 .. 0ffffffffffff(16),
    class: nlt$cc_connection_class,
  recend;

*copyc nlt$cc_address
*copyc nlt$cc_connection_class
*copyc nlt$cc_credits
*copyc nlt$cc_disconnect_reason
*copyc nlt$cc_pdu_kind
*copyc nlt$cc_pdu_size
*copyc nlt$cc_user_data_pad_size
*copyc nlt$cl_reference_number
*DECK DECK=NLT$CC_SEQ#_OR_CONNECT_TIME EXPAND=FALSE

TYPE
  nlt$cc_seq#_or_connect_time = record
    CASE nlt$cc_pdu_kind OF
    = nlc$cc_connect_request =
      time_connect_request_received: integer,
    = nlc$cc_connect_confirm .. nlc$cc_expedited_data =
      sequence_number: nlt$cc_sequence_number,
    CASEND,
  recend;

*copyc nlt$cc_pdu_kind
*copyc nlt$cc_sequence_number
*DECK DECK=NLT$CC_SEQUENCE_NUMBER EXPAND=FALSE

TYPE
  nlt$cc_sequence_number = integer;
*DECK DECK=NLT$CC_USER_DATA_PAD_SIZE EXPAND=FALSE

TYPE
  nlt$cc_user_data_pad_size = 0 .. 0ff(16);

*DECK DECK=NLT$CC_WORK_LIST EXPAND=TRUE
{   NLT$CC_WORK_LIST }

  TYPE
    nlt$cc_work_list = record
      first: ^nlt$cc_work_unit,
      append: ^^nlt$cc_work_unit,
    recend,

    nlt$cc_work_unit_kind = (nlc$cc_event_work_unit,
      nlc$cc_connection_work_unit),

  nlt$cc_work_unit = record
    next_work_unit: ^nlt$cc_work_unit,
    connection_id: nlt$cl_connection_id,
    CASE kind: nlt$cc_work_unit_kind OF
    = nlc$cc_event_work_unit =
      device_received_on: nlt$device_identifier,
      sequence#: nlt$cc_sequence_number,
      cc_header: nlt$cc_protocol_header,
      data: nlt$bm_message_id,
    CASEND,
  recend;

*copyc nlt$bm_message_id
*copyc nlt$cc_protocol_data_unit
*copyc nlt$cc_sequence_number
*copyc nlt$cl_connection
*copyc nlt$device_identifier
*DECK DECK=NLT$CHANNEL_INTERFACE_PROTOCOL EXPAND=FALSE

  CONST
    nlc$channelnet_protocol = 41(16),
    nlc$channel_connection_protocol = 42(16);

  TYPE
    nlt$channel_interface_protocol = 0 .. 0ffff(16);
*DECK DECK=NLT$CL_CONNECTION EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??

{                                                                                                        }
{   Interlayer Connection                                                                                }
{                                                                                                        }
{     The  interlayer  connection provides the foundation for intralayer connection descriptions on a    }
{     connection route.  Each layer requiring connection state data store on a route is identified in    }
{     a structure keyed by interface layer name.  It follows, during connection establishment a place    }
{     holder is reserved for each requiring layer's state  information.   The  interlayer  connection    }
{     also provides the basis for access control, rudimentary validation criteria, and task selection    }
{     criteria for incoming network events destined for a connection end point.                          }
{                                                                                                        }
{     ------------------                                                                                 }
{                                                                                                        }
{     A  connection  route  is  the  path downward through layers from an interface layer through XNS    }
{     transport or channel connection.  The path is 'chosen' by the end user -- the  user's  selection   }
{     of interface layer and protocol for a Service  Access Point.  The actual downward path is          }
{     traversed via procedure  call  to  a  lower  layer  based on knowledge inherent in the selection.  }
{     The upward path is traversed via procedure call to a higher layer event processor which was        }
{     identified to the lower layer during interface / SAP selection or connection establishment.  The   }
{     interface layer is upper boundary and XNS transport or channel connection is lower boundary to a   }
{     connection.                                                                                        }
{                                                                                                        }
{     ------------------                                                                                 }
{                                                                                                        }
{     The interlayer connection is the container for the control information required to  synchronize    }
{     access  to the connection among tasks.  The responsibilty for managing access to the connection    }
{     is delegated exclusively to the boundary layers.  This responsibilty includes acquiring access,    }
{     resolving access contention, and releasing access.  The upper  boundary  (interface  layer)  is    }
{     responsible for the management on user requests and the lower boundary is the responsible layer    }
{     on incoming network events.  Intermediate layers and  the layer  opposite the  boundary stimuli    }
{     have access to the interlayer connection when entered.                                             }
{                                                                                                        }
{     The  timer  evaluation / reaction  process  deviates from the 'boundary layer rule' in that the    }
{     process assumes the role of a boundary layer.  Layers, which  evaluate  and  react  to  timers,    }
{     follow  the  preceding  direction.  It must be noted, in the case of inventory shortages, timer    }
{     reactors  should  postpone  the reaction rather than impeding the process and prohibiting other    }
{     access to the connection.                                                                          }
{                                                                                                        }
{     The  boundary layer at the  point  of  stimuli  is  responsible  for  creating  the  interlayer    }
{     connection  (i.e.,  the interface layer at user request and the lower boundary layer at network    }
{     event.  Individual layers are responsible for 'creating' and 'destroying' their own  connection    }
{     state  data store.  The timer process is responsible for destroying an interlayer connection --    }
{     an interlayer connection continues to exist as long as a layer connection exists.  The duration    }
{     of layer connection existance is dependent on features provided by the layer.                      }
{                                                                                                        }
{     ------------------                                                                                 }
{                                                                                                        }
{     The identifier contained in the interlayer connection provides the  rudimentary  selection  and    }
{     validation  key.   Further  validation  of  authenticity  of  user  request or network event is    }
{     performed by the respective boundary layer.  This validation does not guarantee authenticity of    }
{     request parameters or protocol at any other layer.                                                 }
{                                                                                                        }
{     ------------------                                                                                 }
{                                                                                                        }
{     The data sender, data receiver and supervisory receiver requestor descriptions provide:            }
{       1. a subset of the information necessary to direct the processing of  an  incoming  network      }
{          event to an appropriate task -- the other information is the event itself; and                }
{       2. a  subset  of  the  information necessary for an interface layer to control user request      }
{          rates -- the remaining knowledge is inherent in the specific features of the interfaces.      }
{                                                                                                        }
{                                                                                                        }
{     The selection of an appropriate task at instance of network event is based on the  lower  layer    }
{     protocols (3a - 4, CC), the presence or absence of outstanding user requests, and whether the job  }
{     containing the task is in memory.  Assuming the investigation of protocol  determines  that  an    }
{     event  is  destined  for  a connection end point and that the job is in memory, the appropriate    }
{     task is selected as follows:                                                                       }
{           IF (XNS transport packet type IS data) OR (Channel Connection PDU) THEN                      }
{             IF data receiver is active THEN                                                            }
{               SEND network event to data receiver task.                                                }
{             ELSEIF data sender is active THEN                                                          }
{               SEND network event to data sender task.                                                  }
{             ELSE                                                                                       }
{               SEND network event to system task.                                                       }
{             IFEND                                                                                      }
{           ELSEIF XNS transport packet type IS system THEN                                              }
{             IF data sender is active THEN                                                              }
{               SEND network event to data sender task.                                                  }
{             ELSEIF data receiver is active THEN                                                        }
{               SEND network event to data receiver task.                                                }
{             ELSE                                                                                       }
{               SEND network event to system task.                                                       }
{             IFEND                                                                                      }
{           ELSEIF XNS transport packet type IS expedited or disconnect THEN                             }
{             IF data receiver is active THEN                                                            }
{               SEND network event to data receiver task.                                                }
{             ELSEIF data sender is active THEN                                                          }
{               SEND network event to data sender task.                                                  }
{             ELSE                                                                                       }
{               SEND network event to system task.                                                       }
{             IFEND                                                                                      }
{           IFEND                                                                                        }
{                                                                                                        }
{     NOTE: task  selection  at network event instance may not be appropriate at processing instance.    }
{           Therefore, the event may  require  redirection  at  the  initial  processing  task.   The    }
{           redirection may occur within either boundary layer.                                          }
{                                                                                                        }
{     Network events not destined for a connection end point are directed to a network  system  task.    }
{     Network  events  destined  for a connection end point, but the appropriate job / task is not in    }
{     memory are directed to a network system task.  Conversly, network events which are directed to     }
{     a system task are multicast datagrams, datagrams which must be relayed, datagrams whose  packet    }
{     (protocol)  type  is  not   'sequenced  packet',   sequenced packet datagrams whose destination    }
{     connection identifier is not known or zero (0), and  those  events  which  would  otherwise  be    }
{     directed to a job / task which is not in memory.                                                   }
{                                                                                                        }
{                                                                                                        }
{     The  data  sender  and data receiver requestor descriptions are utilized by interface layers to    }
{     limit the outstanding user requests to one (1) data  sender  and  one  (1)  data  receiver  per    }
{     connection.   The  interface layer is the sole manager of requestor descriptions (i.e., request    }
{     inactive <--> request active).   Dependent  on  request  style  and  current  connection state,    }
{     request  completion  is communicated via returned parameters or upward via event processors and    }
{     and layer events.
{                                                                                                        }
?? POP ??

  TYPE
    nlt$cl_connection = record
      nextt: ^nlt$cl_connection,
      access_control: ALIGNED [0 MOD 8] nlt$cl_connection_access,
      notify_system_task: boolean,
      identifier: nlt$cl_connection_id,
      message_receiver: nlt$cl_requestor,
      message_sender: nlt$cl_requestor,
      application_layer: nlt$cl_application_layer,
      layers_active: nlt$cl_layers,
      layer_connections: ^nlt$cl_layer_connections,
      device_ids: nlt$device_ids,
      CASE queue_on_connection: boolean OF
      = TRUE =
        connection_queue: nlt$connection_queue,
        input_queue: nat$received_message_list,
        active_receiver: ^nlt$udp_active_receiver,
      = FALSE =
        next_assignable_cc_sequence#: nlt$cc_sequence_number,
      CASEND,
    recend;

  TYPE
    nlt$cl_connection_access = record
      notify_system_task: boolean,
*IF $true(osv$unix)
      fill: 0 .. 7fffffff(16),
*ELSE
      fill: 0 .. 0ffffffff(16),
*IFEND
      task_id: ost$global_task_id,
    recend;

  TYPE
    nlt$cl_connection_id = nat$connection_id;

  TYPE
    nlt$cl_requestor = record
      active: boolean,
      task: ost$global_task_id,
    recend;


{                                                                                                        }
{   Layer Connections                                                                                    }
{     The  layer connections SEQuence can be viewed as an 'array' of bound records.  Layer name being    }
{     the key identifying the successor intralayer connection.   Based on  the  layers  active  field    }
{     of  the  interlayer  connection and the stimuli (upward, downward nature of invokation or timer    }
{     expiration), a given layer can determine the basic state of its layer connection data store and    }
{     in turn perform the steps corresponding to the intersection of stimuli and state.                  }
{                                                                                                        }

  TYPE
    nlt$cl_layer_connections = SEQ ( * );

*copyc nat$connection_id
*copyc nat$received_message_list
*copyc nlt$cc_sequence_number
*copyc nlt$cl_layer_name
*copyc nlt$connection_queue
*copyc nlt$device_ids
*copyc nlt$udp_active_receiver
*copyc ost$global_task_id
*DECK DECK=NLT$CL_CONNECTIONS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  TYPE
    nlt$cl_connections = record
      cid_seed: ALIGNED [0 MOD 8] integer,
      active: ALIGNED [0 MOD 8] integer,
      list: ^array [0 .. * ] of nlt$cl_connection_root,
    recend,

    nlt$cl_connections_per_system = 2 .. 65536,

    nlt$cl_connection_root = record
      access_control: ALIGNED [0 MOD 8] nlt$cl_connection_root_access,
      first: ^nlt$cl_connection,
    recend,

    nlt$cl_connection_root_access = record
      nonexclusive_accessors: 0 .. 0ffffffff(16),
      exclusive: boolean,
      fill: 0 .. 0ffffff(16),
    recend;

  TYPE
    nlt$cl_connections_control = record
      lock: ALIGNED [0 MOD 8] string (8),
    recend;

  CONST
    nlc$cl_connections_locked = 'LOCKED  ',
    nlc$cl_connections_unlocked = 'UNLOCKED';

*copyc nlt$cl_connection
*DECK DECK=NLT$CL_CONNECTION_LAYER_TEMPLAT EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  CONST
    nlc$cl_path_locked = 'LOCKED  ',
    nlc$cl_path_unlocked = 'UNLOCKED';


  TYPE
    nlt$cl_connection_layer_templat = record
      initialization_lock: ALIGNED [0 MOD 8] string (8),
      path_header_size: nat$data_length,
      path: array [nlt$cl_layer_name] of boolean,
      sap: array [nlt$cl_layer_name] of nlt$cl_sap_template,
      connection: array [nlt$cl_layer_name] of nlt$cl_connection_template,
    recend,

    nlt$cl_sap_template = record
      event_processor: nlt$cl_event_processor,
      timer_evaluator: nat$network_procedure,
    recend,

    nlt$cl_connection_template = record
      description_offset: nlt$cl_layer_connection_size,
      description_size: nlt$cl_layer_connection_size,
      maximum_protocol_header_size: nat$data_length,
      event_processor: nlt$cl_event_processor,
      timer_evaluator: nat$network_procedure,
    recend,

    nlt$cl_layer_connection_size = 1 .. 0ffffffff(16),

    nlt$cl_event_processor = record
      CASE layer: nlt$cl_layer_name OF
      = nlc$xns_session_layer =
        se: nat$network_procedure,
      = nlc$channel_connection_layer =
        cc: nat$network_procedure,
      = nlc$osi_transport_access_agent =
        ta: nat$network_procedure,
      = nlc$tcp_access_agent =
        tcpaa: nat$network_procedure,
      CASEND,
    recend,

    nlt$cl_evaluate_sap_timer = ^procedure (current_time: integer),
    nlt$cl_evaluat_connection_timer = ^procedure (current_time: integer;
      cl_connection: ^nlt$cl_connection);

*copyc nlt$cl_layer_name
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_connection
*copyc nlt$sl_event_processor
*copyc nat$data_fragments
*copyc nat$network_procedure
?? POP ??
*DECK DECK=NLT$CL_LAYER_NAME EXPAND=FALSE

{ NOTES:
{   1. The ordering of nlt$cl_layer_name is important i.e. an N layer must have
{   a smaller ordinal value than its N-1 layer.
{   2. IF nlt$cl_layer_name is changed the CONSTANTS application_layers and
{   all_layers in module NLM$CL_CONNECTION_LAYER_TEMPLAT must also be changed.

  TYPE
    nlt$cl_layer_name = (

{ Application layers:

          nlc$osi_session_interface, nlc$osi_generic_xport_interface,
          nlc$osi_sys_mgmt_access_agent, nlc$osi_network_access_agent,
          nlc$osi_link_access_agent, nlc$tcpip_mgmt_access_agent,
          nlc$tcp_interface, nlc$udp_interface,

{ Interface layers:

          nlc$xns_session_layer, nlc$osi_transport_access_agent,
          nlc$tcp_access_agent, nlc$channel_connection_layer),

    nlt$cl_layers = set of nlt$cl_layer_name,

    nlt$cl_application_layer = nlc$osi_session_interface .. nlc$udp_interface,

    nlt$cl_osi_application_layer = SET OF nlc$osi_session_interface .. nlc$udp_interface,

    nlt$cl_connection_route = set of nlt$cl_application_layer;



*DECK DECK=NLT$CL_REFERENCE_NUMBER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  TYPE
    nlt$cl_reference_number = 0 .. 65535;
*DECK DECK=NLT$CN_EVENT_PROCESSOR EXPAND=FALSE

  TYPE
    nlt$cn_event_processor = ^procedure (sap_id: nat$cn_sap_id;
          source_device: nlt$device_identifier;
          source: nat$system_address;
          data: nlt$bm_message_id);

*copyc nat$cn_interface
*copyc nat$system_address
*copyc nlt$bm_message_id
*copyc nlt$device_identifier
*DECK DECK=NLT$CONFIGURED_NETWORK_DEVICES EXPAND=FALSE

 TYPE
    nlt$configured_network_devices = record
      access_control: ALIGNED [0 MOD 8] nlt$access_control,
      next_log_msg_time: integer,
      network_device_count: nlt$device_count,
      network_device_list: ^nlt$network_device_list,
    recend;

*copyc nlt$access_control
*copyc nlt$device_count
*copyc nlt$network_device_list
*DECK DECK=NLT$CONNECTIONS_PER_SYSTEM EXPAND=FALSE

  TYPE
    nlt$connections_per_system = 0 .. 4096;
*DECK DECK=NLT$CONNECTION_QUEUE EXPAND=FALSE

  TYPE
    nlt$connection_queue = record
      fill: aligned [0 MOD 8] 0 .. 0ff(16),
      in_queue: boolean,
      next_connection: ^nlt$cl_connection,
    recend;

*copyc nlt$cl_connection
*DECK DECK=NLT$DELIVER_NETWORK_EVENT EXPAND=FALSE

  TYPE
    nlt$deliver_network_event = ^procedure (sap: nat$network_selector;
          source_address: nat$osi_network_address;
          device_id: nlt$device_identifier;
          data: nlt$bm_message_id);

*copyc nat$network_selector
*copyc nat$osi_network_address
*copyc nlt$bm_message_id
*copyc nlt$device_identifier
*DECK DECK=NLT$DEVICE_COUNT EXPAND=FALSE

  TYPE
    nlt$device_count = 0 .. 0ff(16);
*DECK DECK=NLT$DEVICE_IDENTIFIER EXPAND=FALSE

  CONST
    nlc$null_device_identifier = 0,
    nlc$maximum_network_devices = 64;

  TYPE
    nlt$device_identifier = 0 .. 0ff(16);
*DECK DECK=NLT$DEVICE_IDS EXPAND=FALSE

  TYPE
    nlt$device_ids = SET OF 1 .. nlc$maximum_network_devices;

*copyc nlt$device_identifier
*DECK DECK=NLT$DEVICE_LIST EXPAND=FALSE

  TYPE
    nlt$device_list = array [1 .. *] of nlt$device_identifier;

*copyc nlt$device_identifier
*DECK DECK=NLT$DEVICE_USAGE_DATA EXPAND=FALSE

  TYPE
    nlt$device_usage_data = record
      bytes_transmitted: integer,
      bytes_received: integer,
    recend;
*DECK DECK=NLT$DEVICE_USAGE_DATA_LIST EXPAND=FALSE

  TYPE
    nlt$device_usage_data_list = array [1 .. *] of nlt$device_usage_data;

*copyc nlt$device_usage_data
*DECK DECK=NLT$ETHERNET_ADDR_AND_CHECKSUM EXPAND=FALSE

 TYPE
   nlt$ethernet_addr_and_checksum = record
     system_identifier: nat$system_identifier,
     checksum: nat$checksum_value,
   recend;

*copyc nat$checksum
*copyc nat$system_identifier
*DECK DECK=NLT$FLOW_CONTROL_STATUS EXPAND=FALSE

  TYPE
   nlt$flow_control_status = (nlc$flow_control_enabled, nlc$flow_control_disabled);
*DECK DECK=NLT$LA_CONNECTION EXPAND=FALSE

  TYPE
    nlt$la_connection = record
      state: nlt$la_connection_state,
      subnet_id: nat$subnet_identifier,
      device_id: nlt$device_identifier,
      event_processor: nat$network_procedure,
      sap_id: nat$cn_sap_id,
    recend,

    nlt$la_connection_state = (nlc$la_closed, nlc$la_connect_confirm_wait, nlc$la_open);


*copyc nat$cn_interface
*copyc nat$network_procedure
*copyc nat$subnet_identifier
*copyc nlt$device_identifier
*DECK DECK=NLT$LA_DISCONNECT_REASON EXPAND=FALSE
{ NLT$LA_DISCONNECT_REASON }

{ The disconnect reason codes for an open SAP reject are
{ as follows:

  CONST
    nlc$la_subnet_id_unknown = 1,
    nlc$la_invalid_sap_id = 2,
    nlc$la_sap_already_open = 3;


{ The disconnect reason codes for a close SAP indication
{ are as follows:

  CONST
    nlc$la_subnet_deleted = 1,
    nlc$la_max_data_length_exceeded = 2,
    nlc$la_lap_detects_protocol_err = 3;


  TYPE
    nlt$la_disconnect_reason = 0 .. 0ff(16);
*DECK DECK=NLT$LA_HEADER_FORMAT EXPAND=FALSE

  CONST
    nlc$la_standard_header = 1,
    nlc$la_xns_header = 2,
    nlc$la_ieee_xns_header = 3;

  TYPE
    nlt$la_header_format = 0 .. 0ff(16);
*DECK DECK=NLT$LA_OPEN_SAP_LIST EXPAND=FALSE

  TYPE
    nlt$la_open_sap_list = record
      lock: ost$signature_lock,
      sap_list: ^nlt$la_sap_descriptor,
    recend;

*copyc nlt$la_sap_descriptor
*copyc ost$signature_lock
*DECK DECK=NLT$LA_PDU_KIND EXPAND=FALSE
{ NLT$LA_PDU_KIND }

  CONST
    outgoing_pdu_base = 200(16),
    incoming_pdu_base = 280(16),

{  Incoming PDU kinds.

    nlc$la_open_sap_confirm = incoming_pdu_base + 0,
    nlc$la_open_sap_reject = incoming_pdu_base + 1,
    nlc$la_close_sap_indication = incoming_pdu_base + 2,
    nlc$la_data_indication = incoming_pdu_base + 3,

{  Outgoing PDU kinds.

    nlc$la_open_sap_request = outgoing_pdu_base + 0,
    nlc$la_data_request = outgoing_pdu_base + 1,
    nlc$la_close_sap_request = outgoing_pdu_base + 2;

  TYPE
    nlt$la_pdu_kind = 0 .. 0ffff(16);

*DECK DECK=NLT$LA_PRIORITY EXPAND=FALSE

  TYPE
    nlt$la_priority = 0 .. 0ff(16);

  CONST
    nlc$la_batch_priority = 0,
    nlc$la_interact_priority = 1,
    nlc$la_real_time_priority = 2,
    nlc$la_system_priority = 3;
*DECK DECK=NLT$LA_PROTOCOL_DATA_UNIT EXPAND=FALSE
{ NLT$LA_PROTOCOL_DATA_UNIT }

  CONST
{  Close SAP request reason codes.
    nlc$la_user_request = 1,
    nlc$la_laa_detects_protocol_err = 4;

  TYPE
    nlt$la_close_request_reason = 0 .. 0ff(16),
    nlt$la_pdu_length = 0 .. 0ffff(16);

  TYPE
    nlt$la_pdu_header = record
      length: nlt$la_pdu_length,
      kind: nlt$la_pdu_kind,
    recend,

    nlt$la_open_sap_request = record
      header: nlt$la_pdu_header,
      subnet_id: nat$subnet_identifier,
      sap_id: nat$cn_sap_id,
    recend,

    nlt$la_open_sap_confirm = record
      header: nlt$la_pdu_header,
    recend,

{ A Link Access disconnect indication can be either a
{ nlc$la_open_sap_reject or a nlc$la_close_sap_indication.

    nlt$la_disconnect_indication = record
      header: nlt$la_pdu_header,
      reason: nlt$la_disconnect_reason,
    recend,

    nlt$la_close_sap_request = record
      header: nlt$la_pdu_header,
      reason: nlt$la_close_request_reason,
    recend,


{  The Link Access data request and data indication PDU's are defined in the
{  Link Access Agent FSM (A8054) as having a number of variable length fields.
{  This variability allows for support of a variety of Link Layers. Currently,
{  however, the XNS stack is the only user of LAA and the PDU's have been defined
{  taking advantage of this fact. If and when additional users of LAA are defined
{  the PDU definitions may need to be changed appropriately.

    nlt$la_data_request = record
      header: nlt$la_pdu_header,
      priority_length: 0 .. 0ff(16),
      priority: nlt$la_priority,
      header_format_length: 0 .. 0ff(16),
      header_format: nlt$la_header_format,
      destination_sap: nat$cn_sap_id,
      destination_subnet_addr_length: 0 .. 0ff(16), { Current users of LAA use a 6 byte system identifier
      destination_subnet_address: nat$system_identifier, { to specify the subnet point of attachment.
{     user_data: SEQ (*),
    recend,

    nlt$la_data_indication = record
      header: nlt$la_pdu_header,
      multicast: boolean,
      priority_length: 0 .. 0ff(16),
{     priority: nlt$la_priority,             The current users of LAA do not make use of the priority field.
      header_format_length: 0 .. 0ff(16),
      header_format: nlt$la_header_format,
      source_sap: nat$cn_sap_id,
      fill1: 0 .. 0ff(16),
      source_subnet_addr_length: 0 .. 0ff(16), { Current users of LAA use a 6 byte system identifier
      source_subnet_address: nat$system_identifier, { to specify the subnet point of attachment.
      fill2: 0 .. 0ff(16),
      destination_subnet_addr_length: 0 .. 0ff(16),
      destination_subnet_address: nat$system_identifier,
{     user_data: SEQ (*),
    recend;

*copyc nat$cn_interface
*copyc nat$subnet_identifier
*copyc nat$system_identifier
*copyc nlt$la_disconnect_reason
*copyc nlt$la_header_format
*copyc nlt$la_pdu_kind
*copyc nlt$la_priority
*DECK DECK=NLT$LA_SAP_DESCRIPTOR EXPAND=FALSE
{ NLT$LA_SAP_DESCRIPTOR }

  TYPE
    nlt$la_sap_descriptor = record
      nextt: ^nlt$la_sap_descriptor,
      sap_id: nat$cn_sap_id,
      event_processor: nat$network_procedure,
      connection_class: nlt$cc_connection_class,
      devices: nlt$device_ids,
      subnet_list: ^nlt$la_subnet_entry,
    recend,

    nlt$la_subnet_entry = record
      nextt: ^nlt$la_subnet_entry,
      subnet_id: nat$subnet_identifier,
      status: nlt$la_sap_status,
      connection_id: nat$connection_id,
    recend,

    nlt$la_sap_status = (nlc$la_sap_closed, nlc$la_open_sap_confirm_wait, nlc$la_sap_open,
          nlc$la_resource_constraint);


*copyc nat$cn_interface
*copyc nat$connection_id
*copyc nat$network_procedure
*copyc nat$subnet_identifier
*copyc nlt$cc_connection_class
*copyc nlt$device_ids
*DECK DECK=NLT$LINK_SDU_SIZE EXPAND=FALSE

  TYPE
    nlt$link_sdu_size = 0 .. 0ffff(16);
*DECK DECK=NLT$MASTER_CONTROL_TABLE EXPAND=FALSE

  TYPE
    nlt$master_control_table = packed record
      initialized: boolean,
      fill1: 0 .. 7fffffffffffff(16),
      device_id: nlt$device_identifier,
      request_queues: array [nlc$cc_normal_class .. nlc$cc_priority_class] of nlt$request_queue,
      buffer_pool_headers: ALIGNED [4 MOD 8] ost$real_memory_address,
    recend,

    nlt$request_queue = packed record
      request_length: nlt$request_length,
      request_rma: ALIGNED [4 MOD 8] ost$real_memory_address,
      last_request: ALIGNED [4 MOD 8] ost$real_memory_address,
    recend,

    nlt$request_length = 0 .. 0ffff(16);

*copyc nlt$cc_connection_class
*copyc nlt$device_identifier
*copyc ost$hardware_subranges
*DECK DECK=NLT$NA_CONNECTION_STATE EXPAND=FALSE

  TYPE
    nlt$na_connection_state = (nlc$na_connection_closed, nlc$na_connection_open,
         nlc$na_await_connection_confirm);
*DECK DECK=NLT$NA_DISCONNECT_REASON EXPAND=FALSE

{ This common deck contains the disconnect reason codes sent and
{ received by the Network Access Agent (NAA). These reason codes
{ are sent as disconnect data.

{ The following are the reason codes for sending a close network sap
{ request to the Network Access Provider in the device.

  CONST
    nlc$na_dr_user_request = 1,
{ The protocol error has been further subdivided into the following sub codes.
    nlc$na_dr_unexpected_event = 4,
    nlc$na_dr_unexpected_length = 5,
    nlc$na_dr_insufficient_data = 6,
    nlc$na_dr_length_mismatch = 7,
    nlc$na_dr_namve_error = 8,
    nlc$na_dr_sme_disconnect = 9,

{ The following are the reason codes for close sap indication
{ received by the NAA.

    nlc$na_dr_invalid_priority = 1,
    nlc$na_dr_user_data_too_big = 2,
    nlc$na_dr_nap_det_protocol_err  = 3,

{ The folowing are the reason codes for an open network sap reject
{ received by the NAA. These reason codes are returned by the network
{ layer in the device.

    nlc$na_dr_sap_already_open = 1;

  TYPE
    nlt$na_disconnect_reason = 0 .. 0ff(16);
*DECK DECK=NLT$NA_LAYER_CONNECTION EXPAND=FALSE

  TYPE
    nlt$na_layer_connection = record
      state: nlt$na_connection_state,
      device_id: nlt$device_identifier,
      sap_id: nat$network_selector,
      event_processor: nat$network_procedure,
    recend;

*copyc nat$network_procedure
*copyc nat$network_selector
*copyc nlt$device_identifier
*copyc nlt$na_connection_state
*DECK DECK=NLT$NA_PRIORITY EXPAND=FALSE

  TYPE
    nlt$na_priority = 0 .. 0ff(16);
*DECK DECK=NLT$NA_PROTOCOL_DATA_UNIT EXPAND=FALSE

{ This common deck describes the format of the Protocol Data Units
{ (PDU) received and sent by Network Access Agent (NAA).

  CONST
    nlc$na_outgoing_pdu_base = 300(16),
    nlc$na_incoming_pdu_base = 380(16),

{ Incoming PDU kinds.

    nlc$na_open_sap_confirm = nlc$na_incoming_pdu_base + 0,
    nlc$na_open_sap_reject = nlc$na_incoming_pdu_base + 1,
    nlc$na_close_sap_indication = nlc$na_incoming_pdu_base + 2,
    nlc$na_data_indication = nlc$na_incoming_pdu_base + 4,

{ Outgoing PDU kinds.

    nlc$na_open_sap_request = nlc$na_outgoing_pdu_base + 0,
    nlc$na_close_sap_request = nlc$na_outgoing_pdu_base + 1,
    nlc$na_data_request = nlc$na_outgoing_pdu_base + 2;

  TYPE
    nlt$na_pdu_kind = 0 .. 0ffff(16),
    nlt$na_pdu_length = 0 .. 0ffff(16),
    nlt$na_pdu_header = record
      length: nlt$na_pdu_length,
      kind: nlt$na_pdu_kind,
    recend,

    nlt$na_close_sap_request = record
      header: nlt$na_pdu_header,
      reason: nlt$na_disconnect_reason,
    recend,

    nlt$na_data_indication_fixed = record
      header: nlt$na_pdu_header,
      priority: nlt$na_priority,
      source_address_length: nat$osi_network_address_length,
{ The folowing fields follow the fixed information.
{     source_address: nat$osi_network_address,
{     user data
    recend,

    nlt$na_data_request_fixed = record
      header: nlt$na_pdu_header,
      priority: nlt$na_priority,
      destination_address_length: nat$osi_network_address_length,
{ The following fields follow the fixed information.
{     destination_address: nat$osi_network_address,
{     user data.
    recend,

    nlt$na_disconnect_indication = record
      header: nlt$na_pdu_header,
      reason: nlt$na_disconnect_reason,
    recend,

    nlt$na_open_sap_request = record
      header: nlt$na_pdu_header,
      network_selector: nat$network_selector,
    recend;

*copyc nat$network_selector
*copyc nat$osi_network_address
*copyc nlt$na_disconnect_reason
*copyc nlt$na_priority
*DECK DECK=NLT$NA_SAP_ATTRIBUTES EXPAND=FALSE

  TYPE
    nlt$na_sap_attributes = record
      next_entry: ^nlt$na_sap_attributes,
      sap_id: nat$network_selector,
      priority: nlt$na_priority,
      connection_class: nlt$cc_connection_class,
      event_processor: nat$network_procedure,
      sap_device_list: nlt$na_sap_device_list,
    recend;

*copyc nat$network_procedure
*copyc nat$network_selector
*copyc nlt$cc_connection_class
*copyc nlt$na_priority
*copyc nlt$na_sap_device_list
*DECK DECK=NLT$NA_SAP_DEVICE_ENTRY EXPAND=FALSE

  TYPE
    nlt$na_sap_device_entry = record
      device_id: nlt$device_identifier,
      status: nlt$na_sap_status,
      connection_id: nat$connection_id,
    recend;

*copyc nat$connection_id
*copyc nlt$device_identifier
*copyc nlt$na_sap_status
*DECK DECK=NLT$NA_SAP_DEVICE_LIST EXPAND=FALSE

  TYPE
    nlt$na_sap_device_list = array [*] of nlt$na_sap_device_entry;

*copyc nlt$na_sap_device_entry
*DECK DECK=NLT$NA_SAP_LIST EXPAND=FALSE

  TYPE
    nlt$na_sap_list = record
      lock: ost$signature_lock,
      open_saps: packed array [0 .. 0ff(16)] of boolean,
      sap_attributes: ^nlt$na_sap_attributes,
    recend;

*copyc nlt$na_sap_attributes
*copyc ost$signature_lock
*DECK DECK=NLT$NA_SAP_STATUS EXPAND=FALSE

  TYPE
    nlt$na_sap_status = (nlc$na_sap_closed, nlc$na_sap_open,
       nlc$na_await_open_sap_confirm, nlc$na_resource_constraint);
*DECK DECK=NLT$NETWORK_DEVICE EXPAND=FALSE

  TYPE
    nlt$network_device = record
      device_id: nlt$device_identifier,
      system_id: nat$system_identifier,
      logical_unit: iot$logical_unit,
      path_status: nlt$network_path_status,
      element: cmt$element_name,
      channel: cmt$channel_ordinal,
      channel_address: cmt$physical_equipment_number,
      pp_identification: cmt$pp_identification,   {physical_pp}
      pp_number : iot$pp_number, { logical pp }
      driver_name: pmt$program_name,
      kind: nat$device_type,
      state: nlt$network_device_state,
      reset_down_count_intervl: integer,
      reset_down_count: 0 .. 0ff(16),
      reset_timestamp: integer,
      task_waiting_for_state_change: ost$global_task_id,
      maximum_pdu_size: nlt$cc_pdu_size,
      channel_interface_protocol: nlt$channel_interface_protocol,
      last_usage_data: nlt$device_usage_data,
    recend;
*copyc cmt$channel_ordinal
*copyc cmt$element_name
*copyc cmt$physical_equipment_number
*copyc cmt$pp_identification
*copyc iot$logical_unit
*copyc iot$pp_number
*copyc nat$device_type
*copyc nat$system_identifier
*copyc nlt$cc_pdu_size
*copyc nlt$channel_interface_protocol
*copyc nlt$device_identifier
*copyc nlt$device_usage_data
*copyc nlt$network_device_state
*copyc nlt$network_path_status
*copyc ost$global_task_id
*copyc pmt$program_name
*DECK DECK=NLT$NETWORK_DEVICE_LIST EXPAND=FALSE

  TYPE
    nlt$network_device_list = array [1..*] of nlt$network_device;

*copyc nlt$network_device
*DECK DECK=NLT$NETWORK_DEVICE_STATE EXPAND=FALSE

  TYPE
    nlt$network_device_state = (nlc$normal, nlc$state_change_pending, nlc$closed);
*DECK DECK=NLT$NETWORK_PATH_STATUS EXPAND=FALSE

  TYPE
    nlt$network_path_status = (nlc$path_down, nlc$path_available, nlc$path_unavailable);
*DECK DECK=NLT$NETWORK_TITLES_LIST EXPAND=FALSE
 TYPE
    nlt$network_titles_entry = record
      next_entry: ^nlt$network_titles_entry,
      network: nat$network_identifier,
      generating_system: nat$system_identifier,
      info_changed: boolean,
      directly_connected_network: boolean,
      relay_count: 0 .. 0ff(16),
      community_titles_list: ^nlt$community_titles_list,
      case multicast_network: boolean of
      = TRUE =
        broadcast_address: nat$system_identifier,
      casend,
    recend,

    nlt$community_titles_list = array [ * ] of nlt$title_address_pair,

    nlt$title_address_pair = record
      title: string (32),
      address: nat$system_identifier,
      title_length: 1 .. 32,
    recend;

*copyc nat$network_address
*DECK DECK=NLT$PDU_TYPE EXPAND=FALSE

TYPE
  nlt$pdu_type = (nlc$channelnet_pdu, nlc$channel_connection_pdu);
*DECK DECK=NLT$PEER_GLOBAL_FLOW_CONTROL EXPAND=FALSE

  TYPE
    nlt$peer_global_flow_control = array [nlc$cc_normal_class .. nlc$cc_priority_class] of
          nlt$pp_flow_ctrl_status,

    nlt$pp_flow_ctrl_status = record
      fill: 0 .. 0ff(16),
      flow_control_status: nlt$flow_control_status,
    recend;

*copyc nlt$cc_connection_class
*copyc nlt$flow_control_status
*DECK DECK=NLT$PP_BUFFER EXPAND=FALSE

{ NOTE:  Align so that the size of array will be 2(number of pools) *
{ 2(size of the descriptor) * maximum number of elements.

  TYPE
    nlt$pp_buffer = record
      pool_header: ALIGNED [0 MOD 80] nlt$pp_buffer_pool_headers,
      pool: array [ nlt$bm_pool_index] of ^nlt$pp_buffer_pool,
    recend,

    nlt$pp_buffer_pool_headers = array [ nlt$bm_pool_index] of nlt$pp_buffer_pool_header,

    nlt$pp_buffer_pool_header = record
      pp_buffer_pool: ALIGNED [4 MOD 8] ost$real_memory_address,
      inn: ALIGNED [6 MOD 8] nlt$pp_buffer_pool_offset,
      cpu_out: ALIGNED [6 MOD 8] nlt$pp_buffer_pool_offset,
      pp_out: ALIGNED [6 MOD 8] nlt$pp_buffer_pool_offset,
      fill1: 0 .. 0ffff(16),
      buffer_length: nlt$bm_buffer_length,
      threshold: 0 .. 0ffff(16),
      limit: nlt$pp_buffer_pool_offset,
    recend,

    nlt$pp_buffer_pool = array [0 .. * ] of nlt$pp_buffer_pool_entry,

    nlt$pp_buffer_pool_entry = record
      pva_fill: 0 .. 0ffff(16),
      descriptor_pva: ^nlt$bm_message_descriptor,
      container_rma: ALIGNED [4 MOD 8] ost$real_memory_address,
    recend,

    nlt$pp_buffer_pool_offset = 0 .. 0ffff(16);

*copyc nlt$bm_message_descriptor
*copyc nlt$bm_pool_index
*copyc nlt$bm_buffer_length
*copyc ost$hardware_subranges
*DECK DECK=NLT$PP_POOL_STATUS_AND_MESSAGE EXPAND=FALSE

  TYPE
    nlt$pp_pool_status_and_message = record
      pp_status_report: nlt$pp_status_report,
      received_message: array [1 ..*] of nlt$pp_message_delivery,
    recend,

    nlt$pp_message_delivery = record
      data_length: nlt$bm_buffer_length,
      message_descriptor: ^nlt$bm_message_descriptor,
    recend;

*copyc nlt$bm_buffer_length
*copyc nlt$bm_message_descriptor
*copyc nlt$pp_status_report
*DECK DECK=NLT$PP_SEND_QUEUE_TAIL EXPAND=FALSE

  TYPE
    nlt$pp_send_queue_tail = record
      send_queue_tail: ALIGNED [0 MOD 8] ^nat$request_block,
      fill: 0 .. 0ffff(16),
    recend;

*copyc nat$request_block
*DECK DECK=NLT$PP_SEND_QUEUE_TAILS EXPAND=FALSE

  TYPE
    nlt$pp_send_queue_tails = array [1 .. *] of array [nlc$cc_normal_class .. nlc$cc_priority_class]
          of nlt$pp_send_queue_tail;

*copyc nlt$cc_connection_class
*copyc nlt$pp_send_queue_tail
*DECK DECK=NLT$PP_STATUS_REPORT EXPAND=FALSE

  TYPE
    nlt$pp_status_report = record
      pp_buffer_pool_status: array [1 .. 2] of nlt$pp_buffer_pool_status,
      peer_global_flow_control: nlt$peer_global_flow_control,
    recend,

    nlt$pp_buffer_pool_status = record
      fill: 0 .. 0ff(16),
      buffer_pool_status: nlt$buffer_pool_status,
    recend;

*copyc nlt$buffer_pool_status
*copyc nlt$peer_global_flow_control
*DECK DECK=NLT$PROTOCOL EXPAND=FALSE
   {supported internal values for nat$protocol}
  CONST
  nac$xns_internet = 1,
    nac$xns_transport = 2,
    nac$cdna_transport = 3;

*DECK DECK=NLT$QUALITY_OF_SERVICE EXPAND=FALSE

  TYPE
    nlt$quality_of_service = seq(*),
    nlt$quality_of_service_size = 0 .. 0ff(16);
*DECK DECK=NLT$RECEIVED_MESSAGE_DESCRIPTOR EXPAND=FALSE

 TYPE
    nlt$received_message_descriptor = record
      next_received_message: ^nlt$bm_message_descriptor,
      connection_id: nlt$cl_connection_id,
      device_id: nlt$device_identifier,
      pp_pools_need_replenishing: boolean,
      peer_global_flow_control: nlt$peer_global_flow_control,
      CASE pdu_type: nlt$pdu_type OF
      = nlc$channel_connection_pdu =
        sequence#_or_connect_timestamp: nlt$cc_seq#_or_connect_time,
      = nlc$channelnet_pdu =
        ,
      CASEND,
    recend;

*copyc nlt$cl_connection
*copyc nlt$bm_message_descriptor
*copyc nlt$cc_seq#_or_connect_time
*copyc nlt$device_identifier
*copyc nlt$pdu_type
*copyc nlt$peer_global_flow_control
*DECK DECK=NLT$RECEIVING_CONNECTIONS EXPAND=FALSE

  TYPE
    nlt$receiving_connections = record
      fill: 0 .. 0ffff(16),
      next_connection: ^nlt$cl_connection,
    recend;

*copyc nlt$cl_connection
*DECK DECK=NLT$SE_MAX_ACTIVE_CONNECTIONS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  TYPE
    nlt$se_max_active_connections = 1 .. 0ffff(16);
*DECK DECK=NLT$SIGNAL_DEVICE_ERROR EXPAND=FALSE

 TYPE
    nlt$signal_device_error = record
      reset_device: boolean,
      device_id: nlt$device_identifier,
      pp_pools_need_replenishing: boolean,
      peer_global_flow_control: nlt$peer_global_flow_control,
      message: ^nlt$bm_message_descriptor,
    recend;

*copyc nlt$bm_message_descriptor
*copyc nlt$device_identifier
*copyc nlt$peer_global_flow_control
*DECK DECK=NLT$SK_OFFERED_SOCKET EXPAND=FALSE

  TYPE
    nlt$sk_offered_socket = record
      next_entry: ^nlt$sk_offered_socket,
      socket_id: nat$sk_socket_identifier,
      status: nlt$sk_offered_socket_status,
      source_job: jmt$system_supplied_name,
      destination_job: jmt$system_supplied_name,
      port: nat$sk_port_number,
      bound_address: nat$sk_ip_address,
      application: nat$application_name,
      ring: ost$ring,
      capability: ost$name,
      system_privilege: boolean,
      traffic_pattern: nat$sk_traffic_pattern,
      waiting_task: ost$global_task_id,
      CASE socket_type: nat$sk_socket_type OF
      = nac$sk_udp_socket =
        global_socket_id: nlt$udp_global_socket_id,
      = nac$sk_tcp_socket =
        connection_id: nat$connection_id,
        tcp_socket_type: nlt$tcp_socket_type,
      CASEND,
    recend;

*copyc jmt$system_supplied_name
*copyc nat$application_name
*copyc nat$connection_id
*copyc nat$sk_ip_address
*copyc nlt$sk_offered_socket_status
*copyc nat$sk_port_number
*copyc nat$sk_socket_identifier
*copyc nat$sk_socket_type
*copyc nat$sk_traffic_pattern
*copyc nlt$tcp_socket_type
*copyc nlt$udp_global_socket_id
*copyc osd$virtual_address
*copyc ost$global_task_id
*copyc ost$name
*DECK DECK=NLT$SK_OFFERED_SOCKETS_LIST EXPAND=FALSE

  TYPE
    nlt$sk_offered_sockets_list = record
      lock: ost$signature_lock,
      wait_for_socket_offer: ^nlt$sk_wait_for_socket_offer,
      offered_socket: ^nlt$sk_offered_socket,
    recend;

*copyc nlt$sk_offered_socket
*copyc nlt$sk_wait_for_socket_offer
*copyc ost$signature_lock
*DECK DECK=NLT$SK_OFFERED_SOCKET_STATUS EXPAND=FALSE

  TYPE
    nlt$sk_offered_socket_status = (nlc$sk_offer_pending, nlc$sk_offer_accepted,
      nlc$sk_offer_being_validated);

*DECK DECK=NLT$SK_TCP_ACK_DELAY_TIME EXPAND=FALSE

  TYPE
    nlt$sk_tcp_ack_delay_time = 0 .. 0ffff(16);

*DECK DECK=NLT$SK_WAIT_FOR_SOCKET_OFFER EXPAND=FALSE

  TYPE
    nlt$sk_wait_for_socket_offer = record
      next_entry: ^nlt$sk_wait_for_socket_offer,
      waiting_task_id: ost$global_task_id,
      waiting_job: jmt$system_supplied_name,
      source_job: jmt$system_supplied_name,     { from which the switch offer is to be accepted }
    recend;

*copyc jmt$system_supplied_name
*copyc ost$global_task_id
*DECK DECK=NLT$SL_ACCOUNTING_INFO EXPAND=FALSE

  TYPE

    nlt$sl_accounting_info = array [ 1 .. nlc$sl_max_accounting_length ] of cell;

*copyc nlt$sl_interface
*DECK DECK=NLT$SL_ACCOUNTING_LENGTH EXPAND=FALSE

  TYPE

    nlt$sl_accounting_length = 0 .. nlc$sl_max_accounting_length;

*copyc nlt$sl_interface
*DECK DECK=NLT$SL_APPLICATION_NAME_LENGTH EXPAND=FALSE

  TYPE
    nlt$sl_application_name_length = nlc$sl_min_appl_name_length .. nlc$sl_max_appl_name_length;

*copyc nlc$sl_appl_name_length
*DECK DECK=NLT$SL_CLEAR_REASON EXPAND=FALSE

  TYPE

    nlt$sl_clear_reason = (nlc$sl_user_clear, nlc$sl_layer_clear);
*DECK DECK=NLT$SL_CONNECTION_DESCRIPTOR EXPAND=FALSE

  TYPE

    nlt$sl_connection_descriptor = record
      current_state: nlt$sl_machine_state,
      receive_sequence_active: boolean,
      qbit_receive_sequence: boolean,
      send_sequence_active: boolean,
      qbit_send_sequence: boolean,
      source: nat$network_address,
      mark_count: integer,
      call_pdu_message_id: nlt$bm_message_id,
      clear_timer: nlt$timer,
      complete_data_pdu: boolean,
      sap: nat$sap_identifier,
      transport_end_of_message: boolean,
      event_processor:  nat$network_procedure,
    recend;

*copyc nat$network_address
*copyc nat$network_procedure
*copyc nat$sap_identifier
*copyc nlt$bm_message_id
*copyc nlt$sl_event
*copyc nlt$sl_event_processor
*copyc nlt$timer
*copyc osd$virtual_address
*DECK DECK=NLT$SL_DISCARD_OPTIONS EXPAND=FALSE

  TYPE

    nlt$sl_discard_options = (nlc$sl_discard_send_receive, nlc$sl_discard_send,
      nlc$sl_discard_receive);
*DECK DECK=NLT$SL_EVENT EXPAND=FALSE

  TYPE

    nlt$sl_event_kind = (nlc$sl_call_event, nlc$sl_confirm_event,
      nlc$sl_data_event, nlc$sl_clear_to_send_event, nlc$sl_interrupt_event,
      nlc$sl_synch_event, nlc$sl_synch_confirm_event, nlc$sl_clear_event),

    nlt$sl_event = record
      case kind: nlt$sl_event_kind of
      = nlc$sl_call_event =
        call: nlt$sl_call_event,
      = nlc$sl_confirm_event =
        confirm: nlt$sl_confirm_event,
      = nlc$sl_data_event =
        data: nlt$sl_data_event,
      = nlc$sl_interrupt_event =
        interrupt: nlt$sl_interrupt_event,
      = nlc$sl_synch_event =
        synch: nlt$sl_synch_event,
      = nlc$sl_clear_event =
        clear: nlt$sl_clear_event,
      casend,
    recend,

    nlt$sl_call_event = record
      source: nat$network_address,
      sap: nat$sap_identifier,
      accounting_info: ^nlt$sl_accounting_info,
      accounting_length: nlt$sl_accounting_length,
      message_id: nlt$bm_message_id,
    recend,

    nlt$sl_confirm_event = record
      accounting_info: ^nlt$sl_accounting_info,
      accounting_length: nlt$sl_accounting_length,
      message_id: nlt$bm_message_id,
    recend,

    nlt$sl_clear_event = record
      reason: nlt$sl_clear_reason,
      message_id: nlt$bm_message_id,
    recend,

    nlt$sl_data_event = record
      qualified_data: boolean,
      end_of_message: boolean,
      message_id: nlt$bm_message_id,
    recend,

    nlt$sl_interrupt_event = record
      message_id: nlt$bm_message_id,
    recend,

    nlt$sl_synch_event = record
      discard_option: nlt$sl_discard_options,
      message_id: nlt$bm_message_id,
    recend;

*copyc nat$gt_interface
*copyc nat$network_address
*copyc nat$sap_identifier
*copyc nlt$bm_message_id
*copyc nlt$sl_accounting_info
*copyc nlt$sl_accounting_length
*copyc nlt$sl_clear_reason
*copyc nlt$sl_discard_options
*copyc nlt$user_interface
*DECK DECK=NLT$SL_EVENT_PROCESSOR EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  TYPE
    nlt$sl_event_processor = ^procedure (xns_connection: ^nlt$cl_connection;
          event: nlt$sl_event;
      VAR inventory_report: nlt$ta_inventory_report);

*copyc nlt$sl_event
*copyc nlt$ta_inventory_report
*copyc nlt$cl_connection
*DECK DECK=NLT$SL_FAMILY_NAME_LENGTH EXPAND=FALSE

  TYPE
    nlt$sl_family_name_length = nlc$sl_min_family_name_length .. nlc$sl_max_family_name_length;

*copyc nlc$sl_family_name_length
*DECK DECK=NLT$SL_INTERFACE EXPAND=FALSE

 CONST

    nlc$sl_max_accounting_length = 0ffff(16),
    nlc$sl_max_blocksize = osc$max_segment_length,
    nlc$sl_max_call_message = 512,
    nlc$sl_max_clear_message = 512,
    nlc$sl_max_clear_wait = 600000000,
    nlc$sl_max_interrupt_message = 14,
    nlc$sl_max_interrupt_size = 14,
    nlc$sl_max_sap_value = 0ffff(16),
    nlc$sl_max_synch_message = 14,
    nlc$sl_max_unique_value = 03fffffff(16),
    nlc$sl_max_validation_length = 0ffff(16),
    nlc$sl_min_accounting_length = 0,
    nlc$sl_min_interrupt_message = 1,
    nlc$sl_min_synch_message = 1,
    nlc$sl_min_validation_length = 0,
    nlc$sl_version_no = 1,
    nlc$sl_unexpected_disconnect = 0,
    nlc$sl_max_connection_value = 0ffff(16);
*DECK DECK=NLT$SL_INVENTORY_REPORT EXPAND=FALSE

  TYPE
    nlt$sl_inventory_report = nlt$ta_inventory_report;

*copyc nlt$ta_inventory_report
*DECK DECK=NLT$SL_MACHINE_STATE EXPAND=FALSE

  TYPE

    nlt$sl_machine_state = (nlc$sl_closed, nlc$sl_connect_confirm_wait,
      nlc$sl_call_wait, nlc$sl_call_ok_wait, nlc$sl_call_response_wait,
      nlc$sl_data_transfer, nlc$sl_m_r_fr_wait, nlc$sl_fwd_mark_wait,
      nlc$sl_synch_response_wait, nlc$sl_rev_mark_wait,
      nlc$sl_synch_collision_fr, nlc$sl_disconnect_wait);
*DECK DECK=NLT$SL_MAX_ACTIVE_CONNECTIONS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  TYPE
    nlt$sl_max_active_connections = 1 .. 0ffff(16);
*DECK DECK=NLT$SL_PDU_HEADER EXPAND=FALSE

 CONST

    nlc$sl_call_type = 0,
    nlc$sl_call_ok_type = 1,
    nlc$sl_clear_type = 2,
    nlc$sl_data_type = 3,
    nlc$sl_synch_request_type = 4,
    nlc$sl_mark_type = 5,
    nlc$sl_interrupt_type = 6;

  TYPE

    nlt$sl_pdu_types = 0 .. 0f(16),

    nlt$sl_pdu_header = packed record
      version_no: 0 .. 0f(16),
      case pdu_type: nlt$sl_pdu_types of
      = nlc$sl_data_type =
        data_six_bit_fill: 0 .. 03f(16),
        qualified_data: boolean,
        more_data: boolean,
      = nlc$sl_synch_request_type =
        synch_six_bit_fill: 0 .. 03f(16),
        discard_option: nlt$sl_discard_options,
      = nlc$sl_call_type, nlc$sl_call_ok_type, nlc$sl_clear_type,
        nlc$sl_mark_type, nlc$sl_interrupt_type =
        one_byte_fill: 0 .. 0ff(16),
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$sl_discard_options
?? POP ??

*DECK DECK=NLT$SL_SESSION_LAYER EXPAND=FALSE

 CONST
    nlc$sl_successful = 0,
    nlc$sl_failed = 1,
    nlc$sl_variable_locked = 2,
    nlc$sl_call_type = 0,
    nlc$sl_call_ok_type = 1,
    nlc$sl_clear_type = 2,
    nlc$sl_data_type = 3,
    nlc$sl_synch_request_type = 4,
    nlc$sl_mark_type = 5,
    nlc$sl_interrupt_type = 6,
    nlc$sl_max_accounting_length = 0ffff(16),
    nlc$sl_max_blocksize = osc$max_segment_length,
    nlc$sl_max_call_message = 512,
    nlc$sl_max_clear_message = 512,
    nlc$sl_max_clear_wait = 0ffff(16),
    nlc$sl_max_interrupt_message = 14,
    nlc$sl_max_interrupt_size = 14,
    nlc$sl_max_sap_value = 0ffff(16),
    nlc$sl_max_synch_message = 14,
    nlc$sl_max_unique_value = 03fffffff(16),
    nlc$sl_max_validation_length = 0ffff(16),
    nlc$sl_min_accounting_length = 0,
    nlc$sl_min_interrupt_message = 1,
    nlc$sl_min_synch_message = 1,
    nlc$sl_min_validation_length = 0,
    nlc$sl_version_no = 1,
    nlc$sl_unexpected_disconnect = 0,
    nlc$sl_max_connection_value = 0ffff(16),
    nlc$sl_title =  'SESSION LAYER SERVER';

  TYPE

    nlt$sl_clear_reason = (nlc$sl_user_clear, nlc$sl_layer_clear),

    nlt$sl_connection_descriptor = record
      lock: ALIGNED [0 MOD 8] integer,
      connection_id: ALIGNED [0 MOD 8] nlt$sl_connection_id,
      user_connection_id: nat$user_connection_id,
      transport_connection_id: nlt$gt_connection_id,
      transport_user_connection_id: nlt$user_connection_id,
      current_state: nlt$sl_machine_state,
      receive_sequence_active: boolean,
      qbit_receive_sequence: boolean,
      send_sequence_active: boolean,
      qbit_send_sequence: boolean,
      source: nat$gt_address,
      mark_count: integer,
      call_pdu_message_id: nlt$bm_message_id,
      clear_timer_task_id: pmt$task_id,
      valid_clear_timer: boolean,
      complete_data_pdu: boolean,
      sap_id: nlt$sl_sap_id,
      transport_end_of_message: boolean,
      event_processor: nlt$sl_event_processor,
    recend,

    nlt$sl_connection_id = nlt$sl_validation_key,

    nlt$sl_discard_options = (nlc$sl_discard_send_receive, nlc$sl_discard_send,
      nlc$sl_discard_receive),

    nlt$sl_max_offset = 0 .. osc$maximum_offset,

    nlt$sl_machine_state = (nlc$sl_closed, nlc$sl_connect_confirm_wait,
      nlc$sl_call_wait, nlc$sl_call_ok_wait, nlc$sl_call_response_wait,
      nlc$sl_data_transfer, nlc$sl_m_r_fr_wait, nlc$sl_fwd_mark_wait,
      nlc$sl_synch_response_wait, nlc$sl_rev_mark_wait,
      nlc$sl_synch_collision_fr, nlc$sl_disconnect_wait),

    nlt$sl_pdu_types = 0 .. 0f(16),

    nlt$sl_pdu_header = packed record
      version_no: 0 .. 0f(16),
      case pdu_type: nlt$sl_pdu_types of
      = nlc$sl_data_type =
        data_six_bit_fill: 0 .. 03f(16),
        qualified_data: boolean,
        more_data: boolean,
      = nlc$sl_synch_request_type =
        synch_six_bit_fill: 0 .. 03f(16),
        discard_option: nlt$sl_discard_options,
      = nlc$sl_call_type, nlc$sl_call_ok_type, nlc$sl_clear_type,
        nlc$sl_mark_type, nlc$sl_interrupt_type =
        one_byte_fill: 0 .. 0ff(16),
      casend,
    recend,

    nlt$sl_sap_descriptor = record
      lock: ALIGNED [0 MOD 8] integer,
      sap_id: ALIGNED [0 MOD 8] nlt$sl_sap_id,
      user_sap_id: nlt$user_sap_id,
      transport_sap_id: nlt$gt_sap_id,
      transport_user_sap_id: nlt$user_sap_id,
      event_processor: nlt$sl_event_processor,
    recend,

    nlt$sl_sap_id = nlt$sl_validation_key,

    nlt$sl_sap_list = record
      lock: ost$signature_lock,
      first_sap: ^nlt$sl_sap_descriptor,
      sap_count: nlt$sl_sap_value,
    recend,

    nlt$sl_sap_value = 0 .. nlc$sl_max_sap_value,

    nlt$sl_unique_value = 0 .. nlc$sl_max_unique_value,

    nlt$sl_validation_key = packed record
      identifier: nat$validation_identifier,
      unique_value: nlt$sl_unique_value,
      locked: boolean,
      offset: nlt$sl_max_offset,
    recend,

    nlt$sl_version_number = 0 .. 0ff(16);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc nlt$user_interface
*copyc nlt$ta_event
*copyc nlt$sl_event
*copyc nlt$bm_message_id
*copyc ost$signature_lock
*copyc ost$global_task_id
*copyc pmt$task_id
?? POP ??

*DECK DECK=NLT$SL_USER_NAME_LENGTH EXPAND=FALSE

  TYPE
    nlt$sl_user_name_length = nlc$sl_min_user_name_length .. nlc$sl_max_user_name_length;

*copyc nlc$sl_user_name_length
*DECK DECK=NLT$SL_VALIDATION_VERSION EXPAND=FALSE

  TYPE
    nlt$sl_validation_version = nlc$sl_min_validation_version .. nlc$sl_max_validation_version;

*copyc nlc$sl_validation_version
*DECK DECK=NLT$SL_VERSION_NUMBER EXPAND=FALSE

  TYPE

    nlt$sl_version_number = 0 .. 0ff(16);
*DECK DECK=NLT$SM_AWAIT_ROUTING_QUERIES EXPAND=FALSE

  TYPE
    nlt$sm_await_routing_queries = record
      lock: ost$signature_lock,
      await_routing_query: ^nlt$sm_await_routing_query,
    recend;

*copyc nlt$sm_await_routing_query
*copyc ost$signature_lock
*DECK DECK=NLT$SM_AWAIT_ROUTING_QUERY EXPAND=FALSE

  TYPE
    nlt$sm_await_routing_query = record
      next_entry: ^nlt$sm_await_routing_query,
      request_id: nlt$sm_request_identifier,
      task_id: ost$global_task_id,
      ready_on_route_known_response: boolean,
{ The destination_address field is needed for DEBUG only. It should be
{ deleted after JIT.
      destination_address: seq (REP nac$osi_max_network_address_len of cell),
      query_count: 0 .. 0ff(16),
      response_count: 0 .. 0ff(16),
      device_information_list: nlt$sm_device_information_list,
    recend;

*copyc nat$osi_network_address
*copyc nlt$sm_device_information
*copyc nlt$sm_request_identifier
*copyc ost$global_task_id
*DECK DECK=NLT$SM_DEVICES EXPAND=FALSE

  TYPE
    nlt$sm_devices = record
      access_control: ALIGNED [0 MOD 8] nlt$access_control,
      list: ^nlt$sm_device_list,
    recend,

    nlt$sm_device_list = array [1..*] of nlt$system_management;

*copyc nlt$access_control
*copyc nlt$system_management

*DECK DECK=NLT$SM_DEVICE_ATTRIBUTES EXPAND=FALSE

TYPE
  nlt$sm_device_attributes = RECORD
    code: 0 .. 0FF(16),
    length: 0 .. 0FF(16),
    value: string ( * ),
  RECEND;

*DECK DECK=NLT$SM_DEVICE_ATTRIBUTES_LIST EXPAND=FALSE

TYPE
  nlt$sm_device_attributes_list = nlt$sm_device_attributes;

*copyc nlt$sm_device_attributes
*DECK DECK=NLT$SM_DEVICE_INFORMATION EXPAND=FALSE

  TYPE
    nlt$sm_device_information_list = array [1..*] of nlt$sm_device_information,
    nlt$sm_device_information = record
      device_id: nlt$device_identifier,
      device_version: nlt$sm_version,
      response_received: boolean,
      route_status: nlt$sm_route_status,
    recend;

*copyc nlt$device_identifier
*copyc nlt$sm_route_status
*DECK DECK=NLT$SM_DEVICE_SERVICE_ATTRIBUTE EXPAND=FALSE

TYPE
  nlt$sm_device_service_attribute  = nlc$sm_min_service_attrib .. nlc$sm_max_service_attrib;

*copyc nlc$sm_device_service_attribute
*DECK DECK=NLT$SM_DEVICE_SERVICE_VALUES EXPAND=FALSE

TYPE
  nlt$sm_device_service_values = nlc$sm_tp4_clns .. nlc$sm_tp4_clns_cons_tp0_tp2;

*copyc nlc$sm_device_service_values
*DECK DECK=NLT$SM_DEVICE_VERSION_LIST EXPAND=FALSE

TYPE
  nlt$sm_device_version_list = ARRAY [ 1 .. * ] of nlt$sm_version;

*DECK DECK=NLT$SM_DISCONNECT_REASON EXPAND=FALSE

  TYPE
    nlt$sm_disconnect_reason = 0 .. 0ff(16);

{ Disconnect reason codes - detected by SMAA in the host and sent to the
{ SMAP in the device.

  CONST
    nlc$sm_dr_null_reason = 0,
    nlc$sm_dr_version_not_supported = 1,
    nlc$sm_dr_incorrect_dev_address = 2,
    nlc$sm_dr_unexpected_event = 3,
    nlc$sm_dr_unexpected_length = 4,
    nlc$sm_dr_dup_connect_event = 5,
    nlc$sm_dr_dup_subnet = 6,
    nlc$sm_dr_ill_formed_pdu = 7,
    nlc$sm_dr_implementation_error = 8,
    nlc$sm_dr_invalid_service_attr = 9,
    nlc$sm_dr_unknown_pdu_kind = 11,
    nlc$sm_dr_length_mismatch = 12,
    nlc$sm_dr_pdu_too_small = 13,
    nlc$sm_dr_unexpected_cc_event = 14,
    nlc$sm_dr_namve_error = 15,
    nlc$sm_dr_incorrect_addr_length = 16;

{ Disconnect reason codes - detected by SMAP in the device and sent to the
{ SMAA in the host.

  CONST
    nlc$sm_dr_dup_host_address = 0;



*DECK DECK=NLT$SM_LAYER_CONNECTION EXPAND=FALSE

  TYPE
    nlt$sm_layer_connection = record
      device_id: nlt$device_identifier,
      state: nlt$sm_state,
    recend,

    nlt$sm_state = (nlc$sm_closed, nlc$sm_await_version_confirm,
      nlc$sm_await_int_attrib_confirm, nlc$sm_await_dev_spec_host_addr,
      nlc$sm_open, nlc$sm_await_subnet_definition);

*copyc nlt$device_identifier
*DECK DECK=NLT$SM_PROTOCOL_DATA_UNIT EXPAND=FALSE

{ This common deck describes the format of the Protocol Data Units
{ (PDU) received and sent by the System Management Access Agent.

  CONST
    nlc$sm_outgoing_pdu_base = 800(16),
    nlc$sm_incoming_pdu_base = 880(16),

{ Incoming PDU kinds.

    nlc$sm_define_version = nlc$sm_incoming_pdu_base + 0,
    nlc$sm_version_confirm = nlc$sm_incoming_pdu_base + 1,
    nlc$sm_confirm_interface_attrib = nlc$sm_incoming_pdu_base + 2,
    nlc$sm_define_dev_spec_host_add = nlc$sm_incoming_pdu_base + 3,
    nlc$sm_define_subnets = nlc$sm_incoming_pdu_base + 4,
    nlc$sm_end_subnet_definition = nlc$sm_incoming_pdu_base + 5,
    nlc$sm_dest_accessible_response = nlc$sm_incoming_pdu_base + 6,
    nlc$sm_disconnect_indication = nlc$sm_incoming_pdu_base + 7,
    nlc$sm_device_service_attribute = nlc$sm_incoming_pdu_base + 8,
    nlc$sm_incoming_pdu_limit = nlc$sm_disconnect_indication,

{ Outgoing PDU kinds.

    nlc$sm_version_response = nlc$sm_outgoing_pdu_base + 0,
    nlc$sm_define_interface_attrib = nlc$sm_outgoing_pdu_base + 1,
    nlc$sm_confrm_dev_spec_host_add = nlc$sm_outgoing_pdu_base + 2,
    nlc$sm_dest_accessible_request = nlc$sm_outgoing_pdu_base + 3,
    nlc$sm_disconnect_request = nlc$sm_outgoing_pdu_base + 4,
    nlc$sm_outgoing_pdu_limit = nlc$sm_disconnect_request;

  TYPE
    nlt$sm_version = 0 .. 0ff(16),
    nlt$sm_pdu_kind = 0 .. 0ffff(16),
    nlt$sm_pdu_length = 0 .. 0ffff(16),
    nlt$sm_pdu_header = record
      length: nlt$sm_pdu_length,
      kind: nlt$sm_pdu_kind,
    recend,

{ Outgoing PDU formats.

    nlt$sm_version_response = record
      header: nlt$sm_pdu_header,
      common_version: nlt$sm_version
    recend,

    nlt$sm_define_interface_attrib = record
      header: nlt$sm_pdu_header,
      transport_network_selector: nat$network_selector,
      subnet_id: nat$subnet_identifier,
      system_id: nat$system_identifier,
      date_and_time: ost$date_time,
    recend,

    nlt$sm_confrm_dev_spec_host_add = record
      header: nlt$sm_pdu_header,
    recend,

    nlt$sm_dest_accessible_request = record
      header: nlt$sm_pdu_header,
      request_id: nlt$sm_request_identifier,
      destination_address: nat$osi_network_address,
    recend,

    nlt$sm_disconnect_request = record
      header: nlt$sm_pdu_header,
      reason: nlt$sm_disconnect_reason,
    recend,

{ Incoming PDU formats.

    nlt$sm_define_version = record
      smap_version: nlt$sm_version,
    recend,

    nlt$sm_confirm_int_attrib_fixed = record
      header: nlt$sm_pdu_header,
      network_address_length: nat$osi_network_address_length,

{ The following field follows the fixed record.

{     network_address_prefix: nat$osi_network_address_prefix,
    recend,

    nlt$sm_define_dev_spec_host_add = record
      device_specific_host_address: nat$osi_network_address,
    recend,

{ The define_subnet_attributes pdu contains the fixed attributes followed by
{ the variable sized multicast address and the quality of services fields.

    nlt$sm_fixed_subnet_attributes = record
      subnet_id: nat$subnet_identifier,
      directly_connected: boolean,
      subnet_status: nlt$subnet_status,
      subnet_type: nlt$subnet_type,
      max_link_sdu_size: 0 .. 0ffff(16),
      multicast_address_length: nat$osi_network_address_length,
      quality_of_service_size: nlt$quality_of_service_size,

{ The following fields may follow the fixed record.

{     multicast_address: nat$osi_network_address,
{     quality_of_service: nlt$quality_of_service,
    recend,

    nlt$sm_dest_acc_fixed_response = record
      request_id: nlt$sm_request_identifier,
      route_status: nlt$sm_route_status,

{ The following field may follow the fixed record.

{     quality_of_service: nlt$quality_of_service,
    recend,

    nlt$sm_disconnect_indication = record
      reason: nlt$sm_disconnect_reason,
    recend,

    nlt$sm_define_device_service = record
      attribute_list: nlt$sm_device_attributes_list,
    recend;

*copyc nat$network_selector
*copyc nat$osi_network_address
*copyc nat$osi_network_address_prefix
*copyc nat$subnet_identifier
*copyc nat$system_identifier
*copyc nlt$link_sdu_size
*copyc nlt$quality_of_service
*copyc nlt$sm_device_attributes_list
*copyc nlt$sm_disconnect_reason
*copyc nlt$sm_request_identifier
*copyc nlt$sm_route_status
*copyc nlt$subnet_status
*copyc nlt$subnet_type
*copyc ost$date_time
*DECK DECK=NLT$SM_REQUEST_IDENTIFIER EXPAND=FALSE

    TYPE
    nlt$sm_request_identifier = 0 .. 0ffff(16);
*DECK DECK=NLT$SM_ROUTE_STATUS EXPAND=FALSE

  TYPE
    nlt$sm_route_status = (nlc$sm_route_unknown, nlc$sm_route_known, nlc$sm_route_indeterminate);
*DECK DECK=NLT$SUBNET_ATTRIBUTES EXPAND=FALSE

  TYPE
    nlt$subnet_attributes = record
      next_entry: ^nlt$subnet_attributes,
      subnet_id: nat$subnet_identifier,
      quality_of_service: ^nlt$quality_of_service,
      multicast_address: ^SEQ (*),
      CASE directly_connected: boolean OF
      = TRUE =
        subnet_status: nlt$subnet_status,
        subnet_type: nlt$subnet_type,
        max_link_sdu_size: nlt$link_sdu_size,
      CASEND,
    recend;

*copyc nat$subnet_identifier
*copyc nlt$link_sdu_size
*copyc nlt$quality_of_service
*copyc nlt$subnet_status
*copyc nlt$subnet_type
*DECK DECK=NLT$SUBNET_STATUS EXPAND=FALSE

  TYPE
    nlt$subnet_status = (nlc$subnet_down, nlc$subnet_up);
*DECK DECK=NLT$SUBNET_TYPE EXPAND=FALSE

  TYPE
    nlt$subnet_type = (nlc$subnet_ethernet, nlc$subnet_hdlc, nlc$subnet_fddi);
*DECK DECK=NLT$SYSTEM_MANAGEMENT EXPAND=FALSE

  TYPE
    nlt$system_management = record
      device_id: nlt$device_identifier,
      state: nlt$system_management_state,
      connection_id : nat$connection_id,
      network_address_length: nat$osi_network_address_length,
      network_address_prefix: ^nat$osi_network_address_prefix,
      generic_host_address: SEQ (REP nac$osi_max_network_address_len OF cell),
      device_specific_host_address: SEQ (REP nac$osi_max_network_address_len OF cell),
      device_version: nlt$sm_version,
      supported_protocol_class: nat$ta_preferred_protocol_class,
      active_connection_count: ALIGNED [0 MOD 8] integer,
      subnet_list: ^nlt$subnet_attributes,
      new_subnet_list: ^nlt$subnet_attributes,
    recend;

*copyc nat$connection_id
*copyc nat$osi_network_address
*copyc nat$osi_network_address_prefix
*copyc nat$ta_preferred_protocol_class
*copyc nlt$device_identifier
*copyc nlt$sm_protocol_data_unit
*copyc nlt$subnet_attributes
*copyc nlt$system_management_state
*DECK DECK=NLT$SYSTEM_MANAGEMENT_STATE EXPAND=FALSE

{ NOTE: During initialization phase 1 the System Management Entity negotiates
{       the version and exchanges addresses. During initialization phase 2, the
{       network layer saps are opened via network access and the device is
{       configured.

  TYPE
    nlt$system_management_state = (nlc$sm_uninitialized, nlc$sm_initialization_phase1,
      nlc$sm_initialization_phase2, nlc$sm_initialized);
*DECK DECK=NLT$TA_AGGREGATE_MESSAGE EXPAND=FALSE

  TYPE
    nlt$ta_aggregate_message = array [1 .. * ] of nlt$ta_aggregate,

    nlt$ta_aggregate = record
      case kind: nlt$ta_event_kind of
      = nlc$ta_data_event =
        end_of_message: boolean,
        data: nlt$bm_message_id,
      = nlc$ta_expedited_data_event =
        expedited_data: nlt$bm_message_id,
      casend,
    recend;

*copyc nlt$bm_message_id
*copyc nlt$ta_event
*DECK DECK=NLT$TA_CONNECTION EXPAND=FALSE

  TYPE
    nlt$ta_connection = record
      accumulated_message_buffers: integer,
      event_processor: nat$network_procedure,
      state: nlt$ta_connection_states,
      unconfirmed_expedited_requests: 0 .. 0ff(16),
      process_expedited_data: boolean,
      expedited_data_allowed: boolean,
    recend;

*copyc nat$network_procedure
*copyc nlt$ta_connection_states
*DECK DECK=NLT$TA_CONNECTION_STATES EXPAND=FALSE

{
{   NLC$TA_CLOSED                   - the connection has been disconnected or
{                                     the connections inital state.
{   NLC$TA_CONNECT_CONFIRM_WAIT     - a connection request has been sent to the
{                                     peer.  Waiting for the peer to respond
{                                     with a confirm or a reject (disconnect).
{   NLC$TA_CONNECT_RESPONSE_WAIT    - a connect indication has been received
{                                     from the peer.  A connect indication
{                                     has been sent to the user.  Waiting for
{                                     the user to respond with an accept or a
{                                     reject (disconnect).
{   NLC$TA_OPEN                     - the connection is open.

  TYPE
    nlt$ta_connection_states = (nlc$ta_closed, nlc$ta_connect_confirm_wait,
          nlc$ta_connect_response_wait, nlc$ta_open);

*DECK DECK=NLT$TA_DISCONNECT_REASON EXPAND=FALSE

  CONST
    nlc$ta_max_disconnect_reason = 127(10),
    nlc$ta_min_disconnect_reason = 96(10);

  CONST
    nlc$ta_expedited_not_pending = nlc$ta_min_disconnect_reason + 5,
    nlc$ta_expedited_not_selected = nlc$ta_min_disconnect_reason + 6,
    nlc$ta_header_indiscernible = nlc$ta_min_disconnect_reason + 4,
    nlc$ta_header_length_incorrect = nlc$ta_min_disconnect_reason + 3,
    nlc$ta_invalid_encoding = nlc$ta_min_disconnect_reason + 1,
    nlc$ta_message_exceeds_max_len = nlc$ta_min_disconnect_reason + 2,
    nlc$ta_system_congested = nlc$ta_min_disconnect_reason + 0,
    nlc$ta_user_disconnect_request = 0;

  TYPE
    nlt$ta_disconnect_reason = 0 .. 0ff(16);

*DECK DECK=NLT$TA_EVENT EXPAND=FALSE

{
{   NLC$TA_CLEAR_TO_SEND_EVENT      - indicates that the external interface
{                                        will be allowed to send data queued
{                                        in its co-routine mechanism.
{   NLC$TA_CONNECT_EVENT            - indicates that the peer has issued
{                                        a connect request.
{   NLC$TA_CONNECT_CONFIRM_EVENT    - indicates that the peer has accepted
{                                        the local users connect request.
{   NLC$TA_DISCONNECT_EVENT         - indicates that the connection has been
{                                        terminated.
{   NLC$TA_DATA_EVENT               - indicates data sent from the peer.
{   NLC$TA_EXPEDITED_DATA_EVENT     - indicates expedited data from the peer.

  TYPE

    nlt$ta_event = record
      case kind: nlt$ta_event_kind of
      = nlc$ta_connect_event =
        osi_connect: nlt$ta_connect,
      = nlc$ta_connect_confirm_event =
        osi_connect_confirm: nlt$ta_connect_confirm,
      = nlc$ta_disconnect_event =
        osi_disconnect: nlt$ta_disconnect,
      = nlc$ta_data_event =
        osi_data: nlt$ta_data,
      = nlc$ta_expedited_data_event =
        osi_expedited_data: nlt$ta_expedited_data,
      = nlc$ta_clear_to_send_event =
      casend,
    recend,

    nlt$ta_event_kind = (nlc$ta_clear_to_send_event, nlc$ta_connect_event,
          nlc$ta_connect_confirm_event, nlc$ta_disconnect_event, nlc$ta_data_event,
          nlc$ta_expedited_data_event),

    nlt$ta_connect = record
      checksum: boolean,
      destination_transport_sap: nlt$ta_sap_selector, {local taa's service access point.
      expedited_data: boolean,
      quality_of_service: ^nlt$ta_quality_of_service,
      source_address: nat$osi_transport_address, {peer's address
      data: nlt$bm_message_id,
    recend,

    nlt$ta_connect_confirm = record
      checksum: boolean,
      expedited_data: boolean,
      quality_of_service: ^nlt$ta_quality_of_service,
      data: nlt$bm_message_id,
    recend,

    nlt$ta_disconnect = record
      osi_8073_reason: nat$osi_disconnect_reason,
      proprietary_reason: nlt$ta_disconnect_reason,
      data: nlt$bm_message_id,
    recend,

    nlt$ta_data = record
      end_of_message: boolean,
      data: nlt$bm_message_id,
    recend,

    nlt$ta_expedited_data = record
      data: nlt$bm_message_id,
    recend;

*copyc nat$osi_disconnect_reason
*copyc nat$osi_transport_address
*copyc nlt$bm_message_id
*copyc nlt$ta_disconnect_reason
*copyc nlt$ta_quality_of_service
*copyc nlt$ta_sap_selector
*DECK DECK=NLT$TA_EVENT_PROCESSOR EXPAND=FALSE

  TYPE
    nlt$ta_event_processor = ^procedure (cl_connection: ^nlt$cl_connection;
          event: nlt$ta_event;
      VAR inventory_report: nlt$ta_inventory_report);

*copyc nlt$cl_connection
*copyc nlt$ta_event
*copyc nlt$ta_inventory_report
*DECK DECK=NLT$TA_INVENTORY_REPORT EXPAND=FALSE

  TYPE
    nlt$ta_inventory_report = record
      CASE changed: boolean OF
      = TRUE =
        accumulated_message_buffers: integer,
      CASEND,
    recend;
*DECK DECK=NLT$TA_PRIORITY EXPAND=FALSE

{
{ NOTE:
{   The highest priority is 14.  A value outside of the range
{   0 .. 14 will be interpreted as 0 (the lowest priority).

  CONST
    nlc$ta_highest_priority = 14;

  TYPE
    nlt$ta_priority = 0 .. 0ffff(16);
*DECK DECK=NLT$TA_PROTOCOL_DATA_UNIT EXPAND=FALSE

  CONST
    incoming_pdu_base = 400(16), { From the device to the host.
    outgoing_pdu_base = 480(16); { From the host to the device.

  CONST
    nlc$ta_connect_request = incoming_pdu_base + 3,          {403(16)
    nlc$ta_connect_response = incoming_pdu_base + 4,         {404(16)
    nlc$ta_data_request = incoming_pdu_base + 5,             {405(16)
    nlc$ta_disconnect_request = incoming_pdu_base + 7,       {407(16)
    nlc$ta_expedited_request = incoming_pdu_base + 6,        {406(16)

    nlc$ta_connect_confirmation = outgoing_pdu_base + 6,     {486(16)
    nlc$ta_connect_indication = outgoing_pdu_base + 5,       {485(16)
    nlc$ta_data_indication = outgoing_pdu_base + 7,          {487(16)
    nlc$ta_disconnect_indication = outgoing_pdu_base + 10,   {48A(16)
    nlc$ta_expedited_confirmation = outgoing_pdu_base + 9,   {489(16)
    nlc$ta_expedited_indication = outgoing_pdu_base + 8,     {488(16)
    nlc$ta_max_protocol_data_unit = 0ffff(16);

  TYPE

    nlt$ta_header_length = 0 .. 0ffff(16),

    nlt$ta_protocol_data_unit_kind = 0 .. nlc$ta_max_protocol_data_unit,

    nlt$ta_connect_confirm_pdu = record
      length: nlt$ta_header_length,
      kind: nlt$ta_protocol_data_unit_kind,
      checksum: boolean,
      expedited_data: boolean,
      quality_of_service_length: nlt$ta_quality_of_service_len,
{     ( Variable fields )
{     quality_of_service: 0 .. 49 bytes
{     response_data: 0 .. 32 bytes
    recend,

    nlt$ta_connect_indication_pdu = record
      length: nlt$ta_header_length,
      kind: nlt$ta_protocol_data_unit_kind,
      destination_transport_sap: nlt$ta_sap_selector,
      checksum: boolean,
      expedited_data: boolean,
      source_transport_sap_length: nat$osi_tsap_selector_length,
{     ( Variable fields )
{     source_transport_sap: 0 .. 255 bytes
{     source_nsap_address_len: 1 byte
{     source_nsap_address: 1 .. 255 bytes
{     quality_of_service_length: 1 byte
{     quality_of_service: 0 .. 49 bytes
{     connect_data: 0 .. 32 bytes
    recend,

    nlt$ta_connect_request_pdu = record
      length: nlt$ta_header_length,
      kind: nlt$ta_protocol_data_unit_kind,
      source_transport_sap: nlt$ta_sap_selector,
      checksum: boolean,
      expedited_data: boolean,
      priority: nlt$ta_priority,
      destination_transport_sap_len: nat$osi_tsap_selector_length,
{     ( Variable fields )
{     destination_transport_sap: 0 .. 255 bytes
{     destination_nsap_address_len: 1 byte
{     destination_nsap_address: 1 .. 255 bytes
{     quality_of_service_length: 1 byte
{     quality_of_service: 0 .. 49 bytes
{     connect_data: 0 .. 32 bytes
    recend,

    nlt$ta_connect_request_pdu_v2 = record
      length: nlt$ta_header_length,
      kind: nlt$ta_protocol_data_unit_kind,
      source_transport_sap: nlt$ta_sap_selector,
      checksum: boolean,
      expedited_data: boolean,
      priority: nlt$ta_priority,
      preferred_protocol_class: nat$ta_preferred_protocol_class,
      alternate_protocol_class: nat$ta_alternate_protocol_class,
      destination_transport_sap_len: nat$osi_tsap_selector_length,
{     ( Variable fields )
{     destination_transport_sap: 0 .. 255 bytes
{     destination_nsap_address_len: 1 byte
{     destination_nsap_address: 1 .. 255 bytes
{     quality_of_service_length: 1 byte
{     quality_of_service: 0 .. 49 bytes
{     connect_data: 0 .. 32 bytes
    recend,

    nlt$ta_connect_response_pdu = record
      length: nlt$ta_header_length,
      kind: nlt$ta_protocol_data_unit_kind,
      checksum: boolean,
      expedited_data: boolean,
      priority: nlt$ta_priority,
      quality_of_service_length: nlt$ta_quality_of_service_len,
{     ( Variable fields )
{     quality_of_service: 0 .. 49 bytes
{     response_data: 0 .. 32 bytes
    recend,

    nlt$ta_data_pdu = record
      length: nlt$ta_header_length,
      kind: nlt$ta_protocol_data_unit_kind,
      end_of_message: boolean,
{     ( Variable fields )
{     data: 1 .. maximum number of bytes allowed by the communication device
    recend,

    nlt$ta_disconnect_indicat_pdu = record
      length: nlt$ta_header_length,
      kind: nlt$ta_protocol_data_unit_kind,
      proprietary_reason: nlt$ta_disconnect_reason, { CDNA disconnect reason
      osi_8073_reason: nat$osi_disconnect_reason, { OSI disconnect reason
{     ( Variable fields )
{     disconnect_data: 0 .. 64 bytes
    recend,

    nlt$ta_disconnect_request_pdu = record
      length: nlt$ta_header_length,
      kind: nlt$ta_protocol_data_unit_kind,
      proprietary_reason: nlt$ta_disconnect_reason,
{     ( Variable fields )
{     user_data: 0 .. 64 bytes
    recend,

    nlt$ta_expedited_data_pdu = record
      length: nlt$ta_header_length,
      kind: nlt$ta_protocol_data_unit_kind,
{     ( Variable fields )
{     expedited_data: 1 .. 16 bytes    The expedited confirm pdu does not have data field.
    recend;

*copyc nat$osi_disconnect_reason
*copyc nat$osi_transport_sap_selector
*copyc nat$ta_alternate_protocol_class
*copyc nat$ta_preferred_protocol_class
*copyc nlt$ta_disconnect_reason
*copyc nlt$ta_priority
*copyc nlt$ta_quality_of_service
*copyc nlt$ta_sap_selector

*DECK DECK=NLT$TA_QUALITY_OF_SERVICE EXPAND=FALSE

  TYPE
    nlt$ta_quality_of_service = array [ 0 .. * ] of
          nlt$ta_quality_of_service_item,

    nlt$ta_quality_of_service_code = 0 .. 0ffff(16),

    nlt$ta_quality_of_service_item = record
      code: nlt$ta_quality_of_service_code,
      length: nlt$ta_qual_of_serv_value_len,
      value: ^string ( * ),
    recend,

    nlt$ta_qual_of_serv_value_len = 0 .. 0ff(16),

    nlt$ta_quality_of_service_len = 0 .. 0ff(16);
*DECK DECK=NLT$TA_SAP_SELECTOR EXPAND=FALSE

  TYPE
    nlt$ta_sap_selector = nlc$ta_low_min_osi_sap ..
          nlc$ta_max_se_session_sap;

*copyc nlc$ta_sap_ranges
*DECK DECK=NLT$TCPAA_CONNECTION EXPAND=FALSE

  TYPE
    nlt$tcpaa_connection = record
      device_id: nlt$device_identifier,
      event_processor: nat$network_procedure,
      listen_active: boolean,
      state: nlt$tcpaa_connection_state,
      flush_release_timer: nlt$timer,
    recend;

*copyc nat$network_procedure
*copyc nlt$device_identifier
*copyc nlt$tcpaa_connection_state
*copyc nlt$timer

*DECK DECK=NLT$TCPAA_CONNECTION_STATE EXPAND=FALSE

  TYPE
    nlt$tcpaa_connection_state = (nlc$tcpaa_conn_open, nlc$tcpaa_conn_closed,
          nlc$tcpaa_conn_closing, nlc$tcpaa_conn_await_confirm,
          nlc$tcpaa_conn_await_accept);

*DECK DECK=NLT$TCPAA_EVENT EXPAND=FALSE

  TYPE
    nlt$tcpaa_event = record
      case kind: nlt$tcpaa_event_kind of
      = nlc$tcpaa_connect_event =
        connect: nlt$tcpaa_connect_event,
      = nlc$tcpaa_connect_confirm_event =
        connect_confirm: nlt$tcpaa_connect_confirm_event,
      = nlc$tcpaa_listen_confirm_event =
        listen_confirm: nlt$tcpaa_listen_confirm_event,
      = nlc$tcpaa_listen_reject_event =
        listen_reject: nlt$tcpaa_listen_reject_event,
      = nlc$tcpaa_data_event =
        data: nlt$tcpaa_data_event,
      = nlc$tcpaa_clear_to_send_event =
        ,
      = nlc$tcpaa_release_event =
        release: nlt$tcpaa_release_event,
      casend,
    recend,

    nlt$tcpaa_connect_event = record
      destination_socket: nat$sk_socket_address,
      source_socket: nat$sk_socket_address,
      device_id: nlt$device_identifier,
    recend,

    nlt$tcpaa_connect_confirm_event = record
      local_port: nat$sk_port_number,
    recend,

    nlt$tcpaa_listen_confirm_event = record
      local_port: nat$sk_port_number,
    recend,

    nlt$tcpaa_listen_reject_event = record
      reason: nlt$tcpaa_release_ind_reason,
    recend,

    nlt$tcpaa_data_event = record
      push_data: boolean,
      urgent_data: boolean,
      data: nlt$bm_message_id,
    recend,

    nlt$tcpaa_release_event = record
      case reason: nlt$tcpaa_release_ind_reason of
      = nlc$tcpaa_ri_network_disconnect =
        cc_disconnect_reason: nlt$cc_disconnect_reason,
      casend,
    recend;

*copyc nat$sk_socket_address
*copyc nlt$bm_message_id
*copyc nlt$cc_interface
*copyc nlt$device_identifier
*copyc nlt$tcpaa_event_kind
*copyc nlt$tcpaa_release_ind_reason
*DECK DECK=NLT$TCPAA_EVENT_KIND EXPAND=FALSE

  TYPE
    nlt$tcpaa_event_kind = (nlc$tcpaa_connect_event,
          nlc$tcpaa_connect_confirm_event, nlc$tcpaa_listen_confirm_event,
          nlc$tcpaa_listen_reject_event, nlc$tcpaa_data_event,
          nlc$tcpaa_clear_to_send_event, nlc$tcpaa_release_event);

*DECK DECK=NLT$TCPAA_EVENT_PROCESSOR EXPAND=FALSE

  TYPE
    nlt$tcpaa_event_processor = ^procedure (cl_connection: ^nlt$cl_connection;
          event: nlt$tcpaa_event;
      VAR inventory_report: integer);

*copyc nlt$cl_connection
*copyc nlt$tcpaa_event
*DECK DECK=NLT$TCPAA_INVENTORY_REPORT EXPAND=FALSE

  TYPE
    nlt$tcpaa_inventory_report = record
      CASE changed: boolean OF
      = TRUE =
        accumulated_message_buffers: integer,
      CASEND,
    recend;
*DECK DECK=NLT$TCPAA_LISTEN_REJECT_REASON EXPAND=FALSE

  CONST
    nlc$tcpaa_lr_resources_unavail = 1,
    nlc$tcpaa_lr_port_in_use = 2;

*DECK DECK=NLT$TCPAA_PDU_HEADER EXPAND=FALSE

  TYPE
    nlt$tcpaa_pdu_header = record
      length: nlt$tcpaa_pdu_length,
      kind: nlt$tcpaa_pdu_kind,
    recend;

*copyc nlt$tcpaa_pdu_kind
*copyc nlt$tcpaa_pdu_length

*DECK DECK=NLT$TCPAA_PDU_KIND EXPAND=FALSE

  CONST
    nlc$tcpaa_outgoing_pdu_base = 1400(16),      { host to device }
    nlc$tcpaa_incoming_pdu_base = 1480(16),      { device to host }

{ Incoming PDU kinds.

    nlc$tcpaa_listen_confirm_ind = nlc$tcpaa_incoming_pdu_base + 0,
    nlc$tcpaa_listen_reject_ind = nlc$tcpaa_incoming_pdu_base + 1,
    nlc$tcpaa_connect_ind = nlc$tcpaa_incoming_pdu_base + 2,
    nlc$tcpaa_connect_confirm_ind = nlc$tcpaa_incoming_pdu_base + 3,
    nlc$tcpaa_release_ind = nlc$tcpaa_incoming_pdu_base + 4,
    nlc$tcpaa_data_ind = nlc$tcpaa_incoming_pdu_base + 5,
    nlc$tcpaa_flush_release_ind = nlc$tcpaa_incoming_pdu_base + 6,

{ Outgoing PDU kinds.

    nlc$tcpaa_listen_req = nlc$tcpaa_outgoing_pdu_base + 0,
    nlc$tcpaa_connect_req = nlc$tcpaa_outgoing_pdu_base + 1,
    nlc$tcpaa_accept_connect_req = nlc$tcpaa_outgoing_pdu_base + 2,
    nlc$tcpaa_release_req = nlc$tcpaa_outgoing_pdu_base + 3,
    nlc$tcpaa_data_req = nlc$tcpaa_outgoing_pdu_base + 4,
    nlc$tcpaa_set_options_req = nlc$tcpaa_outgoing_pdu_base + 5,
    nlc$tcpaa_flush_release_req = nlc$tcpaa_outgoing_pdu_base + 6;

  TYPE
    nlt$tcpaa_pdu_kind = 0 .. 0ffff(16);

*DECK DECK=NLT$TCPAA_PDU_LENGTH EXPAND=FALSE

  TYPE
    nlt$tcpaa_pdu_length = 0 .. 0ffff(16);

*DECK DECK=NLT$TCPAA_PROTOCOL_DATA_UNIT EXPAND=FALSE

{ This common deck describes the format of the Protocol Data Units sent and
{ received by the TCP Access Agent.

  TYPE
    nlt$tcpaa_pdu_length = 0 .. 0ffff(16),

    nlt$tcpaa_pdu_header = record
      length: nlt$tcpaa_pdu_length,
      kind: nlt$tcpaa_pdu_kind,
    recend,

{ Outgoing PDU formats.

    nlt$tcpaa_listen_request_pdu = record
      header: nlt$tcpaa_pdu_header,
      local_port: nat$sk_port_number,
      queue_limit: 0 .. 0ffff(16),
      source_port: nat$sk_port_number,
      ack_delay_time: nlt$sk_tcp_ack_delay_time,
      source_ip_address: nat$sk_ip_address,
    recend,

    nlt$tcpaa_release_request_pdu = record
      header: nlt$tcpaa_pdu_header,
      reason: nlt$tcpaa_release_req_reason,
    recend,

    nlt$tcpaa_connect_request_pdu = record
      header: nlt$tcpaa_pdu_header,
      source_port: nat$sk_port_number,
      destination_port: nat$sk_port_number,
      source_ip_address: nat$sk_ip_address,
      destination_ip_address: nat$sk_ip_address,
      ack_delay_time: nlt$sk_tcp_ack_delay_time,
      graceful_close: boolean,
      traffic_pattern: nat$sk_traffic_pattern,
    recend,

    nlt$tcpaa_accept_request_pdu = record
      header: nlt$tcpaa_pdu_header,
      graceful_close: boolean,
      traffic_pattern: nat$sk_traffic_pattern,
    recend,

    nlt$tcpaa_data_request_pdu = record
      header: nlt$tcpaa_pdu_header,
      urgent_data: boolean,
      push_data: boolean,
{ Variable sized user data follows.
    recend,

    nlt$tcpaa_set_options_req_pdu = record
      header: nlt$tcpaa_pdu_header,
      graceful_close: boolean,
      traffic_pattern: nat$sk_traffic_pattern,
      ack_delay_time: nlt$sk_tcp_ack_delay_time,
    recend,

    nlt$tcpaa_flush_release_req_pdu = record
      header: nlt$tcpaa_pdu_header,
    recend,

{ Incoming PDU formats.

    nlt$tcpaa_release_ind_pdu = record
      header: nlt$tcpaa_pdu_header,
      reason: nlt$tcpaa_release_ind_reason,
    recend,

    nlt$tcpaa_conn_confirm_ind_pdu = record
      header: nlt$tcpaa_pdu_header,
      local_port: nat$sk_port_number,
    recend,

    nlt$tcpaa_connect_ind_pdu = record
      header: nlt$tcpaa_pdu_header,
      destination_port: nat$sk_port_number,
      source_port: nat$sk_port_number,
      destination_ip_address: nat$sk_ip_address,
      source_ip_address: nat$sk_ip_address,
    recend,

    nlt$tcpaa_data_ind_pdu = record
      header: nlt$tcpaa_pdu_header,
      urgent_data: boolean,
      push_data: boolean,
{ Variable sized user data follows.
    recend,

    nlt$tcpaa_flush_release_ind_pdu = record
      header: nlt$tcpaa_pdu_header,
    recend;

*copyc nat$sk_ip_address
*copyc nat$sk_port_number
*copyc nat$sk_traffic_pattern
*copyc nlt$sk_tcp_ack_delay_time
*copyc nlt$tcpaa_pdu_kind
*copyc nlt$tcpaa_release_ind_reason
*copyc nlt$tcpaa_release_req_reason
*DECK DECK=NLT$TCPAA_RELEASE_IND_REASON EXPAND=FALSE

{ The '_lri_'  in the following definitions stands for
{ 'listen_release_indication'. These are the release socket
{ reason codes received via the listen socket reject indication
{ from the TCP Access Provider.

  CONST
    nlc$tcpaa_lri_resources_unavail = 1,
    nlc$tcpaa_lri_port_in_use = 2;

{ The '_ri_'  in the following definitions stands for
{ 'release_indication'. These are the release socket
{ reason codes received via the release socket indication
{ from the TCP Access Provider.

  CONST
    nlc$tcpaa_ri_user_data_too_big = 1,
    nlc$tcpaa_ri_peer_termination = 2,
    nlc$tcpaa_ri_user_termination = 3,
    nlc$tcpaa_ri_peer_not_respond = 4,
    nlc$tcpaa_ri_address_in_use = 5,
    nlc$tcpaa_ri_protocol_error = 11,
    nlc$tcpaa_ri_flush_confirm = 12,
    nlc$tcpaa_ri_network_disconnect = 13; { CC disconnect.

  TYPE
    nlt$tcpaa_release_ind_reason = 0 .. 0ff(16);




*DECK DECK=NLT$TCPAA_RELEASE_REQ_REASON EXPAND=FALSE

{ The '_rr_'  in the following definitions stands for
{ 'release_request'. These are the release socket reason
{ codes sent to the TCP Access Provider by the TCP Access
{ Agent.

  CONST
    nlc$tcpaa_rr_user_request = 1,
    nlc$tcpaa_rr_protocol_error = 10,
    nlc$tcpaa_rr_flush_confirm = 12,
    nlc$tcpaa_rr_header_indiscern = 13,
    nlc$tcpaa_rr_header_length_in = 14,
    nlc$tcpaa_rr_invalid_encoding = 15;

  TYPE
    nlt$tcpaa_release_req_reason = 0 .. 0ff(16);

*DECK DECK=NLT$TCPIP_ADDRESS EXPAND=FALSE
{
{ NOTE:
{   The type nlt$tcpip_address is a 32 bit address.  There are three address classes A, B, and C.
{   The class is identified by the first two bits of the address.  The first two bits of a class
{   A address are either 00(2) or 01(2).  The first two bits of a class B address are 10(2).  The
{   first two bits of a class C address are 11(2).  Class A has a one byte (8 bit) network identifier
{   and a 3 byte (24 bit) host identifier.  Class B has a two byte (16 bit) network identifier and a
{   2 byte (16 bit) host identifier.  Class C has a three byte (24 bit) network identifier and a 1
{   byte (8 bit) host identifier.

  TYPE
    nlt$tcpip_address = packed record
      case 0 .. 6 of
      = 0 =
        full: 0 .. 0ffffffff(16),
      = 1 =
        sub_part: array [1 .. 4] of 0 .. 0ff(16),
      = 2 =
        set_value: set of 0 .. 31,
      = 3 =
        class: 0 .. 3,
      = 4 =
        network_id_class_a: 0 .. 0ff(16),
        host_id_class_a: 0 .. 0ffffff(16),
      = 5 =
        network_id_class_b: 0 .. 0ffff(16),
        host_id_class_b: 0 .. 0ffff(16),
      = 6 =
        network_id_class_c: 0 .. 0ffffff(16),
        host_id_class_c: 0 .. 0ff(16),
      casend,
    recend;
*DECK DECK=NLT$TCPIP_ADDRESS_CLASS EXPAND=FALSE

  CONST
    nlc$tcpip_class_a = 0,
    nlc$tcpip_class_b = 2,
    nlc$tcpip_class_c = 3;

  TYPE
    nlt$tcpip_address_class = nlc$tcpip_class_a .. nlc$tcpip_class_b;
*DECK DECK=NLT$TCP_ASSIGNED_PORT EXPAND=FALSE

  TYPE
    nlt$tcp_assigned_port = record
      port: nat$sk_port_number,
      usage_count: 0 .. 0ff(16),  { ?? }
      owner: ost$global_task_id,
    recend;

*copyc nat$sk_port_number
*copyc ost$global_task_id
*DECK DECK=NLT$TCP_ASSIGNED_PORTS EXPAND=FALSE

  TYPE
    nlt$tcp_assigned_ports = record
      next_entry: ^nlt$tcp_assigned_ports,
      assigned_ports: array [1 .. 0ff(16)] of nlt$tcp_assigned_port,
    recend;

*copyc nlt$tcp_assigned_port
*DECK DECK=NLT$TCP_CONNECTION_STATE EXPAND=FALSE

  TYPE
    nlt$tcp_connection_state = (nlc$tcp_conn_closed, nlc$tcp_conn_open,
      nlc$tcp_conn_await_confirm, nlc$tcp_conn_await_accept, nlc$tcp_conn_offered,
      nlc$tcp_conn_terminated, nlc$tcp_conn_closing);

*DECK DECK=NLT$TCP_LISTEN_SOCKET EXPAND=FALSE

  TYPE
    nlt$tcp_listen_socket = record
      access_control: nlt$access_control,
      next_entry: ^nlt$tcp_listen_socket,
      identifier: nat$sk_socket_identifier,
      port: nat$sk_port_number,
      application: nat$application_name,
      bound_address: nat$sk_ip_address,
      queue_limit: nat$sk_listen_queue_limit,
      selection_criteria: nat$sk_socket_address,
      received_sockets: ^nlt$tcp_received_socket,
      wait_for_socket_list: ^nlt$tcp_wait_for_socket,
      device_list: nlt$tcp_socket_device_list,
    recend;

*copyc nat$application_name
*copyc nat$sk_ip_address
*copyc nat$sk_listen_queue_limit
*copyc nat$sk_socket_address
*copyc nat$sk_socket_identifier
*copyc nlt$access_control
*copyc nlt$tcp_received_socket
*copyc nlt$tcp_socket_device_list
*copyc nlt$tcp_wait_for_socket
*DECK DECK=NLT$TCP_LISTEN_SOCKETS EXPAND=FALSE

  TYPE
    nlt$tcp_listen_sockets = record
      access_control: nlt$access_control,
      list: ^nlt$tcp_listen_socket,
    recend;

*copyc nlt$access_control
*copyc nlt$tcp_listen_socket
*DECK DECK=NLT$TCP_LISTEN_SOCKET_LIST EXPAND=FALSE

  TYPE
    nlt$tcp_listen_socket_list = record
      access_control: nlt$access_control,
      listen_sockets_list: ^nlt$tcp_listen_socket,
    recend;

*copyc nlt$access_control
*copyc nlt$tcp_listen_socket
*DECK DECK=NLT$TCP_OPEN_PORT EXPAND=FALSE

  TYPE
    nlt$tcp_open_port = record
      next_entry: ^nlt$tcp_open_port,
      port: nat$sk_port_number,
      ip_address: nat$sk_ip_address,
      listen_active: boolean,
      count: 0 .. 0ff(16),
    recend;

*copyc nat$sk_ip_address
*copyc nat$sk_port_number
*DECK DECK=NLT$TCP_PORTS EXPAND=FALSE

{ The TCP ports have been divided into the following ranges:
{       Reserved range - 1 to 1023
{       Variable range - 1024 to 65535

  TYPE
    nlt$tcp_ports = record
      lock: ost$signature_lock,
      next_assignable_port: nlc$sk_min_assigned_port .. nlc$sk_max_assigned_port,
      open_ports: ^nlt$tcp_open_port,
    recend;

*copyc nlc$sk_max_assigned_port
*copyc nlc$sk_min_assigned_port
*copyc nlt$tcp_open_port
*copyc ost$signature_lock
*DECK DECK=NLT$TCP_RECEIVED_DATA EXPAND=FALSE

  TYPE
    nlt$tcp_received_data = record
      next_entry: ^nlt$tcp_received_data,
      message_id: nlt$bm_message_id,
      push_flag: boolean,
      urgent_flag: boolean,
      length: integer,
      buffer_count: integer,
    recend;

*copyc nlt$bm_message_id


*DECK DECK=NLT$TCP_RECEIVED_SOCKET EXPAND=FALSE

  TYPE
    nlt$tcp_received_socket = record
      next_entry: ^nlt$tcp_received_socket,
      connection_id: nat$connection_id,
      source_socket: nat$sk_socket_address,
      destination_socket: nat$sk_socket_address,
      CASE connected: boolean OF
      = FALSE =
        release_reason: nlt$tcpaa_release_ind_reason,
      CASEND,
    recend;

*copyc nat$connection_id
*copyc nat$sk_socket_address
*copyc nlt$tcpaa_release_ind_reason
*DECK DECK=NLT$TCP_RECEIVER_TASK EXPAND=FALSE

  TYPE
    nlt$tcp_receiver_task = record
      next_entry: ^nlt$tcp_receiver_task,
      task_id: ost$global_task_id,
      CASE receive_type: nlt$tcp_receive_type OF
      = nlc$tcp_await_data_available =
        receiver_active: boolean,
      = nlc$tcp_receive_data =
        data_buffer: ^nat$data_fragments,
        remaining_buffer_capacity: integer,
        received_data_length: ^integer,
        urgent_flag: ^boolean,
        activity_status: ^ost$activity_status,
      CASEND,
    recend;

*copyc nat$data_fragments
*copyc nlt$tcp_receive_type
*copyc ost$activity_status
*copyc ost$global_task_id


*DECK DECK=NLT$TCP_RECEIVE_TYPE EXPAND=FALSE

  TYPE
    nlt$tcp_receive_type = (nlc$tcp_receive_data, nlc$tcp_await_data_available);

*DECK DECK=NLT$TCP_SENDER_TASK EXPAND=FALSE

  TYPE
    nlt$tcp_sender_task = record
      next_entry: ^nlt$tcp_sender_task,
      task_id: ost$global_task_id,
      send_type: nlt$tcp_send_type,
    recend;

*copyc nlt$tcp_send_type
*copyc ost$global_task_id
*DECK DECK=NLT$TCP_SEND_TYPE EXPAND=FALSE

  TYPE
    nlt$tcp_send_type = (nlc$tcp_send_data, nlc$tcp_await_clear_to_send);

*DECK DECK=NLT$TCP_SOCKET_DEVICE EXPAND=FALSE

  TYPE
    nlt$tcp_socket_device = record
      device_id: nlt$device_identifier,
      ip_address: nat$sk_ip_address,
      status: nlt$tcp_socket_device_status,
      connection_id: nat$connection_id,
    recend;

*copyc nat$connection_id
*copyc nat$sk_ip_address
*copyc nlt$device_identifier
*copyc nlt$tcp_socket_device_status
*DECK DECK=NLT$TCP_SOCKET_DEVICE_LIST EXPAND=FALSE

  TYPE
    nlt$tcp_socket_device_list = array [1 .. *] of nlt$tcp_socket_device;

*copyc nlt$tcp_socket_device
*DECK DECK=NLT$TCP_SOCKET_DEVICE_STATUS EXPAND=FALSE

  TYPE
    nlt$tcp_socket_device_status = (nlc$tcp_device_closed, nlc$tcp_device_open,
      nlc$tcp_device_await_confirm, nlc$tcp_device_res_constraint);
*DECK DECK=NLT$TCP_SOCKET_LAYER EXPAND=FALSE

  TYPE
    nlt$tcp_socket_layer = record
      state: nlt$tcp_connection_state,
      disconnect_reason: nlt$tcpaa_release_ind_reason,
      device_id: nlt$device_identifier,
      user_initiated_close: boolean,
      socket_id: nat$sk_socket_identifier,
      socket_type: nlt$tcp_socket_type,
      inventory_report: integer,
      send_queue: ^nlt$tcp_sender_task,
      receive_queue: ^nlt$tcp_receiver_task,
      received_data: ^nlt$tcp_received_data,
      available_sender_pool: ^nlt$tcp_sender_task,
      available_receiver_pool: ^nlt$tcp_receiver_task,
      available_data_pool: ^nlt$tcp_received_data,
      source_socket: nat$sk_socket_address,
      destination_socket: nat$sk_socket_address,
      waiting_task_id: ost$global_task_id,
    recend;

*copyc nat$sk_socket_address
*copyc nat$sk_socket_identifier
*copyc nlt$device_identifier
*copyc nlt$tcp_connection_state
*copyc nlt$tcp_received_data
*copyc nlt$tcp_receiver_task
*copyc nlt$tcp_sender_task
*copyc nlt$tcp_socket_type
*copyc nlt$tcpaa_release_ind_reason
*copyc ost$global_task_id
*DECK DECK=NLT$TCP_SOCKET_TYPE EXPAND=FALSE

  TYPE
    nlt$tcp_socket_type = (nlc$tcp_null_socket, nlc$tcp_connect_socket, nlc$tcp_accept_socket,
      nlc$tcp_listen_socket);
*DECK DECK=NLT$TCP_WAIT_FOR_SOCKET EXPAND=FALSE

  TYPE
    nlt$tcp_wait_for_socket = record
      next_entry: ^nlt$tcp_wait_for_socket,
      task_id: ost$global_task_id,
    recend;

*copyc ost$global_task_id

*DECK DECK=NLT$TIMER EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  TYPE
    nlt$timer = record
      CASE selected: boolean OF
      = TRUE =
        count: nlt$timer_count,
        expiration_time: integer,
      CASEND,
    recend,

    nlt$timer_count = 0 .. 255;

  CONST
    nlc$sap_timer_duration = (2 * 60 * 1000 * 1000);    {Time durations are microseconds.}
*DECK DECK=NLT$TM_ADDRESS_ACCESSIBLE_TASK EXPAND=FALSE

  TYPE
    nlt$tm_address_accessible_task = record
      nextt: ^nlt$tm_address_accessible_task,
      task_id: ost$global_task_id,
    recend;

*copyc ost$global_task_id
*DECK DECK=NLT$TM_ADDR_ACCESS_REQ_ENTRY EXPAND=FALSE

  TYPE
    nlt$tm_addr_access_req_entry = record
      nextt: ^nlt$tm_addr_access_req_entry,
      request_id: nlt$tm_request_identifier,
      task_id: ost$global_task_id,
      destination_address: nlt$tcpip_address,
      request_count: 0 .. 0ff(16),
      response_count: 0 .. 0ff(16),
      save_count: 0 .. 0ff(16),
      first_device_index: nlt$device_identifier,
      ready_on_first_route_known: boolean,
      refresh: boolean,
      task_queue_count: 0 .. 0ffff(16),
      task_queue: ^nlt$tm_address_accessible_task,
      unavailable_routes: nlt$device_ids,
      network_search_refresh: boolean,
      response_queue: nlt$tm_addr_access_res_queue,
    recend;

*copyc nlt$device_identifier
*copyc nlt$device_ids
*copyc nlt$tcpip_address
*copyc nlt$tm_addr_access_res_queue
*copyc nlt$tm_address_accessible_task
*copyc nlt$tm_request_identifier
*copyc ost$global_task_id
*DECK DECK=NLT$TM_ADDR_ACCESS_REQ_QUEUE EXPAND=FALSE

  TYPE
    nlt$tm_addr_access_req_queue = record
      lock: ost$signature_lock,
      first_request: ^nlt$tm_addr_access_req_entry,
    recend;

*copyc nlt$tm_addr_access_req_entry
*copyc ost$signature_lock
*DECK DECK=NLT$TM_ADDR_ACCESS_RES_ENTRY EXPAND=FALSE

  TYPE
    nlt$tm_addr_access_res_entry = record
      route_cost: 0 .. 0100000000(16),
      route_status: nlt$tm_route_status,
    recend;

*copyc nlt$tm_route_status

*DECK DECK=NLT$TM_ADDR_ACCESS_RES_QUEUE EXPAND=FALSE

  TYPE
    nlt$tm_addr_access_res_queue = array [ 1 .. * ] of nlt$tm_addr_access_res_entry;

*copyc nlt$tm_addr_access_res_entry
*DECK DECK=NLT$TM_CACHE_DEVICE EXPAND=FALSE

  TYPE
    nlt$tm_cache_device = record
      device_id: nlt$device_identifier, { device_id of zero signifies an empty entry.
      usage_count: nlt$tm_usage_count,
    recend;

*copyc nlt$device_identifier
*copyc nlt$tm_usage_count

*DECK DECK=NLT$TM_CACHE_ENTRY EXPAND=FALSE

  TYPE
    nlt$tm_cache_entry = record
      destination_address: nlt$tcpip_address,
      refresh_timestamp: nlt$tm_cache_interval,
      last_used_timestamp: nlt$tm_cache_interval,
      device_count: nlt$device_count,
      unavailable_routes: nlt$device_ids,
      device_list: ^array [ 1 .. * ] of nlt$tm_cache_device,
    recend;

*copyc nlt$device_count
*copyc nlt$device_ids
*copyc nlt$tcpip_address
*copyc nlt$tm_cache_device
*copyc nlt$tm_cache_interval

*DECK DECK=NLT$TM_CACHE_INTERVAL EXPAND=FALSE

  TYPE
    nlt$tm_cache_interval = 0 .. 0ffffffffffff(16);
*DECK DECK=NLT$TM_CONNECTION EXPAND=FALSE

  TYPE
    nlt$tm_connection = record
      device_id: nlt$device_identifier,
      state: nlt$tm_connection_states,
      version: nlt$tm_version,
    recend;

*copyc nlt$device_identifier
*copyc nlt$tm_connection_states
*copyc nlt$tm_version
*DECK DECK=NLT$TM_CONNECTION_STATES EXPAND=FALSE

{
{ nlc$tm_configuration_ind_wait - a CC connect confirm request with the protocol
{                                 negotiation response has been sent to the
{                                 the TCP/IP communication device (TMAP).
{
{ nlc$tm_enable_host_routing    - the version level and the device configuration
{                                 have been exchanged and validated.  The path
{                                 is open for data transmission - management
{                                 information can be transmitted and received.
{
{ nlc$tm_closed                 - the initial state of the TMAA connection.
{

  TYPE
    nlt$tm_connection_states = (nlc$tm_configuration_ind_wait,
       nlc$tm_enable_host_routing, nlc$tm_closed);

*DECK DECK=NLT$TM_DEVICE_ADDRESS EXPAND=FALSE

  TYPE
    nlt$tm_device_address = record
      address: nat$sk_ip_address,
      device_id: nlt$device_identifier,
    recend;

*copyc nat$sk_ip_address
*copyc nlt$device_identifier
*DECK DECK=NLT$TM_DEVICE_ADDRESS_LIST EXPAND=FALSE

  TYPE
    nlt$tm_device_address_list = array [ 1 .. * ] of nlt$tm_device_address;

*copyc nlt$tm_device_address
*DECK DECK=NLT$TM_DEVICE_CONFIGURATION EXPAND=FALSE

  TYPE
    nlt$tm_device_configuration = record
      lock: ost$signature_lock,
      count: nlt$device_count,
      tcp: nlt$tm_device_information,
      udp: nlt$tm_device_information,
      list: array [ 1 .. * ] of nlt$tm_device_specific_info,
    recend;

*copyc nlt$device_count
*copyc nlt$tm_device_information
*copyc nlt$tm_device_specific_info
*copyc ost$signature_lock
*DECK DECK=NLT$TM_DEVICE_IDENTIFIER EXPAND=FALSE

  TYPE
    nlt$tm_device_identifier = record
      identifier: nlt$device_identifier,
    recend;

*copyc nlt$device_identifier
*DECK DECK=NLT$TM_DEVICE_INFORMATION EXPAND=FALSE

  TYPE
    nlt$tm_device_information = record
      count: nlt$device_count,
      identifier: nlt$device_identifier,
    recend;

*copyc nlt$device_count
*copyc nlt$device_identifier
*DECK DECK=NLT$TM_DEVICE_LIST EXPAND=FALSE

  TYPE
    nlt$tm_device_list = record
      list: ^array [1 .. *] of nlt$tm_device_identifier,
      count: nlt$device_count,
    recend;

*copyc nlt$device_count
*copyc nlt$tm_device_identifier
*DECK DECK=NLT$TM_DEVICE_SPECIFIC_INFO EXPAND=FALSE

  TYPE
    nlt$tm_device_specific_info = record
      local_device_address: nlt$tcpip_address,
      connection_id: nat$connection_id,
      protocol: nlt$tm_protocol,
    recend;

*copyc nat$connection_id
*copyc nlt$tcpip_address
*copyc nlt$tm_protocol
*DECK DECK=NLT$TM_HASH_RANGE EXPAND=FALSE

  TYPE
    nlt$tm_hash_range = 0 .. nlc$tm_hash_elements - 1;

*copyc nlc$tm_hash_elements
*DECK DECK=NLT$TM_HOST_NAME EXPAND=FALSE

  TYPE
    nlt$tm_host_name = string (nlc$tm_max_host_name_length);

*copyc nlt$tm_host_name_length
*DECK DECK=NLT$TM_HOST_NAME_LENGTH EXPAND=TRUE

  CONST
    nlc$tm_max_host_name_length = 0ff(16);

  TYPE
    nlt$tm_host_name_length = 0 .. nlc$tm_max_host_name_length;
*DECK DECK=NLT$TM_LOCAL_HOST_NAME EXPAND=FALSE

  TYPE
    nlt$tm_local_host_name = record
      name_length: nlt$tm_host_name_length,
      name: nlt$tm_host_name,
    recend;

*copyc nlt$tm_host_name
*copyc nlt$tm_host_name_length
*DECK DECK=NLT$TM_MASK EXPAND=FALSE

  TYPE
    nlt$tm_mask = record
      case boolean of
      = TRUE =
        value: 0 .. 0ffffffff(16),
      = FALSE =
        set_value: set of 0 .. 31,
      casend,
    recend;

*DECK DECK=NLT$TM_PDU EXPAND=FALSE

{ NOTE:
{   The pdu types are in logical order i.e. an nlt$tm_negotiate_protocol_req
{   is received then a nlt$tm_negotiate_protocol_res is sent.

  CONST
    nlc$tm_outgoing_pdu_base = 1800(16), { Host to the device.
    nlc$tm_incoming_pdu_base = 1880(16), { Device to the host.

{ Outgoing PDU kinds.

    nlc$tm_negotiate_protocol_res = nlc$tm_outgoing_pdu_base + 0,
    nlc$tm_device_config_confirm = nlc$tm_outgoing_pdu_base + 1,
    nlc$tm_enable_host_routing_req = nlc$tm_outgoing_pdu_base + 2,
    nlc$tm_address_accessible_req = nlc$tm_outgoing_pdu_base + 3,
    nlc$tm_release_request = nlc$tm_outgoing_pdu_base + 4,

{ Incoming PDU kinds.

    nlc$tm_negotiate_protocol_req = nlc$tm_incoming_pdu_base + 0,
    nlc$tm_device_config_request = nlc$tm_incoming_pdu_base + 1,
    nlc$tm_address_accessible_res = nlc$tm_incoming_pdu_base + 2,
    nlc$tm_subnet_available_ind = nlc$tm_incoming_pdu_base + 3,
    nlc$tm_subnet_unavailable_ind = nlc$tm_incoming_pdu_base + 4,
    nlc$tm_route_unavailable_ind = nlc$tm_incoming_pdu_base + 5,
    nlc$tm_release_indication = nlc$tm_incoming_pdu_base + 6;

  TYPE

    nlt$tm_pdu_kind = 0 .. 0ffff(16),

    nlt$tm_pdu_header = record
      length: 0 .. 0ffff(16),
      kind: nlt$tm_pdu_kind,
    recend,

    nlt$tm_negotiate_protocol_req = record
      header: nlt$tm_pdu_header,
      version: nlt$tm_version,
    recend,

    nlt$tm_negotiate_protocol_res = record
      header: nlt$tm_pdu_header,
      version: nlt$tm_version,
    recend,

    nlt$tm_device_config_request = record
      host_internet_address: nlt$tcpip_address,
      udp_access_enabled: boolean,
      tcp_access_enabled: boolean,
    recend,

    nlt$tm_device_config_confirm = record
      header: nlt$tm_pdu_header,
    recend,

    nlt$tm_enable_host_routing_req = record
      header: nlt$tm_pdu_header,
    recend,

    nlt$tm_address_accessible_req = record
      header: nlt$tm_pdu_header,
      request_id: nlt$tm_request_identifier,
      internet_address: nlt$tcpip_address,
    recend,

    nlt$tm_address_accessible_res = record
      request_id: nlt$tm_request_identifier,
      route_cost: 0 .. 0ffffffff(16),
      route_status: nlt$tm_route_status,
    recend,

    nlt$tm_subnet_available_ind = record
      internet_address: nlt$tcpip_address,
      subnet_mask: nlt$tm_mask,
      route_cost: 0 .. 0ffffffff(16),
      subnet_id: nlt$tm_subnet_identifier,
    recend,

    nlt$tm_subnet_unavailable_ind = record
      subnet_id: nlt$tm_subnet_identifier,
    recend,

    nlt$tm_route_unavailable_ind = record
      internet_address: nlt$tcpip_address,
      reason_code: nlt$tm_route_unavail_reason,
    recend,

    nlt$tm_release_request = record
      header: nlt$tm_pdu_header,
      reason: nlt$tm_release_reason,
    recend,

    nlt$tm_release_indication = record
      header: nlt$tm_pdu_header,
      reason: nlt$tm_release_reason,
    recend;

*copyc nlt$tcpip_address
*copyc nlt$tm_mask
*copyc nlt$tm_release_reason
*copyc nlt$tm_request_identifier
*copyc nlt$tm_route_status
*copyc nlt$tm_route_unavail_reason
*copyc nlt$tm_subnet_identifier
*copyc nlt$tm_version
*DECK DECK=NLT$TM_PROTOCOL EXPAND=FALSE

  TYPE
    nlt$tm_protocol = (nlc$tm_null, nlc$tm_tcp, nlc$tm_udp, nlc$tm_tcp_udp);
*DECK DECK=NLT$TM_RELEASE_REASON EXPAND=FALSE

  CONST
    nlc$tm_agent_protocol_error = 1,
    nlc$tm_provider_protocol_error = 2,
    nlc$tm_version_not_supported = 3,
    nlc$tm_address_not_valid = 4,
    nlc$tm_service_terminated = 5,
    nlc$tm_header_indicernible = 6,
    nlc$tm_header_length_incorrect = 7,
    nlc$tm_invalid_encoding = 8,
    nlc$tm_host_not_configured = 9;

  TYPE
    nlt$tm_release_reason = 0 .. 0ff(16);
*DECK DECK=NLT$TM_REQUEST_IDENTIFIER EXPAND=FALSE

  TYPE
    nlt$tm_request_identifier = 0 .. 0ffffffff(16);
*DECK DECK=NLT$TM_ROUTE_CACHE EXPAND=FALSE

  TYPE
    nlt$tm_route_cache = record
      element_list: array [ nlt$tm_hash_range ] of nlt$tm_route_cache_element,
      forward_search_range: nlt$tm_search_range,     { Number of cache entries allowed on a cache element.
      refresh_interval: nlt$tm_cache_interval,       { Milliseconds an entry may remain cached.
      stale_release_interval: nlt$tm_cache_interval, { Milliseconds an entry may remain cached if not used.
    recend;

*copyc nlt$tm_cache_interval
*copyc nlt$tm_hash_range
*copyc nlt$tm_route_cache_element
*copyc nlt$tm_search_range
*DECK DECK=NLT$TM_ROUTE_CACHE_ELEMENT EXPAND=FALSE

  TYPE
    nlt$tm_route_cache_element = record
      lock: ost$signature_lock,
      entry_list: ^nlt$tm_route_cache_entry_list,
    recend;

*copyc nlt$tm_route_cache_entry_list
*copyc ost$signature_lock

*DECK DECK=NLT$TM_ROUTE_CACHE_ENTRY_LIST EXPAND=FALSE

  TYPE
    nlt$tm_route_cache_entry_list = array [ 1 .. * ] of nlt$tm_cache_entry;

*copyc nlt$tm_cache_entry
*DECK DECK=NLT$TM_ROUTE_COST EXPAND=FALSE

  TYPE
    nlt$tm_route_cost = 0 .. nlc$tm_maximum_route_cost;

  CONST
    nlc$tm_maximum_route_cost = 0ffffffff(16);
*DECK DECK=NLT$TM_ROUTE_STATUS EXPAND=FALSE

  CONST
    nlc$tm_route_unknown = 0,
    nlc$tm_route_known = 1,
    nlc$tm_route_indeterminate = 2, { Default route available.
    nlc$tm_await_route_status = 3;  { A route query has been sent to the local device.

  TYPE
    nlt$tm_route_status = 0 .. 0ff(16);

*DECK DECK=NLT$TM_ROUTE_UNAVAIL_REASON EXPAND=FALSE

  CONST
    nlc$tm_network_unreachable = 1,
    nlc$tm_host_unreachable = 2,
    nlc$tm_route_failed = 3;

  TYPE
    nlt$tm_route_unavail_reason = 0 .. 0ff(16);
*DECK DECK=NLT$TM_SEARCH_RANGE EXPAND=FALSE

  TYPE
    nlt$tm_search_range = 1 .. 0ff(16);
*DECK DECK=NLT$TM_STATIC_ROUTE EXPAND=FALSE

  TYPE
    nlt$tm_static_route = record
      local_device_name: cmt$element_name,
      local_device_id: nlt$device_identifier,
      protocol: nlt$tm_protocol,
      destination_address: nlt$tcpip_address,
      mask: nlt$tm_mask,
      strict_route: boolean,
    recend;

*copyc cmt$element_name
*copyc nlt$device_identifier
*copyc nlt$tcpip_address
*copyc nlt$tm_mask
*copyc nlt$tm_protocol
*DECK DECK=NLT$TM_STATIC_ROUTES EXPAND=FALSE

  TYPE
    nlt$tm_static_routes = ARRAY [ 1 .. * ] of nlt$tm_static_route;

*copyc nlt$tm_static_route
*DECK DECK=NLT$TM_STATIC_ROUTE_DEFINITION EXPAND=FALSE

  TYPE
    nlt$tm_static_route_definition = record
      nextt: ^nlt$tm_static_route_definition,
      local_device_id: nlt$device_identifier,
      local_device_name: cmt$element_name,
      destination_address: nat$sk_ip_address,
      destination_address_mask: nat$sk_ip_address,
      strict_route: boolean,
    recend;

*copyc cmt$element_name
*copyc nat$sk_ip_address
*copyc nlt$device_identifier

*DECK DECK=NLT$TM_STATIC_ROUTE_DEFINITIONS EXPAND=FALSE

  TYPE
    nlt$tm_static_route_definitions = ARRAY [ 1 .. * ] of nlt$tm_static_route_definition;

*copyc nlt$tm_static_route_definition
*DECK DECK=NLT$TM_STATIC_ROUTING_TABLE EXPAND=FALSE

  TYPE
    nlt$tm_static_routing_table = record
      lock: nlt$access_control,
      routes: ^nlt$tm_static_routes,
    recend;

*copyc nlt$access_control
*copyc nlt$tm_static_routes
*DECK DECK=NLT$TM_SUBNET_ENTRY EXPAND=FALSE

  TYPE
    nlt$tm_subnet_entry = record
      nextt: ^nlt$tm_subnet_entry,
      destination_address: nlt$tcpip_address,
      local_device: nlt$device_identifier,
      protocol: nlt$tm_protocol,
      mask: nlt$tm_mask,
      subnet_id: nlt$tm_subnet_identifier,  { 0 and 0ff(16) are invalid subnet identifiers.
      network_mask: nlt$tm_mask,
      route_cost: nlt$tm_route_cost,
    recend;

*copyc nlt$device_identifier
*copyc nlt$tcpip_address
*copyc nlt$tm_mask
*copyc nlt$tm_protocol
*copyc nlt$tm_route_cost
*copyc nlt$tm_subnet_identifier
*DECK DECK=NLT$TM_SUBNET_IDENTIFIER EXPAND=FALSE

  TYPE
    nlt$tm_subnet_identifier = 0 .. 0ff(16);
*DECK DECK=NLT$TM_SUBNET_LIST EXPAND=FALSE

  TYPE
    nlt$tm_subnet_list = record
      lock: nlt$access_control, { Non exclusive to read and exclusive to change an entry.
      root: ^nlt$tm_subnet_entry,
    recend;

*copyc nlt$access_control
*copyc nlt$tm_subnet_entry
*DECK DECK=NLT$TM_UDP_DEVICE EXPAND=FALSE

  TYPE
    nlt$tm_udp_device = record
      identifier: nlt$device_identifier,
      local_address: nlt$tcpip_address,
    recend;

*copyc nlt$device_identifier
*copyc nlt$tcpip_address
*DECK DECK=NLT$TM_UDP_DEVICE_LIST EXPAND=FALSE

  TYPE
    nlt$tm_udp_device_list = array [1 .. * ] of nlt$tm_udp_device;

*copyc nlt$tm_udp_device
*DECK DECK=NLT$TM_USAGE_COUNT EXPAND=FALSE

  TYPE
    nlt$tm_usage_count = 0 .. nlc$tm_maximum_usage_count;

  CONST
    nlc$tm_maximum_usage_count = 0ffff(16);
*DECK DECK=NLT$TM_VERSION EXPAND=FALSE

  TYPE
    nlt$tm_version = 0 .. 0ff(16);
*DECK DECK=NLT$UDPAA_OPEN_REJECT_REASON EXPAND=FALSE

{ In the following definition '_orr_' stands for '_open_reject_reason_'.
{ The following are the reason codes sent by the UDP Access Provider
{ via the Open Socket Reject Indication.

  CONST
    nlc$udpaa_orr_resources_unavail = 1,
    nlc$udpaa_orr_port_already_bind = 2;

  TYPE
    nlt$udpaa_open_reject_reason = 0 .. 0ff(16);
*DECK DECK=NLT$UDPAA_PDU_HEADER EXPAND=FALSE

  TYPE
    nlt$udpaa_pdu_header = record
      length: nlt$udpaa_pdu_length,
      kind: nlt$udpaa_pdu_kind,
    recend;

*copyc nlt$udpaa_pdu_kind
*copyc nlt$udpaa_pdu_length
*DECK DECK=NLT$UDPAA_PDU_KIND EXPAND=FALSE

  CONST
    nlc$udpaa_outgoing_pdu_base = 1300(16),  {host to device}
    nlc$udpaa_incoming_pdu_base = 1380(16),  {device to host}

{ Incoming PDU kinds.

    nlc$udpaa_open_confirm_ind = nlc$udpaa_incoming_pdu_base + 0,
    nlc$udpaa_open_reject_ind = nlc$udpaa_incoming_pdu_base + 1,
    nlc$udpaa_release_ind = nlc$udpaa_incoming_pdu_base + 2,
    nlc$udpaa_data_ind = nlc$udpaa_incoming_pdu_base + 3,
    nlc$udpaa_clear_send_ind = nlc$udpaa_incoming_pdu_base + 4,

{ Outgoing PDU kinds.

    nlc$udpaa_open_req = nlc$udpaa_outgoing_pdu_base + 0,
    nlc$udpaa_release_req = nlc$udpaa_outgoing_pdu_base + 1,
    nlc$udpaa_data_req = nlc$udpaa_outgoing_pdu_base + 2,
    nlc$udpaa_set_options_req = nlc$udpaa_outgoing_pdu_base + 3,
    nlc$udpaa_clear_send_req = nlc$udpaa_outgoing_pdu_base + 4;

  TYPE
    nlt$udpaa_pdu_kind = 0 .. 0ffff(16);

*DECK DECK=NLT$UDPAA_PDU_LENGTH EXPAND=FALSE

  TYPE
    nlt$udpaa_pdu_length = 0 .. 0ffff(16);

*DECK DECK=NLT$UDPAA_PROTOCOL_DATA_UNIT EXPAND=FALSE

{ This common decks describes the format of the Protocol Data
{ Units sent and received by the UDP Access Agent.

{ Outgoing PDU formats.

  TYPE
    nlt$udpaa_open_request = record
      header: nlt$udpaa_pdu_header,
      port: nat$sk_port_number,
      traffic_pattern: nat$sk_traffic_pattern,
    recend,

    nlt$udpaa_release_request = record
      header: nlt$udpaa_pdu_header,
      reason: nlt$udpaa_release_req_reason,
    recend,

    nlt$udpaa_data_request = record
      header: nlt$udpaa_pdu_header,
      end_of_message: boolean,
      checksum: boolean,
      destination_port: nat$sk_port_number,
      destination_ip_address: nat$sk_ip_address,
      source_ip_address: nat$sk_ip_address,
{ Variable sized user data follows.
    recend,

    nlt$udpaa_set_options_request = record
      header: nlt$udpaa_pdu_header,
      traffic_pattern: nat$sk_traffic_pattern,
      broadcast_enabled: boolean,
    recend,

    nlt$udpaa_clear_send_request = record
      header: nlt$udpaa_pdu_header,
    recend,
{ Incoming PDU formats.

    nlt$udpaa_open_confirm_ind = record
      header: nlt$udpaa_pdu_header,
      port: nat$sk_port_number,
    recend,

    nlt$udpaa_open_reject_ind = record
      header: nlt$udpaa_pdu_header,
      reason: nlt$udpaa_open_reject_reason,
    recend,

    nlt$udpaa_release_ind = record
      header: nlt$udpaa_pdu_header,
      reason: nlt$udpaa_release_ind_reason,
    recend,

    nlt$udpaa_data_ind = record
      header: nlt$udpaa_pdu_header,
      end_of_message: boolean,
      fill: 0 .. 0ff(16),           { In place of checksum }
      source_port: nat$sk_port_number,
      source_ip_address: nat$sk_ip_address,
      destination_ip_address: nat$sk_ip_address,
{ Variable sized user data follows.
    recend,

    nlt$udpaa_clear_send_ind = record
      header: nlt$udpaa_pdu_header,
    recend;

*copyc nat$sk_ip_address
*copyc nat$sk_port_number
*copyc nat$sk_traffic_pattern
*copyc nlt$udpaa_pdu_header
*copyc nlt$udpaa_open_reject_reason
*copyc nlt$udpaa_release_ind_reason
*copyc nlt$udpaa_release_req_reason
*DECK DECK=NLT$UDPAA_RELEASE_IND_REASON EXPAND=FALSE

{ In the following definition '_ri_' stands for '_release_indication_'.
{ The following are the reason codes sent by the UDP Access Provider
{ via the Release Socket Indication.

  CONST
    nlc$udpaa_ri_user_data_too_big = 1,
    nlc$udpaa_ri_protocol_error = 3,
    nlc$udpaa_ri_cc_service_term = 4;

  TYPE
    nlt$udpaa_release_ind_reason = 0 .. 0ff(16);
*DECK DECK=NLT$UDPAA_RELEASE_REQ_REASON EXPAND=FALSE

{ In the following definition '_rr_' stands for '_release_request_'.
{ The following are the reason codes sent by the UDP Access Agent to
{ the UDP Access Provider via the Release Socket Request.

  CONST
    nlc$udpaa_rr_user_request = 1,
    nlc$udpaa_rr_protocol_error = 2;

  TYPE
    nlt$udpaa_release_req_reason = 0 .. 0ff(16);
*DECK DECK=NLT$UDP_ACTIVE_RECEIVER EXPAND=FALSE

  TYPE
    nlt$udp_active_receiver = record
      task_id: ALIGNED [0 MOD 8] ost$global_task_id,
*IF $true(osv$unix)
      fill_1: 0 .. 0ffff(16),
      fill_2: 0 .. 0ffffff(16),
*ELSE
      fill: 0 .. 0ffffffffff(16),
*IFEND
    recend;

*copyc ost$global_task_id
*DECK DECK=NLT$UDP_CONNECTION_STATE EXPAND=FALSE

  TYPE
    nlt$udp_connection_state = (nlc$udp_conn_closed, nlc$udp_conn_open,
      nlc$udp_conn_await_confirm);
*DECK DECK=NLT$UDP_DEVICE_INVENTORY EXPAND=FALSE

  TYPE
    nlt$udp_device_inventory = record
      connection_id: nat$connection_id,
      buffers_freed: nat$data_fragment_count,
    recend;

*copyc nat$connection_id
*copyc nat$data_fragments
*DECK DECK=NLT$UDP_GLOBAL_SOCKET EXPAND=FALSE

  TYPE
    nlt$udp_global_socket = record
      next_entry: ^nlt$udp_global_socket,
      lock: ost$signature_lock,
      identifier: nlt$udp_global_socket_id,
      time_stamp: ost$free_running_clock,
      status: nlt$udp_global_socket_status,
      local_socket_id: nat$sk_socket_identifier,
      port: nat$sk_port_number,
      traffic_pattern: nat$sk_traffic_pattern,
      broadcast_enabled: boolean,
      bound_address: nat$sk_ip_address,
      active_receiver: ^nlt$udp_active_receiver,
      receive_wait_queue: ^nlt$udp_receiver_task,
      available_receiver_pool: ^nlt$udp_receiver_task,
      available_message_pool_size: 0 .. 0ffff(16),
      available_message_pool: ^nlt$udp_received_message,
      active_device_count: nlt$device_count,
      waiting_task_id: ost$global_task_id,
      last_receiving_device: nlt$device_identifier,
      device_list: nlt$udp_socket_device_list,
    recend;

*copyc nat$sk_ip_address
*copyc nat$sk_port_number
*copyc nat$sk_socket_address
*copyc nat$sk_socket_identifier
*copyc nat$sk_traffic_pattern
*copyc nlt$device_count
*copyc nlt$device_identifier
*copyc nlt$udp_active_receiver
*copyc nlt$udp_global_socket
*copyc nlt$udp_global_socket_id
*copyc nlt$udp_global_socket_status
*copyc nlt$udp_received_message
*copyc nlt$udp_receiver_task
*copyc nlt$udp_socket_device_list
*copyc ost$free_running_clock
*copyc ost$global_task_id
*copyc ost$signature_lock
*DECK DECK=NLT$UDP_GLOBAL_SOCKETS EXPAND=FALSE

  TYPE
    nlt$udp_global_sockets = record
      socket_seed: ALIGNED [0 MOD 8] integer,
      active: ALIGNED [0 MOD 8] integer,
      list: ^array [0 .. * ] of nlt$udp_global_socket_root,
    recend,

    nlt$udp_global_sckts_per_system = 2 .. 65536,

    nlt$udp_global_socket_root = record
      access_control: ALIGNED [0 MOD 8] nlt$udp_global_sckt_root_access,
      first: ^nlt$udp_global_socket,
    recend,

    nlt$udp_global_sckt_root_access = record
      nonexclusive_accessors: 0 .. 0ffffffff(16),
      exclusive: boolean,
      fill: 0 .. 0ffffff(16),
    recend;

  TYPE
    nlt$udp_global_sockets_control = record
      lock: ALIGNED [0 MOD 8] string (8),
    recend;

  CONST
    nlc$udp_global_sockets_locked = 'LOCKED  ',
    nlc$udp_global_sockets_unlocked = 'UNLOCKED';

*copyc nlt$udp_global_socket
*DECK DECK=NLT$UDP_GLOBAL_SOCKET_ID EXPAND=FALSE

  TYPE

    nlt$udp_global_socket_id = packed record
      sequence: 0 .. 0ffffffffffff(16),
      reference_number: nlt$udp_reference_number,
    recend;

*copyc nlt$udp_reference_number

*DECK DECK=NLT$UDP_GLOBAL_SOCKET_STATUS EXPAND=FALSE

  TYPE
    nlt$udp_global_socket_status = (nlc$udp_global_socket_closed, nlc$udp_global_socket_open,
      nlc$udp_global_socket_unbound, nlc$udp_global_socket_offered, nlc$udp_global_socket_term);

*DECK DECK=NLT$UDP_LOCAL_CACHE EXPAND=FALSE

  TYPE
    nlt$udp_local_cache = record
      source_ip_address: nat$sk_ip_address,
      destination_ip_address: nat$sk_ip_address,
      device_id: nlt$device_identifier,
    recend;

*copyc nat$sk_ip_address
*copyc nlt$device_identifier

*DECK DECK=NLT$UDP_LOCAL_ROUTING_CACHE EXPAND=FALSE

  TYPE
    nlt$udp_local_routing_cache = record
      last_send: nlt$udp_local_cache,
      last_receive: nlt$udp_local_cache,
    recend;

*copyc nlt$udp_local_cache

*DECK DECK=NLT$UDP_OPEN_PORT EXPAND=FALSE

  TYPE
    nlt$udp_open_port = record
      next_entry: ^nlt$udp_open_port,
      port: nat$sk_port_number,
      ip_address: nat$sk_ip_address,
    recend;

*copyc nat$sk_ip_address
*copyc nat$sk_port_number
*DECK DECK=NLT$UDP_PORTS EXPAND=FALSE


{ The UDP ports have been divided into the following ranges:
{       Reserved range - 1 to 1023
{       Variable range - 1024 to 65535

  TYPE
    nlt$udp_ports = record
      lock: ost$signature_lock,
      next_assignable_port: nlc$sk_min_assigned_port .. nlc$sk_max_assigned_port,
      open_ports: ^nlt$udp_open_port,
    recend;

*copyc nlc$sk_max_assigned_port
*copyc nlc$sk_min_assigned_port
*copyc nlt$udp_open_port
*copyc ost$signature_lock
*DECK DECK=NLT$UDP_RECEIVED_MESSAGE EXPAND=FALSE

  TYPE
    nlt$udp_received_message = record
      next_entry: ^nlt$udp_received_message,
      abort_receive: boolean,
      source_socket: nat$sk_socket_address,
      destination_ip_address: nat$sk_ip_address,
      data: nlt$bm_message_id,
      data_length: integer,
      buffer_count: integer,
      end_of_message: boolean,
    recend;

*copyc nat$sk_ip_address
*copyc nat$sk_socket_address
*copyc nlt$bm_message_id
*DECK DECK=NLT$UDP_RECEIVER_TASK EXPAND=FALSE

  TYPE
    nlt$udp_receiver_task = record
      next_entry: ^nlt$udp_receiver_task,
      task_id: ost$global_task_id,
      end_of_message: boolean,
      CASE receive_type: nlt$udp_receive_type OF
      = nlc$udp_receive_data =
        activity_status: ^ost$activity_status,
        interface_mode: nat$sk_interface_mode,
        original_receive_buffer: ^nat$data_fragments,
        original_buffer_length: integer,
        selection_criteria: nat$sk_socket_address,
        receive_buffer: ^nat$data_fragments,
        buffer_length: integer,
        received_data_length: ^integer,
        device_id: ^nlt$device_identifier,
        connection_id: nat$connection_id,
        foreign_socket: ^nat$sk_socket_address,
        local_ip_address: ^nat$sk_ip_address,
      = nlc$udp_await_data_available =
        activity_complete: ^boolean,
        receiver_active: boolean,
      CASEND,
    recend;

*copyc nat$connection_id
*copyc nat$data_fragments
*copyc nat$sk_interface_mode
*copyc nat$sk_ip_address
*copyc nat$sk_socket_address
*copyc nlt$device_identifier
*copyc nlt$udp_receive_type
*copyc ost$activity_status
*copyc ost$global_task_id
*DECK DECK=NLT$UDP_RECEIVE_DATA_SIGNAL EXPAND=FALSE

  TYPE
    nlt$udp_receive_data_signal = record
      global_socket_id: nlt$udp_global_socket_id,
      device_id: nlt$device_identifier,
    recend;

*copyc nlt$device_identifier
*copyc nlt$udp_global_socket_id
*DECK DECK=NLT$UDP_RECEIVE_TYPE EXPAND=FALSE

  TYPE
    nlt$udp_receive_type = (nlc$udp_receive_data, nlc$udp_await_data_available);
*DECK DECK=NLT$UDP_REFERENCE_NUMBER EXPAND=FALSE

  TYPE
    nlt$udp_reference_number = 0 .. 65535;

*DECK DECK=NLT$UDP_SENDER_TASK EXPAND=FALSE

  TYPE
    nlt$udp_sender_task = record
      next_entry: ^nlt$udp_sender_task,
      task_id: ost$global_task_id,
      send_type: nlt$udp_send_type,
    recend;

*copyc nlt$udp_send_type
*copyc ost$global_task_id
*DECK DECK=NLT$UDP_SEND_TYPE EXPAND=FALSE

  TYPE
    nlt$udp_send_type = (nlc$udp_send_data, nlc$udp_await_clear_to_send);

*DECK DECK=NLT$UDP_SOCKET_DEVICE EXPAND=FALSE

  TYPE
    nlt$udp_socket_device = record
      device_id: nlt$device_identifier,
      ip_address: nat$sk_ip_address,
      status: nlt$udp_socket_device_status,
      connection_id: nat$connection_id,
      discard_data: boolean,
      receiver_task: ^nlt$udp_receiver_task,
      received_messages: ^nlt$udp_received_message,
    recend;

*copyc nat$connection_id
*copyc nat$sk_ip_address
*copyc nlt$device_identifier
*copyc nlt$udp_received_message
*copyc nlt$udp_receiver_task
*copyc nlt$udp_socket_device_status
*DECK DECK=NLT$UDP_SOCKET_DEVICE_LIST EXPAND=FALSE

  TYPE
    nlt$udp_socket_device_list = array [1..*] of nlt$udp_socket_device;

*copyc nlt$udp_socket_device
*DECK DECK=NLT$UDP_SOCKET_DEVICE_STATUS EXPAND=FALSE

  TYPE
    nlt$udp_socket_device_status = (nlc$udp_device_closed, nlc$udp_device_open,
      nlc$udp_device_await_confirm, nlc$udp_device_closing, nlc$udp_device_res_constraint);
*DECK DECK=NLT$UDP_SOCKET_INVENTORY EXPAND=FALSE

  TYPE
    nlt$udp_socket_inventory = array [1 .. *] of nlt$udp_device_inventory;

*copyc nlt$udp_device_inventory
*DECK DECK=NLT$UDP_SOCKET_LAYER EXPAND=TRUE

  TYPE
    nlt$udp_socket_layer = record
      state: nlt$udp_connection_state,
      device_id: nlt$device_identifier,
      local_ip_address: nat$sk_ip_address,
      global_socket_id: nlt$udp_global_socket_id,
      inventory_report: integer,
      send_queue: ^nlt$udp_sender_task,
      available_sender_pool: ^nlt$udp_sender_task,
    recend;

*copyc nat$sk_ip_address
*copyc nlt$device_identifier
*copyc nlt$udp_global_socket_id
*copyc nlt$udp_connection_state
*copyc nlt$udp_sender_task
*DECK DECK=NLT$USER_INTERFACE EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  TYPE
    nlt$user_sap_id = SEQ (REP 8 of cell);
*DECK DECK=NLT$XE_ERROR_PROTOCOL_INTERFACE EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  TYPE
    nlt$xe_error_number = 0 .. 65535,
    nlt$xe_error_parameter = 0 .. 65535;



  { NAM/VE: XNS Error Protocol -- Error Number Constants }

  CONST
    nlc$xe_unspec_at_destination = 0,
    nlc$xe_checksum_at_destination = 1,
    nlc$xe_unknown_sap = 2,
    nlc$xe_destination_resources = 3,
    nlc$xe_unspec_before_destinat = 512,
    nlc$xe_cannot_reach_destination = 514,
    nlc$xe_packet_lifetime_expired = 515,
    nlc$xe_packet_too_large = 516;
*DECK DECK=NLV$BM_ALLOCATED_BUFFER_MAXIMUM EXPAND=FALSE

  VAR
    nlv$bm_allocated_buffer_maximum: [XREF, oss$network_paged] nlt$bm_buffer_count;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_buffer_count
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$BM_ALLOCATED_BUFFER_POOL EXPAND=FALSE

  VAR
    nlv$bm_allocated_buffer_pool: [XREF, oss$network_paged] nlt$bm_allocated_buffer_pool;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_allocated_buffer_pool
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$BM_ALLOCAT_BUFFER_THRESHOLD EXPAND=FALSE

  VAR
    nlv$bm_allocat_buffer_threshold: [XREF, oss$network_paged] nlt$bm_buffer_count;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_buffer_count
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$BM_BUFFERS_FREED EXPAND=FALSE
  VAR
    nlv$bm_buffers_freed: [XREF] boolean;
*DECK DECK=NLV$BM_BUFFER_MANAGER_CALLER EXPAND=FALSE

  VAR
    nlv$bm_buffer_manager_caller: [XREF, oss$network_paged] string (21);

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
?? POP ??

*DECK DECK=NLV$BM_BUFFER_MANAGER_CONTROL EXPAND=FALSE

{ Nlv$bm_buffer_manager_control is used to synchronize buffer manager requests which
{ acquire or return buffers.

  VAR
    nlv$bm_buffer_manager_control: [XREF, oss$network_paged] nlt$bm_buffer_manager_control;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_buffer_manager_control
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$BM_BUFFER_POOL EXPAND=FALSE

  VAR
    nlv$bm_buffer_pool: [XREF, oss$network_paged] nlt$bm_buffer_pool;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_buffer_pool
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$BM_LARGE_BUFFERS EXPAND=FALSE
*DECK DECK=NLV$BM_LARGE_BUFFER_SIZE EXPAND=FALSE

{ Nlv$bm_large_buffer_size is equal the current mainfame's page size.

  VAR
    nlv$bm_large_buffer_size: [XREF, oss$network_paged] nlt$bm_buffer_length;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_buffer_length
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$BM_NIL_MESSAGE_ID EXPAND=FALSE

  VAR
    nlv$bm_nil_message_id: [XREF, oss$network_paged] nlt$bm_message_id;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_id
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$BM_NULL_MESSAGE_ID EXPAND=FALSE

  VAR
    nlv$bm_null_message_id: [XREF, oss$network_paged] nlt$bm_message_id;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_message_id
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$CC_GRANT_CREDIT_TRIGGER EXPAND=FALSE

 VAR
   nlv$cc_grant_credit_trigger: [XREF, oss$network_paged] nlt$cc_credits;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_credits
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$CC_INITIALIZE_CONNECTION EXPAND=FALSE

  VAR
    nlv$cc_initialize_connection: [XREF, oss$network_paged] nlt$cc_connection;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_connection
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$CC_MAXIMUM_RECEIVE_WINDOW EXPAND=FALSE

 VAR
   nlv$cc_maximum_receive_window: [XREF, oss$network_paged] nlt$cc_credits;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_credits
?? POP ??
*DECK DECK=NLV$CC_WORK_LIST EXPAND=FALSE

  VAR
    nlv$cc_work_list: [XREF, oss$network_paged] nlt$cc_work_list;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cc_work_list
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$CL_ACTIVE_CONNECTIONS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  VAR
    nlv$cl_active_connections: [XREF] nlt$cl_reference_number;
?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_reference_number
?? POP ??
*DECK DECK=NLV$CL_CONNECTIONS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  VAR
    { The following must be locked before modifying the pointer to connections (nlv$cl_connections.list). }
    nlv$cl_connections_control: [XREF, oss$mainframe_wired] nlt$cl_connections_control,

    nlv$cl_connections: [XREF, oss$mainframe_wired] nlt$cl_connections;

*copyc nlt$cl_connections
*copyc oss$mainframe_wired
*DECK DECK=NLV$CL_CONNECTION_LAYER_TEMPLAT EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  VAR
    nlv$cl_connection_layer_templat: [XREF] array [nlt$cl_application_layer] of
          nlt$cl_connection_layer_templat;

*copyc nlt$cl_connection_layer_templat
*DECK DECK=NLV$CL_PRIORITY_CONNECTIONS EXPAND=FALSE

  VAR
    nlv$cl_priority_connections: [XREF, oss$network_paged] integer;

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$CL_PRIORITY_CONNECT_COUNT EXPAND=FALSE

  VAR
    nlv$cl_priority_connect_count: [XREF, oss$network_paged] nlt$cl_reference_number;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$cl_reference_number
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$CONFIGURED_NETWORK_DEVICES EXPAND=FALSE

  VAR
    nlv$configured_network_devices: [XREF, oss$network_paged]
          nlt$configured_network_devices;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$configured_network_devices
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$DEVICE_USAGE_DATA EXPAND=FALSE

  VAR
    nlv$device_usage_data: [XREF, oss$network_wired] ^nlt$device_usage_data_list;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$device_usage_data_list
*copyc oss$network_wired
?? POP ??
*DECK DECK=NLV$DIRECTORY_ID_SEQ_NUMBER EXPAND=FALSE
  VAR
    nlv$directory_id_seq_number: [XREF] integer;
*DECK DECK=NLV$DIRECTORY_LOCK EXPAND=FALSE

  VAR
    nlv$directory_lock: [XREF] ost$signature_lock;
*DECK DECK=NLV$DIRECTORY_PDU_SEQ_NUMBER EXPAND=FALSE
  VAR
    nlv$directory_pdu_seq_number: [XREF] integer;
*DECK DECK=NLV$DIRECTORY_VERSION EXPAND=FALSE

  VAR
    nlv$directory_version: [XREF] 2 .. 3;
*DECK DECK=NLV$LA_OPEN_SAP_LIST EXPAND=FALSE

  VAR
    nlv$la_open_sap_list: [XREF, oss$network_paged] nlt$la_open_sap_list;


*copyc nlt$la_open_sap_list
*copyc oss$network_paged
*DECK DECK=NLV$MAXIMUM_SYSTEM_CONNECTIONS EXPAND=TRUE

  VAR
    nlv$maximum_system_connections: [XREF, oss$mainframe_wired]
          nlt$connections_per_system;

?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_wired
*copyc nlt$connections_per_system
?? POP ??
*DECK DECK=NLV$NA_SAP_LIST EXPAND=FALSE

  VAR
    nlv$na_sap_list: [XREF, OSS$NETWORK_PAGED] nlt$na_sap_list;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$na_sap_list
?? POP ??
*DECK DECK=NLV$PP_BUFFER EXPAND=FALSE

  VAR
    nlv$pp_buffer: [XREF] ^nlt$pp_buffer;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$pp_buffer
?? POP ??
*DECK DECK=NLV$PP_SEND_QUEUE_TAILS EXPAND=FALSE

  VAR
    nlv$pp_send_queue_tails: [XREF] ^nlt$pp_send_queue_tails;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$pp_send_queue_tails
?? POP ??
*DECK DECK=NLV$RECEIVING_CONNECTIONS EXPAND=FALSE

  VAR
    nlv$receiving_connections: [XREF, oss$mainframe_wired] nlt$receiving_connections;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$receiving_connections
*copyc oss$mainframe_wired
?? POP ??
*DECK DECK=NLV$REPLENISH_PP_BUFFER_POOLS EXPAND=FALSE

  VAR
    nlv$replenish_pp_buffer_pools: [XREF, oss$network_wired] boolean;

*DECK DECK=NLV$SK_OFFERED_SOCKETS_LIST EXPAND=FALSE

  VAR
    nlv$sk_offered_sockets_list: [XREF, oss$network_paged] nlt$sk_offered_sockets_list;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$sk_offered_sockets_list
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$SL_CONNECTION_NAME_LIST EXPAND=FALSE

  VAR
    nlv$sl_connection_name_list: [XREF, oss$network_paged] nlt$sl_connection_name_list;

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
*copyc nlt$sl_session_layer
?? POP ??

*DECK DECK=NLV$SM_AWAIT_ROUTING_QUERIES EXPAND=FALSE

  VAR
    nlv$sm_await_routing_queries: [XREF, oss$network_paged]
          nlt$sm_await_routing_queries;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$sm_await_routing_queries
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$SM_DEVICES EXPAND=FALSE

  VAR
    nlv$sm_devices: [XREF, oss$network_paged] nlt$sm_devices;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$sm_devices
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$TCP_LISTEN_SOCKETS EXPAND=FALSE

  VAR
    nlv$tcp_listen_sockets: [XREF, oss$network_paged] nlt$tcp_listen_sockets;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$tcp_listen_sockets
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$TCP_PORTS EXPAND=FALSE

  VAR
    nlv$tcp_ports: [XREF, oss$network_paged] nlt$tcp_ports;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$tcp_ports
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$TIMER_MONITOR_TASK EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

  VAR
    nlv$timer_monitor_task: [XREF] ost$global_task_id;

*copyc ost$global_task_id
*DECK DECK=NLV$TM_ADDRESS_ACCESSIBLE EXPAND=FALSE

{
{ PURPOSE:
{   This variable contains all of the outstanding address accessible requests.
{   A request is queued when all of the configured devices are queried for a
{   specific destination address.  As each device responds the request is updated.
{   After the last device responds the request is removed from the queue.  The
{   requestor will be readied and informed which device if any is the best route
{   to the destination address.
{

  VAR
    nlv$tm_address_accessible: [XREF, oss$network_paged] nlt$tm_addr_access_req_queue;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$tm_addr_access_req_queue
*copyc oss$network_paged
?? POP ??

*DECK DECK=NLV$TM_DEVICE_CONFIGURATION EXPAND=FALSE

{ NOTE:
{   The intent of this variable is to hold information about each configured device.

  VAR
    nlv$tm_device_configuration: [XREF, oss$network_paged] ^nlt$tm_device_configuration;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$tm_device_configuration
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$TM_DEVICE_LIST EXPAND=FALSE

{ NOTE:
{   The intent of this variable is to hold information about each configured device.
{   The array elements should be read and written in one operation to avoid partial updates.
{   This removes the need for a lock.

  VAR
    nlv$tm_device_list: [XREF, oss$network_paged] nlt$tm_device_list;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$tm_device_list
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$TM_HOST EXPAND=FALSE

{ NOTE:
{   nlv$tm_host is initiallized by the DEFINE_TCPIP_HOST command.

  VAR
    nlv$tm_host: [XREF, oss$network_paged] nlt$tm_local_host_name;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$tm_local_host_name
*copyc oss$network_paged
?? POP ??

*DECK DECK=NLV$TM_ROUTE_CACHE EXPAND=FALSE

{ NOTE:
{   The route cache is enabled with the DEFINE_TCPIP_HOST command.

  VAR
    nlv$tm_route_cache: [XREF, oss$network_paged] nlt$tm_route_cache;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$tm_route_cache
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$TM_STATIC_ROUTING_TABLE EXPAND=FALSE

{ NOTE:
{   The static routing table is built with the DEFINE_STATIC_ROUTE command.

  VAR
    nlv$tm_static_routing_table: [XREF, oss$network_paged] nlt$tm_static_routing_table;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$tm_static_routing_table
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$TM_SUBNET_LIST EXPAND=FALSE

{ NOTE:
{   The subnet cache is enabled with the DEFINE_TCPIP_HOST command.

  VAR
    nlv$tm_subnet_list: [XREF, oss$network_paged] nlt$tm_subnet_list;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$tm_subnet_list
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$TRANSPORT_NETWORK_SELECTOR EXPAND=FALSE

  VAR
    nlv$transport_network_selector: [XREF, oss$network_paged]
          nat$network_selector;

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
*copyc nat$network_selector
?? POP ??
*DECK DECK=NLV$UDP_ACTIVE_GLOBAL_SOCKETS EXPAND=FALSE

  VAR
    nlv$udp_active_global_sockets: [XREF] nlt$udp_reference_number;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_global_socket_id
?? POP ??
*DECK DECK=NLV$UDP_GLOBAL_SOCKETS EXPAND=FALSE

  VAR
    nlv$udp_global_sockets_control: [XREF, oss$network_paged] nlt$udp_global_sockets_control,
    nlv$udp_global_sockets: [XREF, oss$network_paged] nlt$udp_global_sockets;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_global_sockets
*copyc oss$network_paged
?? POP ??
*DECK DECK=NLV$UDP_LOCAL_ROUTING_CACHE EXPAND=FALSE

  VAR
    nlv$udp_local_routing_cache: [XREF, oss$task_private] ^nlt$udp_local_routing_cache;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_local_routing_cache
*copyc oss$task_private
?? POP ??
*DECK DECK=NLV$UDP_PORTS EXPAND=FALSE

  VAR
    nlv$udp_ports: [XREF, oss$network_paged] nlt$udp_ports;

?? PUSH (LISTEXT := ON) ??
*copyc nlt$udp_ports
*copyc oss$network_paged
?? POP ??
*DECK DECK=NSH$FIND_REMOTE_VALIDATION EXPAND=FALSE
{
{    The purpose of this request is to provide the ETA station facility with
{ access to remote validation information
{
{        NSP$FIND_REMOTE_VALIDATION (LOCATION, VALIDATION_LINE_COUNT, STATUS)
{
{ LOCATION:  (input) This parameter specifies the remote location.
{
{ VALIDATION_LINE_COUNT:  (output) This parameter specifies the size of an
{        array required to hold the remote validation.
{
{ STATUS:  (output) This parameter indicates the status of the request.
{      CONDITIONS: none
*DECK DECK=NSH$GET_FNAME_FROM_PATH EXPAND=FALSE
{
{    The purpose of this request is to retrieve an evalutated file path, the
{ name of a file and the respective length of the associated strings based
{ on a file reference from an SCL parameter value table.
{
{        NSP$GET_FNAME_FROM_PATH (PATH, FNAME, FNAME_SIZE,
{             EVALUATED_FILE_PATH, EVALUATED_FILE_PATH_SIZE, STATUS)
{
{ PATH: (input) This is the "resolved" path found in the parameter value table
{      after calling clp$evaluate_parameters.
{
{ FNAME: (output) This is the "NAME" part of the path.
{
{ FNAME_SIZE: (output) This is the size of FNAME.
{
{ EVALUATED_FILE_PATH: (output) This is the path with all generic reverences
{     "evaluated." ($USER, $HIGH and so forth)
{
{ EVALUATED_FILE_PATH_SIZE: (output) This is the size of EVALUATED_FILE_PATH
{
{ STATUS:  (output) This parameter indicates the status of the request.
{
*DECK DECK=NSH$GET_REMOTE_VALIDATION EXPAND=FALSE
{
{    The purpose of this request is to provide the ETA station facility with
{ access to remote validation information
{
{        NSP$GET_REMOTE_VALIDATION (LOCATION, VALIDATION, STATUS)
{
{ LOCATION:  (input) This parameter specifies the remote location.
{
{ VALIDATION_LINE_COUNT:  (output) This parameter specifies the remote
{        validation aed to hold the remote validation.
{
{ STATUS:  (output) This parameter indicates the status of the request.
{      CONDITIONS: nfe$remote_val_undefined
{      IDENTIFIER: nfc$setatus_id
{
*DECK DECK=NSM$OS_INTERFACE EXPAND=TRUE
*DECK DECK=NSP$FIND_REMOTE_VALIDATION EXPAND=FALSE
*DECK DECK=NSP$GET_FNAME_FROM_PATH EXPAND=FALSE
*DECK DECK=NSP$GET_REMOTE_VALIDATION EXPAND=FALSE
*DECK DECK=NV0E569 EXPAND=TRUE
                                                                    1992-12-10
FEATURE_INFO_DECK_VERSION = '2.0'


ANALYST:  murali krishna
PHONE:    482-6047

FEATURE_NAME    = NV0E569
PRODUCT_NAME    = OS
WORKING_CATALOG = :COBALT.CMCAM.NV0E569
FEATURE_CATALOG = NONE

PLANNED_RELEASE_LEVEL = '1.7.1/L803'
REQUESTED_BUILD_CYCLE = C3

FEATURE_PRIORITY              = 'NEITHER'
FEATURE_PURPOSE               = 'NEW_CAPABILITY'
CLSH_CRITICAL_PROBLEM         = FALSE
SERIOUS_PROBLEMS_WITH_FEATURE = FALSE

PERFORMANCE_IMPACT = 'NONE'  "Enter DEGRADED, IMPROVED, or NONE"

FEATURE_DESCRIPTION:
PROBLEM:
CONTROL T IS IGNORED IN CREATE_OBJECT_LIBRARY IF CALLED BY PROC.
The Condition Handler of  CREATE_OBJECT_LIBRARY, ignores a
terminate_break  condition in all cases.

SOLUTION:
The Condition Handler of CREATE_OBJECT_LIBRARY is modified to,not establish
a condition handler for terminate break, since the SCL condition handler
for a utility processes the condition correctly.
DEPENDENCIES:
None
TESTING_METHOD:
Own test procedures

NOTES_TO_REVIEWERS:
 None

NOTES_TO_INTEGRATION:
 None

CLSH_IMPACT:
 None

EVALUATION_IMPACT:
 None

INSTALLABILITY_IMPACT:
 None

USER_IMPACT:
 None

PSRS_ANSWERED:
 None

SRB_ARTICLE:
 None

PERFORMANCE_CHECKLIST:

***WARNING- An error occurred checking base data at BUILD_C310
   The following procedures have been modified by this feature:

condition_handler
ocp$_create_object_library

A benchmark comparison is required if you have:
  1. changed the number of times procedures used by the benchmarks are called.
  2. changed the cpu usage of these procedures by code changes or the addition
     or removal of calls to other procedures.
  3. changed the size of variables used by these procedures, added new ones,
     moved them to a different section, or changed the way space for them is
     created.
  4. changed the attributes of these procedures or the variables they use.
  5. changed the output format of data that is referenced by any of the
     benchmark execution or reporting procedures.



PERFORMANCE_INFO:
{ If a benchmark comparison exists for this feature then place it here. }
{ If not, then explain how you know that this feature does not do       }
{ any of the things mentioned above.  This is REQUIRED.                 }
None.
(As the module changed is an utility module ,this will not have benchmark
performance impact.)
*DECK DECK=OCC$BREAKLIST EXPAND=FALSE
  CONST
    occ$max_breaklist_items = 0ffff(16);

  CONST
    occ$address_formulation = 'address_formulation',
    occ$binding_section = 'binding_section',
    occ$binding_template_records = 'binding_template_records',
    occ$command_description_header = 'command_description_header',
    occ$command_dictionary = 'command_dictionary',
    occ$command_header = 'command_header',
    occ$component_header = 'component',
    occ$deferred_common_block = 'deferred_common_block',
    occ$deferred_entry_point = 'deferred_entry_point',
    occ$entry_definition = 'entry_definition',
    occ$entry_point_dictionary = 'entry_point_dictionary',
    occ$external_linkage = 'external_linkage',
    occ$function_description_header = 'function_description_header',
    occ$function_dictionary = 'function_dictionary',
    occ$function_header = 'function_header',
    occ$help_module_dictionary = 'help_module_dictionary',
    occ$info_element_header = 'info_element_header',
    occ$last_breaklist = 'last_breaklist',
    occ$load_module_header = 'load_module_header',
    occ$message_header = 'message_header',
    occ$message_module_dictionary = 'message_module_dictionary',
    occ$message_template = 'message_template',
    occ$message_template_module = 'message_template_module',
    occ$module_dictionary = 'module_dictionary',
    occ$motorola_68000_absolute = 'motorola_68000_absolute',
    occ$mtm_condition_code = 'mtm_condition_code',
    occ$mtm_condition_name = 'mtm_condition_name',
    occ$panel_dictionary = 'panel_dictionary',
    occ$panel_header = 'panel_header',
    occ$program_header = 'program_header',
    occ$relocation = 'relocation',
    occ$section_definition = 'section_definition',
    occ$section_map_header = 'section_map',
    occ$starting_breaklist = 'start of breaklist';

*DECK DECK=OCC$CONDITION_LIMITS EXPAND=FALSE

  CONST
    occ$min_ecc = (($INTEGER ('O') * 100(16)) + $INTEGER ('C')) * 1000000(16),
    occ$max_ecc = occ$min_ecc + 9999;

*DECK DECK=OCC$CORRECTOR EXPAND=FALSE

  CONST
    occ$max_number_of_correctors = 0ffffff(16),
    occ$corrector_header_version = 'CORRECTOR HEADER VERSION 1.1';
*DECK DECK=OCC$DIFFERENCE EXPAND=FALSE
*DECK DECK=OCC$GENERATE_PREDICTOR EXPAND=FALSE
  CONST
    occ$invalid_section_ordinal = 0ffff(16);
*DECK DECK=OCC$INITIAL_SEGMENT_NUMBER EXPAND=FALSE

  CONST
    occ$initial_segment_number = 0;

*DECK DECK=OCC$RETAIN EXPAND=FALSE
  CONST
    occ$retain = TRUE,
    occ$no_retain = FALSE;

*DECK DECK=OCC$RETAIN_ALL_COMMON_BLOCKS EXPAND=FALSE

  CONST
    occ$retain_all_common_blocks = '*** Retain All Common Blocks **';

*DECK DECK=OCC$SYMBOL_TABLE_VERSION EXPAND=FALSE

  CONST
    occ$symbol_table_version = 'VMST_V1.2';

*DECK DECK=OCD$OBJECT_CODE_EXCEPTIONS EXPAND=FALSE

?? NEWTITLE := 'Object Code Maintenance    : ''OC'' 0 - 9999' ??
*copyc occ$condition_limits
*copyc oce$library_generator_errors      " 0000 .. 0199
*copyc oce$object_converter_exceptions   " 0200 .. 0299
*copyc oce$interrupt_exceptions          " 0300 .. 0399
*copyc oce$anaol_exceptions              " 0400 .. 0499
*copyc oce$ve_linker_exceptions          " 0500 .. 0699
*copyc oce$rm_builder_exceptions         " 0700 .. 0899
*copyc oce$generate_not_complete         " 0900
*copyc oce$format_not_allowed_with_nl    " 0901
*copyc oce$metapatch_generator_errors    " 1000 .. 1199
?? OLDTITLE ??
*DECK DECK=OCE$ANAOL_EXCEPTIONS EXPAND=FALSE
*copyc occ$condition_limits
?? NEWTITLE := 'ANALYZE_OBJECT_LIBRARY : ''OC'' 400 .. 499', EJECT ??
?? FMT (FORMAT := OFF) ??

CONST
  occ$anaol_base_exception        = occ$min_ecc + 400,


  oce$object_library_not_analyzed = occ$anaol_base_exception +  0,
    {E An object library must be analyzed before it is displayed.}

  oce$unknown_module              = occ$anaol_base_exception +  1,
    {E Module +P is not on the current library.}

  oce$usel_not_executed = occ$anaol_base_exception +  2,
    {E An object library must be specified on the USE_LIBRARY subcommand before }
    {this function can be performed.}

  occ$max_anaol_exception         = occ$anaol_base_exception + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=OCE$FORMAT_NOT_ALLOWED_WITH_NL EXPAND=FALSE
*copyc occ$condition_limits
?? FMT (FORMAT := OFF) ??

  CONST
    oce$format_not_allowed_with_nl  = occ$min_ecc + 901;
{E +P not an allowed value for parameter FORMAT when generating to +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=OCE$GENERATE_NOT_COMPLETE EXPAND=FALSE
*copyc occ$condition_limits
?? FMT (FORMAT := OFF) ??

  CONST
    oce$generate_not_complete       = occ$min_ecc + 900;
{I The GENERATE_LIBRARY subcommand was unable to write to file +P.  The module }
{list is the same as it was before the subcommand was issued.}

?? FMT (FORMAT := ON) ??
*DECK DECK=OCE$INTERRUPT_EXCEPTIONS EXPAND=FALSE
*copyc occ$condition_limits
?? NEWTITLE := 'Interrupt conditions : ''OC''  300 .. 399', EJECT ??
?? FMT (FORMAT := OFF) ??

CONST
  occ$interrupt_base_exception    = occ$min_ecc + 300,


  oce$internal_error              = occ$interrupt_base_exception +  0,
    {E Internal error detected: +P.}

  oce$premature_eof_in_segment    = occ$interrupt_base_exception +  1,
    {E Premature end of file encountered on +F.}

  oce$structure_error_in_segment  = occ$interrupt_base_exception +  2,
    {E Structure error encountered on file +F2: +P1.}


  occ$max_interrupt_exception     = occ$interrupt_base_exception + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=OCE$LIBRARY_GENERATOR_ERRORS EXPAND=FALSE
*copyc occ$condition_limits
?? NEWTITLE := 'OCDERRR : Object Library Generator : ''OC'' 0 .. 199', EJECT
??
?? FMT (FORMAT := OFF) ??

CONST
  occ$olg_base_exception          = occ$min_ecc + 0,



  oce$e_module_not_found          = occ$olg_base_exception +  0,
                                   {E Module +P not found.}

  oce$e_internal_olg_seg_overflow = occ$olg_base_exception +  1,
                                   {E Internal OLG segment overflow.}

  oce$e_premature_eof_on_file     = occ$olg_base_exception +  2,
                                   {E Premature end of file encountered on file +F.}

  oce$e_module_already_on_library = occ$olg_base_exception +  3,
                                   {E Module +P already on current library.}

  oce$e_too_many_components       = occ$olg_base_exception +  4,
                                   {E Too many components specified.}

  oce$e_xdcl_already_exists       = occ$olg_base_exception +  5,
                                   {E Entry point +P already exists.}

  oce$e_xdcl_doesnt_exist         = occ$olg_base_exception +  6,
                                   {E Entry point +P not found.}

  oce$e_after_in_reorder_list     = occ$olg_base_exception +  7,
                                   {E Module +P specified in both MODULE and LOCATION parameters.}

  oce$e_multiple_ident_rec        = occ$olg_base_exception +  8,
                                   {E Multiple identification records found in module +P.}

  oce$e_invalid_object_rec_kind   = occ$olg_base_exception +  9,
                                   {E Record number +P2 in module +P1 is an unknown record kind.}

  oce$e_no_ident_rec_on_load_mod  = occ$olg_base_exception + 10,
                                   {E Identification record expected on load module +P.}

  oce$e_code_section_not_found    = occ$olg_base_exception + 11,
                                   {E Code section +P not found in module +P.}

  oce$e_empty_object_file         = occ$olg_base_exception + 12,
                                    {E Object file +F is empty.}

  oce$e_invalid_section_ordinal   = occ$olg_base_exception + 13,
                                   {E Unknown section ordinal encountered in module +P.}

  oce$e_duplicate_section_defn    = occ$olg_base_exception + 14,
                                   {E Duplicate section definition encountered in module +P.}

  oce$e_section_not_yet_defined   = occ$olg_base_exception + 15,
                                   {E Missing section definition in module +P.}

  oce$e_reference_outside_section = occ$olg_base_exception + 16,
                                   {E Referencing outside section in module +P.}

  oce$e_section_defn_expected     = occ$olg_base_exception + 17,
                                   {E Section definition expected in module +P.}

  oce$e_missing_code_section_defn = occ$olg_base_exception + 18,
                                   {E Missing code section definition in module +P.}

  oce$e_relocation_rec_expected   = occ$olg_base_exception + 19,
                                   {E Relocation record expected in module +P.}

  oce$e_too_many_relocation_items = occ$olg_base_exception + 20,
                                   {E Too many relocation items encountered in module +P.}

  oce$e_too_many_template_items   = occ$olg_base_exception + 21,
                                   {E Too many template items encountered in module +P.}

  oce$e_too_many_modules_on_lib   = occ$olg_base_exception + 22,
                                   {E Too many modules on library.}

  oce$e_too_many_entry_points     = occ$olg_base_exception + 23,
                                   {E Too many entry points encountered.}

  oce$e_too_many_section_defns    = occ$olg_base_exception + 24,
                                   {E Too many section definitions encountered.}

  oce$e_object_file_must_be_lib   = occ$olg_base_exception + 25,
                                   {E File +F specified is not a library.}

  oce$e_on_off_toggles_overlap    = occ$olg_base_exception + 26,
                                   {E Conflicting on-off toggles specified.}

  oce$e_no_modules_on_current_lib = occ$olg_base_exception + 27,
                                   {E No modules on current library.}

  oce$e_file_name_cannot_be_range = occ$olg_base_exception + 28,
                                   {E File name +F can not be part of a subrange +F .. +P.}

  oce$e_module_not_on_library     = occ$olg_base_exception + 29,
                                   {E Module +P not on current library.}

  oce$e_no_ident_rec_on_obj_file  = occ$olg_base_exception + 30,
                                   {E Identification record expected on object file +F.}

  oce$e_missing_or_empty_file     = occ$olg_base_exception + 31,
                                   {E Empty or missing file +F.}

  oce$e_non_object_file           = occ$olg_base_exception + 32,
                                   {E File +F does not contain object code.}

  oce$e_premature_eof_in_module   = occ$olg_base_exception + 33,
                                   {E Premature end of file encountered in module +P.}

  oce$e_non_object_module_found   = occ$olg_base_exception + 34,
                                   {E Non object module +P cannot be placed on an object file.}

  oce$e_too_many_libraries        = occ$olg_base_exception + 35,
                                   {E Too many libraries encountered. }

  oce$e_container_outside_record  = occ$olg_base_exception + 36,
                                   {E Relocation container goes beyond record area in module +P.}

  oce$e_opcode_not_within_record  = occ$olg_base_exception + 37,
                                   {E Offset for instruction opcode is less than zero in module +P.}

  oce$e_invalid_container_kind    = occ$olg_base_exception + 38,
                                   {E Unknown relocation container kind encountered in module +P.}

  oce$e_sign_bit_set_in_container = occ$olg_base_exception + 39,
                                   {E Sign bit set in relocation container for signed address type }
                                   {in module +P.}

  oce$e_invalid_container_adr_typ = occ$olg_base_exception + 40,
                                   {E Unknown relocation container address type in module +P.}

  oce$e_invalid_template_adr_kind = occ$olg_base_exception + 41,
                                   {E Unknown binding template address kind encountered in module +P.}

  oce$e_relocating_sec_wrong_kind = occ$olg_base_exception + 42,
                                   {E Relocating section is not code or binding in module +P.}

  oce$e_starting_proc_not_in_code = occ$olg_base_exception + 43,
                                   {E Starting procedure +P not located in a code section.}

  oce$e_generate_is_aborting      = occ$olg_base_exception + 44,
                                   {E GENERATE is aborting - no recovery is possible.}

  oce$e_offset_arithmetic_in_bs   = occ$olg_base_exception + 45,
                                   {E Offset arithmetic in bind section of module +P.}

  oce$e_bad_binding_sec_offset    = occ$olg_base_exception + 46,
                                   {E Binding offset has no binding section template with matching offset }
                                   {in module +P.}

  oce$e_invalid_address_kind      = occ$olg_base_exception + 47,
                                   {E Unknown binding template address kind encountered.}

  oce$e_no_modules_on_library     = occ$olg_base_exception + 48,
                                   {E No modules on library +F.}

  oce$e_invalid_module_kind       = occ$olg_base_exception + 49,
                                   {E Incompatible library module kind for module +P.}

  oce$e_too_many_modules_on_file  = occ$olg_base_exception + 50,
                                   {E Too many modules on file +F.}

  oce$e_conflicting_map_options   = occ$olg_base_exception + 51,
                                   {E Map option parameter NONE used with other specifications.}

  oce$e_file_opened_as_object     = occ$olg_base_exception + 52,
                                   {E File +F previously opened as an object file.}

  oce$e_eof_on_generated_file     = occ$olg_base_exception + 53,
                                   {E End of file encountered on generated library.}

  oce$e_module_not_bindable       = occ$olg_base_exception + 54,
                                   {E Module +P being bound is type nonbindable.}

  oce$e_duplicate_global_ept      = occ$olg_base_exception + 55,
                                   {E Duplicate entry point +P found on libraries.}

  oce$e_bnd_sec_ext_not_found     = occ$olg_base_exception + 56,
                                   {E External linkage record not found for binding section in module +P.}

  oce$e_invalid_library_version   = occ$olg_base_exception + 57,
                                   {E Incompatible object library version +P on library +F.}

  oce$e_invalid_obj_text_version  = occ$olg_base_exception + 58,
                                   {E Incompatible object text version +P in module +P.}

  oce$e_invalid_scl_proc          = occ$olg_base_exception + 59,
                                   {E SCL procedure number +P2 on file +F1 is incorrect or..
{ the file attribute(s) are incompatible.}

  oce$w_module_not_found          = occ$olg_base_exception + 60,
                                   {E Module +P not found - module ignored.}

  oce$w_subrange_module_not_found = occ$olg_base_exception + 61,
                                   {E Module +P not found - Module subrange +P .. +P ignored.}

  oce$w_same_module_quoted_twice  = occ$olg_base_exception + 62,
                                   {E Duplicate module +P specified - second occurrence ignored.}

  oce$w_module_already_on_library = occ$olg_base_exception + 63,
                                   {E Module +P already on current library - module ignored.}

  oce$w_module_not_on_library     = occ$olg_base_exception + 64,
                                   {E Module +P not on current library - module ignored.}

  oce$w_subrange_not_found_on_lib = occ$olg_base_exception + 65,
                                   {E Module +P not on current library - module subrange +P .. +P ignored.}

  oce$w_duplicate_module_on_file  = occ$olg_base_exception + 66,
                                   {W Duplicate module +P on file +F.}

  oce$w_library_not_generated     = occ$olg_base_exception + 67,
                                   {W Exiting library generator without generating current library.}

  oce$w_no_modules_on_current_lib = occ$olg_base_exception + 68,
                                   {E No modules on current library.}

  oce$w_new_file_is_on_file       = occ$olg_base_exception + 69,
                                   {E Due to errors the generated +P was placed on +F.}

  oce$w_new_file_not_generated    = occ$olg_base_exception + 70,
                                   {E New file was not generated due to errors encountered.}

  oce$w_xdcl_already_exists       = occ$olg_base_exception + 71,
                                   {E Entry point +P already exists - entry point ignored.}

  oce$w_xdcl_doesnt_exist         = occ$olg_base_exception + 72,
                                   {E Entry point +P not found - entry point ignored.}

  oce$w_external_not_satisfied    = occ$olg_base_exception + 73,
                                   {W External reference +P not satisfied.}

  oce$e_multiple_binding_sections = occ$olg_base_exception + 74,
                                   {E Module +P has multiple binding sections.}

  oce$w_conflicting_common_length = occ$olg_base_exception + 75,
                                   {W Conflicting length for common block +P.}

  oce$w_conflicting_com_attribute = occ$olg_base_exception + 76,
                                   {W Conflicting attributes for common block +P.}

  oce$e_bad_symbol_table          = occ$olg_base_exception + 77,
                                   {E Bad debug symbol table in module +P - symbol number +P.}

  oce$e_bad_line_table            = occ$olg_base_exception + 78,
                                   {E Bad line table in module +P.}

  oce$e_zero_allocation_align     = occ$olg_base_exception + 79,
                                   {E Zero section alignment in module +P.}

  oce$w_library_not_found         = occ$olg_base_exception + 80,
                                   {W Library +P not found.}

  oce$e_fatal_error               = occ$olg_base_exception + 81,
                                   {E Fatal error in library_generator.}

  oce$e_insufficient_memory       = occ$olg_base_exception + 82,
                                   {E Insufficient memory for completion of library generation.}

  oce$e_cant_compare_file_and_lib = occ$olg_base_exception + 83,
                                   {E Can not compare an object file and an object library.}

  oce$e_generate_terminated       = occ$olg_base_exception + 84,
                                   {E Command terminated - new library not generated.}

  oce$e_module_is_not_an_scl_proc = occ$olg_base_exception + 85,
                                    {E Module +P is not an scl procedure.}

  oce$e_no_unique_file_name       = occ$olg_base_exception + 86,
                                   {E Unable to generate a unique local file name.}

  oce$e_some_modules_not          = occ$olg_base_exception + 87,
                                   {E Some of the modules specified could not be +P.}

  oce$e_some_attributes_not       = occ$olg_base_exception + 88,
                                   {E Some of the attributes specified could not be changed.}


  oce$w_error_in_command          = occ$olg_base_exception + 89,
                                   {E Command completed - Non fatal errors encountered.}

  oce$i_display_toggle            = occ$olg_base_exception + 90,
                                   {I +P}

  oce$e_range_module_2_not_found  = occ$olg_base_exception + 91,
                                   {E Module +P not found after module +P - Subrange ignored.}

  oce$e_bad_otd_size              = occ$olg_base_exception + 92,
                                   {E Invalid size encountered on object text descriptor in module +P.}

  oce$w_dup_ent_pnt_on_lib        = occ$olg_base_exception + 93,
                                   {W Duplicate entry point +P in library may cause unpredictable results.}

  oce$relocation_value_not_found  = occ$olg_base_exception + 94,
                                   {E Relocation value not found in module +P.}

  oce$w_declaration_mismatch      = occ$olg_base_exception + 95,
                                   {W Declaration mismatch on reference to entry point +P1 in }
                                   {module +P2 from module +P3, using source text checking.}

  oce$w_non_fatal_generate_error  = occ$olg_base_exception + 96,
                                   {W WARNING - Nonfatal error(s) encountered during generation }
                                   {of new library.}

  oce$misc_exception              = occ$olg_base_exception + 97,
                                   {I +P}

  oce$container_overflow          = occ$olg_base_exception + 98,
                                   {E The bound module has overflowed a +P.}

  oce$e_cant_change_module_name   = occ$olg_base_exception + 99,
                                   {E Module name can not be changed when multiple modules specified.}

  oce$e_too_many_commands_on_lib  = occ$olg_base_exception + 100,
                                   {E Too many commands on library.}

  oce$e_too_many_functions_on_lib = occ$olg_base_exception + 101,
                                   {E Too many functions on library.}

  oce$e_too_many_help_mods_on_lib = occ$olg_base_exception + 102,
                                   {E Too many help modules on library.}

  oce$e_too_many_msg_mods_on_lib  = occ$olg_base_exception + 103,
                                   {E Too many message modules on library.}

  oce$e_too_many_panels_on_lib    = occ$olg_base_exception + 104,
                                   {E Too many forms on library.}

  oce$w_dup_commands_on_lib       = occ$olg_base_exception + 105,
                                   {W Duplicate command +P in library may cause unpredictable results.}

  oce$w_dup_functions_on_lib      = occ$olg_base_exception + 106,
                                   {W Duplicate function +P in library may cause unpredictable results.}

  oce$w_dup_help_modules_on_lib   = occ$olg_base_exception + 107,
                                   {W Duplicate help modules +P in library may cause unpredictable results.}

  oce$w_dup_msg_modules_on_lib    = occ$olg_base_exception + 108,
                                   {W Duplicate message modules +P in library may cause unpredictable..
{ results.}

  oce$w_dup_panels_on_lib         = occ$olg_base_exception + 109,
                                   {W Duplicate command +P in library may cause unpredictable results.}

  oce$e_option_must_be_used_alone = occ$olg_base_exception + 110,
                                   {E +P must be used alone for parameter +P.}

  oce$invalid_type_matching       = occ$olg_base_exception + 111,
                                    {E Modules +P and +P with parameter number +P..
{ of procedure +P are incompatible types.}

  oce$invalid_kind_matching       = occ$olg_base_exception + 112,
                                    {E Modules +P and +P with parameter number +P..
{ of procedure +P are incompatible kinds.}

  oce$invalid_mode_matching       = occ$olg_base_exception + 113,
                                    {E Modules +P and +P with parameter number +P..
{ of procedure +P are incompatible modes.}

  oce$bad_char_length             = occ$olg_base_exception + 114,
                                    {E +P has character length mismatch on parameter +P, actual length = +P
{ and formal length = +P.}

  oce$actual_less_than_formal     = occ$olg_base_exception + 115,
                                    {E +P parameter number +P actual length of +P less than formal length
{ of +P.}

  oce$unable_to_create_table      = occ$olg_base_exception + 116,
                                    {E Unable to create (+P) container.}

  oce$loader_table_overflow       = occ$olg_base_exception + 117,
                                    {E Overflow of (+P) container.}

  oce$entry_point_mismatch        = occ$olg_base_exception + 118,
                                    {E Parameter mismatch (+P).}

  oce$ext_not_found_for_actual    = occ$olg_base_exception + 119,
                                    {E The external record for +P needed by an actual parameter record..
{ in module +P has not been encountered.}

  oce$invalid_param_for_proc      = occ$olg_base_exception + 120,
                                    {E Procedure +P in modules +P and +P do..
{ not have the same number of parameters.}

  oce$entry_not_found_for_formal  = occ$olg_base_exception + 121,
{E The entry point record for +P needed by a formal parameter record in module..
{ +P has not been encountered.}

  oce$invalid_unalloc_common_bl   = occ$olg_base_exception + 122,
                                    {E Unallocated common block has invalid..
{ section kind in module +P.}

  oce$e_form_def_found_in_module  = occ$olg_base_exception + 123,
                                    {E Form definition found in module +P.}

  oce$e_must_be_file_or_string    = occ$olg_base_exception + 124,
                                    {E Value of parameter +P must be FILE or STRING.}

  oce$not_application_administrtr = occ$olg_base_exception + 125,
                                    {E Only an application administrator may specify an application..
{ identifier.}

  oce$cannot_be_an_application    = occ$olg_base_exception + 126,
                                    {E +P cannot be an application.}

  oce$fortran_array_type_mismatch = occ$olg_base_exception + 127,
                                    {E Call from +P to +P parameter number +P has an array mismatch.}

  oce$e_module_is_not_a_prog_desc = occ$olg_base_exception + 128,
                                    {E Module +P is not a program description.}

  oce$e_bound_module_too_large    = occ$olg_base_exception + 129,
                                    {E The module being generated is too large.  Q field overflow }
                                    {occurred while binding module +P.}

  oce$w_name_not_in_symbol_table  = occ$olg_base_exception + 130,
                                    {W Entry point +P, specified on a DELETE_DECLARATION_MATCHING }
                                    {subcommand, is not in the linked symbol table.}

  oce$w_must_include_symbols      = occ$olg_base_exception + 131,
                                    {W DELETE_DECLARATION_MATCHING cannot be done for entry points that }
                                    {are not included in a segment specified by INCLUDE_LINKED_SYMBOLS.}

  oce$bad_integer_length          = occ$olg_base_exception + 132,
                                    {E Modules +P and +P with parameter number +P of procedure +P are }
{ incompatible integer lengths. }

  oce$w_param_checking_not_cybil  = occ$olg_base_exception + 133,
                                    {W No entry points generated by CYBIL were found in module +P. The }
                                    {value of attribute CYBIL_PARAMETER_CHECKING was not changed.}

  oce$f_declaration_mismatch      = occ$olg_base_exception + 134,
                                    {F Declaration mismatch on reference to entry point +P1 in module +P2 }
                                    {from module +P3, using object text checking. }

  oce$w_decl_mismatch_ext_source  = occ$olg_base_exception + 135,
                                    {W The declaration of the reference to entry point +P1 from module +P2 }
                                    {and the declaration of the reference to the same entry point from }
                                    {module +P3 do not match, using source text checking. }

  oce$w_decl_mismatch_ext_object  = occ$olg_base_exception + 136,
                                    {W The declaration of the reference to entry point +P1 from module +P2 }
                                    {and the declaration of the reference to the same entry point from }
                                    {module +P3 do not match, using object text checking. }

  oce$e_module_not_a_command_desc = occ$olg_base_exception + 137,
                                    {E Module +P is not a command description.}

  oce$e_bad_command_desc_params   = occ$olg_base_exception + 138,
                                    {E When creating or changing a command description, either the }
                                    {STARTING_PROCEDURE or SYSTEM_COMMAND_NAME parameter may be specified }
                                    {but not both. Also, the LIBRARY parameter may only be specified for }
                                    {a command description defined with the STARTING_PROCEDURE parameter.}

  oce$e_module_not_a_func_desc    = occ$olg_base_exception + 139,
                                    {E Module +P is not a function description.}

  oce$e_module_has_null_name      = occ$olg_base_exception + 140,
                                    {E A module on file +F has an invalid name which is all blanks.}

  occ$max_olg_exception           = occ$olg_base_exception + 199;



?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=OCE$METAPATCH_GENERATOR_ERRORS EXPAND=FALSE
*copyc occ$condition_limits
?? NEWTITLE := 'Metapatch Generator : ''OC'' 1000 .. 1199', EJECT
??
?? FMT (FORMAT := OFF) ??

  CONST
    occ$status_id = 'OC',
    occ$mg_base_exception = occ$min_ecc + 1000,

    oce$invalid_module_kind = occ$mg_base_exception + 10,
{F Module kind +P invalid.}

    oce$no_section_definition = occ$mg_base_exception + 20,
{F No section_definition for section number +P.}

    oce$offset_mismatch = occ$mg_base_exception + 30,
{F Offset mismatch in predictor.}

    oce$invalid_section_length = occ$mg_base_exception + 40,
{F Section lengths in predictor do not match.}

    oce$no_code_section = occ$mg_base_exception + 50,
{F No code section found for module +P.}

    oce$no_section_maps = occ$mg_base_exception + 60,
{E +P object library generated without section_maps.}

    oce$invalid_container = occ$mg_base_exception + 70,
{F Relocation record container is invalid.}

    oce$invalid_relocation_address = occ$mg_base_exception + 80,
{F Relocation record address field is invalid.}

    oce$unexpected_record_kind = occ$mg_base_exception + 90,
{F Record type +P is unknown.}

    oce$binding_adr_not_found = occ$mg_base_exception + 100,
{F Address formulation record not found for binding section.}

    oce$section_map_invalid_pointer = occ$mg_base_exception + 110,
{F Section map pointer points to middle of +P record.}

    oce$text_record_expected = occ$mg_base_exception + 120,
{F A text, replication, or bit_string_insertion record was expected.}

    oce$id_record_expected = occ$mg_base_exception + 130,
{F Identification record was expected.}

    oce$breaklist_not_sorted = occ$mg_base_exception + 140,
{F Breaklist is not sorted.}

    oce$files_dont_differ = occ$mg_base_exception + 150,
{E Files are identical, correction not generated.}

    oce$bad_metapatch_generated = occ$mg_base_exception + 160,
{F Correction generated produces invalid object library.}

    oce$invalid_library_version = occ$mg_base_exception + 170,
{F Incompatible object library version on file +P.}

    oce$error_in_correction_gen = occ$mg_base_exception + 180,
{F Unexpected error occurred while +P during correction generation.}

    occ$max_mg_exception = occ$mg_base_exception + 199;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??

*DECK DECK=OCE$OBJECT_CONVERTER_EXCEPTIONS EXPAND=FALSE

*copyc OCC$CONDITION_LIMITS
?? NEWTITLE := 'Object Module Converter : ''OC'' 200 .. 299', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    occ$object_cnvrt_base_exception = occ$min_ecc + 200,

    oce$missing_or_empty_file       = occ$object_cnvrt_base_exception +    0,
                                      {E Missing or empty file: +F.}

    oce$missing_rec_or_descriptor   = occ$object_cnvrt_base_exception +    1,
                                      {E Missing record or descriptor: +P.}

    oce$short_record_or_descriptor  = occ$object_cnvrt_base_exception +    2,
                                      {E Short record or descriptor: +P.}

    oce$ident_or_lib_desc_expected  = occ$object_cnvrt_base_exception +    3,
                                      {E Identification or library descriptor expected: +P.}

    oce$multiple_ident_records      = occ$object_cnvrt_base_exception +    4,
                                      {E Multiple identification records in same module: +P.}

    oce$invalid_version             = occ$object_cnvrt_base_exception +    5,
                                      {E Invalid object text version. +P.}

    oce$invalid_cpu_record_kind     = occ$object_cnvrt_base_exception +    6,
                                      {E Invalid CPU record kind: +P.}

    oce$invalid_ppu_record_kind     = occ$object_cnvrt_base_exception +    7,
                                      {E Invalid PPU record kind: +P.}

    oce$invalid_object_module_kind  = occ$object_cnvrt_base_exception +    8,
                                      {E Invalid object module kind: +P.}

    oce$invalid_parameter_kind      = occ$object_cnvrt_base_exception +    9,
                                      {E Invalid parameter kind: +P.}

    oce$invalid_object_record_kind  = occ$object_cnvrt_base_exception +   10,
                                      {E Invalid object record kind: +P.}

    occ$object_cnvrt_max_exception  = occ$object_cnvrt_base_exception +  299;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=OCE$RM_BUILDER_EXCEPTIONS EXPAND=FALSE

*copyc OCC$CONDITION_LIMITS
?? NEWTITLE := 'OCDMBER : Real Memory Builder : ''OC'' 700 .. 899', EJECT ??
?? FMT (FORMAT := OFF) ??

CONST
  occ$rm_builder_base_exception   = occ$min_ecc + 700,



  oce$e_build_option_error       = occ$rm_builder_base_exception +   0,
                                    {E Inconsistent build options - +P.}

  oce$e_empty_segment_file        = occ$rm_builder_base_exception +   1,
                                    {E Segment file +P contains no segment descriptors.}

  oce$e_exch_segment_not_found    = occ$rm_builder_base_exception +   2,
                                    {E Segment +P not found.}

  oce$e_segment_number_to_large   = occ$rm_builder_base_exception +   3,
                                    {E Segment number +P greater than segment table size.}

  oce$e_duplicate_segment_numbers = occ$rm_builder_base_exception +   4,
                                    {E Duplicate segment +P specified.}

  oce$e_real_memory_overflow      = occ$rm_builder_base_exception +   5,
                                    {E Real memory file overflow.}

  oce$e_segment_not_found         = occ$rm_builder_base_exception +   6,
                                    {E Segment +P not found.}

  oce$e_real_memory_seg_overflow  = occ$rm_builder_base_exception +   7,
                                    {E +P extends beyond end of segment +P.}

  oce$e_bad_input_file            = occ$rm_builder_base_exception +   8,
                                    {E Unknown contents on input file +P.}

  oce$e_real_memory_read_error    = occ$rm_builder_base_exception +   9,
                                    {E Tried reading beyond end of real memory image.}

  oce$e_page_width_error          = occ$rm_builder_base_exception +  10,
                                    {E Page width to narrow to display memory.}

  oce$e_invalid_address_space_id  = occ$rm_builder_base_exception +  11,
                                    {E Invalid address space id.}

  oce$e_no_memory_available       = occ$rm_builder_base_exception +  12,
                                    {E All real memory pages have been assigned.}

  oce$e_no_contiguous_real_memory = occ$rm_builder_base_exception +  13,
                                    {E Contiguous real memory unavailable for segment +P.}

  oce$e_page_already_allocated    = occ$rm_builder_base_exception +  14,
                                    {E Page at address +P has been allocated.}

  oce$e_exchange_symbol_not_found = occ$rm_builder_base_exception +  15,
                                    {E Entry +P not found in symbol table.}

  oce$e_asid_already_assigned     = occ$rm_builder_base_exception +  16,
                                    {E Asid +P has already been assigned.}

  oce$e_page_table_retry_failed   = occ$rm_builder_base_exception +  17,
                                    {E Unable to make page table entry.}

  oce$e_invalid_define_seg_addr   = occ$rm_builder_base_exception +  18,
                                    {E Segment +P load_address less than load offset.}

  oce$e_duplicate_asid_specified  = occ$rm_builder_base_exception +  19,
                                    {E Asid +P was previously specified.}

  oce$e_page_table_overflow       = occ$rm_builder_base_exception +  20,
                                    {E Page Table overflow.}

  oce$e_invalid_ring1_ring2       = occ$rm_builder_base_exception +  21,
                                    {E Invalid ring bracket specified (+P,+P).}

  oce$e_invalid_file_name         = occ$rm_builder_base_exception +  22,
                                    {E Invalid file name +P specified.}

  oce$e_integer_not_power_of_two  = occ$rm_builder_base_exception +  23,
                                    {E +P must be a power of two.}

  oce$e_asid_wont_hash_in_pt      = occ$rm_builder_base_exception +  24,
                                    {E Unable to assign asid +P to page table.}

  oce$e_invalid_xp_seg_table_leng = occ$rm_builder_base_exception +  25,
                                    {E Exchange Package in segment +P contains invalid segment table length.}

  oce$e_invalid_load_file_version = occ$rm_builder_base_exception +  26,
                                    {E Load file +P contains invalid version number.}

  oce$w_real_memory_not_generated = occ$rm_builder_base_exception + 100,
                                    {W Exiting Real Memory Builder without executing GENERATE command.}

  oce$w_no_exchange_package       = occ$rm_builder_base_exception + 101,
                                    {W +P undefined and cannot be printed.}

  oce$w_invalid_display_mem_addr  = occ$rm_builder_base_exception + 102,
                                    {W Beginning display memory address is beyond end of real memory image.}

  occ$max_rm_builder_exception    = occ$rm_builder_base_exception + 199;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=OCE$VE_LINKER_EXCEPTIONS EXPAND=FALSE
*copyc occ$condition_limits
?? NEWTITLE := 'Virtual Environment Linker : ''OC'' 500 .. 699', EJECT ??
?? FMT (FORMAT := OFF) ??

CONST
  occ$ve_linker_base_exception    = occ$min_ecc + 500,



  oce$e_global_local_key_mismatch = occ$ve_linker_base_exception +   0,
  {E Non master key-locks +P and +P must be equal.}

  oce$e_storage_allocation_failed = occ$ve_linker_base_exception +   1,
  {E Internal storage allocation failed - +P.}

  oce$e_file_is_not_library       = occ$ve_linker_base_exception +   2,
  {E File +F is not a library.}

  oce$e_file_is_not_symbol_table  = occ$ve_linker_base_exception +   3,
  {E File +F does not contain a symbol table.}

  oce$e_invalid_ring_bracket      = occ$ve_linker_base_exception +   4,
  {E Invalid ring brackets specified +P, +P, and +P.}

  oce$e_duplicate_module_named    = occ$ve_linker_base_exception +   5,
  {E Duplicate module +P specified.}

  oce$e_duplicate_file_named      = occ$ve_linker_base_exception +   6,
  {E Duplicate file +F specified.}

  oce$e_seg_attribute_conflict    = occ$ve_linker_base_exception +   7,
  {E Segment attribute conflict - +P specified.}

  oce$e_duplicate_segment_named   = occ$ve_linker_base_exception +   8,
  {E Duplicate segment number +P specified.}

  oce$e_duplicate_section_named   = occ$ve_linker_base_exception +   9,
  {E Duplicate section name +P specified.}

  oce$e_duplicate_section_attr    = occ$ve_linker_base_exception +  10,
  {E Sections +P and +P have duplicate attributes specified.}

  oce$e_segment_number_overflow   = occ$ve_linker_base_exception +  11,
  {E Segment number overflow.}

  oce$e_invalid_lst_version       = occ$ve_linker_base_exception +  12,
  {E Invalid symbol table version on file +F.}

  oce$e_bad_obj_text_on_file      = occ$ve_linker_base_exception +  13,
  {E Bad object text on file +P - +P.}

  oce$e_bad_obj_text_in_module    = occ$ve_linker_base_exception +  14,
  {E Bad object text in module +P, at record +P - +P.}

  oce$e_starting_proc_not_found   = occ$ve_linker_base_exception +  15,
  {E Starting procedure +P not found.}

  oce$e_linked_symbols_not_gate   = occ$ve_linker_base_exception +  16,
  {E GATE_RING_LEVEL can only be specified when LINKED_SYMBOLS is GATE.}

  oce$e_section_segment_together = occ$ve_linker_base_exception +  17,
  {E Both SECTION and SEGMENT_NUMBER specified.}

  oce$e_missing_section_segment   = occ$ve_linker_base_exception +  18,
  {E SECTION or SEGMENT_NUMBER must be specified.}

  oce$e_section_or_seg_not_found  = occ$ve_linker_base_exception +  19,
  {E SECTION or SEGMENT not found for pointer +P.}

  oce$deferred_entry_pt_not_found = occ$ve_linker_base_exception +  20,
  {W Entry Point +P specified on the defer_entry_points parameter was
  { not found.}

  oce$deferred_com_blk_not_found = occ$ve_linker_base_exception +  21,
  {W Common Block +P specified on the defer_common_blocks parameter was
  { not found.}

  oce$cannot_defer_unalloc_common = occ$ve_linker_base_exception +  22,
  {W Common Block +P was not deferred because it is unallocated common.}

  oce$w_module_not_included       = occ$ve_linker_base_exception + 100,
  {W Module +P not included in link.}

  oce$w_unsatisfied_module        = occ$ve_linker_base_exception + 101,
  {W Unsatisfied reference to module +P.}

  oce$w_unsatisfied_external      = occ$ve_linker_base_exception + 102,
  {W Unsatisfied reference to external +P.}

  oce$w_no_modules_on_file        = occ$ve_linker_base_exception + 103,
  {W No modules on file +F.}

  oce$w_required_library_missing  = occ$ve_linker_base_exception + 104,
  {W Required library +P missing.}

  oce$w_data_in_binding           = occ$ve_linker_base_exception + 105,
  {W Attempted to place data in module +P's binding section.}

  oce$w_conflicting_common_attr   = occ$ve_linker_base_exception + 106,
  {W Conflicting attributes for common block +P on module +P.}

  oce$w_conflicting_common_lngth  = occ$ve_linker_base_exception + 107,
  {W Conflicting lengths for common block +P on module +P.}

  oce$w_duplicate_entry_points    = occ$ve_linker_base_exception + 108,
  {W Duplicate entry point +P encountered.}

  oce$f_ext_param_verification    = occ$ve_linker_base_exception + 109,
  {F Parameter verification error on external +P1}
  { referenced by module +P2, using object text checking.}

  oce$w_no_starting_procedure     = occ$ve_linker_base_exception + 110,
  {W No starting procedure encountered.}

  oce$w_ring_violation            = occ$ve_linker_base_exception + 111,
  {W Possible ring violation with external +P.}

  oce$w_empty_symbol_table        = occ$ve_linker_base_exception + 112,
  {W Empty symbol table +P.}

  oce$w_generator_not_executed    = occ$ve_linker_base_exception + 113,
  {W Exiting VE Linker without executing the GENERATE command.}

  oce$e_symbol_table_not_defined  = occ$ve_linker_base_exception + 114,
  {E Symbol table +F has not been referenced by a USE_SYMBOL_TABLE command.}

  oce$e_seg_not_defined_for_sect  = occ$ve_linker_base_exception + 115,
  {E Section +P1 was not specified in the section_names parameter}
  { of a DEFINE_SEGMENT subcommand.}

  oce$i_generate_status           = occ$ve_linker_base_exception + 175,
  {I +P.}

  oce$w_generate_status           = occ$ve_linker_base_exception + 176,
  {W +P.}

  oce$e_generate_status           = occ$ve_linker_base_exception + 177,
  {E +P.}

  oce$e_invalid_debug_tbl_version = occ$ve_linker_base_exception + 178,
  {E Invalid debug table version on file +F.}

  oce$w_ext_param_verification    = occ$ve_linker_base_exception + 179,
  {W Parameter verification on external +P referenced by module +P,}
  { using source text checking.}

  oce$w_build_level_not_specified = occ$ve_linker_base_exception + 180,
  {W No build level has been specified for initialization.}

  oce$e_add_undefined_68000_seq   = occ$ve_linker_base_exception + 185,
  {E Add undefined 68000 seq.}

  oce$e_sec_overflow_in_segment   = occ$ve_linker_base_exception + 187,
  {E Segment +P overflow.}

  oce$e_eof_on_debug_file         = occ$ve_linker_base_exception + 188,
  {E Premature end of file on +P.}

  oce$e_debug_table_not_open      = occ$ve_linker_base_exception + 189,
  {E A debug table must be specified before it's used.}

  oce$e_module_item_not_found     = occ$ve_linker_base_exception + 190,
  {E Module +P not found.}

  oce$e_address_not_found         = occ$ve_linker_base_exception + 191,
  {E Address +P +P not found.}

  oce$e_entry_point_not_found     = occ$ve_linker_base_exception + 192,
  {E Entry point +P not found.}

  oce$e_invalid_address_specified = occ$ve_linker_base_exception + 193,
  {E Invalid address +P +P specified.}

  oce$e_segment_number_underflow  = occ$ve_linker_base_exception + 194,
  {E Segment less than minimum pre-linked segment.}

  oce$w_module_compiled_opt_debug = occ$ve_linker_base_exception + 195,
  {E Module +P compiled with OPT=DEBUG - System may abort.}

  oce$w_default_heap_in_system    = occ$ve_linker_base_exception + 196,
  {E Module +P contains an ALLOCATE or FREE which didn't specify a system}
  { heap.}

  occ$max_ve_linker_exception     = occ$ve_linker_base_exception + 199;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=OCH$ADD_MODULE_PREDICTOR EXPAND=FALSE
{}
{   The purpose of this request is to add a single module predictor to the
{ predictor sequence.
{}
{       OCP$ADD_MODULE_PREDICTOR (SINGLE_MOD_PRED, SIZE_OF_SINGLE_MODULE_PREDICTOR,
{         PREDICTOR, SIZE_OF_PREDICTOR, FIRST_MODULE_PREDICTOR)
{}
{ SINGLE_MOD_PRED: (input) This parameter specifies a pointer to the single
{       module predictor.
{}
{ SIZE_OF_SINGLE_MODULE_PREDICTOR: (input) This parameter specifies the size
{       of the single module predictor in bytes.
{}
{ PREDICTOR: (input - output) This parameter specifies a pointer to the predictor.
{}
{ SIZE_OF_PREDICTOR: (input - output) This parameter specifies the current size
{       of the predictor in bytes.
{}
{ FIRST_MODULE_PREDICTOR: (output) This parameter specifies a pointer to the first
{       single module predictor in the predictor.
{}
*DECK DECK=OCH$ADJUST_ALLOTTED_SECTIONS EXPAND=FALSE
{}
{    The purpose of this request is to apply the module_dicitonary offset change
{ vector to the pointer to the allotted sections.
{}
{        OCP$ADJUST_ALLOTTED_SECTIONS (MOD_DICTIONARY_OCV, SECTION_DEFS, INT_OL)
{}
{ MOD_DICTIONARY_OCV: (input) This parameter specifies the module dictionary offset
{        change vector.
{}
{ SECTION_DEFS: (input) This parameter spceifies a pointer to the first section
{        definition.
{}
{ INT_OL: (input) This parameter specifies a pointer to the intermediate object library.
{}
*DECK DECK=OCH$APPLY_CORRECTOR EXPAND=FALSE
{}
{    The purpose of this request is to apply the corrector items to the
{ second intermediate object library to create the final result object library.
{}
{        OCP$APPLY_CORRECTOR (CORRECTOR, INT_OL, RESULT)
{}
{ CORRECTOR: (input) This parameter specifies the corrector, which contains
{        records specifying which bytes to delete and insert in order to
{        transform the second intermediate object library into the final
{        version.
{}
{ INT_OL: (input) This parameter specifies a pointer to the second
{        intermediate object library.
{}
{ RESULT: (input - output) This parameter specifies a pointer to the
{        final corrected version of the object library.
{}
*DECK DECK=OCH$APPLY_MESSAGE_PREDICTOR EXPAND=FALSE
{
{    The purpose of this request is to apply a message predictor to a message
{ module.
{
{       OCP$APPLY_MESSAGE_PREDICTOR (P_MODULE_PREDICTOR, MODULE_DICTIONARY,
{             P_INT_OL)
{
{ P_MODULE_PREDICTOR: (input)  This parameter specifies a pointer to the
{       message module predictor.
{
{ MODULE_DICTIONARY: (input)  This parameter spceifies a pointer to the module
{       dictionary.
{
{ P_INT_OL: (input)  This parameter specifies a pointer to the intermediate
{       object library.
{
*DECK DECK=OCH$APPLY_MODULE_PREDICTORS EXPAND=FALSE
{}
{    The purpose of this request is to call procedures to apply the module
{ predictors to the B0 instructions, the interpretive element, information
{ element, and the message modules.
{}
{        OCP$APPLY_MODULE_PREDICTORS (PREDICTOR, FIRST_INTERMEDIATE_OL)
{}
{ PREDICTOR: (input) This parameter specifies the predictor, which contains
{        offset changes to be used in updating object library offsets.
{}
{ FIRST_INTERMEDIATE_OL: (input) This parameter specifies a pointer to the first
{        intermediate object library.
{}
*DECK DECK=OCH$APPLY_MOVE_ITEMS EXPAND=FALSE
{}
{    The purpose of this request is reorder the object library according to
{ offsets specified by the move items.
{}
{        OCP$APPLY_MOVE_ITEMS (FIRST_INTERMEDIATE_OL, MOVE_ITEMS,
{          NUMBER_OF_MOVE_ITEMS, SECOND_INTERMEDIATE_OL)
{}
{ FIRST_INTERMEDIATE_OL: (input) This parameter specifies the first intermediate
{        object library.
{}
{ MOVE_ITEMS: (input) This parameter specifies the move items which contain information
{        about where blocks of data from the first intermediate object library should
{        be copied into the second intermediate object library.
{}
{ NUMBER_OF_MOVE_ITMES: (input) This parameter specifies the number of move items.
{}
{ SECOND_INTERMEDIATE_OL: (input) This parameter specifies a pointer to the second
{        intermediate object library.
{}
*DECK DECK=OCH$BUILD_ADR_BREAKLIST_ITEMS EXPAND=FALSE
*DECK DECK=OCH$BUILD_BINDING_SECTION_CV EXPAND=FALSE
{}
{   The purpose of this request is to build the binding section offset change vector.
{}
{       OCP$BUILD_BINDING_SECTION_CV (OLD_MODULE_HEADER, NEW_MODULE_HEADER,
{         SECTION_DIRECTORY, OLD_OL, NEW_OL, BINDING_SECTION_OFFSET_CV)
{}
{ OLD_MODULE_HEADER: (input) This parameter specifies a load module header
{       in the old object library.
{}
{ NEW_MODULE_HEADER: (input) This parameter specifies a load module header
{       in the new object library.
{}
{ SECTION_DIRECTORY: (input) This parameter specifies a pointer to a directory
{       containing section ordinal changes and pointers to normal section offset
{       change vectors.
{}
{ OLD_OL: (input - output) This parameter specifies a pointer to the old object library.
{}
{ NEW_OL: (input - output) This parameter specifies a pointer to the new object library.
{}
{ BINDING_SECTION_OFFSET_CV: (output) This parameter specifies a pointer to the binding
{       section offset change vector.
{}
*DECK DECK=OCH$BUILD_CODE_SEC_DIRECTORY EXPAND=FALSE
{}
{   The purpose of this request is to build a directory containing
{ the code section ordinals and pointers to the beginining of the
{ code sections for each module in the object library.
{}
{       OCP$BUILD_CODE_SEC_DIRECTORY (OBJECT_LIBRARY, CODE_SECTION_DIRECTORY,
{         MODULE_CODE_SECTIONS)
{}
{ OBJECT_LIBRARY: (input) This parameter specifies a pointer to the
{       object_library.
{}
{ CODE_SECTION_DIRECTORY: (output) This parameter specifies an array with
{       an entry for each module pointing into the code section directory.
{}
{ MODULE_CODE_SECTIONS: (output) This parameter specifies the section ordinal
{       and a pointer to the beginning of the code section for each code
{       section in a module.
{}
*DECK DECK=OCH$BUILD_COMPONENT_INDEX_CV EXPAND=FALSE
{}
{    The purpose of this request is build a component index change vector.
{}
{        OCH$BUILD_COMPONENT_INDEX_CV (OLD_MODULE_HEADER, NEW_MODULE_HEADER,
{          OLD_OL, NEW_OL, LENGTH_COMPONENT_INDEX_CV, COMPONENT_INDEX_CV,
{          STATUS)
{}
{ OLD_MODULE_HEADER: (input) This parameter specifies a load module header in
{        the old object library.
{}
{ NEW_MODULE_HEADER: (input) This parameter specifies a load module header in
{        the new object library.
{}
{ OLD_OL: (input) This parameter specifies a pointer to the old object library.
{}
{ NEW_OL: (input) This parameter specifies a pointer to the new object library.
{}
{ LENGTH_COMPONENT_INDEX_CV: (output) This parameter specifies the length of the
{        component index change vector.
{}
{ COMPONENT_INDEX_CV: (output) This parameter specifies the changes in the
{        component indices between the two object libraries.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}
*DECK DECK=OCH$BUILD_CORRECTOR EXPAND=FALSE
{}
{    The purpose of this request is to build the corrector by comparing the
{ second intermediate object library and the new object library using the
{ breaklists.
{}
{        OCP$BUILD_CORRECTOR (OLD_BREAKLIST, NEW_BREAKLIST, SECOND_INTER_OL,
{          NEW_OL, LENGTH_OF_OLD_BREAKLIST, LENGTH_OF_NEW_BREAKLIST, CORRECTOR)
{}
{ OLD_BREAKLIST: (input) This parameter specifies the breaklist generated for
{        the old object library.
{}
{ NEW_BREAKLIST: (input) This parameter specifies the breaklist generated for
{        the new object library.
{}
{ SECOND_INTER_OL: (input) This parameter specifies the second intermediate
{        object library.
{}
{ NEW_OL: (input) This parameter specifies the new object library.
{}
{ LENGTH_OF_OLD_BREAKLIST: (input) This parameter specifies the length of the
{        old breaklist.
{}
{ LENGTH_OF_NEW_BREAKLIST: (input) This parameter specifies the length of the
{        new breaklist.
{}
{ COMPRESSED_CORRECTOR: (output) This parameter specifies the corrector, which
{        contains information to transform the second intermediate object
{        library to the final updated form.
{}

*DECK DECK=OCH$BUILD_CORRECTOR_ITEM EXPAND=FALSE
*DECK DECK=OCH$BUILD_FIRST_INTERMEDIATE_OL EXPAND=FALSE
{}
{    The purpose of this request is to build the first intermediate object library
{ with the old version of the object library and the predictor.
{}
{        OCP$BUILD_FIRST_INTERMEDIATE_OL (PREDICTOR, OLD_OL, FIRST_INTERMEDIATE_OL)
{}
{ PREDICTOR: (INPUT) This parameter specifies the predictor, which contains the
{        section number, section offset, and global offset change vectors.
{}
{ OLD_OL: (input) This parameter specifies a pointer to the old object library.
{}
{ FIRST_INTERMEDIATE_OL: (output) This parameter specifies a pointer to the
{        first intermediate object library, which is the old object library
{        with offsets and section ordinals updated by the predictor.
{}
*DECK DECK=OCH$BUILD_GLOBAL_OFFSET_CV EXPAND=FALSE
{}
{   The purpose of this request is to build the global offset change vector.
{}
{       OCP$BUILD_GLOBAL_OFFSET_CV (MODULE_DIRECTORY, OLD_MODULE_DICTIONARY,
{         NEW_MODULE_DICTIONARY, OLD_OL, NEW_OL, PREDICTOR, SIZE_OF_PREDICTOR,
{         GLOBAL_OFFSET_PREDICTOR, GOCV_GENERATED)
{}
{ MODULE_DIRECTORY: (input) This paramter specifies corresponding modules in
{       the two object libraries.
{}
{ OLD_MODULE_DICTIONARY: (input) This parameter specifies a module_dictionary in
{       the old object library.
{}
{ NEW_MODULE_DICTIONARY: (input) This paramter specifies a module dictionary
{       in the new object library.
{}
{ OLD_OL: (input - output) This parameter specifies a pointer to the old
{       object library.
{}
{ NEW_OL: (input - output) This parameter specifies a pointer to the new
{       object library.
{}
{ PREDICTOR: (input - output) This paramter specifies a pointer to the predictor.
{}
{ SIZE_OF_PREDICTOR: (input_output) This paramter specifies the current size
{       of the predictor in bytes.
{}
{ GLOBAL_OFFSET_PREDICTOR: (output) This parameter specifies a pointer to the
{       global offset change vector in the predictor.
{}
{ GOCV_GENERATED: (output) This paramter specifies whether or not the global
{       offset change vector was generated.
{}
*DECK DECK=OCH$BUILD_LOAD_MODULE_BREAKLIST EXPAND=FALSE
*DECK DECK=OCH$BUILD_LOAD_MODULE_PREDICTOR EXPAND=FALSE
{}
{    The purpose of this request is build a module predictor for a load
{ module.
{}
{        OCP$BUILD_LOAD_MODULE_PREDICTOR (OLD_MODULE_HEADER, NEW_MODULE_HEADER,
{          MODULE_NAME, OLD_OL, NEW_OL, SINGLE_PREDICTOR, SINGLE_PREDICTOR_SIZE,
{          MODULE_DIRECTORY_ITEM)
{}
{ OLD_MODULE_HEADER: (input) This parameter specifies a load module header in
{        the old object library.
{}
{ NEW_MODULE_HEADER: (input) This parameter specifies a load module header in
{        the new object library.
{}
{ MODULE_NAME: (input) This parameter specifies the name of the module.
{}
{ OLD_OL: (input) This parameter specifies a pointer to the old object library.
{}
{ NEW_OL: (input) This parameter specifies a pointer to the new object library.
{}
{ SINGLE_PREDICTOR: (output) This parameter specifies the module predictor.
{}
{ SINGLE_PREDICTOR_SIZE: (output) This parameter specifies the size of the module
{        predictor.
{}
{ MODULE_DIRECTORY_ITEM: (output) This parameter specifies a pointer to the
{        section number change list for the module.
{}
*DECK DECK=OCH$BUILD_MESSAGE_PREDICTOR EXPAND=FALSE
{}
{    The purpose of this request is build a module predictor for a
{ message module.
{}
{        OCP$BUILD_MESSAGE_PREDICTOR (OLD_MESSAGE_HEADER, NEW_MESSAGE_HEADER,
{          MODULE_NAME, OLD_OL, NEW_OL, SINGLE_PREDICTOR, SINGLE_PREDICTOR_SIZE)
{}
{ OLD_MESSAGE_HEADER: (input) This parameter specifies a message module header
{        in the old object library.
{}
{ NEW_MESSAGE_HEADER: (input) This parameter specifies a message module header
{        in the new object library.
{}
{ MODULE_NAME: (input) This parameter specifies the name of the module.
{}
{ OLD_OL: (input) This parameter specifies the old object_library.
{}
{ NEW_OL: (input) This parameter specifies the new object_library.
{}
{ SINGLE_PREDICTOR: (output) This parameter specifies the module predictor.
{}
{ SINGLE_PREDICTOR_SIZE: (output) This parameter specifies the size of the
{        predictor in bytes.
{}
*DECK DECK=OCH$BUILD_MODULE_MAP EXPAND=FALSE
*DECK DECK=OCH$BUILD_MODULE_PREDICTOR EXPAND=FALSE
{}
{   The purpose of this request is to calculate differences in section ordinals,
{ normal sections and the binding section for a module.
{}
{       OCP$BUILD_MODULE_PREDICTOR (OLD_MODULE_DICTIONARY_ITEM,
{         NEW_MODULE_DICTIONARY_ITEM, OLD_OL, NEW_OL, SINGLE_MOD_PRED,
{         SIZE_OF_SINGLE_MODULE_PREDICTOR, MODULE_DIRECTORY)
{}
{ OLD_MODULE_DICTIONARY_ITEM: (input) This parameter specifies one module
{       dictionary in the old version of the object library.
{}
{ NEW_MODULE_DICTIONARY_ITEM: (input) This parameter specifies one module
{       dictionary in the new version of the object library.
{}
{ OLD_OL: (input-output) This parameter specifies a pointer to the old object library.
{}
{ NEW_OL: (input-output) This parameter specifies a pointer to the new object library.
{}
{ SINGLE_MOD_PRED: (input_output) This parameter specifies a pointer to a
{       single module predictor.
{}
{ SIZE_OF_SINGLE_MODULE_PREDICTOR: (output) This parameter specifies the size
{       of the single module predictor in bytes.
{}
{ MODULE_DIRECTORY: (output) This parameter specifies corresponding modules
{       between two object libraries, section number changes and pointers to the
{       section offset change vectors.
{}
*DECK DECK=OCH$BUILD_MODULE_PREDICTORS EXPAND=FALSE
{}
{   The purpose of this request is to build a sequence of module predictors
{ which contain changes in section numbers, section offsets, and binding
{ section offsets.
{}
{       OCP$BUILD_MODULE_PREDICTORS (OLD_OL, NEW_OL, OLD_MODULE_DICTIONARY,
{         NEW_MODULE_DICTIONARY, MODULE_DIRECTORY, PREDICTOR)
{}
{ OLD_OL: (input-output) This parameter specifies a pointer to the old object library.
{}
{ NEW_OL: (input-output) This parameter specifies a pointer to the new object library.
{}
{ OLD_MODULE_DICTIONARY: (input) This parameter specifies a pointer to the old
{       object library module dictionary.
{}
{ NEW_MODULE_DICTIONARY: (input) This parameter specifies a pointer to the new
{       object library module dictionary.
{}
{ MODULE_DIRECTORY: (input - output) This parameter specifies corresponding modules in
{      the two object libraries.
{}
{ PREDICTOR: (input - output) This parameter specifies a pointer to the predictor.
{}
*DECK DECK=OCH$BUILD_MOD_DICTIONARY_OCV EXPAND=FALSE
{}
{    The purpose of this request is to build an offset change vector using
{ the module dicitonary.
{}
{        OCP$BUILD_MOD_DICTIONARY_OCV (MODULE_DIRECTORY, OLD_MODULE_DICTIONARY,
{          NEW_MODULE_DICTIONARY, OLD_OL, NEW_OL, PREDICTOR)
{}
{ MODULE_DIRECTORY: (input) This parameter specifies corresponding modules
{        in the two object libraries.
{}
{ OLD_MODULE_DICTIONARY: (input) This parameter specifies the module dictionary
{        in the old object library.
{}
{ NEW_MODULE_DICTIONARY: (input) This parameter specifies the module dictionary
{        in the new object library.
{}
{ OLD_OL: (input - output) This parameter specifies a pointer to the old object library.
{}
{ NEW_OL: (input - output) This parameter specifies a pointer to the new object library.
{}
{ PREDICTOR: (input - output) This parameter specifies a pointer to the predictor.
{}
*DECK DECK=OCH$BUILD_MOVE_ITEMS EXPAND=FALSE
{}
{    The purpose of this request is to build the move items. Move items
{ specify boundaries within the object library as blocks that are later
{ reordered.
{}
{        OCP$BUILD_MOVE_ITEMS (NEW_ARRAY, NEW_BREAKLIST, NUMBER_OF_NEW_BREAKLIST_ITEMS,
{          OLD_ARRAY, OLD_BREAKLIST, NUMBER_OF_OLD_BREAKLIST_ITEMS, MOVE_ITEMS,
{          NUMBER_OF_MOVE_ITEMS)
{}
{ NEW_ARRAY: (input) This parameter specifies the new object library array
{        which contains an entry for each breaklist item in the new breaklist
{        and a pointer into either the old_array or the symbol_table.
{}
{ NEW_BREAKLIST: (input) This parameter specifies the breaklist generated for
{        the new object library.
{}
{ NUMBER_OF_NEW_BREAKLIST_ITEMS: (input) This parameter specifies the number
{        of items in the new breaklist.
{}
{ OLD_ARRAY: (input) This parameter specifies the old object library array
{        which contains an entry for each breaklist item in the old breaklist
{        and a pointer into either the new_array or the symbol_table.
{}
{ OLD_BREAKLIST: (input) This parameter specifies the breaklist generated for
{        the old object library.
{}
{ NUMBER_OF_OLD_BREAKLIST_ITEMS: (input) This parameter specifies the number
{        of items in the old breaklist.
{}
{ MOVE_ITEMS: (output) This parameter specifies the move items.
{}
{ NUMBER_OF_MOVE_ITEMS: (output) This parameter specifies the number of move items.
{}

*DECK DECK=OCH$BUILD_NORMAL_OFFSET_CV EXPAND=FALSE
{}
{   The purpose of this request is to calculate the differences in the
{ normal section offsets.
{}
{       OCP$BUILD_NORMAL_OFFSET_CV (OLD_MODULE_HEADER, NEW_MODULE_HEADER,
{         OLD_OL, NEW_OL, NORMAL_SOCV, SECTION_DIRECTORY, NUMBER_SECTION_OFFSET_CVS)
{}
{ OLD_MODULE_HEADER: (input) This parameter specifies one load module
{       header in the old object library.
{}
{ NEW_MODULE_HEADER: (input) This parameter specifies one load module
{       header in the new object library.
{}
{ OLD_OL: (input) This parameter specifies a pointer to the old object library.
{}
{ NEW_OL: (input) This parameter specifies a pointer to the new object library.
{}
{ NORMAL_SOCV: (input - output) This parameter specifies a pointer to the
{       normal section offset change vector.
{}
{ SECTION_DIRECTORY: (input - output) This parameter specifies differences in
{       section ordinals and pointers to the section offset change vectors.
{}
{ NUMBER_SECTION_OFFSET_CVS: (output) This parameter specifies the number of
{       normal section offset change vectors generated.
{}
*DECK DECK=OCH$BUILD_OL_DICTIONARY_OCV EXPAND=FALSE
{}
{    The purpose of this request is to build an offset change vector using
{ the object library dictionary.
{}
{        OCP$BUILD_OL_DICTIONARY_OCV (OLD_OL, NEW_OL, PREDICTOR)
{}
{ OLD_OL: (input) This parameter specifies a pointer to the old object library.
{}
{ NEW_OL: (input) This parameter specifies a pointer to the new object library.
{}
{ PREDICTOR: (output) This parameter specifies a pointer to the predictor.
{}
*DECK DECK=OCH$BUILD_SECOND_INTER_OL EXPAND=FALSE
{}
{    The purpose of this request is to build the second intermediate object
{ library which is the first intermediate object library reordered.  The
{ reordering is done using the move items which are built here.
{}
{        OCP$BUILD_SECOND_INTER_OL (FIRST_INTERMEDIATE_OL, NEW_BREAKLIST,
{          LENGTH_OF_NEW_BREAKLIST, OLD_BREAKLIST, LENGTH_OF_OLD_BREAKLIST,
{          SECOND_INTERMEDIATE_OL, MOVE_ITEMS, NUMBER_OF_MOVE_ITEMS)
{}
{ FIRST_INTERMEDIATE_OL: (input) This parameter specifies the first intermediate
{        object library which is the old object library updated with the
{        predictor.
{}
{ NEW_BREAKLIST: (input) This parameter specifies the breaklist generated for
{        the new object library.
{}
{ LENGTH_OF_NEW_BREAKLIST: (input) This parameter specifies the number of items
{        in the new breaklist.
{}
{ OLD_BREAKLIST: (input - output) This parameter specifies the breaklist
{        generated for the old object library.
{}
{ LENGTH_OF_OLD_BREAKLIST: (input - output) This parameter specifies the number
{        of items in the old breaklist.
{}
{ SECOND_INTERMEDAITE_OL: (output) This parameter specifies the second intermediate
{        object library.
{}
{ MOVE_ITEMS: (output) This parameter specifies the move items which contain
{        information about blocks in the object library to be moved.
{}
{ NUMBER_OF_MOVE_ITEMS: (output) This parameter specifies the number of move
{        items generated.
{}


*DECK DECK=OCH$BUILD_SECTION_DIRECTORY EXPAND=FALSE
{}
{    The purpose of this request is to build the section directory which contains
{ the section number change vector and a pointer to the section offset change vector.
{}
{        OCP$BUILD_SECTION_DIRECTORY (MODULE_PREDICTOR, MODULE_HEADER, OBJECT_LIBRARY,
{          SECTION_DIRECTORY)
{}
{ MODULE_PREDICTOR: (input) This parameter specifies a pointer to a single module
{        predictor.
{}
{ MODULE_HEADER: (input) This parameter specifies a pointer to the load module header.
{}
{ OBJECT_LIBRARY: (input) This parameter specifies a pointer to the object library.
{}
{ SECTION_DIRECTORY: (output) This parameter specifies the section directory.
{}
*DECK DECK=OCH$BUILD_SECTION_NUMBER_CV EXPAND=FALSE
{}
{   The purpose of this request is to calculate the changes in the section ordinals.
{}
{       OCP$BUILD_SECTION_NUMBER_CV (OLD_MODULE_HEADER, NEW_MODULE_HEADER,
{         OLD_OL, NEW_OL, SECTION_NUMBER_CV, MODULE_IS_BOUND, SECTION_DIRECTORY)
{}
{ OLD_MODULE_HEADER: (input) This parameter specifies one load module header
{       in the old version of the object library.
{}
{ NEW_MODULE_HEADER: (input) This parameter specifies one load module header
{       in the new version of the object library.
{}
{ OLD_OL: (input) This parameter specifies a pointer to the old object library.
{}
{ NEW_OL: (input) This parameter specifies a pointer to the new object library.
{}
{ SECTION_NUMBER_CV: (output) This parameter specifies the section number
{       change vector.
{}
{ MODULE_IS_BOUND: (output) This parameter specifies whether the module is
{       bound or not.
{}
{ SECTION_DIRECTORY: (output) This parameter specifies the section number
{       change vector.
{}
*DECK DECK=OCH$BUILD_SECTION_OCV EXPAND=FALSE
{}
{   The purpose of this request is to build the normal section offset change vectors.
{}
{       OCP$BUILD_SECTION_OCV (OLD_SECTION_MAP, NEW_SECTION_MAP, SECTION_ORDINAL,
{         OLD_SECTION_DEFINITIONS, OLD_OBJECT_LIBRARY, NORMAL_SOCV, SECTION_OFFSET_CV,
{         SOCV_GENERATED)
{}
{ OLD_SECTION_MAP: (input) This parameter specifies a pointer to a particular
{       sections section map in the old object library.
{}
{ NEW_SECTION_MAP: (input) This parameter specifies a pointer to a particular
{       sections section map in the new object library.
{}
{ SECTION_ORDINAL: (input) This parameter specifies the section ordinal.
{}
{ OLD_SECTION_DEFINITIONS: (input) This parameter specifies a pointer to the
{       section definitions in the old object library.
{}
{ OLD_OBJECT_LIBRARY: (input) This parameter specifies a pointer to the old
{       object_library.
{}
{ NORMAL_SOCV: (input - output) This parameter specifies a pointer to the normal
{       section offset change vectors.
{}
{ SECTION_OFFSET_CV: (output) This parameter specifies a pointer to the current
{       section offset change vector.
{}
{ SOCV_GENERATED: (output) This parameter specifies whether or not this section
{       offset change vector was generated.
{}
*DECK DECK=OCH$BUILD_SYMBOL_TABLE EXPAND=FALSE
{}
{    The purpose of this request is to build the symbol table by hashing each
{ breaklist item into it.  The symbol table will contain an entry for each
{ unique breaklist item in he old and new breaklists.
{}
{        OCP$BUILD_SYMBOL_TABLE (OLD_BREAKLIST, NEW_BREAKLIST,
{          NUMBER_OF_OLD_BREAKLIST_ITEMS, NUMBER_OF_NEW_BREAKLIST_ITEMS,
{          OLD_ARRAY, NEW_ARRAY, SYMBOL_TABLE)
{}
{ OLD_BREAKLIST: (input) This parameter specifies the breaklist generated for
{        the old object library.
{}
{ NEW_BREAKLIST: (input) This parameter specifies the breaklist generated for
{        the new object library.
{}
{ NUMBER_OF_OLD_BREAKLIST_ITEMS: (input) This parameter specifies the number of
{        items in old breaklist.
{}
{ NUMBER_OF_NEW_BREAKLIST_ITEMS: (input) This parameter specifies the number of
{        items in new breaklist.
{}
{ OLD_ARRAY: (output) This parameter specifies the array generated from the
{        old object library.  It contains a pointer into either the new array
{        or the symbol table.
{}
{ NEW_ARRAY: (output) This parameter specifies the array generated from the
{        new object library.  It contains a pointer into either the old array
{        or the symbol table.
{}
{ SYMBOL_TABLE: (output) This parameter specifies the symbol table which
{        contains an entry for each unique breaklist item in the old and
{        new breaklists, and the number of times that entry was encountered.
{}


*DECK DECK=OCH$BUILD_TEXT_BL_FOR_UNBOUND EXPAND=FALSE
*DECK DECK=OCH$BUILD_TEXT_BREAKLIST_ITEMS EXPAND=FALSE
*DECK DECK=OCH$CHECKSUM EXPAND=FALSE
{}
{    The purpose of this request is to build a thirty-two bit checksum of
{ the given sequence.
{}
{        OCP$CHECKSUM (SEQUENCE)
{}
{ SEQUENCE: (input) This parameter specifies a pointer to the sequnece
{        being checksummed.
{}
{ OCP$CHECKSUM: (output) This parameter specifies the thirty-two bit checksum
{        generated.
{}


*DECK DECK=OCH$COMPARE_LENGTH EXPAND=FALSE
{}
{    The purpose of this request is assign an appropriate length for the
{ number of bytes to compare and the maximum number of compares to make
{ in a breaklist item using the breaklist kind.
{}
{        OCP$COMPARE_LENGTH (BREAKLIST_KIND, LENGTH, MAX_TRIES)
{}
{ BREAKLIST_KIND: (input) This parameter specifies the breaklist kind.
{}
{ LENGTH: (output) This parameter specifies the length assigned.
{}
{ MAX_TRIES: (output) This parameter specifies the maximum number of compares
{       to make before going to the next byte.
{}
*DECK DECK=OCH$COMPRESS_CHANGE_VECTOR EXPAND=FALSE
{}
{    The purpose of this request is sort and compress an offset change vector.
{}
{        OCP$COMPRESS_CHANGE_VECTOR (CHANGE_VECTOR, CHANGE_LENGTH)
{}
{ CHANGE_VECTOR: (input - output) This parameter specifies an offset
{        change vector.
{}
{ CHANGE_LENGTH: (input - output) This parameter specifies the length
{        of the offset change vector.
{}
*DECK DECK=OCH$COMPRESS_CORRECTOR EXPAND=FALSE
*DECK DECK=OCH$CONSTRUCT_BREAKLIST EXPAND=FALSE
{}
{   The purpose of this request is to build breaklist items pointing
{ into the object library.  A breaklist item defines a location in the
{ object library.  Matching breaklist items in two object libraries
{ are used to do block moves.
{}
{       OCP$CONSTRUCT_BREAKLIST (OBJECT_LIBRARY, MODULE_DIRECTORY,
{         ORIGINAL_OBJECT_LIBRARY, INT_OL, BREAKLIST, NUMBER_OF_BREAKLIST_ITEMS,
{         STATUS)
{}
{ OBJECT_LIBRARY: (input) This parameter specifies a pointer to the
{       object_library.
{}
{ MODULE_DIRECTORY: (input) This parameter specifies a directory
{       containing the section number change vectors.
{}
{ ORIGINAL_OBJECT_LIBRARY: (input) This parameter specifies whether
{       or not the object library is the old version or the new version.
{       This information is used to determine whether or not section
{       ordinals in the breaklist will be updated.
{}
{ INT_OL: (input) This parameter specifies a pointer to the intermediate
{       object library.
{}
{ BREAKLIST: (output) This parameter specifies the breaklist items
{       pointing into the object_library.
{}
{ NUMBER_OF_BREAKLIST_ITEMS: (output) This parameter specifies the
{       number of breaklist items created.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}
*DECK DECK=OCH$CONSTRUCT_CODE_BREAKLIST EXPAND=FALSE
*DECK DECK=OCH$CONSTRUCT_DICTIONARY_BL EXPAND=FALSE
*DECK DECK=OCH$CONSTRUCT_INFORMATION_BL EXPAND=FALSE
*DECK DECK=OCH$CONSTRUCT_INTERPRETIVE_BL EXPAND=FALSE
*DECK DECK=OCH$CONSTRUCT_METAPATCH EXPAND=FALSE
{}
{    The purpose of this request is to build the "metapatch" which contains
{ the predictor, move_items, and the corrector.
{}
{        OCP$CONSTRUCT_METAPATCH (PREDICTOR, MOVE_ITEMS, NUMBER_OF_MOVE_ITEMS,
{          CORRECTOR, METAPATCH, LENGTH)
{}
{ PREDICTOR: (input) This parameter specifies a pointer to the sequence
{        containing the predictor.
{}
{ MOVE_ITEMS: (input) This parameter specifies the array of move_items.
{}
{ NUMBER_OF_MOVE_ITEMS: (input) This parameter specifies the number of move
{        items.
{}
{ CORRECTOR: (input) This parameter specifies a pointer to the sequence
{        containing the corrector.
{}
{ METAPATCH: (output) This parameter specifies a pointer to the sequence
{        containing all the information necessary for updating the object
{        library.  This information is the predictor, move_items, and the
{        corrector.
{}
{ LENGTH: (output) This parameter specifies the length in bytes of METAPATCH.
{}

*DECK DECK=OCH$CONSTRUCT_MODULE_PREDICTOR EXPAND=FALSE
{}
{   The purpose of this request is to construct the single module predictor
{ by setting up a header and putting the section number, normal section
{ offset and binding section offset change vectors together in the single
{ module predictor.
{}
{       OCP$CONSTRUCT_MODULE_PREDICTOR (MODULE_NAME, NUMBER_SECTION_OFFSET_CVS,
{         SECTION_NUMBER_CV, NORMAL_SOCV, BINDING_SECTION_OCV, SINGLE_PREDICTOR,
{         SIZE_OF_PREDICTOR)
{}
{ MODULE_NAME: (input) This parameter specifies the module name.
{}
{ NUMBER_SECTION_OFFSET_CVS: (input) This parameter specifies the number of
{       normal section offset change vectors generated.
{}
{ SECTION_NUNBER_CV: (input) This parameter specifies a pointer to the
{       section number change vector.
{}
{ NORMAL_SOCV: (input) This parameter specifies a pointer to the
{       normal section offset change vectors.
{}
{ BINDING_SECTION_OCV: (input) This parameter specifies a pointer to the
{       binding section offset change vector.
{}
{ SINGLE_PREDICTOR: (output) This parameter specifies a pointer to the
{       single module predictor.
{}
{ SIZE_OF_PREDICTOR: (output) This parameter specifies the size of the single
{       module predictor in bytes.
{}
*DECK DECK=OCH$CONSTRUCT_READ_BREAKLIST EXPAND=FALSE
*DECK DECK=OCH$COPY EXPAND=FALSE
{}
{    The purpose of this request is to copy the old object library to
{ another file and to inform memory manager that these libraries will be
{ accessed sequentially.
{}
{        OCP$COPY (OLD_OL, NEW_OL)
{}
{ OLD_OL: (input) This parameter specifies a pointer to the old object library.
{}
{ NEW_OL: (output) This parameter specifies a pointer to the new file containing
{       the object library.
{}
*DECK DECK=OCH$CORRECT_OBJECT_LIBRARY EXPAND=FALSE
{}
{   The purpose of this request is to build an upgraded version of
{ the object library using the old version and the correction.
{}
{      OCP$CORRECT_OBJECT_LIBRARY (BASE_FILE, TARGET_FILE, METAPATCH, STATUS)
{}
{ BASE_FILE: (input) This parameter specifies the file that contains the old
{       version of the object library.
{}
{ TARGET_FILE: (input) This parameter specifies the file that will contain the
{       new version of the object library.
{}
{ METAPATCH: (input) This parameter specifies a sequence containing information
{       to enable updating the old object library to the new one.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=OCH$CREATE_SECTION_LIST EXPAND=FALSE
{}
{   The purpose of this request is to build a section list, which is an
{ array with one entry for each section in the object library.
{}
{       OCH$CREATE_SECTION_LIST (SECTION_DEFINITIONS, SEG_P, SECTION_LIST)
{}
{ SECTION_DEFINITIONS: (input) This parameter specifies the address in
{       the object library where the section definitions begin.
{}
{ SEG_P: (input-output) This parameter specifies the sequence pointer to
{       the object library.
{}
{ SECTION_LIST: (output) This parameter specifies the section list.
{}
*DECK DECK=OCH$DETERMINE_IF_FILES_DIFFER EXPAND=FALSE
{}
{    The purpose of this request is to determine if the two object libraries
{ are different.
{}
{        OCP$DETERMINE_IF_FILES_DIFFER (OLD_OL, NEW_OL, FILES_DIFFER)
{}
{ OLD_OL: (input) This parameter specifies a pointer to the old object
{        library.
{}
{ NEW_OL: (input) This parameter specifies a pointer to the new object
{        library.
{}
{ FILES_DIFFER: (output) This parameter specifies whether or not the object
{        libraries differ.
{}


*DECK DECK=OCH$FIND_MATCH_BREAKLIST_ITEMS EXPAND=FALSE
{}
{    The purpose of this request is to find matches between items in the old
{ breaklist and items in the new breaklist.
{}
{        OCP$FIND_MATCH_BREAKLIST_ITEMS (OLD_BREAKLIST, NEW_BREAKLIST, OLD_ARRAY,
{          NEW_ARRAY, SYMBOL_TABLE)
{}
{ OLD_BREAKLIST: (input) This parameter specifies the breaklist generated for
{         the old object library.
{}
{ NEW_BREAKLIST: (input) This parameter specifies the breaklist generated for
{         the new object_library.
{}
{ OLD_ARRAY: (input - output) This parameter specifies the array generated
{        from the old breaklist.  It contains a pointer to a matching item
{        in new_array if one exists, otherwise it points to its entry in the
{        symbol_table.
{}
{ NEW_ARRAY: (input - output) This parameter specifies the array generated
{        from the new breaklist.  It contains a pointer to a matching item
{        in old_array if one exists, otherwise it points to its entry in the
{        symbol_table.
{}
{ SYMBOL_TABLE: (input - output) This parameter specifies a table containing
{        one entry for each unique breaklist item in the old and new arrays.
{}

*DECK DECK=OCH$FIND_TEXT_RECORDS EXPAND=FALSE
*DECK DECK=OCH$GENERATE_METAPATCH EXPAND=FALSE
{}
{    The purpose of this request is to build an object library correction
{ by comparing the old and new object libraries and generating a package by
{ which the old object library can be transformed into the new object library.
{}
{        OCP$GENERATE_METAPATCH (OLD_FILE_NAME, NEW_FILE_NAME, METATPATCH,
{          SIZE, STATUS);
{}
{ OLD_FILE_NAME: (input) This parameter specifies the local file name of
{       the old version of the object library.
{}
{ NEW_FILE_NAME: (input) This parameter specifies the loacl file name of
{       the new version of the object library.
{}
{ METAPATCH: (output) This parameter specifies a pointer to the sequence
{       containing the correction.
{}
{ SIZE: (output) This parameter specifies the size of METAPATCH in bytes.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=OCH$GENERATE_OL_CORRECTIONS EXPAND=FALSE
{}
{    The purpose of this request is to geenrate the object library
{ corrections.
{}
{        OCP$GENERATE_OL_CORRECTIONS (PARAMETER_LIST, CORRECTION_FILE_NAME)
{}
{ PARAMETER_LIST: (input) This parameter specifies the parameter list which
{        contains the file names of the old and new object libraries.
{}
{ CORRECTION_FILE_NAME: (INPUT) This parameter specifies the name of the
{        correction file.
{}


*DECK DECK=OCH$GENERATE_OL_PREDICTOR EXPAND=FALSE
{}
{   The purpose of this request is to calculate changes in sections and offsets
{ and use this information to create the first intermediate object library.
{}
{      OCP$GENERATE_OL_PREDICTOR (OLD_OL, NEW_OL, PREDICTOR, MODULE_DIRECTORY)
{}
{ OLD_OL: (input - output) This parameter specifies a pointer to the old
{       object library.
{}
{ NEW_OL: (input - output) This parameter specifies a pointer to the new
{       object library.
{}
{ PREDICTOR: (output) This parameter specifies the sequence that contains
{       change information for each module.
{}
{ MODULE_DIRECTORY: (output) This parameter specifies a directory of cor-
{       responding modules and their section change vectors.
{}

*DECK DECK=OCH$GEN_CORRECTIONS_FOR_LIBRARY EXPAND=FALSE
{}
{    The purpose of this request is to generate corrections for object
{ libraries.
{}
{        OCP$GEN_CORRECTIONS_FOR_LIBRARY (OLD_FILE_NAME, NEW_FILE_NAME,
{          METAPATCH)
{}
{ OLD_FILE_NAME: (input) This parameter specifies the file name of the old
{        object library.
{}
{ NEW_FILE_NAME: (input) This parameter specifies the file name of the new
{        object library.
{}
{ METAPATCH: (output) This parameter specifies a pointer to the sequence
{        containing corrections to an object library.
{}

*DECK DECK=OCH$GET_NEW_Q_FIELD EXPAND=FALSE
{}
{    The purpose of this request is to apply the section offset change vector
{ to the q-field of a B0 instruction to obtain a new q-field.
{}
{        OCP$GET_NEW_Q_FIELD (CURRENT_OFFSET, OLD_Q_FIELD, SECTION_OFFSET_CV,
{          NEW_Q_FIELD)
{}
{ CURRENT_OFFSET: (input) This parameter specifies the offset into the code section
{        of the current B0 instruction.
{}
{ OLD_Q_FIELD: (input)  This parameter specifies the q-field in the current B0
{        instruction.
{}
{ SECTION_OFFSET_CV: (input) This parameter specifies a pointer to the section
{        offset change vector.
{}
{ NEW_Q_FIELD: (output) This parameter specifies the new q-field generated.
{}
*DECK DECK=OCH$GET_NEXT_TEXT_REP_BSI EXPAND=FALSE
*DECK DECK=OCH$NEW_GLOBAL_OFFSET EXPAND=FALSE
{}
{    The purpose of this request is to apply an offset change vector to
{ a given offset.
{}
{        OCP$NEW_GLOBAL_OFFSET (OLD_OFFSET, OFFSET_CHANGE_VECTOR)
{}
{ OLD_OFFSET: (input) This parameter specifies an offset to be adjusted.
{}
{ OFFSET_CHANGE_VECTOR: (input) This parameter specifies an offset change vector.
{}
{ OCP$NEW_OFFSET: (output) This parameter specifies the new adjusted offset.
{}
*DECK DECK=OCH$NEW_OFFSET EXPAND=FALSE
{}
{    The purpose of this request is to apply a section offset change vector to
{ a given offset.
{}
{        OCP$NEW_OFFSET (OLD_OFFSET, OFFSET_CHANGE_VECTOR)
{}
{ OLD_OFFSET: (input) This parameter specifies an offset to be adjusted.
{}
{ OFFSET_CHANGE_VECTOR: (input) This parameter specifies an offset change vector.
{}
{ OCP$NEW_OFFSET: (output) This parameter specifies the new adjusted offset.
{}
*DECK DECK=OCH$NORMALIZE_BINDING_SEC_VALUE EXPAND=FALSE
{}
{   The purpose of this request is to apply the section offset change
{ vector to the binding section offset in the relocation records.
{}
{       OCP$NORMALIZE_BINDING_SEC_VALUE (CODE_SECTION_DIRECTORY,
{         MODULE_CODE_SECTION_DIRECTORY, RELOCATION, SECTION_DIRECTORY)
{}
{ CODE_SECTION_DIRECTORY: (input) This parameter specifies indices for a module
{       into the module code section directory.
{}
{ MODULE_CODE_SECTION_DIRECTORY: (input) This parameter specifies an array
{       containing code section ordinals and pointers to the code section(s)
{       for each module.
{}
{ RELOCATION: (input) This parameter specifies the relocation item to be
{       normalized.
{}
{ SECTION_DIRECTORY: (input) This parameter specifies the section number
{       and the section offset change vectors.
{}
*DECK DECK=OCH$OPEN_SCRATCH_SEGMENT EXPAND=FALSE
{}
{   The purpose of this request is to open a scratch segment using a unique
{ filename and create an SCL variable whose value is that unique name.
{}
{      OCP$OPEN_SCRATCH_SEGMENT (SCL_VAR, FID, SEG_P)
{}
{ SCL_VAR: (input) This parameter specifies the SCL variable name.
{}
{ FID: (output) This parameter specifies the file_identifier.
{}
{ SEG_P: (output) This parameter specifies the segment pointer to the file.
{}
*DECK DECK=OCH$PROCESS_B0_INSTRUCTIONS EXPAND=FALSE
{}
{    The purpose of this request is to adjust the q-field of the B0 instructions
{ using a section offset change vector.
{}
{        OCP$PROCESS_B0_INSTRUCTIONS (MODULE_PREDICTOR, MODULE_DICTIONARY, INT_OL)
{}
{ MODULE_PREDICTOR: (input) This parameter specifies a module predictor.
{}
{ MODULE_DICTIONARY: (input) This parameter specifies the module dictionary.
{}
{ INT_OL: (input) This parameter specifies a pointer to the intermediate object library.
{}
*DECK DECK=OCH$PROCESS_BTI_RECORDS EXPAND=FALSE
{}
{    The purpose of this request is to apply the binding section offset change
{ vector to each binding template offset.
{}
{        OCP$PROCESS_BTI_RECORDS (MODULE_PREDICTOR, MODULE_PREDICTOR_HEADER,
{          SECTION_DIRECTORY, BTI_RECORDS, NUMBER_OF_TEMPLATE_ITEMS)
{}
{ MODULE_PREDICTOR: (input) This parameter specifies a sequence containing the
{        section number and section offset change vectors for a module.
{}
{ MODULE_PREDICTOR_HEADER: (input) This parameter specifies the header record
{        from the module predictor.
{}
{ SECTION_DIRECTORY: (input) This parameter specifies a directory of section number
{        changes and pointers to section offset change vectors.
{}
{ BTI_RECORDS: (input) This parameter specifies the array of binding template
{        items in an object library.
{}
{ NUMBER_OF_TEMPLATE_ITEMS: (input) This parameter specifies the number of binding
{        template items in the object library.
{}
*DECK DECK=OCH$PROCESS_COMMAND_DICTIONARY EXPAND=FALSE
{}
{    The purpose of this apply the module dictionary offset change vector
{ to the command dictionary.
{}
{        OCP$ROCESS_COMMAND_DICTIONARY (COMMAND_DICTIONARY,
{          MOD_DICTIONARY_OCV, INT_OL)
{}
{ COMMAND_DICTIONARY: (input) This parameter specifies the command dictionary.
{}
{ MOD_DICTIONARY_OCV: (input) This parameter specifies the module dictionary
{        offset change vector.
{}
{ INT_OL: (input) This parameter specifies a pointer to the intermediate object library.
{}
*DECK DECK=OCH$PROCESS_DICTIONARIES EXPAND=FALSE
{}
{    The purpose of this apply the object library offset change vectors to
{ al the dicitonaries.
{}
{        OCP$PROCESS_DICTIONARIES (OL_DIRECTORY_OCV, MOD_DICTIONARY_OCV,
{          OBJECT_LIBRARY)
{}
{ OL_DICTIONARY_OCV: (input) This parameter specifies the object library
{        dictionary offset change vector.
{}
{ MOD_DICTIONARY_OCV: (input) This parameter specifies the module dictionary
{        offset change_vector.
{}
{ OBJECT_LIBRARY: (input) This parameter specifies a pointer to the object library.
{}
*DECK DECK=OCH$PROCESS_EPTS EXPAND=FALSE
{}
{    The purpose of this request is to apply the section change vectors to the
{ entry point definitions.
{}
{        OCP$PROCESS_EPTS (INT_OL, ENTRY_POINTS, MODULE_DIRECTORY)
{}
{ INT_OL: (input) This parameter specifies a pointer to the intermediate object library.
{}
{ ENTRY_POINTS: (input) This parameter specifies a pointer to the first entry
{        point definition.
{}
{ SECTION_DIRECTORY: (input) This parameter specifies the section number change
{       vector and a pointer to each section offset change vector.
{}
*DECK DECK=OCH$PROCESS_EPT_DICTIONARY EXPAND=FALSE
{}
{    The purpose of this request is to apply the module dicitonary offset
{ change vector to the entry point dictionary.
{}
{        OCP$PROCESS_EPT_DICTIONARY (ENTRY_POINT_DICTIONARY, MOD_DICTIONARY_OCV,
{          INT_OL)
{}
{ ENTRY_POINT_DICTIONARY: (input) This parameter specifies the entry point
{       dictionary.
{}
{ MOD_DICTIONARY_OCV: (input) This parameter specifies the module dictionary
{       offset change vector.
{}
{ INT_OL: (input) This parameter specifies a pointer to the intermediate object library.
{}
*DECK DECK=OCH$PROCESS_EXTS EXPAND=FALSE
{}
{    The purpose of this request is to apply the section change vectors to the
{ external linkages.
{}
{        OCP$PROCESS_EXTS (INT_OL, EXTERNAL_ELEMENT, SECTION_DIRECTORY)
{}
{ INT_OL: (input) This parameter specifies a pointer to the intermediate object library.
{}
{ EXTERNAL_ELEMENT: (input) This parameter specifies a pointer to the first
{        external linkage.
{}
{ SECTION_DIRECTORY: (input) This parameter specifies  the section number change
{       vector and a pointer to each section offset change vector.
{}
*DECK DECK=OCH$PROCESS_FUNCTION_DICTIONARY EXPAND=FALSE
{}
{    The purpose of this request is to apply the module dictionary
{ offset change vector to the command dictionary.
{}
{        OCP$PROCESS_FUNCTION_DICTIONARY (FUNCTION_DICTIONARY, MOD_DICTIONARY_OCV,
{          INT_OL)
{}
{ FUNCTION_DICTIONARY: (input) This parameter specifies the function
{       dictionary.
{}
{ MOD_DICTIONARY_OCV: (input) This parameter specifies the module dictionary
{       offset change vector.
{}
{ INT_OL: (input) This parameter specifies a pointer to the intermediate object library.
{}
*DECK DECK=OCH$PROCESS_HELP_DICTIONARY EXPAND=FALSE
{}
{    The purpose of this request is to apply the module dicitonary offset
{ change vector to the help dictionary.
{}
{        OCP$PROCESS_EPT_DICTIONARY (HELP_DICTIONARY, MOD_DICTIONARY_OCV,
{          INT_OL)
{}
{ HELP_DICTIONARY: (input) This parameter specifies the entry point dictionary.
{}
{ MOD_DICTIONARY_OCV: (input) This parameter specifies the module dictionary
{       offset change vector.
{}
{ INT_OL: (input) This parameter specifies a pointer to the intermediate object library.
{}
*DECK DECK=OCH$PROCESS_INFO_ELEMENT EXPAND=FALSE
{}
{    The purpose of this request is to apply the offset change vectors to the
{ information element.
{}
{        OCP$PROCESS_INFO_ELEMENT (MODULE_PREDICTOR, MODULE_DICTIONARY,
{          MOD_DICTIONARY_OCV, INT_OL, CODE_SECTION_DIRECTORY,
{          MODULE_CODE_SECTIONS, CURRENT_MODULE)
{}
{ MODULE_PREDICTOR: (input) This parameter specifies a pointer to the module
{        predictor which contains the change vectors.
{}
{ MODULE_DICTIONARY: (input) This parameter specifies the module dictionary.
{}
{ MOD_DICTIONARY_OCV: (input) This parameter specifies the module dictionary
{        offset change vector.
{}
{ INT_OL: (input) This parameter specifies a pointer to the intermediate object
{        library.
{}
{ CODE_SECTION_DIRECTORY: (input) This parameter specifies indices into the
{        module code section directory.
{}
{ MODULE_CODE_SECTIONS: (input) This parameter specifies the code section
{        ordinal and a pointer to the code section(s).
{}
{ CURRENT_MODULE: (input - output) This parameter specifies the number of
{        the current module being processed.
{}

*DECK DECK=OCH$PROCESS_INTERP_ELEMENT EXPAND=FALSE
{}
{    The purpose of this request is to adjust the offsets and section ordinals
{ in the interpretive element using the predictor.
{}
{        OCP$PROCESS_INTERP_ELEMENT (MODULE_PREDICTOR, MODULE_DICTIONARY,
{          MOD_DICTIONARY_OCV, INT_OL, CURRENT_MODULE)
{}
{ MODULE_PREDICTOR: (input) This parameter specifies a pointer to the predictor.
{}
{ MODULE_DICTIONARY: (input) This parameter specifies the module dictionary.
{}
{ MOD_DICTIONARY_OCV: (input) This parameter specifies the module dictionary
{       offset change vector.
{}
{ INT_OL: (input) This parameter specifies a pointer to the first intermediate
{        object library.
{}
{ CURRENT_MODULE: (input - output) This parameter specifies the ordinal of the
{       current module in the module dictionary.
{}
*DECK DECK=OCH$PROCESS_MESSAGE_DICTIONARY EXPAND=FALSE
{}
{    The purpose of this request is to apply the module dicitonary offset
{ change vector to the message dictionary.
{}
{        OCP$PROCESS_MESSAGE_DICTIONARY (MESSAGE_DICTIONARY, MOD_DICTIONARY_OCV,
{          INT_OL)
{}
{ MESSAGE_DICTIONARY: (input) This parameter specifies the message dictionary.
{}
{ MOD_DICTIONARY_OCV: (input) This parameter specifies the module dictionary
{       offset change vector.
{}
{ INT_OL: (input) This parameter specifies a pointer to the intermediate object library.
{}
*DECK DECK=OCH$PROCESS_MODULE_DICTIONARY EXPAND=FALSE
{}
{    The purpose of this request is to apply the module dicitonary offset
{ change vector to the module dictionary.
{}
{        OCP$PROCESS_MODULE_DICTIONARY (MODULE_DICTIONARY, MOD_DICTIONARY_OCV,
{          INT_OL)
{}
{ MODULE_DICTIONARY: (input) This parameter specifies the module dictionary.
{}
{ MOD_DICTIONARY_OCV: (input) This parameter specifies the module dictionary
{       offset change vector.
{}
{ INT_OL: (input) This parameter specifies a pointer to the intermediate object library.
{}
*DECK DECK=OCH$PROCESS_PANEL_DICTIONARY EXPAND=FALSE
{}
{    The purpose of this request is to apply the module dicitonary offset
{ change vector to the panel dictionary.
{}
{        OCP$PROCESS_PANEL_DICTIONARY (PANEL_DICTIONARY, MOD_DICTIONARY_OCV,
{          INT_OL)
{}
{ PANEL_DICTIONARY: (input) This parameter specifies the panel dictionary.
{}
{ MOD_DICTIONARY_OCV: (input) This parameter specifies the module dictionary
{       offset change vector.
{}
{ INT_OL: (input) This parameter specifies a pointer to the intermediate object library.
{}
*DECK DECK=OCH$PROCESS_REL_RECORDS EXPAND=FALSE
{}
{    The purpose of this request is to adjust the offset and section ordinals
{ of the relocation records using the section change vectors.
{}
{        OCP$PROCESS_REL_RECORDS (SECTION_DIRECTORY, RELOCATION, NUMBER_OF_REL_ITEMS,
{          CODE_SECTION_DIRECTORY, MODULE_CODE_SECTIONS)
{}
{ SECTION_DIRECTORY: (input) This parameter specifies a directory containing
{        the section number change vector and pointers to the section offset
{        change vectors.
{}
{ RELOCATION: (input) This parameter specifies the array of relocation items
{        in the object library.
{}
{ NUMBER_OF_REL_ITEMS: (input) This parameter specifies the number of relocation
{        items in the relocation array.
{}
{ CODE_SECTION_DIRECTORY: (input) This parameter specifies indices into the module
{        code section directory for each module.
{}
{ MODULE_CODE_SECTIONS: (input) This parameter specifies a directory of code section
{        ordinals and pointers to code sections.
{}

*DECK DECK=OCH$PROCESS_SECTIONS EXPAND=FALSE
{}
{    The purpose of this request is to adjust the offsets and section ordinals
{ in the section definitions, text, replication, bit string insertion, and
{ address formulation records.
{}
{        OCP$PROCESS_SECTIONS (INT_OL, SECTION_DEFS, SECTION_DIRECTORY,
{          MOD_DICTIONARY_OCV)
{}
{ INT_OL: (input) This parameter specifies a pointer to the intermediate
{        object library.
{}
{ SECTION_DEFS: (input) This parameter specifies a pointer to the first section
{        definition.
{}
{ SECTION_DIRECTORY: (input) This parameter specifies a directory containing
{        the section number change vector and pointers to the section offset
{        change vectors.
{}
{ MOD_DICTIONARY_OCV: (input) This parameter specifies the module dictionary
{        offset change vector.
{}
*DECK DECK=OCH$PROCESS_SECTION_MAPS EXPAND=FALSE
{}
{   The purpose of this request is to update the offset in the section
{ maps using the section offset change vector.
{}
{       OCP$PROCESS_SECTION_MAPS (SECTION_DIRECTORY, MOD_DICTIONARY_OCV,
{         SECTION_MAPS, NUMBER_OF_SECTION_MAPS, INTERMEDIATE_OL,
{         MODULE_PREDICTOR)
{}
{ SECTION_DIRECTORY: (input) This parameter specifies the section number
{       and section offset change vectors.
{}
{ MOD_DICTIONARY_OCV: (input) This parameter specifies the module dictionary
{       offset change vector.
{}
{ SECTION_MAPS: (input) This parameter specifies a pointer to the section
{       maps.
{}
{ NUMBER_OF_SECTION_MAPS: (input) This parameter specifies the number of
{       section maps in this module.
{}
{ INTERMEDIATE_OL: (input) This parameter specifies a pointer to the
{       intermediate object library.
{}
{ MODULE_PREDICTOR: (input) This parameter specifies the component change
{       vector used to update the component index in the section maps.
{}
*DECK DECK=OCH$SEARCH_UNTIL_DIFFERENCE EXPAND=FALSE
*DECK DECK=OCH$SEARCH_UNTIL_MATCH EXPAND=FALSE
*DECK DECK=OCH$UPDATE_OLD_BREAKLIST EXPAND=FALSE
{}
{    The purpose of this request is to update the old breaklist by adjusting
{ the breaklist offsets using the move_item offsets, deleting old breaklist
{ items that are not in the new breaklist and then sorting the old breaklist
{ on offset.
{}
{        OCP$UPDATE_OLD_BREAKLIST (MOVE_ITEMS, NUMBER_OF_MOVE_ITEMS,
{          OLD_BREAKLIST, LENGTH_OF_OLD_BREAKLIST)
{}
{ MOVE_ITEMS: (input) This parameter specifies the move items.
{}
{ NUMBER_OF_MOVE_ITEMS: (input) This parameter specifies the number of move
{        items.
{}
{ OLD_BREAKLIST: (input - ouptut) This parameter specifies the old object
{        library breaklist.
{}
{ LENGTH_OF_OLD_BREAKLIST: (input) This parameter specifies the length of the
{        old breaklist.
{}

*DECK DECK=OCH$VERIFY_MATCH EXPAND=FALSE
{}
{    The purpose of this request is to verify that two instructions are the same.
{    This procedure is used in building the corrector which is the third and
{ final phase in generating a correction for an object library.  This procedure
{ is used when building the corrector, not when applying it.
{}
{        OCP$VERIFY_MATCH (NEW_INDEX, OLD_INDEX, OLD_INSTRUCTIONS,
{          NEW_INSTRUCTIONS, MATCH)
{}
{ NEW_INDEX: (input) This parameter specifies an index into NEW_INSTRUCTIONS
{        which is the instruction to check.
{}
{ OLD_INDEX: (input) This parameter specifies an index into OLD_INSTRUCTIONS
{        which is the instruction to check.
{}
{ OLD_INSTRUCTIONS: (input) This parameter specifies the array of instructions
{        from a code section of the old object library.
{}
{ NEW_INSTRUCTIONS: (input) This parameter specifies the array of instructions
{        from a code section of the new object library.
{}
{ MATCH: (output) This parameter specifies whether the instructions match or not.
{}
*DECK DECK=OCM$$MODULE_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??                                                         
MODULE ocm$$module_attributes;                                                                                
                                                                                                              
                                                                                                              
                                                                                                              
{ PURPOSE:                                                                                                    
{   To retrieve information about all or part of the contents of a object                                     
{   file or library.                                                                                          
                                                                                                              
  VAR                                                                                                         
    command_status: ost$status;                                                                               
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc cle$ecc_miscellaneous                                                                                  
*copyc llt$load_module                                                                                        
*copyc llt$object_module                                                                                      
*copyc oce$library_generator_errors                                                                           
*copyc oct$attribute_keyword_set                                                                              
*copyc oct$display_toggles                                                                                    
*copyc oct$name_list                                                                                          
*copyc oct$new_library_module_list                                                                            
*copyc oct$object_code_utility_types                                                                          
*copyc oct$olg_scratch_seq                                                                                    
*copyc oct$open_file_list                                                                                     
?? POP ??                                                                                                     
*copyc clp$evaluate_parameters                                                                                
*copyc clp$make_list_value                                                                                    
*copyc ocp$build_module_attributes                                                                            
*copyc ocp$generate_message                                                                                   
*copyc ocp$obtain_library_list                                                                                
*copyc ocp$obtain_object_file                                                                                 
*copyc ocp$search_nlm_tree                                                                                    
*copyc ocp$search_object_file                                                                                 
*copyc ocp$search_open_file_list                                                                              
*copyc ocp$sort_name_list                                                                                     
*copyc osp$append_status_parameter                                                                            
*copyc osp$set_status_abnormal                                                                                
                                                                                                              
*copyc ocv$global_display_toggles                                                                             
*copyc ocv$module_attribute_keys                                                                              
*copyc ocv$nlm_list                                                                                           
*copyc ocv$olg_scratch_seq                                                                                    
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] ocp$$module_attributes', EJECT ??                                                      
                                                                                                              
{ PURPOSE:                                                                                                    
{   Function processor for the CREOL $MODULE_ATTRIBUTES function.                                             
                                                                                                              
  PROCEDURE [XDCL] ocp$$module_attributes                                                                     
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area: ^clt$work_area;                                                                           
     VAR result: ^clt$data_value;                                                                             
     VAR status: ost$status);                                                                                 
                                                                                                              
?? NEWTITLE := 'collect_modules_from_current', EJECT ??                                                       
                                                                                                              
{ PURPOSE:                                                                                                    
{   Convert the modules parameter of the function to a list of modules from                                   
{   the current library.                                                                                      
                                                                                                              
    PROCEDURE collect_modules_from_current                                                                    
      (    modules: ^clt$data_value;                                                                          
       VAR module_list: oct$name_list;                                                                        
       VAR status: ost$status);                                                                               
                                                                                                              
?? NEWTITLE := 'collect_modules', EJECT ??                                                                    
                                                                                                              
{ PURPOSE:                                                                                                    
{   Generate a list of modules from the current library from the specified                                    
{   module range.                                                                                             
                                                                                                              
      PROCEDURE collect_modules                                                                               
        (    first_module: pmt$program_name;                                                                  
             last_module: pmt$program_name;                                                                   
         VAR module_list: oct$name_list;                                                                      
         VAR status: ost$status);                                                                             
                                                                                                              
                                                                                                              
        VAR                                                                                                   
          current_module: pmt$program_name,                                                                   
          last_new_module: ^oct$name_list,                                                                    
          last_old_module: ^oct$name_list,                                                                    
          module_found: boolean,                                                                              
          nlm: ^oct$new_library_module_list;                                                                  
                                                                                                              
                                                                                                              
        last_old_module := ^module_list;                                                                      
        WHILE last_old_module^.link <> NIL DO                                                                 
          last_old_module := last_old_module^.link;                                                           
        WHILEND;                                                                                              
        last_new_module := last_old_module;                                                                   
                                                                                                              
                                                                                                              
        ocp$search_nlm_tree (first_module, nlm, module_found);                                                
        IF NOT module_found THEN                                                                              
          IF first_module = last_module THEN                                                                  
            osp$set_status_abnormal (oc, oce$w_module_not_found, first_module, status);                       
          ELSE                                                                                                
            osp$set_status_abnormal (oc, oce$w_subrange_module_not_found, first_module, status);              
            osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);               
            osp$append_status_parameter (osc$status_parameter_delimiter, last_module, status);                
          IFEND;                                                                                              
          ocp$generate_message (status);                                                                      
          osp$set_status_abnormal (oc, oce$e_some_modules_not, 'found', command_status);                      
          RETURN;                                                                                             
        IFEND;                                                                                                
                                                                                                              
        REPEAT                                                                                                
          IF nlm^.name = osc$null_name THEN                                                                   
            IF last_module <> osc$null_name THEN                                                              
              osp$set_status_abnormal (oc, oce$e_range_module_2_not_found, last_module, status);              
              osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);             
              ocp$generate_message (status);                                                                  
              osp$set_status_abnormal (oc, oce$e_some_modules_not, 'found', command_status);                  
            IFEND;                                                                                            
            RETURN;                                                                                           
          IFEND;                                                                                              
                                                                                                              
          current_module := nlm^.name;                                                                        
                                                                                                              
          NEXT last_new_module^.link IN ocv$olg_scratch_seq;                                                  
          last_new_module := last_new_module^.link;                                                           
          IF last_new_module = NIL THEN                                                                       
            osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);                        
            RETURN;                                                                                           
          IFEND;                                                                                              
                                                                                                              
          last_new_module^.name := current_module;                                                            
          last_new_module^.link := NIL;                                                                       
                                                                                                              
          nlm := nlm^.f_link;                                                                                 
        UNTIL current_module = last_module;                                                                   
                                                                                                              
      PROCEND collect_modules;                                                                                
?? OLDTITLE ??                                                                                                
?? EJECT ??                                                                                                   
                                                                                                              
                                                                                                              
      VAR                                                                                                     
        a_module: ^clt$data_value,                                                                            
                                                                                                              
        first_module: pmt$program_name,                                                                       
        last_module: pmt$program_name;                                                                        
                                                                                                              
                                                                                                              
      IF (modules <> NIL) AND (modules^.kind = clc$list) THEN                                                 
        a_module := modules;                                                                                  
                                                                                                              
        REPEAT                                                                                                
          IF a_module^.element_value^.kind = clc$range THEN                                                   
            first_module := a_module^.element_value^.low_value^.program_name_value;                           
            last_module := a_module^.element_value^.high_value^.program_name_value;                           
          ELSE                                                                                                
            first_module := a_module^.element_value^.program_name_value;                                      
            last_module := first_module;                                                                      
          IFEND;                                                                                              
                                                                                                              
          collect_modules (first_module, last_module, module_list, status);                                   
          IF NOT status.normal THEN                                                                           
            RETURN;                                                                                           
          IFEND;                                                                                              
          a_module := a_module^.link;                                                                         
        UNTIL a_module = NIL;                                                                                 
                                                                                                              
      ELSE                                                                                                    
        IF ocv$nlm_list^.f_link^.name = osc$null_name THEN                                                    
          osp$set_status_abnormal (oc, oce$w_no_modules_on_current_lib, '', status);                          
          RETURN;                                                                                             
        IFEND;                                                                                                
                                                                                                              
        first_module := ocv$nlm_list^.f_link^.name;                                                           
        last_module := ocv$nlm_list^.b_link^.name;                                                            
                                                                                                              
        collect_modules (first_module, last_module, module_list, status);                                     
      IFEND;                                                                                                  
                                                                                                              
                                                                                                              
    PROCEND collect_modules_from_current;                                                                     
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'collect_modules_from_external', EJECT ??                                                      
                                                                                                              
{ PURPOSE:                                                                                                    
{   Convert the modules parameter of the function to a list of modules from                                   
{   the external library.                                                                                     
                                                                                                              
    PROCEDURE collect_modules_from_external                                                                   
      (    modules: ^clt$data_value;                                                                          
       VAR input_file: ^oct$open_file_list;                                                                   
       VAR module_list: oct$name_list;                                                                        
       VAR status: ost$status);                                                                               
                                                                                                              
?? NEWTITLE := 'collect_modules', EJECT ??                                                                    
                                                                                                              
{ PURPOSE:                                                                                                    
{   Generate a list of modules from the external library from the specified                                   
{   module range.                                                                                             
                                                                                                              
      PROCEDURE collect_modules                                                                               
        (    first_module: pmt$program_name;                                                                  
             last_module: pmt$program_name;                                                                   
         VAR module_list: oct$name_list;                                                                      
         VAR status: ost$status);                                                                             
                                                                                                              
                                                                                                              
        VAR                                                                                                   
          current_module: pmt$program_name,                                                                   
          last_new_module: ^oct$name_list,                                                                    
          last_old_module: ^oct$name_list,                                                                    
          module_found: boolean,                                                                              
          nlm: ^oct$new_library_module_list;                                                                  
                                                                                                              
                                                                                                              
        last_old_module := ^module_list;                                                                      
        WHILE last_old_module^.link <> NIL DO                                                                 
          last_old_module := last_old_module^.link;                                                           
        WHILEND;                                                                                              
        last_new_module := last_old_module;                                                                   
                                                                                                              
        input_file^.current_module := 1;                                                                      
        ocp$search_object_file (first_module, module_found, input_file);                                      
        IF NOT module_found THEN                                                                              
          IF first_module = last_module THEN                                                                  
            osp$set_status_abnormal (oc, oce$w_module_not_found, first_module, status);                       
          ELSE                                                                                                
            osp$set_status_abnormal (oc, oce$w_subrange_module_not_found, first_module, status);              
            osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);               
            osp$append_status_parameter (osc$status_parameter_delimiter, last_module, status);                
          IFEND;                                                                                              
          ocp$generate_message (status);                                                                      
          osp$set_status_abnormal (oc, oce$e_some_modules_not, 'found', command_status);                      
          RETURN;                                                                                             
        IFEND;                                                                                                
                                                                                                              
        REPEAT                                                                                                
          IF input_file^.current_module > UPPERBOUND (input_file^.directory^) THEN                            
            IF last_module <> osc$null_name THEN                                                              
              osp$set_status_abnormal (oc, oce$e_range_module_2_not_found, last_module, status);              
              osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);             
              ocp$generate_message (status);                                                                  
              osp$set_status_abnormal (oc, oce$e_some_modules_not, 'found', command_status);                  
            IFEND;                                                                                            
            RETURN;                                                                                           
          IFEND;                                                                                              
                                                                                                              
          current_module := input_file^.directory^ [input_file^.current_module].name;                         
                                                                                                              
          NEXT last_new_module^.link IN ocv$olg_scratch_seq;                                                  
          last_new_module := last_new_module^.link;                                                           
          IF last_new_module = NIL THEN                                                                       
            osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);                        
            RETURN;                                                                                           
          IFEND;                                                                                              
                                                                                                              
          last_new_module^.name := current_module;                                                            
          last_new_module^.link := NIL;                                                                       
                                                                                                              
          input_file^.current_module := input_file^.current_module + 1;                                       
        UNTIL current_module = last_module;                                                                   
                                                                                                              
      PROCEND collect_modules;                                                                                
?? OLDTITLE ??                                                                                                
?? EJECT ??                                                                                                   
                                                                                                              
                                                                                                              
      VAR                                                                                                     
        a_module: ^clt$data_value,                                                                            
                                                                                                              
        first_module: pmt$program_name,                                                                       
        last_module: pmt$program_name;                                                                        
                                                                                                              
                                                                                                              
      IF (modules <> NIL) AND (modules^.kind = clc$list) THEN                                                 
        a_module := modules;                                                                                  
                                                                                                              
        REPEAT                                                                                                
          IF a_module^.element_value^.kind = clc$range THEN                                                   
            first_module := a_module^.element_value^.low_value^.program_name_value;                           
            last_module := a_module^.element_value^.high_value^.program_name_value;                           
          ELSE                                                                                                
            first_module := a_module^.element_value^.program_name_value;                                      
            last_module := first_module;                                                                      
          IFEND;                                                                                              
                                                                                                              
          collect_modules (first_module, last_module, module_list, status);                                   
          IF NOT status.normal THEN                                                                           
            RETURN;                                                                                           
          IFEND;                                                                                              
          a_module := a_module^.link;                                                                         
        UNTIL a_module = NIL;                                                                                 
                                                                                                              
      ELSE                                                                                                    
                                                                                                              
        first_module := input_file^.directory^ [1].name;                                                      
        last_module := osc$null_name;                                                                         
                                                                                                              
        collect_modules (first_module, last_module, module_list, status);                                     
      IFEND;                                                                                                  
                                                                                                              
                                                                                                              
    PROCEND collect_modules_from_external;                                                                    
?? OLDTITLE ??                                                                                                
?? EJECT ??                                                                                                   
                                                                                                              
{ FUNCTION (OCM$CREOL_$MODA) $module_attributes (                                                             
{   modules: any of                                                                                           
{     key all keyend                                                                                          
{     list of any of                                                                                          
{       program_name                                                                                          
{       range of program_name                                                                                 
{     anyend                                                                                                  
{   anyend = all                                                                                              
{   library: any of                                                                                           
{     key new_library keyend                                                                                  
{     file                                                                                                    
{   anyend = new_library                                                                                      
{   attributes: any of                                                                                        
{       key all keyend                                                                                        
{       list of key                                                                                           
{         header, program_attributes                                                                          
{         (kind, k)                                                                                           
{         (name, n)                                                                                           
{         (abort_file, af)                                                                                    
{         (aliases, alias, al)                                                                                
{         (application_identifier, ai)                                                                        
{         (arithmetic_loss_of_significance, alos)                                                             
{         (arithmetic_overflow, ao)                                                                           
{         (availability, a)                                                                                   
{         (comment, commentary)                                                                               
{         (components, component, c)                                                                          
{         (creation_date_time, cdt)                                                                           
{         (debug_input, di)                                                                                   
{         (debug_mode, dm)                                                                                    
{         (debug_output, do)                                                                                  
{         (divide_fault, df)                                                                                  
{         (entry_points, entry_point, ep)                                                                     
{         (exponent_overflow, eo)                                                                             
{         (exponent_underflow, eu)                                                                            
{         (fp_indefinite, fpi, fi)                                                                            
{         (fp_loss_of_significance, fplos, flos)                                                              
{         (generator, g)                                                                                      
{         (generator_version, gv)                                                                             
{         (invalid_bdp_data, ibdpd, ibd)                                                                      
{         (libraries, library, l)                                                                             
{         (load_map, lm)                                                                                      
{         (load_map_options, load_map_option, lmo)                                                            
{         (log_option, lo)                                                                                    
{         (module_kind, mk)                                                                                   
{         (modules, module, m)                                                                                
{         (natural_language, nl)                                                                              
{         (object_files, object_file, of)                                                                     
{         (online_manual, om)                                                                                 
{         (preset_value, pv)                                                                                  
{         (references, reference, r)                                                                          
{         (scope, s)                                                                                          
{         (stack_size, ss)                                                                                    
{         (starting_procedure, sp)                                                                            
{         (status_codes, status_code, sc)                                                                     
{         (system_command_name, scn),                                                                         
{         (termination_error_level, tel)                                                                      
{         (text_kind, tk)                                                                                     
{       keyend                                                                                                
{     anyend = header)                                                                                        
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
                                                                                                              
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 3] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 3] 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$union_type_qualifier,                                                              
            type_size_1: clt$type_specification_size,                                                         
            element_type_spec_1: record                                                                       
              header: clt$type_specification_header,                                                          
            recend,                                                                                           
            type_size_2: clt$type_specification_size,                                                         
            element_type_spec_2: record                                                                       
              header: clt$type_specification_header,                                                          
              qualifier: clt$range_type_qualifier,                                                            
              element_type_spec: record                                                                       
                header: clt$type_specification_header,                                                        
              recend,                                                                                         
            recend,                                                                                           
          recend,                                                                                             
        recend,                                                                                               
        default_value: string (3),                                                                            
      recend,                                                                                                 
      type2: 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,                                                              
        recend,                                                                                               
        default_value: string (11),                                                                           
      recend,                                                                                                 
      type3: 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 .. 96] of clt$keyword_specification,                                      
          recend,                                                                                             
        recend,                                                                                               
        default_value: string (6),                                                                            
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [93, 10, 13, 4, 49, 58, 392],                                                                             
    clc$function, 3, 3, 0, 0, 0, 0, 0, 'OCM$CREOL_$MODA'], [                                                  
    ['ATTRIBUTES                     ',clc$nominal_entry, 3],                                                 
    ['LIBRARY                        ',clc$nominal_entry, 2],                                                 
    ['MODULES                        ',clc$nominal_entry, 1]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [3, 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, 113, clc$optional_default_parameter, 0, 3],                                
{ PARAMETER 2                                                                                                 
    [2, 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, 67, clc$optional_default_parameter, 0, 11],                                
{ PARAMETER 3                                                                                                 
    [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, 3639, clc$optional_default_parameter, 0, 6                                 
  ]],                                                                                                         
{ 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]]                                                                                 
      ],                                                                                                      
    49, [[1, 0, clc$list_type], [33, 1, clc$max_list_size, 0, FALSE, FALSE],                                  
        [[1, 0, clc$union_type], [[clc$program_name_type,                                                     
        clc$range_type],                                                                                      
        FALSE, 2],                                                                                            
        3, [[1, 0, clc$program_name_type]],                                                                   
        10, [[1, 0, clc$range_type], [3],                                                                     
            [[1, 0, clc$program_name_type]]                                                                   
          ]                                                                                                   
        ]                                                                                                     
      ]                                                                                                       
    ,                                                                                                         
    'all'],                                                                                                   
{ PARAMETER 2                                                                                                 
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],                                              
    FALSE, 2],                                                                                                
    44, [[1, 0, clc$keyword_type], [1], [                                                                     
      ['NEW_LIBRARY                    ', clc$nominal_entry,                                                  
  clc$normal_usage_entry, 1]]                                                                                 
      ],                                                                                                      
    3, [[1, 0, clc$file_type]]                                                                                
    ,                                                                                                         
    'new_library'],                                                                                           
{ PARAMETER 3                                                                                                 
    [[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]]                                                                                 
      ],                                                                                                      
    3575, [[1, 0, clc$list_type], [3559, 1, clc$max_list_size, 0, FALSE, FALSE]                               
  ,                                                                                                           
        [[1, 0, clc$keyword_type], [96], [                                                                    
        ['A                              ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 10],                                                                                
        ['ABORT_FILE                     ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 5],                                                                                 
        ['AF                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 5],                                                                                 
        ['AI                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 7],                                                                                 
        ['AL                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 6],                                                                                 
        ['ALIAS                          ', clc$alias_entry,                                                  
  clc$normal_usage_entry, 6],                                                                                 
        ['ALIASES                        ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 6],                                                                                 
        ['ALOS                           ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 8],                                                                                 
        ['AO                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 9],                                                                                 
        ['APPLICATION_IDENTIFIER         ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 7],                                                                                 
        ['ARITHMETIC_LOSS_OF_SIGNIFICANCE', clc$nominal_entry,                                                
  clc$normal_usage_entry, 8],                                                                                 
        ['ARITHMETIC_OVERFLOW            ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 9],                                                                                 
        ['AVAILABILITY                   ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 10],                                                                                
        ['C                              ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 12],                                                                                
        ['CDT                            ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 13],                                                                                
        ['COMMENT                        ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 11],                                                                                
        ['COMMENTARY                     ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 11],                                                                                
        ['COMPONENT                      ', clc$alias_entry,                                                  
  clc$normal_usage_entry, 12],                                                                                
        ['COMPONENTS                     ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 12],                                                                                
        ['CREATION_DATE_TIME             ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 13],                                                                                
        ['DEBUG_INPUT                    ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 14],                                                                                
        ['DEBUG_MODE                     ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 15],                                                                                
        ['DEBUG_OUTPUT                   ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 16],                                                                                
        ['DF                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 17],                                                                                
        ['DI                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 14],                                                                                
        ['DIVIDE_FAULT                   ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 17],                                                                                
        ['DM                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 15],                                                                                
        ['DO                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 16],                                                                                
        ['ENTRY_POINT                    ', clc$alias_entry,                                                  
  clc$normal_usage_entry, 18],                                                                                
        ['ENTRY_POINTS                   ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 18],                                                                                
        ['EO                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 19],                                                                                
        ['EP                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 18],                                                                                
        ['EU                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 20],                                                                                
        ['EXPONENT_OVERFLOW              ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 19],                                                                                
        ['EXPONENT_UNDERFLOW             ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 20],                                                                                
        ['FI                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 21],                                                                                
        ['FLOS                           ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 22],                                                                                
        ['FPI                            ', clc$alias_entry,                                                  
  clc$normal_usage_entry, 21],                                                                                
        ['FPLOS                          ', clc$alias_entry,                                                  
  clc$normal_usage_entry, 22],                                                                                
        ['FP_INDEFINITE                  ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 21],                                                                                
        ['FP_LOSS_OF_SIGNIFICANCE        ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 22],                                                                                
        ['G                              ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 23],                                                                                
        ['GENERATOR                      ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 23],                                                                                
        ['GENERATOR_VERSION              ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 24],                                                                                
        ['GV                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 24],                                                                                
        ['HEADER                         ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 1],                                                                                 
        ['IBD                            ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 25],                                                                                
        ['IBDPD                          ', clc$alias_entry,                                                  
  clc$normal_usage_entry, 25],                                                                                
        ['INVALID_BDP_DATA               ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 25],                                                                                
        ['K                              ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 3],                                                                                 
        ['KIND                           ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 3],                                                                                 
        ['L                              ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 26],                                                                                
        ['LIBRARIES                      ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 26],                                                                                
        ['LIBRARY                        ', clc$alias_entry,                                                  
  clc$normal_usage_entry, 26],                                                                                
        ['LM                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 27],                                                                                
        ['LMO                            ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 28],                                                                                
        ['LO                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 29],                                                                                
        ['LOAD_MAP                       ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 27],                                                                                
        ['LOAD_MAP_OPTION                ', clc$alias_entry,                                                  
  clc$normal_usage_entry, 28],                                                                                
        ['LOAD_MAP_OPTIONS               ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 28],                                                                                
        ['LOG_OPTION                     ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 29],                                                                                
        ['M                              ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 31],                                                                                
        ['MK                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 30],                                                                                
        ['MODULE                         ', clc$alias_entry,                                                  
  clc$normal_usage_entry, 31],                                                                                
        ['MODULES                        ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 31],                                                                                
        ['MODULE_KIND                    ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 30],                                                                                
        ['N                              ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 4],                                                                                 
        ['NAME                           ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 4],                                                                                 
        ['NATURAL_LANGUAGE               ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 32],                                                                                
        ['NL                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 32],                                                                                
        ['OBJECT_FILE                    ', clc$alias_entry,                                                  
  clc$normal_usage_entry, 33],                                                                                
        ['OBJECT_FILES                   ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 33],                                                                                
        ['OF                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 33],                                                                                
        ['OM                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 34],                                                                                
        ['ONLINE_MANUAL                  ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 34],                                                                                
        ['PRESET_VALUE                   ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 35],                                                                                
        ['PROGRAM_ATTRIBUTES             ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 2],                                                                                 
        ['PV                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 35],                                                                                
        ['R                              ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 36],                                                                                
        ['REFERENCE                      ', clc$alias_entry,                                                  
  clc$normal_usage_entry, 36],                                                                                
        ['REFERENCES                     ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 36],                                                                                
        ['S                              ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 37],                                                                                
        ['SC                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 40],                                                                                
        ['SCN                            ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 41],                                                                                
        ['SCOPE                          ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 37],                                                                                
        ['SP                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 39],                                                                                
        ['SS                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 38],                                                                                
        ['STACK_SIZE                     ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 38],                                                                                
        ['STARTING_PROCEDURE             ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 39],                                                                                
        ['STATUS_CODE                    ', clc$alias_entry,                                                  
  clc$normal_usage_entry, 40],                                                                                
        ['STATUS_CODES                   ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 40],                                                                                
        ['SYSTEM_COMMAND_NAME            ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 41],                                                                                
        ['TEL                            ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 42],                                                                                
        ['TERMINATION_ERROR_LEVEL        ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 42],                                                                                
        ['TEXT_KIND                      ', clc$nominal_entry,                                                
  clc$normal_usage_entry, 43],                                                                                
        ['TK                             ', clc$abbreviation_entry,                                           
  clc$normal_usage_entry, 43]]                                                                                
        ]                                                                                                     
      ]                                                                                                       
    ,                                                                                                         
    'header']];                                                                                               
                                                                                                              
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$modules = 1,                                                                                          
      p$library = 2,                                                                                          
      p$attributes = 3;                                                                                       
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 3] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      temp: integer,                                                                                          
      attribute: ^clt$data_value,                                                                             
      dummy: boolean,                                                                                         
      external_file: boolean,                                                                                 
      header_only: boolean,                                                                                   
      high: oct$module_attribute_keywords,                                                                    
      input_file: ^oct$open_file_list,                                                                        
      low: oct$module_attribute_keywords,                                                                     
      module_list: ^oct$name_list,                                                                            
      nlm: ^oct$new_library_module_list,                                                                      
      pick: oct$module_attribute_keywords,                                                                    
      selected_keywords: oct$attribute_keyword_set,                                                           
      value: ^^clt$data_value;                                                                                
                                                                                                              
                                                                                                              
    status.normal := TRUE;                                                                                    
    command_status.normal := TRUE;                                                                            
                                                                                                              
    RESET ocv$olg_scratch_seq;                                                                                
                                                                                                              
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    PUSH module_list;                                                                                         
    module_list^.link := NIL;                                                                                 
                                                                                                              
    IF pvt [p$library].value^.kind = clc$file THEN                                                            
      external_file := TRUE;                                                                                  
                                                                                                              
      ocp$obtain_object_file (pvt [p$library].value^.file_value^, input_file, status);                        
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      collect_modules_from_external (pvt [p$modules].value, input_file, module_list^, status);                
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
    ELSE                                                                                                      
      external_file := FALSE;                                                                                 
                                                                                                              
      collect_modules_from_current (pvt [p$modules].value, module_list^, status);                             
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    attribute := pvt [p$attributes].value;                                                                    
    IF attribute^.kind = clc$keyword THEN                                                                     
      selected_keywords := $oct$attribute_keyword_set [occ$kwd_all];                                          
    ELSE                                                                                                      
      selected_keywords := $oct$attribute_keyword_set [];                                                     
      WHILE attribute <> NIL DO                                                                               
        high := UPPERBOUND (ocv$module_attribute_keys);                                                       
        low := LOWERBOUND (ocv$module_attribute_keys);                                                        
        REPEAT                                                                                                
          temp := high + low;                                                                                 
          pick := temp DIV 2;                                                                                 
          IF attribute^.element_value^.keyword_value = ocv$module_attribute_keys [pick].name THEN             
            high := pick;                                                                                     
            low := pick;                                                                                      
          ELSEIF attribute^.element_value^.keyword_value > ocv$module_attribute_keys [pick].name THEN         
            low := pick + 1;                                                                                  
          ELSE                                                                                                
            high := pick - 1;                                                                                 
          IFEND;                                                                                              
        UNTIL high = low;                                                                                     
        selected_keywords := selected_keywords + $oct$attribute_keyword_set                                   
              [ocv$module_attribute_keys [low].attribute];                                                    
        attribute := attribute^.link;                                                                         
      WHILEND;                                                                                                
    IFEND;                                                                                                    
                                                                                                              
    module_list := module_list^.link;                                                                         
    result := NIL;                                                                                            
    value := ^result;                                                                                         
                                                                                                              
    WHILE module_list <> NIL DO                                                                               
      clp$make_list_value (work_area, value^);                                                                
      IF external_file THEN                                                                                   
        input_file^.current_module := 1;                                                                      
        ocp$search_object_file (module_list^.name, dummy, input_file);                                        
        ocp$build_module_attributes (selected_keywords, input_file^.directory^ [input_file^.current_module],  
              NIL, work_area, value^^.element_value, status);                                                 
      ELSE                                                                                                    
        ocp$search_nlm_tree (module_list^.name, nlm, dummy);                                                  
        ocp$build_module_attributes (selected_keywords, nlm^.description^, nlm^.changed_info, work_area,      
              value^^.element_value, status);                                                                 
      IFEND;                                                                                                  
                                                                                                              
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      module_list := module_list^.link;                                                                       
      value := ^value^^.link;                                                                                 
    WHILEND;                                                                                                  
                                                                                                              
    IF result = NIL THEN                                                                                      
      clp$make_list_value (work_area, result);                                                                
    IFEND;                                                                                                    
                                                                                                              
    status := command_status;                                                                                 
                                                                                                              
  PROCEND ocp$$module_attributes;                                                                             
?? OLDTITLE ??                                                                                                
                                                                                                              
MODEND ocm$$module_attributes;                                                                                
*DECK DECK=OCM$$MODULE_LIST EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??                                                         
MODULE ocm$$module_list;                                                                                      
                                                                                                              
                                                                                                              
                                                                                                              
{ PURPOSE:                                                                                                    
{   To return the list of modules on the current library.                                                     
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc cle$ecc_miscellaneous                                                                                  
*copyc llt$load_module                                                                                        
*copyc llt$object_module                                                                                      
*copyc oce$library_generator_errors                                                                           
*copyc oct$module_kinds                                                                                       
*copyc oct$new_library_module_list                                                                            
*copyc oct$object_code_utility_types                                                                          
*copyc oct$open_file_list                                                                                     
?? POP ??                                                                                                     
*copyc clp$evaluate_parameters                                                                                
*copyc clp$make_list_value                                                                                    
*copyc clp$make_program_name_value                                                                            
*copyc ocp$generate_message                                                                                   
*copyc ocp$obtain_object_file                                                                                 
*copyc ocp$search_nlm_tree                                                                                    
*copyc ocp$sort_name_list                                                                                     
*copyc osp$append_status_parameter                                                                            
*copyc osp$set_status_abnormal                                                                                
*copyc osp$set_status_condition                                                                               
                                                                                                              
*copyc ocv$nlm_list                                                                                           
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??                                        
?? FMT (FORMAT := OFF) ??                                                                                     
                                                                                                              
  VAR                                                                                                         
    module_kinds: array [1 .. 10] of record                                                                   
      name: ost$name,                                                                                         
      kinds: oct$module_kinds,                                                                                
    recend := [                                                                                               
      ['COMMAND_DESCRIPTION            ', [occ$command_description, occ$applic_command_description]],         
      ['COMMAND_PROCEDURE              ', [occ$command_procedure, occ$applic_command_procedure]],             
      ['CPU_MODULE                     ', [occ$cpu_object_module]],                                           
      ['FORM_MODULE                    ', [occ$panel_module]],                                                
      ['FUNCTION_DESCRIPTION           ', [occ$function_description]],                                        
      ['FUNCTION_PROCEDURE             ', [occ$function_procedure]],                                          
      ['LOAD_MODULE                    ', [occ$load_module, occ$bound_module]],                               
      ['MESSAGE_MODULE                 ', [occ$message_module]],                                              
      ['PPU_MODULE                     ', [occ$ppu_object_module]],                                           
      ['PROGRAM_DESCRIPTION            ', [occ$program_description, occ$applic_program_description]]];        
?? FMT (FORMAT := ON) ??                                                                                      
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] ocp$$module_list', EJECT ??                                                            
                                                                                                              
{ PURPOSE:                                                                                                    
{   Function processor for the $MODULE_LIST function.                                                         
                                                                                                              
  PROCEDURE [XDCL] ocp$$module_list                                                                           
    (    parameter_list: clt$parameter_list;                                                                  
     VAR work_area: ^clt$work_area;                                                                           
     VAR result: ^clt$data_value;                                                                             
     VAR status: ost$status);                                                                                 
                                                                                                              
?? NEWTITLE := 'build_module_list_from_current', EJECT ??                                                     
                                                                                                              
{ PURPOSE:                                                                                                    
{   Build the list of names of the selected module kinds from the current                                     
{   library.                                                                                                  
                                                                                                              
    PROCEDURE build_module_list_from_current                                                                  
      (    selected_kinds: oct$module_kinds;                                                                  
       VAR result: ^clt$data_value);                                                                          
                                                                                                              
      VAR                                                                                                     
        current_module: pmt$program_name,                                                                     
        first_module: pmt$program_name,                                                                       
        last_module: pmt$program_name,                                                                        
        module_found: boolean,                                                                                
        nlm: ^oct$new_library_module_list,                                                                    
        value: ^^clt$data_value;                                                                              
                                                                                                              
      value := ^result;                                                                                       
                                                                                                              
      first_module := ocv$nlm_list^.f_link^.name;                                                             
      last_module := ocv$nlm_list^.b_link^.name;                                                              
                                                                                                              
      ocp$search_nlm_tree (first_module, nlm, module_found);                                                  
                                                                                                              
      REPEAT                                                                                                  
        IF nlm^.name = osc$null_name THEN                                                                     
          RETURN;                                                                                             
        IFEND;                                                                                                
                                                                                                              
        current_module := nlm^.name;                                                                          
        IF nlm^.description^.kind IN selected_kinds THEN                                                      
          clp$make_list_value (work_area, value^);                                                            
          clp$make_program_name_value (current_module, work_area, value^^.element_value);                     
          value := ^value^^.link;                                                                             
        IFEND;                                                                                                
                                                                                                              
        nlm := nlm^.f_link;                                                                                   
      UNTIL current_module = last_module;                                                                     
                                                                                                              
    PROCEND build_module_list_from_current;                                                                   
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'build_module_list_from_library', EJECT ??                                                     
                                                                                                              
{ PURPOSE:                                                                                                    
{   Build the list of module names of the selected module kinds from the                                      
{   specified library file.                                                                                   
                                                                                                              
    PROCEDURE build_module_list_from_library                                                                  
      (    selected_kinds: oct$module_kinds;                                                                  
           file_name: fst$file_reference;                                                                     
       VAR result: ^clt$data_value;                                                                           
       VAR status: ost$status);                                                                               
                                                                                                              
      VAR                                                                                                     
        current_module: integer,                                                                              
        input_file: ^oct$open_file_list,                                                                      
        value: ^^clt$data_value;                                                                              
                                                                                                              
      value := ^result;                                                                                       
                                                                                                              
      ocp$obtain_object_file (file_name, input_file, status);                                                 
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      FOR current_module := 1 TO UPPERBOUND (input_file^.directory^) DO                                       
        IF input_file^.directory^ [current_module].kind IN selected_kinds THEN                                
          clp$make_list_value (work_area, value^);                                                            
          clp$make_program_name_value (input_file^.directory^ [current_module].name, work_area,               
                value^^.element_value);                                                                       
          value := ^value^^.link;                                                                             
        IFEND;                                                                                                
      FOREND;                                                                                                 
                                                                                                              
    PROCEND build_module_list_from_library;                                                                   
?? OLDTITLE, EJECT ??                                                                                         
                                                                                                              
{ FUNCTION (OCM$CREOL_$MODL) $module_list (                                                                   
{   library: any of                                                                                           
{     key new_library keyend                                                                                  
{     file                                                                                                    
{    anyend = new_library                                                                                     
{   kinds: any of                                                                                             
{     key all keyend                                                                                          
{     list of key                                                                                             
{       (command_description, cd),                                                                            
{       (command_procedure, cp),                                                                              
{       (cpu_module, cm),                                                                                     
{       (form_module, fm),                                                                                    
{       (function_description, fd),                                                                           
{       (function_procedure, fp),                                                                             
{       (load_module, lm),                                                                                    
{       (message_module, mm),                                                                                 
{       (ppu_module, ppum, pm),                                                                               
{       (program_description, pd)                                                                             
{     keyend                                                                                                  
{    anyend = all)                                                                                            
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
?? FMT (FORMAT := OFF) ??                                                                                     
                                                                                                              
  VAR                                                                                                         
    pdt: [STATIC, READ, cls$declaration_section] record                                                       
      header: clt$pdt_header,                                                                                 
      names: array [1 .. 2] of clt$pdt_parameter_name,                                                        
      parameters: array [1 .. 2] 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,                                                              
        recend,                                                                                               
        default_value: string (11),                                                                           
      recend,                                                                                                 
      type2: 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,                                                                 
          element_type_spec: record                                                                           
            header: clt$type_specification_header,                                                            
            qualifier: clt$keyword_type_qualifier,                                                            
            keyword_specs: array [1 .. 21] of clt$keyword_specification,                                      
          recend,                                                                                             
        recend,                                                                                               
        default_value: string (3),                                                                            
      recend,                                                                                                 
    recend := [                                                                                               
    [1,                                                                                                       
    [89, 9, 1, 15, 19, 42, 289],                                                                              
    clc$function, 2, 2, 0, 0, 0, 0, 0, 'OCM$CREOL_$MODL'], [                                                  
    ['KINDS                          ',clc$nominal_entry, 2],                                                 
    ['LIBRARY                        ',clc$nominal_entry, 1]],                                                
    [                                                                                                         
{ PARAMETER 1                                                                                                 
    [2, 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, 67,                         
  clc$optional_default_parameter, 0, 11],                                                                     
{ PARAMETER 2                                                                                                 
    [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, 864,                        
  clc$optional_default_parameter, 0, 3]],                                                                     
{ PARAMETER 1                                                                                                 
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],                                              
    FALSE, 2],                                                                                                
    44, [[1, 0, clc$keyword_type], [1], [                                                                     
      ['NEW_LIBRARY                    ', clc$nominal_entry, clc$normal_usage_entry, 1]]                      
      ],                                                                                                      
    3, [[1, 0, clc$file_type]]                                                                                
    ,                                                                                                         
    'new_library'],                                                                                           
{ PARAMETER 2                                                                                                 
    [[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]]                      
      ],                                                                                                      
    800, [[1, 0, clc$list_type], [784, 1, clc$max_list_size, FALSE],                                          
        [[1, 0, clc$keyword_type], [21], [                                                                    
        ['CD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],               
        ['CM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],               
        ['COMMAND_DESCRIPTION            ', clc$nominal_entry, clc$normal_usage_entry, 1],                    
        ['COMMAND_PROCEDURE              ', clc$nominal_entry, clc$normal_usage_entry, 2],                    
        ['CP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],               
        ['CPU_MODULE                     ', clc$nominal_entry, clc$normal_usage_entry, 3],                    
        ['FD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],               
        ['FM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],               
        ['FORM_MODULE                    ', clc$nominal_entry, clc$normal_usage_entry, 4],                    
        ['FP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],               
        ['FUNCTION_DESCRIPTION           ', clc$nominal_entry, clc$normal_usage_entry, 5],                    
        ['FUNCTION_PROCEDURE             ', clc$nominal_entry, clc$normal_usage_entry, 6],                    
        ['LM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],               
        ['LOAD_MODULE                    ', clc$nominal_entry, clc$normal_usage_entry, 7],                    
        ['MESSAGE_MODULE                 ', clc$nominal_entry, clc$normal_usage_entry, 8],                    
        ['MM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],               
        ['PD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 10],              
        ['PM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 9],               
        ['PPUM                           ', clc$alias_entry, clc$normal_usage_entry, 9],                      
        ['PPU_MODULE                     ', clc$nominal_entry, clc$normal_usage_entry, 9],                    
        ['PROGRAM_DESCRIPTION            ', clc$nominal_entry, clc$normal_usage_entry, 10]]                   
        ]                                                                                                     
      ]                                                                                                       
    ,                                                                                                         
    'all']];                                                                                                  
                                                                                                              
?? FMT (FORMAT := ON) ??                                                                                      
?? POP ??                                                                                                     
                                                                                                              
    CONST                                                                                                     
      p$library = 1,                                                                                          
      p$kinds = 2;                                                                                            
                                                                                                              
    VAR                                                                                                       
      pvt: array [1 .. 2] of clt$parameter_value;                                                             
                                                                                                              
    VAR                                                                                                       
      i: integer,                                                                                             
      item_p: ^clt$data_value,                                                                                
      selected_kinds: oct$module_kinds;                                                                       
                                                                                                              
    status.normal := TRUE;                                                                                    
                                                                                                              
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);                                  
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF pvt [p$kinds].value^.kind = clc$keyword THEN                                                           
      selected_kinds := -$oct$module_kinds [];                                                                
    ELSE { list of module kind keywords                                                                       
      selected_kinds := $oct$module_kinds [];                                                                 
      item_p := pvt [p$kinds].value;                                                                          
      WHILE item_p <> NIL DO                                                                                  
        FOR i := LOWERBOUND (module_kinds) TO UPPERBOUND (module_kinds) DO                                    
          IF item_p^.element_value^.name_value = module_kinds [i].name THEN                                   
            selected_kinds := selected_kinds + module_kinds [i].kinds;                                        
          IFEND;                                                                                              
        FOREND;                                                                                               
        item_p := item_p^.link;                                                                               
      WHILEND;                                                                                                
    IFEND;                                                                                                    
                                                                                                              
    result := NIL;                                                                                            
    IF pvt [p$library].value^.kind = clc$keyword THEN                                                         
      IF ocv$nlm_list^.f_link^.name <> osc$null_name THEN                                                     
        build_module_list_from_current (selected_kinds, result);                                              
      IFEND;                                                                                                  
                                                                                                              
    ELSE { library.kind = clc$file_value                                                                      
      build_module_list_from_library (selected_kinds, pvt [p$library].value^.file_value^, result, status);    
      IF NOT status.normal AND (status.condition = oce$w_no_modules_on_current_lib) THEN                      
        status.normal := TRUE;                                                                                
        clp$make_list_value (work_area, result);                                                              
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    IF result = NIL THEN                                                                                      
      clp$make_list_value (work_area, result);                                                                
    IFEND;                                                                                                    
                                                                                                              
  PROCEND ocp$$module_list;                                                                                   
?? OLDTITLE ??                                                                                                
                                                                                                              
MODEND ocm$$module_list;                                                                                      
*DECK DECK=OCM$ADD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
MODULE ocm$add;

{ PURPOSE:
{   To add all or selected modules from
{   the named file or library to the
{   current library.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc oce$library_generator_errors
*copyc oct$display_toggles
*copyc oct$new_library_module_list
*copyc oct$nlm_modification_list
*copyc oct$open_file_list
*copyc ost$status
?? POP ??
*copyc clp$evaluate_parameters
*copyc ocp$add_additions_to_nlm_list
*copyc ocp$close_all_open_files
*copyc ocp$create_an_nlm
*copyc ocp$free_nlm_modification_list
*copyc ocp$generate_message
*copyc ocp$get_module_from_wfl
*copyc ocp$initialize_olg_working_heap
*copyc ocp$obtain_object_file
*copyc ocp$rewind_working_file_list
*copyc ocp$search_modification_list
*copyc ocp$search_nlm_tree
*copyc ocp$search_working_file_list
*copyc ocp$skip_module_on_wfl
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc ocv$nlm_list
*copyc ocv$olg_scratch_seq
*copyc ocv$open_file_list
*copyc ocv$return_file_list
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    command_status: ost$status;

?? OLDTITLE ??
?? NEWTITLE := 'add_module_subrange' ??
?? EJECT ??

  PROCEDURE add_module_subrange
    (    first_module: pmt$program_name;
         last_module: pmt$program_name;
     VAR working_file_list: oct$working_file_list;
         addition_list: {output} ^oct$nlm_modification_list;
     VAR status: ost$status);


    VAR
      new_additions: ^oct$nlm_modification_list,
      last_addition: ^oct$nlm_modification_list,

      module_found: boolean,
      nlm: ^oct$new_library_module_list,
      current_module: pmt$program_name,
      file_descriptor: ^oct$open_file_list;


    ocp$search_modification_list (osc$null_name, addition_list, new_additions, module_found);

    ocp$rewind_working_file_list (working_file_list);

    ocp$search_working_file_list (first_module, working_file_list, module_found);
    IF NOT module_found THEN
      IF first_module = last_module THEN
        osp$set_status_abnormal (oc, oce$w_module_not_found, first_module, status);
      ELSE
        osp$set_status_abnormal (oc, oce$w_subrange_module_not_found, first_module, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, last_module, status);
      IFEND;
      ocp$generate_message (status);
      osp$set_status_abnormal (oc, oce$e_some_modules_not, 'added', command_status);
      RETURN;
    IFEND;

    REPEAT
      ocp$get_module_from_wfl (working_file_list, current_module, file_descriptor);
      IF current_module = osc$null_name THEN
        IF last_module <> osc$null_name THEN
          osp$set_status_abnormal (oc, oce$e_range_module_2_not_found, last_module, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);
          ocp$generate_message (status);
          osp$set_status_abnormal (oc, oce$e_some_modules_not, 'added', command_status);
          ocp$free_nlm_modification_list (new_additions);
        IFEND;
        RETURN;
      IFEND;

      ocp$search_modification_list (current_module, addition_list, last_addition, module_found);
      IF module_found THEN
        osp$set_status_abnormal (oc, oce$w_same_module_quoted_twice, current_module, status);
        ocp$generate_message (status);
        osp$set_status_abnormal (oc, oce$e_some_modules_not, 'added', command_status);

      ELSE
        ocp$search_nlm_tree (current_module, nlm, module_found);
        IF module_found THEN
          osp$set_status_abnormal (oc, oce$w_module_already_on_library, current_module, status);
          ocp$generate_message (status);
          osp$set_status_abnormal (oc, oce$e_some_modules_not, 'added', command_status);
        ELSE
          NEXT last_addition^.link IN ocv$olg_scratch_seq;
          last_addition := last_addition^.link;
          IF last_addition = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;

          ocp$create_an_nlm (^file_descriptor^.directory^ [file_descriptor^.current_module],
                last_addition^.nlm, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          last_addition^.link := NIL;
        IFEND;
      IFEND;

      ocp$skip_module_on_wfl (working_file_list);

    UNTIL current_module = last_module;


  PROCEND add_module_subrange;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$_add_module' ??
?? EJECT ??

{ This procedure is the command processor for the CREATE_OBJECT_LIBRARY
{ subcommand ADD_MODULE.

  PROCEDURE [XDCL] ocp$_add_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$creol_addm) add_module, add_modules, addm (
{   library, libraries, l: list of file = $required
{   module, modules, m: list of any of
{       program_name
{       range of program_name
{     anyend = $optional
{   placement, p: key
{       (after, a)
{       (before, b)
{     keyend = after
{   destination, d: program_name = $optional
{   return_file_when_complete: (BY_NAME, HIDDEN) boolean = false
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 12] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
      type5: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [93, 10, 11, 1, 15, 48, 228],
    clc$command, 12, 6, 1, 0, 1, 0, 6, 'OCM$CREOL_ADDM'], [
    ['D                              ',clc$abbreviation_entry, 4],
    ['DESTINATION                    ',clc$nominal_entry, 4],
    ['L                              ',clc$abbreviation_entry, 1],
    ['LIBRARIES                      ',clc$alias_entry, 1],
    ['LIBRARY                        ',clc$nominal_entry, 1],
    ['M                              ',clc$abbreviation_entry, 2],
    ['MODULE                         ',clc$nominal_entry, 2],
    ['MODULES                        ',clc$alias_entry, 2],
    ['P                              ',clc$abbreviation_entry, 3],
    ['PLACEMENT                      ',clc$nominal_entry, 3],
    ['RETURN_FILE_WHEN_COMPLETE      ',clc$nominal_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 19, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 49, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [11, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 5],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$program_name_type,
      clc$range_type],
      FALSE, 2],
      3, [[1, 0, clc$program_name_type]],
      10, [[1, 0, clc$range_type], [3],
          [[1, 0, clc$program_name_type]]
        ]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['AFTER                          ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['B                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['BEFORE                         ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'after'],
{ PARAMETER 4
    [[1, 0, clc$program_name_type]],
{ PARAMETER 5
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$library = 1,
      p$module = 2,
      p$placement = 3,
      p$destination = 4,
      p$return_file_when_complete = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    VAR
      addition_list: oct$nlm_modification_list,
      after: ^oct$new_library_module_list,
      return_file_entry: ^oct$return_file_list,
      file_descriptor: ^oct$open_file_list,
      first_module: pmt$program_name,
      ignore_status: ost$status,
      last_module: pmt$program_name,
      module_found: boolean,
      nlm: ^oct$new_library_module_list,
      node: ^clt$data_value,
      working_file_list: oct$working_file_list;

    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler;


    status.normal := TRUE;
    command_status.normal := TRUE;

    RESET ocv$olg_scratch_seq;

    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /protect/
    BEGIN
      working_file_list.current_file := ^working_file_list.first_working_file;
      node := pvt [p$library].value;
      WHILE node <> NIL DO
        NEXT working_file_list.current_file^.link IN ocv$olg_scratch_seq;
        working_file_list.current_file := working_file_list.current_file^.link;
        IF working_file_list.current_file = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        ocp$obtain_object_file (node^.element_value^.file_value^, working_file_list.current_file^.descriptor,
              status);
        IF NOT status.normal THEN
          EXIT /protect/;
        IFEND;
        IF pvt [p$return_file_when_complete].value^.boolean_value.value THEN
          ALLOCATE return_file_entry;
          ALLOCATE return_file_entry^.file_name: [STRLENGTH(node^.element_value^.file_value^)];
          return_file_entry^.file_name^ := node^.element_value^.file_value^;
          return_file_entry^.link := ocv$return_file_list;
          ocv$return_file_list := return_file_entry;
        IFEND;

        node := node^.link;
      WHILEND;

      working_file_list.current_file^.link := NIL;

      IF pvt [p$destination].specified THEN
        ocp$search_nlm_tree (pvt [p$destination].value^.program_name_value, nlm, module_found);
        IF NOT module_found THEN
          osp$set_status_abnormal (oc, oce$e_module_not_found, pvt [p$destination].value^.program_name_value,
                status);
          EXIT /protect/;
        IFEND;
        IF pvt [p$placement].value^.keyword_value = 'AFTER' THEN
          after := nlm;
        ELSE { BEFORE
          after := nlm^.b_link;
        IFEND;
      ELSE
        IF pvt [p$placement].value^.keyword_value = 'AFTER' THEN
          after := ocv$nlm_list^.b_link;
        ELSE { BEFORE
          after := ocv$nlm_list;
        IFEND;
      IFEND;

      addition_list.link := NIL;

      IF pvt [p$module].specified THEN
        node := pvt [p$module].value;

      /obtain_addition_list/
        WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
          IF node^.element_value^.kind = clc$range THEN
            first_module := node^.element_value^.low_value^.program_name_value;
            last_module := node^.element_value^.high_value^.program_name_value;
          ELSE
            first_module := node^.element_value^.program_name_value;
            last_module := first_module;
          IFEND;
          add_module_subrange (first_module, last_module, working_file_list, ^addition_list, status);
          IF NOT status.normal THEN
            EXIT /obtain_addition_list/;
          IFEND;
          node := node^.link;
        WHILEND /obtain_addition_list/;
      ELSE
        ocp$rewind_working_file_list (working_file_list);
        ocp$get_module_from_wfl (working_file_list, first_module, file_descriptor);
        last_module := osc$null_name;
        add_module_subrange (first_module, last_module, working_file_list, ^addition_list, status);
      IFEND;

      IF NOT status.normal THEN
        ocp$free_nlm_modification_list (^addition_list);
        EXIT /protect/;
      IFEND;

      ocp$add_additions_to_nlm_list (after, ^addition_list);
      status := command_status;
    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);


  PROCEND ocp$_add_module;
?? OLDTITLE ??
MODEND ocm$add;
*DECK DECK=OCM$ADJUST_ALLOTTED_SECTIONS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$adjust_allotted_sections;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc llt$object_text_descriptor
*copyc llt$section_definition
*copyc llt$segment_definition
*copyc llt$obsolete_segment_definition
*copyc oct$offset_change_list
*copyc ocp$new_global_offset
?? POP ??

*copyc och$adjust_allotted_sections

  PROCEDURE [XDCL] ocp$adjust_allotted_sections (mod_dictionary_ocv: ^oct$offset_change_list;
        section_defs: ^llt$object_text_descriptor;
        p_int_ol: ^SEQ ( * ));

    VAR
      int_ol: ^SEQ ( * ),
      object_text_descriptor: ^llt$object_text_descriptor,
      obsolete_segment_definition: ^llt$obsolete_segment_definition,
      ocv_applied: boolean,
      section_definition: ^llt$section_definition,
      segment_definition: ^llt$segment_definition;

    int_ol := p_int_ol;

    ocv_applied := FALSE;
    RESET int_ol TO section_defs;
    REPEAT
      NEXT object_text_descriptor IN int_ol;
      CASE object_text_descriptor^.kind OF

      = llc$section_definition, llc$unallocated_common_block =
        NEXT section_definition IN int_ol;

      = llc$segment_definition =
        NEXT segment_definition IN int_ol;

      = llc$obsolete_segment_definition =
        NEXT obsolete_segment_definition IN int_ol;

      = llc$obsolete_allotted_seg_def =
        object_text_descriptor^.allotted_segment := ocp$new_global_offset (object_text_descriptor^.
              allotted_segment, mod_dictionary_ocv);
        NEXT obsolete_segment_definition IN int_ol;

      = llc$allotted_section_definition =
        object_text_descriptor^.allotted_section := ocp$new_global_offset (object_text_descriptor^.
              allotted_section, mod_dictionary_ocv);
        NEXT section_definition IN int_ol;

      = llc$allotted_segment_definition =
        object_text_descriptor^.allotted_segment := ocp$new_global_offset (object_text_descriptor^.
              allotted_segment, mod_dictionary_ocv);
        NEXT segment_definition IN int_ol;
      ELSE
        ocv_applied := TRUE;
      CASEND;
    UNTIL ocv_applied;
  PROCEND ocp$adjust_allotted_sections;
MODEND ocm$adjust_allotted_sections;
*DECK DECK=OCM$ANALYZE_OBJECT_LIBRARY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Object Library Analyzer' ??
MODULE ocm$analyze_object_library;

{ PURPOSE:
{   This module contains the command handlers for ANALYZE_OBJECT_LIBRARY.


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc cle$ecc_miscellaneous
*copyc oct$anaol_types
*copyc oct$interrupt_types
?? POP ??
*copyc amp$fetch
*copyc amp$get_segment_pointer
*copyc clp$begin_utility
*copyc clp$convert_string_to_file
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc clp$make_integer_value
*copyc fsp$close_file
*copyc fsp$open_file
*copyc ocp$abort_if_abnormal_status
*copyc ocp$abort_if_segment_overflow
*copyc ocp$create_transient_segment
*copyc ocp$display_library_analysis
*copyc ocp$display_module_analysis
*copyc ocp$display_performance_anal
*copyc ocp$display_section_usage
*copyc ocp$get_binding_section_refs
*copyc ocp$initialize_object_library
*copyc ocp$internal_error
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$establish_condition_handler
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    utility_name = 'ANALYZE_OBJECT_LIBRARY         ';

  VAR
    command_file: amt$local_file_name := clc$current_command_input,
    utility_attributes: array [1 .. 3] of clt$utility_attribute :=
          [[clc$utility_command_table, * ], [clc$utility_function_proc_table, * ], [clc$utility_prompt, [3,
          'AOL']]],
    occ$all_access_attributes: [XDCL, READ] llt$section_access_attributes := [],

    ocv$object_library: [XDCL] ^oct$object_library := NIL,

    ocv$command_sequence: [XDCL] ^SEQ ( * ) := NIL,
    ocv$library_sequence: [XDCL] ^SEQ ( * ) := NIL;

?? OLDTITLE ??
?? NEWTITLE := 'reset_environment', EJECT ??

  PROCEDURE reset_environment;


    VAR
      abort_status: ost$status,
      transient_segment: amt$segment_pointer;


    IF (ocv$command_sequence = NIL) THEN
      ocp$create_transient_segment (amc$sequence_pointer, transient_segment, abort_status);
      ocp$abort_if_abnormal_status (abort_status);
      ocv$command_sequence := transient_segment.sequence_pointer;
    IFEND;

    IF (ocv$library_sequence = NIL) THEN
      ocp$create_transient_segment (amc$sequence_pointer, transient_segment, abort_status);
      ocp$abort_if_abnormal_status (abort_status);
      ocv$library_sequence := transient_segment.sequence_pointer;
    IFEND;


    close_current_object_library;

    RESET ocv$command_sequence;
    RESET ocv$library_sequence;


  PROCEND reset_environment;
?? OLDTITLE ??
?? NEWTITLE := 'open_object_library', EJECT ??

  PROCEDURE open_object_library
    (    file: clt$file;
     VAR status: ost$status);

    VAR
      fetch_attributes: [STATIC] array [1 .. 1] of amt$fetch_item := [
            {} [ * , amc$file_structure, * ]];

    VAR
      attachment_options: ^fst$attachment_options,
      attribute_validation: ^fst$file_cycle_attributes,
      file_identifier: amt$file_identifier,
      segment_pointer: amt$segment_pointer,
      object_library: ^oct$object_library;

    PUSH attachment_options: [1 .. 3];
    attachment_options^ [1].selector := fsc$access_and_share_modes;
    attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options^ [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_options^ [1].share_modes.selector := fsc$determine_from_access_modes;
    attachment_options^ [2].selector := fsc$create_file;
    attachment_options^ [2].create_file := FALSE;
    attachment_options^ [3].selector := fsc$open_position;
    attachment_options^ [3].open_position := amc$open_at_boi;

    PUSH attribute_validation: [1 .. 2];
    attribute_validation^ [1].selector := fsc$file_contents_and_processor;
    attribute_validation^ [1].file_contents := fsc$object_data;
    attribute_validation^ [1].file_processor := fsc$unknown_processor;
    attribute_validation^ [2].selector := fsc$file_contents_and_processor;
    attribute_validation^ [2].file_contents := fsc$object_library;
    attribute_validation^ [2].file_processor := fsc$unknown_processor;

    fsp$open_file (file.local_file_name, amc$segment, attachment_options, NIL, NIL, attribute_validation, NIL,
          file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_identifier, amc$sequence_pointer, segment_pointer, status);
    ocp$abort_if_abnormal_status (status);

    reset_environment;

    NEXT object_library IN ocv$library_sequence;
    ocp$abort_if_segment_overflow (^object_library);

    object_library^.file := file;
    object_library^.file_identifier := file_identifier;
    object_library^.sequence := segment_pointer.sequence_pointer;

    amp$fetch (object_library^.file_identifier, fetch_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    ocp$initialize_object_library ((fetch_attributes [1].file_structure = amc$library), object_library);

    ocv$object_library := object_library;


  PROCEND open_object_library;
?? OLDTITLE ??
?? NEWTITLE := 'close_current_object_library', EJECT ??

  PROCEDURE close_current_object_library;


    VAR
      local_file_identifier: amt$file_identifier,
      abort_status: ost$status;


    IF (ocv$object_library <> NIL) THEN
      local_file_identifier := ocv$object_library^.file_identifier;
      ocv$object_library := NIL;

      fsp$close_file (local_file_identifier, abort_status);
      ocp$abort_if_abnormal_status (abort_status);
    IFEND;


  PROCEND close_current_object_library;
?? OLDTITLE ??
?? NEWTITLE := 'add_module_subrange', EJECT ??

  PROCEDURE add_module_subrange
    (    first_module: pmt$program_name;
         last_module: pmt$program_name;
         module_list: ^oct$module_list;
     VAR end_of_list: ^oct$module_item;
     VAR status: ost$status);

    VAR
      i: integer;

    i := 1;
    WHILE (i <= UPPERBOUND (module_list^)) AND (module_list^ [i].name <> first_module) DO
      i := i + 1;
    WHILEND;

    IF (i > UPPERBOUND (module_list^)) THEN
      osp$set_status_abnormal ('OC', oce$unknown_module, first_module, status);
      RETURN;
    IFEND;

    end_of_list^.link := ^module_list^ [i];
    end_of_list := end_of_list^.link;

    IF (first_module <> last_module) THEN
      i := i + 1;
      WHILE (i <= UPPERBOUND (module_list^)) AND (module_list^ [i].name <> last_module) DO
        end_of_list^.link := ^module_list^ [i];
        end_of_list := end_of_list^.link;
        i := i + 1;
      WHILEND;

      IF (i > UPPERBOUND (module_list^)) THEN
        osp$set_status_abnormal ('OC', oce$unknown_module, last_module, status);
        RETURN;
      IFEND;

      end_of_list^.link := ^module_list^ [i];
      end_of_list := end_of_list^.link;
    IFEND;

    end_of_list^.link := NIL;


  PROCEND add_module_subrange;
?? OLDTITLE ??
?? NEWTITLE := 'use_library_command', EJECT ??

  PROCEDURE use_library_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$anaol_usel) use_library, usel (
{   library, l: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 18, 18, 14, 37, 256],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OCM$ANAOL_USEL'], [
    ['L                              ',clc$abbreviation_entry, 1],
    ['LIBRARY                        ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$library = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      file: clt$file;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_string_to_file (pvt [p$library].value^.file_value^, file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    open_object_library (file, status);

  PROCEND use_library_command;
?? OLDTITLE ??
?? NEWTITLE := 'display_library_command', EJECT ??

  PROCEDURE display_library_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$anaol_disla) display_library_analysis, disla (
{   display_options, display_option, do: any of
{       key
{         all
{       keyend
{       list of key
{         (number_of_modules, nom)
{         (record_analysis, ra)
{       keyend
{     anyend = all
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 4] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 16, 17, 32, 51, 792],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'OCM$ANAOL_DISLA'], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 1],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 1],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 235, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    171, [[1, 0, clc$list_type], [155, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [4], [
        ['NOM                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['NUMBER_OF_MODULES              ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['RA                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['RECORD_ANALYSIS                ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$display_options = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      display_options: oct$anaol_display_options,
      node: ^clt$data_value,
      output_file: clt$file;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (ocv$object_library = NIL) THEN
      osp$set_status_condition (oce$object_library_not_analyzed, status);
      RETURN;
    IFEND;

    IF (pvt [p$display_options].value^.kind = clc$keyword) THEN
      display_options := -$oct$anaol_display_options [];
    ELSE
      display_options := $oct$anaol_display_options [];
      node := pvt [p$display_options].value;
      WHILE node <> NIL DO
        CASE node^.element_value^.keyword_value (1) OF
        = 'N' =
          display_options := display_options + $oct$anaol_display_options [occ$display_number_of_modules];
        = 'R' =
          display_options := display_options + $oct$anaol_display_options [occ$display_record_analysis];
        ELSE
          ;
        CASEND;
        node := node^.link;
      WHILEND;
    IFEND;

    clp$convert_string_to_file (pvt [p$output].value^.file_value^, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$display_library_analysis (ocv$object_library, display_options, output_file, status);

  PROCEND display_library_command;
?? OLDTITLE ??
?? NEWTITLE := 'display_module_command', EJECT ??

  PROCEDURE display_module_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$anaol_disma) display_module_analysis, disma (
{   modules, module, m: any of
{       key
{         all
{       keyend
{       list of program_name
{       list of range of program_name
{     anyend = all
{   display_options, display_option, do: any of
{       key
{         all
{       keyend
{       list of key
{         (record_analysis, ra)
{         (section_analysis, sa)
{       keyend
{     anyend = all
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 4] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 16, 17, 46, 46, 728],
    clc$command, 9, 4, 0, 0, 0, 0, 4, 'OCM$ANAOL_DISMA'], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['M                              ',clc$abbreviation_entry, 1],
    ['MODULE                         ',clc$alias_entry, 1],
    ['MODULES                        ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 113, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 235, clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$program_name_type]]
      ],
    26, [[1, 0, clc$list_type], [10, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$range_type], [3],
          [[1, 0, clc$program_name_type]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[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]]
      ],
    171, [[1, 0, clc$list_type], [155, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [4], [
        ['RA                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['RECORD_ANALYSIS                ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['SA                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['SECTION_ANALYSIS               ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$modules = 1,
      p$display_options = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      display_options: oct$anaol_display_options,
      end_of_list: ^oct$module_item,
      first_module: pmt$program_name,
      last_module: pmt$program_name,
      module_index: clt$list_size,
      node: ^clt$data_value,
      output_file: clt$file;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (ocv$object_library = NIL) THEN
      osp$set_status_condition (oce$object_library_not_analyzed, status);
      RETURN;
    IFEND;
    end_of_list := ^ocv$object_library^.module_list^ [occ$head_of_list];
    end_of_list^.link := NIL;

    IF (pvt [p$modules].value^.kind = clc$keyword) THEN

{ The only keyword is 'ALL'. Add all modules.

      FOR module_index := 1 TO UPPERBOUND (ocv$object_library^.module_list^) DO
        end_of_list^.link := ^ocv$object_library^.module_list^ [module_index];
        end_of_list := end_of_list^.link;
      FOREND;
      end_of_list^.link := NIL;
    ELSE
      node := pvt [p$modules].value;
      WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
        IF node^.element_value^.kind = clc$range THEN
          first_module := node^.element_value^.low_value^.program_name_value;
          last_module := node^.element_value^.high_value^.program_name_value;
        ELSE
          first_module := node^.element_value^.program_name_value;
          last_module := first_module;
        IFEND;
        add_module_subrange (first_module, last_module, ocv$object_library^.module_list, end_of_list, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        node := node^.link;
      WHILEND;
    IFEND;

    IF (pvt [p$display_options].value^.kind = clc$keyword) THEN
      display_options := -$oct$anaol_display_options [];
    ELSE
      display_options := $oct$anaol_display_options [];
      node := pvt [p$display_options].value;
      WHILE node <> NIL DO
        CASE node^.element_value^.keyword_value (1) OF
        = 'S' =
          display_options := display_options + $oct$anaol_display_options [occ$display_section_analysis];
        = 'R' =
          display_options := display_options + $oct$anaol_display_options [occ$display_record_analysis];
        ELSE
          ;
        CASEND;
        node := node^.link;
      WHILEND;
    IFEND;

    clp$convert_string_to_file (pvt [p$output].value^.file_value^, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$display_module_analysis (ocv$object_library, display_options, output_file, status);

  PROCEND display_module_command;
?? OLDTITLE ??
?? NEWTITLE := 'display_performance_command', EJECT ??

  PROCEDURE display_performance_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$anaol_dispd) display_performance_data, dispd (
{   modules, module, m: any of
{       key
{         all
{       keyend
{       list of program_name
{       list of range of program_name
{     anyend = all
{   performance_data, pd: any of
{       key
{         all
{       keyend
{       list of key
{         (bound_modules, bm)
{         (line_tables, lt)
{         (load_modules, lm)
{         (multiple_entry_points, mep)
{         (object_modules, om)
{         (opt_debug, od)
{         (opt_low, ol)
{         (parameter_checking, pc)
{         (runtime_checking, rc)
{         (runtime_libraries, rl)
{         (runtime_library_calls, rlc)
{         (symbol_tables, st)
{         (unreferenced_sections, us)
{       keyend
{     anyend = all
{   display_option, display_options, do: any of
{       key
{         all, none
{       keyend
{       list of key
{         (description, d)
{         (module_names, mn)
{       keyend
{     anyend = description
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 26] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type3: 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 .. 2] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 4] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (11),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 16, 22, 7, 42, 200],
    clc$command, 11, 5, 0, 0, 0, 0, 5, 'OCM$ANAOL_DISPD'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 3],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 3],
    ['DO                             ',clc$abbreviation_entry, 3],
    ['M                              ',clc$abbreviation_entry, 1],
    ['MODULE                         ',clc$alias_entry, 1],
    ['MODULES                        ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OUTPUT                         ',clc$nominal_entry, 4],
    ['PD                             ',clc$abbreviation_entry, 2],
    ['PERFORMANCE_DATA               ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 113, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 1049, clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 272, clc$optional_default_parameter, 0, 11],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$program_name_type]]
      ],
    26, [[1, 0, clc$list_type], [10, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$range_type], [3],
          [[1, 0, clc$program_name_type]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[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]]
      ],
    985, [[1, 0, clc$list_type], [969, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [26], [
        ['BM                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['BOUND_MODULES                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['LINE_TABLES                    ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['LM                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['LOAD_MODULES                   ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['LT                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['MEP                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['MULTIPLE_ENTRY_POINTS          ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['OBJECT_MODULES                 ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['OD                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['OL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
        ['OM                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['OPT_DEBUG                      ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
        ['OPT_LOW                        ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
        ['PARAMETER_CHECKING             ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
        ['PC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
        ['RC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
        ['RL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
        ['RLC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 11],
        ['RUNTIME_CHECKING               ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
        ['RUNTIME_LIBRARIES              ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
        ['RUNTIME_LIBRARY_CALLS          ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
        ['ST                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 12],
        ['SYMBOL_TABLES                  ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
        ['UNREFERENCED_SECTIONS          ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
        ['US                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 13]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    171, [[1, 0, clc$list_type], [155, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [4], [
        ['D                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['DESCRIPTION                    ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['MN                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['MODULE_NAMES                   ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
        ]
      ]
    ,
    'description'],
{ PARAMETER 4
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$modules = 1,
      p$performance_data = 2,
      p$display_option = 3,
      p$output = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      display_options: oct$anaol_performance_options,
      end_of_list: ^oct$module_item,
      first_module: pmt$program_name,
      last_module: pmt$program_name,
      module_index: clt$list_size,
      node: ^clt$data_value,
      performance_problems: oct$anaol_performance_problems,
      output_file: clt$file;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (ocv$object_library = NIL) THEN
      osp$set_status_condition (oce$object_library_not_analyzed, status);
      RETURN;
    IFEND;

    end_of_list := ^ocv$object_library^.module_list^ [occ$head_of_list];
    end_of_list^.link := NIL;

    IF (pvt [p$modules].value^.kind = clc$keyword) THEN

{ The only keyword is 'ALL'. Add all modules.

      FOR module_index := 1 TO UPPERBOUND (ocv$object_library^.module_list^) DO
        end_of_list^.link := ^ocv$object_library^.module_list^ [module_index];
        end_of_list := end_of_list^.link;
      FOREND;
      end_of_list^.link := NIL;
    ELSE
      node := pvt [p$modules].value;
      WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
        IF node^.element_value^.kind = clc$range THEN
          first_module := node^.element_value^.low_value^.program_name_value;
          last_module := node^.element_value^.high_value^.program_name_value;
        ELSE
          first_module := node^.element_value^.program_name_value;
          last_module := first_module;
        IFEND;
        add_module_subrange (first_module, last_module, ocv$object_library^.module_list, end_of_list, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        node := node^.link;
      WHILEND;
    IFEND;

    IF (pvt [p$performance_data].value^.kind = clc$keyword) THEN
      performance_problems := -$oct$anaol_performance_problems [];
    ELSE
      performance_problems := $oct$anaol_performance_problems [];
      node := pvt [p$performance_data].value;
      WHILE node <> NIL DO
        IF (node^.element_value^.keyword_value = 'BOUND_MODULES') THEN
          performance_problems := performance_problems + $oct$anaol_performance_problems [occ$bound_module];
        ELSEIF (node^.element_value^.keyword_value = 'LINE_TABLES') THEN
          performance_problems := performance_problems + $oct$anaol_performance_problems [occ$line_tables];
        ELSEIF (node^.element_value^.keyword_value = 'LOAD_MODULES') THEN
          performance_problems := performance_problems + $oct$anaol_performance_problems [occ$load_module];
        ELSEIF (node^.element_value^.keyword_value = 'MULTIPLE_ENTRY_POINTS') THEN
          performance_problems := performance_problems + $oct$anaol_performance_problems
                [occ$multiple_entry_points];
        ELSEIF (node^.element_value^.keyword_value = 'OBJECT_MODULES') THEN
          performance_problems := performance_problems + $oct$anaol_performance_problems [occ$object_module];
        ELSEIF (node^.element_value^.keyword_value = 'OPT_DEBUG') THEN
          performance_problems := performance_problems + $oct$anaol_performance_problems [occ$opt_debug];
        ELSEIF (node^.element_value^.keyword_value = 'OPT_LOW') THEN
          performance_problems := performance_problems + $oct$anaol_performance_problems [occ$opt_low];
        ELSEIF (node^.element_value^.keyword_value = 'PARAMETER_CHECKING') THEN
          performance_problems := performance_problems + $oct$anaol_performance_problems
                [occ$parameter_checking];
        ELSEIF (node^.element_value^.keyword_value = 'RUNTIME_CHECKING') THEN
          performance_problems := performance_problems + $oct$anaol_performance_problems
                [occ$runtime_checking];
        ELSEIF (node^.element_value^.keyword_value = 'RUNTIME_LIBRARIES') THEN
          performance_problems := performance_problems + $oct$anaol_performance_problems
                [occ$runtime_libraries];
        ELSEIF (node^.element_value^.keyword_value = 'RUNTIME_LIBRARY_CALLS') THEN
          performance_problems := performance_problems + $oct$anaol_performance_problems
                [occ$runtime_library_calls];
        ELSEIF (node^.element_value^.keyword_value = 'SYMBOL_TABLES') THEN
          performance_problems := performance_problems + $oct$anaol_performance_problems [occ$symbol_tables];
        ELSE { node^.element_value^.keyword_value = 'UNREFERENCED_SECTIONS'
          performance_problems := performance_problems + $oct$anaol_performance_problems
                [occ$unreferenced_sections];
        IFEND;
        node := node^.link;
      WHILEND;
    IFEND;

    IF (pvt [p$display_option].value^.kind = clc$keyword) THEN
      IF (pvt [p$display_option].value^.keyword_value = 'ALL') THEN
        display_options := -$oct$anaol_performance_options [];
      ELSE { NONE
        display_options := $oct$anaol_performance_options [];
      IFEND;
    ELSE
      display_options := $oct$anaol_performance_options [];
      node := pvt [p$display_option].value;
      WHILE node <> NIL DO
        CASE node^.element_value^.keyword_value (1) OF
        = 'D' =
          display_options := display_options + $oct$anaol_performance_options [occ$display_description];
        = 'M' =
          display_options := display_options + $oct$anaol_performance_options [occ$display_module_names];
        ELSE
          ;
        CASEND;
        node := node^.link;
      WHILEND;
    IFEND;

    clp$convert_string_to_file (pvt [p$output].value^.file_value^, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$display_performance_anal (ocv$object_library, performance_problems, display_options, output_file,
          status);

  PROCEND display_performance_command;
?? OLDTITLE ??
?? NEWTITLE := 'display_section_usage_command', EJECT ??

  PROCEDURE display_section_usage_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$anaol_dissa) display_section_analysis, dissa (
{   modules, module, m: any of
{       key
{         all
{       keyend
{       list of program_name
{       list of range of program_name
{     anyend = all
{   section_kinds, sk: any of
{       key
{         all
{       keyend
{       list of key
{         (code, c)
{         (binding, b)
{         (working_storage, ws)
{         (extensible_working_storage, ews)
{         (common_block, cb)
{         (extensible_common_block, ecb)
{       keyend
{     anyend = all
{   section_access_attributes, saa: any of
{       key
{         all
{       keyend
{       list of key
{         (read, r)
{         (write, w)
{         (execute, e)
{         (binding, b)
{       keyend
{     anyend = all
{   section_name, sn: name = $optional
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 12] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] 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,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 12] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type3: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 8] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 16, 23, 9, 19, 316],
    clc$command, 12, 6, 0, 0, 0, 0, 6, 'OCM$ANAOL_DISSA'], [
    ['M                              ',clc$abbreviation_entry, 1],
    ['MODULE                         ',clc$alias_entry, 1],
    ['MODULES                        ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 5],
    ['OUTPUT                         ',clc$nominal_entry, 5],
    ['SAA                            ',clc$abbreviation_entry, 3],
    ['SECTION_ACCESS_ATTRIBUTES      ',clc$nominal_entry, 3],
    ['SECTION_KINDS                  ',clc$nominal_entry, 2],
    ['SECTION_NAME                   ',clc$nominal_entry, 4],
    ['SK                             ',clc$abbreviation_entry, 2],
    ['SN                             ',clc$abbreviation_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 113, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 531, clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 383, clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$program_name_type]]
      ],
    26, [[1, 0, clc$list_type], [10, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$range_type], [3],
          [[1, 0, clc$program_name_type]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[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]]
      ],
    467, [[1, 0, clc$list_type], [451, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [12], [
        ['B                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['BINDING                        ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['CB                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['CODE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['COMMON_BLOCK                   ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['ECB                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['EWS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['EXTENSIBLE_COMMON_BLOCK        ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
        ['EXTENSIBLE_WORKING_STORAGE     ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['WORKING_STORAGE                ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['WS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[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]]
      ],
    319, [[1, 0, clc$list_type], [303, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [8], [
        ['B                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['BINDING                        ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['E                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['EXECUTE                        ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['R                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['READ                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['W                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['WRITE                          ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 5
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$modules = 1,
      p$section_kinds = 2,
      p$section_access_attributes = 3,
      p$section_name = 4,
      p$output = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      access_attributes: llt$section_access_attributes,
      end_of_list: ^oct$module_item,
      first_module: pmt$program_name,
      index: clt$list_size,
      last_module: pmt$program_name,
      node: ^clt$data_value,
      output_file: clt$file,
      section_name: pmt$program_name,
      section_kinds: oct$section_kinds;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (ocv$object_library = NIL) THEN
      osp$set_status_condition (oce$object_library_not_analyzed, status);
      RETURN;
    IFEND;

    end_of_list := ^ocv$object_library^.module_list^ [occ$head_of_list];
    end_of_list^.link := NIL;

    IF (pvt [p$modules].value^.kind = clc$keyword) THEN

{ The only keyword is 'ALL'. Add all modules.

      FOR index := 1 TO UPPERBOUND (ocv$object_library^.module_list^) DO
        end_of_list^.link := ^ocv$object_library^.module_list^ [index];
        end_of_list := end_of_list^.link;
      FOREND;
      end_of_list^.link := NIL;
    ELSE
      node := pvt [p$modules].value;
      WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
        IF node^.element_value^.kind = clc$range THEN
          first_module := node^.element_value^.low_value^.program_name_value;
          last_module := node^.element_value^.high_value^.program_name_value;
        ELSE
          first_module := node^.element_value^.program_name_value;
          last_module := first_module;
        IFEND;
        add_module_subrange (first_module, last_module, ocv$object_library^.module_list, end_of_list, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        node := node^.link;
      WHILEND;
    IFEND;

    IF pvt [p$section_kinds].value^.kind = clc$keyword THEN
      section_kinds := -$oct$section_kinds [];
    ELSE
      section_kinds := $oct$section_kinds [];
      node := pvt [p$section_kinds].value;
      WHILE node <> NIL DO
        IF (node^.element_value^.keyword_value = 'CODE') THEN
          section_kinds := section_kinds + $oct$section_kinds [llc$code_section];
        ELSEIF (node^.element_value^.keyword_value = 'BINDING') THEN
          section_kinds := section_kinds + $oct$section_kinds [llc$binding_section];
        ELSEIF (node^.element_value^.keyword_value = 'WORKING_STORAGE') THEN
          section_kinds := section_kinds + $oct$section_kinds [llc$working_storage_section];
        ELSEIF (node^.element_value^.keyword_value = 'EXTENSIBLE_WORKING_STORAGE') THEN
          section_kinds := section_kinds + $oct$section_kinds [llc$extensible_working_storage];
        ELSEIF (node^.element_value^.keyword_value = 'COMMON_BLOCK') THEN
          section_kinds := section_kinds + $oct$section_kinds [llc$common_block];
        ELSE { node^.element_value^.keyword_value = 'EXTENSIBLE_COMMON_BLOCK'
          section_kinds := section_kinds + $oct$section_kinds [llc$extensible_common_block];
        IFEND;
        node := node^.link;
      WHILEND;
    IFEND;

    IF pvt [p$section_access_attributes].value^.kind = clc$keyword THEN
      access_attributes := occ$all_access_attributes;
    ELSE
      access_attributes := $llt$section_access_attributes [];
      node := pvt [p$section_access_attributes].value;
      WHILE node <> NIL DO
        CASE node^.element_value^.keyword_value (1) OF
        = 'R' =
          access_attributes := access_attributes + $llt$section_access_attributes [llc$read];
        = 'W' =
          access_attributes := access_attributes + $llt$section_access_attributes [llc$write];
        = 'E' =
          access_attributes := access_attributes + $llt$section_access_attributes [llc$execute];
        = 'B' =
          access_attributes := access_attributes + $llt$section_access_attributes [llc$binding];
        ELSE
          ;
        CASEND;
        node := node^.link;
      WHILEND;
    IFEND;

    IF pvt [p$section_name].specified THEN
      section_name := pvt [p$section_name].value^.name_value;
    ELSE
      section_name := occ$any_section_name;
    IFEND;

    clp$convert_string_to_file (pvt [p$output].value^.file_value^, output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$display_section_usage (ocv$object_library, section_kinds, access_attributes, section_name,
          output_file, status);

  PROCEND display_section_usage_command;
?? OLDTITLE ??
?? NEWTITLE := 'quit_command', EJECT ??

  PROCEDURE quit_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$anaol_qui) quit, qui

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 8, 16, 23, 39, 15, 258],
    clc$command, 0, 0, 0, 0, 0, 0, 0, 'OCM$ANAOL_QUI']];

?? FMT (FORMAT := ON) ??
?? POP ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    close_current_object_library;
    clp$end_include (utility_name, status);

  PROCEND quit_command;
?? OLDTITLE ??
?? NEWTITLE := 'binding_section_references', EJECT ??

  PROCEDURE binding_section_references
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (ocm$anaol_$binsr) $binding_section_references, $binsr (
{   module: any of
{       key
{         all
{       keyend
{       list of program_name
{       list of range of program_name
{     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,
          recend,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier_v2,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
        default_value: string (3),
      recend,
    recend := [
    [1,
    [92, 1, 24, 19, 50, 48, 661],
    clc$function, 1, 1, 0, 0, 0, 0, 0, 'OCM$ANAOL_$BINSR'], [
    ['MODULE                         ',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, 113,
  clc$optional_default_parameter, 0, 3]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$program_name_type]]
      ],
    26, [[1, 0, clc$list_type], [10, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$range_type], [3],
          [[1, 0, clc$program_name_type]]
        ]
      ]
    ,
    'all']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$module = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      count: 0 .. llc$max_binding_items,
      end_of_list: ^oct$module_item,
      first_module: pmt$program_name,
      index: clt$list_size,
      last_module: pmt$program_name,
      node: ^clt$data_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF ocv$object_library = NIL THEN
      osp$set_status_condition (oce$usel_not_executed, status);
      RETURN;
    IFEND;

    end_of_list := ^ocv$object_library^.module_list^ [occ$head_of_list];
    end_of_list^.link := NIL;

    IF pvt [p$module].value^.kind = clc$keyword THEN

{ The only keyword is "ALL".  Add all modules.

      FOR index := 1 TO UPPERBOUND (ocv$object_library^.module_list^) DO
        end_of_list^.link := ^ocv$object_library^.module_list^ [index];
        end_of_list := end_of_list^.link;
      FOREND;
      end_of_list^.link := NIL;

    ELSE
      node := pvt [p$module].value;
      WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
        IF node^.element_value^.kind = clc$range THEN
          first_module := node^.element_value^.low_value^.program_name_value;
          last_module := node^.element_value^.high_value^.program_name_value;
        ELSE
          first_module := node^.element_value^.program_name_value;
          last_module := first_module;
        IFEND;
        add_module_subrange (first_module, last_module, ocv$object_library^.module_list, end_of_list, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        node := node^.link;
      WHILEND;
    IFEND;

    ocp$get_binding_section_refs (ocv$object_library, count);

    clp$make_integer_value (count, 10, FALSE, work_area, result);

  PROCEND binding_section_references;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$_analyze_object_library', EJECT ??

  PROCEDURE [XDCL, #GATE] ocp$_analyze_object_library
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$anaol) analyze_object_library, anaol (
{   library, l: file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 16, 17, 8, 9, 454],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OCM$ANAOL'], [
    ['L                              ',clc$abbreviation_entry, 1],
    ['LIBRARY                        ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$library = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

{ table command_table type=command scope=local
{ command (use_library,                       usel) use_library_command ..
{   cm=local
{ command (display_library_analysis,          disla) ..
{   display_library_command cm=local
{ command (display_module_analysis,           disma) ..
{   display_module_command cm=local
{ command (display_performance_data,          dispd) ..
{   display_performance_command cm=local
{ command (display_section_analysis,          dissa) ..
{   display_section_usage_command cm=local
{ command (quit,                              qui) quit_command cm=local
{ command (display_section_usage,             dissu) ..
{   display_section_usage_command cm=local a=hidden
{ command (analyze_object_library,            anaol) use_library_command ..
{   cm=local a=hidden
{ tablend

?? PUSH (LISTEXT := ON) ??

    VAR
      command_table: [STATIC, READ] ^clt$command_table := ^command_table_entries,

      command_table_entries: [STATIC, READ] array [1 .. 16] of clt$command_table_entry := [
            {} ['ANALYZE_OBJECT_LIBRARY         ', clc$nominal_entry, clc$hidden_entry, 8,
            clc$automatically_log, clc$linked_call, ^use_library_command],
            {} ['ANAOL                          ', clc$abbreviation_entry, clc$hidden_entry, 8,
            clc$automatically_log, clc$linked_call, ^use_library_command],
            {} ['DISLA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^display_library_command],
            {} ['DISMA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^display_module_command],
            {} ['DISPD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^display_performance_command],
            {} ['DISPLAY_LIBRARY_ANALYSIS       ', clc$nominal_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^display_library_command],
            {} ['DISPLAY_MODULE_ANALYSIS        ', clc$nominal_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^display_module_command],
            {} ['DISPLAY_PERFORMANCE_DATA       ', clc$nominal_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^display_performance_command],
            {} ['DISPLAY_SECTION_ANALYSIS       ', clc$nominal_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^display_section_usage_command],
            {} ['DISPLAY_SECTION_USAGE          ', clc$nominal_entry, clc$hidden_entry, 7,
            clc$automatically_log, clc$linked_call, ^display_section_usage_command],
            {} ['DISSA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^display_section_usage_command],
            {} ['DISSU                          ', clc$abbreviation_entry, clc$hidden_entry, 7,
            clc$automatically_log, clc$linked_call, ^display_section_usage_command],
            {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^quit_command],
            {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^quit_command],
            {} ['USEL                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^use_library_command],
            {} ['USE_LIBRARY                    ', clc$nominal_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^use_library_command]];

?? POP ??

{ table function_table t=f s=local
{ function ($binding_section_references, $binsr) binding_section_references ..
{   cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  function_table: [STATIC, READ] ^clt$function_processor_table :=
      ^function_table_entries,

  function_table_entries: [STATIC, READ] array [1 .. 2] of
      clt$function_proc_table_entry := [
  {} ['$BINDING_SECTION_REFERENCES    ', clc$nominal_entry,
        clc$normal_usage_entry, 1, clc$linked_call,
        ^binding_section_references],
  {} ['$BINSR                         ', clc$abbreviation_entry,
        clc$normal_usage_entry, 1, clc$linked_call,
        ^binding_section_references]];

?? POP ??
?? NEWTITLE := 'abort_handler', EJECT ??

    VAR
      abort_condition: [STATIC, READ] pmt$condition := [pmc$user_defined_condition, occ$abort_condition],
      abort_descriptor: pmt$established_handler;




    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);


      VAR
        abort_status: ^ost$status;


      abort_status := condition_descriptor;
      status := abort_status^;

      EXIT ocp$_analyze_object_library;


    PROCEND abort_handler;
?? OLDTITLE ??
?? EJECT ??

    VAR
      file: clt$file,
      ignore_status: ost$status;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    utility_attributes [1].command_table := command_table;
    utility_attributes [2].function_processor_table := function_table;
    pmp$establish_condition_handler (abort_condition, ^abort_handler, ^abort_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$library].specified) THEN
      clp$convert_string_to_file (pvt [p$library].value^.file_value^, file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      open_object_library (file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;


    clp$begin_utility (utility_name, utility_attributes, status);
    ocp$abort_if_abnormal_status (status);

    clp$include_file (command_file, '', utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (utility_name, ignore_status);

  PROCEND ocp$_analyze_object_library;
?? OLDTITLE ??

MODEND ocm$analyze_object_library;
*DECK DECK=OCM$ANAOL_DISPLAY_HANDLERS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$anaol_display_handlers;



{ PURPOSE:
{   This module contains the display handlers for ANALYZE_OBJECT_LIBRARY.


?? PUSH (LISTEXT := ON) ??
*copyc oct$anaol_types
?? POP ??
*copyc ocp$open_output_file
*copyc ocp$output
*copyc ocp$output_section_kind
*copyc ocp$output_access_attributes
*copyc ocp$close_output_file

*copyc ocp$analyze_load_module
*copyc ocp$internal_error
*copyc ocp$abort_if_abnormal_status
*copyc ocp$abort_if_segment_overflow

*copyc pmp$get_last_path_name
?? NEWTITLE := '  Global Declarations', EJECT ??

  VAR
    ocv$command_sequence: [XREF] ^SEQ ( * ),
    ocv$library_sequence: [XREF] ^SEQ ( * );




  CONST
    end_of_line = TRUE,
    continue = FALSE;


  VAR
    v$page_header: [STATIC] string (58) := 'Analysis of Object Library ',
    strng: string (131),
    lngth: integer;

?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_RECORD_ANALYSIS', EJECT ??

  PROCEDURE display_record_analysis
    (    record_analysis: ^oct$record_analysis);


    VAR
      order: [STATIC, READ] array [llt$object_record_kind] of llt$object_record_kind :=
            [llc$identification, llc$libraries, llc$section_definition, llc$allotted_section_definition,
            llc$unallocated_common_block, llc$obsolete_segment_definition, llc$obsolete_allotted_seg_def,
            llc$segment_definition, llc$allotted_segment_definition, llc$text, llc$replication,
            llc$bit_string_insertion, llc$ppu_absolute, llc$68000_absolute, llc$address_formulation,
            llc$external_linkage, llc$entry_definition, llc$deferred_entry_points, llc$deferred_common_blocks,
            llc$relocation, llc$binding_template, llc$obsolete_line_table, llc$cybil_symbol_table_fragment,
            llc$line_table_fragment, llc$symbol_table_fragment, llc$line_table, llc$symbol_table,
            llc$supplemental_debug_tables, llc$actual_parameters, llc$obsolete_formal_parameters,
            llc$formal_parameters, llc$ses_reserved_1, llc$ses_reserved_2, llc$ses_reserved_3,
            llc$transfer_symbol, llc$form_definition, llc$application_identifier],


      record_kind: [STATIC, READ] array [llt$object_record_kind] of string (38) := [
            {} '     Identification records:          ', {} '     Libraries:                       ',
            {} '     Section definitions:             ', {} '     Text records:                    ',
            {} '     Replication records:             ', {} '     Bit string insertion records:    ',
            {} '     Entry definitions:               ', {} '     Relocation records:              ',
            {} '     Address formulation records:     ', {} '     External linkage records:        ',
            {} '     Obsolete Formal parameters:      ', {} '     Actual parameters:               ',
            {} '     Binding templates:               ', {} '     PPU absolute records:            ',
            {} '     Obsolete line table records:     ', {} '     Cybil symbol table fragments:    ',
            {} '     Allotted section definitions:    ', {} '     Symbol table records:            ',
            {} '     Transfer symbols:                ', {} '     SES reserved 1:                  ',
            {} '     SES reserved 2:                  ', {} '     SES reserved 3:                  ',
            {} '     M68000 absolute records:         ', {} '     Line table records:              ',
            {} '     Line table fragments:            ', {} '     symbol table fragments:          ',
            {} '     Obsolete segment definitions:    ', {} '     Obsolete allotted segment defs:  ',
            {} '     Formal parameters:               ', {} '     Unallocated common blocks:       ',
            {} '     Form definitions:                ', {} '     Application_identifiers:         ',
            {} '     Segment definitions:             ', {} '     Allotted segment definitions:    ',
            {} '     Supplemental debug tables:       ', {} '     Deferred entry points:           ',
            {} '     Deferred common blocks:          '],

      k: llt$object_record_kind,
      kind: llt$object_record_kind;


    ocp$output ('0', '  Record Analysis', 17, end_of_line);
    ocp$output (' ', '  ~~~~~~~~~~~~~~~', 17, end_of_line);

    FOR k := LOWERVALUE (llt$object_record_kind) TO UPPERVALUE (llt$object_record_kind) DO
      kind := order [k];
      IF (record_analysis^.kind [kind].number <> 0) THEN
        STRINGREP (strng, lngth, record_analysis^.kind [kind].number: 8);

        IF (record_analysis^.kind [kind].number_of_items <> 0) THEN
          ocp$output (record_kind [kind], strng, lngth, continue);

          STRINGREP (strng, lngth, record_analysis^.kind [kind].number_of_items: 8);
          ocp$output ('   items:', strng, lngth, end_of_line);
        ELSE
          ocp$output (record_kind [kind], strng, lngth, end_of_line);
        IFEND;
      IFEND;
    FOREND;


    ocp$output ('                                      ', '--------', 8, end_of_line);
    STRINGREP (strng, lngth, record_analysis^.total: 8);
    ocp$output ('       Total records:                 ', strng, lngth, end_of_line);


  PROCEND display_record_analysis;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_SECTION', EJECT ??

  PROCEDURE display_section
    (    section_: oct$section);


    VAR
      ignore: boolean;


    IF section_.segment_definition THEN
      ocp$output ('     Segment: ', section_.definition^.name, 31, continue);
    ELSE
      ocp$output ('     Section: ', section_.definition^.name, 31, continue);
    IFEND;

    STRINGREP (strng, lngth, section_.definition^.length: 12, ' bytes');
    ocp$output (' ', strng, lngth, continue);

    IF section_.allotted THEN
      ocp$output ('  ', 'ALLOTTED   ', 11, continue);
    ELSEIF section_.unallocated_common_block THEN
      ocp$output ('  ', 'UNALLOCATED', 11, continue);
    ELSE
      ocp$output ('  ', '           ', 11, continue);
    IFEND;

    ocp$output_section_kind (^section_.definition^.kind, continue, ignore);

    ocp$output_access_attributes (section_.definition^.access_attributes, end_of_line);

    IF ((section_.bytes_initialized + section_.externals_in + section_.addresses_in +
          section_.addresses_to) <> 0) THEN
      ocp$output ('', '     ', 5, continue);
      IF (section_.bytes_initialized <> 0) THEN
        STRINGREP (strng, lngth, section_.bytes_initialized);
        ocp$output ('  Bytes initialized:', strng, lngth, continue);
      IFEND;
      IF (section_.externals_in <> 0) THEN
        STRINGREP (strng, lngth, section_.externals_in);
        ocp$output ('  Externals in:', strng, lngth, continue);
      IFEND;
      IF (section_.addresses_in <> 0) THEN
        STRINGREP (strng, lngth, section_.addresses_in);
        ocp$output ('  Addresses in:', strng, lngth, continue);
      IFEND;
      IF (section_.addresses_to <> 0) THEN
        STRINGREP (strng, lngth, section_.addresses_to);
        ocp$output ('  Addresses to:', strng, lngth, continue);
      IFEND;

      ocp$output ('', ' ', 1, end_of_line);
    IFEND;


  PROCEND display_section;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_SECTION_ANALYSIS', EJECT ??

  PROCEDURE display_section_analysis
    (    sections: ^oct$sections);


    VAR
      i: llt$section_ordinal;


    ocp$output ('0', '  Section Analysis', 18, end_of_line);
    ocp$output (' ', '  ~~~~~~~~~~~~~~~~', 18, end_of_line);

    FOR i := LOWERBOUND (sections^) TO UPPERBOUND (sections^) DO
      IF sections^ [i].definition <> NIL THEN
        display_section (sections^ [i]);
      IFEND;
    FOREND;


  PROCEND display_section_analysis;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_LIBRARY_ANALYSIS', EJECT ??

  PROCEDURE display_library_analysis
    (    object_library: ^oct$object_library;
         display_options: oct$anaol_display_options);


    VAR
      i: integer;


    IF (occ$display_number_of_modules IN display_options) THEN
      STRINGREP (strng, lngth, object_library^.number_of_modules);
      ocp$output ('0  Number of modules: ', strng, lngth, end_of_line);
    IFEND;

    IF (occ$display_record_analysis IN display_options) THEN
      FOR i := 1 TO object_library^.number_of_modules DO
        ocp$analyze_load_module (object_library, ^object_library^.module_list^ [i], display_options);
      FOREND;

      display_record_analysis (object_library^.record_analysis);
    IFEND;


  PROCEND display_library_analysis;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_MODULE_ANALYSIS', EJECT ??

  PROCEDURE display_module_analysis
    (    object_library: ^oct$object_library;
         display_options: oct$anaol_display_options);


    VAR
      next_module: ^oct$module_item;


    next_module := object_library^.module_list^ [occ$head_of_list].link;

    WHILE (next_module <> NIL) DO
      ocp$output ('1Module Analysis of ', next_module^.name, #SIZE (next_module^.name), end_of_line);

      ocp$analyze_load_module (object_library, next_module, display_options);

      IF (occ$display_record_analysis IN display_options) THEN
        display_record_analysis (next_module^.record_analysis);
      IFEND;
      IF (occ$display_section_analysis IN display_options) THEN
        display_section_analysis (next_module^.record_analysis^.sections);
      IFEND;

      next_module := next_module^.link;
    WHILEND;


  PROCEND display_module_analysis;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_SECTION_USAGE', EJECT ??

  PROCEDURE display_section_usage
    (    object_library: ^oct$object_library;
         section_kinds: oct$section_kinds;
         access_attributes: llt$section_access_attributes;
         section_name: pmt$program_name);


    VAR
      display_options: [STATIC, READ] oct$anaol_display_options := [occ$display_section_analysis],
      occ$all_access_attributes: [XREF] llt$section_access_attributes,
      title_printed: boolean,
      next_module: ^oct$module_item,
      sections: ^oct$sections,
      i: llt$section_ordinal;


    next_module := object_library^.module_list^ [occ$head_of_list].link;

    WHILE (next_module <> NIL) DO
      ocp$analyze_load_module (object_library, next_module, display_options);

      sections := next_module^.record_analysis^.sections;

      IF (sections <> NIL) THEN
        title_printed := FALSE;

        FOR i := LOWERBOUND (sections^) TO UPPERBOUND (sections^) DO

          IF (sections^ [i].definition <> NIL) AND (sections^ [i].definition^.kind IN section_kinds) AND {}
                ((access_attributes = occ$all_access_attributes) OR {}
                (access_attributes = sections^ [i].definition^.access_attributes)) AND {}
                ((section_name = occ$any_section_name) OR (section_name = sections^ [i].definition^.name))
                THEN

            IF NOT title_printed THEN
              ocp$output ('1Section Usage of ', next_module^.name, #SIZE (next_module^.name), end_of_line);
              title_printed := TRUE;
            IFEND;

            display_section (sections^ [i]);
          IFEND;
        FOREND;
      IFEND;

      next_module := next_module^.link;
    WHILEND;


  PROCEND display_section_usage;
?? OLDTITLE ??
?? NEWTITLE := '  OUT70', EJECT ??

  PROCEDURE [INLINE] out70
    (    strng: string (70));


    ocp$output ('     ', strng, 70, end_of_line);

  PROCEND out70;
?? OLDTITLE ??
?? NEWTITLE := '  SYMBOL_TABLE_DESC', EJECT ??

  PROCEDURE symbol_table_desc;

    out70 ('  Symbol table records can be extremely large and use up a            ');
    out70 ('considerable amount of disk space.  Modules with symbol tables        ');
    out70 ('also take slightly longer to load than modules without symbol         ');
    out70 ('tables.  However, removing symbol tables significantly reduces        ');
    out70 ('the ability to debug failures in a program.                           ');
    out70 ('                                                                      ');
    out70 ('  Symbol table records can be removed from a module by either         ');
    out70 ('recompiling the module specifying DEBUG_AIDS=NONE, or by using        ');
    out70 ('the CHANGE_MODULE_ATTRIBUTES subcommand of CREATE_OBJECT_LIBRARY      ');
    out70 ('specifying OMIT_DEBUG_TABLE=SYMBOL_TABLE.                             ');
    out70 ('                                                                      ');

  PROCEND symbol_table_desc;
?? OLDTITLE ??
?? NEWTITLE := '  LINE_TABLE_DESC', EJECT ??

  PROCEDURE line_table_desc;

    out70 ('  Line table records can be large and use up a considerable           ');
    out70 ('amount of disk space.  Modules with line tables also take             ');
    out70 ('slightly longer to load than modules without line tables.             ');
    out70 ('                                                                      ');
    out70 ('  Line table records can be removed from a module by either           ');
    out70 ('recompiling the module specifying DEBUG_AIDS=NONE, or by using        ');
    out70 ('the CHANGE_MODULE_ATTRIBUTES subcommand of CREATE_OBJECT_LIBRARY      ');
    out70 ('specifying OMIT_DEBUG_TABLE=LINE_TABLE.                               ');
    out70 ('                                                                      ');

  PROCEND line_table_desc;
?? OLDTITLE ??
?? NEWTITLE := '  SUPPLEMENTAL_DEBUG_TABLE_DESC', EJECT ??

  PROCEDURE supplemental_debug_table_desc;

    out70 ('  Supplemental debug table records can be large and use up a          ');
    out70 ('considerable amount of disk space.  Modules with supplemental         ');
    out70 ('debug tables also take slightly longer to load than modules           ');
    out70 ('without supplemental debug tables.                                    ');
    out70 ('                                                                      ');
    out70 ('  Supplemental debug table records can be removed from a module by    ');
    out70 ('either recompiling the module specifying DEBUG_AIDS=NONE, or by using ');
    out70 ('the CHANGE_MODULE_ATTRIBUTES subcommand of CREATE_OBJECT_LIBRARY      ');
    out70 ('specifying OMIT_DEBUG_TABLE=SUPPLEMENTAL_DEBUG_TABLE.                 ');
    out70 ('                                                                      ');

  PROCEND supplemental_debug_table_desc;
?? OLDTITLE ??
?? NEWTITLE := '  PARAMETER_CHECKING_DESC', EJECT ??

  PROCEDURE parameter_checking_desc;

    out70 ('  Parameter checking records can significantly increase the           ');
    out70 ('load time of a module.  Since the same information is checked         ');
    out70 ('every time a module is loaded, it is a good idea to turn off          ');
    out70 ('parameter checking before putting a large program into production.    ');
    out70 ('                                                                      ');
    out70 ('  Parameter checking records can be removed from a module by either   ');
    out70 ('recompiling the module specifying DEBUG_AIDS=NONE, or by using        ');
    out70 ('the CHANGE_MODULE_ATTRIBUTES subcommand of CREATE_OBJECT_LIBRARY      ');
    out70 ('specifying OMIT_DEBUG_TABLE=PARAMETER_CHECKING.                       ');
    out70 ('                                                                      ');

  PROCEND parameter_checking_desc;
?? OLDTITLE ??
?? NEWTITLE := '  RUNTIME_CHECKING_DESC', EJECT ??

  PROCEDURE runtime_checking_desc;

    out70 ('  Runtime range checking of variables, subscript expressions, and     ');
    out70 ('character substring expressions can significantly increase the        ');
    out70 ('execution time of a module.  The actual increase depends on the       ');
    out70 ('runtime checking options selected at compile time and the language    ');
    out70 ('the program is written in.                                            ');
    out70 ('                                                                      ');
    out70 ('  Runtime checking can be removed from a module by recompiling the    ');
    out70 ('module specifying RUNTIME_CHECKS=NONE.                                ');
    out70 ('                                                                      ');

  PROCEND runtime_checking_desc;
?? OLDTITLE ??
?? NEWTITLE := '  RUNTIME_LIBRARY_CALLS_DESC', EJECT ??

  PROCEDURE runtime_library_calls_desc;

    out70 ('  Modules which contain external references to runtime library        ');
    out70 ('routines take longer to load, and execute slower than a single        ');
    out70 ('module bound with the runtime library routines it calls.              ');
    out70 ('However, the bound module''s copy of the runtime library code          ');
    out70 ('is not sharable with other programs.                                  ');
    out70 ('                                                                      ');
    out70 ('  A bound module can be built using the CREATE_OBJECT_LIBRARY         ');
    out70 ('subcommands ADD_MODULE, DISPLAY_NEW_LIBRARY, SATISFY_EXTERNAL_        ');
    out70 ('REFERENCES, CREATE_MODULE, and GENERATE_LIBRARY.  The runtime         ');
    out70 ('libraries to specify on the SATISFY_EXTERNAL_REFERENCES command       ');
    out70 ('can be obtained by doing DISPLAY_NEW_LIBRARY DO=LIBRARY.              ');
    out70 ('                                                                      ');

  PROCEND runtime_library_calls_desc;
?? OLDTITLE ??
?? NEWTITLE := '  RUNTIME_LIBRARIES_DESC', EJECT ??

  PROCEDURE runtime_libraries_desc;

    out70 ('  Modules which contain text imbedded runtime library records         ');
    out70 ('take longer to load than modules without runtime library records.     ');
    out70 ('Any libraries which are not required during loading should be         ');
    out70 ('omitted.                                                              ');
    out70 ('                                                                      ');
    out70 ('  After all the runtime library calls from a module have been         ');
    out70 ('satisfied, runtime library records can be omitted using the           ');
    out70 ('CHANGE_MODULE_ATTRIBUTES subcommand of CREATE_OBJECT_LIBRARY          ');
    out70 ('specifying OMIT_LIBRARY=( list of libraries ).  The library names     ');
    out70 ('to omit can be obtained by doing DISPLAY_NEW_LIBRARY DO=LIBRARY.      ');
    out70 ('                                                                      ');

  PROCEND runtime_libraries_desc;
?? OLDTITLE ??
?? NEWTITLE := '  OPT_DEBUG_DESC', EJECT ??

  PROCEDURE opt_debug_desc;

    out70 ('  Object code which is generated at an optimization level of          ');
    out70 ('DEBUG executes slower than object code generated at optimization      ');
    out70 ('levels of LOW or HIGH.                                                ');
    out70 ('                                                                      ');
    out70 ('  Execution time can be reduced by recompiling the module             ');
    out70 ('specifying OPTIMIZATION=LOW or OPTIMIZATION=HIGH.                     ');
    out70 ('                                                                      ');

  PROCEND opt_debug_desc;
?? OLDTITLE ??
?? NEWTITLE := '  OPT_LOW_DESC', EJECT ??

  PROCEDURE opt_low_desc;

    out70 ('  Object code which is generated at an optimization level of          ');
    out70 ('LOW executes slower than object code generated at optimization        ');
    out70 ('level HIGH.                                                           ');
    out70 ('                                                                      ');
    out70 ('  Execution time can be reduced by recompiling the module             ');
    out70 ('specifying OPTIMIZATION=HIGH.                                         ');
    out70 ('                                                                      ');

  PROCEND opt_low_desc;
?? OLDTITLE ??
?? NEWTITLE := '  OBJECT_MODULES_DESC', EJECT ??

  PROCEDURE object_modules_desc;

    out70 ('  Modules which exist on object libraries will load faster and        ');
    out70 ('execute slightly faster than modules which exist on object            ');
    out70 ('files.  Also, the code and read only data in a module can be          ');
    out70 ('be shared when the module is on an object library.                    ');
    out70 ('                                                                      ');
    out70 ('  An object library can be created using the ADD_MODULE,              ');
    out70 ('CREATE_MODULE, or CREATE_LINKED_MODULE subcommands of the             ');
    out70 ('CREATE_OBJECT_LIBRARY utility.                                        ');
    out70 ('                                                                      ');

  PROCEND object_modules_desc;
?? OLDTITLE ??
?? NEWTITLE := '  LOAD_MODULES_DESC', EJECT ??

  PROCEDURE load_modules_desc;

    out70 ('  A program which is made up of a number of unbound load              ');
    out70 ('modules will take longer to load and will execute slower              ');
    out70 ('than a module which has been bound into a single bound                ');
    out70 ('module.                                                               ');
    out70 ('                                                                      ');
    out70 ('  A bound module can be created using the CREATE_MODULE               ');
    out70 ('subcommand of the CREATE_OBJECT_LIBRARY utility.                      ');
    out70 ('                                                                      ');

  PROCEND load_modules_desc;
?? OLDTITLE ??
?? NEWTITLE := '  BOUND_MODULES_DESC', EJECT ??

  PROCEDURE bound_modules_desc;

    out70 ('  A bound module that has been prelinked can take significantly       ');
    out70 ('less time to load than the original bound module.                     ');
    out70 ('                                                                      ');
    out70 ('  A prelinked module can be created using the CREATE_LINKED_MODULE    ');
    out70 ('subcommand of the CREATE_OBJECT_LIBRARY utility.                      ');
    out70 ('                                                                      ');

  PROCEND bound_modules_desc;
?? OLDTITLE ??
?? NEWTITLE := '  UNREFERENCED_SECTIONS_DESC', EJECT ??

  PROCEDURE unreferenced_sections_desc;

    out70 ('  Section definitions which are not initialized and are never         ');
    out70 ('referenced inside an object module, unnecessarily increase the        ');
    out70 ('load time of the module.                                              ');
    out70 ('                                                                      ');
    out70 ('  The source of the module can be changed to omit any references      ');
    out70 ('to the empty section, and then recompiled.  The unreferenced          ');
    out70 ('sections can be found by using the ANALYZE_OBJECT_LIBRARY             ');
    out70 ('subcommand DISPLAY_MODULE_ANALYSIS and specifying                     ');
    out70 ('DISPLAY_OPTION=SECTION_ANALYSIS.  Any sections that are not           ');
    out70 ('initialized, and contain no references to or in,  can be              ');
    out70 ('omitted.                                                              ');
    out70 ('                                                                      ');

  PROCEND unreferenced_sections_desc;
?? OLDTITLE ??
?? NEWTITLE := '  MULTIPLE_ENTRY_POINTS_DESC', EJECT ??

  PROCEDURE multiple_entry_points_desc;

    out70 ('  Unused entry points in an object module increase the load time      ');
    out70 ('of the module.                                                        ');
    out70 ('                                                                      ');
    out70 ('  Unused entry points can be omitted from a module by using the       ');
    out70 ('CREATE_OBJECT_LIBRARY subcommand CHANGE_MODULE_ATTRIBUTES and         ');
    out70 ('specifying OMIT=( list of entry points ).  A list of a module''s       ');
    out70 ('entry points can be obtained by entering DISPLAY_NEW_LIBRARY          ');
    out70 ('DO=ENTRY_POINT.                                                       ');

  PROCEND multiple_entry_points_desc;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_PROBLEM_MODULES', EJECT ??

  PROCEDURE display_problem_modules
    (    object_library: ^oct$object_library;
         problem: oct$anaol_performance_problem;
         display_options: oct$anaol_performance_options);


    VAR
      problem_list: [STATIC, READ] array [oct$anaol_performance_problem] of record
        strng: string (43),
        description: ^procedure,
      recend := [

      {} ['   Modules with SYMBOL_TABLES:             ', ^symbol_table_desc],
            {} ['   Modules with LINE_TABLES:               ', ^line_table_desc],
            {} ['   Modules with PARAMETER_CHECKING:        ', ^parameter_checking_desc],
            {} ['   Modules with RUNTIME_CHECKING:          ', ^runtime_checking_desc],
            {} ['   Modules with RUNTIME_LIBRARY_CALLS:     ', ^runtime_library_calls_desc],
            {} ['   Modules with RUNTIME_LIBRARIES:         ', ^runtime_libraries_desc],
            {} ['   Modules compiled at OPT_DEBUG:          ', ^opt_debug_desc],
            {} ['   Modules compiled at OPT_LOW:            ', ^opt_low_desc],
            {} ['   Modules that are OBJECT_MODULES:        ', ^object_modules_desc],
            {} ['   Modules that are LOAD_MODULES:          ', ^load_modules_desc],
            {} ['   Modules that are BOUND_MODULES:         ', ^bound_modules_desc],
            {} ['   Modules with UNREFERENCED_SECTIONS:     ', ^unreferenced_sections_desc],
            {} ['      with MULTIPLE_ENTRY_POINTS:          ', ^multiple_entry_points_desc],
            {} ['   Modules with SUPPLEMENTAL_DEBUG_TABLES: ', ^supplemental_debug_table_desc]];

?? EJECT ??

    VAR
      count: integer,
      next_module: ^oct$module_item;

    count := 0;
    next_module := object_library^.module_list^ [occ$head_of_list].link;

    WHILE (next_module <> NIL) DO
      IF (problem IN next_module^.record_analysis^.performance_problems) THEN
        count := count + 1;
      IFEND;

      next_module := next_module^.link;
    WHILEND;

    IF (count > 0) THEN
      IF (problem = occ$multiple_entry_points) THEN
        ocp$output ('   ', 'Bound or prelinked modules', 26, end_of_line);
      IFEND;

      STRINGREP (strng, lngth, count: 5);
      ocp$output (problem_list [problem].strng, strng, lngth, end_of_line);

      IF (occ$display_module_names IN display_options) THEN
        next_module := object_library^.module_list^ [occ$head_of_list].link;

        WHILE (next_module <> NIL) DO
          IF (problem IN next_module^.record_analysis^.performance_problems) THEN
            ocp$output ('     ', next_module^.name, #SIZE (next_module^.name), end_of_line);
          IFEND;
          next_module := next_module^.link;
        WHILEND;

        ocp$output (' ', ' ', 1, end_of_line);
      IFEND;

      IF (occ$display_description IN display_options) THEN
        problem_list [problem].description^;
      IFEND;
    IFEND;


  PROCEND display_problem_modules;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_PERFORMANCE_ANALYSIS', EJECT ??

  PROCEDURE display_performance_analysis
    (    object_library: ^oct$object_library;
         performance_problems: oct$anaol_performance_problems;
         display_options: oct$anaol_performance_options);

    VAR
      analysis_options: [STATIC, READ] oct$anaol_display_options := [occ$display_record_analysis],
      next_module: ^oct$module_item,
      problem: oct$anaol_performance_problem;


    next_module := object_library^.module_list^ [occ$head_of_list].link;

    WHILE (next_module <> NIL) DO
      ocp$analyze_load_module (object_library, next_module, analysis_options);

      next_module := next_module^.link;
    WHILEND;

    ocp$output (' ', ' ', 1, end_of_line);

    FOR problem := LOWERVALUE (oct$anaol_performance_problem) TO UPPERVALUE (oct$anaol_performance_problem) DO
      IF (problem IN performance_problems) THEN
        display_problem_modules (object_library, problem, display_options);
      IFEND;
    FOREND;

  PROCEND display_performance_analysis;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$DISPLAY_LIBRARY_ANALYSIS', EJECT ??

  PROCEDURE [XDCL] ocp$display_library_analysis
    (    object_library: ^oct$object_library;
         display_options: oct$anaol_display_options;
         output: clt$file;
     VAR status: ost$status);


    VAR
      library_name: amt$local_file_name;


    pmp$get_last_path_name (object_library^.file.local_file_name, library_name, status);
    ocp$abort_if_abnormal_status (status);

    v$page_header (28, 31) := library_name;
    ocp$open_output_file (output.local_file_name, ^v$page_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$output ('1Library Analysis of ', library_name, #SIZE (library_name), end_of_line);

    display_library_analysis (object_library, display_options);

    ocp$output (' ', ' ', 1, end_of_line);

    ocp$close_output_file (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


  PROCEND ocp$display_library_analysis;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$DISPLAY_MODULE_ANALYSIS', EJECT ??

  PROCEDURE [XDCL] ocp$display_module_analysis
    (    object_library: ^oct$object_library;
         display_options: oct$anaol_display_options;
         output: clt$file;
     VAR status: ost$status);


    pmp$get_last_path_name (object_library^.file.local_file_name, v$page_header (28, 31), status);
    ocp$abort_if_abnormal_status (status);

    ocp$open_output_file (output.local_file_name, ^v$page_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_module_analysis (object_library, display_options);

    ocp$output (' ', ' ', 1, end_of_line);

    ocp$close_output_file (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


  PROCEND ocp$display_module_analysis;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$DISPLAY_SECTION_USAGE', EJECT ??

  PROCEDURE [XDCL] ocp$display_section_usage
    (    object_library: ^oct$object_library;
         section_kinds: oct$section_kinds;
         access_attributes: llt$section_access_attributes;
         section_name: pmt$program_name;
         output: clt$file;
     VAR status: ost$status);


    pmp$get_last_path_name (object_library^.file.local_file_name, v$page_header (28, 31), status);
    ocp$abort_if_abnormal_status (status);

    ocp$open_output_file (output.local_file_name, ^v$page_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_section_usage (object_library, section_kinds, access_attributes, section_name);

    ocp$output (' ', ' ', 1, end_of_line);

    ocp$close_output_file (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


  PROCEND ocp$display_section_usage;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$DISPLAY_PERFORMANCE_ANAL', EJECT ??

  PROCEDURE [XDCL] ocp$display_performance_anal
    (    object_library: ^oct$object_library;
         performance_problems: oct$anaol_performance_problems;
         display_options: oct$anaol_performance_options;
         output: clt$file;
     VAR status: ost$status);


    VAR
      library_name: amt$local_file_name;


    pmp$get_last_path_name (object_library^.file.local_file_name, library_name, status);
    ocp$abort_if_abnormal_status (status);

    v$page_header (28, 31) := library_name;
    ocp$open_output_file (output.local_file_name, ^v$page_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$output ('1Performance Analysis of ', library_name, #SIZE (library_name), end_of_line);

    display_performance_analysis (object_library, performance_problems, display_options);

    ocp$output (' ', ' ', 1, end_of_line);

    ocp$close_output_file (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


  PROCEND ocp$display_performance_anal;
?? OLDTITLE ??
MODEND ocm$anaol_display_handlers;
*DECK DECK=OCM$ANAOL_LIBRARY_SCANNERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Management : Analyze Object Library' ??
MODULE ocm$anaol_library_scanners;

{ PURPOSE:
{   This module contains the routines for analyzing information from an object library.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc llt$deferred_common_blocks
*copyc llt$deferred_entry_points
*copyc llt$section_address
*copyc oct$anaol_types
?? POP ??
*copyc ocp$internal_error
*copyc ocp$abort_if_segment_overflow
*copyc ocp$abort_if_premature_eof
*copyc ocp$abort_with_structure_error
*copyc ocp$convert_information_element
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    ocv$library_sequence: [XREF] ^SEQ ( * );

?? OLDTITLE ??
?? NEWTITLE := 'find_module_dictionary', EJECT ??

  PROCEDURE find_module_dictionary
    (    object_library: ^oct$object_library;
     VAR module_dictionary: ^llt$module_dictionary);


    VAR
      object_library_header: ^llt$object_library_header,
      library_dictionary: ^llt$object_library_dictionaries,
      i: integer;


    RESET object_library^.sequence;

    NEXT object_library_header IN object_library^.sequence;
    ocp$abort_if_premature_eof (^object_library_header, object_library^.file);

    IF (object_library_header^.version <> llc$object_library_version) THEN
      ocp$abort_with_structure_error ('Invalid object library version', object_library^.file);
    IFEND;

    NEXT library_dictionary: [1 .. object_library_header^.number_of_dictionaries] IN object_library^.sequence;
    ocp$abort_if_premature_eof (^library_dictionary, object_library^.file);

    FOR i := LOWERBOUND (library_dictionary^) TO UPPERBOUND (library_dictionary^) DO
      CASE library_dictionary^ [i].kind OF
      = llc$module_dictionary =
        module_dictionary := #PTR (library_dictionary^ [i].module_dictionary, object_library^.sequence^);
        RETURN;
      ELSE
      CASEND;
    FOREND;

    module_dictionary := NIL;


  PROCEND find_module_dictionary;
?? OLDTITLE ??
?? NEWTITLE := 'build_load_module_list', EJECT ??

  PROCEDURE build_load_module_list
    (    object_library: ^oct$object_library;
         module_dictionary: ^llt$module_dictionary);


    VAR
      library_sequence: ^SEQ ( * ),
      i: integer,
      module_item: ^oct$module_item;


    library_sequence := ocv$library_sequence;
    object_library^.number_of_modules := 0;

    NEXT module_item IN library_sequence;
    ocp$abort_if_segment_overflow (^module_item);

    module_item^.name := '* Head of Module List *';
    module_item^.load_module_header := NIL;
    module_item^.interpretive_records := NIL;
    module_item^.record_analysis := NIL;

    IF (module_dictionary <> NIL) THEN
      FOR i := LOWERBOUND (module_dictionary^) TO UPPERBOUND (module_dictionary^) DO
        CASE module_dictionary^ [i].kind OF
        = llc$load_module =
          NEXT module_item IN library_sequence;
          ocp$abort_if_segment_overflow (^module_item);

          object_library^.number_of_modules := object_library^.number_of_modules + 1;

          module_item^.name := module_dictionary^ [i].name;
          module_item^.load_module_header := #PTR (module_dictionary^ [i].module_header,
                object_library^.sequence^);
          module_item^.interpretive_records := #PTR (module_item^.load_module_header^.interpretive_element,
                object_library^.sequence^);
          ocp$abort_if_premature_eof (^module_item^.interpretive_records, object_library^.file);

          module_item^.record_analysis := NIL;
        ELSE
        CASEND;
      FOREND;
    IFEND;

    NEXT object_library^.module_list: [0 .. object_library^.number_of_modules] IN ocv$library_sequence;
    ocp$abort_if_segment_overflow (^object_library^.module_list);


  PROCEND build_load_module_list;
?? OLDTITLE ??
?? NEWTITLE := 'build_object_module_list', EJECT ??

  PROCEDURE build_object_module_list
    (    object_library: ^oct$object_library);


    VAR
      module_list: oct$module_item,
      module_item: ^oct$module_item,
      object_file: ^SEQ ( * ),
      object_text_descriptor: ^llt$object_text_descriptor,
      identification: ^llt$identification,
      analysis_options: oct$anaol_display_options,
      record_analysis: ^oct$record_analysis,
      i: integer;


    object_library^.number_of_modules := 0;

    module_item := ^module_list;
    module_item^.name := '* Head of Module List *';
    module_item^.load_module_header := NIL;
    module_item^.interpretive_records := NIL;
    module_item^.record_analysis := NIL;
    module_item^.link := NIL;

    RESET object_library^.sequence;

    analysis_options := -$oct$anaol_display_options []; { Temporary }

    REPEAT
      object_file := object_library^.sequence;
      NEXT object_text_descriptor IN object_file;
      NEXT identification IN object_file;

      IF (identification <> NIL) THEN
        PUSH module_item^.link;
        module_item := module_item^.link;
        ocp$abort_if_segment_overflow (^module_item);

        object_library^.number_of_modules := object_library^.number_of_modules + 1;

        module_item^.name := identification^.name;
        module_item^.load_module_header := NIL;
        module_item^.interpretive_records := object_text_descriptor;
        module_item^.record_analysis := NIL;
        module_item^.link := NIL;

        initialize_record_analysis (record_analysis);
        analyze_interpretive_records (object_library, module_item, record_analysis, analysis_options);

        update_record_analysis (record_analysis, object_library^.record_analysis^);
        module_item^.record_analysis := record_analysis;
      IFEND;
    UNTIL (identification = NIL);

    NEXT object_library^.module_list: [0 .. object_library^.number_of_modules] IN ocv$library_sequence;
    ocp$abort_if_segment_overflow (^object_library^.module_list);

    module_item := ^module_list;
    FOR i := 0 TO object_library^.number_of_modules DO
      object_library^.module_list^ [i] := module_item^;
      module_item := module_item^.link;
    FOREND;


  PROCEND build_object_module_list;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_record_analysis', EJECT ??

  PROCEDURE initialize_record_analysis
    (VAR record_analysis: ^oct$record_analysis);


    VAR
      record_kind: llt$object_record_kind;


    NEXT record_analysis IN ocv$library_sequence;
    ocp$abort_if_segment_overflow (^record_analysis);

    record_analysis^.total := 0;

    FOR record_kind := LOWERBOUND (record_analysis^.kind) TO UPPERBOUND (record_analysis^.kind) DO
      record_analysis^.kind [record_kind].number := 0;
      record_analysis^.kind [record_kind].number_of_items := 0;
    FOREND;

    record_analysis^.sections := NIL;
    record_analysis^.performance_problems := $oct$anaol_performance_problems [];

  PROCEND initialize_record_analysis;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$initialize_object_library', EJECT ??

  PROCEDURE [XDCL] ocp$initialize_object_library
    (    file_structure_is_library: boolean;
         object_library: ^oct$object_library);


    VAR
      module_dictionary: ^llt$module_dictionary;


    initialize_record_analysis (object_library^.record_analysis);

    IF file_structure_is_library THEN
      find_module_dictionary (object_library, module_dictionary);

      build_load_module_list (object_library, module_dictionary);
    ELSE
      build_object_module_list (object_library);
    IFEND;


  PROCEND ocp$initialize_object_library;
?? OLDTITLE ??
?? NEWTITLE := 'update_record_analysis', EJECT ??

  PROCEDURE update_record_analysis
    (    record_analysis: ^oct$record_analysis;
     VAR updated_analysis: oct$record_analysis);


    VAR
      record_kind: llt$object_record_kind;


    updated_analysis.total := updated_analysis.total + record_analysis^.total;

    FOR record_kind := LOWERBOUND (record_analysis^.kind) TO UPPERBOUND (record_analysis^.kind) DO
      updated_analysis.kind [record_kind].number := updated_analysis.kind [record_kind].number +
            record_analysis^.kind [record_kind].number;
      updated_analysis.kind [record_kind].number_of_items :=
            updated_analysis.kind [record_kind].number_of_items +
            record_analysis^.kind [record_kind].number_of_items;
    FOREND;


  PROCEND update_record_analysis;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_module_for_performance', EJECT ??

  PROCEDURE analyze_module_for_performance
    (    object_module: boolean;
         identification: ^llt$identification;
         ra: ^oct$record_analysis);


    VAR
      binder_or_prelinker: [STATIC, READ] set of llt$module_generator :=
            [llc$object_library_generator, llc$virtual_environment_linker],

      i: integer;


    IF (object_module) THEN
      ra^.performance_problems := ra^.performance_problems +
            $oct$anaol_performance_problems [occ$object_module];
    ELSEIF (identification <> NIL) THEN
      IF (identification^.generator_id = llc$object_library_generator) THEN
        ra^.performance_problems := ra^.performance_problems +
              $oct$anaol_performance_problems [occ$bound_module];
      ELSEIF (identification^.generator_id <> llc$virtual_environment_linker) THEN
        ra^.performance_problems := ra^.performance_problems +
              $oct$anaol_performance_problems [occ$load_module];
      IFEND;
    IFEND;

    IF (ra^.kind [llc$symbol_table].number > 0) THEN
      ra^.performance_problems := ra^.performance_problems +
            $oct$anaol_performance_problems [occ$symbol_tables];
    IFEND;

    IF (ra^.kind [llc$line_table].number > 0) THEN
      ra^.performance_problems := ra^.performance_problems + $oct$anaol_performance_problems
            [occ$line_tables];
    IFEND;

    IF (ra^.kind [llc$supplemental_debug_tables].number > 0) THEN
      ra^.performance_problems := ra^.performance_problems +
            $oct$anaol_performance_problems [occ$supplemental_debug_tables];
    IFEND;

    IF ((ra^.kind [llc$actual_parameters].number + ra^.kind [llc$formal_parameters].
          number + ra^.kind [llc$obsolete_formal_parameters].number) > 0) THEN
      ra^.performance_problems := ra^.performance_problems +
            $oct$anaol_performance_problems [occ$parameter_checking];
    IFEND;

    IF (ra^.kind [llc$libraries].number > 0) THEN
      ra^.performance_problems := ra^.performance_problems +
            $oct$anaol_performance_problems [occ$runtime_libraries];
    IFEND;

    IF (ra^.sections <> NIL) THEN
      FOR i := LOWERBOUND (ra^.sections^) TO UPPERBOUND (ra^.sections^) DO
        IF (ra^.sections^ [i].definition <> NIL) THEN
          IF (ra^.sections^ [i].definition^.name (1, 4) = 'DBB$') THEN
            ra^.performance_problems := ra^.performance_problems +
                  $oct$anaol_performance_problems [occ$opt_debug];
          IFEND;

          IF (identification <> NIL) AND (identification^.generator_id <> llc$virtual_environment_linker) THEN
            IF ((ra^.sections^ [i].bytes_initialized + ra^.sections^ [i].externals_in +
                  ra^.sections^ [i].addresses_in + ra^.sections^ [i].addresses_to) = 0) THEN
              ra^.performance_problems := ra^.performance_problems +
                    $oct$anaol_performance_problems [occ$unreferenced_sections];
            IFEND;
          IFEND;
        IFEND;
      FOREND;
    IFEND;


    IF (identification <> NIL) THEN
      IF (identification^.generator_id IN binder_or_prelinker) THEN
        IF (ra^.kind [llc$entry_definition].number > 1) THEN
          ra^.performance_problems := ra^.performance_problems +
                $oct$anaol_performance_problems [occ$multiple_entry_points];
        IFEND;

{ The following code is dependent on the commentary string in the identification record.
{ Some generators do not indicate optimization level or runtime checking options in the
{ commentary string (for example, FORTRAN at Release 1.4.1 indicates optimization but not
{ runtime checking) so these can't be checked here.

      ELSEIF (identification^.generator_id = llc$cybil) OR
            (identification^.generator_id = llc$obsolete_cybil) THEN
        i := 1;

      /runtime_checking_search/
        WHILE ((i + 6) <= #SIZE (identification^.commentary)) DO
          IF (identification^.commentary (i, 3) = 'RC=') THEN
            IF (identification^.commentary (i, 7) <> 'RC=NONE') THEN
              ra^.performance_problems := ra^.performance_problems +
                    $oct$anaol_performance_problems [occ$runtime_checking];
            IFEND;
            EXIT /runtime_checking_search/;
          IFEND;

          i := i + 1;
        WHILEND /runtime_checking_search/;

      /optimization_search/
        WHILE ((i + 4) <= #SIZE (identification^.commentary)) DO
          IF (identification^.commentary (i, 4) = 'OPT=') THEN
            IF (identification^.commentary (i + 4) = 'L') THEN
              ra^.performance_problems := ra^.performance_problems +
                    $oct$anaol_performance_problems [occ$opt_low];
            ELSEIF (identification^.commentary (i + 4) = 'D') THEN
              ra^.performance_problems := ra^.performance_problems +
                    $oct$anaol_performance_problems [occ$opt_debug];
            IFEND;
            EXIT /optimization_search/;
          IFEND;

          i := i + 1;
        WHILEND /optimization_search/;
      ELSEIF (identification^.generator_id = llc$fortran) THEN
        i := 1;

      /ftn_optimization_search/
        WHILE ((i + 4) <= #SIZE (identification^.commentary)) DO
          IF (identification^.commentary (i, 4) = 'OPT=') THEN
            IF (identification^.commentary (i + 4) = 'L') THEN
              ra^.performance_problems := ra^.performance_problems +
                    $oct$anaol_performance_problems [occ$opt_low];
            ELSEIF (identification^.commentary (i + 4) = 'D') THEN
              ra^.performance_problems := ra^.performance_problems +
                    $oct$anaol_performance_problems [occ$opt_debug];
            IFEND;
            EXIT /ftn_optimization_search/;
          IFEND;

          i := i + 1;
        WHILEND /ftn_optimization_search/;


      IFEND;
    IFEND;


  PROCEND analyze_module_for_performance;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_interpretive_records', EJECT ??

  PROCEDURE analyze_interpretive_records
    (    object_library: ^oct$object_library;
         module_item: ^oct$module_item;
         record_analysis: ^oct$record_analysis;
         analysis_options: oct$anaol_display_options);



    VAR
      identification: ^llt$identification; { Used for performance analysis



?? NEWTITLE := 'analyze_object_text_descriptor', EJECT ??

    PROCEDURE analyze_object_text_descriptor
      (VAR kind: llt$object_record_kind;
       VAR size: integer);

      VAR
        object_text_descriptor: ^llt$object_text_descriptor;

      NEXT object_text_descriptor IN object_library^.sequence;
      ocp$abort_if_premature_eof (^object_text_descriptor, object_library^.file);

      CASE object_text_descriptor^.kind OF
      = llc$identification, llc$section_definition, llc$bit_string_insertion, llc$entry_definition,
            llc$binding_template, llc$transfer_symbol, llc$obsolete_segment_definition,
            llc$segment_definition, llc$unallocated_common_block, llc$application_identifier =
        size := 0;
      = llc$libraries =
        size := object_text_descriptor^.number_of_libraries;
      = llc$allotted_section_definition =
        size := object_text_descriptor^.allotted_section;
      = llc$allotted_segment_definition, llc$obsolete_allotted_seg_def =
        size := (object_text_descriptor^.allotted_segment * 100000000(16)) +
              object_text_descriptor^.allotted_segment_length;
      = llc$text, llc$replication =
        size := object_text_descriptor^.number_of_bytes;
      = llc$relocation =
        size := object_text_descriptor^.number_of_rel_items;
      = llc$address_formulation =
        size := object_text_descriptor^.number_of_adr_items;
      = llc$external_linkage =
        size := object_text_descriptor^.number_of_ext_items;
      = llc$obsolete_line_table, llc$line_table =
        size := object_text_descriptor^.number_of_line_items;
      = llc$obsolete_formal_parameters, llc$formal_parameters, llc$actual_parameters,
            llc$cybil_symbol_table_fragment, llc$68000_absolute, llc$symbol_table, llc$form_definition,
            llc$supplemental_debug_tables =
        size := object_text_descriptor^.sequence_length;
      = llc$ppu_absolute =
        size := object_text_descriptor^.number_of_words;
      = llc$deferred_entry_points =
        size := object_text_descriptor^.number_of_entry_points;
      = llc$deferred_common_blocks =
        size := object_text_descriptor^.number_of_common_blocks;
      ELSE
        ocp$abort_with_structure_error ('Invalid object record kind', object_library^.file);
      CASEND;


      kind := object_text_descriptor^.kind;

      IF (occ$display_record_analysis IN analysis_options) THEN
        record_analysis^.total := record_analysis^.total + 1;
        record_analysis^.kind [kind].number := record_analysis^.kind [kind].number + 1;

        IF (kind <> llc$allotted_section_definition) AND (kind <> llc$allotted_segment_definition) AND
              (kind <> llc$obsolete_allotted_seg_def) AND (kind <> llc$replication) THEN
          record_analysis^.kind [kind].number_of_items := record_analysis^.kind [kind].number_of_items + size;
        IFEND;
      IFEND;


    PROCEND analyze_object_text_descriptor;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_identification_record', EJECT ??

    PROCEDURE analyze_identification_record
      (VAR module_kind: llt$module_kind);


      VAR
        i: llt$section_ordinal;


      NEXT identification IN object_library^.sequence;
      ocp$abort_if_premature_eof (^identification, object_library^.file);


      IF (identification^.object_text_version <> 'V1.2') AND
            (identification^.object_text_version <> 'V1.3') AND
            (identification^.object_text_version <> 'V1.4') THEN
        ocp$abort_with_structure_error ('Invalid object text version', object_library^.file);
      IFEND;

      IF (identification^.object_text_version < 'V1.4') AND (identification^.generator_id = llc$cybil) THEN
        ocp$abort_with_structure_error ('CYBIL must be > V1.3', object_library^.file);
      IFEND;

      IF (identification^.kind < LOWERVALUE (llt$module_kind)) OR
            (identification^.kind > UPPERVALUE (llt$module_kind)) THEN
        ocp$abort_with_structure_error ('Invalid module kind', object_library^.file);
      IFEND;


      module_kind := identification^.kind;

      IF (occ$display_record_analysis IN analysis_options) THEN
        NEXT record_analysis^.sections: [0 .. identification^.greatest_section_ordinal] IN
              ocv$library_sequence;
        ocp$abort_if_segment_overflow (^ocv$library_sequence);

        FOR i := 0 TO identification^.greatest_section_ordinal DO
          record_analysis^.sections^ [i].allotted := FALSE;
          record_analysis^.sections^ [i].unallocated_common_block := FALSE;
          record_analysis^.sections^ [i].segment_definition := FALSE;
          record_analysis^.sections^ [i].definition := NIL;
          record_analysis^.sections^ [i].bytes_initialized := 0;
          record_analysis^.sections^ [i].externals_in := 0;
          record_analysis^.sections^ [i].addresses_in := 0;
          record_analysis^.sections^ [i].addresses_to := 0;
          record_analysis^.sections^ [i].internal_binding_section_ptrs := 0;
        FOREND;
      IFEND;


    PROCEND analyze_identification_record;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_section_definition', EJECT ??

    PROCEDURE analyze_section_definition;


      VAR
        section_definition: ^llt$section_definition;


      NEXT section_definition IN object_library^.sequence;
      ocp$abort_if_premature_eof (^section_definition, object_library^.file);


      IF (occ$display_record_analysis IN analysis_options) THEN
        record_analysis^.sections^ [section_definition^.section_ordinal].definition := section_definition;
      IFEND;


    PROCEND analyze_section_definition;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_allotted_section_def', EJECT ??

    PROCEDURE analyze_allotted_section_def
      (    allotted_section: ost$relative_pointer);


      VAR
        section_definition: ^llt$section_definition;


      NEXT section_definition IN object_library^.sequence;
      ocp$abort_if_premature_eof (^section_definition, object_library^.file);


      IF (occ$display_record_analysis IN analysis_options) THEN
        record_analysis^.sections^ [section_definition^.section_ordinal].allotted := TRUE;
        record_analysis^.sections^ [section_definition^.section_ordinal].allotted_section := allotted_section;
        record_analysis^.sections^ [section_definition^.section_ordinal].definition := section_definition;
        record_analysis^.sections^ [section_definition^.section_ordinal].bytes_initialized :=
              section_definition^.length;
      IFEND;


    PROCEND analyze_allotted_section_def;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_unallocated_common_bl', EJECT ??

    PROCEDURE analyze_unallocated_common_bl;


      VAR
        section_definition: ^llt$section_definition;


      NEXT section_definition IN object_library^.sequence;
      ocp$abort_if_premature_eof (^section_definition, object_library^.file);


      IF (occ$display_record_analysis IN analysis_options) THEN
        record_analysis^.sections^ [section_definition^.section_ordinal].unallocated_common_block := TRUE;
        record_analysis^.sections^ [section_definition^.section_ordinal].definition := section_definition;
      IFEND;


    PROCEND analyze_unallocated_common_bl;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_segment_definition', EJECT ??

    PROCEDURE analyze_segment_definition
      (    kind: llt$object_record_kind);


      VAR
        obsolete_segment_definition: ^llt$obsolete_segment_definition,
        section_definition: ^llt$section_definition,
        segment_definition: ^llt$segment_definition;


      IF (kind = llc$segment_definition) THEN
        NEXT segment_definition IN object_library^.sequence;
        ocp$abort_if_premature_eof (^segment_definition, object_library^.file);

        section_definition := ^segment_definition^.section_definition;

      ELSE
        NEXT obsolete_segment_definition IN object_library^.sequence;
        ocp$abort_if_premature_eof (^obsolete_segment_definition, object_library^.file);

        section_definition := ^obsolete_segment_definition^.section_definition;
      IFEND;


      IF (occ$display_record_analysis IN analysis_options) THEN
        record_analysis^.sections^ [section_definition^.section_ordinal].definition := section_definition;
        record_analysis^.sections^ [section_definition^.section_ordinal].segment_definition := TRUE;
      IFEND;


    PROCEND analyze_segment_definition;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_allotted_segment_def', EJECT ??

    PROCEDURE analyze_allotted_segment_def
      (    kind: llt$object_record_kind;
           allotted_section: ost$segment_length;
           allotted_section_length: ost$segment_length);


      VAR
        obsolete_segment_definition: ^llt$obsolete_segment_definition,
        section_definition: ^llt$section_definition,
        segment_definition: ^llt$segment_definition;


      IF (kind = llc$allotted_segment_definition) THEN
        NEXT segment_definition IN object_library^.sequence;
        ocp$abort_if_premature_eof (^segment_definition, object_library^.file);

        section_definition := ^segment_definition^.section_definition;

      ELSE
        NEXT obsolete_segment_definition IN object_library^.sequence;
        ocp$abort_if_premature_eof (^obsolete_segment_definition, object_library^.file);

        section_definition := ^obsolete_segment_definition^.section_definition;
      IFEND;


      IF (occ$display_record_analysis IN analysis_options) THEN
        record_analysis^.sections^ [section_definition^.section_ordinal].allotted := TRUE;
        record_analysis^.sections^ [section_definition^.section_ordinal].allotted_section := allotted_section;
        record_analysis^.sections^ [section_definition^.section_ordinal].segment_definition := TRUE;
        record_analysis^.sections^ [section_definition^.section_ordinal].definition := section_definition;
        IF (allotted_section_length = 0) THEN
          record_analysis^.sections^ [section_definition^.section_ordinal].bytes_initialized :=
                section_definition^.length;
        ELSE
          record_analysis^.sections^ [section_definition^.section_ordinal].bytes_initialized :=
                allotted_section_length;
        IFEND;
      IFEND;


    PROCEND analyze_allotted_segment_def;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_libraries_record', EJECT ??

    PROCEDURE analyze_libraries_record
      (    number_of_libraries: 1 .. llc$max_libraries);


      VAR
        libraries: ^llt$libraries;


      NEXT libraries: [1 .. number_of_libraries] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^libraries, object_library^.file);


    PROCEND analyze_libraries_record;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_text_record', EJECT ??

    PROCEDURE analyze_text_record
      (    number_of_bytes: 1 .. osc$max_segment_length);


      VAR
        text: ^llt$text;


      NEXT text: [1 .. number_of_bytes] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^text, object_library^.file);


      IF (occ$display_record_analysis IN analysis_options) THEN
        record_analysis^.sections^ [text^.section_ordinal].bytes_initialized := record_analysis^.
              sections^ [text^.section_ordinal].bytes_initialized + number_of_bytes;
      IFEND;


    PROCEND analyze_text_record;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_replication_record', EJECT ??

    PROCEDURE analyze_replication_record
      (    number_of_bytes: 1 .. osc$max_segment_length);


      VAR
        replication: ^llt$replication;


      NEXT replication: [1 .. number_of_bytes] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^replication, object_library^.file);


      IF (occ$display_record_analysis IN analysis_options) THEN
        record_analysis^.kind [llc$replication].number_of_items :=
              record_analysis^.kind [llc$replication].number_of_items +
              (replication^.count * number_of_bytes);
        record_analysis^.sections^ [replication^.section_ordinal].bytes_initialized :=
              record_analysis^.sections^ [replication^.section_ordinal].bytes_initialized +
              (replication^.count * number_of_bytes);
      IFEND;


    PROCEND analyze_replication_record;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_bit_insertion_record', EJECT ??

    PROCEDURE analyze_bit_insertion_record;


      VAR
        bit_insertion: ^llt$bit_string_insertion;


      NEXT bit_insertion IN object_library^.sequence;
      ocp$abort_if_premature_eof (^bit_insertion, object_library^.file);


    PROCEND analyze_bit_insertion_record;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_entry_definition_record', EJECT ??

    PROCEDURE analyze_entry_definition_record;


      VAR
        entry_definition: ^llt$entry_definition;


      NEXT entry_definition IN object_library^.sequence;
      ocp$abort_if_premature_eof (^entry_definition, object_library^.file);


    PROCEND analyze_entry_definition_record;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_deferred_entry_pt_rec', EJECT ??

    PROCEDURE analyze_deferred_entry_pt_rec
      (    number_of_entry_points: 1 .. llc$max_deferred_entry_points);

      VAR
        deferred_entry_points: ^llt$deferred_entry_points;


      NEXT deferred_entry_points: [1 .. number_of_entry_points] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^deferred_entry_points, object_library^.file);


    PROCEND analyze_deferred_entry_pt_rec;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_deferred_common_blk_rec', EJECT ??

    PROCEDURE analyze_deferred_common_blk_rec
      (    number_of_common_blocks: 1 .. llc$max_deferred_common_blocks);

      VAR
        deferred_common_blocks: ^llt$deferred_common_blocks;


      NEXT deferred_common_blocks: [1 .. number_of_common_blocks] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^deferred_common_blocks, object_library^.file);


    PROCEND analyze_deferred_common_blk_rec;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_relocation_record', EJECT ??

    PROCEDURE analyze_relocation_record
      (    number_of_rel_items: llt$number_of_info_elements);


      VAR
        relocation: ^llt$relocation;


      NEXT relocation: [1 .. number_of_rel_items] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^relocation, object_library^.file);
    PROCEND analyze_relocation_record;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_obsolete_form_parm_rec', EJECT ??

    PROCEDURE analyze_obsolete_form_parm_rec
      (    sequence_length: ost$segment_length);


      VAR
        obsolete_formal_parameters: ^llt$obsolete_formal_parameters;


      NEXT obsolete_formal_parameters: [[REP sequence_length OF cell]] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^obsolete_formal_parameters, object_library^.file);


    PROCEND analyze_obsolete_form_parm_rec;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_formal_parameter_record', EJECT ??

    PROCEDURE analyze_formal_parameter_record
      (    sequence_length: ost$segment_length);


      VAR
        formal_parameters: ^llt$formal_parameters;


      NEXT formal_parameters: [[REP sequence_length OF cell]] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^formal_parameters, object_library^.file);


    PROCEND analyze_formal_parameter_record;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_actual_parameter_record', EJECT ??

    PROCEDURE analyze_actual_parameter_record
      (    sequence_length: ost$segment_length);


      VAR
        actual_parameters: ^llt$actual_parameters;


      NEXT actual_parameters: [[REP sequence_length OF cell]] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^actual_parameters, object_library^.file);


    PROCEND analyze_actual_parameter_record;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_address_formulation', EJECT ??

    PROCEDURE analyze_address_formulation
      (    number_of_adr_items: 1 .. llc$max_adr_items);


      VAR
        address_formulation: ^llt$address_formulation,
        i: 1 .. llc$max_adr_items;


      NEXT address_formulation: [1 .. number_of_adr_items] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^address_formulation, object_library^.file);


      IF (occ$display_record_analysis IN analysis_options) THEN
        record_analysis^.sections^ [address_formulation^.dest_section].addresses_in :=
              record_analysis^.sections^ [address_formulation^.dest_section].addresses_in +
              number_of_adr_items;

        FOR i := 1 TO number_of_adr_items DO
          IF (address_formulation^.item [i].kind = llc$external_proc) THEN
            record_analysis^.sections^ [address_formulation^.dest_section].addresses_in :=
                  record_analysis^.sections^ [address_formulation^.dest_section].addresses_in + 1;
          IFEND;
        FOREND;

        record_analysis^.sections^ [address_formulation^.value_section].addresses_to :=
              record_analysis^.sections^ [address_formulation^.value_section].addresses_to +
              number_of_adr_items;
      IFEND;


    PROCEND analyze_address_formulation;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_external_linkage', EJECT ??

    PROCEDURE analyze_external_linkage
      (    number_of_ext_items: 1 .. llc$max_ext_items);


      VAR
        runtime_library_ids: [STATIC, READ] array [1 .. 9] of string (2) := ['AA', 'BC', 'CB', 'CY', 'DB',
              'FL', 'ML', 'PA', 'SM'],
        runtime_checkers: [STATIC, READ] array [1 .. 5] of pmt$program_name := [
              {} 'FLP$CHECK_ARRAY_BOUNDS         ', {} 'FLP$MOVE_CHARACTERS_CHECK      ',
              {} 'FLP$COMPARE_FIXED_CHECK        ', {} 'FLP$COMPARE_USER_CHECK         ',
              {} 'FLP$SUBSTRING_CHECK            '],

        external: ^llt$external_linkage,
        i: integer;


      NEXT external: [1 .. number_of_ext_items] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^external, object_library^.file);

      IF (occ$display_record_analysis IN analysis_options) THEN
        FOR i := 1 TO number_of_ext_items DO
          record_analysis^.sections^ [external^.item [i].section_ordinal].externals_in :=
                record_analysis^.sections^ [external^.item [i].section_ordinal].externals_in +
                number_of_ext_items;
        FOREND;

        IF (external^.name (4) = '$') THEN
          IF NOT (occ$runtime_library_calls IN record_analysis^.performance_problems) THEN

          /runtime_library_call_search/
            FOR i := LOWERBOUND (runtime_library_ids) TO UPPERBOUND (runtime_library_ids) DO
              IF (external^.name (1, 2) = runtime_library_ids [i]) THEN
                IF (external^.name (1, 2) <> 'CY') OR ((external^.name <> 'CYP$ERROR') AND (external^.name <>
                      'CYP$NIL')) THEN
                  record_analysis^.performance_problems := record_analysis^.performance_problems +
                        $oct$anaol_performance_problems [occ$runtime_library_calls];

                  EXIT /runtime_library_call_search/;
                IFEND;
              IFEND;
            FOREND /runtime_library_call_search/;
          IFEND;

          IF NOT (occ$runtime_checking IN record_analysis^.performance_problems) THEN
            IF (external^.name (1, 3) = 'FLP') THEN

            /runtime_checking_search/
              FOR i := LOWERBOUND (runtime_checkers) TO UPPERBOUND (runtime_checkers) DO
                IF (external^.name = runtime_checkers [i]) THEN
                  record_analysis^.performance_problems := record_analysis^.performance_problems +
                        $oct$anaol_performance_problems [occ$runtime_checking];

                  EXIT /runtime_checking_search/;
                IFEND;
              FOREND /runtime_checking_search/;
            IFEND;
          IFEND;
        IFEND;
      IFEND;


    PROCEND analyze_external_linkage;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_binding_template_record', EJECT ??

    PROCEDURE analyze_binding_template_record;


      VAR
        binding_template: ^llt$binding_template;


      NEXT binding_template IN object_library^.sequence;
      ocp$abort_if_premature_eof (^binding_template, object_library^.file);

    PROCEND analyze_binding_template_record;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_form_definition', EJECT ??

    PROCEDURE analyze_form_definition;

      VAR
        record_kind: llt$object_record_kind;

      IF record_kind = llc$form_definition THEN
        ocp$abort_with_structure_error ('Form definition found in module', object_library^.file);
      IFEND;
    PROCEND analyze_form_definition;

?? OLDTITLE ??
?? NEWTITLE := 'analyze_68000_absolute', EJECT ??

    PROCEDURE analyze_68000_absolute
      (    number_of_68000_bytes: 1 .. llc$maximum_68000_address);


      VAR
        m68000_absolute: ^llt$68000_absolute;


      NEXT m68000_absolute: [[REP number_of_68000_bytes OF cell]] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^m68000_absolute, object_library^.file);


    PROCEND analyze_68000_absolute;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_ppu_absolute', EJECT ??

    PROCEDURE analyze_ppu_absolute
      (    number_of_words: llt$ppu_address);


      VAR
        ppu_absolute: ^llt$ppu_absolute;


      NEXT ppu_absolute: [0 .. (number_of_words - 1)] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^ppu_absolute, object_library^.file);


    PROCEND analyze_ppu_absolute;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_cybil_symbol_table', EJECT ??

    PROCEDURE analyze_cybil_symbol_table
      (    sequence_length: ost$segment_length);


      VAR
        debug_table_fragment: ^llt$debug_table_fragment;


      NEXT debug_table_fragment: [[REP sequence_length OF cell]] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^debug_table_fragment, object_library^.file);


    PROCEND analyze_cybil_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_obsolete_line_table', EJECT ??

    PROCEDURE analyze_obsolete_line_table
      (    number_of_line_items: llt$line_address_table_size);


      VAR
        obsolete_line_address_table: ^llt$obsolete_line_address_table;


      NEXT obsolete_line_address_table: [1 .. number_of_line_items] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^obsolete_line_address_table, object_library^.file);


    PROCEND analyze_obsolete_line_table;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_line_table', EJECT ??

    PROCEDURE analyze_line_table
      (    number_of_line_items: llt$line_address_table_size);


      VAR
        line_address_table: ^llt$line_address_table,
        i: llt$line_address_table_size;


      NEXT line_address_table: [1 .. number_of_line_items] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^line_address_table, object_library^.file);


    PROCEND analyze_line_table;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_symbol_table', EJECT ??

    PROCEDURE analyze_symbol_table
      (    sequence_length: ost$segment_length);


      VAR
        symbol_table: ^llt$symbol_table;


      NEXT symbol_table: [[REP sequence_length OF cell]] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^symbol_table, object_library^.file);


    PROCEND analyze_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_supplemental_dtables', EJECT ??

    PROCEDURE analyze_supplemental_dtables
      (    sequence_length: ost$segment_length);


      VAR
        supplemental_debug_tables: ^llt$supplemental_debug_tables;


      NEXT supplemental_debug_tables: [[REP sequence_length OF cell]] IN object_library^.sequence;
      ocp$abort_if_premature_eof (^supplemental_debug_tables, object_library^.file);


    PROCEND analyze_supplemental_dtables;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_transfer_symbol_record', EJECT ??

    PROCEDURE analyze_transfer_symbol_record;


      VAR
        transfer_symbol: ^llt$transfer_symbol;


      NEXT transfer_symbol IN object_library^.sequence;
      ocp$abort_if_premature_eof (^transfer_symbol, object_library^.file);


    PROCEND analyze_transfer_symbol_record;
?? OLDTITLE ??
?? EJECT ??

    VAR
      record_kind: llt$object_record_kind,
      module_kind: llt$module_kind,
      size: integer;


    analyze_object_text_descriptor (record_kind, size);
    IF record_kind <> llc$identification THEN
      ocp$abort_with_structure_error ('IDR must be first record of module', object_library^.file);
    IFEND;

    analyze_identification_record (module_kind);
    CASE module_kind OF
    = llc$iou =
      analyze_object_text_descriptor (record_kind, size);
      IF (record_kind <> llc$ppu_absolute) THEN
        ocp$abort_with_structure_error ('PPU ABSOLUTE expected in module', object_library^.file);
      IFEND;

      analyze_ppu_absolute (size);
      RETURN; { ---->

    = llc$mi_virtual_state, llc$vector_virtual_state, llc$motorola_68000, llc$motorola_68000_absolute,
          llc$vector_extended_state =
      { Valid kind } ;
    ELSE
      ocp$internal_error ('Unselected module kind - ANALYZE_INTERPRETIVE_RECORDS');
    CASEND;

    REPEAT
      analyze_object_text_descriptor (record_kind, size);

      CASE record_kind OF
      = llc$identification =
        ocp$abort_with_structure_error ('Duplicate IDR record', object_library^.file);
      = llc$libraries =
        analyze_libraries_record (size);
      = llc$section_definition =
        analyze_section_definition;
      = llc$allotted_section_definition =
        analyze_allotted_section_def (size);
      = llc$unallocated_common_block =
        analyze_unallocated_common_bl;
      = llc$segment_definition, llc$obsolete_segment_definition =
        analyze_segment_definition (record_kind);
      = llc$allotted_segment_definition, llc$obsolete_allotted_seg_def =
        analyze_allotted_segment_def (record_kind, (size DIV 100000000(16)), (size MOD 100000000(16)));
      = llc$text =
        analyze_text_record (size);
      = llc$replication =
        analyze_replication_record (size);
      = llc$bit_string_insertion =
        analyze_bit_insertion_record;
      = llc$entry_definition =
        analyze_entry_definition_record;
      = llc$deferred_entry_points =
        analyze_deferred_entry_pt_rec (size);
      = llc$deferred_common_blocks =
        analyze_deferred_common_blk_rec (size);
      = llc$relocation =
        analyze_relocation_record (size);
      = llc$obsolete_formal_parameters =
        analyze_obsolete_form_parm_rec (size);
      = llc$formal_parameters =
        analyze_formal_parameter_record (size);
      = llc$actual_parameters =
        analyze_actual_parameter_record (size);
      = llc$obsolete_line_table =
        analyze_obsolete_line_table (size);
      = llc$cybil_symbol_table_fragment =
        analyze_cybil_symbol_table (size);
      = llc$line_table =
        analyze_line_table (size);
      = llc$symbol_table =
        analyze_symbol_table (size);
      = llc$supplemental_debug_tables =
        analyze_supplemental_dtables (size);
      = llc$address_formulation =
        analyze_address_formulation (size);
      = llc$external_linkage =
        analyze_external_linkage (size);
      = llc$binding_template =
        analyze_binding_template_record;
      = llc$form_definition =
        analyze_form_definition;
      = llc$68000_absolute =
        analyze_68000_absolute (size);
      = llc$transfer_symbol =
        analyze_transfer_symbol_record;
      ELSE
        ocp$abort_with_structure_error ('Invalid CPU record kind', object_library^.file);
      CASEND;

    UNTIL (record_kind = llc$transfer_symbol);

    IF (occ$display_record_analysis IN analysis_options) THEN
      analyze_module_for_performance ((module_item^.load_module_header = NIL), identification,
            record_analysis);
    IFEND;

  PROCEND analyze_interpretive_records;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$analyze_load_module', EJECT ??

  PROCEDURE [XDCL] ocp$analyze_load_module
    (    object_library: ^oct$object_library;
         module_item: ^oct$module_item;
         display_options: oct$anaol_display_options);


?? NEWTITLE := 'analyze_information_records', EJECT ??

    PROCEDURE analyze_information_records;

?? NEWTITLE := 'analyze_relocation_items', EJECT ??

      PROCEDURE analyze_relocation_items
        (    relocation: ^llt$relocation,
             number_of_rel_items: llt$number_of_info_elements);

        TYPE
          t$q_field = packed record
            q: -7fff(16) .. 7fff(16),
          recend;

        VAR
          temp: integer,
          found: boolean,
          hi: llt$number_of_info_elements,
          i: llt$number_of_info_elements,
          j: llt$number_of_info_elements,
          lo: llt$number_of_info_elements,
          mid: llt$number_of_info_elements,
          offset: llt$section_offset,
          q_field_p: ^t$q_field,
          relocation_value: t$q_field,
          relocation_values: ^array [1 .. * ] of t$q_field,
          last_relocation_value: llt$number_of_info_elements;


        IF (occ$display_record_analysis IN analysis_options) THEN
          IF (occ$count_internal_binding_refs IN analysis_options) THEN
            PUSH relocation_values: [1 .. number_of_rel_items];
            last_relocation_value := 0;
            FOR i := 1 TO number_of_rel_items DO
              IF (relocation^ [i].container = llc$180_q_field) AND (relocation^ [i].address =
                    llc$byte_signed) THEN
                IF record_analysis^.sections^ [relocation^ [i].section_ordinal].allotted THEN
                  offset := record_analysis^.sections^ [relocation^ [i].section_ordinal].allotted_section +
                        relocation^ [i].offset;
                  q_field_p := #ADDRESS (#RING (object_library^.sequence),
                        #SEGMENT (object_library^.sequence), offset);
                  relocation_value.q := (q_field_p^.q DIV 8) * 8;

                  lo := 1;
                  hi := last_relocation_value;
                  found := FALSE;

                  WHILE (NOT found) AND (lo <= hi) DO
                    temp := lo + hi;
                    mid := temp DIV 2;
                    IF relocation_value.q = relocation_values^ [mid].q THEN
                      found := TRUE;
                    ELSEIF relocation_value.q > relocation_values^ [mid].q THEN
                      lo := mid + 1;
                    ELSE
                      hi := mid - 1;
                    IFEND;
                  WHILEND;

                  IF NOT found THEN
                    FOR j := last_relocation_value DOWNTO lo DO
                      relocation_values^ [j + 1] := relocation_values^ [j];
                    FOREND;
                    last_relocation_value := last_relocation_value + 1;
                    relocation_values^ [lo] := relocation_value;
                    record_analysis^.sections^ [relocation^ [i].relocating_section].
                          internal_binding_section_ptrs := record_analysis^.
                          sections^ [relocation^ [i].relocating_section].internal_binding_section_ptrs + 1;
                  IFEND;
                IFEND;
              IFEND;
            FOREND;
          IFEND;
          record_analysis^.total := record_analysis^.total + 1;
          record_analysis^.kind [llc$relocation].number := record_analysis^.kind [llc$relocation].number + 1;
          record_analysis^.kind [llc$relocation].number_of_items :=
                record_analysis^.kind [llc$relocation].number_of_items + number_of_rel_items;
        IFEND;


      PROCEND analyze_relocation_items;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_binding_template_items', EJECT ??

      PROCEDURE analyze_binding_template_items
        (    number_of_template_items: llt$number_of_info_elements);


        VAR
          i: integer;


        IF (occ$display_record_analysis IN analysis_options) THEN
          record_analysis^.total := record_analysis^.total + 1;
          record_analysis^.kind [llc$binding_template].number :=
                record_analysis^.kind [llc$binding_template].number + 1;
          record_analysis^.kind [llc$binding_template].number_of_items := record_analysis^.
                kind [llc$binding_template].number_of_items + number_of_template_items;
        IFEND;


      PROCEND analyze_binding_template_items;
?? OLDTITLE ??
?? EJECT ??

      VAR
        relocation: ^llt$relocation,
        binding_template: ^llt$binding_section_template,
        info_element_header: ^llt$info_element_header,
        new_header: llt$info_element_header;


      IF (llc$information_element IN module_item^.load_module_header^.elements_defined) THEN
        info_element_header := #PTR (module_item^.load_module_header^.information_element,
              object_library^.sequence^);
        ocp$abort_if_premature_eof (^info_element_header, object_library^.file);

        IF info_element_header^.version <> llc$info_element_version THEN
          ocp$convert_information_element (info_element_header, new_header);

          info_element_header := ^new_header;
        IFEND;

        IF info_element_header^.number_of_rel_items <> 0 THEN
          relocation := #PTR (info_element_header^.relocation_ptr, object_library^.sequence^);
          ocp$abort_if_premature_eof (^relocation, object_library^.file);

          RESET object_library^.sequence TO relocation;
          analyze_relocation_items (relocation, info_element_header^.number_of_rel_items);
        IFEND;

        IF info_element_header^.number_of_template_items <> 0 THEN
          binding_template := #PTR (info_element_header^.binding_template_ptr, object_library^.sequence^);
          ocp$abort_if_premature_eof (^binding_template, object_library^.file);

          RESET object_library^.sequence TO binding_template;
          analyze_binding_template_items (info_element_header^.number_of_template_items);
        IFEND;
      IFEND;


    PROCEND analyze_information_records;
?? OLDTITLE ??
?? EJECT ??

    VAR
      analysis_options: oct$anaol_display_options,
      record_analysis: ^oct$record_analysis;


    IF occ$count_internal_binding_refs IN display_options THEN
      analysis_options := -$oct$anaol_display_options [];
    ELSE
      analysis_options := -$oct$anaol_display_options []; { Temporary }
      analysis_options := analysis_options - $oct$anaol_display_options [occ$count_internal_binding_refs];
    IFEND;
    IF (module_item^.record_analysis = NIL) THEN
      initialize_record_analysis (record_analysis);

      RESET object_library^.sequence TO module_item^.interpretive_records;

      analyze_interpretive_records (object_library, module_item, record_analysis, analysis_options);

      analyze_information_records;

      update_record_analysis (record_analysis, object_library^.record_analysis^);
      module_item^.record_analysis := record_analysis;
    IFEND;


  PROCEND ocp$analyze_load_module;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$get_binding_section_refs', EJECT ??

  PROCEDURE [XDCL] ocp$get_binding_section_refs
    (    object_library: ^oct$object_library;
     VAR count: 0 .. llc$max_binding_items);

    VAR
      display_options: [STATIC, READ] oct$anaol_display_options := [occ$count_internal_binding_refs],
      i: llt$section_ordinal,
      next_module: ^oct$module_item,
      sections: ^oct$sections;


    count := 0;

    next_module := object_library^.module_list^ [occ$head_of_list].link;

    WHILE (next_module <> NIL) DO
      ocp$analyze_load_module (object_library, next_module, display_options);

      sections := next_module^.record_analysis^.sections;

      IF sections <> NIL THEN

      /find_binding_section/
        FOR i := LOWERBOUND (sections^) TO UPPERBOUND (sections^) DO
          IF (sections^ [i].definition <> NIL) AND (sections^ [i].definition^.kind = llc$binding_section) THEN
            count := count + sections^ [i].internal_binding_section_ptrs;
            EXIT /find_binding_section/;
          IFEND;
        FOREND /find_binding_section/;
      IFEND;

      next_module := next_module^.link;
    WHILEND;

  PROCEND ocp$get_binding_section_refs;
?? OLDTITLE ??
MODEND ocm$anaol_library_scanners;

*DECK DECK=OCM$APPLY_CORRECTOR EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$apply_corrector;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc occ$corrector
*copyc oct$corrector
*copyc oct$fill_sequence
?? POP ??

*copyc och$apply_corrector

  PROCEDURE [XDCL] ocp$apply_corrector
    (    p_corrector: ^SEQ ( * );
         p_int_ol: ^SEQ ( * );
     VAR result: ^SEQ ( * ));

    VAR
      byte_address: 0 .. 0ffffffff(16),
      corrector: ^SEQ ( * ),
      corrector_header: ^oct$corrector_header,
      corrector_header_v1_0: ^oct$corrector_header_v1_0,
      corrector_item: ^oct$corrector_item,
      delete_fill: ^oct$fill_sequence,
      i: oct$number_of_correctors,
      insert_fill: ^oct$fill_sequence,
      int_ol: ^SEQ ( * ),
      new_bytes: ^oct$new_bytes,
      new_fill: ^oct$fill_sequence,
      old_fill: ^oct$fill_sequence;

    corrector := p_corrector;
    int_ol := p_int_ol;

    RESET int_ol;
    RESET corrector;
    NEXT corrector_header IN corrector;

{ If the corrector header version is not the "current" version, convert it
{ to a local copy of the new version.

    IF (corrector_header = NIL) OR (corrector_header^.version <> occ$corrector_header_version) THEN
      RESET corrector;
      NEXT corrector_header_v1_0 IN corrector;
      PUSH corrector_header;
      corrector_header^.number_of_correctors := corrector_header_v1_0^.number_of_correctors;
      corrector_header^.size := corrector_header_v1_0^.size;
    IFEND;

    FOR i := 1 TO corrector_header^.number_of_correctors DO
      NEXT corrector_item IN corrector;

      IF corrector_item^.bytes_ok > 0 THEN
        NEXT old_fill: [1 .. corrector_item^.bytes_ok] IN int_ol;
        NEXT new_fill: [1 .. corrector_item^.bytes_ok] IN result;
        new_fill^ := old_fill^;
        byte_address := #OFFSET (new_fill);
      ELSE
        byte_address := 0;
      IFEND;

      IF corrector_item^.bytes_to_delete > 0 THEN
        NEXT delete_fill: [1 .. corrector_item^.bytes_to_delete] IN int_ol;
      IFEND;

      IF corrector_item^.bytes_to_insert > 0 THEN
        NEXT new_bytes: [1 .. corrector_item^.bytes_to_insert] IN corrector;
        NEXT insert_fill: [1 .. corrector_item^.bytes_to_insert] IN result;
        insert_fill^ := new_bytes^;
      IFEND;
    FOREND;
  PROCEND ocp$apply_corrector;
MODEND ocm$apply_corrector;
*DECK DECK=OCM$APPLY_MESSAGE_PREDICTOR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Management : Binary Correction Generator' ??
MODULE ocm$apply_message_predictor;

{ PURPOSE:
{   This module updates offsets in a message module using a message module
{   "predictor" which contains offset change information that has been generated
{   from comparing two versions of the module.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc llt$library_member_header
*copyc llt$module_dictionary
*copyc llt$section_address
*copyc oct$name_index_changes
*copyc oct$offset_change_list
*copyc oct$single_module_predictor_hdr
*copyc ost$message_template
*copyc ost$mtm_condition_codes
*copyc ost$mtm_condition_names
*copyc ost$mtm_header
?? POP ??
*copyc ocp$new_global_offset
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$apply_message_predictor', EJECT ??
*copyc och$apply_message_predictor

  PROCEDURE [XDCL] ocp$apply_message_predictor
    (    p_module_predictor: ^SEQ ( * );
         module_dictionary: ^llt$module_dictionary;
         p_int_ol: ^SEQ ( * ));

    VAR
      member: record
        case boolean of
        = TRUE =
          pointer: ^SEQ ( * ),
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      template: record
        case boolean of
        = TRUE =
          pointer: ^ost$message_template,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      condition_codes: ^ost$mtm_condition_codes,
      condition_names: ^ost$mtm_condition_names,
      found: boolean,
      i: llt$module_index,
      int_ol: ^SEQ ( * ),
      k: 0 .. osc$max_status_condition_code + 1,
      member_seq: ^SEQ ( * ),
      message_header: ^llt$library_member_header,
      message_module_ocv: ^oct$offset_change_list,
      message_name_index_changes: ^oct$name_index_changes,
      module_predictor: ^SEQ ( * ),
      module_predictor_header: ^oct$single_module_predictor_hdr,
      mtm_header: ^ost$mtm_header,
      new_offset: llt$section_address_range;

    int_ol := p_int_ol;
    module_predictor := p_module_predictor;

    RESET module_predictor;
    NEXT module_predictor_header IN module_predictor;
    NEXT message_name_index_changes: [0 .. module_predictor_header^.last_name_index] IN module_predictor;

    IF module_predictor_header^.length_message_template_cv > 0 THEN
      message_module_ocv := #PTR (module_predictor_header^.message_template_cv, module_predictor^);
    ELSE
      message_module_ocv := NIL;
    IFEND;

    found := FALSE;
    i := 1;
    WHILE NOT found AND (i <= UPPERBOUND (module_dictionary^)) DO
      found := ((module_dictionary^ [i].name = module_predictor_header^.module_name) AND
            ((module_dictionary^ [i].kind = llc$message_module) OR
            (module_dictionary^ [i].kind = llc$help_module)));
      IF found THEN
        message_header := #PTR (module_dictionary^ [i].message_header, int_ol^);
        member.pointer := #PTR (message_header^.member, int_ol^);
        RESET int_ol TO member.pointer;

        NEXT member_seq: [[REP message_header^.member_size OF cell]] IN int_ol;

        NEXT mtm_header IN member_seq;
        NEXT condition_codes: [0 .. mtm_header^.number_of_codes - 1] IN member_seq;
        FOR k := 0 TO UPPERBOUND (condition_codes^) DO
          IF message_name_index_changes^ [condition_codes^ [k].name_index] <>
                osc$max_status_condition_code THEN
            condition_codes^ [k].name_index := message_name_index_changes^ [condition_codes^ [k].name_index];
          IFEND;
        FOREND;

        NEXT condition_names: [0 .. mtm_header^.number_of_names - 1] IN member_seq;
        FOR k := 0 TO UPPERBOUND (condition_names^) DO
          template.pointer := #PTR (condition_names^ [k].template, member_seq^);
          new_offset := ocp$new_global_offset (#OFFSET (template.pointer), message_module_ocv);
          template.pva := #ADDRESS (#RING (template.pointer), #SEGMENT (template.pointer), new_offset);
?? PUSH (CHKRNG := OFF) ??
          condition_names^ [k].template := #REL (template.pointer, member_seq^);
?? POP ??
        FOREND;
        new_offset := ocp$new_global_offset (#OFFSET (member.pointer), message_module_ocv);
        member.pva := #ADDRESS (#RING (member.pointer), #SEGMENT (member.pointer), new_offset);
        message_header^.member := #REL (member.pointer, int_ol^);
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;
  PROCEND ocp$apply_message_predictor;
?? OLDTITLE ??
MODEND ocm$apply_message_predictor;
*DECK DECK=OCM$APPLY_MODULE_PREDICTORS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Management : Binary Correction Generator' ??
MODULE ocm$apply_module_predictors;

{ PURPOSE:
{   This module calls the necessary procedures to update offsets in modules using
{   offset change information that has been generated from comparing two versions
{   of the module.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc llt$message_module_dictionary
*copyc llt$module_dictionary
*copyc llt$object_library_header
*copyc oct$code_section_directory
*copyc oct$predictor_header
*copyc oct$single_module_predictor_hdr
?? POP ??
*copyc ocp$apply_message_predictor
*copyc ocp$build_code_sec_directory
*copyc ocp$process_b0_instructions
*copyc ocp$process_info_element
*copyc ocp$process_interp_element
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$apply_module_predictors', EJECT ??
*copyc och$apply_module_predictors

  PROCEDURE [XDCL] ocp$apply_module_predictors
    (    p_predictor: ^SEQ ( * );
         p_first_intermediate_ol: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      code_section_directory: ^oct$code_section_directory,
      first_intermediate_ol: ^SEQ ( * ),
      i: 0 .. llc$max_dictionaries_on_library,
      mod_dictionary_ocv: ^oct$offset_change_list,
      module_code_section_directory: ^oct$module_code_sections,
      module_dictionary: ^llt$module_dictionary,
      module_predictor: ^SEQ ( * ),
      module_predictor_hdr: ^oct$single_module_predictor_hdr,
      object_library_dictionaries: ^llt$object_library_dictionaries,
      object_library_header: ^llt$object_library_header,
      predictor: ^SEQ ( * ),
      predictor_header: ^oct$predictor_header;

    first_intermediate_ol := p_first_intermediate_ol;
    predictor := p_predictor;

    ocp$build_code_sec_directory (first_intermediate_ol, code_section_directory,
          module_code_section_directory);
    RESET first_intermediate_ol;
    NEXT object_library_header IN first_intermediate_ol;
    NEXT object_library_dictionaries: [1 .. object_library_header^.number_of_dictionaries] IN
          first_intermediate_ol;
    module_dictionary := NIL;
    i := 1;
    WHILE (module_dictionary = NIL) AND (i <= UPPERBOUND (object_library_dictionaries^)) DO
      IF object_library_dictionaries^ [i].kind = llc$module_dictionary THEN
        module_dictionary := #PTR (object_library_dictionaries^ [i].module_dictionary,
              first_intermediate_ol^);
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;

    RESET predictor;
    NEXT predictor_header IN predictor;
    IF predictor_header^.number_of_mod_ocv_elements > 0 THEN
      mod_dictionary_ocv := #PTR (predictor_header^.mod_dictionary_ocv, predictor^);
    ELSE
      mod_dictionary_ocv := NIL;
    IFEND;
    FOR i := 1 TO predictor_header^.number_module_predictors DO
      NEXT module_predictor_hdr IN predictor;
      RESET predictor TO module_predictor_hdr;
      NEXT module_predictor: [[REP module_predictor_hdr^.predictor_size OF cell]] IN predictor;
      CASE module_predictor_hdr^.kind OF
      = llc$message_module =
        ocp$apply_message_predictor (module_predictor, module_dictionary, first_intermediate_ol);
      = llc$load_module =
        ocp$process_b0_instructions (module_predictor, module_dictionary, first_intermediate_ol, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        ;
      CASEND;
    FOREND;
    ocp$process_interp_element (predictor, first_intermediate_ol);
    ocp$process_info_element (predictor, first_intermediate_ol, code_section_directory,
          module_code_section_directory, status);
  PROCEND ocp$apply_module_predictors;
?? OLDTITLE ??
MODEND ocm$apply_module_predictors;
*DECK DECK=OCM$APPLY_MOVE_ITEMS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$apply_move_items;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc oct$breaklist
*copyc oct$move_items
*copyc i#move
?? POP ??

*copyc och$apply_move_items

  PROCEDURE [XDCL] ocp$apply_move_items (first_intermediate_ol: ^SEQ ( * );
        move_items: ^oct$move_items;
        number_of_move_items: oct$breaklist_index;
    VAR second_intermediate_ol: ^SEQ ( * ));

    VAR
      i: oct$breaklist_index,
      new_address: ^cell,
      old_address: ^cell;

    FOR i := 1 TO number_of_move_items DO
      old_address := #address (#ring (first_intermediate_ol), #segment (first_intermediate_ol), move_items^
            [i].old_offset);
      new_address := #address (#ring (second_intermediate_ol), #segment (second_intermediate_ol), move_items^
            [i].new_offset);
      i#move (old_address, new_address, move_items^ [i].length);
    FOREND;
  PROCEND ocp$apply_move_items;
MODEND ocm$apply_move_items;

*DECK DECK=OCM$APPLY_OBJECT_CORRECTION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: OCP$APPLY_OBJECT_CORRECTION Interface.' ??
MODULE ocm$apply_object_correction;
{ PURPOSE:
{   The module contains the interface to apply an object library correction.
{
{ DESIGN:
{  This compiled module resides in RAF$LIBRARY.
{
{  NOTES:
{
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$condition_codes
*copyc oct$metapatch_header
*copyc oct$move_items
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$return
*copyc amp$set_segment_eoi
*copyc fsp$close_file
*copyc fsp$open_file
*copyc ocp$apply_corrector
*copyc ocp$apply_move_items
*copyc ocp$build_first_intermediate_ol
*copyc ocp$checksum
*copyc ocp$copy
*copyc osp$append_status_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pmp$get_unique_name
*copyc rap$open_file
?? OLDTITLE, NEWTITLE := '[XDCL] ocp$apply_object_correction', EJECT ??

{ PURPOSE:
{   This interface applys an object correction to the base file
{   and returns the result in the target file.
{
{ DESIGN:
{
{
{ NOTES:
{

  PROCEDURE [XDCL] ocp$apply_object_correction
    (    base_file: fst$file_reference;
         correction_file: fst$file_reference;
         target_file { output } : fst$file_reference;
     VAR status: ost$status);

    VAR
      attribute: array [1 .. 1] of fst$file_cycle_attribute,
      base_object_library: amt$segment_pointer,
      base_fid: amt$file_identifier,
      base_file_open: boolean,
      correction_fid: amt$file_identifier,
      correction_file_open: boolean,
      correction_sequence: amt$segment_pointer,
      corrector: ^SEQ ( * ),
      first_temp_fid: amt$file_identifier,
      first_temp_file: ost$name,
      first_temp_file_open: boolean,
      first_temp_object_library: amt$segment_pointer,
      ignore_status: ost$status,
      local_status: ost$status,
      metapatch: ^SEQ ( * ),
      metapatch_header: ^oct$metapatch_header,
      move_items: ^oct$move_items,
      new_checksum: integer,
      old_checksum: integer,
      predictor: ^SEQ ( * ),
      second_temp_fid: amt$file_identifier,
      second_temp_file: ost$name,
      second_temp_file_open: boolean,
      second_temp_object_library: amt$segment_pointer,
      target_object_library: amt$segment_pointer,
      target_fid: amt$file_identifier,
      target_file_open: boolean,
      write_attachment: array [1 .. 2] of fst$attachment_option;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   Return any open files and delete any sequences.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF base_file_open THEN
        fsp$close_file (base_fid, ignore_status);
        base_file_open := FALSE;
      IFEND;

      IF target_file_open THEN
        fsp$close_file (target_fid, ignore_status);
        target_file_open := FALSE;
      IFEND;

      IF correction_file_open THEN
        fsp$close_file (correction_fid, ignore_status);
        correction_file_open := FALSE;
      IFEND;

      IF first_temp_file_open THEN
        fsp$close_file (first_temp_fid, ignore_status);
        first_temp_file_open := FALSE;
        amp$return(first_temp_file, ignore_status);
      IFEND;

      IF second_temp_file_open THEN
        fsp$close_file (second_temp_fid, ignore_status);
        second_temp_file_open := FALSE;
        amp$return(second_temp_file, ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    base_file_open := FALSE;
    target_file_open := FALSE;
    correction_file_open := FALSE;
    first_temp_file_open := FALSE;
    second_temp_file_open := FALSE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      rap$open_file (^base_file, amc$segment, fsc$read, FALSE, NIL, base_fid, base_file_open, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (base_fid, amc$sequence_pointer, base_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$open_file (^correction_file, amc$segment, fsc$read, FALSE, NIL, correction_fid,
            correction_file_open, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (correction_fid, amc$sequence_pointer, correction_sequence, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      metapatch := correction_sequence.sequence_pointer;

      write_attachment [1].selector := fsc$access_and_share_modes;
      write_attachment [1].access_modes.selector := fsc$specific_access_modes;
      write_attachment [1].access_modes.value := $fst$file_access_options
            [fsc$read, fsc$shorten, fsc$append, fsc$modify];
      write_attachment [1].share_modes.selector := fsc$determine_from_access_modes;
      write_attachment [2].selector := fsc$create_file;
      write_attachment [2].create_file := TRUE;

      attribute [1].selector := fsc$file_contents_and_processor;
      attribute [1].file_contents := fsc$object_library;
      attribute [1].file_processor := fsc$unknown_processor;

      fsp$open_file (target_file, amc$segment, ^write_attachment, ^attribute, NIL, NIL, NIL, target_fid,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (target_fid, amc$sequence_pointer, target_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      pmp$get_unique_name (first_temp_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fsp$open_file (first_temp_file, amc$segment, ^write_attachment, NIL, NIL, NIL, NIL, first_temp_fid,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      first_temp_file_open := TRUE;

      amp$get_segment_pointer (first_temp_fid, amc$sequence_pointer, first_temp_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      RESET metapatch;
      NEXT metapatch_header IN metapatch;
      IF metapatch_header = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment, 'METAPATCH', status);
        EXIT /main/;
      IFEND;

      old_checksum := ocp$checksum (base_object_library.sequence_pointer);

      IF old_checksum <> metapatch_header^.old_checksum THEN
        osp$set_status_abnormal ('RA', rae$corr_base_checksum_mismatch, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, base_file, status);
        EXIT /main/;
      IFEND;

      IF metapatch_header^.predictor_size > 0 THEN
        predictor := #PTR (metapatch_header^.predictor, metapatch^);
        RESET metapatch TO predictor;
        NEXT predictor: [[REP metapatch_header^.predictor_size OF cell]] IN metapatch;
        IF predictor = NIL THEN
          osp$set_status_abnormal ('RA', rae$accessed_beyond_segment, 'METAPATCH', status);
          RETURN;
        IFEND;

        ocp$build_first_intermediate_ol (predictor, base_object_library.sequence_pointer,
              first_temp_object_library.sequence_pointer, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
      ELSE
        ocp$copy (base_object_library.sequence_pointer, first_temp_object_library.sequence_pointer, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
      IFEND;

      pmp$get_unique_name (second_temp_file, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      fsp$open_file (second_temp_file, amc$segment, ^write_attachment, NIL, NIL, NIL, NIL, second_temp_fid,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      second_temp_file_open := TRUE;

      amp$get_segment_pointer (second_temp_fid, amc$sequence_pointer, second_temp_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF metapatch_header^.number_of_move_items > 0 THEN
        move_items := #PTR (metapatch_header^.move_items, metapatch^);
        RESET metapatch TO move_items;
        NEXT move_items: [1 .. metapatch_header^.number_of_move_items] IN metapatch;
        IF move_items = NIL THEN
          osp$set_status_abnormal ('RA', rae$accessed_beyond_segment, 'METAPATCH', status);
          EXIT /main/;
        IFEND;

        ocp$apply_move_items (first_temp_object_library.sequence_pointer, move_items,
              metapatch_header^.number_of_move_items, second_temp_object_library.sequence_pointer);
      ELSE
        ocp$copy (first_temp_object_library.sequence_pointer, second_temp_object_library.sequence_pointer,
              status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
      IFEND;

      IF metapatch_header^.corrector_size > 0 THEN
        corrector := #PTR (metapatch_header^.corrector, metapatch^);
        RESET metapatch TO corrector;
        NEXT corrector: [[REP metapatch_header^.corrector_size OF cell]] IN metapatch;
        IF corrector = NIL THEN
          osp$set_status_abnormal ('RA', rae$accessed_beyond_segment, 'METAPATCH', status);
          EXIT /main/;
        IFEND;

        ocp$apply_corrector (corrector, second_temp_object_library.sequence_pointer,
              target_object_library.sequence_pointer);
      ELSE
        ocp$copy (second_temp_object_library.sequence_pointer, target_object_library.sequence_pointer,
              status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
      IFEND;

      amp$set_segment_eoi (target_fid, target_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      fsp$close_file (target_fid, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      target_file_open := FALSE;

      rap$open_file (^target_file, amc$segment, fsc$read, FALSE, NIL, target_fid, target_file_open, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (target_fid, amc$sequence_pointer, target_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      new_checksum := ocp$checksum (target_object_library.sequence_pointer);
      IF new_checksum <> metapatch_header^.new_checksum THEN
        osp$set_status_abnormal ('RA', rae$error_in_object_library, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, correction_file, status);
        osp$append_status_file (osc$status_parameter_delimiter, base_file, status);
        EXIT /main/;
      IFEND;

    END /main/;

    IF base_file_open THEN
      fsp$close_file (base_fid, local_status);
      base_file_open := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF target_file_open THEN
      fsp$close_file (target_fid, local_status);
      target_file_open := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF correction_file_open THEN
      fsp$close_file (correction_fid, local_status);
      correction_file_open := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF first_temp_file_open THEN
      fsp$close_file (first_temp_fid, local_status);
      first_temp_file_open := FALSE;
      amp$return(first_temp_file, ignore_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF second_temp_file_open THEN
      fsp$close_file (second_temp_fid, local_status);
      second_temp_file_open := FALSE;
      amp$return(second_temp_file, ignore_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

   osp$disestablish_cond_handler;

  PROCEND ocp$apply_object_correction;
?? OLDTITLE ??
MODEND ocm$apply_object_correction;
*DECK DECK=OCM$BIND_MODULE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
?? EJECT ??
MODULE ocm$bind_module;



{ PURPOSE:
{   To bind multiple modules together into a
{   single new module.  The code sections of
{   the old modules are reordered according to
{   the order parameter from the bind_module
{   command.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_expression_result
*copyc cle$ecc_parameter_list
*copyc llt$object_library_header
*copyc occ$retain
*copyc oce$library_generator_errors
*copyc oct$bound_module_components
*copyc oct$changed_info
*copyc oct$code_section_ids
*copyc oct$component_list
*copyc oct$debug_table
*copyc oct$display_toggles
*copyc oct$external_declaration_list
*copyc oct$external_reference_list
*copyc oct$header
*copyc oct$module_description
*copyc oct$name_list
*copyc oct$new_library_module_list
*copyc oct$open_file_list
*copyc ost$status
?? POP ??
*copyc clp$convert_string_to_file
*copyc clp$evaluate_parameters
*copyc clp$read_variable
*copyc ocp$add_an_nlm
*copyc ocp$close_all_open_files
*copyc ocp$generate_message
*copyc ocp$initialize_olg_working_heap
*copyc ocp$obtain_code_section_ids
*copyc ocp$obtain_header
*copyc ocp$obtain_library_list
*copyc ocp$obtain_object_file
*copyc ocp$obtain_xdcl_list
*copyc ocp$obtain_xref_list
*copyc ocp$search_nlm_tree
*copyc ocp$search_object_file
*copyc ocp$search_object_file
*copyc ocp$search_xdcl_list
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_legible_date_time
*copyc ocv$nlm_list
*copyc ocv$olg_scratch_seq
*copyc ocv$olg_working_heap
*copyc ocv$open_file_list

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    object_type_checking: [STATIC, READ] string (6) := 'OBJECT';

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$_bind_module', EJECT ??

  PROCEDURE [XDCL] ocp$_bind_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$creol_binm) bind_module, binm (
{   mode, m: key
{       continue, quit
{     keyend = $required
{   name, n: program_name = $optional
{   file, f: file = $optional
{   starting_procedure, sp: program_name = $optional
{   section_order, so: (BY_NAME) list of record
{       section_name: program_name
{       section_ordinal: integer
{     recend = $optional
{   preset_value, pv: (BY_NAME) key
{       (zero, z)
{       (floating_point_indefinite, fpi)
{       (infinity, i)
{       (alternate_ones, ao)
{     keyend = $optional
{   include_binary_section_maps, ibsm: (BY_NAME) boolean = $optional
{   output, o: (BY_NAME) file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 17] of clt$pdt_parameter_name,
      parameters: array [1 .. 9] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
      type9: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 2, 12, 9, 57, 48, 683],
    clc$command, 17, 9, 1, 0, 0, 0, 9, 'OCM$CREOL_BINM'], [
    ['F                              ',clc$abbreviation_entry, 3],
    ['FILE                           ',clc$nominal_entry, 3],
    ['IBSM                           ',clc$abbreviation_entry, 7],
    ['INCLUDE_BINARY_SECTION_MAPS    ',clc$nominal_entry, 7],
    ['M                              ',clc$abbreviation_entry, 1],
    ['MODE                           ',clc$nominal_entry, 1],
    ['N                              ',clc$abbreviation_entry, 2],
    ['NAME                           ',clc$nominal_entry, 2],
    ['O                              ',clc$abbreviation_entry, 8],
    ['OUTPUT                         ',clc$nominal_entry, 8],
    ['PRESET_VALUE                   ',clc$nominal_entry, 6],
    ['PV                             ',clc$abbreviation_entry, 6],
    ['SECTION_ORDER                  ',clc$nominal_entry, 5],
    ['SO                             ',clc$abbreviation_entry, 5],
    ['SP                             ',clc$abbreviation_entry, 4],
    ['STARTING_PROCEDURE             ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 9]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 8
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 9
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [2], [
    ['CONTINUE                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 2
    [[1, 0, clc$program_name_type]],
{ PARAMETER 3
    [[1, 0, clc$file_type]],
{ PARAMETER 4
    [[1, 0, clc$program_name_type]],
{ PARAMETER 5
    [[1, 0, clc$list_type], [102, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [2],
      ['SECTION_NAME                   ', clc$required_field, 3], [[1, 0, clc$program_name_type]],
      ['SECTION_ORDINAL                ', clc$required_field, 20], [[1, 0, clc$integer_type], [clc$min_integer
  , clc$max_integer, 10]]
      ]
    ],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [8], [
    ['ALTERNATE_ONES                 ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['AO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['FLOATING_POINT_INDEFINITE      ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['FPI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['INFINITY                       ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['Z                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ZERO                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 7
    [[1, 0, clc$boolean_type]],
{ PARAMETER 8
    [[1, 0, clc$file_type]],
{ PARAMETER 9
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$mode = 1,
      p$name = 2,
      p$file = 3,
      p$starting_procedure = 4,
      p$section_order = 5,
      p$preset_value = 6,
      p$include_binary_section_maps = 7,
      p$output = 8,
      p$status = 9;

    VAR
      pvt: array [1 .. 9] of clt$parameter_value;

{ These constants are used for the field values in the section_order record.

    CONST
      p$section_name = 1,
      p$section_ordinal = 2;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    VAR
      time: ost$time,
      date: ost$date;

?? FMT (FORMAT := OFF) ??
    VAR
      module_header_template: [STATIC] llt$identification :=
        [  *,                              {name}
           llc$object_text_version,        {object_text_version}
           LLC$MI_VIRTUAL_STATE,           {kind}
           [OSC$HMS_TIME, *],              {time_created}
           [OSC$MDY_DATE, *],              {date_created}
           *,                              {attributes}
           0,                              {greatest_section_ordinal}
           LLC$OBJECT_LIBRARY_GENERATOR,   {generator_id}
           'OBJECT LIBRARY GENERATOR ' CAT llc$object_library_version,  {generator_name_vers}
           OSC$NULL_NAME];                 {commentary}
?? FMT (FORMAT := ON) ??

    VAR
      first_pass: [STATIC] boolean := TRUE,
      nlm: [STATIC] ^oct$new_library_module_list,
      end_of_ordered_code_sections: [STATIC] ^oct$code_section_ids,
      number_of_components: [STATIC] 0 .. llc$max_components,
      component_list: [STATIC] oct$component_list,
      procedure_specified: [STATIC] boolean := FALSE;


    VAR
      bound_modules_xdcl_list: oct$external_declaration_list,
      changed_info_entry_points: oct$external_declaration_list,
      component_number: 0 .. llc$max_components,
      current_module: pmt$program_name,
      deferred_entry_point_list: oct$external_declaration_list,
      dummy: integer,
      file_descriptor: ^oct$open_file_list,
      header: oct$header,
      ignore_status: ost$status,
      last_code_section_ids: ^oct$code_section_ids,
      last_component: ^oct$component_list,
      last_library: ^oct$name_list,
      last_xdcl: ^oct$external_declaration_list,
      last_xref: ^oct$external_reference_list,
      library_list: oct$name_list,
      module_already_exists: boolean,
      module_name: pmt$program_name,
      modules_last_library: ^oct$name_list,
      modules_last_xdcl: ^oct$external_declaration_list,
      modules_last_xref: ^oct$external_reference_list,
      modules_library_list: oct$name_list,
      modules_xdcl_list: oct$external_declaration_list,
      modules_xref_list: oct$external_reference_list,
      node: ^clt$data_value,
      ordinal_number: integer,
      program_name: pmt$program_name,
      section_map_file: clt$file,
      section_ordinal_stg: string (5),
      start_proc: pmt$program_name,
      temporary_pointer: ^oct$code_section_ids,
      xdcl_found: boolean;

    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler;



    status.normal := TRUE;
    RESET ocv$olg_scratch_seq;

    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];

    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /protect/
    BEGIN

    /valid_data_processing/
      BEGIN

        clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
        IF NOT status.normal THEN
          IF first_pass THEN
            EXIT /protect/;
          ELSE
            EXIT /valid_data_processing/;
          IFEND;
        IFEND;

        IF first_pass THEN
          pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
          module_header_template.date_created.mdy := date.mdy;
          module_header_template.time_created.hms := time.hms;

          ocp$obtain_object_file (pvt [p$file].value^.file_value^, file_descriptor, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;

          program_name := pvt [p$name].value^.program_name_value;
          ocp$search_nlm_tree (program_name, nlm, module_already_exists);
          IF module_already_exists THEN
            osp$set_status_abnormal (oc, oce$e_module_already_on_library, program_name, status);
            EXIT /protect/;
          IFEND;

          ALLOCATE nlm IN ocv$olg_working_heap^;
          IF nlm = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;

          nlm^.name := program_name;

          ALLOCATE nlm^.description IN ocv$olg_working_heap^;
          IF nlm^.description = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            FREE nlm IN ocv$olg_working_heap^;
            RETURN;
          IFEND;

          nlm^.description^.name := program_name;
          nlm^.description^.source := occ$current;
          nlm^.description^.file := NIL;
          nlm^.description^.kind := occ$bound_module;

          ALLOCATE nlm^.changed_info IN ocv$olg_working_heap^;
          IF nlm^.changed_info = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            FREE nlm^.description IN ocv$olg_working_heap^;
            FREE nlm IN ocv$olg_working_heap^;
            RETURN;
          IFEND;

          nlm^.changed_info^.name := NIL;
          nlm^.changed_info^.commentary := NIL;
          nlm^.changed_info^.entry_points := NIL;
          nlm^.changed_info^.starting_procedure := osc$null_name;
          nlm^.changed_info^.new_libraries := TRUE;
          nlm^.changed_info^.library_list := NIL;
          nlm^.changed_info^.debug_tables_to_omit := $oct$debug_tables [];
          nlm^.changed_info^.application_identifier := NIL;
          nlm^.changed_info^.cybil_parameter_checking := '      ';

          ALLOCATE nlm^.description^.bound_module_header IN ocv$olg_working_heap^;
          IF nlm^.description^.bound_module_header = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            FREE nlm^.changed_info IN ocv$olg_working_heap^;
            FREE nlm^.description IN ocv$olg_working_heap^;
            FREE nlm IN ocv$olg_working_heap^;
            RETURN;
          IFEND;


          module_header_template.name := nlm^.name;

          nlm^.description^.bound_module_header^.identification := module_header_template;
          nlm^.description^.bound_module_header^.section_map.local_file_name := osc$null_name;
          nlm^.description^.bound_module_header^.xref_list.link := NIL;
          nlm^.description^.bound_module_header^.code_section_ids.link := NIL;
          nlm^.description^.bound_module_header^.components := NIL;
          nlm^.description^.bound_module_header^.preset_value := pmc$initialize_to_zero;
          nlm^.description^.bound_module_header^.preset_specified := FALSE;
          nlm^.description^.bound_module_header^.include_binary_section_maps := FALSE;

          nlm^.f_link := NIL;
          nlm^.b_link := NIL;
          nlm^.r_link := NIL;
          nlm^.l_link := NIL;
          nlm^.t_link := NIL;

          component_list.link := NIL;
          number_of_components := 0;

          bound_modules_xdcl_list.link := NIL;
          library_list.link := NIL;
          last_component := ^component_list;
          last_code_section_ids := ^nlm^.description^.bound_module_header^.code_section_ids;

          FOR file_descriptor^.current_module := 1 TO UPPERBOUND (file_descriptor^.directory^) DO
            IF number_of_components >= llc$max_components THEN
              osp$set_status_condition (oce$e_too_many_components, status);
              EXIT /valid_data_processing/;
            IFEND;

            number_of_components := number_of_components + 1;

            NEXT last_component^.link IN ocv$olg_scratch_seq;
            last_component := last_component^.link;
            IF last_component = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              EXIT /valid_data_processing/;
            IFEND;

            last_component^.link := NIL;
            last_component^.module_description := ^file_descriptor^.
                  directory^ [file_descriptor^.current_module];

            IF (last_component^.module_description^.kind <> occ$cpu_object_module) AND
                  (last_component^.module_description^.kind <> occ$load_module) THEN
              osp$set_status_abnormal (oc, oce$e_invalid_module_kind,
                    last_component^.module_description^.name, status);
              EXIT /valid_data_processing/;
            IFEND;

            ocp$obtain_header (last_component^.module_description^, nlm^.changed_info, header, status);
            IF NOT status.normal THEN
              EXIT /valid_data_processing/;
            IFEND;

            IF header.identification.kind = llc$vector_virtual_state THEN
              nlm^.description^.bound_module_header^.identification.kind := llc$vector_virtual_state;
            ELSEIF header.identification.kind = llc$vector_extended_state THEN
              nlm^.description^.bound_module_header^.identification.kind := llc$vector_extended_state;
            IFEND;

            IF llc$nonbindable IN header.identification.attributes THEN
              osp$set_status_abnormal (oc, oce$e_module_not_bindable,
                    last_component^.module_description^.name, status);
              EXIT /valid_data_processing/;
            IFEND;

            IF llc$object_cybil_checking IN header.identification.attributes THEN
              nlm^.changed_info^.cybil_parameter_checking := object_type_checking;
            IFEND;

            ocp$obtain_xdcl_list ({changed_info} NIL, occ$retain, {obtain_deferred_entry_points} FALSE,
                  last_component^.module_description^, modules_xdcl_list, start_proc,
                  deferred_entry_point_list, status);
            IF start_proc <> osc$null_name THEN
              nlm^.changed_info^.starting_procedure := start_proc;
            IFEND;
            IF NOT status.normal THEN
              EXIT /valid_data_processing/;
            IFEND;

            ocp$obtain_xref_list (last_component^.module_description^, modules_xref_list, occ$retain, status);
            IF NOT status.normal THEN
              EXIT /valid_data_processing/;
            IFEND;

            ocp$obtain_code_section_ids (last_component^.module_description^, last_code_section_ids^, status);
            IF NOT status.normal THEN
              EXIT /valid_data_processing/;
            IFEND;

            WHILE last_code_section_ids^.link <> NIL DO
              last_code_section_ids := last_code_section_ids^.link;
            WHILEND;

            ocp$obtain_library_list (last_component^.module_description^, NIL, modules_library_list,
                  occ$retain, status);
            IF NOT status.normal THEN
              EXIT /valid_data_processing/;
            IFEND;
            modules_last_xdcl := modules_xdcl_list.link;

            WHILE modules_last_xdcl <> NIL DO
              ocp$search_xdcl_list (modules_last_xdcl^.name, ^bound_modules_xdcl_list, xdcl_found, last_xdcl);
              IF xdcl_found THEN
                osp$set_status_abnormal (oc, oce$e_xdcl_already_exists, modules_last_xdcl^.name, status);
                EXIT /valid_data_processing/;
              IFEND;

              last_xdcl^.link := modules_last_xdcl;
              modules_last_xdcl := modules_last_xdcl^.link;
              last_xdcl^.link^.link := NIL;
            WHILEND;

            modules_last_xref := modules_xref_list.link;
            WHILE modules_last_xref <> NIL DO
              last_xref := ^nlm^.description^.bound_module_header^.xref_list;
              WHILE (last_xref^.link <> NIL) AND (last_xref^.link^.name <> modules_last_xref^.name) DO
                last_xref := last_xref^.link;
              WHILEND;

              IF last_xref^.link = NIL THEN
                last_xref^.link := modules_last_xref;
                modules_last_xref := modules_last_xref^.link;
                last_xref^.link^.link := NIL;
              ELSE
                modules_last_xref := modules_last_xref^.link;
              IFEND;
            WHILEND;


            modules_last_library := modules_library_list.link;
            WHILE modules_last_library <> NIL DO
              last_library := ^library_list;
              WHILE (last_library^.link <> NIL) AND (last_library^.link^.name <> modules_last_library^.name)
                    DO
                last_library := last_library^.link;
              WHILEND;

              IF last_library^.link = NIL THEN
                last_library^.link := modules_last_library;
                modules_last_library := modules_last_library^.link;
                last_library^.link^.link := NIL;
              ELSE
                modules_last_library := modules_last_library^.link;
              IFEND;
            WHILEND;
          FOREND;

          nlm^.changed_info^.entry_points := bound_modules_xdcl_list.link;
          nlm^.changed_info^.library_list := library_list.link;

          first_pass := FALSE;
          end_of_ordered_code_sections := ^nlm^.description^.bound_module_header^.code_section_ids;
?? EJECT ??
        ELSE { NOT first_pass
          IF pvt [p$name].specified THEN
            osp$set_status_abnormal (oc, cle$doubly_defined_parameter, 'NAME', status);
            EXIT /valid_data_processing/;
          IFEND;

          IF pvt [p$file].specified THEN
            osp$set_status_abnormal (oc, cle$doubly_defined_parameter, 'FILE', status);
            EXIT /valid_data_processing/;
          IFEND;
        IFEND;

        IF pvt [p$starting_procedure].specified THEN
          IF procedure_specified THEN
            osp$set_status_abnormal (oc, cle$doubly_defined_parameter, 'STARTING_PROCEDURE', status);
            EXIT /valid_data_processing/;
          IFEND;

          procedure_specified := TRUE;
          program_name := pvt [p$starting_procedure].value^.program_name_value;

          changed_info_entry_points.link := nlm^.changed_info^.entry_points;

          ocp$search_xdcl_list (program_name, ^changed_info_entry_points, xdcl_found, last_xdcl);
          IF NOT xdcl_found THEN
            osp$set_status_abnormal (oc, oce$e_xdcl_doesnt_exist, program_name, status);
            EXIT /valid_data_processing/;
          IFEND;

          nlm^.changed_info^.starting_procedure := program_name;
        IFEND;

        node := pvt [p$section_order].value;
        WHILE node <> NIL DO
          module_name := node^.element_value^.field_values^ [p$section_name].value^.program_name_value;
          ordinal_number := node^.element_value^.field_values^ [p$section_ordinal].value^.integer_value.value;

          last_code_section_ids := end_of_ordered_code_sections;

          WHILE ((last_code_section_ids^.link^.name <> module_name) OR
                (last_code_section_ids^.link^.section_ordinal <> ordinal_number)) AND
                (last_code_section_ids^.link^.link <> NIL) DO
            last_code_section_ids := last_code_section_ids^.link;
          WHILEND;

          IF (last_code_section_ids^.link^.name = module_name) AND
                (last_code_section_ids^.link^.section_ordinal = ordinal_number) THEN
            temporary_pointer := last_code_section_ids^.link;
            last_code_section_ids^.link := temporary_pointer^.link;
            temporary_pointer^.link := end_of_ordered_code_sections^.link;
            end_of_ordered_code_sections^.link := temporary_pointer;
            end_of_ordered_code_sections := temporary_pointer;
          ELSE
            STRINGREP (section_ordinal_stg, dummy, ordinal_number);
            osp$set_status_abnormal (oc, oce$e_code_section_not_found, section_ordinal_stg (1, dummy),
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, module_name, status);
            EXIT /valid_data_processing/;
          IFEND;
          node := node^.link;
        WHILEND;

        IF pvt [p$preset_value].specified THEN
          nlm^.description^.bound_module_header^.preset_specified := TRUE;
          IF pvt [p$preset_value].value^.keyword_value = 'ZERO' THEN
            nlm^.description^.bound_module_header^.preset_value := pmc$initialize_to_zero;
          ELSEIF pvt [p$preset_value].value^.keyword_value = 'FLOATING_POINT_INDEFINITE' THEN
            nlm^.description^.bound_module_header^.preset_value := pmc$initialize_to_indefinite;
          ELSEIF pvt [p$preset_value].value^.keyword_value = 'INFINITY' THEN
            nlm^.description^.bound_module_header^.preset_value := pmc$initialize_to_infinity;
          ELSE {IF pvt [p$preset_value].value^.keyword_value = 'ALTERNATE_ONES' THEN
            nlm^.description^.bound_module_header^.preset_value := pmc$initialize_to_alt_ones;
          IFEND;

        ELSE
          nlm^.description^.bound_module_header^.preset_value := pmc$initialize_to_zero;
        IFEND;

        IF pvt [p$include_binary_section_maps].specified THEN
          nlm^.description^.bound_module_header^.include_binary_section_maps :=
                pvt [p$include_binary_section_maps].value^.boolean_value.value;
        IFEND;

        IF pvt [p$output].specified THEN
          clp$convert_string_to_file (pvt [p$output].value^.file_value^, section_map_file, status);
          IF NOT status.normal THEN
            EXIT /valid_data_processing/;
          IFEND;
          nlm^.description^.bound_module_header^.section_map.local_file_name :=
                section_map_file.local_file_name;
        IFEND;

        IF pvt [p$mode].value^.keyword_value <> 'QUIT' THEN
          EXIT /protect/;
        ELSE


          last_component := component_list.link;

          ALLOCATE nlm^.description^.bound_module_header^.components: [1 .. number_of_components] IN
                ocv$olg_working_heap^;
          IF nlm^.description^.bound_module_header^.components = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;
          FOR component_number := 1 TO number_of_components DO
            nlm^.description^.bound_module_header^.components^ [component_number] :=
                  last_component^.module_description;
            last_component := last_component^.link;
            component_list.link := last_component;
          FOREND;

          ocp$add_an_nlm (ocv$nlm_list^.b_link, nlm);

          first_pass := TRUE;
          procedure_specified := FALSE;

          EXIT /protect/; { This is the normal RETURN path when MODE=QUIT.
        IFEND;

      END /valid_data_processing/;


      FREE nlm IN ocv$olg_working_heap^;
      first_pass := TRUE;
      procedure_specified := FALSE;
    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);

  PROCEND ocp$_bind_module;
?? OLDTITLE ??

MODEND ocm$bind_module;
*DECK DECK=OCM$BUILD_CODE_SEC_DIRECTORY EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$build_code_sec_directory;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc oct$code_section_directory
*copyc llt$object_library_header
*copyc llt$module_dictionary
*copyc llt$load_module_header
*copyc llt$object_text_descriptor
*copyc llt$section_address
*copyc llt$section_definition
*copyc llt$segment_definition
*copyc llt$obsolete_segment_definition
?? POP ??

*copyc och$build_code_sec_directory

  PROCEDURE [XDCL] ocp$build_code_sec_directory (p_object_library: ^SEQ ( * );
    VAR code_section_directory: ^oct$code_section_directory;
    VAR module_code_sections: ^oct$module_code_sections);

    VAR
      end_of_section_definitions: boolean,
      first: llt$section_ordinal,
      found: boolean,
      i: llt$module_index,
      j: llt$section_ordinal,
      module_dictionary: ^llt$module_dictionary,
      module_header: ^llt$load_module_header,
      object_library: ^SEQ ( * ),
      object_library_dictionaries: ^llt$object_library_dictionaries,
      object_library_header: ^llt$object_library_header,
      object_text_descriptor: ^llt$object_text_descriptor,
      obsolete_segment_definition: ^llt$obsolete_segment_definition,
      section_definition: ^llt$section_definition,
      segment_definition: ^llt$segment_definition,
      section_definitions: ^llt$object_text_descriptor;

    object_library := p_object_library;

    RESET object_library;
    NEXT object_library_header IN object_library;
    NEXT object_library_dictionaries: [1 .. object_library_header^.number_of_dictionaries] IN object_library;
    found := FALSE;
    i := 1;

    REPEAT
      IF object_library_dictionaries^ [i].kind = llc$module_dictionary THEN
        found := TRUE;
      ELSE
        i := i + 1;
      IFEND;
    UNTIL found OR (i > object_library_header^.number_of_dictionaries);

    IF found THEN
      module_dictionary := #PTR (object_library_dictionaries^ [i].module_dictionary, object_library^);
      ALLOCATE code_section_directory: [1 .. UPPERBOUND (module_dictionary^)];
      ALLOCATE module_code_sections: [1 .. llc$max_section_ordinal];
      j := 1;

      FOR i := 1 TO UPPERBOUND (module_dictionary^) DO
        IF module_dictionary^ [i].kind = llc$load_module THEN
          module_header := #PTR (module_dictionary^ [i].module_header, object_library^);
          IF llc$section_element IN module_header^.interpretive_header.elements_defined THEN
            section_definitions := #PTR (module_header^.interpretive_header.section_definitions,
                  object_library^);
            RESET object_library TO section_definitions;
            first := j;
            end_of_section_definitions := FALSE;

            REPEAT
              NEXT object_text_descriptor IN object_library;
              CASE object_text_descriptor^.kind OF
              = llc$allotted_section_definition =
                NEXT section_definition IN object_library;
                IF section_definition^.kind = llc$code_section THEN
                  module_code_sections^ [j].section_ordinal := section_definition^.section_ordinal;
                  module_code_sections^ [j].start_of_section := #address (#ring (object_library), #segment
                        (object_library), object_text_descriptor^.allotted_section);
                  j := j + 1;
                IFEND;

              = llc$section_definition, llc$unallocated_common_block =
                NEXT section_definition IN object_library;

              = llc$obsolete_allotted_seg_def =
                NEXT obsolete_segment_definition IN object_library;
                IF obsolete_segment_definition^.section_definition.kind = llc$code_section THEN
                  module_code_sections^ [j].section_ordinal := obsolete_segment_definition^.
                        section_definition.section_ordinal;
                  module_code_sections^ [j].start_of_section := #address (#ring (object_library), #segment
                        (object_library), object_text_descriptor^.allotted_segment);
                  j := j + 1;
                IFEND;

              = llc$allotted_segment_definition =
                NEXT segment_definition IN object_library;
                IF segment_definition^.section_definition.kind = llc$code_section THEN
                  module_code_sections^ [j].section_ordinal := segment_definition^.section_definition.
                        section_ordinal;
                  module_code_sections^ [j].start_of_section := #address (#ring (object_library), #segment
                        (object_library), object_text_descriptor^.allotted_segment);
                  j := j + 1;
                IFEND;

              = llc$obsolete_segment_definition =
                NEXT obsolete_segment_definition IN object_library;

              = llc$segment_definition =
                NEXT segment_definition IN object_library;

              ELSE
                end_of_section_definitions := TRUE;
              CASEND;
            UNTIL end_of_section_definitions;
            code_section_directory^ [i].first_entry_number := first;
            code_section_directory^ [i].last_entry_number := j - 1;
          IFEND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND ocp$build_code_sec_directory;
MODEND ocm$build_code_sec_directory;
*DECK DECK=OCM$BUILD_CORRECTOR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Management : Correction Generation' ??
MODULE ocm$build_corrector;
?? PUSH (LISTEXT := ON) ??
*copyc occ$corrector
*copyc oce$metapatch_generator_errors
*copyc oct$breaklist
*copyc oct$corrector
*copyc oct$offset
?? POP ??
*copyc amp$get_segment_pointer
*copyc i#move
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pmp$get_unique_name

  TYPE
    byte_array = array [1 .. * ] of 0 .. 0ff(16);

?? NEWTITLE := '[XDCL] ocp$build_corrector', EJECT ??
*copyc och$build_corrector

  PROCEDURE [XDCL] ocp$build_corrector
    (    old_breaklist: ^oct$breaklist;
         new_breaklist: ^oct$breaklist;
         p_second_inter_ol: ^SEQ ( * );
         p_new_ol: ^SEQ ( * );
         length_of_old_breaklist: oct$breaklist_length;
         length_of_new_breaklist: oct$breaklist_length;
     VAR compressed_corrector: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      bytes_ok: oct$offset,
      bytes_to_delete: oct$offset,
      bytes_to_insert: oct$offset,
      corrector: ^SEQ ( * ),
      corrector_header: ^oct$corrector_header,
      corrector_item_size: 0 .. 256,
      from: ^cell,
      i: oct$breaklist_length,
      j: oct$breaklist_length,
      local_status: ost$status,
      match_found: boolean,
      new: oct$breaklist_length,
      new_breaklist_bytes: ^byte_array,
      new_current_position_pointer: ^cell,
      new_length: oct$breaklist_length,
      new_ol: ^SEQ ( * ),
      new_start: oct$breaklist_length,
      offset: oct$offset,
      old: oct$breaklist_length,
      old_breaklist_bytes: ^byte_array,
      old_current_position_pointer: ^cell,
      old_length: oct$breaklist_length,
      old_start: oct$breaklist_length,
      second_inter_ol: ^SEQ ( * ),
      temp_cor: ost$name,
      temp_cor_fid: amt$file_identifier,
      temp_cor_file_opened: boolean,
      temp_cor_seg: amt$segment_pointer;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the file has been opened, it will be closed before the
{   the procedure returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF temp_cor_file_opened THEN
        fsp$close_file (temp_cor_fid, ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    new_ol := p_new_ol;
    second_inter_ol := p_second_inter_ol;

    pmp$get_unique_name (temp_cor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      attachment_options [1].selector := fsc$access_and_share_modes;
      attachment_options [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options [1].access_modes.value := $fst$file_access_options
            [fsc$read, fsc$shorten, fsc$append, fsc$modify];
      attachment_options [1].share_modes.selector := fsc$determine_from_access_modes;
      attachment_options [2].selector := fsc$create_file;
      attachment_options [2].create_file := TRUE;
      attachment_options [3].selector := fsc$wait_for_attachment;
      attachment_options [3].wait_for_attachment.wait := osc$wait;
      attachment_options [3].wait_for_attachment.wait_time := fsc$longest_wait_time;

      temp_cor_file_opened := TRUE;
      fsp$open_file (temp_cor, amc$segment, ^attachment_options, NIL, NIL, NIL, NIL, temp_cor_fid, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (temp_cor_fid, amc$sequence_pointer, temp_cor_seg, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      corrector := temp_cor_seg.sequence_pointer;

      RESET corrector;
      NEXT corrector_header IN corrector;
      corrector_header^.version := occ$corrector_header_version;
      corrector_header^.number_of_correctors := 0;
      corrector_header^.size := #SIZE (corrector_header^);
      new := 1;
      corrector_item_size := #SIZE (oct$corrector_item);
      FOR old := 1 TO length_of_old_breaklist DO
        match_found := FALSE;
        WHILE NOT match_found DO
          IF new > length_of_new_breaklist THEN
            osp$set_status_abnormal (occ$status_id, oce$error_in_correction_gen, 'building corrector',
                  status);
            EXIT /main/;
          IFEND;
          match_found := (old_breaklist^ [old].module_name = new_breaklist^ [new].module_name) AND
                (old_breaklist^ [old].major_name = new_breaklist^ [new].major_name) AND
                (old_breaklist^ [old].minor_name = new_breaklist^ [new].minor_name) AND
                (old_breaklist^ [old].kind = new_breaklist^ [new].kind) AND
                (old_breaklist^ [old].section_ordinal = new_breaklist^ [new].section_ordinal) AND
                (old_breaklist^ [old].secondary_section_ordinal =
                new_breaklist^ [new].secondary_section_ordinal);
          IF NOT match_found THEN
            from := #ADDRESS (#RING (new_ol), #SEGMENT (new_ol), new_breaklist^ [new].offset);
            build_corrector_item (0, 0, new_breaklist^ [new].length, from, corrector, corrector_header);
            new := new + 1;
          IFEND;
        WHILEND;
        old_current_position_pointer := #ADDRESS (#RING (second_inter_ol), #SEGMENT (second_inter_ol),
              old_breaklist^ [old].offset);
        new_current_position_pointer := #ADDRESS (#RING (new_ol), #SEGMENT (new_ol),
              new_breaklist^ [new].offset);
        RESET second_inter_ol TO old_current_position_pointer;
        RESET new_ol TO new_current_position_pointer;
        old_length := old_breaklist^ [old].length;
        new_length := new_breaklist^ [new].length;
        NEXT old_breaklist_bytes: [1 .. old_length] IN second_inter_ol;
        NEXT new_breaklist_bytes: [1 .. new_length] IN new_ol;
        old_start := 1;
        new_start := 1;

        REPEAT
          IF (old_start <= old_length) AND (new_start <= new_length) THEN
            search_until_difference (old_breaklist_bytes, new_breaklist_bytes, old_start, new_start,
                  bytes_ok);
            old_start := old_start + bytes_ok;
            new_start := new_start + bytes_ok;

            IF (old_start <= old_length) AND (new_start <= new_length) THEN
              search_until_match (old_breaklist^ [old].kind, old_breaklist_bytes, new_breaklist_bytes,
                    old_start, new_start, bytes_to_delete, bytes_to_insert);
              old_start := old_start + bytes_to_delete;
              new_start := new_start + bytes_to_insert;
            ELSE
              bytes_to_insert := new_length - new_start + 1;
              bytes_to_delete := old_length - old_start + 1;
              old_start := old_start + bytes_to_delete;
              new_start := new_start + bytes_to_insert;
            IFEND;
          ELSE
            bytes_ok := 0;
            bytes_to_delete := old_length - old_start + 1;
            bytes_to_insert := new_length - new_start + 1;
            old_start := old_start + bytes_to_delete;
            new_start := new_start + bytes_to_insert;
          IFEND;
          IF (bytes_ok > 0) AND (bytes_ok < corrector_item_size) AND NOT ((bytes_to_delete = 0) AND
                (bytes_to_insert = 0)) THEN
            bytes_to_delete := bytes_to_delete + bytes_ok;
            bytes_to_insert := bytes_to_insert + bytes_ok;
            bytes_ok := 0;
          IFEND;
          IF bytes_to_insert > 0 THEN
            offset := new_breaklist^ [new].offset + new_start - bytes_to_insert - 1;
            from := #ADDRESS (#RING (new_ol), #SEGMENT (new_ol), offset);
          ELSE
            from := NIL;
          IFEND;
          build_corrector_item (bytes_ok, bytes_to_delete, bytes_to_insert, from, corrector,
                corrector_header);
        UNTIL (old_start > old_length) OR (new_start > new_length);
        new := new + 1;
      FOREND;

      IF new <= length_of_new_breaklist THEN
        j := 0;
        FOR i := new TO length_of_new_breaklist DO
          j := j + new_breaklist^ [i].length;
        FOREND;
        IF j > 0 THEN
          from := #ADDRESS (#RING (new_ol), #SEGMENT (new_ol), new_breaklist^ [new].offset);
        ELSE
          from := NIL;
        IFEND;
        build_corrector_item (0, 0, j, from, corrector, corrector_header);
      IFEND;

      compress_corrector (corrector, compressed_corrector);

    END /main/;

    IF temp_cor_file_opened THEN
      fsp$close_file (temp_cor_fid, local_status);
    IFEND;

    osp$disestablish_cond_handler;

    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

  PROCEND ocp$build_corrector;
?? OLDTITLE ??
?? NEWTITLE := 'compress_corrector', EJECT ??

{ PURPOSE:
{    The purpose of this request is compress the corrector.  Upon entry
{ the corrector contains at least one item for each breaklist item.  This
{ procedure combines corrector items that do not specify any bytes to delete
{ or insert with its adjacent corrector item.

  PROCEDURE compress_corrector
    (    p_old_corrector: ^SEQ ( * );
     VAR new_corrector: ^SEQ ( * ));

    VAR
      i: oct$corrector_size,
      index: oct$corrector_size,
      j: oct$corrector_size,
      new_bytes: ^oct$new_bytes,
      new_corrector_header: ^oct$corrector_header,
      new_item: ^oct$corrector_item,
      old_corrector: ^SEQ ( * ),
      old_corrector_header: ^oct$corrector_header,
      old_item: ^oct$corrector_item,
      save_bytes: ^oct$new_bytes,
      temp_bytes: ^oct$new_bytes,
      temp_item: oct$corrector_item;

    old_corrector := p_old_corrector;

    ALLOCATE save_bytes: [1 .. 10000000];
    RESET old_corrector;
    RESET new_corrector;
    NEXT old_corrector_header IN old_corrector;
    NEXT new_corrector_header IN new_corrector;
    new_corrector_header^ := old_corrector_header^;
    new_corrector_header^.size := #SIZE (new_corrector_header^);
    new_corrector_header^.number_of_correctors := 0;

    index := 1;
    NEXT old_item IN old_corrector;
    temp_item := old_item^;
    IF old_item^.bytes_to_insert > 0 THEN
      NEXT temp_bytes: [1 .. old_item^.bytes_to_insert] IN old_corrector;
      FOR j := 1 TO old_item^.bytes_to_insert DO
        save_bytes^ [index] := temp_bytes^ [j];
        index := index + 1;
      FOREND;
    IFEND;

    FOR i := 2 TO old_corrector_header^.number_of_correctors DO
      NEXT old_item IN old_corrector;
      IF (old_item^.bytes_ok > 0) AND NOT ((temp_item.bytes_to_delete = 0) AND
            (temp_item.bytes_to_insert = 0)) THEN
        NEXT new_item IN new_corrector;
        new_item^ := temp_item;
        new_corrector_header^.size := new_corrector_header^.size + #SIZE (new_item^);
        IF new_item^.bytes_to_insert > 0 THEN
          NEXT new_bytes: [1 .. new_item^.bytes_to_insert] IN new_corrector;
          FOR j := 1 TO new_item^.bytes_to_insert DO
            new_bytes^ [j] := save_bytes^ [j];
          FOREND;
          index := 1;
          new_corrector_header^.size := new_corrector_header^.size + #SIZE (new_bytes^);
        IFEND;
        new_corrector_header^.number_of_correctors := new_corrector_header^.number_of_correctors + 1;
        temp_item := old_item^;
      ELSE
        temp_item.bytes_ok := temp_item.bytes_ok + old_item^.bytes_ok;
        temp_item.bytes_to_delete := temp_item.bytes_to_delete + old_item^.bytes_to_delete;
        temp_item.bytes_to_insert := temp_item.bytes_to_insert + old_item^.bytes_to_insert;
      IFEND;
      IF old_item^.bytes_to_insert > 0 THEN
        NEXT temp_bytes: [1 .. old_item^.bytes_to_insert] IN old_corrector;
        FOR j := 1 TO old_item^.bytes_to_insert DO
          save_bytes^ [index] := temp_bytes^ [j];
          index := index + 1;
        FOREND;
      IFEND;
    FOREND;
    NEXT new_item IN new_corrector;
    new_item^ := temp_item;
    new_corrector_header^.size := new_corrector_header^.size + #SIZE (new_item^);
    IF new_item^.bytes_to_insert > 0 THEN
      NEXT new_bytes: [1 .. new_item^.bytes_to_insert] IN new_corrector;
      FOR j := 1 TO new_item^.bytes_to_insert DO
        new_bytes^ [j] := save_bytes^ [j];
      FOREND;
      new_corrector_header^.size := new_corrector_header^.size + #SIZE (new_bytes^);
    IFEND;
    new_corrector_header^.number_of_correctors := new_corrector_header^.number_of_correctors + 1;
    FREE save_bytes;

  PROCEND compress_corrector;
?? OLDTITLE ??
?? NEWTITLE := 'tune_search_options', EJECT ??

  PROCEDURE tune_search_options
    (    breaklist_kind: oct$breaklist_kind;
     VAR length: oct$breaklist_length;
     VAR max_tries: oct$breaklist_index);


    length := 2;
    max_tries := 100;
    CASE breaklist_kind OF
    = occ$code =
      length := 8;
      max_tries := 500;
    = occ$idr =
      length := 2;
      max_tries := 50;
    = occ$read =
      length := 20;
      max_tries := 148;
    = occ$ept =
      length := 2;
      max_tries := 55;
    = occ$ext =
      length := 2;
      max_tries := 55;
    = occ$module_header =
      length := 8;
      max_tries := 100;
    = occ$adr =
      length := 4;
      max_tries := 100;
    = occ$text =
      length := 2;
      max_tries := 50;
    = occ$secdef =
      length := 8;
      max_tries := 64;
    = occ$object_library_header =
      length := 2;
      max_tries := 50;
    = occ$dictionary =
      length := 27;
      max_tries := 148;
    = occ$command_proc =
      length := 4;
      max_tries := 30;
    = occ$program_des =
      length := 4;
      max_tries := 30;
    = occ$app_command_proc =
      length := 4;
      max_tries := 30;
    = occ$app_program_des =
      length := 4;
      max_tries := 30;
    = occ$info_element =
      length := 8;
      max_tries := 30;
    = occ$bti =
      length := 8;
      max_tries := 148;
    = occ$rel =
      length := 4;
      max_tries := 10;
    = occ$component =
      length := 8;
      max_tries := 24;
    = occ$section_map =
      length := 2;
      max_tries := 19;
    = occ$function_proc =
      length := 2;
      max_tries := 100;
    = occ$message_mod =
      length := 2;
      max_tries := 100;
    = occ$panel_mod =
      length := 2;
      max_tries := 100;
    = occ$library_member_header =
      length := 2;
      max_tries := 100;
    = occ$mtm_header =
      length := 2;
      max_tries := 100;
    = occ$mtm_cc =
      length := 2;
      max_tries := 100;
    = occ$mtm_cn =
      length := 2;
      max_tries := 100;
    = occ$mess_temp =
      length := 2;
      max_tries := 100;
    = occ$m68000 =
      length := 4;
      max_tries := 500;
    = occ$deferred_ept =
      length := 2;
      max_tries := 56;
    = occ$deferred_common_blk =
      length := 2;
      max_tries := 73;
    ELSE
      ;
    CASEND;
  PROCEND tune_search_options;
?? OLDTITLE ??
?? NEWTITLE := 'search_until_match', EJECT ??

{ PURPOSE:
{    The purpose of this request is to search the bytes in a breaklist item
{ until a match is found.  The number of bytes between where the search is
{ started and where the match is found determines the number of bytes to be
{ inserted or deleted.

  PROCEDURE search_until_match
    (    breaklist_kind: oct$breaklist_kind;
         old_breaklist_bytes: ^byte_array;
         new_breaklist_bytes: ^byte_array;
         old_start: oct$breaklist_length;
         new_start: oct$breaklist_length;
     VAR bytes_to_delete: oct$offset;
     VAR bytes_to_insert: oct$offset);

    VAR
      compare_length: oct$breaklist_length,
      i: oct$breaklist_length,
      match: boolean,
      max_tries: oct$breaklist_index,
      new: oct$breaklist_length,
      new_length: oct$breaklist_length,
      new_remainder: oct$breaklist_length,
      old: oct$breaklist_length,
      old_length: oct$breaklist_length,
      old_remainder: oct$breaklist_length;

{ This procedure searches through the old and new object libraries using
{ arrays which point to certain sections of the object library.  The
{ variables used to accomplish this search are -
{       OLD_LENGTH:  The length (or last byte) of the old breaklist item array.
{       NEW_LENGTH:  The length (or last byte) of the new breaklist item array.
{       OLD_START:   The position in the old breaklist of the first byte compared
{                    during this call of the procedure.
{       NEW_START:   The position in the new breaklist of the first byte compared
{                    during this call of the procedure.
{       OLD:         The current position in the old breaklist array.
{       NEW:         The current position in the new breaklist array.
{ OLD_START, NEW_START, OLD_LENGTH, and NEW_LENGTH are not changed during the running
{ of this procedure.  OLD and NEW are updated as needed to make comparisons while searching.

    old_length := UPPERBOUND (old_breaklist_bytes^);
    new_length := UPPERBOUND (new_breaklist_bytes^);
    old := old_start;
    new := new_start + 1;

{ The call to OCP$TUNE_SEARCH_OPTIONS sets initial values for COMPARE_LENGTH and
{ MAX_TRIES which are used in searching.  These variables are tuned to the kind
{ of breaklist being searched.  (For example: CODE, RELOCATION RECORDS, BINDING
{ TEMPLATE RECORDS, SECTION_MAPS, etc.) COMPARE_LENGTH is the number of consecutive
{ bytes that must be the same in order to be considered a match.  MAX_TRIES is
{ the number of compares that may be made before "giving up" and beginning to
{ look for a match at the next possible location.  As the search approaches the
{ end of the breaklist item, both MAX_TRIES and COMPARE_LENGTH will be updated
{ to allow searching to continue right to the end of the breaklist item.

    tune_search_options (breaklist_kind, compare_length, max_tries);

    match := FALSE;
    WHILE NOT match AND (old <= old_length) AND (new <= new_length) DO

{ As mentioned above,  MAX_TRIES and COMPARE_LENGTH get updated when getting
{ to the end of a breaklist item.  If COMPARE_LENGTH is greater than the
{ number of bytes left in the old or the new breaklist it is adjusted to the
{ smaller of the two.  If MAX_TRIES is greater than the number of bytes left in
{ the new breaklist it gets reset to this number.  These adjustments are made in
{ order to allow comparisons to be made right to the end of the breaklist item.

      old_remainder := old_length - old + 1;
      new_remainder := new_length - new + 1;
      IF (old_remainder < compare_length) AND (old_remainder <= new_remainder) THEN
        compare_length := old_remainder;
      ELSEIF (new_remainder < compare_length) AND (new_remainder <= old_remainder) THEN
        compare_length := new_remainder;
      IFEND;

      IF max_tries > (new_length - new + 1) THEN
        max_tries := new_length - new + 1;
      IFEND;

{ Check for a match that is the appropriate number of bytes long.

      match := TRUE;
      i := 0;
      WHILE match AND (i < compare_length) DO
        match := (old_breaklist_bytes^ [old + i] = new_breaklist_bytes^ [new + i]);
        i := i + 1;
      WHILEND;

      IF match THEN
        bytes_to_delete := old - old_start;
        bytes_to_insert := new - new_start;

      ELSEIF ((new - new_start + 1) >= max_tries) AND ((old - old_start) <= (max_tries * 2)) THEN

{ If enough compares have been made between one byte item (a byte item would be a string of bytes
{ the length of COMPARE_LENGTH) in the old breaklist and MAX_TRIES byte items in the new breaklist,
{ restart the search at the next byte item in the old breaklist and the starting location in the new
{ breaklist.

        old := old + 1;
        new := new_start;

      ELSEIF ((new - new_start + 1) >= max_tries) AND ((old - old_start) > (max_tries * 2)) THEN

{ If enough compares have been made in searching for a match (MAX_TRIES * 2 byte items in the
{ old breaklist with MAX_TRIES byte items in the new breaklist), then "give up".  Although a match
{ has not actually been found, this flag is set in order to drop out of the loop.  Bytes_to_delete
{ and bytes_to_insert are set to delete MAX_TRIES bytes from the old breaklist and to insert
{ MAX_TRIES bytes in the new breaklist since no match was found.  The next time this procedure is
{ entered OLD_START and NEW_START will be set so that searching will begin again at this point.

        match := TRUE;
        old := old_start + max_tries;
        bytes_to_delete := old - old_start;
        bytes_to_insert := new - new_start;

      ELSE

{ If a match is not found continue searching with the next byte item in the new breaklist.

        new := new + 1;
      IFEND;
    WHILEND;

    IF (old > old_length) OR (new > new_length) THEN
      bytes_to_delete := old_length - old_start + 1;
      bytes_to_insert := new_length - new_start + 1;
    IFEND;
  PROCEND search_until_match;
?? OLDTITLE ??
?? NEWTITLE := 'search_until_difference', EJECT ??

{ PURPOSE:
{    The purpose of this request is to compare bytes in an old breaklist
{ and a new breaklist and count the bytes that match until a non-match is
{ found.

  PROCEDURE search_until_difference
    (    old_breaklist_bytes: ^byte_array;
         new_breaklist_bytes: ^byte_array;
         old_start: oct$breaklist_length;
         new_start: oct$breaklist_length;
     VAR bytes_ok: oct$offset);

    VAR
      match: boolean,
      new: oct$breaklist_length,
      new_length: oct$breaklist_length,
      old: oct$breaklist_length,
      old_length: oct$breaklist_length;

    old_length := UPPERBOUND (old_breaklist_bytes^);
    new_length := UPPERBOUND (new_breaklist_bytes^);
    old := old_start;
    new := new_start;
    match := TRUE;
    WHILE match AND (old <= old_length) AND (new <= new_length) DO
      match := (old_breaklist_bytes^ [old] = new_breaklist_bytes^ [new]);
      old := old + 1;
      new := new + 1;
    WHILEND;

    IF match THEN
      bytes_ok := old - old_start;
    ELSE
      bytes_ok := old - old_start - 1;
    IFEND;
  PROCEND search_until_difference;
?? OLDTITLE ??
?? NEWTITLE := 'build_corrector_item', EJECT ??

{ PURPOSE:
{    The purpose of this request is to build an individual corrector item,
{ which together with the corrector header and the bytes that must be inserted,
{ make up the entire corrector which is used in the third and final pass of
{ an update.
{    Each corrector item specifies the number of bytes that are ok (can be
{ left unchanged from old version to new version), the number of bytes
{ to delete from the old version and the number of bytes to be inserted.
{ If there are bytes to insert they are placed in the corrector right after
{ the corrector item that references them.

  PROCEDURE build_corrector_item
    (    bytes_ok: oct$offset;
         bytes_to_delete: oct$offset;
         bytes_to_insert: oct$offset;
         from: ^cell;
     VAR corrector: ^SEQ ( * );
     VAR corrector_header: ^oct$corrector_header);

    VAR
      corrector_item: ^oct$corrector_item,
      new_bytes: ^oct$new_bytes;

    NEXT corrector_item IN corrector;
    corrector_item^.bytes_ok := bytes_ok;
    corrector_item^.bytes_to_delete := bytes_to_delete;
    corrector_item^.bytes_to_insert := bytes_to_insert;
    corrector_header^.size := corrector_header^.size + #SIZE (corrector_item^);

    IF bytes_to_insert > 0 THEN
      NEXT new_bytes: [1 .. bytes_to_insert] IN corrector;
      i#move (from, new_bytes, bytes_to_insert);
      corrector_header^.size := corrector_header^.size + bytes_to_insert;
    IFEND;

    corrector_header^.number_of_correctors := corrector_header^.number_of_correctors + 1;
  PROCEND build_corrector_item;
?? OLDTITLE ??

MODEND ocm$build_corrector;
*DECK DECK=OCM$BUILD_FIRST_INTERMEDIATE_OL EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$build_first_intermediate_ol;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc occ$generate_predictor
*copyc oct$offset_change_list
*copyc oct$predictor_header
*copyc oce$metapatch_generator_errors
*copyc ocp$apply_module_predictors
*copyc ocp$process_dictionaries
*copyc ocp$copy
*copyc osp$set_status_abnormal
?? POP ??

*copyc och$build_first_intermediate_ol

  PROCEDURE [XDCL] ocp$build_first_intermediate_ol (p_predictor: ^SEQ ( * );
        old_ol: ^SEQ ( * );
    VAR first_intermediate_ol: ^SEQ ( * );
    VAR status: ost$status);

    VAR
      mod_dictionary_ocv: ^oct$offset_change_list,
      ol_dictionary_ocv: ^oct$offset_change_list,
      predictor: ^SEQ ( * ),
      predictor_header: ^oct$predictor_header,
      valid: boolean;

    predictor := p_predictor;

    ocp$copy (old_ol, first_intermediate_ol, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET predictor;
    NEXT predictor_header IN predictor;
    IF predictor_header^.number_module_predictors > 0 THEN
      RESET predictor;
      ocp$apply_module_predictors (predictor, first_intermediate_ol, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    IF (predictor_header^.number_of_ol_ocv_elements > 0) THEN
      ol_dictionary_ocv := #PTR (predictor_header^.ol_dictionary_ocv, predictor^);
    ELSE
      ol_dictionary_ocv := NIL;
    IFEND;
    IF (predictor_header^.number_of_mod_ocv_elements > 0) THEN
      mod_dictionary_ocv := #PTR (predictor_header^.mod_dictionary_ocv, predictor^);
    ELSE
      mod_dictionary_ocv := NIL;
    IFEND;
    IF (mod_dictionary_ocv <> NIL) OR (ol_dictionary_ocv <> NIL) THEN
      ocp$process_dictionaries (ol_dictionary_ocv, mod_dictionary_ocv, first_intermediate_ol, status);
    IFEND;
  PROCEND ocp$build_first_intermediate_ol;
MODEND ocm$build_first_intermediate_ol;
*DECK DECK=OCM$BUILD_MODULE_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??                                                         
MODULE ocm$build_module_attributes;                                                                           
                                                                                                              
                                                                                                              
                                                                                                              
{ PURPOSE:                                                                                                    
{   To return information about a specific module in scl data structures.                                     
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc llt$object_module                                                                                      
*copyc llt$load_module                                                                                        
*copyc oce$library_generator_errors                                                                           
*copyc oct$attribute_keyword_set                                                                              
*copyc oct$changed_info                                                                                       
*copyc oct$external_reference_list                                                                            
*copyc oct$header                                                                                             
*copyc oct$module_attribute_keywords                                                                          
*copyc oct$module_description                                                                                 
*copyc oct$name_list                                                                                          
*copyc ocs$literals                                                                                           
?? POP ??                                                                                                     
*copyc clp$evaluate_parameters                                                                                
*copyc clp$get_message_module_info                                                                            
*copyc clp$make_boolean_value                                                                                 
*copyc clp$make_integer_value                                                                                 
*copyc clp$make_keyword_value                                                                                 
*copyc clp$make_list_value                                                                                    
*copyc clp$make_name_value                                                                                    
*copyc clp$make_program_name_value                                                                            
*copyc clp$make_range_value                                                                                   
*copyc clp$make_record_value                                                                                  
*copyc clp$make_status_code_value                                                                             
*copyc clp$make_string_value                                                                                  
*copyc clp$make_unspecified_value                                                                             
*copyc clp$trimmed_string_size                                                                                
*copyc ocp$make_date_time_value                                                                               
*copyc ocp$make_file_value                                                                                    
*copyc ocp$make_library_member_kind_va                                                                        
*copyc ocp$make_module_generator_value                                                                        
*copyc ocp$make_module_kind_value                                                                             
*copyc ocp$obtain_component_info                                                                              
*copyc ocp$obtain_header                                                                                      
*copyc ocp$obtain_library_list                                                                                
*copyc ocp$obtain_xdcl_list                                                                                   
*copyc ocp$obtain_xref_list                                                                                   
*copyc osp$get_status_condition_string                                                                        
*copyc osp$set_status_abnormal                                                                                
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??                                        
                                                                                                              
?? FMT (FORMAT := OFF) ??                                                                                     
  VAR                                                                                                         
    ocv$module_attribute_keys: [XDCL, READ, ocs$literals                                                      
] array [1 .. occ$kwd_maximum] of record                                                                      
      attribute: oct$module_attribute_keywords,                                                               
      name: ost$name,                                                                                         
    recend := [                                                                                               
     [occ$kwd_abort_file             , 'ABORT_FILE'],                                                         
     [occ$kwd_aliases                , 'ALIASES'],                                                            
     [occ$kwd_all                    , 'ALL'],                                                                
     [occ$kwd_application_identifier , 'APPLICATION_IDENTIFIER'],                                             
     [occ$kwd_arithmetic_loss_of_sig , 'ARITHMETIC_LOSS_OF_SIGNIFICANCE'],                                    
     [occ$kwd_arithmetic_overflow    , 'ARITHMETIC_OVERFLOW'],                                                
     [occ$kwd_availability           , 'AVAILABILITY'],                                                       
     [occ$kwd_comment                , 'COMMENT'],                                                            
     [occ$kwd_components             , 'COMPONENTS'],                                                         
     [occ$kwd_creation_date_time     , 'CREATION_DATE_TIME'],                                                 
     [occ$kwd_debug_input            , 'DEBUG_INPUT'],                                                        
     [occ$kwd_debug_mode             , 'DEBUG_MODE'],                                                         
     [occ$kwd_debug_output           , 'DEBUG_OUTPUT'],                                                       
     [occ$kwd_divide_fault           , 'DIVIDE_FAULT'],                                                       
     [occ$kwd_entry_points           , 'ENTRY_POINTS'],                                                       
     [occ$kwd_exponent_overflow      , 'EXPONENT_OVERFLOW'],                                                  
     [occ$kwd_exponent_underflow     , 'EXPONENT_UNDERFLOW'],                                                 
     [occ$kwd_fp_indefinite          , 'FP_INDEFINITE'],                                                      
     [occ$kwd_fp_loss_of_significance, 'FP_LOSS_OF_SIGNIFICANCE'],                                            
     [occ$kwd_generator              , 'GENERATOR'],                                                          
     [occ$kwd_generator_version      , 'GENERATOR_VERSION'],                                                  
     [occ$kwd_header                 , 'HEADER'],                                                             
     [occ$kwd_invalid_bdp_data       , 'INVALID_BDP_DATA'],                                                   
     [occ$kwd_kind                   , 'KIND'],                                                               
     [occ$kwd_libraries              , 'LIBRARIES'],                                                          
     [occ$kwd_load_map               , 'LOAD_MAP'],                                                           
     [occ$kwd_load_map_options       , 'LOAD_MAP_OPTIONS'],                                                   
     [occ$kwd_log_option             , 'LOG_OPTION'],                                                         
     [occ$kwd_modules                , 'MODULES'],                                                            
     [occ$kwd_module_kind            , 'MODULE_KIND'],                                                        
     [occ$kwd_name                   , 'NAME'],                                                               
     [occ$kwd_natural_language       , 'NATURAL_LANGUAGE'],                                                   
     [occ$kwd_object_files           , 'OBJECT_FILES'],                                                       
     [occ$kwd_online_manual          , 'ONLINE_MANUAL'],                                                      
     [occ$kwd_preset_value           , 'PRESET_VALUE'],                                                       
     [occ$kwd_program_attributes     , 'PROGRAM_ATTRIBUTES'],                                                 
     [occ$kwd_references             , 'REFERENCES'],                                                         
     [occ$kwd_scope                  , 'SCOPE'],                                                              
     [occ$kwd_stack_size             , 'STACK_SIZE'],                                                         
     [occ$kwd_starting_procedure     , 'STARTING_PROCEDURE'],                                                 
     [occ$kwd_status_codes           , 'STATUS_CODES'],                                                       
     [occ$kwd_system_command_name    , 'SYSTEM_COMMAND_NAME'],                                                
     [occ$kwd_termination_error_level, 'TERMINATION_ERROR_LEVEL'],                                            
     [occ$kwd_text_kind              , 'TEXT_KIND']];                                                         
?? FMT (FORMAT := ON) ??                                                                                      
                                                                                                              
  TYPE                                                                                                        
    field_values = array [1 .. * ] of clt$field_value;                                                        
                                                                                                              
  TYPE                                                                                                        
    attribute_info = record                                                                                   
      kind: ost$name,                                                                                         
      valid_attributes: oct$attribute_keyword_set,                                                            
    recend;                                                                                                   
                                                                                                              
  TYPE                                                                                                        
    text_module_kind = record                                                                                 
      case valid: boolean of                                                                                  
      = TRUE =                                                                                                
        text_kind: llt$module_kind,                                                                           
      casend,                                                                                                 
    recend;                                                                                                   
                                                                                                              
  VAR                                                                                                         
    program_attributes_group: [STATIC, READ, ocs$literals] oct$attribute_keyword_set :=                       
          [occ$kwd_name, occ$kwd_kind, occ$kwd_abort_file, occ$kwd_arithmetic_overflow,                       
          occ$kwd_arithmetic_loss_of_sig, occ$kwd_debug_input, occ$kwd_debug_mode, occ$kwd_debug_output,      
          occ$kwd_divide_fault, occ$kwd_exponent_overflow, occ$kwd_exponent_underflow, occ$kwd_fp_indefinite, 
          occ$kwd_fp_loss_of_significance, occ$kwd_invalid_bdp_data, occ$kwd_libraries, occ$kwd_load_map,     
          occ$kwd_load_map_options, occ$kwd_modules, occ$kwd_object_files, occ$kwd_preset_value,              
          occ$kwd_stack_size, occ$kwd_starting_procedure, occ$kwd_termination_error_level];                   
                                                                                                              
  VAR                                                                                                         
    header_attributes: [STATIC, READ, ocs$literals] oct$attribute_keyword_set :=                              
          [occ$kwd_name, occ$kwd_kind, occ$kwd_comment, occ$kwd_creation_date_time, occ$kwd_generator,        
          occ$kwd_generator_version];                                                                         
                                                                                                              
  VAR                                                                                                         
    command_description_attributes: [STATIC, READ, ocs$literals] attribute_info :=                            
          ['COMMAND_DESCRIPTION', [occ$kwd_name, occ$kwd_kind, occ$kwd_aliases,                               
          occ$kwd_application_identifier, occ$kwd_availability, occ$kwd_comment, occ$kwd_creation_date_time,  
          occ$kwd_generator, occ$kwd_generator_version, occ$kwd_libraries, occ$kwd_scope,                     
          occ$kwd_starting_procedure, occ$kwd_system_command_name]];                                          
                                                                                                              
  VAR                                                                                                         
    command_procedure_attributes: [STATIC, READ, ocs$literals] attribute_info :=                              
          ['COMMAND_PROCEDURE', [occ$kwd_name, occ$kwd_kind, occ$kwd_aliases, occ$kwd_application_identifier, 
          occ$kwd_availability, occ$kwd_comment, occ$kwd_creation_date_time, occ$kwd_generator,               
          occ$kwd_generator_version, occ$kwd_log_option, occ$kwd_scope]];                                     
                                                                                                              
  VAR                                                                                                         
    cpu_object_module_attributes: [STATIC, READ, ocs$literals] attribute_info :=                              
          ['CPU_MODULE', [occ$kwd_name, occ$kwd_kind, occ$kwd_application_identifier, occ$kwd_comment,        
          occ$kwd_creation_date_time, occ$kwd_entry_points, occ$kwd_generator, occ$kwd_generator_version,     
          occ$kwd_libraries, occ$kwd_references, occ$kwd_starting_procedure, occ$kwd_text_kind]];             
                                                                                                              
  VAR                                                                                                         
    form_module_attributes: [STATIC, READ, ocs$literals] attribute_info :=                                    
          ['FORM_MODULE', [occ$kwd_name, occ$kwd_kind, occ$kwd_comment, occ$kwd_creation_date_time,           
          occ$kwd_generator, occ$kwd_generator_version]];                                                     
                                                                                                              
  VAR                                                                                                         
    function_description_attributes: [STATIC, READ, ocs$literals] attribute_info :=                           
          ['FUNCTION_DESCRIPTION', [occ$kwd_name, occ$kwd_kind, occ$kwd_aliases, occ$kwd_availability,        
          occ$kwd_comment, occ$kwd_creation_date_time, occ$kwd_generator, occ$kwd_generator_version,          
          occ$kwd_libraries, occ$kwd_scope, occ$kwd_starting_procedure]];                                     
                                                                                                              
  VAR                                                                                                         
    function_procedure_attributes: [STATIC, READ, ocs$literals] attribute_info :=                             
          ['FUNCTION_PROCEDURE', [occ$kwd_name, occ$kwd_kind, occ$kwd_aliases, occ$kwd_availability,          
          occ$kwd_comment, occ$kwd_creation_date_time, occ$kwd_generator, occ$kwd_generator_version,          
          occ$kwd_scope]];                                                                                    
                                                                                                              
  VAR                                                                                                         
    load_module_attributes: [STATIC, READ, ocs$literals] attribute_info :=                                    
          ['LOAD_MODULE', [occ$kwd_name, occ$kwd_kind, occ$kwd_application_identifier, occ$kwd_comment,       
          occ$kwd_components, occ$kwd_creation_date_time, occ$kwd_entry_points, occ$kwd_generator,            
          occ$kwd_generator_version, occ$kwd_libraries, occ$kwd_references, occ$kwd_starting_procedure,       
          occ$kwd_text_kind]];                                                                                
                                                                                                              
  VAR                                                                                                         
    message_module_attributes: [STATIC, READ, ocs$literals] attribute_info :=                                 
          ['MESSAGE_MODULE', [occ$kwd_name, occ$kwd_kind, occ$kwd_comment, occ$kwd_creation_date_time,        
          occ$kwd_generator, occ$kwd_generator_version, occ$kwd_module_kind, occ$kwd_natural_language,        
          occ$kwd_online_manual, occ$kwd_status_codes]];                                                      
                                                                                                              
  VAR                                                                                                         
    ppu_object_module_attributes: [STATIC, READ, ocs$literals] attribute_info :=                              
          ['PPU_MODULE', [occ$kwd_name, occ$kwd_kind, occ$kwd_application_identifier, occ$kwd_comment,        
          occ$kwd_creation_date_time, occ$kwd_generator, occ$kwd_generator_version, occ$kwd_text_kind]];      
                                                                                                              
  VAR                                                                                                         
    program_description_attributes: [STATIC, READ, ocs$literals] attribute_info :=                            
          ['PROGRAM_DESCRIPTION', [occ$kwd_name, occ$kwd_kind, occ$kwd_aliases,                               
          occ$kwd_application_identifier, occ$kwd_availability, occ$kwd_comment, occ$kwd_creation_date_time,  
          occ$kwd_generator, occ$kwd_generator_version, occ$kwd_log_option, occ$kwd_scope, occ$kwd_abort_file,
          occ$kwd_arithmetic_overflow, occ$kwd_arithmetic_loss_of_sig, occ$kwd_debug_input,                   
          occ$kwd_debug_mode, occ$kwd_debug_output, occ$kwd_divide_fault, occ$kwd_exponent_overflow,          
          occ$kwd_exponent_underflow, occ$kwd_fp_indefinite, occ$kwd_fp_loss_of_significance,                 
          occ$kwd_invalid_bdp_data, occ$kwd_libraries, occ$kwd_load_map, occ$kwd_load_map_options,            
          occ$kwd_modules, occ$kwd_object_files, occ$kwd_preset_value, occ$kwd_stack_size,                    
          occ$kwd_starting_procedure, occ$kwd_termination_error_level]];                                      
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'build_message_module_attributes', EJECT ??                                                    
                                                                                                              
{ PURPOSE:                                                                                                    
{   Build the field values specific to message modules.                                                       
{                                                                                                             
{ GENERATED FIELDS:                                                                                           
{   module_kind: key                                                                                          
{     message_and_help_module, message_module, help_module                                                    
{   keyend                                                                                                    
{   natural_language: name                                                                                    
{   online_manual: program_name                                                                               
{   status_codes: range of status_code                                                                        
                                                                                                              
  PROCEDURE build_message_module_attributes                                                                   
    (    selected_attributes: oct$attribute_keyword_set;                                                      
         library_member_header: llt$library_member_header;                                                    
         changed_info: ^oct$changed_info;                                                                     
     VAR module_description: oct$module_description;                                                          
     VAR work_area: ^clt$work_area;                                                                           
     VAR fields: field_values;                                                                                
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      message_template_module: ^ost$message_template_module;                                                  
                                                                                                              
    VAR                                                                                                       
      strng: string (255),                                                                                    
      length: integer,                                                                                        
      natural_language: ost$natural_language,                                                                 
      keyword: ost$name,                                                                                      
      online_manual: ost$online_manual_name,                                                                  
      help_module: boolean,                                                                                   
      message_module: boolean,                                                                                
      lowest_condition_code: ost$status_condition_code,                                                       
      highest_condition_code: ost$status_condition_code,                                                      
      condition_string: ost$string;                                                                           
                                                                                                              
                                                                                                              
    IF (selected_attributes * $oct$attribute_keyword_set [occ$kwd_module_kind, occ$kwd_natural_language,      
          occ$kwd_online_manual, occ$kwd_status_codes]) = $oct$attribute_keyword_set [] THEN                  
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    message_template_module := #PTR (module_description.message_module_header^.member,                        
          module_description.file^);                                                                          
    IF message_template_module = NIL THEN                                                                     
      osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);      
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    clp$get_message_module_info (message_template_module, natural_language, online_manual, help_module,       
          message_module, lowest_condition_code, highest_condition_code, status);                             
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Module_type                                                                                                 
                                                                                                              
    IF occ$kwd_module_kind IN selected_attributes THEN                                                        
      IF message_module AND help_module THEN                                                                  
        keyword := 'MESSAGE_AND_HELP_MODULE';                                                                 
      ELSEIF message_module THEN                                                                              
        keyword := 'MESSAGE_MODULE';                                                                          
      ELSEIF help_module THEN                                                                                 
        keyword := 'HELP_MODULE';                                                                             
      ELSE                                                                                                    
        keyword := 'UNKNOWN';                                                                                 
      IFEND;                                                                                                  
      clp$make_keyword_value (keyword, work_area, fields [occ$kwd_module_kind].value);                        
    IFEND;                                                                                                    
                                                                                                              
                                                                                                              
{ Natural Language                                                                                            
                                                                                                              
    IF occ$kwd_natural_language IN selected_attributes THEN                                                   
      clp$make_name_value (natural_language, work_area, fields [occ$kwd_natural_language].value);             
    IFEND;                                                                                                    
                                                                                                              
{ Online Manual                                                                                               
                                                                                                              
    IF (occ$kwd_online_manual IN selected_attributes) AND (online_manual <> osc$null_name) THEN               
      clp$make_program_name_value (online_manual, work_area, fields [occ$kwd_online_manual].value);           
    IFEND;                                                                                                    
                                                                                                              
{ Status codes                                                                                                
                                                                                                              
    IF (occ$kwd_status_codes IN selected_attributes) AND message_module THEN                                  
      clp$make_range_value (work_area, fields [occ$kwd_status_codes].value);                                  
      clp$make_status_code_value (lowest_condition_code, work_area,                                           
            fields [occ$kwd_status_codes].value^.low_value);                                                  
      clp$make_status_code_value (highest_condition_code, work_area,                                          
            fields [occ$kwd_status_codes].value^.high_value);                                                 
    IFEND;                                                                                                    
                                                                                                              
  PROCEND build_message_module_attributes;                                                                    
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'build_program_attributes', EJECT ??                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   build the program attributes.                                                                             
{                                                                                                             
{ GENERATED FIELDS:                                                                                           
{   abort_file: any of                                                                                        
{       file                                                                                                  
{       string                                                                                                
{     anyend                                                                                                  
{   arithmetic_loss_of_significance: boolean                                                                  
{   arithmetic_overflow: boolean                                                                              
{   debug_input: any of                                                                                       
{       file                                                                                                  
{       string                                                                                                
{     anyend                                                                                                  
{   debug_mode: boolean                                                                                       
{   debug_output: any of                                                                                      
{       file                                                                                                  
{       string                                                                                                
{     anyend                                                                                                  
{   divide_fault: boolean                                                                                     
{   exponent_overflow: boolean                                                                                
{   exponent_underflow: boolean                                                                               
{   fp_indefinite: boolean                                                                                    
{   fp_loss_of_significance: boolean                                                                          
{   invalid_bdp_data: boolean                                                                                 
{   libraries: list of any of                                                                                 
{       key osf$current_library, osf$task_services_library keyend                                             
{       file                                                                                                  
{       string                                                                                                
{     anyend                                                                                                  
{   load_map_options: any of                                                                                  
{       key all, none keyend                                                                                  
{       list of key                                                                                           
{         segment, block, cross_reference, entry_point                                                        
{       keyend                                                                                                
{     anyend                                                                                                  
{   modules: list of program_name                                                                             
{   object_files: list of any of                                                                              
{       file                                                                                                  
{       string                                                                                                
{     anyend                                                                                                  
{   preset_value: key                                                                                         
{       zero, alternate_ones, floating_point_indefinite, infinity                                             
{     keyend                                                                                                  
{   stack_size: integer                                                                                       
{   starting_procedure: program_name                                                                          
{   termination_error_level: key                                                                              
{       warning, error, fatal                                                                                 
{     keyend                                                                                                  
                                                                                                              
  PROCEDURE build_program_attributes                                                                          
    (    selected_attributes: oct$attribute_keyword_set;                                                      
         library_member_header: llt$library_member_header;                                                    
         changed_info: ^oct$changed_info;                                                                     
     VAR module_description: oct$module_description;                                                          
     VAR work_area: ^clt$work_area;                                                                           
     VAR fields: field_values;                                                                                
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      conditions: ^pmt$enable_inhibit_conditions,                                                             
      i: integer,                                                                                             
      keyword: ost$name,                                                                                      
      l: integer,                                                                                             
      library_list: ^llt$object_library_list,                                                                 
      member: ^llt$program_description,                                                                       
      module_list: ^pmt$module_list,                                                                          
      object_file_list: ^llt$object_file_list,                                                                
      program_attributes: ^llt$program_attributes,                                                            
      strng: string (120),                                                                                    
      value: ^^clt$data_value;                                                                                
                                                                                                              
    VAR                                                                                                       
      condition_info: [STATIC, READ, ocs$literals] array [1 .. 8] of record                                   
        condition: pmt$system_condition,                                                                      
        field_index: integer,                                                                                 
      recend := [[pmc$arithmetic_overflow, occ$kwd_arithmetic_overflow],                                      
            [pmc$arithmetic_significance, occ$kwd_arithmetic_loss_of_sig],                                    
            [pmc$divide_fault, occ$kwd_divide_fault], [pmc$exponent_overflow, occ$kwd_exponent_overflow],     
            [pmc$exponent_underflow, occ$kwd_exponent_underflow], [pmc$fp_indefinite, occ$kwd_fp_indefinite], 
            [pmc$fp_significance_loss, occ$kwd_fp_loss_of_significance],                                      
            [pmc$invalid_bdp_data, occ$kwd_invalid_bdp_data]];                                                
                                                                                                              
    IF (selected_attributes * program_attributes_group) = $oct$attribute_keyword_set [] THEN                  
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    member := #PTR (library_member_header.member, module_description.file^);                                  
    IF member = NIL THEN                                                                                      
      osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);      
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    RESET member;                                                                                             
    NEXT program_attributes IN member;                                                                        
    IF program_attributes = NIL THEN                                                                          
      osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);      
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Object file list.                                                                                           
                                                                                                              
    IF occ$kwd_object_files IN selected_attributes THEN                                                       
      IF (pmc$object_file_list_specified IN program_attributes^.contents) AND                                 
            (program_attributes^.number_of_object_files <> 0) THEN                                            
        NEXT object_file_list: [1 .. program_attributes^.number_of_object_files] IN member;                   
        IF object_file_list = NIL THEN                                                                        
          osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);  
          RETURN;                                                                                             
        IFEND;                                                                                                
        value := ^fields [occ$kwd_object_files].value;                                                        
        FOR i := 1 TO program_attributes^.number_of_object_files DO                                           
          clp$make_list_value (work_area, value^);                                                            
          ocp$make_file_value (object_file_list^ [i], work_area, value^^.element_value);                      
          value := ^value^^.link;                                                                             
        FOREND;                                                                                               
      ELSE                                                                                                    
        clp$make_unspecified_value (work_area, fields [occ$kwd_object_files].value);                          
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Module list                                                                                                 
                                                                                                              
    IF occ$kwd_modules IN selected_attributes THEN                                                            
      IF (pmc$module_list_specified IN program_attributes^.contents) AND                                      
            (program_attributes^.number_of_modules <> 0) THEN                                                 
        NEXT module_list: [1 .. program_attributes^.number_of_modules] IN member;                             
        IF module_list = NIL THEN                                                                             
          osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);  
          RETURN;                                                                                             
        IFEND;                                                                                                
                                                                                                              
        value := ^fields [occ$kwd_modules].value;                                                             
        FOR i := 1 TO program_attributes^.number_of_modules DO                                                
          clp$make_list_value (work_area, value^);                                                            
          clp$make_program_name_value (module_list^ [i], work_area, value^^.element_value);                   
        FOREND;                                                                                               
      ELSE                                                                                                    
        clp$make_unspecified_value (work_area, fields [occ$kwd_modules].value);                               
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Library list:                                                                                               
                                                                                                              
    IF occ$kwd_libraries IN selected_attributes THEN                                                          
      IF (pmc$library_list_specified IN program_attributes^.contents) AND                                     
            (program_attributes^.number_of_libraries <> 0) THEN                                               
        NEXT library_list: [1 .. program_attributes^.number_of_libraries] IN member;                          
        IF library_list = NIL THEN                                                                            
          osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);  
          RETURN;                                                                                             
        IFEND;                                                                                                
                                                                                                              
        value := ^fields [occ$kwd_libraries].value;                                                           
        FOR i := 1 TO program_attributes^.number_of_libraries DO                                              
          clp$make_list_value (work_area, value^);                                                            
          ocp$make_file_value (library_list^ [i], work_area, value^^.element_value);                          
          value := ^value^^.link;                                                                             
        FOREND;                                                                                               
      ELSE                                                                                                    
        clp$make_list_value (work_area, fields [occ$kwd_libraries].value);                                    
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Abort File                                                                                                  
                                                                                                              
    IF occ$kwd_abort_file IN selected_attributes THEN                                                         
      IF pmc$abort_file_specified IN program_attributes^.contents THEN                                        
        ocp$make_file_value (program_attributes^.abort_file, work_area, fields [occ$kwd_abort_file].value);   
      ELSE                                                                                                    
        clp$make_unspecified_value (work_area, fields [occ$kwd_abort_file].value);                            
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Conditions:                                                                                                 
                                                                                                              
    IF (pmc$condition_specified IN program_attributes^.contents) THEN                                         
      NEXT conditions IN member;                                                                              
      IF conditions = NIL THEN                                                                                
        osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);    
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      FOR i := 1 TO UPPERBOUND (condition_info) DO                                                            
        IF condition_info [i].field_index IN selected_attributes THEN                                         
          value := ^fields [condition_info [i].field_index].value;                                            
          IF condition_info [i].condition IN conditions^.enable_system_conditions THEN                        
            clp$make_boolean_value (TRUE, clc$on_off_boolean, work_area, value^);                             
          ELSEIF condition_info [i].condition IN conditions^.inhibit_system_conditions THEN                   
            clp$make_boolean_value (FALSE, clc$on_off_boolean, work_area, value^);                            
          ELSE                                                                                                
            clp$make_unspecified_value (work_area, value^);                                                   
          IFEND;                                                                                              
        IFEND;                                                                                                
      FOREND;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
                                                                                                              
{ Debug Input                                                                                                 
                                                                                                              
    IF occ$kwd_debug_input IN selected_attributes THEN                                                        
      IF pmc$debug_input_specified IN program_attributes^.contents THEN                                       
        ocp$make_file_value (program_attributes^.debug_input, work_area, fields [occ$kwd_debug_input].value); 
      ELSE                                                                                                    
        clp$make_unspecified_value (work_area, fields [occ$kwd_debug_input].value);                           
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Debug Mode                                                                                                  
                                                                                                              
    IF occ$kwd_debug_mode IN selected_attributes THEN                                                         
      IF pmc$debug_mode_specified IN program_attributes^.contents THEN                                        
        clp$make_boolean_value (program_attributes^.debug_mode, clc$on_off_boolean, work_area,                
              fields [occ$kwd_debug_mode].value);                                                             
      ELSE                                                                                                    
        clp$make_unspecified_value (work_area, fields [occ$kwd_debug_mode].value);                            
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Debug Output                                                                                                
                                                                                                              
    IF occ$kwd_debug_output IN selected_attributes THEN                                                       
      IF pmc$debug_output_specified IN program_attributes^.contents THEN                                      
        ocp$make_file_value (program_attributes^.debug_output, work_area, fields [occ$kwd_debug_output].      
              value);                                                                                         
      ELSE                                                                                                    
        clp$make_unspecified_value (work_area, fields [occ$kwd_debug_output].value);                          
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Load map file.                                                                                              
                                                                                                              
    IF occ$kwd_load_map IN selected_attributes THEN                                                           
      IF pmc$load_map_file_specified IN program_attributes^.contents THEN                                     
        ocp$make_file_value (program_attributes^.load_map_file, work_area, fields [occ$kwd_load_map].value);  
      ELSE                                                                                                    
        clp$make_unspecified_value (work_area, fields [occ$kwd_load_map].value);                              
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Load map options                                                                                            
                                                                                                              
    IF occ$kwd_load_map_options IN selected_attributes THEN                                                   
      IF pmc$load_map_options_specified IN program_attributes^.contents THEN                                  
        value := ^fields [occ$kwd_load_map_options].value;                                                    
        IF pmc$no_load_map IN program_attributes^.load_map_options THEN                                       
          clp$make_keyword_value ('NONE', work_area, value^);                                                 
        IFEND;                                                                                                
        IF pmc$segment_map IN program_attributes^.load_map_options THEN                                       
          clp$make_list_value (work_area, value^);                                                            
          clp$make_keyword_value ('SEGMENT', work_area, value^^.element_value);                               
          value := ^value^^.link;                                                                             
        IFEND;                                                                                                
        IF pmc$block_map IN program_attributes^.load_map_options THEN                                         
          clp$make_list_value (work_area, value^);                                                            
          clp$make_keyword_value ('BLOCK', work_area, value^^.element_value);                                 
          value := ^value^^.link;                                                                             
        IFEND;                                                                                                
        IF pmc$entry_point_map IN program_attributes^.load_map_options THEN                                   
          clp$make_list_value (work_area, value^);                                                            
          clp$make_keyword_value ('ENTRY_POINT', work_area, value^^.element_value);                           
          value := ^value^^.link;                                                                             
        IFEND;                                                                                                
        IF pmc$entry_point_xref IN program_attributes^.load_map_options THEN                                  
          clp$make_list_value (work_area, value^);                                                            
          clp$make_keyword_value ('XREF', work_area, value^^.element_value);                                  
          value := ^value^^.link;                                                                             
        IFEND;                                                                                                
      ELSE                                                                                                    
        clp$make_unspecified_value (work_area, fields [occ$kwd_load_map_options].value);                      
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Preset value                                                                                                
                                                                                                              
    IF occ$kwd_preset_value IN selected_attributes THEN                                                       
      IF pmc$preset_specified IN program_attributes^.contents THEN                                            
        CASE program_attributes^.preset OF                                                                    
        = pmc$initialize_to_zero =                                                                            
          keyword := 'ZERO';                                                                                  
        = pmc$initialize_to_alt_ones =                                                                        
          keyword := 'ALTERNATE_ONES';                                                                        
        = pmc$initialize_to_indefinite =                                                                      
          keyword := 'FLOATING_POINT_INDEFINITE';                                                             
        = pmc$initialize_to_infinity =                                                                        
          keyword := 'INFINITY';                                                                              
        ELSE                                                                                                  
          keyword := 'UNKNOWN';                                                                               
        CASEND;                                                                                               
        clp$make_keyword_value (keyword, work_area, fields [occ$kwd_preset_value].value);                     
      ELSE                                                                                                    
        clp$make_unspecified_value (work_area, fields [occ$kwd_preset_value].value);                          
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Stack_size                                                                                                  
                                                                                                              
    IF occ$kwd_stack_size IN selected_attributes THEN                                                         
      IF pmc$max_stack_size_specified IN program_attributes^.contents THEN                                    
        clp$make_integer_value (program_attributes^.maximum_stack_size, 10, FALSE, work_area,                 
              fields [occ$kwd_stack_size].value);                                                             
      ELSE                                                                                                    
        clp$make_unspecified_value (work_area, fields [occ$kwd_stack_size].value);                            
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Starting procedure                                                                                          
                                                                                                              
    IF occ$kwd_starting_procedure IN selected_attributes THEN                                                 
      IF pmc$starting_proc_specified IN program_attributes^.contents THEN                                     
        clp$make_program_name_value (program_attributes^.starting_procedure, work_area,                       
              fields [occ$kwd_starting_procedure].value);                                                     
      ELSE                                                                                                    
        clp$make_unspecified_value (work_area, fields [occ$kwd_starting_procedure].value);                    
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Termination Error Level                                                                                     
                                                                                                              
    IF occ$kwd_termination_error_level IN selected_attributes THEN                                            
      IF pmc$term_error_level_specified IN program_attributes^.contents THEN                                  
        CASE program_attributes^.termination_error_level OF                                                   
        = pmc$warning_load_errors =                                                                           
          keyword := 'WARNING';                                                                               
        = pmc$error_load_errors =                                                                             
          keyword := 'ERROR';                                                                                 
        = pmc$fatal_load_errors =                                                                             
          keyword := 'FATAL';                                                                                 
        ELSE                                                                                                  
          keyword := 'UNKNOWN';                                                                               
        CASEND;                                                                                               
        clp$make_keyword_value (keyword, work_area, fields [occ$kwd_termination_error_level].value);          
      ELSE                                                                                                    
        clp$make_unspecified_value (work_area, fields [occ$kwd_termination_error_level].value);               
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
  PROCEND build_program_attributes;                                                                           
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'build_standard_header', EJECT ??                                                              
                                                                                                              
{ PURPOSE:                                                                                                    
{   Build a header of type llt$library_member_header for the module.                                          
                                                                                                              
  PROCEDURE build_standard_header                                                                             
    (    changed_info: ^oct$changed_info;                                                                     
     VAR module_description: oct$module_description;                                                          
     VAR module_kind: text_module_kind;                                                                       
     VAR application_identifier: ost$name;                                                                    
     VAR header: llt$library_member_header;                                                                   
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      ignore: boolean,                                                                                        
      module_header: oct$header;                                                                              
                                                                                                              
                                                                                                              
    module_header.application_member_header.application_identifier.name := '';                                
                                                                                                              
    ocp$obtain_header (module_description, changed_info, module_header, status);                              
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    CASE module_description.kind OF                                                                           
    = occ$cpu_object_module, occ$ppu_object_module, occ$load_module, occ$bound_module =                       
      header.name := module_header.identification.name;                                                       
      header.time_created := module_header.identification.time_created;                                       
      header.date_created := module_header.identification.date_created;                                       
      header.generator_id := module_header.identification.generator_id;                                       
      header.generator_name_vers := module_header.identification.generator_name_vers;                         
      header.commentary := module_header.identification.commentary;                                           
      application_identifier := module_header.application_identifier.name;                                    
      module_kind.valid := TRUE;                                                                              
      module_kind.text_kind := module_header.identification.kind;                                             
    ELSE                                                                                                      
      header := module_header.library_member_header;                                                          
      application_identifier := module_header.application_member_header.application_identifier.name;          
      module_kind.valid := FALSE;                                                                             
    CASEND;                                                                                                   
                                                                                                              
  PROCEND build_standard_header;                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'make_alias_list', EJECT ??                                                                    
                                                                                                              
{ PURPOSE:                                                                                                    
{   Build list of aliases.                                                                                    
                                                                                                              
{ GENERATED VALUE:                                                                                            
{     aliases: list of program_name                                                                           
                                                                                                              
  PROCEDURE make_alias_list                                                                                   
    (    changed_info: ^oct$changed_info;                                                                     
     VAR module_description: oct$module_description;                                                          
     VAR work_area: ^clt$work_area;                                                                           
     VAR field: clt$field_value;                                                                              
     VAR status: ost$status);                                                                                 
                                                                                                              
                                                                                                              
    VAR                                                                                                       
      aliases: oct$external_declaration_list,                                                                 
      ignore: oct$external_declaration_list,                                                                  
      next_alias: ^oct$external_declaration_list,                                                             
      starting_procedure: pmt$program_name,                                                                   
      value: ^^clt$data_value;                                                                                
                                                                                                              
                                                                                                              
    ocp$obtain_xdcl_list (changed_info, occ$no_retain, {obtain_deferred_entry_points=} FALSE,                 
          module_description, aliases, starting_procedure, ignore, status);                                   
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    next_alias := aliases.link;                                                                               
                                                                                                              
    IF next_alias <> NIL THEN                                                                                 
      value := ^field.value;                                                                                  
                                                                                                              
      REPEAT                                                                                                  
        IF next_alias^.name <> osc$null_name THEN                                                             
          clp$make_list_value (work_area, value^);                                                            
          clp$make_program_name_value (next_alias^.name, work_area, value^^.element_value);                   
          value := ^value^^.link;                                                                             
        IFEND;                                                                                                
        next_alias := next_alias^.link;                                                                       
      UNTIL next_alias = NIL;                                                                                 
                                                                                                              
    ELSE                                                                                                      
      clp$make_list_value (work_area, field.value);                                                           
    IFEND;                                                                                                    
                                                                                                              
                                                                                                              
  PROCEND make_alias_list;                                                                                    
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'make_command_attributes', EJECT ??                                                            
                                                                                                              
{ PURPOSE:                                                                                                    
{   Build fields specific to command_descriptions and function_descriptions.                                  
{                                                                                                             
{ GENERATED FIELDS:                                                                                           
{   libraries: list of file                                                                                   
{   starting_procedure: program_name                                                                          
{   system_command_name: name                                                                                 
                                                                                                              
  PROCEDURE make_command_attributes                                                                           
    (    selected_attributes: oct$attribute_keyword_set;                                                      
         changed_info: ^oct$changed_info;                                                                     
         library_member_header: llt$library_member_header;                                                    
     VAR module_description: oct$module_description;                                                          
     VAR work_area: ^clt$work_area;                                                                           
     VAR fields: field_values;                                                                                
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      aliases: ^pmt$module_list,                                                                              
      command_attributes: ^llt$command_desc_contents,                                                         
      deferred_xdcl_list: oct$external_declaration_list,                                                      
      library_path: ^fst$file_reference,                                                                      
      member: ^llt$command_description,                                                                       
      starting_procedure: pmt$program_name,                                                                   
      xdcl_list: oct$external_declaration_list;                                                               
                                                                                                              
                                                                                                              
    member := #PTR (library_member_header.member, module_description.file^);                                  
    IF member = NIL THEN                                                                                      
      osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);      
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    RESET member;                                                                                             
    NEXT command_attributes IN member;                                                                        
    IF command_attributes = NIL THEN                                                                          
      osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);      
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF command_attributes^.system_command THEN                                                                
                                                                                                              
{ System command name                                                                                         
                                                                                                              
      IF occ$kwd_system_command_name IN selected_attributes THEN                                              
        clp$make_name_value (command_attributes^.system_command_name, work_area,                              
              fields [occ$kwd_system_command_name].value);                                                    
      IFEND;                                                                                                  
                                                                                                              
    ELSE                                                                                                      
                                                                                                              
{ Library Path                                                                                                
                                                                                                              
      IF occ$kwd_libraries IN selected_attributes THEN                                                        
        IF command_attributes^.library_path_size > 0 THEN                                                     
          NEXT library_path: [command_attributes^.library_path_size] IN member;                               
          IF library_path = NIL THEN                                                                          
            osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);
            RETURN;                                                                                           
          IFEND;                                                                                              
                                                                                                              
          clp$make_list_value (work_area, fields [occ$kwd_libraries].value);                                  
          ocp$make_file_value (library_path^, work_area, fields [occ$kwd_libraries].value^.element_value);    
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
{ Starting procedure                                                                                          
                                                                                                              
      IF occ$kwd_starting_procedure IN selected_attributes THEN                                               
                                                                                                              
        IF command_attributes^.starting_procedure <> osc$null_name THEN                                       
          clp$make_program_name_value (command_attributes^.starting_procedure, work_area,                     
                fields [occ$kwd_starting_procedure].value);                                                   
        IFEND;                                                                                                
      IFEND;                                                                                                  
                                                                                                              
    IFEND;                                                                                                    
                                                                                                              
  PROCEND make_command_attributes;                                                                            
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'make_component_list', EJECT ??                                                                
                                                                                                              
{ PURPOSE:                                                                                                    
{   Build a list of record of component information.                                                          
{                                                                                                             
{ GENERATED VALUE:                                                                                            
{   components: list of record                                                                                
{     name: name                                                                                              
{     creation_date_time: date_time                                                                           
{     generator: keyword                                                                                      
{     generator_version: string                                                                               
{     comment: string                                                                                         
{   recend                                                                                                    
                                                                                                              
  PROCEDURE make_component_list                                                                               
    (    component: ^llt$component_information;                                                               
     VAR work_area: ^clt$work_area;                                                                           
     VAR field: clt$field_value);                                                                             
                                                                                                              
    CONST                                                                                                     
      p$name = 1,                                                                                             
      p$creation_date_time = 2,                                                                               
      p$generator = 3,                                                                                        
      p$generator_version = 4,                                                                                
      p$comment = 5;                                                                                          
                                                                                                              
                                                                                                              
    VAR                                                                                                       
      fields: ^field_values,                                                                                  
      ignore: boolean,                                                                                        
      i: integer,                                                                                             
      value: ^^clt$data_value;                                                                                
                                                                                                              
                                                                                                              
    IF component = NIL THEN                                                                                   
      clp$make_list_value (work_area, field.value);                                                           
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    value := ^field.value;                                                                                    
                                                                                                              
    FOR i := 1 TO UPPERBOUND (component^) DO                                                                  
                                                                                                              
      clp$make_list_value (work_area, value^);                                                                
      clp$make_record_value (5, work_area, value^^.element_value);                                            
      fields := value^^.element_value^.field_values;                                                          
      value := ^value^^.link;                                                                                 
                                                                                                              
{component:                                                                                                   
                                                                                                              
      fields^ [p$name].name := 'NAME';                                                                        
      clp$make_program_name_value (component^ [i].name, work_area, fields^ [p$name].value);                   
                                                                                                              
{ Created:                                                                                                    
                                                                                                              
      fields^ [p$creation_date_time].name := 'CREATION_DATE_TIME';                                            
      ocp$make_date_time_value (component^ [i].date_created, component^ [i].                                  
            time_created, work_area, fields^ [p$creation_date_time].value);                                   
                                                                                                              
{ Generator:                                                                                                  
                                                                                                              
      fields^ [p$generator].name := 'GENERATOR';                                                              
      ocp$make_module_generator_value (component^ [i].generator_id, work_area, fields^ [p$generator].value);  
                                                                                                              
{ Generator name version                                                                                      
                                                                                                              
      fields^ [p$generator_version].name := 'GENERATOR_VERSION';                                              
      clp$make_string_value (component^ [i].generator_name_vers                                               
            (1, clp$trimmed_string_size (component^ [i].generator_name_vers)),                                
            work_area, fields^ [p$generator_version].value);                                                  
                                                                                                              
{ Comment                                                                                                     
                                                                                                              
      fields^ [p$comment].name := 'COMMENT';                                                                  
      clp$make_string_value (component^ [i].commentary (1, clp$trimmed_string_size (component^ [i].           
            commentary)), work_area, fields^ [p$comment].value);                                              
    FOREND;                                                                                                   
                                                                                                              
  PROCEND make_component_list;                                                                                
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'make_entry_points_list', EJECT ??                                                             
                                                                                                              
{ PURPOSE:                                                                                                    
{   Build a list of entry_points.                                                                             
{                                                                                                             
{ GENERATED VALUE:                                                                                            
{   entry_points: list of record                                                                              
{     name: program_name                                                                                      
{     deferred: boolean                                                                                       
{     gated: boolean                                                                                          
{     retained: boolean                                                                                       
{   recend                                                                                                    
                                                                                                              
  PROCEDURE make_entry_points_list                                                                            
    (    xdcl_list: oct$external_declaration_list;                                                            
         deferred_xdcl_list: oct$external_declaration_list;                                                   
     VAR work_area: ^clt$work_area;                                                                           
     VAR field: clt$field_value);                                                                             
                                                                                                              
                                                                                                              
    CONST                                                                                                     
      p$name = 1,                                                                                             
      p$deferred = 2,                                                                                         
      p$gated = 3,                                                                                            
      p$retained = 4;                                                                                         
                                                                                                              
    VAR                                                                                                       
      entry: ^clt$data_value,                                                                                 
      entry_kind: (normal, deferred),                                                                         
      value: ^^clt$data_value,                                                                                
      x_dcl: ^oct$external_declaration_list;                                                                  
                                                                                                              
                                                                                                              
    value := ^field.value;                                                                                    
                                                                                                              
    FOR entry_kind := normal TO deferred DO                                                                   
                                                                                                              
      IF entry_kind = normal THEN                                                                             
        x_dcl := xdcl_list.link;                                                                              
      ELSE                                                                                                    
        x_dcl := deferred_xdcl_list.link;                                                                     
      IFEND;                                                                                                  
                                                                                                              
      WHILE x_dcl <> NIL DO                                                                                   
        IF x_dcl^.name <> osc$null_name THEN                                                                  
          clp$make_list_value (work_area, value^);                                                            
          clp$make_record_value (4, work_area, entry);                                                        
          value^^.element_value := entry;                                                                     
                                                                                                              
          entry^.field_values^ [p$name].name := 'NAME';                                                       
          clp$make_program_name_value (x_dcl^.name, work_area, entry^.field_values^ [p$name].value);          
                                                                                                              
          entry^.field_values^ [p$deferred].name := 'DEFERRED';                                               
          clp$make_boolean_value ((entry_kind = deferred), clc$true_false_boolean, work_area,                 
                entry^.field_values^ [p$deferred].value);                                                     
                                                                                                              
          entry^.field_values^ [p$gated].name := 'GATED';                                                     
          clp$make_boolean_value ((llc$gated_entry_point IN x_dcl^.attributes), clc$true_false_boolean,       
                work_area, entry^.field_values^ [p$gated].value);                                             
                                                                                                              
          entry^.field_values^ [p$retained].name := 'RETAINED';                                               
          clp$make_boolean_value ((llc$retain_entry_point IN x_dcl^.attributes), clc$true_false_boolean,      
                work_area, entry^.field_values^ [p$retained].value);                                          
          value := ^value^^.link;                                                                             
        IFEND;                                                                                                
        x_dcl := x_dcl^.link;                                                                                 
      WHILEND;                                                                                                
    FOREND;                                                                                                   
    value^ := NIL;                                                                                            
                                                                                                              
    IF field.value = NIL THEN                                                                                 
      clp$make_list_value (work_area, field.value);                                                           
    IFEND;                                                                                                    
                                                                                                              
                                                                                                              
  PROCEND make_entry_points_list;                                                                             
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'make_executable_attributes', EJECT ??                                                         
                                                                                                              
{ PURPOSE:                                                                                                    
{   Make the attributes of executable modules.                                                                
{                                                                                                             
{ GENERATED FIELDS:                                                                                           
{   components: list of component records                                                                     
{   entry_points: list of entry point records                                                                 
{   references: list of program_name                                                                          
                                                                                                              
  PROCEDURE make_executable_attributes                                                                        
    (    selected_attributes: oct$attribute_keyword_set;                                                      
         changed_info: ^oct$changed_info;                                                                     
     VAR module_description: oct$module_description;                                                          
     VAR work_area: ^clt$work_area;                                                                           
     VAR fields: field_values;                                                                                
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      alias_list: oct$external_declaration_list,                                                              
      component_info: ^llt$component_information,                                                             
      deferred_xdcl_list: oct$external_declaration_list,                                                      
      starting_procedure: pmt$program_name,                                                                   
      xdcl_list: oct$external_declaration_list,                                                               
      xref_list: oct$external_reference_list;                                                                 
                                                                                                              
                                                                                                              
{ Components.                                                                                                 
                                                                                                              
    IF occ$kwd_components IN selected_attributes THEN                                                         
      ocp$obtain_component_info (module_description, component_info, status);                                 
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      make_component_list (component_info, work_area, fields [occ$kwd_components]);                           
    IFEND;                                                                                                    
                                                                                                              
{ Entry points.                                                                                               
                                                                                                              
    IF occ$kwd_entry_points IN selected_attributes THEN                                                       
      ocp$obtain_xdcl_list (changed_info, occ$no_retain, {obtain_deferred_entry_points=} TRUE,                
            module_description, xdcl_list, starting_procedure, deferred_xdcl_list, status);                   
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      make_entry_points_list (xdcl_list, deferred_xdcl_list, work_area, fields [occ$kwd_entry_points]);       
    IFEND;                                                                                                    
                                                                                                              
{ References.                                                                                                 
                                                                                                              
    IF occ$kwd_references IN selected_attributes THEN                                                         
      ocp$obtain_xref_list (module_description, xref_list, occ$no_retain, status);                            
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      make_references_list (xref_list, work_area, fields [occ$kwd_references]);                               
    IFEND;                                                                                                    
                                                                                                              
                                                                                                              
  PROCEND make_executable_attributes;                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'make_function_attributes', EJECT ??                                                           
                                                                                                              
{ PURPOSE:                                                                                                    
{   Build fields specific to command_descriptions and function_descriptions.                                  
{                                                                                                             
{ GENERATED FIELDS:                                                                                           
{   libraries: list of file                                                                                   
{   starting_procedure: program_name                                                                          
{   system_command_name: name                                                                                 
                                                                                                              
  PROCEDURE make_function_attributes                                                                          
    (    selected_attributes: oct$attribute_keyword_set;                                                      
         changed_info: ^oct$changed_info;                                                                     
         library_member_header: llt$library_member_header;                                                    
     VAR module_description: oct$module_description;                                                          
     VAR work_area: ^clt$work_area;                                                                           
     VAR fields: field_values;                                                                                
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      aliases: ^pmt$module_list,                                                                              
      function_attributes: ^llt$function_desc_contents,                                                       
      deferred_xdcl_list: oct$external_declaration_list,                                                      
      library_path: ^fst$file_reference,                                                                      
      member: ^llt$command_description,                                                                       
      starting_procedure: pmt$program_name,                                                                   
      xdcl_list: oct$external_declaration_list;                                                               
                                                                                                              
                                                                                                              
    member := #PTR (library_member_header.member, module_description.file^);                                  
    IF member = NIL THEN                                                                                      
      osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);      
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    RESET member;                                                                                             
    NEXT function_attributes IN member;                                                                       
    IF function_attributes = NIL THEN                                                                         
      osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);      
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
                                                                                                              
{ Library Path                                                                                                
                                                                                                              
    IF occ$kwd_libraries IN selected_attributes THEN                                                          
      IF function_attributes^.library_path_size > 0 THEN                                                      
        NEXT library_path: [function_attributes^.library_path_size] IN member;                                
        IF library_path = NIL THEN                                                                            
          osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);  
          RETURN;                                                                                             
        IFEND;                                                                                                
                                                                                                              
        clp$make_list_value (work_area, fields [occ$kwd_libraries].value);                                    
        ocp$make_file_value (library_path^, work_area, fields [occ$kwd_libraries].value^.element_value);      
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Starting procedure                                                                                          
                                                                                                              
    IF occ$kwd_starting_procedure IN selected_attributes THEN                                                 
                                                                                                              
      IF function_attributes^.starting_procedure <> osc$null_name THEN                                        
        clp$make_program_name_value (function_attributes^.starting_procedure, work_area,                      
              fields [occ$kwd_starting_procedure].value);                                                     
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
  PROCEND make_function_attributes;                                                                           
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'make_header_fields', EJECT ??                                                                 
                                                                                                              
{ PURPOSE:                                                                                                    
{   Make the header fields.                                                                                   
{                                                                                                             
{ GENERATED FIELDS:                                                                                           
{   name: program_name                                                                                        
{   application_identifier: name                                                                              
{   availability: key                                                                                         
{     normal_usage, advanced_usage, hidden                                                                    
{   keyend                                                                                                    
{   comment: string                                                                                           
{   creation_date_time: date_time                                                                             
{   generator: module generator keyword                                                                       
{   generator_version: string                                                                                 
{   log_option: key                                                                                           
{     automatic, manual                                                                                       
{   keyend                                                                                                    
{   scope: key                                                                                                
{     xdcl, gate, local                                                                                       
{   keyend                                                                                                    
{   text_kind: key                                                                                            
{     mi_virtual_state, vector_virtual_state,                                                                 
{     motorola_68000, motorola_68000_absolute,                                                                
{     p_code, iou                                                                                             
{   keyend                                                                                                    
                                                                                                              
  PROCEDURE make_header_fields                                                                                
    (    selected_attributes: oct$attribute_keyword_set;                                                      
         application_identifier: ost$name;                                                                    
         header: llt$library_member_header;                                                                   
         module_kind: text_module_kind;                                                                       
     VAR work_area: ^clt$work_area;                                                                           
     VAR fields: field_values;                                                                                
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      keyword: ost$name;                                                                                      
                                                                                                              
                                                                                                              
{ Name                                                                                                        
                                                                                                              
    IF occ$kwd_name IN selected_attributes THEN                                                               
      clp$make_program_name_value (header.name, work_area, fields [occ$kwd_name].value);                      
    IFEND;                                                                                                    
                                                                                                              
{ Application identifier                                                                                      
                                                                                                              
    IF occ$kwd_application_identifier IN selected_attributes THEN                                             
      IF application_identifier <> osc$null_name THEN                                                         
        clp$make_name_value (application_identifier, work_area, fields [occ$kwd_application_identifier].      
              value);                                                                                         
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
{ Availability                                                                                                
                                                                                                              
    IF occ$kwd_availability IN selected_attributes THEN                                                       
      CASE header.command_function_availability OF                                                            
      = clc$normal_usage_entry =                                                                              
        keyword := 'NORMAL_USAGE';                                                                            
      = clc$advanced_usage_entry =                                                                            
        keyword := 'ADVANCED_USAGE';                                                                          
      = clc$hidden_entry =                                                                                    
        keyword := 'HIDDEN';                                                                                  
      ELSE                                                                                                    
        keyword := 'UNKNOWN';                                                                                 
      CASEND;                                                                                                 
      clp$make_keyword_value (keyword, work_area, fields [occ$kwd_availability].value);                       
    IFEND;                                                                                                    
                                                                                                              
{ Comment                                                                                                     
                                                                                                              
    IF occ$kwd_comment IN selected_attributes THEN                                                            
      clp$make_string_value (header.commentary (1, clp$trimmed_string_size (header.commentary)),              
            work_area, fields [occ$kwd_comment].value);                                                       
    IFEND;                                                                                                    
                                                                                                              
{ Creation date time                                                                                          
                                                                                                              
    IF occ$kwd_creation_date_time IN selected_attributes THEN                                                 
      ocp$make_date_time_value (header.date_created, header.time_created, work_area,                          
            fields [occ$kwd_creation_date_time].value);                                                       
    IFEND;                                                                                                    
                                                                                                              
{ Library Generator                                                                                           
                                                                                                              
    IF occ$kwd_generator IN selected_attributes THEN                                                          
      ocp$make_module_generator_value (header.generator_id, work_area, fields [occ$kwd_generator].value);     
    IFEND;                                                                                                    
                                                                                                              
{ Library Generator version                                                                                   
                                                                                                              
    IF occ$kwd_generator_version IN selected_attributes THEN                                                  
      clp$make_string_value (header.generator_name_vers (1,                                                   
            clp$trimmed_string_size (header.generator_name_vers)),                                            
            work_area, fields [occ$kwd_generator_version].value);                                             
    IFEND;                                                                                                    
                                                                                                              
{ Log Option                                                                                                  
                                                                                                              
    IF occ$kwd_log_option IN selected_attributes THEN                                                         
      CASE header.command_log_option OF                                                                       
      = clc$automatically_log =                                                                               
        keyword := 'AUTOMATIC';                                                                               
      = clc$manually_log =                                                                                    
        keyword := 'MANUAL';                                                                                  
      ELSE                                                                                                    
        keyword := 'UNKNOWN';                                                                                 
      CASEND;                                                                                                 
      clp$make_keyword_value (keyword, work_area, fields [occ$kwd_log_option].value);                         
    IFEND;                                                                                                    
                                                                                                              
{ Scope                                                                                                       
                                                                                                              
    IF occ$kwd_scope IN selected_attributes THEN                                                              
      CASE header.command_function_kind OF                                                                    
      = llc$entry_point =                                                                                     
        keyword := 'XDCL';                                                                                    
      = llc$gate =                                                                                            
        keyword := 'GATE';                                                                                    
      = llc$local_to_library =                                                                                
        keyword := 'LOCAL';                                                                                   
      ELSE                                                                                                    
        keyword := 'UNKNOWN';                                                                                 
      CASEND;                                                                                                 
      clp$make_keyword_value (keyword, work_area, fields [occ$kwd_scope].value);                              
    IFEND;                                                                                                    
                                                                                                              
{ Text kind                                                                                                   
                                                                                                              
    IF (occ$kwd_text_kind IN selected_attributes) AND module_kind.valid THEN                                  
      ocp$make_module_kind_value (module_kind.text_kind, work_area, fields [occ$kwd_text_kind].value);        
    IFEND;                                                                                                    
                                                                                                              
  PROCEND make_header_fields;                                                                                 
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'make_library_list', EJECT ??                                                                  
                                                                                                              
{ PURPOSE:                                                                                                    
{   Build a list of librarys.                                                                                 
{                                                                                                             
{ GENERATED VALUE                                                                                             
{   libraries: list of file                                                                                   
                                                                                                              
  PROCEDURE make_library_list                                                                                 
    (    library_list: oct$name_list;                                                                         
     VAR work_area: ^clt$work_area;                                                                           
     VAR field: clt$field_value);                                                                             
                                                                                                              
                                                                                                              
    VAR                                                                                                       
      value: ^^clt$data_value,                                                                                
      library: ^oct$name_list;                                                                                
                                                                                                              
                                                                                                              
    field.name := 'LIBRARIES';                                                                                
    library := library_list.link;                                                                             
                                                                                                              
    value := ^field.value;                                                                                    
    IF library <> NIL THEN                                                                                    
                                                                                                              
      REPEAT                                                                                                  
        clp$make_list_value (work_area, value^);                                                              
        clp$make_name_value (library^.name, work_area, value^^.element_value);                                
        library := library^.link;                                                                             
        value := ^value^^.link;                                                                               
      UNTIL library = NIL;                                                                                    
                                                                                                              
    ELSE                                                                                                      
      clp$make_list_value (work_area, field.value);                                                           
    IFEND;                                                                                                    
                                                                                                              
                                                                                                              
  PROCEND make_library_list;                                                                                  
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'make_other_exec_attributes', EJECT ??                                                         
                                                                                                              
{ PURPOSE:                                                                                                    
{   Make those fields common to most executable modules.                                                      
{                                                                                                             
{ GENERATED FIELDS:                                                                                           
{   libraries: list of name                                                                                   
{   starting_procedure: program_name                                                                          
                                                                                                              
  PROCEDURE make_other_exec_attributes                                                                        
    (    selected_attributes: oct$attribute_keyword_set;                                                      
         changed_info: ^oct$changed_info;                                                                     
     VAR module_description: oct$module_description;                                                          
     VAR work_area: ^clt$work_area;                                                                           
     VAR fields: field_values;                                                                                
     VAR status: ost$status);                                                                                 
                                                                                                              
    VAR                                                                                                       
      deferred_xdcl_list: oct$external_declaration_list,                                                      
      library_list: oct$name_list,                                                                            
      starting_procedure: pmt$program_name,                                                                   
      xdcl_list: oct$external_declaration_list;                                                               
                                                                                                              
{ Libraries                                                                                                   
                                                                                                              
    IF occ$kwd_libraries IN selected_attributes THEN                                                          
      ocp$obtain_library_list (module_description, changed_info, library_list, occ$no_retain, status);        
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      make_library_list (library_list, work_area, fields [occ$kwd_libraries]);                                
    IFEND;                                                                                                    
                                                                                                              
{ Starting procedure                                                                                          
                                                                                                              
    IF occ$kwd_starting_procedure IN selected_attributes THEN                                                 
      ocp$obtain_xdcl_list (changed_info, occ$no_retain, {obtain_deferred_entry_points=} FALSE,               
            module_description, xdcl_list, starting_procedure, deferred_xdcl_list, status);                   
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
                                                                                                              
      IF starting_procedure <> osc$null_name THEN                                                             
        clp$make_program_name_value (starting_procedure, work_area, fields [occ$kwd_starting_procedure].      
              value);                                                                                         
      IFEND;                                                                                                  
    IFEND;                                                                                                    
  PROCEND make_other_exec_attributes;                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := 'make_references_list', EJECT ??                                                               
                                                                                                              
{ PURPOSE:                                                                                                    
{   Build a list of xrefs.                                                                                    
{                                                                                                             
{ GENERATED VALUE:                                                                                            
{   references: list of program_name                                                                          
                                                                                                              
  PROCEDURE make_references_list                                                                              
    (    xref_list: oct$external_reference_list;                                                              
     VAR work_area: ^clt$work_area;                                                                           
     VAR field: clt$field_value);                                                                             
                                                                                                              
                                                                                                              
    VAR                                                                                                       
      value: ^^clt$data_value,                                                                                
      x_ref: ^oct$external_reference_list;                                                                    
                                                                                                              
    x_ref := xref_list.link;                                                                                  
                                                                                                              
    IF x_ref <> NIL THEN                                                                                      
      value := ^field.value;                                                                                  
                                                                                                              
      REPEAT                                                                                                  
        clp$make_list_value (work_area, value^);                                                              
        clp$make_program_name_value (x_ref^.name, work_area, value^^.element_value);                          
        value := ^value^^.link;                                                                               
        x_ref := x_ref^.link;                                                                                 
      UNTIL x_ref = NIL;                                                                                      
                                                                                                              
    ELSE                                                                                                      
      clp$make_list_value (work_area, field.value);                                                           
    IFEND;                                                                                                    
                                                                                                              
                                                                                                              
  PROCEND make_references_list;                                                                               
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] ocp$build_module_attributes', EJECT ??                                                 
                                                                                                              
{ PURPOSE:                                                                                                    
{   Return the command language value for the specified module.                                               
{                                                                                                             
{ GENERATED VALUE:                                                                                            
{   If only one attribute is requested then a that value is returned othewise                                 
{   the attributes are grouped in a record.                                                                   
{                                                                                                             
{   record                                                                                                    
{     fields selected on function call                                                                        
{   recend                                                                                                    
                                                                                                              
  PROCEDURE [XDCL] ocp$build_module_attributes                                                                
    (    attribute_keywords: oct$attribute_keyword_set;                                                       
     VAR module_description: {READ} oct$module_description;                                                   
         changed_info: ^oct$changed_info;                                                                     
     VAR work_area: ^clt$work_area;                                                                           
     VAR result: ^clt$data_value;                                                                             
     VAR status: ost$status);                                                                                 
                                                                                                              
                                                                                                              
    VAR                                                                                                       
      application_identifier: ost$name,                                                                       
      attribute: oct$module_attribute_keywords,                                                               
      desired_attributes: oct$attribute_keyword_set,                                                          
      field: 0 .. occ$kwd_last_attribute,                                                                     
      fields: array [occ$kwd_name .. occ$kwd_last_attribute] of clt$field_value,                              
      index: oct$module_attribute_keywords,                                                                   
      info: attribute_info,                                                                                   
      last_attribute: oct$module_attribute_keywords,                                                          
      module_kind: text_module_kind,                                                                          
      requested_attributes: oct$attribute_keyword_set,                                                        
      standard_header: llt$library_member_header;                                                             
                                                                                                              
    status.normal := TRUE;                                                                                    
    CASE module_description.kind OF                                                                           
    = occ$cpu_object_module =                                                                                 
      info := cpu_object_module_attributes;                                                                   
    = occ$ppu_object_module =                                                                                 
      info := ppu_object_module_attributes;                                                                   
    = occ$load_module, occ$bound_module =                                                                     
      info := load_module_attributes;                                                                         
    = occ$program_description, occ$applic_program_description =                                               
      info := program_description_attributes;                                                                 
    = occ$command_procedure, occ$applic_command_procedure =                                                   
      info := command_procedure_attributes;                                                                   
    = occ$command_description, occ$applic_command_description =                                               
      info := command_description_attributes;                                                                 
    = occ$function_procedure =                                                                                
      info := function_procedure_attributes;                                                                  
    = occ$function_description =                                                                              
      info := function_description_attributes;                                                                
    = occ$message_module =                                                                                    
      info := message_module_attributes;                                                                      
    = occ$panel_module =                                                                                      
      info := form_module_attributes;                                                                         
    ELSE                                                                                                      
      info.kind := 'UNKNOWN';                                                                                 
      info.valid_attributes := header_attributes;                                                             
    CASEND;                                                                                                   
                                                                                                              
    requested_attributes := attribute_keywords;                                                               
    IF occ$kwd_all IN requested_attributes THEN                                                               
      requested_attributes := info.valid_attributes;                                                          
    ELSE                                                                                                      
      IF occ$kwd_program_attributes IN requested_attributes THEN                                              
        requested_attributes := requested_attributes + program_attributes_group;                              
      IFEND;                                                                                                  
      IF occ$kwd_header IN requested_attributes THEN                                                          
        requested_attributes := requested_attributes + header_attributes;                                     
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    desired_attributes := requested_attributes * info.valid_attributes;                                       
                                                                                                              
    field := 0;                                                                                               
    FOR index := 1 TO UPPERBOUND (ocv$module_attribute_keys) DO                                               
      attribute := ocv$module_attribute_keys [index].attribute;                                               
      IF (attribute <= occ$kwd_last_attribute) AND (attribute IN requested_attributes) THEN                   
        field := field + 1;                                                                                   
        last_attribute := attribute;                                                                          
        fields [attribute].name := ocv$module_attribute_keys [index].name;                                    
        fields [attribute].value := NIL;                                                                      
      IFEND;                                                                                                  
    FOREND;                                                                                                   
                                                                                                              
    build_standard_header (changed_info, module_description, module_kind, application_identifier,             
          standard_header, status);                                                                           
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
{ Kind                                                                                                        
                                                                                                              
    IF occ$kwd_kind IN desired_attributes THEN                                                                
      clp$make_keyword_value (info.kind, work_area, fields [occ$kwd_kind].value);                             
    IFEND;                                                                                                    
                                                                                                              
    make_header_fields (desired_attributes, application_identifier, standard_header, module_kind, work_area,  
          fields, status);                                                                                    
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF occ$kwd_aliases IN desired_attributes THEN                                                             
      make_alias_list (changed_info, module_description, work_area, fields [occ$kwd_aliases], status);        
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
    IFEND;                                                                                                    
                                                                                                              
    CASE module_description.kind OF                                                                           
    = occ$cpu_object_module, occ$load_module, occ$bound_module, occ$command_procedure, occ$function_procedure,
          occ$applic_command_procedure =                                                                      
      make_executable_attributes (desired_attributes, changed_info, module_description, work_area, fields,    
            status);                                                                                          
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
      make_other_exec_attributes (desired_attributes, changed_info, module_description, work_area, fields,    
            status);                                                                                          
    = occ$command_description, occ$applic_command_description =                                               
      make_executable_attributes (desired_attributes, changed_info, module_description, work_area, fields,    
            status);                                                                                          
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
      make_command_attributes (desired_attributes, changed_info, standard_header, module_description,         
            work_area, fields, status);                                                                       
    = occ$function_description =                                                                              
      make_executable_attributes (desired_attributes, changed_info, module_description, work_area, fields,    
            status);                                                                                          
      IF NOT status.normal THEN                                                                               
        RETURN;                                                                                               
      IFEND;                                                                                                  
      make_function_attributes (desired_attributes, changed_info, standard_header, module_description,        
            work_area, fields, status);                                                                       
    = occ$program_description, occ$applic_program_description =                                               
      build_program_attributes (desired_attributes, standard_header, changed_info, module_description,        
            work_area, fields, status);                                                                       
    = occ$message_module =                                                                                    
      build_message_module_attributes (desired_attributes, standard_header, changed_info, module_description, 
            work_area, fields, status);                                                                       
    ELSE                                                                                                      
    CASEND;                                                                                                   
    IF NOT status.normal THEN                                                                                 
      RETURN;                                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    clp$make_record_value (field, work_area, result);                                                         
                                                                                                              
    field := 0;                                                                                               
    FOR attribute := occ$kwd_name TO occ$kwd_last_attribute DO                                                
      IF attribute IN requested_attributes THEN                                                               
        field := field + 1;                                                                                   
        IF fields [attribute].value = NIL THEN                                                                
          clp$make_unspecified_value (work_area, fields [attribute].value);                                   
        IFEND;                                                                                                
        result^.field_values^ [field] := fields [attribute];                                                  
      IFEND;                                                                                                  
    FOREND;                                                                                                   
                                                                                                              
  PROCEND ocp$build_module_attributes;                                                                        
?? OLDTITLE ??                                                                                                
MODEND ocm$build_module_attributes;                                                                           
*DECK DECK=OCM$BUILD_SECOND_INTER_OL EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Management : Correction Generation' ??
MODULE ocm$build_second_inter_ol;

{ PURPOSE:
{   This module contains the procedures that build "move items" using the breaklists
{   for both the old and new object libraries.  The move items are generated by finding
{   matching breaklist items and calculating where a specific portion of the old object
{   library is in the new object library.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oct$breaklist
*copyc oct$move_items
?? POP ??
*copyc i#move
*copyc ocp$apply_move_items
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    breaklist_symbol_table = array [1 .. *] of breaklist_symbol_table_item,
    breaklist_symbol_table_item = record
      old_count: symbol_table_index,
      new_count: symbol_table_index,
      index_into_old_array: symbol_table_index,
    recend,
    difference_array = array [1 .. *] of difference_map,
    difference_map = record
      CASE index_into: index_kind OF
      = symbol_table_entry =
        symbol_table_index: symbol_table_index,
      = other_array =
        array_index: 1 .. 7fffffff(16),
      CASEND,
    RECEND,
    index_kind = (symbol_table_entry, other_array),
    items_deleted = array [1 .. * ] of oct$breaklist_length,
    symbol_table_index = 0 .. 7fffffff(16);

?? OLDTITLE ??
?? NEWTITLE := 'build_move_items', EJECT ??
*copy och$build_move_items

  PROCEDURE build_move_items
    (    new_array: ^difference_array;
         new_breaklist: ^oct$breaklist;
         number_of_new_breaklist_items: oct$breaklist_length;
         old_array: ^difference_array;
         old_breaklist: ^oct$breaklist;
         number_of_old_breaklist_items: oct$breaklist_length;
     VAR scratch_segment: ^SEQ ( * );
     VAR move_items: ^oct$move_items;
     VAR number_of_move_items: oct$breaklist_index);

    VAR
      anything_left: boolean,
      i: oct$breaklist_length,
      interchange: boolean,
      j: oct$breaklist_length,
      length: oct$breaklist_length,
      move_item: ^oct$move_item,
      new_offset: oct$offset,
      old_offset: oct$offset,
      pass: oct$breaklist_index,
      save_original_position: ^SEQ ( * ),
      temp_move_item: oct$move_item;


    save_original_position := scratch_segment;
    number_of_move_items := 0;
    i := 1;
    anything_left := TRUE;
    WHILE anything_left DO
      IF new_array^ [i].index_into = other_array THEN
        j := new_array^ [i].array_index;
        length := 0;
        old_offset := old_breaklist^ [j].offset;
        new_offset := new_breaklist^ [i].offset;
        REPEAT
          length := length + old_breaklist^ [j].length;
          j := j + 1;
          i := i + 1;
        UNTIL (i > number_of_new_breaklist_items) OR (j > number_of_old_breaklist_items) OR
              (new_array^ [i].index_into = symbol_table_entry) OR
              ((new_array^ [i].index_into = other_array) AND (new_array^ [i].array_index <> j));
        NEXT move_item IN scratch_segment;
        number_of_move_items := number_of_move_items + 1;
        move_item^.old_offset := old_offset;
        move_item^.new_offset := new_offset;
        move_item^.length := length;
        IF i > number_of_new_breaklist_items THEN
          anything_left := FALSE;
        IFEND;
      ELSE
        IF i = number_of_new_breaklist_items THEN
          anything_left := FALSE;
        ELSE
          i := i + 1;
        IFEND;
      IFEND;
    WHILEND;

    scratch_segment := save_original_position;
    NEXT move_items: [1 .. number_of_move_items] IN scratch_segment;

    interchange := TRUE;
    pass := 1;
    WHILE (pass <= number_of_move_items - 1) AND interchange DO
      interchange := FALSE;
      FOR j := 1 TO (number_of_move_items - pass) DO
        IF move_items^ [j].new_offset > move_items^ [j + 1].new_offset THEN
          interchange := TRUE;
          temp_move_item := move_items^ [j];
          move_items^ [j] := move_items^ [j + 1];
          move_items^ [j + 1] := temp_move_item;
        IFEND;
      FOREND;
      pass := pass + 1;
    WHILEND;
    FOR i := 2 TO number_of_move_items DO
      move_items^ [i].new_offset := move_items^ [i - 1].new_offset + move_items^ [i - 1].length;
    FOREND;
  PROCEND build_move_items;
?? OLDTITLE ??
?? NEWTITLE := 'build_symbol_table', EJECT ??
*copy och$build_symbol_table

  PROCEDURE build_symbol_table
    (    old_breaklist: ^oct$breaklist;
         new_breaklist: ^oct$breaklist;
         number_of_old_breaklist_items: oct$breaklist_length;
         number_of_new_breaklist_items: oct$breaklist_length;
     VAR old_array: ^difference_array;
     VAR new_array: ^difference_array;
     VAR symbol_table: ^breaklist_symbol_table);

    CONST
      fold_size = 10000(16);

    VAR
      fold_number: 0 .. 0fffff(16),
      i: symbol_table_index,
      index: symbol_table_index,
      j: 1 .. 4,
      number: integer,
      save_number: integer,
      two_bytes: 0 .. 0ffff(16);

    FOR i := 1 TO UPPERBOUND (symbol_table^) DO
      symbol_table^ [i].new_count := 0;
      symbol_table^ [i].old_count := 0;
      symbol_table^ [i].index_into_old_array := 0;
    FOREND;

    FOR i := 1 TO number_of_new_breaklist_items DO
      convert_name_to_integer (new_breaklist^ [i].module_name, number);
      save_number := number;
      convert_name_to_integer (new_breaklist^ [i].major_name, number);
      save_number := save_number + number;
      convert_name_to_integer (new_breaklist^ [i].minor_name, number);
      save_number := save_number + number;
      save_number := save_number + $INTEGER (new_breaklist^ [i].kind);
      save_number := save_number - new_breaklist^ [i].section_ordinal;
      save_number := save_number + new_breaklist^ [i].secondary_section_ordinal;

      fold_number := 0;
      FOR j := 1 TO 4 DO
        two_bytes := save_number MOD fold_size;
        fold_number := (fold_number + two_bytes) * 2;
        fold_number := (fold_number MOD fold_size) + (fold_number DIV fold_size);
        save_number := save_number DIV fold_size;
      FOREND;
      index := (fold_number MOD UPPERBOUND (symbol_table^)) + 1;

      new_array^ [i].index_into := symbol_table_entry;
      new_array^ [i].symbol_table_index := index;
      symbol_table^ [index].new_count := symbol_table^ [index].new_count + 1;
    FOREND;

    FOR i := 1 TO number_of_old_breaklist_items DO
      convert_name_to_integer (old_breaklist^ [i].module_name, number);
      save_number := number;
      convert_name_to_integer (old_breaklist^ [i].major_name, number);
      save_number := save_number + number;
      convert_name_to_integer (old_breaklist^ [i].minor_name, number);
      save_number := save_number + number;
      save_number := save_number + $INTEGER (old_breaklist^ [i].kind);
      save_number := save_number - old_breaklist^ [i].section_ordinal;
      save_number := save_number + old_breaklist^ [i].secondary_section_ordinal;

      fold_number := 0;
      FOR j := 1 TO 4 DO
        two_bytes := save_number MOD fold_size;
        fold_number := (fold_number + two_bytes) * 2;
        fold_number := (fold_number MOD fold_size) + (fold_number DIV fold_size);
        save_number := save_number DIV fold_size;
      FOREND;
      index := (fold_number MOD UPPERBOUND (symbol_table^)) + 1;

      old_array^ [i].index_into := symbol_table_entry;
      old_array^ [i].symbol_table_index := index;
      symbol_table^ [index].old_count := symbol_table^ [index].old_count + 1;
      symbol_table^ [index].index_into_old_array := i;
    FOREND;
  PROCEND build_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] convert_name_to_integer', EJECT ??

{ PURPOSE:
{   This procedure converts a name to an integer by folding
{   six bytes at a time.

  PROCEDURE [INLINE] convert_name_to_integer
    (    name: ost$name;
     VAR save_number: integer);

    VAR
      i: 1 .. 31,
      j: 1 .. 6,
      number: 0 .. 0ff(16),
      number_value: integer;

    save_number := 0;
    number_value := 0;
    i := 1;
    WHILE i < 30 DO
      FOR j := 1 TO 6 DO
        number := $INTEGER (name (i, 1));
        number_value := number_value * 256 + number;
        i := i + 1;
      FOREND;
      save_number := save_number + number_value;
      number_value := 0;
    WHILEND;
    save_number := save_number + $INTEGER (name (31, 1));
  PROCEND convert_name_to_integer;
?? OLDTITLE ??
?? NEWTITLE := 'find_match_breaklist_items', EJECT ??
*copy och$find_match_breaklist_items

  PROCEDURE find_match_breaklist_items
    (    old_breaklist: ^oct$breaklist;
         new_breaklist: ^oct$breaklist;
     VAR old_array: ^difference_array;
     VAR new_array: ^difference_array;
     VAR symbol_table: ^breaklist_symbol_table);

    VAR
      i: oct$breaklist_length,
      j: oct$breaklist_length;

    new_array^ [1].index_into := other_array;
    new_array^ [1].array_index := 1;
    old_array^ [1].index_into := other_array;
    old_array^ [1].array_index := 1;

    i := UPPERBOUND (old_array^);
    j := UPPERBOUND (new_array^);
    IF (new_array^ [j].index_into = symbol_table_entry) AND
          (old_array^ [i].index_into = symbol_table_entry) AND
          (new_array^ [j].symbol_table_index = old_array^ [i].symbol_table_index) THEN
      new_array^ [j].index_into := other_array;
      new_array^ [j].array_index := i;
      old_array^ [i].index_into := other_array;
      old_array^ [i].array_index := j;
    IFEND;

    FOR i := 1 TO UPPERBOUND (new_array^) DO
      IF (symbol_table^ [new_array^ [i].symbol_table_index].new_count = 1) AND
            (symbol_table^ [new_array^ [i].symbol_table_index].old_count = 1) THEN
        j := symbol_table^ [new_array^ [i].symbol_table_index].index_into_old_array;
        IF (new_breaklist^ [i].module_name = old_breaklist^ [j].module_name) AND
              (new_breaklist^ [i].major_name = old_breaklist^ [j].major_name) AND
              (new_breaklist^ [i].minor_name = old_breaklist^ [j].minor_name) AND
              (new_breaklist^ [i].kind = old_breaklist^ [j].kind) AND
              (new_breaklist^ [i].section_ordinal = old_breaklist^ [j].section_ordinal) AND
              (new_breaklist^ [i].secondary_section_ordinal = old_breaklist^ [j].secondary_section_ordinal)
              THEN
          new_array^ [i].index_into := other_array;
          new_array^ [i].array_index := j;
          old_array^ [j].index_into := other_array;
          old_array^ [j].array_index := i;
        IFEND;
      IFEND;
    FOREND;

    FOR i := 1 TO UPPERBOUND (new_array^) - 1 DO
      IF new_array^ [i].index_into = other_array THEN
        j := new_array^ [i].array_index;
        IF j < UPPERBOUND (old_array^) THEN
          IF (new_array^ [i + 1].index_into = symbol_table_entry) AND
                (old_array^ [j + 1].index_into = symbol_table_entry) AND
                (old_array^ [j + 1].symbol_table_index = new_array^ [i + 1].symbol_table_index) THEN
            IF (new_breaklist^ [i + 1].module_name = old_breaklist^ [j + 1].module_name) AND
                  (new_breaklist^ [i + 1].major_name = old_breaklist^ [j + 1].major_name) AND
                  (new_breaklist^ [i + 1].minor_name = old_breaklist^ [j + 1].minor_name) AND
                  (new_breaklist^ [i + 1].kind = old_breaklist^ [j + 1].kind) AND
                  (new_breaklist^ [i + 1].section_ordinal = old_breaklist^ [j + 1].section_ordinal) AND
                  (new_breaklist^ [i + 1].secondary_section_ordinal =
                  old_breaklist^ [j + 1].secondary_section_ordinal) THEN
              old_array^ [j + 1].index_into := other_array;
              old_array^ [j + 1].array_index := i + 1;
              new_array^ [i + 1].index_into := other_array;
              new_array^ [i + 1].array_index := j + 1;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

    FOR i := UPPERBOUND (new_array^) DOWNTO 2 DO
      IF new_array^ [i].index_into = other_array THEN
        j := new_array^ [i].array_index;
        IF j > 1 THEN
          IF (new_array^ [i - 1].index_into = symbol_table_entry) AND
                (old_array^ [j - 1].index_into = symbol_table_entry) AND
                (old_array^ [j - 1].symbol_table_index = new_array^ [i - 1].symbol_table_index) THEN
            IF (new_breaklist^ [i - 1].module_name = old_breaklist^ [j - 1].module_name) AND
                  (new_breaklist^ [i - 1].major_name = old_breaklist^ [j - 1].major_name) AND
                  (new_breaklist^ [i - 1].minor_name = old_breaklist^ [j - 1].minor_name) AND
                  (new_breaklist^ [i - 1].kind = old_breaklist^ [j - 1].kind) AND
                  (new_breaklist^ [i - 1].section_ordinal = old_breaklist^ [j - 1].section_ordinal) AND
                  (new_breaklist^ [i - 1].secondary_section_ordinal =
                  old_breaklist^ [j - 1].secondary_section_ordinal) THEN
              old_array^ [j - 1].index_into := other_array;
              old_array^ [j - 1].array_index := i - 1;
              new_array^ [i - 1].index_into := other_array;
              new_array^ [i - 1].array_index := j - 1;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    FOREND;
  PROCEND find_match_breaklist_items;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$build_second_inter_ol', EJECT ??
*copy och$build_second_inter_ol

  PROCEDURE [XDCL] ocp$build_second_inter_ol
    (    first_intermediate_ol: ^SEQ ( * );
         new_breaklist: ^oct$breaklist;
         length_of_new_breaklist: oct$breaklist_length;
     VAR old_breaklist: ^oct$breaklist;
     VAR length_of_old_breaklist: oct$breaklist_length;
     VAR second_intermediate_ol: ^SEQ ( * );
     VAR scratch_segment: ^SEQ ( * );
     VAR move_items: ^oct$move_items;
     VAR number_of_move_items: oct$breaklist_index);

    VAR
      i: oct$breaklist_index,
      interchange: boolean,
      j: oct$breaklist_index,
      new_array: ^difference_array,
      old_array: ^difference_array,
      old_offset_sorted_move_items: ^oct$move_items,
      pass: oct$breaklist_index,
      symbol_table: ^breaklist_symbol_table,
      symbol_table_size: symbol_table_index,
      temp_move_item: oct$move_item;

    NEXT new_array: [1 .. length_of_new_breaklist] IN scratch_segment;
    NEXT old_array: [1 .. length_of_old_breaklist] IN scratch_segment;
    symbol_table_size := 17 * (length_of_new_breaklist + length_of_old_breaklist);
    NEXT symbol_table: [1 .. symbol_table_size] IN scratch_segment;

    build_symbol_table (old_breaklist, new_breaklist, length_of_old_breaklist, length_of_new_breaklist,
          old_array, new_array, symbol_table);

    find_match_breaklist_items (old_breaklist, new_breaklist, old_array, new_array, symbol_table);

    build_move_items (new_array, new_breaklist, length_of_new_breaklist, old_array, old_breaklist,
          length_of_old_breaklist, scratch_segment, move_items, number_of_move_items);

    PUSH old_offset_sorted_move_items: [1 .. number_of_move_items];

    old_offset_sorted_move_items^ := move_items^;

    interchange := TRUE;
    pass := 1;
    WHILE (pass <= number_of_move_items - 1) AND interchange DO
      interchange := FALSE;
      FOR j := 1 TO (number_of_move_items - pass) DO
        IF old_offset_sorted_move_items^ [j].old_offset > old_offset_sorted_move_items^ [j + 1].
              old_offset THEN
          interchange := TRUE;
          temp_move_item := old_offset_sorted_move_items^ [j];
          old_offset_sorted_move_items^ [j] := old_offset_sorted_move_items^ [j + 1];
          old_offset_sorted_move_items^ [j + 1] := temp_move_item;
        IFEND;
      FOREND;
      pass := pass + 1;
    WHILEND;

    update_old_breaklist (old_offset_sorted_move_items, number_of_move_items, old_breaklist,
          length_of_old_breaklist);

    ocp$apply_move_items (first_intermediate_ol, move_items, number_of_move_items, second_intermediate_ol);

  PROCEND ocp$build_second_inter_ol;
?? OLDTITLE ??
?? NEWTITLE := 'sort_breaklist', EJECT ??

{ PURPOSE:
{   The purpose of this request is to sort a breaklist.

  PROCEDURE sort_breaklist
    (    number: integer;
     VAR breaklist: ^oct$breaklist);

    VAR
      i: integer,
      j: integer,
      key: llt$section_offset,
      left: integer,
      right: integer,
      temp: oct$breaklist_item;

    IF number <= 1 THEN
      RETURN;
    ELSEIF number = 2 THEN
      IF breaklist^ [1].offset > breaklist^ [2].offset THEN
        temp := breaklist^ [1];
        breaklist^ [1] := breaklist^ [2];
        breaklist^ [2] := temp;
      IFEND;
      RETURN;
    IFEND;

    left := (number DIV 2) + 1;
    right := number;

  /outer_loop/
    WHILE TRUE DO
      IF left > 1 THEN
        left := left - 1;
        temp := breaklist^ [left];
        key := breaklist^ [left].offset;
      ELSE
        temp := breaklist^ [right];
        key := breaklist^ [right].offset;
        breaklist^ [right] := breaklist^ [1];
        right := right - 1;
        IF right = 1 THEN
          breaklist^ [right] := temp;
          RETURN;
        IFEND;
      IFEND;

      j := left;

    /inner_loop/
      WHILE TRUE DO
        i := j;
        j := j + j;
        IF j < right THEN
          IF (breaklist^ [j].offset < breaklist^ [j + 1].offset) THEN
            j := j + 1;
          IFEND;
        ELSEIF j > right THEN
          EXIT /inner_loop/;
        IFEND;

        IF key >= breaklist^ [j].offset THEN
          EXIT /inner_loop/;
        IFEND;

        breaklist^ [i] := breaklist^ [j];
      WHILEND /inner_loop/;

      breaklist^ [i] := temp;
    WHILEND /outer_loop/;
  PROCEND sort_breaklist;
?? OLDTITLE ??
?? NEWTITLE := 'update_old_breaklist', EJECT ??
*copy och$update_old_breaklist

  PROCEDURE update_old_breaklist
    (    move_items: ^oct$move_items;
         number_of_move_items: oct$breaklist_index;
     VAR old_breaklist: ^oct$breaklist;
     VAR length_of_old_breaklist: oct$breaklist_length);

    VAR
      delete_index: ^items_deleted,
      i: oct$breaklist_length,
      j: oct$breaklist_index,
      k: oct$breaklist_length,
      l: oct$breaklist_length,
      number_of_delete_items: oct$breaklist_length;

    PUSH delete_index: [1 .. length_of_old_breaklist];
    k := 1;
    j := 1;
    i := 1;
    WHILE (i <= length_of_old_breaklist) AND (j <= number_of_move_items) DO
      IF (move_items^ [j].old_offset <= old_breaklist^ [i].offset) AND
            (old_breaklist^ [i].offset < (move_items^ [j].old_offset + move_items^ [j].length)) THEN
        old_breaklist^ [i].offset := old_breaklist^ [i].offset - move_items^ [j].old_offset +
              move_items^ [j].new_offset;
        i := i + 1;
      ELSEIF (old_breaklist^ [i].offset >= (move_items^ [j].old_offset + move_items^ [j].length)) THEN
        j := j + 1;
      ELSE
        delete_index^ [k] := i;
        k := k + 1;
        i := i + 1;
      IFEND;
    WHILEND;

    IF (j > number_of_move_items) AND (i <= length_of_old_breaklist) THEN
      FOR l := i TO length_of_old_breaklist DO
        delete_index^ [k] := l;
        k := k + 1;
      FOREND;
    IFEND;

    number_of_delete_items := k - 1;
    l := 1;
    k := 1;

  /delete_entries/
    FOR i := 1 TO length_of_old_breaklist DO
      IF (k <= number_of_delete_items) AND (delete_index^ [k] = i) THEN
        k := k + 1;
        CYCLE /delete_entries/
      IFEND;
      old_breaklist^ [l] := old_breaklist^ [i];
      l := l + 1;
    FOREND /delete_entries/;

    length_of_old_breaklist := l - 1;

    sort_breaklist (length_of_old_breaklist, old_breaklist);
  PROCEND update_old_breaklist;
?? OLDTITLE ??
MODEND ocm$build_second_inter_ol;
*DECK DECK=OCM$BUILD_SECTION_DIRECTORY EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$build_section_directory;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc llt$load_module_header
*copyc llt$object_text_descriptor
*copyc llt$section_definition
*copyc occ$generate_predictor
*copyc oct$offset_change_list
*copyc oct$section_directory
*copyc oct$single_module_predictor_hdr
*copyc oct$offset_change_list
*copyc oct$section_offset_changes
*copyc oct$module_predictor_size
*copyc oce$metapatch_generator_errors
*copyc llt$section_address
*copyc osp$set_status_abnormal
?? POP ??

*copyc och$build_section_directory

  PROCEDURE [XDCL] ocp$build_section_directory (p_module_predictor: ^oct$module_predictor;
        module_header: ^llt$load_module_header;
        object_library: ^SEQ ( * );
    VAR section_directory: ^oct$section_directory);

    VAR
      binding_section_ocv: ^oct$offset_change_list,
      i: llt$section_ordinal,
      module_predictor: ^oct$module_predictor,
      module_predictor_header: ^oct$single_module_predictor_hdr,
      section_number_change_list: ^oct$new_ordinal_list,
      section_number_cv: ^oct$new_ordinal_list,
      section_offset_cv: ^oct$section_offset_changes,
      socv: ^oct$offset_change_list,
      socv_header: ^oct$section_info,
      status: ost$status;

    module_predictor := p_module_predictor;

    FOR i := 0 TO UPPERBOUND (section_directory^) DO
      section_directory^ [i].new_section_number := i;
      section_directory^ [i].section_offset_change_vector := NIL;
    FOREND;
    RESET module_predictor;
    NEXT module_predictor_header IN module_predictor;
    IF module_predictor_header^.last_section_ordinal <> occ$invalid_section_ordinal THEN
      section_number_cv := #PTR (module_predictor_header^.section_number_cv, module_predictor^);
      RESET module_predictor TO section_number_cv;
      NEXT section_number_change_list: [0 .. module_predictor_header^.last_section_ordinal] IN
            module_predictor;
      FOR i := 0 TO UPPERBOUND (section_directory^) DO
        section_directory^ [i].new_section_number := section_number_change_list^ [i];
      FOREND;
    IFEND;
    IF module_predictor_header^.length_normal_section_ocv > 0 THEN
      section_offset_cv := #PTR (module_predictor_header^.section_offset_cv, module_predictor^);
      RESET module_predictor TO section_offset_cv;
      FOR i := 1 TO module_predictor_header^.length_normal_section_ocv DO
        NEXT socv_header IN module_predictor;
        NEXT socv: [1 .. socv_header^.number_of_socv_items] IN module_predictor;
        section_directory^ [socv_header^.section_ordinal].section_offset_change_vector := socv;
      FOREND;
    IFEND;
    IF module_predictor_header^.length_binding_socv > 0 THEN
      binding_section_ocv := #PTR (module_predictor_header^.binding_section_ocv, module_predictor^);
      section_directory^ [module_predictor_header^.binding_section_ordinal].section_offset_change_vector :=
                    binding_section_ocv;
    IFEND;
  PROCEND ocp$build_section_directory;
MODEND ocm$build_section_directory;
*DECK DECK=OCM$CHANGE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
MODULE ocm$change;



{ PURPOSE:
{   To alter various characteristics of
{   a module in the output library.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc occ$retain
*copyc oce$library_generator_errors
*copyc oct$display_toggles
*copyc oct$header
*copyc oct$nlm_modification_list
*copyc ost$status
?? POP ??
*copyc avp$get_capability
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc ocp$add_an_nlm_to_tree
*copyc ocp$close_all_open_files
*copyc ocp$extract_nlm_from_tree
*copyc ocp$generate_message
*copyc ocp$initialize_olg_working_heap
*copyc ocp$obtain_header
*copyc ocp$obtain_library_list
*copyc ocp$obtain_xdcl_list
*copyc ocp$search_modification_list
*copyc ocp$search_nlm_tree
*copyc ocp$search_xdcl_list
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler

*copyc ocv$nlm_list
*copyc ocv$olg_scratch_seq
*copyc ocv$olg_working_heap
*copyc ocv$open_file_list
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    command_status: ost$status;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$_change_module_attribute' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$_change_module_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$creol_chama) change_module_attributes, chama (
{   module, modules, m: any of
{       key
{         all
{       keyend
{       list of program_name
{       list of range of program_name
{     anyend = $required
{   new_name, nn: program_name = $optional
{   substitute, substitutes, s: (BY_NAME) list of record
{       old_name: program_name
{       new_name: program_name
{     recend = $optional
{   omit, o: (BY_NAME) list of program_name = $optional
{   gate, gates, g: (BY_NAME) any of
{       key
{         all
{       keyend
{       list of program_name
{     anyend = $optional
{   not_gate, not_gates, ng: (BY_NAME) any of
{       key
{         all
{       keyend
{       list of program_name
{     anyend = $optional
{   starting_procedure, sp: (BY_NAME) program_name = $optional
{   omit_library, omit_libraries, ol: (BY_NAME) list of name = $optional
{   add_library, add_libraries, al: (BY_NAME) list of name = $optional
{   retain, r: (BY_NAME) any of
{       key
{         all
{       keyend
{       list of program_name
{     anyend = $optional
{   not_retain, nr: (BY_NAME) any of
{       key
{         all
{       keyend
{       list of program_name
{     anyend = $optional
{   omit_non_retained_entry_points, onrep: (BY_NAME) boolean = $optional
{   omit_debug_tables, omit_debug_table, odt: (BY_NAME) any of
{       key
{         all
{       keyend
{       list of key
{         (line_table, lt)
{         (parameter_checking, pc)
{         (supplemental_debug_table, sdt)
{         (symbol_table, st)
{       keyend
{     anyend = $optional
{   comment, c: (BY_NAME) string 1..40 = $optional
{   application_identifier, ai: (BY_NAME, ADVANCED) any of
{       key
{         $unspecified
{       keyend
{       name
{     anyend = $optional
{   cybil_parameter_checking, cpc: (BY_NAME) key
{       (source, s)
{       (object, o)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 40] of clt$pdt_parameter_name,
      parameters: array [1 .. 17] 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,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type5: 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,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type6: 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,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type10: 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,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type11: 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,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type12: record
        header: clt$type_specification_header,
      recend,
      type13: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 8] of clt$keyword_specification,
          recend,
        recend,
      recend,
      type14: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type15: 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$name_type_qualifier,
        recend,
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type17: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 10, 14, 41, 44, 322],
    clc$command, 40, 17, 1, 1, 0, 0, 17, 'OCM$CREOL_CHAMA'], [
    ['ADD_LIBRARIES                  ',clc$alias_entry, 9],
    ['ADD_LIBRARY                    ',clc$nominal_entry, 9],
    ['AI                             ',clc$abbreviation_entry, 15],
    ['AL                             ',clc$abbreviation_entry, 9],
    ['APPLICATION_IDENTIFIER         ',clc$nominal_entry, 15],
    ['C                              ',clc$abbreviation_entry, 14],
    ['COMMENT                        ',clc$nominal_entry, 14],
    ['CPC                            ',clc$abbreviation_entry, 16],
    ['CYBIL_PARAMETER_CHECKING       ',clc$nominal_entry, 16],
    ['G                              ',clc$abbreviation_entry, 5],
    ['GATE                           ',clc$nominal_entry, 5],
    ['GATES                          ',clc$alias_entry, 5],
    ['M                              ',clc$abbreviation_entry, 1],
    ['MODULE                         ',clc$nominal_entry, 1],
    ['MODULES                        ',clc$alias_entry, 1],
    ['NEW_NAME                       ',clc$nominal_entry, 2],
    ['NG                             ',clc$abbreviation_entry, 6],
    ['NN                             ',clc$abbreviation_entry, 2],
    ['NOT_GATE                       ',clc$nominal_entry, 6],
    ['NOT_GATES                      ',clc$alias_entry, 6],
    ['NOT_RETAIN                     ',clc$nominal_entry, 11],
    ['NR                             ',clc$abbreviation_entry, 11],
    ['O                              ',clc$abbreviation_entry, 4],
    ['ODT                            ',clc$abbreviation_entry, 13],
    ['OL                             ',clc$abbreviation_entry, 8],
    ['OMIT                           ',clc$nominal_entry, 4],
    ['OMIT_DEBUG_TABLE               ',clc$alias_entry, 13],
    ['OMIT_DEBUG_TABLES              ',clc$nominal_entry, 13],
    ['OMIT_LIBRARIES                 ',clc$alias_entry, 8],
    ['OMIT_LIBRARY                   ',clc$nominal_entry, 8],
    ['OMIT_NON_RETAINED_ENTRY_POINTS ',clc$nominal_entry, 12],
    ['ONREP                          ',clc$abbreviation_entry, 12],
    ['R                              ',clc$abbreviation_entry, 10],
    ['RETAIN                         ',clc$nominal_entry, 10],
    ['S                              ',clc$abbreviation_entry, 3],
    ['SP                             ',clc$abbreviation_entry, 7],
    ['STARTING_PROCEDURE             ',clc$nominal_entry, 7],
    ['STATUS                         ',clc$nominal_entry, 17],
    ['SUBSTITUTE                     ',clc$nominal_entry, 3],
    ['SUBSTITUTES                    ',clc$alias_entry, 3]],
    [
{ PARAMETER 1
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 113, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [39, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 101, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 19, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 83, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 83, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [37, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [30, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 21, clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 21, clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [34, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 83, clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 83, clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [31, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 13
    [28, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 383, clc$optional_parameter, 0, 0],
{ PARAMETER 14
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 15
    [5, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 16
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [38, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$program_name_type]]
      ],
    26, [[1, 0, clc$list_type], [10, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$range_type], [3],
          [[1, 0, clc$program_name_type]]
        ]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$program_name_type]],
{ PARAMETER 3
    [[1, 0, clc$list_type], [85, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$record_type], [2],
      ['OLD_NAME                       ', clc$required_field, 3], [[1, 0,
  clc$program_name_type]],
      ['NEW_NAME                       ', clc$required_field, 3], [[1, 0,
  clc$program_name_type]]
      ]
    ],
{ PARAMETER 4
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$program_name_type]]
    ],
{ PARAMETER 5
    [[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]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$program_name_type]]
      ]
    ],
{ PARAMETER 6
    [[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]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$program_name_type]]
      ]
    ],
{ PARAMETER 7
    [[1, 0, clc$program_name_type]],
{ PARAMETER 8
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 9
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 10
    [[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]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$program_name_type]]
      ]
    ],
{ PARAMETER 11
    [[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]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$program_name_type]]
      ]
    ],
{ PARAMETER 12
    [[1, 0, clc$boolean_type]],
{ PARAMETER 13
    [[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]]
      ],
    319, [[1, 0, clc$list_type], [303, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [8], [
        ['LINE_TABLE                     ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['LT                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['PARAMETER_CHECKING             ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['PC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['SDT                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['ST                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['SUPPLEMENTAL_DEBUG_TABLE       ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['SYMBOL_TABLE                   ', clc$nominal_entry,
  clc$normal_usage_entry, 4]]
        ]
      ]
    ],
{ PARAMETER 14
    [[1, 0, clc$string_type], [1, 40, FALSE]],
{ PARAMETER 15
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 16
    [[1, 0, clc$keyword_type], [4], [
    ['O                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['OBJECT                         ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['SOURCE                         ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 17
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$module = 1,
      p$new_name = 2,
      p$substitute = 3,
      p$omit = 4,
      p$gate = 5,
      p$not_gate = 6,
      p$starting_procedure = 7,
      p$omit_library = 8,
      p$add_library = 9,
      p$retain = 10,
      p$not_retain = 11,
      p$omit_non_retained_entry_point = 12 {OMIT_NON_RETAINED_ENTRY_POINTS} ,
      p$omit_debug_tables = 13,
      p$comment = 14,
      p$application_identifier = 15,
      p$cybil_parameter_checking = 16,
      p$status = 17;

    VAR
      pvt: array [1 .. 17] of clt$parameter_value;

    TYPE
      oct$attribute_change = (add_attribute, remove_attribute);

    TYPE
      oct$names = array [1 .. * ] of pmt$program_name;

    VAR
      object_type_checking: [STATIC, READ] string (6) := 'OBJECT';

    VAR
      application_administrator: boolean;

    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'add_modules_to_change_list', EJECT ??

    PROCEDURE add_modules_to_change_list
      (    first_module: pmt$program_name;
           last_module: pmt$program_name;
           change_list: {output} ^oct$nlm_modification_list;
       VAR status: ost$status);


      VAR
        new_changes: ^oct$nlm_modification_list,
        last_change: ^oct$nlm_modification_list,

        module_found: boolean,
        nlm: ^oct$new_library_module_list,
        current_module: pmt$program_name;


      ocp$search_modification_list (osc$null_name, change_list, new_changes, module_found);


      ocp$search_nlm_tree (first_module, nlm, module_found);

      IF NOT module_found THEN
        IF first_module = last_module THEN
          osp$set_status_abnormal (oc, oce$w_module_not_on_library, first_module, status);
        ELSE
          osp$set_status_abnormal (oc, oce$w_subrange_not_found_on_lib, first_module, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, last_module, status);
        IFEND;

        ocp$generate_message (status);
        osp$set_status_abnormal (oc, oce$e_some_modules_not, 'changed', command_status);
        RETURN; { ---->
      IFEND;

?? EJECT ??

      REPEAT
        current_module := nlm^.name;
        IF current_module = osc$null_name THEN
          osp$set_status_abnormal (oc, oce$e_range_module_2_not_found, last_module, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);
          ocp$generate_message (status);
          osp$set_status_abnormal (oc, oce$e_some_modules_not, 'changed', command_status);
          new_changes^.link := NIL;
          RETURN;
        IFEND;

        ocp$search_modification_list (current_module, change_list, last_change, module_found);
        IF module_found THEN
          osp$set_status_abnormal (oc, oce$w_same_module_quoted_twice, current_module, status);
          ocp$generate_message (status);
          osp$set_status_abnormal (oc, oce$e_some_modules_not, 'changed', command_status);

        ELSE
          NEXT last_change^.link IN ocv$olg_scratch_seq;
          last_change := last_change^.link;
          IF last_change = NIL THEN
            osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
            RETURN;
          IFEND;

          IF nlm^.changed_info = NIL THEN
            ALLOCATE nlm^.changed_info IN ocv$olg_working_heap^;
            IF nlm^.changed_info = NIL THEN
              osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
              RETURN;
            IFEND;

            nlm^.changed_info^.name := NIL;
            nlm^.changed_info^.commentary := NIL;
            nlm^.changed_info^.entry_points := NIL;
            nlm^.changed_info^.starting_procedure := osc$null_name;
            nlm^.changed_info^.new_libraries := FALSE;
            nlm^.changed_info^.library_list := NIL;
            nlm^.changed_info^.debug_tables_to_omit := $oct$debug_tables [];
            nlm^.changed_info^.application_identifier := NIL;
            nlm^.changed_info^.cybil_parameter_checking := '      ';
          IFEND;

          last_change^.nlm := nlm;
          last_change^.link := NIL;
        IFEND;

        nlm := nlm^.f_link;

      UNTIL current_module = last_module;


    PROCEND add_modules_to_change_list;
?? OLDTITLE ??
?? NEWTITLE := 'change_module_name', EJECT ??

    PROCEDURE change_module_name
      (    parameter: clt$parameter_value;
           change_list: ^oct$nlm_modification_list;
       VAR status: ost$status);


      VAR
        new_module_name: pmt$program_name,
        ignore: ^oct$new_library_module_list,
        module_found: boolean;

      status.normal := TRUE;
      IF multiple_modules THEN
        osp$set_status_condition (oce$e_cant_change_module_name, status);
        RETURN;
      IFEND;

      new_module_name := parameter.value^.program_name_value;
      ocp$search_nlm_tree (new_module_name, ignore, module_found);
      IF module_found THEN
        osp$set_status_abnormal (oc, oce$e_module_already_on_library, new_module_name, status);
        RETURN;
      IFEND;

      IF change_list^.nlm^.changed_info^.name = NIL THEN
        ALLOCATE change_list^.nlm^.changed_info^.name IN ocv$olg_working_heap^;
        IF change_list^.nlm^.changed_info^.name = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
      IFEND;
      change_list^.nlm^.changed_info^.name^ := new_module_name;

      ocp$extract_nlm_from_tree (change_list^.nlm);
      change_list^.nlm^.name := new_module_name;
      ocp$add_an_nlm_to_tree (change_list^.nlm);


    PROCEND change_module_name;
?? OLDTITLE ??
?? NEWTITLE := 'build_xdcl_lists', EJECT ??

    PROCEDURE build_xdcl_lists
      (    change_list: ^oct$nlm_modification_list;
       VAR status: ost$status);


      VAR
        deferred_entry_point_list: oct$external_declaration_list,
        next_change: ^oct$nlm_modification_list,
        nlm: ^oct$new_library_module_list,
        xdcl_list: oct$external_declaration_list,
        starting_procedure: pmt$program_name;

      status.normal := TRUE;
      next_change := change_list;

      WHILE (next_change <> NIL) DO
        nlm := next_change^.nlm;

        ocp$obtain_xdcl_list (nlm^.changed_info, occ$retain, {obtain_deferred_entry_points} FALSE,
              nlm^.description^, xdcl_list, starting_procedure, deferred_entry_point_list, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        nlm^.changed_info^.entry_points := xdcl_list.link;
        nlm^.changed_info^.starting_procedure := starting_procedure;

        next_change := next_change^.link;
      WHILEND;


    PROCEND build_xdcl_lists;
?? OLDTITLE ??
?? NEWTITLE := 'build_library_lists', EJECT ??

    PROCEDURE build_library_lists
      (    change_list: ^oct$nlm_modification_list;
       VAR status: ost$status);


      VAR
        next_change: ^oct$nlm_modification_list,
        nlm: ^oct$new_library_module_list,
        library_list: oct$name_list;

      status.normal := TRUE;
      next_change := change_list;

      WHILE (next_change <> NIL) DO
        nlm := next_change^.nlm;

        ocp$obtain_library_list (nlm^.description^, nlm^.changed_info, library_list, occ$retain, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        nlm^.changed_info^.library_list := library_list.link;

        next_change := next_change^.link;
      WHILEND;


    PROCEND build_library_lists;
?? OLDTITLE ??
?? NEWTITLE := 'process_substitutions', EJECT ??

    PROCEDURE process_substitutions
      (    parameter: clt$parameter_value;
           change_list: ^oct$nlm_modification_list;
       VAR status: ost$status);


      VAR
        old_names: ^oct$names,
        new_names: ^oct$names,
        i: integer,
        next_change: ^oct$nlm_modification_list,
        node: ^clt$data_value,
        number_of_names: clt$list_size,
        found: boolean,
        xdcl_list: oct$external_declaration_list,
        xdcl_before: ^oct$external_declaration_list;

      status.normal := TRUE;
      number_of_names := clp$count_list_elements (parameter.value);
      NEXT old_names: [1 .. number_of_names] IN ocv$olg_scratch_seq;
      IF (old_names = NIL) THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;
      NEXT new_names: [1 .. number_of_names] IN ocv$olg_scratch_seq;
      IF (new_names = NIL) THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;
      node := parameter.value;
      FOR i := 1 TO number_of_names DO
        old_names^ [i] := node^.element_value^.field_values^ [1].value^.program_name_value;
        new_names^ [i] := node^.element_value^.field_values^ [2].value^.program_name_value;
        node := node^.link;
      FOREND;

      next_change := change_list;

      WHILE (next_change <> NIL) DO
        xdcl_list.link := next_change^.nlm^.changed_info^.entry_points;

        FOR i := LOWERBOUND (new_names^) TO UPPERBOUND (old_names^) DO
          ocp$search_xdcl_list (new_names^ [i], ^xdcl_list, found, xdcl_before);
          IF found THEN
            IF NOT multiple_modules THEN
              osp$set_status_abnormal (oc, oce$w_xdcl_already_exists, new_names^ [i], status);
              ocp$generate_message (status);
              osp$set_status_abnormal (oc, oce$e_some_attributes_not, '', command_status);
            IFEND;
          ELSE
            ocp$search_xdcl_list (old_names^ [i], ^xdcl_list, found, xdcl_before);
            IF NOT found THEN
              IF NOT multiple_modules THEN
                osp$set_status_abnormal (oc, oce$w_xdcl_doesnt_exist, old_names^ [i], status);
                ocp$generate_message (status);
                osp$set_status_abnormal (oc, oce$e_some_attributes_not, '', command_status);
              IFEND;
            ELSE
              xdcl_before^.link^.name := new_names^ [i];

              IF old_names^ [i] = next_change^.nlm^.changed_info^.starting_procedure THEN
                next_change^.nlm^.changed_info^.starting_procedure := new_names^ [i];
              IFEND;
            IFEND;
          IFEND;
        FOREND;

        next_change := next_change^.link;
      WHILEND;


    PROCEND process_substitutions;
?? OLDTITLE ??
?? NEWTITLE := 'process_omissions', EJECT ??

    PROCEDURE process_omissions
      (    parameter: clt$parameter_value;
           change_list: ^oct$nlm_modification_list;
       VAR status: ost$status);


      VAR
        names: ^oct$names,
        i: integer,
        next_change: ^oct$nlm_modification_list,
        node: ^clt$data_value,
        number_of_names: clt$list_size,
        found: boolean,
        xdcl_list: oct$external_declaration_list,
        xdcl_before: ^oct$external_declaration_list;


      status.normal := TRUE;
      number_of_names := clp$count_list_elements (parameter.value);
      NEXT names: [1 .. number_of_names] IN ocv$olg_scratch_seq;
      IF (names = NIL) THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;
      node := parameter.value;
      FOR i := 1 TO number_of_names DO
        names^ [i] := node^.element_value^.program_name_value;
        node := node^.link;
      FOREND;

      next_change := change_list;

      WHILE (next_change <> NIL) DO
        xdcl_list.link := next_change^.nlm^.changed_info^.entry_points;

        FOR i := LOWERBOUND (names^) TO UPPERBOUND (names^) DO
          ocp$search_xdcl_list (names^ [i], ^xdcl_list, found, xdcl_before);
          IF NOT found THEN
            IF NOT multiple_modules THEN
              osp$set_status_abnormal (oc, oce$w_xdcl_doesnt_exist, names^ [i], status);
              ocp$generate_message (status);
              osp$set_status_condition (oce$e_some_attributes_not, command_status);
            IFEND;
          ELSE
            xdcl_before^.link^.name := osc$null_name;

            IF names^ [i] = next_change^.nlm^.changed_info^.starting_procedure THEN
              next_change^.nlm^.changed_info^.starting_procedure := osc$null_name;
            IFEND;
          IFEND;
        FOREND;

        next_change := next_change^.link;
      WHILEND;


    PROCEND process_omissions;
?? OLDTITLE ??
?? NEWTITLE := 'process_ep_attributes', EJECT ??

    PROCEDURE process_ep_attributes
      (    parameter: clt$parameter_value;
           attribute: llt$entry_point_attributes;
           kind_of_change: oct$attribute_change;
           change_list: ^oct$nlm_modification_list;
       VAR status: ost$status);


      VAR
        found: boolean,
        i: integer,
        names: ^oct$names,
        next_change: ^oct$nlm_modification_list,
        number_of_names: clt$list_size,
        xdcl_list: oct$external_declaration_list,
        x_dcl: ^oct$external_declaration_list,
        xdcl_before: ^oct$external_declaration_list;

      status.normal := TRUE;
      next_change := change_list;
      WHILE (next_change <> NIL) DO
        IF parameter.value^.kind = clc$keyword THEN

{ Add all names to the change list.

          xdcl_list.link := next_change^.nlm^.changed_info^.entry_points;
          x_dcl := xdcl_list.link;
          WHILE (x_dcl <> NIL) DO
            IF (kind_of_change = add_attribute) THEN
              x_dcl^.attributes := x_dcl^.attributes + attribute;
            ELSE
              x_dcl^.attributes := x_dcl^.attributes - attribute;
            IFEND;
            x_dcl := x_dcl^.link;
          WHILEND;
        ELSE

{ Get list of names to change.

          number_of_names := clp$count_list_elements (parameter.value);
          NEXT names: [1 .. number_of_names] IN ocv$olg_scratch_seq;
          IF (names = NIL) THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;
          node := parameter.value;
          FOR i := 1 TO number_of_names DO
            names^ [i] := node^.element_value^.program_name_value;
            node := node^.link;
          FOREND;
          xdcl_list.link := next_change^.nlm^.changed_info^.entry_points;

          FOR i := LOWERBOUND (names^) TO UPPERBOUND (names^) DO
            ocp$search_xdcl_list (names^ [i], ^xdcl_list, found, xdcl_before);
            IF NOT found THEN
              IF NOT multiple_modules THEN
                osp$set_status_abnormal (oc, oce$w_xdcl_doesnt_exist, names^ [i], status);
                ocp$generate_message (status);
                osp$set_status_condition (oce$e_some_attributes_not, command_status);
              IFEND;
            ELSE
              IF (kind_of_change = add_attribute) THEN
                xdcl_before^.link^.attributes := xdcl_before^.link^.attributes + attribute;
              ELSE
                xdcl_before^.link^.attributes := xdcl_before^.link^.attributes - attribute;
              IFEND;
            IFEND;
          FOREND;

        IFEND;
        next_change := next_change^.link;
      WHILEND;


    PROCEND process_ep_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'process_starting_procedure', EJECT ??

    PROCEDURE process_starting_procedure
      (    parameter: clt$parameter_value;
           change_list: ^oct$nlm_modification_list;
       VAR status: ost$status);


      VAR
        next_change: ^oct$nlm_modification_list,
        found: boolean,
        starting_procedure: pmt$program_name,
        xdcl_list: oct$external_declaration_list,
        xdcl_before: ^oct$external_declaration_list;

      status.normal := TRUE;
      next_change := change_list;
      starting_procedure := parameter.value^.program_name_value;
      WHILE (next_change <> NIL) DO
        xdcl_list.link := next_change^.nlm^.changed_info^.entry_points;

        ocp$search_xdcl_list (starting_procedure, ^xdcl_list, found, xdcl_before);
        IF NOT found THEN
          IF NOT multiple_modules THEN
            osp$set_status_abnormal (oc, oce$w_xdcl_doesnt_exist, starting_procedure, status);
            ocp$generate_message (status);
            osp$set_status_condition (oce$e_some_attributes_not, command_status);
          IFEND;
        ELSE
          next_change^.nlm^.changed_info^.starting_procedure := starting_procedure;
        IFEND;

        next_change := next_change^.link;
      WHILEND;


    PROCEND process_starting_procedure;
?? OLDTITLE ??
?? NEWTITLE := 'process_omit_non_retained_eps', EJECT ??

    PROCEDURE process_omit_non_retained_eps
      (    parameter: clt$parameter_value;
           change_list: ^oct$nlm_modification_list);

      VAR
        next_change: ^oct$nlm_modification_list,
        x_dcl: ^oct$external_declaration_list;

      IF (parameter.value^.boolean_value.value) THEN
        next_change := change_list;

        WHILE (next_change <> NIL) DO
          x_dcl := next_change^.nlm^.changed_info^.entry_points;

          WHILE (x_dcl <> NIL) DO
            IF (next_change^.nlm^.changed_info^.starting_procedure <> x_dcl^.name) THEN
              IF NOT (llc$retain_entry_point IN x_dcl^.attributes) THEN
                x_dcl^.name := osc$null_name;
              IFEND;
            IFEND;

            x_dcl := x_dcl^.link;
          WHILEND;

          next_change := next_change^.link;
        WHILEND;
      IFEND;


    PROCEND process_omit_non_retained_eps;
?? OLDTITLE ??
?? NEWTITLE := 'process_library_additions', EJECT ??

    PROCEDURE process_library_additions
      (    parameter: clt$parameter_value;
           change_list: ^oct$nlm_modification_list;
       VAR status: ost$status);


      VAR
        libraries: ^oct$names,
        next_change: ^oct$nlm_modification_list,
        i: integer,
        library_list: oct$name_list,
        library: ^oct$name_list,
        node: ^clt$data_value,
        number_of_libraries: clt$list_size;

      status.normal := TRUE;
      number_of_libraries := clp$count_list_elements (parameter.value);
      NEXT libraries: [1 .. number_of_libraries] IN ocv$olg_scratch_seq;
      IF (libraries = NIL) THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;
      node := parameter.value;
      FOR i := 1 TO number_of_libraries DO
        libraries^ [i] := node^.element_value^.name_value;
        node := node^.link;
      FOREND;
      next_change := change_list;

      WHILE (next_change <> NIL) DO
        library_list.link := next_change^.nlm^.changed_info^.library_list;

        FOR i := LOWERBOUND (libraries^) TO UPPERBOUND (libraries^) DO

          library := ^library_list;
          WHILE (library^.link <> NIL) AND (library^.link^.name <> libraries^ [i]) DO
            library := library^.link;
          WHILEND;

          IF library^.link = NIL THEN
            ALLOCATE library^.link IN ocv$olg_working_heap^;
            library := library^.link;
            IF library = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;

            library^.name := libraries^ [i];
            library^.link := NIL;
          IFEND;
        FOREND;

        next_change^.nlm^.changed_info^.new_libraries := TRUE;
        next_change^.nlm^.changed_info^.library_list := library_list.link;

        next_change := next_change^.link;
      WHILEND;


    PROCEND process_library_additions;
?? OLDTITLE ??
?? NEWTITLE := 'process_library_omissions', EJECT ??

    PROCEDURE process_library_omissions
      (    parameter: clt$parameter_value;
           change_list: ^oct$nlm_modification_list;
       VAR status: ost$status);


      VAR
        libraries: ^oct$names,
        next_change: ^oct$nlm_modification_list,
        i: integer,
        library_list: oct$name_list,
        library: ^oct$name_list,
        node: ^clt$data_value,
        number_of_libraries: clt$list_size;

      status.normal := TRUE;
      number_of_libraries := clp$count_list_elements (parameter.value);
      NEXT libraries: [1 .. number_of_libraries] IN ocv$olg_scratch_seq;
      IF (libraries = NIL) THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;
      node := parameter.value;
      FOR i := 1 TO number_of_libraries DO
        libraries^ [i] := node^.element_value^.name_value;
        node := node^.link;
      FOREND;
      next_change := change_list;

      WHILE (next_change <> NIL) DO
        library_list.link := next_change^.nlm^.changed_info^.library_list;

        FOR i := LOWERBOUND (libraries^) TO UPPERBOUND (libraries^) DO

          library := ^library_list;
          WHILE (library^.link <> NIL) AND (library^.link^.name <> libraries^ [i]) DO
            library := library^.link;
          WHILEND;

          IF library^.link = NIL THEN
            IF NOT multiple_modules THEN
              osp$set_status_abnormal (oc, oce$w_library_not_found, libraries^ [i], status);
              ocp$generate_message (status);
              osp$set_status_condition (oce$e_some_attributes_not, command_status);
            IFEND;
          ELSE
            library^.link := library^.link^.link;
          IFEND;
        FOREND;

        next_change^.nlm^.changed_info^.new_libraries := TRUE;
        next_change^.nlm^.changed_info^.library_list := library_list.link;

        next_change := next_change^.link;
      WHILEND;


    PROCEND process_library_omissions;
?? OLDTITLE ??
?? NEWTITLE := 'process_omit_debug_tables', EJECT ??

    PROCEDURE process_omit_debug_tables
      (    parameter: clt$parameter_value;
           change_list: ^oct$nlm_modification_list);

      VAR
        debug_tables_to_omit: oct$debug_tables,
        next_change: ^oct$nlm_modification_list,
        node: ^clt$data_value;

      debug_tables_to_omit := $oct$debug_tables [];
      IF parameter.value^.kind = clc$keyword THEN

{ Omit all debug tables.

        debug_tables_to_omit := -$oct$debug_tables [];
      ELSE
        node := parameter.value;
        WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
          IF node^.element_value^.keyword_value = 'LINE_TABLE' THEN
            debug_tables_to_omit := debug_tables_to_omit + $oct$debug_tables [occ$line_table];
          ELSEIF node^.element_value^.keyword_value = 'SYMBOL_TABLE' THEN
            debug_tables_to_omit := debug_tables_to_omit + $oct$debug_tables [occ$symbol_table];
          ELSEIF node^.element_value^.keyword_value = 'SUPPLEMENTAL_DEBUG_TABLE' THEN
            debug_tables_to_omit := debug_tables_to_omit + $oct$debug_tables [occ$supplemental_debug_table];
          ELSEIF node^.element_value^.keyword_value = 'PARAMETER_CHECKING' THEN
            debug_tables_to_omit := debug_tables_to_omit + $oct$debug_tables [occ$parameter_checking];
          IFEND;
          node := node^.link;
        WHILEND;
      IFEND;
      IF debug_tables_to_omit = $oct$debug_tables [] THEN
        RETURN;
      IFEND;
      next_change := change_list;

      WHILE (next_change <> NIL) DO
        next_change^.nlm^.changed_info^.debug_tables_to_omit :=
              next_change^.nlm^.changed_info^.debug_tables_to_omit + debug_tables_to_omit;

        next_change := next_change^.link;
      WHILEND;


    PROCEND process_omit_debug_tables;
?? OLDTITLE ??
?? NEWTITLE := 'process_comment', EJECT ??

    PROCEDURE process_comment
      (    parameter: clt$parameter_value;
           change_list: ^oct$nlm_modification_list;
       VAR status: ost$status);


      VAR
        next_change: ^oct$nlm_modification_list,
        nlm: ^oct$new_library_module_list;

      status.normal := TRUE;
      next_change := change_list;

      WHILE (next_change <> NIL) DO
        nlm := next_change^.nlm;

        IF nlm^.changed_info^.commentary = NIL THEN
          ALLOCATE nlm^.changed_info^.commentary IN ocv$olg_working_heap^;
          IF nlm^.changed_info^.commentary = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;
        IFEND;

        nlm^.changed_info^.commentary^ := parameter.value^.string_value^;

        next_change := next_change^.link;
      WHILEND;


    PROCEND process_comment;
?? OLDTITLE ??
?? NEWTITLE := 'process_application_identifier', EJECT ??

    PROCEDURE process_application_identifier
      (    parameter: clt$parameter_value;
           change_list: ^oct$nlm_modification_list;
       VAR status: ost$status);

      VAR
        next_change: ^oct$nlm_modification_list,
        nlm: ^oct$new_library_module_list;

      status.normal := TRUE;
      next_change := change_list;

      WHILE (next_change <> NIL) DO
        nlm := next_change^.nlm;

        CASE nlm^.description^.kind OF
        = occ$cpu_object_module, occ$load_module, occ$bound_module, occ$temporary_load_module,
              occ$program_description, occ$command_procedure, occ$command_description,
              occ$applic_command_procedure, occ$applic_program_description, occ$applic_command_description =
          ;
        ELSE
          osp$set_status_abnormal (oc, oce$cannot_be_an_application, nlm^.name, status);
          RETURN;
        CASEND;

        IF nlm^.changed_info^.application_identifier = NIL THEN
          ALLOCATE nlm^.changed_info^.application_identifier IN ocv$olg_working_heap^;
          IF nlm^.changed_info^.application_identifier = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;
        IFEND;

        IF pvt [p$application_identifier].value^.kind = clc$keyword THEN

{ Set application identifier to $unspecified.

          nlm^.changed_info^.application_identifier^.name := osc$null_name;
        ELSE
          nlm^.changed_info^.application_identifier^.name := parameter.value^.name_value;
        IFEND;

        next_change := next_change^.link;
      WHILEND;

    PROCEND process_application_identifier;
?? OLDTITLE ??
?? NEWTITLE := 'process_parameter_checking', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to process the CYBIL_PARAMETER_CHECKING
{   parameter.  It determines if the module(s) to be changed were generated
{   by CYBIL; if not, the module attributes are unchanged.

    PROCEDURE process_parameter_checking
      (    parameter: clt$parameter_value;
           change_list: ^oct$nlm_modification_list;
       VAR status: ost$status);

      VAR
        component_index: 1 .. llc$max_components,
        component_pointer: ^llt$component_information,
        file: ^SEQ ( * ),
        found_a_cybil_component: boolean,
        identification: ^llt$identification,
        information_element_header: ^llt$info_element_header,
        interpretive_element: ^llt$object_text_descriptor,
        next_change: ^oct$nlm_modification_list,
        nlm: ^oct$new_library_module_list;

      status.normal := TRUE;
      next_change := change_list;

      WHILE (next_change <> NIL) DO
        nlm := next_change^.nlm;

      /check_for_right_type_of_module/
        BEGIN
          CASE nlm^.description^.kind OF
          = occ$cpu_object_module =
            IF nlm^.description^.cpu_object_module_header^.identification^.generator_id <> llc$cybil THEN
              osp$set_status_abnormal (oc, oce$w_param_checking_not_cybil, nlm^.name, status);
              ocp$generate_message (status);
              osp$set_status_condition (oce$e_some_attributes_not, command_status);
              EXIT /check_for_right_type_of_module/;
            IFEND;
          = occ$load_module =
            information_element_header := #PTR (nlm^.description^.load_module_header^.information_element,
                  nlm^.description^.file^);
            IF information_element_header = NIL THEN
              osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, nlm^.name, status);
              RETURN;
            IFEND;
            IF information_element_header^.number_of_components = 0 THEN

{ Module is not bound; check identification record for generator.

              interpretive_element := #PTR (nlm^.description^.load_module_header^.interpretive_element,
                    nlm^.description^.file^);
              IF interpretive_element = NIL THEN
                osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, nlm^.name, status);
                RETURN;
              IFEND;
              IF interpretive_element^.kind <> llc$identification THEN
                osp$set_status_abnormal (oc, oce$e_no_ident_rec_on_load_mod, nlm^.name, status);
                RETURN;
              IFEND;
              file := nlm^.description^.file;
              RESET file TO interpretive_element;
              NEXT interpretive_element IN file;
              NEXT identification IN file;
              IF identification^.generator_id <> llc$cybil THEN
                osp$set_status_abnormal (oc, oce$w_param_checking_not_cybil, nlm^.name, status);
                ocp$generate_message (status);
                osp$set_status_condition (oce$e_some_attributes_not, command_status);
                EXIT /check_for_right_type_of_module/;
              IFEND;
            ELSE

{ Module is bound; check for a CYBIL component.

              found_a_cybil_component := FALSE;
              component_pointer := #PTR (information_element_header^.component_ptr, nlm^.description^.file^);
              IF component_pointer = NIL THEN
                osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, nlm^.name, status);
                RETURN;
              IFEND;

            /look_for_a_cybil_component/
              FOR component_index := 1 TO information_element_header^.number_of_components DO
                IF component_pointer^ [component_index].generator_id = llc$cybil THEN
                  found_a_cybil_component := TRUE;
                  EXIT /look_for_a_cybil_component/;
                IFEND;
              FOREND /look_for_a_cybil_component/;
              IF NOT found_a_cybil_component THEN
                osp$set_status_abnormal (oc, oce$w_param_checking_not_cybil, nlm^.name, status);
                ocp$generate_message (status);
                osp$set_status_condition (oce$e_some_attributes_not, command_status);
                EXIT /check_for_right_type_of_module/;
              IFEND;
            IFEND;
          = occ$bound_module =
            IF nlm^.description^.bound_module_header^.identification.generator_id <> llc$cybil THEN
              osp$set_status_abnormal (oc, oce$w_param_checking_not_cybil, nlm^.name, status);
              ocp$generate_message (status);
              osp$set_status_condition (oce$e_some_attributes_not, command_status);
              EXIT /check_for_right_type_of_module/;
            IFEND;
          = occ$temporary_load_module =
            IF nlm^.description^.temporary_module_header^.identification.generator_id <> llc$cybil THEN
              osp$set_status_abnormal (oc, oce$w_param_checking_not_cybil, nlm^.name, status);
              ocp$generate_message (status);
              osp$set_status_condition (oce$e_some_attributes_not, command_status);
              EXIT /check_for_right_type_of_module/;
            IFEND;
          ELSE
            osp$set_status_abnormal (oc, oce$w_param_checking_not_cybil, nlm^.name, status);
            ocp$generate_message (status);
            osp$set_status_condition (oce$e_some_attributes_not, command_status);
            EXIT /check_for_right_type_of_module/;
          CASEND;

          IF (parameter.value^.keyword_value = object_type_checking) THEN
            nlm^.changed_info^.cybil_parameter_checking := object_type_checking;
          IFEND;
        END /check_for_right_type_of_module/;

        next_change := next_change^.link;
      WHILEND;
    PROCEND process_parameter_checking;
?? OLDTITLE ??
?? EJECT ??

    VAR
      change_list: oct$nlm_modification_list,
      first_module: pmt$program_name,
      ignore_status: ost$status,
      last_module: pmt$program_name,
      multiple_modules: boolean,
      node: ^clt$data_value;

    status.normal := TRUE;
    command_status.normal := TRUE;
    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET ocv$olg_scratch_seq;

    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /protect/
    BEGIN
      multiple_modules := FALSE;
      change_list.link := NIL;
      IF pvt [p$module].value^.kind = clc$keyword THEN

{ Add all modules, if there are any, to the list of modules to change.

        IF ocv$nlm_list^.f_link^.name = osc$null_name THEN
          EXIT /protect/;
        ELSE
          multiple_modules := TRUE;
          first_module := ocv$nlm_list^.f_link^.name;
          last_module := ocv$nlm_list^.b_link^.name;
          add_modules_to_change_list (first_module, last_module, ^change_list, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
        IFEND;
      ELSE

{ Get lists of modules to change.

        node := pvt [p$module].value;
        WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
          IF node^.element_value^.kind = clc$range THEN
            first_module := node^.element_value^.low_value^.program_name_value;
            last_module := node^.element_value^.high_value^.program_name_value;
          ELSE
            first_module := node^.element_value^.program_name_value;
            last_module := first_module;
          IFEND;
          add_modules_to_change_list (first_module, last_module, ^change_list, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
          node := node^.link;
        WHILEND;
      IFEND;
      IF change_list.link = NIL THEN
        status := command_status;
        EXIT /protect/;
      ELSE
        multiple_modules := (change_list.link^.link <> NIL);
      IFEND;

      IF pvt [p$new_name].specified THEN
        change_module_name (pvt [p$new_name], change_list.link, status);
        IF NOT status.normal THEN
          EXIT /protect/;
        IFEND;
      IFEND;

      IF (pvt [p$substitute].specified) OR (pvt [p$omit].specified) OR
            (pvt [p$gate].specified) OR (pvt [p$not_gate].specified) OR (pvt [p$starting_procedure].
            specified) OR (pvt [p$retain].specified) OR (pvt [p$not_retain].specified) OR
            (pvt [p$omit_non_retained_entry_point].specified) THEN
        build_xdcl_lists (change_list.link, status);
        IF NOT status.normal THEN
          EXIT /protect/;
        IFEND;

        IF pvt [p$substitute].specified THEN
          process_substitutions (pvt [p$substitute], change_list.link, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
        IFEND;

        IF pvt [p$omit].specified THEN
          process_omissions (pvt [p$omit], change_list.link, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
        IFEND;

        IF pvt [p$gate].specified THEN
          process_ep_attributes (pvt [p$gate], $llt$entry_point_attributes [llc$gated_entry_point],
                add_attribute, change_list.link, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
        IFEND;

        IF pvt [p$not_gate].specified THEN
          process_ep_attributes (pvt [p$not_gate], $llt$entry_point_attributes [llc$gated_entry_point],
                remove_attribute, change_list.link, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
        IFEND;

        IF pvt [p$retain].specified THEN
          process_ep_attributes (pvt [p$retain], $llt$entry_point_attributes [llc$retain_entry_point],
                add_attribute, change_list.link, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
        IFEND;

        IF pvt [p$not_retain].specified THEN
          process_ep_attributes (pvt [p$not_retain], $llt$entry_point_attributes [llc$retain_entry_point],
                remove_attribute, change_list.link, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
        IFEND;

        IF pvt [p$starting_procedure].specified THEN
          process_starting_procedure (pvt [p$starting_procedure], change_list.link, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
        IFEND;

        IF pvt [p$omit_non_retained_entry_point].specified THEN
          process_omit_non_retained_eps (pvt [p$omit_non_retained_entry_point], change_list.link);
        IFEND;
      IFEND;


      IF (pvt [p$add_library].specified) OR (pvt [p$omit_library].specified) THEN
        build_library_lists (change_list.link, status);
        IF NOT status.normal THEN
          EXIT /protect/;
        IFEND;

        IF pvt [p$add_library].specified THEN
          process_library_additions (pvt [p$add_library], change_list.link, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
        IFEND;

        IF pvt [p$omit_library].specified THEN
          process_library_omissions (pvt [p$omit_library], change_list.link, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
        IFEND;
      IFEND;

      IF pvt [p$omit_debug_tables].specified THEN
        process_omit_debug_tables (pvt [p$omit_debug_tables], change_list.link);
      IFEND;

      IF pvt [p$comment].specified THEN
        process_comment (pvt [p$comment], change_list.link, status);
        IF NOT status.normal THEN
          EXIT /protect/;
        IFEND;
      IFEND;

      IF pvt [p$application_identifier].specified THEN
        avp$get_capability (avc$application_administration, avc$user, application_administrator, status);
        IF NOT status.normal THEN
          EXIT /protect/;
        ELSEIF NOT application_administrator THEN
          osp$set_status_condition (oce$not_application_administrtr, status);
          EXIT /protect/;
        ELSE
          process_application_identifier (pvt [p$application_identifier], change_list.link, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
        IFEND;
      IFEND;

      IF pvt [p$cybil_parameter_checking].specified THEN
        process_parameter_checking (pvt [p$cybil_parameter_checking], change_list.link, status);
        IF NOT status.normal THEN
          EXIT /protect/;
        IFEND;
      IFEND;
      status := command_status;
    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);


  PROCEND ocp$_change_module_attribute;

MODEND ocm$change;
*DECK DECK=OCM$CHANGE_COMMAND_DESCRIPTION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Management: Change Command Description' ??
MODULE ocm$change_command_description;

{
{ PURPOSE:
{   Change a command description on an object library.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc llt$command_description
*copyc oce$library_generator_errors
*copyc oct$new_library_module_list
*copyc ost$status
?? POP ??
*copyc avp$get_capability
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc i#current_sequence_position
*copyc ocp$close_all_open_files
*copyc ocp$initialize_olg_working_heap
*copyc ocp$search_nlm_tree
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_date
*copyc pmp$get_time
*copyc ocv$olg_scratch_seq
*copyc ocv$olg_working_heap
*copyc ocv$open_file_list
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$_change_command_description', EJECT ??

  PROCEDURE [XDCL] ocp$_change_command_description
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$creol_chacd) change_command_description,
{      change_command_descriptions, chacd (
{   name, names, n: list of name = $required
{   starting_procedure, sp: (BY_NAME) program_name = $optional
{   library, l: (BY_NAME) any of
{       key
{         $unspecified, osf$current_library
{       keyend
{       file
{       string
{     anyend = $optional
{   system_command_name, scn: (BY_NAME) name = $optional
{   availability, a: (BY_NAME) key
{       (normal_usage, nu)
{       (advanced_usage, au)
{       (hidden, h)
{     keyend = $optional
{   scope, s: (BY_NAME) key
{       (xdcl, x)
{       (gate, g)
{       (local, l)
{     keyend = $optional
{   log_option, lo: (BY_NAME) key
{       (automatic, a)
{       (manual, m)
{     keyend = $optional
{   application_identifier, ai: (BY_NAME, ADVANCED) any of
{       key
{         $unspecified
{       keyend
{       name
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 18] of clt$pdt_parameter_name,
      parameters: array [1 .. 9] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type8: 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$name_type_qualifier,
        recend,
      recend,
      type9: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 9, 12, 14, 58, 13, 214],
    clc$command, 18, 9, 1, 1, 0, 0, 9, 'OCM$CREOL_CHACD'], [
    ['A                              ',clc$abbreviation_entry, 5],
    ['AI                             ',clc$abbreviation_entry, 8],
    ['APPLICATION_IDENTIFIER         ',clc$nominal_entry, 8],
    ['AVAILABILITY                   ',clc$nominal_entry, 5],
    ['L                              ',clc$abbreviation_entry, 3],
    ['LIBRARY                        ',clc$nominal_entry, 3],
    ['LO                             ',clc$abbreviation_entry, 7],
    ['LOG_OPTION                     ',clc$nominal_entry, 7],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['S                              ',clc$abbreviation_entry, 6],
    ['SCN                            ',clc$abbreviation_entry, 4],
    ['SCOPE                          ',clc$nominal_entry, 6],
    ['SP                             ',clc$abbreviation_entry, 2],
    ['STARTING_PROCEDURE             ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 9],
    ['SYSTEM_COMMAND_NAME            ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 21, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 116, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [3, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$program_name_type]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type,
    clc$string_type],
    FALSE, 3],
    81, [[1, 0, clc$keyword_type], [2], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['OSF$CURRENT_LIBRARY            ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    3, [[1, 0, clc$file_type]],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [6], [
    ['ADVANCED_USAGE                 ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['AU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['H                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['HIDDEN                         ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['NORMAL_USAGE                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['NU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [6], [
    ['G                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['GATE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['LOCAL                          ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['X                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['XDCL                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 7
    [[1, 0, clc$keyword_type], [4], [
    ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['AUTOMATIC                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['M                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['MANUAL                         ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 9
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$starting_procedure = 2,
      p$library = 3,
      p$system_command_name = 4,
      p$availability = 5,
      p$scope = 6,
      p$log_option = 7,
      p$application_identifier = 8,
      p$status = 9;

    VAR
      pvt: array [1 .. 9] of clt$parameter_value;

    CONST
      unspecified = '$UNSPECIFIED';

    VAR
      application_administrator: boolean,
      date: ost$date,
      ignore_status: ost$status,
      member: ^SEQ ( * ),
      member_size: ost$segment_length,
      module_description: ^oct$module_description,
      module_does_exist: boolean,
      name: clt$command_name,
      name_node: ^clt$data_value,
      new_alias_list: ^pmt$module_list,
      new_applic_command_header: ^llt$application_member_header,
      new_application_identifier: ^llt$application_identifier,
      new_command_description_content: ^llt$command_desc_contents,
      new_command_description_header: ^llt$library_member_header,
      new_library_parameter: ^fst$file_reference,
      new_library_path: ^fst$file_reference,
      nlm: ^oct$new_library_module_list,
      old_alias_list: ^pmt$module_list,
      old_application_identifier: ^llt$application_identifier,
      old_command_description_content: ^llt$command_desc_contents,
      old_command_description_header: ^llt$library_member_header,
      old_library_path: ^fst$file_reference,
      old_member: ^SEQ ( * ),
      old_seq: ^SEQ ( * ),
      sequence: ^SEQ ( * ),
      size: ost$segment_length,
      time: ost$time;

    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler;

?? NEWTITLE := 'check_parameters', EJECT ??

{
{ This "check parameters procedure" verifies that command description
{ parameters specify information for either a "normal" command description
{ or a "system command description" but not both.
{

    PROCEDURE check_parameters
      (    pvt: ^clt$parameter_value_table;
           ignore_which_parameter: clt$which_parameter;
       VAR status: ost$status);


      status.normal := TRUE;

      IF pvt^ [p$system_command_name].specified AND (pvt^ [p$starting_procedure].
            specified OR pvt^ [p$library].specified) THEN
        osp$set_status_condition (oce$e_bad_command_desc_params, status);
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$application_identifier].specified THEN
      avp$get_capability (avc$application_administration, avc$user, application_administrator, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF NOT application_administrator THEN
        osp$set_status_condition (oce$not_application_administrtr, status);
        RETURN;
      IFEND;
    IFEND;

    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];
    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /protect/
    BEGIN
      name_node := pvt [p$name].value;
      WHILE (name_node <> NIL) AND (name_node^.element_value <> NIL) DO
        name := name_node^.element_value^.name_value;

        ocp$search_nlm_tree (name, nlm, module_does_exist);
        IF NOT module_does_exist THEN
          osp$set_status_abnormal ('OC', oce$w_module_not_found, name, status);
          EXIT /protect/;
        IFEND;
        CASE nlm^.description^.kind OF
        = occ$command_description =
          old_command_description_header := nlm^.description^.command_description_header;
          old_application_identifier := NIL;
        = occ$applic_command_description =
          old_command_description_header := ^nlm^.description^.applic_command_description_hdr^.
                library_member_header;
          old_application_identifier := ^nlm^.description^.applic_command_description_hdr^.
                application_identifier;
        ELSE
          osp$set_status_abnormal ('OC', oce$e_module_not_a_command_desc, name, status);
          EXIT /protect/;
        CASEND;

        old_seq := nlm^.description^.file;
        RESET ocv$olg_scratch_seq;

        NEXT new_command_description_header IN ocv$olg_scratch_seq;
        IF new_command_description_header = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;

        new_command_description_header^ := old_command_description_header^;

{   Since an APPLICATION COMMAND DESCRIPTION is a record of:
{                llt$library_member_header,
{                llt$application_identifier,
{ processing of the APPLICATION_IDENTIFIER parameter must be done first after the
{ command description is set up so that the application identifier (llt$application_identifier)
{ immediately follows the command description (llt$library_member_header) in OCV$OLG_SCRATCH_SEQ.

        new_application_identifier := NIL;
        IF pvt [p$application_identifier].specified THEN
          IF pvt [p$application_identifier].value^.kind = clc$keyword {AND keyword = unspecified} THEN
            new_command_description_header^.kind := llc$command_description;
          ELSE {clc$name}
            NEXT new_application_identifier IN ocv$olg_scratch_seq;
            IF new_application_identifier = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;
            new_application_identifier^.name := pvt [p$application_identifier].value^.name_value;
            new_command_description_header^.kind := llc$applic_command_description;
          IFEND;
        ELSEIF old_application_identifier <> NIL THEN
          NEXT new_application_identifier IN ocv$olg_scratch_seq;
          IF new_application_identifier = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;
          new_application_identifier^.name := old_application_identifier^.name;
        IFEND;

        IF new_command_description_header^.number_of_aliases <> 0 THEN
          old_alias_list := #PTR (old_command_description_header^.aliases, old_seq^);
          NEXT new_alias_list: [1 .. new_command_description_header^.number_of_aliases] IN
                ocv$olg_scratch_seq;
          IF new_alias_list = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, name, status);
            EXIT /protect/;
          IFEND;
          new_alias_list^ := old_alias_list^;
        IFEND;

        old_member := #PTR (old_command_description_header^.member, old_seq^);
        RESET old_member;
        NEXT old_command_description_content IN old_member;
        IF old_command_description_content = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        NEXT new_command_description_content IN ocv$olg_scratch_seq;
        IF new_command_description_content = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        new_command_description_content^ := old_command_description_content^;

        IF pvt [p$system_command_name].specified THEN
          new_command_description_content^.system_command := TRUE;
          new_command_description_content^.system_command_name :=
                pvt [p$system_command_name].value^.name_value;

        ELSE
          IF pvt [p$starting_procedure].specified THEN
            new_command_description_content^.system_command := FALSE;
            new_command_description_content^.starting_procedure :=
                  pvt [p$starting_procedure].value^.program_name_value;
          IFEND;

          IF old_command_description_content^.system_command THEN
            PUSH old_library_path: [0];
          ELSE
            NEXT old_library_path: [old_command_description_content^.library_path_size] IN old_member;
            IF old_library_path = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;
          IFEND;

          IF pvt [p$library].specified THEN
            IF old_command_description_content^.system_command AND (NOT pvt [p$starting_procedure].specified)
                  THEN
              osp$set_status_condition (oce$e_bad_command_desc_params, status);
              EXIT /protect/;
            IFEND;
            CASE pvt [p$library].value^.kind OF
            = clc$keyword =
              IF pvt [p$library].value^.keyword_value = unspecified THEN
                PUSH new_library_parameter: [0];
              ELSE {OSF$CURRENT_LIBRARY}
                new_library_parameter := ^pvt [p$library].value^.keyword_value;
              IFEND;
            = clc$file =
              new_library_parameter := pvt [p$library].value^.file_value;
            ELSE {clc$string}
              new_library_parameter := pvt [p$library].value^.string_value;
            CASEND;
            IF STRLENGTH (new_library_parameter^) >= fsc$max_path_size THEN
              new_command_description_content^.library_path_size := fsc$max_path_size;
            ELSE
              new_command_description_content^.library_path_size := STRLENGTH (new_library_parameter^);
            IFEND;
            NEXT new_library_path: [new_command_description_content^.library_path_size] IN
                  ocv$olg_scratch_seq;
            IF new_library_path = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;
            new_library_path^ := new_library_parameter^;

          ELSEIF STRLENGTH (old_library_path^) > 0 THEN
            NEXT new_library_path: [STRLENGTH (old_library_path^)] IN ocv$olg_scratch_seq;
            IF new_library_path = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;
            new_library_path^ := old_library_path^;
          IFEND;
        IFEND;

        IF pvt [p$availability].specified THEN
          IF pvt [p$availability].value^.keyword_value = 'NORMAL_USAGE' THEN
            new_command_description_header^.command_function_availability := clc$normal_usage_entry;
          ELSEIF pvt [p$availability].value^.keyword_value = 'ADVANCED_USAGE' THEN
            new_command_description_header^.command_function_availability := clc$advanced_usage_entry;
          ELSE {HIDDEN}
            new_command_description_header^.command_function_availability := clc$hidden_entry;
          IFEND;
        IFEND;

        IF pvt [p$scope].specified THEN
          IF pvt [p$scope].value^.keyword_value = 'XDCL' THEN
            new_command_description_header^.command_function_kind := llc$entry_point;
          ELSEIF pvt [p$scope].value^.keyword_value = 'GATE' THEN
            new_command_description_header^.command_function_kind := llc$gate;
          ELSE {LOCAL}
            new_command_description_header^.command_function_kind := llc$local_to_library;
          IFEND;
        IFEND;

        IF pvt [p$log_option].specified THEN
          IF pvt [p$log_option].value^.keyword_value = 'AUTOMATIC' THEN
            new_command_description_header^.command_log_option := clc$automatically_log;
          ELSE {MANUAL}
            new_command_description_header^.command_log_option := clc$manually_log;
          IFEND;
        IFEND;

        pmp$get_time (osc$hms_time, time, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        pmp$get_date (osc$mdy_date, date, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        new_command_description_header^.time_created := time;
        new_command_description_header^.date_created := date;

        ALLOCATE module_description IN ocv$olg_working_heap^;
        IF module_description = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;

        module_description^.name := new_command_description_header^.name;
        module_description^.source := occ$current;
        IF new_application_identifier = NIL THEN
          module_description^.kind := occ$command_description;
        ELSE
          module_description^.kind := occ$applic_command_description;
        IFEND;

        size := i#current_sequence_position (ocv$olg_scratch_seq);
        RESET ocv$olg_scratch_seq;

        ALLOCATE module_description^.file: [[REP size OF cell]] IN ocv$olg_working_heap^;
        IF module_description^.file = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;

        IF #SEGMENT (nlm^.description^.file) = #SEGMENT (ocv$olg_working_heap) THEN
          FREE nlm^.description^.file IN ocv$olg_working_heap^;
        IFEND;
        nlm^.description := module_description;
        nlm^.description^.file := module_description^.file;

        RESET module_description^.file;

        IF new_application_identifier = NIL THEN
          NEXT module_description^.command_description_header IN module_description^.file;
          NEXT new_command_description_header IN ocv$olg_scratch_seq;
          module_description^.command_description_header^ := new_command_description_header^;
          IF module_description^.command_description_header^.number_of_aliases <> 0 THEN
            NEXT new_alias_list: [1 .. module_description^.command_description_header^.number_of_aliases] IN
                  module_description^.file;
            module_description^.command_description_header^.aliases :=
                  #REL (new_alias_list, module_description^.file^);
            NEXT old_alias_list: [1 .. module_description^.command_description_header^.number_of_aliases] IN
                  ocv$olg_scratch_seq;
            new_alias_list^ := old_alias_list^;
          IFEND;
        ELSE
          NEXT module_description^.applic_command_description_hdr IN module_description^.file;
          NEXT new_applic_command_header IN ocv$olg_scratch_seq;
          module_description^.applic_command_description_hdr^ := new_applic_command_header^;
          IF module_description^.applic_command_description_hdr^.library_member_header.number_of_aliases <>
                0 THEN
            NEXT new_alias_list: [1 .. module_description^.applic_command_description_hdr^.
                  library_member_header.number_of_aliases] IN module_description^.file;
            module_description^.applic_command_description_hdr^.library_member_header.aliases :=
                  #REL (new_alias_list, module_description^.file^);

            NEXT old_alias_list: [1 .. module_description^.applic_command_description_hdr^.
                  library_member_header.number_of_aliases] IN ocv$olg_scratch_seq;
            new_alias_list^ := old_alias_list^;
          IFEND;
        IFEND;

        member_size := size - i#current_sequence_position (module_description^.file);
        NEXT member: [[REP member_size OF cell]] IN module_description^.file;
        IF new_application_identifier = NIL THEN
          module_description^.command_description_header^.member := #REL (member, module_description^.file^);
          module_description^.command_description_header^.member_size := member_size;
        ELSE
          module_description^.applic_command_description_hdr^.library_member_header.member :=
                #REL (member, module_description^.file^);
          module_description^.applic_command_description_hdr^.library_member_header.member_size :=
                member_size;
        IFEND;

        NEXT sequence: [[REP member_size OF cell]] IN ocv$olg_scratch_seq;
        member^ := sequence^;
        name_node := name_node^.link;
      WHILEND;

    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);

  PROCEND ocp$_change_command_description;

MODEND ocm$change_command_description
*DECK DECK=OCM$CHANGE_FUNCTION_DESCRIPTION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Management: Change Function Description' ??
MODULE ocm$change_function_description;

{
{ PURPOSE:
{   To change a function description on an object library.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$function_name
*copyc clt$parameter_list
*copyc llt$function_description
*copyc oce$library_generator_errors
*copyc oct$new_library_module_list
*copyc ost$status
?? POP ??
*copyc avp$get_capability
*copyc clp$evaluate_parameters
*copyc i#current_sequence_position
*copyc ocp$close_all_open_files
*copyc ocp$initialize_olg_working_heap
*copyc ocp$search_nlm_tree
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_date
*copyc pmp$get_time
*copyc ocv$olg_scratch_seq
*copyc ocv$olg_working_heap
*copyc ocv$open_file_list
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$_change_function_descriptio', EJECT ??

  PROCEDURE [XDCL] ocp$_change_function_descriptio
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$creol_chafd) change_function_description,
{      change_function_descriptions, chafd (
{   name, names, n: any of
{       data_name
{       list of data_name
{     anyend = $required
{   starting_procedure, sp: (BY_NAME) program_name = $optional
{   library, l: (BY_NAME) any of
{       key
{         $unspecified, osf$current_library
{       keyend
{       file
{       string
{     anyend = $optional
{   availability, a: (BY_NAME) key
{       (normal_usage, nu)
{       (advanced_usage, au)
{       (hidden, h)
{     keyend = $optional
{   scope, s: (BY_NAME) key
{       (xdcl, x)
{       (gate, g)
{       (local, l)
{     keyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 12] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 9, 12, 15, 22, 28, 894],
    clc$command, 12, 6, 1, 0, 0, 0, 6, 'OCM$CREOL_CHAFD'], [
    ['A                              ',clc$abbreviation_entry, 4],
    ['AVAILABILITY                   ',clc$nominal_entry, 4],
    ['L                              ',clc$abbreviation_entry, 3],
    ['LIBRARY                        ',clc$nominal_entry, 3],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['S                              ',clc$abbreviation_entry, 5],
    ['SCOPE                          ',clc$nominal_entry, 5],
    ['SP                             ',clc$abbreviation_entry, 2],
    ['STARTING_PROCEDURE             ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 42, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 116, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$data_name_type,
    clc$list_type],
    FALSE, 2],
    3, [[1, 0, clc$data_name_type]],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$data_name_type]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$program_name_type]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type,
    clc$string_type],
    FALSE, 3],
    81, [[1, 0, clc$keyword_type], [2], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['OSF$CURRENT_LIBRARY            ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    3, [[1, 0, clc$file_type]],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [6], [
    ['ADVANCED_USAGE                 ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['AU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['H                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['HIDDEN                         ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['NORMAL_USAGE                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['NU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [6], [
    ['G                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['GATE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['LOCAL                          ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['X                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['XDCL                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$starting_procedure = 2,
      p$library = 3,
      p$availability = 4,
      p$scope = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    CONST
      unspecified = '$UNSPECIFIED';

    VAR
      date: ost$date,
      ignore_status: ost$status,
      member: ^SEQ ( * ),
      member_size: ost$segment_length,
      module_description: ^oct$module_description,
      module_does_exist: boolean,
      name: clt$function_name,
      name_node: ^clt$data_value,
      new_alias_list: ^pmt$module_list,
      new_function_desc_contents: ^llt$function_desc_contents,
      new_function_description_header: ^llt$library_member_header,
      new_library_parameter: ^fst$file_reference,
      new_library_path: ^fst$file_reference,
      nlm: ^oct$new_library_module_list,
      old_alias_list: ^pmt$module_list,
      old_function_desc_contents: ^llt$function_desc_contents,
      old_function_description_header: ^llt$library_member_header,
      old_library_path: ^fst$file_reference,
      old_member: ^SEQ ( * ),
      old_seq: ^SEQ ( * ),
      sequence: ^SEQ ( * ),
      size: ost$segment_length,
      time: ost$time;

    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];
    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /protect/
    BEGIN

      IF pvt [p$name].value^.kind = clc$list THEN
        name_node := pvt [p$name].value;
      ELSE
        PUSH name_node;
        name_node^.kind := clc$list;
        name_node^.element_value := pvt [p$name].value;
        name_node^.link := NIL;
        name_node^.generated_via_list_rest := FALSE;
      IFEND;
      WHILE (name_node <> NIL) DO
        name := name_node^.element_value^.data_name_value;

        ocp$search_nlm_tree (name, nlm, module_does_exist);
        IF NOT module_does_exist THEN
          osp$set_status_abnormal ('OC', oce$w_module_not_found, name, status);
          EXIT /protect/;
        ELSEIF nlm^.description^.kind <> occ$function_description THEN
          osp$set_status_abnormal ('OC', oce$e_module_not_a_func_desc, name, status);
          EXIT /protect/;
        IFEND;
        old_function_description_header := nlm^.description^.function_description_header;

        old_seq := nlm^.description^.file;
        RESET ocv$olg_scratch_seq;


        NEXT new_function_description_header IN ocv$olg_scratch_seq;
        IF new_function_description_header = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;

        new_function_description_header^ := old_function_description_header^;

        IF new_function_description_header^.number_of_aliases <> 0 THEN
          old_alias_list := #PTR (old_function_description_header^.aliases, old_seq^);
          NEXT new_alias_list: [1 .. new_function_description_header^.number_of_aliases] IN
                ocv$olg_scratch_seq;
          IF new_alias_list = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, name, status);
            EXIT /protect/;
          IFEND;
          new_alias_list^ := old_alias_list^;
        IFEND;

        old_member := #PTR (old_function_description_header^.member, old_seq^);
        RESET old_member;
        NEXT old_function_desc_contents IN old_member;
        IF old_function_desc_contents = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        NEXT new_function_desc_contents IN ocv$olg_scratch_seq;
        IF new_function_desc_contents = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        new_function_desc_contents^ := old_function_desc_contents^;

        IF pvt [p$starting_procedure].specified THEN
          new_function_desc_contents^.starting_procedure := pvt [p$starting_procedure].value^.
                program_name_value;
        IFEND;

        NEXT old_library_path: [old_function_desc_contents^.library_path_size] IN old_member;
        IF old_library_path = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        IF pvt [p$library].specified THEN
          CASE pvt [p$library].value^.kind OF
          = clc$keyword =
            IF pvt [p$library].value^.keyword_value = unspecified THEN
              PUSH new_library_parameter: [0];
            ELSE {OSF$CURRENT_LIBRARY}
              new_library_parameter := ^pvt [p$library].value^.keyword_value;
            IFEND;
          = clc$file =
            new_library_parameter := pvt [p$library].value^.file_value;
          ELSE {clc$string}
            new_library_parameter := pvt [p$library].value^.string_value;
          CASEND;
          IF STRLENGTH (new_library_parameter^) >= fsc$max_path_size THEN
            new_function_desc_contents^.library_path_size := fsc$max_path_size;
          ELSE
            new_function_desc_contents^.library_path_size := STRLENGTH (new_library_parameter^);
          IFEND;
          NEXT new_library_path: [new_function_desc_contents^.library_path_size] IN ocv$olg_scratch_seq;
          IF new_library_path = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;
          new_library_path^ := new_library_parameter^;
        ELSEIF old_function_desc_contents^.library_path_size > 0 THEN
          NEXT new_library_path: [old_function_desc_contents^.library_path_size] IN ocv$olg_scratch_seq;
          IF new_library_path = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;
          new_library_path^ := old_library_path^;
        IFEND;

        IF pvt [p$availability].specified THEN
          IF pvt [p$availability].value^.keyword_value = 'NORMAL_USAGE' THEN
            new_function_description_header^.command_function_availability := clc$normal_usage_entry;
          ELSEIF pvt [p$availability].value^.keyword_value = 'ADVANCED_USAGE' THEN
            new_function_description_header^.command_function_availability := clc$advanced_usage_entry;
          ELSE {HIDDEN}
            new_function_description_header^.command_function_availability := clc$hidden_entry;
          IFEND;
        IFEND;

        IF pvt [p$scope].specified THEN
          IF pvt [p$scope].value^.keyword_value = 'XDCL' THEN
            new_function_description_header^.command_function_kind := llc$entry_point;
          ELSEIF pvt [p$scope].value^.keyword_value = 'GATE' THEN
            new_function_description_header^.command_function_kind := llc$gate;
          ELSE {LOCAL}
            new_function_description_header^.command_function_kind := llc$local_to_library;
          IFEND;
        IFEND;

        pmp$get_time (osc$hms_time, time, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        pmp$get_date (osc$mdy_date, date, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        new_function_description_header^.time_created := time;
        new_function_description_header^.date_created := date;

        ALLOCATE module_description IN ocv$olg_working_heap^;
        IF module_description = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;

        module_description^.name := new_function_description_header^.name;
        module_description^.source := occ$current;
        module_description^.kind := occ$function_description;

        size := i#current_sequence_position (ocv$olg_scratch_seq);
        RESET ocv$olg_scratch_seq;

        ALLOCATE module_description^.file: [[REP size OF cell]] IN ocv$olg_working_heap^;
        IF module_description^.file = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;

        IF #SEGMENT (nlm^.description^.file) = #SEGMENT (ocv$olg_working_heap) THEN
          FREE nlm^.description^.file IN ocv$olg_working_heap^;
        IFEND;
        nlm^.description := module_description;
        nlm^.description^.file := module_description^.file;

        RESET module_description^.file;

        NEXT module_description^.function_description_header IN module_description^.file;
        NEXT new_function_description_header IN ocv$olg_scratch_seq;
        module_description^.function_description_header^ := new_function_description_header^;
        IF module_description^.function_description_header^.number_of_aliases <> 0 THEN
          NEXT new_alias_list: [1 .. module_description^.function_description_header^.number_of_aliases] IN
                module_description^.file;
          module_description^.function_description_header^.aliases :=
                #REL (new_alias_list, module_description^.file^);
          NEXT old_alias_list: [1 .. module_description^.function_description_header^.number_of_aliases] IN
                ocv$olg_scratch_seq;
          new_alias_list^ := old_alias_list^;
        IFEND;

        member_size := size - i#current_sequence_position (module_description^.file);
        NEXT member: [[REP member_size OF cell]] IN module_description^.file;
        module_description^.function_description_header^.member := #REL (member, module_description^.file^);
        module_description^.function_description_header^.member_size := member_size;

        NEXT sequence: [[REP member_size OF cell]] IN ocv$olg_scratch_seq;
        member^ := sequence^;
        name_node := name_node^.link;
      WHILEND;

    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);

  PROCEND ocp$_change_function_descriptio;

MODEND ocm$change_function_description
*DECK DECK=OCM$CHANGE_PROGRAM_DESCRIPTION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Maintenance: Change Program Description' ??
MODULE ocm$change_program_description;

{
{ PURPOSE:
{   To change a program description on an object library.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc llt$program_description
*copyc oce$library_generator_errors
*copyc oct$new_library_module_list
*copyc ost$status
?? POP ??
*copyc avp$get_capability
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc i#current_sequence_position
*copyc ocp$close_all_open_files
*copyc ocp$initialize_olg_working_heap
*copyc ocp$search_nlm_tree
*copyc ocv$olg_scratch_seq
*copyc ocv$olg_working_heap
*copyc ocv$open_file_list
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_date
*copyc pmp$get_time
?? OLDTITLE ??
?? NEWTITLE := 'ocp$_change_program_description', EJECT ??

  PROCEDURE [XDCL] ocp$_change_program_description
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (ocm$creol_chapd) change_program_description, chapd (
{    name, names, n: list of program_name = $required
{    file, files, f, object_files: any of
{        key
{          $unspecified
{        keyend
{        list of any of
{          file
{          string
{        anyend
{      anyend = $optional
{    library, libraries, l: any of
{        key
{          $unspecified
{        keyend
{        list of any of
{          key
{            osf$task_services_library, osf$current_library
{          keyend
{          file
{          string
{        anyend
{      anyend = $optional
{    module, modules, m: any of
{        key
{          $unspecified
{        keyend
{        list of program_name
{      anyend = $optional
{    starting_procedure, sp: any of
{        key
{          $unspecified
{        keyend
{        program_name
{      anyend = $optional
{    load_map, lm: (BY_NAME) any of
{        key
{          $unspecified
{        keyend
{        file
{        string
{      anyend = $optional
{    load_map_option, load_map_options, lmo: (BY_NAME) any of
{        key
{          $unspecified, all, none
{        keyend
{        list of key
{          (segment, s)
{          (block, b)
{          (entry_point, ep)
{          (cross_reference, cr, xref)
{        keyend
{      anyend = $optional
{    termination_error_level, tel: (BY_NAME) key
{        $unspecified
{        (warning, w)
{        (error, e)
{        (fatal, f)
{      keyend = $optional
{    preset_value, pv: (BY_NAME) key
{        $unspecified
{        (zero, z)
{        (infinity, i)
{        (floating_point_indefinite, fpi)
{        (alternate_ones, ao)
{      keyend = $optional
{    stack_size, ss: (BY_NAME) any of
{        key
{          $unspecified
{        keyend
{        integer 0..osc$max_segment_length
{      anyend = $optional
{    abort_file, af: (BY_NAME) any of
{        key
{          $unspecified
{        keyend
{        file
{        string
{      anyend = $optional
{    debug_input, di: (BY_NAME) any of
{        key
{          $unspecified
{        keyend
{        file
{        string
{      anyend = $optional
{    debug_output, do: (BY_NAME) any of
{        key
{          $unspecified
{        keyend
{        file
{        string
{      anyend = $optional
{    debug_mode, dm: (BY_NAME) any of
{        key
{          $unspecified
{        keyend
{        boolean
{      anyend = $optional
{    availability, a: (BY_NAME) key
{        (normal_usage, a, advertised, nu)
{        (advanced_usage, au)
{        (hidden, h)
{      keyend = $optional
{    scope, s: (BY_NAME) key
{        (xdcl, x)
{        (gate, g)
{        (local, l)
{      keyend = $optional
{    log_option, lo: (BY_NAME) key
{        (automatic, a)
{        (manual, m)
{      keyend = $optional
{    application_identifier, ai: (BY_NAME, ADVANCED) any of
{        key
{          $unspecified
{        keyend
{        name
{      anyend = $optional
{    arithmetic_overflow, ao: (BY_NAME, ADVANCED) any of
{        key
{          $unspecified
{        keyend
{        boolean
{      anyend = $optional
{    arithmetic_loss_of_significance, alos: (BY_NAME, ADVANCED) any of
{        key
{          $unspecified
{        keyend
{        boolean
{      anyend = $optional
{    divide_fault, df: (BY_NAME, ADVANCED) any of
{        key
{          $unspecified
{        keyend
{        boolean
{      anyend = $optional
{    exponent_overflow, eo: (BY_NAME, ADVANCED) any of
{        key
{          $unspecified
{        keyend
{        boolean
{      anyend = $optional
{    exponent_underflow, eu: (BY_NAME, ADVANCED) any of
{        key
{          $unspecified
{        keyend
{        boolean
{      anyend = $optional
{    fp_indefinite, fpi, fi: (BY_NAME, ADVANCED) any of
{        key
{          $unspecified
{        keyend
{        boolean
{      anyend = $optional
{    fp_loss_of_significance, fplos, flos: (BY_NAME, ADVANCED) any of
{        key
{          $unspecified
{        keyend
{        boolean
{      anyend = $optional
{    invalid_bdp_data, ibdpd, ibd: (BY_NAME, ADVANCED) any of
{        key
{          $unspecified
{        keyend
{        boolean
{      anyend = $optional
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 62] of clt$pdt_parameter_name,
      parameters: array [1 .. 27] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: 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$union_type_qualifier,
            type_size_1: clt$type_specification_size,
            element_type_spec_1: record
              header: clt$type_specification_header,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$string_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type3: 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$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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
            recend,
            type_size_3: clt$type_specification_size,
            element_type_spec_3: record
              header: clt$type_specification_header,
              qualifier: clt$string_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type4: 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,
          recend,
        recend,
      recend,
      type5: 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,
        recend,
      recend,
      type6: 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,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type7: 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 .. 3] 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 .. 9] of clt$keyword_specification,
          recend,
        recend,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 7] of clt$keyword_specification,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 9] of clt$keyword_specification,
      recend,
      type10: 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$integer_type_qualifier,
        recend,
      recend,
      type11: 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,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type12: 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,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type13: 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,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type14: 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,
        recend,
      recend,
      type15: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type17: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type18: 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$name_type_qualifier,
        recend,
      recend,
      type19: 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,
        recend,
      recend,
      type20: 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,
        recend,
      recend,
      type21: 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,
        recend,
      recend,
      type22: 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,
        recend,
      recend,
      type23: 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,
        recend,
      recend,
      type24: 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,
        recend,
      recend,
      type25: 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,
        recend,
      recend,
      type26: 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,
        recend,
      recend,
      type27: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 3, 20, 12, 7, 7, 728],
    clc$command, 62, 27, 1, 9, 0, 0, 27, 'OCM$CREOL_CHAPD'], [
    ['A                              ',clc$abbreviation_entry, 15],
    ['ABORT_FILE                     ',clc$nominal_entry, 11],
    ['AF                             ',clc$abbreviation_entry, 11],
    ['AI                             ',clc$abbreviation_entry, 18],
    ['ALOS                           ',clc$abbreviation_entry, 20],
    ['AO                             ',clc$abbreviation_entry, 19],
    ['APPLICATION_IDENTIFIER         ',clc$nominal_entry, 18],
    ['ARITHMETIC_LOSS_OF_SIGNIFICANCE',clc$nominal_entry, 20],
    ['ARITHMETIC_OVERFLOW            ',clc$nominal_entry, 19],
    ['AVAILABILITY                   ',clc$nominal_entry, 15],
    ['DEBUG_INPUT                    ',clc$nominal_entry, 12],
    ['DEBUG_MODE                     ',clc$nominal_entry, 14],
    ['DEBUG_OUTPUT                   ',clc$nominal_entry, 13],
    ['DF                             ',clc$abbreviation_entry, 21],
    ['DI                             ',clc$abbreviation_entry, 12],
    ['DIVIDE_FAULT                   ',clc$nominal_entry, 21],
    ['DM                             ',clc$abbreviation_entry, 14],
    ['DO                             ',clc$abbreviation_entry, 13],
    ['EO                             ',clc$abbreviation_entry, 22],
    ['EU                             ',clc$abbreviation_entry, 23],
    ['EXPONENT_OVERFLOW              ',clc$nominal_entry, 22],
    ['EXPONENT_UNDERFLOW             ',clc$nominal_entry, 23],
    ['F                              ',clc$alias_entry, 2],
    ['FI                             ',clc$abbreviation_entry, 24],
    ['FILE                           ',clc$nominal_entry, 2],
    ['FILES                          ',clc$alias_entry, 2],
    ['FLOS                           ',clc$abbreviation_entry, 25],
    ['FPI                            ',clc$alias_entry, 24],
    ['FPLOS                          ',clc$alias_entry, 25],
    ['FP_INDEFINITE                  ',clc$nominal_entry, 24],
    ['FP_LOSS_OF_SIGNIFICANCE        ',clc$nominal_entry, 25],
    ['IBD                            ',clc$abbreviation_entry, 26],
    ['IBDPD                          ',clc$alias_entry, 26],
    ['INVALID_BDP_DATA               ',clc$nominal_entry, 26],
    ['L                              ',clc$abbreviation_entry, 3],
    ['LIBRARIES                      ',clc$alias_entry, 3],
    ['LIBRARY                        ',clc$nominal_entry, 3],
    ['LM                             ',clc$abbreviation_entry, 6],
    ['LMO                            ',clc$abbreviation_entry, 7],
    ['LO                             ',clc$abbreviation_entry, 17],
    ['LOAD_MAP                       ',clc$nominal_entry, 6],
    ['LOAD_MAP_OPTION                ',clc$nominal_entry, 7],
    ['LOAD_MAP_OPTIONS               ',clc$alias_entry, 7],
    ['LOG_OPTION                     ',clc$nominal_entry, 17],
    ['M                              ',clc$abbreviation_entry, 4],
    ['MODULE                         ',clc$nominal_entry, 4],
    ['MODULES                        ',clc$alias_entry, 4],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['OBJECT_FILES                   ',clc$abbreviation_entry, 2],
    ['PRESET_VALUE                   ',clc$nominal_entry, 9],
    ['PV                             ',clc$abbreviation_entry, 9],
    ['S                              ',clc$abbreviation_entry, 16],
    ['SCOPE                          ',clc$nominal_entry, 16],
    ['SP                             ',clc$abbreviation_entry, 5],
    ['SS                             ',clc$abbreviation_entry, 10],
    ['STACK_SIZE                     ',clc$nominal_entry, 10],
    ['STARTING_PROCEDURE             ',clc$nominal_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 27],
    ['TEL                            ',clc$abbreviation_entry, 8],
    ['TERMINATION_ERROR_LEVEL        ',clc$nominal_entry, 8]],
    [
{ PARAMETER 1
    [49, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 19, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 111, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [37, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 196, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [46, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 83, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [59, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [41, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 79, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [42, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 494, clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [62, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 266, clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [52, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 340, clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [58, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 79, clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 79, clc$optional_parameter, 0, 0],
{ PARAMETER 13
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 79, clc$optional_parameter, 0, 0],
{ PARAMETER 14
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 15
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 303, clc$optional_parameter, 0, 0],
{ PARAMETER 16
    [55, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [44, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_parameter, 0, 0],
{ PARAMETER 18
    [7, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 19
    [9, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 20
    [8, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 21
    [16, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 22
    [21, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 23
    [22, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 24
    [30, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 25
    [31, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 26
    [34, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 27
    [60, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$program_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    47, [[1, 0, clc$list_type], [31, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$union_type], [[clc$file_type,
        clc$string_type],
        TRUE, 2],
        3, [[1, 0, clc$file_type]],
        8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
        ]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    132, [[1, 0, clc$list_type], [116, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$union_type], [[clc$file_type,
        clc$keyword_type, clc$string_type],
        FALSE, 3],
        81, [[1, 0, clc$keyword_type], [2], [
          ['OSF$CURRENT_LIBRARY            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
          ['OSF$TASK_SERVICES_LIBRARY      ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        3, [[1, 0, clc$file_type]],
        8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
        ]
      ]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$program_name_type]]
      ]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$program_name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$program_name_type]]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type,
    clc$string_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 3]]
      ],
    356, [[1, 0, clc$list_type], [340, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [9], [
        ['B                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['BLOCK                          ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['CR                             ', clc$alias_entry,
  clc$normal_usage_entry, 4],
        ['CROSS_REFERENCE                ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['ENTRY_POINT                    ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['EP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['SEGMENT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['XREF                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4]]
        ]
      ]
    ],
{ PARAMETER 8
    [[1, 0, clc$keyword_type], [7], [
    ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['E                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['ERROR                          ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['F                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
    ['FATAL                          ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['W                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['WARNING                        ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 9
    [[1, 0, clc$keyword_type], [9], [
    ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['ALTERNATE_ONES                 ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
    ['AO                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
    ['FLOATING_POINT_INDEFINITE      ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['FPI                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
    ['I                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['INFINITY                       ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['Z                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['ZERO                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, osc$max_segment_length, 10]]
    ],
{ PARAMETER 11
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type,
    clc$string_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 12
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type,
    clc$string_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 13
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type,
    clc$string_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 14
    [[1, 0, clc$union_type], [[clc$boolean_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 15
    [[1, 0, clc$keyword_type], [8], [
    ['A                              ', clc$alias_entry,
  clc$normal_usage_entry, 1],
    ['ADVANCED_USAGE                 ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['ADVERTISED                     ', clc$alias_entry,
  clc$normal_usage_entry, 1],
    ['AU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['H                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['HIDDEN                         ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['NORMAL_USAGE                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['NU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 16
    [[1, 0, clc$keyword_type], [6], [
    ['G                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['GATE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['LOCAL                          ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['X                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['XDCL                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 17
    [[1, 0, clc$keyword_type], [4], [
    ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['AUTOMATIC                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['M                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['MANUAL                         ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 18
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 19
    [[1, 0, clc$union_type], [[clc$boolean_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 20
    [[1, 0, clc$union_type], [[clc$boolean_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 21
    [[1, 0, clc$union_type], [[clc$boolean_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 22
    [[1, 0, clc$union_type], [[clc$boolean_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 23
    [[1, 0, clc$union_type], [[clc$boolean_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 24
    [[1, 0, clc$union_type], [[clc$boolean_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 25
    [[1, 0, clc$union_type], [[clc$boolean_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 26
    [[1, 0, clc$union_type], [[clc$boolean_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['$UNSPECIFIED                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 27
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$file = 2,
      p$library = 3,
      p$module = 4,
      p$starting_procedure = 5,
      p$load_map = 6,
      p$load_map_option = 7,
      p$termination_error_level = 8,
      p$preset_value = 9,
      p$stack_size = 10,
      p$abort_file = 11,
      p$debug_input = 12,
      p$debug_output = 13,
      p$debug_mode = 14,
      p$availability = 15,
      p$scope = 16,
      p$log_option = 17,
      p$application_identifier = 18,
      p$arithmetic_overflow = 19,
      p$arithmetic_loss_of_significan = 20 {ARITHMETIC_LOSS_OF_SIGNIFICANCE} ,
      p$divide_fault = 21,
      p$exponent_overflow = 22,
      p$exponent_underflow = 23,
      p$fp_indefinite = 24,
      p$fp_loss_of_significance = 25,
      p$invalid_bdp_data = 26,
      p$status = 27;

    VAR
      pvt: array [1 .. 27] of clt$parameter_value;

    CONST
      unspecified = '$UNSPECIFIED';

    VAR
      application_administrator: boolean,
      date: ost$date,
      i: clt$list_size,
      ignore_status: ost$status,
      member: ^SEQ ( * ),
      member_size: ost$segment_length,
      module_description: ^oct$module_description,
      module_does_exist: boolean,
      name: pmt$program_name,
      name_node: ^clt$data_value,
      new_alias_list: ^pmt$module_list,
      new_applic_program_header: ^llt$application_member_header,
      new_application_identifier: ^llt$application_identifier,
      new_enable_inhibit_conditions: ^pmt$enable_inhibit_conditions,
      new_module_list: ^pmt$module_list,
      new_object_file_list: ^llt$object_file_list,
      new_object_library_list: ^llt$object_library_list,
      new_program_attributes: ^llt$program_attributes,
      new_program_description_header: ^llt$library_member_header,
      nlm: ^oct$new_library_module_list,
      node: ^clt$data_value,
      number_of_libraries: clt$list_size,
      number_of_modules: clt$list_size,
      number_of_object_files: clt$list_size,
      old_alias_list: ^pmt$module_list,
      old_application_identifier: ^llt$application_identifier,
      old_enable_inhibit_conditions: ^pmt$enable_inhibit_conditions,
      old_member: ^SEQ ( * ),
      old_module_list: ^pmt$module_list,
      old_number_of_libraries: clt$list_size,
      old_number_of_modules: clt$list_size,
      old_number_of_object_files: clt$list_size,
      old_object_file_list: ^llt$object_file_list,
      old_object_library_list: ^llt$object_library_list,
      old_program_attributes: ^llt$program_attributes,
      old_program_description_header: ^llt$library_member_header,
      old_seq: ^SEQ ( * ),
      sequence: ^SEQ ( * ),
      size: ost$segment_length,
      temp_enable_inhibit_conditions: pmt$enable_inhibit_conditions,
      time: ost$time;

    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'change_system_condition_param', EJECT ??

    PROCEDURE [INLINE] change_system_condition_param
      (    parameter_number: clt$parameter_number;
           system_condition: pmt$system_condition);


      IF pvt [parameter_number].specified THEN
        IF pvt [parameter_number].value^.kind = clc$keyword { keyword = unspecified} THEN
          temp_enable_inhibit_conditions.enable_system_conditions :=
                temp_enable_inhibit_conditions.enable_system_conditions -
                $pmt$system_conditions [system_condition];
          temp_enable_inhibit_conditions.inhibit_system_conditions :=
                temp_enable_inhibit_conditions.inhibit_system_conditions -
                $pmt$system_conditions [system_condition];
        ELSE {clc$boolean}
          IF pvt [parameter_number].value^.boolean_value.value THEN
            temp_enable_inhibit_conditions.enable_system_conditions :=
                  temp_enable_inhibit_conditions.enable_system_conditions +
                  $pmt$system_conditions [system_condition];
            temp_enable_inhibit_conditions.inhibit_system_conditions :=
                  temp_enable_inhibit_conditions.inhibit_system_conditions -
                  $pmt$system_conditions [system_condition];
          ELSE
            temp_enable_inhibit_conditions.enable_system_conditions :=
                  temp_enable_inhibit_conditions.enable_system_conditions -
                  $pmt$system_conditions [system_condition];
            temp_enable_inhibit_conditions.inhibit_system_conditions :=
                  temp_enable_inhibit_conditions.inhibit_system_conditions +
                  $pmt$system_conditions [system_condition];
          IFEND;
        IFEND;
      IFEND;

    PROCEND change_system_condition_param;
?? OLDTITLE, EJECT ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$application_identifier].specified THEN
      avp$get_capability (avc$application_administration, avc$user, application_administrator, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF NOT application_administrator THEN
        osp$set_status_condition (oce$not_application_administrtr, status);
        RETURN;
      IFEND;
    IFEND;

    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];
    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /protect/
    BEGIN

      name_node := pvt [p$name].value;
      WHILE (name_node <> NIL) AND (name_node^.element_value <> NIL) DO
        name := name_node^.element_value^.program_name_value;
        ocp$search_nlm_tree (name, nlm, module_does_exist);
        IF NOT module_does_exist THEN
          osp$set_status_abnormal ('OC', oce$w_module_not_found, name, status);
          EXIT /protect/;
        IFEND;
        CASE nlm^.description^.kind OF
        = occ$program_description =
          old_program_description_header := nlm^.description^.program_description_header;
          old_application_identifier := NIL;
        = occ$applic_program_description =
          old_program_description_header := ^nlm^.description^.applic_program_description_hdr^.
                library_member_header;
          old_application_identifier := ^nlm^.description^.applic_program_description_hdr^.
                application_identifier;
        ELSE
          osp$set_status_abnormal ('OC', oce$e_module_is_not_a_prog_desc, name, status);
          EXIT /protect/;
        CASEND;
        old_number_of_object_files := 0;
        old_number_of_modules := 0;
        old_number_of_libraries := 0;

        old_seq := nlm^.description^.file;
        RESET ocv$olg_scratch_seq;
        NEXT new_program_description_header IN ocv$olg_scratch_seq;
        IF new_program_description_header = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;

        new_program_description_header^ := old_program_description_header^;

{   Since an APPLICATION PROGRAM DESCRIPTION is a record of:
{                llt$library_member_header,
{                llt$application_identifier,
{ processing of the APPLICATION_IDENTIFIER parameter must be done first after the
{ program description is set up so that the application identifier (llt$application_identifier)
{ immediately follows the program description (llt$library_member_header) in OCV$OLG_SCRATCH_SEQ.

        new_application_identifier := NIL;
        IF pvt [p$application_identifier].specified THEN
          IF pvt [p$application_identifier].value^.kind = clc$keyword { keyword = unspecified} THEN
            new_program_description_header^.kind := llc$program_description;
          ELSE {clc$name}
            NEXT new_application_identifier IN ocv$olg_scratch_seq;
            IF new_application_identifier = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;
            new_application_identifier^.name := pvt [p$application_identifier].value^.name_value;
            new_program_description_header^.kind := llc$applic_program_description;
          IFEND;
        ELSEIF old_application_identifier <> NIL THEN
          NEXT new_application_identifier IN ocv$olg_scratch_seq;
          IF new_application_identifier = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;
          new_application_identifier^.name := old_application_identifier^.name;
        IFEND;

        IF new_program_description_header^.number_of_aliases <> 0 THEN
          old_alias_list := #PTR (old_program_description_header^.aliases, old_seq^);
          NEXT new_alias_list: [1 .. new_program_description_header^.number_of_aliases] IN
                ocv$olg_scratch_seq;
          IF new_alias_list = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, name, status);
            EXIT /protect/;
          IFEND;
          new_alias_list^ := old_alias_list^;
        IFEND;

        old_member := #PTR (old_program_description_header^.member, old_seq^);
        RESET old_member;
        NEXT old_program_attributes IN old_member;
        IF old_program_attributes = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        NEXT new_program_attributes IN ocv$olg_scratch_seq;
        IF new_program_attributes = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        new_program_attributes^ := old_program_attributes^;

        IF (pmc$object_file_list_specified IN old_program_attributes^.contents) AND
              (old_program_attributes^.number_of_object_files > 0) THEN
          old_number_of_object_files := old_program_attributes^.number_of_object_files;
          NEXT old_object_file_list: [1 .. old_program_attributes^.number_of_object_files] IN old_member;
          IF old_object_file_list = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;
        IFEND;
        IF pvt [p$file].specified THEN
          IF pvt [p$file].value^.kind = clc$keyword { keyword = unspecified} THEN
            new_program_attributes^.contents := new_program_attributes^.contents -
                  $pmt$prog_description_contents [pmc$object_file_list_specified];
            new_program_attributes^.number_of_object_files := 0;
          ELSE {clc$list of clc$file or clc$string}
            number_of_object_files := clp$count_list_elements (pvt [p$file].value);
            new_program_attributes^.contents := new_program_attributes^.contents +
                  $pmt$prog_description_contents [pmc$object_file_list_specified];
            new_program_attributes^.number_of_object_files := number_of_object_files;
            NEXT new_object_file_list: [1 .. number_of_object_files] IN ocv$olg_scratch_seq;
            IF new_object_file_list = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;
            node := pvt [p$file].value;
            FOR i := 1 TO number_of_object_files DO
              IF node^.element_value^.kind = clc$file THEN
                new_object_file_list^ [i] := node^.element_value^.file_value^;
              ELSE {clc$string}
                new_object_file_list^ [i] := node^.element_value^.string_value^;
              IFEND;
              node := node^.link;
            FOREND;
          IFEND;
        ELSEIF old_number_of_object_files > 0 THEN
          NEXT new_object_file_list: [1 .. old_number_of_object_files] IN ocv$olg_scratch_seq;
          IF new_object_file_list = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;
          new_object_file_list^ := old_object_file_list^;
        IFEND;

        IF (pmc$module_list_specified IN old_program_attributes^.contents) AND
              (old_program_attributes^.number_of_modules > 0) THEN
          old_number_of_modules := old_program_attributes^.number_of_modules;
          NEXT old_module_list: [1 .. old_program_attributes^.number_of_modules] IN old_member;
          IF old_module_list = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;
        IFEND;
        IF pvt [p$module].specified THEN
          IF pvt [p$module].value^.kind = clc$keyword { keyword = unspecified} THEN
            new_program_attributes^.contents := new_program_attributes^.contents -
                  $pmt$prog_description_contents [pmc$module_list_specified];
            new_program_attributes^.number_of_modules := 0;
          ELSE {clc$list of clc$program_name}
            number_of_modules := clp$count_list_elements (pvt [p$module].value);
            new_program_attributes^.contents := new_program_attributes^.contents +
                  $pmt$prog_description_contents [pmc$module_list_specified];
            new_program_attributes^.number_of_modules := number_of_modules;
            NEXT new_module_list: [1 .. number_of_modules] IN ocv$olg_scratch_seq;
            IF new_module_list = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;
            node := pvt [p$module].value;
            FOR i := 1 TO number_of_modules DO
              new_module_list^ [i] := node^.element_value^.program_name_value;
              node := node^.link;
            FOREND;
          IFEND;
        ELSEIF old_number_of_modules > 0 THEN
          NEXT new_module_list: [1 .. old_number_of_modules] IN ocv$olg_scratch_seq;
          IF new_module_list = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;
          new_module_list^ := old_module_list^;
        IFEND;

        IF (pmc$library_list_specified IN old_program_attributes^.contents) AND
              (old_program_attributes^.number_of_libraries > 0) THEN
          old_number_of_libraries := old_program_attributes^.number_of_libraries;
          NEXT old_object_library_list: [1 .. old_program_attributes^.number_of_libraries] IN old_member;
          IF old_object_library_list = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;
        IFEND;
        IF pvt [p$library].specified THEN
          IF pvt [p$library].value^.kind = clc$keyword { keyword = unspecified} THEN
            new_program_attributes^.contents := new_program_attributes^.contents -
                  $pmt$prog_description_contents [pmc$library_list_specified];
            new_program_attributes^.number_of_libraries := 0;
          ELSE {clc$list of clc$keyword or clc$file or clc$string}
            number_of_libraries := clp$count_list_elements (pvt [p$library].value);
            new_program_attributes^.contents := new_program_attributes^.contents +
                  $pmt$prog_description_contents [pmc$library_list_specified];
            new_program_attributes^.number_of_libraries := number_of_libraries;
            NEXT new_object_library_list: [1 .. number_of_libraries] IN ocv$olg_scratch_seq;
            IF new_object_library_list = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;
            node := pvt [p$library].value;
            FOR i := 1 TO number_of_libraries DO
              CASE node^.element_value^.kind OF
              = clc$keyword =
                new_object_library_list^ [i] := node^.element_value^.keyword_value;
              = clc$file =
                new_object_library_list^ [i] := node^.element_value^.file_value^;
              ELSE {clc$string}
                new_object_library_list^ [i] := node^.element_value^.string_value^;
              CASEND;
              node := node^.link;
            FOREND;
          IFEND;
        ELSEIF old_number_of_libraries > 0 THEN
          NEXT new_object_library_list: [1 .. old_number_of_libraries] IN ocv$olg_scratch_seq;
          IF new_object_library_list = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;
          new_object_library_list^ := old_object_library_list^;
        IFEND;

        IF pmc$condition_specified IN old_program_attributes^.contents THEN
          NEXT old_enable_inhibit_conditions IN old_member;
          IF old_enable_inhibit_conditions = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;
          temp_enable_inhibit_conditions := old_enable_inhibit_conditions^;
        ELSE
          temp_enable_inhibit_conditions.enable_system_conditions := $pmt$system_conditions [];
          temp_enable_inhibit_conditions.inhibit_system_conditions := $pmt$system_conditions [];
        IFEND;
        change_system_condition_param (p$arithmetic_overflow, pmc$arithmetic_overflow);
        change_system_condition_param (p$arithmetic_loss_of_significan, pmc$arithmetic_significance);
        change_system_condition_param (p$divide_fault, pmc$divide_fault);
        change_system_condition_param (p$exponent_overflow, pmc$exponent_overflow);
        change_system_condition_param (p$exponent_underflow, pmc$exponent_underflow);
        change_system_condition_param (p$fp_indefinite, pmc$fp_indefinite);
        change_system_condition_param (p$fp_loss_of_significance, pmc$fp_significance_loss);
        change_system_condition_param (p$invalid_bdp_data, pmc$invalid_bdp_data);
        IF (temp_enable_inhibit_conditions.enable_system_conditions = $pmt$system_conditions []) AND
              (temp_enable_inhibit_conditions.inhibit_system_conditions = $pmt$system_conditions []) THEN
          new_program_attributes^.contents := new_program_attributes^.contents -
                $pmt$prog_description_contents [pmc$condition_specified];
        ELSE
          new_program_attributes^.contents := new_program_attributes^.contents +
                $pmt$prog_description_contents [pmc$condition_specified];
          NEXT new_enable_inhibit_conditions IN ocv$olg_scratch_seq;
          IF new_enable_inhibit_conditions = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;
          new_enable_inhibit_conditions^ := temp_enable_inhibit_conditions;
        IFEND;

        IF pvt [p$starting_procedure].specified THEN
          IF pvt [p$starting_procedure].value^.kind = clc$keyword { keyword = unspecified} THEN
            new_program_attributes^.contents := new_program_attributes^.contents -
                  $pmt$prog_description_contents [pmc$starting_proc_specified];
          ELSE
            new_program_attributes^.starting_procedure := pvt [p$starting_procedure].value^.
                  program_name_value;
            new_program_attributes^.contents := new_program_attributes^.contents +
                  $pmt$prog_description_contents [pmc$starting_proc_specified];
          IFEND;
        IFEND;

        IF pvt [p$load_map].specified THEN
          CASE pvt [p$load_map].value^.kind OF
          = clc$keyword = { keyword = unspecified}
            new_program_attributes^.contents := new_program_attributes^.contents -
                  $pmt$prog_description_contents [pmc$load_map_file_specified];
          = clc$file =
            new_program_attributes^.load_map_file := pvt [p$load_map].value^.file_value^;
            new_program_attributes^.contents := new_program_attributes^.contents +
                  $pmt$prog_description_contents [pmc$load_map_file_specified];
          ELSE {clc$string}
            new_program_attributes^.load_map_file := pvt [p$load_map].value^.string_value^;
            new_program_attributes^.contents := new_program_attributes^.contents +
                  $pmt$prog_description_contents [pmc$load_map_file_specified];
          CASEND;
        IFEND;

        IF pvt [p$load_map_option].specified THEN
          new_program_attributes^.contents := new_program_attributes^.contents +
                $pmt$prog_description_contents [pmc$load_map_options_specified];
          IF pvt [p$load_map_option].value^.kind = clc$keyword THEN
            IF pvt [p$load_map_option].value^.keyword_value = unspecified THEN
              new_program_attributes^.contents := new_program_attributes^.contents -
                    $pmt$prog_description_contents [pmc$load_map_options_specified];
            ELSEIF pvt [p$load_map_option].value^.keyword_value = 'ALL' THEN
              new_program_attributes^.load_map_options := -$pmt$load_map_options [pmc$no_load_map];
            ELSE {NONE}
              new_program_attributes^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
            IFEND;
          ELSE {clc$list of clc$keyword}
            new_program_attributes^.load_map_options := $pmt$load_map_options [];
            node := pvt [p$load_map_option].value;
            WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
              IF node^.element_value^.keyword_value = 'SEGMENT' THEN
                new_program_attributes^.load_map_options := new_program_attributes^.load_map_options +
                      $pmt$load_map_options [pmc$segment_map];
              ELSEIF node^.element_value^.keyword_value = 'BLOCK' THEN
                new_program_attributes^.load_map_options := new_program_attributes^.load_map_options +
                      $pmt$load_map_options [pmc$block_map];
              ELSEIF node^.element_value^.keyword_value = 'ENTRY_POINT' THEN
                new_program_attributes^.load_map_options := new_program_attributes^.load_map_options +
                      $pmt$load_map_options [pmc$entry_point_map];
              ELSE {CROSS_REFERENCE}
                new_program_attributes^.load_map_options := new_program_attributes^.load_map_options +
                      $pmt$load_map_options [pmc$entry_point_xref];
              IFEND;
              node := node^.link;
            WHILEND;
          IFEND;
        IFEND;

        IF pvt [p$termination_error_level].specified THEN
          new_program_attributes^.contents := new_program_attributes^.contents +
                $pmt$prog_description_contents [pmc$term_error_level_specified];
          IF pvt [p$termination_error_level].value^.keyword_value = unspecified THEN
            new_program_attributes^.contents := new_program_attributes^.contents -
                  $pmt$prog_description_contents [pmc$term_error_level_specified];
          ELSEIF pvt [p$termination_error_level].value^.keyword_value = 'WARNING' THEN
            new_program_attributes^.termination_error_level := pmc$warning_load_errors;
          ELSEIF pvt [p$termination_error_level].value^.keyword_value = 'ERROR' THEN
            new_program_attributes^.termination_error_level := pmc$error_load_errors;
          ELSE {FATAL}
            new_program_attributes^.termination_error_level := pmc$fatal_load_errors;
          IFEND;
        IFEND;

        IF pvt [p$preset_value].specified THEN
          new_program_attributes^.contents := new_program_attributes^.contents +
                $pmt$prog_description_contents [pmc$preset_specified];
          IF pvt [p$preset_value].value^.keyword_value = unspecified THEN
            new_program_attributes^.contents := new_program_attributes^.contents -
                  $pmt$prog_description_contents [pmc$preset_specified];
          ELSEIF pvt [p$preset_value].value^.keyword_value = 'ZERO' THEN
            new_program_attributes^.preset := pmc$initialize_to_zero;
          ELSEIF pvt [p$preset_value].value^.keyword_value = 'INFINITY' THEN
            new_program_attributes^.preset := pmc$initialize_to_infinity;
          ELSEIF pvt [p$preset_value].value^.keyword_value = 'FLOATING_POINT_INDEFINITE' THEN
            new_program_attributes^.preset := pmc$initialize_to_indefinite;
          ELSE {ALTERNATE_ONES}
            new_program_attributes^.preset := pmc$initialize_to_alt_ones;
          IFEND;
        IFEND;

        IF pvt [p$stack_size].specified THEN
          IF pvt [p$stack_size].value^.kind = clc$keyword { keyword = unspecified} THEN
            new_program_attributes^.contents := new_program_attributes^.contents -
                  $pmt$prog_description_contents [pmc$max_stack_size_specified];
          ELSE {clc$integer}
            new_program_attributes^.contents := new_program_attributes^.contents +
                  $pmt$prog_description_contents [pmc$max_stack_size_specified];
            new_program_attributes^.maximum_stack_size := pvt [p$stack_size].value^.integer_value.value;
          IFEND;
        IFEND;

        IF pvt [p$abort_file].specified THEN
          CASE pvt [p$abort_file].value^.kind OF
          = clc$keyword = { keyword = unspecified}
            new_program_attributes^.contents := new_program_attributes^.contents -
                  $pmt$prog_description_contents [pmc$abort_file_specified];
          = clc$file =
            new_program_attributes^.contents := new_program_attributes^.contents +
                  $pmt$prog_description_contents [pmc$abort_file_specified];
            new_program_attributes^.abort_file := pvt [p$abort_file].value^.file_value^;
          ELSE {clc$string}
            new_program_attributes^.contents := new_program_attributes^.contents +
                  $pmt$prog_description_contents [pmc$abort_file_specified];
            new_program_attributes^.abort_file := pvt [p$abort_file].value^.string_value^;
          CASEND;
        IFEND;

        IF pvt [p$debug_input].specified THEN
          CASE pvt [p$debug_input].value^.kind OF
          = clc$keyword = { keyword = unspecified}
            new_program_attributes^.contents := new_program_attributes^.contents -
                  $pmt$prog_description_contents [pmc$debug_input_specified];
          = clc$file =
            new_program_attributes^.contents := new_program_attributes^.contents +
                  $pmt$prog_description_contents [pmc$debug_input_specified];
            new_program_attributes^.debug_input := pvt [p$debug_input].value^.file_value^;
          ELSE {clc$string}
            new_program_attributes^.contents := new_program_attributes^.contents +
                  $pmt$prog_description_contents [pmc$debug_input_specified];
            new_program_attributes^.debug_input := pvt [p$debug_input].value^.string_value^;
          CASEND;
        IFEND;

        IF pvt [p$debug_output].specified THEN
          CASE pvt [p$debug_output].value^.kind OF
          = clc$keyword = { keyword = unspecified}
            new_program_attributes^.contents := new_program_attributes^.contents -
                  $pmt$prog_description_contents [pmc$debug_output_specified];
          = clc$file =
            new_program_attributes^.contents := new_program_attributes^.contents +
                  $pmt$prog_description_contents [pmc$debug_output_specified];
            new_program_attributes^.debug_output := pvt [p$debug_output].value^.file_value^;
          ELSE {clc$string}
            new_program_attributes^.contents := new_program_attributes^.contents +
                  $pmt$prog_description_contents [pmc$debug_output_specified];
            new_program_attributes^.debug_output := pvt [p$debug_output].value^.string_value^;
          CASEND;
        IFEND;

        IF pvt [p$debug_mode].specified THEN
          IF pvt [p$debug_mode].value^.kind = clc$keyword { keyword = unspecified} THEN
            new_program_attributes^.contents := new_program_attributes^.contents -
                  $pmt$prog_description_contents [pmc$debug_mode_specified];
          ELSE {clc$boolean}
            new_program_attributes^.contents := new_program_attributes^.contents +
                  $pmt$prog_description_contents [pmc$debug_mode_specified];
            new_program_attributes^.debug_mode := pvt [p$debug_mode].value^.boolean_value.value;
          IFEND;
        IFEND;

        IF pvt [p$availability].specified THEN
          IF pvt [p$availability].value^.keyword_value = 'NORMAL_USAGE' THEN
            new_program_description_header^.command_function_availability := clc$normal_usage_entry;
          ELSEIF pvt [p$availability].value^.keyword_value = 'ADVANCED_USAGE' THEN
            new_program_description_header^.command_function_availability := clc$advanced_usage_entry;
          ELSE {HIDDEN}
            new_program_description_header^.command_function_availability := clc$hidden_entry;
          IFEND;
        IFEND;

        IF pvt [p$scope].specified THEN
          IF pvt [p$scope].value^.keyword_value = 'XDCL' THEN
            new_program_description_header^.command_function_kind := llc$entry_point;
          ELSEIF pvt [p$scope].value^.keyword_value = 'GATE' THEN
            new_program_description_header^.command_function_kind := llc$gate;
          ELSE {LOCAL}
            new_program_description_header^.command_function_kind := llc$local_to_library;
          IFEND;
        IFEND;

        IF pvt [p$log_option].specified THEN
          IF pvt [p$log_option].value^.keyword_value = 'AUTOMATIC' THEN
            new_program_description_header^.command_log_option := clc$automatically_log;
          ELSE {MANUAL}
            new_program_description_header^.command_log_option := clc$manually_log;
          IFEND;
        IFEND;

        pmp$get_time (osc$hms_time, time, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        pmp$get_date (osc$mdy_date, date, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        new_program_description_header^.time_created := time;
        new_program_description_header^.date_created := date;

        ALLOCATE module_description IN ocv$olg_working_heap^;
        IF module_description = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;

        module_description^.name := new_program_description_header^.name;
        module_description^.source := occ$current;
        IF new_application_identifier = NIL THEN
          module_description^.kind := occ$program_description;
        ELSE
          module_description^.kind := occ$applic_program_description;
        IFEND;

        size := i#current_sequence_position (ocv$olg_scratch_seq);
        RESET ocv$olg_scratch_seq;

        ALLOCATE module_description^.file: [[REP size OF cell]] IN ocv$olg_working_heap^;
        IF module_description^.file = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;

        IF #SEGMENT (nlm^.description^.file) = #SEGMENT (ocv$olg_working_heap) THEN
          FREE nlm^.description^.file IN ocv$olg_working_heap^;
        IFEND;
        nlm^.description := module_description;
        nlm^.description^.file := module_description^.file;

        RESET module_description^.file;

        IF new_application_identifier = NIL THEN
          NEXT module_description^.program_description_header IN module_description^.file;
          NEXT new_program_description_header IN ocv$olg_scratch_seq;
          module_description^.program_description_header^ := new_program_description_header^;
          IF module_description^.program_description_header^.number_of_aliases <> 0 THEN
            NEXT new_alias_list: [1 .. module_description^.program_description_header^.number_of_aliases] IN
                  module_description^.file;
            module_description^.program_description_header^.aliases :=
                  #REL (new_alias_list, module_description^.file^);
            NEXT old_alias_list: [1 .. module_description^.program_description_header^.number_of_aliases] IN
                  ocv$olg_scratch_seq;
            new_alias_list^ := old_alias_list^;
          IFEND;
        ELSE
          NEXT module_description^.applic_program_description_hdr IN module_description^.file;
          NEXT new_applic_program_header IN ocv$olg_scratch_seq;
          module_description^.applic_program_description_hdr^ := new_applic_program_header^;
          IF module_description^.applic_program_description_hdr^.library_member_header.number_of_aliases <>
                0 THEN
            NEXT new_alias_list: [1 .. module_description^.applic_program_description_hdr^.
                  library_member_header.number_of_aliases] IN module_description^.file;
            module_description^.applic_program_description_hdr^.library_member_header.aliases :=
                  #REL (new_alias_list, module_description^.file^);

            NEXT old_alias_list: [1 .. module_description^.applic_program_description_hdr^.
                  library_member_header.number_of_aliases] IN ocv$olg_scratch_seq;
            new_alias_list^ := old_alias_list^;
          IFEND;
        IFEND;

        member_size := size - i#current_sequence_position (module_description^.file);
        NEXT member: [[REP member_size OF cell]] IN module_description^.file;
        IF new_application_identifier = NIL THEN
          module_description^.program_description_header^.member := #REL (member, module_description^.file^);
          module_description^.program_description_header^.member_size := member_size;
        ELSE
          module_description^.applic_program_description_hdr^.library_member_header.member :=
                #REL (member, module_description^.file^);
          module_description^.applic_program_description_hdr^.library_member_header.member_size :=
                member_size;
        IFEND;

        NEXT sequence: [[REP member_size OF cell]] IN ocv$olg_scratch_seq;
        member^ := sequence^;
        name_node := name_node^.link;
      WHILEND;

    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);

  PROCEND ocp$_change_program_description;

MODEND ocm$change_program_description;
*DECK DECK=OCM$CHECKSUM EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$checksum;

*copyc och$checksum

  FUNCTION [XDCL] ocp$checksum (p_sequence: ^SEQ ( * )): integer;

    CONST
      max_trailing_bytes = 3,
      shift_one_byte = 100(16),
      max_halfword = 0ffffffff(16);

    TYPE
      unsigned_8_bit = 0 .. 0ff(16),
      unsigned_32_bit = 0 .. max_halfword;

    VAR
      accumulator: integer,
      shift: 0 .. 3,
      trailing_bytes: 0 .. 3,
      four_bytes: ^unsigned_32_bit,
      sequence: ^SEQ ( * ),
      one_byte: ^unsigned_8_bit,
      temp_bytes: unsigned_32_bit;

{ NOTE:  When a NEXT goes beyond the end of a sequence, it returns a NIL
{ pointer.  The value of the sequence pointer itself however, has not changed.
{ This fact is utilized in the code below when a NEXT of the ONE_BYTE
{ pointer is done after the NEXT for the FOUR_BYTES pointer returns NIL.

    sequence := p_sequence;

    RESET sequence;
    accumulator := 0;
    NEXT four_bytes IN sequence;
    WHILE four_bytes <> NIL DO
      accumulator := (accumulator + four_bytes^) * 2;
      accumulator := (accumulator MOD (max_halfword + 1)) + (accumulator DIV (max_halfword + 1));
      NEXT four_bytes IN sequence;
    WHILEND;
    trailing_bytes := 0;
    temp_bytes := 0;
    NEXT one_byte IN sequence;
    WHILE one_byte <> NIL DO
      temp_bytes := temp_bytes * shift_one_byte;
      temp_bytes := temp_bytes + one_byte^;
      trailing_bytes := trailing_bytes + 1;
      NEXT one_byte IN sequence;
    WHILEND;
    IF trailing_bytes > 0 THEN
      FOR shift := max_trailing_bytes DOWNTO trailing_bytes DO
        temp_bytes := temp_bytes * shift_one_byte;
      FOREND;
      accumulator := (accumulator + temp_bytes) * 2;
      accumulator := (accumulator MOD (max_halfword + 1)) + (accumulator DIV (max_halfword + 1));
    IFEND;
    ocp$checksum := accumulator;
  FUNCEND ocp$checksum;
MODEND ocm$checksum;
*DECK DECK=OCM$COMBINE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
MODULE ocm$combine;


{ PURPOSE:
{   To combine all or selected modules
{   from the named file or library with
{   the output library.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oce$library_generator_errors
*copyc oct$display_toggles
*copyc oct$nlm_modification_list
*copyc oct$nlm_replacement_list
*copyc oct$open_file_list
*copyc ost$status
?? POP ??
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc ocp$add_additions_to_nlm_list
*copyc ocp$close_all_open_files
*copyc ocp$create_an_nlm
*copyc ocp$free_nlm_modification_list
*copyc ocp$free_nlm_replacement_list
*copyc ocp$generate_message
*copyc ocp$get_module_from_wfl
*copyc ocp$initialize_olg_working_heap
*copyc ocp$obtain_object_file
*copyc ocp$replace_list_into_nlm_list
*copyc ocp$rewind_working_file_list
*copyc ocp$search_modification_list
*copyc ocp$search_nlm_tree
*copyc ocp$search_replacement_list
*copyc ocp$search_working_file_list
*copyc ocp$skip_module_on_wfl
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc ocv$nlm_list
*copyc ocv$olg_scratch_seq
*copyc ocv$olg_working_heap
*copyc ocv$open_file_list
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    command_status: ost$status;

?? OLDTITLE ??
?? NEWTITLE := 'combine_module_subrange' ??
?? EJECT ??

  PROCEDURE combine_module_subrange
    (    first_module: pmt$program_name;
         last_module: pmt$program_name;
     VAR working_file_list: oct$working_file_list;
         addition_list: {output} ^oct$nlm_modification_list;
         replacement_list: {output} ^oct$nlm_replacement_list;
     VAR status: ost$status);




    VAR
      new_additions: ^oct$nlm_modification_list,
      new_replacements: ^oct$nlm_replacement_list,
      last_addition: ^oct$nlm_modification_list,
      last_replacement: ^oct$nlm_replacement_list,

      module_found: boolean,
      nlm: ^oct$new_library_module_list,
      current_module: pmt$program_name,
      file_descriptor: ^oct$open_file_list;

    status.normal := TRUE;
    ocp$search_modification_list (osc$null_name, addition_list, new_additions, module_found);
    ocp$search_replacement_list (osc$null_name, replacement_list, new_replacements, module_found);

    ocp$rewind_working_file_list (working_file_list);

    ocp$search_working_file_list (first_module, working_file_list, module_found);
    IF NOT module_found THEN
      IF first_module = last_module THEN
        osp$set_status_abnormal (oc, oce$w_module_not_found, first_module, status);
      ELSE
        osp$set_status_abnormal (oc, oce$w_subrange_module_not_found, first_module, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, last_module, status);
      IFEND;
      ocp$generate_message (status);
      osp$set_status_abnormal (oc, oce$e_some_modules_not, 'combined', command_status);
      RETURN;
    IFEND;

    REPEAT
      ocp$get_module_from_wfl (working_file_list, current_module, file_descriptor);
      IF current_module = osc$null_name THEN
        IF last_module <> osc$null_name THEN
          osp$set_status_abnormal (oc, oce$e_range_module_2_not_found, last_module, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);
          ocp$generate_message (status);
          osp$set_status_abnormal (oc, oce$e_some_modules_not, 'combined', command_status);
          ocp$free_nlm_modification_list (new_additions);
          ocp$free_nlm_replacement_list (new_replacements);
        IFEND;
        RETURN;
      IFEND;

      ocp$search_replacement_list (current_module, replacement_list, last_replacement, module_found);
      IF module_found THEN
        osp$set_status_abnormal (oc, oce$w_same_module_quoted_twice, current_module, status);
        ocp$generate_message (status);
        osp$set_status_abnormal (oc, oce$e_some_modules_not, 'combined', command_status);

      ELSE
        ocp$search_modification_list (current_module, addition_list, last_addition, module_found);
        IF module_found THEN
          osp$set_status_abnormal (oc, oce$w_same_module_quoted_twice, current_module, status);
          ocp$generate_message (status);
          osp$set_status_abnormal (oc, oce$e_some_modules_not, 'combined', command_status);

        ELSE
          ocp$search_nlm_tree (current_module, nlm, module_found);
          IF module_found THEN
            NEXT last_replacement^.link IN ocv$olg_scratch_seq;
            last_replacement := last_replacement^.link;
            IF last_replacement = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;

            last_replacement^.nlm := nlm;
            last_replacement^.link := NIL;

            last_replacement^.description := ^file_descriptor^.directory^ [file_descriptor^.current_module];
          ELSE
            NEXT last_addition^.link IN ocv$olg_scratch_seq;
            last_addition := last_addition^.link;
            IF last_addition = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;

            ocp$create_an_nlm (^file_descriptor^.directory^ [file_descriptor^.current_module],
                  last_addition^.nlm, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            last_addition^.link := NIL;
          IFEND;
        IFEND;
      IFEND;

      ocp$skip_module_on_wfl (working_file_list);

    UNTIL current_module = last_module;


  PROCEND combine_module_subrange;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$_combine_module' ??
?? EJECT ??

{ This procedure is the command processor for the CREATE_OBJECT_LIBRARY
{ subcommand COMBINE_MODULE.

  PROCEDURE [XDCL] ocp$_combine_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$creol_comm) combine_module, combine_modules, comm (
{   library, libraries, l: list of file = $required
{   module, modules, m: list of any of
{       program_name
{       range of program_name
{     anyend = $optional
{   placement, p: key
{       (after, a)
{       (before, b)
{     keyend = after
{   destination, d: program_name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [93, 10, 11, 1, 24, 24, 846],
    clc$command, 11, 5, 1, 0, 0, 0, 5, 'OCM$CREOL_COMM'], [
    ['D                              ',clc$abbreviation_entry, 4],
    ['DESTINATION                    ',clc$nominal_entry, 4],
    ['L                              ',clc$abbreviation_entry, 1],
    ['LIBRARIES                      ',clc$alias_entry, 1],
    ['LIBRARY                        ',clc$nominal_entry, 1],
    ['M                              ',clc$abbreviation_entry, 2],
    ['MODULE                         ',clc$nominal_entry, 2],
    ['MODULES                        ',clc$alias_entry, 2],
    ['P                              ',clc$abbreviation_entry, 3],
    ['PLACEMENT                      ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 19, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 49, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$program_name_type,
      clc$range_type],
      FALSE, 2],
      3, [[1, 0, clc$program_name_type]],
      10, [[1, 0, clc$range_type], [3],
          [[1, 0, clc$program_name_type]]
        ]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['AFTER                          ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['B                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['BEFORE                         ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'after'],
{ PARAMETER 4
    [[1, 0, clc$program_name_type]],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$library = 1,
      p$module = 2,
      p$placement = 3,
      p$destination = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      addition_list: oct$nlm_modification_list,
      after: ^oct$new_library_module_list,
      file_descriptor: ^oct$open_file_list,
      first_module: pmt$program_name,
      ignore_status: ost$status,
      last_module: pmt$program_name,
      module_found: boolean,
      nlm: ^oct$new_library_module_list,
      node: ^clt$data_value,
      replacement_list: oct$nlm_replacement_list,
      working_file_list: oct$working_file_list;

    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    command_status.normal := TRUE;

    RESET ocv$olg_scratch_seq;

    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /protect/
    BEGIN
      working_file_list.current_file := ^working_file_list.first_working_file;
      node := pvt [p$library].value;
      WHILE node <> NIL DO
        NEXT working_file_list.current_file^.link IN ocv$olg_scratch_seq;
        working_file_list.current_file := working_file_list.current_file^.link;
        IF working_file_list.current_file = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        ocp$obtain_object_file (node^.element_value^.file_value^, working_file_list.current_file^.descriptor,
              status);
        IF NOT status.normal THEN
          EXIT /protect/;
        IFEND;
        node := node^.link;
      WHILEND;

      working_file_list.current_file^.link := NIL;

      IF pvt [p$destination].specified THEN
        ocp$search_nlm_tree (pvt [p$destination].value^.program_name_value, nlm, module_found);
        IF NOT module_found THEN
          osp$set_status_abnormal (oc, oce$e_module_not_found, pvt [p$destination].value^.program_name_value,
                status);
          EXIT /protect/;
        IFEND;
        IF pvt [p$placement].value^.keyword_value = 'AFTER' THEN
          after := nlm;
        ELSE { BEFORE
          after := nlm^.b_link;
        IFEND;
      ELSE
        IF pvt [p$placement].value^.keyword_value = 'AFTER' THEN
          after := ocv$nlm_list^.b_link;
        ELSE { BEFORE
          after := ocv$nlm_list;
        IFEND;
      IFEND;

      addition_list.link := NIL;
      replacement_list.link := NIL;
      IF pvt [p$module].specified THEN
        node := pvt [p$module].value;

      /obtain_combination_lists/
        WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
          IF node^.element_value^.kind = clc$range THEN
            first_module := node^.element_value^.low_value^.program_name_value;
            last_module := node^.element_value^.high_value^.program_name_value;
          ELSE
            first_module := node^.element_value^.program_name_value;
            last_module := first_module;
          IFEND;
          combine_module_subrange (first_module, last_module, working_file_list, ^addition_list,
                ^replacement_list, status);
          IF NOT status.normal THEN
            EXIT /obtain_combination_lists/;
          IFEND;
          node := node^.link;
        WHILEND /obtain_combination_lists/;
      ELSE
        ocp$rewind_working_file_list (working_file_list);
        ocp$get_module_from_wfl (working_file_list, first_module, file_descriptor);
        last_module := osc$null_name;
        combine_module_subrange (first_module, last_module, working_file_list, ^addition_list,
              ^replacement_list, status);
      IFEND;

      IF NOT status.normal THEN
        ocp$free_nlm_modification_list (^addition_list);
        ocp$free_nlm_replacement_list (^replacement_list);
        EXIT /protect/;
      IFEND;

      ocp$add_additions_to_nlm_list (after, ^addition_list);
      ocp$replace_list_into_nlm_list (^replacement_list);
      status := command_status;
    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);


  PROCEND ocp$_combine_module;
?? OLDTITLE ??
MODEND ocm$combine;
*DECK DECK=OCM$COMPARE_OBJECT_LIBRARY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Management: Compare Object Libraries or Files' ??
MODULE ocm$compare_object_library;

{  PURPOSE:
{    Compare two object files or two object libraries and produce a
{    listing of the differences.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc cst$menu_class
*copyc cst$menu_list
*copyc cyd$debug_symbol_table
*copyc cyd$debug_symbol_table_header
*copyc fdt$form_definition
*copyc llt$deferred_common_blocks
*copyc llt$deferred_entry_points
*copyc llt$form_definition
*copyc oce$library_generator_errors
*copyc oct$display_toggles
*copyc oct$module_description
*copyc ost$message_template
*copyc ost$message_template_index
*copyc ost$mtm_condition_codes
*copyc ost$mtm_condition_names
*copyc ost$mtm_header
*copyc ost$mtm_menu_header
*copyc ost$status
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$extract_msg_module_contents
*copyc clp$get_next_scl_proc_line
*copyc ocp$close_all_open_files
*copyc ocp$close_output_file
*copyc ocp$convert_information_element
*copyc ocp$initialize_oc_environment
*copyc ocp$obtain_object_file
*copyc ocp$open_output_file
*copyc ocp$output
*copyc osp$generate_message
*copyc osp$set_status_abnormal
*copyc pmp$get_last_path_name
*copyc pmp$position_object_library
*copyc ocv$open_file_list
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    premature_end_of_file = 'PREMATURE END OF FILE';

  VAR { for error messages }
    old_object_text_descriptor: ^llt$object_text_descriptor,
    new_object_text_descriptor: ^llt$object_text_descriptor;

  VAR
    length: integer,
    number_of_compare_errors: [STATIC] integer := 0,
    strng: string (132);

?? OLDTITLE ??
?? NEWTITLE := '  SORT_MODULE_DIRECTORY', EJECT ??

  PROCEDURE sort_module_directory
    (VAR directory: array [1 .. * ] of oct$module_description);


    VAR
      changed_flag: integer,
      i: integer,
      sort_count: integer,
      temp: oct$module_description;


    changed_flag := UPPERBOUND (directory) - 1;

    REPEAT
      sort_count := changed_flag;
      changed_flag := 0;

      FOR i := 1 TO sort_count DO
        IF directory [i].name > directory [i + 1].name THEN
          changed_flag := i - 1;

          temp := directory [i];
          directory [i] := directory [i + 1];
          directory [i + 1] := temp;
        IFEND;
      FOREND;
    UNTIL changed_flag <= 0;


  PROCEND sort_module_directory;
?? OLDTITLE ??
?? NEWTITLE := '  COMPARE_MODULES', EJECT ??

  PROCEDURE compare_modules
    (VAR old_module: oct$module_description;
     VAR new_module: oct$module_description;
     VAR header_printed: boolean);

?? NEWTITLE := '    ERROR', EJECT ??

    PROCEDURE compare_error
      (    record_value: string ( * );
           old: ^cell;
           new: ^cell);


      VAR
        strng: string (10),
        l: integer,
        dummy: ost$status;


      number_of_compare_errors := number_of_compare_errors + 1;

      IF NOT header_printed THEN
        ocp$output (occ$new_page, 'Modules changed', 15, occ$end_of_line);
        ocp$output (occ$single_space, '~~~~~~~~~~~~~~~', 15, occ$end_of_line);

        header_printed := TRUE;
      IFEND;


      ocp$output (occ$single_space, new_module.name, #SIZE (new_module.name), occ$continue);
      ocp$output (' - ', 'First difference at record number', 33, occ$continue);

      STRINGREP (strng, l, record_number);
      ocp$output ('', strng (1, l), l, occ$continue);

      ocp$output (' - ', record_value, #SIZE (record_value), occ$end_of_line);

      display_error (old, new);

      error_in_compare := TRUE;

    PROCEND compare_error;
?? OLDTITLE ??
?? NEWTITLE := '    FORMAT_ERROR_STRING', EJECT ??

    PROCEDURE format_error_string
      (    error: ^0 .. 0ff(16);
           maximum_offset: ost$segment_length;
       VAR strng: string ( * );
       VAR lngth: integer);

      CONST
        half = 15,
        bytes_to_display = 2 * half;

      VAR
        offset: integer,
        hex_array: ^array [1 .. bytes_to_display] of 0 .. 0ff(16),
        ignore: integer,
        i: integer,
        number_to_display: 0 .. bytes_to_display;

      offset := #OFFSET (error) - half;
      IF (offset <= 0) THEN
        offset := 1;
      IFEND;

      hex_array := #ADDRESS (#RING (error), #SEGMENT (error), offset);

      IF #OFFSET(error) > maximum_offset THEN
        number_to_display := maximum_offset - #offset (hex_array) + 1;
      ELSE
        number_to_display := bytes_to_display;
      IFEND;

      lngth := 1;
      FOR i := 1 TO number_to_display DO
        STRINGREP (strng (lngth, 3), ignore, hex_array^ [i]: 3: #(16));
        lngth := lngth + 3;
      FOREND;

      lngth := lngth - 1;
    PROCEND format_error_string;
?? OLDTITLE ??
?? NEWTITLE := '    DISPLAY_ERROR', EJECT ??

    PROCEDURE display_error
      (    old: ^cell;
           new: ^cell);


      VAR
        old_array: ^array [1 .. 65536] of 0 .. 0ff(16),
        new_array: ^array [1 .. 65536] of 0 .. 0ff(16),
        error: integer,
        l: integer;


      IF (old = NIL) OR (new = NIL) THEN
        RETURN;
      IFEND;

      old_array := old;
      new_array := new;
      error := 1;

      WHILE (error < UPPERBOUND (old_array^)) AND (old_array^ [error] = new_array^ [error]) DO
        error := error + 1;
      WHILEND;

      format_error_string (^old_array^ [error], #size (old_module.file^), strng, l);
      ocp$output ('    REPLACED - ', strng, l, occ$end_of_line);
      format_error_string (^new_array^ [error], #size (new_module.file^), strng, l);
      ocp$output ('        WITH - ', strng, l, occ$end_of_line);

    PROCEND display_error;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE', EJECT ??

    PROCEDURE compare
      (    size: integer;
           record_kind: string ( * ));


      CONST
        buffer_size = 255;

      VAR
        s: integer,
        old: ^string ( * ),
        new: ^string ( * );


      s := size;

      WHILE s > 0 DO
        IF s > buffer_size THEN
          NEXT old: [buffer_size] IN old_module.file;
          NEXT new: [buffer_size] IN new_module.file;
        ELSE
          NEXT old: [s] IN old_module.file;
          NEXT new: [s] IN new_module.file;
        IFEND;

        s := s - buffer_size;


        IF (old = NIL) OR (new = NIL) THEN
          compare_error (premature_end_of_file, NIL, NIL);
          RETURN;
        IFEND;


        IF (old^ <> new^) THEN
          compare_error (record_kind, old, new);
          RETURN;
        IFEND;
      WHILEND;


    PROCEND compare;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_OBJECT_TEXT_DESCRIPTOR', EJECT ??

    PROCEDURE compare_object_text_descriptors
      (VAR old_object_text_descriptor: ^llt$object_text_descriptor;
       VAR new_object_text_descriptor: ^llt$object_text_descriptor);


      NEXT old_object_text_descriptor IN old_module.file;
      NEXT new_object_text_descriptor IN new_module.file;

      IF (old_object_text_descriptor = NIL) OR (new_object_text_descriptor = NIL) THEN
        compare_error (premature_end_of_file, NIL, NIL);
        RETURN;
      IFEND;


      IF (old_object_text_descriptor^.kind <> new_object_text_descriptor^.kind) THEN
        compare_error ('OBJECT RECORD KIND', old_object_text_descriptor, new_object_text_descriptor);
        RETURN;
      IFEND;


    PROCEND compare_object_text_descriptors;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_IDENTIFICATION_RECORDS', EJECT ??

    PROCEDURE compare_identification_records;


      VAR
        old: ^llt$identification,
        new: ^llt$identification;


      NEXT old IN old_module.file;
      NEXT new IN new_module.file;


      IF (old = NIL) OR (new = NIL) THEN
        compare_error (premature_end_of_file, NIL, NIL);
        RETURN;
      IFEND;


      IF old^.name = new^.name THEN
        IF old^.object_text_version = new^.object_text_version THEN
          IF old^.kind = new^.kind THEN
            IF old^.attributes = new^.attributes THEN
              IF old^.greatest_section_ordinal = new^.greatest_section_ordinal THEN

                RETURN;

              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;


      compare_error ('IDENTIFICATION RECORD', old, new);


    PROCEND compare_identification_records;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_TRANSFER_SYMBOLS', EJECT ??

    PROCEDURE compare_transfer_symbols;


      compare (#SIZE (llt$transfer_symbol), 'TRANSFER SYMBOL');


    PROCEND compare_transfer_symbols;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_SECTION_DEFINITIONS', EJECT ??

    PROCEDURE compare_section_definitions;


      compare (#SIZE (llt$section_definition), 'SECTION DEFINITION');


    PROCEND compare_section_definitions;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_ALLOTTED_SECTION_DEFS', EJECT ??

    PROCEDURE compare_allotted_section_defs
      (    old_size: integer;
           new_size: integer);


      CONST
        record_kind = 'ALLOTTED SECTION DEFINITION';

      VAR
        section_definition: ^llt$section_definition,
        old_reset: ^SEQ ( * ),
        new_reset: ^SEQ ( * ),
        valid_position: boolean;


      old_reset := old_module.file;

      compare (#SIZE (llt$section_definition), record_kind CAT ' LENGTH');
      IF error_in_compare THEN
        RETURN;
      IFEND;

      NEXT section_definition IN old_reset;

      old_reset := old_module.file;
      new_reset := new_module.file;

      pmp$position_object_library (old_module.file, old_size, valid_position);
      IF NOT valid_position THEN
        compare_error (premature_end_of_file, NIL, NIL);
        RETURN;
      IFEND;

      pmp$position_object_library (new_module.file, new_size, valid_position);
      IF NOT valid_position THEN
        compare_error (premature_end_of_file, NIL, NIL);
        RETURN;
      IFEND;

      compare (section_definition^.length, record_kind);
      IF error_in_compare THEN
        RETURN;
      IFEND;

      old_module.file := old_reset;
      new_module.file := new_reset;


    PROCEND compare_allotted_section_defs;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_SEGMENT_DEFINITIONS', EJECT ??

    PROCEDURE compare_segment_definitions;


      compare (#SIZE (llt$segment_definition), 'SEGMENT DEFINITION');


    PROCEND compare_segment_definitions;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_ALLOTTED_SEGMENT_DEFS', EJECT ??

    PROCEDURE compare_allotted_segment_defs;


      CONST
        record_kind = 'ALLOTTED SEGMENT DEFINITION';

      VAR
        old_segment_definition: ^llt$segment_definition,
        new_segment_definition: ^llt$segment_definition,
        old_position: ost$segment_length,
        new_position: ost$segment_length,
        old_allotted_segment_length: ost$segment_length,
        new_allotted_segment_length: ost$segment_length,
        length: ost$segment_length,
        old_reset: ^SEQ ( * ),
        new_reset: ^SEQ ( * ),
        valid_position: boolean;


      old_position := old_object_text_descriptor^.allotted_segment;
      new_position := new_object_text_descriptor^.allotted_segment;
      old_allotted_segment_length := old_object_text_descriptor^.allotted_segment_length;
      new_allotted_segment_length := new_object_text_descriptor^.allotted_segment_length;

      IF (old_allotted_segment_length <> new_allotted_segment_length) THEN
        compare_error ('ALLOTTED SEGMENT LENGTH', old_object_text_descriptor, new_object_text_descriptor);
      IFEND;

      NEXT old_segment_definition IN old_module.file;
      NEXT new_segment_definition IN new_module.file;
      IF (old_segment_definition = NIL) OR (new_segment_definition = NIL) THEN
        compare_error (premature_end_of_file, NIL, NIL);
        RETURN;
      IFEND;

      IF (old_segment_definition^ <> new_segment_definition^) THEN
        compare_error (record_kind, old_segment_definition, new_segment_definition);
        RETURN;
      IFEND;

?? EJECT ??

      IF (old_allotted_segment_length <> 0) THEN
        length := old_allotted_segment_length;
      ELSE
        length := old_segment_definition^.section_definition.length;
      IFEND;

      old_reset := old_module.file;
      new_reset := new_module.file;

      pmp$position_object_library (old_module.file, old_position, valid_position);
      IF NOT valid_position THEN
        compare_error (premature_end_of_file, NIL, NIL);
        RETURN;
      IFEND;

      pmp$position_object_library (new_module.file, new_position, valid_position);
      IF NOT valid_position THEN
        compare_error (premature_end_of_file, NIL, NIL);
        RETURN;
      IFEND;

      compare (length, record_kind);
      IF error_in_compare THEN
        RETURN;
      IFEND;

      old_module.file := old_reset;
      new_module.file := new_reset;


    PROCEND compare_allotted_segment_defs;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_OBSOLETE_SEG_DEFS', EJECT ??

    PROCEDURE compare_obsolete_seg_defs;


      compare (#SIZE (llt$obsolete_segment_definition), 'OBSOLETE SEGMENT DEFINITION');


    PROCEND compare_obsolete_seg_defs;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_OBS_ALLOTTED_SEG_DEFS', EJECT ??

    PROCEDURE compare_obs_allotted_seg_defs;


      CONST
        record_kind = 'OBSOLETE ALLOTTED SEGMENT DEFINITION';

      VAR
        old_segment_definition: ^llt$obsolete_segment_definition,
        new_segment_definition: ^llt$obsolete_segment_definition,
        old_position: ost$segment_length,
        new_position: ost$segment_length,
        old_allotted_segment_length: ost$segment_length,
        new_allotted_segment_length: ost$segment_length,
        length: ost$segment_length,
        old_reset: ^SEQ ( * ),
        new_reset: ^SEQ ( * ),
        valid_position: boolean;


      old_position := old_object_text_descriptor^.allotted_segment;
      new_position := new_object_text_descriptor^.allotted_segment;
      old_allotted_segment_length := old_object_text_descriptor^.allotted_segment_length;
      new_allotted_segment_length := new_object_text_descriptor^.allotted_segment_length;

      IF (old_allotted_segment_length <> new_allotted_segment_length) THEN
        compare_error ('OBSOLETE ALLOTTED SEGMENT LENGTH', old_object_text_descriptor,
              new_object_text_descriptor);
      IFEND;

      NEXT old_segment_definition IN old_module.file;
      NEXT new_segment_definition IN new_module.file;
      IF (old_segment_definition = NIL) OR (new_segment_definition = NIL) THEN
        compare_error (premature_end_of_file, NIL, NIL);
        RETURN;
      IFEND;

      IF (old_segment_definition^ <> new_segment_definition^) THEN
        compare_error (record_kind, old_segment_definition, new_segment_definition);
        RETURN;
      IFEND;

?? EJECT ??

      IF (old_allotted_segment_length <> 0) THEN
        length := old_allotted_segment_length;
      ELSE
        length := old_segment_definition^.section_definition.length;
      IFEND;

      old_reset := old_module.file;
      new_reset := new_module.file;

      pmp$position_object_library (old_module.file, old_position, valid_position);
      IF NOT valid_position THEN
        compare_error (premature_end_of_file, NIL, NIL);
        RETURN;
      IFEND;

      pmp$position_object_library (new_module.file, new_position, valid_position);
      IF NOT valid_position THEN
        compare_error (premature_end_of_file, NIL, NIL);
        RETURN;
      IFEND;

      compare (length, record_kind);
      IF error_in_compare THEN
        RETURN;
      IFEND;

      old_module.file := old_reset;
      new_module.file := new_reset;


    PROCEND compare_obs_allotted_seg_defs;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_BIT_STRING_INSERTIONS', EJECT ??

    PROCEDURE compare_bit_string_insertions;


      compare (#SIZE (llt$bit_string_insertion), 'BIT STRING INSERTION');


    PROCEND compare_bit_string_insertions;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_ENTRY_DEFINITIONS', EJECT ??

    PROCEDURE compare_entry_definitions;


      VAR
        old: ^llt$entry_definition,
        new: ^llt$entry_definition;


      NEXT old IN old_module.file;
      NEXT new IN new_module.file;

      IF (old = NIL) OR (new = NIL) THEN
        compare_error (premature_end_of_file, NIL, NIL);
        RETURN;
      IFEND;


      IF old^.section_ordinal = new^.section_ordinal THEN
        IF old^.offset = new^.offset THEN
          IF old^.attributes = new^.attributes THEN
            IF old^.name = new^.name THEN
              IF old^.language = new^.language THEN
                IF old^.declaration_matching_required = new^.declaration_matching_required THEN
                  IF old^.declaration_matching_required THEN
                    IF old^.language = llc$cybil THEN
                      IF (old^.declaration_matching.object_encryption =
                            new^.declaration_matching.object_encryption) AND
                            (old^.declaration_matching.source_encryption =
                            new^.declaration_matching.source_encryption) THEN
                        RETURN;
                      IFEND;
                    ELSE
                      IF old^.declaration_matching.language_dependent_value =
                            new^.declaration_matching.language_dependent_value THEN
                        RETURN;
                      IFEND;
                    IFEND;
                  ELSE
                    RETURN;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;


      compare_error ('ENTRY DEFINITION', old, new);


    PROCEND compare_entry_definitions;
?? OLDTITLE ??
?? NEWTITLE := 'compare_deferred_entry_points', EJECT ??

    PROCEDURE compare_deferred_entry_points
      (    old_size: 1 .. llc$max_deferred_entry_points;
           new_size: 1 .. llc$max_deferred_entry_points);

      CONST
        record_size = 'DEFERRED ENTRY POINT SIZE';

      VAR
        index: 1 .. llc$max_deferred_entry_points,
        new: ^llt$deferred_entry_points,
        old: ^llt$deferred_entry_points;


      IF old_size <> new_size THEN
        compare_error (record_size, old_object_text_descriptor, new_object_text_descriptor);
        RETURN;
      IFEND;

      NEXT old: [1 .. old_size] IN old_module.file;
      NEXT new: [1 .. new_size] IN new_module.file;

      IF (old = NIL) OR (new = NIL) THEN
        compare_error (premature_end_of_file, NIL, NIL);
        RETURN;
      IFEND;

      FOR index := 1 TO old_size DO
        IF (old^ [index].address.ring = new^ [index].address.ring) AND
              (old^ [index].address.segment = new^ [index].address.segment) AND
              (old^ [index].address.offset = new^ [index].address.offset) THEN
          IF old^ [index].section_ordinal = new^ [index].section_ordinal THEN
            IF old^ [index].attributes = new^ [index].attributes THEN
              IF old^ [index].name = new^ [index].name THEN
                IF old^ [index].language = new^ [index].language THEN
                  IF old^ [index].declaration_matching_required = new^ [index].
                        declaration_matching_required THEN
                    IF (old^ [index].binding_section_address.ring = new^ [index].
                          binding_section_address.ring) AND (old^ [index].binding_section_address.segment =
                          new^ [index].binding_section_address.segment) AND
                          (old^ [index].binding_section_address.offset =
                          new^ [index].binding_section_address.offset) THEN
                      IF old^ [index].declaration_matching_required THEN
                        IF old^ [index].language = llc$cybil THEN
                          IF (old^ [index].declaration_matching_value.object_encryption =
                                new^ [index].declaration_matching_value.object_encryption) AND
                                (old^ [index].declaration_matching_value.source_encryption =
                                new^ [index].declaration_matching_value.source_encryption) AND
                                (old^ [index].source_type_checking = new^ [index].source_type_checking) THEN
                            RETURN;
                          IFEND;
                        ELSE
                          IF old^ [index].declaration_matching_value.language_dependent_value =
                                new^ [index].declaration_matching_value.language_dependent_value THEN
                            RETURN;
                          IFEND;
                        IFEND;
                      ELSE
                        RETURN;
                      IFEND;
                    IFEND;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND;

      compare_error ('DEFERRED ENTRY POINTS', old, new);


    PROCEND compare_deferred_entry_points;
?? OLDTITLE ??
?? NEWTITLE := 'compare_deferred_common_blocks', EJECT ??

    PROCEDURE compare_deferred_common_blocks
      (    old_size: 1 .. llc$max_deferred_common_blocks;
           new_size: 1 .. llc$max_deferred_common_blocks);

      CONST
        record_size = 'DEFERRED COMMON BLOCK SIZE';

      VAR
        index: 1 .. llc$max_deferred_common_blocks,
        new: ^llt$deferred_common_blocks,
        old: ^llt$deferred_common_blocks;


      IF old_size <> new_size THEN
        compare_error (record_size, old_object_text_descriptor, new_object_text_descriptor);
        RETURN;
      IFEND;

      NEXT old: [1 .. old_size] IN old_module.file;
      NEXT new: [1 .. new_size] IN new_module.file;

      IF (old = NIL) OR (new = NIL) THEN
        compare_error (premature_end_of_file, NIL, NIL);
        RETURN;
      IFEND;

      FOR index := 1 TO old_size DO
        IF (old^ [index].name = new^ [index].name) AND (old^ [index].global_lock = new^ [index].
              global_lock) AND (old^ [index].loaded_ring = new^ [index].loaded_ring) THEN
          IF (old^ [index].address.ring = new^ [index].address.ring) AND
                (old^ [index].address.segment = new^ [index].address.segment) AND
                (old^ [index].address.offset = new^ [index].address.offset) THEN
            IF (old^ [index].allocation_length = new^ [index].allocation_length) AND
                  (old^ [index].allocation_alignment = new^ [index].allocation_alignment) AND
                  (old^ [index].allocation_offset = new^ [index].allocation_offset) THEN
              IF (old^ [index].access_attributes = new^ [index].access_attributes) AND
                    (old^ [index].segment_access_control = new^ [index].segment_access_control) AND
                    (old^ [index].extensible = new^ [index].extensible) THEN
                IF old^ [index].unallocated_common = new^ [index].unallocated_common THEN
                  IF old^ [index].unallocated_common THEN
                    IF old^ [index].unallocated_common_segment = new^ [index].unallocated_common_segment THEN
                      IF old^ [index].unallocated_common_open = new^ [index].unallocated_common_open THEN
                        IF old^ [index].unallocated_common_open THEN
                          IF old^ [index].unallocated_common_file_id = new^ [index].
                                unallocated_common_file_id THEN
                            RETURN;
                          IFEND;
                        ELSE
                          RETURN;
                        IFEND;
                      IFEND;
                    IFEND;
                  ELSE
                    RETURN;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND;

      compare_error ('DEFERRED COMMON BLOCKS', old, new);


    PROCEND compare_deferred_common_blocks;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_BINDING_TEMPLATE', EJECT ??

    PROCEDURE compare_binding_templates;


      VAR
        old_binding_template: ^llt$binding_template,
        new_binding_template: ^llt$binding_template;


      NEXT old_binding_template IN old_module.file;
      NEXT new_binding_template IN new_module.file;

      IF (old_binding_template = NIL) OR (new_binding_template = NIL) THEN
        compare_error (premature_end_of_file, NIL, NIL);
        RETURN;
      IFEND;


      IF old_binding_template^.binding_offset = new_binding_template^.binding_offset THEN
        IF old_binding_template^.kind = new_binding_template^.kind THEN
          CASE old_binding_template^.kind OF
          = llc$current_module =
            IF old_binding_template^.section_ordinal = new_binding_template^.section_ordinal THEN
              IF old_binding_template^.offset = new_binding_template^.offset THEN
                IF old_binding_template^.internal_address = new_binding_template^.internal_address THEN

                  RETURN;

                IFEND;
              IFEND;
            IFEND;

          = llc$external_reference =
            IF old_binding_template^.name = new_binding_template^.name THEN
              IF old_binding_template^.address = new_binding_template^.address THEN

                RETURN;

              IFEND;
            IFEND;
          ELSE
            compare_error ('Invalid BINDING TEMPLATE kind', NIL, NIL);
            RETURN;
          CASEND;
        IFEND;
      IFEND;


      compare_error ('BINDING TEMPLATE', old_binding_template, new_binding_template);


    PROCEND compare_binding_templates;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_LINE_TABLES', EJECT ??

    PROCEDURE compare_obsolete_line_tables
      (    old_size: integer;
           new_size: integer);


      CONST
        record_size = 'OBSOLETE LINE ADDRESS TABLE SIZE',
        record_kind = 'OBSOLETE LINE ADDRESS TABLE';

      VAR
        i: llt$line_address_table_size,
        old: ^llt$obsolete_line_address_table,
        new: ^llt$obsolete_line_address_table,
        dummy: ost$status;


      IF old_size <> new_size THEN
        compare_error (record_size, old_object_text_descriptor, new_object_text_descriptor);
        RETURN;
      IFEND;


      NEXT old: [1 .. old_size] IN old_module.file;
      NEXT new: [1 .. new_size] IN new_module.file;

      IF (old = NIL) OR (new = NIL) THEN
        compare_error (premature_end_of_file, NIL, NIL);
        RETURN;
      IFEND;


      IF old^.original_name = new^.original_name THEN
        IF old^.optimized_code = new^.optimized_code THEN
          IF old^.language = new^.language THEN
            IF old^.number_of_items = new^.number_of_items THEN

            /error_in_item/
              BEGIN

              /next_item/
                FOR i := 1 TO old^.number_of_items DO
                  IF old^.item [i].line_number = new^.item [i].line_number THEN
                    IF old^.item [i].section_ordinal = new^.item [i].section_ordinal THEN
                      IF old^.item [i].offset = new^.item [i].offset THEN
                        IF old^.item [i].extent = new^.item [i].extent THEN
                          IF old^.item [i].statement_labeled = new^.item [i].statement_labeled THEN
                            IF old^.item [i].breakpoint_permitted = new^.item [i].breakpoint_permitted THEN
                              CASE old^.language OF
                              = llc$cybil =
                                IF old^.item [i].cybil_line_kind = new^.item [i].cybil_line_kind THEN
                                  CYCLE /next_item/;
                                IFEND;
                              ELSE
                                compare_error ('Invalid LINE ADDRESS ITEM kind', NIL, NIL);
                                RETURN;
                              CASEND;
                              EXIT /error_in_item/;
                            IFEND;
                          IFEND;
                        IFEND;
                      IFEND;
                    IFEND;
                  IFEND;

                  EXIT /error_in_item/
                FOREND /next_item/;

                RETURN; {no errors}

              END /error_in_item/;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
      compare_error (record_kind, old, new);


    PROCEND compare_obsolete_line_tables;
?? OLDTITLE ??
?? NEWTITLE := ' COMPARE_LINE_TABLES', EJECT ??

    PROCEDURE compare_line_tables
      (    old_size: integer;
           new_size: integer);


      CONST
        record_size = 'LINE ADDRESS TABLE SIZE',
        record_kind = 'LINE ADDRESS TABLE';


      VAR
        i: llt$line_address_table_size,
        old: ^llt$line_address_table,
        new: ^llt$line_address_table,
        dummy: ost$status;


      IF old_size <> new_size THEN
        compare_error (record_size, old_object_text_descriptor, new_object_text_descriptor);
        RETURN;
      IFEND;


      NEXT old: [1 .. old_size] IN old_module.file;
      NEXT new: [1 .. new_size] IN new_module.file;

      IF (old = NIL) OR (new = NIL) THEN
        compare_error (premature_end_of_file, NIL, NIL);
        RETURN;
      IFEND;



      IF old^.original_module_name = new^.original_module_name THEN
        IF old^.version = new^.version THEN
          IF old^.language = new^.language THEN
            IF old^.optimization_level = new^.optimization_level THEN
              IF old^.number_of_items = new^.number_of_items THEN

              /error_in_item/
                BEGIN

                /next_item/
                  FOR i := 1 TO old^.number_of_items DO
                    IF old^.item [i].line_number = new^.item [i].line_number THEN
                      IF old^.item [i].section_ordinal = new^.item [i].section_ordinal THEN
                        IF old^.item [i].offset = new^.item [i].offset THEN
                          IF old^.item [i].extent = new^.item [i].extent THEN
                            IF old^.item [i].nesting_level = new^.item [i].nesting_level THEN
                              IF old^.item [i].line_attributes = new^.item [i].line_attributes THEN
                                CASE old^.language OF
                                = llc$cybil =
                                  IF old^.item [i].cybil_statement_kind = new^.item [i].
                                       cybil_statement_kind THEN
                                   CYCLE /next_item/;
                                 IFEND;
                               = llc$cobol =
                                 IF old^.item [i].cobol_statement_kind = new^.item [i].
                                       cobol_statement_kind THEN
                                   CYCLE /next_item/;
                                 IFEND;
                               = llc$fortran =
                                 IF old^.item [i].fortran_statement_kind =
                                       new^.item [i].fortran_statement_kind THEN
                                   CYCLE /next_item/;
                                 IFEND;
                               = llc$basic =
                                 IF old^.item [i].basic_statement_kind = new^.item [i].
                                       basic_statement_kind THEN
                                   CYCLE /next_item/;
                                 IFEND;
                               = llc$pascal =
                                 IF old^.item [i].pascal_statement_kind = new^.item [i].
                                       pascal_statement_kind THEN
                                   CYCLE /next_item/;
                                 IFEND;
                               = llc$the_c_language =
                                 IF old^.item [i].c_statement_kind = new^.item [i].
                                       c_statement_kind THEN
                                   CYCLE /next_item/;
                                 IFEND;
                               ELSE
                                 compare_error ('invalid STATEMENT ADDRESS ITEM kind', NIL, NIL);
                                 RETURN;
                               CASEND;
                               EXIT /error_in_item/;
                             IFEND;
                           IFEND;
                         IFEND;
                       IFEND;
                     IFEND;
                   IFEND;


                   EXIT /error_in_item/
                 FOREND /next_item/;
                 RETURN; {no errors}
               END /error_in_item/;
             IFEND;
           IFEND;
         IFEND;
       IFEND;
     IFEND;
     compare_error (record_kind, old, NIL);


   PROCEND compare_line_tables;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_FORM_DEF_RECORDS', EJECT ??

   PROCEDURE compare_form_def_records;

     compare_error ('Form def found in object module', NIL, NIL);

   PROCEND compare_form_def_records;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_PPU_ABSOLUTE_RECORDS', EJECT ??

   PROCEDURE compare_ppu_absolute_records
     (    old_size: integer;
          new_size: integer);


     CONST
       record_size = 'PPU ABSOLUTE SIZE',
       record_kind = 'PPU ABSOLUTE';

     VAR
       dummy: ^llt$ppu_absolute;


     IF old_size <> new_size THEN
       compare_error (record_size, old_object_text_descriptor, new_object_text_descriptor);
       RETURN;
     IFEND;


     PUSH dummy: [0 .. old_size];


     compare (#SIZE (dummy^), record_kind);


   PROCEND compare_ppu_absolute_records;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_68000_ABSOLUTE_RECORDS', EJECT ??

   PROCEDURE compare_68000_absolute_records
     (    old_size: integer;
          new_size: integer);


     CONST
       record_size = 'MOTOROLA 68000 ABSOLUTE SIZE',
       record_kind = 'MOTOROLA 68000 ABSOLUTE';

     VAR
       dummy: ^llt$68000_absolute;


     IF old_size <> new_size THEN
       compare_error (record_size, old_object_text_descriptor, new_object_text_descriptor);
       RETURN;
     IFEND;


     PUSH dummy: [[REP old_size OF cell]];

     compare (#SIZE (dummy^), record_kind);


   PROCEND compare_68000_absolute_records;

?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_APPLICATION_IDENTIFIERS', EJECT ??

   PROCEDURE compare_application_identifiers;


     VAR
       old: ^llt$application_identifier,
       new: ^llt$application_identifier;


     NEXT old IN old_module.file;
     NEXT new IN new_module.file;


     IF (old = NIL) OR (new = NIL) THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;

     IF old^.name = new^.name THEN
       RETURN;
     IFEND;

     compare_error ('APPLICATION_IDENTIFIER', old, new);


   PROCEND compare_application_identifiers;

?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_LIBRARIES', EJECT ??

   PROCEDURE compare_libraries
     (    old_size: integer;
          new_size: integer);


     CONST
       record_size = 'NUMBER OF LIBRARIES',
       record_kind = 'LIBRARIES';

     VAR
       dummy: ^llt$libraries;


     IF old_size <> new_size THEN
       compare_error (record_size, old_object_text_descriptor, new_object_text_descriptor);
       RETURN;
     IFEND;


     PUSH dummy: [1 .. old_size];


     compare (#SIZE (dummy^), record_kind);


   PROCEND compare_libraries;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_TEXT_RECORDS', EJECT ??

   PROCEDURE compare_text_records
     (    old_size: integer;
          new_size: integer);


     CONST
       record_size = 'TEXT SIZE',
       record_kind = 'TEXT';

     VAR
       dummy: ^llt$text;


     IF old_size <> new_size THEN
       compare_error (record_size, old_object_text_descriptor, new_object_text_descriptor);
       RETURN;
     IFEND;


     PUSH dummy: [1 .. old_size];


     compare (#SIZE (dummy^), record_kind);


   PROCEND compare_text_records;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_REPLICATION_RECORDS', EJECT ??

   PROCEDURE compare_replication_records
     (    old_size: integer;
          new_size: integer);


     CONST
       record_size = 'REPLICATION SIZE',
       record_kind = 'REPLICATION';

     VAR
       dummy: ^llt$replication;


     IF old_size <> new_size THEN
       compare_error (record_size, old_object_text_descriptor, new_object_text_descriptor);
       RETURN;
     IFEND;


     PUSH dummy: [1 .. old_size];


     compare (#SIZE (dummy^), record_kind);


   PROCEND compare_replication_records;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_RELOCATION_RECORDS', EJECT ??

   PROCEDURE compare_relocation_records
     (    old_size: integer;
          new_size: integer);


     CONST
       record_size = 'RELOCATION SIZE',
       record_kind = 'RELOCATION';

     VAR
       dummy: ^llt$relocation;


     IF old_size <> new_size THEN
       compare_error (record_size, old_object_text_descriptor, new_object_text_descriptor);
       RETURN;
     IFEND;


     PUSH dummy: [1 .. old_size];


     compare (#SIZE (dummy^), record_kind);


   PROCEND compare_relocation_records;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_ADDRESS_FORMULATIONS', EJECT ??

   PROCEDURE compare_address_formulations
     (    old_size: integer;
          new_size: integer);


     CONST
       record_size = 'ADDRESS FORMULATION SIZE',
       record_kind = 'ADDRESS FORMULATION';

     VAR
       dummy: ^llt$address_formulation;


     IF old_size <> new_size THEN
       compare_error (record_size, old_object_text_descriptor, new_object_text_descriptor);
       RETURN;
     IFEND;


     PUSH dummy: [1 .. old_size];


     compare (#SIZE (dummy^), record_kind);


   PROCEND compare_address_formulations;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_EXTERNAL_LINKAGES', EJECT ??

   PROCEDURE compare_external_linkages
     (    old_size: integer;
          new_size: integer);



     CONST
       record_size = 'EXTERNAL LINKAGE SIZE',
       record_kind = 'EXTERNAL LINKAGE';

     VAR
       declaration_matching_passes: boolean,
       old: ^llt$external_linkage,
       new: ^llt$external_linkage,

       i: integer;


     IF old_size <> new_size THEN
       compare_error (record_size, old_object_text_descriptor, new_object_text_descriptor);
       RETURN;
     IFEND;

     NEXT old: [1 .. old_size] IN old_module.file;
     NEXT new: [1 .. new_size] IN new_module.file;

     IF (old = NIL) OR (new = NIL) THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;


     IF old^.name = new^.name THEN
       IF old^.language = new^.language THEN
         IF old^.declaration_matching_required = new^.declaration_matching_required THEN
           declaration_matching_passes := FALSE;
           IF old^.language = llc$cybil THEN
             IF (old^.declaration_matching.object_encryption =
                   new^.declaration_matching.object_encryption) AND
                   (old^.declaration_matching.source_encryption = new^.declaration_matching.source_encryption)
                   THEN
               declaration_matching_passes := TRUE;
             IFEND;
           ELSE
             IF old^.declaration_matching.language_dependent_value =
                   new^.declaration_matching.language_dependent_value THEN
               declaration_matching_passes := TRUE;
             IFEND;
           IFEND;
           IF (NOT old^.declaration_matching_required) OR declaration_matching_passes THEN

           /error_in_item/
             BEGIN

             /next_item/
               FOR i := 1 TO old_size DO
                 IF old^.item [i].section_ordinal = new^.item [i].section_ordinal THEN
                   IF old^.item [i].offset = new^.item [i].offset THEN
                     IF old^.item [i].kind = new^.item [i].kind THEN
                       IF (NOT ((old^.item [i].kind = llc$address_addition) OR
                             (old^.item [i].kind = llc$address_subtraction))) OR
                             (old^.item [i].offset_operand = new^.item [i].offset_operand) THEN
                         CYCLE /next_item/
                       IFEND;
                     IFEND;
                   IFEND;
                 IFEND;

                 EXIT /error_in_item/;
               FOREND /next_item/;

               RETURN; { no errors }
             END /error_in_item/;
           IFEND;
         IFEND;
       IFEND;
     IFEND;


     compare_error (record_kind, old, new);


   PROCEND compare_external_linkages;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_FORMAL_PARAMETERS', EJECT ??

   PROCEDURE compare_formal_parameters
     (    old_size: integer;
          new_size: integer);


     CONST
       record_size = 'FORMAL PARAMETERS SIZE',
       record_kind = 'FORMAL PARAMETERS';

     VAR
       dummy: ^llt$formal_parameters;


     IF old_size <> new_size THEN
       compare_error (record_size, old_object_text_descriptor, new_object_text_descriptor);
       RETURN;
     IFEND;


     PUSH dummy: [[REP old_size OF cell]];


     compare (#SIZE (dummy^), record_kind);


   PROCEND compare_formal_parameters;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_ACTUAL_PARAMETERS', EJECT ??

   PROCEDURE compare_actual_parameters
     (    old_size: integer;
          new_size: integer);


     CONST
       record_size = 'ACTUAL PARAMETERS SIZE',
       record_kind = 'ACTUAL PARAMETERS';

     VAR
       dummy: ^llt$actual_parameters;


     IF old_size <> new_size THEN
       compare_error (record_size, old_object_text_descriptor, new_object_text_descriptor);
       RETURN;
     IFEND;


     PUSH dummy: [[REP old_size OF cell]];


     compare (#SIZE (dummy^), record_kind);


   PROCEND compare_actual_parameters;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_CYBIL_SYMBOL_TABLES', EJECT ??

   PROCEDURE compare_cybil_symbol_tables
     (    old_size: integer;
          new_size: integer);


     CONST
       cybil_symbol_table_size = 'CYBIL SYMBOL TABLE SIZE',
       cybil_symbol_table = 'CYBIL SYMBOL TABLE';

     VAR
       i: symbol_no,
       old: ^llt$debug_table_fragment,
       new: ^llt$debug_table_fragment,
       old_text: ^SEQ ( * ),
       new_text: ^SEQ ( * ),
       size_of_old_text: ost$segment_length,
       size_of_new_text: ost$segment_length,
       old_symbol_table_header: ^cyt$debug_symbol_table_header,
       new_symbol_table_header: ^cyt$debug_symbol_table_header,
       old_items: ^array [ * ] of cyt$debug_symbol_table_item,
       new_items: ^array [ * ] of cyt$debug_symbol_table_item,
       number_of_symbol_table_items: symbol_no,
       dummy: ost$status;


     IF old_size <> new_size THEN
       compare_error (cybil_symbol_table_size, old_object_text_descriptor, new_object_text_descriptor);
       RETURN;
     IFEND;


     NEXT old: [[REP old_size OF cell]] IN old_module.file;
     NEXT new: [[REP new_size OF cell]] IN new_module.file;

     IF (old = NIL) OR (new = NIL) THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;


     IF old^.offset = new^.offset THEN
       old_text := ^old^.text;
       RESET old_text;
       size_of_old_text := #SIZE (old_text^);
       new_text := ^new^.text;
       RESET new_text;
       size_of_new_text := #SIZE (new_text^);

     /compare_headers/
       BEGIN
         IF size_of_old_text = size_of_new_text THEN
           IF (size_of_old_text MOD #SIZE (cyt$debug_symbol_table_item)) <> 0 THEN
             NEXT old_symbol_table_header IN old_text;
             NEXT new_symbol_table_header IN new_text;
             IF (old_symbol_table_header = NIL) OR (new_symbol_table_header = NIL) THEN
               compare_error (premature_end_of_file, NIL, NIL);
               RETURN;
             IFEND;
             IF old_symbol_table_header^ = new_symbol_table_header^ THEN
               IF old_symbol_table_header^.language = new_symbol_table_header^.language THEN
                 IF old_symbol_table_header^.optimization_level =
                       new_symbol_table_header^.optimization_level THEN
                   IF old_symbol_table_header^.version = new_symbol_table_header^.version THEN
                     IF old_symbol_table_header^.module_symbol_list =
                           new_symbol_table_header^.module_symbol_list THEN
                       IF old_symbol_table_header^.number_of_symbols =
                             new_symbol_table_header^.number_of_symbols THEN
                         size_of_old_text := size_of_old_text - #SIZE (cyt$debug_symbol_table_header);
                         EXIT /compare_headers/;
                       IFEND;
                     IFEND;
                   IFEND;
                 IFEND;
               IFEND;
             IFEND;
             compare_error (cybil_symbol_table, old_symbol_table_header, new_symbol_table_header);
             RETURN;
           IFEND;
         IFEND;
       END /compare_headers/;
       number_of_symbol_table_items := size_of_old_text DIV #SIZE (cyt$debug_symbol_table_item);


       NEXT old_items: [1 .. number_of_symbol_table_items] IN old_text;
       NEXT new_items: [1 .. number_of_symbol_table_items] IN new_text;
       IF (old_items = NIL) OR (new_items = NIL) THEN
         compare_error (premature_end_of_file, NIL, NIL);
         RETURN;
       IFEND;

     /error_in_item/
       BEGIN

       /next_item/
         FOR i := 1 TO number_of_symbol_table_items DO
           IF old_items^ [i].symbol_name = new_items^ [i].symbol_name THEN
             IF old_items^ [i].end_of_chain = new_items^ [i].end_of_chain THEN
               IF old_items^ [i].symtab_no = new_items^ [i].symtab_no THEN
                 IF old_items^ [i].symbol_type = new_items^ [i].symbol_type THEN
                   CASE old_items^ [i].symbol_type OF
                   = int_kind, bool_kind, char_kind, real_kind, longreal_kind, cell_kind =
                     CYCLE /next_item/;
                   = var_kind =
                     IF old_items^ [i].var_type = new_items^ [i].var_type THEN
                       IF old_items^ [i].var_length = new_items^ [i].var_length THEN
                         IF old_items^ [i].base = new_items^ [i].base THEN
                           IF old_items^ [i].var_section_ordinal = new_items^ [i].var_section_ordinal THEN
                             IF old_items^ [i].var_offset = new_items^ [i].var_offset THEN
                               IF old_items^ [i].indirectly_referenced = new_items^ [i].
                                     indirectly_referenced THEN
                                 IF old_items^ [i].var_is_parameter = new_items^ [i].var_is_parameter THEN
                                   CYCLE /next_item/;
                                 IFEND;
                               IFEND;
                             IFEND;
                           IFEND;
                         IFEND;
                       IFEND;
                     IFEND;
                   = cons_kind =
                     IF old_items^ [i].cons_type = new_items^ [i].cons_type THEN
                       IF old_items^ [i].cons_length_type = new_items^ [i].cons_length_type THEN
                         IF old_items^ [i].cons_value = new_items^ [i].cons_value THEN
                           CYCLE /next_item/;
                         IFEND;
                       IFEND;
                     IFEND;
                   = label_kind =
                     IF old_items^ [i].line_no = new_items^ [i].line_no THEN
                       CYCLE /next_item/;
                     IFEND;
                   = ordinal_kind =
                     IF old_items^ [i].last_const = new_items^ [i].last_const THEN
                       IF old_items^ [i].upper_bound = new_items^ [i].upper_bound THEN
                         CYCLE /next_item/;
                       IFEND;
                     IFEND;
                   = subrange_kind =
                     IF old_items^ [i].subtype = new_items^ [i].subtype THEN
                       IF old_items^ [i].low_value_type = new_items^ [i].low_value_type THEN
                         IF old_items^ [i].high_value_type = new_items^ [i].high_value_type THEN
                           IF old_items^ [i].low_value = new_items^ [i].low_value THEN
                             IF old_items^ [i].high_value = new_items^ [i].high_value THEN
                               CYCLE /next_item/;
                             IFEND;
                           IFEND;
                         IFEND;
                       IFEND;
                     IFEND;
                   = proc_kind =
                     IF old_items^ [i].lexical_level = new_items^ [i].lexical_level THEN
                       IF old_items^ [i].symbol_list = new_items^ [i].symbol_list THEN
                         IF old_items^ [i].proc_section_ordinal = new_items^ [i].proc_section_ordinal THEN
                           IF old_items^ [i].proc_offset = new_items^ [i].proc_offset THEN
                             IF old_items^ [i].proc_length = new_items^ [i].proc_length THEN
                               IF old_items^ [i].parent_proc = new_items^ [i].parent_proc THEN
                                 IF old_items^ [i].return_type = new_items^ [i].return_type THEN
                                   CYCLE /next_item/;
                                 IFEND;
                               IFEND;
                             IFEND;
                           IFEND;
                         IFEND;
                       IFEND;
                     IFEND;
                   = pointer_kind =
                     IF old_items^ [i].ptr_type = new_items^ [i].ptr_type THEN
                       IF old_items^ [i].ptr_object_length = new_items^ [i].ptr_object_length THEN
                         CYCLE /next_item/;
                       IFEND;
                     IFEND;
                   = set_kind =
                     IF old_items^ [i].set_element_type = new_items^ [i].set_element_type THEN
                       IF old_items^ [i].set_len = new_items^ [i].set_len THEN
                         CYCLE /next_item/;
                       IFEND;
                     IFEND;
                   = string_kind =
                     IF old_items^ [i].len_type = new_items^ [i].len_type THEN
                       IF old_items^ [i].string_len = new_items^ [i].string_len THEN
                         CYCLE /next_item/;
                       IFEND;
                     IFEND;
                   = array_kind =
                     IF old_items^ [i].array_binding = new_items^ [i].array_binding THEN
                       IF old_items^ [i].array_packing = new_items^ [i].array_packing THEN
                         IF old_items^ [i].length_is_bits = new_items^ [i].length_is_bits THEN
                           IF old_items^ [i].index_type = new_items^ [i].index_type THEN
                             IF old_items^ [i].array_element_type = new_items^ [i].array_element_type THEN
                               IF old_items^ [i].element_length = new_items^ [i].element_length THEN
                                 CYCLE /next_item/;
                               IFEND;
                             IFEND;
                           IFEND;
                         IFEND;
                       IFEND;
                     IFEND;
                   = record_kind =
                     IF old_items^ [i].record_binding = new_items^ [i].record_binding THEN
                       IF old_items^ [i].record_packing = new_items^ [i].record_packing THEN
                         IF old_items^ [i].variation_flag = new_items^ [i].variation_flag THEN
                           IF old_items^ [i].first_field = new_items^ [i].first_field THEN
                             IF old_items^ [i].record_length = new_items^ [i].record_length THEN
                               IF old_items^ [i].selector = new_items^ [i].selector THEN
                                 CYCLE /next_item/;
                               IFEND;
                             IFEND;
                           IFEND;
                         IFEND;
                       IFEND;
                     IFEND;
                   = field_kind =
                     IF old_items^ [i].field_offset = new_items^ [i].field_offset THEN
                       IF old_items^ [i].field_length = new_items^ [i].field_length THEN
                         IF old_items^ [i].unit_addressed = new_items^ [i].unit_addressed THEN
                           IF old_items^ [i].field_type = new_items^ [i].field_type THEN
                             IF old_items^ [i].next_field = new_items^ [i].next_field THEN
                               CYCLE /next_item/;
                             IFEND;
                           IFEND;
                         IFEND;
                       IFEND;
                     IFEND;
                   = selector_kind =
                     IF old_items^ [i].variation = new_items^ [i].variation THEN
                       IF old_items^ [i].next_selector = new_items^ [i].next_selector THEN
                         IF old_items^ [i].low_selector = new_items^ [i].low_selector THEN
                           IF old_items^ [i].high_selector = new_items^ [i].high_selector THEN
                             CYCLE /next_item/;
                           IFEND;
                         IFEND;
                       IFEND;
                     IFEND;
                   = heap_kind =
                     CYCLE /next_item/;
                   = seq_kind =
                     CYCLE /next_item/;
                   = bound_vrec_kind =
                     IF old_items^ [i].bound_type = new_items^ [i].bound_type THEN
                       CYCLE /next_item/;
                     IFEND;
                   = rel_ptr_kind =
                     IF old_items^ [i].parent_type = new_items^ [i].parent_type THEN
                       IF old_items^ [i].object_type = new_items^ [i].object_type THEN
                         IF old_items^ [i].rel_ptr_object_length = new_items^ [i].rel_ptr_object_length THEN
                           CYCLE /next_item/;
                         IFEND;
                       IFEND;
                     IFEND;
                   = error_kind, vstring_spare_kind, union_spare_kind, lbl_typ_spare_kind, nil_kind,
                         parameter_kind, proc_decl_kind, file_kind, union_spare_element_kind, span_elem_kind,
                         module_kind, prong_kind, synonym_kind, last_one, section_kind =
                     CYCLE /next_item/;
                   ELSE
                     compare_error ('Invalid CYBIL SYMBOL TABLE ITEM kind', NIL, NIL);
                     RETURN;
                   CASEND;
                 IFEND;
               IFEND;
             IFEND;
           IFEND;
           EXIT /error_in_item/;
         FOREND /next_item/;

         RETURN; {no errors}

       END /error_in_item/;
     IFEND;

     compare_error (cybil_symbol_table, old_items, new_items);


   PROCEND compare_cybil_symbol_tables;
?? OLDTITLE ??
?? NEWTITLE := '     COMPARE_DEBUG_SYMBOL_TABLES', EJECT ??

   PROCEDURE compare_debug_symbol_tables
     (    old_size: integer;
          new_size: integer);


     CONST
       record_size = 'DEBUG SYMBOL TABLE SIZE',
       record_kind = 'DEBUG SYMBOL TABLE';

     VAR
       i: llt$symbol_number,
       old: ^llt$symbol_table,
       new: ^llt$symbol_table,
       old_text: ^SEQ ( * ),
       new_text: ^SEQ ( * ),
       size_of_old_text: llt$section_length,
       size_of_new_text: llt$section_length,
       old_symbol_table_header: ^llt$debug_symbol_table,
       new_symbol_table_header: ^llt$debug_symbol_table,
       old_items: ^llt$debug_symbol_table,
       new_items: ^llt$debug_symbol_table,
       number_of_symbol_table_items: symbol_no,
       dummy: ost$status;



     IF old_size <> new_size THEN
       compare_error (record_size, old_object_text_descriptor, new_object_text_descriptor);
       RETURN;
     IFEND;


     NEXT old: [[REP old_size OF cell]] IN old_module.file;
     NEXT new: [[REP new_size OF cell]] IN new_module.file;

     IF (old = NIL) OR (new = NIL) THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;


     IF old^.language = new^.language THEN
       old_text := ^old^.text;
       RESET old_text;
       size_of_old_text := #SIZE (old_text^);
       new_text := ^new^.text;
       RESET new_text;
       size_of_new_text := #SIZE (new_text^);

     /compare_headers/
       BEGIN
         IF size_of_old_text = size_of_new_text THEN
           IF (size_of_old_text MOD #SIZE (llt$symbol_table_item)) <> 0 THEN
             NEXT old_symbol_table_header: [1 .. 1] IN old_text;
             NEXT new_symbol_table_header: [1 .. 1] IN new_text;
             IF (old_symbol_table_header = NIL) OR (new_symbol_table_header = NIL) THEN
               compare_error (premature_end_of_file, NIL, NIL);
               RETURN;
             IFEND;
             IF old_symbol_table_header^.original_module_name =
                   new_symbol_table_header^.original_module_name THEN
               IF old_symbol_table_header^.language = new_symbol_table_header^.language THEN
                 IF old_symbol_table_header^.optimization_level =
                       new_symbol_table_header^.optimization_level THEN
                   IF old_symbol_table_header^.version = new_symbol_table_header^.version THEN
                     IF old_symbol_table_header^.first_symbol_for_module =
                           new_symbol_table_header^.first_symbol_for_module THEN
                       IF old_symbol_table_header^.number_of_items =
                             new_symbol_table_header^.number_of_items THEN
                         IF old_symbol_table_header^.attributes = new_symbol_table_header^.attributes THEN
                           EXIT /compare_headers/;
                         IFEND;
                       IFEND;
                     IFEND;
                   IFEND;
                 IFEND;
               IFEND;
             IFEND;
             compare_error (record_kind, old_symbol_table_header, new_symbol_table_header);
             RETURN;
           IFEND;
         IFEND;
       END /compare_headers/;
       number_of_symbol_table_items := old_symbol_table_header^.number_of_items;
       RESET old_text;
       RESET new_text;
       NEXT old_items: [1 .. number_of_symbol_table_items] IN old_text;
       NEXT new_items: [1 .. number_of_symbol_table_items] IN new_text;
       IF (old_items = NIL) OR (new_items = NIL) THEN
         compare_error (premature_end_of_file, NIL, NIL);
         RETURN;
       IFEND;

     /error_in_item/
       BEGIN

       /next_item/
         FOR i := 1 TO number_of_symbol_table_items DO
           IF old_items^.item [i].symbol_name = new_items^.item [i].symbol_name THEN
             IF old_items^.item [i].end_of_chain = new_items^.item [i].end_of_chain THEN
               IF old_items^.item [i].symbol_kind = new_items^.item [i].symbol_kind THEN
                 CASE old_items^.item [i].symbol_kind OF
                 = llc$integer_kind, llc$boolean_kind, llc$char_kind, llc$real_kind, llc$longreal_kind,
                       llc$cell_kind, llc$complex_kind, llc$ftn_logical_kind, llc$ftn_boolean_kind,
                       llc$bit_kind, llc$shortreal_kind, llc$ftn_subprogram_name, llc$ftn_character_kind,
                       llc$typeless_kind, llc$filename_kind, llc$bdp_pdu, llc$bdp_pdulsd, llc$bdp_pds,
                       llc$bdp_pdslsd, llc$bdp_udu, llc$bdp_udtsch, llc$bdp_udtss, llc$bdp_bu, llc$bdp_tpds,
                       llc$bdp_tpdslsd, llc$bdp_tbu, llc$bdp_tbs, llc$bdp_a, llc$cobol_justified,
                       llc$cobol_index_data_item, llc$cobol_index_name, llc$bdp_udlsch, llc$bdp_udlss,
                       llc$cobol_numeric_edited, llc$cobol_a_edited, llc$unsigned_integer_kind =
                   CYCLE /next_item/;
                 = llc$var_kind =
                   IF old_items^.item [i].var_type = new_items^.item [i].var_type THEN
                     IF old_items^.item [i].var_length = new_items^.item [i].var_length THEN
                       IF old_items^.item [i].var_base = new_items^.item [i].var_base THEN
                         IF old_items^.item [i].var_section_ordinal = new_items^.item [i].
                               var_section_ordinal THEN
                           IF old_items^.item [i].var_offset = new_items^.item [i].var_offset THEN
                             IF old_items^.item [i].var_attributes = new_items^.item [i].var_attributes THEN
                               IF old_items^.item [i].var_containing_symbol =
                                     new_items^.item [i].var_containing_symbol THEN
                                 IF old_items^.item [i].var_point_location =
                                       new_items^.item [i].var_point_location THEN
                                   CYCLE /next_item/;
                                 IFEND;
                               IFEND;
                             IFEND;
                           IFEND;
                         IFEND;
                       IFEND;
                     IFEND;
                   IFEND;
                 = llc$cobol_array_kind =
                   IF old_items^.item [i].cobol_array_element_type =
                         new_items^.item [i].cobol_array_element_type THEN
                     IF old_items^.item [i].cobol_subscript_count = new_items^.item [i].
                           cobol_subscript_count THEN
                       IF old_items^.item [i].max_cobol_subscript_value =
                             new_items^.item [i].max_cobol_subscript_value THEN
                         IF old_items^.item [i].occurrence_length = new_items^.item [i].occurrence_length THEN
                           CYCLE /next_item/;
                         IFEND;
                       IFEND;
                     IFEND;
                   IFEND;
                 = llc$constant_kind =
                   IF old_items^.item [i].constant_type = new_items^.item [i].constant_type THEN
                     IF old_items^.item [i].constant_length = new_items^.item [i].constant_length THEN
                       IF old_items^.item [i].constant_kind = new_items^.item [i].constant_kind THEN
                         CASE old_items^.item [i].constant_kind OF
                         = llc$short_constant =
                           IF old_items^.item [i].short_constant_value.kind =
                                 new_items^.item [i].short_constant_value.kind THEN
                             CASE old_items^.item [i].short_constant_value.kind OF
                             = llc$boolean_kind =
                               IF old_items^.item [i].short_constant_value.boolean_value = new_items^.
                                     item [i].short_constant_value.boolean_value THEN
                                 CYCLE /next_item/;
                               IFEND;

                             = llc$char_kind =
                               IF old_items^.item [i].short_constant_value.char_value =
                                     new_items^.item [i].short_constant_value.char_value THEN
                                 CYCLE /next_item/;
                               IFEND;

                             = llc$bit_kind =
                               IF old_items^.item [i].short_constant_value.bit_value =
                                     new_items^.item [i].short_constant_value.bit_value THEN
                                 CYCLE /next_item/;
                               IFEND;

                             = llc$integer_kind =
                               IF old_items^.item [i].short_constant_value.integer_value = new_items^.
                                     item [i].short_constant_value.integer_value THEN
                                 CYCLE /next_item/;
                               IFEND;
                             CASEND;
                           IFEND;
                         = llc$medium_constant =
                           IF old_items^.item [i].medium_constant_value.kind =
                                 new_items^.item [i].medium_constant_value.kind THEN
                             CASE old_items^.item [i].medium_constant_value.kind OF
                             = llc$integer_kind =
                               IF old_items^.item [i].medium_constant_value.integer_value = new_items^.
                                     item [i].medium_constant_value.integer_value THEN
                                 CYCLE /next_item/;
                               IFEND;
                             = llc$real_kind =
                               IF old_items^.item [i].medium_constant_value.real_value =
                                     new_items^.item [i].medium_constant_value.real_value THEN
                                 CYCLE /next_item/;
                               IFEND;
                             = llc$shortreal_kind =
                               IF old_items^.item [i].medium_constant_value.shortreal_value =
                                     new_items^.item [i].medium_constant_value.shortreal_value THEN
                                 CYCLE /next_item/;
                               IFEND;
                             CASEND;
                           IFEND;
                         = llc$long_constant =
                           IF old_items^.item [i].constant_section_ordinal =
                                 new_items^.item [i].constant_section_ordinal THEN
                             IF old_items^.item [i].constant_offset = new_items^.item [i].constant_offset THEN
                               CYCLE /next_item/;
                             IFEND;
                           IFEND;
                         ELSE
                           compare_error ('INVALID DEBUG SYMBOL TABLE ITEM CONSTANT', NIL, NIL);
                           RETURN;
                         CASEND;
                       IFEND;
                     IFEND;
                   IFEND;
                 = llc$label_kind =
                   IF old_items^.item [i].label_attributes = new_items^.item [i].label_attributes THEN
                     IF old_items^.item [i].label_section_ordinal = new_items^.item [i].
                           label_section_ordinal THEN
                       IF old_items^.item [i].label_offset = new_items^.item [i].label_offset THEN
                         IF old_items^.item [i].label_scope = new_items^.item [i].label_scope THEN
                           IF old_items^.item [i].label_containing_symbol =
                                 new_items^.item [i].label_containing_symbol THEN
                             CYCLE /next_item/;
                           IFEND;
                         IFEND;
                       IFEND;
                     IFEND;
                   IFEND;
                 = llc$ordinal_kind =
                   IF old_items^.item [i].last_constant = new_items^.item [i].last_constant THEN
                     IF old_items^.item [i].ordinal_upper_bound = new_items^.item [i].ordinal_upper_bound THEN
                       CYCLE /next_item/;
                     IFEND;
                   IFEND;
                 = llc$subrange_kind =
                   IF old_items^.item [i].subtype = new_items^.item [i].subtype THEN
                     IF old_items^.item [i].low_value_type = new_items^.item [i].low_value_type THEN
                       IF old_items^.item [i].high_value_type = new_items^.item [i].high_value_type THEN
                         IF old_items^.item [i].low_value = new_items^.item [i].low_value THEN
                           IF old_items^.item [i].high_value = new_items^.item [i].high_value THEN
                             CYCLE /next_item/;
                           IFEND;
                         IFEND;
                       IFEND;
                     IFEND;
                   IFEND;
                 = llc$proc_kind =
                   IF old_items^.item [i].proc_lexical_level = new_items^.item [i].proc_lexical_level THEN
                     IF old_items^.item [i].first_symbol_for_proc = new_items^.item [i].
                           first_symbol_for_proc THEN
                       IF old_items^.item [i].proc_section_ordinal = new_items^.item [i].
                             proc_section_ordinal THEN
                         IF old_items^.item [i].proc_offset = new_items^.item [i].proc_offset THEN
                           IF old_items^.item [i].proc_length = new_items^.item [i].proc_length THEN
                             IF old_items^.item [i].proc_parent = new_items^.item [i].proc_parent THEN
                               IF old_items^.item [i].proc_attributes = new_items^.item [i].
                                     proc_attributes THEN
                                 IF old_items^.item [i].proc_return_type =
                                       new_items^.item [i].proc_return_type THEN
                                   IF old_items^.item [i].proc_return_length =
                                       new_items^.item [i].proc_return_length THEN
                                   CYCLE /next_item/;
                                 IFEND;
                               IFEND;
                             IFEND;
                           IFEND;
                         IFEND;
                       IFEND;
                     IFEND;
                   IFEND;
                 IFEND;
               = llc$pointer_kind =
                 IF old_items^.item [i].ptr_type = new_items^.item [i].ptr_type THEN
                   IF old_items^.item [i].ptr_object_length = new_items^.item [i].ptr_object_length THEN
                     CYCLE /next_item/;
                   IFEND;
                 IFEND;
               = llc$set_kind =
                 IF old_items^.item [i].set_element_type = new_items^.item [i].set_element_type THEN
                   IF old_items^.item [i].set_length = new_items^.item [i].set_length THEN
                     CYCLE /next_item/;
                   IFEND;
                 IFEND;
               = llc$string_kind =
                 IF old_items^.item [i].string_length_type = new_items^.item [i].string_length_type THEN
                   IF old_items^.item [i].string_length = new_items^.item [i].string_length THEN
                     CYCLE /next_item/;
                   IFEND;
                 IFEND;
               = llc$cybil_array_kind =
                 IF old_items^.item [i].cybil_array_binding = new_items^.item [i].cybil_array_binding THEN
                   IF old_items^.item [i].cybil_array_packing = new_items^.item [i].cybil_array_packing THEN
                     IF old_items^.item [i].cybil_array_attributes =
                           new_items^.item [i].cybil_array_attributes THEN
                       IF old_items^.item [i].cybil_index_type = new_items^.item [i].cybil_index_type THEN
                         IF old_items^.item [i].cybil_array_element_type =
                               new_items^.item [i].cybil_array_element_type THEN
                           IF old_items^.item [i].cybil_array_element_length =
                                 new_items^.item [i].cybil_array_element_length THEN
                             CYCLE /next_item/;
                           IFEND;
                         IFEND;
                       IFEND;
                     IFEND;
                   IFEND;
                 IFEND;
               = llc$record_kind =
                 IF old_items^.item [i].record_binding = new_items^.item [i].record_binding THEN
                   IF old_items^.item [i].record_packing = new_items^.item [i].record_packing THEN
                     IF old_items^.item [i].record_attributes = new_items^.item [i].record_attributes THEN
                       IF old_items^.item [i].record_first_field = new_items^.item [i].record_first_field THEN
                         IF old_items^.item [i].record_length = new_items^.item [i].record_length THEN
                           IF old_items^.item [i].record_selector = new_items^.item [i].record_selector THEN
                             CYCLE /next_item/;
                           IFEND;
                         IFEND;
                       IFEND;
                     IFEND;
                   IFEND;
                 IFEND;
               = llc$field_kind =
                 IF old_items^.item [i].field_offset = new_items^.item [i].field_offset THEN
                   IF old_items^.item [i].field_length = new_items^.item [i].field_length THEN
                     IF old_items^.item [i].field_attributes = new_items^.item [i].field_attributes THEN
                       IF old_items^.item [i].field_type = new_items^.item [i].field_type THEN
                         IF old_items^.item [i].next_field = new_items^.item [i].next_field THEN
                           CYCLE /next_item/;
                         IFEND;
                       IFEND;
                     IFEND;
                   IFEND;
                 IFEND;
               = llc$selector_kind =
                 IF old_items^.item [i].variation = new_items^.item [i].variation THEN
                   IF old_items^.item [i].next_selector = new_items^.item [i].next_selector THEN
                     IF old_items^.item [i].low_selector = new_items^.item [i].low_selector THEN
                       IF old_items^.item [i].high_selector = new_items^.item [i].high_selector THEN
                         CYCLE /next_item/;
                       IFEND;
                     IFEND;
                   IFEND;
                 IFEND;
               = llc$heap_kind =
                 CYCLE /next_item/;
               = llc$seq_kind =
                 CYCLE /next_item/;
               = llc$bound_vrec_kind =
                 IF old_items^.item [i].bound_type = new_items^.item [i].bound_type THEN
                   CYCLE /next_item/;
                 IFEND;
               = llc$rel_ptr_kind =
                 IF old_items^.item [i].parent_type = new_items^.item [i].parent_type THEN
                   IF old_items^.item [i].object_type = new_items^.item [i].object_type THEN
                     IF old_items^.item [i].rel_ptr_object_length = new_items^.item [i].
                           rel_ptr_object_length THEN
                       CYCLE /next_item/;
                     IFEND;
                   IFEND;
                 IFEND;
               = llc$ftn_array_kind =
                 IF old_items^.item [i].ftn_array_element_type = new_items^.item [i].
                       ftn_array_element_type THEN
                   IF old_items^.item [i].ftn_array_element_length =
                         new_items^.item [i].ftn_array_element_length THEN
                     IF old_items^.item [i].ftn_array_base = new_items^.item [i].ftn_array_base THEN
                       IF old_items^.item [i].ftn_array_section_ordinal =
                             new_items^.item [i].ftn_array_section_ordinal THEN
                         IF old_items^.item [i].ftn_array_offset = new_items^.item [i].ftn_array_offset THEN
                           IF old_items^.item [i].ftn_array_attributes =
                                 new_items^.item [i].ftn_array_attributes THEN
                             IF old_items^.item [i].dimension_info_section_ordinal =
                                   new_items^.item [i].dimension_info_section_ordinal THEN
                               IF old_items^.item [i].dimension_info_offset =
                                     new_items^.item [i].dimension_info_offset THEN
                                 CYCLE /next_item/;
                               IFEND;
                             IFEND;
                           IFEND;
                         IFEND;
                       IFEND;
                     IFEND;
                   IFEND;
                 IFEND;
               = llc$namelist_group_kind =
                 IF old_items^.item [i].namelist_info_section_ordinal =
                       new_items^.item [i].namelist_info_section_ordinal THEN
                   IF old_items^.item [i].namelist_info_offset = new_items^.item [i].namelist_info_offset THEN
                     CYCLE /next_item/;
                   IFEND;
                 IFEND;
               = llc$equated_label =
                 IF old_items^.item [i].first_equated_symbol = new_items^.item [i].first_equated_symbol THEN
                   CYCLE /next_item/;
                 IFEND;
               = llc$external_equate =
                 IF old_items^.item [i].operation = new_items^.item [i].operation THEN
                   IF old_items^.item [i].operand = new_items^.item [i].operand THEN
                     CYCLE /next_item/;
                   IFEND;
                 IFEND;
               = llc$basic_array_kind =
                 IF old_items^.item [i].basic_array_element_type =
                       new_items^.item [i].basic_array_element_type THEN
                   CYCLE /next_item/;
                 IFEND;
               = llc$pascal_conf_array_kind =
                 IF old_items^.item [i].conf_array_packing = new_items^.item [i].conf_array_packing THEN
                   IF old_items^.item [i].conf_array_attributes = new_items^.item [i].
                         conf_array_attributes THEN
                     IF old_items^.item [i].conf_array_lower_bound =
                           new_items^.item [i].conf_array_lower_bound THEN
                       IF old_items^.item [i].conf_array_upper_bound =
                             new_items^.item [i].conf_array_upper_bound THEN
                         IF old_items^.item [i].conf_array_element_kind =
                               new_items^.item [i].conf_array_element_kind THEN
                           IF old_items^.item [i].conf_array_element_length =
                                 new_items^.item [i].conf_array_element_length THEN
                             CYCLE /next_item/;
                           IFEND;
                         IFEND;
                       IFEND;
                     IFEND;
                   IFEND;
                 IFEND;
               = llc$pascal_file_kind =
                 IF old_items^.item [i].buffer_type = new_items^.item [i].buffer_type THEN
                   CYCLE /next_item/;
                 IFEND;
               = llc$pascal_with_kind =
                 IF old_items^.item [i].with_first_symbol = new_items^.item [i].with_first_symbol THEN
                   IF old_items^.item [i].with_section_ordinal = new_items^.item [i].with_section_ordinal THEN
                     IF old_items^.item [i].with_offset = new_items^.item [i].with_offset THEN
                       IF old_items^.item [i].with_length = new_items^.item [i].with_length THEN
                         IF old_items^.item [i].with_parent = new_items^.item [i].with_parent THEN
                           CYCLE /next_item/;
                         IFEND;
                       IFEND;
                     IFEND;
                   IFEND;
                 IFEND;
               ELSE
                 compare_error ('invalid DEBUG SYMBOL TABLE ITEM kind', NIL, NIL);
                 RETURN;
               CASEND;
             IFEND;
           IFEND;
         IFEND;
         EXIT /error_in_item/;
       FOREND /next_item/;
       RETURN; {no errors}

     END /error_in_item/;
   IFEND;

   compare_error (record_kind, old_items, new_items);

 PROCEND compare_debug_symbol_tables;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_SUPPLEMENTAL_DTABLES', EJECT ??

 PROCEDURE compare_supplemental_dtables
   (    old_size: integer;
        new_size: integer);

  VAR
    new: ^string ( * ),
    old: ^string ( * );

{ CV2 uses the supplemental debug table to store file names and time stamps for the included
{ files.  This information varies for every compilation.  Therefore, a difference will always
{ be detected, but it does not indicate that a significant change has occurred.  This table
{ will be skipped.

   NEXT old: [old_size] IN old_module.file;
   NEXT new: [new_size] IN new_module.file;
   RETURN;

 PROCEND compare_supplemental_dtables;

?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_OBS_FORMAL_PARAMETERS', EJECT ??

 PROCEDURE compare_obs_formal_parameters
   (    old_size: integer;
        new_size: integer);

   CONST
     record_size = 'OBSOLETE FORMAL PARAMETERS SIZE',
     record_kind = 'OBSOLETE FORMAL PARAMETERS';

   VAR
     dummy: ^llt$obsolete_formal_parameters;

   IF old_size <> new_size THEN
     compare_error (record_size, old_object_text_descriptor, new_object_text_descriptor);
     RETURN;
   IFEND;

   PUSH dummy: [[REP old_size OF cell]];

   compare (#SIZE (dummy^), record_kind);

 PROCEND compare_obs_formal_parameters;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_UNALLOC_COMMON_BLOCKS', EJECT ??

 PROCEDURE compare_unalloc_common_blocks;

   compare (#SIZE (llt$section_definition), 'UNALLOCATED COMMON BLOCK');

 PROCEND compare_unalloc_common_blocks;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_INTERPRETIVE_RECORDS', EJECT ??

 PROCEDURE compare_interpretive_records;


   record_number := record_number + 1;

   compare_identification_records;


   WHILE NOT error_in_compare DO
     record_number := record_number + 1;

     compare_object_text_descriptors (old_object_text_descriptor, new_object_text_descriptor);
     IF error_in_compare THEN
       RETURN;
     IFEND;

     CASE old_object_text_descriptor^.kind OF
     = llc$transfer_symbol =
       compare_transfer_symbols;
       RETURN;

     = llc$ppu_absolute =
       compare_ppu_absolute_records (old_object_text_descriptor^.number_of_words,
             new_object_text_descriptor^.number_of_words);
       RETURN;

     = llc$form_definition =
       compare_form_def_records;
       RETURN;

     = llc$68000_absolute =
       compare_68000_absolute_records (old_object_text_descriptor^.number_of_words,
             new_object_text_descriptor^.number_of_words);
       RETURN;

     = llc$application_identifier =
       compare_application_identifiers;

     = llc$libraries =
       compare_libraries (old_object_text_descriptor^.number_of_libraries,
             new_object_text_descriptor^.number_of_libraries);

     = llc$section_definition =
       compare_section_definitions;

     = llc$allotted_section_definition =
       compare_allotted_section_defs (old_object_text_descriptor^.allotted_section,
             new_object_text_descriptor^.allotted_section);

     = llc$segment_definition =
       compare_segment_definitions;

     = llc$allotted_segment_definition =
       compare_allotted_segment_defs;

     = llc$obsolete_segment_definition =
       compare_obsolete_seg_defs;

     = llc$obsolete_allotted_seg_def =
       compare_obs_allotted_seg_defs;

     = llc$text =
       compare_text_records (old_object_text_descriptor^.number_of_bytes,
             new_object_text_descriptor^.number_of_bytes);

     = llc$replication =
       compare_replication_records (old_object_text_descriptor^.number_of_bytes,
             new_object_text_descriptor^.number_of_bytes);

     = llc$bit_string_insertion =
       compare_bit_string_insertions;

     = llc$entry_definition =
       compare_entry_definitions;

     = llc$deferred_entry_points =
       compare_deferred_entry_points (old_object_text_descriptor^.number_of_entry_points,
             new_object_text_descriptor^.number_of_entry_points);

     = llc$deferred_common_blocks =
       compare_deferred_common_blocks (old_object_text_descriptor^.number_of_common_blocks,
             new_object_text_descriptor^.number_of_common_blocks);

     = llc$relocation =
       compare_relocation_records (old_object_text_descriptor^.number_of_rel_items,
             new_object_text_descriptor^.number_of_rel_items);

     = llc$address_formulation =
       compare_address_formulations (old_object_text_descriptor^.number_of_adr_items,
             new_object_text_descriptor^.number_of_adr_items);

     = llc$external_linkage =
       compare_external_linkages (old_object_text_descriptor^.number_of_ext_items,
             new_object_text_descriptor^.number_of_ext_items);

     = llc$formal_parameters =
       compare_formal_parameters (old_object_text_descriptor^.sequence_length,
             new_object_text_descriptor^.sequence_length);

     = llc$actual_parameters =
       compare_actual_parameters (old_object_text_descriptor^.sequence_length,
             new_object_text_descriptor^.sequence_length);

     = llc$binding_template =
       compare_binding_templates;

     = llc$obsolete_line_table =
       compare_obsolete_line_tables (old_object_text_descriptor^.number_of_line_items,
             new_object_text_descriptor^.number_of_line_items);

     = llc$line_table =
       compare_line_tables (old_object_text_descriptor^.number_of_line_items,
             new_object_text_descriptor^.number_of_line_items);

     = llc$cybil_symbol_table_fragment =
       compare_cybil_symbol_tables (old_object_text_descriptor^.sequence_length,
             new_object_text_descriptor^.sequence_length);

     = llc$symbol_table =
       compare_debug_symbol_tables (old_object_text_descriptor^.sequence_length,
             new_object_text_descriptor^.sequence_length);

     = llc$supplemental_debug_tables =
       compare_supplemental_dtables (old_object_text_descriptor^.sequence_length,
             new_object_text_descriptor^.sequence_length);

     = llc$obsolete_formal_parameters =
       compare_obs_formal_parameters (old_object_text_descriptor^.sequence_length,
             new_object_text_descriptor^.sequence_length);

     = llc$unallocated_common_block =
       compare_unalloc_common_blocks;

     ELSE
       compare_error ('INVALID OBJECT RECORD KIND', NIL, NIL);
     CASEND;
   WHILEND;


 PROCEND compare_interpretive_records;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_CPU_OBJECT_MODULES' ??
?? NEWTITLE := '    COMPARE_PPU_OBJECT_MODULES', EJECT ??

 PROCEDURE compare_cpu_object_modules;


   RESET old_module.file TO old_module.cpu_object_module_header^.identification;
   RESET new_module.file TO new_module.cpu_object_module_header^.identification;

   compare_interpretive_records;


 PROCEND compare_cpu_object_modules;
?? OLDTITLE ??






 PROCEDURE compare_ppu_object_modules;


   RESET old_module.file TO old_module.ppu_object_module_header;
   RESET new_module.file TO new_module.ppu_object_module_header;

   compare_interpretive_records;


 PROCEND compare_ppu_object_modules;
?? OLDTITLE ??
?? NEWTITLE := 'compare_library_member_headers', EJECT ??

 PROCEDURE compare_library_member_headers;

{ The purpose of this procedure is to compare two library member headers.

   VAR
     errors: boolean,
     new_aliases_p: ^pmt$module_list,
     new_header_p: ^llt$library_member_header,
     old_aliases_p: ^pmt$module_list,
     old_header_p: ^llt$library_member_header;

   NEXT old_header_p IN old_module.file;
   NEXT new_header_p IN new_module.file;

   IF (old_header_p = NIL) OR (new_header_p = NIL) THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   errors := TRUE;

   IF old_header_p^.name = new_header_p^.name THEN
     IF old_header_p^.kind = new_header_p^.kind THEN
       IF old_header_p^.generator_id = new_header_p^.generator_id THEN
         IF old_header_p^.generator_name_vers = new_header_p^.generator_name_vers THEN
           IF old_header_p^.commentary = new_header_p^.commentary THEN
             IF old_header_p^.member_size = new_header_p^.member_size THEN
               IF old_header_p^.number_of_aliases = new_header_p^.number_of_aliases THEN
                 IF old_header_p^.command_function_availability =
                       new_header_p^.command_function_availability THEN
                   IF old_header_p^.command_function_kind = new_header_p^.command_function_kind THEN
                     IF old_header_p^.command_log_option = new_header_p^.command_log_option THEN

                       errors := FALSE;

                     IFEND;
                   IFEND;
                 IFEND;
               IFEND;
             IFEND;
           IFEND;
         IFEND;
       IFEND;
     IFEND;
   IFEND;

   IF errors THEN
     compare_error ('LIBRARY MEMBER HEADER', old_header_p, new_header_p);
     RETURN;
   IFEND;

   IF old_header_p^.number_of_aliases <> 0 THEN
     old_aliases_p := #PTR (old_header_p^.aliases, old_module.file^);
     IF old_aliases_p = NIL THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;

     new_aliases_p := #PTR (new_header_p^.aliases, new_module.file^);
     IF new_aliases_p = NIL THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;

     RESET old_module.file TO old_aliases_p;
     RESET new_module.file TO new_aliases_p;

     compare ((old_header_p^.number_of_aliases * #SIZE (pmt$program_name)), 'ALIASES');
   IFEND;

 PROCEND compare_library_member_headers;
?? OLDTITLE ??
?? NEWTITLE := 'compare_program_attributes', EJECT ??

 PROCEDURE compare_program_attributes
   (VAR old_member_p: ^SEQ ( * );
    VAR new_member_p: ^SEQ ( * ));

{ The purpose of this procedure is to compare two groups of program attributes.

   VAR
     new_conditions_p: ^pmt$enable_inhibit_conditions,
     new_module_list_p: ^pmt$module_list,
     new_object_file_list_p: ^llt$object_file_list,
     new_object_library_list_p: ^llt$object_library_list,
     new_program_attributes_p: ^llt$program_attributes,
     old_conditions_p: ^pmt$enable_inhibit_conditions,
     old_module_list_p: ^pmt$module_list,
     old_object_file_list_p: ^llt$object_file_list,
     old_object_library_list_p: ^llt$object_library_list,
     old_program_attributes_p: ^llt$program_attributes;

   NEXT old_program_attributes_p IN old_member_p;
   IF old_program_attributes_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   NEXT new_program_attributes_p IN new_member_p;
   IF new_program_attributes_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   RESET old_module.file TO old_program_attributes_p;
   RESET new_module.file TO new_program_attributes_p;

   IF (old_program_attributes_p^.contents <> new_program_attributes_p^.contents) THEN
     compare_error ('PROGRAM DESCRIPTION', old_program_attributes_p, new_program_attributes_p);
     RETURN;
   IFEND;

   IF (pmc$starting_proc_specified IN old_program_attributes_p^.contents) THEN
     IF (old_program_attributes_p^.starting_procedure <> new_program_attributes_p^.starting_procedure) THEN
       compare_error ('PROGRAM DESCRIPTION', old_program_attributes_p, new_program_attributes_p);
       RETURN;
     IFEND;
   IFEND;

   IF (pmc$load_map_file_specified IN old_program_attributes_p^.contents) THEN
     IF (old_program_attributes_p^.load_map_file <> new_program_attributes_p^.load_map_file) THEN
       compare_error ('PROGRAM DESCRIPTION', old_program_attributes_p, new_program_attributes_p);
       RETURN;
     IFEND;
   IFEND;

   IF (pmc$load_map_options_specified IN old_program_attributes_p^.contents) THEN
     IF (old_program_attributes_p^.load_map_options <> new_program_attributes_p^.load_map_options) THEN
       compare_error ('PROGRAM DESCRIPTION', old_program_attributes_p, new_program_attributes_p);
       RETURN;
     IFEND;
   IFEND;

   IF (pmc$term_error_level_specified IN old_program_attributes_p^.contents) THEN
     IF (old_program_attributes_p^.termination_error_level <>
           new_program_attributes_p^.termination_error_level) THEN
       compare_error ('PROGRAM DESCRIPTION', old_program_attributes_p, new_program_attributes_p);
       RETURN;
     IFEND;
   IFEND;

   IF (pmc$preset_specified IN old_program_attributes_p^.contents) THEN
     IF (old_program_attributes_p^.preset <> new_program_attributes_p^.preset) THEN
       compare_error ('PROGRAM DESCRIPTION', old_program_attributes_p, new_program_attributes_p);
       RETURN;
     IFEND;
   IFEND;

   IF (pmc$max_stack_size_specified IN old_program_attributes_p^.contents) THEN
     IF (old_program_attributes_p^.maximum_stack_size <> new_program_attributes_p^.maximum_stack_size) THEN
       compare_error ('PROGRAM DESCRIPTION', old_program_attributes_p, new_program_attributes_p);
       RETURN;
     IFEND;
   IFEND;

   IF (pmc$debug_input_specified IN old_program_attributes_p^.contents) THEN
     IF (old_program_attributes_p^.debug_input <> new_program_attributes_p^.debug_input) THEN
       compare_error ('PROGRAM DESCRIPTION', old_program_attributes_p, new_program_attributes_p);
       RETURN;
     IFEND;
   IFEND;

   IF (pmc$debug_output_specified IN old_program_attributes_p^.contents) THEN
     IF (old_program_attributes_p^.debug_output <> new_program_attributes_p^.debug_output) THEN
       compare_error ('PROGRAM DESCRIPTION', old_program_attributes_p, new_program_attributes_p);
       RETURN;
     IFEND;
   IFEND;

   IF (pmc$abort_file_specified IN old_program_attributes_p^.contents) THEN
     IF (old_program_attributes_p^.abort_file <> new_program_attributes_p^.abort_file) THEN
       compare_error ('PROGRAM DESCRIPTION', old_program_attributes_p, new_program_attributes_p);
       RETURN;
     IFEND;
   IFEND;

   IF (pmc$debug_mode_specified IN old_program_attributes_p^.contents) THEN
     IF (old_program_attributes_p^.debug_mode <> new_program_attributes_p^.debug_mode) THEN
       compare_error ('PROGRAM DESCRIPTION', old_program_attributes_p, new_program_attributes_p);
       RETURN;
     IFEND;
   IFEND;

   IF (pmc$object_file_list_specified IN old_program_attributes_p^.contents) THEN
     IF (old_program_attributes_p^.number_of_object_files = new_program_attributes_p^.number_of_object_files)
           THEN
       NEXT old_object_file_list_p: [1 .. old_program_attributes_p^.number_of_object_files] IN old_member_p;
       IF old_object_file_list_p = NIL THEN
         compare_error (premature_end_of_file, NIL, NIL);
         RETURN;
       IFEND;
       NEXT new_object_file_list_p: [1 .. new_program_attributes_p^.number_of_object_files] IN new_member_p;
       IF new_object_file_list_p = NIL THEN
         compare_error (premature_end_of_file, NIL, NIL);
         RETURN;
       IFEND;
       RESET old_module.file TO old_object_file_list_p;
       RESET new_module.file TO new_object_file_list_p;
       compare (old_program_attributes_p^.number_of_object_files * #SIZE (amt$local_file_name),
             'PROGRAM DESCRIPTION');
       IF error_in_compare THEN
         RETURN;
       IFEND;
     ELSE
       compare_error ('PROGRAM DESCRIPTION', old_program_attributes_p, new_program_attributes_p);
       RETURN;
     IFEND;
   IFEND;

   IF (pmc$module_list_specified IN old_program_attributes_p^.contents) THEN
     IF (old_program_attributes_p^.number_of_modules = new_program_attributes_p^.number_of_modules) THEN
       NEXT old_module_list_p: [1 .. old_program_attributes_p^.number_of_modules] IN old_member_p;
       IF old_module_list_p = NIL THEN
         compare_error (premature_end_of_file, NIL, NIL);
         RETURN;
       IFEND;
       NEXT new_module_list_p: [1 .. new_program_attributes_p^.number_of_modules] IN new_member_p;
       IF new_module_list_p = NIL THEN
         compare_error (premature_end_of_file, NIL, NIL);
         RETURN;
       IFEND;
       RESET old_module.file TO old_module_list_p;
       RESET new_module.file TO new_module_list_p;
       compare (old_program_attributes_p^.number_of_modules * #SIZE (pmt$program_name),
             'PROGRAM DESCRIPTION');
       IF error_in_compare THEN
         RETURN;
       IFEND;
     ELSE
       compare_error ('PROGRAM DESCRIPTION', old_program_attributes_p, new_program_attributes_p);
       RETURN;
     IFEND;
   IFEND;

   IF (pmc$library_list_specified IN old_program_attributes_p^.contents) THEN
     IF (old_program_attributes_p^.number_of_libraries = new_program_attributes_p^.number_of_libraries) THEN
       NEXT old_object_library_list_p: [1 .. old_program_attributes_p^.number_of_libraries] IN old_member_p;
       IF old_object_library_list_p = NIL THEN
         compare_error (premature_end_of_file, NIL, NIL);
         RETURN;
       IFEND;
       NEXT new_object_library_list_p: [1 .. new_program_attributes_p^.number_of_libraries] IN new_member_p;
       IF new_object_library_list_p = NIL THEN
         compare_error (premature_end_of_file, NIL, NIL);
         RETURN;
       IFEND;
       RESET old_module.file TO old_object_library_list_p;
       RESET new_module.file TO new_object_library_list_p;
       compare (old_program_attributes_p^.number_of_libraries * #SIZE (amt$local_file_name),
             'PROGRAM DESCRIPTION');
       IF error_in_compare THEN
         RETURN;
       IFEND;
     ELSE
       compare_error ('PROGRAM DESCRIPTION', old_program_attributes_p, new_program_attributes_p);
       RETURN;
     IFEND;
   IFEND;

   IF (pmc$condition_specified IN old_program_attributes_p^.contents) THEN
     NEXT old_conditions_p IN old_member_p;
     IF old_conditions_p = NIL THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;
     NEXT new_conditions_p IN new_member_p;
     IF new_conditions_p = NIL THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;
     RESET old_module.file TO old_conditions_p;
     RESET new_module.file TO new_conditions_p;
     compare (#SIZE (pmt$enable_inhibit_conditions), 'PROGRAM DESCRIPTION');
   IFEND;
 PROCEND compare_program_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'compare_program_descriptions', EJECT ??

 PROCEDURE compare_program_descriptions;

{ The purpose of this procedure is to compare two program descriptions.

   VAR
     new_header_p: ^llt$library_member_header,
     new_member_p: ^SEQ ( * ),
     old_header_p: ^llt$library_member_header,
     old_member_p: ^SEQ ( * );

   RESET old_module.file TO old_module.program_description_header;
   RESET new_module.file TO new_module.program_description_header;

   compare_library_member_headers;

   IF error_in_compare THEN
     RETURN;
   IFEND;

{ Pointers old_header_p and new_header_p won't be NIL here. That would have
{ been caught by compare_library_member_headers.

   old_header_p := old_module.program_description_header;
   new_header_p := new_module.program_description_header;

   old_member_p := #PTR (old_header_p^.member, old_module.file^);
   IF old_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   new_member_p := #PTR (new_header_p^.member, new_module.file^);
   IF new_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   RESET old_member_p;
   RESET new_member_p;

   compare_program_attributes (old_member_p, new_member_p);

 PROCEND compare_program_descriptions;
?? OLDTITLE ??
?? NEWTITLE := 'compare_command_procedures', EJECT ??

 PROCEDURE compare_command_procedures;

{ The purpose of this procedure is to compare two command procedures.

   VAR
     new_header_p: ^llt$library_member_header,
     new_member_p: ^SEQ ( * ),
     new_scl_procedure_p: ^SEQ ( * ),
     old_header_p: ^llt$library_member_header,
     old_member_p: ^SEQ ( * ),
     old_scl_procedure_p: ^SEQ ( * );

   RESET old_module.file TO old_module.command_procedure_header;
   RESET new_module.file TO new_module.command_procedure_header;

   compare_library_member_headers;

   IF error_in_compare THEN
     RETURN;
   IFEND;

{ Pointers old_header_p and new_header_p won't be NIL here. That would have
{ been caught by compare_library_member_headers.

   old_header_p := old_module.command_procedure_header;
   new_header_p := new_module.command_procedure_header;

   old_member_p := #PTR (old_header_p^.member, old_module.file^);
   IF old_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   new_member_p := #PTR (new_header_p^.member, new_module.file^);
   IF new_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   RESET old_member_p;
   RESET new_member_p;

   NEXT old_scl_procedure_p: [[REP old_header_p^.member_size OF cell]] IN old_member_p;
   IF old_scl_procedure_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;
   NEXT new_scl_procedure_p: [[REP new_header_p^.member_size OF cell]] IN new_member_p;
   IF new_scl_procedure_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;
   compare_scl_procedures (old_scl_procedure_p, new_scl_procedure_p);
 PROCEND compare_command_procedures;
?? OLDTITLE ??
?? NEWTITLE := 'compare_scl_procedures', EJECT ??

 PROCEDURE compare_scl_procedures
   (VAR old_scl_procedure_p: ^SEQ ( * );
    VAR new_scl_procedure_p: ^SEQ ( * ));

{ The purpose of this procedure is to compare two SCL procedures.

   VAR
     ignore_status: ost$status,
     new_line_p: ^clt$command_line,
     old_line_p: ^clt$command_line;

{ Compare SCL procedures line-by-line. Procedure clp$get_next_scl_proc_line
{ advances pointers old_scl_procedure_p and new_scl_procedure_p.

   WHILE TRUE DO
     clp$get_next_scl_proc_line (old_scl_procedure_p, old_line_p, ignore_status);
     clp$get_next_scl_proc_line (new_scl_procedure_p, new_line_p, ignore_status);
     IF (old_line_p = NIL) OR (new_line_p = NIL) THEN
       IF (old_line_p = NIL) AND (new_line_p = NIL) THEN
         RETURN;
       ELSE
         compare_error (premature_end_of_file, NIL, NIL);
         RETURN;
       IFEND;
     ELSE
       IF (old_line_p^ <> new_line_p^) THEN
         compare_error ('SCL PROCEDURE', old_line_p, new_line_p);
         RETURN;
       IFEND;
     IFEND;
   WHILEND;
 PROCEND compare_scl_procedures;
?? OLDTITLE ??
?? NEWTITLE := 'compare_command_descriptions', EJECT ??

 PROCEDURE compare_command_descriptions;

{ The purpose of this procedure is to compare two command descriptions.

   VAR
     new_header_p: ^llt$library_member_header,
     new_member_p: ^SEQ ( * ),
     old_header_p: ^llt$library_member_header,
     old_member_p: ^SEQ ( * );

   RESET old_module.file TO old_module.command_description_header;
   RESET new_module.file TO new_module.command_description_header;

   compare_library_member_headers;

   IF error_in_compare THEN
     RETURN;
   IFEND;

{ Pointers old_header_p and new_header_p won't be NIL here. That would have
{ been caught by compare_library_member_headers.

   old_header_p := old_module.command_description_header;
   new_header_p := new_module.command_description_header;

   old_member_p := #PTR (old_header_p^.member, old_module.file^);
   IF old_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   new_member_p := #PTR (new_header_p^.member, new_module.file^);
   IF new_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   RESET old_member_p;
   RESET new_member_p;

   compare_command_desc_contents (old_member_p, new_member_p);

 PROCEND compare_command_descriptions;
?? OLDTITLE ??
?? NEWTITLE := 'compare_command_desc_contents', EJECT ??

 PROCEDURE compare_command_desc_contents
   (VAR old_member_p: ^SEQ ( * );
    VAR new_member_p: ^SEQ ( * ));

{ The purpose of this procedure is to compare two groups of command description contents.

   VAR
     new_command_desc_contents_p: ^llt$command_desc_contents,
     new_file_reference_p: ^fst$file_reference,
     old_command_desc_contents_p: ^llt$command_desc_contents,
     old_file_reference_p: ^fst$file_reference;

   NEXT old_command_desc_contents_p IN old_member_p;
   IF old_command_desc_contents_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;
   NEXT new_command_desc_contents_p IN new_member_p;
   IF new_command_desc_contents_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;
   IF (old_command_desc_contents_p^.version <> new_command_desc_contents_p^.version) THEN
     compare_error ('COMMAND DESCRIPTION', old_command_desc_contents_p, new_command_desc_contents_p);
     RETURN;
   IFEND;

   IF (old_command_desc_contents_p^.system_command <> new_command_desc_contents_p^.system_command) THEN
     compare_error ('COMMAND DESCRIPTION', old_command_desc_contents_p, new_command_desc_contents_p);
     RETURN;
   IFEND;
   IF old_command_desc_contents_p^.system_command THEN
     IF (old_command_desc_contents_p^.system_command_name <> new_command_desc_contents_p^.system_command_name)
           THEN
       compare_error ('COMMAND DESCRIPTION', old_command_desc_contents_p, new_command_desc_contents_p);
       RETURN;
     IFEND;
   ELSE
     IF (old_command_desc_contents_p^.starting_procedure <> new_command_desc_contents_p^.starting_procedure)
           THEN
       compare_error ('COMMAND DESCRIPTION', old_command_desc_contents_p, new_command_desc_contents_p);
       RETURN;
     IFEND;
     IF (old_command_desc_contents_p^.library_path_size <> new_command_desc_contents_p^.library_path_size)
           THEN
       compare_error ('COMMAND DESCRIPTION', old_command_desc_contents_p, new_command_desc_contents_p);
       RETURN;
     IFEND;
     IF (old_command_desc_contents_p^.library_path_size > 0) THEN
       NEXT old_file_reference_p: [old_command_desc_contents_p^.library_path_size] IN old_member_p;
       IF old_file_reference_p = NIL THEN
         compare_error (premature_end_of_file, NIL, NIL);
         RETURN;
       IFEND;
       NEXT new_file_reference_p: [new_command_desc_contents_p^.library_path_size] IN new_member_p;
       IF new_file_reference_p = NIL THEN
         compare_error (premature_end_of_file, NIL, NIL);
         RETURN;
       IFEND;
       IF (old_file_reference_p^ <> new_file_reference_p^) THEN
         compare_error ('COMMAND DESCRIPTION', old_file_reference_p, new_file_reference_p);
         RETURN;
       IFEND;
     IFEND;
   IFEND;

 PROCEND compare_command_desc_contents;
?? OLDTITLE ??
?? NEWTITLE := 'compare_function_procedures', EJECT ??

 PROCEDURE compare_function_procedures;

{ The purpose of this procedure is to compare two function procedures.

   VAR
     new_header_p: ^llt$library_member_header,
     new_member_p: ^SEQ ( * ),
     new_scl_procedure_p: ^SEQ ( * ),
     old_header_p: ^llt$library_member_header,
     old_member_p: ^SEQ ( * ),
     old_scl_procedure_p: ^SEQ ( * );

   RESET old_module.file TO old_module.function_procedure_header;
   RESET new_module.file TO new_module.function_procedure_header;

   compare_library_member_headers;

   IF error_in_compare THEN
     RETURN;
   IFEND;

{ Pointers old_header_p and new_header_p won't be NIL here. That would have
{ been caught by compare_library_member_headers.

   old_header_p := old_module.function_procedure_header;
   new_header_p := new_module.function_procedure_header;

   old_member_p := #PTR (old_header_p^.member, old_module.file^);
   IF old_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   new_member_p := #PTR (new_header_p^.member, new_module.file^);
   IF new_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   RESET old_member_p;
   RESET new_member_p;

   NEXT old_scl_procedure_p: [[REP old_header_p^.member_size OF cell]] IN old_member_p;
   IF old_scl_procedure_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;
   NEXT new_scl_procedure_p: [[REP new_header_p^.member_size OF cell]] IN new_member_p;
   IF new_scl_procedure_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;
   compare_scl_procedures (old_scl_procedure_p, new_scl_procedure_p);

 PROCEND compare_function_procedures;
?? OLDTITLE ??
?? NEWTITLE := 'compare_function_descriptions', EJECT ??

 PROCEDURE compare_function_descriptions;

{ The purpose of this procedure is to compare two function descriptions.

   VAR
     new_function_desc_contents_p: ^llt$function_desc_contents,
     new_file_reference_p: ^fst$file_reference,
     new_header_p: ^llt$library_member_header,
     new_member_p: ^SEQ ( * ),
     old_function_desc_contents_p: ^llt$function_desc_contents,
     old_file_reference_p: ^fst$file_reference,
     old_header_p: ^llt$library_member_header,
     old_member_p: ^SEQ ( * );

   RESET old_module.file TO old_module.function_description_header;
   RESET new_module.file TO new_module.function_description_header;

   compare_library_member_headers;

   IF error_in_compare THEN
     RETURN;
   IFEND;

{ Pointers old_header_p and new_header_p won't be NIL here. That would have
{ been caught by compare_library_member_headers.

   old_header_p := old_module.function_description_header;
   new_header_p := new_module.function_description_header;

   old_member_p := #PTR (old_header_p^.member, old_module.file^);
   IF old_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   new_member_p := #PTR (new_header_p^.member, new_module.file^);
   IF new_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   RESET old_member_p;
   RESET new_member_p;

   NEXT old_function_desc_contents_p IN old_member_p;
   IF old_function_desc_contents_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;
   NEXT new_function_desc_contents_p IN new_member_p;
   IF new_function_desc_contents_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   IF (old_function_desc_contents_p^.version <> new_function_desc_contents_p^.version) THEN
     compare_error ('LIBRARY_MEMBER', old_function_desc_contents_p, new_function_desc_contents_p);
     RETURN;
   IFEND;

   IF (old_function_desc_contents_p^.starting_procedure <> new_function_desc_contents_p^.starting_procedure)
         THEN
     compare_error ('LIBRARY_MEMBER', old_function_desc_contents_p, new_function_desc_contents_p);
     RETURN;
   IFEND;
   IF (old_function_desc_contents_p^.library_path_size <> new_function_desc_contents_p^.library_path_size)
         THEN
     compare_error ('LIBRARY_MEMBER', old_function_desc_contents_p, new_function_desc_contents_p);
     RETURN;
   IFEND;
   IF (old_function_desc_contents_p^.library_path_size > 0) THEN
     NEXT old_file_reference_p: [old_function_desc_contents_p^.library_path_size] IN old_member_p;
     IF old_file_reference_p = NIL THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;
     NEXT new_file_reference_p: [new_function_desc_contents_p^.library_path_size] IN new_member_p;
     IF new_file_reference_p = NIL THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;
     IF (old_file_reference_p^ <> new_file_reference_p^) THEN
       compare_error ('LIBRARY_MEMBER', old_file_reference_p, new_file_reference_p);
       RETURN;
     IFEND;
   IFEND;

 PROCEND compare_function_descriptions;
?? OLDTITLE ??
?? NEWTITLE := 'compare_applic_program_descrip', EJECT ??

 PROCEDURE compare_applic_program_descrip;

{ The purpose of this procedure is to compare two application program descriptions.

   VAR
     new_header_p: ^llt$library_member_header,
     new_member_p: ^SEQ ( * ),
     old_header_p: ^llt$library_member_header,
     old_member_p: ^SEQ ( * );

   RESET old_module.file TO old_module.applic_program_description_hdr;
   RESET new_module.file TO new_module.applic_program_description_hdr;

   compare_library_member_headers;

   IF error_in_compare THEN
     RETURN;
   IFEND;

   IF old_module.applic_program_description_hdr^.application_identifier.name <>
         new_module.applic_program_description_hdr^.application_identifier.name THEN
     compare_error ('APPLICATION IDENTIFIER', ^old_module.applic_program_description_hdr^.
           application_identifier.name, ^new_module.applic_program_description_hdr^.application_identifier.
           name);
   IFEND;

{ Pointers old_header_p and new_header_p won't be NIL here. That would have
{ been caught by compare_library_member_headers.

   old_header_p := ^old_module.applic_program_description_hdr^.library_member_header;
   new_header_p := ^new_module.applic_program_description_hdr^.library_member_header;

   old_member_p := #PTR (old_header_p^.member, old_module.file^);
   IF old_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   new_member_p := #PTR (new_header_p^.member, new_module.file^);
   IF new_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   RESET old_member_p;
   RESET new_member_p;

   compare_program_attributes (old_member_p, new_member_p);

 PROCEND compare_applic_program_descrip;
?? OLDTITLE ??
?? NEWTITLE := 'compare_applic_command_procs', EJECT ??

 PROCEDURE compare_applic_command_procs;

{ The purpose of this procedure is to compare two application command procedures.

   VAR
     new_header_p: ^llt$library_member_header,
     new_member_p: ^SEQ ( * ),
     new_scl_procedure_p: ^SEQ ( * ),
     old_header_p: ^llt$library_member_header,
     old_member_p: ^SEQ ( * ),
     old_scl_procedure_p: ^SEQ ( * );

   RESET old_module.file TO old_module.applic_command_procedure_header;
   RESET new_module.file TO new_module.applic_command_procedure_header;

   compare_library_member_headers;

   IF error_in_compare THEN
     RETURN;
   IFEND;

   IF old_module.applic_command_procedure_header^.application_identifier.name <>
         new_module.applic_command_procedure_header^.application_identifier.name THEN
     compare_error ('APPLICATION IDENTIFIER', ^old_module.applic_command_procedure_header^.
           application_identifier.name, ^new_module.applic_command_procedure_header^.application_identifier.
           name);
   IFEND;

{ Pointers old_header_p and new_header_p won't be NIL here. That would have
{ been caught by compare_library_member_headers.

   old_header_p := ^old_module.applic_command_procedure_header^.library_member_header;
   new_header_p := ^new_module.applic_command_procedure_header^.library_member_header;

   old_member_p := #PTR (old_header_p^.member, old_module.file^);
   IF old_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   new_member_p := #PTR (new_header_p^.member, old_module.file^);
   IF new_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   RESET old_member_p;
   RESET new_member_p;

   NEXT old_scl_procedure_p: [[REP old_header_p^.member_size OF cell]] IN old_member_p;
   IF old_scl_procedure_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;
   NEXT new_scl_procedure_p: [[REP new_header_p^.member_size OF cell]] IN new_member_p;
   IF new_scl_procedure_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;
   compare_scl_procedures (old_scl_procedure_p, new_scl_procedure_p);
 PROCEND compare_applic_command_procs;
?? OLDTITLE ??
?? NEWTITLE := 'compare_applic_command_descrip', EJECT ??

 PROCEDURE compare_applic_command_descrip;

{ The purpose of this procedure is to compare two application command descriptions.

   VAR
     new_header_p: ^llt$library_member_header,
     new_member_p: ^SEQ ( * ),
     old_header_p: ^llt$library_member_header,
     old_member_p: ^SEQ ( * );

   RESET old_module.file TO old_module.applic_command_description_hdr;
   RESET new_module.file TO new_module.applic_command_description_hdr;

   compare_library_member_headers;

   IF error_in_compare THEN
     RETURN;
   IFEND;

   IF old_module.applic_command_description_hdr^.application_identifier.name <>
         new_module.applic_command_description_hdr^.application_identifier.name THEN
     compare_error ('APPLICATION IDENTIFIER', ^old_module.applic_command_description_hdr^.
           application_identifier.name, ^new_module.applic_command_description_hdr^.application_identifier.
           name);
   IFEND;

{ Pointers old_header_p and new_header_p won't be NIL here. That would have
{ been caught by compare_library_member_headers.

   old_header_p := ^old_module.applic_command_description_hdr^.library_member_header;
   new_header_p := ^new_module.applic_command_description_hdr^.library_member_header;

   old_member_p := #PTR (old_header_p^.member, old_module.file^);
   IF old_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   new_member_p := #PTR (new_header_p^.member, new_module.file^);
   IF new_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   RESET old_member_p;
   RESET new_member_p;

   compare_command_desc_contents (old_member_p, new_member_p);

 PROCEND compare_applic_command_descrip;
?? OLDTITLE ??
?? NEWTITLE := 'compare_message_modules', EJECT ??

 PROCEDURE compare_message_modules;

{ The purpose of this procedure is to compare two message modules.

   VAR
     errors: boolean,
     new_codes_p: ^ost$mtm_condition_codes,
     new_header_p: ^llt$library_member_header,
     new_member_p: ^SEQ ( * ),
     new_menu_classes_p: cst$menu_class, { this type is a pointer }
     new_menu_header_p: ^ost$mtm_menu_header,
     new_menu_items_p: cst$menu_list, { this type is a pointer }
     new_mtm_header_p: ^ost$mtm_header,
     new_names_p: ^ost$mtm_condition_names,
     new_template_p: ^ost$message_template,
     old_codes_p: ^ost$mtm_condition_codes,
     old_header_p: ^llt$library_member_header,
     old_member_p: ^SEQ ( * ),
     old_menu_classes_p: cst$menu_class, { this type is a pointer }
     old_menu_header_p: ^ost$mtm_menu_header,
     old_menu_items_p: cst$menu_list, { this type is a pointer }
     old_mtm_header_p: ^ost$mtm_header,
     old_names_p: ^ost$mtm_condition_names,
     old_template_p: ^ost$message_template,
     template_index: ost$message_template_index;

   RESET old_module.file TO old_module.message_module_header;
   RESET new_module.file TO new_module.message_module_header;

   compare_library_member_headers;
   IF error_in_compare THEN
     RETURN;
   IFEND;

{ Pointers old_header_p and new_header_p won't be NIL here.  That would have
{ been caught by compare_library_member_headers.

   old_header_p := old_module.message_module_header;
   new_header_p := new_module.message_module_header;

   old_member_p := #PTR (old_header_p^.member, old_module.file^);
   IF old_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   new_member_p := #PTR (new_header_p^.member, new_module.file^);
   IF new_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   RESET old_member_p;
   RESET new_member_p;

   clp$extract_msg_module_contents (old_member_p, old_mtm_header_p, old_codes_p, old_names_p);
   IF old_mtm_header_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   clp$extract_msg_module_contents (new_member_p, new_mtm_header_p, new_codes_p, new_names_p);
   IF new_mtm_header_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

{ Compare message template module headers.

   errors := TRUE;
   IF old_mtm_header_p^.version = new_mtm_header_p^.version THEN
     IF old_mtm_header_p^.language = new_mtm_header_p^.language THEN
       IF old_mtm_header_p^.online_manual_name = new_mtm_header_p^.online_manual_name THEN
         IF old_mtm_header_p^.number_of_codes = new_mtm_header_p^.number_of_codes THEN
           IF old_mtm_header_p^.number_of_names = new_mtm_header_p^.number_of_names THEN
             errors := FALSE;
           IFEND;
         IFEND;
       IFEND;
     IFEND;
   IFEND;
   IF errors THEN
     compare_error ('LIBRARY MEMBER', old_mtm_header_p, new_mtm_header_p);
     RETURN;
   IFEND;

{ Compare message template contents.

   IF (old_mtm_header_p^.number_of_codes > 0) AND (old_codes_p = NIL) THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;
   IF (new_mtm_header_p^.number_of_codes > 0) AND (new_codes_p = NIL) THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;
   IF old_names_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;
   IF new_names_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   FOR template_index := 0 TO old_mtm_header_p^.number_of_names - 1 DO
     errors := TRUE;
     IF old_names_p^ [template_index].name = new_names_p^ [template_index].name THEN
       IF old_names_p^ [template_index].kind = new_names_p^ [template_index].kind THEN
         CASE old_names_p^ [template_index].kind OF
         = osc$status_message =
           old_template_p := #PTR (old_names_p^ [template_index].template, old_member_p^);
           IF old_template_p = NIL THEN
             compare_error (premature_end_of_file, NIL, NIL);
             RETURN;
           IFEND;
           new_template_p := #PTR (new_names_p^ [template_index].template, new_member_p^);
           IF new_template_p = NIL THEN
             compare_error (premature_end_of_file, NIL, NIL);
             RETURN;
           IFEND;
           IF old_template_p^ = new_template_p^ THEN
             IF old_names_p^ [template_index].code = new_names_p^ [template_index].code THEN
               IF old_names_p^ [template_index].severity = new_names_p^ [template_index].severity THEN
                 errors := FALSE;
               IFEND;
             IFEND;
           IFEND;
         = osc$brief_help, osc$full_help =
           old_template_p := #PTR (old_names_p^ [template_index].template, old_member_p^);
           IF old_template_p = NIL THEN
             compare_error (premature_end_of_file, NIL, NIL);
             RETURN;
           IFEND;
           new_template_p := #PTR (new_names_p^ [template_index].template, new_member_p^);
           IF new_template_p = NIL THEN
             compare_error (premature_end_of_file, NIL, NIL);
             RETURN;
           IFEND;
           IF old_template_p^ = new_template_p^ THEN
             errors := FALSE;
           IFEND;
         = osc$parameter_prompt, osc$parameter_assistance_prompt, osc$parameter_help =
           old_template_p := #PTR (old_names_p^ [template_index].template, old_member_p^);
           IF old_template_p = NIL THEN
             compare_error (premature_end_of_file, NIL, NIL);
             RETURN;
           IFEND;
           new_template_p := #PTR (new_names_p^ [template_index].template, new_member_p^);
           IF new_template_p = NIL THEN
             compare_error (premature_end_of_file, NIL, NIL);
             RETURN;
           IFEND;
           IF old_template_p^ = new_template_p^ THEN
             errors := FALSE;
           IFEND;
         = osc$application_menu =
           old_menu_header_p := #PTR (old_names_p^ [template_index].menu_header, old_member_p^);
           IF old_menu_header_p = NIL THEN
             compare_error (premature_end_of_file, NIL, NIL);
             RETURN;
           IFEND;
           new_menu_header_p := #PTR (new_names_p^ [template_index].menu_header, new_member_p^);
           IF new_menu_header_p = NIL THEN
             compare_error (premature_end_of_file, NIL, NIL);
             RETURN;
           IFEND;
           IF old_menu_header_p^.number_of_classes = new_menu_header_p^.number_of_classes THEN
             IF old_menu_header_p^.number_of_menu_items = new_menu_header_p^.number_of_menu_items THEN
               errors := FALSE;
               RESET old_member_p TO old_menu_header_p;
               NEXT old_menu_header_p IN old_member_p;
               NEXT old_menu_classes_p: [1 .. old_menu_header_p^.number_of_classes] IN old_member_p;
               IF (old_menu_classes_p = NIL) THEN
                 compare_error (premature_end_of_file, NIL, NIL);
                 RETURN;
               IFEND;
               RESET new_member_p TO new_menu_header_p;
               NEXT new_menu_header_p IN new_member_p;
               NEXT new_menu_classes_p: [1 .. new_menu_header_p^.number_of_classes] IN new_member_p;
               IF (new_menu_classes_p = NIL) THEN
                 compare_error (premature_end_of_file, NIL, NIL);
                 RETURN;
               IFEND;
               RESET old_member_p TO old_menu_classes_p;
               RESET new_member_p TO new_menu_classes_p;
               compare (old_menu_header_p^.number_of_classes * #SIZE (cst$class_name), 'APPLICATION MENUS');
               IF error_in_compare THEN
                 RETURN;
               IFEND;

               NEXT old_menu_items_p: [1 .. old_menu_header_p^.number_of_menu_items] IN old_member_p;
               IF (old_menu_items_p = NIL) THEN
                 compare_error (premature_end_of_file, NIL, NIL);
                 RETURN;
               IFEND;
               NEXT new_menu_items_p: [1 .. new_menu_header_p^.number_of_menu_items] IN new_member_p;
               IF (new_menu_items_p = NIL) THEN
                 compare_error (premature_end_of_file, NIL, NIL);
                 RETURN;
               IFEND;
               RESET old_member_p TO old_menu_items_p;
               RESET new_member_p TO new_menu_items_p;
               compare (old_menu_header_p^.number_of_menu_items * #SIZE (cst$menu_item),
                     'APPLICATIONS MENUS');
               IF error_in_compare THEN
                 RETURN;
               IFEND;
             IFEND;
           IFEND;
         ELSE
           ;
         CASEND;
       IFEND;
     IFEND;
     IF errors THEN
       compare_error ('LIBRARY MEMBER', old_member_p, new_member_p);
       RETURN;
     IFEND;
   FOREND;

 PROCEND compare_message_modules;
?? OLDTITLE ??
?? NEWTITLE := 'compare_panel_modules', EJECT ??

 PROCEDURE compare_panel_modules;

{ The purpose of this procedure is to compare two form (panel) modules.

   VAR
     errors: boolean,
     new_header_p: ^llt$library_member_header,
     new_member_p: ^SEQ ( * ),
     old_header_p: ^llt$library_member_header,
     old_member_p: ^SEQ ( * );

   RESET old_module.file TO old_module.panel_module_header;
   RESET new_module.file TO new_module.panel_module_header;

   compare_library_member_headers;

   IF error_in_compare THEN
     RETURN;
   IFEND;

{ Pointers old_header_p and new_header_p won't be NIL here.  That would have
{ been caught by compare_library_member_headers.

   old_header_p := old_module.panel_module_header;
   new_header_p := new_module.panel_module_header;

   old_member_p := #PTR (old_header_p^.member, old_module.file^);
   IF old_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   new_member_p := #PTR (new_header_p^.member, new_module.file^);
   IF new_member_p = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   RESET old_module.file TO old_member_p;
   RESET new_module.file TO new_member_p;

   compare (old_header_p^.member_size, 'LIBRARY MEMBER');
   IF error_in_compare THEN
     RETURN;
   IFEND;

 PROCEND compare_panel_modules;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_INFO_ELEMENT_HEADERS', EJECT ??

 PROCEDURE compare_info_element_headers
   (    old_info_element_header: ^llt$info_element_header;
        new_info_element_header: ^llt$info_element_header);


   CONST
     info_element_header = 'INFORMATION ELEMENT HEADER';

   VAR
     i: integer,
     old_relocation: ^llt$relocation,
     new_relocation: ^llt$relocation,
     old_binding_section_template: ^llt$binding_section_template,
     new_binding_section_template: ^llt$binding_section_template,
     old_section_maps: ^llt$section_maps,
     new_section_maps: ^llt$section_maps,
     old_map: ^llt$section_map_items,
     new_map: ^llt$section_map_items;


   IF old_info_element_header^.number_of_rel_items <> new_info_element_header^.number_of_rel_items THEN
     compare_error (info_element_header, old_info_element_header, new_info_element_header);
     RETURN;
   IFEND;

   IF old_info_element_header^.number_of_template_items <>
         new_info_element_header^.number_of_template_items THEN
     compare_error (info_element_header, old_info_element_header, new_info_element_header);
     RETURN;
   IFEND;


   IF old_info_element_header^.number_of_section_maps <> new_info_element_header^.number_of_section_maps THEN
     compare_error (info_element_header, old_info_element_header, new_info_element_header);
     RETURN;
   IFEND;
?? EJECT ??

   IF old_info_element_header^.number_of_rel_items <> 0 THEN
     old_relocation := #PTR (old_info_element_header^.relocation_ptr, old_module.file^);
     IF old_relocation = NIL THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;

     new_relocation := #PTR (new_info_element_header^.relocation_ptr, new_module.file^);
     IF new_relocation = NIL THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;

     RESET old_module.file TO old_relocation;
     RESET new_module.file TO new_relocation;


     record_number := record_number + 1;
     compare ((old_info_element_header^.number_of_rel_items * #SIZE (llt$relocation_item)),
           info_element_header);
     IF error_in_compare THEN
       RETURN;
     IFEND;
   IFEND;


   IF old_info_element_header^.number_of_template_items <> 0 THEN
     old_binding_section_template := #PTR (old_info_element_header^.binding_template_ptr, old_module.file^);
     IF old_binding_section_template = NIL THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;

     new_binding_section_template := #PTR (new_info_element_header^.binding_template_ptr, new_module.file^);
     IF new_binding_section_template = NIL THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;

     RESET old_module.file TO old_binding_section_template;
     RESET new_module.file TO new_binding_section_template;

     FOR i := 1 TO old_info_element_header^.number_of_template_items DO
       record_number := record_number + 1;

       compare_binding_templates;

       IF error_in_compare THEN
         RETURN;
       IFEND;
     FOREND;
   IFEND;
?? EJECT ??

   IF old_info_element_header^.number_of_section_maps <> 0 THEN
     old_section_maps := #PTR (old_info_element_header^.section_maps, old_module.file^);
     IF old_section_maps = NIL THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;

     new_section_maps := #PTR (new_info_element_header^.section_maps, new_module.file^);
     IF new_section_maps = NIL THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;

     FOR i := 0 TO UPPERBOUND (old_section_maps^) DO
       IF old_section_maps^ [i].number_of_items <> new_section_maps^ [i].number_of_items THEN
         compare_error ('NUMBER OF MAP ITEMS', old_section_maps, new_section_maps);
         RETURN;
       IFEND;

       IF old_section_maps^ [i].number_of_items > 0 THEN
         old_map := #PTR (old_section_maps^ [i].map, old_module.file^);
         IF old_map = NIL THEN
           compare_error (premature_end_of_file, NIL, NIL);
           RETURN;
         IFEND;

         new_map := #PTR (new_section_maps^ [i].map, new_module.file^);
         IF new_map = NIL THEN
           compare_error (premature_end_of_file, NIL, NIL);
           RETURN;
         IFEND;

         RESET old_module.file TO old_map;
         RESET new_module.file TO new_map;

         compare (#SIZE (old_map^), 'BINARY SECTION MAP');
         IF error_in_compare THEN
           RETURN;
         IFEND;
       IFEND;
     FOREND;
   IFEND;


 PROCEND compare_info_element_headers;
?? OLDTITLE ??
?? NEWTITLE := '    COMPARE_LOAD_MODULES', EJECT ??

 PROCEDURE compare_load_modules;


   VAR
     old_info_element_header: ^llt$info_element_header,
     new_info_element_header: ^llt$info_element_header,
     old_header: llt$info_element_header,
     new_header: llt$info_element_header;


   IF old_module.load_module_header^.elements_defined <> new_module.load_module_header^.elements_defined THEN
     compare_error ('ELEMENTS DEFINED', old_module.load_module_header, new_module.load_module_header);
     RETURN;
   IFEND;

   IF old_module.load_module_header^.interpretive_header.elements_defined <>
         new_module.load_module_header^.interpretive_header.elements_defined THEN
     compare_error ('INTERPRETIVE ELEMENTS DEFINED', old_module.load_module_header,
           new_module.load_module_header);
     RETURN;
   IFEND;


   old_object_text_descriptor := #PTR (old_module.load_module_header^.interpretive_element, old_module.file^);
   IF old_object_text_descriptor = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   new_object_text_descriptor := #PTR (new_module.load_module_header^.interpretive_element, new_module.file^);
   IF new_object_text_descriptor = NIL THEN
     compare_error (premature_end_of_file, NIL, NIL);
     RETURN;
   IFEND;

   RESET old_module.file TO old_object_text_descriptor;
   RESET new_module.file TO new_object_text_descriptor;

   NEXT old_object_text_descriptor IN old_module.file;
   NEXT new_object_text_descriptor IN new_module.file;


   compare_interpretive_records;

   IF error_in_compare THEN
     RETURN;
   IFEND;
?? EJECT ??


   IF llc$information_element IN old_module.load_module_header^.elements_defined THEN
     old_info_element_header := #PTR (old_module.load_module_header^.information_element, old_module.file^);
     IF old_info_element_header = NIL THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;

     IF (old_info_element_header^.version <> llc$info_element_version) THEN
       ocp$convert_information_element (old_info_element_header, old_header);
       old_info_element_header := ^old_header;
     IFEND;


     new_info_element_header := #PTR (new_module.load_module_header^.information_element, new_module.file^);
     IF new_info_element_header = NIL THEN
       compare_error (premature_end_of_file, NIL, NIL);
       RETURN;
     IFEND;

     IF (new_info_element_header^.version <> llc$info_element_version) THEN
       ocp$convert_information_element (new_info_element_header, new_header);
       new_info_element_header := ^new_header;
     IFEND;

     compare_info_element_headers (old_info_element_header, new_info_element_header);
     IF error_in_compare THEN
       RETURN;
     IFEND;
   IFEND;


 PROCEND compare_load_modules;
?? OLDTITLE ??
?? EJECT ??


 VAR
   record_number: integer,
   error_in_compare: boolean;


 record_number := 0;
 error_in_compare := FALSE;


 IF old_module.kind <> new_module.kind THEN
   compare_error ('MODULE KIND', NIL, NIL);
   RETURN;
 IFEND;


 CASE old_module.kind OF
 = occ$cpu_object_module =
   compare_cpu_object_modules;

 = occ$ppu_object_module =
   compare_ppu_object_modules;

 = occ$load_module =
   compare_load_modules;

 = occ$program_description =
   compare_program_descriptions;

 = occ$command_procedure =
   compare_command_procedures;

 = occ$command_description =
   compare_command_descriptions;

 = occ$function_procedure =
   compare_function_procedures;

 = occ$function_description =
   compare_function_descriptions;

 = occ$message_module =
   compare_message_modules;

 = occ$panel_module =
   compare_panel_modules;

 = occ$applic_program_description =
   compare_applic_program_descrip;

 = occ$applic_command_procedure =
   compare_applic_command_procs;

 = occ$applic_command_description =
   compare_applic_command_descrip;

 ELSE
   compare_error ('***** internal error 1 *****', NIL, NIL);
 CASEND;


 PROCEND compare_modules;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$COMPARE_OBJECT_LIBRARY', EJECT ??

 PROGRAM [XDCL, #GATE] ocp$compare_object_library
   (    parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE (ocm$comol) compare_object_library, comol (
{   file, f: file = $required
{   with, w: file = $required
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 4, 24, 14, 33, 32, 145],
    clc$command, 7, 4, 2, 0, 0, 0, 4, 'OCM$COMOL'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['W                              ',clc$abbreviation_entry, 2],
    ['WITH                           ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

   CONST
     p$file = 1,
     p$with = 2,
     p$output = 3,
     p$status = 4;

   VAR
     pvt: array [1 .. 4] of clt$parameter_value;


   VAR
     old_library: ^oct$open_file_list,
     old_library_name: amt$local_file_name,
     new_library: ^oct$open_file_list,
     new_library_name: amt$local_file_name,
     old: llt$module_index,
     new: llt$module_index,
     found: boolean,
     header_printed: boolean,
     page_header: string (86),
     dummy: ost$status;


 /compare_processing/
   BEGIN

     clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;


     ocp$initialize_oc_environment (status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;


     ocp$obtain_object_file (pvt [p$file].value^.file_value^, old_library, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

     IF old_library^.name = osc$null_name THEN
       osp$set_status_abnormal ('OC', oce$e_non_object_file, pvt [p$file].value^.file_value^, status);
       RETURN;
     ELSE
       pmp$get_last_path_name (pvt [p$file].value^.file_value^, old_library_name, status);
       IF NOT status.normal THEN
         RETURN;
       IFEND;
     IFEND;


     ocp$obtain_object_file (pvt [p$with].value^.file_value^, new_library, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

     IF new_library^.name = osc$null_name THEN
       osp$set_status_abnormal ('OC', oce$e_non_object_file, pvt [p$with].value^.file_value^, status);
       RETURN;
     ELSE
       pmp$get_last_path_name (pvt [p$with].value^.file_value^, new_library_name, status);
       IF NOT status.normal THEN
         RETURN;
       IFEND;
     IFEND;


     IF old_library^.kind <> new_library^.kind THEN
       osp$set_status_abnormal ('OC', oce$e_cant_compare_file_and_lib, '', status);
       RETURN;
     IFEND;


     sort_module_directory (old_library^.directory^);
     sort_module_directory (new_library^.directory^);


     page_header (1, * ) := 'COMPARE LISTING of';
     page_header (20, 31) := old_library_name;
     page_header (52, 3) := 'and';
     page_header (56, 31) := new_library_name;

     ocp$open_output_file (pvt [p$output].value^.file_value^, ^page_header, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;


     IF old_library^.name = new_library^.name THEN
       EXIT /compare_processing/;
     IFEND;


     header_printed := FALSE;

     FOR old := 1 TO UPPERBOUND (old_library^.directory^) DO
       new := 1;
       WHILE (new <= UPPERBOUND (new_library^.directory^)) AND
             (old_library^.directory^ [old].name <> new_library^.directory^ [new].name) DO
         new := new + 1;
       WHILEND;

       IF new > UPPERBOUND (new_library^.directory^) THEN
         IF NOT header_printed THEN
           ocp$output (occ$new_page, 'Old modules deleted from', 24, occ$continue);
           ocp$output (' ', old_library_name, #SIZE (old_library_name), occ$end_of_line);
           ocp$output (occ$single_space, '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~', 56,
                 occ$end_of_line);
           header_printed := TRUE;
         IFEND;

         ocp$output (occ$single_space, old_library^.directory^
               [old].name, #SIZE (old_library^.directory^ [old].name), occ$end_of_line);
       IFEND;
     FOREND;


     header_printed := FALSE;

     FOR new := 1 TO UPPERBOUND (new_library^.directory^) DO
       old := 1;
       WHILE (old <= UPPERBOUND (old_library^.directory^)) AND
             (new_library^.directory^ [new].name <> old_library^.directory^ [old].name) DO
         old := old + 1;
       WHILEND;

       IF old > UPPERBOUND (old_library^.directory^) THEN
         IF NOT header_printed THEN
           ocp$output (occ$new_page, 'New modules added to', 20, occ$continue);
           ocp$output (' ', new_library_name, #SIZE (new_library_name), occ$end_of_line);
           ocp$output (occ$single_space, '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~', 52,
                 occ$end_of_line);
           header_printed := TRUE;
         IFEND;

         ocp$output (occ$single_space, new_library^.directory^
               [new].name, #SIZE (new_library^.directory^ [new].name), occ$end_of_line);
       IFEND;
     FOREND;


     header_printed := FALSE;

     FOR new := 1 TO UPPERBOUND (new_library^.directory^) DO
       old := 1;

       WHILE (old <= UPPERBOUND (old_library^.directory^)) AND
             (new_library^.directory^ [new].name <> old_library^.directory^ [old].name) DO
         old := old + 1;
       WHILEND;

       IF old <= UPPERBOUND (old_library^.directory^) THEN
         compare_modules (old_library^.directory^ [old], new_library^.directory^ [new], header_printed);
       IFEND;
     FOREND;

   END /compare_processing/;


   ocp$close_all_open_files (ocv$open_file_list);

   STRINGREP (strng, length, number_of_compare_errors);
   ocp$output (occ$triple_space, 'Number of compare errors:', 25, occ$continue);
   ocp$output ('', strng (1, length), length, occ$end_of_line);

   ocp$close_output_file (status);
   IF NOT status.normal THEN
     RETURN;
   IFEND;

 PROCEND ocp$compare_object_library;

 MODEND ocm$compare_object_library;
*DECK DECK=OCM$CONSTRUCT_BREAKLIST EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Management : Correction Generation' ??
MODULE ocm$construct_breaklist;

{ PURPOSE:
{   This module contains the procedures that build a breaklist, which is an array
{   where each element contains distinguishing information about a specific location
{   in an object library.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc llt$deferred_common_blocks
*copyc llt$deferred_entry_points
*copyc llt$information_element
*copyc llt$load_module
*copyc occ$breaklist
*copyc occ$generate_predictor
*copyc oce$metapatch_generator_errors
*copyc oct$breaklist
*copyc oct$module_directory
*copyc oct$module_map
*copyc ost$message_template
*copyc ost$mtm_condition_codes
*copyc ost$mtm_condition_names
*copyc ost$mtm_header
*copyc ost$name
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*copyc ocp$convert_information_element
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := 'build_adr_breaklist_items', EJECT ??

{ PURPOSE:
{   The purpose of this request is to build breaklist items pointing
{ to the address formulation records in the object library.

  PROCEDURE build_adr_breaklist_items
    (    p_object_library: ^SEQ ( * );
         current_module: oct$module_map_item;
         binding_section: llt$section_ordinal;
     VAR breaklist_seq_p: ^SEQ ( * );
     VAR breaklist_index: oct$breaklist_length);

    VAR
      actual_parameters: ^llt$actual_parameters,
      adr: ^llt$address_formulation,
      adr_found: boolean,
      bit_string_insertion: ^llt$bit_string_insertion,
      breaklist_item: ^oct$breaklist_item,
      current_object_text_descriptor: ^llt$object_text_descriptor,
      current_section_definition: ^llt$section_definition,
      deferred_common_blocks: ^llt$deferred_common_blocks,
      deferred_entry_points: ^llt$deferred_entry_points,
      ending_offset: 0 .. 7fffffff(16),
      entry_definition: ^llt$entry_definition,
      external_linkage: ^llt$external_linkage,
      formal_parameters: ^llt$formal_parameters,
      i: llt$number_of_sections,
      j: 1 .. llc$max_adr_items,
      no_more_section_definitions: boolean,
      object_library: ^SEQ ( * ),
      object_text_descriptor: ^llt$object_text_descriptor,
      obsolete_formal_parameters: ^llt$obsolete_formal_parameters,
      replication: ^llt$replication,
      section_definition: ^llt$section_definition,
      section_map: ^llt$section_map_items,
      text: ^llt$text;

    object_library := p_object_library;
    no_more_section_definitions := FALSE;
    RESET object_library TO current_module.section_definitions;
    REPEAT
      NEXT object_text_descriptor IN object_library;
      CASE object_text_descriptor^.kind OF
      = llc$section_definition, llc$allotted_section_definition, llc$unallocated_common_block =
        NEXT section_definition IN object_library;
        IF section_definition^.kind <> llc$binding_section THEN
          current_object_text_descriptor := object_text_descriptor;
          current_section_definition := section_definition;
          REPEAT
            NEXT object_text_descriptor IN object_library;
            CASE object_text_descriptor^.kind OF
            = llc$section_definition, llc$allotted_section_definition, llc$unallocated_common_block =
              NEXT section_definition IN object_library;

            = llc$external_linkage =
              NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN object_library;

            = llc$entry_definition =
              NEXT entry_definition IN object_library;

            = llc$deferred_entry_points =
              NEXT deferred_entry_points: [1 .. object_text_descriptor^.number_of_entry_points] IN
                    object_library;

            = llc$deferred_common_blocks =
              NEXT deferred_common_blocks: [1 .. object_text_descriptor^.number_of_common_blocks] IN
                    object_library;

            = llc$obsolete_formal_parameters =
              NEXT obsolete_formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                    object_library;

            = llc$formal_parameters =
              NEXT formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                    object_library;

            = llc$actual_parameters =
              NEXT actual_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                    object_library;

            = llc$text =
              NEXT text: [1 .. object_text_descriptor^.number_of_bytes] IN object_library;

            = llc$replication =
              NEXT replication: [1 .. object_text_descriptor^.number_of_bytes] IN object_library;

            = llc$bit_string_insertion =
              NEXT bit_string_insertion IN object_library;

            = llc$address_formulation =
              NEXT adr: [1 .. object_text_descriptor^.number_of_adr_items] IN object_library;
              IF (adr^.value_section = current_section_definition^.section_ordinal) AND
                    (adr^.dest_section = binding_section) THEN
                section_map := #PTR (current_module.section_maps^ [adr^.value_section].map, object_library^);
                i := 1;
                FOR j := 1 TO object_text_descriptor^.number_of_adr_items DO
                  adr_found := FALSE;
                  WHILE (NOT adr_found) AND (i <= current_module.section_maps^ [adr^.value_section].
                        number_of_items) AND (section_map^ [i].offset <= adr^.
                        item [object_text_descriptor^.number_of_adr_items].value_offset) DO
                    ending_offset := section_map^ [i].offset + section_map^ [i].length;
                    IF (adr^.item [j].value_offset >= section_map^ [i].offset) AND (adr^.item [j].
                          value_offset < ending_offset) THEN
                      adr_found := TRUE;
                      NEXT breaklist_item IN breaklist_seq_p;
                      breaklist_index := breaklist_index + 1;
                      breaklist_item^.module_name := current_module.name;
                      breaklist_item^.major_name := current_module.
                            component_info^ [section_map^ [i].component].name;
                      breaklist_item^.minor_name := current_section_definition^.name;
                      breaklist_item^.kind := occ$adr;
                      breaklist_item^.section_ordinal := current_module.change_list^ [adr^.dest_section];
                      breaklist_item^.secondary_section_ordinal := current_module.
                            change_list^ [adr^.value_section];
                      breaklist_item^.offset := #OFFSET (^adr^.item [j]);
                    ELSE
                      i := i + 1;
                    IFEND;
                  WHILEND;
                FOREND;

              ELSEIF (adr^.dest_section = current_section_definition^.section_ordinal) AND
                    (current_object_text_descriptor^.kind = llc$section_definition) THEN
                section_map := #PTR (current_module.section_maps^ [adr^.dest_section].map, object_library^);
                i := 1;
                FOR j := 1 TO object_text_descriptor^.number_of_adr_items DO
                  adr_found := FALSE;
                  WHILE NOT adr_found AND (i <= current_module.section_maps^ [adr^.dest_section].
                        number_of_items) AND (section_map^ [i].offset <= adr^.
                        item [object_text_descriptor^.number_of_adr_items].dest_offset) DO
                    ending_offset := section_map^ [i].offset + section_map^ [i].length;
                    IF (adr^.item [j].dest_offset >= section_map^ [i].offset) AND (adr^.item [j].
                          dest_offset < ending_offset) THEN
                      adr_found := TRUE;
                      NEXT breaklist_item IN breaklist_seq_p;
                      breaklist_index := breaklist_index + 1;
                      breaklist_item^.module_name := current_module.name;
                      breaklist_item^.major_name := current_module.
                            component_info^ [section_map^ [i].component].name;
                      breaklist_item^.minor_name := current_section_definition^.name;
                      breaklist_item^.kind := occ$adr;
                      breaklist_item^.section_ordinal := current_module.change_list^ [adr^.dest_section];
                      breaklist_item^.secondary_section_ordinal := current_module.
                            change_list^ [adr^.value_section];
                      breaklist_item^.offset := #OFFSET (^adr^.item [j]);
                    ELSE
                      i := i + 1;
                    IFEND;
                  WHILEND;
                FOREND;
              IFEND;
            ELSE
              ;
            CASEND;
          UNTIL object_text_descriptor^.kind = llc$transfer_symbol;
          RESET object_library TO current_section_definition;
          NEXT section_definition IN object_library;
        IFEND;
      ELSE
        no_more_section_definitions := TRUE;
      CASEND;
    UNTIL no_more_section_definitions;

  PROCEND build_adr_breaklist_items;
?? OLDTITLE ??
?? NEWTITLE := 'build_load_module_breaklist', EJECT ??

{ PURPOSE:
{   The purpose of this request is to build breaklist items for a load
{ module.

  PROCEDURE build_load_module_breaklist
    (    current_module: oct$module_map_item;
         p_object_library: ^SEQ ( * );
         interpretive_element: ^llt$object_text_descriptor;
     VAR breaklist_seq_p: ^SEQ ( * );
     VAR breaklist_index: oct$breaklist_length;
     VAR status: ost$status);

    VAR
      actual_parameters: ^llt$actual_parameters,
      adr: ^llt$address_formulation,
      application_identifier: ^llt$application_identifier,
      binding_section: llt$section_ordinal,
      binding_template: ^llt$binding_template,
      breaklist_item: ^oct$breaklist_item,
      bsi: ^llt$bit_string_insertion,
      debug_table_fragment: ^llt$debug_table_fragment,
      deferred_common_blocks: ^llt$deferred_common_blocks,
      deferred_entry_points: ^llt$deferred_entry_points,
      deferred_index: 1 .. llc$max_deferred_entry_points,
      entry_definition: ^llt$entry_definition,
      external_linkage: ^llt$external_linkage,
      formal_parameters: ^llt$formal_parameters,
      identification: ^llt$identification,
      length: integer,
      libraries: ^llt$libraries,
      line_address_table: ^llt$line_address_table,
      m68000_absolute: ^llt$68000_absolute,
      message: string (100),
      object_library: ^SEQ ( * ),
      object_text_descriptor: ^llt$object_text_descriptor,
      obsolete_formal_parameters: ^llt$obsolete_formal_parameters,
      obsolete_line_address_table: ^llt$obsolete_line_address_table,
      obsolete_segment_definition: ^llt$obsolete_segment_definition,
      relocation: ^llt$relocation,
      replication: ^llt$replication,
      section_definition: ^llt$section_definition,
      segment_definition: ^llt$segment_definition,
      supplemental_debug_tables: ^llt$supplemental_debug_tables,
      symbol_table: ^llt$symbol_table,
      text: ^llt$text;

    status.normal := TRUE;
    object_library := p_object_library;

    binding_section := occ$invalid_section_ordinal;

    RESET object_library TO interpretive_element;
    REPEAT
      NEXT object_text_descriptor IN object_library;
      CASE object_text_descriptor^.kind OF
      = llc$identification =
        NEXT identification IN object_library;
      = llc$application_identifier =
        NEXT application_identifier IN object_library;
      = llc$libraries =
        NEXT libraries: [1 .. object_text_descriptor^.number_of_libraries] IN object_library;
      = llc$section_definition, llc$allotted_section_definition, llc$unallocated_common_block =
        NEXT section_definition IN object_library;
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := current_module.name;
        breaklist_item^.major_name := occ$section_definition;
        breaklist_item^.minor_name := section_definition^.name;
        breaklist_item^.offset := #OFFSET (object_text_descriptor);
        breaklist_item^.kind := occ$secdef;
        breaklist_item^.section_ordinal := current_module.change_list^ [section_definition^.section_ordinal];
        breaklist_item^.secondary_section_ordinal := 0;

        IF (section_definition^.kind <> llc$binding_section) AND
              (object_text_descriptor^.kind <> llc$allotted_section_definition) AND
              NOT current_module.bound_module THEN
          build_text_bl_for_unbound (section_definition^.section_ordinal, section_definition^.name,
                current_module, object_library, breaklist_seq_p, breaklist_index, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        ELSEIF section_definition^.kind = llc$binding_section THEN
          binding_section := section_definition^.section_ordinal;
        IFEND;
      = llc$external_linkage =
        NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN object_library;
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := current_module.name;
        breaklist_item^.major_name := occ$external_linkage;
        breaklist_item^.minor_name := external_linkage^.name;
        breaklist_item^.offset := #OFFSET (object_text_descriptor);
        breaklist_item^.kind := occ$ext;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      = llc$entry_definition =
        NEXT entry_definition IN object_library;
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := current_module.name;
        breaklist_item^.major_name := occ$entry_definition;
        breaklist_item^.minor_name := entry_definition^.name;
        breaklist_item^.offset := #OFFSET (object_text_descriptor);
        breaklist_item^.kind := occ$ept;
        breaklist_item^.section_ordinal := current_module.change_list^ [entry_definition^.section_ordinal];
        breaklist_item^.secondary_section_ordinal := 0;

      = llc$deferred_entry_points =
        NEXT deferred_entry_points: [1 .. object_text_descriptor^.number_of_entry_points] IN object_library;
        FOR deferred_index := 1 TO object_text_descriptor^.number_of_entry_points DO
          NEXT breaklist_item IN breaklist_seq_p;
          breaklist_index := breaklist_index + 1;
          breaklist_item^.module_name := current_module.name;
          breaklist_item^.major_name := occ$deferred_entry_point;
          breaklist_item^.minor_name := deferred_entry_points^ [deferred_index].name;
          breaklist_item^.offset := #OFFSET (^deferred_entry_points^ [deferred_index]);
          breaklist_item^.kind := occ$deferred_ept;
          breaklist_item^.section_ordinal := current_module.change_list^
                [deferred_entry_points^ [deferred_index].section_ordinal];
          breaklist_item^.secondary_section_ordinal := 0;
        FOREND;

      = llc$deferred_common_blocks =
        NEXT deferred_common_blocks: [1 .. object_text_descriptor^.number_of_common_blocks] IN object_library;
        FOR deferred_index := 1 TO object_text_descriptor^.number_of_common_blocks DO
          NEXT breaklist_item IN breaklist_seq_p;
          breaklist_index := breaklist_index + 1;
          breaklist_item^.module_name := current_module.name;
          breaklist_item^.major_name := occ$deferred_common_block;
          breaklist_item^.minor_name := deferred_common_blocks^ [deferred_index].name;
          breaklist_item^.offset := #OFFSET (^deferred_common_blocks^ [deferred_index]);
          breaklist_item^.kind := occ$deferred_common_blk;
          breaklist_item^.section_ordinal := 0;
          breaklist_item^.secondary_section_ordinal := 0;
        FOREND;

      = llc$segment_definition, llc$allotted_segment_definition =
        NEXT segment_definition IN object_library;
        section_definition := ^segment_definition^.section_definition;
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := current_module.name;
        breaklist_item^.major_name := occ$section_definition;
        breaklist_item^.minor_name := section_definition^.name;
        breaklist_item^.offset := #OFFSET (object_text_descriptor);
        breaklist_item^.kind := occ$secdef;
        breaklist_item^.section_ordinal := current_module.change_list^ [section_definition^.section_ordinal];
        breaklist_item^.secondary_section_ordinal := 0;

        IF (section_definition^.kind <> llc$binding_section) AND
              (object_text_descriptor^.kind = llc$segment_definition) AND NOT current_module.bound_module THEN
          build_text_bl_for_unbound (section_definition^.section_ordinal, section_definition^.name,
                current_module, object_library, breaklist_seq_p, breaklist_index, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      = llc$obsolete_segment_definition, llc$obsolete_allotted_seg_def =
        NEXT obsolete_segment_definition IN object_library;
        section_definition := ^obsolete_segment_definition^.section_definition;
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := current_module.name;
        breaklist_item^.major_name := occ$section_definition;
        breaklist_item^.minor_name := section_definition^.name;
        breaklist_item^.offset := #OFFSET (object_text_descriptor);
        breaklist_item^.kind := occ$secdef;
        breaklist_item^.section_ordinal := current_module.change_list^ [section_definition^.section_ordinal];
        breaklist_item^.secondary_section_ordinal := 0;

        IF (section_definition^.kind <> llc$binding_section) AND
              (object_text_descriptor^.kind = llc$obsolete_segment_definition) AND
              NOT current_module.bound_module THEN
          build_text_bl_for_unbound (section_definition^.section_ordinal, section_definition^.name,
                current_module, object_library, breaklist_seq_p, breaklist_index, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      = llc$obsolete_formal_parameters =
        NEXT obsolete_formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
              object_library;

      = llc$formal_parameters =
        NEXT formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;

      = llc$actual_parameters =
        NEXT actual_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;

      = llc$text =
        NEXT text: [1 .. object_text_descriptor^.number_of_bytes] IN object_library;

      = llc$replication =
        NEXT replication: [1 .. object_text_descriptor^.number_of_bytes] IN object_library;

      = llc$bit_string_insertion =
        NEXT bsi IN object_library;

      = llc$address_formulation =
        NEXT adr: [1 .. object_text_descriptor^.number_of_adr_items] IN object_library;
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := current_module.name;
        breaklist_item^.major_name := occ$address_formulation;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (object_text_descriptor);
        breaklist_item^.kind := occ$adr;
        breaklist_item^.section_ordinal := current_module.change_list^ [adr^.dest_section];
        breaklist_item^.secondary_section_ordinal := current_module.change_list^ [adr^.value_section];

      = llc$binding_template =
        NEXT binding_template IN object_library;

      = llc$relocation =
        NEXT relocation: [1 .. object_text_descriptor^.number_of_rel_items] IN object_library;

      = llc$cybil_symbol_table_fragment =
        NEXT debug_table_fragment: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;

      = llc$symbol_table =
        NEXT symbol_table: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;

      = llc$supplemental_debug_tables =
        NEXT supplemental_debug_tables: [[REP object_text_descriptor^.sequence_length OF cell]] IN
              object_library;

      = llc$68000_absolute =
        NEXT m68000_absolute: [[REP object_text_descriptor^.number_of_68000_bytes OF cell]] IN object_library;
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := current_module.name;
        breaklist_item^.major_name := occ$motorola_68000_absolute;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (object_text_descriptor);
        breaklist_item^.kind := occ$m68000;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      = llc$line_table =
        NEXT line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN object_library;

      = llc$obsolete_line_table =
        NEXT obsolete_line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN
              object_library;

      = llc$transfer_symbol =
        ;

      ELSE
        STRINGREP (message, length, object_text_descriptor^.kind);
        osp$set_status_abnormal (occ$status_id, oce$unexpected_record_kind, message (1, length), status);
        RETURN;

      CASEND;
    UNTIL object_text_descriptor^.kind = llc$transfer_symbol;
    IF current_module.bound_module THEN
      build_text_breaklist_items (object_library, current_module, breaklist_seq_p, breaklist_index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_adr_breaklist_items (object_library, current_module, binding_section, breaklist_seq_p,
            breaklist_index);
    IFEND;

  PROCEND build_load_module_breaklist;
?? OLDTITLE ??
?? NEWTITLE := 'build_module_map', EJECT ??

{ PURPOSE:
{   The purpose of this request is to build a directory containing
{ information about each module.  The directory contains the module
{ name, module kind, pointer to section definitions, greatest section
{ ordinal, whether the module is bound, a pointer to the section maps,
{ and the section number change vectors.

  PROCEDURE build_module_map
    (    p_object_library: ^SEQ ( * );
         module_directory: ^oct$module_directory;
         original_object_library: boolean;
     VAR module_map: ^oct$module_map;
     VAR status: ost$status);

    VAR
      found: boolean,
      i: llt$module_index,
      identification: ^llt$identification,
      info_element_header: ^llt$info_element_header,
      information_element: llt$info_element_header,
      interpretive_element: ^llt$object_text_descriptor,
      j: llt$section_ordinal,
      module_dictionary: ^llt$module_dictionary,
      module_header: ^llt$load_module_header,
      object_library: ^SEQ ( * ),
      object_library_dictionaries: ^llt$object_library_dictionaries,
      object_library_header: ^llt$object_library_header,
      object_text_descriptor: ^llt$object_text_descriptor,
      section_number_changes: ^oct$change_list;

    status.normal := TRUE;

    object_library := p_object_library;

    RESET object_library;
    NEXT object_library_header IN object_library;
    NEXT object_library_dictionaries: [1 .. object_library_header^.number_of_dictionaries] IN object_library;
    found := FALSE;
    i := 1;
    WHILE NOT found AND (i <= object_library_header^.number_of_dictionaries) DO
      IF object_library_dictionaries^ [i].kind = llc$module_dictionary THEN
        found := TRUE;
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;
    IF NOT found THEN
      RETURN;
    IFEND;
    module_dictionary := #PTR (object_library_dictionaries^ [i].module_dictionary, object_library^);
    ALLOCATE module_map: [1 .. UPPERBOUND (module_dictionary^)];
    FOR i := 1 TO UPPERBOUND (module_dictionary^) DO
      module_map^ [i].kind := module_dictionary^ [i].kind;
      module_map^ [i].name := module_dictionary^ [i].name;
      CASE module_dictionary^ [i].kind OF
      = llc$load_module =
        module_map^ [i].section_definitions := NIL;
        module_map^ [i].greatest_section_ordinal := 0;
        module_map^ [i].bound_module := FALSE;
        module_map^ [i].change_list := NIL;
        module_map^ [i].section_maps := NIL;
        module_map^ [i].component_info := NIL;
        module_header := #PTR (module_dictionary^ [i].module_header, object_library^);
        IF llc$interpretive_element IN module_header^.elements_defined THEN
          interpretive_element := #PTR (module_header^.interpretive_element, object_library^);
          RESET object_library TO interpretive_element;
          NEXT object_text_descriptor IN object_library;
          IF object_text_descriptor^.kind <> llc$identification THEN
            osp$set_status_abnormal (occ$status_id, oce$id_record_expected, '', status);
            RETURN;
          IFEND;
          NEXT identification IN object_library;
          IF llc$section_element IN module_header^.interpretive_header.elements_defined THEN
            module_map^ [i].section_definitions := #PTR (module_header^.interpretive_header.
                  section_definitions, object_library^);
          IFEND;
          module_map^ [i].greatest_section_ordinal := identification^.greatest_section_ordinal;
          IF original_object_library AND (module_directory^ [i].last_section_ordinal <>
                occ$invalid_section_ordinal) THEN
            ALLOCATE section_number_changes: [0 .. module_directory^ [i].last_section_ordinal];
            FOR j := 0 TO module_directory^ [i].last_section_ordinal DO
              section_number_changes^ [j] := module_directory^ [i].section_number_change_list^ [j];
            FOREND;
          ELSE
            ALLOCATE section_number_changes: [0 .. identification^.greatest_section_ordinal];
            FOR j := 0 TO identification^.greatest_section_ordinal DO
              section_number_changes^ [j] := j;
            FOREND;
          IFEND;
          module_map^ [i].change_list := section_number_changes;
        IFEND;
        IF llc$information_element IN module_header^.elements_defined THEN
          info_element_header := #PTR (module_header^.information_element, object_library^);
          IF info_element_header^.version = llc$info_element_version THEN
            information_element := info_element_header^;
          ELSE
            ocp$convert_information_element (info_element_header, information_element);
          IFEND;

          IF information_element.number_of_section_maps > 0 THEN
            module_map^ [i].section_maps := #PTR (information_element.section_maps, object_library^);
          IFEND;
          IF information_element.number_of_components > 0 THEN
            module_map^ [i].component_info := #PTR (information_element.component_ptr, object_library^);
            module_map^ [i].bound_module := TRUE;
          IFEND;
        IFEND;
      ELSE
        ;
      CASEND;
    FOREND;
  PROCEND build_module_map;
?? OLDTITLE ??
?? NEWTITLE := 'build_text_bl_for_unbound', EJECT ??

{ PURPOSE:
{   The purpose of this request is to build text breaklist items pointing
{ to the text, replication and bit string insertion records in an unbound
{ library.

  PROCEDURE build_text_bl_for_unbound
    (    section_ordinal: llt$section_ordinal;
         section_name: pmt$program_name;
         current_module: oct$module_map_item;
         p_object_library: ^SEQ ( * );
     VAR breaklist_seq_p: ^SEQ ( * );
     VAR breaklist_index: oct$breaklist_length;
     VAR status: ost$status);

    VAR
      actual_parameters: ^llt$actual_parameters,
      adr: ^llt$address_formulation,
      binding_template: ^llt$binding_template,
      bit_string_insertion: ^llt$bit_string_insertion,
      breaklist_item: ^oct$breaklist_item,
      debug_table_fragment: ^llt$debug_table_fragment,
      deferred_common_blocks: ^llt$deferred_common_blocks,
      deferred_entry_points: ^llt$deferred_entry_points,
      entry_definition: ^llt$entry_definition,
      external_linkage: ^llt$external_linkage,
      formal_parameters: ^llt$formal_parameters,
      length: integer,
      libraries: ^llt$libraries,
      line_address_table: ^llt$line_address_table,
      m68000_absolute: ^llt$68000_absolute,
      message: string (100),
      object_library: ^SEQ ( * ),
      object_text_descriptor: ^llt$object_text_descriptor,
      obsolete_formal_parameters: ^llt$obsolete_formal_parameters,
      obsolete_line_address_table: ^llt$obsolete_line_address_table,
      obsolete_segment_definition: ^llt$obsolete_segment_definition,
      relocation: ^llt$relocation,
      replication: ^llt$replication,
      section_definition: ^llt$section_definition,
      segment_definition: ^llt$segment_definition,
      supplemental_debug_tables: ^llt$supplemental_debug_tables,
      symbol_table: ^llt$symbol_table,
      text: ^llt$text,
      text_breaklist_made: boolean;

    status.normal := TRUE;

    object_library := p_object_library;

    RESET object_library TO current_module.section_definitions;
    text_breaklist_made := FALSE;
    REPEAT
      NEXT object_text_descriptor IN object_library;
      CASE object_text_descriptor^.kind OF
      = llc$section_definition, llc$allotted_section_definition, llc$unallocated_common_block =
        NEXT section_definition IN object_library;

      = llc$segment_definition, llc$allotted_segment_definition =
        NEXT segment_definition IN object_library;

      = llc$obsolete_segment_definition, llc$obsolete_allotted_seg_def =
        NEXT obsolete_segment_definition IN object_library;

      = llc$external_linkage =
        NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN object_library;

      = llc$entry_definition =
        NEXT entry_definition IN object_library;

      = llc$deferred_entry_points =
        NEXT deferred_entry_points: [1 .. object_text_descriptor^.number_of_entry_points] IN object_library;

      = llc$deferred_common_blocks =
        NEXT deferred_common_blocks: [1 .. object_text_descriptor^.number_of_common_blocks] IN object_library;

      = llc$obsolete_formal_parameters =
        NEXT obsolete_formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
              object_library;

      = llc$formal_parameters =
        NEXT formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;

      = llc$actual_parameters =
        NEXT actual_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;

      = llc$text =
        NEXT text: [1 .. object_text_descriptor^.number_of_bytes] IN object_library;
        IF (text^.section_ordinal = section_ordinal) AND NOT text_breaklist_made THEN
          NEXT breaklist_item IN breaklist_seq_p;
          breaklist_index := breaklist_index + 1;
          breaklist_item^.module_name := current_module.name;
          breaklist_item^.major_name := osc$null_name;
          breaklist_item^.minor_name := section_name;
          breaklist_item^.offset := #OFFSET (object_text_descriptor);
          breaklist_item^.kind := occ$text;
          breaklist_item^.section_ordinal := current_module.change_list^ [section_ordinal];
          breaklist_item^.secondary_section_ordinal := 0;
          text_breaklist_made := TRUE;
        IFEND;

      = llc$bit_string_insertion =
        NEXT bit_string_insertion IN object_library;
        IF (bit_string_insertion^.section_ordinal = section_ordinal) AND NOT text_breaklist_made THEN
          NEXT breaklist_item IN breaklist_seq_p;
          breaklist_index := breaklist_index + 1;
          breaklist_item^.module_name := current_module.name;
          breaklist_item^.major_name := osc$null_name;
          breaklist_item^.minor_name := section_name;
          breaklist_item^.offset := #OFFSET (object_text_descriptor);
          breaklist_item^.kind := occ$text;
          breaklist_item^.section_ordinal := current_module.change_list^ [section_ordinal];
          breaklist_item^.secondary_section_ordinal := 0;
          text_breaklist_made := TRUE;
        IFEND;

      = llc$replication =
        NEXT replication: [1 .. object_text_descriptor^.number_of_bytes] IN object_library;
        IF (replication^.section_ordinal = section_ordinal) AND NOT text_breaklist_made THEN
          NEXT breaklist_item IN breaklist_seq_p;
          breaklist_index := breaklist_index + 1;
          breaklist_item^.module_name := current_module.name;
          breaklist_item^.major_name := osc$null_name;
          breaklist_item^.minor_name := section_name;
          breaklist_item^.offset := #OFFSET (object_text_descriptor);
          breaklist_item^.kind := occ$text;
          breaklist_item^.section_ordinal := current_module.change_list^ [section_ordinal];
          breaklist_item^.secondary_section_ordinal := 0;
          text_breaklist_made := TRUE;
        IFEND;

      = llc$address_formulation =
        NEXT adr: [1 .. object_text_descriptor^.number_of_adr_items] IN object_library;

      = llc$binding_template =
        NEXT binding_template IN object_library;

      = llc$libraries =
        NEXT libraries: [1 .. object_text_descriptor^.number_of_libraries] IN object_library;

      = llc$relocation =
        NEXT relocation: [1 .. object_text_descriptor^.number_of_rel_items] IN object_library;

      = llc$cybil_symbol_table_fragment =
        NEXT debug_table_fragment: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;

      = llc$symbol_table =
        NEXT symbol_table: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;

      = llc$supplemental_debug_tables =
        NEXT supplemental_debug_tables: [[REP object_text_descriptor^.sequence_length OF cell]] IN
              object_library;

      = llc$68000_absolute =
        NEXT m68000_absolute: [[REP object_text_descriptor^.number_of_68000_bytes OF cell]] IN object_library;

      = llc$line_table =
        NEXT line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN object_library;

      = llc$obsolete_line_table =
        NEXT obsolete_line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN
              object_library;

      = llc$transfer_symbol =
        ;

      ELSE
        STRINGREP (message, length, object_text_descriptor^.kind);
        osp$set_status_abnormal (occ$status_id, oce$unexpected_record_kind, message (1, length), status);
        RETURN;
      CASEND;
    UNTIL object_text_descriptor^.kind = llc$transfer_symbol;

  PROCEND build_text_bl_for_unbound;
?? OLDTITLE ??
?? NEWTITLE := 'build_text_breaklist_items', EJECT ??

{ PURPOSE:
{   The purpose of this request is to build breaklist items pointing
{ to the text records in a bound module.

  PROCEDURE build_text_breaklist_items
    (    p_object_library: ^SEQ ( * );
         current_module: oct$module_map_item;
     VAR breaklist_seq_p: ^SEQ ( * );
     VAR breaklist_index: oct$breaklist_length;
     VAR status: ost$status);

    VAR
      end_of_section_definitions: boolean,
      object_library: ^SEQ ( * ),
      object_text_descriptor: ^llt$object_text_descriptor,
      section_definition: ^llt$section_definition,
      section_name: pmt$program_name,
      section_ordinal: llt$section_ordinal;

    status.normal := TRUE;

    object_library := p_object_library;

    end_of_section_definitions := FALSE;
    RESET object_library TO current_module.section_definitions;
    REPEAT
      NEXT object_text_descriptor IN object_library;
      CASE object_text_descriptor^.kind OF
      = llc$allotted_section_definition =
        NEXT section_definition IN object_library;

      = llc$section_definition, llc$unallocated_common_block =
        NEXT section_definition IN object_library;
        IF section_definition^.kind <> llc$binding_section THEN
          section_ordinal := section_definition^.section_ordinal;
          section_name := section_definition^.name;
          find_text_records (object_library, section_ordinal, section_name, current_module, breaklist_seq_p,
                breaklist_index, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      ELSE
        end_of_section_definitions := TRUE;
      CASEND;
    UNTIL end_of_section_definitions;

  PROCEND build_text_breaklist_items;
?? OLDTITLE ??
?? NEWTITLE := 'construct_code_breaklist', EJECT ??

{ PURPOSE:
{   The purpose of this request is to build breaklist items pointing
{ into the code section of the object library.

  PROCEDURE construct_code_breaklist
    (    p_object_library: ^SEQ ( * );
         module_map: ^oct$module_map;
     VAR breaklist_seq_p: ^SEQ ( * );
     VAR breaklist_index: oct$breaklist_length);

    VAR
      breaklist_item: ^oct$breaklist_item,
      code_section_found: boolean,
      end_of_section_definitions: boolean,
      first_record: ^llt$object_text_descriptor,
      i: llt$module_index,
      j: llt$number_of_sections,
      object_library: ^SEQ ( * ),
      obsolete_segment_definition: ^llt$obsolete_segment_definition,
      section_definition: ^llt$section_definition,
      section_map: ^llt$section_map_items,
      segment_definition: ^llt$segment_definition;

    object_library := p_object_library;

    FOR i := 1 TO UPPERBOUND (module_map^) DO
      IF module_map^ [i].kind = llc$load_module THEN
        IF NOT module_map^ [i].bound_module THEN
          end_of_section_definitions := FALSE;
          IF module_map^ [i].section_definitions = NIL THEN
            RETURN;
          IFEND;
          RESET object_library TO module_map^ [i].section_definitions;
          REPEAT
            NEXT first_record IN object_library;
            CASE first_record^.kind OF
            = llc$section_definition, llc$unallocated_common_block =
              NEXT section_definition IN object_library;
            = llc$allotted_section_definition =
              NEXT section_definition IN object_library;
              IF section_definition^.kind = llc$code_section THEN
                NEXT breaklist_item IN breaklist_seq_p;
                breaklist_index := breaklist_index + 1;
                breaklist_item^.module_name := module_map^ [i].name;
                breaklist_item^.major_name := osc$null_name;
                breaklist_item^.minor_name := section_definition^.name;
                breaklist_item^.offset := first_record^.allotted_section;
                breaklist_item^.kind := occ$code;
                breaklist_item^.section_ordinal := module_map^ [i].
                      change_list^ [section_definition^.section_ordinal];
                breaklist_item^.secondary_section_ordinal := 0;
              IFEND;
            = llc$segment_definition =
              NEXT segment_definition IN object_library;
            = llc$allotted_segment_definition =
              NEXT segment_definition IN object_library;
              section_definition := ^segment_definition^.section_definition;
              IF section_definition^.kind = llc$code_section THEN
                NEXT breaklist_item IN breaklist_seq_p;
                breaklist_index := breaklist_index + 1;
                breaklist_item^.module_name := module_map^ [i].name;
                breaklist_item^.major_name := osc$null_name;
                breaklist_item^.minor_name := section_definition^.name;
                breaklist_item^.offset := first_record^.allotted_segment;
                breaklist_item^.kind := occ$code;
                breaklist_item^.section_ordinal := module_map^ [i].
                      change_list^ [section_definition^.section_ordinal];
                breaklist_item^.secondary_section_ordinal := 0;
              IFEND;

            = llc$obsolete_segment_definition =
              NEXT obsolete_segment_definition IN object_library;

            = llc$obsolete_allotted_seg_def =
              NEXT obsolete_segment_definition IN object_library;
              section_definition := ^obsolete_segment_definition^.section_definition;
              IF section_definition^.kind = llc$code_section THEN
                NEXT breaklist_item IN breaklist_seq_p;
                breaklist_index := breaklist_index + 1;
                breaklist_item^.module_name := module_map^ [i].name;
                breaklist_item^.major_name := osc$null_name;
                breaklist_item^.minor_name := section_definition^.name;
                breaklist_item^.offset := first_record^.allotted_segment;
                breaklist_item^.kind := occ$code;
                breaklist_item^.section_ordinal := module_map^ [i].
                      change_list^ [section_definition^.section_ordinal];
                breaklist_item^.secondary_section_ordinal := 0;
              IFEND;
            ELSE
              end_of_section_definitions := TRUE;
            CASEND;
          UNTIL end_of_section_definitions;
        ELSE
          code_section_found := FALSE;
          end_of_section_definitions := FALSE;
          IF module_map^ [i].section_definitions = NIL THEN
            RETURN;
          IFEND;
          RESET object_library TO module_map^ [i].section_definitions;
          REPEAT
            NEXT first_record IN object_library;
            CASE first_record^.kind OF
            = llc$section_definition, llc$unallocated_common_block =
              NEXT section_definition IN object_library;
            = llc$allotted_section_definition =
              NEXT section_definition IN object_library;
              IF section_definition^.kind = llc$code_section THEN
                code_section_found := TRUE;
                IF module_map^ [i].section_maps <> NIL THEN
                  section_map := #PTR (module_map^ [i].section_maps^ [section_definition^.section_ordinal].
                        map, object_library^);
                  FOR j := 1 TO module_map^ [i].section_maps^ [section_definition^.section_ordinal].
                        number_of_items DO
                    NEXT breaklist_item IN breaklist_seq_p;
                    breaklist_index := breaklist_index + 1;
                    breaklist_item^.module_name := module_map^ [i].name;
                    breaklist_item^.major_name := module_map^ [i].component_info^ [section_map^ [j].
                          component].name;
                    breaklist_item^.minor_name := section_map^ [j].name;
                    breaklist_item^.offset := first_record^.allotted_section + section_map^ [j].offset;
                    breaklist_item^.kind := occ$code;
                    breaklist_item^.section_ordinal := module_map^ [i].
                          change_list^ [section_definition^.section_ordinal];
                    breaklist_item^.secondary_section_ordinal := 0;
                  FOREND;
                IFEND;
              IFEND;
            ELSE
              end_of_section_definitions := TRUE;
            CASEND;
          UNTIL code_section_found OR end_of_section_definitions;
        IFEND;
      IFEND;
    FOREND;

  PROCEND construct_code_breaklist;
?? OLDTITLE ??
?? NEWTITLE := 'construct_dictionary_bl', EJECT ??

{ PURPOSE:
{   The purpose of this request is to build breaklist items pointing
{ to the beginning of the object library, and to all the dictionaries
{ in the object library.

  PROCEDURE construct_dictionary_bl
    (    p_object_library: ^SEQ ( * );
     VAR breaklist_seq_p: ^SEQ ( * );
     VAR breaklist_index: oct$breaklist_length;
     VAR status: ost$status);

    VAR
      breaklist_item: ^oct$breaklist_item,
      command_dictionary: ^llt$command_dictionary,
      entry_point_dictionary: ^llt$entry_point_dictionary,
      function_dictionary: ^llt$function_dictionary,
      help_module_dictionary: ^llt$help_module_dictionary,
      i: 0 .. llc$max_dictionaries_on_library,
      length: integer,
      message: string (100),
      message_module_dictionary: ^llt$message_module_dictionary,
      module_dictionary: ^llt$module_dictionary,
      object_library: ^SEQ ( * ),
      ol_dictionaries: ^llt$object_library_dictionaries,
      ol_header: ^llt$object_library_header,
      panel_dictionary: ^llt$panel_dictionary;

    object_library := p_object_library;

    NEXT breaklist_item IN breaklist_seq_p;
    breaklist_index := breaklist_index + 1;
    breaklist_item^.module_name := occ$starting_breaklist;
    breaklist_item^.major_name := osc$null_name;
    breaklist_item^.minor_name := osc$null_name;
    breaklist_item^.offset := 0;
    breaklist_item^.kind := occ$object_library_header;
    breaklist_item^.section_ordinal := 0;
    breaklist_item^.secondary_section_ordinal := 0;

    RESET object_library;
    NEXT ol_header IN object_library;
    NEXT ol_dictionaries: [1 .. ol_header^.number_of_dictionaries] IN object_library;

    FOR i := 1 TO ol_header^.number_of_dictionaries DO
      CASE ol_dictionaries^ [i].kind OF
      = llc$module_dictionary =
        module_dictionary := #PTR (ol_dictionaries^ [i].module_dictionary, object_library^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := occ$module_dictionary;
        breaklist_item^.major_name := osc$null_name;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (module_dictionary);
        breaklist_item^.kind := occ$dictionary;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      = llc$entry_point_dictionary =
        entry_point_dictionary := #PTR (ol_dictionaries^ [i].entry_point_dictionary, object_library^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := occ$entry_point_dictionary;
        breaklist_item^.major_name := osc$null_name;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (entry_point_dictionary);
        breaklist_item^.kind := occ$dictionary;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      = llc$command_dictionary =
        command_dictionary := #PTR (ol_dictionaries^ [i].command_dictionary, object_library^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := occ$command_dictionary;
        breaklist_item^.major_name := osc$null_name;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (command_dictionary);
        breaklist_item^.kind := occ$dictionary;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      = llc$function_dictionary =
        function_dictionary := #PTR (ol_dictionaries^ [i].function_dictionary, object_library^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := occ$function_dictionary;
        breaklist_item^.major_name := osc$null_name;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (function_dictionary);
        breaklist_item^.kind := occ$dictionary;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      = llc$help_module_dictionary =
        help_module_dictionary := #PTR (ol_dictionaries^ [i].help_module_dictionary, object_library^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := occ$help_module_dictionary;
        breaklist_item^.major_name := osc$null_name;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (help_module_dictionary);
        breaklist_item^.kind := occ$dictionary;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      = llc$message_module_dictionary =
        message_module_dictionary := #PTR (ol_dictionaries^ [i].message_module_dictionary, object_library^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := occ$message_module_dictionary;
        breaklist_item^.major_name := osc$null_name;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (message_module_dictionary);
        breaklist_item^.kind := occ$dictionary;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      = llc$panel_dictionary =
        panel_dictionary := #PTR (ol_dictionaries^ [i].panel_dictionary, object_library^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := occ$panel_dictionary;
        breaklist_item^.major_name := osc$null_name;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (panel_dictionary);
        breaklist_item^.kind := occ$dictionary;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      ELSE
        STRINGREP (message, length, ol_dictionaries^ [i].kind);
        osp$set_status_abnormal (occ$status_id, oce$unexpected_record_kind, message (1, length), status);
        RETURN;
      CASEND;
    FOREND;

  PROCEND construct_dictionary_bl;
?? OLDTITLE ??
?? NEWTITLE := 'construct_information_bl', EJECT ??

{ PURPOSE:
{   The purpose of this request is to build breaklist items pointing
{ into the information element of the object library.

  PROCEDURE construct_information_bl
    (    p_object_library: ^SEQ ( * );
         module_map: ^oct$module_map;
         original_object_library: boolean;
         p_int_ol: ^SEQ ( * );
     VAR breaklist_seq_p: ^SEQ ( * );
     VAR breaklist_index: oct$breaklist_length);

    VAR
      address_name: ost$name,
      binding_template_int: ^llt$binding_section_template,
      binding_templates: ^llt$binding_section_template,
      breaklist_item: ^oct$breaklist_item,
      found: boolean,
      i: llt$module_index,
      info_element_header: ^llt$info_element_header,
      information_element: llt$info_element_header,
      int_ol: ^SEQ ( * ),
      j: 0 .. llc$max_rel_items,
      k: llt$number_of_sections,
      l: llt$number_of_sections,
      load_module_header: ^llt$load_module_header,
      module_dictionary: ^llt$module_dictionary,
      object_library: ^SEQ ( * ),
      object_library_dictionaries: ^llt$object_library_dictionaries,
      object_library_header: ^llt$object_library_header,
      relocation_int: ^llt$relocation,
      relocation_ptr: ^llt$relocation,
      section_map_items: ^llt$section_map_items,
      section_maps: ^llt$section_maps;

?? NEWTITLE := '[INLINE] convert_address_type_to_name', EJECT ??
    PROCEDURE [INLINE] convert_address_type_to_name
      (    address_type: llt$address_type;
       VAR address_name: ost$name);

      CASE address_type OF
      = llc$byte_positive =
        address_name := 'BYTE_POSITIVE';
      = llc$two_byte_positive =
        address_name := 'TWO_BYTE_POSITIVE';
      = llc$four_byte_positive =
        address_name := 'FOUR_BYTE_POSITIVE';
      = llc$eight_byte_positive =
        address_name := 'EIGHT_BYTE_POSITIVE';
      = llc$byte_signed =
        address_name := 'BYTE_SIGNED';
      = llc$two_byte_signed =
        address_name := 'TWO_BYTE_SIGNED';
      = llc$four_byte_signed =
        address_name := 'FOUR_BYTE_SIGNED';
      = llc$eight_byte_signed =
        address_name := 'EIGHT_BYTE_SIGNED';
      ELSE
      CASEND;

    PROCEND convert_address_type_to_name;
?? OLDTITLE ??
?? EJECT ??
    object_library := p_object_library;
    int_ol := p_int_ol;

    RESET object_library;
    NEXT object_library_header IN object_library;
    NEXT object_library_dictionaries: [1 .. object_library_header^.number_of_dictionaries] IN object_library;
    found := FALSE;
    i := 1;
    WHILE NOT found AND (i <= object_library_header^.number_of_dictionaries) DO
      IF object_library_dictionaries^ [i].kind = llc$module_dictionary THEN
        found := TRUE
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;
    IF NOT found THEN
      RETURN;
    IFEND;
    module_dictionary := #PTR (object_library_dictionaries^ [i].module_dictionary, object_library^);
    FOR i := 1 TO UPPERBOUND (module_dictionary^) DO
      IF module_dictionary^ [i].kind = llc$load_module THEN
        load_module_header := #PTR (module_dictionary^ [i].module_header, object_library^);
        IF llc$information_element IN load_module_header^.elements_defined THEN
          info_element_header := #PTR (load_module_header^.information_element, object_library^);
          NEXT breaklist_item IN breaklist_seq_p;
          breaklist_index := breaklist_index + 1;
          breaklist_item^.module_name := module_map^ [i].name;
          breaklist_item^.major_name := occ$info_element_header;
          breaklist_item^.minor_name := osc$null_name;
          breaklist_item^.offset := #OFFSET (info_element_header);
          breaklist_item^.kind := occ$info_element;
          breaklist_item^.section_ordinal := 0;
          breaklist_item^.secondary_section_ordinal := 0;

          IF info_element_header^.version = llc$info_element_version THEN
            information_element := info_element_header^;
          ELSE
            ocp$convert_information_element (info_element_header, information_element);
          IFEND;

          IF information_element.number_of_rel_items > 0 THEN
            relocation_ptr := #PTR (information_element.relocation_ptr, object_library^);
            IF original_object_library THEN
              relocation_int := #PTR (information_element.relocation_ptr, int_ol^);
            IFEND;
            FOR j := 1 TO information_element.number_of_rel_items DO
              NEXT breaklist_item IN breaklist_seq_p;
              breaklist_index := breaklist_index + 1;
              breaklist_item^.module_name := module_map^ [i].name;
              convert_address_type_to_name (relocation_ptr^ [j].address, address_name);
              breaklist_item^.major_name := address_name;
              breaklist_item^.minor_name := osc$null_name;
              breaklist_item^.offset := #OFFSET (^relocation_ptr^ [j]);
              breaklist_item^.kind := occ$rel;
              breaklist_item^.section_ordinal := module_map^ [i].change_list^ [relocation_ptr^ [j].
                    section_ordinal];
              IF original_object_library THEN
                breaklist_item^.secondary_section_ordinal := relocation_int^ [j].offset;
              ELSE
                breaklist_item^.secondary_section_ordinal := relocation_ptr^ [j].offset;
              IFEND;
            FOREND;
          IFEND;

          IF information_element.number_of_template_items > 0 THEN
            binding_templates := #PTR (information_element.binding_template_ptr, object_library^);
            IF original_object_library THEN
              binding_template_int := #PTR (information_element.binding_template_ptr, int_ol^);
            IFEND;
            FOR j := 1 TO information_element.number_of_template_items DO
              NEXT breaklist_item IN breaklist_seq_p;
              breaklist_index := breaklist_index + 1;
              breaklist_item^.module_name := module_map^ [i].name;
              breaklist_item^.major_name := occ$binding_template_records;
              breaklist_item^.offset := #OFFSET (^binding_templates^ [j]);
              breaklist_item^.kind := occ$bti;
              IF binding_templates^ [j].kind = llc$current_module THEN
                breaklist_item^.minor_name := osc$null_name;
                breaklist_item^.section_ordinal := module_map^ [i].change_list^ [binding_templates^ [j].
                      section_ordinal];
                IF original_object_library THEN
                  breaklist_item^.secondary_section_ordinal := binding_template_int^ [j].offset;
                ELSE
                  breaklist_item^.secondary_section_ordinal := binding_templates^ [j].offset;
                IFEND;
              ELSEIF binding_templates^ [j].kind = llc$external_reference THEN
                breaklist_item^.minor_name := binding_templates^ [j].name;
                breaklist_item^.section_ordinal := 0;
                breaklist_item^.secondary_section_ordinal := 0;
              IFEND;
            FOREND;
          IFEND;

          IF module_map^ [i].bound_module THEN
            IF information_element.number_of_components > 0 THEN
              FOR k := 1 TO information_element.number_of_components DO
                NEXT breaklist_item IN breaklist_seq_p;
                breaklist_index := breaklist_index + 1;
                breaklist_item^.module_name := module_map^ [i].name;
                breaklist_item^.major_name := occ$component_header;
                breaklist_item^.minor_name := module_map^ [i].component_info^ [k].name;
                breaklist_item^.offset := #OFFSET (^module_map^ [i].component_info^ [k]);
                breaklist_item^.kind := occ$component;
                breaklist_item^.section_ordinal := 0;
                breaklist_item^.secondary_section_ordinal := 0;
              FOREND;
            IFEND;

            IF information_element.number_of_section_maps > 0 THEN
              section_maps := #PTR (information_element.section_maps, object_library^);
              FOR k := 0 TO information_element.number_of_section_maps - 1 DO
                NEXT breaklist_item IN breaklist_seq_p;
                breaklist_index := breaklist_index + 1;
                breaklist_item^.module_name := module_map^ [i].name;
                breaklist_item^.major_name := occ$section_map_header;
                breaklist_item^.minor_name := osc$null_name;
                breaklist_item^.offset := #OFFSET (^section_maps^ [k]);
                breaklist_item^.kind := occ$section_map;
                breaklist_item^.section_ordinal := module_map^ [i].change_list^ [k];
                breaklist_item^.secondary_section_ordinal := 0;
              FOREND;
              FOR k := 0 TO information_element.number_of_section_maps - 1 DO
                section_map_items := #PTR (section_maps^ [k].map, object_library^);
                FOR l := 1 TO section_maps^ [k].number_of_items DO
                  NEXT breaklist_item IN breaklist_seq_p;
                  breaklist_index := breaklist_index + 1;
                  breaklist_item^.module_name := module_map^ [i].name;
                  IF module_map^ [i].component_info <> NIL THEN
                    breaklist_item^.major_name := module_map^ [i].component_info^ [section_map_items^ [l].
                          component].name;
                  ELSE
                    breaklist_item^.major_name := osc$null_name;
                  IFEND;
                  breaklist_item^.minor_name := section_map_items^ [l].name;
                  breaklist_item^.offset := #OFFSET (^section_map_items^ [l]);
                  breaklist_item^.kind := occ$section_map;
                  breaklist_item^.section_ordinal := module_map^ [i].change_list^ [k];
                  breaklist_item^.secondary_section_ordinal := 0;
                FOREND;
              FOREND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND construct_information_bl;
?? OLDTITLE ??
?? NEWTITLE := 'construct_interpretive_bl', EJECT ??

{ PURPOSE:
{   The purpose of this request is to build breaklist items pointing
{ into the interpretive element of the object library.

  PROCEDURE construct_interpretive_bl
    (    p_object_library: ^SEQ ( * );
         module_map: ^oct$module_map;
     VAR breaklist_seq_p: ^SEQ ( * );
     VAR breaklist_index: oct$breaklist_length;
     VAR status: ost$status);

    VAR
      application_member_header: ^llt$application_member_header,
      breaklist_item: ^oct$breaklist_item,
      found: boolean,
      i: llt$module_index,
      interpretive_element: ^llt$object_text_descriptor,
      load_module_header: ^llt$load_module_header,
      member_header: ^llt$library_member_header,
      message_header: ^llt$library_member_header,
      module_dictionary: ^llt$module_dictionary,
      object_library: ^SEQ ( * ),
      object_library_dictionaries: ^llt$object_library_dictionaries,
      object_library_header: ^llt$object_library_header;

    status.normal := TRUE;

    object_library := p_object_library;

    RESET object_library;
    NEXT object_library_header IN object_library;
    NEXT object_library_dictionaries: [1 .. object_library_header^.number_of_dictionaries] IN object_library;
    found := FALSE;
    i := 1;
    WHILE NOT found AND (i <= object_library_header^.number_of_dictionaries) DO
      IF object_library_dictionaries^ [i].kind = llc$module_dictionary THEN
        found := TRUE
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;
    IF NOT found THEN
      RETURN;
    IFEND;

    module_dictionary := #PTR (object_library_dictionaries^ [i].module_dictionary, object_library^);
    FOR i := 1 TO UPPERBOUND (module_dictionary^) DO
      CASE module_dictionary^ [i].kind OF
      = llc$load_module =
        load_module_header := #PTR (module_dictionary^ [i].module_header, object_library^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := module_map^ [i].name;
        breaklist_item^.major_name := occ$load_module_header;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (load_module_header);
        breaklist_item^.kind := occ$module_header;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

        IF llc$interpretive_element IN load_module_header^.elements_defined THEN
          interpretive_element := #PTR (load_module_header^.interpretive_element, object_library^);

          build_load_module_breaklist (module_map^ [i], object_library, interpretive_element, breaklist_seq_p,
                breaklist_index, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      = llc$command_procedure =
        member_header := #PTR (module_dictionary^ [i].command_header, object_library^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := module_map^ [i].name;
        breaklist_item^.major_name := occ$command_header;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (member_header);
        breaklist_item^.kind := occ$command_proc;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      = llc$program_description =
        member_header := #PTR (module_dictionary^ [i].program_header, object_library^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := module_map^ [i].name;
        breaklist_item^.major_name := occ$program_header;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (member_header);
        breaklist_item^.kind := occ$program_des;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      = llc$function_procedure =
        member_header := #PTR (module_dictionary^ [i].function_header, object_library^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := module_map^ [i].name;
        breaklist_item^.major_name := occ$function_header;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (member_header);
        breaklist_item^.kind := occ$function_proc;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      = llc$command_description =
        member_header := #PTR (module_dictionary^ [i].command_description_header, object_library^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := module_map^ [i].name;
        breaklist_item^.major_name := occ$command_description_header;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (member_header);
        breaklist_item^.kind := occ$command_des;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      = llc$function_description =
        member_header := #PTR (module_dictionary^ [i].function_description_header, object_library^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := module_map^ [i].name;
        breaklist_item^.major_name := occ$function_description_header;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (member_header);
        breaklist_item^.kind := occ$function_des;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      = llc$message_module { and llc$help_module} =
        message_header := #PTR (module_dictionary^ [i].message_header, object_library^);
        construct_mtm_breaklist (message_header, module_dictionary^ [i].name, object_library, breaklist_seq_p,
              breaklist_index);
      = llc$panel_module =
        member_header := #PTR (module_dictionary^ [i].panel_header, object_library^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := module_map^ [i].name;
        breaklist_item^.major_name := occ$panel_header;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (member_header);
        breaklist_item^.kind := occ$panel_mod;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      = llc$applic_command_procedure =
        application_member_header := #PTR (module_dictionary^ [i].applic_command_header, object_library^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := module_map^ [i].name;
        breaklist_item^.major_name := occ$command_header;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (application_member_header);
        breaklist_item^.kind := occ$app_command_proc;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      = llc$applic_program_description =
        application_member_header := #PTR (module_dictionary^ [i].applic_program_header, object_library^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := module_map^ [i].name;
        breaklist_item^.major_name := occ$program_header;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (application_member_header);
        breaklist_item^.kind := occ$app_program_des;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      = llc$applic_command_description =
        application_member_header := #PTR (module_dictionary^ [i].applic_command_description_hdr,
              object_library^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := module_map^ [i].name;
        breaklist_item^.major_name := occ$command_description_header;
        breaklist_item^.minor_name := osc$null_name;
        breaklist_item^.offset := #OFFSET (application_member_header);
        breaklist_item^.kind := occ$app_command_des;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;

      ELSE
        ;
      CASEND;
    FOREND;

  PROCEND construct_interpretive_bl;
?? OLDTITLE ??
?? NEWTITLE := 'construct_mtm_breaklist', EJECT ??

{ PURPOSE:
{   The purpose of this request is to build breaklist items for
{   a message template or a help module.

  PROCEDURE construct_mtm_breaklist
    (    message_header: ^llt$library_member_header;
         module_name: pmt$program_name;
         p_object_library: ^SEQ ( * );
     VAR breaklist_seq_p: ^SEQ ( * );
     VAR breaklist_index: oct$breaklist_length);

    VAR
      breaklist_item: ^oct$breaklist_item,
      code: ost$name,
      condition_codes: ^ost$mtm_condition_codes,
      condition_names: ^ost$mtm_condition_names,
      k: 0 .. osc$max_status_condition_code + 1,
      member: ^SEQ ( * ),
      member_header: ^SEQ ( * ),
      mtm_header: ^ost$mtm_header,
      object_library: ^SEQ ( * ),
      size: integer,
      template: ^ost$message_template;

    object_library := p_object_library;

    NEXT breaklist_item IN breaklist_seq_p;
    breaklist_index := breaklist_index + 1;
    breaklist_item^.module_name := module_name;
    breaklist_item^.major_name := occ$message_template_module;
    breaklist_item^.minor_name := osc$null_name;
    breaklist_item^.offset := #OFFSET (message_header);
    breaklist_item^.kind := occ$library_member_header;
    breaklist_item^.section_ordinal := 0;
    breaklist_item^.secondary_section_ordinal := 0;

    member_header := #PTR (message_header^.member, object_library^);
    NEXT breaklist_item IN breaklist_seq_p;
    breaklist_index := breaklist_index + 1;
    breaklist_item^.module_name := module_name;
    breaklist_item^.major_name := message_header^.name;
    breaklist_item^.minor_name := osc$null_name;
    breaklist_item^.offset := #OFFSET (member_header);
    breaklist_item^.kind := occ$mtm_header;
    breaklist_item^.section_ordinal := 0;
    breaklist_item^.secondary_section_ordinal := 0;

    RESET object_library TO member_header;
    NEXT member: [[REP message_header^.member_size OF cell]] IN object_library;
    RESET member;
    NEXT mtm_header IN member;
    IF mtm_header^.number_of_codes > 0 THEN
      NEXT condition_codes: [0 .. mtm_header^.number_of_codes - 1] IN member;

      FOR k := 0 TO mtm_header^.number_of_codes - 1 DO
        STRINGREP (code, size, condition_codes^ [k].code);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := module_name;
        breaklist_item^.major_name := occ$mtm_condition_code;
        breaklist_item^.minor_name := code (1, size);
        breaklist_item^.offset := #OFFSET (^condition_codes^ [k]);
        breaklist_item^.kind := occ$mtm_cc;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;
      FOREND;
    IFEND;

    IF mtm_header^.number_of_names > 0 THEN
      NEXT condition_names: [0 .. mtm_header^.number_of_names - 1] IN member;
      FOR k := 0 TO mtm_header^.number_of_names - 1 DO
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := module_name;
        breaklist_item^.major_name := occ$mtm_condition_name;
        breaklist_item^.minor_name := condition_names^ [k].name;
        breaklist_item^.offset := #OFFSET (^condition_names^ [k]);
        breaklist_item^.kind := occ$mtm_cn;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;
      FOREND;

      FOR k := 0 TO mtm_header^.number_of_names - 1 DO
        template := #PTR (condition_names^ [k].template, member^);
        NEXT breaklist_item IN breaklist_seq_p;
        breaklist_index := breaklist_index + 1;
        breaklist_item^.module_name := module_name;
        breaklist_item^.major_name := occ$message_template;
        breaklist_item^.minor_name := condition_names^ [k].name;
        breaklist_item^.offset := #OFFSET (template);
        breaklist_item^.kind := occ$mess_temp;
        breaklist_item^.section_ordinal := 0;
        breaklist_item^.secondary_section_ordinal := 0;
      FOREND;
    IFEND;

  PROCEND construct_mtm_breaklist;
?? OLDTITLE ??
?? NEWTITLE := 'construct_read_breaklist', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to construct breaklist items in
{ the working storage sections of the object library.

  PROCEDURE construct_read_breaklist
    (    p_object_library: ^SEQ ( * );
         module_map: ^oct$module_map;
     VAR breaklist_seq_p: ^SEQ ( * );
     VAR breaklist_index: oct$breaklist_length);

    VAR
      breaklist_item: ^oct$breaklist_item,
      first_record: ^llt$object_text_descriptor,
      i: llt$module_index,
      j: llt$number_of_sections,
      no_more_section_definitions: boolean,
      object_library: ^SEQ ( * ),
      obsolete_segment_definition: ^llt$obsolete_segment_definition,
      section_definition: ^llt$section_definition,
      section_map: ^llt$section_map_items,
      segment_definition: ^llt$segment_definition;

    object_library := p_object_library;

    FOR i := 1 TO UPPERBOUND (module_map^) DO
      IF module_map^ [i].kind = llc$load_module THEN
        no_more_section_definitions := FALSE;
        IF module_map^ [i].section_definitions = NIL THEN
          RETURN;
        IFEND;
        RESET object_library TO module_map^ [i].section_definitions;
        REPEAT
          NEXT first_record IN object_library;
          CASE first_record^.kind OF
          = llc$section_definition, llc$unallocated_common_block =
            NEXT section_definition IN object_library;
          = llc$allotted_section_definition =
            NEXT section_definition IN object_library;
            IF section_definition^.kind = llc$working_storage_section THEN
              IF module_map^ [i].bound_module THEN
                IF module_map^ [i].section_maps <> NIL THEN
                  section_map := #PTR (module_map^ [i].section_maps^ [section_definition^.section_ordinal].
                        map, object_library^);
                  FOR j := 1 TO module_map^ [i].section_maps^ [section_definition^.section_ordinal].
                        number_of_items DO
                    IF section_map^ [j].length > 0 THEN
                      NEXT breaklist_item IN breaklist_seq_p;
                      breaklist_index := breaklist_index + 1;
                      breaklist_item^.module_name := module_map^ [i].name;
                      breaklist_item^.major_name := module_map^ [i].component_info^ [section_map^ [j].
                            component].name;
                      breaklist_item^.minor_name := section_definition^.name;
                      breaklist_item^.offset := first_record^.allotted_section + section_map^ [j].offset;
                      breaklist_item^.kind := occ$read;
                      breaklist_item^.section_ordinal := module_map^ [i].
                            change_list^ [section_definition^.section_ordinal];
                      breaklist_item^.secondary_section_ordinal := 0;
                    IFEND;
                  FOREND;
                IFEND;
              ELSE
                NEXT breaklist_item IN breaklist_seq_p;
                breaklist_index := breaklist_index + 1;
                breaklist_item^.module_name := module_map^ [i].name;
                breaklist_item^.major_name := osc$null_name;
                breaklist_item^.minor_name := section_definition^.name;
                breaklist_item^.offset := first_record^.allotted_section;
                breaklist_item^.kind := occ$read;
                breaklist_item^.section_ordinal := module_map^ [i].
                      change_list^ [section_definition^.section_ordinal];
                breaklist_item^.secondary_section_ordinal := 0;
              IFEND;
            IFEND;
          = llc$segment_definition =
            NEXT segment_definition IN object_library;
          = llc$allotted_segment_definition =
            NEXT segment_definition IN object_library;
            section_definition := ^segment_definition^.section_definition;
            IF section_definition^.kind = llc$working_storage_section THEN
              IF module_map^ [i].bound_module THEN
                IF module_map^ [i].section_maps <> NIL THEN
                  section_map := #PTR (module_map^ [i].section_maps^ [section_definition^.section_ordinal].
                        map, object_library^);
                  FOR j := 1 TO module_map^ [i].section_maps^ [section_definition^.section_ordinal].
                        number_of_items DO
                    IF section_map^ [j].length > 0 THEN
                      NEXT breaklist_item IN breaklist_seq_p;
                      breaklist_index := breaklist_index + 1;
                      breaklist_item^.module_name := module_map^ [i].name;
                      breaklist_item^.major_name := module_map^ [i].component_info^ [section_map^ [j].
                            component].name;
                      breaklist_item^.minor_name := section_definition^.name;
                      breaklist_item^.offset := first_record^.allotted_segment + section_map^ [j].offset;
                      breaklist_item^.kind := occ$read;
                      breaklist_item^.section_ordinal := module_map^ [i].
                            change_list^ [section_definition^.section_ordinal];
                      breaklist_item^.secondary_section_ordinal := 0;
                    IFEND;
                  FOREND;
                IFEND;
              ELSE
                NEXT breaklist_item IN breaklist_seq_p;
                breaklist_index := breaklist_index + 1;
                breaklist_item^.module_name := module_map^ [i].name;
                breaklist_item^.major_name := osc$null_name;
                breaklist_item^.minor_name := section_definition^.name;
                breaklist_item^.offset := first_record^.allotted_segment;
                breaklist_item^.kind := occ$read;
                breaklist_item^.section_ordinal := module_map^ [i].
                      change_list^ [section_definition^.section_ordinal];
                breaklist_item^.secondary_section_ordinal := 0;
              IFEND;
            IFEND;
          = llc$obsolete_segment_definition =
            NEXT obsolete_segment_definition IN object_library;
          = llc$obsolete_allotted_seg_def =
            NEXT obsolete_segment_definition IN object_library;
            section_definition := ^obsolete_segment_definition^.section_definition;
            IF section_definition^.kind = llc$working_storage_section THEN
              IF module_map^ [i].bound_module THEN
                IF module_map^ [i].section_maps <> NIL THEN
                  section_map := #PTR (module_map^ [i].section_maps^ [section_definition^.section_ordinal].
                        map, object_library^);
                  FOR j := 1 TO module_map^ [i].section_maps^ [section_definition^.section_ordinal].
                        number_of_items DO
                    IF section_map^ [j].length > 0 THEN
                      NEXT breaklist_item IN breaklist_seq_p;
                      breaklist_index := breaklist_index + 1;
                      breaklist_item^.module_name := module_map^ [i].name;
                      breaklist_item^.major_name := module_map^ [i].component_info^ [section_map^ [j].
                            component].name;
                      breaklist_item^.minor_name := section_definition^.name;
                      breaklist_item^.offset := first_record^.allotted_segment + section_map^ [j].offset;
                      breaklist_item^.kind := occ$read;
                      breaklist_item^.section_ordinal := module_map^ [i].
                            change_list^ [section_definition^.section_ordinal];
                      breaklist_item^.secondary_section_ordinal := 0;
                    IFEND;
                  FOREND;
                IFEND;
              ELSE
                NEXT breaklist_item IN breaklist_seq_p;
                breaklist_index := breaklist_index + 1;
                breaklist_item^.module_name := module_map^ [i].name;
                breaklist_item^.major_name := osc$null_name;
                breaklist_item^.minor_name := section_definition^.name;
                breaklist_item^.offset := first_record^.allotted_segment;
                breaklist_item^.kind := occ$read;
                breaklist_item^.section_ordinal := module_map^ [i].
                      change_list^ [section_definition^.section_ordinal];
                breaklist_item^.secondary_section_ordinal := 0;
              IFEND;
            IFEND;
          ELSE
            no_more_section_definitions := TRUE;
          CASEND;
        UNTIL no_more_section_definitions;
      IFEND;
    FOREND;

  PROCEND construct_read_breaklist;
?? OLDTITLE ??
?? NEWTITLE := 'find_text_records', EJECT ??

{ PURPOSE:
{   The purpose of this request is to build breaklist items pointing
{ to the text records in a bound object library.

  PROCEDURE find_text_records
    (    object_library: ^SEQ ( * );
         section_ordinal: llt$section_ordinal;
         section_name: pmt$program_name;
         current_module: oct$module_map_item;
     VAR breaklist_seq_p: ^SEQ ( * );
     VAR breaklist_index: oct$breaklist_length;
     VAR status: ost$status);

    VAR
      breaklist_item: ^oct$breaklist_item,
      bsi: ^llt$bit_string_insertion,
      found: boolean,
      i: llt$number_of_sections,
      object_text_descriptor: ^llt$object_text_descriptor,
      offset: integer,
      replication: ^llt$replication,
      section_map: ^llt$section_map_items,
      text: ^llt$text;

    status.normal := TRUE;

    object_text_descriptor := current_module.section_definitions;
    section_map := #PTR (current_module.section_maps^ [section_ordinal].map, object_library^);
    FOR i := 1 TO current_module.section_maps^ [section_ordinal].number_of_items DO
      IF section_map^ [i].length > 0 THEN
        offset := 0;
        found := TRUE;
        WHILE found AND (offset = 0) DO
          get_next_text_rep_bsi (section_ordinal, object_library, found, object_text_descriptor, text,
                replication, bsi, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF NOT found THEN
            object_text_descriptor := current_module.section_definitions;
          ELSE
            IF object_text_descriptor^.kind = llc$bit_string_insertion THEN
              IF section_map^ [i].offset <= bsi^.offset THEN
                offset := #OFFSET (object_text_descriptor);
              ELSEIF (section_map^ [i].offset > bsi^.offset) AND
                    (section_map^ [i].offset < (bsi^.offset + ((bsi^.bit_length + bsi^.bit_offset) DIV 8)))
                    THEN
                osp$set_status_abnormal (occ$status_id, oce$section_map_invalid_pointer,
                      'bit_string_insertion', status);
                RETURN;
              IFEND;
            ELSEIF object_text_descriptor^.kind = llc$replication THEN
              IF section_map^ [i].offset <= replication^.offset THEN
                offset := #OFFSET (object_text_descriptor);
              ELSEIF (section_map^ [i].offset > replication^.offset) AND
                    (section_map^ [i].offset < (replication^.offset +
                    object_text_descriptor^.number_of_bytes)) THEN
                osp$set_status_abnormal (occ$status_id, oce$section_map_invalid_pointer, 'replication',
                      status);
                RETURN;
              IFEND;
            ELSEIF object_text_descriptor^.kind = llc$text THEN
              IF section_map^ [i].offset <= text^.offset THEN
                offset := #OFFSET (object_text_descriptor);
              ELSEIF (section_map^ [i].offset > text^.offset) AND
                    (section_map^ [i].offset < (text^.offset + object_text_descriptor^.number_of_bytes)) THEN
                offset := #OFFSET (^text^.byte) + section_map^ [i].offset - text^.offset;
              IFEND;
            IFEND;
          IFEND;
        WHILEND;
        IF offset <> 0 THEN
          NEXT breaklist_item IN breaklist_seq_p;
          breaklist_index := breaklist_index + 1;
          breaklist_item^.module_name := current_module.name;
          breaklist_item^.major_name := current_module.component_info^ [section_map^ [i].component].name;
          breaklist_item^.minor_name := section_name;
          breaklist_item^.offset := offset;
          breaklist_item^.kind := occ$text;
          breaklist_item^.section_ordinal := current_module.change_list^ [section_ordinal];
          breaklist_item^.secondary_section_ordinal := 0;
        IFEND;
      IFEND;
    FOREND;
  PROCEND find_text_records;
?? OLDTITLE ??
?? NEWTITLE := 'get_next_text_rep_bsi', EJECT ??

{ PURPOSE:
{   The purpose of this request is find the next text, replication or
{ bit string insertion record pair having the given section ordinal.

  PROCEDURE get_next_text_rep_bsi
    (    section_ordinal: llt$section_ordinal;
         p_object_library: ^SEQ ( * );
     VAR found: boolean;
     VAR object_text_descriptor: ^llt$object_text_descriptor;
     VAR text: ^llt$text;
     VAR replication: ^llt$replication;
     VAR bsi: ^llt$bit_string_insertion;
     VAR status: ost$status);

    VAR
      actual_parameters: ^llt$actual_parameters,
      adr: ^llt$address_formulation,
      binding_template: ^llt$binding_template,
      debug_table_fragment: ^llt$debug_table_fragment,
      deferred_common_blocks: ^llt$deferred_common_blocks,
      deferred_entry_points: ^llt$deferred_entry_points,
      entry_definition: ^llt$entry_definition,
      external_linkage: ^llt$external_linkage,
      formal_parameters: ^llt$formal_parameters,
      length: integer,
      libraries: ^llt$libraries,
      line_address_table: ^llt$line_address_table,
      m68000_absolute: ^llt$68000_absolute,
      message: string (100),
      object_library: ^SEQ ( * ),
      obsolete_formal_parameters: ^llt$obsolete_formal_parameters,
      obsolete_line_address_table: ^llt$obsolete_line_address_table,
      obsolete_segment_definition: ^llt$obsolete_segment_definition,
      ppu_absolute: ^llt$ppu_absolute,
      relocation: ^llt$relocation,
      section_definition: ^llt$section_definition,
      segment_definition: ^llt$segment_definition,
      supplemental_debug_tables: ^llt$supplemental_debug_tables,
      symbol_table: ^llt$symbol_table;

    status.normal := TRUE;

    object_library := p_object_library;

{ Skip over the the already processed object library record pair.

    found := FALSE;
    RESET object_library TO object_text_descriptor;
    NEXT object_text_descriptor IN object_library;
    CASE object_text_descriptor^.kind OF
    = llc$section_definition, llc$allotted_section_definition, llc$unallocated_common_block =
      NEXT section_definition IN object_library;
    = llc$segment_definition, llc$allotted_segment_definition =
      NEXT segment_definition IN object_library;
    = llc$obsolete_segment_definition, llc$obsolete_allotted_seg_def =
      NEXT obsolete_segment_definition IN object_library;
    = llc$external_linkage =
      NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN object_library;
    = llc$entry_definition =
      NEXT entry_definition IN object_library;
    = llc$deferred_entry_points =
      NEXT deferred_entry_points: [1 .. object_text_descriptor^.number_of_entry_points] IN object_library;
    = llc$deferred_common_blocks =
      NEXT deferred_common_blocks: [1 .. object_text_descriptor^.number_of_common_blocks] IN object_library;
    = llc$obsolete_formal_parameters =
      NEXT obsolete_formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
            object_library;
    = llc$formal_parameters =
      NEXT formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;
    = llc$actual_parameters =
      NEXT actual_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;
    = llc$text =
      NEXT text: [1 .. object_text_descriptor^.number_of_bytes] IN object_library;
    = llc$replication =
      NEXT replication: [1 .. object_text_descriptor^.number_of_bytes] IN object_library;
    = llc$bit_string_insertion =
      NEXT bsi IN object_library;
    = llc$address_formulation =
      NEXT adr: [1 .. object_text_descriptor^.number_of_adr_items] IN object_library;
    = llc$binding_template =
      NEXT binding_template IN object_library;
    = llc$libraries =
      NEXT libraries: [1 .. object_text_descriptor^.number_of_libraries] IN object_library;
    = llc$relocation =
      NEXT relocation: [1 .. object_text_descriptor^.number_of_rel_items] IN object_library;
    = llc$cybil_symbol_table_fragment =
      NEXT debug_table_fragment: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;
    = llc$symbol_table =
      NEXT symbol_table: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;
    = llc$supplemental_debug_tables =
      NEXT supplemental_debug_tables: [[REP object_text_descriptor^.sequence_length OF cell]] IN
            object_library;
    = llc$ppu_absolute =
      NEXT ppu_absolute: [0 .. object_text_descriptor^.number_of_words - 1] IN object_library;
    = llc$68000_absolute =
      NEXT m68000_absolute: [[REP object_text_descriptor^.number_of_68000_bytes OF cell]] IN object_library;
    = llc$line_table =
      NEXT line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN object_library;
    = llc$obsolete_line_table =
      NEXT obsolete_line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN object_library;
    = llc$transfer_symbol =
      RETURN;
    ELSE
      STRINGREP (message, length, object_text_descriptor^.kind);
      osp$set_status_abnormal (occ$status_id, oce$unexpected_record_kind, message (1, length), status);
      RETURN;
    CASEND;

{ Find the next TEXT, REPLICATION, or BIT STRING INSERTION record with section_ordinal.

    WHILE NOT found AND (object_text_descriptor^.kind <> llc$transfer_symbol) DO
      NEXT object_text_descriptor IN object_library;
      CASE object_text_descriptor^.kind OF
      = llc$section_definition, llc$allotted_section_definition, llc$unallocated_common_block =
        NEXT section_definition IN object_library;
      = llc$segment_definition, llc$allotted_segment_definition =
        NEXT segment_definition IN object_library;
      = llc$obsolete_segment_definition, llc$obsolete_allotted_seg_def =
        NEXT obsolete_segment_definition IN object_library;
      = llc$external_linkage =
        NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN object_library;
      = llc$entry_definition =
        NEXT entry_definition IN object_library;
      = llc$deferred_entry_points =
        NEXT deferred_entry_points: [1 .. object_text_descriptor^.number_of_entry_points] IN object_library;
      = llc$deferred_common_blocks =
        NEXT deferred_common_blocks: [1 .. object_text_descriptor^.number_of_common_blocks] IN object_library;
      = llc$obsolete_formal_parameters =
        NEXT obsolete_formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
              object_library;
      = llc$formal_parameters =
        NEXT formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;
      = llc$actual_parameters =
        NEXT actual_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;
      = llc$text =
        NEXT text: [1 .. object_text_descriptor^.number_of_bytes] IN object_library;
        IF text^.section_ordinal = section_ordinal THEN
          found := TRUE;
        IFEND;
      = llc$replication =
        NEXT replication: [1 .. object_text_descriptor^.number_of_bytes] IN object_library;
        IF replication^.section_ordinal = section_ordinal THEN
          found := TRUE;
        IFEND;
      = llc$bit_string_insertion =
        NEXT bsi IN object_library;
        IF bsi^.section_ordinal = section_ordinal THEN
          found := TRUE;
        IFEND;
      = llc$address_formulation =
        NEXT adr: [1 .. object_text_descriptor^.number_of_adr_items] IN object_library;
      = llc$binding_template =
        NEXT binding_template IN object_library;
      = llc$libraries =
        NEXT libraries: [1 .. object_text_descriptor^.number_of_libraries] IN object_library;
      = llc$relocation =
        NEXT relocation: [1 .. object_text_descriptor^.number_of_rel_items] IN object_library;
      = llc$cybil_symbol_table_fragment =
        NEXT debug_table_fragment: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;
      = llc$symbol_table =
        NEXT symbol_table: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;
      = llc$supplemental_debug_tables =
        NEXT supplemental_debug_tables: [[REP object_text_descriptor^.sequence_length OF cell]] IN
              object_library;
      = llc$ppu_absolute =
        NEXT ppu_absolute: [0 .. object_text_descriptor^.number_of_words - 1] IN object_library;
      = llc$68000_absolute =
        NEXT m68000_absolute: [[REP object_text_descriptor^.number_of_68000_bytes OF cell]] IN object_library;
      = llc$line_table =
        NEXT line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN object_library;
      = llc$obsolete_line_table =
        NEXT obsolete_line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN
              object_library;
      = llc$transfer_symbol =
        ;
      ELSE
        STRINGREP (message, length, object_text_descriptor^.kind);
        osp$set_status_abnormal (occ$status_id, oce$unexpected_record_kind, message (1, length), status);
        RETURN;
      CASEND;
    WHILEND;
  PROCEND get_next_text_rep_bsi;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$construct_breaklist', EJECT ??
*copy och$construct_breaklist

  PROCEDURE [XDCL] ocp$construct_breaklist
    (    p_object_library: ^SEQ ( * );
         module_directory: ^oct$module_directory;
         original_object_library: boolean;
         p_int_ol: ^SEQ ( * );
     VAR breaklist: ^oct$breaklist;
     VAR breaklist_seq_p: ^SEQ ( * );
     VAR breaklist_index: oct$breaklist_length;
     VAR status: ost$status);

    VAR
      i: oct$breaklist_length,
      index: oct$breaklist_length,
      int_ol: ^SEQ ( * ),
      j: llt$module_index,
      module_map: ^oct$module_map,
      object_library: ^SEQ ( * );

    status.normal := TRUE;

    object_library := p_object_library;
    int_ol := p_int_ol;

    build_module_map (object_library, module_directory, original_object_library, module_map, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET breaklist_seq_p;
    breaklist_index := 0;
    construct_dictionary_bl (object_library, breaklist_seq_p, breaklist_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    construct_code_breaklist (object_library, module_map, breaklist_seq_p, breaklist_index);

    construct_read_breaklist (object_library, module_map, breaklist_seq_p, breaklist_index);

    construct_interpretive_bl (object_library, module_map, breaklist_seq_p, breaklist_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    construct_information_bl (object_library, module_map, original_object_library, int_ol, breaklist_seq_p,
          breaklist_index);

    FOR j := 1 TO UPPERBOUND (module_map^) DO
      IF (module_map^ [j].kind = llc$load_module) AND (module_map^ [j].change_list <> NIL) THEN
        FREE module_map^ [j].change_list;
      IFEND;
    FOREND;
    FREE module_map;

    RESET breaklist_seq_p;
    NEXT breaklist: [1 .. breaklist_index] IN breaklist_seq_p;

    sort_breaklist (breaklist_index, breaklist);

    i := 1;
    index := 1;
    WHILE i <= breaklist_index DO
      WHILE (i < breaklist_index) AND (breaklist^ [i].offset = breaklist^ [i + 1].offset) DO
        i := i + 1;
      WHILEND;
      breaklist^ [index] := breaklist^ [i];
      IF index > 1 THEN
        breaklist^ [index - 1].length := breaklist^ [index].offset - breaklist^ [index - 1].offset;
      IFEND;
      index := index + 1;
      i := i + 1;
    WHILEND;
    breaklist_index := index - 1;

    breaklist^ [breaklist_index].length := #SIZE (object_library^) - breaklist^ [breaklist_index].offset;
  PROCEND ocp$construct_breaklist;
?? OLDTITLE ??
?? NEWTITLE := 'sort_breaklist', EJECT ??

{ PURPOSE:
{   The purpose of this request is to sort the breaklist.

  PROCEDURE sort_breaklist
    (    number: integer;
     VAR breaklist: ^oct$breaklist);

    VAR
      i: integer,
      j: integer,
      key: llt$section_offset,
      left: integer,
      right: integer,
      temp: oct$breaklist_item;

    IF number <= 1 THEN
      RETURN;
    ELSEIF number = 2 THEN
      IF breaklist^ [1].offset > breaklist^ [2].offset THEN
        temp := breaklist^ [1];
        breaklist^ [1] := breaklist^ [2];
        breaklist^ [2] := temp;
      IFEND;
      RETURN;
    IFEND;

    left := (number DIV 2) + 1;
    right := number;

  /outer_loop/
    WHILE TRUE DO
      IF left > 1 THEN
        left := left - 1;
        temp := breaklist^ [left];
        key := breaklist^ [left].offset;
      ELSE
        temp := breaklist^ [right];
        key := breaklist^ [right].offset;
        breaklist^ [right] := breaklist^ [1];
        right := right - 1;
        IF right = 1 THEN
          breaklist^ [right] := temp;
          RETURN;
        IFEND;
      IFEND;

      j := left;

    /inner_loop/
      WHILE TRUE DO
        i := j;
        j := j + j;
        IF j < right THEN
          IF (breaklist^ [j].offset < breaklist^ [j + 1].offset) THEN
            j := j + 1;
          IFEND;
        ELSEIF j > right THEN
          EXIT /inner_loop/;
        IFEND;

        IF key >= breaklist^ [j].offset THEN
          EXIT /inner_loop/;
        IFEND;

        breaklist^ [i] := breaklist^ [j];
      WHILEND /inner_loop/;

      breaklist^ [i] := temp;
    WHILEND /outer_loop/;

  PROCEND sort_breaklist;
?? OLDTITLE ??
MODEND ocm$construct_breaklist
*DECK DECK=OCM$CONVERT_64_TO_32_BITS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'PMM$CONVERT_64_TO_32_BITS', EJECT ??
MODULE ocm$convert_64_to_32_bits;



{ PURPOSE:  The purpose of this module is to convert a file packed 64 bits in
{           64 bits to a file packed 32 bits in 64 bits.




{ *callc clxspl  }
{ *callc clxgval }
{ *callc amxgfat }
{ *callc amxopen }
{ *callc amxgsgp }
{ *callc amxsete }
{ *callc amxclse }
{ *callc osxssa  }
{ *callc ocdvler }
?? PUSH (LISTEXT := ON) ??
*copyc CLP$SCAN_PARAMETER_LIST
*copyc CLP$GET_VALUE
*copyc AMP$GET_FILE_ATTRIBUTES
*copyc AMP$OPEN
*copyc AMP$GET_SEGMENT_POINTER
*copyc AMP$SET_SEGMENT_EOI
*copyc AMP$CLOSE
*copyc OSP$SET_STATUS_ABNORMAL
*copyc OCE$VE_LINKER_EXCEPTIONS
?? POP ??
?? NEWTITLE := '  PMP$CONVERT_64_TO_32_BITS', EJECT ??

  PROCEDURE [XDCL, #GATE] ocp$convert_64_to_32_bits (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{ pdt convert_pdt (
{   input, i : file = $required
{   output, o : file = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      convert_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^convert_pdt_names,
        ^convert_pdt_params];

    VAR
      convert_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
        clt$parameter_name_descriptor := [['INPUT', 1], ['I', 1], ['OUTPUT', 2], ['O', 2], ['STATUS', 3]];

    VAR
      convert_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ INPUT I }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ OUTPUT O }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??


    VAR
      input_parameter: clt$value,
      input_identifier: amt$file_identifier,
      input_segment: amt$segment_pointer,
      output_parameter: clt$value,
      output_identifier: amt$file_identifier,
      output_segment: amt$segment_pointer,
      local_file: boolean,
      existing_file: boolean,
      contains_data: boolean,
      length_attribute: [STATIC] array [1 .. 1] of amt$get_item := [[ * , amc$file_length, * ]],
      input_attributes: [STATIC] array [1 .. 1] of amt$access_selection := [[amc$access_mode,
        $pft$usage_selections [pfc$read]]],
      output_attributes: [STATIC] array [1 .. 1] of amt$access_selection := [[amc$access_mode,
        $pft$usage_selections [pfc$read, pfc$shorten, pfc$append, pfc$modify]]],
      input_word_array: ^ARRAY [1 .. * ] of 0 .. 0ffffffff(16),
      output_word_array: ^array [1 .. * ] of integer,
      input_byte_array: ^array [1 .. * ] of 0 .. 0ff(16),
      output_word: ^integer,
      i: integer,
      number_of_half_words: integer,
      number_of_bytes: integer;


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, convert_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    clp$get_value ('INPUT', 1, 1, clc$low, input_parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    clp$get_value ('OUTPUT', 1, 1, clc$low, output_parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
?? EJECT ??


    IF input_parameter.file.local_file_name = output_parameter.file.local_file_name THEN
      osp$set_status_abnormal ('OC', oce$e_duplicate_file_named, input_parameter.file.local_file_name,
            status);
      RETURN;
    IFEND;


    amp$get_file_attributes (input_parameter.file.local_file_name, length_attribute, local_file,
          existing_file, contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    number_of_half_words := (length_attribute [1].file_length DIV 4);
    number_of_bytes := (length_attribute [1].file_length - (number_of_half_words * 4));

    amp$open (input_parameter.file.local_file_name, amc$segment, ^input_attributes, input_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (input_identifier, amc$sequence_pointer, input_segment, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    amp$open (output_parameter.file.local_file_name, amc$segment, ^output_attributes, output_identifier,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (output_identifier, amc$sequence_pointer, output_segment, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
?? EJECT ??


    RESET input_segment.sequence_pointer;
    NEXT input_word_array: [1 .. number_of_half_words] IN input_segment.sequence_pointer;
    IF input_word_array = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'INPUT - 1', status);
      RETURN;
    IFEND;

    RESET output_segment.sequence_pointer;
    NEXT output_word_array: [1 .. number_of_half_words] IN output_segment.sequence_pointer;
    IF output_word_array = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'OUTPUT - 1', status);
      RETURN;
    IFEND;


    FOR i := 1 TO number_of_half_words DO
      output_word_array^ [i] := input_word_array^ [i];
    FOREND;


    IF number_of_bytes > 0 THEN
      NEXT input_byte_array: [1 .. number_of_bytes] IN input_segment.sequence_pointer;
      IF input_byte_array = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'INPUT - 2', status);
        RETURN;
      IFEND;

      NEXT output_word IN output_segment.sequence_pointer;
      IF output_word = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'OUTPUT - 2', status);
        RETURN;
      IFEND;


      output_word^ := 0;

      FOR i := 1 TO number_of_bytes DO
        output_word^ := (output_word^ * 100(16)) + input_byte_array^ [i];
      FOREND;
      FOR i := (number_of_bytes + 1) TO 4 DO
        output_word^ := output_word^ * 100(16);
      FOREND;
    IFEND;
?? EJECT ??


    amp$set_segment_eoi (output_identifier, output_segment, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$close (input_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$close (output_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;




  PROCEND ocp$convert_64_to_32_bits;


MODEND ocm$convert_64_to_32_bits.
*DECK DECK=OCM$COPY EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$copy;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc mmp$set_access_selections
*copyc syp$advised_move_bytes
?? POP ??

*copyc och$copy
  PROCEDURE [XDCL] ocp$copy (old_ol: ^SEQ ( * );
    VAR new_ol: ^SEQ ( * );
    VAR status: ost$status);

    VAR
      length: integer;

    length := #SIZE (old_ol^);
    mmp$set_access_selections (old_ol, mmc$as_sequential, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    mmp$set_access_selections (new_ol, mmc$as_sequential, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    syp$advised_move_bytes (old_ol, new_ol, length, status);

  PROCEND ocp$copy;
MODEND ocm$copy;

*DECK DECK=OCM$COPY_MODULES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
MODULE ocm$copy_modules;


{  This module contains the routines for copying modules to the temporary
{  library and file.


  VAR
    object_type_checking: [STATIC, READ] string (6) := 'OBJECT';

?? PUSH (LISTEXT := ON) ??
*copyc clt$scl_procedure
*copyc llt$deferred_common_blocks
*copyc llt$deferred_entry_points
*copyc llt$line_address_table
*copyc oce$library_generator_errors
*copyc oct$changed_info
*copyc oct$debug_table
*copyc oct$display_toggles
*copyc oct$external_declaration_list
*copyc oct$module_description
*copyc oct$segment_relocation_info
*copyc ost$message_template_module
?? POP ??
*copyc i#move
*copyc ocp$convert_information_element
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc pmp$position_object_library
*copyc ocv$olg_scratch_seq

?? NEWTITLE := '  OCP$RELOCATE_SEG_DEFINITIONS', EJECT ??

  PROCEDURE [XDCL] ocp$relocate_seg_definitions
    (    relocation: ^llt$relocation;
         segment_relocation_info: ^oct$segment_relocation_info);


    VAR
      i: integer,
      offset: ^ost$segment_length,
      rs: llt$section_ordinal,
      so: llt$section_ordinal;


    FOR i := 1 TO UPPERBOUND (relocation^) DO
      rs := relocation^ [i].relocating_section;

      IF segment_relocation_info^ [rs].old_offset <> segment_relocation_info^ [rs].new_offset THEN
        so := relocation^ [i].section_ordinal;
        offset := #LOC (segment_relocation_info^ [so].text^ [(relocation^ [i].offset + 1)]);

        offset^ := offset^ -segment_relocation_info^ [rs].old_offset +
              segment_relocation_info^ [rs].new_offset;
      IFEND;
    FOREND;


  PROCEND ocp$relocate_seg_definitions;
?? OLDTITLE ??
?? NEWTITLE := 'FIND_OLD_ENTRY_POINT_NAME' ??
?? EJECT ??

  PROCEDURE find_old_entry_point_name
    (    module_name: pmt$program_name;
         changed_entry_points: ^oct$external_declaration_list;
         old_name: pmt$program_name;
     VAR new_name: pmt$program_name;
     VAR status: ost$status);

    VAR
      entry_point: ^oct$external_declaration_list,
      external_declaration_list: ^oct$external_declaration_list;


    status.normal := TRUE;

    external_declaration_list := changed_entry_points;
    WHILE (external_declaration_list <> NIL) AND (external_declaration_list^.old_name <> old_name) DO
      external_declaration_list := external_declaration_list^.link;
    WHILEND;

    IF external_declaration_list = NIL THEN
      osp$set_status_abnormal (oc, oce$entry_not_found_for_formal, old_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, module_name, status);
      RETURN;
    IFEND;

    new_name := external_declaration_list^.name;

  PROCEND find_old_entry_point_name;

?? OLDTITLE ??
?? NEWTITLE := '  COPY_CPU_OBJECT_MODULE' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_cpu_object_module
    (    module_description: ^oct$module_description;
         changed_info: ^oct$changed_info;
     VAR temporary_object_file: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      old_object_text_descriptor: ^llt$object_text_descriptor,
      old_identification: ^llt$identification,
      old_application_identifier: ^llt$application_identifier,
      old_libraries: ^llt$libraries,
      old_section_definition: ^llt$section_definition,
      old_segment_definition: ^llt$segment_definition,
      old_obsolete_segment_def: ^llt$obsolete_segment_definition,
      old_text: ^llt$text,
      old_replication: ^llt$replication,
      old_bit_string_insertion: ^llt$bit_string_insertion,
      old_entry_definition: ^llt$entry_definition,
      old_deferred_entry_points: ^llt$deferred_entry_points,
      old_deferred_common_blocks: ^llt$deferred_common_blocks,
      old_relocation: ^llt$relocation,
      old_address_formulation: ^llt$address_formulation,
      old_external_linkage: ^llt$external_linkage,
      old_obsolete_formal_parameters: ^llt$obsolete_formal_parameters,
      old_formal_parameters: ^llt$formal_parameters,
      old_actual_parameters: ^llt$actual_parameters,
      old_debug_table_fragment: ^llt$debug_table_fragment,
      old_obsolete_line_address_table: ^llt$obsolete_line_address_table,
      old_symbol_table: ^llt$symbol_table,
      old_line_address_table: ^llt$line_address_table,
      old_supplemental_debug_tables: ^llt$supplemental_debug_tables,
      old_binding_template: ^llt$binding_template,
      old_m68000_absolute: ^llt$68000_absolute,
      old_transfer_symbol: ^llt$transfer_symbol;

    VAR
      new_object_text_descriptor: ^llt$object_text_descriptor,
      new_identification: ^llt$identification,
      new_application_identifier: ^llt$application_identifier,
      new_libraries: ^llt$libraries,
      new_section_definition: ^llt$section_definition,
      new_segment_definition: ^llt$segment_definition,
      new_obsolete_segment_def: ^llt$obsolete_segment_definition,
      new_text: ^llt$text,
      new_replication: ^llt$replication,
      new_bit_string_insertion: ^llt$bit_string_insertion,
      new_entry_definition: ^llt$entry_definition,
      new_deferred_entry_points: ^llt$deferred_entry_points,
      new_deferred_common_blocks: ^llt$deferred_common_blocks,
      new_relocation: ^llt$relocation,
      new_address_formulation: ^llt$address_formulation,
      new_external_linkage: ^llt$external_linkage,
      new_formal_parameters: ^llt$formal_parameters,
      new_actual_parameters: ^llt$actual_parameters,
      new_debug_table_fragment: ^llt$debug_table_fragment,
      new_obsolete_line_address_table: ^llt$obsolete_line_address_table,
      new_symbol_table: ^llt$symbol_table,
      new_line_address_table: ^llt$line_address_table,
      new_supplemental_debug_tables: ^llt$supplemental_debug_tables,
      new_binding_template: ^llt$binding_template,
      new_m68000_absolute: ^llt$68000_absolute,
      new_transfer_symbol: ^llt$transfer_symbol;

    VAR
      module_name: pmt$program_name,
      application_identifier_changed: boolean,
      libraries_have_been_changed: boolean,
      library_list: ^oct$name_list,
      number_of_libraries: integer,
      library_name: integer,
      entry_points_have_been_changed: boolean,
      new_entry_point: ^oct$external_declaration_list,
      new_starting_procedure: pmt$program_name,
      debug_tables_to_omit: oct$debug_tables;


    RESET module_description^.file TO module_description^.cpu_object_module_header^.identification;


    NEXT new_object_text_descriptor IN temporary_object_file;

    IF new_object_text_descriptor = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY1', status);
      RETURN;
    IFEND;

    new_object_text_descriptor^.kind := llc$identification;


    NEXT old_identification IN module_description^.file;
    NEXT new_identification IN temporary_object_file;

    IF new_identification = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY2', status);
      RETURN;
    IFEND;

    new_identification^ := old_identification^;

    application_identifier_changed := FALSE;
    entry_points_have_been_changed := FALSE;

    IF changed_info <> NIL THEN
      IF changed_info^.name <> NIL THEN
        new_identification^.name := changed_info^.name^;
      IFEND;

      IF changed_info^.commentary <> NIL THEN
        new_identification^.commentary := changed_info^.commentary^;
      IFEND;

      IF changed_info^.entry_points <> NIL THEN
        entry_points_have_been_changed := TRUE;
        new_entry_point := changed_info^.entry_points;
        new_starting_procedure := changed_info^.starting_procedure;
      IFEND;

      IF changed_info^.application_identifier <> NIL THEN
        application_identifier_changed := TRUE;
      IFEND;

      IF changed_info^.cybil_parameter_checking = object_type_checking THEN
        new_identification^.attributes := new_identification^.attributes +
              $llt$module_attributes [llc$object_cybil_checking];
      ELSE
        new_identification^.attributes := new_identification^.attributes -
              $llt$module_attributes [llc$object_cybil_checking];
      IFEND;

      libraries_have_been_changed := changed_info^.new_libraries;
      debug_tables_to_omit := changed_info^.debug_tables_to_omit;
    ELSE
      libraries_have_been_changed := FALSE;
      debug_tables_to_omit := $oct$debug_tables [];
    IFEND;

    IF application_identifier_changed AND (changed_info^.application_identifier^.name <> osc$null_name) THEN
      NEXT new_object_text_descriptor IN temporary_object_file;
      IF new_object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY2.25', status);
        RETURN;
      IFEND;

      new_object_text_descriptor^.kind := llc$application_identifier;

      NEXT new_application_identifier IN temporary_object_file;
      IF new_application_identifier = NIL THEN
        osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY2.5', status);
        RETURN;
      IFEND;

      new_application_identifier^.name := changed_info^.application_identifier^.name;
    IFEND;

    IF libraries_have_been_changed THEN
      IF changed_info^.library_list <> NIL THEN
        number_of_libraries := 0;
        library_list := changed_info^.library_list;
        WHILE library_list <> NIL DO
          number_of_libraries := number_of_libraries + 1;
          library_list := library_list^.link;
        WHILEND;

        IF number_of_libraries > llc$max_libraries THEN
          osp$set_status_abnormal (oc, oce$e_too_many_libraries, '', status);
          RETURN;
        IFEND;

        NEXT new_object_text_descriptor IN temporary_object_file;
        IF new_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY3', status);
          RETURN;
        IFEND;

        new_object_text_descriptor^.kind := llc$libraries;
        new_object_text_descriptor^.number_of_libraries := number_of_libraries;

        NEXT new_libraries: [1 .. new_object_text_descriptor^.number_of_libraries] IN temporary_object_file;
        IF new_libraries = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY4', status);
          RETURN;
        IFEND;

        library_list := changed_info^.library_list;
        FOR library_name := 1 TO number_of_libraries DO
          new_libraries^ [library_name] := library_list^.name;
          library_list := library_list^.link;
        FOREND;
      IFEND;
    IFEND;

    REPEAT
      NEXT old_object_text_descriptor IN module_description^.file;
      NEXT new_object_text_descriptor IN temporary_object_file;

      IF new_object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY5', status);
        RETURN;
      IFEND;

      new_object_text_descriptor^ := old_object_text_descriptor^;


      CASE new_object_text_descriptor^.kind OF
      = llc$application_identifier =
        NEXT old_application_identifier IN module_description^.file;

        IF NOT application_identifier_changed THEN
          NEXT new_application_identifier IN temporary_object_file;
          IF new_application_identifier = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY5.5', status);
            RETURN;
          IFEND;

          new_application_identifier^ := old_application_identifier^;
        ELSE
          RESET temporary_object_file TO new_object_text_descriptor;
        IFEND;

      = llc$libraries =
        NEXT old_libraries: [1 .. old_object_text_descriptor^.number_of_libraries] IN
              module_description^.file;

        IF NOT libraries_have_been_changed THEN
          NEXT new_libraries: [1 .. new_object_text_descriptor^.number_of_libraries] IN temporary_object_file;

          IF new_libraries = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY6', status);
            RETURN;
          IFEND;

          new_libraries^ := old_libraries^;
        ELSE
          RESET temporary_object_file TO new_object_text_descriptor;
        IFEND;

      = llc$section_definition, llc$unallocated_common_block =
        NEXT old_section_definition IN module_description^.file;
        NEXT new_section_definition IN temporary_object_file;

        IF new_section_definition = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY7', status);
          RETURN;
        IFEND;

        new_section_definition^ := old_section_definition^;


      = llc$segment_definition =
        NEXT old_segment_definition IN module_description^.file;
        NEXT new_segment_definition IN temporary_object_file;

        IF new_segment_definition = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY8', status);
          RETURN;
        IFEND;

        new_segment_definition^ := old_segment_definition^;

      = llc$obsolete_segment_definition =
        NEXT old_obsolete_segment_def IN module_description^.file;
        NEXT new_obsolete_segment_def IN temporary_object_file;

        IF new_obsolete_segment_def = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY9', status);
          RETURN;
        IFEND;

        new_obsolete_segment_def^ := old_obsolete_segment_def^;

      = llc$text =
        NEXT old_text: [1 .. old_object_text_descriptor^.number_of_bytes] IN module_description^.file;
        NEXT new_text: [1 .. new_object_text_descriptor^.number_of_bytes] IN temporary_object_file;

        IF new_text = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY10', status);
          RETURN;
        IFEND;

        new_text^ := old_text^;


      = llc$replication =
        NEXT old_replication: [1 .. old_object_text_descriptor^.number_of_bytes] IN module_description^.file;
        NEXT new_replication: [1 .. new_object_text_descriptor^.number_of_bytes] IN temporary_object_file;

        IF new_replication = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY11', status);
          RETURN;
        IFEND;

        new_replication^ := old_replication^;


      = llc$bit_string_insertion =
        NEXT old_bit_string_insertion IN module_description^.file;
        NEXT new_bit_string_insertion IN temporary_object_file;

        IF new_bit_string_insertion = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY12', status);
          RETURN;
        IFEND;

        new_bit_string_insertion^ := old_bit_string_insertion^;

      = llc$entry_definition =
        NEXT old_entry_definition IN module_description^.file;

        IF (entry_points_have_been_changed) AND (new_entry_point^.name = osc$null_name) THEN
          new_entry_point := new_entry_point^.link;
          RESET temporary_object_file TO new_object_text_descriptor;
        ELSE
          NEXT new_entry_definition IN temporary_object_file;

          IF new_entry_definition = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY13', status);
            RETURN;
          IFEND;

          new_entry_definition^ := old_entry_definition^;

          IF entry_points_have_been_changed THEN
            new_entry_definition^.name := new_entry_point^.name;
            new_entry_definition^.attributes := new_entry_point^.attributes;
            new_entry_point := new_entry_point^.link;
          IFEND;
        IFEND;

      = llc$deferred_entry_points =
        NEXT old_deferred_entry_points: [1 .. old_object_text_descriptor^.number_of_entry_points] IN
              module_description^.file;
        NEXT new_deferred_entry_points: [1 .. new_object_text_descriptor^.number_of_entry_points] IN
              temporary_object_file;

        IF new_deferred_entry_points = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY13.3', status);
          RETURN;
        IFEND;

        new_deferred_entry_points^ := old_deferred_entry_points^;

      = llc$deferred_common_blocks =
        NEXT old_deferred_common_blocks: [1 .. old_object_text_descriptor^.number_of_common_blocks] IN
              module_description^.file;
        NEXT new_deferred_common_blocks: [1 .. new_object_text_descriptor^.number_of_common_blocks] IN
              temporary_object_file;

        IF new_deferred_common_blocks = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY13.6', status);
          RETURN;
        IFEND;

        new_deferred_common_blocks^ := old_deferred_common_blocks^;

      = llc$relocation =
        NEXT old_relocation: [1 .. old_object_text_descriptor^.number_of_rel_items] IN
              module_description^.file;
        NEXT new_relocation: [1 .. new_object_text_descriptor^.number_of_rel_items] IN temporary_object_file;

        IF new_relocation = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY14', status);
          RETURN;
        IFEND;

        new_relocation^ := old_relocation^;

      = llc$address_formulation =
        NEXT old_address_formulation: [1 .. old_object_text_descriptor^.number_of_adr_items] IN
              module_description^.file;
        NEXT new_address_formulation: [1 .. new_object_text_descriptor^.number_of_adr_items] IN
              temporary_object_file;

        IF new_address_formulation = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY15', status);
          RETURN;
        IFEND;

        new_address_formulation^ := old_address_formulation^;


      = llc$external_linkage =
        NEXT old_external_linkage: [1 .. old_object_text_descriptor^.number_of_ext_items] IN
              module_description^.file;
        NEXT new_external_linkage: [1 .. new_object_text_descriptor^.number_of_ext_items] IN
              temporary_object_file;

        IF new_external_linkage = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY16', status);
          RETURN;
        IFEND;

        new_external_linkage^ := old_external_linkage^;



      = llc$obsolete_formal_parameters =
        NEXT old_obsolete_formal_parameters: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;
        RESET temporary_object_file TO new_object_text_descriptor;


      = llc$formal_parameters =
        NEXT old_formal_parameters: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;

        IF NOT (occ$parameter_checking IN debug_tables_to_omit) THEN
          NEXT new_formal_parameters: [[REP new_object_text_descriptor^.sequence_length OF cell]] IN
                temporary_object_file;

          IF new_formal_parameters = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY17', status);
            RETURN;
          IFEND;

          new_formal_parameters^ := old_formal_parameters^;

          IF entry_points_have_been_changed THEN
            find_old_entry_point_name (module_description^.name, changed_info^.entry_points,
                  old_formal_parameters^.procedure_name, new_formal_parameters^.procedure_name, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF (new_formal_parameters^.procedure_name = osc$null_name) THEN
              RESET temporary_object_file TO new_object_text_descriptor;
              RETURN;
            IFEND;
          IFEND;
        ELSE
          RESET temporary_object_file TO new_object_text_descriptor;
        IFEND;


      = llc$actual_parameters =
        NEXT old_actual_parameters: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;

        IF NOT (occ$parameter_checking IN debug_tables_to_omit) THEN
          NEXT new_actual_parameters: [[REP new_object_text_descriptor^.sequence_length OF cell]] IN
                temporary_object_file;

          IF new_actual_parameters = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY18', status);
            RETURN;
          IFEND;

          new_actual_parameters^ := old_actual_parameters^;
        ELSE
          RESET temporary_object_file TO new_object_text_descriptor;
        IFEND;


      = llc$binding_template =
        NEXT old_binding_template IN module_description^.file;
        NEXT new_binding_template IN temporary_object_file;

        IF new_binding_template = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY19', status);
          RETURN;
        IFEND;

        new_binding_template^ := old_binding_template^;

      = llc$cybil_symbol_table_fragment =
        NEXT old_debug_table_fragment: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;

        IF NOT (occ$symbol_table IN debug_tables_to_omit) THEN
          NEXT new_debug_table_fragment: [[REP new_object_text_descriptor^.sequence_length OF cell]] IN
                temporary_object_file;

          IF new_debug_table_fragment = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY20', status);
            RETURN;
          IFEND;

          new_debug_table_fragment^ := old_debug_table_fragment^;
        ELSE
          RESET temporary_object_file TO new_object_text_descriptor;
        IFEND;


      = llc$obsolete_line_table =
        NEXT old_obsolete_line_address_table: [1 .. old_object_text_descriptor^.number_of_line_items] IN
              module_description^.file;

        IF NOT (occ$line_table IN debug_tables_to_omit) THEN
          NEXT new_obsolete_line_address_table: [1 .. new_object_text_descriptor^.number_of_line_items] IN
                temporary_object_file;

          IF new_obsolete_line_address_table = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY21', status);
            RETURN;
          IFEND;

          new_obsolete_line_address_table^ := old_obsolete_line_address_table^;
        ELSE
          RESET temporary_object_file TO new_object_text_descriptor;
        IFEND;

      = llc$symbol_table =
        NEXT old_symbol_table: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;

        IF NOT (occ$symbol_table IN debug_tables_to_omit) THEN
          NEXT new_symbol_table: [[REP new_object_text_descriptor^.sequence_length OF cell]] IN
                temporary_object_file;

          IF new_symbol_table = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY22', status);
            RETURN;
          IFEND;

          new_symbol_table^ := old_symbol_table^;
        ELSE
          RESET temporary_object_file TO new_object_text_descriptor;
        IFEND;


      = llc$line_table =
        NEXT old_line_address_table: [1 .. old_object_text_descriptor^.number_of_line_items] IN
              module_description^.file;

        IF NOT (occ$line_table IN debug_tables_to_omit) THEN
          NEXT new_line_address_table: [1 .. new_object_text_descriptor^.number_of_line_items] IN
                temporary_object_file;

          IF new_line_address_table = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY23', status);
            RETURN;
          IFEND;

          new_line_address_table^ := old_line_address_table^;
        ELSE
          RESET temporary_object_file TO new_object_text_descriptor;
        IFEND;

      = llc$supplemental_debug_tables =
        NEXT old_supplemental_debug_tables: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;

        IF NOT (occ$supplemental_debug_table IN debug_tables_to_omit) THEN
          NEXT new_supplemental_debug_tables: [[REP new_object_text_descriptor^.sequence_length OF cell]] IN
                temporary_object_file;

          IF new_supplemental_debug_tables = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY24', status);
            RETURN;
          IFEND;

          new_supplemental_debug_tables^ := old_supplemental_debug_tables^;
        ELSE
          RESET temporary_object_file TO new_object_text_descriptor;
        IFEND;


      = llc$form_definition =
        osp$set_status_abnormal (oc, oce$e_form_def_found_in_module, module_name, status);
        RETURN;

      = llc$68000_absolute =
        NEXT old_m68000_absolute: [[REP old_object_text_descriptor^.number_of_68000_bytes OF cell]] IN
              module_description^.file;

        NEXT new_m68000_absolute: [[REP new_object_text_descriptor^.number_of_68000_bytes OF cell]] IN
              temporary_object_file;
        IF new_m68000_absolute = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY25', status);
          RETURN;
        IFEND;

        new_m68000_absolute^ := old_m68000_absolute^;



      = llc$transfer_symbol =
        NEXT old_transfer_symbol IN module_description^.file;
        NEXT new_transfer_symbol IN temporary_object_file;

        IF new_transfer_symbol = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY26', status);
          RETURN;
        IFEND;

        IF entry_points_have_been_changed THEN
          new_transfer_symbol^.name := new_starting_procedure;
        ELSE
          new_transfer_symbol^ := old_transfer_symbol^;
        IFEND;

      CASEND;
    UNTIL new_object_text_descriptor^.kind = llc$transfer_symbol;

  PROCEND copy_cpu_object_module;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_PPU_OBJECT_MODULE' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_ppu_object_module
    (    module_description: ^oct$module_description;
         changed_info: ^oct$changed_info;
     VAR object_text_descriptor: ^llt$object_text_descriptor;
     VAR temporary_object_file: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      old_object_text_descriptor: ^llt$object_text_descriptor,
      old_identification: ^llt$identification,
      old_ppu_absolute: ^llt$ppu_absolute;

    VAR
      new_object_text_descriptor: ^llt$object_text_descriptor,
      new_identification: ^llt$identification,
      new_ppu_absolute: ^llt$ppu_absolute;


    RESET module_description^.file TO module_description^.ppu_object_module_header;


    NEXT object_text_descriptor IN temporary_object_file;

    IF object_text_descriptor = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY27', status);
      RETURN;
    IFEND;

    object_text_descriptor^.kind := llc$identification;


    NEXT old_identification IN module_description^.file;
    NEXT new_identification IN temporary_object_file;

    IF new_identification = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY28', status);
      RETURN;
    IFEND;

    new_identification^ := old_identification^;


    IF changed_info <> NIL THEN
      IF changed_info^.name <> NIL THEN
        new_identification^.name := changed_info^.name^;
      IFEND;

      IF changed_info^.commentary <> NIL THEN
        new_identification^.commentary := changed_info^.commentary^;
      IFEND;
    IFEND;

    NEXT old_object_text_descriptor IN module_description^.file;
    IF old_object_text_descriptor = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_object_text_descriptor IN temporary_object_file;

    IF new_object_text_descriptor = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY29', status);
      RETURN;
    IFEND;

    new_object_text_descriptor^ := old_object_text_descriptor^;


    NEXT old_ppu_absolute: [0 .. old_object_text_descriptor^.number_of_words - 1] IN module_description^.file;
    IF old_ppu_absolute = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_ppu_absolute: [0 .. new_object_text_descriptor^.number_of_words - 1] IN temporary_object_file;

    IF new_ppu_absolute = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY30', status);
      RETURN;
    IFEND;

    new_ppu_absolute^ := old_ppu_absolute^;


  PROCEND copy_ppu_object_module;
?? OLDTITLE ??
?? NEWTITLE := '  WRITE_NEW_SECTION' ??
?? EJECT ??

  PROCEDURE write_new_section
    (    old_section: ^llt$code_element;
         section_definition: ^llt$section_definition;
         length: ost$segment_length;
     VAR new_section: ^cell;
     VAR allotted_section: ost$relative_pointer);



    VAR
      temp_address: ^cell,
      section_base: ost$segment_offset;



    section_base := #OFFSET (new_section);

    WHILE section_definition^.allocation_offset <> (section_base MOD section_definition^.allocation_alignment)
          DO
      section_base := section_base + 1;
    WHILEND;

    temp_address := new_section;
    new_section := #ADDRESS (#RING (temp_address), #SEGMENT (temp_address), section_base);

    i#move (#LOC (old_section^), new_section, length);

    allotted_section := section_base;

    new_section := #ADDRESS (#RING (temp_address), #SEGMENT (temp_address), section_base + length);


  PROCEND write_new_section;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_LOAD_MODULE' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_load_module
    (    module_index: llt$module_index;
         module_description: ^oct$module_description;
         changed_info: ^oct$changed_info;
     VAR new_load_module_header: ^llt$load_module_header;
     VAR new_code_section: ^cell;
     VAR new_read_section: ^cell;
     VAR temporary_library: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      application_identifier_changed: boolean,
      debug_tables_to_omit: oct$debug_tables,
      deferred_index: 1 .. llc$max_deferred_entry_points,
      entry_points_have_been_changed: boolean,
      length: ost$segment_length,
      library_list: ^oct$name_list,
      library_number: integer,
      libraries_have_been_changed: boolean,
      module_name: pmt$program_name,
      new_actual_parameters: ^llt$actual_parameters,
      new_address_formulation: ^llt$address_formulation,
      new_application_identifier: ^llt$application_identifier,
      new_bit_string_insertion: ^llt$bit_string_insertion,
      new_debug_table_fragment: ^llt$debug_table_fragment,
      new_deferred_common_blocks: ^llt$deferred_common_blocks,
      new_deferred_entry_points: ^llt$deferred_entry_points,
      new_entry_definition: ^llt$entry_definition,
      new_entry_point: ^oct$external_declaration_list,
      new_external_linkage: ^llt$external_linkage,
      new_formal_parameters: ^llt$formal_parameters,
      new_identification: ^llt$identification,
      new_libraries: ^llt$libraries,
      new_line_address_table: ^llt$line_address_table,
      new_m68000_absolute: ^llt$68000_absolute,
      new_object_text_descriptor: ^llt$object_text_descriptor,
      new_obsolete_line_address_table: ^llt$obsolete_line_address_table,
      new_obsolete_segment_def: ^llt$obsolete_segment_definition,
      new_replication: ^llt$replication,
      new_section_definition: ^llt$section_definition,
      new_segment_definition: ^llt$segment_definition,
      new_starting_procedure: pmt$program_name,
      new_supplemental_debug_tables: ^llt$supplemental_debug_tables,
      new_symbol_table: ^llt$symbol_table,
      new_text: ^llt$text,
      new_transfer_symbol: ^llt$transfer_symbol,
      number_of_libraries: integer,
      old_actual_parameters: ^llt$actual_parameters,
      old_address_formulation: ^llt$address_formulation,
      old_application_identifier: ^llt$application_identifier,
      old_bit_string_insertion: ^llt$bit_string_insertion,
      old_debug_table_fragment: ^llt$debug_table_fragment,
      old_deferred_common_blocks: ^llt$deferred_common_blocks,
      old_deferred_entry_points: ^llt$deferred_entry_points,
      old_entry_definition: ^llt$entry_definition,
      old_external_linkage: ^llt$external_linkage,
      old_formal_parameters: ^llt$formal_parameters,
      old_identification: ^llt$identification,
      old_libraries: ^llt$libraries,
      old_line_address_table: ^llt$line_address_table,
      old_load_module_header: ^llt$load_module_header,
      old_m68000_absolute: ^llt$68000_absolute,
      old_object_text_descriptor: ^llt$object_text_descriptor,
      old_obsolete_formal_parameters: ^llt$obsolete_formal_parameters,
      old_obsolete_line_address_table: ^llt$obsolete_line_address_table,
      old_obsolete_segment_def: ^llt$obsolete_segment_definition,
      old_replication: ^llt$replication,
      old_section: ^llt$code_element,
      old_section_definition: ^llt$section_definition,
      old_segment_definition: ^llt$segment_definition,
      old_supplemental_debug_tables: ^llt$supplemental_debug_tables,
      old_symbol_table: ^llt$symbol_table,
      old_text: ^llt$text,
      old_transfer_symbol: ^llt$transfer_symbol,
      record_number: integer,
      relative_pointer: ost$relative_pointer,
      reset_value: ^SEQ ( * ),
      sec_or_seg_def_encountered: boolean,
      valid_position: boolean;


    NEXT new_load_module_header IN temporary_library;
    IF new_load_module_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY31', status);
      RETURN;
    IFEND;

    new_load_module_header^.module_index := module_index;
    new_load_module_header^.interpretive_header.elements_defined := $llt$interpretive_elements [];
    new_load_module_header^.elements_defined := $llt$load_module_elements [llc$interpretive_element];

    old_object_text_descriptor := #PTR (module_description^.load_module_header^.interpretive_element,
          module_description^.file^);
    IF old_object_text_descriptor = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    RESET module_description^.file TO old_object_text_descriptor;
    NEXT old_object_text_descriptor IN module_description^.file;

    record_number := 1;

    NEXT new_object_text_descriptor IN temporary_library;
    IF new_object_text_descriptor = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY32', status);
      RETURN;
    IFEND;

    new_object_text_descriptor^ := old_object_text_descriptor^;

    new_load_module_header^.interpretive_element := #REL (new_object_text_descriptor, temporary_library^);

    NEXT old_identification IN module_description^.file;
    IF old_identification = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_identification IN temporary_library;
    IF new_identification = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY33', status);
      RETURN;
    IFEND;

    new_identification^ := old_identification^;

    module_description^.segment_relocation_info := NIL;

    entry_points_have_been_changed := FALSE;
    application_identifier_changed := FALSE;

    IF changed_info <> NIL THEN
      IF changed_info^.name <> NIL THEN
        new_identification^.name := changed_info^.name^;
      IFEND;

      IF changed_info^.commentary <> NIL THEN
        new_identification^.commentary := changed_info^.commentary^;
      IFEND;

      IF changed_info^.entry_points <> NIL THEN
        entry_points_have_been_changed := TRUE;
        new_entry_point := changed_info^.entry_points;
        new_starting_procedure := changed_info^.starting_procedure;
      IFEND;

      IF changed_info^.application_identifier <> NIL THEN
        application_identifier_changed := TRUE;
      IFEND;

      IF changed_info^.cybil_parameter_checking = object_type_checking THEN
        new_identification^.attributes := new_identification^.attributes +
              $llt$module_attributes [llc$object_cybil_checking];
      ELSE
        new_identification^.attributes := new_identification^.attributes -
              $llt$module_attributes [llc$object_cybil_checking];
      IFEND;

      libraries_have_been_changed := changed_info^.new_libraries;
      debug_tables_to_omit := changed_info^.debug_tables_to_omit;
    ELSE
      libraries_have_been_changed := FALSE;
      debug_tables_to_omit := $oct$debug_tables [];
    IFEND;

    NEXT old_object_text_descriptor IN module_description^.file;
    IF old_object_text_descriptor = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    record_number := record_number + 1;

    NEXT new_object_text_descriptor IN temporary_library;
    IF new_object_text_descriptor = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY34', status);
      RETURN;
    IFEND;

    new_object_text_descriptor^ := old_object_text_descriptor^;

    IF NOT application_identifier_changed THEN
      IF old_object_text_descriptor^.kind = llc$application_identifier THEN

        NEXT old_application_identifier IN module_description^.file;
        IF old_application_identifier = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_application_identifier IN temporary_library;
        IF new_application_identifier = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY34.2', status);
          RETURN;
        IFEND;

        new_application_identifier^ := old_application_identifier^;

        NEXT old_object_text_descriptor IN module_description^.file;
        IF old_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        record_number := record_number + 1;

        NEXT new_object_text_descriptor IN temporary_library;
        IF new_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY34.4', status);
          RETURN;
        IFEND;

        new_object_text_descriptor^ := old_object_text_descriptor^;
      IFEND;

    ELSE
      IF changed_info^.application_identifier^.name <> osc$null_name THEN
        new_object_text_descriptor^.kind := llc$application_identifier;

        NEXT new_application_identifier IN temporary_library;
        IF new_application_identifier = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY34.6', status);
          RETURN;
        IFEND;

        new_application_identifier^.name := changed_info^.application_identifier^.name;

        NEXT new_object_text_descriptor IN temporary_library;
        IF new_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY34.8', status);
          RETURN;
        IFEND;
      IFEND;

      IF old_object_text_descriptor^.kind = llc$application_identifier THEN
        NEXT old_application_identifier IN module_description^.file;
        IF old_application_identifier = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT old_object_text_descriptor IN module_description^.file;
        IF old_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        record_number := record_number + 1;
      IFEND;
      new_object_text_descriptor^ := old_object_text_descriptor^;
    IFEND;

    IF NOT libraries_have_been_changed THEN
      IF old_object_text_descriptor^.kind = llc$libraries THEN
        new_load_module_header^.interpretive_header.library_list :=
              #REL (new_object_text_descriptor, temporary_library^);
        new_load_module_header^.interpretive_header.elements_defined :=
              new_load_module_header^.interpretive_header.elements_defined +
              $llt$interpretive_elements [llc$library_element];

        NEXT old_libraries: [1 .. old_object_text_descriptor^.number_of_libraries] IN
              module_description^.file;
        IF old_libraries = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_libraries: [1 .. new_object_text_descriptor^.number_of_libraries] IN temporary_library;
        IF new_libraries = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY35', status);
          RETURN;
        IFEND;

        new_libraries^ := old_libraries^;

        NEXT old_object_text_descriptor IN module_description^.file;
        IF old_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        record_number := record_number + 1;

        NEXT new_object_text_descriptor IN temporary_library;
        IF new_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY36', status);
          RETURN;
        IFEND;

        new_object_text_descriptor^ := old_object_text_descriptor^;
      IFEND;

    ELSE
      IF changed_info^.library_list <> NIL THEN
        new_load_module_header^.interpretive_header.library_list :=
              #REL (new_object_text_descriptor, temporary_library^);
        new_load_module_header^.interpretive_header.elements_defined :=
              new_load_module_header^.interpretive_header.elements_defined +
              $llt$interpretive_elements [llc$library_element];
        library_list := changed_info^.library_list;
        number_of_libraries := 0;
        WHILE library_list <> NIL DO
          number_of_libraries := number_of_libraries + 1;
          library_list := library_list^.link;
        WHILEND;

        IF number_of_libraries > llc$max_libraries THEN
          osp$set_status_abnormal (oc, oce$e_too_many_libraries, '', status);
          RETURN;
        IFEND;

        new_object_text_descriptor^.kind := llc$libraries;
        new_object_text_descriptor^.number_of_libraries := number_of_libraries;

        NEXT new_libraries: [1 .. new_object_text_descriptor^.number_of_libraries] IN temporary_library;
        IF new_libraries = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY37', status);
          RETURN;
        IFEND;

        library_list := changed_info^.library_list;

        FOR library_number := 1 TO number_of_libraries DO
          new_libraries^ [library_number] := library_list^.name;
          library_list := library_list^.link;
        FOREND;

        NEXT new_object_text_descriptor IN temporary_library;
        IF new_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY38', status);
          RETURN;
        IFEND;
      IFEND;

      IF old_object_text_descriptor^.kind = llc$libraries THEN
        NEXT old_libraries: [1 .. old_object_text_descriptor^.number_of_libraries] IN
              module_description^.file;
        IF old_libraries = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT old_object_text_descriptor IN module_description^.file;
        IF old_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        record_number := record_number + 1;
      IFEND;
      new_object_text_descriptor^ := old_object_text_descriptor^;
    IFEND;

    sec_or_seg_def_encountered := FALSE;

    IF (old_object_text_descriptor^.kind = llc$segment_definition) OR
          (old_object_text_descriptor^.kind = llc$allotted_segment_definition) THEN

      old_obsolete_segment_def := NIL; { Make sure these aren't used }
      new_obsolete_segment_def := NIL;

      IF NOT sec_or_seg_def_encountered THEN
        new_load_module_header^.interpretive_header.section_definitions :=
              #REL (new_object_text_descriptor, temporary_library^);
        new_load_module_header^.interpretive_header.elements_defined :=
              new_load_module_header^.interpretive_header.elements_defined +
              $llt$interpretive_elements [llc$section_element];
        sec_or_seg_def_encountered := TRUE;
      IFEND;

      NEXT module_description^.segment_relocation_info: [0 .. new_identification^.greatest_section_ordinal] IN
            ocv$olg_scratch_seq;
      IF module_description^.segment_relocation_info = NIL THEN
        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
        RETURN;
      IFEND;

      REPEAT
        NEXT old_segment_definition IN module_description^.file;
        IF old_segment_definition = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_segment_definition IN temporary_library;
        IF new_segment_definition = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY39', status);
          RETURN;
        IFEND;

        new_segment_definition^ := old_segment_definition^;

        IF new_object_text_descriptor^.kind <> llc$allotted_segment_definition THEN
          module_description^.segment_relocation_info^ [new_segment_definition^.section_definition.
                section_ordinal].old_offset := 0;
          module_description^.segment_relocation_info^ [new_segment_definition^.section_definition.
                section_ordinal].new_offset := 0;
        ELSE
          IF (old_object_text_descriptor^.allotted_segment_length <> 0) THEN
            length := old_object_text_descriptor^.allotted_segment_length;
          ELSE
            length := new_segment_definition^.section_definition.length;
          IFEND;

          reset_value := module_description^.file;
          pmp$position_object_library (module_description^.file, old_object_text_descriptor^.allotted_segment,
                valid_position);
          IF NOT valid_position THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
            RETURN;
          IFEND;

          NEXT old_section: [1 .. length] IN module_description^.file;
          IF old_section = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
            RETURN;
          IFEND;

          module_description^.file := reset_value;

          IF old_segment_definition^.section_definition.kind = llc$code_section THEN
            write_new_section (old_section, ^new_segment_definition^.section_definition, length,
                  new_code_section, relative_pointer);
          ELSE
            write_new_section (old_section, ^new_segment_definition^.section_definition, length,
                  new_read_section, relative_pointer);
          IFEND;
          new_object_text_descriptor^.allotted_segment := relative_pointer;

          reset_value := temporary_library;
          pmp$position_object_library (temporary_library, new_object_text_descriptor^.allotted_segment,
                valid_position);
          IF NOT valid_position THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY40', status);
            RETURN;
          IFEND;

          IF (old_object_text_descriptor^.allotted_segment_length <> 0) THEN
            NEXT module_description^.segment_relocation_info^
                  [new_segment_definition^.section_definition.section_ordinal].text: [1 .. length] IN
                  temporary_library;
            module_description^.segment_relocation_info^ [new_segment_definition^.section_definition.
                  section_ordinal].old_offset := 0;
            module_description^.segment_relocation_info^ [new_segment_definition^.section_definition.
                  section_ordinal].new_offset := 0;
          ELSE
            NEXT module_description^.segment_relocation_info^
                  [new_segment_definition^.section_definition.section_ordinal].text: [1 .. length] IN
                  temporary_library;
            module_description^.segment_relocation_info^ [new_segment_definition^.section_definition.
                  section_ordinal].old_offset := old_object_text_descriptor^.allotted_segment;
            module_description^.segment_relocation_info^ [new_segment_definition^.section_definition.
                  section_ordinal].new_offset := new_object_text_descriptor^.allotted_segment;
          IFEND;
          temporary_library := reset_value;
        IFEND;

        NEXT old_object_text_descriptor IN module_description^.file;
        IF old_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        record_number := record_number + 1;

        NEXT new_object_text_descriptor IN temporary_library;
        IF new_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY41', status);
          RETURN;
        IFEND;

        new_object_text_descriptor^ := old_object_text_descriptor^;

      UNTIL (old_object_text_descriptor^.kind <> llc$segment_definition) AND
            (old_object_text_descriptor^.kind <> llc$allotted_segment_definition);
    IFEND;

    IF (old_object_text_descriptor^.kind = llc$obsolete_segment_definition) OR
          (old_object_text_descriptor^.kind = llc$obsolete_allotted_seg_def) THEN

      old_segment_definition := NIL; { Make sure these aren't used }
      new_segment_definition := NIL;

      IF NOT sec_or_seg_def_encountered THEN
        new_load_module_header^.interpretive_header.section_definitions :=
              #REL (new_object_text_descriptor, temporary_library^);
        new_load_module_header^.interpretive_header.elements_defined :=
              new_load_module_header^.interpretive_header.elements_defined +
              $llt$interpretive_elements [llc$section_element];
        sec_or_seg_def_encountered := TRUE;
      IFEND;

      NEXT module_description^.segment_relocation_info: [0 .. new_identification^.greatest_section_ordinal] IN
            ocv$olg_scratch_seq;
      IF module_description^.segment_relocation_info = NIL THEN
        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
        RETURN;
      IFEND;

      REPEAT
        NEXT old_obsolete_segment_def IN module_description^.file;
        IF old_obsolete_segment_def = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_obsolete_segment_def IN temporary_library;
        IF new_obsolete_segment_def = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY42', status);
          RETURN;
        IFEND;

        new_obsolete_segment_def^ := old_obsolete_segment_def^;

        IF new_object_text_descriptor^.kind <> llc$obsolete_allotted_seg_def THEN
          module_description^.segment_relocation_info^ [new_obsolete_segment_def^.section_definition.
                section_ordinal].old_offset := 0;
          module_description^.segment_relocation_info^ [new_obsolete_segment_def^.section_definition.
                section_ordinal].new_offset := 0;
        ELSE
          IF (old_object_text_descriptor^.allotted_segment_length <> 0) THEN
            length := old_object_text_descriptor^.allotted_segment_length;
          ELSE
            length := new_obsolete_segment_def^.section_definition.length;
          IFEND;

          reset_value := module_description^.file;
          pmp$position_object_library (module_description^.file, old_object_text_descriptor^.allotted_segment,
                valid_position);
          IF NOT valid_position THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
            RETURN;
          IFEND;

          NEXT old_section: [1 .. length] IN module_description^.file;
          IF old_section = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
            RETURN;
          IFEND;

          module_description^.file := reset_value;

          IF old_obsolete_segment_def^.section_definition.kind = llc$code_section THEN
            write_new_section (old_section, ^new_obsolete_segment_def^.section_definition, length,
                  new_code_section, relative_pointer);
          ELSE
            write_new_section (old_section, ^new_obsolete_segment_def^.section_definition, length,
                  new_read_section, relative_pointer);
          IFEND;
          new_object_text_descriptor^.allotted_segment := relative_pointer;

          reset_value := temporary_library;
          pmp$position_object_library (temporary_library, new_object_text_descriptor^.allotted_segment,
                valid_position);
          IF NOT valid_position THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY43', status);
            RETURN;
          IFEND;

          IF (old_object_text_descriptor^.allotted_segment_length <> 0) THEN
            NEXT module_description^.segment_relocation_info^
                  [new_obsolete_segment_def^.section_definition.section_ordinal].text: [1 .. length] IN
                  temporary_library;
            module_description^.segment_relocation_info^ [new_obsolete_segment_def^.section_definition.
                  section_ordinal].old_offset := 0;
            module_description^.segment_relocation_info^ [new_obsolete_segment_def^.section_definition.
                  section_ordinal].new_offset := 0;
          ELSE
            NEXT module_description^.segment_relocation_info^
                  [new_obsolete_segment_def^.section_definition.section_ordinal].text: [1 .. length] IN
                  temporary_library;
            module_description^.segment_relocation_info^ [new_obsolete_segment_def^.section_definition.
                  section_ordinal].old_offset := old_object_text_descriptor^.allotted_segment;
            module_description^.segment_relocation_info^ [new_obsolete_segment_def^.section_definition.
                  section_ordinal].new_offset := new_object_text_descriptor^.allotted_segment;
          IFEND;
          temporary_library := reset_value;
        IFEND;

        NEXT old_object_text_descriptor IN module_description^.file;
        IF old_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        record_number := record_number + 1;

        NEXT new_object_text_descriptor IN temporary_library;
        IF new_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY44', status);
          RETURN;
        IFEND;

        new_object_text_descriptor^ := old_object_text_descriptor^;

      UNTIL (old_object_text_descriptor^.kind <> llc$obsolete_segment_definition) AND
            (old_object_text_descriptor^.kind <> llc$obsolete_allotted_seg_def);
    IFEND;

    IF (old_object_text_descriptor^.kind = llc$section_definition) OR
          (old_object_text_descriptor^.kind = llc$allotted_section_definition) OR
          (old_object_text_descriptor^.kind = llc$unallocated_common_block) THEN

      IF NOT sec_or_seg_def_encountered THEN
        new_load_module_header^.interpretive_header.section_definitions :=
              #REL (new_object_text_descriptor, temporary_library^);
        new_load_module_header^.interpretive_header.elements_defined :=
              new_load_module_header^.interpretive_header.elements_defined +
              $llt$interpretive_elements [llc$section_element];
        sec_or_seg_def_encountered := TRUE;
      IFEND;

      REPEAT
        NEXT old_section_definition IN module_description^.file;
        IF old_section_definition = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_section_definition IN temporary_library;
        IF new_section_definition = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY45', status);
          RETURN;
        IFEND;

        new_section_definition^ := old_section_definition^;
        IF (module_description^.segment_relocation_info <> NIL) THEN
          module_description^.segment_relocation_info^ [new_section_definition^.section_ordinal].old_offset :=
                0;
          module_description^.segment_relocation_info^ [new_section_definition^.section_ordinal].new_offset :=
                0;
        IFEND;

        IF old_object_text_descriptor^.kind = llc$allotted_section_definition THEN
          reset_value := module_description^.file;
          pmp$position_object_library (module_description^.file, old_object_text_descriptor^.allotted_section,
                valid_position);
          IF NOT valid_position THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
            RETURN;
          IFEND;

          NEXT old_section: [1 .. old_section_definition^.length] IN module_description^.file;
          IF old_section = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
            RETURN;
          IFEND;

          module_description^.file := reset_value;

          IF old_section_definition^.kind = llc$code_section THEN
            write_new_section (old_section, new_section_definition, new_section_definition^.length,
                  new_code_section, new_object_text_descriptor^.allotted_section);
          ELSE
            write_new_section (old_section, new_section_definition, new_section_definition^.length,
                  new_read_section, new_object_text_descriptor^.allotted_section);
          IFEND;
        IFEND;

        NEXT old_object_text_descriptor IN module_description^.file;
        IF old_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        record_number := record_number + 1;

        NEXT new_object_text_descriptor IN temporary_library;
        IF new_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY46', status);
          RETURN;
        IFEND;

        new_object_text_descriptor^ := old_object_text_descriptor^;

      UNTIL (old_object_text_descriptor^.kind <> llc$section_definition) AND
            (old_object_text_descriptor^.kind <> llc$allotted_section_definition) AND
            (old_object_text_descriptor^.kind <> llc$unallocated_common_block);
    IFEND;

    new_load_module_header^.interpretive_header.elements_defined :=
          new_load_module_header^.interpretive_header.elements_defined -
          $llt$interpretive_elements [llc$entry_point_element, llc$external_element];

    REPEAT

      CASE old_object_text_descriptor^.kind OF

      = llc$text =
        NEXT old_text: [1 .. old_object_text_descriptor^.number_of_bytes] IN module_description^.file;
        IF old_text = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_text: [1 .. new_object_text_descriptor^.number_of_bytes] IN temporary_library;
        IF new_text = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY47', status);
          RETURN;
        IFEND;

        new_text^ := old_text^;

        IF module_description^.segment_relocation_info <> NIL THEN
          module_description^.segment_relocation_info^ [new_text^.section_ordinal].text := ^new_text^.byte;
        IFEND;

      = llc$replication =
        NEXT old_replication: [1 .. old_object_text_descriptor^.number_of_bytes] IN module_description^.file;
        IF old_replication = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_replication: [1 .. new_object_text_descriptor^.number_of_bytes] IN temporary_library;
        IF new_replication = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY48', status);
          RETURN;
        IFEND;

        new_replication^ := old_replication^;

      = llc$bit_string_insertion =
        NEXT old_bit_string_insertion IN module_description^.file;
        IF old_bit_string_insertion = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_bit_string_insertion IN temporary_library;
        IF new_bit_string_insertion = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY49', status);
          RETURN;
        IFEND;

        new_bit_string_insertion^ := old_bit_string_insertion^;

      = llc$address_formulation =
        NEXT old_address_formulation: [1 .. old_object_text_descriptor^.number_of_adr_items] IN
              module_description^.file;
        IF old_address_formulation = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_address_formulation: [1 .. new_object_text_descriptor^.number_of_adr_items] IN
              temporary_library;
        IF new_address_formulation = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY50', status);
          RETURN;
        IFEND;

        new_address_formulation^ := old_address_formulation^;

      = llc$obsolete_formal_parameters =
        NEXT old_obsolete_formal_parameters: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;
        IF old_obsolete_formal_parameters = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;
        RESET temporary_library TO new_object_text_descriptor;

      = llc$formal_parameters =
        NEXT old_formal_parameters: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;
        IF old_formal_parameters = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        IF NOT (occ$parameter_checking IN debug_tables_to_omit) THEN
          NEXT new_formal_parameters: [[REP new_object_text_descriptor^.sequence_length OF cell]] IN
                temporary_library;
          IF new_formal_parameters = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY51', status);
            RETURN;
          IFEND;

          new_formal_parameters^ := old_formal_parameters^;

          IF entry_points_have_been_changed THEN
            find_old_entry_point_name (module_description^.name, changed_info^.entry_points,
                  old_formal_parameters^.procedure_name, new_formal_parameters^.procedure_name, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF (new_formal_parameters^.procedure_name = osc$null_name) THEN
              RESET temporary_library TO new_object_text_descriptor;
              RETURN;
            IFEND;
          IFEND;
        ELSE
          RESET temporary_library TO new_object_text_descriptor;
        IFEND;

      = llc$actual_parameters =
        NEXT old_actual_parameters: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;
        IF old_actual_parameters = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        IF NOT (occ$parameter_checking IN debug_tables_to_omit) THEN
          NEXT new_actual_parameters: [[REP new_object_text_descriptor^.sequence_length OF cell]] IN
                temporary_library;
          IF new_actual_parameters = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY52', status);
            RETURN;
          IFEND;

          new_actual_parameters^ := old_actual_parameters^;
        ELSE
          RESET temporary_library TO new_object_text_descriptor;
        IFEND;

      = llc$cybil_symbol_table_fragment =
        NEXT old_debug_table_fragment: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;
        IF old_debug_table_fragment = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        IF NOT (occ$symbol_table IN debug_tables_to_omit) THEN
          NEXT new_debug_table_fragment: [[REP new_object_text_descriptor^.sequence_length OF cell]] IN
                temporary_library;
          IF new_debug_table_fragment = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY53', status);
            RETURN;
          IFEND;

          new_debug_table_fragment^ := old_debug_table_fragment^;
        ELSE
          RESET temporary_library TO new_object_text_descriptor;
        IFEND;

      = llc$obsolete_line_table =
        NEXT old_obsolete_line_address_table: [1 .. old_object_text_descriptor^.number_of_line_items] IN
              module_description^.file;
        IF old_obsolete_line_address_table = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        IF NOT (occ$line_table IN debug_tables_to_omit) THEN
          NEXT new_obsolete_line_address_table: [1 .. new_object_text_descriptor^.number_of_line_items] IN
                temporary_library;
          IF new_obsolete_line_address_table = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY54', status);
            RETURN;
          IFEND;

          new_obsolete_line_address_table^ := old_obsolete_line_address_table^;
        ELSE
          RESET temporary_library TO new_object_text_descriptor;
        IFEND;

      = llc$symbol_table =
        NEXT old_symbol_table: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;
        IF old_symbol_table = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        IF NOT (occ$symbol_table IN debug_tables_to_omit) THEN
          NEXT new_symbol_table: [[REP new_object_text_descriptor^.sequence_length OF cell]] IN
                temporary_library;
          IF new_symbol_table = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY55', status);
            RETURN;
          IFEND;

          new_symbol_table^ := old_symbol_table^;
        ELSE
          RESET temporary_library TO new_object_text_descriptor;
        IFEND;

      = llc$line_table =
        NEXT old_line_address_table: [1 .. old_object_text_descriptor^.number_of_line_items] IN
              module_description^.file;
        IF old_line_address_table = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        IF NOT (occ$line_table IN debug_tables_to_omit) THEN
          NEXT new_line_address_table: [1 .. new_object_text_descriptor^.number_of_line_items] IN
                temporary_library;
          IF new_line_address_table = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY56', status);
            RETURN;
          IFEND;

          new_line_address_table^ := old_line_address_table^;
        ELSE
          RESET temporary_library TO new_object_text_descriptor;
        IFEND;

      = llc$supplemental_debug_tables =
        NEXT old_supplemental_debug_tables: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;
        IF old_supplemental_debug_tables = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        IF NOT (occ$supplemental_debug_table IN debug_tables_to_omit) THEN
          NEXT new_supplemental_debug_tables: [[REP new_object_text_descriptor^.sequence_length OF cell]] IN
                temporary_library;
          IF new_supplemental_debug_tables = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY57', status);
            RETURN;
          IFEND;

          new_supplemental_debug_tables^ := old_supplemental_debug_tables^;
        ELSE
          RESET temporary_library TO new_object_text_descriptor;
        IFEND;

      = llc$form_definition =
        osp$set_status_abnormal (oc, oce$e_form_def_found_in_module, module_name, status);
        RETURN;

      = llc$68000_absolute =
        NEXT old_m68000_absolute: [[REP old_object_text_descriptor^.number_of_68000_bytes OF cell]] IN
              module_description^.file;
        IF old_m68000_absolute = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_m68000_absolute: [[REP new_object_text_descriptor^.number_of_68000_bytes OF cell]] IN
              temporary_library;
        IF new_m68000_absolute = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY58', status);
          RETURN;
        IFEND;

        new_m68000_absolute^ := old_m68000_absolute^;

      = llc$entry_definition =
        NEXT old_entry_definition IN module_description^.file;
        IF old_entry_definition = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        IF (entry_points_have_been_changed) AND (new_entry_point^.name = osc$null_name) THEN
          new_entry_point := new_entry_point^.link;
          RESET temporary_library TO new_object_text_descriptor;
        ELSE
          NEXT new_entry_definition IN temporary_library;
          IF new_entry_definition = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY59', status);
            RETURN;
          IFEND;

          new_entry_definition^ := old_entry_definition^;

          IF NOT (llc$entry_point_element IN new_load_module_header^.interpretive_header.elements_defined)
                THEN
            new_load_module_header^.interpretive_header.elements_defined :=
                  new_load_module_header^.interpretive_header.elements_defined +
                  $llt$interpretive_elements [llc$entry_point_element];
            new_load_module_header^.interpretive_header.entry_points :=
                  #REL (new_object_text_descriptor, temporary_library^);
          IFEND;

          IF entry_points_have_been_changed THEN
            new_entry_definition^.name := new_entry_point^.name;
            new_entry_definition^.attributes := new_entry_point^.attributes;
            new_entry_point := new_entry_point^.link;
          IFEND;
        IFEND;

      = llc$deferred_entry_points =
        NEXT old_deferred_entry_points: [1 .. old_object_text_descriptor^.number_of_entry_points] IN
              module_description^.file;
        IF old_deferred_entry_points = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_deferred_entry_points: [1 .. new_object_text_descriptor^.number_of_entry_points] IN
              temporary_library;
        IF new_deferred_entry_points = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY59.3', status);
          RETURN;
        IFEND;

        new_deferred_entry_points^ := old_deferred_entry_points^;

        IF NOT (llc$entry_point_element IN new_load_module_header^.interpretive_header.elements_defined) THEN
          new_load_module_header^.interpretive_header.elements_defined :=
                new_load_module_header^.interpretive_header.elements_defined +
                $llt$interpretive_elements [llc$entry_point_element];
          new_load_module_header^.interpretive_header.entry_points :=
                #REL (new_object_text_descriptor, temporary_library^);
        IFEND;

        IF module_description^.segment_relocation_info <> NIL THEN
          FOR deferred_index := 1 TO new_object_text_descriptor^.number_of_entry_points DO
            new_deferred_entry_points^ [deferred_index].address.offset :=
                  new_deferred_entry_points^ [deferred_index].address.offset +
                  module_description^.segment_relocation_info^ [new_deferred_entry_points^ [deferred_index].
                  section_ordinal].new_offset - module_description^.
                  segment_relocation_info^ [new_deferred_entry_points^ [deferred_index].section_ordinal].
                  old_offset;
          FOREND;
        IFEND;

      = llc$deferred_common_blocks =
        NEXT old_deferred_common_blocks: [1 .. old_object_text_descriptor^.number_of_common_blocks] IN
              module_description^.file;
        IF old_deferred_common_blocks = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_deferred_common_blocks: [1 .. new_object_text_descriptor^.number_of_common_blocks] IN
              temporary_library;
        IF new_deferred_common_blocks = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY59.6', status);
          RETURN;
        IFEND;

        new_deferred_common_blocks^ := old_deferred_common_blocks^;

      = llc$external_linkage =
        IF NOT (llc$external_element IN new_load_module_header^.interpretive_header.elements_defined) THEN
          new_load_module_header^.interpretive_header.elements_defined :=
                new_load_module_header^.interpretive_header.elements_defined +
                $llt$interpretive_elements [llc$external_element];
          new_load_module_header^.interpretive_header.external_linkages :=
                #REL (new_object_text_descriptor, temporary_library^);
        IFEND;

        NEXT old_external_linkage: [1 .. old_object_text_descriptor^.number_of_ext_items] IN
              module_description^.file;
        IF old_external_linkage = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_external_linkage: [1 .. new_object_text_descriptor^.number_of_ext_items] IN
              temporary_library;
        IF new_external_linkage = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY60', status);
          RETURN;
        IFEND;

        new_external_linkage^ := old_external_linkage^;

      = llc$transfer_symbol =
        new_load_module_header^.interpretive_header.transfer_symbol :=
              #REL (new_object_text_descriptor, temporary_library^);
        new_load_module_header^.interpretive_header.elements_defined :=
              new_load_module_header^.interpretive_header.elements_defined +
              $llt$interpretive_elements [llc$transfer_symbol_element];

        NEXT old_transfer_symbol IN module_description^.file;
        IF old_transfer_symbol = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_transfer_symbol IN temporary_library;
        IF new_transfer_symbol = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY61', status);
          RETURN;
        IFEND;

        IF entry_points_have_been_changed THEN
          new_transfer_symbol^.name := new_starting_procedure;
        ELSE
          new_transfer_symbol^.name := old_transfer_symbol^.name;
        IFEND;

        RETURN;

      ELSE

        osp$set_status_abnormal (oc, oce$e_invalid_object_rec_kind, module_description^.name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, record_number, 10, FALSE, status);
        RETURN;

      CASEND;

      NEXT old_object_text_descriptor IN module_description^.file;
      IF old_object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
        RETURN;
      IFEND;

      record_number := record_number + 1;

      NEXT new_object_text_descriptor IN temporary_library;
      IF new_object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY62', status);
        RETURN;
      IFEND;

      new_object_text_descriptor^ := old_object_text_descriptor^;

    UNTIL FALSE;


{ The normal return is through the transfer symbol.

  PROCEND copy_load_module;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_LOAD_TO_OBJECT_MODULE' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_load_to_object_module
    (    module_description: ^oct$module_description;
         changed_info: ^oct$changed_info;
     VAR temporary_library: ^SEQ ( * );
     VAR status: ost$status);




    VAR
      old_object_text_descriptor: ^llt$object_text_descriptor,
      old_load_module_header: ^llt$load_module_header,

      old_identification: ^llt$identification,
      old_application_identifier: ^llt$application_identifier,
      old_libraries: ^llt$libraries,
      old_section_definition: ^llt$section_definition,
      old_segment_definition: ^llt$segment_definition,
      old_obsolete_segment_def: ^llt$obsolete_segment_definition,
      old_text: ^llt$text,
      old_replication: ^llt$replication,
      old_bit_string_insertion: ^llt$bit_string_insertion,
      old_entry_definition: ^llt$entry_definition,
      old_deferred_entry_points: ^llt$deferred_entry_points,
      old_deferred_common_blocks: ^llt$deferred_common_blocks,
      old_external_linkage: ^llt$external_linkage,
      old_address_formulation: ^llt$address_formulation,
      old_obsolete_formal_parameters: ^llt$obsolete_formal_parameters,
      old_formal_parameters: ^llt$formal_parameters,
      old_actual_parameters: ^llt$actual_parameters,
      old_debug_table_fragment: ^llt$debug_table_fragment,
      old_obsolete_line_address_table: ^llt$obsolete_line_address_table,
      old_symbol_table: ^llt$symbol_table,
      old_line_address_table: ^llt$line_address_table,
      old_supplemental_debug_tables: ^llt$supplemental_debug_tables,
      old_m68000_absolute: ^llt$68000_absolute,
      old_relocation: ^llt$relocation,
      old_binding_template: ^llt$binding_section_template,
      old_transfer_symbol: ^llt$transfer_symbol,
      old_info_element_header: ^llt$info_element_header,
      old_header: llt$info_element_header,

      new_object_text_descriptor: ^llt$object_text_descriptor,

      new_identification: ^llt$identification,
      new_application_identifier: ^llt$application_identifier,
      new_libraries: ^llt$libraries,
      new_section_definition: ^llt$section_definition,
      new_segment_definition: ^llt$segment_definition,
      new_obsolete_segment_def: ^llt$obsolete_segment_definition,
      new_text: ^llt$text,
      new_replication: ^llt$replication,
      new_bit_string_insertion: ^llt$bit_string_insertion,
      new_entry_definition: ^llt$entry_definition,
      new_deferred_entry_points: ^llt$deferred_entry_points,
      new_deferred_common_blocks: ^llt$deferred_common_blocks,
      new_external_linkage: ^llt$external_linkage,
      new_address_formulation: ^llt$address_formulation,
      new_formal_parameters: ^llt$formal_parameters,
      new_actual_parameters: ^llt$actual_parameters,
      new_debug_table_fragment: ^llt$debug_table_fragment,
      new_obsolete_line_address_table: ^llt$obsolete_line_address_table,
      new_symbol_table: ^llt$symbol_table,
      new_line_address_table: ^llt$line_address_table,
      new_m68000_absolute: ^llt$68000_absolute,
      new_relocation: ^llt$relocation,
      new_supplemental_debug_tables: ^llt$supplemental_debug_tables,
      number_of_rel_items: integer,
      next_rel_item: integer,
      new_binding_template: ^llt$binding_template,
      new_transfer_symbol: ^llt$transfer_symbol,

      valid_position: boolean,
      length: ost$segment_length,
      old_section: ^array [1 .. * ] of 0 .. 255,
      reset_value: ^SEQ ( * ),

      application_identifier_changed: boolean,
      entry_points_have_been_changed: boolean,
      new_starting_procedure: pmt$program_name,

      deferred_index: 1 .. llc$max_deferred_entry_points,
      new_entry_point: ^oct$external_declaration_list,
      module_name: pmt$program_name,
      libraries_have_been_changed: boolean,
      library_list: ^oct$name_list,
      library_number: integer,
      number_of_libraries: integer,
      i: integer,
      debug_tables_to_omit: oct$debug_tables,
      segment_relocation_info: ^oct$segment_relocation_info,
      record_number: integer;


    segment_relocation_info := NIL;

    old_object_text_descriptor := #PTR (module_description^.load_module_header^.interpretive_element,
          module_description^.file^);
    IF old_object_text_descriptor = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    RESET module_description^.file TO old_object_text_descriptor;
    NEXT old_object_text_descriptor IN module_description^.file;

    record_number := 1;

    NEXT new_object_text_descriptor IN temporary_library;
    IF new_object_text_descriptor = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY63', status);
      RETURN;
    IFEND;

    new_object_text_descriptor^ := old_object_text_descriptor^;

    NEXT old_identification IN module_description^.file;
    IF old_identification = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_identification IN temporary_library;
    IF new_identification = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY64', status);
      RETURN;
    IFEND;

    new_identification^ := old_identification^;

    entry_points_have_been_changed := FALSE;
    application_identifier_changed := FALSE;

    IF changed_info <> NIL THEN
      IF changed_info^.name <> NIL THEN
        new_identification^.name := changed_info^.name^;
      IFEND;

      IF changed_info^.commentary <> NIL THEN
        new_identification^.commentary := changed_info^.commentary^;
      IFEND;

      IF changed_info^.entry_points <> NIL THEN
        entry_points_have_been_changed := TRUE;
        new_entry_point := changed_info^.entry_points;
        new_starting_procedure := changed_info^.starting_procedure;
      IFEND;

      IF changed_info^.application_identifier <> NIL THEN
        application_identifier_changed := TRUE;
      IFEND;

      libraries_have_been_changed := changed_info^.new_libraries;
      debug_tables_to_omit := changed_info^.debug_tables_to_omit;
    ELSE
      libraries_have_been_changed := FALSE;
      debug_tables_to_omit := $oct$debug_tables [];
    IFEND;

    NEXT old_object_text_descriptor IN module_description^.file;
    IF old_object_text_descriptor = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    record_number := record_number + 1;

    NEXT new_object_text_descriptor IN temporary_library;
    IF new_object_text_descriptor = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY65', status);
      RETURN;
    IFEND;

    new_object_text_descriptor^ := old_object_text_descriptor^;

    IF NOT application_identifier_changed THEN
      IF old_object_text_descriptor^.kind = llc$application_identifier THEN
        NEXT old_application_identifier IN module_description^.file;
        IF old_application_identifier = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_application_identifier IN temporary_library;
        IF new_application_identifier = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY65.2', status);
          RETURN;
        IFEND;

        new_application_identifier^ := old_application_identifier^;

        NEXT old_object_text_descriptor IN module_description^.file;
        IF old_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        record_number := record_number + 1;

        NEXT new_object_text_descriptor IN temporary_library;
        IF new_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY65.4', status);
          RETURN;
        IFEND;

        new_object_text_descriptor^ := old_object_text_descriptor^;
      IFEND;

    ELSE
      IF changed_info^.application_identifier^.name <> osc$null_name THEN
        new_object_text_descriptor^.kind := llc$application_identifier;

        NEXT new_application_identifier IN temporary_library;
        IF new_application_identifier = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY65.6', status);
          RETURN;
        IFEND;

        new_application_identifier^.name := changed_info^.application_identifier^.name;

        NEXT new_object_text_descriptor IN temporary_library;
        IF new_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY65.8', status);
          RETURN;
        IFEND;
      IFEND;

      IF old_object_text_descriptor^.kind = llc$application_identifier THEN
        NEXT old_application_identifier IN module_description^.file;
        IF old_application_identifier = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT old_object_text_descriptor IN module_description^.file;
        IF old_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        record_number := record_number + 1;
      IFEND;
      new_object_text_descriptor^ := old_object_text_descriptor^;
    IFEND;

    IF NOT libraries_have_been_changed THEN
      IF old_object_text_descriptor^.kind = llc$libraries THEN
        NEXT old_libraries: [1 .. old_object_text_descriptor^.number_of_libraries] IN
              module_description^.file;
        IF old_libraries = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_libraries: [1 .. new_object_text_descriptor^.number_of_libraries] IN temporary_library;
        IF new_libraries = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY66', status);
          RETURN;
        IFEND;

        new_libraries^ := old_libraries^;

        NEXT old_object_text_descriptor IN module_description^.file;
        IF old_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        record_number := record_number + 1;

        NEXT new_object_text_descriptor IN temporary_library;
        IF new_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY67', status);
          RETURN;
        IFEND;

        new_object_text_descriptor^ := old_object_text_descriptor^;
      IFEND;

    ELSE
      IF changed_info^.library_list <> NIL THEN
        library_list := changed_info^.library_list;
        number_of_libraries := 0;
        WHILE library_list <> NIL DO
          number_of_libraries := number_of_libraries + 1;
          library_list := library_list^.link;
        WHILEND;

        IF number_of_libraries > llc$max_libraries THEN
          osp$set_status_abnormal (oc, oce$e_too_many_libraries, '', status);
          RETURN;
        IFEND;

        new_object_text_descriptor^.kind := llc$libraries;
        new_object_text_descriptor^.number_of_libraries := number_of_libraries;

        NEXT new_libraries: [1 .. new_object_text_descriptor^.number_of_libraries] IN temporary_library;
        IF new_libraries = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY68', status);
          RETURN;
        IFEND;

        library_list := changed_info^.library_list;

        FOR library_number := 1 TO number_of_libraries DO
          new_libraries^ [library_number] := library_list^.name;
          library_list := library_list^.link;
        FOREND;

        NEXT new_object_text_descriptor IN temporary_library;
        IF new_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY69', status);
          RETURN;
        IFEND;
      IFEND;

      IF old_object_text_descriptor^.kind = llc$libraries THEN
        NEXT old_libraries: [1 .. old_object_text_descriptor^.number_of_libraries] IN
              module_description^.file;
        IF old_libraries = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT old_object_text_descriptor IN module_description^.file;
        IF old_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        record_number := record_number + 1;
      IFEND;
      new_object_text_descriptor^ := old_object_text_descriptor^;
    IFEND;

    IF (old_object_text_descriptor^.kind = llc$segment_definition) OR
          (old_object_text_descriptor^.kind = llc$allotted_segment_definition) THEN
      PUSH segment_relocation_info: [0 .. new_identification^.greatest_section_ordinal];

      old_obsolete_segment_def := NIL; { Make sure these aren't used }
      new_obsolete_segment_def := NIL;

      WHILE (old_object_text_descriptor^.kind = llc$segment_definition) OR
            (old_object_text_descriptor^.kind = llc$allotted_segment_definition) DO

        NEXT old_segment_definition IN module_description^.file;
        IF old_segment_definition = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_segment_definition IN temporary_library;
        IF new_segment_definition = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY70', status);
          RETURN;
        IFEND;

        new_segment_definition^ := old_segment_definition^;

        IF new_object_text_descriptor^.kind <> llc$allotted_segment_definition THEN
          segment_relocation_info^ [new_segment_definition^.section_definition.section_ordinal].old_offset :=
                0;
          segment_relocation_info^ [new_segment_definition^.section_definition.section_ordinal].new_offset :=
                0;
        ELSE
          new_object_text_descriptor^.kind := llc$segment_definition;
          new_object_text_descriptor^.unused := 0;

          reset_value := module_description^.file;
          pmp$position_object_library (module_description^.file, old_object_text_descriptor^.allotted_segment,
                valid_position);
          IF NOT valid_position THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
            RETURN;
          IFEND;

          IF (old_object_text_descriptor^.allotted_segment_length <> 0) AND
                (old_object_text_descriptor^.allotted_segment_length <=
                old_segment_definition^.section_definition.length) THEN
            length := old_object_text_descriptor^.allotted_segment_length;
          ELSE
            length := old_segment_definition^.section_definition.length;
          IFEND;

          NEXT old_section: [1 .. length] IN module_description^.file;
          IF old_section = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
            RETURN;
          IFEND;

          module_description^.file := reset_value;

          NEXT new_object_text_descriptor IN temporary_library;
          IF new_object_text_descriptor = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY71', status);
            RETURN;
          IFEND;

          new_object_text_descriptor^.kind := llc$text;
          new_object_text_descriptor^.number_of_bytes := length;

          NEXT new_text: [1 .. new_object_text_descriptor^.number_of_bytes] IN temporary_library;
          IF new_text = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY72', status);
            RETURN;
          IFEND;

          new_text^.section_ordinal := new_segment_definition^.section_definition.section_ordinal;
          new_text^.offset := 0;
          new_text^.byte := old_section^;

          IF (old_object_text_descriptor^.allotted_segment_length <> 0) THEN {allotted rw relocates to 0}
            segment_relocation_info^ [new_segment_definition^.section_definition.section_ordinal].
                  old_offset := 0;
            segment_relocation_info^ [new_segment_definition^.section_definition.section_ordinal].
                  new_offset := 0;
          ELSE
            segment_relocation_info^ [new_segment_definition^.section_definition.section_ordinal].
                  old_offset := old_object_text_descriptor^.allotted_segment;
            segment_relocation_info^ [new_segment_definition^.section_definition.section_ordinal].
                  new_offset := 0;
          IFEND;
          segment_relocation_info^ [new_segment_definition^.section_definition.section_ordinal].text :=
                ^new_text^.byte;
        IFEND;


        NEXT old_object_text_descriptor IN module_description^.file;
        IF old_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        record_number := record_number + 1;

        NEXT new_object_text_descriptor IN temporary_library;
        IF new_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY73', status);
          RETURN;
        IFEND;

        new_object_text_descriptor^ := old_object_text_descriptor^;

      WHILEND;
    IFEND;

    IF (old_object_text_descriptor^.kind = llc$obsolete_segment_definition) OR
          (old_object_text_descriptor^.kind = llc$obsolete_allotted_seg_def) THEN
      PUSH segment_relocation_info: [0 .. new_identification^.greatest_section_ordinal];

      old_segment_definition := NIL; { Make sure these aren't used }
      new_segment_definition := NIL;

      WHILE (old_object_text_descriptor^.kind = llc$obsolete_segment_definition) OR
            (old_object_text_descriptor^.kind = llc$obsolete_allotted_seg_def) DO

        NEXT old_obsolete_segment_def IN module_description^.file;
        IF old_obsolete_segment_def = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_obsolete_segment_def IN temporary_library;
        IF new_obsolete_segment_def = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY74', status);
          RETURN;
        IFEND;

        new_obsolete_segment_def^ := old_obsolete_segment_def^;

        IF new_object_text_descriptor^.kind <> llc$obsolete_allotted_seg_def THEN
          segment_relocation_info^ [new_obsolete_segment_def^.section_definition.section_ordinal].
                old_offset := 0;
          segment_relocation_info^ [new_obsolete_segment_def^.section_definition.section_ordinal].
                new_offset := 0;
        ELSE
          new_object_text_descriptor^.kind := llc$obsolete_segment_definition;
          new_object_text_descriptor^.unused := 0;

          reset_value := module_description^.file;
          pmp$position_object_library (module_description^.file, old_object_text_descriptor^.allotted_segment,
                valid_position);
          IF NOT valid_position THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
            RETURN;
          IFEND;

          IF (old_object_text_descriptor^.allotted_segment_length <> 0) AND
                (old_object_text_descriptor^.allotted_segment_length <=
                old_obsolete_segment_def^.section_definition.length) THEN
            length := old_object_text_descriptor^.allotted_segment_length;
          ELSE
            length := old_obsolete_segment_def^.section_definition.length;
          IFEND;

          NEXT old_section: [1 .. length] IN module_description^.file;
          IF old_section = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
            RETURN;
          IFEND;

          module_description^.file := reset_value;

          NEXT new_object_text_descriptor IN temporary_library;
          IF new_object_text_descriptor = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY75', status);
            RETURN;
          IFEND;

          new_object_text_descriptor^.kind := llc$text;
          new_object_text_descriptor^.number_of_bytes := length;

          NEXT new_text: [1 .. new_object_text_descriptor^.number_of_bytes] IN temporary_library;
          IF new_text = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY76', status);
            RETURN;
          IFEND;

          new_text^.section_ordinal := new_obsolete_segment_def^.section_definition.section_ordinal;
          new_text^.offset := 0;
          new_text^.byte := old_section^;

          IF (old_object_text_descriptor^.allotted_segment_length <> 0) THEN {allotted rw relocates to 0}
            segment_relocation_info^ [new_obsolete_segment_def^.section_definition.section_ordinal].
                  old_offset := 0;
            segment_relocation_info^ [new_obsolete_segment_def^.section_definition.section_ordinal].
                  new_offset := 0;
          ELSE
            segment_relocation_info^ [new_obsolete_segment_def^.section_definition.section_ordinal].
                  old_offset := old_object_text_descriptor^.allotted_segment;
            segment_relocation_info^ [new_obsolete_segment_def^.section_definition.section_ordinal].
                  new_offset := 0;
          IFEND;
          segment_relocation_info^ [new_obsolete_segment_def^.section_definition.section_ordinal].text :=
                ^new_text^.byte;
        IFEND;


        NEXT old_object_text_descriptor IN module_description^.file;
        IF old_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        record_number := record_number + 1;

        NEXT new_object_text_descriptor IN temporary_library;
        IF new_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY77', status);
          RETURN;
        IFEND;

        new_object_text_descriptor^ := old_object_text_descriptor^;

      WHILEND;
    IFEND;

    WHILE (old_object_text_descriptor^.kind = llc$section_definition) OR
          (old_object_text_descriptor^.kind = llc$allotted_section_definition) OR
          (old_object_text_descriptor^.kind = llc$unallocated_common_block) DO

      NEXT old_section_definition IN module_description^.file;
      IF old_section_definition = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
        RETURN;
      IFEND;

      NEXT new_section_definition IN temporary_library;
      IF new_section_definition = NIL THEN
        osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY78', status);
        RETURN;
      IFEND;

      new_section_definition^ := old_section_definition^;
      IF (segment_relocation_info <> NIL) THEN
        segment_relocation_info^ [new_section_definition^.section_ordinal].old_offset := 0;
        segment_relocation_info^ [new_section_definition^.section_ordinal].new_offset := 0;
      IFEND;

      IF old_object_text_descriptor^.kind = llc$allotted_section_definition THEN
        new_object_text_descriptor^.kind := llc$section_definition;
        new_object_text_descriptor^.unused := 0;

        reset_value := module_description^.file;
        pmp$position_object_library (module_description^.file, old_object_text_descriptor^.allotted_section,
              valid_position);
        IF NOT valid_position THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT old_section: [1 .. old_section_definition^.length] IN module_description^.file;
        IF old_section = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        module_description^.file := reset_value;

        NEXT new_object_text_descriptor IN temporary_library;
        IF new_object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY79', status);
          RETURN;
        IFEND;

        new_object_text_descriptor^.kind := llc$text;
        new_object_text_descriptor^.number_of_bytes := new_section_definition^.length;

        NEXT new_text: [1 .. new_object_text_descriptor^.number_of_bytes] IN temporary_library;
        IF new_text = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY80', status);
          RETURN;
        IFEND;

        new_text^.section_ordinal := new_section_definition^.section_ordinal;
        new_text^.offset := 0;
        new_text^.byte := old_section^;
      IFEND;


      NEXT old_object_text_descriptor IN module_description^.file;
      IF old_object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
        RETURN;
      IFEND;

      record_number := record_number + 1;

      NEXT new_object_text_descriptor IN temporary_library;
      IF new_object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY81', status);
        RETURN;
      IFEND;

      new_object_text_descriptor^ := old_object_text_descriptor^;

    WHILEND;

    REPEAT

      CASE old_object_text_descriptor^.kind OF

      = llc$text =
        NEXT old_text: [1 .. old_object_text_descriptor^.number_of_bytes] IN module_description^.file;
        IF old_text = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_text: [1 .. new_object_text_descriptor^.number_of_bytes] IN temporary_library;
        IF new_text = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY82', status);
          RETURN;
        IFEND;

        new_text^ := old_text^;

        IF segment_relocation_info <> NIL THEN
          segment_relocation_info^ [new_text^.section_ordinal].text := ^new_text^.byte;
        IFEND;


      = llc$replication =
        NEXT old_replication: [1 .. old_object_text_descriptor^.number_of_bytes] IN module_description^.file;
        IF old_replication = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_replication: [1 .. new_object_text_descriptor^.number_of_bytes] IN temporary_library;
        IF new_replication = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY83', status);
          RETURN;
        IFEND;

        new_replication^ := old_replication^;

      = llc$bit_string_insertion =
        NEXT old_bit_string_insertion IN module_description^.file;
        IF old_bit_string_insertion = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_bit_string_insertion IN temporary_library;
        IF new_bit_string_insertion = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY84', status);
          RETURN;
        IFEND;

        new_bit_string_insertion^ := old_bit_string_insertion^;

      = llc$address_formulation =
        NEXT old_address_formulation: [1 .. old_object_text_descriptor^.number_of_adr_items] IN
              module_description^.file;
        IF old_address_formulation = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_address_formulation: [1 .. new_object_text_descriptor^.number_of_adr_items] IN
              temporary_library;
        IF new_address_formulation = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY85', status);
          RETURN;
        IFEND;

        new_address_formulation^ := old_address_formulation^;


      = llc$obsolete_formal_parameters =
        NEXT old_obsolete_formal_parameters: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;
        IF old_obsolete_formal_parameters = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;
        RESET temporary_library TO new_object_text_descriptor;

      = llc$formal_parameters =
        NEXT old_formal_parameters: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;
        IF old_formal_parameters = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        IF NOT (occ$parameter_checking IN debug_tables_to_omit) THEN
          NEXT new_formal_parameters: [[REP new_object_text_descriptor^.sequence_length OF cell]] IN
                temporary_library;
          IF new_formal_parameters = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY86', status);
            RETURN;
          IFEND;

          new_formal_parameters^ := old_formal_parameters^;

          IF entry_points_have_been_changed THEN
            find_old_entry_point_name (module_description^.name, changed_info^.entry_points,
                  old_formal_parameters^.procedure_name, new_formal_parameters^.procedure_name, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF (new_formal_parameters^.procedure_name = osc$null_name) THEN
              RESET temporary_library TO new_object_text_descriptor;
              RETURN;
            IFEND;
          IFEND;
        ELSE
          RESET temporary_library TO new_object_text_descriptor;
        IFEND;


      = llc$actual_parameters =
        NEXT old_actual_parameters: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;
        IF old_actual_parameters = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        IF NOT (occ$parameter_checking IN debug_tables_to_omit) THEN
          NEXT new_actual_parameters: [[REP new_object_text_descriptor^.sequence_length OF cell]] IN
                temporary_library;
          IF new_actual_parameters = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY87', status);
            RETURN;
          IFEND;

          new_actual_parameters^ := old_actual_parameters^;
        ELSE
          RESET temporary_library TO new_object_text_descriptor;
        IFEND;

      = llc$cybil_symbol_table_fragment =
        NEXT old_debug_table_fragment: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;
        IF old_debug_table_fragment = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        IF NOT (occ$symbol_table IN debug_tables_to_omit) THEN
          NEXT new_debug_table_fragment: [[REP new_object_text_descriptor^.sequence_length OF cell]] IN
                temporary_library;
          IF new_debug_table_fragment = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY88', status);
            RETURN;
          IFEND;

          new_debug_table_fragment^ := old_debug_table_fragment^;
        ELSE
          RESET temporary_library TO new_object_text_descriptor;
        IFEND;

      = llc$obsolete_line_table =
        NEXT old_obsolete_line_address_table: [1 .. old_object_text_descriptor^.number_of_line_items] IN
              module_description^.file;
        IF old_obsolete_line_address_table = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        IF NOT (occ$line_table IN debug_tables_to_omit) THEN
          NEXT new_obsolete_line_address_table: [1 .. new_object_text_descriptor^.number_of_line_items] IN
                temporary_library;
          IF new_obsolete_line_address_table = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY89', status);
            RETURN;
          IFEND;

          new_obsolete_line_address_table^ := old_obsolete_line_address_table^;
        ELSE
          RESET temporary_library TO new_object_text_descriptor;
        IFEND;


      = llc$symbol_table =
        NEXT old_symbol_table: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;
        IF old_symbol_table = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        IF NOT (occ$symbol_table IN debug_tables_to_omit) THEN
          NEXT new_symbol_table: [[REP new_object_text_descriptor^.sequence_length OF cell]] IN
                temporary_library;
          IF new_symbol_table = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY90', status);
            RETURN;
          IFEND;

          new_symbol_table^ := old_symbol_table^;
        ELSE
          RESET temporary_library TO new_object_text_descriptor;
        IFEND;

      = llc$line_table =
        NEXT old_line_address_table: [1 .. old_object_text_descriptor^.number_of_line_items] IN
              module_description^.file;
        IF old_line_address_table = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        IF NOT (occ$line_table IN debug_tables_to_omit) THEN
          NEXT new_line_address_table: [1 .. new_object_text_descriptor^.number_of_line_items] IN
                temporary_library;
          IF new_line_address_table = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY91', status);
            RETURN;
          IFEND;

          new_line_address_table^ := old_line_address_table^;
        ELSE
          RESET temporary_library TO new_object_text_descriptor;
        IFEND;

      = llc$supplemental_debug_tables =
        NEXT old_supplemental_debug_tables: [[REP old_object_text_descriptor^.sequence_length OF cell]] IN
              module_description^.file;
        IF old_supplemental_debug_tables = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        IF NOT (occ$supplemental_debug_table IN debug_tables_to_omit) THEN
          NEXT new_supplemental_debug_tables: [[REP new_object_text_descriptor^.sequence_length OF cell]] IN
                temporary_library;
          IF new_supplemental_debug_tables = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY92', status);
            RETURN;
          IFEND;

          new_supplemental_debug_tables^ := old_supplemental_debug_tables^;
        ELSE
          RESET temporary_library TO new_object_text_descriptor;
        IFEND;

      = llc$form_definition =
        osp$set_status_abnormal (oc, oce$e_form_def_found_in_module, module_name, status);
        RETURN;

      = llc$68000_absolute =
        NEXT old_m68000_absolute: [[REP old_object_text_descriptor^.number_of_68000_bytes OF cell]] IN
              module_description^.file;
        IF old_m68000_absolute = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_m68000_absolute: [[REP new_object_text_descriptor^.number_of_68000_bytes OF cell]] IN
              temporary_library;
        IF new_m68000_absolute = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY93', status);
          RETURN;
        IFEND;

        new_m68000_absolute^ := old_m68000_absolute^;

      = llc$entry_definition =
        NEXT old_entry_definition IN module_description^.file;
        IF old_entry_definition = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        IF (entry_points_have_been_changed) AND (new_entry_point^.name = osc$null_name) THEN
          new_entry_point := new_entry_point^.link;
          RESET temporary_library TO new_object_text_descriptor;
        ELSE
          NEXT new_entry_definition IN temporary_library;
          IF new_entry_definition = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY94', status);
            RETURN;
          IFEND;

          new_entry_definition^ := old_entry_definition^;


          IF entry_points_have_been_changed THEN
            new_entry_definition^.name := new_entry_point^.name;
            new_entry_definition^.attributes := new_entry_point^.attributes;
            new_entry_point := new_entry_point^.link;
          IFEND;
        IFEND;

      = llc$deferred_entry_points =
        NEXT old_deferred_entry_points: [1 .. old_object_text_descriptor^.number_of_entry_points] IN
              module_description^.file;
        IF old_deferred_entry_points = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_deferred_entry_points: [1 .. new_object_text_descriptor^.number_of_entry_points] IN
              temporary_library;
        IF new_deferred_entry_points = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY94.3', status);
          RETURN;
        IFEND;

        new_deferred_entry_points^ := old_deferred_entry_points^;

        IF segment_relocation_info <> NIL THEN
          FOR deferred_index := 1 TO new_object_text_descriptor^.number_of_entry_points DO
            new_deferred_entry_points^ [deferred_index].address.offset :=
                  new_deferred_entry_points^ [deferred_index].address.offset +
                  segment_relocation_info^ [new_deferred_entry_points^ [deferred_index].section_ordinal].
                  new_offset - segment_relocation_info^ [new_deferred_entry_points^ [deferred_index].
                  section_ordinal].old_offset;
          FOREND;
        IFEND;

      = llc$deferred_common_blocks =
        NEXT old_deferred_common_blocks: [1 .. old_object_text_descriptor^.number_of_common_blocks] IN
              module_description^.file;
        IF old_deferred_common_blocks = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_deferred_common_blocks: [1 .. new_object_text_descriptor^.number_of_common_blocks] IN
              temporary_library;
        IF new_deferred_common_blocks = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY94.6', status);
          RETURN;
        IFEND;

        new_deferred_common_blocks^ := old_deferred_common_blocks^;


      = llc$external_linkage =
        NEXT old_external_linkage: [1 .. old_object_text_descriptor^.number_of_ext_items] IN
              module_description^.file;
        IF old_external_linkage = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;

        NEXT new_external_linkage: [1 .. new_object_text_descriptor^.number_of_ext_items] IN
              temporary_library;
        IF new_external_linkage = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY95', status);
          RETURN;
        IFEND;

        new_external_linkage^ := old_external_linkage^;

      = llc$transfer_symbol =
        NEXT old_transfer_symbol IN module_description^.file;
        IF old_transfer_symbol = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
          RETURN;
        IFEND;


        IF llc$information_element IN module_description^.load_module_header^.elements_defined THEN
          old_info_element_header := #PTR (module_description^.load_module_header^.information_element,
                module_description^.file^);
          IF old_info_element_header = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
            RETURN;
          IFEND;


          IF (old_info_element_header^.version <> llc$info_element_version) THEN
            ocp$convert_information_element (old_info_element_header, old_header);
            old_info_element_header := ^old_header;
          IFEND;

          IF old_info_element_header^.number_of_rel_items <> 0 THEN
            old_relocation := #PTR (old_info_element_header^.relocation_ptr, module_description^.file^);
            IF old_relocation = NIL THEN
              osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
              RETURN;
            IFEND;

            number_of_rel_items := old_info_element_header^.number_of_rel_items;
            next_rel_item := 0;

            WHILE (number_of_rel_items > 0) DO
              new_object_text_descriptor^.kind := llc$relocation;
              IF (number_of_rel_items <= UPPERVALUE (new_object_text_descriptor^.number_of_rel_items)) THEN
                new_object_text_descriptor^.number_of_rel_items := number_of_rel_items;
              ELSE
                new_object_text_descriptor^.number_of_rel_items :=
                      UPPERVALUE (new_object_text_descriptor^.number_of_rel_items);
              IFEND;

              NEXT new_relocation: [1 .. new_object_text_descriptor^.number_of_rel_items] IN
                    temporary_library;
              IF new_relocation = NIL THEN
                osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY96', status);
                RETURN;
              IFEND;

              IF (old_info_element_header^.number_of_rel_items =
                    new_object_text_descriptor^.number_of_rel_items) THEN
                new_relocation^ := old_relocation^;
              ELSE
                FOR i := 1 TO new_object_text_descriptor^.number_of_rel_items DO
                  new_relocation^ [i] := old_relocation^ [next_rel_item + i];
                FOREND;
              IFEND;
              next_rel_item := next_rel_item + new_object_text_descriptor^.number_of_rel_items;
              number_of_rel_items := number_of_rel_items - new_object_text_descriptor^.number_of_rel_items;

              NEXT new_object_text_descriptor IN temporary_library;
              IF new_object_text_descriptor = NIL THEN
                osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY97', status);
                RETURN;
              IFEND;

              IF segment_relocation_info <> NIL THEN
                ocp$relocate_seg_definitions (new_relocation, segment_relocation_info);
              IFEND;
            WHILEND;
          IFEND;

          IF old_info_element_header^.number_of_template_items <> 0 THEN
            old_binding_template := #PTR (old_info_element_header^.binding_template_ptr,
                  module_description^.file^);
            IF old_binding_template = NIL THEN
              osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
              RETURN;
            IFEND;

            FOR i := 1 TO old_info_element_header^.number_of_template_items DO
              new_object_text_descriptor^.kind := llc$binding_template;
              new_object_text_descriptor^.unused := 0;

              NEXT new_binding_template IN temporary_library;
              IF new_binding_template = NIL THEN
                osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY98', status);
                RETURN;
              IFEND;

              new_binding_template^ := old_binding_template^ [i];

              NEXT new_object_text_descriptor IN temporary_library;
              IF new_object_text_descriptor = NIL THEN
                osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY99', status);
                RETURN;
              IFEND;
            FOREND;
          IFEND;
        IFEND;
        new_object_text_descriptor^.kind := llc$transfer_symbol;
        new_object_text_descriptor^.unused := 0;

        NEXT new_transfer_symbol IN temporary_library;
        IF new_transfer_symbol = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY100', status);
          RETURN;
        IFEND;

        IF entry_points_have_been_changed THEN
          new_transfer_symbol^.name := new_starting_procedure;
        ELSE
          new_transfer_symbol^.name := old_transfer_symbol^.name;
        IFEND;

        RETURN;

      ELSE

        osp$set_status_abnormal (oc, oce$e_invalid_object_rec_kind, module_description^.name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, record_number, 10, FALSE, status);
        RETURN;

      CASEND;

      NEXT old_object_text_descriptor IN module_description^.file;
      IF old_object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
        RETURN;
      IFEND;

      record_number := record_number + 1;

      NEXT new_object_text_descriptor IN temporary_library;
      IF new_object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY101', status);
        RETURN;
      IFEND;

      new_object_text_descriptor^ := old_object_text_descriptor^;

    UNTIL FALSE;


{ The normal return is through the transfer symbol.

  PROCEND copy_load_to_object_module;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] copy_temporary_load_module', EJECT ??

  PROCEDURE [XDCL] copy_temporary_load_module
    (    module_index: llt$module_index;
         module_description: ^oct$module_description;
     VAR load_module_header: ^llt$load_module_header;
     VAR code_section: ^cell;
     VAR read_section: ^cell;
     VAR temporary_library: ^SEQ ( * );
     VAR status: ost$status);

?? NEWTITLE := 'no_segment_definitions', EJECT ??

    FUNCTION no_segment_definitions
      (    section_definition_list: ^oct$section_definition_list): boolean;


      VAR
        sections: ^oct$section_definition_list;


      sections := section_definition_list;

      WHILE (sections <> NIL) DO
        IF (sections^.predefined_segment) THEN
          no_segment_definitions := FALSE;
          RETURN;
        IFEND;

        sections := sections^.link;
      WHILEND;

      no_segment_definitions := TRUE;


    FUNCEND no_segment_definitions;
?? OLDTITLE ??
?? NEWTITLE := 'sort_section_definitions', EJECT ??

    PROCEDURE sort_section_definitions
      (    greatest_section_ordinal: llt$section_ordinal;
           section_definitions: REL (llt$object_library) ^llt$object_text_descriptor;
       VAR temporary_library: ^SEQ ( * );
       VAR sections: ^array [0 .. * ] of section_record);


      VAR
        section_ptr: ^llt$object_text_descriptor,
        reset_value: ^SEQ ( * ),
        attributes: llt$section_access_attributes,
        temp: section_record,
        i,
        j: integer;


      reset_value := temporary_library;
      section_ptr := #PTR (section_definitions, temporary_library^);
      RESET temporary_library TO section_ptr;

      NEXT sections: [0 .. greatest_section_ordinal] IN temporary_library;

      i := 0;
      REPEAT
        attributes := sections^ [i].definition.access_attributes;
        j := i + 1;

        WHILE j <= greatest_section_ordinal DO
          IF attributes = sections^ [j].definition.access_attributes THEN
            i := i + 1;
            temp := sections^ [i];
            sections^ [i] := sections^ [j];
            sections^ [j] := temp;
          IFEND;
          j := j + 1;
        WHILEND;

        i := i + 1;
      UNTIL i >= (greatest_section_ordinal - 1);

      temporary_library := reset_value;

    PROCEND sort_section_definitions;
?? OLDTITLE ??
?? NEWTITLE := 'build_segment_relocation_info', EJECT ??

    PROCEDURE build_segment_relocation_info
      (    greatest_section_ordinal: llt$section_ordinal;
           section_definitions: REL (llt$object_library) ^llt$object_text_descriptor;
           temporary_library: ^SEQ ( * );
       VAR segment_relocation_info: ^oct$segment_relocation_info;
       VAR status: ost$status);

      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        segment_definition: ^llt$segment_definition,
        section_definition: ^llt$section_definition,
        section_ordinal: llt$section_ordinal,
        library: ^SEQ ( * ),
        reset_value: ^SEQ ( * ),
        valid_position: boolean,
        i: integer;


      library := temporary_library;
      object_text_descriptor := #PTR (section_definitions, library^);
      RESET library TO object_text_descriptor;

      NEXT segment_relocation_info: [0 .. greatest_section_ordinal] IN ocv$olg_scratch_seq;
      IF segment_relocation_info = NIL THEN
        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
        RETURN;
      IFEND;

      FOR i := 0 TO greatest_section_ordinal DO
        NEXT object_text_descriptor IN library;
        CASE object_text_descriptor^.kind OF
        = llc$section_definition, llc$allotted_section_definition, llc$unallocated_common_block =
          NEXT section_definition IN library;
          section_ordinal := section_definition^.section_ordinal;
        = llc$segment_definition, llc$allotted_segment_definition =
          NEXT segment_definition IN library;
          section_ordinal := segment_definition^.section_definition.section_ordinal;
        CASEND;

        IF (object_text_descriptor^.kind <> llc$allotted_segment_definition) THEN
          module_description^.segment_relocation_info^ [section_ordinal].old_offset := 0;
          module_description^.segment_relocation_info^ [section_ordinal].new_offset := 0;
        ELSE
          reset_value := library;
          pmp$position_object_library (library, object_text_descriptor^.allotted_segment, valid_position);
          IF NOT valid_position THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY102', status);
            RETURN;
          IFEND;

          IF (object_text_descriptor^.allotted_segment_length <> 0) THEN
            NEXT segment_relocation_info^ [section_ordinal].text:
                  [1 .. object_text_descriptor^.allotted_segment_length] IN library;
            segment_relocation_info^ [section_ordinal].old_offset := 0;
            segment_relocation_info^ [section_ordinal].new_offset := 0;
          ELSE
            NEXT segment_relocation_info^ [section_ordinal].text:
                  [1 .. segment_definition^.section_definition.length] IN library;
            segment_relocation_info^ [section_ordinal].old_offset := 0;
            segment_relocation_info^ [section_ordinal].new_offset := object_text_descriptor^.allotted_segment;
          IFEND;

          library := reset_value;
        IFEND;
      FOREND;

    PROCEND build_segment_relocation_info;
?? OLDTITLE ??
?? NEWTITLE := '    ********* NEXT KLUDGE ********' ??
?? EJECT ??

    PROCEDURE next_kludge
      (VAR object_text_descriptor: ^llt$object_text_descriptor;
       VAR temporary_library: ^SEQ ( * ));


      NEXT object_text_descriptor IN temporary_library;


    PROCEND next_kludge;
?? OLDTITLE ??
?? EJECT ??

    TYPE
      section_record = record
        descriptor: llt$object_text_descriptor,
        definition: llt$section_definition,
      recend;

    VAR
      actual_parameters: ^llt$actual_parameters,
      address_formulation: ^llt$address_formulation,
      address_formulation_list: ^oct$address_formulation_list,
      apl: ^oct$actual_parameter_list,
      application_identifier: ^llt$application_identifier,
      bit_string_insertion: ^llt$bit_string_insertion,
      debug_table_fragment: ^llt$debug_table_fragment,
      deferred_common_blocks: ^llt$deferred_common_blocks,
      deferred_entry_points: ^llt$deferred_entry_points,
      deferred_index: 1 .. llc$max_deferred_entry_points,
      entry_definition: ^llt$entry_definition,
      entry_definition_list: ^oct$entry_definition_list,
      external_linkage: ^llt$external_linkage,
      external_linkage_list: ^oct$external_linkage_list,
      formal_parameters: ^llt$formal_parameters,
      identification: ^llt$identification,
      length: ost$segment_length,
      libraries: ^llt$libraries,
      library_list: ^oct$name_list,
      library_number: integer,
      line_address_table: ^llt$line_address_table,
      m68000_absolute: ^llt$68000_absolute,
      miscellaneous_record_list: ^oct$object_record_list,
      module_name: pmt$program_name,
      number_of_libraries: integer,
      object_text_descriptor: ^llt$object_text_descriptor,
      obsolete_line_address_table: ^llt$obsolete_line_address_table,
      relative_pointer: ost$relative_pointer,
      replication: ^llt$replication,
      section_count: integer,
      section_definition: ^llt$section_definition,
      section_definition_list: ^oct$section_definition_list,
      sections: ^array [0 .. * ] of section_record,
      segment_definition: ^llt$segment_definition,
      supplemental_debug_tables: ^llt$supplemental_debug_tables,
      symbol_table: ^llt$symbol_table,
      temporary_module: ^oct$temporary_module_header,
      text: ^llt$text,
      text_insertion_list: ^oct$text_insertion_list,
      transfer_symbol: ^llt$transfer_symbol;


    module_description^.segment_relocation_info := NIL;

    temporary_module := module_description^.temporary_module_header;

    NEXT load_module_header IN temporary_library;
    IF load_module_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY103', status);
      RETURN;
    IFEND;

    load_module_header^.module_index := module_index;
    load_module_header^.interpretive_header.elements_defined := $llt$interpretive_elements [];
    load_module_header^.elements_defined := $llt$load_module_elements [llc$interpretive_element];

    next_kludge (object_text_descriptor, temporary_library);
    IF object_text_descriptor = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY104', status);
      RETURN;
    IFEND;

    load_module_header^.interpretive_element := #REL (object_text_descriptor, temporary_library^);
    object_text_descriptor^.kind := llc$identification;
    object_text_descriptor^.unused := 0;

    NEXT identification IN temporary_library;
    IF identification = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY105', status);
      RETURN;
    IFEND;

    identification^ := temporary_module^.identification;
    identification^.greatest_section_ordinal := 0;

    NEXT object_text_descriptor IN temporary_library;
    IF object_text_descriptor = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY106', status);
      RETURN;
    IFEND;

    IF temporary_module^.application_identifier <> NIL THEN

      IF temporary_module^.application_identifier^.name <> osc$null_name THEN
        object_text_descriptor^.kind := llc$application_identifier;

        NEXT application_identifier IN temporary_library;
        IF application_identifier = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY106.25', status);
          RETURN;
        IFEND;

        application_identifier^.name := temporary_module^.application_identifier^.name;

        NEXT object_text_descriptor IN temporary_library;
        IF object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY106.5', status);
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    IF temporary_module^.library_list.link <> NIL THEN
      load_module_header^.interpretive_header.library_list :=
            #REL (object_text_descriptor, temporary_library^);
      load_module_header^.interpretive_header.elements_defined :=
            load_module_header^.interpretive_header.elements_defined +
            $llt$interpretive_elements [llc$library_element];

      library_list := temporary_module^.library_list.link;
      number_of_libraries := 0;
      WHILE library_list <> NIL DO
        number_of_libraries := number_of_libraries + 1;
        library_list := library_list^.link;
      WHILEND;

      IF number_of_libraries > llc$max_libraries THEN
        osp$set_status_abnormal (oc, oce$e_too_many_libraries, '', status);
        RETURN;
      IFEND;

      object_text_descriptor^.kind := llc$libraries;
      object_text_descriptor^.number_of_libraries := number_of_libraries;

      NEXT libraries: [1 .. object_text_descriptor^.number_of_libraries] IN temporary_library;
      IF libraries = NIL THEN
        osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY107', status);
        RETURN;
      IFEND;

      library_list := temporary_module^.library_list.link;

      FOR library_number := 1 TO number_of_libraries DO
        libraries^ [library_number] := library_list^.name;
        library_list := library_list^.link;
      FOREND;

      NEXT object_text_descriptor IN temporary_library;
      IF object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY108', status);
        RETURN;
      IFEND;
    IFEND;

    IF temporary_module^.section_definitions.link <> NIL THEN
      load_module_header^.interpretive_header.section_definitions :=
            #REL (object_text_descriptor, temporary_library^);
      load_module_header^.interpretive_header.elements_defined :=
            load_module_header^.interpretive_header.elements_defined +
            $llt$interpretive_elements [llc$section_element];
      section_count := 0;

      IF no_segment_definitions (temporary_module^.section_definitions.link) THEN
        section_definition_list := temporary_module^.section_definitions.link;
        REPEAT
          IF section_definition_list^.unallocated_common_block THEN
            object_text_descriptor^.kind := llc$unallocated_common_block;
          ELSE
            object_text_descriptor^.kind := llc$section_definition;
          IFEND;

          NEXT section_definition IN temporary_library;
          IF section_definition = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY109', status);
            RETURN;
          IFEND;

          section_definition^ := section_definition_list^.section_definition;
          IF identification^.greatest_section_ordinal < section_definition^.section_ordinal THEN
            identification^.greatest_section_ordinal := section_definition^.section_ordinal;
          IFEND;

          IF NOT section_definition_list^.allotted_section THEN
            object_text_descriptor^.unused := 0;
          ELSE
            object_text_descriptor^.kind := llc$allotted_section_definition;

            IF section_definition_list^.section_definition.kind = llc$code_section THEN
              write_new_section (section_definition_list^.section_ptr, section_definition,
                    section_definition^.length, code_section, object_text_descriptor^.allotted_section);
            ELSE
              write_new_section (section_definition_list^.section_ptr, section_definition,
                    section_definition^.length, read_section, object_text_descriptor^.allotted_section);
            IFEND;
          IFEND;

          section_definition_list := section_definition_list^.link;
          section_count := section_count + 1;

          NEXT object_text_descriptor IN temporary_library;
          IF object_text_descriptor = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY110', status);
            RETURN;
          IFEND;
        UNTIL section_definition_list = NIL;

        sort_section_definitions (section_count - 1, load_module_header^.interpretive_header.
              section_definitions, temporary_library, sections);

        FOR section_count := 0 TO section_count - 1 DO
          section_definition_list := temporary_module^.section_definitions.link;
          WHILE sections^ [section_count].definition.section_ordinal <>
                section_definition_list^.section_definition.section_ordinal DO
            section_definition_list := section_definition_list^.link;
          WHILEND;

          IF section_definition_list^.text_insertion_records.link <> NIL THEN
            text_insertion_list := section_definition_list^.text_insertion_records.link;

            REPEAT

              CASE text_insertion_list^.kind OF
              = llc$text =
                object_text_descriptor^.kind := llc$text;
                object_text_descriptor^.number_of_bytes := UPPERBOUND (text_insertion_list^.text^.byte);

                NEXT text: [1 .. object_text_descriptor^.number_of_bytes] IN temporary_library;
                IF text = NIL THEN
                  osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY111', status);
                  RETURN;
                IFEND;

                text^ := text_insertion_list^.text^;

                NEXT object_text_descriptor IN temporary_library;
                IF object_text_descriptor = NIL THEN
                  osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY112', status);
                  RETURN;
                IFEND;

              = llc$replication =
                object_text_descriptor^.kind := llc$replication;
                object_text_descriptor^.number_of_bytes := UPPERBOUND (text_insertion_list^.replication^.
                      byte);

                NEXT replication: [1 .. object_text_descriptor^.number_of_bytes] IN temporary_library;
                IF replication = NIL THEN
                  osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY113', status);
                  RETURN;
                IFEND;

                replication^ := text_insertion_list^.replication^;

                NEXT object_text_descriptor IN temporary_library;
                IF object_text_descriptor = NIL THEN
                  osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY114', status);
                  RETURN;
                IFEND;

              = llc$bit_string_insertion =
                object_text_descriptor^.kind := llc$bit_string_insertion;
                object_text_descriptor^.unused := 0;

                NEXT bit_string_insertion IN temporary_library;
                IF bit_string_insertion = NIL THEN
                  osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY115', status);
                  RETURN;
                IFEND;

                bit_string_insertion^ := text_insertion_list^.bit_string_insertion^;

                NEXT object_text_descriptor IN temporary_library;
                IF object_text_descriptor = NIL THEN
                  osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY116', status);
                  RETURN;
                IFEND;

              CASEND;

              text_insertion_list := text_insertion_list^.link;

            UNTIL text_insertion_list = NIL;
          IFEND;

          IF temporary_module^.address_formulation_list <> NIL THEN
            address_formulation_list := temporary_module^.address_formulation_list;

            REPEAT
              IF address_formulation_list^.address_formulation.dest_section =
                    sections^ [section_count].definition.section_ordinal THEN
                object_text_descriptor^.kind := llc$address_formulation;
                object_text_descriptor^.number_of_adr_items := UPPERBOUND (address_formulation_list^.
                      address_formulation.item);

                NEXT address_formulation: [1 .. object_text_descriptor^.number_of_adr_items] IN
                      temporary_library;
                IF address_formulation = NIL THEN
                  osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY117', status);
                  RETURN;
                IFEND;

                address_formulation^ := address_formulation_list^.address_formulation;

                NEXT object_text_descriptor IN temporary_library;
                IF object_text_descriptor = NIL THEN
                  osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY118', status);
                  RETURN;
                IFEND;
              IFEND;

              address_formulation_list := address_formulation_list^.link;

            UNTIL address_formulation_list = NIL;
          IFEND;
        FOREND;

      ELSE { predefined segments and maybe section definitions }
        section_definition_list := temporary_module^.section_definitions.link;

        REPEAT
          IF (section_definition_list^.predefined_segment) THEN
            object_text_descriptor^.kind := llc$segment_definition;

            NEXT segment_definition IN temporary_library;
            IF segment_definition = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY119', status);
              RETURN;
            IFEND;

            segment_definition^.segment_number := section_definition_list^.predefined_segment_number;
            segment_definition^.r1 := section_definition_list^.predefined_r1;
            segment_definition^.r2 := section_definition_list^.predefined_r2;
            segment_definition^.section_definition := section_definition_list^.section_definition;
            segment_definition^.binding_section_ordinal := section_definition_list^.
                  predefined_binding_ordinal;
            segment_definition^.binding_section_offset := section_definition_list^.predefined_binding_offset;
            segment_definition^.future_use := 0;
            IF identification^.greatest_section_ordinal < segment_definition^.section_definition.
                  section_ordinal THEN
              identification^.greatest_section_ordinal := segment_definition^.section_definition.
                    section_ordinal;
            IFEND;

            IF NOT section_definition_list^.allotted_section THEN
              object_text_descriptor^.unused := 0;
            ELSE
              object_text_descriptor^.kind := llc$allotted_segment_definition;
              object_text_descriptor^.allotted_segment_length :=
                    section_definition_list^.allotted_section_length;
              IF (object_text_descriptor^.allotted_segment_length <> 0) THEN
                length := section_definition_list^.allotted_section_length;
              ELSE
                length := segment_definition^.section_definition.length;
              IFEND;

              IF section_definition_list^.section_definition.kind = llc$code_section THEN
                write_new_section (section_definition_list^.section_ptr,
                      ^segment_definition^.section_definition, length, code_section, relative_pointer);
              ELSE
                write_new_section (section_definition_list^.section_ptr,
                      ^segment_definition^.section_definition, length, read_section, relative_pointer);
              IFEND;
              object_text_descriptor^.allotted_segment := relative_pointer;
            IFEND;

            section_count := section_count + 1;

            NEXT object_text_descriptor IN temporary_library;
            IF object_text_descriptor = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY120', status);
              RETURN;
            IFEND;
          IFEND;

          section_definition_list := section_definition_list^.link;
        UNTIL section_definition_list = NIL;

{ Sections definitions must be next so segments can be shared at load time

        section_definition_list := temporary_module^.section_definitions.link;

        REPEAT
          IF (NOT section_definition_list^.predefined_segment) THEN
            IF section_definition_list^.unallocated_common_block THEN
              object_text_descriptor^.kind := llc$unallocated_common_block;
            ELSE
              object_text_descriptor^.kind := llc$section_definition;
            IFEND;

            NEXT section_definition IN temporary_library;
            IF section_definition = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY121', status);
              RETURN;
            IFEND;

            section_definition^ := section_definition_list^.section_definition;
            IF identification^.greatest_section_ordinal < section_definition^.section_ordinal THEN
              identification^.greatest_section_ordinal := section_definition^.section_ordinal;
            IFEND;

            IF NOT section_definition_list^.allotted_section THEN
              object_text_descriptor^.unused := 0;
            ELSE
              object_text_descriptor^.kind := llc$allotted_section_definition;

              IF section_definition_list^.section_definition.kind = llc$code_section THEN
                write_new_section (section_definition_list^.section_ptr, section_definition,
                      section_definition^.length, code_section, object_text_descriptor^.allotted_section);
              ELSE
                write_new_section (section_definition_list^.section_ptr, section_definition,
                      section_definition^.length, read_section, object_text_descriptor^.allotted_section);
              IFEND;
            IFEND;

            section_count := section_count + 1;

            NEXT object_text_descriptor IN temporary_library;
            IF object_text_descriptor = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY122', status);
              RETURN;
            IFEND;
          IFEND;

          section_definition_list := section_definition_list^.link;
        UNTIL section_definition_list = NIL;

        build_segment_relocation_info (section_count - 1, load_module_header^.interpretive_header.
              section_definitions, temporary_library, module_description^.segment_relocation_info, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        section_definition_list := temporary_module^.section_definitions.link;

        WHILE (section_definition_list <> NIL) DO

          IF section_definition_list^.text_insertion_records.link <> NIL THEN
            text_insertion_list := section_definition_list^.text_insertion_records.link;

            REPEAT
              CASE text_insertion_list^.kind OF
              = llc$text =
                object_text_descriptor^.kind := llc$text;
                object_text_descriptor^.number_of_bytes := UPPERBOUND (text_insertion_list^.text^.byte);

                NEXT text: [1 .. object_text_descriptor^.number_of_bytes] IN temporary_library;
                IF text = NIL THEN
                  osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY123', status);
                  RETURN;
                IFEND;
              CASEND;

              text^ := text_insertion_list^.text^;

              IF module_description^.segment_relocation_info <> NIL THEN
                module_description^.segment_relocation_info^ [text^.section_ordinal].text := ^text^.byte;
              IFEND;

              NEXT object_text_descriptor IN temporary_library;
              IF object_text_descriptor = NIL THEN
                osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY124', status);
                RETURN;
              IFEND;

              text_insertion_list := text_insertion_list^.link;
            UNTIL text_insertion_list = NIL;
          IFEND;

          IF temporary_module^.address_formulation_list <> NIL THEN
            address_formulation_list := temporary_module^.address_formulation_list;

            REPEAT
              IF address_formulation_list^.address_formulation.dest_section =
                    section_definition_list^.section_definition.section_ordinal THEN
                object_text_descriptor^.kind := llc$address_formulation;
                object_text_descriptor^.number_of_adr_items := UPPERBOUND (address_formulation_list^.
                      address_formulation.item);

                NEXT address_formulation: [1 .. object_text_descriptor^.number_of_adr_items] IN
                      temporary_library;
                IF address_formulation = NIL THEN
                  osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY125', status);
                  RETURN;
                IFEND;

                address_formulation^ := address_formulation_list^.address_formulation;

                NEXT object_text_descriptor IN temporary_library;
                IF object_text_descriptor = NIL THEN
                  osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY126', status);
                  RETURN;
                IFEND;
              IFEND;

              address_formulation_list := address_formulation_list^.link;

            UNTIL address_formulation_list = NIL;
          IFEND;

          section_definition_list := section_definition_list^.link;
        WHILEND;
      IFEND;
    IFEND;

    IF temporary_module^.external_linkage_list <> NIL THEN
      external_linkage_list := temporary_module^.external_linkage_list;
      load_module_header^.interpretive_header.external_linkages :=
            #REL (object_text_descriptor, temporary_library^);
      load_module_header^.interpretive_header.elements_defined :=
            load_module_header^.interpretive_header.elements_defined +
            $llt$interpretive_elements [llc$external_element];

      REPEAT
        object_text_descriptor^.kind := llc$external_linkage;
        object_text_descriptor^.number_of_ext_items := UPPERBOUND (external_linkage_list^.external_linkage.
              item);

        NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN temporary_library;
        IF external_linkage = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY127', status);
          RETURN;
        IFEND;

        external_linkage^ := external_linkage_list^.external_linkage;

        NEXT object_text_descriptor IN temporary_library;
        IF object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY128', status);
          RETURN;
        IFEND;
        external_linkage_list := external_linkage_list^.link;
      UNTIL external_linkage_list = NIL;
    IFEND;

    IF temporary_module^.entry_definition_list.link <> NIL THEN
      load_module_header^.interpretive_header.entry_points :=
            #REL (object_text_descriptor, temporary_library^);
      load_module_header^.interpretive_header.elements_defined :=
            load_module_header^.interpretive_header.elements_defined +
            $llt$interpretive_elements [llc$entry_point_element];
      entry_definition_list := temporary_module^.entry_definition_list.link;

      REPEAT
        object_text_descriptor^.kind := llc$entry_definition;
        object_text_descriptor^.unused := 0;

        NEXT entry_definition IN temporary_library;
        IF entry_definition = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY129', status);
          RETURN;
        IFEND;

        entry_definition^ := entry_definition_list^.entry_definition;

        NEXT object_text_descriptor IN temporary_library;
        IF object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY130', status);
          RETURN;
        IFEND;

        entry_definition_list := entry_definition_list^.link;
      UNTIL entry_definition_list = NIL;
    IFEND;

    IF temporary_module^.deferred_entry_points <> NIL THEN
      IF NOT (llc$entry_point_element IN load_module_header^.interpretive_header.elements_defined) THEN
        load_module_header^.interpretive_header.entry_points :=
              #REL (object_text_descriptor, temporary_library^);
        load_module_header^.interpretive_header.elements_defined :=
              load_module_header^.interpretive_header.elements_defined +
              $llt$interpretive_elements [llc$entry_point_element];
      IFEND;

      object_text_descriptor^.kind := llc$deferred_entry_points;
      object_text_descriptor^.number_of_entry_points := UPPERBOUND (temporary_module^.deferred_entry_points^);

      NEXT deferred_entry_points: [1 .. object_text_descriptor^.number_of_entry_points] IN temporary_library;
      IF deferred_entry_points = NIL THEN
        osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY132.3', status);
        RETURN;
      IFEND;

      deferred_entry_points^ := temporary_module^.deferred_entry_points^;

      IF module_description^.segment_relocation_info <> NIL THEN
        FOR deferred_index := 1 TO object_text_descriptor^.number_of_entry_points DO
          deferred_entry_points^ [deferred_index].address.offset :=
                deferred_entry_points^ [deferred_index].address.offset +
                module_description^.segment_relocation_info^ [deferred_entry_points^ [deferred_index].
                section_ordinal].new_offset - module_description^.
                segment_relocation_info^ [deferred_entry_points^ [deferred_index].section_ordinal].old_offset;
        FOREND;
      IFEND;

      NEXT object_text_descriptor IN temporary_library;
      IF object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY132.6', status);
        RETURN;
      IFEND;
    IFEND;

    IF temporary_module^.entry_definition_list.link <> NIL THEN
      entry_definition_list := temporary_module^.entry_definition_list.link;
      REPEAT
        IF entry_definition_list^.formal_parameter <> NIL THEN

          object_text_descriptor^.kind := llc$formal_parameters;
          object_text_descriptor^.sequence_length := #SIZE (entry_definition_list^.formal_parameter^.
                specification);
          NEXT formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                temporary_library;
          IF formal_parameters = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY131', status);
            RETURN;
          IFEND;

          formal_parameters^ := entry_definition_list^.formal_parameter^;

          NEXT object_text_descriptor IN temporary_library;
          IF object_text_descriptor = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY132', status);
            RETURN;
          IFEND;
        IFEND;
        entry_definition_list := entry_definition_list^.link;
      UNTIL entry_definition_list = NIL;
    IFEND;

    IF temporary_module^.deferred_common_blocks <> NIL THEN
      object_text_descriptor^.kind := llc$deferred_common_blocks;
      object_text_descriptor^.number_of_common_blocks := UPPERBOUND (temporary_module^.
            deferred_common_blocks^);

      NEXT deferred_common_blocks: [1 .. object_text_descriptor^.number_of_common_blocks] IN
            temporary_library;
      IF deferred_common_blocks = NIL THEN
        osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY124.3', status);
        RETURN;
      IFEND;

      deferred_common_blocks^ := temporary_module^.deferred_common_blocks^;

      NEXT object_text_descriptor IN temporary_library;
      IF object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY124.6', status);
        RETURN;
      IFEND;
    IFEND;

    IF temporary_module^.external_linkage_list <> NIL THEN
      external_linkage_list := temporary_module^.external_linkage_list;

      REPEAT
        IF external_linkage_list^.actual_parameter_list.nnext <> NIL THEN
          apl := external_linkage_list^.actual_parameter_list.nnext;
          WHILE apl <> NIL DO
            object_text_descriptor^.kind := llc$actual_parameters;
            object_text_descriptor^.sequence_length := #SIZE (apl^.actual_parameter^.specification);

            NEXT actual_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                  temporary_library;
            IF actual_parameters = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY133', status);
              RETURN;
            IFEND;

            actual_parameters^ := apl^.actual_parameter^;

            NEXT object_text_descriptor IN temporary_library;
            IF object_text_descriptor = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY134', status);
              RETURN;
            IFEND;
            apl := apl^.nnext;
          WHILEND;
        IFEND;
        external_linkage_list := external_linkage_list^.link;
      UNTIL external_linkage_list = NIL;
    IFEND;

    IF temporary_module^.miscellaneous_record_list.link <> NIL THEN
      miscellaneous_record_list := temporary_module^.miscellaneous_record_list.link;

      REPEAT

        CASE miscellaneous_record_list^.kind OF

        = llc$cybil_symbol_table_fragment =
          object_text_descriptor^.kind := llc$cybil_symbol_table_fragment;
          object_text_descriptor^.sequence_length := #SIZE (miscellaneous_record_list^.debug_table_fragment^.
                text);

          NEXT debug_table_fragment: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                temporary_library;
          IF debug_table_fragment = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY135', status);
            RETURN;
          IFEND;

          debug_table_fragment^ := miscellaneous_record_list^.debug_table_fragment^;

        = llc$obsolete_line_table =
          object_text_descriptor^.kind := llc$obsolete_line_table;
          object_text_descriptor^.number_of_line_items := UPPERBOUND (miscellaneous_record_list^.
                obsolete_line_address_table^.item);

          NEXT obsolete_line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN
                temporary_library;
          IF obsolete_line_address_table = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY136', status);
            RETURN;
          IFEND;

          obsolete_line_address_table^ := miscellaneous_record_list^.obsolete_line_address_table^;

        = llc$symbol_table =
          object_text_descriptor^.kind := llc$symbol_table;
          object_text_descriptor^.sequence_length := #SIZE (miscellaneous_record_list^.symbol_table^.text);

          NEXT symbol_table: [[REP object_text_descriptor^.sequence_length OF cell]] IN temporary_library;
          IF symbol_table = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY137', status);
            RETURN;
          IFEND;

          symbol_table^ := miscellaneous_record_list^.symbol_table^;

        = llc$line_table =
          object_text_descriptor^.kind := llc$line_table;
          object_text_descriptor^.number_of_line_items := UPPERBOUND (miscellaneous_record_list^.
                line_address_table^.item);

          NEXT line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN temporary_library;
          IF line_address_table = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY138', status);
            RETURN;
          IFEND;

          line_address_table^ := miscellaneous_record_list^.line_address_table^;

        = llc$supplemental_debug_tables =
          object_text_descriptor^.kind := llc$supplemental_debug_tables;
          object_text_descriptor^.sequence_length := #SIZE (miscellaneous_record_list^.
                supplemental_debug_tables^.sd_table);

          NEXT supplemental_debug_tables: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                temporary_library;
          IF supplemental_debug_tables = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY139', status);
            RETURN;
          IFEND;

          supplemental_debug_tables^ := miscellaneous_record_list^.supplemental_debug_tables^;

        = llc$form_definition =
          osp$set_status_abnormal (oc, oce$e_form_def_found_in_module, module_name, status);
          RETURN;

        = llc$68000_absolute =
          object_text_descriptor^.kind := llc$68000_absolute;
          object_text_descriptor^.number_of_68000_bytes := #SIZE (miscellaneous_record_list^.m68000_absolute^.
                text);

          NEXT m68000_absolute: [[REP object_text_descriptor^.number_of_68000_bytes OF cell]] IN
                temporary_library;
          IF m68000_absolute = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY140', status);
            RETURN;
          IFEND;

          m68000_absolute^ := miscellaneous_record_list^.m68000_absolute^;
        CASEND;

        NEXT object_text_descriptor IN temporary_library;
        IF object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY141', status);
          RETURN;
        IFEND;

        miscellaneous_record_list := miscellaneous_record_list^.link;

      UNTIL miscellaneous_record_list = NIL;
    IFEND;

    load_module_header^.interpretive_header.transfer_symbol :=
          #REL (object_text_descriptor, temporary_library^);
    load_module_header^.interpretive_header.elements_defined :=
          load_module_header^.interpretive_header.elements_defined +
          $llt$interpretive_elements [llc$transfer_symbol_element];

    object_text_descriptor^.kind := llc$transfer_symbol;
    object_text_descriptor^.unused := 0;

    NEXT transfer_symbol IN temporary_library;
    IF transfer_symbol = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY142', status);
      RETURN;
    IFEND;

    transfer_symbol^.name := temporary_module^.starting_procedure;

  PROCEND copy_temporary_load_module;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_PROGRAM_DESCRIPTION' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_program_description
    (    module_index: llt$module_index;
         module_description: ^oct$module_description;
         changed_info: ^oct$changed_info;
     VAR new_program_description_header: ^llt$library_member_header;
     VAR temporary_library: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      temp_seq: ^SEQ ( * ),

      old_program_description_header: ^llt$library_member_header,
      old_alias_list: ^pmt$module_list,
      old_program_description: ^llt$program_description,

      new_alias_list: ^pmt$module_list,
      new_program_description: ^llt$program_description,

      last_alias: ^oct$external_declaration_list,
      new_alias: ^pmt$program_name,
      number_of_aliases: llt$number_of_aliases;




    old_program_description_header := module_description^.program_description_header;
    IF old_program_description_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_program_description_header IN temporary_library;
    IF new_program_description_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY143', status);
      RETURN;
    IFEND;

    new_program_description_header^ := old_program_description_header^;
    new_program_description_header^.module_index := module_index;

    IF changed_info <> NIL THEN
      IF changed_info^.name <> NIL THEN
        new_program_description_header^.name := changed_info^.name^;
      IFEND;

      IF changed_info^.commentary <> NIL THEN
        new_program_description_header^.commentary := changed_info^.commentary^;
      IFEND;
    IFEND;

    number_of_aliases := old_program_description_header^.number_of_aliases;

    IF number_of_aliases <> 0 THEN
      old_alias_list := #PTR (old_program_description_header^.aliases, module_description^.file^);
      IF old_alias_list = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
        RETURN;
      IFEND;

      IF (changed_info <> NIL) AND (changed_info^.entry_points <> NIL) THEN
        last_alias := changed_info^.entry_points;
        number_of_aliases := 0;
        temp_seq := temporary_library;

        WHILE last_alias <> NIL DO
          IF last_alias^.name <> osc$null_name THEN
            number_of_aliases := number_of_aliases + 1;

            NEXT new_alias IN temp_seq;
            IF new_alias = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY144', status);
              RETURN;
            IFEND;

            new_alias^ := last_alias^.name;
          IFEND;

          last_alias := last_alias^.link;
        WHILEND;

        new_program_description_header^.number_of_aliases := number_of_aliases;

        IF number_of_aliases <> 0 THEN
          NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
          IF new_alias_list = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY145', status);
            RETURN;
          IFEND;
          new_program_description_header^.aliases := #REL (new_alias_list, temporary_library^);
        IFEND;
      ELSE

        NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
        IF new_alias_list = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY146', status);
          RETURN;
        IFEND;

        new_alias_list^ := old_alias_list^;
        new_program_description_header^.aliases := #REL (new_alias_list, temporary_library^);
      IFEND;
    IFEND;

    old_program_description := #PTR (old_program_description_header^.member, module_description^.file^);
    IF old_program_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_program_description: [[REP new_program_description_header^.member_size OF cell]] IN
          temporary_library;
    IF new_program_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY147', status);
      RETURN;
    IFEND;

    new_program_description_header^.member := #REL (new_program_description, temporary_library^);


    new_program_description^ := old_program_description^;


  PROCEND copy_program_description;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_SCL_PROCEDURE' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_scl_procedure
    (    module_index: llt$module_index;
         module_description: ^oct$module_description;
         changed_info: ^oct$changed_info;
     VAR new_scl_procedure_header: ^llt$library_member_header;
     VAR temporary_library: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      old_scl_procedure_header: ^llt$library_member_header,
      old_alias_list: ^pmt$module_list,
      old_scl_procedure: ^clt$scl_procedure,

      new_alias_list: ^pmt$module_list,
      temp_seq: ^SEQ ( * ),
      new_scl_procedure: ^clt$scl_procedure,

      last_alias: ^oct$external_declaration_list,
      new_alias: ^pmt$program_name,
      number_of_aliases: llt$number_of_aliases;



    CASE module_description^.kind OF
    = occ$command_procedure =
      old_scl_procedure_header := module_description^.command_procedure_header;
    = occ$function_procedure =
      old_scl_procedure_header := module_description^.function_procedure_header;
    CASEND;

    IF old_scl_procedure_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_scl_procedure_header IN temporary_library;
    IF new_scl_procedure_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY148', status);
      RETURN;
    IFEND;

    new_scl_procedure_header^ := old_scl_procedure_header^;
    new_scl_procedure_header^.module_index := module_index;

    IF changed_info <> NIL THEN
      IF changed_info^.name <> NIL THEN
        new_scl_procedure_header^.name := changed_info^.name^;
      IFEND;

      IF changed_info^.commentary <> NIL THEN
        new_scl_procedure_header^.commentary := changed_info^.commentary^;
      IFEND;
    IFEND;

    number_of_aliases := old_scl_procedure_header^.number_of_aliases;

    IF number_of_aliases <> 0 THEN
      old_alias_list := #PTR (old_scl_procedure_header^.aliases, module_description^.file^);
      IF old_alias_list = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
        RETURN;
      IFEND;

      IF (changed_info <> NIL) AND (changed_info^.entry_points <> NIL) THEN
        last_alias := changed_info^.entry_points;
        number_of_aliases := 0;
        temp_seq := temporary_library;

        WHILE last_alias <> NIL DO
          IF last_alias^.name <> osc$null_name THEN
            number_of_aliases := number_of_aliases + 1;

            NEXT new_alias IN temp_seq;
            IF new_alias = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY149', status);
              RETURN;
            IFEND;

            new_alias^ := last_alias^.name;
          IFEND;

          last_alias := last_alias^.link;
        WHILEND;

        new_scl_procedure_header^.number_of_aliases := number_of_aliases;

        IF number_of_aliases <> 0 THEN
          NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
          IF new_alias_list = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY150', status);
            RETURN;
          IFEND;
          new_scl_procedure_header^.aliases := #REL (new_alias_list, temporary_library^);
        IFEND;
      ELSE
        NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
        IF new_alias_list = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY151', status);
          RETURN;
        IFEND;

        new_alias_list^ := old_alias_list^;
        new_scl_procedure_header^.aliases := #REL (new_alias_list, temporary_library^);
      IFEND;
    IFEND;

    old_scl_procedure := #PTR (old_scl_procedure_header^.member, module_description^.file^);
    IF old_scl_procedure = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_scl_procedure: [[REP new_scl_procedure_header^.member_size OF cell]] IN temporary_library;
    IF new_scl_procedure = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY152', status);
      RETURN;
    IFEND;

    new_scl_procedure_header^.member := #REL (new_scl_procedure, temporary_library^);


    new_scl_procedure^ := old_scl_procedure^;

  PROCEND copy_scl_procedure;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_COMMAND_DESCRIPTION' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_command_description (module_index: llt$module_index;
        module_description: ^oct$module_description;
        changed_info: ^oct$changed_info;
    VAR new_command_description_header: ^llt$library_member_header;
    VAR temporary_library: ^SEQ ( * );
    VAR status: ost$status);


    VAR
      temp_seq: ^SEQ ( * ),

      old_command_description_header: ^llt$library_member_header,
      old_alias_list: ^pmt$module_list,
      old_command_description: ^llt$command_description,

      new_alias_list: ^pmt$module_list,
      new_command_description: ^llt$command_description,

      last_alias: ^oct$external_declaration_list,
      new_alias: ^pmt$program_name,
      number_of_aliases: llt$number_of_aliases;


    status.normal := TRUE;

    old_command_description_header :=  module_description^.command_description_header;
    IF old_command_description_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_command_description_header IN temporary_library;
    IF new_command_description_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY143a', status);
      RETURN;
    IFEND;

    new_command_description_header^ := old_command_description_header^;
    new_command_description_header^.module_index := module_index;

    IF changed_info <> NIL THEN
      IF changed_info^.name <> NIL THEN
        new_command_description_header^.name := changed_info^.name^;
      IFEND;

      IF changed_info^.commentary <> NIL THEN
        new_command_description_header^.commentary := changed_info^.commentary^;
      IFEND;
    IFEND;

    number_of_aliases := old_command_description_header^.number_of_aliases;

    IF number_of_aliases <> 0 THEN
      old_alias_list := #PTR (old_command_description_header^.aliases, module_description^.file^);
      IF old_alias_list = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
        RETURN;
      IFEND;

      IF (changed_info <> NIL) AND (changed_info^.entry_points <> NIL) THEN
        last_alias := changed_info^.entry_points;
        number_of_aliases := 0;
        temp_seq := temporary_library;

        WHILE last_alias <> NIL DO
          IF last_alias^.name <> osc$null_name THEN
            number_of_aliases := number_of_aliases + 1;

            NEXT new_alias IN temp_seq;
            IF new_alias = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY144a', status);
              RETURN;
            IFEND;

            new_alias^ := last_alias^.name;
          IFEND;

          last_alias := last_alias^.link;
        WHILEND;

        new_command_description_header^.number_of_aliases := number_of_aliases;

        IF number_of_aliases <> 0 THEN
          NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
          IF new_alias_list = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY145a', status);
            RETURN;
          IFEND;
          new_command_description_header^.aliases := #REL (new_alias_list, temporary_library^);
        IFEND;
      ELSE

        NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
        IF new_alias_list = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY146a', status);
          RETURN;
        IFEND;

        new_alias_list^ := old_alias_list^;
        new_command_description_header^.aliases := #REL (new_alias_list, temporary_library^);
      IFEND;
    IFEND;

    old_command_description := #PTR (old_command_description_header^.member, module_description^.file^);
    IF old_command_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_command_description: [[REP new_command_description_header^.member_size OF cell]] IN
          temporary_library;
    IF new_command_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY147a', status);
      RETURN;
    IFEND;

    new_command_description_header^.member := #REL (new_command_description, temporary_library^);

    new_command_description^ := old_command_description^;

  PROCEND copy_command_description;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_FUNCTION_DESCRIPTION' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_function_description (module_index: llt$module_index;
        module_description: ^oct$module_description;
        changed_info: ^oct$changed_info;
    VAR new_function_description_header: ^llt$library_member_header;
    VAR temporary_library: ^SEQ ( * );
    VAR status: ost$status);


    VAR
      temp_seq: ^SEQ ( * ),

      old_function_description_header: ^llt$library_member_header,
      old_alias_list: ^pmt$module_list,
      old_function_description: ^llt$function_description,

      new_alias_list: ^pmt$module_list,
      new_function_description: ^llt$function_description,

      last_alias: ^oct$external_declaration_list,
      new_alias: ^pmt$program_name,
      number_of_aliases: llt$number_of_aliases;


    status.normal := TRUE;

    old_function_description_header :=  module_description^.function_description_header;
    IF old_function_description_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_function_description_header IN temporary_library;
    IF new_function_description_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY143b', status);
      RETURN;
    IFEND;

    new_function_description_header^ := old_function_description_header^;
    new_function_description_header^.module_index := module_index;

    IF changed_info <> NIL THEN
      IF changed_info^.name <> NIL THEN
        new_function_description_header^.name := changed_info^.name^;
      IFEND;

      IF changed_info^.commentary <> NIL THEN
        new_function_description_header^.commentary := changed_info^.commentary^;
      IFEND;
    IFEND;

    number_of_aliases := old_function_description_header^.number_of_aliases;

    IF number_of_aliases <> 0 THEN
      old_alias_list := #PTR (old_function_description_header^.aliases, module_description^.file^);
      IF old_alias_list = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
        RETURN;
      IFEND;

      IF (changed_info <> NIL) AND (changed_info^.entry_points <> NIL) THEN
        last_alias := changed_info^.entry_points;
        number_of_aliases := 0;
        temp_seq := temporary_library;

        WHILE last_alias <> NIL DO
          IF last_alias^.name <> osc$null_name THEN
            number_of_aliases := number_of_aliases + 1;

            NEXT new_alias IN temp_seq;
            IF new_alias = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY144b', status);
              RETURN;
            IFEND;

            new_alias^ := last_alias^.name;
          IFEND;

          last_alias := last_alias^.link;
        WHILEND;

        new_function_description_header^.number_of_aliases := number_of_aliases;

        IF number_of_aliases <> 0 THEN
          NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
          IF new_alias_list = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY145b', status);
            RETURN;
          IFEND;
          new_function_description_header^.aliases := #REL (new_alias_list, temporary_library^);
        IFEND;
      ELSE

        NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
        IF new_alias_list = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY146b', status);
          RETURN;
        IFEND;

        new_alias_list^ := old_alias_list^;
        new_function_description_header^.aliases := #REL (new_alias_list, temporary_library^);
      IFEND;
    IFEND;

    old_function_description := #PTR (old_function_description_header^.member, module_description^.file^);
    IF old_function_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_function_description: [[REP new_function_description_header^.member_size OF cell]] IN
          temporary_library;
    IF new_function_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY147b', status);
      RETURN;
    IFEND;

    new_function_description_header^.member := #REL (new_function_description, temporary_library^);

    new_function_description^ := old_function_description^;

  PROCEND copy_function_description;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_MESSAGE_MODULE' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_message_module
    (    module_index: llt$module_index;
         module_description: ^oct$module_description;
         changed_info: ^oct$changed_info;
     VAR new_message_module_header: ^llt$library_member_header;
     VAR temporary_library: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      old_message_module_header: ^llt$library_member_header,
      old_message_module: ^ost$message_template_module,

      temp_seq: ^SEQ ( * ),
      new_message_module: ^ost$message_template_module;




    RESET module_description^.file TO module_description^.message_module_header;


    NEXT old_message_module_header IN module_description^.file;
    IF old_message_module_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_message_module_header IN temporary_library;
    IF new_message_module_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY153', status);
      RETURN;
    IFEND;

    new_message_module_header^ := old_message_module_header^;
    new_message_module_header^.module_index := module_index;

    IF changed_info <> NIL THEN
      IF changed_info^.name <> NIL THEN
        new_message_module_header^.name := changed_info^.name^;
      IFEND;

      IF changed_info^.commentary <> NIL THEN
        new_message_module_header^.commentary := changed_info^.commentary^;
      IFEND;
    IFEND;

    old_message_module := #PTR (old_message_module_header^.member, module_description^.file^);
    IF old_message_module = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_message_module: [[REP new_message_module_header^.member_size OF cell]] IN temporary_library;
    IF new_message_module = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY154', status);
      RETURN;
    IFEND;

    new_message_module_header^.member := #REL (new_message_module, temporary_library^);


    new_message_module^ := old_message_module^;

  PROCEND copy_message_module;

?? OLDTITLE ??
?? NEWTITLE := '  COPY_PANEL_MODULE' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_panel_module
    (    module_index: llt$module_index;
         module_description: ^oct$module_description;
         changed_info: ^oct$changed_info;
     VAR new_panel_module_header: ^llt$library_member_header;
     VAR temporary_library: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      old_panel_module_header: ^llt$library_member_header,
      old_panel_module: ^SEQ ( * ),

      temp_seq: ^SEQ ( * ),
      new_panel_module: ^SEQ ( * );



    RESET module_description^.file TO module_description^.panel_module_header;


    NEXT old_panel_module_header IN module_description^.file;
    IF old_panel_module_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_panel_module_header IN temporary_library;
    IF new_panel_module_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY155', status);
      RETURN;
    IFEND;

    new_panel_module_header^ := old_panel_module_header^;
    new_panel_module_header^.module_index := module_index;

    IF changed_info <> NIL THEN
      IF changed_info^.name <> NIL THEN
        new_panel_module_header^.name := changed_info^.name^;
      IFEND;

      IF changed_info^.commentary <> NIL THEN
        new_panel_module_header^.commentary := changed_info^.commentary^;
      IFEND;
    IFEND;

    old_panel_module := #PTR (old_panel_module_header^.member, module_description^.file^);
    IF old_panel_module = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_panel_module: [[REP new_panel_module_header^.member_size OF cell]] IN temporary_library;
    IF new_panel_module = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY156', status);
      RETURN;
    IFEND;

    new_panel_module_header^.member := #REL (new_panel_module, temporary_library^);


    new_panel_module^ := old_panel_module^;

  PROCEND copy_panel_module;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_APPLIC_PROGRAM_DESCRIPTION' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_applic_program_description
    (    module_index: llt$module_index;
         module_description: ^oct$module_description;
         changed_info: ^oct$changed_info;
     VAR new_applic_program_des_hdr: ^llt$application_member_header;
     VAR temporary_library: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      temp_seq: ^SEQ ( * ),

      old_applic_program_des_hdr: ^llt$application_member_header,
      old_alias_list: ^pmt$module_list,
      old_applic_program_description: ^llt$program_description,

      new_alias_list: ^pmt$module_list,
      new_applic_program_description: ^llt$program_description,

      last_alias: ^oct$external_declaration_list,
      new_alias: ^pmt$program_name,
      number_of_aliases: llt$number_of_aliases;


    old_applic_program_des_hdr := module_description^.applic_program_description_hdr;
    IF old_applic_program_des_hdr = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_applic_program_des_hdr IN temporary_library;
    IF new_applic_program_des_hdr = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY157', status);
      RETURN;
    IFEND;

    new_applic_program_des_hdr^ := old_applic_program_des_hdr^;
    new_applic_program_des_hdr^.library_member_header.module_index := module_index;

    IF changed_info <> NIL THEN
      IF changed_info^.name <> NIL THEN
        new_applic_program_des_hdr^.library_member_header.name := changed_info^.name^;
      IFEND;

      IF changed_info^.commentary <> NIL THEN
        new_applic_program_des_hdr^.library_member_header.commentary := changed_info^.commentary^;
      IFEND;

      IF changed_info^.application_identifier <> NIL THEN
        new_applic_program_des_hdr^.application_identifier.name := changed_info^.application_identifier^.name;
      IFEND;
    IFEND;

    number_of_aliases := old_applic_program_des_hdr^.library_member_header.number_of_aliases;

    IF number_of_aliases <> 0 THEN
      old_alias_list := #PTR (old_applic_program_des_hdr^.library_member_header.aliases,
            module_description^.file^);
      IF old_alias_list = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
        RETURN;
      IFEND;

      IF (changed_info <> NIL) AND (changed_info^.entry_points <> NIL) THEN
        last_alias := changed_info^.entry_points;
        number_of_aliases := 0;
        temp_seq := temporary_library;

        WHILE last_alias <> NIL DO
          IF last_alias^.name <> osc$null_name THEN
            number_of_aliases := number_of_aliases + 1;

            NEXT new_alias IN temp_seq;
            IF new_alias = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY158', status);
              RETURN;
            IFEND;

            new_alias^ := last_alias^.name;
          IFEND;

          last_alias := last_alias^.link;
        WHILEND;

        new_applic_program_des_hdr^.library_member_header.number_of_aliases := number_of_aliases;

        IF number_of_aliases <> 0 THEN
          NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
          IF new_alias_list = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY159', status);
            RETURN;
          IFEND;
          new_applic_program_des_hdr^.library_member_header.aliases :=
                #REL (new_alias_list, temporary_library^);
        IFEND;
      ELSE

        NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
        IF new_alias_list = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY160', status);
          RETURN;
        IFEND;

        new_alias_list^ := old_alias_list^;
        new_applic_program_des_hdr^.library_member_header.aliases :=
              #REL (new_alias_list, temporary_library^);
      IFEND;
    IFEND;

    old_applic_program_description := #PTR (old_applic_program_des_hdr^.library_member_header.member,
          module_description^.file^);
    IF old_applic_program_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_applic_program_description: [[REP new_applic_program_des_hdr^.library_member_header.
          member_size OF cell]] IN temporary_library;
    IF new_applic_program_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY161', status);
      RETURN;
    IFEND;

    new_applic_program_des_hdr^.library_member_header.member :=
          #REL (new_applic_program_description, temporary_library^);


    new_applic_program_description^ := old_applic_program_description^;


  PROCEND copy_applic_program_description;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_APPLIC_COMMAND_PROCEDURE' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_applic_command_procedure
    (    module_index: llt$module_index;
         module_description: ^oct$module_description;
         changed_info: ^oct$changed_info;
     VAR new_applic_command_proc_hdr: ^llt$application_member_header;
     VAR temporary_library: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      old_applic_command_proc_hdr: ^llt$application_member_header,
      old_alias_list: ^pmt$module_list,
      old_applic_command_procedure: ^clt$scl_procedure,

      new_alias_list: ^pmt$module_list,
      temp_seq: ^SEQ ( * ),
      new_applic_command_procedure: ^clt$scl_procedure,

      last_alias: ^oct$external_declaration_list,
      new_alias: ^pmt$program_name,
      number_of_aliases: llt$number_of_aliases;



    old_applic_command_proc_hdr := module_description^.applic_command_procedure_header;
    IF old_applic_command_proc_hdr = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_applic_command_proc_hdr IN temporary_library;
    IF new_applic_command_proc_hdr = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY162', status);
      RETURN;
    IFEND;

    new_applic_command_proc_hdr^ := old_applic_command_proc_hdr^;
    new_applic_command_proc_hdr^.library_member_header.module_index := module_index;

    IF changed_info <> NIL THEN
      IF changed_info^.name <> NIL THEN
        new_applic_command_proc_hdr^.library_member_header.name := changed_info^.name^;
      IFEND;

      IF changed_info^.commentary <> NIL THEN
        new_applic_command_proc_hdr^.library_member_header.commentary := changed_info^.commentary^;
      IFEND;

      IF changed_info^.application_identifier <> NIL THEN
        new_applic_command_proc_hdr^.application_identifier.name :=
              changed_info^.application_identifier^.name;
      IFEND;
    IFEND;

    number_of_aliases := old_applic_command_proc_hdr^.library_member_header.number_of_aliases;

    IF number_of_aliases <> 0 THEN
      old_alias_list := #PTR (old_applic_command_proc_hdr^.library_member_header.aliases,
            module_description^.file^);
      IF old_alias_list = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
        RETURN;
      IFEND;

      IF (changed_info <> NIL) AND (changed_info^.entry_points <> NIL) THEN
        last_alias := changed_info^.entry_points;
        number_of_aliases := 0;
        temp_seq := temporary_library;

        WHILE last_alias <> NIL DO
          IF last_alias^.name <> osc$null_name THEN
            number_of_aliases := number_of_aliases + 1;

            NEXT new_alias IN temp_seq;
            IF new_alias = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY163', status);
              RETURN;
            IFEND;

            new_alias^ := last_alias^.name;
          IFEND;

          last_alias := last_alias^.link;
        WHILEND;

        new_applic_command_proc_hdr^.library_member_header.number_of_aliases := number_of_aliases;

        IF number_of_aliases <> 0 THEN
          NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
          IF new_alias_list = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY164', status);
            RETURN;
          IFEND;
          new_applic_command_proc_hdr^.library_member_header.aliases :=
                #REL (new_alias_list, temporary_library^);
        IFEND;
      ELSE
        NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
        IF new_alias_list = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY165', status);
          RETURN;
        IFEND;

        new_alias_list^ := old_alias_list^;
        new_applic_command_proc_hdr^.library_member_header.aliases :=
              #REL (new_alias_list, temporary_library^);
      IFEND;
    IFEND;

    old_applic_command_procedure := #PTR (old_applic_command_proc_hdr^.library_member_header.member,
          module_description^.file^);
    IF old_applic_command_procedure = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_applic_command_procedure: [[REP new_applic_command_proc_hdr^.library_member_header.member_size OF
          cell]] IN temporary_library;
    IF new_applic_command_procedure = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY166', status);
      RETURN;
    IFEND;

    new_applic_command_proc_hdr^.library_member_header.member :=
          #REL (new_applic_command_procedure, temporary_library^);


    new_applic_command_procedure^ := old_applic_command_procedure^;

  PROCEND copy_applic_command_procedure;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_APPLIC_COMMAND_DESCRIPTION' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_applic_command_description (module_index: llt$module_index;
        module_description: ^oct$module_description;
        changed_info: ^oct$changed_info;
    VAR new_applic_command_des_hdr: ^llt$application_member_header;
    VAR temporary_library: ^SEQ ( * );
    VAR status: ost$status);


    VAR
      temp_seq: ^SEQ ( * ),

      old_applic_command_des_hdr: ^llt$application_member_header,
      old_alias_list: ^pmt$module_list,
      old_applic_command_description: ^llt$command_description,

      new_alias_list: ^pmt$module_list,
      new_applic_command_description: ^llt$command_description,

      last_alias: ^oct$external_declaration_list,
      new_alias: ^pmt$program_name,
      number_of_aliases: llt$number_of_aliases;


    status.normal := TRUE;

    old_applic_command_des_hdr :=  module_description^.applic_command_description_hdr;
    IF old_applic_command_des_hdr = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_applic_command_des_hdr IN temporary_library;
    IF new_applic_command_des_hdr = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY157a', status);
      RETURN;
    IFEND;

    new_applic_command_des_hdr^ := old_applic_command_des_hdr^;
    new_applic_command_des_hdr^.library_member_header.module_index := module_index;

    IF changed_info <> NIL THEN
      IF changed_info^.name <> NIL THEN
        new_applic_command_des_hdr^.library_member_header.name := changed_info^.name^;
      IFEND;

      IF changed_info^.commentary <> NIL THEN
        new_applic_command_des_hdr^.library_member_header.commentary := changed_info^.commentary^;
      IFEND;

      IF changed_info^.application_identifier <> NIL THEN
        new_applic_command_des_hdr^.application_identifier.name := changed_info^.
              application_identifier^.name;
      IFEND;
    IFEND;

    number_of_aliases := old_applic_command_des_hdr^.library_member_header.number_of_aliases;

    IF number_of_aliases <> 0 THEN
      old_alias_list := #PTR (old_applic_command_des_hdr^.library_member_header.aliases,
            module_description^.file^);
      IF old_alias_list = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
        RETURN;
      IFEND;

      IF (changed_info <> NIL) AND (changed_info^.entry_points <> NIL) THEN
        last_alias := changed_info^.entry_points;
        number_of_aliases := 0;
        temp_seq := temporary_library;

        WHILE last_alias <> NIL DO
          IF last_alias^.name <> osc$null_name THEN
            number_of_aliases := number_of_aliases + 1;

            NEXT new_alias IN temp_seq;
            IF new_alias = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY158a', status);
              RETURN;
            IFEND;

            new_alias^ := last_alias^.name;
          IFEND;

          last_alias := last_alias^.link;
        WHILEND;

        new_applic_command_des_hdr^.library_member_header.number_of_aliases := number_of_aliases;

        IF number_of_aliases <> 0 THEN
          NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
          IF new_alias_list = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY159a', status);
            RETURN;
          IFEND;
          new_applic_command_des_hdr^.library_member_header.aliases := #REL (new_alias_list,
                temporary_library^);
        IFEND;
      ELSE

        NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
        IF new_alias_list = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY160', status);
          RETURN;
        IFEND;

        new_alias_list^ := old_alias_list^;
        new_applic_command_des_hdr^.library_member_header.aliases := #REL (new_alias_list,
              temporary_library^);
      IFEND;
    IFEND;

    old_applic_command_description := #PTR (old_applic_command_des_hdr^.library_member_header.member,
          module_description^.file^);
    IF old_applic_command_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_applic_command_description: [[REP new_applic_command_des_hdr^.library_member_header.
          member_size OF cell]] IN temporary_library;
    IF new_applic_command_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY161', status);
      RETURN;
    IFEND;

    new_applic_command_des_hdr^.library_member_header.member := #REL (new_applic_command_description,
          temporary_library^);

    new_applic_command_description^ := old_applic_command_description^;

  PROCEND copy_applic_command_description;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_PROG_DES_TO_APP_PROG_DES' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_prog_des_to_app_prog_des
    (    module_index: llt$module_index;
         module_description: ^oct$module_description;
         changed_info: ^oct$changed_info;
     VAR new_applic_program_des_hdr: ^llt$application_member_header;
     VAR temporary_library: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      temp_seq: ^SEQ ( * ),

      old_program_description_header: ^llt$library_member_header,
      old_alias_list: ^pmt$module_list,
      old_applic_program_description: ^llt$program_description,

      new_alias_list: ^pmt$module_list,
      new_applic_program_description: ^llt$program_description,

      last_alias: ^oct$external_declaration_list,
      new_alias: ^pmt$program_name,
      number_of_aliases: llt$number_of_aliases;

    old_program_description_header := module_description^.program_description_header;
    IF old_program_description_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_applic_program_des_hdr IN temporary_library;
    IF new_applic_program_des_hdr = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY167', status);
      RETURN;
    IFEND;

    new_applic_program_des_hdr^.library_member_header := old_program_description_header^;
    new_applic_program_des_hdr^.application_identifier.name := changed_info^.application_identifier^.name;
    new_applic_program_des_hdr^.library_member_header.kind := llc$applic_program_description;
    new_applic_program_des_hdr^.library_member_header.module_index := module_index;

    IF changed_info^.name <> NIL THEN
      new_applic_program_des_hdr^.library_member_header.name := changed_info^.name^;
    IFEND;

    IF changed_info^.commentary <> NIL THEN
      new_applic_program_des_hdr^.library_member_header.commentary := changed_info^.commentary^;
    IFEND;

    number_of_aliases := old_program_description_header^.number_of_aliases;

    IF number_of_aliases <> 0 THEN
      old_alias_list := #PTR (old_program_description_header^.aliases, module_description^.file^);
      IF old_alias_list = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
        RETURN;
      IFEND;

      IF changed_info^.entry_points <> NIL THEN
        last_alias := changed_info^.entry_points;
        number_of_aliases := 0;
        temp_seq := temporary_library;

        WHILE last_alias <> NIL DO
          IF last_alias^.name <> osc$null_name THEN
            number_of_aliases := number_of_aliases + 1;

            NEXT new_alias IN temp_seq;
            IF new_alias = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY168', status);
              RETURN;
            IFEND;

            new_alias^ := last_alias^.name;
          IFEND;

          last_alias := last_alias^.link;
        WHILEND;

        new_applic_program_des_hdr^.library_member_header.number_of_aliases := number_of_aliases;

        IF number_of_aliases <> 0 THEN
          NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
          IF new_alias_list = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY169', status);
            RETURN;
          IFEND;
          new_applic_program_des_hdr^.library_member_header.aliases :=
                #REL (new_alias_list, temporary_library^);
        IFEND;
      ELSE

        NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
        IF new_alias_list = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY170', status);
          RETURN;
        IFEND;

        new_alias_list^ := old_alias_list^;
        new_applic_program_des_hdr^.library_member_header.aliases :=
              #REL (new_alias_list, temporary_library^);
      IFEND;
    IFEND;

    old_applic_program_description := #PTR (old_program_description_header^.member,
          module_description^.file^);
    IF old_applic_program_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_applic_program_description: [[REP new_applic_program_des_hdr^.library_member_header.
          member_size OF cell]] IN temporary_library;
    IF new_applic_program_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY171', status);
      RETURN;
    IFEND;

    new_applic_program_des_hdr^.library_member_header.member :=
          #REL (new_applic_program_description, temporary_library^);

    new_applic_program_description^ := old_applic_program_description^;


  PROCEND copy_prog_des_to_app_prog_des;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_SCL_PROC_TO_APP_SCL_PROC' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_scl_proc_to_app_scl_proc
    (    module_index: llt$module_index;
         module_description: ^oct$module_description;
         changed_info: ^oct$changed_info;
     VAR new_applic_command_proc_hdr: ^llt$application_member_header;
     VAR temporary_library: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      old_command_procedure_header: ^llt$library_member_header,
      old_alias_list: ^pmt$module_list,
      old_applic_command_procedure: ^clt$scl_procedure,

      new_alias_list: ^pmt$module_list,
      temp_seq: ^SEQ ( * ),
      new_applic_command_procedure: ^clt$scl_procedure,

      last_alias: ^oct$external_declaration_list,
      new_alias: ^pmt$program_name,
      number_of_aliases: llt$number_of_aliases;



    old_command_procedure_header := module_description^.command_procedure_header;
    IF old_command_procedure_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_applic_command_proc_hdr IN temporary_library;
    IF new_applic_command_proc_hdr = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY172', status);
      RETURN;
    IFEND;

    new_applic_command_proc_hdr^.library_member_header := old_command_procedure_header^;
    new_applic_command_proc_hdr^.application_identifier.name := changed_info^.application_identifier^.name;
    new_applic_command_proc_hdr^.library_member_header.kind := llc$applic_command_procedure;
    new_applic_command_proc_hdr^.library_member_header.module_index := module_index;

    IF changed_info^.name <> NIL THEN
      new_applic_command_proc_hdr^.library_member_header.name := changed_info^.name^;
    IFEND;

    IF changed_info^.commentary <> NIL THEN
      new_applic_command_proc_hdr^.library_member_header.commentary := changed_info^.commentary^;
    IFEND;

    number_of_aliases := old_command_procedure_header^.number_of_aliases;

    IF number_of_aliases <> 0 THEN
      old_alias_list := #PTR (old_command_procedure_header^.aliases, module_description^.file^);
      IF old_alias_list = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
        RETURN;
      IFEND;

      IF changed_info^.entry_points <> NIL THEN
        last_alias := changed_info^.entry_points;
        number_of_aliases := 0;
        temp_seq := temporary_library;

        WHILE last_alias <> NIL DO
          IF last_alias^.name <> osc$null_name THEN
            number_of_aliases := number_of_aliases + 1;

            NEXT new_alias IN temp_seq;
            IF new_alias = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY173', status);
              RETURN;
            IFEND;

            new_alias^ := last_alias^.name;
          IFEND;

          last_alias := last_alias^.link;
        WHILEND;

        new_applic_command_proc_hdr^.library_member_header.number_of_aliases := number_of_aliases;

        IF number_of_aliases <> 0 THEN
          NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
          IF new_alias_list = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY174', status);
            RETURN;
          IFEND;
          new_applic_command_proc_hdr^.library_member_header.aliases :=
                #REL (new_alias_list, temporary_library^);
        IFEND;
      ELSE
        NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
        IF new_alias_list = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY175', status);
          RETURN;
        IFEND;

        new_alias_list^ := old_alias_list^;
        new_applic_command_proc_hdr^.library_member_header.aliases :=
              #REL (new_alias_list, temporary_library^);
      IFEND;
    IFEND;

    old_applic_command_procedure := #PTR (old_command_procedure_header^.member, module_description^.file^);
    IF old_applic_command_procedure = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_applic_command_procedure: [[REP new_applic_command_proc_hdr^.library_member_header.member_size OF
          cell]] IN temporary_library;
    IF new_applic_command_procedure = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY176', status);
      RETURN;
    IFEND;

    new_applic_command_proc_hdr^.library_member_header.member :=
          #REL (new_applic_command_procedure, temporary_library^);

    new_applic_command_procedure^ := old_applic_command_procedure^;

  PROCEND copy_scl_proc_to_app_scl_proc;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_CMND_DES_TO_APP_CMND_DES' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_cmnd_des_to_app_cmnd_des (module_index: llt$module_index;
        module_description: ^oct$module_description;
        changed_info: ^oct$changed_info;
    VAR new_applic_command_des_hdr: ^llt$application_member_header;
    VAR temporary_library: ^SEQ ( * );
    VAR status: ost$status);


    VAR
      temp_seq: ^SEQ ( * ),

      old_command_description_header: ^llt$library_member_header,
      old_alias_list: ^pmt$module_list,
      old_applic_command_description: ^llt$command_description,

      new_alias_list: ^pmt$module_list,
      new_applic_command_description: ^llt$command_description,

      last_alias: ^oct$external_declaration_list,
      new_alias: ^pmt$program_name,
      number_of_aliases: llt$number_of_aliases;

    old_command_description_header :=  module_description^.command_description_header;
    IF old_command_description_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_applic_command_des_hdr IN temporary_library;
    IF new_applic_command_des_hdr = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY167', status);
      RETURN;
    IFEND;

    new_applic_command_des_hdr^.library_member_header := old_command_description_header^;
    new_applic_command_des_hdr^.application_identifier.name := changed_info^.application_identifier^.name;
    new_applic_command_des_hdr^.library_member_header.kind := llc$applic_command_description;
    new_applic_command_des_hdr^.library_member_header.module_index := module_index;

    IF changed_info^.name <> NIL THEN
      new_applic_command_des_hdr^.library_member_header.name := changed_info^.name^;
    IFEND;

    IF changed_info^.commentary <> NIL THEN
      new_applic_command_des_hdr^.library_member_header.commentary := changed_info^.commentary^;
    IFEND;

    number_of_aliases := old_command_description_header^.number_of_aliases;

    IF number_of_aliases <> 0 THEN
      old_alias_list := #PTR (old_command_description_header^.aliases, module_description^.file^);
      IF old_alias_list = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
        RETURN;
      IFEND;

      IF changed_info^.entry_points <> NIL THEN
        last_alias := changed_info^.entry_points;
        number_of_aliases := 0;
        temp_seq := temporary_library;

        WHILE last_alias <> NIL DO
          IF last_alias^.name <> osc$null_name THEN
            number_of_aliases := number_of_aliases + 1;

            NEXT new_alias IN temp_seq;
            IF new_alias = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY168', status);
              RETURN;
            IFEND;

            new_alias^ := last_alias^.name;
          IFEND;

          last_alias := last_alias^.link;
        WHILEND;

        new_applic_command_des_hdr^.library_member_header.number_of_aliases := number_of_aliases;

        IF number_of_aliases <> 0 THEN
          NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
          IF new_alias_list = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY169', status);
            RETURN;
          IFEND;
          new_applic_command_des_hdr^.library_member_header.aliases := #REL (new_alias_list,
                temporary_library^);
        IFEND;
      ELSE

        NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
        IF new_alias_list = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY170', status);
          RETURN;
        IFEND;

        new_alias_list^ := old_alias_list^;
        new_applic_command_des_hdr^.library_member_header.aliases := #REL (new_alias_list,
              temporary_library^);
      IFEND;
    IFEND;

    old_applic_command_description := #PTR (old_command_description_header^.member,
          module_description^.file^);
    IF old_applic_command_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_applic_command_description: [[REP new_applic_command_des_hdr^.library_member_header.
          member_size OF cell]] IN temporary_library;
    IF new_applic_command_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY171', status);
      RETURN;
    IFEND;

    new_applic_command_des_hdr^.library_member_header.member := #REL (new_applic_command_description,
          temporary_library^);

    new_applic_command_description^ := old_applic_command_description^;


  PROCEND copy_cmnd_des_to_app_cmnd_des;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_APP_PROG_DES_TO_PROG_DES' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_app_prog_des_to_prog_des
    (    module_index: llt$module_index;
         module_description: ^oct$module_description;
         changed_info: ^oct$changed_info;
     VAR new_program_description_header: ^llt$library_member_header;
     VAR temporary_library: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      temp_seq: ^SEQ ( * ),

      old_applic_program_des_hdr: ^llt$application_member_header,
      old_alias_list: ^pmt$module_list,
      old_program_description: ^llt$program_description,

      new_alias_list: ^pmt$module_list,
      new_program_description: ^llt$program_description,

      last_alias: ^oct$external_declaration_list,
      new_alias: ^pmt$program_name,
      number_of_aliases: llt$number_of_aliases;

    old_applic_program_des_hdr := module_description^.applic_program_description_hdr;
    IF old_applic_program_des_hdr = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_program_description_header IN temporary_library;
    IF new_program_description_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY177', status);
      RETURN;
    IFEND;

    new_program_description_header^ := old_applic_program_des_hdr^.library_member_header;
    new_program_description_header^.kind := llc$program_description;
    new_program_description_header^.module_index := module_index;

    IF changed_info^.name <> NIL THEN
      new_program_description_header^.name := changed_info^.name^;
    IFEND;

    IF changed_info^.commentary <> NIL THEN
      new_program_description_header^.commentary := changed_info^.commentary^;
    IFEND;

    number_of_aliases := old_applic_program_des_hdr^.library_member_header.number_of_aliases;

    IF number_of_aliases <> 0 THEN
      old_alias_list := #PTR (old_applic_program_des_hdr^.library_member_header.aliases,
            module_description^.file^);
      IF old_alias_list = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
        RETURN;
      IFEND;

      IF changed_info^.entry_points <> NIL THEN
        last_alias := changed_info^.entry_points;
        number_of_aliases := 0;
        temp_seq := temporary_library;

        WHILE last_alias <> NIL DO
          IF last_alias^.name <> osc$null_name THEN
            number_of_aliases := number_of_aliases + 1;

            NEXT new_alias IN temp_seq;
            IF new_alias = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY178', status);
              RETURN;
            IFEND;

            new_alias^ := last_alias^.name;
          IFEND;

          last_alias := last_alias^.link;
        WHILEND;

        new_program_description_header^.number_of_aliases := number_of_aliases;

        IF number_of_aliases <> 0 THEN
          NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
          IF new_alias_list = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY179', status);
            RETURN;
          IFEND;
          new_program_description_header^.aliases := #REL (new_alias_list, temporary_library^);
        IFEND;
      ELSE

        NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
        IF new_alias_list = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY180', status);
          RETURN;
        IFEND;

        new_alias_list^ := old_alias_list^;
        new_program_description_header^.aliases := #REL (new_alias_list, temporary_library^);
      IFEND;
    IFEND;

    old_program_description := #PTR (old_applic_program_des_hdr^.library_member_header.member,
          module_description^.file^);
    IF old_program_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_program_description: [[REP new_program_description_header^.member_size OF cell]] IN
          temporary_library;
    IF new_program_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY181', status);
      RETURN;
    IFEND;

    new_program_description_header^.member := #REL (new_program_description, temporary_library^);


    new_program_description^ := old_program_description^;


  PROCEND copy_app_prog_des_to_prog_des;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_APP_SCL_PROC_TO_SCL_PROC' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_app_scl_proc_to_scl_proc
    (    module_index: llt$module_index;
         module_description: ^oct$module_description;
         changed_info: ^oct$changed_info;
     VAR new_scl_procedure_header: ^llt$library_member_header;
     VAR temporary_library: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      old_applic_scl_proc_header: ^llt$application_member_header,
      old_alias_list: ^pmt$module_list,
      old_scl_procedure: ^clt$scl_procedure,

      new_alias_list: ^pmt$module_list,
      temp_seq: ^SEQ ( * ),
      new_scl_procedure: ^clt$scl_procedure,

      last_alias: ^oct$external_declaration_list,
      new_alias: ^pmt$program_name,
      number_of_aliases: llt$number_of_aliases;


    old_applic_scl_proc_header := module_description^.applic_command_procedure_header;
    IF old_applic_scl_proc_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_scl_procedure_header IN temporary_library;
    IF new_scl_procedure_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY182', status);
      RETURN;
    IFEND;

    new_scl_procedure_header^ := old_applic_scl_proc_header^.library_member_header;
    new_scl_procedure_header^.kind := llc$command_procedure;
    new_scl_procedure_header^.module_index := module_index;

    IF changed_info^.name <> NIL THEN
      new_scl_procedure_header^.name := changed_info^.name^;
    IFEND;

    IF changed_info^.commentary <> NIL THEN
      new_scl_procedure_header^.commentary := changed_info^.commentary^;
    IFEND;

    number_of_aliases := old_applic_scl_proc_header^.library_member_header.number_of_aliases;

    IF number_of_aliases <> 0 THEN
      old_alias_list := #PTR (old_applic_scl_proc_header^.library_member_header.aliases,
            module_description^.file^);
      IF old_alias_list = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
        RETURN;
      IFEND;

      IF changed_info^.entry_points <> NIL THEN
        last_alias := changed_info^.entry_points;
        number_of_aliases := 0;
        temp_seq := temporary_library;

        WHILE last_alias <> NIL DO
          IF last_alias^.name <> osc$null_name THEN
            number_of_aliases := number_of_aliases + 1;

            NEXT new_alias IN temp_seq;
            IF new_alias = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY183', status);
              RETURN;
            IFEND;

            new_alias^ := last_alias^.name;
          IFEND;

          last_alias := last_alias^.link;
        WHILEND;

        new_scl_procedure_header^.number_of_aliases := number_of_aliases;

        IF number_of_aliases <> 0 THEN
          NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
          IF new_alias_list = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY184', status);
            RETURN;
          IFEND;
          new_scl_procedure_header^.aliases := #REL (new_alias_list, temporary_library^);
        IFEND;
      ELSE
        NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
        IF new_alias_list = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY185', status);
          RETURN;
        IFEND;

        new_alias_list^ := old_alias_list^;
        new_scl_procedure_header^.aliases := #REL (new_alias_list, temporary_library^);
      IFEND;
    IFEND;

    old_scl_procedure := #PTR (old_applic_scl_proc_header^.library_member_header.member,
          module_description^.file^);
    IF old_scl_procedure = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_scl_procedure: [[REP new_scl_procedure_header^.member_size OF cell]] IN temporary_library;
    IF new_scl_procedure = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY186', status);
      RETURN;
    IFEND;

    new_scl_procedure_header^.member := #REL (new_scl_procedure, temporary_library^);


    new_scl_procedure^ := old_scl_procedure^;

  PROCEND copy_app_scl_proc_to_scl_proc;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_APP_CMND_DES_TO_CMND_DES' ??
?? EJECT ??

  PROCEDURE [XDCL] copy_app_cmnd_des_to_cmnd_des (module_index: llt$module_index;
        module_description: ^oct$module_description;
        changed_info: ^oct$changed_info;
    VAR new_command_description_header: ^llt$library_member_header;
    VAR temporary_library: ^SEQ ( * );
    VAR status: ost$status);


    VAR
      temp_seq: ^SEQ ( * ),

      old_applic_command_des_hdr: ^llt$application_member_header,
      old_alias_list: ^pmt$module_list,
      old_command_description: ^llt$command_description,

      new_alias_list: ^pmt$module_list,
      new_command_description: ^llt$command_description,

      last_alias: ^oct$external_declaration_list,
      new_alias: ^pmt$program_name,
      number_of_aliases: llt$number_of_aliases;

    old_applic_command_des_hdr :=  module_description^.applic_command_description_hdr;
    IF old_applic_command_des_hdr = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_command_description_header IN temporary_library;
    IF new_command_description_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY177', status);
      RETURN;
    IFEND;

    new_command_description_header^ := old_applic_command_des_hdr^.library_member_header;
    new_command_description_header^.kind := llc$command_description;
    new_command_description_header^.module_index := module_index;

    IF changed_info^.name <> NIL THEN
      new_command_description_header^.name := changed_info^.name^;
    IFEND;

    IF changed_info^.commentary <> NIL THEN
      new_command_description_header^.commentary := changed_info^.commentary^;
    IFEND;

    number_of_aliases := old_applic_command_des_hdr^.library_member_header.number_of_aliases;

    IF number_of_aliases <> 0 THEN
      old_alias_list := #PTR (old_applic_command_des_hdr^.library_member_header.aliases, module_description^
            .file^);
      IF old_alias_list = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
        RETURN;
      IFEND;

      IF changed_info^.entry_points <> NIL THEN
        last_alias := changed_info^.entry_points;
        number_of_aliases := 0;
        temp_seq := temporary_library;

        WHILE last_alias <> NIL DO
          IF last_alias^.name <> osc$null_name THEN
            number_of_aliases := number_of_aliases + 1;

            NEXT new_alias IN temp_seq;
            IF new_alias = NIL THEN
              osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY178', status);
              RETURN;
            IFEND;

            new_alias^ := last_alias^.name;
          IFEND;

          last_alias := last_alias^.link;
        WHILEND;

        new_command_description_header^.number_of_aliases := number_of_aliases;

        IF number_of_aliases <> 0 THEN
          NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
          IF new_alias_list = NIL THEN
            osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY179', status);
            RETURN;
          IFEND;
          new_command_description_header^.aliases := #REL (new_alias_list, temporary_library^);
        IFEND;
      ELSE

        NEXT new_alias_list: [1 .. number_of_aliases] IN temporary_library;
        IF new_alias_list = NIL THEN
          osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY180', status);
          RETURN;
        IFEND;

        new_alias_list^ := old_alias_list^;
        new_command_description_header^.aliases := #REL (new_alias_list, temporary_library^);
      IFEND;
    IFEND;

    old_command_description := #PTR (old_applic_command_des_hdr^.library_member_header.member,
          module_description^.file^);
    IF old_command_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
      RETURN;
    IFEND;

    NEXT new_command_description: [[REP new_command_description_header^.member_size OF cell]] IN
          temporary_library;
    IF new_command_description = NIL THEN
      osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'CPY181', status);
      RETURN;
    IFEND;

    new_command_description_header^.member := #REL (new_command_description, temporary_library^);


    new_command_description^ := old_command_description^;


  PROCEND copy_app_cmnd_des_to_cmnd_des;

MODEND ocm$copy_modules;
*DECK DECK=OCM$CRACK_PROGRAM_NAME EXPAND=TRUE
?? RIGHT := 110 ??
*copyc OSD$DEFAULT_PRAGMATS
MODULE ocm$crack_program_name;




{ *callc pmdname }

{ *callc osxssa  }
{ *callc osxasp  }

{ *callc cldval  }
{ *callc cldeere }
?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_NAME

*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSP$APPEND_STATUS_PARAMETER

*copyc CLD$VALUE
*copyc CLE$ECC_EXPRESSION_RESULT
?? POP ??
?? NEWTITLE := '  OCP$CRACK_PROGRAM_NAME', EJECT ??

  PROCEDURE [XDCL] ocp$crack_program_name (keyword: string ( * );
        parameter: clt$value;
    VAR program_name: pmt$program_name;
    VAR status: ost$status);


    VAR
      parameter_string: [STATIC] string (40) := ' for parameter ';


    CASE parameter.kind OF
    = clc$name_value =
      program_name := parameter.name.value;
    = clc$string_value =
      program_name := parameter.str.value;
    ELSE
      osp$set_status_abnormal ('OC', cle$wrong_kind_of_value, 'NAME or STRING', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, parameter.descriptor, status);
      parameter_string (16, * ) := keyword;
      osp$append_status_parameter (osc$status_parameter_delimiter, parameter_string, status);
      RETURN;
    CASEND;


  PROCEND ocp$crack_program_name;
?? OLDTITLE ??




MODEND ocm$crack_program_name.
*DECK DECK=OCM$CREATE_COMMAND_DESCRIPTION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Management: Create Command Description' ??
MODULE ocm$create_command_description;

{
{ PURPOSE:
{   This module contains the commands that create command descriptions
{   and system command descriptions.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_parsing
*copyc clt$parameter_list
*copyc llt$command_description
*copyc llt$object_library_header
*copyc oce$library_generator_errors
*copyc oct$display_toggles
*copyc ost$status
?? POP ??
*copyc avp$get_capability
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc i#current_sequence_position
*copyc ocp$add_an_nlm
*copyc ocp$close_all_open_files
*copyc ocp$create_an_nlm
*copyc ocp$initialize_olg_working_heap
*copyc ocp$search_nlm_tree
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_date
*copyc pmp$get_time
*copyc ocv$nlm_list
*copyc ocv$olg_scratch_seq
*copyc ocv$olg_working_heap
*copyc ocv$open_file_list
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$_create_command_description', EJECT ??

  PROCEDURE [XDCL] ocp$_create_command_description
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$creol_crecd) create_command_description, crecd (
{   name, names, n: record
{       name: name
{       aliases: list rest of name = $optional
{     recend = $required
{   starting_procedure, sp: (BY_NAME) program_name = $optional
{   library, l: (BY_NAME) any of
{       key
{         osf$current_library
{       keyend
{       file
{       string
{     anyend = $optional
{   system_command_name, scn: (BY_NAME) name = $optional
{   availability, a: (BY_NAME) key
{       (normal_usage, nu)
{       (advanced_usage, au)
{       (hidden, h)
{     keyend = normal_usage
{   scope, s: (BY_NAME) key
{       (xdcl, x)
{       (gate, g)
{       (local, l)
{     keyend = xdcl
{   log_option, lo: (BY_NAME) key
{       (automatic, a)
{       (manual, m)
{     keyend = automatic
{   merge_option, mo: (BY_NAME) key
{       (add, a)
{       (replace, r)
{       (combine, c)
{     keyend = combine
{   application_identifier, ai: (BY_NAME, ADVANCED) name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 20] of clt$pdt_parameter_name,
      parameters: array [1 .. 10] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: 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,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (12),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (9),
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 9, 12, 22, 0, 23, 724],
    clc$command, 20, 10, 1, 1, 0, 0, 10, 'OCM$CREOL_CRECD'], [
    ['A                              ',clc$abbreviation_entry, 5],
    ['AI                             ',clc$abbreviation_entry, 9],
    ['APPLICATION_IDENTIFIER         ',clc$nominal_entry, 9],
    ['AVAILABILITY                   ',clc$nominal_entry, 5],
    ['L                              ',clc$abbreviation_entry, 3],
    ['LIBRARY                        ',clc$nominal_entry, 3],
    ['LO                             ',clc$abbreviation_entry, 7],
    ['LOG_OPTION                     ',clc$nominal_entry, 7],
    ['MERGE_OPTION                   ',clc$nominal_entry, 8],
    ['MO                             ',clc$abbreviation_entry, 8],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['S                              ',clc$abbreviation_entry, 6],
    ['SCN                            ',clc$abbreviation_entry, 4],
    ['SCOPE                          ',clc$nominal_entry, 6],
    ['SP                             ',clc$abbreviation_entry, 2],
    ['STARTING_PROCEDURE             ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 10],
    ['SYSTEM_COMMAND_NAME            ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 105, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 79, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_default_parameter, 0, 12],
{ PARAMETER 6
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_default_parameter, 0, 4],
{ PARAMETER 7
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 9],
{ PARAMETER 8
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_default_parameter, 0, 7],
{ PARAMETER 9
    [3, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$record_type], [2],
    ['NAME                           ', clc$required_field, 5], [[1, 0,
  clc$name_type], [1, osc$max_name_size]],
    ['ALIASES                        ', clc$optional_field, 21], [[1, 0,
  clc$list_type], [5, 0, clc$max_list_size, TRUE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$program_name_type]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type,
    clc$string_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['OSF$CURRENT_LIBRARY            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [6], [
    ['ADVANCED_USAGE                 ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['AU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['H                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['HIDDEN                         ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['NORMAL_USAGE                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['NU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1]]
    ,
    'normal_usage'],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [6], [
    ['G                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['GATE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['LOCAL                          ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['X                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['XDCL                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ,
    'xdcl'],
{ PARAMETER 7
    [[1, 0, clc$keyword_type], [4], [
    ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['AUTOMATIC                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['M                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['MANUAL                         ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'automatic'],
{ PARAMETER 8
    [[1, 0, clc$keyword_type], [6], [
    ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['ADD                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['COMBINE                        ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['R                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['REPLACE                        ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'combine'],
{ PARAMETER 9
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 10
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$starting_procedure = 2,
      p$library = 3,
      p$system_command_name = 4,
      p$availability = 5,
      p$scope = 6,
      p$log_option = 7,
      p$merge_option = 8,
      p$application_identifier = 9,
      p$status = 10;

    VAR
      pvt: array [1 .. 10] of clt$parameter_value;

    VAR
      alias_list: ^pmt$module_list,
      alias_number: clt$list_size,
      application_administrator: boolean,
      application_identifier: ^llt$application_identifier,
      command_description_contents: ^llt$command_desc_contents,
      command_description_header: ^llt$library_member_header,
      date: ost$date,
      ignore_status: ost$status,
      library_parameter: ^clt$string_value,
      library_path: ^fst$file_reference,
      member: ^SEQ ( * ),
      member_size: ost$segment_length,
      module_already_exists: boolean,
      module_description: ^oct$module_description,
      nlm: ^oct$new_library_module_list,
      node: ^clt$data_value,
      sequence: ^SEQ ( * ),
      size: ost$segment_length,
      time: ost$time;

    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler;

?? NEWTITLE := 'check_parameters', EJECT ??

{
{ This "check parameters procedure" verifies that command description
{ parameters specify information for either a "normal" command description
{ or a "system command description" but not both.
{

    PROCEDURE check_parameters
      (    pvt: ^clt$parameter_value_table;
           ignore_which_parameter: clt$which_parameter;
       VAR status: ost$status);


      status.normal := TRUE;

      IF pvt^ [p$system_command_name].specified THEN
        IF pvt^ [p$starting_procedure].specified OR pvt^ [p$library].specified THEN
          osp$set_status_condition (oce$e_bad_command_desc_params, status);
        IFEND;
      ELSEIF NOT pvt^ [p$starting_procedure].specified THEN
        osp$set_status_abnormal ('OC', cle$required_parameter_omitted,
              'STARTING_PROCEDURE or SYSTEM_COMMAND_NAME', status);
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET ocv$olg_scratch_seq;

    pmp$get_time (osc$hms_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$get_date (osc$mdy_date, date, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];
    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /protect/
    BEGIN

      NEXT command_description_header IN ocv$olg_scratch_seq;
      IF command_description_header = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      command_description_header^.name := pvt [p$name].value^.field_values^ [1].value^.name_value;

      IF pvt [p$application_identifier].specified THEN
        avp$get_capability (avc$application_administration, avc$user, application_administrator, status);
        IF NOT status.normal THEN
          EXIT /protect/;
        IFEND;
        IF NOT application_administrator THEN
          osp$set_status_condition (oce$not_application_administrtr, status);
          EXIT /protect/;
        IFEND;
        NEXT application_identifier IN ocv$olg_scratch_seq;
        IF application_identifier = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        application_identifier^.name := pvt [p$application_identifier].value^.name_value;
        command_description_header^.kind := llc$applic_command_description;
      ELSE
        command_description_header^.kind := llc$command_description;
      IFEND;

      command_description_header^.time_created := time;
      command_description_header^.date_created := date;
      command_description_header^.generator_id := llc$object_library_generator;
      command_description_header^.generator_name_vers := occ$generator_name CAT llc$object_library_version;
      command_description_header^.commentary := osc$null_name;

      command_description_header^.number_of_aliases :=
            clp$count_list_elements (pvt [p$name].value^.field_values^ [2].value);
      IF command_description_header^.number_of_aliases <> 0 THEN
        NEXT alias_list: [1 .. command_description_header^.number_of_aliases] IN ocv$olg_scratch_seq;
        IF alias_list = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        node := pvt [p$name].value^.field_values^ [2].value;
        FOR alias_number := 1 TO command_description_header^.number_of_aliases DO
          alias_list^ [alias_number] := node^.element_value^.name_value;
          node := node^.link;
        FOREND;
      IFEND;

      IF pvt [p$availability].value^.keyword_value = 'HIDDEN' THEN
        command_description_header^.command_function_availability := clc$hidden_entry;
      ELSEIF pvt [p$availability].value^.keyword_value = 'ADVANCED_USAGE' THEN
        command_description_header^.command_function_availability := clc$advanced_usage_entry;
      ELSE {NORMAL_USAGE}
        command_description_header^.command_function_availability := clc$normal_usage_entry;
      IFEND;

      IF pvt [p$scope].value^.keyword_value = 'XDCL' THEN
        command_description_header^.command_function_kind := llc$entry_point;
      ELSEIF pvt [p$scope].value^.keyword_value = 'GATE' THEN
        command_description_header^.command_function_kind := llc$gate;
      ELSE {LOCAL}
        command_description_header^.command_function_kind := llc$local_to_library;
      IFEND;

      IF pvt [p$log_option].value^.keyword_value = 'AUTOMATIC' THEN
        command_description_header^.command_log_option := clc$automatically_log;
      ELSE {MANUAL}
        command_description_header^.command_log_option := clc$manually_log;
      IFEND;

      NEXT command_description_contents IN ocv$olg_scratch_seq;
      IF command_description_contents = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      command_description_contents^.version := llc$command_desc_version;
      command_description_contents^.system_command := pvt [p$system_command_name].specified;

      IF command_description_contents^.system_command THEN
        command_description_contents^.system_command_name := pvt [p$system_command_name].value^.name_value;

      ELSE
        command_description_contents^.starting_procedure := pvt [p$starting_procedure].value^.
              program_name_value;

        IF NOT pvt [p$library].specified THEN
          command_description_contents^.library_path_size := 0;
        ELSE
          CASE pvt [p$library].value^.kind OF
          = clc$keyword = {OSF$CURRENT_LIBRARY}
            library_parameter := ^pvt [p$library].value^.keyword_value;
          = clc$file =
            library_parameter := pvt [p$library].value^.file_value;
          ELSE {clc$string}
            library_parameter := pvt [p$library].value^.string_value;
          CASEND;
          IF STRLENGTH (library_parameter^) >= fsc$max_path_size THEN
            command_description_contents^.library_path_size := fsc$max_path_size;
          ELSE
            command_description_contents^.library_path_size := STRLENGTH (library_parameter^);
          IFEND;
          NEXT library_path: [command_description_contents^.library_path_size] IN ocv$olg_scratch_seq;
          IF library_path = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;
          library_path^ := library_parameter^;
        IFEND;
      IFEND;

      ALLOCATE module_description IN ocv$olg_working_heap^;
      IF module_description = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      module_description^.name := command_description_header^.name;
      module_description^.source := occ$current;
      IF pvt [p$application_identifier].specified THEN
        module_description^.kind := occ$applic_command_description
      ELSE
        module_description^.kind := occ$command_description;
      IFEND;

      ocp$search_nlm_tree (command_description_header^.name, nlm, module_already_exists);

      IF pvt [p$merge_option].value^.keyword_value = 'ADD' THEN
        IF module_already_exists THEN
          osp$set_status_abnormal ('OC', oce$e_module_already_on_library, command_description_header^.name,
                status);
          EXIT /protect/;
        ELSE
          ocp$create_an_nlm (module_description, nlm, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
          ocp$add_an_nlm (ocv$nlm_list^.b_link, nlm);
        IFEND;

      ELSEIF pvt [p$merge_option].value^.keyword_value = 'REPLACE' THEN
        IF module_already_exists THEN
          nlm^.description := module_description;
          nlm^.changed_info := NIL;
        ELSE
          osp$set_status_abnormal ('OC', oce$e_module_not_found, command_description_header^.name, status);
          EXIT /protect/;
        IFEND;

      ELSE {COMBINE}
        IF module_already_exists THEN
          nlm^.description := module_description;
          nlm^.changed_info := NIL;
        ELSE
          ocp$create_an_nlm (module_description, nlm, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
          ocp$add_an_nlm (ocv$nlm_list^.b_link, nlm);
        IFEND;
      IFEND;

      size := i#current_sequence_position (ocv$olg_scratch_seq);
      RESET ocv$olg_scratch_seq;
      NEXT sequence: [[REP size OF cell]] IN ocv$olg_scratch_seq;
      ALLOCATE module_description^.file: [[REP size OF cell]] IN ocv$olg_working_heap^;
      IF module_description^.file = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      module_description^.file^ := sequence^;
      RESET module_description^.file;
      IF pvt [p$application_identifier].specified THEN
        NEXT module_description^.applic_command_description_hdr IN module_description^.file;
        IF module_description^.applic_command_description_hdr^.library_member_header.number_of_aliases <>
              0 THEN
          NEXT alias_list: [1 .. module_description^.applic_command_description_hdr^.library_member_header.
                number_of_aliases] IN module_description^.file;
          module_description^.applic_command_description_hdr^.library_member_header.aliases :=
                #REL (alias_list, module_description^.file^);
        IFEND;
      ELSE
        NEXT module_description^.command_description_header IN module_description^.file;
        IF module_description^.command_description_header^.number_of_aliases <> 0 THEN
          NEXT alias_list: [1 .. module_description^.command_description_header^.number_of_aliases] IN
                module_description^.file;
          module_description^.command_description_header^.aliases :=
                #REL (alias_list, module_description^.file^);
        IFEND;
      IFEND;

      member_size := size - i#current_sequence_position (module_description^.file);
      NEXT member: [[REP member_size OF cell]] IN module_description^.file;

      IF pvt [p$application_identifier].specified THEN
        module_description^.applic_command_description_hdr^.library_member_header.member :=
              #REL (member, module_description^.file^);
        module_description^.applic_command_description_hdr^.library_member_header.member_size := member_size;
      ELSE
        module_description^.command_description_header^.member := #REL (member, module_description^.file^);
        module_description^.command_description_header^.member_size := member_size;
      IFEND;

    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);

  PROCEND ocp$_create_command_description;

MODEND ocm$create_command_description;
*DECK DECK=OCM$CREATE_FORM_MODULE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Utilities: Create Form Module' ??
MODULE ocm$create_form_module;

{ PURPOSE:
{   This module contains the command processor for the CREATE_FORM_MODULE subcommand
{   of CREATE_OBJECT_LIBRARY.
{ DESIGN:
{   The Format Display (FD) routines actually create the form module; the
{   CREATE_OBJECT_LIBRARY utility only processes the command to create a form
{   module and merges the newly-created module with the current library.
{ NOTE:
{   "Panel module" is the old name for "form module".

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_value
*copyc fdc$screen_generator_version
*copyc fdt$form_identifier
*copyc fdt$form_status
*copyc oce$library_generator_errors
*copyc oct$display_toggles
*copyc oct$new_library_module_list
*copyc osd$virtual_address
*copyc ost$date
*copyc ost$status
*copyc ost$time
*copyc pmt$condition
*copyc pmt$established_handler
*copyc pmt$system_conditions
?? POP ??
*copyc clp$evaluate_parameters
*copyc fdp$begin_create_form_module
*copyc fdp$close_form
*copyc fdp$copy_form
*copyc fdp$find_form_definition
*copyc i#current_sequence_position
*copyc ocp$add_an_nlm
*copyc ocp$close_all_open_files
*copyc ocp$create_an_nlm
*copyc ocp$initialize_olg_working_heap
*copyc ocp$search_nlm_tree
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_date
*copyc pmp$get_time
*copyc ocv$nlm_list
*copyc ocv$olg_scratch_seq
*copyc ocv$olg_working_heap
*copyc ocv$open_file_list
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$_create_form_module', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to process the CREATE_FORM_MODULE subcommand
{   of CREATE_OBJECT_LIBRARY.

  PROCEDURE [XDCL] ocp$_create_form_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$creol_crefm) create_form_module, crefm(
{   form_name, fn: name = $required
{   merge_option, mo: key
{     (add, a)
{     (replace, r)
{     (combine, c)
{    keyend = combine
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 2, 14, 17, 38, 26, 340],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'OCM$CREOL_CREFM'], [
    ['FN                             ',clc$abbreviation_entry, 1],
    ['FORM_NAME                      ',clc$nominal_entry, 1],
    ['MERGE_OPTION                   ',clc$nominal_entry, 2],
    ['MO                             ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [6], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ADD                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['COMBINE                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['REPLACE                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'combine'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$form_name = 1,
      p$merge_option = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      compact_form_identifier: fdt$form_identifier,
      create_module: boolean,
      date: ost$date,
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler,
      form_identifier: fdt$form_identifier,
      form_module_header_p: ^llt$library_member_header,
      form_module_p: ^SEQ ( * ),
      form_module_size: ost$segment_length,
      form_status_p: ^fdt$form_status,
      form_storage_p: ^SEQ ( * ),
      header_plus_module_size: ost$segment_length,
      ignore_status: ost$status,
      module_description_p: ^oct$module_description,
      module_exists: boolean,
      module_p: ^SEQ ( * ),
      nlm_p: ^oct$new_library_module_list,
      sequence_p: ^SEQ ( * ),
      temporary_module_header: llt$library_member_header,
      time: ost$time;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   This procedure is the condition handler for ocp$_create_form_module.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_time (osc$hms_time, time, ignore_status);

    pmp$get_date (osc$mdy_date, date, ignore_status);
    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /protect/
    BEGIN
      fdp$begin_create_form_module (pvt [p$form_name].value^.name_value, form_identifier, create_module,
            status);
      IF (NOT status.normal) OR (NOT create_module) THEN

{ No clean up is necessary here. Procedure fdp$begin_create_form_module has already done it.

        EXIT /protect/;
      IFEND;

{ Make the form compact and clean up space used by the original form.

      fdp$copy_form (form_identifier, compact_form_identifier, status);
      fdp$close_form (form_identifier, ignore_status);
      IF NOT status.normal THEN
        EXIT /protect/;
      IFEND;

{ Get the form definition record for the form module.

      fdp$find_form_definition (compact_form_identifier, form_status_p, status);
      IF NOT status.normal THEN
        fdp$close_form (compact_form_identifier, ignore_status);
        EXIT /protect/;
      IFEND;
      temporary_module_header.name := pvt [p$form_name].value^.name_value;
      temporary_module_header.kind := llc$panel_module;
      temporary_module_header.time_created := time;
      temporary_module_header.date_created := date;
      temporary_module_header.generator_id := llc$screen_formatter;
      temporary_module_header.generator_name_vers := fdc$screen_generator_version;
      temporary_module_header.commentary := osc$null_name;
      temporary_module_header.number_of_aliases := 0;

      ALLOCATE module_description_p IN ocv$olg_working_heap^;
      IF module_description_p = NIL THEN
        fdp$close_form (compact_form_identifier, ignore_status);
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      module_description_p^.name := temporary_module_header.name;
      module_description_p^.source := occ$current;
      module_description_p^.kind := occ$panel_module;

      ocp$search_nlm_tree (temporary_module_header.name, nlm_p, module_exists);

{ Check for error conditions.

      CASE pvt [p$merge_option].value^.keyword_value (1) OF
      = 'A' =
        IF module_exists THEN
          fdp$close_form (compact_form_identifier, ignore_status);
          osp$set_status_abnormal (oc, oce$e_module_already_on_library, temporary_module_header.name, status);
          EXIT /protect/;
        IFEND;
      = 'R' =
        IF NOT module_exists THEN
          osp$set_status_abnormal (oc, oce$e_module_not_found, temporary_module_header.name, status);
          fdp$close_form (compact_form_identifier, ignore_status);
          EXIT /protect/;
        IFEND;
      ELSE
      CASEND;

{ Replace the module if it exists already; add it if it doesn't.

      IF module_exists THEN
        nlm_p^.description := module_description_p;
        nlm_p^.changed_info := NIL;
      ELSE
        ocp$create_an_nlm (module_description_p, nlm_p, status);
        IF NOT status.normal THEN
          fdp$close_form (compact_form_identifier, ignore_status);
          EXIT /protect/;
        IFEND;
        ocp$add_an_nlm (ocv$nlm_list^.b_link, nlm_p);
      IFEND;

      RESET ocv$olg_scratch_seq;
      NEXT form_module_header_p IN ocv$olg_scratch_seq;
      IF form_module_header_p = NIL THEN
        fdp$close_form (compact_form_identifier, ignore_status);
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;
      form_module_size := i#current_sequence_position (form_status_p^.p_form_module);
      NEXT sequence_p: [[REP form_module_size OF cell]] IN ocv$olg_scratch_seq;
      IF sequence_p = NIL THEN
        fdp$close_form (compact_form_identifier, ignore_status);
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

{ Get the size of the module header + the module itself.

      header_plus_module_size := i#current_sequence_position (ocv$olg_scratch_seq);

      ALLOCATE module_description_p^.file: [[REP header_plus_module_size OF cell]] IN ocv$olg_working_heap^;
      IF module_description_p^.file = NIL THEN
        fdp$close_form (compact_form_identifier, ignore_status);
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;
      RESET module_description_p^.file;
      NEXT module_description_p^.panel_module_header IN module_description_p^.file;
      module_description_p^.panel_module_header^ := temporary_module_header;

{ Set up a pointer to an object of the correct size (form_module_size) in sequence
{ form_status_p^.p_form_module.

      form_storage_p := form_status_p^.p_form_module;
      RESET form_storage_p;
      NEXT form_module_p: [[REP form_module_size OF cell]] IN form_storage_p;

      NEXT module_p: [[REP form_module_size OF cell]] IN module_description_p^.file;
      module_p^ := form_module_p^;
      module_description_p^.panel_module_header^.member := #REL (module_p, module_description_p^.file^);
      module_description_p^.panel_module_header^.member_size := form_module_size;
      fdp$close_form (compact_form_identifier, ignore_status);
    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);
  PROCEND ocp$_create_form_module;
?? OLDTITLE ??
MODEND ocm$create_form_module;
*DECK DECK=OCM$CREATE_FUNCTION_DESCRIPTION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Management: Create Function Description' ??
MODULE ocm$create_function_description;

{
{ PURPOSE:
{   This module contains the commands that create function descriptions.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_parsing
*copyc clt$parameter_list
*copyc llt$function_description
*copyc llt$object_library_header
*copyc oce$library_generator_errors
*copyc oct$display_toggles
*copyc ost$status
?? POP ??
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc i#current_sequence_position
*copyc ocp$add_an_nlm
*copyc ocp$close_all_open_files
*copyc ocp$create_an_nlm
*copyc ocp$initialize_olg_working_heap
*copyc ocp$search_nlm_tree
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_date
*copyc pmp$get_time
*copyc ocv$nlm_list
*copyc ocv$olg_scratch_seq
*copyc ocv$olg_working_heap
*copyc ocv$open_file_list
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$_create_function_descriptio', EJECT ??

  PROCEDURE [XDCL] ocp$_create_function_descriptio
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$creol_crefd) create_function_description, crefd (
{   name, names, n: any of
{       data_name
{       record
{         name: data_name
{         aliases: list rest of data_name = $optional
{       recend
{     anyend = $required
{   starting_procedure, sp: (BY_NAME) program_name = $required
{   library, l: (BY_NAME) any of
{       key
{         osf$current_library
{       keyend
{       file
{       string
{     anyend = $optional
{   availability, a: (BY_NAME) key
{       (normal_usage, nu)
{       (advanced_usage, au)
{       (hidden, h)
{     keyend = normal_usage
{   scope, s: (BY_NAME) key
{       (xdcl, x)
{       (gate, g)
{       (local, l)
{     keyend = xdcl
{   merge_option, mo: (BY_NAME) key
{       (add, a)
{       (replace, r)
{       (combine, c)
{     keyend = combine
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 14] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$list_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: 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,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (12),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 9, 8, 10, 4, 58, 88],
    clc$command, 14, 7, 2, 0, 0, 0, 7, 'OCM$CREOL_CREFD'], [
    ['A                              ',clc$abbreviation_entry, 4],
    ['AVAILABILITY                   ',clc$nominal_entry, 4],
    ['L                              ',clc$abbreviation_entry, 3],
    ['LIBRARY                        ',clc$nominal_entry, 3],
    ['MERGE_OPTION                   ',clc$nominal_entry, 6],
    ['MO                             ',clc$abbreviation_entry, 6],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['S                              ',clc$abbreviation_entry, 5],
    ['SCOPE                          ',clc$nominal_entry, 5],
    ['SP                             ',clc$abbreviation_entry, 2],
    ['STARTING_PROCEDURE             ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 7]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 124,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 79, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 12],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 6
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 7
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$data_name_type, clc$record_type],
    FALSE, 2],
    3, [[1, 0, clc$data_name_type]],
    101, [[1, 0, clc$record_type], [2],
      ['NAME                           ', clc$required_field, 3], [[1, 0, clc$data_name_type]],
      ['ALIASES                        ', clc$optional_field, 19], [[1, 0, clc$list_type], [3, 0,
  clc$max_list_size, TRUE],
          [[1, 0, clc$data_name_type]]
        ]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$program_name_type]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type, clc$string_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['OSF$CURRENT_LIBRARY            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [6], [
    ['ADVANCED_USAGE                 ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['AU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['H                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['HIDDEN                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['NORMAL_USAGE                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['NU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1]]
    ,
    'normal_usage'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [6], [
    ['G                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['GATE                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['LOCAL                          ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['X                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['XDCL                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'xdcl'],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [6], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ADD                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['COMBINE                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['REPLACE                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'combine'],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$starting_procedure = 2,
      p$library = 3,
      p$availability = 4,
      p$scope = 5,
      p$merge_option = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;


    VAR
      alias_list: ^pmt$module_list,
      alias_number: clt$list_size,
      function_description_contents: ^llt$function_desc_contents,
      function_description_header: ^llt$library_member_header,
      date: ost$date,
      ignore_status: ost$status,
      library_parameter: ^clt$string_value,
      library_path: ^fst$file_reference,
      member: ^SEQ ( * ),
      member_size: ost$segment_length,
      module_already_exists: boolean,
      module_description: ^oct$module_description,
      nlm: ^oct$new_library_module_list,
      node: ^clt$data_value,
      sequence: ^SEQ ( * ),
      size: ost$segment_length,
      time: ost$time;

    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET ocv$olg_scratch_seq;

    pmp$get_time (osc$hms_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$get_date (osc$mdy_date, date, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];
    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /protect/
    BEGIN

      NEXT function_description_header IN ocv$olg_scratch_seq;
      IF function_description_header = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      IF pvt [p$name].value^.kind = clc$data_name THEN
        function_description_header^.name := pvt [p$name].value^.data_name_value;
        node := NIL;
        function_description_header^.number_of_aliases := 0;
      ELSE
        function_description_header^.name := pvt [p$name].value^.field_values^ [1].value^.data_name_value;
        node := pvt [p$name].value^.field_values^ [2].value;
        function_description_header^.number_of_aliases := clp$count_list_elements (node);
      IFEND;
      IF function_description_header^.name (1) <> '$' THEN
        osp$set_status_abnormal ('CL', cle$function_name_needs_$, function_description_header^.name, status);
        EXIT /protect/;
      IFEND;

      function_description_header^.kind := llc$function_description;
      function_description_header^.time_created := time;
      function_description_header^.date_created := date;
      function_description_header^.generator_id := llc$object_library_generator;
      function_description_header^.generator_name_vers := occ$generator_name CAT llc$object_library_version;
      function_description_header^.commentary := osc$null_name;

      IF function_description_header^.number_of_aliases <> 0 THEN
        NEXT alias_list: [1 .. function_description_header^.number_of_aliases] IN ocv$olg_scratch_seq;
        IF alias_list = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        FOR alias_number := 1 TO function_description_header^.number_of_aliases DO
          IF node^.element_value^.data_name_value (1) <> '$' THEN
            osp$set_status_abnormal ('CL', cle$function_name_needs_$, node^.element_value^.data_name_value,
                  status);
            EXIT /protect/;
          IFEND;
          alias_list^ [alias_number] := node^.element_value^.data_name_value;
          node := node^.link;
        FOREND;
      IFEND;

      IF pvt [p$availability].value^.keyword_value = 'HIDDEN' THEN
        function_description_header^.command_function_availability := clc$hidden_entry;
      ELSEIF pvt [p$availability].value^.keyword_value = 'ADVANCED_USAGE' THEN
        function_description_header^.command_function_availability := clc$advanced_usage_entry;
      ELSE {NORMAL_USAGE}
        function_description_header^.command_function_availability := clc$normal_usage_entry;
      IFEND;

      IF pvt [p$scope].value^.keyword_value = 'XDCL' THEN
        function_description_header^.command_function_kind := llc$entry_point;
      ELSEIF pvt [p$scope].value^.keyword_value = 'GATE' THEN
        function_description_header^.command_function_kind := llc$gate;
      ELSE {LOCAL}
        function_description_header^.command_function_kind := llc$local_to_library;
      IFEND;

      function_description_header^.command_log_option := clc$automatically_log;

      NEXT function_description_contents IN ocv$olg_scratch_seq;
      IF function_description_contents = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      function_description_contents^.version := llc$function_desc_version;
      function_description_contents^.starting_procedure :=
            pvt [p$starting_procedure].value^.program_name_value;

      IF NOT pvt [p$library].specified THEN
        function_description_contents^.library_path_size := 0;
      ELSE
        CASE pvt [p$library].value^.kind OF
        = clc$keyword = {OSF$CURRENT_LIBRARY}
          library_parameter := ^pvt [p$library].value^.keyword_value;
        = clc$file =
          library_parameter := pvt [p$library].value^.file_value;
        ELSE {clc$string}
          library_parameter := pvt [p$library].value^.string_value;
        CASEND;
        IF STRLENGTH (library_parameter^) >= fsc$max_path_size THEN
          function_description_contents^.library_path_size := fsc$max_path_size;
        ELSE
          function_description_contents^.library_path_size := STRLENGTH (library_parameter^);
        IFEND;
        NEXT library_path: [function_description_contents^.library_path_size] IN ocv$olg_scratch_seq;
        IF library_path = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        library_path^ := library_parameter^;
      IFEND;

      ALLOCATE module_description IN ocv$olg_working_heap^;
      IF module_description = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      module_description^.name := function_description_header^.name;
      module_description^.source := occ$current;
      module_description^.kind := occ$function_description;

      ocp$search_nlm_tree (function_description_header^.name, nlm, module_already_exists);

      IF pvt [p$merge_option].value^.keyword_value = 'ADD' THEN
        IF module_already_exists THEN
          osp$set_status_abnormal ('OC', oce$e_module_already_on_library, function_description_header^.name,
                status);
          EXIT /protect/;
        ELSE
          ocp$create_an_nlm (module_description, nlm, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
          ocp$add_an_nlm (ocv$nlm_list^.b_link, nlm);
        IFEND;

      ELSEIF pvt [p$merge_option].value^.keyword_value = 'REPLACE' THEN
        IF module_already_exists THEN
          nlm^.description := module_description;
          nlm^.changed_info := NIL;
        ELSE
          osp$set_status_abnormal ('OC', oce$e_module_not_found, function_description_header^.name, status);
          EXIT /protect/;
        IFEND;

      ELSE {COMBINE}
        IF module_already_exists THEN
          nlm^.description := module_description;
          nlm^.changed_info := NIL;
        ELSE
          ocp$create_an_nlm (module_description, nlm, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
          ocp$add_an_nlm (ocv$nlm_list^.b_link, nlm);
        IFEND;
      IFEND;

      size := i#current_sequence_position (ocv$olg_scratch_seq);
      RESET ocv$olg_scratch_seq;
      NEXT sequence: [[REP size OF cell]] IN ocv$olg_scratch_seq;
      ALLOCATE module_description^.file: [[REP size OF cell]] IN ocv$olg_working_heap^;
      IF module_description^.file = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      module_description^.file^ := sequence^;
      RESET module_description^.file;
      NEXT module_description^.function_description_header IN module_description^.file;
      IF module_description^.function_description_header^.number_of_aliases <> 0 THEN
        NEXT alias_list: [1 .. module_description^.function_description_header^.number_of_aliases] IN
              module_description^.file;
        module_description^.function_description_header^.aliases :=
              #REL (alias_list, module_description^.file^);
      IFEND;

      member_size := size - i#current_sequence_position (module_description^.file);
      NEXT member: [[REP member_size OF cell]] IN module_description^.file;

      module_description^.function_description_header^.member := #REL (member, module_description^.file^);
      module_description^.function_description_header^.member_size := member_size;

    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);

  PROCEND ocp$_create_function_descriptio;

MODEND ocm$create_function_description;
*DECK DECK=OCM$CREATE_LINKED_MODULE EXPAND=TRUE
PROCEDURE ocp$create_linked_module, crelm (
  name, n: program_name = $required
  component, components, c: list of record
      library: file
      modules: list rest of any of
          program_name
          range of program_name
        anyend = $optional
    recend = $required
  ring_brackets, rb: record
      r1: integer 3..15
      r2: integer 3..15
      r3: integer 3..15
    recend = ($ring $ring $ring)
  retain_common_block, retain_common_blocks, rcb: (ADVANCED) any of
      key
        all
      keyend
      list of program_name
    anyend = $optional
  ignore_section_names, isn: (ADVANCED) boolean = true
  starting_segment, ss: (ADVANCED) integer 0..4097 = $optional
  output, o: file = $optional
  debug_table, dt: file = $optional
  next_available_segment, nas: (VAR ADVANCED) integer = $optional
  application_identifier, ai: (ADVANCED) name = $optional
  defer_entry_points, dep: (BY_NAME ADVANCED) any of
      key
        all, none
        ($not_retained, $nr)
      keyend
      record
        action: key
          ($defer_all_except, $dae)
        keyend
        entry_points: list rest of program_name
      recend
      list of program_name
    anyend = none
  defer_common_blocks, dcb: (BY_NAME ADVANCED) any of
      key
        all, none
      keyend
      record
        action: key
          ($defer_all_except, $dae)
        keyend
        common_blocks: list rest of program_name
      recend
      list of program_name
    anyend = none
  preset_value, pv: (BY_NAME) key
      (zero z)
      (floating_point_indefinite, fpi)
      (infinity, i)
      (alternate_ones, ao)
    keyend = zero
  status)

  "$FORMAT=OFF
  VAR
    local_status: status
    module_library: file = $unique($local)
    unique2: name = $unique(name)
    linked_module: file = $local//unique2
  VAREND
  "$FORMAT=ON"

  WHEN any_fault DO
    detach_file file=module_library status=local_status
    detach_file file=linked_module status=local_status
    EXIT_PROC WITH osv$status
  WHENEND

  CREATE_OBJECT_LIBRARY
    FOR EACH component IN components DO
      IF $field(component modules initialized) THEN
        add_module library=component.library modules=component.modules
      ELSE
        add_module library=component.library
      IFEND
    FOREND

    generate_library library=module_library
  QUIT
  LINK_VIRTUAL_ENVIRONMENT
    set_link_option mode=product
    set_link_option build_level=$substr($string(name) 1 22)
    set_link_option ignore_section_names=ignore_section_names
    set_link_option starting_segment=starting_segment
    add_object_file file=module_library ring_brackets=ring_brackets
    set_link_option preset_value=preset_value
    set_link_option link_map=output defer_entry_points=defer_entry_points ..
          defer_common_blocks=defer_common_blocks
    IF $specified(retain_common_blocks) THEN
      retain_common_blocks name=$apply(retain_common_blocks $string(x))
    IFEND
    generate_virtual_memory virtual_image=linked_module debug_table=debug_table
    IF $specified(next_available_segment) THEN
      next_available_segment = $next_available_segment
    IFEND
  QUIT

  detach_file file=module_library
  add_module library=linked_module return_file_when_complete=true

" The linker builds the product module with the module name equal to the last path name
" of the file specified for the virtual_image parameter on the GENERATE_VIRTUAL_MEMORY
" command.  The module name must be changed to the name specified on the request.

  change_module_attributes module=unique2 new_name=$string(name) application_identifier=application_identifier

PROCEND ocp$create_linked_module
*DECK DECK=OCM$CREATE_MESSAGE_MODULE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
MODULE ocm$create_message_module;


{ PURPOSE:
{   To create a message module and replace or combine it on the new object library.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_mt_generator
*copyc llt$object_library_header
*copyc loc$task_services_library_name
*copyc oce$library_generator_errors
*copyc oct$display_toggles
*copyc ost$status
?? POP ??
*copyc clp$define_message_module
*copyc clp$evaluate_parameters
*copyc i#current_sequence_position
*copyc ocp$add_an_nlm
*copyc ocp$close_all_open_files
*copyc ocp$create_an_nlm
*copyc ocp$generate_message
*copyc ocp$initialize_olg_working_heap
*copyc ocp$search_nlm_tree
*copyc osp$set_status_abnormal
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_date
*copyc pmp$get_time
*copyc ocv$nlm_list
*copyc ocv$olg_scratch_seq
*copyc ocv$olg_working_heap
*copyc ocv$open_file_list
?? OLDTITLE ??
?? NEWTITLE := 'ocp$_create_message_module' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$_create_message_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$creol_cremm) create_message_module, cremm (
{   name, n: program_name = $required
{   manual, m: program_name = $optional
{   natural_language, nl: any of
{       key
{         us_english, danish, dutch, english, finnish, flemish, french, german,
{         italian, norwegian, portuguese spanish, swedish
{       keyend
{       name
{     anyend = us_english
{   merge_option, mo: key
{       (add, a)
{       (replace, r)
{       (combine, c)
{     keyend = combine
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: 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 .. 13] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        default_value: string (10),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 15, 10, 42, 33, 7],
    clc$command, 9, 5, 1, 0, 0, 0, 5, 'OCM$CREOL_CREMM'], [
    ['M                              ',clc$abbreviation_entry, 2],
    ['MANUAL                         ',clc$nominal_entry, 2],
    ['MERGE_OPTION                   ',clc$nominal_entry, 4],
    ['MO                             ',clc$abbreviation_entry, 4],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NATURAL_LANGUAGE               ',clc$nominal_entry, 3],
    ['NL                             ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 513, clc$optional_default_parameter, 0, 10],
{ PARAMETER 4
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$program_name_type]],
{ PARAMETER 2
    [[1, 0, clc$program_name_type]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    488, [[1, 0, clc$keyword_type], [13], [
      ['DANISH                         ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['DUTCH                          ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['ENGLISH                        ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['FINNISH                        ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
      ['FLEMISH                        ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
      ['FRENCH                         ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
      ['GERMAN                         ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
      ['ITALIAN                        ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
      ['NORWEGIAN                      ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
      ['PORTUGUESE                     ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
      ['SPANISH                        ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
      ['SWEDISH                        ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
      ['US_ENGLISH                     ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'us_english'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [6], [
    ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['ADD                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['COMBINE                        ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['R                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['REPLACE                        ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'combine'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$manual = 2,
      p$natural_language = 3,
      p$merge_option = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    VAR

      time: ost$time,
      date: ost$date,
      ignore_status: ost$status,
      module_already_exists: boolean,

      nlm: ^oct$new_library_module_list,
      module_description: ^oct$module_description,

      sequence: ^SEQ ( * ),
      size: ost$segment_length,
      member_size: ost$segment_length,
      member: ^SEQ ( * ),

      module_name: pmt$program_name,
      natural_language: ost$natural_language,
      online_manual_name: ost$online_manual_name,
      work_area: ^SEQ ( * ),
      message_module: ^ost$message_template_module,

      temporary_module_header: llt$library_member_header,
      message_module_header: ^llt$library_member_header;

    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler;

    status.normal := TRUE;
    RESET ocv$olg_scratch_seq;

    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_time (osc$hms_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_date (osc$mdy_date, date, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    module_name := pvt [p$name].value^.program_name_value;

    IF pvt [p$natural_language].specified THEN
      IF pvt [p$natural_language].value^.kind = clc$keyword THEN
        natural_language := pvt [p$natural_language].value^.keyword_value;
      ELSE { name
        natural_language := pvt [p$natural_language].value^.name_value;
      IFEND;
    ELSE
      natural_language := osc$default_natural_language;
    IFEND;

    IF pvt [p$manual].specified THEN
      online_manual_name := pvt [p$manual].value^.program_name_value;
    ELSE
      online_manual_name := osc$null_name;
    IFEND;

    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /protect/
    BEGIN
      RESET ocv$olg_scratch_seq;
      NEXT work_area: [[REP (#SIZE (ocv$olg_scratch_seq^)) OF cell]] IN ocv$olg_scratch_seq;

      clp$define_message_module (module_name, natural_language, online_manual_name, work_area, message_module,
            status);

      IF NOT status.normal THEN
        IF status.condition <> cle$errors_in_module THEN
          EXIT /protect/;
        IFEND;
      IFEND;

      IF message_module = NIL THEN
        EXIT /protect/;
      IFEND;

      RESET ocv$olg_scratch_seq;

      NEXT message_module_header IN ocv$olg_scratch_seq;
      IF message_module_header = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_internal_olg_seg_overflow, '', status);
        RETURN;
      IFEND;

      temporary_module_header.name := module_name;
      temporary_module_header.kind := llc$message_module;
      temporary_module_header.time_created := time;
      temporary_module_header.date_created := date;
      temporary_module_header.generator_id := llc$object_library_generator;
      temporary_module_header.generator_name_vers := occ$generator_name CAT llc$object_library_version;
      temporary_module_header.commentary := osc$null_name;
      temporary_module_header.number_of_aliases := 0;

      ALLOCATE module_description IN ocv$olg_working_heap^;
      IF module_description = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_internal_olg_seg_overflow, '', status);
        RETURN;
      IFEND;

      module_description^.name := temporary_module_header.name;
      module_description^.source := occ$current;
      module_description^.kind := occ$message_module;

      ocp$search_nlm_tree (temporary_module_header.name, nlm, module_already_exists);

{ Check for error conditions.

      CASE pvt [p$merge_option].value^.keyword_value (1) OF
      = 'A' =
        IF module_already_exists THEN
          osp$set_status_abnormal ('OC', oce$e_module_already_on_library, temporary_module_header.name,
                status);
          EXIT /protect/;
        IFEND;
      = 'R' =
        IF NOT module_already_exists THEN
          osp$set_status_abnormal ('OC', oce$e_module_not_found, temporary_module_header.name, status);
          EXIT /protect/;
        IFEND;
      ELSE
      CASEND;

{ Replace the module if it exists already; add it if it doesn't.

      IF module_already_exists THEN
        nlm^.description := module_description;
        nlm^.changed_info := NIL;
      ELSE
        ocp$create_an_nlm (module_description, nlm, status);
        IF NOT status.normal THEN
          EXIT /protect/;
        IFEND;
        ocp$add_an_nlm (ocv$nlm_list^.b_link, nlm);
      IFEND;
      RESET message_module;
      member_size := #SIZE (message_module^);
      NEXT sequence: [[REP member_size OF cell]] IN ocv$olg_scratch_seq;

      size := i#current_sequence_position (ocv$olg_scratch_seq);

      ALLOCATE module_description^.file: [[REP size OF cell]] IN ocv$olg_working_heap^;
      IF module_description^.file = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_internal_olg_seg_overflow, '', status);
        RETURN;
      IFEND;

      RESET module_description^.file;
      NEXT module_description^.message_module_header IN module_description^.file;
      module_description^.message_module_header^ := temporary_module_header;
      NEXT member: [[REP member_size OF cell]] IN module_description^.file;
      member^ := message_module^;

      module_description^.message_module_header^.member := #REL (member, module_description^.file^);
      module_description^.message_module_header^.member_size := member_size;
    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);


  PROCEND ocp$_create_message_module;

MODEND ocm$create_message_module;
*DECK DECK=OCM$CREATE_MODULE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
MODULE ocm$create_module;



{ PURPOSE:
{   To create a single load module from the
{   specified component object or load modules.

?? NEWTITLE := 'Global Declarations Referenced by This Module', ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_expression_result
*copyc llt$object_library_header
*copyc occ$retain
*copyc oce$library_generator_errors
*copyc oct$component_list
*copyc oct$display_toggles
*copyc oct$header
*copyc oct$open_file_list
*copyc ost$status
?? POP ??
*copyc avp$get_capability
*copyc clp$convert_string_to_file
*copyc clp$evaluate_parameters
*copyc ocp$add_an_nlm
*copyc ocp$close_all_open_files
*copyc ocp$generate_message
*copyc ocp$initialize_olg_working_heap
*copyc ocp$obtain_header
*copyc ocp$obtain_library_list
*copyc ocp$obtain_object_file
*copyc ocp$obtain_xdcl_list
*copyc ocp$obtain_xref_list
*copyc ocp$search_nlm_tree
*copyc ocp$search_object_file
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_legible_date_time
*copyc ocv$nlm_list
*copyc ocv$olg_scratch_seq
*copyc ocv$olg_working_heap
*copyc ocv$open_file_list
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    object_type_checking: [STATIC, READ] string (6) := 'OBJECT';

?? OLDTITLE ??
?? NEWTITLE := 'get_xdcl', EJECT ??

  PROCEDURE get_xdcl
    (    name: pmt$program_name;
         sorted_xdcl_list: oct$sorted_xdcl_list;
         number_of_xdcls: llt$entry_point_index;
     VAR xdcl_found: boolean;
     VAR external_declaration: ^oct$external_declaration_list);

    VAR
      temp: integer,
      hi: llt$entry_point_index,
      lo: llt$entry_point_index,
      mid: llt$entry_point_index;


    xdcl_found := FALSE;
    hi := number_of_xdcls;
    lo := 1;

    WHILE (lo <= hi) AND NOT xdcl_found DO
      temp := lo + hi;
      mid := temp DIV 2;
      IF name = sorted_xdcl_list^ [mid]^.name THEN
        xdcl_found := TRUE;
        external_declaration := sorted_xdcl_list^ [mid];
      ELSEIF name < sorted_xdcl_list^ [mid]^.name THEN
        hi := mid - 1;
      ELSE
        lo := mid + 1;
      IFEND;
    WHILEND;

  PROCEND get_xdcl;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_sorted_xdcl_list' ??
?? EJECT ??

  PROCEDURE add_to_sorted_xdcl_list
    (    last_modules_xdcl: ^oct$external_declaration_list;
     VAR sorted_xdcl_list: oct$sorted_xdcl_list;
     VAR sorted_xdcl_list_size: llt$entry_point_index;
     VAR number_of_xdcls: llt$entry_point_index;
     VAR status: ost$status);


{ The size of the sorted_xdcl_list will start out at 3000 and increase in increments of
{ 3000 if necessary.  3000 was chosen because it should be enough most of the time.  It
{ seems more efficient to allocate extra space that isn't used in the smaller cases than
{ to choose a smaller number and reallocate the space over and over for the larger cases.

    CONST
      xdcl_list_increment = 3000;

    VAR
      temp: integer,
      found: boolean,
      hi: llt$entry_point_index,
      i: llt$entry_point_index,
      lo: llt$entry_point_index,
      mid: llt$entry_point_index,
      old_xdcl_list: oct$sorted_xdcl_list;

    status.normal := TRUE;

    IF number_of_xdcls = sorted_xdcl_list_size THEN
      old_xdcl_list := sorted_xdcl_list;

      NEXT sorted_xdcl_list: [1 .. (sorted_xdcl_list_size + xdcl_list_increment)] IN ocv$olg_scratch_seq;
      IF sorted_xdcl_list = NIL THEN
        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
        RETURN;
      IFEND;

      FOR i := 1 TO sorted_xdcl_list_size DO
        sorted_xdcl_list^ [i] := old_xdcl_list^ [i];
      FOREND;

      sorted_xdcl_list_size := sorted_xdcl_list_size + xdcl_list_increment;
    IFEND;

    found := FALSE;
    hi := number_of_xdcls;
    lo := 1;

    WHILE (lo <= hi) AND NOT found DO
      temp := lo + hi;
      mid := temp DIV 2;
      IF last_modules_xdcl^.name = sorted_xdcl_list^ [mid]^.name THEN
        found := TRUE;
      ELSEIF last_modules_xdcl^.name < sorted_xdcl_list^ [mid]^.name THEN
        hi := mid - 1;
      ELSE
        lo := mid + 1;
      IFEND;
    WHILEND;

    IF found THEN
      osp$set_status_abnormal (oc, oce$e_xdcl_already_exists, last_modules_xdcl^.name, status);
      RETURN;
    IFEND;

    number_of_xdcls := number_of_xdcls + 1;

    FOR i := (number_of_xdcls - 1) DOWNTO lo DO
      sorted_xdcl_list^ [i + 1] := sorted_xdcl_list^ [i];
    FOREND;

    sorted_xdcl_list^ [lo] := last_modules_xdcl;

  PROCEND add_to_sorted_xdcl_list;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_sorted_xref_list' ??
?? EJECT ??

  PROCEDURE add_to_sorted_xref_list
    (    last_modules_xref: ^oct$external_reference_list;
     VAR sorted_xref_list: oct$sorted_xref_list;
     VAR sorted_xref_list_size: 0 .. llc$max_ext_items;
     VAR number_of_xrefs: 0 .. llc$max_ext_items;
     VAR xref_found: boolean;
     VAR status: ost$status);


{ The size of the sorted_xref_list will start out at 3000 and increase in increments of
{ 3000 if necessary.  3000 was chosen because it should be enough most of the time.  It
{ seems more efficient to allocate extra space that isn't used in the smaller cases than
{ to choose a smaller number and reallocate the space over and over for the larger cases.

    CONST
      xref_list_increment = 3000;

    VAR
      temp: integer,
      hi: 0 .. llc$max_ext_items,
      i: 0 .. llc$max_ext_items,
      lo: 0 .. llc$max_ext_items,
      mid: 0 .. llc$max_ext_items,
      old_xref_list: oct$sorted_xref_list;

    status.normal := TRUE;

    xref_found := FALSE;

    IF number_of_xrefs = sorted_xref_list_size THEN
      old_xref_list := sorted_xref_list;

      NEXT sorted_xref_list: [1 .. (sorted_xref_list_size + xref_list_increment)] IN ocv$olg_scratch_seq;
      IF sorted_xref_list = NIL THEN
        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
        RETURN;
      IFEND;

      FOR i := 1 TO sorted_xref_list_size DO
        sorted_xref_list^ [i] := old_xref_list^ [i];
      FOREND;

      sorted_xref_list_size := sorted_xref_list_size + xref_list_increment;
    IFEND;

    hi := number_of_xrefs;
    lo := 1;

    WHILE (lo <= hi) AND NOT xref_found DO
      temp := lo + hi;
      mid := temp DIV 2;
      IF last_modules_xref^.name = sorted_xref_list^ [mid]^.name THEN
        xref_found := TRUE;
      ELSEIF last_modules_xref^.name < sorted_xref_list^ [mid]^.name THEN
        hi := mid - 1;
      ELSE
        lo := mid + 1;
      IFEND;
    WHILEND;

    IF NOT xref_found THEN
      number_of_xrefs := number_of_xrefs + 1;

      FOR i := (number_of_xrefs - 1) DOWNTO lo DO
        sorted_xref_list^ [i + 1] := sorted_xref_list^ [i];
      FOREND;

      sorted_xref_list^ [lo] := last_modules_xref;
    IFEND;

  PROCEND add_to_sorted_xref_list;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_component_list' ??
?? EJECT ??

  PROCEDURE add_to_component_list
    (    first_module: pmt$program_name;
         last_module: pmt$program_name;
         xdcl_list: ^oct$external_declaration_list;
     VAR file_descriptor: ^oct$open_file_list;
     VAR last_xdcl: ^oct$external_declaration_list;
     VAR sorted_xdcl_list: oct$sorted_xdcl_list;
     VAR sorted_xdcl_list_size: llt$entry_point_index;
     VAR number_of_xdcls: llt$entry_point_index;
     VAR sorted_xref_list: oct$sorted_xref_list;
     VAR sorted_xref_list_size: 0 .. llc$max_ext_items;
     VAR number_of_xrefs: 0 .. llc$max_ext_items;
     VAR identification: llt$identification;
     VAR starting_procedure: pmt$program_name;
     VAR xref_list: oct$external_reference_list;
     VAR library_list: oct$name_list;
     VAR last_component: ^oct$component_list;
     VAR number_of_components: integer;
     VAR object_type_checking_found: boolean;
     VAR status: ost$status);




    VAR
      current_module: pmt$program_name,
      deferred_entry_point_list: oct$external_declaration_list,
      header: oct$header,
      last_library: ^oct$name_list,
      last_modules_xdcl: ^oct$external_declaration_list,
      last_xref: ^oct$external_reference_list,
      module_found: boolean,
      modules_last_library: ^oct$name_list,
      modules_last_xref: ^oct$external_reference_list,
      modules_library_list: oct$name_list,
      modules_xdcl_list: oct$external_declaration_list,
      modules_xref_list: oct$external_reference_list,
      start_proc: pmt$program_name,
      xdcl_found: boolean,
      xref_found: boolean;


    status.normal := TRUE;

    file_descriptor^.current_module := 1;

    ocp$search_object_file (first_module, module_found, file_descriptor);
    IF NOT module_found THEN
      osp$set_status_abnormal (oc, oce$e_module_not_found, first_module, status);
      RETURN;
    IFEND;

    REPEAT
      IF file_descriptor^.current_module > UPPERBOUND (file_descriptor^.directory^) THEN
        osp$set_status_abnormal (oc, oce$e_module_not_found, last_module, status);
        RETURN;
      IFEND;

      current_module := file_descriptor^.directory^ [file_descriptor^.current_module].name;
      number_of_components := number_of_components + 1;

      NEXT last_component^.link IN ocv$olg_scratch_seq;
      last_component := last_component^.link;
      IF last_component = NIL THEN
        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
        RETURN;
      IFEND;

      last_component^.link := NIL;
      last_component^.module_description := ^file_descriptor^.directory^ [file_descriptor^.current_module];

      IF (last_component^.module_description^.kind <> occ$cpu_object_module) AND
            (last_component^.module_description^.kind <> occ$load_module) THEN
        osp$set_status_abnormal (oc, oce$e_invalid_module_kind, last_component^.module_description^.name,
              status);
        RETURN;
      IFEND;

      ocp$obtain_header (last_component^.module_description^, NIL, header, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF llc$nonbindable IN header.identification.attributes THEN
        osp$set_status_abnormal (oc, oce$e_module_not_bindable, last_component^.module_description^.name,
              status);
        RETURN;
      IFEND;

      IF llc$object_cybil_checking IN header.identification.attributes THEN
        object_type_checking_found := TRUE;
      IFEND;

      IF header.identification.kind = llc$vector_virtual_state THEN
        identification.kind := llc$vector_virtual_state;
      ELSEIF header.identification.kind = llc$vector_extended_state THEN
        identification.kind := llc$vector_extended_state;
      IFEND;

      ocp$obtain_library_list (last_component^.module_description^, NIL, modules_library_list, occ$retain,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      ocp$obtain_xdcl_list ({changed_info} NIL, occ$retain, {obtain_deferred_entry_points} FALSE,
            last_component^.module_description^, modules_xdcl_list, start_proc, deferred_entry_point_list,
            status);
      IF start_proc <> osc$null_name THEN
        starting_procedure := start_proc;
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      ocp$obtain_xref_list (last_component^.module_description^, modules_xref_list, occ$retain, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      last_modules_xdcl := modules_xdcl_list.link;

      WHILE last_modules_xdcl <> NIL DO
        add_to_sorted_xdcl_list (last_modules_xdcl, sorted_xdcl_list, sorted_xdcl_list_size, number_of_xdcls,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        last_xdcl^.link := last_modules_xdcl;
        last_modules_xdcl := last_modules_xdcl^.link;
        last_xdcl^.link^.link := NIL;
        last_xdcl := last_xdcl^.link;
      WHILEND;

      last_xref := ^xref_list;
      WHILE (last_xref^.link <> NIL) DO
        last_xref := last_xref^.link;
      WHILEND;

      modules_last_xref := modules_xref_list.link;
      WHILE modules_last_xref <> NIL DO
        add_to_sorted_xref_list (modules_last_xref, sorted_xref_list, sorted_xref_list_size, number_of_xrefs,
              xref_found, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF NOT xref_found THEN
          last_xref^.link := modules_last_xref;
          modules_last_xref := modules_last_xref^.link;
          last_xref := last_xref^.link;
          last_xref^.link := NIL;
        ELSE
          modules_last_xref := modules_last_xref^.link;
        IFEND;
      WHILEND;


      modules_last_library := modules_library_list.link;
      WHILE modules_last_library <> NIL DO
        last_library := ^library_list;
        WHILE (last_library^.link <> NIL) AND (last_library^.link^.name <> modules_last_library^.name) DO
          last_library := last_library^.link;
        WHILEND;

        IF last_library^.link = NIL THEN
          last_library^.link := modules_last_library;
          modules_last_library := modules_last_library^.link;
          last_library^.link^.link := NIL;
        ELSE
          modules_last_library := modules_last_library^.link;
        IFEND;
      WHILEND;

      file_descriptor^.current_module := file_descriptor^.current_module + 1;

    UNTIL current_module = last_module;

  PROCEND add_to_component_list;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$_create_module' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$_create_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$creol_crem) create_module, crem (
{   name, n: program_name = $required
{   component, components, c: list of record
{       library: file
{       modules: list rest of any of
{         program_name
{         range of program_name
{       anyend = $optional
{     recend = $required
{   gate, gates, g: (BY_NAME) any of
{       key
{         all
{       keyend
{       list of program_name
{     anyend = $optional
{   retain, r: (BY_NAME) any of
{       key
{         all
{       keyend
{       list of program_name
{     anyend = $optional
{   starting_procedure, sp: (BY_NAME) program_name = $optional
{   preset_value, pv: (BY_NAME) key
{       (zero, z)
{       (floating_point_indefinite, fpi)
{       (infinity, i)
{       (alternate_ones, ao)
{     keyend = $optional
{   include_binary_section_maps, ibsm: (BY_NAME) boolean = $optional
{   output, o: (BY_NAME) file = $optional
{   application_identifier, ai: (BY_NAME, ADVANCED) name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 21] of clt$pdt_parameter_name,
      parameters: array [1 .. 10] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$list_type_qualifier,
            element_type_spec: 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,
              recend,
              type_size_2: clt$type_specification_size,
              element_type_spec_2: record
                header: clt$type_specification_header,
                qualifier: clt$range_type_qualifier,
                element_type_spec: record
                  header: clt$type_specification_header,
                recend,
              recend,
            recend,
          recend,
        recend,
      recend,
      type3: 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,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type4: 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,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 20, 11, 41, 40, 588],
    clc$command, 21, 10, 2, 1, 0, 0, 10, 'OCM$CREOL_CREM'], [
    ['AI                             ',clc$abbreviation_entry, 9],
    ['APPLICATION_IDENTIFIER         ',clc$nominal_entry, 9],
    ['C                              ',clc$abbreviation_entry, 2],
    ['COMPONENT                      ',clc$nominal_entry, 2],
    ['COMPONENTS                     ',clc$alias_entry, 2],
    ['G                              ',clc$abbreviation_entry, 3],
    ['GATE                           ',clc$nominal_entry, 3],
    ['GATES                          ',clc$alias_entry, 3],
    ['IBSM                           ',clc$abbreviation_entry, 7],
    ['INCLUDE_BINARY_SECTION_MAPS    ',clc$nominal_entry, 7],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 8],
    ['OUTPUT                         ',clc$nominal_entry, 8],
    ['PRESET_VALUE                   ',clc$nominal_entry, 6],
    ['PV                             ',clc$abbreviation_entry, 6],
    ['R                              ',clc$abbreviation_entry, 4],
    ['RETAIN                         ',clc$nominal_entry, 4],
    ['SP                             ',clc$abbreviation_entry, 5],
    ['STARTING_PROCEDURE             ',clc$nominal_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 10]],
    [
{ PARAMETER 1
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 147,
  clc$required_parameter, 0, 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 83, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 83, clc$optional_parameter,
  0, 0],
{ PARAMETER 5
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 6
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 8
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 9
    [2, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 10
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$program_name_type]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [131, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$record_type], [2],
      ['LIBRARY                        ', clc$required_field, 3], [[1, 0, clc$file_type]],
      ['MODULES                        ', clc$optional_field, 49], [[1, 0, clc$list_type], [33, 0,
  clc$max_list_size, TRUE],
          [[1, 0, clc$union_type], [[clc$program_name_type, clc$range_type],
          FALSE, 2],
          3, [[1, 0, clc$program_name_type]],
          10, [[1, 0, clc$range_type], [3],
              [[1, 0, clc$program_name_type]]
            ]
          ]
        ]
      ]
    ],
{ PARAMETER 3
    [[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]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$program_name_type]]
      ]
    ],
{ PARAMETER 4
    [[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]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$program_name_type]]
      ]
    ],
{ PARAMETER 5
    [[1, 0, clc$program_name_type]],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [8], [
    ['ALTERNATE_ONES                 ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['AO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['FLOATING_POINT_INDEFINITE      ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['FPI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['INFINITY                       ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['Z                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ZERO                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 7
    [[1, 0, clc$boolean_type]],
{ PARAMETER 8
    [[1, 0, clc$file_type]],
{ PARAMETER 9
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 10
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$component = 2,
      p$gate = 3,
      p$retain = 4,
      p$starting_procedure = 5,
      p$preset_value = 6,
      p$include_binary_section_maps = 7,
      p$output = 8,
      p$application_identifier = 9,
      p$status = 10;

    VAR
      pvt: array [1 .. 10] of clt$parameter_value;

{ These constants define the field numbers in the component record.

    CONST
      p$library = 1,
      p$modules = 2;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    VAR
      date: ost$date,

?? FMT (FORMAT := OFF) ??

      module_header_template: [STATIC] llt$identification :=
            [*,                                                          {name}
             llc$object_text_version,                                    {object_text_version}
             llc$mi_virtual_state,                                       {kind}
             [osc$hms_time, *],                                          {time_created}
             [osc$mdy_date, *],                                          {date_created}
             *,                                                          {attributes}
             0,                                                          {greatest_section_ordinal}
             llc$object_library_generator,                               {generator_id}
             'OBJECT LIBRARY GENERATOR ' CAT llc$object_library_version, {generator_name_vers}
             osc$null_name],                                             {commentary}

?? FMT (FORMAT := ON) ??
      time: ost$time;

    VAR
      application_administrator: boolean,
      component_list: oct$component_list,
      component_number: 0 .. llc$max_components,
      external_declaration: ^oct$external_declaration_list,
      file_descriptor: ^oct$open_file_list,
      first_module: pmt$program_name,
      ignore_status: ost$status,
      last_component: ^oct$component_list,
      last_module: pmt$program_name,
      last_xdcl: ^oct$external_declaration_list,
      library_list: oct$name_list,
      module_already_exists: boolean,
      module_node: ^clt$data_value,
      nlm: ^oct$new_library_module_list,
      node: ^clt$data_value,
      number_of_components: integer,
      number_of_xdcls: llt$entry_point_index,
      number_of_xrefs: 0 .. llc$max_ext_items,
      object_type_checking_found: boolean,
      program_name: pmt$program_name,
      section_map_file: clt$file,
      sorted_xdcl_list: oct$sorted_xdcl_list,
      sorted_xdcl_list_size: llt$entry_point_index,
      sorted_xref_list: oct$sorted_xref_list,
      sorted_xref_list_size: 0 .. llc$max_ext_items,
      xdcl_found: boolean,
      xdcl_list: oct$external_declaration_list;

    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler;

    status.normal := TRUE;
    RESET ocv$olg_scratch_seq;

    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    module_header_template.time_created.hms := time.hms;
    module_header_template.date_created.mdy := date.mdy;

    program_name := pvt [p$name].value^.program_name_value;

    ocp$search_nlm_tree (program_name, nlm, module_already_exists);
    IF module_already_exists THEN
      osp$set_status_abnormal (oc, oce$e_module_already_on_library, program_name, status);
      RETURN;
    IFEND;

    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);

  /protect/
    BEGIN
      ALLOCATE nlm IN ocv$olg_working_heap^;
      IF nlm = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      nlm^.name := program_name;
      module_header_template.name := nlm^.name;


      ALLOCATE nlm^.changed_info IN ocv$olg_working_heap^;
      IF nlm^.changed_info = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        FREE nlm IN ocv$olg_working_heap^;
        RETURN;
      IFEND;

      nlm^.changed_info^.name := NIL;
      nlm^.changed_info^.commentary := NIL;
      nlm^.changed_info^.entry_points := NIL;
      nlm^.changed_info^.starting_procedure := osc$null_name;
      nlm^.changed_info^.new_libraries := TRUE;
      nlm^.changed_info^.library_list := NIL;
      nlm^.changed_info^.debug_tables_to_omit := $oct$debug_tables [];
      nlm^.changed_info^.application_identifier := NIL;
      nlm^.changed_info^.cybil_parameter_checking := '      ';

      object_type_checking_found := FALSE;

      ALLOCATE nlm^.description IN ocv$olg_working_heap^;
      IF nlm^.description = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        FREE nlm^.changed_info IN ocv$olg_working_heap^;
        FREE nlm IN ocv$olg_working_heap^;
        RETURN;
      IFEND;

      nlm^.description^.name := program_name;
      nlm^.description^.source := occ$current;
      nlm^.description^.file := NIL;
      nlm^.description^.kind := occ$bound_module;

      ALLOCATE nlm^.description^.bound_module_header IN ocv$olg_working_heap^;
      IF nlm^.description^.bound_module_header = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        FREE nlm^.changed_info IN ocv$olg_working_heap^;
        FREE nlm^.description IN ocv$olg_working_heap^;
        FREE nlm IN ocv$olg_working_heap^;
        RETURN;
      IFEND;

      nlm^.description^.bound_module_header^.identification := module_header_template;
      nlm^.description^.bound_module_header^.xref_list.link := NIL;
      nlm^.description^.bound_module_header^.components := NIL;
      nlm^.description^.bound_module_header^.code_section_ids.link := NIL;
      nlm^.description^.bound_module_header^.preset_specified := FALSE;
      nlm^.description^.bound_module_header^.preset_value := pmc$initialize_to_zero;
      nlm^.description^.bound_module_header^.include_binary_section_maps := FALSE;

      nlm^.f_link := NIL;
      nlm^.b_link := NIL;
      nlm^.r_link := NIL;
      nlm^.l_link := NIL;
      nlm^.t_link := NIL;

      component_list.link := NIL;
      number_of_components := 0;

      xdcl_list.link := NIL;
      last_xdcl := ^xdcl_list;

      sorted_xdcl_list := NIL;
      sorted_xdcl_list_size := 0;
      number_of_xdcls := 0;

      sorted_xref_list := NIL;
      sorted_xref_list_size := 0;
      number_of_xrefs := 0;

      last_component := ^component_list;
      library_list.link := NIL;

    /valid_data_processing/
      BEGIN
        node := pvt [p$component].value;
        WHILE node <> NIL DO
          ocp$obtain_object_file (node^.element_value^.field_values^ [p$library].value^.file_value^,
                file_descriptor, status);
          IF NOT status.normal THEN
            EXIT /valid_data_processing/;
          IFEND;
          IF node^.element_value^.field_values^ [p$modules].value = NIL THEN

{ The modules field of the record was omitted. Use all the modules on the file.

            first_module := file_descriptor^.directory^ [1].name;
            last_module := file_descriptor^.directory^ [UPPERBOUND (file_descriptor^.directory^)].name;
            add_to_component_list (first_module, last_module, ^xdcl_list, file_descriptor, last_xdcl,
                  sorted_xdcl_list, sorted_xdcl_list_size, number_of_xdcls, sorted_xref_list,
                  sorted_xref_list_size, number_of_xrefs, nlm^.description^.bound_module_header^.
                  identification, nlm^.changed_info^.starting_procedure,
                  nlm^.description^.bound_module_header^.xref_list, library_list, last_component,
                  number_of_components, object_type_checking_found, status);
            IF NOT status.normal THEN
              EXIT /valid_data_processing/;
            IFEND;
          ELSE
            module_node := node^.element_value^.field_values^ [p$modules].value;
            WHILE (module_node <> NIL) AND (module_node^.element_value <> NIL) DO

{ Check whether a program_name or range of program_name was specified.

              IF module_node^.element_value^.kind = clc$program_name THEN
                first_module := module_node^.element_value^.program_name_value;
                last_module := first_module;
              ELSE
                first_module := module_node^.element_value^.low_value^.program_name_value;
                last_module := module_node^.element_value^.high_value^.program_name_value;
              IFEND;
              add_to_component_list (first_module, last_module, ^xdcl_list, file_descriptor, last_xdcl,
                    sorted_xdcl_list, sorted_xdcl_list_size, number_of_xdcls, sorted_xref_list,
                    sorted_xref_list_size, number_of_xrefs, nlm^.description^.bound_module_header^.
                    identification, nlm^.changed_info^.starting_procedure,
                    nlm^.description^.bound_module_header^.xref_list, library_list, last_component,
                    number_of_components, object_type_checking_found, status);
              IF NOT status.normal THEN
                EXIT /valid_data_processing/;
              IFEND;
              module_node := module_node^.link;
            WHILEND;
          IFEND;
          IF object_type_checking_found THEN
            nlm^.changed_info^.cybil_parameter_checking := object_type_checking;
          IFEND;
          node := node^.link;
        WHILEND;

        IF pvt [p$gate].specified THEN
          IF pvt [p$gate].value^.kind = clc$keyword THEN

{ Gate all externals.

            last_xdcl := xdcl_list.link;
            WHILE last_xdcl <> NIL DO
              last_xdcl^.attributes := last_xdcl^.attributes +
                    $llt$entry_point_attributes [llc$gated_entry_point];
              last_xdcl := last_xdcl^.link;
            WHILEND;
          ELSE
            node := pvt [p$gate].value;
            WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
              get_xdcl (node^.element_value^.program_name_value, sorted_xdcl_list, number_of_xdcls,
                    xdcl_found, external_declaration);
              IF NOT xdcl_found THEN
                osp$set_status_abnormal (oc, oce$e_xdcl_doesnt_exist, node^.element_value^.program_name_value,
                      status);
                EXIT /valid_data_processing/;
              IFEND;

              external_declaration^.attributes := external_declaration^.attributes +
                    $llt$entry_point_attributes [llc$gated_entry_point];
              node := node^.link;
            WHILEND;
          IFEND;
        IFEND;
        IF pvt [p$retain].specified THEN
          IF pvt [p$retain].value^.kind = clc$keyword THEN

{ Retain all externals.

            last_xdcl := xdcl_list.link;
            WHILE last_xdcl <> NIL DO
              last_xdcl^.attributes := last_xdcl^.attributes +
                    $llt$entry_point_attributes [llc$retain_entry_point];
              last_xdcl := last_xdcl^.link;
            WHILEND;
          ELSE
            node := pvt [p$retain].value;
            WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
              get_xdcl (node^.element_value^.program_name_value, sorted_xdcl_list, number_of_xdcls,
                    xdcl_found, external_declaration);
              IF NOT xdcl_found THEN
                osp$set_status_abnormal (oc, oce$e_xdcl_doesnt_exist, node^.element_value^.program_name_value,
                      status);
                EXIT /valid_data_processing/;
              IFEND;

              external_declaration^.attributes := external_declaration^.attributes +
                    $llt$entry_point_attributes [llc$retain_entry_point];
              node := node^.link;
            WHILEND;
          IFEND;
        IFEND;

        IF pvt [p$starting_procedure].specified THEN
          get_xdcl (pvt [p$starting_procedure].value^.program_name_value, sorted_xdcl_list, number_of_xdcls,
                xdcl_found, external_declaration);
          IF NOT xdcl_found THEN
            osp$set_status_abnormal (oc, oce$e_xdcl_doesnt_exist,
                  pvt [p$starting_procedure].value^.program_name_value, status);
            EXIT /valid_data_processing/;
          IFEND;
          nlm^.changed_info^.starting_procedure := pvt [p$starting_procedure].value^.program_name_value;
        IFEND;


        nlm^.description^.bound_module_header^.preset_specified := pvt [p$preset_value].specified;
        IF pvt [p$preset_value].specified THEN
          IF pvt [p$preset_value].value^.keyword_value = 'ZERO' THEN
            nlm^.description^.bound_module_header^.preset_value := pmc$initialize_to_zero;
          ELSEIF pvt [p$preset_value].value^.keyword_value = 'FLOATING_POINT_INDEFINITE' THEN
            nlm^.description^.bound_module_header^.preset_value := pmc$initialize_to_indefinite;
          ELSEIF pvt [p$preset_value].value^.keyword_value = 'INFINITY' THEN
            nlm^.description^.bound_module_header^.preset_value := pmc$initialize_to_infinity;
          ELSE {IF pvt [p$preset_value].value^.keyword_value = 'ALTERNATE_ONES' THEN
            nlm^.description^.bound_module_header^.preset_value := pmc$initialize_to_alt_ones;
          IFEND;
        ELSE
          nlm^.description^.bound_module_header^.preset_value := pmc$initialize_to_zero;
        IFEND;

        IF pvt [p$include_binary_section_maps].specified THEN
          nlm^.description^.bound_module_header^.include_binary_section_maps :=
                pvt [p$include_binary_section_maps].value^.boolean_value.value;
        IFEND;

        IF pvt [p$output].specified THEN
          clp$convert_string_to_file (pvt [p$output].value^.file_value^, section_map_file, status);
          IF NOT status.normal THEN
            EXIT /valid_data_processing/;
          IFEND;
          nlm^.description^.bound_module_header^.section_map.local_file_name :=
                section_map_file.local_file_name;
        ELSE
          nlm^.description^.bound_module_header^.section_map.local_file_name := osc$null_name;
        IFEND;

        IF pvt [p$application_identifier].specified THEN

          avp$get_capability (avc$application_administration, avc$user, application_administrator, status);
          IF NOT status.normal THEN
            EXIT /valid_data_processing/;
          IFEND;
          IF NOT application_administrator THEN
            osp$set_status_condition (oce$not_application_administrtr, status);
            EXIT /valid_data_processing/;
          IFEND;

          ALLOCATE nlm^.changed_info^.application_identifier IN ocv$olg_working_heap^;
          nlm^.changed_info^.application_identifier^.name := pvt [p$application_identifier].value^.name_value;
        IFEND;


        nlm^.changed_info^.entry_points := xdcl_list.link;
        nlm^.changed_info^.library_list := library_list.link;

        IF number_of_components >= llc$max_components THEN
          osp$set_status_condition (oce$e_too_many_components, status);
          EXIT /valid_data_processing/;
        IFEND;

        last_component := component_list.link;

        ALLOCATE nlm^.description^.bound_module_header^.components: [1 .. number_of_components] IN
              ocv$olg_working_heap^;
        IF nlm^.description^.bound_module_header^.components = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        FOR component_number := 1 TO number_of_components DO
          nlm^.description^.bound_module_header^.components^ [component_number] :=
                last_component^.module_description;
          last_component := last_component^.link;
          component_list.link := last_component;
        FOREND;



        ocp$add_an_nlm (ocv$nlm_list^.b_link, nlm);

        EXIT /protect/; { Normal return is from here.

      END /valid_data_processing/;



      FREE nlm IN ocv$olg_working_heap^;
    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);

  PROCEND ocp$_create_module;

MODEND ocm$create_module;

*DECK DECK=OCM$CREATE_OBJECT_LIBRARY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
MODULE ocm$create_object_library;

{ PURPOSE:
{   To initiate execution of the object
{   library generation command.
{ DESIGN:
{   The CREATE_OBJECT_LIBRARY utility is initiated in this module.
{   The real work is done by the procedures called to process the subcommands.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc cyd$run_time_error_condition
*copyc oce$library_generator_errors
*copyc oct$return_file_list
*copyc ost$status
?? POP ??
*copyc clp$begin_utility
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc ocp$initialize_oc_environment
*copyc ocp$close_all_open_files
*copyc ocp$return_files
*copyc ocv$nlm_list
*copyc ocv$open_file_list
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    command_file: amt$local_file_name := clc$current_command_input,
    ocv$return_file_list: [XDCL, STATIC] ^oct$return_file_list := NIL,
    utility_name: string (31) := 'CREATE_OBJECT_LIBRARY          ',
    utility_attributes: array [1 .. 3] of clt$utility_attribute :=
          [[clc$utility_command_table, * ], [clc$utility_function_proc_table, * ], [clc$utility_prompt, [3,
          'COL']]];

{ table command_table type=command scope=local
{ command (add_module                     ,add_modules,  addm)          ..
{   ocp$_add_module call_method=xref
{ command (bind_module                    ,binm) ocp$_bind_module          ..
{   call_method=xref
{ command (change_command_description     ,change_command_descriptions,    ..
{       chacd) ocp$_change_command_description call_method=xref
{ command (change_function_description    ,change_function_descriptions,   ..
{       chafd) ocp$_change_function_descriptio call_method=xref
{ command (change_module_attribute        ,change_module_attributes,       ..
{       chama) ocp$_change_module_attribute call_method=xref
{ command (change_program_description     ,chapd)          ..
{   ocp$_change_program_description call_method=xref
{ command (combine_module                 ,combine_modules,  comm)         ..
{    ocp$_combine_module call_method=xref
{ command (create_command_description     ,crecd)          ..
{   ocp$_create_command_description call_method=xref
{ command (create_form_module             ,crefm) ocp$_create_form_module  ..
{           call_method=xref
{ command (create_function_description    ,crefd)          ..
{   ocp$_create_function_descriptio call_method=xref
{ command (create_linked_module           ,crelm) ocp$create_linked_module ..
{            call_method=proc
{ command (create_message_module          ,cremm)          ..
{   ocp$_create_message_module call_method=xref
{ command (create_module                  ,crem) ocp$_create_module        ..
{     call_method=xref
{ command (create_program_description     ,crepd)          ..
{   ocp$_create_program_description call_method=xref
{ command (delete_module                  ,delete_modules,  delm)          ..
{   ocp$_delete_module call_method=xref
{ command (display_new_library            ,disnl) ocp$_display_new_library ..
{            call_method=xref
{ command (generate_library               ,genl) ocp$generate          ..
{   call_method=xref
{ command (quit                           ,qui) ocp$_quit call_method=local
{ command (reorder_module                 ,reorder_modules,  reom)         ..
{    ocp$_reorder_module call_method=xref
{ command (replace_module                 ,replace_modules,  repm)         ..
{    ocp$_replace_module call_method=xref
{ command (satisfy_external_reference     ,satisfy_external_references,    ..
{          sater) ocp$_satisfy_external_reference call_method=xref
{ command (set_display_option             ,set_display_options,  setdo)    ..
{   ocp$_set_display_option                                       ..
{                call_method=xref
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    command_table: [STATIC, READ] ^clt$command_table := ^command_table_entries,

    command_table_entries: [STATIC, READ] array [1 .. 54] of clt$command_table_entry := [
          {} ['ADDM                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^ocp$_add_module],
          {} ['ADD_MODULE                     ', clc$nominal_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^ocp$_add_module],
          {} ['ADD_MODULES                    ', clc$alias_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^ocp$_add_module],
          {} ['BIND_MODULE                    ', clc$nominal_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^ocp$_bind_module],
          {} ['BINM                           ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^ocp$_bind_module],
          {} ['CHACD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^ocp$_change_command_description],
          {} ['CHAFD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^ocp$_change_function_descriptio],
          {} ['CHAMA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^ocp$_change_module_attribute],
          {} ['CHANGE_COMMAND_DESCRIPTION     ', clc$nominal_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^ocp$_change_command_description],
          {} ['CHANGE_COMMAND_DESCRIPTIONS    ', clc$alias_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^ocp$_change_command_description],
          {} ['CHANGE_FUNCTION_DESCRIPTION    ', clc$nominal_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^ocp$_change_function_descriptio],
          {} ['CHANGE_FUNCTION_DESCRIPTIONS   ', clc$alias_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^ocp$_change_function_descriptio],
          {} ['CHANGE_MODULE_ATTRIBUTE        ', clc$nominal_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^ocp$_change_module_attribute],
          {} ['CHANGE_MODULE_ATTRIBUTES       ', clc$alias_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^ocp$_change_module_attribute],
          {} ['CHANGE_PROGRAM_DESCRIPTION     ', clc$nominal_entry, clc$normal_usage_entry, 6,
          clc$automatically_log, clc$linked_call, ^ocp$_change_program_description],
          {} ['CHAPD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
          clc$automatically_log, clc$linked_call, ^ocp$_change_program_description],
          {} ['COMBINE_MODULE                 ', clc$nominal_entry, clc$normal_usage_entry, 7,
          clc$automatically_log, clc$linked_call, ^ocp$_combine_module],
          {} ['COMBINE_MODULES                ', clc$alias_entry, clc$normal_usage_entry, 7,
          clc$automatically_log, clc$linked_call, ^ocp$_combine_module],
          {} ['COMM                           ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
          clc$automatically_log, clc$linked_call, ^ocp$_combine_module],
          {} ['CREATE_COMMAND_DESCRIPTION     ', clc$nominal_entry, clc$normal_usage_entry, 8,
          clc$automatically_log, clc$linked_call, ^ocp$_create_command_description],
          {} ['CREATE_FORM_MODULE             ', clc$nominal_entry, clc$normal_usage_entry, 9,
          clc$automatically_log, clc$linked_call, ^ocp$_create_form_module],
          {} ['CREATE_FUNCTION_DESCRIPTION    ', clc$nominal_entry, clc$normal_usage_entry, 10,
          clc$automatically_log, clc$linked_call, ^ocp$_create_function_descriptio],
          {} ['CREATE_LINKED_MODULE           ', clc$nominal_entry, clc$normal_usage_entry, 11,
          clc$automatically_log, clc$program_call, 'OCP$CREATE_LINKED_MODULE'],
          {} ['CREATE_MESSAGE_MODULE          ', clc$nominal_entry, clc$normal_usage_entry, 12,
          clc$automatically_log, clc$linked_call, ^ocp$_create_message_module],
          {} ['CREATE_MODULE                  ', clc$nominal_entry, clc$normal_usage_entry, 13,
          clc$automatically_log, clc$linked_call, ^ocp$_create_module],
          {} ['CREATE_PROGRAM_DESCRIPTION     ', clc$nominal_entry, clc$normal_usage_entry, 14,
          clc$automatically_log, clc$linked_call, ^ocp$_create_program_description],
          {} ['CRECD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
          clc$automatically_log, clc$linked_call, ^ocp$_create_command_description],
          {} ['CREFD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
          clc$automatically_log, clc$linked_call, ^ocp$_create_function_descriptio],
          {} ['CREFM                          ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
          clc$automatically_log, clc$linked_call, ^ocp$_create_form_module],
          {} ['CRELM                          ', clc$abbreviation_entry, clc$normal_usage_entry, 11,
          clc$automatically_log, clc$program_call, 'OCP$CREATE_LINKED_MODULE'],
          {} ['CREM                           ', clc$abbreviation_entry, clc$normal_usage_entry, 13,
          clc$automatically_log, clc$linked_call, ^ocp$_create_module],
          {} ['CREMM                          ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
          clc$automatically_log, clc$linked_call, ^ocp$_create_message_module],
          {} ['CREPD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 14,
          clc$automatically_log, clc$linked_call, ^ocp$_create_program_description],
          {} ['DELETE_MODULE                  ', clc$nominal_entry, clc$normal_usage_entry, 15,
          clc$automatically_log, clc$linked_call, ^ocp$_delete_module],
          {} ['DELETE_MODULES                 ', clc$alias_entry, clc$normal_usage_entry, 15,
          clc$automatically_log, clc$linked_call, ^ocp$_delete_module],
          {} ['DELM                           ', clc$abbreviation_entry, clc$normal_usage_entry, 15,
          clc$automatically_log, clc$linked_call, ^ocp$_delete_module],
          {} ['DISNL                          ', clc$abbreviation_entry, clc$normal_usage_entry, 16,
          clc$automatically_log, clc$linked_call, ^ocp$_display_new_library],
          {} ['DISPLAY_NEW_LIBRARY            ', clc$nominal_entry, clc$normal_usage_entry, 16,
          clc$automatically_log, clc$linked_call, ^ocp$_display_new_library],
          {} ['GENERATE_LIBRARY               ', clc$nominal_entry, clc$normal_usage_entry, 17,
          clc$automatically_log, clc$linked_call, ^ocp$generate],
          {} ['GENL                           ', clc$abbreviation_entry, clc$normal_usage_entry, 17,
          clc$automatically_log, clc$linked_call, ^ocp$generate],
          {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 18,
          clc$automatically_log, clc$linked_call, ^ocp$_quit],
          {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 18,
          clc$automatically_log, clc$linked_call, ^ocp$_quit],
          {} ['REOM                           ', clc$abbreviation_entry, clc$normal_usage_entry, 19,
          clc$automatically_log, clc$linked_call, ^ocp$_reorder_module],
          {} ['REORDER_MODULE                 ', clc$nominal_entry, clc$normal_usage_entry, 19,
          clc$automatically_log, clc$linked_call, ^ocp$_reorder_module],
          {} ['REORDER_MODULES                ', clc$alias_entry, clc$normal_usage_entry, 19,
          clc$automatically_log, clc$linked_call, ^ocp$_reorder_module],
          {} ['REPLACE_MODULE                 ', clc$nominal_entry, clc$normal_usage_entry, 20,
          clc$automatically_log, clc$linked_call, ^ocp$_replace_module],
          {} ['REPLACE_MODULES                ', clc$alias_entry, clc$normal_usage_entry, 20,
          clc$automatically_log, clc$linked_call, ^ocp$_replace_module],
          {} ['REPM                           ', clc$abbreviation_entry, clc$normal_usage_entry, 20,
          clc$automatically_log, clc$linked_call, ^ocp$_replace_module],
          {} ['SATER                          ', clc$abbreviation_entry, clc$normal_usage_entry, 21,
          clc$automatically_log, clc$linked_call, ^ocp$_satisfy_external_reference],
          {} ['SATISFY_EXTERNAL_REFERENCE     ', clc$nominal_entry, clc$normal_usage_entry, 21,
          clc$automatically_log, clc$linked_call, ^ocp$_satisfy_external_reference],
          {} ['SATISFY_EXTERNAL_REFERENCES    ', clc$alias_entry, clc$normal_usage_entry, 21,
          clc$automatically_log, clc$linked_call, ^ocp$_satisfy_external_reference],
          {} ['SETDO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 22,
          clc$automatically_log, clc$linked_call, ^ocp$_set_display_option],
          {} ['SET_DISPLAY_OPTION             ', clc$nominal_entry, clc$normal_usage_entry, 22,
          clc$automatically_log, clc$linked_call, ^ocp$_set_display_option],
          {} ['SET_DISPLAY_OPTIONS            ', clc$alias_entry, clc$normal_usage_entry, 22,
          clc$automatically_log, clc$linked_call, ^ocp$_set_display_option]];

  PROCEDURE [XREF] ocp$generate
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_add_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_bind_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_change_command_description
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_change_function_descriptio
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_change_module_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_change_program_description
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_combine_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_create_command_description
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_create_form_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_create_function_descriptio
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_create_message_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_create_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_create_program_description
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_delete_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_display_new_library
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_reorder_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_replace_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_satisfy_external_reference
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$_set_display_option
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??


{ table function_table t=f s=local
{ function $module_list                ocp$$module_list cm=xref
{ function $module_attributes          ocp$$module_attributes cm=xref
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    function_table: [STATIC, READ] ^clt$function_processor_table := ^function_table_entries,

    function_table_entries: [STATIC, READ] array [1 .. 2] of clt$function_proc_table_entry := [
          {} ['$MODULE_ATTRIBUTES             ', clc$nominal_entry, clc$normal_usage_entry, 2,
          clc$linked_call, ^ocp$$module_attributes],
          {} ['$MODULE_LIST                   ', clc$nominal_entry, clc$normal_usage_entry, 1,
          clc$linked_call, ^ocp$$module_list]];

  PROCEDURE [XREF] ocp$$module_attributes
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

  PROCEDURE [XREF] ocp$$module_list
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? POP ??
?? OLDTITLE ??
?? NEWTITLE := 'ocp$_create_object_library', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to initiate the CREATE_OBJECT_LIBRARY utility.

  PROGRAM ocp$_create_object_library
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (ocm$creol) create_object_library, creol (
{     status)

?? 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,
      recend,
    recend := [
    [1,
    [89, 3, 21, 12, 37, 40, 116],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'OCM$CREOL'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.


    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      ocp$close_all_open_files (ocv$open_file_list);
      ocp$return_files;
      IF (status.normal) AND (ocv$nlm_list^.f_link^.name <> osc$null_name) THEN
        osp$set_status_condition (oce$w_library_not_generated, status);
      IFEND;
      clp$end_utility (utility_name, ignore_status);
    PROCEND condition_handler;
?? OLDTITLE ??
?? EJECT ??

    VAR
      ignore_status: ost$status;

    status.normal := TRUE;
    utility_attributes [1].command_table := command_table;
    utility_attributes [2].function_processor_table := function_table;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$initialize_oc_environment (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (command_file, '', utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$disestablish_cond_handler;
    ocp$close_all_open_files (ocv$open_file_list);
    ocp$return_files;
    IF (ocv$nlm_list^.f_link^.name <> osc$null_name) THEN
      osp$set_status_condition (oce$w_library_not_generated, status);
    IFEND;
    clp$end_utility (utility_name, ignore_status);

  PROCEND ocp$_create_object_library;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$_quit', EJECT ??

{ PURPOSE:
{   This procedure is the command processor for the quit subcommand
{   of the CREATE_OBJECT_LIBRARY utility.

  PROCEDURE ocp$_quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (ocm$creol_qui) quit, qui ()

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 3, 21, 15, 0, 53, 974],
    clc$command, 0, 0, 0, 0, 0, 0, 0, 'OCM$CREOL_QUI']];

?? FMT (FORMAT := ON) ??
?? POP ??
    status.normal := TRUE;

{ An "empty" PDT and PVT=NIL indicate that the command has no parameters.

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_include (utility_name, status);

  PROCEND ocp$_quit;
?? OLDTITLE ??
MODEND ocm$create_object_library;
*DECK DECK=OCM$DEFINE_PROGRAM EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Maintenance: Create Program Description' ??
MODULE ocm$define_program;

{
{ PURPOSE:
{   To create a program description and add, replace or combine
{   it on the new object library.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc llt$object_library_header
*copyc llt$program_description
*copyc oce$library_generator_errors
*copyc oct$display_toggles
*copyc ost$status
?? POP ??
*copyc avp$get_capability
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc i#current_sequence_position
*copyc ocp$add_an_nlm
*copyc ocp$close_all_open_files
*copyc ocp$create_an_nlm
*copyc ocp$initialize_olg_working_heap
*copyc ocp$search_nlm_tree
*copyc ocv$nlm_list
*copyc ocv$olg_scratch_seq
*copyc ocv$olg_working_heap
*copyc ocv$open_file_list
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_date
*copyc pmp$get_time
?? OLDTITLE ??
?? NEWTITLE := 'ocp$_create_program_description', EJECT ??

  PROCEDURE [XDCL] ocp$_create_program_description
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$creol_crepd) create_program_description, crepd (
{   name, names, n: record
{       name: program_name
{       aliases: list rest of program_name = $optional
{     recend = $required
{   file, files, f, object_files: list of any of
{       file
{       string
{     anyend = $optional
{   library, libraries, l: list of any of
{       key
{         osf$task_services_library, osf$current_library
{       keyend
{       file
{       string
{     anyend = $optional
{   module, modules, m: list of program_name = $optional
{   starting_procedure, sp: program_name = $optional
{   load_map, lm: (BY_NAME) any of
{       file
{       string
{     anyend = $optional
{   load_map_option, load_map_options, lmo: (BY_NAME) any of
{       key
{         all, none
{       keyend
{       list of key
{         (segment, s)
{         (block, b)
{         (entry_point, ep)
{         (cross_reference, cr, xref)
{       keyend
{     anyend = $optional
{   termination_error_level, tel: (BY_NAME) key
{       (warning, w)
{       (error, e)
{       (fatal, f)
{     keyend = $optional
{   preset_value, pv: (BY_NAME) key
{       (zero, z)
{       (floating_point_indefinite, fpi)
{       (infinity, i)
{       (alternate_ones, ao)
{     keyend = $optional
{   stack_size, ss: (BY_NAME) integer 0..osc$max_segment_length = $optional
{   abort_file, af: (BY_NAME) any of
{       file
{       string
{     anyend = $optional
{   debug_input, di: (BY_NAME) any of
{       file
{       string
{     anyend = $optional
{   debug_output, do: (BY_NAME) any of
{       file
{       string
{     anyend = $optional
{   debug_mode, dm: (BY_NAME) boolean = $optional
{   availability, a: (BY_NAME) key
{       (normal_usage, a, advertised, nu)
{       (advanced_usage, au)
{       (hidden, h)
{     keyend = normal_usage
{   scope, s: (BY_NAME) key
{       (xdcl, x)
{       (gate, g)
{       (local, l)
{     keyend = xdcl
{   log_option, lo: (BY_NAME) key
{       (automatic, a)
{       (manual, m)
{     keyend = automatic
{   merge_option, mo: (BY_NAME) key
{       (add, a)
{       (replace, r)
{       (combine, c)
{     keyend = combine
{   application_identifier, ai: (BY_NAME, ADVANCED) name = $optional
{   arithmetic_overflow, ao: (BY_NAME, ADVANCED) boolean = $optional
{   arithmetic_loss_of_significance, alos: (BY_NAME, ADVANCED) boolean = $optional
{   divide_fault, df: (BY_NAME, ADVANCED) boolean = $optional
{   exponent_overflow, eo: (BY_NAME, ADVANCED) boolean = $optional
{   exponent_underflow, eu: (BY_NAME, ADVANCED) boolean = $optional
{   fp_indefinite, fpi, fi: (BY_NAME, ADVANCED) boolean = $optional
{   fp_loss_of_significance, fplos, flos: (BY_NAME, ADVANCED) boolean = $optional
{   invalid_bdp_data, ibdpd, ibd: (BY_NAME, ADVANCED) boolean = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 64] of clt$pdt_parameter_name,
      parameters: array [1 .. 28] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
        recend,
        field_spec_2: clt$field_specification,
        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,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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 .. 2] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
          type_size_3: clt$type_specification_size,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
      type6: 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type7: 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 .. 2] 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 .. 9] of clt$keyword_specification,
          recend,
        recend,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type11: 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type12: 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type13: 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type14: record
        header: clt$type_specification_header,
      recend,
      type15: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
        default_value: string (12),
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type17: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (9),
      recend,
      type18: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type19: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type20: record
        header: clt$type_specification_header,
      recend,
      type21: record
        header: clt$type_specification_header,
      recend,
      type22: record
        header: clt$type_specification_header,
      recend,
      type23: record
        header: clt$type_specification_header,
      recend,
      type24: record
        header: clt$type_specification_header,
      recend,
      type25: record
        header: clt$type_specification_header,
      recend,
      type26: record
        header: clt$type_specification_header,
      recend,
      type27: record
        header: clt$type_specification_header,
      recend,
      type28: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 3, 20, 14, 14, 18, 294],
    clc$command, 64, 28, 1, 9, 0, 0, 28, 'OCM$CREOL_CREPD'], [
    ['A                              ',clc$abbreviation_entry, 15],
    ['ABORT_FILE                     ',clc$nominal_entry, 11],
    ['AF                             ',clc$abbreviation_entry, 11],
    ['AI                             ',clc$abbreviation_entry, 19],
    ['ALOS                           ',clc$abbreviation_entry, 21],
    ['AO                             ',clc$abbreviation_entry, 20],
    ['APPLICATION_IDENTIFIER         ',clc$nominal_entry, 19],
    ['ARITHMETIC_LOSS_OF_SIGNIFICANCE',clc$nominal_entry, 21],
    ['ARITHMETIC_OVERFLOW            ',clc$nominal_entry, 20],
    ['AVAILABILITY                   ',clc$nominal_entry, 15],
    ['DEBUG_INPUT                    ',clc$nominal_entry, 12],
    ['DEBUG_MODE                     ',clc$nominal_entry, 14],
    ['DEBUG_OUTPUT                   ',clc$nominal_entry, 13],
    ['DF                             ',clc$abbreviation_entry, 22],
    ['DI                             ',clc$abbreviation_entry, 12],
    ['DIVIDE_FAULT                   ',clc$nominal_entry, 22],
    ['DM                             ',clc$abbreviation_entry, 14],
    ['DO                             ',clc$abbreviation_entry, 13],
    ['EO                             ',clc$abbreviation_entry, 23],
    ['EU                             ',clc$abbreviation_entry, 24],
    ['EXPONENT_OVERFLOW              ',clc$nominal_entry, 23],
    ['EXPONENT_UNDERFLOW             ',clc$nominal_entry, 24],
    ['F                              ',clc$alias_entry, 2],
    ['FI                             ',clc$abbreviation_entry, 25],
    ['FILE                           ',clc$nominal_entry, 2],
    ['FILES                          ',clc$alias_entry, 2],
    ['FLOS                           ',clc$abbreviation_entry, 26],
    ['FPI                            ',clc$alias_entry, 25],
    ['FPLOS                          ',clc$alias_entry, 26],
    ['FP_INDEFINITE                  ',clc$nominal_entry, 25],
    ['FP_LOSS_OF_SIGNIFICANCE        ',clc$nominal_entry, 26],
    ['IBD                            ',clc$abbreviation_entry, 27],
    ['IBDPD                          ',clc$alias_entry, 27],
    ['INVALID_BDP_DATA               ',clc$nominal_entry, 27],
    ['L                              ',clc$abbreviation_entry, 3],
    ['LIBRARIES                      ',clc$alias_entry, 3],
    ['LIBRARY                        ',clc$nominal_entry, 3],
    ['LM                             ',clc$abbreviation_entry, 6],
    ['LMO                            ',clc$abbreviation_entry, 7],
    ['LO                             ',clc$abbreviation_entry, 17],
    ['LOAD_MAP                       ',clc$nominal_entry, 6],
    ['LOAD_MAP_OPTION                ',clc$nominal_entry, 7],
    ['LOAD_MAP_OPTIONS               ',clc$alias_entry, 7],
    ['LOG_OPTION                     ',clc$nominal_entry, 17],
    ['M                              ',clc$abbreviation_entry, 4],
    ['MERGE_OPTION                   ',clc$nominal_entry, 18],
    ['MO                             ',clc$abbreviation_entry, 18],
    ['MODULE                         ',clc$nominal_entry, 4],
    ['MODULES                        ',clc$alias_entry, 4],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['OBJECT_FILES                   ',clc$abbreviation_entry, 2],
    ['PRESET_VALUE                   ',clc$nominal_entry, 9],
    ['PV                             ',clc$abbreviation_entry, 9],
    ['S                              ',clc$abbreviation_entry, 16],
    ['SCOPE                          ',clc$nominal_entry, 16],
    ['SP                             ',clc$abbreviation_entry, 5],
    ['SS                             ',clc$abbreviation_entry, 10],
    ['STACK_SIZE                     ',clc$nominal_entry, 10],
    ['STARTING_PROCEDURE             ',clc$nominal_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 28],
    ['TEL                            ',clc$abbreviation_entry, 8],
    ['TERMINATION_ERROR_LEVEL        ',clc$nominal_entry, 8]],
    [
{ PARAMETER 1
    [51, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 101, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 47, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [37, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 132, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [48, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 19, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [61, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [41, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 31, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [42, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 457, clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [64, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [54, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 303, clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [60, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 31, clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 31, clc$optional_parameter, 0, 0],
{ PARAMETER 13
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 31, clc$optional_parameter, 0, 0],
{ PARAMETER 14
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 15
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 303, clc$optional_default_parameter, 0, 12],
{ PARAMETER 16
    [57, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_default_parameter, 0, 4],
{ PARAMETER 17
    [44, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 9],
{ PARAMETER 18
    [46, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$optional_default_parameter, 0, 7],
{ PARAMETER 19
    [7, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 20
    [9, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 21
    [8, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 22
    [16, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 23
    [21, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 24
    [22, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 25
    [30, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 26
    [31, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 27
    [34, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 28
    [62, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$record_type], [2],
    ['NAME                           ', clc$required_field, 3], [[1, 0,
  clc$program_name_type]],
    ['ALIASES                        ', clc$optional_field, 19], [[1, 0,
  clc$list_type], [3, 0, clc$max_list_size, 0, FALSE, TRUE],
        [[1, 0, clc$program_name_type]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [31, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$file_type,
      clc$string_type],
      TRUE, 2],
      3, [[1, 0, clc$file_type]],
      8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$list_type], [116, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$file_type,
      clc$keyword_type, clc$string_type],
      FALSE, 3],
      81, [[1, 0, clc$keyword_type], [2], [
        ['OSF$CURRENT_LIBRARY            ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['OSF$TASK_SERVICES_LIBRARY      ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
        ],
      3, [[1, 0, clc$file_type]],
      8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
      ]
    ],
{ PARAMETER 4
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$program_name_type]]
    ],
{ PARAMETER 5
    [[1, 0, clc$program_name_type]],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$file_type, clc$string_type],
    TRUE, 2],
    3, [[1, 0, clc$file_type]],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    356, [[1, 0, clc$list_type], [340, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [9], [
        ['B                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['BLOCK                          ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['CR                             ', clc$alias_entry,
  clc$normal_usage_entry, 4],
        ['CROSS_REFERENCE                ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['ENTRY_POINT                    ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['EP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['SEGMENT                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['XREF                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4]]
        ]
      ]
    ],
{ PARAMETER 8
    [[1, 0, clc$keyword_type], [6], [
    ['E                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['ERROR                          ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['F                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['FATAL                          ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['W                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['WARNING                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 9
    [[1, 0, clc$keyword_type], [8], [
    ['ALTERNATE_ONES                 ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['AO                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
    ['FLOATING_POINT_INDEFINITE      ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['FPI                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['I                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['INFINITY                       ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['Z                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['ZERO                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 10
    [[1, 0, clc$integer_type], [0, osc$max_segment_length, 10]],
{ PARAMETER 11
    [[1, 0, clc$union_type], [[clc$file_type, clc$string_type],
    TRUE, 2],
    3, [[1, 0, clc$file_type]],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 12
    [[1, 0, clc$union_type], [[clc$file_type, clc$string_type],
    TRUE, 2],
    3, [[1, 0, clc$file_type]],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 13
    [[1, 0, clc$union_type], [[clc$file_type, clc$string_type],
    TRUE, 2],
    3, [[1, 0, clc$file_type]],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 14
    [[1, 0, clc$boolean_type]],
{ PARAMETER 15
    [[1, 0, clc$keyword_type], [8], [
    ['A                              ', clc$alias_entry,
  clc$normal_usage_entry, 1],
    ['ADVANCED_USAGE                 ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['ADVERTISED                     ', clc$alias_entry,
  clc$normal_usage_entry, 1],
    ['AU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['H                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['HIDDEN                         ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['NORMAL_USAGE                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['NU                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1]]
    ,
    'normal_usage'],
{ PARAMETER 16
    [[1, 0, clc$keyword_type], [6], [
    ['G                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['GATE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['LOCAL                          ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['X                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['XDCL                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ,
    'xdcl'],
{ PARAMETER 17
    [[1, 0, clc$keyword_type], [4], [
    ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['AUTOMATIC                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['M                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['MANUAL                         ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'automatic'],
{ PARAMETER 18
    [[1, 0, clc$keyword_type], [6], [
    ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['ADD                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
    ['COMBINE                        ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['R                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['REPLACE                        ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'combine'],
{ PARAMETER 19
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 20
    [[1, 0, clc$boolean_type]],
{ PARAMETER 21
    [[1, 0, clc$boolean_type]],
{ PARAMETER 22
    [[1, 0, clc$boolean_type]],
{ PARAMETER 23
    [[1, 0, clc$boolean_type]],
{ PARAMETER 24
    [[1, 0, clc$boolean_type]],
{ PARAMETER 25
    [[1, 0, clc$boolean_type]],
{ PARAMETER 26
    [[1, 0, clc$boolean_type]],
{ PARAMETER 27
    [[1, 0, clc$boolean_type]],
{ PARAMETER 28
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$file = 2,
      p$library = 3,
      p$module = 4,
      p$starting_procedure = 5,
      p$load_map = 6,
      p$load_map_option = 7,
      p$termination_error_level = 8,
      p$preset_value = 9,
      p$stack_size = 10,
      p$abort_file = 11,
      p$debug_input = 12,
      p$debug_output = 13,
      p$debug_mode = 14,
      p$availability = 15,
      p$scope = 16,
      p$log_option = 17,
      p$merge_option = 18,
      p$application_identifier = 19,
      p$arithmetic_overflow = 20,
      p$arithmetic_loss_of_significan = 21 {ARITHMETIC_LOSS_OF_SIGNIFICANCE} ,
      p$divide_fault = 22,
      p$exponent_overflow = 23,
      p$exponent_underflow = 24,
      p$fp_indefinite = 25,
      p$fp_loss_of_significance = 26,
      p$invalid_bdp_data = 27,
      p$status = 28;

    VAR
      pvt: array [1 .. 28] of clt$parameter_value;

    VAR
      alias_list: ^pmt$module_list,
      alias_number: clt$list_size,
      application_administrator: boolean,
      application_identifier: ^llt$application_identifier,
      date: ost$date,
      enable_inhibit_conditions: ^pmt$enable_inhibit_conditions,
      ignore_status: ost$status,
      library_number: clt$list_size,
      member: ^SEQ ( * ),
      member_size: ost$segment_length,
      module_already_exists: boolean,
      module_description: ^oct$module_description,
      module_list: ^pmt$module_list,
      module_number: clt$list_size,
      nlm: ^oct$new_library_module_list,
      node: ^clt$data_value,
      number_of_libraries: clt$list_size,
      number_of_modules: clt$list_size,
      number_of_object_files: clt$list_size,
      object_file_list: ^llt$object_file_list,
      object_file_number: clt$list_size,
      object_library_list: ^llt$object_library_list,
      program_attributes: ^llt$program_attributes,
      program_description_header: ^llt$library_member_header,
      sequence: ^SEQ ( * ),
      size: ost$segment_length,
      time: ost$time;

    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'set_system_condition_parameter', EJECT ??

    PROCEDURE [INLINE] set_system_condition_parameter
      (    parameter_number: clt$parameter_number;
           system_condition: pmt$system_condition);


      IF pvt [parameter_number].specified THEN
        IF NOT (pmc$condition_specified IN program_attributes^.contents) THEN
          program_attributes^.contents := program_attributes^.contents +
                $pmt$prog_description_contents [pmc$condition_specified];
          NEXT enable_inhibit_conditions IN ocv$olg_scratch_seq;
          enable_inhibit_conditions^.enable_system_conditions := $pmt$system_conditions [];
          enable_inhibit_conditions^.inhibit_system_conditions := $pmt$system_conditions [];
        IFEND;
        IF pvt [parameter_number].value^.boolean_value.value THEN
          enable_inhibit_conditions^.enable_system_conditions :=
                enable_inhibit_conditions^.enable_system_conditions + $pmt$system_conditions
                [system_condition];
        ELSE
          enable_inhibit_conditions^.inhibit_system_conditions :=
                enable_inhibit_conditions^.inhibit_system_conditions +
                $pmt$system_conditions [system_condition];
        IFEND;
      IFEND;

    PROCEND set_system_condition_parameter;
?? OLDTITLE, EJECT ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET ocv$olg_scratch_seq;

    pmp$get_time (osc$hms_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$get_date (osc$mdy_date, date, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];
    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /protect/
    BEGIN

      NEXT program_description_header IN ocv$olg_scratch_seq;
      IF program_description_header = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      program_description_header^.name := pvt [p$name].value^.field_values^ [1].value^.program_name_value;

      IF pvt [p$application_identifier].specified THEN
        avp$get_capability (avc$application_administration, avc$user, application_administrator, status);
        IF NOT status.normal THEN
          EXIT /protect/;
        IFEND;
        IF NOT application_administrator THEN
          osp$set_status_condition (oce$not_application_administrtr, status);
          EXIT /protect/;
        IFEND;
        NEXT application_identifier IN ocv$olg_scratch_seq;
        IF application_identifier = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        application_identifier^.name := pvt [p$application_identifier].value^.name_value;
        program_description_header^.kind := llc$applic_program_description;
      ELSE
        program_description_header^.kind := llc$program_description;
      IFEND;

      program_description_header^.time_created := time;
      program_description_header^.date_created := date;
      program_description_header^.generator_id := llc$object_library_generator;
      program_description_header^.generator_name_vers := occ$generator_name CAT llc$object_library_version;
      program_description_header^.commentary := osc$null_name;

      program_description_header^.number_of_aliases := clp$count_list_elements
            (pvt [p$name].value^.field_values^ [2].value);

      IF program_description_header^.number_of_aliases <> 0 THEN
        NEXT alias_list: [1 .. program_description_header^.number_of_aliases] IN ocv$olg_scratch_seq;
        IF alias_list = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        node := pvt [p$name].value^.field_values^ [2].value;
        FOR alias_number := 1 TO program_description_header^.number_of_aliases DO
          alias_list^ [alias_number] := node^.element_value^.program_name_value;
          node := node^.link;
        FOREND;
      IFEND;

      IF pvt [p$availability].value^.keyword_value = 'HIDDEN' THEN
        program_description_header^.command_function_availability := clc$hidden_entry;
      ELSEIF pvt [p$availability].value^.keyword_value = 'ADVANCED_USAGE' THEN
        program_description_header^.command_function_availability := clc$advanced_usage_entry;
      ELSE {NORMAL_USAGE}
        program_description_header^.command_function_availability := clc$normal_usage_entry;
      IFEND;

      IF pvt [p$scope].value^.keyword_value = 'XDCL' THEN
        program_description_header^.command_function_kind := llc$entry_point;
      ELSEIF pvt [p$scope].value^.keyword_value = 'GATE' THEN
        program_description_header^.command_function_kind := llc$gate;
      ELSE {LOCAL}
        program_description_header^.command_function_kind := llc$local_to_library;
      IFEND;

      IF pvt [p$log_option].value^.keyword_value = 'AUTOMATIC' THEN
        program_description_header^.command_log_option := clc$automatically_log;
      ELSE {MANUAL}
        program_description_header^.command_log_option := clc$manually_log;
      IFEND;

      NEXT program_attributes IN ocv$olg_scratch_seq;
      IF program_attributes = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      program_attributes^.contents := $pmt$prog_description_contents [];

      number_of_object_files := clp$count_list_elements (pvt [p$file].value);
      IF number_of_object_files <> 0 THEN
        program_attributes^.contents := program_attributes^.contents +
              $pmt$prog_description_contents [pmc$object_file_list_specified];
        program_attributes^.number_of_object_files := number_of_object_files;
        NEXT object_file_list: [1 .. number_of_object_files] IN ocv$olg_scratch_seq;
        IF object_file_list = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        node := pvt [p$file].value;
        FOR object_file_number := 1 TO number_of_object_files DO
          IF node^.element_value^.kind = clc$file THEN
            object_file_list^ [object_file_number] := node^.element_value^.file_value^;
          ELSE {clc$string}
            object_file_list^ [object_file_number] := node^.element_value^.string_value^;
          IFEND;
          node := node^.link;
        FOREND;
      IFEND;

      number_of_modules := clp$count_list_elements (pvt [p$module].value);
      IF number_of_modules <> 0 THEN
        program_attributes^.contents := program_attributes^.contents +
              $pmt$prog_description_contents [pmc$module_list_specified];
        program_attributes^.number_of_modules := number_of_modules;
        NEXT module_list: [1 .. number_of_modules] IN ocv$olg_scratch_seq;
        IF module_list = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        node := pvt [p$module].value;
        FOR module_number := 1 TO number_of_modules DO
          module_list^ [module_number] := node^.element_value^.program_name_value;
          node := node^.link;
        FOREND;
      IFEND;

      number_of_libraries := clp$count_list_elements (pvt [p$library].value);
      IF number_of_libraries <> 0 THEN
        program_attributes^.contents := program_attributes^.contents +
              $pmt$prog_description_contents [pmc$library_list_specified];
        program_attributes^.number_of_libraries := number_of_libraries;
        NEXT object_library_list: [1 .. number_of_libraries] IN ocv$olg_scratch_seq;
        IF object_library_list = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        node := pvt [p$library].value;
        FOR library_number := 1 TO number_of_libraries DO
          CASE node^.element_value^.kind OF
          = clc$keyword = {OSF$TASK_SERVICES_LIBRARY or OSF$CURRENT_LIBRARY}
            object_library_list^ [library_number] := node^.element_value^.keyword_value;
          = clc$file =
            object_library_list^ [library_number] := node^.element_value^.file_value^;
          ELSE {clc$string}
            object_library_list^ [library_number] := node^.element_value^.string_value^;
          CASEND;
          node := node^.link;
        FOREND;
      IFEND;

      IF pvt [p$starting_procedure].specified THEN
        program_attributes^.contents := program_attributes^.contents +
              $pmt$prog_description_contents [pmc$starting_proc_specified];
        program_attributes^.starting_procedure := pvt [p$starting_procedure].value^.program_name_value;
      IFEND;

      IF pvt [p$load_map].specified THEN
        program_attributes^.contents := program_attributes^.contents +
              $pmt$prog_description_contents [pmc$load_map_file_specified];
        IF pvt [p$load_map].value^.kind = clc$file THEN
          program_attributes^.load_map_file := pvt [p$load_map].value^.file_value^;
        ELSE {clc$string}
          program_attributes^.load_map_file := pvt [p$load_map].value^.string_value^;
        IFEND;
      IFEND;

      IF pvt [p$load_map_option].specified THEN
        program_attributes^.contents := program_attributes^.contents +
              $pmt$prog_description_contents [pmc$load_map_options_specified];
        program_attributes^.load_map_options := $pmt$load_map_options [];
        IF pvt [p$load_map_option].value^.kind = clc$keyword THEN
          IF pvt [p$load_map_option].value^.keyword_value = 'ALL' THEN
            program_attributes^.load_map_options := -$pmt$load_map_options [pmc$no_load_map];
          ELSE {NONE}
            program_attributes^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
          IFEND;
        ELSE {clc$list of clc$keyword}
          node := pvt [p$load_map_option].value;
          WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
            IF node^.element_value^.keyword_value = 'SEGMENT' THEN
              program_attributes^.load_map_options := program_attributes^.load_map_options +
                    $pmt$load_map_options [pmc$segment_map];
            ELSEIF node^.element_value^.keyword_value = 'BLOCK' THEN
              program_attributes^.load_map_options := program_attributes^.load_map_options +
                    $pmt$load_map_options [pmc$block_map];
            ELSEIF node^.element_value^.keyword_value = 'ENTRY_POINT' THEN
              program_attributes^.load_map_options := program_attributes^.load_map_options +
                    $pmt$load_map_options [pmc$entry_point_map];
            ELSE {CROSS_REFERENCE}
              program_attributes^.load_map_options := program_attributes^.load_map_options +
                    $pmt$load_map_options [pmc$entry_point_xref];
            IFEND;
            node := node^.link;
          WHILEND;
        IFEND;
      IFEND;

      IF pvt [p$termination_error_level].specified THEN
        program_attributes^.contents := program_attributes^.contents +
              $pmt$prog_description_contents [pmc$term_error_level_specified];
        IF pvt [p$termination_error_level].value^.keyword_value = 'WARNING' THEN
          program_attributes^.termination_error_level := pmc$warning_load_errors;
        ELSEIF pvt [p$termination_error_level].value^.keyword_value = 'ERROR' THEN
          program_attributes^.termination_error_level := pmc$error_load_errors;
        ELSE {FATAL}
          program_attributes^.termination_error_level := pmc$fatal_load_errors;
        IFEND;
      IFEND;

      IF pvt [p$preset_value].specified THEN
        program_attributes^.contents := program_attributes^.contents +
              $pmt$prog_description_contents [pmc$preset_specified];
        IF pvt [p$preset_value].value^.keyword_value = 'ZERO' THEN
          program_attributes^.preset := pmc$initialize_to_zero;
        ELSEIF pvt [p$preset_value].value^.keyword_value = 'INFINITY' THEN
          program_attributes^.preset := pmc$initialize_to_infinity;
        ELSEIF pvt [p$preset_value].value^.keyword_value = 'FLOATING_POINT_INDEFINITE' THEN
          program_attributes^.preset := pmc$initialize_to_indefinite;
        ELSE {ALTERNATE_ONES}
          program_attributes^.preset := pmc$initialize_to_alt_ones;
        IFEND;
      IFEND;

      IF pvt [p$stack_size].specified THEN
        program_attributes^.contents := program_attributes^.contents +
              $pmt$prog_description_contents [pmc$max_stack_size_specified];
        program_attributes^.maximum_stack_size := pvt [p$stack_size].value^.integer_value.value;
      IFEND;

      IF pvt [p$abort_file].specified THEN
        program_attributes^.contents := program_attributes^.contents +
              $pmt$prog_description_contents [pmc$abort_file_specified];
        IF pvt [p$abort_file].value^.kind = clc$file THEN
          program_attributes^.abort_file := pvt [p$abort_file].value^.file_value^;
        ELSE {clc$string}
          program_attributes^.abort_file := pvt [p$abort_file].value^.string_value^;
        IFEND;
      IFEND;

      IF pvt [p$debug_input].specified THEN
        program_attributes^.contents := program_attributes^.contents +
              $pmt$prog_description_contents [pmc$debug_input_specified];
        IF pvt [p$debug_input].value^.kind = clc$file THEN
          program_attributes^.debug_input := pvt [p$debug_input].value^.file_value^;
        ELSE {clc$string}
          program_attributes^.debug_input := pvt [p$debug_input].value^.string_value^;
        IFEND;
      IFEND;

      IF pvt [p$debug_output].specified THEN
        program_attributes^.contents := program_attributes^.contents +
              $pmt$prog_description_contents [pmc$debug_output_specified];
        IF pvt [p$debug_output].value^.kind = clc$file THEN
          program_attributes^.debug_output := pvt [p$debug_output].value^.file_value^;
        ELSE {clc$string}
          program_attributes^.debug_output := pvt [p$debug_output].value^.string_value^;
        IFEND;
      IFEND;

      IF pvt [p$debug_mode].specified THEN
        program_attributes^.contents := program_attributes^.contents +
              $pmt$prog_description_contents [pmc$debug_mode_specified];
        program_attributes^.debug_mode := pvt [p$debug_mode].value^.boolean_value.value;
      IFEND;

      set_system_condition_parameter (p$arithmetic_overflow, pmc$arithmetic_overflow);
      set_system_condition_parameter (p$arithmetic_loss_of_significan, pmc$arithmetic_significance);
      set_system_condition_parameter (p$divide_fault, pmc$divide_fault);
      set_system_condition_parameter (p$exponent_overflow, pmc$exponent_overflow);
      set_system_condition_parameter (p$exponent_underflow, pmc$exponent_underflow);
      set_system_condition_parameter (p$fp_indefinite, pmc$fp_indefinite);
      set_system_condition_parameter (p$fp_loss_of_significance, pmc$fp_significance_loss);
      set_system_condition_parameter (p$invalid_bdp_data, pmc$invalid_bdp_data);

      ALLOCATE module_description IN ocv$olg_working_heap^;
      IF module_description = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      module_description^.name := program_description_header^.name;
      module_description^.source := occ$current;
      IF pvt [p$application_identifier].specified THEN
        module_description^.kind := occ$applic_program_description
      ELSE
        module_description^.kind := occ$program_description;
      IFEND;

      ocp$search_nlm_tree (program_description_header^.name, nlm, module_already_exists);

      IF pvt [p$merge_option].value^.keyword_value = 'ADD' THEN
        IF module_already_exists THEN
          osp$set_status_abnormal ('OC', oce$e_module_already_on_library, program_description_header^.name,
                status);
          EXIT /protect/;
        ELSE
          ocp$create_an_nlm (module_description, nlm, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
          ocp$add_an_nlm (ocv$nlm_list^.b_link, nlm);
        IFEND;

      ELSEIF pvt [p$merge_option].value^.keyword_value = 'REPLACE' THEN
        IF module_already_exists THEN
          nlm^.description := module_description;
          nlm^.changed_info := NIL;
        ELSE
          osp$set_status_abnormal ('OC', oce$e_module_not_found, program_description_header^.name, status);
          EXIT /protect/;
        IFEND;

      ELSE {COMBINE}
        IF module_already_exists THEN
          nlm^.description := module_description;
          nlm^.changed_info := NIL;
        ELSE
          ocp$create_an_nlm (module_description, nlm, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
          ocp$add_an_nlm (ocv$nlm_list^.b_link, nlm);
        IFEND;
      IFEND;

      size := i#current_sequence_position (ocv$olg_scratch_seq);
      RESET ocv$olg_scratch_seq;
      NEXT sequence: [[REP size OF cell]] IN ocv$olg_scratch_seq;
      ALLOCATE module_description^.file: [[REP size OF cell]] IN ocv$olg_working_heap^;
      IF module_description^.file = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      module_description^.file^ := sequence^;
      RESET module_description^.file;
      IF pvt [p$application_identifier].specified THEN
        NEXT module_description^.applic_program_description_hdr IN module_description^.file;
        IF module_description^.applic_program_description_hdr^.library_member_header.number_of_aliases <>
              0 THEN
          NEXT alias_list: [1 .. module_description^.applic_program_description_hdr^.library_member_header.
                number_of_aliases] IN module_description^.file;
          module_description^.applic_program_description_hdr^.library_member_header.aliases :=
                #REL (alias_list, module_description^.file^);
        IFEND;
      ELSE
        NEXT module_description^.program_description_header IN module_description^.file;
        IF module_description^.program_description_header^.number_of_aliases <> 0 THEN
          NEXT alias_list: [1 .. module_description^.program_description_header^.number_of_aliases] IN
                module_description^.file;
          module_description^.program_description_header^.aliases :=
                #REL (alias_list, module_description^.file^);
        IFEND;
      IFEND;

      member_size := size - i#current_sequence_position (module_description^.file);
      NEXT member: [[REP member_size OF cell]] IN module_description^.file;

      IF pvt [p$application_identifier].specified THEN
        module_description^.applic_program_description_hdr^.library_member_header.member :=
              #REL (member, module_description^.file^);
        module_description^.applic_program_description_hdr^.library_member_header.member_size := member_size;
      ELSE
        module_description^.program_description_header^.member := #REL (member, module_description^.file^);
        module_description^.program_description_header^.member_size := member_size;
      IFEND;

    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);

  PROCEND ocp$_create_program_description;
?? OLDTITLE ??
MODEND ocm$define_program;
*DECK DECK=OCM$DELETE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
MODULE ocm$delete;


{ PURPOSE:
{   To delete module(s) currently scheduled
{   to be part of the output library.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oce$library_generator_errors
*copyc oct$nlm_modification_list
*copyc ost$status
?? POP ??
*copyc clp$evaluate_parameters
*copyc ocp$close_all_open_files
*copyc ocp$delete_list_from_nlm_list
*copyc ocp$generate_message
*copyc ocp$initialize_olg_working_heap
*copyc ocp$search_modification_list
*copyc ocp$search_nlm_tree
*copyc ocv$nlm_list
*copyc ocv$olg_scratch_seq
*copyc ocv$open_file_list
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    command_status: ost$status;

?? OLDTITLE ??
?? NEWTITLE := 'delete_module_subrange' ??
?? EJECT ??

  PROCEDURE delete_module_subrange
    (    first_module: pmt$program_name;
         last_module: pmt$program_name;
         deletion_list: {output} ^oct$nlm_modification_list;
     VAR status: ost$status);


    VAR
      new_deletions: ^oct$nlm_modification_list,
      last_deletion: ^oct$nlm_modification_list,

      module_found: boolean,
      nlm: ^oct$new_library_module_list,
      current_module: pmt$program_name;


    ocp$search_modification_list (osc$null_name, deletion_list, new_deletions, module_found);

    ocp$search_nlm_tree (first_module, nlm, module_found);
    IF NOT module_found THEN
      IF first_module = last_module THEN
        osp$set_status_abnormal ('OC', oce$w_module_not_on_library, first_module, status);
      ELSE
        osp$set_status_abnormal ('OC', oce$w_subrange_not_found_on_lib, first_module, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, last_module, status);
      IFEND;
      ocp$generate_message (status);
      osp$set_status_abnormal ('OC', oce$e_some_modules_not, 'deleted', command_status);
      RETURN;
    IFEND;

    REPEAT
      current_module := nlm^.name;
      IF current_module = osc$null_name THEN
        osp$set_status_abnormal ('OC', oce$e_range_module_2_not_found, last_module, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);
        ocp$generate_message (status);
        osp$set_status_abnormal ('OC', oce$e_some_modules_not, 'deleted', command_status);
        new_deletions^.link := NIL;
        RETURN;
      IFEND;

      ocp$search_modification_list (current_module, deletion_list, last_deletion, module_found);
      IF module_found THEN
        osp$set_status_abnormal ('OC', oce$w_same_module_quoted_twice, current_module, status);
        ocp$generate_message (status);
        osp$set_status_abnormal ('OC', oce$e_some_modules_not, 'deleted', command_status);

      ELSE
        NEXT last_deletion^.link IN ocv$olg_scratch_seq;
        last_deletion := last_deletion^.link;
        IF last_deletion = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_internal_olg_seg_overflow, '', status);
          RETURN;
        IFEND;

        last_deletion^.nlm := nlm;

        last_deletion^.link := NIL;
      IFEND;

      nlm := nlm^.f_link;

    UNTIL current_module = last_module;


  PROCEND delete_module_subrange;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$_delete_module' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$_delete_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$creol_delm) delete_module, delete_modules, delm (
{   module, modules, m: any of
{       key
{         all
{       keyend
{       list of any of
{         program_name
{         range of program_name
{       anyend
{     anyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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$union_type_qualifier,
            type_size_1: clt$type_specification_size,
            element_type_spec_1: record
              header: clt$type_specification_header,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$range_type_qualifier,
              element_type_spec: record
                header: clt$type_specification_header,
              recend,
            recend,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [93, 10, 11, 0, 45, 25, 703],
    clc$command, 4, 2, 1, 0, 0, 0, 2, 'OCM$CREOL_DELM'], [
    ['M                              ',clc$abbreviation_entry, 1],
    ['MODULE                         ',clc$nominal_entry, 1],
    ['MODULES                        ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 113, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    49, [[1, 0, clc$list_type], [33, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$union_type], [[clc$program_name_type,
        clc$range_type],
        FALSE, 2],
        3, [[1, 0, clc$program_name_type]],
        10, [[1, 0, clc$range_type], [3],
            [[1, 0, clc$program_name_type]]
          ]
        ]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$module = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    VAR
      after: ^oct$new_library_module_list,
      deletion_list: oct$nlm_modification_list,
      first_module: pmt$program_name,
      ignore_status: ost$status,
      last_module: pmt$program_name,
      node: ^clt$data_value;


    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler;


    status.normal := TRUE;
    command_status.normal := TRUE;
    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];

    RESET ocv$olg_scratch_seq;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /protect/
    BEGIN
      deletion_list.link := NIL;
      IF pvt [p$module].value^.kind = clc$keyword THEN

{ Delete all modules if there are any.

        IF ocv$nlm_list^.f_link^.name = osc$null_name THEN
          EXIT /protect/;
        ELSE
          first_module := ocv$nlm_list^.f_link^.name;
          last_module := ocv$nlm_list^.b_link^.name;
          delete_module_subrange (first_module, last_module, ^deletion_list, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
        IFEND;
      ELSE
        node := pvt [p$module].value;
        WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
          IF node^.element_value^.kind = clc$range THEN
            first_module := node^.element_value^.low_value^.program_name_value;
            last_module := node^.element_value^.high_value^.program_name_value;
          ELSE
            first_module := node^.element_value^.program_name_value;
            last_module := first_module;
          IFEND;
          delete_module_subrange (first_module, last_module, ^deletion_list, status);
          IF NOT status.normal THEN
            EXIT /protect/;
          IFEND;
          node := node^.link;
        WHILEND;
      IFEND;

      ocp$delete_list_from_nlm_list (^deletion_list);

      status := command_status;
    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);


  PROCEND ocp$_delete_module;
?? OLDTITLE ??
MODEND ocm$delete;
*DECK DECK=OCM$DISPLAY_HELPERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Code Utilities', EJECT ??
MODULE ocm$display_helpers;



{ PURPOSE:
{   To display specific information about a module.

?? PUSH (LIST := OFF) ??
*copyc llt$object_module
*copyc llt$load_module
*copyc ost$segment_access_control
?? POP ??
*copyc clp$convert_date_time_to_string
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_date_time
*copyc ocp$output
?? NEWTITLE := '[XDCL] ocp$hexrep', EJECT ??

  PROCEDURE [XDCL] ocp$hexrep
    (VAR strng: string ( * );
     VAR length: integer;
         intger: integer);

    VAR
      str: ost$string,
      status: ost$status;

    clp$convert_integer_to_string (intger, 16, FALSE, str, status);

    strng (1) := ' ';
    strng (2, str.size) := str.value;
    length := str.size + 1;

  PROCEND ocp$hexrep;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$output_time', EJECT ??

  PROCEDURE [XDCL] ocp$output_time
    (    time: ^ost$time;
         end_of_line: boolean;
     VAR valid_format: boolean);

    VAR
      status: ost$status,
      str: ost$string,
      cl_time: clt$date_time;

    valid_format := TRUE;

    CASE time^.time_format OF
    = osc$ampm_time =
      clp$convert_string_to_date_time (time^.ampm, 'AMPM', cl_time, status);
    = osc$hms_time =
      ocp$output (' ', time^.hms, STRLENGTH (time^.hms), end_of_line);
      RETURN;
    = osc$millisecond_time =
      clp$convert_string_to_date_time (time^.millisecond, 'MS', cl_time, status);
    ELSE
      status.normal := FALSE;
    CASEND;

    IF status.normal THEN
      clp$convert_date_time_to_string (cl_time, 'HMS', str, status);
    IFEND;

    IF status.normal THEN
      ocp$output (' ', str.value, str.size, end_of_line);
    ELSE
      valid_format := FALSE;
      ocp$output (' ', '**:**:**', 12, end_of_line);
    IFEND;

  PROCEND ocp$output_time;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$output_date', EJECT ??

  PROCEDURE [XDCL] ocp$output_date
    (    date: ^ost$date;
         end_of_line: boolean;
     VAR valid_format: boolean);

    VAR
      date_time: clt$date_time,
      status: ost$status,
      str: ost$string;

    valid_format := TRUE;

    CASE date^.date_format OF
    = osc$month_date =
      clp$convert_string_to_date_time (date^.month, 'MONTH', date_time, status);
      str.value := date^.month;
      str.size := STRLENGTH (date^.month);
    = osc$iso_date =
      ocp$output (' ', date^.iso, STRLENGTH (date^.iso), end_of_line);
      RETURN;
    = osc$ordinal_date =
      clp$convert_string_to_date_time (date^.ordinal, 'ORDINAL', date_time, status);
      str.value := date^.ordinal;
      str.size := STRLENGTH (date^.ordinal);
    = osc$dmy_date =
      clp$convert_string_to_date_time (date^.dmy, 'DMY', date_time, status);
      str.value := date^.dmy;
      str.size := STRLENGTH (date^.dmy);
    = osc$mdy_date =
      clp$convert_string_to_date_time (date^.mdy, 'MDY', date_time, status);
      str.value := date^.mdy;
      str.size := STRLENGTH (date^.mdy);
    ELSE
      status.normal := FALSE;
    CASEND;

    IF status.normal THEN
      clp$convert_date_time_to_string (date_time, 'ISOD', str, status);
    IFEND;

    ocp$output (' ', str.value, str.size, end_of_line);
    valid_format := status.normal;

  PROCEND ocp$output_date;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$output_module_kind', EJECT ??

  PROCEDURE [XDCL] ocp$output_module_kind
    (    kind: ^llt$module_kind;
         end_of_line: boolean;
     VAR valid_kind: boolean);

    valid_kind := TRUE;

    CASE kind^ OF
    = llc$mi_virtual_state =
      ocp$output (' ', 'MI_VIRTUAL_STATE', 16, end_of_line);
    = llc$vector_virtual_state =
      ocp$output (' ', 'VECTOR_VIRTUAL_STATE', 20, end_of_line);
    = llc$iou =
      ocp$output (' ', 'IOU', 3, end_of_line);
    = llc$motorola_68000 =
      ocp$output (' ', 'MOTOROLA_68000', 14, end_of_line);
    = llc$motorola_68000_absolute =
      ocp$output (' ', 'MOTOROLA_68000_ABSOLUTE', 23, end_of_line);
    = llc$p_code =
      ocp$output (' ', 'P_CODE', 6, end_of_line);
      valid_kind := FALSE;
    = llc$vector_extended_state =
      ocp$output (' ', 'VECTOR_EXTENDED_STATE', 21, end_of_line);
    ELSE
      valid_kind := FALSE;
      ocp$output (' ', '*****************', 17, end_of_line);
    CASEND;

  PROCEND ocp$output_module_kind;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$output_library_member_kind', EJECT ??

  PROCEDURE [XDCL] ocp$output_library_member_kind
    (    library_member_kind: ^llt$library_member_kind;
         end_of_line: boolean;
     VAR valid_kind: boolean);

    valid_kind := TRUE;

    CASE library_member_kind^ OF
    = llc$program_description =
      ocp$output (' ', 'PROGRAM DESCRIPTION', 19, end_of_line);
    = llc$command_procedure =
      ocp$output (' ', 'COMMAND PROCEDURE', 17, end_of_line);
    = llc$command_description =
      ocp$output (' ', 'COMMAND DESCRIPTION', 19, end_of_line);
    = llc$function_procedure =
      ocp$output (' ', 'FUNCTION PROCEDURE', 18, end_of_line);
    = llc$function_description =
      ocp$output (' ', 'FUNCTION DESCRIPTION', 20, end_of_line);
    = llc$message_module =
      ocp$output (' ', 'MESSAGE MODULE', 14, end_of_line);
    = llc$panel_module =
      ocp$output (' ', 'FORM MODULE', 11, end_of_line);
    = llc$applic_program_description =
      ocp$output (' ', 'APPLICATION PROGRAM DESCRIPTION', 31, end_of_line);
    = llc$applic_command_procedure =
      ocp$output (' ', 'APPLICATION COMMAND PROCEDURE', 29, end_of_line);
    = llc$applic_command_description =
      ocp$output (' ', 'APPLICATION COMMAND DESCRIPTION', 31, end_of_line);
    ELSE
      valid_kind := FALSE;
      ocp$output (' ', '*******************', 19, end_of_line);
    CASEND;

  PROCEND ocp$output_library_member_kind;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$output_module_generator', EJECT ??

  PROCEDURE [XDCL] ocp$output_module_generator
    (    module_generator: ^llt$module_generator;
         end_of_line: boolean;
     VAR valid_module_generator: boolean);

    valid_module_generator := TRUE;

    CASE module_generator^ OF
    = llc$algol =
      ocp$output (' ', 'ALGOL', 5, end_of_line);
    = llc$apl =
      ocp$output (' ', 'APL', 3, end_of_line);
    = llc$basic =
      ocp$output (' ', 'BASIC', 5, end_of_line);
    = llc$cobol =
      ocp$output (' ', 'COBOL', 5, end_of_line);
    = llc$assembler =
      ocp$output (' ', 'ASSEMBLER', 9, end_of_line);
    = llc$fortran =
      ocp$output (' ', 'FORTRAN', 7, end_of_line);
    = llc$object_library_generator =
      ocp$output (' ', 'OBJECT_LIBRARY_GENERATOR', 24, end_of_line);
    = llc$pascal =
      ocp$output (' ', 'PASCAL', 6, end_of_line);
    = llc$obsolete_cybil =
      ocp$output (' ', 'OBSOLETE_CYBIL', 14, end_of_line);
    = llc$pl_i =
      ocp$output (' ', 'PL/I', 4, end_of_line);
    = llc$unknown_generator =
      ocp$output (' ', 'UNKNOWN_GENERATOR', 17, end_of_line);
    = llc$the_c_language =
      ocp$output (' ', 'THE_C_LANGUAGE', 14, end_of_line);
    = llc$ada =
      ocp$output (' ', 'ADA', 3, end_of_line);
    = llc$real_memory_builder =
      ocp$output (' ', 'REAL_MEMORY_BUILDER', 19, end_of_line);
    = llc$virtual_environment_linker =
      ocp$output (' ', 'VIRTUAL_ENVIRONMENT_LINKER', 26, end_of_line);
    = llc$malet =
      ocp$output (' ', 'MALET', 5, end_of_line);
    = llc$screen_formatter =
      ocp$output (' ', 'SCREEN_FORMATTER', 16, end_of_line);
    = llc$lisp =
      ocp$output (' ', 'LISP', 4, end_of_line);
    = llc$cybil =
      ocp$output (' ', 'CYBIL', 5, end_of_line);
    ELSE
      valid_module_generator := FALSE;
      ocp$output (' ', '************************', 24, end_of_line);
    CASEND;

  PROCEND ocp$output_module_generator;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$output_section_kind', EJECT ??

  PROCEDURE [XDCL] ocp$output_section_kind
    (    kind: ^llt$section_kind;
         end_of_line: boolean;
     VAR valid_kind: boolean);

    valid_kind := TRUE;

    CASE kind^ OF
    = llc$code_section =
      ocp$output (' ', 'CODE', 4, end_of_line);
    = llc$binding_section =
      ocp$output (' ', 'BINDING', 7, end_of_line);
    = llc$working_storage_section =
      ocp$output (' ', 'WORKING STORAGE', 15, end_of_line);
    = llc$common_block =
      ocp$output (' ', 'COMMON BLOCK', 12, end_of_line);
    = llc$extensible_working_storage =
      ocp$output (' ', 'EXTENSIBLE WORKING STORAGE', 26, end_of_line);
    = llc$extensible_common_block =
      ocp$output (' ', 'EXTENSIBLE COMMON BLOCK', 23, end_of_line);
    = llc$lts_reserved =
      ocp$output (' ', 'LINE TABLE RESERVED', 19, end_of_line);
    ELSE
      valid_kind := FALSE;
      ocp$output (' ', '**************************', 26, end_of_line);
    CASEND;

  PROCEND ocp$output_section_kind;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$output_boolean', EJECT ??

  PROCEDURE [XDCL] ocp$output_boolean
    (    boolean_value: boolean;
         end_of_line: boolean);

    IF boolean_value THEN
      ocp$output (' ', 'TRUE', 4, end_of_line);
    ELSE
      ocp$output (' ', 'FALSE', 5, end_of_line);
    IFEND;

  PROCEND ocp$output_boolean;
?? OLDTITLE ??
?? NEWTITLE := 'OCP$OUTPUT_ACCESS_ATTRIBUTES', EJECT ??

  PROCEDURE [XDCL] ocp$output_access_attributes
    (    access_attributes: llt$section_access_attributes;
         end_of_line: boolean);

    ocp$output (' ', '[', 1, FALSE);

    IF llc$read IN access_attributes THEN
      ocp$output (' ', 'R', 1, FALSE);
    IFEND;

    IF llc$write IN access_attributes THEN
      ocp$output (' ', 'W', 1, FALSE);
    IFEND;

    IF llc$binding IN access_attributes THEN
      ocp$output (' ', 'B', 1, FALSE);
    IFEND;

    IF llc$execute IN access_attributes THEN
      ocp$output (' ', 'X', 1, FALSE);
    IFEND;

    ocp$output (' ', ']', 1, end_of_line);

  PROCEND ocp$output_access_attributes;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$output_access_control', EJECT ??

  PROCEDURE [XDCL] ocp$output_access_control
    (    control: ost$segment_access_control;
         end_of_line: boolean);

    ocp$output (' ', '[', 1, FALSE);

    IF control.cache_bypass THEN
      ocp$output (' ', 'CB', 2, FALSE);
    IFEND;

    CASE control.execute_privilege OF
    = osc$non_privileged =
      ocp$output (' ', 'EX', 2, FALSE);
    = osc$local_privilege =
      ocp$output (' ', 'LP', 2, FALSE);
    = osc$global_privilege =
      ocp$output (' ', 'GP', 1, FALSE);
    ELSE
    CASEND;

    CASE control.read_privilege OF
    = osc$read_key_lock_controlled =
      ocp$output (' ', 'RK', 2, FALSE);
    = osc$read_uncontrolled =
      ocp$output (' ', 'RD', 2, FALSE);
    = osc$binding_segment =
      ocp$output (' ', 'BI', 2, FALSE);
    ELSE
    CASEND;

    CASE control.write_privilege OF
    = osc$write_key_lock_controlled =
      ocp$output (' ', 'WK', 2, FALSE);
    = osc$write_uncontrolled =
      ocp$output (' ', 'WT', 2, FALSE);
    ELSE
    CASEND;

    ocp$output (' ', ']', 1, end_of_line);

  PROCEND ocp$output_access_control;
?? OLDTITLE ??
MODEND ocm$display_helpers
*DECK DECK=OCM$DISPLAY_MODULE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
MODULE ocm$display_module;

{ PURPOSE:                              }
{   To display information about all or }
{   part of the contents of a module.   }

?? PUSH (LISTEXT := ON) ??
*copyc llt$command_description
*copyc llt$function_description
*copyc llt$program_description
*copyc occ$retain
*copyc oce$library_generator_errors
*copyc oct$changed_info
*copyc oct$display_toggles
*copyc oct$external_declaration_list
*copyc oct$external_reference_list
*copyc oct$header
*copyc oct$module_description
*copyc oct$name_list
?? POP ??
*copyc ocp$output
*copyc ocp$output_time
*copyc ocp$output_date
*copyc ocp$output_module_kind
*copyc ocp$output_library_member_kind
*copyc ocp$output_module_generator
*copyc ocp$output_scl_parameters
*copyc ocp$obtain_xdcl_list
*copyc ocp$obtain_xref_list
*copyc ocp$obtain_component_info
*copyc ocp$obtain_header
*copyc ocp$obtain_library_list


*copyc clp$get_message_module_info

*copyc osp$get_status_condition_string
*copyc osp$set_status_abnormal

?? NEWTITLE := '  DISPLAY_IDENTIFICATION' ??
?? EJECT ??

  PROCEDURE display_identification (header: oct$header;
        kind: string ( * );
        display_toggles: oct$display_toggles);


    VAR
      identification: llt$identification,
      ignore: boolean;


    identification := header.identification;

    IF display_toggles = $oct$display_toggles [] THEN
      ocp$output (occ$single_space, identification.name, #SIZE (identification.name), occ$end_of_line);

    ELSE
      IF display_toggles - $oct$display_toggles [occ$display_time_date] <> $oct$display_toggles [] THEN
        ocp$output (occ$double_space, ' ', 1, occ$end_of_line);
      IFEND;
      ocp$output (occ$single_space, identification.name, #SIZE (identification.name), occ$continue);
      ocp$output (' - ', kind, #SIZE (kind), occ$continue);

      IF (occ$display_time_date IN display_toggles) OR (occ$display_module_header IN display_toggles) THEN
        ocp$output ('', ' -', 2, occ$continue);
        ocp$output_time (^identification.time_created, occ$continue, ignore);
        ocp$output_date (^identification.date_created, occ$end_of_line, ignore);
      ELSE
        ocp$output ('', ' ', 1, occ$end_of_line);
      IFEND;


      IF occ$display_module_header IN display_toggles THEN
        ocp$output (' ', 'kind:', 5, occ$continue);
        ocp$output_module_kind (^identification.kind, occ$continue, ignore);

        ocp$output ('  ', 'generator:', 10, occ$continue);
        ocp$output_module_generator (^identification.generator_id, occ$end_of_line, ignore);

        ocp$output (' ', 'generator name version:', 23, occ$continue);
        ocp$output (' ', identification.generator_name_vers, STRLENGTH (identification.generator_name_vers),
              occ$end_of_line);

        IF identification.commentary <> osc$null_name THEN
          ocp$output (' ', 'commentary:', 11, occ$continue);
          ocp$output (' ', identification.commentary, STRLENGTH (identification.commentary), occ$end_of_line);
        IFEND;

        IF header.application_identifier.name <> osc$null_name THEN
          ocp$output (' ', 'application identifier:', 23, occ$continue);
          ocp$output (' ', header.application_identifier.name, STRLENGTH (header.application_identifier.name),
                occ$end_of_line);
        IFEND;
      IFEND;
    IFEND;



  PROCEND display_identification;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_LIBRARY_MEMBER_HEADER' ??
?? EJECT ??

  PROCEDURE display_library_member_header (header: llt$library_member_header;
        kind: string ( * );
        display_toggles: oct$display_toggles);


    VAR
      availability_kinds: [STATIC, READ] llt$library_member_kinds := [llc$command_procedure,
        llc$program_description, llc$function_procedure, llc$applic_command_procedure,
        llc$applic_program_description, llc$applic_command_description, llc$command_description,
        llc$function_description],
      scope_kinds: [STATIC, READ] llt$library_member_kinds := [llc$command_procedure, llc$program_description,
        llc$function_procedure, llc$applic_command_procedure, llc$applic_program_description,
        llc$applic_command_description, llc$command_description, llc$function_description],
      log_option_kinds: [STATIC, READ] llt$library_member_kinds := [llc$command_procedure,
        llc$program_description, llc$applic_command_procedure, llc$applic_program_description,
        llc$applic_command_description, llc$command_description],
      ignore: boolean;


    IF display_toggles = $oct$display_toggles [] THEN
      ocp$output (occ$single_space, header.name, STRLENGTH (header.name), occ$end_of_line);

    ELSE
      IF display_toggles - $oct$display_toggles [occ$display_time_date] <> $oct$display_toggles [] THEN
        ocp$output (occ$double_space, ' ', 1, occ$end_of_line);
      IFEND;
      ocp$output (occ$single_space, header.name, STRLENGTH (header.name), occ$continue);
      ocp$output (' - ', kind, STRLENGTH (kind), occ$continue);

      IF (occ$display_time_date IN display_toggles) OR (occ$display_module_header IN display_toggles) THEN
        ocp$output ('', ' -', 2, occ$continue);
        ocp$output_time (^header.time_created, occ$continue, ignore);
        ocp$output_date (^header.date_created, occ$end_of_line, ignore);
      ELSE
        ocp$output ('', ' ', 1, occ$end_of_line);
      IFEND;


      IF occ$display_module_header IN display_toggles THEN
        ocp$output (' ', 'kind:', 5, occ$continue);
        ocp$output_library_member_kind (^header.kind, occ$continue, ignore);

        ocp$output ('  ', 'generator:', 10, occ$continue);
        ocp$output_module_generator (^header.generator_id, occ$end_of_line, ignore);

        ocp$output (' ', 'generator name version:', 23, occ$continue);
        ocp$output (' ', header.generator_name_vers, STRLENGTH (header.generator_name_vers), occ$end_of_line);

        IF header.commentary <> osc$null_name THEN
          ocp$output (' ', 'commentary:', 11, occ$continue);
          ocp$output (' ', header.commentary, STRLENGTH (header.commentary), occ$end_of_line);
        IFEND;

        IF header.kind IN availability_kinds THEN
          ocp$output (' ', 'availability:', 13, occ$continue);
          CASE header.command_function_availability OF
          = clc$normal_usage_entry =
            ocp$output (' ', 'NORMAL USAGE', 12, occ$end_of_line);
          = clc$advanced_usage_entry =
            ocp$output (' ', 'ADVANCED USAGE', 14, occ$end_of_line);
          = clc$hidden_entry =
            ocp$output (' ', 'HIDDEN', 6, occ$end_of_line);
          ELSE
          CASEND;
        IFEND;

        IF header.kind IN scope_kinds THEN
          ocp$output (' ', 'scope:', 6, occ$continue);
          CASE header.command_function_kind OF
          = llc$entry_point =
            ocp$output (' ', 'XDCL', 4, occ$end_of_line);
          = llc$gate =
            ocp$output (' ', 'GATE', 4, occ$end_of_line);
          = llc$local_to_library =
            ocp$output (' ', 'LOCAL', 5, occ$end_of_line);
          ELSE
          CASEND;
        IFEND;

        IF header.kind IN log_option_kinds THEN
          ocp$output (' ', 'log option:', 11, occ$continue);
          CASE header.command_log_option OF
          = clc$automatically_log =
            ocp$output (' ', 'AUTOMATIC', 9, occ$end_of_line);
          = clc$manually_log =
            ocp$output (' ', 'MANUAL', 6, occ$end_of_line);
          ELSE
          CASEND;
        IFEND;

      IFEND;
    IFEND;



  PROCEND display_library_member_header;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_LIBRARY_LIST' ??
?? EJECT ??

  PROCEDURE display_library_list (library_list: oct$name_list);


    VAR
      library: ^oct$name_list;


    library := library_list.link;

    IF library <> NIL THEN
      ocp$output ('0', 'libraries', 9, occ$end_of_line);
      ocp$output (' ', '~~~~~~~~~', 9, occ$end_of_line);

      REPEAT
        ocp$output ('   ', library^.name, STRLENGTH (library^.name), occ$continue);
        library := library^.link;

        IF library <> NIL THEN
          ocp$output ('  ', library^.name, STRLENGTH (library^.name), occ$continue);
          library := library^.link;
        IFEND;

        ocp$output ('', ' ', 1, occ$end_of_line);
      UNTIL library = NIL;
    IFEND;


  PROCEND display_library_list;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_ALIASES' ??
?? EJECT ??

  PROCEDURE display_aliases (aliases: oct$external_declaration_list);


    VAR
      next_alias: ^oct$external_declaration_list;


    next_alias := aliases.link;

    IF next_alias <> NIL THEN
      ocp$output ('0', 'aliases', 7, occ$end_of_line);
      ocp$output (' ', '~~~~~~~', 7, occ$end_of_line);

      REPEAT
        IF next_alias^.name <> osc$null_name THEN
          ocp$output ('   ', next_alias^.name, STRLENGTH (next_alias^.name), occ$end_of_line);
        IFEND;

        next_alias := next_alias^.link;
      UNTIL next_alias = NIL;
    IFEND;



  PROCEND display_aliases;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_XDCL_LIST' ??
?? EJECT ??

  PROCEDURE display_xdcl_list (xdcl_list: oct$external_declaration_list;
        starting_procedure: pmt$program_name;
        deferred_entry_point_list: oct$external_declaration_list);

    VAR
      deferred_entry_point: ^oct$external_declaration_list,
      x_dcl: ^oct$external_declaration_list;


    deferred_entry_point := deferred_entry_point_list.link;
    x_dcl := xdcl_list.link;

    IF (x_dcl <> NIL) OR (deferred_entry_point <> NIL) THEN
      ocp$output ('0', 'entry points', 12, occ$end_of_line);
      ocp$output (' ', '~~~~~~~~~~~~', 12, occ$end_of_line);

      IF x_dcl <> NIL THEN
        REPEAT
          IF x_dcl^.name <> osc$null_name THEN
            ocp$output ('   ', x_dcl^.name, STRLENGTH (x_dcl^.name), occ$continue);

            IF llc$gated_entry_point IN x_dcl^.attributes THEN
              ocp$output (' ', 'GATED', 5, occ$continue);
            ELSE
              ocp$output (' ', '     ', 5, occ$continue);
            IFEND;
            IF llc$retain_entry_point IN x_dcl^.attributes THEN
              ocp$output ('  ', 'RETAINED', 8, occ$continue);
            IFEND;
            ocp$output ('  ', ' ', 1, occ$end_of_line);
          IFEND;
          x_dcl := x_dcl^.link;
        UNTIL x_dcl = NIL;
      IFEND;

      IF deferred_entry_point <> NIL THEN
        REPEAT
          IF deferred_entry_point^.name <> osc$null_name THEN
            ocp$output ('   ', deferred_entry_point^.name, STRLENGTH (deferred_entry_point^.name),
                  occ$continue);

            IF llc$gated_entry_point IN deferred_entry_point^.attributes THEN
              ocp$output (' ', 'GATED', 5, occ$continue);
            ELSE
              ocp$output (' ', '     ', 5, occ$continue);
            IFEND;
            IF llc$retain_entry_point IN deferred_entry_point^.attributes THEN
              ocp$output ('  ', 'RETAINED', 8, occ$continue);
            ELSE
              ocp$output ('  ', '        ', 8, occ$continue);
            IFEND;
            ocp$output ('  ', 'DEFERRED', 8, occ$end_of_line);
          IFEND;
          deferred_entry_point := deferred_entry_point^.link;
        UNTIL deferred_entry_point = NIL;
      IFEND;
    IFEND;

    IF starting_procedure <> osc$null_name THEN
      ocp$output ('0', 'starting procedure:', 19, occ$continue);
      ocp$output (' ', starting_procedure, STRLENGTH (starting_procedure), occ$end_of_line);
    IFEND;


  PROCEND display_xdcl_list;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_XREF_LIST' ??
?? EJECT ??

  PROCEDURE display_xref_list (xref_list: oct$external_reference_list);


    VAR
      x_ref: ^oct$external_reference_list;


    x_ref := xref_list.link;

    IF x_ref <> NIL THEN
      ocp$output ('0', 'external references', 19, occ$end_of_line);
      ocp$output (' ', '~~~~~~~~~~~~~~~~~~~', 19, occ$end_of_line);

      REPEAT
        ocp$output ('   ', x_ref^.name, STRLENGTH (x_ref^.name), occ$continue);
        x_ref := x_ref^.link;

        IF x_ref <> NIL THEN
          ocp$output ('  ', x_ref^.name, STRLENGTH (x_ref^.name), occ$continue);
          x_ref := x_ref^.link;
        IFEND;

        ocp$output ('', ' ', 1, occ$end_of_line);
      UNTIL x_ref = NIL;
    IFEND;


  PROCEND display_xref_list;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_COMPONENT_DESCRIPTION' ??
?? EJECT ??

  PROCEDURE display_component_information (component: ^llt$component_information);


    VAR
      ignore: boolean,
      i: integer;


    ocp$output ('0', 'components', 10, occ$end_of_line);
    ocp$output (' ', '~~~~~~~~~~', 10, occ$end_of_line);

    FOR i := 1 TO UPPERBOUND (component^) DO
      ocp$output ('   ', 'component:', 10, occ$continue);
      ocp$output (' ', component^ [i].name, STRLENGTH (component^ [i].name), occ$end_of_line);

      ocp$output ('   ', 'created:  ', 10, occ$continue);
      ocp$output_time (^component^ [i].time_created, occ$continue, ignore);
      ocp$output_date (^component^ [i].date_created, occ$end_of_line, ignore);

      ocp$output ('   ', 'generator:', 10, occ$continue);
      ocp$output_module_generator (^component^ [i].generator_id, occ$end_of_line, ignore);

      ocp$output ('   ', 'generator name version:', 23, occ$continue);
      ocp$output (' ', component^ [i].generator_name_vers, STRLENGTH (component^ [i].generator_name_vers),
            occ$end_of_line);

      IF component^ [i].commentary <> osc$null_name THEN
        ocp$output ('   ', 'commentary:', 11, occ$continue);
        ocp$output (' ', component^ [i].commentary, STRLENGTH (component^ [i].commentary), occ$end_of_line);
      IFEND;

      IF i <> UPPERBOUND (component^) THEN
        ocp$output (' ', '  ', 2, occ$end_of_line);
      IFEND;
    FOREND;



  PROCEND display_component_information;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_PROGRAM_ATTRIBUTES' ??
?? EJECT ??

  PROCEDURE display_program_attributes (VAR module_description: oct$module_description;
        library_member_header: llt$library_member_header;
    VAR status: ost$status);


    VAR
      strng: string (120),
      l: integer,
      i: integer,

      member: ^llt$program_description,
      aliases: ^pmt$module_list,
      program_attributes: ^llt$program_attributes,
      conditions: ^pmt$enable_inhibit_conditions,
      object_file_list: ^llt$object_file_list,
      library_list: ^llt$object_library_list,
      module_list: ^pmt$module_list;


    IF library_member_header.number_of_aliases <> 0 THEN
      aliases := #PTR (library_member_header.aliases, module_description.file^);
      IF aliases = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);
        RETURN;
      IFEND;
    IFEND;

    member := #PTR (library_member_header.member, module_description.file^);
    IF member = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);
      RETURN;
    IFEND;

    RESET member;
    NEXT program_attributes IN member;
    IF program_attributes = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);
      RETURN;
    IFEND;

    IF (pmc$object_file_list_specified IN program_attributes^.contents) AND (program_attributes^.
          number_of_object_files <> 0) THEN
      NEXT object_file_list: [1 .. program_attributes^.number_of_object_files] IN member;
      IF object_file_list = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);
        RETURN;
      IFEND;

      ocp$output ('0', 'object file list', 16, occ$end_of_line);
      ocp$output (' ', '~~~~~~~~~~~~~~~~', 16, occ$end_of_line);
      FOR i := 1 TO program_attributes^.number_of_object_files DO
        ocp$output ('   ', object_file_list^ [i], STRLENGTH (object_file_list^ [i]), occ$end_of_line);
      FOREND;
    IFEND;
?? EJECT ??


    IF (pmc$module_list_specified IN program_attributes^.contents) AND (program_attributes^.number_of_modules
          <> 0) THEN
      NEXT module_list: [1 .. program_attributes^.number_of_modules] IN member;
      IF module_list = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);
        RETURN;
      IFEND;

      ocp$output ('0', 'module list', 11, occ$end_of_line);
      ocp$output (' ', '~~~~~~~~~~~', 11, occ$end_of_line);

      i := 1;
      FOR i := 1 TO program_attributes^.number_of_modules DO
        ocp$output ('   ', module_list^ [i], STRLENGTH (module_list^ [i]), occ$end_of_line);
      FOREND;
    IFEND;


    IF (pmc$library_list_specified IN program_attributes^.contents) AND (program_attributes^.
          number_of_libraries <> 0) THEN
      NEXT library_list: [1 .. program_attributes^.number_of_libraries] IN member;
      IF library_list = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);
        RETURN;
      IFEND;

      ocp$output ('0', 'library list', 12, occ$end_of_line);
      ocp$output (' ', '~~~~~~~~~~~~', 12, occ$end_of_line);

      FOR i := 1 TO program_attributes^.number_of_libraries DO
        ocp$output ('   ', library_list^ [i], STRLENGTH (library_list^ [i]), occ$end_of_line);
      FOREND;
    IFEND;

    ocp$output (' ', '  ', 2, occ$end_of_line);

?? EJECT ??

    IF (pmc$condition_specified IN program_attributes^.contents) THEN
      NEXT conditions IN member;
      IF conditions = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);
        RETURN;
      IFEND;

      ocp$output ('0', 'conditions', 10, occ$end_of_line);
      ocp$output (' ', '~~~~~~~~~~', 10, occ$end_of_line);

      IF pmc$arithmetic_overflow IN conditions^.enable_system_conditions THEN
        ocp$output ('   ', 'arithmetic overflow             :  ON', 37, occ$end_of_line);
      ELSEIF pmc$arithmetic_overflow IN conditions^.inhibit_system_conditions THEN
        ocp$output ('   ', 'arithmetic overflow             : OFF', 37, occ$end_of_line);
      IFEND;

      IF pmc$arithmetic_significance IN conditions^.enable_system_conditions THEN
        ocp$output ('   ', 'arithmetic loss of significance :  ON', 37, occ$end_of_line);
      ELSEIF pmc$arithmetic_significance IN conditions^.inhibit_system_conditions THEN
        ocp$output ('   ', 'arithmetic loss of significance : OFF', 37, occ$end_of_line);
      IFEND;

      IF pmc$divide_fault IN conditions^.enable_system_conditions THEN
        ocp$output ('   ', 'divide fault                    :  ON', 37, occ$end_of_line);
      ELSEIF pmc$divide_fault IN conditions^.inhibit_system_conditions THEN
        ocp$output ('   ', 'divide fault                    : OFF', 37, occ$end_of_line);
      IFEND;

      IF pmc$exponent_overflow IN conditions^.enable_system_conditions THEN
        ocp$output ('   ', 'exponent overflow               :  ON', 37, occ$end_of_line);
      ELSEIF pmc$exponent_overflow IN conditions^.inhibit_system_conditions THEN
        ocp$output ('   ', 'exponent overflow               : OFF', 37, occ$end_of_line);
      IFEND;

      IF pmc$exponent_underflow IN conditions^.enable_system_conditions THEN
        ocp$output ('   ', 'exponent underflow              :  ON', 37, occ$end_of_line);
      ELSEIF pmc$exponent_underflow IN conditions^.inhibit_system_conditions THEN
        ocp$output ('   ', 'exponent underflow              : OFF', 37, occ$end_of_line);
      IFEND;

      IF pmc$fp_indefinite IN conditions^.enable_system_conditions THEN
        ocp$output ('   ', 'fp indefinite                   :  ON', 37, occ$end_of_line);
      ELSEIF pmc$fp_indefinite IN conditions^.inhibit_system_conditions THEN
        ocp$output ('   ', 'fp indefinite                   : OFF', 37, occ$end_of_line);
      IFEND;

      IF pmc$fp_significance_loss IN conditions^.enable_system_conditions THEN
        ocp$output ('   ', 'fp loss of significnace         :  ON', 37, occ$end_of_line);
      ELSEIF pmc$fp_significance_loss IN conditions^.inhibit_system_conditions THEN
        ocp$output ('   ', 'fp loss of significance         : OFF', 37, occ$end_of_line);
      IFEND;

      IF pmc$invalid_bdp_data IN conditions^.enable_system_conditions THEN
        ocp$output ('   ', 'invalid BDP data                :  ON', 37, occ$end_of_line);
      ELSEIF pmc$invalid_bdp_data IN conditions^.inhibit_system_conditions THEN
        ocp$output ('   ', 'invalid BDP data                : OFF', 37, occ$end_of_line);
      IFEND;
    IFEND;

    ocp$output (' ', '  ', 2, occ$end_of_line);


    IF pmc$starting_proc_specified IN program_attributes^.contents THEN
      ocp$output (' ', 'starting procedure:', 19, occ$continue);
      ocp$output (' ', program_attributes^.starting_procedure, STRLENGTH (program_attributes^.
            starting_procedure), occ$end_of_line);
    IFEND;

?? EJECT ??
    IF pmc$load_map_file_specified IN program_attributes^.contents THEN
      ocp$output (' ', 'load map file:', 14, occ$continue);
      ocp$output (' ', program_attributes^.load_map_file, STRLENGTH (program_attributes^.load_map_file),
            occ$end_of_line);
    IFEND;

    IF pmc$load_map_options_specified IN program_attributes^.contents THEN
      ocp$output (' ', 'load map options: [', 19, occ$continue);

      IF pmc$no_load_map IN program_attributes^.load_map_options THEN
        ocp$output (' ', 'NONE', 4, occ$continue);
      IFEND;
      IF pmc$segment_map IN program_attributes^.load_map_options THEN
        ocp$output (' ', 'SEGMENT', 7, occ$continue);
      IFEND;
      IF pmc$block_map IN program_attributes^.load_map_options THEN
        ocp$output (' ', 'BLOCK', 5, occ$continue);
      IFEND;
      IF pmc$entry_point_map IN program_attributes^.load_map_options THEN
        ocp$output (' ', 'ENTRY_POINT', 11, occ$continue);
      IFEND;
      IF pmc$entry_point_xref IN program_attributes^.load_map_options THEN
        ocp$output (' ', 'XREF', 4, occ$continue);
      IFEND;

      ocp$output (' ', ']', 1, occ$end_of_line);
    IFEND;

    IF pmc$term_error_level_specified IN program_attributes^.contents THEN
      ocp$output (' ', 'termination error level:', 24, occ$continue);

      CASE program_attributes^.termination_error_level OF
      = pmc$warning_load_errors =
        ocp$output (' ', 'WARNING', 7, occ$end_of_line);
      = pmc$error_load_errors =
        ocp$output (' ', 'ERROR', 5, occ$end_of_line);
      = pmc$fatal_load_errors =
        ocp$output (' ', 'FATAL', 5, occ$end_of_line);
      ELSE
        ocp$output (' ', '*******', 7, occ$end_of_line);
      CASEND;
    IFEND;

?? EJECT ??
    IF pmc$preset_specified IN program_attributes^.contents THEN
      ocp$output (' ', 'preset value:', 13, occ$continue);

      CASE program_attributes^.preset OF
      = pmc$initialize_to_zero =
        ocp$output (' ', 'ZERO', 4, occ$end_of_line);
      = pmc$initialize_to_alt_ones =
        ocp$output (' ', 'ALTERNATE ONES', 14, occ$end_of_line);
      = pmc$initialize_to_indefinite =
        ocp$output (' ', 'FLOATING POINT INDEFINITE', 25, occ$end_of_line);
      = pmc$initialize_to_infinity =
        ocp$output (' ', 'INFINITY', 8, occ$end_of_line);
      ELSE
        ocp$output (' ', '******', 6, occ$end_of_line);
      CASEND;
    IFEND;

    IF pmc$max_stack_size_specified IN program_attributes^.contents THEN
      STRINGREP (strng, l, program_attributes^.maximum_stack_size);

      ocp$output (' ', 'stack size:', 11, occ$continue);
      ocp$output ('', strng, l, occ$end_of_line);
    IFEND;

    IF pmc$abort_file_specified IN program_attributes^.contents THEN
      ocp$output (' ', 'abort file:', 11, occ$continue);
      ocp$output (' ', program_attributes^.abort_file, STRLENGTH (program_attributes^.abort_file),
            occ$end_of_line);
    IFEND;

    IF pmc$debug_input_specified IN program_attributes^.contents THEN
      ocp$output (' ', 'debug input:', 12, occ$continue);
      ocp$output (' ', program_attributes^.debug_input, STRLENGTH (program_attributes^.debug_input),
            occ$end_of_line);
    IFEND;

    IF pmc$debug_output_specified IN program_attributes^.contents THEN
      ocp$output (' ', 'debug output:', 13, occ$continue);
      ocp$output (' ', program_attributes^.debug_output, STRLENGTH (program_attributes^.debug_output),
            occ$end_of_line);
    IFEND;

    IF pmc$debug_mode_specified IN program_attributes^.contents THEN
      IF program_attributes^.debug_mode THEN
        ocp$output (' ', 'debug mode: ON', 14, occ$end_of_line);
      ELSE
        ocp$output (' ', 'debug mode: OFF', 15, occ$end_of_line);
      IFEND;
    IFEND;


  PROCEND display_program_attributes;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_COMMAND_ATTRIBUTES' ??
?? EJECT ??

  PROCEDURE display_command_attributes
    (VAR module_description: oct$module_description;
         library_member_header: llt$library_member_header;
     VAR status: ost$status);

    VAR
      member: ^llt$command_description,
      aliases: ^pmt$module_list,
      command_attributes: ^llt$command_desc_contents,
      library_path: ^fst$file_reference;


    status.normal := TRUE;

    member := #PTR (library_member_header.member, module_description.file^);
    IF member = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);
      RETURN;
    IFEND;

    RESET member;
    NEXT command_attributes IN member;
    IF command_attributes = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);
      RETURN;
    IFEND;

    IF command_attributes^.system_command THEN
      ocp$output ('0', 'system command name:', 20, occ$continue);
      ocp$output (' ', command_attributes^.system_command_name, STRLENGTH (command_attributes^.
            system_command_name), occ$end_of_line);

    ELSE
      ocp$output ('0', 'starting procedure:', 19, occ$continue);
      ocp$output (' ', command_attributes^.starting_procedure, STRLENGTH (command_attributes^.
            starting_procedure), occ$end_of_line);

      IF command_attributes^.library_path_size > 0 THEN
        NEXT library_path: [command_attributes^.library_path_size] IN member;
        IF library_path = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);
          RETURN;
        IFEND;

        ocp$output ('0', 'library', 7, occ$end_of_line);
        ocp$output (' ', '~~~~~~~', 7, occ$end_of_line);

        ocp$output ('   ', library_path^, STRLENGTH (library_path^), occ$end_of_line);
      IFEND;
    IFEND;

  PROCEND display_command_attributes;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_FUNCTION_ATTRIBUTES' ??
?? EJECT ??

  PROCEDURE display_function_attributes
    (VAR module_description: oct$module_description;
         library_member_header: llt$library_member_header;
     VAR status: ost$status);

    VAR
      member: ^llt$function_description,
      aliases: ^pmt$module_list,
      function_attributes: ^llt$function_desc_contents,
      library_path: ^fst$file_reference;


    status.normal := TRUE;

    member := #PTR (library_member_header.member, module_description.file^);
    IF member = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);
      RETURN;
    IFEND;

    RESET member;
    NEXT function_attributes IN member;
    IF function_attributes = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);
      RETURN;
    IFEND;

    ocp$output ('0', 'starting procedure:', 19, occ$continue);
    ocp$output (' ', function_attributes^.starting_procedure, STRLENGTH (function_attributes^.
          starting_procedure), occ$end_of_line);

    IF function_attributes^.library_path_size > 0 THEN
      NEXT library_path: [function_attributes^.library_path_size] IN member;
      IF library_path = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, library_member_header.name, status);
        RETURN;
      IFEND;

      ocp$output ('0', 'library', 7, occ$end_of_line);
      ocp$output (' ', '~~~~~~~', 7, occ$end_of_line);

      ocp$output ('   ', library_path^, STRLENGTH (library_path^), occ$end_of_line);
    IFEND;

  PROCEND display_function_attributes;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_MSG_MODULE_ATTRIBUTES' ??
?? EJECT ??

  PROCEDURE display_msg_module_attributes (message_template_module: ^ost$message_template_module;
    VAR status: ost$status);

    VAR
      strng: string (255),
      length: integer,
      natural_language: ost$natural_language,
      online_manual: ost$online_manual_name,
      help_module: boolean,
      message_module: boolean,
      lowest_condition_code: ost$status_condition_code,
      highest_condition_code: ost$status_condition_code,
      condition_string: ost$string;


    clp$get_message_module_info (message_template_module, natural_language, online_manual, help_module,
          message_module, lowest_condition_code, highest_condition_code, status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$output ('0', 'module type:', 12, occ$continue);
    IF message_module AND help_module THEN
      ocp$output (' ', 'MESSAGE AND HELP MODULE', 23, occ$end_of_line);
    ELSEIF message_module THEN
      ocp$output (' ', 'MESSAGE MODULE', 14, occ$end_of_line);
    ELSEIF help_module THEN
      ocp$output (' ', 'HELP MODULE', 11, occ$end_of_line);
    IFEND;

    ocp$output (' ', 'natural language:', 17, occ$continue);
    ocp$output (' ', natural_language, STRLENGTH (natural_language), occ$end_of_line);

    ocp$output (' ', 'online manual:', 14, occ$continue);
    ocp$output (' ', online_manual, STRLENGTH (online_manual), occ$end_of_line);

    IF message_module THEN
      osp$get_status_condition_string (lowest_condition_code, condition_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      ocp$output (' ', 'lowest condition code:', 22, occ$continue);
      ocp$output (' ', condition_string.value, condition_string.size, occ$end_of_line);
      osp$get_status_condition_string (highest_condition_code, condition_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      ocp$output (' ', 'highest condition code:', 22, occ$continue);
      ocp$output (' ', condition_string.value, condition_string.size, occ$end_of_line);
    IFEND;

  PROCEND display_msg_module_attributes;
?? OLDTITLE ??

?? NEWTITLE := '  DISPLAY_CPU_OBJECT_MODULE' ??
?? EJECT ??

  PROCEDURE display_cpu_object_module (display_toggles: oct$display_toggles;
    VAR module_description: oct$module_description;
        changed_info: ^oct$changed_info;
    VAR status: ost$status);


    VAR
      deferred_entry_point_list: oct$external_declaration_list,
      header: oct$header,
      xdcl_list: oct$external_declaration_list,
      starting_procedure: pmt$program_name,
      xref_list: oct$external_reference_list,
      library_list: oct$name_list;


    ocp$obtain_header (module_description, changed_info, header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_identification (header, 'object module      ', display_toggles);

    IF occ$display_libraries IN display_toggles THEN
      ocp$obtain_library_list (module_description, changed_info, library_list, occ$no_retain, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_library_list (library_list);
    IFEND;

    IF occ$display_xdcls IN display_toggles THEN
      ocp$obtain_xdcl_list (changed_info, occ$no_retain, {obtain_deferred_entry_points} TRUE,
            module_description, xdcl_list, starting_procedure, deferred_entry_point_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_xdcl_list (xdcl_list, starting_procedure, deferred_entry_point_list);
    IFEND;

    IF occ$display_xrefs IN display_toggles THEN
      ocp$obtain_xref_list (module_description, xref_list, occ$no_retain, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_xref_list (xref_list);
    IFEND;


  PROCEND display_cpu_object_module;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_LOAD_MODULE' ??
?? EJECT ??

  PROCEDURE display_load_module (display_toggles: oct$display_toggles;
    VAR module_description: oct$module_description;
        changed_info: ^oct$changed_info;
    VAR status: ost$status);


    VAR
      deferred_entry_point_list: oct$external_declaration_list,
      header: oct$header,
      xdcl_list: oct$external_declaration_list,
      starting_procedure: pmt$program_name,
      xref_list: oct$external_reference_list,
      library_list: oct$name_list,
      component_info: ^llt$component_information;


    ocp$obtain_header (module_description, changed_info, header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_identification (header, 'load module        ', display_toggles);

    IF occ$display_libraries IN display_toggles THEN
      ocp$obtain_library_list (module_description, changed_info, library_list, occ$no_retain, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_library_list (library_list);
    IFEND;

    IF occ$display_xdcls IN display_toggles THEN
      ocp$obtain_xdcl_list (changed_info, occ$no_retain, {obtain_deferred_entry_points} TRUE,
            module_description, xdcl_list, starting_procedure, deferred_entry_point_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_xdcl_list (xdcl_list, starting_procedure, deferred_entry_point_list);
    IFEND;

    IF occ$display_xrefs IN display_toggles THEN
      ocp$obtain_xref_list (module_description, xref_list, occ$no_retain, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_xref_list (xref_list);
    IFEND;
?? EJECT ??
    IF occ$display_component_info IN display_toggles THEN
      ocp$obtain_component_info (module_description, component_info, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF component_info <> NIL THEN
        display_component_information (component_info);
      IFEND;
    IFEND;


  PROCEND display_load_module;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_PPU_OBJECT_MODULE' ??
?? EJECT ??

  PROCEDURE display_ppu_object_module (display_toggles: oct$display_toggles;
    VAR module_description: oct$module_description;
        changed_info: ^oct$changed_info;
    VAR status: ost$status);


    VAR
      header: oct$header;


    ocp$obtain_header (module_description, changed_info, header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_identification (header, 'ppu module         ', display_toggles);


  PROCEND display_ppu_object_module;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_PROGRAM_DESCRIPTION' ??
?? EJECT ??

  PROCEDURE display_program_description (display_toggles: oct$display_toggles;
    VAR module_description: oct$module_description;
        changed_info: ^oct$changed_info;
    VAR status: ost$status);


    VAR
      deferred_entry_point_list: oct$external_declaration_list,
      header: oct$header,
      alias_list: oct$external_declaration_list,
      starting_procedure: pmt$program_name;


    ocp$obtain_header (module_description, changed_info, header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_library_member_header (header.library_member_header, 'program description', display_toggles);

    IF occ$display_xdcls IN display_toggles THEN
      ocp$obtain_xdcl_list (changed_info, occ$no_retain, {obtain_deferred_entry_points} FALSE,
            module_description, alias_list, starting_procedure, deferred_entry_point_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_aliases (alias_list);
    IFEND;

    IF occ$display_module_header IN display_toggles THEN
      display_program_attributes (module_description, header.library_member_header, status);
    IFEND;


  PROCEND display_program_description;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_COMMAND_PROCEDURE' ??
?? EJECT ??

  PROCEDURE display_command_procedure (display_toggles: oct$display_toggles;
    VAR module_description: oct$module_description;
        changed_info: ^oct$changed_info;
    VAR status: ost$status);


    VAR
      deferred_entry_point_list: oct$external_declaration_list,
      header: oct$header,
      alias_list: oct$external_declaration_list,
      starting_procedure: pmt$program_name,
      command_procedure: ^SEQ ( * );


    ocp$obtain_header (module_description, changed_info, header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_library_member_header (header.library_member_header, 'command procedure  ', display_toggles);

    IF occ$display_module_header IN display_toggles THEN
      ocp$output ('0', 'parameters', 10, occ$end_of_line);
      ocp$output (' ', '~~~~~~~~~~', 10, occ$end_of_line);
      command_procedure := #PTR (module_description.command_procedure_header^.member, module_description.
            file^);
      ocp$output_scl_parameters (command_procedure, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF occ$display_xdcls IN display_toggles THEN
      ocp$obtain_xdcl_list (changed_info, occ$no_retain, {obtain_deferred_entry_points} FALSE,
            module_description, alias_list, starting_procedure, deferred_entry_point_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_aliases (alias_list);
    IFEND;


  PROCEND display_command_procedure;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_COMMAND_DESCRIPTION' ??
?? EJECT ??

  PROCEDURE display_command_description (display_toggles: oct$display_toggles;
    VAR module_description: oct$module_description;
        changed_info: ^oct$changed_info;
    VAR status: ost$status);


    VAR
      deferred_entry_point_list: oct$external_declaration_list,
      header: oct$header,
      alias_list: oct$external_declaration_list,
      starting_procedure: pmt$program_name;


    ocp$obtain_header (module_description, changed_info, header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_library_member_header (header.library_member_header, 'command description', display_toggles);

    IF occ$display_xdcls IN display_toggles THEN
      ocp$obtain_xdcl_list (changed_info, occ$no_retain, {obtain_deferred_entry_points} FALSE,
            module_description, alias_list, starting_procedure, deferred_entry_point_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_aliases (alias_list);
    IFEND;

    IF occ$display_module_header IN display_toggles THEN
      display_command_attributes (module_description, header.library_member_header, status);
    IFEND;

  PROCEND display_command_description;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_FUNCTION_PROCEDURE' ??
?? EJECT ??

  PROCEDURE display_function_procedure (display_toggles: oct$display_toggles;
    VAR module_description: oct$module_description;
        changed_info: ^oct$changed_info;
    VAR status: ost$status);


    VAR
      deferred_entry_point_list: oct$external_declaration_list,
      header: oct$header,
      alias_list: oct$external_declaration_list,
      starting_procedure: pmt$program_name,
      function_procedure: ^SEQ ( * );


    ocp$obtain_header (module_description, changed_info, header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_library_member_header (header.library_member_header, 'function procedure ', display_toggles);

    IF occ$display_module_header IN display_toggles THEN
      ocp$output ('0', 'parameters', 10, occ$end_of_line);
      ocp$output (' ', '~~~~~~~~~~', 10, occ$end_of_line);
      function_procedure := #PTR (module_description.function_procedure_header^.member, module_description.
            file^);
      ocp$output_scl_parameters (function_procedure, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF occ$display_xdcls IN display_toggles THEN
      ocp$obtain_xdcl_list (changed_info, occ$no_retain, {obtain_deferred_entry_points} FALSE,
            module_description, alias_list, starting_procedure, deferred_entry_point_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_aliases (alias_list);
    IFEND;


  PROCEND display_function_procedure;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_FUNCTION_DESCRIPTION' ??
?? EJECT ??

  PROCEDURE display_function_description (display_toggles: oct$display_toggles;
    VAR module_description: oct$module_description;
        changed_info: ^oct$changed_info;
    VAR status: ost$status);


    VAR
      deferred_entry_point_list: oct$external_declaration_list,
      header: oct$header,
      alias_list: oct$external_declaration_list,
      starting_procedure: pmt$program_name;


    ocp$obtain_header (module_description, changed_info, header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_library_member_header (header.library_member_header, 'function desc      ', display_toggles);

    IF occ$display_xdcls IN display_toggles THEN
      ocp$obtain_xdcl_list (changed_info, occ$no_retain, {obtain_deferred_entry_points} FALSE,
            module_description, alias_list, starting_procedure, deferred_entry_point_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_aliases (alias_list);
    IFEND;

    IF occ$display_module_header IN display_toggles THEN
      display_function_attributes (module_description, header.library_member_header, status);
    IFEND;

  PROCEND display_function_description;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_MESSAGE_MODULE' ??
?? EJECT ??

  PROCEDURE display_message_module (display_toggles: oct$display_toggles;
    VAR module_description: oct$module_description;
        changed_info: ^oct$changed_info;
    VAR status: ost$status);


    VAR
      message_template_module: ^ost$message_template_module,
      header: oct$header;


    ocp$obtain_header (module_description, changed_info, header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_library_member_header (header.library_member_header, 'message module     ', display_toggles);

    IF occ$display_module_header IN display_toggles THEN
      ocp$output ('0', 'message module attributes', 25, occ$end_of_line);
      ocp$output (' ', '~~~~~~~~~~~~~~~~~~~~~~~~~', 25, occ$end_of_line);
      message_template_module := #PTR (module_description.message_module_header^.member, module_description.
            file^);
      IF message_template_module = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_premature_eof_in_module, header.library_member_header.name,
              status);
        RETURN;
      IFEND;
      display_msg_module_attributes (message_template_module, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;


  PROCEND display_message_module;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_PANEL_MODULE' ??
?? EJECT ??

  PROCEDURE display_panel_module (display_toggles: oct$display_toggles;
    VAR module_description: oct$module_description;
        changed_info: ^oct$changed_info;
    VAR status: ost$status);


    VAR
      header: oct$header;


    ocp$obtain_header (module_description, changed_info, header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_library_member_header (header.library_member_header, 'form module        ', display_toggles);


  PROCEND display_panel_module;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_APPLIC_PROGRAM_DESCRIP' ??
?? EJECT ??

  PROCEDURE display_applic_program_descrip (display_toggles: oct$display_toggles;
        changed_info: ^oct$changed_info;
    VAR module_description: oct$module_description;
    VAR status: ost$status);

    VAR
      alias_list: oct$external_declaration_list,
      deferred_entry_point_list: oct$external_declaration_list,
      header: oct$header,
      starting_procedure: pmt$program_name;

    ocp$obtain_header (module_description, changed_info, header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_library_member_header (header.application_member_header.library_member_header,
      'applic program desc', display_toggles);

    IF occ$display_xdcls IN display_toggles THEN
      ocp$obtain_xdcl_list (changed_info, occ$no_retain, {obtain_deferred_entry_points} FALSE,
            module_description, alias_list, starting_procedure, deferred_entry_point_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_aliases (alias_list);
    IFEND;

    IF occ$display_module_header IN display_toggles THEN
      display_program_attributes (module_description, header.application_member_header.
            library_member_header, status);

      ocp$output (' ', 'application identifier:', 23, occ$continue);
      ocp$output (' ', header.application_member_header.application_identifier.name, STRLENGTH (
            header.application_member_header.application_identifier.name), occ$end_of_line);
    IFEND;

  PROCEND display_applic_program_descrip;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_APPLIC_COMMAND_PROC' ??
?? EJECT ??

  PROCEDURE display_applic_command_proc (display_toggles: oct$display_toggles;
        changed_info: ^oct$changed_info;
    VAR module_description: oct$module_description;
    VAR status: ost$status);

    VAR
      deferred_entry_point_list: oct$external_declaration_list,
      alias_list: oct$external_declaration_list,
      command_procedure: ^SEQ ( * ),
      header: oct$header,
      starting_procedure: pmt$program_name;

    ocp$obtain_header (module_description, changed_info, header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_library_member_header (header.application_member_header.library_member_header,
      'applic command proc', display_toggles);

    IF occ$display_module_header IN display_toggles THEN
      ocp$output ('0', 'parameters', 10, occ$end_of_line);
      ocp$output (' ', '~~~~~~~~~~', 10, occ$end_of_line);
      command_procedure := #PTR (module_description.applic_command_procedure_header^.library_member_header.
            member, module_description.file^);
      ocp$output_scl_parameters (command_procedure, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF occ$display_xdcls IN display_toggles THEN
      ocp$obtain_xdcl_list (changed_info, occ$no_retain, {obtain_deferred_entry_points} FALSE,
            module_description, alias_list, starting_procedure, deferred_entry_point_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_aliases (alias_list);
    IFEND;

    IF occ$display_module_header IN display_toggles THEN
      ocp$output ('0', 'application identifier:', 23, occ$continue);
      ocp$output (' ', header.application_member_header.application_identifier.name, STRLENGTH (
            header.application_member_header.application_identifier.name), occ$end_of_line);
    IFEND;

  PROCEND display_applic_command_proc;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_APPLIC_COMMAND_DESCRIP' ??
?? EJECT ??

  PROCEDURE display_applic_command_descrip (display_toggles: oct$display_toggles;
        changed_info: ^oct$changed_info;
    VAR module_description: oct$module_description;
    VAR status: ost$status);

    VAR
      alias_list: oct$external_declaration_list,
      deferred_entry_point_list: oct$external_declaration_list,
      header: oct$header,
      starting_procedure: pmt$program_name;

    ocp$obtain_header (module_description, changed_info, header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_library_member_header (header.application_member_header.library_member_header,
      'applic command desc', display_toggles);

    IF occ$display_xdcls IN display_toggles THEN
      ocp$obtain_xdcl_list (changed_info, occ$no_retain, {obtain_deferred_entry_points} FALSE,
            module_description, alias_list, starting_procedure, deferred_entry_point_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_aliases (alias_list);
    IFEND;

    IF occ$display_module_header IN display_toggles THEN
      display_command_attributes (module_description, header.application_member_header.
            library_member_header, status);

      ocp$output (' ', 'application identifier:', 23, occ$continue);
      ocp$output (' ', header.application_member_header.application_identifier.name, STRLENGTH (
            header.application_member_header.application_identifier.name), occ$end_of_line);
    IFEND;

  PROCEND display_applic_command_descrip;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$DISPLAY_MODULE', EJECT ??

  PROCEDURE [XDCL] ocp$display_module (display_toggles: oct$display_toggles;
    VAR module_description: oct$module_description;
        changed_info: ^oct$changed_info;
    VAR status: ost$status);


    CASE module_description.kind OF
    = occ$cpu_object_module =
      display_cpu_object_module (display_toggles, module_description, changed_info, status);
    = occ$ppu_object_module =
      display_ppu_object_module (display_toggles, module_description, changed_info, status);
    = occ$load_module, occ$bound_module =
      display_load_module (display_toggles, module_description, changed_info, status);
    = occ$program_description =
      IF (changed_info <> NIL) AND (changed_info^.application_identifier <> NIL) AND (changed_info^.
            application_identifier^.name <> osc$null_name) THEN
        display_applic_program_descrip (display_toggles, changed_info, module_description, status);
      ELSE
        display_program_description (display_toggles, module_description, changed_info, status);
      IFEND;
    = occ$command_procedure =
      IF (changed_info <> NIL) AND (changed_info^.application_identifier <> NIL) AND (changed_info^.
            application_identifier^.name <> osc$null_name) THEN
        display_applic_command_proc (display_toggles, changed_info, module_description, status);
      ELSE
        display_command_procedure (display_toggles, module_description, changed_info, status);
      IFEND;
    = occ$command_description =
      IF (changed_info <> NIL) AND (changed_info^.application_identifier <> NIL) AND (changed_info^.
            application_identifier^.name <> osc$null_name) THEN
        display_applic_command_descrip (display_toggles, changed_info, module_description, status);
      ELSE
        display_command_description (display_toggles, module_description, changed_info, status);
      IFEND;
    = occ$function_procedure =
      display_function_procedure (display_toggles, module_description, changed_info, status);
    = occ$function_description =
      display_function_description (display_toggles, module_description, changed_info, status);
    = occ$message_module =
      display_message_module (display_toggles, module_description, changed_info, status);
    = occ$panel_module =
      display_panel_module (display_toggles, module_description, changed_info, status);
    = occ$applic_program_description =
      IF (changed_info <> NIL) AND (changed_info^.application_identifier <> NIL) AND (changed_info^.
            application_identifier^.name = osc$null_name) THEN
        display_program_description (display_toggles, module_description, changed_info, status);
      ELSE
        display_applic_program_descrip (display_toggles, changed_info, module_description, status);
      IFEND;
    = occ$applic_command_procedure =
      IF (changed_info <> NIL) AND (changed_info^.application_identifier <> NIL) AND (changed_info^.
            application_identifier^.name = osc$null_name) THEN
        display_command_procedure (display_toggles, module_description, changed_info, status);
      ELSE
        display_applic_command_proc (display_toggles, changed_info, module_description, status);
      IFEND;
    = occ$applic_command_description =
      IF (changed_info <> NIL) AND (changed_info^.application_identifier <> NIL) AND (changed_info^.
            application_identifier^.name = osc$null_name) THEN
        display_command_description (display_toggles, module_description, changed_info, status);
      ELSE
        display_applic_command_descrip (display_toggles, changed_info, module_description, status);
      IFEND;
    CASEND;

  PROCEND ocp$display_module;

MODEND ocm$display_module;
*DECK DECK=OCM$DISPLAY_NEW_LIBRARY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
?? EJECT ??
MODULE ocm$display_new_library;



{ PURPOSE:
{   To display information about all or
{   part of the contents of a object
{   file or library.


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc oce$library_generator_errors
*copyc oct$open_file_list
?? POP ??
*copyc clp$evaluate_parameters
*copyc ifp$discard_suspended_output
*copyc ocp$close_output_file
*copyc ocp$display_module
*copyc ocp$generate_message
*copyc ocp$obtain_library_list
*copyc ocp$obtain_object_file
*copyc ocp$open_output_file
*copyc ocp$output
*copyc ocp$search_nlm_tree
*copyc ocp$search_object_file
*copyc ocp$search_open_file_list
*copyc ocp$sort_name_list
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$establish_condition_handler
*copyc ocv$global_display_toggles
*copyc ocv$nlm_list
*copyc ocv$olg_scratch_seq
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    command_status: ost$status;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$_display_new_library', EJECT ??

  PROCEDURE [XDCL] ocp$_display_new_library
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? NEWTITLE := 'display_module_list' ??
?? NEWTITLE := 'terminate_display_module', EJECT ??

    PROCEDURE display_module_list
      (    module_list: oct$name_list;
           display_toggles: oct$display_toggles;
       VAR status: ost$status);

      VAR
        term_dm_established_descriptor: pmt$established_handler;


      PROCEDURE terminate_display_module
        (    condition: pmt$condition;
             condition_descriptor: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR condition_status: ost$status);


        VAR
          ignore_status: ost$status;


        ifp$discard_suspended_output;

        status.normal := TRUE;
        osp$set_status_abnormal (oc, oce$e_some_modules_not, 'displayed', command_status);

        EXIT display_module_list;


      PROCEND terminate_display_module;
?? OLDTITLE ??
?? EJECT ??

      VAR
        current_module: ^oct$name_list,
        nlm: ^oct$new_library_module_list,
        terminate_condition: pmt$condition,
        dummy: boolean;

      terminate_condition.selector := ifc$interactive_condition;

      pmp$establish_condition_handler (terminate_condition, ^terminate_display_module,
            ^term_dm_established_descriptor, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


      IF (display_toggles - $oct$display_toggles [occ$display_time_date]) = $oct$display_toggles [] THEN
        ocp$output (occ$single_space, ' ', 1, occ$end_of_line);
      IFEND;


      current_module := module_list.link;

      WHILE current_module <> NIL DO
        ocp$search_nlm_tree (current_module^.name, nlm, dummy);

        ocp$display_module (display_toggles, nlm^.description^, nlm^.changed_info, status);
        IF NOT status.normal THEN
          ocp$generate_message (status);
          osp$set_status_abnormal (oc, oce$e_some_modules_not, 'displayed', command_status);
        IFEND;

        current_module := current_module^.link;
      WHILEND;


      ocp$output (occ$single_space, ' ', 1, occ$end_of_line);


    PROCEND display_module_list;
?? OLDTITLE ??
?? NEWTITLE := 'collect_modules_from_current' ??
?? EJECT ??

    PROCEDURE collect_modules_from_current
      (    first_module: pmt$program_name;
           last_module: pmt$program_name;
       VAR module_list: oct$name_list;
       VAR status: ost$status);


      VAR
        nlm: ^oct$new_library_module_list,
        module_found: boolean,
        current_module: pmt$program_name,

        last_old_module: ^oct$name_list,
        last_new_module: ^oct$name_list;




      last_old_module := ^module_list;
      WHILE last_old_module^.link <> NIL DO
        last_old_module := last_old_module^.link;
      WHILEND;
      last_new_module := last_old_module;


      ocp$search_nlm_tree (first_module, nlm, module_found);
      IF NOT module_found THEN
        IF first_module = last_module THEN
          osp$set_status_abnormal (oc, oce$w_module_not_found, first_module, status);
        ELSE
          osp$set_status_abnormal (oc, oce$w_subrange_module_not_found, first_module, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, last_module, status);
        IFEND;
        ocp$generate_message (status);
        osp$set_status_abnormal (oc, oce$e_some_modules_not, 'displayed', command_status);
        RETURN;
      IFEND;

      REPEAT
        IF nlm^.name = osc$null_name THEN
          IF last_module <> osc$null_name THEN
            osp$set_status_abnormal (oc, oce$e_range_module_2_not_found, last_module, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);
            ocp$generate_message (status);
            osp$set_status_abnormal (oc, oce$e_some_modules_not, 'displayed', command_status);
            last_old_module^.link := NIL;
          IFEND;
          RETURN;
        IFEND;

        current_module := nlm^.name;

        NEXT last_new_module^.link IN ocv$olg_scratch_seq;
        last_new_module := last_new_module^.link;
        IF last_new_module = NIL THEN
          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
          RETURN;
        IFEND;

        last_new_module^.name := current_module;
        last_new_module^.link := NIL;

        nlm := nlm^.f_link;
      UNTIL current_module = last_module;



    PROCEND collect_modules_from_current;
?? OLDTITLE ??
?? EJECT ??

{ PROCEDURE (ocm$creol_disnl) display_new_library, disnl (
{   module, modules, m: any of
{       list of program_name
{       list of range of program_name
{     anyend = $optional
{   display_option, display_options, do: any of
{       key
{         all, none
{       keyend
{       list of key
{         (component, c)
{         (date_time, dt)
{         (entry_point, ep)
{         (header, h)
{         (libraries, library, l)
{         (reference, r)
{       keyend
{     anyend = date_time
{   output, o: file = $output
{   alphabetical_order, ao: boolean = false
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
      recend,
      type2: 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 .. 2] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 13] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (9),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 6, 16, 42, 29, 479],
    clc$command, 11, 5, 0, 0, 0, 0, 5, 'OCM$CREOL_DISNL'], [
    ['ALPHABETICAL_ORDER             ',clc$nominal_entry, 4],
    ['AO                             ',clc$abbreviation_entry, 4],
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['M                              ',clc$abbreviation_entry, 1],
    ['MODULE                         ',clc$nominal_entry, 1],
    ['MODULES                        ',clc$alias_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 65, clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 605, clc$optional_default_parameter, 0, 9],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 5],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$list_type],
    FALSE, 2],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$program_name_type]]
      ],
    26, [[1, 0, clc$list_type], [10, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$range_type], [3],
          [[1, 0, clc$program_name_type]]
        ]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    504, [[1, 0, clc$list_type], [488, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [13], [
        ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['COMPONENT                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['DATE_TIME                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['DT                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['ENTRY_POINT                    ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['EP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['H                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['HEADER                         ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['LIBRARIES                      ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['LIBRARY                        ', clc$alias_entry,
  clc$normal_usage_entry, 5],
        ['R                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['REFERENCE                      ', clc$nominal_entry,
  clc$normal_usage_entry, 6]]
        ]
      ]
    ,
    'date_time'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$module = 1,
      p$display_option = 2,
      p$output = 3,
      p$alphabetical_order = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      first_module: pmt$program_name,
      ignore_status: ost$status,
      last_module: pmt$program_name,
      module_list: oct$name_list,
      node: ^clt$data_value,
      page_header: string (33),
      toggles: oct$display_toggles;

    status.normal := TRUE;
    command_status.normal := TRUE;

    RESET ocv$olg_scratch_seq;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    page_header := 'Display of CURRENT Object Library';
    ocp$open_output_file (pvt [p$output].value^.file_value^, ^page_header, status);
    IF NOT status.normal THEN
      ocp$close_output_file (ignore_status);
      RETURN;
    IFEND;

    IF pvt [p$display_option].specified THEN
      toggles := $oct$display_toggles [];
      IF pvt [p$display_option].value^.kind = clc$keyword THEN
        IF pvt [p$display_option].value^.keyword_value = 'ALL' THEN
          toggles := -$oct$display_toggles [];
        ELSE { none
          toggles := $oct$display_toggles [];
        IFEND;
      ELSE { list of keywords
        node := pvt [p$display_option].value;
        WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
          CASE node^.element_value^.keyword_value (1) OF
          = 'C' =
            toggles := toggles + $oct$display_toggles [occ$display_component_info];
          = 'L' =
            toggles := toggles + $oct$display_toggles [occ$display_libraries];
          = 'D' =
            toggles := toggles + $oct$display_toggles [occ$display_time_date];
          = 'E' =
            toggles := toggles + $oct$display_toggles [occ$display_xdcls];
          = 'H' =
            toggles := toggles + $oct$display_toggles [occ$display_module_header];
          = 'R' =
            toggles := toggles + $oct$display_toggles [occ$display_xrefs];
          CASEND;
          node := node^.link;
        WHILEND;
      IFEND;
    ELSE
      toggles := ocv$global_display_toggles;
    IFEND;

    module_list.link := NIL;
    IF pvt [p$module].specified THEN
      node := pvt [p$module].value;

      WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
        IF node^.element_value^.kind = clc$range THEN
          first_module := node^.element_value^.low_value^.program_name_value;
          last_module := node^.element_value^.high_value^.program_name_value;
        ELSE
          first_module := node^.element_value^.program_name_value;
          last_module := first_module;
        IFEND;
        collect_modules_from_current (first_module, last_module, module_list, status);
        IF NOT status.normal THEN
          ocp$close_output_file (ignore_status);
          RETURN;
        IFEND;
        node := node^.link;
      WHILEND;
    ELSE
      IF ocv$nlm_list^.f_link^.name = osc$null_name THEN
        osp$set_status_condition (oce$w_no_modules_on_current_lib, status);
        RETURN;
      IFEND;

      first_module := ocv$nlm_list^.f_link^.name;
      last_module := ocv$nlm_list^.b_link^.name;

      collect_modules_from_current (first_module, last_module, module_list, status);
      IF NOT status.normal THEN
        ocp$close_output_file (ignore_status);
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$alphabetical_order].value^.boolean_value.value THEN
      ocp$sort_name_list (module_list);
    IFEND;

    display_module_list (module_list, toggles, status);
    IF NOT status.normal THEN
      ocp$close_output_file (ignore_status);
      RETURN;
    IFEND;

    ocp$close_output_file (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    status := command_status;


  PROCEND ocp$_display_new_library;
?? OLDTITLE ??
MODEND ocm$display_new_library;
*DECK DECK=OCM$DISPLAY_OBJECT_LIBRARY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
?? EJECT ??
MODULE ocm$display_object_library;



{ PURPOSE:
{   To display information about all or
{   part of the contents of a object
{   file or library.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc oce$library_generator_errors
*copyc oct$display_toggles
?? POP ??
*copyc clp$evaluate_parameters
*copyc ocp$close_all_open_files
*copyc ocp$close_output_file
*copyc ocp$display_module
*copyc ocp$generate_message
*copyc ocp$initialize_oc_environment
*copyc ocp$obtain_object_file
*copyc ocp$open_output_file
*copyc ocp$output
*copyc ocp$search_object_file
*copyc ocp$search_open_file_list
*copyc ocp$sort_name_list
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc pmp$get_last_path_name
*copyc ocv$nlm_list
*copyc ocv$olg_scratch_seq
*copyc ocv$olg_working_heap
*copyc ocv$open_file_list
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    command_status: ost$status;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$_display_object_library', EJECT ??

  PROCEDURE [XDCL, #GATE] ocp$_display_object_library
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? NEWTITLE := 'display_module_list', EJECT ??

    PROCEDURE display_module_list
      (    module_list: oct$name_list;
       VAR input_file: ^oct$open_file_list;
           display_toggles: oct$display_toggles;
       VAR status: ost$status);


      VAR
        current_module: ^oct$name_list,
        dummy: boolean;


      IF (display_toggles - $oct$display_toggles [occ$display_time_date]) = $oct$display_toggles [] THEN
        ocp$output (occ$single_space, ' ', 1, occ$end_of_line);
      IFEND;


      current_module := module_list.link;

      WHILE current_module <> NIL DO
        input_file^.current_module := 1;

        ocp$search_object_file (current_module^.name, dummy, input_file);

        ocp$display_module (display_toggles, input_file^.directory^ [input_file^.current_module],
              NIL, status);
        IF NOT status.normal THEN
          ocp$generate_message (status);
          osp$set_status_abnormal (oc, oce$e_some_modules_not, 'displayed', command_status);
        IFEND;

        current_module := current_module^.link;
      WHILEND;


      ocp$output (occ$single_space, ' ', 1, occ$end_of_line);


    PROCEND display_module_list;
?? OLDTITLE ??
?? NEWTITLE := 'collect_modules_from_external' ??
?? EJECT ??

    PROCEDURE collect_modules_from_external
      (    first_module: pmt$program_name;
           last_module: pmt$program_name;
       VAR input_file: ^oct$open_file_list;
       VAR last_module_in_list: ^oct$name_list;
       VAR status: ost$status);


      VAR
        module_found: boolean,
        current_module: pmt$program_name,

        last_old_module: ^oct$name_list,
        last_new_module: ^oct$name_list;


      last_old_module := ^module_list;
      WHILE last_old_module^.link <> NIL DO
        last_old_module := last_old_module^.link;
      WHILEND;
      last_new_module := last_old_module;


      input_file^.current_module := 1;

      ocp$search_object_file (first_module, module_found, input_file);
      IF NOT module_found THEN
        IF first_module = last_module THEN
          osp$set_status_abnormal (oc, oce$w_module_not_found, first_module, status);
        ELSE
          osp$set_status_abnormal (oc, oce$w_subrange_module_not_found, first_module, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, last_module, status);
        IFEND;
        ocp$generate_message (status);
        osp$set_status_abnormal (oc, oce$e_some_modules_not, 'displayed', command_status);
        RETURN;
      IFEND;
?? EJECT ??

      REPEAT
        IF input_file^.current_module > UPPERBOUND (input_file^.directory^) THEN
          IF last_module <> osc$null_name THEN
            osp$set_status_abnormal (oc, oce$e_range_module_2_not_found, last_module, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);
            ocp$generate_message (status);
            osp$set_status_abnormal (oc, oce$e_some_modules_not, 'displayed', command_status);
            last_old_module^.link := NIL;
          IFEND;
          RETURN;
        IFEND;

        current_module := input_file^.directory^ [input_file^.current_module].name;

        NEXT last_module_in_list^.link IN ocv$olg_scratch_seq;
        last_module_in_list := last_module_in_list^.link;
        IF last_module_in_list = NIL THEN
          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
          RETURN;
        IFEND;

        last_module_in_list^.name := current_module;
        last_module_in_list^.link := NIL;

        input_file^.current_module := input_file^.current_module + 1;
      UNTIL current_module = last_module;



    PROCEND collect_modules_from_external;
?? OLDTITLE ??
?? EJECT ??

{ PROCEDURE (ocm$disol) display_object_library, disol (
{   library, l: file = $required
{   module, modules, m: any of
{       list of program_name
{       list of range of program_name
{     anyend = $optional
{   display_option, display_options, do: any of
{       key
{         all, none
{       keyend
{       list of key
{         (component, c)
{         (date_time, dt)
{         (entry_point, ep)
{         (header, h)
{         (libraries, library, l)
{         (reference, r)
{       keyend
{     anyend = date_time
{   output, o: file = $output
{   alphabetical_order, ao: boolean = false
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
      recend,
      type3: 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 .. 2] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 13] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (9),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 5, 13, 14, 59, 563],
    clc$command, 13, 6, 1, 0, 0, 0, 6, 'OCM$DISOL'], [
    ['ALPHABETICAL_ORDER             ',clc$nominal_entry, 5],
    ['AO                             ',clc$abbreviation_entry, 5],
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 3],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 3],
    ['DO                             ',clc$abbreviation_entry, 3],
    ['L                              ',clc$abbreviation_entry, 1],
    ['LIBRARY                        ',clc$nominal_entry, 1],
    ['M                              ',clc$abbreviation_entry, 2],
    ['MODULE                         ',clc$nominal_entry, 2],
    ['MODULES                        ',clc$alias_entry, 2],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OUTPUT                         ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 65, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 605, clc$optional_default_parameter, 0, 9],
{ PARAMETER 4
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 5],
{ PARAMETER 6
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$list_type],
    FALSE, 2],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$program_name_type]]
      ],
    26, [[1, 0, clc$list_type], [10, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$range_type], [3],
          [[1, 0, clc$program_name_type]]
        ]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    504, [[1, 0, clc$list_type], [488, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [13], [
        ['C                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['COMPONENT                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['DATE_TIME                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['DT                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['ENTRY_POINT                    ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['EP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['H                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['HEADER                         ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['LIBRARIES                      ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['LIBRARY                        ', clc$alias_entry,
  clc$normal_usage_entry, 5],
        ['R                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['REFERENCE                      ', clc$nominal_entry,
  clc$normal_usage_entry, 6]]
        ]
      ]
    ,
    'date_time'],
{ PARAMETER 4
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 5
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$library = 1,
      p$module = 2,
      p$display_option = 3,
      p$output = 4,
      p$alphabetical_order = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      first_module: pmt$program_name,
      input_file: ^oct$open_file_list,
      last_module: pmt$program_name,
      last_module_in_list: ^oct$name_list,
      module_list: oct$name_list,
      module_set_index: clt$list_size,
      node: ^clt$data_value,
      number_of_module_sets: clt$list_size,
      number_of_toggles: clt$list_size,
      page_header: string (59),
      toggle_index: clt$list_size,
      toggles: oct$display_toggles;

    status.normal := TRUE;
    command_status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$initialize_oc_environment (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$obtain_object_file (pvt [p$library].value^.file_value^, input_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    page_header (1, * ) := 'Display of object ******* -';
    CASE input_file^.kind OF
    = occ$library =
      page_header (19, 7) := 'library';
    = occ$file =
      page_header (19, 7) := ' file  ';
    CASEND;

    pmp$get_last_path_name (pvt [p$library].value^.file_value^, page_header (29, 31), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$open_output_file (pvt [p$output].value^.file_value^, ^page_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$display_option].value^.kind = clc$keyword THEN
      IF pvt [p$display_option].value^.keyword_value = 'ALL' THEN
        toggles := -$oct$display_toggles [];
      ELSE { none
        toggles := $oct$display_toggles [];
      IFEND;
    ELSE { list of keywords
      toggles := $oct$display_toggles [];
      node := pvt [p$display_option].value;
      WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
        CASE node^.element_value^.keyword_value (1) OF
        = 'C' =
          toggles := toggles + $oct$display_toggles [occ$display_component_info];
        = 'L' =
          toggles := toggles + $oct$display_toggles [occ$display_libraries];
        = 'D' =
          toggles := toggles + $oct$display_toggles [occ$display_time_date];
        = 'E' =
          toggles := toggles + $oct$display_toggles [occ$display_xdcls];
        = 'H' =
          toggles := toggles + $oct$display_toggles [occ$display_module_header];
        = 'R' =
          toggles := toggles + $oct$display_toggles [occ$display_xrefs];
        CASEND;
        node := node^.link;
      WHILEND;
    IFEND;

    module_list.link := NIL;
    last_module_in_list := ^module_list;
    IF pvt [p$module].specified THEN
      node := pvt [p$module].value;

      WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
        IF node^.element_value^.kind = clc$range THEN
          first_module := node^.element_value^.low_value^.program_name_value;
          last_module := node^.element_value^.high_value^.program_name_value;
        ELSE
          first_module := node^.element_value^.program_name_value;
          last_module := first_module;
        IFEND;
        collect_modules_from_external (first_module, last_module, input_file, last_module_in_list, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        node := node^.link;
      WHILEND;
    ELSE
      first_module := input_file^.directory^ [1].name;
      last_module := osc$null_name;
      collect_modules_from_external (first_module, last_module, input_file, last_module_in_list, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$alphabetical_order].value^.boolean_value.value THEN
      ocp$sort_name_list (module_list);
    IFEND;

    display_module_list (module_list, input_file, toggles, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$close_all_open_files (ocv$open_file_list);

    ocp$close_output_file (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    status := command_status;


  PROCEND ocp$_display_object_library;
?? OLDTITLE ??
MODEND ocm$display_object_library;
*DECK DECK=OCM$EXCEPTION_CONDITION_CODES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc OSD$DEFAULT_PRAGMATS

MODULE ocm$exception_condition_codes;


*copyc OCC$CONDITION_LIMITS

?? NEWTITLE := 'OCDERRR - OBJECT LIBRARY GENERATOR EXCEPTION CODES' ??
?? EJECT ??
*copyc OCE$LIBRARY_GENERATOR_ERRORS
?? OLDTITLE ??
?? NEWTITLE := 'OCDVLER - VIRTUAL ENVIRONMENT LINKER EXCEPTION CODES' ??
?? EJECT ??
*copyc OCE$VE_LINKER_EXCEPTIONS
?? OLDTITLE ??
?? NEWTITLE := 'OCDMBER -  REAL MEMORY BUILDER EXCEPTION CODES' ??
?? EJECT ??
*copyc OCE$RM_BUILDER_EXCEPTIONS
?? OLDTITLE ??
?? NEWTITLE := 'OCDCIER - OBJECT MODULE CONVERTER EXCEPTION CODES' ??
?? EJECT ??
*copyc OCE$OBJECT_CONVERTER_EXCEPTIONS
?? OLDTITLE ??
MODEND ocm$exception_condition_codes;
*DECK DECK=OCM$FUNCTION_HELPERS EXPAND=TRUE
?? RIGHT := 110 ??                                                                                            
?? NEWTITLE := 'NOS/VE:  Object Code Utilities', EJECT ??                                                     
MODULE ocm$function_helpers;                                                                                  
                                                                                                              
                                                                                                              
                                                                                                              
{ PURPOSE:                                                                                                    
{   Common routines to build scl function results.                                                            
                                                                                                              
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??                                      
?? PUSH (LIST := OFF) ??                                                                                      
*copyc llt$object_module                                                                                      
*copyc llt$load_module                                                                                        
*copyc ocs$literals                                                                                           
*copyc ost$segment_access_control                                                                             
?? POP ??                                                                                                     
*copyc clp$convert_string_to_date_time                                                                        
*copyc clp$make_boolean_value                                                                                 
*copyc clp$make_date_time_value                                                                               
*copyc clp$make_file_value                                                                                    
*copyc clp$make_list_value                                                                                    
*copyc clp$make_keyword_value                                                                                 
*copyc clp$make_record_value                                                                                  
*copyc clp$make_string_value                                                                                  
*copyc clp$trimmed_string_size                                                                                
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] ocp$make_access_attributes_valu', EJECT ??                                             
                                                                                                              
  PROCEDURE [XDCL] ocp$make_access_attributes_valu                                                            
    (    access_attributes: llt$section_access_attributes;                                                    
     VAR work_area: ^clt$work_area;                                                                           
     VAR result: ^clt$data_value);                                                                            
                                                                                                              
    VAR                                                                                                       
      value: ^^clt$data_value;                                                                                
                                                                                                              
    result := NIL;                                                                                            
    value := ^result;                                                                                         
                                                                                                              
    IF llc$read IN access_attributes THEN                                                                     
      clp$make_list_value (work_area, value^);                                                                
      clp$make_keyword_value ('READ', work_area, value^^.element_value);                                      
      value := ^value^^.link;                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF llc$write IN access_attributes THEN                                                                    
      clp$make_list_value (work_area, value^);                                                                
      clp$make_keyword_value ('WRITE', work_area, value^^.element_value);                                     
      value := ^value^^.link;                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF llc$binding IN access_attributes THEN                                                                  
      clp$make_list_value (work_area, value^);                                                                
      clp$make_keyword_value ('BINDING', work_area, value^^.element_value);                                   
      value := ^value^^.link;                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF llc$execute IN access_attributes THEN                                                                  
      clp$make_list_value (work_area, value^);                                                                
      clp$make_keyword_value ('EXECUTE', work_area, value^^.element_value);                                   
      value := ^value^^.link;                                                                                 
    IFEND;                                                                                                    
                                                                                                              
    IF result = NIL THEN                                                                                      
      clp$make_list_value (work_area, result);                                                                
    IFEND;                                                                                                    
                                                                                                              
  PROCEND ocp$make_access_attributes_valu;                                                                    
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] ocp$make_access_control_value', EJECT ??                                               
                                                                                                              
  PROCEDURE [XDCL] ocp$make_access_control_value                                                              
    (    control: ost$segment_access_control;                                                                 
     VAR work_area: ^clt$work_area;                                                                           
     VAR result: ^clt$data_value);                                                                            
                                                                                                              
    VAR                                                                                                       
      privilege: ost$name;                                                                                    
                                                                                                              
    clp$make_record_value (4, work_area, result);                                                             
                                                                                                              
    result^.field_values^ [1].name := 'CACHE_BYPASS';                                                         
    clp$make_boolean_value (control.cache_bypass, clc$true_false_boolean, work_area, result^.                 
          field_values^ [1].value);                                                                           
                                                                                                              
    CASE control.execute_privilege OF                                                                         
    = osc$non_privileged =                                                                                    
      privilege := 'NON_PRIVILEGED';                                                                          
    = osc$local_privilege =                                                                                   
      privilege := 'LOCAL_PRIVILEGE';                                                                         
    = osc$global_privilege =                                                                                  
      privilege := 'GLOBAL_PRIVILEGE';                                                                        
    ELSE                                                                                                      
      privilege := 'ILLEGAL_PRIVILEGE';                                                                       
    CASEND;                                                                                                   
    result^.field_values^ [2].name := 'EXECUTE_PRIVILEGE';                                                    
    clp$make_keyword_value (privilege, work_area, result^.field_values^ [2].value);                           
                                                                                                              
    CASE control.read_privilege OF                                                                            
    = osc$read_key_lock_controlled =                                                                          
      privilege := 'READ_KEY_LOCK_CONTROLLED';                                                                
    = osc$read_uncontrolled =                                                                                 
      privilege := 'READ_UNCONTROLLED';                                                                       
    = osc$binding_segment =                                                                                   
      privilege := 'BINDING_SEGMENT';                                                                         
    ELSE                                                                                                      
      privilege := 'ILLEGAL_PRIVILEGE';                                                                       
    CASEND;                                                                                                   
    result^.field_values^ [3].name := 'READ_PRIVILEGE';                                                       
    clp$make_keyword_value (privilege, work_area, result^.field_values^ [3].value);                           
                                                                                                              
    CASE control.write_privilege OF                                                                           
    = osc$write_key_lock_controlled =                                                                         
      privilege := 'WRITE_KEY_LOCK_CONTROLLED';                                                               
    = osc$write_uncontrolled =                                                                                
      privilege := 'WRITE_UNCONTROLLED';                                                                      
    ELSE                                                                                                      
      privilege := 'ILLEGAL_PRIVILEGE';                                                                       
    CASEND;                                                                                                   
    result^.field_values^ [4].name := 'WRITE_PRIVILEGE';                                                      
    clp$make_keyword_value (privilege, work_area, result^.field_values^ [4].value);                           
                                                                                                              
  PROCEND ocp$make_access_control_value;                                                                      
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] ocp$make_date_time_value', EJECT ??                                                    
                                                                                                              
  PROCEDURE [XDCL] ocp$make_date_time_value                                                                   
    (    date: ost$date;                                                                                      
         time: ost$time;                                                                                      
     VAR work_area: ^clt$work_area;                                                                           
     VAR result: ^clt$data_value);                                                                            
                                                                                                              
    VAR                                                                                                       
      status: ost$status,                                                                                     
      the_date: clt$date_time,                                                                                
      the_time: clt$date_time;                                                                                
                                                                                                              
    result := NIL;                                                                                            
                                                                                                              
    CASE time.time_format OF                                                                                  
    = osc$ampm_time =                                                                                         
      clp$convert_string_to_date_time (time.ampm, 'AMPM', the_time, status);                                  
    = osc$hms_time =                                                                                          
      clp$convert_string_to_date_time (time.hms, 'HMS', the_time, status);                                    
    = osc$millisecond_time =                                                                                  
      clp$convert_string_to_date_time (time.millisecond, 'MS', the_time, status);                             
    ELSE                                                                                                      
      status.normal := FALSE;                                                                                 
    CASEND;                                                                                                   
                                                                                                              
    the_time.time_specified := status.normal;                                                                 
                                                                                                              
    CASE date.date_format OF                                                                                  
    = osc$month_date =                                                                                        
      clp$convert_string_to_date_time (date.month, 'MONTH', the_date, status);                                
    = osc$iso_date =                                                                                          
      clp$convert_string_to_date_time (date.iso, 'ISOD', the_date, status);                                   
    = osc$ordinal_date =                                                                                      
      clp$convert_string_to_date_time (date.ordinal, 'ORDINAL', the_date, status);                            
    = osc$dmy_date =                                                                                          
      clp$convert_string_to_date_time (date.dmy, 'DMY', the_date, status);                                    
    = osc$mdy_date =                                                                                          
      clp$convert_string_to_date_time (date.mdy, 'MDY', the_date, status);                                    
    ELSE                                                                                                      
      status.normal := FALSE;                                                                                 
    CASEND;                                                                                                   
                                                                                                              
    the_time.date_specified := status.normal;                                                                 
    IF the_time.date_specified THEN                                                                           
      the_time.value.year := the_date.value.year;                                                             
      the_time.value.month := the_date.value.month;                                                           
      the_time.value.day := the_date.value.day;                                                               
    IFEND;                                                                                                    
                                                                                                              
    clp$make_date_time_value (the_time, work_area, result);                                                   
                                                                                                              
  PROCEND ocp$make_date_time_value;                                                                           
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] ocp$make_file_value', EJECT ??                                                         
                                                                                                              
  PROCEDURE [XDCL] ocp$make_file_value                                                                        
    (    file_name: string ( * );                                                                             
     VAR work_area: ^clt$work_area;                                                                           
     VAR result: ^clt$data_value);                                                                            
                                                                                                              
    VAR                                                                                                       
      index: integer,                                                                                         
      non_file_char_found: boolean;                                                                           
                                                                                                              
    VAR                                                                                                       
      non_file_char: [STATIC, READ, ocs$literals] packed array [char] of boolean := [                         
            {---} REP 32 of TRUE,                                                                             
            {   } FALSE,                                                                                      
            {---} REP 2 of TRUE,                                                                              
            { # } FALSE,                                                                                      
            { $ } FALSE,                                                                                      
            {---} REP 9 of TRUE,                                                                              
            { . } FALSE,                                                                                      
            { / } TRUE,                                                                                       
            {0..9} REP 10 of FALSE,                                                                           
            {---} REP 6 of TRUE,                                                                              
            { @ } FALSE,                                                                                      
            {A..Z} REP 26 of FALSE,                                                                           
            { [ } FALSE,                                                                                      
            { \ } FALSE,                                                                                      
            { ] } FALSE,                                                                                      
            { ^ } FALSE,                                                                                      
            { _ } FALSE,                                                                                      
            { ` } FALSE,                                                                                      
            {a..z} REP 26 of TRUE,                                                                            
            { { } FALSE,                                                                                      
            { | } FALSE,                                                                                      
            { } FALSE,                                                                                        
            { ~ } FALSE,                                                                                      
            {---} REP 129 of TRUE];                                                                           
                                                                                                              
    IF file_name (1) = ':' THEN                                                                               
      #SCAN (non_file_char, file_name (2, * ), index, non_file_char_found);                                   
      IF non_file_char_found THEN                                                                             
        clp$make_string_value (file_name (1, clp$trimmed_string_size (file_name)), work_area, result);        
      ELSE                                                                                                    
        clp$make_file_value (file_name (1, clp$trimmed_string_size (file_name)), work_area, result);          
      IFEND;                                                                                                  
    ELSEIF (file_name = 'OSF$TASK_SERVICES_LIBRARY') OR (file_name = 'OSF$CURRENT_LIBRARY') THEN              
      clp$make_keyword_value (file_name (1, 31), work_area, result);                                          
    ELSE                                                                                                      
      clp$make_string_value (file_name (1, clp$trimmed_string_size (file_name)), work_area, result);          
    IFEND;                                                                                                    
                                                                                                              
  PROCEND ocp$make_file_value;                                                                                
                                                                                                              
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] ocp$make_library_member_kind_va', EJECT ??                                             
                                                                                                              
  PROCEDURE [XDCL] ocp$make_library_member_kind_va                                                            
    (    library_member_kind: llt$library_member_kind;                                                        
     VAR work_area: ^clt$work_area;                                                                           
     VAR result: ^clt$data_value);                                                                            
                                                                                                              
    VAR                                                                                                       
      kind: ost$name;                                                                                         
                                                                                                              
    CASE library_member_kind OF                                                                               
    = llc$program_description, llc$applic_program_description =                                               
      kind := 'PROGRAM_DESCRIPTION';                                                                          
    = llc$command_procedure, llc$applic_command_procedure =                                                   
      kind := 'COMMAND_PROCEDURE';                                                                            
    = llc$function_procedure =                                                                                
      kind := 'FUNCTION_PROCEDURE';                                                                           
    = llc$message_module =                                                                                    
      kind := 'MESSAGE_MODULE';                                                                               
    = llc$panel_module =                                                                                      
      kind := 'FORM_MODULE';                                                                                  
    ELSE                                                                                                      
      kind := 'UNKNOWN';                                                                                      
    CASEND;                                                                                                   
    clp$make_keyword_value (kind, work_area, result);                                                         
                                                                                                              
  PROCEND ocp$make_library_member_kind_va;                                                                    
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] ocp$make_module_generator_value', EJECT ??                                             
                                                                                                              
  PROCEDURE [XDCL] ocp$make_module_generator_value                                                            
    (    module_generator: llt$module_generator;                                                              
     VAR work_area: ^clt$work_area;                                                                           
     VAR result: ^clt$data_value);                                                                            
                                                                                                              
    VAR                                                                                                       
      generator: ost$name;                                                                                    
                                                                                                              
    CASE module_generator OF                                                                                  
    = llc$algol =                                                                                             
      generator := 'ALGOL';                                                                                   
    = llc$apl =                                                                                               
      generator := 'APL';                                                                                     
    = llc$basic =                                                                                             
      generator := 'BASIC';                                                                                   
    = llc$cobol =                                                                                             
      generator := 'COBOL';                                                                                   
    = llc$assembler =                                                                                         
      generator := 'ASSEMBLER';                                                                               
    = llc$fortran =                                                                                           
      generator := 'FORTRAN';                                                                                 
    = llc$object_library_generator =                                                                          
      generator := 'OBJECT_LIBRARY_GENERATOR';                                                                
    = llc$pascal =                                                                                            
      generator := 'PASCAL';                                                                                  
    = llc$obsolete_cybil =                                                                                    
      generator := 'OBSOLETE_CYBIL';                                                                          
    = llc$pl_i =                                                                                              
      generator := 'PL_I';                                                                                    
    = llc$unknown_generator =                                                                                 
      generator := 'UNKNOWN_GENERATOR';                                                                       
    = llc$the_c_language =                                                                                    
      generator := 'THE_C_LANGUAGE';                                                                          
    = llc$ada =                                                                                               
      generator := 'ADA';                                                                                     
    = llc$real_memory_builder =                                                                               
      generator := 'REAL_MEMORY_BUILDER';                                                                     
    = llc$virtual_environment_linker =                                                                        
      generator := 'VIRTUAL_ENVIRONMENT_LINKER';                                                              
    = llc$malet =                                                                                             
      generator := 'MALET';                                                                                   
    = llc$screen_formatter =                                                                                  
      generator := 'SCREEN_FORMATTER';                                                                        
    = llc$lisp =                                                                                              
      generator := 'LISP';                                                                                    
    = llc$cybil =                                                                                             
      generator := 'CYBIL';                                                                                   
    ELSE                                                                                                      
      generator := 'INVALID_GENERATOR';                                                                       
    CASEND;                                                                                                   
    clp$make_keyword_value (generator, work_area, result);                                                    
                                                                                                              
  PROCEND ocp$make_module_generator_value;                                                                    
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] ocp$make_module_kind_value', EJECT ??                                                  
                                                                                                              
  PROCEDURE [XDCL] ocp$make_module_kind_value                                                                 
    (    module_kind: llt$module_kind;                                                                        
     VAR work_area: ^clt$work_area;                                                                           
     VAR result: ^clt$data_value);                                                                            
                                                                                                              
    VAR                                                                                                       
      kind: ost$name;                                                                                         
                                                                                                              
    CASE module_kind OF                                                                                       
    = llc$mi_virtual_state =                                                                                  
      kind := 'MI_VIRTUAL_STATE';                                                                             
    = llc$vector_virtual_state =                                                                              
      kind := 'VECTOR_VIRTUAL_STATE';                                                                         
    = llc$iou =                                                                                               
      kind := 'IOU';                                                                                          
    = llc$motorola_68000 =                                                                                    
      kind := 'MOTOROLA_68000';                                                                               
    = llc$motorola_68000_absolute =                                                                           
      kind := 'MOTOROLA_68000_ABSOLUTE';                                                                      
    = llc$p_code =                                                                                            
      kind := 'P_CODE';                                                                                       
    = llc$form =                                                                                              
      kind := 'FORM';                                                                                         
    = llc$vector_extended_state =                                                                             
      kind := 'VECTOR_EXTENDED';                                                                              
    ELSE                                                                                                      
      kind := 'UNKNOWN';                                                                                      
    CASEND;                                                                                                   
    clp$make_keyword_value (kind, work_area, result);                                                         
                                                                                                              
  PROCEND ocp$make_module_kind_value;                                                                         
?? OLDTITLE ??                                                                                                
?? NEWTITLE := '[XDCL] ocp$make_section_kind_value', EJECT ??                                                 
                                                                                                              
  PROCEDURE [XDCL] ocp$make_section_kind_value                                                                
    (    section_kind: llt$section_kind;                                                                      
     VAR work_area: ^clt$work_area;                                                                           
     VAR result: ^clt$data_value);                                                                            
                                                                                                              
    VAR                                                                                                       
      kind: ost$name;                                                                                         
                                                                                                              
    CASE section_kind OF                                                                                      
    = llc$code_section =                                                                                      
      kind := 'CODE';                                                                                         
    = llc$binding_section =                                                                                   
      kind := 'BINDING';                                                                                      
    = llc$working_storage_section =                                                                           
      kind := 'WORKING_STORAGE';                                                                              
    = llc$common_block =                                                                                      
      kind := 'COMMON_BLOCK';                                                                                 
    = llc$extensible_working_storage =                                                                        
      kind := 'EXTENSIBLE_WORKING_STORAGE';                                                                   
    = llc$extensible_common_block =                                                                           
      kind := 'EXTENSIBLE_COMMON_BLOCK';                                                                      
    = llc$lts_reserved =                                                                                      
      kind := 'LINE_TABLE_RESERVED';                                                                          
    ELSE                                                                                                      
      kind := 'INVALID_SECTION_KIND';                                                                         
    CASEND;                                                                                                   
    clp$make_keyword_value (kind, work_area, result);                                                         
                                                                                                              
  PROCEND ocp$make_section_kind_value;                                                                        
?? OLDTITLE ??                                                                                                
MODEND ocm$function_helpers                                                                                   
*DECK DECK=OCM$GENERATE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
MODULE ocm$generate;

{ PURPOSE:
{   To initiate the generation of the
{   output library pursuant to the
{   previously issued commands.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_command_processing
*copyc cyd$run_time_error_condition
*copyc llt$deferred_common_blocks
*copyc llt$deferred_entry_points
*copyc llt$obsolete_formal_parameters
*copyc oce$format_not_allowed_with_nl
*copyc oce$generate_not_complete
*copyc oce$library_generator_errors
*copyc oct$actual_parameter_list
*copyc oct$display_toggles
*copyc oct$entry_point_sorted_list
*copyc oct$load_module_list
*copyc oct$separated_components
*copyc oss$job_paged_literal
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$extract_message_module
*copyc clp$extract_scl_procedure
*copyc clp$get_message_module_info
*copyc fdp$generate_form_module
*copyc fdp$generate_form_variable
*copyc fsp$close_file
*copyc fsp$open_file
*copyc i#current_sequence_position
*copyc i#move
*copyc mmp$advise_out
*copyc mmp$create_scratch_segment
*copyc mmp$create_user_segment
*copyc mmp$delete_scratch_segment
*copyc mmp$preset_page_streaming
*copyc mmp$set_access_selections
*copyc ocp$add_additions_to_nlm_list
*copyc ocp$build_file_dir_from_temp
*copyc ocp$build_library_directory
*copyc ocp$close_all_open_files
*copyc ocp$close_output_file
*copyc ocp$convert_information_element
*copyc ocp$create_an_nlm
*copyc ocp$generate_message
*copyc ocp$initialize_olg_working_heap
*copyc ocp$open_output_file
*copyc ocp$output
*copyc ocp$output_date
*copyc ocp$output_section_kind
*copyc ocp$output_time
*copyc ocp$return_files
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$get_page_size
*copyc pmp$position_object_library
*copyc syp$advised_move_bytes
*copyc ocv$nlm_list
*copyc ocv$olg_scratch_seq
*copyc ocv$olg_working_heap
*copyc ocv$open_file_list
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    command_status: ost$status,
    object_type_checking: [STATIC, READ] string (6) := 'OBJECT';

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$generate', EJECT ??

  PROCEDURE [XDCL] ocp$generate
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    CONST
      c$spd = osc$status_parameter_delimiter;

    TYPE
      oct$q_field = packed record
        q: -7fff(16) .. 7fff(16),
      recend;

    VAR
      working_segments_open: [STATIC] boolean := FALSE,
      segment_1: [STATIC] ^SEQ ( * ), { separated_components,  entry_point_address_list, BTIs }
      segment_2: [STATIC] ^SEQ ( * ), { TEXs, RPLs, BITs }
      segment_3: [STATIC] ^SEQ ( * ), { ADRs, EXTs }
      segment_4: [STATIC] ^SEQ ( * ), { EPTs }
      segment_5: [STATIC] ^SEQ ( * ); { SDCs, ASDS }

    VAR
      preset_segment: [STATIC] array [pmt$initialization_value] of amt$segment_pointer :=
            [REP ($INTEGER (UPPERVALUE (pmt$initialization_value)) + 1) of [amc$sequence_pointer, NIL]];

?? NEWTITLE := 'initialize_working_segments', EJECT ??

    PROCEDURE initialize_working_segments
      (VAR status: ost$status);


      VAR
        preset_value: pmt$initialization_value,
        segment_pointer: amt$segment_pointer;

      status.normal := TRUE;
      IF NOT working_segments_open THEN
        mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        segment_1 := segment_pointer.sequence_pointer;

        mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        segment_2 := segment_pointer.sequence_pointer;

        mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        segment_3 := segment_pointer.sequence_pointer;

        mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        segment_4 := segment_pointer.sequence_pointer;

        mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        segment_5 := segment_pointer.sequence_pointer;
        working_segments_open := TRUE;
      IFEND;

      RESET segment_1;
      RESET segment_2;
      RESET segment_3;
      RESET segment_4;
      RESET segment_5;

{ If any of the preset segments still exist, remove them.  We need new, uncorrupted
{ segments to generate another library.  These will be created as needed.

      FOR preset_value := LOWERVALUE (pmt$initialization_value) TO UPPERVALUE (pmt$initialization_value) DO
        IF preset_segment [preset_value].sequence_pointer <> NIL THEN
          mmp$delete_scratch_segment (preset_segment [preset_value], {ignore} status);
          preset_segment [preset_value].sequence_pointer := NIL;
        IFEND;
        status.normal := TRUE;
      FOREND;

    PROCEND initialize_working_segments;
?? OLDTITLE ??
?? NEWTITLE := 'generate_scl_proc_file', EJECT ??

    PROCEDURE generate_scl_proc_file
      (    file: fst$file_reference;
       VAR status: ost$status);

      VAR
        nlm: ^oct$new_library_module_list,
        file_id: amt$file_identifier,
        scl_procedure_header: ^llt$library_member_header,
        alias_list: ^pmt$module_list,
        scl_procedure: ^SEQ ( * ),
        sequence: ^SEQ ( * ),
        ignore_status: ost$status,
        attachment_options: array [1 .. 3] of fst$attachment_option,
        default_creation_attributes: array [1 .. 2] of fst$file_cycle_attribute,
        validation_attributes: array [1 .. 5] of fst$file_cycle_attribute;


      validation_attributes [1].selector := fsc$file_contents_and_processor;
      validation_attributes [1].file_contents := fsc$legible_scl_procedure;
      validation_attributes [1].file_processor := osc$null_name;
      validation_attributes [2].selector := fsc$file_contents_and_processor;
      validation_attributes [2].file_contents := fsc$legible_data;
      validation_attributes [2].file_processor := osc$null_name;
      validation_attributes [3].selector := fsc$file_contents_and_processor;
      validation_attributes [3].file_contents := amc$legible;
      validation_attributes [3].file_processor := osc$null_name;
      validation_attributes [4].selector := fsc$file_contents_and_processor;
      validation_attributes [4].file_contents := fsc$data;
      validation_attributes [4].file_processor := osc$null_name;
      validation_attributes [5].selector := fsc$file_contents_and_processor;
      validation_attributes [5].file_contents := fsc$unknown_contents;
      validation_attributes [5].file_processor := osc$null_name;
      attachment_options [1].selector := fsc$access_and_share_modes;
      attachment_options [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
      attachment_options [1].share_modes.selector := fsc$specific_share_modes;
      attachment_options [1].share_modes.value := $fst$file_access_options [];
      attachment_options [2].selector := fsc$access_and_share_modes;
      attachment_options [2].access_modes.selector := fsc$specific_access_modes;
      attachment_options [2].access_modes.value := $fst$file_access_options [fsc$append];
      attachment_options [2].share_modes.selector := fsc$specific_share_modes;
      attachment_options [2].share_modes.value := $fst$file_access_options [];
      attachment_options [3].selector := fsc$open_share_modes;
      attachment_options [3].open_share_modes := -$fst$file_access_options [];
      default_creation_attributes [1].selector := fsc$file_contents_and_processor;
      default_creation_attributes [1].file_contents := fsc$legible_scl_procedure;
      default_creation_attributes [1].file_processor := osc$null_name;
      default_creation_attributes [2].selector := fsc$page_format;
      default_creation_attributes [2].page_format := amc$untitled_form;
      fsp$open_file (file, amc$record, ^attachment_options, ^default_creation_attributes, NIL,
            ^validation_attributes, NIL, file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      nlm := ocv$nlm_list^.f_link;

      REPEAT
        IF (nlm^.description^.kind = occ$command_procedure) OR
              (nlm^.description^.kind = occ$applic_command_procedure) OR
              (nlm^.description^.kind = occ$function_procedure) THEN
          IF (nlm^.description^.kind = occ$applic_command_procedure) THEN
            scl_procedure_header := ^nlm^.description^.applic_command_procedure_header^.library_member_header;
          ELSE
            scl_procedure_header := nlm^.description^.command_procedure_header;
          IFEND;

          sequence := #PTR (scl_procedure_header^.member, nlm^.description^.file^);
          IF sequence = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, nlm^.name, status);
            RETURN;
          IFEND;

          RESET sequence;

          NEXT scl_procedure: [[REP scl_procedure_header^.member_size OF cell]] IN sequence;
          IF scl_procedure = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, nlm^.name, status);
            RETURN;
          IFEND;

          clp$extract_scl_procedure (file_id, scl_procedure, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        nlm := nlm^.f_link;
      UNTIL nlm^.name = osc$null_name;


      fsp$close_file (file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND generate_scl_proc_file;
?? OLDTITLE ??
?? NEWTITLE := 'generate_message_module_file', EJECT ??

    PROCEDURE generate_message_module_file
      (    file: fst$file_reference;
       VAR status: ost$status);

      VAR
        nlm: ^oct$new_library_module_list,
        file_id: amt$file_identifier,
        message_module_header: ^llt$library_member_header,
        message_module: ^SEQ ( * ),
        sequence: ^SEQ ( * ),
        ignore_status: ost$status,
        attachment_options: array [1 .. 3] of fst$attachment_option,
        default_creation_attributes: array [1 .. 2] of fst$file_cycle_attribute,
        validation_attributes: array [1 .. 5] of fst$file_cycle_attribute;


      validation_attributes [1].selector := fsc$file_contents_and_processor;
      validation_attributes [1].file_contents := fsc$legible_scl_include;
      validation_attributes [1].file_processor := osc$null_name;
      validation_attributes [2].selector := fsc$file_contents_and_processor;
      validation_attributes [2].file_contents := fsc$legible_data;
      validation_attributes [2].file_processor := osc$null_name;
      validation_attributes [3].selector := fsc$file_contents_and_processor;
      validation_attributes [3].file_contents := amc$legible;
      validation_attributes [3].file_processor := osc$null_name;
      validation_attributes [4].selector := fsc$file_contents_and_processor;
      validation_attributes [4].file_contents := fsc$data;
      validation_attributes [4].file_processor := osc$null_name;
      validation_attributes [5].selector := fsc$file_contents_and_processor;
      validation_attributes [5].file_contents := fsc$unknown_contents;
      validation_attributes [5].file_processor := osc$null_name;
      attachment_options [1].selector := fsc$access_and_share_modes;
      attachment_options [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
      attachment_options [1].share_modes.selector := fsc$specific_share_modes;
      attachment_options [1].share_modes.value := $fst$file_access_options [];
      attachment_options [2].selector := fsc$access_and_share_modes;
      attachment_options [2].access_modes.selector := fsc$specific_access_modes;
      attachment_options [2].access_modes.value := $fst$file_access_options [fsc$append];
      attachment_options [2].share_modes.selector := fsc$specific_share_modes;
      attachment_options [2].share_modes.value := $fst$file_access_options [];
      attachment_options [3].selector := fsc$open_share_modes;
      attachment_options [3].open_share_modes := -$fst$file_access_options [];
      default_creation_attributes [1].selector := fsc$file_contents_and_processor;
      default_creation_attributes [1].file_contents := fsc$legible_scl_include;
      default_creation_attributes [1].file_processor := osc$null_name;
      default_creation_attributes [2].selector := fsc$page_format;
      default_creation_attributes [2].page_format := amc$untitled_form;
      fsp$open_file (file, amc$record, ^attachment_options, ^default_creation_attributes, NIL,
            ^validation_attributes, NIL, file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      nlm := ocv$nlm_list^.f_link;

      REPEAT
        IF nlm^.description^.kind = occ$message_module THEN
          message_module_header := nlm^.description^.message_module_header;

          sequence := #PTR (message_module_header^.member, nlm^.description^.file^);
          IF sequence = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, nlm^.name, status);
            RETURN;
          IFEND;

          RESET sequence;
          NEXT message_module: [[REP message_module_header^.member_size OF cell]] IN sequence;
          IF message_module = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, nlm^.name, status);
            RETURN;
          IFEND;

          clp$extract_message_module (file_id, message_module_header^.name, message_module, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        nlm := nlm^.f_link;
      UNTIL nlm^.name = osc$null_name;


      fsp$close_file (file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND generate_message_module_file;
?? OLDTITLE ??
?? NEWTITLE := 'generate_form_source_file', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to generate a file containing all
{   the form modules on the current library.

    PROCEDURE generate_form_source_file
      (    file: fst$file_reference;
       VAR status: ost$status);

      VAR
        attachment_options: array [1 .. 3] of fst$attachment_option,
        default_creation_attributes: array [1 .. 2] of fst$file_cycle_attribute,
        file_id: amt$file_identifier,
        form_module_header_p: ^llt$library_member_header,
        form_module_p: ^fdt$form_module,
        form_module_sequence_p: ^SEQ ( * ),
        ignore_status: ost$status,
        nlm_p: ^oct$new_library_module_list,
        validation_attributes: array [1 .. 5] of fst$file_cycle_attribute;


      validation_attributes [1].selector := fsc$file_contents_and_processor;
      validation_attributes [1].file_contents := fsc$legible_scl_include;
      validation_attributes [1].file_processor := osc$null_name;
      validation_attributes [2].selector := fsc$file_contents_and_processor;
      validation_attributes [2].file_contents := fsc$legible_data;
      validation_attributes [2].file_processor := osc$null_name;
      validation_attributes [3].selector := fsc$file_contents_and_processor;
      validation_attributes [3].file_contents := amc$legible;
      validation_attributes [3].file_processor := osc$null_name;
      validation_attributes [4].selector := fsc$file_contents_and_processor;
      validation_attributes [4].file_contents := fsc$data;
      validation_attributes [4].file_processor := osc$null_name;
      validation_attributes [5].selector := fsc$file_contents_and_processor;
      validation_attributes [5].file_contents := fsc$unknown_contents;
      validation_attributes [5].file_processor := osc$null_name;
      attachment_options [1].selector := fsc$access_and_share_modes;
      attachment_options [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
      attachment_options [1].share_modes.selector := fsc$specific_share_modes;
      attachment_options [1].share_modes.value := $fst$file_access_options [];
      attachment_options [2].selector := fsc$access_and_share_modes;
      attachment_options [2].access_modes.selector := fsc$specific_access_modes;
      attachment_options [2].access_modes.value := $fst$file_access_options [fsc$append];
      attachment_options [2].share_modes.selector := fsc$specific_share_modes;
      attachment_options [2].share_modes.value := $fst$file_access_options [];
      attachment_options [3].selector := fsc$open_share_modes;
      attachment_options [3].open_share_modes := -$fst$file_access_options [];
      default_creation_attributes [1].selector := fsc$file_contents_and_processor;
      default_creation_attributes [1].file_contents := fsc$legible_scl_include;
      default_creation_attributes [1].file_processor := osc$null_name;
      default_creation_attributes [2].selector := fsc$page_format;
      default_creation_attributes [2].page_format := amc$untitled_form;
      fsp$open_file (file, amc$record, ^attachment_options, ^default_creation_attributes, NIL,
            ^validation_attributes, NIL, file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      nlm_p := ocv$nlm_list^.f_link;

      REPEAT
        IF nlm_p^.description^.kind = occ$panel_module THEN
          form_module_header_p := nlm_p^.description^.panel_module_header;

          form_module_sequence_p := #PTR (form_module_header_p^.member, nlm_p^.description^.file^);
          IF form_module_sequence_p = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, nlm_p^.name, status);
            fsp$close_file (file_id, ignore_status);
            RETURN;
          IFEND;

          RESET form_module_sequence_p;
          NEXT form_module_p: [[REP form_module_header_p^.member_size OF cell]] IN form_module_sequence_p;
          IF form_module_p = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, nlm_p^.name, status);
            fsp$close_file (file_id, ignore_status);
            RETURN;
          IFEND;

          fdp$generate_form_module (file_id, form_module_header_p^.name, form_module_p, status);
          IF NOT status.normal THEN
            fsp$close_file (file_id, ignore_status);
            RETURN;
          IFEND;
        IFEND;

        nlm_p := nlm_p^.f_link;
      UNTIL nlm_p^.name = osc$null_name;

      fsp$close_file (file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND generate_form_source_file;
?? OLDTITLE ??
?? NEWTITLE := 'generate_form_variable_file', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to generate a file containing all
{   the form variables for every form module on the current library.

    PROCEDURE generate_form_variable_file
      (    file: fst$file_reference;
       VAR status: ost$status);

      VAR
        attachment_options: array [1 .. 3] of fst$attachment_option,
        default_creation_attributes: array [1 .. 2] of fst$file_cycle_attribute,
        file_id: amt$file_identifier,
        form_module_header_p: ^llt$library_member_header,
        form_module_p: ^fdt$form_module,
        form_module_sequence_p: ^SEQ ( * ),
        ignore_status: ost$status,
        nlm_p: ^oct$new_library_module_list,
        validation_attributes: array [1 .. 1] of fst$file_cycle_attribute;


      validation_attributes [1].selector := fsc$file_contents_and_processor;
      validation_attributes [1].file_contents := fsc$legible_data;
      validation_attributes [1].file_processor := fsc$scu;
      attachment_options [1].selector := fsc$access_and_share_modes;
      attachment_options [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
      attachment_options [1].share_modes.selector := fsc$specific_share_modes;
      attachment_options [1].share_modes.value := $fst$file_access_options [];
      attachment_options [2].selector := fsc$access_and_share_modes;
      attachment_options [2].access_modes.selector := fsc$specific_access_modes;
      attachment_options [2].access_modes.value := $fst$file_access_options [fsc$append];
      attachment_options [2].share_modes.selector := fsc$specific_share_modes;
      attachment_options [2].share_modes.value := $fst$file_access_options [];
      attachment_options [3].selector := fsc$open_share_modes;
      attachment_options [3].open_share_modes := -$fst$file_access_options [];
      default_creation_attributes [1].selector := fsc$file_contents_and_processor;
      default_creation_attributes [1].file_contents := fsc$legible_data;
      default_creation_attributes [1].file_processor := fsc$scu;
      default_creation_attributes [2].selector := fsc$page_format;
      default_creation_attributes [2].page_format := amc$untitled_form;
      fsp$open_file (file, amc$record, ^attachment_options, ^default_creation_attributes, NIL,
            ^validation_attributes, NIL, file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      nlm_p := ocv$nlm_list^.f_link;

      REPEAT
        IF nlm_p^.description^.kind = occ$panel_module THEN
          form_module_header_p := nlm_p^.description^.panel_module_header;

          form_module_sequence_p := #PTR (form_module_header_p^.member, nlm_p^.description^.file^);
          IF form_module_sequence_p = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, nlm_p^.name, status);
            fsp$close_file (file_id, ignore_status);
            RETURN;
          IFEND;

          RESET form_module_sequence_p;
          NEXT form_module_p: [[REP form_module_header_p^.member_size OF cell]] IN form_module_sequence_p;
          IF form_module_p = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, nlm_p^.name, status);
            fsp$close_file (file_id, ignore_status);
            RETURN;
          IFEND;

          fdp$generate_form_variable (file_id, form_module_header_p^.name, form_module_p, status);
          IF NOT status.normal THEN
            fsp$close_file (file_id, ignore_status);
            RETURN;
          IFEND;
        IFEND;

        nlm_p := nlm_p^.f_link;
      UNTIL nlm_p^.name = osc$null_name;


      fsp$close_file (file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND generate_form_variable_file;
?? OLDTITLE ??
?? NEWTITLE := 'generate_object_file', EJECT ??

    PROCEDURE generate_object_file
      (    format: clt$keyword;
           library_value: clt$data_value;
       VAR status: ost$status);

?? NEWTITLE := '      COPY_CPU_OBJECT_MODULE' ??
?? EJECT ??

      PROCEDURE [XREF] copy_cpu_object_module
        (    module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR temporary_object_file: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '      COPY_PPU_OBJECT_MODULE' ??
?? EJECT ??

      PROCEDURE [XREF] copy_ppu_object_module
        (    module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR object_text_descriptor: ^llt$object_text_descriptor;
         VAR temporary_object_file: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '      COPY_LOAD_MODULE' ??
?? EJECT ??

      PROCEDURE [XREF] copy_load_module
        (    module_index: llt$module_index;
             module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR new_load_module_header: ^llt$load_module_header;
         VAR new_code_section: ^cell;
         VAR new_read_section: ^cell;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);


?? OLDTITLE ??
?? NEWTITLE := '      COPY_LOAD_TO_OBJECT_MODULE' ??
?? EJECT ??

      PROCEDURE [XREF] copy_load_to_object_module
        (    module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);


?? OLDTITLE ??
?? NEWTITLE := '      COPY_TEMPORARY_LOAD_MODULE' ??
?? EJECT ??

      PROCEDURE [XREF] copy_temporary_load_module
        (    module_index: llt$module_index;
             module_description: ^oct$module_description;
         VAR load_module_header: ^llt$load_module_header;
         VAR code_section: ^cell;
         VAR read_section: ^cell;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '      COPY_PROGRAM_DESCRIPTION' ??
?? EJECT ??

      PROCEDURE [XREF] copy_program_description
        (    module_index: llt$module_index;
             module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR new_program_description_header: ^llt$library_member_header;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '      COPY_SCL_PROCEDURE' ??
?? EJECT ??

      PROCEDURE [XREF] copy_scl_procedure
        (    module_index: llt$module_index;
             module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR new_scl_procedure_header: ^llt$library_member_header;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '      COPY_COMMAND_DESCRIPTION' ??
?? EJECT ??

      PROCEDURE [XREF] copy_command_description
        (    module_index: llt$module_index;
             module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR new_command_description_header: ^llt$library_member_header;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '      COPY_FUNCTION_DESCRIPTION' ??
?? EJECT ??

      PROCEDURE [XREF] copy_function_description
        (    module_index: llt$module_index;
             module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR new_function_description_header: ^llt$library_member_header;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '      COPY_APPLIC_PROGRAM_DESCRIPTION' ??
?? EJECT ??

      PROCEDURE [XREF] copy_applic_program_description
        (    module_index: llt$module_index;
             module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR new_applic_program_description: ^llt$application_member_header;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '      COPY_APPLIC_COMMAND_PROCEDURE' ??
?? EJECT ??

      PROCEDURE [XREF] copy_applic_command_procedure
        (    module_index: llt$module_index;
             module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR new_applic_command_procedure: ^llt$application_member_header;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '      COPY_APPLIC_COMMAND_DESCRIPTION' ??
?? EJECT ??

      PROCEDURE [XREF] copy_applic_command_description
        (    module_index: llt$module_index;
             module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR new_applic_command_description: ^llt$application_member_header;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '      COPY_APP_PROG_DES_TO_PROG_DES' ??
?? EJECT ??

      PROCEDURE [XREF] copy_app_prog_des_to_prog_des
        (    module_index: llt$module_index;
             module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR new_program_description_header: ^llt$library_member_header;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '      COPY_APP_SCL_PROC_TO_SCL_PROC' ??
?? EJECT ??

      PROCEDURE [XREF] copy_app_scl_proc_to_scl_proc
        (    module_index: llt$module_index;
             module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR new_scl_procedure_header: ^llt$library_member_header;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '      COPY_APP_CMND_DES_TO_CMND_DES' ??
?? EJECT ??

      PROCEDURE [XREF] copy_app_cmnd_des_to_cmnd_des
        (    module_index: llt$module_index;
             module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR new_command_description_header: ^llt$library_member_header;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '      COPY_PROG_DES_TO_APP_PROG_DES' ??
?? EJECT ??

      PROCEDURE [XREF] copy_prog_des_to_app_prog_des
        (    module_index: llt$module_index;
             module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR new_applic_program_description: ^llt$application_member_header;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '      COPY_SCL_PROC_TO_APP_SCL_PROC' ??
?? EJECT ??

      PROCEDURE [XREF] copy_scl_proc_to_app_scl_proc
        (    module_index: llt$module_index;
             module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR new_applic_command_procedure: ^llt$application_member_header;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '      COPY_CMND_DES_TO_APP_CMND_DES' ??
?? EJECT ??

      PROCEDURE [XREF] copy_cmnd_des_to_app_cmnd_des
        (    module_index: llt$module_index;
             module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR new_applic_command_description: ^llt$application_member_header;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '      COPY_MESSAGE_MODULE' ??
?? EJECT ??

      PROCEDURE [XREF] copy_message_module
        (    module_index: llt$module_index;
             module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR new_message_module_header: ^llt$library_member_header;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '      COPY_PANEL_MODULE' ??
?? EJECT ??

      PROCEDURE [XREF] copy_panel_module
        (    module_index: llt$module_index;
             module_description: ^oct$module_description;
             changed_info: ^oct$changed_info;
         VAR new_panel_module_header: ^llt$library_member_header;
         VAR temporary_library: ^SEQ ( * );
         VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := '    GENERATE_TEMPORARY_OBJECT_FILE' ??
?? EJECT ??

      PROCEDURE generate_temporary_object_file
        (VAR temporary_object_file: ^SEQ ( * );
         VAR status: ost$status);



        VAR
          local_status: ost$status,
          object_text_descriptor: ^llt$object_text_descriptor,

          nlm: ^oct$new_library_module_list;


        local_status.normal := TRUE;

        RESET temporary_object_file;
        nlm := ocv$nlm_list^.f_link;

        REPEAT
          CASE nlm^.description^.kind OF
          = occ$cpu_object_module =
            copy_cpu_object_module (nlm^.description, nlm^.changed_info, temporary_object_file, local_status);

          = occ$load_module =
            copy_load_to_object_module (nlm^.description, nlm^.changed_info, temporary_object_file,
                  local_status);

          = occ$ppu_object_module =
            copy_ppu_object_module (nlm^.description, nlm^.changed_info, object_text_descriptor,
                  temporary_object_file, local_status);

          ELSE
            ;
          CASEND;

          IF NOT local_status.normal THEN
            ocp$generate_message (local_status);
            osp$set_status_abnormal (oc, oce$w_new_file_not_generated, '', status);
          IFEND;

          nlm := nlm^.f_link;

        UNTIL nlm^.name = osc$null_name;


      PROCEND generate_temporary_object_file;
?? OLDTITLE ??
?? NEWTITLE := '      GENERATE_TEMPORARY_LIBRARY_FILE' ??
?? EJECT ??

      PROCEDURE generate_temporary_library_file
        (VAR temporary_library_file: ^SEQ ( * );
         VAR status: ost$status);

?? NEWTITLE := '        BUILD_LOAD_MODULE_LIST' ??
?? EJECT ??

        PROCEDURE build_load_module_list
          (    nlm_list: ^oct$new_library_module_list;
           VAR load_module_list: oct$load_module_list;
           VAR status: ost$status);

?? NEWTITLE := '          BUILD_TEMPORARY_LOAD_MODULE' ??
?? EJECT ??

          PROCEDURE build_temporary_load_module
            (    module_description: ^oct$module_description;
                 changed_info: ^oct$changed_info;
             VAR temporary_load_module: ^oct$module_description;
             VAR status: ost$status);





            VAR
              quick_bind: boolean,
              ocv$binding_section: ^oct$section_definition_list;

?? NEWTITLE := '            CHANGE_BOUND_TO_TEMP_MODULE' ??
?? EJECT ??

            PROCEDURE change_bound_to_temp_module
              (VAR bound_module: oct$bound_module_header;
                   changed_info: ^oct$changed_info;
               VAR temporary_module_header: ^oct$temporary_module_header;
               VAR status: ost$status);

?? NEWTITLE := '              CHECK_SECTION_ORDINAL_&_OFFSET', EJECT ??

              PROCEDURE [INLINE] check_section_ordinal_offset
                (    section_ordinal: llt$section_ordinal;
                     section_offset: ost$segment_offset;
                     section_definitions: ^oct$section_definitions;
                     module_name: pmt$program_name;
                 VAR status: ost$status);


                IF section_ordinal > UPPERBOUND (section_definitions^) THEN
                  osp$set_status_abnormal (oc, oce$e_invalid_section_ordinal, module_name, status);
                  RETURN;
                IFEND;

                IF section_definitions^ [section_ordinal] = NIL THEN
                  osp$set_status_abnormal (oc, oce$e_section_not_yet_defined, module_name, status);
                  RETURN;
                IFEND;

                IF section_offset > section_definitions^ [section_ordinal]^.section_definition.length THEN
                  osp$set_status_abnormal (oc, oce$e_reference_outside_section, module_name, status);
                  RETURN;
                IFEND;


              PROCEND check_section_ordinal_offset;
?? OLDTITLE ??
?? NEWTITLE := '              RELOCATED_SECTION_ORDINAL' ??
?? NEWTITLE := '              RELOCATED_SECTION_OFFSET', EJECT ??

              PROCEDURE [INLINE] relocated_section_ordinal
                (    component: oct$separated_module_header;
                     old_section_ordinal: llt$section_ordinal;
                 VAR new_section_ordinal: llt$section_ordinal);


                new_section_ordinal := component.section_definitions^ [old_section_ordinal]^.new^.
                      section_definition.section_ordinal;


              PROCEND relocated_section_ordinal;



              FUNCTION relocated_section_offset
                (    component: oct$separated_module_header;
                     old_section_ordinal: llt$section_ordinal;
                     old_section_offset: ost$segment_offset): ost$segment_offset;


                relocated_section_offset := component.section_definitions^ [old_section_ordinal]^.
                      new_section_offset + old_section_offset;


              FUNCEND relocated_section_offset;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := '              ADD_TEXT_INSERTION_RECORD' ??
?? EJECT ??

{ PURPOSE:
{   This procedure inserts a text insertion record into a list.  There is a text
{   insertion list generated for each section and the records are kept in order
{   by bit offset into the section.  A text insertion record may represent a TEXT,
{   REPLICATION or BIT STRING INSERTION object text record.
{ DESIGN:
{   For each section, there is a text insertion list and two pointers into
{   the list.  One pointer points to the last text insertion record.  The
{   other pointer points to the text insertion record that was last inserted.
{   This procedure first checks to see if the text insertion record should be
{   added at the end of the list.  If it is not a search will be made
{   sequentially through the list.  If the record should come after the one that
{   was last inserted the search starts there, otherwise it will start at the
{   beginning of the list.

              PROCEDURE [INLINE] add_text_insertion_record
                (VAR last_text_insertion_record: ^oct$text_insertion_list;
                 VAR last_text_insertion_point: ^oct$text_insertion_list;
                 VAR text_insertion_records: oct$text_insertion_list;
                 VAR text_insertion_record: ^oct$text_insertion_list);


                VAR
                  next_text_record: ^oct$text_insertion_list,
                  this_text_record: ^oct$text_insertion_list,
                  tir_starting_bit_offset: integer,
                  tir_ending_bit_offset: integer;


                IF (text_insertion_record^.starting_bit_offset >
                      last_text_insertion_record^.ending_bit_offset) THEN
                  last_text_insertion_record^.link := text_insertion_record;
                  last_text_insertion_record := text_insertion_record;
                  last_text_insertion_point := text_insertion_record;
                  RETURN; {---->
                IFEND;


                tir_starting_bit_offset := text_insertion_record^.starting_bit_offset;
                tir_ending_bit_offset := text_insertion_record^.ending_bit_offset;

                IF (tir_starting_bit_offset > last_text_insertion_point^.ending_bit_offset) THEN
                  this_text_record := last_text_insertion_point;
                ELSE
                  this_text_record := ^text_insertion_records;
                IFEND;
                next_text_record := this_text_record^.link;

              /loop/
                WHILE next_text_record <> NIL DO
                  IF (NOT next_text_record^.overlapped) THEN
                    IF (next_text_record^.starting_bit_offset <= tir_ending_bit_offset) AND
                          (next_text_record^.ending_bit_offset >= tir_starting_bit_offset) THEN
                      next_text_record^.overlapped := TRUE;
                    ELSEIF tir_ending_bit_offset < next_text_record^.starting_bit_offset THEN
                      EXIT /loop/
                    IFEND;
                  IFEND;

                  this_text_record := next_text_record;
                  next_text_record := this_text_record^.link;
                WHILEND /loop/;

                text_insertion_record^.link := next_text_record;
                this_text_record^.link := text_insertion_record;
                last_text_insertion_point := text_insertion_record;
                IF text_insertion_record^.link = NIL THEN
                  last_text_insertion_record := text_insertion_record;
                IFEND;


              PROCEND add_text_insertion_record;
?? OLDTITLE ??
?? NEWTITLE := '              SEPARATE_COMPONENTS' ??
?? EJECT ??

              PROCEDURE separate_components
                (    bound_components: ^oct$bound_components;
                     debug_tables_to_omit: oct$debug_tables;
                 VAR changed_entry_points: ^oct$external_declaration_list;
                 VAR separated_components: ^oct$separated_components;
                 VAR status: ost$status);

?? NEWTITLE := '                SEPARATE_OBJECT_RECORDS' ??
?? EJECT ??

                PROCEDURE separate_object_records
                  (    module_name: pmt$program_name;
                       debug_tables_to_omit: oct$debug_tables;
                   VAR object_records: ^SEQ ( * );
                   VAR next_changed_entry_point: ^oct$external_declaration_list;
                   VAR separated_module: oct$separated_module_header;
                   VAR status: ost$status);

?? NEWTITLE := '                  ALLOCATE_SPACE_FOR_SECTION' ??
?? EJECT ??

                  PROCEDURE allocate_space_for_section
                    (    module_name: pmt$program_name;
                     VAR separated_module: oct$separated_module_header;
                     VAR section_definition: oct$section_definition;
                     VAR status: ost$status);


                    IF ((section_definition.section_definition.access_attributes *
                          $llt$section_access_attributes [llc$write,
                          llc$binding]) = $llt$section_access_attributes []) AND
                          (section_definition.section_definition.kind <> llc$extensible_working_storage) AND
                          (section_definition.section_definition.kind <> llc$common_block) AND
                          (section_definition.section_definition.kind <> llc$extensible_common_block) AND
                          (section_definition.section_definition.length <> 0) AND
                          (separated_module.header^.kind <> llc$motorola_68000) THEN

                      NEXT section_definition.text: [1 .. section_definition.section_definition.length] IN
                            segment_5;
                      IF section_definition.text = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                        RETURN;
                      IFEND;

                      section_definition.allotted_section := TRUE;
                    IFEND;


                  PROCEND allocate_space_for_section;
?? OLDTITLE ??
?? NEWTITLE := '                  ADD_TEXT_RECORD' ??
?? EJECT ??

                  PROCEDURE add_text_record
                    (VAR section_definition: oct$section_definition;
                         text: ^llt$text;
                     VAR status: ost$status);


                    VAR
                      text_insertion_record: ^oct$text_insertion_list;


                    IF section_definition.text <> NIL THEN

                      i#move (#LOC (text^.byte), #LOC (section_definition.text^ [text^.offset + 1]),
                            UPPERBOUND (text^.byte));

                    ELSE
                      NEXT text_insertion_record IN segment_2;
                      IF text_insertion_record = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                        RETURN;
                      IFEND;

                      text_insertion_record^.offset := text^.offset;
                      text_insertion_record^.bit_offset := 0;
                      text_insertion_record^.length := UPPERBOUND (text^.byte);
                      text_insertion_record^.starting_bit_offset := (text^.offset * 8);
                      text_insertion_record^.ending_bit_offset := text_insertion_record^.
                            starting_bit_offset + (text_insertion_record^.length * 8) - 1;
                      text_insertion_record^.overlapped := FALSE;

                      text_insertion_record^.kind := llc$text;
                      text_insertion_record^.text := text;
                      text_insertion_record^.link := NIL;

                      add_text_insertion_record (section_definition.last_text_insertion_record,
                            section_definition.last_text_insertion_point,
                            section_definition.text_insertion_records, text_insertion_record);
                    IFEND;


                  PROCEND add_text_record;
?? OLDTITLE ??
?? NEWTITLE := '                  ADD_REPLICATION_RECORD' ??
?? EJECT ??

                  PROCEDURE add_replication_record
                    (VAR section_definition: oct$section_definition;
                         replication: ^llt$replication;
                     VAR status: ost$status);


                    VAR
                      text_insertion_record: ^oct$text_insertion_list,
                      offset: integer,
                      i: integer;


                    IF section_definition.text <> NIL THEN
                      offset := replication^.offset + 1;
                      FOR i := 1 TO replication^.count DO
                        i#move (#LOC (replication^.byte), #LOC (section_definition.text^ [offset]),
                              UPPERBOUND (replication^.byte));
                        offset := offset + replication^.increment;
                      FOREND;

                    ELSE
                      NEXT text_insertion_record IN segment_2;
                      IF text_insertion_record = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                        RETURN;
                      IFEND;

                      text_insertion_record^.offset := replication^.offset;
                      text_insertion_record^.bit_offset := 0;
                      text_insertion_record^.length := ((replication^.count - 1) *
                            replication^.increment) + UPPERBOUND (replication^.byte);
                      text_insertion_record^.starting_bit_offset := (replication^.offset * 8);
                      text_insertion_record^.ending_bit_offset := text_insertion_record^.
                            starting_bit_offset + (text_insertion_record^.length * 8) - 1;
                      text_insertion_record^.overlapped := FALSE;

                      text_insertion_record^.kind := llc$replication;
                      text_insertion_record^.replication := replication;
                      text_insertion_record^.link := NIL;

                      add_text_insertion_record (section_definition.last_text_insertion_record,
                            section_definition.last_text_insertion_point,
                            section_definition.text_insertion_records, text_insertion_record);
                    IFEND;


                  PROCEND add_replication_record;
?? OLDTITLE ??
?? NEWTITLE := '                  ADD_BIT_STRING_INSERTION_RECORD' ??
?? EJECT ??

                  PROCEDURE add_bit_string_insertion_record
                    (VAR section_definition: oct$section_definition;
                         bit_string_insertion: ^llt$bit_string_insertion;
                     VAR status: ost$status);


                    VAR
                      text_insertion_record: ^oct$text_insertion_list,
                      bit_string: ^packed array [1 .. 70] of 0 .. 1,
                      i: 1 .. 63;


                    IF section_definition.text <> NIL THEN
                      bit_string := #LOC (section_definition.text^ [bit_string_insertion^.offset + 1]);
                      FOR i := 1 TO bit_string_insertion^.bit_length DO
                        bit_string^ [i + bit_string_insertion^.bit_offset] :=
                              bit_string_insertion^.bit_string [i];
                      FOREND;

                    ELSE
                      NEXT text_insertion_record IN segment_2;
                      IF text_insertion_record = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                        RETURN;
                      IFEND;

                      text_insertion_record^.offset := bit_string_insertion^.offset;
                      text_insertion_record^.bit_offset := bit_string_insertion^.bit_offset;
                      text_insertion_record^.length := (bit_string_insertion^.bit_offset +
                            bit_string_insertion^.bit_length + 7) DIV 8;
                      text_insertion_record^.starting_bit_offset :=
                            (8 * bit_string_insertion^.offset) + bit_string_insertion^.bit_offset;
                      text_insertion_record^.ending_bit_offset := text_insertion_record^.starting_bit_offset +
                            bit_string_insertion^.bit_length - 1;
                      text_insertion_record^.overlapped := FALSE;

                      text_insertion_record^.kind := llc$bit_string_insertion;
                      text_insertion_record^.bit_string_insertion := bit_string_insertion;
                      text_insertion_record^.link := NIL;

                      add_text_insertion_record (section_definition.last_text_insertion_record,
                            section_definition.last_text_insertion_point,
                            section_definition.text_insertion_records, text_insertion_record);
                    IFEND;


                  PROCEND add_bit_string_insertion_record;
?? OLDTITLE ??
?? EJECT ??

{ The size of the old_binding_template_list will start out at 500 and increase in increments
{ of 500 if necessary.  There is no scientific reason why 500 was chosen, it just seemed like
{ a good number.

                  CONST
                    binding_template_items = 500;

                  VAR
                    binding_template_list_size: llt$number_of_info_elements,
                    record_number: integer,
                    i: integer,
                    section_definition_length: ost$segment_length,
                    segment_length: ost$segment_length,
                    local_status: ost$status,

                    greatest_section_ordinal: integer,
                    section_ordinal: llt$section_ordinal,
                    section_offset: ost$segment_offset,
                    value_section: llt$section_ordinal,
                    dest_section: llt$section_ordinal,
                    relocating_section: llt$section_ordinal,

                    reset_value: ^SEQ ( * ),
                    valid_position: boolean,
                    allotted_section: ^llt$code_element,

                    section_definitions: ^oct$section_definitions,
                    any_obsolete_segment_defs: boolean,
                    binding_section_ordinal: llt$section_ordinal,
                    found: boolean,

                    last_library: ^oct$library_list,
                    last_entry_definition: ^oct$entry_definition_list,
                    last_address_formulation: ^^oct$address_formulation_list,
                    last_external_linkage: ^^oct$external_linkage_list,
                    last_byte_relocation: ^oct$relocation_item_list,
                    last_two_byte_relocation: ^oct$relocation_item_list,
                    last_four_byte_relocation: ^oct$relocation_item_list,
                    last_eight_byte_relocation: ^oct$relocation_item_list,
                    last_miscellaneous_record: ^oct$object_record_list,

                    binding_template_index: llt$number_of_info_elements,
                    old_binding_template_list: oct$old_binding_template_list;

                  VAR
                    object_text_descriptor: ^llt$object_text_descriptor,
                    identification: ^llt$identification,
                    application_identifier: ^llt$application_identifier,
                    libraries: ^llt$libraries,
                    section_definition: ^llt$section_definition,
                    segment_definition: ^llt$segment_definition,
                    obs_segment_definition: ^llt$obsolete_segment_definition,
                    text: ^llt$text,
                    replication: ^llt$replication,
                    bit_string_insertion: ^llt$bit_string_insertion,
                    apl: ^oct$actual_parameter_list,
                    entry_definition: ^llt$entry_definition,
                    deferred_entry_points: ^llt$deferred_entry_points,
                    entry_def: ^oct$entry_definition_list,
                    external_def: ^oct$external_linkage_list,
                    relocation: ^llt$relocation,
                    address_formulation: ^llt$address_formulation,
                    external_linkage: ^llt$external_linkage,
                    obsolete_formal_parameters: ^llt$obsolete_formal_parameters,
                    formal_parameter: ^llt$formal_parameters,
                    formal_parameters: ^llt$formal_parameters,
                    actual_parameters: ^llt$actual_parameters,
                    debug_table_fragment: ^llt$debug_table_fragment,
                    obsolete_line_address_table: ^llt$obsolete_line_address_table,
                    symbol_table: ^llt$symbol_table,
                    line_address_table: ^llt$line_address_table,
                    supplemental_debug_tables: ^llt$supplemental_debug_tables,
                    binding_template: ^llt$binding_template,
                    m68000_absolute: ^llt$68000_absolute,
                    transfer_symbol: ^llt$transfer_symbol;


                  any_obsolete_segment_defs := FALSE;

                  separated_module.file := object_records;

                  separated_module.application_identifier := NIL;

                  separated_module.library_list.link := NIL;
                  last_library := ^separated_module.library_list;

                  separated_module.relocation_list.byte.link := NIL;
                  last_byte_relocation := ^separated_module.relocation_list.byte;
                  separated_module.relocation_list.two_byte.link := NIL;
                  last_two_byte_relocation := ^separated_module.relocation_list.two_byte;
                  separated_module.relocation_list.four_byte.link := NIL;
                  last_four_byte_relocation := ^separated_module.relocation_list.four_byte;
                  separated_module.relocation_list.eight_byte.link := NIL;
                  last_eight_byte_relocation := ^separated_module.relocation_list.eight_byte;

                  separated_module.entry_definition_list.link := NIL;
                  last_entry_definition := ^separated_module.entry_definition_list;

                  separated_module.address_formulation_list := NIL;
                  last_address_formulation := ^separated_module.address_formulation_list;

                  separated_module.external_linkage_list := NIL;
                  last_external_linkage := ^separated_module.external_linkage_list;

{ The OLD_BINDING_TEMPLATE_LIST being set up here is an array where each entry represents a word in the
{ binding section (ie. entry 0 represents the first 8 bytes in the binding section, entry 1 represents
{ the second 8 bytes in the binding section, etc.).  This allows the binding template item for any
{ binding offset to be found directly by dividing the binding offset by 8 to get the index into this
{ array which contains a pointer to the binding template item.  Note that each entry in the binding
{ section is either 1 word or 2 words long and the binding offset will either be on a word boundary or
{ in the case of an internal address, the word boundary + 2.

                  binding_template_list_size := binding_template_items;

                  NEXT old_binding_template_list: [0 .. binding_template_list_size] IN ocv$olg_scratch_seq;
                  IF old_binding_template_list = NIL THEN
                    osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                    RETURN;
                  IFEND;

                  separated_module.binding_template_list := old_binding_template_list;
                  FOR i := 0 TO binding_template_list_size DO
                    old_binding_template_list^ [i].binding_template := NIL;
                  FOREND;
                  separated_module.number_of_template_items := 0;

                  separated_module.miscellaneous_record_list.link := NIL;
                  last_miscellaneous_record := ^separated_module.miscellaneous_record_list;

                  separated_module.deferred_common_blocks := NIL;
                  separated_module.deferred_entry_points := NIL;

                  separated_module.components := NIL;
                  separated_module.section_maps := NIL;

                  record_number := 1;

                  NEXT identification IN object_records;
                  IF identification = NIL THEN
                    osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                    RETURN;
                  IFEND;

                  separated_module.header := identification;

                  greatest_section_ordinal := identification^.greatest_section_ordinal;

                  NEXT separated_module.section_definitions: [0 .. greatest_section_ordinal] IN segment_1;

                  section_definitions := separated_module.section_definitions;
                  IF section_definitions = NIL THEN
                    osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                    RETURN;
                  IFEND;

                  FOR section_ordinal := 0 TO greatest_section_ordinal DO
                    section_definitions^ [section_ordinal] := NIL;
                  FOREND;

                  REPEAT
                    NEXT object_text_descriptor IN object_records;
                    IF object_text_descriptor = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                      RETURN;
                    IFEND;

                    record_number := record_number + 1;

                    CASE object_text_descriptor^.kind OF
                    = llc$identification =
                      osp$set_status_abnormal (oc, oce$e_multiple_ident_rec, module_name, status);
                      RETURN;


                    = llc$application_identifier =
                      NEXT application_identifier IN object_records;
                      IF application_identifier = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                      separated_module.application_identifier := application_identifier;

                    = llc$libraries =
                      NEXT libraries: [1 .. object_text_descriptor^.number_of_libraries] IN object_records;
                      IF libraries = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                      NEXT last_library^.link IN ocv$olg_scratch_seq;
                      last_library := last_library^.link;
                      IF last_library = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                        RETURN;
                      IFEND;

                      last_library^.link := NIL;
                      last_library^.libraries := libraries;

                    = llc$section_definition, llc$allotted_section_definition, llc$unallocated_common_block =
                      NEXT section_definition IN object_records;
                      IF section_definition = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                      section_ordinal := section_definition^.section_ordinal;
                      IF section_ordinal > greatest_section_ordinal THEN
                        osp$set_status_abnormal (oc, oce$e_invalid_section_ordinal, module_name, status);
                        RETURN;
                      IFEND;
                      IF section_definitions^ [section_ordinal] <> NIL THEN
                        osp$set_status_abnormal (oc, oce$e_duplicate_section_defn, module_name, status);
                        RETURN;
                      IFEND;
                      IF section_definition^.allocation_alignment = 0 THEN
                        osp$set_status_abnormal (oc, oce$e_zero_allocation_align, module_name, status);
                        RETURN;
                      IFEND;

                      NEXT section_definitions^ [section_ordinal] IN ocv$olg_scratch_seq;
                      IF section_definitions^ [section_ordinal] = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                        RETURN;
                      IFEND;

                      section_definitions^ [section_ordinal]^.section_definition := section_definition^;
                      section_definitions^ [section_ordinal]^.new := NIL;
                      section_definitions^ [section_ordinal]^.new_section_offset := 0;
                      section_definitions^ [section_ordinal]^.unallocated_common_block :=
                            object_text_descriptor^.kind = llc$unallocated_common_block;

                      IF (section_definitions^ [section_ordinal]^.unallocated_common_block) THEN
                        IF (section_definitions^ [section_ordinal]^.section_definition.kind <>
                              llc$common_block) AND (section_definitions^ [section_ordinal]^.
                              section_definition.kind <> llc$extensible_common_block) THEN
                          osp$set_status_abnormal (oc, oce$invalid_unalloc_common_bl, module_name, status);
                          RETURN;
                        IFEND;
                      IFEND;

                      section_definitions^ [section_ordinal]^.allotted_section := FALSE;
                      section_definitions^ [section_ordinal]^.allotted_section_length := 0;
                      section_definitions^ [section_ordinal]^.text := NIL;
                      section_definitions^ [section_ordinal]^.text_insertion_records.link := NIL;
                      section_definitions^ [section_ordinal]^.text_insertion_records.starting_bit_offset :=
                            -1;
                      section_definitions^ [section_ordinal]^.text_insertion_records.ending_bit_offset := -1;
                      section_definitions^ [section_ordinal]^.last_text_insertion_record :=
                            ^section_definitions^ [section_ordinal]^.text_insertion_records;
                      section_definitions^ [section_ordinal]^.last_text_insertion_point :=
                            ^section_definitions^ [section_ordinal]^.text_insertion_records;
                      section_definitions^ [section_ordinal]^.predefined_segment := FALSE;
                      section_definitions^ [section_ordinal]^.predefined_segment_number := 0;
                      section_definitions^ [section_ordinal]^.predefined_r1 := 0;
                      section_definitions^ [section_ordinal]^.predefined_r2 := 0;
                      section_definitions^ [section_ordinal]^.predefined_binding_ordinal := 0;
                      section_definitions^ [section_ordinal]^.predefined_binding_offset := 0;
                      section_definition_length := section_definition^.length;

                      allocate_space_for_section (module_name, separated_module,
                            section_definitions^ [section_ordinal]^, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                      IF (section_definition^.kind = llc$binding_section) OR
                            (section_definition^.kind = llc$lts_reserved) THEN
                        section_definitions^ [section_ordinal]^.section_definition.name := osc$null_name;
                      IFEND;

                      IF object_text_descriptor^.kind = llc$allotted_section_definition THEN
                        reset_value := object_records;
                        pmp$position_object_library (object_records, object_text_descriptor^.allotted_section,
                              valid_position);
                        IF NOT valid_position THEN
                          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                          RETURN;
                        IFEND;

                        NEXT allotted_section: [1 .. section_definition^.length] IN object_records;
                        IF allotted_section = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                          RETURN;
                        IFEND;

                        IF section_definitions^ [section_ordinal]^.text = NIL THEN
                          NEXT section_definitions^ [section_ordinal]^.text:
                                [1 .. section_definition_length] IN ocv$olg_scratch_seq;
                          IF section_definitions^ [section_ordinal]^.text = NIL THEN
                            osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                            RETURN;
                          IFEND;
                        IFEND;

                        i#move (#LOC (allotted_section^), #LOC (section_definitions^ [section_ordinal]^.
                              text^), section_definition_length);

                        object_records := reset_value;
                      IFEND;

                    = llc$segment_definition =
                      NEXT segment_definition IN object_records;
                      IF segment_definition = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                      section_ordinal := segment_definition^.section_definition.section_ordinal;
                      IF section_ordinal > greatest_section_ordinal THEN
                        osp$set_status_abnormal (oc, oce$e_invalid_section_ordinal, module_name, status);
                        RETURN;
                      IFEND;
                      IF section_definitions^ [section_ordinal] <> NIL THEN
                        osp$set_status_abnormal (oc, oce$e_duplicate_section_defn, module_name, status);
                        RETURN;
                      IFEND;
                      IF segment_definition^.section_definition.allocation_alignment = 0 THEN
                        osp$set_status_abnormal (oc, oce$e_zero_allocation_align, module_name, status);
                        RETURN;
                      IFEND;

                      NEXT section_definitions^ [section_ordinal] IN ocv$olg_scratch_seq;
                      IF section_definitions^ [section_ordinal] = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                        RETURN;
                      IFEND;

                      section_definitions^ [section_ordinal]^.section_definition :=
                            segment_definition^.section_definition;
                      section_definitions^ [section_ordinal]^.new := NIL;
                      section_definitions^ [section_ordinal]^.new_section_offset := 0;
                      section_definitions^ [section_ordinal]^.unallocated_common_block := FALSE;
                      section_definitions^ [section_ordinal]^.allotted_section := FALSE;
                      section_definitions^ [section_ordinal]^.allotted_section_length := 0;
                      section_definitions^ [section_ordinal]^.text := NIL;
                      section_definitions^ [section_ordinal]^.text_insertion_records.link := NIL;
                      section_definitions^ [section_ordinal]^.text_insertion_records.starting_bit_offset :=
                            -1;
                      section_definitions^ [section_ordinal]^.text_insertion_records.ending_bit_offset := -1;
                      section_definitions^ [section_ordinal]^.last_text_insertion_record :=
                            ^section_definitions^ [section_ordinal]^.text_insertion_records;
                      section_definitions^ [section_ordinal]^.last_text_insertion_point :=
                            ^section_definitions^ [section_ordinal]^.text_insertion_records;
                      section_definitions^ [section_ordinal]^.predefined_segment := TRUE;
                      section_definitions^ [section_ordinal]^.predefined_segment_number :=
                            segment_definition^.segment_number;
                      section_definitions^ [section_ordinal]^.predefined_r1 := segment_definition^.r1;
                      section_definitions^ [section_ordinal]^.predefined_r2 := segment_definition^.r2;
                      section_definitions^ [section_ordinal]^.predefined_binding_ordinal :=
                            segment_definition^.binding_section_ordinal;
                      section_definitions^ [section_ordinal]^.predefined_binding_offset :=
                            segment_definition^.binding_section_offset;
                      section_definition_length := segment_definition^.section_definition.length;

                      allocate_space_for_section (module_name, separated_module,
                            section_definitions^ [section_ordinal]^, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                      IF (segment_definition^.section_definition.kind = llc$binding_section) OR
                            (segment_definition^.section_definition.kind = llc$lts_reserved) THEN
                        section_definitions^ [section_ordinal]^.section_definition.name := osc$null_name;
                      IFEND;

                    = llc$obsolete_segment_definition =
                      NEXT obs_segment_definition IN object_records;
                      IF obs_segment_definition = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                      any_obsolete_segment_defs := TRUE;
                      segment_definition := NIL; { Trap any errors }

                      section_ordinal := obs_segment_definition^.section_definition.section_ordinal;
                      IF section_ordinal > greatest_section_ordinal THEN
                        osp$set_status_abnormal (oc, oce$e_invalid_section_ordinal, module_name, status);
                        RETURN;
                      IFEND;
                      IF section_definitions^ [section_ordinal] <> NIL THEN
                        osp$set_status_abnormal (oc, oce$e_duplicate_section_defn, module_name, status);
                        RETURN;
                      IFEND;
                      IF obs_segment_definition^.section_definition.allocation_alignment = 0 THEN
                        osp$set_status_abnormal (oc, oce$e_zero_allocation_align, module_name, status);
                        RETURN;
                      IFEND;

                      NEXT section_definitions^ [section_ordinal] IN ocv$olg_scratch_seq;
                      IF section_definitions^ [section_ordinal] = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                        RETURN;
                      IFEND;

                      section_definitions^ [section_ordinal]^.section_definition :=
                            obs_segment_definition^.section_definition;
                      section_definitions^ [section_ordinal]^.new := NIL;
                      section_definitions^ [section_ordinal]^.new_section_offset := 0;
                      section_definitions^ [section_ordinal]^.unallocated_common_block := FALSE;
                      section_definitions^ [section_ordinal]^.allotted_section := FALSE;
                      section_definitions^ [section_ordinal]^.allotted_section_length := 0;
                      section_definitions^ [section_ordinal]^.text := NIL;
                      section_definitions^ [section_ordinal]^.text_insertion_records.link := NIL;
                      section_definitions^ [section_ordinal]^.text_insertion_records.starting_bit_offset :=
                            -1;
                      section_definitions^ [section_ordinal]^.text_insertion_records.ending_bit_offset := -1;
                      section_definitions^ [section_ordinal]^.last_text_insertion_record :=
                            ^section_definitions^ [section_ordinal]^.text_insertion_records;
                      section_definitions^ [section_ordinal]^.last_text_insertion_point :=
                            ^section_definitions^ [section_ordinal]^.text_insertion_records;
                      section_definitions^ [section_ordinal]^.predefined_segment := TRUE;
                      section_definitions^ [section_ordinal]^.predefined_segment_number :=
                            obs_segment_definition^.segment_number;
                      section_definitions^ [section_ordinal]^.predefined_r1 := obs_segment_definition^.r1;
                      section_definitions^ [section_ordinal]^.predefined_r2 := obs_segment_definition^.r2;
                      section_definitions^ [section_ordinal]^.predefined_binding_offset := 0;
                      section_definitions^ [section_ordinal]^.predefined_binding_ordinal := 0;
                      section_definition_length := obs_segment_definition^.section_definition.length;

                      allocate_space_for_section (module_name, separated_module,
                            section_definitions^ [section_ordinal]^, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                      IF (obs_segment_definition^.section_definition.kind = llc$binding_section) OR
                            (obs_segment_definition^.section_definition.kind = llc$lts_reserved) THEN
                        section_definitions^ [section_ordinal]^.section_definition.name := osc$null_name;
                      IFEND;

                    = llc$text =
                      NEXT text: [1 .. object_text_descriptor^.number_of_bytes] IN object_records;
                      IF text = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;


                      section_ordinal := text^.section_ordinal;
                      section_offset := text^.offset + object_text_descriptor^.number_of_bytes;

                      check_section_ordinal_offset (section_ordinal, section_offset, section_definitions,
                            module_name, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;


                      add_text_record (section_definitions^ [section_ordinal]^, text, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                    = llc$replication =
                      NEXT replication: [1 .. object_text_descriptor^.number_of_bytes] IN object_records;
                      IF replication = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;


                      section_ordinal := replication^.section_ordinal;
                      section_offset := replication^.offset + ((replication^.count - 1) *
                            replication^.increment) + object_text_descriptor^.number_of_bytes;

                      check_section_ordinal_offset (section_ordinal, section_offset, section_definitions,
                            module_name, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;


                      add_replication_record (section_definitions^ [section_ordinal]^, replication, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                    = llc$bit_string_insertion =
                      NEXT bit_string_insertion IN object_records;
                      IF bit_string_insertion = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;


                      section_ordinal := bit_string_insertion^.section_ordinal;
                      section_offset := bit_string_insertion^.offset +
                            ((bit_string_insertion^.bit_offset + bit_string_insertion^.bit_length + 7) DIV 8);

                      check_section_ordinal_offset (section_ordinal, section_offset, section_definitions,
                            module_name, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;


                      add_bit_string_insertion_record (section_definitions^ [section_ordinal]^,
                            bit_string_insertion, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                    = llc$entry_definition =
                      NEXT entry_definition IN object_records;


                      section_ordinal := entry_definition^.section_ordinal;
                      section_offset := entry_definition^.offset;

                      check_section_ordinal_offset (section_ordinal, section_offset, section_definitions,
                            module_name, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;


                      NEXT last_entry_definition^.link IN segment_4;
                      last_entry_definition := last_entry_definition^.link;
                      IF last_entry_definition = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                        RETURN;
                      IFEND;

                      last_entry_definition^.entry_definition := entry_definition^;
                      last_entry_definition^.link := NIL;
                      last_entry_definition^.changed_name := ^entry_definition^.name;
                      last_entry_definition^.formal_parameter := NIL;

                      IF next_changed_entry_point <> NIL THEN
                        last_entry_definition^.changed_name := ^next_changed_entry_point^.name;
                        last_entry_definition^.entry_definition.attributes :=
                              next_changed_entry_point^.attributes;
                        next_changed_entry_point := next_changed_entry_point^.link;
                      IFEND;

                    = llc$deferred_entry_points =
                      NEXT deferred_entry_points: [1 .. object_text_descriptor^.number_of_entry_points] IN
                            object_records;
                      IF deferred_entry_points = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                      NEXT separated_module.deferred_entry_points:
                            [1 .. object_text_descriptor^.number_of_entry_points] IN segment_4;
                      IF separated_module.deferred_entry_points = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                        RETURN;
                      IFEND;

                      separated_module.deferred_entry_points^ := deferred_entry_points^;


                    = llc$deferred_common_blocks =
                      NEXT separated_module.deferred_common_blocks:
                            [1 .. object_text_descriptor^.number_of_common_blocks] IN object_records;
                      IF separated_module.deferred_common_blocks = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                    = llc$address_formulation =
                      NEXT address_formulation: [1 .. object_text_descriptor^.number_of_adr_items] IN
                            object_records;
                      IF address_formulation = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;


                      value_section := address_formulation^.value_section;

                      check_section_ordinal_offset (value_section, 0, section_definitions, module_name,
                            status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;


                      dest_section := address_formulation^.dest_section;

                      FOR i := 1 TO object_text_descriptor^.number_of_adr_items DO
                        section_offset := address_formulation^.item [i].dest_offset;

                        check_section_ordinal_offset (dest_section, section_offset, section_definitions,
                              module_name, status);
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;
                      FOREND;


                      section_definitions^ [dest_section]^.allotted_section := FALSE;


                      NEXT last_address_formulation^: [1 .. object_text_descriptor^.number_of_adr_items] IN
                            segment_3;
                      IF last_address_formulation^ = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                        RETURN;
                      IFEND;

                      last_address_formulation^^.address_formulation := address_formulation^;
                      last_address_formulation^^.link := NIL;
                      last_address_formulation := ^last_address_formulation^^.link;

                    = llc$external_linkage =
                      NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN
                            object_records;
                      IF external_linkage = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;


                      FOR i := 1 TO object_text_descriptor^.number_of_ext_items DO
                        section_ordinal := external_linkage^.item [i].section_ordinal;
                        section_offset := external_linkage^.item [i].offset;

                        check_section_ordinal_offset (section_ordinal, section_offset, section_definitions,
                              module_name, status);
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;

                        section_definitions^ [section_ordinal]^.allotted_section := FALSE;
                      FOREND;


                      NEXT last_external_linkage^: [1 .. object_text_descriptor^.number_of_ext_items] IN
                            segment_3;
                      IF last_external_linkage^ = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                        RETURN;
                      IFEND;

                      last_external_linkage^^.external_linkage := external_linkage^;
                      last_external_linkage^^.link := NIL;
                      last_external_linkage^^.actual_parameter_list.nnext := NIL;
                      last_external_linkage := ^last_external_linkage^^.link;

                    = llc$relocation =
                      NEXT relocation: [1 .. object_text_descriptor^.number_of_rel_items] IN object_records;
                      IF relocation = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                      FOR i := 1 TO object_text_descriptor^.number_of_rel_items DO
                        section_ordinal := relocation^ [i].section_ordinal;
                        section_offset := relocation^ [i].offset;

                        check_section_ordinal_offset (section_ordinal, section_offset, section_definitions,
                              module_name, status);
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;

                        relocating_section := relocation^ [i].relocating_section;

                        check_section_ordinal_offset (relocating_section, 0, section_definitions, module_name,
                              status);
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;

                        CASE relocation^ [i].address OF
                        = llc$byte_positive, llc$byte_signed =
                          NEXT last_byte_relocation^.link IN ocv$olg_scratch_seq;
                          last_byte_relocation := last_byte_relocation^.link;
                          IF last_byte_relocation = NIL THEN
                            osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                            RETURN;
                          IFEND;

                          last_byte_relocation^.item := ^relocation^ [i];
                          last_byte_relocation^.link := NIL;

                        = llc$two_byte_positive, llc$two_byte_signed =
                          NEXT last_two_byte_relocation^.link IN ocv$olg_scratch_seq;
                          last_two_byte_relocation := last_two_byte_relocation^.link;
                          IF last_two_byte_relocation = NIL THEN
                            osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                            RETURN;
                          IFEND;

                          last_two_byte_relocation^.item := ^relocation^ [i];
                          last_two_byte_relocation^.link := NIL;

                        = llc$four_byte_positive, llc$four_byte_signed =
                          NEXT last_four_byte_relocation^.link IN ocv$olg_scratch_seq;
                          last_four_byte_relocation := last_four_byte_relocation^.link;
                          IF last_four_byte_relocation = NIL THEN
                            osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                            RETURN;
                          IFEND;

                          last_four_byte_relocation^.item := ^relocation^ [i];
                          last_four_byte_relocation^.link := NIL;

                        = llc$eight_byte_positive, llc$eight_byte_signed =
                          NEXT last_eight_byte_relocation^.link IN ocv$olg_scratch_seq;
                          last_eight_byte_relocation := last_eight_byte_relocation^.link;
                          IF last_eight_byte_relocation = NIL THEN
                            osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                            RETURN;
                          IFEND;

                          last_eight_byte_relocation^.item := ^relocation^ [i];
                          last_eight_byte_relocation^.link := NIL;

                        ELSE
                          osp$set_status_abnormal (oc, oce$e_invalid_container_adr_typ,
                                separated_module.header^.name, status);
                          RETURN;
                        CASEND;
                      FOREND;

                    = llc$binding_template =
                      NEXT binding_template IN object_records;
                      IF binding_template = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                      IF binding_template^.kind = llc$current_module THEN
                        section_ordinal := binding_template^.section_ordinal;
                        section_offset := binding_template^.offset;

                        check_section_ordinal_offset (section_ordinal, 0, section_definitions, module_name,
                              status);
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;
                      IFEND;

                      separated_module.number_of_template_items :=
                            separated_module.number_of_template_items + 1;
                      binding_template_index := binding_template^.binding_offset DIV 8;
                      WHILE binding_template_index > binding_template_list_size DO
                        NEXT old_binding_template_list: [0 .. binding_template_list_size +
                              binding_template_items] IN ocv$olg_scratch_seq;
                        IF old_binding_template_list = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                          RETURN;
                        IFEND;

                        FOR i := 0 TO binding_template_list_size DO
                          old_binding_template_list^ [i] := separated_module.binding_template_list^ [i];
                        FOREND;
                        FOR i := binding_template_list_size + 1 TO binding_template_list_size +
                              binding_template_items DO
                          old_binding_template_list^ [i].binding_template := NIL;
                        FOREND;

                        separated_module.binding_template_list := old_binding_template_list;
                        binding_template_list_size := binding_template_list_size + binding_template_items;
                      WHILEND;

                      old_binding_template_list^ [binding_template_index].binding_template :=
                            binding_template;
                      old_binding_template_list^ [binding_template_index].referenced_in_new_binding_sect :=
                            FALSE;

                    = llc$obsolete_formal_parameters =
                      NEXT obsolete_formal_parameters: [[REP object_text_descriptor^.sequence_length OF
                            cell]] IN object_records;
                      IF obsolete_formal_parameters = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                    = llc$formal_parameters =
                      NEXT formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                            object_records;
                      IF formal_parameters = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                      IF NOT (occ$parameter_checking IN debug_tables_to_omit) THEN
                        entry_def := separated_module.entry_definition_list.link;
                        WHILE (entry_def <> NIL) AND (entry_def^.entry_definition.name <>
                              formal_parameters^.procedure_name) DO
                          entry_def := entry_def^.link;
                        WHILEND;

                        IF entry_def = NIL THEN
                          osp$set_status_abnormal (oc, oce$entry_not_found_for_formal, formal_parameters^.
                                procedure_name, status);
                          osp$append_status_parameter (osc$status_parameter_delimiter, module_name, status);
                          RETURN;
                        ELSE
                          NEXT entry_def^.formal_parameter: [[REP object_text_descriptor^.sequence_length OF
                                cell]] IN segment_4;
                          IF entry_def^.formal_parameter = NIL THEN
                            osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                            RETURN;
                          IFEND;

                          entry_def^.formal_parameter^ := formal_parameters^;
                          IF entry_def^.changed_name <> NIL THEN
                            entry_def^.formal_parameter^.procedure_name := entry_def^.changed_name^;
                          IFEND;
                        IFEND;
                      IFEND;

                    = llc$actual_parameters =
                      NEXT actual_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                            object_records;
                      IF actual_parameters = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                      IF NOT (occ$parameter_checking IN debug_tables_to_omit) THEN
                        external_def := separated_module.external_linkage_list;
                        WHILE (external_def <> NIL) AND (external_def^.external_linkage.name <>
                              actual_parameters^.callee_name) DO
                          external_def := external_def^.link;
                        WHILEND;
                        IF external_def = NIL THEN
                          osp$set_status_abnormal (oc, oce$ext_not_found_for_actual,
                                actual_parameters^.callee_name, status);
                          osp$append_status_parameter (osc$status_parameter_delimiter, module_name, status);
                          RETURN;
                        ELSE
                          NEXT apl IN segment_4;
                          IF apl = NIL THEN
                            osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                            RETURN;
                          ELSE
                            NEXT apl^.actual_parameter: [[REP object_text_descriptor^.sequence_length OF
                                  cell]] IN segment_4;
                            apl^.nnext := external_def^.actual_parameter_list.nnext;
                            external_def^.actual_parameter_list.nnext := apl;
                            apl^.actual_parameter^ := actual_parameters^;
                          IFEND;
                        IFEND;
                      IFEND;

                    = llc$cybil_symbol_table_fragment =
                      NEXT debug_table_fragment: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                            object_records;
                      IF debug_table_fragment = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                      IF (identification^.object_text_version > 'V1.2') AND
                            (NOT (occ$symbol_table IN debug_tables_to_omit)) THEN
                        NEXT last_miscellaneous_record^.link IN ocv$olg_scratch_seq;
                        last_miscellaneous_record := last_miscellaneous_record^.link;
                        IF last_miscellaneous_record = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                          RETURN;
                        IFEND;

                        NEXT last_miscellaneous_record^.debug_table_fragment:
                              [[REP object_text_descriptor^.sequence_length OF cell]] IN ocv$olg_scratch_seq;
                        IF last_miscellaneous_record^.debug_table_fragment = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                          RETURN;
                        IFEND;

                        last_miscellaneous_record^.kind := llc$cybil_symbol_table_fragment;
                        last_miscellaneous_record^.debug_table_fragment^ := debug_table_fragment^;
                        last_miscellaneous_record^.link := NIL;
                      IFEND;

                    = llc$obsolete_line_table =
                      NEXT obsolete_line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN
                            object_records;
                      IF obsolete_line_address_table = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                      IF NOT (occ$line_table IN debug_tables_to_omit) THEN
                        NEXT last_miscellaneous_record^.link IN ocv$olg_scratch_seq;
                        last_miscellaneous_record := last_miscellaneous_record^.link;
                        IF last_miscellaneous_record = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                          RETURN;
                        IFEND;

                        NEXT last_miscellaneous_record^.obsolete_line_address_table:
                              [1 .. object_text_descriptor^.number_of_line_items] IN ocv$olg_scratch_seq;
                        IF last_miscellaneous_record^.obsolete_line_address_table = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                          RETURN;
                        IFEND;

                        last_miscellaneous_record^.kind := llc$obsolete_line_table;
                        last_miscellaneous_record^.obsolete_line_address_table^ :=
                              obsolete_line_address_table^;
                        last_miscellaneous_record^.link := NIL;
                      IFEND;

                    = llc$symbol_table =
                      NEXT symbol_table: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                            object_records;
                      IF symbol_table = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                      IF NOT (occ$symbol_table IN debug_tables_to_omit) THEN
                        NEXT last_miscellaneous_record^.link IN ocv$olg_scratch_seq;
                        last_miscellaneous_record := last_miscellaneous_record^.link;
                        IF last_miscellaneous_record = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                          RETURN;
                        IFEND;

                        NEXT last_miscellaneous_record^.symbol_table:
                              [[REP object_text_descriptor^.sequence_length OF cell]] IN ocv$olg_scratch_seq;
                        IF last_miscellaneous_record^.symbol_table = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                          RETURN;
                        IFEND;

                        last_miscellaneous_record^.kind := llc$symbol_table;
                        last_miscellaneous_record^.symbol_table^ := symbol_table^;
                        last_miscellaneous_record^.link := NIL;
                      IFEND;

                    = llc$line_table =
                      NEXT line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN
                            object_records;
                      IF line_address_table = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                      IF NOT (occ$line_table IN debug_tables_to_omit) THEN
                        NEXT last_miscellaneous_record^.link IN ocv$olg_scratch_seq;
                        last_miscellaneous_record := last_miscellaneous_record^.link;
                        IF last_miscellaneous_record = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                          RETURN;
                        IFEND;

                        NEXT last_miscellaneous_record^.line_address_table:
                              [1 .. object_text_descriptor^.number_of_line_items] IN ocv$olg_scratch_seq;
                        IF last_miscellaneous_record^.line_address_table = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                          RETURN;
                        IFEND;

                        last_miscellaneous_record^.kind := llc$line_table;
                        last_miscellaneous_record^.line_address_table^ := line_address_table^;
                        last_miscellaneous_record^.link := NIL;
                      IFEND;

                    = llc$supplemental_debug_tables =
                      NEXT supplemental_debug_tables: [[REP object_text_descriptor^.sequence_length OF
                            cell]] IN object_records;
                      IF supplemental_debug_tables = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                      IF NOT (occ$supplemental_debug_table IN debug_tables_to_omit) THEN
                        NEXT last_miscellaneous_record^.link IN ocv$olg_scratch_seq;
                        last_miscellaneous_record := last_miscellaneous_record^.link;
                        IF last_miscellaneous_record = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                          RETURN;
                        IFEND;

                        NEXT last_miscellaneous_record^.supplemental_debug_tables:
                              [[REP object_text_descriptor^.sequence_length OF cell]] IN ocv$olg_scratch_seq;
                        IF last_miscellaneous_record^.supplemental_debug_tables = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                          RETURN;
                        IFEND;

                        last_miscellaneous_record^.kind := llc$supplemental_debug_tables;
                        last_miscellaneous_record^.supplemental_debug_tables^ := supplemental_debug_tables^;
                        last_miscellaneous_record^.link := NIL;
                      IFEND;


                    = llc$form_definition =
                      osp$set_status_abnormal (oc, oce$e_form_def_found_in_module, module_name, status);
                      RETURN;


                    = llc$68000_absolute =
                      NEXT m68000_absolute: [[REP object_text_descriptor^.number_of_68000_bytes OF cell]] IN
                            object_records;
                      IF m68000_absolute = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                      NEXT last_miscellaneous_record^.link IN ocv$olg_scratch_seq;
                      last_miscellaneous_record := last_miscellaneous_record^.link;
                      IF last_miscellaneous_record = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                        RETURN;
                      IFEND;

                      last_miscellaneous_record^.kind := llc$68000_absolute;
                      last_miscellaneous_record^.m68000_absolute := m68000_absolute;
                      last_miscellaneous_record^.link := NIL;


                    = llc$transfer_symbol =
                      NEXT transfer_symbol IN object_records;
                      IF transfer_symbol = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                        RETURN;
                      IFEND;

                      separated_module.starting_procedure := transfer_symbol^.name;


                      IF (any_obsolete_segment_defs) THEN
                        binding_section_ordinal := 0;
                        found := FALSE;

                        i := 0;
                        WHILE (i <= greatest_section_ordinal) AND (NOT found) DO
                          IF (section_definitions^ [i] <> NIL) AND (section_definitions^ [i]^.
                                section_definition.kind = llc$binding_section) THEN
                            binding_section_ordinal := section_definitions^ [section_ordinal]^.
                                  section_definition.section_ordinal;
                            found := TRUE;
                          IFEND;
                          i := i + 1;
                        WHILEND;

                        FOR i := 0 TO greatest_section_ordinal DO
                          IF (section_definitions^ [i] <> NIL) AND (section_definitions^ [i]^.
                                section_definition.kind = llc$code_section) THEN
                            section_definitions^ [i]^.predefined_binding_ordinal := binding_section_ordinal;
                          IFEND;
                        FOREND;
                      IFEND;


                    ELSE
                      osp$set_status_abnormal (oc, oce$e_invalid_object_rec_kind, module_name, status);
                      osp$append_status_integer (osc$status_parameter_delimiter, record_number, 10, FALSE,
                            status);
                      RETURN;
                    CASEND;

                  UNTIL object_text_descriptor^.kind = llc$transfer_symbol;

                  segment_length := i#current_sequence_position (segment_1);
                  mmp$advise_out (segment_1, segment_length, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;

                  segment_length := i#current_sequence_position (segment_2);
                  mmp$advise_out (segment_2, segment_length, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;

                  segment_length := i#current_sequence_position (segment_3);
                  mmp$advise_out (segment_3, segment_length, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;

                  segment_length := i#current_sequence_position (segment_4);
                  mmp$advise_out (segment_4, segment_length, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;

                PROCEND separate_object_records;
?? OLDTITLE ??
?? NEWTITLE := '                COLLECT_FROM_INFO_HEADER' ??
?? EJECT ??

                PROCEDURE collect_from_info_header
                  (    module_name: pmt$program_name;
                       info_element_header: ^llt$info_element_header;
                   VAR file: ^SEQ ( * );
                   VAR separated_module: oct$separated_module_header;
                   VAR status: ost$status);


                  VAR
                    relocation: ^llt$relocation,
                    binding_section_template: ^llt$binding_section_template,
                    components: ^llt$component_information,
                    index: llt$number_of_info_elements,
                    i: integer,
                    last_byte_relocation: ^oct$relocation_item_list,
                    last_two_byte_relocation: ^oct$relocation_item_list,
                    last_four_byte_relocation: ^oct$relocation_item_list,
                    last_eight_byte_relocation: ^oct$relocation_item_list;


                  IF info_element_header^.number_of_rel_items <> 0 THEN
                    separated_module.relocation_list.byte.link := NIL;
                    last_byte_relocation := ^separated_module.relocation_list.byte;
                    separated_module.relocation_list.two_byte.link := NIL;
                    last_two_byte_relocation := ^separated_module.relocation_list.two_byte;
                    separated_module.relocation_list.four_byte.link := NIL;
                    last_four_byte_relocation := ^separated_module.relocation_list.four_byte;
                    separated_module.relocation_list.eight_byte.link := NIL;
                    last_eight_byte_relocation := ^separated_module.relocation_list.eight_byte;

                    relocation := #PTR (info_element_header^.relocation_ptr, file^);
                    IF relocation = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                      RETURN;
                    IFEND;

                    FOR i := 1 TO info_element_header^.number_of_rel_items DO
                      CASE relocation^ [i].address OF
                      = llc$byte_positive, llc$byte_signed =
                        NEXT last_byte_relocation^.link IN ocv$olg_scratch_seq;
                        last_byte_relocation := last_byte_relocation^.link;
                        IF last_byte_relocation = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                          RETURN;
                        IFEND;

                        last_byte_relocation^.item := ^relocation^ [i];
                        last_byte_relocation^.link := NIL;

                      = llc$two_byte_positive, llc$two_byte_signed =
                        NEXT last_two_byte_relocation^.link IN ocv$olg_scratch_seq;
                        last_two_byte_relocation := last_two_byte_relocation^.link;
                        IF last_two_byte_relocation = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                          RETURN;
                        IFEND;

                        last_two_byte_relocation^.item := ^relocation^ [i];
                        last_two_byte_relocation^.link := NIL;

                      = llc$four_byte_positive, llc$four_byte_signed =
                        NEXT last_four_byte_relocation^.link IN ocv$olg_scratch_seq;
                        last_four_byte_relocation := last_four_byte_relocation^.link;
                        IF last_four_byte_relocation = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                          RETURN;
                        IFEND;

                        last_four_byte_relocation^.item := ^relocation^ [i];
                        last_four_byte_relocation^.link := NIL;

                      = llc$eight_byte_positive, llc$eight_byte_signed =
                        NEXT last_eight_byte_relocation^.link IN ocv$olg_scratch_seq;
                        last_eight_byte_relocation := last_eight_byte_relocation^.link;
                        IF last_eight_byte_relocation = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                          RETURN;
                        IFEND;

                        last_eight_byte_relocation^.item := ^relocation^ [i];
                        last_eight_byte_relocation^.link := NIL;

                      ELSE
                        osp$set_status_abnormal (oc, oce$e_invalid_container_adr_typ,
                              separated_module.header^.name, status);
                        RETURN;
                      CASEND;
                    FOREND;

                  IFEND;

                  IF info_element_header^.number_of_template_items <> 0 THEN
                    binding_section_template := #PTR (info_element_header^.binding_template_ptr, file^);
                    IF binding_section_template = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                      RETURN;
                    IFEND;

{ The BINDING_TEMPLATE_LIST being set up here is an array where each entry represents a word in the
{ binding section (ie. entry 0 represents the first 8 bytes in the binding section, entry 1 represents
{ the second 8 bytes in the binding section, etc.).  This allows the binding template item for any
{ binding offset to be found directly by dividing the binding offset by 8 to get the index into this
{ array which contains a pointer to the binding template item.  Note that each entry in the binding
{ section is either 1 word or 2 words long and the binding offset will either be on a word boundary or
{ in the case of an internal address, the word boundary + 2.
{
{ The size of the array was chosen to be the number_of_template_items * 2 because the maximum size of an
{ entry in the binding section is 2 words.  This should be more than adequate since many entries should
{ only be 1 word in length.

                    NEXT separated_module.binding_template_list: [0 .. (info_element_header^.
                          number_of_template_items * 2)] IN ocv$olg_scratch_seq;
                    IF separated_module.binding_template_list = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    separated_module.number_of_template_items := info_element_header^.
                          number_of_template_items;

                    FOR i := 0 TO (info_element_header^.number_of_template_items * 2) DO
                      separated_module.binding_template_list^ [i].binding_template := NIL;
                    FOREND;

                    FOR i := 1 TO info_element_header^.number_of_template_items DO
                      index := binding_section_template^ [i].binding_offset DIV 8;
                      separated_module.binding_template_list^ [index].binding_template :=
                            ^binding_section_template^ [i];
                      separated_module.binding_template_list^ [index].referenced_in_new_binding_sect := FALSE;
                    FOREND;
                  IFEND;

                  IF info_element_header^.number_of_section_maps <> 0 THEN
                    components := #PTR (info_element_header^.component_ptr, file^);
                    IF components = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                      RETURN;
                    IFEND;

                    NEXT separated_module.components: [1 .. info_element_header^.number_of_components] IN
                          ocv$olg_scratch_seq;
                    IF separated_module.components = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    FOR i := 1 TO info_element_header^.number_of_components DO
                      separated_module.components^ [i].description := components^ [i];
                    FOREND;


                    separated_module.section_maps := #PTR (info_element_header^.section_maps, file^);
                    IF separated_module.section_maps = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
                      RETURN;
                    IFEND;
                  IFEND;


                PROCEND collect_from_info_header;
?? OLDTITLE ??
?? EJECT ??


                VAR
                  i: llt$module_index,
                  object_text_descriptor: ^llt$object_text_descriptor,
                  new_header: llt$info_element_header,
                  info_element_header: ^llt$info_element_header;


                FOR i := 1 TO UPPERBOUND (bound_components^) DO

                  CASE bound_components^ [i]^.kind OF
                  = occ$load_module =
                    object_text_descriptor := #PTR (bound_components^ [i]^.load_module_header^.
                          interpretive_element, bound_components^ [i]^.file^);
                    IF object_text_descriptor = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, bound_components^ [i]^.name,
                            status);
                      RETURN;
                    IFEND;

                    RESET bound_components^ [i]^.file TO object_text_descriptor;
                    NEXT object_text_descriptor IN bound_components^ [i]^.file;

                    separate_object_records (bound_components^ [i]^.name, debug_tables_to_omit,
                          bound_components^ [i]^.file, changed_entry_points, separated_components^ [i],
                          status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;

                    IF llc$information_element IN bound_components^ [i]^.load_module_header^.
                          elements_defined THEN
                      info_element_header := #PTR (bound_components^ [i]^.load_module_header^.
                            information_element, bound_components^ [i]^.file^);

                      IF (info_element_header^.version <> llc$info_element_version) THEN
                        ocp$convert_information_element (info_element_header, new_header);
                        info_element_header := ^new_header;
                      IFEND;

                      collect_from_info_header (bound_components^ [i]^.name, info_element_header,
                            bound_components^ [i]^.file, separated_components^ [i], status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;
                    IFEND;

                  = occ$cpu_object_module =
                    RESET bound_components^ [i]^.file TO bound_components^ [i]^.cpu_object_module_header^.
                          identification;
                    separate_object_records (bound_components^ [i]^.name, debug_tables_to_omit,
                          bound_components^ [i]^.file, changed_entry_points, separated_components^ [i],
                          status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;


                  CASEND;
                FOREND;


              PROCEND separate_components;
?? OLDTITLE ??
?? NEWTITLE := '              COLLECT_COMPONENT_INFO' ??
?? EJECT ??

              PROCEDURE collect_component_info
                (    component: ^oct$separated_components;
                 VAR component_info: ^llt$component_information;
                 VAR status: ost$status);


                VAR
                  i: integer,
                  j: integer,
                  count: integer,
                  component_description: ^llt$component_description,
                  reset_value: ^SEQ ( * );


                count := 0;
                reset_value := ocv$olg_scratch_seq;

                FOR i := 1 TO UPPERBOUND (component^) DO
                  IF component^ [i].components = NIL THEN
                    NEXT component_description IN ocv$olg_scratch_seq;
                    IF component_description = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    count := count + 1;
                    component^ [i].component_number := count;
                    component_description^.name := component^ [i].header^.name;
                    component_description^.time_created := component^ [i].header^.time_created;
                    component_description^.date_created := component^ [i].header^.date_created;
                    component_description^.generator_id := component^ [i].header^.generator_id;
                    component_description^.generator_name_vers := component^ [i].header^.generator_name_vers;
                    component_description^.commentary := component^ [i].header^.commentary;
                  ELSE
                    FOR j := 1 TO UPPERBOUND (component^ [i].components^) DO
                      NEXT component_description IN ocv$olg_scratch_seq;
                      IF component_description = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                        RETURN;
                      IFEND;

                      count := count + 1;
                      component^ [i].components^ [j].new_component_number := count;
                      component_description^ := component^ [i].components^ [j].description;
                    FOREND;
                  IFEND;
                FOREND;

                ocv$olg_scratch_seq := reset_value;
                NEXT component_info: [1 .. count] IN ocv$olg_scratch_seq;


              PROCEND collect_component_info;
?? OLDTITLE ??
?? NEWTITLE := '              COLLECT_LIBRARIES' ??
?? EJECT ??

              PROCEDURE collect_libraries
                (    component: oct$separated_module_header;
                 VAR new_modules_library_list: oct$name_list;
                 VAR status: ost$status);

                VAR
                  library: 1 .. llc$max_libraries,
                  new_library: ^oct$name_list,
                  component_library: ^oct$library_list;


                component_library := component.library_list.link;

                WHILE component_library <> NIL DO
                  FOR library := LOWERBOUND (component_library^.libraries^)
                        TO UPPERBOUND (component_library^.libraries^) DO

                    new_library := ^new_modules_library_list;

                    WHILE (new_library^.link <> NIL) AND (new_library^.link^.name <>
                          component_library^.libraries^ [library]) DO
                      new_library := new_library^.link;
                    WHILEND;

                    IF new_library^.link = NIL THEN
                      NEXT new_library^.link IN ocv$olg_scratch_seq;
                      new_library := new_library^.link;
                      IF new_library = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                        RETURN;
                      IFEND;

                      new_library^.name := component_library^.libraries^ [library];
                      new_library^.link := NIL;
                    IFEND;
                  FOREND;

                  component_library := component_library^.link;
                WHILEND;


              PROCEND collect_libraries;
?? OLDTITLE ??
?? NEWTITLE := '              COLLECT_SECTION_RECORDS' ??
?? EJECT ??

              PROCEDURE collect_section_records
                (VAR component: oct$separated_module_header;
                 VAR current_section_ordinal: 0 .. llc$max_section_ordinal + 1;
                 VAR section_definitions: oct$section_definition_list;
                 VAR status: ost$status);

?? NEWTITLE := '                GET_NEW_SECTION' ??
?? NEWTITLE := '                  CONVERT_RW_TO_ALLOTTED_SEGMENT', EJECT ??

                PROCEDURE get_new_section
                  (VAR old_section: oct$section_definition;
                   VAR section_definitions: oct$section_definition_list;
                   VAR current_section_ordinal: 0 .. llc$max_section_ordinal + 1;
                   VAR new_section: ^oct$section_definition_list;
                   VAR status: ost$status);






                  PROCEDURE convert_rw_to_allotted_segment
                    (VAR old: oct$section_definition);


                    VAR
                      tir: ^oct$text_insertion_list;



                    IF NOT (llc$binding IN old.section_definition.access_attributes) THEN
                      tir := old.text_insertion_records.link;
                      IF (tir <> NIL) AND (tir^.kind = llc$text) AND (tir^.link = NIL) THEN
                        IF (#SIZE (tir^.text^.byte) >= occ$min_shadow_size) THEN
                          IF ((occ$min_shadow_size MOD old.section_definition.allocation_alignment) = 0) THEN
                            old.allotted_section := TRUE;
                            old.allotted_section_length := (((#SIZE (tir^.text^.byte) + occ$min_shadow_size -
                                  1) DIV occ$min_shadow_size) * occ$min_shadow_size);
                            old.section_definition.allocation_offset := 0;
                            old.section_definition.allocation_alignment := occ$min_shadow_size;
                          IFEND;
                        IFEND;
                      IFEND;
                    IFEND;


                  PROCEND convert_rw_to_allotted_segment;
?? OLDTITLE ??
?? EJECT ??


                  new_section := ^section_definitions;

                  WHILE new_section^.link <> NIL DO
                    new_section := new_section^.link;

                    IF NOT (old_section.predefined_segment OR new_section^.predefined_segment) THEN
                      IF (NOT quick_bind) OR (old_section.section_definition.kind <> llc$code_section) THEN
                        IF old_section.section_definition.kind <> llc$lts_reserved THEN
                          IF (old_section.section_definition.name = new_section^.section_definition.name) OR
                                (new_section^.section_definition.kind = llc$code_section) THEN
                            IF ((old_section.section_definition.kind = llc$common_block) OR
                                  (old_section.section_definition.kind = llc$extensible_common_block)) AND
                                  ((new_section^.section_definition.kind = llc$common_block) OR
                                  (new_section^.section_definition.kind = llc$extensible_common_block)) THEN
                              new_section^.section_definition.access_attributes :=
                                    new_section^.section_definition.access_attributes +
                                    old_section.section_definition.access_attributes;
                              new_section^.allotted_section := new_section^.allotted_section AND
                                    old_section.allotted_section;
                              RETURN;
                            IFEND;

                            IF old_section.section_definition.kind = new_section^.section_definition.kind THEN
                              IF old_section.section_definition.kind <> llc$extensible_working_storage THEN
                                IF (old_section.section_definition.kind = llc$binding_section) OR
                                      (old_section.section_definition.access_attributes =
                                      new_section^.section_definition.access_attributes) THEN
                                  IF old_section.allotted_section = new_section^.allotted_section THEN
                                    RETURN;
                                  IFEND;
                                IFEND;
                              IFEND;
                            IFEND;
                          IFEND;
                        IFEND;
                      IFEND;
                    IFEND;
                  WHILEND;

                  IF current_section_ordinal >= llc$max_section_ordinal THEN
                    osp$set_status_abnormal (oc, oce$e_too_many_section_defns, '', status);
                    RETURN;
                  IFEND;

                  NEXT new_section^.link IN segment_1;
                  new_section := new_section^.link;
                  IF new_section = NIL THEN
                    osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                    RETURN;
                  IFEND;

                  IF (old_section.predefined_segment) AND (NOT old_section.allotted_section) THEN
                    convert_rw_to_allotted_segment (old_section);
                  IFEND;

                  new_section^.link := NIL;
                  new_section^.section_definition := old_section.section_definition;
                  new_section^.section_definition.section_ordinal := current_section_ordinal;
                  current_section_ordinal := current_section_ordinal + 1;

                  IF old_section.section_definition.kind = llc$binding_section THEN
                    new_section^.section_definition.access_attributes :=
                          $llt$section_access_attributes [llc$read, llc$binding];
                  IFEND;

                  new_section^.predefined_segment := old_section.predefined_segment;
                  new_section^.predefined_segment_number := old_section.predefined_segment_number;
                  new_section^.predefined_r1 := old_section.predefined_r1;
                  new_section^.predefined_r2 := old_section.predefined_r2;
                  new_section^.predefined_binding_ordinal := old_section.predefined_binding_ordinal;
                  new_section^.predefined_binding_offset := old_section.predefined_binding_offset;
                  new_section^.section_ptr := NIL;
                  new_section^.old_sections.link := NIL;
                  new_section^.last_old_section := ^new_section^.old_sections;
                  new_section^.unallocated_common_block := old_section.unallocated_common_block;
                  new_section^.allotted_section := old_section.allotted_section;
                  new_section^.allotted_section_length := old_section.allotted_section_length;
                  new_section^.text_insertion_records.link := NIL;

{ Make sure that the binding section has the greatest section ordinal

                  IF ocv$binding_section <> NIL THEN
                    new_section^.section_definition.section_ordinal :=
                          ocv$binding_section^.section_definition.section_ordinal;
                    ocv$binding_section^.section_definition.section_ordinal := current_section_ordinal - 1;
                  ELSEIF new_section^.section_definition.kind = llc$binding_section THEN
                    ocv$binding_section := new_section;
                  IFEND;


                PROCEND get_new_section;
?? OLDTITLE ??
?? EJECT ??

                VAR
                  section_ordinal: llt$section_ordinal,
                  new_section: ^oct$section_definition_list;


                FOR section_ordinal := 0 TO UPPERBOUND (component.section_definitions^) DO
                  IF component.section_definitions^ [section_ordinal] <> NIL THEN
                    get_new_section (component.section_definitions^ [section_ordinal]^, section_definitions,
                          current_section_ordinal, new_section, status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;

                    component.section_definitions^ [section_ordinal]^.new := new_section;

                    NEXT new_section^.last_old_section^.link IN segment_1;
                    new_section^.last_old_section := new_section^.last_old_section^.link;
                    IF new_section^.last_old_section = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    new_section^.last_old_section^.component := ^component;
                    new_section^.last_old_section^.section_ordinal := section_ordinal;
                    new_section^.last_old_section^.link := NIL;
                  IFEND;
                FOREND;


              PROCEND collect_section_records;
?? OLDTITLE ??
?? NEWTITLE := '              SORT_CODE_SECTIONS', EJECT ??

              PROCEDURE sort_code_sections
                (    code_section_ids: oct$code_section_ids;
                     section_definitions: oct$section_definition_list);


                VAR
                  code: ^oct$section_definition_list,
                  last: ^oct$old_section_list,
                  old: ^oct$old_section_list,
                  temp: ^oct$old_section_list,
                  id: ^oct$code_section_ids;


                IF code_section_ids.link <> NIL THEN
                  code := section_definitions.link;
                  WHILE code^.section_definition.kind <> llc$code_section DO
                    code := code^.link;
                  WHILEND;

                  id := code_section_ids.link;
                  last := ^code^.old_sections;

                  WHILE id <> NIL DO
                    old := last;

                    WHILE (id^.name <> old^.link^.component^.header^.name) OR
                          (id^.section_ordinal <> old^.link^.section_ordinal) DO
                      old := old^.link;
                    WHILEND;

                    temp := old^.link;
                    old^.link := temp^.link;

                    temp^.link := last^.link;
                    last^.link := temp;

                    last := last^.link;

                    id := id^.link;
                  WHILEND;
                IFEND;


              PROCEND sort_code_sections;
?? OLDTITLE ??
?? NEWTITLE := '              BUILD_COMPOSITE_SECTIONS', EJECT ??

              PROCEDURE build_composite_sections
                (VAR section_definitions: oct$section_definition_list;
                 VAR status: ost$status);

?? NEWTITLE := '                UPDATE_SECTION', EJECT ??

                PROCEDURE update_section
                  (VAR composite: oct$section_definition_list;
                   VAR status: ost$status);

?? NEWTITLE := '                  RELOCATE_LINE_TABLE', EJECT ??

                  PROCEDURE relocate_obsolete_line_table
                    (    component: ^oct$separated_module_header;
                         section_ordinal: llt$section_ordinal;
                     VAR status: ost$status);


                    VAR
                      sequence: ^oct$olg_scratch_seq,
                      obsolete_line_table: ^llt$obsolete_line_address_table,
                      i: integer,
                      size: integer,
                      number_of_items: integer;


                    IF component^.section_definitions^ [section_ordinal]^.text <> NIL THEN
                      size := #SIZE (component^.section_definitions^ [section_ordinal]^.text^) -
                            (#SIZE (pmt$program_name) + #SIZE (boolean) + #SIZE (llt$module_generator) +
                            #SIZE (llt$line_address_table_size));
                      number_of_items := size DIV #SIZE (llt$obsolete_line_address_item);
                      IF number_of_items > 0 THEN
                        sequence := ocv$olg_scratch_seq;
                        RESET sequence TO component^.section_definitions^ [section_ordinal]^.text;

                        NEXT obsolete_line_table: [1 .. number_of_items] IN sequence;

                        FOR i := 1 TO number_of_items DO
                          check_section_ordinal_offset (obsolete_line_table^.item [i].section_ordinal,
                                obsolete_line_table^.item [i].offset, component^.section_definitions,
                                component^.header^.name, status);
                          IF NOT status.normal THEN
                            RETURN;
                          IFEND;

                          obsolete_line_table^.item [i].offset := relocated_section_offset
                                (component^, obsolete_line_table^.item [i].section_ordinal,
                                obsolete_line_table^.item [i].offset);
                          relocated_section_ordinal (component^, obsolete_line_table^.item [i].
                                section_ordinal, obsolete_line_table^.item [i].section_ordinal);
                        FOREND;
                      IFEND;
                    ELSE
                      osp$set_status_abnormal (oc, oce$e_bad_line_table, component^.header^.name, status);
                    IFEND;


                  PROCEND relocate_obsolete_line_table;
?? OLDTITLE ??
?? EJECT ??


                  VAR
                    offset: ost$segment_length,
                    old_section: ^oct$old_section_list,
                    old: ^oct$section_definition,
                    temp: ost$segment_length;


                  composite.section_definition.allocation_offset := 0;

                  offset := 0;
                  old_section := composite.old_sections.link;

                  WHILE old_section <> NIL DO
                    old := old_section^.component^.section_definitions^ [old_section^.section_ordinal];

{ compute new allocation alignment

                    temp := 1;
                    WHILE (temp < old^.section_definition.allocation_alignment) AND
                          ((temp * composite.section_definition.allocation_alignment) MOD
                          old^.section_definition.allocation_alignment <> 0) DO
                      temp := temp + 1;
                    WHILEND;

                    composite.section_definition.allocation_alignment :=
                          temp * composite.section_definition.allocation_alignment;


                    IF old^.section_definition.length <> 0 THEN
                      WHILE (offset MOD old^.section_definition.allocation_alignment) <>
                            old^.section_definition.allocation_offset DO
                        offset := offset + 1;
                      WHILEND;
                    IFEND;

                    old^.new_section_offset := offset;
                    offset := offset + old^.section_definition.length;

                    IF old^.section_definition.kind = llc$lts_reserved THEN
                      relocate_obsolete_line_table (old_section^.component, old_section^.section_ordinal,
                            status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;
                    IFEND;

                    old_section := old_section^.link;
                  WHILEND;

                  composite.section_definition.length := offset;


                  IF (composite.section_definition.kind = llc$code_section) THEN
                    IF (NOT quick_bind) THEN
                      composite.section_definition.name := osc$null_name;
                    IFEND;

                    IF (composite.predefined_segment) AND (ocv$binding_section <> NIL) THEN
                      composite.predefined_binding_ordinal := ocv$binding_section^.section_definition.
                            section_ordinal;
                    IFEND;
                  IFEND;

                PROCEND update_section;
?? OLDTITLE ??
?? NEWTITLE := '                  UPDATE_COMMON_SECTION', EJECT ??

                PROCEDURE update_common_section
                  (VAR composite: oct$section_definition_list);


                  VAR
                    offset: ost$segment_length,
                    old_section: ^oct$old_section_list,
                    old: ^oct$section_definition,
                    temp: ost$segment_length,
                    local_status: ost$status;


                  offset := composite.section_definition.allocation_offset;

                  old_section := composite.old_sections.link;

                  WHILE old_section <> NIL DO
                    old := old_section^.component^.section_definitions^ [old_section^.section_ordinal];

                    IF old^.section_definition.kind <> composite.section_definition.kind THEN
                      osp$set_status_abnormal (oc, oce$w_conflicting_com_attribute,
                            composite.section_definition.name, local_status);
                      ocp$generate_message (local_status);
                    IFEND;

                    IF old^.section_definition.access_attributes <>
                          composite.section_definition.access_attributes THEN
                      osp$set_status_abnormal (oc, oce$w_conflicting_com_attribute,
                            composite.section_definition.name, local_status);
                      ocp$generate_message (local_status);
                    IFEND;

                    IF (old^.section_definition.allocation_alignment <>
                          composite.section_definition.allocation_alignment) OR
                          (old^.section_definition.allocation_offset <>
                          composite.section_definition.allocation_offset) THEN
                      osp$set_status_abnormal (oc, oce$w_conflicting_com_attribute,
                            composite.section_definition.name, local_status);
                      ocp$generate_message (local_status);
                    IFEND;

                    IF old^.section_definition.length > composite.section_definition.length THEN
                      IF composite.section_definition.kind = llc$extensible_common_block THEN
                        composite.section_definition.length := old^.section_definition.length;
                      ELSE
                        osp$set_status_abnormal (oc, oce$w_conflicting_common_length,
                              composite.section_definition.name, local_status);
                        ocp$generate_message (local_status);
                        old^.section_definition.length := composite.section_definition.length;
                      IFEND;
                    IFEND;

                    old^.new_section_offset := offset;

                    old_section := old_section^.link;
                  WHILEND;

                  composite.section_definition.allocation_offset := 0;
                  composite.section_definition.length := composite.section_definition.length + offset;


                PROCEND update_common_section;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] initialize_preset_segment', EJECT ??

{ PURPOSE:
{   The purpose of this request is to determine if a preset segment exists or
{   not and, if it does not exist, to create it.
{ NOTE:
{   This request must NOT be called in a loop since it has automatic variable
{   space.  If the need to call this request in a loop arises, this cannot be
{   inline any longer.

                PROCEDURE [INLINE] initialize_preset_segment
                  (    preset_value: pmt$initialization_value;
                   VAR status: ost$status);

                  VAR
                    segment_attributes_p: ^array [ * ] of mmt$user_attribute_descriptor;

                  status.normal := TRUE;
                  IF preset_segment [preset_value].sequence_pointer = NIL THEN
                    PUSH segment_attributes_p: [1 .. 1];
                    segment_attributes_p^ [1].keyword := mmc$ua_preset_value;
                    segment_attributes_p^ [1].preset_value := preset_value;
                    mmp$create_user_segment (segment_attributes_p, amc$sequence_pointer, mmc$as_random,
                          preset_segment [preset_value], status);
                    IF status.normal THEN
                      RESET preset_segment [preset_value].sequence_pointer;
                    IFEND;
                  IFEND;

                PROCEND initialize_preset_segment;
?? OLDTITLE ??
?? NEWTITLE := 'collect_allotted_sections', EJECT ??

                PROCEDURE collect_allotted_sections
                  (VAR composite: oct$section_definition_list;
                   VAR status: ost$status);


                  VAR
                    cell_ptr: ^cell,
                    current_sequence_position: ost$segment_offset,
                    old_section: ^oct$old_section_list,
                    old: ^oct$section_definition,
                    preset_value: pmt$initialization_value,
                    seq_ptr: ^SEQ ( * ),
                    valid_position: boolean;

                  preset_value := bound_module.preset_value;
                  initialize_preset_segment (preset_value, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;

                  current_sequence_position := i#current_sequence_position
                        (preset_segment [preset_value].sequence_pointer);
                  WHILE (current_sequence_position MOD composite.section_definition.allocation_alignment) <>
                        composite.section_definition.allocation_offset DO
                    current_sequence_position := current_sequence_position + 1;
                  WHILEND;
                  pmp$position_object_library (preset_segment [preset_value].sequence_pointer,
                        current_sequence_position, valid_position);
                  IF NOT valid_position THEN
                    osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
                    RETURN;
                  IFEND;

                  seq_ptr := preset_segment [preset_value].sequence_pointer;

                  IF composite.section_definition.length <> 0 THEN
                    NEXT composite.section_ptr: [0 .. composite.section_definition.length - 1] IN
                          preset_segment [preset_value].sequence_pointer;
                    IF composite.section_ptr = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    old_section := composite.old_sections.link;

                    WHILE old_section <> NIL DO
                      old := old_section^.component^.section_definitions^ [old_section^.section_ordinal];

                      IF old^.text <> NIL THEN
                        cell_ptr := #LOC (composite.section_ptr^ [old^.new_section_offset]);
                        i#move (#LOC (old^.text^ [1]), cell_ptr, old^.section_definition.length);

                        RESET seq_ptr TO cell_ptr;
                        NEXT old^.text: [1 .. old^.section_definition.length] IN seq_ptr;
                      IFEND;

                      old_section := old_section^.link;
                    WHILEND;
                  IFEND;


                PROCEND collect_allotted_sections;
?? OLDTITLE ??
?? NEWTITLE := '              COLLECT_ALLOTTED_RW_SECTIONS', EJECT ??

                PROCEDURE collect_allotted_rw_sections
                  (VAR composite: oct$section_definition_list;
                   VAR status: ost$status);


                  VAR
                    current_sequence_position: ost$segment_offset,
                    length: ost$segment_length,
                    old_section: ^oct$old_section_list,
                    old: ^oct$section_definition,
                    preset_value: pmt$initialization_value,
                    tir: ^oct$text_insertion_list,
                    valid_position: boolean;

                  preset_value := bound_module.preset_value;
                  initialize_preset_segment (preset_value, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;

                  current_sequence_position := i#current_sequence_position
                        (preset_segment [preset_value].sequence_pointer);
                  WHILE (current_sequence_position MOD composite.section_definition.allocation_alignment) <>
                        composite.section_definition.allocation_offset DO
                    current_sequence_position := current_sequence_position + 1;
                  WHILEND;
                  pmp$position_object_library (preset_segment [preset_value].sequence_pointer,
                        current_sequence_position, valid_position);
                  IF NOT valid_position THEN
                    osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
                    RETURN;
                  IFEND;

                  old_section := composite.old_sections.link;
                  old := old_section^.component^.section_definitions^ [old_section^.section_ordinal];

                  NEXT composite.section_ptr: [0 .. old^.allotted_section_length - 1] IN
                        preset_segment [preset_value].sequence_pointer;
                  IF (composite.section_ptr = NIL) THEN
                    osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '944', status);
                    RETURN;
                  IFEND;

                  tir := old^.text_insertion_records.link;
                  length := #SIZE (tir^.text^.byte);

{ Fill in whatever part of the section has been initialized.  The remainder
{ defaults to the preset value for the bound module.

                  i#move (#LOC (tir^.text^.byte), #LOC (composite.section_ptr^), length);
                PROCEND collect_allotted_rw_sections;
?? OLDTITLE ??
?? NEWTITLE := '              COLLECT_TEXT_INSERTION_RECORDS', EJECT ??

                PROCEDURE collect_text_insertion_records
                  (VAR composite: oct$section_definition_list;
                   VAR status: ost$status);


                  VAR
                    old_section: ^oct$old_section_list,
                    old: ^oct$section_definition,
                    text: ^oct$text_insertion_list,
                    last_record: ^oct$text_insertion_list;


                  old_section := composite.old_sections.link;
                  last_record := ^composite.text_insertion_records;

                  WHILE old_section <> NIL DO
                    old := old_section^.component^.section_definitions^ [old_section^.section_ordinal];

                    IF old^.text <> NIL THEN
                      NEXT text IN segment_2;
                      IF text = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                        RETURN;
                      IFEND;

                      text^.kind := llc$text;
                      text^.link := NIL;

                      NEXT text^.text: [1 .. old^.section_definition.length] IN segment_1;
                      IF text^.text = NIL THEN
                        osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                        RETURN;
                      IFEND;

                      text^.offset := 0;
                      text^.bit_offset := 0;
                      text^.length := old^.section_definition.length;
                      text^.starting_bit_offset := 0;
                      text^.ending_bit_offset := 0 + (8 * text^.length) - 1;
                      text^.overlapped := FALSE;
                      text^.text^.section_ordinal := old^.section_definition.section_ordinal;
                      text^.text^.offset := 0;
                      text^.text^.byte := old^.text^;
                      old^.text_insertion_records.link := text;
                    IFEND;

                    last_record^.link := old^.text_insertion_records.link;

                    WHILE last_record^.link <> NIL DO
                      last_record := last_record^.link;

                      last_record^.offset := last_record^.offset + old^.new_section_offset;
                      last_record^.starting_bit_offset := last_record^.starting_bit_offset +
                            (8 * old^.new_section_offset);
                      last_record^.ending_bit_offset := last_record^.ending_bit_offset +
                            (8 * old^.new_section_offset);
                    WHILEND;

                    old_section := old_section^.link;
                  WHILEND;


                PROCEND collect_text_insertion_records;
?? OLDTITLE ??
?? NEWTITLE := '              PACK_TEXT_INSERTION_RECORDS', EJECT ??

                PROCEDURE pack_text_insertion_records
                  (VAR composite: oct$section_definition_list;
                   VAR status: ost$status);


?? NEWTITLE := 'pack_text_records', EJECT ??

                  PROCEDURE pack_text_records
                    (VAR last_record: ^oct$text_insertion_list;
                     VAR last_text_insertion_record: ^oct$text_insertion_list;
                     VAR status: ost$status);

                    VAR
                      current_sequence_position: ost$segment_offset,
                      i: ost$segment_length,
                      length: ost$segment_length,
                      next_record: ^oct$text_insertion_list,
                      offset: ost$segment_offset,
                      preset_value: pmt$initialization_value,
                      valid_position: boolean;

                    preset_value := bound_module.preset_value;
                    initialize_preset_segment (preset_value, status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;


                    offset := last_record^.offset;
                    length := last_record^.length;
                    next_record := last_record^.link;

                  /loop/
                    WHILE (next_record <> NIL) AND (next_record^.kind = llc$text) DO
                      IF next_record^.offset < offset THEN
                        IF (next_record^.offset + next_record^.length) >= offset THEN
                          IF (next_record^.offset + next_record^.length) >= (offset + length) THEN
                            length := next_record^.length;
                          ELSE
                            length := (offset + length) - next_record^.offset;
                          IFEND;
                          offset := next_record^.offset;
                        ELSE
                          EXIT /loop/;
                        IFEND;

                      ELSEIF next_record^.offset <= (offset + length) THEN
                        IF (offset + length) < (next_record^.offset + next_record^.length) THEN
                          length := (next_record^.offset + next_record^.length) - offset;
                        IFEND;

{ If the user did not supply a preset value on the create_module request, do not
{ force non-adjacent text records together.  That is, keep the records distinct to
{ allow the flexibility of specifying preset value at execution or link time.

                      ELSEIF (bound_module.preset_specified) AND (next_record^.offset >= highest_offset) AND
                            ((next_record^.offset) <= (offset + length + 24)) THEN
                        IF (offset + length) < (next_record^.offset + next_record^.length) THEN
                          length := (next_record^.offset + next_record^.length) - offset;
                        IFEND;

                      ELSE
                        EXIT /loop/;
                      IFEND;

                      next_record := next_record^.link;
                    WHILEND /loop/;

                    NEXT last_text_insertion_record^.link IN segment_2;
                    last_text_insertion_record := last_text_insertion_record^.link;
                    IF last_text_insertion_record = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    last_text_insertion_record^.offset := offset;
                    last_text_insertion_record^.bit_offset := 0;
                    last_text_insertion_record^.length := length;
                    last_text_insertion_record^.starting_bit_offset := (8 * offset);
                    last_text_insertion_record^.ending_bit_offset :=
                          last_text_insertion_record^.starting_bit_offset + (8 * length) - 1;
                    last_text_insertion_record^.kind := llc$text;
                    last_text_insertion_record^.link := NIL;

                    current_sequence_position := i#current_sequence_position
                          (preset_segment [preset_value].sequence_pointer);
                    WHILE (current_sequence_position MOD composite.section_definition.allocation_alignment) <>
                          composite.section_definition.allocation_offset DO
                      current_sequence_position := current_sequence_position + 1;
                    WHILEND;

{ Offset the start of the data for the text record in the preset value segment according
{ the new nearest word offset.  The full offset does not need to be considered.  The
{ calculation is based on the position of the 'BYTE' field in the type llt$text.

{ WARNING!!!  - This code is based on the type llt$text not being changed.  It assumes
{  TYPE
{    llt$text = record
{      section_ordinal: llt$section_ordinal,
{      offset: llt$section_offset,
{      byte: array [1 .. *] of 0..255,
{    recend;

                    WHILE ((current_sequence_position MOD 8) <> ((last_text_insertion_record^.offset -
                          #SIZE (llt$section_ordinal) - #SIZE (llt$section_offset) + 8) MOD 8)) DO
                      current_sequence_position := current_sequence_position + 1;
                    WHILEND;
                    pmp$position_object_library (preset_segment [preset_value].sequence_pointer,
                          current_sequence_position, valid_position);
                    IF NOT valid_position THEN
                      osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
                      RETURN;
                    IFEND;

                    NEXT last_text_insertion_record^.text: [1 .. length] IN
                          preset_segment [preset_value].sequence_pointer;
                    IF last_text_insertion_record^.text = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    last_text_insertion_record^.text^.section_ordinal :=
                          composite.section_definition.section_ordinal;
                    last_text_insertion_record^.text^.offset := offset;

{ Anything that is not initialized will be based on the preset value in the resulting
{ packed record.

                    REPEAT
                      i#move (#LOC (last_record^.text^.byte), #LOC (last_text_insertion_record^.text^.
                            byte [(last_record^.offset - offset + 1)]), UPPERBOUND (last_record^.text^.byte));

                      last_record := last_record^.link;
                    UNTIL last_record = next_record;

                    IF (offset + length) > highest_offset THEN
                      highest_offset := offset + length;
                    IFEND;


                  PROCEND pack_text_records;
?? OLDTITLE ??
?? NEWTITLE := '                ADD_REPLICATION_RECORD', EJECT ??

                  PROCEDURE add_replication_record
                    (VAR last_record: ^oct$text_insertion_list;
                     VAR last_text_insertion_record: ^oct$text_insertion_list;
                     VAR status: ost$status);


                    NEXT last_text_insertion_record^.link IN segment_2;
                    last_text_insertion_record := last_text_insertion_record^.link;
                    IF last_text_insertion_record = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    last_text_insertion_record^ := last_record^;
                    last_text_insertion_record^.link := NIL;


                    NEXT last_text_insertion_record^.replication:
                          [1 .. UPPERBOUND (last_record^.replication^.byte)] IN segment_1;
                    IF last_text_insertion_record^.replication = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    last_text_insertion_record^.replication^ := last_record^.replication^;
                    last_text_insertion_record^.replication^.section_ordinal :=
                          composite.section_definition.section_ordinal;
                    last_text_insertion_record^.replication^.offset := last_record^.offset;


                    IF (last_record^.offset + last_record^.length) > highest_offset THEN
                      highest_offset := last_record^.offset + last_record^.length;
                    IFEND;


                    last_record := last_record^.link;


                  PROCEND add_replication_record;
?? OLDTITLE ??
?? NEWTITLE := '                ADD_BIT_STRING_INSERTION_RECORD', EJECT ??

                  PROCEDURE add_bit_string_insertion_record
                    (VAR last_record: ^oct$text_insertion_list;
                     VAR last_text_insertion_record: ^oct$text_insertion_list;
                     VAR status: ost$status);


                    NEXT last_text_insertion_record^.link IN segment_2;
                    last_text_insertion_record := last_text_insertion_record^.link;
                    IF last_text_insertion_record = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    last_text_insertion_record^ := last_record^;
                    last_text_insertion_record^.link := NIL;


                    NEXT last_text_insertion_record^.bit_string_insertion IN segment_1;
                    IF last_text_insertion_record^.bit_string_insertion = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    last_text_insertion_record^.bit_string_insertion^ := last_record^.bit_string_insertion^;
                    last_text_insertion_record^.bit_string_insertion^.section_ordinal :=
                          composite.section_definition.section_ordinal;
                    last_text_insertion_record^.bit_string_insertion^.offset := last_record^.offset;


                    IF (last_record^.offset + last_record^.length) > highest_offset THEN
                      highest_offset := last_record^.offset + last_record^.length;
                    IFEND;


                    last_record := last_record^.link;


                  PROCEND add_bit_string_insertion_record;
?? OLDTITLE ??
?? EJECT ??


                  VAR
                    last_text_insertion_record: ^oct$text_insertion_list,
                    last_record: ^oct$text_insertion_list,
                    highest_offset: ost$segment_length;


                  last_record := composite.text_insertion_records.link;
                  last_text_insertion_record := ^composite.text_insertion_records;
                  last_text_insertion_record^.link := NIL;


                  highest_offset := 0;

                  WHILE last_record <> NIL DO

                    CASE last_record^.kind OF
                    = llc$text =
                      pack_text_records (last_record, last_text_insertion_record, status);
                    = llc$replication =
                      add_replication_record (last_record, last_text_insertion_record, status);
                    = llc$bit_string_insertion =
                      add_bit_string_insertion_record (last_record, last_text_insertion_record, status);
                    CASEND;

                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;
                  WHILEND;


                PROCEND pack_text_insertion_records;
?? OLDTITLE ??
?? EJECT ??

                VAR
                  composite: ^oct$section_definition_list;


                composite := section_definitions.link;

                WHILE composite <> NIL DO
                  IF (composite^.section_definition.kind = llc$common_block) OR
                        (composite^.section_definition.kind = llc$extensible_common_block) THEN
                    update_common_section (composite^);
                  ELSE
                    update_section (composite^, status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;
                  IFEND;

                  IF composite^.allotted_section THEN
                    IF (composite^.allotted_section_length = 0) THEN
                      collect_allotted_sections (composite^, status);
                    ELSE
                      collect_allotted_rw_sections (composite^, status);
                    IFEND;
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;

                  ELSE
                    collect_text_insertion_records (composite^, status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;

                    pack_text_insertion_records (composite^, status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;
                  IFEND;

                  composite := composite^.link;
                WHILEND;


              PROCEND build_composite_sections;
?? OLDTITLE ??
?? NEWTITLE := '              COLLECT_MISCELLANEOUS_RECORDS', EJECT ??

              PROCEDURE collect_miscellaneous_records
                (    separated_components: ^oct$separated_components;
                 VAR miscellaneous_record_list: oct$object_record_list;
                 VAR status: ost$status);

?? NEWTITLE := '                RELOCATE_CYBIL_SYMBOL_TABLE', EJECT ??

                PROCEDURE relocate_cybil_symbol_table
                  (    sequence: ^SEQ ( * );
                   VAR status: ost$status);


                  VAR
                    symbol_table: ^SEQ ( * ),
                    j: integer,
                    item: ^array [1 .. * ] of cyt$debug_symbol_table_item,
                    number_of_items: integer,
                    ordinal: llt$section_ordinal,
                    offset: llt$section_offset,
                    symbol_table_pointer: ^cyt$debug_symbol_table,
                    valid_position: boolean;


                  symbol_table := sequence;

                  IF (#SIZE (symbol_table^) MOD #SIZE (cyt$debug_symbol_table_item)) <> 0 THEN
                    pmp$position_object_library (symbol_table, 41, valid_position);
                    IF NOT valid_position THEN
                      osp$set_status_abnormal (oc, oce$e_bad_symbol_table,
                            separated_components^ [i].header^.name, status);
                      RETURN;
                    IFEND;
                  ELSE
                    RESET symbol_table;
                  IFEND;

                  number_of_items := #SIZE (symbol_table^) DIV #SIZE (cyt$debug_symbol_table_item);

                  IF number_of_items > 0 THEN
                    NEXT item: [1 .. number_of_items] IN symbol_table;
                    IF item = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_bad_symbol_table,
                            separated_components^ [i].header^.name, status);
                      osp$append_status_integer (osc$status_parameter_delimiter, 0, 10, FALSE, status);
                      RETURN;
                    IFEND;

                    FOR j := 1 TO number_of_items DO
                      CASE item^ [j].symbol_type OF
                      = proc_kind =
                        check_section_ordinal_offset (item^ [j].proc_section_ordinal, item^ [j].proc_offset,
                              separated_components^ [i].section_definitions, separated_components^ [i].
                              header^.name, status);
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;

                        item^ [j].proc_offset := relocated_section_offset
                              (separated_components^ [i], item^ [j].proc_section_ordinal,
                              item^ [j].proc_offset);
                        relocated_section_ordinal (separated_components^ [i], item^ [j].proc_section_ordinal,
                              item^ [j].proc_section_ordinal);

                      = var_kind =
                        IF item^ [j].base = static_base THEN
                          check_section_ordinal_offset (item^ [j].var_section_ordinal, item^ [j].var_offset,
                                separated_components^ [i].section_definitions,
                                separated_components^ [i].header^.name, status);
                          IF NOT status.normal THEN
                            RETURN;
                          IFEND;

                          item^ [j].var_offset := relocated_section_offset
                                (separated_components^ [i], item^ [j].var_section_ordinal,
                                item^ [j].var_offset);
                          relocated_section_ordinal (separated_components^ [i], item^ [j].var_section_ordinal,
                                item^ [j].var_section_ordinal);
                        IFEND;

                      ELSE
                      CASEND;

                      IF NOT status.normal THEN
                        ocp$generate_message (status);
                        osp$set_status_abnormal (oc, oce$e_bad_symbol_table, separated_components^ [i].
                              header^.name, status);
                        osp$append_status_integer (osc$status_parameter_delimiter, j, 10, FALSE, status);
                        RETURN;
                      IFEND;
                    FOREND;
                  IFEND;


                PROCEND relocate_cybil_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := '                RELOCATE_OBSOLETE_LINE_TABLE', EJECT ??

                PROCEDURE relocate_obsolete_line_table
                  (    obsolete_line_address_table: ^llt$obsolete_line_address_table);


                  VAR
                    j: 1 .. llc$max_line_adr_table_size;


                  FOR j := 1 TO UPPERBOUND (obsolete_line_address_table^.item) DO
                    check_section_ordinal_offset (obsolete_line_address_table^.item [j].section_ordinal,
                          obsolete_line_address_table^.item [j].offset,
                          separated_components^ [i].section_definitions,
                          separated_components^ [i].header^.name, status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;

                    obsolete_line_address_table^.item [j].offset :=
                          relocated_section_offset (separated_components^ [i],
                          obsolete_line_address_table^.item [j].section_ordinal,
                          obsolete_line_address_table^.item [j].offset);
                    relocated_section_ordinal (separated_components^ [i],
                          obsolete_line_address_table^.item [j].section_ordinal,
                          obsolete_line_address_table^.item [j].section_ordinal);
                  FOREND;


                PROCEND relocate_obsolete_line_table;
?? OLDTITLE ??
?? NEWTITLE := '                RELOCATE_DEBUG_SYMBOL_TABLE', EJECT ??

                PROCEDURE relocate_debug_symbol_table
                  (    sequence: ^SEQ ( * );
                   VAR status: ost$status);


                  VAR
                    symbol_table_sequence: ^SEQ ( * ),
                    j: integer,
                    symbol_table: ^llt$debug_symbol_table,
                    ordinal: llt$section_ordinal,
                    offset: llt$section_offset;


                  symbol_table_sequence := sequence;

                  RESET symbol_table_sequence;
                  NEXT symbol_table: [1 .. 1] IN symbol_table_sequence;
                  IF symbol_table = NIL THEN
                    osp$set_status_abnormal (oc, oce$e_bad_symbol_table,
                          separated_components^ [i].header^.name, status);
                    osp$append_status_integer (osc$status_parameter_delimiter, 0, 10, FALSE, status);
                    RETURN;
                  IFEND;

                  RESET symbol_table_sequence;
                  NEXT symbol_table: [1 .. symbol_table^.number_of_items] IN symbol_table_sequence;
                  IF symbol_table = NIL THEN
                    osp$set_status_abnormal (oc, oce$e_bad_symbol_table,
                          separated_components^ [i].header^.name, status);
                    osp$append_status_integer (osc$status_parameter_delimiter, 0, 10, FALSE, status);
                    RETURN;
                  IFEND;

                  FOR j := 1 TO symbol_table^.number_of_items DO
                    CASE symbol_table^.item [j].symbol_kind OF
                    = llc$proc_kind =
                      check_section_ordinal_offset (symbol_table^.item [j].proc_section_ordinal,
                            symbol_table^.item [j].proc_offset, separated_components^ [i].section_definitions,
                            separated_components^ [i].header^.name, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                      symbol_table^.item [j].proc_offset := relocated_section_offset
                            (separated_components^ [i], symbol_table^.item [j].proc_section_ordinal,
                            symbol_table^.item [j].proc_offset);
                      relocated_section_ordinal (separated_components^ [i],
                            symbol_table^.item [j].proc_section_ordinal,
                            symbol_table^.item [j].proc_section_ordinal);

                    = llc$ftn_array_kind =
                      IF symbol_table^.item [j].ftn_array_base = llc$static_base THEN
                        check_section_ordinal_offset (symbol_table^.item [j].ftn_array_section_ordinal,
                              symbol_table^.item [j].ftn_array_offset,
                              separated_components^ [i].section_definitions, separated_components^ [i].
                              header^.name, status);
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;

                        symbol_table^.item [j].ftn_array_offset := relocated_section_offset (
                              separated_components^ [i], symbol_table^.item [j].ftn_array_section_ordinal,
                              symbol_table^.item [j].ftn_array_offset);
                        relocated_section_ordinal (separated_components^ [i],
                              symbol_table^.item [j].ftn_array_section_ordinal,
                              symbol_table^.item [j].ftn_array_section_ordinal);
                      IFEND;


                      check_section_ordinal_offset (symbol_table^.item [j].dimension_info_section_ordinal,
                            symbol_table^.item [j].dimension_info_offset,
                            separated_components^ [i].section_definitions,
                            separated_components^ [i].header^.name, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                      symbol_table^.item [j].dimension_info_offset :=
                            relocated_section_offset (separated_components^ [i],
                            symbol_table^.item [j].dimension_info_section_ordinal,
                            symbol_table^.item [j].dimension_info_offset);
                      relocated_section_ordinal (separated_components^ [i],
                            symbol_table^.item [j].dimension_info_section_ordinal,
                            symbol_table^.item [j].dimension_info_section_ordinal);

                    = llc$namelist_group_kind =
                      check_section_ordinal_offset (symbol_table^.item [j].namelist_info_section_ordinal,
                            symbol_table^.item [j].namelist_info_offset,
                            separated_components^ [i].section_definitions,
                            separated_components^ [i].header^.name, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                      symbol_table^.item [j].namelist_info_offset :=
                            relocated_section_offset (separated_components^ [i],
                            symbol_table^.item [j].namelist_info_section_ordinal,
                            symbol_table^.item [j].namelist_info_offset);
                      relocated_section_ordinal (separated_components^ [i],
                            symbol_table^.item [j].namelist_info_section_ordinal,
                            symbol_table^.item [j].namelist_info_section_ordinal);

                    = llc$label_kind =
                      check_section_ordinal_offset (symbol_table^.item [j].label_section_ordinal,
                            symbol_table^.item [j].label_offset, separated_components^ [i].
                            section_definitions, separated_components^ [i].header^.name, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                      symbol_table^.item [j].label_offset := relocated_section_offset
                            (separated_components^ [i], symbol_table^.item [j].label_section_ordinal,
                            symbol_table^.item [j].label_offset);
                      relocated_section_ordinal (separated_components^ [i],
                            symbol_table^.item [j].label_section_ordinal,
                            symbol_table^.item [j].label_section_ordinal);

                    = llc$constant_kind =
                      IF symbol_table^.item [j].constant_kind = llc$long_constant THEN
                        check_section_ordinal_offset (symbol_table^.item [j].constant_section_ordinal,
                              symbol_table^.item [j].constant_offset, separated_components^ [i].
                              section_definitions, separated_components^ [i].header^.name, status);
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;

                        symbol_table^.item [j].constant_offset := relocated_section_offset (
                              separated_components^ [i], symbol_table^.item [j].constant_section_ordinal,
                              symbol_table^.item [j].constant_offset);
                        relocated_section_ordinal (separated_components^ [i],
                              symbol_table^.item [j].constant_section_ordinal,
                              symbol_table^.item [j].constant_section_ordinal);
                      IFEND;

                    = llc$pascal_with_kind =
                      check_section_ordinal_offset (symbol_table^.item [j].with_section_ordinal,
                            symbol_table^.item [j].with_offset, separated_components^ [i].section_definitions,
                            separated_components^ [i].header^.name, status);
                      IF NOT status.normal THEN
                        RETURN;
                      IFEND;

                      symbol_table^.item [j].with_offset := relocated_section_offset
                            (separated_components^ [i], symbol_table^.item [j].with_section_ordinal,
                            symbol_table^.item [j].with_offset);

                      relocated_section_ordinal (separated_components^ [i],
                            symbol_table^.item [j].with_section_ordinal,
                            symbol_table^.item [j].with_section_ordinal);

                    = llc$var_kind =
                      IF symbol_table^.item [j].var_base = llc$static_base THEN
                        check_section_ordinal_offset (symbol_table^.item [j].var_section_ordinal,
                              symbol_table^.item [j].var_offset, separated_components^ [i].
                              section_definitions, separated_components^ [i].header^.name, status);
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;

                        symbol_table^.item [j].var_offset := relocated_section_offset
                              (separated_components^ [i], symbol_table^.item [j].var_section_ordinal,
                              symbol_table^.item [j].var_offset);
                        relocated_section_ordinal (separated_components^ [i],
                              symbol_table^.item [j].var_section_ordinal,
                              symbol_table^.item [j].var_section_ordinal);
                      IFEND;

                    ELSE
                    CASEND;

                    IF NOT status.normal THEN
                      ocp$generate_message (status);
                      osp$set_status_abnormal (oc, oce$e_bad_symbol_table,
                            separated_components^ [i].header^.name, status);
                      osp$append_status_integer (osc$status_parameter_delimiter, j, 10, FALSE, status);
                      RETURN;
                    IFEND;
                  FOREND;


                PROCEND relocate_debug_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := '                RELOCATE_LINE_TABLE', EJECT ??

                PROCEDURE relocate_line_table
                  (    line_address_table: ^llt$line_address_table);


                  VAR
                    j: 1 .. llc$max_line_adr_table_size;


                  FOR j := 1 TO UPPERBOUND (line_address_table^.item) DO
                    check_section_ordinal_offset (line_address_table^.item [j].section_ordinal,
                          line_address_table^.item [j].offset, separated_components^ [i].section_definitions,
                          separated_components^ [i].header^.name, status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;

                    line_address_table^.item [j].offset := relocated_section_offset
                          (separated_components^ [i], line_address_table^.item [j].section_ordinal,
                          line_address_table^.item [j].offset);
                    relocated_section_ordinal (separated_components^ [i],
                          line_address_table^.item [j].section_ordinal,
                          line_address_table^.item [j].section_ordinal);
                  FOREND;


                PROCEND relocate_line_table;
?? OLDTITLE ??
?? EJECT ??


                VAR
                  i: integer,
                  last_misc: ^oct$object_record_list;


                last_misc := ^miscellaneous_record_list;

                FOR i := 1 TO UPPERBOUND (separated_components^) DO
                  last_misc^.link := separated_components^ [i].miscellaneous_record_list.link;

                  WHILE last_misc^.link <> NIL DO
                    last_misc := last_misc^.link;

                    CASE last_misc^.kind OF
                    = llc$symbol_table =
                      relocate_debug_symbol_table (^last_misc^.symbol_table^.text, status);
                    = llc$line_table =
                      relocate_line_table (last_misc^.line_address_table);
                    = llc$cybil_symbol_table_fragment =
                      relocate_cybil_symbol_table (^last_misc^.debug_table_fragment^.text, status);
                    = llc$obsolete_line_table =
                      relocate_obsolete_line_table (last_misc^.obsolete_line_address_table);
                    ELSE
                    CASEND;

                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;
                  WHILEND;
                FOREND;


              PROCEND collect_miscellaneous_records;
?? OLDTITLE ??
?? NEWTITLE := '              QUICK_BIND_MODULE' ??
?? EJECT ??

              PROCEDURE quick_bind_module
                (    components: ^oct$separated_components;
                 VAR temporary_module_header: ^oct$temporary_module_header;
                 VAR status: ost$status);


?? NEWTITLE := '                COMBINE_EXT_RECORDS' ??
?? EJECT ??

                PROCEDURE combine_ext_records
                  (VAR old_external_linkage_list: ^oct$external_linkage_list;
                   VAR status: ost$status);


                  VAR
                    new_external_linkage_list: ^oct$external_linkage_list,
                    new_external_linkage: ^^oct$external_linkage_list,
                    old_external_linkage: ^^oct$external_linkage_list,
                    number_of_items: integer,
                    number: integer,
                    items: ^array [1 .. * ] of llt$external_linkage_item,
                    new_actual_parameter: ^oct$actual_parameter_list;



                  new_external_linkage_list := NIL;
                  new_external_linkage := ^new_external_linkage_list;

                  WHILE old_external_linkage_list <> NIL DO
                    number := UPPERBOUND (old_external_linkage_list^.external_linkage.item);
                    NEXT new_external_linkage^: [1 .. number] IN ocv$olg_scratch_seq;
                    IF new_external_linkage^ = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    new_external_linkage^^.external_linkage := old_external_linkage_list^.external_linkage;
                    new_external_linkage^^.actual_parameter_list :=
                          old_external_linkage_list^.actual_parameter_list;

                    new_actual_parameter := ^new_external_linkage^^.actual_parameter_list;
                    old_external_linkage := ^old_external_linkage_list;
                    old_external_linkage_list := old_external_linkage_list^.link;

                    number_of_items := number;

                    WHILE old_external_linkage^ <> NIL DO
                      IF (old_external_linkage^^.external_linkage.name =
                            new_external_linkage^^.external_linkage.name) THEN

                        number := UPPERBOUND (old_external_linkage^^.external_linkage.item);

                        IF ((number_of_items + number) <= llc$max_ext_items) THEN
                          NEXT items: [1 .. number] IN ocv$olg_scratch_seq;
                          IF items = NIL THEN
                            osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                            RETURN;
                          IFEND;

                          number_of_items := number_of_items + number;
                          items^ := old_external_linkage^^.external_linkage.item;

                          IF old_external_linkage^^.actual_parameter_list.nnext <> NIL THEN
                            WHILE new_actual_parameter^.nnext <> NIL DO
                              new_actual_parameter := new_actual_parameter^.nnext;
                            WHILEND;
                            new_actual_parameter^.nnext := old_external_linkage^^.actual_parameter_list.nnext;
                          IFEND;

                          old_external_linkage^ := old_external_linkage^^.link;
                        ELSE
                          old_external_linkage := ^old_external_linkage^^.link;
                        IFEND;
                      ELSE
                        old_external_linkage := ^old_external_linkage^^.link;
                      IFEND;
                    WHILEND;

                    RESET ocv$olg_scratch_seq TO new_external_linkage^;
                    NEXT new_external_linkage^: [1 .. number_of_items] IN ocv$olg_scratch_seq;

                    new_external_linkage := ^new_external_linkage^^.link;

                  WHILEND;

                  old_external_linkage_list := new_external_linkage_list;
                  new_external_linkage^ := NIL;

                PROCEND combine_ext_records;
?? OLDTITLE ??
?? NEWTITLE := '                COMBINE_ADR_RECORDS' ??
?? EJECT ??

                PROCEDURE combine_adr_records
                  (VAR old_address_formulation_list: ^oct$address_formulation_list;
                   VAR status: ost$status);


                  VAR
                    new_address_formulation_list: ^oct$address_formulation_list,
                    new_address_formulation: ^^oct$address_formulation_list,
                    old_address_formulation: ^^oct$address_formulation_list,

                    number_of_items: integer,
                    number: integer,
                    items: ^array [1 .. * ] of llt$address_formulation_item;



                  new_address_formulation_list := NIL;
                  new_address_formulation := ^new_address_formulation_list;

                  WHILE old_address_formulation_list <> NIL DO
                    number := UPPERBOUND (old_address_formulation_list^.address_formulation.item);
                    NEXT new_address_formulation^: [1 .. number] IN ocv$olg_scratch_seq;
                    IF new_address_formulation^ = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    new_address_formulation^^.address_formulation :=
                          old_address_formulation_list^.address_formulation;

                    old_address_formulation := ^old_address_formulation_list;
                    old_address_formulation_list := old_address_formulation_list^.link;

                    number_of_items := number;

                    WHILE old_address_formulation^ <> NIL DO
                      IF (old_address_formulation^^.address_formulation.value_section =
                            new_address_formulation^^.address_formulation.value_section) AND
                            (old_address_formulation^^.address_formulation.dest_section =
                            new_address_formulation^^.address_formulation.dest_section) THEN

                        number := UPPERBOUND (old_address_formulation^^.address_formulation.item);

                        IF ((number + number_of_items) <= llc$max_adr_items) THEN
                          NEXT items: [1 .. number] IN ocv$olg_scratch_seq;
                          IF items = NIL THEN
                            osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                            RETURN;
                          IFEND;

                          number_of_items := number_of_items + number;
                          items^ := old_address_formulation^^.address_formulation.item;
                          old_address_formulation^ := old_address_formulation^^.link;
                        ELSE
                          old_address_formulation := ^old_address_formulation^^.link;
                        IFEND;
                      ELSE
                        old_address_formulation := ^old_address_formulation^^.link;
                      IFEND;
                    WHILEND;

                    RESET ocv$olg_scratch_seq TO new_address_formulation^;
                    NEXT new_address_formulation^: [1 .. number_of_items] IN ocv$olg_scratch_seq;

                    new_address_formulation := ^new_address_formulation^^.link;

                  WHILEND;

                  old_address_formulation_list := new_address_formulation_list;
                  new_address_formulation^ := NIL;

                PROCEND combine_adr_records;
?? OLDTITLE ??
?? NEWTITLE := '                COLLECT_RELOCATION_RECORDS' ??
?? EJECT ??

                PROCEDURE collect_relocation_records
                  (VAR relocation: ^oct$relocation_item_list;
                   VAR number_of_rel_items: llt$number_of_info_elements;
                   VAR item: ^oct$relocation_list;
                   VAR status: ost$status);


                  status.normal := TRUE;

                  WHILE relocation <> NIL DO
                    number_of_rel_items := number_of_rel_items + 1;

                    NEXT item^.link IN ocv$olg_scratch_seq;
                    item := item^.link;
                    IF item = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    item^.link := NIL;
                    item^.relocation_item := relocation^.item^;

                    item^.relocation_item.offset := relocated_section_offset
                          (component, item^.relocation_item.section_ordinal, item^.relocation_item.offset);
                    relocated_section_ordinal (component, item^.relocation_item.section_ordinal,
                          item^.relocation_item.section_ordinal);
                    relocated_section_ordinal (component, item^.relocation_item.relocating_section,
                          item^.relocation_item.relocating_section);

                    relocation := relocation^.link;
                  WHILEND;
                PROCEND collect_relocation_records;
?? OLDTITLE, EJECT ??

                VAR
                  component: oct$separated_module_header,

                  entry_definition: ^oct$entry_definition_list,
                  old_entry_definition: ^oct$entry_definition_list,
                  external: ^oct$external_linkage_list,
                  address: ^oct$address_formulation_list,

                  relocation: ^oct$relocation_item_list,
                  i: integer,
                  j: llt$number_of_info_elements,
                  item: ^oct$relocation_list,

                  new_item: ^oct$new_binding_template_list;


                component := components^ [1];


                temporary_module_header^.number_of_entry_definitions := 0;
                entry_definition := ^temporary_module_header^.entry_definition_list;
                old_entry_definition := component.entry_definition_list.link;

                WHILE old_entry_definition <> NIL DO
                  IF old_entry_definition^.changed_name^ <> osc$null_name THEN
                    temporary_module_header^.number_of_entry_definitions :=
                          temporary_module_header^.number_of_entry_definitions + 1;

                    entry_definition^.link := old_entry_definition;
                    entry_definition := entry_definition^.link;

                    entry_definition^.entry_definition.offset := relocated_section_offset
                          (component, entry_definition^.entry_definition.section_ordinal,
                          entry_definition^.entry_definition.offset);
                    relocated_section_ordinal (component, entry_definition^.entry_definition.section_ordinal,
                          entry_definition^.entry_definition.section_ordinal);

                    entry_definition^.entry_definition.name := entry_definition^.changed_name^;
                  IFEND;

                  old_entry_definition := old_entry_definition^.link;
                WHILEND;

                entry_definition^.link := NIL;

                temporary_module_header^.deferred_entry_points := component.deferred_entry_points;
                IF temporary_module_header^.deferred_entry_points <> NIL THEN
                  FOR i := 1 TO UPPERBOUND (temporary_module_header^.deferred_entry_points^) DO
                    relocated_section_ordinal (component, temporary_module_header^.deferred_entry_points^ [i].
                          section_ordinal, temporary_module_header^.deferred_entry_points^ [i].
                          section_ordinal);
                  FOREND;
                IFEND;

                temporary_module_header^.external_linkage_list := component.external_linkage_list;

                external := temporary_module_header^.external_linkage_list;

                WHILE external <> NIL DO
                  FOR i := 1 TO UPPERBOUND (external^.external_linkage.item) DO
                    external^.external_linkage.item [i].offset :=
                          relocated_section_offset (component, external^.external_linkage.item [i].
                          section_ordinal, external^.external_linkage.item [i].offset);
                    relocated_section_ordinal (component, external^.external_linkage.item [i].section_ordinal,
                          external^.external_linkage.item [i].section_ordinal);
                  FOREND;

                  external := external^.link;
                WHILEND;

                combine_ext_records (temporary_module_header^.external_linkage_list, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                temporary_module_header^.address_formulation_list := component.address_formulation_list;

                address := temporary_module_header^.address_formulation_list;

                WHILE address <> NIL DO
                  FOR i := 1 TO UPPERBOUND (address^.address_formulation.item) DO
                    address^.address_formulation.item [i].value_offset :=
                          relocated_section_offset (component, address^.address_formulation.value_section,
                          address^.address_formulation.item [i].value_offset);
                    address^.address_formulation.item [i].dest_offset :=
                          relocated_section_offset (component, address^.address_formulation.dest_section,
                          address^.address_formulation.item [i].dest_offset);
                  FOREND;

                  relocated_section_ordinal (component, address^.address_formulation.value_section,
                        address^.address_formulation.value_section);
                  relocated_section_ordinal (component, address^.address_formulation.dest_section,
                        address^.address_formulation.dest_section);

                  address := address^.link;
                WHILEND;

                combine_adr_records (temporary_module_header^.address_formulation_list, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                collect_miscellaneous_records (components, temporary_module_header^.miscellaneous_record_list,
                      status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                temporary_module_header^.number_of_rel_items := 0;
                item := ^temporary_module_header^.relocation_list;

                collect_relocation_records (component.relocation_list.byte.link,
                      temporary_module_header^.number_of_rel_items, item, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                collect_relocation_records (component.relocation_list.two_byte.link,
                      temporary_module_header^.number_of_rel_items, item, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                collect_relocation_records (component.relocation_list.four_byte.link,
                      temporary_module_header^.number_of_rel_items, item, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                collect_relocation_records (component.relocation_list.eight_byte.link,
                      temporary_module_header^.number_of_rel_items, item, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                temporary_module_header^.number_of_template_items := component.number_of_template_items;

                new_item := ^temporary_module_header^.binding_template_list;
                j := 0;
                FOR i := 1 TO temporary_module_header^.number_of_template_items DO
                  WHILE component.binding_template_list^ [j].binding_template = NIL DO
                    j := j + 1;
                  WHILEND;

                  NEXT new_item^.link IN ocv$olg_scratch_seq;
                  new_item := new_item^.link;
                  IF new_item = NIL THEN
                    osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                    RETURN;
                  IFEND;

                  new_item^.link := NIL;
                  new_item^.binding_template := component.binding_template_list^ [j].binding_template^;

                  IF new_item^.binding_template.kind = llc$current_module THEN
                    new_item^.binding_template.offset := new_item^.binding_template.offset +
                          component.section_definitions^ [new_item^.binding_template.section_ordinal]^.
                          new_section_offset;
                    new_item^.binding_template.section_ordinal := component.
                          section_definitions^ [new_item^.binding_template.section_ordinal]^.new^.
                          section_definition.section_ordinal;

                  IFEND;
                  j := j + 1;
                FOREND;

              PROCEND quick_bind_module;
?? OLDTITLE ??
?? NEWTITLE := '              BIND_MODULE', EJECT ??

              PROCEDURE bind_module
                (    separated_components: ^oct$separated_components;
                 VAR temporary_module_header: ^oct$temporary_module_header;
                 VAR status: ost$status);


?? NEWTITLE := '                GET_OLD_BINDING_TEMPLATE_ITEM' ??
?? EJECT ??

                PROCEDURE [INLINE] get_old_binding_template_item
                  (    component: oct$separated_module_header;
                       offset: llt$section_offset;
                   VAR old_binding_template_item: ^oct$old_binding_template_item;
                   VAR status: ost$status);


                  VAR
                    bti: llt$binding_template;


                  old_binding_template_item := ^component.binding_template_list^ [offset DIV 8];

                  IF old_binding_template_item^.binding_template <> NIL THEN
                    bti := old_binding_template_item^.binding_template^;
                    IF bti.binding_offset = offset THEN
                      RETURN;

                    ELSEIF (bti.binding_offset - 2) = offset THEN
                      CASE bti.kind OF
                      = llc$current_module =
                        IF bti.internal_address = llc$address THEN
                          RETURN;
                        IFEND;
                      = llc$external_reference =
                        IF (bti.address = llc$address) OR (bti.address = llc$address_addition) OR
                              (bti.address = llc$address_subtraction) THEN
                          RETURN;
                        IFEND;
                      CASEND;

                    IFEND;
                  IFEND;

                  osp$set_status_abnormal (oc, oce$e_bad_binding_sec_offset, component.header^.name, status);

                PROCEND get_old_binding_template_item;
?? OLDTITLE ??
?? NEWTITLE := '                ADD_TO_ENTRY_POINT_ADDRESS_TREE', EJECT ??

                PROCEDURE build_entry_point_sorted_list
                  (    number_of_entry_points: llt$entry_point_index;
                       first_entry_point_address_item: ^oct$entry_point_address_list;
                   VAR entry_point_sorted_list: oct$entry_point_sorted_list;
                   VAR status: ost$status);

                  VAR
                    entry_point_address_item: ^oct$entry_point_address_list,
                    found: boolean,
                    hi: llt$entry_point_index,
                    i: llt$entry_point_index,
                    insert: llt$entry_point_index,
                    k: llt$entry_point_index,
                    lo: llt$entry_point_index,
                    mid: llt$entry_point_index,
                    temp: integer,
                    sorted_list_size: llt$entry_point_index;


                  entry_point_address_item := first_entry_point_address_item;
                  sorted_list_size := 0;

                  NEXT entry_point_sorted_list: [1 .. number_of_entry_points] IN ocv$olg_scratch_seq;
                  IF entry_point_sorted_list = NIL THEN
                    osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                    RETURN;
                  IFEND;

                  FOR k := 1 TO number_of_entry_points DO
                    hi := sorted_list_size;
                    found := FALSE;
                    lo := 1;

                    WHILE (lo <= hi) AND NOT found DO
                      temp := lo + hi;
                      mid := temp DIV 2;
                      IF entry_point_address_item^.name = entry_point_sorted_list^ [mid]^.name THEN
                        found := TRUE;
                      ELSEIF entry_point_address_item^.name < entry_point_sorted_list^ [mid]^.name THEN
                        hi := mid - 1;
                      ELSE
                        lo := mid + 1;
                      IFEND;
                    WHILEND;

                    IF found THEN
                      insert := mid;
                    ELSE
                      insert := lo;
                    IFEND;

                    sorted_list_size := sorted_list_size + 1;

                    FOR i := (sorted_list_size - 1) DOWNTO insert DO
                      entry_point_sorted_list^ [i + 1] := entry_point_sorted_list^ [i];
                    FOREND;

                    entry_point_sorted_list^ [insert] := entry_point_address_item;

                    entry_point_address_item := entry_point_address_item^.link;
                  FOREND;

                PROCEND build_entry_point_sorted_list;
?? OLDTITLE ??
?? NEWTITLE := '                SEARCH_ENTRY_POINT_ADDRESS_LIST' ??
?? EJECT ??

                PROCEDURE [INLINE] search_entry_point_sorted_list
                  (    name: pmt$program_name;
                   VAR name_found: boolean;
                   VAR entry_point_address_item: ^oct$entry_point_address_list);

                  VAR
                    temp: integer,
                    hi: llt$entry_point_index,
                    lo: llt$entry_point_index,
                    mid: llt$entry_point_index;

                  hi := UPPERBOUND (entry_point_sorted_list^);
                  lo := 1;
                  name_found := FALSE;

                  WHILE (lo <= hi) AND NOT name_found DO
                    temp := lo + hi;
                    mid := temp DIV 2;
                    IF name = entry_point_sorted_list^ [mid]^.name THEN
                      name_found := TRUE;
                      entry_point_address_item := entry_point_sorted_list^ [mid];
                    ELSEIF name < entry_point_sorted_list^ [mid]^.name THEN
                      hi := mid - 1;
                    ELSE
                      lo := mid + 1;
                    IFEND;
                  WHILEND;

                PROCEND search_entry_point_sorted_list;
?? OLDTITLE ??
?? NEWTITLE := '                BUILD_NEW_ADR_RECORD' ??
?? EJECT ??

                PROCEDURE build_new_adr_record
                  (    destination_section_ordinal: llt$section_ordinal;
                       destination_offset: llt$section_offset;
                       value_section_ordinal: llt$section_ordinal;
                       value_offset: ost$segment_offset;
                       kind: llt$address_kind;
                       offset_operand: llt$section_address_range;
                   VAR status: ost$status);



                  NEXT ocv$last_new_adr_formulation^.link IN ocv$olg_scratch_seq;
                  ocv$last_new_adr_formulation := ocv$last_new_adr_formulation^.link;
                  IF ocv$last_new_adr_formulation = NIL THEN
                    osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                    RETURN;
                  IFEND;

                  ocv$last_new_adr_formulation^.link := NIL;
                  ocv$last_new_adr_formulation^.value_section := value_section_ordinal;
                  ocv$last_new_adr_formulation^.dest_section := destination_section_ordinal;
                  ocv$last_new_adr_formulation^.item.dest_offset := destination_offset;

                  IF kind = llc$address_addition THEN
                    ocv$last_new_adr_formulation^.item.value_offset := value_offset + offset_operand;
                    ocv$last_new_adr_formulation^.item.kind := llc$address;
                  ELSEIF kind = llc$address_subtraction THEN
                    ocv$last_new_adr_formulation^.item.value_offset := value_offset - offset_operand;
                    ocv$last_new_adr_formulation^.item.kind := llc$address;
                  ELSE
                    ocv$last_new_adr_formulation^.item.value_offset := value_offset;
                    ocv$last_new_adr_formulation^.item.kind := kind;
                  IFEND;



                PROCEND build_new_adr_record;
?? OLDTITLE ??
?? NEWTITLE := '                BUILD_NEW_EXT_RECORD' ??
?? EJECT ??

                PROCEDURE build_new_ext_record
                  (    external_linkage: ^oct$external_linkage_list;
                       value_section_ordinal: llt$section_ordinal;
                       value_offset: llt$section_offset;
                       address_kind: llt$address_kind;
                       offset_operand: llt$section_address_range;
                   VAR status: ost$status);



                  NEXT ocv$last_new_external^.link IN ocv$olg_scratch_seq;
                  ocv$last_new_external := ocv$last_new_external^.link;
                  IF ocv$last_new_external = NIL THEN
                    osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                    RETURN;
                  IFEND;

                  ocv$last_new_external^.link := NIL;
                  ocv$last_new_external^.name := external_linkage^.external_linkage.name;
                  ocv$last_new_external^.language := external_linkage^.external_linkage.language;
                  ocv$last_new_external^.declaration_matching_required :=
                        external_linkage^.external_linkage.declaration_matching_required;
                  ocv$last_new_external^.declaration_matching :=
                        external_linkage^.external_linkage.declaration_matching;
                  ocv$last_new_external^.item.section_ordinal := value_section_ordinal;
                  ocv$last_new_external^.item.offset := value_offset;
                  ocv$last_new_external^.item.kind := address_kind;
                  ocv$last_new_external^.item.offset_operand := offset_operand;
                  ocv$last_new_external^.actual_parameter_list := NIL;

                PROCEND build_new_ext_record;
?? OLDTITLE ??
?? NEWTITLE := '                  COMBINE_EXT_RECORDS' ??
?? EJECT ??

                PROCEDURE combine_ext_records
                  (VAR old_external_linkage_items: ^oct$external_linkage_item;
                   VAR new_external_linkage_list: ^oct$external_linkage_list;
                   VAR status: ost$status);


                  VAR
                    old_external_item: ^^oct$external_linkage_item,
                    last_new_external_linkage: ^^oct$external_linkage_list,
                    actual_parameter: ^oct$actual_parameter_list,
                    number_of_items: integer,
                    item: ^llt$external_linkage_item;


                  new_external_linkage_list := NIL;
                  last_new_external_linkage := ^new_external_linkage_list;

                  WHILE old_external_linkage_items <> NIL DO
                    NEXT last_new_external_linkage^: [1 .. 1] IN segment_3;
                    IF last_new_external_linkage^ = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    last_new_external_linkage^^.external_linkage.name := old_external_linkage_items^.name;
                    last_new_external_linkage^^.external_linkage.language :=
                          old_external_linkage_items^.language;
                    last_new_external_linkage^^.external_linkage.declaration_matching_required :=
                          old_external_linkage_items^.declaration_matching_required;
                    last_new_external_linkage^^.external_linkage.declaration_matching :=
                          old_external_linkage_items^.declaration_matching;
                    last_new_external_linkage^^.external_linkage.item [1] := old_external_linkage_items^.item;
                    last_new_external_linkage^^.actual_parameter_list.nnext :=
                          old_external_linkage_items^.actual_parameter_list;
                    old_external_linkage_items := old_external_linkage_items^.link;
                    old_external_item := ^old_external_linkage_items;

                    number_of_items := 1;

                    WHILE old_external_item^ <> NIL DO
                      IF (old_external_item^^.name = last_new_external_linkage^^.external_linkage.name) AND
                            ((number_of_items + 1) <= llc$max_ext_items) THEN
                        NEXT item IN segment_3;
                        IF item = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                          RETURN;
                        IFEND;

                        IF old_external_item^^.actual_parameter_list <> NIL THEN
                          actual_parameter := old_external_item^^.actual_parameter_list;
                          WHILE actual_parameter^.nnext <> NIL DO
                            actual_parameter := actual_parameter^.nnext;
                          WHILEND;

                          actual_parameter^.nnext := last_new_external_linkage^^.actual_parameter_list.nnext;

                          last_new_external_linkage^^.actual_parameter_list.nnext :=
                                old_external_item^^.actual_parameter_list;
                        IFEND;

                        number_of_items := number_of_items + 1;
                        item^ := old_external_item^^.item;
                        old_external_item^ := old_external_item^^.link;
                      ELSE
                        old_external_item := ^old_external_item^^.link;
                      IFEND;
                    WHILEND;

                    IF number_of_items > 1 THEN
                      RESET segment_3 TO last_new_external_linkage^;
                      NEXT last_new_external_linkage^: [1 .. number_of_items] IN segment_3;
                    IFEND;

                    last_new_external_linkage := ^last_new_external_linkage^^.link;

                  WHILEND;

                  last_new_external_linkage^ := NIL;


                PROCEND combine_ext_records;
?? OLDTITLE ??
?? NEWTITLE := '                COMBINE_ADR_RECORDS' ??
?? EJECT ??

                PROCEDURE combine_adr_records
                  (VAR old_address_formulation_items: ^oct$address_formulation_item;
                   VAR new_address_formulation_list: ^oct$address_formulation_list;
                   VAR status: ost$status);


                  VAR
                    old_address_formulation_item: ^^oct$address_formulation_item,
                    last_new_address_formulation: ^^oct$address_formulation_list,

                    number_of_items: integer,
                    item: ^llt$address_formulation_item;



                  new_address_formulation_list := NIL;
                  last_new_address_formulation := ^new_address_formulation_list;

                  WHILE old_address_formulation_items <> NIL DO
                    NEXT last_new_address_formulation^: [1 .. 1] IN segment_3;
                    IF last_new_address_formulation^ = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    last_new_address_formulation^^.address_formulation.dest_section :=
                          old_address_formulation_items^.dest_section;
                    last_new_address_formulation^^.address_formulation.value_section :=
                          old_address_formulation_items^.value_section;
                    last_new_address_formulation^^.address_formulation.item [1] :=
                          old_address_formulation_items^.item;

                    old_address_formulation_items := old_address_formulation_items^.link;
                    old_address_formulation_item := ^old_address_formulation_items;

                    number_of_items := 1;

                    WHILE old_address_formulation_item^ <> NIL DO
                      IF (old_address_formulation_item^^.value_section =
                            last_new_address_formulation^^.address_formulation.value_section) AND
                            (old_address_formulation_item^^.dest_section =
                            last_new_address_formulation^^.address_formulation.dest_section) AND
                            ((number_of_items + 1) <= llc$max_adr_items) THEN

                        NEXT item IN segment_3;
                        IF item = NIL THEN
                          osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                          RETURN;
                        IFEND;

                        number_of_items := number_of_items + 1;
                        item^ := old_address_formulation_item^^.item;
                        old_address_formulation_item^ := old_address_formulation_item^^.link;
                      ELSE
                        old_address_formulation_item := ^old_address_formulation_item^^.link;
                      IFEND;
                    WHILEND;

                    IF number_of_items > 1 THEN
                      RESET segment_3 TO last_new_address_formulation^;
                      NEXT last_new_address_formulation^: [1 .. number_of_items] IN segment_3;
                    IFEND;

                    last_new_address_formulation := ^last_new_address_formulation^^.link;

                  WHILEND;

                  last_new_address_formulation^ := NIL;


                PROCEND combine_adr_records;
?? OLDTITLE ??
?? NEWTITLE := '                GENERATE_BINDING_TEMPLATE_ITEM' ??
?? EJECT ??

                PROCEDURE generate_binding_template_item
                  (    component: oct$separated_module_header;
                       old_binding_template_offset: llt$section_offset;
                   VAR new_binding_section_offset: ost$segment_offset;
                   VAR status: ost$status);

?? NEWTITLE := '                  SEARCH_BINDING_TEMP_FOR_ADDRESS' ??
?? EJECT ??

                  PROCEDURE search_binding_temp_for_address
                    (    section_ordinal: llt$section_ordinal;
                         offset: ost$segment_offset;
                         internal_address: llt$internal_address_kind;
                     VAR binding_template_found: boolean;
                     VAR new_binding_section_offset: ost$segment_offset);



                    VAR
                      binding_template: ^oct$new_binding_template_list;



                    binding_template := temporary_module_header^.binding_template_list.link;

                    WHILE binding_template <> NIL DO
                      IF (binding_template^.binding_template.section_ordinal = section_ordinal) AND
                            (binding_template^.binding_template.offset = offset) AND
                            (binding_template^.binding_template.internal_address = internal_address) THEN

                        new_binding_section_offset := binding_template^.binding_template.binding_offset;
                        binding_template_found := TRUE;
                        RETURN;
                      IFEND;

                      binding_template := binding_template^.link;
                    WHILEND;

                    binding_template_found := FALSE;

                  PROCEND search_binding_temp_for_address;
?? OLDTITLE ??
?? NEWTITLE := '                  SEARCH_BINDING_TEMP_FOR_NAME' ??
?? EJECT ??

                  PROCEDURE search_binding_temp_for_name
                    (    name: pmt$program_name;
                         address: llt$address_kind;
                     VAR binding_template_found: boolean;
                     VAR new_binding_section_offset: ost$segment_offset);



                    VAR
                      binding_template: ^oct$new_binding_template_list;



                    binding_template := temporary_module_header^.binding_template_list.link;

                    WHILE binding_template <> NIL DO
                      IF (binding_template^.binding_template.name = name) AND
                            (binding_template^.binding_template.address = address) THEN
                        new_binding_section_offset := binding_template^.binding_template.binding_offset;
                        binding_template_found := TRUE;
                        RETURN;
                      IFEND;

                      binding_template := binding_template^.link;
                    WHILEND;

                    binding_template_found := FALSE;


                  PROCEND search_binding_temp_for_name;
?? OLDTITLE ??
?? NEWTITLE := '                  COMPUTE_NEW_BINDING_SEC_OFFSET' ??
?? EJECT ??

                  PROCEDURE [INLINE] compute_new_binding_sec_offset
                    (    address_kind: llt$address_kind;
                     VAR new_binding_section_offset: ost$segment_offset;
                     VAR status: ost$status);



                    CASE address_kind OF

                    = llc$address =
                      new_binding_section_offset := ocv$next_avail_binding_offset + 2;
                      ocv$next_avail_binding_offset := ocv$next_avail_binding_offset + 8;

                    = llc$internal_proc =
                      new_binding_section_offset := ocv$next_avail_binding_offset;
                      ocv$next_avail_binding_offset := ocv$next_avail_binding_offset + 8;

                    = llc$external_proc =
                      new_binding_section_offset := ocv$next_avail_binding_offset;
                      ocv$next_avail_binding_offset := ocv$next_avail_binding_offset + 16;

                    = llc$address_addition =
                      new_binding_section_offset := ocv$next_avail_binding_offset + 2;
                      ocv$next_avail_binding_offset := ocv$next_avail_binding_offset + 8;

                    = llc$address_subtraction =
                      new_binding_section_offset := ocv$next_avail_binding_offset + 2;
                      ocv$next_avail_binding_offset := ocv$next_avail_binding_offset + 8;

                    ELSE
                      osp$set_status_abnormal (oc, oce$e_invalid_address_kind, '', status);
                      RETURN;
                    CASEND;

                  PROCEND compute_new_binding_sec_offset;
?? OLDTITLE ??
?? NEWTITLE := '                  BUILD_CURRENT_TEMPLATE_ENTRY' ??
?? EJECT ??

                  PROCEDURE build_current_template_entry
                    (    address_kind: llt$address_kind;
                     VAR new_binding_section_offset: ost$segment_offset;
                     VAR status: ost$status);




                    NEXT ocv$last_new_binding_template^.link IN segment_1;
                    ocv$last_new_binding_template := ocv$last_new_binding_template^.link;
                    IF ocv$last_new_binding_template = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    ocv$number_of_new_temp_items := ocv$number_of_new_temp_items + 1;

                    compute_new_binding_sec_offset (address_kind, new_binding_section_offset, status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;

                    ocv$last_new_binding_template^.link := NIL;
                    ocv$last_new_binding_template^.binding_template.binding_offset :=
                          new_binding_section_offset;
                    ocv$last_new_binding_template^.binding_template.kind := llc$current_module;
                    ocv$last_new_binding_template^.binding_template.internal_address := address_kind;
                    ocv$last_new_binding_template^.binding_template.section_ordinal := new_section_ordinal;
                    ocv$last_new_binding_template^.binding_template.offset := new_section_offset;

                  PROCEND build_current_template_entry;
?? OLDTITLE ??
?? NEWTITLE := '                  BUILD_EXTERNAL_TEMPLATE_ENTRY' ??
?? EJECT ??

                  PROCEDURE build_external_template_entry
                    (    old_binding_template_item: ^oct$old_binding_template_item;
                     VAR new_binding_section_offset: ost$segment_offset;
                     VAR status: ost$status);



                    NEXT ocv$last_new_binding_template^.link IN segment_1;
                    ocv$last_new_binding_template := ocv$last_new_binding_template^.link;
                    IF ocv$last_new_binding_template = NIL THEN
                      osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                      RETURN;
                    IFEND;

                    ocv$number_of_new_temp_items := ocv$number_of_new_temp_items + 1;

                    compute_new_binding_sec_offset (old_binding_template_item^.binding_template^.address,
                          new_binding_section_offset, status);
                    IF NOT status.normal THEN
                      RETURN;
                    IFEND;

                    ocv$last_new_binding_template^.link := NIL;
                    ocv$last_new_binding_template^.binding_template.binding_offset :=
                          new_binding_section_offset;
                    ocv$last_new_binding_template^.binding_template.kind := llc$external_reference;
                    ocv$last_new_binding_template^.binding_template.address :=
                          old_binding_template_item^.binding_template^.address;
                    ocv$last_new_binding_template^.binding_template.name :=
                          old_binding_template_item^.binding_template^.name;

                  PROCEND build_external_template_entry;
?? OLDTITLE ??
?? NEWTITLE := '                  FIND_OFFSET_OPERAND' ??
?? EJECT ??

{ The purpose of this procedure is to find an external linkage record with the correct
{ name and old_binding_template_offset and return the address_kind and offset_operand from it.
{ Note that there may be more than one external linkage record with the same name.

                  PROCEDURE find_offset_operand
                    (    name: pmt$program_name;
                         old_binding_template_offset: llt$section_offset;
                     VAR external_linkage: ^oct$external_linkage_list;
                     VAR address_kind: llt$address_kind;
                     VAR offset_operand: llt$section_address_range;
                     VAR status: ost$status);

                    VAR
                      binding_section_found: boolean,
                      binding_section_ordinal: llt$section_ordinal,
                      i: integer;

                    status.normal := TRUE;
                    binding_section_found := FALSE;
                    i := 0;

                  /find_binding_section/
                    WHILE (NOT binding_section_found) AND (i <= UPPERBOUND (component.section_definitions^))
                          DO
                      IF (component.section_definitions^ [i] = NIL) THEN
                        i := i + 1;
                        CYCLE /find_binding_section/;
                      IFEND;
                      IF component.section_definitions^ [i]^.section_definition.kind =
                            llc$binding_section THEN
                        binding_section_ordinal := component.section_definitions^ [i]^.section_definition.
                              section_ordinal;
                        binding_section_found := TRUE;
                      ELSE
                        i := i + 1;
                      IFEND;
                    WHILEND /find_binding_section/;

                    IF NOT binding_section_found THEN
                      osp$set_status_abnormal (oc, oce$e_bnd_sec_ext_not_found, component.header^.name,
                            status);
                      RETURN;
                    IFEND;

                    external_linkage := component.external_linkage_list;
                    WHILE (external_linkage <> NIL) DO
                      IF external_linkage^.external_linkage.name = name THEN
                        i := 1;
                        WHILE (i <= UPPERBOUND (external_linkage^.external_linkage.item)) DO
                          IF external_linkage^.external_linkage.item [i].section_ordinal =
                                binding_section_ordinal THEN
                            IF old_binding_template_offset = external_linkage^.external_linkage.item [i].
                                  offset THEN
                              address_kind := external_linkage^.external_linkage.item [i].kind;
                              offset_operand := external_linkage^.external_linkage.item [i].offset_operand;
                              RETURN;
                            ELSE
                              i := i + 1;
                            IFEND;
                          IFEND;
                        WHILEND;
                      IFEND;
                      external_linkage := external_linkage^.link;
                    WHILEND;

{ If we get here, then we searched the whole external_linkage list and didn't find the right name.

                    osp$set_status_abnormal (oc, oce$e_bnd_sec_ext_not_found, component.header^.name, status);

                  PROCEND find_offset_operand;
?? OLDTITLE ??
?? EJECT ??


                  VAR
                    address_kind: llt$address_kind,
                    offset_operand: llt$section_address_range,
                    external_found: boolean,
                    new_template_item_found: boolean,

                    entry_point_address_item: ^oct$entry_point_address_list,
                    external_linkage: ^oct$external_linkage_list,

                    new_section_ordinal: llt$section_ordinal,
                    new_section_offset: ost$segment_offset,

                    new_address_kind: llt$address_kind,
                    new_binding_template_item: ^oct$new_binding_template_list,
                    old_binding_template_item: ^oct$old_binding_template_item;



{ This routine is recursive in that it may call itself if the binding template
{item being
{ generated references the binding section. This may occur a number of times.
{Recursion is
{ necessary to accomodate chains of unreferenced pointers linked through the
{ binding section. A typical example of this is a statically initialized
{pointer to
{ procedure. It is highly unlikely that this will ever occur, however, it must
{ be considered.

                  get_old_binding_template_item (component, old_binding_template_offset,
                        old_binding_template_item, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;

                  IF old_binding_template_item^.referenced_in_new_binding_sect THEN
                    new_binding_section_offset := old_binding_template_item^.new_binding_section_offset;
                    new_section_ordinal := ocv$new_binding_section_ordinal;
                    RETURN;

                  ELSE
                    CASE old_binding_template_item^.binding_template^.kind OF

                    = llc$current_module =

                      IF component.section_definitions^ [old_binding_template_item^.binding_template^.
                            section_ordinal]^.section_definition.kind = llc$binding_section THEN

{ Pointer stored in value address of the binding section points to another
{ binding section entry.

                        new_section_ordinal := ocv$new_binding_section_ordinal;
                        generate_binding_template_item (component, old_binding_template_item^.
                              binding_template^.binding_offset, new_section_offset, status);
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;
                      ELSE
                        relocated_section_ordinal (component, old_binding_template_item^.binding_template^.
                              section_ordinal, new_section_ordinal);
                        new_section_offset := relocated_section_offset
                              (component, old_binding_template_item^.binding_template^.section_ordinal,
                              old_binding_template_item^.binding_template^.offset);
                      IFEND;

{ Check if the new binding template already contains an entry with the corresponding
{ new_section ordinal and offset.

                      search_binding_temp_for_address (new_section_ordinal, new_section_offset,
                            old_binding_template_item^.binding_template^.internal_address,
                            new_template_item_found, new_binding_section_offset);

                      IF NOT new_template_item_found THEN
                        build_current_template_entry (old_binding_template_item^.binding_template^.
                              internal_address, new_binding_section_offset, status);
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;

                        build_new_adr_record (ocv$new_binding_section_ordinal,
                              ocv$last_new_binding_template^.binding_template.binding_offset,
                              ocv$last_new_binding_template^.binding_template.section_ordinal,
                              ocv$last_new_binding_template^.binding_template.offset,
                              ocv$last_new_binding_template^.binding_template.internal_address, 0, status);
                        IF NOT status.normal THEN
                          RETURN;
                        IFEND;
                      IFEND;

                    = llc$external_reference =
                      search_entry_point_sorted_list (old_binding_template_item^.binding_template^.name,
                            external_found, entry_point_address_item);

                      IF NOT external_found THEN

{ Check if this external has already been referenced and has an entry in the
{ the new binding template.

                        search_binding_temp_for_name (old_binding_template_item^.binding_template^.name,
                              old_binding_template_item^.binding_template^.address, new_template_item_found,
                              new_binding_section_offset);

                        IF NOT new_template_item_found THEN
                          build_external_template_entry (old_binding_template_item,
                                new_binding_section_offset, status);
                          IF NOT status.normal THEN
                            RETURN;
                          IFEND;

                          find_offset_operand (ocv$last_new_binding_template^.binding_template.name,
                                old_binding_template_offset, external_linkage, address_kind, offset_operand,
                                status);
                          IF NOT status.normal THEN
                            RETURN;
                          IFEND;

                          build_new_ext_record (external_linkage, ocv$new_binding_section_ordinal,
                                ocv$last_new_binding_template^.binding_template.binding_offset, address_kind,
                                offset_operand, status);
                          IF NOT status.normal THEN
                            RETURN;
                          IFEND;
                        IFEND;

                      ELSE
                        IF entry_point_address_item^.defined THEN
                          new_address_kind := old_binding_template_item^.binding_template^.address;
                          new_section_ordinal := entry_point_address_item^.section_ordinal;
                          new_section_offset := entry_point_address_item^.offset;
                          IF (old_binding_template_item^.binding_template^.address = llc$address_addition) OR
                                (old_binding_template_item^.binding_template^.address =
                                llc$address_subtraction) THEN
                            find_offset_operand (old_binding_template_item^.binding_template^.name,
                                  old_binding_template_offset, external_linkage, address_kind, offset_operand,
                                  status);
                            IF NOT status.normal THEN
                              RETURN;
                            IFEND;

                            new_address_kind := llc$address;
                            IF old_binding_template_item^.binding_template^.address =
                                  llc$address_addition THEN
                              new_section_offset := new_section_offset + offset_operand;
                            ELSE
                              new_section_offset := new_section_offset - offset_operand;
                            IFEND;
                          IFEND;
                        ELSE

{ Pointer stored in value address of the binding section points to another
{ binding section entry.

                          new_section_ordinal := ocv$new_binding_section_ordinal;
                          generate_binding_template_item (entry_point_address_item^.component^,
                                entry_point_address_item^.old_binding_offset, new_section_offset, status);
                          IF NOT status.normal THEN
                            RETURN;
                          IFEND;
                        IFEND;

{ Check if the new binding template already contains an entry with the corresponding
{ new_section ordinal and offset.

                        search_binding_temp_for_address (new_section_ordinal, new_section_offset,
                              new_address_kind, new_template_item_found, new_binding_section_offset);

                        IF NOT new_template_item_found THEN
                          build_current_template_entry (new_address_kind, new_binding_section_offset, status);
                          build_new_adr_record (ocv$new_binding_section_ordinal,
                                ocv$last_new_binding_template^.binding_template.binding_offset,
                                ocv$last_new_binding_template^.binding_template.section_ordinal,
                                ocv$last_new_binding_template^.binding_template.offset,
                                ocv$last_new_binding_template^.binding_template.internal_address, 0, status);
                          IF NOT status.normal THEN
                            RETURN;
                          IFEND;
                        IFEND;
                      IFEND;
                    CASEND;

                    old_binding_template_item^.new_binding_section_offset := new_binding_section_offset;
                    old_binding_template_item^.referenced_in_new_binding_sect := TRUE;
                  IFEND;
                PROCEND generate_binding_template_item;
?? OLDTITLE ??
?? NEWTITLE := '                BUILD_NEW_ENTRY_POINT_DEFN' ??
?? EJECT ??

                PROCEDURE build_new_entry_point_defn
                  (    separated_components: ^oct$separated_components;
                       starting_procedure: pmt$program_name;
                   VAR entry_point_address_list: oct$entry_point_address_list;
                       new_entry_definition_list: {output} ^oct$entry_definition_list;
                   VAR number_of_entry_definitions: llt$entry_point_index;
                       module_attributes: llt$module_attributes;
                   VAR status: ost$status);



                  CONST
                    c$allocation_size = 100;

                  TYPE
                    t$external = record
                      ext: ^oct$external_linkage_list,
                      module_name: ^pmt$program_name,
                      link: ^t$external,
                    recend,

                    t$external_list = record
                      name: ^pmt$program_name,
                      externals: ^t$external,
                      l_link: ^t$external_list,
                      r_link: ^t$external_list,
                    recend;


?? NEWTITLE := '                  BUILD_EXTERNAL_LIST' ??
?? EJECT ??

                  PROCEDURE build_external_list
                    (    separated_components: ^oct$separated_components;
                     VAR external_list: ^t$external_list;
                     VAR status: ost$status);


                    VAR
                      i: llt$module_index,
                      external: ^oct$external_linkage_list,
                      el_array: ^array [1 .. c$allocation_size] of t$external_list,
                      e_array: ^array [1 .. c$allocation_size] of t$external,
                      next_el: 1 .. c$allocation_size + 1,
                      next_e: 1 .. c$allocation_size + 1,
                      el: ^^t$external_list,
                      e: ^t$external;


                    external_list := NIL;
                    next_el := c$allocation_size + 1;
                    next_e := c$allocation_size + 1;

                    FOR i := 1 TO UPPERBOUND (separated_components^) DO
                      external := separated_components^ [i].external_linkage_list;

                      WHILE external <> NIL DO
                        el := ^external_list;

                      /loop/
                        WHILE el^ <> NIL DO
                          IF external^.external_linkage.name = el^^.name^ THEN
                            IF (external^.external_linkage.declaration_matching_required AND
                                  el^^.externals^.ext^.external_linkage.declaration_matching_required) AND
                                  (external^.external_linkage.language =
                                  el^^.externals^.ext^.external_linkage.language) THEN
                              IF (external^.external_linkage.language = llc$cybil) THEN
                                IF (external^.external_linkage.declaration_matching.object_encryption <>
                                      el^^.externals^.ext^.external_linkage.declaration_matching.
                                      object_encryption) THEN
                                  osp$set_status_abnormal (oc, oce$w_decl_mismatch_ext_object, el^^.name^,
                                       status);
                                 osp$append_status_parameter (osc$status_parameter_delimiter,
                                       el^^.externals^.module_name^, status);
                                 osp$append_status_parameter (osc$status_parameter_delimiter,
                                       separated_components^ [i].header^.name, status);
                                 ocp$generate_message (status);
                                 osp$set_status_abnormal (oc, oce$w_non_fatal_generate_error, '',
                                       command_status);
                               ELSEIF (external^.external_linkage.declaration_matching.source_encryption <>
                                     el^^.externals^.ext^.external_linkage.declaration_matching.
                                     source_encryption) THEN
                                 osp$set_status_abnormal (oc, oce$w_decl_mismatch_ext_source, el^^.name^,
                                       status);
                                 osp$append_status_parameter (osc$status_parameter_delimiter,
                                       el^^.externals^.module_name^, status);
                                 osp$append_status_parameter (osc$status_parameter_delimiter,
                                       separated_components^ [i].header^.name, status);
                                 ocp$generate_message (status);
                                 osp$set_status_abnormal (oc, oce$w_non_fatal_generate_error, '',
                                       command_status);
                               IFEND;
                             ELSE
                               IF (external^.external_linkage.declaration_matching.language_dependent_value <>
                                     el^^.externals^.ext^.external_linkage.declaration_matching.
                                     language_dependent_value) THEN
                                 osp$set_status_abnormal (oc, oce$w_decl_mismatch_ext_source, el^^.name^,
                                       status);
                                 osp$append_status_parameter (osc$status_parameter_delimiter,
                                       el^^.externals^.module_name^, status);
                                 osp$append_status_parameter (osc$status_parameter_delimiter,
                                       separated_components^ [i].header^.name, status);
                                 ocp$generate_message (status);
                                 osp$set_status_abnormal (oc, oce$w_non_fatal_generate_error, '',
                                       command_status);
                               IFEND;
                             IFEND;
                           IFEND;
                           IF next_e > c$allocation_size THEN
                             NEXT e_array IN segment_3;
                             IF e_array = NIL THEN
                               osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                               RETURN;
                             IFEND;
                             next_e := 1;
                           IFEND;

                           e := ^e_array^ [next_e];
                           next_e := next_e + 1;
                           e^.ext := external;
                           e^.module_name := ^separated_components^ [i].header^.name;
                           e^.link := el^^.externals;
                           el^^.externals := e;
                           EXIT /loop/;
                         ELSEIF external^.external_linkage.name > el^^.name^ THEN
                           el := ^el^^.r_link;
                         ELSE
                           el := ^el^^.l_link;
                         IFEND;
                       WHILEND /loop/;

                       IF el^ = NIL THEN
                         IF next_el > c$allocation_size THEN
                           NEXT el_array IN segment_3;
                           IF el_array = NIL THEN
                             osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                             RETURN;
                           IFEND;
                           next_el := 1;
                         IFEND;

                         el^ := ^el_array^ [next_el];
                         next_el := next_el + 1;
                         el^^.name := ^external^.external_linkage.name;

                         IF next_e > c$allocation_size THEN
                           NEXT e_array IN segment_3;
                           IF e_array = NIL THEN
                             osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                             RETURN;
                           IFEND;
                           next_e := 1;
                         IFEND;

                         el^^.externals := ^e_array^ [next_e];
                         next_e := next_e + 1;
                         el^^.externals^.ext := external;
                         el^^.externals^.module_name := ^separated_components^ [i].header^.name;
                         el^^.externals^.link := NIL;

                         el^^.l_link := NIL;
                         el^^.r_link := NIL;
                       IFEND;

                       external := external^.link;
                     WHILEND;
                   FOREND;


                 PROCEND build_external_list;
?? OLDTITLE ??
?? NEWTITLE := '                  SEARCH_EXTERNAL_LIST' ??
?? EJECT ??

                 PROCEDURE search_external_list
                   (    entry: ^oct$entry_definition_list;
                        module_name: ^pmt$program_name;
                        external_list: ^t$external_list;
                        module_attributes: llt$module_attributes;
                    VAR referenced_in_new_module: boolean);


                   VAR
                     apl: ^oct$actual_parameter_list,
                     el: ^t$external_list,
                     e: ^t$external;

                   el := external_list;

                   WHILE el <> NIL DO
                     IF el^.name^ = entry^.changed_name^ THEN
                       e := el^.externals;
                       WHILE e <> NIL DO
                         IF entry^.formal_parameter <> NIL THEN
                           apl := e^.ext^.actual_parameter_list.nnext;
                           WHILE apl <> NIL DO
                             fortran_argument_checking (apl^.actual_parameter, entry^.formal_parameter,
                                   module_name^, e^.module_name^);
                             apl := apl^.nnext;
                           WHILEND;
                         IFEND;
                         IF (entry^.entry_definition.declaration_matching_required AND
                               e^.ext^.external_linkage.declaration_matching_required) AND
                               (entry^.entry_definition.language = e^.ext^.external_linkage.language) THEN
                           IF (entry^.entry_definition.language = llc$cybil) THEN
                             IF (llc$object_cybil_checking IN module_attributes) THEN
                               IF (entry^.entry_definition.declaration_matching.object_encryption <>
                                     e^.ext^.external_linkage.declaration_matching.object_encryption) THEN
                                 osp$set_status_abnormal (oc, oce$f_declaration_mismatch,
                                       entry^.changed_name^, status);
                                 osp$append_status_parameter (osc$status_parameter_delimiter, module_name^,
                                       status);
                                 osp$append_status_parameter (osc$status_parameter_delimiter, e^.module_name^,
                                       status);
                                 ocp$generate_message (status);
                                 osp$set_status_abnormal (oc, oce$e_fatal_error, '', command_status);
                               IFEND;
                             ELSE { source type checking
                               IF (entry^.entry_definition.declaration_matching.source_encryption <>
                                     e^.ext^.external_linkage.declaration_matching.source_encryption) THEN
                                 osp$set_status_abnormal (oc, oce$w_declaration_mismatch,
                                       entry^.changed_name^, status);
                                 osp$append_status_parameter (osc$status_parameter_delimiter, module_name^,
                                       status);
                                 osp$append_status_parameter (osc$status_parameter_delimiter, e^.module_name^,
                                       status);
                                 ocp$generate_message (status);
                                 osp$set_status_abnormal (oc, oce$w_non_fatal_generate_error, '',
                                       command_status);
                               IFEND;
                             IFEND;
                           ELSE { language is not CYBIL
                             IF (entry^.entry_definition.declaration_matching.language_dependent_value <>
                                   e^.ext^.external_linkage.declaration_matching.language_dependent_value)
                                   THEN
                               osp$set_status_abnormal (oc, oce$w_declaration_mismatch, entry^.changed_name^,
                                     status);
                               osp$append_status_parameter (osc$status_parameter_delimiter, module_name^,
                                     status);
                               osp$append_status_parameter (osc$status_parameter_delimiter, e^.module_name^,
                                     status);
                               ocp$generate_message (status);
                               osp$set_status_abnormal (oc, oce$w_non_fatal_generate_error, '',
                                     command_status);
                             IFEND;
                           IFEND;
                         IFEND;
                         e := e^.link;
                       WHILEND;

                       referenced_in_new_module := TRUE;
                       RETURN;
                     ELSEIF entry^.changed_name^ > el^.name^ THEN
                       el := el^.r_link;
                     ELSE
                       el := el^.l_link;
                     IFEND;
                   WHILEND;

                   referenced_in_new_module := FALSE;


                 PROCEND search_external_list;
?? OLDTITLE ??
?? EJECT ??

                 VAR
                   i: llt$module_index,
                   entry_point: ^oct$entry_definition_list,
                   entry_definition: llt$entry_definition,
                   entry_point_address_item: ^oct$entry_point_address_list,
                   number_of_entry_points: llt$entry_point_index,
                   last_new_entry_definition: ^oct$entry_definition_list,
                   external_list: ^t$external_list,
                   formal_parameter: ^llt$formal_parameters,
                   referenced_in_new_module: boolean,
                   segment_offset: ost$segment_offset;

{ generate the entry point address list

                 number_of_entry_points := 0;
                 entry_point_address_item := ^entry_point_address_list;

                 FOR i := 1 TO UPPERBOUND (separated_components^) DO
                   entry_point := separated_components^ [i].entry_definition_list.link;

                   WHILE entry_point <> NIL DO
                     entry_definition := entry_point^.entry_definition;

                     NEXT entry_point_address_item^.link IN segment_4;
                     entry_point_address_item := entry_point_address_item^.link;
                     IF entry_point_address_item = NIL THEN
                       osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
                       RETURN;
                     IFEND;

                     number_of_entry_points := number_of_entry_points + 1;
                     entry_point_address_item^.name := entry_definition.name;

                     IF separated_components^ [i].section_definitions^ [entry_definition.section_ordinal]^.
                           section_definition.kind = llc$binding_section THEN
                       entry_point_address_item^.defined := FALSE;
                       entry_point_address_item^.component := ^separated_components^ [i];
                       entry_point_address_item^.old_binding_offset := entry_definition.offset;
                     ELSE
                       entry_point_address_item^.defined := TRUE;
                       relocated_section_ordinal (separated_components^ [i], entry_definition.section_ordinal,
                             entry_point_address_item^.section_ordinal);
                       entry_point_address_item^.offset := relocated_section_offset
                             (separated_components^ [i], entry_definition.section_ordinal,
                             entry_definition.offset);
                     IFEND;

                     entry_point := entry_point^.link;
                   WHILEND;
                 FOREND;

                 entry_point_address_item^.link := NIL;

                 build_entry_point_sorted_list (number_of_entry_points, entry_point_address_list.link,
                       entry_point_sorted_list, status);
                 IF NOT status.normal THEN
                   RETURN;
                 IFEND;

{ generate new entry definition records


                 build_external_list (separated_components, external_list, status);
                 IF NOT status.normal THEN
                   RETURN;
                 IFEND;

                 entry_point_address_item := entry_point_address_list.link;
                 last_new_entry_definition := new_entry_definition_list;

                 FOR i := 1 TO UPPERBOUND (separated_components^) DO
                   entry_point := separated_components^ [i].entry_definition_list.link;

                   WHILE entry_point <> NIL DO
                     entry_definition := entry_point^.entry_definition;
                     search_external_list (entry_point, ^separated_components^ [i].header^.name,
                           external_list, module_attributes, referenced_in_new_module);

                     IF ((entry_definition.attributes <> $llt$entry_point_attributes []) OR
                           (NOT referenced_in_new_module) OR (entry_definition.name = starting_procedure)) AND
                           (entry_point^.changed_name^ <> osc$null_name) THEN

                       IF separated_components^ [i].section_definitions^ [entry_definition.section_ordinal]^.
                             section_definition.kind = llc$binding_section THEN

                         entry_point_address_item^.defined := TRUE;
                         generate_binding_template_item (separated_components^ [i], entry_definition.offset,
                               segment_offset, status);
                         IF NOT status.normal THEN
                           RETURN;
                         IFEND;
                         entry_point_address_item^.offset := segment_offset;

                         entry_point_address_item^.section_ordinal := ocv$new_binding_section_ordinal;
                       IFEND;

                       last_new_entry_definition^.link := entry_point;
                       last_new_entry_definition := last_new_entry_definition^.link;
                       last_new_entry_definition^.entry_definition.section_ordinal :=
                             entry_point_address_item^.section_ordinal;
                       last_new_entry_definition^.entry_definition.offset := entry_point_address_item^.offset;
                       last_new_entry_definition^.entry_definition.name := entry_point^.changed_name^;

                       number_of_entry_definitions := number_of_entry_definitions + 1;

                       IF entry_definition.name = starting_procedure THEN
                         last_new_entry_definition^.entry_definition.attributes :=
                               last_new_entry_definition^.entry_definition.attributes +
                               $llt$entry_point_attributes [llc$retain_entry_point];
                         IF separated_components^ [i].section_definitions^
                               [entry_definition.section_ordinal]^.section_definition.kind <>
                               llc$code_section THEN
                           osp$set_status_abnormal (oc, oce$e_starting_proc_not_in_code, starting_procedure,
                                 status);
                           RETURN;
                         IFEND;
                       IFEND;
                     IFEND;

                     entry_point := entry_point^.link;
                     entry_point_address_item := entry_point_address_item^.link;
                   WHILEND;

                 FOREND;

                 last_new_entry_definition^.link := NIL;

               PROCEND build_new_entry_point_defn;


?? OLDTITLE ??
?? NEWTITLE := '                FORTRAN_ARGUMENT_CHECKING' ??
?? EJECT ??

               PROCEDURE fortran_argument_checking
                 (VAR actual_parameters: ^llt$actual_parameters;
                      formal_parameters: ^llt$formal_parameters;
                      mod1: pmt$program_name;
                      mod2: pmt$program_name);

                 TYPE
                   formal_type_array = array [llt$fortran_argument_type] of boolean,
                   actual_type_array = array [llt$fortran_argument_type] of formal_type_array,
                   formal_kind_array = array [llt$fortran_argument_kind] of boolean,
                   actual_kind_array = array [llc$fortran_variable .. llc$fortran_array_element] of
                         formal_kind_array,
                   formal_usage_array = array [llt$argument_usage] of boolean,
                   actual_usage_array = array [llt$argument_usage] of formal_usage_array;

?? FMT (FORMAT := OFF) ??


      VAR
        fortran_argument_type_checking: [STATIC, READ, oss$job_paged_literal] actual_type_array := [
                    {  L      I      R      DR    COMP   CHAR    B      NT     SL     HR     BIT  }
        {    L   }  [ TRUE,  FALSE, FALSE, FALSE, FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    I   }  [ FALSE, TRUE,  FALSE, FALSE, FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    R   }  [ FALSE, FALSE, TRUE,  FALSE, FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    DR  }  [ FALSE, FALSE, FALSE, TRUE,  FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {   COMP }  [ FALSE, FALSE, FALSE, FALSE, TRUE,  FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {   CHAR }  [ FALSE, FALSE, FALSE, FALSE, FALSE, TRUE,  TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    B   }  [ TRUE,  TRUE,  TRUE,  FALSE, FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    NT  }  [ TRUE,  TRUE,  TRUE,  TRUE,  TRUE,  TRUE,  TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    SL  }  [ FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE,  FALSE, FALSE ],
        {    HR  }  [ FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE,  FALSE ],
        {   BIT  }  [ FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE ]];



      VAR
        fortran_argument_kind_checking: [STATIC, READ, oss$job_paged_literal] actual_kind_array := [
                  {  V      A      X      AE     U    }
        {  V  }   [ TRUE,  FALSE, FALSE, FALSE, TRUE  ],
        {  A  }   [ FALSE, TRUE,  FALSE, FALSE, FALSE ],
        {  X  }   [ FALSE, FALSE, TRUE,  FALSE, TRUE  ],
        {  AE }   [ TRUE,  TRUE,  FALSE, FALSE, TRUE ]];


      VAR
        fortran_argument_usage_checking: [STATIC, READ, oss$job_paged_literal] actual_usage_array := [

                 {  W      NW  }
        {  W   }  [ TRUE,  TRUE ],
        {  NW  }  [ FALSE, TRUE ]];

  ?? FMT (FORMAT := ON) ??

                 VAR
                   actual_seq: ^SEQ ( * ),
                   formal_seq: ^SEQ ( * ),
                   actual_parameter_descriptor: ^llt$fortran_argument_desc,
                   formal_parameter_descriptor: ^llt$fortran_argument_desc,
                   parameter_number: integer,
                   type_valid: boolean,
                   kind_valid: boolean,
                   usage_valid: boolean,
                   valid: boolean,
                   actual_length: integer,
                   formal_length: integer;

                 actual_seq := ^actual_parameters^.specification;
                 formal_seq := ^formal_parameters^.specification;
                 RESET actual_seq;
                 RESET formal_seq;

                 NEXT actual_parameter_descriptor IN actual_seq;
                 NEXT formal_parameter_descriptor IN formal_seq;

                 parameter_number := 0;
                 WHILE (actual_parameter_descriptor <> NIL) AND (formal_parameter_descriptor <> NIL) DO
                   type_valid := fortran_argument_type_checking [actual_parameter_descriptor^.argument_type]
                         [formal_parameter_descriptor^.argument_type];
                   IF NOT type_valid THEN
                     osp$set_status_abnormal (oc, oce$invalid_type_matching, mod2, status);
                     osp$append_status_parameter (osc$status_parameter_delimiter, mod1, status);
                     osp$append_status_integer (osc$status_parameter_delimiter, parameter_number, 10, FALSE,
                           status);
                     osp$append_status_parameter (osc$status_parameter_delimiter,
                           actual_parameters^.callee_name, status);
                     ocp$generate_message (status);
                   ELSE
                     kind_valid := fortran_argument_kind_checking
                           [actual_parameter_descriptor^.argument_kind]
                           [formal_parameter_descriptor^.argument_kind];
                     IF NOT kind_valid THEN
                       osp$set_status_abnormal (oc, oce$invalid_kind_matching, mod2, status);
                       osp$append_status_parameter (osc$status_parameter_delimiter, mod1, status);
                       osp$append_status_integer (osc$status_parameter_delimiter, parameter_number, 10, FALSE,
                             status);
                       osp$append_status_parameter (osc$status_parameter_delimiter,
                             actual_parameters^.callee_name, status);
                       ocp$generate_message (status);
                     ELSE
                       usage_valid := fortran_argument_usage_checking [actual_parameter_descriptor^.mode]
                             [formal_parameter_descriptor^.mode];
                       IF NOT usage_valid THEN
                         osp$set_status_abnormal (oc, oce$invalid_mode_matching, mod2, status);
                         osp$append_status_parameter (osc$status_parameter_delimiter, mod1, status);
                         osp$append_status_integer (osc$status_parameter_delimiter, parameter_number, 10,
                               FALSE, status);
                         osp$append_status_parameter (osc$status_parameter_delimiter,
                               actual_parameters^.callee_name, status);
                         ocp$generate_message (status);
                       IFEND;
                     IFEND;
                   IFEND;

                   IF (actual_parameter_descriptor^.argument_type = llc$fortran_char) AND
                         (formal_parameter_descriptor^.argument_type = llc$fortran_boolean) THEN
                     valid := actual_parameter_descriptor^.string_length.number_of_characters >= 8;
                     IF NOT valid THEN
                       osp$set_status_abnormal (oc, oce$bad_char_length, mod1, status);
                       osp$append_status_integer (c$spd, parameter_number, 10, FALSE, status);
                       osp$append_status_integer (c$spd, actual_parameter_descriptor^.string_length.
                             number_of_characters, 10, FALSE, status);
                       osp$append_status_integer (c$spd, formal_parameter_descriptor^.string_length.
                             number_of_characters, 10, FALSE, status);
                       ocp$generate_message (status);
                     IFEND;
                   IFEND;

                   IF (actual_parameter_descriptor^.argument_type = llc$fortran_char) AND
                         (formal_parameter_descriptor^.argument_type = llc$fortran_char) AND
                         (NOT (llc$fortran_assumed_len_string IN actual_parameter_descriptor^.string_length.
                         attributes)) THEN
                     valid := actual_parameter_descriptor^.string_length.number_of_characters >=
                           formal_parameter_descriptor^.string_length.number_of_characters;
                     IF NOT valid THEN
                       osp$set_status_abnormal (oc, oce$bad_char_length, mod1, status);
                       osp$append_status_integer (c$spd, parameter_number, 10, FALSE, status);
                       osp$append_status_integer (c$spd, actual_parameter_descriptor^.string_length.
                             number_of_characters, 10, FALSE, status);
                       osp$append_status_integer (c$spd, formal_parameter_descriptor^.string_length.
                             number_of_characters, 10, FALSE, status);
                       ocp$generate_message (status);
                     IFEND;
                   IFEND;

                   IF ((actual_parameter_descriptor^.argument_type = llc$fortran_char) AND
                         (formal_parameter_descriptor^.argument_type = llc$fortran_char)) THEN
                     IF (((actual_parameter_descriptor^.argument_kind = llc$fortran_array) AND
                           (NOT (llc$fortran_adaptable_array IN actual_parameter_descriptor^.array_size.
                           attributes) AND NOT (llc$fortran_assumed_len_array IN
                           actual_parameter_descriptor^.array_size.attributes)) OR
                           (actual_parameter_descriptor^.argument_kind = llc$fortran_array_element) AND
                           (NOT (llc$fortran_assumed_len_string IN actual_parameter_descriptor^.string_length.
                           attributes))) AND (formal_parameter_descriptor^.argument_kind =
                           llc$fortran_array) AND (NOT (llc$fortran_adaptable_array IN
                           formal_parameter_descriptor^.array_size.attributes) AND
                           NOT (llc$fortran_assumed_len_array IN formal_parameter_descriptor^.array_size.
                           attributes))) THEN
                       IF actual_parameter_descriptor^.argument_kind = llc$fortran_array THEN
                         actual_length := actual_parameter_descriptor^.array_size.number_of_elements *
                               actual_parameter_descriptor^.string_length.number_of_characters;
                       ELSE
                         actual_length := actual_parameter_descriptor^.string_length.number_of_characters;
                       IFEND;

                       IF formal_parameter_descriptor^.argument_kind = llc$fortran_array THEN
                         formal_length := formal_parameter_descriptor^.array_size.number_of_elements *
                               formal_parameter_descriptor^.string_length.number_of_characters;
                       ELSE
                         formal_length := formal_parameter_descriptor^.string_length.number_of_characters;
                       IFEND;
                       valid := actual_length >= formal_length;
                       IF NOT valid THEN
                         osp$set_status_abnormal (oc, oce$actual_less_than_formal, mod1, status);
                         osp$append_status_integer (c$spd, parameter_number, 10, FALSE, status);
                         osp$append_status_integer (c$spd, actual_length, 10, FALSE, status);
                         osp$append_status_integer (c$spd, formal_length, 10, FALSE, status);
                         ocp$generate_message (status);
                       IFEND;
                     IFEND;
                   IFEND;

                   IF (actual_parameter_descriptor^.argument_type = llc$fortran_integer) AND
                         (formal_parameter_descriptor^.argument_type = llc$fortran_integer) THEN

{ The purpose of the following code is to maintain compatibility with binary files
{ compiled before INTEGER*N code is available in FORTRAN.

                     IF actual_parameter_descriptor^.string_length.number_of_characters = 0 THEN
                       actual_length := 8;
                     ELSE
                       actual_length := actual_parameter_descriptor^.string_length.number_of_characters;
                     IFEND;
                     IF formal_parameter_descriptor^.string_length.number_of_characters = 0 THEN
                       formal_length := 8;
                     ELSE
                       formal_length := formal_parameter_descriptor^.string_length.number_of_characters;
                     IFEND;

{ End of code to maintain compatibility

                     valid := actual_length = formal_length;
                     IF NOT valid THEN
                       osp$set_status_abnormal (oc, oce$bad_integer_length, mod2, status);
                       osp$append_status_parameter (osc$status_parameter_delimiter, mod1, status);
                       osp$append_status_integer (osc$status_parameter_delimiter, parameter_number, 10, FALSE,
                             status);
                       osp$append_status_parameter (osc$status_parameter_delimiter,
                             actual_parameters^.callee_name, status);
                       ocp$generate_message (status);
                     IFEND;
                   IFEND;

                   IF formal_parameter_descriptor^.argument_kind = llc$fortran_array THEN
                     IF llc$fortran_assumed_shape_array IN formal_parameter_descriptor^.array_size.
                           attributes THEN
                       IF ((actual_parameter_descriptor^.argument_kind <> llc$fortran_array) OR
                             (llc$fortran_assumed_len_array IN actual_parameter_descriptor^.array_size.
                             attributes) OR (formal_parameter_descriptor^.array_size.rank <>
                             actual_parameter_descriptor^.array_size.rank)) THEN
                         osp$set_status_abnormal (oc, oce$fortran_array_type_mismatch, mod2, status);
                         osp$append_status_parameter (c$spd, mod1, status);
                         osp$append_status_integer (c$spd, parameter_number, 10, FALSE, status);
                         ocp$generate_message (status);
                       IFEND;
                     ELSE
                       IF (actual_parameter_descriptor^.argument_kind = llc$fortran_array) AND
                             ((llc$fortran_assumed_shape_array IN actual_parameter_descriptor^.array_size.
                             attributes) OR (llc$fortran_array_section IN
                             actual_parameter_descriptor^.array_size.attributes)) THEN
                         osp$set_status_abnormal (oc, oce$fortran_array_type_mismatch, mod2, status);
                         osp$append_status_parameter (c$spd, mod1, status);
                         osp$append_status_integer (c$spd, parameter_number, 10, FALSE, status);
                         ocp$generate_message (status);
                       IFEND;
                     IFEND;
                   IFEND;

                   NEXT actual_parameter_descriptor IN actual_seq;
                   NEXT formal_parameter_descriptor IN formal_seq;
                   parameter_number := parameter_number + 1;
                 WHILEND;
                 IF (actual_parameter_descriptor = NIL) AND (formal_parameter_descriptor <> NIL) THEN
                   osp$set_status_abnormal (oc, oce$invalid_param_for_proc, actual_parameters^.callee_name,
                         status);
                   osp$append_status_parameter (osc$status_parameter_delimiter, mod2, status);
                   osp$append_status_parameter (osc$status_parameter_delimiter, mod1, status);
                   ocp$generate_message (status);
                 IFEND;
               PROCEND fortran_argument_checking;


?? OLDTITLE ??
?? NEWTITLE := '                PROCESS_RELOCATION_RECORDS' ??
?? EJECT ??

               PROCEDURE process_relocation_records
                 (    separated_components: ^oct$separated_components;
                  VAR new_relocation_list: oct$relocation_list;
                  VAR status: ost$status);

?? NEWTITLE := '                  FETCH_OLD_RELOCATION_VALUE' ??
?? EJECT ??

                 PROCEDURE fetch_old_relocation_value
                   (    component: oct$separated_module_header;
                        old_relocation: llt$relocation_item;
                    VAR old_relocation_value: llt$section_offset;
                    VAR new_relocation: llt$relocation_item;
                    VAR container_location: ^cell;
                    VAR instruction_location: ^cell;
                    VAR temp_bit_string: bit_string_array;
                    VAR bit_string_insertion_record: ^llt$bit_string_insertion;
                    VAR status: ost$status);



                   VAR
                     parcel_container: ^packed record
                       case 0 .. 1 of

                       = 0 =
                         parcel: 0 .. 0ffff(16),

                       = 1 =
                         sign_bit: boolean,
                       casend,
                     recend,

                     three_byte_container: ^packed record
                       case 0 .. 1 of

                       = 0 =
                         three_byte: 0 .. 0ffffff(16),

                       = 1 =
                         sign_bit: boolean,
                       casend,
                     recend,

                     halfword_container: ^packed record
                       case 0 .. 1 of

                       = 0 =
                         halfword: 0 .. 0ffffffff(16),

                       = 1 =
                         sign_bit: boolean,
                       casend,
                     recend,

                     word_container: ^packed record
                       case 0 .. 1 of

                       = 0 =
                         word: integer,

                       = 1 =
                         sign_bit: boolean,
                       casend,
                     recend,

                     d_field_container: ^packed record
                       case 0 .. 1 of

                       = 0 =
                         i_portion: 0 .. 0f(16),
                         d_portion: 0 .. 0fff(16),

                       = 1 =
                         filler: 0 .. 0f(16),
                         sign_bit: boolean,
                       casend,
                     recend,

                     q_field_container: ^packed record
                       case 0 .. 1 of

                       = 0 =
                         q_field: oct$q_field,

                       = 1 =
                         sign_bit: boolean,
                       casend,
                     recend,

                     long_d_field_container: ^packed record
                       case 0 .. 1 of

                       = 0 =
                         long_d_field: 0 .. 0ffffff(16),

                       = 1 =
                         sign_bit: boolean,
                       casend,
                     recend,

                     bit_offset: 0 .. 7,
                     bit: 1 .. 63,

                     container_offset: llt$section_offset,
                     container_size: [STATIC] array [llt$relocation_container] of 2 .. 8 :=
                           [2, 3, 4, 8, 2, 2, 3],
                     section_length: ost$segment_length,

                     offset: llt$section_offset,
                     length: integer,
                     number_of_replications: integer,

                     sign_bit_on: boolean,

                     text_insertion: ^oct$text_insertion_list;


                   instruction_location := NIL;

                   relocated_section_ordinal (component, old_relocation.section_ordinal,
                         new_relocation.section_ordinal);
                   new_relocation.offset := relocated_section_offset
                         (component, old_relocation.section_ordinal, old_relocation.offset);

                 /get_container_location/
                   BEGIN
                     IF component.section_definitions^ [old_relocation.section_ordinal]^.new^.section_ptr <>
                           NIL THEN

                       section_length := #SIZE (component.section_definitions^
                             [old_relocation.section_ordinal]^.new^.section_ptr^);
                       IF (new_relocation.offset + container_size [old_relocation.container]) >
                             section_length THEN
                         osp$set_status_abnormal (oc, oce$e_container_outside_record, component.header^.name,
                               status);
                         RETURN;
                       IFEND;

                       container_location := #LOC (component.section_definitions^
                             [old_relocation.section_ordinal]^.new^.section_ptr^ [new_relocation.offset]);

                       IF (new_relocation.offset - 2) >= 0 THEN
                         IF old_relocation.container = llc$180_q_field THEN
                           instruction_location := #LOC (component.section_definitions^
                                 [old_relocation.section_ordinal]^.new^.
                                 section_ptr^ [new_relocation.offset - 2]);
                         IFEND;
                       ELSE
                         osp$set_status_abnormal (oc, oce$e_opcode_not_within_record, component.header^.name,
                               status);
                         RETURN;
                       IFEND;

                       EXIT /get_container_location/;

                     ELSE
                       container_location := NIL;

                       text_insertion := component.section_definitions^ [old_relocation.section_ordinal]^.
                             new^.text_insertion_records.link;

                       WHILE (text_insertion <> NIL) AND (NOT text_insertion^.overlapped) AND
                             ((text_insertion^.offset + text_insertion^.length) >= new_relocation.offset) DO

                         CASE text_insertion^.kind OF

                         = llc$text =
                           length := text_insertion^.length;
                           IF (new_relocation.offset >= text_insertion^.offset) AND
                                 (new_relocation.offset < (text_insertion^.offset + length)) THEN

                             IF (new_relocation.offset + container_size [old_relocation.container]) >
                                   (text_insertion^.offset + length) THEN
                               osp$set_status_abnormal (oc, oce$e_container_outside_record,
                                     component.header^.name, status);
                               RETURN;
                             IFEND;


                             container_offset := new_relocation.offset - text_insertion^.text^.offset;
                             container_location := #LOC (text_insertion^.text^.byte [container_offset + 1]);

                             IF (container_offset - 2) >= 0 THEN
                               IF old_relocation.container = llc$180_q_field THEN
                                 instruction_location := #LOC (text_insertion^.text^.
                                       byte [(container_offset - 2) + 1])
                               IFEND;
                             ELSE
                               osp$set_status_abnormal (oc, oce$e_opcode_not_within_record,
                                     component.header^.name, status);
                               RETURN;
                             IFEND;

                             EXIT /get_container_location/;
                           IFEND;

                         = llc$replication =
                           IF new_relocation.offset >= text_insertion^.offset THEN
                             offset := text_insertion^.offset;
                             length := #SIZE (text_insertion^.replication^.byte);

                           /check_replications_for_offset/
                             FOR number_of_replications := 1 TO text_insertion^.replication^.count DO
                               IF (new_relocation.offset >= offset) THEN
                                 IF new_relocation.offset < (offset + length) THEN
                                   IF (new_relocation.offset + container_size [old_relocation.container]) >
                                       (offset + length) THEN
                                   osp$set_status_abnormal (oc, oce$e_container_outside_record,
                                       component.header^.name, status);
                                 RETURN;
                               IFEND;
                               container_offset := new_relocation.offset - offset;
                               container_location := #LOC (text_insertion^.replication^.
                                     byte [container_offset + 1]);

                               IF (container_offset - 2) >= 0 THEN
                                 IF old_relocation.container = llc$180_q_field THEN
                                   instruction_location := #LOC (text_insertion^.replication^.
                                       byte [(container_offset - 2) + 1]);
                               IFEND;
                             ELSE
                               osp$set_status_abnormal (oc, oce$e_opcode_not_within_record,
                                     component.header^.name, status);
                               RETURN;
                             IFEND;

                             EXIT /get_container_location/;
                           IFEND;
                         ELSE
                           EXIT /check_replications_for_offset/;
                         IFEND;

                         offset := offset + text_insertion^.replication^.increment;
                       FOREND /check_replications_for_offset/;
                     IFEND;

                   = llc$bit_string_insertion =
                     bit_string_insertion_record := text_insertion^.bit_string_insertion;

                     length := ((bit_string_insertion_record^.bit_offset +
                           bit_string_insertion_record^.bit_length + 7) DIV 8);
                     IF (new_relocation.offset >= bit_string_insertion_record^.offset) AND
                           (new_relocation.offset < bit_string_insertion_record^.offset + length) THEN

                       container_offset := new_relocation.offset - bit_string_insertion_record^.offset;

                       IF ((container_offset = 0) AND (bit_string_insertion_record^.bit_offset <> 0) AND
                             ((bit_string_insertion_record^.bit_offset <> 4) OR
                             (new_relocation.container <> llc$180_d_field))) OR
                             (((container_offset + container_size [old_relocation.container]) * 8) >
                             (bit_string_insertion_record^.bit_offset +
                             bit_string_insertion_record^.bit_length)) THEN
                         osp$set_status_abnormal (oc, oce$e_container_outside_record, component.header^.name,
                               status);
                         RETURN;
                       IFEND;

                       bit_offset := text_insertion^.bit_string_insertion^.bit_offset;
                       FOR bit := 1 TO text_insertion^.bit_string_insertion^.bit_length DO
                         temp_bit_string.bit_array [bit + bit_offset] :=
                               text_insertion^.bit_string_insertion^.bit_string [bit];
                       FOREND;

                       container_location := #LOC (temp_bit_string.byte_array [container_offset + 1]);

                       IF old_relocation.container = llc$180_q_field THEN
                         instruction_location := #LOC (temp_bit_string.byte_array [(container_offset - 2) +
                               1])
                       IFEND;
                       EXIT /get_container_location/;
                     IFEND;

                   CASEND;

                   text_insertion := text_insertion^.link;
                 WHILEND;

                 IF container_location = NIL THEN
                   osp$set_status_abnormal (oc, oce$relocation_value_not_found, component.header^.name,
                         status);
                   RETURN;
                 IFEND;
               IFEND;
             END /get_container_location/;

             CASE old_relocation.container OF

             = llc$two_bytes =
               parcel_container := container_location;
               old_relocation_value := parcel_container^.parcel;
               sign_bit_on := parcel_container^.sign_bit;

             = llc$three_bytes =
               three_byte_container := container_location;
               old_relocation_value := three_byte_container^.three_byte;
               sign_bit_on := three_byte_container^.sign_bit;

             = llc$four_bytes =
               halfword_container := container_location;
               old_relocation_value := halfword_container^.halfword;
               sign_bit_on := halfword_container^.sign_bit;

             = llc$eight_bytes =
               word_container := container_location;
               old_relocation_value := word_container^.word;
               sign_bit_on := word_container^.sign_bit;

             = llc$180_d_field =
               d_field_container := container_location;
               old_relocation_value := d_field_container^.d_portion;
               sign_bit_on := d_field_container^.sign_bit;

             = llc$180_q_field =
               q_field_container := container_location;
               old_relocation_value := q_field_container^.q_field.q;
               sign_bit_on := q_field_container^.sign_bit;

             = llc$180_long_d_field =
               long_d_field_container := container_location;
               old_relocation_value := long_d_field_container^.long_d_field;
               sign_bit_on := long_d_field_container^.sign_bit;
             ELSE
               osp$set_status_abnormal (oc, oce$e_invalid_container_kind, component.header^.name, status);
               RETURN;

             CASEND;

             CASE old_relocation.address OF

             = llc$byte_positive =

             = llc$two_byte_positive =
               old_relocation_value := old_relocation_value * 2;

             = llc$four_byte_positive =
               old_relocation_value := old_relocation_value * 4;

             = llc$eight_byte_positive =
               old_relocation_value := old_relocation_value * 8;

             = llc$byte_signed =
               IF sign_bit_on THEN
                 osp$set_status_abnormal (oc, oce$e_sign_bit_set_in_container, component.header^.name,
                       status);
                 RETURN;
               IFEND;

             = llc$two_byte_signed =
               old_relocation_value := old_relocation_value * 2;

               IF sign_bit_on THEN
                 osp$set_status_abnormal (oc, oce$e_sign_bit_set_in_container, component.header^.name,
                       status);
                 RETURN;
               IFEND;

             = llc$four_byte_signed =
               old_relocation_value := old_relocation_value * 4;

               IF sign_bit_on THEN
                 osp$set_status_abnormal (oc, oce$e_sign_bit_set_in_container, component.header^.name,
                       status);
                 RETURN;
               IFEND;

             = llc$eight_byte_signed =
               old_relocation_value := old_relocation_value * 8;

               IF sign_bit_on THEN
                 osp$set_status_abnormal (oc, oce$e_sign_bit_set_in_container, component.header^.name,
                       status);
                 RETURN;
               IFEND;

             ELSE
               osp$set_status_abnormal (oc, oce$e_invalid_container_adr_typ, component.header^.name, status);
             CASEND;

           PROCEND fetch_old_relocation_value;
?? OLDTITLE ??
?? NEWTITLE := '                  BUILD_CALLREL_USING_A3' ??
?? EJECT ??

           PROCEDURE build_callrel_using_a3
             (    instruction_location: ^cell;
                  relocation_distance: integer;
              VAR status: ost$status);


             VAR
               instruction: ^packed record
                 opcode: 0(16) .. 0ff(16),
                 j_field: 0(16) .. 0f(16),
                 k_field: 0(16) .. 0f(16),
                 q_field: oct$q_field,
               recend;


             instruction := instruction_location;

             instruction^.opcode := 0b0(16);
             instruction^.j_field := 3;

             IF (relocation_distance < LOWERVALUE (instruction^.q_field.q)) OR
                   (relocation_distance > UPPERVALUE (instruction^.q_field.q)) THEN
               osp$set_status_abnormal (oc, oce$container_overflow, 'Q-field in a CALLREL instruction',
                     status);
               RETURN;
             IFEND;

             instruction^.q_field.q := relocation_distance;


           PROCEND build_callrel_using_a3;
?? OLDTITLE ??
?? NEWTITLE := '                  BUILD_CALLREL_USING_AJ' ??
?? EJECT ??

           PROCEDURE build_callrel_using_aj
             (    instruction_location: ^cell;
                  relocation_distance: integer;
              VAR status: ost$status);


             VAR
               instruction: ^packed record
                 opcode: 0(16) .. 0ff(16),
                 j_field: 0(16) .. 0f(16),
                 k_field: 0(16) .. 0f(16),
                 q_field: oct$q_field,
               recend;


             instruction := instruction_location;

             instruction^.opcode := 0b0(16);

             IF (relocation_distance < LOWERVALUE (instruction^.q_field.q)) OR
                   (relocation_distance > UPPERVALUE (instruction^.q_field.q)) THEN
               osp$set_status_abnormal (oc, oce$container_overflow, 'Q-field in a CALLREL instruction',
                     status);
               RETURN;
             IFEND;

             instruction^.q_field.q := relocation_distance;


           PROCEND build_callrel_using_aj;
?? OLDTITLE ??
?? NEWTITLE := '                  REPLACE_NEW_RELOCATION_VALUE' ??
?? EJECT ??

           PROCEDURE replace_new_relocation_value
             (    new_relocation: llt$relocation_item;
                  temp_bit_string: bit_string_array;
                  module_name: pmt$program_name;
              VAR new_relocation_value: ost$segment_offset;
              VAR bit_string_insertion_record: ^llt$bit_string_insertion;
              VAR container_location: ^cell;
              VAR status: ost$status);


             VAR
               parcel_container: ^0(16) .. 0ffff(16),
               three_byte_container: ^0(16) .. 0ffffff(16),
               halfword_container: ^0(16) .. 0ffffffff(16),
               word_container: ^integer,
               d_field_container: ^packed record
                 i_portion: 0(16) .. 0f(16),
                 d_portion: 0(16) .. 0fff(16),
               recend,
               q_field_container: ^oct$q_field,
               long_d_field_container: ^0(16) .. 0ffffff(16),

               bit: 1 .. 63,

               container_offset: llt$section_offset,

               text_insertion: ^oct$text_insertion_list;


             CASE new_relocation.address OF

             = llc$byte_positive =

             = llc$two_byte_positive =
               new_relocation_value := new_relocation_value DIV 2;

             = llc$four_byte_positive =
               new_relocation_value := new_relocation_value DIV 4;

             = llc$eight_byte_positive =
               new_relocation_value := new_relocation_value DIV 8;

             = llc$byte_signed =

             = llc$two_byte_signed =
               new_relocation_value := new_relocation_value DIV 2;

             = llc$four_byte_signed =
               new_relocation_value := new_relocation_value DIV 4;

             = llc$eight_byte_signed =
               new_relocation_value := new_relocation_value DIV 8;

             CASEND;

             CASE new_relocation.container OF

             = llc$two_bytes =
               parcel_container := container_location;

               IF (new_relocation_value < LOWERVALUE (parcel_container^)) OR
                     (new_relocation_value > UPPERVALUE (parcel_container^)) THEN
                 osp$set_status_abnormal (oc, oce$container_overflow, 'parcel', status);
                 RETURN;
               IFEND;

               parcel_container^ := new_relocation_value;

             = llc$three_bytes =
               three_byte_container := container_location;

               IF (new_relocation_value < LOWERVALUE (three_byte_container^)) OR
                     (new_relocation_value > UPPERVALUE (three_byte_container^)) THEN
                 osp$set_status_abnormal (oc, oce$container_overflow, 'three bytes', status);
                 RETURN;
               IFEND;

               three_byte_container^ := new_relocation_value;

             = llc$four_bytes =
               halfword_container := container_location;

               IF (new_relocation_value < LOWERVALUE (halfword_container^)) OR
                     (new_relocation_value > UPPERVALUE (halfword_container^)) THEN
                 osp$set_status_abnormal (oc, oce$container_overflow, 'halfword', status);
                 RETURN;
               IFEND;

               halfword_container^ := new_relocation_value;

             = llc$eight_bytes =
               word_container := container_location;

               IF (new_relocation_value < LOWERVALUE (word_container^)) OR
                     (new_relocation_value > UPPERVALUE (word_container^)) THEN
                 osp$set_status_abnormal (oc, oce$container_overflow, 'word', status);
                 RETURN;
               IFEND;

               word_container^ := new_relocation_value;

             = llc$180_d_field =
               d_field_container := container_location;

               IF (new_relocation_value < LOWERVALUE (d_field_container^.d_portion)) OR
                     (new_relocation_value > UPPERVALUE (d_field_container^.d_portion)) THEN
                 osp$set_status_abnormal (oc, oce$container_overflow, 'd_field', status);
                 RETURN;
               IFEND;

               d_field_container^.d_portion := new_relocation_value;

             = llc$180_q_field =
               q_field_container := container_location;
               q_field_container^.q := new_relocation_value;

               IF (new_relocation_value < LOWERVALUE (q_field_container^.q)) OR
                     (new_relocation_value > UPPERVALUE (q_field_container^.q)) THEN
                 osp$set_status_abnormal (oc, oce$e_bound_module_too_large, module_name, status);
                 RETURN;
               IFEND;


             = llc$180_long_d_field =
               long_d_field_container := container_location;

               IF (new_relocation_value < LOWERVALUE (long_d_field_container^)) OR
                     (new_relocation_value > UPPERVALUE (long_d_field_container^)) THEN
                 osp$set_status_abnormal (oc, oce$container_overflow, 'd_field', status);
                 RETURN;
               IFEND;

               long_d_field_container^ := new_relocation_value;

             CASEND;

             IF bit_string_insertion_record <> NIL THEN
               FOR bit := 1 TO bit_string_insertion_record^.bit_length DO
                 bit_string_insertion_record^.bit_string [bit] :=
                       temp_bit_string.bit_array [bit + bit_string_insertion_record^.bit_offset];
               FOREND;
             IFEND;

           PROCEND replace_new_relocation_value;
?? OLDTITLE ??
?? NEWTITLE := '                  RELOCATE_NEW_CODE_SECTION' ??
?? EJECT ??

           PROCEDURE relocate_to_new_code_section
             (    component: oct$separated_module_header;
                  old_relocation: llt$relocation_item;
                  old_relocation_value: llt$section_offset;
                  new_relocation_item: llt$relocation_item;
                  temp_bit_string: bit_string_array;
              VAR bit_string_insertion_record: ^llt$bit_string_insertion;
              VAR container_location: ^cell;
              VAR status: ost$status);




             VAR
               new_relocation_value: ost$segment_offset;


             new_relocation_value := relocated_section_offset
                   (component, old_relocation.relocating_section, old_relocation_value);
             replace_new_relocation_value (new_relocation_item, temp_bit_string, component.header^.name,
                   new_relocation_value, bit_string_insertion_record, container_location, status);
             IF NOT status.normal THEN
               RETURN;
             IFEND;

             NEXT last_new_relocation^.link IN segment_4;
             last_new_relocation := last_new_relocation^.link;
             IF last_new_relocation = NIL THEN
               osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
               RETURN;
             IFEND;

             last_new_relocation^.link := NIL;
             last_new_relocation^.relocation_item := new_relocation_item;

             ocv$number_of_new_rel_items := ocv$number_of_new_rel_items + 1;

           PROCEND relocate_to_new_code_section;
?? OLDTITLE ??
?? NEWTITLE := '                  RELOCATE_EXT_TO_NEW_BINDING_SEC' ??
?? EJECT ??

           PROCEDURE relocate_ext_to_new_binding_sec
             (    component: oct$separated_module_header;
                  old_relocation_value: llt$section_offset;
                  new_relocation_item: llt$relocation_item;
                  old_binding_template_item: ^oct$old_binding_template_item;
                  instruction_location: ^cell;
                  temp_bit_string: bit_string_array;
              VAR bit_string_insertion_record: ^llt$bit_string_insertion;
              VAR container_location: ^cell;
              VAR status: ost$status);



             CONST
               two_to_the_plus_fifteenth = 8000(16),
               two_to_the_minus_fifteenth = -two_to_the_plus_fifteenth,
               callseg = 0b5(16);



             VAR
               external_found: boolean,

               entry_point_address_item: ^oct$entry_point_address_list,

               instruction: ^packed record
                 opcode: 0(16) .. 0ff(16),
                 j_field: 0(16) .. 0f(16),
                 k_field: 0(16) .. 0f(16),
                 q_field: oct$q_field,
               recend,

               new_binding_section_offset: ost$segment_offset,

               relocation_distance: integer;





             instruction := instruction_location;

             IF (new_relocation_item.container = llc$180_q_field) AND (instruction^.opcode = callseg) THEN
               search_entry_point_sorted_list (old_binding_template_item^.binding_template^.name,
                     external_found, entry_point_address_item);

               IF external_found THEN
                 IF entry_point_address_item^.section_ordinal = new_relocation_item.section_ordinal THEN
                   relocation_distance := (entry_point_address_item^.offset DIV 8) -
                         ((new_relocation_item.offset - 2) DIV 8);
                   IF (relocation_distance > two_to_the_minus_fifteenth) AND
                         (relocation_distance < two_to_the_plus_fifteenth) THEN

                     IF ((old_binding_template_item^.binding_template^.kind = llc$current_module) AND
                           (old_binding_template_item^.binding_template^.internal_address =
                           llc$internal_proc)) OR ((old_binding_template_item^.binding_template^.kind =
                           llc$external_reference) AND (old_binding_template_item^.binding_template^.address =
                           llc$internal_proc)) THEN
                       build_callrel_using_a3 (instruction_location, relocation_distance, status);

                     ELSEIF ((old_binding_template_item^.binding_template^.kind = llc$current_module) AND
                           (old_binding_template_item^.binding_template^.internal_address =
                           llc$external_proc)) OR ((old_binding_template_item^.binding_template^.kind =
                           llc$external_reference) AND (old_binding_template_item^.binding_template^.address =
                           llc$external_proc)) THEN
                       build_callrel_using_aj (instruction_location, relocation_distance, status);

                     ELSE
                       osp$set_status_abnormal (oc, oce$e_invalid_template_adr_kind, component.header^.name,
                             status);
                     IFEND;

                     RETURN;
                   IFEND;
                 IFEND;
               IFEND;
             IFEND;

             generate_binding_template_item (component, old_binding_template_item^.binding_template^.
                   binding_offset, new_binding_section_offset, status);
             ocv$number_of_new_rel_items := ocv$number_of_new_rel_items + 1;
             IF NOT status.normal THEN
               RETURN;
             IFEND;

             replace_new_relocation_value (new_relocation_item, temp_bit_string, component.header^.name,
                   new_binding_section_offset, bit_string_insertion_record, container_location, status);
             IF NOT status.normal THEN
               RETURN;
             IFEND;

             NEXT last_new_relocation^.link IN segment_4;
             last_new_relocation := last_new_relocation^.link;
             IF last_new_relocation = NIL THEN
               osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
               RETURN;
             IFEND;

             last_new_relocation^.link := NIL;
             last_new_relocation^.relocation_item := new_relocation_item;


           PROCEND relocate_ext_to_new_binding_sec;
?? OLDTITLE ??
?? NEWTITLE := '                  RELOCATE_NEW_MODULE_ADDRESS' ??
?? EJECT ??

           PROCEDURE relocate_new_module_address
             (    component: oct$separated_module_header;
                  old_relocation_value: llt$section_offset;
                  old_binding_template_item: ^oct$old_binding_template_item;
                  new_relocation_item: llt$relocation_item;
                  instruction_location: ^cell;
                  temp_bit_string: bit_string_array;
              VAR bit_string_insertion_record: ^llt$bit_string_insertion;
              VAR container_location: ^cell;
              VAR status: ost$status);



             CONST
               two_to_the_plus_fifteenth = 8000(16),
               two_to_the_minus_fifteenth = -two_to_the_plus_fifteenth,
               callseg = 0b5(16);




             VAR
               new_binding_section_offset: ost$segment_offset,
               procedure_section_ordinal: llt$section_ordinal,
               procedure_offset: llt$section_offset,
               instruction: ^packed record
                 opcode: 0(16) .. 0ff(16),
                 j_field: 0(16) .. 0f(16),
                 k_field: 0(16) .. 0f(16),
                 q_field: oct$q_field,
               recend,

               relocation_distance: integer;



             instruction := instruction_location;

             IF (new_relocation_item.container = llc$180_q_field) AND (instruction^.opcode = callseg) THEN
               relocated_section_ordinal (component, old_binding_template_item^.binding_template^.
                     section_ordinal, procedure_section_ordinal);

               IF procedure_section_ordinal = new_relocation_item.section_ordinal THEN
                 procedure_offset := relocated_section_offset (component,
                       old_binding_template_item^.binding_template^.section_ordinal,
                       old_binding_template_item^.binding_template^.offset);
                 relocation_distance := (procedure_offset DIV 8) - ((new_relocation_item.offset - 2) DIV 8);

                 IF (relocation_distance > two_to_the_minus_fifteenth) AND
                       (relocation_distance < two_to_the_plus_fifteenth) THEN

                   IF ((old_binding_template_item^.binding_template^.kind = llc$current_module) AND
                         (old_binding_template_item^.binding_template^.internal_address =
                         llc$internal_proc)) OR ((old_binding_template_item^.binding_template^.kind =
                         llc$external_reference) AND (old_binding_template_item^.binding_template^.address =
                         llc$internal_proc)) THEN
                     build_callrel_using_a3 (instruction_location, relocation_distance, status);

                   ELSEIF ((old_binding_template_item^.binding_template^.kind = llc$current_module) AND
                         (old_binding_template_item^.binding_template^.internal_address =
                         llc$external_proc)) OR ((old_binding_template_item^.binding_template^.kind =
                         llc$external_reference) AND (old_binding_template_item^.binding_template^.address =
                         llc$external_proc)) THEN
                     build_callrel_using_aj (instruction_location, relocation_distance, status);
                   ELSE
                     osp$set_status_abnormal (oc, oce$e_invalid_template_adr_kind, component.header^.name,
                           status);
                   IFEND;

                   RETURN;
                 IFEND;
               IFEND;
             IFEND;

             generate_binding_template_item (component, old_binding_template_item^.binding_template^.
                   binding_offset, new_binding_section_offset, status);
             ocv$number_of_new_rel_items := ocv$number_of_new_rel_items + 1;
             IF NOT status.normal THEN
               RETURN;
             IFEND;

             replace_new_relocation_value (new_relocation_item, temp_bit_string, component.header^.name,
                   new_binding_section_offset, bit_string_insertion_record, container_location, status);
             IF NOT status.normal THEN
               RETURN;
             IFEND;

             NEXT last_new_relocation^.link IN segment_4;
             last_new_relocation := last_new_relocation^.link;
             IF last_new_relocation = NIL THEN
               osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
               RETURN;
             IFEND;

             last_new_relocation^.link := NIL;
             last_new_relocation^.relocation_item := new_relocation_item;


           PROCEND relocate_new_module_address;
?? OLDTITLE ??
?? NEWTITLE := '                  [INLINE] RELOCATE_ADDRESS', EJECT ??

           PROCEDURE [INLINE] relocate_address
             (    component: oct$separated_module_header;
              VAR relocation: ^oct$relocation_item_list;
              VAR status: ost$status);

             VAR
               bit_string_insertion_record: ^llt$bit_string_insertion,
               container_location: ^cell,
               instruction_location: ^cell,
               item_number: integer,
               new_relocation_item: llt$relocation_item,
               old_binding_template_item: ^oct$old_binding_template_item,
               old_relocation_item: llt$relocation_item,
               old_relocation_value: llt$section_offset,
               temp_bit_string: bit_string_array;

             status.normal := TRUE;

             WHILE relocation <> NIL DO
               old_relocation_item := relocation^.item^;

               new_relocation_item := old_relocation_item;
               bit_string_insertion_record := NIL;

               fetch_old_relocation_value (component, old_relocation_item, old_relocation_value,
                     new_relocation_item, container_location, instruction_location, temp_bit_string,
                     bit_string_insertion_record, status);
               IF NOT status.normal THEN
                 RETURN;
               IFEND;

               relocated_section_ordinal (component, old_relocation_item.relocating_section,
                     new_relocation_item.relocating_section);

               CASE component.section_definitions^ [old_relocation_item.relocating_section]^.
                     section_definition.kind OF

               = llc$code_section =
                 relocate_to_new_code_section (component, old_relocation_item, old_relocation_value,
                       new_relocation_item, temp_bit_string, bit_string_insertion_record, container_location,
                       status);
                 IF NOT status.normal THEN
                   RETURN;
                 IFEND;

               = llc$binding_section =
                 get_old_binding_template_item (component, old_relocation_value, old_binding_template_item,
                       status);
                 IF NOT status.normal THEN
                   RETURN;
                 IFEND;

                 IF old_binding_template_item^.binding_template^.kind = llc$external_reference THEN
                   relocate_ext_to_new_binding_sec (component, old_relocation_value, new_relocation_item,
                         old_binding_template_item, instruction_location, temp_bit_string,
                         bit_string_insertion_record, container_location, status);
                   IF NOT status.normal THEN
                     RETURN;
                   IFEND;

                 ELSE
                   relocate_new_module_address (component, old_relocation_value, old_binding_template_item,
                         new_relocation_item, instruction_location, temp_bit_string,
                         bit_string_insertion_record, container_location, status);
                   IF NOT status.normal THEN
                     RETURN;
                   IFEND;

                 IFEND;
               ELSE
                 osp$set_status_abnormal (oc, oce$e_relocating_sec_wrong_kind, component.header^.name,
                       status);
                 RETURN;
               CASEND;

               relocation := relocation^.link;
             WHILEND;
           PROCEND relocate_address;
?? OLDTITLE ??
?? EJECT ??

           TYPE
             bit_string_array = record
               case 0 .. 1 of

               = 0 =
                 bit_array: packed array [1 .. 70] of 0 .. 1,

               = 1 =
                 byte_array: array [1 .. 9] of 0 .. 0ff(16),
               casend,
             recend;

           VAR
             i: llt$module_index,
             last_new_relocation: ^oct$relocation_list,
             relocation: ^oct$relocation_item_list;

           status.normal := TRUE;

           last_new_relocation := ^new_relocation_list;

           FOR i := 1 TO UPPERBOUND (separated_components^) DO
             relocation := separated_components^ [i].relocation_list.byte.link;

             relocate_address (separated_components^ [i], relocation, status);
             IF NOT status.normal THEN
               RETURN;
             IFEND;
           FOREND;

           FOR i := 1 TO UPPERBOUND (separated_components^) DO
             relocation := separated_components^ [i].relocation_list.two_byte.link;

             relocate_address (separated_components^ [i], relocation, status);
             IF NOT status.normal THEN
               RETURN;
             IFEND;
           FOREND;

           FOR i := 1 TO UPPERBOUND (separated_components^) DO
             relocation := separated_components^ [i].relocation_list.four_byte.link;

             relocate_address (separated_components^ [i], relocation, status);
             IF NOT status.normal THEN
               RETURN;
             IFEND;
           FOREND;

           FOR i := 1 TO UPPERBOUND (separated_components^) DO
             relocation := separated_components^ [i].relocation_list.eight_byte.link;

             relocate_address (separated_components^ [i], relocation, status);
             IF NOT status.normal THEN
               RETURN;
             IFEND;
           FOREND;

         PROCEND process_relocation_records;
?? OLDTITLE ??
?? NEWTITLE := '                PROCESS_ADR_FORMULATION_RECORDS' ??
?? EJECT ??

         PROCEDURE process_adr_formulation_records
           (    separated_components: ^oct$separated_components;
            VAR status: ost$status);



           VAR
             address_formulation: ^oct$address_formulation_list,
             address_formulation_item: llt$address_formulation_item,

             i: llt$module_index,
             item_number: integer,

             new_dest_section_ordinal: llt$section_ordinal,
             new_value_section_ordinal: llt$section_ordinal,
             new_dest_offset: llt$section_offset,
             new_value_offset: ost$segment_offset;





           FOR i := 1 TO UPPERBOUND (separated_components^) DO
             address_formulation := separated_components^ [i].address_formulation_list;

             WHILE address_formulation <> NIL DO
               IF separated_components^ [i].section_definitions^
                     [address_formulation^.address_formulation.dest_section]^.section_definition.kind <>
                     llc$binding_section THEN

                 relocated_section_ordinal (separated_components^ [i],
                       address_formulation^.address_formulation.dest_section, new_dest_section_ordinal);
                 relocated_section_ordinal (separated_components^ [i],
                       address_formulation^.address_formulation.value_section, new_value_section_ordinal);

                 FOR item_number := LOWERBOUND (address_formulation^.address_formulation.item)
                       TO UPPERBOUND (address_formulation^.address_formulation.item) DO

                   address_formulation_item := address_formulation^.address_formulation.item [item_number];
                   new_dest_offset := relocated_section_offset (separated_components^ [i],
                         address_formulation^.address_formulation.dest_section,
                         address_formulation_item.dest_offset);

                   IF separated_components^ [i].section_definitions^
                         [address_formulation^.address_formulation.value_section]^.section_definition.kind =
                         llc$binding_section THEN

                     generate_binding_template_item (separated_components^ [i],
                           address_formulation_item.value_offset, new_value_offset, status);
                     IF NOT status.normal THEN
                       RETURN;
                     IFEND;
                   ELSE
                     new_value_offset := relocated_section_offset
                           (separated_components^ [i], address_formulation^.address_formulation.value_section,
                           address_formulation_item.value_offset);
                   IFEND;

                   build_new_adr_record (new_dest_section_ordinal, new_dest_offset, new_value_section_ordinal,
                         new_value_offset, address_formulation_item.kind, 0, status);
                   IF NOT status.normal THEN
                     RETURN;
                   IFEND;
                 FOREND;
               IFEND;

               address_formulation := address_formulation^.link;
             WHILEND;

           FOREND;

         PROCEND process_adr_formulation_records;
?? OLDTITLE ??
?? NEWTITLE := '                PROCESS_EXT_LINKAGE_RECORDS' ??
?? EJECT ??

         PROCEDURE process_ext_linkage_records
           (    separated_components: ^oct$separated_components;
            VAR status: ost$status);




           VAR
             component: ^oct$separated_components,
             external_found: boolean,
             actual_parameter: ^oct$actual_parameter_list,
             external_linkage: ^oct$external_linkage_list,
             external_linkage_item: llt$external_linkage_item,
             entry_point_address_item: ^oct$entry_point_address_list,
             link: ^oct$external_linkage_item,
             i: llt$module_index,
             item_number: integer,

             new_dest_section_ordinal: llt$section_ordinal,
             new_dest_offset: llt$section_offset,

             new_value_section_ordinal: llt$section_ordinal,
             new_value_offset: ost$segment_offset;



           FOR i := 1 TO UPPERBOUND (separated_components^) DO
             external_linkage := separated_components^ [i].external_linkage_list;

             WHILE external_linkage <> NIL DO
               FOR item_number := LOWERBOUND (external_linkage^.external_linkage.item)
                     TO UPPERBOUND (external_linkage^.external_linkage.item) DO

                 external_linkage_item := external_linkage^.external_linkage.item [item_number];

                 IF separated_components^ [i].section_definitions^ [external_linkage_item.section_ordinal]^.
                       section_definition.kind <> llc$binding_section THEN

                   relocated_section_ordinal (separated_components^ [i],
                         external_linkage_item.section_ordinal, new_dest_section_ordinal);
                   new_dest_offset := relocated_section_offset (separated_components^ [i],
                         external_linkage_item.section_ordinal, external_linkage_item.offset);
                   search_entry_point_sorted_list (external_linkage^.external_linkage.name, external_found,
                         entry_point_address_item);

                   IF external_found THEN
                     IF entry_point_address_item^.defined THEN
                       new_value_section_ordinal := entry_point_address_item^.section_ordinal;
                       new_value_offset := entry_point_address_item^.offset;
                     ELSE
                       generate_binding_template_item (entry_point_address_item^.component^,
                             entry_point_address_item^.old_binding_offset, new_value_offset, status);
                       IF NOT status.normal THEN
                         RETURN;
                       IFEND;

                       new_value_section_ordinal := ocv$new_binding_section_ordinal;
                     IFEND;

                     build_new_adr_record (new_dest_section_ordinal, new_dest_offset,
                           new_value_section_ordinal, new_value_offset, external_linkage_item.kind,
                           external_linkage_item.offset_operand, status);
                     IF NOT status.normal THEN
                       RETURN;
                     IFEND;
                   ELSE
                     build_new_ext_record (external_linkage, new_dest_section_ordinal, new_dest_offset,
                           external_linkage_item.kind, external_linkage_item.offset_operand, status);
                     IF NOT status.normal THEN
                       RETURN;
                     IFEND;
                   IFEND;
                 IFEND;
               FOREND;
               IF (external_linkage^.actual_parameter_list.nnext <> NIL) THEN
                 link := temporary_module_header^.external_linkage_items.link;

               /loop/
                 WHILE link <> NIL DO
                   IF link^.name = external_linkage^.external_linkage.name THEN
                     IF (link^.actual_parameter_list = NIL) THEN
                       link^.actual_parameter_list := external_linkage^.actual_parameter_list.nnext;
                     ELSE
                       actual_parameter := link^.actual_parameter_list;
                       WHILE actual_parameter^.nnext <> NIL DO
                         actual_parameter := actual_parameter^.nnext;
                       WHILEND;
                       actual_parameter^.nnext := external_linkage^.actual_parameter_list.nnext;
                     IFEND;
                     EXIT /loop/;
                   ELSE
                     link := link^.link;
                   IFEND;
                 WHILEND /loop/;
               IFEND;
               external_linkage := external_linkage^.link;
             WHILEND;

           FOREND;

         PROCEND process_ext_linkage_records;
?? OLDTITLE ??
?? EJECT ??



         VAR
           entry_point_address_list: oct$entry_point_address_list,
           entry_point_sorted_list: oct$entry_point_sorted_list,
           ocv$last_new_adr_formulation: ^oct$address_formulation_item,
           ocv$last_new_binding_template: ^oct$new_binding_template_list,
           ocv$last_new_external: ^oct$external_linkage_item,

           ocv$number_of_new_temp_items: integer,
           ocv$number_of_new_rel_items: integer,


           ocv$new_binding_section_ordinal: llt$section_ordinal,
           ocv$next_avail_binding_offset: llt$section_offset;




         ocv$number_of_new_temp_items := 0;
         ocv$number_of_new_rel_items := 0;

         IF ocv$binding_section <> NIL THEN
           ocv$new_binding_section_ordinal := ocv$binding_section^.section_definition.section_ordinal;
           ocv$next_avail_binding_offset := 0;
         IFEND;

         ocv$last_new_adr_formulation := ^temporary_module_header^.address_formulation_items;
         ocv$last_new_adr_formulation^.link := NIL;
         ocv$last_new_external := ^temporary_module_header^.external_linkage_items;
         ocv$last_new_external^.link := NIL;
         ocv$last_new_binding_template := ^temporary_module_header^.binding_template_list;


         build_new_entry_point_defn (separated_components, temporary_module_header^.starting_procedure,
               entry_point_address_list, ^temporary_module_header^.entry_definition_list,
               temporary_module_header^.number_of_entry_definitions,
               temporary_module_header^.identification.attributes, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;

         process_relocation_records (separated_components, temporary_module_header^.relocation_list, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;

         process_adr_formulation_records (separated_components, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;

         process_ext_linkage_records (separated_components, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;

         IF ocv$number_of_new_rel_items > llc$max_info_elements THEN
           osp$set_status_abnormal (oc, oce$e_too_many_relocation_items,
                 temporary_module_header^.identification.name, status);
           RETURN;
         ELSE
           temporary_module_header^.number_of_rel_items := ocv$number_of_new_rel_items;
         IFEND;

         IF ocv$number_of_new_temp_items > llc$max_info_elements THEN
           osp$set_status_abnormal (oc, oce$e_too_many_template_items,
                 temporary_module_header^.identification.name, status);
           RETURN;
         ELSE
           temporary_module_header^.number_of_template_items := ocv$number_of_new_temp_items;
         IFEND;

         IF ocv$binding_section <> NIL THEN
           IF ocv$next_avail_binding_offset <> 0 THEN
             ocv$binding_section^.section_definition.length := ocv$next_avail_binding_offset;
           ELSE

{ Delete the binding section definition

             ocv$binding_section := ^temporary_module_header^.section_definitions;
             WHILE ocv$binding_section^.link^.section_definition.kind <> llc$binding_section DO
               ocv$binding_section := ocv$binding_section^.link;
             WHILEND;

             ocv$binding_section^.link := ocv$binding_section^.link^.link;
           IFEND;
         IFEND;

         combine_ext_records (temporary_module_header^.external_linkage_items.link,
               temporary_module_header^.external_linkage_list, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;

         combine_adr_records (temporary_module_header^.address_formulation_items.link,
               temporary_module_header^.address_formulation_list, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;

         collect_miscellaneous_records (separated_components,
               temporary_module_header^.miscellaneous_record_list, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;


       PROCEND bind_module;
?? OLDTITLE ??
?? NEWTITLE := '              PRINT_SECTION_MAP', EJECT ??

       PROCEDURE print_section_map
         (    temporary_module_header: ^oct$temporary_module_header;
              map_file: clt$file;
          VAR status: ost$status);


         VAR
           next_section: ^oct$section_definition_list,
           old_section: ^oct$old_section_list,

           page_header: string (62),
           line: [STATIC] string (123) := '   offset: ########  length: ########  module:             ' CAT
                 '                        section:',
           str: ost$string,
           section_name: pmt$program_name,
           valid: boolean,
           ignore: ost$status;


         page_header := 'Display of sections for module ';
         page_header (32, 31) := temporary_module_header^.identification.name;

         ocp$open_output_file (map_file.local_file_name, ^page_header, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;


         ocp$output (occ$triple_space, 'Section map for module ', 23, occ$continue);
         ocp$output (' ', temporary_module_header^.identification.name, 31, occ$continue);
         ocp$output ('    ', 'created:', 8, occ$continue);
         ocp$output_time (^temporary_module_header^.identification.time_created, occ$continue, valid);
         ocp$output ('', ' ', 1, occ$continue);
         ocp$output_date (^temporary_module_header^.identification.date_created, occ$end_of_line, valid);
         ocp$output (occ$single_space, '', 0, occ$end_of_line);

         next_section := temporary_module_header^.section_definitions.link;

         WHILE next_section <> NIL DO
           ocp$output (occ$triple_space, 'kind:', 5, occ$continue);
           ocp$output_section_kind (^next_section^.section_definition.kind, occ$continue, valid);

           clp$convert_integer_to_string (next_section^.section_definition.length, 16, FALSE, str, ignore);
           ocp$output ('  length: ', str.value, str.size, occ$continue);

           IF next_section^.section_definition.name <> osc$null_name THEN
             ocp$output ('  name: ', next_section^.section_definition.name, 31, occ$end_of_line);
           ELSE
             ocp$output ('', ' ', 1, occ$end_of_line);
           IFEND;

           ocp$output (' ', ' ', 1, occ$end_of_line);

           IF (next_section^.section_definition.kind <> llc$binding_section) THEN
             old_section := next_section^.old_sections.link;

             WHILE old_section <> NIL DO
               clp$convert_integer_to_string (old_section^.component^.
                     section_definitions^ [old_section^.section_ordinal]^.new_section_offset, 16, FALSE, str,
                     ignore);
               line (12, 8) := str.value (1, str.size);

               clp$convert_integer_to_string (old_section^.component^.
                     section_definitions^ [old_section^.section_ordinal]^.section_definition.length, 16,
                     FALSE, str, ignore);
               line (30, 8) := str.value (1, str.size);

               line (48, 31) := old_section^.component^.header^.name;

               section_name := old_section^.component^.section_definitions^ [old_section^.section_ordinal]^.
                     section_definition.name;

               IF section_name = osc$null_name THEN
                 ocp$output ('', line, 78, occ$end_of_line);
               ELSE
                 line (93, * ) := section_name;
                 ocp$output ('', line, 123, occ$end_of_line);
               IFEND;

               old_section := old_section^.link;
             WHILEND;
           IFEND;

           next_section := next_section^.link;
         WHILEND;


         ocp$close_output_file (status);
         IF NOT status.normal THEN
           ocp$generate_message (status);
         IFEND;


       PROCEND print_section_map;
?? OLDTITLE ??
?? EJECT ??


       VAR
         changed_entry_points: ^oct$external_declaration_list,
         debug_tables_to_omit: oct$debug_tables,
         separated_components: ^oct$separated_components,

         current_section_ordinal: 0 .. llc$max_section_ordinal + 1,
         i: llt$module_index,
         collect_component_libraries: boolean,
         number_of_binding_sections: integer,
         binding_sections: ^oct$section_definition_list;


{ SEPARATE BOUND MODULE COMPONENTS


       NEXT separated_components: [1 .. UPPERBOUND (bound_module.components^)] IN segment_1;
       IF separated_components = NIL THEN
         osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
         RETURN;
       IFEND;

       IF (changed_info <> NIL) THEN
         debug_tables_to_omit := changed_info^.debug_tables_to_omit;

         IF (changed_info^.entry_points <> NIL) THEN
           changed_entry_points := changed_info^.entry_points;
         ELSE
           changed_entry_points := NIL;
         IFEND;
       ELSE
         changed_entry_points := NIL;
         debug_tables_to_omit := $oct$debug_tables [];
       IFEND;

       separate_components (bound_module.components, debug_tables_to_omit, changed_entry_points,
             separated_components, status);

       IF NOT status.normal THEN
         RETURN;
       IFEND;

{ INITIAL TEMPORARY_MODULE_HEADER


       temporary_module_header^.identification := bound_module.identification;
       IF quick_bind THEN
         temporary_module_header^.application_identifier := separated_components^ [1].application_identifier;
         temporary_module_header^.deferred_common_blocks := separated_components^ [1].deferred_common_blocks;
       ELSE
         temporary_module_header^.application_identifier := NIL;
         temporary_module_header^.deferred_common_blocks := NIL;
         temporary_module_header^.deferred_entry_points := NIL;
       IFEND;

       IF changed_info <> NIL THEN
         IF changed_info^.name <> NIL THEN
           temporary_module_header^.identification.name := changed_info^.name^;
         IFEND;

         IF changed_info^.commentary <> NIL THEN
           temporary_module_header^.identification.commentary := changed_info^.commentary^;
         IFEND;

         IF changed_info^.entry_points <> NIL THEN
           temporary_module_header^.starting_procedure := changed_info^.starting_procedure;
         ELSE
           temporary_module_header^.starting_procedure := separated_components^
                 [UPPERBOUND (separated_components^)].starting_procedure;
         IFEND;

         IF changed_info^.new_libraries THEN
           temporary_module_header^.library_list.link := changed_info^.library_list;
           collect_component_libraries := FALSE;
         ELSE
           temporary_module_header^.library_list.link := NIL;
           collect_component_libraries := TRUE;
         IFEND;

         IF changed_info^.application_identifier <> NIL THEN
           temporary_module_header^.application_identifier := changed_info^.application_identifier;
         IFEND;

         IF changed_info^.cybil_parameter_checking = object_type_checking THEN
           temporary_module_header^.identification.attributes :=
                 temporary_module_header^.identification.attributes +
                 $llt$module_attributes [llc$object_cybil_checking];
         ELSE
           temporary_module_header^.identification.attributes :=
                 temporary_module_header^.identification.attributes -
                 $llt$module_attributes [llc$object_cybil_checking];
         IFEND;

       ELSE
         temporary_module_header^.starting_procedure := separated_components^
               [UPPERBOUND (separated_components^)].starting_procedure;
         temporary_module_header^.library_list.link := NIL;
         collect_component_libraries := TRUE;
       IFEND;

       temporary_module_header^.section_definitions.link := NIL;

       temporary_module_header^.number_of_entry_definitions := 0;
       temporary_module_header^.entry_definition_list.link := NIL;

       temporary_module_header^.external_linkage_list := NIL;
       temporary_module_header^.external_linkage_items.link := NIL;
       temporary_module_header^.address_formulation_list := NIL;
       temporary_module_header^.address_formulation_items.link := NIL;

       temporary_module_header^.miscellaneous_record_list.link := NIL;

       temporary_module_header^.number_of_rel_items := 0;
       temporary_module_header^.relocation_list.link := NIL;

       temporary_module_header^.number_of_template_items := 0;
       temporary_module_header^.binding_template_list.link := NIL;

{ COLLECT SEPARATED COMPONENT INFO, LIBRARIES, SECTION DEFINITIONS, AND CODE SECTIONS

       collect_component_info (separated_components, temporary_module_header^.component_info, status);
       IF NOT status.normal THEN
         RETURN;
       IFEND;


       ocv$binding_section := NIL;
       current_section_ordinal := 0;

       FOR i := 1 TO UPPERBOUND (separated_components^) DO
         IF collect_component_libraries THEN
           collect_libraries (separated_components^ [i], temporary_module_header^.library_list, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;
         IFEND;


         collect_section_records (separated_components^ [i], current_section_ordinal,
               temporary_module_header^.section_definitions, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;

       FOREND;


{ BIND THE SEPARATED COMPONENTS


       IF bound_module.code_section_ids.link <> NIL THEN
         sort_code_sections (bound_module.code_section_ids, temporary_module_header^.section_definitions);
       IFEND;


       build_composite_sections (temporary_module_header^.section_definitions, status);
       IF NOT status.normal THEN
         RETURN;
       IFEND;


       IF quick_bind THEN
         quick_bind_module (separated_components, temporary_module_header, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;
       ELSE
         bind_module (separated_components, temporary_module_header, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;
       IFEND;


       number_of_binding_sections := 0;
       binding_sections := temporary_module_header^.section_definitions.link;

       WHILE binding_sections <> NIL DO
         IF binding_sections^.section_definition.kind = llc$binding_section THEN
           number_of_binding_sections := number_of_binding_sections + 1;
         IFEND;
         binding_sections := binding_sections^.link;
       WHILEND;

       IF number_of_binding_sections > 1 THEN
         osp$set_status_abnormal ('OC', oce$e_multiple_binding_sections,
               temporary_module_header^.identification.name, status);
         RETURN;
       IFEND;

       IF bound_module.section_map.local_file_name <> osc$null_name THEN
         print_section_map (temporary_module_header, bound_module.section_map, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;
       IFEND;


       temporary_module_header^.include_binary_section_maps :=
             (bound_module.include_binary_section_maps AND (temporary_module_header^.section_definitions.
             link <> NIL));


     PROCEND change_bound_to_temp_module;
?? OLDTITLE ??
?? EJECT ??


     VAR
       bound_module_header: oct$bound_module_header;


     NEXT temporary_load_module IN ocv$olg_scratch_seq;
     IF temporary_load_module = NIL THEN
       osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
       RETURN;
     IFEND;

     temporary_load_module^.kind := occ$temporary_load_module;

{ Set to NIL so that write_header_interpretive_info can reference the file field
{ of the load_module_header without getting a ring zero fault.

     temporary_load_module^.file := NIL;

     NEXT temporary_load_module^.temporary_module_header IN ocv$olg_scratch_seq;
     IF temporary_load_module^.temporary_module_header = NIL THEN
       osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
       RETURN;
     IFEND;


     CASE module_description^.kind OF
     = occ$cpu_object_module =
       quick_bind := TRUE;
       bound_module_header.identification := module_description^.cpu_object_module_header^.identification^;
       bound_module_header.section_map.local_file_name := osc$null_name;

       bound_module_header.xref_list.link := NIL; { NEVER used in 'change_bound_to_temp_module'}

       NEXT bound_module_header.components: [1 .. 1] IN ocv$olg_scratch_seq;
       IF bound_module_header.components = NIL THEN
         osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
         RETURN;
       IFEND;
       bound_module_header.components^ [1] := module_description;

       bound_module_header.code_section_ids.link := NIL;
       bound_module_header.preset_specified := FALSE;
       bound_module_header.preset_value := pmc$initialize_to_zero;
       bound_module_header.include_binary_section_maps := FALSE;

       change_bound_to_temp_module (bound_module_header, changed_info,
             temporary_load_module^.temporary_module_header, status);


     = occ$bound_module =
       quick_bind := FALSE;
       change_bound_to_temp_module (module_description^.bound_module_header^, changed_info,
             temporary_load_module^.temporary_module_header, status);

     CASEND;


   PROCEND build_temporary_load_module;
?? OLDTITLE ??
?? EJECT ??


   VAR
     nlm: ^oct$new_library_module_list,
     load_module: ^oct$load_module_list,

     temporary_load_module: ^oct$module_description,

     local_status: ost$status;


   local_status.normal := TRUE;

   nlm := nlm_list^.f_link;
   load_module := ^load_module_list;

   REPEAT
     NEXT load_module^.link IN ocv$olg_scratch_seq;
     load_module := load_module^.link;

     IF load_module = NIL THEN
       osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
       RETURN;
     IFEND;

     load_module^.name := nlm^.name;

     CASE nlm^.description^.kind OF
     = occ$cpu_object_module, occ$bound_module =
       build_temporary_load_module (nlm^.description, nlm^.changed_info, temporary_load_module, local_status);

       IF local_status.normal THEN
         load_module^.description := temporary_load_module;
         load_module^.changed_info := NIL;
       IFEND;

     = occ$ppu_object_module, occ$program_description, occ$command_procedure, occ$function_procedure,
           occ$message_module, occ$panel_module, occ$load_module, occ$applic_program_description,
           occ$applic_command_procedure, occ$applic_command_description, occ$command_description,
           occ$function_description =
       load_module^.description := nlm^.description;
       load_module^.changed_info := nlm^.changed_info;

     ELSE
       osp$set_status_abnormal (oc, oce$e_invalid_module_kind, nlm^.name, local_status);

     CASEND;

     IF NOT local_status.normal THEN
       ocp$generate_message (local_status);
       osp$set_status_abnormal (oc, oce$w_new_file_not_generated, '', status);
     IFEND;

     nlm := nlm^.f_link;

   UNTIL nlm^.name = osc$null_name;

   load_module^.link := NIL;



 PROCEND build_load_module_list;
?? OLDTITLE ??
?? NEWTITLE := '        GENERATE_TEMPORARY_LIBRARY' ??
?? EJECT ??


 PROCEDURE generate_temporary_library
   (    load_module_list: oct$load_module_list;
    VAR temporary_library: ^SEQ ( * );
    VAR status: ost$status);

?? NEWTITLE := '          SKIP_TO_PAGE_BOUNDRY' ??
?? EJECT ??

   PROCEDURE skip_to_page_boundry
     (    page_size: ost$page_size;
      VAR temporary_library: ^SEQ ( * ));


     VAR
       temp: ost$segment_length,
       valid_position: boolean,
       sequence_ptr: ost$segment_length;


     sequence_ptr := i#current_sequence_position (temporary_library);

     IF (sequence_ptr MOD page_size) <> 0 THEN
       temp := sequence_ptr + page_size;
       sequence_ptr := (temp - (temp MOD page_size));
       pmp$position_object_library (temporary_library, sequence_ptr, valid_position);
       IF NOT valid_position THEN
         osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
         RETURN;
       IFEND;
     IFEND;


   PROCEND skip_to_page_boundry;
?? OLDTITLE ??
?? NEWTITLE := '          WRITE_HEADER_AND_DICTIONARIES' ??
?? EJECT ??

   PROCEDURE write_header_and_dictionaries
     (    load_module_list: oct$load_module_list;
      VAR module_dictionary: ^llt$module_dictionary;
      VAR entry_point_dictionary: ^llt$entry_point_dictionary;
      VAR command_dictionary: ^llt$command_dictionary;
      VAR function_dictionary: ^llt$function_dictionary;
      VAR help_module_dictionary: ^llt$help_module_dictionary;
      VAR message_module_dictionary: ^llt$message_module_dictionary;
      VAR panel_dictionary: ^llt$panel_dictionary;
      VAR new_library: ^SEQ ( * );
      VAR status: ost$status);

?? NEWTITLE := '            OBTAIN_DICTIONARY_SIZES' ??
?? EJECT ??

{ NOTE:
{   Only save the current_segment_number and current_offset for those records
{ that require the module description to be referenced.

     PROCEDURE obtain_dictionary_sizes
       (    module_description: ^oct$module_description;
            changed_info: ^oct$changed_info;
        VAR dictionary_sizes: dictionary_size_info;
        VAR status: ost$status);


       VAR
         next_entry_point: ^oct$external_declaration_list,

         library: ^SEQ ( * ),
         library_member_header: ^llt$library_member_header,
         message_template_module: ^ost$message_template_module,

         natural_language: ost$natural_language,
         online_manual_name: ost$online_manual_name,
         help_module: boolean,
         message_module: boolean,
         lowest_message_code: ost$status_condition_code,
         highest_message_code: ost$status_condition_code,

         object_text_descriptor: ^llt$object_text_descriptor,
         transfer_symbol: ^llt$transfer_symbol,
         entry_definition: ^llt$entry_definition;

       library := temporary_library;


       IF (changed_info <> NIL) AND (changed_info^.entry_points <> NIL) THEN

         next_entry_point := changed_info^.entry_points;

         REPEAT
           IF next_entry_point^.name <> osc$null_name THEN
             CASE module_description^.kind OF

             = occ$load_module, occ$temporary_load_module =
               dictionary_sizes.number_of_entry_points := dictionary_sizes.number_of_entry_points + 1;

             = occ$program_description, occ$command_procedure, occ$applic_program_description,
                   occ$applic_command_procedure, occ$applic_command_description, occ$command_description =
               dictionary_sizes.number_of_commands := dictionary_sizes.number_of_commands + 1;

             = occ$function_procedure, occ$function_description =
               dictionary_sizes.number_of_functions := dictionary_sizes.number_of_functions + 1;

             ELSE

             CASEND;
           IFEND;

           next_entry_point := next_entry_point^.link;
         UNTIL next_entry_point = NIL;

         IF changed_info^.starting_procedure <> osc$null_name THEN
           dictionary_sizes.number_of_commands := dictionary_sizes.number_of_commands + 1;
         IFEND;

         CASE module_description^.kind OF

         = occ$load_module, occ$temporary_load_module =

         = occ$program_description, occ$command_procedure, occ$applic_program_description,
               occ$applic_command_procedure, occ$applic_command_description, occ$command_description =
           dictionary_sizes.number_of_commands := dictionary_sizes.number_of_commands + 1;

         = occ$function_procedure, occ$function_description =
           dictionary_sizes.number_of_functions := dictionary_sizes.number_of_functions + 1;

         CASEND;

       ELSE

         CASE module_description^.kind OF

         = occ$temporary_load_module =

           IF module_description^.temporary_module_header^.starting_procedure <> osc$null_name THEN
             dictionary_sizes.number_of_commands := dictionary_sizes.number_of_commands + 1;
           IFEND;

           dictionary_sizes.number_of_entry_points := dictionary_sizes.number_of_entry_points +
                 module_description^.temporary_module_header^.number_of_entry_definitions;
           current_segment_number := #SEGMENT (module_description^.temporary_module_header);
           current_offset := #OFFSET (module_description^.temporary_module_header);

         = occ$load_module =

           IF (llc$interpretive_element IN module_description^.load_module_header^.elements_defined) AND
                 (llc$transfer_symbol_element IN module_description^.load_module_header^.interpretive_header.
                 elements_defined) THEN

             object_text_descriptor := #PTR (module_description^.load_module_header^.interpretive_header.
                   transfer_symbol, module_description^.file^);
             IF object_text_descriptor = NIL THEN
               osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
               RETURN;
             IFEND;

             RESET module_description^.file TO object_text_descriptor;
             NEXT object_text_descriptor IN module_description^.file;
             NEXT transfer_symbol IN module_description^.file;
             IF transfer_symbol^.name <> osc$null_name THEN
               dictionary_sizes.number_of_commands := dictionary_sizes.number_of_commands + 1;
             IFEND;

           IFEND;

           IF llc$entry_point_element IN module_description^.load_module_header^.interpretive_header.
                 elements_defined THEN
             object_text_descriptor := #PTR (module_description^.load_module_header^.interpretive_header.
                   entry_points, module_description^.file^);
             IF object_text_descriptor = NIL THEN
               osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name, status);
               RETURN;
             IFEND;

             IF object_text_descriptor^.kind = llc$entry_definition THEN
               RESET module_description^.file TO object_text_descriptor;
               NEXT object_text_descriptor IN module_description^.file;

               REPEAT
                 NEXT entry_definition IN module_description^.file;
                 IF entry_definition = NIL THEN
                   osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name,
                         status);
                   RETURN;
                 IFEND;

                 dictionary_sizes.number_of_entry_points := dictionary_sizes.number_of_entry_points + 1;

                 NEXT object_text_descriptor IN module_description^.file;
                 IF object_text_descriptor = NIL THEN
                   osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description^.name,
                         status);
                   RETURN;
                 IFEND;

               UNTIL object_text_descriptor^.kind <> llc$entry_definition;
             IFEND;
           IFEND;
           current_segment_number := #SEGMENT (module_description^.load_module_header);
           current_offset := #OFFSET (module_description^.load_module_header);

         = occ$program_description =
           dictionary_sizes.number_of_commands := dictionary_sizes.number_of_commands +
                 module_description^.program_description_header^.number_of_aliases + 1;
           current_segment_number := #SEGMENT (module_description^.program_description_header);
           current_offset := #OFFSET (module_description^.program_description_header);

         = occ$command_procedure =
           dictionary_sizes.number_of_commands := dictionary_sizes.number_of_commands +
                 module_description^.command_procedure_header^.number_of_aliases + 1;
           current_segment_number := #SEGMENT (module_description^.command_procedure_header);
           current_offset := #OFFSET (module_description^.command_procedure_header);

         = occ$command_description =
           dictionary_sizes.number_of_commands := dictionary_sizes.number_of_commands +
                 module_description^.command_description_header^.number_of_aliases + 1;
           current_segment_number := #SEGMENT (module_description^.command_description_header);
           current_offset := #OFFSET (module_description^.command_description_header);

         = occ$applic_program_description =
           dictionary_sizes.number_of_commands := dictionary_sizes.number_of_commands +
                 module_description^.applic_program_description_hdr^.library_member_header.number_of_aliases +
                 1;
           current_segment_number := #SEGMENT (module_description^.applic_program_description_hdr);
           current_offset := #OFFSET (module_description^.applic_program_description_hdr);

         = occ$applic_command_procedure =
           dictionary_sizes.number_of_commands := dictionary_sizes.number_of_commands +
                 module_description^.applic_command_procedure_header^.library_member_header.
                 number_of_aliases + 1;
           current_segment_number := #SEGMENT (module_description^.applic_command_procedure_header);
           current_offset := #OFFSET (module_description^.applic_command_procedure_header);

         = occ$applic_command_description =
           dictionary_sizes.number_of_commands := dictionary_sizes.number_of_commands +
                 module_description^.applic_command_description_hdr^.library_member_header.number_of_aliases +
                 1;
           current_segment_number := #SEGMENT (module_description^.applic_command_description_hdr);
           current_offset := #OFFSET (module_description^.applic_command_description_hdr);

         = occ$function_procedure =
           dictionary_sizes.number_of_functions := dictionary_sizes.number_of_functions +
                 module_description^.function_procedure_header^.number_of_aliases + 1;
           current_segment_number := #SEGMENT (module_description^.function_procedure_header);
           current_offset := #OFFSET (module_description^.function_procedure_header);

         = occ$function_description =
           dictionary_sizes.number_of_functions := dictionary_sizes.number_of_functions +
                 module_description^.function_description_header^.number_of_aliases + 1;
           current_segment_number := #SEGMENT (module_description^.function_description_header);
           current_offset := #OFFSET (module_description^.function_description_header);

         = occ$message_module =

           library_member_header := module_description^.message_module_header;
           RESET module_description^.file TO library_member_header;
           message_template_module := #PTR (library_member_header^.member, module_description^.file^);

           RESET message_template_module;
           clp$get_message_module_info (message_template_module, natural_language, online_manual_name,
                 help_module, message_module, lowest_message_code, highest_message_code, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;

           IF message_module THEN
             dictionary_sizes.number_of_message_modules := dictionary_sizes.number_of_message_modules + 1;
           IFEND;

           IF help_module THEN
             dictionary_sizes.number_of_help_modules := dictionary_sizes.number_of_help_modules + 1;
           IFEND;
           current_segment_number := #SEGMENT (module_description^.message_module_header);
           current_offset := #OFFSET (module_description^.message_module_header);

         = occ$panel_module =
           dictionary_sizes.number_of_panels := dictionary_sizes.number_of_panels + 1;

         = occ$ppu_object_module =

{ No entry points

         CASEND;

       IFEND;


     PROCEND obtain_dictionary_sizes;
?? OLDTITLE ??
?? EJECT ??

{ The value for prestreaming_transfer_size is chosen with the understanding that
{ access to the library members is not quite sequential (in the typical case).
{ Access is from low address to high address, but oftentimes several pages are
{ skipped due to large modules.  Streaming is useful if the library contains
{ small modules, program descriptions, small SCL procedures or the like.
{ So, very little read ahead is done because it is unknown if the next module
{ is small or large.

     CONST
       prestreaming_transfer_size = 16384;

{ Indicates the number of library members that will be accessed before pages in
{ memory are flushed out of the working set.  This number should be chosen with
{ the understanding that each library member may cross a page boundary and thus
{ the number of pages in the working set may be double this value.

     CONST
       advise_out_limit = 50;

     TYPE
       dictionary_size_info = record
         number_of_modules: integer,
         number_of_entry_points: integer,
         number_of_commands: integer,
         number_of_functions: integer,
         number_of_help_modules: integer,
         number_of_message_modules: integer,
         number_of_panels: integer,
       recend;

     VAR
       advise_out_count: 0 .. advise_out_limit,
       current_offset: ost$segment_length,
       current_segment_number: ost$segment,
       last_offset: ost$segment_length,
       last_segment_number: ost$segment,
       page_size: ost$page_size,
       save_free_behind: boolean,
       save_transfer_size: 0 .. 15,
       ignore_status: ost$status,
       pva_p: ^cell,

       load_module: ^oct$load_module_list,

       number_of_dictionaries: 0 .. llc$max_dictionaries_on_library,
       i: 0 .. llc$max_dictionaries_on_library,
       dictionary_sizes: dictionary_size_info,

       object_library_header: ^llt$object_library_header,
       object_library_dictionaries: ^llt$object_library_dictionaries;

     number_of_dictionaries := 0;
     dictionary_sizes.number_of_modules := 0;
     dictionary_sizes.number_of_entry_points := 0;
     dictionary_sizes.number_of_commands := 0;
     dictionary_sizes.number_of_functions := 0;
     dictionary_sizes.number_of_help_modules := 0;
     dictionary_sizes.number_of_message_modules := 0;
     dictionary_sizes.number_of_panels := 0;

     load_module := load_module_list.link;

     last_segment_number := 0;
     current_segment_number := 0;
     pva_p := ^current_segment_number;

     pmp$get_page_size (page_size, ignore_status);
     current_offset := 0;
     last_offset := 0;
     advise_out_count := 0;

     REPEAT

{ IMPORTANT:
{   The procedure obtain_dictionary_sizes changes the values of the variables
{   current_segment_number and current_offset.

{ If the segment number has changed, reset the segment attributes on the old
{ segment to what they were and set the segment attributes on the new segment
{ for sequential access and free-behind.  The expected case is for the name
{ list to be ordered for sequential access on a file.  This happens if ADDM is
{ called with just a library or a library and a range of module names.  These
{ are two of the three typical cases.  The third case is an ADDM of just one
{ or two modules.  Additional overhead will occur in this case, but typically
{ only once per file.  A very degenerative case would be for a library to be in
{ reverse alphabetical order and then have ADDM requests done in alphabetical
{ order.  This would cause access to the segment to be backwards, so free behind
{ and sequential access would be ignored.  This case is not typical, so it will
{ be ignored.

       IF current_segment_number <> last_segment_number THEN
         IF last_segment_number <> 0 THEN
           pva_p := #ADDRESS (#RING (pva_p), last_segment_number, 0);
           mmp$preset_page_streaming ({preset_and_save_ts_fb} FALSE, pva_p, prestreaming_transfer_size,
                 save_transfer_size, save_free_behind, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;
         IFEND;
         pva_p := #ADDRESS (#RING (pva_p), current_segment_number, 0);
         mmp$preset_page_streaming ({preset_and_save_ts_fb} TRUE, pva_p, prestreaming_transfer_size,
               save_transfer_size, save_free_behind, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;
         last_segment_number := current_segment_number;

{ Let page and cyclic aging remove the pages from the working set.  True sequential
{ access has not been achieved.

         current_offset := (current_offset DIV page_size) * page_size;
         last_offset := current_offset;
         advise_out_count := 0;
       IFEND;

{ Free-behind only works well if the pages in the file are accessed sequentially
{ one after the other, without skipping pages.  Since this is not the case here,
{ memory management must be notified that pages must be removed from the working
{ set.  After examining the module headers for advise_out_limit modules, the pages
{ between the last saved segment offset and the current offset (minus one) are
{ forced out of the working set by call mmp$advise_out.  This significantly
{ reduces the cost of aging the working set.

       IF advise_out_count = advise_out_limit THEN

{ Round down to nearest page size.

         current_offset := (current_offset DIV page_size) * page_size;
         IF last_offset < current_offset THEN
           pva_p := #ADDRESS (#RING (pva_p), current_segment_number, last_offset);
           mmp$advise_out (pva_p, current_offset - last_offset, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;
           last_offset := current_offset;
         IFEND;
         advise_out_count := 0;
       ELSE
         advise_out_count := advise_out_count + 1;
       IFEND;

       dictionary_sizes.number_of_modules := dictionary_sizes.number_of_modules + 1;

       obtain_dictionary_sizes (load_module^.description, load_module^.changed_info, dictionary_sizes,
             status);
       IF NOT status.normal THEN
         RETURN;
       IFEND;

       load_module := load_module^.link;

     UNTIL load_module = NIL;

     IF last_segment_number <> 0 THEN
       pva_p := #ADDRESS (#RING (pva_p), last_segment_number, 0);
       mmp$preset_page_streaming ({preset_and_save_ts_fb} FALSE, pva_p, prestreaming_transfer_size,
             save_transfer_size, save_free_behind, status);
       IF NOT status.normal THEN
         RETURN;
       IFEND;
     IFEND;

     IF dictionary_sizes.number_of_modules > 0 THEN
       number_of_dictionaries := number_of_dictionaries + 1;
     IFEND;

     IF dictionary_sizes.number_of_entry_points > 0 THEN
       number_of_dictionaries := number_of_dictionaries + 1;
     IFEND;

     IF dictionary_sizes.number_of_commands > 0 THEN
       number_of_dictionaries := number_of_dictionaries + 1;
     IFEND;

     IF dictionary_sizes.number_of_functions > 0 THEN
       number_of_dictionaries := number_of_dictionaries + 1;
     IFEND;

     IF dictionary_sizes.number_of_help_modules > 0 THEN
       number_of_dictionaries := number_of_dictionaries + 1;
     IFEND;

     IF dictionary_sizes.number_of_message_modules > 0 THEN
       number_of_dictionaries := number_of_dictionaries + 1;
     IFEND;

     IF dictionary_sizes.number_of_panels > 0 THEN
       number_of_dictionaries := number_of_dictionaries + 1;
     IFEND;

     NEXT object_library_header IN new_library;
     IF object_library_header = NIL THEN
       osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
       RETURN;
     IFEND;

     object_library_header^.version := llc$object_library_version;
     object_library_header^.number_of_dictionaries := number_of_dictionaries;

     NEXT object_library_dictionaries: [1 .. number_of_dictionaries] IN new_library;
     IF object_library_dictionaries = NIL THEN
       osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
       RETURN;
     IFEND;

     i := 1;

     IF dictionary_sizes.number_of_modules > 0 THEN
       IF dictionary_sizes.number_of_modules > llc$max_modules_in_library THEN
         osp$set_status_abnormal (oc, oce$e_too_many_modules_on_lib, '', status);
         RETURN;
       IFEND;
       NEXT module_dictionary: [1 .. dictionary_sizes.number_of_modules] IN new_library;
       IF module_dictionary = NIL THEN
         osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
         RETURN;
       IFEND;
       object_library_dictionaries^ [i].kind := llc$module_dictionary;
       object_library_dictionaries^ [i].module_dictionary := #REL (module_dictionary, new_library^);
       i := i + 1;
     ELSE
       module_dictionary := NIL;
     IFEND;

     IF dictionary_sizes.number_of_entry_points > 0 THEN
       IF dictionary_sizes.number_of_entry_points > llc$max_entry_points_in_library THEN
         osp$set_status_abnormal (oc, oce$e_too_many_entry_points, '', status);
         RETURN;
       IFEND;
       NEXT entry_point_dictionary: [1 .. dictionary_sizes.number_of_entry_points] IN new_library;
       IF entry_point_dictionary = NIL THEN
         osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
         RETURN;
       IFEND;
       object_library_dictionaries^ [i].kind := llc$entry_point_dictionary;
       object_library_dictionaries^ [i].entry_point_dictionary := #REL (entry_point_dictionary, new_library^);
       i := i + 1;
     ELSE
       entry_point_dictionary := NIL;
     IFEND;

     IF dictionary_sizes.number_of_commands > 0 THEN
       IF dictionary_sizes.number_of_commands > llc$max_commands_in_library THEN
         osp$set_status_abnormal (oc, oce$e_too_many_commands_on_lib, '', status);
         RETURN;
       IFEND;
       NEXT command_dictionary: [1 .. dictionary_sizes.number_of_commands] IN new_library;
       IF command_dictionary = NIL THEN
         osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
         RETURN;
       IFEND;
       object_library_dictionaries^ [i].kind := llc$command_dictionary;
       object_library_dictionaries^ [i].command_dictionary := #REL (command_dictionary, new_library^);
       i := i + 1;
     ELSE
       command_dictionary := NIL;
     IFEND;

     IF dictionary_sizes.number_of_functions > 0 THEN
       IF dictionary_sizes.number_of_functions > llc$max_functions_in_library THEN
         osp$set_status_abnormal (oc, oce$e_too_many_functions_on_lib, '', status);
         RETURN;
       IFEND;
       NEXT function_dictionary: [1 .. dictionary_sizes.number_of_functions] IN new_library;
       IF function_dictionary = NIL THEN
         osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
         RETURN;
       IFEND;
       object_library_dictionaries^ [i].kind := llc$function_dictionary;
       object_library_dictionaries^ [i].function_dictionary := #REL (function_dictionary, new_library^);
       i := i + 1;
     ELSE
       function_dictionary := NIL;
     IFEND;

     IF dictionary_sizes.number_of_help_modules > 0 THEN
       IF dictionary_sizes.number_of_help_modules > llc$max_help_modules_in_library THEN
         osp$set_status_abnormal (oc, oce$e_too_many_help_mods_on_lib, '', status);
         RETURN;
       IFEND;
       NEXT help_module_dictionary: [1 .. dictionary_sizes.number_of_help_modules] IN new_library;
       IF help_module_dictionary = NIL THEN
         osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
         RETURN;
       IFEND;
       object_library_dictionaries^ [i].kind := llc$help_module_dictionary;
       object_library_dictionaries^ [i].help_module_dictionary := #REL (help_module_dictionary, new_library^);
       i := i + 1;
     ELSE
       help_module_dictionary := NIL;
     IFEND;

     IF dictionary_sizes.number_of_message_modules > 0 THEN
       IF dictionary_sizes.number_of_message_modules > llc$max_message_modules_in_lib THEN
         osp$set_status_abnormal (oc, oce$e_too_many_msg_mods_on_lib, '', status);
         RETURN;
       IFEND;
       NEXT message_module_dictionary: [1 .. dictionary_sizes.number_of_message_modules] IN new_library;
       IF message_module_dictionary = NIL THEN
         osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
         RETURN;
       IFEND;
       object_library_dictionaries^ [i].kind := llc$message_module_dictionary;
       object_library_dictionaries^ [i].message_module_dictionary :=
             #REL (message_module_dictionary, new_library^);
       i := i + 1;
     ELSE
       message_module_dictionary := NIL;
     IFEND;

     IF dictionary_sizes.number_of_panels > 0 THEN
       IF dictionary_sizes.number_of_panels > llc$max_panels_in_library THEN
         osp$set_status_abnormal (oc, oce$e_too_many_panels_on_lib, '', status);
         RETURN;
       IFEND;
       NEXT panel_dictionary: [1 .. dictionary_sizes.number_of_panels] IN new_library;
       IF panel_dictionary = NIL THEN
         osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
         RETURN;
       IFEND;
       object_library_dictionaries^ [i].kind := llc$panel_dictionary;
       object_library_dictionaries^ [i].panel_dictionary := #REL (panel_dictionary, new_library^);
     ELSE
       panel_dictionary := NIL;
     IFEND;

   PROCEND write_header_and_dictionaries;
?? OLDTITLE ??
?? NEWTITLE := '          COMPUTE_SECTION_LENGTH' ??
?? EJECT ??

   PROCEDURE compute_section_length
     (    for_code_sections: boolean;
          load_module_list: oct$load_module_list;
      VAR temporary_library: ^SEQ ( * );
      VAR section_length: ost$segment_length;
      VAR status: ost$status);

?? NEWTITLE := '            ADD_TO_SECTION_LENGTH' ??
?? EJECT ??

     PROCEDURE add_to_section_length
       (    allocation_alignment: ost$segment_offset;
            allocation_offset: ost$segment_offset;
            section_length: ost$segment_length;
        VAR offset: ost$segment_length);



       WHILE allocation_offset <> (offset MOD allocation_alignment) DO
         offset := offset + 1;
       WHILEND;

       offset := offset + section_length;


     PROCEND add_to_section_length;
?? OLDTITLE ??
?? NEWTITLE := '            COMPUTE_LOAD_MODULE_SEC_LENGTH' ??
?? EJECT ??

     PROCEDURE compute_load_module_sec_length
       (    for_code_sections: boolean;
            description: ^oct$module_description;
        VAR section_length: ost$segment_length;
        VAR status: ost$status);



       VAR
         section_definition: ^llt$section_definition,
         segment_definition: ^llt$segment_definition,
         obsolete_segment_definition: ^llt$obsolete_segment_definition,

         load_module_header: ^llt$load_module_header,

         object_text_descriptor: ^llt$object_text_descriptor,
         length: ost$segment_length;


       IF (llc$section_element IN description^.load_module_header^.interpretive_header.elements_defined) THEN

         object_text_descriptor := #PTR (description^.load_module_header^.interpretive_header.
               section_definitions, description^.file^);
         IF object_text_descriptor = NIL THEN
           osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, description^.name, status);
           RETURN;
         IFEND;

         RESET description^.file TO object_text_descriptor;
         NEXT object_text_descriptor IN description^.file;

         WHILE (object_text_descriptor^.kind = llc$segment_definition) OR
               (object_text_descriptor^.kind = llc$allotted_segment_definition) DO

           NEXT segment_definition IN description^.file;
           IF segment_definition = NIL THEN
             osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, description^.name, status);
             RETURN;
           IFEND;

           IF object_text_descriptor^.kind = llc$allotted_segment_definition THEN
             section_definition := ^segment_definition^.section_definition;

             IF (object_text_descriptor^.allotted_segment_length <> 0) THEN
               length := object_text_descriptor^.allotted_segment_length;
             ELSE
               length := section_definition^.length;
             IFEND;

             IF length <> 0 THEN
               IF ((for_code_sections) AND (section_definition^.kind = llc$code_section)) OR
                     ((NOT for_code_sections) AND (section_definition^.kind <> llc$code_section)) THEN
                 add_to_section_length (section_definition^.allocation_alignment,
                       section_definition^.allocation_offset, length, section_length);
               IFEND;
             IFEND;
           IFEND;

           NEXT object_text_descriptor IN description^.file;
           IF object_text_descriptor = NIL THEN
             osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, description^.name, status);
             RETURN;
           IFEND;

         WHILEND;

         WHILE (object_text_descriptor^.kind = llc$obsolete_segment_definition) OR
               (object_text_descriptor^.kind = llc$obsolete_allotted_seg_def) DO

           NEXT obsolete_segment_definition IN description^.file;
           IF obsolete_segment_definition = NIL THEN
             osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, description^.name, status);
             RETURN;
           IFEND;

           IF object_text_descriptor^.kind = llc$obsolete_allotted_seg_def THEN
             section_definition := ^obsolete_segment_definition^.section_definition;

             IF (object_text_descriptor^.allotted_segment_length <> 0) THEN
               length := object_text_descriptor^.allotted_segment_length;
             ELSE
               length := section_definition^.length;
             IFEND;

             IF length <> 0 THEN
               IF ((for_code_sections) AND (section_definition^.kind = llc$code_section)) OR
                     ((NOT for_code_sections) AND (section_definition^.kind <> llc$code_section)) THEN
                 add_to_section_length (section_definition^.allocation_alignment,
                       section_definition^.allocation_offset, length, section_length);
               IFEND;
             IFEND;
           IFEND;

           NEXT object_text_descriptor IN description^.file;
           IF object_text_descriptor = NIL THEN
             osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, description^.name, status);
             RETURN;
           IFEND;

         WHILEND;

         WHILE (object_text_descriptor^.kind = llc$section_definition) OR
               (object_text_descriptor^.kind = llc$allotted_section_definition) OR
               (object_text_descriptor^.kind = llc$unallocated_common_block) DO
           NEXT section_definition IN description^.file;
           IF section_definition = NIL THEN
             osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, description^.name, status);
             RETURN;
           IFEND;

           IF object_text_descriptor^.kind = llc$allotted_section_definition THEN
             IF section_definition^.length <> 0 THEN
               IF ((for_code_sections) AND (section_definition^.kind = llc$code_section)) OR
                     ((NOT for_code_sections) AND (section_definition^.kind <> llc$code_section)) THEN
                 add_to_section_length (section_definition^.allocation_alignment,
                       section_definition^.allocation_offset, section_definition^.length, section_length);
               IFEND;
             IFEND;
           IFEND;

           NEXT object_text_descriptor IN description^.file;
           IF object_text_descriptor = NIL THEN
             osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, description^.name, status);
             RETURN;
           IFEND;

         WHILEND;
       IFEND;


     PROCEND compute_load_module_sec_length;
?? OLDTITLE ??
?? NEWTITLE := '            WRITE_TEMP_MODULE_CODE_SECTION' ??
?? EJECT ??

     PROCEDURE compute_temp_module_sec_length
       (    for_code_sections: boolean;
            description: ^oct$module_description;
        VAR section_length: ost$segment_length;
        VAR status: ost$status);


       VAR
         section_definition: llt$section_definition,
         section_definitions: ^oct$section_definition_list,
         length: ost$segment_length;


       section_definitions := description^.temporary_module_header^.section_definitions.link;

       WHILE section_definitions <> NIL DO
         IF section_definitions^.allotted_section THEN
           section_definition := section_definitions^.section_definition;

           IF (section_definitions^.allotted_section_length <> 0) THEN
             length := section_definitions^.allotted_section_length;
           ELSE
             length := section_definition.length;
           IFEND;

           IF length <> 0 THEN
             IF ((for_code_sections) AND (section_definition.kind = llc$code_section)) OR
                   ((NOT for_code_sections) AND (section_definition.kind <> llc$code_section)) THEN
               add_to_section_length (section_definition.allocation_alignment,
                     section_definition.allocation_offset, length, section_length);
             IFEND;
           IFEND;
         IFEND;

         section_definitions := section_definitions^.link;
       WHILEND;



     PROCEND compute_temp_module_sec_length;
?? OLDTITLE ??
?? EJECT ??


     VAR
       seq_pointer: ost$segment_length,
       offset: ost$segment_length,
       load_module: ^oct$load_module_list;


     offset := i#current_sequence_position (temporary_library);
     seq_pointer := offset;


     load_module := load_module_list.link;

     REPEAT

       CASE load_module^.description^.kind OF
       = occ$ppu_object_module, occ$program_description, occ$command_procedure, occ$function_procedure,
             occ$message_module, occ$panel_module, occ$applic_program_description,
             occ$applic_command_procedure, occ$applic_command_description, occ$command_description,
             occ$function_description =

{ N/A

       = occ$load_module =
         compute_load_module_sec_length (for_code_sections, load_module^.description, offset, status);

       = occ$temporary_load_module =
         compute_temp_module_sec_length (for_code_sections, load_module^.description, offset, status);

       CASEND;

       load_module := load_module^.link;

     UNTIL load_module = NIL;


     section_length := offset - seq_pointer;


   PROCEND compute_section_length;
?? OLDTITLE ??
?? NEWTITLE := '          WRITE_HEADER_INTERPRETIVE_INFO' ??
?? EJECT ??

   PROCEDURE write_header_interpretive_info
     (    load_module_list: oct$load_module_list;
      VAR temporary_library: ^SEQ ( * );
      VAR module_dictionary: ^llt$module_dictionary;
      VAR entry_point_dictionary: ^llt$entry_point_dictionary;
      VAR command_dictionary: ^llt$command_dictionary;
      VAR function_dictionary: ^llt$function_dictionary;
      VAR help_module_dictionary: ^llt$help_module_dictionary;
      VAR message_module_dictionary: ^llt$message_module_dictionary;
      VAR panel_dictionary: ^llt$panel_dictionary;
      VAR code_section: ^cell;
      VAR read_section: ^cell;
      VAR status: ost$status);

?? NEWTITLE := '            ADD_TO_ENTRY_POINT_DICTIONARY' ??
?? EJECT ??

     PROCEDURE add_to_entry_point_dictionary
       (    module_dictionary_item: llt$module_dictionary_item;
            temporary_library: ^SEQ ( * );
        VAR next_entry_point: llt$entry_point_index;
        VAR entry_point_dictionary: ^llt$entry_point_dictionary);

?? NEWTITLE := '              ADD_ENTRY_POINT', EJECT ??

       PROCEDURE add_entry_point
         (    entry_point_item: llt$entry_point_dictionary_item);


         VAR
           entry_point_found: boolean,
           hi: llt$entry_point_index,
           i: llt$entry_point_index,
           insert: llt$entry_point_index,
           lo: llt$entry_point_index,
           local_status: ost$status,
           temp: integer,
           mid: llt$entry_point_index;

         hi := next_entry_point;
         entry_point_found := FALSE;
         lo := 1;

         WHILE (lo <= hi) AND NOT entry_point_found DO
           temp := lo + hi;
           mid := temp DIV 2;
           IF entry_point_item.name = entry_point_dictionary^ [mid].name THEN
             entry_point_found := TRUE;
           ELSEIF entry_point_item.name < entry_point_dictionary^ [mid].name THEN
             hi := mid - 1;
           ELSE
             lo := mid + 1;
           IFEND;
         WHILEND;

         IF entry_point_found THEN
           insert := mid;
         ELSE
           insert := lo;
         IFEND;

         IF entry_point_found AND ((entry_point_dictionary^ [insert].module_kind <> llc$load_module) OR
               (entry_point_item.module_kind <> llc$load_module)) THEN
           osp$set_status_abnormal (oc, oce$w_dup_ent_pnt_on_lib, entry_point_item.name, local_status);
           ocp$generate_message (local_status);
           osp$set_status_abnormal (oc, oce$w_non_fatal_generate_error, '', command_status);
         IFEND;

         next_entry_point := next_entry_point + 1;

         FOR i := (next_entry_point - 1) DOWNTO insert DO
           entry_point_dictionary^ [i + 1] := entry_point_dictionary^ [i];
         FOREND;

         entry_point_dictionary^ [insert] := entry_point_item;

       PROCEND add_entry_point;
?? OLDTITLE ??
?? EJECT ??


       VAR
         library: ^SEQ ( * ),

         load_module_header: ^llt$load_module_header,
         object_text_descriptor: ^llt$object_text_descriptor,
         entry_definition: ^llt$entry_definition,
         entry_point_item: llt$entry_point_dictionary_item;


       library := temporary_library;

       load_module_header := #PTR (module_dictionary_item.module_header, library^);

       IF llc$entry_point_element IN load_module_header^.interpretive_header.elements_defined THEN
         object_text_descriptor := #PTR (load_module_header^.interpretive_header.entry_points, library^);

         RESET library TO object_text_descriptor;
         NEXT object_text_descriptor IN library;

         IF object_text_descriptor^.kind = llc$entry_definition THEN
           REPEAT
             NEXT entry_definition IN library;

             entry_point_item.name := entry_definition^.name;

             IF llc$gated_entry_point IN entry_definition^.attributes THEN
               entry_point_item.kind := llc$gate;
             ELSE
               entry_point_item.kind := llc$entry_point;
             IFEND;

             entry_point_item.module_kind := llc$load_module;
             entry_point_item.module_header := module_dictionary_item.module_header;
             add_entry_point (entry_point_item);

             NEXT object_text_descriptor IN library;

           UNTIL object_text_descriptor^.kind <> llc$entry_definition;
         IFEND;
       IFEND;


     PROCEND add_to_entry_point_dictionary;
?? OLDTITLE ??
?? NEWTITLE := '            ADD_TO_COMMAND_DICTIONARY' ??
?? EJECT ??

     PROCEDURE add_to_command_dictionary
       (    module_dictionary_item: llt$module_dictionary_item;
            temporary_library: ^SEQ ( * );
        VAR next_command: llt$command_index;
        VAR command_dictionary: ^llt$command_dictionary);

?? NEWTITLE := '              ADD_COMMAND', EJECT ??

       PROCEDURE add_command
         (    command_item: llt$command_dictionary_item);


         VAR
           i: llt$command_index,
           local_status: ost$status;


         FOR i := 1 TO next_command DO
           IF command_dictionary^ [i].name = command_item.name THEN
             IF (command_dictionary^ [i].module_kind <> llc$load_module) OR
                   (command_item.module_kind <> llc$load_module) THEN
               osp$set_status_abnormal (oc, oce$w_dup_commands_on_lib, command_item.name, local_status);
               ocp$generate_message (local_status);
               osp$set_status_abnormal (oc, oce$w_non_fatal_generate_error, '', command_status);
             IFEND;
           IFEND;
         FOREND;


         next_command := next_command + 1;

         command_dictionary^ [next_command] := command_item;


       PROCEND add_command;
?? OLDTITLE ??
?? EJECT ??


       VAR
         library: ^SEQ ( * ),

         application_member_header: ^llt$application_member_header,
         library_member_header: ^llt$library_member_header,
         alias_list: ^pmt$module_list,
         i: llt$number_of_aliases,
         entry_definition: ^llt$entry_definition,
         load_module_header: ^llt$load_module_header,
         transfer_symbol: ^llt$transfer_symbol,
         object_text_descriptor: ^llt$object_text_descriptor,
         command_item: llt$command_dictionary_item;


       library := temporary_library;

       CASE module_dictionary_item.kind OF

       = llc$load_module =

         load_module_header := #PTR (module_dictionary_item.module_header, library^);

         IF (llc$interpretive_element IN load_module_header^.elements_defined) AND
               (llc$transfer_symbol_element IN load_module_header^.interpretive_header.elements_defined) THEN

           object_text_descriptor := #PTR (load_module_header^.interpretive_header.transfer_symbol, library^);
           IF object_text_descriptor = NIL THEN
             osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, '', status);
             RETURN;
           IFEND;

           RESET library TO object_text_descriptor;
           NEXT object_text_descriptor IN library;
           NEXT transfer_symbol IN library;
           IF transfer_symbol^.name <> osc$null_name THEN

{ Find the entry point definition record for the transfer symbol.

             IF llc$entry_point_element IN load_module_header^.interpretive_header.elements_defined THEN
               object_text_descriptor := #PTR (load_module_header^.interpretive_header.entry_points,
                     library^);
               RESET library TO object_text_descriptor;
               NEXT object_text_descriptor IN library;

{ If object_text_descriptor or entry_definition is NIL, we would have discovered it earlier.

             /find_entry_point/
               BEGIN
                 REPEAT
                   NEXT entry_definition IN library;
                   IF entry_definition^.name = transfer_symbol^.name THEN
                     IF llc$gated_entry_point IN entry_definition^.attributes THEN
                       command_item.kind := llc$gate;
                     ELSE
                       command_item.kind := llc$entry_point;
                     IFEND;
                     EXIT /find_entry_point/;
                   IFEND;
                   NEXT object_text_descriptor IN library;
                 UNTIL object_text_descriptor^.kind <> llc$entry_definition;

{ We didn't find an entry point record to match the transfer symbol; could be an error,
{ could be C code.  Assume the worst, that it's C.

                 command_item.kind := llc$entry_point;
               END /find_entry_point/;
             ELSE

{ No entry point element was found. Again, this could be an error or it could be C.

               command_item.kind := llc$entry_point;

             IFEND;

             command_item.name := transfer_symbol^.name;
             command_item.class := clc$nominal_entry;
             command_item.availability := clc$advertised_entry;
             command_item.ordinal := load_module_header^.module_index;
             command_item.log_option := clc$automatically_log;
             command_item.module_kind := llc$load_module;
             command_item.module_header := module_dictionary_item.module_header;

             add_command (command_item);

           IFEND;

         IFEND;

       = llc$program_description =

         library_member_header := #PTR (module_dictionary_item.program_header, library^);

         command_item.name := module_dictionary_item.name;
         command_item.class := clc$nominal_entry;
         command_item.availability := library_member_header^.command_function_availability;
         command_item.ordinal := library_member_header^.module_index;
         command_item.kind := library_member_header^.command_function_kind;
         command_item.log_option := library_member_header^.command_log_option;
         command_item.module_kind := llc$program_description;
         command_item.program_header := module_dictionary_item.program_header;

         add_command (command_item);

         IF library_member_header^.number_of_aliases <> 0 THEN
           alias_list := #PTR (library_member_header^.aliases, library^);
           FOR i := 1 TO library_member_header^.number_of_aliases DO
             command_item.name := alias_list^ [i];
             IF i = library_member_header^.number_of_aliases THEN
               command_item.class := clc$abbreviation_entry;
             ELSE
               command_item.class := clc$alias_entry;
             IFEND;
             add_command (command_item);
           FOREND;
         IFEND;

       = llc$command_procedure =

         library_member_header := #PTR (module_dictionary_item.command_header, library^);

         command_item.name := module_dictionary_item.name;
         command_item.class := clc$nominal_entry;
         command_item.availability := library_member_header^.command_function_availability;
         command_item.ordinal := library_member_header^.module_index;
         command_item.kind := library_member_header^.command_function_kind;
         command_item.log_option := library_member_header^.command_log_option;
         command_item.module_kind := llc$command_procedure;
         command_item.command_header := module_dictionary_item.command_header;

         add_command (command_item);

         IF library_member_header^.number_of_aliases <> 0 THEN
           alias_list := #PTR (library_member_header^.aliases, library^);
           FOR i := 1 TO library_member_header^.number_of_aliases DO
             command_item.name := alias_list^ [i];
             IF i = library_member_header^.number_of_aliases THEN
               command_item.class := clc$abbreviation_entry;
             ELSE
               command_item.class := clc$alias_entry;
             IFEND;
             add_command (command_item);
           FOREND;
         IFEND;

       = llc$command_description =

         library_member_header := #PTR (module_dictionary_item.command_description_header, library^);

         command_item.name := module_dictionary_item.name;
         command_item.class := clc$nominal_entry;
         command_item.availability := library_member_header^.command_function_availability;
         command_item.ordinal := library_member_header^.module_index;
         command_item.kind := library_member_header^.command_function_kind;
         command_item.log_option := library_member_header^.command_log_option;
         command_item.module_kind := llc$command_description;
         command_item.command_description_header := module_dictionary_item.command_description_header;

         add_command (command_item);

         IF library_member_header^.number_of_aliases <> 0 THEN
           alias_list := #PTR (library_member_header^.aliases, library^);
           FOR i := 1 TO library_member_header^.number_of_aliases DO
             command_item.name := alias_list^ [i];
             IF i = library_member_header^.number_of_aliases THEN
               command_item.class := clc$abbreviation_entry;
             ELSE
               command_item.class := clc$alias_entry;
             IFEND;
             add_command (command_item);
           FOREND;
         IFEND;

       = llc$applic_program_description =

         application_member_header := #PTR (module_dictionary_item.applic_program_header, library^);

         command_item.name := module_dictionary_item.name;
         command_item.class := clc$nominal_entry;
         command_item.availability := application_member_header^.library_member_header.
               command_function_availability;
         command_item.ordinal := application_member_header^.library_member_header.module_index;
         command_item.kind := application_member_header^.library_member_header.command_function_kind;
         command_item.log_option := application_member_header^.library_member_header.command_log_option;
         command_item.module_kind := llc$applic_program_description;
         command_item.program_header := module_dictionary_item.applic_program_header;

         add_command (command_item);

         IF application_member_header^.library_member_header.number_of_aliases <> 0 THEN
           alias_list := #PTR (application_member_header^.library_member_header.aliases, library^);
           FOR i := 1 TO application_member_header^.library_member_header.number_of_aliases DO
             command_item.name := alias_list^ [i];
             IF i = application_member_header^.library_member_header.number_of_aliases THEN
               command_item.class := clc$abbreviation_entry;
             ELSE
               command_item.class := clc$alias_entry;
             IFEND;
             add_command (command_item);
           FOREND;
         IFEND;

       = llc$applic_command_procedure =

         application_member_header := #PTR (module_dictionary_item.applic_command_header, library^);

         command_item.name := module_dictionary_item.name;
         command_item.class := clc$nominal_entry;
         command_item.availability := application_member_header^.library_member_header.
               command_function_availability;
         command_item.ordinal := application_member_header^.library_member_header.module_index;
         command_item.kind := application_member_header^.library_member_header.command_function_kind;
         command_item.log_option := application_member_header^.library_member_header.command_log_option;
         command_item.module_kind := llc$applic_command_procedure;
         command_item.command_header := module_dictionary_item.applic_command_header;

         add_command (command_item);

         IF application_member_header^.library_member_header.number_of_aliases <> 0 THEN
           alias_list := #PTR (application_member_header^.library_member_header.aliases, library^);
           FOR i := 1 TO application_member_header^.library_member_header.number_of_aliases DO
             command_item.name := alias_list^ [i];
             IF i = application_member_header^.library_member_header.number_of_aliases THEN
               command_item.class := clc$abbreviation_entry;
             ELSE
               command_item.class := clc$alias_entry;
             IFEND;
             add_command (command_item);
           FOREND;
         IFEND;

       = llc$applic_command_description =

         application_member_header := #PTR (module_dictionary_item.applic_command_description_hdr, library^);

         command_item.name := module_dictionary_item.name;
         command_item.class := clc$nominal_entry;
         command_item.availability := application_member_header^.library_member_header.
               command_function_availability;
         command_item.ordinal := application_member_header^.library_member_header.module_index;
         command_item.kind := application_member_header^.library_member_header.command_function_kind;
         command_item.log_option := application_member_header^.library_member_header.command_log_option;
         command_item.module_kind := llc$applic_command_description;
         command_item.command_description_header := module_dictionary_item.applic_command_description_hdr;

         add_command (command_item);

         IF application_member_header^.library_member_header.number_of_aliases <> 0 THEN
           alias_list := #PTR (application_member_header^.library_member_header.aliases, library^);
           FOR i := 1 TO application_member_header^.library_member_header.number_of_aliases DO
             command_item.name := alias_list^ [i];
             IF i = application_member_header^.library_member_header.number_of_aliases THEN
               command_item.class := clc$abbreviation_entry;
             ELSE
               command_item.class := clc$alias_entry;
             IFEND;
             add_command (command_item);
           FOREND;
         IFEND;

       CASEND;


     PROCEND add_to_command_dictionary;
?? OLDTITLE ??
?? NEWTITLE := '            ADD_TO_FUNCTION_DICTIONARY' ??
?? EJECT ??

     PROCEDURE add_to_function_dictionary
       (    module_dictionary_item: llt$module_dictionary_item;
            temporary_library: ^SEQ ( * );
        VAR next_function: llt$function_index;
        VAR function_dictionary: ^llt$function_dictionary);

?? NEWTITLE := '              ADD_FUNCTION', EJECT ??

       PROCEDURE add_function
         (    function_item: llt$function_dictionary_item);


         VAR
           i: llt$function_index,
           local_status: ost$status;


         FOR i := 1 TO next_function DO
           IF function_dictionary^ [i].name = function_item.name THEN
             osp$set_status_abnormal (oc, oce$w_dup_functions_on_lib, function_item.name, local_status);
             ocp$generate_message (local_status);
             osp$set_status_abnormal (oc, oce$w_non_fatal_generate_error, '', command_status);
           IFEND;
         FOREND;


         next_function := next_function + 1;

         function_dictionary^ [next_function] := function_item;


       PROCEND add_function;
?? OLDTITLE ??
?? EJECT ??


       VAR
         library: ^SEQ ( * ),

         library_member_header: ^llt$library_member_header,
         alias_list: ^pmt$module_list,
         i: llt$number_of_aliases,

         function_item: llt$function_dictionary_item;


       library := temporary_library;

       CASE module_dictionary_item.kind OF

       = llc$function_procedure =
         library_member_header := #PTR (module_dictionary_item.function_header, library^);

         function_item.name := module_dictionary_item.name;
         function_item.class := clc$nominal_entry;
         function_item.availability := library_member_header^.command_function_availability;
         function_item.ordinal := library_member_header^.module_index;
         function_item.kind := library_member_header^.command_function_kind;
         function_item.module_kind := llc$function_procedure;
         function_item.function_header := module_dictionary_item.function_header;

         add_function (function_item);

         IF library_member_header^.number_of_aliases <> 0 THEN
           alias_list := #PTR (library_member_header^.aliases, library^);
           FOR i := 1 TO library_member_header^.number_of_aliases DO
             function_item.name := alias_list^ [i];
             IF i = library_member_header^.number_of_aliases THEN
               function_item.class := clc$abbreviation_entry;
             ELSE
               function_item.class := clc$alias_entry;
             IFEND;
             add_function (function_item);
           FOREND;
         IFEND;

       = llc$function_description =
         library_member_header := #PTR (module_dictionary_item.function_description_header, library^);

         function_item.name := module_dictionary_item.name;
         function_item.class := clc$nominal_entry;
         function_item.availability := library_member_header^.command_function_availability;
         function_item.ordinal := library_member_header^.module_index;
         function_item.kind := library_member_header^.command_function_kind;
         function_item.module_kind := llc$function_description;
         function_item.function_description_header := module_dictionary_item.function_description_header;

         add_function (function_item);

         IF library_member_header^.number_of_aliases <> 0 THEN
           alias_list := #PTR (library_member_header^.aliases, library^);
           FOR i := 1 TO library_member_header^.number_of_aliases DO
             function_item.name := alias_list^ [i];
             IF i = library_member_header^.number_of_aliases THEN
               function_item.class := clc$abbreviation_entry;
             ELSE
               function_item.class := clc$alias_entry;
             IFEND;
             add_function (function_item);
           FOREND;
         IFEND;

       CASEND;

     PROCEND add_to_function_dictionary;
?? OLDTITLE ??
?? NEWTITLE := '            ADD_TO_MSG_AND_OR_MODULE_DICTS' ??
?? EJECT ??

     PROCEDURE add_to_msg_or_help_module_dicts
       (    module_dictionary_item: llt$module_dictionary_item;
            temporary_library: ^SEQ ( * );
        VAR next_help_module: llt$help_module_index;
        VAR next_message_module: llt$message_module_index;
        VAR message_module_dictionary: ^llt$message_module_dictionary);

?? NEWTITLE := '              ADD_HELP_MODULE', EJECT ??

       PROCEDURE add_help_module
         (    help_module_item: llt$help_module_dictionary_item);


         VAR
           i: llt$help_module_index,
           local_status: ost$status;


         FOR i := 1 TO next_help_module DO
           IF help_module_dictionary^ [i].name = help_module_item.name THEN
             osp$set_status_abnormal (oc, oce$w_dup_help_modules_on_lib, help_module_item.name, local_status);
             ocp$generate_message (local_status);
             osp$set_status_abnormal (oc, oce$w_non_fatal_generate_error, '', command_status);
           IFEND;
         FOREND;


         next_help_module := next_help_module + 1;

         help_module_dictionary^ [next_help_module] := help_module_item;


       PROCEND add_help_module;
?? OLDTITLE ??
?? NEWTITLE := '              ADD_MESSAGE_MODULE', EJECT ??

       PROCEDURE add_message_module
         (    message_module_item: llt$message_module_dict_item);


         VAR
           i: llt$message_module_index,
           local_status: ost$status;


         FOR i := 1 TO next_message_module DO
           IF message_module_dictionary^ [i].name = message_module_item.name THEN
             osp$set_status_abnormal (oc, oce$w_dup_msg_modules_on_lib, message_module_item.name,
                   local_status);
             ocp$generate_message (local_status);
             osp$set_status_abnormal (oc, oce$w_non_fatal_generate_error, '', command_status);
           IFEND;
         FOREND;


         next_message_module := next_message_module + 1;

         message_module_dictionary^ [next_message_module] := message_module_item;


       PROCEND add_message_module;
?? OLDTITLE ??
?? EJECT ??


       VAR
         library: ^SEQ ( * ),

         library_member_header: ^llt$library_member_header,
         message_template_module: ^ost$message_template_module,

         natural_language: ost$natural_language,
         online_manual_name: ost$online_manual_name,
         help_module: boolean,
         message_module: boolean,
         lowest_message_code: ost$status_condition_code,
         highest_message_code: ost$status_condition_code,

         message_module_item: llt$message_module_dict_item,
         help_module_item: llt$help_module_dictionary_item;


       library := temporary_library;

       library_member_header := #PTR (module_dictionary_item.message_header, library^);
       RESET library TO library_member_header;
       message_template_module := #PTR (library_member_header^.member, library^);

       RESET message_template_module;
       clp$get_message_module_info (message_template_module, natural_language, online_manual_name,
             help_module, message_module, lowest_message_code, highest_message_code, status);
       IF NOT status.normal THEN
         RETURN;
       IFEND;

       IF message_module THEN

         message_module_item.name := module_dictionary_item.name;
         message_module_item.language := natural_language;
         message_module_item.lowest_condition_code := lowest_message_code;
         message_module_item.highest_condition_code := highest_message_code;
         message_module_item.message_header := module_dictionary_item.message_header;

         add_message_module (message_module_item);

       IFEND;

       IF help_module THEN

         help_module_item.name := module_dictionary_item.name;
         help_module_item.language := natural_language;
         help_module_item.help_header := module_dictionary_item.message_header;

         add_help_module (help_module_item);

       IFEND;

     PROCEND add_to_msg_or_help_module_dicts;
?? OLDTITLE ??
?? NEWTITLE := '            ADD_TO_PANEL_DICTIONARY' ??
?? EJECT ??

     PROCEDURE add_to_panel_dictionary
       (    module_dictionary_item: llt$module_dictionary_item;
            temporary_library: ^SEQ ( * );
        VAR next_panel: llt$panel_index;
        VAR panel_dictionary: ^llt$panel_dictionary);

?? NEWTITLE := '              ADD_PANEL', EJECT ??

       PROCEDURE add_panel
         (    panel_item: llt$panel_dictionary_item);


         VAR
           i: llt$panel_index,
           local_status: ost$status;


         FOR i := 1 TO next_panel DO
           IF panel_dictionary^ [i].name = panel_item.name THEN
             osp$set_status_abnormal (oc, oce$w_dup_panels_on_lib, panel_item.name, local_status);
             ocp$generate_message (local_status);
             osp$set_status_abnormal (oc, oce$w_non_fatal_generate_error, '', command_status);
           IFEND;
         FOREND;


         next_panel := next_panel + 1;

         panel_dictionary^ [next_panel] := panel_item;


       PROCEND add_panel;
?? OLDTITLE ??
?? EJECT ??


       VAR
         library: ^SEQ ( * ),

         panel_item: llt$panel_dictionary_item;


       library := temporary_library;

       panel_item.name := module_dictionary_item.name;
       panel_item.panel_header := module_dictionary_item.panel_header;

       add_panel (panel_item);


     PROCEND add_to_panel_dictionary;
?? OLDTITLE ??
?? EJECT ??

{ The value for prestreaming_transfer_size is chosen for optimum performance.  The
{ library is accessed sequentially (typically) and thus prestreaming should read-ahead
{ as much data is as possible to keep the disk driver streaming.

     CONST
       prestreaming_transfer_size = 65536;

     VAR
       save_temp_transfer_size: 0 .. 15,
       save_temp_free_behind: boolean,
       save_transfer_size: 0 .. 15,
       save_free_behind: boolean,
       last_segment_number: ost$segment,
       current_segment_number: ost$segment,
       pva_p: ^cell,
       load_module_header: ^llt$load_module_header,
       ppu_header: ^llt$object_text_descriptor,
       program_header: ^llt$library_member_header,
       command_header: ^llt$library_member_header,
       command_description_header: ^llt$library_member_header,
       function_header: ^llt$library_member_header,
       function_description_header: ^llt$library_member_header,
       message_header: ^llt$library_member_header,
       panel_header: ^llt$library_member_header,
       applic_program_header: ^llt$application_member_header,
       applic_command_header: ^llt$application_member_header,
       applic_command_description_hdr: ^llt$application_member_header,

       module_index: llt$module_index,

       next_entry_point: llt$entry_point_index,
       next_command: llt$command_index,
       next_function: llt$function_index,
       next_message_module: llt$message_module_index,
       next_help_module: llt$help_module_index,
       next_panel: llt$panel_index,

       load_module: ^oct$load_module_list;

     module_index := 0;
     next_entry_point := 0;
     next_command := 0;
     next_function := 0;
     next_message_module := 0;
     next_help_module := 0;
     next_panel := 0;

     load_module := load_module_list.link;

     last_segment_number := 0;
     current_segment_number := 0;
     pva_p := ^current_segment_number;
     mmp$preset_page_streaming ({preset_and_save_ts_fb} TRUE, temporary_library, prestreaming_transfer_size,
           save_temp_transfer_size, save_temp_free_behind, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

     REPEAT

{ If the segment number has changed, reset the segment attributes on the old
{ segment to what they were and set the segment attributes on the new segment
{ for sequential access and free-behind.  The expected case is for the name
{ list to be ordered for sequential access on a file.  This happens if ADDM is
{ called with just a library or a library and a range of module names.  These
{ are two of the three typical cases.  The third case is an ADDM of just one
{ or two modules.  Additional overhead will occur in this case, but typically
{ only once per file.  A very degenerative case would be for a library to be in
{ reverse alphabetical order and then have ADDM requests done in alphabetical
{ order.  This would cause access to the segment to be backwards, so free behind
{ and sequential access would be ignored.  This case is not typical, so it will
{ be ignored.

       IF current_segment_number <> last_segment_number THEN
         IF last_segment_number <> 0 THEN
           pva_p := #ADDRESS (#RING (pva_p), last_segment_number, 0);
           mmp$preset_page_streaming ({preset_and_save_ts_fb} FALSE, pva_p, prestreaming_transfer_size,
                 save_transfer_size, save_free_behind, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;
         IFEND;
         pva_p := #ADDRESS (#RING (pva_p), current_segment_number, 0);
         mmp$preset_page_streaming ({preset_and_save_ts_fb} TRUE, pva_p, prestreaming_transfer_size,
               save_transfer_size, save_free_behind, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;
         last_segment_number := current_segment_number;
       IFEND;
       module_index := module_index + 1;
       module_dictionary^ [module_index].name := load_module^.name;
       IF load_module^.description^.file <> NIL THEN
         current_segment_number := #SEGMENT (load_module^.description^.file);
       IFEND;

       CASE load_module^.description^.kind OF
       = occ$ppu_object_module =
         module_dictionary^ [module_index].kind := llc$ppu_object_module;

         copy_ppu_object_module (load_module^.description, load_module^.changed_info, ppu_header,
               temporary_library, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;

         module_dictionary^ [module_index].ppu_header := #REL (ppu_header, temporary_library^);

       = occ$load_module =
         module_dictionary^ [module_index].kind := llc$load_module;

         copy_load_module (module_index, load_module^.description, load_module^.changed_info,
               load_module_header, code_section, read_section, temporary_library, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;

         module_dictionary^ [module_index].module_header := #REL (load_module_header, temporary_library^);

         add_to_entry_point_dictionary (module_dictionary^ [module_index], temporary_library,
               next_entry_point, entry_point_dictionary);

         add_to_command_dictionary (module_dictionary^ [module_index], temporary_library, next_command,
               command_dictionary);

       = occ$program_description =
         IF (load_module^.changed_info <> NIL) AND (load_module^.changed_info^.application_identifier <>
               NIL) AND (load_module^.changed_info^.application_identifier^.name <> osc$null_name) THEN
           module_dictionary^ [module_index].kind := llc$applic_program_description;

           copy_prog_des_to_app_prog_des (module_index, load_module^.description, load_module^.changed_info,
                 applic_program_header, temporary_library, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;

           module_dictionary^ [module_index].applic_program_header :=
                 #REL (applic_program_header, temporary_library^);
         ELSE
           module_dictionary^ [module_index].kind := llc$program_description;

           copy_program_description (module_index, load_module^.description, load_module^.changed_info,
                 program_header, temporary_library, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;

           module_dictionary^ [module_index].program_header := #REL (program_header, temporary_library^);
         IFEND;

         add_to_command_dictionary (module_dictionary^ [module_index], temporary_library, next_command,
               command_dictionary);

       = occ$command_procedure =
         IF (load_module^.changed_info <> NIL) AND (load_module^.changed_info^.application_identifier <>
               NIL) AND (load_module^.changed_info^.application_identifier^.name <> osc$null_name) THEN
           module_dictionary^ [module_index].kind := llc$applic_command_procedure;

           copy_scl_proc_to_app_scl_proc (module_index, load_module^.description, load_module^.changed_info,
                 applic_command_header, temporary_library, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;

           module_dictionary^ [module_index].applic_command_header :=
                 #REL (applic_command_header, temporary_library^);
         ELSE
           module_dictionary^ [module_index].kind := llc$command_procedure;

           copy_scl_procedure (module_index, load_module^.description, load_module^.changed_info,
                 command_header, temporary_library, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;

           module_dictionary^ [module_index].command_header := #REL (command_header, temporary_library^);
         IFEND;

         add_to_command_dictionary (module_dictionary^ [module_index], temporary_library, next_command,
               command_dictionary);

       = occ$command_description =
         IF (load_module^.changed_info <> NIL) AND (load_module^.changed_info^.application_identifier <>
               NIL) AND (load_module^.changed_info^.application_identifier^.name <> osc$null_name) THEN
           module_dictionary^ [module_index].kind := llc$applic_command_description;

           copy_cmnd_des_to_app_cmnd_des (module_index, load_module^.description, load_module^.changed_info,
                 applic_command_description_hdr, temporary_library, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;

           module_dictionary^ [module_index].applic_command_description_hdr :=
                 #REL (applic_command_description_hdr, temporary_library^);
         ELSE
           module_dictionary^ [module_index].kind := llc$command_description;

           copy_command_description (module_index, load_module^.description, load_module^.changed_info,
                 command_description_header, temporary_library, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;

           module_dictionary^ [module_index].command_description_header :=
                 #REL (command_description_header, temporary_library^);
         IFEND;

         add_to_command_dictionary (module_dictionary^ [module_index], temporary_library, next_command,
               command_dictionary);

       = occ$function_procedure =
         module_dictionary^ [module_index].kind := llc$function_procedure;

         copy_scl_procedure (module_index, load_module^.description, load_module^.changed_info,
               function_header, temporary_library, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;

         module_dictionary^ [module_index].function_header := #REL (function_header, temporary_library^);

         add_to_function_dictionary (module_dictionary^ [module_index], temporary_library, next_function,
               function_dictionary);

       = occ$function_description =
         module_dictionary^ [module_index].kind := llc$function_description;

         copy_function_description (module_index, load_module^.description, load_module^.changed_info,
               function_description_header, temporary_library, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;

         module_dictionary^ [module_index].function_description_header :=
               #REL (function_description_header, temporary_library^);

         add_to_function_dictionary (module_dictionary^ [module_index], temporary_library, next_function,
               function_dictionary);

       = occ$message_module =
         module_dictionary^ [module_index].kind := llc$message_module;

         copy_message_module (module_index, load_module^.description, load_module^.changed_info,
               message_header, temporary_library, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;

         module_dictionary^ [module_index].message_header := #REL (message_header, temporary_library^);

         add_to_msg_or_help_module_dicts (module_dictionary^ [module_index], temporary_library,
               next_help_module, next_message_module, message_module_dictionary);

       = occ$panel_module =
         module_dictionary^ [module_index].kind := llc$panel_module;

         copy_panel_module (module_index, load_module^.description, load_module^.changed_info, panel_header,
               temporary_library, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;

         module_dictionary^ [module_index].panel_header := #REL (panel_header, temporary_library^);

         add_to_panel_dictionary (module_dictionary^ [module_index], temporary_library, next_panel,
               panel_dictionary);

       = occ$temporary_load_module =
         module_dictionary^ [module_index].kind := llc$load_module;

         copy_temporary_load_module (module_index, load_module^.description, load_module_header, code_section,
               read_section, temporary_library, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;

         module_dictionary^ [module_index].module_header := #REL (load_module_header, temporary_library^);

         add_to_entry_point_dictionary (module_dictionary^ [module_index], temporary_library,
               next_entry_point, entry_point_dictionary);

         add_to_command_dictionary (module_dictionary^ [module_index], temporary_library, next_command,
               command_dictionary);

       = occ$applic_program_description =
         IF (load_module^.changed_info <> NIL) AND (load_module^.changed_info^.application_identifier <>
               NIL) AND (load_module^.changed_info^.application_identifier^.name = osc$null_name) THEN
           module_dictionary^ [module_index].kind := llc$program_description;

           copy_app_prog_des_to_prog_des (module_index, load_module^.description, load_module^.changed_info,
                 program_header, temporary_library, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;

           module_dictionary^ [module_index].program_header := #REL (program_header, temporary_library^);
         ELSE
           module_dictionary^ [module_index].kind := llc$applic_program_description;

           copy_applic_program_description (module_index, load_module^.description, load_module^.changed_info,
                 applic_program_header, temporary_library, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;

           module_dictionary^ [module_index].applic_program_header :=
                 #REL (applic_program_header, temporary_library^);
         IFEND;

         add_to_command_dictionary (module_dictionary^ [module_index], temporary_library, next_command,
               command_dictionary);

       = occ$applic_command_procedure =
         IF (load_module^.changed_info <> NIL) AND (load_module^.changed_info^.application_identifier <>
               NIL) AND (load_module^.changed_info^.application_identifier^.name = osc$null_name) THEN
           module_dictionary^ [module_index].kind := llc$command_procedure;

           copy_app_scl_proc_to_scl_proc (module_index, load_module^.description, load_module^.changed_info,
                 command_header, temporary_library, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;

           module_dictionary^ [module_index].command_header := #REL (command_header, temporary_library^);
         ELSE
           module_dictionary^ [module_index].kind := llc$applic_command_procedure;

           copy_applic_command_procedure (module_index, load_module^.description, load_module^.changed_info,
                 applic_command_header, temporary_library, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;

           module_dictionary^ [module_index].applic_command_header :=
                 #REL (applic_command_header, temporary_library^);
         IFEND;

         add_to_command_dictionary (module_dictionary^ [module_index], temporary_library, next_command,
               command_dictionary);

       = occ$applic_command_description =
         IF (load_module^.changed_info <> NIL) AND (load_module^.changed_info^.application_identifier <>
               NIL) AND (load_module^.changed_info^.application_identifier^.name = osc$null_name) THEN
           module_dictionary^ [module_index].kind := llc$command_description;

           copy_app_cmnd_des_to_cmnd_des (module_index, load_module^.description, load_module^.changed_info,
                 command_description_header, temporary_library, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;

           module_dictionary^ [module_index].command_description_header :=
                 #REL (command_description_header, temporary_library^);
         ELSE
           module_dictionary^ [module_index].kind := llc$applic_command_description;

           copy_applic_command_description (module_index, load_module^.description, load_module^.changed_info,
                 applic_command_description_hdr, temporary_library, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;

           module_dictionary^ [module_index].applic_command_description_hdr :=
                 #REL (applic_command_description_hdr, temporary_library^);
         IFEND;

         add_to_command_dictionary (module_dictionary^ [module_index], temporary_library, next_command,
               command_dictionary);

       CASEND;

       load_module := load_module^.link;

     UNTIL load_module = NIL;
     mmp$preset_page_streaming ({preset_and_save_ts_fb} FALSE, temporary_library, prestreaming_transfer_size,
           save_temp_transfer_size, save_temp_free_behind, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

     IF last_segment_number <> 0 THEN
       pva_p := #ADDRESS (#RING (pva_p), last_segment_number, 0);
       mmp$preset_page_streaming ({preset_and_save_ts_fb} FALSE, pva_p, prestreaming_transfer_size,
             save_transfer_size, save_free_behind, status);
     IFEND;
   PROCEND write_header_interpretive_info;
?? OLDTITLE ??
?? NEWTITLE := '          WRITE_INFORMATION_ELEMENTS' ??
?? EJECT ??

   PROCEDURE write_information_elements
     (    load_module_list: oct$load_module_list;
          module_dictionary: ^llt$module_dictionary;
      VAR temporary_library: ^SEQ ( * );
      VAR status: ost$status);




     PROCEDURE [XREF] ocp$relocate_seg_definitions
       (    relocation: ^llt$relocation;
            segment_relocation_info: ^oct$segment_relocation_info);

?? NEWTITLE := '            COPY_OLD_INFO_ELEMENT' ??
?? EJECT ??

     PROCEDURE copy_old_info_element
       (    old_info_element_header: ^llt$info_element_header;
            old_load_module: ^oct$module_description;
        VAR new_info_element_header: ^llt$info_element_header;
        VAR temporary_library: ^SEQ ( * );
        VAR status: ost$status);


       VAR
         old_relocation_items: ^llt$relocation,
         old_components: ^llt$component_information,
         old_template_items: ^llt$binding_section_template,
         old_section_maps: ^llt$section_maps,
         old_map: ^llt$section_map_items,

         new_relocation_items: ^llt$relocation,
         new_components: ^llt$component_information,
         new_template_items: ^llt$binding_section_template,
         new_section_maps: ^llt$section_maps,
         new_map: ^llt$section_map_items,
         i,
         j: integer;



       new_info_element_header^ := old_info_element_header^;

       IF old_info_element_header^.number_of_rel_items <> 0 THEN
         old_relocation_items := #PTR (old_info_element_header^.relocation_ptr, old_load_module^.file^);
         IF old_relocation_items = NIL THEN
           osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, old_load_module^.name, status);
           RETURN;
         IFEND;

         NEXT new_relocation_items: [1 .. new_info_element_header^.number_of_rel_items] IN temporary_library;
         IF new_relocation_items = NIL THEN
           osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
           RETURN;
         IFEND;

         new_info_element_header^.relocation_ptr := #REL (new_relocation_items, temporary_library^);
         new_relocation_items^ := old_relocation_items^;

         IF old_load_module^.segment_relocation_info <> NIL THEN
           ocp$relocate_seg_definitions (new_relocation_items, old_load_module^.segment_relocation_info);
         IFEND;
       IFEND;

       IF old_info_element_header^.number_of_components <> 0 THEN
         old_components := #PTR (old_info_element_header^.component_ptr, old_load_module^.file^);
         IF old_components = NIL THEN
           osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, old_load_module^.name, status);
           RETURN;
         IFEND;

         NEXT new_components: [1 .. new_info_element_header^.number_of_components] IN temporary_library;
         IF new_components = NIL THEN
           osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
           RETURN;
         IFEND;

         new_info_element_header^.component_ptr := #REL (new_components, temporary_library^);
         new_components^ := old_components^;
       IFEND;


       IF old_info_element_header^.number_of_template_items <> 0 THEN
         old_template_items := #PTR (old_info_element_header^.binding_template_ptr, old_load_module^.file^);
         IF old_template_items = NIL THEN
           osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, old_load_module^.name, status);
           RETURN;
         IFEND;

         NEXT new_template_items: [1 .. new_info_element_header^.number_of_template_items] IN
               temporary_library;
         IF new_template_items = NIL THEN
           osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
           RETURN;
         IFEND;

         new_info_element_header^.binding_template_ptr := #REL (new_template_items, temporary_library^);
         new_template_items^ := old_template_items^;
       IFEND;

       IF old_info_element_header^.number_of_section_maps <> 0 THEN
         old_section_maps := #PTR (old_info_element_header^.section_maps, old_load_module^.file^);
         IF old_section_maps = NIL THEN
           osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, old_load_module^.name, status);
           RETURN;
         IFEND;

         NEXT new_section_maps: [0 .. UPPERBOUND (old_section_maps^)] IN temporary_library;
         IF new_section_maps = NIL THEN
           osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
           RETURN;
         IFEND;

         new_info_element_header^.section_maps := #REL (new_section_maps, temporary_library^);
         new_section_maps^ := old_section_maps^;


         FOR i := 0 TO UPPERBOUND (old_section_maps^) DO
           IF old_section_maps^ [i].number_of_items <> 0 THEN
             old_map := #PTR (old_section_maps^ [i].map, old_load_module^.file^);
             IF old_map = NIL THEN
               osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, old_load_module^.name, status);
               RETURN;
             IFEND;

             NEXT new_map: [1 .. new_section_maps^ [i].number_of_items] IN temporary_library;
             IF new_map = NIL THEN
               osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
               RETURN;
             IFEND;

             new_section_maps^ [i].map := #REL (new_map, temporary_library^);
             new_map^ := old_map^;
           IFEND;
         FOREND;
       IFEND;


     PROCEND copy_old_info_element;
?? OLDTITLE ??
?? NEWTITLE := '            COPY_OLD_INFORMATION_ELEMENT' ??
?? EJECT ??

     PROCEDURE copy_old_information_element
       (    old_load_module: ^oct$module_description;
            new_load_module_header: ^llt$load_module_header;
        VAR temporary_library: ^SEQ ( * );
        VAR status: ost$status);


       VAR
         old_header: llt$info_element_header,
         old_info_element_header: ^llt$info_element_header,
         new_info_element_header: ^llt$info_element_header;


       IF llc$information_element IN old_load_module^.load_module_header^.elements_defined THEN
         new_load_module_header^.elements_defined := new_load_module_header^.elements_defined +
               $llt$load_module_elements [llc$information_element];
         NEXT new_info_element_header IN temporary_library;
         IF new_info_element_header = NIL THEN
           osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
           RETURN;
         IFEND;

         new_load_module_header^.information_element := #REL (new_info_element_header, temporary_library^);


         old_info_element_header := #PTR (old_load_module^.load_module_header^.information_element,
               old_load_module^.file^);
         IF old_info_element_header = NIL THEN
           osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, old_load_module^.name, status);
           RETURN;
         IFEND;

         IF (old_info_element_header^.version <> llc$info_element_version) THEN
           ocp$convert_information_element (old_info_element_header, old_header);
           old_info_element_header := ^old_header;
         IFEND;

         copy_old_info_element (old_info_element_header, old_load_module, new_info_element_header,
               temporary_library, status);
         IF NOT status.normal THEN
           RETURN;
         IFEND;
       IFEND;


     PROCEND copy_old_information_element;
?? OLDTITLE ??
?? NEWTITLE := '            BUILD_BINARY_SECTION_MAPS', EJECT ??

     PROCEDURE build_binary_section_maps
       (    section_definition_list: oct$section_definition_list;
        VAR number_of_section_maps: llt$number_of_sections;
        VAR section_maps_relative_pointer: REL (llt$object_library) ^array [0 .. * ] of llt$section_map;
        VAR temporary_library: ^SEQ ( * );
        VAR status: ost$status);


       VAR
         section_definition: ^oct$section_definition_list,
         old_section: ^oct$old_section_list,
         section_maps: ^llt$section_maps,
         map: ^llt$section_map_items,
         old_map: ^llt$section_map_items,
         new_map: ^llt$section_map_items,
         item: ^llt$section_map_item,
         reset_value: ^SEQ ( * ),
         count: integer,
         i: integer,
         j: integer;


       section_definition := section_definition_list.link;
       number_of_section_maps := 0;

       WHILE section_definition <> NIL DO
         section_definition := section_definition^.link;
         number_of_section_maps := number_of_section_maps + 1;
       WHILEND;

       NEXT section_maps: [0 .. (number_of_section_maps - 1)] IN temporary_library;
       IF section_maps = NIL THEN
         osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'BBSM1', status);
         RETURN;
       IFEND;

       section_maps_relative_pointer := #REL (section_maps, temporary_library^);

       FOR i := 0 TO (number_of_section_maps - 1) DO
         section_definition := section_definition_list.link;
         WHILE (section_definition^.section_definition.section_ordinal <> i) DO
           section_definition := section_definition^.link;
         WHILEND;

         reset_value := temporary_library;
         old_section := section_definition^.old_sections.link;
         count := 0;

         IF section_definition^.section_definition.kind <> llc$binding_section THEN
           WHILE old_section <> NIL DO
             IF old_section^.component^.section_maps = NIL THEN
               NEXT item IN temporary_library;
               IF item = NIL THEN
                 osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'BBSM2', status);
                 RETURN;
               IFEND;

               count := count + 1;
               item^.original_section_ordinal := old_section^.section_ordinal;
               item^.offset := old_section^.component^.section_definitions^ [old_section^.section_ordinal]^.
                     new_section_offset;
               item^.length := old_section^.component^.section_definitions^ [old_section^.section_ordinal]^.
                     section_definition.length;
               item^.name := old_section^.component^.section_definitions^ [old_section^.section_ordinal]^.
                     section_definition.name;
               item^.component := old_section^.component^.component_number;

             ELSEIF old_section^.component^.section_maps^ [old_section^.section_ordinal].number_of_items <>
                   0 THEN
               old_map := #PTR (old_section^.component^.section_maps^ [old_section^.section_ordinal].map,
                     old_section^.component^.file^);
               NEXT new_map: [1 .. UPPERBOUND (old_map^)] IN temporary_library;
               IF new_map = NIL THEN
                 osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, 'BBSM3', status);
                 RETURN;
               IFEND;

               new_map^ := old_map^;
               count := count + UPPERBOUND (new_map^);

               FOR j := 1 TO UPPERBOUND (new_map^) DO
                 new_map^ [j].offset := new_map^ [j].offset + old_section^.component^.
                       section_definitions^ [old_section^.section_ordinal]^.new_section_offset;
                 new_map^ [j].component := old_section^.component^.components^ [new_map^ [j].component].
                       new_component_number;
               FOREND;
             IFEND;

             old_section := old_section^.link;
           WHILEND;
         IFEND;


         section_maps^ [i].number_of_items := count;

         IF count > 0 THEN
           temporary_library := reset_value;
           NEXT map: [1 .. count] IN temporary_library;
           section_maps^ [i].map := #REL (map, temporary_library^);
         IFEND;
       FOREND;


     PROCEND build_binary_section_maps;
?? OLDTITLE ??
?? NEWTITLE := '            COPY_NEW_INFORMATION_ELEMENT' ??
?? EJECT ??

     PROCEDURE copy_new_information_element
       (    temp_load_module: ^oct$module_description;
            new_load_module_header: ^llt$load_module_header;
        VAR temporary_library: ^SEQ ( * );
        VAR status: ost$status);


       VAR
         new_info_element_hdr: ^llt$info_element_header,
         new_relocation_items: ^llt$relocation,
         new_components: ^llt$component_information,
         new_template_items: ^llt$binding_section_template,

         i: integer,
         next_relocation_item: ^oct$relocation_list,
         next_template_item: ^oct$new_binding_template_list;


       IF (temp_load_module^.temporary_module_header^.number_of_rel_items <> 0) OR
             (UPPERBOUND (temp_load_module^.temporary_module_header^.component_info^) > 1) OR
             (temp_load_module^.temporary_module_header^.number_of_template_items <> 0) OR
             (temp_load_module^.temporary_module_header^.include_binary_section_maps) THEN

         new_load_module_header^.elements_defined := new_load_module_header^.elements_defined +
               $llt$load_module_elements [llc$information_element];

         NEXT new_info_element_hdr IN temporary_library;
         IF new_info_element_hdr = NIL THEN
           osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
           RETURN;
         IFEND;

         new_load_module_header^.information_element := #REL (new_info_element_hdr, temporary_library^);

         new_info_element_hdr^.version := llc$info_element_version;

         new_info_element_hdr^.number_of_rel_items := temp_load_module^.temporary_module_header^.
               number_of_rel_items;
         IF new_info_element_hdr^.number_of_rel_items <> 0 THEN

           NEXT new_relocation_items: [1 .. new_info_element_hdr^.number_of_rel_items] IN temporary_library;
           IF new_relocation_items = NIL THEN
             osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
             RETURN;
           IFEND;

           new_info_element_hdr^.relocation_ptr := #REL (new_relocation_items, temporary_library^);
           next_relocation_item := temp_load_module^.temporary_module_header^.relocation_list.link;

           FOR i := 1 TO new_info_element_hdr^.number_of_rel_items DO
             new_relocation_items^ [i] := next_relocation_item^.relocation_item;
             next_relocation_item := next_relocation_item^.link;
           FOREND;

           IF temp_load_module^.segment_relocation_info <> NIL THEN
             ocp$relocate_seg_definitions (new_relocation_items, temp_load_module^.segment_relocation_info);
           IFEND;
         IFEND;


         new_info_element_hdr^.number_of_components := UPPERBOUND (temp_load_module^.temporary_module_header^.
               component_info^);
         IF (new_info_element_hdr^.number_of_components = 1) AND
               (NOT temp_load_module^.temporary_module_header^.include_binary_section_maps) THEN
           new_info_element_hdr^.number_of_components := 0;

         ELSE
           NEXT new_components: [1 .. new_info_element_hdr^.number_of_components] IN temporary_library;
           IF new_components = NIL THEN
             osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
             RETURN;
           IFEND;

           new_info_element_hdr^.component_ptr := #REL (new_components, temporary_library^);
           new_components^ := temp_load_module^.temporary_module_header^.component_info^;
         IFEND;

         new_info_element_hdr^.number_of_template_items := temp_load_module^.temporary_module_header^.
               number_of_template_items;
         IF new_info_element_hdr^.number_of_template_items <> 0 THEN
           NEXT new_template_items: [1 .. new_info_element_hdr^.number_of_template_items] IN
                 temporary_library;
           IF new_template_items = NIL THEN
             osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
             RETURN;
           IFEND;

           new_info_element_hdr^.binding_template_ptr := #REL (new_template_items, temporary_library^);
           next_template_item := temp_load_module^.temporary_module_header^.binding_template_list.link;

           FOR i := 1 TO new_info_element_hdr^.number_of_template_items DO
             new_template_items^ [i] := next_template_item^.binding_template;
             next_template_item := next_template_item^.link;
           FOREND;
         IFEND;


         IF temp_load_module^.temporary_module_header^.include_binary_section_maps THEN
           build_binary_section_maps (temp_load_module^.temporary_module_header^.section_definitions,
                 new_info_element_hdr^.number_of_section_maps, new_info_element_hdr^.section_maps,
                 temporary_library, status);
           IF NOT status.normal THEN
             RETURN;
           IFEND;
         ELSE
           new_info_element_hdr^.number_of_section_maps := 0;
         IFEND;
       IFEND;


     PROCEND copy_new_information_element;
?? OLDTITLE ??
?? EJECT ??




     VAR
       load_module: ^oct$load_module_list,
       new_load_module_header: ^llt$load_module_header,

       i: llt$module_index;


     load_module := load_module_list.link;
     i := 0;

     REPEAT
       i := i + 1;

       IF (load_module^.description^.kind = occ$load_module) OR
             (load_module^.description^.kind = occ$temporary_load_module) THEN
         new_load_module_header := #PTR (module_dictionary^ [i].module_header, temporary_library^);

         CASE load_module^.description^.kind OF
         = occ$load_module =
           copy_old_information_element (load_module^.description, new_load_module_header, temporary_library,
                 status);

         = occ$temporary_load_module =
           copy_new_information_element (load_module^.description, new_load_module_header, temporary_library,
                 status);

         CASEND;
       IFEND;

       IF NOT status.normal THEN
         RETURN;
       IFEND;

       load_module := load_module^.link;

     UNTIL load_module = NIL;


   PROCEND write_information_elements;

?? OLDTITLE ??
?? NEWTITLE := '        SORT_COMMAND_DICTIONARY', EJECT ??

   PROCEDURE sort_command_dictionary
     (VAR commands: llt$command_dictionary);


     VAR
       left: integer,
       right: integer,
       i: integer,
       j: integer,
       number: integer,
       temp: llt$command_dictionary_item,
       key: pmt$program_name;


     number := UPPERBOUND (commands);

     IF (number = 1) THEN
       RETURN;
     ELSEIF (number = 2) THEN
       IF (commands [1].name > commands [2].name) THEN
         temp := commands [1];
         commands [1] := commands [2];
         commands [2] := temp;
       IFEND;
       RETURN;
     IFEND;

     left := (number DIV 2) + 1;
     right := number;

   /outer_loop/
     WHILE (TRUE) DO
       IF (left > 1) THEN
         left := left - 1;
         temp := commands [left];
         key := commands [left].name;
       ELSE
         temp := commands [right];
         key := commands [right].name;
         commands [right] := commands [1];
         right := right - 1;
         IF (right = 1) THEN
           commands [right] := temp;
           RETURN;
         IFEND;
       IFEND;

       j := left;

     /inner_loop/
       WHILE (TRUE) DO
         i := j;
         j := j + j;

         IF (j < right) THEN
           IF (commands [j].name < commands [j + 1].name) THEN
             j := j + 1;
           IFEND;
         ELSEIF (j > right) THEN
           EXIT /inner_loop/;
         IFEND;

         IF (key >= commands [j].name) THEN
           EXIT /inner_loop/;
         IFEND;

         commands [i] := commands [j];
       WHILEND /inner_loop/;

       commands [i] := temp;
     WHILEND /outer_loop/;


   PROCEND sort_command_dictionary;
?? OLDTITLE ??
?? NEWTITLE := '        SORT_FUNCTION_DICTIONARY', EJECT ??

   PROCEDURE sort_function_dictionary
     (VAR functions: llt$function_dictionary);


     VAR
       left: integer,
       right: integer,
       i: integer,
       j: integer,
       number: integer,
       temp: llt$function_dictionary_item,
       key: pmt$program_name;


     number := UPPERBOUND (functions);

     IF (number = 1) THEN
       RETURN;
     ELSEIF (number = 2) THEN
       IF (functions [1].name > functions [2].name) THEN
         temp := functions [1];
         functions [1] := functions [2];
         functions [2] := temp;
       IFEND;
       RETURN;
     IFEND;

     left := (number DIV 2) + 1;
     right := number;

   /outer_loop/
     WHILE (TRUE) DO
       IF (left > 1) THEN
         left := left - 1;
         temp := functions [left];
         key := functions [left].name;
       ELSE
         temp := functions [right];
         key := functions [right].name;
         functions [right] := functions [1];
         right := right - 1;
         IF (right = 1) THEN
           functions [right] := temp;
           RETURN;
         IFEND;
       IFEND;

       j := left;

     /inner_loop/
       WHILE (TRUE) DO
         i := j;
         j := j + j;

         IF (j < right) THEN
           IF (functions [j].name < functions [j + 1].name) THEN
             j := j + 1;
           IFEND;
         ELSEIF (j > right) THEN
           EXIT /inner_loop/;
         IFEND;

         IF (key >= functions [j].name) THEN
           EXIT /inner_loop/;
         IFEND;

         functions [i] := functions [j];
       WHILEND /inner_loop/;

       functions [i] := temp;
     WHILEND /outer_loop/;


   PROCEND sort_function_dictionary;
?? OLDTITLE ??
?? NEWTITLE := '        SORT_MESSAGE_MODULE_DICTIONARY', EJECT ??

   PROCEDURE sort_message_module_dictionary
     (VAR message_modules: llt$message_module_dictionary);


     VAR
       left: integer,
       right: integer,
       i: integer,
       j: integer,
       number: integer,
       temp: llt$message_module_dict_item,
       key: pmt$program_name;


     number := UPPERBOUND (message_modules);

     IF (number = 1) THEN
       RETURN;
     ELSEIF (number = 2) THEN
       IF (message_modules [1].name > message_modules [2].name) THEN
         temp := message_modules [1];
         message_modules [1] := message_modules [2];
         message_modules [2] := temp;
       IFEND;
       RETURN;
     IFEND;

     left := (number DIV 2) + 1;
     right := number;

   /outer_loop/
     WHILE (TRUE) DO
       IF (left > 1) THEN
         left := left - 1;
         temp := message_modules [left];
         key := message_modules [left].name;
       ELSE
         temp := message_modules [right];
         key := message_modules [right].name;
         message_modules [right] := message_modules [1];
         right := right - 1;
         IF (right = 1) THEN
           message_modules [right] := temp;
           RETURN;
         IFEND;
       IFEND;

       j := left;

     /inner_loop/
       WHILE (TRUE) DO
         i := j;
         j := j + j;

         IF (j < right) THEN
           IF (message_modules [j].name < message_modules [j + 1].name) THEN
             j := j + 1;
           IFEND;
         ELSEIF (j > right) THEN
           EXIT /inner_loop/;
         IFEND;

         IF (key >= message_modules [j].name) THEN
           EXIT /inner_loop/;
         IFEND;

         message_modules [i] := message_modules [j];
       WHILEND /inner_loop/;

       message_modules [i] := temp;
     WHILEND /outer_loop/;


   PROCEND sort_message_module_dictionary;
?? OLDTITLE ??
?? NEWTITLE := '        SORT_HELP_MODULE_DICTIONARY', EJECT ??

   PROCEDURE sort_help_module_dictionary
     (VAR help_modules: llt$help_module_dictionary);


     VAR
       left: integer,
       right: integer,
       i: integer,
       j: integer,
       number: integer,
       temp: llt$help_module_dictionary_item,
       key: pmt$program_name;


     number := UPPERBOUND (help_modules);

     IF (number = 1) THEN
       RETURN;
     ELSEIF (number = 2) THEN
       IF (help_modules [1].name > help_modules [2].name) THEN
         temp := help_modules [1];
         help_modules [1] := help_modules [2];
         help_modules [2] := temp;
       IFEND;
       RETURN;
     IFEND;

     left := (number DIV 2) + 1;
     right := number;

   /outer_loop/
     WHILE (TRUE) DO
       IF (left > 1) THEN
         left := left - 1;
         temp := help_modules [left];
         key := help_modules [left].name;
       ELSE
         temp := help_modules [right];
         key := help_modules [right].name;
         help_modules [right] := help_modules [1];
         right := right - 1;
         IF (right = 1) THEN
           help_modules [right] := temp;
           RETURN;
         IFEND;
       IFEND;

       j := left;

     /inner_loop/
       WHILE (TRUE) DO
         i := j;
         j := j + j;

         IF (j < right) THEN
           IF (help_modules [j].name < help_modules [j + 1].name) THEN
             j := j + 1;
           IFEND;
         ELSEIF (j > right) THEN
           EXIT /inner_loop/;
         IFEND;

         IF (key >= help_modules [j].name) THEN
           EXIT /inner_loop/;
         IFEND;

         help_modules [i] := help_modules [j];
       WHILEND /inner_loop/;

       help_modules [i] := temp;
     WHILEND /outer_loop/;


   PROCEND sort_help_module_dictionary;
?? OLDTITLE ??
?? NEWTITLE := '        SORT_PANEL_DICTIONARY', EJECT ??

   PROCEDURE sort_panel_dictionary
     (VAR panels: llt$panel_dictionary);


     VAR
       left: integer,
       right: integer,
       i: integer,
       j: integer,
       number: integer,
       temp: llt$panel_dictionary_item,
       key: pmt$program_name;


     number := UPPERBOUND (panels);

     IF (number = 1) THEN
       RETURN;
     ELSEIF (number = 2) THEN
       IF (panels [1].name > panels [2].name) THEN
         temp := panels [1];
         panels [1] := panels [2];
         panels [2] := temp;
       IFEND;
       RETURN;
     IFEND;

     left := (number DIV 2) + 1;
     right := number;

   /outer_loop/
     WHILE (TRUE) DO
       IF (left > 1) THEN
         left := left - 1;
         temp := panels [left];
         key := panels [left].name;
       ELSE
         temp := panels [right];
         key := panels [right].name;
         panels [right] := panels [1];
         right := right - 1;
         IF (right = 1) THEN
           panels [right] := temp;
           RETURN;
         IFEND;
       IFEND;

       j := left;

     /inner_loop/
       WHILE (TRUE) DO
         i := j;
         j := j + j;

         IF (j < right) THEN
           IF (panels [j].name < panels [j + 1].name) THEN
             j := j + 1;
           IFEND;
         ELSEIF (j > right) THEN
           EXIT /inner_loop/;
         IFEND;

         IF (key >= panels [j].name) THEN
           EXIT /inner_loop/;
         IFEND;

         panels [i] := panels [j];
       WHILEND /inner_loop/;

       panels [i] := temp;
     WHILEND /outer_loop/;


   PROCEND sort_panel_dictionary;
?? OLDTITLE ??
?? EJECT ??

   CONST
     for_code_sections = TRUE,
     for_read_sections = FALSE;


   VAR
     page_size: ost$page_size,

     code_section_element: ^llt$code_element,
     read_section_element: ^llt$code_element,

     code_section: ^cell,
     read_section: ^cell,

     code_section_length: ost$segment_length,
     read_section_length: ost$segment_length,

     module_dictionary: ^llt$module_dictionary,
     entry_point_dictionary: ^llt$entry_point_dictionary,
     command_dictionary: ^llt$command_dictionary,
     function_dictionary: ^llt$function_dictionary,
     help_module_dictionary: ^llt$help_module_dictionary,
     message_module_dictionary: ^llt$message_module_dictionary,
     panel_dictionary: ^llt$panel_dictionary;


   pmp$get_page_size (page_size, status);
   IF NOT status.normal THEN
     RETURN;
   IFEND;


   RESET temporary_library;

   write_header_and_dictionaries (load_module_list, module_dictionary, entry_point_dictionary,
         command_dictionary, function_dictionary, help_module_dictionary, message_module_dictionary,
         panel_dictionary, temporary_library, status);

   IF NOT status.normal THEN
     RETURN;
   IFEND;


   skip_to_page_boundry (page_size, temporary_library);

   compute_section_length (for_code_sections, load_module_list, temporary_library, code_section_length,
         status);

   IF NOT status.normal THEN
     RETURN;
   IFEND;

   IF code_section_length <> 0 THEN
     NEXT code_section_element: [1 .. code_section_length] IN temporary_library;
     IF code_section_element = NIL THEN
       osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
       RETURN;
     IFEND;
     code_section := #LOC (code_section_element^);
   ELSE
     code_section := NIL;
   IFEND;



   compute_section_length (for_read_sections, load_module_list, temporary_library, read_section_length,
         status);

   IF NOT status.normal THEN
     RETURN;
   IFEND;

   IF read_section_length <> 0 THEN
     NEXT read_section_element: [1 .. read_section_length] IN temporary_library;
     IF read_section_element = NIL THEN
       osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
       RETURN;
     IFEND;
     read_section := #LOC (read_section_element^);
   ELSE
     read_section := NIL;
   IFEND;


   IF (code_section_length + read_section_length) <> 0 THEN
     skip_to_page_boundry (page_size, temporary_library);
   IFEND;

   write_header_interpretive_info (load_module_list, temporary_library, module_dictionary,
         entry_point_dictionary, command_dictionary, function_dictionary, help_module_dictionary,
         message_module_dictionary, panel_dictionary, code_section, read_section, status);

   IF NOT status.normal THEN
     RETURN;
   IFEND;



   skip_to_page_boundry (page_size, temporary_library);

   write_information_elements (load_module_list, module_dictionary, temporary_library, status);

   IF NOT status.normal THEN
     RETURN;
   IFEND;

   IF command_dictionary <> NIL THEN
     sort_command_dictionary (command_dictionary^);
   IFEND;

   IF function_dictionary <> NIL THEN
     sort_function_dictionary (function_dictionary^);
   IFEND;

   IF message_module_dictionary <> NIL THEN
     sort_message_module_dictionary (message_module_dictionary^);
   IFEND;

   IF help_module_dictionary <> NIL THEN
     sort_help_module_dictionary (help_module_dictionary^);
   IFEND;

   IF panel_dictionary <> NIL THEN
     sort_panel_dictionary (panel_dictionary^);
   IFEND;




 PROCEND generate_temporary_library;
?? OLDTITLE ??
?? EJECT ??


 VAR
   load_module_list: oct$load_module_list;


 build_load_module_list (ocv$nlm_list, load_module_list, status);


 IF status.normal THEN

   generate_temporary_library (load_module_list, temporary_library_file, status);

 IFEND;


 PROCEND generate_temporary_library_file;
?? OLDTITLE ??
?? NEWTITLE := 'add_modules_from_temporary_back', EJECT ??

{ PURPOSE:
{   The purpose of this request is to recover the generated library or file
{   to allow the user the opportunity to re-enter the generate_library
{   subcommand.
{ DESIGN:
{   This procedure basically does an "add_module" of the temporary segment.
{ NOTES:
{   Since the library or file has already been generated successfully,
{   (up to the point of writing to the output file) there is no need to check
{   for NIL pointers or bad status from the procedure calls.


 PROCEDURE add_modules_from_temporary_back
   (    format: clt$keyword;
    VAR temporary: amt$segment_pointer);

   VAR
     addition_list: oct$nlm_modification_list,
     current_module: 1 .. llc$max_modules_in_library + 1,
     file_descriptor: ^oct$open_file_list,
     ignore_status: ost$status,
     last_addition: ^oct$nlm_modification_list;


   ocp$initialize_olg_working_heap;
   RESET ocv$olg_scratch_seq;

   ALLOCATE file_descriptor IN ocv$olg_working_heap^;
   file_descriptor^.name := 'TEMPORARY';

   IF format = 'FILE' THEN
     file_descriptor^.kind := occ$file;

{ The procedure ocp$build_file_dir_from_temp is dependent on the temporary
{ sequence being positioned at the end of the last module. Do NOT reset the
{ sequence before this call.

     ocp$build_file_dir_from_temp (temporary.sequence_pointer, file_descriptor);

   ELSE {format = 'LIBRARY'
     file_descriptor^.kind := occ$library;
     ocp$build_library_directory (temporary.sequence_pointer, file_descriptor, ignore_status);
   IFEND;

   addition_list.link := NIL;
   last_addition := ^addition_list;

   FOR current_module := 1 TO UPPERBOUND (file_descriptor^.directory^) DO
     NEXT last_addition^.link IN ocv$olg_scratch_seq;
     last_addition := last_addition^.link;

     last_addition^.link := NIL;

     ocp$create_an_nlm (^file_descriptor^.directory^ [current_module], last_addition^.nlm, ignore_status);

   FOREND;

   ocp$add_additions_to_nlm_list (ocv$nlm_list^.b_link, ^addition_list);

 PROCEND add_modules_from_temporary_back;
?? OLDTITLE ??
?? NEWTITLE := 'copy_temporary_to_output_file', EJECT ??

 PROCEDURE copy_temporary_to_output_file
   (    format: clt$keyword;
        output_file_name: fst$file_reference;
    VAR temporary: amt$segment_pointer;
    VAR status: ost$status);

?? NEWTITLE := 'copy_files', EJECT ??

   PROCEDURE copy_files
     (    format: clt$keyword;
          output_file_name: fst$file_reference;
      VAR temporary: amt$segment_pointer;
      VAR status: ost$status);

?? NEWTITLE := 'condition_handler', EJECT ??

     PROCEDURE condition_handler
       (    condition: pmt$condition;
            condition_descriptor: ^pmt$condition_information;
            save_area: ^ost$stack_frame_save_area;
        VAR condition_status: ost$status);

{ Ignore the condition.

       RETURN;

     PROCEND condition_handler;
?? OLDTITLE, EJECT ??

     VAR
       attachment_options: array [1 .. 2] of fst$attachment_option,
       creation_validation_attributes: array [1 .. 2] of fst$file_cycle_attribute,
       output: amt$segment_pointer,
       output_file: ^SEQ ( * ),
       output_id: amt$file_identifier,
       size: ost$segment_offset,
       temporary_file: ^SEQ ( * );


     VAR
       established_conditions: pmt$condition,
       established_descriptor: pmt$established_handler;


     established_conditions.selector := pmc$condition_combination;
     established_conditions.combination := $pmt$condition_combination
           [ifc$interactive_condition, pmc$block_exit_processing];

     pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
           status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

     attachment_options [1].selector := fsc$access_and_share_modes;
     attachment_options [1].access_modes.selector := fsc$specific_access_modes;
     attachment_options [1].access_modes.value := $fst$file_access_options
           [fsc$append, fsc$modify, fsc$shorten];
     attachment_options [1].share_modes.selector := fsc$specific_share_modes;
     attachment_options [1].share_modes.value := $fst$file_access_options [];
     attachment_options [2].selector := fsc$delete_data;
     attachment_options [2].delete_data := TRUE;

     creation_validation_attributes [1].selector := fsc$file_contents_and_processor;
     IF format = 'LIBRARY' THEN
       creation_validation_attributes [1].file_contents := fsc$object_library;
     ELSE
       creation_validation_attributes [1].file_contents := fsc$object_data;
     IFEND;
     creation_validation_attributes [1].file_processor := amc$unknown_processor;
     creation_validation_attributes [2].selector := fsc$record_type;
     creation_validation_attributes [2].record_type := amc$undefined;
     fsp$open_file (output_file_name, amc$segment, ^attachment_options, NIL, ^creation_validation_attributes,
           ^creation_validation_attributes, NIL, output_id, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

     amp$get_segment_pointer (output_id, amc$sequence_pointer, output, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

     IF output.sequence_pointer = NIL THEN
       RETURN; { $NULL }
     IFEND;

     size := i#current_sequence_position (temporary.sequence_pointer);

     IF size > 0 THEN
       RESET temporary.sequence_pointer;
       NEXT temporary_file: [[REP size OF cell]] IN temporary.sequence_pointer;

       RESET output.sequence_pointer;
       NEXT output_file: [[REP size OF cell]] IN output.sequence_pointer;
       IF output_file = NIL THEN
         osp$set_status_abnormal (oc, oce$e_eof_on_generated_file, '', status);
         RETURN;
       IFEND;

       syp$advised_move_bytes (#LOC (temporary_file^), #LOC (output_file^), size, status);
       IF NOT status.normal THEN
         RETURN;
       IFEND;
     ELSE
       RESET output.sequence_pointer;
     IFEND;

     amp$set_segment_eoi (output_id, output, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

     fsp$close_file (output_id, status);
     IF NOT status.normal THEN
       RETURN;
     IFEND;

     pmp$disestablish_cond_handler (established_conditions, status);

   PROCEND copy_files;
?? OLDTITLE ??
?? EJECT ??


   status.normal := TRUE;

   ocp$close_all_open_files (ocv$open_file_list);
   ocp$return_files;

   copy_files (format, output_file_name, temporary, status);
   IF NOT status.normal THEN
     ocp$generate_message (status);
     add_modules_from_temporary_back (format, temporary);
     osp$set_status_abnormal (oc, oce$generate_not_complete, output_file_name, status);
   IFEND;

 PROCEND copy_temporary_to_output_file;
?? OLDTITLE ??
?? EJECT ??

 VAR
   temporary_file: amt$segment_pointer;


 mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, temporary_file, status);
 IF NOT status.normal THEN
   RETURN;
 IFEND;

 IF format = 'FILE' THEN
   generate_temporary_object_file (temporary_file.sequence_pointer, status);
 ELSE
   generate_temporary_library_file (temporary_file.sequence_pointer, status);
 IFEND;
 IF NOT status.normal THEN
   RETURN;
 IFEND;

 IF library_value.kind = clc$file THEN
   copy_temporary_to_output_file (format, library_value.file_value^, temporary_file, status);
   IF NOT status.normal THEN
     RETURN;
   IFEND;
 ELSE {library_value.kind = clc$keyword
   ocp$close_all_open_files (ocv$open_file_list);
   ocp$return_files;
   add_modules_from_temporary_back (format, temporary_file);
 IFEND;

 PROCEND generate_object_file;
?? OLDTITLE ??
?? EJECT ??

{ PROCEDURE (ocm$creol_genl) generate_library, genl (
{   library, l: any of
{       key
{         (new_library, nl)
{       keyend
{       file
{     anyend = $required
{   format, f: key
{       (library, l)
{       (file, f)
{       (scl_procedure, scl_proc, sp)
{       (message_module, mm)
{       (form_source, fs)
{       (form_variable, fv)
{     keyend = library
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 13] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 1, 9, 10, 51, 23, 102],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'OCM$CREOL_GENL'], [
    ['F                              ',clc$abbreviation_entry, 2],
    ['FORMAT                         ',clc$nominal_entry, 2],
    ['L                              ',clc$abbreviation_entry, 1],
    ['LIBRARY                        ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 104,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 488,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['NEW_LIBRARY                    ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['NL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [13], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FILE                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['FORM_SOURCE                    ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['FORM_VARIABLE                  ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['FS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['FV                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['LIBRARY                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['MESSAGE_MODULE                 ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['MM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['SCL_PROC                       ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['SCL_PROCEDURE                  ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['SP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3]]
    ,
    'library'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$library = 1,
      p$format = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


 VAR
   ignore_status: ost$status;

 VAR
   established_conditions: pmt$condition,
   established_descriptor: pmt$established_handler;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

 PROCEDURE condition_handler
   (    condition: pmt$condition;
        condition_descriptor: ^pmt$condition_information;
        save_area: ^ost$stack_frame_save_area;
    VAR handler_status: ost$status);

   VAR
     ignore_status: ost$status,
     message: ost$status;

   IF (condition.selector = pmc$block_exit_processing) THEN
     ocp$close_all_open_files (ocv$open_file_list);
     ocp$return_files;
     ocp$initialize_olg_working_heap;
     RESET ocv$olg_scratch_seq;
   ELSEIF (condition.selector = ifc$interactive_condition) AND
         (condition.interactive_condition = ifc$terminate_break) THEN
     osp$set_status_from_condition (oc, condition, save_area, message, ignore_status);
     ocp$generate_message (message);
     osp$set_status_condition (oce$e_generate_terminated, status);
     EXIT ocp$generate;
   ELSE
     pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
   IFEND;

 PROCEND condition_handler;
?? OLDTITLE ??
?? EJECT ??

 status.normal := TRUE;
 command_status.normal := TRUE;
 established_conditions.selector := pmc$condition_combination;
 established_conditions.combination := $pmt$condition_combination
       [ifc$interactive_condition, pmc$block_exit_processing];

 clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
 IF NOT status.normal THEN
   RETURN;
 IFEND;

 IF ocv$nlm_list^.f_link^.name = osc$null_name THEN
   osp$set_status_abnormal (oc, oce$e_no_modules_on_current_lib, '', status);
   RETURN;
 IFEND;

 IF (pvt [p$library].value^.kind = clc$keyword) AND (pvt [p$format].value^.keyword_value <> 'LIBRARY') AND
       (pvt [p$format].value^.keyword_value <> 'FILE') THEN
   osp$set_status_abnormal (oc, oce$format_not_allowed_with_nl, pvt [p$format].value^.keyword_value, status);
   osp$append_status_parameter (osc$status_parameter_delimiter, pvt [p$library].value^.keyword_value,
         status);
   RETURN;
 IFEND;

 pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
       status);
 IF NOT status.normal THEN
   RETURN;
 IFEND;

 RESET ocv$olg_scratch_seq;
 mmp$set_access_selections (ocv$olg_scratch_seq, mmc$as_sequential, status);
 IF NOT status.normal THEN
   RETURN;
 IFEND;

 initialize_working_segments (status);
 IF NOT status.normal THEN
   RETURN;
 IFEND;

 IF pvt [p$format].value^.keyword_value = 'SCL_PROCEDURE' THEN
   generate_scl_proc_file (pvt [p$library].value^.file_value^, status);

 ELSEIF pvt [p$format].value^.keyword_value = 'MESSAGE_MODULE' THEN
   generate_message_module_file (pvt [p$library].value^.file_value^, status);

 ELSEIF pvt [p$format].value^.keyword_value = 'FORM_SOURCE' THEN
   generate_form_source_file (pvt [p$library].value^.file_value^, status);

 ELSEIF pvt [p$format].value^.keyword_value = 'FORM_VARIABLE' THEN
   generate_form_variable_file (pvt [p$library].value^.file_value^, status);

 ELSE
   generate_object_file (pvt [p$format].value^.keyword_value, pvt [p$library].value^, status);
   IF (NOT status.normal) AND (status.condition <> oce$generate_not_complete) THEN
     RETURN;
   IFEND;

 IFEND;

 pmp$disestablish_cond_handler (established_conditions, ignore_status);

 IF NOT status.normal THEN
   RETURN;
 IFEND;

 status := command_status;

{ Clean up.

 IF pvt [p$library].value^.kind <> clc$keyword THEN
   ocp$close_all_open_files (ocv$open_file_list);
   ocp$return_files;
   ocp$initialize_olg_working_heap;
   RESET ocv$olg_scratch_seq;
 IFEND;

 PROCEND ocp$generate;
?? OLDTITLE ??
 MODEND ocm$generate;
*DECK DECK=OCM$GENERATE_OBJECT_CORRECTION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Management : Correction Generation' ??
MODULE ocm$generate_object_correction;

{ PURPOSE:
{ The procedures in this module create a correction for an object
{ library when given an old version of an object library a new version of the
{ same object library.
{
{ DESIGN:
{  This module is compiled to RAF$LIBRARY.
{
{  NOTES:
{
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$error_messages
*copyc llt$module_dictionary
*copyc oce$metapatch_generator_errors
*copyc oct$breaklist
*copyc oct$corrector
*copyc oct$fill_sequence
*copyc oct$metapatch_header
*copyc oct$module_directory
*copyc oct$move_items
*copyc oct$predictor_header
*copyc rat$subproduct_info_types
?? POP ??
*copyc i#current_sequence_position
*copyc amp$get_segment_pointer
*copyc fsp$close_file
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc mmp$set_access_selections
*copyc ocp$apply_corrector
*copyc ocp$build_corrector
*copyc ocp$build_first_intermediate_ol
*copyc ocp$build_second_inter_ol
*copyc ocp$checksum
*copyc ocp$construct_breaklist
*copyc ocp$generate_ol_predictor
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pmp$get_unique_name
*copyc rap$open_file
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$generate_object_correction' ??
*copy och$generate_metapatch

  PROCEDURE [XDCL] ocp$generate_object_correction
    (    old_file_name: fst$file_reference;
         new_file_name: fst$file_reference;
         calculate_checksums: boolean;
         old_file_checksum: rat$checksum;
         new_file_checksum: rat$checksum;
     VAR metapatch: ^SEQ ( * );
     VAR size: oct$corrector_size;
     VAR status: ost$status);

    VAR
      corrector_seg: amt$segment_pointer,
      first_intermediate_ol: amt$segment_pointer,
      i: llt$module_index,
      length_of_new_breaklist: oct$breaklist_length,
      length_of_old_breaklist: oct$breaklist_length,
      local_status: ost$status,
      metapatch_header: ^oct$metapatch_header,
      module_directory: ^oct$module_directory,
      move_items: ^oct$move_items,
      new_break_seg: amt$segment_pointer,
      new_breaklist: ^oct$breaklist,
      new_breaks: ^SEQ ( * ),
      new_fid: amt$file_identifier,
      new_file_opened: boolean,
      new_ol: amt$segment_pointer,
      number_of_move_items: oct$breaklist_index,
      old_break_seg: amt$segment_pointer,
      old_breaklist: ^oct$breaklist,
      old_breaks: ^SEQ ( * ),
      old_fid: amt$file_identifier,
      old_file_opened: boolean,
      old_ol: amt$segment_pointer,
      original_object_library: boolean,
      predictor: amt$segment_pointer,
      result: amt$segment_pointer,
      result_checksum: integer,
      result_seq_p: ^SEQ ( * ),
      result_size: integer,
      scratch_segment: amt$segment_pointer,
      second_intermediate_ol: amt$segment_pointer;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the file has been opened, it will be closed before the
{   the procedure returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF old_file_opened THEN
        fsp$close_file (old_fid, ignore_status);
        old_file_opened := FALSE;
      IFEND;

      IF new_file_opened THEN
        fsp$close_file (new_fid, ignore_status);
        new_file_opened := FALSE;
      IFEND;

      IF result.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (result, local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;
      IFEND;

      IF predictor.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (predictor, ignore_status);
      IFEND;

      IF first_intermediate_ol.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (first_intermediate_ol, ignore_status);
      IFEND;

      IF old_break_seg.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (old_break_seg, ignore_status);
      IFEND;

      IF new_break_seg.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (new_break_seg, ignore_status);
      IFEND;

      IF second_intermediate_ol.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (second_intermediate_ol, ignore_status);
      IFEND;

      IF scratch_segment.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (scratch_segment, ignore_status);
      IFEND;

      IF corrector_seg.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (corrector_seg, ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    new_file_opened := FALSE;
    old_file_opened := FALSE;
    result.sequence_pointer := NIL;
    predictor.sequence_pointer := NIL;
    first_intermediate_ol.sequence_pointer := NIL;
    old_break_seg.sequence_pointer := NIL;
    new_break_seg.sequence_pointer := NIL;
    scratch_segment.sequence_pointer := NIL;
    second_intermediate_ol.sequence_pointer := NIL;
    corrector_seg.sequence_pointer := NIL;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      rap$open_file (^old_file_name, amc$segment, fsc$read, FALSE, NIL, old_fid, old_file_opened, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$open_file (^new_file_name, amc$segment, fsc$read, FALSE, NIL, new_fid, new_file_opened, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (old_fid, amc$sequence_pointer, old_ol, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (new_fid, amc$sequence_pointer, new_ol, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, predictor, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      ocp$generate_ol_predictor (old_file_name, new_file_name, old_ol, new_ol, predictor, module_directory,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, first_intermediate_ol, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      ocp$build_first_intermediate_ol (predictor.sequence_pointer, old_ol.sequence_pointer,
            first_intermediate_ol.sequence_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, old_break_seg, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      old_breaks := old_break_seg.sequence_pointer;
      original_object_library := TRUE;

      ocp$construct_breaklist (old_ol.sequence_pointer, module_directory, original_object_library,
            first_intermediate_ol.sequence_pointer, old_breaklist, old_breaks, length_of_old_breaklist,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, new_break_seg, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      new_breaks := new_break_seg.sequence_pointer;
      original_object_library := FALSE;

      ocp$construct_breaklist (new_ol.sequence_pointer, module_directory, original_object_library,
            first_intermediate_ol.sequence_pointer, new_breaklist, new_breaks, length_of_new_breaklist,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, second_intermediate_ol, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, scratch_segment, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      RESET scratch_segment.sequence_pointer;

      ocp$build_second_inter_ol (first_intermediate_ol.sequence_pointer, new_breaklist,
            length_of_new_breaklist, old_breaklist, length_of_old_breaklist,
            second_intermediate_ol.sequence_pointer, scratch_segment.sequence_pointer, move_items,
            number_of_move_items);

      FOR i := 1 TO UPPERBOUND (module_directory^) DO
        IF module_directory^ [i].section_number_change_list <> NIL THEN
          FREE module_directory^ [i].section_number_change_list;
        IFEND;
      FOREND;
      FREE module_directory;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, corrector_seg, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      ocp$build_corrector (old_breaklist, new_breaklist, second_intermediate_ol.sequence_pointer,
            new_ol.sequence_pointer, length_of_old_breaklist, length_of_new_breaklist,
            corrector_seg.sequence_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      construct_metapatch (predictor, move_items, number_of_move_items, corrector_seg.sequence_pointer,
            metapatch, size);

      RESET metapatch;
      NEXT metapatch_header IN metapatch;

      IF calculate_checksums THEN
        metapatch_header^.old_checksum := ocp$checksum (old_ol.sequence_pointer);
        metapatch_header^.new_checksum := ocp$checksum (new_ol.sequence_pointer);
      ELSE
        metapatch_header^.old_checksum := old_file_checksum;
        metapatch_header^.new_checksum := new_file_checksum;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, result, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      ocp$apply_corrector (corrector_seg.sequence_pointer, second_intermediate_ol.sequence_pointer,
            result.sequence_pointer);

      result_size := i#current_sequence_position (result.sequence_pointer);

      RESET result.sequence_pointer;
      NEXT result_seq_p: [[REP result_size OF cell]] IN result.sequence_pointer;

      result_checksum := ocp$checksum (result_seq_p);
      IF result_checksum <> metapatch_header^.new_checksum THEN
        osp$set_status_abnormal (occ$status_id, oce$bad_metapatch_generated, '', status);
        EXIT /main/;
      IFEND;

    END /main/;

    IF old_file_opened THEN
      fsp$close_file (old_fid, local_status);
      old_file_opened := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF new_file_opened THEN
      fsp$close_file (new_fid, local_status);
      new_file_opened := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF result.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (result, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF predictor.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (predictor, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF first_intermediate_ol.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (first_intermediate_ol, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF old_break_seg.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (old_break_seg, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF new_break_seg.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (new_break_seg, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF second_intermediate_ol.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (second_intermediate_ol, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF scratch_segment.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (scratch_segment, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF corrector_seg.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (corrector_seg, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND ocp$generate_object_correction;

?? OLDTITLE ??
?? NEWTITLE := 'construct_metapatch', EJECT ??
*copy och$construct_metapatch

  PROCEDURE construct_metapatch
    (    p_predictor: amt$segment_pointer,
         move_items: ^oct$move_items;
         number_of_move_items: oct$breaklist_index;
         p_corrector: ^SEQ ( * );
     VAR metapatch: ^SEQ ( * );
     VAR length: oct$corrector_size);

    VAR
      corrector: ^SEQ ( * ),
      corrector_header: ^oct$corrector_header,
      corrector_seq: ^SEQ ( * ),
      meta_corrector: ^SEQ ( * ),
      meta_move_items: ^oct$move_items,
      meta_predictor: ^oct$predictor,
      metapatch_header: ^oct$metapatch_header,
      predictor: amt$segment_pointer,
      predictor_header: ^oct$predictor_header,
      predictor_seq: ^oct$predictor,
      predictor_size: oct$predictor_size;

    predictor := p_predictor;
    corrector := p_corrector;

    RESET metapatch;
    NEXT metapatch_header IN metapatch;
    metapatch_header^.size_of_metapatch := #SIZE (metapatch_header^);

    RESET predictor.sequence_pointer;
    NEXT predictor_header IN predictor.sequence_pointer;
    predictor_size := predictor_header^.size_predictor;

    RESET predictor.sequence_pointer;

    IF predictor_size > 0 THEN
      NEXT predictor_seq: [[REP predictor_size OF cell]] IN predictor.sequence_pointer;
      NEXT meta_predictor: [[REP predictor_size OF cell]] IN metapatch;
      meta_predictor^ := predictor_seq^;
      metapatch_header^.size_of_metapatch := metapatch_header^.size_of_metapatch + predictor_size;
      metapatch_header^.predictor := #REL (meta_predictor, metapatch^);
      metapatch_header^.predictor_size := predictor_size;
    ELSE
      metapatch_header^.predictor_size := 0;
    IFEND;

    IF number_of_move_items > 0 THEN
      NEXT meta_move_items: [1 .. number_of_move_items] IN metapatch;
      meta_move_items^ := move_items^;
      metapatch_header^.size_of_metapatch := metapatch_header^.size_of_metapatch + #SIZE (meta_move_items^);
      metapatch_header^.move_items := #REL (meta_move_items, metapatch^);
      metapatch_header^.number_of_move_items := number_of_move_items;
    ELSE
      metapatch_header^.number_of_move_items := 0;
    IFEND;

    RESET corrector;
    NEXT corrector_header IN corrector;

    RESET corrector;
    IF corrector_header^.number_of_correctors > 0 THEN
      NEXT corrector_seq: [[REP corrector_header^.size OF cell]] IN corrector;
      NEXT meta_corrector: [[REP corrector_header^.size OF cell]] IN metapatch;
      meta_corrector^ := corrector_seq^;
      metapatch_header^.size_of_metapatch := metapatch_header^.size_of_metapatch + corrector_header^.size;
      metapatch_header^.corrector := #REL (meta_corrector, metapatch^);
      metapatch_header^.corrector_size := corrector_header^.size;
    ELSE
      metapatch_header^.corrector_size := 0;
    IFEND;

    length := metapatch_header^.size_of_metapatch;
  PROCEND construct_metapatch;

MODEND ocm$generate_object_correction;
*DECK DECK=OCM$GENERATE_PREDICTOR EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$generate_predictor;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc amt$segment_pointer
*copyc amt$file_identifier
*copyc clt$file
*copyc oce$metapatch_generator_errors
*copyc oct$bytes
*copyc oct$section_directory
*copyc oct$section_list
*copyc oct$name_index_changes
*copyc oct$offset_change_list
*copyc oct$section_offset_changes
*copyc oct$single_module_predictor_hdr
*copyc oct$predictor_header
*copyc oct$predictor_size
*copyc oct$fill_sequence
*copyc occ$generate_predictor
*copyc oct$module_directory
*copyc ost$mtm_condition_codes
*copyc ost$mtm_condition_names
*copyc ost$mtm_header
*copyc ost$status_condition_code
*copyc ost$name
*copyc ost$status
*copyc pmt$program_name
*copyc llt$information_element
*copyc llt$load_module_header
*copyc llt$section_address
*copyc llt$object_text_descriptor
*copyc llt$entry_point_dictionary
*copyc llt$identification
*copyc llt$module_dictionary
*copyc llt$object_library_header
*copyc llt$library_member_header
*copyc llt$section_definition
*copyc llt$segment_definition
*copyc llt$obsolete_segment_definition
*copyc llt$command_dictionary
*copyc llt$function_dictionary
*copyc llt$help_module_dictionary
*copyc llt$message_module_dictionary
*copyc llt$panel_dictionary
?? POP ??
*copyc i#move
*copyc amp$get_segment_pointer
*copyc fsp$close_file
*copyc fsp$open_file
*copyc ocp$new_offset
*copyc ocp$convert_information_element
*copyc osp$set_status_abnormal
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc pmp$zero_out_table
*copyc pmp$get_unique_name

?? EJECT ??
?? TITLE := 'OCP$GENERATE_OL_PREDICTOR' ??
?? NEWTITLE := 'BUILD_BINDING_SECTION_CV' ??

*copyc och$build_binding_section_cv

  PROCEDURE build_binding_section_cv
    (    old_module_header: ^llt$load_module_header;
         new_module_header: ^llt$load_module_header;
         section_directory: ^oct$section_directory;
         old_file_name: fst$file_reference;
         new_file_name: fst$file_reference;
         old_ol: amt$segment_pointer;
         new_ol: amt$segment_pointer;
     VAR binding_section_offset_cv: ^oct$offset_change_list;
     VAR status: ost$status);

    VAR
      binding_section_changes: ^oct$offset_change_list,
      expected_offset: llt$section_address_range,
      expected_section_ordinal: llt$section_ordinal,
      i: integer,
      j: integer,
      length: 0 .. llc$max_binding_items,
      match_found: boolean,
      new_binding_templates: ^llt$binding_section_template,
      new_info_element_hdr: ^llt$info_element_header,
      new_information_element: llt$info_element_header,
      new_position: 0 .. llc$max_binding_items,
      old_binding_templates: ^llt$binding_section_template,
      old_info_element_hdr: ^llt$info_element_header,
      old_information_element: llt$info_element_header,
      old_position: 0 .. llc$max_binding_items,
      search_complete: boolean,
      starting_position: 0 .. llc$max_binding_items;

    status.normal := TRUE;

    old_info_element_hdr := #PTR (old_module_header^.information_element, old_ol.sequence_pointer^);
    new_info_element_hdr := #PTR (new_module_header^.information_element, new_ol.sequence_pointer^);
    IF old_info_element_hdr^.version = llc$info_element_version THEN
      old_information_element := old_info_element_hdr^;
    ELSEIF old_info_element_hdr^.version = llc$info_element_version_1_0 THEN
      ocp$convert_information_element (old_info_element_hdr, old_information_element);
    ELSE
      osp$set_status_abnormal (occ$status_id, oce$invalid_library_version, old_file_name, status);
      RETURN;
    IFEND;

    IF new_info_element_hdr^.version = llc$info_element_version THEN
      new_information_element := new_info_element_hdr^;
    ELSEIF new_info_element_hdr^.version = llc$info_element_version_1_0 THEN
      ocp$convert_information_element (new_info_element_hdr, new_information_element);
    ELSE
      osp$set_status_abnormal (occ$status_id, oce$invalid_library_version, new_file_name, status);
      RETURN;
    IFEND;

    IF (old_information_element.number_of_template_items > 0) AND
          (new_information_element.number_of_template_items > 0) THEN
      old_binding_templates := #PTR (old_information_element.binding_template_ptr, old_ol.sequence_pointer^);
      new_binding_templates := #PTR (new_information_element.binding_template_ptr, new_ol.sequence_pointer^);
      PUSH binding_section_changes: [1 .. old_information_element.number_of_template_items];
      i := 1;
      starting_position := 1;

    /search_for_match/
      FOR old_position := 1 TO old_information_element.number_of_template_items DO
        new_position := starting_position;
        match_found := FALSE;
        search_complete := FALSE;
        WHILE NOT match_found AND NOT search_complete DO
          IF old_binding_templates^ [old_position].kind = new_binding_templates^ [new_position].kind THEN
            IF old_binding_templates^ [old_position].kind = llc$current_module THEN
              IF section_directory^ [old_binding_templates^ [old_position].section_ordinal].
                    new_section_number = occ$invalid_section_ordinal THEN
                CYCLE /search_for_match/;
              IFEND;
              expected_section_ordinal := section_directory^ [old_binding_templates^ [old_position].
                    section_ordinal].new_section_number;
              expected_offset := ocp$new_offset (old_binding_templates^ [old_position].offset,
                    section_directory^ [old_binding_templates^ [old_position].section_ordinal].
                    section_offset_change_vector);
              match_found := (expected_section_ordinal = new_binding_templates^ [new_position].
                    section_ordinal) AND (expected_offset = new_binding_templates^ [new_position].offset);
            ELSE
              match_found := (old_binding_templates^ [old_position].
                    name = new_binding_templates^ [new_position].name);
            IFEND;
          IFEND;
          IF match_found THEN
            binding_section_changes^ [i].offset := (old_binding_templates^ [old_position].binding_offset DIV
                  8) * 8;
            binding_section_changes^ [i].delta := new_binding_templates^ [new_position].binding_offset -
                  old_binding_templates^ [old_position].binding_offset;
            i := i + 1;
            starting_position := new_position + 1;
            IF starting_position > new_information_element.number_of_template_items THEN
              starting_position := 1;
            IFEND;
          ELSE
            new_position := new_position + 1;
            IF new_position > new_information_element.number_of_template_items THEN
              new_position := 1;
            IFEND;
            search_complete := (new_position = starting_position);
          IFEND;
        WHILEND;
      FOREND /search_for_match/;
      length := i - 1;
      i := 1;
      WHILE (i <= length) AND (binding_section_changes^ [i].delta = 0) DO
        i := i + 1;
      WHILEND;
      IF (i = length + 1) OR (length = 0) THEN
        RETURN;
      IFEND;

      j := 2;
      i := 2;
      WHILE i <= length DO
        WHILE (i <= length) AND (binding_section_changes^ [i - 1].delta = binding_section_changes^ [i].
              delta) DO
          i := i + 1;
        WHILEND;
        IF i <= length THEN
          binding_section_changes^ [j] := binding_section_changes^ [i];
          j := j + 1;
          i := i + 1;
        IFEND;
      WHILEND;
      length := j - 1;
      ALLOCATE binding_section_offset_cv: [1 .. length];
      FOR i := 1 TO length DO
        binding_section_offset_cv^ [i] := binding_section_changes^ [i];
      FOREND;
    IFEND;
  PROCEND build_binding_section_cv;
?? EJECT ??
?? OLDTITLE ??
?? NEWTITLE := 'BUILD_COMPONENT_INDEX_CV' ??
*copyc och$build_component_index_cv

  PROCEDURE build_component_index_cv
    (    old_module_header: ^llt$load_module_header;
         new_module_header: ^llt$load_module_header;
         old_ol: amt$segment_pointer;
         new_ol: amt$segment_pointer;
     VAR length_component_index_cv: 0 .. llc$max_components;
     VAR component_index_cv: ^array [1 .. * ] of 0 .. llc$max_components;
     VAR module_directory_item: oct$module_directory_item;
     VAR status: ost$status);

    VAR
      i: 0 .. llc$max_components,
      j: 0 .. llc$max_components,
      match_found: boolean,
      new_components: ^llt$component_information,
      new_info_element: ^llt$info_element_header,
      new_information_element: llt$info_element_header,
      old_components: ^llt$component_information,
      old_info_element: ^llt$info_element_header,
      old_information_element: llt$info_element_header,
      search_complete: boolean,
      start: 0 .. llc$max_components;

    status.normal := TRUE;

    length_component_index_cv := 0;
    component_index_cv := NIL;

    old_info_element := #PTR (old_module_header^.information_element, old_ol.sequence_pointer^);
    new_info_element := #PTR (new_module_header^.information_element, new_ol.sequence_pointer^);

    IF old_info_element^.version = llc$info_element_version THEN
      old_information_element := old_info_element^;
    ELSE
      ocp$convert_information_element (old_info_element, old_information_element);
    IFEND;

    IF new_info_element^.version = llc$info_element_version THEN
      new_information_element := new_info_element^;
    ELSE
      ocp$convert_information_element (new_info_element, new_information_element);
    IFEND;

    module_directory_item.number_of_components := old_information_element.number_of_components;

    IF (old_information_element.number_of_components = 0) OR
          (new_information_element.number_of_components = 0) THEN
      RETURN;
    IFEND;

    old_components := #PTR (old_information_element.component_ptr, old_ol.sequence_pointer^);
    new_components := #PTR (new_information_element.component_ptr, new_ol.sequence_pointer^);

    ALLOCATE component_index_cv: [1 .. UPPERBOUND (old_components^)];
    start := 1;

    FOR i := 1 TO UPPERBOUND (old_components^) DO
      match_found := FALSE;
      search_complete := FALSE;
      component_index_cv^ [i] := i;
      j := start;
      WHILE NOT match_found AND NOT search_complete DO
        match_found := (old_components^ [i].name = new_components^ [j].name);
        IF match_found THEN
          component_index_cv^ [i] := j;
          start := j + 1;
          IF start > UPPERBOUND (new_components^) THEN
            start := 1;
          IFEND;
        ELSE
          j := j + 1;
          IF j > UPPERBOUND (new_components^) THEN
            j := 1;
          IFEND;
          search_complete := (j = start);
        IFEND;
      WHILEND;
    FOREND;
    length_component_index_cv := UPPERBOUND (old_components^);
  PROCEND build_component_index_cv;


?? EJECT ??
?? OLDTITLE ??
?? NEWTITLE := 'BUILD_LOAD_MODULE_PREDICTOR' ??
*copyc och$build_load_module_predictor

  PROCEDURE build_load_module_predictor
    (    old_module_header: ^llt$load_module_header;
         new_module_header: ^llt$load_module_header;
         module_name: pmt$program_name;
         old_file_name: fst$file_reference;
         new_file_name: fst$file_reference;
         p_old_ol: amt$segment_pointer;
         new_ol: amt$segment_pointer;
     VAR single_predictor: ^SEQ ( * );
     VAR single_predictor_size: oct$module_predictor_size;
     VAR module_directory_item: oct$module_directory_item;
     VAR status: ost$status);

    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      binding_section: llt$section_ordinal,
      binding_section_found: boolean,
      binding_section_ocv: ^oct$offset_change_list,
      change_list: ^oct$section_number_change_list,
      component_index_cv: ^array [1 .. * ] of 0 .. llc$max_components,
      end_of_sec_defs: boolean,
      i: llt$section_ordinal,
      length_component_index_cv: 0 .. llc$max_components,
      local_status: ost$status,
      module_is_bound: boolean,
      normal_socv: amt$segment_pointer,
      nsocv_fid: amt$file_identifier,
      nsocv_file_opened: boolean,
      nsocv_lfn: ost$name,
      number_section_offset_cvs: llt$section_ordinal,
      object_text_descriptor: ^llt$object_text_descriptor,
      obsolete_segment_definition: ^llt$obsolete_segment_definition,
      old_ol: amt$segment_pointer,
      section_definition: ^llt$section_definition,
      section_definitions: ^llt$object_text_descriptor,
      section_directory: ^oct$section_directory,
      section_number_cv: ^oct$new_ordinal_list,
      segment_definition: ^llt$segment_definition;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the file has been opened, it will be closed before the
{   the procedure returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF nsocv_file_opened THEN
        fsp$close_file (nsocv_fid, ignore_status);
        nsocv_file_opened := FALSE;
      IFEND;

      IF section_number_cv <> NIL THEN
        FREE section_number_cv;
      IFEND;

      FREE section_directory;
      IF binding_section_ocv <> NIL THEN
        FREE binding_section_ocv;
      IFEND;

      IF component_index_cv <> NIL THEN
        FREE component_index_cv;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    nsocv_file_opened := FALSE;

    old_ol := p_old_ol;

    single_predictor_size := 0;

    section_directory := NIL;
    section_number_cv := NIL;
    build_section_number_cv (old_module_header, new_module_header, old_ol,
          new_ol, section_number_cv, module_is_bound, section_directory,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    module_directory_item.bound_module := module_is_bound;
    IF section_directory <> NIL THEN
      module_directory_item.last_section_ordinal :=
            UPPERBOUND (section_directory^);

      ALLOCATE change_list: [0 .. module_directory_item.last_section_ordinal];
      FOR i := 0 TO module_directory_item.last_section_ordinal DO
        change_list^ [i] := section_directory^ [i].new_section_number;
      FOREND;
      module_directory_item.section_number_change_list := change_list;
    ELSE
      module_directory_item.last_section_ordinal :=
            occ$invalid_section_ordinal;
      module_directory_item.section_number_change_list := NIL;
      RETURN;
    IFEND;

    number_section_offset_cvs := 0;
    component_index_cv := NIL;

    FOR i := 0 TO UPPERBOUND (section_directory^) DO
      section_directory^ [i].section_offset_change_vector := NIL;
    FOREND;
    length_component_index_cv := 0;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      IF module_is_bound THEN
        pmp$get_unique_name (nsocv_lfn, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        attachment_options [1].selector := fsc$access_and_share_modes;
        attachment_options [1].access_modes.selector := fsc$specific_access_modes;
        attachment_options [1].access_modes.value := $fst$file_access_options
              [fsc$read, fsc$shorten, fsc$append, fsc$modify];
        attachment_options [1].share_modes.selector := fsc$determine_from_access_modes;
        attachment_options [2].selector := fsc$create_file;
        attachment_options [2].create_file := TRUE;
        attachment_options [3].selector := fsc$wait_for_attachment;
        attachment_options [3].wait_for_attachment.wait := osc$wait;
        attachment_options [3].wait_for_attachment.wait_time := fsc$longest_wait_time;

        nsocv_file_opened := TRUE;
        fsp$open_file (nsocv_lfn, amc$segment, ^attachment_options, NIL, NIL, NIL, NIL, nsocv_fid, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        amp$get_segment_pointer (nsocv_fid, amc$sequence_pointer, normal_socv,
              status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        build_normal_offset_cv (old_module_header, new_module_header, new_file_name, old_file_name, old_ol,
              new_ol, normal_socv, section_directory,
              number_section_offset_cvs, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        build_component_index_cv (old_module_header, new_module_header, old_ol,
              new_ol, length_component_index_cv, component_index_cv, module_directory_item, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

      IFEND;

      binding_section_ocv := NIL;
      IF llc$information_element IN old_module_header^.elements_defined THEN
        build_binding_section_cv (old_module_header, new_module_header,
              section_directory, old_file_name, new_file_name, old_ol, new_ol, binding_section_ocv, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        IF binding_section_ocv <> NIL THEN
          IF llc$section_element IN old_module_header^.interpretive_header.
                elements_defined THEN
            section_definitions := #PTR (old_module_header^.
                  interpretive_header.section_definitions,
                  old_ol.sequence_pointer^);
            RESET old_ol.sequence_pointer TO section_definitions;
            end_of_sec_defs := FALSE;
            binding_section_found := FALSE;
            REPEAT
              NEXT object_text_descriptor IN old_ol.sequence_pointer;
              CASE object_text_descriptor^.kind OF
              = llc$section_definition, llc$allotted_section_definition,
                    llc$unallocated_common_block =
                NEXT section_definition IN old_ol.sequence_pointer;
                IF section_definition^.kind = llc$binding_section THEN
                  binding_section := section_definition^.section_ordinal;
                  binding_section_found := TRUE;
                IFEND;
              = llc$segment_definition, llc$allotted_segment_definition =
                NEXT segment_definition IN old_ol.sequence_pointer;
                IF segment_definition^.section_definition.kind =
                      llc$binding_section THEN
                  binding_section := segment_definition^.section_definition.
                        section_ordinal;
                  binding_section_found := TRUE;
                IFEND;
              = llc$obsolete_segment_definition,
                    llc$obsolete_allotted_seg_def =
                NEXT obsolete_segment_definition IN old_ol.sequence_pointer;
                IF obsolete_segment_definition^.section_definition.kind =
                      llc$binding_section THEN
                  binding_section := obsolete_segment_definition^.
                        section_definition.section_ordinal;
                  binding_section_found := TRUE;
                IFEND;
              ELSE
                end_of_sec_defs := TRUE;
              CASEND;
            UNTIL end_of_sec_defs OR binding_section_found;
          IFEND;
        IFEND;
      IFEND;

      construct_module_predictor (module_name, number_section_offset_cvs,
            section_number_cv, normal_socv, binding_section_ocv,
            binding_section, component_index_cv, length_component_index_cv,
            single_predictor, single_predictor_size);

    END /main/;

    IF section_number_cv <> NIL THEN
      FREE section_number_cv;
    IFEND;

    FREE section_directory;
    IF binding_section_ocv <> NIL THEN
      FREE binding_section_ocv;
    IFEND;

    IF component_index_cv <> NIL THEN
      FREE component_index_cv;
    IFEND;

    IF nsocv_file_opened THEN
      fsp$close_file (nsocv_fid, local_status);
      nsocv_file_opened := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND build_load_module_predictor;

?? EJECT ??
?? OLDTITLE ??
?? NEWTITLE := 'BUILD_MESSAGE_PREDICTOR' ??
*copyc och$build_message_predictor

  PROCEDURE build_message_predictor
    (    old_message_header: ^llt$library_member_header;
         new_message_header: ^llt$library_member_header,
         module_name: pmt$program_name;
         p_old_ol: amt$segment_pointer;
         p_new_ol: amt$segment_pointer;
     VAR single_predictor: ^SEQ ( * );
     VAR single_predictor_size: oct$module_predictor_size;
     VAR status: ost$status);

    VAR
      change_length: oct$max_offset_changes,
      found: boolean,
      index: oct$max_offset_changes,
      k: ost$status_condition_code,
      l: ost$status_condition_code,
      message_name_index_changes: ^oct$name_index_changes,
      message_offset_changes: ^oct$offset_change_list,
      message_template_cv: ^oct$offset_change_list,
      new: ost$status_condition_code,
      new_condition_codes: ^ost$mtm_condition_codes,
      new_condition_names: ^ost$mtm_condition_names,
      new_member: ^SEQ ( * ),
      new_member_seq: ^SEQ ( * ),
      new_mtm_header: ^ost$mtm_header,
      new_ol: amt$segment_pointer,
      new_template: ^ost$message_template,
      old: ost$status_condition_code,
      old_condition_codes: ^ost$mtm_condition_codes,
      old_condition_names: ^ost$mtm_condition_names,
      old_member: ^SEQ ( * ),
      old_member_seq: ^SEQ ( * ),
      old_mtm_header: ^ost$mtm_header,
      old_ol: amt$segment_pointer,
      old_template: ^ost$message_template,
      predictor_header: ^oct$single_module_predictor_hdr;

    status.normal := TRUE;

    new_ol := p_new_ol;
    old_ol := p_old_ol;

    RESET single_predictor;
    NEXT predictor_header IN single_predictor;
    predictor_header^.predictor_size := #SIZE (predictor_header^);

    index := 1;
    old_member := #PTR (old_message_header^.member, old_ol.sequence_pointer^);
    new_member := #PTR (new_message_header^.member, new_ol.sequence_pointer^);

    RESET old_ol.sequence_pointer TO old_member;
    RESET new_ol.sequence_pointer TO new_member;

    NEXT old_member_seq: [[REP old_message_header^.member_size OF cell]] IN old_ol.sequence_pointer;
    NEXT new_member_seq: [[REP new_message_header^.member_size OF cell]] IN new_ol.sequence_pointer;

    RESET old_member_seq;
    RESET new_member_seq;

    NEXT old_mtm_header IN old_member_seq;
    NEXT new_mtm_header IN new_member_seq;

    ALLOCATE message_offset_changes: [1 .. old_mtm_header^.number_of_names + 1];
    message_offset_changes^ [index].offset := #OFFSET (old_member);
    message_offset_changes^ [index].delta := #OFFSET (new_member) - #OFFSET (old_member);
    index := index + 1;

    IF old_mtm_header^.number_of_codes > 0 THEN
      NEXT old_condition_codes: [0 .. old_mtm_header^.number_of_codes - 1] IN old_member_seq;
      NEXT new_condition_codes: [0 .. new_mtm_header^.number_of_codes - 1] IN new_member_seq;

      NEXT old_condition_names: [0 .. old_mtm_header^.number_of_names - 1] IN old_member_seq;
      NEXT new_condition_names: [0 .. new_mtm_header^.number_of_names - 1] IN new_member_seq;

      NEXT message_name_index_changes: [0 .. old_mtm_header^.number_of_codes - 1] IN single_predictor;
      FOR k := 0 TO UPPERBOUND (message_name_index_changes^) DO
        message_name_index_changes^ [k] := osc$max_status_condition_code;
      FOREND;

      old := 0;
      new := 0;
      WHILE (old <= old_mtm_header^.number_of_codes - 1) AND (new <= new_mtm_header^.number_of_codes - 1) DO
        found := FALSE;
        WHILE NOT found AND (old <= old_mtm_header^.number_of_codes - 1) AND
              (new <= new_mtm_header^.number_of_codes - 1) DO
          IF old_condition_codes^ [old].code = new_condition_codes^ [new].code THEN
            found := TRUE;
          ELSEIF old_condition_codes^ [old].code < new_condition_codes^ [new].code THEN
            old := old + 1;
          ELSEIF old_condition_codes^ [old].code > new_condition_codes^ [new].code THEN
            new := new + 1;
          IFEND;
        WHILEND;

        IF found THEN
          k := old_condition_codes^ [old].name_index;
          l := new_condition_codes^ [new].name_index;
          message_name_index_changes^ [k] := l;
          old_template := #PTR (old_condition_names^ [k].template, old_member_seq^);
          new_template := #PTR (new_condition_names^ [l].template, new_member_seq^);
          message_offset_changes^ [index].offset := #OFFSET (old_template);
          message_offset_changes^ [index].delta := (#OFFSET (new_template) - #OFFSET (new_member_seq)) -
                (#OFFSET (old_template) - #OFFSET (old_member_seq));
          index := index + 1;
          old := old + 1;
          new := new + 1;
        IFEND;
      WHILEND;

      predictor_header^.last_name_index := old_mtm_header^.number_of_codes - 1;
      predictor_header^.predictor_size := predictor_header^.predictor_size +
            #SIZE (message_name_index_changes^);

      change_length := index - 1;
      compress_change_vector (message_offset_changes, change_length);

      IF change_length > 0 THEN
        predictor_header^.length_message_template_cv := change_length;
        NEXT message_template_cv: [1 .. change_length] IN single_predictor;
        message_template_cv^ := message_offset_changes^;
        predictor_header^.message_template_cv := #REL (message_template_cv, single_predictor^);
        predictor_header^.predictor_size := predictor_header^.predictor_size + #SIZE (message_template_cv^);
        predictor_header^.module_name := module_name;
        predictor_header^.kind := llc$message_module;
      IFEND;
    IFEND;

    IF predictor_header^.predictor_size > #SIZE (predictor_header^) THEN
      single_predictor_size := predictor_header^.predictor_size;
    ELSE
      single_predictor_size := 0;
    IFEND;

    FREE message_offset_changes;

  PROCEND build_message_predictor;
?? EJECT ??
?? OLDTITLE ??
?? NEWTITLE := 'BUILD_MOD_DICTIONARY_OCV' ??
*copyc och$build_mod_dictionary_ocv

  PROCEDURE build_mod_dictionary_ocv
    (    module_directory: ^oct$module_directory;
         old_module_dictionary: ^llt$module_dictionary;
         new_module_dictionary: ^llt$module_dictionary;
     VAR old_ol: amt$segment_pointer;
     VAR new_ol: amt$segment_pointer;
     VAR predictor: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      change_count: 0 .. llc$max_modules_in_library,
      change_length: 0 .. llc$max_modules_in_library,
      end_of_old_sec_defs: boolean,
      expected_new_section_ordinal: 0 .. llc$max_modules_in_library,
      fill: ^oct$fill_sequence,
      first_new_section_definition: ^llt$object_text_descriptor,
      first_old_section_definition: ^llt$object_text_descriptor,
      i: 0 .. llc$max_modules_in_library,
      j: 0 .. llc$max_modules_in_library,
      length: integer,
      match_found: boolean,
      mod_dictionary_ocv: ^oct$offset_change_list,
      module_offset_cv: ^oct$offset_change_list,
      new_applic_command_header: ^llt$application_member_header,
      new_applic_program_header: ^llt$application_member_header,
      new_binding_template_ptr: ^llt$binding_section_template,
      new_command_header: ^llt$library_member_header,
      new_component_ptr: ^llt$component_information,
      new_entry_points: ^llt$object_text_descriptor,
      new_external_linkages: ^llt$object_text_descriptor,
      new_function_header: ^llt$library_member_header,
      new_info_element_hdr: ^llt$info_element_header,
      new_information_element: llt$info_element_header,
      new_interpretive_element: ^llt$object_text_descriptor,
      new_library_list: ^llt$object_text_descriptor,
      new_load_module_hdr: ^llt$load_module_header,
      new_map: ^llt$section_map_items,
      new_message_header: ^llt$library_member_header,
      new_mod_number: 0 .. llc$max_modules_in_library,
      new_object_text_descriptor: ^llt$object_text_descriptor,
      new_panel_header: ^llt$library_member_header,
      new_ppu_header: ^llt$object_text_descriptor,
      new_program_header: ^llt$library_member_header,
      new_relocation_ptr: ^llt$relocation,
      new_section_def: llt$section_ordinal,
      new_section_definition: ^llt$section_definition,
      new_section_maps: ^llt$section_maps,
      new_transfer_symbol: ^llt$object_text_descriptor,
      obsolete_segment_definition: ^llt$obsolete_segment_definition,
      old_applic_command_header: ^llt$application_member_header,
      old_applic_program_header: ^llt$application_member_header,
      old_binding_template_ptr: ^llt$binding_section_template,
      old_command_header: ^llt$library_member_header,
      old_component_ptr: ^llt$component_information,
      old_entry_points: ^llt$object_text_descriptor,
      old_external_linkages: ^llt$object_text_descriptor,
      old_function_header: ^llt$library_member_header,
      old_info_element_hdr: ^llt$info_element_header,
      old_information_element: llt$info_element_header,
      old_interpretive_element: ^llt$object_text_descriptor,
      old_library_list: ^llt$object_text_descriptor,
      old_load_module_hdr: ^llt$load_module_header,
      old_map: ^llt$section_map_items,
      old_message_header: ^llt$library_member_header,
      old_mod_number: 0 .. llc$max_modules_in_library,
      old_object_text_descriptor: ^llt$object_text_descriptor,
      old_panel_header: ^llt$library_member_header,
      old_ppu_header: ^llt$object_text_descriptor,
      old_program_header: ^llt$library_member_header,
      old_relocation_ptr: ^llt$relocation,
      old_section_definition: ^llt$section_definition,
      old_section_maps: ^llt$section_maps,
      old_transfer_symbol: ^llt$object_text_descriptor,
      predictor_header: ^oct$predictor_header,
      search_complete: boolean,
      segment_definition: ^llt$segment_definition,
      starting_section_def: llt$section_ordinal,
      text: string (osc$max_string_size);

    status.normal := TRUE;

    change_count := 1;
    PUSH module_offset_cv: [1 .. llc$max_section_ordinal];
    FOR old_mod_number := 1 TO UPPERBOUND (module_directory^) DO
      new_mod_number := module_directory^ [old_mod_number].new_module_number;
      IF new_mod_number <> 0 THEN
        CASE old_module_dictionary^ [old_mod_number].kind OF
        = llc$ppu_object_module =
          old_ppu_header := #PTR (old_module_dictionary^ [old_mod_number].ppu_header,
                old_ol.sequence_pointer^);
          new_ppu_header := #PTR (new_module_dictionary^ [new_mod_number].ppu_header,
                new_ol.sequence_pointer^);
          module_offset_cv^ [change_count].offset := #OFFSET (old_ppu_header);
          module_offset_cv^ [change_count].delta := #OFFSET (new_ppu_header) - #OFFSET (old_ppu_header);
          change_count := change_count + 1;

        = llc$program_description =
          old_program_header := #PTR (old_module_dictionary^ [old_mod_number].program_header,
                old_ol.sequence_pointer^);
          new_program_header := #PTR (new_module_dictionary^ [new_mod_number].program_header,
                new_ol.sequence_pointer^);
          module_offset_cv^ [change_count].offset := #OFFSET (old_program_header);
          module_offset_cv^ [change_count].delta := #OFFSET (new_program_header) -
                #OFFSET (old_program_header);
          change_count := change_count + 1;

        = llc$command_procedure =
          old_command_header := #PTR (old_module_dictionary^ [old_mod_number].command_header,
                old_ol.sequence_pointer^);
          new_command_header := #PTR (new_module_dictionary^ [new_mod_number].command_header,
                new_ol.sequence_pointer^);
          module_offset_cv^ [change_count].offset := #OFFSET (old_command_header);
          module_offset_cv^ [change_count].delta := #OFFSET (new_command_header) -
                #OFFSET (old_command_header);
          change_count := change_count + 1;

        = llc$applic_program_description =
          old_applic_program_header := #PTR (old_module_dictionary^ [old_mod_number].applic_program_header,
                old_ol.sequence_pointer^);
          new_applic_program_header := #PTR (new_module_dictionary^ [new_mod_number].applic_program_header,
                new_ol.sequence_pointer^);
          module_offset_cv^ [change_count].offset := #OFFSET (old_applic_program_header);
          module_offset_cv^ [change_count].delta := #OFFSET (new_applic_program_header) -
                #OFFSET (old_applic_program_header);
          change_count := change_count + 1;

        = llc$applic_command_procedure =
          old_applic_command_header := #PTR (old_module_dictionary^ [old_mod_number].applic_command_header,
                old_ol.sequence_pointer^);
          new_applic_command_header := #PTR (new_module_dictionary^ [new_mod_number].applic_command_header,
                new_ol.sequence_pointer^);
          module_offset_cv^ [change_count].offset := #OFFSET (old_applic_command_header);
          module_offset_cv^ [change_count].delta := #OFFSET (new_applic_command_header) -
                #OFFSET (old_applic_command_header);
          change_count := change_count + 1;

        = llc$function_procedure =
          old_function_header := #PTR (old_module_dictionary^ [old_mod_number].function_header,
                old_ol.sequence_pointer^);
          new_function_header := #PTR (new_module_dictionary^ [new_mod_number].function_header,
                new_ol.sequence_pointer^);
          module_offset_cv^ [change_count].offset := #OFFSET (old_function_header);
          module_offset_cv^ [change_count].delta := #OFFSET (new_function_header) -
                #OFFSET (old_function_header);
          change_count := change_count + 1;

        = llc$message_module =
          old_message_header := #PTR (old_module_dictionary^ [old_mod_number].message_header,
                old_ol.sequence_pointer^);
          new_message_header := #PTR (new_module_dictionary^ [new_mod_number].message_header,
                new_ol.sequence_pointer^);
          module_offset_cv^ [change_count].offset := #OFFSET (old_message_header);
          module_offset_cv^ [change_count].delta := #OFFSET (new_message_header) -
                #OFFSET (old_message_header);
          change_count := change_count + 1;

        = llc$panel_module =
          old_panel_header := #PTR (old_module_dictionary^ [old_mod_number].panel_header,
                old_ol.sequence_pointer^);
          new_panel_header := #PTR (new_module_dictionary^ [new_mod_number].panel_header,
                new_ol.sequence_pointer^);
          module_offset_cv^ [change_count].offset := #OFFSET (old_panel_header);
          module_offset_cv^ [change_count].delta := #OFFSET (new_panel_header) - #OFFSET (old_panel_header);
          change_count := change_count + 1;

        = llc$load_module =
          old_load_module_hdr := #PTR (old_module_dictionary^ [old_mod_number].module_header,
                old_ol.sequence_pointer^);
          new_load_module_hdr := #PTR (new_module_dictionary^ [new_mod_number].module_header,
                new_ol.sequence_pointer^);
          module_offset_cv^ [change_count].offset := #OFFSET (old_load_module_hdr);
          module_offset_cv^ [change_count].delta := #OFFSET (new_load_module_hdr) -
                #OFFSET (old_load_module_hdr);
          change_count := change_count + 1;

          IF llc$interpretive_element IN old_load_module_hdr^.elements_defined THEN
            old_interpretive_element := #PTR (old_load_module_hdr^.interpretive_element,
                  old_ol.sequence_pointer^);
            new_interpretive_element := #PTR (new_load_module_hdr^.interpretive_element,
                  new_ol.sequence_pointer^);
            module_offset_cv^ [change_count].offset := #OFFSET (old_interpretive_element);
            module_offset_cv^ [change_count].delta := #OFFSET (new_interpretive_element) -
                  module_offset_cv^ [change_count].offset;
            change_count := change_count + 1;

            IF llc$library_element IN old_load_module_hdr^.interpretive_header.elements_defined THEN
              old_library_list := #PTR (old_load_module_hdr^.interpretive_header.library_list,
                    old_ol.sequence_pointer^);
              new_library_list := #PTR (new_load_module_hdr^.interpretive_header.library_list,
                    new_ol.sequence_pointer^);
              module_offset_cv^ [change_count].offset := #OFFSET (old_library_list);
              module_offset_cv^ [change_count].delta := #OFFSET (new_library_list) -
                    module_offset_cv^ [change_count].offset;
              change_count := change_count + 1;
            IFEND;

            IF llc$section_element IN old_load_module_hdr^.interpretive_header.elements_defined THEN
              first_old_section_definition := #PTR (old_load_module_hdr^.interpretive_header.
                    section_definitions, old_ol.sequence_pointer^);
              first_new_section_definition := #PTR (new_load_module_hdr^.interpretive_header.
                    section_definitions, new_ol.sequence_pointer^);
              module_offset_cv^ [change_count].offset := #OFFSET (first_old_section_definition);
              module_offset_cv^ [change_count].delta := #OFFSET (first_new_section_definition) -
                    module_offset_cv^ [change_count].offset;
              change_count := change_count + 1;

              end_of_old_sec_defs := FALSE;
              RESET old_ol.sequence_pointer TO first_old_section_definition;

            /find_matching_allotted_section/
              REPEAT
                NEXT old_object_text_descriptor IN old_ol.sequence_pointer;
                CASE old_object_text_descriptor^.kind OF
                = llc$section_definition, llc$unallocated_common_block =
                  NEXT old_section_definition IN old_ol.sequence_pointer;
                = llc$allotted_section_definition =
                  NEXT old_section_definition IN old_ol.sequence_pointer;
                  IF (module_directory^ [old_mod_number].section_number_change_list^
                        [old_section_definition^.section_ordinal] = occ$invalid_section_ordinal) THEN
                    CYCLE /find_matching_allotted_section/;
                  IFEND;
                  RESET new_ol.sequence_pointer TO first_new_section_definition;
                  match_found := FALSE;
                  search_complete := FALSE;
                  expected_new_section_ordinal := module_directory^ [old_mod_number].
                        section_number_change_list^ [old_section_definition^.section_ordinal];
                  REPEAT
                    NEXT new_object_text_descriptor IN new_ol.sequence_pointer;
                    CASE new_object_text_descriptor^.kind OF
                    = llc$section_definition, llc$unallocated_common_block =
                      NEXT new_section_definition IN new_ol.sequence_pointer;
                    = llc$allotted_section_definition =
                      NEXT new_section_definition IN new_ol.sequence_pointer;
                      match_found := (expected_new_section_ordinal =
                            new_section_definition^.section_ordinal) AND
                            (new_section_definition^.kind = old_section_definition^.kind) AND
                            (new_section_definition^.access_attributes =
                            old_section_definition^.access_attributes) AND
                            (new_section_definition^.name = old_section_definition^.name);
                      IF match_found THEN
                        module_offset_cv^ [change_count].offset := old_object_text_descriptor^.
                              allotted_section;
                        module_offset_cv^ [change_count].delta := new_object_text_descriptor^.
                              allotted_section - old_object_text_descriptor^.allotted_section;
                        change_count := change_count + 1;
                      IFEND;
                    ELSE
                      search_complete := TRUE;
                    CASEND;
                  UNTIL match_found OR search_complete;
                = llc$segment_definition =
                  NEXT segment_definition IN old_ol.sequence_pointer;
                = llc$obsolete_segment_definition =
                  NEXT obsolete_segment_definition IN old_ol.sequence_pointer;
                = llc$allotted_segment_definition =
                  NEXT segment_definition IN old_ol.sequence_pointer;
                  old_section_definition := ^segment_definition^.section_definition;
                  IF (module_directory^ [old_mod_number].section_number_change_list^
                        [old_section_definition^.section_ordinal] = occ$invalid_section_ordinal) THEN
                    CYCLE /find_matching_allotted_section/;
                  IFEND;
                  RESET new_ol.sequence_pointer TO first_new_section_definition;
                  match_found := FALSE;
                  search_complete := FALSE;
                  expected_new_section_ordinal := module_directory^ [old_mod_number].
                        section_number_change_list^ [old_section_definition^.section_ordinal];
                  REPEAT
                    NEXT new_object_text_descriptor IN new_ol.sequence_pointer;
                    CASE new_object_text_descriptor^.kind OF
                    = llc$segment_definition =
                      NEXT segment_definition IN new_ol.sequence_pointer;
                    = llc$allotted_segment_definition =
                      NEXT segment_definition IN new_ol.sequence_pointer;
                      new_section_definition := ^segment_definition^.section_definition;
                      match_found := (expected_new_section_ordinal =
                            new_section_definition^.section_ordinal) AND
                            (new_section_definition^.kind = old_section_definition^.kind) AND
                            (new_section_definition^.access_attributes =
                            old_section_definition^.access_attributes) AND
                            (new_section_definition^.name = old_section_definition^.name);
                      IF match_found THEN
                        module_offset_cv^ [change_count].offset := old_object_text_descriptor^.
                              allotted_segment;
                        module_offset_cv^ [change_count].delta := new_object_text_descriptor^.
                              allotted_segment - old_object_text_descriptor^.allotted_segment;
                        change_count := change_count + 1;
                      IFEND;
                    ELSE
                      search_complete := TRUE;
                    CASEND;
                  UNTIL match_found OR search_complete;
                = llc$obsolete_allotted_seg_def =
                  NEXT obsolete_segment_definition IN old_ol.sequence_pointer;
                  old_section_definition := ^obsolete_segment_definition^.section_definition;
                  IF (module_directory^ [old_mod_number].section_number_change_list^
                        [old_section_definition^.section_ordinal] = occ$invalid_section_ordinal) THEN
                    CYCLE /find_matching_allotted_section/;
                  IFEND;
                  RESET new_ol.sequence_pointer TO first_new_section_definition;
                  match_found := FALSE;
                  search_complete := FALSE;
                  expected_new_section_ordinal := module_directory^ [old_mod_number].
                        section_number_change_list^ [old_section_definition^.section_ordinal];
                  REPEAT
                    NEXT new_object_text_descriptor IN new_ol.sequence_pointer;
                    CASE new_object_text_descriptor^.kind OF
                    = llc$obsolete_segment_definition =
                      NEXT obsolete_segment_definition IN new_ol.sequence_pointer;
                    = llc$obsolete_allotted_seg_def =
                      NEXT obsolete_segment_definition IN new_ol.sequence_pointer;
                      new_section_definition := ^obsolete_segment_definition^.section_definition;
                      match_found := (expected_new_section_ordinal =
                            new_section_definition^.section_ordinal) AND
                            (new_section_definition^.kind = old_section_definition^.kind) AND
                            (new_section_definition^.access_attributes =
                            old_section_definition^.access_attributes) AND
                            (new_section_definition^.name = old_section_definition^.name);
                      IF match_found THEN
                        module_offset_cv^ [change_count].offset := old_object_text_descriptor^.
                              allotted_segment;
                        module_offset_cv^ [change_count].delta := new_object_text_descriptor^.
                              allotted_segment - old_object_text_descriptor^.allotted_segment;
                        change_count := change_count + 1;
                      IFEND;
                    ELSE
                      search_complete := TRUE;
                    CASEND;
                  UNTIL match_found OR search_complete;
                ELSE
                  end_of_old_sec_defs := TRUE;
                CASEND;
              UNTIL end_of_old_sec_defs;
            IFEND;

            IF llc$entry_point_element IN old_load_module_hdr^.interpretive_header.elements_defined THEN
              old_entry_points := #PTR (old_load_module_hdr^.interpretive_header.entry_points,
                    old_ol.sequence_pointer^);
              new_entry_points := #PTR (new_load_module_hdr^.interpretive_header.entry_points,
                    new_ol.sequence_pointer^);
              module_offset_cv^ [change_count].offset := #OFFSET (old_entry_points);
              module_offset_cv^ [change_count].delta := #OFFSET (new_entry_points) -
                    module_offset_cv^ [change_count].offset;
              change_count := change_count + 1;
            IFEND;

            IF llc$external_element IN old_load_module_hdr^.interpretive_header.elements_defined THEN
              old_external_linkages := #PTR (old_load_module_hdr^.interpretive_header.external_linkages,
                    old_ol.sequence_pointer^);
              new_external_linkages := #PTR (new_load_module_hdr^.interpretive_header.external_linkages,
                    new_ol.sequence_pointer^);
              module_offset_cv^ [change_count].offset := #OFFSET (old_external_linkages);
              module_offset_cv^ [change_count].delta := #OFFSET (new_external_linkages) -
                    module_offset_cv^ [change_count].offset;
              change_count := change_count + 1;
            IFEND;

            IF llc$transfer_symbol_element IN old_load_module_hdr^.interpretive_header.elements_defined THEN
              old_transfer_symbol := #PTR (old_load_module_hdr^.interpretive_header.transfer_symbol,
                    old_ol.sequence_pointer^);
              new_transfer_symbol := #PTR (new_load_module_hdr^.interpretive_header.transfer_symbol,
                    new_ol.sequence_pointer^);
              module_offset_cv^ [change_count].offset := #OFFSET (old_transfer_symbol);
              module_offset_cv^ [change_count].delta := #OFFSET (new_transfer_symbol) -
                    module_offset_cv^ [change_count].offset;
              change_count := change_count + 1;
            IFEND;
          IFEND;

          IF llc$information_element IN old_load_module_hdr^.elements_defined THEN
            old_info_element_hdr := #PTR (old_load_module_hdr^.information_element, old_ol.sequence_pointer^);
            new_info_element_hdr := #PTR (new_load_module_hdr^.information_element, new_ol.sequence_pointer^);
            module_offset_cv^ [change_count].offset := #OFFSET (old_info_element_hdr);
            module_offset_cv^ [change_count].delta := #OFFSET (new_info_element_hdr) -
                  #OFFSET (old_info_element_hdr);
            change_count := change_count + 1;

            IF old_info_element_hdr^.version = llc$info_element_version THEN
              old_information_element := old_info_element_hdr^;
            ELSE
              ocp$convert_information_element (old_info_element_hdr, old_information_element);
            IFEND;

            IF new_info_element_hdr^.version = llc$info_element_version THEN
              new_information_element := new_info_element_hdr^;
            ELSE
              ocp$convert_information_element (new_info_element_hdr, new_information_element);
            IFEND;

            IF old_information_element.number_of_rel_items > 0 THEN
              module_directory^ [old_mod_number].number_of_rel_items := old_information_element.
                    number_of_rel_items;
              old_relocation_ptr := #PTR (old_information_element.relocation_ptr, old_ol.sequence_pointer^);
              new_relocation_ptr := #PTR (new_information_element.relocation_ptr, new_ol.sequence_pointer^);
              module_offset_cv^ [change_count].offset := #OFFSET (old_relocation_ptr);
              module_offset_cv^ [change_count].delta := #OFFSET (new_relocation_ptr) -
                    module_offset_cv^ [change_count].offset;
              change_count := change_count + 1;
            IFEND;

            IF old_information_element.number_of_components > 0 THEN
              old_component_ptr := #PTR (old_information_element.component_ptr, old_ol.sequence_pointer^);
              new_component_ptr := #PTR (new_information_element.component_ptr, new_ol.sequence_pointer^);
              module_offset_cv^ [change_count].offset := #OFFSET (old_component_ptr);
              module_offset_cv^ [change_count].delta := #OFFSET (new_component_ptr) -
                    module_offset_cv^ [change_count].offset;
              change_count := change_count + 1;
            IFEND;

            IF old_information_element.number_of_template_items > 0 THEN
              old_binding_template_ptr := #PTR (old_information_element.binding_template_ptr,
                    old_ol.sequence_pointer^);
              new_binding_template_ptr := #PTR (new_information_element.binding_template_ptr,
                    new_ol.sequence_pointer^);
              module_offset_cv^ [change_count].offset := #OFFSET (old_binding_template_ptr);
              module_offset_cv^ [change_count].delta := #OFFSET (new_binding_template_ptr) -
                    module_offset_cv^ [change_count].offset;
              change_count := change_count + 1;
            IFEND;

            IF old_information_element.number_of_section_maps > 0 THEN
              old_section_maps := #PTR (old_information_element.section_maps, old_ol.sequence_pointer^);
              new_section_maps := #PTR (new_information_element.section_maps, new_ol.sequence_pointer^);
              module_offset_cv^ [change_count].offset := #OFFSET (old_section_maps);
              module_offset_cv^ [change_count].delta := #OFFSET (new_section_maps) -
                    #OFFSET (old_section_maps);
              change_count := change_count + 1;
              FOR i := 0 TO old_information_element.number_of_section_maps - 1 DO
                j := module_directory^ [old_mod_number].section_number_change_list^ [i];
                old_map := #PTR (old_section_maps^ [i].map, old_ol.sequence_pointer^);
                new_map := #PTR (new_section_maps^ [i].map, new_ol.sequence_pointer^);
                module_offset_cv^ [change_count].offset := #OFFSET (old_map);
                module_offset_cv^ [change_count].delta := #OFFSET (new_map) - #OFFSET (old_map);
                change_count := change_count + 1;
              FOREND;
            IFEND;
          IFEND;

        ELSE
          STRINGREP (text, length, old_module_dictionary^ [old_mod_number].kind);
          osp$set_status_abnormal (occ$status_id, oce$invalid_module_kind, text (1, length), status);
          RETURN;
        CASEND;
      IFEND;
    FOREND;

    change_length := change_count - 1;
    compress_change_vector (module_offset_cv, change_length);

    IF change_length > 0 THEN
      module_offset_cv^ [change_length].offset := #SIZE (old_ol.sequence_pointer^);

      RESET predictor.sequence_pointer;
      NEXT predictor_header IN predictor.sequence_pointer;
      RESET predictor.sequence_pointer;
      NEXT fill: [1 .. predictor_header^.size_predictor] IN predictor.sequence_pointer;
      NEXT mod_dictionary_ocv: [1 .. change_length] IN predictor.sequence_pointer;
      FOR i := 1 TO change_length DO
        mod_dictionary_ocv^ [i] := module_offset_cv^ [i];
      FOREND;
      predictor_header^.number_of_mod_ocv_elements := change_length;
      predictor_header^.mod_dictionary_ocv := #REL (mod_dictionary_ocv, predictor.sequence_pointer^);
      predictor_header^.size_predictor := predictor_header^.size_predictor + #SIZE (mod_dictionary_ocv^);
    ELSE
      RESET predictor.sequence_pointer;
      NEXT predictor_header IN predictor.sequence_pointer;
      predictor_header^.number_of_mod_ocv_elements := 0;
    IFEND;
  PROCEND build_mod_dictionary_ocv;

?? EJECT ??
?? OLDTITLE ??
?? NEWTITLE := 'BUILD_MODULE_PREDICTORS' ??
*copyc och$build_module_predictors

  PROCEDURE build_module_predictors
    (    old_file_name: fst$file_reference;
         new_file_name: fst$file_reference;
         old_ol: amt$segment_pointer;
         new_ol: amt$segment_pointer;
         old_module_dictionary: ^llt$module_dictionary;
         new_module_dictionary: ^llt$module_dictionary;
     VAR module_directory: ^oct$module_directory;
     VAR predictor: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      fill: ^SEQ ( * ),
      smp_file_opened: boolean,
      i: llt$module_index,
      j: llt$module_index,
      local_status: ost$status,
      module_predictor: ^SEQ ( * ),
      new_message_header: ^llt$library_member_header,
      new_module_header: ^llt$load_module_header,
      old_message_header: ^llt$library_member_header,
      old_module_header: ^llt$load_module_header,
      predictor_header: ^oct$predictor_header,
      s_predictor: ^SEQ ( * ),
      single_predictor: ^SEQ ( * ),
      single_predictor_size: oct$module_predictor_size,
      smp_fid: amt$file_identifier,
      smp_lfn: ost$name,
      smp_seg: amt$segment_pointer;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the file has been opened, it will be closed before the
{   the procedure returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF smp_file_opened THEN
        fsp$close_file (smp_fid, ignore_status);
        smp_file_opened := FALSE;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    smp_file_opened := FALSE;

    pmp$get_unique_name (smp_lfn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      attachment_options [1].selector := fsc$access_and_share_modes;
      attachment_options [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options [1].access_modes.value := $fst$file_access_options
            [fsc$read, fsc$shorten, fsc$append, fsc$modify];
      attachment_options [1].share_modes.selector := fsc$determine_from_access_modes;
      attachment_options [2].selector := fsc$create_file;
      attachment_options [2].create_file := TRUE;
      attachment_options [3].selector := fsc$wait_for_attachment;
      attachment_options [3].wait_for_attachment.wait := osc$wait;
      attachment_options [3].wait_for_attachment.wait_time := fsc$longest_wait_time;

      smp_file_opened := TRUE;
      fsp$open_file (smp_lfn, amc$segment, ^attachment_options, NIL, NIL, NIL, NIL, smp_fid, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (smp_fid, amc$sequence_pointer, smp_seg, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      single_predictor := smp_seg.sequence_pointer;
      RESET predictor.sequence_pointer;
      NEXT predictor_header IN predictor.sequence_pointer;
      predictor_header^.number_module_predictors := 0;
      single_predictor_size := 0;

      FOR i := 1 TO UPPERBOUND (module_directory^) DO
        j := module_directory^ [i].new_module_number;
        IF (j <> 0) THEN
          CASE old_module_dictionary^ [i].kind OF
          = llc$load_module =
            old_module_header := #PTR (old_module_dictionary^ [i].
                  module_header, old_ol.sequence_pointer^);
            new_module_header := #PTR (new_module_dictionary^ [j].
                  module_header, new_ol.sequence_pointer^);
            build_load_module_predictor (old_module_header, new_module_header,
                  old_module_dictionary^ [i].name, old_file_name, new_file_name, old_ol, new_ol,
                  single_predictor, single_predictor_size,
                  module_directory^ [i], status);
            IF NOT status.normal THEN
              EXIT /main/;
            IFEND;
          = llc$message_module =
            old_message_header := #PTR (old_module_dictionary^ [i].
                  message_header, old_ol.sequence_pointer^);
            new_message_header := #PTR (new_module_dictionary^ [j].
                  message_header, new_ol.sequence_pointer^);
            build_message_predictor (old_message_header, new_message_header,
                  old_module_dictionary^ [i].name, old_ol, new_ol,
                  single_predictor, single_predictor_size, status);
            IF NOT status.normal THEN
              EXIT /main/;
            IFEND;
          ELSE
            ;
          CASEND;
          IF single_predictor_size > 0 THEN
            RESET single_predictor;
            RESET predictor.sequence_pointer;
            NEXT fill: [[REP predictor_header^.size_predictor OF cell]] IN
                  predictor.sequence_pointer;
            NEXT module_predictor: [[REP single_predictor_size OF cell]] IN
                  predictor.sequence_pointer;
            NEXT s_predictor: [[REP single_predictor_size OF cell]] IN
                  single_predictor;
            module_predictor^ := s_predictor^;
            predictor_header^.number_module_predictors :=
                  predictor_header^.number_module_predictors + 1;
            predictor_header^.size_predictor :=
                  predictor_header^.size_predictor + single_predictor_size;
          IFEND;
          single_predictor_size := 0;
        IFEND;
      FOREND;

    END /main/;

    IF smp_file_opened THEN
      fsp$close_file (smp_fid, local_status);
      smp_file_opened := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND build_module_predictors;

?? EJECT ??
?? OLDTITLE ??
?? NEWTITLE := 'BUILD_NORMAL_OFFSET_CV' ??
*copyc och$build_normal_offset_cv

  PROCEDURE build_normal_offset_cv
    (    old_module_header: ^llt$load_module_header;
         new_module_header: ^llt$load_module_header;
         old_file_name: fst$file_reference;
         new_file_name: fst$file_reference;
         old_ol: amt$segment_pointer;
         new_ol: amt$segment_pointer;
     VAR normal_socv: amt$segment_pointer;
     VAR section_directory: ^oct$section_directory;
     VAR number_section_offset_cvs: llt$section_ordinal;
     VAR status: ost$status);

    VAR
      i: llt$section_ordinal,
      j: llt$section_ordinal,
      new_component_info: ^llt$component_information,
      new_info_element_header: ^llt$info_element_header,
      new_information_element: llt$info_element_header,
      new_section_map: ^llt$section_map_items,
      new_section_maps: ^llt$section_maps,
      old_component_info: ^llt$component_information,
      old_info_element_header: ^llt$info_element_header,
      old_information_element: llt$info_element_header,
      old_section_definitions: ^llt$object_text_descriptor,
      old_section_map: ^llt$section_map_items,
      old_section_maps: ^llt$section_maps,
      socv_generated: boolean,
      section_offset_cv: ^oct$section_offset_changes;

    status.normal := TRUE;

    number_section_offset_cvs := 0;
    RESET normal_socv.sequence_pointer;
    IF (llc$information_element IN old_module_header^.elements_defined) AND
          (llc$information_element IN new_module_header^.elements_defined) THEN

      old_info_element_header := #PTR (old_module_header^.information_element, old_ol.sequence_pointer^);
      new_info_element_header := #PTR (new_module_header^.information_element, new_ol.sequence_pointer^);

      IF (old_info_element_header^.version = llc$info_element_version) THEN
        old_information_element := old_info_element_header^;
      ELSE
        ocp$convert_information_element (old_info_element_header, old_information_element);
      IFEND;

      IF (old_information_element.number_of_section_maps = 0) THEN
        osp$set_status_abnormal (occ$status_id, oce$no_section_maps, old_file_name, status);
        RETURN;
      IFEND;

      IF (new_info_element_header^.version = llc$info_element_version) THEN
        new_information_element := new_info_element_header^;
      ELSE
        ocp$convert_information_element (new_info_element_header, new_information_element);
      IFEND;

      IF (new_information_element.number_of_section_maps = 0) THEN
        osp$set_status_abnormal (occ$status_id, oce$no_section_maps, old_file_name, status);
        RETURN;
      IFEND;

      old_section_maps := #PTR (old_information_element.section_maps, old_ol.sequence_pointer^);
      new_section_maps := #PTR (new_information_element.section_maps, new_ol.sequence_pointer^);
      IF old_information_element.number_of_components > 0 THEN
        old_component_info := #PTR (old_information_element.component_ptr, old_ol.sequence_pointer^);
      ELSE
        old_component_info := NIL;
      IFEND;
      IF new_information_element.number_of_components > 0 THEN
        new_component_info := #PTR (new_information_element.component_ptr, new_ol.sequence_pointer^);
      ELSE
        new_component_info := NIL;
      IFEND;

      IF llc$section_element IN old_module_header^.interpretive_header.elements_defined THEN
        old_section_definitions := #PTR (old_module_header^.interpretive_header.section_definitions,
              old_ol.sequence_pointer^);
      ELSE
        old_section_definitions := NIL;
      IFEND;
      FOR i := 0 TO UPPERBOUND (section_directory^) DO
        IF (section_directory^ [i].new_section_number <> occ$invalid_section_ordinal) AND
              (old_section_maps^ [i].number_of_items > 0) THEN
          j := section_directory^ [i].new_section_number;
          old_section_map := #PTR (old_section_maps^ [i].map, old_ol.sequence_pointer^);
          new_section_map := #PTR (new_section_maps^ [j].map, new_ol.sequence_pointer^);
          build_section_ocv (old_section_map, new_section_map, i, old_section_definitions,
                old_ol.sequence_pointer, old_component_info, new_component_info, normal_socv,
                section_offset_cv, socv_generated, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF socv_generated THEN
            number_section_offset_cvs := number_section_offset_cvs + 1;
            section_directory^ [i].section_offset_change_vector := ^section_offset_cv^.change_list;
          IFEND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND build_normal_offset_cv;
?? EJECT ??
?? OLDTITLE ??
?? NEWTITLE := 'BUILD_OL_DICTIONARY_OCV' ??
*copyc och$build_ol_dictionary_ocv

  PROCEDURE build_ol_dictionary_ocv
    (    p_old_ol: amt$segment_pointer;
         p_new_ol: amt$segment_pointer;
     VAR predictor: amt$segment_pointer;
     VAR status: ost$status);

    VAR
      change_length: oct$max_offset_changes,
      i: 0 .. llc$max_dictionaries_on_library,
      j: 0 .. llc$max_dictionaries_on_library,
      k: oct$max_offset_changes,
      match_found: boolean,
      new_command_dictionary: ^llt$command_dictionary,
      new_ept_dictionary: ^llt$entry_point_dictionary,
      new_function_dictionary: ^llt$function_dictionary,
      new_header: ^llt$object_library_header,
      new_help_dictionary: ^llt$help_module_dictionary,
      new_message_dictionary: ^llt$message_module_dictionary,
      new_module_dictionary: ^llt$module_dictionary,
      new_ol: amt$segment_pointer,
      new_ol_dictionaries: ^llt$object_library_dictionaries,
      new_panel_dictionary: ^llt$panel_dictionary,
      ol_dictionary_changes: ^oct$offset_change_list,
      ol_dictionary_ocv: ^oct$offset_change_list,
      old_command_dictionary: ^llt$command_dictionary,
      old_ept_dictionary: ^llt$entry_point_dictionary,
      old_function_dictionary: ^llt$function_dictionary,
      old_header: ^llt$object_library_header,
      old_help_dictionary: ^llt$help_module_dictionary,
      old_message_dictionary: ^llt$message_module_dictionary,
      old_module_dictionary: ^llt$module_dictionary,
      old_ol: amt$segment_pointer,
      old_ol_dictionaries: ^llt$object_library_dictionaries,
      old_panel_dictionary: ^llt$panel_dictionary,
      predictor_fill: ^oct$fill_sequence,
      predictor_header: ^oct$predictor_header,
      search_complete: boolean,
      start: 0 .. llc$max_dictionaries_on_library;

    status.normal := TRUE;

    new_ol := p_new_ol;
    old_ol := p_old_ol;

    RESET old_ol.sequence_pointer;
    RESET new_ol.sequence_pointer;
    RESET predictor.sequence_pointer;
    NEXT predictor_header IN predictor.sequence_pointer;
    RESET predictor.sequence_pointer;
    NEXT predictor_fill: [1 .. predictor_header^.size_predictor] IN predictor.sequence_pointer;
    NEXT old_header IN old_ol.sequence_pointer;
    NEXT new_header IN new_ol.sequence_pointer;
    NEXT old_ol_dictionaries: [1 .. old_header^.number_of_dictionaries] IN old_ol.sequence_pointer;
    NEXT new_ol_dictionaries: [1 .. new_header^.number_of_dictionaries] IN new_ol.sequence_pointer;
    k := 1;
    PUSH ol_dictionary_changes: [1 .. old_header^.number_of_dictionaries];
    start := 1;
    FOR i := 1 TO old_header^.number_of_dictionaries DO
      match_found := FALSE;
      search_complete := FALSE;
      j := start;
      WHILE NOT match_found AND NOT search_complete DO
        match_found := (old_ol_dictionaries^ [i].kind = new_ol_dictionaries^ [j].kind);
        IF match_found THEN
          CASE old_ol_dictionaries^ [i].kind OF
          = llc$module_dictionary =
            old_module_dictionary := #PTR (old_ol_dictionaries^ [i].module_dictionary,
                  old_ol.sequence_pointer^);
            new_module_dictionary := #PTR (new_ol_dictionaries^ [j].module_dictionary,
                  new_ol.sequence_pointer^);
            ol_dictionary_changes^ [k].offset := #OFFSET (old_module_dictionary);
            ol_dictionary_changes^ [k].delta := #OFFSET (new_module_dictionary) -
                  #OFFSET (old_module_dictionary);
            k := k + 1;
          = llc$entry_point_dictionary =
            old_ept_dictionary := #PTR (old_ol_dictionaries^ [i].entry_point_dictionary,
                  old_ol.sequence_pointer^);
            new_ept_dictionary := #PTR (new_ol_dictionaries^ [j].entry_point_dictionary,
                  new_ol.sequence_pointer^);
            ol_dictionary_changes^ [k].offset := #OFFSET (old_ept_dictionary);
            ol_dictionary_changes^ [k].delta := #OFFSET (new_ept_dictionary) - #OFFSET (old_ept_dictionary);
            k := k + 1;
          = llc$command_dictionary =
            old_command_dictionary := #PTR (old_ol_dictionaries^ [i].command_dictionary,
                  old_ol.sequence_pointer^);
            new_command_dictionary := #PTR (new_ol_dictionaries^ [j].command_dictionary,
                  new_ol.sequence_pointer^);
            ol_dictionary_changes^ [k].offset := #OFFSET (old_command_dictionary);
            ol_dictionary_changes^ [k].delta := #OFFSET (new_command_dictionary) -
                  #OFFSET (old_command_dictionary);
            k := k + 1;
          = llc$function_dictionary =
            old_function_dictionary := #PTR (old_ol_dictionaries^ [i].function_dictionary,
                  old_ol.sequence_pointer^);
            new_function_dictionary := #PTR (new_ol_dictionaries^ [j].function_dictionary,
                  new_ol.sequence_pointer^);
            ol_dictionary_changes^ [k].offset := #OFFSET (old_function_dictionary);
            ol_dictionary_changes^ [k].delta := #OFFSET (new_function_dictionary) -
                  #OFFSET (old_function_dictionary);
            k := k + 1;
          = llc$help_module_dictionary =
            old_help_dictionary := #PTR (old_ol_dictionaries^ [i].help_module_dictionary,
                  old_ol.sequence_pointer^);
            new_help_dictionary := #PTR (new_ol_dictionaries^ [j].help_module_dictionary,
                  new_ol.sequence_pointer^);
            ol_dictionary_changes^ [k].offset := #OFFSET (old_help_dictionary);
            ol_dictionary_changes^ [k].delta := #OFFSET (new_help_dictionary) - #OFFSET (old_help_dictionary);
            k := k + 1;
          = llc$message_module_dictionary =
            old_message_dictionary := #PTR (old_ol_dictionaries^ [i].message_module_dictionary,
                  old_ol.sequence_pointer^);
            new_message_dictionary := #PTR (new_ol_dictionaries^ [j].message_module_dictionary,
                  new_ol.sequence_pointer^);
            ol_dictionary_changes^ [k].offset := #OFFSET (old_message_dictionary);
            ol_dictionary_changes^ [k].delta := #OFFSET (new_message_dictionary) -
                  #OFFSET (old_message_dictionary);
            k := k + 1;
          = llc$panel_dictionary =
            old_panel_dictionary := #PTR (old_ol_dictionaries^ [i].panel_dictionary,
                  old_ol.sequence_pointer^);
            new_panel_dictionary := #PTR (new_ol_dictionaries^ [j].panel_dictionary,
                  new_ol.sequence_pointer^);
            ol_dictionary_changes^ [k].offset := #OFFSET (old_panel_dictionary);
            ol_dictionary_changes^ [k].delta := #OFFSET (new_panel_dictionary) -
                  #OFFSET (old_panel_dictionary);
            k := k + 1;
          ELSE
            ;
          CASEND;

          start := start + 1;
          IF start > new_header^.number_of_dictionaries THEN
            start := 1;
          IFEND;
        ELSE
          j := j + 1;
          IF j > new_header^.number_of_dictionaries THEN
            j := 1;
          IFEND;
          search_complete := (j = start);
        IFEND;
      WHILEND;
    FOREND;

    change_length := k - 1;
    compress_change_vector (ol_dictionary_changes, change_length);

    IF change_length > 0 THEN
      NEXT ol_dictionary_ocv: [1 .. change_length] IN predictor.sequence_pointer;
      FOR i := 1 TO change_length DO
        ol_dictionary_ocv^ [i] := ol_dictionary_changes^ [i];
      FOREND;
      predictor_header^.number_of_ol_ocv_elements := change_length;
      predictor_header^.ol_dictionary_ocv := #REL (ol_dictionary_ocv, predictor.sequence_pointer^);
      predictor_header^.size_predictor := predictor_header^.size_predictor + #SIZE (ol_dictionary_ocv^);
    ELSE
      predictor_header^.number_of_ol_ocv_elements := 0;
    IFEND;
  PROCEND build_ol_dictionary_ocv;
?? EJECT ??
?? OLDTITLE ??
?? NEWTITLE := 'BUILD_SECTION_NUMBER_CV' ??
*copyc och$build_section_number_cv

  PROCEDURE build_section_number_cv
    (    old_module_header: ^llt$load_module_header;
         new_module_header: ^llt$load_module_header;
         p_old_ol: amt$segment_pointer;
         p_new_ol: amt$segment_pointer;
     VAR section_number_cv: ^oct$new_ordinal_list;
     VAR module_is_bound: boolean;
     VAR section_directory: ^oct$section_directory;
     VAR status: ost$status);

    VAR
      i: llt$section_ordinal,
      j: llt$section_ordinal,
      match_found: boolean,
      new_identification_record: ^llt$identification,
      new_interpretive_element: ^llt$object_text_descriptor,
      new_ol: amt$segment_pointer,
      new_section_list: ^oct$section_list,
      object_text_descriptor: ^llt$object_text_descriptor,
      old_identification_record: ^llt$identification,
      old_info_element: ^llt$info_element_header,
      old_information_element: llt$info_element_header,
      old_interpretive_element: ^llt$object_text_descriptor,
      old_ol: amt$segment_pointer,
      old_section_list: ^oct$section_list,
      same_section_lists: boolean,
      search_complete: boolean,
      section_definitions: ^llt$object_text_descriptor,
      start: llt$section_ordinal;

    status.normal := TRUE;

    new_ol := p_new_ol;
    old_ol := p_old_ol;

    module_is_bound := FALSE;
    IF llc$information_element IN old_module_header^.elements_defined THEN
      old_info_element := #PTR (old_module_header^.information_element, old_ol.sequence_pointer^);
      IF old_info_element^.version = llc$info_element_version THEN
        old_information_element := old_info_element^;
      ELSE
        ocp$convert_information_element (old_info_element, old_information_element);
      IFEND;

      module_is_bound := (old_information_element.number_of_components > 0);
    IFEND;

    IF (llc$interpretive_element IN old_module_header^.elements_defined) AND
          (llc$interpretive_element IN new_module_header^.elements_defined) THEN
      old_interpretive_element := #PTR (old_module_header^.interpretive_element, old_ol.sequence_pointer^);
      new_interpretive_element := #PTR (new_module_header^.interpretive_element, new_ol.sequence_pointer^);

      RESET old_ol.sequence_pointer TO old_interpretive_element;
      NEXT object_text_descriptor IN old_ol.sequence_pointer;
      IF object_text_descriptor^.kind <> llc$identification THEN
        osp$set_status_abnormal (occ$status_id, oce$id_record_expected, ' ', status);
        RETURN;
      IFEND;

      NEXT old_identification_record IN old_ol.sequence_pointer;

      IF NOT (llc$section_element IN old_module_header^.interpretive_header.elements_defined) THEN
        RETURN;
      IFEND;

      section_definitions := #PTR (old_module_header^.interpretive_header.section_definitions,
            old_ol.sequence_pointer^);
      PUSH old_section_list: [0 .. old_identification_record^.greatest_section_ordinal];
      create_section_list (section_definitions, old_ol, old_section_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      RESET new_ol.sequence_pointer TO new_interpretive_element;
      NEXT object_text_descriptor IN new_ol.sequence_pointer;
      IF object_text_descriptor^.kind <> llc$identification THEN
        osp$set_status_abnormal (occ$status_id, oce$id_record_expected, ' ', status);
        RETURN;
      IFEND;

      NEXT new_identification_record IN new_ol.sequence_pointer;

      IF NOT (llc$section_element IN new_module_header^.interpretive_header.elements_defined) THEN
        RETURN;
      IFEND;

      section_definitions := #PTR (new_module_header^.interpretive_header.section_definitions,
            new_ol.sequence_pointer^);
      PUSH new_section_list: [0 .. new_identification_record^.greatest_section_ordinal];
      create_section_list (section_definitions, new_ol, new_section_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF new_identification_record^.greatest_section_ordinal =
            old_identification_record^.greatest_section_ordinal THEN
        i := 0;
        same_section_lists := TRUE;
        WHILE same_section_lists AND (i <= old_identification_record^.greatest_section_ordinal) DO
          same_section_lists := (old_section_list^ [i] = new_section_list^ [i]);
          i := i + 1;
        WHILEND;
      ELSE
        same_section_lists := FALSE;
      IFEND;

      ALLOCATE section_directory: [0 .. old_identification_record^.greatest_section_ordinal];
      IF same_section_lists THEN
        FOR i := 0 TO UPPERBOUND (section_directory^) DO
          section_directory^ [i].new_section_number := i;
        FOREND;
        RETURN;
      IFEND;

      ALLOCATE section_number_cv: [0 .. old_identification_record^.greatest_section_ordinal];

      start := 0;
      FOR i := 0 TO old_identification_record^.greatest_section_ordinal DO
        j := start;
        match_found := FALSE;
        search_complete := FALSE;
        section_number_cv^ [i] := occ$invalid_section_ordinal;
        section_directory^ [i].new_section_number := occ$invalid_section_ordinal;

        WHILE NOT match_found AND NOT search_complete DO
          match_found := (old_section_list^ [i] = new_section_list^ [j]) AND (old_section_list^ [i].
                found = FALSE);
          IF match_found THEN
            old_section_list^ [i].found := TRUE;
            new_section_list^ [j].found := TRUE;
            section_number_cv^ [i] := j;
            section_directory^ [i].new_section_number := j;
            start := j + 1;
            IF start > new_identification_record^.greatest_section_ordinal THEN
              start := 0;
            IFEND;
          ELSE
            j := j + 1;
            IF j > new_identification_record^.greatest_section_ordinal THEN
              j := 0;
            IFEND;
            search_complete := (j = start);
          IFEND;
        WHILEND;
      FOREND;
    IFEND;
  PROCEND build_section_number_cv;
?? EJECT ??
?? OLDTITLE ??
?? NEWTITLE := 'BUILD_SECTION_OCV' ??
*copyc och$build_section_ocv

  PROCEDURE build_section_ocv
    (    old_section_map: ^llt$section_map_items;
         new_section_map: ^llt$section_map_items;
         section_ordinal: llt$section_ordinal;
         old_section_definitions: ^llt$object_text_descriptor;
         p_old_object_library: ^SEQ ( * );
         old_component_info: ^llt$component_information;
         new_component_info: ^llt$component_information;
     VAR normal_socv: amt$segment_pointer;
     VAR section_offset_cv: ^oct$section_offset_changes;
     VAR socv_generated: boolean;
     VAR status: ost$status);

    VAR
      i: llt$section_ordinal,
      j: llt$section_ordinal,
      k: llt$section_ordinal,
      length: llt$section_ordinal,
      match_found: boolean,
      object_text_descriptor: ^llt$object_text_descriptor,
      old_object_library: ^SEQ ( * ),
      search_complete: boolean,
      section_definition: ^llt$section_definition,
      section_found: boolean,
      section_offset_changes: ^oct$offset_change_list,
      start: llt$section_ordinal,
      string_length: integer,
      string_ordinal: string (osc$max_string_size);

    status.normal := TRUE;

    old_object_library := p_old_object_library;

    PUSH section_offset_changes: [1 .. llc$max_section_ordinal];
    k := 1;
    start := 1;
    FOR i := 1 TO UPPERBOUND (old_section_map^) DO
      j := start;
      match_found := FALSE;
      search_complete := FALSE;
      WHILE NOT match_found AND NOT search_complete DO
        match_found := (old_section_map^ [i].name = new_section_map^ [j].name) AND
              (old_component_info^ [old_section_map^ [i].component].
              name = new_component_info^ [new_section_map^ [j].component].name);
        IF match_found THEN
          section_offset_changes^ [k].offset := old_section_map^ [i].offset;
          section_offset_changes^ [k].delta := new_section_map^ [j].offset - old_section_map^ [i].offset;
          k := k + 1;
          start := j + 1;
          IF start > UPPERBOUND (new_section_map^) THEN
            start := 1;
          IFEND;
        ELSE
          j := j + 1;
          IF j > UPPERBOUND (new_section_map^) THEN
            j := 1;
          IFEND;
          search_complete := (j = start);
        IFEND;
      WHILEND;
    FOREND;
    length := k - 1;
    i := 1;
    WHILE (i <= length) AND (section_offset_changes^ [i].delta = 0) DO
      i := i + 1;
    WHILEND;
    IF ((i - 1) = length) OR (length = 0) THEN
      socv_generated := FALSE;
      RETURN;
    IFEND;
    socv_generated := TRUE;

{ Compress section offset change vector.

    i := 2;
    j := 2;
    WHILE i <= length DO
      WHILE (i <= length) AND (section_offset_changes^ [i - 1].delta = section_offset_changes^ [i].delta) DO
        i := i + 1;
      WHILEND;
      IF i <= length THEN
        section_offset_changes^ [j] := section_offset_changes^ [i];
        j := j + 1;
        i := i + 1;
      IFEND;
    WHILEND;
    length := j - 1;
    RESET old_object_library TO old_section_definitions;
    section_found := FALSE;
    REPEAT
      NEXT object_text_descriptor IN old_object_library;
      CASE object_text_descriptor^.kind OF
      = llc$section_definition, llc$allotted_section_definition, llc$unallocated_common_block =
        NEXT section_definition IN old_object_library;
        section_found := (section_definition^.section_ordinal = section_ordinal);
      ELSE
        STRINGREP (string_ordinal, string_length, section_ordinal);
        osp$set_status_abnormal (occ$status_id, oce$no_section_definition, string_ordinal (1, string_length),
              status);
        RETURN;
      CASEND;
    UNTIL section_found;
    NEXT section_offset_cv: [1 .. length] IN normal_socv.sequence_pointer;
    section_offset_cv^.header.section_ordinal := section_ordinal;
    section_offset_cv^.header.number_of_socv_items := length;
    section_offset_cv^.header.section_kind := section_definition^.kind;
    section_offset_cv^.change_list := section_offset_changes^;
  PROCEND build_section_ocv;
?? EJECT ??
?? OLDTITLE ??
?? NEWTITLE := 'COMPRESS_CHANGE_VECTOR' ??
*copyc och$compress_change_vector

  PROCEDURE compress_change_vector
    (VAR change_vector: ^oct$offset_change_list;
     VAR number: oct$max_offset_changes);

    PROCEDURE sort_change_vector
      (    number: oct$max_offset_changes;
       VAR change_vector: ^oct$offset_change_list);

      VAR
        i: integer,
        j: integer,
        key: llt$section_offset,
        left: integer,
        right: integer,
        temp: oct$change_items;


      IF number = 2 THEN
        IF change_vector^ [1].offset > change_vector^ [2].offset THEN
          temp := change_vector^ [1];
          change_vector^ [1] := change_vector^ [2];
          change_vector^ [2] := temp;
        IFEND;
        RETURN;
      IFEND;

      left := (number DIV 2) + 1;
      right := number;

    /outer_loop/
      WHILE TRUE DO
        IF left > 1 THEN
          left := left - 1;
          temp := change_vector^ [left];
          key := change_vector^ [left].offset;
        ELSE
          temp := change_vector^ [right];
          key := change_vector^ [right].offset;
          change_vector^ [right] := change_vector^ [1];
          right := right - 1;
          IF right = 1 THEN
            change_vector^ [right] := temp;
            RETURN;
          IFEND;
        IFEND;

        j := left;

      /inner_loop/
        WHILE TRUE DO
          i := j;
          j := j + j;
          IF j < right THEN
            IF (change_vector^ [j].offset < change_vector^ [j + 1].offset) THEN
              j := j + 1;
            IFEND;
          ELSEIF j > right THEN
            EXIT /inner_loop/;
          IFEND;

          IF key >= change_vector^ [j].offset THEN
            EXIT /inner_loop/;
          IFEND;

          change_vector^ [i] := change_vector^ [j];
        WHILEND /inner_loop/;

        change_vector^ [i] := temp;
      WHILEND /outer_loop/;
    PROCEND sort_change_vector;

    VAR
      i: integer,
      j: integer;

    IF number <= 1 THEN
      RETURN;
    IFEND;

    sort_change_vector (number, change_vector);

    j := 1;
    i := 1;
    WHILE i <= number DO
      WHILE (i < number) AND (change_vector^ [i].delta = change_vector^ [i + 1].delta) DO
        i := i + 1;
      WHILEND;
      change_vector^ [j] := change_vector^ [i];
      j := j + 1;
      i := i + 1;
    WHILEND;

    number := j - 1;
  PROCEND compress_change_vector;
?? EJECT ??
?? OLDTITLE ??
?? NEWTITLE := 'CONSTRUCT_MODULE_PREDICTOR' ??
*copyc och$construct_module_predictor

  PROCEDURE construct_module_predictor
    (    module_name: pmt$program_name;
         number_section_offset_cvs: llt$section_ordinal;
         section_number_cv: ^oct$new_ordinal_list;
         p_normal_socv: amt$segment_pointer;
         binding_section_ocv: ^oct$offset_change_list;
         binding_section: llt$section_ordinal;
         component_index_cv: ^array [1 .. * ] of 0 .. llc$max_components;
         length_component_index_cv: 0 .. llc$max_components;
     VAR single_predictor: ^SEQ ( * );
     VAR size_of_predictor: oct$module_predictor_size);

    VAR
      binding_section_changes: ^oct$offset_change_list,
      component_index_changes: ^array [1 .. * ] of 0 .. llc$max_components,
      i: llt$section_length,
      module_predictor_header: ^oct$single_module_predictor_hdr,
      normal_socv: amt$segment_pointer,
      section_info: ^oct$section_info,
      section_number_change_list: ^oct$new_ordinal_list,
      section_offset_change_list: ^oct$offset_change_list,
      section_offset_cv: ^oct$section_offset_changes;

    normal_socv := p_normal_socv;

    RESET single_predictor;
    NEXT module_predictor_header IN single_predictor;
    size_of_predictor := #SIZE (module_predictor_header^);
    module_predictor_header^.module_name := module_name;
    module_predictor_header^.kind := llc$load_module;
    module_predictor_header^.last_section_ordinal := occ$invalid_section_ordinal;
    module_predictor_header^.length_normal_section_ocv := 0;
    module_predictor_header^.length_binding_socv := 0;
    module_predictor_header^.length_component_index_cv := 0;
    IF section_number_cv <> NIL THEN
      module_predictor_header^.last_section_ordinal := UPPERBOUND (section_number_cv^);
      NEXT section_number_change_list: [0 .. UPPERBOUND (section_number_cv^)] IN single_predictor;
      section_number_change_list^ := section_number_cv^;
      module_predictor_header^.section_number_cv := #REL (section_number_change_list, single_predictor^);
      size_of_predictor := size_of_predictor + #SIZE (section_number_change_list^);
    IFEND;
    IF number_section_offset_cvs > 0 THEN
      module_predictor_header^.length_normal_section_ocv := number_section_offset_cvs;
      RESET normal_socv.sequence_pointer;
      NEXT section_info IN normal_socv.sequence_pointer;
      NEXT section_offset_change_list: [1 .. section_info^.number_of_socv_items] IN
            normal_socv.sequence_pointer;
      NEXT section_offset_cv: [1 .. section_info^.number_of_socv_items] IN single_predictor;
      module_predictor_header^.section_offset_cv := #REL (section_offset_cv, single_predictor^);
      section_offset_cv^.header := section_info^;
      section_offset_cv^.change_list := section_offset_change_list^;
      size_of_predictor := size_of_predictor + #SIZE (section_offset_cv^);
      FOR i := 2 TO number_section_offset_cvs DO
        NEXT section_info IN normal_socv.sequence_pointer;
        NEXT section_offset_change_list: [1 .. section_info^.number_of_socv_items] IN
              normal_socv.sequence_pointer;
        NEXT section_offset_cv: [1 .. section_info^.number_of_socv_items] IN single_predictor;
        section_offset_cv^.header := section_info^;
        section_offset_cv^.change_list := section_offset_change_list^;
        size_of_predictor := size_of_predictor + #SIZE (section_offset_cv^);
      FOREND;
    IFEND;
    IF binding_section_ocv <> NIL THEN
      module_predictor_header^.length_binding_socv := UPPERBOUND (binding_section_ocv^);
      NEXT binding_section_changes: [1 .. UPPERBOUND (binding_section_ocv^)] IN single_predictor;
      binding_section_changes^ := binding_section_ocv^;
      size_of_predictor := size_of_predictor + #SIZE (binding_section_changes^);
      module_predictor_header^.binding_section_ocv := #REL (binding_section_changes, single_predictor^);
      module_predictor_header^.binding_section_ordinal := binding_section;
    IFEND;
    IF component_index_cv <> NIL THEN
      module_predictor_header^.length_component_index_cv := length_component_index_cv;
      NEXT component_index_changes: [1 .. length_component_index_cv] IN single_predictor;
      component_index_changes^ := component_index_cv^;
      size_of_predictor := size_of_predictor + #SIZE (component_index_changes^);
      module_predictor_header^.component_index_cv := #REL (component_index_changes, single_predictor^);
    IFEND;

    module_predictor_header^.predictor_size := size_of_predictor;
    IF (module_predictor_header^.last_section_ordinal = occ$invalid_section_ordinal) AND
          (module_predictor_header^.length_normal_section_ocv = 0) AND
          (module_predictor_header^.length_binding_socv = 0) AND
          (module_predictor_header^.length_component_index_cv = 0) THEN
      size_of_predictor := 0;
    IFEND;
  PROCEND construct_module_predictor;
?? EJECT ??
?? OLDTITLE ??
?? NEWTITLE := 'CREATE_SECTION_LIST' ??
*copyc och$create_section_list

  PROCEDURE create_section_list
    (    section_definitions: ^llt$object_text_descriptor;
         p_seg_p: amt$segment_pointer;
     VAR section_list: ^oct$section_list;
     VAR status: ost$status);

    VAR
      i: llt$section_ordinal,
      length: integer,
      no_more_sections: boolean,
      object_text_descriptor: ^llt$object_text_descriptor,
      obsolete_segment_definition: ^llt$obsolete_segment_definition,
      section_definition: ^llt$section_definition,
      seg_p: amt$segment_pointer,
      segment_definition: ^llt$segment_definition,
      text: string (osc$max_string_size);

    status.normal := TRUE;

    seg_p := p_seg_p;

    FOR i := 0 TO UPPERBOUND (section_list^) DO
      no_more_sections := FALSE;
      RESET seg_p.sequence_pointer TO section_definitions;
      REPEAT
        NEXT object_text_descriptor IN seg_p.sequence_pointer;
        CASE object_text_descriptor^.kind OF
        = llc$section_definition, llc$allotted_section_definition, llc$unallocated_common_block =
          NEXT section_definition IN seg_p.sequence_pointer;
        = llc$segment_definition, llc$allotted_segment_definition =
          NEXT segment_definition IN seg_p.sequence_pointer;
          section_definition := ^segment_definition^.section_definition;
        = llc$obsolete_segment_definition, llc$obsolete_allotted_seg_def =
          NEXT obsolete_segment_definition IN seg_p.sequence_pointer;
          section_definition := ^obsolete_segment_definition^.section_definition;
        ELSE
          no_more_sections := TRUE;
        CASEND;
      UNTIL no_more_sections OR (section_definition^.section_ordinal = i);
      IF section_definition^.section_ordinal = i THEN
        section_list^ [i].found := FALSE;
        section_list^ [i].allotted := (object_text_descriptor^.kind = llc$allotted_section_definition) OR
              (object_text_descriptor^.kind = llc$allotted_segment_definition) OR
              (object_text_descriptor^.kind = llc$obsolete_allotted_seg_def);
        section_list^ [i].kind := section_definition^.kind;
        section_list^ [i].access_attributes := section_definition^.access_attributes;
        section_list^ [i].name := section_definition^.name;
      ELSE
        STRINGREP (text, length, i);
        osp$set_status_abnormal (occ$status_id, oce$no_section_definition, text (1, length), status);
        RETURN;
      IFEND;
    FOREND;
  PROCEND create_section_list;
?? EJECT ??
?? OLDTITLE ??
*copyc och$generate_ol_predictor

  PROCEDURE [XDCL] ocp$generate_ol_predictor
    (    old_file_name: fst$file_reference;
         new_file_name: fst$file_reference;
     VAR old_ol: amt$segment_pointer;
     VAR new_ol: amt$segment_pointer;
     VAR predictor: amt$segment_pointer;
     VAR module_directory: ^oct$module_directory;
     VAR status: ost$status);

    VAR
      i: llt$module_index,
      j: llt$module_index,
      match_found: boolean,
      new_found: boolean,
      new_header: ^llt$object_library_header,
      new_module_dictionary: ^llt$module_dictionary,
      new_ol_dictionaries: ^llt$object_library_dictionaries,
      old_found: boolean,
      old_header: ^llt$object_library_header,
      old_module_dictionary: ^llt$module_dictionary,
      old_ol_dictionaries: ^llt$object_library_dictionaries,
      predictor_header: ^oct$predictor_header,
      search_complete: boolean,
      start: llt$module_index;

    status.normal := TRUE;

    RESET predictor.sequence_pointer;
    NEXT predictor_header IN predictor.sequence_pointer;
    predictor_header^.size_predictor := #SIZE (predictor_header^);

    RESET old_ol.sequence_pointer;
    RESET new_ol.sequence_pointer;

    NEXT old_header IN old_ol.sequence_pointer;
    IF old_header^.version <> llc$object_library_version THEN
      osp$set_status_abnormal (occ$status_id, oce$invalid_library_version, old_file_name, status);
      RETURN;
    IFEND;

    NEXT new_header IN new_ol.sequence_pointer;
    IF new_header^.version <> llc$object_library_version THEN
      osp$set_status_abnormal (occ$status_id, oce$invalid_library_version, new_file_name, status);
      RETURN;
    IFEND;

    NEXT old_ol_dictionaries: [1 .. old_header^.number_of_dictionaries] IN old_ol.sequence_pointer;
    NEXT new_ol_dictionaries: [1 .. new_header^.number_of_dictionaries] IN new_ol.sequence_pointer;

    i := 1;
    old_found := FALSE;
    WHILE NOT old_found AND (i <= old_header^.number_of_dictionaries) DO
      IF old_ol_dictionaries^ [i].kind = llc$module_dictionary THEN
        old_found := TRUE;
        old_module_dictionary := #PTR (old_ol_dictionaries^ [i].module_dictionary, old_ol.sequence_pointer^);
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;
    IF old_found THEN
      i := 1;
      new_found := FALSE;
      WHILE NOT new_found AND (i <= new_header^.number_of_dictionaries) DO
        IF new_ol_dictionaries^ [i].kind = llc$module_dictionary THEN
          new_found := TRUE;
          new_module_dictionary := #PTR (new_ol_dictionaries^ [i].module_dictionary,
                new_ol.sequence_pointer^);
        ELSE
          i := i + 1;
        IFEND;
      WHILEND;
      IF new_found THEN
        ALLOCATE module_directory: [1 .. UPPERBOUND (old_module_dictionary^)];
        start := 1;
        FOR i := 1 TO UPPERBOUND (old_module_dictionary^) DO
          match_found := FALSE;
          search_complete := FALSE;
          module_directory^ [i].module_name := old_module_dictionary^ [i].name;
          module_directory^ [i].new_module_number := 0;
          module_directory^ [i].last_section_ordinal := occ$invalid_section_ordinal;
          module_directory^ [i].section_number_change_list := NIL;
          module_directory^ [i].number_of_components := 0;
          module_directory^ [i].number_of_rel_items := 0;
          j := start;
          WHILE NOT match_found AND NOT search_complete DO
            match_found := (old_module_dictionary^ [i].name = new_module_dictionary^ [j].name) AND
                  (old_module_dictionary^ [i].kind = new_module_dictionary^ [j].kind);
            IF match_found THEN
              module_directory^ [i].new_module_number := j;
              start := j + 1;
              IF start > UPPERBOUND (new_module_dictionary^) THEN
                start := 1;
              IFEND;
            ELSE
              j := j + 1;
              IF j > UPPERBOUND (new_module_dictionary^) THEN
                j := 1;
              IFEND;
              search_complete := (j = start);
            IFEND;
          WHILEND;
        FOREND;

        build_module_predictors (new_file_name, old_file_name, old_ol, new_ol, old_module_dictionary,
              new_module_dictionary, module_directory, predictor, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        build_mod_dictionary_ocv (module_directory, old_module_dictionary, new_module_dictionary, old_ol,
              new_ol, predictor, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;
    build_ol_dictionary_ocv (old_ol, new_ol, predictor, status);
  PROCEND ocp$generate_ol_predictor;
MODEND ocm$generate_predictor;
*DECK DECK=OCM$INTERRUPT_AND_ERROR_HANDLER EXPAND=TRUE
?? RIGHT := 110 ??
*copy osd$default_pragmats
MODULE ocm$interrupt_and_error_handler;


  { Purpose: This module contains the following general interrupt and error handling routines:
  {
  {                   ocp$ignore_interupts;
  {                   ocp$abort
  {                   ocp$abort_if_abnormal_status
  {                   ocp$abort_if_segment_overflow
  {                   ocp$abort_if_premature_eof
  {                   ocp$abort_with_structure_error
  {                   ocp$internal_error



  { *copyc oct$interrupt_types
  { *copyc oce$interrupt_exceptions

  { *copyc clt$file
  { *copyc pmp$abort
  { *copyc pmp$cause_condition
  { *copyc pmt$condition
  { *copyc ost$stack_frame_save_area

  { *copyc osp$set_status_abnormal
  { *copyc osp$append_status_parameter
?? PUSH (LIST := OFF) ??
*copyc oct$interrupt_types
*copyc oce$interrupt_exceptions

*copyc clt$file
*copyc pmp$abort
*copyc pmp$cause_condition
*copyc pmt$condition
*copyc ost$stack_frame_save_area

*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
?? POP ??
?? NEWTITLE := 'OCP$IGNORE_INTERUPTS', EJECT ??




  VAR
    ocv$interupt_condition: [XDCL, READ] pmt$condition := [ifc$interactive_condition,
      ifc$terminate_break];




  PROCEDURE [XDCL] ocp$ignore_interupts (condition: pmt$condition;
        condition_information: ^pmt$condition_information;
        stack_frame_save_area: ^ost$stack_frame_save_area;
    VAR condition_status: ost$status);


    condition_status.normal := TRUE;


  PROCEND ocp$ignore_interupts;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$ABORT' ??
?? NEWTITLE := '  OCP$ABORT_IF_ABNORMAL_STATUS' ??
?? NEWTITLE := '  OCP$INTERNAL_ERROR', EJECT ??

  PROCEDURE [XDCL] ocp$abort (abort_status: ost$status);


    VAR
      return_status: ost$status;


    pmp$cause_condition (occ$abort_condition, ^abort_status, return_status);

    IF (NOT return_status.normal) THEN
      pmp$abort (abort_status);
    IFEND;


  PROCEND ocp$abort;
?? OLDTITLE ??




  PROCEDURE [XDCL] ocp$abort_if_abnormal_status (status: ost$status);


    IF NOT status.normal THEN
      ocp$abort (status);
    IFEND;


  PROCEND ocp$abort_if_abnormal_status;
?? OLDTITLE ??




  PROCEDURE [XDCL] ocp$internal_error (error_text: string ( * ));


    VAR
      abort_status: ost$status;


    osp$set_status_abnormal ('OC', oce$internal_error, error_text, abort_status);

    ocp$abort (abort_status);


  PROCEND ocp$internal_error;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$ABORT_IF_SEGMENT_OVERFLOW' ??
?? NEWTITLE := '  OCP$ABORT_IF_PREMATURE_EOF', ??
?? NEWTITLE := '  OCP$ABORT_WITH_STRUCTURE_ERROR', EJECT ??

  PROCEDURE [XDCL] ocp$abort_if_segment_overflow (segment_pointer: ^cell);

     VAR
       pointer: ^^cell;

    pointer := segment_pointer;

    IF (pointer^ = NIL) THEN
      ocp$internal_error ('Internal segment overflow')
    IFEND;

  PROCEND ocp$abort_if_segment_overflow;
?? OLDTITLE ??




  PROCEDURE [XDCL] ocp$abort_if_premature_eof (segment_pointer: ^cell;
        file: clt$file);

     VAR
       pointer: ^^cell,
       abort_status: ost$status;

    pointer := segment_pointer;

    IF (pointer^ = NIL) THEN
      osp$set_status_abnormal ('OC', oce$premature_eof_in_segment, file.local_file_name, abort_status);
      ocp$abort (abort_status);
    IFEND;

  PROCEND ocp$abort_if_premature_eof;
?? OLDTITLE ??




  PROCEDURE [XDCL] ocp$abort_with_structure_error (error: string ( * );
        file: clt$file);

    VAR
      abort_status: ost$status;

    osp$set_status_abnormal ('OC', oce$structure_error_in_segment, error, abort_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, file.local_file_name, abort_status);

    ocp$abort (abort_status);

  PROCEND ocp$abort_with_structure_error;
?? OLDTITLE ??




MODEND ocm$interrupt_and_error_handler.

*DECK DECK=OCM$LINKER_DEBUG_TABLE_BUILDER EXPAND=TRUE
?? 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;
*DECK DECK=OCM$LINK_MAP_GENERATOR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : VEL Link Map Generator' ??
MODULE ocm$link_map_generator;

{  PURPOSE:
{    This module handles output to the LINK MAP generated by the
{  virtual environment linker.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fsc$file_contents
*copyc fst$file_reference
*copyc llt$load_module
*copyc llt$object_module
*copyc loe$map_malfunction
*copyc lot$load_map_data
*copyc lot$loader_options
*copyc lot$loader_type_definitions
?? POP ??
*copyc amp$store
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_string_to_file
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$open_display_file
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc pmp$cause_condition
*copyc pmp$get_last_path_name
*copyc pmp$get_legible_date_time
*copyc pmp$get_os_version
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    start_of_accumulation_line = 8;

  TYPE
    oct$lm_header = (occ$lm_section_header, occ$lm_entry_header, occ$lm_xref_header, occ$lm_segment_header),
    oct$lines_per_header_text = array [oct$lm_header] of 0 .. 15,
    oct$lines_per_detail_text = array [lot$lm_code] of 0 .. 15;

  VAR
    accumulation_line_position: [STATIC] start_of_accumulation_line .. 135,
    continuous_form: [STATIC] boolean,
    display_control: [STATIC] clt$display_control,
    entry_detail_header_listed: [STATIC] boolean,
    lines_per_detail_text: [STATIC] ^oct$lines_per_detail_text,
    lines_per_header_text: [STATIC] ^oct$lines_per_header_text,
    narrow_format: [STATIC] boolean,
    section_detail_header_listed: [STATIC] boolean,
    segment_header_listed: [STATIC] boolean,
    xref_header_listed: [STATIC] boolean;

  VAR
    continuous_increments: [READ] oct$lines_per_detail_text := [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0],
    non_cont_wide_increments: [READ] oct$lines_per_detail_text :=
          [4, 1, 2, 1, 2, 2, 4, 1, 1, 1, 1, 8, 0, 0, 0],
    non_cont_narrow_increments: [READ] oct$lines_per_detail_text :=
          [5, 2, 3, 1, 3, 2, 4, 1, 1, 1, 1, 8, 0, 0, 0];

  VAR
    continuous_header_increments: [READ] oct$lines_per_header_text := [0, 0, 0, 0],
    non_cont_wide_header_increments: [READ] oct$lines_per_header_text := [4, 5, 6, 6],
    non_cont_narrow_header_incremts: [READ] oct$lines_per_header_text := [5, 5, 7, 6];

  VAR
    page_header: [STATIC] string (72) := '                         LINK MAP.                            PAGE';

  VAR
    privilege_table: [READ] array [ost$execute_privilege] of string (6) := ['      ', '      ', 'LOCAL ',
          'GLOBAL '],
    section_kind_table: [READ] array [llt$section_kind] of string (26) := ['CODE                      ',
          'BINDING                   ', 'WORKING_STORAGE           ', 'COMMON_BLOCK              ',
          'EXTENSIBLE_WORKING_STORAGE', 'EXTENSIBLE_COMMON_BLOCK   ', 'LINE_ADDRESS_TABLE        '];



  VAR
    skeleton_module_detail_1: [STATIC] string (194) := 'MODULE:                                    FROM      '
          CAT '  :                                    LOADED RING:       CALL BRACKET:       GLOBAL KEY/L' CAT
          'OCK:    ' CAT '   LOCAL KEY/LOCK:       PRIVILEGE:       ',
    skeleton_module_detail_2: [STATIC] string (127) := '   DATE:             GENERATOR:                      '
          CAT '                       COMMENTS:                                         ',
    section_detail_header: [READ] string (104) := '   SECTION TYPE                    ACCESS ATTRIBUTES   LOA'
          CAT 'DED ADDRESS    (16) LENGTH (10)  SECTION NAME',
    skeleton_section_detail: [STATIC] string (123) := '                                                      '
          CAT '                                                                  ',
    entry_detail_header: [READ] string (48) := '   ENTRY POINT NAME                     ADDRESS',
    skeleton_entry_detail: [STATIC] string (101) := '                                                    ' CAT
          '                                                ',
    xref_header: [READ] string (146) := 'ENTRY POINT CROSS REFERENCE MAP    ENTRY POINT NAME                 '
          CAT '    ADDRESS                      DEFINING MODULE        REFERENCING MODULE(S)',
    segment_detail_header: [READ] string (138) := 'ALLOCATED SEGMENT MAP    SEGMENT                          '
          CAT '  GLOBAL&LOCAL    NUMBER       (16) LENGTH (10)    R1/R2     ACCESS ATTRIBUTES',
    skeleton_segment_detail: [STATIC] string (71) :=
          '                                   (  ,  )                            ',
    skeleton_transfer_detail: [STATIC] string (83) :=
          'TRANSFER SYMBOL :                                 TRANSFER ADDRESS:               ',
    skeleton_accumulate_names: [STATIC] string (135) := '                                                    '
          CAT '                                                                                        ',
    skeleton_asis_text: [STATIC] string (132) := ' ',
    diagnostic_summary_header: [READ] string (21) := 'DIAGNOSTIC SUMMARY: ',
    header_data_divider: [READ] string (123) := '   ---------------------------------------------------------'
          CAT '--------------------------------------------------------------';

?? OLDTITLE ??
?? NEWTITLE := '    NEW_PAGE_PROCEDURE', EJECT ??

  PROCEDURE new_page_procedure
    (VAR display_control: clt$display_control;
         new_page_number: integer;
     VAR status: ost$status);


    VAR
      l: integer;


    clp$reset_for_next_display_page (display_control, status);

    page_header (67, 5) := '     ';

    STRINGREP (page_header (67, * ), l, display_control.page_number);
    clp$put_display (display_control, page_header, clc$trim, status);

    clp$new_display_line (display_control, 2, status);


  PROCEND new_page_procedure;
?? OLDTITLE ??
?? NEWTITLE := '  LINK_MAP_ERROR_EXIT_PROCEDURE', EJECT ??

  PROCEDURE link_map_error_exit_procedure
    (    file_identifier: amt$file_identifier;
     VAR status {input} : ost$status);


    VAR
      dummy: ost$status;


    pmp$cause_condition (loe$map_malfunction, ^status, dummy);


  PROCEND link_map_error_exit_procedure;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$INITIALIZE_LINK_MAP', EJECT ??

  PROCEDURE [XDCL] ocp$initialize_link_map
    (    map_file: fst$file_reference;
         build_level: pmt$os_name;
     VAR status: ost$status);


    CONST
      wide_format_threshold = 126;

    VAR
      of_execution: boolean,
      date: ost$date,
      time: ost$time,

      file: clt$file,
      default_rings: amt$ring_attributes,
      file_attributes: array [1 .. 1] of amt$store_item;


    status.normal := TRUE;

    clp$convert_string_to_file (map_file, file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    default_rings.r1 := #RING (^of_execution);
    default_rings.r2 := #RING (^of_execution);
    default_rings.r3 := #RING (^of_execution);

    clp$open_display_file (file, ^new_page_procedure, fsc$list, default_rings, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF display_control.page_width > 132 THEN
      display_control.page_width := 132;
    IFEND;


    file_attributes [1].key := amc$error_exit_procedure;
    file_attributes [1].error_exit_procedure := ^link_map_error_exit_procedure;

    amp$store (display_control.file_id, file_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
?? EJECT ??


    narrow_format := display_control.page_width < wide_format_threshold;

    IF display_control.page_format = amc$continuous_form THEN
      continuous_form := TRUE;
      lines_per_detail_text := ^continuous_increments;
      lines_per_header_text := ^continuous_header_increments;
    ELSE
      continuous_form := FALSE;
      IF narrow_format THEN
        lines_per_detail_text := ^non_cont_narrow_increments;
        lines_per_header_text := ^non_cont_narrow_header_incremts;
      ELSE
        lines_per_detail_text := ^non_cont_wide_increments;
        lines_per_header_text := ^non_cont_wide_header_increments;
      IFEND;
    IFEND;


    page_header (1, 22) := build_level;

    pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    page_header (40, 8) := date.mdy;
    page_header (50, 8) := time.hms;


    xref_header_listed := FALSE;
    segment_header_listed := FALSE;
    accumulation_line_position := start_of_accumulation_line;


  PROCEND ocp$initialize_link_map;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$GENERATE_LINK_MAP_TEXT', EJECT ??

  PROCEDURE [XDCL] ocp$generate_link_map_text
    (    link_map_data: lot$load_map_data);


    VAR
      status: ost$status,
      window_position: 35 .. 72,
      name_length: 1 .. 32,
      message_content: ost$status_message,
      message: ^ost$status_message,
      diagnostic_line_count: ^ost$status_message_line_count,
      diagnostic_line_index: ost$status_message_line_count,
      diagnostic_line_size: ^ost$status_message_line_size,
      diagnostic_line: ^ost$status_message_line,
      severity: ost$status_severity,
      diagnostic_header_generated: boolean,
      diagnostic_summary_detail: string (38),
      converted_number: string (7),
      conversion_length: integer,
      last_character: 0 .. 41;


    CASE link_map_data.code OF
    = loc$lm_module_detail_1 =
      skeleton_module_detail_1 (9, 31) := link_map_data.module_name;
      skeleton_module_detail_1 (49, 7) := link_map_data.file_type;
      pmp$get_last_path_name (link_map_data.file_name, skeleton_module_detail_1 (58, 31), status);
      clp$convert_integer_to_rjstring (link_map_data.loaded_ring, 16, FALSE, ' ',
            skeleton_module_detail_1 (106, 2), status);
      clp$convert_integer_to_rjstring (link_map_data.call_bracket, 16, FALSE, ' ',
            skeleton_module_detail_1 (126, 2), status);
      clp$convert_integer_to_rjstring (link_map_data.module_global_key_lock, 16, FALSE, ' ',
            skeleton_module_detail_1 (149, 2), status);
      clp$convert_integer_to_rjstring (link_map_data.module_local_key_lock, 16, FALSE, ' ',
            skeleton_module_detail_1 (171, 2), status);
      skeleton_module_detail_1 (188, 6) := privilege_table [link_map_data.execute_privilege];

      IF (display_control.line_number + lines_per_detail_text^ [loc$lm_module_detail_1]) >
            display_control.page_length THEN
        clp$new_display_page (display_control, status);
      IFEND;
      clp$new_display_line (display_control, 2, status);
      IF narrow_format THEN
        clp$put_display (display_control, skeleton_module_detail_1 (1, 39), clc$trim, status);
        clp$put_display (display_control, skeleton_module_detail_1 (41, 49), clc$trim, status);
      ELSE
        clp$put_display (display_control, skeleton_module_detail_1 (1, 88), clc$trim, status);
      IFEND;
      clp$put_display (display_control, skeleton_module_detail_1 (90, 39), clc$trim, status);
      clp$put_display (display_control, skeleton_module_detail_1 (129, 66), clc$trim, status);
      section_detail_header_listed := FALSE;
      entry_detail_header_listed := FALSE;
?? EJECT ??

    = loc$lm_module_detail_2 =
      skeleton_module_detail_2 (10, 10) := link_map_data.date;
      skeleton_module_detail_2 (33, 40) := link_map_data.generator;
      skeleton_module_detail_2 (87, 40) := link_map_data.commentary;
      IF (display_control.line_number + lines_per_detail_text^ [loc$lm_module_detail_2]) >
            display_control.page_length THEN
        clp$new_display_page (display_control, status);
      IFEND;
      IF narrow_format THEN
        clp$put_display (display_control, skeleton_module_detail_2 (1, 72), clc$trim, status);
        clp$put_display (display_control, skeleton_module_detail_2 (74, 54), clc$trim, status);
      ELSE
        clp$put_display (display_control, skeleton_module_detail_2, clc$trim, status);
      IFEND;


    = loc$lm_section_detail =
      IF NOT section_detail_header_listed THEN
        section_detail_header_listed := TRUE;
        IF (display_control.line_number + lines_per_header_text^ [occ$lm_section_header] +
              lines_per_detail_text^ [loc$lm_section_detail]) > display_control.page_length THEN
          clp$new_display_page (display_control, status);
        IFEND;
        clp$new_display_line (display_control, 2, status);
        IF narrow_format THEN
          clp$put_display (display_control, section_detail_header (1, 53), clc$trim, status);
          clp$put_display (display_control, section_detail_header (55, 50), clc$trim, status);
          clp$put_display (display_control, header_data_divider (1, 68), clc$trim, status);
        ELSE
          clp$put_display (display_control, section_detail_header, clc$trim, status);
          clp$put_display (display_control, header_data_divider, clc$trim, status);
        IFEND;
      IFEND;
?? EJECT ??

      skeleton_section_detail (4, 26) := section_kind_table [link_map_data.section_kind];
      window_position := 36;
      skeleton_section_detail (window_position, 26) := '';
      IF llc$binding IN link_map_data.section_access_attributes THEN
        skeleton_section_detail (window_position, 7) := 'BINDING';
        window_position := window_position + 8;
      IFEND;
      IF llc$execute IN link_map_data.section_access_attributes THEN
        skeleton_section_detail (window_position, 7) := 'EXECUTE';
        window_position := window_position + 8;
      IFEND;
      IF llc$read IN link_map_data.section_access_attributes THEN
        skeleton_section_detail (window_position, 4) := 'READ';
        window_position := window_position + 5;
      IFEND;
      IF llc$write IN link_map_data.section_access_attributes THEN
        skeleton_section_detail (window_position, 5) := 'WRITE';
      IFEND;
      clp$convert_integer_to_rjstring (link_map_data.section_address.segment, 16, FALSE, ' ',
            skeleton_section_detail (58, 3), status);
      clp$convert_integer_to_rjstring (link_map_data.section_address.offset, 16, FALSE, ' ',
            skeleton_section_detail (62, 8), status);
      clp$convert_integer_to_rjstring (link_map_data.section_length, 16, FALSE, ' ',
            skeleton_section_detail (71, 8), status);
      clp$convert_integer_to_rjstring (link_map_data.section_length, 10, FALSE, ' ',
            skeleton_section_detail (80, 10), status);
      skeleton_section_detail (92, 31) := link_map_data.section_name;

      IF (display_control.line_number + lines_per_detail_text^ [loc$lm_section_detail]) >
            display_control.page_length THEN
        clp$new_display_page (display_control, status);
      IFEND;
      clp$new_display_line (display_control, 1, status);
      IF narrow_format THEN
        clp$put_display (display_control, skeleton_section_detail (1, 53), clc$trim, status);
        clp$put_display (display_control, skeleton_section_detail (55, 67), clc$trim, status);
      ELSE
        clp$put_display (display_control, skeleton_section_detail, clc$trim, status);
      IFEND;
?? EJECT ??

    = loc$lm_entry_detail =
      IF NOT entry_detail_header_listed THEN
        entry_detail_header_listed := TRUE;
        IF (display_control.line_number + lines_per_header_text^ [occ$lm_entry_header] +
              lines_per_detail_text^ [loc$lm_entry_detail]) > display_control.page_length THEN
          clp$new_display_page (display_control, status);
        IFEND;
        clp$new_display_line (display_control, 2, status);
        clp$put_display (display_control, entry_detail_header, clc$trim, status);
        clp$put_display (display_control, header_data_divider (1, 66), clc$trim, status);
        clp$put_display (display_control, ' ', clc$trim, status);
      IFEND;

      skeleton_entry_detail (4, 31) := link_map_data.entry_name;
      clp$convert_integer_to_rjstring (link_map_data.entry_address.segment, 16, FALSE, ' ',
            skeleton_entry_detail (41, 3), status);
      clp$convert_integer_to_rjstring (link_map_data.entry_address.offset, 16, FALSE, ' ',
            skeleton_entry_detail (45, 8), status);
      skeleton_entry_detail (59, 5) := link_map_data.entry_attribute;
      skeleton_entry_detail (65, 8) := link_map_data.deferred;

      IF (display_control.line_number + lines_per_detail_text^ [loc$lm_entry_detail]) >
            display_control.page_length THEN
        clp$new_display_page (display_control, status);
      IFEND;
      clp$put_display (display_control, skeleton_entry_detail (1, 72), clc$trim, status);
?? EJECT ??

    = loc$lm_xref_detail =
      IF NOT xref_header_listed THEN
        xref_header_listed := TRUE;
        clp$new_display_page (display_control, status);
        clp$new_display_line (display_control, 2, status);
        IF narrow_format THEN
          clp$put_display (display_control, xref_header (1, 31), clc$trim, status);
          clp$put_display (display_control, xref_header (33, 64), clc$trim, status);
          clp$put_display (display_control, xref_header (97, 21), clc$trim, status);
          clp$put_display (display_control, xref_header (118, 29), clc$trim, status);
          clp$put_display (display_control, header_data_divider (1, 66), clc$trim, status);
        ELSE
          clp$put_display (display_control, xref_header (1, 31), clc$trim, status);
          clp$put_display (display_control, xref_header (33, 85), clc$trim, status);
          clp$put_display (display_control, xref_header (118, 29), clc$trim, status);
          clp$put_display (display_control, header_data_divider (1, 120), clc$trim, status);
        IFEND;
      IFEND;

      skeleton_entry_detail (4, 31) := link_map_data.entry_name;
      clp$convert_integer_to_rjstring (link_map_data.entry_address.segment, 16, FALSE, ' ',
            skeleton_entry_detail (41, 3), status);
      clp$convert_integer_to_rjstring (link_map_data.entry_address.offset, 16, FALSE, ' ',
            skeleton_entry_detail (45, 8), status);
      skeleton_entry_detail (59, 5) := link_map_data.entry_attribute;
      skeleton_entry_detail (70, 31) := link_map_data.defining_module;

      IF (display_control.line_number + lines_per_detail_text^ [loc$lm_xref_detail]) >
            display_control.page_length THEN
        clp$new_display_page (display_control, status);
      IFEND;
      IF narrow_format THEN
        clp$put_display (display_control, skeleton_entry_detail (1, 63), clc$trim, status);
        clp$put_display (display_control, skeleton_entry_detail (65, 37), clc$trim, status);
      ELSE
        clp$put_display (display_control, skeleton_entry_detail, clc$trim, status);
      IFEND;
?? EJECT ??

    = loc$lm_segment_detail =
      IF NOT segment_header_listed THEN
        segment_header_listed := TRUE;
        clp$new_display_page (display_control, status);
        clp$new_display_line (display_control, 2, status);
        clp$put_display (display_control, segment_detail_header (1, 21), clc$trim, status);
        clp$put_display (display_control, segment_detail_header (23, 11), clc$trim, status);
        clp$put_display (display_control, segment_detail_header (74, 64), clc$trim, status);
        clp$put_display (display_control, header_data_divider (1, 71), clc$trim, status);
      IFEND;

      clp$new_display_line (display_control, 1, status);
      clp$convert_integer_to_rjstring (link_map_data.segment, 16, FALSE, ' ', skeleton_segment_detail (4, 3),
            status);
      clp$convert_integer_to_rjstring (link_map_data.segment_length, 16, FALSE, ' ',
            skeleton_segment_detail (13, 8), status);
      clp$convert_integer_to_rjstring (link_map_data.segment_length, 10, FALSE, ' ',
            skeleton_segment_detail (23, 10), status);
      clp$convert_integer_to_rjstring (link_map_data.r1, 16, FALSE, ' ', skeleton_segment_detail (37, 2),
            status);
      clp$convert_integer_to_rjstring (link_map_data.r2, 16, FALSE, ' ', skeleton_segment_detail (40, 2),
            status);
      clp$convert_integer_to_rjstring (link_map_data.segment_global_key_lock, 16, FALSE, ' ',
            skeleton_segment_detail (49, 2), status);
      clp$convert_integer_to_rjstring (link_map_data.segment_local_key_lock, 16, FALSE, ' ',
            skeleton_segment_detail (52, 2), status);
      window_position := 47;
      skeleton_segment_detail (window_position, 24) := '';
      IF link_map_data.stack_segment THEN
        skeleton_segment_detail (window_position, 16) := 'STACK READ WRITE';
      ELSE
        IF link_map_data.segment_access_attributes.execute_privilege <> osc$non_executable THEN
          skeleton_segment_detail (window_position, 7) := 'EXECUTE';
          window_position := window_position + 8;
        IFEND;
        CASE link_map_data.segment_access_attributes.read_privilege OF
        = osc$read_key_lock_controlled =
          skeleton_segment_detail (window_position, 7) := 'READ_KL';
          window_position := window_position + 8;
        = osc$read_uncontrolled =
          skeleton_segment_detail (window_position, 4) := 'READ';
          window_position := window_position + 5;
        = osc$binding_segment =
          skeleton_segment_detail (window_position, 7) := 'BINDING';
          window_position := window_position + 8;
        ELSE
        CASEND;
        CASE link_map_data.segment_access_attributes.write_privilege OF
        = osc$write_key_lock_controlled =
          skeleton_segment_detail (window_position, 8) := 'WRITE_KL';
        = osc$write_uncontrolled =
          skeleton_segment_detail (window_position, 5) := 'WRITE';
        ELSE
        CASEND;
      IFEND;

      clp$put_display (display_control, skeleton_segment_detail, clc$trim, status);
?? EJECT ??

    = loc$lm_transfer_detail =
      IF (display_control.line_number + lines_per_detail_text^ [loc$lm_transfer_detail]) >
            display_control.page_length THEN
        clp$new_display_page (display_control, status);
      IFEND;

      clp$convert_integer_to_rjstring (link_map_data.transfer_address.ring, 16, FALSE, ' ',
            skeleton_transfer_detail (69, 1), status);
      clp$convert_integer_to_rjstring (link_map_data.transfer_address.segment, 16, FALSE, ' ',
            skeleton_transfer_detail (71, 3), status);
      clp$convert_integer_to_rjstring (link_map_data.transfer_address.offset, 16, FALSE, ' ',
            skeleton_transfer_detail (75, 8), status);
      skeleton_transfer_detail (19, 31) := link_map_data.transfer_symbol;

      clp$new_display_line (display_control, 2, status);
      clp$put_display (display_control, skeleton_transfer_detail (1, 49), clc$trim, status);
      clp$put_display (display_control, skeleton_transfer_detail (51, 33), clc$trim, status);


    = loc$lm_accumulate_names =
      name_length := 31;
      WHILE link_map_data.name (name_length) = ' ' DO
        name_length := name_length - 1;
      WHILEND;
      IF accumulation_line_position + name_length > display_control.page_width THEN
        IF (display_control.line_number + lines_per_detail_text^ [loc$lm_accumulate_names]) >
              display_control.page_length THEN
          clp$new_display_page (display_control, status);
        IFEND;
        clp$put_display (display_control, skeleton_accumulate_names (1, accumulation_line_position - 2),
              clc$trim, status);
        accumulation_line_position := start_of_accumulation_line;
      IFEND;

      skeleton_accumulate_names (accumulation_line_position, name_length + 2) :=
            link_map_data.name (1, name_length);
      accumulation_line_position := accumulation_line_position + name_length + 2;

    = loc$lm_flush_accumulated_names =
      IF (display_control.line_number + lines_per_detail_text^ [loc$lm_flush_accumulated_names]) >
            display_control.page_length THEN
        clp$new_display_page (display_control, status);
      IFEND;
      clp$put_display (display_control, skeleton_accumulate_names (1, accumulation_line_position - 2),
            clc$trim, status);
      accumulation_line_position := start_of_accumulation_line;
?? EJECT ??

    = loc$lm_asis_text =
      skeleton_asis_text := link_map_data.text;
      clp$put_display (display_control, skeleton_asis_text, clc$no_trim, status);

    = loc$lm_issue_diagnostic =
      message := ^message_content;
      osp$format_message (link_map_data.diagnostic_status, osc$full_message_level, display_control.page_width,
            message_content, status);
      RESET message;
      NEXT diagnostic_line_count IN message;
      IF (display_control.line_number + diagnostic_line_count^) > display_control.page_length THEN
        clp$new_display_page (display_control, status);
      IFEND;
      FOR diagnostic_line_index := 1 TO diagnostic_line_count^ DO
        NEXT diagnostic_line_size IN message;
        NEXT diagnostic_line: [diagnostic_line_size^] IN message;
        clp$put_display (display_control, diagnostic_line^ (1, diagnostic_line_size^), clc$trim, status);
      FOREND;
?? EJECT ??

    = loc$lm_diagnostic_summary =
      diagnostic_header_generated := FALSE;
      FOR severity := LOWERVALUE (ost$status_severity) TO UPPERVALUE (ost$status_severity) DO
        IF link_map_data.diagnostic_count [severity] <> 0 THEN
          IF NOT diagnostic_header_generated THEN
            diagnostic_header_generated := TRUE;
            IF (display_control.line_number + lines_per_detail_text^ [loc$lm_diagnostic_summary]) >
                  display_control.page_length THEN
              clp$new_display_page (display_control, status);
            IFEND;
            clp$new_display_line (display_control, 2, status);
            clp$put_display (display_control, diagnostic_summary_header, clc$trim, status);
          IFEND;
          STRINGREP (converted_number, conversion_length, link_map_data.diagnostic_count [severity]);
          diagnostic_summary_detail := ' ****';
          diagnostic_summary_detail (12 - conversion_length, conversion_length) :=
                converted_number (1, conversion_length);
          CASE severity OF
          = osc$informative_status =
            diagnostic_summary_detail (13, 13) := 'INFORMATIONAL';
            last_character := 25;
          = osc$warning_status =
            diagnostic_summary_detail (13, 7) := 'WARNING';
            last_character := 19;
          = osc$error_status =
            diagnostic_summary_detail (13, 5) := 'ERROR';
            last_character := 17;
          = osc$fatal_status =
            diagnostic_summary_detail (13, 5) := 'FATAL';
            last_character := 17;
          = osc$catastrophic_status =
            diagnostic_summary_detail (13, 12) := 'CATASTROPHIC';
            last_character := 24;
          CASEND;
          IF link_map_data.diagnostic_count [severity] = 1 THEN
            diagnostic_summary_detail (last_character + 1, 11) := ' diagnostic';
            last_character := last_character + 11;
          ELSE
            diagnostic_summary_detail (last_character + 1, 12) := ' diagnostics';
            last_character := last_character + 12;
          IFEND;
          clp$put_display (display_control, diagnostic_summary_detail (1, last_character), clc$trim, status);
        IFEND;
      FOREND;

    = loc$lm_page_header =
      IF (NOT continuous_form) AND (display_control.line_number <= 3) THEN
        clp$new_display_page (display_control, status);
      IFEND;


    ELSE
    CASEND;
  PROCEND ocp$generate_link_map_text;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$CLOSE_LINK_MAP', EJECT ??

  PROCEDURE [XDCL] ocp$close_link_map
    (VAR status: ost$status);


    clp$close_display (display_control, status);


  PROCEND ocp$close_link_map;
?? OLDTITLE ??
MODEND ocm$link_map_generator;
*DECK DECK=OCM$LIST_OBJECT_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Utilities: Display Object Text' ??
MODULE ocm$list_object_file;

{
{ PURPOSE:
{   This module contains the processor for the DISPLAY_OBJECT_TEXT command
{   (once called LIST_OBJECT_FILE).
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$scl_procedure
*copyc cyd$debug_symbol_table
*copyc llt$deferred_common_blocks
*copyc llt$deferred_entry_points
*copyc llt$function_dictionary
*copyc llt$help_module_dictionary
*copyc llt$load_module
*copyc llt$message_module_dictionary
*copyc llt$object_library
*copyc llt$object_module
*copyc llt$panel_dictionary
*copyc oce$library_generator_errors
*copyc oct$display_toggles
?? POP ??
*copyc amp$get_segment_pointer
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$get_message_module_info
*copyc fsp$get_open_information
*copyc fsp$open_file
*copyc i#build_adaptable_array_ptr
*copyc i#current_sequence_position
*copyc ocp$close_output_file
*copyc ocp$convert_information_element
*copyc ocp$initialize_oc_environment
*copyc ocp$open_output_file
*copyc ocp$output
*copyc ocp$output_boolean
*copyc ocp$output_date
*copyc ocp$output_module_generator
*copyc ocp$output_module_kind
*copyc ocp$output_section_kind
*copyc ocp$output_time
*copyc osp$set_status_abnormal
*copyc pmp$get_last_path_name
*copyc pmp$position_object_library
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    c$allotted = TRUE,
    premature_end_of_file = 'PREMATURE END-OF-FILE ENCOUNTERED';

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$list_object_file', EJECT ??

  PROCEDURE [XDCL, #GATE] ocp$list_object_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? NEWTITLE := 'process_cybil_symbol_table', EJECT ??

    PROCEDURE process_cybil_symbol_table
      (    sequence_length: ost$segment_length;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        debug_table_fragment: ^llt$debug_table_fragment,
        text: ^SEQ ( * ),
        number_of_items: integer,
        debug_symbol_table: ^cyt$debug_symbol_table,
        item: ^array [0 .. * ] of cyt$debug_symbol_table_item,
        i: integer;


      NEXT debug_table_fragment: [[REP sequence_length OF cell]] IN file;
      IF debug_table_fragment = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      hexrep (strng, length, debug_table_fragment^.offset);
      ocp$output ('      ', 'offset:', 7, occ$continue);
      ocp$output (' ', strng, length, occ$end_of_line);

      IF module_info.version >= 'V1.3' THEN
        number_of_items := sequence_length DIV #SIZE (cyt$debug_symbol_table_item);

        text := ^debug_table_fragment^.text;
        RESET text;

        IF (sequence_length MOD #SIZE (cyt$debug_symbol_table_item)) <> 0 THEN
          NEXT debug_symbol_table: [0 .. number_of_items - 1] IN text;
          IF debug_symbol_table = NIL THEN
            error (' ', 'INTERNAL PROBLEM 7', 18, occ$end_of_line);
            fatal_error := TRUE;
            RETURN;
          IFEND;

          ocp$output ('      ', 'original name:', 14, occ$continue);
          ocp$output (' ', debug_symbol_table^.original_name, #SIZE (debug_symbol_table^.original_name),
                occ$end_of_line);

          ocp$output ('      ', 'language:', 9, occ$continue);
          output_language (^debug_symbol_table^.language, occ$continue);

          STRINGREP (strng, length, debug_symbol_table^.optimization_level);
          ocp$output ('  ', 'optimization level:', 19, occ$continue);
          ocp$output (' ', strng, length, occ$end_of_line);

          ocp$output ('      ', 'version:', 8, occ$continue);
          ocp$output (' ', debug_symbol_table^.version, #SIZE (debug_symbol_table^.version), occ$continue);

          STRINGREP (strng, length, debug_symbol_table^.module_symbol_list);
          ocp$output ('  module symbol list:', strng, length, occ$continue);

          STRINGREP (strng, length, debug_symbol_table^.number_of_symbols);
          ocp$output ('  number of symbols:', strng, length, occ$end_of_line);

          item := ^debug_symbol_table^.item;

        ELSE
          NEXT item: [0 .. number_of_items - 1] IN text;
          IF item = NIL THEN
            error (' ', 'INTERNAL PROBLEM 8', 18, occ$end_of_line);
            fatal_error := TRUE;
            RETURN;
          IFEND;
        IFEND;

        FOR i := 0 TO (number_of_items - 1) DO
          ocp$output ('0     ', 'symbol name:', 12, occ$continue);
          ocp$output (' ', item^ [i].symbol_name, #SIZE (item^ [i].symbol_name), occ$continue);

          STRINGREP (strng, length, item^ [i].symtab_no);
          ocp$output ('  symtab no:', strng, length, occ$end_of_line);

          ocp$output ('      ', 'end of chain:', 13, occ$continue);
          ocp$output_boolean (item^ [i].end_of_chain, occ$continue);

          ocp$output ('  ', 'symbol type:', 12, occ$continue);

          CASE item^ [i].symbol_type OF
          = int_kind =
            ocp$output (' ', 'INT KIND', 8, occ$end_of_line);

          = bool_kind =
            ocp$output (' ', 'BOOL KIND', 9, occ$end_of_line);

          = char_kind =
            ocp$output (' ', 'CHAR KIND', 9, occ$end_of_line);

          = real_kind =
            ocp$output (' ', 'REAL KIND', 9, occ$end_of_line);

          = longreal_kind =
            ocp$output (' ', 'LONGREAL KIND', 13, occ$end_of_line);

          = cell_kind =
            ocp$output (' ', 'CELL KIND', 9, occ$end_of_line);

          = var_kind =
            ocp$output (' ', 'VAR KIND', 8, occ$end_of_line);

            STRINGREP (strng, length, item^ [i].var_type);
            ocp$output ('      var type:', strng, length, occ$continue);

            hexrep (strng, length, item^ [i].var_length);
            ocp$output ('  var length: ', strng, length, occ$continue);

            ocp$output ('  ', 'base: ', 6, occ$continue);
            CASE item^ [i].base OF
            = null_base =
              ocp$output (' ', 'NULL BASE', 9, occ$end_of_line);
            = static_base =
              ocp$output (' ', 'STATIC BASE', 11, occ$end_of_line);
            = constant_base =
              ocp$output (' ', 'CONSTANT BASE', 13, occ$end_of_line);
            = stack_frame_base =
              ocp$output (' ', 'STACK FRAME BASE', 16, occ$end_of_line);
            = parm_list_base =
              ocp$output (' ', 'PARM LIST BASE', 14, occ$end_of_line);
            = xref_base =
              ocp$output (' ', 'XREF BASE', 9, occ$end_of_line);
            = register_base =
              ocp$output (' ', 'REGISTER BASE', 13, occ$end_of_line);
            ELSE
              ocp$output (' ', '*************', 13, occ$end_of_line);
              error (' ', 'INVALID BASE', 12, occ$end_of_line);
            CASEND;

            hexrep (strng, length, item^ [i].var_section_ordinal);
            ocp$output ('      var section ordinal: ', strng, length, occ$continue);

            hexrep (strng, length, item^ [i].var_offset);
            ocp$output ('  var section offset: ', strng, length, occ$end_of_line);

            ocp$output ('      ', 'indirectly referenced:', 22, occ$continue);
            ocp$output_boolean (item^ [i].indirectly_referenced, occ$continue);

            ocp$output ('  ', 'var is parameter:', 17, occ$continue);
            ocp$output_boolean (item^ [i].var_is_parameter, occ$end_of_line);

          = cons_kind =
            ocp$output (' ', 'CONS KIND', 9, occ$end_of_line);

            STRINGREP (strng, length, item^ [i].cons_type);
            ocp$output ('      cons type:', strng, length, occ$continue);

            ocp$output ('  ', 'cons length type:', 17, occ$continue);
            CASE item^ [i].cons_length_type OF
            = short_constant_type =
              ocp$output (' ', 'SHORT CONSTANT TYPE', 19, occ$continue);
            = long_constant_type =
              ocp$output (' ', 'LONG CONSTANT TYPE', 18, occ$continue);
            ELSE
              ocp$output (' ', '******************', 18, occ$end_of_line);
              error (' ', 'INVALID CONSTANT TYPE', 21, occ$end_of_line);
            CASEND;

            STRINGREP (strng, length, item^ [i].cons_value);
            ocp$output ('  cons value:', strng, length, occ$end_of_line);

          = label_kind =
            ocp$output (' ', 'LABEL KIND', 10, occ$end_of_line);

            STRINGREP (strng, length, item^ [i].line_no);
            ocp$output ('      line no:', strng, length, occ$end_of_line);


          = ordinal_kind =
            ocp$output (' ', 'ORDINAL KIND', 12, occ$end_of_line);

            STRINGREP (strng, length, item^ [i].last_const);
            ocp$output ('      last const:', strng, length, occ$continue);

            STRINGREP (strng, length, item^ [i].upper_bound);
            ocp$output ('  upper bound:', strng, length, occ$end_of_line);

          = subrange_kind =
            ocp$output (' ', 'SUBRANGE KIND', 13, occ$end_of_line);

            STRINGREP (strng, length, item^ [i].subtype);
            ocp$output ('      subtype:', strng, length, occ$continue);

            ocp$output ('  ', 'low value type:', 15, occ$continue);
            CASE item^ [i].low_value_type OF
            = short_len =
              ocp$output (' ', 'SHORT LEN', 9, occ$continue);
            = long_len =
              ocp$output (' ', 'LONG LEN', 8, occ$continue);
            = not_fixed_spare_len =
              ocp$output (' ', 'NOT FIXED SPARE LEN', 19, occ$continue);
            = adapt_len =
              ocp$output (' ', 'ADAPT LEN', 9, occ$continue);
            ELSE
              ocp$output (' ', '*********', 9, occ$end_of_line);
              error (' ', 'INVALID LEN KIND', 16, occ$end_of_line);
            CASEND;

            ocp$output ('  ', 'high value type:', 16, occ$continue);
            CASE item^ [i].high_value_type OF
            = short_len =
              ocp$output (' ', 'SHORT LEN', 9, occ$end_of_line);
            = long_len =
              ocp$output (' ', 'LONG LEN', 8, occ$end_of_line);
            = not_fixed_spare_len =
              ocp$output (' ', 'NOT FIXED SPARE LEN', 19, occ$end_of_line);
            = adapt_len =
              ocp$output (' ', 'ADAPT LEN', 9, occ$end_of_line);
            ELSE
              ocp$output (' ', '*********', 9, occ$end_of_line);
              error (' ', 'INVALID LEN KIND', 16, occ$end_of_line);
            CASEND;

            STRINGREP (strng, length, item^ [i].low_value);
            ocp$output ('      low value:', strng, length, occ$continue);

            STRINGREP (strng, length, item^ [i].high_value);
            ocp$output ('  high value:', strng, length, occ$end_of_line);

          = proc_kind =
            ocp$output (' ', 'PROC KIND', 9, occ$end_of_line);

            STRINGREP (strng, length, item^ [i].lexical_level);
            ocp$output ('      lexical level:', strng, length, occ$continue);

            STRINGREP (strng, length, item^ [i].symbol_list);
            ocp$output ('  symbol list: ', strng, length, occ$end_of_line);

            hexrep (strng, length, item^ [i].proc_section_ordinal);
            ocp$output ('      proc section ordinal: ', strng, length, occ$continue);

            hexrep (strng, length, item^ [i].proc_offset);
            ocp$output ('  proc offset: ', strng, length, occ$continue);

            hexrep (strng, length, item^ [i].proc_length);
            ocp$output ('  proc length: ', strng, length, occ$end_of_line);

            STRINGREP (strng, length, item^ [i].parent_proc);
            ocp$output ('      parent proc:', strng, length, occ$continue);

            STRINGREP (strng, length, item^ [i].return_type);
            ocp$output ('  return type: ', strng, length, occ$end_of_line);

          = pointer_kind =
            ocp$output (' ', 'POINTER KIND', 12, occ$end_of_line);

            STRINGREP (strng, length, item^ [i].ptr_type);
            ocp$output ('      ptr type', strng, length, occ$continue);

            hexrep (strng, length, item^ [i].ptr_object_length);
            ocp$output ('  ptr object length: ', strng, length, occ$end_of_line);

          = set_kind =
            ocp$output (' ', 'SET KIND', 8, occ$end_of_line);

            STRINGREP (strng, length, item^ [i].set_element_type);
            ocp$output ('      set element type:', strng, length, occ$continue);

            STRINGREP (strng, length, item^ [i].set_len);
            ocp$output ('  set len:', strng, length, occ$end_of_line);

          = string_kind =
            ocp$output (' ', 'STRING KIND', 11, occ$end_of_line);

            ocp$output ('      ', 'len type:', 9, occ$continue);
            CASE item^ [i].len_type OF
            = short_len =
              ocp$output (' ', 'SHORT LEN', 9, occ$continue);
            = long_len =
              ocp$output (' ', 'LONG LEN', 8, occ$continue);
            = not_fixed_spare_len =
              ocp$output (' ', 'NOT FIXED SPARE LEN', 19, occ$continue);
            = adapt_len =
              ocp$output (' ', 'ADAPT LEN', 9, occ$continue);
            ELSE
              ocp$output (' ', '*********', 9, occ$end_of_line);
              error (' ', 'INVALID LEN TYPE', 16, occ$end_of_line);
            CASEND;

            STRINGREP (strng, length, item^ [i].string_len);
            ocp$output ('  string len:', strng, length, occ$end_of_line);

          = array_kind =
            ocp$output (' ', 'ARRAY KIND', 10, occ$end_of_line);

            ocp$output ('      ', 'array binding: [', 16, occ$continue);
            IF fixed_bind IN item^ [i].array_binding THEN
              ocp$output (' ', 'FIXED BIND', 10, occ$continue);
            IFEND;
            IF variable_spare_bind IN item^ [i].array_binding THEN
              ocp$output (' ', 'VARIABLE SPARE BIND', 19, occ$continue);
            IFEND;
            IF adaptable_bind IN item^ [i].array_binding THEN
              ocp$output (' ', 'ADAPTABLE BIND', 14, occ$continue);
            IFEND;
            IF variant_bind IN item^ [i].array_binding THEN
              ocp$output (' ', 'VARIANT BIND', 12, occ$continue);
            IFEND;
            ocp$output (' ', ']', 1, occ$end_of_line);

            ocp$output ('      ', 'array packing:', 14, occ$continue);
            CASE item^ [i].array_packing OF
            = packd =
              ocp$output (' ', 'PACKD', 5, occ$continue);
            = unpackd =
              ocp$output (' ', 'UNPACKD', 7, occ$continue);
            = not_packd =
              ocp$output (' ', 'NOT PACKD', 9, occ$continue);
            ELSE
              ocp$output (' ', '*********', 9, occ$end_of_line);
              error (' ', 'INVALID ARRAY PACKING', 21, occ$end_of_line);
            CASEND;

            ocp$output ('  ', 'length is bits:', 15, occ$continue);
            ocp$output_boolean (item^ [i].length_is_bits, occ$end_of_line);

            STRINGREP (strng, length, item^ [i].index_type);
            ocp$output ('      index type:', strng, length, occ$continue);

            STRINGREP (strng, length, item^ [i].array_element_type);
            ocp$output ('  array element type:', strng, length, occ$continue);

            STRINGREP (strng, length, item^ [i].element_length);
            ocp$output ('  element length:', strng, length, occ$end_of_line);

          = record_kind =
            ocp$output (' ', 'RECORD KIND', 11, occ$end_of_line);

            ocp$output ('      ', 'record binding: [', 17, occ$continue);
            IF fixed_bind IN item^ [i].record_binding THEN
              ocp$output (' ', 'FIXED BIND', 10, occ$continue);
            IFEND;
            IF variable_spare_bind IN item^ [i].record_binding THEN
              ocp$output (' ', 'VARIABLE SPARE BIND', 19, occ$continue);
            IFEND;
            IF adaptable_bind IN item^ [i].record_binding THEN
              ocp$output (' ', 'ADAPTABLE BIND', 14, occ$continue);
            IFEND;
            IF variant_bind IN item^ [i].record_binding THEN
              ocp$output (' ', 'VARIANT BIND', 12, occ$continue);
            IFEND;
            ocp$output (' ', ']', 1, occ$end_of_line);

            ocp$output ('      ', 'record packing:', 14, occ$continue);
            CASE item^ [i].record_packing OF
            = packd =
              ocp$output (' ', 'PACKD', 5, occ$continue);
            = unpackd =
              ocp$output (' ', 'UNPACKD', 7, occ$continue);
            = not_packd =
              ocp$output (' ', 'NOT PACKD', 9, occ$continue);
            ELSE
              ocp$output (' ', '*********', 9, occ$end_of_line);
              error (' ', 'INVALID ARRAY PACKING', 21, occ$end_of_line);
            CASEND;

            ocp$output ('  ', 'variation flag:', 15, occ$continue);
            ocp$output_boolean (item^ [i].variation_flag, occ$end_of_line);

            STRINGREP (strng, length, item^ [i].first_field);
            ocp$output ('      first field:', strng, length, occ$continue);

            STRINGREP (strng, length, item^ [i].record_length);
            ocp$output ('  record length:', strng, length, occ$continue);

            STRINGREP (strng, length, item^ [i].selector);
            ocp$output ('  selector:', strng, length, occ$end_of_line);

          = field_kind =
            ocp$output (' ', 'FIELD KIND', 10, occ$end_of_line);

            STRINGREP (strng, length, item^ [i].field_offset);
            ocp$output ('      field offset:', strng, length, occ$continue);

            STRINGREP (strng, length, item^ [i].field_length);
            ocp$output ('  field length:', strng, length, occ$continue);

            ocp$output ('  ', 'unit addressed:', 15, occ$continue);
            IF item^ [i].unit_addressed THEN
              ocp$output (' ', 'BYTES', 5, occ$end_of_line);
            ELSE
              ocp$output (' ', 'BITS', 4, occ$end_of_line);
            IFEND;

            STRINGREP (strng, length, item^ [i].field_type);
            ocp$output ('      field type:', strng, length, occ$continue);

            STRINGREP (strng, length, item^ [i].next_field);
            ocp$output ('  next field:', strng, length, occ$end_of_line);

          = selector_kind =
            ocp$output (' ', 'SELECTOR KIND', 13, occ$end_of_line);

            STRINGREP (strng, length, item^ [i].variation);
            ocp$output ('      variation:', strng, length, occ$continue);

            STRINGREP (strng, length, item^ [i].next_selector);
            ocp$output ('  next selector:', strng, length, occ$end_of_line);

            STRINGREP (strng, length, item^ [i].low_selector);
            ocp$output ('      low selector:', strng, length, occ$continue);

            STRINGREP (strng, length, item^ [i].high_selector);
            ocp$output ('  high selector:', strng, length, occ$end_of_line);

          = heap_kind =
            ocp$output (' ', 'HEAP KIND', 9, occ$end_of_line);

          = seq_kind =
            ocp$output (' ', 'SEQ KIND', 8, occ$end_of_line);

          = bound_vrec_kind =
            ocp$output (' ', 'BOUND VREC KIND', 15, occ$end_of_line);

            STRINGREP (strng, length, item^ [i].bound_type);
            ocp$output ('      bound type:', strng, length, occ$end_of_line);

          = rel_ptr_kind =
            ocp$output (' ', 'REL PTR KIND', 12, occ$end_of_line);

            STRINGREP (strng, length, item^ [i].parent_type);
            ocp$output ('      parent_type:', strng, length, occ$continue);

            STRINGREP (strng, length, item^ [i].object_type);
            ocp$output ('  object type:', strng, length, occ$continue);

            STRINGREP (strng, length, item^ [i].rel_ptr_object_length);
            ocp$output ('  rel ptr object length:', strng, length, occ$end_of_line);

          = error_kind =
            ocp$output (' ', 'ERROR KIND', 10, occ$end_of_line);

          = vstring_spare_kind =
            ocp$output (' ', 'VSTRING SPARE KIND', 18, occ$end_of_line);

          = union_spare_kind =
            ocp$output (' ', 'UNION SPARE KIND', 16, occ$end_of_line);

          = lbl_typ_spare_kind =
            ocp$output (' ', 'LBL TYP SPARE KIND', 18, occ$end_of_line);

          = nil_kind =
            ocp$output (' ', 'NIL KIND', 8, occ$end_of_line);

          = parameter_kind =
            ocp$output (' ', 'PARAMETER KIND', 14, occ$end_of_line);

          = proc_decl_kind =
            ocp$output (' ', 'PROC DECL KIND', 14, occ$end_of_line);

          = file_kind =
            ocp$output (' ', 'FILE KIND', 9, occ$end_of_line);

          = union_spare_element_kind =
            ocp$output (' ', 'UNION SPARE ELEMENT KIND', 24, occ$end_of_line);

          = span_elem_kind =
            ocp$output (' ', 'SPAN ELEM KIND', 14, occ$end_of_line);

          = module_kind =
            ocp$output (' ', 'MODULE KIND', 11, occ$end_of_line);

          = prong_kind =
            ocp$output (' ', 'PRONG KIND', 10, occ$end_of_line);

          = synonym_kind =
            ocp$output (' ', 'SYNONYM KIND', 12, occ$end_of_line);

          = last_one =
            ocp$output (' ', 'LAST ONE', 8, occ$end_of_line);

          = section_kind =
            ocp$output (' ', 'SECTION KIND', 12, occ$end_of_line);

          ELSE
            ocp$output (' ', '************', 12, occ$end_of_line);
            error (' ', 'INVALID SYMBOL TYPE', 19, occ$end_of_line);

          CASEND;
        FOREND;
      IFEND;


    PROCEND process_cybil_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_OBSOLETE_LINE_TABLE', EJECT ??

    PROCEDURE process_obsolete_line_table
      (    number_of_line_items: llt$line_address_table_size;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        obsolete_line_address_table: ^llt$obsolete_line_address_table,
        i: llt$line_address_table_size;


      NEXT obsolete_line_address_table: [1 .. number_of_line_items] IN file;
      IF obsolete_line_address_table = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      ocp$output ('      ', 'original name:', 14, occ$continue);
      ocp$output (' ', obsolete_line_address_table^.original_name,
            STRLENGTH (obsolete_line_address_table^.original_name), occ$continue);

      ocp$output ('  ', 'optimized code:', 15, occ$continue);
      ocp$output_boolean (obsolete_line_address_table^.optimized_code, occ$end_of_line);

      ocp$output ('      ', 'language:', 9, occ$continue);
      output_language (^obsolete_line_address_table^.language, occ$continue);

      STRINGREP (strng, length, obsolete_line_address_table^.number_of_items);
      ocp$output ('  number of items:', strng, length, occ$end_of_line);

      FOR i := 1 TO number_of_line_items DO
        ocp$output ('0     ', 'line number:', 12, occ$continue);
        ocp$output (' ', obsolete_line_address_table^.item [i].
              line_number, STRLENGTH (obsolete_line_address_table^.item [i].line_number), occ$end_of_line);

        hexrep (strng, length, obsolete_line_address_table^.item [i].section_ordinal);
        ocp$output ('      ', 'section ordinal:', 16, occ$continue);
        ocp$output (' ', strng, length, occ$continue);

        hexrep (strng, length, obsolete_line_address_table^.item [i].offset);
        ocp$output ('  ', 'offset:', 7, occ$continue);
        ocp$output (' ', strng, length, occ$continue);

        hexrep (strng, length, obsolete_line_address_table^.item [i].extent);
        ocp$output ('  ', 'extent:', 7, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

        verify_address (obsolete_line_address_table^.item [i].section_ordinal,
              obsolete_line_address_table^.item [i].offset);

        ocp$output ('      ', 'statement labeled:', 18, occ$continue);
        ocp$output_boolean (obsolete_line_address_table^.item [i].statement_labeled, occ$continue);

        ocp$output ('  ', 'breakpoint permitted:', 21, occ$continue);
        ocp$output_boolean (obsolete_line_address_table^.item [i].breakpoint_permitted, occ$end_of_line);

        CASE obsolete_line_address_table^.language OF
        = llc$cybil, llc$obsolete_cybil =
          ocp$output ('      ', 'cybil line kind:', 16, occ$continue);
          CASE obsolete_line_address_table^.item [i].cybil_line_kind OF
          = cyc$cybil_procedure =
            ocp$output (' ', 'cybil procedure', 15, occ$end_of_line);
          = cyc$cybil_assignment =
            ocp$output (' ', 'cybil assignment', 16, occ$end_of_line);
          = cyc$cybil_begin =
            ocp$output (' ', 'cybil begin', 11, occ$end_of_line);
          = cyc$cybil_end =
            ocp$output (' ', 'cybil end', 9, occ$end_of_line);
          = cyc$cybil_while =
            ocp$output (' ', 'cybil while', 11, occ$end_of_line);
          = cyc$cybil_whilend =
            ocp$output (' ', 'cybil whilend', 13, occ$end_of_line);
          = cyc$cybil_repeat =
            ocp$output (' ', 'cybil repeat', 12, occ$end_of_line);
          = cyc$cybil_until =
            ocp$output (' ', 'cybil until', 11, occ$end_of_line);
          = cyc$cybil_for =
            ocp$output (' ', 'cybil for', 9, occ$end_of_line);
          = cyc$cybil_forend =
            ocp$output (' ', 'cybil forend', 12, occ$end_of_line);
          = cyc$cybil_procedure_call =
            ocp$output (' ', 'cybil procedure call', 20, occ$end_of_line);
          = cyc$cybil_if =
            ocp$output (' ', 'cybil if', 8, occ$end_of_line);
          = cyc$cybil_elseif =
            ocp$output (' ', 'cybil elseif', 12, occ$end_of_line);
          = cyc$cybil_else =
            ocp$output (' ', 'cybil else', 10, occ$end_of_line);
          = cyc$cybil_ifend =
            ocp$output (' ', 'cybil ifend', 11, occ$end_of_line);
          = cyc$cybil_case =
            ocp$output (' ', 'cybil case', 10, occ$end_of_line);
          = cyc$cybil_case_selector =
            ocp$output (' ', 'cybil case selector', 19, occ$end_of_line);
          = cyc$cybil_casend =
            ocp$output (' ', 'cybil casend', 12, occ$end_of_line);
          = cyc$cybil_cycle =
            ocp$output (' ', 'cybil cycle', 11, occ$end_of_line);
          = cyc$cybil_exit =
            ocp$output (' ', 'cybil exit', 10, occ$end_of_line);
          = cyc$cybil_return =
            ocp$output (' ', 'cybil return', 12, occ$end_of_line);
          = cyc$cybil_push =
            ocp$output (' ', 'cybil push', 10, occ$end_of_line);
          = cyc$cybil_next =
            ocp$output (' ', 'cybil next', 10, occ$end_of_line);
          = cyc$cybil_reset =
            ocp$output (' ', 'cybil reset', 11, occ$end_of_line);
          = cyc$cybil_allocate =
            ocp$output (' ', 'cybil allocate', 14, occ$end_of_line);
          = cyc$cybil_free =
            ocp$output (' ', 'cybil free', 10, occ$end_of_line);
          ELSE
            ocp$output (' ', '**********', 10, occ$end_of_line);
            error (' ', 'INVALID CYBIL LINE KIND', 23, occ$end_of_line);
          CASEND;
        ELSE
          ocp$output (' ', '**********', 10, occ$end_of_line);
          error (' ', 'INVALID LINE ADDRESS TABLE LANGUAGE KIND', 40, occ$end_of_line);
        CASEND;
      FOREND;


    PROCEND process_obsolete_line_table;
?? OLDTITLE ??
?? NEWTITLE := '  OUTPUT_OPTIMIZATION_LEVEL', EJECT ??

    PROCEDURE output_optimization_level
      (    optimization_level: llt$optimization_level;
           end_of_line: boolean);

      CASE optimization_level OF
      = llc$debug_optimization_level =
        ocp$output (' ', 'debug', 5, end_of_line);
      = llc$low_optimization_level =
        ocp$output (' ', 'low', 3, end_of_line);
      = llc$high_optimization_level =
        ocp$output (' ', 'high', 4, end_of_line);
      ELSE
        ocp$output (' ', 'INVALID OPTIMIZATION LEVEL', 26, end_of_line);
      CASEND;
    PROCEND output_optimization_level;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_LINE_TABLE' ??
?? EJECT ??

    PROCEDURE process_line_table
      (    number_of_line_items: llt$line_address_table_size;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        line_address_table: ^llt$line_address_table,
        i: llt$line_address_table_size;


      NEXT line_address_table: [1 .. number_of_line_items] IN file;
      IF line_address_table = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      ocp$output ('      ', 'original name:', 14, occ$continue);
      ocp$output (' ', line_address_table^.original_module_name,
            STRLENGTH (line_address_table^.original_module_name), occ$continue);

      ocp$output (' ', 'version:', 8, occ$continue);
      ocp$output (' ', line_address_table^.version, STRLENGTH (line_address_table^.version), occ$end_of_line);

      ocp$output ('      ', 'language:', 9, occ$continue);
      output_language (^line_address_table^.language, occ$continue);

      ocp$output ('  ', 'optimization level:', 19, occ$continue);
      output_optimization_level (line_address_table^.optimization_level, occ$continue);

      STRINGREP (strng, length, line_address_table^.number_of_items);
      ocp$output ('  number of items:', strng, length, occ$end_of_line);

      FOR i := 1 TO number_of_line_items DO
        ocp$output (' ', ' ', 1, occ$end_of_line);

        STRINGREP (strng, length, line_address_table^.item [i].line_number);
        ocp$output ('      line number', strng, length, occ$continue);

        hexrep (strng, length, line_address_table^.item [i].section_ordinal);
        ocp$output ('      ', 'section ordinal:', 16, occ$continue);
        ocp$output (' ', strng, length, occ$continue);

        hexrep (strng, length, line_address_table^.item [i].offset);
        ocp$output ('  ', 'offset:', 7, occ$continue);
        ocp$output (' ', strng, length, occ$continue);

        hexrep (strng, length, line_address_table^.item [i].extent);
        ocp$output ('  ', 'extent:', 7, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

        verify_address (line_address_table^.item [i].section_ordinal, line_address_table^.item [i].offset);

        ocp$output ('      ', 'line attributes: [', 18, occ$continue);
        IF llc$line_number_unique IN line_address_table^.item [i].line_attributes THEN
          ocp$output (' ', 'LINE_NUMBER_UNIQUE', 18, occ$continue);
        IFEND;

        IF llc$breakpoint_permitted IN line_address_table^.item [i].line_attributes THEN
          ocp$output (' ', 'BREAKPOINT_PERMITTED', 20, occ$continue);
        IFEND;

        IF llc$labelled_line IN line_address_table^.item [i].line_attributes THEN
          ocp$output (' ', 'LABELLED_LINE', 13, occ$continue);
        IFEND;

        IF llc$prolog_code IN line_address_table^.item [i].line_attributes THEN
          ocp$output (' ', 'PROLOG_CODE', 11, occ$continue);
        IFEND;

        IF llc$no_object_code_for_line IN line_address_table^.item [i].line_attributes THEN
          ocp$output (' ', 'NO_OBJECT_CODE_FOR_LINE', 23, occ$continue);
        IFEND;

        IF llc$line_attribute_spare6 IN line_address_table^.item [i].line_attributes THEN
          ocp$output (' ', 'SPARE6', 6, occ$continue);
        IFEND;

        IF llc$line_attribute_spare7 IN line_address_table^.item [i].line_attributes THEN
          ocp$output (' ', 'SPARE7', 6, occ$continue);
        IFEND;

        IF llc$line_attribute_spare8 IN line_address_table^.item [i].line_attributes THEN
          ocp$output (' ', 'SPARE8', 6, occ$continue);
        IFEND;

        ocp$output (' ', ']', 1, occ$end_of_line);

        CASE line_address_table^.language OF
        = llc$cobol =
          ocp$output ('      ', 'cobol statement kind:', 21, occ$continue);
          CASE line_address_table^.item [i].cobol_statement_kind OF
          = llc$cobol_unknown_stmt_kind =
            ocp$output (' ', 'unknown cobol statement', 23, occ$end_of_line);
          = llc$cobol_program =
            ocp$output (' ', 'cobol program', 13, occ$end_of_line);
          = llc$cobol_section =
            ocp$output (' ', 'cobol section', 13, occ$end_of_line);
          = llc$cobol_paragraph =
            ocp$output (' ', 'cobol paragraph', 15, occ$end_of_line);
          = llc$cobol_accept =
            ocp$output (' ', 'cobol accept', 12, occ$end_of_line);
          = llc$cobol_add =
            ocp$output (' ', 'cobol add', 9, occ$end_of_line);
          = llc$cobol_alter =
            ocp$output (' ', 'cobol alter', 11, occ$end_of_line);
          = llc$cobol_call =
            ocp$output (' ', 'cobol call', 10, occ$end_of_line);
          = llc$cobol_cancel =
            ocp$output (' ', 'cobol cancel', 12, occ$end_of_line);
          = llc$cobol_close =
            ocp$output (' ', 'cobol close', 11, occ$end_of_line);
          = llc$cobol_compute =
            ocp$output (' ', 'cobol compute', 13, occ$end_of_line);
          = llc$cobol_continue =
            ocp$output (' ', 'cobol continue', 14, occ$end_of_line);
          = llc$cobol_delete =
            ocp$output (' ', 'cobol delete', 12, occ$end_of_line);
          = llc$cobol_display =
            ocp$output (' ', 'cobol display', 13, occ$end_of_line);
          = llc$cobol_divide =
            ocp$output (' ', 'cobol divide', 12, occ$end_of_line);
          = llc$cobol_else =
            ocp$output (' ', 'cobol else', 10, occ$end_of_line);
          = llc$cobol_end_if =
            ocp$output (' ', 'cobol endif', 11, occ$end_of_line);
          = llc$cobol_end_perform =
            ocp$output (' ', 'cobol end perform', 17, occ$end_of_line);
          = llc$cobol_enter =
            ocp$output (' ', 'cobol enter', 11, occ$end_of_line);
          = llc$cobol_exit =
            ocp$output (' ', 'cobol exit', 10, occ$end_of_line);
          = llc$cobol_generate =
            ocp$output (' ', 'cobol generate', 14, occ$end_of_line);
          = llc$cobol_goto =
            ocp$output (' ', 'cobol goto', 10, occ$end_of_line);
          = llc$cobol_if =
            ocp$output (' ', 'cobol if', 8, occ$end_of_line);
          = llc$cobol_initialize =
            ocp$output (' ', 'cobol initialize', 16, occ$end_of_line);
          = llc$cobol_initiate =
            ocp$output (' ', 'cobol initiate', 14, occ$end_of_line);
          = llc$cobol_inspect =
            ocp$output (' ', 'cobol inspect', 13, occ$end_of_line);
          = llc$cobol_merge =
            ocp$output (' ', 'cobol merge', 11, occ$end_of_line);
          = llc$cobol_move =
            ocp$output (' ', 'cobol move', 10, occ$end_of_line);
          = llc$cobol_multiply =
            ocp$output (' ', 'cobol multiply', 14, occ$end_of_line);
          = llc$cobol_open =
            ocp$output (' ', 'cobol open', 10, occ$end_of_line);
          = llc$cobol_perform =
            ocp$output (' ', 'cobol perform', 13, occ$end_of_line);
          = llc$cobol_purge =
            ocp$output (' ', 'cobol purge', 11, occ$end_of_line);
          = llc$cobol_read =
            ocp$output (' ', 'cobol read', 10, occ$end_of_line);
          = llc$cobol_receive =
            ocp$output (' ', 'cobol receive', 13, occ$end_of_line);
          = llc$cobol_release =
            ocp$output (' ', 'cobol release', 13, occ$end_of_line);
          = llc$cobol_return =
            ocp$output (' ', 'cobol return', 12, occ$end_of_line);
          = llc$cobol_rewrite =
            ocp$output (' ', 'cobol rewrite', 13, occ$end_of_line);
          = llc$cobol_search =
            ocp$output (' ', 'cobol search', 12, occ$end_of_line);
          = llc$cobol_send =
            ocp$output (' ', 'cobol send', 10, occ$end_of_line);
          = llc$cobol_set =
            ocp$output (' ', 'cobol set', 9, occ$end_of_line);
          = llc$cobol_sort =
            ocp$output (' ', 'cobol sort', 10, occ$end_of_line);
          = llc$cobol_start =
            ocp$output (' ', 'cobol start', 11, occ$end_of_line);
          = llc$cobol_stop =
            ocp$output (' ', 'cobol stop', 10, occ$end_of_line);
          = llc$cobol_string =
            ocp$output (' ', 'cobol string', 12, occ$end_of_line);
          = llc$cobol_subtract =
            ocp$output (' ', 'cobol subtract', 14, occ$end_of_line);
          = llc$cobol_suppress =
            ocp$output (' ', 'cobol suppress', 14, occ$end_of_line);
          = llc$cobol_terminate =
            ocp$output (' ', 'cobol terminate', 15, occ$end_of_line);
          = llc$cobol_unstring =
            ocp$output (' ', 'cobol unstring', 14, occ$end_of_line);
          = llc$cobol_write =
            ocp$output (' ', 'cobol write', 11, occ$end_of_line);
          ELSE
            ocp$output (' ', '**********', 10, occ$end_of_line);
            error (' ', 'INVALID COBOL LINE KIND', 23, occ$end_of_line);

          CASEND;

        = llc$fortran =
          ocp$output ('      ', 'fortran statement kind:', 23, occ$continue);
          CASE line_address_table^.item [i].fortran_statement_kind OF
          = llc$fortran_unknown_stmt_kind =
            ocp$output (' ', 'unknown fortran statement', 25, occ$end_of_line);
          = llc$fortran_program =
            ocp$output (' ', 'fortran program', 15, occ$end_of_line);
          = llc$fortran_subroutine =
            ocp$output (' ', 'fortran subroutine', 18, occ$end_of_line);
          = llc$fortran_function =
            ocp$output (' ', 'fortran function', 16, occ$end_of_line);
          = llc$fortran_arithmetic_if =
            ocp$output (' ', 'fortran arithmatic if', 21, occ$end_of_line);
          = llc$fortran_assign =
            ocp$output (' ', 'fortran assign', 14, occ$end_of_line);
          = llc$fortran_assigned_goto =
            ocp$output (' ', 'fortran assigned goto', 21, occ$end_of_line);
          = llc$fortran_assignment =
            ocp$output (' ', 'fortran assignment', 18, occ$end_of_line);
          = llc$fortran_backspace =
            ocp$output (' ', 'fortran backspace', 17, occ$end_of_line);
          = llc$fortran_block_if =
            ocp$output (' ', 'fortran block if', 16, occ$end_of_line);
          = llc$fortran_buffer_in =
            ocp$output (' ', 'fortran buffer in', 17, occ$end_of_line);
          = llc$fortran_buffer_out =
            ocp$output (' ', 'fortran buffer out', 18, occ$end_of_line);
          = llc$fortran_call =
            ocp$output (' ', 'fortran call', 12, occ$end_of_line);
          = llc$fortran_close =
            ocp$output (' ', 'fortran close', 13, occ$end_of_line);
          = llc$fortran_computed_goto =
            ocp$output (' ', 'fortran computed goto', 21, occ$end_of_line);
          = llc$fortran_continue =
            ocp$output (' ', 'fortran continue', 16, occ$end_of_line);
          = llc$fortran_decode =
            ocp$output (' ', 'fortran decode', 14, occ$end_of_line);
          = llc$fortran_do =
            ocp$output (' ', 'fortran do', 10, occ$end_of_line);
          = llc$fortran_else =
            ocp$output (' ', 'fortran else', 12, occ$end_of_line);
          = llc$fortran_elseif =
            ocp$output (' ', 'fortran elseif', 14, occ$end_of_line);
          = llc$fortran_encode =
            ocp$output (' ', 'fortran encode', 14, occ$end_of_line);
          = llc$fortran_end =
            ocp$output (' ', 'fortran end', 11, occ$end_of_line);
          = llc$fortran_endfile =
            ocp$output (' ', 'fortran endfile', 15, occ$end_of_line);
          = llc$fortran_endif =
            ocp$output (' ', 'fortran endif', 13, occ$end_of_line);
          = llc$fortran_entry =
            ocp$output (' ', 'fortran entry', 13, occ$end_of_line);
          = llc$fortran_inquire =
            ocp$output (' ', 'fortran inquire', 15, occ$end_of_line);
          = llc$fortran_logical_if =
            ocp$output (' ', 'fortran logical if', 18, occ$end_of_line);
          = llc$fortran_open =
            ocp$output (' ', 'fortran open', 12, occ$end_of_line);
          = llc$fortran_pause =
            ocp$output (' ', 'fortran pause', 13, occ$end_of_line);
          = llc$fortran_print =
            ocp$output (' ', 'fortran print', 13, occ$end_of_line);
          = llc$fortran_punch =
            ocp$output (' ', 'fortran punch', 13, occ$end_of_line);
          = llc$fortran_read =
            ocp$output (' ', 'fortran read', 12, occ$end_of_line);
          = llc$fortran_return =
            ocp$output (' ', 'fortran return', 14, occ$end_of_line);
          = llc$fortran_rewind =
            ocp$output (' ', 'fortran rewind', 14, occ$end_of_line);
          = llc$fortran_stop =
            ocp$output (' ', 'fortran stop', 12, occ$end_of_line);
          = llc$fortran_write =
            ocp$output (' ', 'fortran write', 13, occ$end_of_line);
          = llc$fortran_unconditional_goto =
            ocp$output (' ', 'fortran unconditional goto', 26, occ$end_of_line);
          ELSE
            ocp$output (' ', '**********', 10, occ$end_of_line);
            error (' ', 'INVALID FORTRAN LINE KIND', 25, occ$end_of_line);
          CASEND;

        = llc$cybil, llc$obsolete_cybil =
          ocp$output ('      ', 'cybil statement kind:', 21, occ$continue);
          CASE line_address_table^.item [i].cybil_statement_kind OF
          = llc$cybil_unknown_stmt_kind =
            ocp$output (' ', 'unknown cybil statement', 23, occ$end_of_line);
          = llc$cybil_procedure =
            ocp$output (' ', 'cybil procedure', 15, occ$end_of_line);
          = llc$cybil_assignment =
            ocp$output (' ', 'cybil assignment', 16, occ$end_of_line);
          = llc$cybil_begin =
            ocp$output (' ', 'cybil begin', 11, occ$end_of_line);
          = llc$cybil_end =
            ocp$output (' ', 'cybil end', 9, occ$end_of_line);
          = llc$cybil_while =
            ocp$output (' ', 'cybil while', 11, occ$end_of_line);
          = llc$cybil_whilend =
            ocp$output (' ', 'cybil whilend', 13, occ$end_of_line);
          = llc$cybil_repeat =
            ocp$output (' ', 'cybil repeat', 12, occ$end_of_line);
          = llc$cybil_until =
            ocp$output (' ', 'cybil until', 11, occ$end_of_line);
          = llc$cybil_for =
            ocp$output (' ', 'cybil for', 9, occ$end_of_line);
          = llc$cybil_forend =
            ocp$output (' ', 'cybil forend', 12, occ$end_of_line);
          = llc$cybil_procedure_call =
            ocp$output (' ', 'cybil procedure call', 20, occ$end_of_line);
          = llc$cybil_if =
            ocp$output (' ', 'cybil if', 8, occ$end_of_line);
          = llc$cybil_elseif =
            ocp$output (' ', 'cybil elseif', 12, occ$end_of_line);
          = llc$cybil_else =
            ocp$output (' ', 'cybil else', 10, occ$end_of_line);
          = llc$cybil_ifend =
            ocp$output (' ', 'cybil ifend', 11, occ$end_of_line);
          = llc$cybil_case =
            ocp$output (' ', 'cybil case', 10, occ$end_of_line);
          = llc$cybil_case_selector =
            ocp$output (' ', 'cybil case selector', 19, occ$end_of_line);
          = llc$cybil_casend =
            ocp$output (' ', 'cybil casend', 12, occ$end_of_line);
          = llc$cybil_cycle =
            ocp$output (' ', 'cybil cycle', 11, occ$end_of_line);
          = llc$cybil_exit =
            ocp$output (' ', 'cybil exit', 10, occ$end_of_line);
          = llc$cybil_return =
            ocp$output (' ', 'cybil return', 12, occ$end_of_line);
          = llc$cybil_push =
            ocp$output (' ', 'cybil push', 10, occ$end_of_line);
          = llc$cybil_next =
            ocp$output (' ', 'cybil next', 10, occ$end_of_line);
          = llc$cybil_reset =
            ocp$output (' ', 'cybil reset', 11, occ$end_of_line);
          = llc$cybil_allocate =
            ocp$output (' ', 'cybil allocate', 14, occ$end_of_line);
          = llc$cybil_free =
            ocp$output (' ', 'cybil free', 10, occ$end_of_line);
          = llc$cybil_procend =
            ocp$output (' ', 'cybil procend', 13, occ$end_of_line);
          = llc$cybil_pocket_code =
            ocp$output (' ', 'cybil pocket code', 17, occ$end_of_line);
          ELSE
            ocp$output (' ', '**********', 10, occ$end_of_line);
            error (' ', 'INVALID CYBIL LINE KIND', 23, occ$end_of_line);
          CASEND;
        = llc$the_c_language =
          ocp$output ('      ', 'c statement kind:', 17, occ$continue);
          CASE line_address_table^.item [i].c_statement_kind OF
          = llc$c_unknown_statement_kind =
            ocp$output (' ', 'unknown c statement', 19, occ$end_of_line);
          = llc$c_function =
            ocp$output (' ', 'c function', 10, occ$end_of_line);
          = llc$c_assignment =
            ocp$output (' ', 'c assignment', 12, occ$end_of_line);
          = llc$c_begin =
            ocp$output (' ', 'c begin', 7, occ$end_of_line);
          = llc$c_end =
            ocp$output (' ', 'c end', 5, occ$end_of_line);
          = llc$c_while =
            ocp$output (' ', 'c while', 7, occ$end_of_line);
          = llc$c_whilend =
            ocp$output (' ', 'c whilend', 9, occ$end_of_line);
          = llc$c_do =
            ocp$output (' ', 'c do', 4, occ$end_of_line);
          = llc$c_until =
            ocp$output (' ', 'c until', 7, occ$end_of_line);
          = llc$c_for =
            ocp$output (' ', 'c for', 5, occ$end_of_line);
          = llc$c_forend =
            ocp$output (' ', 'c forend', 8, occ$end_of_line);
          = llc$c_function_call =
            ocp$output (' ', 'c function call', 15, occ$end_of_line);
          = llc$c_if =
            ocp$output (' ', 'c if', 4, occ$end_of_line);
          = llc$c_elseif =
            ocp$output (' ', 'c elseif', 8, occ$end_of_line);
          = llc$c_else =
            ocp$output (' ', 'c else', 6, occ$end_of_line);
          = llc$c_ifend =
            ocp$output (' ', 'c ifend', 7, occ$end_of_line);
          = llc$c_switch =
            ocp$output (' ', 'c switch', 8, occ$end_of_line);
          = llc$c_switch_selector =
            ocp$output (' ', 'c switch selector', 17, occ$end_of_line);
          = llc$c_switchend =
            ocp$output (' ', 'c switchend', 11, occ$end_of_line);
          = llc$c_continue =
            ocp$output (' ', 'c continue', 10, occ$end_of_line);
          = llc$c_break =
            ocp$output (' ', 'c break', 7, occ$end_of_line);
          = llc$c_return =
            ocp$output (' ', 'c return', 8, occ$end_of_line);
          = llc$c_push =
            ocp$output (' ', 'c push', 6, occ$end_of_line);
          = llc$c_next =
            ocp$output (' ', 'c next', 6, occ$end_of_line);
          = llc$c_reset =
            ocp$output (' ', 'c reset', 7, occ$end_of_line);
          = llc$c_allocate =
            ocp$output (' ', 'c allocate', 10, occ$end_of_line);
          = llc$c_free =
            ocp$output (' ', 'c free', 6, occ$end_of_line);
          = llc$c_function_end =
            ocp$output (' ', 'c function end', 14, occ$end_of_line);
          = llc$c_goto =
            ocp$output (' ', 'c goto', 6, occ$end_of_line);
          = llc$c_null =
            ocp$output (' ', 'c null', 6, occ$end_of_line);
          ELSE
            ocp$output (' ', '**********', 10, occ$end_of_line);
            error (' ', 'INVALID C LINE KIND', 19, occ$end_of_line);
          CASEND;
        ELSE
          ocp$output (' ', '**********', 10, occ$end_of_line);
          error (' ', 'INVALID LINE ADDRESS TABLE LANGUAGE KIND', 40, occ$end_of_line);
        CASEND;
      FOREND;


    PROCEND process_line_table;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS SYMBOL TABLE' ??
?? NEWTITLE := '    OUTPUT_LENGTH_KINDS', EJECT ??

    PROCEDURE process_symbol_table
      (    sequence_length: ost$segment_length;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);





      PROCEDURE output_length_kinds
        (    s: string ( * );
             value_type: llt$length_kind;
             end_of_line: boolean);

        CASE value_type OF
        = llc$short_length =
          ocp$output (s, 'SHORT LENGTH', 12, end_of_line);

        = llc$long_length =
          ocp$output (s, 'LONG LENGTH', 11, end_of_line);

        = llc$variable_length =
          ocp$output (s, 'VARIABLE LENGTH', 15, end_of_line);

        = llc$adaptable_length =
          ocp$output (s, 'ADAPTABLE LENGTH', 16, end_of_line);

        = llc$dynamic_length =
          ocp$output (s, 'DYNAMIC LENGTH', 14, end_of_line);

        = llc$indefinite_length =
          ocp$output (s, 'INDEFINITE LENGTH', 17, end_of_line);

        = llc$null_terminator_length =
          ocp$output (s, 'NULL TERMINATOR LENGTH', 21, end_of_line);
        ELSE
          ocp$output (' ', '************', 12, occ$end_of_line);
          error (' ', 'UNKNOWN LENGTH??', 16, end_of_line);
        CASEND;

      PROCEND output_length_kinds;
?? OLDTITLE ??
?? EJECT ??


      VAR
        symbol_table: ^llt$symbol_table,
        text: ^SEQ ( * ),
        debug_symbol_table: ^llt$debug_symbol_table,
        item: ^array [1 .. * ] of llt$symbol_table_item,
        i: integer;


      NEXT symbol_table: [[REP sequence_length OF cell]] IN file;
      IF symbol_table = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      ocp$output ('      ', 'language:', 9, occ$continue);
      output_language (^symbol_table^.language, occ$end_of_line);

      text := ^symbol_table^.text;
      RESET text;

      NEXT debug_symbol_table: [1 .. 1] IN text;
      IF debug_symbol_table = NIL THEN
        error (' ', 'First NEXT in SYMBOL_TABLE failed', 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      RESET text;
      NEXT debug_symbol_table: [1 .. debug_symbol_table^.number_of_items] IN text;
      IF debug_symbol_table = NIL THEN
        error (' ', 'Second NEXT in SYMBOL_TABLE failed', 34, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      ocp$output ('      ', 'original module name:', 21, occ$continue);
      ocp$output (' ', debug_symbol_table^.original_module_name,
            #SIZE (debug_symbol_table^.original_module_name), occ$end_of_line);

      ocp$output ('      ', 'language:', 9, occ$continue);
      output_language (^debug_symbol_table^.language, occ$continue);

      ocp$output ('  ', 'optimization level:', 19, occ$continue);
      output_optimization_level (debug_symbol_table^.optimization_level, occ$end_of_line);

      ocp$output ('      ', 'version:', 8, occ$continue);
      ocp$output (' ', debug_symbol_table^.version, #SIZE (debug_symbol_table^.version), occ$continue);

      STRINGREP (strng, length, debug_symbol_table^.first_symbol_for_module);
      ocp$output ('  first symbol for module:', strng, length, occ$continue);

      STRINGREP (strng, length, debug_symbol_table^.number_of_items);
      ocp$output ('  number of items:', strng, length, occ$end_of_line);

      ocp$output ('      ', 'symbol table attributes: [', 26, occ$continue);
      IF (llc$symbol_number_is_index IN debug_symbol_table^.attributes) THEN
        ocp$output (' ', 'INDEX', 5, occ$continue);
      IFEND;

      IF (llc$language_is_case_sensitive IN debug_symbol_table^.attributes) THEN
        ocp$output (' ', 'LANGUAGE IS CASE SENSITIVE', 26, occ$continue);
      IFEND;

      IF (llc$sym_table_attribute_spare3 IN debug_symbol_table^.attributes) THEN
        ocp$output (' ', 'SPARE3', 6, occ$continue);
      IFEND;

      IF (llc$sym_table_attribute_spare4 IN debug_symbol_table^.attributes) THEN
        ocp$output (' ', 'SPARE4', 6, occ$continue);
      IFEND;

      IF (llc$sym_table_attribute_spare5 IN debug_symbol_table^.attributes) THEN
        ocp$output (' ', 'SPARE5', 6, occ$continue);
      IFEND;

      IF (llc$sym_table_attribute_spare6 IN debug_symbol_table^.attributes) THEN
        ocp$output (' ', 'SPARE6', 6, occ$continue);
      IFEND;

      IF (llc$sym_table_attribute_spare7 IN debug_symbol_table^.attributes) THEN
        ocp$output (' ', 'SPARE7', 6, occ$continue);
      IFEND;

      IF (llc$sym_table_attribute_spare8 IN debug_symbol_table^.attributes) THEN
        ocp$output (' ', 'SPARE8', 6, occ$continue);
      IFEND;
      ocp$output (' ', ']', 1, occ$end_of_line);

      item := ^debug_symbol_table^.item;

      ocp$output (' ', ' ', 1, occ$end_of_line);

      FOR i := 1 TO (debug_symbol_table^.number_of_items) DO
        ocp$output ('      ', 'symbol name:', 12, occ$continue);
        ocp$output (' ', item^ [i].symbol_name, #SIZE (item^ [i].symbol_name), occ$continue);

        STRINGREP (strng, length, item^ [i].symbol_number);
        ocp$output ('  symbol number:', strng, length, occ$end_of_line);

        ocp$output ('      ', 'end of chain:', 13, occ$continue);
        ocp$output_boolean (item^ [i].end_of_chain, occ$continue);

        ocp$output ('  ', 'symbol kind:', 12, occ$continue);

        CASE item^ [i].symbol_kind OF
        = llc$integer_kind =
          ocp$output (' ', 'INTEGER KIND', 12, occ$end_of_line);

        = llc$boolean_kind =
          ocp$output (' ', 'BOOLEAN KIND', 12, occ$end_of_line);

        = llc$char_kind =
          ocp$output (' ', 'CHAR KIND', 9, occ$end_of_line);

        = llc$real_kind =
          ocp$output (' ', 'REAL KIND', 9, occ$end_of_line);

        = llc$longreal_kind =
          ocp$output (' ', 'LONGREAL KIND', 13, occ$end_of_line);

        = llc$cell_kind =
          ocp$output (' ', 'CELL KIND', 9, occ$end_of_line);

        = llc$complex_kind =
          ocp$output (' ', 'COMPLEX KIND', 12, occ$end_of_line);

        = llc$ftn_logical_kind =
          ocp$output (' ', 'FORTRAN LOGICAL KIND', 20, occ$end_of_line);

        = llc$ftn_boolean_kind =
          ocp$output (' ', 'FORTRAN BOOLEAN KIND', 20, occ$end_of_line);

        = llc$bit_kind =
          ocp$output (' ', 'BIT KIND', 8, occ$end_of_line);

        = llc$shortreal_kind =
          ocp$output (' ', 'SHORTREAL KIND', 14, occ$end_of_line);

        = llc$ftn_subprogram_name =
          ocp$output (' ', 'FORTRAN SUBPROGRAM NAME', 23, occ$end_of_line);

        = llc$ftn_character_kind =
          ocp$output (' ', 'FORTRAN CHARACTER KIND', 22, occ$end_of_line);

        = llc$typeless_kind =
          ocp$output (' ', 'TYPELESS KIND', 13, occ$end_of_line);

        = llc$filename_kind =
          ocp$output (' ', 'FILENAME KIND', 13, occ$end_of_line);

        = llc$bdp_pdu =
          ocp$output (' ', 'BDP PDU', 7, occ$end_of_line);

        = llc$bdp_pdulsd =
          ocp$output (' ', 'BDP PDULSD', 10, occ$end_of_line);

        = llc$bdp_pds =
          ocp$output (' ', 'BDP PDS', 7, occ$end_of_line);

        = llc$bdp_pdslsd =
          ocp$output (' ', 'BDP PDSLSD', 10, occ$end_of_line);

        = llc$bdp_udu =
          ocp$output (' ', 'BDP UDU', 7, occ$end_of_line);

        = llc$bdp_udtsch =
          ocp$output (' ', 'BDP UDTSCH', 10, occ$end_of_line);

        = llc$bdp_udtss =
          ocp$output (' ', 'BDP UDTSS', 9, occ$end_of_line);

        = llc$bdp_bu =
          ocp$output (' ', 'BDP BU', 6, occ$end_of_line);

        = llc$bdp_tpds =
          ocp$output (' ', 'BDP TPDS', 8, occ$end_of_line);

        = llc$bdp_tpdslsd =
          ocp$output (' ', 'BDP TPDSLSD', 11, occ$end_of_line);

        = llc$bdp_tbu =
          ocp$output (' ', 'BDP TBU', 7, occ$end_of_line);

        = llc$bdp_tbs =
          ocp$output (' ', 'BDP TBS', 7, occ$end_of_line);

        = llc$bdp_a =
          ocp$output (' ', 'BDP A', 5, occ$end_of_line);

        = llc$cobol_justified =
          ocp$output (' ', 'COBOL JUSTIFIED', 15, occ$end_of_line);

        = llc$cobol_index_data_item =
          ocp$output (' ', 'COBOL INDEX DATA ITEM', 21, occ$end_of_line);

        = llc$cobol_index_name =
          ocp$output (' ', 'COBOL INDEX NAME', 16, occ$end_of_line);

        = llc$bdp_udlsch =
          ocp$output (' ', 'BDP UDLSCH', 10, occ$end_of_line);

        = llc$bdp_udlss =
          ocp$output (' ', 'BDP UDLSS', 9, occ$end_of_line);

        = llc$cobol_numeric_edited =
          ocp$output (' ', 'COBOL NUMERIC EDITED', 20, occ$end_of_line);

        = llc$cobol_a_edited =
          ocp$output (' ', 'COBOL A EDITED', 14, occ$end_of_line);

        = llc$var_kind =
          ocp$output (' ', 'VAR KIND', 8, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].var_type);
          ocp$output ('      var type: ', strng, length, occ$continue);

          hexrep (strng, length, item^ [i].var_length);
          ocp$output ('  var length: ', strng, length, occ$continue);

          ocp$output ('  ', 'var base:', 9, occ$continue);
          CASE item^ [i].var_base OF
          = llc$null_base =
            ocp$output (' ', 'NULL BASE', 9, occ$end_of_line);

          = llc$static_base =
            ocp$output (' ', 'STATIC BASE', 11, occ$end_of_line);

          = llc$constant_base =
            ocp$output (' ', 'CONSTANT BASE', 13, occ$end_of_line);

          = llc$stack_frame_base =
            ocp$output (' ', 'STACK FRAME BASE', 16, occ$end_of_line);

          = llc$parm_list_base =
            ocp$output (' ', 'PARM LIST BASE', 14, occ$end_of_line);

          = llc$xref_base =
            ocp$output (' ', 'XREF BASE', 9, occ$end_of_line);

          = llc$register_base =
            ocp$output (' ', 'REGISTER BASE', 13, occ$end_of_line);

          ELSE
            ocp$output (' ', '*************', 13, occ$end_of_line);
            error (' ', 'INVALID BASE', 12, occ$end_of_line);
          CASEND;

          hexrep (strng, length, item^ [i].var_section_ordinal);
          ocp$output ('      var section ordinal: ', strng, length, occ$continue);

          hexrep (strng, length, item^ [i].var_offset);
          ocp$output ('  var section offset: ', strng, length, occ$end_of_line);

          IF item^ [i].var_base = llc$static_base THEN
            verify_address (item^ [i].var_section_ordinal, item^ [i].var_offset);
          IFEND;

          ocp$output ('      ', 'var attributes: [', 17, occ$continue);
          IF (llc$var_qualifier_needed IN item^ [i].var_attributes) THEN
            ocp$output (' ', 'VAR_QUALIFIER_NEEDED', 20, occ$continue);
          IFEND;

          IF (llc$var_indirectly_referenced IN item^ [i].var_attributes) THEN
            ocp$output (' ', 'VAR_INDIRECTLY_REFERENCED', 25, occ$continue);
          IFEND;

          IF (llc$var_is_dummy_argument IN item^ [i].var_attributes) THEN
            ocp$output (' ', 'VAR_IS_DUMMY_ARGUMENT', 21, occ$continue);
          IFEND;

          IF (llc$non_source_variable IN item^ [i].var_attributes) THEN
            ocp$output (' ', 'NON_SOURCE_VARIABLE', 19, occ$continue);
          IFEND;

          IF (llc$var_attribute_spare5 IN item^ [i].var_attributes) THEN
            ocp$output (' ', 'SPARE5', 6, occ$continue);
          IFEND;

          IF (llc$var_attribute_spare6 IN item^ [i].var_attributes) THEN
            ocp$output (' ', 'SPARE6', 6, occ$continue);
          IFEND;

          IF (llc$var_attribute_spare7 IN item^ [i].var_attributes) THEN
            ocp$output (' ', 'SPARE7', 6, occ$continue);
          IFEND;

          IF (llc$var_attribute_spare8 IN item^ [i].var_attributes) THEN
            ocp$output (' ', 'SPARE8', 6, occ$continue);
          IFEND;

          ocp$output (' ', ']', 1, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].var_containing_symbol);
          ocp$output ('      var containing symbol:', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].var_point_location.value);
          ocp$output ('      var point location:', strng, length, occ$end_of_line);

        = llc$cobol_array_kind =
          ocp$output (' ', 'COBOL ARRAY KIND', 16, occ$end_of_line);

          ocp$output ('      ', 'cobol array element type:', 25, occ$continue);

          CASE item^ [i].cobol_array_element_type OF
          = llc$integer_kind =
            ocp$output (' ', 'INTEGER KIND', 12, occ$end_of_line);

          = llc$boolean_kind =
            ocp$output (' ', 'BOOLEAN KIND', 12, occ$end_of_line);

          = llc$char_kind =
            ocp$output (' ', 'CHAR KIND', 9, occ$end_of_line);

          = llc$real_kind =
            ocp$output (' ', 'REAL KIND', 9, occ$end_of_line);

          = llc$longreal_kind =
            ocp$output (' ', 'LONGREAL KIND', 13, occ$end_of_line);

          = llc$cell_kind =
            ocp$output (' ', 'CELL KIND', 9, occ$end_of_line);

          = llc$complex_kind =
            ocp$output (' ', 'COMPLEX KIND', 12, occ$end_of_line);

          = llc$ftn_logical_kind =
            ocp$output (' ', 'FORTRAN LOGICAL KIND', 20, occ$end_of_line);

          = llc$ftn_boolean_kind =
            ocp$output (' ', 'FORTRAN BOOLEAN KIND', 20, occ$end_of_line);

          = llc$bit_kind =
            ocp$output (' ', 'BIT KIND', 8, occ$end_of_line);

          = llc$shortreal_kind =
            ocp$output (' ', 'SHORTREAL KIND', 14, occ$end_of_line);

          = llc$ftn_subprogram_name =
            ocp$output (' ', 'FORTRAN SUBPROGRAM NAME', 23, occ$end_of_line);

          = llc$ftn_character_kind =
            ocp$output (' ', 'FORTRAN CHARACTER KIND', 22, occ$end_of_line);

          = llc$typeless_kind =
            ocp$output (' ', 'TYPELESS KIND', 13, occ$end_of_line);

          = llc$filename_kind =
            ocp$output (' ', 'FILENAME KIND', 13, occ$end_of_line);

          = llc$bdp_pdu =
            ocp$output (' ', 'BDP PDU', 7, occ$end_of_line);

          = llc$bdp_pdulsd =
            ocp$output (' ', 'BDP PDULSD', 10, occ$end_of_line);

          = llc$bdp_pds =
            ocp$output (' ', 'BDP PDS', 7, occ$end_of_line);

          = llc$bdp_pdslsd =
            ocp$output (' ', 'BDP PDSLSD', 10, occ$end_of_line);

          = llc$bdp_udu =
            ocp$output (' ', 'BDP UDU', 7, occ$end_of_line);

          = llc$bdp_udtsch =
            ocp$output (' ', 'BDP UDTSCH', 10, occ$end_of_line);

          = llc$bdp_udtss =
            ocp$output (' ', 'BDP UDTSS', 9, occ$end_of_line);

          = llc$bdp_bu =
            ocp$output (' ', 'BDP BU', 6, occ$end_of_line);

          = llc$bdp_tpds =
            ocp$output (' ', 'BDP TPDS', 8, occ$end_of_line);

          = llc$bdp_tpdslsd =
            ocp$output (' ', 'BDP TPDSLSD', 11, occ$end_of_line);

          = llc$bdp_tbu =
            ocp$output (' ', 'BDP TBU', 7, occ$end_of_line);

          = llc$bdp_tbs =
            ocp$output (' ', 'BDP TBS', 7, occ$end_of_line);

          = llc$bdp_a =
            ocp$output (' ', 'BDP A', 5, occ$end_of_line);

          = llc$cobol_justified =
            ocp$output (' ', 'COBOL JUSTIFIED', 15, occ$end_of_line);

          = llc$cobol_index_data_item =
            ocp$output (' ', 'COBOL INDEX DATA ITEM', 20, occ$end_of_line);

          = llc$cobol_index_name =
            ocp$output (' ', 'COBOL INDEX NAME', 16, occ$end_of_line);

          = llc$bdp_udlsch =
            ocp$output (' ', 'BDP UDLSCH', 10, occ$end_of_line);

          = llc$bdp_udlss =
            ocp$output (' ', 'BDP UDLSS', 9, occ$end_of_line);

          = llc$cobol_numeric_edited =
            ocp$output (' ', 'COBOL NUMERIC EDITED', 20, occ$end_of_line);

          = llc$cobol_a_edited =
            ocp$output (' ', 'COBOL A EDITED', 14, occ$end_of_line);

          = llc$var_kind =
            ocp$output (' ', 'VAR KIND', 8, occ$end_of_line);

          = llc$cobol_array_kind =
            ocp$output (' ', 'COBOL ARRAY KIND', 15, occ$end_of_line);

          = llc$constant_kind =
            ocp$output (' ', 'CONSTANT KIND', 13, occ$end_of_line);

          = llc$label_kind =
            ocp$output (' ', 'LABEL KIND', 10, occ$end_of_line);

          = llc$ordinal_kind =
            ocp$output (' ', 'ORDINAL KIND', 12, occ$end_of_line);

          = llc$subrange_kind =
            ocp$output (' ', 'SUBRANGE KIND', 13, occ$end_of_line);

          = llc$proc_kind =
            ocp$output (' ', 'PROC KIND', 9, occ$end_of_line);

          = llc$pointer_kind =
            ocp$output (' ', 'POINTER KIND', 12, occ$end_of_line);

          = llc$set_kind =
            ocp$output (' ', 'SET KIND', 8, occ$end_of_line);

          = llc$string_kind =
            ocp$output (' ', 'STRING KIND', 11, occ$end_of_line);

          = llc$cybil_array_kind =
            ocp$output (' ', 'CYBIL ARRAY KIND', 16, occ$end_of_line);

          = llc$record_kind =
            ocp$output (' ', 'RECORD KIND', 11, occ$end_of_line);

          = llc$field_kind =
            ocp$output (' ', 'FIELD KIND', 10, occ$end_of_line);

          = llc$selector_kind =
            ocp$output (' ', 'SELECTOR KIND', 13, occ$end_of_line);

          = llc$heap_kind =
            ocp$output (' ', 'HEAP KIND', 9, occ$end_of_line);

          = llc$seq_kind =
            ocp$output (' ', 'SEQ KIND', 8, occ$end_of_line);

          = llc$bound_vrec_kind =
            ocp$output (' ', 'BOUND VREC KIND', 15, occ$end_of_line);

          = llc$rel_ptr_kind =
            ocp$output (' ', 'REL PTR KIND', 12, occ$end_of_line);

          = llc$ftn_array_kind =
            ocp$output (' ', 'FORTRAN ARRAY KIND', 18, occ$end_of_line);

          = llc$namelist_group_kind =
            ocp$output (' ', 'NAMELIST GROUP KIND', 19, occ$end_of_line);

          = llc$equated_label =
            ocp$output (' ', 'EQUATED LABEL', 13, occ$end_of_line);

          = llc$external_equate =
            ocp$output (' ', 'EXTERNAL EQUATE', 15, occ$end_of_line);

          = llc$basic_array_kind =
            ocp$output (' ', 'BASIC ARRAY KIND', 16, occ$end_of_line);

          = llc$pascal_conf_array_kind =
            ocp$output (' ', 'PASCAL CONF ARRAY KIND', 22, occ$end_of_line);

          = llc$pascal_file_kind =
            ocp$output (' ', 'PASCAL FILE KIND', 16, occ$end_of_line);

          = llc$pascal_with_kind =
            ocp$output (' ', 'PASCAL WITH KIND', 16, occ$end_of_line);

          = llc$unsigned_integer_kind =
            ocp$output (' ', 'UNSIGNED INTEGER KIND', 21, occ$end_of_line);

          ELSE
            ocp$output (' ', '************', 12, occ$end_of_line);
            error (' ', 'INVALID SYMBOL TYPE', 19, occ$end_of_line);
          CASEND;

          STRINGREP (strng, length, item^ [i].cobol_subscript_count);
          ocp$output ('      cobol subscript count: ', strng, length, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].max_cobol_subscript_value);
          ocp$output ('      max cobol subscript value: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].occurrence_length);
          ocp$output ('  occurrence length: ', strng, length, occ$end_of_line);

        = llc$constant_kind =
          ocp$output (' ', 'CONSTANT KIND', 13, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].constant_type);
          ocp$output ('      constant type: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].constant_length);
          ocp$output ('  constant length: ', strng, length, occ$end_of_line);

          ocp$output ('      ', 'constant kind:', 14, occ$continue);
          CASE item^ [i].constant_kind OF
          = llc$short_constant =
            ocp$output (' ', 'SHORT CONSTANT', 14, occ$end_of_line);

            ocp$output ('      ', 'kind:', 5, occ$continue);
            CASE item^ [i].short_constant_value.kind OF
            = llc$boolean_kind =
              ocp$output (' BOOLEAN KIND', '  value:', 8, occ$continue);
              ocp$output_boolean (item^ [i].short_constant_value.boolean_value, occ$end_of_line);

            = llc$ftn_logical_kind =
              ocp$output (' FTN LOGICAL KIND', '  value:', 8, occ$continue);
              ocp$output_boolean (item^ [i].short_constant_value.boolean_value, occ$end_of_line);

            = llc$char_kind =
              ocp$output (' CHAR KIND', '  value:', 8, occ$continue);
              strng (1) := item^ [i].short_constant_value.char_value;
              ocp$output (' ', strng, 1, occ$end_of_line);

            = llc$bit_kind =
              ocp$output (' BIT KIND', '  value:', 8, occ$continue);
              STRINGREP (strng, length, item^ [i].short_constant_value.bit_value);
              ocp$output (' ', strng, length, occ$end_of_line);

            = llc$integer_kind =
              ocp$output (' INTEGER KIND', '  value:', 8, occ$continue);
              STRINGREP (strng, length, item^ [i].short_constant_value.integer_value);
              ocp$output (' ', strng, length, occ$end_of_line);

            ELSE
              ocp$output (' ', '**********', 10, occ$end_of_line);
              error (' ', 'INVALID SHORT CONSTANT KIND', 28, occ$end_of_line);
            CASEND;

          = llc$medium_constant =
            ocp$output (' ', 'MEDIUM CONSTANT', 15, occ$end_of_line);

            ocp$output ('      ', 'kind:', 5, occ$continue);
            CASE item^ [i].medium_constant_value.kind OF
            = llc$integer_kind =
              ocp$output (' INTEGER KIND', '  value:', 8, occ$continue);
              STRINGREP (strng, length, item^ [i].medium_constant_value.integer_value);
              ocp$output (' ', strng, length, occ$end_of_line);

            = llc$ftn_boolean_kind =
              ocp$output (' FTN BOOLEAN KIND', '  value:', 8, occ$continue);
              STRINGREP (strng, length, item^ [i].medium_constant_value.integer_value);
              ocp$output (' ', strng, length, occ$end_of_line);

            = llc$real_kind =
              ocp$output (' REAL KIND', '  value:', 8, occ$continue);
              STRINGREP (strng, length, item^ [i].medium_constant_value.real_value);
              ocp$output (' ', strng, length, occ$end_of_line);

            = llc$shortreal_kind =
              ocp$output ('SHORTREAL KIND', '  value:', 8, occ$continue);
              STRINGREP (strng, length, item^ [i].medium_constant_value.shortreal_value);
              ocp$output (' ', strng, length, occ$end_of_line);

            ELSE
              ocp$output (' ', '**********', 10, occ$end_of_line);
              error (' ', 'INVALID MEDIMUM CONSTANT VALUE', 32, occ$end_of_line);
            CASEND;

          = llc$long_constant =
            ocp$output (' ', 'LONG CONSTANT', 13, occ$end_of_line);

            hexrep (strng, length, item^ [i].constant_section_ordinal);
            ocp$output ('      constant section ordinal: ', strng, length, occ$continue);

            hexrep (strng, length, item^ [i].constant_offset);
            ocp$output ('  constant offset: ', strng, length, occ$end_of_line);

            verify_address (item^ [i].constant_section_ordinal, item^ [i].constant_offset);

          ELSE
            ocp$output (' ', '******************', 18, occ$end_of_line);
            error (' ', 'INVALID CONSTANT TYPE', 21, occ$end_of_line);
          CASEND;


        = llc$label_kind =
          ocp$output (' ', 'LABEL KIND', 10, occ$end_of_line);


          ocp$output ('      ', 'label attributes: [', 19, occ$continue);
          IF llc$label_qualifier_needed IN item^ [i].label_attributes THEN
            ocp$output (' ', 'LABEL_QUALIFIER_NEEDED', 22, occ$continue);
          IFEND;

          IF llc$cobol_section_name IN item^ [i].label_attributes THEN
            ocp$output (' ', 'COBOL_SECTION_NAME', 18, occ$continue);
          IFEND;

          IF llc$cobol_paragraph_name IN item^ [i].label_attributes THEN
            ocp$output (' ', 'COBOL_PARAGRAPH_NAME', 19, occ$continue);
          IFEND;

          IF llc$no_object_code_for_label IN item^ [i].label_attributes THEN
            ocp$output (' ', 'NO_OBJECT_CODE_FOR_LABEL', 24, occ$continue);
          IFEND;

          IF llc$non_source_label IN item^ [i].label_attributes THEN
            ocp$output (' ', 'NON_SOURCE_LABEL', 16, occ$continue);
          IFEND;

          IF llc$label_attribute_spare6 IN item^ [i].label_attributes THEN
            ocp$output (' ', 'SPARE6', 6, occ$continue);
          IFEND;

          IF llc$label_attribute_spare7 IN item^ [i].label_attributes THEN
            ocp$output (' ', 'SPARE7', 6, occ$continue);
          IFEND;

          IF llc$label_attribute_spare8 IN item^ [i].label_attributes THEN
            ocp$output (' ', 'SPARE8', 6, occ$continue);
          IFEND;

          ocp$output (' ', ']', 1, occ$end_of_line);

          hexrep (strng, length, item^ [i].label_section_ordinal);
          ocp$output ('      label section ordinal: ', strng, length, occ$continue);

          hexrep (strng, length, item^ [i].label_offset);
          ocp$output ('  label offset: ', strng, length, occ$end_of_line);

          verify_address (item^ [i].label_section_ordinal, item^ [i].label_offset);

          hexrep (strng, length, item^ [i].label_scope);
          ocp$output ('      label scope: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].label_containing_symbol);
          ocp$output ('  label containing symbol: ', strng, length, occ$end_of_line);

        = llc$ordinal_kind =
          ocp$output (' ', 'ORDINAL KIND', 12, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].last_constant);
          ocp$output ('      last constant: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].ordinal_upper_bound);
          ocp$output ('  ordinal upper bound: ', strng, length, occ$end_of_line);

        = llc$subrange_kind =
          ocp$output (' ', 'SUBRANGE KIND', 13, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].subtype);
          ocp$output ('      subtype: ', strng, length, occ$continue);

          output_length_kinds ('  low value type: ', item^ [i].low_value_type, occ$continue);
          output_length_kinds ('  high value type: ', item^ [i].high_value_type, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].low_value);
          ocp$output ('      low value: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].high_value);
          ocp$output ('  high value: ', strng, length, occ$end_of_line);

        = llc$proc_kind =
          ocp$output (' ', 'PROC KIND', 9, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].proc_lexical_level);
          ocp$output ('      lexical level: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].first_symbol_for_proc);
          ocp$output ('  first symbol for proc: ', strng, length, occ$end_of_line);

          hexrep (strng, length, item^ [i].proc_section_ordinal);
          ocp$output ('      proc section ordinal: ', strng, length, occ$continue);

          hexrep (strng, length, item^ [i].proc_offset);
          ocp$output ('  proc offset: ', strng, length, occ$continue);

          verify_address (item^ [i].proc_section_ordinal, item^ [i].proc_offset);

          hexrep (strng, length, item^ [i].proc_length);
          ocp$output ('  proc length: ', strng, length, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].proc_parent);
          ocp$output ('      proc parent: ', strng, length, occ$end_of_line);

          ocp$output ('      ', 'proc attributes: [', 18, occ$continue);
          IF llc$multiple_entry_points IN item^ [i].proc_attributes THEN
            ocp$output (' ', 'MULTIPLE_ENTRY_POINTS', 21, occ$continue);
          IFEND;

          IF llc$proc_uses_outer_level_stack IN item^ [i].proc_attributes THEN
            ocp$output (' ', 'PROC_USES_OUTER_LEVEL_STACK', 27, occ$continue);
          IFEND;

          IF llc$proc_attribute_spare3 IN item^ [i].proc_attributes THEN
            ocp$output (' ', 'SPARE3', 6, occ$continue);
          IFEND;

          IF llc$proc_attribute_spare4 IN item^ [i].proc_attributes THEN
            ocp$output (' ', 'SPARE4', 6, occ$continue);
          IFEND;

          IF llc$proc_attribute_spare5 IN item^ [i].proc_attributes THEN
            ocp$output (' ', 'SPARE5', 6, occ$continue);
          IFEND;

          IF llc$proc_attribute_spare6 IN item^ [i].proc_attributes THEN
            ocp$output (' ', 'SPARE6', 6, occ$continue);
          IFEND;

          IF llc$proc_attribute_spare7 IN item^ [i].proc_attributes THEN
            ocp$output (' ', 'SPARE7', 6, occ$continue);
          IFEND;

          IF llc$proc_attribute_spare8 IN item^ [i].proc_attributes THEN
            ocp$output (' ', 'SPARE8', 6, occ$continue);
          IFEND;

          ocp$output (' ', ']', 1, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].proc_return_type);
          ocp$output ('      proc return type: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].proc_return_length);
          ocp$output ('  proc return length: ', strng, length, occ$end_of_line);

        = llc$pointer_kind =
          ocp$output (' ', 'POINTER KIND', 12, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].ptr_type);
          ocp$output ('      ptr type: ', strng, length, occ$continue);

          hexrep (strng, length, item^ [i].ptr_object_length);
          ocp$output ('  ptr object length: ', strng, length, occ$end_of_line);

        = llc$set_kind =
          ocp$output (' ', 'SET KIND', 8, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].set_element_type);
          ocp$output ('      set element type: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].set_length);
          ocp$output ('  set length: ', strng, length, occ$end_of_line);

        = llc$string_kind =
          ocp$output (' ', 'STRING KIND', 11, occ$end_of_line);

          output_length_kinds ('      string length type: ', item^ [i].string_length_type, occ$continue);

          STRINGREP (strng, length, item^ [i].string_length);
          ocp$output ('  string length: ', strng, length, occ$end_of_line);

        = llc$cybil_array_kind =
          ocp$output (' ', 'CYBIL ARRAY KIND', 16, occ$end_of_line);

          ocp$output ('      ', 'cybil array binding:', 20, occ$continue);
          CASE item^ [i].cybil_array_binding OF
          = llc$fixed_binding =
            ocp$output (' ', 'FIXED BINDING', 13, occ$continue);

          = llc$variable_spare_binding =
            ocp$output (' ', 'VARIABLE SPARE BINDING', 22, occ$continue);

          = llc$adaptable_binding =
            ocp$output (' ', 'ADAPTABLE BINDING', 17, occ$continue);

          = llc$variant_binding =
            ocp$output (' ', 'VARIANT BINDING', 15, occ$continue);

          ELSE
            ocp$output (' ', 'INVALID BINDING KIND', 20, occ$continue);
          CASEND;

          ocp$output ('  ', 'cybil array packing:', 20, occ$continue);
          CASE item^ [i].cybil_array_packing OF
          = llc$packed =
            ocp$output (' ', 'PACKED', 6, occ$end_of_line);

          = llc$unpacked =
            ocp$output (' ', 'UNPACKED', 8, occ$end_of_line);

          = llc$not_packed =
            ocp$output (' ', 'NOT PACKED', 10, occ$end_of_line);

          ELSE
            ocp$output (' ', '*********', 9, occ$end_of_line);
            error (' ', 'INVALID ARRAY PACKING', 21, occ$end_of_line);
          CASEND;


          ocp$output ('      ', 'cybil array attributes: [', 25, occ$continue);
          IF llc$cybil_array_is_bits IN item^ [i].cybil_array_attributes THEN
            ocp$output (' ', 'CYBIL_ARRAY_IS_BITS', 19, occ$continue);
          IFEND;

          IF llc$cyb_array_attribute_spare2 IN item^ [i].cybil_array_attributes THEN
            ocp$output (' ', 'SPARE2', 6, occ$continue);
          IFEND;

          IF llc$cyb_array_attribute_spare3 IN item^ [i].cybil_array_attributes THEN
            ocp$output (' ', 'SPARE3', 6, occ$continue);
          IFEND;

          IF llc$cyb_array_attribute_spare4 IN item^ [i].cybil_array_attributes THEN
            ocp$output (' ', 'SPARE4', 6, occ$continue);
          IFEND;

          IF llc$cyb_array_attribute_spare5 IN item^ [i].cybil_array_attributes THEN
            ocp$output (' ', 'SPARE5', 6, occ$continue);
          IFEND;

          IF llc$cyb_array_attribute_spare6 IN item^ [i].cybil_array_attributes THEN
            ocp$output (' ', 'SPARE6', 6, occ$continue);
          IFEND;

          IF llc$cyb_array_attribute_spare7 IN item^ [i].cybil_array_attributes THEN
            ocp$output (' ', 'SPARE7', 6, occ$continue);
          IFEND;

          IF llc$cyb_array_attribute_spare8 IN item^ [i].cybil_array_attributes THEN
            ocp$output (' ', 'SPARE8', 6, occ$continue);
          IFEND;

          ocp$output (' ', ']', 1, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].cybil_index_type);
          ocp$output ('      cybil index type: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].cybil_array_element_type);
          ocp$output ('  cybil array element type: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].cybil_array_element_length);
          ocp$output ('  cybil array element length: ', strng, length, occ$end_of_line);

        = llc$record_kind =
          ocp$output (' ', 'RECORD KIND', 11, occ$end_of_line);

          ocp$output ('      ', 'record binding:', 15, occ$continue);
          CASE item^ [i].record_binding OF
          = llc$fixed_binding =
            ocp$output (' ', 'FIXED BINDING', 13, occ$continue);

          = llc$variable_spare_binding =
            ocp$output (' ', 'VARIABLE SPARE BINDING', 22, occ$continue);

          = llc$adaptable_binding =
            ocp$output (' ', 'ADAPTABLE BINDING', 17, occ$continue);

          = llc$variant_binding =
            ocp$output (' ', 'VARIANT BINDING', 15, occ$continue);

          ELSE
            ocp$output (' ', '********************', 20, occ$end_of_line);
            error (' ', 'INVALID BINDING KIND', 20, occ$end_of_line);
          CASEND;

          ocp$output ('  ', 'record packing:', 15, occ$continue);
          CASE item^ [i].record_packing OF
          = llc$packed =
            ocp$output (' ', 'PACKED', 6, occ$end_of_line);

          = llc$unpacked =
            ocp$output (' ', 'UNPACKED', 8, occ$end_of_line);

          = llc$not_packed =
            ocp$output (' ', 'NOT PACKED', 10, occ$end_of_line);

          ELSE
            ocp$output (' ', '*********', 9, occ$end_of_line);
            error (' ', 'INVALID RECORD PACKING', 22, occ$end_of_line);
          CASEND;

          ocp$output ('      ', 'record attributes: [', 20, occ$continue);
          IF llc$record_variation IN item^ [i].record_attributes THEN
            ocp$output (' ', 'RECORD_VARIATION', 16, occ$continue);
          IFEND;

          IF llc$record_attribute_spare2 IN item^ [i].record_attributes THEN
            ocp$output (' ', 'SPARE2', 6, occ$continue);
          IFEND;

          IF llc$record_attribute_spare3 IN item^ [i].record_attributes THEN
            ocp$output (' ', 'SPARE3', 6, occ$continue);
          IFEND;

          IF llc$record_attribute_spare4 IN item^ [i].record_attributes THEN
            ocp$output (' ', 'SPARE4', 6, occ$continue);
          IFEND;

          IF llc$record_attribute_spare5 IN item^ [i].record_attributes THEN
            ocp$output (' ', 'SPARE5', 6, occ$continue);
          IFEND;

          IF llc$record_attribute_spare6 IN item^ [i].record_attributes THEN
            ocp$output (' ', 'SPARE6', 6, occ$continue);
          IFEND;

          IF llc$record_attribute_spare7 IN item^ [i].record_attributes THEN
            ocp$output (' ', 'SPARE7', 6, occ$continue);
          IFEND;

          IF llc$record_attribute_spare8 IN item^ [i].record_attributes THEN
            ocp$output (' ', 'SPARE8', 6, occ$continue);
          IFEND;

          ocp$output (' ', ']', 1, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].record_first_field);
          ocp$output ('      record first field: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].record_length);
          ocp$output ('  record length: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].record_selector);
          ocp$output ('  record selector: ', strng, length, occ$end_of_line);

        = llc$field_kind =
          ocp$output (' ', 'FIELD KIND', 10, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].field_offset);
          ocp$output ('      field offset: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].field_length);
          ocp$output ('  field length: ', strng, length, occ$continue);

          ocp$output ('      ', 'field attributes: [', 19, occ$continue);
          IF llc$field_is_byte_addressable IN item^ [i].field_attributes THEN
            ocp$output (' ', 'FIELD_IS_BYTE_ADDRESSABLE', 25, occ$continue);
          IFEND;

          IF llc$field_attribute_spare2 IN item^ [i].field_attributes THEN
            ocp$output (' ', 'SPARE2', 6, occ$continue);
          IFEND;

          IF llc$field_attribute_spare3 IN item^ [i].field_attributes THEN
            ocp$output (' ', 'SPARE3', 6, occ$continue);
          IFEND;

          IF llc$field_attribute_spare4 IN item^ [i].field_attributes THEN
            ocp$output (' ', 'SPARE4', 6, occ$continue);
          IFEND;

          IF llc$field_attribute_spare5 IN item^ [i].field_attributes THEN
            ocp$output (' ', 'SPARE5', 6, occ$continue);
          IFEND;

          IF llc$field_attribute_spare6 IN item^ [i].field_attributes THEN
            ocp$output (' ', 'SPARE6', 6, occ$continue);
          IFEND;

          IF llc$field_attribute_spare7 IN item^ [i].field_attributes THEN
            ocp$output (' ', 'SPARE7', 6, occ$continue);
          IFEND;

          IF llc$field_attribute_spare8 IN item^ [i].field_attributes THEN
            ocp$output (' ', 'SPARE8', 6, occ$continue);
          IFEND;

          ocp$output (' ', ']', 1, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].field_type);
          ocp$output ('      field type: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].next_field);
          ocp$output ('  next field: ', strng, length, occ$end_of_line);

        = llc$selector_kind =
          ocp$output (' ', 'SELECTOR KIND', 13, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].variation);
          ocp$output ('      variation: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].next_selector);
          ocp$output ('  next selector: ', strng, length, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].low_selector);
          ocp$output ('      low selector: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].high_selector);
          ocp$output ('  high selector: ', strng, length, occ$end_of_line);

        = llc$heap_kind =
          ocp$output (' ', 'HEAP KIND', 9, occ$end_of_line);

        = llc$seq_kind =
          ocp$output (' ', 'SEQ KIND', 8, occ$end_of_line);

        = llc$bound_vrec_kind =
          ocp$output (' ', 'BOUND VREC KIND', 15, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].bound_type);
          ocp$output ('      bound type: ', strng, length, occ$end_of_line);

        = llc$rel_ptr_kind =
          ocp$output (' ', 'REL PTR KIND', 12, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].parent_type);
          ocp$output ('      parent_type: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].object_type);
          ocp$output ('  object type: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].rel_ptr_object_length);
          ocp$output ('  rel ptr object length: ', strng, length, occ$end_of_line);

        = llc$ftn_array_kind =
          ocp$output (' ', 'FORTRAN ARRAY KIND', 18, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].ftn_array_element_type);
          ocp$output ('      fortran array element type: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].ftn_array_element_length);
          ocp$output ('  fortran array element length: ', strng, length, occ$end_of_line);

          ocp$output ('      ', 'fortran array base:', 19, occ$continue);
          CASE item^ [i].ftn_array_base OF
          = llc$null_base =
            ocp$output (' ', 'NULL BASE', 9, occ$end_of_line);

          = llc$static_base =
            ocp$output (' ', 'STATIC BASE', 11, occ$end_of_line);

          = llc$constant_base =
            ocp$output (' ', 'CONSTANT BASE', 13, occ$end_of_line);

          = llc$stack_frame_base =
            ocp$output (' ', 'STACK FRAME BASE', 16, occ$end_of_line);

          = llc$parm_list_base =
            ocp$output (' ', 'PARM LIST BASE', 14, occ$end_of_line);

          = llc$xref_base =
            ocp$output (' ', 'XREF BASE', 9, occ$end_of_line);

          = llc$register_base =
            ocp$output (' ', 'REGISTER BASE', 13, occ$end_of_line);

          ELSE
            ocp$output (' ', '*************', 13, occ$end_of_line);
            error (' ', 'INVALID BASE', 12, occ$end_of_line);
          CASEND;

          hexrep (strng, length, item^ [i].ftn_array_section_ordinal);
          ocp$output ('      fortran array section ordinal: ', strng, length, occ$continue);

          hexrep (strng, length, item^ [i].ftn_array_offset);
          ocp$output ('  fortran array offset: ', strng, length, occ$end_of_line);

          IF item^ [i].ftn_array_base = llc$static_base THEN
            verify_address (item^ [i].ftn_array_section_ordinal, item^ [i].ftn_array_offset);
          IFEND;

          ocp$output ('      ', 'fortran array attributes: [', 27, occ$continue);
          IF llc$ftn_array_is_parameter IN item^ [i].ftn_array_attributes THEN
            ocp$output (' ', 'ARRAY_IS_PARAMETER', 18, occ$continue);
          IFEND;

          IF llc$ftn_storage_is_columnwise IN item^ [i].ftn_array_attributes THEN
            ocp$output (' ', 'STORAGE_IS_COLUMNWISE', 21, occ$continue);
          IFEND;

          IF llc$ftn_array_adjustable IN item^ [i].ftn_array_attributes THEN
            ocp$output (' ', 'ADUSTABLE', 9, occ$continue);
          IFEND;

          IF llc$ftn_array_assumed_size IN item^ [i].ftn_array_attributes THEN
            ocp$output (' ', 'ASSUMED_SIZE', 12, occ$continue);
          IFEND;

          IF llc$ftn_array_assumed_shape IN item^ [i].ftn_array_attributes THEN
            ocp$output (' ', 'ASSUMED_SHAPE', 13, occ$continue);
          IFEND;

          IF llc$ftn_array_indirect_accessed IN item^ [i].ftn_array_attributes THEN
            ocp$output (' ', 'INDIRECT_ACCESSED', 17, occ$continue);
          IFEND;

          IF llc$cdc_ftn_dimension_desc IN item^ [i].ftn_array_attributes THEN
            ocp$output (' ', 'DIMENSION_DESC', 14, occ$continue);
          IFEND;

          IF llc$ftn_array_attribute_spare8 IN item^ [i].ftn_array_attributes THEN
            ocp$output (' ', 'SPARE8', 6, occ$continue);
          IFEND;

          ocp$output (' ', ']', 1, occ$end_of_line);

          hexrep (strng, length, item^ [i].dimension_info_section_ordinal);
          ocp$output ('      dimension info section ordinal: ', strng, length, occ$continue);

          hexrep (strng, length, item^ [i].dimension_info_offset);
          ocp$output ('  dimension info offset: ', strng, length, occ$end_of_line);

          verify_address (item^ [i].dimension_info_section_ordinal, item^ [i].dimension_info_offset);

        = llc$namelist_group_kind =
          ocp$output (' ', 'NAMELIST GROUP KIND', 19, occ$end_of_line);

          hexrep (strng, length, item^ [i].namelist_info_section_ordinal);
          ocp$output ('      namelist info section ordinal: ', strng, length, occ$continue);

          hexrep (strng, length, item^ [i].namelist_info_offset);
          ocp$output ('  namelist info offset: ', strng, length, occ$end_of_line);

          verify_address (item^ [i].namelist_info_section_ordinal, item^ [i].namelist_info_offset);

        = llc$equated_label =
          ocp$output (' ', 'EQUATED LABEL', 13, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].first_equated_symbol);
          ocp$output ('      first equated symbol: ', strng, length, occ$end_of_line);

        = llc$external_equate =
          ocp$output (' ', 'EXTERNAL EQUATE', 15, occ$end_of_line);

          ocp$output ('      ', 'operation:', 10, occ$continue);
          CASE item^ [i].operation OF
          = llc$external_no_operation =
            ocp$output (' ', 'EXTERNAL NO OPERATION', 21, occ$continue);

          = llc$external_addition =
            ocp$output (' ', 'EXTERNAL ADDITION', 17, occ$continue);

          = llc$external_subtraction =
            ocp$output (' ', 'EXTERNAL SUBTRACTION', 20, occ$continue);

          = llc$external_multiplication =
            ocp$output (' ', 'EXTERNAL MULTIPLICATION', 23, occ$continue);

          = llc$external_division =
            ocp$output (' ', 'EXTERNAL DIVISION', 17, occ$continue);

          ELSE
            ocp$output (' ', 'INVALID EXTERNAL', 16, occ$continue);
          CASEND;

          STRINGREP (strng, length, item^ [i].operand);
          ocp$output ('  operand: ', strng, length, occ$end_of_line);

        = llc$basic_array_kind =
          ocp$output (' ', 'BASIC ARRAY KIND', 16, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].basic_array_element_type);
          ocp$output ('   basic array element type: ', strng, length, occ$end_of_line);

        = llc$pascal_conf_array_kind =
          ocp$output (' ', 'PASCAL CONF ARRAY KIND', 22, occ$end_of_line);

          ocp$output ('  ', 'conf array packing:', 20, occ$continue);
          CASE item^ [i].conf_array_packing OF
          = llc$packed =
            ocp$output (' ', 'PACKED', 6, occ$end_of_line);

          = llc$unpacked =
            ocp$output (' ', 'UNPACKED', 8, occ$end_of_line);

          = llc$not_packed =
            ocp$output (' ', 'NOT PACKED', 10, occ$end_of_line);

          ELSE
            ocp$output (' ', '*********', 9, occ$end_of_line);
            error (' ', 'INVALID ARRAY PACKING', 21, occ$end_of_line);
          CASEND;

          ocp$output ('      ', 'conf array attributes: [', 25, occ$continue);
          IF llc$cybil_array_is_bits IN item^ [i].conf_array_attributes THEN
            ocp$output (' ', 'CYBIL_ARRAY_IS_BITS', 19, occ$continue);
          IFEND;

          IF llc$cyb_array_attribute_spare2 IN item^ [i].conf_array_attributes THEN
            ocp$output (' ', 'SPARE2', 6, occ$continue);
          IFEND;

          IF llc$cyb_array_attribute_spare3 IN item^ [i].conf_array_attributes THEN
            ocp$output (' ', 'SPARE3', 6, occ$continue);
          IFEND;

          IF llc$cyb_array_attribute_spare4 IN item^ [i].conf_array_attributes THEN
            ocp$output (' ', 'SPARE4', 6, occ$continue);
          IFEND;

          IF llc$cyb_array_attribute_spare5 IN item^ [i].conf_array_attributes THEN
            ocp$output (' ', 'SPARE5', 6, occ$continue);
          IFEND;

          IF llc$cyb_array_attribute_spare6 IN item^ [i].conf_array_attributes THEN
            ocp$output (' ', 'SPARE6', 6, occ$continue);
          IFEND;

          IF llc$cyb_array_attribute_spare7 IN item^ [i].conf_array_attributes THEN
            ocp$output (' ', 'SPARE7', 6, occ$continue);
          IFEND;

          IF llc$cyb_array_attribute_spare8 IN item^ [i].conf_array_attributes THEN
            ocp$output (' ', 'SPARE8', 6, occ$continue);
          IFEND;

          ocp$output (' ', ']', 1, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].conf_array_lower_bound);
          ocp$output ('      conf array lower bound: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].conf_array_upper_bound);
          ocp$output ('  conf array upper bound: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].conf_array_element_kind);
          ocp$output ('  conf array element kind: ', strng, length, occ$continue);

          STRINGREP (strng, length, item^ [i].conf_array_element_length);
          ocp$output ('  conf array element length: ', strng, length, occ$end_of_line);

        = llc$pascal_file_kind =
          ocp$output (' ', ' PASCAL FILE KIND', 16, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].buffer_type);
          ocp$output ('       buffer type: ', strng, length, occ$end_of_line);

        = llc$pascal_with_kind =
          ocp$output (' ', 'PASCAL WITH KIND', 16, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].with_first_symbol);
          ocp$output ('   with first symbol: ', strng, length, occ$continue);

          hexrep (strng, length, item^ [i].with_section_ordinal);
          ocp$output ('   with section ordinal: ', strng, length, occ$continue);

          hexrep (strng, length, item^ [i].with_offset);
          ocp$output ('       with offset: ', strng, length, occ$continue);

          hexrep (strng, length, item^ [i].with_length);
          ocp$output ('       with length: ', strng, length, occ$end_of_line);

          STRINGREP (strng, length, item^ [i].with_parent);
          ocp$output ('       with parent: ', strng, length, occ$end_of_line);

        = llc$unsigned_integer_kind =
          ocp$output (' ', 'UNSIGNED INTEGER KIND', 21, occ$end_of_line);

        ELSE
          ocp$output (' ', '************', 12, occ$end_of_line);
          error (' ', 'INVALID SYMBOL TYPE', 19, occ$end_of_line);
        CASEND;

        ocp$output (' ', ' ', 1, occ$end_of_line);

      FOREND;


    PROCEND process_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_SUPPLEMENTAL_DTABLES' ??
?? EJECT ??

    PROCEDURE process_supplemental_dtables
      (    sequence_length: ost$segment_length;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);

      VAR
        supplemental_debug_tables: ^llt$supplemental_debug_tables;

      NEXT supplemental_debug_tables: [[REP sequence_length OF cell]] IN file;
      IF supplemental_debug_tables = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
      IFEND;

    PROCEND process_supplemental_dtables;

?? OLDTITLE ??
?? NEWTITLE := '  HEXREP' ??
?? EJECT ??

    PROCEDURE hexrep
      (VAR strng: string ( * );
       VAR length: integer;
           intger: integer);


      VAR
        str: ost$string,
        status: ost$status;


      clp$convert_integer_to_string (intger, 16, FALSE, str, status);

      length := str.size;
      strng (1, length) := str.value;


    PROCEND hexrep;
?? OLDTITLE ??
?? NEWTITLE := '  HEXREP_FULL' ??
?? EJECT ??

    PROCEDURE hexrep_full
      (VAR strng: string ( * );
       VAR length: integer;
           location: ^cell;
           offset: integer;
           size: 1 .. 32);


      VAR
        array_pointer: ^array [1 .. * ] of 0 .. 0ff(16),
        i: 1 .. 32,
        str: ost$string,
        status: ost$status;


      length := 0;
      i#build_adaptable_array_ptr (#RING (location), #SEGMENT (location), (#OFFSET (location) + offset), size,
            1, 1, #LOC (array_pointer));

      FOR i := 1 TO size DO
        clp$convert_integer_to_string (array_pointer^ [i], 16, FALSE, str, status);

        CASE str.size OF
        = 1 =
          strng (1 + length) := '0';
          strng (1 + length + 1) := str.value (1);
        = 2 =
          strng (1 + length, 2) := str.value (1, 2);
        = 3 =
          strng (1 + length, 2) := str.value (2, 2);
        ELSE
          error (' ', 'INTERNAL PROBLEM 1', 18, occ$end_of_line);
        CASEND;

        length := length + 2;
      FOREND;


    PROCEND hexrep_full;
?? OLDTITLE ??
?? NEWTITLE := '  HEX_DUMP' ??
?? EJECT ??

    PROCEDURE hex_dump
      (    location: ^cell;
           size: integer);


      VAR
        i: integer;


      IF NOT display_hex_records THEN
        ocp$output ('0', '     {**** HEX RECORD NOT DISPLAYED ****}', 41, occ$end_of_line);
        RETURN;
      IFEND;

      ocp$output (' ', '     ', 5, occ$continue);

      i := 0;
      REPEAT
        IF (size - i) < 4 THEN
          hexrep_full (strng, length, location, i, (size - i));
        ELSE
          hexrep_full (strng, length, location, i, 4);
        IFEND;

        IF (i MOD 24) = 0 THEN
          ocp$output ('', '', 0, occ$end_of_line);
          ocp$output ('      ', strng, length, occ$continue);
        ELSE
          ocp$output ('  ', strng, length, occ$continue);
        IFEND;

        i := i + 4;
      UNTIL i >= size;

      ocp$output ('', '', 0, occ$end_of_line);


    PROCEND hex_dump;
?? OLDTITLE ??
?? NEWTITLE := '  OUTPUT_LANGUAGE', EJECT ??

    PROCEDURE output_language
      (    language: ^llt$module_generator;
           end_of_line: boolean);


      VAR
        valid_language: boolean;


      ocp$output_module_generator (language, end_of_line, valid_language);

      IF NOT valid_language THEN
        ocp$output (' ', ' ', 1, occ$end_of_line);
        error (' ', 'INVALID MODULE GENERATOR', 24, occ$end_of_line);
      IFEND;


    PROCEND output_language;
?? OLDTITLE ??
?? NEWTITLE := '  VERIFY_ADDRESS' ??
?? EJECT ??

    PROCEDURE verify_address
      (    section_ordinal: integer;
           offset: integer);


      IF section_ordinal > module_info.greatest_section_ordinal THEN
        hexrep (strng, length, section_ordinal);
        error (' ', 'SECTION ORDINAL > GREATEST SECTION ORDINAL:', 43, occ$continue);
        error (' ', strng, length, occ$end_of_line);

      ELSEIF module_info.section_definition^ [section_ordinal] = NIL THEN
        hexrep (strng, length, section_ordinal);
        error (' ', 'SECTION DEFINITION FOR THIS SECTION NOT YET ENCOUNTERED:', 56, occ$continue);
        error (' ', strng, length, occ$end_of_line);

      ELSEIF (offset + 1) > module_info.section_definition^ [section_ordinal]^.length THEN
        hexrep (strng, length, (offset + 1));
        warning (' ', 'OFFSET REFERENCE (', 18, occ$continue);
        warning (' ', strng, length, occ$continue);
        hexrep (strng, length, module_info.section_definition^ [section_ordinal]^.length);
        warning (' ', ') > SECTION LENGTH (', 20, occ$continue);
        warning (' ', strng, length, occ$continue);
        warning (' ', ')', 1, occ$end_of_line);

      ELSEIF offset < 0 THEN
        hexrep (strng, length, offset);
        warning (' ', 'INVALID OFFSET:', 15, occ$continue);
        warning (' ', strng, length, occ$end_of_line);

      IFEND;


    PROCEND verify_address;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_OBJECT_TEXT_DESCRIPTOR' ??
?? EJECT ??

    PROCEDURE process_object_text_descriptor
      (VAR file: ^SEQ ( * );
       VAR fatal_error: boolean;
       VAR end_of_file: boolean;
       VAR kind: llt$object_record_kind;
       VAR size: integer);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,

        file_position: ost$segment_offset;


      end_of_file := FALSE;

      NEXT object_text_descriptor IN file;
      IF object_text_descriptor = NIL THEN
        file_position := i#current_sequence_position (file);
        IF file_position >= #SIZE (file^) THEN
          end_of_file := TRUE;
        ELSE
          error (' ', premature_end_of_file, 33, occ$end_of_line);
          fatal_error := TRUE;
        IFEND;
        RETURN;
      IFEND;


      CASE object_text_descriptor^.kind OF
      = llc$identification =
        kind := llc$identification;
        ocp$output ('0', 'IDR', 3, occ$continue);

      = llc$libraries =
        kind := llc$libraries;
        ocp$output ('0', 'LIB', 3, occ$continue);

      = llc$section_definition =
        kind := llc$section_definition;
        ocp$output ('0', 'SDC', 3, occ$continue);

      = llc$allotted_section_definition =
        kind := llc$allotted_section_definition;
        ocp$output ('0', 'ASD', 3, occ$continue);

      = llc$segment_definition =
        kind := llc$segment_definition;
        ocp$output ('0', 'SGD', 3, occ$continue);

      = llc$allotted_segment_definition =
        kind := llc$allotted_segment_definition;
        ocp$output ('0', 'ASG', 3, occ$continue);

      = llc$obsolete_segment_definition =
        kind := llc$obsolete_segment_definition;
        ocp$output ('0', 'OSD', 3, occ$continue);

      = llc$obsolete_allotted_seg_def =
        kind := llc$obsolete_allotted_seg_def;
        ocp$output ('0', 'OAS', 3, occ$continue);

      = llc$unallocated_common_block =
        kind := llc$unallocated_common_block;
        ocp$output ('0', 'UCB', 3, occ$continue);

      = llc$text =
        kind := llc$text;
        ocp$output ('0', 'TEX', 3, occ$continue);

      = llc$replication =
        kind := llc$replication;
        ocp$output ('0', 'RPL', 3, occ$continue);

      = llc$bit_string_insertion =
        kind := llc$bit_string_insertion;
        ocp$output ('0', 'BSI', 3, occ$continue);

      = llc$entry_definition =
        kind := llc$entry_definition;
        ocp$output ('0', 'EPT', 3, occ$continue);

      = llc$deferred_entry_points =
        kind := llc$deferred_entry_points;
        ocp$output ('0', 'DEP', 3, occ$continue);

      = llc$deferred_common_blocks =
        kind := llc$deferred_common_blocks;
        ocp$output ('0', 'DCB', 3, occ$continue);

      = llc$relocation =
        kind := llc$relocation;
        ocp$output ('0', 'RIF', 3, occ$continue);

      = llc$address_formulation =
        kind := llc$address_formulation;
        ocp$output ('0', 'ADR', 3, occ$continue);

      = llc$external_linkage =
        kind := llc$external_linkage;
        ocp$output ('0', 'EXT', 3, occ$continue);

      = llc$obsolete_formal_parameters =
        kind := llc$obsolete_formal_parameters;
        ocp$output ('0', 'OFP', 3, occ$continue);

      = llc$formal_parameters =
        kind := llc$formal_parameters;
        ocp$output ('0', 'FPR', 3, occ$continue);

      = llc$actual_parameters =
        kind := llc$actual_parameters;
        ocp$output ('0', 'APR', 3, occ$continue);

      = llc$binding_template =
        kind := llc$binding_template;
        ocp$output ('0', 'BTI', 3, occ$continue);

      = llc$ppu_absolute =
        kind := llc$ppu_absolute;
        ocp$output ('0', 'PPU', 3, occ$continue);

      = llc$obsolete_line_table =
        kind := llc$obsolete_line_table;
        ocp$output ('0', 'OLT', 3, occ$continue);

      = llc$cybil_symbol_table_fragment =
        kind := llc$cybil_symbol_table_fragment;
        ocp$output ('0', 'CST', 3, occ$continue);

      = llc$line_table =
        kind := llc$line_table;
        ocp$output ('0', 'LAT', 3, occ$continue);

      = llc$symbol_table =
        kind := llc$symbol_table;
        ocp$output ('0', 'DST', 3, occ$continue);

      = llc$supplemental_debug_tables =
        kind := llc$supplemental_debug_tables;
        ocp$output ('0', 'SDT', 3, occ$continue);

      = llc$form_definition =
        kind := llc$form_definition;
        ocp$output ('0', 'FRM', 3, occ$continue);

      = llc$application_identifier =
        kind := llc$application_identifier;
        ocp$output ('0', 'AIR', 3, occ$continue);

      = llc$68000_absolute =
        kind := llc$68000_absolute;
        ocp$output ('0', '68A', 3, occ$continue);

      = llc$transfer_symbol =
        kind := llc$transfer_symbol;
        ocp$output ('0', 'TRA', 3, occ$continue);

      ELSE
        ocp$output ('0', '***', 3, occ$continue);
      CASEND;

      STRINGREP (strng, length, record_number);
      ocp$output ('  ', 'rn:', 3, occ$continue);
      ocp$output (' ', strng, length, occ$continue);
      record_number := record_number + 1;

      hexrep (strng, length, #OFFSET (object_text_descriptor));
      ocp$output ('  ', 'bn:', 3, occ$continue);
      ocp$output (' ', strng, length, occ$continue);
      CASE object_text_descriptor^.kind OF
      = llc$identification, llc$section_definition, llc$bit_string_insertion, llc$entry_definition,
            llc$binding_template, llc$transfer_symbol, llc$segment_definition, llc$unallocated_common_block,
            llc$application_identifier, llc$obsolete_segment_definition =
        ocp$output ('', '', 0, occ$end_of_line);

      = llc$libraries =
        size := object_text_descriptor^.number_of_libraries;
        hexrep (strng, length, object_text_descriptor^.number_of_libraries);
        ocp$output ('  ', 'number of libraries:', 20, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

        IF object_text_descriptor^.number_of_libraries = 0 THEN
          error (' ', 'NUMBER OF LIBRARIES CAN NOT BE 0', 32, occ$end_of_line);
          fatal_error := TRUE;
        IFEND;

      = llc$allotted_section_definition =
        size := object_text_descriptor^.allotted_section;
        hexrep (strng, length, object_text_descriptor^.allotted_section);
        ocp$output ('  ', 'allotted section:', 17, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

      = llc$allotted_segment_definition, llc$obsolete_allotted_seg_def =
        size := object_text_descriptor^.allotted_segment;
        hexrep (strng, length, object_text_descriptor^.allotted_segment);
        ocp$output ('  ', 'allotted segment:', 17, occ$continue);
        ocp$output (' ', strng, length, occ$continue);
        size := (size * 100000000(16)) + object_text_descriptor^.allotted_segment_length; {kludge}
        hexrep (strng, length, object_text_descriptor^.allotted_segment_length);
        ocp$output ('  ', 'allotted segment length:', 24, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

      = llc$text, llc$replication =
        size := object_text_descriptor^.number_of_bytes;
        hexrep (strng, length, object_text_descriptor^.number_of_bytes);
        ocp$output ('  ', 'number of bytes:', 16, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

        IF object_text_descriptor^.number_of_bytes = 0 THEN
          error (' ', 'NUMBER OF BYTES CAN NOT BE 0', 33, occ$end_of_line);
          fatal_error := TRUE;
        IFEND;

      = llc$relocation =
        size := object_text_descriptor^.number_of_rel_items;
        hexrep (strng, length, object_text_descriptor^.number_of_rel_items);
        ocp$output ('  ', 'number of relocation items:', 27, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

        IF object_text_descriptor^.number_of_rel_items = 0 THEN
          error (' ', 'NUMBER OF ITEMS CAN NOT BE 0', 33, occ$end_of_line);
          fatal_error := TRUE;
        IFEND;

      = llc$address_formulation =
        size := object_text_descriptor^.number_of_adr_items;
        hexrep (strng, length, object_text_descriptor^.number_of_adr_items);
        ocp$output ('  ', 'number of address formulation items:', 36, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

        IF object_text_descriptor^.number_of_adr_items = 0 THEN
          error (' ', 'NUMBER OF ITEMS CAN NOT BE 0', 33, occ$end_of_line);
          fatal_error := TRUE;
        IFEND;

      = llc$deferred_entry_points =
        size := object_text_descriptor^.number_of_entry_points;
        hexrep (strng, length, object_text_descriptor^.number_of_entry_points);
        ocp$output ('  ', 'number of entry points:', 23, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

      = llc$deferred_common_blocks =
        size := object_text_descriptor^.number_of_common_blocks;
        hexrep (strng, length, object_text_descriptor^.number_of_common_blocks);
        ocp$output ('  ', 'number of common blocks:', 24, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

      = llc$external_linkage =
        size := object_text_descriptor^.number_of_ext_items;
        hexrep (strng, length, object_text_descriptor^.number_of_ext_items);
        ocp$output ('  ', 'number of external items:', 25, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

        IF object_text_descriptor^.number_of_ext_items = 0 THEN
          error (' ', 'NUMBER OF ITEMS CAN NOT BE 0', 33, occ$end_of_line);
          fatal_error := TRUE;
        IFEND;

      = llc$obsolete_line_table, llc$line_table =
        size := object_text_descriptor^.number_of_line_items;
        hexrep (strng, length, object_text_descriptor^.number_of_line_items);
        ocp$output ('  ', 'number of line table items:', 27, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

        IF object_text_descriptor^.number_of_line_items = 0 THEN
          error (' ', 'NUMBER OF LINE TABLE ITEMS CAN NOT BE 0', 39, occ$end_of_line);
          fatal_error := TRUE;
        IFEND;

      = llc$obsolete_formal_parameters, llc$formal_parameters, llc$actual_parameters,
            llc$cybil_symbol_table_fragment, llc$68000_absolute, llc$symbol_table, llc$form_definition,
            llc$supplemental_debug_tables =
        size := object_text_descriptor^.sequence_length;
        hexrep (strng, length, object_text_descriptor^.sequence_length);
        ocp$output ('  ', 'sequence length:', 16, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

        IF object_text_descriptor^.sequence_length = 0 THEN
          error (' ', 'SEQUENCE LENGTH CAN NOT BE 0', 28, occ$end_of_line);
          fatal_error := TRUE;
        IFEND;

      = llc$ppu_absolute =
        size := object_text_descriptor^.number_of_words;
        hexrep (strng, length, object_text_descriptor^.number_of_words);
        ocp$output ('  ', 'number of words:', 17, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

        IF object_text_descriptor^.number_of_words > llc$max_ppu_size THEN
          error (' ', 'INVALID NUMBER OF WORDS', 23, occ$end_of_line);
          fatal_error := TRUE;
        IFEND;

      ELSE
        ocp$output ('', '', 0, occ$end_of_line);

        error (' ', 'INVALID OBJECT RECORD KIND', 26, occ$end_of_line);
        fatal_error := TRUE;
      CASEND;


    PROCEND process_object_text_descriptor;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_IDENTIFICATION_RECORD' ??
?? EJECT ??

    PROCEDURE process_identification_record
      (VAR file: ^SEQ ( * );
       VAR fatal_error: boolean;
       VAR module_kind: llt$module_kind);


      VAR
        valid: boolean,
        identification: ^llt$identification;


      NEXT identification IN file;
      IF identification = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      ocp$output ('      ', 'name:', 5, occ$continue);
      ocp$output (' ', identification^.name, STRLENGTH (identification^.name), occ$end_of_line);

      ocp$output ('      ', 'kind:', 5, occ$continue);
      ocp$output_module_kind (^identification^.kind, occ$continue, valid);
      IF valid THEN
        module_kind := identification^.kind;
      ELSE
        ocp$output (' ', '*', 1, occ$end_of_line);
        error (' ', 'INVALID MODULE KIND', 19, occ$end_of_line);
        fatal_error := TRUE;
      IFEND;

      ocp$output ('   ', 'created:', 8, occ$continue);
      ocp$output_time (^identification^.time_created, occ$continue, valid);
      IF NOT valid THEN
        ocp$output (' ', ' ', 1, occ$end_of_line);
        error (' ', 'INVALID TIME FORMAT', 19, occ$end_of_line);
        ocp$output (' ', '     ', 5, occ$continue);
      IFEND;

      ocp$output ('', ' ', 1, occ$continue);
      ocp$output_date (^identification^.date_created, occ$end_of_line, valid);
      IF NOT valid THEN
        error (' ', 'INVALID DATE FORMAT', 19, occ$end_of_line);
      IFEND;

      ocp$output ('      ', 'attr = [', 8, occ$continue);
      IF NOT (llc$nonbindable IN identification^.attributes) THEN
        ocp$output (' ', 'BIND', 4, occ$continue);
      IFEND;
      IF NOT (llc$nonexecutable IN identification^.attributes) THEN
        ocp$output (' ', 'EXECUTE', 7, occ$continue);
      IFEND;
      IF (identification^.generator_id = llc$cybil) OR (identification^.generator_id =
            llc$object_library_generator) OR (identification^.generator_id = llc$virtual_environment_linker)
            THEN
        IF (llc$object_cybil_checking IN identification^.attributes) THEN
          ocp$output (' ', 'OBJECT_CYBIL_CHECKING', 21, occ$continue);
        ELSE
          ocp$output (' ', 'SOURCE_CYBIL_CHECKING', 21, occ$continue);
        IFEND;
      IFEND;
      IF (llc$ma_unused_1 IN identification^.attributes) THEN
        ocp$output (' ', 'SPARE1', 6, occ$continue);
      IFEND;
      IF (llc$ma_unused_2 IN identification^.attributes) THEN
        ocp$output (' ', 'SPARE2', 6, occ$continue);
      IFEND;
      IF (llc$ma_unused_3 IN identification^.attributes) THEN
        ocp$output (' ', 'SPARE3', 6, occ$continue);
      IFEND;
      IF (llc$ma_unused_4 IN identification^.attributes) THEN
        ocp$output (' ', 'SPARE4', 6, occ$continue);
      IFEND;
      IF (llc$ma_unused_5 IN identification^.attributes) THEN
        ocp$output (' ', 'SPARE5', 6, occ$continue);
      IFEND;
      ocp$output (' ', ']', 1, occ$continue);

      IF identification^.kind <> llc$iou THEN
        module_info.greatest_section_ordinal := identification^.greatest_section_ordinal;
        hexrep (strng, length, module_info.greatest_section_ordinal);
        ocp$output ('   ', 'greatest section ordinal:', 25, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);
      ELSE
        module_info.greatest_section_ordinal := 0;
        ocp$output ('', '', 0, occ$end_of_line);
      IFEND;

      ocp$output ('      ', 'generator:', 10, occ$continue);
      output_language (^identification^.generator_id, occ$continue);

      module_info.version := identification^.object_text_version;
      ocp$output ('   ', 'object text version:', 20, occ$continue);
      ocp$output (' ', module_info.version, STRLENGTH (module_info.version), occ$end_of_line);
      IF (module_info.version <> 'V1.2') AND (module_info.version <> 'V1.3') AND (module_info.version <>
            'V1.4') THEN
        error (' ', 'INVALID OBJECT TEXT VERSION', 27, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      IF (module_info.version < 'V1.4') AND ((identification^.generator_id = llc$cybil) OR
            (identification^.generator_id = llc$obsolete_cybil)) THEN
        error (' ', 'CYBIL must be > V1.3', 20, occ$end_of_line);
      IFEND;

      ocp$output ('      ', 'generator name version:', 23, occ$continue);
      ocp$output (' ', identification^.generator_name_vers, STRLENGTH (identification^.generator_name_vers),
            occ$end_of_line);

      ocp$output ('      ', 'commentary:', 11, occ$continue);
      ocp$output (' ', identification^.commentary, STRLENGTH (identification^.commentary), occ$end_of_line);


    PROCEND process_identification_record;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_SECTION_DEFINITION' ??
?? EJECT ??

    PROCEDURE display_section_definition
      (    section_definition: ^llt$section_definition;
           allotted: boolean;
           allotted_section: ost$relative_pointer;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        valid: boolean,
        valid_position: boolean,
        file_ptr: ost$segment_offset,
        reset_value: ^SEQ ( * ),
        section_element: ^array [1 .. * ] of 0 .. 0ff(16);


      hexrep (strng, length, section_definition^.section_ordinal);
      ocp$output (' ', '     section:', 13, occ$continue);
      ocp$output (' ', strng, length, occ$continue);

      ocp$output ('  ', 'kind:', 5, occ$continue);
      ocp$output_section_kind (^section_definition^.kind, occ$continue, valid);
      IF NOT valid THEN
        ocp$output (' ', ' ', 1, occ$end_of_line);
        ocp$output (' ', '     ', 5, occ$continue);
        error (' ', 'INVALID SECTION KIND', 20, occ$end_of_line);
      IFEND;

      ocp$output ('  ', 'attr = [', 8, occ$continue);
      IF llc$read IN section_definition^.access_attributes THEN
        ocp$output (' ', 'R', 1, occ$continue);
      IFEND;
      IF llc$write IN section_definition^.access_attributes THEN
        ocp$output (' ', 'W', 1, occ$continue);
      IFEND;
      IF llc$execute IN section_definition^.access_attributes THEN
        ocp$output (' ', 'X', 1, occ$continue);
      IFEND;
      IF llc$binding IN section_definition^.access_attributes THEN
        ocp$output (' ', 'B', 1, occ$continue);
      IFEND;
      ocp$output (' ', ']', 1, occ$end_of_line);

      hexrep (strng, length, section_definition^.length);
      ocp$output ('      ', 'length:', 7, occ$continue);
      ocp$output (' ', strng, length, occ$continue);

      hexrep (strng, length, section_definition^.allocation_offset);
      ocp$output ('  ', 'offset:', 7, occ$continue);
      ocp$output (' ', strng, length, occ$continue);

      hexrep (strng, length, section_definition^.allocation_alignment);
      ocp$output ('  ', 'alignment:', 10, occ$continue);
      ocp$output (' ', strng, length, occ$end_of_line);

      IF section_definition^.allocation_alignment = 0 THEN
        error (' ', 'ALLOCATION ALIGNMENT EQUALS 0', 29, occ$end_of_line);
      IFEND;
      IF section_definition^.name <> osc$null_name THEN
        ocp$output ('      ', 'name:', 5, occ$continue);
        ocp$output (' ', section_definition^.name, STRLENGTH (section_definition^.name), occ$end_of_line);
      IFEND;

      IF section_definition^.section_ordinal > module_info.greatest_section_ordinal THEN
        error (' ', 'SECTION ORDINAL > GREATEST SECTION ORDINAL', 43, occ$end_of_line);
        RETURN;
      IFEND;

      IF module_info.section_definition^ [section_definition^.section_ordinal] <> NIL THEN
        error (' ', 'SECTION DEFINTION ALREADY ENCOUNTERED FOR THIS SECTION', 54, occ$end_of_line);
        RETURN;
      IFEND;

      module_info.section_definition^ [section_definition^.section_ordinal] := section_definition;

      IF allotted THEN
        IF section_definition^.length = 0 THEN
          error (' ', 'ZERO LENGTH SECTION', 19, occ$end_of_line);
        ELSE
          reset_value := file;
          pmp$position_object_library (file, allotted_section, valid_position);
          IF NOT valid_position THEN
            error (' ', 'PREMATURE END_OF_FILE ENCOUNTERED', 33, occ$end_of_line);
          ELSE
            NEXT section_element: [1 .. section_definition^.length] IN file;
            IF section_element = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
            ELSE
              ocp$output (' ', ' ', 1, occ$end_of_line);
              hex_dump (#LOC (section_element^), section_definition^.length);
            IFEND;
          IFEND;

          file := reset_value;
        IFEND;
      IFEND;


    PROCEND display_section_definition;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_SECTION_DEFINITION' ??
?? EJECT ??

    PROCEDURE process_section_definition
      (VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        section_definition: ^llt$section_definition;


      NEXT section_definition IN file;
      IF section_definition = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      display_section_definition (section_definition, (NOT c$allotted), 0, file, fatal_error);


    PROCEND process_section_definition;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_ALLOTTED_SECTION_DEF' ??
?? EJECT ??

    PROCEDURE process_allotted_section_def
      (    allotted_section: ost$relative_pointer;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        section_definition: ^llt$section_definition;


      NEXT section_definition IN file;
      IF section_definition = NIL THEN
        error (' ', 'PREMATURE END-OF-FILE encountered', 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      display_section_definition (section_definition, c$allotted, allotted_section, file, fatal_error);


    PROCEND process_allotted_section_def;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_SEGMENT_DEFINITION', EJECT ??

    PROCEDURE display_segment_definition
      (    segment_definition: ^llt$segment_definition;
           allotted: boolean;
           allotted_segment: ost$segment_length;
           allotted_segment_length: ost$segment_length;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        bytes_to_display: integer,
        valid_position: boolean,
        file_ptr: ost$segment_offset,
        reset_value: ^SEQ ( * ),
        segment_element: ^array [1 .. * ] of 0 .. 0ff(16);


      hexrep (strng, length, segment_definition^.segment_number);
      ocp$output (' ', '     segment:', 13, occ$continue);
      ocp$output (' ', strng, length, occ$continue);

      hexrep (strng, length, segment_definition^.r1);
      ocp$output ('  r1: ', strng, length, occ$continue);

      hexrep (strng, length, segment_definition^.r2);
      ocp$output ('  r2: ', strng, length, occ$end_of_line);

      display_section_definition (^segment_definition^.section_definition, (NOT c$allotted), 0, file,
            fatal_error);
      IF (fatal_error) THEN
        RETURN;
      IFEND;

      hexrep (strng, length, segment_definition^.binding_section_ordinal);
      ocp$output ('      binding section ordinal: ', strng, length, occ$continue);
      hexrep (strng, length, segment_definition^.binding_section_offset);
      ocp$output ('  binding section offset: ', strng, length, occ$continue);
      hexrep (strng, length, segment_definition^.future_use);
      ocp$output ('  future use: ', strng, length, occ$end_of_line);

      IF allotted THEN
        IF llc$write IN segment_definition^.section_definition.access_attributes THEN
          bytes_to_display := allotted_segment_length;
        ELSE
          bytes_to_display := segment_definition^.section_definition.length;
        IFEND;

        IF bytes_to_display = 0 THEN
          error (' ', 'ZERO LENGTH SEGMENT', 19, occ$end_of_line);
        ELSE
          reset_value := file;
          pmp$position_object_library (file, allotted_segment, valid_position);
          IF NOT valid_position THEN
            error (' ', 'PREMATURE END_OF_FILE ENCOUNTERED', 33, occ$end_of_line);
          ELSE
            NEXT segment_element: [1 .. bytes_to_display] IN file;
            IF segment_element = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
            ELSE
              ocp$output (' ', ' ', 1, occ$end_of_line);
              hex_dump (#LOC (segment_element^), segment_definition^.section_definition.length);
            IFEND;
          IFEND;

          file := reset_value;
        IFEND;
      IFEND;


    PROCEND display_segment_definition;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_SEGMENT_DEFINITION' ??
?? EJECT ??

    PROCEDURE process_segment_definition
      (VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        segment_definition: ^llt$segment_definition;


      NEXT segment_definition IN file;
      IF segment_definition = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      display_segment_definition (segment_definition, (NOT c$allotted), 0, 0, file, fatal_error);


    PROCEND process_segment_definition;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_ALLOTTED_SEGMENT_DEF' ??
?? EJECT ??

    PROCEDURE process_allotted_segment_def
      (    allotted_segment: ost$segment_length;
           allotted_segment_length: ost$segment_length;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        segment_definition: ^llt$segment_definition;


      NEXT segment_definition IN file;
      IF segment_definition = NIL THEN
        error (' ', 'PREMATURE END-OF-FILE encountered', 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      display_segment_definition (segment_definition, c$allotted, allotted_segment, allotted_segment_length,
            file, fatal_error);


    PROCEND process_allotted_segment_def;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_OBSOLETE_SEG_DEF', EJECT ??

    PROCEDURE display_obsolete_seg_def
      (    segment_definition: ^llt$obsolete_segment_definition;
           allotted: boolean;
           allotted_segment: ost$segment_length;
           allotted_segment_length: ost$segment_length;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        bytes_to_display: integer,
        valid_position: boolean,
        file_ptr: ost$segment_offset,
        reset_value: ^SEQ ( * ),
        segment_element: ^array [1 .. * ] of 0 .. 0ff(16);


      hexrep (strng, length, segment_definition^.segment_number);
      ocp$output (' ', '     segment:', 13, occ$continue);
      ocp$output (' ', strng, length, occ$continue);

      hexrep (strng, length, segment_definition^.r1);
      ocp$output ('  r1: ', strng, length, occ$continue);

      hexrep (strng, length, segment_definition^.r2);
      ocp$output ('  r2: ', strng, length, occ$end_of_line);

      display_section_definition (^segment_definition^.section_definition, (NOT c$allotted), 0, file,
            fatal_error);
      IF (fatal_error) THEN
        RETURN;
      IFEND;

      IF allotted THEN
        IF llc$write IN segment_definition^.section_definition.access_attributes THEN
          bytes_to_display := allotted_segment_length;
        ELSE
          bytes_to_display := segment_definition^.section_definition.length;
        IFEND;

        IF bytes_to_display = 0 THEN
          error (' ', 'ZERO LENGTH SEGMENT', 19, occ$end_of_line);
        ELSE
          reset_value := file;
          pmp$position_object_library (file, allotted_segment, valid_position);
          IF NOT valid_position THEN
            error (' ', 'PREMATURE END_OF_FILE ENCOUNTERED', 33, occ$end_of_line);
          ELSE
            NEXT segment_element: [1 .. bytes_to_display] IN file;
            IF segment_element = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
            ELSE
              ocp$output (' ', ' ', 1, occ$end_of_line);
              hex_dump (#LOC (segment_element^), segment_definition^.section_definition.length);
            IFEND;
          IFEND;

          file := reset_value;
        IFEND;
      IFEND;


    PROCEND display_obsolete_seg_def;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_OBSOLETE_SEG_DEF' ??
?? EJECT ??

    PROCEDURE process_obsolete_seg_def
      (VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        obsolete_segment_definition: ^llt$obsolete_segment_definition;


      NEXT obsolete_segment_definition IN file;
      IF obsolete_segment_definition = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      display_obsolete_seg_def (obsolete_segment_definition, (NOT c$allotted), 0, 0, file, fatal_error);


    PROCEND process_obsolete_seg_def;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_OBS_ALLOTTED_SEG_DEF' ??
?? EJECT ??

    PROCEDURE process_obs_allotted_seg_def
      (    allotted_segment: ost$segment_length;
           allotted_segment_length: ost$segment_length;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        obsolete_segment_definition: ^llt$obsolete_segment_definition;


      NEXT obsolete_segment_definition IN file;
      IF obsolete_segment_definition = NIL THEN
        error (' ', 'PREMATURE END-OF-FILE encountered', 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      display_obsolete_seg_def (obsolete_segment_definition, c$allotted, allotted_segment,
            allotted_segment_length, file, fatal_error);


    PROCEND process_obs_allotted_seg_def;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_LIBRARIES_RECORD' ??
?? EJECT ??

    PROCEDURE process_libraries_record
      (    number_of_libraries: 1 .. llc$max_libraries;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        libraries: ^llt$libraries,
        l: 1 .. llc$max_libraries;


      NEXT libraries: [1 .. number_of_libraries] IN file;
      IF libraries = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      l := 1;
      REPEAT
        ocp$output ('      ', libraries^ [l], STRLENGTH (libraries^ [l]), occ$continue);
        l := l + 1;
        IF l > number_of_libraries THEN
          ocp$output ('', '', 0, occ$end_of_line);
        ELSE
          ocp$output ('  ', libraries^ [l], STRLENGTH (libraries^ [l]), occ$end_of_line);
          l := l + 1;
        IFEND;
      UNTIL l > number_of_libraries;


    PROCEND process_libraries_record;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_TEXT_RECORD' ??
?? EJECT ??

    PROCEDURE process_text_record
      (    number_of_bytes: 1 .. osc$max_segment_length;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        text: ^llt$text;


      NEXT text: [1 .. number_of_bytes] IN file;
      IF text = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      hexrep (strng, length, text^.section_ordinal);
      ocp$output ('      ', 'section:', 8, occ$continue);
      ocp$output (' ', strng, length, occ$continue);

      hexrep (strng, length, text^.offset);
      ocp$output ('  ', 'offset:', 7, occ$continue);
      ocp$output (' ', strng, length, occ$end_of_line);

      verify_address (text^.section_ordinal, (text^.offset + number_of_bytes - 1));

      hex_dump (#LOC (text^.byte), number_of_bytes);


    PROCEND process_text_record;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_REPLICATION_RECORD' ??
?? EJECT ??

    PROCEDURE process_replication_record
      (    number_of_bytes: 1 .. osc$max_segment_length;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        replication: ^llt$replication;


      NEXT replication: [1 .. number_of_bytes] IN file;
      IF replication = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      hexrep (strng, length, replication^.section_ordinal);
      ocp$output ('      ', 'section:', 8, occ$continue);
      ocp$output (' ', strng, length, occ$continue);

      hexrep (strng, length, replication^.offset);
      ocp$output ('  ', 'offset:', 7, occ$continue);
      ocp$output (' ', strng, length, occ$end_of_line);

      hexrep (strng, length, replication^.increment);
      ocp$output ('      ', 'increment:', 10, occ$continue);
      IF replication^.increment = 0 THEN
        ocp$output (' ', '********', 8, occ$end_of_line);
        ocp$output (' ', '     ', 5, occ$continue);
        error (' ', 'INVALID INCREMENT:', 18, occ$continue);
        error (' ', strng, length, occ$end_of_line);
      ELSE
        ocp$output (' ', strng, length, occ$continue);
      IFEND;

      hexrep (strng, length, replication^.count);
      ocp$output ('  ', 'count:', 6, occ$continue);
      IF replication^.increment = 0 THEN
        ocp$output (' ', '********', 8, occ$end_of_line);
        error (' ', 'INVALID COUNT:', 14, occ$continue);
        error (' ', strng, length, occ$end_of_line);
      ELSE
        ocp$output (' ', strng, length, occ$end_of_line);
      IFEND;

      verify_address (replication^.section_ordinal, (replication^.offset +
            ((replication^.count - 1) * replication^.increment) + number_of_bytes - 1));

      hex_dump (#LOC (replication^.byte), number_of_bytes);


    PROCEND process_replication_record;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_BIT_INSERTION_RECORD' ??
?? EJECT ??

    PROCEDURE process_bit_insertion_record
      (VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        bit_insertion: ^llt$bit_string_insertion;


      NEXT bit_insertion IN file;
      IF bit_insertion = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      hexrep (strng, length, bit_insertion^.section_ordinal);
      ocp$output ('      ', 'section:', 8, occ$continue);
      ocp$output (' ', strng, length, occ$continue);

      hexrep (strng, length, bit_insertion^.offset);
      ocp$output ('  ', 'offset:', 7, occ$continue);
      ocp$output (' ', strng, length, occ$end_of_line);

      hexrep (strng, length, bit_insertion^.bit_offset);
      ocp$output ('      ', 'bit offset:', 11, occ$continue);
      IF bit_insertion^.bit_offset > UPPERVALUE (bit_insertion^.bit_offset) THEN
        ocp$output (' ', '*', 1, occ$end_of_line);
        ocp$output (' ', '     ', 5, occ$continue);
        error (' ', 'INVALID BIT OFFSET:', 19, occ$continue);
        error (' ', strng, length, occ$end_of_line);
      ELSE
        ocp$output (' ', strng, length, occ$continue);
      IFEND;

      hexrep (strng, length, bit_insertion^.bit_length);
      ocp$output ('  ', 'bit length:', 11, occ$continue);
      IF (bit_insertion^.bit_length < LOWERVALUE (bit_insertion^.bit_length)) OR
            (bit_insertion^.bit_length > UPPERVALUE (bit_insertion^.bit_length)) THEN
        ocp$output (' ', '**', 2, occ$end_of_line);
        error (' ', 'INVALID BIT LENGTH:', 19, occ$continue);
        error (' ', strng, length, occ$end_of_line);
      ELSE
        ocp$output (' ', strng, length, occ$end_of_line);
      IFEND;

      hexrep_full (strng, length, #LOC (bit_insertion^.bit_string), 0, #SIZE (bit_insertion^.bit_string));
      ocp$output ('      ', 'bit string:', 11, occ$continue);
      ocp$output (' ', strng, length, occ$end_of_line);

      verify_address (bit_insertion^.section_ordinal, (bit_insertion^.offset - 1 +
            ((bit_insertion^.bit_offset + bit_insertion^.bit_length + 7) DIV 8)));


    PROCEND process_bit_insertion_record;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_ENTRY_DEFINITION_RECORD' ??
?? EJECT ??

    PROCEDURE process_entry_definition_record
      (VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        entry_definition: ^llt$entry_definition;


      NEXT entry_definition IN file;
      IF entry_definition = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      ocp$output ('      ', 'name:', 5, occ$continue);
      ocp$output (' ', entry_definition^.name, STRLENGTH (entry_definition^.name), occ$continue);

      ocp$output (' ', 'language:', 9, occ$continue);
      output_language (^entry_definition^.language, occ$end_of_line);

      hexrep (strng, length, entry_definition^.section_ordinal);
      ocp$output ('      ', 'section:', 8, occ$continue);
      ocp$output (' ', strng, length, occ$continue);

      hexrep (strng, length, entry_definition^.offset);
      ocp$output ('  ', 'offset:', 7, occ$continue);
      ocp$output (' ', strng, length, occ$continue);

      ocp$output ('  ', 'attr = [', 8, occ$continue);
      IF llc$retain_entry_point IN entry_definition^.attributes THEN
        ocp$output (' ', 'RETAIN', 6, occ$continue);
      IFEND;
      IF llc$gated_entry_point IN entry_definition^.attributes THEN
        ocp$output (' ', 'GATED', 5, occ$continue);
      IFEND;
      IF llc$epa_unused_1 IN entry_definition^.attributes THEN
        ocp$output (' ', 'SPARE1', 6, occ$continue);
      IFEND;
      IF llc$epa_unused_2 IN entry_definition^.attributes THEN
        ocp$output (' ', 'SPARE2', 6, occ$continue);
      IFEND;
      IF llc$epa_unused_3 IN entry_definition^.attributes THEN
        ocp$output (' ', 'SPARE3', 6, occ$continue);
      IFEND;
      IF llc$epa_unused_4 IN entry_definition^.attributes THEN
        ocp$output (' ', 'SPARE4', 6, occ$continue);
      IFEND;
      IF llc$epa_unused_5 IN entry_definition^.attributes THEN
        ocp$output (' ', 'SPARE5', 6, occ$continue);
      IFEND;
      IF llc$epa_unused_6 IN entry_definition^.attributes THEN
        ocp$output (' ', 'SPARE6', 6, occ$continue);
      IFEND;
      ocp$output (' ', ']', 1, occ$end_of_line);

      ocp$output ('      ', 'declaration matching required:', 30, occ$continue);
      ocp$output_boolean (entry_definition^.declaration_matching_required, occ$continue);
      IF entry_definition^.declaration_matching_required THEN
        IF entry_definition^.language = llc$cybil THEN
          ocp$output ('  ', 'object:', 7, occ$continue);
          hexrep_full (strng, length, #LOC (entry_definition^.declaration_matching.object_encryption), 0,
                #SIZE (entry_definition^.declaration_matching.object_encryption));
          ocp$output (' ', strng, length, occ$continue);
          ocp$output ('  ', 'source:', 7, occ$continue);
          hexrep_full (strng, length, #LOC (entry_definition^.declaration_matching.source_encryption), 0,
                #SIZE (entry_definition^.declaration_matching.source_encryption));
          ocp$output (' ', strng, length, occ$continue);
          ocp$output ('', ' ', 1, occ$end_of_line);
        ELSE
          hexrep_full (strng, length, #LOC (entry_definition^.declaration_matching.language_dependent_value),
                0, #SIZE (entry_definition^.declaration_matching.language_dependent_value));
          ocp$output ('  ', 'value:', 6, occ$continue);
          ocp$output (' ', strng, length, occ$end_of_line);
        IFEND;
      ELSE
        ocp$output ('', ' ', 1, occ$end_of_line);
      IFEND;

      verify_address (entry_definition^.section_ordinal, entry_definition^.offset);


    PROCEND process_entry_definition_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_deferred_entry_points', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display the deferred entry point object text record.

    PROCEDURE process_deferred_entry_points
      (    number_of_entry_points: 1 .. llc$max_deferred_entry_points;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        deferred_entry_points: ^llt$deferred_entry_points,
        entry_point_index: 1 .. llc$max_deferred_entry_points;


      NEXT deferred_entry_points: [1 .. number_of_entry_points] IN file;
      IF deferred_entry_points = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      FOR entry_point_index := 1 TO number_of_entry_points DO
        hexrep (strng, length, deferred_entry_points^ [entry_point_index].address.ring);
        ocp$output ('      ring: ', strng, length, occ$continue);

        hexrep (strng, length, deferred_entry_points^ [entry_point_index].address.segment);
        ocp$output ('  segment: ', strng, length, occ$continue);

        hexrep (strng, length, deferred_entry_points^ [entry_point_index].address.offset);
        ocp$output ('  offset: ', strng, length, occ$end_of_line);

        hexrep (strng, length, deferred_entry_points^ [entry_point_index].section_ordinal);
        ocp$output ('      section ordinal: ', strng, length, occ$continue);

        ocp$output ('  ', 'attr = [', 8, occ$continue);
        IF llc$retain_entry_point IN deferred_entry_points^ [entry_point_index].attributes THEN
          ocp$output (' ', 'RETAIN', 6, occ$continue);
        IFEND;
        IF llc$gated_entry_point IN deferred_entry_points^ [entry_point_index].attributes THEN
          ocp$output (' ', 'GATED', 5, occ$continue);
        IFEND;
        IF llc$epa_unused_1 IN deferred_entry_points^ [entry_point_index].attributes THEN
          ocp$output (' ', 'SPARE1', 6, occ$continue);
        IFEND;
        IF llc$epa_unused_2 IN deferred_entry_points^ [entry_point_index].attributes THEN
          ocp$output (' ', 'SPARE2', 6, occ$continue);
        IFEND;
        IF llc$epa_unused_3 IN deferred_entry_points^ [entry_point_index].attributes THEN
          ocp$output (' ', 'SPARE3', 6, occ$continue);
        IFEND;
        IF llc$epa_unused_4 IN deferred_entry_points^ [entry_point_index].attributes THEN
          ocp$output (' ', 'SPARE4', 6, occ$continue);
        IFEND;
        IF llc$epa_unused_5 IN deferred_entry_points^ [entry_point_index].attributes THEN
          ocp$output (' ', 'SPARE5', 6, occ$continue);
        IFEND;
        IF llc$epa_unused_6 IN deferred_entry_points^ [entry_point_index].attributes THEN
          ocp$output (' ', 'SPARE6', 6, occ$continue);
        IFEND;
        ocp$output (' ', ']', 1, occ$end_of_line);

        ocp$output ('      ', 'name:', 5, occ$continue);
        ocp$output (' ', deferred_entry_points^ [entry_point_index].
              name, STRLENGTH (deferred_entry_points^ [entry_point_index].name), occ$continue);

        ocp$output (' ', 'language:', 9, occ$continue);
        output_language (^deferred_entry_points^ [entry_point_index].language, occ$end_of_line);

        ocp$output ('      ', 'declaration matching required:', 30, occ$continue);
        ocp$output_boolean (deferred_entry_points^ [entry_point_index].declaration_matching_required,
              occ$continue);
        IF deferred_entry_points^ [entry_point_index].declaration_matching_required THEN
          IF deferred_entry_points^ [entry_point_index].language = llc$cybil THEN
            ocp$output ('  ', 'object:', 7, occ$continue);
            hexrep_full (strng, length, #LOC (deferred_entry_points^ [entry_point_index].
                  declaration_matching_value.object_encryption),
                  0, #SIZE (deferred_entry_points^ [entry_point_index].declaration_matching_value.
                  object_encryption));
            ocp$output (' ', strng, length, occ$continue);
            ocp$output ('  ', 'source:', 7, occ$continue);
            hexrep_full (strng, length, #LOC (deferred_entry_points^ [entry_point_index].
                  declaration_matching_value.source_encryption),
                  0, #SIZE (deferred_entry_points^ [entry_point_index].declaration_matching_value.
                  source_encryption));
            ocp$output (' ', strng, length, occ$continue);
            ocp$output (' ', 'source declaration matching:', 28, occ$continue);
            ocp$output_boolean (deferred_entry_points^ [entry_point_index].source_type_checking,
                  occ$end_of_line);
          ELSE
            hexrep_full (strng, length, #LOC (deferred_entry_points^ [entry_point_index].
                  declaration_matching_value.language_dependent_value),
                  0, #SIZE (deferred_entry_points^ [entry_point_index].declaration_matching_value.
                  language_dependent_value));
            ocp$output ('  ', 'value:', 6, occ$continue);
            ocp$output (' ', strng, length, occ$end_of_line);
          IFEND;
        ELSE
          ocp$output ('', ' ', 1, occ$end_of_line);
        IFEND;

        hexrep (strng, length, deferred_entry_points^ [entry_point_index].binding_section_address.ring);
        ocp$output ('      binding section address - ring: ', strng, length, occ$continue);

        hexrep (strng, length, deferred_entry_points^ [entry_point_index].binding_section_address.segment);
        ocp$output ('  segment: ', strng, length, occ$continue);

        hexrep (strng, length, deferred_entry_points^ [entry_point_index].binding_section_address.offset);
        ocp$output ('  offset: ', strng, length, occ$end_of_line);

      FOREND;

    PROCEND process_deferred_entry_points;
?? OLDTITLE ??
?? NEWTITLE := 'process_deferred_common_blocks', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display the deferred common block object text record.

    PROCEDURE process_deferred_common_blocks
      (    number_of_common_blocks: 1 .. llc$max_deferred_common_blocks;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        common_block_index: 1 .. llc$max_deferred_common_blocks,
        deferred_common_blocks: ^llt$deferred_common_blocks;


      NEXT deferred_common_blocks: [1 .. number_of_common_blocks] IN file;
      IF deferred_common_blocks = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      FOR common_block_index := 1 TO number_of_common_blocks DO
        ocp$output ('      name: ', deferred_common_blocks^ [common_block_index].
              name, STRLENGTH (deferred_common_blocks^ [common_block_index].name), occ$continue);

        hexrep (strng, length, deferred_common_blocks^ [common_block_index].global_lock);
        ocp$output ('  global lock: ', strng, length, occ$continue);

        hexrep (strng, length, deferred_common_blocks^ [common_block_index].loaded_ring);
        ocp$output ('  loaded ring: ', strng, length, occ$end_of_line);

        hexrep (strng, length, deferred_common_blocks^ [common_block_index].address.ring);
        ocp$output ('      ring: ', strng, length, occ$continue);

        hexrep (strng, length, deferred_common_blocks^ [common_block_index].address.segment);
        ocp$output ('  segment: ', strng, length, occ$continue);

        hexrep (strng, length, deferred_common_blocks^ [common_block_index].address.offset);
        ocp$output ('  offset: ', strng, length, occ$continue);

        hexrep (strng, length, deferred_common_blocks^ [common_block_index].allocation_length);
        ocp$output ('  allocation length: ', strng, length, occ$end_of_line);

        hexrep (strng, length, deferred_common_blocks^ [common_block_index].allocation_alignment);
        ocp$output ('      allocation alignment: ', strng, length, occ$continue);

        hexrep (strng, length, deferred_common_blocks^ [common_block_index].allocation_offset);
        ocp$output ('  allocation offset: ', strng, length, occ$continue);

        ocp$output ('  ', 'attr = [', 8, occ$continue);
        IF llc$read IN deferred_common_blocks^ [common_block_index].access_attributes THEN
          ocp$output (' ', 'R', 1, occ$continue);
        IFEND;
        IF llc$write IN deferred_common_blocks^ [common_block_index].access_attributes THEN
          ocp$output (' ', 'W', 1, occ$continue);
        IFEND;
        IF llc$execute IN deferred_common_blocks^ [common_block_index].access_attributes THEN
          ocp$output (' ', 'X', 1, occ$continue);
        IFEND;
        IF llc$binding IN deferred_common_blocks^ [common_block_index].access_attributes THEN
          ocp$output (' ', 'B', 1, occ$continue);
        IFEND;
        ocp$output (' ', ']', 1, occ$end_of_line);

        ocp$output ('      ', 'cache bypass: ', 14, occ$continue);
        ocp$output_boolean (deferred_common_blocks^ [common_block_index].segment_access_control.cache_bypass,
              occ$continue);

        ocp$output ('  ', 'privileges = [', 14, occ$continue);
        CASE deferred_common_blocks^ [common_block_index].segment_access_control.execute_privilege OF
        = osc$non_executable =
          ocp$output (' ', 'NON EXECUTABLE, ', 16, occ$continue);
        = osc$non_privileged =
          ocp$output (' ', 'NON PRIVILEGED, ', 16, occ$continue);
        = osc$local_privilege =
          ocp$output (' ', 'LOCAL PRIVILEGE, ', 17, occ$continue);
        = osc$global_privilege =
          ocp$output (' ', 'GLOBAL PRIVILEGE, ', 18, occ$continue);
        ELSE
          error (' ', 'INVALID EXECUTE PRIVILEGE', 25, occ$continue);
        CASEND;
        CASE deferred_common_blocks^ [common_block_index].segment_access_control.read_privilege OF
        = osc$non_readable =
          ocp$output (' ', 'NON READABLE, ', 14, occ$continue);
        = osc$read_key_lock_controlled =
          ocp$output (' ', 'READ KEY LOCK CONTROLLED, ', 26, occ$continue);
        = osc$read_uncontrolled =
          ocp$output (' ', 'READ UNCONTROLLED, ', 19, occ$continue);
        = osc$binding_segment =
          ocp$output (' ', 'BINDING SEGMENT, ', 17, occ$continue);
        ELSE
          error (' ', 'INVALID READ PRIVILEGE', 22, occ$continue);
        CASEND;
        CASE deferred_common_blocks^ [common_block_index].segment_access_control.write_privilege OF
        = osc$non_writable =
          ocp$output (' ', 'NON WRITABLE', 12, occ$continue);
        = osc$write_key_lock_controlled =
          ocp$output (' ', 'WRITE KEY LOCK CONTROLLED', 25, occ$continue);
        = osc$write_uncontrolled =
          ocp$output (' ', 'WRITE UNCONTROLLED', 18, occ$continue);
        = osc$wp_reserved =
          ocp$output (' ', 'RESERVED', 8, occ$continue);
        ELSE
          error (' ', 'INVALID WRITE PRIVILEGE', 23, occ$continue);
        CASEND;
        ocp$output (' ', ']', 1, occ$end_of_line);

        ocp$output ('      ', 'extensible: ', 12, occ$continue);
        ocp$output_boolean (deferred_common_blocks^ [common_block_index].extensible, occ$continue);

        ocp$output (' ', 'unallocated common: ', 20, occ$continue);
        ocp$output_boolean (deferred_common_blocks^ [common_block_index].unallocated_common, occ$end_of_line);

        IF deferred_common_blocks^ [common_block_index].unallocated_common THEN
          ocp$output ('      ', 'unallocated common open: ', 25, occ$continue);
          ocp$output_boolean (deferred_common_blocks^ [common_block_index].unallocated_common_open,
                occ$continue);

          hexrep (strng, length, deferred_common_blocks^ [common_block_index].unallocated_common_segment);
          ocp$output ('  unallocated common segment: ', strng, length, occ$end_of_line);

          IF deferred_common_blocks^ [common_block_index].unallocated_common_open THEN
            hexrep (strng, length, deferred_common_blocks^ [common_block_index].unallocated_common_file_id.
                  ordinal);
            ocp$output ('      unallocated common file id: ', strng, length, occ$continue);

            hexrep (strng, length, deferred_common_blocks^ [common_block_index].unallocated_common_file_id.
                  sequence);
            ocp$output (' ', strng, length, occ$end_of_line);
          IFEND;
        IFEND;
      FOREND;

    PROCEND process_deferred_common_blocks;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_RELOCATION_RECORD' ??
?? EJECT ??

    PROCEDURE process_relocation_record
      (    number_of_rel_items: llt$number_of_info_elements;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        relocation: ^llt$relocation,
        i: llt$number_of_info_elements;


      NEXT relocation: [1 .. number_of_rel_items] IN file;
      IF relocation = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      FOR i := 1 TO number_of_rel_items DO
        hexrep (strng, length, relocation^ [i].section_ordinal);
        ocp$output ('0     ', 'section:', 8, occ$continue);
        ocp$output (' ', strng, length, occ$continue);

        hexrep (strng, length, relocation^ [i].offset);
        ocp$output ('  ', 'offset:', 7, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

        verify_address (relocation^ [i].section_ordinal, relocation^ [i].offset);

        hexrep (strng, length, relocation^ [i].relocating_section);
        ocp$output ('      ', 'relocating section:', 19, occ$continue);
        ocp$output (' ', strng, length, occ$continue);

        ocp$output ('  ', 'container:', 10, occ$continue);
        CASE relocation^ [i].container OF
        = llc$two_bytes =
          ocp$output (' ', 'TWO BYTES', 9, occ$end_of_line);
        = llc$three_bytes =
          ocp$output (' ', 'THREE BYTES', 11, occ$end_of_line);
        = llc$four_bytes =
          ocp$output (' ', 'FOUR BYTES', 10, occ$end_of_line);
        = llc$eight_bytes =
          ocp$output (' ', 'EIGHT BYTES', 11, occ$end_of_line);
        = llc$180_d_field =
          ocp$output (' ', '180 D-FIELD', 11, occ$end_of_line);
        = llc$180_q_field =
          ocp$output (' ', '180 Q-FIELD', 11, occ$end_of_line);
        = llc$180_long_d_field =
          ocp$output (' ', '180 LONG D-FIELD', 16, occ$end_of_line);
        ELSE
          ocp$output (' ', '************', 12, occ$end_of_line);
          error (' ', 'INVALID CONTAINER', 17, occ$end_of_line);
        CASEND;

        ocp$output ('      ', 'address:', 8, occ$continue);
        CASE relocation^ [i].address OF
        = llc$byte_positive =
          ocp$output (' ', 'BYTE POSITIVE', 13, occ$end_of_line);
        = llc$two_byte_positive =
          ocp$output (' ', 'TWO BYTE POSITIVE', 17, occ$end_of_line);
        = llc$four_byte_positive =
          ocp$output (' ', 'FOUR BYTE POSITIVE', 18, occ$end_of_line);
        = llc$eight_byte_positive =
          ocp$output (' ', 'EIGHT BYTE POSITIVE', 20, occ$end_of_line);
        = llc$byte_signed =
          ocp$output (' ', 'BYTE SIGNED', 11, occ$end_of_line);
        = llc$two_byte_signed =
          ocp$output (' ', 'TWO BYTE SIGNED', 15, occ$end_of_line);
        = llc$four_byte_signed =
          ocp$output (' ', 'FOUR BYTE SIGNED', 16, occ$end_of_line);
        = llc$eight_byte_signed =
          ocp$output (' ', 'EIGHT BYTE SIGNED', 17, occ$end_of_line);
        ELSE
          ocp$output (' ', '*****************', 17, occ$end_of_line);
          error (' ', 'INVALID ADDRESS', 15, occ$end_of_line);
        CASEND;
      FOREND;


    PROCEND process_relocation_record;
?? OLDTITLE ??
?? NEWTITLE := '  PROC_OBSOLETE_FORMAL_PARA_REC' ??
?? EJECT ??

    PROCEDURE proc_obsolete_formal_param_rec
      (    sequence_length: ost$segment_length;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);

      VAR
        obsolete_formal_parameters: ^llt$obsolete_formal_parameters;

      NEXT obsolete_formal_parameters: [[REP sequence_length OF cell]] IN file;
      IF obsolete_formal_parameters = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      ocp$output ('      ', 'procedure name:', 15, occ$continue);
      ocp$output (' ', obsolete_formal_parameters^.procedure_name,
            STRLENGTH (obsolete_formal_parameters^.procedure_name), occ$end_of_line);

      hex_dump (#LOC (obsolete_formal_parameters^.specification), sequence_length);

    PROCEND proc_obsolete_formal_param_rec;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_FORMAL_PARAMETER_RECORD' ??
?? EJECT ??

    PROCEDURE process_formal_parameter_record
      (    sequence_length: ost$segment_length;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        formal_parameters: ^llt$formal_parameters;


      NEXT formal_parameters: [[REP sequence_length OF cell]] IN file;
      IF formal_parameters = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;
      ocp$output ('      ', 'language: ', 10, occ$continue);
      output_language (^formal_parameters^.language, occ$end_of_line);

      ocp$output ('      ', 'procedure name:', 15, occ$continue);
      ocp$output (' ', formal_parameters^.procedure_name, STRLENGTH (formal_parameters^.procedure_name),
            occ$end_of_line);

      hex_dump (#LOC (formal_parameters^.specification), sequence_length);


    PROCEND process_formal_parameter_record;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_ACTUAL_PARAMETERS' ??
?? EJECT ??

    PROCEDURE process_actual_parameter_record
      (    sequence_length: ost$segment_length;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        actual_parameters: ^llt$actual_parameters;


      NEXT actual_parameters: [[REP sequence_length OF cell]] IN file;
      IF actual_parameters = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      ocp$output ('      ', 'callee name:', 12, occ$continue);
      ocp$output (' ', actual_parameters^.callee_name, STRLENGTH (actual_parameters^.callee_name),
            occ$continue);

      ocp$output ('     ', 'language: ', 10, occ$continue);
      output_language (^actual_parameters^.language, occ$end_of_line);

      ocp$output ('      ', 'line number of call:', 20, occ$continue);
      STRINGREP (strng, length, actual_parameters^.line_number_of_call);
      ocp$output ('', strng, length, occ$end_of_line);

      hex_dump (#LOC (actual_parameters^.specification), sequence_length);


    PROCEND process_actual_parameter_record;
?? OLDTITLE ??
?? NEWTITLE := ' PROCESS_FORM_DEFINITION' ??
?? EJECT ??

    PROCEDURE process_form_definition
      (VAR fatal_error: boolean);

      error (' ', 'FORM DEFINITION FOUND IN OBJECT MODULE', 39, occ$end_of_line);
      fatal_error := TRUE;
      RETURN;

    PROCEND process_form_definition;
?? OLDTITLE ??
?? NEWTITLE := ' PROCESS_APPLICATION_IDENTIFIER' ??
?? EJECT ??

    PROCEDURE process_applic_identifier
      (VAR fatal_error: boolean);


      VAR
        application_identifier: ^llt$application_identifier;


      NEXT application_identifier IN file;
      IF application_identifier = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      IF application_identifier^.name <> osc$null_name THEN
        ocp$output ('      ', 'application identifier:', 24, occ$continue);
        ocp$output (' ', application_identifier^.name, STRLENGTH (application_identifier^.name),
              occ$end_of_line);
      IFEND;


    PROCEND process_applic_identifier;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_ADDRESS_FORMULATION' ??
?? EJECT ??

    PROCEDURE process_address_formulation
      (    number_of_adr_items: 1 .. llc$max_adr_items;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);

      VAR
        address_formulation: ^llt$address_formulation,
        i: 1 .. llc$max_adr_items;

      NEXT address_formulation: [1 .. number_of_adr_items] IN file;
      IF address_formulation = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      hexrep (strng, length, address_formulation^.value_section);
      ocp$output ('      ', 'value section:', 14, occ$continue);
      ocp$output (' ', strng, length, occ$continue);

      hexrep (strng, length, address_formulation^.dest_section);
      ocp$output ('  ', 'dest. section:', 14, occ$continue);
      ocp$output (' ', strng, length, occ$end_of_line);

      FOR i := 1 TO number_of_adr_items DO
        ocp$output ('      ', 'kind:', 5, occ$continue);
        CASE address_formulation^.item [i].kind OF
        = llc$address =
          ocp$output (' ', 'ADDRESS', 7, occ$end_of_line);
        = llc$internal_proc =
          ocp$output (' ', 'INTERNAL PROC', 13, occ$end_of_line);
        = llc$short_address =
          ocp$output (' ', 'SHORT ADDRESS', 13, occ$end_of_line);
        = llc$external_proc =
          ocp$output (' ', 'EXTERNAL PROC', 13, occ$end_of_line);
        ELSE
          ocp$output (' ', '**********************', 22, occ$end_of_line);
          error (' ', 'INVALID ADDRESS KIND', 20, occ$end_of_line);
        CASEND;

        hexrep (strng, length, address_formulation^.item [i].value_offset);
        ocp$output ('      ', 'value offset:', 13, occ$continue);
        ocp$output (' ', strng, length, occ$continue);

        hexrep (strng, length, address_formulation^.item [i].dest_offset);
        ocp$output ('  ', 'dest. offset:', 13, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

        verify_address (address_formulation^.value_section, 0);
        verify_address (address_formulation^.dest_section, address_formulation^.item [i].dest_offset);
      FOREND;

    PROCEND process_address_formulation;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_EXTERNAL_LINKAGE' ??
?? EJECT ??

    PROCEDURE process_external_linkage
      (    number_of_ext_items: 1 .. llc$max_ext_items;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        external: ^llt$external_linkage,
        i: 1 .. llc$max_ext_items;


      NEXT external: [1 .. number_of_ext_items] IN file;
      IF external = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      ocp$output ('      ', 'name:', 5, occ$continue);
      ocp$output (' ', external^.name, STRLENGTH (external^.name), occ$continue);

      ocp$output ('  ', 'language:', 9, occ$continue);
      output_language (^external^.language, occ$end_of_line);

      ocp$output ('      ', 'declaration matching required:', 30, occ$continue);
      ocp$output_boolean (external^.declaration_matching_required, occ$continue);
      IF external^.declaration_matching_required THEN
        IF external^.language = llc$cybil THEN
          ocp$output (' ', 'object:', 7, occ$continue);
          hexrep_full (strng, length, #LOC (external^.declaration_matching.object_encryption),
                0, #SIZE (external^.declaration_matching.object_encryption));
          ocp$output (' ', strng, length, occ$continue);
          ocp$output (' ', 'source:', 7, occ$continue);
          hexrep_full (strng, length, #LOC (external^.declaration_matching.source_encryption),
                0, #SIZE (external^.declaration_matching.source_encryption));
          ocp$output (' ', strng, length, occ$continue);
          ocp$output ('', ' ', 1, occ$end_of_line);
        ELSE
          hexrep_full (strng, length, #LOC (external^.declaration_matching.language_dependent_value), 0,
                #SIZE (external^.declaration_matching.language_dependent_value));
          ocp$output (' ', 'value = ', 8, occ$continue);
          ocp$output (' ', strng, length, occ$end_of_line);
        IFEND;
      ELSE
        ocp$output ('', ' ', 1, occ$end_of_line);
      IFEND;

      FOR i := 1 TO number_of_ext_items DO
        hexrep (strng, length, external^.item [i].section_ordinal);
        ocp$output ('      ', 'section:', 8, occ$continue);
        ocp$output (' ', strng, length, occ$continue);

        hexrep (strng, length, external^.item [i].offset);
        ocp$output ('  ', 'offset:', 7, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

        verify_address (external^.item [i].section_ordinal, external^.item [i].offset);

        ocp$output ('      ', 'kind:', 5, occ$continue);
        CASE external^.item [i].kind OF
        = llc$address =
          ocp$output (' ', 'ADDRESS', 7, occ$end_of_line);
        = llc$internal_proc =
          ocp$output (' ', 'INTERNAL PROC', 13, occ$end_of_line);
        = llc$short_address =
          ocp$output (' ', 'SHORT ADDRESS', 13, occ$end_of_line);
        = llc$external_proc =
          ocp$output (' ', 'EXTERNAL PROC', 13, occ$end_of_line);
        = llc$address_addition =
          ocp$output (' ', 'ADDRESS ADDITION', 17, occ$continue);
          hexrep (strng, length, external^.item [i].offset_operand);
          ocp$output ('  ', '  offset operand:', 17, occ$continue);
          ocp$output (' ', strng, length, occ$end_of_line);
        = llc$address_subtraction =
          ocp$output (' ', 'ADDRESS SUBTRACTION', 20, occ$continue);
          hexrep (strng, length, external^.item [i].offset_operand);
          ocp$output ('  ', '  offset operand:', 17, occ$continue);
          ocp$output (' ', strng, length, occ$end_of_line);
        ELSE
          ocp$output (' ', '**********************', 22, occ$end_of_line);
          error (' ', 'INVALID ADDRESS KIND', 20, occ$end_of_line);
        CASEND;

      FOREND;


    PROCEND process_external_linkage;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_BINDING_TEMPLATE_RECORD' ??
?? EJECT ??

    PROCEDURE process_binding_template_record
      (VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        binding_template: ^llt$binding_template;


      NEXT binding_template IN file;
      IF binding_template = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      hexrep (strng, length, binding_template^.binding_offset);
      ocp$output ('      ', 'binding offset:', 15, occ$continue);
      ocp$output (' ', strng, length, occ$continue);

      ocp$output ('  ', 'kind:', 5, occ$continue);
      CASE binding_template^.kind OF
      = llc$current_module =
        ocp$output (' ', 'CURRENT MODULE', 14, occ$end_of_line);

        hexrep (strng, length, binding_template^.section_ordinal);
        ocp$output ('      ', 'section:', 8, occ$continue);
        ocp$output (' ', strng, length, occ$continue);

        hexrep (strng, length, binding_template^.offset);
        ocp$output ('  ', 'offset:', 7, occ$continue);
        ocp$output (' ', strng, length, occ$continue);

        ocp$output ('  ', 'address:', 8, occ$continue);
        CASE binding_template^.internal_address OF
        = llc$address =
          ocp$output (' ', 'ADDRESS', 7, occ$end_of_line);
        = llc$internal_proc =
          ocp$output (' ', 'INTERNAL PROC', 13, occ$end_of_line);
        = llc$short_address =
          ocp$output (' ', 'SHORT ADDRESS', 13, occ$end_of_line);
        = llc$external_proc =
          ocp$output (' ', 'EXTERNAL PROC', 13, occ$end_of_line);
        ELSE
          ocp$output (' ', '**********************', 22, occ$end_of_line);
          error (' ', 'INVALID ADDRESS KIND', 20, occ$end_of_line);
        CASEND;

        verify_address (binding_template^.section_ordinal, binding_template^.offset);

      = llc$external_reference =
        ocp$output (' ', 'EXTERNAL REFERENCE', 18, occ$end_of_line);

        ocp$output ('      ', 'name:', 5, occ$continue);
        ocp$output (' ', binding_template^.name, STRLENGTH (binding_template^.name), occ$continue);

        ocp$output ('  ', 'address:', 8, occ$continue);
        CASE binding_template^.address OF
        = llc$address =
          ocp$output ('  ', 'ADDRESS', 7, occ$end_of_line);
        = llc$internal_proc =
          ocp$output ('  ', 'INTERNAL PROC', 13, occ$end_of_line);
        = llc$short_address =
          ocp$output ('  ', 'SHORT ADDRESS', 13, occ$end_of_line);
        = llc$external_proc =
          ocp$output ('  ', 'EXTERNAL PROC', 13, occ$end_of_line);
        = llc$address_addition =
          ocp$output ('  ', 'ADDRESS ADDITION', 17, occ$end_of_line);
        = llc$address_subtraction =
          ocp$output ('  ', 'ADDRESS SUBTRACTION', 20, occ$end_of_line);
        ELSE
          ocp$output (' ', '**********************', 22, occ$end_of_line);
          error (' ', 'INVALID ADDRESS KIND', 20, occ$end_of_line);
        CASEND;

      ELSE
        ocp$output (' ', '******************', 18, occ$end_of_line);
        error (' ', 'INVALID TEMPLATE KIND', 19, occ$end_of_line);
      CASEND;


    PROCEND process_binding_template_record;
?? OLDTITLE ??
?? NEWTITLE := 'PROCESS_68000_ABSOLUTE', EJECT ??

    PROCEDURE process_68000_absolute
      (    number_of_68000_bytes: 1 .. llc$maximum_68000_address;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        m68000_absolute: ^llt$68000_absolute;


      NEXT m68000_absolute: [[REP number_of_68000_bytes OF cell]] IN file;
      IF m68000_absolute = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      hexrep (strng, length, m68000_absolute^.load_address);
      ocp$output ('      load_address: ', strng, length, occ$continue);

      hexrep (strng, length, m68000_absolute^.transfer_address);
      ocp$output ('  transfer_address: ', strng, length, occ$end_of_line);

      hex_dump (#LOC (m68000_absolute^.text), number_of_68000_bytes);


    PROCEND process_68000_absolute;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_TRANSFER_SYMBOL_RECORD' ??
?? EJECT ??

    PROCEDURE process_transfer_symbol_record
      (VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        transfer_symbol: ^llt$transfer_symbol;


      NEXT transfer_symbol IN file;
      IF transfer_symbol = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      IFEND;

      IF transfer_symbol^.name <> osc$null_name THEN
        ocp$output ('      ', 'starting procedure:', 19, occ$continue);
        ocp$output (' ', transfer_symbol^.name, STRLENGTH (transfer_symbol^.name), occ$end_of_line);
      IFEND;


    PROCEND process_transfer_symbol_record;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_CPU_MODULE' ??
?? EJECT ??

    PROCEDURE process_cpu_module
      (VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);


      VAR
        end_of_file: boolean,
        record_kind: llt$object_record_kind,
        size: integer,
        s: llt$section_ordinal;


      ALLOCATE module_info.section_definition: [0 .. module_info.greatest_section_ordinal];
      IF module_info.section_definition = NIL THEN
        error (' ', 'INTERNAL PROBLEM 6 - no space in heap', 37, occ$end_of_line);
        fatal_error := TRUE;
        RETURN;
      ELSE
        FOR s := 0 TO module_info.greatest_section_ordinal DO
          module_info.section_definition^ [s] := NIL;

        FOREND;
      IFEND;

      REPEAT
        process_object_text_descriptor (file, fatal_error, end_of_file, record_kind, size);
        IF NOT fatal_error THEN
          IF end_of_file THEN
            error (' ', premature_end_of_file, 33, occ$end_of_line);
            fatal_error := TRUE;
          ELSE
            CASE record_kind OF
            = llc$identification =
              error (' ', 'DUPLICATE IDENTIFICATION RECORD ENCOUNTERED', 43, occ$end_of_line);
              fatal_error := TRUE;
            = llc$libraries =
              process_libraries_record (size, file, fatal_error);
            = llc$section_definition, llc$unallocated_common_block =
              process_section_definition (file, fatal_error);
            = llc$allotted_section_definition =
              process_allotted_section_def (size, file, fatal_error);
            = llc$segment_definition =
              process_segment_definition (file, fatal_error);
            = llc$allotted_segment_definition =

{ DIV and MOD is to extract allotted_segment_length and allotted_segment

              process_allotted_segment_def ((size DIV 100000000(16)), size MOD 100000000(16), file,
                    fatal_error);
            = llc$obsolete_segment_definition =
              process_obsolete_seg_def (file, fatal_error);
            = llc$obsolete_allotted_seg_def =

{ DIV and MOD is to extract allotted_segment_length and allotted_segment

              process_obs_allotted_seg_def ((size DIV 100000000(16)), size MOD 100000000(16), file,
                    fatal_error);
            = llc$text =
              process_text_record (size, file, fatal_error);
            = llc$replication =
              process_replication_record (size, file, fatal_error);
            = llc$bit_string_insertion =
              process_bit_insertion_record (file, fatal_error);
            = llc$entry_definition =
              process_entry_definition_record (file, fatal_error);
            = llc$deferred_entry_points =
              process_deferred_entry_points (size, file, fatal_error);
            = llc$deferred_common_blocks =
              process_deferred_common_blocks (size, file, fatal_error);
            = llc$relocation =
              process_relocation_record (size, file, fatal_error);
            = llc$obsolete_formal_parameters =
              proc_obsolete_formal_param_rec (size, file, fatal_error);
            = llc$formal_parameters =
              process_formal_parameter_record (size, file, fatal_error);
            = llc$actual_parameters =
              process_actual_parameter_record (size, file, fatal_error);
            = llc$obsolete_line_table =
              process_obsolete_line_table (size, file, fatal_error);
            = llc$cybil_symbol_table_fragment =
              process_cybil_symbol_table (size, file, fatal_error);
            = llc$line_table =
              process_line_table (size, file, fatal_error);
            = llc$symbol_table =
              process_symbol_table (size, file, fatal_error);
            = llc$supplemental_debug_tables =
              process_supplemental_dtables (size, file, fatal_error);
            = llc$form_definition =
              process_form_definition (fatal_error);
            = llc$application_identifier =
              process_applic_identifier (fatal_error);
            = llc$address_formulation =
              process_address_formulation (size, file, fatal_error);
            = llc$external_linkage =
              process_external_linkage (size, file, fatal_error);
            = llc$binding_template =
              process_binding_template_record (file, fatal_error);
            = llc$68000_absolute =
              process_68000_absolute (size, file, fatal_error);
            = llc$transfer_symbol =
              process_transfer_symbol_record (file, fatal_error);
            ELSE
              error (' ', 'INVALID CPU RECORD KIND', 23, occ$end_of_line);
              fatal_error := TRUE;
            CASEND;
          IFEND;
        IFEND;
      UNTIL fatal_error OR (record_kind = llc$transfer_symbol);


    PROCEND process_cpu_module;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_IOU_MODULE' ??
?? EJECT ??

    PROCEDURE process_iou_module
      (VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);

?? NEWTITLE := '    PROCESS_PPU_ABSOLUTE_RECORD' ??
?? EJECT ??

      PROCEDURE process_ppu_absolute_record
        (    number_of_words: llt$ppu_address;
         VAR file: ^SEQ ( * );
         VAR fatal_error: boolean);


        VAR
          ppu_absolute: ^llt$ppu_absolute;


        NEXT ppu_absolute: [0 .. number_of_words - 1] IN file;
        IF ppu_absolute = NIL THEN
          error (' ', premature_end_of_file, 33, occ$end_of_line);
          fatal_error := TRUE;
          RETURN;
        IFEND;

        ocp$output ('      ', 'executes on any ppu:', 20, occ$continue);
        ocp$output_boolean (ppu_absolute^.executes_on_any_ppu, occ$continue);

        hexrep (strng, length, ppu_absolute^.ppu_number);
        ocp$output ('  ', 'ppu number:', 11, occ$continue);
        IF ppu_absolute^.ppu_number <= llc$max_ppu_number THEN
          ocp$output (' ', strng, length, occ$end_of_line);
        ELSE
          ocp$output (' ', '***', 3, occ$end_of_line);
          error (' ', 'INVALID PPU NUMBER:', 19, occ$continue);
          error (' ', strng, length, occ$end_of_line);
        IFEND;

        hexrep (strng, length, ppu_absolute^.load_address);
        ocp$output ('      ', 'load address:', 13, occ$continue);
        ocp$output (' ', strng, length, occ$continue);

        hexrep (strng, length, ppu_absolute^.entry_address);
        ocp$output ('  ', 'entry address:', 14, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

        IF ppu_absolute^.load_address > llc$max_ppu_size THEN
          error (' ', 'INVALID LOAD ADDRESS', 20, occ$end_of_line);
        IFEND;
        IF ppu_absolute^.entry_address > llc$max_ppu_size THEN
          error (' ', 'INVALID ENTRY ADDRESS', 21, occ$end_of_line);
        IFEND;

        hex_dump (#LOC (ppu_absolute^.text), (number_of_words * 2));


      PROCEND process_ppu_absolute_record;
?? OLDTITLE ??
?? EJECT ??


      VAR
        end_of_file: boolean,
        record_kind: llt$object_record_kind,
        size: integer;


      process_object_text_descriptor (file, fatal_error, end_of_file, record_kind, size);

      IF NOT fatal_error THEN
        IF end_of_file THEN
          error (' ', premature_end_of_file, 33, occ$end_of_line);
          fatal_error := TRUE;
        ELSE
          IF record_kind = llc$ppu_absolute THEN
            process_ppu_absolute_record (size, file, fatal_error);
          ELSE
            error (' ', 'INVALID IOU RECORD KIND', 23, occ$end_of_line);
            fatal_error := TRUE;
          IFEND;
        IFEND;
      IFEND;


    PROCEND process_iou_module;
?? OLDTITLE ??
?? NEWTITLE := 'process_object_file' ??
?? EJECT ??

    PROCEDURE process_object_file
      (VAR file: ^SEQ ( * ));


      VAR
        fatal_error: [STATIC] boolean := FALSE,
        end_of_file: boolean,

        record_kind: llt$object_record_kind,
        size: integer,
        module_kind: llt$module_kind;


      REPEAT
        module_info.section_definition := NIL;
        record_number := 1;
        ocp$output ('1', '  ', 2, occ$end_of_line);

        process_object_text_descriptor (file, fatal_error, end_of_file, record_kind, size);

        IF NOT (end_of_file OR fatal_error) THEN
          IF record_kind <> llc$identification THEN
            error (' ', 'IDENTIFICATION RECORD MUST BE FIRST RECORD OF MODULE', 52, occ$end_of_line);
            fatal_error := TRUE;
          ELSE
            process_identification_record (file, fatal_error, module_kind);
          IFEND;

          IF NOT fatal_error THEN
            CASE module_kind OF
            = llc$mi_virtual_state, llc$vector_virtual_state, llc$motorola_68000, llc$motorola_68000_absolute,
                  llc$vector_extended_state =
              process_cpu_module (file, fatal_error);
            = llc$iou =
              process_iou_module (file, fatal_error);
            ELSE
              error (' ', 'INTERNAL PROBLEM 2', 18, occ$end_of_line);
              fatal_error := TRUE;
            CASEND;
          IFEND;
        IFEND;

        IF module_info.section_definition <> NIL THEN
          FREE module_info.section_definition;
        IFEND;
      UNTIL end_of_file OR fatal_error;


    PROCEND process_object_file;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_OBJECT_LIBRARY' ??
?? EJECT ??

    PROCEDURE process_object_library
      (VAR file: ^SEQ ( * ));

?? NEWTITLE := '    PROCESS_MODULE_DICTIONARY' ??
?? EJECT ??

      PROCEDURE process_module_dictionary
        (    number_of_modules: 0 .. llc$max_modules_in_library;
             module_dictionary: ^llt$module_dictionary);


        VAR
          i: 0 .. llc$max_modules_in_library;


        ocp$output ('-', 'module dictionary', 17, occ$end_of_line);
        ocp$output (' ', '~~~~~~~~~~~~~~~~~', 17, occ$end_of_line);

        IF number_of_modules = 0 THEN
          ocp$output ('0', '*** NO MODULES ON LIBRARY ***', 29, occ$end_of_line);
        ELSE
          FOR i := 1 TO number_of_modules DO
            ocp$output ('0', 'name:', 5, occ$continue);
            ocp$output (' ', module_dictionary^ [i].name, STRLENGTH (module_dictionary^ [i].name),
                  occ$end_of_line);

            ocp$output (' ', 'kind:', 5, occ$continue);
            CASE module_dictionary^ [i].kind OF
            = llc$load_module =
              ocp$output (' ', 'LOAD MODULE', 11, occ$end_of_line);
            = llc$ppu_object_module =
              ocp$output (' ', 'PPU OBJECT MODULE', 17, occ$end_of_line);
            = llc$program_description =
              ocp$output (' ', 'PROGRAM DESCRIPTION', 19, occ$end_of_line);
            = llc$applic_program_description =
              ocp$output (' ', 'APPLICATION PROGRAM DESCRIPTION', 31, occ$end_of_line);
            = llc$command_procedure =
              ocp$output (' ', 'COMMAND PROCEDURE', 17, occ$end_of_line);
            = llc$applic_command_procedure =
              ocp$output (' ', 'APPLICATION COMMAND PROCEDURE', 29, occ$end_of_line);
            = llc$command_description =
              ocp$output (' ', 'COMMAND DESCRIPTION', 19, occ$end_of_line);
            = llc$applic_command_description =
              ocp$output (' ', 'APPLICATION COMMAND DESCRIPTION', 31, occ$end_of_line);
            = llc$function_procedure =
              ocp$output (' ', 'FUNCTION PROCEDURE', 18, occ$end_of_line);
            = llc$function_description =
              ocp$output (' ', 'FUNCTION DESCRIPTION', 20, occ$end_of_line);
            = llc$message_module =
              ocp$output (' ', 'MESSAGE MODULE', 14, occ$end_of_line);
            = llc$panel_module =
              ocp$output (' ', 'FORM MODULE', 11, occ$end_of_line);

            ELSE
              ocp$output (' ', '*******************', 19, occ$end_of_line);
              ocp$output ('', ' ', 1, occ$continue);

              error (' ', 'INVALID KIND', 12, occ$end_of_line);
            CASEND;

          FOREND;
        IFEND;


      PROCEND process_module_dictionary;
?? OLDTITLE ??
?? NEWTITLE := '    PROCESS_ENTRY_POINT_DICTIONARY' ??
?? EJECT ??

      PROCEDURE process_entry_point_dictionary
        (    number_of_entry_points: 0 .. llc$max_entry_points_in_library;
             entry_point_dictionary: ^llt$entry_point_dictionary);


        VAR
          i: 0 .. llc$max_entry_points_in_library;


        ocp$output ('1', 'entry point dictionary', 22, occ$end_of_line);
        ocp$output (' ', '~~~~~~~~~~~~~~~~~~~~~~', 22, occ$end_of_line);

        IF number_of_entry_points = 0 THEN
          ocp$output ('0', ' * NO ENTRY POINTS *', 20, occ$end_of_line);
        ELSE
          FOR i := 1 TO number_of_entry_points DO
            ocp$output ('0', 'name:', 5, occ$continue);
            ocp$output (' ', entry_point_dictionary^ [i].name, STRLENGTH (entry_point_dictionary^ [i].name),
                  occ$end_of_line);

            ocp$output (' ', 'scope:', 6, occ$continue);
            CASE entry_point_dictionary^ [i].kind OF
            = llc$entry_point =
              ocp$output (' ', 'XDCL', 4, occ$continue);
            = llc$gate =
              ocp$output (' ', 'GATE', 4, occ$continue);
            ELSE
              ocp$output (' ', '***********', 11, occ$end_of_line);
              error (' ', 'INVALID KIND', 12, occ$end_of_line);
            CASEND;

            ocp$output ('  ', 'module kind:', 12, occ$continue);
            CASE entry_point_dictionary^ [i].module_kind OF
            = llc$load_module =
              ocp$output (' ', 'LOAD MODULE', 11, occ$end_of_line);
            = llc$program_description =
              ocp$output (' ', 'PROGRAM DESCRIPTION', 19, occ$end_of_line);
            = llc$command_procedure =
              ocp$output (' ', 'COMMAND PROCEDURE', 17, occ$end_of_line);

            ELSE
              ocp$output (' ', '*******************', 19, occ$end_of_line);

              error (' ', 'INVALID MODULE KIND', 19, occ$end_of_line);
            CASEND;
          FOREND;
        IFEND;

      PROCEND process_entry_point_dictionary;
?? OLDTITLE ??
?? NEWTITLE := '    PROCESS_COMMAND_DICTIONARY' ??
?? EJECT ??

      PROCEDURE process_command_dictionary
        (    number_of_commands: 0 .. llc$max_commands_in_library;
             command_dictionary: ^llt$command_dictionary);


        VAR
          i: 0 .. llc$max_commands_in_library;


        ocp$output ('-', 'command dictionary', 18, occ$end_of_line);
        ocp$output (' ', '~~~~~~~~~~~~~~~~~~', 18, occ$end_of_line);

        IF number_of_commands = 0 THEN
          ocp$output ('0', '*** NO COMMANDS ON LIBRARY ***', 30, occ$end_of_line);
        ELSE
          FOR i := 1 TO number_of_commands DO
            ocp$output ('0', 'name:', 5, occ$continue);
            ocp$output (' ', command_dictionary^ [i].name, STRLENGTH (command_dictionary^ [i].name),
                  occ$end_of_line);

            ocp$output (' ', 'class:', 6, occ$continue);
            CASE command_dictionary^ [i].class OF
            = clc$nominal_entry =
              ocp$output (' ', 'NOMINAL', 7, occ$end_of_line);
            = clc$alias_entry =
              ocp$output (' ', 'ALIAS', 5, occ$end_of_line);
            = clc$abbreviation_entry =
              ocp$output (' ', 'ABBREVIATION', 12, occ$end_of_line);

            ELSE
              ocp$output (' ', '*******************', 19, occ$end_of_line);
              ocp$output ('', ' ', 1, occ$continue);

              error (' ', 'INVALID CLASS', 13, occ$end_of_line);
            CASEND;


            ocp$output (' ', 'availability:', 13, occ$continue);
            CASE command_dictionary^ [i].availability OF
            = clc$normal_usage_entry =
              ocp$output (' ', 'NORMAL_USAGE', 12, occ$end_of_line);
            = clc$advanced_usage_entry =
              ocp$output (' ', 'ADVANCED_USAGE', 14, occ$end_of_line);
            = clc$hidden_entry =
              ocp$output (' ', 'HIDDEN', 6, occ$end_of_line);

            ELSE
              ocp$output (' ', '*******************', 19, occ$end_of_line);
              ocp$output ('', ' ', 1, occ$continue);

              error (' ', 'INVALID AVAILABILITY', 20, occ$end_of_line);
            CASEND;

            STRINGREP (strng, length, command_dictionary^ [i].ordinal);
            ocp$output (' ', 'ordinal:', 8, occ$continue);
            ocp$output (' ', strng, length, occ$end_of_line);

            ocp$output (' ', 'scope:', 6, occ$continue);
            CASE command_dictionary^ [i].kind OF
            = llc$entry_point =
              ocp$output (' ', 'XDCL', 4, occ$end_of_line);
            = llc$gate =
              ocp$output (' ', 'GATE', 4, occ$end_of_line);
            = llc$local_to_library =
              ocp$output (' ', 'LOCAL', 5, occ$end_of_line);

            ELSE
              ocp$output (' ', '*******************', 19, occ$end_of_line);
              ocp$output ('', ' ', 1, occ$continue);

              error (' ', 'INVALID SCOPE', 13, occ$end_of_line);
            CASEND;

            ocp$output (' ', 'log option:', 11, occ$continue);
            CASE command_dictionary^ [i].log_option OF
            = clc$automatically_log =
              ocp$output (' ', 'AUTOMATIC', 9, occ$end_of_line);
            = clc$manually_log =
              ocp$output (' ', 'MANUAL', 6, occ$end_of_line);

            ELSE
              ocp$output (' ', '*******************', 19, occ$end_of_line);
              ocp$output ('', ' ', 1, occ$continue);

              error (' ', 'INVALID LOG OPTION', 18, occ$end_of_line);
            CASEND;

            ocp$output (' ', 'module kind:', 12, occ$continue);
            CASE command_dictionary^ [i].module_kind OF
            = llc$command_procedure =
              ocp$output (' ', 'COMMAND PROCEDURE', 17, occ$end_of_line);
            = llc$applic_command_procedure =
              ocp$output (' ', 'APPLICATION COMMAND PROCEDURE', 29, occ$end_of_line);
            = llc$command_description =
              ocp$output (' ', 'COMMAND DESCRIPTION', 19, occ$end_of_line);
            = llc$applic_command_description =
              ocp$output (' ', 'APPLICATION COMMAND DESCRIPTION', 31, occ$end_of_line);
            = llc$program_description =
              ocp$output (' ', 'PROGRAM DESCRIPTION', 19, occ$end_of_line);
            = llc$applic_program_description =
              ocp$output (' ', 'APPLICATION PROGRAM DESCRIPTION', 31, occ$end_of_line);
            = llc$load_module =
              ocp$output (' ', 'LOAD MODULE', 11, occ$end_of_line);

            ELSE
              ocp$output (' ', '*******************', 19, occ$end_of_line);
              ocp$output ('', ' ', 1, occ$continue);

              error (' ', 'INVALID MODULE KIND', 19, occ$end_of_line);
            CASEND;

          FOREND;
        IFEND;


      PROCEND process_command_dictionary;
?? OLDTITLE ??
?? NEWTITLE := '    PROCESS_FUNCTION_DICTIONARY' ??
?? EJECT ??

      PROCEDURE process_function_dictionary
        (    number_of_functions: 0 .. llc$max_functions_in_library;
             function_dictionary: ^llt$function_dictionary);


        VAR
          i: 0 .. llc$max_functions_in_library;


        ocp$output ('-', 'function dictionary', 19, occ$end_of_line);
        ocp$output (' ', '~~~~~~~~~~~~~~~~~~~', 19, occ$end_of_line);

        IF number_of_functions = 0 THEN
          ocp$output ('0', '*** NO FUNCTIONS ON LIBRARY ***', 31, occ$end_of_line);
        ELSE
          FOR i := 1 TO number_of_functions DO
            ocp$output ('0', 'name:', 5, occ$continue);
            ocp$output (' ', function_dictionary^ [i].name, STRLENGTH (function_dictionary^ [i].name),
                  occ$end_of_line);

            ocp$output (' ', 'class:', 6, occ$continue);
            CASE function_dictionary^ [i].class OF
            = clc$nominal_entry =
              ocp$output (' ', 'NOMINAL', 7, occ$end_of_line);
            = clc$alias_entry =
              ocp$output (' ', 'ALIAS', 5, occ$end_of_line);
            = clc$abbreviation_entry =
              ocp$output (' ', 'ABBREVIATION', 12, occ$end_of_line);

            ELSE
              ocp$output (' ', '*******************', 19, occ$end_of_line);
              ocp$output ('', ' ', 1, occ$continue);

              error (' ', 'INVALID CLASS', 13, occ$end_of_line);
            CASEND;

            ocp$output (' ', 'availability:', 13, occ$continue);
            CASE function_dictionary^ [i].availability OF
            = clc$normal_usage_entry =
              ocp$output (' ', 'NORMAL_USAGE', 12, occ$end_of_line);
            = clc$advanced_usage_entry =
              ocp$output (' ', 'ADVANCED_USAGE', 14, occ$end_of_line);
            = clc$hidden_entry =
              ocp$output (' ', 'HIDDEN', 6, occ$end_of_line);

            ELSE
              ocp$output (' ', '*******************', 19, occ$end_of_line);
              ocp$output ('', ' ', 1, occ$continue);

              error (' ', 'INVALID AVAILABILITY', 20, occ$end_of_line);
            CASEND;

            STRINGREP (strng, length, function_dictionary^ [i].ordinal);
            ocp$output (' ', 'ordinal:', 8, occ$continue);
            ocp$output (' ', strng, length, occ$end_of_line);

            ocp$output (' ', 'scope:', 6, occ$continue);
            CASE function_dictionary^ [i].kind OF
            = llc$entry_point =
              ocp$output (' ', 'XDCL', 4, occ$end_of_line);
            = llc$gate =
              ocp$output (' ', 'GATE', 4, occ$end_of_line);
            = llc$local_to_library =
              ocp$output (' ', 'LOCAL', 5, occ$end_of_line);

            ELSE
              ocp$output (' ', '*******************', 19, occ$end_of_line);
              ocp$output ('', ' ', 1, occ$continue);

              error (' ', 'INVALID SCOPE', 13, occ$end_of_line);
            CASEND;

            ocp$output (' ', 'module kind:', 12, occ$continue);
            CASE function_dictionary^ [i].module_kind OF
            = llc$function_procedure =
              ocp$output (' ', 'FUNCTION PROCEDURE', 18, occ$end_of_line);
            = llc$function_description =
              ocp$output (' ', 'FUNCTION DESCRIPTION', 20, occ$end_of_line);

            ELSE
              ocp$output (' ', '*******************', 19, occ$end_of_line);
              ocp$output ('', ' ', 1, occ$continue);

              error (' ', 'INVALID MODULE KIND', 19, occ$end_of_line);
            CASEND;

          FOREND;
        IFEND;


      PROCEND process_function_dictionary;
?? OLDTITLE ??
?? NEWTITLE := '    PROCESS_HELP_MODULE_DICTIONARY' ??
?? EJECT ??

      PROCEDURE process_help_module_dictionary
        (    number_of_help_modules: 0 .. llc$max_help_modules_in_library;
             help_module_dictionary: ^llt$help_module_dictionary);


        VAR
          i: 0 .. llc$max_help_modules_in_library;


        ocp$output ('-', 'help module dictionary', 22, occ$end_of_line);
        ocp$output (' ', '~~~~~~~~~~~~~~~~~~~~~~', 22, occ$end_of_line);

        IF number_of_help_modules = 0 THEN
          ocp$output ('0', '*** NO HELP MODULES ON LIBRARY ***', 34, occ$end_of_line);
        ELSE
          FOR i := 1 TO number_of_help_modules DO
            ocp$output ('0', 'name:', 5, occ$continue);
            ocp$output (' ', help_module_dictionary^ [i].name, STRLENGTH (help_module_dictionary^ [i].name),
                  occ$end_of_line);
            ocp$output (' ', 'language:', 9, occ$continue);
            ocp$output (' ', help_module_dictionary^ [i].language,
                  STRLENGTH (help_module_dictionary^ [i].name), occ$end_of_line);
          FOREND;
        IFEND;


      PROCEND process_help_module_dictionary;
?? OLDTITLE ??
?? NEWTITLE := '    PROCESS_MESSAGE_MODULE_DICTIONARY' ??
?? EJECT ??

      PROCEDURE process_msg_module_dictionary
        (    number_of_message_modules: 0 .. llc$max_message_modules_in_lib;
             message_module_dictionary: ^llt$message_module_dictionary);


        VAR
          i: 0 .. llc$max_message_modules_in_lib;


        ocp$output ('-', 'message module dictionary', 25, occ$end_of_line);
        ocp$output (' ', '~~~~~~~~~~~~~~~~~~~~~~~~~', 25, occ$end_of_line);

        IF number_of_message_modules = 0 THEN
          ocp$output ('0', '*** NO MESSAGE MODULES ON LIBRARY ***', 37, occ$end_of_line);
        ELSE
          FOR i := 1 TO number_of_message_modules DO
            ocp$output ('0', 'name:', 5, occ$continue);
            ocp$output (' ', message_module_dictionary^ [i].name,
                  STRLENGTH (message_module_dictionary^ [i].name), occ$end_of_line);
            ocp$output (' ', 'language:', 9, occ$continue);
            ocp$output (' ', message_module_dictionary^ [i].language,
                  STRLENGTH (message_module_dictionary^ [i].language), occ$end_of_line);

            STRINGREP (strng, length, message_module_dictionary^ [i].lowest_condition_code);
            ocp$output (' ', 'lowest condition code:', 22, occ$continue);
            ocp$output (' ', strng, length, occ$end_of_line);

            STRINGREP (strng, length, message_module_dictionary^ [i].highest_condition_code);
            ocp$output (' ', 'highest condition code:', 22, occ$continue);
            ocp$output (' ', strng, length, occ$end_of_line);
          FOREND;
        IFEND;


      PROCEND process_msg_module_dictionary;
?? OLDTITLE ??
?? NEWTITLE := '    PROCESS_PANEL_DICTIONARY' ??
?? EJECT ??

      PROCEDURE process_panel_dictionary
        (    number_of_panels: 0 .. llc$max_panels_in_library;
             panel_dictionary: ^llt$panel_dictionary);


        VAR
          i: 0 .. llc$max_panels_in_library;


        ocp$output ('-', 'form dictionary', 15, occ$end_of_line);
        ocp$output (' ', '~~~~~~~~~~~~~~~', 15, occ$end_of_line);

        IF number_of_panels = 0 THEN
          ocp$output ('0', '*** NO FORMS ON LIBRARY ***', 27, occ$end_of_line);
        ELSE
          FOR i := 1 TO number_of_panels DO
            ocp$output ('0', 'name:', 5, occ$continue);
            ocp$output (' ', panel_dictionary^ [i].name, STRLENGTH (panel_dictionary^ [i].name),
                  occ$end_of_line);
          FOREND;
        IFEND;


      PROCEND process_panel_dictionary;
?? OLDTITLE ??
?? NEWTITLE := '    PROCESS_LIBRARY_MODULES' ??
?? EJECT ??

      PROCEDURE process_library_modules
        (    number_of_modules: 0 .. llc$max_modules_in_library;
             module_dictionary: ^llt$module_dictionary;
         VAR file: ^SEQ ( * ));


?? NEWTITLE := '      PROCESS_LIBRARY_MEMBER_HEADER' ??
?? EJECT ??

        PROCEDURE process_library_member_header
          (    library_member_header: ^llt$library_member_header;
           VAR file: ^SEQ ( * );
           VAR fatal_error: boolean);


          VAR
            aliases: ^pmt$module_list,
            availability_kinds: [STATIC, READ] llt$library_member_kinds :=
                  [llc$command_procedure, llc$program_description, llc$function_procedure,
                  llc$applic_command_procedure, llc$applic_program_description,
                  llc$applic_command_description, llc$command_description, llc$function_description],
            scope_kinds: [STATIC, READ] llt$library_member_kinds :=
                  [llc$command_procedure, llc$program_description, llc$function_procedure,
                  llc$applic_command_procedure, llc$applic_program_description,
                  llc$applic_command_description, llc$command_description, llc$function_description],
            log_option_kinds: [STATIC, READ] llt$library_member_kinds :=
                  [llc$command_procedure, llc$program_description, llc$applic_command_procedure,
                  llc$applic_program_description, llc$applic_command_description, llc$command_description],
            i: llt$number_of_aliases,
            valid: boolean;


          ocp$output ('0', 'library member header', 21, occ$end_of_line);
          ocp$output (' ', '~~~~~~~~~~~~~~~~~~~~~', 21, occ$end_of_line);

          ocp$output ('0', 'module name:', 12, occ$continue);
          ocp$output (' ', library_member_header^.name, STRLENGTH (library_member_header^.name),
                occ$continue);

          STRINGREP (strng, length, library_member_header^.module_index);
          ocp$output ('  ', 'module index:', 13, occ$continue);
          ocp$output (' ', strng, length, occ$end_of_line);

          ocp$output (' ', 'kind:', 5, occ$continue);
          CASE library_member_header^.kind OF
          = llc$program_description =
            ocp$output (' ', 'PROGRAM DESCRIPTION', 19, occ$continue);
          = llc$applic_program_description =
            ocp$output (' ', 'APPLICATION PROGRAM DESCRIPTION', 31, occ$continue);
          = llc$command_procedure =
            ocp$output (' ', 'COMMAND PROCEDURE', 17, occ$continue);
          = llc$applic_command_procedure =
            ocp$output (' ', 'APPLICATION COMMAND PROCEDURE', 29, occ$continue);
          = llc$command_description =
            ocp$output (' ', 'COMMAND DESCRIPTION', 19, occ$continue);
          = llc$applic_command_description =
            ocp$output (' ', 'APPLICATION COMMAND DESCRIPTION', 31, occ$continue);
          = llc$function_procedure =
            ocp$output (' ', 'FUNCTION PROCEDURE', 18, occ$continue);
          = llc$function_description =
            ocp$output (' ', 'FUNCTION DESCRIPTION', 20, occ$continue);
          = llc$message_module =
            ocp$output (' ', 'MESSAGE MODULE', 14, occ$continue);
          = llc$panel_module =
            ocp$output (' ', 'FORM MODULE', 11, occ$continue);
          ELSE
            ocp$output (' ', '*******************', 19, occ$end_of_line);
            error (' ', 'INVALID MEMBER KIND', 19, occ$end_of_line);
          CASEND;

          ocp$output ('  ', 'created:', 8, occ$continue);

          ocp$output_time (^library_member_header^.time_created, occ$continue, valid);
          IF NOT valid THEN
            ocp$output ('', ' ', 1, occ$end_of_line);
            error (' ', 'INVALID TIME FORMAT', 19, occ$end_of_line);
            ocp$output (occ$single_space, '', 0, occ$continue);
          IFEND;

          ocp$output ('', ' ', 1, occ$continue);
          ocp$output_date (^library_member_header^.date_created, occ$end_of_line, valid);
          IF NOT valid THEN
            error (' ', 'INVALID DATE FORMAT', 19, occ$end_of_line);
          IFEND;

          ocp$output (' ', 'generator:', 10, occ$continue);
          output_language (^library_member_header^.generator_id, occ$end_of_line);

          ocp$output (' ', 'generator name version:', 23, occ$continue);
          ocp$output (' ', library_member_header^.generator_name_vers,
                STRLENGTH (library_member_header^.generator_name_vers), occ$end_of_line);

          IF library_member_header^.commentary <> osc$null_name THEN
            ocp$output (' ', 'commentary:', 11, occ$continue);
            ocp$output (' ', library_member_header^.commentary, STRLENGTH (library_member_header^.commentary),
                  occ$end_of_line);
          IFEND;

          STRINGREP (strng, length, library_member_header^.member_size);
          ocp$output (' ', 'member size:', 12, occ$continue);
          ocp$output (' ', strng, length, occ$end_of_line);

          STRINGREP (strng, length, library_member_header^.number_of_aliases);
          ocp$output (' ', 'number of aliases:', 18, occ$continue);
          ocp$output (' ', strng, length, occ$end_of_line);


          IF library_member_header^.number_of_aliases <> 0 THEN
            ocp$output ('0', 'aliases', 7, occ$end_of_line);
            ocp$output (' ', '~~~~~~~', 7, occ$end_of_line);

            aliases := #PTR (library_member_header^.aliases, file^);
            IF aliases = NIL THEN
              error ('', premature_end_of_file, 33, occ$end_of_line);
              fatal_error := TRUE;
              RETURN;
            IFEND;

            FOR i := 1 TO library_member_header^.number_of_aliases DO
              ocp$output ('   ', aliases^ [i], STRLENGTH (aliases^ [i]), occ$end_of_line);
            FOREND;
          IFEND;

          IF library_member_header^.kind IN availability_kinds THEN
            ocp$output ('0', 'availability:', 12, occ$continue);
            CASE library_member_header^.command_function_availability OF
            = clc$normal_usage_entry =
              ocp$output (' ', 'NORMAL_USAGE', 12, occ$end_of_line);
            = clc$advanced_usage_entry =
              ocp$output (' ', 'ADVANCED_USAGE', 14, occ$end_of_line);
            = clc$hidden_entry =
              ocp$output (' ', 'HIDDEN', 6, occ$end_of_line);
            ELSE
              ocp$output (' ', '********************', 20, occ$end_of_line);
              ocp$output (' ', 'INVALID AVAILABILITY', 20, occ$end_of_line);
            CASEND;
          IFEND;

          IF library_member_header^.kind IN scope_kinds THEN
            ocp$output ('0', 'scope:', 6, occ$continue);
            CASE library_member_header^.command_function_kind OF
            = llc$entry_point =
              ocp$output (' ', 'XDCL', 4, occ$end_of_line);
            = llc$gate =
              ocp$output (' ', 'GATE', 4, occ$end_of_line);
            = llc$local_to_library =
              ocp$output (' ', 'LOCAL', 5, occ$end_of_line);
            ELSE
              ocp$output (' ', '*************', 13, occ$end_of_line);
              ocp$output (' ', 'INVALID SCOPE', 13, occ$end_of_line);
            CASEND;
          IFEND;

          IF library_member_header^.kind IN log_option_kinds THEN
            ocp$output ('0', 'log option:', 11, occ$continue);
            CASE library_member_header^.command_log_option OF
            = clc$automatically_log =
              ocp$output (' ', 'AUTOMATIC', 9, occ$end_of_line);
            = clc$manually_log =
              ocp$output (' ', 'MANUAL', 6, occ$end_of_line);
            ELSE
              ocp$output (' ', '******************', 18, occ$end_of_line);
              ocp$output (' ', 'INVALID LOG OPTION', 18, occ$end_of_line);
            CASEND;
          IFEND;

        PROCEND process_library_member_header;
?? OLDTITLE ??
?? NEWTITLE := '      PROCESS_LOAD_MODULE' ??
?? EJECT ??

        PROCEDURE process_load_module
          (    load_module_header: ^llt$load_module_header;
           VAR file: ^SEQ ( * ));

?? NEWTITLE := '        PROCESS_LOAD_MODULE_HEADER' ??
?? EJECT ??

          PROCEDURE process_load_module_header
            (    load_module_header: ^llt$load_module_header);


            ocp$output ('0', 'load module header', 18, occ$end_of_line);
            ocp$output (' ', '~~~~~~~~~~~~~~~~~~', 18, occ$end_of_line);

            STRINGREP (strng, length, load_module_header^.module_index);
            ocp$output ('0', 'index:', 6, occ$continue);
            ocp$output (' ', strng, length, occ$continue);

            ocp$output ('  ', 'elements defined = [', 20, occ$continue);
            IF llc$information_element IN load_module_header^.elements_defined THEN
              ocp$output (' ', 'INFORMATION', 11, occ$continue);
            IFEND;
            IF llc$interpretive_element IN load_module_header^.elements_defined THEN
              ocp$output (' ', 'INTERPRETIVE', 12, occ$continue);
            IFEND;
            ocp$output (' ', ']', 1, occ$end_of_line);

            IF llc$interpretive_element IN load_module_header^.elements_defined THEN
              ocp$output (' ', 'interpretive elements defined = [', 33, occ$continue);
              IF llc$library_element IN load_module_header^.interpretive_header.elements_defined THEN
                ocp$output (' ', 'LIB', 3, occ$continue);
              IFEND;
              IF llc$section_element IN load_module_header^.interpretive_header.elements_defined THEN
                ocp$output (' ', 'SDC', 3, occ$continue);
              IFEND;
              IF llc$entry_point_element IN load_module_header^.interpretive_header.elements_defined THEN
                ocp$output (' ', 'EPT', 3, occ$continue);
              IFEND;
              IF llc$external_element IN load_module_header^.interpretive_header.elements_defined THEN
                ocp$output (' ', 'EXT', 3, occ$continue);
              IFEND;
              IF llc$transfer_symbol_element IN load_module_header^.interpretive_header.elements_defined THEN
                ocp$output (' ', 'TRA', 3, occ$continue);
              IFEND;
              ocp$output (' ', ']', 1, occ$end_of_line);
            IFEND;

          PROCEND process_load_module_header;
?? OLDTITLE ??
?? NEWTITLE := 'process_interpretive_element' ??
?? EJECT ??

          PROCEDURE process_interpretive_element
            (    load_module_header: ^llt$load_module_header;
             VAR file: ^SEQ ( * ));


            VAR
              interpretive_element: ^llt$object_text_descriptor,

              fatal_error: boolean,
              end_of_file: boolean,
              record_kind: llt$object_record_kind,
              size: integer,
              module_kind: llt$module_kind;


            fatal_error := FALSE;

            ocp$output ('-', 'interpretive element', 20, occ$end_of_line);
            ocp$output (' ', '~~~~~~~~~~~~~~~~~~~~', 20, occ$end_of_line);

            interpretive_element := #PTR (load_module_header^.interpretive_element, file^);
            IF interpretive_element = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
              RETURN;
            IFEND;
            RESET file TO interpretive_element;

            process_object_text_descriptor (file, fatal_error, end_of_file, record_kind, size);
            IF NOT fatal_error THEN
              IF end_of_file THEN
                error (' ', premature_end_of_file, 33, occ$end_of_line);
              ELSE
                IF record_kind <> llc$identification THEN
                  error (' ', 'IDENTIFICATION RECORD MUST BE FIRST RECORD OF MODULE', 52, occ$end_of_line);
                ELSE
                  process_identification_record (file, fatal_error, module_kind);
                  IF NOT fatal_error THEN
                    CASE module_kind OF
                    = llc$mi_virtual_state, llc$vector_virtual_state, llc$motorola_68000,
                          llc$motorola_68000_absolute, llc$vector_extended_state =
                      process_cpu_module (file, fatal_error);
                    = llc$iou =
                      error (' ', 'INVALID LOAD MODULE KIND', 24, occ$end_of_line);
                    ELSE
                      error (' ', 'INTERNAL PROBLEM 3', 18, occ$end_of_line);
                    CASEND;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;


          PROCEND process_interpretive_element;
?? OLDTITLE ??
?? NEWTITLE := '        PROCESS_INFORMATION_ELEMENT' ??
?? EJECT ??

          PROCEDURE process_information_element
            (    load_module_header: ^llt$load_module_header;
             VAR file: ^SEQ ( * ));

?? NEWTITLE := '          PROCESS_RELOCATION_ITEMS' ??
?? EJECT ??

            PROCEDURE process_relocation_items
              (    number_of_rel_items: llt$number_of_info_elements;
               VAR file: ^SEQ ( * );
               VAR fatal_error: boolean);


              ocp$output ('0', 'RIF', 3, occ$continue);

              STRINGREP (strng, length, record_number);
              ocp$output ('  ', 'rn:', 3, occ$continue);
              ocp$output (' ', strng, length, occ$continue);
              record_number := record_number + 1;

              hexrep (strng, length, number_of_rel_items);
              ocp$output ('  ', 'number of relocation items:', 27, occ$continue);
              ocp$output (' ', strng, length, occ$end_of_line);

              process_relocation_record (number_of_rel_items, file, fatal_error);
              IF fatal_error THEN
                fatal_error := FALSE;
              IFEND;


            PROCEND process_relocation_items;
?? OLDTITLE ??
?? NEWTITLE := '          PROCESS_BINDING_TEMPLATE_ITEMS' ??
?? EJECT ??

            PROCEDURE process_binding_template_items
              (    number_of_template_items: llt$number_of_info_elements;
               VAR file: ^SEQ ( * );
               VAR fatal_error: boolean);


              VAR
                i: integer;


              FOR i := 1 TO number_of_template_items DO
                ocp$output ('0', 'BTI', 3, occ$continue);

                STRINGREP (strng, length, record_number);
                ocp$output ('  ', 'rn:', 3, occ$continue);
                ocp$output (' ', strng, length, occ$end_of_line);
                record_number := record_number + 1;

                process_binding_template_record (file, fatal_error);
                IF fatal_error THEN
                  fatal_error := FALSE;
                  RETURN;
                IFEND;
              FOREND;


            PROCEND process_binding_template_items;
?? OLDTITLE ??
?? NEWTITLE := '          PROCESS_COMPONENT_INFO' ??
?? EJECT ??

            PROCEDURE process_component_info
              (    number_of_components: llt$number_of_info_elements;
                   component_information: ^llt$component_information);


              VAR
                i: integer;


              ocp$output ('-', 'component information', 21, occ$end_of_line);
              ocp$output (' ', '~~~~~~~~~~~~~~~~~~~~~', 21, occ$end_of_line);

              FOR i := 1 TO number_of_components DO
                ocp$output ('0', 'component name:', 15, occ$continue);
                ocp$output (' ', component_information^ [i].name, STRLENGTH (component_information^ [i].name),
                      occ$continue);
                STRINGREP (strng, length, i);
                ocp$output ('  number:', strng, length, occ$end_of_line);

                ocp$output (' ', 'created:', 8, occ$continue);
                CASE component_information^ [i].time_created.time_format OF
                = osc$ampm_time =
                  ocp$output (' ', component_information^ [i].time_created.ampm,
                        STRLENGTH (component_information^ [i].time_created.ampm), occ$continue);
                = osc$hms_time =
                  ocp$output (' ', component_information^ [i].time_created.hms,
                        STRLENGTH (component_information^ [i].time_created.hms), occ$continue);
                = osc$millisecond_time =
                  ocp$output (' ', component_information^ [i].time_created.millisecond,
                        STRLENGTH (component_information^ [i].time_created.millisecond), occ$continue);
                ELSE
                  ocp$output (' ', '**:**:**.***', 12, occ$end_of_line);
                  error (' ', 'INVALID TIME FORMAT', 19, occ$end_of_line);
                CASEND;

                CASE component_information^ [i].date_created.date_format OF
                = osc$month_date =
                  ocp$output ('  ', component_information^ [i].date_created.month,
                        STRLENGTH (component_information^ [i].date_created.month), occ$end_of_line);
                = osc$mdy_date =
                  ocp$output ('  ', component_information^ [i].date_created.mdy,
                        STRLENGTH (component_information^ [i].date_created.mdy), occ$end_of_line);
                = osc$iso_date =
                  ocp$output ('  ', component_information^ [i].date_created.iso,
                        STRLENGTH (component_information^ [i].date_created.iso), occ$end_of_line);
                = osc$ordinal_date =
                  ocp$output ('  ', component_information^ [i].date_created.ordinal,
                        STRLENGTH (component_information^ [i].date_created.ordinal), occ$end_of_line);
                ELSE
                  ocp$output ('  ', '**/**/**', 8, occ$end_of_line);
                  error (' ', 'INVALID DATE FORMAT', 19, occ$end_of_line);
                CASEND;

                ocp$output (' ', 'generator:', 10, occ$continue);
                output_language (^component_information^ [i].generator_id, occ$end_of_line);

                ocp$output (' ', 'generator name version:', 23, occ$continue);
                ocp$output (' ', component_information^ [i].generator_name_vers,
                      STRLENGTH (component_information^ [i].generator_name_vers), occ$end_of_line);

                ocp$output (' ', 'commentary:', 11, occ$continue);
                ocp$output (' ', component_information^ [i].commentary,
                      STRLENGTH (component_information^ [i].commentary), occ$end_of_line);
              FOREND;


            PROCEND process_component_info;
?? OLDTITLE ??
?? NEWTITLE := '          PROCESS_SECTION_MAPS', EJECT ??

            PROCEDURE process_section_maps
              (    section_maps: ^llt$section_maps;
               VAR file: ^SEQ ( * );
               VAR fatal_error: boolean);


              VAR
                i: integer,
                j: integer,
                map: ^llt$section_map_items;


              ocp$output ('-', 'section maps', 12, occ$end_of_line);
              ocp$output (' ', '~~~~~~~~~~~~', 12, occ$end_of_line);

              FOR i := 0 TO UPPERBOUND (section_maps^) DO
                hexrep (strng, length, i);
                ocp$output ('0section ordinal: ', strng, length, occ$continue);

                STRINGREP (strng, length, section_maps^ [i].number_of_items);
                ocp$output ('  number of items:', strng, length, occ$end_of_line);

                IF section_maps^ [i].number_of_items <> 0 THEN
                  map := #PTR (section_maps^ [i].map, file^);

                  FOR j := 1 TO UPPERBOUND (map^) DO
                    hexrep (strng, length, map^ [j].original_section_ordinal);
                    ocp$output ('   original section ordinal: ', strng, length, occ$continue);
                    hexrep (strng, length, map^ [j].offset);
                    ocp$output ('  offset: ', strng, length, occ$continue);
                    hexrep (strng, length, map^ [j].length);
                    ocp$output ('  length: ', strng, length, occ$end_of_line);

                    ocp$output ('   name: ', map^ [j].name, STRLENGTH (map^ [j].name), occ$continue);
                    STRINGREP (strng, length, map^ [j].component);
                    ocp$output ('  component:', strng, length, occ$end_of_line);
                  FOREND;
                IFEND;
              FOREND;

            PROCEND process_section_maps;
?? OLDTITLE ??
?? NEWTITLE := '          PROCESS_INFO_ELEMENT_HEADER' ??
?? EJECT ??

            PROCEDURE process_info_element_header
              (    info_element_header: ^llt$info_element_header;
                   version: llt$version;
               VAR file: ^SEQ ( * ));


              VAR
                component_information: ^llt$component_information,
                relocation: ^llt$relocation,
                binding_template: ^llt$binding_section_template,
                section_maps: ^llt$section_maps,
                fatal_error: boolean;


              ocp$output ('0version: ', version, STRLENGTH (version), occ$end_of_line);

              hexrep (strng, length, info_element_header^.number_of_rel_items);
              ocp$output ('0', 'number of relocation items:', 27, occ$continue);
              ocp$output (' ', strng, length, occ$end_of_line);

              hexrep (strng, length, info_element_header^.number_of_template_items);
              ocp$output (' ', 'number of template items:', 25, occ$continue);
              ocp$output (' ', strng, length, occ$end_of_line);

              hexrep (strng, length, info_element_header^.number_of_components);
              ocp$output (' ', 'number of components:', 21, occ$continue);
              ocp$output (' ', strng, length, occ$end_of_line);

              hexrep (strng, length, info_element_header^.number_of_section_maps);
              ocp$output (' ', 'number of section maps:', 23, occ$continue);
              ocp$output (' ', strng, length, occ$end_of_line);

              IF info_element_header^.number_of_rel_items <> 0 THEN
                relocation := #PTR (info_element_header^.relocation_ptr, file^);
                IF relocation = NIL THEN
                  error (' ', premature_end_of_file, 33, occ$end_of_line);
                ELSE
                  RESET file TO relocation;
                  process_relocation_items (info_element_header^.number_of_rel_items, file, fatal_error);
                IFEND;
              IFEND;

              IF info_element_header^.number_of_template_items <> 0 THEN
                binding_template := #PTR (info_element_header^.binding_template_ptr, file^);
                IF binding_template = NIL THEN
                  error (' ', premature_end_of_file, 33, occ$end_of_line);
                ELSE
                  RESET file TO binding_template;
                  process_binding_template_items (info_element_header^.number_of_template_items, file,
                        fatal_error);
                IFEND;
              IFEND;

              IF info_element_header^.number_of_components <> 0 THEN
                component_information := #PTR (info_element_header^.component_ptr, file^);
                IF component_information = NIL THEN
                  error (' ', premature_end_of_file, 33, occ$end_of_line);
                ELSE
                  process_component_info (info_element_header^.number_of_components, component_information);
                IFEND;
              IFEND;

              IF info_element_header^.number_of_section_maps <> 0 THEN
                section_maps := #PTR (info_element_header^.section_maps, file^);
                IF section_maps = NIL THEN
                  error (' ', premature_end_of_file, 33, occ$end_of_line);
                ELSE
                  process_section_maps (section_maps, file, fatal_error);
                IFEND;
              IFEND;


            PROCEND process_info_element_header;
?? OLDTITLE ??
?? EJECT ??

            VAR
              info_element_header: ^llt$info_element_header,
              new_header: llt$info_element_header,
              version: llt$version;

            ocp$output ('-', 'information element', 19, occ$end_of_line);
            ocp$output (' ', '~~~~~~~~~~~~~~~~~~~', 19, occ$end_of_line);

            info_element_header := #PTR (load_module_header^.information_element, file^);
            IF info_element_header = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
              RETURN;
            IFEND;

            version := info_element_header^.version;

            IF (version <> llc$info_element_version) THEN
              IF (version <> llc$info_element_version_1_0) THEN
                version := '????';
              IFEND;

              ocp$convert_information_element (info_element_header, new_header);

              info_element_header := ^new_header;
            IFEND;

            process_info_element_header (info_element_header, version, file);


          PROCEND process_information_element;
?? OLDTITLE ??
?? EJECT ??

          module_info.section_definition := NIL;
          record_number := 1;

          process_load_module_header (load_module_header);

          IF NOT (llc$interpretive_element IN load_module_header^.elements_defined) THEN
            error (' ', 'INTERPRETIVE ELEMENT NOT PRESENT', 32, occ$end_of_line);
            RETURN;
          IFEND;

          process_interpretive_element (load_module_header, file);

          IF llc$information_element IN load_module_header^.elements_defined THEN
            process_information_element (load_module_header, file);
          IFEND;

          IF module_info.section_definition <> NIL THEN
            FREE module_info.section_definition;
          IFEND;


        PROCEND process_load_module;
?? OLDTITLE ??
?? NEWTITLE := 'process_ppu_object_module' ??
?? EJECT ??

        PROCEDURE process_ppu_object_module
          (VAR file: ^SEQ ( * ));


          VAR
            fatal_error: boolean,
            end_of_file: boolean,
            record_kind: llt$object_record_kind,
            size: integer,
            module_kind: llt$module_kind;


          fatal_error := FALSE;

          process_object_text_descriptor (file, fatal_error, end_of_file, record_kind, size);
          IF NOT fatal_error THEN
            IF end_of_file THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
            ELSE
              IF record_kind <> llc$identification THEN
                error (' ', 'IDENTIFICATION RECORD MUST BE FIRST RECORD OF MODULE', 52, occ$end_of_line);
              ELSE
                process_identification_record (file, fatal_error, module_kind);
                IF NOT fatal_error THEN
                  CASE module_kind OF
                  = llc$mi_virtual_state, llc$vector_virtual_state, llc$motorola_68000,
                        llc$motorola_68000_absolute, llc$vector_extended_state =
                    error (' ', 'INVALID PPU OBJECT MODULE KIND', 30, occ$end_of_line);
                  = llc$iou =
                    process_iou_module (file, fatal_error);
                  ELSE
                    error (' ', 'INTERNAL PROBLEM 4', 18, occ$end_of_line);
                  CASEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;


        PROCEND process_ppu_object_module;
?? OLDTITLE ??
?? NEWTITLE := '      PROCESS_PROGRAM_DESCRIPTION' ??
?? EJECT ??

        PROCEDURE process_program_description
          (    library_member_header: ^llt$library_member_header;
           VAR file: ^SEQ ( * ));


          VAR
            fatal_error: boolean,
            member: ^llt$program_description,
            program_attributes: ^llt$program_attributes,
            conditions: ^pmt$enable_inhibit_conditions,
            object_file_list: ^llt$object_file_list,
            library_list: ^llt$object_library_list,
            module_list: ^pmt$module_list,
            i: integer;


          fatal_error := FALSE;

          process_library_member_header (library_member_header, file, fatal_error);
          IF fatal_error THEN
            RETURN;
          IFEND;

          member := #PTR (library_member_header^.member, file^);
          IF member = NIL THEN
            error (' ', premature_end_of_file, 33, occ$end_of_line);
            RETURN;
          IFEND;
          RESET member;

          NEXT program_attributes IN member;
          IF program_attributes = NIL THEN
            error (' ', premature_end_of_file, 33, occ$end_of_line);
            RETURN;
          IFEND;

          IF (pmc$object_file_list_specified IN program_attributes^.contents) AND
                (program_attributes^.number_of_object_files <> 0) THEN
            NEXT object_file_list: [1 .. program_attributes^.number_of_object_files] IN member;
            IF object_file_list = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
              RETURN;
            IFEND;

            ocp$output ('0', 'object file list', 16, occ$end_of_line);
            ocp$output (' ', '~~~~~~~~~~~~~~~~', 16, occ$end_of_line);

            FOR i := 1 TO program_attributes^.number_of_object_files DO
              ocp$output ('   ', object_file_list^ [i], STRLENGTH (object_file_list^ [i]), occ$end_of_line);
            FOREND;
          IFEND;

          IF (pmc$module_list_specified IN program_attributes^.contents) AND
                (program_attributes^.number_of_modules <> 0) THEN
            NEXT module_list: [1 .. program_attributes^.number_of_modules] IN member;
            IF module_list = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
              RETURN;
            IFEND;

            ocp$output ('0', 'module list', 11, occ$end_of_line);
            ocp$output (' ', '~~~~~~~~~~~', 11, occ$end_of_line);

            i := 1;
            FOR i := 1 TO program_attributes^.number_of_modules DO
              ocp$output ('   ', module_list^ [i], STRLENGTH (module_list^ [i]), occ$end_of_line);
            FOREND;
          IFEND;

          IF (pmc$library_list_specified IN program_attributes^.contents) AND
                (program_attributes^.number_of_libraries <> 0) THEN
            NEXT library_list: [1 .. program_attributes^.number_of_libraries] IN member;
            IF library_list = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
              RETURN;
            IFEND;

            ocp$output ('0', 'library list', 12, occ$end_of_line);
            ocp$output (' ', '~~~~~~~~~~~~', 12, occ$end_of_line);

            FOR i := 1 TO program_attributes^.number_of_libraries DO
              ocp$output ('   ', library_list^ [i], STRLENGTH (library_list^ [i]), occ$end_of_line);
            FOREND;
          IFEND;

          ocp$output (' ', '  ', 2, occ$end_of_line);

          IF (pmc$condition_specified IN program_attributes^.contents) THEN
            NEXT conditions IN member;
            IF conditions = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
              RETURN;
            IFEND;

            ocp$output ('0', 'conditions', 10, occ$end_of_line);
            ocp$output (' ', '~~~~~~~~~~', 10, occ$end_of_line);

            IF pmc$arithmetic_overflow IN conditions^.enable_system_conditions THEN
              ocp$output ('   ', 'arithmetic overflow             :  ON', 37, occ$end_of_line);
            ELSEIF pmc$arithmetic_overflow IN conditions^.inhibit_system_conditions THEN
              ocp$output ('   ', 'arithmetic overflow             : OFF', 37, occ$end_of_line);
            IFEND;

            IF pmc$arithmetic_significance IN conditions^.enable_system_conditions THEN
              ocp$output ('   ', 'arithmetic loss of significance :  ON', 37, occ$end_of_line);
            ELSEIF pmc$arithmetic_significance IN conditions^.inhibit_system_conditions THEN
              ocp$output ('   ', 'arithmetic loss of significance : OFF', 37, occ$end_of_line);
            IFEND;

            IF pmc$divide_fault IN conditions^.enable_system_conditions THEN
              ocp$output ('   ', 'divide_fault                    :  ON', 37, occ$end_of_line);
            ELSEIF pmc$divide_fault IN conditions^.inhibit_system_conditions THEN
              ocp$output ('   ', 'divide_fault                    : OFF', 37, occ$end_of_line);
            IFEND;

            IF pmc$exponent_overflow IN conditions^.enable_system_conditions THEN
              ocp$output ('   ', 'exponent overflow               :  ON', 37, occ$end_of_line);
            ELSEIF pmc$exponent_overflow IN conditions^.inhibit_system_conditions THEN
              ocp$output ('   ', 'exponent overflow               : OFF', 37, occ$end_of_line);
            IFEND;

            IF pmc$exponent_underflow IN conditions^.enable_system_conditions THEN
              ocp$output ('   ', 'exponent underflow              :  ON', 37, occ$end_of_line);
            ELSEIF pmc$exponent_underflow IN conditions^.inhibit_system_conditions THEN
              ocp$output ('   ', 'exponent underflow              : OFF', 37, occ$end_of_line);
            IFEND;

            IF pmc$fp_indefinite IN conditions^.enable_system_conditions THEN
              ocp$output ('   ', 'fp indefinite                   :  ON', 37, occ$end_of_line);
            ELSEIF pmc$fp_indefinite IN conditions^.inhibit_system_conditions THEN
              ocp$output ('   ', 'fp indefinite                   : OFF', 37, occ$end_of_line);
            IFEND;

            IF pmc$fp_significance_loss IN conditions^.enable_system_conditions THEN
              ocp$output ('   ', 'fp loss of significance         :  ON', 37, occ$end_of_line);
            ELSEIF pmc$fp_significance_loss IN conditions^.inhibit_system_conditions THEN
              ocp$output ('   ', 'fp loss of significance         : OFF', 37, occ$end_of_line);
            IFEND;

            IF pmc$invalid_bdp_data IN conditions^.enable_system_conditions THEN
              ocp$output ('   ', 'invalid BDP data                :  ON', 37, occ$end_of_line);
            ELSEIF pmc$invalid_bdp_data IN conditions^.inhibit_system_conditions THEN
              ocp$output ('   ', 'invalid BDP data                : OFF', 37, occ$end_of_line);
            IFEND;
          IFEND;

          ocp$output (' ', '  ', 2, occ$end_of_line);

          IF pmc$starting_proc_specified IN program_attributes^.contents THEN
            ocp$output (' ', 'starting procedure:', 19, occ$continue);
            ocp$output (' ', program_attributes^.starting_procedure,
                  STRLENGTH (program_attributes^.starting_procedure), occ$end_of_line);
          IFEND;

          IF pmc$load_map_file_specified IN program_attributes^.contents THEN
            ocp$output (' ', 'load map file:', 14, occ$continue);
            ocp$output (' ', program_attributes^.load_map_file, STRLENGTH (program_attributes^.load_map_file),
                  occ$end_of_line);
          IFEND;

          IF pmc$load_map_options_specified IN program_attributes^.contents THEN
            ocp$output (' ', 'load map options: [', 19, occ$continue);

            IF pmc$no_load_map IN program_attributes^.load_map_options THEN
              ocp$output (' ', 'NONE', 4, occ$continue);
            IFEND;
            IF pmc$segment_map IN program_attributes^.load_map_options THEN
              ocp$output (' ', 'SEGMENT', 7, occ$continue);
            IFEND;
            IF pmc$block_map IN program_attributes^.load_map_options THEN
              ocp$output (' ', 'BLOCK', 5, occ$continue);
            IFEND;
            IF pmc$entry_point_map IN program_attributes^.load_map_options THEN
              ocp$output (' ', 'ENTRY_POINT', 11, occ$continue);
            IFEND;
            IF pmc$entry_point_xref IN program_attributes^.load_map_options THEN
              ocp$output (' ', 'XREF', 4, occ$continue);
            IFEND;

            ocp$output (' ', ']', 1, occ$end_of_line);
          IFEND;

          IF pmc$term_error_level_specified IN program_attributes^.contents THEN
            ocp$output (' ', 'termination error level:', 24, occ$continue);

            CASE program_attributes^.termination_error_level OF
            = pmc$warning_load_errors =
              ocp$output (' ', 'WARNING', 7, occ$end_of_line);
            = pmc$error_load_errors =
              ocp$output (' ', 'ERROR', 5, occ$end_of_line);
            = pmc$fatal_load_errors =
              ocp$output (' ', 'FATAL', 5, occ$end_of_line);
            ELSE
              ocp$output (' ', '*******', 7, occ$end_of_line);
            CASEND;
          IFEND;

          IF pmc$preset_specified IN program_attributes^.contents THEN
            ocp$output (' ', 'preset value:', 13, occ$continue);

            CASE program_attributes^.preset OF
            = pmc$initialize_to_zero =
              ocp$output (' ', 'ZERO', 4, occ$end_of_line);
            = pmc$initialize_to_alt_ones =
              ocp$output (' ', 'ALTERNATE ONES', 14, occ$end_of_line);
            = pmc$initialize_to_indefinite =
              ocp$output (' ', 'FLOATING POINT INDEFINITE', 25, occ$end_of_line);
            = pmc$initialize_to_infinity =
              ocp$output (' ', 'INFINITY', 8, occ$end_of_line);
            ELSE
              ocp$output (' ', '******', 6, occ$end_of_line);
            CASEND;
          IFEND;

          IF pmc$max_stack_size_specified IN program_attributes^.contents THEN
            hexrep (strng, length, program_attributes^.maximum_stack_size);

            ocp$output (' ', 'stack size:', 11, occ$continue);
            ocp$output ('', strng, length, occ$end_of_line);
          IFEND;

          IF pmc$abort_file_specified IN program_attributes^.contents THEN
            ocp$output (' ', 'abort file:', 11, occ$continue);
            ocp$output (' ', program_attributes^.abort_file, STRLENGTH (program_attributes^.abort_file),
                  occ$end_of_line);
          IFEND;

          IF pmc$debug_mode_specified IN program_attributes^.contents THEN
            IF program_attributes^.debug_mode THEN
              ocp$output (' ', 'debug mode: ON', 14, occ$end_of_line);
            ELSE
              ocp$output (' ', 'debug mode: OFF', 15, occ$end_of_line);
            IFEND;
          IFEND;

          IF pmc$debug_input_specified IN program_attributes^.contents THEN
            ocp$output (' debug_input: ', program_attributes^.debug_input,
                  STRLENGTH (program_attributes^.debug_input), occ$end_of_line);
          IFEND;

          IF pmc$debug_output_specified IN program_attributes^.contents THEN
            ocp$output ('      debug_output: ', program_attributes^.debug_output,
                  STRLENGTH (program_attributes^.debug_output), occ$end_of_line);
          IFEND;


        PROCEND process_program_description;
?? OLDTITLE ??
?? NEWTITLE := '      PROCESS_COMMAND_DESCRIPTION' ??
?? EJECT ??

        PROCEDURE process_command_description
          (    library_member_header: ^llt$library_member_header;
           VAR file: ^SEQ ( * ));


          VAR
            fatal_error: boolean,
            member: ^llt$command_description,
            command_attributes: ^llt$command_desc_contents,
            library_path: ^fst$file_reference,
            i: integer;


          fatal_error := FALSE;

          process_library_member_header (library_member_header, file, fatal_error);
          IF fatal_error THEN
            RETURN;
          IFEND;

          member := #PTR (library_member_header^.member, file^);
          IF member = NIL THEN
            error (' ', premature_end_of_file, 33, occ$end_of_line);
            RETURN;
          IFEND;
          RESET member;

          NEXT command_attributes IN member;
          IF command_attributes = NIL THEN
            error (' ', premature_end_of_file, 33, occ$end_of_line);
            RETURN;
          IFEND;

          IF command_attributes^.system_command THEN
            ocp$output ('0', 'system command name:', 20, occ$continue);
            ocp$output (' ', command_attributes^.system_command_name,
                  STRLENGTH (command_attributes^.system_command_name), occ$end_of_line);

          ELSE
            ocp$output ('0', 'starting procedure:', 19, occ$continue);
            ocp$output (' ', command_attributes^.starting_procedure,
                  STRLENGTH (command_attributes^.starting_procedure), occ$end_of_line);

            IF command_attributes^.library_path_size > 0 THEN
              NEXT library_path: [command_attributes^.library_path_size] IN member;
              IF library_path = NIL THEN
                error (' ', premature_end_of_file, 33, occ$end_of_line);
                RETURN;
              IFEND;

              ocp$output ('0', 'library', 7, occ$end_of_line);
              ocp$output (' ', '~~~~~~~', 7, occ$end_of_line);

              ocp$output ('   ', library_path^, STRLENGTH (library_path^), occ$end_of_line);
            IFEND;
          IFEND;

        PROCEND process_command_description;
?? OLDTITLE ??
?? NEWTITLE := '      PROCESS_COMMAND_PROCEDURE' ??
?? EJECT ??

        PROCEDURE process_command_procedure
          (    library_member_header: ^llt$library_member_header;
           VAR file: ^SEQ ( * ));


          VAR
            fatal_error: boolean,
            command_procedure: ^clt$scl_procedure;


          fatal_error := FALSE;

          process_library_member_header (library_member_header, file, fatal_error);
          IF fatal_error THEN
            RETURN;
          IFEND;

          command_procedure := #PTR (library_member_header^.member, file^);
          IF command_procedure = NIL THEN
            error (' ', premature_end_of_file, 33, occ$end_of_line);
            RETURN;
          IFEND;

          ocp$output ('0', 'command procedure', 17, occ$end_of_line);
          ocp$output (' ', '~~~~~~~~~~~~~~~~~', 17, occ$end_of_line);
          hex_dump (#LOC (command_procedure^), library_member_header^.member_size);


        PROCEND process_command_procedure;
?? OLDTITLE ??
?? NEWTITLE := '      PROCESS_APPLIC_PROGRAM_DESCRIP' ??
?? EJECT ??

        PROCEDURE process_applic_program_descrip
          (    application_member_header: ^llt$application_member_header;
           VAR file: ^SEQ ( * ));

          VAR
            library_member_header: ^llt$library_member_header;

          library_member_header := ^application_member_header^.library_member_header;

          process_program_description (library_member_header, file);

          ocp$output (' ', 'application identifier:', 23, occ$continue);
          ocp$output (' ', application_member_header^.application_identifier.name,
                STRLENGTH (application_member_header^.application_identifier.name), occ$end_of_line);
        PROCEND process_applic_program_descrip;
?? OLDTITLE ??
?? NEWTITLE := '      PROCESS_APPLIC_COMMAND_DESCRIP' ??
?? EJECT ??

        PROCEDURE process_applic_command_descrip
          (    application_member_header: ^llt$application_member_header;
           VAR file: ^SEQ ( * ));

          VAR
            library_member_header: ^llt$library_member_header;

          library_member_header := ^application_member_header^.library_member_header;

          process_command_description (library_member_header, file);

          ocp$output (' ', 'application identifier:', 23, occ$continue);
          ocp$output (' ', application_member_header^.application_identifier.name,
                STRLENGTH (application_member_header^.application_identifier.name), occ$end_of_line);
        PROCEND process_applic_command_descrip;
?? OLDTITLE ??
?? NEWTITLE := '      PROCESS_APPLIC_COMMAND_PROC' ??
?? EJECT ??

        PROCEDURE process_applic_command_proc
          (    application_member_header: ^llt$application_member_header;
           VAR file: ^SEQ ( * ));

          VAR
            library_member_header: ^llt$library_member_header;

          library_member_header := ^application_member_header^.library_member_header;

          process_command_procedure (library_member_header, file);

          ocp$output (' ', 'application identifier:', 23, occ$continue);
          ocp$output (' ', application_member_header^.application_identifier.name,
                STRLENGTH (application_member_header^.application_identifier.name), occ$end_of_line);
        PROCEND process_applic_command_proc;
?? OLDTITLE ??
?? NEWTITLE := '      PROCESS_FUNCTION_PROCEDURE' ??
?? EJECT ??

        PROCEDURE process_function_procedure
          (    library_member_header: ^llt$library_member_header;
           VAR file: ^SEQ ( * ));


          VAR
            fatal_error: boolean,
            function_procedure: ^clt$scl_procedure;


          fatal_error := FALSE;

          process_library_member_header (library_member_header, file, fatal_error);
          IF fatal_error THEN
            RETURN;
          IFEND;

          function_procedure := #PTR (library_member_header^.member, file^);
          IF function_procedure = NIL THEN
            error (' ', premature_end_of_file, 33, occ$end_of_line);
            RETURN;
          IFEND;

          ocp$output ('0', 'function procedure', 18, occ$end_of_line);
          ocp$output (' ', '~~~~~~~~~~~~~~~~~~', 18, occ$end_of_line);
          hex_dump (#LOC (function_procedure^), library_member_header^.member_size);


        PROCEND process_function_procedure;
?? OLDTITLE ??
?? NEWTITLE := '      PROCESS_FUNCTION_DESCRIPTION' ??
?? EJECT ??

        PROCEDURE process_function_description
          (    library_member_header: ^llt$library_member_header;
           VAR file: ^SEQ ( * ));


          VAR
            fatal_error: boolean,
            member: ^llt$function_description,
            function_attributes: ^llt$function_desc_contents,
            library_path: ^fst$file_reference,
            i: integer;


          fatal_error := FALSE;

          process_library_member_header (library_member_header, file, fatal_error);
          IF fatal_error THEN
            RETURN;
          IFEND;

          member := #PTR (library_member_header^.member, file^);
          IF member = NIL THEN
            error (' ', premature_end_of_file, 33, occ$end_of_line);
            RETURN;
          IFEND;
          RESET member;

          NEXT function_attributes IN member;
          IF function_attributes = NIL THEN
            error (' ', premature_end_of_file, 33, occ$end_of_line);
            RETURN;
          IFEND;

          ocp$output ('0', 'starting procedure:', 19, occ$continue);
          ocp$output (' ', function_attributes^.starting_procedure,
                STRLENGTH (function_attributes^.starting_procedure), occ$end_of_line);

          IF function_attributes^.library_path_size > 0 THEN
            NEXT library_path: [function_attributes^.library_path_size] IN member;
            IF library_path = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
              RETURN;
            IFEND;

            ocp$output ('0', 'library', 7, occ$end_of_line);
            ocp$output (' ', '~~~~~~~', 7, occ$end_of_line);

            ocp$output ('   ', library_path^, STRLENGTH (library_path^), occ$end_of_line);
          IFEND;

        PROCEND process_function_description;
?? OLDTITLE ??
?? NEWTITLE := '      PROCESS_MESSAGE_MODULE_PROCEDURE' ??
?? EJECT ??

        PROCEDURE process_msg_module_procedure
          (    library_member_header: ^llt$library_member_header;
           VAR file: ^SEQ ( * ));


          VAR
            fatal_error: boolean,
            message_template_module: ^ost$message_template_module,
            natural_language: ost$natural_language,
            online_manual: ost$online_manual_name,
            help_module: boolean,
            message_module: boolean,
            lowest_condition_code: ost$status_condition_code,
            highest_condition_code: ost$status_condition_code,
            local_status: ost$status;

          fatal_error := FALSE;

          process_library_member_header (library_member_header, file, fatal_error);
          IF fatal_error THEN
            RETURN;
          IFEND;

          message_template_module := #PTR (library_member_header^.member, file^);
          IF message_template_module = NIL THEN
            error (' ', premature_end_of_file, 33, occ$end_of_line);
            RETURN;
          IFEND;

          clp$get_message_module_info (message_template_module, natural_language, online_manual, help_module,
                message_module, lowest_condition_code, highest_condition_code, local_status);

          IF NOT local_status.normal THEN
            RETURN;
          IFEND;

          ocp$output ('0', 'module type:', 12, occ$continue);
          IF message_module AND help_module THEN
            ocp$output (' ', 'MESSAGE AND HELP MODULE', 23, occ$end_of_line);
          ELSEIF message_module THEN
            ocp$output (' ', 'MESSAGE MODULE', 14, occ$end_of_line);
          ELSEIF help_module THEN
            ocp$output (' ', 'HELP MODULE', 11, occ$end_of_line);
          IFEND;

          ocp$output ('0', 'natural language:', 17, occ$continue);
          ocp$output (' ', natural_language, STRLENGTH (natural_language), occ$end_of_line);

          ocp$output ('0', 'online manual:', 14, occ$continue);
          ocp$output (' ', online_manual, STRLENGTH (online_manual), occ$end_of_line);

          IF message_module THEN
            STRINGREP (strng, length, lowest_condition_code);
            ocp$output ('0', 'lowest condition code:', 22, occ$continue);
            ocp$output (' ', strng, length, occ$end_of_line);
            STRINGREP (strng, length, highest_condition_code);
            ocp$output (' ', 'highest condition code:', 22, occ$continue);
            ocp$output (' ', strng, length, occ$end_of_line);
          IFEND;

          hex_dump (#LOC (message_template_module^), library_member_header^.member_size);


        PROCEND process_msg_module_procedure;
?? OLDTITLE ??
?? NEWTITLE := '      PROCESS_PANEL_MODEL_PROCEDURE' ??
?? EJECT ??

        PROCEDURE process_panel_module_procedure
          (    library_member_header: ^llt$library_member_header;
           VAR file: ^SEQ ( * ));


          VAR
            fatal_error: boolean,
            panel_module_procedure: ^SEQ ( * );


          fatal_error := FALSE;

          process_library_member_header (library_member_header, file, fatal_error);
          IF fatal_error THEN
            RETURN;
          IFEND;

          panel_module_procedure := #PTR (library_member_header^.member, file^);
          IF panel_module_procedure = NIL THEN
            error (' ', premature_end_of_file, 33, occ$end_of_line);
            RETURN;
          IFEND;

          ocp$output ('0', 'form module procedure', 21, occ$end_of_line);
          ocp$output (' ', '~~~~~~~~~~~~~~~~~~~~~', 21, occ$end_of_line);

          hex_dump (#LOC (panel_module_procedure^), library_member_header^.member_size);


        PROCEND process_panel_module_procedure;
?? OLDTITLE ??
?? EJECT ??

        VAR
          application_member_header: ^llt$application_member_header,
          valid_position: boolean,
          i: 1 .. llc$max_modules_in_library,
          load_module_header: ^llt$load_module_header,
          object_text_descriptor: ^llt$object_text_descriptor,
          library_member_header: ^llt$library_member_header;


        ocp$output ('1', '  ', 2, occ$end_of_line);

        FOR i := 1 TO number_of_modules DO
          ocp$output (' ', 'module:', 7, occ$continue);
          ocp$output (' ', module_dictionary^ [i].name, STRLENGTH (module_dictionary^ [i].name),
                occ$end_of_line);

          CASE module_dictionary^ [i].kind OF

          = llc$load_module =
            load_module_header := #PTR (module_dictionary^ [i].module_header, file^);
            IF load_module_header = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
            IFEND;
            process_load_module (load_module_header, file);

          = llc$ppu_object_module =
            object_text_descriptor := #PTR (module_dictionary^ [i].ppu_header, file^);
            IF object_text_descriptor = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
            IFEND;
            RESET file TO object_text_descriptor;
            process_ppu_object_module (file);

          = llc$program_description =
            library_member_header := #PTR (module_dictionary^ [i].program_header, file^);
            IF library_member_header = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
            IFEND;
            process_program_description (library_member_header, file);

          = llc$command_procedure =
            library_member_header := #PTR (module_dictionary^ [i].command_header, file^);
            IF library_member_header = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
            IFEND;
            process_command_procedure (library_member_header, file);

          = llc$command_description =
            library_member_header := #PTR (module_dictionary^ [i].command_description_header, file^);
            IF library_member_header = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
            IFEND;
            process_command_description (library_member_header, file);

          = llc$function_procedure =
            library_member_header := #PTR (module_dictionary^ [i].function_header, file^);
            IF library_member_header = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
            IFEND;
            process_function_procedure (library_member_header, file);

          = llc$function_description =
            library_member_header := #PTR (module_dictionary^ [i].function_description_header, file^);
            IF library_member_header = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
            IFEND;
            process_function_description (library_member_header, file);

          = llc$message_module =
            library_member_header := #PTR (module_dictionary^ [i].message_header, file^);
            IF library_member_header = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
            IFEND;
            process_msg_module_procedure (library_member_header, file);

          = llc$panel_module =
            library_member_header := #PTR (module_dictionary^ [i].panel_header, file^);
            IF library_member_header = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
            IFEND;
            process_panel_module_procedure (library_member_header, file);

          = llc$applic_command_procedure =
            application_member_header := #PTR (module_dictionary^ [i].applic_command_header, file^);
            IF application_member_header = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
            IFEND;
            process_applic_command_proc (application_member_header, file);

          = llc$applic_program_description =
            application_member_header := #PTR (module_dictionary^ [i].applic_program_header, file^);
            IF application_member_header = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
            IFEND;
            process_applic_program_descrip (application_member_header, file);

          = llc$applic_command_description =
            application_member_header := #PTR (module_dictionary^ [i].applic_command_description_hdr, file^);
            IF application_member_header = NIL THEN
              error (' ', premature_end_of_file, 33, occ$end_of_line);
            IFEND;
            process_applic_command_descrip (application_member_header, file);

          ELSE

{ error already flagged

          CASEND;

          ocp$output ('1', '  ', 2, occ$end_of_line);
        FOREND;


      PROCEND process_library_modules;
?? OLDTITLE ??
?? EJECT ??

      VAR
        library_header: ^llt$object_library_header,
        library_hdr: ^llt$object_library_header_v1_0,
        entry_point_dictionary: ^llt$entry_point_dictionary,
        command_dictionary: ^llt$command_dictionary,
        function_dictionary: ^llt$function_dictionary,
        help_module_dictionary: ^llt$help_module_dictionary,
        message_module_dictionary: ^llt$message_module_dictionary,
        panel_dictionary: ^llt$panel_dictionary,
        module_dictionary: ^llt$module_dictionary,
        module_dictionary_size: 0 .. llc$max_modules_in_library,
        dictionary_size: integer,
        library_dictionary: ^llt$object_library_dictionaries,
        i: 0 .. llc$max_dictionaries_on_library;


      NEXT library_header IN file;
      IF library_header = NIL THEN
        error (' ', premature_end_of_file, 33, occ$end_of_line);
        RETURN;
      IFEND;

      ocp$output ('-', 'object library version:', 23, occ$continue);
      ocp$output (' ', library_header^.version, STRLENGTH (library_header^.version), occ$end_of_line);

      IF library_header^.version = llc$object_library_version THEN
        NEXT library_dictionary: [1 .. library_header^.number_of_dictionaries] IN file;
        IF library_dictionary = NIL THEN
          error (' ', premature_end_of_file, 33, occ$end_of_line);
          RETURN;
        IFEND;

        FOR i := LOWERBOUND (library_dictionary^) TO UPPERBOUND (library_dictionary^) DO

          CASE library_dictionary^ [i].kind OF

          = llc$module_dictionary =
            module_dictionary := #PTR (library_dictionary^ [i].module_dictionary, file^);
            dictionary_size := UPPERBOUND (module_dictionary^);
            STRINGREP (strng, length, dictionary_size);
            ocp$output (' ', 'number of modules:', 18, occ$continue);
            ocp$output (' ', strng, length, occ$end_of_line);

          = llc$entry_point_dictionary =
            entry_point_dictionary := #PTR (library_dictionary^ [i].entry_point_dictionary, file^);
            dictionary_size := UPPERBOUND (entry_point_dictionary^);
            STRINGREP (strng, length, dictionary_size);
            ocp$output (' ', 'number of entry points:', 24, occ$continue);
            ocp$output (' ', strng, length, occ$end_of_line);

          = llc$command_dictionary =
            command_dictionary := #PTR (library_dictionary^ [i].command_dictionary, file^);
            dictionary_size := UPPERBOUND (command_dictionary^);
            STRINGREP (strng, length, dictionary_size);
            ocp$output (' ', 'number of commands:', 19, occ$continue);
            ocp$output (' ', strng, length, occ$end_of_line);

          = llc$function_dictionary =
            function_dictionary := #PTR (library_dictionary^ [i].function_dictionary, file^);
            dictionary_size := UPPERBOUND (function_dictionary^);
            STRINGREP (strng, length, dictionary_size);
            ocp$output (' ', 'number of functions:', 20, occ$continue);
            ocp$output (' ', strng, length, occ$end_of_line);

          = llc$help_module_dictionary =
            help_module_dictionary := #PTR (library_dictionary^ [i].help_module_dictionary, file^);
            dictionary_size := UPPERBOUND (help_module_dictionary^);
            STRINGREP (strng, length, dictionary_size);
            ocp$output (' ', 'number of help modules:', 23, occ$continue);
            ocp$output (' ', strng, length, occ$end_of_line);

          = llc$message_module_dictionary =
            message_module_dictionary := #PTR (library_dictionary^ [i].message_module_dictionary, file^);
            dictionary_size := UPPERBOUND (message_module_dictionary^);
            STRINGREP (strng, length, dictionary_size);
            ocp$output (' ', 'number of message modules:', 26, occ$continue);
            ocp$output (' ', strng, length, occ$end_of_line);

          = llc$panel_dictionary =
            panel_dictionary := #PTR (library_dictionary^ [i].panel_dictionary, file^);
            dictionary_size := UPPERBOUND (panel_dictionary^);
            STRINGREP (strng, length, dictionary_size);
            ocp$output (' ', 'number of forms:', 16, occ$continue);
            ocp$output (' ', strng, length, occ$end_of_line);

          CASEND;

        FOREND;


        FOR i := LOWERBOUND (library_dictionary^) TO UPPERBOUND (library_dictionary^) DO

          CASE library_dictionary^ [i].kind OF

          = llc$module_dictionary =
            module_dictionary := #PTR (library_dictionary^ [i].module_dictionary, file^);
            module_dictionary_size := UPPERBOUND (module_dictionary^);
            dictionary_size := UPPERBOUND (module_dictionary^);
            process_module_dictionary (dictionary_size, module_dictionary);

          = llc$entry_point_dictionary =
            entry_point_dictionary := #PTR (library_dictionary^ [i].entry_point_dictionary, file^);
            dictionary_size := UPPERBOUND (entry_point_dictionary^);
            process_entry_point_dictionary (dictionary_size, entry_point_dictionary);

          = llc$command_dictionary =
            command_dictionary := #PTR (library_dictionary^ [i].command_dictionary, file^);
            dictionary_size := UPPERBOUND (command_dictionary^);
            process_command_dictionary (dictionary_size, command_dictionary);

          = llc$function_dictionary =
            function_dictionary := #PTR (library_dictionary^ [i].function_dictionary, file^);
            dictionary_size := UPPERBOUND (function_dictionary^);
            process_function_dictionary (dictionary_size, function_dictionary);

          = llc$help_module_dictionary =
            help_module_dictionary := #PTR (library_dictionary^ [i].help_module_dictionary, file^);
            dictionary_size := UPPERBOUND (help_module_dictionary^);
            process_help_module_dictionary (dictionary_size, help_module_dictionary);

          = llc$message_module_dictionary =
            message_module_dictionary := #PTR (library_dictionary^ [i].message_module_dictionary, file^);
            dictionary_size := UPPERBOUND (message_module_dictionary^);
            process_msg_module_dictionary (dictionary_size, message_module_dictionary);

          = llc$panel_dictionary =
            panel_dictionary := #PTR (library_dictionary^ [i].panel_dictionary, file^);
            dictionary_size := UPPERBOUND (panel_dictionary^);
            process_panel_dictionary (dictionary_size, panel_dictionary);

          CASEND;

        FOREND;

        process_library_modules (module_dictionary_size, module_dictionary, file);

      ELSEIF library_header^.version = 'V1.0' THEN

        RESET file;
        NEXT library_hdr IN file;

        STRINGREP (strng, length, library_hdr^.number_of_modules);
        ocp$output (' ', 'number of modules:', 18, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

        STRINGREP (strng, length, library_hdr^.number_of_entry_points);
        ocp$output (' ', 'number of entry points:', 23, occ$continue);
        ocp$output (' ', strng, length, occ$end_of_line);

        module_dictionary := #PTR (library_hdr^.module_dictionary, file^);
        IF module_dictionary = NIL THEN
          error (' ', premature_end_of_file, 33, occ$end_of_line);
          RETURN;
        IFEND;

        process_module_dictionary (library_hdr^.number_of_modules, module_dictionary);

        entry_point_dictionary := #PTR (library_hdr^.entry_point_dictionary, file^);
        IF entry_point_dictionary = NIL THEN
          error (' ', premature_end_of_file, 33, occ$end_of_line);
          RETURN;
        IFEND;

        process_entry_point_dictionary (library_hdr^.number_of_entry_points, entry_point_dictionary);

        process_library_modules (library_hdr^.number_of_modules, module_dictionary, file);

      ELSE
        error (' ', 'INVALID OBJECT LIBRARY VERSION', 30, occ$end_of_line);
        RETURN;
      IFEND;

    PROCEND process_object_library;
?? OLDTITLE ??
?? NEWTITLE := '  ERROR', EJECT ??

    PROCEDURE error
      (    filler: string ( * );
           error_strng: string ( * );
           size: oct$output_line_size;
           end_of_line: boolean);


      VAR
        strng: string (255),
        length: integer;


      IF NOT error_header_printed THEN
        ocp$output (occ$double_space, '**** ERROR', 10, occ$continue);

        number_of_errors_detected := number_of_errors_detected + 1;
        STRINGREP (strng, length, number_of_errors_detected);
        ocp$output ('', strng (1, length), length, occ$continue);

        ocp$output ('', ' - ', 3, occ$continue);
        error_header_printed := TRUE;
      IFEND;

      ocp$output (filler, error_strng, size, occ$continue);

      IF end_of_line THEN
        ocp$output ('', '.', 1, occ$end_of_line);
        error_header_printed := FALSE;
      IFEND;


    PROCEND error;
?? OLDTITLE ??
?? NEWTITLE := '  WARNING', EJECT ??

    PROCEDURE warning
      (    filler: string ( * );
           warning_strng: string ( * );
           size: oct$output_line_size;
           end_of_line: boolean);


      VAR
        out_string: string (121),
        str_length: integer;


      IF NOT warning_header_printed THEN
        ocp$output (occ$double_space, '**** WARNING', 12, occ$continue);

        number_of_warnings_detected := number_of_warnings_detected + 1;
        STRINGREP (out_string, str_length, number_of_warnings_detected);
        ocp$output ('', out_string (1, str_length), str_length, occ$continue);

        ocp$output ('', ' - ', 3, occ$continue);
        warning_header_printed := TRUE;
      IFEND;

      ocp$output (filler, warning_strng, size, occ$continue);

      IF end_of_line THEN
        ocp$output ('', '.', 1, occ$end_of_line);
        warning_header_printed := FALSE;
      IFEND;


    PROCEND warning;
?? OLDTITLE ??
?? NEWTITLE := '  OBTAIN_OBJECT_FILE' ??
?? EJECT ??

    PROCEDURE obtain_object_file
      (    file_reference: fst$file_reference;
       VAR file_name: ost$name;
       VAR file: ^SEQ ( * );
       VAR file_contents: amt$file_contents;
       VAR status: ost$status);

      VAR
        attachment_options: array [1 .. 3] of fst$attachment_option,
        cycle_attribute_values: fst$cycle_attribute_values,
        file_id: amt$file_identifier,
        ignore_user_defined_attr_size: fst$user_defined_attribute_size,
        resolved_file_reference: fst$resolved_file_reference,
        segment: amt$segment_pointer,
        validation_attributes: array [1 .. 2] of fst$file_cycle_attribute;


      validation_attributes [1].selector := fsc$file_contents_and_processor;
      validation_attributes [1].file_contents := fsc$object_library;
      validation_attributes [1].file_processor := osc$null_name;
      validation_attributes [2].selector := fsc$file_contents_and_processor;
      validation_attributes [2].file_contents := fsc$object_data;
      validation_attributes [2].file_processor := osc$null_name;
      attachment_options [1].selector := fsc$access_and_share_modes;
      attachment_options [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options [1].access_modes.value := $fst$file_access_options [fsc$read];
      attachment_options [1].share_modes.selector := fsc$specific_share_modes;
      attachment_options [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
      attachment_options [2].selector := fsc$open_share_modes;
      attachment_options [2].open_share_modes := $fst$file_access_options [fsc$read, fsc$execute];
      attachment_options [3].selector := fsc$create_file;
      attachment_options [3].create_file := FALSE;

      fsp$open_file (file_reference, amc$segment, ^attachment_options, NIL, NIL, ^validation_attributes, NIL,
            file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fsp$get_open_information (file_id, NIL, NIL, NIL, ^cycle_attribute_values, NIL,
            ^resolved_file_reference, NIL, ignore_user_defined_attr_size, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      file_name := resolved_file_reference.path (resolved_file_reference.file_name.index,
            resolved_file_reference.file_name.size);
      file_contents := cycle_attribute_values.file_contents;

      amp$get_segment_pointer (file_id, amc$sequence_pointer, segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      file := segment.sequence_pointer;
      RESET file;

    PROCEND obtain_object_file;
?? OLDTITLE ??
?? EJECT ??

{ PROCEDURE (ocm$disot) display_object_text, disot (
{   file, f: file = lgo
{   output, o: file = $output
{   display_hex_records, dhr: boolean = true
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 4, 7, 14, 0, 9, 538],
    clc$command, 7, 4, 0, 0, 0, 0, 4, 'OCM$DISOT'], [
    ['DHR                            ',clc$abbreviation_entry, 3],
    ['DISPLAY_HEX_RECORDS            ',clc$nominal_entry, 3],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    'lgo'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$output = 2,
      p$display_hex_records = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;


    VAR
      file_name: ost$name,
      file_contents: amt$file_contents,
      file: ^SEQ ( * ),
      page_header: string (59),
      strng: string (121),
      length: integer,
      record_number: integer,
      warning_header_printed: [STATIC] boolean := FALSE,
      number_of_warnings_detected: [STATIC] integer := 0,
      error_header_printed: [STATIC] boolean := FALSE,
      number_of_errors_detected: [STATIC] integer := 0;

    VAR
      display_hex_records: boolean,
      module_info: record
        version: string (4),
        greatest_section_ordinal: llt$section_ordinal,
        section_definition: ^array [0 .. * ] of ^llt$section_definition,
      recend;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_hex_records := pvt [p$display_hex_records].value^.boolean_value.value;

    ocp$initialize_oc_environment (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    obtain_object_file (pvt [p$file].value^.file_value^, file_name, file, file_contents, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    page_header (1, * ) := 'OBJECT LISTING of ******* - ';
    IF file_contents = fsc$object_library THEN
      page_header (19, 7) := 'LIBRARY';
    ELSE
      page_header (19, 7) := ' FILE  ';
    IFEND;
    page_header (29, 31) := file_name;

    ocp$open_output_file (pvt [p$output].value^.file_value^, ^page_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF file_contents = fsc$object_library THEN
      process_object_library (file);
    ELSE
      process_object_file (file);
    IFEND;

    STRINGREP (strng, length, number_of_warnings_detected);
    ocp$output ('0', '  NUMBER OF WARNINGS DETECTED:', 30, occ$continue);
    ocp$output (' ', strng, length, occ$end_of_line);

    STRINGREP (strng, length, number_of_errors_detected);
    ocp$output ('0', '  NUMBER OF ERRORS DETECTED:', 28, occ$continue);
    ocp$output (' ', strng, length, occ$end_of_line);
    ocp$output (' ', '  ', 2, occ$end_of_line);
    ocp$output (' ', '  ', 2, occ$end_of_line);

    ocp$close_output_file (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND ocp$list_object_file;
?? OLDTITLE ??
MODEND ocm$list_object_file;
*DECK DECK=OCM$LIST_PROCESSORS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
MODULE ocm$list_processors;




{ PURPOSE:                                }
{   Contains the routines needed by the   }
{   OLG 'structure' commands to modify the}
{   NLM list.                             }

?? PUSH (LISTEXT := ON) ??
*copyc oct$nlm_modification_list
*copyc oct$nlm_replacement_list
*copyc OST$STATUS
?? POP ??
*copyc OSP$SET_STATUS_ABNORMAL

*copyc OCP$ADD_AN_NLM
*copyc OCP$ADD_AN_NLM_TO_LIST
*copyc OCP$DELETE_AN_NLM
*copyc OCP$EXTRACT_NLM_FROM_LIST
*copyc ocv$olg_working_heap
?? NEWTITLE := '  OCP$SEARCH_MODIFICATION_LIST' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$search_modification_list ALIAS 'ocpsml' (module_name: pmt$program_name;
    modification_list: ^oct$nlm_modification_list;
    VAR element_before: ^oct$nlm_modification_list;
    VAR name_found: boolean);




    element_before := modification_list;

    WHILE (element_before^.link <> NIL) DO
      IF (element_before^.link^.nlm^.name = module_name) THEN
        name_found := TRUE;
        RETURN;
      ELSE
        element_before := element_before^.link;
      IFEND;

    WHILEND;

    name_found := FALSE;



  PROCEND ocp$search_modification_list;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$SEARCH_REPLACEMENT_LIST' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$search_replacement_list ALIAS 'ocpsrl' (module_name: pmt$program_name;
    replacement_list: ^oct$nlm_replacement_list;
    VAR element_before: ^oct$nlm_replacement_list;
    VAR name_found: boolean);




    element_before := replacement_list;

    WHILE (element_before^.link <> NIL) DO
      IF (element_before^.link^.nlm^.name = module_name) THEN
        name_found := TRUE;
        RETURN;
      ELSE
        element_before := element_before^.link;
      IFEND;

    WHILEND;

    name_found := FALSE;



  PROCEND ocp$search_replacement_list;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$FREE_NLM_MODIFICATION_LIST' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$free_nlm_modification_list (modification_list: ^oct$nlm_modification_list);


    VAR
      modification: ^oct$nlm_modification_list;


    modification := modification_list^.link;
    modification_list^.link := NIL;

    WHILE modification <> NIL DO
      FREE modification^.nlm IN ocv$olg_working_heap^;

      modification := modification^.link;
    WHILEND;


  PROCEND ocp$free_nlm_modification_list;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$FREE_NLM_REPLACEMENT_LIST' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$free_nlm_replacement_list (replacement_list: ^oct$nlm_replacement_list);


    VAR
      replacement: ^oct$nlm_replacement_list;


    replacement := replacement_list^.link;
    replacement_list^.link := NIL;

    WHILE replacement <> NIL DO
      replacement := replacement^.link;
    WHILEND;


  PROCEND ocp$free_nlm_replacement_list;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$SEARCH_XDCL_LIST' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$search_xdcl_list ALIAS 'ocpsxl' (name: pmt$program_name;
    list: ^oct$external_declaration_list;
    VAR name_found: boolean;
    VAR element_before: ^oct$external_declaration_list);




    element_before := list;

    WHILE (element_before^.link <> NIL) AND (element_before^.link^.name <> name) DO
      element_before := element_before^.link;
    WHILEND;

    name_found := element_before^.link <> NIL;


  PROCEND ocp$search_xdcl_list;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$ADD_ADDITIONS_TO_NLM_LIST' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$add_additions_to_nlm_list ALIAS 'ocpaanl' (after: ^oct$new_library_module_list;
    addition_list: ^oct$nlm_modification_list);


    VAR
      where: ^oct$new_library_module_list,
      next_addition: ^oct$nlm_modification_list;




    next_addition := addition_list^.link;
    where := after;

    WHILE (next_addition <> NIL) DO
      ocp$add_an_nlm (where, next_addition^.nlm);

      where := next_addition^.nlm;

      next_addition := next_addition^.link;
    WHILEND;


  PROCEND ocp$add_additions_to_nlm_list;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$DELETE_LIST_FROM_NLM_LIST' ??
  ?? EJECT ??

  PROCEDURE [XDCL] ocp$delete_list_from_nlm_list ALIAS 'ocpdlnl' (deletion_list: ^oct$nlm_modification_list);


    VAR
      next_deletion: ^oct$nlm_modification_list;




    next_deletion := deletion_list^.link;

    WHILE (next_deletion <> NIL) DO
      ocp$delete_an_nlm (next_deletion^.nlm);

      next_deletion := next_deletion^.link;
    WHILEND;


  PROCEND ocp$delete_list_from_nlm_list;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$REPLACE_INTO_NLM_LIST' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$replace_list_into_nlm_list ALIAS 'ocprlnl' (replacement_list:
    ^oct$nlm_replacement_list);


    VAR
      next_replacement: ^oct$nlm_replacement_list;




    next_replacement := replacement_list^.link;

    WHILE (next_replacement <> NIL) DO
      next_replacement^.nlm^.description := next_replacement^.description;
      next_replacement^.nlm^.changed_info := NIL;

      next_replacement := next_replacement^.link;
    WHILEND;


  PROCEND ocp$replace_list_into_nlm_list;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$REORDER_NLM_LIST' ??
?? EJECT ??




  PROCEDURE [XDCL] ocp$reorder_nlm_list ALIAS 'ocprnl' (after: ^oct$new_library_module_list;
    reorder_list: ^oct$nlm_modification_list);


    VAR
      where: ^oct$new_library_module_list,
      next_reorder: ^oct$nlm_modification_list;


    next_reorder := reorder_list^.link;
    where := after;

    WHILE (next_reorder <> NIL) DO
      ocp$extract_nlm_from_list (next_reorder^.nlm);

      ocp$add_an_nlm_to_list (where, next_reorder^.nlm);

      where := next_reorder^.nlm;

      next_reorder := next_reorder^.link;
    WHILEND;


  PROCEND ocp$reorder_nlm_list;
?? OLDTITLE ??




MODEND ocm$list_processors.
*DECK DECK=OCM$MESSAGE_GENERATOR EXPAND=TRUE
?? RIGHT := 110, PAGESIZE := 60 ??
*copyc OSD$DEFAULT_PRAGMATS
MODULE ocm$message_generator;




{ *callc pmxexit }
{ *callc osxgemg }
?? PUSH (LISTEXT := ON) ??
*copyc OSP$GENERATE_ERROR_MESSAGE
?? POP ??
?? NEWTITLE := 'OCP$GENERATE_MESSAGE', EJECT ??

  PROCEDURE [XDCL] ocp$generate_message (VAR status: ost$status);


    VAR
      local_status: ost$status;




    osp$generate_error_message (status, local_status);

    status.normal := TRUE;


  PROCEND ocp$generate_message;
?? OLDTITLE ??




MODEND ocm$message_generator.
*DECK DECK=OCM$MESSAGE_TEMPLATE_MODULE EXPAND=TRUE
MODULE OCm$message_template_module ALIAS 'OCmsgtm';
?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, KEYW := UPPER, IDENT := LOWER) ??
?? SET (LIST := ON, LISTCTS := OFF) ??

  CONST
    osc$max_template_size = 24 * 80;

  TYPE
    ost$template_array_descriptor = array [1 .. * ] of
      ost$template_list_descriptor,

    ost$template_list_descriptor = record
      condition: ost$status_condition,
      condition_name: ost$name,
      severity: ost$status_severity,
      short_form: ^string ( * <= osc$max_string_size),
      long_form: ^string ( * <= osc$max_string_size),
    recend;

  SECTION
    oss$message_template_descriptor: READ,
    oss$message_template_strings: READ;


  CONST
    osc$max_name_size = 31,
    osc$null_name = '                               ';

  TYPE
    ost$name_size = 1 .. osc$max_name_size;

  TYPE
    ost$name = string (osc$max_name_size);

  TYPE
    ost$status_severity = (osc$informative_status, osc$warning_status,
      osc$error_status, osc$fatal_status, osc$catastrophic_status);

  CONST
    osc$max_condition = 999999,
    osc$status_parameter_delimiter = CHR (31) {Unit Separator} ;

  TYPE
    ost$status_condition = 0 .. osc$max_condition;

  TYPE
    ost$status = record
      case normal: boolean of
      = FALSE =
        identifier: string (2),
        condition: ost$status_condition,
        text: ost$string,
      casend,
    recend;


  CONST
    osc$max_string_size = 256;

  TYPE
    ost$string_size = 0 .. osc$max_string_size;

  TYPE
    ost$string_index = 1 .. osc$max_string_size + 1;

  TYPE
    ost$string = record
      size: ost$string_size,
      value: string (osc$max_string_size),
    recend;

?? EJECT ??
  CONST
    occ$status_id = 'OC',
    occ$status_condition = 530000;

  CONST
    oce$invalid_module_kind = occ$status_condition + 10,
{F Module kind +P invalid.}

    oce$no_section_definition = occ$status_condition + 20,
{F No section_definition for section number +P.}

    oce$offset_mismatch = occ$status_condition + 30,
{F Offset mismatch in predictor.}

    oce$invalid_section_length = occ$status_condition + 40,
{F Section lengths in predictor do not match.}

    oce$no_code_section = occ$status_condition + 50,
{F No code section found for module +P.}

    oce$no_section_maps = occ$status_condition + 60,
{E +P object library generated without section_maps.}

    oce$invalid_container = occ$status_condition + 70,
{F Relocation record container is invalid.}

    oce$invalid_relocation_address = occ$status_condition + 80,
{F Relocation record address field is invalid.}

    oce$unexpected_record_kind = occ$status_condition + 90,
{F Record type +P is unknown.}

    oce$binding_adr_not_found = occ$status_condition + 100,
{F Address formulation record not found for binding section.}

    oce$section_map_invalid_pointer = occ$status_condition + 110,
{F Section map pointer points to middle of +P record.}

    oce$text_record_expected = occ$status_condition + 120,
{F A text, replication, or bit_string_insertion record was expected.}

    oce$id_record_expected = occ$status_condition + 130,
{F Identification record was expected.}

    oce$breaklist_not_sorted = occ$status_condition + 140,
{F Breaklist is not sorted.}

    oce$files_dont_differ = occ$status_condition + 150,
{E Files are identical, correction not generated.}

    oce$bad_metapatch_generated = occ$status_condition + 160,
{F Correction generated produces invalid object library.}

    oce$invalid_library_version = occ$status_condition + 170;
{F Incompatible object library version on file +P.}
?? EJECT ??

  CONST
    number_of_entries_in_530000 = 18;
?? EJECT ??

  VAR
    osv$template_array_530000_p ALIAS 'm530000' : [XDCL, #GATE, READ, oss$message_template_descriptor]
      ^ost$template_array_descriptor := ^osv$template_array_530000,

    osv$template_array_530000: [STATIC, READ, oss$message_template_descriptor]
      ARRAY [1 .. number_of_entries_in_530000] OF ost$template_list_descriptor := [
        [oce$invalid_module_kind, 'oce$invalid_module_kind',
           osc$fatal_status, ^template_line_0, NIL],
        [oce$no_section_definition, 'oce$no_section_definition',
           osc$fatal_status, ^template_line_1, NIL],
        [oce$offset_mismatch, 'oce$offset_mismatch',
           osc$fatal_status, ^template_line_2, NIL],
        [oce$invalid_section_length, 'oce$invalid_section_length',
           osc$fatal_status, ^template_line_3, NIL],
        [oce$no_code_section, 'oce$no_code_section',
           osc$fatal_status, ^template_line_4, NIL],
        [oce$no_section_maps, 'oce$no_section_maps',
           osc$error_status, ^template_line_5, NIL],
        [oce$invalid_container, 'oce$invalid_container',
           osc$fatal_status, ^template_line_6, NIL],
        [oce$invalid_relocation_address, 'oce$invalid_relocation_address',
           osc$fatal_status, ^template_line_7, NIL],
        [oce$unexpected_record_kind, 'oce$unexpected_record_kind',
           osc$fatal_status, ^template_line_8, NIL],
        [oce$binding_adr_not_found, 'oce$binding_adr_not_found',
           osc$fatal_status, ^template_line_9, NIL],
        [oce$section_map_invalid_pointer, 'oce$section_map_invalid_pointer',
           osc$fatal_status, ^template_line_10, NIL],
        [oce$text_record_expected, 'oce$text_record_expected',
           osc$fatal_status, ^template_line_11, NIL],
        [oce$id_record_expected, 'oce$id_record_expected',
           osc$fatal_status, ^template_line_12, NIL],
        [oce$breaklist_not_sorted, 'oce$breaklist_not_sorted',
           osc$fatal_status, ^template_line_13, NIL],
        [oce$files_dont_differ, 'oce$files_dont_differ',
           osc$error_status, ^template_line_14, NIL],
        [oce$bad_metapatch_generated, 'oce$bad_metapatch_generated',
           osc$fatal_status, ^template_line_15, NIL],
        [oce$invalid_library_version, 'oce$invalid_library_version',
           osc$fatal_status, ^template_line_16, NIL],
        [0, '', osc$error_status, NIL, NIL]];
?? EJECT ??

  VAR
    template_line_0: [STATIC, READ, oss$message_template_strings] STRING(23) :=
      'Module kind +P invalid.';

  VAR
    template_line_1: [STATIC, READ, oss$message_template_strings] STRING(44) :=
      'No section_definition for section number +P.';

  VAR
    template_line_2: [STATIC, READ, oss$message_template_strings] STRING(29) :=
      'Offset mismatch in predictor.';

  VAR
    template_line_3: [STATIC, READ, oss$message_template_strings] STRING(42) :=
      'Section lengths in predictor do not match.';

  VAR
    template_line_4: [STATIC, READ, oss$message_template_strings] STRING(36) :=
      'No code section found for module +P.';

  VAR
    template_line_5: [STATIC, READ, oss$message_template_strings] STRING(49) :=
      '+P object library generated without section_maps.';

  VAR
    template_line_6: [STATIC, READ, oss$message_template_strings] STRING(39) :=
      'Relocation record container is invalid.';

  VAR
    template_line_7: [STATIC, READ, oss$message_template_strings] STRING(43) :=
      'Relocation record address field is invalid.';

  VAR
    template_line_8: [STATIC, READ, oss$message_template_strings] STRING(26) :=
      'Record type +P is unknown.';

  VAR
    template_line_9: [STATIC, READ, oss$message_template_strings] STRING(57) :=
      'Address formulation record not found for binding section.';

  VAR
    template_line_10: [STATIC, READ, oss$message_template_strings] STRING(50) :=
      'Section map pointer points to middle of +P record.';

  VAR
    template_line_11: [STATIC, READ, oss$message_template_strings] STRING(65) :=
      'A text, replication, or bit_string_insertion record was expected.';

  VAR
    template_line_12: [STATIC, READ, oss$message_template_strings] STRING(35) :=
      'Identification record was expected.';

  VAR
    template_line_13: [STATIC, READ, oss$message_template_strings] STRING(24) :=
      'Breaklist is not sorted.';

  VAR
    template_line_14: [STATIC, READ, oss$message_template_strings] STRING(46) :=
      'Files are identical, correction not generated.';

  VAR
    template_line_15: [STATIC, READ, oss$message_template_strings] STRING(53) :=
      'Correction generated produces invalid object library.';

  VAR
    template_line_16: [STATIC, READ, oss$message_template_strings] STRING(47) :=
      'Incompatible object library version on file +P.';

MODEND OCm$message_template_module;
*DECK DECK=OCM$MISC_UTILITY_ROUTINES EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$misc_utility_routines;



{ PURPOSE:                             }
{   This module contains miscellaneous }
{   utility routines used by other OCM }
{   modules.                           }

?? PUSH (LISTEXT := ON) ??
*copyc oct$name_list
*copyc pmt$program_name
?? POP ??
?? NEWTITLE := '  OCP$SORT_NAME_LIST', EJECT ??

  PROCEDURE [XDCL] ocp$sort_name_list (VAR name_list: oct$name_list);


    VAR
      cur: ^oct$name_list,
      nxt: ^oct$name_list,
      temp: pmt$program_name;


    cur := name_list.link;

    WHILE cur <> NIL DO
      nxt := cur^.link;

      WHILE nxt <> NIL DO
        IF cur^.name > nxt^.name THEN
          temp := cur^.name;
          cur^.name := nxt^.name;
          nxt^.name := temp;
        IFEND;

        nxt := nxt^.link;
      WHILEND;

      cur := cur^.link;
    WHILEND;


  PROCEND ocp$sort_name_list;
?? OLDTITLE ??
MODEND ocp$misc_utility_routines.
*DECK DECK=OCM$NEW_GLOBAL_OFFSET EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$new_global_offset;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc llt$section_address
*copyc oct$offset_change_list
?? POP ??

*copyc och$new_global_offset

  FUNCTION [XDCL] ocp$new_global_offset (old_offset: llt$section_address_range;
        offset_change_vector: ^oct$offset_change_list): llt$section_address_range;

    VAR
      i: llt$section_offset;

    ocp$new_global_offset := old_offset;
    IF offset_change_vector <> NIL THEN

    /find_entry/
      FOR i := 1 TO UPPERBOUND (offset_change_vector^) DO
        IF old_offset <= offset_change_vector^ [i].offset THEN
          ocp$new_global_offset := old_offset + offset_change_vector^ [i].delta;
          EXIT /find_entry/
        IFEND;
      FOREND /find_entry/;
    IFEND;
  FUNCEND ocp$new_global_offset;
MODEND ocm$new_global_offset;

*DECK DECK=OCM$NEW_OFFSET EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$new_offset;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc llt$section_address
*copyc oct$offset_change_list
?? POP ??

*copyc och$new_offset

  FUNCTION [XDCL] ocp$new_offset (old_offset: llt$section_address_range;
        offset_change_vector: ^oct$offset_change_list): llt$section_address_range;

    VAR
      i: llt$section_offset;

    ocp$new_offset := old_offset;
    IF offset_change_vector <> NIL THEN

    /find_entry/
      FOR i := UPPERBOUND (offset_change_vector^) DOWNTO 1 DO
        IF old_offset >= offset_change_vector^ [i].offset THEN
          ocp$new_offset := old_offset + offset_change_vector^ [i].delta;
          EXIT /find_entry/
        IFEND;
      FOREND /find_entry/;
    IFEND;
  FUNCEND ocp$new_offset;
MODEND ocm$new_offset;
*DECK DECK=OCM$NLM_PROCESSORS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
MODULE ocm$nlm_processors;


{ PURPOSE:                            }
{   To handle all searches, additions,}
{   deletions, removals, and creations}
{   in the New Library Module List.   }
?? PUSH (LISTEXT := ON) ??
*copyc oce$library_generator_errors
*copyc oct$new_library_module_list
*copyc ost$status
?? POP ??
*copyc OSP$SET_STATUS_ABNORMAL
*copyc ocv$nlm_list
*copyc ocv$olg_working_heap
?? NEWTITLE := '  OCP$SEARCH_NLM_LIST' ??
?? EJECT ??

  PROCEDURE {[XDCL]} ocp$search_nlm_list ALIAS 'ocpsnl' (module_name: pmt$program_name;
    VAR nlm: ^oct$new_library_module_list;
    VAR module_found: boolean);




    REPEAT
      nlm := nlm^.f_link;

    UNTIL (nlm^.name = module_name) OR (nlm^.name = osc$null_name);

    module_found := (nlm^.name = module_name);


  PROCEND ocp$search_nlm_list;
?? OLDTITLE ??

?? NEWTITLE := '  OCP$SEARCH_NLM_TREE' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$search_nlm_tree ALIAS 'ocpsnt' (module_name: pmt$program_name;
    VAR nlm: ^oct$new_library_module_list;
    VAR module_found: boolean);

    nlm := ocv$nlm_list;

    REPEAT
      IF module_name = nlm^.name THEN
        module_found := TRUE;
        RETURN;
      ELSE
        IF module_name < nlm^.name THEN
          nlm := nlm^.l_link;
        ELSE
          nlm := nlm^.r_link;
        IFEND;
      IFEND;
    UNTIL nlm = NIL;

    module_found := FALSE;

  PROCEND ocp$search_nlm_tree;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$CREATE_AN_NLM' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$create_an_nlm ALIAS 'ocpcan' (module_description: ^oct$module_description;
    VAR nlm: ^oct$new_library_module_list;
    VAR status: ost$status);


    ALLOCATE nlm IN ocv$olg_working_heap^;
    IF nlm = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_internal_olg_seg_overflow, '', status);
      RETURN;
    IFEND;

    nlm^.name := module_description^.name;
    nlm^.description := module_description;
    nlm^.changed_info := NIL;

    nlm^.f_link := NIL;
    nlm^.b_link := NIL;
    nlm^.r_link := NIL;
    nlm^.l_link := NIL;
    nlm^.t_link := NIL;

  PROCEND ocp$create_an_nlm;
?? OLDTITLE ??

?? NEWTITLE := '  OCP$ADD_AN_NLM' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$add_an_nlm ALIAS 'ocpaan' (module_before: ^oct$new_library_module_list;
    new_nlm: ^oct$new_library_module_list);




    ocp$add_an_nlm_to_list (module_before, new_nlm);

    ocp$add_an_nlm_to_tree (new_nlm);


  PROCEND ocp$add_an_nlm;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$ADD_AN_NLM_TO_LIST' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$add_an_nlm_to_list ALIAS 'ocpantl' (module_before: ^oct$new_library_module_list;
    new_nlm: ^oct$new_library_module_list);





    new_nlm^.b_link := module_before;
    new_nlm^.f_link := module_before^.f_link;

    module_before^.f_link^.b_link := new_nlm;
    module_before^.f_link := new_nlm;



  PROCEND ocp$add_an_nlm_to_list;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$ADD_AN_NLM_TO_TREE' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$add_an_nlm_to_tree ALIAS 'ocpantt' (new_nlm: ^oct$new_library_module_list);


    VAR
      nlm: ^oct$new_library_module_list;


    nlm := ocv$nlm_list;

    REPEAT
      IF new_nlm^.name < nlm^.name THEN
        IF nlm^.l_link = NIL THEN
          nlm^.l_link := new_nlm;
          new_nlm^.t_link := nlm;
          RETURN;
        ELSE
          nlm := nlm^.l_link;
        IFEND;
      ELSE
        IF nlm^.r_link = NIL THEN
          nlm^.r_link := new_nlm;
          new_nlm^.t_link := nlm;
          RETURN;
        ELSE
          nlm := nlm^.r_link;
        IFEND;
      IFEND;
    UNTIL FALSE;


  PROCEND ocp$add_an_nlm_to_tree;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$DELETE_AN_NLM' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$delete_an_nlm ALIAS 'ocpdan' (nlm: ^oct$new_library_module_list);


    VAR
      nlm_to_delete: ^oct$new_library_module_list;

    nlm_to_delete := nlm;

    ocp$extract_nlm_from_list (nlm_to_delete);

    ocp$extract_nlm_from_tree (nlm_to_delete);

    FREE nlm_to_delete IN ocv$olg_working_heap^;


  PROCEND ocp$delete_an_nlm;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$EXTRACT_NLM_FROM_LIST' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$extract_nlm_from_list ALIAS 'ocpenfl' (nlm: ^oct$new_library_module_list);




    nlm^.b_link^.f_link := nlm^.f_link;
    nlm^.f_link^.b_link := nlm^.b_link;
    nlm^.b_link := NIL;
    nlm^.f_link := NIL;


  PROCEND ocp$extract_nlm_from_list;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$EXTRACT_NLM_FROM_TREE' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$extract_nlm_from_tree ALIAS 'ocpenft' (nlm: ^oct$new_library_module_list);


    VAR
      nlm_ptr: ^^oct$new_library_module_list,
      next_nlm: ^oct$new_library_module_list;


    IF nlm^.name < nlm^.t_link^.name THEN
      nlm_ptr := ^nlm^.t_link^.l_link;
    ELSE
      nlm_ptr := ^nlm^.t_link^.r_link;
    IFEND;

    IF (nlm^.l_link = NIL) OR (nlm^.r_link = NIL) THEN
      IF (nlm^.l_link = NIL) AND (nlm^.r_link = NIL) THEN
        nlm_ptr^ := NIL;
      ELSE
        IF nlm^.l_link = NIL THEN
          nlm_ptr^ := nlm^.r_link;
          nlm^.r_link^.t_link := nlm^.t_link;
        ELSE
          nlm_ptr^ := nlm^.l_link;
          nlm^.l_link^.t_link := nlm^.t_link;
        IFEND;
      IFEND;
    ELSE
      next_nlm := nlm^.l_link;

      WHILE next_nlm^.r_link <> NIL DO
        next_nlm := next_nlm^.r_link;
      WHILEND;

      next_nlm^.r_link := nlm^.r_link;
      nlm^.r_link^.t_link := next_nlm;

      nlm_ptr^ := nlm^.l_link;
      nlm^.l_link^.t_link := nlm^.t_link;
    IFEND;

    nlm^.l_link := NIL;
    nlm^.r_link := NIL;


  PROCEND ocp$extract_nlm_from_tree;
?? OLDTITLE ??




MODEND ocm$nlm_processors.
*DECK DECK=OCM$NORMALIZE_BINDING_SEC_VALUE EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$normalize_binding_sec_value;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc oce$metapatch_generator_errors
*copyc oct$code_section_directory
*copyc oct$section_directory
*copyc llt$relocation
*copyc ost$status
*copyc osp$set_status_abnormal
*copyc ocp$new_offset
?? POP ??

*copyc och$normalize_binding_sec_value
  PROCEDURE [XDCL] ocp$normalize_binding_sec_value (code_section_directory: oct$code_directory_item;
        module_code_section_directory: ^oct$module_code_sections;
        relocation: llt$relocation_item;
        section_directory: ^oct$section_directory;
    VAR status: ost$status);

    VAR
      two_byte_container: ^packed record
        case boolean of
        = TRUE =
          two_byte: 0 .. 0ffff(16),
        = FALSE =
          sign_bit: boolean,
        casend,
      recend,

      three_byte_container: ^packed record
        case boolean of
        = TRUE =
          three_byte: 0 .. 0ffffff(16),
        = FALSE =
          sign_bit: boolean,
        casend,
      recend,

      halfword_container: ^packed record
        case boolean of
        = TRUE =
          halfword: 0 .. 0ffffffff(16),
        = FALSE =
          sign_bit: boolean,
        casend,
      recend,

      word_container: ^packed record
        case boolean of
        = TRUE =
          word: integer,
        = FALSE =
          sign_bit: boolean,
        casend,
      recend,

      d_field_container: ^packed record
        case boolean of
        = TRUE =
          i_portion: 0 .. 0f(16),
          d_portion: 0 .. 0fff(16),
        = FALSE =
          filler: 0 .. 0f(16),
          sign_bit: boolean,
        casend,
      recend,

      q_field_container: ^packed record
        case boolean of
        = TRUE =
          q_field: oct$q_field,
        = FALSE =
          sign_bit: boolean,
        casend,
      recend,

      long_d_field_container: ^packed record
        case boolean of
        = TRUE =
          long_d_field: 0 .. 0ffffff(16),
        = FALSE =
          sign_bit: boolean,
        casend,
      recend,

      bs_offset: integer,
      bs_field: ^cell,
      i: llt$section_ordinal,
      index: llt$section_ordinal,
      offset: integer,
      ring: integer,
      section_found: boolean,
      segment: integer,
      sign_bit_on: boolean;

    IF code_section_directory.last_entry_number >= code_section_directory.first_entry_number THEN

      i := code_section_directory.first_entry_number;

      REPEAT
        section_found := (module_code_section_directory^ [i].section_ordinal = relocation.section_ordinal);
        i := i + 1;
      UNTIL section_found OR (i > code_section_directory.last_entry_number);

      IF section_found THEN

        index := i - 1;
        offset := #offset (module_code_section_directory^ [index].start_of_section) + relocation.offset;
        ring := #ring (module_code_section_directory^ [index].start_of_section);
        segment := #segment (module_code_section_directory^ [index].start_of_section);
        bs_field := #address (ring, segment, offset);

        CASE relocation.container OF
        = llc$two_bytes =
          two_byte_container := bs_field;
          bs_offset := two_byte_container^.two_byte;
          sign_bit_on := two_byte_container^.sign_bit;

        = llc$three_bytes =
          three_byte_container := bs_field;
          bs_offset := three_byte_container^.three_byte;
          sign_bit_on := three_byte_container^.sign_bit;

        = llc$four_bytes =
          halfword_container := bs_field;
          bs_offset := halfword_container^.halfword;
          sign_bit_on := halfword_container^.sign_bit;

        = llc$eight_bytes =
          word_container := bs_field;
          bs_offset := word_container^.word;
          sign_bit_on := word_container^.sign_bit;

        = llc$180_d_field =
          d_field_container := bs_field;
          bs_offset := d_field_container^.d_portion;
          sign_bit_on := d_field_container^.sign_bit;

        = llc$180_q_field =
          q_field_container := bs_field;
          bs_offset := q_field_container^.q_field;
          sign_bit_on := q_field_container^.sign_bit;

        = llc$180_long_d_field =
          long_d_field_container := bs_field;
          bs_offset := long_d_field_container^.long_d_field;
          sign_bit_on := long_d_field_container^.sign_bit;

        ELSE

          osp$set_status_abnormal (occ$status_id, oce$invalid_container, ' ', status);
          RETURN;
        CASEND;

        CASE relocation.address OF

        = llc$byte_positive =
          ;

        = llc$two_byte_positive =
          bs_offset := bs_offset * 2;

        = llc$four_byte_positive =
          bs_offset := bs_offset * 4;

        = llc$eight_byte_positive =
          bs_offset := bs_offset * 8;

        = llc$byte_signed =
          IF sign_bit_on THEN
            osp$set_status_abnormal (occ$status_id, oce$invalid_relocation_address, ' ', status);
            RETURN;
          IFEND;

        = llc$two_byte_signed =
          bs_offset := bs_offset * 2;
          IF sign_bit_on THEN
            osp$set_status_abnormal (occ$status_id, oce$invalid_relocation_address, ' ', status);
            RETURN;
          IFEND;

        = llc$four_byte_signed =
          bs_offset := bs_offset * 4;
          IF sign_bit_on THEN
            osp$set_status_abnormal (occ$status_id, oce$invalid_relocation_address, ' ', status);
            RETURN;
          IFEND;

        = llc$eight_byte_signed =
          bs_offset := bs_offset * 8;
          IF sign_bit_on THEN
            osp$set_status_abnormal (occ$status_id, oce$invalid_relocation_address, ' ', status);
            RETURN;
          IFEND;

        ELSE
          osp$set_status_abnormal (occ$status_id, oce$invalid_relocation_address, ' ', status);
          RETURN;
        CASEND;

        bs_offset := ocp$new_offset (bs_offset, section_directory^ [relocation.relocating_section].
              section_offset_change_vector);
        CASE relocation.address OF

        = llc$byte_positive, llc$byte_signed =
          ;

        = llc$two_byte_positive, llc$two_byte_signed =
          bs_offset := bs_offset DIV 2;

        = llc$four_byte_positive, llc$four_byte_signed =
          bs_offset := bs_offset DIV 4;

        = llc$eight_byte_positive, llc$eight_byte_signed =
          bs_offset := bs_offset DIV 8;

        ELSE
          ;
        CASEND;

        CASE relocation.container OF

        = llc$two_bytes =
          two_byte_container^.two_byte := bs_offset;

        = llc$three_bytes =
          three_byte_container^.three_byte := bs_offset;

        = llc$four_bytes =
          halfword_container^.halfword := bs_offset;

        = llc$eight_bytes =
          word_container^.word := bs_offset;

        = llc$180_d_field =
          d_field_container^.d_portion := bs_offset;

        = llc$180_q_field =
          q_field_container^.q_field := bs_offset;

        = llc$180_long_d_field =
          long_d_field_container^.long_d_field := bs_offset;

        ELSE
          ;
        CASEND;
      IFEND;
    IFEND;
  PROCEND ocp$normalize_binding_sec_value;
MODEND ocm$normalize_binding_sec_value;
*DECK DECK=OCM$OBJECT_CODE_UTILITY_HELPERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Code Utilities' ??
MODULE ocm$object_code_utility_helpers;



{ PURPOSE:                                 }
{   This module contains global variables  }
{   and routines needed by all object code }
{   utilities.



  VAR
    ocv$nlm_list: [XDCL] ^oct$new_library_module_list,
    ocv$open_file_list: [XDCL] oct$open_file_list,
    ocv$global_display_toggles: [XDCL] oct$display_toggles,
    ocv$olg_scratch_seq: [XDCL] ^oct$olg_scratch_seq,
    ocv$olg_working_heap: [XDCL] ^oct$olg_working_heap;

?? OLDTITLE ??
?? PUSH (LISTEXT := ON) ??
*copyc oct$display_toggles
*copyc oct$new_library_module_list
*copyc oct$olg_scratch_seq
*copyc oct$olg_working_heap
*copyc oct$open_file_list
*copyc ost$status
?? POP ??
*copyc ocp$create_transient_segment

*copyc amp$get_file_attributes

*copyc osp$set_status_abnormal
?? NEWTITLE := '  OCP$INITIALIZE_OLG_WORKING_HEAP', EJECT ??

  PROCEDURE [XDCL] ocp$initialize_olg_working_heap;


    RESET ocv$olg_working_heap^;


    ALLOCATE ocv$nlm_list IN ocv$olg_working_heap^;
    ALLOCATE ocv$nlm_list^.description IN ocv$olg_working_heap^;

    ocv$nlm_list^.name := osc$null_name;
    ocv$nlm_list^.description := NIL;
    ocv$nlm_list^.changed_info := NIL;

    ocv$nlm_list^.f_link := ocv$nlm_list;
    ocv$nlm_list^.b_link := ocv$nlm_list;

    ocv$nlm_list^.r_link := NIL;
    ocv$nlm_list^.l_link := NIL;
    ocv$nlm_list^.t_link := NIL;

  PROCEND ocp$initialize_olg_working_heap;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$INITIALIZE_OC_ENVIRONMENT', EJECT ??

  PROCEDURE [XDCL] ocp$initialize_oc_environment (VAR status: ost$status);


    VAR
      segment_pointer: amt$segment_pointer;


    ocv$open_file_list.name := 'CURRENT';
    ocv$open_file_list.kind := occ$current;
    ocv$open_file_list.link := NIL;


    ocv$global_display_toggles := $oct$display_toggles [occ$display_time_date];


    ocp$create_transient_segment (amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    ocv$olg_scratch_seq := segment_pointer.sequence_pointer;


    ocp$create_transient_segment (amc$heap_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    ocv$olg_working_heap := segment_pointer.heap_pointer;

    ocp$initialize_olg_working_heap;


  PROCEND ocp$initialize_oc_environment;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$GET_RING_BRACKETS', EJECT ??

  PROCEDURE [XDCL] ocp$get_ring_brackets (file_name: amt$local_file_name;
    VAR ring_brackets: amt$ring_attributes;
    VAR status: ost$status);


    VAR
      get_attributes: array [1 .. 1] of amt$get_item,
      local_file: boolean,
      existing_file: boolean,
      contains_data: boolean,
      ring: ost$valid_ring;


    get_attributes [1].key := amc$ring_attributes;

    amp$get_file_attributes (file_name, get_attributes, local_file,
          existing_file, contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    IF get_attributes [1].source <> amc$undefined_attribute THEN
      ring_brackets.r1 := get_attributes [1].ring_attributes.r1;
      ring_brackets.r2 := get_attributes [1].ring_attributes.r2;
      ring_brackets.r3 := get_attributes [1].ring_attributes.r3;

    ELSE
      ring := #ring (#LOC (get_attributes));
      ring_brackets.r1 := ring;
      ring_brackets.r2 := ring;
      ring_brackets.r3 := ring;

    IFEND;


  PROCEND ocp$get_ring_brackets;
?? OLDTITLE ??

MODEND ocm$object_code_utility_helpers.
*DECK DECK=OCM$OBJECT_FILE_HANDLERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
MODULE ocm$object_file_handlers;

{ PURPOSE:
{   Contains the routines for the
{   accessing of object and library
{   files.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc oce$library_generator_errors
*copyc oct$new_library_module_list
*copyc oct$open_file_list
*copyc oct$working_file_list
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$return
*copyc bap$get_phn_via_file_id
*copyc clp$count_list_elements
*copyc clp$validate_local_file_name
*copyc fsp$close_file
*copyc fsp$convert_to_new_contents
*copyc fsp$get_open_information
*copyc fsp$open_file
*copyc fsp$set_file_reference_abnormal
*copyc ocp$build_file_directory
*copyc ocp$build_library_directory
*copyc ocp$build_module_directory
*copyc ocp$build_panel_directory
*copyc ocp$build_scl_directory
*copyc ocp$generate_message
*copyc ocp$search_nlm_tree
*copyc osp$set_status_abnormal
*copyc ocv$olg_scratch_seq
*copyc ocv$olg_working_heap
*copyc ocv$open_file_list
*copyc ocv$return_file_list
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$search_object_file' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$search_object_file
    (    module_name: pmt$program_name;
     VAR module_found: boolean;
     VAR file_descriptor: ^oct$open_file_list);



    FOR file_descriptor^.current_module := file_descriptor^.current_module TO
          UPPERBOUND (file_descriptor^.directory^) DO

      IF module_name = file_descriptor^.directory^ [file_descriptor^.current_module].name THEN
        module_found := TRUE;
        RETURN;
      IFEND;
    FOREND;

    module_found := FALSE;


  PROCEND ocp$search_object_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$search_open_file_list' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$search_open_file_list
    (    file_name: amt$local_file_name;
     VAR file_found: boolean;
     VAR file_descriptor: ^oct$open_file_list);


    file_descriptor := ocv$open_file_list.link;

    WHILE file_descriptor <> NIL DO
      IF file_descriptor^.name = file_name THEN
        file_found := TRUE;
        RETURN;
      ELSE
        file_descriptor := file_descriptor^.link;
      IFEND;
    WHILEND;


    file_found := FALSE;


  PROCEND ocp$search_open_file_list;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$obtain_object_file' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$obtain_object_file
    (    file_name: fst$file_reference;
     VAR file_descriptor: ^oct$open_file_list;
     VAR status: ost$status);

    VAR
      attachment_options: array [1 .. 5] of fst$attachment_option,
      cycle_attributes: fst$cycle_attribute_values,
      file_already_open: boolean,
      file_id: amt$file_identifier,
      ignore_name_is_valid: boolean,
      ignore_path_handle: fmt$path_handle,
      ignore_status: ost$status,
      ignore_user_attributes_size: fst$user_defined_attribute_size,
      local_file_name: amt$local_file_name,
      name_is_path_handle: boolean,
      segment: amt$segment_pointer,
      validation_attributes: array [1 .. 8] of fst$file_cycle_attribute;


    clp$validate_local_file_name (file_name, local_file_name, ignore_path_handle, name_is_path_handle,
          ignore_name_is_valid);
    IF name_is_path_handle THEN
      ocp$search_open_file_list (local_file_name, file_already_open, file_descriptor);
      IF file_already_open THEN
        RETURN;
      IFEND;
    IFEND;

    validation_attributes [1].selector := fsc$file_contents_and_processor;
    validation_attributes [1].file_contents := fsc$object_library;
    validation_attributes [1].file_processor := osc$null_name;
    validation_attributes [2].selector := fsc$file_contents_and_processor;
    validation_attributes [2].file_contents := fsc$object_data;
    validation_attributes [2].file_processor := osc$null_name;

    validation_attributes [3].selector := fsc$file_contents_and_processor;
    validation_attributes [3].file_contents := fsc$screen_form;
    validation_attributes [3].file_processor := osc$null_name;

    validation_attributes [4].selector := fsc$file_contents_and_processor;
    validation_attributes [4].file_contents := fsc$legible_scl_procedure;
    validation_attributes [4].file_processor := osc$null_name;
    validation_attributes [5].selector := fsc$file_contents_and_processor;
    validation_attributes [5].file_contents := fsc$legible_data;
    validation_attributes [5].file_processor := osc$null_name;
    validation_attributes [6].selector := fsc$file_contents_and_processor;
    validation_attributes [6].file_contents := amc$legible;
    validation_attributes [6].file_processor := osc$null_name;
    validation_attributes [7].selector := fsc$file_contents_and_processor;
    validation_attributes [7].file_contents := fsc$data;
    validation_attributes [7].file_processor := osc$null_name;
    validation_attributes [8].selector := fsc$file_contents_and_processor;
    validation_attributes [8].file_contents := fsc$unknown_contents;
    validation_attributes [8].file_processor := osc$null_name;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_options [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
    attachment_options [2].selector := fsc$open_share_modes;
    attachment_options [2].open_share_modes := $fst$file_access_options [fsc$read, fsc$execute];
    attachment_options [3].selector := fsc$sequential_access;
    attachment_options [3].sequential_access := TRUE;
    attachment_options [4].selector := fsc$free_behind;
    attachment_options [4].free_behind := TRUE;
    attachment_options [5].selector := fsc$create_file;
    attachment_options [5].create_file := FALSE;

    fsp$open_file (file_name, amc$segment, ^attachment_options, NIL, NIL, ^validation_attributes, NIL,
          file_id, status);
    IF NOT status.normal THEN
      IF status.condition = ame$new_file_requires_append THEN
        osp$set_status_abnormal ('OC', oce$e_missing_or_empty_file, file_name, status);
      IFEND;
      RETURN;
    IFEND;

    bap$get_phn_via_file_id (file_id, local_file_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$search_open_file_list (local_file_name, file_already_open, file_descriptor);
    IF file_already_open THEN
      fsp$close_file (file_id, ignore_status);
      RETURN;
    IFEND;

    fsp$get_open_information (file_id, NIL, NIL, NIL, ^cycle_attributes, NIL, NIL, NIL,
          ignore_user_attributes_size, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE file_descriptor IN ocv$olg_working_heap^;
    IF file_descriptor = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_internal_olg_seg_overflow, '', status);
      RETURN;
    IFEND;

  /obtain_object_file/
    BEGIN
      file_descriptor^.name := local_file_name;

      IF (cycle_attributes.file_contents = fsc$object_library) OR
            (cycle_attributes.file_contents = fsc$object_data) THEN
        amp$get_segment_pointer (file_id, amc$sequence_pointer, segment, status);
        IF NOT status.normal THEN
          EXIT /obtain_object_file/;
        IFEND;

        file_descriptor^.identifier := file_id;
        IF cycle_attributes.file_contents = fsc$object_data THEN
          file_descriptor^.kind := occ$file;
          ocp$build_file_directory (segment.sequence_pointer, file_descriptor, status);
        ELSE
          file_descriptor^.kind := occ$library;
          ocp$build_library_directory (segment.sequence_pointer, file_descriptor, status);
        IFEND;

      ELSEIF cycle_attributes.file_contents = fsc$screen_form THEN
        amp$get_segment_pointer (file_id, amc$sequence_pointer, segment, status);
        IF NOT status.normal THEN
          EXIT /obtain_object_file/;
        IFEND;

        file_descriptor^.identifier := file_id;
        file_descriptor^.kind := occ$file;
        ocp$build_panel_directory (segment.sequence_pointer, file_descriptor, status);

      ELSE {fsc$legible_scl_procedure or equivalent}

{ Re-open the file for record access.

        fsp$open_file (local_file_name, amc$record, ^attachment_options, NIL, NIL, NIL, NIL,
              file_descriptor^.identifier, status);
        IF NOT status.normal THEN
          EXIT /obtain_object_file/;
        IFEND;

        fsp$close_file (file_id, ignore_status);
        file_id := file_descriptor^.identifier;

        file_descriptor^.kind := occ$library;
        ocp$build_scl_directory (local_file_name, file_descriptor, status);

        file_descriptor^.name := osc$null_name;
        fsp$close_file (file_descriptor^.identifier, ignore_status);
      IFEND;
    END /obtain_object_file/;

    IF NOT status.normal THEN
      fsp$close_file (file_id, ignore_status);
      FREE file_descriptor IN ocv$olg_working_heap^;
      RETURN;
    IFEND;

    file_descriptor^.link := ocv$open_file_list.link;
    ocv$open_file_list.link := file_descriptor;

  PROCEND ocp$obtain_object_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$close_all_open_files' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$close_all_open_files
    (VAR open_file_list: oct$open_file_list);


    VAR
      status: ost$status,
      file: ^oct$open_file_list;


    status.normal := TRUE;
    file := open_file_list.link;

    WHILE file <> NIL DO
      IF file^.name <> osc$null_name THEN
        fsp$close_file (file^.identifier, status);
        IF NOT status.normal THEN
          ocp$generate_message (status);
          status.normal := TRUE;
        IFEND;
      IFEND;

      file := file^.link;
    WHILEND;

    open_file_list.link := NIL;


  PROCEND ocp$close_all_open_files;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$return_files' ??
?? EJECT ??
  PROCEDURE [XDCL] ocp$return_files;

    VAR
      entry: ^oct$return_file_list,
      ignore_status: ost$status,
      next_entry: ^oct$return_file_list;


    IF ocv$return_file_list <> NIL THEN
      entry := ocv$return_file_list;
      REPEAT
        amp$return (entry^.file_name^, ignore_status);
        next_entry := entry^.link;
        FREE entry^.file_name;
        FREE entry;
        entry := next_entry;
      UNTIL entry = NIL;

      ocv$return_file_list := NIL;
    IFEND;

  PROCEND ocp$return_files;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$rewind_working_file_list' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$rewind_working_file_list
    (VAR working_file_list: oct$working_file_list);


    working_file_list.current_file := working_file_list.first_working_file.link;
    working_file_list.current_file^.descriptor^.current_module := 1;


  PROCEND ocp$rewind_working_file_list;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$get_module_from_wfl' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$get_module_from_wfl
    (    working_file_list: oct$working_file_list;
     VAR module_name: pmt$program_name;
     VAR file_descriptor: ^oct$open_file_list);


    IF working_file_list.current_file = NIL THEN
      file_descriptor := NIL;
      module_name := osc$null_name;
    ELSE
      file_descriptor := working_file_list.current_file^.descriptor;
      module_name := file_descriptor^.directory^ [file_descriptor^.current_module].name;
    IFEND;


  PROCEND ocp$get_module_from_wfl;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$skip_module_on_wfl' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$skip_module_on_wfl
    (VAR working_file_list: oct$working_file_list);


    VAR
      module_name: pmt$program_name;


    IF working_file_list.current_file^.descriptor^.current_module >=
          UPPERBOUND (working_file_list.current_file^.descriptor^.directory^) THEN
      working_file_list.current_file := working_file_list.current_file^.link;
      IF working_file_list.current_file <> NIL THEN
        working_file_list.current_file^.descriptor^.current_module := 1;
      IFEND;
    ELSE
      working_file_list.current_file^.descriptor^.current_module :=
            working_file_list.current_file^.descriptor^.current_module + 1;
    IFEND;


  PROCEND ocp$skip_module_on_wfl;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$search_working_file_list' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$search_working_file_list
    (    module_name: pmt$program_name;
     VAR working_file_list: oct$working_file_list;
     VAR module_found: boolean);


    REPEAT
      ocp$search_object_file (module_name, module_found, working_file_list.current_file^.descriptor);
      IF module_found THEN
        RETURN;
      ELSE
        working_file_list.current_file := working_file_list.current_file^.link;
        IF working_file_list.current_file = NIL THEN
          RETURN;
        ELSE
          working_file_list.current_file^.descriptor^.current_module := 1;
        IFEND;
      IFEND;
    UNTIL FALSE;


  PROCEND ocp$search_working_file_list;
?? OLDTITLE ??

MODEND ocm$object_file_handlers;
*DECK DECK=OCM$OBJECT_MODULE_CONVERTER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := '                     NOS/VE : OBJECT MODULE CONVERTER' ??
MODULE ocm$object_module_converter;

{  PURPOSE:                               }
{    This module contains the needed      }
{    declarations to convert multiple 170 }
{    to multiple 180 object modules.      }
?? NEWTITLE := ' Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cyd$debug_symbols
*copyc llt$object_module
*copyc oce$object_converter_exceptions
*copyc oss$job_paged_literal
*copyc pme$program_services_exceptions
?? POP ??
*copyc amp$close
*copyc amp$get_file_attributes
*copyc amp$get_next
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$set_segment_eoi
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc i#move
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := '  OCP$GET_RING_BRACKETS', EJECT ??

  PROCEDURE ocp$get_ring_brackets (file_name: amt$local_file_name;
    VAR ring_brackets: amt$ring_attributes;
    VAR status: ost$status);


    VAR
      get_attributes: array [1 .. 1] of amt$get_item,
      local_file: boolean,
      existing_file: boolean,
      contains_data: boolean,
      ring: ost$valid_ring;


    get_attributes [1].key := amc$ring_attributes;

    amp$get_file_attributes (file_name, get_attributes, local_file, existing_file, contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    IF get_attributes [1].source <> amc$undefined_attribute THEN
      ring_brackets.r1 := get_attributes [1].ring_attributes.r1;
      ring_brackets.r2 := get_attributes [1].ring_attributes.r2;
      ring_brackets.r3 := get_attributes [1].ring_attributes.r3;

    ELSE
      ring := #ring (#LOC (get_attributes));
      ring_brackets.r1 := ring;
      ring_brackets.r2 := ring;
      ring_brackets.r3 := ring;

    IFEND;


  PROCEND ocp$get_ring_brackets;
?? OLDTITLE ??
?? NEWTITLE := '                       CITOII CONVERTER' ??

?? EJECT ??

  PROCEDURE [XDCL, #GATE] citoii (parameter_list: clt$parameter_list;
    VAR status: ost$status);



    PROCEDURE eoi_warning (eoi_warning_condition: integer;
      VAR status: ost$status);

      status.normal := FALSE;
      status_state := eoi_warning_status;
      status.condition := eoi_warning_condition;

    PROCEND eoi_warning;



    PROCEDURE error (error_condition: integer;
          error_string: string ( * );
      VAR status: ost$status);


      osp$set_status_abnormal ('OC', error_condition, error_string, status);


    PROCEND error;
?? OLDTITLE ??
?? NEWTITLE := '                         OBTAIN CI FILE' ??
?? EJECT ??

    PROCEDURE obtain_ci_file (ci_file_name: amt$local_file_name;
      VAR ci_file_identifier: amt$file_identifier;
      VAR ci_input_seg: ^SEQ ( * );
      VAR status: ost$status);




      VAR
        ci_segment: amt$segment_pointer,
        local_file: boolean,
        existing_file: boolean,
        contains_data: boolean,

        dummy: array [1 .. 1] of amt$get_item,

?? FMT (FORMAT := OFF) ??
        file_attributes: [STATIC, READ, oss$job_paged_literal] array [1 .. 2] of amt$access_selection := [
          [amc$access_mode, $pft$usage_selections [pfc$read]],
          [amc$open_position, amc$open_at_boi]];


?? FMT (FORMAT:=ON) ??
        dummy [1].key := amc$access_mode;

      amp$get_file_attributes (ci_file_name, dummy, local_file, existing_file, contains_data, status);

      IF status.normal THEN
        IF contains_data THEN
          amp$open (ci_file_name, amc$segment, ^file_attributes, ci_file_identifier, status);
          IF status.normal THEN
            amp$get_segment_pointer (ci_file_identifier, amc$sequence_pointer, ci_segment, status);
            IF status.normal THEN
              ci_input_seg := ci_segment.sequence_pointer;
              RESET ci_input_seg;
            IFEND;
          IFEND;
        ELSE
          error (oce$missing_or_empty_file, ci_file_name, status);
        IFEND;
      IFEND;


    PROCEND obtain_ci_file;
?? OLDTITLE ??
?? NEWTITLE := '                         OBTAIN II SEQ' ??
?? EJECT ??

    PROCEDURE obtain_ii_seg (ii_file_name: amt$local_file_name;
      VAR ii_file_identifier: amt$file_identifier;
      VAR ii_output_seg: amt$segment_pointer;
      VAR status: ost$status);


      VAR
        file_attributes: array [1 .. 3] of amt$access_selection;


      file_attributes [1].key := amc$access_mode;
      file_attributes [1].access_mode := $pft$usage_selections [pfc$append, pfc$shorten, pfc$read];
      file_attributes [2].key := amc$file_structure;
      file_attributes [2].file_structure := amc$data;
      file_attributes [3].key := amc$file_contents;
      file_attributes [3].file_contents := amc$object;

      amp$open (ii_file_name, amc$segment, ^file_attributes, ii_file_identifier, status);
      IF status.normal THEN
        amp$get_segment_pointer (ii_file_identifier, amc$sequence_pointer, ii_output_seg, status);
        IF status.normal THEN
          RESET ii_output_seg.sequence_pointer;
        IFEND;
      IFEND;


    PROCEND obtain_ii_seg;
?? OLDTITLE ??
?? NEWTITLE := '                         CONVERT OBJECT FILE' ??
?? NEWTITLE := '                           Address and misc. Constants and Types  ' ??
?? EJECT ??

    PROCEDURE convert_object_file (VAR output_seq {buffer} : ^SEQ ( * );
      VAR status: ost$status);

{   PURPOSE:                             }
{     To convert multiple 170 IOU or PPU }
{     object modules to multiple 180     }
{     object modules.                    }



      { 170 program_name and string types }


      TYPE
        pmt$ci_program_name = packed array [1 .. 112] of half_byte,

        pmt$ci_string = packed array [ * ] of half_byte,

        llt$ci_decl_matching_value = packed record
          upper: half_byte,
          lower_1: 0 .. 0fffffff(16),
          lower_2: 0 .. 0ffffffff(16),
        recend;





      { 170 constants and general types }


      TYPE

        byte = 0 .. 0ff(16),
        half_byte = 0 .. 0f(16),
        two_bytes = 0 .. 0ffff(16),
        word = string (8),
        half_word = string (4);




?? OLDTITLE ??
?? NEWTITLE := '                           CONVERT STRING' ??
?? EJECT ??

      PROCEDURE convert_string (VAR ci_strng: pmt$ci_string;
            starting_char: 0 .. 256;
        VAR ii_string: string ( * ));

        VAR
          string_length: 0 .. 256,
          ii_char_count: 0 .. 256,
          ii_count: integer,
          ci_count: integer,
          ii_strng: ^packed array [1 .. 512] of half_byte;


        string_length := STRLENGTH (ii_string);
        ii_strng := #LOC (ii_string);
        ii_count := 1;
        ci_count := ((starting_char + 4) DIV 5) + ((starting_char - 1) * 3) + 2;

        FOR ii_char_count := 1 TO string_length DO
          ii_strng^ [ii_count] := ci_strng [ci_count];
          ii_strng^ [ii_count + 1] := ci_strng [ci_count + 1];

          ii_count := ii_count + 2;
          IF (ci_count MOD 16) = 15 THEN
            ci_count := ci_count + 4;
          ELSE
            ci_count := ci_count + 3;
          IFEND;
        FOREND;

      PROCEND convert_string;


?? TITLE := '                           CONVERT SET' ??
?? EJECT ??

      PROCEDURE convert_set (ci_cell: ^cell;
            set_length: 1 .. 8;
            ii_cell: ^cell);

{       PURPOSE:                                                   }
{         To convert a 170 'set' ( left justified in a byte ) to a }
{         normal 180 set.                                          }

        VAR
          shifts: 1 .. 4,
          number_of_shifts: 1 .. 4,
          ci_set: ^packed record
            upper: half_byte,
            lower: half_byte,
          recend,
          ii_set: ^0 .. 255;


        ci_set := ci_cell;
        ii_set := ii_cell;


        { right shift set by an integer divide if shift is needed }

        IF set_length < 4 THEN
          number_of_shifts := 4 - set_length;
          ii_set^ := ci_set^.lower;
          FOR shifts := 1 TO number_of_shifts DO
            ii_set^ := ii_set^ DIV 2;
          FOREND;
        ELSE
          ii_set^ := ci_set^.lower;
        IFEND;

      PROCEND convert_set;
?? TITLE := '                           CONVERT BOOLEAN' ??
?? EJECT ??

      PROCEDURE convert_boolean (ci_cell: ^cell;
        VAR ii_boolean: boolean);

{       PURPOSE:                                               }
{         To convert a 170 'boolean' (5th bit in the byte) to  }
{         a normal 180 boolean.                                }


        CONST
          ci_true = 1000(2),
          ci_false = 0000(2);

        VAR
          ci_boolean: ^packed record
            upper: half_byte,
            lower: half_byte,
          recend;


        ci_boolean := ci_cell;

        ii_boolean := (ci_boolean^.lower >= ci_true);

      PROCEND convert_boolean;
?? TITLE := '                           CONVERT INTEGER' ??
?? EJECT ??

      PROCEDURE convert_integer (ci_cell: ^cell;
            ii_cell: ^cell);

{       PURPOSE:                                              }
{         To convert a 170 'integer' to a normal 180 integer. }


        CONST
          ci_negative = 1000(2),
          ii_negative = 1111(2);

        TYPE
          intger = packed record
            case 0 .. 1 of
            = 0 =
              ii_sign_byte: half_byte,
              ci_sign_byte: half_byte,
              rest_of_word: array [1 .. 7] of byte,
            = 1 =
              int: integer,
            casend,
          recend;

        VAR
          ci_intger: ^intger,
          ii_intger: ^intger;


        ci_intger := ci_cell;
        ii_intger := ii_cell;
        ii_intger^ := ci_intger^;

        { check if cc sign bit is on, if so extend the sign }

        IF ci_intger^.ci_sign_byte >= ci_negative THEN
          ii_intger^.ii_sign_byte := ii_negative;
          ii_intger^.int := ii_intger^.int + 1;
        ELSE
          ii_intger^.ii_sign_byte := 0;
        IFEND;

      PROCEND convert_integer;
?? OLDTITLE ??
?? NEWTITLE := '                           CONVERT VERSION 1.1 TEXT' ??
?? NEWTITLE := '                             CONVERT OBJECT TEXT DESCRIPTOR - 1.1' ??
?? EJECT ??

      PROCEDURE convert_version_11_text (ii_identification: ^llt$identification;
        VAR output_seq: ^SEQ ( * );
        VAR status: ost$status);

{ The following *copy is here on purpose.  If it is moved to the beginning of
{ the module, it will not compile given the current implementation.  The problem is that
{ ordinal types llt$object_record_kind and llt$extended_object_record_kind, which is
{ declared in procedure convert_object_file, use some of the same ordinal names.
{ Declaring llt$object_record_kind here means that the ordinal names override the ones
{ with the same names declared in the outer procedure.

*copy llt$object_record_kind

        VAR
          ii_text_descriptor: ^llt$object_text_descriptor;


        PROCEDURE convert_object_text_desc_11 (VAR object_type: llt$object_record_kind;
          VAR size: integer;
          VAR status: ost$status);





          TYPE
            llt$ci_object_text_descriptor = record
              f00: array [1 .. 7] of byte,
              case kind: llt$object_record_kind of
              = llc$identification, llc$section_definition, llc$entry_definition, llc$binding_template,
                llc$transfer_symbol, llc$bit_string_insertion =
                unused: ost$segment_offset, {always 0}

              = llc$libraries =
                f02: array [1 .. 6] of byte,
                number_of_libraries: 1 .. llc$max_libraries,

              = llc$text, llc$replication =
                f03: array [1 .. 4] of byte,
                number_of_bytes: 1 .. osc$max_segment_length,

              = llc$relocation =
                f05: array [1 .. 6] of byte,
                number_of_rel_items: 1 .. llc$max_rel_items,

              = llc$address_formulation =
                f06: array [1 .. 6] of byte,
                number_of_adr_items: 1 .. llc$max_adr_items,

              = llc$external_linkage =
                f07: array [1 .. 6] of byte,
                number_of_ext_items: 1 .. llc$max_ext_items,

              = llc$formal_parameters, llc$actual_parameters, llc$cybil_symbol_table_fragment =
                f08: array [1 .. 4] of byte,
                sequence_length: ost$segment_length,

              = llc$ppu_absolute =
                f09: array [1 .. 6] of byte,
                number_of_words: llt$ppu_address,
              casend,
            recend;




          VAR
            ci_text_descriptor: ^llt$ci_object_text_descriptor;



          NEXT ci_text_descriptor IN ci_input_seg;

          IF ci_text_descriptor <> NIL THEN
            object_type := ci_text_descriptor^.kind;

            NEXT ii_text_descriptor IN output_seq;

            ii_text_descriptor^.kind := ci_text_descriptor^.kind;

            CASE ci_text_descriptor^.kind OF
            = llc$identification, llc$section_definition, llc$entry_definition, llc$binding_template,
                  llc$bit_string_insertion, llc$transfer_symbol =
              ii_text_descriptor^.unused := ci_text_descriptor^.unused;

            = llc$libraries =
              ii_text_descriptor^.number_of_libraries := ci_text_descriptor^.number_of_libraries;
              size := ci_text_descriptor^.number_of_libraries;

            = llc$text, llc$replication =
              ii_text_descriptor^.number_of_bytes := ci_text_descriptor^.number_of_bytes;
              size := ci_text_descriptor^.number_of_bytes;

            = llc$relocation =
              ii_text_descriptor^.number_of_rel_items := ci_text_descriptor^.number_of_rel_items;
              size := ci_text_descriptor^.number_of_rel_items;

            = llc$address_formulation =
              ii_text_descriptor^.number_of_adr_items := ci_text_descriptor^.number_of_adr_items;
              size := ci_text_descriptor^.number_of_adr_items;

            = llc$external_linkage =
              ii_text_descriptor^.number_of_ext_items := ci_text_descriptor^.number_of_ext_items;
              size := ci_text_descriptor^.number_of_ext_items;

            = llc$formal_parameters, llc$actual_parameters, llc$cybil_symbol_table_fragment =
              size := ci_text_descriptor^.sequence_length;

            = llc$ppu_absolute =
              ii_text_descriptor^.number_of_words := ci_text_descriptor^.number_of_words;
              size := ci_text_descriptor^.number_of_words;

            ELSE
              error (oce$invalid_object_record_kind, 'Object Text Descriptor 1.1', status);

            CASEND;

          ELSE
            eoi_warning (oce$missing_rec_or_descriptor, status);

          IFEND;


        PROCEND convert_object_text_desc_11;
?? OLDTITLE ??

?? NEWTITLE := '                             CONVERT IOU OBJECT MODULE' ??
?? NEWTITLE := '                               CONVERT PPU ABSOLUTE ITEM' ??
?? EJECT ??

        PROCEDURE convert_iou_object_module (VAR status: ost$status);




          PROCEDURE convert_ppu_absolute_item (number_of_words: llt$ppu_address;
            VAR status: ost$status);




            { 170 ppu absolute }


            TYPE
              llt$ci_ppu_absolute = record
                executes_on_any_ppu: boolean,
                f01: array [1 .. 7] of byte,

                f02: array [1 .. 7] of byte,
                ppu_number: 0 .. llc$max_ppu_number,

                f03: array [1 .. 6] of byte,
                load_address: llt$ppu_address,

                f04: array [1 .. 6] of byte,
                entry_address: llt$ppu_address,

                text_array: array [ * ] of ppu_text,

              recend,


              ppu_text = record
                f01: array [1 .. 6] of byte,
                text: 0 .. 0ffff(16),

              recend;






            VAR
              ci_ppu: ^llt$ci_ppu_absolute,
              ii_ppu: ^llt$ppu_absolute,
              w: 0 .. llc$max_ppu_size + 1;



            NEXT ci_ppu: [0 .. number_of_words - 1] IN ci_input_seg;

            IF ci_ppu <> NIL THEN

              NEXT ii_ppu: [0 .. number_of_words - 1] IN output_seq;


              convert_boolean (#LOC (ci_ppu^.executes_on_any_ppu), ii_ppu^.executes_on_any_ppu);

              ii_ppu^.ppu_number := ci_ppu^.ppu_number;
              ii_ppu^.load_address := ci_ppu^.load_address;
              ii_ppu^.entry_address := ci_ppu^.entry_address;

              FOR w := 0 TO (number_of_words - 1) DO
                ii_ppu^.text [w] := ci_ppu^.text_array [w].text;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'PPU Record', status);
            IFEND;


          PROCEND convert_ppu_absolute_item;
?? EJECT ??
?? OLDTITLE ??


          VAR
            type_of_obj_record {control} : llt$object_record_kind,
            size: integer;


          convert_object_text_desc_11 (type_of_obj_record, size, status);

          IF status.normal THEN
            CASE type_of_obj_record OF
            = llc$ppu_absolute =
              convert_ppu_absolute_item (size, status);

            ELSE
              error (oce$invalid_ppu_record_kind, 'IOU Object Module', status);

            CASEND;

          ELSE
            error (oce$missing_rec_or_descriptor, 'PPU Descriptor', status);
          IFEND;


        PROCEND convert_iou_object_module;
?? OLDTITLE ??
?? NEWTITLE := '                             CONVERT CPU OBJECT MODULE' ??
?? NEWTITLE := '                               CONVERT LIBRARY DIRECTIVES' ??
?? EJECT ??

        PROCEDURE convert_cpu_object_module (generator_id: llt$module_generator;
          VAR status: ost$status);

{       NOTE:                                    }
{         The parameter 'generator_id' is used }
{         by 'convert_formal_parameters' to      }
{         identify the type of calling procedure.}



          PROCEDURE convert_library_directives (number_of_libraries: 1 .. llc$max_libraries;
            VAR status: ost$status);


            { 170 library directives }


            TYPE
              llt$ci_libraries = array [ * ] of pmt$ci_program_name;


            VAR
              ci_library: ^llt$ci_libraries,
              ii_library: ^llt$libraries,
              l: 1 .. llc$max_libraries + 1;



            NEXT ci_library: [1 .. number_of_libraries] IN ci_input_seg;

            IF ci_library <> NIL THEN
              NEXT ii_library: [1 .. number_of_libraries] IN output_seq;


              FOR l := 1 TO number_of_libraries DO
                convert_string (ci_library^ [l], 1, ii_library^ [l]);
                IF ii_library^ [l] = 'CYBILIB ' THEN
                  ii_library^ [l] := 'CYF$RUN_TIME_LIBRARY';
                IFEND;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Library Record', status);
            IFEND;


          PROCEND convert_library_directives;
?? TITLE := '                               CONVERT SECTION DEFINITION' ??
?? EJECT ??

          PROCEDURE convert_section_definition_item (VAR status: ost$status);



            { 170 section definitions }


            TYPE
              llt$ci_section_definition = record
                f01: array [1 .. 7] of byte,
                kind: llt$section_kind,

                access_attributes: llt$section_access_attributes,
                f02: array [1 .. 7] of byte,

                f03: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f04: half_word,
                length: ost$segment_length,

                allocation_alignment: ost$segment_offset,

                allocation_offset: ost$segment_offset,

                name: pmt$ci_program_name,

              recend;




?? EJECT ??

            CONST
              num_access_attributes = 4;

            VAR
              ci_section: ^llt$ci_section_definition,
              ii_section: ^llt$section_definition;




            NEXT ci_section IN ci_input_seg;

            IF ci_section <> NIL THEN
              NEXT ii_section IN output_seq;


              ii_section^.kind := ci_section^.kind;

              convert_set (#LOC (ci_section^.access_attributes), num_access_attributes, #LOC (ii_section^.
                    access_attributes));

              ii_section^.section_ordinal := ci_section^.section_ordinal;
              ii_section^.length := ci_section^.length;
              convert_integer (#LOC (ci_section^.allocation_alignment), #LOC (ii_section^.
                    allocation_alignment));
              convert_integer (#LOC (ci_section^.allocation_offset), #LOC (ii_section^.allocation_offset));

              convert_string (ci_section^.name, 1, ii_section^.name);

            ELSE
              error (oce$missing_rec_or_descriptor, 'Section Defn. Record', status);
            IFEND;


          PROCEND convert_section_definition_item;
?? TITLE := '                               CONVERT TEXT ITEM' ??
?? EJECT ??

          PROCEDURE convert_text_item (number_of_bytes: 1 .. osc$max_segment_length;
            VAR status: ost$status);



            { 170 text item }


            TYPE
              llt$ci_text = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                byte_array: array [ * ] of text_component,

              recend,

              text_component = record
                f01: array [1 .. 7] of byte,
                byte: 0 .. 255,

              recend;





            VAR
              ci_text: ^llt$ci_text,
              ii_text: ^llt$text,
              b: 1 .. osc$max_segment_length + 1;

?? EJECT ??
            NEXT ci_text: [1 .. number_of_bytes] IN ci_input_seg;

            IF ci_text <> NIL THEN
              NEXT ii_text: [1 .. number_of_bytes] IN output_seq;


              ii_text^.section_ordinal := ci_text^.section_ordinal;
              ii_text^.offset := ci_text^.offset;

              FOR b := 1 TO number_of_bytes DO
                ii_text^.byte [b] := ci_text^.byte_array [b].byte;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Text Record', status);
            IFEND;


          PROCEND convert_text_item;
?? TITLE := '                               CONVERT REPLICATION ITEM' ??
?? EJECT ??

          PROCEDURE convert_replication_item (number_of_bytes: 1 .. osc$max_segment_length;
            VAR status: ost$status);




            { 170 replication item }


            TYPE
              llt$ci_replication = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                f03: half_word,
                increment: 1 .. osc$max_segment_length,

                f04: half_word,
                count: 1 .. osc$max_segment_length,

                byte_array: array [ * ] of replication_text,

              recend,


              replication_text = record
                f01: array [1 .. 7] of byte,
                byte: 0 .. 255,

              recend;

?? EJECT ??

            VAR
              ci_replication: ^llt$ci_replication,
              ii_replication: ^llt$replication,
              b: 1 .. osc$max_segment_length + 1;



            NEXT ci_replication: [1 .. number_of_bytes] IN ci_input_seg;

            IF ci_replication <> NIL THEN
              NEXT ii_replication: [1 .. number_of_bytes] IN output_seq;


              ii_replication^.section_ordinal := ci_replication^.section_ordinal;
              ii_replication^.offset := ci_replication^.offset;
              ii_replication^.increment := ci_replication^.increment;
              ii_replication^.count := ci_replication^.count;

              FOR b := 1 TO number_of_bytes DO
                ii_replication^.byte [b] := ci_replication^.byte_array [b].byte;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Replication Record', status);
            IFEND;


          PROCEND convert_replication_item;
?? TITLE := '                               CONVERT BIT INSERTION ITEM' ??
?? EJECT ??

          PROCEDURE convert_bit_insertion_item (VAR status: ost$status);




            { 170 bit insertion item }


            TYPE
              llt$ci_bit_string_insertion = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                f03: array [1 .. 7] of byte,
                bit_offset: 0 .. 7,

                f04: array [1 .. 7] of byte,
                bit_length: 1 .. 63,

                bit_string: packed array [1 .. 128] of 0 .. 1,

              recend;


            VAR
              ci_bit_insertion: ^llt$ci_bit_string_insertion,
              ii_bit_insertion: ^llt$bit_string_insertion,
              b: 1 .. 128;

?? EJECT ??



            NEXT ci_bit_insertion IN ci_input_seg;

            IF ci_bit_insertion <> NIL THEN
              NEXT ii_bit_insertion IN output_seq;


              ii_bit_insertion^.section_ordinal := ci_bit_insertion^.section_ordinal;
              ii_bit_insertion^.offset := ci_bit_insertion^.offset;
              ii_bit_insertion^.bit_offset := ci_bit_insertion^.bit_offset;
              ii_bit_insertion^.bit_length := ci_bit_insertion^.bit_length;

              FOR b := 1 TO 60 DO
                ii_bit_insertion^.bit_string [b] := ci_bit_insertion^.bit_string [b + 4];
              FOREND;
              FOR b := 61 TO 63 DO
                ii_bit_insertion^.bit_string [b] := ci_bit_insertion^.bit_string [b + 8];
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Bit Insertion Record', status);
            IFEND;


          PROCEND convert_bit_insertion_item;
?? TITLE := '                               CONVERT ADDRESS FORMULATION ITEM' ??
?? EJECT ??

          PROCEDURE convert_addr_formulation_item (addr_upper_bnd: 1 .. llc$max_adr_items;
            VAR status: ost$status);


            { 170 address formulation item }


            TYPE
              llt$ci_address_formulation = record
                f01: array [1 .. 6] of byte,
                value_section: llt$section_ordinal,

                f02: array [1 .. 6] of byte,
                dest_section: llt$section_ordinal,

                item: array [ * ] of llt$ci_address_formulation_item,

              recend,


              llt$ci_address_formulation_item = record
                f01: array [1 .. 7] of byte,
                kind: llt$internal_address_kind,

                f02: half_word,
                value_offset: llt$section_offset,

                f03: half_word,
                dest_offset: llt$section_offset,

              recend;






            VAR
              ci_address: ^llt$ci_address_formulation,
              ii_address: ^llt$address_formulation,
              a: 1 .. llc$max_adr_items + 1;

?? EJECT ??



            NEXT ci_address: [1 .. addr_upper_bnd] IN ci_input_seg;

            IF ci_address <> NIL THEN
              NEXT ii_address: [1 .. addr_upper_bnd] IN output_seq;


              ii_address^.value_section := ci_address^.value_section;
              ii_address^.dest_section := ci_address^.dest_section;

              FOR a := 1 TO addr_upper_bnd DO
                ii_address^.item [a].kind := ci_address^.item [a].kind;
                ii_address^.item [a].value_offset := ci_address^.item [a].value_offset;
                ii_address^.item [a].dest_offset := ci_address^.item [a].dest_offset;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Address Formulation Record', status);
            IFEND;


          PROCEND convert_addr_formulation_item;
?? TITLE := '                               CONVERT EXTERNAL REFERENCE ITEM' ??
?? EJECT ??

          PROCEDURE convert_external_linkage_item (number_of_ext_items: 1 .. llc$max_ext_items;
            VAR status: ost$status);



            { 170 external reference item }


            TYPE
              llt$ci_external_linkage = record
                name: pmt$ci_program_name,

                f00: array [1 .. 7] of byte,
                language: llt$module_generator,

                declaration_matching_required: boolean,
                f01: array [1 .. 7] of byte,

                declaration_matching_value: llt$ci_decl_matching_value,

                item: array [ * ] of llt$ci_external_linkage_item,
              recend,


              llt$ci_external_linkage_item = record
                f02: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f03: half_word,
                offset: llt$section_offset,
                f01: array [1 .. 7] of byte,
                kind: llt$address_kind,

                offset_operand: - osc$maximum_offset .. osc$maximum_offset,

              recend;


?? EJECT ??

            VAR
              ci_external_linkage: ^llt$ci_external_linkage,
              ii_external_linkage: ^llt$external_linkage,
              e: 1 .. llc$max_ext_items + 1;


            NEXT ci_external_linkage: [1 .. number_of_ext_items] IN ci_input_seg;

            IF ci_external_linkage <> NIL THEN
              NEXT ii_external_linkage: [1 .. number_of_ext_items] IN output_seq;

              convert_string (ci_external_linkage^.name, 1, ii_external_linkage^.name);

              ii_external_linkage^.language := ci_external_linkage^.language;
              IF ci_external_linkage^.language = llc$obsolete_cybil THEN
                convert_boolean (#LOC (ci_external_linkage^.declaration_matching_required),
                      ii_external_linkage^.declaration_matching_required);
                ii_external_linkage^.declaration_matching.language_dependent_value :=
                      ci_external_linkage^.declaration_matching_value.lower_1 * 100000000(16) +
                      ci_external_linkage^.declaration_matching_value.lower_2;
              ELSE
                ii_external_linkage^.declaration_matching_required := FALSE;

                ii_external_linkage^.declaration_matching.object_encryption := 0;
                ii_external_linkage^.declaration_matching.source_encryption := 0;
              IFEND;
              FOR e := 1 TO number_of_ext_items DO
                ii_external_linkage^.item [e].kind := ci_external_linkage^.item [e].kind;

                convert_integer (#LOC (ci_external_linkage^.item [e].offset_operand), #LOC
                      (ii_external_linkage^.item [e].offset_operand));

                ii_external_linkage^.item [e].section_ordinal := ci_external_linkage^.item [e].
                      section_ordinal;
                ii_external_linkage^.item [e].offset := ci_external_linkage^.item [e].offset;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'External Reference Record', status);
            IFEND;


          PROCEND convert_external_linkage_item;
?? TITLE := '                               CONVERT ENTRY POINT DEFINITION' ??
?? EJECT ??

          PROCEDURE convert_entry_point_definition (VAR status: ost$status);




            { 170 entry point definition item }


            TYPE
              llt$ci_entry_definition = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                attributes: llt$entry_point_attributes,
                f03: array [1 .. 7] of byte,

                name: pmt$ci_program_name,

                f04: array [1 .. 7] of byte,
                language: llt$module_generator,

                declaration_matching_required: boolean,
                f05: array [1 .. 7] of byte,

                declaration_matching_value: llt$ci_decl_matching_value,

              recend;


            CONST
              num_entry_point_attr = 2;

?? EJECT ??

            VAR
              ci_entry_point: ^llt$ci_entry_definition,
              ii_entry_point: ^llt$entry_definition;



            NEXT ci_entry_point IN ci_input_seg;

            IF ci_entry_point <> NIL THEN
              NEXT ii_entry_point IN output_seq;


              ii_entry_point^.section_ordinal := ci_entry_point^.section_ordinal;
              ii_entry_point^.offset := ci_entry_point^.offset;

              convert_set (#LOC (ci_entry_point^.attributes), num_entry_point_attr, #LOC (ii_entry_point^.
                    attributes));

              convert_string (ci_entry_point^.name, 1, ii_entry_point^.name);

              ii_entry_point^.language := ci_entry_point^.language;
              IF ci_entry_point^.language = llc$obsolete_cybil THEN
                convert_boolean (#LOC (ci_entry_point^.declaration_matching_required),
                      ii_entry_point^.declaration_matching_required);
                ii_entry_point^.declaration_matching.language_dependent_value :=
                      ci_entry_point^.declaration_matching_value.lower_1 * 100000000(16) +
                      ci_entry_point^.declaration_matching_value.lower_2;
              ELSE

                ii_entry_point^.declaration_matching_required := FALSE;

                ii_entry_point^.declaration_matching.object_encryption := 0;
                ii_entry_point^.declaration_matching.source_encryption := 0;
              IFEND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Entry Point Defn. Record', status);
            IFEND;


          PROCEND convert_entry_point_definition;
?? TITLE := '                               CONVERT RELOCATION ITEM' ??
?? EJECT ??

          PROCEDURE convert_relocation_item (number_of_rel_items: 1 .. llc$max_rel_items;
            VAR status: ost$status);



            { relocation item }

            TYPE
              llt$ci_relocation = array [ * ] of llt$ci_relocation_item,


              llt$ci_relocation_item = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                f03: array [1 .. 6] of byte,
                relocating_section: llt$section_ordinal,

                f04: array [1 .. 7] of byte,
                container: llt$relocation_container,

                f05: array [1 .. 7] of byte,
                address: llt$address_type,

              recend;

?? EJECT ??



            VAR
              ci_relocation: ^llt$ci_relocation,
              ii_relocation: ^llt$relocation,
              r: 1 .. llc$max_rel_items + 1;



            NEXT ci_relocation: [1 .. number_of_rel_items] IN ci_input_seg;

            IF ci_relocation <> NIL THEN
              NEXT ii_relocation: [1 .. number_of_rel_items] IN output_seq;

              FOR r := 1 TO number_of_rel_items DO
                ii_relocation^ [r].section_ordinal := ci_relocation^ [r].section_ordinal;
                ii_relocation^ [r].offset := ci_relocation^ [r].offset;
                ii_relocation^ [r].relocating_section := ci_relocation^ [r].relocating_section;
                ii_relocation^ [r].container := ci_relocation^ [r].container;
                ii_relocation^ [r].address := ci_relocation^ [r].address;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Relocation Record', status);
            IFEND;


          PROCEND convert_relocation_item;
?? TITLE := '                               170 Formal & Actual Parameter Items' ??
?? EJECT ??




          { 170 procedure formal parameter description item }


          TYPE
            llt$ci_formal_parameters = record
              procedure_name: pmt$ci_program_name,

            recend;


          { 170 procedure call actual parameters item }


          TYPE
            llt$ci_actual_parameters = record
              callee_name: pmt$ci_program_name,

              f01: array [1 .. 7] of byte,
              language: llt$module_generator,

              f02: array [1 .. 5] of byte,
              line_number_of_call: llt$source_line_number,


            recend,

            llt$ci_source_line_number = packed array [1 .. 64] of half_byte;





?? TITLE := '                               170 Fortran Argument Descriptor' ??
?? EJECT ??
          { 170 fortran argument description: used to describe a }
          { single actual or formal fortran parameter }


          TYPE
            llt$ci_fortran_argument_desc = record
              f01: array [1 .. 7] of byte,
              argument_type: llt$fortran_argument_type,

              string_length: llt$ci_fortran_string_length,

              f02: array [1 .. 7] of byte,
              argument_kind: llt$fortran_argument_kind,

              array_size: llt$ci_fortran_array_size,

              f03: array [1 .. 6] of byte,
              dummy_argument_ordinal: 1 .. llc$max_fortran_arguments,


              f04: array [1 .. 7] of byte,
              mode: llt$argument_usage,
            recend,


            llt$ci_fortran_string_length = packed record
              f01: half_byte,
              attributes: llt$fortran_string_attributes,
              f02: half_byte,
              f03: array [1 .. 6] of byte,

              f04: array [1 .. 6] of byte,
              number_of_characters: llt$fortran_string_size,
            recend,


            llt$ci_fortran_array_size = packed record
              f01: half_byte,
              attributes: llt$fortran_array_attributes,
              f02: half_byte,
              f03: array [1 .. 6] of byte,

              f04: array [1 .. 7] of byte,
              rank: llt$fortran_array_rank,

              f05: half_word,
              number_of_elements: llt$section_length,
            recend;




?? TITLE := '                               CONVERT FORTRAN PARAMETERS' ??
?? EJECT ??

          PROCEDURE convert_fortran_parameters (sequence_length: ost$segment_length;
            VAR parameters: SEQ ( * );
            VAR status: ost$status);


            VAR
              parameter_sequence: ^SEQ ( * ),
              ci_fortran_parameter: ^array [1 .. * ] of llt$ci_fortran_argument_desc,
              ii_fortran_parameter: ^array [1 .. * ] of llt$fortran_argument_desc,
              num_params: integer,
              np: integer;


            num_params := sequence_length DIV #SIZE (llt$ci_fortran_argument_desc);

            NEXT ci_fortran_parameter: [1 .. num_params] IN ci_input_seg;
            IF ci_fortran_parameter = NIL THEN
              error (oce$missing_rec_or_descriptor, 'Fortran Parameters', status);
              RETURN;
            IFEND;

            parameter_sequence := ^parameters;
            RESET parameter_sequence;
            NEXT ii_fortran_parameter: [1 .. num_params] IN parameter_sequence;

            FOR np := 1 TO num_params DO
              ii_fortran_parameter^ [np].argument_type := ci_fortran_parameter^ [np].argument_type;

              ii_fortran_parameter^ [np].string_length.attributes := ci_fortran_parameter^ [np].string_length.
                    attributes;

              ii_fortran_parameter^ [np].string_length.number_of_characters := ci_fortran_parameter^ [np].
                    string_length.number_of_characters;

              ii_fortran_parameter^ [np].argument_kind := ci_fortran_parameter^ [np].argument_kind;

              ii_fortran_parameter^ [np].array_size.attributes := ci_fortran_parameter^ [np].array_size.
                    attributes;

              ii_fortran_parameter^ [np].array_size.rank := ci_fortran_parameter^ [np].array_size.rank;

              ii_fortran_parameter^ [np].array_size.number_of_elements := ci_fortran_parameter^ [np].
                    array_size.number_of_elements;

              ii_fortran_parameter^ [np].dummy_argument_ordinal := ci_fortran_parameter^ [np].
                    dummy_argument_ordinal;

              ii_fortran_parameter^ [np].mode := ci_fortran_parameter^ [np].mode;
            FOREND;


          PROCEND convert_fortran_parameters;
?? TITLE := '                               CONVERT FORMAL PARAMETERS' ??
?? EJECT ??

          PROCEDURE convert_formal_parameters (sequence_length: ost$segment_length;
                type_of_calling_routine {control} : llt$module_generator;
            VAR status: ost$status);



            VAR
              ci_parameter_item: ^llt$ci_formal_parameters,
              ii_parameter_item: ^llt$formal_parameters;



            NEXT ci_parameter_item IN ci_input_seg;

            IF ci_parameter_item <> NIL THEN
              CASE type_of_calling_routine OF
              = llc$fortran =
                ii_text_descriptor^.sequence_length := sequence_length DIV #SIZE
                      (llt$ci_fortran_argument_desc) * #SIZE (llt$fortran_argument_desc);

                NEXT ii_parameter_item: [[REP ii_text_descriptor^.sequence_length OF cell]] IN output_seq;

                convert_fortran_parameters (sequence_length, ii_parameter_item^.specification, status);
              ELSE
                error (oce$invalid_parameter_kind, 'Formal Parameters', status);
              CASEND;

              convert_string (ci_parameter_item^.procedure_name, 1, ii_parameter_item^.procedure_name);

            ELSE
              error (oce$missing_rec_or_descriptor, 'Formal Parameters', status);
            IFEND;


          PROCEND convert_formal_parameters;
?? TITLE := '                               CONVERT ACTUAL PARAMETERS' ??
?? EJECT ??

          PROCEDURE convert_actual_parameters (sequence_length: ost$segment_length;
            VAR status: ost$status);



            VAR
              ci_parameter_item: ^llt$ci_actual_parameters,
              ii_parameter_item: ^llt$actual_parameters;



            NEXT ci_parameter_item IN ci_input_seg;

            IF ci_parameter_item <> NIL THEN
              CASE ci_parameter_item^.language OF
              = llc$fortran =
                ii_text_descriptor^.sequence_length := sequence_length DIV #SIZE
                      (llt$ci_fortran_argument_desc) * #SIZE (llt$fortran_argument_desc);

                NEXT ii_parameter_item: [[REP ii_text_descriptor^.sequence_length OF cell]] IN output_seq;

                convert_fortran_parameters (sequence_length, ii_parameter_item^.specification, status);
              ELSE
                error (oce$invalid_parameter_kind, 'Actual Parameters', status);
              CASEND;

              convert_string (ci_parameter_item^.callee_name, 1, ii_parameter_item^.callee_name);

              ii_parameter_item^.language := ci_parameter_item^.language;

              ii_parameter_item^.line_number_of_call := ci_parameter_item^.line_number_of_call;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Actual Parameters', status);
            IFEND;


          PROCEND convert_actual_parameters;
?? TITLE := '                               170 Debug Symbol Table Declarations' ??
?? EJECT ??

          TYPE
            cyt$ci_cybil_symbol_table_item = packed record
              symbol_name: packed array [1 .. 100] of half_byte,
              next_symbol: symbol_no,
              symtab_no: symbol_no,
              case symbol_type: entry_kinds of

              = var_kind =
                f01: 0 .. 03ff(16),

                f02: half_byte,
                var_type: symbol_no,
                var_length: ost$segment_length,
                base: base_type,
                f03: 0 .. 1ff(16),

                f04: half_byte,
                var_section_ordinal: llt$section_ordinal,
                var_offset: ost$segment_length,
                indirectly_referenced: boolean,

              = cons_kind =
                f05: 0 .. 03ff(16),

                f06: half_byte,
                cons_type: symbol_no,
                f07: 0 .. 0fffffffffff(16),

                f08: half_byte,
                cons_value: integer_range,

              = label_kind =
                f09: 0 .. 03ff(16),

                f10: half_byte,
                line_no: line_number_range,

              = ordinal_kind =
                f11: 0 .. 03ff(16),

                f12: half_byte,
                last_const: symbol_no,
                upper_bound: 0 .. 4095,

              = subrange_kind =
                f13: 0 .. 03ff(16),

                f14: half_byte,
                subtype: symbol_no,
                low_value_type: len_kinds,
                high_value_type: len_kinds,
                f15: 0 .. 0ffffffffff(16),

                f16: half_byte,
                low_value: integer_range,
                f17: 0 .. 7ff(16),

                f18: half_byte,
                high_value: integer_range,

              = proc_kind =
                main_proc: boolean,
                f19: 0 .. 01ff(16),

                f20: half_byte,
                param_list: symbol_no,
                symbol_list: symbol_no,
                f21: 0 .. 0fffffff(16),

                f22: half_byte,
                proc_section_ordinal: llt$section_offset, {************ change for build M **************}
                f24: 0 .. 01fffffff(16),

                f25: half_byte,
                proc_offset: ost$segment_length,
                f23: 0 .. 0fffffff(16),

                f26: half_byte,
                proc_length: ost$segment_length,
                parent_proc: symbol_no,
                f27: 0 .. 0fff(16),

                f28: half_byte,
                return_type: symbol_no,
                f29: 0 .. 0fffffffffff(16),

              = pointer_kind =
                f30: 0 .. 03ff(16),

                f31: half_byte,
                ptr_type: symbol_no,

              = set_kind =
                f32: 0 .. 03ff(16),

                f33: half_byte,
                set_element_type: symbol_no,
                set_len: 0 .. 7fff(16),

              = string_kind =
                len_type: len_kinds,
                f34: 0 .. 00ff(16),

                f35: half_byte,
                string_len: symbol_no,

              = array_kind =
                array_binding: bindkinds,
                array_packing: packattrs,
                length_is_bits: boolean,
                f36: 0 .. 07(16),

                f37: half_byte,
                index_type: symbol_no,
                array_element_type: symbol_no,
                f38: 0 .. 07ffffff(16),

                f39: half_byte,
                element_length: ost$segment_length,

              = record_kind =
                record_binding: bindkinds,
                record_packing: packattrs,
                variation_flag: boolean,
                f40: 0 .. 07(16),

                f41: half_byte,
                first_field: symbol_no,
                record_length: ost$segment_length,
                f42: 0 .. 7ff(16),

                f43: half_byte,
                selector: symbol_no,

              = field_kind =
                f44: 0 .. 03ff(16),

                f45: half_byte,
                field_offset: machine_addr_in_bits_type,
                f46: 0 .. 3ffffff(16),

                f47: half_byte,
                field_length: machine_addr_in_bits_type,
                unit_addressed: boolean,
                field_type: symbol_no,
                f48: 0 .. 1ff(16),

                f49: half_byte,
                next_field: symbol_no,

              = selector_kind =
                f50: 0 .. 03ff(16),

                f51: half_byte,
                variation: symbol_no,
                next_selector: symbol_no,
                f52: 0 .. 0fffffff(16),

                f53: half_byte,
                low_selector: integer_range,
                f54: 0 .. 7ff(16),

                f55: half_byte,
                high_selector: integer_range,

              = heap_kind =
                ,

              = seq_kind =
                ,


              = parameter_kind =
                param_mode: mode_kinds,
                f56: 0 .. 01f(16),

                f57: half_byte,
                param_type: symbol_no,
                next_param: symbol_no,

              = bound_vrec_kind =
                f58: 0 .. 03ff(16),

                f59: half_byte,
                bound_type: symbol_no,

              casend,
            recend,


            cyt$ci_cybil_symbol_table = record
              original_name: pmt$ci_program_name,

              f01: array [1 .. 7] of byte,
              language: llt$module_generator,

              f02: array [1 .. 6] of byte,
              number_of_symbols: symbol_no,
            recend,


            llt$ci_debug_table_fragment = record
              f01: half_word,
              offset: llt$section_offset,
            recend;

          TYPE
            cyt$ii_cybil_symbol_table = record
              original_name: pmt$program_name,
              language: llt$module_generator,
              number_of_symbols: symbol_no,
            recend;

?? TITLE := '                               CONVERT CYBIL SYMBOL TABLE' ??
?? EJECT ??

          PROCEDURE convert_cybil_symbol_table (sequence_length: ost$segment_length;
            VAR status: ost$status);


          PROCEND convert_cybil_symbol_table;
?? TITLE := '                               CONVERT BINDING TEMPLATE ITEM' ??
?? EJECT ??

          PROCEDURE convert_binding_template (VAR status: ost$status);


            { 170 binding section }

            TYPE
              llt$ci_binding_template = record
                f00: half_word,
                binding_offset: llt$section_offset,

                f01: array [1 .. 7] of byte,
                case kind: llt$binding_template_kind of
                = llc$current_module =
                  f02: array [1 .. 6] of byte,
                  section_ordinal: llt$section_ordinal,

                  f03: 0 .. 0ffffffff(16),
                  offset: llt$section_offset,

                  f04: array [1 .. 7] of byte,
                  internal_address: llt$address_kind,

                  f05: array [1 .. 5] of word,

                = llc$external_reference =
                  name: pmt$ci_program_name,

                  f06: array [1 .. 7] of byte,
                  address: llt$address_kind,
                casend,
              recend;

?? EJECT ??

            VAR
              ci_binding: ^llt$ci_binding_template,
              ii_binding: ^llt$binding_template;


            NEXT ci_binding IN ci_input_seg;

            IF ci_binding <> NIL THEN
              NEXT ii_binding IN output_seq;

              ii_binding^.binding_offset := ci_binding^.binding_offset;

              ii_binding^.kind := ci_binding^.kind;

              CASE ci_binding^.kind OF
              = llc$current_module =
                ii_binding^.section_ordinal := ci_binding^.section_ordinal;
                ii_binding^.offset := ci_binding^.offset;
                ii_binding^.internal_address := ci_binding^.internal_address;

              = llc$external_reference =
                convert_string (ci_binding^.name, 1, ii_binding^.name);
                ii_binding^.address := ci_binding^.address;

              CASEND;
            ELSE
              error (oce$missing_rec_or_descriptor, 'Binding Template Record', status);
            IFEND;


          PROCEND convert_binding_template;
?? TITLE := '                               CONVERT TRANSFER SYMBOL ITEM' ??
?? EJECT ??

          PROCEDURE convert_transfer_symbol_item (VAR status: ost$status);



            { 170 transfer symbol }


            TYPE
              llt$ci_transfer_symbol = record
                name: pmt$ci_program_name,

              recend;


            VAR
              ci_transfer_symbol: ^llt$ci_transfer_symbol,
              ii_transfer_symbol: ^llt$transfer_symbol;

            NEXT ci_transfer_symbol IN ci_input_seg;

            IF ci_transfer_symbol <> NIL THEN
              NEXT ii_transfer_symbol IN output_seq;
              convert_string (ci_transfer_symbol^.name, 1, ii_transfer_symbol^.name);

            ELSE
              error (oce$missing_rec_or_descriptor, 'Transfer Symbol Record', status);
            IFEND;


          PROCEND convert_transfer_symbol_item;
?? OLDTITLE ??
?? EJECT ??

          VAR
            type_of_obj_record {control} : llt$object_record_kind,
            size: integer;


          REPEAT
            convert_object_text_desc_11 (type_of_obj_record, size, status);

            IF status.normal THEN

              CASE type_of_obj_record OF
              = llc$identification =
                error (oce$multiple_ident_records, 'CPU Object Module', status);

              = llc$libraries =
                convert_library_directives (size, status);

              = llc$section_definition =
                convert_section_definition_item (status);

              = llc$text =
                convert_text_item (size, status);

              = llc$replication =
                convert_replication_item (size, status);

              = llc$bit_string_insertion =
                convert_bit_insertion_item (status);

              = llc$address_formulation =
                convert_addr_formulation_item (size, status);

              = llc$external_linkage =
                convert_external_linkage_item (size, status);

              = llc$entry_definition =
                convert_entry_point_definition (status);

              = llc$relocation =
                convert_relocation_item (size, status);

              = llc$actual_parameters =
                convert_actual_parameters (size, status);

              = llc$formal_parameters =
                convert_formal_parameters (size, generator_id, status);

              = llc$cybil_symbol_table_fragment =
                convert_cybil_symbol_table (size, status);

              = llc$binding_template =
                convert_binding_template (status);

              = llc$transfer_symbol =
                convert_transfer_symbol_item (status);

              ELSE
                error (oce$invalid_cpu_record_kind, 'CPU Object Module', status);

              CASEND;

            ELSE
              error (status.condition, 'Object Text Descriptor 1.1', status);
            IFEND;

          UNTIL (type_of_obj_record = llc$transfer_symbol) OR (NOT status.normal);


        PROCEND convert_cpu_object_module;
?? TITLE := '                             CONVERT IDENTIFICATION BODY' ??
?? EJECT ??

        PROCEDURE convert_identification_body (ii_identification: ^llt$identification;
          VAR type_of_object_program: llt$module_kind;
          VAR generator_id: llt$module_generator;
          VAR status: ost$status);


          { 170 identification record }


          TYPE
            llt$ci_identification_body = record
              f00: array [1 .. 7] of byte,
              kind: llt$module_kind,

              time_created: ost$ci_time,

              date_created: ost$ci_date,

              f01: array [1 .. 7] of byte,
              attributes: llt$module_attributes,

              f02: array [1 .. 6] of byte,
              greatest_section_ordinal: llt$section_ordinal,

              f03: array [1 .. 7] of byte,
              generator_id: llt$module_generator,

              generator_name_vers: packed array [1 .. 128] of half_byte,

              commentary: packed array [1 .. 128] of half_byte,

            recend;


          CONST
            num_module_attr = 2;




          { 170 return date }


          TYPE
            ost$ci_date = record
              f01: array [1 .. 7] of byte,
              case date_format: ost$date_formats of
              = osc$month_date =
                month: packed array [1 .. 64] of half_byte,

              = osc$mdy_date =
                mdy: packed array [1 .. 64] of half_byte,

              = osc$iso_date =
                iso: packed array [1 .. 64] of half_byte,

              = osc$ordinal_date =
                ordinal: packed array [1 .. 64] of half_byte,

              casend,

            recend;




          { 170 return time }


          TYPE
            ost$ci_time = record
              f01: array [1 .. 7] of byte,
              case time_format: ost$time_formats of
              = osc$ampm_time =
                ampm: packed array [1 .. 48] of half_byte,

              = osc$hms_time =
                hms: packed array [1 .. 48] of half_byte,

              = osc$millisecond_time =
                millisecond: packed array [1 .. 48] of half_byte,

              casend,

            recend;

?? EJECT ??

          VAR
            ci_identification: ^llt$ci_identification_body;



          NEXT ci_identification IN ci_input_seg;

          IF ci_identification <> NIL THEN

            type_of_object_program := ci_identification^.kind;
            ii_identification^.kind := ci_identification^.kind;

            { convert time request return value }

            ii_identification^.time_created.time_format := ci_identification^.time_created.time_format;

            CASE ci_identification^.time_created.time_format OF
            = osc$ampm_time =
              convert_string (ci_identification^.time_created.ampm, 1, ii_identification^.time_created.ampm);

            = osc$hms_time =
              convert_string (ci_identification^.time_created.hms, 1, ii_identification^.time_created.hms);

            = osc$millisecond_time =
              convert_string (ci_identification^.time_created.millisecond, 1, ii_identification^.time_created.
                    millisecond);
            ELSE
              error (pme$invalid_time_format, 'Identification Record', status);

            CASEND;

            IF status.normal THEN

              { convert date request return value }

              ii_identification^.date_created.date_format := ci_identification^.date_created.date_format;

              CASE ci_identification^.date_created.date_format OF
              = osc$month_date =
                convert_string (ci_identification^.date_created.month, 1, ii_identification^.date_created.
                      month);

              = osc$mdy_date =
                convert_string (ci_identification^.date_created.mdy, 1, ii_identification^.date_created.mdy);

              = osc$iso_date =
                convert_string (ci_identification^.date_created.iso, 1, ii_identification^.date_created.iso);

              = osc$ordinal_date =
                convert_string (ci_identification^.date_created.ordinal, 1, ii_identification^.date_created.
                      ordinal);
              ELSE
                error (pme$invalid_date_format, 'Identification Record', status);

              CASEND;

              IF status.normal THEN

                { finish converting identification record }

                convert_set (#LOC (ci_identification^.attributes), num_module_attr, #LOC (ii_identification^.
                      attributes));

                ii_identification^.greatest_section_ordinal := ci_identification^.greatest_section_ordinal;

                ii_identification^.generator_id := ci_identification^.generator_id;
                generator_id := ci_identification^.generator_id;

                IF generator_id = llc$assembler THEN
                  ii_identification^.attributes := ii_identification^.attributes + $llt$module_attributes
                        [llc$nonbindable];
                IFEND;

                IF generator_id = llc$cybil THEN
                  error (oce$invalid_version, 'V1.1 - CYBIL', status);
                  RETURN;
                IFEND;

                convert_string (ci_identification^.generator_name_vers, 1, ii_identification^.
                      generator_name_vers);

                convert_string (ci_identification^.commentary, 1, ii_identification^.commentary);

              IFEND;
            IFEND;
          ELSE
            error (oce$missing_rec_or_descriptor, 'Identification Record', status);
          IFEND;


        PROCEND convert_identification_body;
?? OLDTITLE ??
?? EJECT ??


        VAR
          kind_of_object_module {control} : llt$module_kind,
          module_generator: llt$module_generator;




        convert_identification_body (ii_identification, kind_of_object_module, module_generator, status);

        IF status.normal THEN
          CASE kind_of_object_module OF
          = llc$iou =
            convert_iou_object_module (status);

          = llc$mi_virtual_state, llc$vector_virtual_state, llc$vector_extended_state =
            convert_cpu_object_module (module_generator, status);

          ELSE
            error (oce$invalid_object_module_kind, 'Version 1.1 Text', status);
          CASEND;

        IFEND;

      PROCEND convert_version_11_text;
?? OLDTITLE ??
?? NEWTITLE := '                           CONVERT VERSION 1.2 TEXT' ??
?? NEWTITLE := '                             CONVERT OBJECT TEXT DESCRIPTOR - 1.2' ??
?? EJECT ??

      PROCEDURE convert_version_12_text (ii_identification: ^llt$identification;
        VAR output_seq: ^SEQ ( * );
        VAR status: ost$status);

{ The following *copy is here on purpose.  If it is moved to the beginning of
{ the module, it will not compile given the current implementation.  The problem is that
{ ordinal types llt$object_record_kind and llt$extended_object_record_kind, which is
{ declared in procedure convert_object_file, use some of the same ordinal names.
{ Declaring llt$object_record_kind here means that the ordinal names override the ones
{ with the same names declared in the outer procedure.

*copy llt$object_record_kind



        VAR
          ii_text_descriptor: ^llt$object_text_descriptor;


        PROCEDURE convert_object_text_desc_12 (VAR object_type: llt$object_record_kind;
          VAR size: integer;
          VAR status: ost$status);





          TYPE
            llt$ci_object_text_descriptor = record
              f00: array [1 .. 7] of byte,
              case kind: llt$object_record_kind of
              = llc$identification, llc$section_definition, llc$entry_definition, llc$binding_template,
                llc$transfer_symbol, llc$bit_string_insertion =
                unused: ost$segment_offset, {always 0}

              = llc$libraries =
                f02: array [1 .. 6] of byte,
                number_of_libraries: 1 .. llc$max_libraries,

              = llc$text, llc$replication =
                f03: array [1 .. 4] of byte,
                number_of_bytes: 1 .. osc$max_segment_length,

              = llc$relocation =
                f05: array [1 .. 6] of byte,
                number_of_rel_items: 1 .. llc$max_rel_items,

              = llc$address_formulation =
                f06: array [1 .. 6] of byte,
                number_of_adr_items: 1 .. llc$max_adr_items,

              = llc$external_linkage =
                f07: array [1 .. 6] of byte,
                number_of_ext_items: 1 .. llc$max_ext_items,

              = llc$formal_parameters, llc$actual_parameters, llc$cybil_symbol_table_fragment =
                f08: array [1 .. 4] of byte,
                sequence_length: ost$segment_length,

              = llc$ppu_absolute =
                f09: array [1 .. 6] of byte,
                number_of_words: llt$ppu_address,
              casend,
            recend;




          VAR
            ci_text_descriptor: ^llt$ci_object_text_descriptor;



          NEXT ci_text_descriptor IN ci_input_seg;

          IF ci_text_descriptor <> NIL THEN
            object_type := ci_text_descriptor^.kind;

            NEXT ii_text_descriptor IN output_seq;

            ii_text_descriptor^.kind := ci_text_descriptor^.kind;

            CASE ci_text_descriptor^.kind OF
            = llc$identification, llc$section_definition, llc$entry_definition, llc$binding_template,
                  llc$bit_string_insertion, llc$transfer_symbol =
              ii_text_descriptor^.unused := ci_text_descriptor^.unused;

            = llc$libraries =
              ii_text_descriptor^.number_of_libraries := ci_text_descriptor^.number_of_libraries;
              size := ci_text_descriptor^.number_of_libraries;

            = llc$text, llc$replication =
              ii_text_descriptor^.number_of_bytes := ci_text_descriptor^.number_of_bytes;
              size := ci_text_descriptor^.number_of_bytes;

            = llc$relocation =
              ii_text_descriptor^.number_of_rel_items := ci_text_descriptor^.number_of_rel_items;
              size := ci_text_descriptor^.number_of_rel_items;

            = llc$address_formulation =
              ii_text_descriptor^.number_of_adr_items := ci_text_descriptor^.number_of_adr_items;
              size := ci_text_descriptor^.number_of_adr_items;

            = llc$external_linkage =
              ii_text_descriptor^.number_of_ext_items := ci_text_descriptor^.number_of_ext_items;
              size := ci_text_descriptor^.number_of_ext_items;

            = llc$formal_parameters, llc$actual_parameters =
              size := ci_text_descriptor^.sequence_length;

            = llc$cybil_symbol_table_fragment =
              size := ci_text_descriptor^.sequence_length;
              RESET output_seq TO ii_text_descriptor;

            = llc$ppu_absolute =
              ii_text_descriptor^.number_of_words := ci_text_descriptor^.number_of_words;
              size := ci_text_descriptor^.number_of_words;

            ELSE
              error (oce$invalid_object_record_kind, 'Object Text Descriptor 1.2', status);

            CASEND;

          ELSE
            eoi_warning (oce$missing_rec_or_descriptor, status);

          IFEND;


        PROCEND convert_object_text_desc_12;
?? OLDTITLE ??

?? NEWTITLE := '                             CONVERT IOU OBJECT MODULE' ??
?? NEWTITLE := '                               CONVERT PPU ABSOLUTE ITEM' ??
?? EJECT ??

        PROCEDURE convert_iou_object_module (VAR status: ost$status);




          PROCEDURE convert_ppu_absolute_item (number_of_words: llt$ppu_address;
            VAR status: ost$status);




            { 170 ppu absolute }


            TYPE
              llt$ci_ppu_absolute = record
                executes_on_any_ppu: boolean,
                f01: array [1 .. 7] of byte,

                f02: array [1 .. 7] of byte,
                ppu_number: 0 .. llc$max_ppu_number,

                f03: array [1 .. 6] of byte,
                load_address: llt$ppu_address,

                f04: array [1 .. 6] of byte,
                entry_address: llt$ppu_address,

                text_array: array [ * ] of ppu_text,

              recend,


              ppu_text = record
                f01: array [1 .. 6] of byte,
                text: 0 .. 0ffff(16),

              recend;






            VAR
              ci_ppu: ^llt$ci_ppu_absolute,
              ii_ppu: ^llt$ppu_absolute,
              w: 0 .. llc$max_ppu_size + 1;



            NEXT ci_ppu: [0 .. number_of_words - 1] IN ci_input_seg;

            IF ci_ppu <> NIL THEN

              NEXT ii_ppu: [0 .. number_of_words - 1] IN output_seq;


              convert_boolean (#LOC (ci_ppu^.executes_on_any_ppu), ii_ppu^.executes_on_any_ppu);

              ii_ppu^.ppu_number := ci_ppu^.ppu_number;
              ii_ppu^.load_address := ci_ppu^.load_address;
              ii_ppu^.entry_address := ci_ppu^.entry_address;

              FOR w := 0 TO (number_of_words - 1) DO
                ii_ppu^.text [w] := ci_ppu^.text_array [w].text;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'PPU Record', status);
            IFEND;


          PROCEND convert_ppu_absolute_item;
?? EJECT ??
?? OLDTITLE ??


          VAR
            type_of_obj_record {control} : llt$object_record_kind,
            size: integer;


          convert_object_text_desc_12 (type_of_obj_record, size, status);

          IF status.normal THEN
            CASE type_of_obj_record OF
            = llc$ppu_absolute =
              convert_ppu_absolute_item (size, status);

            ELSE
              error (oce$invalid_ppu_record_kind, 'IOU Object Module', status);

            CASEND;

          ELSE
            error (oce$missing_rec_or_descriptor, 'PPU Descriptor', status);
          IFEND;


        PROCEND convert_iou_object_module;
?? OLDTITLE ??
?? NEWTITLE := '                             CONVERT CPU OBJECT MODULE' ??
?? NEWTITLE := '                               CONVERT LIBRARY DIRECTIVES' ??
?? EJECT ??

        PROCEDURE convert_cpu_object_module (generator_id: llt$module_generator;
          VAR status: ost$status);

{       NOTE:                                    }
{         The parameter 'generator_id' is used }
{         by 'convert_formal_parameters' to      }
{         identify the type of calling procedure.}



          PROCEDURE convert_library_directives (number_of_libraries: 1 .. llc$max_libraries;
            VAR status: ost$status);


            { 170 library directives }


            TYPE
              llt$ci_libraries = array [ * ] of pmt$ci_program_name;


            VAR
              ci_library: ^llt$ci_libraries,
              ii_library: ^llt$libraries,
              l: 1 .. llc$max_libraries + 1;



            NEXT ci_library: [1 .. number_of_libraries] IN ci_input_seg;

            IF ci_library <> NIL THEN
              NEXT ii_library: [1 .. number_of_libraries] IN output_seq;


              FOR l := 1 TO number_of_libraries DO
                convert_string (ci_library^ [l], 1, ii_library^ [l]);
                IF ii_library^ [l] = 'CYBILIB ' THEN
                  ii_library^ [l] := 'CYF$RUN_TIME_LIBRARY';
                IFEND;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Library Record', status);
            IFEND;


          PROCEND convert_library_directives;
?? TITLE := '                               CONVERT SECTION DEFINITION' ??
?? EJECT ??

          PROCEDURE convert_section_definition_item (VAR status: ost$status);



            { 170 section definitions }


            TYPE
              llt$ci_section_definition = record
                f01: array [1 .. 7] of byte,
                kind: llt$section_kind,

                access_attributes: llt$section_access_attributes,
                f02: array [1 .. 7] of byte,

                f03: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f04: half_word,
                length: ost$segment_length,

                allocation_alignment: ost$segment_offset,

                allocation_offset: ost$segment_offset,

                name: pmt$ci_program_name,

              recend;




?? EJECT ??

            CONST
              num_access_attributes = 4;

            VAR
              ci_section: ^llt$ci_section_definition,
              ii_section: ^llt$section_definition;




            NEXT ci_section IN ci_input_seg;

            IF ci_section <> NIL THEN
              NEXT ii_section IN output_seq;


              ii_section^.kind := ci_section^.kind;

              convert_set (#LOC (ci_section^.access_attributes), num_access_attributes, #LOC (ii_section^.
                    access_attributes));

              ii_section^.section_ordinal := ci_section^.section_ordinal;
              ii_section^.length := ci_section^.length;
              convert_integer (#LOC (ci_section^.allocation_alignment), #LOC (ii_section^.
                    allocation_alignment));
              convert_integer (#LOC (ci_section^.allocation_offset), #LOC (ii_section^.allocation_offset));

              convert_string (ci_section^.name, 1, ii_section^.name);

            ELSE
              error (oce$missing_rec_or_descriptor, 'Section Defn. Record', status);
            IFEND;


          PROCEND convert_section_definition_item;
?? TITLE := '                               CONVERT TEXT ITEM' ??
?? EJECT ??

          PROCEDURE convert_text_item (number_of_bytes: 1 .. osc$max_segment_length;
            VAR status: ost$status);



            { 170 text item }


            TYPE
              llt$ci_text = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                byte_array: array [ * ] of text_component,

              recend,

              text_component = record
                f01: array [1 .. 7] of byte,
                byte: 0 .. 255,

              recend;





            VAR
              ci_text: ^llt$ci_text,
              ii_text: ^llt$text,
              b: 1 .. osc$max_segment_length + 1;

?? EJECT ??
            NEXT ci_text: [1 .. number_of_bytes] IN ci_input_seg;

            IF ci_text <> NIL THEN
              NEXT ii_text: [1 .. number_of_bytes] IN output_seq;


              ii_text^.section_ordinal := ci_text^.section_ordinal;
              ii_text^.offset := ci_text^.offset;

              FOR b := 1 TO number_of_bytes DO
                ii_text^.byte [b] := ci_text^.byte_array [b].byte;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Text Record', status);
            IFEND;


          PROCEND convert_text_item;
?? TITLE := '                               CONVERT REPLICATION ITEM' ??
?? EJECT ??

          PROCEDURE convert_replication_item (number_of_bytes: 1 .. osc$max_segment_length;
            VAR status: ost$status);




            { 170 replication item }


            TYPE
              llt$ci_replication = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                f03: half_word,
                increment: 1 .. osc$max_segment_length,

                f04: half_word,
                count: 1 .. osc$max_segment_length,

                byte_array: array [ * ] of replication_text,

              recend,


              replication_text = record
                f01: array [1 .. 7] of byte,
                byte: 0 .. 255,

              recend;

?? EJECT ??

            VAR
              ci_replication: ^llt$ci_replication,
              ii_replication: ^llt$replication,
              b: 1 .. osc$max_segment_length + 1;



            NEXT ci_replication: [1 .. number_of_bytes] IN ci_input_seg;

            IF ci_replication <> NIL THEN
              NEXT ii_replication: [1 .. number_of_bytes] IN output_seq;


              ii_replication^.section_ordinal := ci_replication^.section_ordinal;
              ii_replication^.offset := ci_replication^.offset;
              ii_replication^.increment := ci_replication^.increment;
              ii_replication^.count := ci_replication^.count;

              FOR b := 1 TO number_of_bytes DO
                ii_replication^.byte [b] := ci_replication^.byte_array [b].byte;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Replication Record', status);
            IFEND;


          PROCEND convert_replication_item;
?? TITLE := '                               CONVERT BIT INSERTION ITEM' ??
?? EJECT ??

          PROCEDURE convert_bit_insertion_item (VAR status: ost$status);




            { 170 bit insertion item }


            TYPE
              llt$ci_bit_string_insertion = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                f03: array [1 .. 7] of byte,
                bit_offset: 0 .. 7,

                f04: array [1 .. 7] of byte,
                bit_length: 1 .. 63,

                bit_string: packed array [1 .. 128] of 0 .. 1,

              recend;


            VAR
              ci_bit_insertion: ^llt$ci_bit_string_insertion,
              ii_bit_insertion: ^llt$bit_string_insertion,
              b: 1 .. 128;

?? EJECT ??



            NEXT ci_bit_insertion IN ci_input_seg;

            IF ci_bit_insertion <> NIL THEN
              NEXT ii_bit_insertion IN output_seq;


              ii_bit_insertion^.section_ordinal := ci_bit_insertion^.section_ordinal;
              ii_bit_insertion^.offset := ci_bit_insertion^.offset;
              ii_bit_insertion^.bit_offset := ci_bit_insertion^.bit_offset;
              ii_bit_insertion^.bit_length := ci_bit_insertion^.bit_length;

              FOR b := 1 TO 60 DO
                ii_bit_insertion^.bit_string [b] := ci_bit_insertion^.bit_string [b + 4];
              FOREND;
              FOR b := 61 TO 63 DO
                ii_bit_insertion^.bit_string [b] := ci_bit_insertion^.bit_string [b + 8];
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Bit Insertion Record', status);
            IFEND;


          PROCEND convert_bit_insertion_item;
?? TITLE := '                               CONVERT ADDRESS FORMULATION ITEM' ??
?? EJECT ??

          PROCEDURE convert_addr_formulation_item (addr_upper_bnd: 1 .. llc$max_adr_items;
            VAR status: ost$status);


            { 170 address formulation item }


            TYPE
              llt$ci_address_formulation = record
                f01: array [1 .. 6] of byte,
                value_section: llt$section_ordinal,

                f02: array [1 .. 6] of byte,
                dest_section: llt$section_ordinal,

                item: array [ * ] of llt$ci_address_formulation_item,

              recend,


              llt$ci_address_formulation_item = record
                f01: array [1 .. 7] of byte,
                kind: llt$internal_address_kind,

                value_offset: ost$segment_offset,

                f03: half_word,
                dest_offset: llt$section_offset,

              recend;






            VAR
              ci_address: ^llt$ci_address_formulation,
              ii_address: ^llt$address_formulation,
              a: 1 .. llc$max_adr_items + 1;

?? EJECT ??



            NEXT ci_address: [1 .. addr_upper_bnd] IN ci_input_seg;

            IF ci_address <> NIL THEN
              NEXT ii_address: [1 .. addr_upper_bnd] IN output_seq;


              ii_address^.value_section := ci_address^.value_section;
              ii_address^.dest_section := ci_address^.dest_section;

              FOR a := 1 TO addr_upper_bnd DO
                ii_address^.item [a].kind := ci_address^.item [a].kind;
                convert_integer (#LOC (ci_address^.item [a].value_offset), #LOC (ii_address^.item [a].
                      value_offset));
                ii_address^.item [a].dest_offset := ci_address^.item [a].dest_offset;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Address Formulation Record', status);
            IFEND;


          PROCEND convert_addr_formulation_item;
?? TITLE := '                               CONVERT EXTERNAL REFERENCE ITEM' ??
?? EJECT ??

          PROCEDURE convert_external_linkage_item (number_of_ext_items: 1 .. llc$max_ext_items;
            VAR status: ost$status);



            { 170 external reference item }


            TYPE
              llt$ci_external_linkage = record
                name: pmt$ci_program_name,

                f00: array [1 .. 7] of byte,
                language: llt$module_generator,

                declaration_matching_required: boolean,
                f01: array [1 .. 7] of byte,

                declaration_matching_value: llt$ci_decl_matching_value,

                item: array [ * ] of llt$ci_external_linkage_item,
              recend,


              llt$ci_external_linkage_item = record
                f02: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f03: half_word,
                offset: llt$section_offset,
                f01: array [1 .. 7] of byte,
                kind: llt$address_kind,

                offset_operand: - osc$maximum_offset .. osc$maximum_offset,

              recend;


?? EJECT ??

            VAR
              ci_external_linkage: ^llt$ci_external_linkage,
              ii_external_linkage: ^llt$external_linkage,
              e: 1 .. llc$max_ext_items + 1;


            NEXT ci_external_linkage: [1 .. number_of_ext_items] IN ci_input_seg;

            IF ci_external_linkage <> NIL THEN
              NEXT ii_external_linkage: [1 .. number_of_ext_items] IN output_seq;

              convert_string (ci_external_linkage^.name, 1, ii_external_linkage^.name);

              ii_external_linkage^.language := ci_external_linkage^.language;
              IF ci_external_linkage^.language = llc$obsolete_cybil THEN
                convert_boolean (#LOC (ci_external_linkage^.declaration_matching_required),
                      ii_external_linkage^.declaration_matching_required);
                ii_external_linkage^.declaration_matching.language_dependent_value :=
                      ci_external_linkage^.declaration_matching_value.lower_1 * 100000000(16) +
                      ci_external_linkage^.declaration_matching_value.lower_2;
              ELSE

                ii_external_linkage^.declaration_matching_required := FALSE;

                ii_external_linkage^.declaration_matching.object_encryption := 0;
                ii_external_linkage^.declaration_matching.source_encryption := 0;
              IFEND;
              FOR e := 1 TO number_of_ext_items DO
                ii_external_linkage^.item [e].kind := ci_external_linkage^.item [e].kind;

                convert_integer (#LOC (ci_external_linkage^.item [e].offset_operand), #LOC
                      (ii_external_linkage^.item [e].offset_operand));

                ii_external_linkage^.item [e].section_ordinal := ci_external_linkage^.item [e].
                      section_ordinal;
                ii_external_linkage^.item [e].offset := ci_external_linkage^.item [e].offset;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'External Reference Record', status);
            IFEND;


          PROCEND convert_external_linkage_item;
?? TITLE := '                               CONVERT ENTRY POINT DEFINITION' ??
?? EJECT ??

          PROCEDURE convert_entry_point_definition (VAR status: ost$status);




            { 170 entry point definition item }


            TYPE
              llt$ci_entry_definition = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                attributes: llt$entry_point_attributes,
                f03: array [1 .. 7] of byte,

                name: pmt$ci_program_name,

                f04: array [1 .. 7] of byte,
                language: llt$module_generator,

                declaration_matching_required: boolean,
                f05: array [1 .. 7] of byte,

                declaration_matching_value: llt$ci_decl_matching_value,

              recend;


            CONST
              num_entry_point_attr = 2;

?? EJECT ??

            VAR
              ci_entry_point: ^llt$ci_entry_definition,
              ii_entry_point: ^llt$entry_definition;



            NEXT ci_entry_point IN ci_input_seg;

            IF ci_entry_point <> NIL THEN
              NEXT ii_entry_point IN output_seq;


              ii_entry_point^.section_ordinal := ci_entry_point^.section_ordinal;
              ii_entry_point^.offset := ci_entry_point^.offset;

              convert_set (#LOC (ci_entry_point^.attributes), num_entry_point_attr, #LOC (ii_entry_point^.
                    attributes));

              convert_string (ci_entry_point^.name, 1, ii_entry_point^.name);

              ii_entry_point^.language := ci_entry_point^.language;
              IF ci_entry_point^.language = llc$obsolete_cybil THEN
                convert_boolean (#LOC (ci_entry_point^.declaration_matching_required),
                      ii_entry_point^.declaration_matching_required);
                ii_entry_point^.declaration_matching.language_dependent_value :=
                      ci_entry_point^.declaration_matching_value.lower_1 * 100000000(16) +
                      ci_entry_point^.declaration_matching_value.lower_2;
              ELSE

                ii_entry_point^.declaration_matching_required := FALSE;

                ii_entry_point^.declaration_matching.object_encryption := 0;
                ii_entry_point^.declaration_matching.source_encryption := 0;
              IFEND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Entry Point Defn. Record', status);
            IFEND;


          PROCEND convert_entry_point_definition;
?? TITLE := '                               CONVERT RELOCATION ITEM' ??
?? EJECT ??

          PROCEDURE convert_relocation_item (number_of_rel_items: 1 .. llc$max_rel_items;
            VAR status: ost$status);



            { relocation item }

            TYPE
              llt$ci_relocation = array [ * ] of llt$ci_relocation_item,


              llt$ci_relocation_item = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                f03: array [1 .. 6] of byte,
                relocating_section: llt$section_ordinal,

                f04: array [1 .. 7] of byte,
                container: llt$relocation_container,

                f05: array [1 .. 7] of byte,
                address: llt$address_type,

              recend;

?? EJECT ??



            VAR
              ci_relocation: ^llt$ci_relocation,
              ii_relocation: ^llt$relocation,
              r: 1 .. llc$max_rel_items + 1;



            NEXT ci_relocation: [1 .. number_of_rel_items] IN ci_input_seg;

            IF ci_relocation <> NIL THEN
              NEXT ii_relocation: [1 .. number_of_rel_items] IN output_seq;

              FOR r := 1 TO number_of_rel_items DO
                ii_relocation^ [r].section_ordinal := ci_relocation^ [r].section_ordinal;
                ii_relocation^ [r].offset := ci_relocation^ [r].offset;
                ii_relocation^ [r].relocating_section := ci_relocation^ [r].relocating_section;
                ii_relocation^ [r].container := ci_relocation^ [r].container;
                ii_relocation^ [r].address := ci_relocation^ [r].address;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Relocation Record', status);
            IFEND;


          PROCEND convert_relocation_item;
?? TITLE := '                               170 Formal & Actual Parameter Items' ??
?? EJECT ??




          { 170 procedure formal parameter description item }


          TYPE
            llt$ci_formal_parameters = record
              procedure_name: pmt$ci_program_name,

            recend;


          { 170 procedure call actual parameters item }


          TYPE
            llt$ci_actual_parameters = record
              callee_name: pmt$ci_program_name,

              f01: array [1 .. 7] of byte,
              language: llt$module_generator,

              f02: array [1 .. 5] of byte,
              line_number_of_call: llt$source_line_number,


            recend,

            llt$ci_source_line_number = packed array [1 .. 32] of half_byte;





?? TITLE := '                               170 Fortran Argument Descriptor' ??
?? EJECT ??
          { 170 fortran argument description: used to describe a }
          { single actual or formal fortran parameter }


          TYPE
            llt$ci_fortran_argument_desc = record
              f01: array [1 .. 7] of byte,
              argument_type: llt$fortran_argument_type,

              string_length: llt$ci_fortran_string_length,

              f02: array [1 .. 7] of byte,
              argument_kind: llt$fortran_argument_kind,

              array_size: llt$ci_fortran_array_size,

              f03: array [1 .. 6] of byte,
              dummy_argument_ordinal: 1 .. llc$max_fortran_arguments,


              f04: array [1 .. 7] of byte,
              mode: llt$argument_usage,
            recend,


            llt$ci_fortran_string_length = packed record
              f01: half_byte,
              attributes: llt$fortran_string_attributes,
              f02: half_byte,
              f03: array [1 .. 6] of byte,

              f04: array [1 .. 6] of byte,
              number_of_characters: llt$fortran_string_size,
            recend,


            llt$ci_fortran_array_size = packed record
              f01: half_byte,
              attributes: llt$fortran_array_attributes,
              f02: half_byte,
              f03: array [1 .. 6] of byte,

              f04: array [1 .. 7] of byte,
              rank: llt$fortran_array_rank,

              f05: half_word,
              number_of_elements: llt$section_length,
            recend;




?? TITLE := '                               CONVERT FORTRAN PARAMETERS' ??
?? EJECT ??

          PROCEDURE convert_fortran_parameters (sequence_length: ost$segment_length;
            VAR parameters: SEQ ( * );
            VAR status: ost$status);


            VAR
              parameter_sequence: ^SEQ ( * ),
              ci_fortran_parameter: ^array [1 .. * ] of llt$ci_fortran_argument_desc,
              ii_fortran_parameter: ^array [1 .. * ] of llt$fortran_argument_desc,
              num_params: integer,
              np: integer;


            num_params := sequence_length DIV #SIZE (llt$ci_fortran_argument_desc);

            NEXT ci_fortran_parameter: [1 .. num_params] IN ci_input_seg;
            IF ci_fortran_parameter = NIL THEN
              error (oce$missing_rec_or_descriptor, 'Fortran Parameters', status);
              RETURN;
            IFEND;

            parameter_sequence := ^parameters;
            RESET parameter_sequence;
            NEXT ii_fortran_parameter: [1 .. num_params] IN parameter_sequence;

            FOR np := 1 TO num_params DO
              ii_fortran_parameter^ [np].argument_type := ci_fortran_parameter^ [np].argument_type;

              ii_fortran_parameter^ [np].string_length.attributes := ci_fortran_parameter^ [np].string_length.
                    attributes;

              ii_fortran_parameter^ [np].string_length.number_of_characters := ci_fortran_parameter^ [np].
                    string_length.number_of_characters;

              ii_fortran_parameter^ [np].argument_kind := ci_fortran_parameter^ [np].argument_kind;

              ii_fortran_parameter^ [np].array_size.attributes := ci_fortran_parameter^ [np].array_size.
                    attributes;

              ii_fortran_parameter^ [np].array_size.rank := ci_fortran_parameter^ [np].array_size.rank;

              ii_fortran_parameter^ [np].array_size.number_of_elements := ci_fortran_parameter^ [np].
                    array_size.number_of_elements;

              ii_fortran_parameter^ [np].dummy_argument_ordinal := ci_fortran_parameter^ [np].
                    dummy_argument_ordinal;

              ii_fortran_parameter^ [np].mode := ci_fortran_parameter^ [np].mode;
            FOREND;


          PROCEND convert_fortran_parameters;
?? TITLE := '                               CONVERT FORMAL PARAMETERS' ??
?? EJECT ??

          PROCEDURE convert_formal_parameters (sequence_length: ost$segment_length;
                type_of_calling_routine {control} : llt$module_generator;
            VAR status: ost$status);



            VAR
              ci_parameter_item: ^llt$ci_formal_parameters,
              ii_parameter_item: ^llt$formal_parameters;



            NEXT ci_parameter_item IN ci_input_seg;

            IF ci_parameter_item <> NIL THEN
              CASE type_of_calling_routine OF
              = llc$fortran =
                ii_text_descriptor^.sequence_length := sequence_length DIV #SIZE
                      (llt$ci_fortran_argument_desc) * #SIZE (llt$fortran_argument_desc);

                NEXT ii_parameter_item: [[REP ii_text_descriptor^.sequence_length OF cell]] IN output_seq;

                convert_fortran_parameters (sequence_length, ii_parameter_item^.specification, status);
              ELSE
                error (oce$invalid_parameter_kind, 'Formal Parameters', status);
              CASEND;

              convert_string (ci_parameter_item^.procedure_name, 1, ii_parameter_item^.procedure_name);

            ELSE
              error (oce$missing_rec_or_descriptor, 'Formal Parameters', status);
            IFEND;


          PROCEND convert_formal_parameters;
?? TITLE := '                               CONVERT ACTUAL PARAMETERS' ??
?? EJECT ??

          PROCEDURE convert_actual_parameters (sequence_length: ost$segment_length;
            VAR status: ost$status);



            VAR
              ci_parameter_item: ^llt$ci_actual_parameters,
              ii_parameter_item: ^llt$actual_parameters;



            NEXT ci_parameter_item IN ci_input_seg;

            IF ci_parameter_item <> NIL THEN
              CASE ci_parameter_item^.language OF
              = llc$fortran =
                ii_text_descriptor^.sequence_length := sequence_length DIV #SIZE
                      (llt$ci_fortran_argument_desc) * #SIZE (llt$fortran_argument_desc);

                NEXT ii_parameter_item: [[REP ii_text_descriptor^.sequence_length OF cell]] IN output_seq;

                convert_fortran_parameters (sequence_length, ii_parameter_item^.specification, status);
              ELSE
                error (oce$invalid_parameter_kind, 'Actual Parameters', status);
              CASEND;

              convert_string (ci_parameter_item^.callee_name, 1, ii_parameter_item^.callee_name);

              ii_parameter_item^.language := ci_parameter_item^.language;

              ii_parameter_item^.line_number_of_call := ci_parameter_item^.line_number_of_call;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Actual Parameters', status);
            IFEND;


          PROCEND convert_actual_parameters;
?? TITLE := '                               170 Debug Symbol Table Declarations' ??
?? EJECT ??

          TYPE
            llt$ci_debug_table_fragment = record
              f01: half_word,
              offset: llt$section_offset,

              sequence: array [1 .. * ] of integer,
            recend;


?? TITLE := '                               CONVERT CYBIL SYMBOL TABLE' ??
?? EJECT ??

          PROCEDURE convert_cybil_symbol_table (sequence_length: ost$segment_length;
            VAR status: ost$status);


            VAR
              ci_debug_table_fragment: ^llt$ci_debug_table_fragment;


            NEXT ci_debug_table_fragment: [1 .. sequence_length] IN ci_input_seg;


          PROCEND convert_cybil_symbol_table;
?? TITLE := '                               CONVERT BINDING TEMPLATE ITEM' ??
?? EJECT ??

          PROCEDURE convert_binding_template (VAR status: ost$status);


            { 170 binding section }

            TYPE
              llt$ci_binding_template = record
                f00: half_word,
                binding_offset: llt$section_offset,

                f01: array [1 .. 7] of byte,
                case kind: llt$binding_template_kind of
                = llc$current_module =
                  f02: array [1 .. 6] of byte,
                  section_ordinal: llt$section_ordinal,

                  offset: ost$segment_offset,

                  f04: array [1 .. 7] of byte,
                  internal_address: llt$address_kind,

                  f05: array [1 .. 5] of word,

                = llc$external_reference =
                  name: pmt$ci_program_name,

                  f06: array [1 .. 7] of byte,
                  address: llt$address_kind,
                casend,
              recend;

?? EJECT ??

            VAR
              ci_binding: ^llt$ci_binding_template,
              ii_binding: ^llt$binding_template;


            NEXT ci_binding IN ci_input_seg;

            IF ci_binding <> NIL THEN
              NEXT ii_binding IN output_seq;

              ii_binding^.binding_offset := ci_binding^.binding_offset;

              ii_binding^.kind := ci_binding^.kind;

              CASE ci_binding^.kind OF
              = llc$current_module =
                ii_binding^.section_ordinal := ci_binding^.section_ordinal;
                convert_integer (#LOC (ci_binding^.offset), #LOC (ii_binding^.offset));
                ii_binding^.internal_address := ci_binding^.internal_address;

              = llc$external_reference =
                convert_string (ci_binding^.name, 1, ii_binding^.name);
                ii_binding^.address := ci_binding^.address;

              CASEND;
            ELSE
              error (oce$missing_rec_or_descriptor, 'Binding Template Record', status);
            IFEND;


          PROCEND convert_binding_template;
?? TITLE := '                               CONVERT TRANSFER SYMBOL ITEM' ??
?? EJECT ??

          PROCEDURE convert_transfer_symbol_item (VAR status: ost$status);



            { 170 transfer symbol }


            TYPE
              llt$ci_transfer_symbol = record
                name: pmt$ci_program_name,

              recend;


            VAR
              ci_transfer_symbol: ^llt$ci_transfer_symbol,
              ii_transfer_symbol: ^llt$transfer_symbol;

            NEXT ci_transfer_symbol IN ci_input_seg;

            IF ci_transfer_symbol <> NIL THEN
              NEXT ii_transfer_symbol IN output_seq;
              convert_string (ci_transfer_symbol^.name, 1, ii_transfer_symbol^.name);

            ELSE
              error (oce$missing_rec_or_descriptor, 'Transfer Symbol Record', status);
            IFEND;


          PROCEND convert_transfer_symbol_item;
?? OLDTITLE ??
?? EJECT ??

          VAR
            type_of_obj_record {control} : llt$object_record_kind,
            size: integer;


          REPEAT
            convert_object_text_desc_12 (type_of_obj_record, size, status);

            IF status.normal THEN

              CASE type_of_obj_record OF
              = llc$identification =
                error (oce$multiple_ident_records, 'CPU Object Module', status);

              = llc$libraries =
                convert_library_directives (size, status);

              = llc$section_definition =
                convert_section_definition_item (status);

              = llc$text =
                convert_text_item (size, status);

              = llc$replication =
                convert_replication_item (size, status);

              = llc$bit_string_insertion =
                convert_bit_insertion_item (status);

              = llc$address_formulation =
                convert_addr_formulation_item (size, status);

              = llc$external_linkage =
                convert_external_linkage_item (size, status);

              = llc$entry_definition =
                convert_entry_point_definition (status);

              = llc$relocation =
                convert_relocation_item (size, status);

              = llc$actual_parameters =
                convert_actual_parameters (size, status);

              = llc$formal_parameters =
                convert_formal_parameters (size, generator_id, status);

              = llc$cybil_symbol_table_fragment =
                convert_cybil_symbol_table (size, status);

              = llc$binding_template =
                convert_binding_template (status);

              = llc$transfer_symbol =
                convert_transfer_symbol_item (status);

              ELSE
                error (oce$invalid_cpu_record_kind, 'CPU Object Module', status);

              CASEND;

            ELSE
              error (status.condition, 'Object Text Descriptor 1.2', status);
            IFEND;

          UNTIL (type_of_obj_record = llc$transfer_symbol) OR (NOT status.normal);


        PROCEND convert_cpu_object_module;
?? TITLE := '                             CONVERT IDENTIFICATION BODY' ??
?? EJECT ??

        PROCEDURE convert_identification_body (ii_identification: ^llt$identification;
          VAR type_of_object_program: llt$module_kind;
          VAR generator_id: llt$module_generator;
          VAR status: ost$status);


          { 170 identification record }


          TYPE
            llt$ci_identification_body = record
              f00: array [1 .. 7] of byte,
              kind: llt$module_kind,

              time_created: ost$ci_time,

              date_created: ost$ci_date,

              attributes: llt$module_attributes,
              f01: array [1 .. 7] of byte,

              f02: array [1 .. 6] of byte,
              greatest_section_ordinal: llt$section_ordinal,

              f03: array [1 .. 7] of byte,
              generator_id: llt$module_generator,

              generator_name_vers: packed array [1 .. 128] of half_byte,

              commentary: packed array [1 .. 128] of half_byte,

            recend;


          CONST
            num_module_attr = 2;




          { 170 return date }


          TYPE
            ost$ci_date = record
              f01: array [1 .. 7] of byte,
              case date_format: ost$date_formats of
              = osc$month_date =
                month: packed array [1 .. 64] of half_byte,

              = osc$mdy_date =
                mdy: packed array [1 .. 64] of half_byte,

              = osc$iso_date =
                iso: packed array [1 .. 64] of half_byte,

              = osc$ordinal_date =
                ordinal: packed array [1 .. 64] of half_byte,

              casend,

            recend;




          { 170 return time }


          TYPE
            ost$ci_time = record
              f01: array [1 .. 7] of byte,
              case time_format: ost$time_formats of
              = osc$ampm_time =
                ampm: packed array [1 .. 48] of half_byte,

              = osc$hms_time =
                hms: packed array [1 .. 48] of half_byte,

              = osc$millisecond_time =
                millisecond: packed array [1 .. 48] of half_byte,

              casend,

            recend;

?? EJECT ??

          VAR
            ci_identification: ^llt$ci_identification_body;



          NEXT ci_identification IN ci_input_seg;

          IF ci_identification <> NIL THEN

            type_of_object_program := ci_identification^.kind;
            ii_identification^.kind := ci_identification^.kind;

            { convert time request return value }

            ii_identification^.time_created.time_format := ci_identification^.time_created.time_format;

            CASE ci_identification^.time_created.time_format OF
            = osc$ampm_time =
              convert_string (ci_identification^.time_created.ampm, 1, ii_identification^.time_created.ampm);

            = osc$hms_time =
              convert_string (ci_identification^.time_created.hms, 1, ii_identification^.time_created.hms);

            = osc$millisecond_time =
              convert_string (ci_identification^.time_created.millisecond, 1, ii_identification^.time_created.
                    millisecond);
            ELSE
              error (pme$invalid_time_format, 'Identification Record', status);

            CASEND;

            IF status.normal THEN

              { convert date request return value }

              ii_identification^.date_created.date_format := ci_identification^.date_created.date_format;

              CASE ci_identification^.date_created.date_format OF
              = osc$month_date =
                convert_string (ci_identification^.date_created.month, 1, ii_identification^.date_created.
                      month);

              = osc$mdy_date =
                convert_string (ci_identification^.date_created.mdy, 1, ii_identification^.date_created.mdy);

              = osc$iso_date =
                convert_string (ci_identification^.date_created.iso, 1, ii_identification^.date_created.iso);

              = osc$ordinal_date =
                convert_string (ci_identification^.date_created.ordinal, 1, ii_identification^.date_created.
                      ordinal);
              ELSE
                error (pme$invalid_date_format, 'Identification Record', status);

              CASEND;

              IF status.normal THEN

                { finish converting identification record }

                convert_set (#LOC (ci_identification^.attributes), num_module_attr, #LOC (ii_identification^.
                      attributes));

                ii_identification^.greatest_section_ordinal := ci_identification^.greatest_section_ordinal;

                ii_identification^.generator_id := ci_identification^.generator_id;
                generator_id := ci_identification^.generator_id;

                IF generator_id = llc$cybil THEN
                  error (oce$invalid_version, 'V1.2 - CYBIL', status);
                  RETURN;
                IFEND;

                convert_string (ci_identification^.generator_name_vers, 1, ii_identification^.
                      generator_name_vers);

                convert_string (ci_identification^.commentary, 1, ii_identification^.commentary);

              IFEND;
            IFEND;
          ELSE
            error (oce$missing_rec_or_descriptor, 'Identification Record', status);
          IFEND;


        PROCEND convert_identification_body;
?? OLDTITLE ??
?? EJECT ??


        VAR
          kind_of_object_module {control} : llt$module_kind,
          module_generator: llt$module_generator;




        convert_identification_body (ii_identification, kind_of_object_module, module_generator, status);

        IF status.normal THEN
          CASE kind_of_object_module OF
          = llc$iou =
            convert_iou_object_module (status);

          = llc$mi_virtual_state, llc$vector_virtual_state, llc$vector_extended_state =
            convert_cpu_object_module (module_generator, status);

          ELSE
            error (oce$invalid_object_module_kind, 'Version 1.2 Text', status);
          CASEND;

        IFEND;

      PROCEND convert_version_12_text;
?? OLDTITLE ??
?? NEWTITLE := '                           CONVERT VERSION 1.3 TEXT' ??
?? NEWTITLE := '                             CONVERT OBJECT TEXT DESCRIPTOR - 1.3' ??
?? EJECT ??

      PROCEDURE convert_version_13_text (ii_identification: ^llt$identification;
        VAR output_seq: ^SEQ ( * );
        VAR status: ost$status);

{ The following *copy is here on purpose.  If it is moved to the beginning of
{ the module, it will not compile given the current implementation.  The problem is that
{ ordinal types llt$object_record_kind and llt$extended_object_record_kind, which is
{ declared in procedure convert_object_file, use some of the same ordinal names.
{ Declaring llt$object_record_kind here means that the ordinal names override the ones
{ with the same names declared in the outer procedure.

*copy llt$object_record_kind


        VAR
          ii_text_descriptor: ^llt$object_text_descriptor;


        PROCEDURE convert_object_text_desc_13 (VAR object_type: llt$object_record_kind;
          VAR size: integer;
          VAR status: ost$status);





          TYPE
            llt$ci_object_text_descriptor = record
              f00: array [1 .. 7] of byte,
              case kind: llt$object_record_kind of
              = llc$identification, llc$section_definition, llc$entry_definition, llc$binding_template,
                llc$transfer_symbol, llc$bit_string_insertion =
                unused: ost$segment_offset, {always 0}

              = llc$libraries =
                f02: array [1 .. 6] of byte,
                number_of_libraries: 1 .. llc$max_libraries,

              = llc$text, llc$replication =
                f03: array [1 .. 4] of byte,
                number_of_bytes: 1 .. osc$max_segment_length,

              = llc$relocation =
                f05: array [1 .. 6] of byte,
                number_of_rel_items: 1 .. llc$max_rel_items,

              = llc$address_formulation =
                f06: array [1 .. 6] of byte,
                number_of_adr_items: 1 .. llc$max_adr_items,

              = llc$external_linkage =
                f07: array [1 .. 6] of byte,
                number_of_ext_items: 1 .. llc$max_ext_items,

              = llc$formal_parameters, llc$actual_parameters, llc$cybil_symbol_table_fragment =
                f08: array [1 .. 4] of byte,
                sequence_length: ost$segment_length,

              = llc$ppu_absolute =
                f09: array [1 .. 6] of byte,
                number_of_words: llt$ppu_address,
              casend,
            recend;




          VAR
            ci_text_descriptor: ^llt$ci_object_text_descriptor;



          NEXT ci_text_descriptor IN ci_input_seg;

          IF ci_text_descriptor <> NIL THEN
            object_type := ci_text_descriptor^.kind;

            NEXT ii_text_descriptor IN output_seq;

            ii_text_descriptor^.kind := ci_text_descriptor^.kind;

            CASE ci_text_descriptor^.kind OF
            = llc$identification, llc$section_definition, llc$entry_definition, llc$binding_template,
                  llc$bit_string_insertion, llc$transfer_symbol =
              ii_text_descriptor^.unused := ci_text_descriptor^.unused;

            = llc$libraries =
              ii_text_descriptor^.number_of_libraries := ci_text_descriptor^.number_of_libraries;
              size := ci_text_descriptor^.number_of_libraries;

            = llc$text, llc$replication =
              ii_text_descriptor^.number_of_bytes := ci_text_descriptor^.number_of_bytes;
              size := ci_text_descriptor^.number_of_bytes;

            = llc$relocation =
              ii_text_descriptor^.number_of_rel_items := ci_text_descriptor^.number_of_rel_items;
              size := ci_text_descriptor^.number_of_rel_items;

            = llc$address_formulation =
              ii_text_descriptor^.number_of_adr_items := ci_text_descriptor^.number_of_adr_items;
              size := ci_text_descriptor^.number_of_adr_items;

            = llc$external_linkage =
              ii_text_descriptor^.number_of_ext_items := ci_text_descriptor^.number_of_ext_items;
              size := ci_text_descriptor^.number_of_ext_items;

            = llc$formal_parameters, llc$actual_parameters =
              size := ci_text_descriptor^.sequence_length;

            = llc$cybil_symbol_table_fragment =
              size := ci_text_descriptor^.sequence_length;

            = llc$ppu_absolute =
              ii_text_descriptor^.number_of_words := ci_text_descriptor^.number_of_words;
              size := ci_text_descriptor^.number_of_words;

            ELSE
              error (oce$invalid_object_record_kind, 'Object Text Descriptor 1.3', status);

            CASEND;

          ELSE
            eoi_warning (oce$missing_rec_or_descriptor, status);

          IFEND;


        PROCEND convert_object_text_desc_13;
?? OLDTITLE ??

?? NEWTITLE := '                             CONVERT IOU OBJECT MODULE' ??
?? NEWTITLE := '                               CONVERT PPU ABSOLUTE ITEM' ??
?? EJECT ??

        PROCEDURE convert_iou_object_module (VAR status: ost$status);




          PROCEDURE convert_ppu_absolute_item (number_of_words: llt$ppu_address;
            VAR status: ost$status);




            { 170 ppu absolute }


            TYPE
              llt$ci_ppu_absolute = record
                executes_on_any_ppu: boolean,
                f01: array [1 .. 7] of byte,

                f02: array [1 .. 7] of byte,
                ppu_number: 0 .. llc$max_ppu_number,

                f03: array [1 .. 6] of byte,
                load_address: llt$ppu_address,

                f04: array [1 .. 6] of byte,
                entry_address: llt$ppu_address,

                text_array: array [ * ] of ppu_text,

              recend,


              ppu_text = record
                f01: array [1 .. 6] of byte,
                text: 0 .. 0ffff(16),

              recend;






            VAR
              ci_ppu: ^llt$ci_ppu_absolute,
              ii_ppu: ^llt$ppu_absolute,
              w: 0 .. llc$max_ppu_size + 1;



            NEXT ci_ppu: [0 .. number_of_words - 1] IN ci_input_seg;

            IF ci_ppu <> NIL THEN

              NEXT ii_ppu: [0 .. number_of_words - 1] IN output_seq;


              convert_boolean (#LOC (ci_ppu^.executes_on_any_ppu), ii_ppu^.executes_on_any_ppu);

              ii_ppu^.ppu_number := ci_ppu^.ppu_number;
              ii_ppu^.load_address := ci_ppu^.load_address;
              ii_ppu^.entry_address := ci_ppu^.entry_address;

              FOR w := 0 TO (number_of_words - 1) DO
                ii_ppu^.text [w] := ci_ppu^.text_array [w].text;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'PPU Record', status);
            IFEND;


          PROCEND convert_ppu_absolute_item;
?? EJECT ??
?? OLDTITLE ??


          VAR
            type_of_obj_record {control} : llt$object_record_kind,
            size: integer;


          convert_object_text_desc_13 (type_of_obj_record, size, status);

          IF status.normal THEN
            CASE type_of_obj_record OF
            = llc$ppu_absolute =
              convert_ppu_absolute_item (size, status);

            ELSE
              error (oce$invalid_ppu_record_kind, 'IOU Object Module', status);

            CASEND;

          ELSE
            error (oce$missing_rec_or_descriptor, 'PPU Descriptor', status);
          IFEND;


        PROCEND convert_iou_object_module;
?? OLDTITLE ??
?? NEWTITLE := '                             CONVERT CPU OBJECT MODULE' ??
?? NEWTITLE := '                               CONVERT LIBRARY DIRECTIVES' ??
?? EJECT ??

        PROCEDURE convert_cpu_object_module (generator_id: llt$module_generator;
          VAR status: ost$status);

{       NOTE:                                    }
{         The parameter 'generator_id' is used }
{         by 'convert_formal_parameters' to      }
{         identify the type of calling procedure.}



          PROCEDURE convert_library_directives (number_of_libraries: 1 .. llc$max_libraries;
            VAR status: ost$status);


            { 170 library directives }


            TYPE
              llt$ci_libraries = array [ * ] of pmt$ci_program_name;


            VAR
              ci_library: ^llt$ci_libraries,
              ii_library: ^llt$libraries,
              l: 1 .. llc$max_libraries + 1;



            NEXT ci_library: [1 .. number_of_libraries] IN ci_input_seg;

            IF ci_library <> NIL THEN
              NEXT ii_library: [1 .. number_of_libraries] IN output_seq;


              FOR l := 1 TO number_of_libraries DO
                convert_string (ci_library^ [l], 1, ii_library^ [l]);
                IF ii_library^ [l] = 'CYBILIB ' THEN
                  ii_library^ [l] := 'CYF$RUN_TIME_LIBRARY';
                IFEND;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Library Record', status);
            IFEND;


          PROCEND convert_library_directives;
?? TITLE := '                               CONVERT SECTION DEFINITION' ??
?? EJECT ??

          PROCEDURE convert_section_definition_item (VAR status: ost$status);



            { 170 section definitions }


            TYPE
              llt$ci_section_definition = record
                f01: array [1 .. 7] of byte,
                kind: llt$section_kind,

                access_attributes: llt$section_access_attributes,
                f02: array [1 .. 7] of byte,

                f03: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f04: half_word,
                length: ost$segment_length,

                allocation_alignment: ost$segment_offset,

                allocation_offset: ost$segment_offset,

                name: pmt$ci_program_name,

              recend;




?? EJECT ??

            CONST
              num_access_attributes = 4;

            VAR
              ci_section: ^llt$ci_section_definition,
              ii_section: ^llt$section_definition;




            NEXT ci_section IN ci_input_seg;

            IF ci_section <> NIL THEN
              NEXT ii_section IN output_seq;


              ii_section^.kind := ci_section^.kind;

              convert_set (#LOC (ci_section^.access_attributes), num_access_attributes, #LOC (ii_section^.
                    access_attributes));

              ii_section^.section_ordinal := ci_section^.section_ordinal;
              ii_section^.length := ci_section^.length;
              convert_integer (#LOC (ci_section^.allocation_alignment), #LOC (ii_section^.
                    allocation_alignment));
              convert_integer (#LOC (ci_section^.allocation_offset), #LOC (ii_section^.allocation_offset));

              convert_string (ci_section^.name, 1, ii_section^.name);

            ELSE
              error (oce$missing_rec_or_descriptor, 'Section Defn. Record', status);
            IFEND;


          PROCEND convert_section_definition_item;
?? TITLE := '                               CONVERT TEXT ITEM' ??
?? EJECT ??

          PROCEDURE convert_text_item (number_of_bytes: 1 .. osc$max_segment_length;
            VAR status: ost$status);



            { 170 text item }


            TYPE
              llt$ci_text = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                byte_array: array [ * ] of text_component,

              recend,

              text_component = record
                f01: array [1 .. 7] of byte,
                byte: 0 .. 255,

              recend;





            VAR
              ci_text: ^llt$ci_text,
              ii_text: ^llt$text,
              b: 1 .. osc$max_segment_length + 1;

?? EJECT ??
            NEXT ci_text: [1 .. number_of_bytes] IN ci_input_seg;

            IF ci_text <> NIL THEN
              NEXT ii_text: [1 .. number_of_bytes] IN output_seq;


              ii_text^.section_ordinal := ci_text^.section_ordinal;
              ii_text^.offset := ci_text^.offset;

              FOR b := 1 TO number_of_bytes DO
                ii_text^.byte [b] := ci_text^.byte_array [b].byte;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Text Record', status);
            IFEND;


          PROCEND convert_text_item;
?? TITLE := '                               CONVERT REPLICATION ITEM' ??
?? EJECT ??

          PROCEDURE convert_replication_item (number_of_bytes: 1 .. osc$max_segment_length;
            VAR status: ost$status);




            { 170 replication item }


            TYPE
              llt$ci_replication = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                f03: half_word,
                increment: 1 .. osc$max_segment_length,

                f04: half_word,
                count: 1 .. osc$max_segment_length,

                byte_array: array [ * ] of replication_text,

              recend,


              replication_text = record
                f01: array [1 .. 7] of byte,
                byte: 0 .. 255,

              recend;

?? EJECT ??

            VAR
              ci_replication: ^llt$ci_replication,
              ii_replication: ^llt$replication,
              b: 1 .. osc$max_segment_length + 1;



            NEXT ci_replication: [1 .. number_of_bytes] IN ci_input_seg;

            IF ci_replication <> NIL THEN
              NEXT ii_replication: [1 .. number_of_bytes] IN output_seq;


              ii_replication^.section_ordinal := ci_replication^.section_ordinal;
              ii_replication^.offset := ci_replication^.offset;
              ii_replication^.increment := ci_replication^.increment;
              ii_replication^.count := ci_replication^.count;

              FOR b := 1 TO number_of_bytes DO
                ii_replication^.byte [b] := ci_replication^.byte_array [b].byte;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Replication Record', status);
            IFEND;


          PROCEND convert_replication_item;
?? TITLE := '                               CONVERT BIT INSERTION ITEM' ??
?? EJECT ??

          PROCEDURE convert_bit_insertion_item (VAR status: ost$status);




            { 170 bit insertion item }


            TYPE
              llt$ci_bit_string_insertion = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                f03: array [1 .. 7] of byte,
                bit_offset: 0 .. 7,

                f04: array [1 .. 7] of byte,
                bit_length: 1 .. 63,

                bit_string: packed array [1 .. 128] of 0 .. 1,

              recend;


            VAR
              ci_bit_insertion: ^llt$ci_bit_string_insertion,
              ii_bit_insertion: ^llt$bit_string_insertion,
              b: 1 .. 128;

?? EJECT ??



            NEXT ci_bit_insertion IN ci_input_seg;

            IF ci_bit_insertion <> NIL THEN
              NEXT ii_bit_insertion IN output_seq;


              ii_bit_insertion^.section_ordinal := ci_bit_insertion^.section_ordinal;
              ii_bit_insertion^.offset := ci_bit_insertion^.offset;
              ii_bit_insertion^.bit_offset := ci_bit_insertion^.bit_offset;
              ii_bit_insertion^.bit_length := ci_bit_insertion^.bit_length;

              FOR b := 1 TO 60 DO
                ii_bit_insertion^.bit_string [b] := ci_bit_insertion^.bit_string [b + 4];
              FOREND;
              FOR b := 61 TO 63 DO
                ii_bit_insertion^.bit_string [b] := ci_bit_insertion^.bit_string [b + 8];
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Bit Insertion Record', status);
            IFEND;


          PROCEND convert_bit_insertion_item;
?? TITLE := '                               CONVERT ADDRESS FORMULATION ITEM' ??
?? EJECT ??

          PROCEDURE convert_addr_formulation_item (addr_upper_bnd: 1 .. llc$max_adr_items;
            VAR status: ost$status);


            { 170 address formulation item }


            TYPE
              llt$ci_address_formulation = record
                f01: array [1 .. 6] of byte,
                value_section: llt$section_ordinal,

                f02: array [1 .. 6] of byte,
                dest_section: llt$section_ordinal,

                item: array [ * ] of llt$ci_address_formulation_item,

              recend,


              llt$ci_address_formulation_item = record
                f01: array [1 .. 7] of byte,
                kind: llt$internal_address_kind,

                value_offset: ost$segment_offset,

                f03: half_word,
                dest_offset: llt$section_offset,

              recend;






            VAR
              ci_address: ^llt$ci_address_formulation,
              ii_address: ^llt$address_formulation,
              a: 1 .. llc$max_adr_items + 1;

?? EJECT ??



            NEXT ci_address: [1 .. addr_upper_bnd] IN ci_input_seg;

            IF ci_address <> NIL THEN
              NEXT ii_address: [1 .. addr_upper_bnd] IN output_seq;


              ii_address^.value_section := ci_address^.value_section;
              ii_address^.dest_section := ci_address^.dest_section;

              FOR a := 1 TO addr_upper_bnd DO
                ii_address^.item [a].kind := ci_address^.item [a].kind;
                convert_integer (#LOC (ci_address^.item [a].value_offset), #LOC (ii_address^.item [a].
                      value_offset));
                ii_address^.item [a].dest_offset := ci_address^.item [a].dest_offset;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Address Formulation Record', status);
            IFEND;


          PROCEND convert_addr_formulation_item;
?? TITLE := '                               CONVERT EXTERNAL REFERENCE ITEM' ??
?? EJECT ??

          PROCEDURE convert_external_linkage_item (number_of_ext_items: 1 .. llc$max_ext_items;
            VAR status: ost$status);



            { 170 external reference item }


            TYPE
              llt$ci_external_linkage = record
                name: pmt$ci_program_name,

                f00: array [1 .. 7] of byte,
                language: llt$module_generator,

                declaration_matching_required: boolean,
                f01: array [1 .. 7] of byte,

                declaration_matching_value: llt$ci_decl_matching_value,

                item: array [ * ] of llt$ci_external_linkage_item,
              recend,


              llt$ci_external_linkage_item = record
                f02: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f03: half_word,
                offset: llt$section_offset,
                f01: array [1 .. 7] of byte,
                kind: llt$address_kind,

                offset_operand: - osc$maximum_offset .. osc$maximum_offset,

              recend;


?? EJECT ??

            VAR
              ci_external_linkage: ^llt$ci_external_linkage,
              ii_external_linkage: ^llt$external_linkage,
              e: 1 .. llc$max_ext_items + 1;


            NEXT ci_external_linkage: [1 .. number_of_ext_items] IN ci_input_seg;

            IF ci_external_linkage <> NIL THEN
              NEXT ii_external_linkage: [1 .. number_of_ext_items] IN output_seq;

              convert_string (ci_external_linkage^.name, 1, ii_external_linkage^.name);

              ii_external_linkage^.language := ci_external_linkage^.language;
              IF ci_external_linkage^.language = llc$obsolete_cybil THEN
                convert_boolean (#LOC (ci_external_linkage^.declaration_matching_required),
                      ii_external_linkage^.declaration_matching_required);
                ii_external_linkage^.declaration_matching.language_dependent_value :=
                      ci_external_linkage^.declaration_matching_value.lower_1 * 100000000(16) +
                      ci_external_linkage^.declaration_matching_value.lower_2;
              ELSE

                ii_external_linkage^.declaration_matching_required := FALSE;

                ii_external_linkage^.declaration_matching.object_encryption := 0;
                ii_external_linkage^.declaration_matching.source_encryption := 0;
              IFEND;
              FOR e := 1 TO number_of_ext_items DO
                ii_external_linkage^.item [e].kind := ci_external_linkage^.item [e].kind;

                convert_integer (#LOC (ci_external_linkage^.item [e].offset_operand), #LOC
                      (ii_external_linkage^.item [e].offset_operand));

                ii_external_linkage^.item [e].section_ordinal := ci_external_linkage^.item [e].
                      section_ordinal;
                ii_external_linkage^.item [e].offset := ci_external_linkage^.item [e].offset;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'External Reference Record', status);
            IFEND;


          PROCEND convert_external_linkage_item;
?? TITLE := '                               CONVERT ENTRY POINT DEFINITION' ??
?? EJECT ??

          PROCEDURE convert_entry_point_definition (VAR status: ost$status);




            { 170 entry point definition item }


            TYPE
              llt$ci_entry_definition = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                attributes: llt$entry_point_attributes,
                f03: array [1 .. 7] of byte,

                name: pmt$ci_program_name,

                f04: array [1 .. 7] of byte,
                language: llt$module_generator,

                declaration_matching_required: boolean,
                f05: array [1 .. 7] of byte,

                declaration_matching_value: llt$ci_decl_matching_value,

              recend;


            CONST
              num_entry_point_attr = 2;

?? EJECT ??

            VAR
              ci_entry_point: ^llt$ci_entry_definition,
              ii_entry_point: ^llt$entry_definition;



            NEXT ci_entry_point IN ci_input_seg;

            IF ci_entry_point <> NIL THEN
              NEXT ii_entry_point IN output_seq;


              ii_entry_point^.section_ordinal := ci_entry_point^.section_ordinal;
              ii_entry_point^.offset := ci_entry_point^.offset;

              convert_set (#LOC (ci_entry_point^.attributes), num_entry_point_attr, #LOC (ii_entry_point^.
                    attributes));

              convert_string (ci_entry_point^.name, 1, ii_entry_point^.name);

              ii_entry_point^.language := ci_entry_point^.language;

              IF ci_entry_point^.language = llc$obsolete_cybil THEN
                convert_boolean (#LOC (ci_entry_point^.declaration_matching_required),
                      ii_entry_point^.declaration_matching_required);
                ii_entry_point^.declaration_matching.language_dependent_value :=
                      ci_entry_point^.declaration_matching_value.lower_1 * 100000000(16) +
                      ci_entry_point^.declaration_matching_value.lower_2;
              ELSE

                ii_entry_point^.declaration_matching_required := FALSE;

                ii_entry_point^.declaration_matching.object_encryption := 0;
                ii_entry_point^.declaration_matching.source_encryption := 0;
              IFEND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Entry Point Defn. Record', status);
            IFEND;


          PROCEND convert_entry_point_definition;
?? TITLE := '                               CONVERT RELOCATION ITEM' ??
?? EJECT ??

          PROCEDURE convert_relocation_item (number_of_rel_items: 1 .. llc$max_rel_items;
            VAR status: ost$status);



            { relocation item }

            TYPE
              llt$ci_relocation = array [ * ] of llt$ci_relocation_item,


              llt$ci_relocation_item = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                f03: array [1 .. 6] of byte,
                relocating_section: llt$section_ordinal,

                f04: array [1 .. 7] of byte,
                container: llt$relocation_container,

                f05: array [1 .. 7] of byte,
                address: llt$address_type,

              recend;

?? EJECT ??



            VAR
              ci_relocation: ^llt$ci_relocation,
              ii_relocation: ^llt$relocation,
              r: 1 .. llc$max_rel_items + 1;



            NEXT ci_relocation: [1 .. number_of_rel_items] IN ci_input_seg;

            IF ci_relocation <> NIL THEN
              NEXT ii_relocation: [1 .. number_of_rel_items] IN output_seq;

              FOR r := 1 TO number_of_rel_items DO
                ii_relocation^ [r].section_ordinal := ci_relocation^ [r].section_ordinal;
                ii_relocation^ [r].offset := ci_relocation^ [r].offset;
                ii_relocation^ [r].relocating_section := ci_relocation^ [r].relocating_section;
                ii_relocation^ [r].container := ci_relocation^ [r].container;
                ii_relocation^ [r].address := ci_relocation^ [r].address;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Relocation Record', status);
            IFEND;


          PROCEND convert_relocation_item;
?? TITLE := '                               170 Formal & Actual Parameter Items' ??
?? EJECT ??




          { 170 procedure formal parameter description item }


          TYPE
            llt$ci_formal_parameters = record
              procedure_name: pmt$ci_program_name,

            recend;


          { 170 procedure call actual parameters item }


          TYPE
            llt$ci_actual_parameters = record
              callee_name: pmt$ci_program_name,

              f01: array [1 .. 7] of byte,
              language: llt$module_generator,

              f02: array [1 .. 5] of byte,
              line_number_of_call: llt$source_line_number,


            recend,

            llt$ci_source_line_number = packed array [1 .. 32] of half_byte;





?? TITLE := '                               170 Fortran Argument Descriptor' ??
?? EJECT ??
          { 170 fortran argument description: used to describe a }
          { single actual or formal fortran parameter }


          TYPE
            llt$ci_fortran_argument_desc = record
              f01: array [1 .. 7] of byte,
              argument_type: llt$fortran_argument_type,

              string_length: llt$ci_fortran_string_length,

              f02: array [1 .. 7] of byte,
              argument_kind: llt$fortran_argument_kind,

              array_size: llt$ci_fortran_array_size,

              f03: array [1 .. 6] of byte,
              dummy_argument_ordinal: 1 .. llc$max_fortran_arguments,


              f04: array [1 .. 7] of byte,
              mode: llt$argument_usage,
            recend,


            llt$ci_fortran_string_length = packed record
              f01: half_byte,
              attributes: llt$fortran_string_attributes,
              f02: half_byte,
              f03: array [1 .. 6] of byte,

              f04: array [1 .. 6] of byte,
              number_of_characters: llt$fortran_string_size,
            recend,


            llt$ci_fortran_array_size = packed record
              f01: half_byte,
              attributes: llt$fortran_array_attributes,
              f02: half_byte,
              f03: array [1 .. 6] of byte,

              f04: array [1 .. 7] of byte,
              rank: llt$fortran_array_rank,

              f05: half_word,
              number_of_elements: llt$section_length,
            recend;




?? TITLE := '                               CONVERT FORTRAN PARAMETERS' ??
?? EJECT ??

          PROCEDURE convert_fortran_parameters (sequence_length: ost$segment_length;
            VAR parameters: SEQ ( * );
            VAR status: ost$status);


            VAR
              parameter_sequence: ^SEQ ( * ),
              ci_fortran_parameter: ^array [1 .. * ] of llt$ci_fortran_argument_desc,
              ii_fortran_parameter: ^array [1 .. * ] of llt$fortran_argument_desc,
              num_params: integer,
              np: integer;


            num_params := sequence_length DIV #SIZE (llt$ci_fortran_argument_desc);

            NEXT ci_fortran_parameter: [1 .. num_params] IN ci_input_seg;
            IF ci_fortran_parameter = NIL THEN
              error (oce$missing_rec_or_descriptor, 'Fortran Parameters', status);
              RETURN;
            IFEND;

            parameter_sequence := ^parameters;
            RESET parameter_sequence;
            NEXT ii_fortran_parameter: [1 .. num_params] IN parameter_sequence;

            FOR np := 1 TO num_params DO
              ii_fortran_parameter^ [np].argument_type := ci_fortran_parameter^ [np].argument_type;

              ii_fortran_parameter^ [np].string_length.attributes := ci_fortran_parameter^ [np].string_length.
                    attributes;

              ii_fortran_parameter^ [np].string_length.number_of_characters := ci_fortran_parameter^ [np].
                    string_length.number_of_characters;

              ii_fortran_parameter^ [np].argument_kind := ci_fortran_parameter^ [np].argument_kind;

              ii_fortran_parameter^ [np].array_size.attributes := ci_fortran_parameter^ [np].array_size.
                    attributes;

              ii_fortran_parameter^ [np].array_size.rank := ci_fortran_parameter^ [np].array_size.rank;

              ii_fortran_parameter^ [np].array_size.number_of_elements := ci_fortran_parameter^ [np].
                    array_size.number_of_elements;

              ii_fortran_parameter^ [np].dummy_argument_ordinal := ci_fortran_parameter^ [np].
                    dummy_argument_ordinal;

              ii_fortran_parameter^ [np].mode := ci_fortran_parameter^ [np].mode;
            FOREND;


          PROCEND convert_fortran_parameters;
?? TITLE := '                               CONVERT FORMAL PARAMETERS' ??
?? EJECT ??

          PROCEDURE convert_formal_parameters (sequence_length: ost$segment_length;
                type_of_calling_routine {control} : llt$module_generator;
            VAR status: ost$status);



            VAR
              ci_parameter_item: ^llt$ci_formal_parameters,
              ii_parameter_item: ^llt$formal_parameters;



            NEXT ci_parameter_item IN ci_input_seg;

            IF ci_parameter_item <> NIL THEN
              CASE type_of_calling_routine OF
              = llc$fortran =
                ii_text_descriptor^.sequence_length := sequence_length DIV #SIZE
                      (llt$ci_fortran_argument_desc) * #SIZE (llt$fortran_argument_desc);

                NEXT ii_parameter_item: [[REP ii_text_descriptor^.sequence_length OF cell]] IN output_seq;

                convert_fortran_parameters (sequence_length, ii_parameter_item^.specification, status);
              ELSE
                error (oce$invalid_parameter_kind, 'Formal Parameters', status);
              CASEND;

              convert_string (ci_parameter_item^.procedure_name, 1, ii_parameter_item^.procedure_name);

            ELSE
              error (oce$missing_rec_or_descriptor, 'Formal Parameters', status);
            IFEND;


          PROCEND convert_formal_parameters;
?? TITLE := '                               CONVERT ACTUAL PARAMETERS' ??
?? EJECT ??

          PROCEDURE convert_actual_parameters (sequence_length: ost$segment_length;
            VAR status: ost$status);



            VAR
              ci_parameter_item: ^llt$ci_actual_parameters,
              ii_parameter_item: ^llt$actual_parameters;



            NEXT ci_parameter_item IN ci_input_seg;

            IF ci_parameter_item <> NIL THEN
              CASE ci_parameter_item^.language OF
              = llc$fortran =
                ii_text_descriptor^.sequence_length := sequence_length DIV #SIZE
                      (llt$ci_fortran_argument_desc) * #SIZE (llt$fortran_argument_desc);

                NEXT ii_parameter_item: [[REP ii_text_descriptor^.sequence_length OF cell]] IN output_seq;

                convert_fortran_parameters (sequence_length, ii_parameter_item^.specification, status);
              ELSE
                error (oce$invalid_parameter_kind, 'Actual Parameters', status);
              CASEND;

              convert_string (ci_parameter_item^.callee_name, 1, ii_parameter_item^.callee_name);

              ii_parameter_item^.language := ci_parameter_item^.language;

              ii_parameter_item^.line_number_of_call := ci_parameter_item^.line_number_of_call;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Actual Parameters', status);
            IFEND;


          PROCEND convert_actual_parameters;
?? TITLE := '                               170 Debug Symbol Table Declarations' ??
?? EJECT ??

          TYPE
            cyt$ci_cybil_symbol_table = record
              original_name: pmt$ci_program_name,

              f01: array [1 .. 7] of byte,
              language: llt$module_generator,

              f02: array [1 .. 7] of byte,
              optimization_level: 0 .. 255,

              version: packed array [1 .. 16] of half_byte,

              f03: array [1 .. 6] of byte,
              module_symbol_list: symbol_no,

              f04: array [1 .. 6] of byte,
              number_of_symbols: symbol_no,
            recend,

            cyt$ci_cybil_symbol_table_item = record
              symbol_name: pmt$ci_program_name,

              end_of_chain: boolean,
              f01: array [1 .. 7] of byte,

              f02: array [1 .. 6] of byte,
              symtab_no: symbol_no,

              f03: array [1 .. 7] of byte,
              case symbol_type: entry_kinds of

              = int_kind, bool_kind, char_kind, real_kind, longreal_kind, cell_kind =
                ,

              = var_kind =
                f04: array [1 .. 6] of byte,
                var_type: symbol_no,

                f05: half_word,
                var_length: ost$segment_length,

                f06: array [1 .. 7] of byte,
                base: base_type,

                f07: array [1 .. 6] of byte,
                var_section_ordinal: llt$section_ordinal,

                f08: half_word,
                var_offset: ost$segment_length,

                indirectly_referenced: boolean,
                f09: array [1 .. 7] of byte,

                var_is_parameter: boolean,
                f10: array [1 .. 7] of byte,

              = cons_kind =
                f11: array [1 .. 6] of byte,
                cons_type: symbol_no,

                f12: array [1 .. 7] of byte,
                cons_length_type: (short_constant_type, long_constant_type),

                cons_value: integer_range,

              = label_kind =
                f13: array [1 .. 6] of byte,
                line_no: line_number_range,

              = ordinal_kind =
                f14: array [1 .. 6] of byte,
                last_const: symbol_no,

                f15: array [1 .. 6] of byte,
                upper_bound: 0 .. 4095,

              = subrange_kind =
                f16: array [1 .. 6] of byte,
                subtype: symbol_no,

                f17: array [1 .. 7] of byte,
                low_value_type: len_kinds,

                f18: array [1 .. 7] of byte,
                high_value_type: len_kinds,

                low_value: integer_range,

                high_value: integer_range,


              = proc_kind =
                f19: array [1 .. 7] of byte,
                lexical_level: 0 .. 255,

                f20: array [1 .. 6] of byte,
                symbol_list: symbol_no,

                f21: array [1 .. 6] of byte,
                proc_section_ordinal: llt$section_ordinal,

                f22: half_word,
                proc_offset: ost$segment_length,

                f23: half_word,
                proc_length: ost$segment_length,

                f24: array [1 .. 6] of byte,
                parent_proc: symbol_no,

                f25: array [1 .. 6] of byte,
                return_type: symbol_no,

              = pointer_kind =
                f26: array [1 .. 6] of byte,
                ptr_type: symbol_no,

                f100: half_word,
                ptr_object_length: ost$segment_length,

              = set_kind =
                f27: array [1 .. 6] of byte,
                set_element_type: symbol_no,

                f28: array [1 .. 6] of byte,
                set_len: 0 .. 7fff(16),

              = string_kind =
                f29: array [1 .. 7] of byte,
                len_type: len_kinds,

                f30: array [1 .. 6] of byte,
                string_len: symbol_no,

              = array_kind =
                array_binding: bindkinds,
                f31: array [1 .. 7] of byte,

                f32: array [1 .. 7] of byte,
                array_packing: packattrs,

                length_is_bits: boolean,
                f33: array [1 .. 7] of byte,

                f34: array [1 .. 6] of byte,
                index_type: symbol_no,

                f35: array [1 .. 6] of byte,
                array_element_type: symbol_no,

                f36: half_word,
                element_length: ost$segment_length,

              = record_kind =
                record_binding: bindkinds,
                f37: array [1 .. 7] of byte,

                f38: array [1 .. 7] of byte,
                record_packing: packattrs,

                variation_flag: boolean,
                f39: array [1 .. 7] of byte,

                f40: array [1 .. 6] of byte,
                first_field: symbol_no,

                f41: half_word,
                record_length: ost$segment_length,

                f42: array [1 .. 6] of byte,
                selector: symbol_no,

              = field_kind =
                f43: array [1 .. 3] of byte,
                field_offset: machine_addr_in_bits_type,

                f44: array [1 .. 3] of byte,
                field_length: machine_addr_in_bits_type,

                unit_addressed: boolean,
                f45: array [1 .. 7] of byte,

                f46: array [1 .. 6] of byte,
                field_type: symbol_no,

                f47: array [1 .. 6] of byte,
                next_field: symbol_no,


              = selector_kind =
                f48: array [1 .. 6] of byte,
                variation: symbol_no,

                f50: array [1 .. 6] of byte,
                next_selector: symbol_no,

                low_selector: integer_range,

                high_selector: integer_range,


              = heap_kind =
                ,


              = seq_kind =
                ,


              = bound_vrec_kind =
                f52: array [1 .. 6] of byte,
                bound_type: symbol_no,


              = rel_ptr_kind =
                f53: array [1 .. 6] of byte,
                parent_type: symbol_no,

                f54: array [1 .. 6] of byte,
                object_type: symbol_no,

                f55: half_word,
                rel_ptr_object_length: ost$segment_length,

              casend,
            recend;

          TYPE

            llt$ci_debug_table_fragment = record
              f01: half_word,
              offset: llt$section_offset,
            recend;

          TYPE
            cyt$ii_cybil_symbol_table = record
              original_name: pmt$program_name,
              language: llt$module_generator,
              optimization_level: 0 .. 255,
              version: string (4),
              module_symbol_list: symbol_no,
              number_of_symbols: symbol_no,
            recend;

?? TITLE := '                               CONVERT CYBIL SYMBOL TABLE' ??
?? EJECT ??

          PROCEDURE convert_cybil_symbol_table (sequence_length: ost$segment_length;
            VAR status: ost$status);


            VAR
              symbol_table_text: ^SEQ ( * ),

              number_of_items: integer,
              item: integer,

              header_present: boolean,
              number_of_bytes: integer,

              ci_debug_table_fragment: ^llt$ci_debug_table_fragment,
              ii_debug_table_fragment: ^llt$debug_table_fragment,

              ci_cybil_symbol_table: ^cyt$ci_cybil_symbol_table,
              ii_cybil_symbol_table: ^cyt$ii_cybil_symbol_table,

              ci_item: ^array [1 .. * ] of cyt$ci_cybil_symbol_table_item,
              ii_item: ^array [1 .. * ] of cyt$debug_symbol_table_item,

              ci_dummy_name: packed array [1 .. 100] of half_byte,
              ii_dummy_name: pmt$program_name;


            number_of_bytes := sequence_length * 8;

            header_present := number_of_bytes MOD #SIZE (cyt$ci_cybil_symbol_table_item) <> 0;

            IF header_present THEN
              number_of_items := (number_of_bytes - #SIZE (cyt$ci_cybil_symbol_table)) DIV #SIZE
                    (cyt$ci_cybil_symbol_table_item);
              ii_text_descriptor^.sequence_length := number_of_items * #SIZE (cyt$debug_symbol_table_item) +
                    #SIZE (cyt$ii_cybil_symbol_table);
            ELSE
              number_of_items := number_of_bytes DIV #SIZE (cyt$ci_cybil_symbol_table_item);
              ii_text_descriptor^.sequence_length := number_of_items * #SIZE (cyt$debug_symbol_table_item);
            IFEND;

            NEXT ci_debug_table_fragment IN ci_input_seg;
            IF ci_debug_table_fragment = NIL THEN
              error (oce$missing_rec_or_descriptor, 'Debug Symbol Table', status);
              RETURN;
            IFEND;

            NEXT ii_debug_table_fragment: [[REP ii_text_descriptor^.sequence_length OF cell]] IN output_seq;

            ii_debug_table_fragment^.offset := ci_debug_table_fragment^.offset;

            symbol_table_text := ^ii_debug_table_fragment^.text;
            RESET symbol_table_text;
            IF header_present THEN
              NEXT ci_cybil_symbol_table IN ci_input_seg;
              IF ci_cybil_symbol_table = NIL THEN
                error (oce$missing_rec_or_descriptor, 'Debug Symbol Table', status);
                RETURN;
              IFEND;

              NEXT ii_cybil_symbol_table IN symbol_table_text;

              convert_string (ci_cybil_symbol_table^.original_name, 1, ii_cybil_symbol_table^.original_name);
              ii_cybil_symbol_table^.language := ci_cybil_symbol_table^.language;
              ii_cybil_symbol_table^.optimization_level := ci_cybil_symbol_table^.optimization_level;
              convert_string (ci_cybil_symbol_table^.version, 1, ii_cybil_symbol_table^.version);
              ii_cybil_symbol_table^.module_symbol_list := ci_cybil_symbol_table^.module_symbol_list;
              ii_cybil_symbol_table^.number_of_symbols := ci_cybil_symbol_table^.number_of_symbols;
            IFEND;

            NEXT ci_item: [1 .. number_of_items] IN ci_input_seg;

            IF ci_item = NIL THEN
              error (oce$missing_rec_or_descriptor, 'Debug Symbol Table', status);
              RETURN;
            IFEND;

            NEXT ii_item: [1 .. number_of_items] IN symbol_table_text;

            FOR item := 1 TO number_of_items DO
              convert_string (ci_item^ [item].symbol_name, 1, ii_item^ [item].symbol_name);
              convert_boolean (#LOC (ci_item^ [item].end_of_chain), ii_item^ [item].end_of_chain);
              ii_item^ [item].symtab_no := ci_item^ [item].symtab_no;
              ii_item^ [item].symbol_type := ci_item^ [item].symbol_type;

              CASE ii_item^ [item].symbol_type OF
              = int_kind, bool_kind, char_kind, real_kind, longreal_kind, cell_kind =

              = var_kind =
                ii_item^ [item].var_type := ci_item^ [item].var_type;
                ii_item^ [item].var_length := ci_item^ [item].var_length;
                ii_item^ [item].base := ci_item^ [item].base;
                ii_item^ [item].var_section_ordinal := ci_item^ [item].var_section_ordinal;
                ii_item^ [item].var_offset := ci_item^ [item].var_offset;
                convert_boolean (#LOC (ci_item^ [item].indirectly_referenced), ii_item^ [item].
                      indirectly_referenced);
                convert_boolean (#LOC (ci_item^ [item].var_is_parameter), ii_item^ [item].var_is_parameter);

              = cons_kind =
                ii_item^ [item].cons_type := ci_item^ [item].cons_type;
                ii_item^ [item].cons_length_type := ci_item^ [item].cons_length_type;
                convert_integer (#LOC (ci_item^ [item].cons_value), #LOC (ii_item^ [item].cons_value));

              = label_kind =
                ii_item^ [item].line_no := ci_item^ [item].line_no;

              = ordinal_kind =
                ii_item^ [item].last_const := ci_item^ [item].last_const;
                ii_item^ [item].upper_bound := ci_item^ [item].upper_bound;

              = subrange_kind =
                ii_item^ [item].subtype := ci_item^ [item].subtype;
                ii_item^ [item].low_value_type := ci_item^ [item].low_value_type;
                ii_item^ [item].high_value_type := ci_item^ [item].high_value_type;
                convert_integer (#LOC (ci_item^ [item].low_value), #LOC (ii_item^ [item].low_value));
                convert_integer (#LOC (ci_item^ [item].high_value), #LOC (ii_item^ [item].high_value));

              = proc_kind =
                ii_item^ [item].lexical_level := ci_item^ [item].lexical_level;
                ii_item^ [item].symbol_list := ci_item^ [item].symbol_list;
                ii_item^ [item].proc_section_ordinal := ci_item^ [item].proc_section_ordinal;
                ii_item^ [item].proc_offset := ci_item^ [item].proc_offset;
                ii_item^ [item].proc_length := ci_item^ [item].proc_length;
                ii_item^ [item].parent_proc := ci_item^ [item].parent_proc;
                ii_item^ [item].return_type := ci_item^ [item].return_type;

              = pointer_kind =
                ii_item^ [item].ptr_type := ci_item^ [item].ptr_type;
                ii_item^ [item].ptr_object_length := ci_item^ [item].ptr_object_length;

              = set_kind =
                ii_item^ [item].set_element_type := ci_item^ [item].set_element_type;
                ii_item^ [item].set_len := ci_item^ [item].set_len;

              = string_kind =
                ii_item^ [item].len_type := ci_item^ [item].len_type;
                ii_item^ [item].string_len := ci_item^ [item].string_len;

              = array_kind =
                convert_set (#LOC (ci_item^ [item].array_binding), 4, #LOC (ii_item^ [item].array_binding));
                ii_item^ [item].array_packing := ci_item^ [item].array_packing;
                convert_boolean (#LOC (ci_item^ [item].length_is_bits), ii_item^ [item].length_is_bits);
                ii_item^ [item].index_type := ci_item^ [item].index_type;
                ii_item^ [item].array_element_type := ci_item^ [item].array_element_type;
                ii_item^ [item].element_length := ci_item^ [item].element_length;

              = record_kind =
                convert_set (#LOC (ci_item^ [item].record_binding), 4, #LOC (ii_item^ [item].record_binding));
                ii_item^ [item].record_packing := ci_item^ [item].record_packing;
                convert_boolean (#LOC (ci_item^ [item].variation_flag), ii_item^ [item].variation_flag);
                ii_item^ [item].first_field := ci_item^ [item].first_field;
                ii_item^ [item].record_length := ci_item^ [item].record_length;
                ii_item^ [item].selector := ci_item^ [item].selector;

              = field_kind =
                ii_item^ [item].field_offset := ci_item^ [item].field_offset;
                ii_item^ [item].field_length := ci_item^ [item].field_length;
                convert_boolean (#LOC (ci_item^ [item].unit_addressed), ii_item^ [item].unit_addressed);
                ii_item^ [item].field_type := ci_item^ [item].field_type;
                ii_item^ [item].next_field := ci_item^ [item].next_field;

              = selector_kind =
                ii_item^ [item].variation := ci_item^ [item].variation;
                ii_item^ [item].next_selector := ci_item^ [item].next_selector;
                convert_integer (#LOC (ci_item^ [item].low_selector), #LOC (ii_item^ [item].low_selector));
                convert_integer (#LOC (ci_item^ [item].high_selector), #LOC (ii_item^ [item].high_selector));

              = heap_kind =

              = seq_kind =

              = bound_vrec_kind =
                ii_item^ [item].bound_type := ci_item^ [item].bound_type;

              = rel_ptr_kind =
                ii_item^ [item].parent_type := ci_item^ [item].parent_type;
                ii_item^ [item].object_type := ci_item^ [item].object_type;
                ii_item^ [item].rel_ptr_object_length := ci_item^ [item].rel_ptr_object_length;

              ELSE
              CASEND;
            FOREND;


          PROCEND convert_cybil_symbol_table;
?? TITLE := '                               CONVERT BINDING TEMPLATE ITEM' ??
?? EJECT ??

          PROCEDURE convert_binding_template (VAR status: ost$status);


            { 170 binding section }

            TYPE
              llt$ci_binding_template = record
                f00: half_word,
                binding_offset: llt$section_offset,

                f01: array [1 .. 7] of byte,
                case kind: llt$binding_template_kind of
                = llc$current_module =
                  f02: array [1 .. 6] of byte,
                  section_ordinal: llt$section_ordinal,

                  offset: ost$segment_offset,

                  f04: array [1 .. 7] of byte,
                  internal_address: llt$address_kind,

                  f05: array [1 .. 5] of word,

                = llc$external_reference =
                  name: pmt$ci_program_name,

                  f06: array [1 .. 7] of byte,
                  address: llt$address_kind,
                casend,
              recend;

?? EJECT ??

            VAR
              ci_binding: ^llt$ci_binding_template,
              ii_binding: ^llt$binding_template;


            NEXT ci_binding IN ci_input_seg;

            IF ci_binding <> NIL THEN
              NEXT ii_binding IN output_seq;

              ii_binding^.binding_offset := ci_binding^.binding_offset;

              ii_binding^.kind := ci_binding^.kind;

              CASE ci_binding^.kind OF
              = llc$current_module =
                ii_binding^.section_ordinal := ci_binding^.section_ordinal;
                convert_integer (#LOC (ci_binding^.offset), #LOC (ii_binding^.offset));
                ii_binding^.internal_address := ci_binding^.internal_address;

              = llc$external_reference =
                convert_string (ci_binding^.name, 1, ii_binding^.name);
                ii_binding^.address := ci_binding^.address;

              CASEND;
            ELSE
              error (oce$missing_rec_or_descriptor, 'Binding Template Record', status);
            IFEND;


          PROCEND convert_binding_template;
?? TITLE := '                               CONVERT TRANSFER SYMBOL ITEM' ??
?? EJECT ??

          PROCEDURE convert_transfer_symbol_item (VAR status: ost$status);



            { 170 transfer symbol }


            TYPE
              llt$ci_transfer_symbol = record
                name: pmt$ci_program_name,

              recend;


            VAR
              ci_transfer_symbol: ^llt$ci_transfer_symbol,
              ii_transfer_symbol: ^llt$transfer_symbol;

            NEXT ci_transfer_symbol IN ci_input_seg;

            IF ci_transfer_symbol <> NIL THEN
              NEXT ii_transfer_symbol IN output_seq;
              convert_string (ci_transfer_symbol^.name, 1, ii_transfer_symbol^.name);

            ELSE
              error (oce$missing_rec_or_descriptor, 'Transfer Symbol Record', status);
            IFEND;


          PROCEND convert_transfer_symbol_item;
?? OLDTITLE ??
?? EJECT ??

          VAR
            type_of_obj_record {control} : llt$object_record_kind,
            size: integer;


          REPEAT
            convert_object_text_desc_13 (type_of_obj_record, size, status);

            IF status.normal THEN

              CASE type_of_obj_record OF
              = llc$identification =
                error (oce$multiple_ident_records, 'CPU Object Module', status);

              = llc$libraries =
                convert_library_directives (size, status);

              = llc$section_definition =
                convert_section_definition_item (status);

              = llc$text =
                convert_text_item (size, status);

              = llc$replication =
                convert_replication_item (size, status);

              = llc$bit_string_insertion =
                convert_bit_insertion_item (status);

              = llc$address_formulation =
                convert_addr_formulation_item (size, status);

              = llc$external_linkage =
                convert_external_linkage_item (size, status);

              = llc$entry_definition =
                convert_entry_point_definition (status);

              = llc$relocation =
                convert_relocation_item (size, status);

              = llc$actual_parameters =
                convert_actual_parameters (size, status);

              = llc$formal_parameters =
                convert_formal_parameters (size, generator_id, status);

              = llc$cybil_symbol_table_fragment =
                convert_cybil_symbol_table (size, status);

              = llc$binding_template =
                convert_binding_template (status);

              = llc$transfer_symbol =
                convert_transfer_symbol_item (status);

              ELSE
                error (oce$invalid_cpu_record_kind, 'CPU Object Module', status);

              CASEND;

            ELSE
              error (status.condition, 'Object Text Descriptor 1.3', status);
            IFEND;

          UNTIL (type_of_obj_record = llc$transfer_symbol) OR (NOT status.normal);


        PROCEND convert_cpu_object_module;
?? TITLE := '                             CONVERT IDENTIFICATION BODY' ??
?? EJECT ??

        PROCEDURE convert_identification_body (ii_identification: ^llt$identification;
          VAR type_of_object_program: llt$module_kind;
          VAR generator_id: llt$module_generator;
          VAR status: ost$status);


          { 170 identification record }


          TYPE
            llt$ci_identification_body = record
              f00: array [1 .. 7] of byte,
              kind: llt$module_kind,

              time_created: ost$ci_time,

              date_created: ost$ci_date,

              attributes: llt$module_attributes,
              f01: array [1 .. 7] of byte,

              f02: array [1 .. 6] of byte,
              greatest_section_ordinal: llt$section_ordinal,

              f03: array [1 .. 7] of byte,
              generator_id: llt$module_generator,

              generator_name_vers: packed array [1 .. 128] of half_byte,

              commentary: packed array [1 .. 128] of half_byte,

            recend;


          CONST
            num_module_attr = 2;




          { 170 return date }


          TYPE
            ost$ci_date = record
              f01: array [1 .. 7] of byte,
              case date_format: ost$date_formats of
              = osc$month_date =
                month: packed array [1 .. 64] of half_byte,

              = osc$mdy_date =
                mdy: packed array [1 .. 64] of half_byte,

              = osc$iso_date =
                iso: packed array [1 .. 64] of half_byte,

              = osc$ordinal_date =
                ordinal: packed array [1 .. 64] of half_byte,

              casend,

            recend;




          { 170 return time }


          TYPE
            ost$ci_time = record
              f01: array [1 .. 7] of byte,
              case time_format: ost$time_formats of
              = osc$ampm_time =
                ampm: packed array [1 .. 48] of half_byte,

              = osc$hms_time =
                hms: packed array [1 .. 48] of half_byte,

              = osc$millisecond_time =
                millisecond: packed array [1 .. 48] of half_byte,

              casend,

            recend;

?? EJECT ??

          VAR
            ci_identification: ^llt$ci_identification_body;



          NEXT ci_identification IN ci_input_seg;

          IF ci_identification <> NIL THEN

            type_of_object_program := ci_identification^.kind;
            ii_identification^.kind := ci_identification^.kind;

            { convert time request return value }

            ii_identification^.time_created.time_format := ci_identification^.time_created.time_format;

            CASE ci_identification^.time_created.time_format OF
            = osc$ampm_time =
              convert_string (ci_identification^.time_created.ampm, 1, ii_identification^.time_created.ampm);

            = osc$hms_time =
              convert_string (ci_identification^.time_created.hms, 1, ii_identification^.time_created.hms);

            = osc$millisecond_time =
              convert_string (ci_identification^.time_created.millisecond, 1, ii_identification^.time_created.
                    millisecond);
            ELSE
              error (pme$invalid_time_format, 'Identification Record', status);

            CASEND;

            IF status.normal THEN

              { convert date request return value }

              ii_identification^.date_created.date_format := ci_identification^.date_created.date_format;

              CASE ci_identification^.date_created.date_format OF
              = osc$month_date =
                convert_string (ci_identification^.date_created.month, 1, ii_identification^.date_created.
                      month);

              = osc$mdy_date =
                convert_string (ci_identification^.date_created.mdy, 1, ii_identification^.date_created.mdy);

              = osc$iso_date =
                convert_string (ci_identification^.date_created.iso, 1, ii_identification^.date_created.iso);

              = osc$ordinal_date =
                convert_string (ci_identification^.date_created.ordinal, 1, ii_identification^.date_created.
                      ordinal);
              ELSE
                error (pme$invalid_date_format, 'Identification Record', status);

              CASEND;

              IF status.normal THEN

                { finish converting identification record }

                convert_set (#LOC (ci_identification^.attributes), num_module_attr, #LOC (ii_identification^.
                      attributes));

                ii_identification^.greatest_section_ordinal := ci_identification^.greatest_section_ordinal;

                ii_identification^.generator_id := ci_identification^.generator_id;
                generator_id := ci_identification^.generator_id;

                IF generator_id = llc$cybil THEN
                  error (oce$invalid_version, 'V1.3 - CYBIL', status);
                  RETURN;
                IFEND;

                convert_string (ci_identification^.generator_name_vers, 1, ii_identification^.
                      generator_name_vers);

                convert_string (ci_identification^.commentary, 1, ii_identification^.commentary);

              IFEND;
            IFEND;
          ELSE
            error (oce$missing_rec_or_descriptor, 'Identification Record', status);
          IFEND;


        PROCEND convert_identification_body;
?? OLDTITLE ??
?? EJECT ??


        VAR
          kind_of_object_module {control} : llt$module_kind,
          module_generator: llt$module_generator;




        convert_identification_body (ii_identification, kind_of_object_module, module_generator, status);

        IF status.normal THEN
          CASE kind_of_object_module OF
          = llc$iou =
            convert_iou_object_module (status);

          = llc$mi_virtual_state, llc$vector_virtual_state, llc$vector_extended_state =
            convert_cpu_object_module (module_generator, status);

          ELSE
            error (oce$invalid_object_module_kind, 'Version 1.3 Text', status);
          CASEND;

        IFEND;

      PROCEND convert_version_13_text;
?? OLDTITLE ??
?? NEWTITLE := '                           CONVERT VERSION 1.4 TEXT' ??
?? NEWTITLE := '                             CONVERT OBJECT TEXT DESCRIPTOR - 1.4' ??
?? EJECT ??

      PROCEDURE convert_version_14_text (ii_identification: ^llt$identification;
        VAR output_seq: ^SEQ ( * );
        VAR status: ost$status);

{ The following *copy is here on purpose.  If it is moved to the beginning of
{ the module, it will not compile given the current implementation.  The problem is that
{ ordinal types llt$object_record_kind and llt$extended_object_record_kind, which is
{ declared in procedure convert_object_file, use some of the same ordinal names.
{ Declaring llt$object_record_kind here means that the ordinal names override the ones
{ with the same names declared in the outer procedure.

*copy llt$object_record_kind


        VAR
          ii_text_descriptor: ^llt$object_text_descriptor;


        PROCEDURE convert_object_text_desc_14 (VAR object_type: llt$object_record_kind;
          VAR size: integer;
          VAR status: ost$status);





          TYPE
            llt$ci_object_text_descriptor = record
              f00: array [1 .. 7] of byte,
              case kind: llt$object_record_kind of
              = llc$identification, llc$section_definition, llc$entry_definition, llc$binding_template,
                llc$transfer_symbol, llc$bit_string_insertion =
                unused: ost$segment_offset, {always 0}

              = llc$libraries =
                f02: array [1 .. 6] of byte,
                number_of_libraries: 1 .. llc$max_libraries,

              = llc$text, llc$replication =
                f03: array [1 .. 4] of byte,
                number_of_bytes: 1 .. osc$max_segment_length,

              = llc$relocation =
                f05: array [1 .. 6] of byte,
                number_of_rel_items: 1 .. llc$max_rel_items,

              = llc$address_formulation =
                f06: array [1 .. 6] of byte,
                number_of_adr_items: 1 .. llc$max_adr_items,

              = llc$external_linkage =
                f07: array [1 .. 6] of byte,
                number_of_ext_items: 1 .. llc$max_ext_items,

              = llc$formal_parameters, llc$actual_parameters, llc$cybil_symbol_table_fragment,
                llc$symbol_table_fragment, llc$line_table_fragment =
                f08: array [1 .. 4] of byte,
                sequence_length: ost$segment_length,

              = llc$ppu_absolute =
                f09: array [1 .. 6] of byte,
                number_of_words: llt$ppu_address,

              = llc$68000_absolute =
                f10: half_word,
                number_of_68000_bytes: 1 .. llc$maximum_68000_address,
              casend,
            recend;




          VAR
            ci_text_descriptor: ^llt$ci_object_text_descriptor;



          NEXT ci_text_descriptor IN ci_input_seg;

          IF ci_text_descriptor <> NIL THEN
            object_type := ci_text_descriptor^.kind;

            NEXT ii_text_descriptor IN output_seq;

            ii_text_descriptor^.kind := ci_text_descriptor^.kind;

            CASE ci_text_descriptor^.kind OF
            = llc$identification, llc$section_definition, llc$entry_definition, llc$binding_template,
                  llc$bit_string_insertion, llc$transfer_symbol =
              ii_text_descriptor^.unused := ci_text_descriptor^.unused;

            = llc$libraries =
              ii_text_descriptor^.number_of_libraries := ci_text_descriptor^.number_of_libraries;
              size := ci_text_descriptor^.number_of_libraries;

            = llc$text, llc$replication =
              ii_text_descriptor^.number_of_bytes := ci_text_descriptor^.number_of_bytes;
              size := ci_text_descriptor^.number_of_bytes;

            = llc$relocation =
              ii_text_descriptor^.number_of_rel_items := ci_text_descriptor^.number_of_rel_items;
              size := ci_text_descriptor^.number_of_rel_items;

            = llc$address_formulation =
              ii_text_descriptor^.number_of_adr_items := ci_text_descriptor^.number_of_adr_items;
              size := ci_text_descriptor^.number_of_adr_items;

            = llc$external_linkage =
              ii_text_descriptor^.number_of_ext_items := ci_text_descriptor^.number_of_ext_items;
              size := ci_text_descriptor^.number_of_ext_items;

            = llc$formal_parameters, llc$actual_parameters =
              size := ci_text_descriptor^.sequence_length;

            = llc$cybil_symbol_table_fragment =
              size := ci_text_descriptor^.sequence_length;

            = llc$68000_absolute =
              ii_text_descriptor^.number_of_68000_bytes := ci_text_descriptor^.number_of_68000_bytes;
              size := ci_text_descriptor^.sequence_length;

            = llc$symbol_table_fragment, llc$line_table_fragment =
              size := ci_text_descriptor^.sequence_length;
              RESET output_seq TO ii_text_descriptor;

            = llc$ppu_absolute =
              ii_text_descriptor^.number_of_words := ci_text_descriptor^.number_of_words;
              size := ci_text_descriptor^.number_of_words;

            ELSE
              error (oce$invalid_object_record_kind, 'Object Text Descriptor 1.4', status);

            CASEND;

          ELSE
            eoi_warning (oce$missing_rec_or_descriptor, status);

          IFEND;


        PROCEND convert_object_text_desc_14;
?? OLDTITLE ??

?? NEWTITLE := '                             CONVERT IOU OBJECT MODULE' ??
?? NEWTITLE := '                               CONVERT PPU ABSOLUTE ITEM' ??
?? EJECT ??

        PROCEDURE convert_iou_object_module (VAR status: ost$status);




          PROCEDURE convert_ppu_absolute_item (number_of_words: llt$ppu_address;
            VAR status: ost$status);




            { 170 ppu absolute }


            TYPE
              llt$ci_ppu_absolute = record
                executes_on_any_ppu: boolean,
                f01: array [1 .. 7] of byte,

                f02: array [1 .. 7] of byte,
                ppu_number: 0 .. llc$max_ppu_number,

                f03: array [1 .. 6] of byte,
                load_address: llt$ppu_address,

                f04: array [1 .. 6] of byte,
                entry_address: llt$ppu_address,

                text_array: array [ * ] of ppu_text,

              recend,


              ppu_text = record
                f01: array [1 .. 6] of byte,
                text: 0 .. 0ffff(16),

              recend;






            VAR
              ci_ppu: ^llt$ci_ppu_absolute,
              ii_ppu: ^llt$ppu_absolute,
              w: 0 .. llc$max_ppu_size + 1;



            NEXT ci_ppu: [0 .. number_of_words - 1] IN ci_input_seg;

            IF ci_ppu <> NIL THEN

              NEXT ii_ppu: [0 .. number_of_words - 1] IN output_seq;


              convert_boolean (#LOC (ci_ppu^.executes_on_any_ppu), ii_ppu^.executes_on_any_ppu);

              ii_ppu^.ppu_number := ci_ppu^.ppu_number;
              ii_ppu^.load_address := ci_ppu^.load_address;
              ii_ppu^.entry_address := ci_ppu^.entry_address;

              FOR w := 0 TO (number_of_words - 1) DO
                ii_ppu^.text [w] := ci_ppu^.text_array [w].text;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'PPU Record', status);
            IFEND;


          PROCEND convert_ppu_absolute_item;
?? EJECT ??
?? OLDTITLE ??


          VAR
            type_of_obj_record {control} : llt$object_record_kind,
            size: integer;


          convert_object_text_desc_14 (type_of_obj_record, size, status);

          IF status.normal THEN
            CASE type_of_obj_record OF
            = llc$ppu_absolute =
              convert_ppu_absolute_item (size, status);

            ELSE
              error (oce$invalid_ppu_record_kind, 'IOU Object Module', status);

            CASEND;

          ELSE
            error (oce$missing_rec_or_descriptor, 'PPU Descriptor', status);
          IFEND;


        PROCEND convert_iou_object_module;
?? OLDTITLE ??
?? NEWTITLE := '                             CONVERT CPU OBJECT MODULE' ??
?? NEWTITLE := '                               CONVERT LIBRARY DIRECTIVES' ??
?? EJECT ??

        PROCEDURE convert_cpu_object_module (generator_id: llt$module_generator;
          VAR status: ost$status);

{       NOTE:                                    }
{         The parameter 'generator_id' is used }
{         by 'convert_formal_parameters' to      }
{         identify the type of calling procedure.}



          PROCEDURE convert_library_directives (number_of_libraries: 1 .. llc$max_libraries;
            VAR status: ost$status);


            { 170 library directives }


            TYPE
              llt$ci_libraries = array [ * ] of pmt$ci_program_name;


            VAR
              ci_library: ^llt$ci_libraries,
              ii_library: ^llt$libraries,
              l: 1 .. llc$max_libraries + 1;



            NEXT ci_library: [1 .. number_of_libraries] IN ci_input_seg;

            IF ci_library <> NIL THEN
              NEXT ii_library: [1 .. number_of_libraries] IN output_seq;


              FOR l := 1 TO number_of_libraries DO
                convert_string (ci_library^ [l], 1, ii_library^ [l]);
                IF ii_library^ [l] = 'CYBILIB ' THEN
                  ii_library^ [l] := 'CYF$RUN_TIME_LIBRARY';
                ELSEIF ii_library^ [l] = 'CYBMLIB' THEN
                  ii_library^ [l] := 'CYF$DIOS_RUN_TIME_LIBRARY';
                IFEND;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Library Record', status);
            IFEND;


          PROCEND convert_library_directives;
?? TITLE := '                               CONVERT SECTION DEFINITION' ??
?? EJECT ??

          PROCEDURE convert_section_definition_item (VAR status: ost$status);



            { 170 section definitions }


            TYPE
              llt$ci_section_definition = record
                f01: array [1 .. 7] of byte,
                kind: llt$section_kind,

                access_attributes: llt$section_access_attributes,
                f02: array [1 .. 7] of byte,

                f03: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f04: half_word,
                length: ost$segment_length,

                allocation_alignment: ost$segment_offset,

                allocation_offset: ost$segment_offset,

                name: pmt$ci_program_name,

              recend;




?? EJECT ??

            CONST
              num_access_attributes = 4;

            VAR
              ci_section: ^llt$ci_section_definition,
              ii_section: ^llt$section_definition;




            NEXT ci_section IN ci_input_seg;

            IF ci_section <> NIL THEN
              NEXT ii_section IN output_seq;


              ii_section^.kind := ci_section^.kind;

              convert_set (#LOC (ci_section^.access_attributes), num_access_attributes, #LOC (ii_section^.
                    access_attributes));

              ii_section^.section_ordinal := ci_section^.section_ordinal;
              ii_section^.length := ci_section^.length;
              convert_integer (#LOC (ci_section^.allocation_alignment), #LOC (ii_section^.
                    allocation_alignment));
              convert_integer (#LOC (ci_section^.allocation_offset), #LOC (ii_section^.allocation_offset));

              convert_string (ci_section^.name, 1, ii_section^.name);

            ELSE
              error (oce$missing_rec_or_descriptor, 'Section Defn. Record', status);
            IFEND;


          PROCEND convert_section_definition_item;
?? TITLE := '                               CONVERT TEXT ITEM' ??
?? EJECT ??

          PROCEDURE convert_text_item (number_of_bytes: 1 .. osc$max_segment_length;
            VAR status: ost$status);



            { 170 text item }


            TYPE
              llt$ci_text = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                byte_array: array [ * ] of text_component,

              recend,

              text_component = record
                f01: array [1 .. 7] of byte,
                byte: 0 .. 255,

              recend;





            VAR
              ci_text: ^llt$ci_text,
              ii_text: ^llt$text,
              b: 1 .. osc$max_segment_length + 1;

?? EJECT ??
            NEXT ci_text: [1 .. number_of_bytes] IN ci_input_seg;

            IF ci_text <> NIL THEN
              NEXT ii_text: [1 .. number_of_bytes] IN output_seq;


              ii_text^.section_ordinal := ci_text^.section_ordinal;
              ii_text^.offset := ci_text^.offset;

              FOR b := 1 TO number_of_bytes DO
                ii_text^.byte [b] := ci_text^.byte_array [b].byte;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Text Record', status);
            IFEND;


          PROCEND convert_text_item;
?? TITLE := '                               CONVERT REPLICATION ITEM' ??
?? EJECT ??

          PROCEDURE convert_replication_item (number_of_bytes: 1 .. osc$max_segment_length;
            VAR status: ost$status);




            { 170 replication item }


            TYPE
              llt$ci_replication = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                f03: half_word,
                increment: 1 .. osc$max_segment_length,

                f04: half_word,
                count: 1 .. osc$max_segment_length,

                byte_array: array [ * ] of replication_text,

              recend,


              replication_text = record
                f01: array [1 .. 7] of byte,
                byte: 0 .. 255,

              recend;

?? EJECT ??

            VAR
              ci_replication: ^llt$ci_replication,
              ii_replication: ^llt$replication,
              b: 1 .. osc$max_segment_length + 1;



            NEXT ci_replication: [1 .. number_of_bytes] IN ci_input_seg;

            IF ci_replication <> NIL THEN
              NEXT ii_replication: [1 .. number_of_bytes] IN output_seq;


              ii_replication^.section_ordinal := ci_replication^.section_ordinal;
              ii_replication^.offset := ci_replication^.offset;
              ii_replication^.increment := ci_replication^.increment;
              ii_replication^.count := ci_replication^.count;

              FOR b := 1 TO number_of_bytes DO
                ii_replication^.byte [b] := ci_replication^.byte_array [b].byte;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Replication Record', status);
            IFEND;


          PROCEND convert_replication_item;
?? TITLE := '                               CONVERT BIT INSERTION ITEM' ??
?? EJECT ??

          PROCEDURE convert_bit_insertion_item (VAR status: ost$status);




            { 170 bit insertion item }


            TYPE
              llt$ci_bit_string_insertion = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                f03: array [1 .. 7] of byte,
                bit_offset: 0 .. 7,

                f04: array [1 .. 7] of byte,
                bit_length: 1 .. 63,

                bit_string: packed array [1 .. 128] of 0 .. 1,

              recend;


            VAR
              ci_bit_insertion: ^llt$ci_bit_string_insertion,
              ii_bit_insertion: ^llt$bit_string_insertion,
              b: 1 .. 128;

?? EJECT ??



            NEXT ci_bit_insertion IN ci_input_seg;

            IF ci_bit_insertion <> NIL THEN
              NEXT ii_bit_insertion IN output_seq;


              ii_bit_insertion^.section_ordinal := ci_bit_insertion^.section_ordinal;
              ii_bit_insertion^.offset := ci_bit_insertion^.offset;
              ii_bit_insertion^.bit_offset := ci_bit_insertion^.bit_offset;
              ii_bit_insertion^.bit_length := ci_bit_insertion^.bit_length;

              FOR b := 1 TO 60 DO
                ii_bit_insertion^.bit_string [b] := ci_bit_insertion^.bit_string [b + 4];
              FOREND;
              FOR b := 61 TO 63 DO
                ii_bit_insertion^.bit_string [b] := ci_bit_insertion^.bit_string [b + 8];
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Bit Insertion Record', status);
            IFEND;


          PROCEND convert_bit_insertion_item;
?? TITLE := '                               CONVERT ADDRESS FORMULATION ITEM' ??
?? EJECT ??

          PROCEDURE convert_addr_formulation_item (addr_upper_bnd: 1 .. llc$max_adr_items;
            VAR status: ost$status);


            { 170 address formulation item }


            TYPE
              llt$ci_address_formulation = record
                f01: array [1 .. 6] of byte,
                value_section: llt$section_ordinal,

                f02: array [1 .. 6] of byte,
                dest_section: llt$section_ordinal,

                item: array [ * ] of llt$ci_address_formulation_item,

              recend,


              llt$ci_address_formulation_item = record
                f01: array [1 .. 7] of byte,
                kind: llt$internal_address_kind,

                value_offset: ost$segment_offset,

                f03: half_word,
                dest_offset: llt$section_offset,

              recend;






            VAR
              ci_address: ^llt$ci_address_formulation,
              ii_address: ^llt$address_formulation,
              a: 1 .. llc$max_adr_items + 1;

?? EJECT ??



            NEXT ci_address: [1 .. addr_upper_bnd] IN ci_input_seg;

            IF ci_address <> NIL THEN
              NEXT ii_address: [1 .. addr_upper_bnd] IN output_seq;


              ii_address^.value_section := ci_address^.value_section;
              ii_address^.dest_section := ci_address^.dest_section;

              FOR a := 1 TO addr_upper_bnd DO
                ii_address^.item [a].kind := ci_address^.item [a].kind;
                convert_integer (#LOC (ci_address^.item [a].value_offset), #LOC (ii_address^.item [a].
                      value_offset));
                ii_address^.item [a].dest_offset := ci_address^.item [a].dest_offset;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Address Formulation Record', status);
            IFEND;


          PROCEND convert_addr_formulation_item;
?? TITLE := '                               CONVERT EXTERNAL REFERENCE ITEM' ??
?? EJECT ??

          PROCEDURE convert_external_linkage_item (number_of_ext_items: 1 .. llc$max_ext_items;
            VAR status: ost$status);



            { 170 external reference item }


            TYPE
              llt$ci_external_linkage = record
                name: pmt$ci_program_name,

                f00: array [1 .. 7] of byte,
                language: llt$module_generator,

                declaration_matching_required: boolean,
                f01: array [1 .. 7] of byte,

                declaration_matching_value: llt$ci_decl_matching_value,

                item: array [ * ] of llt$ci_external_linkage_item,
              recend,


              llt$ci_external_linkage_item = record
                f02: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f03: half_word,
                offset: llt$section_offset,
                f01: array [1 .. 7] of byte,
                kind: llt$address_kind,

                offset_operand: - osc$maximum_offset .. osc$maximum_offset,

              recend;


?? EJECT ??

            VAR
              ci_external_linkage: ^llt$ci_external_linkage,
              ii_external_linkage: ^llt$external_linkage,
              e: 1 .. llc$max_ext_items + 1;


            NEXT ci_external_linkage: [1 .. number_of_ext_items] IN ci_input_seg;

            IF ci_external_linkage <> NIL THEN
              NEXT ii_external_linkage: [1 .. number_of_ext_items] IN output_seq;

              convert_string (ci_external_linkage^.name, 1, ii_external_linkage^.name);

              ii_external_linkage^.language := ci_external_linkage^.language;
              IF ci_external_linkage^.language = llc$obsolete_cybil THEN
                convert_boolean (#LOC (ci_external_linkage^.declaration_matching_required),
                      ii_external_linkage^.declaration_matching_required);
                ii_external_linkage^.declaration_matching.language_dependent_value :=
                      ci_external_linkage^.declaration_matching_value.lower_1 * 100000000(16) +
                      ci_external_linkage^.declaration_matching_value.lower_2;
              ELSE

                ii_external_linkage^.declaration_matching_required := FALSE;

                ii_external_linkage^.declaration_matching.object_encryption := 0;
                ii_external_linkage^.declaration_matching.source_encryption := 0;
              IFEND;
              FOR e := 1 TO number_of_ext_items DO
                ii_external_linkage^.item [e].kind := ci_external_linkage^.item [e].kind;

                convert_integer (#LOC (ci_external_linkage^.item [e].offset_operand), #LOC
                      (ii_external_linkage^.item [e].offset_operand));

                ii_external_linkage^.item [e].section_ordinal := ci_external_linkage^.item [e].
                      section_ordinal;
                ii_external_linkage^.item [e].offset := ci_external_linkage^.item [e].offset;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'External Reference Record', status);
            IFEND;


          PROCEND convert_external_linkage_item;
?? TITLE := '                               CONVERT ENTRY POINT DEFINITION' ??
?? EJECT ??

          PROCEDURE convert_entry_point_definition (VAR status: ost$status);




            { 170 entry point definition item }


            TYPE
              llt$ci_entry_definition = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                attributes: llt$entry_point_attributes,
                f03: array [1 .. 7] of byte,

                name: pmt$ci_program_name,

                f04: array [1 .. 7] of byte,
                language: llt$module_generator,

                declaration_matching_required: boolean,
                f05: array [1 .. 7] of byte,

                declaration_matching_value: llt$ci_decl_matching_value,

              recend;


            CONST
              num_entry_point_attr = 2;

?? EJECT ??

            VAR
              ci_entry_point: ^llt$ci_entry_definition,
              ii_entry_point: ^llt$entry_definition;



            NEXT ci_entry_point IN ci_input_seg;

            IF ci_entry_point <> NIL THEN
              NEXT ii_entry_point IN output_seq;


              ii_entry_point^.section_ordinal := ci_entry_point^.section_ordinal;
              ii_entry_point^.offset := ci_entry_point^.offset;

              convert_set (#LOC (ci_entry_point^.attributes), num_entry_point_attr, #LOC (ii_entry_point^.
                    attributes));

              convert_string (ci_entry_point^.name, 1, ii_entry_point^.name);

              ii_entry_point^.language := ci_entry_point^.language;
              IF ci_entry_point^.language = llc$obsolete_cybil THEN
                convert_boolean (#LOC (ci_entry_point^.declaration_matching_required),
                      ii_entry_point^.declaration_matching_required);
                ii_entry_point^.declaration_matching.language_dependent_value :=
                      ci_entry_point^.declaration_matching_value.lower_1 * 100000000(16) +
                      ci_entry_point^.declaration_matching_value.lower_2;
              ELSE

                ii_entry_point^.declaration_matching_required := FALSE;

                ii_entry_point^.declaration_matching.object_encryption := 0;
                ii_entry_point^.declaration_matching.source_encryption := 0;
              IFEND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Entry Point Defn. Record', status);
            IFEND;


          PROCEND convert_entry_point_definition;
?? TITLE := '                               CONVERT RELOCATION ITEM' ??
?? EJECT ??

          PROCEDURE convert_relocation_item (number_of_rel_items: 1 .. llc$max_rel_items;
            VAR status: ost$status);



            { relocation item }

            TYPE
              llt$ci_relocation = array [ * ] of llt$ci_relocation_item,


              llt$ci_relocation_item = record
                f01: array [1 .. 6] of byte,
                section_ordinal: llt$section_ordinal,

                f02: half_word,
                offset: llt$section_offset,

                f03: array [1 .. 6] of byte,
                relocating_section: llt$section_ordinal,

                f04: array [1 .. 7] of byte,
                container: llt$relocation_container,

                f05: array [1 .. 7] of byte,
                address: llt$address_type,

              recend;

?? EJECT ??



            VAR
              ci_relocation: ^llt$ci_relocation,
              ii_relocation: ^llt$relocation,
              r: 1 .. llc$max_rel_items + 1;



            NEXT ci_relocation: [1 .. number_of_rel_items] IN ci_input_seg;

            IF ci_relocation <> NIL THEN
              NEXT ii_relocation: [1 .. number_of_rel_items] IN output_seq;

              FOR r := 1 TO number_of_rel_items DO
                ii_relocation^ [r].section_ordinal := ci_relocation^ [r].section_ordinal;
                ii_relocation^ [r].offset := ci_relocation^ [r].offset;
                ii_relocation^ [r].relocating_section := ci_relocation^ [r].relocating_section;
                ii_relocation^ [r].container := ci_relocation^ [r].container;
                ii_relocation^ [r].address := ci_relocation^ [r].address;
              FOREND;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Relocation Record', status);
            IFEND;


          PROCEND convert_relocation_item;
?? TITLE := '                               170 Formal & Actual Parameter Items' ??
?? EJECT ??




          { 170 procedure formal parameter description item }


          TYPE
            llt$ci_formal_parameters = record
              procedure_name: pmt$ci_program_name,

            recend;


          { 170 procedure call actual parameters item }


          TYPE
            llt$ci_actual_parameters = record
              callee_name: pmt$ci_program_name,

              f01: array [1 .. 7] of byte,
              language: llt$module_generator,

              f02: array [1 .. 5] of byte,
              line_number_of_call: llt$source_line_number,


            recend,

            llt$ci_source_line_number = packed array [1 .. 32] of half_byte;





?? TITLE := '                               170 Fortran Argument Descriptor' ??
?? EJECT ??
          { 170 fortran argument description: used to describe a }
          { single actual or formal fortran parameter }


          TYPE
            llt$ci_fortran_argument_desc = record
              f01: array [1 .. 7] of byte,
              argument_type: llt$fortran_argument_type,

              string_length: llt$ci_fortran_string_length,

              f02: array [1 .. 7] of byte,
              argument_kind: llt$fortran_argument_kind,

              array_size: llt$ci_fortran_array_size,

              f03: array [1 .. 6] of byte,
              dummy_argument_ordinal: 1 .. llc$max_fortran_arguments,


              f04: array [1 .. 7] of byte,
              mode: llt$argument_usage,
            recend,


            llt$ci_fortran_string_length = packed record
              f01: half_byte,
              attributes: llt$fortran_string_attributes,
              f02: half_byte,
              f03: array [1 .. 6] of byte,

              f04: array [1 .. 6] of byte,
              number_of_characters: llt$fortran_string_size,
            recend,


            llt$ci_fortran_array_size = packed record
              f01: half_byte,
              attributes: llt$fortran_array_attributes,
              f02: half_byte,
              f03: array [1 .. 6] of byte,

              f04: array [1 .. 7] of byte,
              rank: llt$fortran_array_rank,

              f05: half_word,
              number_of_elements: llt$section_length,
            recend;




?? TITLE := '                               CONVERT FORTRAN PARAMETERS' ??
?? EJECT ??

          PROCEDURE convert_fortran_parameters (sequence_length: ost$segment_length;
            VAR parameters: SEQ ( * );
            VAR status: ost$status);


            VAR
              parameter_sequence: ^SEQ ( * ),
              ci_fortran_parameter: ^array [1 .. * ] of llt$ci_fortran_argument_desc,
              ii_fortran_parameter: ^array [1 .. * ] of llt$fortran_argument_desc,
              num_params: integer,
              np: integer;


            num_params := sequence_length DIV #SIZE (llt$ci_fortran_argument_desc);

            NEXT ci_fortran_parameter: [1 .. num_params] IN ci_input_seg;
            IF ci_fortran_parameter = NIL THEN
              error (oce$missing_rec_or_descriptor, 'Fortran Parameters', status);
              RETURN;
            IFEND;

            parameter_sequence := ^parameters;
            RESET parameter_sequence;
            NEXT ii_fortran_parameter: [1 .. num_params] IN parameter_sequence;

            FOR np := 1 TO num_params DO
              ii_fortran_parameter^ [np].argument_type := ci_fortran_parameter^ [np].argument_type;

              ii_fortran_parameter^ [np].string_length.attributes := ci_fortran_parameter^ [np].string_length.
                    attributes;

              ii_fortran_parameter^ [np].string_length.number_of_characters := ci_fortran_parameter^ [np].
                    string_length.number_of_characters;

              ii_fortran_parameter^ [np].argument_kind := ci_fortran_parameter^ [np].argument_kind;

              ii_fortran_parameter^ [np].array_size.attributes := ci_fortran_parameter^ [np].array_size.
                    attributes;

              ii_fortran_parameter^ [np].array_size.rank := ci_fortran_parameter^ [np].array_size.rank;

              ii_fortran_parameter^ [np].array_size.number_of_elements := ci_fortran_parameter^ [np].
                    array_size.number_of_elements;

              ii_fortran_parameter^ [np].dummy_argument_ordinal := ci_fortran_parameter^ [np].
                    dummy_argument_ordinal;

              ii_fortran_parameter^ [np].mode := ci_fortran_parameter^ [np].mode;
            FOREND;


          PROCEND convert_fortran_parameters;
?? TITLE := '                               CONVERT FORMAL PARAMETERS' ??
?? EJECT ??

          PROCEDURE convert_formal_parameters (sequence_length: ost$segment_length;
                type_of_calling_routine {control} : llt$module_generator;
            VAR status: ost$status);



            VAR
              ci_parameter_item: ^llt$ci_formal_parameters,
              ii_parameter_item: ^llt$formal_parameters;



            NEXT ci_parameter_item IN ci_input_seg;

            IF ci_parameter_item <> NIL THEN
              CASE type_of_calling_routine OF
              = llc$fortran =
                ii_text_descriptor^.sequence_length := sequence_length DIV #SIZE
                      (llt$ci_fortran_argument_desc) * #SIZE (llt$fortran_argument_desc);

                NEXT ii_parameter_item: [[REP ii_text_descriptor^.sequence_length OF cell]] IN output_seq;

                convert_fortran_parameters (sequence_length, ii_parameter_item^.specification, status);
              ELSE
                error (oce$invalid_parameter_kind, 'Formal Parameters', status);
              CASEND;

              convert_string (ci_parameter_item^.procedure_name, 1, ii_parameter_item^.procedure_name);

            ELSE
              error (oce$missing_rec_or_descriptor, 'Formal Parameters', status);
            IFEND;


          PROCEND convert_formal_parameters;
?? TITLE := '                               CONVERT ACTUAL PARAMETERS' ??
?? EJECT ??

          PROCEDURE convert_actual_parameters (sequence_length: ost$segment_length;
            VAR status: ost$status);



            VAR
              ci_parameter_item: ^llt$ci_actual_parameters,
              ii_parameter_item: ^llt$actual_parameters;



            NEXT ci_parameter_item IN ci_input_seg;

            IF ci_parameter_item <> NIL THEN
              CASE ci_parameter_item^.language OF
              = llc$fortran =
                ii_text_descriptor^.sequence_length := sequence_length DIV #SIZE
                      (llt$ci_fortran_argument_desc) * #SIZE (llt$fortran_argument_desc);

                NEXT ii_parameter_item: [[REP ii_text_descriptor^.sequence_length OF cell]] IN output_seq;

                convert_fortran_parameters (sequence_length, ii_parameter_item^.specification, status);
              ELSE
                error (oce$invalid_parameter_kind, 'Actual Parameters', status);
              CASEND;

              convert_string (ci_parameter_item^.callee_name, 1, ii_parameter_item^.callee_name);

              ii_parameter_item^.language := ci_parameter_item^.language;

              ii_parameter_item^.line_number_of_call := ci_parameter_item^.line_number_of_call;

            ELSE
              error (oce$missing_rec_or_descriptor, 'Actual Parameters', status);
            IFEND;


          PROCEND convert_actual_parameters;
?? TITLE := '                               170 Debug Symbol Table Declarations' ??
?? EJECT ??

          TYPE
            cyt$ci_cybil_symbol_table = record
              original_name: pmt$ci_program_name,

              f01: array [1 .. 7] of byte,
              language: llt$module_generator,

              f02: array [1 .. 7] of byte,
              optimization_level: 0 .. 255,

              version: packed array [1 .. 16] of half_byte,

              f03: array [1 .. 6] of byte,
              module_symbol_list: symbol_no,

              f04: array [1 .. 6] of byte,
              number_of_symbols: symbol_no,
            recend,

            cyt$ci_cybil_symbol_table_item = record
              symbol_name: pmt$ci_program_name,

              end_of_chain: boolean,
              f01: array [1 .. 7] of byte,

              f02: array [1 .. 6] of byte,
              symtab_no: symbol_no,

              f03: array [1 .. 7] of byte,
              case symbol_type: entry_kinds of

              = int_kind, bool_kind, char_kind, real_kind, longreal_kind, cell_kind =
                ,

              = var_kind =
                f04: array [1 .. 6] of byte,
                var_type: symbol_no,

                f05: half_word,
                var_length: ost$segment_length,

                f06: array [1 .. 7] of byte,
                base: base_type,

                f07: array [1 .. 6] of byte,
                var_section_ordinal: llt$section_ordinal,

                f08: half_word,
                var_offset: ost$segment_length,

                indirectly_referenced: boolean,
                f09: array [1 .. 7] of byte,

                var_is_parameter: boolean,
                f10: array [1 .. 7] of byte,

              = cons_kind =
                f11: array [1 .. 6] of byte,
                cons_type: symbol_no,

                f12: array [1 .. 7] of byte,
                cons_length_type: (short_constant_type, long_constant_type),

                cons_value: integer_range,

              = label_kind =
                f13: array [1 .. 6] of byte,
                line_no: line_number_range,

              = ordinal_kind =
                f14: array [1 .. 6] of byte,
                last_const: symbol_no,

                f15: array [1 .. 6] of byte,
                upper_bound: 0 .. 4095,

              = subrange_kind =
                f16: array [1 .. 6] of byte,
                subtype: symbol_no,

                f17: array [1 .. 7] of byte,
                low_value_type: len_kinds,

                f18: array [1 .. 7] of byte,
                high_value_type: len_kinds,

                low_value: integer_range,

                high_value: integer_range,


              = proc_kind =
                f19: array [1 .. 7] of byte,
                lexical_level: 0 .. 255,

                f20: array [1 .. 6] of byte,
                symbol_list: symbol_no,

                f21: array [1 .. 6] of byte,
                proc_section_ordinal: llt$section_ordinal,

                f22: half_word,
                proc_offset: ost$segment_length,

                f23: half_word,
                proc_length: ost$segment_length,

                f24: array [1 .. 6] of byte,
                parent_proc: symbol_no,

                f25: array [1 .. 6] of byte,
                return_type: symbol_no,

              = pointer_kind =
                f26: array [1 .. 6] of byte,
                ptr_type: symbol_no,

                f100: half_word,
                ptr_object_length: ost$segment_length,

              = set_kind =
                f27: array [1 .. 6] of byte,
                set_element_type: symbol_no,

                f28: array [1 .. 6] of byte,
                set_len: 0 .. 7fff(16),

              = string_kind =
                f29: array [1 .. 7] of byte,
                len_type: len_kinds,

                f30: array [1 .. 6] of byte,
                string_len: symbol_no,

              = array_kind =
                array_binding: bindkinds,
                f31: array [1 .. 7] of byte,

                f32: array [1 .. 7] of byte,
                array_packing: packattrs,

                length_is_bits: boolean,
                f33: array [1 .. 7] of byte,

                f34: array [1 .. 6] of byte,
                index_type: symbol_no,

                f35: array [1 .. 6] of byte,
                array_element_type: symbol_no,

                f36: half_word,
                element_length: ost$segment_length,

              = record_kind =
                record_binding: bindkinds,
                f37: array [1 .. 7] of byte,

                f38: array [1 .. 7] of byte,
                record_packing: packattrs,

                variation_flag: boolean,
                f39: array [1 .. 7] of byte,

                f40: array [1 .. 6] of byte,
                first_field: symbol_no,

                f41: half_word,
                record_length: ost$segment_length,

                f42: array [1 .. 6] of byte,
                selector: symbol_no,

              = field_kind =
                f43: array [1 .. 3] of byte,
                field_offset: machine_addr_in_bits_type,

                f44: array [1 .. 3] of byte,
                field_length: machine_addr_in_bits_type,

                unit_addressed: boolean,
                f45: array [1 .. 7] of byte,

                f46: array [1 .. 6] of byte,
                field_type: symbol_no,

                f47: array [1 .. 6] of byte,
                next_field: symbol_no,


              = selector_kind =
                f48: array [1 .. 6] of byte,
                variation: symbol_no,

                f50: array [1 .. 6] of byte,
                next_selector: symbol_no,

                low_selector: integer_range,

                high_selector: integer_range,


              = heap_kind =
                ,


              = seq_kind =
                ,


              = bound_vrec_kind =
                f52: array [1 .. 6] of byte,
                bound_type: symbol_no,


              = rel_ptr_kind =
                f53: array [1 .. 6] of byte,
                parent_type: symbol_no,

                f54: array [1 .. 6] of byte,
                object_type: symbol_no,

                f55: half_word,
                rel_ptr_object_length: ost$segment_length,

              casend,
            recend;

          TYPE

            llt$ci_debug_table_fragment = record
              f01: half_word,
              offset: llt$section_offset,
            recend;

          TYPE
            cyt$ii_cybil_symbol_table = record
              original_name: pmt$program_name,
              language: llt$module_generator,
              optimization_level: 0 .. 255,
              version: string (4),
              module_symbol_list: symbol_no,
              number_of_symbols: symbol_no,
            recend;

?? TITLE := '                               CONVERT CYBIL SYMBOL TABLE' ??
?? EJECT ??

          PROCEDURE convert_cybil_symbol_table (sequence_length: ost$segment_length;
            VAR status: ost$status);


            VAR
              symbol_table_text: ^SEQ ( * ),

              number_of_items: integer,
              item: integer,

              header_present: boolean,
              number_of_bytes: integer,

              ci_debug_table_fragment: ^llt$ci_debug_table_fragment,
              ii_debug_table_fragment: ^llt$debug_table_fragment,

              ci_cybil_symbol_table: ^cyt$ci_cybil_symbol_table,
              ii_cybil_symbol_table: ^cyt$ii_cybil_symbol_table,

              ci_item: ^array [1 .. * ] of cyt$ci_cybil_symbol_table_item,
              ii_item: ^array [1 .. * ] of cyt$debug_symbol_table_item,

              ci_dummy_name: packed array [1 .. 100] of half_byte,
              ii_dummy_name: pmt$program_name;


            number_of_bytes := sequence_length * 8;

            header_present := number_of_bytes MOD #SIZE (cyt$ci_cybil_symbol_table_item) <> 0;

            IF header_present THEN
              number_of_items := (number_of_bytes - #SIZE (cyt$ci_cybil_symbol_table)) DIV #SIZE
                    (cyt$ci_cybil_symbol_table_item);
              ii_text_descriptor^.sequence_length := number_of_items * #SIZE (cyt$debug_symbol_table_item) +
                    #SIZE (cyt$ii_cybil_symbol_table);
            ELSE
              number_of_items := number_of_bytes DIV #SIZE (cyt$ci_cybil_symbol_table_item);
              ii_text_descriptor^.sequence_length := number_of_items * #SIZE (cyt$debug_symbol_table_item);
            IFEND;

            NEXT ci_debug_table_fragment IN ci_input_seg;
            IF ci_debug_table_fragment = NIL THEN
              error (oce$missing_rec_or_descriptor, 'Debug Symbol Table', status);
              RETURN;
            IFEND;

            NEXT ii_debug_table_fragment: [[REP ii_text_descriptor^.sequence_length OF cell]] IN output_seq;

            ii_debug_table_fragment^.offset := ci_debug_table_fragment^.offset;

            symbol_table_text := ^ii_debug_table_fragment^.text;
            RESET symbol_table_text;
            IF header_present THEN
              NEXT ci_cybil_symbol_table IN ci_input_seg;
              IF ci_cybil_symbol_table = NIL THEN
                error (oce$missing_rec_or_descriptor, 'Debug Symbol Table', status);
                RETURN;
              IFEND;

              NEXT ii_cybil_symbol_table IN symbol_table_text;

              convert_string (ci_cybil_symbol_table^.original_name, 1, ii_cybil_symbol_table^.original_name);
              ii_cybil_symbol_table^.language := ci_cybil_symbol_table^.language;
              ii_cybil_symbol_table^.optimization_level := ci_cybil_symbol_table^.optimization_level;
              convert_string (ci_cybil_symbol_table^.version, 1, ii_cybil_symbol_table^.version);
              ii_cybil_symbol_table^.module_symbol_list := ci_cybil_symbol_table^.module_symbol_list;
              ii_cybil_symbol_table^.number_of_symbols := ci_cybil_symbol_table^.number_of_symbols;
            IFEND;

            NEXT ci_item: [1 .. number_of_items] IN ci_input_seg;

            IF ci_item = NIL THEN
              error (oce$missing_rec_or_descriptor, 'Debug Symbol Table', status);
              RETURN;
            IFEND;

            NEXT ii_item: [1 .. number_of_items] IN symbol_table_text;

            FOR item := 1 TO number_of_items DO
              convert_string (ci_item^ [item].symbol_name, 1, ii_item^ [item].symbol_name);
              convert_boolean (#LOC (ci_item^ [item].end_of_chain), ii_item^ [item].end_of_chain);
              ii_item^ [item].symtab_no := ci_item^ [item].symtab_no;
              ii_item^ [item].symbol_type := ci_item^ [item].symbol_type;

              CASE ii_item^ [item].symbol_type OF
              = int_kind, bool_kind, char_kind, real_kind, longreal_kind, cell_kind =

              = var_kind =
                ii_item^ [item].var_type := ci_item^ [item].var_type;
                ii_item^ [item].var_length := ci_item^ [item].var_length;
                ii_item^ [item].base := ci_item^ [item].base;
                ii_item^ [item].var_section_ordinal := ci_item^ [item].var_section_ordinal;
                ii_item^ [item].var_offset := ci_item^ [item].var_offset;
                convert_boolean (#LOC (ci_item^ [item].indirectly_referenced), ii_item^ [item].
                      indirectly_referenced);
                convert_boolean (#LOC (ci_item^ [item].var_is_parameter), ii_item^ [item].var_is_parameter);

              = cons_kind =
                ii_item^ [item].cons_type := ci_item^ [item].cons_type;
                ii_item^ [item].cons_length_type := ci_item^ [item].cons_length_type;
                convert_integer (#LOC (ci_item^ [item].cons_value), #LOC (ii_item^ [item].cons_value));

              = label_kind =
                ii_item^ [item].line_no := ci_item^ [item].line_no;

              = ordinal_kind =
                ii_item^ [item].last_const := ci_item^ [item].last_const;
                ii_item^ [item].upper_bound := ci_item^ [item].upper_bound;

              = subrange_kind =
                ii_item^ [item].subtype := ci_item^ [item].subtype;
                ii_item^ [item].low_value_type := ci_item^ [item].low_value_type;
                ii_item^ [item].high_value_type := ci_item^ [item].high_value_type;
                convert_integer (#LOC (ci_item^ [item].low_value), #LOC (ii_item^ [item].low_value));
                convert_integer (#LOC (ci_item^ [item].high_value), #LOC (ii_item^ [item].high_value));

              = proc_kind =
                ii_item^ [item].lexical_level := ci_item^ [item].lexical_level;
                ii_item^ [item].symbol_list := ci_item^ [item].symbol_list;
                ii_item^ [item].proc_section_ordinal := ci_item^ [item].proc_section_ordinal;
                ii_item^ [item].proc_offset := ci_item^ [item].proc_offset;
                ii_item^ [item].proc_length := ci_item^ [item].proc_length;
                ii_item^ [item].parent_proc := ci_item^ [item].parent_proc;
                ii_item^ [item].return_type := ci_item^ [item].return_type;

              = pointer_kind =
                ii_item^ [item].ptr_type := ci_item^ [item].ptr_type;
                ii_item^ [item].ptr_object_length := ci_item^ [item].ptr_object_length;

              = set_kind =
                ii_item^ [item].set_element_type := ci_item^ [item].set_element_type;
                ii_item^ [item].set_len := ci_item^ [item].set_len;

              = string_kind =
                ii_item^ [item].len_type := ci_item^ [item].len_type;
                ii_item^ [item].string_len := ci_item^ [item].string_len;

              = array_kind =
                convert_set (#LOC (ci_item^ [item].array_binding), 4, #LOC (ii_item^ [item].array_binding));
                ii_item^ [item].array_packing := ci_item^ [item].array_packing;
                convert_boolean (#LOC (ci_item^ [item].length_is_bits), ii_item^ [item].length_is_bits);
                ii_item^ [item].index_type := ci_item^ [item].index_type;
                ii_item^ [item].array_element_type := ci_item^ [item].array_element_type;
                ii_item^ [item].element_length := ci_item^ [item].element_length;

              = record_kind =
                convert_set (#LOC (ci_item^ [item].record_binding), 4, #LOC (ii_item^ [item].record_binding));
                ii_item^ [item].record_packing := ci_item^ [item].record_packing;
                convert_boolean (#LOC (ci_item^ [item].variation_flag), ii_item^ [item].variation_flag);
                ii_item^ [item].first_field := ci_item^ [item].first_field;
                ii_item^ [item].record_length := ci_item^ [item].record_length;
                ii_item^ [item].selector := ci_item^ [item].selector;

              = field_kind =
                ii_item^ [item].field_offset := ci_item^ [item].field_offset;
                ii_item^ [item].field_length := ci_item^ [item].field_length;
                convert_boolean (#LOC (ci_item^ [item].unit_addressed), ii_item^ [item].unit_addressed);
                ii_item^ [item].field_type := ci_item^ [item].field_type;
                ii_item^ [item].next_field := ci_item^ [item].next_field;

              = selector_kind =
                ii_item^ [item].variation := ci_item^ [item].variation;
                ii_item^ [item].next_selector := ci_item^ [item].next_selector;
                convert_integer (#LOC (ci_item^ [item].low_selector), #LOC (ii_item^ [item].low_selector));
                convert_integer (#LOC (ci_item^ [item].high_selector), #LOC (ii_item^ [item].high_selector));

              = heap_kind =

              = seq_kind =

              = bound_vrec_kind =
                ii_item^ [item].bound_type := ci_item^ [item].bound_type;

              = rel_ptr_kind =
                ii_item^ [item].parent_type := ci_item^ [item].parent_type;
                ii_item^ [item].object_type := ci_item^ [item].object_type;
                ii_item^ [item].rel_ptr_object_length := ci_item^ [item].rel_ptr_object_length;

              ELSE
              CASEND;
            FOREND;


          PROCEND convert_cybil_symbol_table;
?? TITLE := '                               CONVERT SYMBOL TABLE FRAGMENT', EJECT ??

          PROCEDURE convert_symbol_table_fragment (sequence_length: ost$segment_length;
            VAR status: ost$status);


            VAR
              number_of_bytes: ost$segment_length,
              ci_symbol_table_fragment: ^llt$ci_debug_table_fragment,
              text: ^SEQ ( * );


            number_of_bytes := sequence_length * 8;

            NEXT ci_symbol_table_fragment IN ci_input_seg;
            IF ci_symbol_table_fragment = NIL THEN
              error (oce$missing_rec_or_descriptor, 'Symbol table fragment', status);
              RETURN;
            IFEND;

            NEXT text: [[REP number_of_bytes OF cell]] IN ci_input_seg;
            IF text = NIL THEN
              error (oce$missing_rec_or_descriptor, 'Symbol table fragment text', status);
              RETURN;
            IFEND;


          PROCEND convert_symbol_table_fragment;
?? TITLE := '                               CONVERT LINE TABLE FRAGMENT', EJECT ??

          PROCEDURE convert_line_table_fragment (sequence_length: ost$segment_length;
            VAR status: ost$status);


            VAR
              number_of_bytes: ost$segment_length,
              ci_line_table_fragment: ^llt$ci_debug_table_fragment,
              text: ^SEQ ( * );


            number_of_bytes := sequence_length * 8;

            NEXT ci_line_table_fragment IN ci_input_seg;
            IF ci_line_table_fragment = NIL THEN
              error (oce$missing_rec_or_descriptor, 'Line table fragment', status);
              RETURN;
            IFEND;

            NEXT text: [[REP number_of_bytes OF cell]] IN ci_input_seg;
            IF text = NIL THEN
              error (oce$missing_rec_or_descriptor, 'Line table fragment text', status);
              RETURN;
            IFEND;


          PROCEND convert_line_table_fragment;
?? TITLE := '                               CONVERT BINDING TEMPLATE ITEM' ??
?? EJECT ??

          PROCEDURE convert_binding_template (VAR status: ost$status);


            { 170 binding section }

            TYPE
              llt$ci_binding_template = record
                f00: half_word,
                binding_offset: llt$section_offset,

                f01: array [1 .. 7] of byte,
                case kind: llt$binding_template_kind of
                = llc$current_module =
                  f02: array [1 .. 6] of byte,
                  section_ordinal: llt$section_ordinal,

                  offset: ost$segment_offset,

                  f04: array [1 .. 7] of byte,
                  internal_address: llt$address_kind,

                  f05: array [1 .. 5] of word,

                = llc$external_reference =
                  name: pmt$ci_program_name,

                  f06: array [1 .. 7] of byte,
                  address: llt$address_kind,
                casend,
              recend;

?? EJECT ??

            VAR
              ci_binding: ^llt$ci_binding_template,
              ii_binding: ^llt$binding_template;


            NEXT ci_binding IN ci_input_seg;

            IF ci_binding <> NIL THEN
              NEXT ii_binding IN output_seq;

              ii_binding^.binding_offset := ci_binding^.binding_offset;

              ii_binding^.kind := ci_binding^.kind;

              CASE ci_binding^.kind OF
              = llc$current_module =
                ii_binding^.section_ordinal := ci_binding^.section_ordinal;
                convert_integer (#LOC (ci_binding^.offset), #LOC (ii_binding^.offset));
                ii_binding^.internal_address := ci_binding^.internal_address;

              = llc$external_reference =
                convert_string (ci_binding^.name, 1, ii_binding^.name);
                ii_binding^.address := ci_binding^.address;

              CASEND;
            ELSE
              error (oce$missing_rec_or_descriptor, 'Binding Template Record', status);
            IFEND;


          PROCEND convert_binding_template;
?? TITLE := '                               CONVERT 68000 ABSOLUTE' ??
?? EJECT ??

          PROCEDURE convert_68000_absolute (number_of_bytes: 1 .. llc$maximum_68000_address;
            VAR status: ost$status);



            { 170 68000 absolute }


            TYPE
              llt$ci_68000_absolute = record
                f01: half_word,
                load_address: llt$68000_address,

                f02: half_word,
                transfer_address: llt$68000_address,
              recend;


            VAR
              ci_68000_absolute: ^llt$ci_68000_absolute,
              ii_68000_absolute: ^llt$68000_absolute,
              seq_pointer: ^SEQ ( * ),
              array_170: ^packed array [0 .. 15] of half_byte,
              array_180: ^packed array [1 .. * ] of half_byte,
              i: integer,
              c: 0 .. 15;


            NEXT ci_68000_absolute IN ci_input_seg;
            IF ci_68000_absolute = NIL THEN
              error (oce$missing_rec_or_descriptor, '68000 Absolute', status);
              RETURN;
            IFEND;

            NEXT ii_68000_absolute: [[REP number_of_bytes OF cell]] IN output_seq;

            ii_68000_absolute^.load_address := ci_68000_absolute^.load_address;
            ii_68000_absolute^.transfer_address := ci_68000_absolute^.transfer_address;


            seq_pointer := ^ii_68000_absolute^.text;
            RESET seq_pointer;
            NEXT array_180: [1 .. (2 * number_of_bytes)] IN seq_pointer;

            i := 0;
            WHILE (i + 15) <= (2 * number_of_bytes) DO
              NEXT array_170 IN ci_input_seg;
              IF array_170 = NIL THEN
                error (oce$missing_rec_or_descriptor, '68000 Absolute text', status);
                RETURN;
              IFEND;

              FOR c := 1 TO 15 DO
                i := i + 1;
                array_180^ [i] := array_170^ [c];
              FOREND;
            WHILEND;

            IF i < (2 * number_of_bytes) THEN
              NEXT array_170 IN ci_input_seg;
              IF array_170 = NIL THEN
                error (oce$missing_rec_or_descriptor, '68000 Absolute text - last bytes', status);
                RETURN;
              IFEND;

              c := 0;
              FOR i := (i + 1) TO (2 * number_of_bytes) DO
                c := c + 1;
                array_180^ [i] := array_170^ [c];
              FOREND;
            IFEND;


          PROCEND convert_68000_absolute;
?? TITLE := '                               CONVERT TRANSFER SYMBOL ITEM' ??
?? EJECT ??

          PROCEDURE convert_transfer_symbol_item (VAR status: ost$status);



            { 170 transfer symbol }


            TYPE
              llt$ci_transfer_symbol = record
                name: pmt$ci_program_name,

              recend;


            VAR
              ci_transfer_symbol: ^llt$ci_transfer_symbol,
              ii_transfer_symbol: ^llt$transfer_symbol;

            NEXT ci_transfer_symbol IN ci_input_seg;

            IF ci_transfer_symbol <> NIL THEN
              NEXT ii_transfer_symbol IN output_seq;
              convert_string (ci_transfer_symbol^.name, 1, ii_transfer_symbol^.name);

            ELSE
              error (oce$missing_rec_or_descriptor, 'Transfer Symbol Record', status);
            IFEND;


          PROCEND convert_transfer_symbol_item;
?? OLDTITLE ??
?? EJECT ??

          VAR
            type_of_obj_record {control} : llt$object_record_kind,
            size: integer;


          REPEAT
            convert_object_text_desc_14 (type_of_obj_record, size, status);

            IF status.normal THEN

              CASE type_of_obj_record OF
              = llc$identification =
                error (oce$multiple_ident_records, 'CPU Object Module', status);

              = llc$libraries =
                convert_library_directives (size, status);

              = llc$section_definition =
                convert_section_definition_item (status);

              = llc$text =
                convert_text_item (size, status);

              = llc$replication =
                convert_replication_item (size, status);

              = llc$bit_string_insertion =
                convert_bit_insertion_item (status);

              = llc$address_formulation =
                convert_addr_formulation_item (size, status);

              = llc$external_linkage =
                convert_external_linkage_item (size, status);

              = llc$entry_definition =
                convert_entry_point_definition (status);

              = llc$relocation =
                convert_relocation_item (size, status);

              = llc$actual_parameters =
                convert_actual_parameters (size, status);

              = llc$formal_parameters =
                convert_formal_parameters (size, generator_id, status);

              = llc$cybil_symbol_table_fragment =
                convert_cybil_symbol_table (size, status);

              = llc$symbol_table_fragment =
                convert_symbol_table_fragment (size, status);

              = llc$line_table_fragment =
                convert_line_table_fragment (size, status);

              = llc$binding_template =
                convert_binding_template (status);

              = llc$68000_absolute =
                convert_68000_absolute (size, status);

              = llc$transfer_symbol =
                convert_transfer_symbol_item (status);

              ELSE
                error (oce$invalid_cpu_record_kind, 'CPU Object Module', status);

              CASEND;

            ELSE
              error (status.condition, 'Object Text Descriptor 1.4', status);
            IFEND;

          UNTIL (type_of_obj_record = llc$transfer_symbol) OR (NOT status.normal);


        PROCEND convert_cpu_object_module;
?? TITLE := '                             CONVERT IDENTIFICATION BODY' ??
?? EJECT ??

        PROCEDURE convert_identification_body (ii_identification: ^llt$identification;
          VAR type_of_object_program: llt$module_kind;
          VAR generator_id: llt$module_generator;
          VAR status: ost$status);


          { 170 identification record }


          TYPE
            llt$ci_identification_body = record
              f00: array [1 .. 7] of byte,
              kind: llt$module_kind,

              time_created: ost$ci_time,

              date_created: ost$ci_date,

              attributes: llt$module_attributes,
              f01: array [1 .. 7] of byte,

              f02: array [1 .. 6] of byte,
              greatest_section_ordinal: llt$section_ordinal,

              f03: array [1 .. 7] of byte,
              generator_id: llt$module_generator,

              generator_name_vers: packed array [1 .. 128] of half_byte,

              commentary: packed array [1 .. 128] of half_byte,

            recend;


          CONST
            num_module_attr = 2;




          { 170 return date }


          TYPE
            ost$ci_date = record
              f01: array [1 .. 7] of byte,
              case date_format: ost$date_formats of
              = osc$month_date =
                month: packed array [1 .. 64] of half_byte,

              = osc$mdy_date =
                mdy: packed array [1 .. 64] of half_byte,

              = osc$iso_date =
                iso: packed array [1 .. 64] of half_byte,

              = osc$ordinal_date =
                ordinal: packed array [1 .. 64] of half_byte,

              casend,

            recend;




          { 170 return time }


          TYPE
            ost$ci_time = record
              f01: array [1 .. 7] of byte,
              case time_format: ost$time_formats of
              = osc$ampm_time =
                ampm: packed array [1 .. 48] of half_byte,

              = osc$hms_time =
                hms: packed array [1 .. 48] of half_byte,

              = osc$millisecond_time =
                millisecond: packed array [1 .. 48] of half_byte,

              casend,

            recend;

?? EJECT ??

          VAR
            ci_identification: ^llt$ci_identification_body;



          NEXT ci_identification IN ci_input_seg;

          IF ci_identification <> NIL THEN

            type_of_object_program := ci_identification^.kind;
            ii_identification^.kind := ci_identification^.kind;

            { convert time request return value }

            ii_identification^.time_created.time_format := ci_identification^.time_created.time_format;

            CASE ci_identification^.time_created.time_format OF
            = osc$ampm_time =
              convert_string (ci_identification^.time_created.ampm, 1, ii_identification^.time_created.ampm);

            = osc$hms_time =
              convert_string (ci_identification^.time_created.hms, 1, ii_identification^.time_created.hms);

            = osc$millisecond_time =
              convert_string (ci_identification^.time_created.millisecond, 1, ii_identification^.time_created.
                    millisecond);
            ELSE
              error (pme$invalid_time_format, 'Identification Record', status);

            CASEND;

            IF status.normal THEN

              { convert date request return value }

              ii_identification^.date_created.date_format := ci_identification^.date_created.date_format;

              CASE ci_identification^.date_created.date_format OF
              = osc$month_date =
                convert_string (ci_identification^.date_created.month, 1, ii_identification^.date_created.
                      month);

              = osc$mdy_date =
                convert_string (ci_identification^.date_created.mdy, 1, ii_identification^.date_created.mdy);

              = osc$iso_date =
                convert_string (ci_identification^.date_created.iso, 1, ii_identification^.date_created.iso);

              = osc$ordinal_date =
                convert_string (ci_identification^.date_created.ordinal, 1, ii_identification^.date_created.
                      ordinal);
              ELSE
                error (pme$invalid_date_format, 'Identification Record', status);

              CASEND;

              IF status.normal THEN

                { finish converting identification record }

                IF ii_identification^.kind <> llc$motorola_68000_absolute THEN
                  convert_set (#LOC (ci_identification^.attributes), num_module_attr, #LOC
                        (ii_identification^.attributes));
                ELSE
                  ii_identification^.attributes := $llt$module_attributes [llc$nonbindable];
                IFEND;

                ii_identification^.greatest_section_ordinal := ci_identification^.greatest_section_ordinal;

                ii_identification^.generator_id := ci_identification^.generator_id;
                generator_id := ci_identification^.generator_id;

                convert_string (ci_identification^.generator_name_vers, 1, ii_identification^.
                      generator_name_vers);

                convert_string (ci_identification^.commentary, 1, ii_identification^.commentary);

              IFEND;
            IFEND;
          ELSE
            error (oce$missing_rec_or_descriptor, 'Identification Record', status);
          IFEND;


        PROCEND convert_identification_body;
?? OLDTITLE ??
?? EJECT ??


        VAR
          kind_of_object_module {control} : llt$module_kind,
          module_generator: llt$module_generator;




        convert_identification_body (ii_identification, kind_of_object_module, module_generator, status);

        IF status.normal THEN
          CASE kind_of_object_module OF
          = llc$iou =
            convert_iou_object_module (status);

          = llc$mi_virtual_state, llc$vector_virtual_state, llc$motorola_68000, llc$motorola_68000_absolute,
              llc$vector_extended_state =
            convert_cpu_object_module (module_generator, status);

          ELSE
            error (oce$invalid_object_module_kind, 'Version 1.4 Text', status);
          CASEND;

        IFEND;

      PROCEND convert_version_14_text;
?? OLDTITLE ??
?? NEWTITLE := '                           CONVERT OBJECT TEXT DESCRIPTOR' ??
?? EJECT ??

      PROCEDURE convert_object_text_descriptor (VAR object_type: llt$extended_object_record_kind;
        VAR size: integer;
        VAR status: ost$status);





        TYPE
          llt$ci_object_text_descriptor = record
            f00: array [1 .. 7] of byte,
            case kind: llt$extended_object_record_kind of
            = llc$identification, llc$section_definition, llc$entry_definition, llc$binding_template,
              llc$transfer_symbol, llc$bit_string_insertion, llc$obsolte_line_table,
                llc$cybil_symbol_table_fragment, llc$reserved_4, occ$library_header, occ$module_directory,
                occ$entry_point_directory =
              unused: ost$segment_offset, {always 0}

            = llc$libraries =
              f02: array [1 .. 6] of byte,
              number_of_libraries: 1 .. llc$max_libraries,

            = llc$text, llc$replication =
              f03: array [1 .. 4] of byte,
              number_of_bytes: 1 .. osc$max_segment_length,

            = llc$relocation =
              f05: array [1 .. 6] of byte,
              number_of_rel_items: 1 .. llc$max_rel_items,

            = llc$address_formulation =
              f06: array [1 .. 6] of byte,
              number_of_adr_items: 1 .. llc$max_adr_items,

            = llc$external_linkage =
              f07: array [1 .. 6] of byte,
              number_of_ext_items: 1 .. llc$max_ext_items,

            = llc$formal_parameters, llc$actual_parameters =
              f08: array [1 .. 4] of byte,
              sequence_length: ost$segment_length,

            = llc$ppu_absolute =
              f09: array [1 .. 6] of byte,
              number_of_words: llt$ppu_address,
            casend,
          recend;




        VAR
          ci_text_descriptor: ^llt$ci_object_text_descriptor,
          ii_text_descriptor: ^llt$extended_object_text_desc;



        NEXT ci_text_descriptor IN ci_input_seg;

        IF ci_text_descriptor <> NIL THEN
          object_type := ci_text_descriptor^.kind;

          CASE ci_text_descriptor^.kind OF
          = llc$identification =
            NEXT ii_text_descriptor IN output_seq;
            ii_text_descriptor^.kind := ci_text_descriptor^.kind;

            ii_text_descriptor^.unused := ci_text_descriptor^.unused;

          ELSE
            RETURN;

          CASEND;

        ELSE
          eoi_warning (oce$missing_rec_or_descriptor, status);

        IFEND;


      PROCEND convert_object_text_descriptor;
?? OLDTITLE ??
?? EJECT ??

      TYPE
        llt$extended_object_text_desc = record
          case kind: llt$extended_object_record_kind of

          = llc$identification, llc$section_definition, llc$bit_string_insertion, llc$entry_definition,
            llc$binding_template, llc$transfer_symbol, llc$obsolte_line_table,
              llc$cybil_symbol_table_fragment, llc$reserved_4, occ$library_header, occ$module_directory,
              occ$entry_point_directory =
            unused: ost$segment_length, {must be zero}
          = llc$libraries =
            number_of_libraries: 1 .. llc$max_libraries,
          = llc$text, llc$replication =
            number_of_bytes: 1 .. osc$max_segment_length,
          = llc$relocation =
            number_of_rel_items: 1 .. llc$max_rel_items,
          = llc$address_formulation =
            number_of_adr_items: 1 .. llc$max_adr_items,
          = llc$external_linkage =
            number_of_ext_items: 1 .. llc$max_ext_items,
          = llc$formal_parameters, llc$actual_parameters =
            sequence_length: ost$segment_length, {REP sequence_length OF CELL}
          = llc$ppu_absolute =
            number_of_words: llt$ppu_address,
          = llc$allotted_section_definition =
            allotted_section: ost$relative_pointer,
          casend,
        recend;




      TYPE
        llt$extended_object_record_kind = (llc$identification, llc$libraries, llc$section_definition,
          llc$text, llc$replication, llc$bit_string_insertion, llc$entry_definition, llc$relocation,
          llc$address_formulation, llc$external_linkage, llc$formal_parameters, llc$actual_parameters,
          llc$binding_template, llc$ppu_absolute, llc$obsolte_line_table, llc$cybil_symbol_table_fragment,
          llc$allotted_section_definition, llc$reserved_4, llc$transfer_symbol, occ$library_header,
          occ$module_directory, occ$entry_point_directory);





      TYPE
        llt$ci_identification_header = record
          name: pmt$ci_program_name,

          object_text_version: packed array [1 .. 16] of half_byte,
        recend;




      TYPE
        llt$library_record = record
          name: pmt$ci_program_name,
          time_created: array [1 .. 4] of word,
          date_created: array [1 .. 5] of word,
          module_directory_index: integer,
          entry_point_directory_index: integer,
        recend;


      VAR
        ci_library_header: ^llt$library_record,
        ci_identification_header: ^llt$ci_identification_header,
        ii_identification: ^llt$identification,

        version: string (4),
        size: integer,
        type_of_object_record: llt$extended_object_record_kind;


      version := '%%%%';

      REPEAT
        convert_object_text_descriptor (type_of_object_record, size, status);

        IF status.normal THEN
          CASE type_of_object_record OF
          = llc$identification =
            NEXT ci_identification_header IN ci_input_seg;
            IF ci_identification_header <> NIL THEN
              NEXT ii_identification IN output_seq;

              convert_string (ci_identification_header^.name, 1, ii_identification^.name);
              convert_string (ci_identification_header^.object_text_version, 1, version);
              ii_identification^.object_text_version := 'V1.4';

              IF (version (1, 4) = '1.0 ') OR (version (1, 4) = 'V1.1') THEN
                convert_version_11_text (ii_identification, output_seq, status);

              ELSEIF version (1, 4) = 'V1.2' THEN
                convert_version_12_text (ii_identification, output_seq, status);
              ELSEIF version (1, 4) = 'V1.3' THEN
                convert_version_13_text (ii_identification, output_seq, status);

              ELSEIF version (1, 4) = 'V1.4' THEN
                convert_version_14_text (ii_identification, output_seq, status);
              ELSE
                error (oce$invalid_version, version, status);
              IFEND;
            ELSE
              error (oce$missing_rec_or_descriptor, 'Convert Object File', status);
            IFEND;

          = occ$library_header, llc$cybil_symbol_table_fragment =
            NEXT ci_library_header IN ci_input_seg;
            IF ci_library_header = NIL THEN
              error (oce$missing_rec_or_descriptor, 'Convert Object File', status);
            IFEND;

          = occ$module_directory, occ$entry_point_directory =
            RETURN;

          ELSE
            error (oce$ident_or_lib_desc_expected, 'Convert Object File', status);

          CASEND;
        IFEND;
      UNTIL NOT status.normal;

      IF (status_state = eoi_warning_status) THEN
        status.normal := TRUE;
      IFEND;


    PROCEND convert_object_file;
?? OLDTITLE ??
?? NEWTITLE := '                         Parameter Descriptors' ??
?? EJECT ??
{ pdt citoii_pdt (
{   ci : file = $required
{   ii : file = $required
{   status, st)

?? PUSH (LISTEXT := ON) ??

    VAR
      citoii_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^citoii_pdt_names,
        ^citoii_pdt_params];

    VAR
      citoii_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
        clt$parameter_name_descriptor := [['CI', 1], ['II', 2], ['STATUS', 3], ['ST', 3]];

    VAR
      citoii_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ CI }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ II }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS ST }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??


    CONST
      ci = 1,
      ii = 2;

?? OLDTITLE ??
?? EJECT ??

    VAR
      status_state: (eoi_warning_status, error_status),
      file: clt$value,
      ci_file_identifier: amt$file_identifier,
      ii_file_identifier: amt$file_identifier,

      ci_input_seg: ^SEQ ( * ),
      ii_output_seg: amt$segment_pointer;


    status.normal := TRUE;
    status_state := error_status;

    clp$scan_parameter_list (parameter_list, citoii_pdt, status);
    IF status.normal THEN
      clp$get_value ('CI', 1, 1, clc$low, file, status);
      IF status.normal THEN
        obtain_ci_file (file.file.local_file_name, ci_file_identifier, ci_input_seg, status);
        IF status.normal THEN
          clp$get_value ('II', 1, 1, clc$low, file, status);
          IF status.normal THEN
            obtain_ii_seg (file.file.local_file_name, ii_file_identifier, ii_output_seg, status);
            IF status.normal THEN
              IF ii_output_seg.sequence_pointer <> NIL THEN  {$NULL}
                convert_object_file (ii_output_seg.sequence_pointer, status);
                IF status.normal THEN
                  amp$close (ci_file_identifier, status);
                  IF status.normal THEN
                    amp$set_segment_eoi (ii_file_identifier, ii_output_seg, status);
                    IF status.normal THEN
                      amp$close (ii_file_identifier, status);
                    IFEND;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND citoii;




MODEND ocm$object_module_converter;
*DECK DECK=OCM$OBJECT_MODULE_SCANNERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
MODULE ocm$object_module_scanners;

{ PURPOSE:
{   This module contains the procs which scan thru object modules.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cyd$run_time_error_condition
*copyc cle$ecc_proc_declaration
*copyc llt$deferred_common_blocks
*copyc llt$deferred_entry_points
*copyc oce$library_generator_errors
*copyc oct$changed_info
*copyc oct$code_section_ids
*copyc oct$cpu_object_module_header
*copyc oct$display_toggles
*copyc oct$external_declaration_list
*copyc oct$external_reference_list
*copyc oct$header
*copyc oct$module_description
*copyc oct$name_list
*copyc oct$open_file_list
?? POP ??
*copyc clp$define_scl_procedure
*copyc i#current_sequence_position
*copyc ocp$convert_information_element
*copyc ocp$generate_message
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$establish_condition_handler
*copyc pmp$get_legible_date_time
*copyc pmp$position_object_library
*copyc ocv$olg_scratch_seq
*copyc ocv$olg_working_heap
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$build_scl_directory', EJECT ??

  PROCEDURE [XDCL] ocp$build_scl_directory
    (    file_name: amt$local_file_name;
         file_descriptor: ^oct$open_file_list;
     VAR status: ost$status);


    VAR
      scl_header: ^llt$library_member_header,
      alias_list: ^array [1 .. * ] of pmt$program_name,
      aliases: ^array [1 .. * ] of pmt$program_name,
      file_position: amt$file_position,
      procedure_name: pmt$program_name,
      command_or_function: clt$command_or_function,
      availability: clt$named_entry_availability,
      command_kind: llt$command_kind,
      command_log_option: clt$command_log_option,
      sequence: ^SEQ ( * ),
      scl_procedure: ^clt$scl_procedure,
      scl_proc: ^clt$scl_procedure,
      size: 0 .. 0ffffffff(16),

      count: integer,
      reset_value: ^SEQ ( * ),
      temp_seq: ^SEQ ( * ),
      work_area: ^SEQ ( * ),
      module_description: ^oct$module_description,
      directory: ^array [1 .. * ] of oct$module_description,
      local_status: ost$status,
      i: integer,
      j: integer;


    reset_value := ocv$olg_scratch_seq;
    file_position := amc$boi;
    count := 0;

  /loop/
    WHILE file_position <> amc$eoi DO
      temp_seq := ocv$olg_scratch_seq;
      NEXT work_area: [[REP (#SIZE (ocv$olg_scratch_seq^) -
            i#current_sequence_position (ocv$olg_scratch_seq)) OF cell]] IN temp_seq;
      clp$define_scl_procedure (file_descriptor^.identifier, work_area, procedure_name, alias_list,
            command_or_function, availability, command_kind, command_log_option, scl_procedure, file_position,
            status);
      IF NOT status.normal THEN
        IF status.condition = cle$expecting_proc THEN
          IF file_position = amc$eoi THEN
            status.normal := TRUE;
            EXIT /loop/;
          ELSEIF file_position = amc$eop THEN
            CYCLE /loop/;
          IFEND;
        IFEND;
        ocp$generate_message (status);
        osp$set_status_abnormal (oc, oce$e_invalid_scl_proc, file_name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, (count + 1), 10, FALSE, status);
        RETURN;
      IFEND;

      size := #SIZE (scl_procedure^) + #SIZE (llt$library_member_header);

      IF alias_list <> NIL THEN
        size := size + #SIZE (alias_list^);
      IFEND;

      ALLOCATE sequence: [[REP size OF cell]] IN ocv$olg_working_heap^;
      IF sequence = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      RESET sequence;
      NEXT scl_header IN sequence;

      scl_header^.name := procedure_name;

      CASE command_or_function OF
      = clc$command =
        scl_header^.kind := llc$command_procedure;
      = clc$function =
        scl_header^.kind := llc$function_procedure;
      CASEND;

      pmp$get_legible_date_time (osc$mdy_date, scl_header^.date_created, osc$hms_time,
            scl_header^.time_created, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      scl_header^.generator_id := llc$object_library_generator;
      scl_header^.generator_name_vers := occ$generator_name CAT llc$object_library_version;
      scl_header^.commentary := osc$null_name;


      IF alias_list <> NIL THEN
        NEXT aliases: [1 .. UPPERBOUND (alias_list^)] IN sequence;
        aliases^ := alias_list^;
        scl_header^.aliases := #REL (aliases, sequence^);
        scl_header^.number_of_aliases := UPPERBOUND (alias_list^);
      ELSE
        scl_header^.number_of_aliases := 0;
      IFEND;

      scl_header^.command_function_availability := availability;
      scl_header^.command_function_kind := command_kind;

      CASE command_or_function OF
      = clc$command =
        scl_header^.command_log_option := command_log_option;
      = clc$function =
        scl_header^.command_log_option := clc$manually_log;
      CASEND;

      NEXT scl_proc: [[REP #SIZE (scl_procedure^) OF cell]] IN sequence;
      scl_proc^ := scl_procedure^;
      scl_header^.member := #REL (scl_proc, sequence^);
      scl_header^.member_size := #SIZE (scl_proc^);

      count := count + 1;

      NEXT module_description IN ocv$olg_scratch_seq;
      IF module_description = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      module_description^.name := procedure_name;
      module_description^.source := occ$file;
      module_description^.file := sequence;

      CASE command_or_function OF
      = clc$command =
        module_description^.kind := occ$command_procedure;
        module_description^.command_procedure_header := scl_header;
      = clc$function =
        module_description^.kind := occ$function_procedure;
        module_description^.function_procedure_header := scl_header;
      CASEND;

    WHILEND /loop/;

    IF count = 0 THEN
      osp$set_status_abnormal (oc, oce$e_empty_object_file, file_descriptor^.name, status);
      RETURN;
    ELSE
      ocv$olg_scratch_seq := reset_value;
      NEXT directory: [1 .. count] IN ocv$olg_scratch_seq;

      FOR i := 1 TO (UPPERBOUND (directory^) - 1) DO
        IF (directory^ [i].name <> osc$null_name) THEN
          FOR j := (i + 1) TO UPPERBOUND (directory^) DO
            IF (directory^ [i].name = directory^ [j].name) THEN
              osp$set_status_abnormal (oc, oce$w_duplicate_module_on_file, directory^ [i].name, local_status);
              osp$append_status_parameter (osc$status_parameter_delimiter, file_descriptor^.name,
                    local_status);
              ocp$generate_message (local_status);

              directory^ [j].name := osc$null_name;
              count := count - 1;
            IFEND;
          FOREND;
        IFEND;
      FOREND;

      ALLOCATE file_descriptor^.directory: [1 .. count] IN ocv$olg_working_heap^;
      IF file_descriptor^.directory = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      ELSE
        j := 1;
        FOR i := 1 TO count DO
          WHILE (directory^ [j].name = osc$null_name) AND (j < UPPERBOUND (directory^)) DO
            j := j + 1;
          WHILEND;

          file_descriptor^.directory^ [i] := directory^ [j];
          j := j + 1;
        FOREND;
      IFEND;
    IFEND;


    file_descriptor^.current_module := 1;
    file_descriptor^.entry_point_dictionary := NIL;


  PROCEND ocp$build_scl_directory;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$build_library_directory' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$build_library_directory
    (VAR sequence: ^SEQ ( * );
     VAR file_descriptor: ^oct$open_file_list;
     VAR status: ost$status);


    VAR
      object_library_header: ^llt$object_library_header,
      object_library_hdr: ^llt$object_library_header_v1_0,
      library_dictionary: ^llt$object_library_dictionaries,

      module_dictionary: ^llt$module_dictionary,
      number_of_modules: 0 .. llc$max_modules_in_library,

      entry_point_dictionary: ^llt$entry_point_dictionary,
      number_of_entry_points: 0 .. llc$max_entry_points_in_library,

      load_module_header: ^llt$load_module_header,
      identification: ^llt$identification,
      library_member_header: ^llt$library_member_header,
      new_application_member_header: ^llt$application_member_header,
      old_application_member_header: ^llt$application_member_header,
      old_library_member_header: ^llt$library_member_header,
      new_library_member_header: ^llt$library_member_header,

      object_text_descriptor: ^llt$object_text_descriptor,
      obsolete_library_version: boolean,
      i: 1 .. llc$max_modules_in_library,
      j: 1 .. llc$max_commands_in_library;


    RESET sequence;

    NEXT object_library_header IN sequence;
    IF object_library_header = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
      RETURN;
    IFEND;

{ It is not possible for a current version of a library to have a module version
{ that is "obsolete."  Therefore, certain operations can be optimized when scanning
{ a current version library.

    obsolete_library_version := object_library_header^.version <> llc$object_library_version;
    IF NOT obsolete_library_version THEN

      NEXT library_dictionary: [1 .. object_library_header^.number_of_dictionaries] IN sequence;
      IF library_dictionary = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
        RETURN;
      IFEND;

      number_of_modules := 0;
      number_of_entry_points := 0;

      FOR j := LOWERBOUND (library_dictionary^) TO UPPERBOUND (library_dictionary^) DO
        CASE library_dictionary^ [j].kind OF
        = llc$module_dictionary =
          module_dictionary := #PTR (library_dictionary^ [j].module_dictionary, sequence^);
          number_of_modules := UPPERBOUND (module_dictionary^);
        = llc$entry_point_dictionary =
          entry_point_dictionary := #PTR (library_dictionary^ [j].entry_point_dictionary, sequence^);
          number_of_entry_points := UPPERBOUND (entry_point_dictionary^);
        ELSE
        CASEND;
      FOREND;

    ELSEIF object_library_header^.version = 'V1.0' THEN

      RESET sequence;

      NEXT object_library_hdr IN sequence;
      IF object_library_hdr = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
        RETURN;
      IFEND;

      number_of_modules := object_library_hdr^.number_of_modules;

      module_dictionary := #PTR (object_library_hdr^.module_dictionary, sequence^);
      IF module_dictionary = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
        RETURN;
      IFEND;

      number_of_entry_points := object_library_hdr^.number_of_entry_points;

      IF number_of_entry_points <> 0 THEN
        entry_point_dictionary := #PTR (object_library_hdr^.entry_point_dictionary, sequence^);
        IF entry_point_dictionary = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
          RETURN;
        IFEND;
      IFEND;

    ELSE
      osp$set_status_abnormal (oc, oce$e_invalid_library_version, object_library_header^.version, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, file_descriptor^.name, status);
      RETURN;
    IFEND;

    IF number_of_modules = 0 THEN
      osp$set_status_abnormal (oc, oce$e_no_modules_on_library, file_descriptor^.name, status);
      RETURN;
    IFEND;

    ALLOCATE file_descriptor^.directory: [1 .. number_of_modules] IN ocv$olg_working_heap^;
    IF file_descriptor^.directory = NIL THEN
      osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
      RETURN;
    IFEND;

    FOR i := 1 TO number_of_modules DO
      file_descriptor^.directory^ [i].name := module_dictionary^ [i].name;
      file_descriptor^.directory^ [i].source := occ$library;
      file_descriptor^.directory^ [i].file := sequence;

      CASE module_dictionary^ [i].kind OF
      = llc$load_module =
        file_descriptor^.directory^ [i].kind := occ$load_module;

        file_descriptor^.directory^ [i].load_module_header :=
              #PTR (module_dictionary^ [i].module_header, sequence^);
        IF file_descriptor^.directory^ [i].load_module_header = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
          RETURN;
        IFEND;

      = llc$ppu_object_module =
        file_descriptor^.directory^ [i].kind := occ$ppu_object_module;

        object_text_descriptor := #PTR (module_dictionary^ [i].ppu_header, sequence^);
        IF object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
          RETURN;
        IFEND;

        RESET sequence TO object_text_descriptor;
        NEXT object_text_descriptor IN sequence;
        NEXT file_descriptor^.directory^ [i].ppu_object_module_header IN sequence;
        IF file_descriptor^.directory^ [i].ppu_object_module_header = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
          RETURN;
        IFEND;

      = llc$program_description =
        file_descriptor^.directory^ [i].kind := occ$program_description;

        IF obsolete_library_version THEN
          old_library_member_header := #PTR (module_dictionary^ [i].program_header, sequence^);
          IF (old_library_member_header^.generator_name_vers = 'CREATE_OBJECT_LIBRARY  V1.0') OR
                (old_library_member_header^.generator_name_vers = 'OBJECT LIBRARY GENERATOR  V1.0') THEN

            ALLOCATE new_library_member_header IN ocv$olg_working_heap^;
            IF new_library_member_header = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;
            new_library_member_header^ := old_library_member_header^;
            new_library_member_header^.generator_name_vers := occ$generator_name CAT
                  llc$object_library_version;
            new_library_member_header^.command_function_availability := clc$advertised_entry;
            new_library_member_header^.command_function_kind := llc$entry_point;
            new_library_member_header^.command_log_option := clc$automatically_log;
            file_descriptor^.directory^ [i].program_description_header := new_library_member_header;
          IFEND;
        ELSE
          file_descriptor^.directory^ [i].program_description_header :=
                #PTR (module_dictionary^ [i].program_header, sequence^);
          IF file_descriptor^.directory^ [i].program_description_header = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
            RETURN;
          IFEND;
        IFEND;

      = llc$command_procedure =
        file_descriptor^.directory^ [i].kind := occ$command_procedure;

        IF obsolete_library_version THEN
          old_library_member_header := #PTR (module_dictionary^ [i].command_header, sequence^);
          IF (old_library_member_header^.generator_name_vers = 'CREATE_OBJECT_LIBRARY  V1.0') OR
                (old_library_member_header^.generator_name_vers = 'OBJECT LIBRARY GENERATOR  V1.0') THEN

            ALLOCATE new_library_member_header IN ocv$olg_working_heap^;
            IF new_library_member_header = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;
            new_library_member_header^ := old_library_member_header^;
            new_library_member_header^.generator_name_vers := occ$generator_name CAT
                  llc$object_library_version;
            new_library_member_header^.command_function_availability := clc$advertised_entry;
            new_library_member_header^.command_function_kind := llc$entry_point;
            new_library_member_header^.command_log_option := clc$automatically_log;
            file_descriptor^.directory^ [i].command_procedure_header := new_library_member_header;
          IFEND;
        ELSE
          file_descriptor^.directory^ [i].command_procedure_header :=
                #PTR (module_dictionary^ [i].command_header, sequence^);
          IF file_descriptor^.directory^ [i].command_procedure_header = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
            RETURN;
          IFEND;
        IFEND;

      = llc$command_description =
        file_descriptor^.directory^ [i].kind := occ$command_description;
        file_descriptor^.directory^ [i].command_description_header :=
              #PTR (module_dictionary^ [i].command_header, sequence^);
        IF file_descriptor^.directory^ [i].command_description_header = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
          RETURN;
        IFEND;

      = llc$applic_program_description =
        file_descriptor^.directory^ [i].kind := occ$applic_program_description;

        IF obsolete_library_version THEN
          old_application_member_header := #PTR (module_dictionary^ [i].applic_program_header, sequence^);
          IF (old_application_member_header^.library_member_header.generator_name_vers =
                'CREATE_OBJECT_LIBRARY  V1.0') OR (old_application_member_header^.library_member_header.
                generator_name_vers = 'OBJECT LIBRARY GENERATOR  V1.0') THEN

            ALLOCATE new_application_member_header IN ocv$olg_working_heap^;
            IF new_application_member_header = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;
            new_application_member_header^ := old_application_member_header^;
            new_application_member_header^.library_member_header.generator_name_vers := occ$generator_name CAT
                  llc$object_library_version;
            new_application_member_header^.library_member_header.command_function_availability :=
                  clc$advertised_entry;
            new_application_member_header^.library_member_header.command_function_kind := llc$entry_point;
            new_application_member_header^.library_member_header.command_log_option := clc$automatically_log;
            file_descriptor^.directory^ [i].applic_program_description_hdr := new_application_member_header;
          IFEND;
        ELSE
          file_descriptor^.directory^ [i].applic_program_description_hdr :=
                #PTR (module_dictionary^ [i].applic_program_header, sequence^);
          IF file_descriptor^.directory^ [i].applic_program_description_hdr = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
            RETURN;
          IFEND;
        IFEND;

      = llc$applic_command_procedure =
        file_descriptor^.directory^ [i].kind := occ$applic_command_procedure;

        IF obsolete_library_version THEN
          old_application_member_header := #PTR (module_dictionary^ [i].applic_command_header, sequence^);
          IF (old_application_member_header^.library_member_header.generator_name_vers =
                'CREATE_OBJECT_LIBRARY  V1.0') OR (old_application_member_header^.library_member_header.
                generator_name_vers = 'OBJECT LIBRARY GENERATOR  V1.0') THEN

            ALLOCATE new_application_member_header IN ocv$olg_working_heap^;
            IF new_application_member_header = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;
            new_application_member_header^ := old_application_member_header^;
            new_application_member_header^.library_member_header.generator_name_vers := occ$generator_name CAT
                  llc$object_library_version;
            new_application_member_header^.library_member_header.command_function_availability :=
                  clc$advertised_entry;
            new_application_member_header^.library_member_header.command_function_kind := llc$entry_point;
            new_application_member_header^.library_member_header.command_log_option := clc$automatically_log;
            file_descriptor^.directory^ [i].applic_command_procedure_header := new_application_member_header;
          IFEND;
        ELSE
          file_descriptor^.directory^ [i].applic_command_procedure_header :=
                #PTR (module_dictionary^ [i].applic_command_header, sequence^);
          IF file_descriptor^.directory^ [i].applic_command_procedure_header = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
            RETURN;
          IFEND;
        IFEND;

      = llc$applic_command_description =
        file_descriptor^.directory^ [i].kind := occ$applic_command_description;
        file_descriptor^.directory^ [i].applic_command_description_hdr :=
              #PTR (module_dictionary^ [i].applic_command_header, sequence^);
        IF file_descriptor^.directory^ [i].applic_command_description_hdr = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
          RETURN;
        IFEND;

      = llc$function_procedure =
        file_descriptor^.directory^ [i].kind := occ$function_procedure;
        file_descriptor^.directory^ [i].function_procedure_header :=
              #PTR (module_dictionary^ [i].function_header, sequence^);
        IF file_descriptor^.directory^ [i].function_procedure_header = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
          RETURN;
        IFEND;

      = llc$function_description =
        file_descriptor^.directory^ [i].kind := occ$function_description;
        file_descriptor^.directory^ [i].function_description_header :=
              #PTR (module_dictionary^ [i].function_header, sequence^);
        IF file_descriptor^.directory^ [i].function_description_header = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
          RETURN;
        IFEND;

      = llc$message_module =
        file_descriptor^.directory^ [i].kind := occ$message_module;

        file_descriptor^.directory^ [i].message_module_header :=
              #PTR (module_dictionary^ [i].message_header, sequence^);
        IF file_descriptor^.directory^ [i].message_module_header = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
          RETURN;
        IFEND;

      = llc$panel_module =
        file_descriptor^.directory^ [i].kind := occ$panel_module;

        file_descriptor^.directory^ [i].panel_module_header :=
              #PTR (module_dictionary^ [i].panel_header, sequence^);
        IF file_descriptor^.directory^ [i].panel_module_header = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
          RETURN;
        IFEND;

      ELSE
        osp$set_status_abnormal (oc, oce$e_invalid_module_kind, module_dictionary^ [i].name, status);
        RETURN;
      CASEND;
    FOREND;

    IF number_of_entry_points = 0 THEN
      file_descriptor^.entry_point_dictionary := NIL;
    ELSE
      file_descriptor^.entry_point_dictionary := entry_point_dictionary;
    IFEND;


  PROCEND ocp$build_library_directory;
?? OLDTITLE ??
?? NEWTITLE := 'scan_thru_cpu_module' ??
?? EJECT ??

  PROCEDURE scan_thru_cpu_module
    (    module_name: pmt$program_name;
     VAR cpu_object_module_header: ^oct$cpu_object_module_header;
     VAR sequence: ^SEQ ( * );
     VAR status: ost$status);

?? NEWTITLE := 'condition_handler', EJECT ??

    VAR
      error_conditions: [STATIC, READ] pmt$condition := [pmc$user_defined_condition, cye$run_time_condition];



    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);


      condition_status.normal := TRUE;


      osp$set_status_abnormal (oc, oce$e_bad_otd_size, module_name, status);
      EXIT scan_thru_cpu_module;


    PROCEND condition_handler;
?? OLDTITLE ??
?? EJECT ??

    VAR
      actual_parameters: ^llt$actual_parameters,
      address_formulation: ^llt$address_formulation,
      application_identifier: ^llt$application_identifier,
      binding_template: ^llt$binding_template,
      bit_string_insertion: ^llt$bit_string_insertion,
      debug_table_fragment: ^llt$debug_table_fragment,
      deferred_common_blocks: ^llt$deferred_common_blocks,
      deferred_entry_points: ^llt$deferred_entry_points,
      entry_definition: ^llt$entry_definition,
      established_descriptor: pmt$established_handler,
      external_linkage: ^llt$external_linkage,
      formal_parameters: ^llt$formal_parameters,
      libraries: ^llt$libraries,
      line_address_table: ^llt$line_address_table,
      m68000_absolute: ^llt$68000_absolute,
      object_text_descriptor: ^llt$object_text_descriptor,
      obsolete_formal_parameters: ^llt$obsolete_formal_parameters,
      obsolete_line_address_table: ^llt$obsolete_line_address_table,
      obsolete_segment_definition: ^llt$obsolete_segment_definition,
      record_number: integer,
      relocation: ^llt$relocation,
      replication: ^llt$replication,
      section_definition: ^llt$section_definition,
      segment_definition: ^llt$segment_definition,
      supplemental_debug_tables: ^llt$supplemental_debug_tables,
      symbol_table: ^llt$symbol_table,
      text: ^llt$text,
      transfer_symbol: ^llt$transfer_symbol;


    pmp$establish_condition_handler (error_conditions, ^condition_handler, ^established_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    record_number := 1;

    REPEAT
      NEXT object_text_descriptor IN sequence;

      IF object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
        RETURN;
      IFEND;
      record_number := record_number + 1;

      CASE object_text_descriptor^.kind OF

      = llc$identification =
        osp$set_status_abnormal (oc, oce$e_multiple_ident_rec, module_name, status);
        RETURN;

      = llc$application_identifier =
        NEXT application_identifier IN sequence;
        IF application_identifier = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

        cpu_object_module_header^.application_identifier := application_identifier;

      = llc$libraries =
        NEXT libraries: [1 .. object_text_descriptor^.number_of_libraries] IN sequence;
        IF libraries = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$section_definition, llc$unallocated_common_block =
        NEXT section_definition IN sequence;
        IF section_definition = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$segment_definition =
        NEXT segment_definition IN sequence;
        IF segment_definition = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$obsolete_segment_definition =
        NEXT obsolete_segment_definition IN sequence;
        IF obsolete_segment_definition = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$text =
        NEXT text: [1 .. object_text_descriptor^.number_of_bytes] IN sequence;
        IF text = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$replication =
        NEXT replication: [1 .. object_text_descriptor^.number_of_bytes] IN sequence;
        IF replication = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$bit_string_insertion =
        NEXT bit_string_insertion IN sequence;
        IF bit_string_insertion = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$entry_definition =
        NEXT entry_definition IN sequence;
        IF entry_definition = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$deferred_entry_points =
        NEXT deferred_entry_points: [1 .. object_text_descriptor^.number_of_entry_points] IN sequence;
        IF deferred_entry_points = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$deferred_common_blocks =
        NEXT deferred_common_blocks: [1 .. object_text_descriptor^.number_of_common_blocks] IN sequence;
        IF deferred_common_blocks = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$relocation =
        NEXT relocation: [1 .. object_text_descriptor^.number_of_rel_items] IN sequence;
        IF relocation = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$address_formulation =
        NEXT address_formulation: [1 .. object_text_descriptor^.number_of_adr_items] IN sequence;
        IF address_formulation = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$external_linkage =
        NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN sequence;
        IF external_linkage = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$obsolete_formal_parameters =
        NEXT obsolete_formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN sequence;
        IF obsolete_formal_parameters = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$formal_parameters =
        NEXT formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN sequence;
        IF formal_parameters = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$actual_parameters =
        NEXT actual_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN sequence;
        IF actual_parameters = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$cybil_symbol_table_fragment =
        NEXT debug_table_fragment: [[REP object_text_descriptor^.sequence_length OF cell]] IN sequence;
        IF debug_table_fragment = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$obsolete_line_table =
        NEXT obsolete_line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN sequence;
        IF obsolete_line_address_table = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$symbol_table =
        NEXT symbol_table: [[REP object_text_descriptor^.sequence_length OF cell]] IN sequence;
        IF symbol_table = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$line_table =
        NEXT line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN sequence;
        IF line_address_table = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$supplemental_debug_tables =
        NEXT supplemental_debug_tables: [[REP object_text_descriptor^.sequence_length OF cell]] IN sequence;
        IF supplemental_debug_tables = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$binding_template =
        NEXT binding_template IN sequence;
        IF binding_template = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$form_definition =
        osp$set_status_abnormal (oc, oce$e_form_def_found_in_module, module_name, status);
        RETURN;

      = llc$68000_absolute =
        NEXT m68000_absolute: [[REP object_text_descriptor^.number_of_68000_bytes OF cell]] IN sequence;
        IF m68000_absolute = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      = llc$transfer_symbol =
        NEXT transfer_symbol IN sequence;
        IF transfer_symbol = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
          RETURN;
        IFEND;

      ELSE
        osp$set_status_abnormal (oc, oce$e_invalid_object_rec_kind, module_name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, record_number, 10, FALSE, status);
        RETURN;

      CASEND;
    UNTIL object_text_descriptor^.kind = llc$transfer_symbol;


  PROCEND scan_thru_cpu_module;
?? OLDTITLE ??
?? NEWTITLE := 'scan_thru_ppu_module' ??
?? EJECT ??

  PROCEDURE scan_thru_ppu_module
    (    module_name: pmt$program_name;
     VAR sequence: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      object_text_descriptor: ^llt$object_text_descriptor,
      ppu_absolute: ^llt$ppu_absolute;


    NEXT object_text_descriptor IN sequence;
    IF object_text_descriptor = NIL THEN
      osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
      RETURN;
    IFEND;

    IF object_text_descriptor^.kind = llc$ppu_absolute THEN
      NEXT ppu_absolute: [0 .. object_text_descriptor^.number_of_words - 1] IN sequence;
      IF ppu_absolute = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_name, status);
        RETURN;
      IFEND;
    ELSE
      osp$set_status_abnormal (oc, oce$e_invalid_object_rec_kind, module_name, status);
      RETURN;
    IFEND;


  PROCEND scan_thru_ppu_module;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$build_file_directory', EJECT ??

  PROCEDURE [XDCL] ocp$build_file_directory
    (VAR sequence: ^SEQ ( * );
     VAR file_descriptor: ^oct$open_file_list;
     VAR status: ost$status);


    VAR
      directory: ^array [1 .. * ] of oct$module_description,
      i: 1 .. llc$max_modules_in_library,
      identification: ^llt$identification,
      j: 1 .. llc$max_modules_in_library + 1,
      local_status: ost$status,
      module_description: ^oct$module_description,
      number_of_modules: 0 .. llc$max_modules_in_library,
      object_text_descriptor: ^llt$object_text_descriptor,
      reset_value: ^SEQ ( * );

    reset_value := ocv$olg_scratch_seq;

    number_of_modules := 0;

    RESET sequence;
    NEXT object_text_descriptor IN sequence;

    WHILE object_text_descriptor <> NIL DO
      IF object_text_descriptor^.kind <> llc$identification THEN
        osp$set_status_abnormal (oc, oce$e_no_ident_rec_on_obj_file, file_descriptor^.name, status);
        RETURN;
      IFEND;

      IF number_of_modules >= llc$max_modules_in_library THEN
        osp$set_status_abnormal (oc, oce$e_too_many_modules_on_file, file_descriptor^.name, status);
        RETURN;
      IFEND;

      number_of_modules := number_of_modules + 1;

      NEXT identification IN sequence;
      IF identification = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
        RETURN;
      IFEND;

      IF (identification^.object_text_version <> 'V1.2') AND
            (identification^.object_text_version <> 'V1.3') AND
            (identification^.object_text_version <> 'V1.4') THEN
        osp$set_status_abnormal (oc, oce$e_invalid_obj_text_version, identification^.object_text_version,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, identification^.name, status);
        RETURN;
      IFEND;

      IF (identification^.name <> osc$null_name) THEN
        NEXT module_description IN ocv$olg_scratch_seq;
        IF module_description = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;

        module_description^.name := identification^.name;
        module_description^.source := occ$file;
        module_description^.file := sequence;

        CASE identification^.kind OF
        = llc$mi_virtual_state, llc$vector_virtual_state, llc$motorola_68000, llc$motorola_68000_absolute,
              llc$vector_extended_state =
          module_description^.kind := occ$cpu_object_module;

          ALLOCATE module_description^.cpu_object_module_header IN ocv$olg_working_heap^;
          module_description^.cpu_object_module_header^.identification := identification;
          module_description^.cpu_object_module_header^.application_identifier := NIL;

          scan_thru_cpu_module (module_description^.name, module_description^.cpu_object_module_header,
                sequence, status);

        = llc$iou =
          module_description^.kind := occ$ppu_object_module;
          module_description^.ppu_object_module_header := identification;

          scan_thru_ppu_module (module_description^.name, sequence, status);

        ELSE
          osp$set_status_abnormal (oc, oce$e_invalid_module_kind, identification^.name, status);
        CASEND;
      ELSE
        osp$set_status_abnormal (oc, oce$e_module_has_null_name, file_descriptor^.name, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      NEXT object_text_descriptor IN sequence;
    WHILEND;

    IF number_of_modules = 0 THEN
      osp$set_status_abnormal (oc, oce$e_empty_object_file, file_descriptor^.name, status);
      RETURN;
    ELSE
      ocv$olg_scratch_seq := reset_value;
      NEXT directory: [1 .. number_of_modules] IN ocv$olg_scratch_seq;

      FOR i := 1 TO (UPPERBOUND (directory^) - 1) DO
        IF (directory^ [i].name <> osc$null_name) THEN
          FOR j := (i + 1) TO UPPERBOUND (directory^) DO
            IF (directory^ [i].name = directory^ [j].name) THEN
              osp$set_status_abnormal (oc, oce$w_duplicate_module_on_file, directory^ [i].name, local_status);
              osp$append_status_parameter (osc$status_parameter_delimiter, file_descriptor^.name,
                    local_status);
              ocp$generate_message (local_status);

              directory^ [j].name := osc$null_name;
              number_of_modules := number_of_modules - 1;
            IFEND;
          FOREND;
        IFEND;
      FOREND;

      ALLOCATE file_descriptor^.directory: [1 .. number_of_modules] IN ocv$olg_working_heap^;
      IF file_descriptor^.directory = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      ELSE
        j := 1;
        FOR i := 1 TO number_of_modules DO
          WHILE (directory^ [j].name = osc$null_name) AND (j < UPPERBOUND (directory^)) DO
            j := j + 1;
          WHILEND;
          file_descriptor^.directory^ [i] := directory^ [j];
          j := j + 1;
        FOREND;
      IFEND;
    IFEND;

    file_descriptor^.entry_point_dictionary := NIL;

    ocv$olg_scratch_seq := reset_value;


  PROCEND ocp$build_file_directory;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$build_file_dir_from_temp', EJECT ??

{ PURPOSE:
{   The purpose of this request is to build a file directory from modules on
{   a scratch segment.
{ DESIGN:
{   Since EOI is not set at the end of the modules, "NEXT-ing" beyond this point
{   will not return NIL.  Upon entry to this procedure, the scratch segment is
{   positioned at the end of the last module.  This ending position is saved
{   and the sequence is reset and then read until the current sequence position
{   is beyond the ending position.
{ NOTES:
{   Since the file has already been generated successfully there is no need
{   to check for NIL pointers or bad status from procedure calls.

  PROCEDURE [XDCL] ocp$build_file_dir_from_temp
    (VAR sequence: ^SEQ ( * );
     VAR file_descriptor: ^oct$open_file_list);

    VAR
      directory: ^array [1 .. * ] of oct$module_description,
      end_of_file: integer,
      identification: ^llt$identification,
      ignore_status: ost$status,
      module_description: ^oct$module_description,
      number_of_modules: 0 .. llc$max_modules_in_library,
      object_text_descriptor: ^llt$object_text_descriptor,
      reset_value: ^SEQ ( * );


    end_of_file := i#current_sequence_position (sequence);
    reset_value := ocv$olg_scratch_seq;
    number_of_modules := 0;

    RESET sequence;
    NEXT object_text_descriptor IN sequence;

    WHILE i#current_sequence_position (sequence) <= end_of_file DO
      number_of_modules := number_of_modules + 1;
      NEXT identification IN sequence;

      NEXT module_description IN ocv$olg_scratch_seq;
      module_description^.name := identification^.name;
      module_description^.source := occ$file;
      module_description^.file := sequence;

      CASE identification^.kind OF
      = llc$mi_virtual_state, llc$vector_virtual_state, llc$motorola_68000, llc$motorola_68000_absolute,
            llc$vector_extended_state =
        module_description^.kind := occ$cpu_object_module;

        ALLOCATE module_description^.cpu_object_module_header IN ocv$olg_working_heap^;
        module_description^.cpu_object_module_header^.identification := identification;
        module_description^.cpu_object_module_header^.application_identifier := NIL;

        scan_thru_cpu_module (module_description^.name, module_description^.cpu_object_module_header,
              sequence, ignore_status);

      = llc$iou =
        module_description^.kind := occ$ppu_object_module;
        module_description^.ppu_object_module_header := identification;

        scan_thru_ppu_module (module_description^.name, sequence, ignore_status);

      ELSE
        ;
      CASEND;

      NEXT object_text_descriptor IN sequence;
    WHILEND;

    ocv$olg_scratch_seq := reset_value;
    NEXT directory: [1 .. number_of_modules] IN ocv$olg_scratch_seq;

    ALLOCATE file_descriptor^.directory: [1 .. number_of_modules] IN ocv$olg_working_heap^;
    file_descriptor^.directory^ := directory^;

    file_descriptor^.entry_point_dictionary := NIL;
    ocv$olg_scratch_seq := reset_value;
  PROCEND ocp$build_file_dir_from_temp;
?? NEWTITLE := '[XDCL] ocp$build_panel_directory' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$build_panel_directory
    (VAR sequence: ^SEQ ( * );
     VAR file_descriptor: ^oct$open_file_list;
     VAR status: ost$status);

    VAR
      directory: ^array [1 .. * ] of oct$module_description,
      file_form_module: ^SEQ ( * ),
      i: 1 .. llc$max_modules_in_library,
      identification: ^llt$identification,
      j: 1 .. llc$max_modules_in_library + 1,
      library_form_module: ^SEQ ( * ),
      library_member_header: ^llt$library_member_header,
      local_status: ost$status,
      member_sequence: ^SEQ ( * ),
      module_description: ^oct$module_description,
      number_of_modules: 0 .. llc$max_modules_in_library,
      object_text_descriptor: ^llt$object_text_descriptor,
      reset_value: ^SEQ ( * ),
      size: 0 .. 0ffffffff(16);

    reset_value := ocv$olg_scratch_seq;

    number_of_modules := 0;

    RESET sequence;
    NEXT object_text_descriptor IN sequence;

    WHILE object_text_descriptor <> NIL DO
      IF object_text_descriptor^.kind <> llc$identification THEN
        osp$set_status_abnormal (oc, oce$e_no_ident_rec_on_obj_file, file_descriptor^.name, status);
        RETURN;
      IFEND;

      IF number_of_modules >= llc$max_modules_in_library THEN
        osp$set_status_abnormal (oc, oce$e_too_many_modules_on_file, file_descriptor^.name, status);
        RETURN;
      IFEND;

      NEXT identification IN sequence;
      IF identification = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
        RETURN;
      IFEND;

      IF (identification^.object_text_version <> 'V1.2') AND
            (identification^.object_text_version <> 'V1.3') AND
            (identification^.object_text_version <> 'V1.4') THEN
        osp$set_status_abnormal (oc, oce$e_invalid_obj_text_version, identification^.object_text_version,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, identification^.name, status);
        RETURN;
      IFEND;

      NEXT object_text_descriptor IN sequence;
      IF object_text_descriptor^.kind <> llc$form_definition THEN
        osp$set_status_abnormal (oc, oce$e_invalid_object_rec_kind, identification^.name, status);
        RETURN;
      IFEND;

      size := #SIZE (llt$library_member_header) + object_text_descriptor^.sequence_length;
      ALLOCATE member_sequence: [[REP size OF cell]] IN ocv$olg_working_heap^;
      IF member_sequence = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      RESET member_sequence;
      NEXT library_member_header IN member_sequence;
      library_member_header^.name := identification^.name;
      library_member_header^.kind := llc$panel_module;
      library_member_header^.time_created := identification^.time_created;
      library_member_header^.date_created := identification^.date_created;
      library_member_header^.generator_id := identification^.generator_id;
      library_member_header^.generator_name_vers := identification^.generator_name_vers;
      library_member_header^.commentary := identification^.commentary;
      library_member_header^.member_size := object_text_descriptor^.sequence_length;

      NEXT file_form_module: [[REP object_text_descriptor^.sequence_length OF cell]] IN sequence;
      IF file_form_module = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, file_descriptor^.name, status);
        RETURN;
      IFEND;
      NEXT library_form_module: [[REP object_text_descriptor^.sequence_length OF cell]] IN member_sequence;
      library_member_header^.member := #REL (library_form_module, member_sequence^);
      library_form_module^ := file_form_module^;
      number_of_modules := number_of_modules + 1;
      NEXT module_description IN ocv$olg_scratch_seq;
      IF module_description = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      IFEND;

      module_description^.name := identification^.name;
      module_description^.source := occ$file;
      module_description^.file := member_sequence;
      module_description^.kind := occ$panel_module;
      module_description^.panel_module_header := library_member_header;
      NEXT object_text_descriptor IN sequence;
    WHILEND;

    IF number_of_modules = 0 THEN
      osp$set_status_abnormal (oc, oce$e_empty_object_file, file_descriptor^.name, status);
      RETURN;
    ELSE
      ocv$olg_scratch_seq := reset_value;
      NEXT directory: [1 .. number_of_modules] IN ocv$olg_scratch_seq;

      FOR i := 1 TO (UPPERBOUND (directory^) - 1) DO
        IF (directory^ [i].name <> osc$null_name) THEN
          FOR j := (i + 1) TO UPPERBOUND (directory^) DO
            IF (directory^ [i].name = directory^ [j].name) THEN
              osp$set_status_abnormal (oc, oce$w_duplicate_module_on_file, directory^ [i].name, local_status);
              osp$append_status_parameter (osc$status_parameter_delimiter, file_descriptor^.name,
                    local_status);
              ocp$generate_message (local_status);

              directory^ [j].name := osc$null_name;
              number_of_modules := number_of_modules - 1;
            IFEND;
          FOREND;
        IFEND;
      FOREND;

      ALLOCATE file_descriptor^.directory: [1 .. number_of_modules] IN ocv$olg_working_heap^;
      IF file_descriptor^.directory = NIL THEN
        osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
        RETURN;
      ELSE
        j := 1;
        FOR i := 1 TO number_of_modules DO
          WHILE (directory^ [j].name = osc$null_name) AND (j < UPPERBOUND (directory^)) DO
            j := j + 1;
          WHILEND;

          file_descriptor^.directory^ [i] := directory^ [j];
          j := j + 1;
        FOREND;
      IFEND;
    IFEND;

    file_descriptor^.entry_point_dictionary := NIL;

    ocv$olg_scratch_seq := reset_value;


  PROCEND ocp$build_panel_directory;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$obtain_header' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$obtain_header
    (VAR module_description: oct$module_description;
         changed_info: ^oct$changed_info;
     VAR header: oct$header;
     VAR status: ost$status);


    VAR
      object_text_descriptor: ^llt$object_text_descriptor,
      identification: ^llt$identification,
      application_identifier: ^llt$application_identifier;


    CASE module_description.kind OF
    = occ$cpu_object_module =
      header.identification := module_description.cpu_object_module_header^.identification^;
      IF module_description.cpu_object_module_header^.application_identifier <> NIL THEN
        header.application_identifier.name := module_description.cpu_object_module_header^.
              application_identifier^.name;
      ELSE
        header.application_identifier.name := osc$null_name;
      IFEND;

    = occ$ppu_object_module =
      header.identification := module_description.ppu_object_module_header^;

    = occ$program_description =
      IF (changed_info <> NIL) AND (changed_info^.application_identifier <> NIL) AND
            (changed_info^.application_identifier^.name <> osc$null_name) THEN
        header.application_member_header.library_member_header :=
              module_description.program_description_header^;
        header.application_member_header.library_member_header.kind := llc$applic_program_description;
      ELSE
        header.library_member_header := module_description.program_description_header^;
      IFEND;

    = occ$applic_program_description =
      IF (changed_info <> NIL) AND (changed_info^.application_identifier <> NIL) AND
            (changed_info^.application_identifier^.name = osc$null_name) THEN
        header.library_member_header := module_description.applic_program_description_hdr^.
              library_member_header;
        header.library_member_header.kind := llc$program_description;
      ELSE
        header.application_member_header := module_description.applic_program_description_hdr^;
      IFEND;

    = occ$command_procedure =
      IF (changed_info <> NIL) AND (changed_info^.application_identifier <> NIL) AND
            (changed_info^.application_identifier^.name <> osc$null_name) THEN
        header.application_member_header.library_member_header :=
              module_description.command_procedure_header^;
        header.application_member_header.library_member_header.kind := llc$applic_command_procedure;
      ELSE
        header.library_member_header := module_description.command_procedure_header^;
      IFEND;

    = occ$applic_command_procedure =
      IF (changed_info <> NIL) AND (changed_info^.application_identifier <> NIL) AND
            (changed_info^.application_identifier^.name = osc$null_name) THEN
        header.library_member_header := module_description.applic_command_procedure_header^.
              library_member_header;
        header.library_member_header.kind := llc$command_procedure;
      ELSE
        header.application_member_header := module_description.applic_command_procedure_header^;
      IFEND;

    = occ$command_description =
      IF (changed_info <> NIL) AND (changed_info^.application_identifier <> NIL) AND
            (changed_info^.application_identifier^.name <> osc$null_name) THEN
        header.application_member_header.library_member_header :=
              module_description.command_description_header^;
        header.application_member_header.library_member_header.kind := llc$applic_command_description;
      ELSE
        header.library_member_header := module_description.command_description_header^;
      IFEND;

    = occ$applic_command_description =
      IF (changed_info <> NIL) AND (changed_info^.application_identifier <> NIL) AND
            (changed_info^.application_identifier^.name = osc$null_name) THEN
        header.library_member_header := module_description.applic_command_description_hdr^.
              library_member_header;
        header.library_member_header.kind := llc$command_description;
      ELSE
        header.application_member_header := module_description.applic_command_description_hdr^;
      IFEND;

    = occ$function_procedure =
      header.library_member_header := module_description.function_procedure_header^;

    = occ$function_description =
      header.library_member_header := module_description.function_description_header^;

    = occ$message_module =
      header.library_member_header := module_description.message_module_header^;

    = occ$panel_module =
      header.library_member_header := module_description.panel_module_header^;

    = occ$bound_module =
      header.identification := module_description.bound_module_header^.identification;
      header.application_identifier.name := osc$null_name;

    = occ$load_module =
      object_text_descriptor := #PTR (module_description.load_module_header^.interpretive_element,
            module_description.file^);
      IF object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
        RETURN;
      IFEND;

      RESET module_description.file TO object_text_descriptor;
      NEXT object_text_descriptor IN module_description.file;

      NEXT identification IN module_description.file;
      IF identification = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
        RETURN;
      IFEND;
      header.identification := identification^;

      NEXT object_text_descriptor IN module_description.file;
      IF object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
        RETURN;
      IFEND;

      IF object_text_descriptor^.kind = llc$application_identifier THEN
        NEXT application_identifier IN module_description.file;
        IF application_identifier = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
          RETURN;
        IFEND;

        header.application_identifier.name := application_identifier^.name;
      ELSE
        header.application_identifier.name := osc$null_name;
      IFEND;

    CASEND;

    IF changed_info <> NIL THEN
      IF (changed_info^.application_identifier <> NIL) THEN
        CASE module_description.kind OF
        = occ$cpu_object_module, occ$ppu_object_module, occ$load_module, occ$bound_module =
          header.application_identifier.name := changed_info^.application_identifier^.name;

        = occ$program_description, occ$command_procedure, occ$command_description,
              occ$applic_program_description, occ$applic_command_procedure, occ$applic_command_description =
          IF (changed_info^.application_identifier^.name <> osc$null_name) THEN
            header.application_member_header.application_identifier.name :=
                  changed_info^.application_identifier^.name;
          IFEND;
        ELSE
          ;
        CASEND;
      IFEND;

      IF changed_info^.name <> NIL THEN
        CASE module_description.kind OF
        = occ$cpu_object_module, occ$ppu_object_module, occ$load_module, occ$bound_module =
          header.identification.name := changed_info^.name^;
        = occ$function_procedure, occ$function_description, occ$message_module, occ$panel_module =
          header.library_member_header.name := changed_info^.name^;
        = occ$program_description, occ$command_procedure, occ$command_description =
          IF (changed_info^.application_identifier <> NIL) AND
                (changed_info^.application_identifier^.name <> osc$null_name) THEN
            header.application_member_header.library_member_header.name := changed_info^.name^;
          ELSE
            header.library_member_header.name := changed_info^.name^;
          IFEND;
        = occ$applic_program_description, occ$applic_command_procedure, occ$applic_command_description =
          IF (changed_info^.application_identifier <> NIL) AND
                (changed_info^.application_identifier^.name = osc$null_name) THEN
            header.library_member_header.name := changed_info^.name^;
          ELSE
            header.application_member_header.library_member_header.name := changed_info^.name^;
          IFEND;
        CASEND;
      IFEND;

      IF changed_info^.commentary <> NIL THEN
        CASE module_description.kind OF
        = occ$cpu_object_module, occ$ppu_object_module, occ$load_module, occ$bound_module =
          header.identification.commentary := changed_info^.commentary^;
        = occ$function_procedure, occ$function_description, occ$message_module, occ$panel_module =
          header.library_member_header.commentary := changed_info^.commentary^;
        = occ$program_description, occ$command_procedure, occ$command_description =
          IF (changed_info^.application_identifier <> NIL) AND
                (changed_info^.application_identifier^.name <> osc$null_name) THEN
            header.application_member_header.library_member_header.commentary := changed_info^.commentary^;
          ELSE
            header.library_member_header.commentary := changed_info^.commentary^;
          IFEND;
        = occ$applic_program_description, occ$applic_command_procedure, occ$applic_command_description =
          IF (changed_info^.application_identifier <> NIL) AND
                (changed_info^.application_identifier^.name = osc$null_name) THEN
            header.library_member_header.commentary := changed_info^.commentary^;
          ELSE
            header.application_member_header.library_member_header.commentary := changed_info^.commentary^;
          IFEND;
        CASEND;
      IFEND;
    IFEND;


  PROCEND ocp$obtain_header;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$obtain_xdcl_list', EJECT ??

  PROCEDURE [XDCL] ocp$obtain_xdcl_list
    (    changed_info: ^oct$changed_info;
         retain: boolean;
         obtain_deferred_entry_points: boolean;
     VAR module_description: oct$module_description;
     VAR xdcl_list: oct$external_declaration_list;
     VAR starting_procedure: pmt$program_name;
     VAR deferred_entry_point_list: oct$external_declaration_list;
     VAR status: ost$status);

?? NEWTITLE := 'obtain_xdcls_from_object_module', EJECT ??

    PROCEDURE obtain_xdcls_from_object_module
      (    retain: boolean;
           obtain_deferred_entry_points: boolean;
       VAR module_description: oct$module_description;
       VAR xdcl_list: oct$external_declaration_list;
       VAR starting_procedure: pmt$program_name;
       VAR deferred_entry_point_list: oct$external_declaration_list;
       VAR status: ost$status);


      VAR
        last_deferred_entry_point: ^oct$external_declaration_list,
        last_xdcl: ^oct$external_declaration_list;

      VAR { object text record templates }
        object_text_descriptor: ^llt$object_text_descriptor,

        identification: ^llt$identification,
        application_identifier: ^llt$application_identifier,
        libraries: ^llt$libraries,
        section_definition: ^llt$section_definition,
        segment_definition: ^llt$segment_definition,
        obsolete_segment_definition: ^llt$obsolete_segment_definition,
        text: ^llt$text,
        replication: ^llt$replication,
        bit_string_insertion: ^llt$bit_string_insertion,
        relocation: ^llt$relocation,
        binding_template: ^llt$binding_template,
        entry_definition: ^llt$entry_definition,
        deferred_entry_index: 1 .. llc$max_deferred_entry_points,
        deferred_entry_points: ^llt$deferred_entry_points,
        deferred_common_blocks: ^llt$deferred_common_blocks,
        external_linkage: ^llt$external_linkage,
        address_formulation: ^llt$address_formulation,
        obsolete_formal_parameters: ^llt$obsolete_formal_parameters,
        formal_parameters: ^llt$formal_parameters,
        actual_parameters: ^llt$actual_parameters,
        debug_table_fragment: ^llt$debug_table_fragment,
        obsolete_line_address_table: ^llt$obsolete_line_address_table,
        symbol_table: ^llt$symbol_table,
        line_address_table: ^llt$line_address_table,
        supplemental_debug_tables: ^llt$supplemental_debug_tables,
        m68000_absolute: ^llt$68000_absolute,
        transfer_symbol: ^llt$transfer_symbol,
        module_name: pmt$program_name;

      last_deferred_entry_point := ^deferred_entry_point_list;
      last_xdcl := ^xdcl_list;

      RESET module_description.file TO module_description.cpu_object_module_header^.identification;
      NEXT identification IN module_description.file;

      REPEAT
        NEXT object_text_descriptor IN module_description.file;

        CASE object_text_descriptor^.kind OF
        = llc$entry_definition =
          NEXT entry_definition IN module_description.file;

          IF retain THEN
            ALLOCATE last_xdcl^.link IN ocv$olg_working_heap^;
          ELSE
            NEXT last_xdcl^.link IN ocv$olg_scratch_seq;
          IFEND;

          IF last_xdcl^.link = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;

          last_xdcl := last_xdcl^.link;
          last_xdcl^.name := entry_definition^.name;
          last_xdcl^.old_name := entry_definition^.name;
          last_xdcl^.attributes := entry_definition^.attributes;
          last_xdcl^.deferred := FALSE;

        = llc$deferred_entry_points =
          NEXT deferred_entry_points: [1 .. object_text_descriptor^.number_of_entry_points] IN
                module_description.file;

          IF obtain_deferred_entry_points THEN
            FOR deferred_entry_index := 1 TO object_text_descriptor^.number_of_entry_points DO
              IF retain THEN
                ALLOCATE last_deferred_entry_point^.link IN ocv$olg_working_heap^;
              ELSE
                NEXT last_deferred_entry_point^.link IN ocv$olg_scratch_seq;
              IFEND;

              IF last_deferred_entry_point^.link = NIL THEN
                osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
                RETURN;
              IFEND;

              last_deferred_entry_point := last_deferred_entry_point^.link;
              last_deferred_entry_point^.name := deferred_entry_points^ [deferred_entry_index].name;
              last_deferred_entry_point^.old_name := deferred_entry_points^ [deferred_entry_index].name;
              last_deferred_entry_point^.attributes := deferred_entry_points^ [deferred_entry_index].
                    attributes;
              last_deferred_entry_point^.deferred := TRUE;
            FOREND;
          IFEND;

        = llc$deferred_common_blocks =
          NEXT deferred_common_blocks: [1 .. object_text_descriptor^.number_of_common_blocks] IN
                module_description.file;

        = llc$transfer_symbol =
          NEXT transfer_symbol IN module_description.file;
          starting_procedure := transfer_symbol^.name;

        = llc$application_identifier =
          NEXT application_identifier IN module_description.file;

        = llc$libraries =
          NEXT libraries: [1 .. object_text_descriptor^.number_of_libraries] IN module_description.file;

        = llc$section_definition, llc$unallocated_common_block =
          NEXT section_definition IN module_description.file;

        = llc$segment_definition =
          NEXT segment_definition IN module_description.file;

        = llc$obsolete_segment_definition =
          NEXT obsolete_segment_definition IN module_description.file;

        = llc$text =
          NEXT text: [1 .. object_text_descriptor^.number_of_bytes] IN module_description.file;

        = llc$replication =
          NEXT replication: [1 .. object_text_descriptor^.number_of_bytes] IN module_description.file;

        = llc$bit_string_insertion =
          NEXT bit_string_insertion IN module_description.file;

        = llc$address_formulation =
          NEXT address_formulation: [1 .. object_text_descriptor^.number_of_adr_items] IN
                module_description.file;

        = llc$external_linkage =
          NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN
                module_description.file;

        = llc$relocation =
          NEXT relocation: [1 .. object_text_descriptor^.number_of_rel_items] IN module_description.file;

        = llc$actual_parameters =
          NEXT actual_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$cybil_symbol_table_fragment =
          NEXT debug_table_fragment: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$obsolete_line_table =
          NEXT obsolete_line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN
                module_description.file;

        = llc$symbol_table =
          NEXT symbol_table: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$line_table =
          NEXT line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN
                module_description.file;

        = llc$supplemental_debug_tables =
          NEXT supplemental_debug_tables: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$obsolete_formal_parameters =
          NEXT obsolete_formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$formal_parameters =
          NEXT formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$binding_template =
          NEXT binding_template IN module_description.file;

        = llc$form_definition =
          osp$set_status_abnormal (oc, oce$e_form_def_found_in_module, module_name, status);
          RETURN;

        = llc$68000_absolute =
          NEXT m68000_absolute: [[REP object_text_descriptor^.number_of_68000_bytes OF cell]] IN
                module_description.file;

        CASEND;
      UNTIL object_text_descriptor^.kind = llc$transfer_symbol;

      last_deferred_entry_point^.link := NIL;
      last_xdcl^.link := NIL;


    PROCEND obtain_xdcls_from_object_module;
?? OLDTITLE ??
?? NEWTITLE := 'obtain_xdcls_from_load_module', EJECT ??

    PROCEDURE obtain_xdcls_from_load_module
      (    retain: boolean;
           obtain_deferred_entry_points: boolean;
       VAR module_descritpion: oct$module_description;
       VAR xdcl_list: oct$external_declaration_list;
       VAR starting_procedure: pmt$program_name;
       VAR deferred_entry_point_list: oct$external_declaration_list;
       VAR status: ost$status);


      VAR
        deferred_entry_index: 1 .. llc$max_deferred_entry_points,
        deferred_entry_points: ^llt$deferred_entry_points,
        entry_definition: ^llt$entry_definition,
        last_deferred_entry_point: ^oct$external_declaration_list,
        last_xdcl: ^oct$external_declaration_list,
        object_text_descriptor: ^llt$object_text_descriptor,
        transfer_symbol: ^llt$transfer_symbol;


      last_deferred_entry_point := ^deferred_entry_point_list;
      last_xdcl := ^xdcl_list;

      IF llc$entry_point_element IN module_description.load_module_header^.interpretive_header.
            elements_defined THEN
        object_text_descriptor := #PTR (module_description.load_module_header^.interpretive_header.
              entry_points, module_description.file^);
        IF object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
          RETURN;
        IFEND;

        RESET module_description.file TO object_text_descriptor;
        NEXT object_text_descriptor IN module_description.file;

        WHILE object_text_descriptor^.kind = llc$entry_definition DO
          NEXT entry_definition IN module_description.file;
          IF entry_definition = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
            RETURN;
          IFEND;

          IF retain THEN
            ALLOCATE last_xdcl^.link IN ocv$olg_working_heap^;
          ELSE
            NEXT last_xdcl^.link IN ocv$olg_scratch_seq;
          IFEND;

          IF last_xdcl^.link = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;

          last_xdcl := last_xdcl^.link;
          last_xdcl^.name := entry_definition^.name;
          last_xdcl^.old_name := entry_definition^.name;
          last_xdcl^.attributes := entry_definition^.attributes;
          last_xdcl^.deferred := FALSE;

          NEXT object_text_descriptor IN module_description.file;
          IF object_text_descriptor = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
            RETURN;
          IFEND;
        WHILEND;

        IF obtain_deferred_entry_points AND (object_text_descriptor^.kind = llc$deferred_entry_points) THEN
          NEXT deferred_entry_points: [1 .. object_text_descriptor^.number_of_entry_points] IN
                module_description.file;
          IF deferred_entry_points = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
            RETURN;
          IFEND;

          FOR deferred_entry_index := 1 TO object_text_descriptor^.number_of_entry_points DO
            IF retain THEN
              ALLOCATE last_deferred_entry_point^.link IN ocv$olg_working_heap^;
            ELSE
              NEXT last_deferred_entry_point^.link IN ocv$olg_scratch_seq;
            IFEND;

            IF last_deferred_entry_point^.link = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;

            last_deferred_entry_point := last_deferred_entry_point^.link;
            last_deferred_entry_point^.name := deferred_entry_points^ [deferred_entry_index].name;
            last_deferred_entry_point^.old_name := deferred_entry_points^ [deferred_entry_index].name;
            last_deferred_entry_point^.attributes := deferred_entry_points^ [deferred_entry_index].attributes;
            last_deferred_entry_point^.deferred := TRUE;
          FOREND;
        IFEND;
      IFEND;

      last_deferred_entry_point^.link := NIL;
      last_xdcl^.link := NIL;

      IF llc$transfer_symbol_element IN module_description.load_module_header^.interpretive_header.
            elements_defined THEN
        object_text_descriptor := #PTR (module_description.load_module_header^.interpretive_header.
              transfer_symbol, module_description.file^);
        IF object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
          RETURN;
        IFEND;

        RESET module_description.file TO object_text_descriptor;
        NEXT object_text_descriptor IN module_description.file;

        NEXT transfer_symbol IN module_description.file;
        IF transfer_symbol = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
          RETURN;
        IFEND;

        starting_procedure := transfer_symbol^.name;
      ELSE
        starting_procedure := osc$null_name;
      IFEND;

    PROCEND obtain_xdcls_from_load_module;
?? OLDTITLE ??
?? NEWTITLE := 'obtain_aliases_from_scl_proc', EJECT ??

    PROCEDURE obtain_aliases_from_scl_proc
      (VAR module_description: oct$module_description;
       VAR alias_list: oct$external_declaration_list;
           retain: boolean;
       VAR status: ost$status);


      VAR
        command_procedure_header: ^llt$library_member_header,
        function_procedure_header: ^llt$library_member_header,
        last_alias: ^oct$external_declaration_list,
        aliases: ^array [1 .. * ] of pmt$program_name,
        number_of_aliases: llt$number_of_aliases,
        i: llt$number_of_aliases;

      CASE module_description.kind OF

      = occ$command_procedure =
        IF module_description.command_procedure_header^.number_of_aliases = 0 THEN
          alias_list.link := NIL;
          number_of_aliases := 0;
        ELSE
          aliases := #PTR (module_description.command_procedure_header^.aliases, module_description.file^);
          IF aliases = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
            RETURN;
          IFEND;
          number_of_aliases := module_description.command_procedure_header^.number_of_aliases;
        IFEND;

      = occ$function_procedure =
        IF module_description.function_procedure_header^.number_of_aliases = 0 THEN
          alias_list.link := NIL;
          number_of_aliases := 0;
        ELSE
          aliases := #PTR (module_description.function_procedure_header^.aliases, module_description.file^);
          IF aliases = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
            RETURN;
          IFEND;
          number_of_aliases := module_description.function_procedure_header^.number_of_aliases;
        IFEND;

      = occ$applic_command_procedure =
        IF module_description.applic_command_procedure_header^.library_member_header.number_of_aliases =
              0 THEN
          alias_list.link := NIL;
          number_of_aliases := 0;
        ELSE
          aliases := #PTR (module_description.applic_command_procedure_header^.library_member_header.aliases,
                module_description.file^);
          IF aliases = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
            RETURN;
          IFEND;
          number_of_aliases := module_description.applic_command_procedure_header^.library_member_header.
                number_of_aliases;
        IFEND;

      CASEND;

      IF number_of_aliases <> 0 THEN
        last_alias := ^alias_list;
        FOR i := 1 TO number_of_aliases DO
          IF retain THEN
            ALLOCATE last_alias^.link IN ocv$olg_working_heap^;
          ELSE
            NEXT last_alias^.link IN ocv$olg_scratch_seq;
          IFEND;

          IF last_alias^.link = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;

          last_alias := last_alias^.link;
          last_alias^.name := aliases^ [i];
          last_alias^.attributes := $llt$entry_point_attributes [];
        FOREND;

        last_alias^.link := NIL;
      IFEND;

    PROCEND obtain_aliases_from_scl_proc;
?? OLDTITLE ??
?? NEWTITLE := 'obtain_aliases_from_prog_desc', EJECT ??

    PROCEDURE obtain_aliases_from_prog_desc
      (VAR module_description: oct$module_description;
       VAR alias_list: oct$external_declaration_list;
           retain: boolean;
       VAR status: ost$status);


      VAR
        program_description_header: ^llt$library_member_header,
        last_alias: ^oct$external_declaration_list,
        aliases: ^array [1 .. * ] of pmt$program_name,
        i: llt$number_of_aliases;


      IF module_description.program_description_header^.number_of_aliases = 0 THEN
        alias_list.link := NIL;

      ELSE
        aliases := #PTR (module_description.program_description_header^.aliases, module_description.file^);
        IF aliases = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
          RETURN;
        IFEND;

        last_alias := ^alias_list;
        FOR i := 1 TO module_description.program_description_header^.number_of_aliases DO
          IF retain THEN
            ALLOCATE last_alias^.link IN ocv$olg_working_heap^;
          ELSE
            NEXT last_alias^.link IN ocv$olg_scratch_seq;
          IFEND;

          IF last_alias^.link = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;

          last_alias := last_alias^.link;
          last_alias^.name := aliases^ [i];
          last_alias^.attributes := $llt$entry_point_attributes [];
        FOREND;

        last_alias^.link := NIL;
      IFEND;

    PROCEND obtain_aliases_from_prog_desc;
?? OLDTITLE ??
?? NEWTITLE := 'obtain_aliases_from_applic_prog', EJECT ??

    PROCEDURE obtain_aliases_from_applic_prog
      (VAR module_description: oct$module_description;
       VAR alias_list: oct$external_declaration_list;
           retain: boolean;
       VAR status: ost$status);


      VAR
        aliases: ^array [1 .. * ] of pmt$program_name,
        i: llt$number_of_aliases,
        last_alias: ^oct$external_declaration_list,
        program_description_header: ^llt$library_member_header;


      IF module_description.applic_program_description_hdr^.library_member_header.number_of_aliases = 0 THEN
        alias_list.link := NIL;

      ELSE
        aliases := #PTR (module_description.applic_program_description_hdr^.library_member_header.aliases,
              module_description.file^);
        IF aliases = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
          RETURN;
        IFEND;

        last_alias := ^alias_list;
        FOR i := 1 TO module_description.applic_program_description_hdr^.library_member_header.
              number_of_aliases DO
          IF retain THEN
            ALLOCATE last_alias^.link IN ocv$olg_working_heap^;
          ELSE
            NEXT last_alias^.link IN ocv$olg_scratch_seq;
          IFEND;

          IF last_alias^.link = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;

          last_alias := last_alias^.link;
          last_alias^.name := aliases^ [i];
          last_alias^.attributes := $llt$entry_point_attributes [];
        FOREND;

        last_alias^.link := NIL;
      IFEND;


    PROCEND obtain_aliases_from_applic_prog;
?? OLDTITLE ??
?? NEWTITLE := 'obtain_aliases_from_cmnd_desc' ??
?? EJECT ??

    PROCEDURE obtain_aliases_from_cmnd_desc
      (VAR module_description: oct$module_description;
       VAR alias_list: oct$external_declaration_list;
           retain: boolean;
       VAR status: ost$status);


      VAR
        command_description_header: ^llt$library_member_header,
        last_alias: ^oct$external_declaration_list,
        aliases: ^array [1 .. * ] of pmt$program_name,
        i: llt$number_of_aliases;


      IF module_description.command_description_header^.number_of_aliases = 0 THEN
        alias_list.link := NIL;

      ELSE
        aliases := #PTR (module_description.command_description_header^.aliases, module_description.file^);
        IF aliases = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
          RETURN;
        IFEND;

        last_alias := ^alias_list;
        FOR i := 1 TO module_description.command_description_header^.number_of_aliases DO
          IF retain THEN
            ALLOCATE last_alias^.link IN ocv$olg_working_heap^;
          ELSE
            NEXT last_alias^.link IN ocv$olg_scratch_seq;
          IFEND;

          IF last_alias^.link = NIL THEN
            osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
            RETURN;
          IFEND;

          last_alias := last_alias^.link;
          last_alias^.name := aliases^ [i];
          last_alias^.attributes := $llt$entry_point_attributes [];
        FOREND;

        last_alias^.link := NIL;
      IFEND;


    PROCEND obtain_aliases_from_cmnd_desc;
?? OLDTITLE ??
?? NEWTITLE := 'obtain_aliases_from_applic_cmnd' ??
?? EJECT ??

    PROCEDURE obtain_aliases_from_applic_cmnd
      (VAR module_description: oct$module_description;
       VAR alias_list: oct$external_declaration_list;
           retain: boolean;
       VAR status: ost$status);


      VAR
        aliases: ^array [1 .. * ] of pmt$program_name,
        i: llt$number_of_aliases,
        last_alias: ^oct$external_declaration_list,
        command_description_header: ^llt$library_member_header;


      IF module_description.applic_command_description_hdr^.library_member_header.number_of_aliases = 0 THEN
        alias_list.link := NIL;

      ELSE
        aliases := #PTR (module_description.applic_command_description_hdr^.library_member_header.aliases,
              module_description.file^);
        IF aliases = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
          RETURN;
        IFEND;

        last_alias := ^alias_list;
        FOR i := 1 TO module_description.applic_command_description_hdr^.library_member_header.
              number_of_aliases DO
          IF retain THEN
            ALLOCATE last_alias^.link IN ocv$olg_working_heap^;
          ELSE
            NEXT last_alias^.link IN ocv$olg_scratch_seq;
          IFEND;

          IF last_alias^.link = NIL THEN
            osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
            RETURN;
          IFEND;

          last_alias := last_alias^.link;
          last_alias^.name := aliases^ [i];
          last_alias^.attributes := $llt$entry_point_attributes [];
        FOREND;

        last_alias^.link := NIL;
      IFEND;


    PROCEND obtain_aliases_from_applic_cmnd;
?? OLDTITLE ??
?? NEWTITLE := 'obtain_aliases_from_func_desc' ??
?? EJECT ??

    PROCEDURE obtain_aliases_from_func_desc
      (VAR module_description: oct$module_description;
       VAR alias_list: oct$external_declaration_list;
           retain: boolean;
       VAR status: ost$status);


      VAR
        function_description_header: ^llt$library_member_header,
        last_alias: ^oct$external_declaration_list,
        aliases: ^array [1 .. * ] of pmt$program_name,
        i: llt$number_of_aliases;


      IF module_description.function_description_header^.number_of_aliases = 0 THEN
        alias_list.link := NIL;

      ELSE
        aliases := #PTR (module_description.function_description_header^.aliases, module_description.file^);
        IF aliases = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
          RETURN;
        IFEND;

        last_alias := ^alias_list;
        FOR i := 1 TO module_description.function_description_header^.number_of_aliases DO
          IF retain THEN
            ALLOCATE last_alias^.link IN ocv$olg_working_heap^;
          ELSE
            NEXT last_alias^.link IN ocv$olg_scratch_seq;
          IFEND;

          IF last_alias^.link = NIL THEN
            osp$set_status_abnormal (oc, oce$e_internal_olg_seg_overflow, '', status);
            RETURN;
          IFEND;

          last_alias := last_alias^.link;
          last_alias^.name := aliases^ [i];
          last_alias^.attributes := $llt$entry_point_attributes [];
        FOREND;

        last_alias^.link := NIL;
      IFEND;


    PROCEND obtain_aliases_from_func_desc;
?? OLDTITLE ??
?? EJECT ??

    VAR
      ignore_starting_procedure: pmt$program_name,
      ignore_xdcl_list: oct$external_declaration_list;


    IF (changed_info <> NIL) AND (changed_info^.entry_points <> NIL) THEN
      xdcl_list.link := changed_info^.entry_points;
      starting_procedure := changed_info^.starting_procedure;
      IF obtain_deferred_entry_points THEN
        CASE module_description.kind OF
        = occ$cpu_object_module =
          obtain_xdcls_from_object_module (retain, obtain_deferred_entry_points, module_description,
                ignore_xdcl_list, ignore_starting_procedure, deferred_entry_point_list, status);

        = occ$load_module =
          obtain_xdcls_from_load_module (retain, obtain_deferred_entry_points, module_description,
                ignore_xdcl_list, ignore_starting_procedure, deferred_entry_point_list, status);

        ELSE
          deferred_entry_point_list.link := NIL;
        CASEND
      ELSE
        deferred_entry_point_list.link := NIL;
      IFEND;
    ELSE
      CASE module_description.kind OF
      = occ$cpu_object_module =
        obtain_xdcls_from_object_module (retain, obtain_deferred_entry_points, module_description, xdcl_list,
              starting_procedure, deferred_entry_point_list, status);

      = occ$load_module =
        obtain_xdcls_from_load_module (retain, obtain_deferred_entry_points, module_description, xdcl_list,
              starting_procedure, deferred_entry_point_list, status);

      = occ$bound_module =
        xdcl_list.link := NIL;

      = occ$ppu_object_module =
        xdcl_list.link := NIL;
        starting_procedure := osc$null_name;

      = occ$command_procedure, occ$function_procedure, occ$applic_command_procedure =
        obtain_aliases_from_scl_proc (module_description, xdcl_list, retain, status);

      = occ$program_description =
        obtain_aliases_from_prog_desc (module_description, xdcl_list, retain, status);

      = occ$applic_program_description =
        obtain_aliases_from_applic_prog (module_description, xdcl_list, retain, status);

      = occ$command_description =
        obtain_aliases_from_cmnd_desc (module_description, xdcl_list, retain, status);

      = occ$applic_command_description =
        obtain_aliases_from_applic_cmnd (module_description, xdcl_list, retain, status);

      = occ$function_description =
        obtain_aliases_from_func_desc (module_description, xdcl_list, retain, status);

      = occ$message_module, occ$panel_module =
        xdcl_list.link := NIL;
        starting_procedure := osc$null_name;

      CASEND;
    IFEND;

    CASE module_description.kind OF
    = occ$command_procedure, occ$function_procedure, occ$program_description, occ$command_description,
          occ$function_description =
      starting_procedure := osc$null_name;
    ELSE
    CASEND;


  PROCEND ocp$obtain_xdcl_list;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$obtain_xref_list' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$obtain_xref_list
    (VAR module_description: oct$module_description;
     VAR xref_list: oct$external_reference_list;
         retain: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'obtain_xrefs_from_object_module' ??
?? EJECT ??

    PROCEDURE obtain_xrefs_from_object_module
      (VAR module_descritpion: oct$module_description;
       VAR xref_list: oct$external_reference_list;
           retain: boolean;
       VAR status: ost$status);


      VAR
        last_xref: ^oct$external_reference_list;

      VAR { object text record templates }
        object_text_descriptor: ^llt$object_text_descriptor,

        identification: ^llt$identification,
        application_identifier: ^llt$application_identifier,
        libraries: ^llt$libraries,
        section_definition: ^llt$section_definition,
        segment_definition: ^llt$segment_definition,
        obsolete_segment_definition: ^llt$obsolete_segment_definition,
        text: ^llt$text,
        replication: ^llt$replication,
        bit_string_insertion: ^llt$bit_string_insertion,
        relocation: ^llt$relocation,
        binding_template: ^llt$binding_template,
        entry_definition: ^llt$entry_definition,
        deferred_entry_points: ^llt$deferred_entry_points,
        deferred_common_blocks: ^llt$deferred_common_blocks,
        external_linkage: ^llt$external_linkage,
        address_formulation: ^llt$address_formulation,
        obsolete_formal_parameters: ^llt$obsolete_formal_parameters,
        formal_parameters: ^llt$formal_parameters,
        actual_parameters: ^llt$actual_parameters,
        debug_table_fragment: ^llt$debug_table_fragment,
        obsolete_line_address_table: ^llt$obsolete_line_address_table,
        symbol_table: ^llt$symbol_table,
        line_address_table: ^llt$line_address_table,
        supplemental_debug_tables: ^llt$supplemental_debug_tables,
        m68000_absolute: ^llt$68000_absolute,
        transfer_symbol: ^llt$transfer_symbol,
        module_name: pmt$program_name;

      status.normal := TRUE;
      last_xref := ^xref_list;

      RESET module_description.file TO module_description.cpu_object_module_header^.identification;
      NEXT identification IN module_description.file;

      REPEAT
        NEXT object_text_descriptor IN module_description.file;
        IF object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
          RETURN;
        IFEND;

        CASE object_text_descriptor^.kind OF
        = llc$external_linkage =
          NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN
                module_description.file;
          IF external_linkage = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
            RETURN;
          IFEND;

          IF retain THEN
            ALLOCATE last_xref^.link IN ocv$olg_working_heap^;
          ELSE
            NEXT last_xref^.link IN ocv$olg_scratch_seq;
          IFEND;

          IF last_xref^.link = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;

          last_xref := last_xref^.link;
          last_xref^.name := external_linkage^.name;

        = llc$application_identifier =
          NEXT application_identifier IN module_description.file;

        = llc$libraries =
          NEXT libraries: [1 .. object_text_descriptor^.number_of_libraries] IN module_description.file;

        = llc$section_definition, llc$unallocated_common_block =
          NEXT section_definition IN module_description.file;

        = llc$segment_definition =
          NEXT segment_definition IN module_description.file;

        = llc$obsolete_segment_definition =
          NEXT obsolete_segment_definition IN module_description.file;

        = llc$text =
          NEXT text: [1 .. object_text_descriptor^.number_of_bytes] IN module_description.file;

        = llc$replication =
          NEXT replication: [1 .. object_text_descriptor^.number_of_bytes] IN module_description.file;

        = llc$bit_string_insertion =
          NEXT bit_string_insertion IN module_description.file;

        = llc$address_formulation =
          NEXT address_formulation: [1 .. object_text_descriptor^.number_of_adr_items] IN
                module_description.file;

        = llc$entry_definition =
          NEXT entry_definition IN module_description.file;

        = llc$deferred_entry_points =
          NEXT deferred_entry_points: [1 .. object_text_descriptor^.number_of_entry_points] IN
                module_description.file;

        = llc$deferred_common_blocks =
          NEXT deferred_common_blocks: [1 .. object_text_descriptor^.number_of_common_blocks] IN
                module_description.file;

        = llc$relocation =
          NEXT relocation: [1 .. object_text_descriptor^.number_of_rel_items] IN module_description.file;

        = llc$actual_parameters =
          NEXT actual_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$cybil_symbol_table_fragment =
          NEXT debug_table_fragment: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$obsolete_line_table =
          NEXT obsolete_line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN
                module_description.file;

        = llc$symbol_table =
          NEXT symbol_table: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$line_table =
          NEXT line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN
                module_description.file;

        = llc$supplemental_debug_tables =
          NEXT supplemental_debug_tables: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$obsolete_formal_parameters =
          NEXT obsolete_formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$formal_parameters =
          NEXT formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$binding_template =
          NEXT binding_template IN module_description.file;

        = llc$form_definition =
          osp$set_status_abnormal (oc, oce$e_form_def_found_in_module, module_name, status);
          RETURN;

        = llc$68000_absolute =
          NEXT m68000_absolute: [[REP object_text_descriptor^.number_of_68000_bytes OF cell]] IN
                module_description.file;

        = llc$transfer_symbol =
          NEXT transfer_symbol IN module_description.file;

        CASEND;
      UNTIL object_text_descriptor^.kind = llc$transfer_symbol;

      last_xref^.link := NIL;


    PROCEND obtain_xrefs_from_object_module;
?? OLDTITLE ??
?? NEWTITLE := 'obtain_xrefs_from_load_module' ??
?? EJECT ??

    PROCEDURE obtain_xrefs_from_load_module
      (VAR module_descritpion: oct$module_description;
       VAR xref_list: oct$external_reference_list;
           retain: boolean;
       VAR status: ost$status);


      VAR
        last_xref: ^oct$external_reference_list;

      VAR { object text record templates }
        object_text_descriptor: ^llt$object_text_descriptor,
        external_linkage: ^llt$external_linkage;


      last_xref := ^xref_list;

      IF llc$external_element IN module_description.load_module_header^.interpretive_header.
            elements_defined THEN
        object_text_descriptor := #PTR (module_description.load_module_header^.interpretive_header.
              external_linkages, module_description.file^);
        IF object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
          RETURN;
        IFEND;

        RESET module_description.file TO object_text_descriptor;
        NEXT object_text_descriptor IN module_description.file;

        WHILE object_text_descriptor^.kind = llc$external_linkage DO
          NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN
                module_description.file;
          IF external_linkage = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
            RETURN;
          IFEND;

          IF retain THEN
            ALLOCATE last_xref^.link IN ocv$olg_working_heap^;
          ELSE
            NEXT last_xref^.link IN ocv$olg_scratch_seq;
          IFEND;

          IF last_xref^.link = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;

          last_xref := last_xref^.link;
          last_xref^.name := external_linkage^.name;

          NEXT object_text_descriptor IN module_description.file;
          IF object_text_descriptor = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
            RETURN;
          IFEND;
        WHILEND;
      IFEND;

      last_xref^.link := NIL;



    PROCEND obtain_xrefs_from_load_module;
?? OLDTITLE ??
?? EJECT ??


    CASE module_description.kind OF
    = occ$cpu_object_module =
      obtain_xrefs_from_object_module (module_description, xref_list, retain, status);

    = occ$load_module =
      obtain_xrefs_from_load_module (module_description, xref_list, retain, status);

    = occ$bound_module =
      xref_list.link := module_description.bound_module_header^.xref_list.link;

    = occ$command_procedure, occ$function_procedure, occ$program_description, occ$ppu_object_module,
          occ$command_description, occ$function_description, occ$message_module, occ$panel_module =
      xref_list.link := NIL;
    CASEND;

  PROCEND ocp$obtain_xref_list;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$obtain_library_list' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$obtain_library_list
    (VAR module_description: oct$module_description;
         changed_info: ^oct$changed_info;
     VAR library_list: oct$name_list;
         retain: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'obtain_libs_from_object_module' ??
?? EJECT ??

    PROCEDURE obtain_libs_from_object_module
      (VAR module_descritpion: oct$module_description;
       VAR library_list: oct$name_list;
           retain: boolean;
       VAR status: ost$status);


      VAR
        l: integer,
        last_library: ^oct$name_list;

      VAR { object text record templates }
        object_text_descriptor: ^llt$object_text_descriptor,

        identification: ^llt$identification,
        application_identifier: ^llt$application_identifier,
        libraries: ^llt$libraries,
        section_definition: ^llt$section_definition,
        segment_definition: ^llt$segment_definition,
        obsolete_segment_definition: ^llt$obsolete_segment_definition,
        text: ^llt$text,
        replication: ^llt$replication,
        bit_string_insertion: ^llt$bit_string_insertion,
        relocation: ^llt$relocation,
        binding_template: ^llt$binding_template,
        entry_definition: ^llt$entry_definition,
        deferred_entry_points: ^llt$deferred_entry_points,
        deferred_common_blocks: ^llt$deferred_common_blocks,
        external_linkage: ^llt$external_linkage,
        address_formulation: ^llt$address_formulation,
        obsolete_formal_parameters: ^llt$obsolete_formal_parameters,
        formal_parameters: ^llt$formal_parameters,
        actual_parameters: ^llt$actual_parameters,
        debug_table_fragment: ^llt$debug_table_fragment,
        obsolete_line_address_table: ^llt$obsolete_line_address_table,
        symbol_table: ^llt$symbol_table,
        line_address_table: ^llt$line_address_table,
        supplemental_debug_tables: ^llt$supplemental_debug_tables,
        m68000_absolute: ^llt$68000_absolute,
        transfer_symbol: ^llt$transfer_symbol,
        module_name: pmt$program_name;

      library_list.link := NIL;

      RESET module_description.file TO module_description.cpu_object_module_header^.identification;
      NEXT identification IN module_description.file;

      REPEAT
        NEXT object_text_descriptor IN module_description.file;

        CASE object_text_descriptor^.kind OF
        = llc$libraries =
          NEXT libraries: [1 .. object_text_descriptor^.number_of_libraries] IN module_description.file;

          FOR l := 1 TO object_text_descriptor^.number_of_libraries DO
            last_library := ^library_list;
            WHILE (last_library^.link <> NIL) AND (last_library^.link^.name <> libraries^ [l]) DO
              last_library := last_library^.link;
            WHILEND;

            IF last_library^.link = NIL THEN
              IF retain THEN
                ALLOCATE last_library^.link IN ocv$olg_working_heap^;
              ELSE
                NEXT last_library^.link IN ocv$olg_scratch_seq;
              IFEND;

              last_library := last_library^.link;
              IF last_library = NIL THEN
                osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
                RETURN;
              IFEND;

              last_library^.name := libraries^ [l];
              last_library^.link := NIL;
            IFEND;
          FOREND;

        = llc$application_identifier =
          NEXT application_identifier IN module_description.file;

        = llc$section_definition, llc$unallocated_common_block =
          NEXT section_definition IN module_description.file;

        = llc$deferred_common_blocks =
          NEXT deferred_common_blocks: [1 .. object_text_descriptor^.number_of_common_blocks] IN
                module_description.file;

        = llc$segment_definition =
          NEXT segment_definition IN module_description.file;

        = llc$obsolete_segment_definition =
          NEXT obsolete_segment_definition IN module_description.file;

        = llc$text =
          NEXT text: [1 .. object_text_descriptor^.number_of_bytes] IN module_description.file;

        = llc$replication =
          NEXT replication: [1 .. object_text_descriptor^.number_of_bytes] IN module_description.file;

        = llc$bit_string_insertion =
          NEXT bit_string_insertion IN module_description.file;

        = llc$address_formulation =
          NEXT address_formulation: [1 .. object_text_descriptor^.number_of_adr_items] IN
                module_description.file;

        = llc$external_linkage =
          NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN
                module_description.file;

        = llc$entry_definition =
          NEXT entry_definition IN module_description.file;

        = llc$deferred_entry_points =
          NEXT deferred_entry_points: [1 .. object_text_descriptor^.number_of_entry_points] IN
                module_description.file;

        = llc$relocation =
          NEXT relocation: [1 .. object_text_descriptor^.number_of_rel_items] IN module_description.file;

        = llc$actual_parameters =
          NEXT actual_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$cybil_symbol_table_fragment =
          NEXT debug_table_fragment: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$obsolete_line_table =
          NEXT obsolete_line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN
                module_description.file;

        = llc$symbol_table =
          NEXT symbol_table: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$line_table =
          NEXT line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN
                module_description.file;

        = llc$supplemental_debug_tables =
          NEXT supplemental_debug_tables: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$obsolete_formal_parameters =
          NEXT obsolete_formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$formal_parameters =
          NEXT formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$binding_template =
          NEXT binding_template IN module_description.file;

        = llc$form_definition =
          osp$set_status_abnormal (oc, oce$e_form_def_found_in_module, module_name, status);
          RETURN;

        = llc$68000_absolute =
          NEXT m68000_absolute: [[REP object_text_descriptor^.number_of_68000_bytes OF cell]] IN
                module_description.file;

        = llc$transfer_symbol =
          NEXT transfer_symbol IN module_description.file;

        CASEND;
      UNTIL object_text_descriptor^.kind = llc$transfer_symbol;


    PROCEND obtain_libs_from_object_module;
?? OLDTITLE ??
?? NEWTITLE := 'obtain_libs_from_load_module' ??
?? EJECT ??

    PROCEDURE obtain_libs_from_load_module
      (VAR module_descritpion: oct$module_description;
       VAR library_list: oct$name_list;
           retain: boolean;
       VAR status: ost$status);


      VAR
        l: integer,
        last_library: ^oct$name_list;

      VAR { object text record templates }
        object_text_descriptor: ^llt$object_text_descriptor,
        libraries: ^llt$libraries;


      library_list.link := NIL;

      IF llc$library_element IN module_description.load_module_header^.interpretive_header.
            elements_defined THEN
        object_text_descriptor := #PTR (module_description.load_module_header^.interpretive_header.
              library_list, module_description.file^);
        IF object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
          RETURN;
        IFEND;

        RESET module_description.file TO object_text_descriptor;
        NEXT object_text_descriptor IN module_description.file;

        IF object_text_descriptor^.kind = llc$libraries THEN
          NEXT libraries: [1 .. object_text_descriptor^.number_of_libraries] IN module_description.file;
          IF libraries = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
            RETURN;
          IFEND;

          FOR l := 1 TO object_text_descriptor^.number_of_libraries DO
            last_library := ^library_list;
            WHILE (last_library^.link <> NIL) AND (last_library^.link^.name <> libraries^ [l]) DO
              last_library := last_library^.link;
            WHILEND;

            IF last_library^.link = NIL THEN
              IF retain THEN
                ALLOCATE last_library^.link IN ocv$olg_working_heap^;
              ELSE
                NEXT last_library^.link IN ocv$olg_scratch_seq;
              IFEND;

              last_library := last_library^.link;
              IF last_library = NIL THEN
                osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
                RETURN;
              IFEND;

              last_library^.name := libraries^ [l];
              last_library^.link := NIL;
            IFEND;
          FOREND;
        IFEND;
      IFEND;



    PROCEND obtain_libs_from_load_module;
?? OLDTITLE ??
?? EJECT ??


    IF (changed_info <> NIL) AND (changed_info^.new_libraries) THEN
      library_list.link := changed_info^.library_list;

    ELSE
      CASE module_description.kind OF
      = occ$cpu_object_module =
        obtain_libs_from_object_module (module_description, library_list, retain, status);

      = occ$load_module =
        obtain_libs_from_load_module (module_description, library_list, retain, status);

      = occ$command_procedure, occ$function_procedure, occ$program_description, occ$ppu_object_module,
            occ$command_description, occ$function_description, occ$message_module, occ$panel_module =
        library_list.link := NIL;
      CASEND;
    IFEND;

  PROCEND ocp$obtain_library_list;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$obtain_code_section_ids' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$obtain_code_section_ids
    (VAR module_description: oct$module_description;
     VAR code_section_ids: oct$code_section_ids;
     VAR status: ost$status);

?? NEWTITLE := 'get_ordinals_from_object_module' ??
?? EJECT ??

    PROCEDURE get_ordinals_from_object_module
      (VAR module_descritpion: oct$module_description;
       VAR code_section_ids: oct$code_section_ids;
       VAR status: ost$status);


      VAR
        last_code_section_id: ^oct$code_section_ids;

      VAR { object text record templates }
        object_text_descriptor: ^llt$object_text_descriptor,

        identification: ^llt$identification,
        application_identifier: ^llt$application_identifier,
        libraries: ^llt$libraries,
        section_definition: ^llt$section_definition,
        segment_definition: ^llt$segment_definition,
        obsolete_segment_definition: ^llt$obsolete_segment_definition,
        text: ^llt$text,
        replication: ^llt$replication,
        bit_string_insertion: ^llt$bit_string_insertion,
        relocation: ^llt$relocation,
        binding_template: ^llt$binding_template,
        entry_definition: ^llt$entry_definition,
        deferred_entry_points: ^llt$deferred_entry_points,
        deferred_common_blocks: ^llt$deferred_common_blocks,
        external_linkage: ^llt$external_linkage,
        address_formulation: ^llt$address_formulation,
        obsolete_formal_parameters: ^llt$obsolete_formal_parameters,
        formal_parameters: ^llt$formal_parameters,
        actual_parameters: ^llt$actual_parameters,
        debug_table_fragment: ^llt$debug_table_fragment,
        obsolete_line_address_table: ^llt$obsolete_line_address_table,
        symbol_table: ^llt$symbol_table,
        line_address_table: ^llt$line_address_table,
        supplemental_debug_tables: ^llt$supplemental_debug_tables,
        m68000_absolute: ^llt$68000_absolute,
        transfer_symbol: ^llt$transfer_symbol,
        module_name: pmt$program_name;

      last_code_section_id := ^code_section_ids;

      RESET module_description.file TO module_description.cpu_object_module_header^.identification;
      NEXT identification IN module_description.file;

      REPEAT
        NEXT object_text_descriptor IN module_description.file;

        CASE object_text_descriptor^.kind OF
        = llc$section_definition, llc$unallocated_common_block =
          NEXT section_definition IN module_description.file;

          IF section_definition^.kind = llc$code_section THEN
            ALLOCATE last_code_section_id^.link IN ocv$olg_working_heap^;
            IF last_code_section_id^.link = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;

            last_code_section_id := last_code_section_id^.link;
            last_code_section_id^.name := module_description.name;
            last_code_section_id^.section_ordinal := section_definition^.section_ordinal;
          IFEND;

        = llc$deferred_common_blocks =
          NEXT deferred_common_blocks: [1 .. object_text_descriptor^.number_of_common_blocks] IN
                module_description.file;

        = llc$segment_definition =
          NEXT segment_definition IN module_description.file; { Should never get here !!!! }

        = llc$obsolete_segment_definition =
          NEXT obsolete_segment_definition IN module_description.file; { Should never get here !!!! }

        = llc$application_identifier =
          NEXT application_identifier IN module_description.file;

        = llc$libraries =
          NEXT libraries: [1 .. object_text_descriptor^.number_of_libraries] IN module_description.file;

        = llc$text =
          NEXT text: [1 .. object_text_descriptor^.number_of_bytes] IN module_description.file;

        = llc$replication =
          NEXT replication: [1 .. object_text_descriptor^.number_of_bytes] IN module_description.file;

        = llc$bit_string_insertion =
          NEXT bit_string_insertion IN module_description.file;

        = llc$address_formulation =
          NEXT address_formulation: [1 .. object_text_descriptor^.number_of_adr_items] IN
                module_description.file;

        = llc$entry_definition =
          NEXT entry_definition IN module_description.file;

        = llc$deferred_entry_points =
          NEXT deferred_entry_points: [1 .. object_text_descriptor^.number_of_entry_points] IN
                module_description.file;

        = llc$external_linkage =
          NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN
                module_description.file;

        = llc$relocation =
          NEXT relocation: [1 .. object_text_descriptor^.number_of_rel_items] IN module_description.file;

        = llc$actual_parameters =
          NEXT actual_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$cybil_symbol_table_fragment =
          NEXT debug_table_fragment: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$obsolete_line_table =
          NEXT obsolete_line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN
                module_description.file;

        = llc$symbol_table =
          NEXT symbol_table: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$line_table =
          NEXT line_address_table: [1 .. object_text_descriptor^.number_of_line_items] IN
                module_description.file;

        = llc$supplemental_debug_tables =
          NEXT supplemental_debug_tables: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$obsolete_formal_parameters =
          NEXT obsolete_formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$formal_parameters =
          NEXT formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
                module_description.file;

        = llc$binding_template =
          NEXT binding_template IN module_description.file;

        = llc$form_definition =
          osp$set_status_abnormal (oc, oce$e_form_def_found_in_module, module_name, status);
          RETURN;

        = llc$68000_absolute =
          NEXT m68000_absolute: [[REP object_text_descriptor^.number_of_68000_bytes OF cell]] IN
                module_description.file;

        = llc$transfer_symbol =
          NEXT transfer_symbol IN module_description.file;

        CASEND;
      UNTIL object_text_descriptor^.kind = llc$transfer_symbol;

      last_code_section_id^.link := NIL;


    PROCEND get_ordinals_from_object_module;
?? OLDTITLE ??
?? NEWTITLE := 'get_ordinals_from_load_module' ??
?? EJECT ??

    PROCEDURE get_ordinals_from_load_module
      (VAR module_descritpion: oct$module_description;
       VAR code_section_ids: oct$code_section_ids;
       VAR status: ost$status);


      VAR
        last_code_section_id: ^oct$code_section_ids;

      VAR { object text record templates }
        object_text_descriptor: ^llt$object_text_descriptor,
        section_definition: ^llt$section_definition;


      last_code_section_id := ^code_section_ids;

      IF llc$section_element IN module_description.load_module_header^.interpretive_header.
            elements_defined THEN
        object_text_descriptor := #PTR (module_description.load_module_header^.interpretive_header.
              section_definitions, module_description.file^);
        IF object_text_descriptor = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
          RETURN;
        IFEND;

        RESET module_description.file TO object_text_descriptor;
        NEXT object_text_descriptor IN module_description.file;

        WHILE (object_text_descriptor^.kind = llc$section_definition) OR
              (object_text_descriptor^.kind = llc$allotted_section_definition) OR
              (object_text_descriptor^.kind = llc$unallocated_common_block) DO
          NEXT section_definition IN module_description.file;
          IF section_definition = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
            RETURN;
          IFEND;

          IF section_definition^.kind = llc$code_section THEN
            ALLOCATE last_code_section_id^.link IN ocv$olg_working_heap^;
            IF last_code_section_id^.link = NIL THEN
              osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
              RETURN;
            IFEND;

            last_code_section_id := last_code_section_id^.link;
            last_code_section_id^.name := module_description.name;
            last_code_section_id^.section_ordinal := section_definition^.section_ordinal;
          IFEND;

          NEXT object_text_descriptor IN module_description.file;
          IF object_text_descriptor = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
            RETURN;
          IFEND;

        WHILEND;
      IFEND;

      last_code_section_id^.link := NIL;



    PROCEND get_ordinals_from_load_module;
?? OLDTITLE ??
?? EJECT ??


    CASE module_description.kind OF
    = occ$cpu_object_module =
      get_ordinals_from_object_module (module_description, code_section_ids, status);

    = occ$load_module =
      get_ordinals_from_load_module (module_description, code_section_ids, status);

    = occ$command_procedure, occ$function_procedure, occ$program_description, occ$ppu_object_module,
          occ$command_description, occ$function_description, occ$message_module, occ$panel_module,
          occ$bound_module =
      code_section_ids.link := NIL;
    CASEND;

  PROCEND ocp$obtain_code_section_ids;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$obtain_component_info' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$obtain_component_info
    (VAR module_description: oct$module_description;
     VAR component_info: ^llt$component_information;
     VAR status: ost$status);


    VAR

      i: integer,
      info_element_header: ^llt$info_element_header,
      new_header: llt$info_element_header,
      header: oct$header;


    CASE module_description.kind OF
    = occ$cpu_object_module, occ$ppu_object_module, occ$program_description, occ$command_procedure,
          occ$function_procedure, occ$command_description, occ$function_description, occ$message_module,
          occ$panel_module =
      component_info := NIL;

    = occ$load_module =
      IF llc$information_element IN module_description.load_module_header^.elements_defined THEN
        info_element_header := #PTR (module_description.load_module_header^.information_element,
              module_description.file^);
        IF info_element_header = NIL THEN
          osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
          RETURN;
        IFEND;

        IF info_element_header^.version <> llc$info_element_version THEN
          ocp$convert_information_element (info_element_header, new_header);
          info_element_header := ^new_header;
        IFEND;

        IF info_element_header^.number_of_components > 1 THEN
          component_info := #PTR (info_element_header^.component_ptr, module_description.file^);
          IF component_info = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, module_description.name, status);
            RETURN;
          IFEND;
        ELSE
          component_info := NIL;
        IFEND;
      ELSE
        component_info := NIL;
      IFEND;

    = occ$bound_module =
      IF UPPERBOUND (module_description.bound_module_header^.components^) > 1 THEN
        NEXT component_info: [1 .. UPPERBOUND (module_description.bound_module_header^.components^)] IN
              ocv$olg_scratch_seq;
        IF component_info = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;

        FOR i := 1 TO UPPERBOUND (module_description.bound_module_header^.components^) DO
          ocp$obtain_header (module_description.bound_module_header^.components^ [i]^, NIL, header, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          component_info^ [i].name := header.identification.name;
          component_info^ [i].time_created := header.identification.time_created;
          component_info^ [i].date_created := header.identification.date_created;
          component_info^ [i].generator_id := header.identification.generator_id;
          component_info^ [i].generator_name_vers := header.identification.generator_name_vers;
          component_info^ [i].commentary := header.identification.commentary;
        FOREND;
      ELSE
        component_info := NIL;
      IFEND;
    CASEND;


  PROCEND ocp$obtain_component_info;
?? OLDTITLE ??



MODEND ocm$object_module_scanners;
*DECK DECK=OCM$OLG_TYPES EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$olg_types;
*copyc oct$object_code_utility_types
MODEND ocm$olg_types;

*DECK DECK=OCM$OMC_SIMULATED_IO_ROUTINES EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
?? LEFT := 1, RIGHT := 110 ??
*copy OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE : OBJECT MODULE CONVERTER SIMULATED IO', EJECT ??
MODULE ocm$omc_simulated_io_routines;


?? SET (CHKALL := OFF) ??


{ *callc amxgfat }
{ *callc amxfile }
{ *callc amxopen }
{ *callc amxgetp }
{ *callc inxmove }
?? PUSH (LISTEXT := ON) ??
*copyc AMP$GET_FILE_ATTRIBUTES
*copyc AMP$FILE
*copyc AMP$OPEN
*copyc AMP$GET_PARTIAL
*copyc I#MOVE
?? POP ??


  VAR
    status_state: [XREF] (eoi_warning_status, error_status);


  VAR
    ci_file_identifier: [STATIC] amt$file_identifier,
    status: ost$status;

  TYPE
    cc_ost_status = record
      case normal: boolean of
      = FALSE =
        identifier: string (2),
        condition: 0 .. 999999,
        text: cc_ost_string,
      casend,
    recend,

    cc_ost_string = record
      size: 0 .. 256,
      value: string (256),
    recend;

?? NEWTITLE := '                         WARNING & ERROR ' ??
?? FMT (FORMAT := OFF) ??

?? eject ??
?? SET (LIST := OFF) ??
*copyc PME$PROGRAM_SERVICES_EXCEPTIONS
*copyc OCE$OBJECT_CONVERTER_EXCEPTIONS
?? SET (LIST := ON) ??



?? fmt (format := on) ??

  PROCEDURE eoi_warning (eoi_warning_condition: integer;
    VAR status: ost$status);

    status.normal := FALSE;
    status_state := eoi_warning_status;
    status.condition := eoi_warning_condition;

  PROCEND eoi_warning;



  PROCEDURE error (error_condition: integer;
        error_string: string ( * );
    VAR status: ost$status);

    status.normal := FALSE;
    status_state := error_status;
    status.condition := error_condition;
    status.text.value (1, * ) :=
      '                                                                            ';
    status.text.size := STRLENGTH (error_string);
    status.text.value (1, status.text.size) := error_string;
    status.identifier (1, 2) := 'OC';

  PROCEND error;
?? OLDTITLE ??
?? NEWTITLE := '                         OBTAIN CI FILE' ??
?? EJECT ??

  PROCEDURE [XDCL] obtain_ci_file (ci_file_name: amt$local_file_name;
    VAR stat: cc_ost_status);



    VAR
      local_file: boolean,
      existing_file: boolean,
      contains_data: boolean;

    VAR
      file_attributes: array [1 .. 4] of amt$file_attribute;


    file_attributes [1].key := amc$access_mode;
    file_attributes [2].key := amc$block_type;
    file_attributes [3].key := amc$record_type;
    file_attributes [4].key := amc$file_organization;

    amp#get_file_attributes (ci_file_name, file_attributes, local_file, existing_file, contains_data, status);
    IF NOT status.normal THEN
      stat := status;
      RETURN;
    IFEND;

    IF local_file THEN
      file_attributes [1].access_mode := $pft$usage_selections [pfc$read];
      file_attributes [2].block_type := amc$user_specified;
      file_attributes [3].record_type := amc$undefined;
      file_attributes [4].file_organization := amc$sequential;

      amp#file (ci_file_name, file_attributes, status);
      IF NOT status.normal THEN
        stat := status;
        RETURN;
      IFEND;

      amp#open (ci_file_name, amc$record, ci_file_identifier, status);
      stat := status;
    ELSE
      error (oce$missing_or_empty_file, ci_file_name, status);
      stat := status;
    IFEND;


  PROCEND obtain_ci_file;
?? OLDTITLE ??
  ?? NEWTITLE := '                         GET NEXT' ??
  ?? EJECT ??

  PROCEDURE [XDCL] get_next (working_storage_area: ^cell;
        working_storage_length: integer;
    VAR stat: cc_ost_status);




{       PURPOSE:                        }
{         To input the next object      }
{         module item even if it spans  }
{         physical records.             }


    VAR
      record_length: amt$max_record_length,
      transfer_count: amt$transfer_count,
      byte_address: amt$file_byte_address,
      file_position: amt$file_position,

      ws_area: ^cell,
      ws_length: amt$working_storage_length,
      pva: ^ost$pva;


    ws_area := working_storage_area;
    ws_length := working_storage_length;
    status.normal := TRUE;

{kluge1} i#move (ws_area, ws_area, ws_length);

    REPEAT
      amp#get_partial (ci_file_identifier, ws_area, ws_length, record_length, transfer_count, byte_address,
            file_position, amc$no_skip, status);

      IF (status.normal) AND (file_position <> amc$eoi) THEN
        IF transfer_count < ws_length THEN
          pva := #LOC (ws_area);
          pva^.offset := pva^.offset + transfer_count;

          ws_length := ws_length - transfer_count;
          transfer_count := 0;
        IFEND;
      ELSE
        IF (status.normal) AND (file_position = amc$eoi) THEN
          IF ws_length < working_storage_length THEN
            eoi_warning (oce$short_record_or_descriptor, status);
            stat := status;
          ELSE
            eoi_warning (oce$missing_rec_or_descriptor, status);
            stat := status;
          IFEND;
        ELSE
          stat := status;
        IFEND;
      IFEND;
    UNTIL (transfer_count >= ws_length) OR (NOT status.normal);

  PROCEND get_next;
?? OLDTITLE ??
MODEND omc$simulated_io_routines;
*DECK DECK=OCM$OPEN_SCRATCH_SEGMENT EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$open_scratch_segment;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc clp$scan_command_line
*copyc pmp$get_unique_name
*copyc amp$open
*copyc amp$get_segment_pointer
*copyc pmp$abort
?? POP ??
*copyc och$open_scratch_segment

  PROCEDURE [XDCL] ocp$open_scratch_segment (scl_var: string (31);
    VAR fid: amt$file_identifier;
    VAR seg_p: amt$segment_pointer;
    VAR status: ost$status);

    VAR
      access_sel: amt$file_access_selections,
      create_var: string (osc$max_string_size),
      length: integer,
      name: ost$name;

    pmp$get_unique_name (name, status);
    IF NOT status.normal THEN
      pmp$abort (status);
    IFEND;
    STRINGREP (create_var, length, ' create_variable n=', scl_var, ' k=string s=job v=''', name, '''');
    clp$scan_command_line (create_var (1, length), status);
    IF NOT status.normal AND (status.condition <> cle$var_already_created) THEN
      pmp$abort (status);
    IFEND;
    PUSH access_sel: [1 .. 2];
    access_sel^ [1].key := amc$access_mode;
    access_sel^ [1].access_mode := $pft$usage_selections [pfc$read, pfc$shorten, pfc$append, pfc$modify];
    access_sel^ [2].key := amc$return_option;
    access_sel^ [2].return_option := amc$return_at_close;
    amp$open (name, amc$segment, access_sel, fid, status);
    IF NOT status.normal THEN
      pmp$abort (status);
    IFEND;
    amp$get_segment_pointer (fid, amc$sequence_pointer, seg_p, status);
    IF NOT status.normal THEN
      pmp$abort (status);
    IFEND;
  PROCEND ocp$open_scratch_segment;
MODEND ocm$open_scratch_segment;
*DECK DECK=OCM$OUTPUT_DISPLAY_HANDLERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Utilities: Output Display Handlers' ??
MODULE ocm$output_display_handlers;



{ PURPOSE:
{   This module contains the general routines for handling all output displays.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc clc$page_widths
*copyc cle$ecc_miscellaneous
*copyc oct$display_toggles
*copyc oct$open_file_list
?? POP ??
*copyc clp$build_standard_title
*copyc clp$convert_integer_to_string
*copyc clp$close_display
*copyc clp$display_scl_proc_parameters
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc clp$right_justify_string
*copyc clp$trimmed_string_size
*copyc ocp$search_open_file_list
*copyc osp$set_status_abnormal
*copyc pmp$exit
*copyc pmp$get_legible_date_time
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    v$display_control: [STATIC] clt$display_control,

    v$narrow_title1: [STATIC] string (clc$narrow_page_width),
    v$narrow_title2: [STATIC] string (clc$narrow_page_width),
    v$wide: [STATIC] boolean,
    v$wide_title: [STATIC] string (clc$wide_page_width),

    v$output_line: [STATIC] oct$output_line,
    v$error_line: [STATIC] oct$output_line,
    v$warning_line: [STATIC] oct$output_line;

?? OLDTITLE ??
?? NEWTITLE := 'new_page_procedure', EJECT ??

{ PURPOSE:
{   Writes the page header with current page number.

  PROCEDURE new_page_procedure
    (VAR v$display_control: clt$display_control;
         new_page_number: integer;
     VAR status: ost$status);

    CONST
      max_page_chars = 10;

    VAR
      page_number: ost$string,
      ignore: integer,
      ignore_status: ost$status,
      page_and_number: string (max_page_chars);


    clp$reset_for_next_display_page (v$display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (v$display_control.page_number, 10, FALSE, page_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    page_and_number := 'PAGE ';
    page_and_number (6, * ) := page_number.value (1, page_number.size);
    IF v$display_control.include_format_effectors THEN
      clp$right_justify_string (page_and_number);
    IFEND;

    IF v$wide THEN
      v$wide_title (123, 10) := page_and_number;
      clp$put_display (v$display_control, v$wide_title, clc$trim, status);
    ELSE
      v$narrow_title1 (70, 10) := page_and_number;
      clp$put_display (v$display_control, v$narrow_title1, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_display (v$display_control, v$narrow_title2, clc$trim, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$new_display_line (v$display_control, 2, status);

  PROCEND new_page_procedure;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$open_output_file', EJECT ??

{ PURPOSE:
{   Open the specified file as the output file.

  PROCEDURE [XDCL] ocp$open_output_file
    (    output: fst$file_reference;
         page_header: ^string ( * );
     VAR status: ost$status);


    CONST
      v$command_name = '                               ';

    VAR
      default_ring_attributes: amt$ring_attributes,
      file_has_been_opened: boolean,
      file_descriptor: ^oct$open_file_list,
      i: 1 .. 255,
      size: 1 .. 255;

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);

    clp$open_display_reference (output, ^new_page_procedure, fsc$list, default_ring_attributes,
          v$display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    v$wide := v$display_control.page_width >= clc$wide_page_width;
    clp$build_standard_title (v$wide, v$command_name, v$wide_title, v$narrow_title1, v$narrow_title2,
          v$display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF v$wide THEN
      v$wide_title (1, 85) := page_header^;
    ELSE
      size := clp$trimmed_string_size (page_header^);
      IF size > 54 THEN
        i := 54;
        WHILE page_header^ (i) <> ' ' DO
          i := i - 1;
        WHILEND;
        v$narrow_title1 (1, 54) := page_header^ (1, i);
        v$narrow_title2 (1, 54) := page_header^ (i + 1, * );
      ELSE
        v$narrow_title1 (1, 54) := page_header^;
        v$narrow_title2 (1, 54) := ' ';
      IFEND;
    IFEND;

    v$output_line.size := 0;
    v$error_line.size := 0;
    v$warning_line.size := 0;

  PROCEND ocp$open_output_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$output_current_line', EJECT ??

{ PURPOSE:
{   Output the line in progress.

  PROCEDURE [XDCL] ocp$output_current_line
    (    current_line: ^oct$output_line);

    VAR
      local_status: ost$status;


    IF current_line^.size = 0 THEN
      RETURN;
    IFEND;

    WHILE (current_line^.size > 2) AND (current_line^.text (current_line^.size) = ' ') DO
      current_line^.size := current_line^.size - 1;
    WHILEND;

    CASE current_line^.text (1) OF
    = occ$double_space =
      clp$new_display_line (v$display_control, 1, local_status);
    = occ$triple_space =
      clp$new_display_line (v$display_control, 2, local_status);
    = occ$new_page =
      clp$new_display_line (v$display_control, 3, local_status);
    ELSE
      local_status.normal := TRUE;
    CASEND;

    IF NOT local_status.normal THEN
      pmp$exit (local_status);
    IFEND;

    IF current_line^.size > 1 THEN
      clp$put_display (v$display_control, current_line^.text (2, current_line^.size - 1), clc$trim,
            local_status);
      IF NOT local_status.normal THEN
        pmp$exit (local_status);
      IFEND;
    IFEND;

    current_line^.size := 0;

  PROCEND ocp$output_current_line;
?? OLDTITLE ??
?? NEWTITLE := 'add_string_to_line', EJECT ??

{ PURPOSE:
{   Add the specified string to the line in progress.

  PROCEDURE add_string_to_line
    (    strng: ^string ( * );
         string_size: oct$output_line_size;
     VAR line: oct$output_line);


    VAR
      length: oct$output_line_size;


    IF (line.size + string_size) <= #SIZE (line.text) THEN
      length := string_size;
    ELSE
      length := #SIZE (line.text) - line.size;
    IFEND;

    IF length > 0 THEN
      line.text (line.size + 1, length) := strng^ (1, length);
      line.size := line.size + length;
    IFEND;

  PROCEND add_string_to_line;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$output', EJECT ??

{ PURPOSE:
{   Add the two strings to the line in progress limiting the size of the
{   second string to the given length.  The line is output if the end_of_line
{   parameter is given.

  PROCEDURE [XDCL] ocp$output
    (    string_1: string ( * );
         string_2: string ( * );
         string_2_size: integer;
         end_of_line: boolean);


    VAR
      size: integer;


    add_string_to_line (^string_1, #SIZE (string_1), v$output_line);

    IF string_2_size > #SIZE (string_2) THEN
      size := #SIZE (string_2);
    ELSE
      size := string_2_size;
    IFEND;

    add_string_to_line (^string_2, size, v$output_line);

    IF end_of_line THEN
      ocp$output_current_line (^v$output_line);
    IFEND;


  PROCEND ocp$output;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$output_scl_parameters', EJECT ??

{ PURPOSE:
{   Displays the specified procedure parameters.

  PROCEDURE [XDCL] ocp$output_scl_parameters
    (    scl_procedure: ^SEQ ( * );
     VAR status: ost$status);


    clp$display_scl_proc_parameters (v$display_control, scl_procedure, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND ocp$output_scl_parameters;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$close_output_file', EJECT ??

{ PURPOSE:
{   Closes the output file.

  PROCEDURE [XDCL] ocp$close_output_file
    (VAR status: ost$status);


    ocp$output ('', ' ', 1, occ$end_of_line);

    clp$close_display (v$display_control, status);

  PROCEND ocp$close_output_file;
?? OLDTITLE ??

MODEND ocm$output_display_handlers;
*DECK DECK=OCM$PROCESS_B0_INSTRUCTIONS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$process_b0_instructions;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc llt$section_definition
*copyc llt$segment_definition
*copyc llt$obsolete_segment_definition
*copyc llt$object_text_descriptor
*copyc llt$module_dictionary
*copyc llt$load_module
*copyc llt$section_address
*copyc oct$bytes
*copyc oct$single_module_predictor_hdr
*copyc oct$offset_change_list
*copyc oct$section_offset_changes
*copyc oce$metapatch_generator_errors
*copyc ocp$new_offset
*copyc osp$set_status_abnormal
?? POP ??

?? EJECT ??
?? TITLE := 'ocp$get_new_q_field' ??
*copyc och$get_new_q_field

  PROCEDURE ocp$get_new_q_field (current_offset: llt$section_address_range;
        old_q_field: oct$two_bytes;
        section_offset_cv: ^oct$offset_change_list;
    VAR new_q_field: oct$two_bytes);

    FUNCTION complement (old_q_field: oct$two_bytes): oct$two_bytes;

      IF old_q_field = 0 THEN
        complement := 0;
      ELSE
        complement := 0ffff(16) - old_q_field + 1;
      IFEND;

    FUNCEND complement;

?? EJECT ??

    VAR
      callee_offset: llt$section_address_range,
      distance: llt$section_address_range,
      new_callee_offset: llt$section_address_range,
      new_current_offset: llt$section_address_range,
      q_field: oct$two_bytes,
      sign_bit: 0 .. 1;

    sign_bit := old_q_field DIV 8000(16);
    IF sign_bit = 1 THEN
      q_field := complement (old_q_field);
      callee_offset := (((current_offset - (8 * q_field)) DIV 8) * 8);
    ELSE
      callee_offset := (((current_offset + (8 * old_q_field)) DIV 8) * 8);
    IFEND;
    new_callee_offset := ocp$new_offset (callee_offset, section_offset_cv);
    new_current_offset := ocp$new_offset (current_offset, section_offset_cv);
    IF ((new_callee_offset - callee_offset) = (new_current_offset - current_offset)) THEN
      new_q_field := old_q_field;
    ELSE
      distance := new_callee_offset - new_current_offset;
      IF distance < 0 THEN
        new_q_field := complement (((distance * ( - 1)) DIV 8) MOD 10000(16));
      ELSE
        new_q_field := ((distance + 7) DIV 8) MOD 10000(16);
      IFEND;
    IFEND;
  PROCEND ocp$get_new_q_field;

?? EJECT ??
?? TITLE := 'ocp$process_b0_instructions' ??

*copyc och$process_b0_instructions

  PROCEDURE [XDCL] ocp$process_b0_instructions (p_module_predictor: ^SEQ ( * );
        module_dictionary: ^llt$module_dictionary;
        p_int_ol: ^SEQ ( * );
    VAR status: ost$status);

    VAR
      byte_count: llt$section_length,
      code_section_found: boolean,
      current_offset: llt$section_address_range,
      data_descriptor: ^oct$four_bytes,
      int_ol: ^SEQ ( * ),
      j: llt$section_ordinal,
      new_q_field: oct$two_bytes,
      module_header: ^llt$load_module_header,
      module_number: llt$module_index,
      module_predictor: ^SEQ ( * ),
      module_predictor_hdr: ^oct$single_module_predictor_hdr,
      object_text_descriptor: ^llt$object_text_descriptor,
      obsolete_segment_definition: ^llt$obsolete_segment_definition,
      op_code: ^oct$one_byte,
      pva: ^cell,
      q_field: ^oct$two_bytes,
      rest_of_32_bits: ^oct$three_bytes,
      rest_of_16_bits: ^oct$one_byte,
      section_definition: ^llt$section_definition,
      section_definitions: ^llt$object_text_descriptor,
      section_header: ^oct$section_info,
      section_offset_cvs: ^oct$section_offset_changes,
      segment_definition: ^llt$segment_definition,
      socv: ^oct$offset_change_list;

    int_ol := p_int_ol;
    module_predictor := p_module_predictor;

    code_section_found := FALSE;
    RESET module_predictor;
    NEXT module_predictor_hdr IN module_predictor;
    IF module_predictor_hdr^.length_normal_section_ocv > 0 THEN
      section_offset_cvs := #PTR (module_predictor_hdr^.section_offset_cv, module_predictor^);
      RESET module_predictor TO section_offset_cvs;
      FOR j := 1 TO module_predictor_hdr^.length_normal_section_ocv DO
        NEXT section_header IN module_predictor;
        NEXT socv: [1 .. section_header^.number_of_socv_items] IN module_predictor;
        IF section_header^.section_kind = llc$code_section THEN
          module_number := 1;
          REPEAT
            IF (module_dictionary^ [module_number].name = module_predictor_hdr^.module_name) AND
                  (module_dictionary^ [module_number].kind = llc$load_module) THEN
              module_header := #PTR (module_dictionary^ [module_number].module_header, int_ol^);
              section_definitions := #PTR (module_header^.interpretive_header.section_definitions, int_ol^);
              RESET int_ol TO section_definitions;

              REPEAT
                NEXT object_text_descriptor IN int_ol;
                CASE object_text_descriptor^.kind OF

                = llc$obsolete_allotted_seg_def =
                  NEXT obsolete_segment_definition IN int_ol;
                  IF (obsolete_segment_definition^.section_definition.kind = llc$code_section) AND (
                        obsolete_segment_definition^.section_definition.section_ordinal = section_header^.
                        section_ordinal) THEN
                    code_section_found := TRUE;
                  IFEND;

                = llc$allotted_segment_definition =
                  NEXT segment_definition IN int_ol;
                  IF (segment_definition^.section_definition.kind = llc$code_section) AND
                        (segment_definition^.section_definition.section_ordinal = section_header^.
                        section_ordinal) THEN
                    code_section_found := TRUE;
                  IFEND;

                = llc$allotted_section_definition =
                  NEXT section_definition IN int_ol;
                  IF (section_definition^.kind = llc$code_section) AND (section_definition^.section_ordinal =
                        section_header^.section_ordinal) THEN
                    code_section_found := TRUE;
                  IFEND;

                = llc$section_definition, llc$unallocated_common_block =
                  NEXT section_definition IN int_ol;

                = llc$obsolete_segment_definition =
                  NEXT obsolete_segment_definition IN int_ol;

                = llc$segment_definition =
                  NEXT segment_definition IN int_ol;

                ELSE
                  osp$set_status_abnormal (occ$status_id, oce$no_code_section, '', status);
                  RETURN;
                CASEND;
              UNTIL code_section_found;
            ELSE
              module_number := module_number + 1;
            IFEND;
          UNTIL code_section_found OR (module_number > UPPERBOUND (module_dictionary^));
          IF code_section_found THEN
            byte_count := 0;
            pva := #address (#ring (int_ol), #segment (int_ol), object_text_descriptor^.allotted_section);
            RESET int_ol TO pva;
            WHILE byte_count < section_definition^.length DO
              NEXT op_code IN int_ol;
              byte_count := byte_count + 1;
              CASE op_code^ OF
              = 00 .. 06(16), 08 .. 11(16), 14(16), 16(16) .. 1c(16), 1e(16) .. 2a(16), 2c(16) .. 37(16),
                    39(16) .. 3f(16) =
                NEXT rest_of_16_bits IN int_ol;
                byte_count := byte_count + 1;
              = 80(16) .. 0a5(16), 0a7(16) .. 0aa(16), 0ac(16) .. 0ae(16), 0b1(16) .. 0b5(16), 0be(16),
                    0bf(16), 0d0(16) .. 0df(16) =
                NEXT rest_of_32_bits IN int_ol;
                byte_count := byte_count + 3;
              = 70(16) .. 77(16) =
                NEXT rest_of_16_bits IN int_ol;
                NEXT data_descriptor IN int_ol;
                NEXT data_descriptor IN int_ol;
                byte_count := byte_count + 9;
              = 0e4(16), 0e5(16), 0e9(16), 0eb(16) =
                NEXT rest_of_32_bits IN int_ol;
                NEXT data_descriptor IN int_ol;
                NEXT data_descriptor IN int_ol;
                byte_count := byte_count + 11;
              = 0ed(16), 0f3(16), 0f4(16), 0f9(16) .. 0fb(16) =
                NEXT rest_of_32_bits IN int_ol;
                NEXT data_descriptor IN int_ol;
                byte_count := byte_count + 7;
              = 0b0(16) =
                current_offset := #offset (op_code) - #offset (pva);
                NEXT rest_of_16_bits IN int_ol;
                NEXT q_field IN int_ol;
                ocp$get_new_q_field (current_offset, q_field^, socv, new_q_field);
                q_field^ := new_q_field;
                byte_count := byte_count + 3;
              ELSE
                NEXT rest_of_16_bits IN int_ol;
                byte_count := byte_count + 1;
              CASEND;
            WHILEND;
          IFEND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND ocp$process_b0_instructions;
MODEND ocm$process_b0_instructions;
*DECK DECK=OCM$PROCESS_BTI_RECORDS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$process_bti_records;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc oct$single_module_predictor_hdr
*copyc oct$section_directory
*copyc oct$offset_change_list
*copyc llt$section_address
*copyc llt$information_element
*copyc ocp$new_offset
?? POP ??

*copyc och$process_bti_records

  PROCEDURE [XDCL] ocp$process_bti_records (module_predictor: ^oct$module_predictor;
        module_predictor_header: ^oct$single_module_predictor_hdr;
        section_directory: ^oct$section_directory;
        bti_records: ^llt$binding_section_template;
        number_of_template_items: 0 .. llc$max_binding_items);

    VAR
      bsocvs: ^oct$offset_change_list,
      j: 0 .. llc$max_binding_items;

    IF module_predictor_header^.length_binding_socv > 0 THEN
      bsocvs := #PTR (module_predictor_header^.binding_section_ocv, module_predictor^);
    ELSE
      bsocvs := NIL;
    IFEND;
    FOR j := 1 TO number_of_template_items DO
      IF bsocvs <> NIL THEN
        bti_records^ [j].binding_offset := ocp$new_offset (bti_records^ [j].binding_offset, bsocvs);
      IFEND;
      IF bti_records^ [j].kind = llc$current_module THEN
        bti_records^ [j].offset := ocp$new_offset (bti_records^ [j].offset, section_directory^ [bti_records^
              [j].section_ordinal].section_offset_change_vector);
        bti_records^ [j].section_ordinal := section_directory^ [bti_records^ [j].section_ordinal].
              new_section_number;
      IFEND;
    FOREND;
  PROCEND ocp$process_bti_records;
MODEND ocm$process_bti_records;
*DECK DECK=OCM$PROCESS_COMMAND_DICTIONARY EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$process_command_dictionary;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc oce$metapatch_generator_errors
*copyc llt$section_address
*copyc llt$command_dictionary
*copyc llt$load_module_header
*copyc llt$library_member_header
*copyc oct$offset_change_list
*copyc ocp$new_global_offset
*copyc osp$set_status_abnormal
?? POP ??

*copyc och$process_command_dictionary

  PROCEDURE [XDCL] ocp$process_command_dictionary (command_dictionary: ^llt$command_dictionary;
        mod_dictionary_ocv: ^oct$offset_change_list;
        int_ol: ^SEQ ( * );
    VAR status: ost$status);

    VAR
      module_header: record
        case boolean of
        = TRUE =
          pointer: ^llt$load_module_header,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      library_member_header: record
        case boolean of
        = TRUE =
          pointer: ^llt$library_member_header,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      application_member_header: record
        case boolean of
        = TRUE =
          pointer: ^llt$application_member_header,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      i: llt$module_index,
      length: integer,
      message: string (100),
      new_offset: llt$section_address_range;

    FOR i := 1 TO UPPERBOUND (command_dictionary^) DO
      CASE command_dictionary^ [i].module_kind OF
      = llc$load_module =
        module_header.pointer := #PTR (command_dictionary^ [i].module_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (module_header.pointer), mod_dictionary_ocv);
        module_header.pva := #address (#ring (module_header.pointer), #segment (module_header.pointer),
              new_offset);
        command_dictionary^ [i].module_header := #REL (module_header.pointer, int_ol^);
      = llc$command_procedure =
        library_member_header.pointer := #PTR (command_dictionary^ [i].command_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (library_member_header.pointer), mod_dictionary_ocv);
        library_member_header.pva := #address (#ring (library_member_header.pointer), #segment
              (library_member_header.pointer), new_offset);
        command_dictionary^ [i].command_header := #REL (library_member_header.pointer, int_ol^);
      = llc$command_description =
        library_member_header.pointer := #PTR (command_dictionary^ [i].command_description_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (library_member_header.pointer), mod_dictionary_ocv);
        library_member_header.pva := #address (#ring (library_member_header.pointer), #segment
              (library_member_header.pointer), new_offset);
        command_dictionary^ [i].command_description_header := #REL (library_member_header.pointer, int_ol^);
      = llc$program_description =
        library_member_header.pointer := #PTR (command_dictionary^ [i].program_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (library_member_header.pointer), mod_dictionary_ocv);
        library_member_header.pva := #address (#ring (library_member_header.pointer), #segment
              (library_member_header.pointer), new_offset);
        command_dictionary^ [i].program_header := #REL (library_member_header.pointer, int_ol^);
      = llc$applic_command_procedure =
        application_member_header.pointer := #PTR (command_dictionary^ [i].applic_command_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (application_member_header.pointer), mod_dictionary_ocv);
        application_member_header.pva := #address (#ring (application_member_header.pointer), #segment
              (application_member_header.pointer), new_offset);
        command_dictionary^ [i].applic_command_header := #REL (application_member_header.pointer, int_ol^);
      = llc$applic_command_description =
        application_member_header.pointer := #PTR (command_dictionary^ [i].applic_command_description_hdr,
              int_ol^);
        new_offset := ocp$new_global_offset (#offset (application_member_header.pointer), mod_dictionary_ocv);
        application_member_header.pva := #address (#ring (application_member_header.pointer), #segment
              (application_member_header.pointer), new_offset);
        command_dictionary^ [i].applic_command_description_hdr := #REL (application_member_header.pointer,
              int_ol^);
      = llc$applic_program_description =
        application_member_header.pointer := #PTR (command_dictionary^ [i].applic_program_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (application_member_header.pointer), mod_dictionary_ocv);
        application_member_header.pva := #address (#ring (application_member_header.pointer), #segment
              (application_member_header.pointer), new_offset);
        command_dictionary^ [i].applic_program_header := #REL (application_member_header.pointer, int_ol^);
      ELSE
        STRINGREP (message, length, command_dictionary^ [i].module_kind);
        osp$set_status_abnormal (occ$status_id, oce$unexpected_record_kind, message (1, length), status);
        RETURN;
      CASEND;
    FOREND;
  PROCEND ocp$process_command_dictionary;
MODEND ocm$process_command_dictionary;
*DECK DECK=OCM$PROCESS_DICTIONARIES EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$process_dictionaries;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc llt$object_library_header
*copyc oct$offset_change_list
*copyc llt$section_address
*copyc llt$module_dictionary
*copyc llt$entry_point_dictionary
*copyc llt$command_dictionary
*copyc llt$function_dictionary
*copyc llt$help_module_dictionary
*copyc llt$message_module_dictionary
*copyc llt$panel_dictionary
*copyc ocp$new_global_offset
*copyc ocp$process_module_dictionary
*copyc ocp$process_ept_dictionary
*copyc ocp$process_command_dictionary
*copyc ocp$process_function_dictionary
*copyc ocp$process_help_dictionary
*copyc ocp$process_message_dictionary
*copyc ocp$process_panel_dictionary
?? POP ??
*copyc och$process_dictionaries

  PROCEDURE [XDCL] ocp$process_dictionaries (ol_dictionary_ocv: ^oct$offset_change_list;
        mod_dictionary_ocv: ^oct$offset_change_list;
        p_object_library: ^SEQ ( * );
    VAR status: ost$status);

    VAR
      module_dictionary: record
        case boolean of
        = TRUE =
          pointer: ^llt$module_dictionary,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      entry_point_dictionary: record
        case boolean of
        = TRUE =
          pointer: ^llt$entry_point_dictionary,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      command_dictionary: record
        case boolean of
        = TRUE =
          pointer: ^llt$command_dictionary,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      function_dictionary: record
        case boolean of
        = TRUE =
          pointer: ^llt$function_dictionary,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      help_dictionary: record
        case boolean of
        = TRUE =
          pointer: ^llt$help_module_dictionary,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      message_dictionary: record
        case boolean of
        = TRUE =
          pointer: ^llt$message_module_dictionary,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      panel_dictionary: record
        case boolean of
        = TRUE =
          pointer: ^llt$panel_dictionary,
        = FALSE =
          pva: ^cell,
        casend,
      recend,


      header: ^llt$object_library_header,
      i: 0 .. llc$max_dictionaries_on_library,
      new_offset: llt$section_address_range,
      object_library: ^SEQ ( * ),
      object_library_dictionaries: ^llt$object_library_dictionaries;

    object_library := p_object_library;

    RESET object_library;
    NEXT header IN object_library;
    NEXT object_library_dictionaries: [1 .. header^.number_of_dictionaries] IN object_library;

    FOR i := 1 TO header^.number_of_dictionaries DO
      CASE object_library_dictionaries^ [i].kind OF
      = llc$module_dictionary =
        module_dictionary.pointer := #PTR (object_library_dictionaries^ [i].module_dictionary,
              object_library^);
        ocp$process_module_dictionary (module_dictionary.pointer, mod_dictionary_ocv, object_library, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        new_offset := ocp$new_global_offset (#offset (module_dictionary.pointer), ol_dictionary_ocv);
        module_dictionary.pva := #address (#ring (module_dictionary.pointer), #segment (module_dictionary.
              pointer), new_offset);
        object_library_dictionaries^ [i].module_dictionary := #REL (module_dictionary.pointer,
              object_library^);
      = llc$entry_point_dictionary =
        entry_point_dictionary.pointer := #PTR (object_library_dictionaries^ [i].entry_point_dictionary,
              object_library^);
        ocp$process_ept_dictionary (entry_point_dictionary.pointer, mod_dictionary_ocv, object_library);

        new_offset := ocp$new_global_offset (#offset (entry_point_dictionary.pointer), ol_dictionary_ocv);
        entry_point_dictionary.pva := #address (#ring (entry_point_dictionary.pointer), #segment
              (entry_point_dictionary.pointer), new_offset);
        object_library_dictionaries^ [i].entry_point_dictionary := #REL (entry_point_dictionary.pointer,
              object_library^);
      = llc$command_dictionary =
        command_dictionary.pointer := #PTR (object_library_dictionaries^ [i].command_dictionary,
              object_library^);
        ocp$process_command_dictionary (command_dictionary.pointer, mod_dictionary_ocv, object_library,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        new_offset := ocp$new_global_offset (#offset (command_dictionary.pointer), ol_dictionary_ocv);
        command_dictionary.pva := #address (#ring (command_dictionary.pointer), #segment (command_dictionary.
              pointer), new_offset);
        object_library_dictionaries^ [i].command_dictionary := #REL (command_dictionary.pointer,
              object_library^);
      = llc$function_dictionary =
        function_dictionary.pointer := #PTR (object_library_dictionaries^ [i].function_dictionary,
              object_library^);
        ocp$process_function_dictionary (function_dictionary.pointer, mod_dictionary_ocv, object_library);

        new_offset := ocp$new_global_offset (#offset (function_dictionary.pointer), ol_dictionary_ocv);
        function_dictionary.pva := #address (#ring (function_dictionary.pointer), #segment
              (function_dictionary.pointer), new_offset);
        object_library_dictionaries^ [i].function_dictionary := #REL (function_dictionary.pointer,
              object_library^);
      = llc$help_module_dictionary =
        help_dictionary.pointer := #PTR (object_library_dictionaries^ [i].help_module_dictionary,
              object_library^);
        ocp$process_help_dictionary (help_dictionary.pointer, mod_dictionary_ocv, object_library);

        new_offset := ocp$new_global_offset (#offset (help_dictionary.pointer), ol_dictionary_ocv);
        help_dictionary.pva := #address (#ring (help_dictionary.pointer), #segment (help_dictionary.pointer),
              new_offset);
        object_library_dictionaries^ [i].help_module_dictionary := #REL (help_dictionary.pointer,
              object_library^);
      = llc$message_module_dictionary =
        message_dictionary.pointer := #PTR (object_library_dictionaries^ [i].message_module_dictionary,
              object_library^);
        ocp$process_message_dictionary (message_dictionary.pointer, mod_dictionary_ocv, object_library);

        new_offset := ocp$new_global_offset (#offset (message_dictionary.pointer), ol_dictionary_ocv);
        message_dictionary.pva := #address (#ring (message_dictionary.pointer), #segment (message_dictionary.
              pointer), new_offset);
        object_library_dictionaries^ [i].message_module_dictionary := #REL (message_dictionary.pointer,
              object_library^);
      = llc$panel_dictionary =
        panel_dictionary.pointer := #PTR (object_library_dictionaries^ [i].panel_dictionary, object_library^);
        ocp$process_panel_dictionary (panel_dictionary.pointer, mod_dictionary_ocv, object_library);

        new_offset := ocp$new_global_offset (#offset (panel_dictionary.pointer), ol_dictionary_ocv);
        panel_dictionary.pva := #address (#ring (panel_dictionary.pointer), #segment (panel_dictionary.
              pointer), new_offset);
        object_library_dictionaries^ [i].panel_dictionary := #REL (panel_dictionary.pointer, object_library^);
      CASEND;
    FOREND;
  PROCEND ocp$process_dictionaries;
MODEND ocm$process_dictionaries;
*DECK DECK=OCM$PROCESS_EPTS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$process_epts;
?? NEWTITLE := 'Object Correction Generation : Update Entry Point Offsets' ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc llt$deferred_entry_points
*copyc llt$entry_definition
*copyc llt$object_text_descriptor
*copyc oct$section_directory
?? POP ??
*copyc ocp$new_offset
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$process_epts', EJECT ??
*copy och$process_epts

  PROCEDURE [XDCL] ocp$process_epts
    (    p_int_ol: ^SEQ ( * );
         entry_points: ^llt$object_text_descriptor;
         section_directory: ^oct$section_directory);

    VAR
      deferred_entry_points: ^llt$deferred_entry_points,
      entry_definition: ^llt$entry_definition,
      entry_points_all_processed: boolean,
      index: 1 .. llc$max_deferred_entry_points,
      int_ol: ^SEQ ( * ),
      object_text_descriptor: ^llt$object_text_descriptor;

    int_ol := p_int_ol;

    entry_points_all_processed := FALSE;
    RESET int_ol TO entry_points;
    REPEAT
      NEXT object_text_descriptor IN int_ol;
      IF object_text_descriptor^.kind = llc$entry_definition THEN
        NEXT entry_definition IN int_ol;
        entry_definition^.offset := ocp$new_offset (entry_definition^.offset,
              section_directory^ [entry_definition^.section_ordinal].section_offset_change_vector);
        entry_definition^.section_ordinal := section_directory^ [entry_definition^.section_ordinal].
              new_section_number;
      ELSEIF object_text_descriptor^.kind = llc$deferred_entry_points THEN
        NEXT deferred_entry_points: [1 .. object_text_descriptor^.number_of_entry_points] IN int_ol;
        FOR index := 1 TO object_text_descriptor^.number_of_entry_points DO
          deferred_entry_points^ [index].section_ordinal :=
                section_directory^ [deferred_entry_points^ [index].section_ordinal].new_section_number;
        FOREND;
      ELSE
        entry_points_all_processed := TRUE;
      IFEND;
    UNTIL entry_points_all_processed;
  PROCEND ocp$process_epts;
?? OLDTITLE ??
MODEND ocm$process_epts;
*DECK DECK=OCM$PROCESS_EPT_DICTIONARY EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$process_ept_dictionary;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc llt$section_address
*copyc llt$entry_point_dictionary
*copyc llt$load_module_header
*copyc oct$offset_change_list
*copyc ocp$new_global_offset
?? POP ??

*copyc och$process_ept_dictionary

  PROCEDURE [XDCL] ocp$process_ept_dictionary (entry_point_dictionary: ^llt$entry_point_dictionary;
        mod_dictionary_ocv: ^oct$offset_change_list;
        int_ol: ^SEQ ( * ));

    VAR
      module_header: record
        case boolean of
        = TRUE =
          pointer: ^llt$load_module_header,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      i: llt$entry_point_index,
      new_offset: llt$section_address_range;

    FOR i := 1 TO UPPERBOUND (entry_point_dictionary^) DO
      CASE entry_point_dictionary^ [i].module_kind OF
      = llc$load_module =
        module_header.pointer := #PTR (entry_point_dictionary^ [i].module_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (module_header.pointer), mod_dictionary_ocv);
        module_header.pva := #address (#ring (module_header.pointer), #segment (module_header.pointer),
              new_offset);
        entry_point_dictionary^ [i].module_header := #REL (module_header.pointer, int_ol^);
      CASEND;
    FOREND;
  PROCEND ocp$process_ept_dictionary;
MODEND ocm$process_ept_dictionary;
*DECK DECK=OCM$PROCESS_EXTS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$process_exts;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc llt$external_linkage
*copyc llt$object_text_descriptor
*copyc oct$section_directory
*copyc ocp$new_offset
?? POP ??

*copyc och$process_exts

  PROCEDURE [XDCL] ocp$process_exts (p_int_ol: ^ SEQ ( * );
        external_element: ^llt$object_text_descriptor;
        section_directory: ^oct$section_directory);

    VAR
      external_linkage: ^llt$external_linkage,
      externals_all_processed: boolean,
      i: 1 .. llc$max_ext_items,
      int_ol: ^ SEQ ( * ),
      object_text_descriptor: ^llt$object_text_descriptor;

    int_ol := p_int_ol;

    externals_all_processed := FALSE;
    RESET int_ol TO external_element;
    REPEAT
      NEXT object_text_descriptor IN int_ol;
      IF object_text_descriptor^.kind <> llc$external_linkage THEN
        externals_all_processed := TRUE;
      ELSE
        NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN int_ol;
        FOR i := 1 TO object_text_descriptor^.number_of_ext_items DO
          external_linkage^.item [i].offset := ocp$new_offset (external_linkage^.item [i].offset,
                section_directory^ [external_linkage^.item [i].section_ordinal].section_offset_change_vector);
          external_linkage^.item [i].section_ordinal := section_directory^ [external_linkage^.item [i].
                section_ordinal].new_section_number;
        FOREND;
      IFEND;
    UNTIL externals_all_processed;
  PROCEND ocp$process_exts;
MODEND ocm$process_exts;
*DECK DECK=OCM$PROCESS_FUNCTION_DICTIONARY EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$process_function_dictionary;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc llt$section_address
*copyc llt$function_dictionary
*copyc llt$library_member_header
*copyc oct$offset_change_list
*copyc ocp$new_global_offset
?? POP ??

*copyc och$process_function_dictionary

  PROCEDURE [XDCL] ocp$process_function_dictionary (function_dictionary: ^llt$function_dictionary;
        mod_dictionary_ocv: ^oct$offset_change_list;
        int_ol: ^SEQ ( * ));

    VAR
      library_member_header: record
        case boolean of
        = TRUE =
          pointer: ^llt$library_member_header,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      i: llt$module_index,
      new_offset: llt$section_address_range;

    FOR i := 1 TO UPPERBOUND (function_dictionary^) DO
      CASE function_dictionary^ [i].module_kind OF
      = llc$function_procedure =
        library_member_header.pointer := #PTR (function_dictionary^ [i].function_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (library_member_header.pointer), mod_dictionary_ocv);
        library_member_header.pva := #address (#ring (library_member_header.pointer), #segment
              (library_member_header.pointer), new_offset);
        function_dictionary^ [i].function_header := #REL (library_member_header.pointer, int_ol^);
      = llc$function_description =
        library_member_header.pointer := #PTR (function_dictionary^ [i].function_description_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (library_member_header.pointer), mod_dictionary_ocv);
        library_member_header.pva := #address (#ring (library_member_header.pointer), #segment
              (library_member_header.pointer), new_offset);
        function_dictionary^ [i].function_description_header := #REL (library_member_header.pointer, int_ol^);
      CASEND;
    FOREND;
  PROCEND ocp$process_function_dictionary;
MODEND ocm$process_function_dictionary;
*DECK DECK=OCM$PROCESS_HELP_DICTIONARY EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$process_help_dictionary;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc llt$section_address
*copyc llt$help_module_dictionary
*copyc llt$library_member_header
*copyc oct$offset_change_list
*copyc ocp$new_global_offset
?? POP ??

*copyc och$process_help_dictionary

  PROCEDURE [XDCL] ocp$process_help_dictionary (help_dictionary: ^llt$help_module_dictionary;
        mod_dictionary_ocv: ^oct$offset_change_list;
        int_ol: ^SEQ ( * ));

    VAR
      library_member_header: record
        case boolean of
        = TRUE =
          pointer: ^llt$library_member_header,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      i: llt$module_index,
      new_offset: llt$section_address_range;

    FOR i := 1 TO UPPERBOUND (help_dictionary^) DO
      library_member_header.pointer := #PTR (help_dictionary^ [i].help_header, int_ol^);
      new_offset := ocp$new_global_offset (#offset (library_member_header.pointer), mod_dictionary_ocv);
      library_member_header.pva := #address (#ring (library_member_header.pointer), #segment
            (library_member_header.pointer), new_offset);
      help_dictionary^ [i].help_header := #REL (library_member_header.pointer, int_ol^);
    FOREND;
  PROCEND ocp$process_help_dictionary;
MODEND ocm$process_help_dictionary;
*DECK DECK=OCM$PROCESS_INFO_ELEMENT EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$process_info_element;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc llt$information_element
*copyc llt$section_address
*copyc llt$identification
*copyc llt$library_member_header
*copyc llt$load_module_header
*copyc llt$module_dictionary
*copyc llt$object_library_header
*copyc llt$relocation
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc pmt$program_name
*copyc occ$generate_predictor
*copyc oct$single_module_predictor_hdr
*copyc oct$offset_change_list
*copyc oct$predictor_header
*copyc oct$module_predictor_size
*copyc oct$section_directory
*copyc oce$metapatch_generator_errors
*copyc oct$code_section_directory
*copyc ocp$build_section_directory
*copyc ocp$new_global_offset
*copyc ocp$process_bti_records
*copyc ocp$process_rel_records
*copyc ocp$process_section_maps
*copyc ocp$convert_information_element
?? POP ??

*copyc och$process_info_element

  PROCEDURE [XDCL] ocp$process_info_element (p_predictor: ^SEQ ( * );
        p_int_ol: ^SEQ ( * );
        code_section_directory: ^oct$code_section_directory;
        module_code_sections: ^oct$module_code_sections;
    VAR status: ost$status);

    VAR
      aliases: record
        case boolean of
        = TRUE =
          pointer: ^pmt$module_list,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      bti_records: record
        case boolean of
        = TRUE =
          pointer: ^llt$binding_section_template,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      component: record
        case boolean of
        = TRUE =
          pointer: ^llt$component_information,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      member: record
        case boolean of
        = TRUE =
          pointer: ^SEQ ( * ),
        = FALSE =
          pva: ^cell,
        casend,
      recend,


      relocation: record
        case boolean of
        = TRUE =
          pointer: ^llt$relocation,
        = FALSE =
          pva: ^cell,
        casend,
      recend,


      section_maps: record
        case boolean of
        = TRUE =
          pointer: ^llt$section_maps,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      counter: llt$module_index,
      current_module_name: pmt$program_name,
      current_module_used: boolean,
      found: boolean,
      i: llt$module_index,
      id_record: ^llt$identification,
      idr: ^llt$object_text_descriptor,
      info_element: ^llt$info_element_header,
      info_element_v_1_0: ^llt$info_element_header_1_0,
      information_element: llt$info_element_header,
      int_ol: ^SEQ ( * ),
      load_module_found: boolean,
      mod_dictionary_ocv: ^oct$offset_change_list,
      module_dictionary: ^llt$module_dictionary,
      module_header: ^llt$load_module_header,
      module_predictor: ^oct$module_predictor,
      module_predictor_header: ^oct$single_module_predictor_hdr,
      module_predictor_size: ^oct$module_predictor_size,
      new_header: ^llt$library_member_header,
      new_info_element: ^llt$info_element_header,
      new_offset: llt$section_address_range,
      new_pva: ^llt$object_text_descriptor,
      ol_dictionaries: ^llt$object_library_dictionaries,
      ol_header: ^llt$object_library_header,
      predictor: ^SEQ ( * ),
      predictor_header: ^oct$predictor_header,
      program_header: ^llt$library_member_header,
      pva: ^cell,
      save_ptr: ^cell,
      scl_header: ^llt$library_member_header,
      section_directory: ^oct$section_directory;

    int_ol := p_int_ol;
    predictor := p_predictor;

    RESET predictor;
    NEXT predictor_header IN predictor;
    IF predictor_header^.number_of_mod_ocv_elements > 0 THEN
      mod_dictionary_ocv := #PTR (predictor_header^.mod_dictionary_ocv, predictor^);
    ELSE
      mod_dictionary_ocv := NIL;
    IFEND;
    current_module_name := osc$null_name;
    current_module_used := TRUE;
    counter := 0;
    RESET int_ol;
    NEXT ol_header IN int_ol;
    NEXT ol_dictionaries: [1 .. ol_header^.number_of_dictionaries] IN int_ol;
    found := FALSE;
    i := 1;
    WHILE NOT found AND (i <= ol_header^.number_of_dictionaries) DO
      IF ol_dictionaries^ [i].kind = llc$module_dictionary THEN
        found := TRUE;
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;
    IF NOT found THEN
      RETURN;
    IFEND;

    module_dictionary := #PTR (ol_dictionaries^ [i].module_dictionary, int_ol^);
    FOR i := 1 TO UPPERBOUND (module_dictionary^) DO
      IF current_module_used AND (counter < predictor_header^.number_module_predictors) THEN
        REPEAT
          NEXT module_predictor_header IN predictor;
          RESET predictor TO module_predictor_header;
          NEXT module_predictor: [[REP module_predictor_header^.predictor_size OF cell]] IN predictor;
          IF module_predictor_header^.kind = llc$load_module THEN
            load_module_found := TRUE;
          ELSE
            load_module_found := FALSE;
          IFEND;
          current_module_name := module_predictor_header^.module_name;
          counter := counter + 1;
          current_module_used := FALSE;
        UNTIL load_module_found OR (counter >= predictor_header^.number_module_predictors);
      IFEND;
      IF load_module_found THEN
        IF module_dictionary^ [i].kind = llc$load_module THEN
          module_header := #PTR (module_dictionary^ [i].module_header, int_ol^);

          IF (llc$information_element IN module_header^.elements_defined) THEN

            info_element := #PTR (module_header^.information_element, int_ol^);
            IF info_element^.version = llc$info_element_version THEN
              information_element := info_element^;
            ELSE
              ocp$convert_information_element (info_element, information_element);
            IFEND;

            IF module_dictionary^ [i].name = current_module_name THEN
              IF llc$interpretive_element IN module_header^.elements_defined THEN
                idr := #PTR (module_header^.interpretive_element, int_ol^);
                RESET int_ol TO idr;
                NEXT idr IN int_ol;
                NEXT id_record IN int_ol;
                ALLOCATE section_directory: [0 .. id_record^.greatest_section_ordinal];
                ocp$build_section_directory (module_predictor, module_header, int_ol, section_directory);
                IF information_element.number_of_rel_items > 0 THEN
                  relocation.pointer := #PTR (information_element.relocation_ptr, int_ol^);
                  ocp$process_rel_records (section_directory, relocation.pointer, information_element.
                        number_of_rel_items, code_section_directory^ [i], module_code_sections, status);
                  IF NOT status.normal THEN
                    RETURN;
                  IFEND;
                IFEND;
                IF information_element.number_of_template_items > 0 THEN
                  bti_records.pointer := #PTR (information_element.binding_template_ptr, int_ol^);
                  ocp$process_bti_records (module_predictor, module_predictor_header, section_directory,
                        bti_records.pointer, information_element.number_of_template_items);
                IFEND;
                IF information_element.number_of_section_maps > 0 THEN
                  section_maps.pointer := #PTR (information_element.section_maps, int_ol^);
                  ocp$process_section_maps (section_directory, mod_dictionary_ocv, section_maps.pointer,
                        information_element.number_of_section_maps, int_ol, module_predictor);
                IFEND;
                FREE section_directory;
              IFEND;
              current_module_used := TRUE;
            IFEND;
            IF info_element^.version = llc$info_element_version THEN
              IF info_element^.number_of_rel_items > 0 THEN
                relocation.pointer := #PTR (info_element^.relocation_ptr, int_ol^);
                new_offset := ocp$new_global_offset (#offset (relocation.pointer), mod_dictionary_ocv);
                relocation.pva := #address (#ring (relocation.pointer), #segment (relocation.pointer),
                      new_offset);
                info_element^.relocation_ptr := #REL (relocation.pointer, int_ol^);
              IFEND;
              IF info_element^.number_of_components > 0 THEN
                component.pointer := #PTR (info_element^.component_ptr, int_ol^);
                new_offset := ocp$new_global_offset (#offset (component.pointer), mod_dictionary_ocv);
                component.pva := #address (#ring (component.pointer), #segment (component.pointer),
                      new_offset);
                info_element^.component_ptr := #REL (component.pointer, int_ol^);
              IFEND;
              IF info_element^.number_of_template_items > 0 THEN
                bti_records.pointer := #PTR (info_element^.binding_template_ptr, int_ol^);
                new_offset := ocp$new_global_offset (#offset (bti_records.pointer), mod_dictionary_ocv);
                bti_records.pva := #address (#ring (bti_records.pointer), #segment (bti_records.pointer),
                      new_offset);
                info_element^.binding_template_ptr := #REL (bti_records.pointer, int_ol^);
              IFEND;
              IF info_element^.number_of_section_maps > 0 THEN
                section_maps.pointer := #PTR (info_element^.section_maps, int_ol^);
                new_offset := ocp$new_global_offset (#offset (section_maps.pointer), mod_dictionary_ocv);
                section_maps.pva := #address (#ring (section_maps.pointer), #segment (section_maps.pointer),
                      new_offset);
                info_element^.section_maps := #REL (section_maps.pointer, int_ol^);
              IFEND;
            ELSE
              info_element_v_1_0 := #PTR (module_header^.information_element, int_ol^);

              IF info_element_v_1_0^.number_of_rel_items > 0 THEN
                relocation.pointer := #PTR (info_element_v_1_0^.relocation_ptr, int_ol^);
                new_offset := ocp$new_global_offset (#offset (relocation.pointer), mod_dictionary_ocv);
                relocation.pva := #address (#ring (relocation.pointer), #segment (relocation.pointer),
                      new_offset);
                info_element_v_1_0^.relocation_ptr := #REL (relocation.pointer, int_ol^);
              IFEND;
              IF info_element_v_1_0^.number_of_components > 0 THEN
                component.pointer := #PTR (info_element_v_1_0^.component_ptr, int_ol^);
                new_offset := ocp$new_global_offset (#offset (component.pointer), mod_dictionary_ocv);
                component.pva := #address (#ring (component.pointer), #segment (component.pointer),
                      new_offset);
                info_element_v_1_0^.component_ptr := #REL (component.pointer, int_ol^);
              IFEND;
              IF info_element_v_1_0^.number_of_template_items > 0 THEN
                bti_records.pointer := #PTR (info_element_v_1_0^.binding_template_ptr, int_ol^);
                new_offset := ocp$new_global_offset (#offset (bti_records.pointer), mod_dictionary_ocv);
                bti_records.pva := #address (#ring (bti_records.pointer), #segment (bti_records.pointer),
                      new_offset);
                info_element_v_1_0^.binding_template_ptr := #REL (bti_records.pointer, int_ol^);
              IFEND;
              IF info_element_v_1_0^.number_of_section_maps > 0 THEN
                section_maps.pointer := #PTR (info_element_v_1_0^.section_maps, int_ol^);
                new_offset := ocp$new_global_offset (#offset (section_maps.pointer), mod_dictionary_ocv);
                section_maps.pva := #address (#ring (section_maps.pointer), #segment (section_maps.pointer),
                      new_offset);
                info_element_v_1_0^.section_maps := #REL (section_maps.pointer, int_ol^);
              IFEND;
            IFEND;
          IFEND;

          IF mod_dictionary_ocv <> NIL THEN
            IF (llc$interpretive_element IN module_header^.elements_defined) THEN
              pva := #PTR (module_header^.interpretive_element, int_ol^);
              new_offset := ocp$new_global_offset (#offset (pva), mod_dictionary_ocv);
              new_pva := #address (#ring (pva), #segment (pva), new_offset);
              module_header^.interpretive_element := #REL (new_pva, int_ol^);
            IFEND;
            IF (llc$information_element IN module_header^.elements_defined) THEN
              pva := #PTR (module_header^.information_element, int_ol^);
              new_offset := ocp$new_global_offset (#offset (pva), mod_dictionary_ocv);
              new_info_element := #address (#ring (pva), #segment (pva), new_offset);
              module_header^.information_element := #REL (new_info_element, int_ol^);
            IFEND;
            IF (llc$library_element IN module_header^.interpretive_header.elements_defined) THEN
              pva := #PTR (module_header^.interpretive_header.library_list, int_ol^);
              new_offset := ocp$new_global_offset (#offset (pva), mod_dictionary_ocv);
              new_pva := #address (#ring (pva), #segment (pva), new_offset);
              module_header^.interpretive_header.library_list := #REL (new_pva, int_ol^);
            IFEND;
            IF (llc$section_element IN module_header^.interpretive_header.elements_defined) THEN
              pva := #PTR (module_header^.interpretive_header.section_definitions, int_ol^);
              new_offset := ocp$new_global_offset (#offset (pva), mod_dictionary_ocv);
              new_pva := #address (#ring (pva), #segment (pva), new_offset);
              module_header^.interpretive_header.section_definitions := #REL (new_pva, int_ol^);
            IFEND;
            IF (llc$entry_point_element IN module_header^.interpretive_header.elements_defined) THEN
              pva := #PTR (module_header^.interpretive_header.entry_points, int_ol^);
              new_offset := ocp$new_global_offset (#offset (pva), mod_dictionary_ocv);
              new_pva := #address (#ring (pva), #segment (pva), new_offset);
              module_header^.interpretive_header.entry_points := #REL (new_pva, int_ol^);
            IFEND;
            IF (llc$external_element IN module_header^.interpretive_header.elements_defined) THEN
              pva := #PTR (module_header^.interpretive_header.external_linkages, int_ol^);
              new_offset := ocp$new_global_offset (#offset (pva), mod_dictionary_ocv);
              new_pva := #address (#ring (pva), #segment (pva), new_offset);
              module_header^.interpretive_header.external_linkages := #REL (new_pva, int_ol^);
            IFEND;
            IF (llc$transfer_symbol_element IN module_header^.interpretive_header.elements_defined) THEN
              pva := #PTR (module_header^.interpretive_header.transfer_symbol, int_ol^);
              new_offset := ocp$new_global_offset (#offset (pva), mod_dictionary_ocv);
              new_pva := #address (#ring (pva), #segment (pva), new_offset);
              module_header^.interpretive_header.transfer_symbol := #REL (new_pva, int_ol^);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    FOREND;
  PROCEND ocp$process_info_element;
MODEND ocm$process_info_element;
*DECK DECK=OCM$PROCESS_INTERP_ELEMENT EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$process_interp_element;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc amt$segment_pointer
*copyc llt$identification
*copyc llt$object_text_descriptor
*copyc llt$object_library_header
*copyc llt$module_dictionary
*copyc llt$load_module_header
*copyc llt$section_definition
*copyc osp$set_status_abnormal
*copyc occ$generate_predictor
*copyc oct$predictor_header
*copyc oct$single_module_predictor_hdr
*copyc oct$offset_change_list
*copyc oct$section_directory
*copyc oct$module_predictor_size
*copyc oce$metapatch_generator_errors
*copyc ocp$adjust_allotted_sections
*copyc ocp$build_section_directory
*copyc ocp$process_epts
*copyc ocp$process_exts
*copyc ocp$process_sections
?? POP ??

*copyc och$process_interp_element

  PROCEDURE [XDCL] ocp$process_interp_element (p_predictor: ^SEQ ( * );
        p_int_ol: ^SEQ ( * ));

    VAR
      counter: llt$module_index,
      current_module_name: pmt$program_name,
      current_module_used: boolean,
      entry_points: ^llt$object_text_descriptor,
      external_element: ^llt$object_text_descriptor,
      found: boolean,
      i: llt$module_index,
      id_record: ^llt$identification,
      idr: ^llt$object_text_descriptor,
      int_ol: ^SEQ ( * ),
      load_module_found: boolean,
      mod_dictionary_ocv: ^oct$offset_change_list,
      module_dictionary: ^llt$module_dictionary,
      module_header: ^llt$load_module_header,
      module_predictor: ^oct$module_predictor,
      predictor: ^SEQ ( * ),
      section_directory: ^oct$section_directory,
      module_predictor_header: ^oct$single_module_predictor_hdr,
      module_predictor_size: ^oct$module_predictor_size,
      ol_dictionaries: ^llt$object_library_dictionaries,
      ol_header: ^llt$object_library_header,
      predictor_header: ^oct$predictor_header,
      save_ptr: ^cell,
      section_def: ^llt$section_definition,
      section_definitions: ^llt$object_text_descriptor,
      status: ost$status,
      total_module_predictor_size: oct$module_predictor_size,
      valid: boolean;

    int_ol := p_int_ol;
    predictor := p_predictor;

    RESET predictor;
    NEXT predictor_header IN predictor;
    IF predictor_header^.number_of_mod_ocv_elements > 0 THEN
      mod_dictionary_ocv := #PTR (predictor_header^.mod_dictionary_ocv, predictor^);
    ELSE
      mod_dictionary_ocv := NIL;
    IFEND;
    current_module_name := osc$null_name;
    current_module_used := TRUE;
    counter := 0;
    RESET int_ol;
    NEXT ol_header IN int_ol;
    NEXT ol_dictionaries: [1 .. ol_header^.number_of_dictionaries] IN int_ol;
    found := FALSE;
    i := 1;
    WHILE NOT found AND (i <= UPPERBOUND (ol_dictionaries^)) DO
      IF ol_dictionaries^ [i].kind = llc$module_dictionary THEN
        found := TRUE;
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;
    IF NOT found THEN
      RETURN;
    IFEND;
    module_dictionary := #PTR (ol_dictionaries^ [i].module_dictionary, int_ol^);
    FOR i := 1 TO UPPERBOUND (module_dictionary^) DO
      IF module_dictionary^ [i].kind = llc$load_module THEN
        IF current_module_used AND (counter < predictor_header^.number_module_predictors) THEN
          REPEAT
            NEXT module_predictor_header IN predictor;
            RESET predictor TO module_predictor_header;
            NEXT module_predictor: [[REP module_predictor_header^.predictor_size OF cell]] IN predictor;
            IF module_predictor_header^.kind = llc$load_module THEN
              load_module_found := TRUE;
            ELSE
              load_module_found := FALSE;
            IFEND;
            current_module_used := FALSE;
            current_module_name := module_predictor_header^.module_name;
            counter := counter + 1;
          UNTIL load_module_found OR (counter >= predictor_header^.number_module_predictors);
        IFEND;
        IF load_module_found THEN
          module_header := #PTR (module_dictionary^ [i].module_header, int_ol^);
          IF llc$section_element IN module_header^.interpretive_header.elements_defined THEN
            section_definitions := #PTR (module_header^.interpretive_header.section_definitions, int_ol^);
            IF (module_dictionary^ [i].name <> current_module_name) AND (mod_dictionary_ocv <> NIL) THEN
              ocp$adjust_allotted_sections (mod_dictionary_ocv, section_definitions, int_ol);
            IFEND;
          IFEND;
          IF module_dictionary^ [i].name = current_module_name THEN
            IF llc$interpretive_element IN module_header^.elements_defined THEN
              idr := #PTR (module_header^.interpretive_element, int_ol^);
              RESET int_ol TO idr;
              NEXT idr IN int_ol;
              NEXT id_record IN int_ol;
              ALLOCATE section_directory: [0 .. id_record^.greatest_section_ordinal];
              ocp$build_section_directory (module_predictor, module_header, int_ol, section_directory);
              IF (llc$section_element IN module_header^.interpretive_header.elements_defined) THEN
                ocp$process_sections (int_ol, section_definitions, section_directory, mod_dictionary_ocv);
              IFEND;
              IF (llc$external_element IN module_header^.interpretive_header.elements_defined) THEN
                external_element := #PTR (module_header^.interpretive_header.external_linkages, int_ol^);
                ocp$process_exts (int_ol, external_element, section_directory);
              IFEND;
              IF (llc$entry_point_element IN module_header^.interpretive_header.elements_defined) THEN
                entry_points := #PTR (module_header^.interpretive_header.entry_points, int_ol^);
                ocp$process_epts (int_ol, entry_points, section_directory);
              IFEND;
              FREE section_directory;
            IFEND;
            current_module_used := TRUE;
          IFEND;
        IFEND;
      IFEND;
    FOREND;
  PROCEND ocp$process_interp_element;
MODEND ocm$process_interp_element;
*DECK DECK=OCM$PROCESS_LINKER_DEBUG_TABLES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Code Utilities: Process Linker Debug Tables' ??
MODULE ocm$process_linker_debug_tables;


{ PURPOSE:
{   This module contains the routines to open, search, and close a linker debug table.

{   **** ANY CHANGES TO THIS DECK MUST ALSO CHANGE OCM$PROCESS_LNKR_DBG_TBLS_OCU IN OCU ****


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc oce$ve_linker_exceptions
*copyc oss$job_fixed
*copyc oss$mainframe_pageable
?? POP ??
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osv$mainframe_pageable_heap

*copyc pmt$linker_debug_table_header
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
?? EJECT ??

  CONST
    c$system_debug_tables = 'Current System';

  VAR
    ocv$address_entry_points: [oss$mainframe_pageable] ^array [1 .. * ] of pmt$number_of_debug_items,
    ocv$debug_table_header: [oss$mainframe_pageable] ^pmt$linker_debug_table_header := NIL,
    ocv$debug_table_segment: [oss$mainframe_pageable] ^SEQ ( * );

  VAR
    v$debug_table_header: [oss$job_fixed] ^pmt$linker_debug_table_header := NIL,
    v$debug_table_segment: [oss$job_fixed] ^SEQ ( * );

?? OLDTITLE ??
?? NEWTITLE := 'determine_section_name', EJECT ??

{ PURPOSE:
{   Set the section name to the name explicitly given to the section or to
{   a name determined by the segment type.

  PROCEDURE determine_section_name
    (    section_item: pmt$section_item;
     VAR section_name: pmt$program_name);


    IF (section_item.name <> osc$null_name) THEN
      section_name := section_item.name;
    ELSEIF (section_item.kind = llc$code_section) THEN
      section_name := 'CODE SECTION';
    ELSEIF (section_item.kind = llc$binding_section) THEN
      section_name := 'BINDING SECTION';
    ELSEIF (section_item.segment_access_control.read_privilege <> osc$non_readable) AND
          (section_item.segment_access_control.write_privilege <> osc$non_writable) THEN
      section_name := 'READ WRITE';
    ELSEIF (section_item.segment_access_control.read_privilege <> osc$non_readable) THEN
      section_name := 'READ ONLY';
    ELSE
      section_name := 'WORKING STORAGE';
    IFEND;


  PROCEND determine_section_name;
?? OLDTITLE ??
?? NEWTITLE := 'find_entry_point_item', EJECT ??

{ PURPOSE:
{   Search for the given entry_point in the entry point tables.  A binary
{   search can be made as the entry_point table is sorted.

  PROCEDURE find_entry_point_item
    (    entry_point_name: pmt$program_name;
     VAR found: boolean;
     VAR entry_point_item: pmt$entry_point_item);


    VAR
      temp: integer,
      entry_points: ^pmt$entry_point_items,
      lower: pmt$number_of_debug_items,
      upper: pmt$number_of_debug_items,
      mid: pmt$number_of_debug_items;


    found := FALSE;

    IF v$debug_table_header^.number_of_entry_points = 0 THEN
      RETURN;
    IFEND;

    entry_points := #PTR (v$debug_table_header^.entry_point_items, v$debug_table_segment^);


    lower := LOWERBOUND (entry_points^);
    upper := UPPERBOUND (entry_points^);

    WHILE (lower <= upper) DO
      temp := lower + upper;
      mid := temp DIV 2;
      IF (entry_points^ [mid].name = entry_point_name) THEN
        entry_point_item := entry_points^ [mid];
        found := TRUE;
        RETURN;
      ELSEIF (entry_points^ [mid].name < entry_point_name) THEN
        lower := mid + 1;
      ELSE
        upper := mid - 1;
      IFEND;
    WHILEND;


  PROCEND find_entry_point_item;
?? OLDTITLE ??
?? NEWTITLE := 'find_entry_point_via_address', EJECT ??

{ PURPOSE:
{   Search the entry point table for the entry point that matches the specified
{   address.
{
{ NOTE:
{   Entry point index is the index of the entry point corresponding to the
{   address.  If this index is unknown, then 1 should be specified which will
{   cause a search of the beginning of the table.

  PROCEDURE find_entry_point_via_address
    (    address: pmt$segment_and_offset;
         entry_point_index: pmt$number_of_debug_items;
     VAR entry_point_item: pmt$entry_point_item);


    VAR
      entry_points: ^pmt$entry_point_items,
      index: pmt$number_of_debug_items;


    entry_points := #PTR (v$debug_table_header^.entry_point_items, v$debug_table_segment^);

    FOR index := entry_point_index TO UPPERBOUND (entry_points^) DO
      IF (entry_points^ [index].address = address) THEN
        entry_point_item := entry_points^ [index];
        RETURN;
      IFEND;
    FOREND;

  PROCEND find_entry_point_via_address;
?? OLDTITLE ??
?? NEWTITLE := 'find_nearest_address_item', EJECT ??

{ PURPOSE:
{   This routine scans the address items table for the nearest item that
{   is less than or equal to the given address.  This search is done using
{   a binary search as the table is sorted by address.
{
{ NOTE:
{   When ever address_item.from_an_entry_point is TRUE, the variable
{   entry_point_index must be non-zero.  If the address_entry_point table
{   is not for this address table (because the job is in a job template),
{   then the value 1 must be returned for entry_point_index which will cause
{   the entry point table to be scanned from the beginning.

  PROCEDURE find_nearest_address_item
    (    address: pmt$segment_and_offset;
     VAR found: boolean;
     VAR address_item: pmt$address_item;
     VAR entry_point_index: pmt$number_of_debug_items);


    VAR
      temp: integer,
      addresses: ^pmt$address_items,
      nearest: pmt$number_of_debug_items,
      lower: pmt$number_of_debug_items,
      upper: pmt$number_of_debug_items,
      mid: pmt$number_of_debug_items;


    found := FALSE;
    IF v$debug_table_header^.number_of_addresses = 0 THEN
      RETURN;
    IFEND;

    addresses := #PTR (v$debug_table_header^.address_items, v$debug_table_segment^);
    lower := LOWERBOUND (addresses^);
    upper := UPPERBOUND (addresses^);
    nearest := lower;

  /find_nearest_address/
    WHILE (lower <= upper) DO
      temp := lower + upper;
      mid := temp DIV 2;
      IF (addresses^ [mid].segment_offset = address) THEN
        nearest := mid;
        EXIT /find_nearest_address/;
      ELSEIF (addresses^ [mid].segment_offset < address) THEN
        nearest := mid;
        lower := mid + 1;
      ELSE
        upper := mid - 1;
      IFEND;
    WHILEND /find_nearest_address/;

    IF (address >= addresses^ [nearest].segment_offset) AND
          ((address DIV 100000000(16)) = (addresses^ [nearest].segment_offset DIV 100000000(16))) THEN
      found := TRUE;
      address_item := addresses^ [nearest];
      IF v$debug_table_segment = ocv$debug_table_segment THEN
        entry_point_index := ocv$address_entry_points^ [nearest];
        IF entry_point_index > 0 THEN
          address_item.from_an_entry_point := TRUE;
        IFEND;
      ELSE
        entry_point_index := 1;
      IFEND;
    IFEND;

  PROCEND find_nearest_address_item;
?? OLDTITLE ??
?? NEWTITLE := 'find_section_item', EJECT ??

{ PURPOSE:
{   This routine finds the section containing the specified address.

  PROCEDURE find_section_item
    (    address: pmt$segment_and_offset;
         module_item: ^pmt$module_item;
     VAR found: boolean;
     VAR section_item: llt$section_ordinal);


    VAR
      i: llt$section_ordinal;


    found := FALSE;

    FOR i := 0 TO UPPERBOUND (module_item^.section_item) DO
      IF (address >= module_item^.section_item [i].address) AND
            (address < (module_item^.section_item [i].address + module_item^.section_item [i].length)) THEN

        found := TRUE;
        section_item := i;

        RETURN;
      IFEND;
    FOREND;


  PROCEND find_section_item;
?? OLDTITLE ??
?? NEWTITLE := 'match_entry_points_to_addresses', EJECT ??

{ PURPOSE:
{   Build a parallel table to the address table which gives the index of the
{   entry point that corresponds to the address.

  PROCEDURE match_entry_points_to_addresses;


    VAR
      temp: integer,
      address: pmt$segment_and_offset,
      addresses: ^pmt$address_items,
      entry_points: ^pmt$entry_point_items,
      i: pmt$number_of_debug_items,
      lower: pmt$number_of_debug_items,
      upper: pmt$number_of_debug_items,
      mid: pmt$number_of_debug_items;


    IF v$debug_table_header^.number_of_addresses = 0 THEN
      RETURN;
    IFEND;

    addresses := #PTR (v$debug_table_header^.address_items, v$debug_table_segment^);

    ALLOCATE ocv$address_entry_points: [1 .. UPPERBOUND (addresses^)] IN osv$mainframe_pageable_heap^;

    FOR i := 1 TO UPPERBOUND (addresses^) DO
      ocv$address_entry_points^ [i] := 0;
    FOREND;

    IF v$debug_table_header^.number_of_entry_points = 0 THEN
      RETURN;
    IFEND;

    entry_points := #PTR (v$debug_table_header^.entry_point_items, v$debug_table_segment^);

    FOR i := 1 TO UPPERBOUND (entry_points^) DO
      address := entry_points^ [i].address;
      lower := LOWERBOUND (addresses^);
      upper := UPPERBOUND (addresses^);

    /find_address_in_table/
      WHILE (lower <= upper) DO
        temp := lower + upper;
        mid := temp DIV 2;
        IF (addresses^ [mid].segment_offset = address) THEN
          ocv$address_entry_points^ [mid] := i;
          EXIT /find_address_in_table/;
        ELSEIF (addresses^ [mid].segment_offset < address) THEN
          lower := mid + 1;
        ELSE
          upper := mid - 1;
        IFEND;
      WHILEND /find_address_in_table/;

    FOREND;

  PROCEND match_entry_points_to_addresses;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$define_linker_debug_table', EJECT ??

{ PURPOSE:
{   This routine sets the debug table to the specified value.

  PROCEDURE [XDCL, #GATE] ocp$define_linker_debug_table
    (    sequence_pointer: ^SEQ ( * );
     VAR status: ost$status);



    VAR
      ignore_status: ost$status;


    status.normal := TRUE;

    IF sequence_pointer = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_eof_on_debug_file, c$system_debug_tables, status);
      RETURN;
    IFEND;

    v$debug_table_segment := sequence_pointer;
    RESET v$debug_table_segment;

    NEXT v$debug_table_header IN v$debug_table_segment;
    IF v$debug_table_header = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_eof_on_debug_file, c$system_debug_tables, status);
      RETURN;
    IFEND;

    IF v$debug_table_header^.version <> pmc$linker_debug_table_version THEN
      osp$set_status_abnormal ('OC', oce$e_invalid_debug_tbl_version, c$system_debug_tables, status);
      RETURN;
    IFEND;

    IF ocv$debug_table_header = NIL THEN
      ocv$debug_table_header := v$debug_table_header;
      ocv$debug_table_segment := v$debug_table_segment;
      match_entry_points_to_addresses;
    IFEND;


  PROCEND ocp$define_linker_debug_table;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$find_debug_address', EJECT ??

{ PURPOSE:
{   This routine returns the module name, section name, and offset within
{   the section for the specified address.

  PROCEDURE [XDCL, #GATE] ocp$find_debug_address
    (    segment: ost$segment;
         offset: ost$segment_offset;
     VAR found: boolean;
     VAR module_name: pmt$program_name;
     VAR section_name: pmt$program_name;
     VAR offset_in_section: ost$segment_offset;
     VAR status: ost$status);


    VAR
      address: pmt$segment_and_offset,
      address_item: pmt$address_item,
      entry_point_index: pmt$number_of_debug_items,
      entry_point_item: pmt$entry_point_item,
      module_item: ^pmt$module_item,
      section_item: llt$section_ordinal;


    status.normal := TRUE;
    found := FALSE;

    IF v$debug_table_header = NIL THEN
      IF ocv$debug_table_header = NIL THEN
        osp$set_status_condition (oce$e_debug_table_not_open, status);
        RETURN;
      IFEND;
      v$debug_table_header := ocv$debug_table_header;
      v$debug_table_segment := ocv$debug_table_segment;
    IFEND;

    address := (segment * 100000000(16)) + offset;
    find_nearest_address_item (address, found, address_item, entry_point_index);

    IF found THEN
      module_item := #PTR (address_item.module_item, v$debug_table_segment^);
      module_name := module_item^.identification.name;

      find_section_item (address, module_item, found, section_item);

      IF found THEN
        IF address_item.from_an_entry_point THEN
          find_entry_point_via_address (address_item.segment_offset, entry_point_index, entry_point_item);
          section_name := entry_point_item.name;
          offset_in_section := address - entry_point_item.address;
        ELSE
          determine_section_name (module_item^.section_item [section_item], section_name);
          offset_in_section := address - module_item^.section_item [section_item].address;
        IFEND;
      IFEND;
    IFEND;


  PROCEND ocp$find_debug_address;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$find_debug_entry_point', EJECT ??

{ PURPOSE:
{   This routine returns the address and the name of the containing
{   module for the specified entry point.

  PROCEDURE [XDCL, #GATE] ocp$find_debug_entry_point
    (    entry_point: pmt$program_name;
     VAR found: boolean;
     VAR module_name: pmt$program_name;
     VAR segment: ost$segment;
     VAR offset: ost$segment_offset;
     VAR status: ost$status);


    VAR
      entry_point_index: pmt$number_of_debug_items,
      entry_point_item: pmt$entry_point_item,
      module_item: ^pmt$module_item,
      address_item: pmt$address_item,
      module_found: boolean;


    status.normal := TRUE;
    found := FALSE;

    IF v$debug_table_header = NIL THEN
      IF ocv$debug_table_header = NIL THEN
        osp$set_status_condition (oce$e_debug_table_not_open, status);
        RETURN;
      IFEND;
      v$debug_table_header := ocv$debug_table_header;
      v$debug_table_segment := ocv$debug_table_segment;
    IFEND;

    find_entry_point_item (entry_point, found, entry_point_item);
    IF found THEN
      segment := entry_point_item.address DIV 100000000(16);
      offset := entry_point_item.address MOD 100000000(16);

      find_nearest_address_item (entry_point_item.address, module_found, address_item, entry_point_index);
      IF module_found THEN
        module_item := #PTR (address_item.module_item, v$debug_table_segment^);
        module_name := module_item^.identification.name;
      ELSE
        module_name := osc$null_name;
      IFEND;
    IFEND;


  PROCEND ocp$find_debug_entry_point;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$find_debug_module_item', EJECT ??

{ PURPOSE:
{   This routine returns the module information for the specified module.

  PROCEDURE [XDCL, #GATE] ocp$find_debug_module_item
    (    name: pmt$program_name;
         occurrence: pmt$number_of_debug_items;
     VAR found: boolean;
     VAR module_item: ^pmt$module_item;
     VAR status: ost$status);


    VAR
      i: pmt$number_of_debug_items,
      count: pmt$number_of_debug_items,
      item_pointer: ^ REL (pmt$adaptable_sequence) ^pmt$module_item;


    status.normal := TRUE;
    found := FALSE;

    IF v$debug_table_header = NIL THEN
      IF ocv$debug_table_header = NIL THEN
        osp$set_status_condition (oce$e_debug_table_not_open, status);
        RETURN;
      IFEND;
      v$debug_table_header := ocv$debug_table_header;
      v$debug_table_segment := ocv$debug_table_segment;
    IFEND;

    count := 0;

    item_pointer := ^v$debug_table_header^.first_module_address_table_item;

    FOR i := 1 TO v$debug_table_header^.number_of_modules DO
      module_item := #PTR (item_pointer^, v$debug_table_segment^);

      IF module_item^.identification.name = name THEN
        count := count + 1;
        IF count >= occurrence THEN
          found := TRUE;
          RETURN;
        IFEND;
      IFEND;

      item_pointer := ^module_item^.next_module;
    FOREND;


  PROCEND ocp$find_debug_module_item;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$get_debug_table_header', EJECT ??

{ PURPOSE:
{   This routine returns the header of the currently defined debug table.

  PROCEDURE [XDCL, #GATE] ocp$get_debug_table_header
    (VAR debug_table_header: ^pmt$linker_debug_table_header;
     VAR status: ost$status);


    IF v$debug_table_header = NIL THEN
      IF ocv$debug_table_header = NIL THEN
        osp$set_status_condition (oce$e_debug_table_not_open, status);
        RETURN;
      IFEND;
      v$debug_table_header := ocv$debug_table_header;
      v$debug_table_segment := ocv$debug_table_segment;
    IFEND;

    debug_table_header := v$debug_table_header;


  PROCEND ocp$get_debug_table_header;
?? OLDTITLE ??

MODEND ocm$process_linker_debug_tables;
*DECK DECK=OCM$PROCESS_LNKR_DBG_TBLS_OCU EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Code Utilities: Process Lnkr Dbg Tbls OCU' ??
MODULE ocm$process_lnkr_dbg_tbls_ocu;


{ PURPOSE:
{   This module contains the routines to open, search, and close a linker debug table.

{   **** ANY CHANGES HERE MUST ALSO CHANGE OCM$PROCESS_LINKER_DEBUG_TABLES IN OS ****

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oce$ve_linker_exceptions
?? POP ??
*copyc amp$get_segment_pointer
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition

  VAR
    osv$debug_table: [XREF] ^SEQ ( * );

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

*copyc pmt$linker_debug_table_header

  CONST
    c$in_code = TRUE,
    c$code_or_data = FALSE,
    c$maximum_debug_tables = 5,
    c$system_debug_tables = 'Running System';

  VAR
    v$current_debug_table: integer,
    v$debug_table_header: array [1 .. c$maximum_debug_tables] of ^pmt$linker_debug_table_header :=
          [REP c$maximum_debug_tables of NIL],
    v$debug_table_id: array [1 .. c$maximum_debug_tables] of amt$file_identifier,
    v$debug_table_segment: array [1 .. c$maximum_debug_tables] of ^SEQ ( * ),
    v$number_of_dt_in_use: 0 .. c$maximum_debug_tables := 0,
    v$address_entry_points: array [1 .. c$maximum_debug_tables] of ^array [1 .. * ] of
          pmt$number_of_debug_items,
    v$system_debug_table: array [1 .. c$maximum_debug_tables] of boolean;

?? OLDTITLE ??
?? NEWTITLE := 'determine_section_name', EJECT ??

{ PURPOSE:
{   Create a section name from the attributes if no name is present.

  PROCEDURE determine_section_name
    (    section_item: pmt$section_item;
     VAR section_name: pmt$program_name);


    IF (section_item.name <> osc$null_name) THEN
      section_name := section_item.name;
    ELSEIF (section_item.kind = llc$code_section) THEN
      section_name := 'CODE SECTION';
    ELSEIF (section_item.kind = llc$binding_section) THEN
      section_name := 'BINDING SECTION';
    ELSEIF (section_item.segment_access_control.read_privilege <> osc$non_readable) AND
          (section_item.segment_access_control.write_privilege <> osc$non_writable) THEN
      section_name := 'READ WRITE';
    ELSEIF (section_item.segment_access_control.read_privilege <> osc$non_readable) THEN
      section_name := 'READ ONLY';
    ELSE
      section_name := 'WORKING STORAGE';
    IFEND;


  PROCEND determine_section_name;
?? OLDTITLE ??
?? NEWTITLE := 'fetch_addresses', EJECT ??

{ PURPOSE:
{   Return a pointer to the address table.

  PROCEDURE [INLINE] fetch_addresses
    (    code_only: boolean;
         index: 1 .. c$maximum_debug_tables;
     VAR addresses: ^pmt$address_items);


    IF (v$debug_table_header [index]^.number_of_addresses = 0) THEN
      addresses := NIL;
      RETURN;
    IFEND;
    addresses := #PTR (v$debug_table_header [index]^.address_items, v$debug_table_segment [index]^);

  PROCEND fetch_addresses;
?? OLDTITLE ??
?? NEWTITLE := 'find_debug_address', EJECT ??

{ PURPOSE:
{   Return the entry point/module section closest to the specified address.

  PROCEDURE find_debug_address
    (    segment: ost$segment;
         offset: ost$segment_offset;
         code_only: boolean;
     VAR found: boolean;
     VAR module_name: pmt$program_name;
     VAR section_name: pmt$program_name;
     VAR offset_in_section: ost$segment_offset;
     VAR status: ost$status);


    VAR
      address: pmt$segment_and_offset,
      address_item: pmt$address_item,
      code_section: boolean,
      entry_point_item: pmt$entry_point_item,
      module_item: ^pmt$module_item,
      section_item: llt$section_ordinal;


    status.normal := TRUE;
    found := FALSE;

    IF v$number_of_dt_in_use = 0 THEN
      osp$set_status_condition (oce$e_debug_table_not_open, status);
      RETURN;
    IFEND;

    address := (segment * 100000000(16)) + offset;
    find_nearest_address_item (address, code_only, address_item, entry_point_item, found);

    IF found THEN
      module_item := #PTR (address_item.module_item, v$debug_table_segment [v$current_debug_table]^);
      module_name := module_item^.identification.name;

      find_section_item (address, module_item, found, section_item);

      IF found THEN
        code_section := (module_item^.section_item [section_item].kind = llc$code_section);
        IF NOT code_section AND code_only THEN
          found := FALSE;
          RETURN;
        IFEND;
        IF address_item.from_an_entry_point THEN
          section_name := entry_point_item.name;
          offset_in_section := address - entry_point_item.address;
        ELSE
          determine_section_name (module_item^.section_item [section_item], section_name);
          offset_in_section := address - module_item^.section_item [section_item].address;
        IFEND;
      IFEND;
    IFEND;


  PROCEND find_debug_address;
?? OLDTITLE ??
?? NEWTITLE := 'find_entry_point_item', EJECT ??

{ PURPOSE:
{   Scan the entry point list of the debug tables looking for the specified
{   entry point name.

  PROCEDURE find_entry_point_item
    (    entry_point_name: pmt$program_name;
     VAR found: boolean;
     VAR entry_point_item: pmt$entry_point_item;
     VAR debug_segment: ^SEQ ( * ));

    VAR
      temp: integer,
      entry_points: ^pmt$entry_point_items,
      j: integer,
      lower: pmt$number_of_debug_items,
      upper: pmt$number_of_debug_items,
      mid: pmt$number_of_debug_items;


    found := FALSE;

  /debug_table_loop/
    FOR j := 1 TO v$number_of_dt_in_use DO
      IF v$debug_table_header [j]^.number_of_entry_points = 0 THEN
        CYCLE /debug_table_loop/;
      IFEND;

      entry_points := #PTR (v$debug_table_header [j]^.entry_point_items, v$debug_table_segment [j]^);


      lower := LOWERBOUND (entry_points^);
      upper := UPPERBOUND (entry_points^);

      WHILE (NOT found) AND (lower <= upper) DO
        temp := lower + upper;
        mid := temp DIV 2;
        IF (entry_points^ [mid].name = entry_point_name) THEN
          entry_point_item := entry_points^ [mid];
          found := TRUE;
          debug_segment := v$debug_table_segment [j];
          RETURN;
        ELSEIF (entry_points^ [mid].name < entry_point_name) THEN
          lower := mid + 1;
        ELSE
          upper := mid - 1;
        IFEND;
      WHILEND;
    FOREND /debug_table_loop/;

  PROCEND find_entry_point_item;
?? OLDTITLE ??
?? NEWTITLE := 'find_nearest_address_item', EJECT ??

{ PURPOSE:
{   Search the address table for the item closest to but less then the given
{   address.

  PROCEDURE find_nearest_address_item
    (    address: pmt$segment_and_offset;
         code_only: boolean;
     VAR address_item: pmt$address_item;
     VAR entry_point_item: pmt$entry_point_item;
     VAR found: boolean);


    VAR
      temp: integer,
      addresses: ^pmt$address_items,
      entry_points: ^pmt$entry_point_items,
      j: integer,
      lower: pmt$number_of_debug_items,
      mid: pmt$number_of_debug_items,
      nearest: pmt$number_of_debug_items,
      upper: pmt$number_of_debug_items;


    FOR j := 1 TO v$number_of_dt_in_use DO
      fetch_addresses (code_only, j, addresses);
      IF addresses = NIL THEN
        found := FALSE;
        RETURN;
      IFEND;

      lower := LOWERBOUND (addresses^);
      upper := UPPERBOUND (addresses^);
      nearest := lower;

    /find_nearest_address/
      WHILE (lower <= upper) DO
        temp := lower + upper;
        mid := temp DIV 2;
        IF (addresses^ [mid].segment_offset = address) THEN
          nearest := mid;
          EXIT /find_nearest_address/;
        ELSEIF (addresses^ [mid].segment_offset < address) THEN
          nearest := mid;
          lower := mid + 1;
        ELSE
          upper := mid - 1;
        IFEND;
      WHILEND /find_nearest_address/;

      IF (address >= addresses^ [nearest].segment_offset) AND
            ((address DIV 100000000(16)) = (addresses^ [nearest].segment_offset DIV 100000000(16))) THEN
        found := TRUE;
        address_item := addresses^ [nearest];
        v$current_debug_table := j;
        IF v$address_entry_points [j]^ [nearest] > 0 THEN
          entry_points := #PTR (v$debug_table_header [j]^.entry_point_items, v$debug_table_segment [j]^);
          entry_point_item := entry_points^ [v$address_entry_points [j]^ [nearest]];
          address_item.from_an_entry_point := TRUE;
        IFEND;
        RETURN;
      IFEND;

    FOREND;

  PROCEND find_nearest_address_item;
?? OLDTITLE ??
?? NEWTITLE := 'find_nearest_and_next_addr_item', EJECT ??

{ PURPOSE:
{   Search the address table for the item closest to but less then the given
{   address and then locate the next item that is an entry point.

  PROCEDURE find_nearest_and_next_addr_item
    (    address: pmt$segment_and_offset;
         code_only: boolean;
     VAR address_item: pmt$address_item;
     VAR entry_point_item: pmt$entry_point_item;
     VAR found: boolean;
     VAR next_address_item: pmt$address_item;
     VAR next_entry_point_item: pmt$entry_point_item;
     VAR next_entry_point_found: boolean);


    VAR
      temp: integer,
      addresses: ^pmt$address_items,
      entry_points: ^pmt$entry_point_items,
      j: integer,
      next_index: integer,
      lower: pmt$number_of_debug_items,
      mid: pmt$number_of_debug_items,
      nearest: pmt$number_of_debug_items,
      upper: pmt$number_of_debug_items;


    next_entry_point_found := FALSE;

    FOR j := 1 TO v$number_of_dt_in_use DO
      fetch_addresses (code_only, j, addresses);
      IF addresses = NIL THEN
        found := FALSE;
        RETURN;
      IFEND;

      lower := LOWERBOUND (addresses^);
      upper := UPPERBOUND (addresses^);
      nearest := lower;

    /find_nearest_address/
      WHILE (lower <= upper) DO
        temp := lower + upper;
        mid := temp DIV 2;
        IF (addresses^ [mid].segment_offset = address) THEN
          nearest := mid;
          EXIT /find_nearest_address/;
        ELSEIF (addresses^ [mid].segment_offset < address) THEN
          nearest := mid;
          lower := mid + 1;
        ELSE
          upper := mid - 1;
        IFEND;
      WHILEND /find_nearest_address/;

      IF (address >= addresses^ [nearest].segment_offset) AND
            ((address DIV 100000000(16)) = (addresses^ [nearest].segment_offset DIV 100000000(16))) THEN
        found := TRUE;
        address_item := addresses^ [nearest];
        v$current_debug_table := j;
        IF v$address_entry_points [j]^ [nearest] > 0 THEN
          entry_points := #PTR (v$debug_table_header [j]^.entry_point_items, v$debug_table_segment [j]^);
          entry_point_item := entry_points^ [v$address_entry_points [j]^ [nearest]];
          address_item.from_an_entry_point := TRUE;
        IFEND;

        next_index  := nearest + 1;

      /find_next_address/
        WHILE (next_index <= UPPERBOUND (addresses^)) AND NOT next_entry_point_found DO

          IF (address < addresses^ [next_index].segment_offset) AND
                ((address DIV 100000000(16)) = (addresses^ [next_index].segment_offset DIV 100000000(16)))
                THEN
            IF v$address_entry_points [j]^ [next_index] > 0 THEN
              next_entry_point_found := TRUE;
              next_address_item := addresses^ [next_index];
              next_entry_point_item := entry_points^ [v$address_entry_points [j]^ [next_index]];
              next_address_item.from_an_entry_point := TRUE;
            ELSE
              next_index := next_index + 1;
            IFEND;
          ELSE
            RETURN;
          IFEND;
        WHILEND /find_next_address/;

        RETURN;
      IFEND;

    FOREND;

  PROCEND find_nearest_and_next_addr_item;
?? OLDTITLE ??
?? NEWTITLE := 'find_section_item', EJECT ??

{ PURPOSE:
{   Find the section of the module containing the specified address.

  PROCEDURE find_section_item
    (    address: pmt$segment_and_offset;
         module_item: ^pmt$module_item;
     VAR found: boolean;
     VAR section_item: llt$section_ordinal);


    VAR
      i: llt$section_ordinal;


    found := FALSE;

    FOR i := 0 TO UPPERBOUND (module_item^.section_item) DO
      IF (address >= module_item^.section_item [i].address) AND
            (address < (module_item^.section_item [i].address + module_item^.section_item [i].length)) THEN

        found := TRUE;
        section_item := i;

        RETURN;
      IFEND;
    FOREND;

  PROCEND find_section_item;
?? OLDTITLE ??
?? NEWTITLE := 'match_entry_points_to_addresses', EJECT ??

{ PURPOSE:
{   Build a parallel table to the address table which gives the index of the
{   entry point that corresponds to the address.

  PROCEDURE match_entry_points_to_addresses
    (    debug_table: 1 .. c$maximum_debug_tables);


    VAR
      temp: integer,
      address: pmt$segment_and_offset,
      addresses: ^pmt$address_items,
      entry_points: ^pmt$entry_point_items,
      i: pmt$number_of_debug_items,
      lower: pmt$number_of_debug_items,
      upper: pmt$number_of_debug_items,
      mid: pmt$number_of_debug_items;


    fetch_addresses (FALSE, debug_table, addresses);
    IF addresses = NIL THEN
      RETURN;
    IFEND;

    ALLOCATE v$address_entry_points [debug_table]: [1 .. UPPERBOUND (addresses^)];

    FOR i := 1 TO UPPERBOUND (addresses^) DO
      v$address_entry_points [debug_table]^ [i] := 0;
    FOREND;

    IF v$debug_table_header [debug_table]^.number_of_entry_points = 0 THEN
      RETURN;
    IFEND;

    entry_points := #PTR (v$debug_table_header [debug_table]^.
          entry_point_items, v$debug_table_segment [debug_table]^);

    FOR i := 1 TO UPPERBOUND (entry_points^) DO
      address := entry_points^ [i].address;
      lower := LOWERBOUND (addresses^);
      upper := UPPERBOUND (addresses^);

    /find_address_in_table/
      WHILE (lower <= upper) DO
        temp := lower + upper;
        mid := temp  DIV 2;

        IF (addresses^ [mid].segment_offset = address) THEN
          EXIT /find_address_in_table/;
        ELSEIF (addresses^ [mid].segment_offset < address) THEN
          lower := mid + 1;
        ELSE
          upper := mid - 1;
        IFEND;
      WHILEND /find_address_in_table/;
      v$address_entry_points [debug_table]^ [mid] := i;

    FOREND;

  PROCEND match_entry_points_to_addresses;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$close_linker_debug_table', EJECT ??

{ PURPOSE:
{   Close all the open linker debug tables and return any allocated memory.

  PROCEDURE [XDCL, #GATE] ocp$close_linker_debug_table
    (VAR status: ost$status);

    VAR
      j: integer;

    status.normal := TRUE;

    IF v$number_of_dt_in_use = 0 THEN
      osp$set_status_condition (oce$e_debug_table_not_open, status);
      RETURN;
    IFEND;

  /debug_table_loop/
    FOR j := 1 TO v$number_of_dt_in_use DO
      v$debug_table_header [j] := NIL;

      IF v$address_entry_points [j] <> NIL THEN
        FREE v$address_entry_points [j];
      IFEND;

      IF (v$system_debug_table [j]) THEN
        CYCLE /debug_table_loop/;
      IFEND;

      fsp$close_file (v$debug_table_id [j], status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND /debug_table_loop/;
    v$number_of_dt_in_use := 0

  PROCEND ocp$close_linker_debug_table;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$define_linker_debug_table', EJECT ??

{ PURPOSE:
{   Add the specified debug table to the list of tables.

  PROCEDURE [XDCL, #GATE] ocp$define_linker_debug_table
    (    sequence_pointer: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      ignore_status: ost$status;


    status.normal := TRUE;

    IF sequence_pointer = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_eof_on_debug_file, c$system_debug_tables, status);
      RETURN;
    IFEND;

    IF v$number_of_dt_in_use >= c$maximum_debug_tables THEN
      osp$set_status_abnormal ('OC', oce$e_generate_status, 'Maximum of 5 open debug tables allowed', status);
      RETURN;
    IFEND;

    v$number_of_dt_in_use := v$number_of_dt_in_use + 1;

    v$system_debug_table [v$number_of_dt_in_use] := TRUE;
    v$address_entry_points [v$number_of_dt_in_use] := NIL;

    v$debug_table_segment [v$number_of_dt_in_use] := sequence_pointer;
    RESET v$debug_table_segment [v$number_of_dt_in_use];

    NEXT v$debug_table_header [v$number_of_dt_in_use] IN v$debug_table_segment [v$number_of_dt_in_use];
    IF v$debug_table_header [v$number_of_dt_in_use] = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_eof_on_debug_file, c$system_debug_tables, status);
      v$number_of_dt_in_use := v$number_of_dt_in_use - 1;
      RETURN;
    IFEND;

    IF v$debug_table_header [v$number_of_dt_in_use]^.version <> pmc$linker_debug_table_version THEN
      v$debug_table_header [v$number_of_dt_in_use] := NIL;
      osp$set_status_abnormal ('OC', oce$e_invalid_debug_tbl_version, c$system_debug_tables, status);
      v$number_of_dt_in_use := v$number_of_dt_in_use - 1;
      RETURN;
    IFEND;

    match_entry_points_to_addresses (v$number_of_dt_in_use);


  PROCEND ocp$define_linker_debug_table;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$find_debug_address', EJECT ??

{ PURPOSE:
{   Return the entry point and offset from the entry point for an address.

  PROCEDURE [XDCL, #GATE] ocp$find_debug_address
    (    segment: ost$segment;
         offset: ost$segment_offset;
     VAR found: boolean;
     VAR module_name: pmt$program_name;
     VAR section_name: pmt$program_name;
     VAR offset_in_section: ost$segment_offset;
     VAR status: ost$status);


    status.normal := TRUE;

    find_debug_address (segment, offset, c$code_or_data, found, module_name, section_name, offset_in_section,
          status);

  PROCEND ocp$find_debug_address;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$find_debug_address_in_code', EJECT ??

{ PURPOSE:
{   Return the entry point and offset from the entry point for an address.
{   The entry point returned will be in a code section.

  PROCEDURE [XDCL, #GATE] ocp$find_debug_address_in_code
    (    segment: ost$segment;
         offset: ost$segment_offset;
     VAR found: boolean;
     VAR module_name: pmt$program_name;
     VAR section_name: pmt$program_name;
     VAR offset_in_section: ost$segment_offset;
     VAR status: ost$status);


    status.normal := TRUE;

    find_debug_address (segment, offset, c$in_code, found, module_name, section_name, offset_in_section,
          status);

  PROCEND ocp$find_debug_address_in_code;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$find_debug_entry_point', EJECT ??

{ PURPOSE:
{   Return the module, segment, and offset of an entry point.

  PROCEDURE [XDCL, #GATE] ocp$find_debug_entry_point
    (    entry_point: pmt$program_name;
     VAR found: boolean;
     VAR module_name: pmt$program_name;
     VAR segment: ost$segment;
     VAR offset: ost$segment_offset;
     VAR status: ost$status);


    VAR
      debug_segment: ^SEQ ( * ),
      entry_point_item: pmt$entry_point_item,
      module_item: ^pmt$module_item,
      address_item: pmt$address_item,
      module_found: boolean;


    status.normal := TRUE;
    found := FALSE;

    IF v$number_of_dt_in_use = 0 THEN
      osp$set_status_condition (oce$e_debug_table_not_open, status);
      RETURN;
    IFEND;

    find_entry_point_item (entry_point, found, entry_point_item, debug_segment);
    IF found THEN
      segment := entry_point_item.address DIV 100000000(16);
      offset := entry_point_item.address MOD 100000000(16);

      find_nearest_address_item (entry_point_item.address, FALSE, address_item, entry_point_item,
            module_found);
      IF module_found AND (entry_point_item.name = entry_point) THEN
        module_item := #PTR (address_item.module_item, debug_segment^);
        module_name := module_item^.identification.name;
      ELSE
        module_name := osc$null_name;
      IFEND;
    IFEND;


  PROCEND ocp$find_debug_entry_point;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$find_debug_entry_pt_length', EJECT ??

{ PURPOSE:
{   Return the module, segment, and offset of an entry point and calculate
{   the length of the procedure.

  PROCEDURE [XDCL, #GATE] ocp$find_debug_entry_pt_length
    (    entry_point: pmt$program_name;
     VAR entry_point_found: boolean;
     VAR module_name: pmt$program_name;
     VAR segment: ost$segment;
     VAR offset: ost$segment_offset;
     VAR procedure_length: ost$segment_length;
     VAR status: ost$status);


    VAR
      address_item: pmt$address_item,
      debug_segment: ^SEQ ( * ),
      entry_point_item: pmt$entry_point_item,
      index: integer,
      module_found: boolean,
      module_item: ^pmt$module_item,
      module_length: ost$segment_length,
      module_offset: ost$segment_offset,
      next_address_item: pmt$address_item,
      next_entry_point_found: boolean,
      next_entry_point_item: pmt$entry_point_item,
      next_offset: ost$segment_offset;

    status.normal := TRUE;
    entry_point_found := FALSE;

    IF v$number_of_dt_in_use = 0 THEN
      osp$set_status_condition (oce$e_debug_table_not_open, status);
      RETURN;
    IFEND;

    find_entry_point_item (entry_point, entry_point_found, entry_point_item, debug_segment);
    IF entry_point_found THEN
      segment := entry_point_item.address DIV 100000000(16);
      offset := entry_point_item.address MOD 100000000(16);

      find_nearest_and_next_addr_item (entry_point_item.address, FALSE, address_item, entry_point_item,
            module_found, next_address_item, next_entry_point_item, next_entry_point_found);
      IF module_found AND (entry_point_item.name = entry_point) THEN
        module_item := #PTR (address_item.module_item, debug_segment^);
        module_name := module_item^.identification.name;
        IF next_entry_point_found THEN
          next_offset := next_entry_point_item.address MOD 100000000(16);
          procedure_length := next_offset - offset;
        ELSE {entry_point was the last procedure in the module}
          FOR index := 0 TO UPPERBOUND (module_item^.section_item) DO
            IF (module_item^.section_item [index].kind = llc$code_section) THEN
              module_offset := module_item^.section_item [index].address MOD 100000000(16);
              module_length := module_item^.section_item [index].length;
              IF (offset >= module_offset) AND (offset <= module_offset + module_length - 1) THEN
                procedure_length := module_offset + module_length - offset;
                RETURN;
              IFEND;
            IFEND;
          FOREND;
{  Procedure length was not established.
          entry_point_found := FALSE;
        IFEND;
      ELSE
      IFEND;
    IFEND;

  PROCEND ocp$find_debug_entry_pt_length;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$find_debug_module_item', EJECT ??

{ PURPOSE:
{   Return the module information on the nth occurrance of the module
{   in the debug tables.

  PROCEDURE [XDCL, #GATE] ocp$find_debug_module_item
    (    name: pmt$program_name;
         occurrence: pmt$number_of_debug_items;
     VAR found: boolean;
     VAR module_item: ^pmt$module_item;
     VAR status: ost$status);


    VAR
      i: pmt$number_of_debug_items,
      j: integer,
      count: pmt$number_of_debug_items,
      item_pointer: ^ REL (pmt$adaptable_sequence) ^pmt$module_item;


    status.normal := TRUE;
    found := FALSE;

    IF v$number_of_dt_in_use = 0 THEN
      osp$set_status_condition (oce$e_debug_table_not_open, status);
      RETURN;
    IFEND;


    count := 0;
    FOR j := 1 TO v$number_of_dt_in_use DO
      item_pointer := ^v$debug_table_header [j]^.first_module_address_table_item;

      FOR i := 1 TO v$debug_table_header [j]^.number_of_modules DO
        module_item := #PTR (item_pointer^, v$debug_table_segment [j]^);

        IF module_item^.identification.name = name THEN
          count := count + 1;
          IF count >= occurrence THEN
            found := TRUE;
            RETURN;
          IFEND;
        IFEND;

        item_pointer := ^module_item^.next_module;
      FOREND;
    FOREND;

  PROCEND ocp$find_debug_module_item;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$get_debug_table_header', EJECT ??

{ PURPOSE:
{   Return the debug table header.

  PROCEDURE [XDCL, #GATE] ocp$get_debug_table_header
    (VAR debug_table_header: ^pmt$linker_debug_table_header;
     VAR status: ost$status);


    status.normal := TRUE;

    IF v$number_of_dt_in_use = 0 THEN
      osp$set_status_condition (oce$e_debug_table_not_open, status);
    ELSE
      debug_table_header := v$debug_table_header [v$number_of_dt_in_use];
    IFEND;

  PROCEND ocp$get_debug_table_header;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$open_linker_debug_table', EJECT ??

{ PURPOSE:
{   Open a debug table on a file.

  PROCEDURE [XDCL, #GATE] ocp$open_linker_debug_table
    (    debug_file_name: fst$file_reference;
     VAR status: ost$status);


    VAR
      ignore_status: ost$status,
      segment_pointer: amt$segment_pointer,
      read_attributes: [STATIC] array [1 .. 1] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes, $fst$file_access_options [fsc$read]],
            [fsc$specific_share_modes, $fst$file_access_options [fsc$read, fsc$execute]]]];


    status.normal := TRUE;

    IF v$number_of_dt_in_use >= c$maximum_debug_tables THEN
      osp$set_status_abnormal ('OC', oce$e_generate_status, 'Maximum of 5 open debug tables allowed', status);
      RETURN;
    IFEND;

    v$number_of_dt_in_use := v$number_of_dt_in_use + 1;
    v$system_debug_table [v$number_of_dt_in_use] := FALSE;
    v$address_entry_points [v$number_of_dt_in_use] := NIL;

    fsp$open_file (debug_file_name, amc$segment, ^read_attributes, NIL, NIL, NIL, NIL,
          v$debug_table_id [v$number_of_dt_in_use], status);
    IF NOT status.normal THEN
      v$number_of_dt_in_use := v$number_of_dt_in_use - 1;
      RETURN;
    IFEND;

    amp$get_segment_pointer (v$debug_table_id [v$number_of_dt_in_use], amc$sequence_pointer, segment_pointer,
          status);
    IF NOT status.normal THEN
      v$number_of_dt_in_use := v$number_of_dt_in_use - 1;
      RETURN;
    IFEND;

    v$debug_table_segment [v$number_of_dt_in_use] := segment_pointer.sequence_pointer;
    RESET v$debug_table_segment [v$number_of_dt_in_use];

    NEXT v$debug_table_header [v$number_of_dt_in_use] IN v$debug_table_segment [v$number_of_dt_in_use];
    IF v$debug_table_header [v$number_of_dt_in_use] = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_eof_on_debug_file, debug_file_name, status);
      v$number_of_dt_in_use := v$number_of_dt_in_use - 1;
      RETURN;
    IFEND;

    IF v$debug_table_header [v$number_of_dt_in_use]^.version <> pmc$linker_debug_table_version THEN
      v$debug_table_header [v$number_of_dt_in_use] := NIL;
      osp$set_status_abnormal ('OC', oce$e_invalid_debug_tbl_version, debug_file_name, status);
      v$number_of_dt_in_use := v$number_of_dt_in_use - 1;
      RETURN;
    IFEND;

    match_entry_points_to_addresses (v$number_of_dt_in_use);

  PROCEND ocp$open_linker_debug_table;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$open_running_debug_table', EJECT ??

{ PURPOSE:
{   Open the debug table for the running system.

  PROCEDURE [XDCL, #GATE] ocp$open_running_debug_table
    (VAR status: ost$status);


    status.normal := TRUE;

    ocp$define_linker_debug_table (osv$debug_table, status);

  PROCEND ocp$open_running_debug_table;
?? OLDTITLE ??

MODEND ocm$process_lnkr_dbg_tbls_ocu;

*DECK DECK=OCM$PROCESS_MESSAGE_DICTIONARY EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$process_message_dictionary;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc llt$section_address
*copyc llt$message_module_dictionary
*copyc llt$library_member_header
*copyc oct$offset_change_list
*copyc ocp$new_global_offset
?? POP ??

*copyc och$process_message_dictionary

  PROCEDURE [XDCL] ocp$process_message_dictionary (message_dictionary: ^llt$message_module_dictionary;
        mod_dictionary_ocv: ^oct$offset_change_list;
        int_ol: ^SEQ ( * ));

    VAR
      library_member_header: record
        case boolean of
        = TRUE =
          pointer: ^llt$library_member_header,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      i: llt$module_index,
      new_offset: llt$section_address_range;

    FOR i := 1 TO UPPERBOUND (message_dictionary^) DO
      library_member_header.pointer := #PTR (message_dictionary^ [i].message_header, int_ol^);
      new_offset := ocp$new_global_offset (#offset (library_member_header.pointer), mod_dictionary_ocv);
      library_member_header.pva := #address (#ring (library_member_header.pointer), #segment
            (library_member_header.pointer), new_offset);
      message_dictionary^ [i].message_header := #REL (library_member_header.pointer, int_ol^);
    FOREND;
  PROCEND ocp$process_message_dictionary;
MODEND ocm$process_message_dictionary;
*DECK DECK=OCM$PROCESS_MODULE_DICTIONARY EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$process_module_dictionary;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc oce$metapatch_generator_errors
*copyc llt$section_address
*copyc llt$module_dictionary
*copyc llt$load_module_header
*copyc llt$object_text_descriptor
*copyc llt$library_member_header
*copyc oct$offset_change_list
*copyc ocp$new_global_offset
*copyc osp$set_status_abnormal
?? POP ??

*copyc och$process_module_dictionary

  PROCEDURE [XDCL] ocp$process_module_dictionary (module_dictionary: ^llt$module_dictionary;
        mod_dictionary_ocv: ^oct$offset_change_list;
        int_ol: ^SEQ ( * );
    VAR status: ost$status);

    VAR
      module_header: record
        case boolean of
        = TRUE =
          pointer: ^llt$load_module_header,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      ppu_header: record
        case boolean of
        = TRUE =
          pointer: ^llt$object_text_descriptor,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      library_member_header: record
        case boolean of
        = TRUE =
          pointer: ^llt$library_member_header,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      application_member_header: record
        case boolean of
        = TRUE =
          pointer: ^llt$application_member_header,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      i: llt$module_index,
      length: integer,
      message: string (100),
      new_offset: llt$section_address_range;

    FOR i := 1 TO UPPERBOUND (module_dictionary^) DO
      CASE module_dictionary^ [i].kind OF
      = llc$load_module =
        module_header.pointer := #PTR (module_dictionary^ [i].module_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (module_header.pointer), mod_dictionary_ocv);
        module_header.pva := #address (#ring (module_header.pointer), #segment (module_header.pointer),
              new_offset);
        module_dictionary^ [i].module_header := #REL (module_header.pointer, int_ol^);
      = llc$ppu_object_module =
        ppu_header.pointer := #PTR (module_dictionary^ [i].ppu_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (ppu_header.pointer), mod_dictionary_ocv);
        ppu_header.pva := #address (#ring (ppu_header.pointer), #segment (ppu_header.pointer), new_offset);
        module_dictionary^ [i].ppu_header := #REL (ppu_header.pointer, int_ol^);
      = llc$program_description =
        library_member_header.pointer := #PTR (module_dictionary^ [i].program_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (library_member_header.pointer), mod_dictionary_ocv);
        library_member_header.pva := #address (#ring (library_member_header.pointer), #segment
              (library_member_header.pointer), new_offset);
        module_dictionary^ [i].program_header := #REL (library_member_header.pointer, int_ol^);
      = llc$command_procedure =
        library_member_header.pointer := #PTR (module_dictionary^ [i].command_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (library_member_header.pointer), mod_dictionary_ocv);
        library_member_header.pva := #address (#ring (library_member_header.pointer), #segment
              (library_member_header.pointer), new_offset);
        module_dictionary^ [i].command_header := #REL (library_member_header.pointer, int_ol^);
      = llc$command_description =
        library_member_header.pointer := #PTR (module_dictionary^ [i].command_description_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (library_member_header.pointer), mod_dictionary_ocv);
        library_member_header.pva := #address (#ring (library_member_header.pointer), #segment
              (library_member_header.pointer), new_offset);
        module_dictionary^ [i].command_description_header := #REL (library_member_header.pointer, int_ol^);
      = llc$function_procedure =
        library_member_header.pointer := #PTR (module_dictionary^ [i].function_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (library_member_header.pointer), mod_dictionary_ocv);
        library_member_header.pva := #address (#ring (library_member_header.pointer), #segment
              (library_member_header.pointer), new_offset);
        module_dictionary^ [i].function_header := #REL (library_member_header.pointer, int_ol^);
      = llc$function_description =
        library_member_header.pointer := #PTR (module_dictionary^ [i].function_description_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (library_member_header.pointer), mod_dictionary_ocv);
        library_member_header.pva := #address (#ring (library_member_header.pointer), #segment
              (library_member_header.pointer), new_offset);
        module_dictionary^ [i].function_description_header := #REL (library_member_header.pointer, int_ol^);
      = llc$message_module =
        library_member_header.pointer := #PTR (module_dictionary^ [i].message_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (library_member_header.pointer), mod_dictionary_ocv);
        library_member_header.pva := #address (#ring (library_member_header.pointer), #segment
              (library_member_header.pointer), new_offset);
        module_dictionary^ [i].message_header := #REL (library_member_header.pointer, int_ol^);
      = llc$panel_module =
        library_member_header.pointer := #PTR (module_dictionary^ [i].panel_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (library_member_header.pointer), mod_dictionary_ocv);
        library_member_header.pva := #address (#ring (library_member_header.pointer), #segment
              (library_member_header.pointer), new_offset);
        module_dictionary^ [i].panel_header := #REL (library_member_header.pointer, int_ol^);
      = llc$applic_program_description =
        application_member_header.pointer := #PTR (module_dictionary^ [i].applic_program_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (application_member_header.pointer), mod_dictionary_ocv);
        application_member_header.pva := #address (#ring (application_member_header.pointer), #segment
              (application_member_header.pointer), new_offset);
        module_dictionary^ [i].applic_program_header := #REL (application_member_header.pointer, int_ol^);
      = llc$applic_command_procedure =
        application_member_header.pointer := #PTR (module_dictionary^ [i].applic_command_header, int_ol^);
        new_offset := ocp$new_global_offset (#offset (application_member_header.pointer), mod_dictionary_ocv);
        application_member_header.pva := #address (#ring (application_member_header.pointer), #segment
              (application_member_header.pointer), new_offset);
        module_dictionary^ [i].applic_command_header := #REL (application_member_header.pointer, int_ol^);
      = llc$applic_command_description =
        application_member_header.pointer := #PTR (module_dictionary^ [i].applic_command_description_hdr,
              int_ol^);
        new_offset := ocp$new_global_offset (#offset (application_member_header.pointer), mod_dictionary_ocv);
        application_member_header.pva := #address (#ring (application_member_header.pointer), #segment
              (application_member_header.pointer), new_offset);
        module_dictionary^ [i].applic_command_description_hdr := #REL (application_member_header.pointer,
              int_ol^);
      ELSE
        STRINGREP (message, length, module_dictionary^ [i].kind);
        osp$set_status_abnormal (occ$status_id, oce$unexpected_record_kind, message (1, length), status);
        RETURN;
      CASEND;
    FOREND;
  PROCEND ocp$process_module_dictionary;
MODEND ocm$process_module_dictionary;
*DECK DECK=OCM$PROCESS_PANEL_DICTIONARY EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$process_panel_dictionary;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc llt$section_address
*copyc llt$panel_dictionary
*copyc llt$library_member_header
*copyc oct$offset_change_list
*copyc ocp$new_global_offset
?? POP ??

*copyc och$process_panel_dictionary

  PROCEDURE [XDCL] ocp$process_panel_dictionary (panel_dictionary: ^llt$panel_dictionary;
        mod_dictionary_ocv: ^oct$offset_change_list;
        int_ol: ^SEQ ( * ));

    VAR
      library_member_header: record
        case boolean of
        = TRUE =
          pointer: ^llt$library_member_header,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      i: llt$module_index,
      new_offset: llt$section_address_range;

    FOR i := 1 TO UPPERBOUND (panel_dictionary^) DO
      library_member_header.pointer := #PTR (panel_dictionary^ [i].panel_header, int_ol^);
      new_offset := ocp$new_global_offset (#offset (library_member_header.pointer), mod_dictionary_ocv);
      library_member_header.pva := #address (#ring (library_member_header.pointer), #segment
            (library_member_header.pointer), new_offset);
      panel_dictionary^ [i].panel_header := #REL (library_member_header.pointer, int_ol^);
    FOREND;
  PROCEND ocp$process_panel_dictionary;
MODEND ocm$process_panel_dictionary;
*DECK DECK=OCM$PROCESS_REL_RECORDS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$process_rel_records;
*copyc osd$default_pragmats
*copyc ost$status
*copyc oct$code_section_directory
*copyc oct$section_directory
*copyc llt$object_text_descriptor
*copyc llt$relocation
?? PUSH (LISTEXT := ON) ??
*copyc ocp$new_offset
*copyc ocp$normalize_binding_sec_value
?? POP ??

*copyc och$process_rel_records
  PROCEDURE [XDCL] ocp$process_rel_records (section_directory: ^oct$section_directory;
        relocation: ^llt$relocation;
        number_of_rel_items: 0 .. llc$max_rel_items;
        code_section_directory: oct$code_directory_item;
        module_code_sections: ^oct$module_code_sections;
    VAR status: ost$status);

    VAR
      i: 0 .. llc$max_rel_items;

    FOR i := 1 TO number_of_rel_items DO
      ocp$normalize_binding_sec_value (code_section_directory, module_code_sections, relocation^ [i],
            section_directory, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      relocation^ [i].offset := ocp$new_offset (relocation^ [i].offset, section_directory^ [relocation^ [i].
            section_ordinal].section_offset_change_vector);
      relocation^ [i].section_ordinal := section_directory^ [relocation^ [i].section_ordinal].
            new_section_number;
    FOREND;
  PROCEND ocp$process_rel_records;
MODEND ocm$process_rel_records;

*DECK DECK=OCM$PROCESS_SECTIONS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$process_sections;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc llt$object_text_descriptor
*copyc llt$section_definition
*copyc llt$obsolete_segment_definition
*copyc llt$segment_definition
*copyc llt$text
*copyc llt$replication
*copyc llt$bit_string_insertion
*copyc llt$address_formulation
*copyc oct$section_directory
*copyc oct$offset_change_list
*copyc ocp$new_global_offset
*copyc ocp$new_offset
?? POP ??

*copyc och$process_sections

  PROCEDURE [XDCL] ocp$process_sections (p_int_ol: ^SEQ ( * );
        section_defs: ^llt$object_text_descriptor;
        section_directory: ^oct$section_directory;
        mod_dictionary_ocv: ^oct$offset_change_list);

    VAR
      address_formulation: ^llt$address_formulation,
      bit_string_insertion: ^llt$bit_string_insertion,
      i: 1 .. llc$max_adr_items,
      int_ol: ^SEQ ( * ),
      new_offset: ost$relative_pointer,
      object_text_descriptor: ^llt$object_text_descriptor,
      obsolete_segment_definition: ^llt$obsolete_segment_definition,
      replication: ^llt$replication,
      section_definition: ^llt$section_definition,
      segment_definition: ^llt$segment_definition,
      sections_all_processed: boolean,
      text: ^llt$text;

    int_ol := p_int_ol;

    sections_all_processed := FALSE;
    RESET int_ol TO section_defs;
    REPEAT
      NEXT object_text_descriptor IN int_ol;
      CASE object_text_descriptor^.kind OF

      = llc$allotted_section_definition =
        object_text_descriptor^.allotted_section := ocp$new_global_offset (object_text_descriptor^.
              allotted_section, mod_dictionary_ocv);
        NEXT section_definition IN int_ol;
        section_definition^.section_ordinal := section_directory^ [section_definition^.section_ordinal].
              new_section_number;

      = llc$section_definition, llc$unallocated_common_block =
        NEXT section_definition IN int_ol;
        section_definition^.section_ordinal := section_directory^ [section_definition^.section_ordinal].
              new_section_number;

      = llc$obsolete_allotted_seg_def =
        object_text_descriptor^.allotted_segment := ocp$new_global_offset (object_text_descriptor^.
              allotted_segment, mod_dictionary_ocv);
        NEXT obsolete_segment_definition IN int_ol;
        obsolete_segment_definition^.section_definition.section_ordinal := section_directory^ [
              obsolete_segment_definition^.section_definition.section_ordinal].new_section_number;

      = llc$obsolete_segment_definition =
        NEXT obsolete_segment_definition IN int_ol;
        obsolete_segment_definition^.section_definition.section_ordinal := section_directory^ [
              obsolete_segment_definition^.section_definition.section_ordinal].new_section_number;

      = llc$allotted_segment_definition =
        object_text_descriptor^.allotted_segment := ocp$new_global_offset (object_text_descriptor^.
              allotted_segment, mod_dictionary_ocv);
        NEXT segment_definition IN int_ol;
        segment_definition^.section_definition.section_ordinal := section_directory^ [segment_definition^.
              section_definition.section_ordinal].new_section_number;

      = llc$segment_definition =
        NEXT segment_definition IN int_ol;
        segment_definition^.section_definition.section_ordinal := section_directory^ [segment_definition^.
              section_definition.section_ordinal].new_section_number;

      = llc$text =
        NEXT text: [1 .. object_text_descriptor^.number_of_bytes] IN int_ol;
        text^.offset := ocp$new_offset (text^.offset, section_directory^ [text^.section_ordinal].
              section_offset_change_vector);
        text^.section_ordinal := section_directory^ [text^.section_ordinal].new_section_number;

      = llc$replication =
        NEXT replication: [1 .. object_text_descriptor^.number_of_bytes] IN int_ol;
        replication^.offset := ocp$new_offset (replication^.offset, section_directory^ [replication^.
              section_ordinal].section_offset_change_vector);
        replication^.section_ordinal := section_directory^ [replication^.section_ordinal].new_section_number;

      = llc$bit_string_insertion =
        NEXT bit_string_insertion IN int_ol;
        bit_string_insertion^.offset := ocp$new_offset (bit_string_insertion^.offset, section_directory^
              [bit_string_insertion^.section_ordinal].section_offset_change_vector);
        bit_string_insertion^.section_ordinal := section_directory^ [bit_string_insertion^.section_ordinal].
              new_section_number;

      = llc$address_formulation =
        NEXT address_formulation: [1 .. object_text_descriptor^.number_of_adr_items] IN int_ol;
        FOR i := 1 TO object_text_descriptor^.number_of_adr_items DO
          address_formulation^.item [i].value_offset := ocp$new_offset (address_formulation^.item [i].
                value_offset, section_directory^ [address_formulation^.value_section].
                section_offset_change_vector);
          address_formulation^.item [i].dest_offset := ocp$new_offset (address_formulation^.item [i].
                dest_offset, section_directory^ [address_formulation^.dest_section].
                section_offset_change_vector);
        FOREND;
        address_formulation^.value_section := section_directory^ [address_formulation^.value_section].
              new_section_number;
        address_formulation^.dest_section := section_directory^ [address_formulation^.dest_section].
              new_section_number;

      ELSE
        sections_all_processed := TRUE;
      CASEND;
    UNTIL sections_all_processed;
  PROCEND ocp$process_sections;
MODEND ocm$process_sections;
*DECK DECK=OCM$PROCESS_SECTION_MAPS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$process_section_maps;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc llt$section_address
*copyc llt$information_element
*copyc oct$single_module_predictor_hdr
*copyc oct$section_directory
*copyc oct$offset_change_list
*copyc ocp$new_offset
*copyc ocp$new_global_offset
?? POP ??

*copyc och$process_section_maps

  PROCEDURE [XDCL] ocp$process_section_maps (section_directory: ^oct$section_directory;
        mod_dictionary_ocv: ^oct$offset_change_list;
        section_maps: ^llt$section_maps;
        number_of_section_maps: llt$number_of_sections;
        intermediate_ol: ^SEQ ( * );
        p_module_predictor: ^SEQ ( * ));

    VAR
      new_map: record
        case boolean of
        = TRUE =
          pointer: ^llt$section_map_items,
        = FALSE =
          pva: ^cell,
        casend,
      recend,

      component_index_cv: ^array [1 .. * ] of 0 .. llc$max_components,
      j: llt$number_of_sections,
      module_predictor: ^SEQ ( * ),
      module_predictor_header: ^oct$single_module_predictor_hdr,
      new_offset: llt$section_address_range,
      section_ordinal: llt$number_of_sections;

    module_predictor := p_module_predictor;

    RESET module_predictor;
    NEXT module_predictor_header IN module_predictor;
    IF module_predictor_header^.length_component_index_cv > 0 THEN
      component_index_cv := #PTR (module_predictor_header^.component_index_cv, module_predictor^);
    ELSE
      component_index_cv := NIL;
    IFEND;
    FOR section_ordinal := 0 TO (number_of_section_maps - 1) DO
      new_map.pointer := #PTR (section_maps^ [section_ordinal].map, intermediate_ol^);
      FOR j := 1 TO section_maps^ [section_ordinal].number_of_items DO
        new_map.pointer^ [j].offset := ocp$new_offset (new_map.pointer^ [j].offset, section_directory^
              [section_ordinal].section_offset_change_vector);
        new_map.pointer^ [j].component := component_index_cv^ [new_map.pointer^ [j].component];
      FOREND;
      new_offset := ocp$new_global_offset (#offset (new_map.pointer), mod_dictionary_ocv);
      new_map.pva := #address (#ring (intermediate_ol), #segment (intermediate_ol), new_offset);
      section_maps^ [section_ordinal].map := #REL (new_map.pointer, intermediate_ol^);
    FOREND;
  PROCEND ocp$process_section_maps;
MODEND ocm$process_section_maps;
*DECK DECK=OCM$PRODUCT_REFERENCE_UTILITY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Object Code Utilities : Product Reference Utility' ??
MODULE ocm$product_reference_utility;

{ PURPOSE:
{   This module contains the command and subcommands for the NOS/VE Product
{ Reference Utility.  The utility is used as an aid to insure and verify
{ compatibility of software.
{
{ NOTES:
{   This utility is a standalone utility outside of the operating system.  It is
{ available to all users.
{
{   This utility runs in the caller's ring.
{
{   A reference file is composed of a header that describes the version of the
{ file and the number of entry point and external reference definitions in the
{ file.  The header is followed by the entry point definitions which is followed
{ by the external reference definitions.
{
{   This utility uses the concept of a working file.  The file is empty at the
{ start of the utility and "add" commands are used to augment the working file.
{ The other utility commands and the utility functions use the working file
{ as the basis for their information.  The working file is internally represented
{ as two files, one that contains entry point definitions and another that
{ contains external reference definitions.  Externally, the two files "appear"
{ as a single reference file.  Using multiple files for the internal
{ representation is for performance reasons only.
{
{   Unlike the CREATE_OBJECT_LIBRARY utility, the "add" commands do not leave
{ the file open.  The command performs a function against the working file and
{ closes the file(s) as part of command completion.
{
{   For performance reasons, a list of modules and products referenced by the
{ working reference file is maintained.  This is primarily necessary for the
{ functions that return lists of these values.  The list of modules and products
{ is maintained via binary insertion.  The expected number of unique values in
{ these lists is expected to be relatively small.  The most important thing in
{ maintaining this lists is that searching (binary search) must be optimal.
{ Searching frequency is expected to be done one to two orders of magnitude
{ over the frequency of insertion.  If these assumptions turn out to be invalid
{ a balanced tree structure would seem to be a viable alternative, to improve
{ insertion overhead, but as a result, searching overhead becomes very slightly
{ more expensive.  (Knuth knows.)
{
{   Due to duplicate language identifiers for the CYBIL I/M and CYBIL I/I
{ compilers, and that CDCNET has reused NOS/VE product identifiers and duplicated
{ interface names, M68000 modules are not supported by this utility.  If the
{ need arises (there is no defined usefulness for this right now) several things
{ must be considered.  The CYBIL I/I compiler generates both an object and source
{ hash, the CYBIL I/M compiler does not.  The duplication of CDCNET and NOS/VE
{ interfaces, e.g. osp$set_status_abnormal, must be resolved or worked around.
{
{   The routines used to crack an object library are a stripped down version of
{ the routines used for the display_object_text command.
{
{   In the procedure ocp$_add_library, there are several reference to fatal_error
{ and end_of_file.  Currently, these variables are handled the same.  The type of
{ error is not reported.  I have chosen, to leave them here since performance is
{ not largely affected.  Since there is a good likely-hood that the type of error
{ encountered should someday be reported, these variables have been retained.
{
{   There are several small procedures that are NOT INLINE because they PUSH data
{ on the stack and are called within loops.

?? NEWTITLE := 'Global Declarations Referenced By This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc cyd$cybil_structure_definitions
*copyc cyd$debug_symbol_table
*copyc llt$deferred_common_blocks
*copyc llt$deferred_entry_points
*copyc llt$load_module
*copyc llt$object_library
*copyc llt$object_module
*copyc lot$task_services_entry_point
*copyc oce$interrupt_exceptions
*copyc oce$object_converter_exceptions
*copyc oce$rm_builder_exceptions
*copyc oce$ve_linker_exceptions
*copyc oct$task_services_entry_point
*copyc osd$integer_limits
*copyc ost$status
*copyc pmt$linker_debug_table_header
*copyc pmt$virtual_memory_image_header
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc amp$set_segment_eoi
*copyc clp$build_pattern_for_wild_card
*copyc clp$begin_utility
*copyc clp$build_standard_title
*copyc clp$change_variable
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_file
*copyc clp$count_list_elements
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc clp$make_list_value
*copyc clp$make_name_value
*copyc clp$make_program_name_value
*copyc clp$make_record_value
*copyc clp$match_string_pattern
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc clp$trimmed_string_size
*copyc fsp$build_file_ref_from_elems
*copyc fsp$close_file
*copyc fsp$get_open_information
*copyc fsp$open_file
*copyc i#current_sequence_position
*copyc i#move
*copyc mmp$create_user_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$establish_condition_handler
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$format_message
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$log
*copyc pmp$position_object_library
*copyc clv$value_descriptors
*copyc osv$lower_to_upper
*copyc osv$lower_to_upper_26
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared By This Module', EJECT ??

*copy clv$display_variables

  SECTION
    read_only: READ;

  TYPE
    module_kind_set = set of llt$module_kind;

{ For now, only allow C180 CPU code.  See module NOTES section for more information.

  VAR
    valid_module_kinds: module_kind_set := [llc$mi_virtual_state, llc$vector_virtual_state,
          llc$vector_extended_state];

  TYPE
    t$entry_external_file_header = record
      identification: ost$name,
      entry_point_count: ost$non_negative_integers,
      external_count: ost$non_negative_integers,
    recend;

  TYPE
    t$entry_external_files = array [1 .. * ] of t$entry_external_file_element;

  TYPE
    t$entry_external_file_element = record
      entry_point_list_p: ^t$entry_external_list,
      external_list_p: ^t$entry_external_list,
    recend;

  CONST
    c$entry_external_id = 'PRODUCT REFERENCE FILE V1.0';

  TYPE
    t$entry_external_list = array [1 .. * ] of t$entry_external;

  TYPE
    t$entry_external = record
      name: pmt$program_name,
      language: llt$module_generator,
      declaration_matching_required: boolean,
      declaration_matching: llt$declaration_matching_value,
      product_name: ost$name,
      module_name: pmt$program_name,
      attributes: llt$entry_point_attributes,
    recend;

{ This constant represents the size of the type t$entry_external

  CONST
    c$entry_external_record_size = 104; { in bytes

  TYPE
    t$comparison_converter = record
      case boolean of
      = TRUE =
        entry_external_p: ^t$entry_external,
      = FALSE =
        value_p: ^string (c$entry_external_record_size),
      casend,
    recend;

  TYPE
    t$reference_kind = (c$rk_entry_point, c$rk_external);

  VAR
    v$working_file: [STATIC] record
      entry_points_p: ^SEQ ( * ),
      externals_p: ^SEQ ( * ),
    recend := [NIL, NIL];

  VAR
    v$module_list: [STATIC] array [t$reference_kind] of record
      element_count: ost$non_negative_integers,
      elements_p: ^array [1 .. * ] of clt$data_value,
    recend := [[0, NIL], [0, NIL]];

  VAR
    v$product_list: [STATIC] array [t$reference_kind] of record
      element_count: ost$non_negative_integers,
      elements_p: ^array [1 .. * ] of clt$data_value,
    recend := [[0, NIL], [0, NIL]];

  CONST
    c$utility_prompt = 'PRU';

  VAR
    c$utility_name: [STATIC, READ, read_only] clt$utility_name := 'product_reference_utility';

  VAR
    v$display_control: clt$display_control,
    v$output_file_open: [STATIC] boolean := FALSE;

?? OLDTITLE ??
?? NEWTITLE := 'Commands for the Product_Reference_Utility', EJECT ??

{ table name=proru_commands type=command section_name=read_only scope=local
{ command (add_library                    , add_libraries, addl) p=ocp$_add_library cm=local
{ command (add_reference_file             , add_reference_files, addrf) p=ocp$_add_reference_file cm=local
{ command (add_task_services              , addts) p=ocp$_add_task_services cm=local
{ command (compare_reference_file         , comrf) p=ocp$_compare_reference_file cm=local
{ command (quit                           , qui) p=ocp$_quit cm=local
{ command (write_reference_file           , wrirf) p=ocp$_write_reference_file cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    proru_commands: [STATIC, READ, read_only] ^clt$command_table := ^proru_commands_entries,

    proru_commands_entries: [STATIC, READ, read_only] array [1 .. 14] of clt$command_table_entry := [
          {} ['ADDL                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^ocp$_add_library],
          {} ['ADDRF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^ocp$_add_reference_file],
          {} ['ADDTS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^ocp$_add_task_services],
          {} ['ADD_LIBRARIES                  ', clc$alias_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^ocp$_add_library],
          {} ['ADD_LIBRARY                    ', clc$nominal_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^ocp$_add_library],
          {} ['ADD_REFERENCE_FILE             ', clc$nominal_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^ocp$_add_reference_file],
          {} ['ADD_REFERENCE_FILES            ', clc$alias_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^ocp$_add_reference_file],
          {} ['ADD_TASK_SERVICES              ', clc$nominal_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^ocp$_add_task_services],
          {} ['COMPARE_REFERENCE_FILE         ', clc$nominal_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^ocp$_compare_reference_file],
          {} ['COMRF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^ocp$_compare_reference_file],
          {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^ocp$_quit],
          {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 5,
          clc$automatically_log, clc$linked_call, ^ocp$_quit],
          {} ['WRIRF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
          clc$automatically_log, clc$linked_call, ^ocp$_write_reference_file],
          {} ['WRITE_REFERENCE_FILE           ', clc$nominal_entry, clc$normal_usage_entry, 6,
          clc$automatically_log, clc$linked_call, ^ocp$_write_reference_file]];

?? POP ??

{ table name=proru_functions type=function section_name=read_only scope=local
{ function ($compare_reference_file       ,$comrf) p=ocp$$compare_reference_file cm=local
{ function ($module_information            ) p=ocp$$module_information cm=local
{ function ($module_list                   ) p=ocp$$module_list cm=local
{ function ($product_information           ) p=ocp$$product_information cm=local
{ function ($product_list                  ) p=ocp$$product_list cm=local
{ function ($reference_information         ) p=ocp$$reference_information cm=local
{ function ($reference_list                ) p=ocp$$reference_list cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    proru_functions: [STATIC, READ, read_only] ^clt$function_processor_table := ^proru_functions_entries,

    proru_functions_entries: [STATIC, READ, read_only] array [1 .. 8] of clt$function_proc_table_entry := [
          {} ['$COMPARE_REFERENCE_FILE        ', clc$nominal_entry, clc$normal_usage_entry, 1,
          clc$linked_call, ^ocp$$compare_reference_file],
          {} ['$COMRF                         ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
          clc$linked_call, ^ocp$$compare_reference_file],
          {} ['$MODULE_INFORMATION            ', clc$nominal_entry, clc$normal_usage_entry, 2,
          clc$linked_call, ^ocp$$module_information],
          {} ['$MODULE_LIST                   ', clc$nominal_entry, clc$normal_usage_entry, 3,
          clc$linked_call, ^ocp$$module_list],
          {} ['$PRODUCT_INFORMATION           ', clc$nominal_entry, clc$normal_usage_entry, 4,
          clc$linked_call, ^ocp$$product_information],
          {} ['$PRODUCT_LIST                  ', clc$nominal_entry, clc$normal_usage_entry, 5,
          clc$linked_call, ^ocp$$product_list],
          {} ['$REFERENCE_INFORMATION         ', clc$nominal_entry, clc$normal_usage_entry, 6,
          clc$linked_call, ^ocp$$reference_information],
          {} ['$REFERENCE_LIST                ', clc$nominal_entry, clc$normal_usage_entry, 7,
          clc$linked_call, ^ocp$$reference_list]];

?? POP ??
?? OLDTITLE ??
?? NEWTITLE := 'clp$new_page_procedure', EJECT ??
*copy clp$new_page_procedure
?? OLDTITLE ??
?? NEWTITLE := 'add_to_module_list', EJECT ??

{   The purpose of this request is to add module name in the supplied entry external
{ to the module list for the specified reference kind.

  PROCEDURE add_to_module_list
    (    reference_kind: t$reference_kind;
         entry_external: t$entry_external);

    CONST
      estimated_number_of_modules = 1000;

    VAR
      high_index: ost$non_negative_integers,
      index: ost$non_negative_integers,
      insertion_index: ost$non_negative_integers,
      low_index: ost$non_negative_integers,
      module_list_p: ^array [1 .. * ] of clt$data_value,
      temp: integer,
      number_of_modules: ost$non_negative_integers;

    module_list_p := v$module_list [reference_kind].elements_p;
    number_of_modules := v$module_list [reference_kind].element_count;

{ If there is no module list, create one.

    IF number_of_modules = 0 THEN
      ALLOCATE v$module_list [reference_kind].elements_p: [1 .. estimated_number_of_modules];
      v$module_list [reference_kind].element_count := 1;
      v$module_list [reference_kind].elements_p^ [1].kind := clc$program_name;
      v$module_list [reference_kind].elements_p^ [1].program_name_value := entry_external.module_name;
      RETURN;
    IFEND;

{ See if the module is already in the module list.

    high_index := number_of_modules;
    low_index := 1;

    REPEAT
      temp := low_index + high_index;
      insertion_index := temp DIV 2;
      IF entry_external.module_name = module_list_p^ [insertion_index].program_name_value THEN
        RETURN;
      ELSEIF entry_external.module_name > module_list_p^ [insertion_index].program_name_value THEN
        low_index := insertion_index + 1;
      ELSE
        high_index := insertion_index - 1;
      IFEND;
    UNTIL (low_index > high_index);

{ Adjust the insertion_index to point to the element to insert BEFORE.
{ If the last partition indicated to insert AFTER the current entry,
{ increment the insertion_index.

    IF low_index > insertion_index THEN
      insertion_index := insertion_index + 1;
    IFEND;

{ Increase the size of the module list if necessary.

    IF (number_of_modules + 1) > UPPERBOUND (module_list_p^) THEN
      ALLOCATE module_list_p: [1 .. number_of_modules + estimated_number_of_modules];
      i#move (v$module_list [reference_kind].elements_p, module_list_p,
            #SIZE (module_list_p^ [1]) * number_of_modules);
      FREE v$module_list [reference_kind].elements_p;
      v$module_list [reference_kind].elements_p := module_list_p;
    IFEND;

{ Can't do i#move .. darn

    FOR index := number_of_modules DOWNTO insertion_index DO
      module_list_p^ [index + 1] := module_list_p^ [index];
    FOREND;
    module_list_p^ [insertion_index].kind := clc$program_name;
    module_list_p^ [insertion_index].program_name_value := entry_external.module_name;

    v$module_list [reference_kind].element_count := number_of_modules + 1;
  PROCEND add_to_module_list;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_product_list', EJECT ??

{   The purpose of this request is to add the product name of the supplied entry
{ external to the product list for the specified reference kind.

  PROCEDURE add_to_product_list
    (    reference_kind: t$reference_kind;
         entry_external: t$entry_external);

    CONST
      estimated_number_of_products = 100;

    VAR
      high_index: ost$non_negative_integers,
      index: ost$non_negative_integers,
      insertion_index: ost$non_negative_integers,
      low_index: ost$non_negative_integers,
      number_of_products: ost$non_negative_integers,
      temp: integer,
      product_list_p: ^array [1 .. * ] of clt$data_value;

    product_list_p := v$product_list [reference_kind].elements_p;
    number_of_products := v$product_list [reference_kind].element_count;

{ If there is no product list, create one.

    IF number_of_products = 0 THEN
      ALLOCATE v$product_list [reference_kind].elements_p: [1 .. estimated_number_of_products];
      v$product_list [reference_kind].element_count := 1;
      v$product_list [reference_kind].elements_p^ [1].kind := clc$name;
      v$product_list [reference_kind].elements_p^ [1].name_value := entry_external.product_name;
      RETURN;
    IFEND;

{ See if the product is already in the product list.

    high_index := number_of_products;
    low_index := 1;

    REPEAT
      temp := low_index + high_index;
      insertion_index := temp DIV 2;
      IF entry_external.product_name = product_list_p^ [insertion_index].name_value THEN
        RETURN;
      ELSEIF entry_external.product_name > product_list_p^ [insertion_index].name_value THEN
        low_index := insertion_index + 1;
      ELSE
        high_index := insertion_index - 1;
      IFEND;
    UNTIL (low_index > high_index);

{ Adjust the insertion_index to point to the element to insert BEFORE.
{ If the last partition indicated to insert AFTER the current entry,
{ increment the insertion_index.

    IF low_index > insertion_index THEN
      insertion_index := insertion_index + 1;
    IFEND;

{ Increase the size of the product list if necessary.

    IF (number_of_products + 1) > UPPERBOUND (product_list_p^) THEN
      ALLOCATE product_list_p: [1 .. number_of_products + estimated_number_of_products];
      i#move (v$product_list [reference_kind].elements_p, product_list_p,
            #SIZE (product_list_p^ [1]) * number_of_products);
      FREE v$product_list [reference_kind].elements_p;
      v$product_list [reference_kind].elements_p := product_list_p;
    IFEND;

{ Can't do i#move .. darn

    FOR index := number_of_products DOWNTO insertion_index DO
      product_list_p^ [index + 1] := product_list_p^ [index];
    FOREND;
    product_list_p^ [insertion_index].kind := clc$name;
    product_list_p^ [insertion_index].name_value := entry_external.product_name;

    v$product_list [reference_kind].element_count := number_of_products + 1;
  PROCEND add_to_product_list;
?? OLDTITLE ??
?? NEWTITLE := 'close_output_file', EJECT ??

{   The purpose of this request is to close the files used for the output of a
{ display command.

  PROCEDURE close_output_file
    (VAR status: ost$status);

    IF v$output_file_open THEN
      clp$close_display (v$display_control, status);
      IF status.normal THEN
        v$output_file_open := FALSE;
        #SPOIL (v$output_file_open);
      IFEND;
    IFEND;

  PROCEND close_output_file;
?? OLDTITLE ??
?? NEWTITLE := 'close_segment', EJECT ??

{ The purpose of this request is to close (delete) a scratch segment.

  PROCEDURE close_segment
    (    segment_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      segment_pointer: amt$segment_pointer;

    status.normal := TRUE;

    IF segment_p <> NIL THEN
      segment_pointer.kind := amc$sequence_pointer;
      segment_pointer.sequence_pointer := segment_p;
      mmp$delete_scratch_segment (segment_pointer, status);
    IFEND;
  PROCEND close_segment;
?? OLDTITLE ??
?? NEWTITLE := 'close_target_file', EJECT ??

{   The purpose of this request is to close a segment access file that has been
{ written.  The sequence position of the sequence pointer supplied on the request
{ is used to set the file's end of information (EOI).

  PROCEDURE close_target_file
    (    file_p: ^SEQ ( * );
         file_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      segment_pointer: amt$segment_pointer;

    IF file_p <> NIL THEN
      segment_pointer.kind := amc$sequence_pointer;
      segment_pointer.sequence_pointer := file_p;
      amp$set_segment_eoi (file_identifier, segment_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      fsp$close_file (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
  PROCEND close_target_file;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] declaration_mismatch', EJECT ??

{   The purpose of this request is to determine if the two entry externals
{ match for the supplied object or source checking value.  If the languages are
{ the same and both entry externals require declaration matching, then the
{ compiler generated hashes must match.  If the languages are not the same or
{ the one of the entry externals does not require declaration matching then
{ the entry externals match.  This is the same comparison that is used by the
{ NOS/VE loader to detect declaration mismatches.
{
{ NOTE:
{   This function should be used when comparing entry externals to see if they
{ mismatch.

  FUNCTION [INLINE] declaration_mismatch
    (    object_checking: boolean;
         x: t$entry_external;
         y: t$entry_external): boolean;

    IF (x.language = y.language) AND (x.declaration_matching_required) AND
          (y.declaration_matching_required) THEN
      IF x.language = llc$cybil THEN
        IF object_checking THEN
          declaration_mismatch := x.declaration_matching.object_encryption <>
                y.declaration_matching.object_encryption;
        ELSE
          declaration_mismatch := x.declaration_matching.source_encryption <>
                y.declaration_matching.source_encryption;
        IFEND;
      ELSE
        declaration_mismatch := x.declaration_matching.language_dependent_value <>
              y.declaration_matching.language_dependent_value;
      IFEND;
    ELSE
      declaration_mismatch := FALSE;
    IFEND;
  FUNCEND declaration_mismatch;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] declaration_values_match', EJECT ??

{   The purpose of this function is to determine if the two supplied entry externals
{ have the same language, declaration matching required and hash values.  If they
{ do they match, otherwise they do not.
{
{ NOTE:
{   This request should be used to compare two entry externals to see if they
{ match.

  FUNCTION [INLINE] declaration_values_match
    (    x: t$entry_external;
         y: t$entry_external): boolean;

    IF (x.language = y.language) AND (x.declaration_matching_required = y.declaration_matching_required) THEN
      IF x.language = llc$cybil THEN
        declaration_values_match := (x.declaration_matching.object_encryption =
              y.declaration_matching.object_encryption) AND (x.declaration_matching.source_encryption =
              y.declaration_matching.source_encryption);
      ELSE
        declaration_values_match := x.declaration_matching.language_dependent_value =
              y.declaration_matching.language_dependent_value;
      IFEND;
    ELSE
      declaration_values_match := FALSE;
    IFEND;
  FUNCEND declaration_values_match;
?? OLDTITLE ??
?? NEWTITLE := 'display_output_string', EJECT ??

{   The purpose of this request is to display a string to the output file of a
{ display command.  If the output file is not open, the string is discarded.

  PROCEDURE display_output_string
    (    output_string: string ( * );
     VAR status: ost$status);

    IF NOT v$output_file_open THEN
      RETURN;
    IFEND;

    clp$put_display (v$display_control, output_string, clc$trim, status);
  PROCEND display_output_string;
?? OLDTITLE ??
?? NEWTITLE := 'establish_display_title', EJECT ??

{   The purpose of this request is to define the title for a display command.

  PROCEDURE [INLINE] establish_display_title
    (    command_title: string ( * ));

    clv$titles_built := FALSE;
    clv$command_name := command_title;

  PROCEND establish_display_title;
?? OLDTITLE ??
?? NEWTITLE := 'get_entry_external_list', EJECT ??

{   The purpose of this request is to get the entry point list or external
{ reference list from the working file based on the reference type supplied.

  PROCEDURE get_entry_external_list
    (    reference_type: ost$name;
     VAR entry_external_list_p: ^t$entry_external_list;
     VAR status: ost$status);

    VAR
      entry_external_header_p: ^t$entry_external_file_header;

    IF reference_type = 'ENTRY_POINT' THEN
      IF v$working_file.entry_points_p <> NIL THEN
        RESET v$working_file.entry_points_p;
        NEXT entry_external_header_p IN v$working_file.entry_points_p;
        IF entry_external_header_p = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 011', status);
          RETURN;
        IFEND;
        IF entry_external_header_p^.entry_point_count > 0 THEN
          NEXT entry_external_list_p: [1 .. entry_external_header_p^.entry_point_count] IN
                v$working_file.entry_points_p;
          IF entry_external_list_p = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 012', status);
            RETURN;
          IFEND;
        ELSE
          entry_external_list_p := NIL;
        IFEND;
      ELSE
        entry_external_list_p := NIL;
      IFEND;
    ELSE { IF reference_type = 'EXTERNAL_REFERENCE' THEN
      IF v$working_file.externals_p <> NIL THEN
        RESET v$working_file.externals_p;
        NEXT entry_external_header_p IN v$working_file.externals_p;
        IF entry_external_header_p = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 013', status);
          RETURN;
        IFEND;
        IF entry_external_header_p^.external_count > 0 THEN
          NEXT entry_external_list_p: [1 .. entry_external_header_p^.external_count] IN
                v$working_file.externals_p;
          IF entry_external_list_p = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 014', status);
            RETURN;
          IFEND;
        ELSE
          entry_external_list_p := NIL;
        IFEND;
      ELSE
        entry_external_list_p := NIL;
      IFEND;
    IFEND;

  PROCEND get_entry_external_list;
?? OLDTITLE ??
?? NEWTITLE := 'greater_than: boolean', EJECT ??

{   The purpose of this function is to determine if the first entry/external is
{ lexically greater in value than the second entry/external.  Entry external files
{ have the entry/external records in lexically increasing order.

  FUNCTION greater_than
    (    x: t$entry_external;
         y: t$entry_external): boolean;

    VAR
      x_compare: t$comparison_converter,
      y_compare: t$comparison_converter;

    x_compare.entry_external_p := ^x;
    y_compare.entry_external_p := ^y;

    greater_than := x_compare.value_p^ > y_compare.value_p^;
  FUNCEND greater_than;
?? OLDTITLE ??
?? NEWTITLE := 'log_message', EJECT ??

{   The purpose of this request is to log a message to the executing job's
{ job log.

  PROCEDURE log_message
    (    message: string ( * ));

    VAR
      ignore_status: ost$status;

    pmp$log (message (1, clp$trimmed_string_size (message)), ignore_status);
  PROCEND log_message;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] make_entry_external_record', EJECT ??

{   The purpose of this request is to create an SCL record that defines an
{ entry/external.  This record is returned by functions that return a list of
{ entry/external definitions.

  PROCEDURE [INLINE] make_entry_external_record
    (    entry_external: t$entry_external;
     VAR work_area_p: {input, output} ^clt$work_area;
     VAR value_p: ^clt$data_value);

    clp$make_record_value (3, work_area_p, value_p);
    value_p^.field_values^ [1].name := 'REFERENCE_NAME';
    clp$make_program_name_value (entry_external.name, work_area_p, value_p^.field_values^ [1].value);
    value_p^.field_values^ [2].name := 'PRODUCT_NAME';
    clp$make_name_value (entry_external.product_name, work_area_p, value_p^.field_values^ [2].value);
    value_p^.field_values^ [3].name := 'MODULE_NAME';
    clp$make_program_name_value (entry_external.module_name, work_area_p, value_p^.field_values^ [3].value);
  PROCEND make_entry_external_record;
?? OLDTITLE ??
?? NEWTITLE := 'merge_with_working_file', EJECT ??

{   The purpose of this request is to combine the specified list of entry external
{ record lists with the working file.  Duplicate entries are ignored.  The working
{ file is created in lexically increasing order.

  PROCEDURE merge_with_working_file
    (    new_file_list_p: ^t$entry_external_files;
     VAR status: ost$status);

    VAR
      candidate_compare: t$comparison_converter,
      current_compare: t$comparison_converter,
      current_index: 0 .. clc$max_list_size,
      file_index: 1 .. clc$max_list_size,
      merge_file_list_p: ^array [1 .. * ] of record
        element: t$entry_external_file_element,
        entry_point_count: ost$non_negative_integers,
        entry_point_index: ost$non_negative_integers,
        external_count: ost$non_negative_integers,
        external_index: ost$non_negative_integers,
      recend,
      new_entry_external_list_p: ^t$entry_external_list,
      new_entry_external_p: ^t$entry_external,
      new_entry_point_header_p: ^t$entry_external_file_header,
      new_entry_point_p: ^SEQ ( * ),
      new_external_header_p: ^t$entry_external_file_header,
      new_external_p: ^SEQ ( * ),
      rebuild_entry_point_lists: boolean,
      rebuild_external_lists: boolean,
      working_file_header_p: ^t$entry_external_file_header;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   Attempt to cleanup on block exit if something doesn't work.
{ When this handler gets control, the working file is left in a state
{ equivalent to if the command had never been executed.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF condition.selector = pmc$block_exit_processing THEN
        close_segment (new_entry_point_p, ignore_status);
        close_segment (new_external_p, ignore_status);
        rebuild_module_and_product_list (c$rk_entry_point);
        rebuild_module_and_product_list (c$rk_external);

      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND abort_handler;
?? OLDTITLE ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Attempt to cleanup on block exit if something doesn't work.
{   Ignore terminate break conditions.  This is considered a "critical section."

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

{ Ignore terminate break during a critical section.

      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN
        RETURN;

      ELSEIF condition.selector = pmc$block_exit_processing THEN
        close_segment (new_entry_point_p, ignore_status);
        close_segment (new_external_p, ignore_status);
        reset_working_file;

        RETURN;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    new_entry_point_p := NIL;
    new_external_p := NIL;
    #SPOIL (new_entry_point_p, new_external_p);

    rebuild_entry_point_lists := FALSE;
    rebuild_external_lists := FALSE;

{   This condition handler will ignore terminate break.  The whole utility
{ will get messed up if this process is interrupted.

    osp$establish_block_exit_hndlr (^abort_handler);

    open_segment (new_entry_point_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    NEXT new_entry_point_header_p IN new_entry_point_p;
    IF new_entry_point_header_p = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 001', status);
      RETURN;
    IFEND;
    new_entry_point_header_p^.identification := c$entry_external_id;
    new_entry_point_header_p^.entry_point_count := 0;
    new_entry_point_header_p^.external_count := 0;

    open_segment (new_external_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    NEXT new_external_header_p IN new_external_p;
    IF new_external_header_p = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 002', status);
      RETURN;
    IFEND;
    new_external_header_p^.identification := c$entry_external_id;
    new_external_header_p^.entry_point_count := 0;
    new_external_header_p^.external_count := 0;

{ Add the working file to the merge list.  Make it the first entry as the working file
{ will, most often be the one with the most entries and thus less data movement will need
{ to take place when merging.

    PUSH merge_file_list_p: [1 .. (UPPERBOUND (new_file_list_p^) + 1)];
    FOR file_index := 1 TO UPPERBOUND (new_file_list_p^) DO
      merge_file_list_p^ [file_index + 1].element := new_file_list_p^ [file_index];
      merge_file_list_p^ [file_index + 1].entry_point_index := 1;
      merge_file_list_p^ [file_index + 1].external_index := 1;
      IF new_file_list_p^ [file_index].entry_point_list_p = NIL THEN
        merge_file_list_p^ [file_index + 1].entry_point_count := 0;
      ELSE
        merge_file_list_p^ [file_index + 1].entry_point_count :=
              UPPERBOUND (new_file_list_p^ [file_index].entry_point_list_p^);
      IFEND;
      IF new_file_list_p^ [file_index].external_list_p = NIL THEN
        merge_file_list_p^ [file_index + 1].external_count := 0;
      ELSE
        merge_file_list_p^ [file_index + 1].external_count :=
              UPPERBOUND (new_file_list_p^ [file_index].external_list_p^);
      IFEND;
    FOREND;

    IF v$working_file.entry_points_p <> NIL THEN
      RESET v$working_file.entry_points_p;
      NEXT working_file_header_p IN v$working_file.entry_points_p;
      IF working_file_header_p = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 003', status);
        RETURN;
      IFEND;
      IF working_file_header_p^.entry_point_count > 0 THEN
        NEXT merge_file_list_p^ [1].element.entry_point_list_p:
              [1 .. working_file_header_p^.entry_point_count] IN v$working_file.entry_points_p;
        IF merge_file_list_p^ [1].element.entry_point_list_p = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 004', status);
          RETURN;
        IFEND;
        merge_file_list_p^ [1].entry_point_count := working_file_header_p^.entry_point_count;
      ELSE
        merge_file_list_p^ [1].element.entry_point_list_p := NIL;
        merge_file_list_p^ [1].entry_point_count := 0;
      IFEND;
    ELSE
      merge_file_list_p^ [1].element.entry_point_list_p := NIL;
      merge_file_list_p^ [1].entry_point_count := 0;
    IFEND;

    IF v$working_file.externals_p <> NIL THEN
      RESET v$working_file.externals_p;
      NEXT working_file_header_p IN v$working_file.externals_p;
      IF working_file_header_p = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 005', status);
        RETURN;
      IFEND;
      IF working_file_header_p^.external_count > 0 THEN
        NEXT merge_file_list_p^ [1].element.external_list_p: [1 .. working_file_header_p^.external_count] IN
              v$working_file.externals_p;
        IF merge_file_list_p^ [1].element.external_list_p = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 006', status);
          RETURN;
        IFEND;
        merge_file_list_p^ [1].external_count := working_file_header_p^.external_count;
      ELSE
        merge_file_list_p^ [1].element.external_list_p := NIL;
        merge_file_list_p^ [1].external_count := 0;
      IFEND;
    ELSE
      merge_file_list_p^ [1].element.external_list_p := NIL;
      merge_file_list_p^ [1].external_count := 0;
    IFEND;
    merge_file_list_p^ [1].entry_point_index := 1;
    merge_file_list_p^ [1].external_index := 1;

{ Merge Entry Points...
{ If the working file is empty and only one file is being added....
{ Just move the added file to the new list.

    IF (merge_file_list_p^ [1].element.entry_point_list_p = NIL) AND (UPPERBOUND (merge_file_list_p^) =
          2) THEN
      IF merge_file_list_p^ [2].element.entry_point_list_p <> NIL THEN
        NEXT new_entry_external_list_p: [1 .. merge_file_list_p^ [2].entry_point_count] IN new_entry_point_p;
        new_entry_external_list_p^ := merge_file_list_p^ [2].element.entry_point_list_p^;
        new_entry_point_header_p^.entry_point_count := UPPERBOUND (new_entry_external_list_p^);
        rebuild_entry_point_lists := TRUE;
      IFEND;
    ELSE
      REPEAT
        current_index := 0;

      /find_next_entry_point/
        FOR file_index := 1 TO UPPERBOUND (merge_file_list_p^) DO
          IF merge_file_list_p^ [file_index].entry_point_index <=
                merge_file_list_p^ [file_index].entry_point_count THEN
            IF current_index > 0 THEN
              candidate_compare.entry_external_p := ^merge_file_list_p^ [file_index].element.
                    entry_point_list_p^ [merge_file_list_p^ [file_index].entry_point_index];

{ Check for duplicate entry points.

              WHILE candidate_compare.value_p^ = current_compare.value_p^ DO
                merge_file_list_p^ [file_index].entry_point_index :=
                      merge_file_list_p^ [file_index].entry_point_index + 1;
                IF merge_file_list_p^ [file_index].entry_point_index >
                      merge_file_list_p^ [file_index].entry_point_count THEN
                  CYCLE /find_next_entry_point/;
                IFEND;
                candidate_compare.entry_external_p := ^merge_file_list_p^ [file_index].element.
                      entry_point_list_p^ [merge_file_list_p^ [file_index].entry_point_index];
              WHILEND;

              IF current_compare.value_p^ > candidate_compare.value_p^ THEN
                current_index := file_index;
                current_compare := candidate_compare;
              IFEND;
            ELSE
              current_index := file_index;
              current_compare.entry_external_p := ^merge_file_list_p^ [file_index].element.
                    entry_point_list_p^ [merge_file_list_p^ [file_index].entry_point_index];
            IFEND;
          IFEND;
        FOREND /find_next_entry_point/;
        IF current_index > 0 THEN
          new_entry_point_header_p^.entry_point_count := new_entry_point_header_p^.entry_point_count + 1;
          NEXT new_entry_external_p IN new_entry_point_p;
          IF new_entry_external_p = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 007', status);
            RETURN;
          IFEND;
          new_entry_external_p^ := merge_file_list_p^ [current_index].
                element.entry_point_list_p^ [merge_file_list_p^ [current_index].entry_point_index];
          merge_file_list_p^ [current_index].entry_point_index :=
                merge_file_list_p^ [current_index].entry_point_index + 1;

{ If the entry point is not already in the working file module or product list, then add it.

          IF current_index > 1 THEN
            add_to_module_list (c$rk_entry_point, new_entry_external_p^);
            add_to_product_list (c$rk_entry_point, new_entry_external_p^);
          IFEND;
        IFEND;
      UNTIL current_index = 0;
    IFEND;

{ Now Merge the externals
{ If the working file is empty and only one file is being added....
{ Just move the added file to the new list.

    IF (merge_file_list_p^ [1].element.external_list_p = NIL) AND (UPPERBOUND (merge_file_list_p^) = 2) THEN
      IF merge_file_list_p^ [2].element.external_list_p <> NIL THEN
        NEXT new_entry_external_list_p: [1 .. merge_file_list_p^ [2].external_count] IN new_external_p;
        new_entry_external_list_p^ := merge_file_list_p^ [2].element.external_list_p^;
        new_external_header_p^.external_count := UPPERBOUND (new_entry_external_list_p^);
        rebuild_external_lists := TRUE;
      IFEND;
    ELSE

      REPEAT
        current_index := 0;

      /find_next_external/
        FOR file_index := 1 TO UPPERBOUND (merge_file_list_p^) DO
          IF merge_file_list_p^ [file_index].external_index <= merge_file_list_p^ [file_index].
                external_count THEN
            IF current_index > 0 THEN
              candidate_compare.entry_external_p := ^merge_file_list_p^ [file_index].element.
                    external_list_p^ [merge_file_list_p^ [file_index].external_index];

{ Check for duplicate external references.

              WHILE candidate_compare.value_p^ = current_compare.value_p^ DO
                merge_file_list_p^ [file_index].external_index :=
                      merge_file_list_p^ [file_index].external_index + 1;
                IF merge_file_list_p^ [file_index].external_index >
                      merge_file_list_p^ [file_index].external_count THEN
                  CYCLE /find_next_external/;
                IFEND;
                candidate_compare.entry_external_p := ^merge_file_list_p^ [file_index].element.
                      external_list_p^ [merge_file_list_p^ [file_index].external_index];
              WHILEND;

              IF current_compare.value_p^ > candidate_compare.value_p^ THEN
                current_index := file_index;
                current_compare := candidate_compare;
              IFEND;
            ELSE
              current_index := file_index;
              current_compare.entry_external_p := ^merge_file_list_p^ [file_index].
                    element.external_list_p^ [merge_file_list_p^ [file_index].external_index];
            IFEND;
          IFEND;
        FOREND /find_next_external/;
        IF current_index > 0 THEN
          new_external_header_p^.external_count := new_external_header_p^.external_count + 1;
          NEXT new_entry_external_p IN new_external_p;
          IF new_entry_external_p = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 008', status);
            RETURN;
          IFEND;
          new_entry_external_p^ := merge_file_list_p^ [current_index].
                element.external_list_p^ [merge_file_list_p^ [current_index].external_index];
          merge_file_list_p^ [current_index].external_index :=
                merge_file_list_p^ [current_index].external_index + 1;

{ If the external is not already in the working file module or product list, then add it.

          IF current_index > 1 THEN
            add_to_module_list (c$rk_external, new_entry_external_p^);
            add_to_product_list (c$rk_external, new_entry_external_p^);
          IFEND;
        IFEND;
      UNTIL current_index = 0;
    IFEND;

{ Make the new files the working file.

    close_segment (v$working_file.entry_points_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    close_segment (v$working_file.externals_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ This establishment overwrites the establishment of the current handler.
{ This is considered "critical" code and terminate break is ignored.

    osp$establish_condition_handler (^condition_handler, {block_exit} TRUE);

    v$working_file.entry_points_p := new_entry_point_p;
    v$working_file.externals_p := new_external_p;
    IF rebuild_entry_point_lists THEN
      rebuild_module_and_product_list (c$rk_entry_point);
    IFEND;
    IF rebuild_external_lists THEN
      rebuild_module_and_product_list (c$rk_external);
    IFEND;
    osp$disestablish_cond_handler;
  PROCEND merge_with_working_file;
?? OLDTITLE ??
?? NEWTITLE := 'open_output_file', EJECT ??

{   The purpose of this request is to open a file to be used for the output of
{ a display command.

  PROCEDURE open_output_file
    (    output_file: fst$file_reference;
     VAR status: ost$status);

    VAR
      default_ring_attributes: amt$ring_attributes;

    status.normal := TRUE;
    IF NOT v$output_file_open THEN

      default_ring_attributes.r1 := #RING (^default_ring_attributes);
      default_ring_attributes.r2 := #RING (^default_ring_attributes);
      default_ring_attributes.r3 := #RING (^default_ring_attributes);

      clp$open_display_reference (output_file, ^clp$new_page_procedure, fsc$list, default_ring_attributes,
            v$display_control, status);
      IF status.normal THEN
        v$output_file_open := TRUE;
        #SPOIL (v$output_file_open);
      IFEND;
    IFEND;

  PROCEND open_output_file;
?? OLDTITLE ??
?? NEWTITLE := 'open_segment', EJECT ??

{   The purpose of this request is to create a new scratch segment.
{ This request returns with the segment pointer already RESET.

  PROCEDURE open_segment
    (VAR segment_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      segment_attributes_p: ^array [ * ] of mmt$user_attribute_descriptor,
      segment_pointer: amt$segment_pointer;

    status.normal := TRUE;
    PUSH segment_attributes_p: [1 .. 1];

    segment_attributes_p^ [1].keyword := mmc$ua_preset_value;
    segment_attributes_p^ [1].preset_value := pmc$initialize_to_zero;
    mmp$create_user_segment (segment_attributes_p, amc$sequence_pointer, mmc$as_sequential, segment_pointer,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    segment_p := segment_pointer.sequence_pointer;
    RESET segment_p;

  PROCEND open_segment;
?? OLDTITLE ??
?? NEWTITLE := 'open_source_file', EJECT ??

{   The purpose of this request is to open an existing segment access file.
{ This request returns with the sequence reset.

  PROCEDURE open_source_file
    (    file_reference: fst$file_reference;
     VAR file_p: ^SEQ ( * );
     VAR file_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      ignore_status: ost$status,
      segment_pointer: amt$segment_pointer;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_options [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
    attachment_options [2].selector := fsc$sequential_access;
    attachment_options [2].sequential_access := TRUE;
    attachment_options [3].selector := fsc$free_behind;
    attachment_options [3].free_behind := TRUE;

    fsp$open_file (file_reference, amc$segment, ^attachment_options, NIL, NIL, NIL, NIL, file_identifier,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_identifier, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      fsp$close_file (file_identifier, ignore_status);
      RETURN;
    IFEND;

    file_p := segment_pointer.sequence_pointer;
    RESET file_p;
  PROCEND open_source_file;
?? OLDTITLE ??
?? NEWTITLE := 'open_target_file', EJECT ??

{   The purpose of this request is to open up a file to which data is to be
{ written.  The file is opened for segment access.  The sequence returned is
{ reset by this procedure.

  PROCEDURE open_target_file
    (    file_reference: fst$file_reference;
     VAR file_p: ^SEQ ( * );
     VAR file_identifier: amt$file_identifier;
     VAR status: ost$status);

    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      ignore_status: ost$status,
      segment_pointer: amt$segment_pointer;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options
          [fsc$read, fsc$shorten, fsc$append, fsc$modify];
    attachment_options [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options [1].share_modes.value := $fst$file_access_options [];
    attachment_options [2].selector := fsc$sequential_access;
    attachment_options [2].sequential_access := TRUE;
    attachment_options [3].selector := fsc$free_behind;
    attachment_options [3].free_behind := TRUE;

    fsp$open_file (file_reference, amc$segment, ^attachment_options, NIL, NIL, NIL, NIL, file_identifier,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_identifier, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      fsp$close_file (file_identifier, ignore_status);
      RETURN;
    IFEND;

    file_p := segment_pointer.sequence_pointer;
    RESET file_p;
  PROCEND open_target_file;
?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle', EJECT ??

{  This is a dummy procedure used by clp$new_page_procedure for output commands.

  PROCEDURE [INLINE] put_subtitle
    (VAR display_control: clt$display_control;
     VAR status: ost$status);

{ These displays do not have subtitles.  This is merely a dummy routine to keep the module consistant
{ with those that do produce subtitles.

  PROCEND put_subtitle;
?? OLDTITLE ??
?? NEWTITLE := 'rebuild_module_and_product_list', EJECT ??

{   The purpose of this request is to discard the current module and product list
{ and create a new one based on the working file.

  PROCEDURE rebuild_module_and_product_list
    (    reference_kind: t$reference_kind);

    VAR
      entry_external_file_header_p: ^t$entry_external_file_header,
      entry_external_list_p: ^t$entry_external_list,
      index: ost$non_negative_integers;

{ Go through the entry points.

    IF v$module_list [reference_kind].elements_p <> NIL THEN
      FREE v$module_list [reference_kind].elements_p;
    IFEND;
    v$module_list [reference_kind].element_count := 0;
    IF v$product_list [reference_kind].elements_p <> NIL THEN
      FREE v$product_list [reference_kind].elements_p;
    IFEND;
    v$product_list [reference_kind].element_count := 0;

    entry_external_list_p := NIL;
    IF reference_kind = c$rk_entry_point THEN
      IF v$working_file.entry_points_p <> NIL THEN
        RESET v$working_file.entry_points_p;
        NEXT entry_external_file_header_p IN v$working_file.entry_points_p;
        IF entry_external_file_header_p^.entry_point_count > 0 THEN
          NEXT entry_external_list_p: [1 .. entry_external_file_header_p^.entry_point_count] IN
                v$working_file.entry_points_p;
        IFEND;
      IFEND;
    ELSE { IF reference_kind = c$rk_external  THEN
      IF v$working_file.externals_p <> NIL THEN
        RESET v$working_file.externals_p;
        NEXT entry_external_file_header_p IN v$working_file.externals_p;
        IF entry_external_file_header_p^.external_count > 0 THEN
          NEXT entry_external_list_p: [1 .. entry_external_file_header_p^.external_count] IN
                v$working_file.externals_p;
        IFEND;
      IFEND;
    IFEND;

    IF entry_external_list_p <> NIL THEN
      FOR index := 1 TO UPPERBOUND (entry_external_list_p^) DO
        add_to_module_list (reference_kind, entry_external_list_p^ [index]);
        add_to_product_list (reference_kind, entry_external_list_p^ [index]);
      FOREND;
    IFEND;
  PROCEND rebuild_module_and_product_list;
?? OLDTITLE ??
?? NEWTITLE := 'remove_duplicates', EJECT ??

{   The purpose of this request is to remove duplicate entries from the file it is passed.
{
{ NOTE:
{   It is assumed that this is only done on one of the working files, and therefore,
{ there are only entry point or externals in the file, and not both.

  PROCEDURE remove_duplicates
    (VAR file_p: ^SEQ ( * ));

    TYPE
      t$entry_external_list = array [1 .. * ] of string (c$entry_external_record_size);

    VAR
      entry_external_header_p: ^t$entry_external_file_header,
      entry_external_list_p: ^t$entry_external_list,
      index: integer,
      low_index: integer;

    IF file_p = NIL THEN
      RETURN;
    IFEND;

{ Can't return NIL.  Segments have already been verified.

    RESET file_p;
    NEXT entry_external_header_p IN file_p;

    IF entry_external_header_p^.entry_point_count > 0 THEN
      NEXT entry_external_list_p: [1 .. entry_external_header_p^.entry_point_count] IN file_p;
    ELSEIF entry_external_header_p^.external_count > 0 THEN
      NEXT entry_external_list_p: [1 .. entry_external_header_p^.external_count] IN file_p;
    ELSE
      RETURN;
    IFEND;

    low_index := 1;
    FOR index := 2 TO UPPERBOUND (entry_external_list_p^) DO
      IF entry_external_list_p^ [index] <> entry_external_list_p^ [low_index] THEN
        low_index := low_index + 1;
        IF low_index <> index THEN
          entry_external_list_p^ [low_index] := entry_external_list_p^ [index];
        IFEND;
      IFEND;
    FOREND;
    IF entry_external_header_p^.entry_point_count > 0 THEN
      entry_external_header_p^.entry_point_count := low_index;
    ELSE { IF entry_exernal_header_p^.external_count > 0 THEN
      entry_external_header_p^.external_count := low_index;
    IFEND;
  PROCEND remove_duplicates;
?? OLDTITLE ??
?? NEWTITLE := 'reset_working_file', EJECT ??

{   The purpose of this request is to discard the working file, module list and
{ product list.  This resets the utility to the point it was at upon entry.

  PROCEDURE reset_working_file;

    VAR
      ignore_status: ost$status;

    close_segment (v$working_file.entry_points_p, ignore_status);
    close_segment (v$working_file.externals_p, ignore_status);
    v$working_file.entry_points_p := NIL;
    v$working_file.externals_p := NIL;
    IF v$module_list [c$rk_entry_point].elements_p <> NIL THEN
      FREE v$module_list [c$rk_entry_point].elements_p;
    IFEND;
    v$module_list [c$rk_entry_point].element_count := 0;
    IF v$module_list [c$rk_external].elements_p <> NIL THEN
      FREE v$module_list [c$rk_external].elements_p;
    IFEND;
    v$module_list [c$rk_external].element_count := 0;
    IF v$product_list [c$rk_entry_point].elements_p <> NIL THEN
      FREE v$product_list [c$rk_entry_point].elements_p;
    IFEND;
    v$product_list [c$rk_entry_point].element_count := 0;
    IF v$product_list [c$rk_external].elements_p <> NIL THEN
      FREE v$product_list [c$rk_external].elements_p;
    IFEND;
    v$product_list [c$rk_external].element_count := 0;
  PROCEND reset_working_file;
?? OLDTITLE ??
?? NEWTITLE := 'sort_entry_external_list', EJECT ??

{   The purpose of this request is to sort the supplied entry external list.

  PROCEDURE sort_entry_external_list
    (    entry_external_list_p: ^t$entry_external_list);

    VAR
      gap: integer,
      start: integer,
      current: integer,
      swap: t$entry_external;

    gap := UPPERBOUND (entry_external_list_p^);
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := 1 TO UPPERBOUND (entry_external_list_p^) - gap DO
        current := start;
        WHILE (current > 0) AND greater_than (entry_external_list_p^ [current],
              entry_external_list_p^ [current + gap]) DO
          swap := entry_external_list_p^ [current];
          entry_external_list_p^ [current] := entry_external_list_p^ [current + gap];
          entry_external_list_p^ [current + gap] := swap;
          current := current - gap;
        WHILEND;
      FOREND;
    WHILEND;
  PROCEND sort_entry_external_list;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$$compare_reference_file', EJECT ??

{   The purpose of this function is to compare the reference type for the
{ working file with the reference type for the specified reference file.
{
{ DESIGN:
{   Get the correct entry external list from the working file.
{   Open the reference file and get the correct entry external list.
{   Set result to empty list.
{   working_index := 1;   working_list [working_index] is called working_entry
{   compare_index := 1;   compare_list [compare_index] is called compare_entry
{   WHILE working_index and compare_index < the size of their respective entry external lists DO
{     IF working_entry.name = compare_entry.name THEN
{       IF declaration mismatch (working_entry, compare_entry) THEN
{         add mismatch to result list
{       IFEND
{       compare_index := compare_index + 1; {get the next compare list element
{     ELSEIF working_entry.name < compare_entry.name THEN
{       working_index := working_index + 1;
{          need to backup the compare list in case the next working entry is
{          the same as the current compare entry.  This happens as a side
{          effect from the first part of the IF.  This happens when the working
{          file contains entries with the same name.
{       WHILE compare_entry.name = working_entry.name DO
{         compare_index := compare_index - 1;
{       WHILEND;
{     ELSE
{       compare_index := compare_index + 1;
{     IFEND
{   WHILEND
{   close the reference file.

  PROCEDURE ocp$$compare_reference_file
    (    parameter_list: clt$parameter_list;
     VAR work_area { input, output } : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (ocm$$proru_comrf) $compare_reference_file, $comrf (
{   reference_type: key
{       (entry_point, entry_points, ep)
{       (external_reference, external_references, er)
{     keyend = $required
{   reference_file: record
{       file: file
{       reference_type: key
{         (entry_point, entry_points, ep)
{         (external_reference, external_references, er)
{       keyend
{     recend = $required
{   cybil_parameter_checking: key
{       (object, o)
{       (source, s)
{     keyend = object
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 6] of clt$keyword_specification,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (6),
      recend,
    recend := [
    [1,
    [90, 3, 28, 23, 10, 55, 29],
    clc$function, 3, 3, 2, 0, 0, 0, 0, 'OCM$$PRORU_COMRF'], [
    ['CYBIL_PARAMETER_CHECKING       ',clc$nominal_entry, 3],
    ['REFERENCE_FILE                 ',clc$nominal_entry, 2],
    ['REFERENCE_TYPE                 ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, 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, 229,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, 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, 311,
  clc$required_parameter, 0, 0],
{ PARAMETER 3
    [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, 155,
  clc$optional_default_parameter, 0, 6]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [6], [
    ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ENTRY_POINTS                   ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ER                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXTERNAL_REFERENCE             ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['EXTERNAL_REFERENCES            ', clc$alias_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 2
    [[1, 0, clc$record_type], [2],
    ['FILE                           ', clc$required_field, 3], [[1, 0, clc$file_type]],
    ['REFERENCE_TYPE                 ', clc$required_field, 229], [[1, 0, clc$keyword_type], [6], [
      ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['ENTRY_POINTS                   ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ER                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['EXTERNAL_REFERENCE             ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['EXTERNAL_REFERENCES            ', clc$alias_entry, clc$normal_usage_entry, 2]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['O                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['OBJECT                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SOURCE                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'object']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$reference_type = 1,
      p$reference_file = 2,
      p$cybil_parameter_checking = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      compare_fid: amt$file_identifier,
      compare_file_p: ^SEQ ( * ),
      compare_header_p: ^t$entry_external_file_header,
      compare_index: ost$non_negative_integers,
      compare_list_p: ^t$entry_external_list,
      data_value_pp: ^^clt$data_value,
      object_checking: boolean,
      working_index: ost$non_negative_integers,
      working_list_p: ^t$entry_external_list;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Attempt to cleanup on block exit if something doesn't work.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF condition.selector = pmc$block_exit_processing THEN
        fsp$close_file (compare_fid, ignore_status);
        RETURN;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] make_compare_record', EJECT ??

{   The purpose of this request is create an SCL record element to be returned by  the
{ $compare_reference_file function.

    PROCEDURE [INLINE] make_compare_record
      (    working_entry_external: t$entry_external;
           compare_entry_external: t$entry_external;
       VAR work_area_p: {input, output} ^clt$work_area;
       VAR value_p: ^clt$data_value);

      clp$make_record_value (5, work_area_p, value_p);
      value_p^.field_values^ [1].name := 'REFERENCE_NAME';
      clp$make_program_name_value (working_entry_external.name, work_area_p, value_p^.field_values^ [1].
            value);
      value_p^.field_values^ [2].name := 'WORKING_PRODUCT_NAME';
      clp$make_name_value (working_entry_external.product_name, work_area_p, value_p^.field_values^ [2].
            value);
      value_p^.field_values^ [3].name := 'WORKING_MODULE_NAME';
      clp$make_program_name_value (working_entry_external.module_name, work_area_p, value_p^.
            field_values^ [3].value);
      value_p^.field_values^ [4].name := 'FILE_PRODUCT_NAME';
      clp$make_name_value (compare_entry_external.product_name, work_area_p, value_p^.field_values^ [4].
            value);
      value_p^.field_values^ [5].name := 'FILE_MODULE_NAME';
      clp$make_program_name_value (compare_entry_external.module_name, work_area_p, value_p^.
            field_values^ [5].value);
    PROCEND make_compare_record;
?? OLDTITLE ??
?? EJECT ??
    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    object_checking := pvt [p$cybil_parameter_checking].value^.keyword_value = 'OBJECT';

{ Determine which part of the working file to use, entry points or externals

    IF pvt [p$reference_type].value^.keyword_value = 'ENTRY_POINT' THEN
      compare_file_p := v$working_file.entry_points_p;
      IF compare_file_p = NIL THEN
        clp$make_list_value (work_area, result);
        RETURN;
      IFEND;

      RESET compare_file_p;
      NEXT compare_header_p IN compare_file_p;
      IF (compare_file_p = NIL) OR (compare_header_p^.entry_point_count = 0) THEN
        clp$make_list_value (work_area, result);
        RETURN;
      IFEND;
      NEXT working_list_p: [1 .. compare_header_p^.entry_point_count] IN compare_file_p;
      IF working_list_p = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 009', status);
        RETURN;
      IFEND;
    ELSE
      compare_file_p := v$working_file.externals_p;
      IF compare_file_p = NIL THEN
        clp$make_list_value (work_area, result);
        RETURN;
      IFEND;

      RESET compare_file_p;
      NEXT compare_header_p IN compare_file_p;
      IF (compare_file_p = NIL) OR (compare_header_p^.external_count = 0) THEN
        clp$make_list_value (work_area, result);
        RETURN;
      IFEND;
      NEXT working_list_p: [1 .. compare_header_p^.external_count] IN compare_file_p;
      IF working_list_p = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 010', status);
        RETURN;
      IFEND;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

{ Open the reference file to compare with and locate the requested entry points or externals

    open_source_file (pvt [p$reference_file].value^.field_values^ [1].value^.file_value^, compare_file_p,
          compare_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    NEXT compare_header_p IN compare_file_p;
    IF pvt [p$reference_file].value^.field_values^ [2].value^.keyword_value = 'ENTRY_POINT' THEN
      IF (compare_header_p = NIL) OR (compare_header_p^.entry_point_count = 0) THEN
        osp$set_status_condition (oce$missing_or_empty_file, status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$reference_file].
              value^.field_values^ [1].value^.file_value^, status);
        RETURN;
      IFEND;
      NEXT compare_list_p: [1 .. compare_header_p^.entry_point_count] IN compare_file_p;
      IF compare_list_p = NIL THEN
        osp$set_status_condition (oce$premature_eof_in_segment, status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$reference_file].
              value^.field_values^ [1].value^.file_value^, status);
        RETURN;
      IFEND;
    ELSE
      IF (compare_header_p = NIL) OR (compare_header_p^.external_count = 0) THEN
        osp$set_status_condition (oce$missing_or_empty_file, status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$reference_file].
              value^.field_values^ [1].value^.file_value^, status);
        RETURN;
      IFEND;
      IF compare_header_p^.entry_point_count > 0 THEN
        NEXT compare_list_p: [1 .. compare_header_p^.entry_point_count] IN compare_file_p;
        IF compare_list_p = NIL THEN
          osp$set_status_condition (oce$premature_eof_in_segment, status);
          osp$append_status_file (osc$status_parameter_delimiter, pvt [p$reference_file].value^.
                field_values^ [1].value^.file_value^, status);
          RETURN;
        IFEND;
      IFEND;
      NEXT compare_list_p: [1 .. compare_header_p^.external_count] IN compare_file_p;
      IF compare_list_p = NIL THEN
        osp$set_status_condition (oce$premature_eof_in_segment, status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$reference_file].
              value^.field_values^ [1].value^.file_value^, status);
        RETURN;
      IFEND;
    IFEND;

    result := NIL;
    data_value_pp := ^result;

{ Compare the entry points and externals.

    working_index := 1;
    compare_index := 1;

    WHILE (working_index <= UPPERBOUND (working_list_p^)) AND (compare_index <= UPPERBOUND (compare_list_p^))
          DO
      IF working_list_p^ [working_index].name = compare_list_p^ [compare_index].name THEN
        IF declaration_mismatch (object_checking, working_list_p^ [working_index],
              compare_list_p^ [compare_index]) THEN
          clp$make_list_value (work_area, data_value_pp^);
          make_compare_record (working_list_p^ [working_index], compare_list_p^ [compare_index],
                work_area, data_value_pp^^.element_value);
          data_value_pp := ^data_value_pp^^.link;
        IFEND;
        compare_index := compare_index + 1;
      ELSEIF working_list_p^ [working_index].name < compare_list_p^ [compare_index].name THEN
        working_index := working_index + 1;
        IF working_index <= UPPERBOUND (working_list_p^) THEN
          WHILE (compare_index > 1) AND (compare_list_p^ [compare_index - 1].
                name = working_list_p^ [working_index].name) DO
            compare_index := compare_index - 1;
          WHILEND;
        IFEND;
      ELSE
        compare_index := compare_index + 1;
      IFEND;
    WHILEND;

    fsp$close_file (compare_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    osp$disestablish_cond_handler;

{ If result is still NIL, no references were selected.

    IF result = NIL THEN
      clp$make_list_value (work_area, result);
    IFEND;

  PROCEND ocp$$compare_reference_file;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$$module_information', EJECT ??

  PROCEDURE ocp$$module_information
    (    parameter_list: clt$parameter_list;
     VAR work_area { input, output } : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (ocm$$proru_modi) $module_information (
{   reference_type: key
{       (entry_point, entry_points, ep)
{       (external_reference, external_references, er)
{     keyend = $required
{   modules: any of
{       key
{         all
{       keyend
{       list of program_name
{     anyend = all
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type2: 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,
          recend,
        recend,
        default_value: string (3),
      recend,
    recend := [
    [1,
    [90, 3, 28, 23, 11, 40, 702],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OCM$$PRORU_MODI'], [
    ['MODULES                        ',clc$nominal_entry, 2],
    ['REFERENCE_TYPE                 ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 229,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [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, 83,
  clc$optional_default_parameter, 0, 3]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [6], [
    ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ENTRY_POINTS                   ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ER                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXTERNAL_REFERENCE             ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['EXTERNAL_REFERENCES            ', clc$alias_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 2
    [[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]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$program_name_type]]
      ]
    ,
    'all']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$reference_type = 1,
      p$modules = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      all_selected: boolean,
      data_value_pp: ^^clt$data_value,
      entry_external_header_p: ^t$entry_external_file_header,
      entry_external_list_p: ^t$entry_external_list,
      index: ost$non_negative_integers,
      match: boolean,
      node_p: ^clt$data_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Determine whether to use entry points or externals.

    get_entry_external_list (pvt [p$reference_type].value^.keyword_value, entry_external_list_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ If there are none, return an empty list.

    IF entry_external_list_p = NIL THEN
      clp$make_list_value (work_area, result);
      RETURN;
    IFEND;

{ Return the desired records.

    all_selected := pvt [p$modules].value^.kind = clc$keyword;
    result := NIL;
    data_value_pp := ^result;
    index := 1;
    WHILE (index <= UPPERBOUND (entry_external_list_p^)) DO
      IF NOT all_selected THEN
        match := FALSE;
        node_p := pvt [p$modules].value;
        WHILE (NOT match) AND (node_p <> NIL) DO
          match := node_p^.element_value^.program_name_value = entry_external_list_p^ [index].module_name;
          node_p := node_p^.link;
        WHILEND;
      IFEND;

      IF all_selected OR match THEN
        clp$make_list_value (work_area, data_value_pp^);
        make_entry_external_record (entry_external_list_p^ [index], work_area, data_value_pp^^.element_value);
        data_value_pp := ^data_value_pp^^.link;
      IFEND;
      index := index + 1;
    WHILEND;

{ If result is still NIL, no references were selected.

    IF result = NIL THEN
      clp$make_list_value (work_area, result);
    IFEND;

  PROCEND ocp$$module_information;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$$module_list', EJECT ??

  PROCEDURE ocp$$module_list
    (    parameter_list: clt$parameter_list;
     VAR work_area { input, output } : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (ocm$$proru_modl) $module_list (
{   reference_type: key
{       (entry_point, entry_points, ep)
{       (external_reference, external_references, er)
{     keyend = $required
{   module: any of
{       key
{         all
{       keyend
{       list defer_expansion of program_name
{     anyend = all
{   pattern_type: key
{       (basic, b)
{       (extended, e)
{     keyend = $scl_options.wild_card_pattern_type
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type2: 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,
          recend,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (35),
      recend,
    recend := [
    [1,
    [90, 3, 28, 23, 12, 0, 511],
    clc$function, 3, 3, 1, 0, 0, 0, 0, 'OCM$$PRORU_MODL'], [
    ['MODULE                         ',clc$nominal_entry, 2],
    ['PATTERN_TYPE                   ',clc$nominal_entry, 3],
    ['REFERENCE_TYPE                 ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, 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, 229,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [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, 83,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [2, 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, 155,
  clc$optional_default_parameter, 0, 35]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [6], [
    ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ENTRY_POINTS                   ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ER                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXTERNAL_REFERENCE             ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['EXTERNAL_REFERENCES            ', clc$alias_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 2
    [[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]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, TRUE, FALSE],
        [[1, 0, clc$program_name_type]]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BASIC                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXTENDED                       ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    '$scl_options.wild_card_pattern_type']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$reference_type = 1,
      p$module = 2,
      p$pattern_type = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    TYPE
      patterns = array [1 .. * ] of record
        case pattern: boolean of
        = TRUE =
          pattern_p: ^clt$string_pattern,
        = FALSE =
          name: pmt$program_name,
        casend,
      recend;

    VAR
      all_selected: boolean,
      candidate_p: ^clt$string_value,
      data_value_pp: ^^clt$data_value,
      index: ost$non_negative_integers,
      match: boolean,
      match_info: clt$string_pattern_match_info,
      module_list_p: ^array [1 .. * ] of clt$data_value,
      node_p: ^clt$data_value,
      number_of_modules: ost$non_negative_integers,
      original_pattern_p: ^clt$string_value,
      pattern_index: ost$non_negative_integers,
      pattern_p: ^clt$string_value,
      pattern_type: clt$wild_card_pattern_type,
      selected_patterns_p: ^patterns;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$reference_type].value^.keyword_value = 'ENTRY_POINT' THEN
      module_list_p := v$module_list [c$rk_entry_point].elements_p;
      number_of_modules := v$module_list [c$rk_entry_point].element_count;
    ELSE { pvt [p$reference_type].value^.keyword_value = 'EXTERNAL_REFERENCE' THEN
      module_list_p := v$module_list [c$rk_external].elements_p;
      number_of_modules := v$module_list [c$rk_external].element_count;
    IFEND;

{ If there are none, return an empty list.

    IF module_list_p = NIL THEN
      clp$make_list_value (work_area, result);
      RETURN;
    IFEND;

    IF pvt [p$pattern_type].value^.keyword_value = 'BASIC' THEN
      pattern_type := clc$wc_basic_pattern;
    ELSE
      pattern_type := clc$wc_extended_pattern;
    IFEND;

    all_selected := pvt [p$module].value^.kind = clc$keyword;

{ Convert the supplied patterns to an internal pattern representation.  Do this only once
{ then they can be compared individually later.

    IF NOT all_selected THEN
      PUSH selected_patterns_p: [1 .. clp$count_list_elements (pvt [p$module].value)];
      node_p := pvt [p$module].value;
      FOR pattern_index := 1 TO UPPERBOUND (selected_patterns_p^) DO
        IF node_p^.element_value^.kind = clc$program_name THEN
          selected_patterns_p^ [pattern_index].pattern := FALSE;
          selected_patterns_p^ [pattern_index].name := node_p^.element_value^.program_name_value;
        ELSE { it's a pattern
          original_pattern_p := node_p^.element_value^.application_value;
          PUSH pattern_p: [STRLENGTH (original_pattern_p^)];

          IF pattern_type = clc$wc_basic_pattern THEN
            #TRANSLATE (osv$lower_to_upper, original_pattern_p^, pattern_p^);
          ELSE
            #TRANSLATE (osv$lower_to_upper_26, original_pattern_p^, pattern_p^);
          IFEND;

          selected_patterns_p^ [pattern_index].pattern := TRUE;
          clp$build_pattern_for_wild_card (pattern_type, $clt$string_pattern_build_opts
                [clc$sp_match_at_right, clc$sp_ignore_matched_substring], pattern_p^, work_area,
                selected_patterns_p^ [pattern_index].pattern_p, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        node_p := node_p^.link;
      FOREND;
    IFEND;
    result := NIL;
    data_value_pp := ^result;

    index := 1;
    WHILE (index <= number_of_modules) DO
      IF NOT all_selected THEN

{ Compare the name with the selected pattern.

        match := FALSE;

        pattern_index := 1;
        WHILE (NOT match) AND (pattern_index <= UPPERBOUND (selected_patterns_p^)) DO
          IF selected_patterns_p^ [pattern_index].pattern THEN
            clp$match_string_pattern (module_list_p^ [index].program_name_value
                  (1, clp$trimmed_string_size (module_list_p^ [index].program_name_value)),
                  selected_patterns_p^ [pattern_index].pattern_p, clc$sp_anchored, clc$sp_quick_scan,
                  match_info, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            match := match_info.result = clc$sp_success;
          ELSE
            match := selected_patterns_p^ [pattern_index].name = module_list_p^ [index].program_name_value;
          IFEND;
          pattern_index := pattern_index + 1;
        WHILEND;
      IFEND;

      IF all_selected OR match THEN
        clp$make_list_value (work_area, data_value_pp^);
        data_value_pp^^.element_value := ^module_list_p^ [index];
        data_value_pp := ^data_value_pp^^.link;
      IFEND;
      index := index + 1;
    WHILEND;

{ If result is still NIL, no references were selected.

    IF result = NIL THEN
      clp$make_list_value (work_area, result);
    IFEND;

  PROCEND ocp$$module_list;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$$product_information', EJECT ??

  PROCEDURE ocp$$product_information
    (    parameter_list: clt$parameter_list;
     VAR work_area { input, output } : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (ocm$$proru_proi) $product_information (
{   reference_type: key
{       (entry_point, entry_points, ep)
{       (external_reference, external_references, er)
{     keyend = $required
{   product: any of
{       key
{         all
{       keyend
{       list of name
{     anyend = all
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type2: 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
    recend := [
    [1,
    [90, 4, 13, 9, 3, 9, 947],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OCM$$PRORU_PROI'], [
    ['PRODUCT                        ',clc$nominal_entry, 2],
    ['REFERENCE_TYPE                 ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 229,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [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, 85,
  clc$optional_default_parameter, 0, 3]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [6], [
    ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ENTRY_POINTS                   ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ER                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXTERNAL_REFERENCE             ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['EXTERNAL_REFERENCES            ', clc$alias_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 2
    [[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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$reference_type = 1,
      p$product = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      all_selected: boolean,
      data_value_pp: ^^clt$data_value,
      entry_external_header_p: ^t$entry_external_file_header,
      entry_external_list_p: ^t$entry_external_list,
      index: ost$non_negative_integers,
      match: boolean,
      node_p: ^clt$data_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Determine if entry points or externals should be used.

    get_entry_external_list (pvt [p$reference_type].value^.keyword_value, entry_external_list_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ If there are none, return an empty list.

    IF entry_external_list_p = NIL THEN
      clp$make_list_value (work_area, result);
      RETURN;
    IFEND;

    all_selected := pvt [p$product].value^.kind = clc$keyword;
    result := NIL;
    data_value_pp := ^result;
    index := 1;
    WHILE (index <= UPPERBOUND (entry_external_list_p^)) DO
      IF NOT all_selected THEN
        match := FALSE;
        node_p := pvt [p$product].value;
        WHILE (NOT match) AND (node_p <> NIL) DO
          match := node_p^.element_value^.name_value = entry_external_list_p^ [index].product_name;
          node_p := node_p^.link;
        WHILEND;
      IFEND;

      IF all_selected OR match THEN
        clp$make_list_value (work_area, data_value_pp^);
        make_entry_external_record (entry_external_list_p^ [index], work_area, data_value_pp^^.element_value);
        data_value_pp := ^data_value_pp^^.link;
      IFEND;
      index := index + 1;
    WHILEND;

{ If result is still NIL, no references were selected.

    IF result = NIL THEN
      clp$make_list_value (work_area, result);
    IFEND;

  PROCEND ocp$$product_information;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$$product_list', EJECT ??

  PROCEDURE ocp$$product_list
    (    parameter_list: clt$parameter_list;
     VAR work_area { input, output } : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (ocm$$proru_prol) $product_list (
{   reference_type: key
{       (entry_point, entry_points, ep)
{       (external_reference, external_references, er)
{     keyend = $required
{   product: any of
{       key
{         all
{       keyend
{       list defer_expansion of name
{     anyend = all
{   pattern_type: key
{       (basic, b)
{       (extended, e)
{     keyend = $scl_options.wild_card_pattern_type
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type2: 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$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (35),
      recend,
    recend := [
    [1,
    [90, 3, 28, 23, 12, 25, 249],
    clc$function, 3, 3, 1, 0, 0, 0, 0, 'OCM$$PRORU_PROL'], [
    ['PATTERN_TYPE                   ',clc$nominal_entry, 3],
    ['PRODUCT                        ',clc$nominal_entry, 2],
    ['REFERENCE_TYPE                 ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, 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, 229,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, 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, 85,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [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, 155,
  clc$optional_default_parameter, 0, 35]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [6], [
    ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ENTRY_POINTS                   ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ER                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXTERNAL_REFERENCE             ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['EXTERNAL_REFERENCES            ', clc$alias_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 2
    [[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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, TRUE, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BASIC                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXTENDED                       ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    '$scl_options.wild_card_pattern_type']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$reference_type = 1,
      p$product = 2,
      p$pattern_type = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    TYPE
      patterns = array [1 .. * ] of record
        case pattern: boolean of
        = TRUE =
          pattern_p: ^clt$string_pattern,
        = FALSE =
          name: ost$name,
        casend,
      recend;

    VAR
      all_selected: boolean,
      candidate_p: ^clt$string_value,
      data_value_pp: ^^clt$data_value,
      index: ost$non_negative_integers,
      match: boolean,
      match_info: clt$string_pattern_match_info,
      node_p: ^clt$data_value,
      number_of_products: ost$non_negative_integers,
      original_pattern_p: ^clt$string_value,
      pattern_index: ost$non_negative_integers,
      pattern_p: ^clt$string_value,
      pattern_type: clt$wild_card_pattern_type,
      product_list_p: ^array [1 .. * ] of clt$data_value,
      selected_patterns_p: ^patterns;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$reference_type].value^.keyword_value = 'ENTRY_POINT' THEN
      product_list_p := v$product_list [c$rk_entry_point].elements_p;
      number_of_products := v$product_list [c$rk_entry_point].element_count;
    ELSE { pvt [p$reference_type].value^.keyword_value = 'EXTERNAL_REFERENCE' THEN
      product_list_p := v$product_list [c$rk_external].elements_p;
      number_of_products := v$product_list [c$rk_external].element_count;
    IFEND;

{ If there are none, return an empty list.

    IF product_list_p = NIL THEN
      clp$make_list_value (work_area, result);
      RETURN;
    IFEND;

    IF pvt [p$pattern_type].value^.keyword_value = 'BASIC' THEN
      pattern_type := clc$wc_basic_pattern;
    ELSE
      pattern_type := clc$wc_extended_pattern;
    IFEND;

    all_selected := pvt [p$product].value^.kind = clc$keyword;
    IF NOT all_selected THEN

{ Convert the supplied patterns to the internal pattern representation.  Do this only once
{ and then compare with the names in the list.

      PUSH selected_patterns_p: [1 .. clp$count_list_elements (pvt [p$product].value)];
      node_p := pvt [p$product].value;
      FOR pattern_index := 1 TO UPPERBOUND (selected_patterns_p^) DO
        IF node_p^.element_value^.kind = clc$name THEN
          selected_patterns_p^ [pattern_index].pattern := FALSE;
          selected_patterns_p^ [pattern_index].name := node_p^.element_value^.name_value;
        ELSE { it's a pattern
          original_pattern_p := node_p^.element_value^.application_value;
          PUSH pattern_p: [STRLENGTH (original_pattern_p^)];

          IF pattern_type = clc$wc_basic_pattern THEN
            #TRANSLATE (osv$lower_to_upper, original_pattern_p^, pattern_p^);
          ELSE
            #TRANSLATE (osv$lower_to_upper_26, original_pattern_p^, pattern_p^);
          IFEND;

          selected_patterns_p^ [pattern_index].pattern := TRUE;
          clp$build_pattern_for_wild_card (pattern_type, $clt$string_pattern_build_opts
                [clc$sp_match_at_right, clc$sp_ignore_matched_substring], pattern_p^, work_area,
                selected_patterns_p^ [pattern_index].pattern_p, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        node_p := node_p^.link;
      FOREND;
    IFEND;
    result := NIL;
    data_value_pp := ^result;
    index := 1;
    WHILE (index <= number_of_products) DO
      IF NOT all_selected THEN

{ Compare the name with the patterns.

        match := FALSE;

        pattern_index := 1;
        WHILE (NOT match) AND (pattern_index <= UPPERBOUND (selected_patterns_p^)) DO
          IF selected_patterns_p^ [pattern_index].pattern THEN
            clp$match_string_pattern (product_list_p^ [index].
                  name_value (1, clp$trimmed_string_size (product_list_p^ [index].name_value)),
                  selected_patterns_p^ [pattern_index].pattern_p, clc$sp_anchored, clc$sp_quick_scan,
                  match_info, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            match := match_info.result = clc$sp_success;
          ELSE
            match := selected_patterns_p^ [pattern_index].name = product_list_p^ [index].name_value;
          IFEND;
          pattern_index := pattern_index + 1;
        WHILEND;
      IFEND;

      IF all_selected OR match THEN
        clp$make_list_value (work_area, data_value_pp^);
        data_value_pp^^.element_value := ^product_list_p^ [index];
        data_value_pp := ^data_value_pp^^.link;
      IFEND;
      index := index + 1;
    WHILEND;

{ If result is still NIL, no products were selected.

    IF result = NIL THEN
      clp$make_list_value (work_area, result);
    IFEND;

  PROCEND ocp$$product_list;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$$reference', EJECT ??

  PROCEDURE ocp$$reference_information
    (    parameter_list: clt$parameter_list;
     VAR work_area { input, output } : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (ocm$$proru_refi) $reference_information (
{   reference_type: key
{       (entry_point, entry_points, ep)
{       (external_reference, external_references, er)
{     keyend = $required
{   references: any of
{       key
{         all
{       keyend
{       list of program_name
{     anyend = all
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type2: 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,
          recend,
        recend,
        default_value: string (3),
      recend,
    recend := [
    [1,
    [90, 3, 28, 23, 12, 36, 829],
    clc$function, 2, 2, 1, 0, 0, 0, 0, 'OCM$$PRORU_REFI'], [
    ['REFERENCES                     ',clc$nominal_entry, 2],
    ['REFERENCE_TYPE                 ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [2, 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, 229,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [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, 83,
  clc$optional_default_parameter, 0, 3]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [6], [
    ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ENTRY_POINTS                   ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ER                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXTERNAL_REFERENCE             ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['EXTERNAL_REFERENCES            ', clc$alias_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 2
    [[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]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$program_name_type]]
      ]
    ,
    'all']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$reference_type = 1,
      p$references = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      all_selected: boolean,
      data_value_pp: ^^clt$data_value,
      entry_external_header_p: ^t$entry_external_file_header,
      entry_external_list_p: ^t$entry_external_list,
      index: ost$non_negative_integers,
      match: boolean,
      node_p: ^clt$data_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Decide whether to use entry points or externals.

    get_entry_external_list (pvt [p$reference_type].value^.keyword_value, entry_external_list_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ If there are none, return an empty list.

    IF entry_external_list_p = NIL THEN
      clp$make_list_value (work_area, result);
      RETURN;
    IFEND;

    all_selected := pvt [p$references].value^.kind = clc$keyword;
    result := NIL;
    data_value_pp := ^result;
    index := 1;
    WHILE (index <= UPPERBOUND (entry_external_list_p^)) DO
      IF NOT all_selected THEN
        match := FALSE;
        node_p := pvt [p$references].value;
        WHILE (NOT match) AND (node_p <> NIL) DO
          match := node_p^.element_value^.program_name_value = entry_external_list_p^ [index].name;
          node_p := node_p^.link;
        WHILEND;
      IFEND;

      IF all_selected OR match THEN
        clp$make_list_value (work_area, data_value_pp^);
        make_entry_external_record (entry_external_list_p^ [index], work_area, data_value_pp^^.element_value);
        data_value_pp := ^data_value_pp^^.link;
      IFEND;
      index := index + 1;
    WHILEND;

{ If result is still NIL, no references were selected.

    IF result = NIL THEN
      clp$make_list_value (work_area, result);
    IFEND;

  PROCEND ocp$$reference_information;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$$reference_list', EJECT ??

  PROCEDURE ocp$$reference_list
    (    parameter_list: clt$parameter_list;
     VAR work_area { input, output } : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (ocm$$proru_refl) $reference_list (
{   reference_type: key
{       (entry_point, entry_points, ep)
{       (external_reference, external_references, er)
{     keyend = $required
{   references: any of
{       key
{         all
{       keyend
{       list defer_expansion of program_name
{     anyend = all
{   pattern_type: key
{       (basic, b)
{       (extended, e)
{     keyend = $scl_options.wild_card_pattern_type
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type2: 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,
          recend,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (35),
      recend,
    recend := [
    [1,
    [90, 3, 28, 23, 12, 48, 86],
    clc$function, 3, 3, 1, 0, 0, 0, 0, 'OCM$$PRORU_REFL'], [
    ['PATTERN_TYPE                   ',clc$nominal_entry, 3],
    ['REFERENCES                     ',clc$nominal_entry, 2],
    ['REFERENCE_TYPE                 ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, 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, 229,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, 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, 83,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [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, 155,
  clc$optional_default_parameter, 0, 35]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [6], [
    ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ENTRY_POINTS                   ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ER                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXTERNAL_REFERENCE             ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['EXTERNAL_REFERENCES            ', clc$alias_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 2
    [[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]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, TRUE, FALSE],
        [[1, 0, clc$program_name_type]]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BASIC                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXTENDED                       ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    '$scl_options.wild_card_pattern_type']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$reference_type = 1,
      p$references = 2,
      p$pattern_type = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    TYPE
      patterns = array [1 .. * ] of record
        case pattern: boolean of
        = TRUE =
          pattern_p: ^clt$string_pattern,
        = FALSE =
          name: pmt$program_name,
        casend,
      recend;

    VAR
      all_selected: boolean,
      candidate_p: ^clt$string_value,
      data_value_pp: ^^clt$data_value,
      entry_external_header_p: ^t$entry_external_file_header,
      entry_external_list_p: ^t$entry_external_list,
      index: ost$non_negative_integers,
      match: boolean,
      match_info: clt$string_pattern_match_info,
      next_index: ost$non_negative_integers,
      node_p: ^clt$data_value,
      original_pattern_p: ^clt$string_value,
      pattern_index: ost$non_negative_integers,
      pattern_p: ^clt$string_value,
      pattern_type: clt$wild_card_pattern_type,
      selected_patterns_p: ^patterns;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Determine whether to use entry points or externals.

    get_entry_external_list (pvt [p$reference_type].value^.keyword_value, entry_external_list_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ If there are none, return an empty list.

    IF entry_external_list_p = NIL THEN
      clp$make_list_value (work_area, result);
      RETURN;
    IFEND;

    IF pvt [p$pattern_type].value^.keyword_value = 'BASIC' THEN
      pattern_type := clc$wc_basic_pattern;
    ELSE
      pattern_type := clc$wc_extended_pattern;
    IFEND;

    all_selected := pvt [p$references].value^.kind = clc$keyword;
    IF NOT all_selected THEN

{ Convert the specified patterns to their internal representation.  Do this only once
{ and then compare with the names later.

      PUSH selected_patterns_p: [1 .. clp$count_list_elements (pvt [p$references].value)];
      node_p := pvt [p$references].value;
      FOR pattern_index := 1 TO UPPERBOUND (selected_patterns_p^) DO
        IF node_p^.element_value^.kind = clc$program_name THEN
          selected_patterns_p^ [pattern_index].pattern := FALSE;
          selected_patterns_p^ [pattern_index].name := node_p^.element_value^.program_name_value;
        ELSE { it's a pattern
          original_pattern_p := node_p^.element_value^.application_value;
          PUSH pattern_p: [STRLENGTH (original_pattern_p^)];

          IF pattern_type = clc$wc_basic_pattern THEN
            #TRANSLATE (osv$lower_to_upper, original_pattern_p^, pattern_p^);
          ELSE
            #TRANSLATE (osv$lower_to_upper_26, original_pattern_p^, pattern_p^);
          IFEND;

          selected_patterns_p^ [pattern_index].pattern := TRUE;
          clp$build_pattern_for_wild_card (pattern_type, $clt$string_pattern_build_opts
                [clc$sp_match_at_right, clc$sp_ignore_matched_substring], pattern_p^, work_area,
                selected_patterns_p^ [pattern_index].pattern_p, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        node_p := node_p^.link;
      FOREND;
    IFEND;
    result := NIL;
    data_value_pp := ^result;
    index := 1;
    WHILE (index <= UPPERBOUND (entry_external_list_p^)) DO
      IF NOT all_selected THEN

{ Compare the name with the patterns.

        match := FALSE;

        pattern_index := 1;
        WHILE (NOT match) AND (pattern_index <= UPPERBOUND (selected_patterns_p^)) DO
          IF selected_patterns_p^ [pattern_index].pattern THEN
            clp$match_string_pattern (entry_external_list_p^ [index].
                  name (1, clp$trimmed_string_size (entry_external_list_p^ [index].name)),
                  selected_patterns_p^ [pattern_index].pattern_p, clc$sp_anchored, clc$sp_quick_scan,
                  match_info, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            match := match_info.result = clc$sp_success;
          ELSE
            match := selected_patterns_p^ [pattern_index].name = entry_external_list_p^ [index].name;
          IFEND;
          pattern_index := pattern_index + 1;
        WHILEND;
      IFEND;

      IF all_selected OR match THEN
        clp$make_list_value (work_area, data_value_pp^);
        clp$make_program_name_value (entry_external_list_p^ [index].name, work_area,
              data_value_pp^^.element_value);
        data_value_pp := ^data_value_pp^^.link;
      IFEND;
      next_index := index + 1;
      WHILE (next_index <= UPPERBOUND (entry_external_list_p^)) AND
            (entry_external_list_p^ [index].name = entry_external_list_p^ [next_index].name) DO
        next_index := next_index + 1;
      WHILEND;
      index := next_index;
    WHILEND;

{ If result is still NIL, no references were selected.

    IF result = NIL THEN
      clp$make_list_value (work_area, result);
    IFEND;
  PROCEND ocp$$reference_list;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$_add_library', EJECT ??

{ NOTE:
{   The procedure contained within this procedure to "crack" object libraries are
{ stripped down versions of the procedures for the command display_object_text.

  PROCEDURE ocp$_add_library
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$proru_addl) add_library, add_libraries, addl (
{   library, f, file, files, libraries, l: list of file = $required
{   product_name, pn: name = $required
{   control_data_names_only, cdno: (BY_NAME) boolean = TRUE
{   reference_type, rt: (BY_NAME) key
{       all
{       (entry_point, entry_points, ep)
{       (external_reference, external_references, er)
{     keyend = all
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 7] of clt$keyword_specification,
        default_value: string (3),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 3, 23, 10, 59, 57, 990],
    clc$command, 13, 5, 2, 0, 0, 0, 5, 'OCM$PRORU_ADDL'], [
    ['CDNO                           ',clc$abbreviation_entry, 3],
    ['CONTROL_DATA_NAMES_ONLY        ',clc$nominal_entry, 3],
    ['F                              ',clc$alias_entry, 1],
    ['FILE                           ',clc$alias_entry, 1],
    ['FILES                          ',clc$alias_entry, 1],
    ['L                              ',clc$abbreviation_entry, 1],
    ['LIBRARIES                      ',clc$alias_entry, 1],
    ['LIBRARY                        ',clc$nominal_entry, 1],
    ['PN                             ',clc$abbreviation_entry, 2],
    ['PRODUCT_NAME                   ',clc$nominal_entry, 2],
    ['REFERENCE_TYPE                 ',clc$nominal_entry, 4],
    ['RT                             ',clc$abbreviation_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 266,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 5
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [7], [
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['ENTRY_POINTS                   ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['ER                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['EXTERNAL_REFERENCE             ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['EXTERNAL_REFERENCES            ', clc$alias_entry, clc$normal_usage_entry, 3]]
    ,
    'all'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$library = 1,
      p$product_name = 2,
      p$control_data_names_only = 3,
      p$reference_type = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      add_entry_points: boolean,
      add_externals: boolean,
      control_data_names_only: boolean,
      entry_point_file_header_p: ^t$entry_external_file_header,
      entry_point_file_p: ^SEQ ( * ),
      external_file_header_p: ^t$entry_external_file_header,
      external_file_p: ^SEQ ( * ),
      file: ^SEQ ( * ),
      file_contents: amt$file_contents,
      file_identifier: amt$file_identifier,
      file_list_p: ^clt$data_value,
      file_name: ost$name,
      ignore_status: ost$status,
      module_name: pmt$program_name,
      new_entry_externals_p: ^t$entry_external_files,
      product_name: ost$name,
      sort_entry_external_list_p: ^t$entry_external_list,
      sort_file_header_p: ^t$entry_external_file_header,
      sort_file_p: ^SEQ ( * );

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Attempt to cleanup on block exit if something doesn't work.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF condition.selector = pmc$block_exit_processing THEN
        close_segment (entry_point_file_p, ignore_status);
        close_segment (external_file_p, ignore_status);
        fsp$close_file (file_identifier, ignore_status);
        RETURN;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'name_okay: boolean', EJECT ??

{   The purpose of this request is to determine if the format of the name matches
{ the requested name form.

    FUNCTION name_okay
      (    name: pmt$program_name;
           control_data_names_only: boolean): boolean;

      VAR
        s2: string (2);

      IF control_data_names_only THEN
        s2 := name (3, 2);
        name_okay := (s2 = 'P$') OR (s2 = 'V$') OR (s2 = 'p$') OR (s2 = 'v$');
      ELSE
        name_okay := TRUE;
      IFEND;
    FUNCEND name_okay;
?? OLDTITLE ??
?? NEWTITLE := 'process_object_text_descriptor', EJECT ??

    PROCEDURE process_object_text_descriptor
      (VAR file: ^SEQ ( * );
       VAR fatal_error: boolean;
       VAR end_of_file: boolean;
       VAR kind: llt$object_record_kind;
       VAR size: integer);

      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        file_position: ost$segment_offset;

      end_of_file := FALSE;

      NEXT object_text_descriptor IN file;
      IF object_text_descriptor = NIL THEN
        file_position := i#current_sequence_position (file);
        IF file_position >= #SIZE (file^) THEN
          end_of_file := TRUE;
        ELSE
          fatal_error := TRUE;
        IFEND;
        RETURN;
      IFEND;

      kind := object_text_descriptor^.kind;
      CASE object_text_descriptor^.kind OF
      = llc$identification, llc$section_definition, llc$bit_string_insertion, llc$entry_definition,
            llc$binding_template, llc$transfer_symbol, llc$segment_definition, llc$unallocated_common_block,
            llc$application_identifier, llc$obsolete_segment_definition =
        fatal_error := FALSE;

      = llc$libraries =
        size := object_text_descriptor^.number_of_libraries;
        fatal_error := object_text_descriptor^.number_of_libraries = 0;

      = llc$allotted_section_definition =
        size := object_text_descriptor^.allotted_section;

      = llc$allotted_segment_definition, llc$obsolete_allotted_seg_def =
        size := object_text_descriptor^.allotted_segment;
        size := (size * 100000000(16)) + object_text_descriptor^.allotted_segment_length; {kludge}

      = llc$text, llc$replication =
        size := object_text_descriptor^.number_of_bytes;
        fatal_error := object_text_descriptor^.number_of_bytes = 0;

      = llc$relocation =
        size := object_text_descriptor^.number_of_rel_items;
        fatal_error := object_text_descriptor^.number_of_rel_items = 0;

      = llc$address_formulation =
        size := object_text_descriptor^.number_of_adr_items;
        fatal_error := object_text_descriptor^.number_of_adr_items = 0;

      = llc$deferred_entry_points =
        size := object_text_descriptor^.number_of_entry_points;

      = llc$deferred_common_blocks =
        size := object_text_descriptor^.number_of_common_blocks;

      = llc$external_linkage =
        size := object_text_descriptor^.number_of_ext_items;
        fatal_error := object_text_descriptor^.number_of_ext_items = 0;

      = llc$obsolete_line_table, llc$line_table =
        size := object_text_descriptor^.number_of_line_items;
        fatal_error := object_text_descriptor^.number_of_line_items = 0;

      = llc$obsolete_formal_parameters, llc$formal_parameters, llc$actual_parameters,
            llc$cybil_symbol_table_fragment, llc$68000_absolute, llc$symbol_table, llc$form_definition,
            llc$supplemental_debug_tables =
        size := object_text_descriptor^.sequence_length;
        fatal_error := object_text_descriptor^.sequence_length = 0;

      = llc$ppu_absolute =
        size := object_text_descriptor^.number_of_words;
        fatal_error := object_text_descriptor^.number_of_words > llc$max_ppu_size;

      ELSE
        fatal_error := TRUE;
      CASEND;
    PROCEND process_object_text_descriptor;
?? OLDTITLE ??
?? NEWTITLE := 'process_identification_record', EJECT ??

    PROCEDURE process_identification_record
      (VAR file: ^SEQ ( * );
       VAR fatal_error: boolean;
       VAR module_kind: llt$module_kind);

      VAR
        valid: boolean,
        identification: ^llt$identification;

      NEXT identification IN file;
      fatal_error := identification = NIL;
      IF fatal_error THEN
        RETURN;
      IFEND;

      module_kind := identification^.kind;
      module_name := identification^.name;
    PROCEND process_identification_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_entry_definition_record', EJECT ??

    PROCEDURE process_entry_definition_record
      (    module_kind: llt$module_kind;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);

      VAR
        entry_point_p: ^t$entry_external,
        entry_definition: ^llt$entry_definition;

      NEXT entry_definition IN file;
      fatal_error := entry_definition = NIL;
      IF fatal_error THEN
        RETURN;
      IFEND;

      IF (NOT (module_kind IN valid_module_kinds)) OR (NOT add_entry_points) THEN
        RETURN;
      IFEND;

      IF entry_point_file_p = NIL THEN
        RETURN;
      IFEND;

      IF name_okay (entry_definition^.name, control_data_names_only) THEN
        NEXT entry_point_p IN entry_point_file_p;
        entry_point_file_header_p^.entry_point_count := entry_point_file_header_p^.entry_point_count + 1;
        entry_point_p^.name := entry_definition^.name;
        entry_point_p^.module_name := module_name;
        entry_point_p^.product_name := product_name;
        entry_point_p^.language := entry_definition^.language;
        entry_point_p^.declaration_matching_required := entry_definition^.declaration_matching_required;
        entry_point_p^.declaration_matching := entry_definition^.declaration_matching;
        entry_point_p^.attributes := entry_definition^.attributes;
      IFEND;
    PROCEND process_entry_definition_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_deferred_entry_points', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display the deferred entry point object text record.

    PROCEDURE process_deferred_entry_points
      (    module_kind: llt$module_kind;
           number_of_entry_points: 1 .. llc$max_deferred_entry_points;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);

      VAR
        entry_point_p: ^t$entry_external,
        deferred_entry_points: ^llt$deferred_entry_points,
        entry_point_index: 1 .. llc$max_deferred_entry_points;

      NEXT deferred_entry_points: [1 .. number_of_entry_points] IN file;
      fatal_error := deferred_entry_points = NIL;
      IF fatal_error THEN
        RETURN;
      IFEND;

      IF (NOT (module_kind IN valid_module_kinds)) OR (NOT add_entry_points) THEN
        RETURN;
      IFEND;

      IF entry_point_file_p = NIL THEN
        RETURN;
      IFEND;

      FOR entry_point_index := 1 TO number_of_entry_points DO

        IF name_okay (deferred_entry_points^ [entry_point_index].name, control_data_names_only) THEN
          NEXT entry_point_p IN entry_point_file_p;
          entry_point_file_header_p^.entry_point_count := entry_point_file_header_p^.entry_point_count + 1;
          entry_point_p^.name := deferred_entry_points^ [entry_point_index].name;
          entry_point_p^.module_name := module_name;
          entry_point_p^.product_name := product_name;
          entry_point_p^.language := deferred_entry_points^ [entry_point_index].language;
          entry_point_p^.declaration_matching_required := deferred_entry_points^ [entry_point_index].
                declaration_matching_required;
          entry_point_p^.declaration_matching := deferred_entry_points^ [entry_point_index].
                declaration_matching_value;
          entry_point_p^.attributes := deferred_entry_points^ [entry_point_index].attributes;
        IFEND;
      FOREND;
    PROCEND process_deferred_entry_points;
?? OLDTITLE ??
?? NEWTITLE := 'process_external_linkage', EJECT ??

    PROCEDURE process_external_linkage
      (    module_kind: llt$module_kind;
           number_of_ext_items: 1 .. llc$max_ext_items;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);

      VAR
        external_p: ^t$entry_external,
        external: ^llt$external_linkage,
        i: 1 .. llc$max_ext_items;

      NEXT external: [1 .. number_of_ext_items] IN file;
      fatal_error := external = NIL;
      IF fatal_error THEN
        RETURN;
      IFEND;

      IF (NOT (module_kind IN valid_module_kinds)) OR (NOT add_externals) THEN
        RETURN;
      IFEND;

      IF external_file_p = NIL THEN
        RETURN;
      IFEND;

      IF name_okay (external^.name, control_data_names_only) THEN
        NEXT external_p IN external_file_p;
        external_file_header_p^.external_count := external_file_header_p^.external_count + 1;
        external_p^.name := external^.name;
        external_p^.module_name := module_name;
        external_p^.product_name := product_name;
        external_p^.language := external^.language;
        external_p^.declaration_matching_required := external^.declaration_matching_required;
        external_p^.declaration_matching := external^.declaration_matching;
        external_p^.attributes := $llt$entry_point_attributes [];
      IFEND;
    PROCEND process_external_linkage;
?? OLDTITLE ??
?? NEWTITLE := 'process_cpu_module', EJECT ??

    PROCEDURE process_cpu_module
      (    module_kind: llt$module_kind;
       VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);

      VAR
        actual_parameters: ^llt$actual_parameters,
        address_formulation: ^llt$address_formulation,
        application_identifier: ^llt$application_identifier,
        binding_template: ^llt$binding_template,
        bit_insertion: ^llt$bit_string_insertion,
        debug_table_fragment: ^llt$debug_table_fragment,
        deferred_common_blocks: ^llt$deferred_common_blocks,
        end_of_file: boolean,
        formal_parameters: ^llt$formal_parameters,
        libraries: ^llt$libraries,
        line_address_table: ^llt$line_address_table,
        m68000_absolute: ^llt$68000_absolute,
        obsolete_formal_parameters: ^llt$obsolete_formal_parameters,
        obsolete_line_address_table: ^llt$obsolete_line_address_table,
        obsolete_segment_definition: ^llt$obsolete_segment_definition,
        record_kind: llt$object_record_kind,
        relocation: ^llt$relocation,
        replication: ^llt$replication,
        s: llt$section_ordinal,
        section_definition: ^llt$section_definition,
        segment_definition: ^llt$segment_definition,
        size: integer,
        supplemental_debug_tables: ^llt$supplemental_debug_tables,
        symbol_table: ^llt$symbol_table,
        text: ^llt$text,
        transfer_symbol: ^llt$transfer_symbol;

      REPEAT
        process_object_text_descriptor (file, fatal_error, end_of_file, record_kind, size);
        IF NOT fatal_error THEN
          IF end_of_file THEN
            fatal_error := TRUE;
          ELSE
            CASE record_kind OF
            = llc$identification =
              fatal_error := TRUE;

            = llc$libraries =
              NEXT libraries: [1 .. size] IN file;
              fatal_error := libraries = NIL;

            = llc$section_definition, llc$unallocated_common_block =
              NEXT section_definition IN file;
              fatal_error := section_definition = NIL;

            = llc$allotted_section_definition =
              NEXT section_definition IN file;
              fatal_error := section_definition = NIL;

            = llc$segment_definition =
              NEXT segment_definition IN file;
              fatal_error := segment_definition = NIL;

            = llc$allotted_segment_definition =
              NEXT segment_definition IN file;
              fatal_error := segment_definition = NIL;

            = llc$obsolete_segment_definition =
              NEXT obsolete_segment_definition IN file;
              fatal_error := obsolete_segment_definition = NIL;

            = llc$obsolete_allotted_seg_def =
              NEXT obsolete_segment_definition IN file;
              fatal_error := obsolete_segment_definition = NIL;

            = llc$text =
              NEXT text: [1 .. size] IN file;
              fatal_error := text = NIL;

            = llc$replication =
              NEXT replication: [1 .. size] IN file;
              fatal_error := replication = NIL;

            = llc$bit_string_insertion =
              NEXT bit_insertion IN file;
              fatal_error := bit_insertion = NIL;

            = llc$entry_definition =
              process_entry_definition_record (module_kind, file, fatal_error);

            = llc$deferred_entry_points =
              process_deferred_entry_points (module_kind, size, file, fatal_error);

            = llc$deferred_common_blocks =
              NEXT deferred_common_blocks: [1 .. size] IN file;
              fatal_error := deferred_common_blocks = NIL;

            = llc$relocation =
              NEXT relocation: [1 .. size] IN file;
              fatal_error := relocation = NIL;

            = llc$obsolete_formal_parameters =
              NEXT obsolete_formal_parameters: [[REP size OF cell]] IN file;
              fatal_error := obsolete_formal_parameters = NIL;

            = llc$formal_parameters =
              NEXT formal_parameters: [[REP size OF cell]] IN file;
              fatal_error := formal_parameters = NIL;

            = llc$actual_parameters =
              NEXT actual_parameters: [[REP size OF cell]] IN file;
              fatal_error := actual_parameters = NIL;

            = llc$obsolete_line_table =
              NEXT obsolete_line_address_table: [1 .. size] IN file;
              fatal_error := obsolete_line_address_table = NIL;

            = llc$cybil_symbol_table_fragment =
              NEXT debug_table_fragment: [[REP size OF cell]] IN file;
              fatal_error := debug_table_fragment = NIL;

            = llc$line_table =
              NEXT line_address_table: [1 .. size] IN file;
              fatal_error := line_address_table = NIL;

            = llc$symbol_table =
              NEXT symbol_table: [[REP size OF cell]] IN file;
              fatal_error := symbol_table = NIL;

            = llc$supplemental_debug_tables =
              NEXT supplemental_debug_tables: [[REP size OF cell]] IN file;
              fatal_error := supplemental_debug_tables = NIL;

            = llc$form_definition =
              ;

            = llc$application_identifier =
              NEXT application_identifier IN file;
              fatal_error := application_identifier = NIL;

            = llc$address_formulation =
              NEXT address_formulation: [1 .. size] IN file;
              fatal_error := address_formulation = NIL;

            = llc$external_linkage =
              process_external_linkage (module_kind, size, file, fatal_error);

            = llc$binding_template =
              NEXT binding_template IN file;
              fatal_error := binding_template = NIL;

            = llc$68000_absolute =
              NEXT m68000_absolute: [[REP size OF cell]] IN file;
              fatal_error := m68000_absolute = NIL;

            = llc$transfer_symbol =
              NEXT transfer_symbol IN file;
              fatal_error := transfer_symbol = NIL;

            ELSE
              fatal_error := TRUE;
            CASEND;
          IFEND;
        IFEND;
      UNTIL fatal_error OR (record_kind = llc$transfer_symbol);

    PROCEND process_cpu_module;
?? OLDTITLE ??
?? NEWTITLE := 'process_iou_module', EJECT ??

    PROCEDURE process_iou_module
      (VAR file: ^SEQ ( * );
       VAR fatal_error: boolean);

      VAR
        ppu_absolute: ^llt$ppu_absolute,
        end_of_file: boolean,
        record_kind: llt$object_record_kind,
        size: integer;

      process_object_text_descriptor (file, fatal_error, end_of_file, record_kind, size);

      IF NOT fatal_error THEN
        IF end_of_file THEN
          fatal_error := TRUE;
        ELSE
          IF record_kind = llc$ppu_absolute THEN
            NEXT ppu_absolute: [0 .. size - 1] IN file;
            fatal_error := ppu_absolute = NIL;
          ELSE
            fatal_error := TRUE;
          IFEND;
        IFEND;
      IFEND;
    PROCEND process_iou_module;
?? OLDTITLE ??
?? NEWTITLE := 'process_object_file', EJECT ??

    PROCEDURE process_object_file
      (VAR file: ^SEQ ( * ));

      VAR
        fatal_error: [STATIC] boolean := FALSE,
        end_of_file: boolean,
        record_kind: llt$object_record_kind,
        size: integer,
        module_kind: llt$module_kind;

      REPEAT
        process_object_text_descriptor (file, fatal_error, end_of_file, record_kind, size);

        IF NOT (end_of_file OR fatal_error) THEN
          IF record_kind <> llc$identification THEN
            fatal_error := TRUE;
          ELSE
            process_identification_record (file, fatal_error, module_kind);
          IFEND;

          IF NOT fatal_error THEN
            CASE module_kind OF
            = llc$mi_virtual_state, llc$vector_virtual_state, llc$motorola_68000, llc$motorola_68000_absolute,
                  llc$vector_extended_state =
              process_cpu_module (module_kind, file, fatal_error);
            = llc$iou =
              process_iou_module (file, fatal_error);
            ELSE
              fatal_error := TRUE;
            CASEND;
          IFEND;
        IFEND;

      UNTIL end_of_file OR fatal_error;
    PROCEND process_object_file;
?? OLDTITLE ??
?? NEWTITLE := 'process_object_library', EJECT ??

    PROCEDURE process_object_library
      (VAR file: ^SEQ ( * ));

?? NEWTITLE := 'process_library_module', EJECT ??

      PROCEDURE process_library_modules
        (    number_of_modules: 0 .. llc$max_modules_in_library;
             module_dictionary: ^llt$module_dictionary;
         VAR file: ^SEQ ( * ));

        VAR
          application_member_header: ^llt$application_member_header,
          valid_position: boolean,
          i: 1 .. llc$max_modules_in_library,
          load_module_header: ^llt$load_module_header,
          object_text_descriptor: ^llt$object_text_descriptor,
          library_member_header: ^llt$library_member_header;

?? NEWTITLE := 'process_interpretive_element', EJECT ??

        PROCEDURE process_interpretive_element
          (    load_module_header: ^llt$load_module_header;
           VAR file: ^SEQ ( * ));

          VAR
            interpretive_element: ^llt$object_text_descriptor,
            fatal_error: boolean,
            end_of_file: boolean,
            record_kind: llt$object_record_kind,
            size: integer,
            module_kind: llt$module_kind;

          fatal_error := FALSE;

          interpretive_element := #PTR (load_module_header^.interpretive_element, file^);
          fatal_error := interpretive_element = NIL;
          IF fatal_error THEN
            RETURN;
          IFEND;
          RESET file TO interpretive_element;

          process_object_text_descriptor (file, fatal_error, end_of_file, record_kind, size);
          IF NOT fatal_error THEN
            IF NOT end_of_file THEN
              IF record_kind <> llc$identification THEN
                fatal_error := TRUE;
              ELSE
                process_identification_record (file, fatal_error, module_kind);
                IF NOT fatal_error THEN
                  CASE module_kind OF
                  = llc$mi_virtual_state, llc$vector_virtual_state, llc$motorola_68000,
                        llc$motorola_68000_absolute, llc$vector_extended_state =
                    process_cpu_module (module_kind, file, fatal_error);
                  ELSE
                  CASEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        PROCEND process_interpretive_element;
?? OLDTITLE ??
?? EJECT ??

        FOR i := 1 TO number_of_modules DO
          IF module_dictionary^ [i].kind = llc$load_module THEN
            load_module_header := #PTR (module_dictionary^ [i].module_header, file^);
            IF (llc$interpretive_element IN load_module_header^.elements_defined) THEN
              process_interpretive_element (load_module_header, file);
            IFEND;
          IFEND;
        FOREND;
      PROCEND process_library_modules;
?? OLDTITLE ??
?? EJECT ??

      VAR
        library_header: ^llt$object_library_header,
        library_hdr: ^llt$object_library_header_v1_0,
        module_dictionary: ^llt$module_dictionary,
        module_dictionary_size: 0 .. llc$max_modules_in_library,
        dictionary_size: integer,
        library_dictionary: ^llt$object_library_dictionaries,
        i: 0 .. llc$max_dictionaries_on_library;


      NEXT library_header IN file;
      IF library_header = NIL THEN
        RETURN;
      IFEND;

      IF library_header^.version = llc$object_library_version THEN
        NEXT library_dictionary: [1 .. library_header^.number_of_dictionaries] IN file;
        IF library_dictionary = NIL THEN
          RETURN;
        IFEND;

        FOR i := LOWERBOUND (library_dictionary^) TO UPPERBOUND (library_dictionary^) DO

          CASE library_dictionary^ [i].kind OF

          = llc$module_dictionary =
            module_dictionary := #PTR (library_dictionary^ [i].module_dictionary, file^);
            module_dictionary_size := UPPERBOUND (module_dictionary^);

          ELSE
          CASEND;

        FOREND;

        process_library_modules (module_dictionary_size, module_dictionary, file);

      ELSEIF library_header^.version = 'V1.0' THEN

        RESET file;
        NEXT library_hdr IN file;

        module_dictionary := #PTR (library_hdr^.module_dictionary, file^);
        IF module_dictionary = NIL THEN
          RETURN;
        IFEND;

        process_library_modules (library_hdr^.number_of_modules, module_dictionary, file);

      IFEND;

    PROCEND process_object_library;
?? OLDTITLE ??
?? NEWTITLE := 'obtain_object_file', EJECT ??

    PROCEDURE obtain_object_file
      (    file_reference: fst$file_reference;
       VAR file_name: ost$name;
       VAR file: ^SEQ ( * );
       VAR file_contents: amt$file_contents;
       VAR file_identifier: amt$file_identifier;
       VAR status: ost$status);

      VAR
        attachment_options: array [1 .. 5] of fst$attachment_option,
        cycle_attribute_values: fst$cycle_attribute_values,
        ignore_user_defined_attr_size: fst$user_defined_attribute_size,
        resolved_file_reference: fst$resolved_file_reference,
        segment: amt$segment_pointer,
        validation_attributes: array [1 .. 2] of fst$file_cycle_attribute;

      validation_attributes [1].selector := fsc$file_contents_and_processor;
      validation_attributes [1].file_contents := fsc$object_library;
      validation_attributes [1].file_processor := osc$null_name;
      validation_attributes [2].selector := fsc$file_contents_and_processor;
      validation_attributes [2].file_contents := fsc$object_data;
      validation_attributes [2].file_processor := osc$null_name;
      attachment_options [1].selector := fsc$access_and_share_modes;
      attachment_options [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options [1].access_modes.value := $fst$file_access_options [fsc$read];
      attachment_options [1].share_modes.selector := fsc$specific_share_modes;
      attachment_options [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
      attachment_options [2].selector := fsc$open_share_modes;
      attachment_options [2].open_share_modes := $fst$file_access_options [fsc$read, fsc$execute];
      attachment_options [3].selector := fsc$create_file;
      attachment_options [3].create_file := FALSE;
      attachment_options [4].selector := fsc$sequential_access;
      attachment_options [4].sequential_access := TRUE;
      attachment_options [5].selector := fsc$free_behind;
      attachment_options [5].free_behind := TRUE;

      fsp$open_file (file_reference, amc$segment, ^attachment_options, NIL, NIL, ^validation_attributes, NIL,
            file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fsp$get_open_information (file_identifier, NIL, NIL, NIL, ^cycle_attribute_values, NIL,
            ^resolved_file_reference, NIL, ignore_user_defined_attr_size, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      file_name := resolved_file_reference.path (resolved_file_reference.file_name.index,
            resolved_file_reference.file_name.size);
      file_contents := cycle_attribute_values.file_contents;

      amp$get_segment_pointer (file_identifier, amc$sequence_pointer, segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      file := segment.sequence_pointer;
      RESET file;

    PROCEND obtain_object_file;
?? OLDTITLE ??
?? EJECT ??
    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    control_data_names_only := pvt [p$control_data_names_only].value^.boolean_value.value;
    product_name := pvt [p$product_name].value^.name_value;
    add_entry_points := (pvt [p$reference_type].value^.keyword_value = 'ALL') OR
          (pvt [p$reference_type].value^.keyword_value = 'ENTRY_POINT');
    add_externals := (pvt [p$reference_type].value^.keyword_value = 'ALL') OR
          (pvt [p$reference_type].value^.keyword_value = 'EXTERNAL_REFERENCE');

    entry_point_file_p := NIL;
    external_file_p := NIL;
    #SPOIL (entry_point_file_p, external_file_p);
    osp$establish_block_exit_hndlr (^condition_handler);

{ Create a scratch file for entry points and another one for externals.

    open_segment (entry_point_file_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    NEXT entry_point_file_header_p IN entry_point_file_p;
    IF entry_point_file_header_p = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 027', status);
      RETURN;
    IFEND;
    entry_point_file_header_p^.identification := c$entry_external_id;
    entry_point_file_header_p^.entry_point_count := 0;
    entry_point_file_header_p^.external_count := 0;

    open_segment (external_file_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    NEXT external_file_header_p IN external_file_p;
    IF external_file_header_p = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 028', status);
      RETURN;
    IFEND;
    external_file_header_p^.identification := c$entry_external_id;
    external_file_header_p^.entry_point_count := 0;
    external_file_header_p^.external_count := 0;

    file_list_p := pvt [p$library].value;
    WHILE file_list_p <> NIL DO
      obtain_object_file (file_list_p^.element_value^.file_value^, file_name, file, file_contents,
            file_identifier, status);
      log_message ('Cannot open library or object file:');
      log_message (file_list_p^.element_value^.file_value^);
      IF status.normal THEN
        IF file_contents = fsc$object_library THEN
          process_object_library (file);
        ELSE
          process_object_file (file);
        IFEND;

        fsp$close_file (file_identifier, ignore_status);
      IFEND;

      file_list_p := file_list_p^.link;
    WHILEND;

{ File has been verified.  Don't need to check for NIL.

    IF entry_point_file_header_p^.entry_point_count > 0 THEN
      sort_file_p := entry_point_file_p;
      RESET sort_file_p;
      NEXT sort_file_header_p IN sort_file_p;
      NEXT sort_entry_external_list_p: [1 .. sort_file_header_p^.entry_point_count] IN sort_file_p;
      sort_entry_external_list (sort_entry_external_list_p);
      remove_duplicates (entry_point_file_p);
    IFEND;

    IF external_file_header_p^.external_count > 0 THEN
      sort_file_p := external_file_p;
      RESET sort_file_p;
      NEXT sort_file_header_p IN sort_file_p;
      NEXT sort_entry_external_list_p: [1 .. sort_file_header_p^.external_count] IN sort_file_p;
      sort_entry_external_list (sort_entry_external_list_p);
      remove_duplicates (external_file_p);
    IFEND;

    PUSH new_entry_externals_p: [1 .. 1];
    RESET entry_point_file_p;
    NEXT entry_point_file_header_p IN entry_point_file_p;
    IF entry_point_file_header_p^.entry_point_count > 0 THEN
      NEXT new_entry_externals_p^ [1].entry_point_list_p: [1 .. entry_point_file_header_p^.
            entry_point_count] IN entry_point_file_p;
    ELSE
      new_entry_externals_p^ [1].entry_point_list_p := NIL;
    IFEND;
    RESET external_file_p;
    NEXT external_file_header_p IN external_file_p;
    IF external_file_header_p^.external_count > 0 THEN
      NEXT new_entry_externals_p^ [1].external_list_p: [1 .. external_file_header_p^.external_count] IN
            external_file_p;
    ELSE
      new_entry_externals_p^ [1].external_list_p := NIL;
    IFEND;

    merge_with_working_file (new_entry_externals_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    close_segment (entry_point_file_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    close_segment (external_file_p, status);
    osp$disestablish_cond_handler;
  PROCEND ocp$_add_library;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$_add_reference_file', EJECT ??

  PROCEDURE ocp$_add_reference_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$proru_addrf) add_reference_file, add_reference_files, addrf (
{   file, files, f: list 1..1000 of file = $required
{   reference_type, rt: (BY_NAME) key
{       all
{       (entry_point, entry_points, ep)
{       (external_reference, external_references, er)
{     keyend = all
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 7] of clt$keyword_specification,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 3, 19, 19, 51, 47, 439],
    clc$command, 6, 3, 1, 0, 0, 0, 3, 'OCM$PRORU_ADDRF'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['FILES                          ',clc$alias_entry, 1],
    ['REFERENCE_TYPE                 ',clc$nominal_entry, 2],
    ['RT                             ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 266,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, 1000, 0, FALSE, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [7], [
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['ENTRY_POINTS                   ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['ER                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['EXTERNAL_REFERENCE             ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['EXTERNAL_REFERENCES            ', clc$alias_entry, clc$normal_usage_entry, 3]]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$reference_type = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    TYPE
      source_list = record
        file_identifier: amt$file_identifier,
        file_p: ^SEQ ( * ),
      recend;

    VAR
      add_entry_points: boolean,
      add_externals: boolean,
      entry_external_file_list_p: ^clt$data_value,
      entry_external_files_p: ^t$entry_external_files,
      entry_external_header_p: ^t$entry_external_file_header,
      file_index: 1 .. clc$max_list_size,
      source_file_count: 1 .. clc$max_list_size,
      source_file_list_p: ^array [1 .. * ] of source_list,
      target_entry_external_p: ^t$entry_external,
      target_fid: amt$file_identifier,
      target_file_header_p: ^t$entry_external_file_header,
      target_file_p: ^SEQ ( * );

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Attempt to cleanup on block exit if something doesn't work.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF condition.selector = pmc$block_exit_processing THEN
        FOR file_index := 1 TO source_file_count DO
          fsp$close_file (source_file_list_p^ [file_index].file_identifier, ignore_status);
        FOREND;
        RETURN;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;
?? OLDTITLE ??
    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_entry_points := (pvt [p$reference_type].value^.keyword_value = 'ALL') OR
          (pvt [p$reference_type].value^.keyword_value = 'ENTRY_POINT');
    add_externals := (pvt [p$reference_type].value^.keyword_value = 'ALL') OR
          (pvt [p$reference_type].value^.keyword_value = 'EXTERNAL_REFERENCE');
    source_file_count := clp$count_list_elements (pvt [p$file].value);
    #SPOIL (source_file_count);
    PUSH source_file_list_p: [1 .. source_file_count];
    PUSH entry_external_files_p: [1 .. source_file_count];
    entry_external_file_list_p := pvt [p$file].value;
    osp$establish_block_exit_hndlr (^condition_handler);

{ Open all of the specified reference files and add the files to the merge file list.

    FOR file_index := 1 TO source_file_count DO
      open_source_file (entry_external_file_list_p^.element_value^.file_value^,
            source_file_list_p^ [file_index].file_p, source_file_list_p^ [file_index].file_identifier,
            status);
      #SPOIL (source_file_list_p^ [file_index]);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      NEXT entry_external_header_p IN source_file_list_p^ [file_index].file_p;

      IF (entry_external_header_p = NIL) OR (entry_external_header_p^.identification <> c$entry_external_id)
            THEN
        osp$set_status_condition (oce$e_bad_input_file, status);
        osp$append_status_file (osc$status_parameter_delimiter,
              entry_external_file_list_p^.element_value^.file_value^, status);
        RETURN;
      IFEND;

      IF entry_external_header_p^.entry_point_count > 0 THEN
        NEXT entry_external_files_p^ [file_index].entry_point_list_p:
              [1 .. entry_external_header_p^.entry_point_count] IN source_file_list_p^ [file_index].file_p;
        IF entry_external_files_p^ [file_index].entry_point_list_p = NIL THEN
          osp$set_status_condition (oce$premature_eof_in_segment, status);
          osp$append_status_file (osc$status_parameter_delimiter,
                entry_external_file_list_p^.element_value^.file_value^, status);
          RETURN;
        IFEND;
      ELSE
        entry_external_files_p^ [file_index].entry_point_list_p := NIL;
      IFEND;
      IF entry_external_header_p^.external_count > 0 THEN
        NEXT entry_external_files_p^ [file_index].external_list_p:
              [1 .. entry_external_header_p^.external_count] IN source_file_list_p^ [file_index].file_p;
        IF entry_external_files_p^ [file_index].external_list_p = NIL THEN
          osp$set_status_condition (oce$premature_eof_in_segment, status);
          osp$append_status_file (osc$status_parameter_delimiter,
                entry_external_file_list_p^.element_value^.file_value^, status);
          RETURN;
        IFEND;
      ELSE
        entry_external_files_p^ [file_index].external_list_p := NIL;
      IFEND;
      entry_external_file_list_p := entry_external_file_list_p^.link;
    FOREND;

    merge_with_working_file (entry_external_files_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR file_index := 1 TO source_file_count DO
      fsp$close_file (source_file_list_p^ [file_index].file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;
    osp$disestablish_cond_handler;
  PROCEND ocp$_add_reference_file;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$_add_task_services', EJECT ??

  PROCEDURE ocp$_add_task_services
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$proru_addts) add_task_services, addts (
{   product_name, pn: name = $required
{   job_image, ji: file = $required
{   system_debug_table, sdt: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 3, 26, 9, 39, 29, 416],
    clc$command, 7, 4, 3, 0, 0, 0, 4, 'OCM$PRORU_ADDTS'], [
    ['JI                             ',clc$abbreviation_entry, 2],
    ['JOB_IMAGE                      ',clc$nominal_entry, 2],
    ['PN                             ',clc$abbreviation_entry, 1],
    ['PRODUCT_NAME                   ',clc$nominal_entry, 1],
    ['SDT                            ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['SYSTEM_DEBUG_TABLE             ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$file_type]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$product_name = 1,
      p$job_image = 2,
      p$system_debug_table = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      debug_fid: amt$file_identifier,
      debug_file_p: ^SEQ ( * ),
      debug_header_p: ^pmt$linker_debug_table_header,
      entry_point_fid: amt$file_identifier,
      entry_point_file_p: ^SEQ ( * ),
      entry_point_header_p: ^t$entry_external_file_header,
      entry_point_p: ^t$entry_external,
      found: boolean,
      index: integer,
      job_image_fid: amt$file_identifier,
      job_image_file_p: ^SEQ ( * ),
      job_image_header_p: ^pmt$virtual_memory_image_header,
      new_entry_externals_p: ^t$entry_external_files,
      task_services_address: pmt$segment_and_offset,
      task_services_entry_points_p: ^array [1 .. * ] of oct$task_services_entry_point;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Attempt to cleanup on block exit if something doesn't work.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF condition.selector = pmc$block_exit_processing THEN
        fsp$close_file (debug_fid, ignore_status);
        fsp$close_file (job_image_fid, ignore_status);
        close_segment (entry_point_file_p, ignore_status);
        clp$close_display (v$display_control, ignore_status);
        v$output_file_open := FALSE;
        #SPOIL (v$output_file_open);
        RETURN;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'find_task_services_address', EJECT ??

    PROCEDURE find_task_services_address
      (VAR found: boolean;
       VAR address: pmt$segment_and_offset);

      CONST
        task_services_entry_points = 'LOV$TASK_SERVICES_ENTRY_POINTS';

      VAR
        temp: integer,
        entry_points: ^pmt$entry_point_items,
        lower: pmt$number_of_debug_items,
        upper: pmt$number_of_debug_items,
        mid: pmt$number_of_debug_items;

      found := FALSE;
      IF debug_header_p^.number_of_entry_points = 0 THEN
        RETURN;
      IFEND;

      entry_points := #PTR (debug_header_p^.entry_point_items, debug_file_p^);
      lower := LOWERBOUND (entry_points^);
      upper := UPPERBOUND (entry_points^);
      WHILE (lower <= upper) DO
        temp := lower + upper;
        mid := temp DIV 2;
        IF (entry_points^ [mid].name = task_services_entry_points) THEN
          address := entry_points^ [mid].address;
          found := TRUE;
          RETURN;
        ELSEIF (entry_points^ [mid].name < task_services_entry_points) THEN
          lower := mid + 1;
        ELSE
          upper := mid - 1;
        IFEND;
      WHILEND;

    PROCEND find_task_services_address;
?? OLDTITLE ??
?? NEWTITLE := 'find_task_services_in_image', EJECT ??

    PROCEDURE find_task_services_in_image
      (    task_services_address: pmt$segment_and_offset;
       VAR image_file_p: ^SEQ ( * );
       VAR task_services_entry_points_p: ^array [1 .. * ] of oct$task_services_entry_point;
       VAR status: ost$status);

      VAR
        adaptable_array_p: ^ost$adaptable_array_pointer,
        address_converter: record
          case boolean of
          = TRUE =
            segment_and_offset: pmt$segment_and_offset,
          = FALSE =
            segment_number: ost$segment,
            segment_length: ost$segment_length,
          casend,
        recend,
        first_segment_description_p: ^pmt$linked_segment_description,
        found: boolean,
        hunk_p: ^array [0 .. * ] of cell,
        image_file_header_p: ^pmt$virtual_memory_image_header,
        pva_converter: record
          case boolean of
          = TRUE =
            cell_p: ^cell,
          = FALSE =
            pva: ost$pva,
          casend,
        recend,
        segment_description_p: ^pmt$linked_segment_description;

?? NEWTITLE := 'find_segment', EJECT ??

      PROCEDURE find_segment
        (    segment_number: ost$segment;
             image_file_header_p: ^pmt$virtual_memory_image_header;
         VAR image_file_p: ^SEQ ( * );
         VAR segment_description_p: ^pmt$linked_segment_description;
         VAR found: boolean);

        VAR
          hunk_p: ^array [0 .. * ] of cell,
          index: ost$segment;

        found := FALSE;
        FOR index := 1 TO image_file_header_p^.number_of_segments DO
          NEXT segment_description_p IN image_file_p;
          IF segment_description_p = NIL THEN
            RETURN;
          IFEND;
          IF segment_description_p^.segment_number = segment_number THEN
            found := TRUE;
            RETURN;
          ELSE
            NEXT hunk_p: [0 .. segment_description_p^.length - 1] IN image_file_p;
          IFEND;
        FOREND;

      PROCEND find_segment;

?? OLDTITLE ??
?? EJECT ??

      status.normal := TRUE;
      address_converter.segment_and_offset := task_services_address;

      NEXT image_file_header_p IN image_file_p;
      IF (image_file_header_p = NIL) OR (image_file_header_p^.version <> pmc$image_version) THEN
        osp$set_status_condition (oce$e_bad_input_file, status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$job_image].value^.file_value^, status);
        RETURN;
      IFEND;

      NEXT first_segment_description_p IN image_file_p;
      IF first_segment_description_p = NIL THEN
        osp$set_status_condition (oce$premature_eof_in_segment, status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$job_image].value^.file_value^, status);
        RETURN;
      IFEND;
      RESET image_file_p TO first_segment_description_p;

      find_segment (address_converter.segment_number, image_file_header_p, image_file_p,
            segment_description_p, found);
      IF NOT found THEN
        osp$set_status_abnormal ('OC', oce$e_section_or_seg_not_found, 'TASK SERVICES', status);
        RETURN;
      IFEND;

      NEXT hunk_p: [0 .. (address_converter.segment_length - 1)] IN image_file_p;
      IF hunk_p = NIL THEN
        osp$set_status_condition (oce$premature_eof_in_segment, status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$job_image].value^.file_value^, status);
        RETURN;
      IFEND;
      NEXT adaptable_array_p IN image_file_p;
      IF adaptable_array_p = NIL THEN
        osp$set_status_condition (oce$premature_eof_in_segment, status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$job_image].value^.file_value^, status);
        RETURN;
      IFEND;
      pva_converter.cell_p := adaptable_array_p^.pointer;

      RESET image_file_p TO first_segment_description_p;
      find_segment (pva_converter.pva.seg, image_file_header_p, image_file_p, segment_description_p, found);
      IF NOT found THEN
        osp$set_status_abnormal ('OC', oce$e_section_or_seg_not_found, 'TASK SERVICES', status);
        RETURN;
      IFEND;

      NEXT hunk_p: [0 .. (pva_converter.pva.offset - 1)] IN image_file_p;
      IF hunk_p = NIL THEN
        osp$set_status_condition (oce$premature_eof_in_segment, status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$job_image].value^.file_value^, status);
        RETURN;
      IFEND;
      NEXT task_services_entry_points_p: [1 .. (adaptable_array_p^.array_size DIV
            adaptable_array_p^.element_size)] IN image_file_p;
      IF task_services_entry_points_p = NIL THEN
        osp$set_status_condition (oce$premature_eof_in_segment, status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$job_image].value^.file_value^, status);
        RETURN;
      IFEND;
    PROCEND find_task_services_in_image;
?? OLDTITLE ??
?? EJECT ??
    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    entry_point_file_p := NIL;
    #SPOIL (entry_point_file_p);
    osp$establish_block_exit_hndlr (^condition_handler);

    open_source_file (pvt [p$system_debug_table].value^.file_value^, debug_file_p, debug_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    #SPOIL (debug_fid);

    NEXT debug_header_p IN debug_file_p;
    IF (debug_header_p = NIL) OR (debug_header_p^.version <> pmc$linker_debug_table_version) THEN
      osp$set_status_condition (oce$e_file_is_not_symbol_table, status);
      osp$append_status_file (osc$status_parameter_delimiter, pvt [p$system_debug_table].value^.file_value^,
            status);
      RETURN;
    IFEND;

    find_task_services_address (found, task_services_address);
    IF NOT found THEN
      osp$set_status_abnormal ('OC', oce$e_section_or_seg_not_found, 'TASK SERVICES', status);
      RETURN;
    IFEND;

    fsp$close_file (debug_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    open_source_file (pvt [p$job_image].value^.file_value^, job_image_file_p, job_image_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    #SPOIL (job_image_fid);

    find_task_services_in_image (task_services_address, job_image_file_p, task_services_entry_points_p,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    open_segment (entry_point_file_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    NEXT entry_point_header_p IN entry_point_file_p;
    IF entry_point_header_p = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 029', status);
      RETURN;
    IFEND;
    entry_point_header_p^.identification := c$entry_external_id;
    entry_point_header_p^.entry_point_count := 0;
    entry_point_header_p^.external_count := 0;

    FOR index := 1 TO UPPERBOUND (task_services_entry_points_p^) DO
      entry_point_header_p^.entry_point_count := entry_point_header_p^.entry_point_count + 1;
      NEXT entry_point_p IN entry_point_file_p;
      IF entry_point_p = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 030', status);
        RETURN;
      IFEND;
      entry_point_p^.name := task_services_entry_points_p^ [index].ep.name;
      entry_point_p^.module_name := 'OSM$TASK_SERVICES';
      entry_point_p^.product_name := pvt [p$product_name].value^.name_value;
      entry_point_p^.language := task_services_entry_points_p^ [index].ep.language;
      entry_point_p^.declaration_matching_required := task_services_entry_points_p^ [index].ep.
            declaration_matching_required;
      entry_point_p^.declaration_matching := task_services_entry_points_p^ [index].ep.declaration_matching;
      IF task_services_entry_points_p^ [index].ep.gated THEN
        entry_point_p^.attributes := $llt$entry_point_attributes
              [llc$gated_entry_point, llc$retain_entry_point];
      ELSE
        entry_point_p^.attributes := $llt$entry_point_attributes [];
      IFEND;
    FOREND;

    fsp$close_file (job_image_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Segments have been verified.  Don't need to check for NIL.

    PUSH new_entry_externals_p: [1 .. 1];
    RESET entry_point_file_p;
    NEXT entry_point_header_p IN entry_point_file_p;
    NEXT new_entry_externals_p^ [1].entry_point_list_p: [1 .. entry_point_header_p^.entry_point_count] IN
          entry_point_file_p;
    new_entry_externals_p^ [1].external_list_p := NIL;
    merge_with_working_file (new_entry_externals_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    close_segment (entry_point_file_p, status);
    osp$disestablish_cond_handler;
  PROCEND ocp$_add_task_services;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$_compare_reference_file', EJECT ??

  PROCEDURE ocp$_compare_reference_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$proru_comrf) compare_reference_file, comrf (
{   reference_type, rt: key
{       (entry_point, entry_points, ep)
{       (external_reference, external_references, er)
{     keyend = $required
{   reference_file, rf: record
{       file: file
{       reference_type: key
{         (entry_point, entry_points, ep)
{         (external_reference, external_references, er)
{       keyend
{     recend = $required
{   cybil_parameter_checking, cpc: (BY_NAME) key
{       (object, o)
{       (source, s)
{     keyend = object
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 6] of clt$keyword_specification,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (6),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 3, 30, 12, 47, 18, 693],
    clc$command, 9, 5, 2, 0, 0, 0, 5, 'OCM$PRORU_COMRF'], [
    ['CPC                            ',clc$abbreviation_entry, 3],
    ['CYBIL_PARAMETER_CHECKING       ',clc$nominal_entry, 3],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OUTPUT                         ',clc$nominal_entry, 4],
    ['REFERENCE_FILE                 ',clc$nominal_entry, 2],
    ['REFERENCE_TYPE                 ',clc$nominal_entry, 1],
    ['RF                             ',clc$abbreviation_entry, 2],
    ['RT                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 311,
  clc$required_parameter, 0, 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [6], [
    ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ENTRY_POINTS                   ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ER                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXTERNAL_REFERENCE             ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['EXTERNAL_REFERENCES            ', clc$alias_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 2
    [[1, 0, clc$record_type], [2],
    ['FILE                           ', clc$required_field, 3], [[1, 0, clc$file_type]],
    ['REFERENCE_TYPE                 ', clc$required_field, 229], [[1, 0, clc$keyword_type], [6], [
      ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['ENTRY_POINTS                   ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ER                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['EXTERNAL_REFERENCE             ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['EXTERNAL_REFERENCES            ', clc$alias_entry, clc$normal_usage_entry, 2]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['O                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['OBJECT                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SOURCE                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'object'],
{ PARAMETER 4
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$reference_type = 1,
      p$reference_file = 2,
      p$cybil_parameter_checking = 3,
      p$output = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    CONST
      declared_by = 'Declared By',
      referenced_by = 'Referenced By';

    CONST
      maximum_label_string_size = 13; { referenced_by

    VAR
      compare_fid: amt$file_identifier,
      compare_file_p: ^SEQ ( * ),
      compare_header_p: ^t$entry_external_file_header,
      compare_index: ost$non_negative_integers,
      compare_label: string (maximum_label_string_size),
      compare_list_p: ^t$entry_external_list,
      displayed_mismatch: boolean,
      done: boolean,
      mismatch: boolean,
      object_checking: boolean,
      save_compare_index: ost$non_negative_integers,
      working_index: ost$non_negative_integers,
      working_label: string (maximum_label_string_size),
      working_list_p: ^t$entry_external_list;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Attempt to cleanup on block exit if something doesn't work.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF condition.selector = pmc$block_exit_processing THEN
        IF v$output_file_open THEN
          clp$close_display (v$display_control, ignore_status);
          v$output_file_open := FALSE;
          #SPOIL (v$output_file_open);
        IFEND;
        fsp$close_file (compare_fid, ignore_status);


        RETURN;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'display_entry_external', EJECT ??

{   The purpose of this request is to display the entry/external entry to the output file.

    PROCEDURE display_entry_external
      (    label: string ( * <= maximum_label_string_size);
           entry_external: t$entry_external;
       VAR status: ost$status);

      VAR
        line: string (79);

      status.normal := TRUE;

      line (1, 2) := '';
      line (3, 14) := label;
      line (17, 32) := entry_external.product_name;
      line (49, 31) := entry_external.module_name;
      display_output_string (line, status);
    PROCEND display_entry_external;
?? OLDTITLE ??
?? EJECT ??
    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    object_checking := pvt [p$cybil_parameter_checking].value^.keyword_value = 'OBJECT';

{ Determine whether to use entry points or externals.

    IF pvt [p$reference_type].value^.keyword_value = 'ENTRY_POINT' THEN
      compare_file_p := v$working_file.entry_points_p;
      IF compare_file_p = NIL THEN
        RETURN;
      IFEND;
      RESET compare_file_p;
      NEXT compare_header_p IN compare_file_p;
      IF (compare_header_p = NIL) OR (compare_header_p^.entry_point_count = 0) THEN
        RETURN;
      IFEND;
      NEXT working_list_p: [1 .. compare_header_p^.entry_point_count] IN compare_file_p;
      IF working_list_p = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 031', status);
        RETURN;
      IFEND;
      working_label := declared_by;
    ELSE
      compare_file_p := v$working_file.externals_p;
      IF compare_file_p = NIL THEN
        RETURN;
      IFEND;
      RESET compare_file_p;
      NEXT compare_header_p IN compare_file_p;
      IF (compare_header_p = NIL) OR (compare_header_p^.external_count = 0) THEN
        RETURN;
      IFEND;
      NEXT working_list_p: [1 .. compare_header_p^.external_count] IN compare_file_p;
      IF working_list_p = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 032', status);
        RETURN;
      IFEND;
      working_label := referenced_by;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

{ Open the reference file and determine whether to use entry points or externals.

    open_source_file (pvt [p$reference_file].value^.field_values^ [1].value^.file_value^, compare_file_p,
          compare_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    NEXT compare_header_p IN compare_file_p;
    IF pvt [p$reference_file].value^.field_values^ [2].value^.keyword_value = 'ENTRY_POINT' THEN
      IF (compare_header_p = NIL) OR (compare_header_p^.entry_point_count = 0) THEN
        osp$set_status_condition (oce$missing_or_empty_file, status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$reference_file].
              value^.field_values^ [1].value^.file_value^, status);
        RETURN;
      IFEND;
      NEXT compare_list_p: [1 .. compare_header_p^.entry_point_count] IN compare_file_p;
      IF compare_list_p = NIL THEN
        osp$set_status_condition (oce$premature_eof_in_segment, status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$reference_file].
              value^.field_values^ [1].value^.file_value^, status);
        RETURN;
      IFEND;
      compare_label := declared_by;
    ELSE
      IF (compare_header_p = NIL) OR (compare_header_p^.external_count = 0) THEN
        osp$set_status_condition (oce$missing_or_empty_file, status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$reference_file].
              value^.field_values^ [1].value^.file_value^, status);
        RETURN;
      IFEND;
      IF compare_header_p^.entry_point_count > 0 THEN
        NEXT compare_list_p: [1 .. compare_header_p^.entry_point_count] IN compare_file_p;
        IF compare_list_p = NIL THEN
          osp$set_status_condition (oce$premature_eof_in_segment, status);
          osp$append_status_file (osc$status_parameter_delimiter, pvt [p$reference_file].value^.
                field_values^ [1].value^.file_value^, status);
          RETURN;
        IFEND;
      IFEND;
      NEXT compare_list_p: [1 .. compare_header_p^.external_count] IN compare_file_p;
      IF compare_list_p = NIL THEN
        osp$set_status_condition (oce$premature_eof_in_segment, status);
        osp$append_status_file (osc$status_parameter_delimiter, pvt [p$reference_file].
              value^.field_values^ [1].value^.file_value^, status);
        RETURN;
      IFEND;
      compare_label := referenced_by;
    IFEND;

    establish_display_title ('compare_reference_file');

    open_output_file (pvt [p$output].value^.file_value^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    compare_index := 1;
    working_index := 1;

  /compare_entries_and_externals/
    WHILE (working_index <= UPPERBOUND (working_list_p^)) AND (compare_index <= UPPERBOUND (compare_list_p^))
          DO
      IF working_list_p^ [working_index].name = compare_list_p^ [compare_index].name THEN
        save_compare_index := compare_index;
        mismatch := declaration_mismatch (object_checking, working_list_p^ [working_index],
              compare_list_p^ [compare_index]);
        done := FALSE;

{ Determine if there is a mismatch.

        WHILE (compare_index < UPPERBOUND (compare_list_p^)) AND (NOT mismatch) AND (NOT done) DO
          compare_index := compare_index + 1;
          done := working_list_p^ [working_index].name <> compare_list_p^ [compare_index].name;
          IF NOT done THEN
            mismatch := declaration_mismatch (object_checking, working_list_p^ [working_index],
                  compare_list_p^ [compare_index]);
          IFEND;
        WHILEND;

        IF mismatch THEN

{ If there is a mismatch, then display the entry/external name.

          display_output_string (working_list_p^ [working_index].name, status);
          IF NOT status.normal THEN
            EXIT /compare_entries_and_externals/;
          IFEND;

{ Display all entry/externals in the working file that have the same declaration matching value.

          display_entry_external (working_label, working_list_p^ [working_index], status);
          IF NOT status.normal THEN
            EXIT /compare_entries_and_externals/;
          IFEND;

          WHILE (working_index < UPPERBOUND (working_list_p^)) AND
                (working_list_p^ [working_index].name = working_list_p^ [working_index + 1].name) AND
                declaration_values_match (working_list_p^ [working_index],
                working_list_p^ [working_index + 1]) DO
            working_index := working_index + 1;

            display_entry_external ('', working_list_p^ [working_index], status);
            IF NOT status.normal THEN
              EXIT /compare_entries_and_externals/;
            IFEND;

          WHILEND;

{ Display all entry/externals in the reference file for which there is a mismatch.

          compare_index := save_compare_index;
          displayed_mismatch := FALSE;
          WHILE (compare_index <= UPPERBOUND (compare_list_p^)) AND
                (working_list_p^ [working_index].name = compare_list_p^ [compare_index].name) DO
            IF declaration_mismatch (object_checking, working_list_p^ [working_index],
                  compare_list_p^ [compare_index]) THEN
              IF displayed_mismatch THEN
                display_entry_external ('', compare_list_p^ [compare_index], status);
                IF NOT status.normal THEN
                  EXIT /compare_entries_and_externals/;
                IFEND;
              ELSE
                display_entry_external (compare_label, compare_list_p^ [compare_index], status);
                IF NOT status.normal THEN
                  EXIT /compare_entries_and_externals/;
                IFEND;
                displayed_mismatch := TRUE;
              IFEND;
            IFEND;
            compare_index := compare_index + 1;
          WHILEND;
          working_index := working_index + 1;

{ Backup in the reference file if the next working file entry/external has the same name
{ as the one just displayed.

          IF working_index <= UPPERBOUND (working_list_p^) THEN
            WHILE (compare_index > 1) AND (compare_list_p^ [compare_index - 1].
                  name = working_list_p^ [working_index].name) DO
              compare_index := compare_index - 1;
            WHILEND;
          IFEND;
        ELSE { NOT mismatch

{ Skip all entry/externals in the working file for which the name and declaration values match.

          WHILE (working_index < UPPERBOUND (working_list_p^)) AND
                (working_list_p^ [working_index].name = working_list_p^ [working_index + 1].name) AND
                declaration_values_match (working_list_p^ [working_index],
                working_list_p^ [working_index + 1]) DO
            working_index := working_index + 1;
          WHILEND;

          working_index := working_index + 1;

{ Backup in the reference file if the next working file entry/external has the same name
{ as the ones just skipped.

          IF working_index <= UPPERBOUND (working_list_p^) THEN
            WHILE (compare_index > 1) AND (compare_list_p^ [compare_index - 1].
                  name = working_list_p^ [working_index].name) DO
              compare_index := compare_index - 1;
            WHILEND;
          IFEND;
        IFEND;

      ELSEIF working_list_p^ [working_index].name < compare_list_p^ [compare_index].name THEN
        working_index := working_index + 1;

{ Backup in the reference file if the next working file entry/external has the same name
{ as the ones just skipped.

        IF working_index <= UPPERBOUND (working_list_p^) THEN
          WHILE (compare_index > 1) AND (compare_list_p^ [compare_index - 1].
                name = working_list_p^ [working_index].name) DO
            compare_index := compare_index - 1;
          WHILEND;
        IFEND;
      ELSE
        compare_index := compare_index + 1;
      IFEND;
    WHILEND /compare_entries_and_externals/;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    close_output_file (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$close_file (compare_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    osp$disestablish_cond_handler;
  PROCEND ocp$_compare_reference_file;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$_product_reference_utility', EJECT ??

{ PURPOSE:
{   This is the entry point that begins the product reference utility.

  PROGRAM ocp$_product_reference_utility
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$proru) product_reference_utility, product_references_utility, proru (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [90, 3, 19, 20, 3, 54, 198],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'OCM$PRORU'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      utility_attributes_p: ^clt$utility_attributes;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF #SIZE (t$entry_external) <> c$entry_external_record_size THEN
      osp$set_status_abnormal ('OC', oce$internal_error,
            'T$ENTRY_EXTERNAL/C$ENTRY_EXTERNAL_RECORD_SIZE mismatch', status);
      RETURN;
    IFEND;

    PUSH utility_attributes_p: [1 .. 5];
    utility_attributes_p^ [1].key := clc$utility_command_search_mode;
    utility_attributes_p^ [1].command_search_mode := clc$global_command_search;
    utility_attributes_p^ [2].key := clc$utility_command_table;
    utility_attributes_p^ [2].command_table := proru_commands;
    utility_attributes_p^ [3].key := clc$utility_prompt;
    utility_attributes_p^ [3].prompt.value := c$utility_prompt;
    utility_attributes_p^ [3].prompt.size := STRLENGTH (c$utility_prompt);
    utility_attributes_p^ [4].key := clc$utility_termination_command;
    utility_attributes_p^ [4].termination_command := 'quit';
    utility_attributes_p^ [5].key := clc$utility_function_proc_table;
    utility_attributes_p^ [5].function_processor_table := proru_functions;

{ Begin the utility environment.  Establish the command list, and scan the
{ command file for commands.

    clp$begin_utility (c$utility_name, utility_attributes_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, c$utility_prompt, c$utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Close the working file segments - a.k.a., cleanup.

    reset_working_file;

{ End the utility environment and exit the utility.

    clp$end_utility (c$utility_name, status);
  PROCEND ocp$_product_reference_utility;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$_quit', EJECT ??

  PROCEDURE ocp$_quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$proru_qui) quit, qui (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [90, 3, 19, 20, 4, 15, 743],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'OCM$PRORU_QUI'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      ignore_status: ost$status;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_include (c$utility_name, status);

{ Exit the utility.

  PROCEND ocp$_quit;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$_write_reference_file', EJECT ??

  PROCEDURE ocp$_write_reference_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$proru_wrirf) write_reference_file, wrirf (
{   file, f: file = $required
{   discard_working_file, dwf: (BY_NAME) boolean = true
{   reference_type, rt: (BY_NAME) key
{       all
{       (entry_point, entry_points, ep)
{       (external_reference, external_references, er)
{     keyend = all
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 7] of clt$keyword_specification,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 4, 13, 9, 4, 13, 47],
    clc$command, 7, 4, 1, 0, 0, 0, 4, 'OCM$PRORU_WRIRF'], [
    ['DISCARD_WORKING_FILE           ',clc$nominal_entry, 2],
    ['DWF                            ',clc$abbreviation_entry, 2],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['REFERENCE_TYPE                 ',clc$nominal_entry, 3],
    ['RT                             ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 266,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [7], [
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['ENTRY_POINTS                   ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['ER                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['EXTERNAL_REFERENCE             ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['EXTERNAL_REFERENCES            ', clc$alias_entry, clc$normal_usage_entry, 3]]
    ,
    'all'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$discard_working_file = 2,
      p$reference_type = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      target_entry_external_list_p: ^t$entry_external_list,
      target_fid: amt$file_identifier,
      target_file_header_p: ^t$entry_external_file_header,
      target_file_p: ^SEQ ( * ),
      working_entry_external_list_p: ^t$entry_external_list,
      working_file_header_p: ^t$entry_external_file_header;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   Attempt to cleanup on block exit if something doesn't work.
{   Ignore terminate break conditions.  This is considered a "critical section."

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF condition.selector = pmc$block_exit_processing THEN
        fsp$close_file (target_fid, ignore_status);
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND abort_handler;
?? OLDTITLE ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   Attempt to cleanup on block exit if something doesn't work.
{   Ignore terminate break conditions.  This is considered a "critical section."

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

{ Ignore terminate break during a critical section.

      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN
        RETURN;

      ELSEIF condition.selector = pmc$block_exit_processing THEN
        fsp$close_file (target_fid, ignore_status);
        IF pvt [p$discard_working_file].value^.boolean_value.value THEN
          reset_working_file;
        IFEND;
        RETURN;
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    PROCEND condition_handler;
?? OLDTITLE ??
?? EJECT ??
    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

{ Open the file to write the working file to.

    open_target_file (pvt [p$file].value^.file_value^, target_file_p, target_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ The target file has already been reset.  Setup the file header.

    NEXT target_file_header_p IN target_file_p;
    IF target_file_header_p = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 033', status);
      RETURN;
    IFEND;
    target_file_header_p^.identification := c$entry_external_id;

{ Move the working files entry points and externals to the target file.

    IF (v$working_file.entry_points_p <> NIL) AND ((pvt [p$reference_type].value^.keyword_value = 'ALL') OR
          (pvt [p$reference_type].value^.keyword_value = 'ENTRY_POINT')) THEN

      RESET v$working_file.entry_points_p;
      NEXT working_file_header_p IN v$working_file.entry_points_p;
      IF working_file_header_p = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 034', status);
        RETURN;
      IFEND;
      target_file_header_p^.entry_point_count := working_file_header_p^.entry_point_count;
      IF target_file_header_p^.entry_point_count > 0 THEN
        NEXT target_entry_external_list_p: [1 .. target_file_header_p^.entry_point_count] IN target_file_p;
        IF target_entry_external_list_p = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 035', status);
          RETURN;
        IFEND;
        NEXT working_entry_external_list_p: [1 .. target_file_header_p^.entry_point_count] IN
              v$working_file.entry_points_p;
        IF working_entry_external_list_p = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 036', status);
          RETURN;
        IFEND;
        target_entry_external_list_p^ := working_entry_external_list_p^;
      IFEND;
    ELSE
      target_file_header_p^.entry_point_count := 0;
    IFEND;

    IF (v$working_file.externals_p <> NIL) AND ((pvt [p$reference_type].value^.keyword_value = 'ALL') OR
          (pvt [p$reference_type].value^.keyword_value = 'EXTERNAL_REFERENCE')) THEN

      RESET v$working_file.externals_p;
      NEXT working_file_header_p IN v$working_file.externals_p;
      IF working_file_header_p = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 037', status);
        RETURN;
      IFEND;
      target_file_header_p^.external_count := working_file_header_p^.external_count;
      IF target_file_header_p^.external_count > 0 THEN
        NEXT target_entry_external_list_p: [1 .. target_file_header_p^.external_count] IN target_file_p;
        IF target_entry_external_list_p = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 038', status);
          RETURN;
        IFEND;
        NEXT working_entry_external_list_p: [1 .. target_file_header_p^.external_count] IN
              v$working_file.externals_p;
        IF working_entry_external_list_p = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'NEXT 039', status);
          RETURN;
        IFEND;
        target_entry_external_list_p^ := working_entry_external_list_p^;
      IFEND;
    ELSE
      target_file_header_p^.external_count := 0;
    IFEND;

{ The target file must be positioned at EOI when close is called.

    close_target_file (target_file_p, target_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Discard the current working file if requested.
{ The establishment of this handler overwrites the previous handler.
{ This is considered a critical section.

    osp$establish_condition_handler (^condition_handler, {block_exit} TRUE);
    IF pvt [p$discard_working_file].value^.boolean_value.value THEN
      reset_working_file;
    IFEND;
    osp$disestablish_cond_handler;
  PROCEND ocp$_write_reference_file;
?? OLDTITLE ??
MODEND ocm$product_reference_utility;
*DECK DECK=OCM$QUERY_LINKER_DEBUG_TABLES EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Object Code Utilities: Query Linker Debug Tables' ??
MODULE ocm$query_linker_debug_tables;


{ PURPOSE:
{   This module display_information from a debug table produced by the VE linker.



?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc pmt$linker_debug_table_header
*copyc clc$standard_file_names
*copyc oce$ve_linker_exceptions
?? POP ??
*copyc amp$get_next
*copyc clp$begin_utility
*copyc clp$convert_string_to_date_time
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc clp$make_date_time_value
*copyc clp$make_integer_value
*copyc clp$make_list_value
*copyc clp$make_program_name_value
*copyc clp$make_record_value
*copyc clp$make_string_value
*copyc fsp$close_file
*copyc fsp$open_file
*copyc ocp$close_linker_debug_table
*copyc ocp$close_output_file
*copyc ocp$find_debug_address
*copyc ocp$find_debug_entry_point
*copyc ocp$find_debug_module_item
*copyc ocp$get_debug_table_header
*copyc ocp$hexrep
*copyc ocp$open_linker_debug_table
*copyc ocp$open_output_file
*copyc ocp$open_running_debug_table
*copyc ocp$output
*copyc ocp$output_access_control
*copyc ocp$output_date
*copyc ocp$output_module_generator
*copyc ocp$output_module_kind
*copyc ocp$output_section_kind
*copyc ocp$output_time
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal

*copyc osv$lower_to_upper
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    utility_name = 'QUERY_DEBUG_TABLE              ',
    utility_prompt = 'qdt',

    continue = FALSE,
    end_of_line = TRUE;


  VAR
    dummy_header: [STATIC] string (132) := 'Output from QUERY_DEBUG_TABLE';

?? OLDTITLE ??
?? NEWTITLE := 'abnormal_status_with_address', EJECT ??

{ PURPOSE:
{   Build a status message with the address.

  PROCEDURE abnormal_status_with_address
    (    condition: ost$status_condition;
         address: integer;
     VAR status: ost$status);


    VAR
      strng: string (132),
      l: integer;


    ocp$hexrep (strng, l, (address DIV 100000000(16)));
    osp$set_status_abnormal ('OC', condition, strng (1, l), status);

    ocp$hexrep (strng, l, (address MOD 100000000(16)));
    osp$append_status_parameter (osc$status_parameter_delimiter, strng (1, l), status);


  PROCEND abnormal_status_with_address;
?? OLDTITLE ??
?? NEWTITLE := 'c$_display_address', EJECT ??

{ PURPOSE:
{   Command processor for the display_address command.

  PROCEDURE c$_display_address
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE display_address (
{   address, a: integer 0..0fffffffffff(16) RADIX 16 = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 1, 4, 14, 48, 8, 699],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['ADDRESS                        ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 0fffffffffff(16), 16]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$address = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      address: integer,
      segment: ost$segment,
      offset: ost$segment_offset,
      found: boolean,
      module_name: pmt$program_name,
      section_name: pmt$program_name,
      offset_in_section: ost$segment_offset;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    address := pvt [p$address].value^.integer_value.value;
    IF ((address MOD 100000000(16)) > 7fffffff(16)) THEN
      abnormal_status_with_address (oce$e_invalid_address_specified, address, status);
      RETURN;
    IFEND;

    segment := address DIV 100000000(16);
    offset := address MOD 100000000(16);

    ocp$find_debug_address (segment, offset, found, module_name, section_name, offset_in_section, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF found THEN
      display_address (segment, offset, module_name, section_name, offset_in_section);
    ELSE
      abnormal_status_with_address (oce$e_address_not_found, address, status);
    IFEND;


  PROCEND c$_display_address;
?? OLDTITLE ??
?? NEWTITLE := 'c$_display_debug_table', EJECT ??

{ PURPOSE:
{   Command processor for the display_debug_table command.

  PROCEDURE c$_display_debug_table
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE display_debug_table (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [89, 1, 3, 20, 58, 38, 341],
    clc$command, 1, 1, 0, 0, 0, 0, 1, ''], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      debug_table_header: ^pmt$linker_debug_table_header,
      ignore: boolean,
      strng: string (132),
      l: integer;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$get_debug_table_header (debug_table_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    ocp$output ('0  Version: ', debug_table_header^.version, #SIZE (debug_table_header^.version), continue);
    ocp$output ('   Build Level: ', debug_table_header^.build_level, #SIZE (debug_table_header^.build_level),
          end_of_line);

    ocp$output ('   ', 'Date built:', 11, continue);
    ocp$output_date (^debug_table_header^.date, continue, ignore);
    ocp$output ('  ', 'Time:', 5, continue);
    ocp$output_time (^debug_table_header^.time, end_of_line, ignore);

    STRINGREP (strng, l, debug_table_header^.number_of_modules);
    ocp$output ('   Modules:', strng, l, continue);
    STRINGREP (strng, l, debug_table_header^.number_of_entry_points);
    ocp$output ('  Entry Points:', strng, l, continue);
    STRINGREP (strng, l, debug_table_header^.number_of_addresses);
    ocp$output ('  Addresses:', strng, l, end_of_line);

    ocp$output (' ', ' ', 1, end_of_line);


  PROCEND c$_display_debug_table;
?? OLDTITLE ??
?? NEWTITLE := 'c$_display_entry_point', EJECT ??

{ PURPOSE:
{   Command processor for the display_entry_point command.

  PROCEDURE c$_display_entry_point
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE display_entry_point (
{   entry_point, ep: program_name = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 1, 4, 14, 48, 35, 760],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['ENTRY_POINT                    ',clc$nominal_entry, 1],
    ['EP                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$program_name_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$entry_point = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      entry_point: ost$name,
      module_name: pmt$program_name,
      found: boolean,
      segment: ost$segment,
      offset: ost$segment_offset;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;



    entry_point := pvt [p$entry_point].value^.program_name_value;
    ocp$find_debug_entry_point (entry_point, found, module_name, segment, offset, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF found THEN
      display_entry_point (entry_point, module_name, segment, offset);
    ELSE
      osp$set_status_abnormal ('OC', oce$e_entry_point_not_found, entry_point, status);
    IFEND;


  PROCEND c$_display_entry_point;
?? OLDTITLE ??
?? NEWTITLE := 'c$_display_module', EJECT ??

{ PURPOSE:
{   Command processor for the display_module command.

  PROCEDURE c$_display_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE display_module (
{   module, m: program_name = $required
{   occurrence, o: integer 1..pmc$maximum_debug_items = 1
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 1, 4, 14, 48, 51, 711],
    clc$command, 5, 3, 1, 0, 0, 0, 3, ''], [
    ['M                              ',clc$abbreviation_entry, 1],
    ['MODULE                         ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OCCURRENCE                     ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$program_name_type]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, pmc$maximum_debug_items, 10],
    '1'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$module = 1,
      p$occurrence = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      module_name: ost$name,
      occurrence: integer,
      found: boolean,
      module_item: ^pmt$module_item;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    module_name := pvt [p$module].value^.program_name_value;
    occurrence := pvt [p$occurrence].value^.integer_value.value;

    ocp$find_debug_module_item (module_name, occurrence, found, module_item, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT found THEN
      osp$set_status_abnormal ('OC', oce$e_module_item_not_found, module_name, status);
      RETURN;
    IFEND;

    display_module (module_item);


  PROCEND c$_display_module;
?? OLDTITLE ??
?? NEWTITLE := 'c$_quit', EJECT ??

{ PURPOSE:
{   Command processor for the quit command.

  PROCEDURE c$_quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE quit

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 1, 3, 21, 19, 4, 63],
    clc$command, 0, 0, 0, 0, 0, 0, 0, '']];

?? FMT (FORMAT := ON) ??
?? POP ??


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_include (utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


  PROCEND c$_quit;
?? OLDTITLE ??
?? NEWTITLE := 'c$_use_debug_table', EJECT ??

{ PURPOSE:
{   Command processor for the use_debug_table command.

  PROCEDURE c$_use_debug_table
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE use_debug_table (
{   debug_table, dt: any of
{       key
{         (running_system, rs)
{       keyend
{       file
{     anyend = running_system
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
        default_value: string (14),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 1, 3, 21, 1, 20, 419],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['DEBUG_TABLE                    ',clc$nominal_entry, 1],
    ['DT                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 104,
  clc$optional_default_parameter, 0, 14],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['RS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['RUNNING_SYSTEM                 ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'running_system'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$debug_table = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$debug_table].value^.kind = clc$keyword) THEN
      ocp$open_running_debug_table (status);
    ELSE
      ocp$open_linker_debug_table (pvt [p$debug_table].value^.file_value^, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;


  PROCEND c$_use_debug_table;
?? OLDTITLE ??
?? NEWTITLE := 'convert_string_to_integer', EJECT ??

{ PURPOSE:
{   Convert the string containing a hex number to an integer.

  PROCEDURE convert_string_to_integer
    (    strng: string ( * );
     VAR intger: integer);


    VAR
      i: integer;


    intger := 0;

    FOR i := 1 TO STRLENGTH (strng) DO
      CASE strng (i) OF
      = '0' .. '9' =
        intger := (intger * 16) + ($INTEGER (strng (i)) - $INTEGER ('0'));
      = 'a' .. 'f' =
        intger := (intger * 16) + ($INTEGER (strng (i)) - $INTEGER ('a') + 10);
      = 'A' .. 'F' =
        intger := (intger * 16) + ($INTEGER (strng (i)) - $INTEGER ('A') + 10);
      ELSE
        RETURN;
      CASEND;
    FOREND;


  PROCEND convert_string_to_integer;
?? OLDTITLE ??
?? NEWTITLE := 'determine_section_name', EJECT ??

{ PURPOSE:
{   Set the section name to the name explicitly given to the section or to
{   a name determined by the segment type.

  PROCEDURE determine_section_name
    (    section_item: pmt$section_item;
     VAR section_name: pmt$program_name);


    IF (section_item.name <> osc$null_name) THEN
      section_name := section_item.name;
    ELSEIF (section_item.kind = llc$code_section) THEN
      section_name := 'CODE SECTION';
    ELSEIF (section_item.kind = llc$binding_section) THEN
      section_name := 'BINDING SECTION';
    ELSEIF (section_item.segment_access_control.read_privilege <> osc$non_readable) AND
          (section_item.segment_access_control.write_privilege <> osc$non_writable) THEN
      section_name := 'READ WRITE';
    ELSEIF (section_item.segment_access_control.read_privilege <> osc$non_readable) THEN
      section_name := 'READ ONLY';
    ELSE
      section_name := 'WORKING STORAGE';
    IFEND;


  PROCEND determine_section_name;
?? OLDTITLE ??
?? NEWTITLE := 'display_address', EJECT ??

{ PURPOSE:
{   Common routine to display information on an address.

  PROCEDURE display_address
    (    segment: ost$segment;
         offset: ost$segment_offset;
         module_name: pmt$program_name;
         section_name: pmt$program_name;
         offset_in_section: ost$segment_offset);


    VAR
      ignore: boolean,
      strng: string (132),
      l: integer;


    ocp$hexrep (strng, l, segment);
    ocp$output ('   Address: ', strng, l, continue);
    ocp$hexrep (strng, l, offset);
    ocp$output ('', strng, l, continue);

    ocp$output ('   Module: ', module_name, STRLENGTH (module_name), continue);

    ocp$output ('   Section: ', section_name, STRLENGTH (section_name), continue);

    ocp$hexrep (strng, l, offset_in_section);
    ocp$output ('   Offset:', strng, l, end_of_line);


  PROCEND display_address;
?? OLDTITLE ??
?? NEWTITLE := 'display_entry_point', EJECT ??

{ PURPOSE:
{   Displays information about an entry point.

  PROCEDURE display_entry_point
    (    entry_point: pmt$program_name;
         module_name: pmt$program_name;
         segment: ost$segment;
         offset: ost$segment_offset);


    VAR
      strng: string (132),
      l: integer;


    ocp$output ('   Entry Point: ', entry_point, STRLENGTH (entry_point), continue);

    ocp$output ('   Module: ', module_name, STRLENGTH (module_name), continue);

    ocp$hexrep (strng, l, segment);
    ocp$output ('   Address: ', strng, l, continue);
    ocp$hexrep (strng, l, offset);
    ocp$output ('', strng, l, end_of_line);


  PROCEND display_entry_point;
?? OLDTITLE ??
?? NEWTITLE := 'display_module', EJECT ??

{ PURPOSE:
{   Displays information about a module.

  PROCEDURE display_module
    (    module_item: ^pmt$module_item);


    VAR
      ignore: boolean,
      i: integer,
      strng: string (132),
      l: integer;


    ocp$output ('0  Module: ', module_item^.identification.name, #SIZE (module_item^.identification.name),
          continue);

    ocp$output ('  ', 'Created:', 8, continue);
    ocp$output_time (^module_item^.identification.time_created, continue, ignore);
    ocp$output_date (^module_item^.identification.date_created, end_of_line, ignore);


    ocp$output ('   ', 'kind:', 5, continue);
    ocp$output_module_kind (^module_item^.identification.kind, continue, ignore);

    ocp$output ('  ', 'generator:', 10, continue);
    ocp$output_module_generator (^module_item^.identification.generator_id, end_of_line, ignore);

    ocp$output ('   ', 'generator name version:', 23, continue);
    ocp$output (' ', module_item^.identification.generator_name_vers,
          STRLENGTH (module_item^.identification.generator_name_vers), end_of_line);

    IF module_item^.identification.commentary <> osc$null_name THEN
      ocp$output ('   ', 'commentary:', 11, continue);
      ocp$output (' ', module_item^.identification.commentary,
            STRLENGTH (module_item^.identification.commentary), end_of_line);
    IFEND;
?? EJECT ??

    FOR i := 0 TO module_item^.identification.greatest_section_ordinal DO
      ocp$output ('0    ', 'Section kind:', 13, continue);
      ocp$output_section_kind (^module_item^.section_item [i].kind, continue, ignore);
      ocp$output ('  ', 'Attributes:', 11, continue);
      ocp$output_access_control (module_item^.section_item [i].segment_access_control, end_of_line);

      ocp$hexrep (strng, l, module_item^.section_item [i].address DIV 100000000(16));
      ocp$output ('     Segment:', strng, l, continue);
      ocp$hexrep (strng, l, module_item^.section_item [i].address MOD 100000000(16));
      ocp$output ('  Offset:', strng, l, continue);
      ocp$hexrep (strng, l, module_item^.section_item [i].length);
      ocp$output ('  Length:', strng, l, end_of_line);

      ocp$hexrep (strng, l, module_item^.section_item [i].ring.r1);
      ocp$output ('     Rings: (', strng, l, continue);
      ocp$hexrep (strng, l, module_item^.section_item [i].ring.r2);
      ocp$output (',', strng, l, continue);
      ocp$hexrep (strng, l, module_item^.section_item [i].ring.r3);
      ocp$output (',', strng, l, continue);
      ocp$output (' )  Name: ', module_item^.section_item [i].name, #SIZE (pmt$program_name), end_of_line);
    FOREND;

    ocp$output (' ', ' ', 1, end_of_line);


  PROCEND display_module;
?? OLDTITLE ??
?? NEWTITLE := 'f$$debug_table', EJECT ??

{ PURPOSE:
{   Command processor for the $debug_table command.

  PROCEDURE f$$debug_table
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $debug_table

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 1, 4, 12, 36, 57, 473],
    clc$function, 0, 0, 0, 0, 0, 0, 0, '']];

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      date_time: clt$date_time,
      debug_table_header: ^pmt$linker_debug_table_header,
      ignore: boolean,
      strng: string (132),
      l: integer;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$get_debug_table_header (debug_table_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    clp$make_record_value (6, work_area, result);

    result^.field_values^ [1].name := 'VERSION';
    clp$make_string_value (debug_table_header^.version, work_area, result^.field_values^ [1].value);

    result^.field_values^ [2].name := 'BUILD_LEVEL';
    clp$make_string_value (debug_table_header^.build_level, work_area, result^.field_values^ [2].value);

    result^.field_values^ [3].name := 'DATE_BUILT';
    date_time.date_specified := TRUE;
    date_time.time_specified := TRUE;
    ocp$make_date_time_value (debug_table_header^.date, debug_table_header^.time, work_area,
          result^.field_values^ [3].value);

    result^.field_values^ [4].name := 'MODULES';
    clp$make_integer_value (debug_table_header^.number_of_modules, 16, TRUE, work_area,
          result^.field_values^ [4].value);

    result^.field_values^ [5].name := 'ENTRY_POINTS';
    clp$make_integer_value (debug_table_header^.number_of_entry_points, 16, TRUE, work_area,
          result^.field_values^ [5].value);

    result^.field_values^ [6].name := 'ADDRESSES';
    clp$make_integer_value (debug_table_header^.number_of_addresses, 16, TRUE, work_area,
          result^.field_values^ [6].value);

  PROCEND f$$debug_table;
?? OLDTITLE ??
?? NEWTITLE := 'f$$address', EJECT ??

{ PURPOSE:
{   Command processor for the $address function.

  PROCEDURE f$$address
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $address (
{   address: integer 0..0fffffffffff(16) RADIX 16 = $required)

?? 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$integer_type_qualifier,
      recend,
    recend := [
    [1,
    [89, 1, 4, 14, 49, 53, 716],
    clc$function, 1, 1, 1, 0, 0, 0, 0, ''], [
    ['ADDRESS                        ',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, 20, clc$required_parameter,
  0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 0fffffffffff(16), 16]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$address = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      address: integer,
      segment: ost$segment,
      offset: ost$segment_offset,
      found: boolean,
      module_name: pmt$program_name,
      section_name: pmt$program_name,
      offset_in_section: ost$segment_offset;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    address := pvt [p$address].value^.integer_value.value;
    IF ((address MOD 100000000(16)) > 7fffffff(16)) THEN
      abnormal_status_with_address (oce$e_invalid_address_specified, address, status);
      RETURN;
    IFEND;

    segment := address DIV 100000000(16);
    offset := address MOD 100000000(16);

    ocp$find_debug_address (segment, offset, found, module_name, section_name, offset_in_section, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF found THEN

      clp$make_record_value (4, work_area, result);

      result^.field_values^ [1].name := 'ADDRESS';
      clp$make_integer_value (address, 16, TRUE, work_area, result^.field_values^ [1].value);

      result^.field_values^ [2].name := 'MODULE';
      clp$make_program_name_value (module_name, work_area, result^.field_values^ [2].value);

      result^.field_values^ [3].name := 'SECTION';
      clp$make_program_name_value (section_name, work_area, result^.field_values^ [3].value);

      result^.field_values^ [4].name := 'OFFSET';
      clp$make_integer_value (offset_in_section, 16, TRUE, work_area, result^.field_values^ [4].value);
    ELSE
      abnormal_status_with_address (oce$e_address_not_found, address, status);
    IFEND;


  PROCEND f$$address;
?? OLDTITLE ??
?? NEWTITLE := 'f$$entry_point', EJECT ??

{ PURPOSE:
{   Command processor for the $entry_point command.

  PROCEDURE f$$entry_point
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);


{ FUNCTION $entry_point (
{   entry_point: program_name = $required)

?? 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,
      recend,
    recend := [
    [1,
    [89, 1, 4, 14, 50, 9, 616],
    clc$function, 1, 1, 1, 0, 0, 0, 0, ''], [
    ['ENTRY_POINT                    ',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, 3, clc$required_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$program_name_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$entry_point = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      entry_point: ost$name,
      module_name: pmt$program_name,
      found: boolean,
      segment: ost$segment,
      offset: ost$segment_offset;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    entry_point := pvt [p$entry_point].value^.program_name_value;
    ocp$find_debug_entry_point (entry_point, found, module_name, segment, offset, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF found THEN
      clp$make_record_value (3, work_area, result);

      result^.field_values^ [1].name := 'ENTRY_POINT';
      clp$make_program_name_value (entry_point, work_area, result^.field_values^ [1].value);

      result^.field_values^ [2].name := 'MODULE';
      clp$make_program_name_value (module_name, work_area, result^.field_values^ [2].value);

      result^.field_values^ [3].name := 'ADDRESS';
      clp$make_integer_value (segment * 100000000(16) + offset, 16, TRUE, work_area, result^.
            field_values^ [3].value);
    ELSE
      osp$set_status_abnormal ('OC', oce$e_entry_point_not_found, entry_point, status);
    IFEND;


  PROCEND f$$entry_point;
?? OLDTITLE ??
?? NEWTITLE := 'f$$module', EJECT ??

{ PURPOSE:
{   Command processor for the $module function.

  PROCEDURE f$$module
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);


{ FUNCTION $module (
{   module: program_name = $required
{   occurrence: integer 1..pmc$maximum_debug_items = 1)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
    recend := [
    [1,
    [89, 1, 4, 14, 50, 26, 89],
    clc$function, 2, 2, 1, 0, 0, 0, 0, ''], [
    ['MODULE                         ',clc$nominal_entry, 1],
    ['OCCURRENCE                     ',clc$nominal_entry, 2]],
    [
{ 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, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, 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, 20,
  clc$optional_default_parameter, 0, 1]],
{ PARAMETER 1
    [[1, 0, clc$program_name_type]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, pmc$maximum_debug_items, 10],
    '1']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$module = 1,
      p$occurrence = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      entry: ^clt$data_value,
      found: boolean,
      module_item: ^pmt$module_item,
      module_name: ost$name,
      occurrence: integer,
      s: integer,
      section_name: pmt$program_name;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    module_name := pvt [p$module].value^.program_name_value;
    occurrence := pvt [p$occurrence].value^.integer_value.value;

    ocp$find_debug_module_item (module_name, occurrence, found, module_item, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT found THEN
      osp$set_status_abnormal ('OC', oce$e_module_item_not_found, module_name, status);
      RETURN;
    IFEND;

    clp$make_record_value (4, work_area, result);

    result^.field_values^ [1].name := 'MODULE';
    clp$make_program_name_value (module_item^.identification.name, work_area, result^.field_values^ [1].
          value);

    result^.field_values^ [2].name := 'CREATED';
    ocp$make_date_time_value (module_item^.identification.date_created,
          module_item^.identification.time_created, work_area, result^.field_values^ [2].value);

    result^.field_values^ [3].name := 'COMMENTARY';
    clp$make_string_value (module_item^.identification.commentary, work_area, result^.field_values^ [3].
          value);

    result^.field_values^ [4].name := 'SECTIONS';
    result^.field_values^ [4].value := NIL;

    FOR s := module_item^.identification.greatest_section_ordinal DOWNTO 0 DO
      clp$make_list_value (work_area, entry);

      clp$make_record_value (4, work_area, entry^.element_value);
      entry^.link := result^.field_values^ [4].value;
      result^.field_values^ [4].value := entry;
      entry := entry^.element_value;

      entry^.field_values^ [1].name := 'NAME';
      determine_section_name (module_item^.section_item [s], section_name);
      clp$make_program_name_value (section_name, work_area,
            entry^.field_values^ [1].value);

      entry^.field_values^ [2].name := 'ADDRESS';
      clp$make_integer_value (module_item^.section_item [s].address, 16, TRUE, work_area,
            entry^.field_values^ [2].value);

      entry^.field_values^ [3].name := 'LENGTH';
      clp$make_integer_value (module_item^.section_item [s].address, 16, TRUE, work_area,
            entry^.field_values^ [3].value);

      entry^.field_values^ [4].name := 'RINGS';
      clp$make_record_value (3, work_area, entry^.field_values^ [4].value);
      entry := entry^.field_values^ [4].value;

      entry^.field_values^ [1].name := 'R1';
      clp$make_integer_value (module_item^.section_item [s].ring.r1, 16, TRUE, work_area,
            entry^.field_values^ [1].value);

      entry^.field_values^ [2].name := 'R2';
      clp$make_integer_value (module_item^.section_item [s].ring.r2, 16, TRUE, work_area,
            entry^.field_values^ [2].value);

      entry^.field_values^ [3].name := 'R3';
      clp$make_integer_value (module_item^.section_item [s].ring.r3, 16, TRUE, work_area,
            entry^.field_values^ [3].value);

    FOREND;

  PROCEND f$$module;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$make_date_time_value', EJECT ??

  PROCEDURE ocp$make_date_time_value
    (    date: ost$date;
         time: ost$time;
     VAR work_area: ^clt$work_area;
     VAR value: ^clt$data_value);

    VAR
      date_time: clt$date_time,
      status: ost$status,
      time_time: clt$date_time;

    value := NIL;
    CASE time.time_format OF
    = osc$ampm_time =
      clp$convert_string_to_date_time (time.ampm, 'AMPM', time_time, status);
    = osc$hms_time =
      clp$convert_string_to_date_time (time.hms, 'HMS', time_time, status);
    = osc$millisecond_time =
      clp$convert_string_to_date_time (time.millisecond, 'MS', time_time, status);
    ELSE
      status.normal := FALSE;
    CASEND;

    IF NOT status.normal THEN
      time_time.time_specified := FALSE;
    IFEND;

    CASE date.date_format OF
    = osc$month_date =
      clp$convert_string_to_date_time (date.month, 'MONTH', date_time, status);
    = osc$iso_date =
      clp$convert_string_to_date_time (date.iso, 'ISOD', date_time, status);
    = osc$ordinal_date =
      clp$convert_string_to_date_time (date.ordinal, 'ORDINAL', date_time, status);
    = osc$dmy_date =
      clp$convert_string_to_date_time (date.dmy, 'DMY', date_time, status);
    = osc$mdy_date =
      clp$convert_string_to_date_time (date.mdy, 'MDY', date_time, status);
    ELSE
      status.normal := FALSE;
    CASEND;

    IF NOT status.normal THEN
      date_time.date_specified := FALSE;
    IFEND;

    date_time.time_specified := time_time.time_specified;
    IF date_time.time_specified THEN
      date_time.value.hour := time_time.value.hour;
      date_time.value.minute := time_time.value.minute;
      date_time.value.second := time_time.value.second;
      date_time.value.millisecond := time_time.value.millisecond;
    IFEND;

    clp$make_date_time_value (date_time, work_area, value);

  PROCEND ocp$make_date_time_value;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$query_debug_table_scl', EJECT ??

{ PURPOSE:
{   Processes the Query_debug_table utility.

  PROCEDURE [XDCL, #GATE] ocp$query_debug_table_scl
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE query_debug_table (
{   debug_table, dt: any of
{       key
{         (running_system, rs)
{       keyend
{       file
{     anyend = running_system
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
        default_value: string (14),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 1, 3, 21, 19, 37, 407],
    clc$command, 3, 2, 0, 0, 0, 0, 2, ''], [
    ['DEBUG_TABLE                    ',clc$nominal_entry, 1],
    ['DT                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 104,
  clc$optional_default_parameter, 0, 14],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['RS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['RUNNING_SYSTEM                 ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'running_system'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$debug_table = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

{ table utility_functions t=f s=local
{ function $address       f$$address cm=local
{ function $debug_table   f$$debug_table cm=local
{ function $entry_point   f$$entry_point cm=local
{ function $module        f$$module cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

    VAR
      utility_functions: [STATIC, READ] ^clt$function_processor_table := ^utility_functions_entries,

      utility_functions_entries: [STATIC, READ] array [1 .. 4] of clt$function_proc_table_entry := [
            {} ['$ADDRESS                       ', clc$nominal_entry, clc$normal_usage_entry, 1,
            clc$linked_call, ^f$$address],
            {} ['$DEBUG_TABLE                   ', clc$nominal_entry, clc$normal_usage_entry, 2,
            clc$linked_call, ^f$$debug_table],
            {} ['$ENTRY_POINT                   ', clc$nominal_entry, clc$normal_usage_entry, 3,
            clc$linked_call, ^f$$entry_point],
            {} ['$MODULE                        ', clc$nominal_entry, clc$normal_usage_entry, 4,
            clc$linked_call, ^f$$module]];

?? POP ??

{ table utility_commands t=c s=local
{ command (display_address               ,disa) c$_display_address cm=local
{ command (display_debug_table           ,disdt) c$_display_debug_table cm=local
{ command (display_entry_point           ,disep) c$_display_entry_point cm=local
{ command (display_module                ,dism) c$_display_module cm=local
{ command (use_debug_table               ,usedt) c$_use_debug_table cm=local
{ command (quit                          ,qui) c$_quit cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

    VAR
      utility_commands: [STATIC, READ] ^clt$command_table := ^utility_commands_entries,

      utility_commands_entries: [STATIC, READ] array [1 .. 12] of clt$command_table_entry := [
            {} ['DISA                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^c$_display_address],
            {} ['DISDT                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^c$_display_debug_table],
            {} ['DISEP                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^c$_display_entry_point],
            {} ['DISM                           ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^c$_display_module],
            {} ['DISPLAY_ADDRESS                ', clc$nominal_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^c$_display_address],
            {} ['DISPLAY_DEBUG_TABLE            ', clc$nominal_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^c$_display_debug_table],
            {} ['DISPLAY_ENTRY_POINT            ', clc$nominal_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^c$_display_entry_point],
            {} ['DISPLAY_MODULE                 ', clc$nominal_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^c$_display_module],
            {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^c$_quit],
            {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^c$_quit],
            {} ['USEDT                          ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^c$_use_debug_table],
            {} ['USE_DEBUG_TABLE                ', clc$nominal_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^c$_use_debug_table]];

?? POP ??

    VAR
      utility_attributes: array [1 .. 3] of clt$utility_attribute,
      ignore_status: ost$status;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$open_output_file (clc$standard_output, ^dummy_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$debug_table].value <> NIL) THEN
      IF (pvt [p$debug_table].value^.kind = clc$keyword) THEN
        ocp$open_running_debug_table (status);
      ELSE
        ocp$open_linker_debug_table (pvt [p$debug_table].value^.file_value^, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    utility_attributes [1].key := clc$utility_command_table;
    utility_attributes [1].command_table := utility_commands;
    utility_attributes [2].key := clc$utility_function_proc_table;
    utility_attributes [2].function_processor_table := utility_functions;
    utility_attributes [3].key := clc$utility_prompt;
    utility_attributes [3].prompt.value := utility_prompt;
    utility_attributes [3].prompt.size := STRLENGTH (utility_prompt);

    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, '', utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (utility_name, ignore_status);

    ocp$close_linker_debug_table (ignore_status);
    ocp$close_output_file (ignore_status);

  PROCEND ocp$query_debug_table_scl;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ocp$query_debug_table', EJECT ??

{ PURPOSE:
{   Process the Query_debug_table command.

  PROCEDURE [XDCL, #GATE] ocp$query_debug_table
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE query_debug_table (
{   debug_table, dt: any of
{       key
{         (running_system, rs)
{       keyend
{       file
{     anyend = running_system
{   input, i: file = input
{   output, o: file = output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
        default_value: string (14),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (6),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 1, 3, 21, 0, 34, 905],
    clc$command, 7, 4, 0, 0, 0, 0, 4, ''], [
    ['DEBUG_TABLE                    ',clc$nominal_entry, 1],
    ['DT                             ',clc$abbreviation_entry, 1],
    ['I                              ',clc$abbreviation_entry, 2],
    ['INPUT                          ',clc$nominal_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 104,
  clc$optional_default_parameter, 0, 14],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['RS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['RUNNING_SYSTEM                 ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'running_system'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    'input'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    'output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$debug_table = 1,
      p$input = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;


    VAR
      input_file_identifier: amt$file_identifier,
      ignore_status: ost$status;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    IF (pvt [p$debug_table].value <> NIL) THEN
      IF (pvt [p$debug_table].value^.kind = clc$keyword) THEN
        ocp$open_running_debug_table (status);
      ELSE
        ocp$open_linker_debug_table (pvt [p$debug_table].value^.file_value^, status);
      IFEND;

      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;


    open_input_file (pvt [p$input].value^.file_value^, input_file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    ocp$open_output_file (pvt [p$output].value^.file_value^, ^dummy_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    process_input_file (input_file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    ocp$close_linker_debug_table (ignore_status);
    ocp$close_output_file (ignore_status);
    fsp$close_file (input_file_identifier, ignore_status);


  PROCEND ocp$query_debug_table;
?? OLDTITLE ??
?? NEWTITLE := 'open_input_file', EJECT ??

{ PURPOSE:
{   Opens the specified file for input.

  PROCEDURE open_input_file
    (    file: fst$file_reference;
     VAR file_identifier: amt$file_identifier;
     VAR status: ost$status);


    VAR
      read_attributes: [STATIC] array [1 .. 1] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes, $fst$file_access_options [fsc$read]],
            [fsc$required_share_modes]]];


    fsp$open_file (file, amc$record, ^read_attributes, NIL, NIL, NIL, NIL, file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


  PROCEND open_input_file;
?? OLDTITLE ??
?? NEWTITLE := 'process_input_file', EJECT ??

{ PURPOSE:
{  Read commands consisting of module names, procedures, hex pvas, or the
{  word QUIT from the input file.  Output the corresponding information.

  PROCEDURE process_input_file
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);


    VAR
      debug_table_header: ^pmt$linker_debug_table_header,
      transfer_count: amt$transfer_count,
      byte_address: amt$file_byte_address,
      file_position: amt$file_position,
      line: string (31),
      name: string (31),
      found: boolean,
      module_name: pmt$program_name,
      module_item: ^pmt$module_item,
      segment: ost$segment,
      offset: ost$segment_offset,
      intger: integer,
      section_name: pmt$program_name,
      offset_in_section: ost$segment_offset;


    ocp$get_debug_table_header (debug_table_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$output ('0Debug table for ', debug_table_header^.build_level, #SIZE (debug_table_header^.build_level),
          end_of_line);

    ocp$output ('0', 'Enter a module or procedure name, an address, or QUIT to exit.', 62, end_of_line);

?? EJECT ??

    WHILE status.normal DO
      line := ' ';

      amp$get_next (file_identifier, #LOC (line), #SIZE (line), transfer_count, byte_address, file_position,
            status);
      IF status.normal THEN
        IF (file_position = amc$eoi) THEN
          RETURN;
        IFEND;

        IF (transfer_count <> 0) AND (line <> ' ') THEN
          IF (line (1) < '0') OR (line (1) > '9') THEN
            #TRANSLATE (osv$lower_to_upper, line, name);
            IF (name = 'QUI ') OR (name = 'QUIT ') THEN
              RETURN;
            ELSE
              ocp$find_debug_entry_point (name, found, module_name, segment, offset, status);
              IF status.normal THEN
                IF found THEN
                  display_entry_point (name, module_name, segment, offset);
                ELSE
                  ocp$find_debug_module_item (name, 1, found, module_item, status);
                  IF status.normal THEN
                    IF found THEN
                      display_module (module_item);
                    ELSE
                      ocp$output (' Name not found: ', name, #SIZE (name), end_of_line);
                    IFEND;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
?? EJECT ??
          ELSE { address }
            convert_string_to_integer (line, intger);

            segment := intger DIV 100000000(16);
            offset := intger MOD 100000000(16);

            ocp$find_debug_address (segment, offset, found, module_name, section_name, offset_in_section,
                  status);
            IF status.normal THEN
              IF found THEN
                display_address (segment, offset, module_name, section_name, offset_in_section);
              ELSE
                ocp$output (' Address not found: ', line, #SIZE (line), end_of_line);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    WHILEND;


  PROCEND process_input_file;
?? OLDTITLE ??

MODEND ocm$query_linker_debug_tables;
*DECK DECK=OCM$REAL_MEMORY_BUILDER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Real Memory Builder', EJECT ??
MODULE ocm$real_memory_builder;



{ PURPOSE:
{   This module contains the routines for executing the VE
{ Real Memory Builder.

?? PUSH (LISTEXT := ON) ??
*copyc fsc$file_contents
*copyc mmt$segment_descriptor_table_ex
*copyc occ$symbol_table_version
*copyc oce$library_generator_errors
*copyc oce$rm_builder_exceptions
*copyc oce$ve_linker_exceptions
*copyc oct$build_options
*copyc oct$list_of_entry_points
*copyc oct$symbol_table_header
*copyc ost$exchange_package
*copyc ost$execution_control_block
*copyc ost$hardware_subranges
*copyc ost$page_size
*copyc ost$page_table
*copyc ost$spaa_entry
*copyc pmd$memory_image_header
*copyc pmt$virtual_memory_image_header
?? POP ??
*copyc amp$close
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$set_segment_eoi

*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$open_display_file
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page

*copyc i#current_sequence_position
*copyc i#move

*copyc ocp$get_ring_brackets

*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$format_message
*copyc osp$set_status_abnormal

*copyc pmp$get_last_path_name
*copyc pmp$get_legible_date_time
*copyc pmp$position_object_library

*copyc syp$advised_move_bytes
?? NEWTITLE := '  Global Variables', EJECT ??

  CONST
    nos_asid = 0ffff(16),
    ssr_asid = 8000(16),

    reserved = TRUE;

  VAR
    strng: string (80),
    l: integer,

    v$real_memory_image: oct$real_memory_descriptor,
    v$page_table_pages: ^oct$page_descriptor,
    v$end_of_real_memory: ost$real_memory_address,
    v$mtr_exchange_info: oct$exchange_package_info,
    v$job_exchange_info: oct$exchange_package_info,
    v$pp_address_array_rma: ost$real_memory_address,
    v$pp_address_array_pva: oct$exchange_address,
    v$pages_loaded_pva: oct$exchange_address,
    v$page_size_pva: oct$exchange_address,
    v$diagnostic_count: integer,
    v$asid_seed: integer,
    v$display_control: clt$display_control,
    v$zero_filled_page: ^array [ * ] of ost$byte,
    ocv$rmb_scratch_seq: [XREF] ^SEQ ( * );


  VAR
    v$page_header: [STATIC] string (100) :=
          'MEMORY MAP OF                                                                        PAGE';

?? OLDTITLE ??
?? NEWTITLE := '  OCP$GENERATE_REAL_MEMORY', EJECT ??


  PROCEDURE [XDCL] ocp$generate_real_memory
    (    build_options: oct$build_options;
         image_file: amt$local_file_name;
     VAR status: ost$status);

?? NEWTITLE := '    ISSUE_DIAGNOSTIC', EJECT ??

    PROCEDURE issue_diagnostic
      (VAR status: ost$status);



      VAR
        local_status: ost$status,

        message_content: ost$status_message,
        message: ^ost$status_message,
        diagnostic_line_count: ^ost$status_message_line_count,
        diagnostic_line_index: ost$status_message_line_count,
        diagnostic_line_size: ^ost$status_message_line_size,
        diagnostic_line: ^ost$status_message_line;



      message := ^message_content;

      osp$format_message (status, osc$full_message_level, v$display_control.page_width, message_content,
            local_status);

      RESET message;
      NEXT diagnostic_line_count IN message;

      FOR diagnostic_line_index := 1 TO diagnostic_line_count^ DO
        NEXT diagnostic_line_size IN message;
        NEXT diagnostic_line: [diagnostic_line_size^] IN message;

        clp$put_partial_display (v$display_control, diagnostic_line^, clc$no_trim, amc$start, local_status);
      FOREND;

      v$diagnostic_count := v$diagnostic_count + 1;
      status.normal := TRUE;

    PROCEND issue_diagnostic;
?? OLDTITLE ??
?? NEWTITLE := '    NEW_PAGE_PROCEDURE', EJECT ??

    PROCEDURE new_page_procedure
      (VAR display_control: clt$display_control;
           new_page_number: integer;
       VAR status: ost$status);




      clp$reset_for_next_display_page (display_control, status);

      v$page_header (91, 3) := '   ';

      STRINGREP (v$page_header (90, * ), l, display_control.page_number);
      clp$put_display (display_control, v$page_header, clc$trim, status);

      clp$new_display_line (display_control, 2, status);


    PROCEND new_page_procedure;
?? OLDTITLE ??
?? NEWTITLE := '    INITIALIZE_EXCHANGE_INFO', EJECT ??

    PROCEDURE initialize_exchange_info
      (    address_space: oct$address_space_id;
       VAR exchange_info: oct$exchange_package_info);




      exchange_info.p_address.ring := osc$invalid_ring;
      exchange_info.p_address.seg := 0;
      exchange_info.p_address.offset := 0;

      exchange_info.binding_address.ring := osc$invalid_ring;
      exchange_info.binding_address.seg := 0;
      exchange_info.binding_address.offset := 0;

      exchange_info.address_space := address_space;
      exchange_info.rma := 0;
      exchange_info.segment_descriptor_list.link := NIL;
      exchange_info.symbol_table := NIL;

    PROCEND initialize_exchange_info;
?? OLDTITLE ??
?? NEWTITLE := '    SETUP_RMB_PARAMETERS', EJECT ??

    PROCEDURE setup_rmb_parameters
      (VAR status: ost$status);




      VAR
        of_execution: boolean,
        i: integer,
        time: ost$time,
        date: ost$date,
        valid_position: boolean,
        default_rings: amt$ring_attributes,
        open_position: amt$open_position,
        local_status: ost$status;



      v$asid_seed := 1;
      v$diagnostic_count := 0;

      pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pmp$get_last_path_name (image_file, v$page_header (17, 31), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      v$page_header (62, 8) := date.mdy;
      v$page_header (72, 8) := time.hms;

      initialize_exchange_info (occ$mtr, v$mtr_exchange_info);
      initialize_exchange_info (occ$job, v$job_exchange_info);
      v$pp_address_array_rma := 0;

      NEXT v$zero_filled_page: [1 .. build_options.page_size] IN ocv$rmb_scratch_seq;
      IF v$zero_filled_page = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB0', status);
        RETURN;
      IFEND;

      FOR i := 1 TO build_options.page_size DO
        v$zero_filled_page^ [i] := 0;
      FOREND;

      NEXT v$real_memory_image.page: [0 .. build_options.page_table_length DIV 8] IN ocv$rmb_scratch_seq;
      IF v$real_memory_image.page = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB1', status);
        RETURN;
      IFEND;

      FOR i := 0 TO UPPERBOUND (v$real_memory_image.page^) DO
        v$real_memory_image.page^ [i].reserved := FALSE;
        v$real_memory_image.page^ [i].continue_bits := 0;
      FOREND;

      v$end_of_real_memory := (build_options.page_table_length DIV 8) * build_options.page_size;


      v$real_memory_image.reserved_asids.link := NIL;

      open_real_memory_image (image_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (build_options.building_ei) OR (build_options.load_address <> 0) THEN
        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, build_options.load_address,
              valid_position);
      ELSE
        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer,
              build_options.page_table_address + build_options.page_table_length, valid_position);
      IFEND;

      v$real_memory_image.next_free_page := i#current_sequence_position
            (v$real_memory_image.segment.sequence_pointer);
      v$real_memory_image.length := 0;
      v$real_memory_image.pt_continue_bits := 0;

      default_rings.r1 := #RING (^of_execution);
      default_rings.r2 := #RING (^of_execution);
      default_rings.r3 := #RING (^of_execution);

      clp$open_display_file (build_options.memory_map, ^new_page_procedure, fsc$list, default_rings,
            v$display_control, status);
      IF NOT status.normal THEN
        amp$close (v$real_memory_image.id, local_status);
        RETURN;
      IFEND;

    PROCEND setup_rmb_parameters;
?? OLDTITLE ??
?? NEWTITLE := '    VERIFY_BUILD_OPTIONS', EJECT ??

    PROCEDURE verify_build_options
      (    build_options: oct$build_options;
       VAR status: ost$status);




      IF (i#current_sequence_position (v$real_memory_image.segment.sequence_pointer) MOD
            build_options.page_size) <> 0 THEN
        osp$set_status_abnormal ('OC', oce$e_build_option_error, 'LOAD ADDRESS MUST BE ON PAGE BOUNDRY',
              status);
        RETURN;
      IFEND;

      IF i#current_sequence_position (v$real_memory_image.segment.sequence_pointer) <
            build_options.load_offset THEN
        osp$set_status_abnormal ('OC', oce$e_build_option_error, 'LOAD ADDRESS MUST BE GE TO LOAD OFFSET',
              status);
        RETURN;
      IFEND;

      IF NOT build_options.building_ei THEN
        IF build_options.page_table_address < build_options.load_offset THEN
          osp$set_status_abnormal ('OC', oce$e_build_option_error,
                'PAGE TABLE ADDRESS MUST BE GE LOAD OFFSET', status);
          RETURN;
        IFEND;


        IF (build_options.page_table_address MOD build_options.page_table_length) <> 0 THEN
          osp$set_status_abnormal ('OC', oce$e_build_option_error,
                'PAGE TABLE ADDRESS MUST BE 0 MOD PAGE TABLE LENGTH', status);
          RETURN;
        IFEND;

        IF (build_options.page_table_address + build_options.page_table_length) >
              i#current_sequence_position (v$real_memory_image.segment.sequence_pointer) THEN
          osp$set_status_abnormal ('OC', oce$e_build_option_error,
                'LOAD ADDRESS MUST BE GT END OF PAGE TABLE', status);
          RETURN;
        IFEND;
      IFEND;

      IF (build_options.ssr_size MOD build_options.page_size) <> 0 THEN
        osp$set_status_abnormal ('OC', oce$e_build_option_error, 'SSR_SIZE MUST BE ZERO MOD PAGE SIZE',
              status);
        RETURN;
      IFEND;

    PROCEND verify_build_options;
?? OLDTITLE ??
?? NEWTITLE := '    ALLOCATE_PAGE_TABLE', EJECT ??

    PROCEDURE allocate_page_table
      (VAR status: ost$status);

      VAR
        valid_position: boolean,
        i: 0 .. osc$max_page_table_entries;


      allocate_pages (build_options.page_table_address, build_options.page_table_length, v$page_table_pages,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pmp$position_object_library (v$real_memory_image.segment.sequence_pointer,
            build_options.page_table_address, valid_position);

      NEXT v$real_memory_image.page_table: [0 .. build_options.page_table_length DIV 8] IN
            v$real_memory_image.segment.sequence_pointer;

      FOR i := 0 TO UPPERBOUND (v$real_memory_image.page_table^) DO
        v$real_memory_image.page_table^ [i].v := FALSE;
        v$real_memory_image.page_table^ [i].c := FALSE;
        v$real_memory_image.page_table^ [i].u := FALSE;
        v$real_memory_image.page_table^ [i].m := FALSE;
        v$real_memory_image.page_table^ [i].pageid.asid := 0;
        v$real_memory_image.page_table^ [i].pageid.pagenum := 0;
        v$real_memory_image.page_table^ [i].rma := 0;
      FOREND;


{ Deadstart kludge to protect the location of the PP_ADDRESS_ARRAY pointer.

      v$real_memory_image.page_table^ [1].v := TRUE;
      v$real_memory_image.page_table^ [1].m := TRUE;


    PROCEND allocate_page_table;
?? OLDTITLE ??
?? NEWTITLE := '    OPEN_INPUT_FILE', EJECT ??

    PROCEDURE open_input_file
      (    name: amt$local_file_name;
       VAR input_file: oct$file_descriptor;
       VAR status: ost$status);


      VAR
        local_file: boolean,
        existing_file: boolean,
        contains_data: boolean,

        get_attributes: [STATIC] array [1 .. 2] of amt$get_item :=
              [[ * , amc$file_contents, * ], [ * , amc$file_structure, * ]],

        read_attributes: [STATIC] array [1 .. 1] of amt$access_selection :=
              [[amc$access_mode, $pft$usage_selections [pfc$read]]];


      input_file.name := name;

      amp$get_file_attributes (input_file.name, get_attributes, local_file, existing_file, contains_data,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (get_attributes [1].file_contents <> amc$unknown_contents) OR
            (get_attributes [2].file_structure <> amc$data) THEN
        osp$set_status_abnormal ('OC', oce$e_bad_input_file, input_file.name, status);
        RETURN;
      IFEND;

      amp$open (input_file.name, amc$segment, ^read_attributes, input_file.id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$get_segment_pointer (input_file.id, amc$sequence_pointer, input_file.segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND open_input_file;
?? OLDTITLE ??
?? NEWTITLE := '    OPEN_REAL_MEMORY_IMAGE', EJECT ??

    PROCEDURE open_real_memory_image
      (    name: amt$local_file_name;
       VAR status: ost$status);




?? FMT (FORMAT := OFF) ??
  VAR
    file_attributes: [STATIC] array [1 .. 6] of amt$access_selection := [
      [amc$ring_attributes, *],
      [amc$access_mode, $pft$usage_selections [pfc$append, pfc$modify, pfc$shorten, pfc$read]],
      [amc$preset_value, 00(16)],
      [amc$file_structure, amc$data],
      [amc$file_contents, amc$unknown_contents],
      [amc$file_processor, amc$unknown_processor]];


?? FMT (FORMAT:=ON) ??

      ocp$get_ring_brackets (name, file_attributes [1].ring_attributes, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$open (name, amc$segment, ^file_attributes, v$real_memory_image.id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


      amp$get_segment_pointer (v$real_memory_image.id, amc$sequence_pointer, v$real_memory_image.segment,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      RESET v$real_memory_image.segment.sequence_pointer;


    PROCEND open_real_memory_image;
?? OLDTITLE ??
?? NEWTITLE := '    CLOSE_FILE', EJECT ??

    PROCEDURE close_file
      (    file_descriptor: oct$file_descriptor;
       VAR status: ost$status);



      amp$close (file_descriptor.id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


    PROCEND close_file;
?? OLDTITLE ??
?? NEWTITLE := '    SEARCH_FOR_SEGMENT', EJECT ??

    PROCEDURE search_for_segment
      (    address_space: oct$address_space_id;
           segment_number: ost$segment;
       VAR segment_descriptor: ^oct$segment_descriptor;
       VAR found: boolean);



      IF address_space = occ$mtr THEN
        segment_descriptor := v$mtr_exchange_info.segment_descriptor_list.link;
      ELSE
        segment_descriptor := v$job_exchange_info.segment_descriptor_list.link;
      IFEND;

      WHILE segment_descriptor <> NIL DO

        IF segment_descriptor^.segment_number = segment_number THEN
          found := TRUE;
          RETURN;
        IFEND;

        segment_descriptor := segment_descriptor^.link;
      WHILEND;

      found := FALSE;

    PROCEND search_for_segment;
?? OLDTITLE ??
?? NEWTITLE := '    SEARCH_FOR_OFFSET', EJECT ??

    PROCEDURE search_for_offset
      (    offset: ost$segment_offset;
           pages: ^oct$page_descriptor;
       VAR rma: ost$real_memory_address;
       VAR found: boolean);


      VAR
        page: ^oct$page_descriptor,
        offset_in_segment: ost$segment_offset;


      offset_in_segment := 0;
      page := pages;

      WHILE page <> NIL DO
        IF (offset_in_segment + build_options.page_size) > offset THEN
          rma := page^.offset + (offset - offset_in_segment);
          found := TRUE;
          RETURN;
        ELSE
          offset_in_segment := offset_in_segment + build_options.page_size;
          page := page^.link;
        IFEND;
      WHILEND;

      found := FALSE;


    PROCEND search_for_offset;
?? OLDTITLE ??
?? NEWTITLE := '    SEARCH_RESERVED_ASIDS', EJECT ??

    PROCEDURE search_reserved_asids
      (    asid: ost$asid;
       VAR found: boolean;
       VAR last_asid: ^oct$reserved_asids);



      last_asid := ^v$real_memory_image.reserved_asids;

      WHILE last_asid^.link <> NIL DO
        last_asid := last_asid^.link;

        IF last_asid^.asid = asid THEN
          found := TRUE;
          RETURN;
        IFEND;
      WHILEND;

      found := FALSE;


    PROCEND search_reserved_asids;
?? OLDTITLE ??
?? NEWTITLE := '    GENERATE_PAGE_TABLE_INDEX', EJECT ??

    PROCEDURE generate_page_table_index
      (    asid: ost$asid;
           pagenum: 0 .. 3fffff(16);
       VAR pti: -osc$max_page_table_entries .. osc$max_page_table_entries);



      VAR
        i: integer,
        temp_asid: ost$asid,
        temp_pagenum: 0 .. osc$max_page_table_entries,
        f: integer;



      f := 2;
      pti := 0;
      temp_asid := asid;
      temp_pagenum := (pagenum * 512) DIV build_options.page_size;

      FOR i := 1 TO 16 DO
        IF (temp_asid MOD 2) <> (temp_pagenum MOD 2) THEN
          pti := pti + f;
        IFEND;

        temp_asid := temp_asid DIV 2;
        temp_pagenum := temp_pagenum DIV 2;
        f := f * 2;
      FOREND;

      pti := pti MOD (build_options.page_table_length DIV 8);


    PROCEND generate_page_table_index;
?? OLDTITLE ??
?? NEWTITLE := '    ADD_A_SEGMENT', EJECT ??

    PROCEDURE add_a_segment
      (    new_segment_descriptor: ^oct$segment_descriptor;
       VAR segment_descriptor_list: oct$segment_descriptor);




      VAR
        segment_descriptor: ^oct$segment_descriptor,
        local_status: ost$status;



      segment_descriptor := ^segment_descriptor_list;

      WHILE (segment_descriptor^.link <> NIL) AND (segment_descriptor^.link^.segment_number <>
            new_segment_descriptor^.segment_number) DO
        segment_descriptor := segment_descriptor^.link;
      WHILEND;

      IF segment_descriptor^.link = NIL THEN
        segment_descriptor^.link := new_segment_descriptor;
        segment_descriptor^.link^.link := NIL;
      ELSE
        STRINGREP (strng, l, new_segment_descriptor^.segment_number);
        osp$set_status_abnormal ('OC', oce$e_duplicate_segment_numbers, strng (1, l), local_status);
        issue_diagnostic (local_status);
      IFEND;


    PROCEND add_a_segment;
?? OLDTITLE ??
?? NEWTITLE := '    RESERVE_PAGES', EJECT ??

    PROCEDURE search_for_contiguous_pages
      (    starting_address: ost$real_memory_address;
           length: ost$segment_length;
       VAR found: boolean;
       VAR start_of_contiguous_pages: ost$real_memory_address);





      VAR
        contiguous_memory: ost$real_memory_address,
        memory_needed: ost$real_memory_address;





      IF length = 0 THEN
        found := TRUE;
        RETURN;
      IFEND;

      start_of_contiguous_pages := starting_address - (starting_address MOD build_options.page_size);
      memory_needed := length + (starting_address MOD build_options.page_size);

      WHILE start_of_contiguous_pages < v$end_of_real_memory DO
        contiguous_memory := 0;

        WHILE ((start_of_contiguous_pages + contiguous_memory) < v$end_of_real_memory) AND
              (NOT v$real_memory_image.page^ [(contiguous_memory + start_of_contiguous_pages) DIV
              build_options.page_size].reserved) DO
          IF contiguous_memory >= memory_needed THEN
            found := TRUE;
            RETURN;
          IFEND;
          contiguous_memory := contiguous_memory + build_options.page_size;
        WHILEND;

        IF (start_of_contiguous_pages + contiguous_memory) >= v$end_of_real_memory THEN
          found := FALSE;
          RETURN;
        IFEND;

        start_of_contiguous_pages := start_of_contiguous_pages + contiguous_memory + build_options.page_size;
      WHILEND;

      found := FALSE;

    PROCEND search_for_contiguous_pages;
?? OLDTITLE ??
?? NEWTITLE := '    ALLOCATE_PAGES', EJECT ??

    PROCEDURE allocate_pages
      (    starting_address: ost$real_memory_address;
           length: ost$segment_length;
       VAR pages: ^oct$page_descriptor;
       VAR status: ost$status);



      VAR
        valid_position: boolean,
        memory: ^array [ * ] of ost$byte,
        current_address: ost$real_memory_address,
        adjusted_length: ost$segment_length,
        memory_allocated: ost$segment_length,
        last_page_descriptor: ^oct$page_descriptor,
        page_descriptor: oct$page_descriptor;


      page_descriptor.link := NIL;
      last_page_descriptor := ^page_descriptor;

      current_address := starting_address - (starting_address MOD build_options.page_size);
      adjusted_length := length + (starting_address MOD build_options.page_size);
      memory_allocated := 0;

      WHILE memory_allocated < adjusted_length DO
        WHILE v$real_memory_image.page^ [current_address DIV build_options.page_size].reserved DO
          current_address := current_address + build_options.page_size;
        WHILEND;

        IF current_address >= v$end_of_real_memory THEN
          osp$set_status_abnormal ('OC', oce$e_no_memory_available, '', status);
          RETURN;
        IFEND;

        NEXT last_page_descriptor^.link IN ocv$rmb_scratch_seq;
        last_page_descriptor := last_page_descriptor^.link;
        IF last_page_descriptor = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB4', status);
          RETURN;
        IFEND;

        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, current_address,
              valid_position);
        NEXT memory: [1 .. build_options.page_size] IN v$real_memory_image.segment.sequence_pointer;
        IF memory = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_real_memory_overflow, '', status);
          RETURN;
        IFEND;

        memory^ := v$zero_filled_page^;

        v$real_memory_image.page^ [current_address DIV build_options.page_size].reserved := reserved;
        last_page_descriptor^.offset := current_address;
        current_address := current_address + build_options.page_size;
        memory_allocated := memory_allocated + build_options.page_size;
      WHILEND;

      last_page_descriptor^.link := NIL;

      WHILE v$real_memory_image.page^ [v$real_memory_image.next_free_page DIV
            build_options.page_size].reserved DO
        v$real_memory_image.next_free_page := v$real_memory_image.next_free_page + build_options.page_size;
      WHILEND;

      pages := page_descriptor.link;

    PROCEND allocate_pages;
?? OLDTITLE ??
?? NEWTITLE := '    ALLOCATE_FIXED_PAGES', EJECT ??

    PROCEDURE allocate_fixed_pages
      (    starting_address: ost$real_memory_address;
           length: ost$segment_length;
       VAR segment_descriptor: ^oct$segment_descriptor;
       VAR status: ost$status);




      VAR
        adjusted_length: ost$segment_length;



      segment_descriptor^.pages := NIL;

      IF length > 0 THEN
        IF v$real_memory_image.page^ [starting_address DIV build_options.page_size].reserved THEN
          STRINGREP (strng, l, starting_address);
          osp$set_status_abnormal ('OC', oce$e_page_already_allocated, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        allocate_pages (starting_address, build_options.page_size, segment_descriptor^.pages, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        adjusted_length := length + (starting_address MOD build_options.page_size);

        IF adjusted_length > build_options.page_size THEN
          allocate_pages (v$real_memory_image.next_free_page, adjusted_length - build_options.page_size,
                segment_descriptor^.pages^.link, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;

    PROCEND allocate_fixed_pages;
?? OLDTITLE ??
?? NEWTITLE := '    ALLOCATE_FIXED_CONTIGUOUS_PAGES', EJECT ??

    PROCEDURE allocate_fixed_contiguous_pages
      (    starting_address: ost$real_memory_address;
           length: ost$segment_length;
       VAR segment_descriptor: ^oct$segment_descriptor;
       VAR status: ost$status);



      VAR
        adjusted_address: ost$real_memory_address,
        adjusted_length: ost$segment_length,
        contiguous_pages_found: boolean,
        start_of_contiguous_pages: ost$real_memory_address;




      segment_descriptor^.pages := NIL;

      IF length > 0 THEN
        adjusted_address := starting_address - (starting_address MOD build_options.page_size);
        adjusted_length := length + (starting_address MOD build_options.page_size);

        search_for_contiguous_pages (adjusted_address, adjusted_length, contiguous_pages_found,
              start_of_contiguous_pages);
        IF (NOT contiguous_pages_found) OR (adjusted_address <> start_of_contiguous_pages) THEN
          STRINGREP (strng, l, segment_descriptor^.segment_number);
          osp$set_status_abnormal ('OC', oce$e_no_contiguous_real_memory, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        allocate_pages (start_of_contiguous_pages, adjusted_length, segment_descriptor^.pages, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    PROCEND allocate_fixed_contiguous_pages;
?? OLDTITLE ??
?? NEWTITLE := '    BUILD_SEGMENT_DESCRIPTORS', EJECT ??

    PROCEDURE build_segment_descriptor
      (    input_segment: ^pmt$linked_segment_description;
       VAR segment_descriptor: oct$segment_descriptor);



      segment_descriptor.ste := input_segment^.segment_descriptor;

      segment_descriptor.software_attributes := input_segment^.software_attributes;

      segment_descriptor.pages := NIL;
      segment_descriptor.asid := NIL;
      segment_descriptor.segment_number := input_segment^.segment_number;
      segment_descriptor.segment_id := osc$null_name;

      NEXT segment_descriptor.segment_length IN ocv$rmb_scratch_seq;
      IF segment_descriptor.segment_length = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB14', status);
        RETURN;
      IFEND;

      segment_descriptor.segment_length^ := input_segment^.length;
      segment_descriptor.link := NIL;

    PROCEND build_segment_descriptor;
?? OLDTITLE ??
?? NEWTITLE := '    COPY_FILE', EJECT ??

    PROCEDURE copy_file
      (VAR segment_file: oct$file_descriptor;
       VAR segment_descriptor: oct$segment_descriptor;
       VAR status: ost$status);





      VAR
        segment: ^array [1 .. * ] of ost$byte,
        page: ^array [1 .. * ] of ost$byte,
        page_descriptor: ^oct$page_descriptor,
        next_page_descriptor: ^oct$page_descriptor,

        valid_position: boolean,

        bytes_to_move: ost$segment_offset,
        byte: ost$segment_offset,
        length: ost$segment_offset;


      IF segment_descriptor.segment_length^ > 0 THEN

      /copy/
        BEGIN
          NEXT segment: [1 .. segment_descriptor.segment_length^] IN segment_file.segment.sequence_pointer;
          IF segment = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, segment_file.name, status);
            EXIT /copy/;
          IFEND;

          byte := 0;
          page_descriptor := segment_descriptor.pages;

          WHILE page_descriptor <> NIL DO
            bytes_to_move := build_options.page_size;
            next_page_descriptor := page_descriptor^.link;
            WHILE (next_page_descriptor <> NIL) AND ((page_descriptor^.offset + bytes_to_move) =
                  next_page_descriptor^.offset) DO
              bytes_to_move := bytes_to_move + build_options.page_size;
              next_page_descriptor := next_page_descriptor^.link;
            WHILEND;

            pmp$position_object_library (v$real_memory_image.segment.sequence_pointer,
                  page_descriptor^.offset, valid_position);

            NEXT page: [1 .. bytes_to_move] IN v$real_memory_image.segment.sequence_pointer;
            IF page = NIL THEN
              osp$set_status_abnormal ('OC', oce$e_real_memory_overflow, '', status);
              EXIT /copy/;
            IFEND;

            IF (bytes_to_move) <= (segment_descriptor.segment_length^ -byte) THEN
              length := bytes_to_move;
            ELSE
              length := segment_descriptor.segment_length^ -byte;
            IFEND;

            syp$advised_move_bytes (#LOC (segment^ [byte + 1]), #LOC (page^ [1]), length, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            byte := byte + bytes_to_move;
            page_descriptor := next_page_descriptor;
          WHILEND;

          RETURN;
        END /copy/;
      IFEND;

    PROCEND copy_file;
?? OLDTITLE ??
?? NEWTITLE := '    PROCESS_DEFINE_SEGMENTS', EJECT ??

    PROCEDURE process_define_segments
      (    define_segment_list: oct$define_command_list;
       VAR status: ost$status);





      VAR
        last_asid: ^oct$reserved_asids,

        found: boolean,

        segment_descriptor: ^oct$segment_descriptor,
        duplicate_segment_descriptor: ^oct$segment_descriptor,
        define_segments: ^oct$define_command_list;



      define_segments := define_segment_list.link;

      WHILE define_segments <> NIL DO

      /define_segment/
        BEGIN
          IF (define_segments^.address MOD build_options.page_size) <> 0 THEN
            STRINGREP (strng, l, define_segments^.segment_number);
            osp$set_status_abnormal ('OC', oce$e_invalid_define_seg_addr, strng (1, l), status);
            issue_diagnostic (status);
            EXIT /define_segment/;
          IFEND;

          IF define_segments^.address < build_options.load_offset THEN
            STRINGREP (strng, l, define_segments^.segment_number);
            osp$set_status_abnormal ('OC', oce$e_invalid_define_seg_addr, strng (1, l), status);
            issue_diagnostic (status);
            EXIT /define_segment/;
          IFEND;

          NEXT segment_descriptor IN ocv$rmb_scratch_seq;
          IF segment_descriptor = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB5', status);
            RETURN;
          IFEND;

          segment_descriptor^.segment_id := define_segments^.segment_id;

          IF define_segments^.hardware_attributes.cache_bypass THEN
            segment_descriptor^.ste.vl := osc$vl_cache_bypass;
          ELSE
            segment_descriptor^.ste.vl := osc$vl_regular_segment;
          IFEND;

          segment_descriptor^.ste.xp := define_segments^.hardware_attributes.execute_privilege;
          segment_descriptor^.ste.wp := define_segments^.hardware_attributes.write_privilege;
          segment_descriptor^.ste.rp := define_segments^.hardware_attributes.read_privilege;
          segment_descriptor^.ste.r1 := define_segments^.r1;
          segment_descriptor^.ste.r2 := define_segments^.r2;
          segment_descriptor^.ste.key_lock := define_segments^.key_lock;
          segment_descriptor^.software_attributes := define_segments^.software_attributes;

          NEXT segment_descriptor^.asid IN ocv$rmb_scratch_seq;
          IF segment_descriptor^.asid = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB6', status);
            RETURN;
          IFEND;

          segment_descriptor^.asid^.assigned := FALSE;

          IF occ$asid IN define_segments^.parameters THEN
            search_reserved_asids (define_segments^.active_segment_id, found, last_asid);
            IF found THEN
              STRINGREP (strng, l, define_segments^.active_segment_id);
              osp$set_status_abnormal ('OC', oce$e_duplicate_asid_specified, strng (1, l), status);
              issue_diagnostic (status);
              EXIT /define_segment/;
            ELSE
              NEXT last_asid^.link IN ocv$rmb_scratch_seq;
              last_asid := last_asid^.link;
              IF last_asid = NIL THEN
                osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB7', status);
                RETURN;
              IFEND;

              last_asid^.asid := define_segments^.active_segment_id;
              last_asid^.link := NIL;
              segment_descriptor^.asid^.predefined := TRUE;
              segment_descriptor^.asid^.active_segment_id := define_segments^.active_segment_id;
            IFEND;
          ELSE
            segment_descriptor^.asid^.predefined := FALSE;
          IFEND;

          segment_descriptor^.segment_number := define_segments^.segment_number;

          NEXT segment_descriptor^.segment_length IN ocv$rmb_scratch_seq;
          IF segment_descriptor^.segment_length = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB15', status);
            RETURN;
          IFEND;
          segment_descriptor^.segment_length^ := define_segments^.length;

          IF define_segments^.segment_id <> 'PAGE_TABLE                     ' THEN
            IF define_segments^.contiguous_space THEN
              allocate_fixed_contiguous_pages (define_segments^.address, segment_descriptor^.segment_length^,
                    segment_descriptor, status);
            ELSE
              allocate_fixed_pages (define_segments^.address, segment_descriptor^.segment_length^,
                    segment_descriptor, status);
            IFEND;
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSE
            segment_descriptor^.pages := v$page_table_pages;
          IFEND;

          CASE define_segments^.address_space OF
          = occ$mtr =
            add_a_segment (segment_descriptor, v$mtr_exchange_info.segment_descriptor_list);

          = occ$job =
            add_a_segment (segment_descriptor, v$job_exchange_info.segment_descriptor_list);

          = occ$both =
            NEXT duplicate_segment_descriptor IN ocv$rmb_scratch_seq;
            IF duplicate_segment_descriptor = NIL THEN
              osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB15', status);
              RETURN;
            IFEND;

            duplicate_segment_descriptor^ := segment_descriptor^;

            add_a_segment (segment_descriptor, v$mtr_exchange_info.segment_descriptor_list);

            add_a_segment (duplicate_segment_descriptor, v$job_exchange_info.segment_descriptor_list);
          CASEND;
        END /define_segment/;

        define_segments := define_segments^.link;
      WHILEND;

    PROCEND process_define_segments;
?? OLDTITLE ??
?? NEWTITLE := '    READ_SYMBOL_TABLE', EJECT ??

    PROCEDURE read_symbol_table
      (    lst_file: oct$file_descriptor;
       VAR lst_last: integer;
       VAR status: ost$status);


      VAR
        header: ^oct$symbol_table_header,
        linker_symbol_table: ^oct$list_of_entry_points,
        lst_sequence: ^SEQ ( * ),
        symbol_table: ^oct$symbol_table,
        symbol_number: integer;


      lst_sequence := lst_file.segment.sequence_pointer;

      RESET lst_sequence;
      NEXT header IN lst_sequence;
      IF header = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, lst_file.name, status);
        issue_diagnostic (status);
        RETURN;
      IFEND;

      IF header^.version <> occ$symbol_table_version THEN
        osp$set_status_abnormal ('OC', oce$e_invalid_lst_version, lst_file.name, status);
        issue_diagnostic (status);
        RETURN;
      IFEND;

      IF header^.number_of_symbols > 0 THEN
        NEXT linker_symbol_table: [1 .. header^.number_of_symbols] IN lst_sequence;
        IF linker_symbol_table = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, lst_file.name, status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        NEXT symbol_table: [1 .. header^.number_of_symbols] IN ocv$rmb_scratch_seq;
        IF symbol_table = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB8', status);
          RETURN;
        IFEND;

        FOR symbol_number := 1 TO header^.number_of_symbols DO
          symbol_table^ [symbol_number].name := linker_symbol_table^ [symbol_number].name;
          symbol_table^ [symbol_number].pva := linker_symbol_table^ [symbol_number].pva;
        FOREND;

        lst_last := lst_last + header^.number_of_symbols;
      IFEND;

    PROCEND read_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := '    BUILD_SYMBOL_TABLE', EJECT ??

    PROCEDURE build_symbol_table
      (    symbol_table_list: oct$symbol_table_list;
       VAR exchange_info: oct$exchange_package_info;
       VAR status: ost$status);





      VAR
        local_status: ost$status,

        number_of_symbols: integer,
        reset_value: ^SEQ ( * ),

        ost_file: oct$file_descriptor,
        symbol_tables: ^oct$symbol_table_list;



      reset_value := ocv$rmb_scratch_seq;
      number_of_symbols := 0;
      symbol_tables := symbol_table_list.link;

      WHILE symbol_tables <> NIL DO

        open_input_file (symbol_tables^.name, ost_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        read_symbol_table (ost_file, number_of_symbols, status);
        IF NOT status.normal THEN
          close_file (ost_file, local_status);
          IF NOT local_status.normal THEN
            issue_diagnostic (local_status);
          IFEND;
          RETURN;
        IFEND;

        close_file (ost_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        symbol_tables := symbol_tables^.link;
      WHILEND;

      IF number_of_symbols <> 0 THEN
        ocv$rmb_scratch_seq := reset_value;
        NEXT exchange_info.symbol_table: [1 .. number_of_symbols] IN ocv$rmb_scratch_seq;
      IFEND;

    PROCEND build_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := '    CHANGE_EXCHANGE_NAME_TO_ADDR', EJECT ??

    PROCEDURE change_exchange_name_to_addr
      (    exchange_name: oct$exchange_name;
       VAR exchange_address: oct$exchange_address);



      VAR
        local_status: ost$status,

        symbol_table: ^oct$symbol_table,
        i: integer;


      IF exchange_name.address_space = occ$null THEN
        exchange_address.address_space := occ$null;
      ELSE
        IF exchange_name.address_space = occ$mtr THEN
          symbol_table := v$mtr_exchange_info.symbol_table;
        ELSE
          symbol_table := v$job_exchange_info.symbol_table;
        IFEND;

        IF symbol_table <> NIL THEN
          FOR i := 1 TO UPPERBOUND (symbol_table^) DO
            IF exchange_name.name = symbol_table^ [i].name THEN
              exchange_address.address_space := exchange_name.address_space;
              exchange_address.segment := symbol_table^ [i].pva.seg;
              exchange_address.segment_offset := symbol_table^ [i].pva.offset;
              RETURN;
            IFEND;
          FOREND;
        IFEND;

        exchange_address.address_space := occ$null;
        osp$set_status_abnormal ('OC', oce$e_exchange_symbol_not_found, exchange_name.name, local_status);
        issue_diagnostic (local_status);
      IFEND;

    PROCEND change_exchange_name_to_addr;
?? OLDTITLE ??
?? NEWTITLE := '    LOAD_FILE', EJECT ??

    PROCEDURE load_file
      (VAR segment_file: oct$file_descriptor;
       VAR exchange_info: oct$exchange_package_info;
       VAR status: ost$status);


      VAR
        pva: ^ost$pva,
        found: boolean,
        starting_address: ost$real_memory_address,

        virtual_memory_image_header: ^pmt$virtual_memory_image_header,
        segment_descriptors: ^oct$segment_descriptors,
        linked_segment_description: ^pmt$linked_segment_description,

{ 170 comparability kludge

        segment_command: ^oct$segment_command_list,
        seg_desc: ost$segment;



      RESET segment_file.segment.sequence_pointer;

      NEXT virtual_memory_image_header IN segment_file.segment.sequence_pointer;
      IF virtual_memory_image_header = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, segment_file.name, status);
        RETURN;
      IFEND;

      IF virtual_memory_image_header^.version <> pmc$image_version THEN
        osp$set_status_abnormal ('OC', oce$e_invalid_load_file_version, segment_file.name, status);
        RETURN;
      IFEND;

      IF virtual_memory_image_header^.number_of_segments = 0 THEN
        osp$set_status_abnormal ('OC', oce$e_empty_segment_file, segment_file.name, status);
        RETURN;
      ELSE

{ The p_address ring number is zero only if there was no primary entry point for
{ this group of load segments.

        pva := #LOC (virtual_memory_image_header^.starting_procedure.code_pva);

        IF pva^.ring <> osc$invalid_ring THEN
          exchange_info.p_address := pva^;

          pva := #LOC (virtual_memory_image_header^.starting_procedure.binding_pva);
          exchange_info.binding_address := pva^;
        IFEND;

        NEXT segment_descriptors: [1 .. virtual_memory_image_header^.number_of_segments] IN
              ocv$rmb_scratch_seq;
        IF segment_descriptors = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB9', status);
          RETURN;
        IFEND;

      /process_segments/
        FOR seg_desc := 1 TO virtual_memory_image_header^.number_of_segments DO

          NEXT linked_segment_description IN segment_file.segment.sequence_pointer;
          IF linked_segment_description = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, segment_file.name, status);
            RETURN;
          IFEND;

          build_segment_descriptor (linked_segment_description, segment_descriptors^ [seg_desc]);

          NEXT segment_descriptors^ [seg_desc].asid IN ocv$rmb_scratch_seq;
          IF segment_descriptors^ [seg_desc].asid = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB10', status);
            RETURN;
          IFEND;

          segment_descriptors^ [seg_desc].asid^.assigned := FALSE;
          segment_descriptors^ [seg_desc].asid^.predefined := FALSE;

          starting_address := v$real_memory_image.next_free_page;
          IF (exchange_info.address_space = v$job_exchange_info.exchange_address.address_space) AND
                (v$job_exchange_info.exchange_address.segment = segment_descriptors^ [seg_desc].
                segment_number) THEN
            search_for_contiguous_pages (starting_address, segment_descriptors^ [seg_desc].segment_length^,
                  found, starting_address);
            IF found THEN
              v$job_exchange_info.rma := starting_address + exchange_info.exchange_address.segment_offset;
            ELSE
              v$job_exchange_info.exchange_address.address_space := occ$null;
              osp$set_status_abnormal ('OC', oce$e_no_contiguous_real_memory,
                    'containing JOB EXCHANGE PACKAGE', status);
              issue_diagnostic (status);
              CYCLE /process_segments/;
            IFEND;
          IFEND;

          IF (exchange_info.address_space = v$mtr_exchange_info.exchange_address.address_space) AND
                (v$mtr_exchange_info.exchange_address.segment = segment_descriptors^ [seg_desc].
                segment_number) THEN
            search_for_contiguous_pages (starting_address, segment_descriptors^ [seg_desc].segment_length^,
                  found, starting_address);
            IF found THEN
              v$mtr_exchange_info.rma := starting_address + exchange_info.exchange_address.segment_offset;
            ELSE
              v$mtr_exchange_info.exchange_address.address_space := occ$null;
              osp$set_status_abnormal ('OC', oce$e_no_contiguous_real_memory,
                    'containing MTR EXCHANGE PACKAGE', status);
              issue_diagnostic (status);
              CYCLE /process_segments/;
            IFEND;
          IFEND;


          allocate_pages (starting_address, segment_descriptors^ [seg_desc].segment_length^,
                segment_descriptors^ [seg_desc].pages, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          copy_file (segment_file, segment_descriptors^ [seg_desc], status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ 170 comparability kludge

          segment_command := build_options.segment_commands.link;
          WHILE segment_command <> NIL DO
            IF segment_command^.kind = occ$extend THEN
              IF (segment_command^.address_space = exchange_info.address_space) AND
                    (segment_command^.segment_number = segment_descriptors^ [seg_desc].segment_number) THEN
                extend_segment (segment_command, segment_descriptors^ [seg_desc], status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              IFEND;
            IFEND;
            segment_command := segment_command^.link;
          WHILEND;

          add_a_segment (^segment_descriptors^ [seg_desc], exchange_info.segment_descriptor_list);
        FOREND /process_segments/;
      IFEND;

    PROCEND load_file;
?? OLDTITLE ??
?? NEWTITLE := '    PROCESS_LOAD_FILES', EJECT ??

    PROCEDURE process_load_files
      (    load_file_list: oct$load_file_list;
       VAR status: ost$status);





      VAR
        local_status: ost$status,

        header_file: oct$file_descriptor,
        load_files: ^oct$load_file_list;



      load_files := load_file_list.link;

      WHILE load_files <> NIL DO
        open_input_file (load_files^.name, header_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        CASE load_files^.address_space OF
        = occ$mtr =
          load_file (header_file, v$mtr_exchange_info, status);

        = occ$job =
          load_file (header_file, v$job_exchange_info, status);

        CASEND;

        IF NOT status.normal THEN
          close_file (header_file, local_status);
          IF NOT local_status.normal THEN
            issue_diagnostic (local_status);
          IFEND;
          RETURN;
        IFEND;


        close_file (header_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        load_files := load_files^.link;
      WHILEND;


    PROCEND process_load_files;
?? OLDTITLE ??
?? NEWTITLE := '    CHANGE_SEGMENT', EJECT ??

    PROCEDURE change_segment
      (    change_command: ^oct$segment_command_list;
       VAR segment_descriptor: ^oct$segment_descriptor;
       VAR status: ost$status);




      VAR
        found: boolean,
        last_asid: ^oct$reserved_asids;



      IF occ$attributes IN change_command^.parameters THEN
        IF change_command^.hardware_attributes.cache_bypass THEN
          segment_descriptor^.ste.vl := osc$vl_cache_bypass;
        ELSE
          segment_descriptor^.ste.vl := osc$vl_regular_segment;
        IFEND;

        segment_descriptor^.ste.xp := change_command^.hardware_attributes.execute_privilege;
        segment_descriptor^.ste.rp := change_command^.hardware_attributes.read_privilege;
        segment_descriptor^.ste.wp := change_command^.hardware_attributes.write_privilege;
        segment_descriptor^.software_attributes := change_command^.software_attributes;
      IFEND;


      IF occ$ring_brackets IN change_command^.parameters THEN
        segment_descriptor^.ste.r1 := change_command^.r1;
        segment_descriptor^.ste.r2 := change_command^.r2;
      IFEND;

      IF occ$asid IN change_command^.parameters THEN
        IF NOT ((segment_descriptor^.asid^.predefined) AND (change_command^.active_segment_id =
              segment_descriptor^.asid^.active_segment_id)) THEN
          search_reserved_asids (change_command^.active_segment_id, found, last_asid);
          IF found THEN
            STRINGREP (strng, l, change_command^.active_segment_id);
            osp$set_status_abnormal ('OC', oce$e_duplicate_asid_specified, strng (1, l), status);
            issue_diagnostic (status);
          ELSE
            IF segment_descriptor^.asid^.predefined THEN
              search_reserved_asids (segment_descriptor^.asid^.active_segment_id, found, last_asid);
            ELSE
              NEXT last_asid^.link IN ocv$rmb_scratch_seq;
              last_asid := last_asid^.link;
              IF last_asid = NIL THEN
                osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB12', status);
                RETURN;
              IFEND;

              last_asid^.link := NIL;
            IFEND;
            last_asid^.asid := change_command^.active_segment_id;
            segment_descriptor^.asid^.active_segment_id := change_command^.active_segment_id;
            segment_descriptor^.asid^.predefined := TRUE;
          IFEND;
        IFEND;
      IFEND;


      IF occ$gl_key IN change_command^.parameters THEN
        segment_descriptor^.ste.key_lock := change_command^.key_lock;
      IFEND;


    PROCEND change_segment;
?? OLDTITLE ??
?? NEWTITLE := '    SHARE_SEGMENT', EJECT ??

    PROCEDURE share_segment
      (    share_command: ^oct$segment_command_list;
           segment_descriptor: ^oct$segment_descriptor;
       VAR status: ost$status);



      VAR
        new_segment_descriptor: ^oct$segment_descriptor;



      NEXT new_segment_descriptor IN ocv$rmb_scratch_seq;
      IF new_segment_descriptor = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB13', status);
        RETURN;
      IFEND;

      new_segment_descriptor^ := segment_descriptor^;
      new_segment_descriptor^.segment_number := share_command^.new_segment_number;

      CASE share_command^.new_address_space OF

      = occ$mtr =
        add_a_segment (new_segment_descriptor, v$mtr_exchange_info.segment_descriptor_list);

      = occ$job =
        add_a_segment (new_segment_descriptor, v$job_exchange_info.segment_descriptor_list);
      CASEND;

    PROCEND share_segment;
?? OLDTITLE ??
?? NEWTITLE := '    EXTEND_SEGMENT', EJECT ??

    PROCEDURE extend_segment
      (    extend_command: ^oct$segment_command_list;
       VAR segment_descriptor: oct$segment_descriptor;
       VAR status: ost$status);



      VAR
        page_descriptor: ^^oct$page_descriptor,
        adjusted_length: ost$segment_length;




      adjusted_length := extend_command^.extend_length - (build_options.page_size -
            (segment_descriptor.segment_length^ MOD build_options.page_size));

      IF adjusted_length > 0 THEN
        page_descriptor := ^segment_descriptor.pages;

        WHILE page_descriptor^ <> NIL DO
          page_descriptor := ^page_descriptor^^.link;
        WHILEND;

        allocate_pages (v$real_memory_image.next_free_page, adjusted_length, page_descriptor^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      segment_descriptor.segment_length^ := segment_descriptor.segment_length^ +extend_command^.extend_length;


    PROCEND extend_segment;
?? OLDTITLE ??
?? NEWTITLE := '    PROCESS_SEGMENT_COMMANDS', EJECT ??

    PROCEDURE process_segment_commands
      (    segment_command_list: oct$segment_command_list;
       VAR status: ost$status);



      VAR
        segment_descriptor: ^oct$segment_descriptor,
        segment_command: ^oct$segment_command_list,
        segment_found: boolean;



      segment_command := segment_command_list.link;

      WHILE segment_command <> NIL DO
        search_for_segment (segment_command^.address_space, segment_command^.segment_number,
              segment_descriptor, segment_found);

        IF NOT segment_found THEN
          STRINGREP (strng, l, segment_command^.segment_number);
          osp$set_status_abnormal ('OC', oce$e_segment_not_found, strng (1, l), status);
          issue_diagnostic (status);
        ELSE
          CASE segment_command^.kind OF
          = occ$change =
            change_segment (segment_command, segment_descriptor, status);

          = occ$share =
            share_segment (segment_command, segment_descriptor, status);

          = occ$extend =

{ 170 comparability kludge
{ extend_segment (segment_command, segment_descriptor^, status);

          CASEND;

          IF NOT status.normal THEN
            issue_diagnostic (status);
          IFEND;
        IFEND;

        segment_command := segment_command^.link;
      WHILEND;

    PROCEND process_segment_commands;
?? OLDTITLE ??
?? NEWTITLE := '    DISPLAY_MEMORY_ADDRESS', EJECT ??

    PROCEDURE display_memory_address
      (    starting_address: ost$real_memory_address;
           length: ost$real_memory_address;
       VAR display_control: clt$display_control;
       VAR status: ost$status);



      CONST
        word_size = 19;


      VAR
        i: integer,
        memory: ^array [ * ] of ost$byte,
        display_word: ^oct$display_word,
        local_status: ost$status,

        bytes_per_line: integer,
        sum_of_line: integer,
        blank_line: boolean,
        valid_position: boolean,

        current_address: ost$real_memory_address,
        ending_address: ost$real_memory_address;


      VAR
        strng: [STATIC] string (11) := '           ';





      IF display_control.page_width < 28 THEN
        osp$set_status_abnormal ('OC', oce$e_page_width_error, '', status);
        issue_diagnostic (status);
        RETURN;
      IFEND;

      current_address := starting_address;

      IF starting_address + length > v$real_memory_image.length THEN
        IF starting_address >= v$real_memory_image.length THEN
          osp$set_status_abnormal ('OC', oce$w_invalid_display_mem_addr, '', status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        ending_address := v$real_memory_image.length - 1;
      ELSE
        ending_address := starting_address + length - 1;
      IFEND;

      pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, starting_address,
            valid_position);
      NEXT memory: [starting_address .. ending_address] IN v$real_memory_image.segment.sequence_pointer;

      blank_line := FALSE;
      bytes_per_line := ((display_control.page_width - 9) DIV word_size) * 8;

      WHILE (current_address + 7) <= ending_address DO
        IF ((display_control.column_number + word_size) > display_control.page_width) OR
              (display_control.column_number = 1) THEN
          IF (current_address + bytes_per_line) > ending_address THEN
            bytes_per_line := ending_address - current_address + 1;
          IFEND;

          sum_of_line := 0;
          FOR i := 0 TO bytes_per_line - 1 DO
            sum_of_line := sum_of_line + memory^ [current_address + i];
          FOREND;

          IF sum_of_line = 0 THEN
            IF NOT blank_line THEN
              blank_line := TRUE;
              clp$new_display_line (display_control, 1, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;

            current_address := current_address + bytes_per_line;
          ELSE
            blank_line := FALSE;

            clp$convert_integer_to_rjstring (current_address, 16, FALSE, '0', strng (3, 8), status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, strng (3, 9), clc$no_trim, amc$start, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        ELSE
          display_word := #LOC (memory^ [current_address]);

          clp$convert_integer_to_rjstring (display_word^.upper_half, 16, FALSE, '0', strng (3, 8), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, strng (1, 10), clc$no_trim, amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$convert_integer_to_rjstring (display_word^.lower_half, 16, FALSE, '0', strng (3, 8), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, strng (2, 9), clc$no_trim, amc$continue, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          current_address := current_address + 8;
        IFEND;
      WHILEND;

      IF current_address <= ending_address THEN
        bytes_per_line := ending_address - current_address;

        sum_of_line := 0;
        FOR i := 0 TO bytes_per_line DO
          sum_of_line := sum_of_line + memory^ [current_address + i];
        FOREND;

        IF sum_of_line <> 0 THEN
          IF (display_control.column_number + word_size) > display_control.page_width THEN
            clp$convert_integer_to_rjstring (current_address, 16, FALSE, '0', strng (3, 8), status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, strng (3, 9), clc$no_trim, amc$start, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

          IF (current_address + 3) <= ending_address THEN
            display_word := #LOC (memory^ [current_address]);

            clp$convert_integer_to_rjstring (display_word^.upper_half, 16, FALSE, '0', strng (3, 8), status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, strng (1, 10), clc$no_trim, amc$continue, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, ' ', clc$no_trim, amc$continue, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            current_address := current_address + 4;
          ELSE
            clp$put_partial_display (display_control, '  ', clc$no_trim, amc$continue, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

          WHILE current_address <= ending_address DO
            clp$convert_integer_to_rjstring (memory^ [current_address], 16, FALSE, '0', strng (3, 2), status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            clp$put_partial_display (display_control, strng (3, 2), clc$no_trim, amc$continue, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            current_address := current_address + 1;
          WHILEND;
        IFEND;
      IFEND;

      IF (starting_address + length) > v$real_memory_image.length THEN
        clp$put_partial_display (display_control, '          END OF REAL MEMORY IMAGE', clc$no_trim,
              amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    PROCEND display_memory_address;
?? OLDTITLE ??
?? NEWTITLE := '    PRINT_PAGE_TABLE', EJECT ??

    PROCEDURE print_page_table
      (    segment_descriptor_list: oct$segment_descriptor;
           address_space: string (3);
       VAR display_control: clt$display_control;
       VAR status: ost$status);




      VAR
        attr_column: 79 .. 111,
        segment_descriptor: ^oct$segment_descriptor;



      VAR
        underline: [STATIC] string (89) :=
              '-----------------------------------------------------------------------------------------',
        page_table_header: [STATIC] string (89) :=
              '              ID                  ASID     RMA     PAGES   R1/R2   SN  TYPE   ATTRIBUTES',
        page_table_template: [STATIC] string (111) :=
              '                                                           ( , )';



      IF display_control.page_width < 105 THEN
        osp$set_status_abnormal ('OC', oce$e_page_width_error, '', status);
        issue_diagnostic (status);
        RETURN;
      IFEND;

      segment_descriptor := segment_descriptor_list.link;

      clp$put_partial_display (display_control, page_table_header, clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, underline, clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      WHILE segment_descriptor <> NIL DO
        page_table_template (1, 31) := segment_descriptor^.segment_id;

        clp$convert_integer_to_rjstring (segment_descriptor^.asid^.active_segment_id, 16, FALSE, '0',
              page_table_template (35, 4), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF segment_descriptor^.pages <> NIL THEN
          clp$convert_integer_to_rjstring (segment_descriptor^.pages^.offset, 16, FALSE, '0',
                page_table_template (42, 8), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          page_table_template (42, 8) := '********';
        IFEND;

        clp$convert_integer_to_rjstring ((segment_descriptor^.segment_length^ +build_options.page_size -
              1) DIV build_options.page_size, 16, FALSE, '0', page_table_template (53, 4), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$convert_integer_to_rjstring (segment_descriptor^.ste.r1, 16, FALSE, '0',
              page_table_template (61, 1), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$convert_integer_to_rjstring (segment_descriptor^.ste.r2, 16, FALSE, '0',
              page_table_template (63, 1), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$convert_integer_to_rjstring (segment_descriptor^.segment_number, 16, FALSE, '0',
              page_table_template (68, 2), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        page_table_template (73, 3) := address_space;

        attr_column := 79;
        page_table_template (79, 33) := '  ';

        IF segment_descriptor^.ste.xp = osc$non_privileged THEN
          page_table_template (attr_column, 2) := 'EX';
          attr_column := attr_column + 3;
        ELSEIF segment_descriptor^.ste.xp = osc$local_privilege THEN
          page_table_template (attr_column, 2) := 'LP';
          attr_column := attr_column + 3;
        ELSEIF segment_descriptor^.ste.xp = osc$global_privilege THEN
          page_table_template (attr_column, 2) := 'GP';
          attr_column := attr_column + 3;
        IFEND;

        IF segment_descriptor^.ste.rp = osc$read_key_lock_controlled THEN
          page_table_template (attr_column, 2) := 'RK';
          attr_column := attr_column + 3;
        ELSEIF segment_descriptor^.ste.rp = osc$read_uncontrolled THEN
          page_table_template (attr_column, 2) := 'RD';
          attr_column := attr_column + 3;
        ELSEIF segment_descriptor^.ste.rp = osc$binding_segment THEN
          page_table_template (attr_column, 2) := 'BI';
        IFEND;

        IF segment_descriptor^.ste.wp = osc$write_key_lock_controlled THEN
          page_table_template (attr_column, 2) := 'WK';
          attr_column := attr_column + 3;
        ELSEIF segment_descriptor^.ste.wp = osc$write_uncontrolled THEN
          page_table_template (attr_column, 2) := 'WT';
          attr_column := attr_column + 3;
        IFEND;

        IF segment_descriptor^.ste.vl = osc$vl_cache_bypass THEN
          page_table_template (attr_column, 2) := 'CB';
          attr_column := attr_column + 3;
        IFEND;

        IF mmc$sa_wired IN segment_descriptor^.software_attributes THEN
          page_table_template (attr_column, 2) := 'WR';
          attr_column := attr_column + 3;
        IFEND;

        IF mmc$sa_fixed IN segment_descriptor^.software_attributes THEN
          page_table_template (attr_column, 2) := 'FX';
          attr_column := attr_column + 3;
        IFEND;

        IF mmc$sa_stack IN segment_descriptor^.software_attributes THEN
          page_table_template (attr_column, 2) := 'ST';
          attr_column := attr_column + 3;
        IFEND;

        IF mmc$sa_read_transfer_unit IN segment_descriptor^.software_attributes THEN
          page_table_template (attr_column, 2) := 'RT';
          attr_column := attr_column + 3;
        IFEND;

        IF mmc$sa_free_behind IN segment_descriptor^.software_attributes THEN
          page_table_template (attr_column, 2) := 'FB';
          attr_column := attr_column + 3;
        IFEND;

        IF mmc$sa_no_append IN segment_descriptor^.software_attributes THEN
          page_table_template (attr_column, 2) := 'NA';
        IFEND;

        clp$put_partial_display (display_control, page_table_template, clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        segment_descriptor := segment_descriptor^.link;
      WHILEND;

    PROCEND print_page_table;
?? OLDTITLE ??
?? NEWTITLE := '    PRINT_MEMORY_MAP', EJECT ??

    PROCEDURE print_memory_map
      (    segment_descriptor_list: oct$segment_descriptor;
           address_space: string (3);
       VAR display_control: clt$display_control;
       VAR status: ost$status);




      VAR
        pages: ^oct$page_descriptor,
        offset: ost$segment_offset,
        segment_descriptor: ^oct$segment_descriptor,
        page_address: ost$real_memory_address,
        segment_info: [STATIC] string (52) := '    segment 000 from',
        address_template: [STATIC] string (65) :=
              '  0 000 00000000  ...  0 000 00000000     00000000  ...  00000000';



      IF display_control.page_width < 65 THEN
        osp$set_status_abnormal ('OC', oce$e_page_width_error, '', status);
        issue_diagnostic (status);
        RETURN;
      IFEND;

      segment_descriptor := segment_descriptor_list.link;

      WHILE segment_descriptor <> NIL DO
        segment_info (1, 3) := address_space;

        clp$convert_integer_to_rjstring (segment_descriptor^.segment_number, 16, FALSE, '0',
              segment_info (13, 3), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_partial_display (display_control, segment_info, clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$convert_integer_to_rjstring (segment_descriptor^.ste.r1, 16, FALSE, '0', address_template (3, 1),
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        address_template (24, 1) := address_template (3, 1);
        address_template (5, 3) := segment_info (13, 3);
        address_template (26, 3) := address_template (5, 3);

        pages := segment_descriptor^.pages;
        offset := 0;

        WHILE pages <> NIL DO
          clp$convert_integer_to_rjstring (offset, 16, FALSE, '0', address_template (9, 8), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$convert_integer_to_rjstring (pages^.offset, 16, FALSE, '0', address_template (43, 8), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          page_address := pages^.offset;

          WHILE (pages <> NIL) AND (pages^.offset = page_address) DO
            page_address := page_address + build_options.page_size;
            offset := offset + build_options.page_size;
            pages := pages^.link;
          WHILEND;

          IF pages = NIL THEN
            offset := offset - build_options.page_size + (segment_descriptor^.segment_length^ MOD
                  build_options.page_size);
            page_address := page_address - build_options.page_size +
                  (segment_descriptor^.segment_length^ MOD build_options.page_size);
          IFEND;

          clp$convert_integer_to_rjstring (offset - 1, 16, FALSE, '0', address_template (30, 8), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$convert_integer_to_rjstring (page_address - 1, 16, FALSE, '0', address_template (58, 8),
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$put_partial_display (display_control, address_template, clc$no_trim, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        WHILEND;

        segment_descriptor := segment_descriptor^.link;
      WHILEND;

    PROCEND print_memory_map;
?? OLDTITLE ??
?? NEWTITLE := '    PRINT_RMB_SUMMARY', EJECT ??

    PROCEDURE print_rmb_summary
      (VAR display_control: clt$display_control;
       VAR status: ost$status);



      VAR
        highest_load_address: [STATIC] string (32) := ' HIGHEST LOAD ADDRESS =         ',
        pt_continue_bits: [STATIC] string (32) := ' PAGE TABLE CONTINUE BITS =     ';



      clp$convert_integer_to_rjstring (v$real_memory_image.length - 1, 16, FALSE, '0',
            highest_load_address (25, 8), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, highest_load_address, clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_rjstring (v$real_memory_image.pt_continue_bits, 10, FALSE, '0',
            pt_continue_bits (29, 4), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, pt_continue_bits, clc$no_trim, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


    PROCEND print_rmb_summary;
?? OLDTITLE ??
?? NEWTITLE := '    PROCESS_MEMORY_COMMANDS', EJECT ??

    PROCEDURE process_memory_commands
      (    memory_command_list: oct$memory_command_list;
       VAR status: ost$status);




      VAR
        of_execution: boolean,
        local_status: ost$status,
        default_rings: amt$ring_attributes,
        display_control: clt$display_control,
        display_control_ptr: ^clt$display_control,
        memory_command: ^oct$memory_command_list;



      VAR
        position_attribute: array [1 .. 1] of amt$file_item,
        memory_dump_header: [STATIC] string (22) := 'DISPLAY MEMORY ADDRESS',
        mtr_xp_header: [STATIC] string (24) := 'MONITOR EXCHANGE PACKAGE',
        job_xp_header: [STATIC] string (20) := 'JOB EXCHANGE PACKAGE',
        underline: [STATIC] string (24) := '------------------------';




      memory_command := memory_command_list.link;

      WHILE memory_command <> NIL DO
        IF (memory_command^.file_name_specified) AND (memory_command^.output.local_file_name <>
              build_options.memory_map.local_file_name) THEN

          default_rings.r1 := #RING (^of_execution);
          default_rings.r2 := #RING (^of_execution);
          default_rings.r3 := #RING (^of_execution);

          clp$open_display_file (memory_command^.output, ^new_page_procedure, fsc$list, default_rings,
                display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          display_control_ptr := ^display_control;
        ELSE
          display_control_ptr := ^v$display_control;
          clp$new_display_line (v$display_control, 2, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      /command_loop/
        BEGIN
          CASE memory_command^.kind OF

          = occ$display_memory =

            CASE memory_command^.memory OF
            = occ$all =
              display_memory_address (build_options.load_offset, v$real_memory_image.length,
                    display_control_ptr^, status);

            = occ$page_table =
              IF v$mtr_exchange_info.segment_descriptor_list.link <> NIL THEN
                print_page_table (v$mtr_exchange_info.segment_descriptor_list, 'MTR', display_control_ptr^,
                      status);
                IF NOT status.normal THEN
                  EXIT /command_loop/;
                IFEND;

                clp$new_display_line (display_control_ptr^, 2, status);
                IF NOT status.normal THEN
                  EXIT /command_loop/;
                IFEND;
              IFEND;

              IF v$job_exchange_info.segment_descriptor_list.link <> NIL THEN
                print_page_table (v$job_exchange_info.segment_descriptor_list, 'JOB', display_control_ptr^,
                      status);
                IF NOT status.normal THEN
                  EXIT /command_loop/;
                IFEND;

                clp$new_display_line (display_control_ptr^, 2, status);
                IF NOT status.normal THEN
                  EXIT /command_loop/;
                IFEND;
              IFEND;

              print_rmb_summary (display_control_ptr^, status);

            = occ$memory_map =
              print_memory_map (v$mtr_exchange_info.segment_descriptor_list, 'MTR', display_control_ptr^,
                    status);
              IF NOT status.normal THEN
                EXIT /command_loop/;
              IFEND;

              print_memory_map (v$job_exchange_info.segment_descriptor_list, 'JOB', display_control_ptr^,
                    status);

            = occ$mps =
              clp$put_partial_display (display_control_ptr^, mtr_xp_header, clc$no_trim, amc$start, status);
              IF NOT status.normal THEN
                EXIT /command_loop/;
              IFEND;

              clp$put_display (display_control_ptr^, underline, clc$no_trim, status);
              IF NOT status.normal THEN
                EXIT /command_loop/;
              IFEND;

              IF v$mtr_exchange_info.exchange_address.address_space <> occ$null THEN
                display_memory_address (v$mtr_exchange_info.rma, #SIZE (ost$exchange_package),
                      display_control_ptr^, status);
              ELSE
                osp$set_status_abnormal ('OC', oce$w_no_exchange_package, 'MTR EXCHANGE PACKAGE', status);
                issue_diagnostic (status);
              IFEND;

            = occ$jps =
              clp$put_partial_display (display_control_ptr^, job_xp_header, clc$no_trim, amc$start, status);
              IF NOT status.normal THEN
                EXIT /command_loop/;
              IFEND;

              clp$put_display (display_control_ptr^, underline (1, 20), clc$no_trim, status);
              IF NOT status.normal THEN
                EXIT /command_loop/;
              IFEND;

              IF v$job_exchange_info.exchange_address.address_space <> occ$null THEN
                display_memory_address (v$job_exchange_info.rma, #SIZE (ost$exchange_package),
                      display_control_ptr^, status);
              ELSE
                osp$set_status_abnormal ('OC', oce$w_no_exchange_package, 'JOB EXCHANGE PACKAGE', status);
                issue_diagnostic (status);
              IFEND;
            CASEND;

          = occ$display_memory_address =
            clp$put_partial_display (display_control_ptr^, memory_dump_header, clc$no_trim, amc$start,
                  status);
            IF NOT status.normal THEN
              EXIT /command_loop/;
            IFEND;

            clp$put_display (display_control_ptr^, underline (1, 22), clc$no_trim, status);
            IF NOT status.normal THEN
              EXIT /command_loop/;
            IFEND;

            display_memory_address (memory_command^.display_address, memory_command^.length,
                  display_control_ptr^, status);
          CASEND;
        END /command_loop/;

        IF NOT status.normal THEN
          IF (memory_command^.file_name_specified) AND (memory_command^.output.local_file_name <>
                build_options.memory_map.local_file_name) THEN
            clp$close_display (display_control_ptr^, local_status);
            IF NOT local_status.normal THEN
              issue_diagnostic (local_status);
            IFEND;
          IFEND;
          RETURN;
        IFEND;

        IF (memory_command^.file_name_specified) AND (memory_command^.output.local_file_name <>
              build_options.memory_map.local_file_name) THEN
          clp$put_display (display_control_ptr^, '  ', clc$no_trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$close_display (display_control_ptr^, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        memory_command := memory_command^.link;
      WHILEND;

    PROCEND process_memory_commands;
?? OLDTITLE ??
?? NEWTITLE := '    GET_ASID', EJECT ??

    PROCEDURE get_asid
      (VAR asid: ost$asid);



      VAR
        i,
        f: integer,

        found: boolean,
        last_asid: ^oct$reserved_asids;



      found := TRUE;

      REPEAT
        i := v$asid_seed;
        v$asid_seed := v$asid_seed + 1;

        f := build_options.page_table_length DIV 32;
        asid := 0;

        WHILE i <> 0 DO
          IF (i MOD 2) <> 0 THEN
            asid := asid + f;
          IFEND;

          i := i DIV 2;
          f := f DIV 2;
        WHILEND;

        IF (asid <> nos_asid) AND (asid <> ssr_asid) THEN
          search_reserved_asids (asid, found, last_asid);
        IFEND;
      UNTIL NOT found;


    PROCEND get_asid;
?? OLDTITLE ??
?? NEWTITLE := '    PAD_PAGE_TABLE', EJECT ??

    PROCEDURE pad_page_table
      (    pad_size: integer;
           pad_asid: ost$asid;
       VAR status: ost$status);



      VAR
        next_free_page: ost$real_memory_address,
        page_table_overflow: boolean,
        pages: ^oct$page_descriptor,
        pte: ost$page_table_entry;



      IF pad_size <> 0 THEN
        next_free_page := v$real_memory_image.next_free_page;
        allocate_pages (0, pad_size, pages, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        pte.pageid.asid := pad_asid;
        pte.v := TRUE;
        pte.c := FALSE;
        pte.u := FALSE;
        pte.m := TRUE;

        build_next_page_table_entry (0, pages, pte, page_table_overflow);
        IF page_table_overflow THEN
          osp$set_status_abnormal ('OC', oce$e_page_table_overflow, '', status);
          issue_diagnostic (status);
        IFEND;

        WHILE pages <> NIL DO
          v$real_memory_image.page^ [pages^.offset DIV build_options.page_size].reserved := FALSE;
          pages := pages^.link;
        WHILEND;

        v$real_memory_image.next_free_page := next_free_page;
      IFEND;

    PROCEND pad_page_table;
?? OLDTITLE ??
?? NEWTITLE := '    REMOVE_PAGE_TABLE_PADS', EJECT ??

    PROCEDURE remove_page_table_pads;


      VAR
        i: integer,
        asid: ost$asid,
        fb_hash: -osc$max_page_table_entries .. osc$max_page_table_entries,
        current_index: -1 .. osc$max_page_table_entries,
        page_table_length: 512 .. osc$max_page_table_entries;


      page_table_length := build_options.page_table_length DIV 8;

      FOR i := 0 TO page_table_length - 1 DO
        asid := v$real_memory_image.page_table^ [i].pageid.asid;

        IF v$real_memory_image.page_table^ [i].v THEN
          IF (asid = nos_asid) OR (asid = ssr_asid) THEN
            generate_page_table_index (asid, v$real_memory_image.page_table^ [i].pageid.pagenum, fb_hash);

            v$real_memory_image.page_table^ [i].v := FALSE;
            v$real_memory_image.page_table^ [i].m := FALSE;
            v$real_memory_image.page_table^ [i].pageid.asid := 0;
            v$real_memory_image.page_table^ [i].pageid.pagenum := 0;
            v$real_memory_image.page_table^ [i].rma := 0;

            current_index := i;

            WHILE fb_hash <> current_index DO
              current_index := current_index - 1;
              IF current_index < 0 THEN
                current_index := page_table_length - 1;
              IFEND;

              v$real_memory_image.page^ [current_index].continue_bits := v$real_memory_image.
                    page^ [current_index].continue_bits - 1;
              IF v$real_memory_image.page^ [current_index].continue_bits = 0 THEN
                v$real_memory_image.page_table^ [current_index].c := FALSE;
                v$real_memory_image.pt_continue_bits := v$real_memory_image.pt_continue_bits - 1;
              IFEND;
            WHILEND;
          IFEND;
        IFEND;
      FOREND;


    PROCEND remove_page_table_pads;
?? OLDTITLE ??
?? NEWTITLE := '    INSERT_NEXT_PAGE_TABLE_ENTRY', EJECT ??

    PROCEDURE insert_next_page_table_entry
      (    cbits: integer;
           pti: -osc$max_page_table_entries .. osc$max_page_table_entries;
           pagenum: ost$page_table_index;
           page_descriptor: ^oct$page_descriptor;
       VAR pte: ost$page_table_entry;
       VAR page_table_overflow: boolean);



      VAR
        old_pte: ost$page_table_entry;




      IF cbits = 32 THEN
        page_table_overflow := TRUE;
      ELSE
        old_pte := v$real_memory_image.page_table^ [pti];

        IF old_pte.v = TRUE THEN
          IF old_pte.c = FALSE THEN
            v$real_memory_image.page_table^ [pti].c := TRUE;
            v$real_memory_image.pt_continue_bits := v$real_memory_image.pt_continue_bits + 1;
          IFEND;

          v$real_memory_image.page^ [pti].continue_bits := v$real_memory_image.page^ [pti].continue_bits + 1;

          insert_next_page_table_entry ((cbits + 1), (pti + 1) MOD (build_options.page_table_length DIV 8),
                pagenum, page_descriptor, pte, page_table_overflow);

          IF page_table_overflow THEN
            v$real_memory_image.page_table^ [pti] := old_pte;
            IF old_pte.c = FALSE THEN
              v$real_memory_image.pt_continue_bits := v$real_memory_image.pt_continue_bits - 1;
            IFEND;
            v$real_memory_image.page^ [pti].continue_bits := v$real_memory_image.page^ [pti].continue_bits -
                  1;
          IFEND;
        ELSE
          v$real_memory_image.page_table^ [pti] := pte;
          build_next_page_table_entry (pagenum + 1, page_descriptor^.link, pte, page_table_overflow);

          IF page_table_overflow THEN
            v$real_memory_image.page_table^ [pti] := old_pte;
          IFEND;
        IFEND;
      IFEND;

    PROCEND insert_next_page_table_entry;
?? OLDTITLE ??
?? NEWTITLE := '    BUILD_NEXT_PAGE_TABLE_ENTRY', EJECT ??

    PROCEDURE build_next_page_table_entry
      (    pagenum: ost$page_table_index;
           page_descriptor: ^oct$page_descriptor;
       VAR pte: ost$page_table_entry;
       VAR page_table_overflow: boolean);



      VAR
        pti: -osc$max_page_table_entries .. osc$max_page_table_entries;



      IF page_descriptor = NIL THEN
        page_table_overflow := FALSE;
      ELSE
        pte.rma := page_descriptor^.offset DIV 512;
        pte.pageid.pagenum := (pagenum * build_options.page_size) DIV 512;

        generate_page_table_index (pte.pageid.asid, pte.pageid.pagenum, pti);

        insert_next_page_table_entry (0, pti, pagenum, page_descriptor, pte, page_table_overflow);
      IFEND;

    PROCEND build_next_page_table_entry;
?? OLDTITLE ??
?? NEWTITLE := '    BUILD_PAGE_TABLE', EJECT ??

    PROCEDURE build_page_table
      (    segment_descriptor_list: oct$segment_descriptor);




      VAR
        pte: ost$page_table_entry,

        segment_descriptor: ^oct$segment_descriptor,
        asid: ost$asid,

        page_table_overflow: boolean,
        retry_count: 0 .. occ$max_retries;


      segment_descriptor := segment_descriptor_list.link;

      WHILE segment_descriptor <> NIL DO
        IF segment_descriptor^.asid^.assigned THEN
          segment_descriptor := segment_descriptor^.link;
        ELSE
          retry_count := 0;

        /build_pt_entry/
          WHILE retry_count < occ$max_retries DO
            IF segment_descriptor^.asid^.predefined THEN
              asid := segment_descriptor^.asid^.active_segment_id;
            ELSE
              get_asid (asid);
            IFEND;

            pte.pageid.asid := asid;
            pte.v := TRUE;
            pte.c := FALSE;
            pte.u := FALSE;
            pte.m := TRUE;

            build_next_page_table_entry (0, segment_descriptor^.pages, pte, page_table_overflow);

            IF page_table_overflow THEN
              IF segment_descriptor^.asid^.predefined THEN
                osp$set_status_abnormal ('OC', oce$e_asid_wont_hash_in_pt, strng (1, l), status);
                issue_diagnostic (status);
                EXIT /build_pt_entry/;
              ELSE
                retry_count := retry_count + 1;
              IFEND;
            ELSE
              segment_descriptor^.asid^.assigned := TRUE;
              segment_descriptor^.asid^.active_segment_id := asid;
              EXIT /build_pt_entry/;
            IFEND;
          WHILEND /build_pt_entry/;

          IF retry_count = occ$max_retries THEN
            osp$set_status_abnormal ('OC', oce$e_page_table_retry_failed, '', status);
            issue_diagnostic (status);
          IFEND;

          segment_descriptor := segment_descriptor^.link;
        IFEND;
      WHILEND;

    PROCEND build_page_table;
?? OLDTITLE ??
?? NEWTITLE := '    INITIALIZE_EXCHANGE_PACKAGE', EJECT ??

    PROCEDURE initialize_exchange_package
      (    exchange_info: oct$exchange_package_info;
       VAR status: ost$status);



      TYPE
        oct$dummy_exchange_package = packed record
          filler1: 0 .. 0ffff(16),
          p: ost$pva,
          filler2: 0 .. 0ffff(16),
          a0: ost$pva,
          filler3: 0 .. 0ffff(16),
          a1: ost$pva,
          filler4: 0 .. 0ffff(16),
          a2: ost$pva,
          filler5: 0 .. 0ffff(16),
          a3: ost$pva,
        recend;



      VAR
        ring_number: ost$valid_ring,
        segment_table: oct$half_word,
        segment_table_relative_address: ost$real_memory_address,

        segment_descriptor: ^oct$segment_descriptor,
        stack_segment_descriptor: ^oct$segment_descriptor,

        segment_table_entries: ^array [ * ] of record
          ste: ost$segment_descriptor,
          fill: 0 .. 0ffffff(16),
        recend,
        xcb: ^ost$execution_control_block,

        dummy_exchange_package: ^oct$dummy_exchange_package,
        valid_position: boolean,
        tos_pointer: ^cell,
        segment_found: boolean;



      IF exchange_info.exchange_address.address_space <> occ$null THEN
        search_for_segment (exchange_info.exchange_address.address_space,
              exchange_info.exchange_address.segment, segment_descriptor, segment_found);
        IF NOT segment_found THEN
          STRINGREP (strng, l, exchange_info.exchange_address.segment);
          osp$set_status_abnormal ('OC', oce$e_exch_segment_not_found, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        IF (exchange_info.exchange_address.segment_offset + #SIZE (ost$exchange_package)) >
              segment_descriptor^.segment_length^ THEN
          osp$set_status_abnormal ('OC', oce$e_real_memory_seg_overflow, 'EXCHANGE PACKAGE', status);
          osp$append_status_integer (osc$status_parameter_delimiter, exchange_info.exchange_address.segment,
                16, FALSE, status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, exchange_info.rma,
              valid_position);

        NEXT xcb IN v$real_memory_image.segment.sequence_pointer;

        IF exchange_info.exchange_address.address_space = occ$mtr THEN
          xcb^.xp.x_registers [0] := v$pp_address_array_rma DIV 8;
        IFEND;

        segment_table.address_1 := xcb^.xp.segment_table_address_1;
        segment_table.address_2 := xcb^.xp.segment_table_address_2;

        segment_table_relative_address := segment_table.rma;
        segment_table.rma := segment_table.rma + segment_descriptor^.pages^.offset;
        xcb^.xp.segment_table_address_1 := segment_table.address_1;
        xcb^.xp.segment_table_address_2 := segment_table.address_2;

        IF exchange_info.p_address.ring <> 0 THEN
          dummy_exchange_package := #LOC (xcb^);
          dummy_exchange_package^.p := exchange_info.p_address;
          dummy_exchange_package^.a0.ring := xcb^.xp.p_register.pva.ring;
          dummy_exchange_package^.a1.ring := xcb^.xp.p_register.pva.ring;
          dummy_exchange_package^.a3 := exchange_info.binding_address;
        IFEND;

        FOR ring_number := osc$min_ring TO osc$max_ring DO
          tos_pointer := #ADDRESS (xcb^.xp.tos_registers [ring_number].
                pva.ring, xcb^.xp.tos_registers [ring_number].pva.seg, xcb^.xp.tos_registers [ring_number].
                pva.offset);
          IF tos_pointer <> NIL THEN
            xcb^.xp.tos_registers [ring_number].pva.ring := ring_number;

            search_for_segment (exchange_info.address_space, xcb^.xp.tos_registers [ring_number].pva.seg,
                  stack_segment_descriptor, segment_found);
            IF segment_found THEN
              stack_segment_descriptor^.ste.r1 := ring_number;
              stack_segment_descriptor^.ste.r2 := ring_number;
            IFEND;
          IFEND;
        FOREND;

        IF xcb^.xp.segment_table_length <= 0 THEN
          STRINGREP (strng, l, segment_descriptor^.segment_number);
          osp$set_status_abnormal ('OC', oce$e_invalid_xp_seg_table_leng, strng (1, l), status);
          issue_diagnostic (status);
        ELSE
          IF (segment_table_relative_address + (xcb^.xp.segment_table_length * 8)) >
                segment_descriptor^.segment_length^ THEN
            osp$set_status_abnormal ('OC', oce$e_real_memory_seg_overflow, 'SEGMENT TABLE', status);
            osp$append_status_integer (osc$status_parameter_delimiter, segment_descriptor^.segment_number, 16,
                  FALSE, status);
            issue_diagnostic (status);
            RETURN;
          IFEND;

          pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, segment_table.rma,
                valid_position);
          NEXT segment_table_entries: [0 .. xcb^.xp.segment_table_length - 1] IN
                v$real_memory_image.segment.sequence_pointer;


          segment_descriptor := exchange_info.segment_descriptor_list.link;
          WHILE segment_descriptor <> NIL DO
            IF segment_descriptor^.segment_number > xcb^.xp.segment_table_length - 1 THEN
              STRINGREP (strng, l, segment_descriptor^.segment_number);
              osp$set_status_abnormal ('OC', oce$e_segment_number_to_large, strng (1, l), status);
              RETURN;
            IFEND;

            segment_descriptor^.ste.asid := segment_descriptor^.asid^.active_segment_id;

            segment_table_entries^ [segment_descriptor^.segment_number].ste := segment_descriptor^.ste;

{           xcb^.sdtx_p^.sdtx_table [segment_descriptor^.segment_number].software_attribute_set :=
{                 segment_descriptor^.software_attributes;

            segment_descriptor := segment_descriptor^.link;
          WHILEND;
        IFEND;
      IFEND;

    PROCEND initialize_exchange_package;
?? OLDTITLE ??
?? NEWTITLE := '    INITIALIZE_HCS_ROOT', EJECT ??

    PROCEDURE initialize_hcs_root
      (    pages_loaded_name: oct$exchange_name;
           page_size_name: oct$exchange_name;
           bytes_loaded_address: oct$exchange_name;
       VAR status: ost$status);


      VAR
        address: oct$exchange_address,
        segment_descriptor: ^oct$segment_descriptor,
        found: boolean,
        valid_position: boolean,
        rma: ost$real_memory_address,
        value: ^integer,
        half_word: ^0 .. 0ffffffff(16);


      change_exchange_name_to_addr (pages_loaded_name, address);
      v$pages_loaded_pva := address;

      IF address.address_space <> occ$null THEN
        search_for_segment (address.address_space, address.segment, segment_descriptor, found);
        IF NOT found THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_exch_segment_not_found, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        search_for_offset (address.segment_offset, segment_descriptor^.pages, rma, found);
        IF NOT found THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_real_memory_seg_overflow, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, rma, valid_position);
        NEXT value IN v$real_memory_image.segment.sequence_pointer;
        value^ := (v$real_memory_image.length - build_options.load_offset) DIV build_options.page_size;
      IFEND;

      change_exchange_name_to_addr (page_size_name, address);
      v$page_size_pva := address;

      IF address.address_space <> occ$null THEN
        search_for_segment (address.address_space, address.segment, segment_descriptor, found);
        IF NOT found THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_exch_segment_not_found, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        search_for_offset (address.segment_offset, segment_descriptor^.pages, rma, found);
        IF NOT found THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_real_memory_seg_overflow, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, rma, valid_position);
        NEXT value IN v$real_memory_image.segment.sequence_pointer;
        value^ := build_options.page_size;
      IFEND;

      change_exchange_name_to_addr (bytes_loaded_address, address);

      IF address.address_space <> occ$null THEN
        search_for_segment (address.address_space, address.segment, segment_descriptor, found);
        IF NOT found THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_exch_segment_not_found, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        search_for_offset (address.segment_offset, segment_descriptor^.pages, rma, found);
        IF NOT found THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_real_memory_seg_overflow, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, rma, valid_position);
        NEXT half_word IN v$real_memory_image.segment.sequence_pointer;
        half_word^ := (v$real_memory_image.length - build_options.load_offset);
      IFEND;


      IF NOT build_options.building_ei THEN

{ Remove kludge done in allocate_page_table to protect location of PP_ADDRESS_ARRAY pointer.

        v$real_memory_image.page_table^ [1].v := FALSE;
        v$real_memory_image.page_table^ [1].m := FALSE;
      IFEND;


    PROCEND initialize_hcs_root;
?? OLDTITLE ??
?? NEWTITLE := '    RELOCATE_PP_ADDRESS_ARRAY', EJECT ??

    PROCEDURE relocate_pp_address_array
      (    name: oct$exchange_name;
       VAR status: ost$status);


      VAR
        first_words_in_page_table: ^array [1 .. 4] of ost$halfword,
        address: oct$exchange_address,
        segment_descriptor: ^oct$segment_descriptor,
        found: boolean,
        valid_position: boolean,
        spaa: ^array [1 .. 40] of ost$spaa_entry,
        i: integer,
        base_in_words: ost$real_memory_address;


      change_exchange_name_to_addr (name, address);
      v$pp_address_array_pva := address;

      IF address.address_space <> occ$null THEN
        search_for_segment (address.address_space, address.segment, segment_descriptor, found);
        IF NOT found THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_exch_segment_not_found, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;


        search_for_offset (address.segment_offset, segment_descriptor^.pages, v$pp_address_array_rma, found);
        IF NOT found THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_real_memory_seg_overflow, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;


        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer, v$pp_address_array_rma,
              valid_position);
        NEXT spaa IN v$real_memory_image.segment.sequence_pointer;
        IF spaa = NIL THEN
          STRINGREP (strng, l, address.segment);
          osp$set_status_abnormal ('OC', oce$e_real_memory_seg_overflow, strng (1, l), status);
          issue_diagnostic (status);
          RETURN;
        IFEND;

        base_in_words := segment_descriptor^.pages^.offset DIV 8;

      /loop/
        FOR i := 1 TO UPPERBOUND (spaa^) DO
          IF spaa^ [i].address_type = 0 THEN
            EXIT /loop/;
          ELSEIF spaa^ [i].word_rma <> 0 THEN
            spaa^ [i].word_rma := spaa^ [i].word_rma + base_in_words;
          IFEND;
        FOREND /loop/;


        pmp$position_object_library (v$real_memory_image.segment.sequence_pointer,
              build_options.page_table_address, valid_position);
        NEXT first_words_in_page_table IN v$real_memory_image.segment.sequence_pointer;
        first_words_in_page_table^ [4] := v$pp_address_array_rma DIV 8;
      IFEND;


    PROCEND relocate_pp_address_array;
?? OLDTITLE ??
?? NEWTITLE := '    BUILD_REAL_MEMORY_IMAGE', EJECT ??

    PROCEDURE build_real_memory_image
      (    load_offset: ost$segment_length;
       VAR status: ost$status);


      VAR
        length: ost$segment_length,
        filler: ^SEQ ( * ),
        old: ^SEQ ( * ),
        temp: ^SEQ ( * ),
        new: ^SEQ ( * ),
        header: ^pmt$memory_image_header;


      length := v$real_memory_image.length - load_offset;

      RESET v$real_memory_image.segment.sequence_pointer;

      IF load_offset > 0 THEN
        NEXT filler: [[REP load_offset OF cell]] IN v$real_memory_image.segment.sequence_pointer;
      IFEND;


      PUSH temp: [[REP length OF cell]];
      IF temp = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RMB99', status);
        RETURN;
      IFEND;

      NEXT old: [[REP length OF cell]] IN v$real_memory_image.segment.sequence_pointer;
      syp$advised_move_bytes (#LOC (old^), #LOC (temp^), length, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


      RESET v$real_memory_image.segment.sequence_pointer;
      NEXT header IN v$real_memory_image.segment.sequence_pointer;
      IF header = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_real_memory_overflow, '', status);
        RETURN;
      IFEND;

      header^.version := pmc$real_memory_image_version;
      header^.length := length;
      header^.offset := load_offset;


      IF NOT build_options.building_ei THEN
        IF v$job_exchange_info.exchange_address.address_space <> occ$null THEN
          header^.processor_registers.jps := v$job_exchange_info.rma;
        ELSE
          header^.processor_registers.jps := 0;
        IFEND;
        IF v$mtr_exchange_info.exchange_address.address_space <> occ$null THEN
          header^.processor_registers.mps := v$mtr_exchange_info.rma;
        ELSE
          header^.processor_registers.mps := 0;
        IFEND;
        header^.processor_registers.pta := build_options.page_table_address;
        header^.processor_registers.ptl := (build_options.page_table_length DIV 4096) - 1;
        header^.processor_registers.psm := 128 - (build_options.page_size DIV 512);
        header^.processor_registers.eid := 0;
        header^.processor_registers.sit := 70000000(16);
        header^.processor_registers.pid := 0;
        header^.processor_registers.ptm := 0;
        header^.processor_registers.pfs := 0;
        header^.processor_registers.dec := 0;
        header^.processor_registers.vmcl := 8000(16);
        header^.processor_registers.ss := 20(16);
        header^.processor_registers.oi := 0;

        IF v$pp_address_array_pva.address_space <> occ$null THEN
          header^.initialization_values.pp_address_array_segment := v$pp_address_array_pva.segment;
          header^.initialization_values.pp_address_array_offset := v$pp_address_array_pva.segment_offset;
        ELSE
          header^.initialization_values.pages_loaded_segment := 0;
          header^.initialization_values.pages_loaded_offset := 0;
        IFEND;
        IF v$pages_loaded_pva.address_space <> occ$null THEN
          header^.initialization_values.pages_loaded_segment := v$pages_loaded_pva.segment;
          header^.initialization_values.pages_loaded_offset := v$pages_loaded_pva.segment_offset;
        ELSE
          header^.initialization_values.pages_loaded_segment := 0;
          header^.initialization_values.pages_loaded_offset := 0;
        IFEND;
        IF v$page_size_pva.address_space <> occ$null THEN
          header^.initialization_values.page_size_segment := v$page_size_pva.segment;
          header^.initialization_values.page_size_offset := v$page_size_pva.segment_offset;
        ELSE
          header^.initialization_values.page_size_segment := 0;
          header^.initialization_values.page_size_offset := 0;
        IFEND;
      IFEND;

      NEXT new: [[REP length OF cell]] IN v$real_memory_image.segment.sequence_pointer;
      IF new = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_real_memory_overflow, '', status);
        RETURN;
      IFEND;

      syp$advised_move_bytes (#LOC (temp^), #LOC (new^), length, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


      amp$set_segment_eoi (v$real_memory_image.id, v$real_memory_image.segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$close (v$real_memory_image.id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


    PROCEND build_real_memory_image;
?? OLDTITLE ??
?? EJECT ??

    VAR
      page_number: 0 .. osc$max_page_table_entries,
      local_status: ost$status;


    VAR
      diagnostic_summary: [STATIC] string (49) := '     NON FATAL ERRORS ENCOUNTERED DURING GENERATE';






    setup_rmb_parameters (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    verify_build_options (build_options, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT build_options.building_ei THEN
      allocate_page_table (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pad_page_table (build_options.c170_memory_size, nos_asid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pad_page_table (build_options.ssr_size, ssr_asid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  /build_process/
    BEGIN
      process_define_segments (build_options.define_commands, status);
      IF NOT status.normal THEN
        EXIT /build_process/;
      IFEND;

      build_symbol_table (build_options.monitor_symbol_tables, v$mtr_exchange_info, status);
      IF NOT status.normal THEN
        EXIT /build_process/;
      IFEND;

      build_symbol_table (build_options.job_symbol_tables, v$job_exchange_info, status);
      IF NOT status.normal THEN
        EXIT /build_process/;
      IFEND;

      change_exchange_name_to_addr (build_options.job_exchange_address, v$job_exchange_info.exchange_address);
      change_exchange_name_to_addr (build_options.monitor_exchange_address,
            v$mtr_exchange_info.exchange_address);

      process_load_files (build_options.load_files, status);
      IF NOT status.normal THEN
        EXIT /build_process/;
      IFEND;

      process_segment_commands (build_options.segment_commands, status);
      IF NOT status.normal THEN
        EXIT /build_process/;
      IFEND;

{ Calculate Real Memory Image length.

      page_number := build_options.page_table_length DIV 8;

      REPEAT
        page_number := page_number - 1;
      UNTIL v$real_memory_image.page^ [page_number].reserved;

      v$real_memory_image.length := (page_number * build_options.page_size) + build_options.page_size;

      IF NOT build_options.building_ei THEN
        build_page_table (v$job_exchange_info.segment_descriptor_list);
        build_page_table (v$mtr_exchange_info.segment_descriptor_list);

        remove_page_table_pads;
      IFEND;

      IF build_options.pp_address_array_address.address_space <> occ$null THEN
        relocate_pp_address_array (build_options.pp_address_array_address, status);
        IF NOT status.normal THEN
          EXIT /build_process/;
        IFEND;
      IFEND;

      IF build_options.job_exchange_address.address_space <> occ$null THEN
        initialize_exchange_package (v$job_exchange_info, status);
        IF NOT status.normal THEN
          EXIT /build_process/;
        IFEND;
      IFEND;

      IF build_options.monitor_exchange_address.address_space <> occ$null THEN
        initialize_exchange_package (v$mtr_exchange_info, status);
        IF NOT status.normal THEN
          EXIT /build_process/;
        IFEND;
      IFEND;

      initialize_hcs_root (build_options.pages_loaded_address, build_options.page_size_address,
            build_options.bytes_loaded_address, status);
      IF NOT status.normal THEN
        EXIT /build_process/;
      IFEND;

      process_memory_commands (build_options.memory_commands, status);
      IF NOT status.normal THEN
        EXIT /build_process/;
      IFEND;

      build_real_memory_image (build_options.load_offset, status);
      IF NOT status.normal THEN
        EXIT /build_process/;
      IFEND;

    END /build_process/;

    IF v$diagnostic_count <> 0 THEN
      clp$new_display_line (v$display_control, 2, local_status);
      IF NOT local_status.normal THEN
        issue_diagnostic (local_status);
      IFEND;

      clp$convert_integer_to_rjstring (v$diagnostic_count, 10, FALSE, ' ', diagnostic_summary (1, 4),
            local_status);
      IF NOT local_status.normal THEN
        issue_diagnostic (local_status);
      IFEND;

      clp$put_partial_display (v$display_control, diagnostic_summary, clc$no_trim, amc$start, local_status);
      IF NOT local_status.normal THEN
        issue_diagnostic (local_status);
      IFEND;
    IFEND;


    clp$put_display (v$display_control, '  ', clc$no_trim, local_status);
    IF NOT local_status.normal THEN
      issue_diagnostic (local_status);
    IFEND;

    clp$close_display (v$display_control, local_status);
    IF NOT local_status.normal THEN
      issue_diagnostic (local_status);
    IFEND;

    IF status.normal THEN
      IF v$diagnostic_count = 0 THEN
        osp$set_status_abnormal ('OC', oce$i_generate_status, 'GENERATE completed - NO errors encountered',
              status);
      ELSE
        osp$set_status_abnormal ('OC', oce$w_generate_status,
              'GENERATE completed - NON FATAL errors encountered', status);
      IFEND;
    IFEND;


  PROCEND ocp$generate_real_memory;

MODEND ocm$real_memory_builder;
*DECK DECK=OCM$REORDER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
MODULE ocm$reorder;


{ PURPOSE:
{   To alter the order of modules on the
{   current output library.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oce$library_generator_errors
*copyc oct$display_toggles
*copyc oct$new_library_module_list
*copyc oct$nlm_modification_list
*copyc ost$status
?? POP ??
*copyc clp$evaluate_parameters
*copyc ocp$close_all_open_files
*copyc ocp$generate_message
*copyc ocp$initialize_olg_working_heap
*copyc ocp$reorder_nlm_list
*copyc ocp$search_modification_list
*copyc ocp$search_nlm_tree
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc ocv$nlm_list
*copyc ocv$olg_scratch_seq
*copyc ocv$open_file_list
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    command_status: ost$status;

?? OLDTITLE ??
?? NEWTITLE := 'reorder_module_subrange' ??
?? EJECT ??

  PROCEDURE reorder_module_subrange
    (    first_module: pmt$program_name;
         last_module: pmt$program_name;
         reorder_list: {output} ^oct$nlm_modification_list;
     VAR status: ost$status);


    VAR
      new_reorders: ^oct$nlm_modification_list,
      last_reorder: ^oct$nlm_modification_list,

      module_found: boolean,
      nlm: ^oct$new_library_module_list,
      current_module: pmt$program_name;


    ocp$search_modification_list (osc$null_name, reorder_list, new_reorders, module_found);

    ocp$search_nlm_tree (first_module, nlm, module_found);
    IF NOT module_found THEN
      IF first_module = last_module THEN
        osp$set_status_abnormal (oc, oce$w_module_not_on_library, first_module, status);
      ELSE
        osp$set_status_abnormal (oc, oce$w_subrange_not_found_on_lib, first_module, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, last_module, status);
      IFEND;
      ocp$generate_message (status);
      osp$set_status_abnormal (oc, oce$e_some_modules_not, 'reordered', command_status);
      RETURN;
    IFEND;

    REPEAT
      current_module := nlm^.name;
      IF current_module = osc$null_name THEN
        osp$set_status_abnormal (oc, oce$e_range_module_2_not_found, last_module, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);
        ocp$generate_message (status);
        osp$set_status_abnormal (oc, oce$e_some_modules_not, 'reordered', command_status);
        new_reorders^.link := NIL;
        RETURN;
      IFEND;

      ocp$search_modification_list (current_module, reorder_list, last_reorder, module_found);
      IF module_found THEN
        osp$set_status_abnormal (oc, oce$w_same_module_quoted_twice, current_module, status);
        ocp$generate_message (status);
        osp$set_status_abnormal (oc, oce$e_some_modules_not, 'reordered', command_status);

      ELSE
        NEXT last_reorder^.link IN ocv$olg_scratch_seq;
        last_reorder := last_reorder^.link;
        IF last_reorder = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;

        last_reorder^.nlm := nlm;

        last_reorder^.link := NIL;
      IFEND;

      nlm := nlm^.f_link;

    UNTIL current_module = last_module;


  PROCEND reorder_module_subrange;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$_reorder_module' ??
?? EJECT ??

{ This procedure is the command processor for the CREATE_OBJECT_LIBRARY
{ subcommand REORDER_MODULE.

  PROCEDURE [XDCL] ocp$_reorder_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$creol_reom) reorder_module, reorder_modules, reom (
{   module, modules, m: list of any of
{       program_name
{       range of program_name
{     anyend = $required
{   placement, p: key
{       (after, a)
{       (before, b)
{     keyend = after
{   destination, d: program_name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [93, 10, 11, 1, 36, 1, 512],
    clc$command, 8, 4, 1, 0, 0, 0, 4, 'OCM$CREOL_REOM'], [
    ['D                              ',clc$abbreviation_entry, 3],
    ['DESTINATION                    ',clc$nominal_entry, 3],
    ['M                              ',clc$abbreviation_entry, 1],
    ['MODULE                         ',clc$nominal_entry, 1],
    ['MODULES                        ',clc$alias_entry, 1],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PLACEMENT                      ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 49, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$program_name_type,
      clc$range_type],
      FALSE, 2],
      3, [[1, 0, clc$program_name_type]],
      10, [[1, 0, clc$range_type], [3],
          [[1, 0, clc$program_name_type]]
        ]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['AFTER                          ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['B                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['BEFORE                         ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'after'],
{ PARAMETER 3
    [[1, 0, clc$program_name_type]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$module = 1,
      p$placement = 2,
      p$destination = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND condition_handler;
?? OLDTITLE ??

    VAR
      after: ^oct$new_library_module_list,
      first_module: pmt$program_name,
      ignore_status: ost$status,
      last_module: pmt$program_name,
      module_found: boolean,
      nlm: ^oct$new_library_module_list,
      node: ^clt$data_value,
      reorder_list: oct$nlm_modification_list;

    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler;

?? EJECT ??

    status.normal := TRUE;
    command_status.normal := TRUE;

    RESET ocv$olg_scratch_seq;
    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /protect/
    BEGIN
      IF pvt [p$destination].specified THEN
        ocp$search_nlm_tree (pvt [p$destination].value^.program_name_value, nlm, module_found);
        IF NOT module_found THEN
          osp$set_status_abnormal (oc, oce$e_module_not_found, pvt [p$destination].value^.program_name_value,
                status);
          EXIT /protect/;
        IFEND;
        IF pvt [p$placement].value^.keyword_value = 'AFTER' THEN
          after := nlm;
        ELSE { BEFORE
          after := nlm^.b_link;
        IFEND;
      ELSE
        IF pvt [p$placement].value^.keyword_value = 'AFTER' THEN
          after := ocv$nlm_list^.b_link;
        ELSE { BEFORE
          after := ocv$nlm_list;
        IFEND;
      IFEND;

      reorder_list.link := NIL;
      node := pvt [p$module].value;

      WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
        IF node^.element_value^.kind = clc$range THEN
          first_module := node^.element_value^.low_value^.program_name_value;
          last_module := node^.element_value^.high_value^.program_name_value;
        ELSE
          first_module := node^.element_value^.program_name_value;
          last_module := first_module;
        IFEND;
        reorder_module_subrange (first_module, last_module, ^reorder_list, status);
        IF NOT status.normal THEN
          EXIT /protect/;
        IFEND;
        node := node^.link;
      WHILEND;

      IF (reorder_list.link <> NIL) AND (reorder_list.link^.nlm^.name = after^.name) THEN
        reorder_list.link := reorder_list.link^.link;
      IFEND;

      ocp$reorder_nlm_list (after, ^reorder_list);

      status := command_status;
    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);


  PROCEND ocp$_reorder_module;
?? OLDTITLE ??
MODEND ocm$reorder;
*DECK DECK=OCM$REPLACE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Object Library Generator' ??
MODULE ocm$replace;


{ PURPOSE:
{   To replace all or selected modules
{   from the named file or library with
{   the output library.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oce$library_generator_errors
*copyc oct$display_toggles
*copyc oct$new_library_module_list
*copyc oct$nlm_replacement_list
*copyc oct$open_file_list
*copyc ost$status
?? POP ??
*copyc clp$evaluate_parameters
*copyc ocp$close_all_open_files
*copyc ocp$free_nlm_replacement_list
*copyc ocp$generate_message
*copyc ocp$get_module_from_wfl
*copyc ocp$initialize_olg_working_heap
*copyc ocp$obtain_object_file
*copyc ocp$replace_list_into_nlm_list
*copyc ocp$rewind_working_file_list
*copyc ocp$search_nlm_tree
*copyc ocp$search_replacement_list
*copyc ocp$search_working_file_list
*copyc ocp$skip_module_on_wfl
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc ocv$olg_scratch_seq
*copyc ocv$open_file_list
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    command_status: ost$status;

?? OLDTITLE ??
?? NEWTITLE := 'replace_module_subrange' ??
?? EJECT ??

  PROCEDURE replace_module_subrange
    (    first_module: pmt$program_name;
         last_module: pmt$program_name;
     VAR working_file_list: oct$working_file_list;
         replacement_list: {output} ^oct$nlm_replacement_list;
     VAR status: ost$status);




    VAR
      new_replacements: ^oct$nlm_replacement_list,
      last_replacement: ^oct$nlm_replacement_list,

      module_found: boolean,
      nlm: ^oct$new_library_module_list,
      current_module: pmt$program_name,
      file_descriptor: ^oct$open_file_list;


    ocp$search_replacement_list (osc$null_name, replacement_list, new_replacements, module_found);

    ocp$rewind_working_file_list (working_file_list);

    ocp$search_working_file_list (first_module, working_file_list, module_found);
    IF NOT module_found THEN
      IF first_module = last_module THEN
        osp$set_status_abnormal ('OC', oce$w_module_not_found, first_module, status);
      ELSE
        osp$set_status_abnormal ('OC', oce$w_subrange_module_not_found, first_module, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, last_module, status);
      IFEND;
      ocp$generate_message (status);
      osp$set_status_abnormal ('OC', oce$e_some_modules_not, 'replaced', command_status);
      RETURN;
    IFEND;

    REPEAT
      ocp$get_module_from_wfl (working_file_list, current_module, file_descriptor);
      IF current_module = osc$null_name THEN
        IF last_module <> osc$null_name THEN
          osp$set_status_abnormal (oc, oce$e_range_module_2_not_found, last_module, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, first_module, status);
          ocp$generate_message (status);
          osp$set_status_abnormal (oc, oce$e_some_modules_not, 'replaced', command_status);
          ocp$free_nlm_replacement_list (new_replacements);
        IFEND;
        RETURN;
      IFEND;

      ocp$search_replacement_list (current_module, replacement_list, last_replacement, module_found);
      IF module_found THEN
        osp$set_status_abnormal (oc, oce$w_same_module_quoted_twice, current_module, status);
        ocp$generate_message (status);
        osp$set_status_abnormal (oc, oce$e_some_modules_not, 'replaced', command_status);

      ELSE
        ocp$search_nlm_tree (current_module, nlm, module_found);
        IF module_found THEN
          NEXT last_replacement^.link IN ocv$olg_scratch_seq;
          last_replacement := last_replacement^.link;
          IF last_replacement = NIL THEN
            osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
            RETURN;
          IFEND;

          last_replacement^.nlm := nlm;
          last_replacement^.link := NIL;

          last_replacement^.description := ^file_descriptor^.directory^ [file_descriptor^.current_module];
        ELSE
          osp$set_status_abnormal (oc, oce$w_module_not_on_library, current_module, status);
          ocp$generate_message (status);
          osp$set_status_abnormal (oc, oce$e_some_modules_not, 'replaced', command_status);
        IFEND;
      IFEND;

      ocp$skip_module_on_wfl (working_file_list);

    UNTIL current_module = last_module;


  PROCEND replace_module_subrange;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$_replace_module' ??
?? EJECT ??

{ This procedure is the command processor for the CREATE_OBJECT_LIBRARY
{ subcommand REPLACE_MODULE.

  PROCEDURE [XDCL] ocp$_replace_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$creol_repm) replace_module, replace_modules, repm (
{   library, libraries, l: list of file = $required
{   module, modules, m: list of any of
{       program_name
{       range of program_name
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [93, 10, 11, 1, 30, 41, 114],
    clc$command, 7, 3, 1, 0, 0, 0, 3, 'OCM$CREOL_REPM'], [
    ['L                              ',clc$abbreviation_entry, 1],
    ['LIBRARIES                      ',clc$alias_entry, 1],
    ['LIBRARY                        ',clc$nominal_entry, 1],
    ['M                              ',clc$abbreviation_entry, 2],
    ['MODULE                         ',clc$nominal_entry, 2],
    ['MODULES                        ',clc$alias_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 19, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 49, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$program_name_type,
      clc$range_type],
      FALSE, 2],
      3, [[1, 0, clc$program_name_type]],
      10, [[1, 0, clc$range_type], [3],
          [[1, 0, clc$program_name_type]]
        ]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$library = 1,
      p$module = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND condition_handler;
?? OLDTITLE ??


    VAR
      after: ^oct$new_library_module_list,
      file_descriptor: ^oct$open_file_list,
      first_module: pmt$program_name,
      ignore_status: ost$status,
      last_module: pmt$program_name,
      node: ^clt$data_value,
      replacement_list: oct$nlm_replacement_list,
      working_file_list: oct$working_file_list;

    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler;

    status.normal := TRUE;
    command_status.normal := TRUE;

    RESET ocv$olg_scratch_seq;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];

    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);

  /protect/
    BEGIN
      working_file_list.current_file := ^working_file_list.first_working_file;
      node := pvt [p$library].value;
      WHILE node <> NIL DO
        NEXT working_file_list.current_file^.link IN ocv$olg_scratch_seq;
        working_file_list.current_file := working_file_list.current_file^.link;
        IF working_file_list.current_file = NIL THEN
          osp$set_status_condition (oce$e_internal_olg_seg_overflow, status);
          RETURN;
        IFEND;
        ocp$obtain_object_file (node^.element_value^.file_value^, working_file_list.current_file^.descriptor,
              status);
        IF NOT status.normal THEN
          EXIT /protect/;
        IFEND;
        node := node^.link;
      WHILEND;

      working_file_list.current_file^.link := NIL;
      replacement_list.link := NIL;

      IF pvt [p$module].specified THEN
        node := pvt [p$module].value;

      /obtain_replacement_list/
        WHILE (node <> NIL) AND (node^.element_value <> NIL) DO
          IF node^.element_value^.kind = clc$range THEN
            first_module := node^.element_value^.low_value^.program_name_value;
            last_module := node^.element_value^.high_value^.program_name_value;
          ELSE
            first_module := node^.element_value^.program_name_value;
            last_module := first_module;
          IFEND;
          replace_module_subrange (first_module, last_module, working_file_list, ^replacement_list, status);
          IF NOT status.normal THEN
            EXIT /obtain_replacement_list/;
          IFEND;
          node := node^.link;
        WHILEND /obtain_replacement_list/;
      ELSE
        ocp$rewind_working_file_list (working_file_list);
        ocp$get_module_from_wfl (working_file_list, first_module, file_descriptor);
        last_module := osc$null_name;
        replace_module_subrange (first_module, last_module, working_file_list, ^replacement_list, status);
      IFEND;
      IF NOT status.normal THEN
        ocp$free_nlm_replacement_list (^replacement_list);
        EXIT /protect/;
      IFEND;

      ocp$replace_list_into_nlm_list (^replacement_list);

      status := command_status;
    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);


  PROCEND ocp$_replace_module;
?? OLDTITLE ??
MODEND ocm$replace;
*DECK DECK=OCM$RMB_COMMAND_HANDLERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Real Memory Builder Command Handlers', EJECT ??
MODULE ocm$rmb_command_handlers;

{ PURPOSE:
{  Command processors for the Real Memory Builder.
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_expression_result
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_parameter_list
*copyc clc$standard_file_names
*copyc oce$library_generator_errors
*copyc oce$rm_builder_exceptions
*copyc oce$ve_linker_exceptions
*copyc oct$build_options
*copyc ost$hardware_subranges
*copyc ost$page_size
*copyc ost$page_table
?? POP ??
*copyc clp$end_scan_command_file
*copyc clp$get_path_description
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$get_value_count
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$scan_command_file
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc ocp$crack_program_name
*copyc ocp$create_transient_segment
*copyc ocp$generate_real_memory
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
?? POP ??
?? NEWTITLE := '  Global Variables', EJECT ??


  VAR
    ocv$rmb_scratch_seq: [XDCL] ^SEQ ( * );


  VAR
    rmb_generator_not_executed: boolean,

    command_file: [STATIC] amt$local_file_name := clc$current_command_input,
    build_options: oct$build_options;

?? OLDTITLE ??
?? NEWTITLE := '    RESET_MEMORY_BUILDER_PARAMETERS', EJECT ??

  PROCEDURE reset_memory_builder_parameters;






?? FMT (FORMAT := OFF) ??
  VAR
    default_build_options: [STATIC] oct$build_options :=

      [ { page_size }                 4096,
        { page_table_address }        0,
        { page_table_length }         4096,
        { load_address }              0,
        { load_offset }               0,
        { memory_map }                ['MEMORY_MAP'],
        { c170_memory_size }          0,
        { ssr_size }                  0,
        { job_exchange_address }      [occ$null, osc$null_name],
        { mtr_exchange_address }      [occ$null, osc$null_name],
        { pp_address_array_address }  [occ$null, osc$null_name],
        { pages_loaded_address }      [occ$null, osc$null_name],
        { page_size_address }         [occ$null, osc$null_name],
        { define_commands }           [*, *, *, *, *, *, *, *, *, *, *, *, *, nil],
        { load_files }                [osc$null_name, *, nil],
        { monitor_symbol_tables }     [osc$null_name, nil],
        { job_symbol_tables }         [osc$null_name, nil],
        { segment_commands }          [*, *, nil, occ$extend, *],
        { memory_commands }           [false, nil, *, occ$display_memory, *],
        { bytes_loaded_address }      [occ$null, osc$null_name],
        { building_ei }               FALSE];


?? FMT (FORMAT := ON) ??
    RESET ocv$rmb_scratch_seq;

    build_options := default_build_options;

    rmb_generator_not_executed := FALSE;


  PROCEND reset_memory_builder_parameters;
?? OLDTITLE ??
?? NEWTITLE := '  CRACK_EXCHANGE_NAME_PARAMETER', EJECT ??

  PROCEDURE crack_exchange_name_parameter (keyword: string ( * );
    VAR exchange_name: oct$exchange_name;
    VAR status: ost$status);


    VAR
      parameter_specified: boolean,
      parameter: clt$value,
      strng: string (39);


    clp$test_parameter (keyword, parameter_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter_specified THEN
      clp$get_value (keyword, 1, 1, clc$low, parameter, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF parameter.kind = clc$name_value THEN
        IF (parameter.name.value = 'MONITOR') OR (parameter.name.value = 'M') THEN
          exchange_name.address_space := occ$mtr;
        ELSEIF (parameter.name.value = 'JOB') OR (parameter.name.value = 'J') THEN
          exchange_name.address_space := occ$job;
        ELSE
          osp$set_status_abnormal ('OC', oce$e_invalid_address_space_id, '', status);
          RETURN;
        IFEND;
      ELSE
        osp$set_status_abnormal ('OC', cle$wrong_kind_of_value, 'NAME', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, parameter.descriptor, status);
        strng := ' for parameter';
        strng (16, 24) := keyword;
        osp$append_status_parameter (osc$status_parameter_delimiter, strng, status);
        RETURN;
      IFEND;

      clp$get_value (keyword, 2, 1, clc$low, parameter, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      ocp$crack_program_name (keyword, parameter, exchange_name.name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;


  PROCEND crack_exchange_name_parameter;
?? OLDTITLE ??
?? NEWTITLE := '  CRACK_SEGMENT_ATTRIBUTES_PARAM' ??
?? EJECT ??

  PROCEDURE crack_segment_attributes_param (keyword: string ( * );
    VAR hardware_attributes: ost$segment_access_control;
    VAR software_attributes: mmt$software_attribute_set;
    VAR parameter_specified: oct$parameters;
    VAR status: ost$status);




    VAR
      parameter: clt$value,
      number_of_sets: 0 .. clc$max_value_sets,
      i: 0 .. clc$max_value_sets,

      read_attributes: 0 .. clc$max_value_sets,
      write_attributes: 0 .. clc$max_value_sets,
      execute_attributes: 0 .. clc$max_value_sets;



    clp$get_set_count (keyword, number_of_sets, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF number_of_sets <> 0 THEN
      parameter_specified := parameter_specified + $oct$parameters [occ$attributes];
    IFEND;

    hardware_attributes.cache_bypass := FALSE;
    software_attributes := $mmt$software_attribute_set [];

    read_attributes := 0;
    write_attributes := 0;
    execute_attributes := 0;

    FOR i := 1 TO number_of_sets DO
      clp$get_value (keyword, i, 1, clc$low, parameter, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF parameter.name.value = 'RD' THEN
        hardware_attributes.read_privilege := osc$read_uncontrolled;
        read_attributes := read_attributes + 1;

      ELSEIF parameter.name.value = 'RK' THEN
        hardware_attributes.read_privilege := osc$read_key_lock_controlled;
        read_attributes := read_attributes + 1;
?? EJECT ??

      ELSEIF parameter.name.value = 'WT' THEN
        hardware_attributes.write_privilege := osc$write_uncontrolled;
        write_attributes := write_attributes + 1;

      ELSEIF parameter.name.value = 'WK' THEN
        hardware_attributes.write_privilege := osc$write_key_lock_controlled;
        write_attributes := write_attributes + 1;

      ELSEIF parameter.name.value = 'EX' THEN
        hardware_attributes.execute_privilege := osc$non_privileged;
        execute_attributes := execute_attributes + 1;

      ELSEIF parameter.name.value = 'LP' THEN
        hardware_attributes.execute_privilege := osc$local_privilege;
        execute_attributes := execute_attributes + 1;

      ELSEIF parameter.name.value = 'GP' THEN
        hardware_attributes.execute_privilege := osc$global_privilege;
        execute_attributes := execute_attributes + 1;

      ELSEIF parameter.name.value = 'BI' THEN
        hardware_attributes.read_privilege := osc$binding_segment;
        read_attributes := read_attributes + 1;

      ELSEIF parameter.name.value = 'CB' THEN
        hardware_attributes.cache_bypass := TRUE;

      ELSEIF parameter.name.value = 'WR' THEN
        software_attributes := software_attributes + $mmt$software_attribute_set [mmc$sa_wired];

      ELSEIF parameter.name.value = 'FX' THEN
        software_attributes := software_attributes + $mmt$software_attribute_set [mmc$sa_fixed];

      ELSEIF parameter.name.value = 'ST' THEN
        software_attributes := software_attributes + $mmt$software_attribute_set [mmc$sa_stack];

      ELSEIF parameter.name.value = 'RT' THEN
        software_attributes := software_attributes + $mmt$software_attribute_set [mmc$sa_read_transfer_unit];

      ELSEIF parameter.name.value = 'FB' THEN
        software_attributes := software_attributes + $mmt$software_attribute_set [mmc$sa_free_behind];

      ELSEIF parameter.name.value = 'NA' THEN
        software_attributes := software_attributes + $mmt$software_attribute_set [mmc$sa_no_append];

      IFEND;
    FOREND;
?? EJECT ??

    IF read_attributes = 0 THEN
      hardware_attributes.read_privilege := osc$non_readable;
    ELSEIF read_attributes > 1 THEN
      osp$set_status_abnormal ('OC', oce$e_seg_attribute_conflict, 'Multiple READ attributes', status);
      RETURN;
    IFEND;

    IF write_attributes = 0 THEN
      hardware_attributes.write_privilege := osc$non_writable;
    ELSEIF write_attributes > 1 THEN
      osp$set_status_abnormal ('OC', oce$e_seg_attribute_conflict, 'Multiple WRITE attributes', status);
      RETURN;
    IFEND;

    IF execute_attributes = 0 THEN
      hardware_attributes.execute_privilege := osc$non_executable;
    ELSEIF execute_attributes > 1 THEN
      osp$set_status_abnormal ('OC', oce$e_seg_attribute_conflict, 'Multiple EXECUTE attributes', status);
      RETURN;
    IFEND;

  PROCEND crack_segment_attributes_param;
?? OLDTITLE ??
?? NEWTITLE := '  CRACK_RING_BRACKETS_PARAMETER', EJECT ??

  PROCEDURE crack_ring_brackets_parameter (keyword: string ( * );
    VAR r1: ost$valid_ring;
    VAR r2: ost$valid_ring;
    VAR parameter_specified: oct$parameters;
    VAR status: ost$status);


    VAR
      parameter: clt$value,
      strng: string (2),
      l: integer;


    clp$get_value (keyword, 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter.kind <> clc$unknown_value THEN
      parameter_specified := parameter_specified + $oct$parameters [occ$ring_brackets];
      r1 := parameter.int.value;

      clp$get_value (keyword, 2, 1, clc$low, parameter, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      r2 := parameter.int.value;


      IF NOT (r1 <= r2) THEN
        STRINGREP (strng, l, r1);
        osp$set_status_abnormal ('OC', oce$e_invalid_ring1_ring2, strng (1, l), status);
        STRINGREP (strng, l, r2);
        osp$append_status_parameter (osc$status_parameter_delimiter, strng (1, l), status);
        RETURN;
      IFEND;
    IFEND;


  PROCEND crack_ring_brackets_parameter;
?? OLDTITLE ??
?? NEWTITLE := '  CRACK_KEY_LOCK_PARAMETER', EJECT ??

  PROCEDURE crack_key_lock_parameter (keyword: string ( * );
    VAR key_lock: ost$key_lock;
    VAR parameter_specified: oct$parameters;
    VAR status: ost$status);


    VAR
      parameter: clt$value,
      strng: string (80),
      l: integer;


    clp$get_value (keyword, 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter.kind <> clc$unknown_value THEN
      parameter_specified := parameter_specified + $oct$parameters [occ$gl_key];

      IF parameter.int.value = 0 THEN
        key_lock.global := FALSE;
      ELSE
        key_lock.global := TRUE;
        key_lock.value := parameter.int.value;
      IFEND;

      clp$get_value (keyword, 2, 1, clc$low, parameter, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF parameter.int.value = 0 THEN
        key_lock.local := FALSE;
      ELSE
        IF key_lock.global = TRUE THEN
          IF key_lock.value <> parameter.int.value THEN
            STRINGREP (strng, l, key_lock.value);
            osp$set_status_abnormal ('OC', oce$e_global_local_key_mismatch, strng (1, l), status);
            STRINGREP (strng, l, parameter.int.value);
            osp$append_status_parameter (osc$status_parameter_delimiter, strng (1, l), status);
            RETURN;
          ELSE
            key_lock.local := TRUE;
          IFEND;
        ELSE
          key_lock.local := TRUE;
          key_lock.value := parameter.int.value;
        IFEND;
      IFEND;
    IFEND;

  PROCEND crack_key_lock_parameter;
?? OLDTITLE ??
?? NEWTITLE := '  CRACK_SEGMENT_NUMBER_PARAMETER', EJECT ??

  PROCEDURE crack_segment_number_parameter (keyword: string ( * );
    VAR segment_number: ost$segment;
    VAR status: ost$status);


    VAR
      parameter: clt$value;


    clp$get_value (keyword, 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    segment_number := parameter.int.value;


  PROCEND crack_segment_number_parameter;
?? OLDTITLE ??
?? NEWTITLE := '  CRACK_ADDRESS_SPACE_PARAMETER', EJECT ??

  PROCEDURE crack_address_space_parameter (keyword: string ( * );
    VAR address_space: oct$address_space_id;
    VAR status: ost$status);


    VAR
      parameter: clt$value;


    clp$get_value (keyword, 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter.name.value (1) = 'J' THEN
      address_space := occ$job;
    ELSEIF parameter.name.value (1) = 'M' THEN
      address_space := occ$mtr;
    ELSE
      address_space := occ$both;
    IFEND;

  PROCEND crack_address_space_parameter;
?? OLDTITLE ??
?? NEWTITLE := '  CRACK_ADDRESS_PARAMETER', EJECT ??

  PROCEDURE crack_address_parameter (keyword: string ( * );
    VAR rma: ost$real_memory_address;
    VAR status: ost$status);


    VAR
      parameter: clt$value;




    clp$get_value (keyword, 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rma := parameter.int.value;


  PROCEND crack_address_parameter;
?? OLDTITLE ??
?? NEWTITLE := '  CRACK_ACTIVE_SEGMENT_ID_PARAMETER', EJECT ??

  PROCEDURE crack_active_segment_id_param (keyword: string ( * );
    VAR asid: ost$asid;
    VAR parameter_specified: oct$parameters;
    VAR status: ost$status);


    VAR
      parameter: clt$value;




    clp$get_value (keyword, 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter.kind <> clc$unknown_value THEN
      parameter_specified := parameter_specified + $oct$parameters [occ$asid];
      asid := parameter.int.value;
    IFEND;


  PROCEND crack_active_segment_id_param;
?? OLDTITLE ??
?? NEWTITLE := '  CRACK_LENGTH_PARAMETER', EJECT ??

  PROCEDURE crack_length_parameter (keyword: string ( * );
    VAR segment_length: ost$segment_length;
    VAR status: ost$status);


    VAR
      parameter: clt$value;




    clp$get_value (keyword, 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    segment_length := parameter.int.value;


  PROCEND crack_length_parameter;
?? OLDTITLE ??
?? NEWTITLE := '  DUPLICATE_LOAD_FILE', EJECT ??

  FUNCTION duplicate_load_file (file_name: amt$local_file_name;
        load_file_list: oct$load_file_list): boolean;


    VAR
      load_file: ^oct$load_file_list;


    load_file := ^load_file_list;

    REPEAT
      IF load_file^.name = file_name THEN
        duplicate_load_file := TRUE;
        RETURN;
      IFEND;

      load_file := load_file^.link;
    UNTIL load_file = NIL;

    duplicate_load_file := FALSE;


  FUNCEND duplicate_load_file;
?? OLDTITLE ??
?? NEWTITLE := '  DUPLICATE_SYMBOL_TABLE_FILE', EJECT ??

  FUNCTION duplicate_symbol_table_file (file_name: amt$local_file_name;
        symbol_table_list: oct$symbol_table_list): boolean;


    VAR
      symbol_table: ^oct$symbol_table_list;


    symbol_table := ^symbol_table_list;

    REPEAT
      IF symbol_table^.name = file_name THEN
        duplicate_symbol_table_file := TRUE;
        RETURN;
      IFEND;

      symbol_table := symbol_table^.link;
    UNTIL symbol_table = NIL;

    duplicate_symbol_table_file := FALSE;


  FUNCEND duplicate_symbol_table_file;
?? OLDTITLE ??
?? NEWTITLE := '    VERIFY_POWER_OF_TWO', EJECT ??

  PROCEDURE verify_power_of_two (number: integer;
    VAR status: ost$status);




    VAR
      l,
      num: integer,
      strng: string (80);



    num := number;

    WHILE num > 1 DO
      IF (num MOD 2) <> 0 THEN
        STRINGREP (strng, l, number);
        osp$set_status_abnormal ('OC', oce$e_integer_not_power_of_two, strng (1, l), status);
        RETURN;
      IFEND;

      num := num DIV 2;
    WHILEND;

  PROCEND verify_power_of_two;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$SET_BUILD_OPTIONS', EJECT ??

  PROCEDURE ocp$set_build_options (parameter_list: clt$parameter_list;
    VAR status: ost$status);




{ pdt set_build_options_pdt (
{   page_size, ps: integer 2048 .. 16384
{   page_table_address, pta: integer 0 .. 0ffffffff(16)
{   page_table_length, ptl: integer 4096 .. 1048576
{   load_address, la: integer 0 .. 0ffffffff(16)
{   load_offset, lo: integer 0 .. 0ffffffff(16)
{   memory_map, mm: file
{   c170_memory_size, cms: integer 0 .. 0ffffffff(16)
{   ssr_size, ss: integer 0 .. 0ffffffff(16)
{   job_exchange_address, jea: list 2..2 1..1 of any
{   monitor_exchange_address, mea: list 2..2 1..1 of any
{   pp_address_array_address, paaa: list 2..2 1..1 of any
{   pages_loaded_address, pla: list 2..2 1..1 of any
{   page_size_address, psa: list 2..2 1..1 of any
{   bytes_loaded_address, bla : list 2..2 1..1 of any
{   building_environment_interface, bei: boolean = false
{   status, st)

?? PUSH (LISTEXT := ON) ??

    VAR
      set_build_options_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^set_build_options_pdt_names, ^set_build_options_pdt_params];

    VAR
      set_build_options_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 32] of
        clt$parameter_name_descriptor := [['PAGE_SIZE', 1], ['PS', 1], ['PAGE_TABLE_ADDRESS', 2], ['PTA', 2],
        ['PAGE_TABLE_LENGTH', 3], ['PTL', 3], ['LOAD_ADDRESS', 4], ['LA', 4], ['LOAD_OFFSET', 5], ['LO', 5],
        ['MEMORY_MAP', 6], ['MM', 6], ['C170_MEMORY_SIZE', 7], ['CMS', 7], ['SSR_SIZE', 8], ['SS', 8], [
        'JOB_EXCHANGE_ADDRESS', 9], ['JEA', 9], ['MONITOR_EXCHANGE_ADDRESS', 10], ['MEA', 10], [
        'PP_ADDRESS_ARRAY_ADDRESS', 11], ['PAAA', 11], ['PAGES_LOADED_ADDRESS', 12], ['PLA', 12], [
        'PAGE_SIZE_ADDRESS', 13], ['PSA', 13], ['BYTES_LOADED_ADDRESS', 14], ['BLA', 14], [
        'BUILDING_ENVIRONMENT_INTERFACE', 15], ['BEI', 15], ['STATUS', 16], ['ST', 16]];

    VAR
      set_build_options_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 16] of
        clt$parameter_descriptor := [

{ PAGE_SIZE PS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 2048, 16384]],

{ PAGE_TABLE_ADDRESS PTA }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffffff(16)]],

{ PAGE_TABLE_LENGTH PTL }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 4096, 1048576]],

{ LOAD_ADDRESS LA }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffffff(16)]],

{ LOAD_OFFSET LO }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffffff(16)]],

{ MEMORY_MAP MM }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ C170_MEMORY_SIZE CMS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffffff(16)]],

{ SSR_SIZE SS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffffff(16)]],

{ JOB_EXCHANGE_ADDRESS JEA }
      [[clc$optional], 2, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$any_value]],

{ MONITOR_EXCHANGE_ADDRESS MEA }
      [[clc$optional], 2, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$any_value]],

{ PP_ADDRESS_ARRAY_ADDRESS PAAA }
      [[clc$optional], 2, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$any_value]],

{ PAGES_LOADED_ADDRESS PLA }
      [[clc$optional], 2, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$any_value]],

{ PAGE_SIZE_ADDRESS PSA }
      [[clc$optional], 2, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$any_value]],

{ BYTES_LOADED_ADDRESS BLA }
      [[clc$optional], 2, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$any_value]],

{ BUILDING_ENVIRONMENT_INTERFACE BEI }
      [[clc$optional_with_default, ^set_build_options_pdt_dv15], 1, 1, 1, 1, clc$value_range_not_allowed,
        [NIL, clc$boolean_value]],

{ STATUS ST }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      set_build_options_pdt_dv15: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';

?? POP ??
?? EJECT ??

    VAR
      local_parameters: oct$build_options,
      parameter: clt$value,
      parameter_specified: boolean,
      page_table_address_set: boolean,
      segment_command: ^oct$define_command_list;


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, set_build_options_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    local_parameters := build_options;

    clp$get_value ('PAGE_SIZE', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF parameter.kind <> clc$unknown_value THEN
      IF (parameter.int.value = 2048) OR (parameter.int.value = 4096) OR (parameter.int.value = 8192) OR
            (parameter.int.value = 16384) THEN
        local_parameters.page_size := parameter.int.value;
      ELSE
        osp$set_status_abnormal ('OC', oce$e_build_option_error, 'INVALID_PAGE_SIZE_PARAMETER', status);
        RETURN;
      IFEND;
    IFEND;

    clp$get_value ('PAGE_TABLE_ADDRESS', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF parameter.kind <> clc$unknown_value THEN
      local_parameters.page_table_address := parameter.int.value;
      page_table_address_set := TRUE;
    ELSE
      page_table_address_set := FALSE;
    IFEND;

    clp$get_value ('PAGE_TABLE_LENGTH', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF parameter.kind <> clc$unknown_value THEN
      verify_power_of_two (parameter.int.value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      local_parameters.page_table_length := parameter.int.value;
    IFEND;
?? EJECT ??

    clp$get_value ('LOAD_ADDRESS', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF parameter.kind <> clc$unknown_value THEN
      local_parameters.load_address := parameter.int.value;
    IFEND;

    clp$get_value ('LOAD_OFFSET', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF parameter.kind <> clc$unknown_value THEN
      local_parameters.load_offset := parameter.int.value;
    IFEND;

    clp$get_value ('MEMORY_MAP', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF parameter.kind <> clc$unknown_value THEN
      local_parameters.memory_map := parameter.file;
    IFEND;

    clp$get_value ('C170_MEMORY_SIZE', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF parameter.kind <> clc$unknown_value THEN
      verify_power_of_two (parameter.int.value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      local_parameters.c170_memory_size := parameter.int.value;
    IFEND;

    clp$get_value ('SSR_SIZE', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF parameter.kind <> clc$unknown_value THEN
      local_parameters.ssr_size := parameter.int.value;
    IFEND;
?? EJECT ??

    crack_exchange_name_parameter ('JOB_EXCHANGE_ADDRESS', local_parameters.job_exchange_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_exchange_name_parameter ('MONITOR_EXCHANGE_ADDRESS', local_parameters.monitor_exchange_address,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_exchange_name_parameter ('PP_ADDRESS_ARRAY_ADDRESS', local_parameters.pp_address_array_address,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_exchange_name_parameter ('PAGES_LOADED_ADDRESS', local_parameters.pages_loaded_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_exchange_name_parameter ('PAGE_SIZE_ADDRESS', local_parameters.page_size_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_exchange_name_parameter ('BYTES_LOADED_ADDRESS', local_parameters.bytes_loaded_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    clp$get_value ('BUILDING_ENVIRONMENT_INTERFACE', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_parameters.building_ei := parameter.bool.value;

    build_options := local_parameters;


    IF page_table_address_set THEN
      segment_command := build_options.define_commands.link;
      WHILE (segment_command <> NIL) AND (segment_command^.segment_id <> 'PAGE_TABLE') DO
        segment_command := segment_command^.link;
      WHILEND;
      IF segment_command <> NIL THEN
        segment_command^.address := build_options.page_table_address;
      IFEND;
    IFEND;

  PROCEND ocp$set_build_options;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$LOAD_MONITOR', EJECT ??

  PROCEDURE ocp$load_monitor (parameter_list: clt$parameter_list;
    VAR status: ost$status);




{ pdt load_monitor_pdt (
{   virtual_image, vi: list of file = $required
{   symbol_table, symbol_tables, st: list of file
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      load_monitor_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^load_monitor_pdt_names,
        ^load_monitor_pdt_params];

    VAR
      load_monitor_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
        clt$parameter_name_descriptor := [['VIRTUAL_IMAGE', 1], ['VI', 1], ['SYMBOL_TABLE', 2], [
        'SYMBOL_TABLES', 2], ['ST', 2], ['STATUS', 3]];

    VAR
      load_monitor_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor
        := [

{ VIRTUAL_IMAGE VI }
      [[clc$required], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ SYMBOL_TABLE SYMBOL_TABLES ST }
      [[clc$optional], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??
?? EJECT ??

    VAR
      parameter: clt$value,

      load_monitor_files: oct$load_file_list,
      last_load_monitor_file: ^oct$load_file_list,

      new_symbol_table_names: oct$symbol_table_list,
      last_new_symbol_table_name: ^oct$symbol_table_list,

      number_of_files: 0 .. clc$max_value_sets,
      file_number: 0 .. clc$max_value_sets;



    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, load_monitor_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('VIRTUAL_IMAGE', number_of_files, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    load_monitor_files.name := osc$null_name;
    load_monitor_files.link := NIL;
    last_load_monitor_file := ^load_monitor_files;

    FOR file_number := 1 TO number_of_files DO
      clp$get_value ('VIRTUAL_IMAGE', file_number, 1, clc$low, parameter, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF duplicate_load_file (parameter.file.local_file_name, load_monitor_files) OR duplicate_load_file
            (parameter.file.local_file_name, build_options.load_files) THEN
        osp$set_status_abnormal ('OC', oce$e_duplicate_file_named, parameter.file.local_file_name, status);
        RETURN;
      IFEND;

      NEXT last_load_monitor_file^.link IN ocv$rmb_scratch_seq;
      last_load_monitor_file := last_load_monitor_file^.link;
      IF last_load_monitor_file = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RCH1', status);
        RETURN;
      IFEND;

      last_load_monitor_file^.name := parameter.file.local_file_name;
      last_load_monitor_file^.address_space := occ$mtr;
    FOREND;
?? EJECT ??

    last_load_monitor_file^.link := NIL;

    last_load_monitor_file := ^build_options.load_files;
    WHILE last_load_monitor_file^.link <> NIL DO
      last_load_monitor_file := last_load_monitor_file^.link;
    WHILEND;
    last_load_monitor_file^.link := load_monitor_files.link;


    new_symbol_table_names.name := osc$null_name;
    new_symbol_table_names.link := NIL;
    last_new_symbol_table_name := ^new_symbol_table_names;


    clp$get_set_count ('SYMBOL_TABLE', number_of_files, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR file_number := 1 TO number_of_files DO
      clp$get_value ('SYMBOL_TABLE', file_number, 1, clc$low, parameter, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF duplicate_symbol_table_file (parameter.file.local_file_name, build_options.monitor_symbol_tables) OR
            duplicate_symbol_table_file (parameter.file.local_file_name, new_symbol_table_names) THEN
        osp$set_status_abnormal ('OC', oce$e_duplicate_file_named, parameter.file.local_file_name, status);
        RETURN;
      IFEND;

      NEXT last_new_symbol_table_name^.link IN ocv$rmb_scratch_seq;
      last_new_symbol_table_name := last_new_symbol_table_name^.link;
      IF last_new_symbol_table_name = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RCH1', status);
        RETURN;
      IFEND;

      last_new_symbol_table_name^.name := parameter.file.local_file_name;
    FOREND;

    last_new_symbol_table_name^.link := NIL;

    last_new_symbol_table_name := ^build_options.monitor_symbol_tables;
    WHILE last_new_symbol_table_name^.link <> NIL DO
      last_new_symbol_table_name := last_new_symbol_table_name^.link;
    WHILEND;
    last_new_symbol_table_name^.link := new_symbol_table_names.link;


  PROCEND ocp$load_monitor;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$LOAD_JOB', EJECT ??

  PROCEDURE ocp$load_job (parameter_list: clt$parameter_list;
    VAR status: ost$status);




{ pdt load_job_pdt (
{   virtual_image, virtual_images, vi: list of file = $required
{   symbol_table, symbol_tables, st: list of file
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      load_job_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^load_job_pdt_names,
        ^load_job_pdt_params];

    VAR
      load_job_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
        clt$parameter_name_descriptor := [['VIRTUAL_IMAGE', 1], ['VIRTUAL_IMAGES', 1], ['VI', 1], [
        'SYMBOL_TABLE', 2], ['SYMBOL_TABLES', 2], ['ST', 2], ['STATUS', 3]];

    VAR
      load_job_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ VIRTUAL_IMAGE VIRTUAL_IMAGES VI }
      [[clc$required], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ SYMBOL_TABLE SYMBOL_TABLES ST }
      [[clc$optional], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??
?? EJECT ??

    VAR
      parameter: clt$value,

      load_job_files: oct$load_file_list,
      last_load_job_file: ^oct$load_file_list,

      new_symbol_table_names: oct$symbol_table_list,
      last_new_symbol_table_name: ^oct$symbol_table_list,

      number_of_files: 0 .. clc$max_value_sets,
      file_number: 0 .. clc$max_value_sets;



    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, load_job_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    clp$get_set_count ('VIRTUAL_IMAGE', number_of_files, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    load_job_files.name := osc$null_name;
    load_job_files.link := NIL;
    last_load_job_file := ^load_job_files;

    FOR file_number := 1 TO number_of_files DO
      clp$get_value ('VIRTUAL_IMAGE', file_number, 1, clc$low, parameter, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF duplicate_load_file (parameter.file.local_file_name, load_job_files) OR duplicate_load_file
            (parameter.file.local_file_name, build_options.load_files) THEN
        osp$set_status_abnormal ('OC', oce$e_duplicate_file_named, parameter.file.local_file_name, status);
        RETURN;
      IFEND;

      NEXT last_load_job_file^.link IN ocv$rmb_scratch_seq;
      last_load_job_file := last_load_job_file^.link;
      IF last_load_job_file = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RCH2', status);
        RETURN;
      IFEND;

      last_load_job_file^.name := parameter.file.local_file_name;
      last_load_job_file^.address_space := occ$job;
    FOREND;
?? EJECT ??

    last_load_job_file^.link := NIL;

    last_load_job_file := ^build_options.load_files;
    WHILE last_load_job_file^.link <> NIL DO
      last_load_job_file := last_load_job_file^.link;
    WHILEND;
    last_load_job_file^.link := load_job_files.link;

    new_symbol_table_names.name := osc$null_name;
    new_symbol_table_names.link := NIL;
    last_new_symbol_table_name := ^new_symbol_table_names;

    clp$get_set_count ('SYMBOL_TABLE', number_of_files, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR file_number := 1 TO number_of_files DO
      clp$get_value ('SYMBOL_TABLE', file_number, 1, clc$low, parameter, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF duplicate_symbol_table_file (parameter.file.local_file_name, build_options.job_symbol_tables) OR
            duplicate_symbol_table_file (parameter.file.local_file_name, new_symbol_table_names) THEN
        osp$set_status_abnormal ('OC', oce$e_duplicate_file_named, parameter.file.local_file_name, status);
        RETURN;
      IFEND;

      NEXT last_new_symbol_table_name^.link IN ocv$rmb_scratch_seq;
      last_new_symbol_table_name := last_new_symbol_table_name^.link;
      IF last_new_symbol_table_name = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RCH1', status);
        RETURN;
      IFEND;

      last_new_symbol_table_name^.name := parameter.file.local_file_name;
    FOREND;

    last_new_symbol_table_name^.link := NIL;

    last_new_symbol_table_name := ^build_options.job_symbol_tables;
    WHILE last_new_symbol_table_name^.link <> NIL DO
      last_new_symbol_table_name := last_new_symbol_table_name^.link;
    WHILEND;
    last_new_symbol_table_name^.link := new_symbol_table_names.link;


  PROCEND ocp$load_job;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$DEFINE_SEGMENT', EJECT ??

  PROCEDURE ocp$define_segment (parameter_list: clt$parameter_list;
    VAR status: ost$status);



{ pdt define_segment_pdt (
{   address_space, as: key monitor, m, job, j, both = $required
{   segment_identifier, si: name = $required
{   segment_number, sn: integer 0 .. osc$maximum_segment = $required
{   real_address, ra: integer 0 .. 0ffffffff(16)
{   length, l: integer 0 .. osc$max_segment_length = $required
{   attribute, attributes, a: list of key rd, rk, bi, wt, wk, ex, lp, gp, ...
{     cb, wr, sh, fx, st, rt, fb, na = $required
{   ring_brackets, rb: list 2..2 1..1 of integer osc$min_ring .. osc$max_ring = $required
{   active_segment_id, asid: integer 0 .. 0ffff(16)
{   global_local_key, glk: list 2..2 1..1 of integer 0..3f(16) = (0,0)
{   contiguous_memory_required, cmr: boolean = false
{   status, st)

?? PUSH (LISTEXT := ON) ??

    VAR
      define_segment_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^define_segment_pdt_names, ^define_segment_pdt_params];

    VAR
      define_segment_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 23] of
        clt$parameter_name_descriptor := [['ADDRESS_SPACE', 1], ['AS', 1], ['SEGMENT_IDENTIFIER', 2], ['SI',
        2], ['SEGMENT_NUMBER', 3], ['SN', 3], ['REAL_ADDRESS', 4], ['RA', 4], ['LENGTH', 5], ['L', 5], [
        'ATTRIBUTE', 6], ['ATTRIBUTES', 6], ['A', 6], ['RING_BRACKETS', 7], ['RB', 7], ['ACTIVE_SEGMENT_ID',
        8], ['ASID', 8], ['GLOBAL_LOCAL_KEY', 9], ['GLK', 9], ['CONTIGUOUS_MEMORY_REQUIRED', 10], ['CMR', 10],
        ['STATUS', 11], ['ST', 11]];

    VAR
      define_segment_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 11] of
        clt$parameter_descriptor := [

{ ADDRESS_SPACE AS }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^define_segment_pdt_kv1, clc$keyword_value]],

{ SEGMENT_IDENTIFIER SI }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ SEGMENT_NUMBER SN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0,
        osc$maximum_segment]],

{ REAL_ADDRESS RA }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffffff(16)]],

{ LENGTH L }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0,
        osc$max_segment_length]],

{ ATTRIBUTE ATTRIBUTES A }
      [[clc$required], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed, [^define_segment_pdt_kv6,
        clc$keyword_value]],

{ RING_BRACKETS RB }
      [[clc$required], 2, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, osc$min_ring,
        osc$max_ring]],

{ ACTIVE_SEGMENT_ID ASID }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffff(16)]],

{ GLOBAL_LOCAL_KEY GLK }
      [[clc$optional_with_default, ^define_segment_pdt_dv9], 2, 2, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$integer_value, 0, 3f(16)]],

{ CONTIGUOUS_MEMORY_REQUIRED CMR }
      [[clc$optional_with_default, ^define_segment_pdt_dv10], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$boolean_value]],

{ STATUS ST }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      define_segment_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of ost$name := [
        'MONITOR', 'M', 'JOB', 'J', 'BOTH'];

    VAR
      define_segment_pdt_kv6: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 16] of ost$name := ['RD',
        'RK', 'BI', 'WT', 'WK', 'EX', 'LP', 'GP', 'CB', 'WR', 'SH', 'FX', 'ST', 'RT', 'FB', 'NA'];

    VAR
      define_segment_pdt_dv9: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := '(0,0)';

    VAR
      define_segment_pdt_dv10: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';

?? POP ??
?? EJECT ??

    VAR
      parameter: clt$value,
      address_specified: boolean,
      define_segment: ^oct$define_command_list,
      last_define_segment: ^oct$define_command_list;





    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, define_segment_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT define_segment IN ocv$rmb_scratch_seq;
    IF define_segment = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RCH3', status);
      RETURN;
    IFEND;

    define_segment^.link := NIL;
    define_segment^.parameters := $oct$parameters [];


    crack_address_space_parameter ('ADDRESS_SPACE', define_segment^.address_space, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('SEGMENT_IDENTIFIER', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter.kind = clc$unknown_value THEN
      define_segment^.segment_id := osc$null_name;
    ELSE
      define_segment^.segment_id := parameter.name.value;
    IFEND;


?? EJECT ??
    crack_segment_number_parameter ('SEGMENT_NUMBER', define_segment^.segment_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$test_parameter ('REAL_ADDRESS', address_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF address_specified THEN
      crack_address_parameter ('REAL_ADDRESS', define_segment^.address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSEIF define_segment^.segment_id <> 'PAGE_TABLE' THEN
      osp$set_status_abnormal ('OC', cle$required_parameter_omitted, 'REAL_ADDRESS', status);
      RETURN;
    IFEND;




    crack_length_parameter ('LENGTH', define_segment^.length, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_segment_attributes_param ('ATTRIBUTES', define_segment^.hardware_attributes, define_segment^.
          software_attributes, define_segment^.parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    crack_ring_brackets_parameter ('RING_BRACKETS', define_segment^.r1, define_segment^.r2, define_segment^.
          parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    crack_active_segment_id_param ('ACTIVE_SEGMENT_ID', define_segment^.active_segment_id, define_segment^.
          parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_key_lock_parameter ('GLOBAL_LOCAL_KEY', define_segment^.key_lock, define_segment^.parameters,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('CONTIGUOUS_MEMORY_REQUIRED', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    define_segment^.contiguous_space := parameter.bool.value;

    last_define_segment := ^build_options.define_commands;
    WHILE last_define_segment^.link <> NIL DO
      last_define_segment := last_define_segment^.link;
    WHILEND;

    last_define_segment^.link := define_segment;


    IF define_segment^.segment_id = 'PAGE_TABLE' THEN
      IF address_specified THEN
        build_options.page_table_address := define_segment^.address;
      ELSE
        define_segment^.address := build_options.page_table_address;
      IFEND;
    IFEND;


    rmb_generator_not_executed := TRUE;


  PROCEND ocp$define_segment;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$CHANGE_SEGMENT', EJECT ??

  PROCEDURE ocp$change_segment (parameter_list: clt$parameter_list;
    VAR status: ost$status);




{ pdt change_segment_pdt (
{   address_space, as: key monitor, m, job, j, both = $required
{   segment_number, sn: integer 0 .. osc$maximum_segment = $required
{   attribute, attributes, a: list of key rd, rk, bi, wt, wk, ex, lp, gp, ...
{     cb, wr, sh, fx, st, rt, fb, na
{   ring_brackets, rb: list 2..2 1..1 of integer osc$min_ring .. osc$max_ring
{   active_segment_id, asid: integer 0 .. 0ffff(16)
{   global_local_key, glk: list 2..2 1..1 of integer 0..3f(16)
{   status, st)

?? PUSH (LISTEXT := ON) ??

    VAR
      change_segment_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^change_segment_pdt_names, ^change_segment_pdt_params];

    VAR
      change_segment_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 15] of
        clt$parameter_name_descriptor := [['ADDRESS_SPACE', 1], ['AS', 1], ['SEGMENT_NUMBER', 2], ['SN', 2],
        ['ATTRIBUTE', 3], ['ATTRIBUTES', 3], ['A', 3], ['RING_BRACKETS', 4], ['RB', 4], ['ACTIVE_SEGMENT_ID',
        5], ['ASID', 5], ['GLOBAL_LOCAL_KEY', 6], ['GLK', 6], ['STATUS', 7], ['ST', 7]];

    VAR
      change_segment_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 7] of clt$parameter_descriptor
        := [

{ ADDRESS_SPACE AS }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^change_segment_pdt_kv1, clc$keyword_value]],

{ SEGMENT_NUMBER SN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0,
        osc$maximum_segment]],

{ ATTRIBUTE ATTRIBUTES A }
      [[clc$optional], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed, [^change_segment_pdt_kv3,
        clc$keyword_value]],

{ RING_BRACKETS RB }
      [[clc$optional], 2, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, osc$min_ring,
        osc$max_ring]],

{ ACTIVE_SEGMENT_ID ASID }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffff(16)]],

{ GLOBAL_LOCAL_KEY GLK }
      [[clc$optional], 2, 2, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 3f(16)]],

{ STATUS ST }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      change_segment_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of ost$name := [
        'MONITOR', 'M', 'JOB', 'J', 'BOTH'];

    VAR
      change_segment_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 16] of ost$name := ['RD',
        'RK', 'BI', 'WT', 'WK', 'EX', 'LP', 'GP', 'CB', 'WR', 'SH', 'FX', 'ST', 'RT', 'FB', 'NA'];

?? POP ??
?? EJECT ??

    VAR
      parameter: clt$value,
      segment_command: ^oct$segment_command_list,
      duplicate_segment_command: ^oct$segment_command_list,
      last_segment_command: ^oct$segment_command_list;





    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, change_segment_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT segment_command IN ocv$rmb_scratch_seq;
    IF segment_command = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RCH4', status);
      RETURN;
    IFEND;

    segment_command^.link := NIL;
    segment_command^.parameters := $oct$parameters [];
    segment_command^.kind := occ$change;


    crack_address_space_parameter ('ADDRESS_SPACE', segment_command^.address_space, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    crack_segment_number_parameter ('SEGMENT_NUMBER', segment_command^.segment_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    crack_segment_attributes_param ('ATTRIBUTES', segment_command^.hardware_attributes, segment_command^.
          software_attributes, segment_command^.parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    crack_ring_brackets_parameter ('RING_BRACKETS', segment_command^.r1, segment_command^.r2,
          segment_command^.parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
?? EJECT ??

    crack_active_segment_id_param ('ACTIVE_SEGMENT_ID', segment_command^.active_segment_id, segment_command^.
          parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_key_lock_parameter ('GLOBAL_LOCAL_KEY', segment_command^.key_lock, segment_command^.parameters,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    last_segment_command := ^build_options.segment_commands;
    WHILE last_segment_command^.link <> NIL DO
      last_segment_command := last_segment_command^.link;
    WHILEND;

    IF segment_command^.address_space = occ$both THEN
      NEXT duplicate_segment_command IN ocv$rmb_scratch_seq;
      IF duplicate_segment_command = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RCH9', status);
        RETURN;
      IFEND;

      duplicate_segment_command^ := segment_command^;
      duplicate_segment_command^.address_space := occ$mtr;

      last_segment_command^.link := duplicate_segment_command;
      last_segment_command := last_segment_command^.link;

      segment_command^.address_space := occ$job;
    IFEND;

    last_segment_command^.link := segment_command;

    rmb_generator_not_executed := TRUE;


  PROCEND ocp$change_segment;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$SHARE_SEGMENT', EJECT ??

  PROCEDURE ocp$share_segment (parameter_list: clt$parameter_list;
    VAR status: ost$status);




{ pdt share_segment_pdt (
{   address_space, as: key monitor, m, job, j = $required
{   segment_number, sn: integer 0 .. osc$maximum_segment = $required
{   new_address_space, nas: key monitor, m, job, j = $required
{   new_segment_number, nsn: integer 0 .. osc$maximum_segment = $required
{   status, st)

?? PUSH (LISTEXT := ON) ??

    VAR
      share_segment_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^share_segment_pdt_names,
        ^share_segment_pdt_params];

    VAR
      share_segment_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 10] of
        clt$parameter_name_descriptor := [['ADDRESS_SPACE', 1], ['AS', 1], ['SEGMENT_NUMBER', 2], ['SN', 2],
        ['NEW_ADDRESS_SPACE', 3], ['NAS', 3], ['NEW_SEGMENT_NUMBER', 4], ['NSN', 4], ['STATUS', 5], ['ST',
        5]];

    VAR
      share_segment_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of clt$parameter_descriptor
        := [

{ ADDRESS_SPACE AS }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^share_segment_pdt_kv1, clc$keyword_value]],

{ SEGMENT_NUMBER SN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0,
        osc$maximum_segment]],

{ NEW_ADDRESS_SPACE NAS }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^share_segment_pdt_kv3, clc$keyword_value]],

{ NEW_SEGMENT_NUMBER NSN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0,
        osc$maximum_segment]],

{ STATUS ST }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      share_segment_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := [
        'MONITOR', 'M', 'JOB', 'J'];

    VAR
      share_segment_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := [
        'MONITOR', 'M', 'JOB', 'J'];

?? POP ??
?? EJECT ??

    VAR
      parameter: clt$value,
      segment_command: ^oct$segment_command_list,
      last_segment_command: ^oct$segment_command_list;



    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, share_segment_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT segment_command IN ocv$rmb_scratch_seq;
    IF segment_command = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RCH5', status);
      RETURN;
    IFEND;

    segment_command^.link := NIL;
    segment_command^.kind := occ$share;


    crack_address_space_parameter ('ADDRESS_SPACE', segment_command^.address_space, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_segment_number_parameter ('SEGMENT_NUMBER', segment_command^.segment_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_address_space_parameter ('NEW_ADDRESS_SPACE', segment_command^.new_address_space, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_segment_number_parameter ('NEW_SEGMENT_NUMBER', segment_command^.new_segment_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    last_segment_command := ^build_options.segment_commands;
    WHILE last_segment_command^.link <> NIL DO
      last_segment_command := last_segment_command^.link;
    WHILEND;
    last_segment_command^.link := segment_command;

    rmb_generator_not_executed := TRUE;

  PROCEND ocp$share_segment;
?? OLDTITLE ??
?? NEWTITLE := '    OCP$EXTEND_SEGMENT', EJECT ??

  PROCEDURE ocp$extend_segment (parameter_list: clt$parameter_list;
    VAR status: ost$status);




{ pdt extend_segment_pdt (
{   address_space, as: key monitor, m, job, j = $required
{   segment_number, sn: integer 0 .. osc$maximum_segment = $required
{   length, l: integer 0 .. osc$max_segment_length = $required
{   status, st)

?? PUSH (LISTEXT := ON) ??

    VAR
      extend_segment_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^extend_segment_pdt_names, ^extend_segment_pdt_params];

    VAR
      extend_segment_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 8] of
        clt$parameter_name_descriptor := [['ADDRESS_SPACE', 1], ['AS', 1], ['SEGMENT_NUMBER', 2], ['SN', 2],
        ['LENGTH', 3], ['L', 3], ['STATUS', 4], ['ST', 4]];

    VAR
      extend_segment_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor
        := [

{ ADDRESS_SPACE AS }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^extend_segment_pdt_kv1, clc$keyword_value]],

{ SEGMENT_NUMBER SN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0,
        osc$maximum_segment]],

{ LENGTH L }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0,
        osc$max_segment_length]],

{ STATUS ST }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      extend_segment_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := [
        'MONITOR', 'M', 'JOB', 'J'];

?? POP ??
?? EJECT ??

    VAR
      parameter: clt$value,
      segment_command: ^oct$segment_command_list,
      last_segment_command: ^oct$segment_command_list;





    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, extend_segment_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT segment_command IN ocv$rmb_scratch_seq;
    IF segment_command = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RCH6', status);
      RETURN;
    IFEND;

    segment_command^.link := NIL;
    segment_command^.kind := occ$extend;


    crack_address_space_parameter ('ADDRESS_SPACE', segment_command^.address_space, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    crack_segment_number_parameter ('SEGMENT_NUMBER', segment_command^.segment_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    crack_length_parameter ('LENGTH', segment_command^.extend_length, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    last_segment_command := ^build_options.segment_commands;
    WHILE last_segment_command^.link <> NIL DO
      last_segment_command := last_segment_command^.link;
    WHILEND;

    last_segment_command^.link := segment_command;

    rmb_generator_not_executed := TRUE;

  PROCEND ocp$extend_segment;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$DISPLAY_MEMORY', EJECT ??

  PROCEDURE ocp$display_memory (parameter_list: clt$parameter_list;
    VAR status: ost$status);




{ pdt display_memory_pdt (
{   memory, m: key all, page_table, pt, memory_map, mm, monitor_exchange_package, mep ...
{   job_exchange_package, jep = $required
{   output, o: file
{   status, st)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_memory_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^display_memory_pdt_names, ^display_memory_pdt_params];

    VAR
      display_memory_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
        clt$parameter_name_descriptor := [['MEMORY', 1], ['M', 1], ['OUTPUT', 2], ['O', 2], ['STATUS', 3],
        ['ST', 3]];

    VAR
      display_memory_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor
        := [

{ MEMORY M }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^display_memory_pdt_kv1, clc$keyword_value]],

{ OUTPUT O }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS ST }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      display_memory_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 9] of ost$name := ['ALL',
        'PAGE_TABLE', 'PT', 'MEMORY_MAP', 'MM', 'MONITOR_EXCHANGE_PACKAGE', 'MEP', 'JOB_EXCHANGE_PACKAGE',
        'JEP'];

?? POP ??
?? EJECT ??

    VAR
      parameter: clt$value,
      memory_command: ^oct$memory_command_list,
      last_memory_command: ^oct$memory_command_list;


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_memory_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT memory_command IN ocv$rmb_scratch_seq;
    IF memory_command = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RCH7', status);
      RETURN;
    IFEND;

    memory_command^.file_name_specified := FALSE;
    memory_command^.link := NIL;
    memory_command^.kind := occ$display_memory;

    clp$get_value ('MEMORY', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter.name.value = 'ALL' THEN
      memory_command^.memory := occ$all;
    ELSEIF (parameter.name.value = 'MEMORY_MAP') OR (parameter.name.value = 'MM') THEN
      memory_command^.memory := occ$memory_map;
    ELSEIF (parameter.name.value = 'PAGE_TABLE') OR (parameter.name.value = 'PT') THEN
      memory_command^.memory := occ$page_table;
    ELSEIF (parameter.name.value = 'MONITOR_EXCHANGE_PACKAGE') OR (parameter.name.value = 'MEP') THEN
      memory_command^.memory := occ$mps;
    ELSE
      memory_command^.memory := occ$jps;
    IFEND;
?? EJECT ??

    clp$get_value ('OUTPUT', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter.kind <> clc$unknown_value THEN
      memory_command^.file_name_specified := TRUE;
      memory_command^.output := parameter.file;
    IFEND;

    last_memory_command := ^build_options.memory_commands;
    WHILE last_memory_command^.link <> NIL DO
      last_memory_command := last_memory_command^.link;
    WHILEND;
    last_memory_command^.link := memory_command;

    rmb_generator_not_executed := TRUE;

  PROCEND ocp$display_memory;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$DISPLAY_MEMORY_ADDRESS', EJECT ??

  PROCEDURE ocp$display_memory_address (parameter_list: clt$parameter_list;
    VAR status: ost$status);




{ pdt display_mem_addr_pdt (
{   real_address, ra: integer 0 .. 0ffffffff(16) = $required
{   length, l: integer 1 .. osc$max_segment_length = $required
{   output, o: file
{   status, st)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_mem_addr_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^display_mem_addr_pdt_names, ^display_mem_addr_pdt_params];

    VAR
      display_mem_addr_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 8] of
        clt$parameter_name_descriptor := [['REAL_ADDRESS', 1], ['RA', 1], ['LENGTH', 2], ['L', 2], ['OUTPUT',
        3], ['O', 3], ['STATUS', 4], ['ST', 4]];

    VAR
      display_mem_addr_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
        clt$parameter_descriptor := [

{ REAL_ADDRESS RA }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 0ffffffff(16)]],

{ LENGTH L }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 1,
        osc$max_segment_length]],

{ OUTPUT O }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS ST }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??
?? EJECT ??

    VAR
      parameter: clt$value,
      memory_command: ^oct$memory_command_list,
      last_memory_command: ^oct$memory_command_list;



    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_mem_addr_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT memory_command IN ocv$rmb_scratch_seq;
    IF memory_command = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'RCH8', status);
      RETURN;
    IFEND;

    memory_command^.file_name_specified := FALSE;
    memory_command^.link := NIL;
    memory_command^.kind := occ$display_memory_address;


    crack_address_parameter ('REAL_ADDRESS', memory_command^.display_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    clp$get_value ('LENGTH', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    memory_command^.length := parameter.int.value;
?? EJECT ??

    clp$get_value ('OUTPUT', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter.kind <> clc$unknown_value THEN
      memory_command^.file_name_specified := TRUE;
      memory_command^.output := parameter.file;
    IFEND;

    last_memory_command := ^build_options.memory_commands;
    WHILE last_memory_command^.link <> NIL DO
      last_memory_command := last_memory_command^.link;
    WHILEND;
    last_memory_command^.link := memory_command;

    rmb_generator_not_executed := TRUE;

  PROCEND ocp$display_memory_address;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$RMB_GENERATE', EJECT ??

  PROCEDURE ocp$rmb_generate (parameter_list: clt$parameter_list;
    VAR status: ost$status);





{ pdt generate_pdt (
{   real_memory_image, rmi: file = $required
{   status, st)

?? PUSH (LISTEXT := ON) ??

    VAR
      generate_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^generate_pdt_names,
        ^generate_pdt_params];

    VAR
      generate_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
        clt$parameter_name_descriptor := [['REAL_MEMORY_IMAGE', 1], ['RMI', 1], ['STATUS', 2], ['ST', 2]];

    VAR
      generate_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ REAL_MEMORY_IMAGE RMI }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS ST }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??




    VAR
      parameter: clt$value;




    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, generate_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('REAL_MEMORY_IMAGE', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$generate_real_memory (build_options, parameter.file.local_file_name, status);

    IF status.condition <> oce$e_generate_status THEN
      reset_memory_builder_parameters;
    IFEND;

  PROCEND ocp$rmb_generate;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$QUIT', EJECT ??

  PROCEDURE ocp$quit (parameter_list: clt$parameter_list;
    VAR status: ost$status);





{ pdt quit_pdt ()

?? PUSH (LISTEXT := ON) ??

    VAR
      quit_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??




    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, quit_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    clp$end_scan_command_file (rmb_utility_name, status);

  PROCEND ocp$quit;
?? OLDTITLE ??
?? NEWTITLE := '  OCP$BUILDRM', EJECT ??

  PROCEDURE [XDCL, #GATE] ocp$build_real_memory (parameter_list: clt$parameter_list;
    VAR status: ost$status);




{ pdt build_real_memory_pdt (
{   status, st)

?? PUSH (LISTEXT := ON) ??

    VAR
      build_real_memory_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^build_real_memory_pdt_names, ^build_real_memory_pdt_params];

    VAR
      build_real_memory_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of
        clt$parameter_name_descriptor := [['STATUS', 1], ['ST', 1]];

    VAR
      build_real_memory_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
        clt$parameter_descriptor := [

{ STATUS ST }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??
?? EJECT ??
{ table rmb_command_list t=c s=local
{   command (set_build_options              ,set_build_option,  setbo) ocp$set_build_options cm=local
{   command (define_segment                 ,defs) ocp$define_segment cm=local
{   command (load_monitor                   ,loam) ocp$load_monitor cm=local
{   command (load_job                       ,loaj) ocp$load_job cm=local
{   command (change_segment                 ,chas) ocp$change_segment cm=local
{   command (share_segment                  ,shas) ocp$share_segment cm=local
{   command (extend_segment                 ,exts) ocp$extend_segment cm=local
{   command (display_memory                 ,dism) ocp$display_memory cm=local
{   command (display_memory_address         ,disma) ocp$display_memory_address cm=local
{   command (generate_real_memory           ,genrm) ocp$rmb_generate cm=local
{   command (quit                           ,qui) ocp$quit cm=local
{ tablend
?? PUSH (LISTEXT := ON) ??

VAR
  rmb_command_list: [STATIC, READ] ^clt$command_table :=
      ^rmb_command_list_entries,

  rmb_command_list_entries: [STATIC, READ] array [1 .. 23] of
      clt$command_table_entry := [
  {} ['CHANGE_SEGMENT                 ', clc$nominal_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^ocp$change_segment],
  {} ['CHAS                           ', clc$abbreviation_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^ocp$change_segment],
  {} ['DEFINE_SEGMENT                 ', clc$nominal_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^ocp$define_segment],
  {} ['DEFS                           ', clc$abbreviation_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^ocp$define_segment],
  {} ['DISM                           ', clc$abbreviation_entry, clc$advertised_entry, 8,
        clc$automatically_log, clc$linked_call, ^ocp$display_memory],
  {} ['DISMA                          ', clc$abbreviation_entry, clc$advertised_entry, 9,
        clc$automatically_log, clc$linked_call, ^ocp$display_memory_address],
  {} ['DISPLAY_MEMORY                 ', clc$nominal_entry, clc$advertised_entry, 8,
        clc$automatically_log, clc$linked_call, ^ocp$display_memory],
  {} ['DISPLAY_MEMORY_ADDRESS        ', clc$nominal_entry, clc$advertised_entry, 9,
        clc$automatically_log, clc$linked_call, ^ocp$display_memory_address],
  {} ['EXTEND_SEGMENT                 ', clc$nominal_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^ocp$extend_segment],
  {} ['EXTS                           ', clc$abbreviation_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^ocp$extend_segment],
  {} ['GENERATE_REAL_MEMORY           ', clc$nominal_entry, clc$advertised_entry, 10,
        clc$automatically_log, clc$linked_call, ^ocp$rmb_generate],
  {} ['GENRM                          ', clc$abbreviation_entry, clc$advertised_entry, 10,
        clc$automatically_log, clc$linked_call, ^ocp$rmb_generate],
  {} ['LOAD_JOB                       ', clc$nominal_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^ocp$load_job],
  {} ['LOAD_MONITOR                   ', clc$nominal_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^ocp$load_monitor],
  {} ['LOAJ                           ', clc$abbreviation_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^ocp$load_job],
  {} ['LOAM                           ', clc$abbreviation_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^ocp$load_monitor],
  {} ['QUI                            ', clc$abbreviation_entry, clc$advertised_entry, 11,
        clc$automatically_log, clc$linked_call, ^ocp$quit],
  {} ['QUIT                           ', clc$nominal_entry, clc$advertised_entry, 11,
        clc$automatically_log, clc$linked_call, ^ocp$quit],
  {} ['SETBO                          ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^ocp$set_build_options],
  {} ['SET_BUILD_OPTION               ', clc$alias_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^ocp$set_build_options],
  {} ['SET_BUILD_OPTIONS              ', clc$nominal_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^ocp$set_build_options],
  {} ['SHARE_SEGMENT                  ', clc$nominal_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^ocp$share_segment],
  {} ['SHAS                           ', clc$abbreviation_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^ocp$share_segment]];
?? POP ??
?? EJECT ??

    VAR
      parameter: clt$value,
      segment_pointer: amt$segment_pointer;


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, build_real_memory_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    ocp$create_transient_segment (amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    ocv$rmb_scratch_seq := segment_pointer.sequence_pointer;

    reset_memory_builder_parameters;


    clp$push_utility (rmb_utility_name, clc$global_command_search, rmb_command_list, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    clp$scan_command_file (command_file, rmb_utility_name, rmb_prompt_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

?? EJECT ??

    clp$pop_utility (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    IF rmb_generator_not_executed THEN
      osp$set_status_abnormal ('OC', oce$w_real_memory_not_generated, '', status);
    IFEND;


  PROCEND ocp$build_real_memory;

MODEND ocm$rmb_command_handlers;
*DECK DECK=OCM$SATISFY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Object Library Generator' ??
MODULE ocm$satisfy;

{ PURPOSE:
{   To include modules in the output
{   library based on external
{   reference searching of the
{   specified libraries.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc occ$retain
*copyc oce$library_generator_errors
*copyc oct$module_description
*copyc oct$nlm_modification_list
*copyc oct$open_file_list
*copyc ost$status
?? POP ??
*copyc clp$evaluate_parameters
*copyc ocp$add_additions_to_nlm_list
*copyc ocp$add_an_nlm
*copyc ocp$close_all_open_files
*copyc ocp$create_an_nlm
*copyc ocp$delete_an_nlm
*copyc ocp$generate_message
*copyc ocp$initialize_olg_working_heap
*copyc ocp$obtain_object_file
*copyc ocp$obtain_xdcl_list
*copyc ocp$obtain_xref_list
*copyc ocp$search_modification_list
*copyc ocp$search_nlm_tree
*copyc osp$set_status_abnormal
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc ocv$nlm_list
*copyc ocv$olg_scratch_seq
*copyc ocv$open_file_list
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    oct$external_tree = record
      name: pmt$program_name,
      module_description: ^oct$module_description,
      l_link: ^oct$external_tree,
      r_link: ^oct$external_tree
    recend,

    tree_function = (add, delete, search);

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$_satisfy_external_reference' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$_satisfy_external_reference
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to handle the terminate break and
{   block exit conditions.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN

{ Ignore the condition.

        RETURN;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        ocp$close_all_open_files (ocv$open_file_list);
        ocp$initialize_olg_working_heap;
        RESET ocv$olg_scratch_seq;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'process_externals' ??
?? EJECT ??

    PROCEDURE process_externals
      (    process: tree_function;
           name: pmt$program_name;
       VAR module_description: ^oct$module_description;
       VAR tree: oct$external_tree;
       VAR external_found: boolean;
       VAR status: ost$status);

      VAR
        current_entry: ^oct$external_tree,
        previous_entry: ^oct$external_tree,
        external_tree_entry: ^oct$external_tree,
        next_entry: ^oct$external_tree;



      previous_entry := ^tree;
      current_entry := tree.r_link;

      WHILE (current_entry <> NIL) AND (current_entry^.name <> name) DO
        previous_entry := current_entry;

        IF name < current_entry^.name THEN
          current_entry := current_entry^.l_link;
        ELSE
          current_entry := current_entry^.r_link;
        IFEND;
      WHILEND;

      IF current_entry = NIL THEN
        external_found := FALSE;

        IF process = add THEN
          NEXT external_tree_entry IN ocv$olg_scratch_seq;
          IF external_tree_entry = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_internal_olg_seg_overflow, '', status);
            RETURN;
          IFEND;

          external_tree_entry^.name := name;
          external_tree_entry^.module_description := module_description;
          external_tree_entry^.l_link := NIL;
          external_tree_entry^.r_link := NIL;

          IF name < previous_entry^.name THEN
            previous_entry^.l_link := external_tree_entry;
          ELSE
            previous_entry^.r_link := external_tree_entry;
          IFEND;
        IFEND;
?? EJECT ??
      ELSE
        external_found := TRUE;
        module_description := current_entry^.module_description;

        IF process = delete THEN
          IF current_entry^.name < previous_entry^.name THEN
            IF (current_entry^.l_link = NIL) OR (current_entry^.r_link = NIL) THEN
              IF (current_entry^.l_link = NIL) AND (current_entry^.r_link = NIL) THEN
                previous_entry^.l_link := NIL;
              ELSE
                IF current_entry^.l_link = NIL THEN
                  previous_entry^.l_link := current_entry^.r_link;
                ELSE
                  previous_entry^.l_link := current_entry^.l_link;
                IFEND;
              IFEND;
            ELSE
              next_entry := current_entry^.l_link;

              WHILE next_entry^.r_link <> NIL DO
                next_entry := next_entry^.r_link;
              WHILEND;

              next_entry^.r_link := current_entry^.r_link;
              previous_entry^.l_link := current_entry^.l_link;
            IFEND;
          ELSE
            IF (current_entry^.l_link = NIL) OR (current_entry^.r_link = NIL) THEN
              IF (current_entry^.l_link = NIL) AND (current_entry^.r_link = NIL) THEN
                previous_entry^.r_link := NIL;
              ELSE
                IF current_entry^.l_link = NIL THEN
                  previous_entry^.r_link := current_entry^.r_link;
                ELSE
                  previous_entry^.r_link := current_entry^.l_link;
                IFEND;
              IFEND;
            ELSE
              next_entry := current_entry^.l_link;

              WHILE next_entry^.r_link <> NIL DO
                next_entry := next_entry^.r_link;
              WHILEND;

              next_entry^.r_link := current_entry^.r_link;
              previous_entry^.r_link := current_entry^.l_link;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

    PROCEND process_externals;
?? OLDTITLE ??
?? NEWTITLE := 'obtain_global_externals' ??
?? EJECT ??

    PROCEDURE obtain_global_externals
      (    parameter: clt$parameter_value;
       VAR global_externals: oct$external_tree;
       VAR status: ost$status);


      VAR
        external_found: boolean,
        file_descriptor: ^oct$open_file_list,
        entry_point: llt$entry_point_index,
        load_module_header: ^llt$load_module_header,
        module_description: ^oct$module_description,
        node: ^clt$data_value,
        file: ^SEQ ( * );


      global_externals.name := osc$null_name;
      global_externals.l_link := NIL;
      global_externals.r_link := NIL;

      node := parameter.value;
      WHILE node <> NIL DO
        ocp$obtain_object_file (node^.element_value^.file_value^, file_descriptor, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF file_descriptor^.kind <> occ$library THEN
          osp$set_status_abnormal ('OC', oce$e_object_file_must_be_lib, node^.element_value^.file_value^,
                status);
          RETURN;
        IFEND;

        IF (file_descriptor^.directory <> NIL) AND (file_descriptor^.entry_point_dictionary <> NIL) THEN
          file := file_descriptor^.directory^ [1].file;

          FOR entry_point := 1 TO UPPERBOUND (file_descriptor^.entry_point_dictionary^) DO
            IF file_descriptor^.entry_point_dictionary^ [entry_point].module_kind = llc$load_module THEN
              load_module_header := #PTR (file_descriptor^.entry_point_dictionary^ [entry_point].
                    module_header, file^);
              IF load_module_header = NIL THEN
                osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, file_descriptor^.name, status);
                RETURN;
              IFEND;

              module_description := ^file_descriptor^.directory^ [load_module_header^.module_index];

              process_externals (add, file_descriptor^.entry_point_dictionary^ [entry_point].name,
                    module_description, global_externals, external_found, status);

            IFEND;
          FOREND;
        IFEND;
        node := node^.link;
      WHILEND;

    PROCEND obtain_global_externals;
?? OLDTITLE ??
?? NEWTITLE := 'collect_externals' ??
?? EJECT ??

    PROCEDURE collect_externals
      (VAR nlm: ^oct$new_library_module_list;
       VAR unsatisfied_externals: oct$external_tree;
       VAR defined_externals: oct$external_tree;
       VAR status: ost$status);


      VAR
        deferred_entry_point_list: oct$external_declaration_list,
        xdcl_list: oct$external_declaration_list,
        xref_list: oct$external_reference_list,
        starting_procedure: pmt$program_name,

        x_dcl: ^oct$external_declaration_list,
        x_ref: ^oct$external_reference_list,
        external_found: boolean;


      unsatisfied_externals.name := osc$null_name;
      unsatisfied_externals.l_link := NIL;
      unsatisfied_externals.r_link := NIL;

      REPEAT
        nlm := nlm^.f_link;

        ocp$obtain_xdcl_list (nlm^.changed_info, occ$no_retain, {obtain_deferred_entry_points} FALSE,
              nlm^.description^, xdcl_list, starting_procedure, deferred_entry_point_list, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        x_dcl := xdcl_list.link;
        WHILE x_dcl <> NIL DO
          IF x_dcl^.name <> osc$null_name THEN
            process_externals (delete, x_dcl^.name, dummy, unsatisfied_externals, external_found, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            process_externals (add, x_dcl^.name, dummy, defined_externals, external_found, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

          x_dcl := x_dcl^.link;
        WHILEND;
?? EJECT ??

        ocp$obtain_xref_list (nlm^.description^, xref_list, occ$no_retain, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        x_ref := xref_list.link;
        WHILE x_ref <> NIL DO
          process_externals (search, x_ref^.name, dummy, defined_externals, external_found, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF NOT external_found THEN
            process_externals (add, x_ref^.name, dummy, unsatisfied_externals, external_found, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

          x_ref := x_ref^.link;
        WHILEND;
      UNTIL nlm^.f_link^.name = osc$null_name;


    PROCEND collect_externals;
?? OLDTITLE ??
?? NEWTITLE := 'satisfy_externals' ??
?? EJECT ??

    PROCEDURE satisfy_externals
      (    unsatisfied_externals: ^oct$external_tree;
       VAR global_externals: oct$external_tree;
           addition_list: ^oct$nlm_modification_list;
       VAR status: ost$status);


      VAR
        local_status: ost$status,

        addition_before: ^oct$nlm_modification_list,

        global_xdcl_list: ^oct$external_tree,

        load_module_header: ^llt$load_module_header,

        nlm: ^oct$new_library_module_list,
        nlm_before: ^oct$new_library_module_list,
        module_description: ^oct$module_description,
        module_found: boolean,
        external_found: boolean;


      IF unsatisfied_externals <> NIL THEN
        satisfy_externals (unsatisfied_externals^.l_link, global_externals, last_addition, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        process_externals (search, unsatisfied_externals^.name, module_description, global_externals,
              external_found, status);
        IF external_found THEN
          ocp$search_nlm_tree (module_description^.name, nlm_before, module_found);
          IF module_found THEN
            osp$set_status_abnormal ('OC', oce$e_module_already_on_library, module_description^.name, status);
            RETURN;
          IFEND;

          ocp$search_modification_list (module_description^.name, addition_list, addition_before,
                module_found);
          IF NOT module_found THEN
            NEXT addition_before^.link IN ocv$olg_scratch_seq;
            IF addition_before^.link = NIL THEN
              osp$set_status_abnormal ('OC', oce$e_internal_olg_seg_overflow, '', status);
              RETURN;
            IFEND;

            ocp$create_an_nlm (module_description, nlm, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            addition_before^.link^.nlm := nlm;
            addition_before^.link^.link := NIL;
          IFEND;
        IFEND;

        satisfy_externals (unsatisfied_externals^.r_link, global_externals, last_addition, status);
      IFEND;


    PROCEND satisfy_externals;
?? OLDTITLE ??

{ PROCEDURE (ocm$creol_sater) satisfy_external_reference, satisfy_external_re..
{ ferences, sater (
{   library, libraries, l: list of file = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 15, 11, 17, 22, 611],
    clc$command, 4, 2, 1, 0, 0, 0, 2, 'OCM$CREOL_SATER'], [
    ['L                              ',clc$abbreviation_entry, 1],
    ['LIBRARIES                      ',clc$alias_entry, 1],
    ['LIBRARY                        ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 19, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$library = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      last_addition: ^oct$nlm_modification_list,
      addition_list: oct$nlm_modification_list,
      ignore_status: ost$status,
      last_valid_nlm: ^oct$new_library_module_list,
      nlm: ^oct$new_library_module_list,
      dummy: [STATIC] ^oct$module_description := NIL,
      unsatisfied_externals: oct$external_tree,
      defined_externals: oct$external_tree,
      global_externals: oct$external_tree;



    VAR
      established_conditions: pmt$condition,
      established_descriptor: pmt$established_handler;




    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    established_conditions.selector := pmc$condition_combination;
    established_conditions.combination := $pmt$condition_combination
          [ifc$interactive_condition, pmc$block_exit_processing];

    pmp$establish_condition_handler (established_conditions, ^condition_handler, ^established_descriptor,
          status);

  /protect/
    BEGIN
      RESET ocv$olg_scratch_seq;

      obtain_global_externals (pvt [p$library], global_externals, status);
      IF NOT status.normal THEN
        EXIT /protect/;
      IFEND;

      defined_externals.name := osc$null_name;
      defined_externals.l_link := NIL;
      defined_externals.r_link := NIL;

      nlm := ocv$nlm_list;
      last_valid_nlm := ocv$nlm_list^.b_link;

      WHILE (nlm^.f_link^.name <> osc$null_name) AND (status.normal) DO
        collect_externals (nlm, unsatisfied_externals, defined_externals, status);
        IF status.normal THEN
          addition_list.link := NIL;
          last_addition := ^addition_list;

          satisfy_externals (unsatisfied_externals.r_link, global_externals, last_addition, status);
          IF status.normal THEN
            ocp$add_additions_to_nlm_list (ocv$nlm_list^.b_link, ^addition_list);
          IFEND;
        IFEND;
      WHILEND;

      IF NOT status.normal THEN
        WHILE last_valid_nlm^.f_link^.name <> osc$null_name DO
          nlm := last_valid_nlm^.f_link;
          ocp$delete_an_nlm (nlm);
        WHILEND;
      IFEND;
    END /protect/;
    pmp$disestablish_cond_handler (established_conditions, ignore_status);


  PROCEND ocp$_satisfy_external_reference;

MODEND ocm$satisfy;
*DECK DECK=OCM$SELECT_DISPLAY_LEVEL EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Object Library Generator' ??
MODULE ocm$select_display_level;

{ PURPOSE:
{   To alter the default level of display
{   information to be provided by the
{   SET_DISPLAY_OPTION command (formerly called SELECT_DISPLAY_LEVEL)
{   and to display the currently operative default selections.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oce$library_generator_errors
*copyc ost$status
?? POP ??
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc osp$set_status_abnormal
*copyc ocv$global_display_toggles
?? OLDTITLE ??
?? NEWTITLE := 'display_toggle_settings ' ??
?? EJECT ??

  PROCEDURE display_toggle_settings
    (    toggle_settings: oct$display_toggles;
     VAR status: ost$status);


    VAR
      pos: 1 .. 255,
      line: [STATIC] string (256) := '  display_options = (';


    pos := 23;

    IF occ$display_all IN toggle_settings THEN
      line (pos, 5) := 'ALL  ';
      pos := pos + 5;

    ELSEIF toggle_settings = $oct$display_toggles [] THEN
      line (pos, 6) := 'NONE  ';
      pos := pos + 6;

    ELSE
      IF occ$display_time_date IN toggle_settings THEN
        line (pos, 11) := 'DATE_TIME, ';
        pos := pos + 11;
      IFEND;

      IF occ$display_module_header IN toggle_settings THEN
        line (pos, 8) := 'HEADER, ';
        pos := pos + 8;
      IFEND;

      IF occ$display_component_info IN toggle_settings THEN
        line (pos, 11) := 'COMPONENT, ';
        pos := pos + 11;
      IFEND;

      IF occ$display_libraries IN toggle_settings THEN
        line (pos, 11) := 'LIBRARIES, ';
        pos := pos + 11;
      IFEND;

      IF occ$display_xdcls IN toggle_settings THEN
        line (pos, 13) := 'ENTRY_POINT, ';
        pos := pos + 13;
      IFEND;

      IF occ$display_xrefs IN toggle_settings THEN
        line (pos, 11) := 'REFERENCE, ';
        pos := pos + 11;
      IFEND;
    IFEND;

    line (pos - 2, 2) := ' )';

    osp$set_status_abnormal ('OC', oce$i_display_toggle, line (1, pos - 1), status);


  PROCEND display_toggle_settings;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$_set_display_option' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$_set_display_option
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$creol_setdo) set_display_option, set_display_options, setdo (
{   display_option, display_options, do: any of
{       key
{         all, none
{       keyend
{       list of key
{         (component, c)
{         (date_time, dt)
{         (entry_point, ep)
{         (header, h)
{         (libraries, library, l)
{         (reference, r)
{       keyend
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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 .. 2] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 13] of clt$keyword_specification,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 17, 18, 30, 21, 407],
    clc$command, 4, 2, 0, 0, 0, 0, 2, 'OCM$CREOL_SETDO'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 1],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 1],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 605,
  clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    504, [[1, 0, clc$list_type], [488, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [13], [
        ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['COMPONENT                      ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['DATE_TIME                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['DT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['H                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['HEADER                         ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['LIBRARIES                      ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['LIBRARY                        ', clc$alias_entry, clc$normal_usage_entry, 5],
        ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['REFERENCE                      ', clc$nominal_entry, clc$normal_usage_entry, 6]]
        ]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$display_option = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      node: ^clt$data_value,
      toggles: oct$display_toggles;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$display_option].specified THEN
      toggles := $oct$display_toggles [];
      IF pvt [p$display_option].value^.kind = clc$keyword THEN
        IF pvt [p$display_option].value^.keyword_value = 'ALL' THEN
          toggles := -$oct$display_toggles [];
        ELSE { none
          toggles := $oct$display_toggles [];
        IFEND;
      ELSE { list of keywords
        node := pvt [p$display_option].value;
        WHILE node <> NIL DO
          CASE node^.element_value^.keyword_value (1) OF
          = 'C' =
            toggles := toggles + $oct$display_toggles [occ$display_component_info];
          = 'L' =
            toggles := toggles + $oct$display_toggles [occ$display_libraries];
          = 'D' =
            toggles := toggles + $oct$display_toggles [occ$display_time_date];
          = 'E' =
            toggles := toggles + $oct$display_toggles [occ$display_xdcls];
          = 'H' =
            toggles := toggles + $oct$display_toggles [occ$display_module_header];
          = 'R' =
            toggles := toggles + $oct$display_toggles [occ$display_xrefs];
          CASEND;
          node := node^.link;
        WHILEND;

      IFEND;

      ocv$global_display_toggles := toggles;
    IFEND;


    display_toggle_settings (ocv$global_display_toggles, status);


  PROCEND ocp$_set_display_option;


MODEND ocm$select_display_level;
*DECK DECK=OCM$TRANSIENT_SEGMENT_HANDLERS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ocm$transient_segment_handlers;

*copyc mmp$create_scratch_segment

?? NEWTITLE := '[XDCL] ocp$create_transient_segment' ??
?? EJECT ??

  PROCEDURE [XDCL] ocp$create_transient_segment
    (    kind: amt$pointer_kind;
     VAR segment: amt$segment_pointer;
     VAR status: ost$status);


{ This segment gets returned at task exit.

    mmp$create_scratch_segment (kind, mmc$as_random, segment, status);

  PROCEND ocp$create_transient_segment;
?? OLDTITLE ??
MODEND ocm$transient_segment_handlers
*DECK DECK=OCM$VE_LINKER_COMMAND_HANDLERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  VE Linker Command Handlers' ??
MODULE ocm$ve_linker_command_handlers;

{ PURPOSE:
{   This module contains the command and subcommands for the LINK_VIRTUAL_ENVIRONMENT
{ utility.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc mmc$first_transient_segment
*copyc occ$initial_segment_number
*copyc occ$retain_all_common_blocks
*copyc oce$library_generator_errors
*copyc oce$ve_linker_exceptions
*copyc oct$known_file_list
*copyc oct$link_parameters
*copyc oct$output_segment_descriptor
*copyc oct$section_name_list
*copyc oct$segment_attributes
?? POP ??
*copyc clp$begin_utility
*copyc clp$count_list_elements
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc clp$make_integer_value
*copyc ocp$add_to_known_files
*copyc ocp$add_to_object_file_list
*copyc ocp$add_to_predefined_segments
*copyc ocp$add_to_symbol_table_list
*copyc ocp$close_linker_object_files
*copyc ocp$close_linker_symbol_tables
*copyc ocp$close_predefined_segments
*copyc ocp$create_transient_segment
*copyc ocp$duplicate_file
*copyc ocp$duplicate_section_name
*copyc ocp$duplicate_segment_number
*copyc ocp$execute_the_ve_linker
*copyc ocp$open_linker_object_file
*copyc ocp$open_linker_symbol_table
*copyc ocp$open_output_segment
*copyc ocp$search_modules_to_add
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$get_unique_name
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  SECTION
    read_only: READ;

  CONST
    utility_prompt_length = 3,
    utility_prompt = 'VEL';

  VAR
    ocv$known_file_list: [XDCL] oct$known_file_list,
    ocv$next_available_segment: [XDCL] ost$segment := occ$initial_segment_number,
    ocv$predefined_segment_list: [XDCL] oct$output_segment_descriptor,
    ocv$section_name_list: [XDCL] oct$section_name_list,
    ocv$vel_scratch_seq: [XDCL] ^SEQ ( * );

  VAR
    default_link_map: [STATIC] string (7) := 'LINKMAP',
    link_parameters: oct$link_parameters,
    utility_name: [STATIC, READ, read_only] clt$utility_name := 'virtual_environment_linker',
    ve_generator_not_executed: boolean;

?? OLDTITLE ??
?? NEWTITLE := 'initialize_the_linker', EJECT ??

  PROCEDURE initialize_the_linker;


?? FMT (FORMAT := OFF) ??
  VAR
    default_link_parameters: [STATIC] oct$link_parameters :=

      [{ virtual_image }                  NIL,
       { symbol_table }                   NIL,
       { debug_table }                    NIL,

       { symbol_table_id }                osc$null_name,
       { input_debug_table }              NIL,

       { heap_size_specified }            FALSE,
       { heap_size }                      *,

       { map_file }                       ^default_link_map,
       { map_options }                    $pmt$load_map_options [pmc$block_map,
                                                                 pmc$segment_map,
                                                                 pmc$entry_point_map],
       { starting_segment }               occ$null_seg_value,
       { starting_procedure }             osc$null_name,
       { linked_symbols }                 'GATE',
       { gate_ring_level }                osc$min_ring,

       { modules_to_add }                 [ *, NIL],
       { object_files_to_add }            [ NIL, *, *, *, *, *, *, *, *, *, *, false],
       { object_libraries_to_use }        [ NIL, *, *, *, *, *, *, *, *, *, *, false],
       { symbol_tables_to_use }           [ *, *, *, *, *, NIL],

       { exchange_package_variable }      osc$null_name,

       { build_level }                    osc$null_name,
       { build_level_variables }          [ *, NIL ],

       { heap_pointers }                  [ *, *, *, NIL],
       { symbol_table_pointers }          [ *, *, *, NIL],
       { symbol_table_id_variable }       osc$null_name,
       { debug_table_pointers }           [ *, *, *, NIL],

       { recovery_name_table_pointer }    [osc$null_name, *, *, *],
       { recovery_addresses }             [ *, NIL ],

       { ignore_section_names }           FALSE,
       { common_blocks_to_retain }        [osc$null_name, NIL],

       { mode }                           occ$template,
       { mc68000_seq }                    *,
       { mc68000_id }                     *,

       { message_module_list  }           NIL,

       {delete_declaration_matching  }    [osc$null_name, NIL],
       {preset_value }                    pmc$initialize_to_zero,
       {create_only_predefined_segments } FALSE,
       {cybil_parameter_checking }        'SOURCE',
       {defer_entry_points }              NIL,
       {defer_common_blocks }             NIL];

?? EJECT ??

?? FMT (FORMAT := ON) ??

    RESET ocv$vel_scratch_seq;

    link_parameters := default_link_parameters;

    ocv$known_file_list.name := default_link_parameters.map_file;
    ocv$known_file_list.link := NIL;

    ocv$section_name_list.link := NIL;
    ocv$predefined_segment_list.link := NIL;

    ve_generator_not_executed := FALSE;


  PROCEND initialize_the_linker;
?? OLDTITLE ??
?? NEWTITLE := 'crack_segment_attributes_param', EJECT ??

{ PURPOSE:
{   The purpose of this request to process the segment attribute parameter.  The
{   PDT for this parameter is as follows:
{
{         attribute, attributes, a: list of key
{             rd, rk, bi, wt, wk, ex, lp, gp, cb, et, wr, sh, fx, st, rt, fb, na
{           keyend = $required

  PROCEDURE crack_segment_attributes_param
    (    parameter_value: clt$parameter_value;
         inhibit_binding_check: boolean;
     VAR used_attributes: oct$segment_attributes;
     VAR unused_attributes: oct$segment_attributes;
     VAR extensible_attribute: oct$extensible_attributes;
     VAR status: ost$status);


    VAR
      data_value: ^clt$data_value,
      execute_attributes: clt$list_size,
      read_attributes: clt$list_size,
      write_attributes: clt$list_size;


    status.normal := TRUE;

    used_attributes := $oct$segment_attributes [];
    unused_attributes := $oct$segment_attributes [];
    extensible_attribute := occ$non_extensible;

    read_attributes := 0;
    write_attributes := 0;
    execute_attributes := 0;

    data_value := parameter_value.value;
    WHILE data_value <> NIL DO
      IF data_value^.element_value^.keyword_value = 'RD' THEN
        used_attributes := used_attributes + $oct$segment_attributes [occ$sa_read];
        read_attributes := read_attributes + 1;

      ELSEIF data_value^.element_value^.keyword_value = 'RK' THEN
        used_attributes := used_attributes + $oct$segment_attributes [occ$sa_read_kl];
        read_attributes := read_attributes + 1;

      ELSEIF data_value^.element_value^.keyword_value = 'WT' THEN
        used_attributes := used_attributes + $oct$segment_attributes [occ$sa_write];
        write_attributes := write_attributes + 1;

      ELSEIF data_value^.element_value^.keyword_value = 'WK' THEN
        used_attributes := used_attributes + $oct$segment_attributes [occ$sa_write_kl];
        write_attributes := write_attributes + 1;

      ELSEIF data_value^.element_value^.keyword_value = 'EX' THEN
        used_attributes := used_attributes + $oct$segment_attributes [occ$sa_non_privileged];
        execute_attributes := execute_attributes + 1;

      ELSEIF data_value^.element_value^.keyword_value = 'LP' THEN
        used_attributes := used_attributes + $oct$segment_attributes [occ$sa_local_privilege];
        execute_attributes := execute_attributes + 1;

      ELSEIF data_value^.element_value^.keyword_value = 'GP' THEN
        used_attributes := used_attributes + $oct$segment_attributes [occ$sa_global_privilege];
        execute_attributes := execute_attributes + 1;

      ELSEIF data_value^.element_value^.keyword_value = 'BI' THEN
        used_attributes := used_attributes + $oct$segment_attributes [occ$sa_binding];

      ELSEIF data_value^.element_value^.keyword_value = 'CB' THEN
        used_attributes := used_attributes + $oct$segment_attributes [occ$sa_cache_bypass];

      ELSEIF data_value^.element_value^.keyword_value = 'ET' THEN
        used_attributes := used_attributes + $oct$segment_attributes [occ$sa_extensible];
        extensible_attribute := occ$unallocated_extensible;

      ELSEIF data_value^.element_value^.keyword_value = 'WR' THEN
        unused_attributes := unused_attributes + $oct$segment_attributes [occ$sa_wired];

      ELSEIF data_value^.element_value^.keyword_value = 'SH' THEN
        unused_attributes := unused_attributes + $oct$segment_attributes [occ$sa_shared];

      ELSEIF data_value^.element_value^.keyword_value = 'FX' THEN
        unused_attributes := unused_attributes + $oct$segment_attributes [occ$sa_fixed];

      ELSEIF data_value^.element_value^.keyword_value = 'ST' THEN
        unused_attributes := unused_attributes + $oct$segment_attributes [occ$sa_stack];

      ELSEIF data_value^.element_value^.keyword_value = 'RT' THEN
        unused_attributes := unused_attributes + $oct$segment_attributes [occ$sa_read_transfer_unit];

      ELSEIF data_value^.element_value^.keyword_value = 'FB' THEN
        unused_attributes := unused_attributes + $oct$segment_attributes [occ$sa_free_behind];

      ELSEIF data_value^.element_value^.keyword_value = 'NA' THEN
        unused_attributes := unused_attributes + $oct$segment_attributes [occ$sa_no_append];

      IFEND;

      data_value := data_value^.link;
    WHILEND;

    IF occ$sa_binding IN used_attributes THEN
      IF NOT inhibit_binding_check THEN
        IF (read_attributes + write_attributes + execute_attributes) <> 0 THEN
          osp$set_status_abnormal ('OC', oce$e_seg_attribute_conflict, '''BI'' must be used alone', status);
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    IF read_attributes > 1 THEN
      osp$set_status_abnormal ('OC', oce$e_seg_attribute_conflict, 'Multiple READ attributes', status);
      RETURN;
    IFEND;

    IF write_attributes > 1 THEN
      osp$set_status_abnormal ('OC', oce$e_seg_attribute_conflict, 'Multiple WRITE attributes', status);
      RETURN;
    IFEND;

    IF execute_attributes > 1 THEN
      osp$set_status_abnormal ('OC', oce$e_seg_attribute_conflict, 'Multiple EXECUTE attributes', status);
      RETURN;
    IFEND;


  PROCEND crack_segment_attributes_param;
?? OLDTITLE ??
?? NEWTITLE := 'crack_ring_brackets_parameter', EJECT ??

{ PURPOSE:
{   The purpose of this request to process the ring brackets parameter.  The
{   PDT for this parameter is as follows:
{
{         ring_brackets, rb: record
{             r1: integer osc$invalid_ring..osc$max_ring
{             r2: integer osc$invalid_ring..osc$max_ring
{             r3: integer osc$invalid_ring..osc$max_ring
{           recend = $optional

  PROCEDURE crack_ring_brackets_parameter
    (    parameter_value: clt$parameter_value;
     VAR r1: ost$ring;
     VAR r2: ost$ring;
     VAR r3: ost$ring;
     VAR status: ost$status);


    status.normal := TRUE;

    CASE link_parameters.mode OF
    = occ$template, occ$product =

      IF parameter_value.specified THEN
        r1 := parameter_value.value^.field_values^ [1].value^.integer_value.value;
        r2 := parameter_value.value^.field_values^ [2].value^.integer_value.value;
        r3 := parameter_value.value^.field_values^ [3].value^.integer_value.value;

        IF NOT ((0 < r1) AND (r1 <= r2) AND (r2 <= r3)) THEN
          osp$set_status_condition (oce$e_invalid_ring_bracket, status);
          osp$append_status_integer (osc$status_parameter_delimiter, r1, 10, FALSE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, r2, 10, FALSE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, r3, 10, FALSE, status);
        IFEND;

      ELSE
        osp$set_status_abnormal ('OC', cle$required_parameter_omitted, 'RING_BRACKETS', status);
      IFEND;

    ELSE { = occ$mc68000 =
      r1 := osc$invalid_ring;
      r2 := osc$invalid_ring;
      r3 := osc$invalid_ring;

    CASEND;


  PROCEND crack_ring_brackets_parameter;
?? OLDTITLE ??
?? NEWTITLE := 'crack_key_lock_parameter', EJECT ??

{ PURPOSE:
{   The purpose of this request to process the global_local_key parameter.  The
{   PDT for this parameter is as follows:
{
{         global_local_key, glk: record
{             global: integer 0..3f(16)
{             local: integer 0..3f(16)
{           recend = (0, 0)

  PROCEDURE crack_key_lock_parameter
    (    parameter_value: clt$parameter_value;
     VAR global_key: ost$key_lock_value;
     VAR local_key: ost$key_lock_value;
     VAR status: ost$status);


    status.normal := TRUE;

    global_key := parameter_value.value^.field_values^ [1].value^.integer_value.value;
    local_key := parameter_value.value^.field_values^ [2].value^.integer_value.value;

    IF global_key <> local_key THEN
      IF (global_key <> 0) AND (local_key <> 0) THEN
        osp$set_status_condition (oce$e_global_local_key_mismatch, status);
        osp$append_status_integer (osc$status_parameter_delimiter, global_key, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, local_key, 10, FALSE, status);
        RETURN;
      IFEND;
    IFEND;


  PROCEND crack_key_lock_parameter;
?? OLDTITLE ??
?? NEWTITLE := 'crack_segment_number_parameter', EJECT ??

{ PURPOSE:
{   The purpose of this request to process the segment number parameter.  The
{   PDT for this parameter is as follows:
{
{         number, n: integer 0..osc$maximum_segment = $optional

  PROCEDURE crack_segment_number_parameter
    (    parameter_value: clt$parameter_value;
     VAR segment_number_predefined: boolean;
     VAR segment_number: oct$segment;
     VAR status: ost$status);


    status.normal := TRUE;

    IF NOT parameter_value.specified THEN
      segment_number_predefined := FALSE;

    ELSE
      segment_number_predefined := TRUE;
      segment_number := parameter_value.value^.integer_value.value;

      IF ocp$duplicate_segment_number (segment_number) THEN
        osp$set_status_condition (oce$e_duplicate_segment_named, status);
        osp$append_status_integer (osc$status_parameter_delimiter, segment_number, 10, FALSE, status);
        RETURN;
      IFEND;
    IFEND;


  PROCEND crack_segment_number_parameter;
?? OLDTITLE ??
?? NEWTITLE := 'crack_section_name_parameter', EJECT ??

{ PURPOSE:
{   The purpose of this request to process the section name parameter.  The
{   PDT for this parameter is as follows:
{
{         section_name, section_names, sn: list of program_name = $optional

  PROCEDURE crack_section_name_parameter
    (    parameter_value: clt$parameter_value;
     VAR new_section_names: ^oct$section_name_list;
     VAR status: ost$status);


    VAR
      data_value: ^clt$data_value,
      first_section_name: oct$section_name_list,
      next_section_name: ^oct$section_name_list;


    status.normal := TRUE;

    first_section_name.link := NIL;
    next_section_name := ^first_section_name;

    data_value := parameter_value.value;
    WHILE data_value <> NIL DO
      NEXT next_section_name^.link IN ocv$vel_scratch_seq;
      next_section_name := next_section_name^.link;
      IF next_section_name = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH1', status);
        RETURN;
      IFEND;

      next_section_name^.name := data_value^.element_value^.program_name_value;
      next_section_name^.link := NIL;

      IF ocp$duplicate_section_name (next_section_name^.name) THEN
        osp$set_status_abnormal ('OC', oce$e_duplicate_section_named, next_section_name^.name, status);
        RETURN;
      IFEND;

      data_value := data_value^.link;
    WHILEND;

    new_section_names := first_section_name.link;

  PROCEND crack_section_name_parameter;
?? OLDTITLE ??
?? NEWTITLE := 'crack_execute_privilege_param', EJECT ??

{ PURPOSE:
{   The purpose of this request to process the execute privilege parameter.  The
{   PDT for this parameter is as follows:
{
{         execute_privilege, ep: key
{             (execute, e)
{             (local, l)
{             (global, g)
{           keyend = execute

  PROCEDURE crack_execute_privilege_param
    (    parameter_value: clt$parameter_value;
     VAR execute_privilege: ost$execute_privilege);


    IF parameter_value.value^.keyword_value = 'EXECUTE' THEN
      execute_privilege := osc$non_privileged;

    ELSEIF parameter_value.value^.keyword_value = 'LOCAL' THEN
      execute_privilege := osc$local_privilege;

    ELSEIF parameter_value.value^.keyword_value = 'GLOBAL' THEN
      execute_privilege := osc$global_privilege;

    IFEND;


  PROCEND crack_execute_privilege_param;
?? OLDTITLE ??
?? NEWTITLE := 'crack_default_section_param', EJECT ??

{ PURPOSE:
{   The purpose of this request to process the default section parameter.  The
{   PDT for this parameter is as follows:
{
{         default_section, default_sections, ds: list of record
{             section_name: program_name
{             section_attributes: list rest of key
{               (read, r)
{               (write, w)
{               (execute, e)
{               (binding, b)
{             keyend
{           recend = $optional

  PROCEDURE crack_default_section_param
    (    data_value: ^clt$data_value;
     VAR default_section: oct$default_section);

    VAR
      key_value: ^clt$data_value;


    default_section.name := data_value^.field_values^ [1].value^.program_name_value;
    default_section.attributes := $llt$section_access_attributes [];

    key_value := data_value^.field_values^ [2].value;

    WHILE key_value <> NIL DO

      IF (key_value^.element_value^.keyword_value = 'READ ') THEN
        default_section.attributes := default_section.attributes + $llt$section_access_attributes [llc$read];

      ELSEIF (key_value^.element_value^.keyword_value = 'WRITE ') THEN
        default_section.attributes := default_section.attributes + $llt$section_access_attributes [llc$write];

      ELSEIF (key_value^.element_value^.keyword_value = 'EXECUTE ') THEN
        default_section.attributes := default_section.attributes + $llt$section_access_attributes
              [llc$execute];

      ELSE {key_value^.element_value^.keyword_value = 'BINDING '
        default_section.attributes := default_section.attributes + $llt$section_access_attributes
              [llc$binding];

      IFEND;

      key_value := key_value^.link;
    WHILEND;


  PROCEND crack_default_section_param;
?? OLDTITLE ??
?? NEWTITLE := 'crack_default_section_parameter', EJECT ??

{ PURPOSE:
{   The purpose of this request to process the default section parameter.  The
{   PDT for this parameter is as follows:
{
{         default_section, default_sections, ds: list of record
{             section_name: program_name
{             section_attributes: list rest of key
{               (read, r)
{               (write, w)
{               (execute, e)
{               (binding, b)
{             keyend
{           recend = $optional

  PROCEDURE crack_default_section_parameter
    (    parameter_value: clt$parameter_value;
     VAR default_sections: ^oct$default_sections;
     VAR status: ost$status);


    VAR
      data_value: ^clt$data_value,
      i: clt$list_size,
      j: clt$list_size,
      number_of_records: clt$list_size;


    status.normal := TRUE;

    number_of_records := clp$count_list_elements (parameter_value.value);

    IF number_of_records = 0 THEN
      default_sections := NIL;

    ELSE
      NEXT default_sections: [1 .. number_of_records] IN ocv$vel_scratch_seq;
      IF default_sections = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH2', status);
        RETURN;
      IFEND;

      data_value := parameter_value.value;
      FOR i := 1 TO number_of_records DO
        crack_default_section_param (data_value^.element_value, default_sections^ [i]);

        data_value := data_value^.link;

        FOR j := 1 TO (i - 1) DO
          IF default_sections^ [i].attributes = default_sections^ [j].attributes THEN
            osp$set_status_abnormal ('OC', oce$e_duplicate_section_attr, default_sections^ [i].name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, default_sections^ [j].name, status);
            RETURN;
          IFEND;
        FOREND;
      FOREND;
    IFEND;


  PROCEND crack_default_section_parameter;
?? OLDTITLE ??
?? NEWTITLE := 'crack_map_options_parameter', EJECT ??

{ PURPOSE:
{   The purpose of this request to process the link map options parameter.  The
{   PDT for this parameter is as follows:
{
{         link_map_option, link_map_options, lmo: (BY_NAME) any of
{             key
{               all, none
{             keyend
{             list of key
{               (block, b)
{               (entry_point, ep)
{               (segment, s)
{             keyend
{           anyend = $optional

  PROCEDURE crack_map_options_parameter
    (    parameter_value: clt$parameter_value;
     VAR map_options: pmt$load_map_options;
     VAR status: ost$status);


    VAR
      data_value: ^clt$data_value,
      i: clt$list_size,
      number_of_options: clt$list_size;


    status.normal := TRUE;

    IF parameter_value.specified THEN
      map_options := $pmt$load_map_options [];
      IF parameter_value.value^.kind = clc$keyword THEN
        IF parameter_value.value^.keyword_value = 'ALL' THEN
          map_options := $pmt$load_map_options [pmc$block_map, pmc$entry_point_map, pmc$segment_map];
        ELSE { parameter_value.value^.keyword_value = 'NONE'
          map_options := $pmt$load_map_options [pmc$no_load_map];
        IFEND;
      ELSE { parameter_value.value^.kind = clc$list
        number_of_options := clp$count_list_elements (parameter_value.value);
        data_value := parameter_value.value;
        FOR i := 1 TO number_of_options DO

          IF data_value^.element_value^.keyword_value = 'BLOCK' THEN
            map_options := map_options + $pmt$load_map_options [pmc$block_map];
          ELSEIF data_value^.element_value^.keyword_value = 'ENTRY_POINT' THEN
            map_options := map_options + $pmt$load_map_options [pmc$entry_point_map];
          ELSEIF data_value^.element_value^.keyword_value = 'SEGMENT' THEN
            map_options := map_options + $pmt$load_map_options [pmc$segment_map];
          IFEND;

          data_value := data_value^.link;
        FOREND;
      IFEND;
    IFEND;

  PROCEND crack_map_options_parameter;
?? OLDTITLE ??
?? NEWTITLE := 'set_link_options', EJECT ??

  PROCEDURE set_link_options
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$linve_setlo) set_link_option, setlo (
{   build_level, bl: (BY_NAME) string 1..22 = $optional
{   create_only_predefined_segments, cops: (BY_NAME) boolean = $optional
{   cybil_parameter_checking, cpc: (BY_NAME) key
{       (source, s)
{       (object, o)
{     keyend = $optional
{   defer_common_blocks, dcb: (BY_NAME) any of
{       key
{         all, none
{       keyend
{       record
{         action: key
{           ($defer_all_except, $dae)
{         keyend
{         common_blocks: list rest of program_name
{       recend
{       list of program_name
{     anyend = none
{   defer_entry_points, dep: (BY_NAME) any of
{       key
{         all, none
{         ($not_retained, $nr)
{       keyend
{       record
{         action: key
{           ($defer_all_except, $dae)
{         keyend
{         entry_points: list rest of program_name
{       recend
{       list of program_name
{     anyend = none
{   exchange_package_variable, epv: (BY_NAME) program_name = $optional
{   gate_ring_level, grl: (BY_NAME) integer osc$min_ring..osc$max_ring = $optional
{   heap_size, hs: (BY_NAME) integer 0..osc$max_segment_length = $optional
{   ignore_section_names, isn: (BY_NAME) boolean = $optional
{   link_map, lm: (BY_NAME) file = $optional
{   link_map_option, link_map_options, lmo: (BY_NAME) any of
{       key
{         all, none
{       keyend
{       list of key
{         (block, b)
{         (entry_point, ep)
{         (segment, s)
{       keyend
{     anyend = $optional
{   linked_symbols, ls: (BY_NAME) key
{       gate, all
{     keyend = $optional
{   mode, m: (BY_NAME) key
{       template, product, mc68000
{     keyend = $optional
{   preset_value, pv: (BY_NAME) key
{       (zero, z)
{       (floating_point_indefinite, fpi)
{       (infinity, i)
{       (alternate_ones, ao)
{     keyend = $optional
{   starting_procedure, sp: (BY_NAME) program_name = $optional
{   starting_segment, ss: (BY_NAME) integer 0..osc$maximum_segment = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 34] of clt$pdt_parameter_name,
      parameters: array [1 .. 17] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type4: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 2] of clt$keyword_specification,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$list_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
        default_value: string (4),
      recend,
      type5: 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 .. 4] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 2] of clt$keyword_specification,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$list_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
            recend,
          recend,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
        default_value: string (4),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type9: record
        header: clt$type_specification_header,
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
      type11: 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 .. 2] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 6] of clt$keyword_specification,
          recend,
        recend,
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
      recend,
      type13: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      type14: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
      recend,
      type15: record
        header: clt$type_specification_header,
      recend,
      type16: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type17: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 14, 11, 38, 37, 660],
    clc$command, 34, 17, 0, 0, 0, 0, 17, 'OCM$LINVE_SETLO'], [
    ['BL                             ',clc$abbreviation_entry, 1],
    ['BUILD_LEVEL                    ',clc$nominal_entry, 1],
    ['COPS                           ',clc$abbreviation_entry, 2],
    ['CPC                            ',clc$abbreviation_entry, 3],
    ['CREATE_ONLY_PREDEFINED_SEGMENTS',clc$nominal_entry, 2],
    ['CYBIL_PARAMETER_CHECKING       ',clc$nominal_entry, 3],
    ['DCB                            ',clc$abbreviation_entry, 4],
    ['DEFER_COMMON_BLOCKS            ',clc$nominal_entry, 4],
    ['DEFER_ENTRY_POINTS             ',clc$nominal_entry, 5],
    ['DEP                            ',clc$abbreviation_entry, 5],
    ['EPV                            ',clc$abbreviation_entry, 6],
    ['EXCHANGE_PACKAGE_VARIABLE      ',clc$nominal_entry, 6],
    ['GATE_RING_LEVEL                ',clc$nominal_entry, 7],
    ['GRL                            ',clc$abbreviation_entry, 7],
    ['HEAP_SIZE                      ',clc$nominal_entry, 8],
    ['HS                             ',clc$abbreviation_entry, 8],
    ['IGNORE_SECTION_NAMES           ',clc$nominal_entry, 9],
    ['ISN                            ',clc$abbreviation_entry, 9],
    ['LINKED_SYMBOLS                 ',clc$nominal_entry, 12],
    ['LINK_MAP                       ',clc$nominal_entry, 10],
    ['LINK_MAP_OPTION                ',clc$nominal_entry, 11],
    ['LINK_MAP_OPTIONS               ',clc$alias_entry, 11],
    ['LM                             ',clc$abbreviation_entry, 10],
    ['LMO                            ',clc$abbreviation_entry, 11],
    ['LS                             ',clc$abbreviation_entry, 12],
    ['M                              ',clc$abbreviation_entry, 13],
    ['MODE                           ',clc$nominal_entry, 13],
    ['PRESET_VALUE                   ',clc$nominal_entry, 14],
    ['PV                             ',clc$abbreviation_entry, 14],
    ['SP                             ',clc$abbreviation_entry, 15],
    ['SS                             ',clc$abbreviation_entry, 16],
    ['STARTING_PROCEDURE             ',clc$nominal_entry, 15],
    ['STARTING_SEGMENT               ',clc$nominal_entry, 16],
    ['STATUS                         ',clc$nominal_entry, 17]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 377,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 7
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 8
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 9
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 10
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 11
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 346,
  clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81, clc$optional_parameter,
  0, 0],
{ PARAMETER 13
    [27, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 118,
  clc$optional_parameter, 0, 0],
{ PARAMETER 14
    [28, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_parameter, 0, 0],
{ PARAMETER 15
    [32, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 16
    [33, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 17
    [34, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [1, 22, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$boolean_type]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['O                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['OBJECT                         ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SOURCE                         ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type, clc$record_type],
    FALSE, 3],
    81, [[1, 0, clc$keyword_type], [2], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    179, [[1, 0, clc$record_type], [2],
      ['ACTION                         ', clc$required_field, 81], [[1, 0, clc$keyword_type], [2], [
        ['$DAE                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['$DEFER_ALL_EXCEPT              ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      ['COMMON_BLOCKS                  ', clc$required_field, 19], [[1, 0, clc$list_type], [3, 0,
  clc$max_list_size, TRUE],
          [[1, 0, clc$program_name_type]]
        ]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$program_name_type]]
      ]
    ,
    'none'],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type, clc$record_type],
    FALSE, 3],
    155, [[1, 0, clc$keyword_type], [4], [
      ['$NOT_RETAINED                  ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['$NR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    179, [[1, 0, clc$record_type], [2],
      ['ACTION                         ', clc$required_field, 81], [[1, 0, clc$keyword_type], [2], [
        ['$DAE                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['$DEFER_ALL_EXCEPT              ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      ['ENTRY_POINTS                   ', clc$required_field, 19], [[1, 0, clc$list_type], [3, 0,
  clc$max_list_size, TRUE],
          [[1, 0, clc$program_name_type]]
        ]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$program_name_type]]
      ]
    ,
    'none'],
{ PARAMETER 6
    [[1, 0, clc$program_name_type]],
{ PARAMETER 7
    [[1, 0, clc$integer_type], [osc$min_ring, osc$max_ring, 10]],
{ PARAMETER 8
    [[1, 0, clc$integer_type], [0, osc$max_segment_length, 10]],
{ PARAMETER 9
    [[1, 0, clc$boolean_type]],
{ PARAMETER 10
    [[1, 0, clc$file_type]],
{ PARAMETER 11
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    245, [[1, 0, clc$list_type], [229, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [6], [
        ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['BLOCK                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['SEGMENT                        ', clc$nominal_entry, clc$normal_usage_entry, 3]]
        ]
      ]
    ],
{ PARAMETER 12
    [[1, 0, clc$keyword_type], [2], [
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['GATE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 13
    [[1, 0, clc$keyword_type], [3], [
    ['MC68000                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['PRODUCT                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['TEMPLATE                       ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 14
    [[1, 0, clc$keyword_type], [8], [
    ['ALTERNATE_ONES                 ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['AO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['FLOATING_POINT_INDEFINITE      ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['FPI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['INFINITY                       ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['Z                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ZERO                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 15
    [[1, 0, clc$program_name_type]],
{ PARAMETER 16
    [[1, 0, clc$integer_type], [0, osc$maximum_segment, 10]],
{ PARAMETER 17
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$build_level = 1,
      p$create_only_predefined_segmen = 2 {CREATE_ONLY_PREDEFINED_SEGMENTS} ,
      p$cybil_parameter_checking = 3,
      p$defer_common_blocks = 4,
      p$defer_entry_points = 5,
      p$exchange_package_variable = 6,
      p$gate_ring_level = 7,
      p$heap_size = 8,
      p$ignore_section_names = 9,
      p$link_map = 10,
      p$link_map_option = 11,
      p$linked_symbols = 12,
      p$mode = 13,
      p$preset_value = 14,
      p$starting_procedure = 15,
      p$starting_segment = 16,
      p$status = 17;

    VAR
      pvt: array [1 .. 17] of clt$parameter_value;

    VAR
      common_block: ^oct$defer_list,
      data_value: ^clt$data_value,
      defer_common_blocks: ^oct$defer_name_list,
      defer_entry_points: ^oct$defer_name_list,
      entry_point: ^oct$defer_list,
      local_parameters: oct$link_parameters,
      name: ost$name,
      previous_link: ^^oct$defer_list,
      segment: amt$segment_pointer;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_parameters := link_parameters;

    IF pvt [p$link_map].specified THEN
      IF ocp$duplicate_file (pvt [p$link_map].value^.file_value^, ocv$known_file_list) THEN
        osp$set_status_abnormal ('OC', oce$e_duplicate_file_named, pvt [p$link_map].value^.file_value^,
              status);
        RETURN;
      ELSE
        NEXT local_parameters.map_file: [STRLENGTH (pvt [p$link_map].value^.file_value^)] IN
              ocv$vel_scratch_seq;
        IF local_parameters.map_file = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH3', status);
          RETURN;
        IFEND;
        local_parameters.map_file^ := pvt [p$link_map].value^.file_value^;
      IFEND;
    IFEND;

    crack_map_options_parameter (pvt [p$link_map_option], local_parameters.map_options, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$starting_segment].specified THEN
      local_parameters.starting_segment := pvt [p$starting_segment].value^.integer_value.value;
    IFEND;

    IF pvt [p$starting_procedure].specified THEN
      local_parameters.starting_procedure := pvt [p$starting_procedure].value^.program_name_value;
    IFEND;

    IF pvt [p$linked_symbols].specified THEN
      local_parameters.linked_symbols := pvt [p$linked_symbols].value^.keyword_value;
    IFEND;

    IF pvt [p$gate_ring_level].specified THEN
      IF local_parameters.linked_symbols <> 'GATE' THEN
        osp$set_status_condition (oce$e_linked_symbols_not_gate, status);
        RETURN;
      IFEND;
      local_parameters.gate_ring_level := pvt [p$gate_ring_level].value^.integer_value.value;
    IFEND;

    IF pvt [p$heap_size].specified THEN
      local_parameters.heap_size_specified := TRUE;
      local_parameters.heap_size := pvt [p$heap_size].value^.integer_value.value;
    IFEND;

    IF pvt [p$build_level].specified THEN
      local_parameters.build_level := pvt [p$build_level].value^.string_value^;
    IFEND;

    IF pvt [p$exchange_package_variable].specified THEN
      local_parameters.exchange_package_variable := pvt [p$exchange_package_variable].value^.
            program_name_value;
    IFEND;

    IF pvt [p$ignore_section_names].specified THEN
      local_parameters.ignore_section_names := pvt [p$ignore_section_names].value^.boolean_value.value;
    IFEND;

    IF pvt [p$mode].specified THEN
      IF pvt [p$mode].value^.keyword_value = 'TEMPLATE' THEN
        local_parameters.mode := occ$template;
        IF (ocv$next_available_segment = mmc$first_loader_predefined_seg) THEN
          ocv$next_available_segment := occ$initial_segment_number;
        IFEND;
      ELSEIF pvt [p$mode].value^.keyword_value = 'PRODUCT' THEN
        local_parameters.mode := occ$product;
        IF (ocv$next_available_segment = occ$initial_segment_number) THEN
          ocv$next_available_segment := mmc$first_loader_predefined_seg;
        IFEND;
      ELSE {mode = mc68000
        IF link_parameters.mode <> occ$mc68000 THEN
          pmp$get_unique_name (name, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          ocp$open_output_segment (name, local_parameters.mc68000_id, segment, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          local_parameters.mc68000_seq := segment.sequence_pointer;
          local_parameters.mode := occ$mc68000;
        IFEND;
      IFEND;
    IFEND;

    IF pvt [p$preset_value].specified THEN
      IF pvt [p$preset_value].value^.keyword_value = 'ZERO' THEN
        local_parameters.preset_value := pmc$initialize_to_zero;
      ELSEIF pvt [p$preset_value].value^.keyword_value = 'FLOATING_POINT_INDEFINITE' THEN
        local_parameters.preset_value := pmc$initialize_to_indefinite;
      ELSEIF pvt [p$preset_value].value^.keyword_value = 'INFINITY' THEN
        local_parameters.preset_value := pmc$initialize_to_infinity;
      ELSE {IF pvt$p$preset_value].value^.keyword_value = 'ALTERNATE_ONES' THEN
        local_parameters.preset_value := pmc$initialize_to_alt_ones;
      IFEND;
    IFEND;

    IF pvt [p$cybil_parameter_checking].specified THEN
      local_parameters.cybil_parameter_checking := pvt [p$cybil_parameter_checking].value^.keyword_value;
    IFEND;

    IF pvt [p$create_only_predefined_segmen].specified THEN
      local_parameters.create_only_predefined_segments := pvt [p$create_only_predefined_segmen].value^.
            boolean_value.value;
    IFEND;

    IF pvt [p$defer_entry_points].specified THEN
      NEXT defer_entry_points IN ocv$vel_scratch_seq;
      IF defer_entry_points = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH4', status);
        RETURN;
      IFEND;

      CASE pvt [p$defer_entry_points].value^.kind OF
      = clc$keyword =
        IF pvt [p$defer_entry_points].value^.keyword_value = 'NONE' THEN
          RESET ocv$vel_scratch_seq TO defer_entry_points;
          defer_entry_points := NIL;
        ELSEIF pvt [p$defer_entry_points].value^.keyword_value = 'ALL' THEN
          defer_entry_points^.defer := occ$defer_all;
        ELSE { pvt [p$defer_entry_points].value^.keyword_value = '$NOT_RETAINED' THEN
          defer_entry_points^.defer := occ$defer_non_retained;
        IFEND;
      = clc$list =
        defer_entry_points^.defer := occ$defer;
        defer_entry_points^.name_list := NIL;
        previous_link := ^defer_entry_points^.name_list;

        data_value := pvt [p$defer_entry_points].value;
        WHILE data_value <> NIL DO
          NEXT entry_point IN ocv$vel_scratch_seq;
          IF entry_point = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH5', status);
            RETURN;
          IFEND;
          entry_point^.name := data_value^.element_value^.program_name_value;
          entry_point^.name_found := FALSE;
          entry_point^.link := NIL;
          previous_link^ := entry_point;
          previous_link := ^entry_point^.link;

          data_value := data_value^.link;
        WHILEND;
      = clc$record =
        defer_entry_points^.defer := occ$defer_all_except;
        defer_entry_points^.name_list := NIL;
        previous_link := ^defer_entry_points^.name_list;

        data_value := pvt [p$defer_entry_points].value^.field_values^ [2].value;
        WHILE data_value <> NIL DO
          NEXT entry_point IN ocv$vel_scratch_seq;
          IF entry_point = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH6', status);
            RETURN;
          IFEND;
          entry_point^.name := data_value^.element_value^.program_name_value;
          entry_point^.name_found := FALSE;
          entry_point^.link := NIL;
          previous_link^ := entry_point;
          previous_link := ^entry_point^.link;

          data_value := data_value^.link;
        WHILEND;
      ELSE
        ;
      CASEND;

      local_parameters.defer_entry_points := defer_entry_points;
    IFEND;

    IF pvt [p$defer_common_blocks].specified THEN
      NEXT defer_common_blocks IN ocv$vel_scratch_seq;
      IF defer_common_blocks = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH7', status);
        RETURN;
      IFEND;

      CASE pvt [p$defer_common_blocks].value^.kind OF
      = clc$keyword =
        IF pvt [p$defer_common_blocks].value^.keyword_value = 'NONE' THEN
          RESET ocv$vel_scratch_seq TO defer_common_blocks;
          defer_common_blocks := NIL;
        ELSE { pvt [p$defer_common_blocks].value^.keyword_value = 'ALL' THEN
          defer_common_blocks^.defer := occ$defer_all;
        IFEND;
      = clc$list =
        defer_common_blocks^.defer := occ$defer;
        defer_common_blocks^.name_list := NIL;
        previous_link := ^defer_common_blocks^.name_list;

        data_value := pvt [p$defer_common_blocks].value;
        WHILE data_value <> NIL DO
          NEXT common_block IN ocv$vel_scratch_seq;
          IF common_block = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH8', status);
            RETURN;
          IFEND;
          common_block^.name := data_value^.element_value^.program_name_value;
          common_block^.name_found := FALSE;
          common_block^.link := NIL;
          previous_link^ := common_block;
          previous_link := ^common_block^.link;

          data_value := data_value^.link;
        WHILEND;
      = clc$record =
        defer_common_blocks^.defer := occ$defer_all_except;
        defer_common_blocks^.name_list := NIL;
        previous_link := ^defer_common_blocks^.name_list;

        data_value := pvt [p$defer_common_blocks].value^.field_values^ [2].value;
        WHILE data_value <> NIL DO
          NEXT common_block IN ocv$vel_scratch_seq;
          IF common_block = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH9', status);
            RETURN;
          IFEND;
          common_block^.name := data_value^.element_value^.program_name_value;
          common_block^.name_found := FALSE;
          common_block^.link := NIL;
          previous_link^ := common_block;
          previous_link := ^common_block^.link;

          data_value := data_value^.link;
        WHILEND;
      ELSE
        ;
      CASEND;

      local_parameters.defer_common_blocks := defer_common_blocks;
    IFEND;

    ocv$known_file_list.name := local_parameters.map_file;
    link_parameters := local_parameters;

    ve_generator_not_executed := TRUE;


  PROCEND set_link_options;
?? OLDTITLE ??
?? NEWTITLE := 'define_segment', EJECT ??

  PROCEDURE define_segment
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$linve_defs) define_segment, defs (
{   attribute, attributes, a: list of key
{       rd, rk, bi, wt, wk, ex, lp, gp, cb, et, wr, sh, fx, st, rt, fb, na
{     keyend = $required
{   ring_brackets, rb: record
{       r1: integer osc$invalid_ring..osc$max_ring
{       r2: integer osc$invalid_ring..osc$max_ring
{       r3: integer osc$invalid_ring..osc$max_ring
{     recend = $optional
{   number, n: integer 0..osc$maximum_segment = $optional
{   section_name, section_names, sn: list of program_name = $optional
{   global_local_key, glk: record
{       global: integer 0..3f(16)
{       local: integer 0..3f(16)
{     recend = (0, 0)
{   inhibit_binding_check, ibc: boolean = false
{   first_byte_offset, fbo: integer 0..(osc$max_segment_length - 1) = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 17] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 17] of clt$keyword_specification,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (6),
      recend,
      type6: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 13, 12, 9, 42, 287],
    clc$command, 17, 8, 1, 0, 0, 0, 8, 'OCM$LINVE_DEFS'], [
    ['A                              ',clc$abbreviation_entry, 1],
    ['ATTRIBUTE                      ',clc$nominal_entry, 1],
    ['ATTRIBUTES                     ',clc$alias_entry, 1],
    ['FBO                            ',clc$abbreviation_entry, 7],
    ['FIRST_BYTE_OFFSET              ',clc$nominal_entry, 7],
    ['GLK                            ',clc$abbreviation_entry, 5],
    ['GLOBAL_LOCAL_KEY               ',clc$nominal_entry, 5],
    ['IBC                            ',clc$abbreviation_entry, 6],
    ['INHIBIT_BINDING_CHECK          ',clc$nominal_entry, 6],
    ['N                              ',clc$abbreviation_entry, 3],
    ['NUMBER                         ',clc$nominal_entry, 3],
    ['RB                             ',clc$abbreviation_entry, 2],
    ['RING_BRACKETS                  ',clc$nominal_entry, 2],
    ['SECTION_NAME                   ',clc$nominal_entry, 4],
    ['SECTION_NAMES                  ',clc$alias_entry, 4],
    ['SN                             ',clc$abbreviation_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 8]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 652,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 175,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$optional_parameter,
  0, 0],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 119,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 6
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 7
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 8
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [636, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [17], [
      ['BI                             ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['CB                             ', clc$nominal_entry, clc$normal_usage_entry, 9],
      ['ET                             ', clc$nominal_entry, clc$normal_usage_entry, 10],
      ['EX                             ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['FB                             ', clc$nominal_entry, clc$normal_usage_entry, 16],
      ['FX                             ', clc$nominal_entry, clc$normal_usage_entry, 13],
      ['GP                             ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['LP                             ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['NA                             ', clc$nominal_entry, clc$normal_usage_entry, 17],
      ['RD                             ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['RK                             ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['RT                             ', clc$nominal_entry, clc$normal_usage_entry, 15],
      ['SH                             ', clc$nominal_entry, clc$normal_usage_entry, 12],
      ['ST                             ', clc$nominal_entry, clc$normal_usage_entry, 14],
      ['WK                             ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['WR                             ', clc$nominal_entry, clc$normal_usage_entry, 11],
      ['WT                             ', clc$nominal_entry, clc$normal_usage_entry, 4]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$record_type], [3],
    ['R1                             ', clc$required_field, 20], [[1, 0, clc$integer_type], [osc$invalid_ring
  , osc$max_ring, 10]],
    ['R2                             ', clc$required_field, 20], [[1, 0, clc$integer_type], [osc$invalid_ring
  , osc$max_ring, 10]],
    ['R3                             ', clc$required_field, 20], [[1, 0, clc$integer_type], [osc$invalid_ring
  , osc$max_ring, 10]]
    ],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, osc$maximum_segment, 10]],
{ PARAMETER 4
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$program_name_type]]
    ],
{ PARAMETER 5
    [[1, 0, clc$record_type], [2],
    ['GLOBAL                         ', clc$required_field, 20], [[1, 0, clc$integer_type], [0, 3f(16), 10]],
    ['LOCAL                          ', clc$required_field, 20], [[1, 0, clc$integer_type], [0, 3f(16), 10]]
    ,
    '(0, 0)'],
{ PARAMETER 6
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 7
    [[1, 0, clc$integer_type], [0, (osc$max_segment_length - 1), 10]],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$attribute = 1,
      p$ring_brackets = 2,
      p$number = 3,
      p$section_name = 4,
      p$global_local_key = 5,
      p$inhibit_binding_check = 6,
      p$first_byte_offset = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    VAR
      sd: oct$output_segment_descriptor,
      section_names: ^oct$section_name_list,
      space: ^SEQ ( * );


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sd.link := NIL;
    sd.sections_allocated.link := NIL;

    crack_ring_brackets_parameter (pvt [p$ring_brackets], sd.r1, sd.r2, sd.r3, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_key_lock_parameter (pvt [p$global_local_key], sd.global_key, sd.local_key, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_segment_number_parameter (pvt [p$number], sd.number_predefined, sd.number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_section_name_parameter (pvt [p$section_name], section_names, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sd.inhibit_binding_check := pvt [p$inhibit_binding_check].value^.boolean_value.value;

    crack_segment_attributes_param (pvt [p$attribute], sd.inhibit_binding_check, sd.used_attributes,
          sd.unused_attributes, sd.extensible_attribute, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE link_parameters.mode OF
    = occ$template, occ$product =
      pmp$get_unique_name (sd.name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      ocp$open_output_segment (sd.name, sd.id, sd.segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    ELSE { = occ$mc68000 =

      sd.segment.kind := amc$sequence_pointer;
      sd.segment.sequence_pointer := link_parameters.mc68000_seq;
      sd.offset := 0;

      IF pvt [p$first_byte_offset].specified THEN

        sd.offset := pvt [p$first_byte_offset].value^.integer_value.value;

        IF sd.offset <> 0 THEN
          NEXT space: [[REP sd.offset OF cell]] IN sd.segment.sequence_pointer;
        IFEND;
      IFEND;
    CASEND;

    sd.retained_common_block := FALSE;
    sd.relocation_list.link := NIL;
    sd.binding_section_encountered := FALSE;
    sd.binding_section_segment := 0;
    sd.binding_section_offset := 0;
    sd.number_of_bytes_written := 0;
    sd.cybil_default_heap := FALSE;

    ocp$add_to_predefined_segments (^sd, section_names, status);
    IF NOT status.normal THEN
      ocp$close_predefined_segments (^sd);
      RETURN;
    IFEND;

    ve_generator_not_executed := TRUE;


  PROCEND define_segment;
?? OLDTITLE ??
?? NEWTITLE := 'add_object_file', EJECT ??

  PROCEDURE add_object_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$linve_addof) add_object_file, addof (
{   file, f: file = $required
{   ring_brackets, rb: record
{       r1: integer osc$invalid_ring..osc$max_ring
{       r2: integer osc$invalid_ring..osc$max_ring
{       r3: integer osc$invalid_ring..osc$max_ring
{     recend = $optional
{   global_local_key, glk: record
{       global: integer 0..3f(16)
{       local: integer 0..3f(16)
{     recend = (0, 0)
{   execute_privilege, ep: key
{       (execute, e)
{       (local, l)
{       (global, g)
{     keyend = execute
{   default_section, default_sections, ds: list of record
{       section_name: program_name
{       section_attributes: list rest of key
{         (read, r)
{         (write, w)
{         (execute, e)
{         (binding, b)
{       keyend
{     recend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 12] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (6),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$list_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$keyword_type_qualifier,
              keyword_specs: array [1 .. 8] of clt$keyword_specification,
            recend,
          recend,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 13, 12, 10, 46, 503],
    clc$command, 12, 6, 1, 0, 0, 0, 6, 'OCM$LINVE_ADDOF'], [
    ['DEFAULT_SECTION                ',clc$nominal_entry, 5],
    ['DEFAULT_SECTIONS               ',clc$alias_entry, 5],
    ['DS                             ',clc$abbreviation_entry, 5],
    ['EP                             ',clc$abbreviation_entry, 4],
    ['EXECUTE_PRIVILEGE              ',clc$nominal_entry, 4],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['GLK                            ',clc$abbreviation_entry, 3],
    ['GLOBAL_LOCAL_KEY               ',clc$nominal_entry, 3],
    ['RB                             ',clc$abbreviation_entry, 2],
    ['RING_BRACKETS                  ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 175,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 119,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 417,
  clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$record_type], [3],
    ['R1                             ', clc$required_field, 20], [[1, 0, clc$integer_type], [osc$invalid_ring
  , osc$max_ring, 10]],
    ['R2                             ', clc$required_field, 20], [[1, 0, clc$integer_type], [osc$invalid_ring
  , osc$max_ring, 10]],
    ['R3                             ', clc$required_field, 20], [[1, 0, clc$integer_type], [osc$invalid_ring
  , osc$max_ring, 10]]
    ],
{ PARAMETER 3
    [[1, 0, clc$record_type], [2],
    ['GLOBAL                         ', clc$required_field, 20], [[1, 0, clc$integer_type], [0, 3f(16), 10]],
    ['LOCAL                          ', clc$required_field, 20], [[1, 0, clc$integer_type], [0, 3f(16), 10]]
    ,
    '(0, 0)'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [6], [
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['EXECUTE                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['G                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['GLOBAL                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['LOCAL                          ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'execute'],
{ PARAMETER 5
    [[1, 0, clc$list_type], [401, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$record_type], [2],
      ['SECTION_NAME                   ', clc$required_field, 3], [[1, 0, clc$program_name_type]],
      ['SECTION_ATTRIBUTES             ', clc$required_field, 319], [[1, 0, clc$list_type], [303, 0,
  clc$max_list_size, TRUE],
          [[1, 0, clc$keyword_type], [8], [
          ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
          ['BINDING                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
          ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
          ['EXECUTE                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
          ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
          ['READ                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
          ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
          ['WRITE                          ', clc$nominal_entry, clc$normal_usage_entry, 2]]
          ]
        ]
      ]
    ],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$ring_brackets = 2,
      p$global_local_key = 3,
      p$execute_privilege = 4,
      p$default_section = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      ofd: oct$object_file_descriptor;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF ocp$duplicate_file (pvt [p$file].value^.file_value^, ocv$known_file_list) THEN
      osp$set_status_abnormal ('OC', oce$e_duplicate_file_named, pvt [p$file].value^.file_value^, status);
      RETURN;
    IFEND;

    NEXT ofd.name: [STRLENGTH (pvt [p$file].value^.file_value^)] IN ocv$vel_scratch_seq;
    IF ofd.name = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH10', status);
      RETURN;
    IFEND;
    ofd.name^ := pvt [p$file].value^.file_value^;
    ofd.link := NIL;

    crack_ring_brackets_parameter (pvt [p$ring_brackets], ofd.r1, ofd.r2, ofd.r3, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_key_lock_parameter (pvt [p$global_local_key], ofd.global_key, ofd.local_key, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_execute_privilege_param (pvt [p$execute_privilege], ofd.execute_privilege);

    crack_default_section_parameter (pvt [p$default_section], ofd.default_sections, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$open_linker_object_file (^ofd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$add_to_object_file_list (^ofd, ^link_parameters.object_files_to_add, status);
    IF NOT status.normal THEN
      ocp$close_linker_object_files (^ofd);
      RETURN;
    IFEND;

    ocp$add_to_known_files (pvt [p$file].value^.file_value^, ocv$known_file_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ve_generator_not_executed := TRUE;

  PROCEND add_object_file;
?? OLDTITLE ??
?? NEWTITLE := 'add_object_module', EJECT ??

  PROCEDURE add_object_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$linve_addom) add_object_module, add_object_modules, addom (
{   module, modules, m: list of program_name = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 14, 12, 22, 19, 953],
    clc$command, 4, 2, 1, 0, 0, 0, 2, 'OCM$LINVE_ADDOM'], [
    ['M                              ',clc$abbreviation_entry, 1],
    ['MODULE                         ',clc$nominal_entry, 1],
    ['MODULES                        ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$program_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$module = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      data_value: ^clt$data_value,
      last_module: ^oct$program_name_list,
      module_found: boolean,
      module_name: pmt$program_name,
      new_modules: oct$program_name_list;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    new_modules.link := NIL;

    data_value := pvt [p$module].value;
    WHILE data_value <> NIL DO
      module_name := data_value^.element_value^.program_name_value;

      ocp$search_modules_to_add (link_parameters.modules_to_add, module_name, module_found, last_module);
      IF module_found THEN
        osp$set_status_abnormal ('OC', oce$e_duplicate_module_named, module_name, status);
        RETURN;
      IFEND;

      ocp$search_modules_to_add (new_modules, module_name, module_found, last_module);
      IF module_found THEN
        osp$set_status_abnormal ('OC', oce$e_duplicate_module_named, module_name, status);
        RETURN;
      IFEND;

      NEXT last_module^.link IN ocv$vel_scratch_seq;
      last_module := last_module^.link;
      IF last_module = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH11', status);
        RETURN;
      IFEND;

      last_module^.name := module_name;
      last_module^.link := NIL;

      data_value := data_value^.link;
    WHILEND;

    ocp$search_modules_to_add (link_parameters.modules_to_add, osc$null_name, module_found, last_module);
    last_module^.link := new_modules.link;

    ve_generator_not_executed := TRUE;


  PROCEND add_object_module;
?? OLDTITLE ??
?? NEWTITLE := 'use_object_library', EJECT ??

  PROCEDURE use_object_library
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ocm$linve_useol) use_object_library, use_object_libraries, useol (
{   library, libraries, l: list of file = $required
{   ring_brackets, rb: record
{       r1: integer osc$invalid_ring..osc$max_ring
{       r2: integer osc$invalid_ring..osc$max_ring
{       r3: integer osc$invalid_ring..osc$max_ring
{     recend = $optional
{   global_local_key, glk: record
{       global: integer 0..3f(16)
{       local: integer 0..3f(16)
{     recend = (0, 0)
{   execute_privilege, ep: key
{       (execute, e)
{       (local, l)
{       (global, g)
{     keyend = execute
{   default_section, default_sections, ds: list of record
{       section_name: program_name
{       section_attributes: list rest of key
{         (read, r)
{         (write, w)
{         (execute, e)
{         (binding, b)
{       keyend
{     recend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (6),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$list_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$keyword_type_qualifier,
              keyword_specs: array [1 .. 8] of clt$keyword_specification,
            recend,
          recend,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 13, 12, 11, 42, 282],
    clc$command, 13, 6, 1, 0, 0, 0, 6, 'OCM$LINVE_USEOL'], [
    ['DEFAULT_SECTION                ',clc$nominal_entry, 5],
    ['DEFAULT_SECTIONS               ',clc$alias_entry, 5],
    ['DS                             ',clc$abbreviation_entry, 5],
    ['EP                             ',clc$abbreviation_entry, 4],
    ['EXECUTE_PRIVILEGE              ',clc$nominal_entry, 4],
    ['GLK                            ',clc$abbreviation_entry, 3],
    ['GLOBAL_LOCAL_KEY               ',clc$nominal_entry, 3],
    ['L                              ',clc$abbreviation_entry, 1],
    ['LIBRARIES                      ',clc$alias_entry, 1],
    ['LIBRARY                        ',clc$nominal_entry, 1],
    ['RB                             ',clc$abbreviation_entry, 2],
    ['RING_BRACKETS                  ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 175,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 119,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 417,
  clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$record_type], [3],
    ['R1                             ', clc$required_field, 20], [[1, 0, clc$integer_type], [osc$invalid_ring
  , osc$max_ring, 10]],
    ['R2                             ', clc$required_field, 20], [[1, 0, clc$integer_type], [osc$invalid_ring
  , osc$max_ring, 10]],
    ['R3                             ', clc$required_field, 20], [[1, 0, clc$integer_type], [osc$invalid_ring
  , osc$max_ring, 10]]
    ],
{ PARAMETER 3
    [[1, 0, clc$record_type], [2],
    ['GLOBAL                         ', clc$required_field, 20], [[1, 0, clc$integer_type], [0, 3f(16), 10]],
    ['LOCAL                          ', clc$required_field, 20], [[1, 0, clc$integer_type], [0, 3f(16), 10]]
    ,
    '(0, 0)'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [6], [
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['EXECUTE                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['G                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['GLOBAL                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['LOCAL                          ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'execute'],
{ PARAMETER 5
    [[1, 0, clc$list_type], [401, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$record_type], [2],
      ['SECTION_NAME                   ', clc$required_field, 3], [[1, 0, clc$program_name_type]],
      ['SECTION_ATTRIBUTES             ', clc$required_field, 319], [[1, 0, clc$list_type], [303, 0,
  clc$max_list_size, TRUE],
          [[1, 0, clc$keyword_type], [8], [
          ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
          ['BINDING                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
          ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
          ['EXECUTE                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
          ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
          ['READ                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
          ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
          ['WRITE                          ', clc$nominal_entry, clc$normal_usage_entry, 2]]
          ]
        ]
      ]
    ],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$library = 1,
      p$ring_brackets = 2,
      p$global_local_key = 3,
      p$execute_privilege = 4,
      p$default_section = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      data_value: ^clt$data_value,
      last_library_descriptor: ^oct$object_file_descriptor,
      last_library_name: ^oct$known_file_list,
      new_library_list: oct$object_file_descriptor,
      new_library_names: oct$known_file_list,
      ofd: oct$object_file_descriptor;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_ring_brackets_parameter (pvt [p$ring_brackets], ofd.r1, ofd.r2, ofd.r3, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_key_lock_parameter (pvt [p$global_local_key], ofd.global_key, ofd.local_key, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_execute_privilege_param (pvt [p$execute_privilege], ofd.execute_privilege);

    crack_default_section_parameter (pvt [p$default_section], ofd.default_sections, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    new_library_list.link := NIL;
    new_library_names.name := NIL;
    new_library_names.link := NIL;

    data_value := pvt [p$library].value;

    WHILE data_value <> NIL DO
      NEXT ofd.name: [STRLENGTH (data_value^.element_value^.file_value^)] IN ocv$vel_scratch_seq;
      IF ofd.name = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH12', status);
        ocp$close_linker_object_files (new_library_list.link);
        RETURN;
      IFEND;
      ofd.name^ := data_value^.element_value^.file_value^;
      ofd.link := NIL;

      IF ocp$duplicate_file (ofd.name^, ocv$known_file_list) OR
            ocp$duplicate_file (ofd.name^, new_library_names) THEN
        osp$set_status_abnormal ('OC', oce$e_duplicate_file_named, ofd.name^, status);
        ocp$close_linker_object_files (new_library_list.link);
        RETURN;
      IFEND;

      ocp$add_to_known_files (ofd.name^, new_library_names, status);
      IF NOT status.normal THEN
        ocp$close_linker_object_files (new_library_list.link);
        RETURN;
      IFEND;

      ocp$open_linker_object_file (^ofd, status);
      IF NOT status.normal THEN
        ocp$close_linker_object_files (new_library_list.link);
        RETURN;
      IFEND;

      IF NOT ofd.is_a_library THEN
        osp$set_status_abnormal ('OC', oce$e_file_is_not_library, ofd.name^, status);
        ocp$close_linker_object_files (^ofd);
        ocp$close_linker_object_files (new_library_list.link);
        RETURN;
      IFEND;

      ocp$add_to_object_file_list (^ofd, ^new_library_list, status);
      IF NOT status.normal THEN
        ocp$close_linker_object_files (new_library_list.link);
        RETURN;
      IFEND;

      data_value := data_value^.link;
    WHILEND;

    last_library_descriptor := ^link_parameters.object_libraries_to_use;
    WHILE (last_library_descriptor^.link <> NIL) DO
      last_library_descriptor := last_library_descriptor^.link;
    WHILEND;
    last_library_descriptor^.link := new_library_list.link;

    last_library_name := ^ocv$known_file_list;
    WHILE last_library_name^.link <> NIL DO
      last_library_name := last_library_name^.link;
    WHILEND;
    last_library_name^.link := new_library_names.link;

    ve_generator_not_executed := TRUE;


  PROCEND use_object_library;
?? OLDTITLE ??
?? NEWTITLE := 'use_symbol_table', EJECT ??

  PROCEDURE use_symbol_table
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$linve_usest) use_symbol_table, use_symbol_tables, usest (
{   symbol_table, symbol_tables, st: list of file = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 14, 12, 22, 51, 810],
    clc$command, 4, 2, 1, 0, 0, 0, 2, 'OCM$LINVE_USEST'], [
    ['ST                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2],
    ['SYMBOL_TABLE                   ',clc$nominal_entry, 1],
    ['SYMBOL_TABLES                  ',clc$alias_entry, 1]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$symbol_table = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      data_value: ^clt$data_value,
      last_symbol_table_descriptor: ^oct$symbol_table_descriptor,
      last_symbol_table_name: ^oct$known_file_list,
      new_linker_symbol_tables: oct$symbol_table_descriptor,
      new_symbol_table_names: oct$known_file_list,
      std: oct$symbol_table_descriptor;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    new_linker_symbol_tables.link := NIL;
    new_symbol_table_names.name := NIL;
    new_symbol_table_names.link := NIL;

    data_value := pvt [p$symbol_table].value;

    WHILE data_value <> NIL DO
      NEXT std.name: [STRLENGTH (data_value^.element_value^.file_value^)] IN ocv$vel_scratch_seq;
      IF std.name = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH13', status);
        ocp$close_linker_symbol_tables (new_linker_symbol_tables.link);
        RETURN;
      IFEND;
      std.name^ := data_value^.element_value^.file_value^;
      std.link := NIL;

      IF ocp$duplicate_file (std.name^, ocv$known_file_list) OR
            ocp$duplicate_file (std.name^, new_symbol_table_names) THEN
        osp$set_status_abnormal ('OC', oce$e_duplicate_file_named, std.name^, status);
        ocp$close_linker_symbol_tables (new_linker_symbol_tables.link);
        RETURN;
      IFEND;

      ocp$add_to_known_files (std.name^, new_symbol_table_names, status);
      IF NOT status.normal THEN
        ocp$close_linker_symbol_tables (new_linker_symbol_tables.link);
        RETURN;
      IFEND;

      ocp$open_linker_symbol_table (^std, status);
      IF NOT status.normal THEN
        ocp$close_linker_symbol_tables (new_linker_symbol_tables.link);
        RETURN;
      IFEND;

      ocp$add_to_symbol_table_list (^std, ^new_linker_symbol_tables, status);
      IF NOT status.normal THEN
        ocp$close_linker_symbol_tables (^std);
        ocp$close_linker_symbol_tables (new_linker_symbol_tables.link);
        RETURN;
      IFEND;

      data_value := data_value^.link;
    WHILEND;

    last_symbol_table_descriptor := ^link_parameters.symbol_tables_to_use;
    WHILE last_symbol_table_descriptor^.link <> NIL DO
      last_symbol_table_descriptor := last_symbol_table_descriptor^.link;
    WHILEND;
    last_symbol_table_descriptor^.link := new_linker_symbol_tables.link;

    last_symbol_table_name := ^ocv$known_file_list;
    WHILE last_symbol_table_name^.link <> NIL DO
      last_symbol_table_name := last_symbol_table_name^.link;
    WHILEND;
    last_symbol_table_name^.link := new_symbol_table_names.link;

    ve_generator_not_executed := TRUE;

  PROCEND use_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := 'retain_common_blocks', EJECT ??

  PROCEDURE retain_common_blocks
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$linve_retcb) retain_common_blocks, retain_common_block, retcb (
{   name, names, n: list of program_name = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 14, 12, 23, 2, 866],
    clc$command, 4, 2, 1, 0, 0, 0, 2, 'OCM$LINVE_RETCB'], [
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$program_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      data_value: ^clt$data_value,
      last_common_block: ^oct$program_name_list,
      name: pmt$program_name,
      new_common_blocks: oct$program_name_list;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (link_parameters.common_blocks_to_retain.name = occ$retain_all_common_blocks) THEN
      RETURN; { ---->
    IFEND;

    new_common_blocks.link := NIL;
    last_common_block := ^new_common_blocks;

    data_value := pvt [p$name].value;

  /get_common_block_names/
    WHILE data_value <> NIL DO
      name := data_value^.element_value^.program_name_value;

      IF (name = 'ALL') THEN
        link_parameters.common_blocks_to_retain.name := occ$retain_all_common_blocks;
        link_parameters.common_blocks_to_retain.link := NIL;
        new_common_blocks.link := NIL;
        EXIT /get_common_block_names/;
      IFEND;

      NEXT last_common_block^.link IN ocv$vel_scratch_seq;
      last_common_block := last_common_block^.link;
      IF last_common_block = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH14', status);
        RETURN;
      IFEND;

      last_common_block^.name := name;
      last_common_block^.link := NIL;

      data_value := data_value^.link;
    WHILEND /get_common_block_names/;

    last_common_block := ^link_parameters.common_blocks_to_retain;
    WHILE last_common_block^.link <> NIL DO
      last_common_block := last_common_block^.link;
    WHILEND;

    last_common_block^.link := new_common_blocks.link;

    ve_generator_not_executed := TRUE;


  PROCEND retain_common_blocks;
?? OLDTITLE ??
?? NEWTITLE := 'include_linked_symbols', EJECT ??

  PROCEDURE include_linked_symbols
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$linve_incls) include_linked_symbols, incls (
{   pointer, p: program_name = $required
{   section, s: program_name = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 14, 12, 23, 23, 709],
    clc$command, 5, 3, 2, 0, 0, 0, 3, 'OCM$LINVE_INCLS'], [
    ['P                              ',clc$abbreviation_entry, 1],
    ['POINTER                        ',clc$nominal_entry, 1],
    ['S                              ',clc$abbreviation_entry, 2],
    ['SECTION                        ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$program_name_type]],
{ PARAMETER 2
    [[1, 0, clc$program_name_type]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$pointer = 1,
      p$section = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      last: ^oct$pointer_list,
      pointer: ^oct$pointer_list;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT pointer IN ocv$vel_scratch_seq;
    IF pointer = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH15', status);
      RETURN;
    IFEND;

    pointer^.name := pvt [p$pointer].value^.program_name_value;
    pointer^.section_name := pvt [p$section].value^.program_name_value;
    pointer^.link := NIL;

    last := ^link_parameters.symbol_table_pointers;
    WHILE last^.link <> NIL DO
      last := last^.link;
    WHILEND;

    last^.link := pointer;

    ve_generator_not_executed := TRUE;


  PROCEND include_linked_symbols;
?? OLDTITLE ??
?? NEWTITLE := 'include_message_module', EJECT ??

  PROCEDURE include_message_module
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$linve_incmm) include_message_module, incmm (
{   module, m: program_name = $required
{   pointer, p: program_name = $required
{   section, s: program_name = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 14, 12, 24, 18, 542],
    clc$command, 7, 4, 3, 0, 0, 0, 4, 'OCM$LINVE_INCMM'], [
    ['M                              ',clc$abbreviation_entry, 1],
    ['MODULE                         ',clc$nominal_entry, 1],
    ['P                              ',clc$abbreviation_entry, 2],
    ['POINTER                        ',clc$nominal_entry, 2],
    ['S                              ',clc$abbreviation_entry, 3],
    ['SECTION                        ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$program_name_type]],
{ PARAMETER 2
    [[1, 0, clc$program_name_type]],
{ PARAMETER 3
    [[1, 0, clc$program_name_type]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$module = 1,
      p$pointer = 2,
      p$section = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      last: ^^oct$message_module_list,
      pointer: ^oct$message_module_list;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT pointer IN ocv$vel_scratch_seq;
    IF pointer = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH16', status);
      RETURN;
    IFEND;

    pointer^.module_name := pvt [p$module].value^.program_name_value;
    pointer^.pointer_name := pvt [p$pointer].value^.program_name_value;
    pointer^.section_name := pvt [p$section].value^.program_name_value;

    pointer^.link := NIL;

    last := ^link_parameters.message_module_list;
    WHILE last^ <> NIL DO
      last := ^last^^.link;
    WHILEND;
    last^ := pointer;

    ve_generator_not_executed := TRUE;


  PROCEND include_message_module;
?? OLDTITLE ??
?? NEWTITLE := 'include_recovery_name_table', EJECT ??

  PROCEDURE include_recovery_name_table
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$linve_incrnt) include_recovery_name_table, incrnt (
{   pointer, p: program_name = $required
{   section, s: program_name = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 14, 12, 24, 34, 598],
    clc$command, 5, 3, 2, 0, 0, 0, 3, 'OCM$LINVE_INCRNT'], [
    ['P                              ',clc$abbreviation_entry, 1],
    ['POINTER                        ',clc$nominal_entry, 1],
    ['S                              ',clc$abbreviation_entry, 2],
    ['SECTION                        ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$program_name_type]],
{ PARAMETER 2
    [[1, 0, clc$program_name_type]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$pointer = 1,
      p$section = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    link_parameters.recovery_name_table_pointer.name := pvt [p$pointer].value^.program_name_value;
    link_parameters.recovery_name_table_pointer.section_name := pvt [p$section].value^.program_name_value;

    ve_generator_not_executed := TRUE;


  PROCEND include_recovery_name_table;
?? OLDTITLE ??
?? NEWTITLE := 'add_recovery_addresses', EJECT ??

  PROCEDURE add_recovery_addresses
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$linve_addra) add_recovery_addresses, add_recovery_address, addra (
{   name, names, n: list of program_name = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 14, 12, 24, 51, 907],
    clc$command, 4, 2, 1, 0, 0, 0, 2, 'OCM$LINVE_ADDRA'], [
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$program_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      data_value: ^clt$data_value,
      last_address: ^oct$program_name_list,
      new_addresses: oct$program_name_list;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    new_addresses.link := NIL;
    last_address := ^new_addresses;

    data_value := pvt [p$name].value;
    WHILE data_value <> NIL DO
      NEXT last_address^.link IN ocv$vel_scratch_seq;
      last_address := last_address^.link;
      IF last_address = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH17', status);
        RETURN;
      IFEND;

      last_address^.name := data_value^.element_value^.program_name_value;
      last_address^.link := NIL;

      data_value := data_value^.link;
    WHILEND;

    last_address := ^link_parameters.recovery_addresses;
    WHILE last_address^.link <> NIL DO
      last_address := last_address^.link;
    WHILEND;

    last_address^.link := new_addresses.link;

    ve_generator_not_executed := TRUE;

  PROCEND add_recovery_addresses;
?? OLDTITLE ??
?? NEWTITLE := 'initailize_heap_pointer', EJECT ??

  PROCEDURE initialize_heap_pointer
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$linve_inihp) initialize_heap_pointer, inihp (
{   pointer, p: program_name = $required
{   section, s: program_name = $optional
{   segment_number, sn: integer 0..osc$maximum_segment = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 14, 12, 25, 10, 516],
    clc$command, 7, 4, 1, 0, 0, 0, 4, 'OCM$LINVE_INIHP'], [
    ['P                              ',clc$abbreviation_entry, 1],
    ['POINTER                        ',clc$nominal_entry, 1],
    ['S                              ',clc$abbreviation_entry, 2],
    ['SECTION                        ',clc$nominal_entry, 2],
    ['SEGMENT_NUMBER                 ',clc$nominal_entry, 3],
    ['SN                             ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$program_name_type]],
{ PARAMETER 2
    [[1, 0, clc$program_name_type]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, osc$maximum_segment, 10]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$pointer = 1,
      p$section = 2,
      p$segment_number = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      last: ^oct$pointer_list,
      pointer: ^oct$pointer_list;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT pointer IN ocv$vel_scratch_seq;
    IF pointer = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH18', status);
      RETURN;
    IFEND;

    pointer^.name := pvt [p$pointer].value^.program_name_value;

    IF pvt [p$section].specified THEN
      pointer^.section_name := pvt [p$section].value^.program_name_value;
    ELSE
      pointer^.section_name := osc$null_name;
    IFEND;

    IF pvt [p$segment_number].specified THEN
      IF pointer^.section_name = osc$null_name THEN
        pointer^.segment_number := pvt [p$segment_number].value^.integer_value.value;
      ELSE
        osp$set_status_condition (oce$e_section_segment_together, status);
        RETURN;
      IFEND;
    ELSE
      IF pointer^.section_name = osc$null_name THEN
        osp$set_status_condition (oce$e_missing_section_segment, status);
        RETURN;
      IFEND;
    IFEND;

    pointer^.link := NIL;

    last := ^link_parameters.heap_pointers;
    WHILE last^.link <> NIL DO
      last := last^.link;
    WHILEND;

    last^.link := pointer;

    ve_generator_not_executed := TRUE;


  PROCEND initialize_heap_pointer;
?? OLDTITLE ??
?? NEWTITLE := 'use_debug_table', EJECT ??

  PROCEDURE use_debug_table
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$linve_usedt) use_debug_table, usedt (
{   debug_table, dt: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 14, 12, 25, 25, 875],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OCM$LINVE_USEDT'], [
    ['DEBUG_TABLE                    ',clc$nominal_entry, 1],
    ['DT                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$debug_table = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT link_parameters.input_debug_table: [STRLENGTH (pvt [p$debug_table].value^.file_value^)] IN
          ocv$vel_scratch_seq;
    IF link_parameters.input_debug_table = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH19', status);
      RETURN;
    IFEND;
    link_parameters.input_debug_table^ := pvt [p$debug_table].value^.file_value^;

    ve_generator_not_executed := TRUE;

  PROCEND use_debug_table;
?? OLDTITLE ??
?? NEWTITLE := 'include_debug_table', EJECT ??

  PROCEDURE include_debug_table
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$linve_incdt) include_debug_table, incdt (
{   pointer, p: program_name = $required
{   section, s: program_name = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 14, 12, 25, 39, 35],
    clc$command, 5, 3, 2, 0, 0, 0, 3, 'OCM$LINVE_INCDT'], [
    ['P                              ',clc$abbreviation_entry, 1],
    ['POINTER                        ',clc$nominal_entry, 1],
    ['S                              ',clc$abbreviation_entry, 2],
    ['SECTION                        ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$program_name_type]],
{ PARAMETER 2
    [[1, 0, clc$program_name_type]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$pointer = 1,
      p$section = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      pointer: ^oct$pointer_list;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT pointer IN ocv$vel_scratch_seq;
    IF pointer = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH20', status);
      RETURN;
    IFEND;

    pointer^.name := pvt [p$pointer].value^.program_name_value;
    pointer^.section_name := pvt [p$section].value^.program_name_value;

    pointer^.link := NIL;
    link_parameters.debug_table_pointers.link := pointer;

    ve_generator_not_executed := TRUE;


  PROCEND include_debug_table;
?? OLDTITLE ??
?? NEWTITLE := 'set_symbol_table_id', EJECT ??

  PROCEDURE set_symbol_table_id
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$linve_setsti) set_symbol_table_id, setsti (
{   symbol_table, st: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 14, 12, 26, 38, 610],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OCM$LINVE_SETSTI'], [
    ['ST                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2],
    ['SYMBOL_TABLE                   ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$symbol_table = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      std: ^oct$symbol_table_descriptor;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    std := link_parameters.symbol_tables_to_use.link;

    WHILE (std <> NIL) AND (pvt [p$symbol_table].value^.file_value^ <> std^.name^) DO
      std := std^.link;
    WHILEND;

    IF std = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_symbol_table_not_defined, pvt [p$symbol_table].value^.file_value^,
            status);

    ELSE
      link_parameters.symbol_table_id := std^.header^.id;
      ve_generator_not_executed := TRUE;
    IFEND;

  PROCEND set_symbol_table_id;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_symbol_table_id', EJECT ??

  PROCEDURE initialize_symbol_table_id
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$linve_inisti) initialize_symbol_table_id, inisti (
{   id, i: program_name = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 14, 12, 26, 50, 79],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OCM$LINVE_INISTI'], [
    ['I                              ',clc$abbreviation_entry, 1],
    ['ID                             ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$program_name_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$id = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    link_parameters.symbol_table_id_variable := pvt [p$id].value^.program_name_value;

    ve_generator_not_executed := TRUE;


  PROCEND initialize_symbol_table_id;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_build_level', EJECT ??

  PROCEDURE initialize_build_level
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$linve_inibl) initialize_build_level, inibl (
{   name, names, n: list of program_name = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 14, 12, 27, 1, 499],
    clc$command, 4, 2, 1, 0, 0, 0, 2, 'OCM$LINVE_INIBL'], [
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['NAMES                          ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$program_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      data_value: ^clt$data_value,
      last_variable: ^oct$program_name_list,
      new_variables: oct$program_name_list;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    new_variables.link := NIL;
    last_variable := ^new_variables;

    data_value := pvt [p$name].value;
    WHILE data_value <> NIL DO
      NEXT last_variable^.link IN ocv$vel_scratch_seq;
      last_variable := last_variable^.link;
      IF last_variable = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH21', status);
        RETURN;
      IFEND;

      last_variable^.name := data_value^.element_value^.program_name_value;
      last_variable^.link := NIL;

      data_value := data_value^.link;
    WHILEND;

    last_variable := ^link_parameters.build_level_variables;
    WHILE last_variable^.link <> NIL DO
      last_variable := last_variable^.link;
    WHILEND;

    last_variable^.link := new_variables.link;

    ve_generator_not_executed := TRUE;


  PROCEND initialize_build_level;
?? OLDTITLE ??
?? NEWTITLE := 'delete_declaration_matching', EJECT ??

  PROCEDURE delete_declaration_matching
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$linve_deldm) delete_declaration_matching, deldm (
{   entry_points, entry_point, ep: list of program_name = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 14, 12, 27, 23, 461],
    clc$command, 4, 2, 1, 0, 0, 0, 2, 'OCM$LINVE_DELDM'], [
    ['ENTRY_POINT                    ',clc$alias_entry, 1],
    ['ENTRY_POINTS                   ',clc$nominal_entry, 1],
    ['EP                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$program_name_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$entry_points = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      data_value: ^clt$data_value,
      last_entry_point: ^oct$program_name_list,
      new_entry_points: oct$program_name_list;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    new_entry_points.link := NIL;
    last_entry_point := ^new_entry_points;

    data_value := pvt [p$entry_points].value;
    WHILE data_value <> NIL DO
      NEXT last_entry_point^.link IN ocv$vel_scratch_seq;
      last_entry_point := last_entry_point^.link;
      IF last_entry_point = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH22', status);
        RETURN;
      IFEND;

      last_entry_point^.name := data_value^.element_value^.program_name_value;
      last_entry_point^.link := NIL;

      data_value := data_value^.link;
    WHILEND;

    last_entry_point := ^link_parameters.delete_declaration_matching;
    WHILE last_entry_point^.link <> NIL DO
      last_entry_point := last_entry_point^.link;
    WHILEND;

    last_entry_point^.link := new_entry_points.link;

    ve_generator_not_executed := TRUE;

  PROCEND delete_declaration_matching;
?? OLDTITLE ??
?? NEWTITLE := 've_generate', EJECT ??

  PROCEDURE ve_generate
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$linve_genvm) generate_virtual_memory, genvm (
{   virtual_image, vm: file = $required
{   symbol_table, st: file = $optional
{   debug_table, dt: file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 3, 14, 12, 27, 45, 216],
    clc$command, 7, 4, 1, 0, 0, 0, 4, 'OCM$LINVE_GENVM'], [
    ['DEBUG_TABLE                    ',clc$nominal_entry, 3],
    ['DT                             ',clc$abbreviation_entry, 3],
    ['ST                             ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['SYMBOL_TABLE                   ',clc$nominal_entry, 2],
    ['VIRTUAL_IMAGE                  ',clc$nominal_entry, 1],
    ['VM                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$file_type]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$virtual_image = 1,
      p$symbol_table = 2,
      p$debug_table = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT link_parameters.virtual_image: [STRLENGTH (pvt [p$virtual_image].value^.file_value^)] IN
          ocv$vel_scratch_seq;
    IF link_parameters.virtual_image = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH23', status);
      RETURN;
    IFEND;
    link_parameters.virtual_image^ := pvt [p$virtual_image].value^.file_value^;

    IF pvt [p$symbol_table].specified THEN
      NEXT link_parameters.symbol_table: [STRLENGTH (pvt [p$symbol_table].value^.file_value^)] IN
            ocv$vel_scratch_seq;
      IF link_parameters.symbol_table = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH24', status);
        RETURN;
      IFEND;
      link_parameters.symbol_table^ := pvt [p$symbol_table].value^.file_value^;
    IFEND;

    IF pvt [p$debug_table].specified THEN
      NEXT link_parameters.debug_table: [STRLENGTH (pvt [p$debug_table].value^.file_value^)] IN
            ocv$vel_scratch_seq;
      IF link_parameters.debug_table = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'LCH25', status);
        RETURN;
      IFEND;
      link_parameters.debug_table^ := pvt [p$debug_table].value^.file_value^;
    IFEND;

    IF ((link_parameters.symbol_table <> NIL) AND (link_parameters.symbol_table^ =
          link_parameters.virtual_image^)) OR ((link_parameters.debug_table <> NIL) AND
          (link_parameters.debug_table^ = link_parameters.virtual_image^)) THEN
      osp$set_status_abnormal ('OC', oce$e_duplicate_file_named, link_parameters.virtual_image^, status);
      RETURN;
    ELSEIF (link_parameters.symbol_table <> NIL) AND (link_parameters.debug_table <> NIL) AND
          (link_parameters.symbol_table^ = link_parameters.debug_table^) THEN
      osp$set_status_abnormal ('OC', oce$e_duplicate_file_named, link_parameters.symbol_table^, status);
      RETURN;
    IFEND;

    ocp$execute_the_ve_linker (link_parameters, status);

    IF status.condition <> oce$e_generate_status THEN
      ocp$close_linker_object_files (link_parameters.object_files_to_add.link);
      ocp$close_linker_object_files (link_parameters.object_libraries_to_use.link);
      ocp$close_linker_symbol_tables (link_parameters.symbol_tables_to_use.link);
      initialize_the_linker;
    IFEND;

  PROCEND ve_generate;
?? OLDTITLE ??
?? NEWTITLE := 'quit', EJECT ??

  PROCEDURE quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$linve_qui) quit, qui (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [89, 3, 14, 12, 28, 24, 178],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'OCM$LINVE_QUI'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_include (utility_name, status);

  PROCEND quit;
?? OLDTITLE ??
?? NEWTITLE := 'next_available_segment', EJECT ??

  PROCEDURE next_available_segment
    (    parameter_list: clt$parameter_list;
     VAR work_area { input, output } : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (ocm$linve_nexas) $next_available_segment

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 3, 14, 12, 21, 5, 87],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OCM$LINVE_NEXAS']];

?? FMT (FORMAT := ON) ??
?? POP ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_integer_value (ocv$next_available_segment, {radix} 10, {radix_specified} FALSE, work_area,
          result);

  PROCEND next_available_segment;
?? OLDTITLE ??
?? NEWTITLE := 'ocp$_link_virtual_environment', EJECT ??

  PROGRAM ocp$_link_virtual_environment
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ocm$linve) link_virtual_environment, linve (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [89, 1, 6, 8, 39, 11, 245],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'OCM$LINVE'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

{ table name=linkve_command_list type=command section_name=read_only scope=local
{ command (set_link_options              ,set_link_option,  setlo) p=set_link_options cm=local
{ command (define_segment                ,defs) p=define_segment cm=local
{ command (add_object_file               ,addof) p=add_object_file cm=local
{ command (add_object_module             ,add_object_modules,  addom) p=add_object_module cm=local
{ command (use_object_library            ,use_object_libraries,  useol) p=use_object_library cm=local
{ command (use_symbol_table              ,use_symbol_tables,  usest) p=use_symbol_table cm=local
{ command (retain_common_blocks          ,retain_common_block, retcb) p=retain_common_blocks cm=local
{ command (include_linked_symbols        ,incls) p=include_linked_symbols cm=local
{ command (include_message_module        ,incmm) p=include_message_module cm=local
{ command (include_recovery_name_table   ,incrnt) p=include_recovery_name_table cm=local
{ command (initialize_heap_pointer       ,inihp) p=initialize_heap_pointer cm=local
{ command (set_symbol_table_id           ,setsti, setsi) p=set_symbol_table_id cm=local
{ command (initialize_symbol_table_id    ,inisti) p=initialize_symbol_table_id cm=local
{ command (include_debug_table           ,incdt) p=include_debug_table cm=local
{ command (use_debug_table               ,usedt) p=use_debug_table cm=local
{ command (initialize_build_level        ,inibl) p=initialize_build_level cm=local
{ command (delete_declaration_matching   ,deldm) p=delete_declaration_matching cm=local
{ command (generate_virtual_memory       ,genvm) p=ve_generate cm=local
{ command (quit                          ,qui) p=quit cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

    VAR
      linkve_command_list: [STATIC, READ, read_only] ^clt$command_table := ^linkve_command_list_entries,

      linkve_command_list_entries: [STATIC, READ, read_only] array [1 .. 44] of clt$command_table_entry := [
            {} ['ADDOF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^add_object_file],
            {} ['ADDOM                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^add_object_module],
            {} ['ADD_OBJECT_FILE                ', clc$nominal_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^add_object_file],
            {} ['ADD_OBJECT_MODULE              ', clc$nominal_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^add_object_module],
            {} ['ADD_OBJECT_MODULES             ', clc$alias_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^add_object_module],
            {} ['DEFINE_SEGMENT                 ', clc$nominal_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^define_segment],
            {} ['DEFS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^define_segment],
            {} ['DELDM                          ', clc$abbreviation_entry, clc$normal_usage_entry, 17,
            clc$automatically_log, clc$linked_call, ^delete_declaration_matching],
            {} ['DELETE_DECLARATION_MATCHING    ', clc$nominal_entry, clc$normal_usage_entry, 17,
            clc$automatically_log, clc$linked_call, ^delete_declaration_matching],
            {} ['GENERATE_VIRTUAL_MEMORY        ', clc$nominal_entry, clc$normal_usage_entry, 18,
            clc$automatically_log, clc$linked_call, ^ve_generate],
            {} ['GENVM                          ', clc$abbreviation_entry, clc$normal_usage_entry, 18,
            clc$automatically_log, clc$linked_call, ^ve_generate],
            {} ['INCDT                          ', clc$abbreviation_entry, clc$normal_usage_entry, 14,
            clc$automatically_log, clc$linked_call, ^include_debug_table],
            {} ['INCLS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
            clc$automatically_log, clc$linked_call, ^include_linked_symbols],
            {} ['INCLUDE_DEBUG_TABLE            ', clc$nominal_entry, clc$normal_usage_entry, 14,
            clc$automatically_log, clc$linked_call, ^include_debug_table],
            {} ['INCLUDE_LINKED_SYMBOLS         ', clc$nominal_entry, clc$normal_usage_entry, 8,
            clc$automatically_log, clc$linked_call, ^include_linked_symbols],
            {} ['INCLUDE_MESSAGE_MODULE         ', clc$nominal_entry, clc$normal_usage_entry, 9,
            clc$automatically_log, clc$linked_call, ^include_message_module],
            {} ['INCLUDE_RECOVERY_NAME_TABLE    ', clc$nominal_entry, clc$normal_usage_entry, 10,
            clc$automatically_log, clc$linked_call, ^include_recovery_name_table],
            {} ['INCMM                          ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
            clc$automatically_log, clc$linked_call, ^include_message_module],
            {} ['INCRNT                         ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
            clc$automatically_log, clc$linked_call, ^include_recovery_name_table],
            {} ['INIBL                          ', clc$abbreviation_entry, clc$normal_usage_entry, 16,
            clc$automatically_log, clc$linked_call, ^initialize_build_level],
            {} ['INIHP                          ', clc$abbreviation_entry, clc$normal_usage_entry, 11,
            clc$automatically_log, clc$linked_call, ^initialize_heap_pointer],
            {} ['INISTI                         ', clc$abbreviation_entry, clc$normal_usage_entry, 13,
            clc$automatically_log, clc$linked_call, ^initialize_symbol_table_id],
            {} ['INITIALIZE_BUILD_LEVEL         ', clc$nominal_entry, clc$normal_usage_entry, 16,
            clc$automatically_log, clc$linked_call, ^initialize_build_level],
            {} ['INITIALIZE_HEAP_POINTER        ', clc$nominal_entry, clc$normal_usage_entry, 11,
            clc$automatically_log, clc$linked_call, ^initialize_heap_pointer],
            {} ['INITIALIZE_SYMBOL_TABLE_ID     ', clc$nominal_entry, clc$normal_usage_entry, 13,
            clc$automatically_log, clc$linked_call, ^initialize_symbol_table_id],
            {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 19,
            clc$automatically_log, clc$linked_call, ^quit],
            {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 19,
            clc$automatically_log, clc$linked_call, ^quit],
            {} ['RETAIN_COMMON_BLOCK            ', clc$alias_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^retain_common_blocks],
            {} ['RETAIN_COMMON_BLOCKS           ', clc$nominal_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^retain_common_blocks],
            {} ['RETCB                          ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^retain_common_blocks],
            {} ['SETLO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^set_link_options],
            {} ['SETSI                          ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
            clc$automatically_log, clc$linked_call, ^set_symbol_table_id],
            {} ['SETSTI                         ', clc$alias_entry, clc$normal_usage_entry, 12,
            clc$automatically_log, clc$linked_call, ^set_symbol_table_id],
            {} ['SET_LINK_OPTION                ', clc$alias_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^set_link_options],
            {} ['SET_LINK_OPTIONS               ', clc$nominal_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^set_link_options],
            {} ['SET_SYMBOL_TABLE_ID            ', clc$nominal_entry, clc$normal_usage_entry, 12,
            clc$automatically_log, clc$linked_call, ^set_symbol_table_id],
            {} ['USEDT                          ', clc$abbreviation_entry, clc$normal_usage_entry, 15,
            clc$automatically_log, clc$linked_call, ^use_debug_table],
            {} ['USEOL                          ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^use_object_library],
            {} ['USEST                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^use_symbol_table],
            {} ['USE_DEBUG_TABLE                ', clc$nominal_entry, clc$normal_usage_entry, 15,
            clc$automatically_log, clc$linked_call, ^use_debug_table],
            {} ['USE_OBJECT_LIBRARIES           ', clc$alias_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^use_object_library],
            {} ['USE_OBJECT_LIBRARY             ', clc$nominal_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^use_object_library],
            {} ['USE_SYMBOL_TABLE               ', clc$nominal_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^use_symbol_table],
            {} ['USE_SYMBOL_TABLES              ', clc$alias_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^use_symbol_table]];

?? POP ??

{ table linkve_function_table type=function section_name=read_only
{ function $next_available_segment processor=next_available_segment cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

    VAR
      linkve_function_table: [STATIC, READ, read_only] ^clt$function_processor_table :=
            ^linkve_function_table_entries,

      linkve_function_table_entries: [STATIC, READ, read_only] array [1 .. 1] of
            clt$function_proc_table_entry := [
            {} ['$NEXT_AVAILABLE_SEGMENT        ', clc$nominal_entry, clc$normal_usage_entry, 1,
            clc$linked_call, ^next_available_segment]];

?? POP ??

    VAR
      local_status: ost$status,
      segment_pointer: amt$segment_pointer,
      utility_attributes: array [1 .. 3] of clt$utility_attribute;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    utility_attributes [1].key := clc$utility_command_table;
    utility_attributes [1].command_table := linkve_command_list;
    utility_attributes [2].key := clc$utility_function_proc_table;
    utility_attributes [2].function_processor_table := linkve_function_table;
    utility_attributes [3].key := clc$utility_prompt;
    utility_attributes [3].prompt.value := utility_prompt;
    utility_attributes [3].prompt.size := utility_prompt_length;

    ocp$create_transient_segment (amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocv$vel_scratch_seq := segment_pointer.sequence_pointer;

    initialize_the_linker;

    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, utility_prompt, utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF ve_generator_not_executed THEN
      osp$set_status_condition (oce$w_generator_not_executed, status);
    IFEND;

    clp$end_utility (utility_name, local_status);
    IF (NOT local_status.normal) AND status.normal THEN
      status := local_status;
    IFEND;

  PROCEND ocp$_link_virtual_environment;
?? OLDTITLE ??

MODEND ocm$ve_linker_command_handlers;
*DECK DECK=OCM$VE_LINKER_UTILITIES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: VE Linker Utilites' ??
MODULE ocm$ve_linker_utilities;

{ PURPOSE:
{   Utility routines used by the VE Linker.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc llt$object_library_header
*copyc occ$symbol_table_version
*copyc oce$library_generator_errors
*copyc oce$ve_linker_exceptions
*copyc oct$known_file_list
*copyc oct$object_file_descriptor
*copyc oct$output_segment_descriptor
*copyc oct$program_name_list
*copyc oct$section_name_list
*copyc oct$segment
*copyc oct$symbol_table_descriptor
*copyc pmt$linker_debug_table_header
?? POP ??
*copyc amp$get_segment_pointer
*copyc fsp$close_file
*copyc fsp$get_open_information
*copyc fsp$open_file
*copyc osp$append_status_parameter
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc ocv$predefined_segment_list
*copyc ocv$section_name_list
*copyc ocv$vel_scratch_seq
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$search_modules_to_add', EJECT ??

  PROCEDURE [XDCL] ocp$search_modules_to_add
    (VAR modules_to_add: oct$program_name_list;
         module_name: pmt$program_name;
     VAR module_found: boolean;
     VAR module_before: ^oct$program_name_list);


    module_before := ^modules_to_add;

    WHILE (module_before^.link <> NIL) DO
      IF module_before^.link^.name = module_name THEN
        module_found := TRUE;
        RETURN;
      IFEND;

      module_before := module_before^.link;
    WHILEND;

    module_found := FALSE;


  PROCEND ocp$search_modules_to_add;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$duplicate_segment_number', EJECT ??

  FUNCTION [XDCL] ocp$duplicate_segment_number
    (    segment_number: oct$segment): boolean;


    VAR
      segment_descriptor: ^oct$output_segment_descriptor;


    segment_descriptor := ocv$predefined_segment_list.link;

    WHILE segment_descriptor <> NIL DO
      IF segment_descriptor^.number = segment_number THEN
        ocp$duplicate_segment_number := TRUE;
        RETURN;
      IFEND;

      segment_descriptor := segment_descriptor^.link;
    WHILEND;

    ocp$duplicate_segment_number := FALSE;


  FUNCEND ocp$duplicate_segment_number;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$duplicate_section_name', EJECT ??

  FUNCTION [XDCL] ocp$duplicate_section_name
    (    section_name: pmt$program_name): boolean;


    VAR
      section_name_list: ^oct$section_name_list;


    section_name_list := ocv$section_name_list.link;

    WHILE section_name_list <> NIL DO
      IF section_name_list^.name = section_name THEN
        ocp$duplicate_section_name := TRUE;
        RETURN;
      IFEND;

      section_name_list := section_name_list^.link;
    WHILEND;

    ocp$duplicate_section_name := FALSE;


  FUNCEND ocp$duplicate_section_name;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$duplicate_file', EJECT ??

  FUNCTION [XDCL] ocp$duplicate_file
    (    file_name: fst$file_reference;
         known_file_list: oct$known_file_list): boolean;


    VAR
      known_file: ^oct$known_file_list;


    known_file := ^known_file_list;

    REPEAT
      IF (known_file^.name <> NIL) AND (known_file^.name^ = file_name) THEN
        ocp$duplicate_file := TRUE;
        RETURN;
      IFEND;

      known_file := known_file^.link;
    UNTIL known_file = NIL;

    ocp$duplicate_file := FALSE;


  FUNCEND ocp$duplicate_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$add_to_known_files', EJECT ??

  PROCEDURE [XDCL] ocp$add_to_known_files
    (    file_name: fst$file_reference;
     VAR known_file_list: oct$known_file_list;
     VAR status: ost$status);


    VAR
      known_file: ^oct$known_file_list;


    NEXT known_file IN ocv$vel_scratch_seq;
    IF known_file = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'VLU1', status);
      RETURN;
    IFEND;

    NEXT known_file^.name: [STRLENGTH (file_name)] IN ocv$vel_scratch_seq;
    IF known_file^.name = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'VLU2', status);
      RETURN;
    IFEND;

    known_file^.name^ := file_name;
    known_file^.link := known_file_list.link;
    known_file_list.link := known_file;


  PROCEND ocp$add_to_known_files;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$open_linker_object_file', EJECT ??

  PROCEDURE [XDCL] ocp$open_linker_object_file
    (    ofd: ^oct$object_file_descriptor;
     VAR status: ost$status);


    VAR
      attachment_options: array [1 .. 2] of fst$attachment_option,
      cycle_attribute_values: fst$cycle_attribute_values,
      i: 0 .. llc$max_dictionaries_on_library,
      ignore_user_defined_attr_size: fst$user_defined_attribute_size,
      library_dictionary: ^llt$object_library_dictionaries,
      object_library_hdr: ^llt$object_library_header_v1_0,
      object_library_header: ^llt$object_library_header,
      validation_attributes: array [1 .. 2] of fst$file_cycle_attribute;


    status.normal := TRUE;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_options [1].share_modes.selector := fsc$determine_from_access_modes;
    attachment_options [2].selector := fsc$create_file;
    attachment_options [2].create_file := FALSE;
    validation_attributes [1].selector := fsc$file_contents_and_processor;
    validation_attributes [1].file_contents := fsc$object_library;
    validation_attributes [1].file_processor := fsc$unknown_processor;
    validation_attributes [2].selector := fsc$file_contents_and_processor;
    validation_attributes [2].file_contents := fsc$object_data;
    validation_attributes [2].file_processor := fsc$unknown_processor;

    fsp$open_file (ofd^.name^, amc$segment, ^attachment_options, {default_creation_attributes} NIL,
          {mandated_creation_attributes} NIL, ^validation_attributes, {attribute_override} NIL, ofd^.id,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$get_open_information (ofd^.id, {attachment_information} NIL, {catalog_information} NIL,
          {cycle_attribute_sources} NIL, ^cycle_attribute_values, {instance_information} NIL,
          {resolved_file_reference} NIL, {user_defined_attributes} NIL, ignore_user_defined_attr_size,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (ofd^.id, amc$sequence_pointer, ofd^.segment, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ofd^.is_a_library := (cycle_attribute_values.file_contents = fsc$object_library);
    IF ofd^.is_a_library THEN
      RESET ofd^.segment.sequence_pointer;

      NEXT object_library_header IN ofd^.segment.sequence_pointer;
      IF object_library_header = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, ofd^.name^, status);
        RETURN;
      IFEND;

      IF object_library_header^.version = llc$object_library_version THEN

        NEXT library_dictionary: [1 .. object_library_header^.number_of_dictionaries] IN
              ofd^.segment.sequence_pointer;
        IF library_dictionary = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, ofd^.name^, status);
          RETURN;
        IFEND;

        ofd^.module_dictionary := NIL;
        ofd^.entry_point_dictionary := NIL;

        FOR i := LOWERBOUND (library_dictionary^) TO UPPERBOUND (library_dictionary^) DO
          CASE library_dictionary^ [i].kind OF
          = llc$module_dictionary =
            ofd^.module_dictionary := #PTR (library_dictionary^ [i].module_dictionary,
                  ofd^.segment.sequence_pointer^);
          = llc$entry_point_dictionary =
            ofd^.entry_point_dictionary := #PTR (library_dictionary^ [i].entry_point_dictionary,
                  ofd^.segment.sequence_pointer^);
          ELSE
          CASEND;
        FOREND;

      ELSEIF object_library_header^.version = 'V1.0' THEN
        RESET ofd^.segment.sequence_pointer;

        NEXT object_library_hdr IN ofd^.segment.sequence_pointer;
        IF object_library_hdr = NIL THEN
          osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, ofd^.name^, status);
          RETURN;
        IFEND;

        IF object_library_hdr^.number_of_modules <> 0 THEN
          ofd^.module_dictionary := #PTR (object_library_hdr^.module_dictionary,
                ofd^.segment.sequence_pointer^);
          IF ofd^.module_dictionary = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, ofd^.name^, status);
            RETURN;
          IFEND;
        ELSE
          ofd^.module_dictionary := NIL;
        IFEND;

        IF object_library_hdr^.number_of_entry_points <> 0 THEN
          ofd^.entry_point_dictionary := #PTR (object_library_hdr^.entry_point_dictionary,
                ofd^.segment.sequence_pointer^);
          IF ofd^.entry_point_dictionary = NIL THEN
            osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, ofd^.name^, status);
            RETURN;
          IFEND;
        ELSE
          ofd^.entry_point_dictionary := NIL;
        IFEND;

      ELSE
        osp$set_status_abnormal ('OC', oce$e_invalid_library_version, object_library_header^.version, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, ofd^.name^, status);
        RETURN;
      IFEND;

    IFEND;

  PROCEND ocp$open_linker_object_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$open_linker_symbol_table', EJECT ??

  PROCEDURE [XDCL] ocp$open_linker_symbol_table
    (    std: ^oct$symbol_table_descriptor;
     VAR status: ost$status);


    VAR
      attachment_options: array [1 .. 2] of fst$attachment_option,
      ignore_status: ost$status,
      validation_attributes: array [1 .. 1] of fst$file_cycle_attribute;


    status.normal := TRUE;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_options [1].share_modes.selector := fsc$determine_from_access_modes;
    attachment_options [2].selector := fsc$create_file;
    attachment_options [2].create_file := FALSE;
    validation_attributes [1].selector := fsc$file_contents_and_processor;
    validation_attributes [1].file_contents := fsc$data;
    validation_attributes [1].file_processor := fsc$unknown_processor;

    fsp$open_file (std^.name^, amc$segment, ^attachment_options, {default_creation_attributes} NIL,
          {mandated_creation_attributes} NIL, ^validation_attributes, {attribute_override} NIL, std^.id,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (std^.id, amc$sequence_pointer, std^.segment, status);
    IF NOT status.normal THEN
      fsp$close_file (std^.id, ignore_status);
      RETURN;
    IFEND;

    RESET std^.segment.sequence_pointer;

    NEXT std^.header IN std^.segment.sequence_pointer;
    IF std^.header = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, std^.name^, status);
      fsp$close_file (std^.id, ignore_status);
      RETURN;
    IFEND;

    IF std^.header^.version <> occ$symbol_table_version THEN
      osp$set_status_abnormal ('OC', oce$e_invalid_lst_version, std^.name^, status);
      RETURN;
    IFEND;

    IF std^.header^.number_of_symbols = 0 THEN
      std^.symbol_table := NIL;

    ELSE
      NEXT std^.symbol_table: [1 .. std^.header^.number_of_symbols] IN std^.segment.sequence_pointer;
      IF std^.symbol_table = NIL THEN
        osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, std^.name^, status);
        fsp$close_file (std^.id, ignore_status);
      IFEND;
    IFEND;


  PROCEND ocp$open_linker_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$open_output_segment', EJECT ??

  PROCEDURE [XDCL] ocp$open_output_segment
    (    name: fst$file_reference;
     VAR file_identifier: amt$file_identifier;
     VAR segment: amt$segment_pointer;
     VAR status: ost$status);


    VAR
      attachment_options: ^fst$attachment_options,
      creation_validation_attributes: ^fst$file_cycle_attributes,
      ignore_status: ost$status;


    status.normal := TRUE;

    PUSH attachment_options: [1 .. 1];
    PUSH creation_validation_attributes: [1 .. 2];

    attachment_options^ [1].selector := fsc$access_and_share_modes;
    attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options^ [1].access_modes.value := $fst$file_access_options
          [fsc$read, fsc$append, fsc$modify, fsc$shorten];
    attachment_options^ [1].share_modes.selector := fsc$determine_from_access_modes;

    creation_validation_attributes^ [1].selector := fsc$file_contents_and_processor;
    creation_validation_attributes^ [1].file_contents := fsc$data;
    creation_validation_attributes^ [1].file_processor := fsc$unknown_processor;
    creation_validation_attributes^ [2].selector := fsc$preset_value;
    creation_validation_attributes^ [2].preset_value := 0;

    fsp$open_file (name, amc$segment, attachment_options, {default_creation_attributes} NIL,
          creation_validation_attributes, creation_validation_attributes, {attribute_override} NIL,
          file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_identifier, amc$sequence_pointer, segment, status);
    IF NOT status.normal THEN
      fsp$close_file (file_identifier, ignore_status);
      RETURN;
    IFEND;

    RESET segment.sequence_pointer;

  PROCEND ocp$open_output_segment;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$open_segment_for_68000', EJECT ??

  PROCEDURE [XDCL] ocp$open_segment_for_68000
    (    segment_length: ost$segment_length;
     VAR mc68000_seq: ^SEQ ( * );
     VAR segment: amt$segment_pointer;
     VAR status: ost$status);

    segment.kind := amc$sequence_pointer;
    NEXT segment.sequence_pointer: [[REP segment_length OF cell]] IN mc68000_seq;
    IF segment.sequence_pointer = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'VLU3', status);
      RETURN;
    IFEND;


  PROCEND ocp$open_segment_for_68000;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$add_to_predefined_segments', EJECT ??

  PROCEDURE [XDCL] ocp$add_to_predefined_segments
    (    segment_descriptor: ^oct$output_segment_descriptor;
         section_names: ^oct$section_name_list;
     VAR status: ost$status);


    VAR
      segment: ^oct$output_segment_descriptor,
      section_name: ^oct$section_name_list;


    segment := ^ocv$predefined_segment_list;

    WHILE segment^.link <> NIL DO
      segment := segment^.link;
    WHILEND;

    NEXT segment^.link IN ocv$vel_scratch_seq;
    segment := segment^.link;
    IF segment = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'VLU4', status);
      RETURN;
    IFEND;

    segment^ := segment_descriptor^;
    segment^.link := NIL;

    section_name := ^ocv$section_name_list;

    WHILE section_name^.link <> NIL DO
      section_name := section_name^.link;
    WHILEND;

    section_name^.link := section_names;

    section_name := section_name^.link;

    WHILE section_name <> NIL DO
      section_name^.segment_descriptor := segment;
      section_name := section_name^.link;
    WHILEND;


  PROCEND ocp$add_to_predefined_segments;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$add_to_object_file_list', EJECT ??

  PROCEDURE [XDCL] ocp$add_to_object_file_list
    (    ofd: ^oct$object_file_descriptor;
         object_file_list: ^oct$object_file_descriptor;
     VAR status: ost$status);


    VAR
      last_descriptor: ^oct$object_file_descriptor;


    last_descriptor := object_file_list;

    WHILE last_descriptor^.link <> NIL DO
      last_descriptor := last_descriptor^.link;
    WHILEND;

    NEXT last_descriptor^.link IN ocv$vel_scratch_seq;
    last_descriptor := last_descriptor^.link;
    IF last_descriptor = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'VLU5', status);
      RETURN;
    IFEND;

    last_descriptor^ := ofd^;
    last_descriptor^.link := NIL;


  PROCEND ocp$add_to_object_file_list;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$close_linker_object_files', EJECT ??

  PROCEDURE [XDCL] ocp$close_linker_object_files
    (    ofd: ^oct$object_file_descriptor);


    VAR
      descriptor: ^oct$object_file_descriptor,
      status: ost$status;


    descriptor := ofd;

    WHILE descriptor <> NIL DO
      fsp$close_file (descriptor^.id, status);
      IF NOT status.normal THEN
        osp$generate_error_message (status, status);
      IFEND;

      descriptor := descriptor^.link;
    WHILEND;


  PROCEND ocp$close_linker_object_files;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$close_predefined_segments', EJECT ??

  PROCEDURE [XDCL] ocp$close_predefined_segments
    (    sd: ^oct$output_segment_descriptor);


    VAR
      descriptor: ^oct$output_segment_descriptor,
      status: ost$status;


    descriptor := sd;

    WHILE descriptor <> NIL DO
      fsp$close_file (descriptor^.id, status);
      IF NOT status.normal THEN
        osp$generate_error_message (status, status);
      IFEND;

      descriptor := descriptor^.link;
    WHILEND;


  PROCEND ocp$close_predefined_segments;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$close_linker_symbol_tables', EJECT ??

  PROCEDURE [XDCL] ocp$close_linker_symbol_tables
    (    std: ^oct$symbol_table_descriptor);


    VAR
      descriptor: ^oct$symbol_table_descriptor,
      status: ost$status;


    descriptor := std;

    WHILE descriptor <> NIL DO
      fsp$close_file (descriptor^.id, status);
      IF NOT status.normal THEN
        osp$generate_error_message (status, status);
      IFEND;

      descriptor := descriptor^.link;
    WHILEND;


  PROCEND ocp$close_linker_symbol_tables;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$add_to_symbol_table_list', EJECT ??

  PROCEDURE [XDCL] ocp$add_to_symbol_table_list
    (    std: ^oct$symbol_table_descriptor;
         symbol_table_list: ^oct$symbol_table_descriptor;
     VAR status: ost$status);


    VAR
      last_descriptor: ^oct$symbol_table_descriptor;


    last_descriptor := symbol_table_list;

    WHILE last_descriptor^.link <> NIL DO
      last_descriptor := last_descriptor^.link;
    WHILEND;

    NEXT last_descriptor^.link IN ocv$vel_scratch_seq;
    last_descriptor := last_descriptor^.link;
    IF last_descriptor = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_storage_allocation_failed, 'VLU6', status);
      RETURN;
    IFEND;

    last_descriptor^ := std^;
    last_descriptor^.link := NIL;


  PROCEND ocp$add_to_symbol_table_list;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$open_output_debug_table', EJECT ??

  PROCEDURE [XDCL] ocp$open_output_debug_table
    (    name: fst$file_reference;
     VAR file_identifier: amt$file_identifier;
     VAR segment: amt$segment_pointer;
     VAR debug_table_header: ^pmt$linker_debug_table_header;
     VAR status: ost$status);


    VAR
      attachment_options: ^fst$attachment_options,
      creation_validation_attributes: ^fst$file_cycle_attributes,
      ignore_status: ost$status;

    status.normal := TRUE;

    PUSH attachment_options: [1 .. 1];
    PUSH creation_validation_attributes: [1 .. 1];

    attachment_options^ [1].selector := fsc$access_and_share_modes;
    attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options^ [1].access_modes.value := $fst$file_access_options
          [fsc$read, fsc$append, fsc$modify, fsc$shorten];
    attachment_options^ [1].share_modes.selector := fsc$determine_from_access_modes;

    creation_validation_attributes^ [1].selector := fsc$file_contents_and_processor;
    creation_validation_attributes^ [1].file_contents := fsc$data;
    creation_validation_attributes^ [1].file_processor := fsc$unknown_processor;

    fsp$open_file (name, amc$segment, attachment_options, {default_creation_attributes} NIL,
          creation_validation_attributes, creation_validation_attributes, {attribute_override} NIL,
          file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_identifier, amc$sequence_pointer, segment, status);
    IF NOT status.normal THEN
      fsp$close_file (file_identifier, ignore_status);
      RETURN;
    IFEND;

    RESET segment.sequence_pointer;

    NEXT debug_table_header IN segment.sequence_pointer;
    IF debug_table_header = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, name, status);
      RETURN;
    IFEND;


  PROCEND ocp$open_output_debug_table;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$open_input_debug_table', EJECT ??

  PROCEDURE [XDCL] ocp$open_input_debug_table
    (    debug_table: fst$file_reference;
     VAR file_identifier: amt$file_identifier;
     VAR segment: amt$segment_pointer;
     VAR debug_table_header: ^pmt$linker_debug_table_header;
     VAR status: ost$status);


    VAR
      attachment_options: ^fst$attachment_options,
      ignore_status: ost$status;

    status.normal := TRUE;

    PUSH attachment_options: [1 .. 1];

    attachment_options^ [1].selector := fsc$access_and_share_modes;
    attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options^ [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_options^ [1].share_modes.selector := fsc$determine_from_access_modes;

    fsp$open_file (debug_table, amc$segment, attachment_options, {default_creation_attributes} NIL,
          {mandated_creation_attributes} NIL, {attribute_validation} NIL, {attribute_override} NIL,
          file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_identifier, amc$sequence_pointer, segment, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET segment.sequence_pointer;

    NEXT debug_table_header IN segment.sequence_pointer;
    IF debug_table_header = NIL THEN
      osp$set_status_abnormal ('OC', oce$e_premature_eof_on_file, debug_table, status);
      fsp$close_file (file_identifier, ignore_status);
      RETURN;
    IFEND;

    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);
      fsp$close_file (file_identifier, ignore_status);
      RETURN;
    IFEND;


  PROCEND ocp$open_input_debug_table;
?? OLDTITLE ??
MODEND ocm$ve_linker_utilities;
*DECK DECK=OCM$VIRTUAL_ENVIRONMENT_LINKER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Virtual Environment Linker' ??
MODULE ocm$virtual_environment_linker;

{ PURPOSE:
{   This module contains the routines for executing the VE Linker.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cyc$default_heap_name
*copyc cyd$cybil_structure_definitions
*copyc dst$recovery_name_table
*copyc llt$deferred_common_blocks
*copyc llt$deferred_entry_points
*copyc loe$map_malfunction
*copyc lot$loader_options
*copyc lot$loader_type_definitions
*copyc lot$task_services_entry_point
*copyc mmc$first_transient_segment
*copyc mmt$attribute_keyword
*copyc occ$initial_segment_number
*copyc occ$retain_all_common_blocks
*copyc occ$symbol_table_version
*copyc oce$library_generator_errors
*copyc oce$ve_linker_exceptions
*copyc oct$known_file_list
*copyc oct$link_parameters
*copyc oct$object_record_list
*copyc oct$output_segment_descriptor
*copyc oct$section_name_list
*copyc oct$segment_attributes
*copyc oct$task_services_entry_point
*copyc pmt$initialization_value
*copyc pmt$linker_debug_table_header
*copyc pmt$virtual_memory_image_header
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc clp$convert_date_time_to_string
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_string_to_date_time
*copyc clp$convert_string_to_file_ref
*copyc fsp$close_file
*copyc fsp$open_file
*copyc i#build_adaptable_array_ptr
*copyc i#current_sequence_position
*copyc i#move
*copyc mmp$create_user_segment
*copyc mmp$preset_page_streaming
*copyc ocp$add_to_known_files
*copyc ocp$close_link_map
*copyc ocp$dtb_close_debug_table
*copyc ocp$dtb_define_entry_point
*copyc ocp$dtb_define_module
*copyc ocp$dtb_define_section
*copyc ocp$dtb_get_debug_table
*copyc ocp$dtb_initialize_debug_tables
*copyc ocp$dtb_redefine_module
*copyc ocp$dtb_terminate_module
*copyc ocp$duplicate_segment_number
*copyc ocp$generate_link_map_text
*copyc ocp$initialize_link_map
*copyc ocp$open_output_segment
*copyc ocp$search_modules_to_add
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$establish_condition_handler
*copyc pmp$get_date
*copyc pmp$get_page_size
*copyc pmp$get_time
*copyc pmp$get_unique_name
*copyc pmp$position_object_library
*copyc pmp$zero_out_table
*copyc syp$advised_move_bytes
*copyc ocv$next_available_segment
*copyc ocv$predefined_segment_list
*copyc ocv$section_name_list
*copyc ocv$vel_scratch_seq
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    oct$actual_param_group = record
      nnext: ^oct$actual_param_group,
      name: pmt$program_name,
      r1: ost$ring,
      r2: ost$ring,
      r3: ost$ring,
      link: ^oct$actual_param_group,
      global_key: ost$key_lock_value,
      local_key: ost$key_lock_value,
      list: ^oct$actual_param_list_item,
    recend;

  TYPE
    oct$actual_param_list_item = record
      nnext: ^oct$actual_param_list_item,
      definition: ^llt$actual_parameters,
    recend;

  TYPE
    oct$addresses = packed record
      case (occ$pva, occ$code_based_pointer, occ$mc68000_address, occ$mc68000_short_address) of
      = occ$pva =
        pva: ost$pva,

      = occ$code_based_pointer =
        cbp: oct$code_based_pointer,
        fill: 0 .. 0ffff(16),
        binding_section: ost$pva,

      = occ$mc68000_address =
        mc68000_offset: ost$segment_length,
        mc68000_binding_section: ost$segment_length,

      = occ$mc68000_short_address =
        mc68000_short_offset: 0 .. 0ffff(16),

      casend,
    recend;

  TYPE
    oct$array_pointer = packed record
      ring: ost$ring,
      seg: ost$segment,
      offset: 0 .. 0ffffffff(16),
      array_size: 0 .. 0ffffffff(16),
      lower_bound: 0 .. 0ffffffff(16),
      element_size: 0 .. 0ffffffff(16),
    recend;

  TYPE
    oct$code_based_pointer = packed record
      fill1: 0 .. 0f(16),
      vmid: ost$virtual_machine_identifier, { virtual machine id }
      epf: boolean, { external procedure flag }
      fill2: 0 .. 07(16),
      r3: ost$ring, { highest ring of execution }
      rn: ost$ring, { ring number }
      seg: ost$segment, { segment number }
      bn: ost$segment_offset, { byte number }
    recend;

  TYPE
    oct$common_block_item = record
      section_item: ^oct$section_table_item,
      link: ^oct$common_block_item,
    recend;

  TYPE
    oct$ext_reference_list = record
      name: pmt$program_name,
      language: llt$module_generator,
      declaration_matching_required: boolean,
      declaration_matching: llt$declaration_matching_value,
      r1: ost$ring,
      r2: ost$ring,
      check_for_ring_violation: boolean,
      items: oct$external_items,
      modules_referencing: ^oct$program_name_list,
      link: ^oct$ext_reference_list,
    recend;

  TYPE
    oct$external_items = record
      kind: llt$address_kind,
      address: ^oct$addresses,
      offset_operand: ost$segment_offset,
      output: ^oct$output_segment_descriptor,
      link: ^oct$external_items,
    recend;

  TYPE
    oct$formal_param_definition = record
      l_link: ^oct$formal_param_definition,
      r_link: ^oct$formal_param_definition,
      global_key: ost$key_lock_value,
      local_key: ost$key_lock_value,
      defining_module: pmt$program_name,
      r1: ost$ring,
      r2: ost$ring,
      r3: ost$ring,
      definition: ^llt$formal_parameters,
    recend;

  TYPE
    oct$heap_pointer = record
      pva: ost$pva,
      length: 0 .. 0ffffffff(16),
    recend;

  TYPE
    oct$library_entry_points = record
      name: pmt$program_name,
      r1: ost$ring,
      r3: ost$ring,
      object_library: ^oct$object_file_descriptor,
      load_module_header: REL (llt$object_library) ^llt$load_module_header,
      l_link: ^oct$library_entry_points,
      r_link: ^oct$library_entry_points,
    recend;

  TYPE
    oct$list_of_actual_param_group = array [1 .. * ] of oct$actual_param_group;

  TYPE
    oct$list_of_formal_definition = array [1 .. * ] of oct$formal_param_definition;

  TYPE
    oct$module_descriptor_table = record
      name: pmt$program_name,
      r1: ost$ring,
      r2: ost$ring,
      r3: ost$ring,
      global_key: ost$key_lock_value,
      local_key: ost$key_lock_value,
      ring_of_execution: ost$ring,
      execute_attribute: ost$execute_privilege,
      binding_section_encountered: boolean,
      binding_section: ost$pva,
      default_sections: ^oct$default_sections,
      external_names: oct$program_name_list,
      section_table: oct$section_definition_table,
    recend;

  TYPE
    oct$param_matching_node = record
      nnext: ^oct$param_matching_node,
      name: pmt$program_name,
      definitions: ^oct$formal_param_definition,
      references: ^oct$actual_param_group,
    recend;

  TYPE
    oct$section_attributes = record
      read_default: ost$read_privilege,
      write_default: ost$write_privilege,
      execute_default: ost$execute_privilege,
      read_attribute: ost$read_privilege,
      write_attribute: ost$write_privilege,
      execute_attribute: ost$execute_privilege,
      cache_bypass: boolean,
      extensible: boolean,
    recend;

  TYPE
    oct$section_definition_table = array [0 .. * ] of oct$section_table_item,

    oct$section_table_item = record
      undefined: boolean,
      retained_common_block: boolean,
      deferred_common_block: boolean,
      unallocated_common_block: boolean,
      definition: llt$section_definition,
      global_key: ost$key_lock_value,
      local_key: ost$key_lock_value,
      r1: ost$ring,
      r2: ost$ring,
      r3: ost$ring,
      section_name: pmt$program_name,
      common_block_name: pmt$program_name,
      pva: ost$pva,
      text: ^array [0 .. * ] of 0 .. 0ff(16),
      output: ^oct$output_segment_descriptor,
    recend;

  CONST
    oc = 'OC',
    occ$num_of_free_program_names = 50,
    occ$number_of_free_actual_param = 50,
    occ$number_of_free_entry_points = 50,
    occ$number_of_free_externals = 50,
    occ$number_of_free_formal_param = 50,
    occ$free_ext_item_increment = 25,
    occ$free_ext_name_increment = 25;

  VAR
    v$lm_asis_text: lot$load_map_data,
    v$lm_diagnostic_summary: lot$load_map_data,
    v$lm_entry_detail: lot$load_map_data,
    v$lm_issue_diagnostic: lot$load_map_data,
    v$lm_module_detail_1: lot$load_map_data,
    v$lm_module_detail_2: lot$load_map_data,
    v$lm_page_header: lot$load_map_data,
    v$lm_section_detail: lot$load_map_data,
    v$lm_segment_detail: lot$load_map_data,
    v$lm_transfer_detail: lot$load_map_data;

  VAR
    v$actual_param_groups: oct$actual_param_group,
    v$address_formulation_records: oct$object_record_list,
    v$binding_r1: ost$ring,
    v$binding_r2: ost$ring,
    v$common_block_table: oct$common_block_item,
    v$current_segment_number: integer,
    v$entry_points: oct$entry_points,
    v$formal_param_definitions: oct$formal_param_definition,
    v$free_actual_parameters: ^oct$list_of_actual_param_group,
    v$free_entry_points: ^oct$list_of_entry_points,
    v$free_external_items: ^oct$external_items,
    v$free_external_names: ^oct$program_name_list,
    v$free_external_references: ^oct$ext_reference_list,
    v$free_formal_parameters: ^oct$list_of_formal_definition,
    v$free_program_names: ^oct$program_name_list,
    v$generate_debug_tables: boolean,
    v$generate_status: ost$status,
    v$last_address_formulation: ^oct$object_record_list,
    v$last_entry_point: ^oct$entry_points,
    v$last_starting_procedure: pmt$program_name,
    v$library_list: oct$known_file_list,
    v$maximum_segment_number: integer,
    v$mdt: ^oct$module_descriptor_table,
    v$minimum_segment_number: integer,
    v$module_kind: llt$module_kind,
    v$modules_to_add: oct$program_name_list,
    v$next_free_actual_parameter: 1 .. occ$number_of_free_actual_param + 1,
    v$next_free_entry_point: 1 .. occ$number_of_free_entry_points + 1,
    v$next_free_formal_parameter: 1 .. occ$number_of_free_formal_param + 1,
    v$next_retained_cmnblk_seg_num: integer,
    v$number_of_libraries: integer,
    v$object_type_checking: [STATIC, READ] string (6) := 'OBJECT',
    v$outboard_symbol_table: ^oct$list_of_entry_points,
    v$output_segment_list: oct$output_segment_descriptor,
    v$page_size: integer,
    v$record_number: integer,
    v$retained_common_block_segment: amt$segment_pointer,
    v$section_name_list: oct$section_name_list,
    v$source_type_checking: [STATIC] boolean := TRUE,
    v$starting_entry_point: ^oct$entry_points,
    v$starting_procedure: pmt$program_name,
    v$symbol_table_id: ost$name,
    v$unsatisfied_actual_param: oct$actual_param_group,
    v$unsatisfied_externals: oct$ext_reference_list,
    v$vmid: [STATIC] ost$virtual_machine_identifier := osc$cyber_180_mode;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ocp$execute_the_ve_linker', EJECT ??

  PROCEDURE [XDCL] ocp$execute_the_ve_linker
    (    link_parameters: oct$link_parameters;
     VAR status: ost$status);

?? NEWTITLE := 'link_map_malfunction', EJECT ??

    PROCEDURE link_map_malfunction
      (    condition: pmt$condition;
           error_status: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR local_status: ost$status);


      VAR
        malfunction: ^ost$status;


      malfunction := error_status;
      status := malfunction^;

      EXIT ocp$execute_the_ve_linker;


    PROCEND link_map_malfunction;
?? OLDTITLE ??
?? NEWTITLE := 'issue_diagnostic', EJECT ??

    PROCEDURE issue_diagnostic
      (    severity: ost$status_severity;
       VAR status: ost$status);


      IF NOT (pmc$no_load_map IN link_parameters.map_options) THEN
        v$lm_issue_diagnostic.diagnostic_status := status;

        space (1);
        ocp$generate_link_map_text (v$lm_issue_diagnostic);

        v$lm_diagnostic_summary.diagnostic_count [severity] :=
              v$lm_diagnostic_summary.diagnostic_count [severity] + 1;
      IFEND;

      IF severity < osc$fatal_status THEN
        status.normal := TRUE;
        osp$set_status_abnormal (oc, oce$w_generate_status,
              'GENERATE completed - NON FATAL errors encountered', v$generate_status);
      ELSE
        osp$set_status_abnormal (oc, oce$e_generate_status,
              'GENERATE not completed - FATAL error encountered', v$generate_status);
      IFEND;


    PROCEND issue_diagnostic;
?? OLDTITLE ??
?? NEWTITLE := 'build_adaptable_array_pointer', EJECT ??

    PROCEDURE build_adaptable_array_pointer
      (    ring: 0 .. 0f(16);
           seg: 0 .. 0fff(16);
           offset: 0 .. 80000000(16);
           array_size: 0 .. 0ffffffff(16);
           lower_bound: 0 .. 0ffffffff(16);
           element_size: 0 .. 0ffffffff(16);
           array_pointer: ^oct$array_pointer);


      array_pointer^.ring := ring;
      array_pointer^.seg := seg;
      array_pointer^.offset := offset;
      array_pointer^.array_size := array_size;
      array_pointer^.lower_bound := lower_bound;
      array_pointer^.element_size := element_size;


    PROCEND build_adaptable_array_pointer;
?? OLDTITLE ??
?? NEWTITLE := 'build_adaptable_sequence_pointer', EJECT ??

    PROCEDURE build_adaptable_seq_pointer
      (    ring: 0 .. 0f(16);
           seg: 0 .. 0fff(16);
           offset: 0 .. 80000000(16);
           size: 0 .. 0ffffffff(16);
           sequence_pointer: ^cell);

      VAR
        pointer: ^packed record
          ring: 0 .. 0f(16),
          seg: 0 .. 0fff(16),
          offset: 0 .. 0ffffffff(16),
          limit: 0 .. 0ffffffff(16),
          avail: 0 .. 0ffffffff(16),
        recend;

      pointer := sequence_pointer;
      pointer^.ring := ring;
      pointer^.seg := seg;
      pointer^.offset := offset;
      pointer^.limit := size;
      pointer^.avail := 0;


    PROCEND build_adaptable_seq_pointer;
?? OLDTITLE ??
?? NEWTITLE := 'output', EJECT ??

    PROCEDURE output
      (    filler: string ( * );
           strng: string ( * );
           size: 0 .. 256;
           flush_the_output_buffer: boolean);


      v$output_buffer (v$output_pos, * ) := filler;
      v$output_pos := v$output_pos + STRLENGTH (filler);
      v$output_buffer (v$output_pos, * ) := strng (1, size);
      v$output_pos := v$output_pos + size;

      IF flush_the_output_buffer THEN
        v$lm_asis_text.text := v$output_buffer (1, (v$output_pos - 1));
        ocp$generate_link_map_text (v$lm_asis_text);

        v$output_pos := 1;
      IFEND;


    PROCEND output;
?? OLDTITLE ??
?? NEWTITLE := 'space', EJECT ??

    PROCEDURE space
      (    number_of_lines: integer);


      VAR
        i: integer;


      v$lm_asis_text.text := '  ';

      FOR i := 1 TO number_of_lines DO
        ocp$generate_link_map_text (v$lm_asis_text);
      FOREND;


    PROCEND space;
?? OLDTITLE ??
?? NEWTITLE := 'convert_hex_pva_to_ascii', EJECT ??

    PROCEDURE convert_hex_pva_to_ascii
      (    pva: ost$pva;
       VAR strng: string ( * ));


      VAR
        dummy: ost$status;


      strng := '0 000 00000000';

      clp$convert_integer_to_rjstring (pva.ring, 16, FALSE, ' ', strng (1, 1), dummy);
      clp$convert_integer_to_rjstring (pva.seg, 16, FALSE, ' ', strng (3, 3), dummy);
      clp$convert_integer_to_rjstring (pva.offset, 16, FALSE, ' ', strng (7, 8), dummy);


    PROCEND convert_hex_pva_to_ascii;
?? OLDTITLE ??
?? NEWTITLE := 'convert_segment_access_control', EJECT ??

    PROCEDURE convert_segment_access_control
      (    attributes: oct$segment_attributes;
       VAR access_control: ost$segment_access_control);


      access_control.cache_bypass := (occ$sa_cache_bypass IN attributes);

      IF occ$sa_non_privileged IN attributes THEN
        access_control.execute_privilege := osc$non_privileged;
      ELSEIF occ$sa_local_privilege IN attributes THEN
        access_control.execute_privilege := osc$local_privilege;
      ELSEIF occ$sa_global_privilege IN attributes THEN
        access_control.execute_privilege := osc$global_privilege;
      ELSE
        access_control.execute_privilege := osc$non_executable;
      IFEND;

      IF occ$sa_read IN attributes THEN
        access_control.read_privilege := osc$read_uncontrolled;
      ELSEIF occ$sa_read_kl IN attributes THEN
        access_control.read_privilege := osc$read_key_lock_controlled;
      ELSEIF occ$sa_binding IN attributes THEN
        access_control.read_privilege := osc$binding_segment;
      ELSE
        access_control.read_privilege := osc$non_readable;
      IFEND;

      IF occ$sa_write IN attributes THEN
        access_control.write_privilege := osc$write_uncontrolled;
      ELSEIF occ$sa_write_kl IN attributes THEN
        access_control.write_privilege := osc$write_key_lock_controlled;
      ELSE
        access_control.write_privilege := osc$non_writable;
      IFEND;


    PROCEND convert_segment_access_control;
?? OLDTITLE ??
?? NEWTITLE := 'convert_key_lock', EJECT ??

    PROCEDURE convert_key_lock
      (    global_key: ost$key_lock_value;
           local_key: ost$key_lock_value;
       VAR key_lock: ost$key_lock);


      key_lock.value := 0;

      IF global_key <> 0 THEN
        key_lock.global := TRUE;
        key_lock.value := global_key;
      ELSE
        key_lock.global := FALSE;
      IFEND;

      IF local_key <> 0 THEN
        key_lock.local := TRUE;
        key_lock.value := local_key;
      ELSE
        key_lock.local := FALSE;
      IFEND;


    PROCEND convert_key_lock;
?? OLDTITLE ??
?? NEWTITLE := 'get_binding_rings_1_and_2', EJECT ??

    PROCEDURE get_binding_rings_1_and_2
      (VAR r1: ost$ring;
       VAR r2: ost$ring);




      VAR
        file_descriptor: ^oct$object_file_descriptor;


      r1 := osc$max_ring;
      r2 := osc$invalid_ring;

      file_descriptor := link_parameters.object_files_to_add.link;

      WHILE file_descriptor <> NIL DO
        IF file_descriptor^.r1 < r1 THEN
          r1 := file_descriptor^.r1;
        IFEND;

        IF file_descriptor^.r2 > r2 THEN
          r2 := file_descriptor^.r2;
        IFEND;

        file_descriptor := file_descriptor^.link;
      WHILEND;

      file_descriptor := link_parameters.object_libraries_to_use.link;

      WHILE file_descriptor <> NIL DO
        IF file_descriptor^.r1 < r1 THEN
          r1 := file_descriptor^.r1;
        IFEND;

        IF file_descriptor^.r2 > r2 THEN
          r2 := file_descriptor^.r2;
        IFEND;

        file_descriptor := file_descriptor^.link;
      WHILEND;


    PROCEND get_binding_rings_1_and_2;
?? OLDTITLE ??
?? NEWTITLE := 'get_modules_to_add', EJECT ??

    PROCEDURE get_modules_to_add
      (VAR modules_to_add: oct$program_name_list;
       VAR status: ost$status);


      VAR
        old_module: ^oct$program_name_list,
        new_module: ^oct$program_name_list;


      old_module := link_parameters.modules_to_add.link;
      new_module := ^modules_to_add;

      WHILE old_module <> NIL DO
        NEXT new_module^.link IN ocv$vel_scratch_seq;
        new_module := new_module^.link;
        IF new_module = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL1', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        new_module^.name := old_module^.name;
        old_module := old_module^.link;

      WHILEND;

      new_module^.link := NIL;


    PROCEND get_modules_to_add;
?? OLDTITLE ??
?? NEWTITLE := 'add_externals_to_satisfy', EJECT ??

    PROCEDURE add_externals_to_satisfy
      (VAR unsatisfied_externals: oct$ext_reference_list;
       VAR status: ost$status);

?? NEWTITLE := 'add_external', EJECT ??

      PROCEDURE add_external
        (    name: pmt$program_name;
         VAR status: ost$status);


        VAR
          defaults: [STATIC] oct$ext_reference_list := [ * , * , FALSE, * , osc$invalid_ring, osc$max_ring,
                FALSE, [ * , * , * , NIL, NIL], NIL, * ],
          external: ^oct$ext_reference_list;


        get_next_free_external (external, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        external^ := defaults;
        external^.name := name;
        external^.link := unsatisfied_externals.link;
        unsatisfied_externals.link := external;


      PROCEND add_external;
?? OLDTITLE ??
?? EJECT ??


      VAR
        current_message_module: ^oct$message_module_list,
        variable: ^oct$program_name_list,
        pointer: ^oct$pointer_list;


      IF v$starting_procedure <> osc$null_name THEN
        add_external (v$starting_procedure, status);

        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      pointer := link_parameters.heap_pointers.link;

      WHILE pointer <> NIL DO
        add_external (pointer^.name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        pointer := pointer^.link;
      WHILEND;

      pointer := link_parameters.debug_table_pointers.link;

      WHILE pointer <> NIL DO
        add_external (pointer^.name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        pointer := pointer^.link;
      WHILEND;

      IF link_parameters.symbol_table_id_variable <> osc$null_name THEN
        add_external (link_parameters.symbol_table_id_variable, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF link_parameters.exchange_package_variable <> osc$null_name THEN
        add_external (link_parameters.exchange_package_variable, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      variable := link_parameters.build_level_variables.link;

      WHILE variable <> NIL DO
        add_external (variable^.name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        variable := variable^.link;
      WHILEND;

      current_message_module := link_parameters.message_module_list;

      WHILE pointer <> NIL DO
        add_external (current_message_module^.pointer_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        current_message_module := current_message_module^.link;
      WHILEND;


    PROCEND add_externals_to_satisfy;

?? OLDTITLE ??
?? NEWTITLE := 'get_segment_number', EJECT ??

    PROCEDURE get_segment_number
      (    retained_common_block: boolean;
           segment_number_predefined: boolean;
       VAR segment_number: oct$segment;
       VAR status: ost$status);


      IF retained_common_block THEN
        IF v$next_retained_cmnblk_seg_num > UPPERVALUE (ost$segment) THEN
          osp$set_status_condition (oce$e_segment_number_overflow, status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;
        segment_number := v$next_retained_cmnblk_seg_num;
        v$next_retained_cmnblk_seg_num := v$next_retained_cmnblk_seg_num + 1;
        RETURN; { ---->
      IFEND;

      IF NOT segment_number_predefined THEN
        segment_number := occ$null_seg_value;

        WHILE segment_number = occ$null_seg_value DO
          IF v$current_segment_number > v$maximum_segment_number THEN
            osp$set_status_condition (oce$e_segment_number_overflow, status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          IF NOT ocp$duplicate_segment_number (v$current_segment_number) THEN
            segment_number := v$current_segment_number;
          IFEND;

          v$current_segment_number := v$current_segment_number + 1;
        WHILEND;
      IFEND;

      IF (segment_number < v$minimum_segment_number) THEN
        osp$set_status_condition (oce$e_segment_number_underflow, status);
        issue_diagnostic (osc$fatal_status, status);
      ELSEIF (segment_number > v$maximum_segment_number) THEN
        osp$set_status_condition (oce$e_segment_number_overflow, status);
        issue_diagnostic (osc$fatal_status, status);
      IFEND;


    PROCEND get_segment_number;
?? OLDTITLE ??
?? NEWTITLE := 'open_temporary_segment', EJECT ??

    PROCEDURE open_temporary_segment
      (    section_item: oct$section_table_item;
           preset_value: pmt$initialization_value;
       VAR temporary: ^oct$output_segment_descriptor;
       VAR status: ost$status);

      VAR
        segment_attributes_p: ^array [ * ] of mmt$user_attribute_descriptor;

      status.normal := TRUE;
      get_segment_number (temporary^.retained_common_block, temporary^.number_predefined, temporary^.number,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (section_item.retained_common_block) AND (section_item.definition.kind <>
            llc$extensible_common_block) THEN
        temporary^.segment.kind := amc$sequence_pointer;
        IF (section_item.definition.length = 0) THEN

{ It just doesn't matter where, but we need a valid pointer.

          NEXT temporary^.segment.sequence_pointer: [[REP 1 OF cell]] IN ocv$vel_scratch_seq;
        ELSE

{ Add the allocation alignment size to allow for the text to be aligned when it is copied into the area.

          NEXT temporary^.segment.sequence_pointer: [[REP (section_item.definition.length +
                section_item.definition.allocation_alignment) OF cell]] IN
                v$retained_common_block_segment.sequence_pointer;
        IFEND;

        IF (temporary^.segment.sequence_pointer = NIL) THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL_OTS', status);
        IFEND;

      ELSE
        PUSH segment_attributes_p: [1 .. 1];
        segment_attributes_p^ [1].keyword := mmc$ua_preset_value;
        segment_attributes_p^ [1].preset_value := preset_value;
        mmp$create_user_segment (segment_attributes_p, amc$sequence_pointer, mmc$as_sequential,
              temporary^.segment, status);
        RESET temporary^.segment.sequence_pointer;
      IFEND;

      IF NOT status.normal THEN
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      temporary^.sections_allocated.link := NIL;


    PROCEND open_temporary_segment;
?? OLDTITLE ??
?? NEWTITLE := 'validate_section', EJECT ??

    PROCEDURE validate_section
      (    section_ordinal: llt$section_ordinal;
           offset: ost$segment_offset;
       VAR status: ost$status);


      IF section_ordinal > UPPERBOUND (v$mdt^.section_table) THEN
        osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid section ordinal encountered',
              status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      IF v$mdt^.section_table [section_ordinal].undefined THEN
        osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'Undefined section ordinal encountered',
              status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      IF offset > v$mdt^.section_table [section_ordinal].definition.length THEN
        osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              'Reference outside of section encountered', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;


    PROCEND validate_section;
?? OLDTITLE ??
?? NEWTITLE := 'obtain_destination_address', EJECT ??

    PROCEDURE obtain_destination_address
      (    mdt: ^oct$module_descriptor_table;
           address_kind: llt$address_kind;
           dest_section: llt$section_ordinal;
           dest_offset: ost$segment_offset;
       VAR address_pointer: ^oct$addresses;
       VAR status: ost$status);


      VAR
        alignment_cy180: [STATIC] array [llt$address_kind] of 0 .. 7 := [2, 0, 0, 0, 2, 2],
        alignment_mc68000: [STATIC] array [llt$address_kind] of 0 .. 7 := [0, 0, 0, 0, 0, 0],
        address_size_cy180: [STATIC] array [llt$address_kind] of 0 .. 16 := [6, 8, 8, 16, 6, 6],
        address_size_mc68000: [STATIC] array [llt$address_kind] of 0 .. 16 := [4, 2, 2, 8, 4, 4];

      CASE link_parameters.mode OF
      = occ$template, occ$product =
        IF (dest_offset + address_size_cy180 [address_kind]) > mdt^.section_table [dest_section].
              definition.length THEN
          osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, mdt^.name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'Referencing outside of section',
                status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        IF NOT mdt^.section_table [dest_section].output^.inhibit_binding_check THEN
          IF (address_kind = llc$internal_proc) OR (address_kind = llc$short_address) OR
                (address_kind = llc$external_proc) THEN
            IF mdt^.section_table [dest_section].definition.kind <> llc$binding_section THEN
              osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, mdt^.name, status);
              osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    'Code base pointer not in binding section', status);
              issue_diagnostic (osc$fatal_status, status);
              RETURN;
            IFEND;
          IFEND;

          IF occ$sa_binding IN mdt^.section_table [dest_section].output^.used_attributes THEN
            IF ((mdt^.section_table [dest_section].pva.offset + dest_offset) MOD 8) <>
                  alignment_cy180 [address_kind] THEN
              osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, mdt^.name, status);
              osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid pointer alignment_cy180',
                    status);
              issue_diagnostic (osc$fatal_status, status);
              RETURN;
            IFEND;
          IFEND;
        IFEND;

        address_pointer := #LOC (mdt^.section_table [dest_section].text^ [dest_offset]);

      = occ$mc68000 =
        IF (dest_offset + address_size_mc68000 [address_kind]) > mdt^.section_table [dest_section].
              definition.length THEN
          osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, mdt^.name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'Referencing outside of section',
                status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        IF occ$sa_binding IN mdt^.section_table [dest_section].output^.used_attributes THEN
          IF ((mdt^.section_table [dest_section].pva.offset + dest_offset) MOD 2) <>
                alignment_mc68000 [address_kind] THEN
            osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, mdt^.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid pointer alignment_mc68000',
                  status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;
        IFEND;

        address_pointer := #LOC (mdt^.section_table [dest_section].text^ [dest_offset]);
      CASEND;


    PROCEND obtain_destination_address;
?? OLDTITLE ??
?? NEWTITLE := 'rings_overlap', EJECT ??

    FUNCTION rings_overlap
      (    x_lower: ost$ring;
           x_upper: ost$ring;
           y_lower: ost$ring;
           y_upper: ost$ring): boolean;

      rings_overlap := ((x_lower <= y_upper) AND (x_upper >= y_lower));

    FUNCEND rings_overlap;
?? OLDTITLE ??
?? NEWTITLE := 'get_next_free_program_name', EJECT ??

    PROCEDURE get_next_free_program_name
      (VAR program_name: ^oct$program_name_list;
       VAR status: ost$status);


      VAR
        free_program_names: ^array [1 .. occ$num_of_free_program_names] of oct$program_name_list,
        i: 1 .. occ$num_of_free_program_names;


      IF v$free_program_names = NIL THEN
        NEXT free_program_names IN ocv$vel_scratch_seq;
        IF free_program_names = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL29292', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        v$free_program_names := ^free_program_names^ [1];

        FOR i := 1 TO (occ$num_of_free_program_names - 1) DO
          free_program_names^ [i].link := ^free_program_names^ [i + 1];
        FOREND;

        free_program_names^ [occ$num_of_free_program_names].link := NIL;
      IFEND;

      program_name := v$free_program_names;
      v$free_program_names := v$free_program_names^.link;


    PROCEND get_next_free_program_name;
?? OLDTITLE ??
?? NEWTITLE := 'get_next_free_entry_point', EJECT ??

    PROCEDURE get_next_free_entry_point
      (VAR entry_point: ^oct$entry_points;
       VAR status: ost$status);


      IF v$next_free_entry_point > occ$number_of_free_entry_points THEN
        NEXT v$free_entry_points: [1 .. occ$number_of_free_entry_points] IN ocv$vel_scratch_seq;
        IF v$free_entry_points = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL2', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        v$next_free_entry_point := 1;
      IFEND;

      entry_point := ^v$free_entry_points^ [v$next_free_entry_point];
      v$next_free_entry_point := v$next_free_entry_point + 1;


    PROCEND get_next_free_entry_point;
?? OLDTITLE ??
?? NEWTITLE := 'is_entry_point_deferred', EJECT ??

{ PURPOSE:
{   The purpose of this request is to determine if an entry point is to be deferred.
{ DESIGN:
{   If all entry points are to be deferred or if non retained entry points are to be
{   deferred and the entry point is not retained the entry point is to be deferred.
{   Otherwise the list of names specified will be searched.  If the list of names
{   represents those not to be deferred and the entry point is not in it or if the
{   list of names represents those to be deferred and the entry point is in it the
{   entry point will be deferred.

    PROCEDURE is_entry_point_deferred
      (    retained: boolean;
           name: pmt$program_name;
       VAR deferred: boolean);

      VAR
        entry_point: ^oct$defer_list;


      deferred := FALSE;

      IF link_parameters.defer_entry_points <> NIL THEN
        IF link_parameters.defer_entry_points^.defer = occ$defer_all THEN
          deferred := TRUE;

        ELSEIF link_parameters.defer_entry_points^.defer = occ$defer_non_retained THEN
          deferred := NOT retained;

        ELSEIF link_parameters.defer_entry_points^.defer = occ$defer THEN
          entry_point := link_parameters.defer_entry_points^.name_list;
          WHILE entry_point <> NIL DO
            IF entry_point^.name = name THEN
              deferred := TRUE;
              entry_point^.name_found := TRUE;
              RETURN;
            IFEND;
            entry_point := entry_point^.link;
          WHILEND;

        ELSEIF link_parameters.defer_entry_points^.defer = occ$defer_all_except THEN
          entry_point := link_parameters.defer_entry_points^.name_list;
          WHILE entry_point <> NIL DO
            IF entry_point^.name = name THEN
              entry_point^.name_found := TRUE;
              RETURN;
            IFEND;
            entry_point := entry_point^.link;
          WHILEND;
          deferred := TRUE;

        IFEND;
      IFEND;


    PROCEND is_entry_point_deferred;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_entry_point', EJECT ??

    PROCEDURE initialize_entry_point
      (    entry_definition: ^llt$entry_definition;
       VAR entry_point: ^oct$entry_points);

      entry_point^.name := entry_definition^.name;
      entry_point^.ring_violation := FALSE;
      entry_point^.inboard_symbol := FALSE;
      is_entry_point_deferred ((llc$retain_entry_point IN entry_definition^.attributes), entry_point^.name,
            entry_point^.deferred);
      entry_point^.gated := (llc$gated_entry_point IN entry_definition^.attributes);
      entry_point^.attributes := entry_definition^.attributes;
      entry_point^.language := entry_definition^.language;
      entry_point^.declaration_matching_required := entry_definition^.declaration_matching_required;
      entry_point^.declaration_matching := entry_definition^.declaration_matching;

      entry_point^.pva.ring := v$mdt^.ring_of_execution;
      entry_point^.pva.seg := v$mdt^.section_table [entry_definition^.section_ordinal].pva.seg;
      entry_point^.pva.offset := v$mdt^.section_table [entry_definition^.section_ordinal].pva.offset +
            entry_definition^.offset;
      entry_point^.binding_section := v$mdt^.binding_section;

      entry_point^.r1 := v$mdt^.r1;
      entry_point^.r2 := v$mdt^.r2;

      IF entry_point^.gated THEN
        entry_point^.r3 := v$mdt^.r3;
      ELSE
        entry_point^.r3 := v$mdt^.r2;
      IFEND;

      IF entry_point^.name = 'SYP$SYSTEM_CORE_TRAP_HANDLER' THEN { JFS - Kludge }
        entry_point^.r3 := 0d(16);
      IFEND;

      entry_point^.global_key := v$mdt^.global_key;
      entry_point^.local_key := v$mdt^.local_key;

      entry_point^.l_link := NIL;
      entry_point^.r_link := NIL;
      entry_point^.link := NIL;


    PROCEND initialize_entry_point;
?? OLDTITLE ??
?? NEWTITLE := 'search_entry_point_tree', EJECT ??

    PROCEDURE search_entry_point_tree
      (    name: pmt$program_name;
           r1: ost$ring;
           r2: ost$ring;
       VAR entry_point: ^oct$entry_points);


      entry_point := ^v$entry_points;

      WHILE entry_point <> NIL DO
        IF (name = entry_point^.name) AND (rings_overlap (r1, r2, entry_point^.r1, entry_point^.r3)) THEN
          RETURN;

        ELSEIF name < entry_point^.name THEN
          entry_point := entry_point^.l_link;
        ELSE
          entry_point := entry_point^.r_link;
        IFEND;

      WHILEND;


    PROCEND search_entry_point_tree;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_entry_points', EJECT ??

    PROCEDURE add_to_entry_points
      (    entry_point: ^oct$entry_points);


      VAR
        ept: ^oct$entry_points;


      v$last_entry_point^.link := entry_point;
      v$last_entry_point := v$last_entry_point^.link;

      ept := ^v$entry_points;

      WHILE TRUE DO

        IF entry_point^.name < ept^.name THEN
          IF ept^.l_link = NIL THEN
            ept^.l_link := entry_point;
            RETURN;
          ELSE
            ept := ept^.l_link;
          IFEND;

        ELSE
          IF ept^.r_link = NIL THEN
            ept^.r_link := entry_point;
            RETURN;
          ELSE
            ept := ept^.r_link;
          IFEND;
        IFEND;

      WHILEND;


    PROCEND add_to_entry_points;
?? OLDTITLE ??
?? NEWTITLE := 'get_next_free_external', EJECT ??

    PROCEDURE get_next_free_external
      (VAR external: ^oct$ext_reference_list;
       VAR status: ost$status);


      VAR
        free_externals: ^array [1 .. occ$number_of_free_externals] of oct$ext_reference_list,
        i: 1 .. occ$number_of_free_externals;


      IF v$free_external_references = NIL THEN
        NEXT free_externals IN ocv$vel_scratch_seq;
        IF free_externals = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL3', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        v$free_external_references := ^free_externals^ [1];

        FOR i := 1 TO (occ$number_of_free_externals - 1) DO
          free_externals^ [i].link := ^free_externals^ [i + 1];
        FOREND;

        free_externals^ [occ$number_of_free_externals].link := NIL;
      IFEND;

      external := v$free_external_references;
      v$free_external_references := v$free_external_references^.link;


    PROCEND get_next_free_external;
?? OLDTITLE ??
?? NEWTITLE := 'get_next_free_external_item', EJECT ??

    PROCEDURE get_next_free_external_item
      (VAR item: ^oct$external_items;
       VAR status: ost$status);


      VAR
        item_array: ^array [1 .. occ$free_ext_item_increment] of oct$external_items,
        i: 1 .. occ$free_ext_item_increment;


      IF v$free_external_items = NIL THEN
        NEXT item_array IN ocv$vel_scratch_seq;
        IF item_array = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL4', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        v$free_external_items := ^item_array^ [1];

        FOR i := 1 TO (occ$free_ext_item_increment - 1) DO
          item_array^ [i].link := ^item_array^ [i + 1];
        FOREND;

        item_array^ [occ$free_ext_item_increment].link := NIL;
      IFEND;

      item := v$free_external_items;
      v$free_external_items := v$free_external_items^.link;


    PROCEND get_next_free_external_item;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_external_items', EJECT ??

    PROCEDURE add_to_external_items
      (    external_linkage_item: array [1 .. * ] of llt$external_linkage_item;
           external: ^oct$ext_reference_list;
           mod_name: pmt$program_name;
       VAR status: ost$status);


      VAR
        module_name: ^oct$program_name_list,
        i: integer,
        item: ^oct$external_items,
        address: ^oct$addresses;


      get_next_free_program_name (module_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      module_name^.name := mod_name;
      module_name^.link := external^.modules_referencing;
      external^.modules_referencing := module_name;

      FOR i := 1 TO UPPERBOUND (external_linkage_item) DO
        validate_section (external_linkage_item [i].section_ordinal, 0, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF external_linkage_item [i].kind > UPPERVALUE (llt$address_kind) THEN
          osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid address kind encountered',
                status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        obtain_destination_address (v$mdt, external_linkage_item [i].kind,
              external_linkage_item [i].section_ordinal, external_linkage_item [i].offset, address, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        get_next_free_external_item (item, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        item^.kind := external_linkage_item [i].kind;
        item^.address := address;
        item^.offset_operand := external_linkage_item [i].offset_operand;
        item^.output := v$mdt^.section_table [external_linkage_item [i].section_ordinal].output;
        item^.link := external^.items.link;
        external^.items.link := item;
      FOREND;


    PROCEND add_to_external_items;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_external_reference', EJECT ??

    PROCEDURE initialize_external_reference
      (    external_linkage: ^llt$external_linkage;
       VAR external: ^oct$ext_reference_list);

      external^.name := external_linkage^.name;
      external^.language := external_linkage^.language;
      external^.declaration_matching_required := external_linkage^.declaration_matching_required;
      external^.declaration_matching := external_linkage^.declaration_matching;

      external^.r1 := v$mdt^.r1;
      external^.r2 := v$mdt^.r2;

      external^.items.link := NIL;
      external^.check_for_ring_violation := TRUE;
      external^.modules_referencing := NIL;

      external^.link := NIL;


    PROCEND initialize_external_reference;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_external_names', EJECT ??

    PROCEDURE add_to_external_names
      (    name: pmt$program_name;
       VAR status: ost$status);


      VAR
        external: ^oct$program_name_list,
        free_names: ^array [1 .. occ$free_ext_name_increment] of oct$program_name_list,
        i: integer;


      external := ^v$mdt^.external_names;

      WHILE (external^.link <> NIL) AND (external^.link^.name <> name) DO
        external := external^.link;
      WHILEND;

      IF external^.link = NIL THEN
        IF v$free_external_names = NIL THEN
          NEXT free_names IN ocv$vel_scratch_seq;
          IF free_names = NIL THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL5', status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          v$free_external_names := ^free_names^ [1];
          FOR i := 1 TO (occ$free_ext_name_increment - 1) DO
            free_names^ [i].link := ^free_names^ [i + 1];
          FOREND;
          free_names^ [occ$free_ext_name_increment].link := NIL;
        IFEND;

        external^.link := v$free_external_names;
        v$free_external_names := v$free_external_names^.link;

        external := external^.link;
        external^.name := name;
        external^.link := NIL;
      IFEND;


    PROCEND add_to_external_names;
?? OLDTITLE ??
?? NEWTITLE := 'print_external_names', EJECT ??

    PROCEDURE print_external_names
      (VAR external_names: oct$program_name_list);


      VAR
        external: ^oct$program_name_list,
        flush_it: boolean;


      IF external_names.link <> NIL THEN
        space (2);
        output ('', '   EXTERNAL ENTRY POINTS REFERENCED', 35, flush);
        output ('', '   -----------------------------------------------------------------', 68, flush);
        flush_it := FALSE;

        REPEAT
          external := external_names.link;
          external_names.link := external_names.link^.link;
          external^.link := v$free_external_names;
          v$free_external_names := external;

          output ('   ', external^.name, STRLENGTH (external^.name), flush_it);
          flush_it := NOT flush_it;

        UNTIL external_names.link = NIL;

        IF flush_it THEN
          output (' ', ' ', 1, flush);
        IFEND;
      IFEND;


    PROCEND print_external_names;
?? OLDTITLE ??
?? NEWTITLE := 'add_adr_to_products_adr_list', EJECT ??

    PROCEDURE add_adr_to_products_adr_list
      (    adr: ^llt$address_formulation;
       VAR status: ost$status);


      VAR
        i: integer,
        dest_relocation: ost$segment_length,
        value_relocation: ost$segment_length;


      NEXT v$last_address_formulation^.link IN ocv$vel_scratch_seq;
      v$last_address_formulation := v$last_address_formulation^.link;
      IF v$last_address_formulation = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL934', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      NEXT v$last_address_formulation^.address_formulation: [1 .. UPPERBOUND (adr^.item)] IN
            ocv$vel_scratch_seq;
      IF v$last_address_formulation^.address_formulation = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL934', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      v$last_address_formulation^.link := NIL;
      v$last_address_formulation^.address_formulation^ := adr^;
      v$last_address_formulation^.address_formulation^.dest_section := v$mdt^.
            section_table [adr^.dest_section].pva.seg;
      v$last_address_formulation^.address_formulation^.value_section := v$mdt^.
            section_table [adr^.value_section].pva.seg;

      dest_relocation := #OFFSET (v$mdt^.section_table [adr^.dest_section].text);
      IF v$mdt^.section_table [adr^.value_section].text <> NIL THEN
        value_relocation := #OFFSET (v$mdt^.section_table [adr^.value_section].text);
      ELSE
        value_relocation := 0;
      IFEND;

      FOR i := 1 TO UPPERBOUND (v$last_address_formulation^.address_formulation^.item) DO
        v$last_address_formulation^.address_formulation^.item [i].dest_offset :=
              v$last_address_formulation^.address_formulation^.item [i].dest_offset + dest_relocation;
        v$last_address_formulation^.address_formulation^.item [i].value_offset :=
              v$last_address_formulation^.address_formulation^.item [i].value_offset + value_relocation;
      FOREND;


    PROCEND add_adr_to_products_adr_list;
?? OLDTITLE ??
?? NEWTITLE := 'add_item_to_products_adr_list', EJECT ??

    PROCEDURE add_item_to_products_adr_list
      (    dest_segment: ost$segment;
           dest_offset: ost$segment_offset;
           kind: llt$address_kind;
           value_segment: ost$segment;
           value_offset: ost$segment_offset;
       VAR status: ost$status);


      NEXT v$last_address_formulation^.link IN ocv$vel_scratch_seq;
      v$last_address_formulation := v$last_address_formulation^.link;
      IF v$last_address_formulation = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL934', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      NEXT v$last_address_formulation^.address_formulation: [1 .. 1] IN ocv$vel_scratch_seq;
      IF v$last_address_formulation^.address_formulation = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL934', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      v$last_address_formulation^.link := NIL;
      v$last_address_formulation^.address_formulation^.dest_section := dest_segment;
      v$last_address_formulation^.address_formulation^.value_section := value_segment;
      v$last_address_formulation^.address_formulation^.item [1].kind := kind;
      v$last_address_formulation^.address_formulation^.item [1].dest_offset := dest_offset;
      v$last_address_formulation^.address_formulation^.item [1].value_offset := value_offset;


    PROCEND add_item_to_products_adr_list;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_segments_rel_list', EJECT ??

    PROCEDURE add_to_segments_rel_list
      (    address: ^oct$addresses;
       VAR segments_rel_list: oct$segment_relocation_list;
       VAR status: ost$status);

      VAR
        relocation_value: ^oct$segment_relocation_list;


      NEXT relocation_value IN ocv$vel_scratch_seq;
      IF relocation_value = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL1112', status);
        RETURN;
      IFEND;

      relocation_value^.pva := #ADDRESS (#RING (address), #SEGMENT (address), (#OFFSET (address) + 0));
      relocation_value^.link := segments_rel_list.link;
      segments_rel_list.link := relocation_value;


    PROCEND add_to_segments_rel_list;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] update_number_of_bytes_written', EJECT ??

    PROCEDURE [INLINE] update_number_of_bytes_written
      (    offset: ost$segment_length;
       VAR number_of_bytes_written: ost$segment_length);


      IF offset > number_of_bytes_written THEN
        number_of_bytes_written := offset;
      IFEND;


    PROCEND update_number_of_bytes_written;
?? OLDTITLE ??
?? NEWTITLE := 'setup_link', EJECT ??

    PROCEDURE setup_link
      (VAR status: ost$status);


      VAR
        i: ost$status_severity,
        page_size: ost$page_size,
        segment_attributes_p: ^array [ * ] of mmt$user_attribute_descriptor;


{ Set up link map variables.

      v$lm_asis_text.code := loc$lm_asis_text;
      v$lm_issue_diagnostic.code := loc$lm_issue_diagnostic;

      v$lm_diagnostic_summary.code := loc$lm_diagnostic_summary;
      FOR i := LOWERVALUE (ost$status_severity) TO UPPERVALUE (ost$status_severity) DO
        v$lm_diagnostic_summary.diagnostic_count [i] := 0;
      FOREND;

      v$lm_module_detail_1.code := loc$lm_module_detail_1;
      v$lm_module_detail_2.code := loc$lm_module_detail_2;
      v$lm_section_detail.code := loc$lm_section_detail;
      v$lm_entry_detail.code := loc$lm_entry_detail;
      v$lm_transfer_detail.code := loc$lm_transfer_detail;
      v$lm_segment_detail.code := loc$lm_segment_detail;
      v$lm_page_header.code := loc$lm_page_header;

{ Set up product variables

      IF link_parameters.mode = occ$product THEN
        v$number_of_libraries := 0;
        v$library_list.link := NIL;
        v$last_address_formulation := ^v$address_formulation_records;
        v$last_address_formulation^.link := NIL;
      IFEND;

{ Set up global link variables.

      pmp$get_page_size (page_size, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      v$page_size := page_size;

      v$output_buffer := '  ';
      v$output_pos := 1;

      v$output_segment_list.link := NIL;
      v$section_name_list.link := NIL;

      IF link_parameters.starting_segment = occ$null_seg_value THEN
        IF link_parameters.mode <> occ$product THEN
          v$current_segment_number := occ$initial_segment_number;
        ELSE
          v$current_segment_number := mmc$first_loader_predefined_seg;
        IFEND;
      ELSE
        v$current_segment_number := link_parameters.starting_segment;
      IFEND;

      IF link_parameters.mode <> occ$product THEN
        v$minimum_segment_number := LOWERVALUE (ost$segment);
        v$maximum_segment_number := UPPERVALUE (ost$segment);
      ELSE
        v$minimum_segment_number := mmc$first_loader_predefined_seg;
        v$maximum_segment_number := mmc$first_loader_predefined_seg + mmc$num_loader_predefined_segs - 1;
      IFEND;
      v$next_retained_cmnblk_seg_num := v$maximum_segment_number + 1;

      v$common_block_table.link := NIL;

      v$next_free_formal_parameter := occ$number_of_free_formal_param + 1;
      v$formal_param_definitions.defining_module := osc$null_name;
      v$formal_param_definitions.r_link := NIL;
      v$formal_param_definitions.l_link := NIL;

      v$next_free_actual_parameter := occ$number_of_free_actual_param + 1;
      v$actual_param_groups.name := osc$null_name;
      v$actual_param_groups.link := NIL;
      v$next_free_entry_point := occ$number_of_free_entry_points + 1;
      v$free_program_names := NIL;
      v$free_entry_points := NIL;
      v$entry_points.name := osc$null_name;
      v$entry_points.r_link := NIL;
      v$entry_points.l_link := NIL;
      v$entry_points.link := NIL;
      v$last_entry_point := ^v$entry_points;

      v$unsatisfied_externals.link := NIL;
      v$unsatisfied_actual_param.link := NIL;
      v$free_external_references := NIL;
      v$free_external_items := NIL;
      v$free_external_names := NIL;

      v$starting_procedure := link_parameters.starting_procedure;
      v$last_starting_procedure := osc$null_name;
      v$starting_entry_point := NIL;

      PUSH segment_attributes_p: [1 .. 1];
      segment_attributes_p^ [1].keyword := mmc$ua_preset_value;
      segment_attributes_p^ [1].preset_value := link_parameters.preset_value;
      mmp$create_user_segment (segment_attributes_p, amc$sequence_pointer, mmc$as_sequential,
            v$retained_common_block_segment, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET v$retained_common_block_segment.sequence_pointer;

      get_binding_rings_1_and_2 (v$binding_r1, v$binding_r2);

      get_modules_to_add (v$modules_to_add, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      add_externals_to_satisfy (v$unsatisfied_externals, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


    PROCEND setup_link;
?? OLDTITLE ??
?? NEWTITLE := 'process_predefined_segments', EJECT ??

    PROCEDURE process_predefined_segments
      (    predefined_segment_list: oct$output_segment_descriptor;
       VAR status: ost$status);


      VAR
        old_segment: ^oct$output_segment_descriptor,
        new_segment: ^oct$output_segment_descriptor,

        old_section: ^oct$section_name_list,
        new_section: ^oct$section_name_list;


      old_segment := predefined_segment_list.link;
      new_segment := ^v$output_segment_list;

      WHILE old_segment <> NIL DO
        NEXT new_segment^.link IN ocv$vel_scratch_seq;
        new_segment := new_segment^.link;
        IF new_segment = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL6', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        new_segment^ := old_segment^;
        new_segment^.link := NIL;

        get_segment_number (new_segment^.retained_common_block, new_segment^.number_predefined,
              new_segment^.number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        old_segment := old_segment^.link;
      WHILEND;

      old_section := ocv$section_name_list.link;
      new_section := ^v$section_name_list;

      WHILE old_section <> NIL DO
        NEXT new_section^.link IN ocv$vel_scratch_seq;
        new_section := new_section^.link;
        IF new_section = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL7', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        new_section^ := old_section^;

        old_segment := predefined_segment_list.link;
        new_segment := v$output_segment_list.link;

        WHILE old_segment <> old_section^.segment_descriptor DO
          old_segment := old_segment^.link;
          new_segment := new_segment^.link;
        WHILEND;

        new_section^.segment_descriptor := new_segment;

        old_section := old_section^.link;
      WHILEND;

      new_section^.link := NIL;


    PROCEND process_predefined_segments;
?? OLDTITLE ??
?? NEWTITLE := 'process_inboard_symbol_tables', EJECT ??

    PROCEDURE process_inboard_symbol_tables
      (    symbol_tables_to_use: oct$symbol_table_descriptor;
       VAR status: ost$status);


      VAR
        next_symbol_table: ^oct$symbol_table_descriptor,
        inboard_symbol_table: ^oct$list_of_entry_points,
        linker_symbol_table: ^oct$list_of_entry_points,
        i: integer;


      next_symbol_table := symbol_tables_to_use.link;

      WHILE next_symbol_table <> NIL DO
        IF next_symbol_table^.header^.number_of_symbols > 0 THEN
          NEXT linker_symbol_table: [1 .. next_symbol_table^.header^.number_of_symbols] IN
                ocv$vel_scratch_seq;
          IF linker_symbol_table = NIL THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL8', status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          linker_symbol_table^ := next_symbol_table^.symbol_table^;

          FOR i := 1 TO next_symbol_table^.header^.number_of_symbols DO
            linker_symbol_table^ [i].inboard_symbol := TRUE;
            linker_symbol_table^ [i].l_link := NIL;
            linker_symbol_table^ [i].r_link := NIL;
            linker_symbol_table^ [i].link := NIL;

            add_to_entry_points (^linker_symbol_table^ [i]);
          FOREND;
        IFEND;

        next_symbol_table := next_symbol_table^.link;
      WHILEND;


    PROCEND process_inboard_symbol_tables;
?? OLDTITLE ??
?? NEWTITLE := 'process_identification_record', EJECT ??

    PROCEDURE process_identification_record
      (    object_file: ^oct$object_file_descriptor;
       VAR module_kind: llt$module_kind;
       VAR status: ost$status);


      VAR
        date_time: clt$date_time,
        identification: ^llt$identification,
        i: llt$section_ordinal,
        local_status: ost$status,
        object_text_descriptor: ^llt$object_text_descriptor,
        parsed_file_reference: fst$parsed_file_reference,
        str: ost$string;


      status.normal := TRUE;
      local_status.normal := TRUE;

      NEXT object_text_descriptor IN object_file^.segment.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, object_file^.name^, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      IF object_text_descriptor^.kind <> llc$identification THEN
        osp$set_status_abnormal (oc, oce$e_bad_obj_text_on_file, object_file^.name^, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'Identification record expected',
              status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      NEXT identification IN object_file^.segment.sequence_pointer;
      IF identification = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, object_file^.name^, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      IF (pmc$block_map IN link_parameters.map_options) OR
            (pmc$entry_point_map IN link_parameters.map_options) THEN
        v$lm_module_detail_1.module_name := identification^.name;

        clp$convert_string_to_file_ref (object_file^.name^, parsed_file_reference, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        v$lm_module_detail_1.file_name := parsed_file_reference.
              path (parsed_file_reference.last_name.index, parsed_file_reference.last_name.size);
        v$lm_module_detail_1.loaded_ring := object_file^.r2;
        v$lm_module_detail_1.call_bracket := object_file^.r3;
        v$lm_module_detail_1.module_global_key_lock := object_file^.global_key;
        v$lm_module_detail_1.module_local_key_lock := object_file^.local_key;
        v$lm_module_detail_1.execute_privilege := object_file^.execute_privilege;

        IF object_file^.is_a_library THEN
          v$lm_module_detail_1.file_type := 'LIBRARY';
        ELSE
          v$lm_module_detail_1.file_type := '  FILE ';
        IFEND;

        ocp$generate_link_map_text (v$lm_module_detail_1);

        v$lm_module_detail_2.date := '**********';

        CASE identification^.date_created.date_format OF
        = osc$month_date =
          clp$convert_string_to_date_time (identification^.date_created.month, 'MONTH', date_time,
                local_status);

        = osc$mdy_date =
          clp$convert_string_to_date_time (identification^.date_created.mdy, 'MDY', date_time, local_status);

        = osc$iso_date =
          v$lm_module_detail_2.date := identification^.date_created.iso;

        = osc$ordinal_date =
          clp$convert_string_to_date_time (identification^.date_created.ordinal, 'ORDINAL', date_time,
                local_status);

        = osc$dmy_date =
          clp$convert_string_to_date_time (identification^.date_created.dmy, 'DMY', date_time, local_status);

        ELSE
          ;
        CASEND;

        IF local_status.normal AND (identification^.date_created.date_format <> osc$iso_date) THEN
          clp$convert_date_time_to_string (date_time, 'ISOD', str, local_status);
          IF local_status.normal THEN
            v$lm_module_detail_2.date := str.value (1, str.size);
          IFEND;
        IFEND;

        v$lm_module_detail_2.generator := identification^.generator_name_vers;
        v$lm_module_detail_2.commentary := identification^.commentary;

        ocp$generate_link_map_text (v$lm_module_detail_2);
      IFEND;

      IF identification^.object_text_version <> llc$object_text_version THEN
        osp$set_status_abnormal (oc, oce$e_invalid_obj_text_version, identification^.object_text_version,
              status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      NEXT v$mdt: [0 .. identification^.greatest_section_ordinal] IN ocv$vel_scratch_seq;
      IF v$mdt = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL9', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      v$mdt^.name := identification^.name;
      v$mdt^.r1 := object_file^.r1;
      v$mdt^.r2 := object_file^.r2;
      v$mdt^.r3 := object_file^.r3;
      v$mdt^.global_key := object_file^.global_key;
      v$mdt^.local_key := object_file^.local_key;

      v$mdt^.ring_of_execution := object_file^.r1;
      v$mdt^.execute_attribute := object_file^.execute_privilege;

      v$mdt^.binding_section_encountered := FALSE;
      v$mdt^.binding_section.ring := osc$max_ring;
      v$mdt^.binding_section.seg := 0;
      v$mdt^.binding_section.offset := 0;

      v$mdt^.default_sections := object_file^.default_sections;

      FOR i := 0 TO identification^.greatest_section_ordinal DO
        v$mdt^.section_table [i].undefined := TRUE;
      FOREND;

      v$mdt^.external_names.link := NIL;

      IF llc$object_cybil_checking IN identification^.attributes THEN
        v$source_type_checking := FALSE;
      IFEND;

      module_kind := identification^.kind;

      IF v$generate_debug_tables THEN
        ocp$dtb_define_module (identification, status);
        IF NOT status.normal THEN
          issue_diagnostic (osc$fatal_status, status);
        IFEND;
      IFEND;


    PROCEND process_identification_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_ppu_absolute_record', EJECT ??

    PROCEDURE process_ppu_absolute_record
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        ppu_absolute: ^llt$ppu_absolute;


      NEXT object_text_descriptor IN object_file^.segment.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      IF object_text_descriptor^.kind <> llc$ppu_absolute THEN
        osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'PPU absolute record expected', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      NEXT ppu_absolute: [0 .. (object_text_descriptor^.number_of_words - 1)] IN
            object_file^.segment.sequence_pointer;
      IF ppu_absolute = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      osp$set_status_abnormal (oc, oce$w_module_not_included, v$mdt^.name, status);
      issue_diagnostic (osc$warning_status, status);


    PROCEND process_ppu_absolute_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_libraries_record', EJECT ??

    PROCEDURE process_libraries_record
      (    object_file: ^oct$object_file_descriptor;
           number_of_libraries: 1 .. llc$max_libraries;
       VAR status: ost$status);


      VAR
        libraries: ^llt$libraries,
        library: ^oct$object_file_descriptor,
        lib: ^oct$known_file_list,
        i: 1 .. llc$max_libraries,
        parsed_file_reference: fst$parsed_file_reference;


      NEXT libraries: [1 .. number_of_libraries] IN object_file^.segment.sequence_pointer;
      IF libraries = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      FOR i := 1 TO number_of_libraries DO
        library := link_parameters.object_libraries_to_use.link;

      /find_library/
        WHILE (library <> NIL) DO
          clp$convert_string_to_file_ref (library^.name^, parsed_file_reference, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF (parsed_file_reference.path (parsed_file_reference.last_name.index,
                parsed_file_reference.last_name.size) = libraries^ [i]) THEN
            EXIT /find_library/;
          IFEND;

          library := library^.link;
        WHILEND /find_library/;

        IF library = NIL THEN
          osp$set_status_abnormal (oc, oce$w_required_library_missing, libraries^ [i], status);
          issue_diagnostic (osc$warning_status, status);
        IFEND;

        IF link_parameters.mode = occ$product THEN
          lib := ^v$library_list;

          WHILE (lib^.link <> NIL) AND (lib^.link^.name^ <> libraries^ [i]) DO
            lib := lib^.link;
          WHILEND;

          IF lib^.link = NIL THEN
            v$number_of_libraries := v$number_of_libraries + 1;
            ocp$add_to_known_files (libraries^ [i], lib^, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      FOREND;


    PROCEND process_libraries_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_application_id_record', EJECT ??

    PROCEDURE process_application_id_record
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        application_identifier: ^llt$application_identifier;


      NEXT application_identifier IN object_file^.segment.sequence_pointer;
      IF application_identifier = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

    PROCEND process_application_id_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_section_definition', EJECT ??

    PROCEDURE process_section_definition
      (    object_file: ^oct$object_file_descriptor;
           unallocated_common_block: boolean;
           allotted_section: ost$relative_pointer;
       VAR status: ost$status);

?? NEWTITLE := 'obtain_section_attributes', EJECT ??

      PROCEDURE obtain_section_attributes
        (    section_item: oct$section_table_item;
         VAR attributes: oct$section_attributes);


        IF (v$mdt^.global_key <> 0) OR (v$mdt^.local_key <> 0) THEN
          attributes.read_default := osc$read_key_lock_controlled;
          attributes.write_default := osc$write_key_lock_controlled;
        ELSE
          attributes.read_default := osc$read_uncontrolled;
          attributes.write_default := osc$write_uncontrolled;
        IFEND;

        attributes.execute_default := v$mdt^.execute_attribute;

        attributes.cache_bypass := FALSE;

        attributes.extensible := (section_item.definition.kind = llc$extensible_working_storage) OR
              (section_item.definition.kind = llc$extensible_common_block);

        IF llc$binding IN section_item.definition.access_attributes THEN
          attributes.read_attribute := osc$binding_segment;
        ELSEIF llc$read IN section_item.definition.access_attributes THEN
          attributes.read_attribute := attributes.read_default;
        ELSE
          attributes.read_attribute := osc$non_readable;
        IFEND;

        IF llc$write IN section_item.definition.access_attributes THEN
          attributes.write_attribute := attributes.write_default;
        ELSE
          attributes.write_attribute := osc$non_writable;
        IFEND;

        IF llc$execute IN section_item.definition.access_attributes THEN
          attributes.execute_attribute := attributes.execute_default;
        ELSE
          attributes.execute_attribute := osc$non_executable;
        IFEND;


      PROCEND obtain_section_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'convert_section_attributes', EJECT ??

      PROCEDURE convert_section_attributes
        (    section_attributes: oct$section_attributes;
         VAR segment_attributes: oct$segment_attributes);


        VAR
          read_attributes: [STATIC] array [ost$read_privilege] of oct$segment_attributes :=
                [$oct$segment_attributes [], $oct$segment_attributes [occ$sa_read_kl],
                $oct$segment_attributes [occ$sa_read], $oct$segment_attributes [occ$sa_binding]],

          write_attributes: [STATIC] array [ost$write_privilege] of oct$segment_attributes :=
                [$oct$segment_attributes [], $oct$segment_attributes [occ$sa_write_kl],
                $oct$segment_attributes [occ$sa_write], $oct$segment_attributes []],

          execute_attributes: [STATIC] array [ost$execute_privilege] of oct$segment_attributes :=
                [$oct$segment_attributes [], $oct$segment_attributes [occ$sa_non_privileged],
                $oct$segment_attributes [occ$sa_local_privilege],
                $oct$segment_attributes [occ$sa_global_privilege]],

          cache_bypass_attributes: [STATIC] array [boolean] of oct$segment_attributes :=
                [$oct$segment_attributes [], $oct$segment_attributes [occ$sa_cache_bypass]],

          extensible_attributes: [STATIC] array [boolean] of oct$segment_attributes :=
                [$oct$segment_attributes [], $oct$segment_attributes [occ$sa_extensible]];


        segment_attributes := read_attributes [section_attributes.read_attribute] +
              write_attributes [section_attributes.write_attribute] +
              execute_attributes [section_attributes.execute_attribute] +
              cache_bypass_attributes [section_attributes.cache_bypass] +
              extensible_attributes [section_attributes.extensible];


      PROCEND convert_section_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'find_section_name_to_allocate', EJECT ??

      PROCEDURE find_section_name_to_allocate
        (    access_attributes: llt$section_access_attributes;
             default_sections: ^oct$default_sections;
         VAR section_name_to_allocate: pmt$program_name);


        VAR
          i: integer;


        IF default_sections <> NIL THEN

          FOR i := 1 TO UPPERBOUND (default_sections^) DO
            IF access_attributes = default_sections^ [i].attributes THEN
              section_name_to_allocate := default_sections^ [i].name;
              RETURN;
            IFEND;
          FOREND;

        IFEND;


      PROCEND find_section_name_to_allocate;
?? OLDTITLE ??
?? NEWTITLE := 'print_section_definition', EJECT ??

      PROCEDURE print_section_definition
        (    section_name: pmt$program_name;
             section_item: oct$section_table_item);


        v$lm_section_detail.section_kind := section_item.definition.kind;
        v$lm_section_detail.section_access_attributes := section_item.definition.access_attributes;
        v$lm_section_detail.section_address.ring := section_item.pva.ring;
        v$lm_section_detail.section_address.segment := section_item.pva.seg;
        v$lm_section_detail.section_address.offset := section_item.pva.offset;
        v$lm_section_detail.section_length := section_item.definition.length;
        v$lm_section_detail.section_name := section_item.section_name;

        ocp$generate_link_map_text (v$lm_section_detail);

        IF (section_item.definition.kind = llc$common_block) OR
              (section_item.definition.kind = llc$extensible_common_block) THEN
          output ('    NAME: ', section_item.common_block_name, #SIZE (section_item.common_block_name),
                flush);
        ELSEIF section_name <> osc$null_name THEN
          output ('    NAME: ', section_name, #SIZE (section_name), flush);
        IFEND;


      PROCEND print_section_definition;
?? OLDTITLE ??
?? NEWTITLE := 'create_segment_for_section', EJECT ??

      PROCEDURE create_segment_for_section
        (    section_item: oct$section_table_item;
             segment_attributes: oct$segment_attributes;
         VAR segment: ^oct$output_segment_descriptor;
         VAR status: ost$status);

        TYPE
          section_kinds = set of llt$section_kind;

        VAR
          last_segment: ^oct$output_segment_descriptor,
          preset_value: pmt$initialization_value;

        status.normal := TRUE;
        IF link_parameters.mode = occ$mc68000 THEN
          osp$set_status_abnormal (oc, oce$e_add_undefined_68000_seq, 'VEL157', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        NEXT segment IN ocv$vel_scratch_seq;
        IF segment = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL10', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        segment^.used_attributes := segment_attributes;
        segment^.unused_attributes := $oct$segment_attributes [];

        IF occ$sa_extensible IN segment_attributes THEN
          segment^.extensible_attribute := occ$unallocated_extensible;
        ELSE
          segment^.extensible_attribute := occ$non_extensible;
        IFEND;

        segment^.r1 := section_item.r1;
        segment^.r2 := section_item.r2;
        segment^.r3 := section_item.r3;
        segment^.global_key := section_item.global_key;
        segment^.local_key := section_item.local_key;
        segment^.retained_common_block := section_item.retained_common_block;
        segment^.number_predefined := FALSE;
        segment^.sections_allocated.link := NIL;
        segment^.inhibit_binding_check := FALSE;
        segment^.binding_section_encountered := FALSE;
        segment^.binding_section_segment := 0;
        segment^.binding_section_offset := 0;
        segment^.number_of_bytes_written := 0;
        segment^.relocation_list.link := NIL;
        segment^.link := NIL;
        segment^.cybil_default_heap := (section_item.common_block_name = cyc$default_heap_name);

        IF section_item.definition.kind IN $section_kinds [llc$working_storage_section, llc$common_block,
              llc$extensible_working_storage, llc$extensible_common_block] THEN
          preset_value := link_parameters.preset_value;
        ELSE
          preset_value := pmc$initialize_to_zero;
        IFEND;

        open_temporary_segment (section_item, preset_value, segment, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        last_segment := ^v$output_segment_list;

        WHILE last_segment^.link <> NIL DO
          last_segment := last_segment^.link;
        WHILEND;

        last_segment^.link := segment;


      PROCEND create_segment_for_section;
?? OLDTITLE ??
?? NEWTITLE := 'allocate_section_in_segment', EJECT ??

      PROCEDURE allocate_section_in_segment
        (VAR section_item: oct$section_table_item;
         VAR status: ost$status);


        VAR
          valid_position: boolean,
          current_sequence_position: ost$segment_offset;


        status.normal := TRUE;
        current_sequence_position := i#current_sequence_position
              (section_item.output^.segment.sequence_pointer);

        WHILE (current_sequence_position MOD section_item.definition.allocation_alignment) <>
              section_item.definition.allocation_offset DO
          current_sequence_position := current_sequence_position + 1;
        WHILEND;

        pmp$position_object_library (section_item.output^.segment.sequence_pointer, current_sequence_position,
              valid_position);
        IF NOT valid_position THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL11', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        section_item.pva.offset := current_sequence_position;

        IF section_item.definition.length = 0 THEN
          section_item.text := NIL;

        ELSE
          NEXT section_item.text: [0 .. (section_item.definition.length - 1)] IN
                section_item.output^.segment.sequence_pointer;
          IF section_item.text = NIL THEN
            osp$set_status_condition (oce$e_sec_overflow_in_segment, status);
            osp$append_status_integer (osc$status_parameter_delimiter, section_item.output^.number, 10, FALSE,
                  status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;
        IFEND;

        IF section_item.output^.extensible_attribute = occ$unallocated_extensible THEN
          section_item.output^.extensible_attribute := occ$allocated_extensible;
        IFEND;

        section_item.r1 := section_item.output^.r1;
        section_item.r2 := section_item.output^.r2;
        section_item.r3 := section_item.output^.r3;


      PROCEND allocate_section_in_segment;
?? OLDTITLE ??
?? NEWTITLE := 'get_segment_for_unnamed_section', EJECT ??

      PROCEDURE get_segment_for_unnamed_section
        (VAR section_item: oct$section_table_item;
             segment_attributes: oct$segment_attributes;
         VAR status: ost$status);


        VAR
          extensible_attribute: oct$extensible_attributes,
          segment: ^oct$output_segment_descriptor;


        IF occ$sa_extensible IN segment_attributes THEN
          extensible_attribute := occ$unallocated_extensible;
        ELSE
          extensible_attribute := occ$non_extensible;
        IFEND;

        IF ((link_parameters.mode = occ$product) AND (section_item.definition.kind = llc$code_section)) OR
              ((section_item.retained_common_block) AND (NOT section_item.deferred_common_block)) THEN
          segment := NIL;
        ELSE
          segment := v$output_segment_list.link;

          WHILE (segment <> NIL) AND (NOT ((segment^.extensible_attribute = extensible_attribute) AND
                (segment^.used_attributes = segment_attributes) AND (segment^.r1 = section_item.r1) AND
                (segment^.r2 = section_item.r2) AND (segment^.r3 = section_item.r3) AND
                (segment^.global_key = section_item.global_key) AND
                (segment^.local_key = section_item.local_key) AND (NOT segment^.retained_common_block))) DO

            segment := segment^.link;

          WHILEND;
        IFEND;

        IF segment = NIL THEN

{ Common block cannot be deferred if the segment has not already been defined.

          section_item.deferred_common_block := FALSE;

          create_segment_for_section (section_item, segment_attributes, segment, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        section_item.output := segment;
        section_item.pva.seg := segment^.number;


      PROCEND get_segment_for_unnamed_section;
?? OLDTITLE ??
?? NEWTITLE := 'get_segment_for_named_section', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to determine if a named section is already
{   known to the linker and, if it is not, to determine whether to create a
{   segment for it or not.  If the named section is already known or a segment is
{   created, then the segment description is added to the section information and,
{   if necessary, the name of the section allocated is added to the segment
{   description.

      PROCEDURE get_segment_for_named_section
        (VAR section_item: oct$section_table_item;
             segment_attributes: oct$segment_attributes;
         VAR status: ost$status);


        VAR
          extensible_attribute: oct$extensible_attributes,
          section_name: ^oct$section_name_list,
          section_names: ^oct$program_name_list;


        IF occ$sa_extensible IN segment_attributes THEN
          extensible_attribute := occ$unallocated_extensible;
        ELSE
          extensible_attribute := occ$non_extensible;
        IFEND;

        section_name := v$section_name_list.link;

        WHILE (section_name <> NIL) AND ((section_name^.name <> section_item.section_name) OR
              (extensible_attribute <> section_name^.segment_descriptor^.extensible_attribute)) DO

          section_name := section_name^.link;

        WHILEND;

        IF section_name = NIL THEN
          IF link_parameters.create_only_predefined_segments THEN
            osp$set_status_abnormal (oc, oce$e_seg_not_defined_for_sect, section_item.section_name, status);
            issue_diagnostic (osc$error_status, status);
          IFEND;

          NEXT section_name IN ocv$vel_scratch_seq;
          IF section_name = NIL THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL12', status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          section_name^.name := section_item.section_name;
          section_name^.link := v$section_name_list.link;
          v$section_name_list.link := section_name;

          create_segment_for_section (section_item, segment_attributes, section_name^.segment_descriptor,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        section_item.output := section_name^.segment_descriptor;
        section_item.pva.seg := section_name^.segment_descriptor^.number;

        section_names := ^section_name^.segment_descriptor^.sections_allocated;

        WHILE (section_names^.link <> NIL) AND (section_names^.link^.name <> section_item.section_name) DO
          section_names := section_names^.link;
        WHILEND;

        IF section_names^.link = NIL THEN
          NEXT section_names^.link IN ocv$vel_scratch_seq;
          section_names := section_names^.link;
          IF section_names = NIL THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL13', status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          section_names^.name := section_item.section_name;
          section_names^.link := NIL;
        IFEND;


      PROCEND get_segment_for_named_section;
?? OLDTITLE ??
?? NEWTITLE := 'assign_section_to_a_segment', EJECT ??

      PROCEDURE assign_section_to_a_segment
        (VAR section_item: oct$section_table_item;
             section_attributes: oct$section_attributes;
         VAR status: ost$status);


        VAR
          segment_attributes: oct$segment_attributes;


        convert_section_attributes (section_attributes, segment_attributes);

        IF (section_item.section_name = osc$null_name) OR (link_parameters.ignore_section_names) THEN
          get_segment_for_unnamed_section (section_item, segment_attributes, status);
        ELSE
          get_segment_for_named_section (section_item, segment_attributes, status);
        IFEND;

        IF NOT status.normal THEN
          RETURN;
        IFEND;

        allocate_section_in_segment (section_item, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;


      PROCEND assign_section_to_a_segment;
?? OLDTITLE ??
?? NEWTITLE := 'assign_common_block_to_section', EJECT ??

      PROCEDURE assign_common_block_to_section
        (    common_block: ^oct$common_block_item;
         VAR section_item: oct$section_table_item;
         VAR status: ost$status);


        IF common_block^.section_item^.definition.access_attributes <>
              section_item.definition.access_attributes THEN
          osp$set_status_abnormal (oc, oce$w_conflicting_common_attr,
                common_block^.section_item^.common_block_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, v$mdt^.name, status);
          issue_diagnostic (osc$warning_status, status);
        IFEND;

        CASE section_item.definition.kind OF
        = llc$extensible_common_block =
          IF common_block^.section_item^.definition.kind = llc$common_block THEN
            osp$set_status_abnormal (oc, oce$w_conflicting_common_attr,
                  common_block^.section_item^.common_block_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, v$mdt^.name, status);
            issue_diagnostic (osc$warning_status, status);
          IFEND;

          IF common_block^.section_item^.definition.length < section_item.definition.length THEN
            IF common_block^.section_item^.definition.kind = llc$extensible_common_block THEN
              RESET common_block^.section_item^.output^.segment.sequence_pointer TO common_block^.
                    section_item^.text;
              NEXT common_block^.section_item^.text: [0 .. (section_item.definition.length - 1)] IN
                    common_block^.section_item^.output^.segment.sequence_pointer;
              IF common_block^.section_item^.text = NIL THEN
                osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL14', status);
                issue_diagnostic (osc$fatal_status, status);
                RETURN;
              IFEND;

              common_block^.section_item^.definition.length := section_item.definition.length;
            IFEND;
          IFEND;

        = llc$common_block =
          IF common_block^.section_item^.definition.kind = llc$extensible_common_block THEN
            osp$set_status_abnormal (oc, oce$w_conflicting_common_attr,
                  common_block^.section_item^.common_block_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, v$mdt^.name, status);
            issue_diagnostic (osc$warning_status, status);
          IFEND;

          IF common_block^.section_item^.definition.length < section_item.definition.length THEN
            osp$set_status_abnormal (oc, oce$w_conflicting_common_lngth,
                  common_block^.section_item^.common_block_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, v$mdt^.name, status);
            issue_diagnostic (osc$warning_status, status);
          IFEND;

        CASEND;

        section_item := common_block^.section_item^;
        section_item.pva.ring := v$mdt^.r1;
        section_item.r1 := v$mdt^.r2;
        section_item.r2 := v$mdt^.r2;
        section_item.r3 := v$mdt^.r2;


      PROCEND assign_common_block_to_section;
?? OLDTITLE ??
?? NEWTITLE := 'allocate_common_block', EJECT ??

      PROCEDURE allocate_common_block
        (VAR section_item: oct$section_table_item;
         VAR section_attributes: oct$section_attributes;
         VAR status: ost$status);


        VAR
          maximum_heap_size: [STATIC] ost$segment_length := 07fffffff(16),
          common_block: ^oct$common_block_item;


        IF llc$binding IN section_item.definition.access_attributes THEN
          section_attributes.read_attribute := section_attributes.read_default;
        IFEND;

        section_item.r1 := v$mdt^.r2;
        section_item.r2 := v$mdt^.r2;
        section_item.r3 := v$mdt^.r2;
        section_item.pva.ring := v$mdt^.r1;

        assign_section_to_a_segment (section_item, section_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF (link_parameters.mode = occ$mc68000) AND (section_item.common_block_name = cyc$default_heap_name)
              THEN
          IF link_parameters.heap_size_specified THEN
            i#move (#LOC (section_item.definition.length), #LOC (section_item.text^), 4);
          ELSE
            i#move (#LOC (maximum_heap_size), #LOC (section_item.text^), 4);
          IFEND;
          update_number_of_bytes_written ((#OFFSET (section_item.text) + 4),
                section_item.output^.number_of_bytes_written);
        IFEND;

        IF (NOT section_item.output^.inhibit_binding_check) AND
              (llc$binding IN section_item.definition.access_attributes) THEN
          osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'Binding attribute specified in non binding section', status);
          issue_diagnostic (osc$warning_status, status);
        IFEND;

        NEXT common_block IN ocv$vel_scratch_seq;
        IF common_block = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL15', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        common_block^.section_item := ^section_item;
        common_block^.link := v$common_block_table.link;
        v$common_block_table.link := common_block;


      PROCEND allocate_common_block;
?? OLDTITLE ??
?? NEWTITLE := 'allocate_code_section', EJECT ??

      PROCEDURE allocate_code_section
        (VAR section_item: oct$section_table_item;
         VAR section_attributes: oct$section_attributes;
         VAR status: ost$status);


        IF (section_item.definition.access_attributes - $llt$section_access_attributes
              [llc$read, llc$execute]) <> $llt$section_access_attributes [] THEN
          osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid code section attributes',
                status);
          issue_diagnostic (osc$error_status, status);

          section_attributes.read_attribute := section_attributes.read_default;
          section_attributes.write_attribute := osc$non_writable;
          section_attributes.execute_attribute := section_attributes.execute_default;
        IFEND;

        section_item.r1 := v$mdt^.r1;
        section_item.r2 := v$mdt^.r2;
        section_item.r3 := v$mdt^.r3;
        section_item.pva.ring := v$mdt^.ring_of_execution;

        assign_section_to_a_segment (section_item, section_attributes, status);


      PROCEND allocate_code_section;
?? OLDTITLE ??
?? NEWTITLE := 'allocate_binding_section', EJECT ??

      PROCEDURE allocate_binding_section
        (VAR section_item: oct$section_table_item;
         VAR section_attributes: oct$section_attributes;
         VAR status: ost$status);


        IF v$mdt^.binding_section_encountered THEN
          osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'Multiple binding sections encountered', status);
          issue_diagnostic (osc$error_status, status);
        ELSE
          v$mdt^.binding_section_encountered := TRUE;
        IFEND;

        IF (section_item.definition.access_attributes - $llt$section_access_attributes
              [llc$binding, llc$read]) <> $llt$section_access_attributes [] THEN
          section_attributes.read_attribute := osc$binding_segment;
          section_attributes.write_attribute := osc$non_writable;
          section_attributes.execute_attribute := osc$non_executable;
        IFEND;

        section_item.r1 := v$binding_r1;
        section_item.r2 := v$binding_r2;
        section_item.r3 := v$binding_r2;
        section_item.pva.ring := v$mdt^.ring_of_execution;
        section_item.global_key := 0; { master key }
        section_item.local_key := 0; { master key }

        assign_section_to_a_segment (section_item, section_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        v$mdt^.binding_section := section_item.pva;

        IF NOT section_item.output^.inhibit_binding_check THEN
          IF (section_item.definition.access_attributes - $llt$section_access_attributes
                [llc$binding, llc$read]) <> $llt$section_access_attributes [] THEN
            osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid binding section attributes',
                  status);
            issue_diagnostic (osc$error_status, status);
          IFEND;

          IF ((section_item.definition.allocation_alignment + section_item.definition.allocation_offset) MOD
                8) <> 0 THEN
            osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid binding section alignment',
                  status);
            issue_diagnostic (osc$error_status, status);
          IFEND;
        IFEND;


      PROCEND allocate_binding_section;
?? OLDTITLE ??
?? NEWTITLE := 'allocate_working_storage_sec', EJECT ??

      PROCEDURE allocate_working_storage_sec
        (VAR section_item: oct$section_table_item;
         VAR section_attributes: oct$section_attributes;
         VAR status: ost$status);


        IF llc$binding IN section_item.definition.access_attributes THEN
          section_attributes.read_attribute := section_attributes.read_default;
        IFEND;

        section_item.r1 := v$mdt^.r2;
        section_item.r2 := v$mdt^.r2;
        section_item.r3 := v$mdt^.r2;
        section_item.pva.ring := v$mdt^.r1;

        assign_section_to_a_segment (section_item, section_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF NOT section_item.output^.inhibit_binding_check THEN
          IF llc$binding IN section_item.definition.access_attributes THEN
            osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  'Binding attribute specified in non binding section', status);
            issue_diagnostic (osc$error_status, status);
          IFEND;
        IFEND;


      PROCEND allocate_working_storage_sec;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] is_this_a_retained_common_block', EJECT ??

      PROCEDURE [INLINE] is_this_a_retained_common_block
        (    section_item: oct$section_table_item;
         VAR this_is_a_retained_common_block: boolean);


        VAR
          retained_common_blocks: ^oct$program_name_list;


        IF (link_parameters.mode = occ$product) THEN
          IF (section_item.unallocated_common_block) OR (link_parameters.common_blocks_to_retain.name =
                occ$retain_all_common_blocks) OR (section_item.common_block_name = cyc$default_heap_name) THEN
            this_is_a_retained_common_block := TRUE;
            RETURN; { ---->
          IFEND;

          retained_common_blocks := link_parameters.common_blocks_to_retain.link;

          WHILE (retained_common_blocks <> NIL) DO
            IF (retained_common_blocks^.name = section_item.common_block_name) THEN
              this_is_a_retained_common_block := TRUE;
              RETURN; { ---->
            IFEND;

            retained_common_blocks := retained_common_blocks^.link;
          WHILEND;
        IFEND;

        this_is_a_retained_common_block := FALSE;


      PROCEND is_this_a_retained_common_block;
?? OLDTITLE ??
?? NEWTITLE := 'is_common_block_deferred', EJECT ??

{ PURPOSE:
{   The purpose of this request is to determine if a common block is to be deferred.
{ DESIGN:
{   If all common blocks are to be deferred the common block is to be deferred.
{   Otherwise the list of names specified will be searched.  If the list of names
{   represents those not to be deferred and the common block is not in it or if the
{   list of names represents those to be deferred and the common block is in it the
{   common block is to be deferred.
{ NOTE:
{   Unallocated common blocks are not deferred.

      PROCEDURE is_common_block_deferred
        (    section_item: oct$section_table_item;
         VAR deferred: boolean);

        VAR
          common_block: ^oct$defer_list,
          status: ost$status;


        deferred := FALSE;
        IF link_parameters.defer_common_blocks <> NIL THEN
          IF link_parameters.defer_common_blocks^.defer = occ$defer_all THEN
            IF NOT section_item.unallocated_common_block THEN
              deferred := TRUE;
            ELSE
              osp$set_status_abnormal (oc, oce$cannot_defer_unalloc_common, section_item.common_block_name,
                    status);
              issue_diagnostic (osc$warning_status, status);
            IFEND;

          ELSEIF link_parameters.defer_common_blocks^.defer = occ$defer THEN
            common_block := link_parameters.defer_common_blocks^.name_list;
            WHILE common_block <> NIL DO
              IF common_block^.name = section_item.common_block_name THEN
                common_block^.name_found := TRUE;
                IF NOT section_item.unallocated_common_block THEN
                  deferred := TRUE;
                ELSE
                  osp$set_status_abnormal (oc, oce$cannot_defer_unalloc_common,
                        section_item.common_block_name, status);
                  issue_diagnostic (osc$warning_status, status);
                IFEND;
                RETURN;
              IFEND;
              common_block := common_block^.link;
            WHILEND;

          ELSEIF link_parameters.defer_common_blocks^.defer = occ$defer_all_except THEN
            common_block := link_parameters.defer_common_blocks^.name_list;
            WHILE common_block <> NIL DO
              IF common_block^.name = section_item.common_block_name THEN
                common_block^.name_found := TRUE;
                RETURN;
              IFEND;
              common_block := common_block^.link;
            WHILEND;
            IF NOT section_item.unallocated_common_block THEN
              deferred := TRUE;
            ELSE
              osp$set_status_abnormal (oc, oce$cannot_defer_unalloc_common, section_item.common_block_name,
                    status);
              issue_diagnostic (osc$warning_status, status);
            IFEND;

          IFEND;
        IFEND;
      PROCEND is_common_block_deferred;
?? OLDTITLE ??
?? NEWTITLE := 'process_common_block', EJECT ??

      PROCEDURE process_common_block
        (VAR section_item: oct$section_table_item;
         VAR status: ost$status);


        VAR
          common_block: ^oct$common_block_item,
          section_attributes: oct$section_attributes;


        section_item.section_name := osc$null_name;
        section_item.common_block_name := section_item.definition.name;

        IF section_item.common_block_name = cyc$default_heap_name THEN
          IF link_parameters.heap_size_specified THEN
            section_item.definition.length := link_parameters.heap_size;
          ELSEIF section_item.definition.length > 1000(16) THEN
            section_item.definition.length := 1000(16);
          IFEND;
          IF section_item.definition.length < 4 THEN
            section_item.definition.length := 4;
          IFEND;
        IFEND;

        common_block := v$common_block_table.link;

        WHILE (common_block <> NIL) AND (common_block^.section_item^.common_block_name <>
              section_item.common_block_name) DO
          common_block := common_block^.link;
        WHILEND;

        IF common_block <> NIL THEN
          assign_common_block_to_section (common_block, section_item, status);

        ELSE
          is_this_a_retained_common_block (section_item, section_item.retained_common_block);
          is_common_block_deferred (section_item, section_item.deferred_common_block);
          obtain_section_attributes (section_item, section_attributes);

          IF section_item.definition.kind <> llc$extensible_common_block THEN
            find_section_name_to_allocate (section_item.definition.access_attributes, v$mdt^.default_sections,
                  section_item.section_name);
          IFEND;

          allocate_common_block (section_item, section_attributes, status);
        IFEND;


      PROCEND process_common_block;
?? OLDTITLE ??
?? NEWTITLE := 'process_non_common_block', EJECT ??

      PROCEDURE process_non_common_block
        (VAR section_item: oct$section_table_item;
         VAR status: ost$status);


        VAR
          section_attributes: oct$section_attributes;


        section_item.section_name := section_item.definition.name;
        section_item.common_block_name := osc$null_name;

        obtain_section_attributes (section_item, section_attributes);

        IF section_item.definition.kind = llc$code_section THEN
          section_item.section_name := osc$null_name;
        IFEND;

        IF (section_item.section_name = osc$null_name) AND (section_item.definition.kind <>
              llc$extensible_working_storage) THEN
          find_section_name_to_allocate (section_item.definition.access_attributes, v$mdt^.default_sections,
                section_item.section_name);
        IFEND;

        CASE section_item.definition.kind OF
        = llc$code_section =
          allocate_code_section (section_item, section_attributes, status);

        = llc$binding_section =
          allocate_binding_section (section_item, section_attributes, status);

        = llc$working_storage_section, llc$extensible_working_storage, llc$lts_reserved =
          allocate_working_storage_sec (section_item, section_attributes, status);

        ELSE
          osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid section kind encountered',
                status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        CASEND;


      PROCEND process_non_common_block;
?? OLDTITLE ??
?? EJECT ??

      CONST
        debug_section_1 = 'DBB$NEW_PROC_ENCOUNTERED',
        debug_section_2 = 'DBB$NEW_LINE_ENCOUNTERED';

      VAR
        section_definition: ^llt$section_definition,
        section_item: pmt$section_item,
        s: integer,

        valid_position: boolean,
        reset_value: ^SEQ ( * ),
        text: ^array [0 .. * ] of 0 .. 0ff(16);


      NEXT section_definition IN object_file^.segment.sequence_pointer;
      IF section_definition = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      s := section_definition^.section_ordinal;

      IF s > UPPERBOUND (v$mdt^.section_table) THEN
        osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid section ordinal encountered',
              status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      IF NOT v$mdt^.section_table [s].undefined THEN
        osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              'Duplicate section definition encountered', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      IF section_definition^.allocation_alignment = 0 THEN
        osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'Allocation alignment can not be ZERO',
              status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      v$mdt^.section_table [s].undefined := FALSE;
      v$mdt^.section_table [s].retained_common_block := FALSE;
      v$mdt^.section_table [s].deferred_common_block := FALSE;
      v$mdt^.section_table [s].unallocated_common_block := unallocated_common_block;
      v$mdt^.section_table [s].definition := section_definition^;
      v$mdt^.section_table [s].global_key := v$mdt^.global_key;
      v$mdt^.section_table [s].local_key := v$mdt^.local_key;

      IF (section_definition^.kind = llc$common_block) OR (section_definition^.kind =
            llc$extensible_common_block) THEN
        process_common_block (v$mdt^.section_table [s], status);
      ELSE
        process_non_common_block (v$mdt^.section_table [s], status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF pmc$block_map IN link_parameters.map_options THEN
        print_section_definition (section_definition^.name, v$mdt^.section_table [s]);
      IFEND;

      IF allotted_section <> 0 THEN
        IF section_definition^.length <> 0 THEN
          reset_value := object_file^.segment.sequence_pointer;

          pmp$position_object_library (object_file^.segment.sequence_pointer, allotted_section,
                valid_position);
          IF NOT valid_position THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;
          NEXT text: [0 .. (section_definition^.length - 1)] IN object_file^.segment.sequence_pointer;
          IF v$mdt^.section_table [s].text = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          v$mdt^.section_table [s].text^ := text^;
          object_file^.segment.sequence_pointer := reset_value;

          IF link_parameters.mode = occ$product THEN
            update_number_of_bytes_written ((#OFFSET (v$mdt^.section_table [s].text) +
                  section_definition^.length), v$mdt^.section_table [s].output^.number_of_bytes_written);
          IFEND;
        IFEND;
      IFEND;

      IF (link_parameters.mode = occ$template) THEN
        IF (section_definition^.name = debug_section_1) OR (section_definition^.name = debug_section_2) THEN
          osp$set_status_abnormal (oc, oce$w_module_compiled_opt_debug, v$mdt^.name, status);
          issue_diagnostic (osc$error_status, status);

        ELSEIF (section_definition^.name = cyc$default_heap_name) THEN
          osp$set_status_abnormal (oc, oce$w_default_heap_in_system, v$mdt^.name, status);
          issue_diagnostic (osc$error_status, status);
        IFEND;
      IFEND;

      IF v$generate_debug_tables THEN
        section_item.kind := section_definition^.kind;
        section_item.section_ordinal := section_definition^.section_ordinal;
        section_item.address := (v$mdt^.section_table [s].pva.seg *
              100000000(16)) + v$mdt^.section_table [s].pva.offset;
        section_item.length := section_definition^.length;
        convert_segment_access_control (v$mdt^.section_table [s].output^.used_attributes,
              section_item.segment_access_control);
        section_item.ring.r1 := v$mdt^.section_table [s].r1;
        section_item.ring.r2 := v$mdt^.section_table [s].r2;
        section_item.ring.r3 := v$mdt^.section_table [s].r3;
        convert_key_lock (v$mdt^.section_table [s].global_key, v$mdt^.section_table [s].local_key,
              section_item.key_lock);
        section_item.name := section_definition^.name;

        ocp$dtb_define_section (section_item, status);
        IF NOT status.normal THEN
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;
      IFEND;


    PROCEND process_section_definition;
?? OLDTITLE ??
?? NEWTITLE := 'process_text_record', EJECT ??

    PROCEDURE process_text_record
      (    object_file: ^oct$object_file_descriptor;
           number_of_bytes: 1 .. osc$max_segment_length;
       VAR status: ost$status);


      VAR
        text: ^llt$text;


      NEXT text: [1 .. number_of_bytes] IN object_file^.segment.sequence_pointer;
      IF text = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      validate_section (text^.section_ordinal, (text^.offset + number_of_bytes), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT v$mdt^.section_table [text^.section_ordinal].output^.inhibit_binding_check THEN
        IF llc$binding IN v$mdt^.section_table [text^.section_ordinal].definition.access_attributes THEN
          osp$set_status_abnormal (oc, oce$w_data_in_binding, v$mdt^.name, status);
          issue_diagnostic (osc$warning_status, status);
        IFEND;
      IFEND;

      IF (number_of_bytes <= (2 * v$page_size)) THEN
        i#move (#LOC (text^.byte [1]), #LOC (v$mdt^.section_table [text^.section_ordinal].
              text^ [text^.offset]), number_of_bytes);
      ELSE
        syp$advised_move_bytes (#LOC (text^.byte [1]), #LOC (v$mdt^.section_table [text^.section_ordinal].
              text^ [text^.offset]), number_of_bytes, status);
        IF NOT status.normal THEN
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;
      IFEND;

      IF link_parameters.mode = occ$product THEN
        update_number_of_bytes_written ((#OFFSET (#LOC (v$mdt^.section_table [text^.section_ordinal].
              text^ [text^.offset])) + number_of_bytes), v$mdt^.section_table [text^.section_ordinal].output^.
              number_of_bytes_written);
      IFEND;


    PROCEND process_text_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_replication_record', EJECT ??

    PROCEDURE process_replication_record
      (    object_file: ^oct$object_file_descriptor;
           number_of_bytes: 1 .. osc$max_segment_length;
       VAR status: ost$status);


      VAR
        replication: ^llt$replication,
        i: 1 .. osc$max_segment_length,
        offset: integer;


      NEXT replication: [1 .. number_of_bytes] IN object_file^.segment.sequence_pointer;
      IF replication = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      validate_section (replication^.section_ordinal, (replication^.offset +
            ((replication^.count - 1) * replication^.increment) + number_of_bytes), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT v$mdt^.section_table [replication^.section_ordinal].output^.inhibit_binding_check THEN
        IF llc$binding IN v$mdt^.section_table [replication^.section_ordinal].definition.
              access_attributes THEN
          osp$set_status_abnormal (oc, oce$w_data_in_binding, v$mdt^.name, status);
          issue_diagnostic (osc$warning_status, status);
        IFEND;
      IFEND;

      offset := replication^.offset;
      FOR i := 1 TO replication^.count DO
        i#move (#LOC (replication^.byte [1]), #LOC (v$mdt^.section_table [replication^.section_ordinal].
              text^ [offset]), number_of_bytes);
        offset := offset + replication^.increment;
      FOREND;

      IF link_parameters.mode = occ$product THEN
        offset := offset - replication^.increment;
        update_number_of_bytes_written ((#OFFSET (#LOC (v$mdt^.section_table [replication^.section_ordinal].
              text^ [offset])) + number_of_bytes), v$mdt^.section_table [replication^.section_ordinal].
              output^.number_of_bytes_written);
      IFEND;


    PROCEND process_replication_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_bit_insertion_record', EJECT ??

    PROCEDURE process_bit_insertion_record
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        bit_insertion: ^llt$bit_string_insertion,
        i: 1 .. osc$max_segment_length,
        bit_string: ^packed array [1 .. 70] of 0 .. 1;


      NEXT bit_insertion IN object_file^.segment.sequence_pointer;
      IF bit_insertion = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      validate_section (bit_insertion^.section_ordinal, (bit_insertion^.offset +
            ((bit_insertion^.bit_offset + bit_insertion^.bit_length + 7) DIV 8)), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT v$mdt^.section_table [bit_insertion^.section_ordinal].output^.inhibit_binding_check THEN
        IF llc$binding IN v$mdt^.section_table [bit_insertion^.section_ordinal].definition.
              access_attributes THEN
          osp$set_status_abnormal (oc, oce$w_data_in_binding, v$mdt^.name, status);
          issue_diagnostic (osc$warning_status, status);
        IFEND;
      IFEND;

      bit_string := #LOC (v$mdt^.section_table [bit_insertion^.section_ordinal].
            text^ [bit_insertion^.offset]);

      FOR i := 1 TO bit_insertion^.bit_length DO
        bit_string^ [i + bit_insertion^.bit_offset] := bit_insertion^.bit_string [i];
      FOREND;

      IF link_parameters.mode = occ$product THEN
        update_number_of_bytes_written ((#OFFSET (#LOC (v$mdt^.section_table [bit_insertion^.section_ordinal].
              text^ [bit_insertion^.offset])) + 8), v$mdt^.section_table [bit_insertion^.section_ordinal].
              output^.number_of_bytes_written);
      IFEND;


    PROCEND process_bit_insertion_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_address_formulation_rec', EJECT ??

    PROCEDURE process_address_formulation_rec
      (    object_file: ^oct$object_file_descriptor;
       VAR number_of_adr_items: 1 .. llc$max_adr_items;
       VAR status: ost$status);


      VAR
        address: ^oct$addresses,
        address_formulation: ^llt$address_formulation,
        d: integer,
        i: 0 .. llc$max_adr_items,
        entry_point: ^oct$entry_points,
        v: integer;


      NEXT address_formulation: [1 .. number_of_adr_items] IN object_file^.segment.sequence_pointer;
      IF address_formulation = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      d := address_formulation^.dest_section;
      validate_section (d, 0, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      v := address_formulation^.value_section;
      validate_section (v, 0, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (link_parameters.mode = occ$product) AND (v$mdt^.section_table [v].retained_common_block) AND
            (NOT v$mdt^.section_table [v].deferred_common_block) THEN
        add_adr_to_products_adr_list (address_formulation, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        RETURN; { ---->
      IFEND;

      FOR i := 1 TO number_of_adr_items DO
        IF address_formulation^.item [i].kind > UPPERVALUE (llt$internal_address_kind) THEN
          osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid address kind encountered',
                status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        obtain_destination_address (v$mdt, address_formulation^.item [i].
              kind, d, address_formulation^.item [i].dest_offset, address, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        CASE link_parameters.mode OF

        = occ$mc68000 =

          CASE address_formulation^.item [i].kind OF
          = llc$address =
            address^.mc68000_offset := v$mdt^.section_table [v].pva.offset +
                  address_formulation^.item [i].value_offset;

          = llc$short_address, llc$internal_proc =
            address^.mc68000_short_offset := v$mdt^.section_table [v].
                  pva.offset + address_formulation^.item [i].value_offset;

          = llc$external_proc =
            address^.mc68000_offset := v$mdt^.section_table [v].pva.offset +
                  address_formulation^.item [i].value_offset;
            address^.mc68000_binding_section := v$mdt^.binding_section.offset;


          CASEND;

        = occ$template =

          CASE address_formulation^.item [i].kind OF
          = llc$address =
            address^.pva.ring := v$mdt^.section_table [v].pva.ring;
            address^.pva.seg := v$mdt^.section_table [v].pva.seg;
            address^.pva.offset := v$mdt^.section_table [v].pva.offset +
                  address_formulation^.item [i].value_offset;

          = llc$short_address, llc$internal_proc =
            address^.cbp.vmid := v$vmid;
            address^.cbp.epf := (address_formulation^.item [i].kind = llc$short_address);
            address^.cbp.r3 := v$mdt^.section_table [v].r3;
            address^.cbp.rn := v$mdt^.section_table [v].r1;
            address^.cbp.seg := v$mdt^.section_table [v].pva.seg;
            address^.cbp.bn := v$mdt^.section_table [v].pva.offset +
                  address_formulation^.item [i].value_offset;

          = llc$external_proc =
            address^.cbp.vmid := v$vmid;
            address^.cbp.epf := TRUE;
            address^.cbp.r3 := v$mdt^.section_table [v].r3;
            address^.cbp.rn := v$mdt^.section_table [v].r1;
            address^.cbp.seg := v$mdt^.section_table [v].pva.seg;
            address^.cbp.bn := v$mdt^.section_table [v].pva.offset +
                  address_formulation^.item [i].value_offset;
            address^.binding_section := v$mdt^.binding_section;

          CASEND;

        = occ$product =

          CASE address_formulation^.item [i].kind OF
          = llc$address =
            address^.pva.ring := v$mdt^.section_table [v].pva.ring;
            address^.pva.seg := v$mdt^.section_table [v].pva.seg;
            address^.pva.offset := v$mdt^.section_table [v].pva.offset +
                  address_formulation^.item [i].value_offset;

            update_number_of_bytes_written ((#OFFSET (address) + 6), v$mdt^.section_table [d].
                  output^.number_of_bytes_written);

            add_to_segments_rel_list (address, v$mdt^.section_table [d].output^.relocation_list, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

          ELSE
            add_item_to_products_adr_list (v$mdt^.section_table [d].pva.seg, #OFFSET (address),
                  address_formulation^.item [i].kind, v$mdt^.section_table [v].
                  pva.seg, v$mdt^.section_table [v].pva.offset + address_formulation^.item [i].value_offset,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          CASEND;

        CASEND;
      FOREND;


    PROCEND process_address_formulation_rec;
?? OLDTITLE ??
?? NEWTITLE := 'process_entry_definition_record', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to initialize an entry point record, determine if
{   the entry point is a duplicate, and satisfy and free any matching externals in the
{   external list.

    PROCEDURE process_entry_definition_record
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);

      VAR
        module_referencing: ^oct$program_name_list,
        entry_definition: ^llt$entry_definition,
        entry_point: ^oct$entry_points,
        duplicate_entry_point: ^oct$entry_points,
        external: ^oct$ext_reference_list,
        external_before: ^oct$ext_reference_list,
        item: ^oct$external_items,
        address: ^oct$addresses,
        deferred_attribute: [STATIC] array [boolean] of string (8) := ['        ', 'DEFERRED'],
        gate_attributes: [STATIC] array [boolean] of string (5) := ['     ', 'GATED'];


      NEXT entry_definition IN object_file^.segment.sequence_pointer;
      IF entry_definition = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      validate_section (entry_definition^.section_ordinal, entry_definition^.offset, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      get_next_free_entry_point (entry_point, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      initialize_entry_point (entry_definition, entry_point);

      IF pmc$entry_point_map IN link_parameters.map_options THEN
        v$lm_entry_detail.entry_name := entry_point^.name;
        v$lm_entry_detail.entry_address.segment := entry_point^.pva.seg;
        v$lm_entry_detail.entry_address.offset := entry_point^.pva.offset;
        v$lm_entry_detail.entry_attribute := gate_attributes [entry_point^.gated];
        v$lm_entry_detail.deferred := deferred_attribute [entry_point^.deferred];

        ocp$generate_link_map_text (v$lm_entry_detail);
      IFEND;

      IF v$generate_debug_tables THEN
        ocp$dtb_define_entry_point (entry_point^.name, entry_point^.pva, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      search_entry_point_tree (entry_point^.name, entry_point^.r1, entry_point^.r3, duplicate_entry_point);

      IF duplicate_entry_point <> NIL THEN
        osp$set_status_abnormal (oc, oce$w_duplicate_entry_points, entry_point^.name, status);
        issue_diagnostic (osc$warning_status, status);
      IFEND;

      add_to_entry_points (entry_point);

{ Satisfy and free any matching externals in the external list

      external_before := ^v$unsatisfied_externals;

      WHILE external_before^.link <> NIL DO
        external := external_before^.link;

        IF (external^.name = entry_point^.name) AND (rings_overlap
              (external^.r1, external^.r2, entry_point^.r1, entry_point^.r3)) THEN
          IF external^.check_for_ring_violation THEN
            entry_point^.ring_violation := (external^.r1 < entry_point^.r1) OR
                  (external^.r2 > entry_point^.r3);
          IFEND;

          IF (external^.declaration_matching_required AND entry_point^.declaration_matching_required) THEN
            IF (external^.language = entry_point^.language) THEN
              IF (entry_point^.language = llc$cybil) THEN
                IF (link_parameters.cybil_parameter_checking = v$object_type_checking) THEN
                  IF (external^.declaration_matching.object_encryption <>
                        entry_point^.declaration_matching.object_encryption) THEN
                    WHILE external^.modules_referencing <> NIL DO
                      module_referencing := external^.modules_referencing;
                      external^.modules_referencing := external^.modules_referencing^.link;
                      osp$set_status_abnormal (oc, oce$f_ext_param_verification, entry_point^.name, status);
                      osp$append_status_parameter (osc$status_parameter_delimiter, module_referencing^.name,
                            status);
                      issue_diagnostic (osc$fatal_status, status);
                      module_referencing^.link := v$free_program_names;
                      v$free_program_names := module_referencing;
                    WHILEND;
                  IFEND;
                ELSE { source type checking
                  IF (external^.declaration_matching.source_encryption <>
                        entry_point^.declaration_matching.source_encryption) THEN
                    WHILE external^.modules_referencing <> NIL DO
                      module_referencing := external^.modules_referencing;
                      external^.modules_referencing := external^.modules_referencing^.link;
                      osp$set_status_abnormal (oc, oce$w_ext_param_verification, entry_point^.name, status);
                      osp$append_status_parameter (osc$status_parameter_delimiter, module_referencing^.name,
                            status);
                      issue_diagnostic (osc$warning_status, status);
                      module_referencing^.link := v$free_program_names;
                      v$free_program_names := module_referencing;
                    WHILEND;
                  IFEND;
                IFEND;
              ELSE { generator is not CYBIL
                IF (external^.declaration_matching.language_dependent_value <>
                      entry_point^.declaration_matching.language_dependent_value) THEN
                  WHILE external^.modules_referencing <> NIL DO
                    module_referencing := external^.modules_referencing;
                    external^.modules_referencing := external^.modules_referencing^.link;
                    osp$set_status_abnormal (oc, oce$w_ext_param_verification, entry_point^.name, status);
                    osp$append_status_parameter (osc$status_parameter_delimiter, module_referencing^.name,
                          status);
                    issue_diagnostic (osc$warning_status, status);
                    module_referencing^.link := v$free_program_names;
                    v$free_program_names := module_referencing;
                  WHILEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;

          WHILE external^.items.link <> NIL DO
            item := external^.items.link;
            address := item^.address;
            CASE link_parameters.mode OF
            = occ$template =
              CASE item^.kind OF
              = llc$address =
                address^.pva := entry_point^.pva;

              = llc$short_address, llc$internal_proc =
                address^.cbp.vmid := v$vmid;
                address^.cbp.epf := (item^.kind = llc$short_address);
                address^.cbp.r3 := entry_point^.r3;
                address^.cbp.rn := entry_point^.r1;
                address^.cbp.seg := entry_point^.pva.seg;
                address^.cbp.bn := entry_point^.pva.offset;

              = llc$external_proc =
                address^.cbp.vmid := v$vmid;
                address^.cbp.epf := TRUE;
                address^.cbp.r3 := entry_point^.r3;
                address^.cbp.rn := entry_point^.r1;
                address^.cbp.seg := entry_point^.pva.seg;
                address^.cbp.bn := entry_point^.pva.offset;
                address^.binding_section := entry_point^.binding_section;

              = llc$address_addition =
                address^.pva := entry_point^.pva;
                address^.pva.offset := entry_point^.pva.offset + item^.offset_operand;

              = llc$address_subtraction =
                address^.pva := entry_point^.pva;
                address^.pva.offset := entry_point^.pva.offset - item^.offset_operand;

              CASEND;

            = occ$product =
              CASE item^.kind OF
              = llc$address, llc$address_addition, llc$address_subtraction =
                address^.pva := entry_point^.pva;

                IF (item^.kind = llc$address_addition) THEN
                  address^.pva.offset := address^.pva.offset + item^.offset_operand;
                ELSEIF (item^.kind = llc$address_subtraction) THEN
                  address^.pva.offset := address^.pva.offset - item^.offset_operand;
                IFEND;

                update_number_of_bytes_written ((#OFFSET (address) + 6),
                      item^.output^.number_of_bytes_written);

                add_to_segments_rel_list (address, item^.output^.relocation_list, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

              ELSE
                add_item_to_products_adr_list (item^.output^.number, #OFFSET (address), item^.kind,
                      entry_point^.pva.seg, entry_point^.pva.offset, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              CASEND;

            = occ$mc68000 =
              CASE item^.kind OF
              = llc$address =
                address^.mc68000_offset := entry_point^.pva.offset;

              = llc$short_address, llc$internal_proc =
                address^.mc68000_short_offset := entry_point^.pva.offset;

              = llc$external_proc =
                address^.mc68000_offset := entry_point^.pva.offset;
                address^.mc68000_binding_section := entry_point^.binding_section.offset;

              = llc$address_addition =
                address^.mc68000_offset := entry_point^.pva.offset + item^.offset_operand;

              = llc$address_subtraction =
                address^.mc68000_offset := entry_point^.pva.offset - item^.offset_operand;

              CASEND;
            CASEND;

            external^.items.link := external^.items.link^.link;
            item^.link := v$free_external_items;
            v$free_external_items := item;
          WHILEND;

          external_before^.link := external_before^.link^.link;
          external^.link := v$free_external_references;
          v$free_external_references := external;

        ELSE
          external_before := external_before^.link;
        IFEND;

      WHILEND;


    PROCEND process_entry_definition_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_external_linkage_record', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to add the name of an external reference to the
{   list of known externals, satisfy it from the known entry points if possible, and,
{   if not, add the external to the list to be satisfied.

    PROCEDURE process_external_linkage_record
      (    object_file: ^oct$object_file_descriptor;
       VAR number_of_ext_items: 1 .. llc$max_ext_items;
       VAR status: ost$status);


      VAR
        declaration_matching_passes: boolean,
        external_linkage: ^llt$external_linkage,
        entry_point: ^oct$entry_points,
        external: ^oct$ext_reference_list,
        d: llt$section_ordinal,
        i: integer,
        address: ^oct$addresses;


      NEXT external_linkage: [1 .. number_of_ext_items] IN object_file^.segment.sequence_pointer;
      IF external_linkage = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      add_to_external_names (external_linkage^.name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      search_entry_point_tree (external_linkage^.name, v$mdt^.r1, v$mdt^.r2, entry_point);

      IF entry_point <> NIL THEN
        entry_point^.ring_violation := (v$mdt^.r1 < entry_point^.r1) OR (v$mdt^.r2 > entry_point^.r3);

        IF (entry_point^.declaration_matching_required AND external_linkage^.declaration_matching_required)
              THEN
          IF (entry_point^.language = external_linkage^.language) THEN
            IF (entry_point^.language = llc$cybil) THEN
              IF (link_parameters.cybil_parameter_checking = v$object_type_checking) THEN
                IF (entry_point^.declaration_matching.object_encryption <>
                      external_linkage^.declaration_matching.object_encryption) THEN
                  osp$set_status_abnormal (oc, oce$f_ext_param_verification, external_linkage^.name, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, v$mdt^.name, status);
                  issue_diagnostic (osc$fatal_status, status);
                IFEND;
              ELSE { source type checking
                IF (entry_point^.declaration_matching.source_encryption <>
                      external_linkage^.declaration_matching.source_encryption) THEN
                  osp$set_status_abnormal (oc, oce$w_ext_param_verification, external_linkage^.name, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, v$mdt^.name, status);
                  issue_diagnostic (osc$warning_status, status);
                IFEND;
              IFEND;
            ELSE { language is not CYBIL
              IF (entry_point^.declaration_matching.language_dependent_value <>
                    external_linkage^.declaration_matching.language_dependent_value) THEN
                osp$set_status_abnormal (oc, oce$w_ext_param_verification, external_linkage^.name, status);
                osp$append_status_parameter (osc$status_parameter_delimiter, v$mdt^.name, status);
                issue_diagnostic (osc$warning_status, status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        FOR i := 1 TO number_of_ext_items DO
          d := external_linkage^.item [i].section_ordinal;
          validate_section (d, 0, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF external_linkage^.item [i].kind > UPPERVALUE (llt$address_kind) THEN
            osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'Invalid address kind encountered',
                  status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          obtain_destination_address (v$mdt, external_linkage^.item [i].kind, d,
                external_linkage^.item [i].offset, address, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          CASE link_parameters.mode OF
          = occ$mc68000 =
            CASE external_linkage^.item [i].kind OF
            = llc$address =
              address^.mc68000_offset := entry_point^.pva.offset;

            = llc$short_address, llc$internal_proc =
              address^.mc68000_short_offset := entry_point^.pva.offset;

            = llc$external_proc =
              address^.mc68000_offset := entry_point^.pva.offset;
              address^.mc68000_binding_section := entry_point^.binding_section.offset;

            = llc$address_addition =
              address^.mc68000_offset := entry_point^.pva.offset + external_linkage^.item [i].offset_operand;

            = llc$address_subtraction =
              address^.mc68000_offset := entry_point^.pva.offset - external_linkage^.item [i].offset_operand;

            CASEND;

          = occ$template =
            CASE external_linkage^.item [i].kind OF
            = llc$address =
              address^.pva := entry_point^.pva;

            = llc$short_address, llc$internal_proc =
              address^.cbp.vmid := v$vmid;
              address^.cbp.epf := (external_linkage^.item [i].kind = llc$short_address);
              address^.cbp.r3 := entry_point^.r3;
              address^.cbp.rn := entry_point^.r1;
              address^.cbp.seg := entry_point^.pva.seg;
              address^.cbp.bn := entry_point^.pva.offset;

            = llc$external_proc =
              address^.cbp.vmid := v$vmid;
              address^.cbp.epf := TRUE;
              address^.cbp.r3 := entry_point^.r3;
              address^.cbp.rn := entry_point^.r1;
              address^.cbp.seg := entry_point^.pva.seg;
              address^.cbp.bn := entry_point^.pva.offset;
              address^.binding_section := entry_point^.binding_section;

            = llc$address_addition =
              address^.pva := entry_point^.pva;
              address^.pva.offset := entry_point^.pva.offset + external_linkage^.item [i].offset_operand;

            = llc$address_subtraction =
              address^.pva := entry_point^.pva;
              address^.pva.offset := entry_point^.pva.offset - external_linkage^.item [i].offset_operand;

            CASEND;

          = occ$product =
            CASE external_linkage^.item [i].kind OF
            = llc$address, llc$address_addition, llc$address_subtraction =
              address^.pva := entry_point^.pva;

              IF (external_linkage^.item [i].kind = llc$address_addition) THEN
                address^.pva.offset := address^.pva.offset + external_linkage^.item [i].offset_operand;
              ELSEIF (external_linkage^.item [i].kind = llc$address_subtraction) THEN
                address^.pva.offset := address^.pva.offset - external_linkage^.item [i].offset_operand;
              IFEND;

              update_number_of_bytes_written ((#OFFSET (address) + 6), v$mdt^.section_table [d].
                    output^.number_of_bytes_written);

              add_to_segments_rel_list (address, v$mdt^.section_table [d].output^.relocation_list, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

            ELSE
              add_item_to_products_adr_list (v$mdt^.section_table [d].pva.seg, #OFFSET (address),
                    external_linkage^.item [i].kind, entry_point^.pva.seg, entry_point^.pva.offset, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            CASEND;

          CASEND;

        FOREND;

      ELSE { Entry point not yet defined }
        external := ^v$unsatisfied_externals;

        WHILE external^.link <> NIL DO
          external := external^.link;

          declaration_matching_passes := FALSE;

        /check_declaration_matching/
          BEGIN
            IF external^.language = external_linkage^.language THEN
              IF NOT (external^.declaration_matching_required AND
                    external_linkage^.declaration_matching_required) THEN
                declaration_matching_passes := TRUE;
                EXIT /check_declaration_matching/;
              IFEND;
              IF external^.language = llc$cybil THEN
                IF link_parameters.cybil_parameter_checking = v$object_type_checking THEN
                  IF external^.declaration_matching.object_encryption =
                        external_linkage^.declaration_matching.object_encryption THEN
                    declaration_matching_passes := TRUE;
                  IFEND;
                ELSE { source type checking
                  IF external^.declaration_matching.source_encryption =
                        external_linkage^.declaration_matching.source_encryption THEN
                    declaration_matching_passes := TRUE;
                  IFEND;
                IFEND;
              ELSE { language is not CYBIL
                IF external^.declaration_matching.language_dependent_value =
                      external_linkage^.declaration_matching.language_dependent_value THEN
                  declaration_matching_passes := TRUE;
                IFEND;
              IFEND;
            IFEND;
          END /check_declaration_matching/;
          IF (external^.name = external_linkage^.name) AND ((external^.r1 = v$mdt^.r1) AND
                (external^.r2 = v$mdt^.r2)) AND (declaration_matching_passes) THEN
            add_to_external_items (external_linkage^.item, external, v$mdt^.name, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            RETURN; { Normal return when this external has been added to an existing external }
          IFEND;
        WHILEND;

        get_next_free_external (external^.link, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        external := external^.link;
        initialize_external_reference (external_linkage, external);

        add_to_external_items (external_linkage^.item, external, v$mdt^.name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Normal return when a new external has been added to the list

      IFEND;


    PROCEND process_external_linkage_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_relocation_record', EJECT ??

    PROCEDURE process_relocation_record
      (    object_file: ^oct$object_file_descriptor;
           number_of_rel_items: llt$number_of_info_elements;
       VAR status: ost$status);


      VAR
        relocation: ^llt$relocation;


      NEXT relocation: [1 .. number_of_rel_items] IN object_file^.segment.sequence_pointer;
      IF relocation = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ No further processing is required.

    PROCEND process_relocation_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_binding_template_record', EJECT ??

    PROCEDURE process_binding_template_record
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        binding_template: ^llt$binding_template;


      NEXT binding_template IN object_file^.segment.sequence_pointer;
      IF binding_template = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ No further processing is required.

    PROCEND process_binding_template_record;
?? OLDTITLE ??
?? NEWTITLE := 'proc_obsolete_formal_param_rec', EJECT ??

    PROCEDURE proc_obsolete_formal_param_rec
      (    object_file: ^oct$object_file_descriptor;
           sequence_length: ost$segment_length;
       VAR status: ost$status);


      VAR
        obsolete_formal_parameters: ^llt$obsolete_formal_parameters;


      NEXT obsolete_formal_parameters: [[REP sequence_length OF cell]] IN
            object_file^.segment.sequence_pointer;
      IF obsolete_formal_parameters = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ No further processing is required.

    PROCEND proc_obsolete_formal_param_rec;

?? OLDTITLE ??
?? NEWTITLE := 'get_next_free_formal_parameter', EJECT ??

    PROCEDURE get_next_free_formal_parameter
      (VAR formal_param_definition: ^oct$formal_param_definition;
       VAR status: ost$status);

      IF v$next_free_formal_parameter > occ$number_of_free_formal_param THEN
        NEXT v$free_formal_parameters: [1 .. occ$number_of_free_formal_param] IN ocv$vel_scratch_seq;
        IF v$free_formal_parameters = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL2', status);
          RETURN;
        IFEND;

        v$next_free_formal_parameter := 1;
      IFEND;

      formal_param_definition := ^v$free_formal_parameters^ [v$next_free_formal_parameter];
      v$next_free_formal_parameter := v$next_free_formal_parameter + 1;

    PROCEND get_next_free_formal_parameter;

?? OLDTITLE ??
?? NEWTITLE := 'initialize_formal_parameters', EJECT ??


    PROCEDURE initialize_formal_parameters
      (    formal_parameters: ^llt$formal_parameters;
       VAR formal_param_definition: ^oct$formal_param_definition);

      VAR
        entry_point: ^oct$entry_points;


      search_entry_point_tree (formal_parameters^.procedure_name, v$mdt^.r1, v$mdt^.r2, entry_point);
      IF entry_point = NIL THEN
        osp$set_status_abnormal (oc, oce$w_duplicate_entry_points, formal_parameters^.procedure_name, status);
        issue_diagnostic (osc$warning_status, status);
        RETURN;
      IFEND;

      formal_param_definition^.defining_module := v$mdt^.name;
      formal_param_definition^.r1 := v$mdt^.r1;
      formal_param_definition^.r2 := v$mdt^.r2;

      IF entry_point^.gated THEN
        formal_param_definition^.r3 := v$mdt^.r3
      ELSE
        formal_param_definition^.r3 := v$mdt^.r2;
      IFEND;

      IF formal_param_definition^.defining_module = 'SYP$SYSTEM_CORE_TRAP_HANDLER' THEN { JFS - Kludge}
        formal_param_definition^.r3 := 0d(16);
      IFEND;

      formal_param_definition^.global_key := v$mdt^.global_key;
      formal_param_definition^.local_key := v$mdt^.local_key;
      formal_param_definition^.l_link := NIL;
      formal_param_definition^.r_link := NIL;
      formal_param_definition^.definition := formal_parameters;

    PROCEND initialize_formal_parameters;
?? OLDTITLE ??
?? NEWTITLE := 'search_formal_param_tree', EJECT ??

    PROCEDURE search_formal_param_tree
      (    name: pmt$program_name;
           r1: ost$ring;
           r2: ost$ring;
       VAR formal_param_definition: ^oct$formal_param_definition);

      formal_param_definition := ^v$formal_param_definitions;

      WHILE formal_param_definition <> NIL DO
        IF (name = formal_param_definition^.defining_module) AND
              (rings_overlap (r1, r2, v$mdt^.r1, v$mdt^.r3)) THEN
          RETURN;

        ELSEIF name < formal_param_definition^.defining_module THEN
          formal_param_definition := formal_param_definition^.l_link;
        ELSE
          formal_param_definition := formal_param_definition^.r_link;
        IFEND;

      WHILEND;
    PROCEND search_formal_param_tree;

?? OLDTITLE ??
?? NEWTITLE := 'add_to_formal_param_tree', EJECT ??

    PROCEDURE add_to_formal_param_tree
      (    formal_param_definition: ^oct$formal_param_definition);

      VAR
        fpd: ^oct$formal_param_definition;


      fpd := ^v$formal_param_definitions;

      WHILE TRUE DO
        IF formal_param_definition^.defining_module < fpd^.defining_module THEN
          IF fpd^.l_link = NIL THEN
            fpd^.l_link := formal_param_definition;
            RETURN;
          ELSE
            fpd := fpd^.l_link;
          IFEND;
        ELSE
          IF fpd^.r_link = NIL THEN
            fpd^.r_link := formal_param_definition;
            RETURN;
          ELSE
            fpd := fpd^.r_link;
          IFEND;
        IFEND;
      WHILEND;

    PROCEND add_to_formal_param_tree;

?? OLDTITLE ??
?? NEWTITLE := 'process_formal_parameter_record', EJECT ??

    PROCEDURE process_formal_parameter_record
      (    object_file: ^oct$object_file_descriptor;
           sequence_length: ost$segment_length;
       VAR status: ost$status);


      VAR
        formal_parameters: ^llt$formal_parameters,
        formal_param_definition: ^oct$formal_param_definition,
        actual_param_before: ^oct$actual_param_group,
        actual: ^oct$actual_param_group,
        list_ptr: ^oct$actual_param_list_item;


      NEXT formal_parameters: [[REP sequence_length OF cell]] IN object_file^.segment.sequence_pointer;
      IF formal_parameters = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      get_next_free_formal_parameter (formal_param_definition, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      initialize_formal_parameters (formal_parameters, formal_param_definition);

      add_to_formal_param_tree (formal_param_definition);

{ Satisfy and free any matching externals in the external list

      actual_param_before := ^v$unsatisfied_actual_param;

      WHILE actual_param_before^.link <> NIL DO
        actual := actual_param_before^.link;

        IF (actual^.name = formal_param_definition^.defining_module) AND
              (rings_overlap (actual^.r1, actual^.r2, formal_param_definition^.r1,
              formal_param_definition^.r3)) THEN
          list_ptr := actual^.list;
          WHILE list_ptr <> NIL DO
            fortran_argument_checking (list_ptr^.definition, formal_param_definition);
            list_ptr := list_ptr^.nnext;
          WHILEND;
          actual_param_before^.link := actual^.link;
        ELSE
          actual_param_before := actual;
        IFEND;

      WHILEND;
    PROCEND process_formal_parameter_record;

?? OLDTITLE ??
?? NEWTITLE := 'get_next_free_actual_parameter', EJECT ??

    PROCEDURE get_next_free_actual_parameter
      (VAR actual_param_group: ^oct$actual_param_group;
       VAR status: ost$status);

      IF v$next_free_actual_parameter > occ$number_of_free_actual_param THEN
        NEXT v$free_actual_parameters: [1 .. occ$number_of_free_actual_param] IN ocv$vel_scratch_seq;
        IF v$free_actual_parameters = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL2', status);
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;

        v$next_free_actual_parameter := 1;
      IFEND;
      actual_param_group := ^v$free_actual_parameters^ [v$next_free_actual_parameter];
      v$next_free_actual_parameter := v$next_free_actual_parameter + 1;

    PROCEND get_next_free_actual_parameter;

?? OLDTITLE ??
?? NEWTITLE := 'initialize_actual_parameters', EJECT ??

    PROCEDURE initialize_actual_parameters
      (    actual_parameters: ^llt$actual_parameters;
       VAR actual_param_group: ^oct$actual_param_group);

      VAR
        entry_point: ^oct$entry_points;

      actual_param_group^.name := actual_parameters^.callee_name;
      actual_param_group^.r1 := v$mdt^.r1;
      actual_param_group^.r2 := v$mdt^.r2;

      actual_param_group^.global_key := v$mdt^.global_key;
      actual_param_group^.local_key := v$mdt^.local_key;
      actual_param_group^.link := NIL;
      actual_param_group^.list := NIL;

    PROCEND initialize_actual_parameters;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_actual_param_tree', EJECT ??

    PROCEDURE add_to_actual_param_tree
      (    actual_param_group: ^oct$actual_param_group);

      VAR
        apd: ^oct$actual_param_group;

      apd := ^v$actual_param_groups;

      WHILE TRUE DO
        IF actual_param_group^.name < apd^.name THEN
          IF apd^.link = NIL THEN
            apd^.link := actual_param_group;
            RETURN;
          ELSE
            apd := apd^.link;
          IFEND;
        IFEND;
      WHILEND;

    PROCEND add_to_actual_param_tree;
?? OLDTITLE ??
?? NEWTITLE := 'add_to_actual_list', EJECT ??

    PROCEDURE add_to_actual_list
      (    actual_parameters: ^llt$actual_parameters;
       VAR linkage: ^oct$actual_param_list_item;
       VAR status: ost$status);

      VAR
        new_reference: ^oct$actual_param_list_item,
        abort_status: ^ost$status;


      NEXT new_reference IN ocv$vel_scratch_seq;
      IF new_reference = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      new_reference^.definition := actual_parameters;
      new_reference^.nnext := linkage;
      linkage := new_reference;
    PROCEND add_to_actual_list;

?? OLDTITLE ??
?? NEWTITLE := 'process_actual_parameter_record', EJECT ??

    PROCEDURE process_actual_parameter_record
      (    object_file: ^oct$object_file_descriptor;
           sequence_length: ost$segment_length;
       VAR status: ost$status);


      VAR
        actual_parameters: ^llt$actual_parameters,
        duplicate_entry_point: ^oct$entry_points,
        actual_param_group: ^oct$actual_param_group,
        actual_param_group_before: ^oct$actual_param_group,
        linkage: ^oct$param_matching_node,
        formal_param_definition: ^oct$formal_param_definition,
        actual: ^oct$actual_param_group,
        actual_list: ^oct$actual_param_list_item;


      NEXT actual_parameters: [[REP sequence_length OF cell]] IN object_file^.segment.sequence_pointer;
      IF actual_parameters = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      search_formal_param_tree (actual_parameters^.callee_name, v$mdt^.r1, v$mdt^.r2,
            formal_param_definition);
      IF formal_param_definition <> NIL THEN
        fortran_argument_checking (actual_parameters, formal_param_definition);
      IFEND;

      actual_param_group_before := ^v$unsatisfied_actual_param;

      WHILE actual_param_group_before^.link <> NIL DO
        actual_param_group := actual_param_group_before^.link;

        IF (actual_param_group^.name = actual_parameters^.callee_name) AND
              (actual_param_group^.r1 = v$mdt^.r1) AND (actual_param_group^.r2 = v$mdt^.r2) THEN
          add_to_actual_list (actual_parameters, actual_param_group^.list, status);
          RETURN;
        IFEND;
        actual_param_group_before := actual_param_group;
      WHILEND;

      get_next_free_actual_parameter (actual_param_group, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      initialize_actual_parameters (actual_parameters, actual_param_group);

      add_to_actual_list (actual_parameters, actual_param_group^.list, status);

      actual_param_group_before^.link := actual_param_group;

    PROCEND process_actual_parameter_record;
?? OLDTITLE ??
?? NEWTITLE := 'fortran_argument_checking', EJECT ??

    PROCEDURE fortran_argument_checking
      (VAR actual_parameters: ^llt$actual_parameters;
           formal_parameters: ^oct$formal_param_definition);

      TYPE
        formal_type_array = array [llt$fortran_argument_type] of boolean,
        actual_type_array = array [llt$fortran_argument_type] of formal_type_array,
        formal_kind_array = array [llt$fortran_argument_kind] of boolean,
        actual_kind_array = array [llc$fortran_variable .. llc$fortran_array_element] of formal_kind_array,
        formal_usage_array = array [llt$argument_usage] of boolean,
        actual_usage_array = array [llt$argument_usage] of formal_usage_array;

?? FMT (FORMAT := OFF) ??


      VAR
        fortran_argument_type_checking: [STATIC, READ] actual_type_array := [
                    {  L      I      R      DR    COMP   CHAR    B      NT     SL     HR     BIT  }
        {    L   }  [ TRUE,  FALSE, FALSE, FALSE, FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    I   }  [ FALSE, TRUE,  FALSE, FALSE, FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    R   }  [ FALSE, FALSE, TRUE,  FALSE, FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    DR  }  [ FALSE, FALSE, FALSE, TRUE,  FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {   COMP }  [ FALSE, FALSE, FALSE, FALSE, TRUE,  FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {   CHAR }  [ FALSE, FALSE, FALSE, FALSE, FALSE, TRUE,  TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    B   }  [ TRUE,  TRUE,  TRUE,  FALSE, FALSE, FALSE, TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    NT  }  [ TRUE,  TRUE,  TRUE,  TRUE,  TRUE,  TRUE,  TRUE,  TRUE,  FALSE, FALSE, FALSE ],
        {    SL  }  [ FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE,  FALSE, FALSE ],
        {    HR  }  [ FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE,  FALSE ],
        {   BIT  }  [ FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE ]];


      VAR
        fortran_argument_kind_checking: [STATIC, READ] actual_kind_array := [
                  {  V      A      X      AE     U    }
        {  V  }   [ TRUE,  FALSE, FALSE, FALSE, TRUE  ],
        {  A  }   [ FALSE, TRUE,  FALSE, FALSE, FALSE ],
        {  X  }   [ FALSE, FALSE, TRUE,  FALSE, TRUE  ],
        {  AE }   [ TRUE,  TRUE,  FALSE, FALSE, TRUE ]];


      VAR
        fortran_argument_usage_checking: [STATIC, READ] actual_usage_array := [

                  {  W      NW  }
        {  W   }  [ TRUE,  TRUE ],
        {  NW  }  [ FALSE, TRUE ]];

  ?? FMT (FORMAT := ON) ??

      VAR
        actual_seq: ^SEQ ( * ),
        formal_seq: ^SEQ ( * ),
        actual_parameter_descriptor: ^llt$fortran_argument_desc,
        formal_parameter_descriptor: ^llt$fortran_argument_desc,
        parameter_number: 0 .. llc$max_fortran_arguments,
        type_valid: boolean,
        kind_valid: boolean,
        usage_valid: boolean,
        valid: boolean,
        actual_length: integer,
        formal_length: integer;


      actual_seq := ^actual_parameters^.specification;
      formal_seq := ^formal_parameters^.definition^.specification;
      RESET actual_seq;
      RESET formal_seq;

      parameter_number := 0;
      NEXT actual_parameter_descriptor IN actual_seq;
      NEXT formal_parameter_descriptor IN formal_seq;

      WHILE (actual_parameter_descriptor <> NIL) AND (formal_parameter_descriptor <> NIL) DO
        type_valid := fortran_argument_type_checking [actual_parameter_descriptor^.argument_type]
              [formal_parameter_descriptor^.argument_type];

        IF NOT type_valid THEN
          osp$set_status_abnormal (oc, oce$invalid_type_matching, v$mdt^.name, status);
          issue_diagnostic (osc$warning_status, status);
        ELSE
          kind_valid := fortran_argument_kind_checking [actual_parameter_descriptor^.argument_kind]
                [formal_parameter_descriptor^.argument_kind];
          IF NOT kind_valid THEN
            osp$set_status_abnormal (oc, oce$invalid_kind_matching, v$mdt^.name, status);
            issue_diagnostic (osc$warning_status, status);
          ELSE
            usage_valid := fortran_argument_usage_checking [actual_parameter_descriptor^.mode]
                  [formal_parameter_descriptor^.mode];
            IF NOT usage_valid THEN
              osp$set_status_abnormal (oc, oce$invalid_mode_matching, v$mdt^.name, status);
              issue_diagnostic (osc$warning_status, status);
            IFEND;
          IFEND;
        IFEND;

        IF (actual_parameter_descriptor^.argument_type = llc$fortran_char) AND
              (formal_parameter_descriptor^.argument_type = llc$fortran_boolean) THEN
          valid := actual_parameter_descriptor^.string_length.number_of_characters >= 8;
          IF NOT valid THEN
            osp$set_status_abnormal (oc, oce$bad_char_length, actual_parameters^.callee_name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, parameter_number, 10, FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  actual_parameter_descriptor^.string_length.number_of_characters, 10, FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  formal_parameter_descriptor^.string_length.number_of_characters, 10, FALSE, status);
            issue_diagnostic (osc$warning_status, status);
          IFEND;
        IFEND;

        IF (actual_parameter_descriptor^.argument_type = llc$fortran_char) AND
              (formal_parameter_descriptor^.argument_type = llc$fortran_char) AND
              (NOT (llc$fortran_assumed_len_string IN actual_parameter_descriptor^.string_length.attributes))
              THEN
          valid := actual_parameter_descriptor^.string_length.number_of_characters >=
                formal_parameter_descriptor^.string_length.number_of_characters;
          IF NOT valid THEN
            osp$set_status_abnormal (oc, oce$bad_char_length, actual_parameters^.callee_name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, parameter_number, 10, FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  actual_parameter_descriptor^.string_length.number_of_characters, 10, FALSE, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  formal_parameter_descriptor^.string_length.number_of_characters, 10, FALSE, status);
            issue_diagnostic (osc$warning_status, status);
          IFEND;
        IFEND;

        IF ((actual_parameter_descriptor^.argument_type = llc$fortran_char) AND
              (formal_parameter_descriptor^.argument_type = llc$fortran_char)) THEN
          IF (((actual_parameter_descriptor^.argument_kind = llc$fortran_array) AND
                (NOT (llc$fortran_adaptable_array IN actual_parameter_descriptor^.array_size.attributes) AND
                NOT (llc$fortran_assumed_len_array IN actual_parameter_descriptor^.array_size.attributes)) OR
                (actual_parameter_descriptor^.argument_kind = llc$fortran_array_element) AND
                (NOT (llc$fortran_assumed_len_string IN actual_parameter_descriptor^.string_length.
                attributes))) AND (formal_parameter_descriptor^.argument_kind = llc$fortran_array) AND
                (NOT (llc$fortran_adaptable_array IN formal_parameter_descriptor^.array_size.attributes) AND
                NOT (llc$fortran_assumed_len_array IN formal_parameter_descriptor^.array_size.attributes)))
                THEN
            IF actual_parameter_descriptor^.argument_kind = llc$fortran_array THEN
              actual_length := actual_parameter_descriptor^.array_size.number_of_elements *
                    actual_parameter_descriptor^.string_length.number_of_characters;
            ELSE
              actual_length := actual_parameter_descriptor^.string_length.number_of_characters;
            IFEND;

            IF formal_parameter_descriptor^.argument_kind = llc$fortran_array THEN
              formal_length := formal_parameter_descriptor^.array_size.number_of_elements *
                    formal_parameter_descriptor^.string_length.number_of_characters;
            ELSE
              formal_length := formal_parameter_descriptor^.string_length.number_of_characters;
            IFEND;
            valid := actual_length >= formal_length;
            IF NOT valid THEN
              osp$set_status_abnormal (oc, oce$actual_less_than_formal, actual_parameters^.callee_name,
                    status);
              osp$append_status_integer (osc$status_parameter_delimiter, parameter_number, 10, FALSE, status);
              osp$append_status_integer (osc$status_parameter_delimiter, actual_length, 10, FALSE, status);
              osp$append_status_integer (osc$status_parameter_delimiter, formal_length, 10, FALSE, status);
              issue_diagnostic (osc$warning_status, status);
            IFEND;
          IFEND;
        IFEND;

        IF (actual_parameter_descriptor^.argument_type = llc$fortran_integer) AND
              (formal_parameter_descriptor^.argument_type = llc$fortran_integer) THEN

{ The purpose of the following code is to maintain compatibility with binary files
{ compiled before INTEGER*N code is available in FORTRAN.

          IF actual_parameter_descriptor^.string_length.number_of_characters = 0 THEN
            actual_length := 8;
          ELSE
            actual_length := actual_parameter_descriptor^.string_length.number_of_characters;
          IFEND;
          IF formal_parameter_descriptor^.string_length.number_of_characters = 0 THEN
            formal_length := 8;
          ELSE
            formal_length := formal_parameter_descriptor^.string_length.number_of_characters;
          IFEND;

{ End of code to maintain compatibility

          valid := actual_length = formal_length;
          IF NOT valid THEN
            osp$set_status_abnormal (oc, oce$bad_integer_length, v$mdt^.name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, formal_parameters^.defining_module,
                  status);
            osp$append_status_integer (osc$status_parameter_delimiter, parameter_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, actual_parameters^.callee_name,
                  status);
            issue_diagnostic (osc$warning_status, status);
          IFEND;
        IFEND;

        IF formal_parameter_descriptor^.argument_kind = llc$fortran_array THEN
          IF llc$fortran_assumed_shape_array IN formal_parameter_descriptor^.array_size.attributes THEN
            IF ((actual_parameter_descriptor^.argument_kind <> llc$fortran_array) OR
                  (llc$fortran_assumed_len_array IN actual_parameter_descriptor^.array_size.attributes) OR
                  (formal_parameter_descriptor^.array_size.rank <>
                  actual_parameter_descriptor^.array_size.rank)) THEN
              osp$set_status_abnormal (oc, oce$fortran_array_type_mismatch, v$mdt^.name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, actual_parameters^.callee_name,
                    status);
              osp$append_status_integer (osc$status_parameter_delimiter, parameter_number, 10, FALSE, status);
              issue_diagnostic (osc$warning_status, status);
            IFEND;
          ELSE
            IF (actual_parameter_descriptor^.argument_kind = llc$fortran_array) AND
                  ((llc$fortran_assumed_shape_array IN actual_parameter_descriptor^.array_size.attributes) OR
                  (llc$fortran_array_section IN actual_parameter_descriptor^.array_size.attributes)) THEN
              osp$set_status_abnormal (oc, oce$fortran_array_type_mismatch, v$mdt^.name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, actual_parameters^.callee_name,
                    status);
              osp$append_status_integer (osc$status_parameter_delimiter, parameter_number, 10, FALSE, status);
              issue_diagnostic (osc$warning_status, status);
            IFEND;
          IFEND;
        IFEND;

        NEXT actual_parameter_descriptor IN actual_seq;
        NEXT formal_parameter_descriptor IN formal_seq;
        parameter_number := parameter_number + 1;
      WHILEND;
      IF (actual_parameter_descriptor = NIL) AND (formal_parameter_descriptor <> NIL) THEN
        osp$set_status_abnormal (oc, oce$invalid_mode_matching, 'INVALID_PARAMETERS', status);
        issue_diagnostic (osc$warning_status, status);
      IFEND;
    PROCEND fortran_argument_checking;
?? OLDTITLE ??
?? NEWTITLE := 'process_cybil_symbol_table', EJECT ??

    PROCEDURE process_cybil_symbol_table
      (    object_file: ^oct$object_file_descriptor;
           sequence_length: ost$segment_length;
       VAR status: ost$status);


      VAR
        debug_table_fragment: ^llt$debug_table_fragment;


      NEXT debug_table_fragment: [[REP sequence_length OF cell]] IN object_file^.segment.sequence_pointer;
      IF debug_table_fragment = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ No further processing is required.

    PROCEND process_cybil_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := 'process_obsolete_line_table', EJECT ??

    PROCEDURE process_obsolete_line_table
      (    object_file: ^oct$object_file_descriptor;
           number_of_line_items: 1 .. llc$max_line_adr_table_size;
       VAR status: ost$status);


      VAR
        obsolete_line_address_table: ^llt$obsolete_line_address_table;


      NEXT obsolete_line_address_table: [1 .. number_of_line_items] IN object_file^.segment.sequence_pointer;
      IF obsolete_line_address_table = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ no further processing is required

    PROCEND process_obsolete_line_table;
?? OLDTITLE ??
?? NEWTITLE := 'process_symbol_table_record', EJECT ??

    PROCEDURE process_symbol_table_record
      (    object_file: ^oct$object_file_descriptor;
           sequence_length: ost$segment_length;
       VAR status: ost$status);


      VAR
        symbol_table: ^llt$symbol_table;


      NEXT symbol_table: [[REP sequence_length OF cell]] IN object_file^.segment.sequence_pointer;
      IF symbol_table = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ No further processing is required.

    PROCEND process_symbol_table_record;

?? OLDTITLE ??
?? NEWTITLE := 'process_supplemental_dtables', EJECT ??

    PROCEDURE process_supplemental_dtables
      (    object_file: ^oct$object_file_descriptor;
           sequence_length: ost$segment_length;
       VAR status: ost$status);


      VAR
        supplemental_debug_tables: ^llt$supplemental_debug_tables;


      NEXT supplemental_debug_tables: [[REP sequence_length OF cell]] IN
            object_file^.segment.sequence_pointer;
      IF supplemental_debug_tables = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ No further processing is required.

    PROCEND process_supplemental_dtables;

?? OLDTITLE ??
?? NEWTITLE := 'process_form_def_record', EJECT ??

    PROCEDURE process_form_def_record
      (VAR status: ost$status);

      VAR
        module_name: pmt$program_name;

      osp$set_status_abnormal (oc, oce$e_form_def_found_in_module, v$mdt^.name, status);
      issue_diagnostic (osc$fatal_status, status);
      RETURN;
    PROCEND process_form_def_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_line_table_record', EJECT ??

    PROCEDURE process_line_table_record
      (    object_file: ^oct$object_file_descriptor;
           number_of_line_items: 1 .. llc$max_line_adr_table_size;
       VAR status: ost$status);


      VAR
        line_address_table: ^llt$line_address_table;


      NEXT line_address_table: [1 .. number_of_line_items] IN object_file^.segment.sequence_pointer;
      IF line_address_table = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ no further processing is required

    PROCEND process_line_table_record;
?? OLDTITLE ??
?? NEWTITLE := 'process_68000_absolute', EJECT ??

    PROCEDURE process_68000_absolute
      (    object_file: ^oct$object_file_descriptor;
           number_of_68000_bytes: 1 .. llc$maximum_68000_address;
       VAR status: ost$status);


      VAR
        m68000_absolute: ^llt$68000_absolute;


      NEXT m68000_absolute: [[REP number_of_68000_bytes OF cell]] IN object_file^.segment.sequence_pointer;
      IF m68000_absolute = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

{ no further process is required

    PROCEND process_68000_absolute;
?? OLDTITLE ??
?? NEWTITLE := 'process_transfer_symbol_record', EJECT ??

    PROCEDURE process_transfer_symbol_record
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        transfer_symbol: ^llt$transfer_symbol,
        i: integer;


      NEXT transfer_symbol IN object_file^.segment.sequence_pointer;
      IF transfer_symbol = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      IF transfer_symbol^.name <> osc$null_name THEN
        v$last_starting_procedure := transfer_symbol^.name;
      IFEND;

      IF v$generate_debug_tables THEN
        ocp$dtb_terminate_module (status);
        IF NOT status.normal THEN
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;
      IFEND;

{ Store module's binding section offset with each code segment

      IF (link_parameters.mode = occ$product) AND (v$mdt^.binding_section_encountered) THEN
        FOR i := 0 TO UPPERBOUND (v$mdt^.section_table) DO
          IF (v$mdt^.section_table [i].definition.kind = llc$code_section) THEN
            v$mdt^.section_table [i].output^.binding_section_encountered := TRUE;
            v$mdt^.section_table [i].output^.binding_section_segment := v$mdt^.binding_section.seg;
            v$mdt^.section_table [i].output^.binding_section_offset := v$mdt^.binding_section.offset;
          IFEND;
        FOREND;
      IFEND;


    PROCEND process_transfer_symbol_record;
?? OLDTITLE ??
?? NEWTITLE := 'include_object_module', EJECT ??

    PROCEDURE include_object_module
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        module_kind: llt$module_kind;


      v$record_number := 1;

      process_identification_record (object_file, module_kind, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF module_kind = llc$iou THEN
        v$record_number := v$record_number + 1;

        process_ppu_absolute_record (object_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSE
        CASE link_parameters.mode OF
        = occ$template, occ$product =
          IF (module_kind = llc$vector_virtual_state) OR (module_kind = llc$vector_extended_state) THEN
            v$module_kind := module_kind;
          IFEND;
        = occ$mc68000 =
          ;
        CASEND;

        REPEAT
          v$record_number := v$record_number + 1;

          NEXT object_text_descriptor IN object_file^.segment.sequence_pointer;
          IF object_text_descriptor = NIL THEN
            osp$set_status_abnormal (oc, oce$e_premature_eof_in_module, v$mdt^.name, status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          CASE object_text_descriptor^.kind OF
          = llc$identification =
            osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  'Duplicate identification record encountered', status);
            issue_diagnostic (osc$fatal_status, status);
          = llc$ppu_absolute =
            osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  'PPU absolute recored encountered in CPU object module', status);
            issue_diagnostic (osc$fatal_status, status);
          = llc$application_identifier =
            process_application_id_record (object_file, status);
          = llc$libraries =
            process_libraries_record (object_file, object_text_descriptor^.number_of_libraries, status);
          = llc$section_definition =
            process_section_definition (object_file, FALSE, 0, status);
          = llc$unallocated_common_block =
            IF (link_parameters.mode = occ$product) THEN
              process_section_definition (object_file, TRUE, 0, status);
            ELSE
              osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
              osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    'Unallocated common block in non-product link', status);
              issue_diagnostic (osc$fatal_status, status);
            IFEND;
          = llc$allotted_section_definition =
            process_section_definition (object_file, FALSE, object_text_descriptor^.allotted_section, status);
          = llc$text =
            process_text_record (object_file, object_text_descriptor^.number_of_bytes, status);
          = llc$replication =
            process_replication_record (object_file, object_text_descriptor^.number_of_bytes, status);
          = llc$bit_string_insertion =
            process_bit_insertion_record (object_file, status);
          = llc$address_formulation =
            process_address_formulation_rec (object_file, object_text_descriptor^.number_of_adr_items,
                  status);
          = llc$entry_definition =
            process_entry_definition_record (object_file, status);
          = llc$external_linkage =
            process_external_linkage_record (object_file, object_text_descriptor^.number_of_ext_items,
                  status);
          = llc$relocation =
            process_relocation_record (object_file, object_text_descriptor^.number_of_rel_items, status);
          = llc$binding_template =
            process_binding_template_record (object_file, status);
          = llc$obsolete_formal_parameters =
            proc_obsolete_formal_param_rec (object_file, object_text_descriptor^.sequence_length, status);
          = llc$formal_parameters =
            process_formal_parameter_record (object_file, object_text_descriptor^.sequence_length, status);
          = llc$actual_parameters =
            process_actual_parameter_record (object_file, object_text_descriptor^.sequence_length, status);
          = llc$cybil_symbol_table_fragment =
            process_cybil_symbol_table (object_file, object_text_descriptor^.sequence_length, status);
          = llc$obsolete_line_table =
            process_obsolete_line_table (object_file, object_text_descriptor^.number_of_line_items, status);
          = llc$symbol_table =
            process_symbol_table_record (object_file, object_text_descriptor^.sequence_length, status);
          = llc$line_table =
            process_line_table_record (object_file, object_text_descriptor^.number_of_line_items, status);
          = llc$supplemental_debug_tables =
            process_supplemental_dtables (object_file, object_text_descriptor^.sequence_length, status);
          = llc$form_definition =
            process_form_def_record (status);
          = llc$68000_absolute =
            process_68000_absolute (object_file, object_text_descriptor^.number_of_68000_bytes, status);
          = llc$transfer_symbol =
            process_transfer_symbol_record (object_file, status);
          ELSE
            osp$set_status_abnormal (oc, oce$e_bad_obj_text_in_module, v$mdt^.name, status);
            osp$append_status_integer (osc$status_parameter_delimiter, v$record_number, 10, FALSE, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'Unknown object record kind',
                  status);
            issue_diagnostic (osc$fatal_status, status);
          CASEND;

          IF NOT status.normal THEN
            RETURN;
          IFEND;

        UNTIL object_text_descriptor^.kind = llc$transfer_symbol;

      IFEND;
      IF pmc$entry_point_map IN link_parameters.map_options THEN
        print_external_names (v$mdt^.external_names);
      IFEND;


    PROCEND include_object_module;
?? OLDTITLE ??
?? NEWTITLE := 'include_load_module', EJECT ??

    PROCEDURE include_load_module
      (    object_library: ^oct$object_file_descriptor;
           module_header: REL (llt$object_library) ^llt$load_module_header;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        load_module_header: ^llt$load_module_header,
        info_element_header: ^llt$info_element_header;


      load_module_header := #PTR (module_header, object_library^.segment.sequence_pointer^);
      IF load_module_header = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, object_library^.name^, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      object_text_descriptor := #PTR (load_module_header^.interpretive_element,
            object_library^.segment.sequence_pointer^);
      IF object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$e_premature_eof_on_file, object_library^.name^, status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      RESET object_library^.segment.sequence_pointer TO object_text_descriptor;

      include_object_module (object_library, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF v$generate_debug_tables THEN
        IF llc$information_element IN load_module_header^.elements_defined THEN
          info_element_header := #PTR (load_module_header^.information_element,
                object_library^.segment.sequence_pointer^);

          IF ((info_element_header <> NIL) AND (info_element_header^.version = llc$info_element_version) AND
                (info_element_header^.number_of_section_maps <> 0)) THEN
            ocp$dtb_redefine_module (info_element_header, object_library^.segment.sequence_pointer, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      IFEND;


    PROCEND include_load_module;
?? OLDTITLE ??
?? NEWTITLE := 'include_object_file', EJECT ??

    PROCEDURE include_object_file
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor;


      RESET object_file^.segment.sequence_pointer;

      NEXT object_text_descriptor IN object_file^.segment.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_abnormal (oc, oce$w_no_modules_on_file, object_file^.name^, status);
        issue_diagnostic (osc$warning_status, status);
        RETURN;
      IFEND;

      REPEAT
        RESET object_file^.segment.sequence_pointer TO object_text_descriptor;

        include_object_module (object_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        NEXT object_text_descriptor IN object_file^.segment.sequence_pointer;

      UNTIL object_text_descriptor = NIL;


    PROCEND include_object_file;
?? OLDTITLE ??
?? NEWTITLE := 'include_object_library', EJECT ??

    PROCEDURE include_object_library
      (    object_file: ^oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        i: 0 .. llc$max_modules_in_library;


      IF object_file^.module_dictionary <> NIL THEN
        FOR i := 1 TO UPPERBOUND (object_file^.module_dictionary^) DO
          IF object_file^.module_dictionary^ [i].kind <> llc$load_module THEN
            IF object_file^.module_dictionary^ [i].kind <> llc$message_module THEN
              osp$set_status_abnormal (oc, oce$w_module_not_included, object_file^.module_dictionary^ [i].
                    name, status);
              issue_diagnostic (osc$warning_status, status);
            IFEND;
          ELSE
            include_load_module (object_file, object_file^.module_dictionary^ [i].module_header, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

          IFEND;
        FOREND;
      IFEND;


    PROCEND include_object_library;
?? OLDTITLE ??
?? NEWTITLE := 'add_object_files', EJECT ??

    PROCEDURE add_object_files
      (    object_files_to_add: oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        object_file: ^oct$object_file_descriptor;


      object_file := object_files_to_add.link;

      WHILE object_file <> NIL DO
        IF object_file^.is_a_library THEN
          include_object_library (object_file, status);
        ELSE
          include_object_file (object_file, status);
        IFEND;

        IF NOT status.normal THEN
          RETURN;
        IFEND;

        object_file := object_file^.link;
      WHILEND;


    PROCEND add_object_files;
?? OLDTITLE ??
?? NEWTITLE := 'add_object_modules', EJECT ??

    PROCEDURE add_object_modules
      (    modules_to_add: oct$program_name_list;
           object_libraries_to_use: oct$object_file_descriptor;
       VAR status: ost$status);


      VAR
        object_library: ^oct$object_file_descriptor,
        module_found: boolean,
        new_module: ^oct$program_name_list,
        module_before: ^oct$program_name_list,
        i: 0 .. llc$max_modules_in_library;


      IF modules_to_add.link = NIL THEN
        RETURN;
      IFEND;


      object_library := object_libraries_to_use.link;

      WHILE object_library <> NIL DO

        IF object_library^.module_dictionary <> NIL THEN
          FOR i := 1 TO UPPERBOUND (object_library^.module_dictionary^) DO
            IF object_library^.module_dictionary^ [i].kind = llc$load_module THEN
              ocp$search_modules_to_add (v$modules_to_add, object_library^.module_dictionary^ [i].name,
                    module_found, module_before);
              IF module_found THEN
                include_load_module (object_library, object_library^.module_dictionary^ [i].module_header,
                      status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;

                module_before^.link := module_before^.link^.link;
                IF modules_to_add.link = NIL THEN
                  RETURN;
                IFEND;
              IFEND;
            IFEND;
          FOREND;
        IFEND;

        object_library := object_library^.link;
      WHILEND;

    PROCEND add_object_modules;
?? OLDTITLE ??
?? NEWTITLE := 'satisfy_externals', EJECT ??

    PROCEDURE satisfy_externals
      (    object_libraries_to_use: oct$object_file_descriptor;
       VAR status: ost$status);


?? NEWTITLE := 'add_to_library_entry_points', EJECT ??

      PROCEDURE add_to_library_entry_points
        (    entry_point: ^oct$library_entry_points;
         VAR library_entry_points: oct$library_entry_points);


        VAR
          ept: ^oct$library_entry_points;


        ept := ^library_entry_points;

        WHILE TRUE DO
          IF entry_point^.name < ept^.name THEN
            IF ept^.l_link = NIL THEN
              ept^.l_link := entry_point;
              RETURN;
            ELSE
              ept := ept^.l_link;
            IFEND;

          ELSE
            IF ept^.r_link = NIL THEN
              ept^.r_link := entry_point;
              RETURN;
            ELSE
              ept := ept^.r_link;
            IFEND;

          IFEND;
        WHILEND;


      PROCEND add_to_library_entry_points;
?? OLDTITLE ??
?? NEWTITLE := 'collect_library_entry_points', EJECT ??

      PROCEDURE collect_library_entry_points
        (    object_library_to_use: oct$object_file_descriptor;
         VAR library_entry_points: oct$library_entry_points;
         VAR status: ost$status);


        VAR
          r3: ost$ring,
          i: llt$entry_point_index,
          object_library: ^oct$object_file_descriptor,
          entry_point: ^oct$library_entry_points;


        library_entry_points.name := osc$null_name;
        library_entry_points.l_link := NIL;
        library_entry_points.r_link := NIL;

        object_library := object_libraries_to_use.link;

        WHILE object_library <> NIL DO
          IF object_library^.entry_point_dictionary <> NIL THEN
            FOR i := 1 TO UPPERBOUND (object_library^.entry_point_dictionary^) DO
              IF object_library^.entry_point_dictionary^ [i].module_kind = llc$load_module THEN
                NEXT entry_point IN ocv$vel_scratch_seq;
                IF entry_point = NIL THEN
                  osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL16', status);
                  RETURN;
                IFEND;

                entry_point^.name := object_library^.entry_point_dictionary^ [i].name;
                entry_point^.r1 := object_library^.r1;

                IF object_library^.entry_point_dictionary^ [i].kind = llc$gate THEN
                  entry_point^.r3 := object_library^.r3;
                ELSE
                  entry_point^.r3 := object_library^.r2;
                IFEND;

                entry_point^.object_library := object_library;
                entry_point^.load_module_header := object_library^.entry_point_dictionary^ [i].module_header;
                entry_point^.l_link := NIL;
                entry_point^.r_link := NIL;

                add_to_library_entry_points (entry_point, library_entry_points);
              IFEND;
            FOREND;
          IFEND;

          object_library := object_library^.link;
        WHILEND;
      PROCEND collect_library_entry_points;
?? OLDTITLE ??
?? NEWTITLE := 'search_library_entry_points', EJECT ??

      PROCEDURE search_library_entry_points
        (    external: ^oct$ext_reference_list;
         VAR library_entry_points: oct$library_entry_points;
         VAR entry_point: ^oct$library_entry_points);


        entry_point := ^library_entry_points;

        WHILE entry_point <> NIL DO
          IF (external^.name = entry_point^.name) AND (rings_overlap
                (external^.r1, external^.r2, entry_point^.r1, entry_point^.r3)) THEN
            RETURN;

          ELSEIF external^.name < entry_point^.name THEN
            entry_point := entry_point^.l_link;
          ELSE
            entry_point := entry_point^.r_link;
          IFEND;

        WHILEND;


      PROCEND search_library_entry_points;
?? OLDTITLE ??
?? EJECT ??

      VAR
        library_entry_points: oct$library_entry_points,
        entry_point: ^oct$library_entry_points,
        external: ^oct$ext_reference_list,
        external_found: boolean;


      collect_library_entry_points (object_libraries_to_use, library_entry_points, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


      external := ^v$unsatisfied_externals;

      WHILE external^.link <> NIL DO
        search_library_entry_points (external^.link, library_entry_points, entry_point);

        IF entry_point <> NIL THEN
          include_load_module (entry_point^.object_library, entry_point^.load_module_header, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          external := external^.link;
        IFEND;
      WHILEND;

    PROCEND satisfy_externals;
?? OLDTITLE ??
?? NEWTITLE := 'clean_up_residue_diagnostics', EJECT ??

    PROCEDURE clean_up_residue_diagnostics;


      VAR
        defer_common_blocks: ^oct$defer_list,
        defer_entry_points: ^oct$defer_list,
        entry_point: ^oct$entry_points,
        external: ^oct$ext_reference_list,
        header_printed: boolean,
        modules: ^oct$program_name_list;


      IF NOT (pmc$no_load_map IN link_parameters.map_options) THEN
        header_printed := FALSE;

        entry_point := ^v$entry_points;

        WHILE entry_point <> NIL DO
          IF entry_point^.ring_violation THEN
            IF NOT header_printed THEN
              ocp$generate_link_map_text (v$lm_page_header);
              space (2);
            IFEND;
            osp$set_status_abnormal (oc, oce$w_ring_violation, entry_point^.name, status);
            issue_diagnostic (osc$warning_status, status);
          IFEND;

          entry_point := entry_point^.link;
        WHILEND;

        IF v$modules_to_add.link <> NIL THEN
          IF NOT header_printed THEN
            ocp$generate_link_map_text (v$lm_page_header);
            space (2);
          IFEND;

          modules := v$modules_to_add.link;

          WHILE modules <> NIL DO
            osp$set_status_abnormal (oc, oce$w_unsatisfied_module, modules^.name, status);
            issue_diagnostic (osc$warning_status, status);

            modules := modules^.link;
          WHILEND;
        IFEND;


        IF v$unsatisfied_externals.link <> NIL THEN
          IF NOT header_printed THEN
            ocp$generate_link_map_text (v$lm_page_header);
            space (2);
          IFEND;

          external := v$unsatisfied_externals.link;

          WHILE external <> NIL DO
            osp$set_status_abnormal (oc, oce$w_unsatisfied_external, external^.name, status);
            issue_diagnostic (osc$warning_status, status);

            external := external^.link;
          WHILEND;
        IFEND;

        IF (link_parameters.defer_entry_points <> NIL) THEN
          IF (link_parameters.defer_entry_points^.defer = occ$defer) OR
                (link_parameters.defer_entry_points^.defer = occ$defer_all_except) THEN
            defer_entry_points := link_parameters.defer_entry_points^.name_list;
            WHILE defer_entry_points <> NIL DO
              IF NOT defer_entry_points^.name_found THEN
                osp$set_status_abnormal (oc, oce$deferred_entry_pt_not_found, defer_entry_points^.name,
                      status);
                issue_diagnostic (osc$warning_status, status);
              IFEND;
              defer_entry_points := defer_entry_points^.link;
            WHILEND;
          IFEND;
        IFEND;

        IF (link_parameters.defer_common_blocks <> NIL) THEN
          IF (link_parameters.defer_common_blocks^.defer = occ$defer) OR
                (link_parameters.defer_common_blocks^.defer = occ$defer_all_except) THEN
            defer_common_blocks := link_parameters.defer_common_blocks^.name_list;
            WHILE defer_common_blocks <> NIL DO
              IF NOT defer_common_blocks^.name_found THEN
                osp$set_status_abnormal (oc, oce$deferred_com_blk_not_found, defer_common_blocks^.name,
                      status);
                issue_diagnostic (osc$warning_status, status);
              IFEND;
              defer_common_blocks := defer_common_blocks^.link;
            WHILEND;
          IFEND;
        IFEND;
      IFEND;

      search_entry_point_tree (v$starting_procedure, osc$invalid_ring, osc$max_ring, v$starting_entry_point);

      IF v$starting_entry_point = NIL THEN
        space (2);

        osp$set_status_condition (oce$w_no_starting_procedure, status);
        issue_diagnostic (osc$warning_status, status);

        v$starting_entry_point := ^v$entry_points;
        v$starting_entry_point^.name := osc$null_name;
        v$starting_entry_point^.pva.ring := osc$invalid_ring;
        v$starting_entry_point^.pva.seg := 0;
        v$starting_entry_point^.pva.offset := 0;
        v$starting_entry_point^.binding_section.ring := osc$invalid_ring;
        v$starting_entry_point^.binding_section.seg := 0;
        v$starting_entry_point^.binding_section.offset := 0;
      IFEND;


    PROCEND clean_up_residue_diagnostics;
?? OLDTITLE ??
?? NEWTITLE := 'generate_outboard_symbol_table', EJECT ??

    PROCEDURE generate_outboard_symbol_table
      (VAR status: ost$status);


      VAR
        symbol_table: ^SEQ ( * ),
        number_of_outboard_symbols: integer,
        outboard_symbol: ^oct$entry_points,
        entry_point: ^oct$entry_points;


      symbol_table := ocv$vel_scratch_seq;
      number_of_outboard_symbols := 0;
      entry_point := v$entry_points.link;

      WHILE entry_point <> NIL DO
        IF (link_parameters.linked_symbols = 'ALL ') OR ((entry_point^.gated) AND
              (entry_point^.r3 >= link_parameters.gate_ring_level)) THEN
          NEXT outboard_symbol IN symbol_table;
          IF outboard_symbol = NIL THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL19', status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          outboard_symbol^ := entry_point^;
          number_of_outboard_symbols := number_of_outboard_symbols + 1;
        IFEND;

        entry_point := entry_point^.link;
      WHILEND;

      IF number_of_outboard_symbols <> 0 THEN
        NEXT v$outboard_symbol_table: [1 .. number_of_outboard_symbols] IN ocv$vel_scratch_seq;
      ELSE
        v$outboard_symbol_table := NIL;
      IFEND;


    PROCEND generate_outboard_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := 'get_pointer_location', EJECT ??

    PROCEDURE get_pointer_location
      (    name: pmt$program_name;
       VAR location: ^cell);


      VAR
        valid_position: boolean,
        entry_point: ^oct$entry_points,
        output: ^oct$output_segment_descriptor,
        segment: ^SEQ ( * ),
        sequence_pointer: ost$segment_offset;


      search_entry_point_tree (name, osc$invalid_ring, osc$max_ring, entry_point);

      IF entry_point = NIL THEN
        location := NIL;

      ELSE
        output := v$output_segment_list.link;

        WHILE output^.number <> entry_point^.pva.seg DO
          output := output^.link;
        WHILEND;

        segment := output^.segment.sequence_pointer;
        pmp$position_object_library (segment, entry_point^.pva.offset, valid_position);
        IF NOT valid_position THEN
          location := NIL;
          RETURN;
        IFEND;

        NEXT location IN segment;

      IFEND;


    PROCEND get_pointer_location;
?? OLDTITLE ??
?? NEWTITLE := 'get_value_segment', EJECT ??

    PROCEDURE get_value_segment
      (    pointer: ^oct$pointer_list;
       VAR segment: ^oct$output_segment_descriptor);


      VAR
        section_name: ^oct$section_name_list;


      IF pointer^.section_name <> osc$null_name THEN
        section_name := v$section_name_list.link;

        WHILE section_name <> NIL DO
          IF (section_name^.name = pointer^.section_name) AND
                (section_name^.segment_descriptor^.extensible_attribute <> occ$allocated_extensible) THEN
            segment := section_name^.segment_descriptor;
            RETURN;
          IFEND;

          section_name := section_name^.link;
        WHILEND;

        segment := NIL;

      ELSE
        segment := v$output_segment_list.link;

        WHILE segment <> NIL DO
          IF (segment^.number = pointer^.segment_number) AND
                (segment^.extensible_attribute <> occ$allocated_extensible) THEN
            RETURN;
          IFEND;

          segment := segment^.link;
        WHILEND;
      IFEND;

      osp$set_status_abnormal (oc, oce$e_section_or_seg_not_found, pointer^.name, status);
      issue_diagnostic (osc$error_status, status);


    PROCEND get_value_segment;
?? OLDTITLE ??
?? NEWTITLE := 'turn_declaration_matching_off', EJECT ??

{ PURPOSE:
{   This procedure sets DECLARATION_MATCHING_REQUIRED to FALSE for
{   task services entry points (TSEP) specified by the DELETE_DECLARATION_MATCHING
{   program name list.

    PROCEDURE turn_declaration_matching_off
      (    delete_declaration_matching: oct$program_name_list;
       VAR tsep: ^array [1 .. * ] of oct$task_services_entry_point);

      VAR
        temp: integer,
        entry_point_found: boolean,
        entry_point_list: ^oct$program_name_list,
        hi: 0 .. occ$maximum_externals,
        lo: 0 .. occ$maximum_externals,
        mid: 0 .. occ$maximum_externals,
        status: ost$status;

      entry_point_list := delete_declaration_matching.link;

      WHILE entry_point_list <> NIL DO
        hi := UPPERBOUND (tsep^);
        lo := 1;
        entry_point_found := FALSE;

        WHILE (lo <= hi) AND NOT entry_point_found DO
          temp := lo + hi;
          mid := temp DIV 2;
          IF entry_point_list^.name = tsep^ [mid].ep.name THEN
            entry_point_found := TRUE;
            tsep^ [mid].ep.declaration_matching_required := FALSE;
          ELSEIF entry_point_list^.name < tsep^ [mid].ep.name THEN
            hi := mid - 1;
          ELSE
            lo := mid + 1;
          IFEND;
        WHILEND;

        IF NOT entry_point_found THEN
          osp$set_status_abnormal (oc, oce$w_name_not_in_symbol_table, entry_point_list^.name, status);
          issue_diagnostic (osc$warning_status, status);
        IFEND;

        entry_point_list := entry_point_list^.link;
      WHILEND;
    PROCEND turn_declaration_matching_off;
?? OLDTITLE ??
?? NEWTITLE := 'heap_sort_entry_points', EJECT ??

    PROCEDURE heap_sort_entry_points
      (    entry_points: ^array [1 .. * ] of oct$task_services_entry_point);


      VAR
        left: integer,
        right: integer,
        i: integer,
        j: integer,
        number: integer,
        temp: oct$task_services_entry_point,
        key: pmt$program_name;


      number := UPPERBOUND (entry_points^);

      IF (number = 1) THEN
        RETURN;
      ELSEIF (number = 2) THEN
        IF (entry_points^ [1].ep.name > entry_points^ [2].ep.name) THEN
          temp := entry_points^ [1];
          entry_points^ [1] := entry_points^ [2];
          entry_points^ [2] := temp;
        IFEND;
        RETURN;
      IFEND;

      left := (number DIV 2) + 1;
      right := number;

    /outer_loop/
      WHILE (TRUE) DO
        IF (left > 1) THEN
          left := left - 1;
          temp := entry_points^ [left];
          key := entry_points^ [left].ep.name;
        ELSE
          temp := entry_points^ [right];
          key := entry_points^ [right].ep.name;
          entry_points^ [right] := entry_points^ [1];
          right := right - 1;
          IF (right = 1) THEN
            entry_points^ [right] := temp;
            RETURN;
          IFEND;
        IFEND;

        j := left;

      /inner_loop/
        WHILE (TRUE) DO
          i := j;
          j := j + j;

          IF (j < right) THEN
            IF (entry_points^ [j].ep.name < entry_points^ [j + 1].ep.name) THEN
              j := j + 1;
            IFEND;
          ELSEIF (j > right) THEN
            EXIT /inner_loop/;
          IFEND;

          IF (key >= entry_points^ [j].ep.name) THEN
            EXIT /inner_loop/;
          IFEND;

          entry_points^ [i] := entry_points^ [j];
        WHILEND /inner_loop/;

        entry_points^ [i] := temp;
      WHILEND /outer_loop/;


    PROCEND heap_sort_entry_points;
?? OLDTITLE ??
?? NEWTITLE := 'build_task_services_entry_pnts', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to build an array of task services entry
{   points from the outboard symbol table, to sort it in alphabetical order,
{   and to turn declaration matching off for specified entry points.

    PROCEDURE build_task_services_entry_pnts
      (    delete_declaration_matching: oct$program_name_list;
       VAR tsep: ^array [1 .. * ] of oct$task_services_entry_point;
       VAR status: ost$status);


      VAR
        i: integer;

      status.normal := TRUE;

      IF v$outboard_symbol_table = NIL THEN
        tsep := NIL;
        RETURN;
      IFEND;

      NEXT tsep: [1 .. UPPERBOUND (v$outboard_symbol_table^)] IN ocv$vel_scratch_seq;
      IF tsep = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL20', status);
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      FOR i := 1 TO UPPERBOUND (tsep^) DO
        tsep^ [i].ep.name := v$outboard_symbol_table^ [i].name;
        tsep^ [i].ep.address.ring := v$outboard_symbol_table^ [i].pva.ring;
        tsep^ [i].ep.address.segment := v$outboard_symbol_table^ [i].pva.seg;
        tsep^ [i].ep.address.offset := v$outboard_symbol_table^ [i].pva.offset;
        tsep^ [i].ep.binding_section_address.ring := v$outboard_symbol_table^ [i].binding_section.ring;
        tsep^ [i].ep.binding_section_address.segment := v$outboard_symbol_table^ [i].binding_section.seg;
        tsep^ [i].ep.binding_section_address.offset := v$outboard_symbol_table^ [i].binding_section.offset;
        tsep^ [i].ep.gated := v$outboard_symbol_table^ [i].gated;
        tsep^ [i].ep.global_lock := v$outboard_symbol_table^ [i].global_key;
        tsep^ [i].ep.r1 := v$outboard_symbol_table^ [i].r1;
        tsep^ [i].ep.r2 := v$outboard_symbol_table^ [i].r2;
        tsep^ [i].ep.r3 := v$outboard_symbol_table^ [i].r3;
        tsep^ [i].ep.vmid := v$vmid;
        tsep^ [i].ep.declaration_matching_required := v$outboard_symbol_table^ [i].
              declaration_matching_required;
        tsep^ [i].ep.declaration_matching := v$outboard_symbol_table^ [i].declaration_matching;
        tsep^ [i].ep.language := v$outboard_symbol_table^ [i].language;
        tsep^ [i].fill := 0;
      FOREND;

      heap_sort_entry_points (tsep);

      IF delete_declaration_matching.link <> NIL THEN
        turn_declaration_matching_off (delete_declaration_matching, tsep);
      IFEND;

    PROCEND build_task_services_entry_pnts;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_symbol_table_ptrs', EJECT ??

    PROCEDURE initialize_symbol_table_ptrs
      (    symbol_table_pointers: oct$pointer_list;
           delete_declaration_matching: oct$program_name_list;
       VAR status: ost$status);


      VAR
        pointer: ^oct$pointer_list,

        tsep: ^array [1 .. * ] of oct$task_services_entry_point,

        symbol_table: ^array [1 .. * ] of oct$task_services_entry_point,
        symbol_table_pointer: ^cell,

        valid_position: boolean,
        sequence_pointer: ost$segment_offset,

        symbol_table_segment: ^oct$output_segment_descriptor;

      status.normal := TRUE;

      IF symbol_table_pointers.link = NIL THEN
        IF delete_declaration_matching.link <> NIL THEN
          osp$set_status_condition (oce$w_must_include_symbols, status);
          issue_diagnostic (osc$warning_status, status);
          status.normal := TRUE;
        IFEND;
        RETURN;
      IFEND;

      build_task_services_entry_pnts (delete_declaration_matching, tsep, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pointer := symbol_table_pointers.link;

      WHILE pointer <> NIL DO
        get_pointer_location (pointer^.name, symbol_table_pointer);

        IF symbol_table_pointer <> NIL THEN
          IF tsep = NIL THEN
            build_adaptable_array_pointer (0f(16), 0fff(16), 80000000(16), 0, 0, 0, symbol_table_pointer);

          ELSE
            get_value_segment (pointer, symbol_table_segment);

            IF symbol_table_segment <> NIL THEN
              sequence_pointer := i#current_sequence_position (symbol_table_segment^.segment.
                    sequence_pointer);
              sequence_pointer := ((sequence_pointer + 7) DIV 8) * 8;
              pmp$position_object_library (symbol_table_segment^.segment.sequence_pointer, sequence_pointer,
                    valid_position);
              IF NOT valid_position THEN
                osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL239', status);
                build_adaptable_array_pointer (0f(16), 0fff(16), 80000000(16), 0, 0, 0, symbol_table_pointer);
                issue_diagnostic (osc$error_status, status);
              ELSE
                build_adaptable_array_pointer (symbol_table_segment^.r2, symbol_table_segment^.number,
                      sequence_pointer, #SIZE (tsep^), 1, #SIZE (oct$task_services_entry_point),
                      symbol_table_pointer);

                NEXT symbol_table: [1 .. UPPERBOUND (tsep^)] IN
                      symbol_table_segment^.segment.sequence_pointer;
                IF symbol_table = NIL THEN
                  osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL239', status);
                  build_adaptable_array_pointer (0f(16), 0fff(16), 80000000(16), 0, 0, 0,
                        symbol_table_pointer);
                  issue_diagnostic (osc$error_status, status);

                ELSE
                  syp$advised_move_bytes (#LOC (tsep^), #LOC (symbol_table^), #SIZE (symbol_table^), status);
                  IF NOT status.normal THEN
                    issue_diagnostic (osc$fatal_status, status);
                    RETURN;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        pointer := pointer^.link;
      WHILEND;


    PROCEND initialize_symbol_table_ptrs;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_recovery_name_table', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to build a table of names and addresses
{   that will be used when the system being linked is being recovered.
{
{ NOTES:
{   The recovery name table is currently not implemented anywhere but in the linker.

    PROCEDURE initialize_recovery_name_table
      (    name_table: oct$pointer_list;
           addresses: oct$program_name_list;
       VAR status: ost$status);


      VAR
        name_table_pointer: ^oct$array_pointer,
        name_table_segment: ^oct$output_segment_descriptor,
        recovery_name_table: ^dst$recovery_name_table,
        sequence_pointer: ost$segment_offset,
        valid_position: boolean,
        address: ^oct$program_name_list,
        recovery_address: ^dst$recovery_address,
        number_of_addresses: integer,
        entry_point: ^oct$entry_points,
        pva: ^ost$pva;


      IF name_table.name = osc$null_name THEN
        RETURN;
      IFEND;

      get_pointer_location (name_table.name, name_table_pointer);
      IF name_table_pointer = NIL THEN
        RETURN;
      IFEND;

      IF addresses.link = NIL THEN
        build_adaptable_array_pointer (0f(16), 0fff(16), 80000000(16), 0, 0, 0, name_table_pointer);
        RETURN;
      IFEND;

      get_value_segment (^name_table, name_table_segment);
      IF name_table_segment = NIL THEN
        RETURN;
      IFEND;

      sequence_pointer := i#current_sequence_position (name_table_segment^.segment.sequence_pointer);
      sequence_pointer := ((sequence_pointer + 7) DIV 8) * 8;

      pmp$position_object_library (name_table_segment^.segment.sequence_pointer, sequence_pointer,
            valid_position);
      IF NOT valid_position THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL123', status);
        issue_diagnostic (osc$error_status, status);
        build_adaptable_array_pointer (0f(16), 0fff(16), 80000000(16), 0, 0, 0, name_table_pointer);
        RETURN;
      IFEND;

      number_of_addresses := 0;
      address := addresses.link;

      WHILE address <> NIL DO
        NEXT recovery_address IN name_table_segment^.segment.sequence_pointer;
        IF recovery_address = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL123', status);
          issue_diagnostic (osc$error_status, status);
          build_adaptable_array_pointer (0f(16), 0fff(16), 80000000(16), 0, 0, 0, name_table_pointer);
          RETURN;
        IFEND;

        recovery_address^.name := address^.name;
        search_entry_point_tree (address^.name, osc$invalid_ring, osc$max_ring, entry_point);

        IF entry_point = NIL THEN
          recovery_address^.address := NIL;
        ELSE
          pva := #LOC (recovery_address^.address);
          pva^ := entry_point^.pva;
          IF entry_point^.declaration_matching_required THEN
            recovery_address^.verification := entry_point^.declaration_matching;
          ELSE
            recovery_address^.verification.language_dependent_value := 0;
          IFEND;
        IFEND;

        number_of_addresses := number_of_addresses + 1;
        address := address^.link;
      WHILEND;

      build_adaptable_array_pointer (name_table_segment^.r2, name_table_segment^.number, sequence_pointer,
            (number_of_addresses * #SIZE (dst$recovery_address)), 1, #SIZE (dst$recovery_address),
            name_table_pointer);


    PROCEND initialize_recovery_name_table;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_heap_pointers', EJECT ??

    PROCEDURE initialize_heap_pointers
      (    heap_pointers: oct$pointer_list;
       VAR status: ost$status);


      VAR
        offset: integer,
        length: integer,
        pointer: ^oct$pointer_list,
        heap_segment: ^oct$output_segment_descriptor,
        sequence_pointer: ost$segment_offset,
        valid_position: boolean,
        heap_pointer: ^oct$heap_pointer;


      pointer := heap_pointers.link;

      WHILE pointer <> NIL DO
        get_pointer_location (pointer^.name, heap_pointer);

        IF heap_pointer <> NIL THEN
          get_value_segment (pointer, heap_segment);

          IF heap_segment <> NIL THEN
            sequence_pointer := i#current_sequence_position (heap_segment^.segment.sequence_pointer);

            offset := ((sequence_pointer + 31) DIV 32) * 32;
            length := (osc$max_segment_length - 1) - offset;

            IF length <= 0 THEN
              osp$set_status_abnormal (oc, oce$e_section_or_seg_not_found, pointer^.name, status);
              issue_diagnostic (osc$error_status, status);

            ELSE
              heap_pointer^.pva.ring := heap_segment^.r1;
              heap_pointer^.pva.seg := heap_segment^.number;
              heap_pointer^.pva.offset := offset;

              heap_segment^.used_attributes := heap_segment^.used_attributes +
                    $oct$segment_attributes [occ$sa_extensible];
              heap_segment^.extensible_attribute := occ$allocated_extensible;
              pmp$position_object_library (heap_segment^.segment.sequence_pointer, offset, valid_position);
              IF NOT valid_position THEN
                osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, pointer^.name, status);
                issue_diagnostic (osc$fatal_status, status);
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        pointer := pointer^.link;
      WHILEND;


    PROCEND initialize_heap_pointers;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_build_level_vars', EJECT ??

    PROCEDURE initialize_build_level_vars
      (    build_level: pmt$os_name;
           variables: oct$program_name_list);


      VAR
        local_status: ost$status,
        build_level_location: ^pmt$os_name,
        next_variable: ^oct$program_name_list;


      IF variables.link = NIL THEN
        RETURN;
      IFEND;

      IF build_level = osc$null_name THEN
        osp$set_status_condition (oce$w_build_level_not_specified, local_status);
        issue_diagnostic (osc$warning_status, local_status);
      IFEND;

      next_variable := variables.link;

      WHILE next_variable <> NIL DO
        get_pointer_location (next_variable^.name, build_level_location);

        IF build_level_location <> NIL THEN
          build_level_location^ := build_level;
        IFEND;

        next_variable := next_variable^.link;
      WHILEND;


    PROCEND initialize_build_level_vars;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_symbol_table_id', EJECT ??

    PROCEDURE initialize_symbol_table_id
      (    symbol_table_id: ost$name;
           symbol_table_id_variable: pmt$program_name;
       VAR status: ost$status);


      VAR
        name_pointer: ^ost$name;

      IF symbol_table_id <> osc$null_name THEN
        v$symbol_table_id := symbol_table_id;

      ELSE
        pmp$get_unique_name (v$symbol_table_id, status);
        IF NOT status.normal THEN
          issue_diagnostic (osc$fatal_status, status);
          RETURN;
        IFEND;
      IFEND;

      IF NOT (pmc$no_load_map IN link_parameters.map_options) THEN
        space (2);
        output ('SYMBOL TABLE ID = ', v$symbol_table_id, #SIZE (v$symbol_table_id), flush);
      IFEND;

      IF symbol_table_id_variable <> osc$null_name THEN
        get_pointer_location (symbol_table_id_variable, name_pointer);
        IF name_pointer <> NIL THEN
          name_pointer^ := v$symbol_table_id;
        IFEND;
      IFEND;


    PROCEND initialize_symbol_table_id;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_debug_table_pointer', EJECT ??

    PROCEDURE initialize_debug_table_pointer
      (    debug_table: ^SEQ ( * );
           debug_table_pointer: oct$pointer_list;
       VAR status: ost$status);


      VAR
        pointer_to_sequence: ^cell,
        segment: ^oct$output_segment_descriptor,
        saved_table: ^SEQ ( * );

      status.normal := TRUE;

      IF (debug_table_pointer.link = NIL) THEN
        RETURN;
      IFEND;

      get_pointer_location (debug_table_pointer.link^.name, pointer_to_sequence);
      IF (pointer_to_sequence <> NIL) THEN
        get_value_segment (debug_table_pointer.link, segment);
        IF (segment <> NIL) THEN
          NEXT saved_table: [[REP (#SIZE (debug_table^)) OF cell]] IN segment^.segment.sequence_pointer;
          IF saved_table = NIL THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL438', status);
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          syp$advised_move_bytes (#LOC (debug_table^), #LOC (saved_table^), #SIZE (saved_table^), status);
          IF NOT status.normal THEN
            issue_diagnostic (osc$fatal_status, status);
            RETURN;
          IFEND;

          build_adaptable_seq_pointer (segment^.r2, segment^.number, #OFFSET (saved_table),
                #SIZE (saved_table^), pointer_to_sequence);
        IFEND;
      IFEND;


    PROCEND initialize_debug_table_pointer;
?? OLDTITLE ??
?? NEWTITLE := 'clean_up_debug_processing', EJECT ??

    PROCEDURE clean_up_debug_processing
      (    debug_table_pointer: oct$pointer_list;
       VAR status: ost$status);


      VAR
        debug_table: ^SEQ ( * );


      ocp$dtb_get_debug_table (debug_table, status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$error_status, status);
        RETURN;
      IFEND;

      initialize_debug_table_pointer (debug_table, debug_table_pointer, status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$error_status, status);
        RETURN;
      IFEND;

      ocp$dtb_close_debug_table (status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$error_status, status);
        RETURN;
      IFEND;


    PROCEND clean_up_debug_processing;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_message_module_ptr', EJECT ??

    PROCEDURE initialize_message_module_ptr
      (    object_libraries_to_use: oct$object_file_descriptor;
           module_name: pmt$program_name;
           pointer_name: pmt$program_name;
           section_name: pmt$program_name;
       VAR status: ost$status);


      VAR
        message_module_header: ^llt$library_member_header,
        member: ^SEQ ( * ),
        member_size: llt$section_length,
        module_found: boolean,

        object_library: ^oct$object_file_descriptor,
        i: 0 .. llc$max_modules_in_library,

        pointer_to_sequence: ^cell,
        section_pointer: oct$pointer_list,
        segment: ^oct$output_segment_descriptor,
        saved_table: ^SEQ ( * );


      status.normal := TRUE;

      object_library := object_libraries_to_use.link;

      module_found := FALSE;

    /find_message_module/
      WHILE object_library <> NIL DO

        IF object_library^.module_dictionary <> NIL THEN
          FOR i := LOWERBOUND (object_library^.module_dictionary^)
                TO UPPERBOUND (object_library^.module_dictionary^) DO
            IF (object_library^.module_dictionary^ [i].kind = llc$message_module) AND
                  (object_library^.module_dictionary^ [i].name = module_name) THEN

              message_module_header := #PTR (object_library^.module_dictionary^ [i].message_header,
                    object_library^.segment.sequence_pointer^);
              IF message_module_header <> NIL THEN
                member_size := message_module_header^.member_size;
                member := #PTR (message_module_header^.member, object_library^.segment.sequence_pointer^);
                IF member <> NIL THEN
                  RESET member;
                  module_found := TRUE;
                  EXIT /find_message_module/
                ELSE
                  osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL439', status);
                  issue_diagnostic (osc$fatal_status, status);
                  RETURN;
                IFEND;
              ELSE
                osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL439', status);
                issue_diagnostic (osc$fatal_status, status);
                RETURN;
              IFEND;
            IFEND;
          FOREND;
        IFEND;

        object_library := object_library^.link;
      WHILEND /find_message_module/;

      get_pointer_location (pointer_name, pointer_to_sequence);

      IF pointer_to_sequence <> NIL THEN
        IF module_found THEN
          section_pointer.section_name := section_name;
          get_value_segment (^section_pointer, segment);
          IF (segment <> NIL) THEN
            NEXT saved_table: [[REP member_size OF cell]] IN segment^.segment.sequence_pointer;
            IF saved_table = NIL THEN
              osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL439', status);
              issue_diagnostic (osc$fatal_status, status);
              RETURN;
            IFEND;

            saved_table^ := member^;

            build_adaptable_seq_pointer (segment^.r2, segment^.number, #OFFSET (saved_table), member_size,
                  pointer_to_sequence);
          IFEND;
        ELSE
          build_adaptable_seq_pointer (0f(16), 0fff(16), 80000000(16), 0, pointer_to_sequence);
        IFEND;
      IFEND;

    PROCEND initialize_message_module_ptr;
?? OLDTITLE ??
?? NEWTITLE := 'print_allocated_segment_map', EJECT ??

    PROCEDURE print_allocated_segment_map
      (    allocated_segments: oct$output_segment_descriptor);


      VAR
        segment: ^oct$output_segment_descriptor,
        sections: ^oct$program_name_list,
        seq_pointer: ost$segment_offset,

        header_printed: boolean,
        attribute: oct$segment_attribute,
        segment_attributes: oct$segment_attributes,
        ascii_attribute: [STATIC] array [occ$sa_cache_bypass .. occ$sa_no_append] of string (2) :=
              ['CB', 'ET', 'WR', 'SH', 'FX', 'ST', 'RT', 'FB', 'NA'];


      segment := allocated_segments.link;

      WHILE segment <> NIL DO
        v$lm_segment_detail.segment := segment^.number;
        v$lm_segment_detail.r1 := segment^.r1;
        v$lm_segment_detail.r2 := segment^.r2;
        v$lm_segment_detail.segment_global_key_lock := segment^.global_key;
        v$lm_segment_detail.segment_local_key_lock := segment^.local_key;
        v$lm_segment_detail.stack_segment := FALSE;

        seq_pointer := i#current_sequence_position (segment^.segment.sequence_pointer);
        v$lm_segment_detail.segment_length := seq_pointer;

        v$lm_segment_detail.segment_access_attributes.cache_bypass :=
              (occ$sa_cache_bypass IN segment^.used_attributes);

        IF occ$sa_read IN segment^.used_attributes THEN
          v$lm_segment_detail.segment_access_attributes.read_privilege := osc$read_uncontrolled;
        ELSEIF occ$sa_read_kl IN segment^.used_attributes THEN
          v$lm_segment_detail.segment_access_attributes.read_privilege := osc$read_key_lock_controlled;
        ELSEIF occ$sa_binding IN segment^.used_attributes THEN
          v$lm_segment_detail.segment_access_attributes.read_privilege := osc$binding_segment;
        ELSE
          v$lm_segment_detail.segment_access_attributes.read_privilege := osc$non_readable;
        IFEND;

        IF occ$sa_write IN segment^.used_attributes THEN
          v$lm_segment_detail.segment_access_attributes.write_privilege := osc$write_uncontrolled;
        ELSEIF occ$sa_write_kl IN segment^.used_attributes THEN
          v$lm_segment_detail.segment_access_attributes.write_privilege := osc$write_key_lock_controlled;
        ELSE
          v$lm_segment_detail.segment_access_attributes.write_privilege := osc$non_writable;
        IFEND;

        IF occ$sa_non_privileged IN segment^.used_attributes THEN
          v$lm_segment_detail.segment_access_attributes.execute_privilege := osc$non_privileged;
        ELSEIF occ$sa_local_privilege IN segment^.used_attributes THEN
          v$lm_segment_detail.segment_access_attributes.execute_privilege := osc$local_privilege;
        ELSEIF occ$sa_global_privilege IN segment^.used_attributes THEN
          v$lm_segment_detail.segment_access_attributes.execute_privilege := osc$global_privilege;
        ELSE
          v$lm_segment_detail.segment_access_attributes.execute_privilege := osc$non_executable;
        IFEND;

        ocp$generate_link_map_text (v$lm_segment_detail);

        header_printed := FALSE;
        segment_attributes := segment^.used_attributes + segment^.unused_attributes;

        FOR attribute := occ$sa_cache_bypass TO occ$sa_no_append DO
          IF attribute IN segment_attributes THEN
            IF NOT header_printed THEN
              output (' ', '                                               ', 44, no_flush);
              header_printed := TRUE;
            IFEND;

            output (' ', ascii_attribute [attribute], 2, no_flush);
          IFEND;
        FOREND;

        IF header_printed THEN
          output (' ', ' ', 1, flush);
        IFEND;

        IF segment^.sections_allocated.link <> NIL THEN
          sections := segment^.sections_allocated.link;
          output ('                                   SECTIONS : ', sections^.name,
                STRLENGTH (sections^.name), flush);

          sections := sections^.link;

          WHILE sections <> NIL DO
            output ('                                              ', sections^.name,
                  STRLENGTH (sections^.name), flush);
            sections := sections^.link;
          WHILEND;
        IFEND;

        segment := segment^.link;
      WHILEND;

    PROCEND print_allocated_segment_map;
?? OLDTITLE ??
?? NEWTITLE := 'print_common_block_map', EJECT ??

    PROCEDURE print_common_block_map
      (    allocated_common_blocks: oct$common_block_item);


      VAR
        common_block: ^oct$common_block_item,
        print_line: string (80),
        pos: 1 .. 81,
        attributes: oct$segment_attributes,
        dummy: ost$status;


      IF allocated_common_blocks.link <> NIL THEN
        ocp$generate_link_map_text (v$lm_page_header);
        output ('', 'ALLOCATED COMMON BLOCK MAP', 26, flush);
        output ('   ', 'ACCESS ATTRIBUTES', 17, no_flush);
        output ('               ', 'LENGTH', 6, no_flush);
        output ('        ', 'ADDRESS', 7, flush);
        output ('   ', '--------------------------------------------------------------', 60, flush);

        common_block := allocated_common_blocks.link;

        WHILE common_block <> NIL DO
          space (1);
          print_line := '  ';
          pos := 4;

          print_line (pos, 6) := 'NAME: ';
          pos := pos + 6;

          print_line (pos, * ) := common_block^.section_item^.common_block_name;
          pos := pos + 31;

          IF common_block^.section_item^.deferred_common_block THEN
            print_line (pos, * ) := 'DEFERRED ';
            pos := pos + 9;
          IFEND;

          output ('', print_line, 60, flush);

          print_line := '  ';
          pos := 4;
          attributes := common_block^.section_item^.output^.used_attributes;

          IF occ$sa_extensible IN attributes THEN
            print_line (pos, * ) := 'EXTENSIBLE ';
            pos := pos + 11;
          IFEND;

          IF occ$sa_binding IN attributes THEN
            print_line (pos, * ) := 'BINDING ';
            pos := pos + 8;
          ELSEIF occ$sa_read IN attributes THEN
            print_line (pos, * ) := 'READ ';
            pos := pos + 5;
          ELSEIF occ$sa_read_kl IN attributes THEN
            print_line (pos, * ) := 'READ_KL ';
            pos := pos + 8;
          IFEND;

          IF occ$sa_write IN attributes THEN
            print_line (pos, * ) := 'WRITE ';
            pos := pos + 6;
          ELSEIF occ$sa_write_kl IN attributes THEN
            print_line (pos, * ) := 'WRITE_KL ';
            pos := pos + 9;
          IFEND;

          IF (occ$sa_non_privileged IN attributes) OR (occ$sa_local_privilege IN attributes) OR
                (occ$sa_global_privilege IN attributes) THEN
            print_line (pos, * ) := 'EXECUTE ';
            pos := pos + 8;
          IFEND;

          clp$convert_integer_to_rjstring (common_block^.section_item^.definition.length, 16, FALSE, ' ',
                print_line (35, 8), dummy);
          convert_hex_pva_to_ascii (common_block^.section_item^.pva, print_line (47, 14));

          output ('', print_line, 60, flush);

          common_block := common_block^.link;
        WHILEND;
      IFEND;


    PROCEND print_common_block_map;
?? OLDTITLE ??
?? NEWTITLE := 'print_starting_procedure', EJECT ??

    PROCEDURE print_starting_procedure
      (    starting_procedure: ^oct$entry_points);


      IF starting_procedure^.name <> osc$null_name THEN
        v$lm_transfer_detail.transfer_symbol := starting_procedure^.name;
        v$lm_transfer_detail.transfer_address.ring := starting_procedure^.pva.ring;
        v$lm_transfer_detail.transfer_address.segment := starting_procedure^.pva.seg;
        v$lm_transfer_detail.transfer_address.offset := starting_procedure^.pva.offset;

        ocp$generate_link_map_text (v$lm_transfer_detail);
      IFEND;


    PROCEND print_starting_procedure;
?? OLDTITLE ??
?? NEWTITLE := 'build_symbol_table', EJECT ??

    PROCEDURE build_symbol_table
      (    symbol_table_name: ^fst$file_reference;
       VAR status: ost$status);


      VAR
        id: amt$file_identifier,
        segment: amt$segment_pointer,
        symbol_table_header: ^oct$symbol_table_header,
        symbol_table: ^oct$list_of_entry_points,
        ignore_status: ost$status;


      IF symbol_table_name = NIL THEN
        RETURN;
      IFEND;

      ocp$open_output_segment (symbol_table_name^, id, segment, status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      NEXT symbol_table_header IN segment.sequence_pointer;
      IF symbol_table_header = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL99', status);
        issue_diagnostic (osc$fatal_status, status);
        fsp$close_file (id, ignore_status);
        RETURN;
      IFEND;

      symbol_table_header^.version := occ$symbol_table_version;
      symbol_table_header^.id := v$symbol_table_id;

      IF v$outboard_symbol_table = NIL THEN
        symbol_table_header^.number_of_symbols := 0;
      ELSE
        symbol_table_header^.number_of_symbols := UPPERBOUND (v$outboard_symbol_table^);

        NEXT symbol_table: [1 .. symbol_table_header^.number_of_symbols] IN segment.sequence_pointer;
        IF symbol_table = NIL THEN
          osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL100', status);
          issue_diagnostic (osc$fatal_status, status);
          fsp$close_file (id, ignore_status);
          RETURN;
        IFEND;

        symbol_table^ := v$outboard_symbol_table^;
      IFEND;

      amp$set_segment_eoi (id, segment, status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$fatal_status, status);
        fsp$close_file (id, ignore_status);
        RETURN;
      IFEND;

      fsp$close_file (id, status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;


    PROCEND build_symbol_table;
?? OLDTITLE ??
?? NEWTITLE := 'fill_in_image_header', EJECT ??

    PROCEDURE fill_in_image_header
      (    header: ^pmt$virtual_memory_image_header);


      VAR
        entry_point: ^oct$entry_points,
        pva: ^ost$pva,
        i: 0 .. 8;


      header^.version := pmc$image_version;
      header^.system_core_id := v$symbol_table_id;

      header^.starting_procedure.fill1 := 0;
      header^.starting_procedure.vmid := osc$cyber_180_mode;
      header^.starting_procedure.xp := TRUE;
      header^.starting_procedure.fill2 := 0;
      header^.starting_procedure.r3 := v$starting_entry_point^.pva.ring;
      pva := #LOC (header^.starting_procedure.code_pva);
      pva^ := v$starting_entry_point^.pva;
      header^.starting_procedure.fill3 := 0;
      pva := #LOC (header^.starting_procedure.binding_pva);
      pva^ := v$starting_entry_point^.binding_section;

      header^.number_of_segments := 0;

      FOR i := 1 TO UPPERBOUND (header^.pad_for_170_linker) DO
        header^.pad_for_170_linker [i] := 0;
      FOREND;

      IF (link_parameters.exchange_package_variable <> osc$null_name) THEN
        search_entry_point_tree (link_parameters.exchange_package_variable, 1, 15, entry_point);
        IF (entry_point <> NIL) THEN
          header^.exchange_package := #ADDRESS (entry_point^.pva.ring, entry_point^.pva.seg,
                entry_point^.pva.offset);
        ELSE
          header^.exchange_package := NIL;
        IFEND;
      ELSE
        header^.exchange_package := NIL;
      IFEND;


    PROCEND fill_in_image_header;
?? OLDTITLE ??
?? NEWTITLE := 'fill_in_segment_description', EJECT ??

    PROCEDURE fill_in_segment_description
      (    descriptor: ^oct$output_segment_descriptor;
           length: ost$segment_length;
           description: ^pmt$linked_segment_description);


      VAR
        i: 0 .. 8;


      description^.name := descriptor^.name;
      description^.segment_number := descriptor^.number;
      description^.length := length;

      IF occ$sa_cache_bypass IN descriptor^.used_attributes THEN
        description^.segment_descriptor.vl := osc$vl_cache_bypass;
      ELSE
        description^.segment_descriptor.vl := osc$vl_regular_segment;
      IFEND;

      IF occ$sa_non_privileged IN descriptor^.used_attributes THEN
        description^.segment_descriptor.xp := osc$non_privileged;
      ELSEIF occ$sa_local_privilege IN descriptor^.used_attributes THEN
        description^.segment_descriptor.xp := osc$local_privilege;
      ELSEIF occ$sa_global_privilege IN descriptor^.used_attributes THEN
        description^.segment_descriptor.xp := osc$global_privilege;
      ELSE
        description^.segment_descriptor.xp := osc$non_executable;
      IFEND;

      IF occ$sa_read IN descriptor^.used_attributes THEN
        description^.segment_descriptor.rp := osc$read_uncontrolled;
      ELSEIF occ$sa_read_kl IN descriptor^.used_attributes THEN
        description^.segment_descriptor.rp := osc$read_key_lock_controlled;
      ELSEIF occ$sa_binding IN descriptor^.used_attributes THEN
        description^.segment_descriptor.rp := osc$binding_segment;
      ELSE
        description^.segment_descriptor.rp := osc$non_readable;
      IFEND;

      IF occ$sa_write IN descriptor^.used_attributes THEN
        description^.segment_descriptor.wp := osc$write_uncontrolled;
      ELSEIF occ$sa_write_kl IN descriptor^.used_attributes THEN
        description^.segment_descriptor.wp := osc$write_key_lock_controlled;
      ELSE
        description^.segment_descriptor.wp := osc$non_writable;
      IFEND;

      description^.segment_descriptor.r1 := descriptor^.r1;
      description^.segment_descriptor.r2 := descriptor^.r2;
      description^.segment_descriptor.asid := 0;

      description^.segment_descriptor.key_lock.value := 0;

      IF descriptor^.global_key <> 0 THEN
        description^.segment_descriptor.key_lock.global := TRUE;
        description^.segment_descriptor.key_lock.value := descriptor^.global_key;
      ELSE
        description^.segment_descriptor.key_lock.global := FALSE;
      IFEND;

      IF descriptor^.local_key <> 0 THEN
        description^.segment_descriptor.key_lock.local := TRUE;
        description^.segment_descriptor.key_lock.value := descriptor^.local_key;
      ELSE
        description^.segment_descriptor.key_lock.local := FALSE;
      IFEND;

      description^.software_attributes := $mmt$software_attribute_set [];
      IF occ$sa_wired IN descriptor^.unused_attributes THEN
        description^.software_attributes := description^.software_attributes +
              $mmt$software_attribute_set [mmc$sa_wired];
      IFEND;
      IF occ$sa_fixed IN descriptor^.unused_attributes THEN
        description^.software_attributes := description^.software_attributes +
              $mmt$software_attribute_set [mmc$sa_fixed];
      IFEND;
      IF occ$sa_stack IN descriptor^.unused_attributes THEN
        description^.software_attributes := description^.software_attributes +
              $mmt$software_attribute_set [mmc$sa_stack];
      IFEND;
      IF occ$sa_read_transfer_unit IN descriptor^.unused_attributes THEN
        description^.software_attributes := description^.software_attributes +
              $mmt$software_attribute_set [mmc$sa_read_transfer_unit];
      IFEND;
      IF occ$sa_free_behind IN descriptor^.unused_attributes THEN
        description^.software_attributes := description^.software_attributes +
              $mmt$software_attribute_set [mmc$sa_free_behind];
      IFEND;
      IF occ$sa_no_append IN descriptor^.unused_attributes THEN
        description^.software_attributes := description^.software_attributes +
              $mmt$software_attribute_set [mmc$sa_no_append];
      IFEND;

      FOR i := 1 TO UPPERBOUND (description^.pad_for_170_linker) DO
        description^.pad_for_170_linker [i] := 0;
      FOREND;


    PROCEND fill_in_segment_description;
?? OLDTITLE ??
?? NEWTITLE := 'build_virtual_memory_image', EJECT ??

    PROCEDURE build_virtual_memory_image
      (    virtual_memory_image: fst$file_reference;
       VAR status: ost$status);


      VAR
        ignore_status: ost$status,
        id: amt$file_identifier,
        segment: amt$segment_pointer,
        header: ^pmt$virtual_memory_image_header,
        description: ^pmt$linked_segment_description,
        descriptor: ^oct$output_segment_descriptor,
        length: ost$segment_length,
        pad_segment: ^SEQ ( * ),
        temp_segment: ^SEQ ( * ),
        output_segment: ^SEQ ( * );


      ocp$open_output_segment (virtual_memory_image, id, segment, status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;

      NEXT header IN segment.sequence_pointer;
      IF header = NIL THEN
        osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL101', status);
        issue_diagnostic (osc$fatal_status, status);
        fsp$close_file (id, ignore_status);
        RETURN;
      IFEND;

      fill_in_image_header (header);

      descriptor := v$output_segment_list.link;

      WHILE descriptor <> NIL DO

        IF occ$sa_binding IN descriptor^.used_attributes THEN
          NEXT pad_segment: [[REP 8 OF cell]] IN descriptor^.segment.sequence_pointer;
          IF pad_segment = NIL THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VEL98', status);
            issue_diagnostic (osc$fatal_status, status);
            fsp$close_file (id, ignore_status);
            RETURN;
          IFEND;
        IFEND;

{ for 170 linker compatability

        length := ((i#current_sequence_position (descriptor^.segment.sequence_pointer) + 3) DIV 4) * 4;

        IF length > 0 THEN
          header^.number_of_segments := header^.number_of_segments + 1;

          NEXT description IN segment.sequence_pointer;
          IF description = NIL THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VE102', status);
            issue_diagnostic (osc$fatal_status, status);
            fsp$close_file (id, ignore_status);
            RETURN;
          IFEND;

          fill_in_segment_description (descriptor, length, description);

          RESET descriptor^.segment.sequence_pointer;
          NEXT temp_segment: [[REP length OF cell]] IN descriptor^.segment.sequence_pointer;
          NEXT output_segment: [[REP length OF cell]] IN segment.sequence_pointer;
          IF (temp_segment = NIL) OR (output_segment = NIL) THEN
            osp$set_status_abnormal (oc, oce$e_storage_allocation_failed, 'VE103', status);
            issue_diagnostic (osc$fatal_status, status);
            fsp$close_file (id, ignore_status);
            RETURN;
          IFEND;

          syp$advised_move_bytes (#LOC (temp_segment^), #LOC (output_segment^), #SIZE (output_segment^),
                status);
          IF NOT status.normal THEN
            issue_diagnostic (osc$fatal_status, status);
            fsp$close_file (id, ignore_status);
            RETURN;
          IFEND;
        IFEND;

        descriptor := descriptor^.link;
      WHILEND;

      header^.length := i#current_sequence_position (segment.sequence_pointer);

      amp$set_segment_eoi (id, segment, status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$fatal_status, status);
        fsp$close_file (id, ignore_status);
        RETURN;
      IFEND;

      fsp$close_file (id, status);
      IF NOT status.normal THEN
        issue_diagnostic (osc$fatal_status, status);
        RETURN;
      IFEND;


    PROCEND build_virtual_memory_image;
?? OLDTITLE ??
?? NEWTITLE := 'convert_seg_to_section_ordinal', EJECT ??

{ A nearly identical piece of code appears in procedure build_entry_definition_record.
{ If this procedure is changed, that one may need to change too.

    PROCEDURE convert_seg_to_section_ordinal
      (    segment_number: llt$section_ordinal;
       VAR section_ordinal: llt$section_ordinal;
       VAR relocation_offset: ost$segment_offset);

      VAR
        seg: ^oct$output_segment_descriptor;


      seg := v$output_segment_list.link;

      WHILE (seg <> NIL) AND (seg^.number <> segment_number) DO
        seg := seg^.link;
      WHILEND;

      IF (seg <> NIL) THEN
        section_ordinal := seg^.section_ordinal;
        relocation_offset := #OFFSET (seg^.segment.sequence_pointer);
      ELSE
        section_ordinal := UPPERVALUE (segment_number);
        relocation_offset := 0;
      IFEND;

    PROCEND convert_seg_to_section_ordinal;
?? OLDTITLE ??
?? NEWTITLE := 'open_binary_output_file', EJECT ??

    PROCEDURE open_binary_output_file
      (    name: fst$file_reference;
       VAR file_identifier: amt$file_identifier;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        attachment_options: ^fst$attachment_options,
        creation_validation_attributes: ^fst$file_cycle_attributes,
        ignore_status: ost$status;


      status.normal := TRUE;

      PUSH attachment_options: [1 .. 2];
      PUSH creation_validation_attributes: [1 .. 2];

      attachment_options^ [1].selector := fsc$access_and_share_modes;
      attachment_options^ [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options^ [1].access_modes.value := $fst$file_access_options
            [fsc$read, fsc$append, fsc$modify, fsc$shorten];
      attachment_options^ [1].share_modes.selector := fsc$determine_from_access_modes;
      attachment_options^ [2].selector := fsc$delete_data;
      attachment_options^ [2].delete_data := TRUE;

      creation_validation_attributes^ [1].selector := fsc$file_contents_and_processor;
      creation_validation_attributes^ [1].file_contents := fsc$object_data;
      creation_validation_attributes^ [1].file_processor := amc$unknown_processor;
      creation_validation_attributes^ [2].selector := fsc$record_type;
      creation_validation_attributes^ [2].record_type := amc$undefined;

      fsp$open_file (name, amc$segment, attachment_options, {default_creation_attributes} NIL,
            creation_validation_attributes, creation_validation_attributes, {attribute_override} NIL,
            file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$get_segment_pointer (file_identifier, amc$sequence_pointer, output_file, status);
      IF NOT status.normal THEN
        fsp$close_file (file_identifier, ignore_status);
        RETURN;
      IFEND;

      RESET output_file.sequence_pointer;


    PROCEND open_binary_output_file;
?? OLDTITLE ??
?? NEWTITLE := 'assign_section_ordinals', EJECT ??

    PROCEDURE assign_section_ordinals
      (    segments: oct$output_segment_descriptor;
       VAR greatest_section_ordinal: llt$section_ordinal);


      VAR
        seg: ^oct$output_segment_descriptor,
        section_ordinal: integer;


      section_ordinal := -1;
      seg := segments.link;

      WHILE seg <> NIL DO
        IF i#current_sequence_position (seg^.segment.sequence_pointer) <> 0 THEN
          section_ordinal := section_ordinal + 1;
          seg^.section_ordinal := section_ordinal;
        IFEND;

        seg := seg^.link;
      WHILEND;

      IF section_ordinal >= 0 THEN
        greatest_section_ordinal := section_ordinal;
      ELSE
        greatest_section_ordinal := 0;
      IFEND;


    PROCEND assign_section_ordinals;
?? OLDTITLE ??
?? NEWTITLE := 'build_identification_record', EJECT ??

    PROCEDURE build_identification_record
      (    name: fst$file_reference;
           kind: llt$module_kind;
           greatest_section_ordinal: llt$section_ordinal;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        identification: ^llt$identification,
        object_text_descriptor: ^llt$object_text_descriptor,
        parsed_file_reference: fst$parsed_file_reference;


      NEXT object_text_descriptor IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      object_text_descriptor^.kind := llc$identification;
      object_text_descriptor^.unused := 0;

      NEXT identification IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      clp$convert_string_to_file_ref (name, parsed_file_reference, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      identification^.name := parsed_file_reference.path (parsed_file_reference.last_name.index,
            parsed_file_reference.last_name.size);

      identification^.object_text_version := llc$object_text_version;
      identification^.kind := kind;

      pmp$get_time (osc$hms_time, identification^.time_created, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pmp$get_date (osc$mdy_date, identification^.date_created, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      identification^.attributes := $llt$module_attributes [llc$nonbindable];
      IF NOT v$source_type_checking THEN
        identification^.attributes := identification^.attributes +
              $llt$module_attributes [llc$object_cybil_checking];
      IFEND;
      identification^.greatest_section_ordinal := greatest_section_ordinal;
      identification^.generator_id := llc$virtual_environment_linker;
      identification^.generator_name_vers := 'Virtual Environment Linker - V1.0';
      identification^.commentary := ' ';


    PROCEND build_identification_record;
?? OLDTITLE ??
?? NEWTITLE := 'build_68000_absolute', EJECT ??


    PROCEDURE build_68000_absolute
      (    name: fst$file_reference;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        m68000_absolute: ^llt$68000_absolute,
        local_68000_sequence: ^SEQ ( * ),
        text: ^SEQ ( * ),
        file_identifier: amt$file_identifier,
        size: ost$segment_length,
        offset: 0 .. osc$max_segment_length - 1,
        space: ^SEQ ( * ),
        output_file: amt$segment_pointer;


      open_binary_output_file (name, file_identifier, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_identification_record (name, llc$motorola_68000_absolute, 0, output_file, status);

      NEXT object_text_descriptor IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      get_68000_segment_limits (size, offset);
      object_text_descriptor^.kind := llc$68000_absolute;
      object_text_descriptor^.number_of_68000_bytes := size - offset;

      NEXT m68000_absolute: [[REP object_text_descriptor^.number_of_68000_bytes OF cell]] IN
            output_file.sequence_pointer;
      IF m68000_absolute = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      m68000_absolute^.load_address := offset;
      m68000_absolute^.transfer_address := v$starting_entry_point^.pva.offset;

      local_68000_sequence := link_parameters.mc68000_seq;

      RESET local_68000_sequence;

      IF offset <> 0 THEN
        NEXT space: [[REP offset OF cell]] IN local_68000_sequence;
      IFEND;

      NEXT text: [[REP object_text_descriptor^.number_of_68000_bytes OF cell]] IN local_68000_sequence;

      m68000_absolute^.text := text^;

      build_transfer_symbol (v$starting_procedure, output_file, status);

      close_binary_output_file (file_identifier, output_file, status);

    PROCEND build_68000_absolute;

?? OLDTITLE ??
?? NEWTITLE := 'get_68000_segment_limits', EJECT ??

    PROCEDURE get_68000_segment_limits
      (VAR size: ost$segment_length;
       VAR offset: 0 .. osc$max_segment_length - 1);

      VAR
        segment: ^oct$output_segment_descriptor,
        segment2: ^oct$output_segment_descriptor,
        offset1: 0 .. osc$max_segment_length - 1,
        size1: ost$segment_length;

      size := 0;
      offset := 0;

      segment := ^v$output_segment_list;

      IF segment <> NIL THEN
        segment := segment^.link;
        IF segment <> NIL THEN
          size := i#current_sequence_position (segment^.segment.sequence_pointer);
          offset := segment^.offset;
          segment2 := segment^.link;
          WHILE segment2 <> NIL DO
            IF segment2^.offset < offset THEN
              offset := segment2^.offset;
            IFEND;
            size1 := i#current_sequence_position (segment2^.segment.sequence_pointer);
            IF size < size1 THEN
              size := size1;
            IFEND;
            segment2 := segment2^.link;
          WHILEND;
        IFEND;
      IFEND;


    PROCEND get_68000_segment_limits;
?? OLDTITLE ??
?? NEWTITLE := 'build_libraries', EJECT ??

    PROCEDURE build_libraries
      (    number_of_libraries: integer;
           library_list: oct$known_file_list;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        libraries: ^llt$libraries,
        lib: ^oct$known_file_list,
        i: integer;


      IF number_of_libraries > 0 THEN
        NEXT object_text_descriptor IN output_file.sequence_pointer;
        IF object_text_descriptor = NIL THEN
          osp$set_status_condition (oce$e_eof_on_generated_file, status);
          RETURN;
        IFEND;

        object_text_descriptor^.kind := llc$libraries;
        object_text_descriptor^.number_of_libraries := number_of_libraries;

        NEXT libraries: [1 .. number_of_libraries] IN output_file.sequence_pointer;
        IF libraries = NIL THEN
          osp$set_status_condition (oce$e_eof_on_generated_file, status);
          RETURN;
        IFEND;

        lib := library_list.link;

        FOR i := 1 TO number_of_libraries DO
          libraries^ [i] := lib^.name^;
          lib := lib^.link;
        FOREND;
      IFEND;


    PROCEND build_libraries;
?? OLDTITLE ??
?? NEWTITLE := 'assign_section_attributes', EJECT ??

    PROCEDURE assign_section_attributes
      (    segment_attributes: oct$segment_attributes;
           extensible: oct$extensible_attributes;
       VAR section_kind: llt$section_kind;
       VAR section_attributes: llt$section_access_attributes);


      IF (($oct$segment_attributes [occ$sa_non_privileged, occ$sa_local_privilege,
            occ$sa_global_privilege] * segment_attributes) <> $oct$segment_attributes []) THEN
        section_kind := llc$code_section;
        section_attributes := $llt$section_access_attributes [llc$read, llc$execute];

      ELSEIF occ$sa_binding IN segment_attributes THEN
        section_kind := llc$binding_section;
        section_attributes := $llt$section_access_attributes [llc$read, llc$binding];

      ELSE
        IF extensible = occ$allocated_extensible THEN
          section_kind := llc$extensible_working_storage;
        ELSE
          section_kind := llc$working_storage_section;
        IFEND;

        IF (($oct$segment_attributes [occ$sa_read, occ$sa_read_kl] * segment_attributes) <>
              $oct$segment_attributes []) THEN
          section_attributes := $llt$section_access_attributes [llc$read];
        ELSE
          section_attributes := $llt$section_access_attributes [];
        IFEND;

        IF (($oct$segment_attributes [occ$sa_write, occ$sa_write_kl] * segment_attributes) <>
              $oct$segment_attributes []) THEN
          section_attributes := section_attributes + $llt$section_access_attributes [llc$write];
        IFEND;
      IFEND;


    PROCEND assign_section_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'build_segment_definition', EJECT ??

    PROCEDURE build_segment_definition
      (    segment: ^oct$output_segment_descriptor;
           length: ost$segment_length;
       VAR section_kind: llt$section_kind;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        segment_definition: ^llt$segment_definition,
        relocation_offset: ost$segment_offset;


      NEXT object_text_descriptor IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      object_text_descriptor^.kind := llc$segment_definition;
      object_text_descriptor^.unused := 0;

      NEXT segment_definition IN output_file.sequence_pointer;
      IF segment_definition = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      segment_definition^.segment_number := segment^.number;
      segment_definition^.r1 := segment^.r1;
      segment_definition^.r2 := segment^.r2;

      IF segment^.cybil_default_heap THEN
        segment_definition^.section_definition.kind := llc$extensible_common_block;
        segment_definition^.section_definition.access_attributes := $llt$section_access_attributes
              [llc$read, llc$write];

        segment_definition^.section_definition.name := cyc$default_heap_name;
      ELSE
        assign_section_attributes (segment^.used_attributes, segment^.extensible_attribute,
              segment_definition^.section_definition.kind, segment_definition^.section_definition.
              access_attributes);

        segment_definition^.section_definition.name := osc$null_name;
      IFEND;

      segment_definition^.section_definition.section_ordinal := segment^.section_ordinal;
      IF segment^.extensible_attribute <> occ$allocated_extensible THEN
        segment_definition^.section_definition.length := length;
      ELSE
        segment_definition^.section_definition.length := 7fffffff(16);
      IFEND;
      segment_definition^.section_definition.allocation_alignment := 8;
      segment_definition^.section_definition.allocation_offset := 0;
      segment_definition^.section_definition.name := osc$null_name;

      section_kind := segment_definition^.section_definition.kind;

      IF (section_kind = llc$code_section) AND (segment^.binding_section_encountered) THEN
        convert_seg_to_section_ordinal (segment^.binding_section_segment,
              segment_definition^.binding_section_ordinal, relocation_offset);
        segment_definition^.binding_section_offset := segment^.binding_section_offset - relocation_offset;
      ELSE
        segment_definition^.binding_section_ordinal := 0;
        segment_definition^.binding_section_offset := 0;
      IFEND;

      segment_definition^.future_use := 0;


    PROCEND build_segment_definition;
?? OLDTITLE ??
?? NEWTITLE := 'build_common_block_definition', EJECT ??

    PROCEDURE build_common_block_definition
      (    section_item: ^oct$section_table_item;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        section_definition: ^llt$section_definition;


      NEXT object_text_descriptor IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      IF (section_item^.unallocated_common_block) THEN
        object_text_descriptor^.kind := llc$unallocated_common_block;
      ELSE
        object_text_descriptor^.kind := llc$section_definition;
      IFEND;
      object_text_descriptor^.unused := 0;

      NEXT section_definition IN output_file.sequence_pointer;
      IF section_definition = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      section_definition^ := section_item^.definition;
      section_definition^.section_ordinal := section_item^.output^.section_ordinal;
      section_definition^.name := section_item^.common_block_name;
      IF (section_definition^.name = cyc$default_heap_name) THEN
        section_definition^.length := 7fffffff(16);
      IFEND;


    PROCEND build_common_block_definition;
?? OLDTITLE ??
?? NEWTITLE := 'build_deferred_common_block', EJECT ??

{ PURPOSE:
{   The purpose of this request is to build an object text record containing
{   all of the deferred common blocks.
{ DESIGN:
{   Search common block table for those that are deferred and build a common
{   block definition for each uniquely named common block.  Duplicate common
{   block definitions are combined.

    PROCEDURE build_deferred_common_block
      (    common_blocks: oct$common_block_item;
           number_deferred_common_blocks: llt$section_ordinal;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);

      VAR
        common_block: ^oct$common_block_item,
        common_block_index: 0 .. llc$max_deferred_common_blocks,
        deferred_common_blocks: ^llt$deferred_common_blocks,
        extensible_common_block: boolean,
        object_text_descriptor: ^llt$object_text_descriptor,
        previously_defined: boolean,
        search_index: 0 .. llc$max_deferred_common_blocks;


      status.normal := TRUE;

{ Build object text records for the deferred common blocks.

      NEXT object_text_descriptor IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      object_text_descriptor^.kind := llc$deferred_common_blocks;

      NEXT deferred_common_blocks: [1 .. number_deferred_common_blocks] IN output_file.sequence_pointer;
      IF deferred_common_blocks = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      common_block_index := 0;

      common_block := common_blocks.link;

      WHILE (common_block <> NIL) DO
        IF common_block^.section_item^.deferred_common_block THEN
          extensible_common_block := (common_block^.section_item^.definition.kind =
                llc$extensible_common_block);

          previously_defined := FALSE;

        /find_common_block/
          FOR search_index := 1 TO common_block_index DO
            IF (deferred_common_blocks^ [search_index].name = common_block^.section_item^.definition.name)
                  THEN
              previously_defined := TRUE;
              EXIT /find_common_block/
            IFEND;
          FOREND /find_common_block/;

          IF NOT previously_defined THEN
            common_block_index := common_block_index + 1;
            deferred_common_blocks^ [common_block_index].name :=
                  common_block^.section_item^.common_block_name;
            deferred_common_blocks^ [common_block_index].global_lock :=
                  common_block^.section_item^.global_key;
            deferred_common_blocks^ [common_block_index].loaded_ring := common_block^.section_item^.r2;
            deferred_common_blocks^ [common_block_index].address.ring := common_block^.section_item^.pva.ring;
            deferred_common_blocks^ [common_block_index].address.segment :=
                  common_block^.section_item^.pva.seg;
            deferred_common_blocks^ [common_block_index].address.offset :=
                  common_block^.section_item^.pva.offset;
            deferred_common_blocks^ [common_block_index].allocation_length :=
                  common_block^.section_item^.definition.length;
            deferred_common_blocks^ [common_block_index].allocation_alignment :=
                  common_block^.section_item^.definition.allocation_alignment;
            deferred_common_blocks^ [common_block_index].allocation_offset :=
                  common_block^.section_item^.definition.allocation_offset;
            deferred_common_blocks^ [common_block_index].access_attributes :=
                  common_block^.section_item^.definition.access_attributes;
            convert_segment_access_control (common_block^.section_item^.output^.used_attributes,
                  deferred_common_blocks^ [common_block_index].segment_access_control);
            deferred_common_blocks^ [common_block_index].extensible := extensible_common_block;
            deferred_common_blocks^ [common_block_index].unallocated_common := FALSE;
            deferred_common_blocks^ [common_block_index].unallocated_common_open := FALSE;
          ELSE {previously_defined
            IF (deferred_common_blocks^ [search_index].extensible = extensible_common_block) AND
                  (deferred_common_blocks^ [search_index].allocation_alignment =
                  common_block^.section_item^.definition.allocation_alignment) AND
                  (deferred_common_blocks^ [search_index].allocation_offset =
                  common_block^.section_item^.definition.allocation_offset) AND
                  (deferred_common_blocks^ [search_index].access_attributes =
                  common_block^.section_item^.definition.access_attributes) THEN
              IF (deferred_common_blocks^ [search_index].allocation_length <>
                    common_block^.section_item^.definition.length) THEN
                IF extensible_common_block THEN
                  IF (deferred_common_blocks^ [search_index].allocation_length <
                        common_block^.section_item^.definition.length) THEN
                    deferred_common_blocks^ [search_index].allocation_length :=
                          common_block^.section_item^.definition.length;
                  IFEND;
                ELSE
                  osp$set_status_abnormal (oc, oce$w_conflicting_common_length,
                        common_block^.section_item^.common_block_name, status);
                  issue_diagnostic (osc$warning_status, status);
                IFEND;
              IFEND;
            ELSE
              osp$set_status_abnormal (oc, oce$w_conflicting_com_attribute,
                    common_block^.section_item^.common_block_name, status);
              issue_diagnostic (osc$warning_status, status);
            IFEND;
          IFEND; {previously_defined
        IFEND; {deferred_common_block

        common_block := common_block^.link;
      WHILEND;

{ Position output_file to end of last deferred common block definition.

      object_text_descriptor^.number_of_common_blocks := common_block_index;
      RESET output_file.sequence_pointer TO deferred_common_blocks;
      NEXT deferred_common_blocks: [1 .. common_block_index] IN output_file.sequence_pointer;

    PROCEND build_deferred_common_block;
?? OLDTITLE ??
?? NEWTITLE := 'build_text_record', EJECT ??

    PROCEDURE build_text_record
      (    section_ordinal: llt$section_ordinal;
           segment: amt$segment_pointer;
           length: ost$segment_length;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        local_segment: amt$segment_pointer,
        object_text_descriptor: ^llt$object_text_descriptor,
        text: ^llt$text,
        byte: ^array [1 .. * ] of 0 .. 255;


      local_segment := segment;

      NEXT object_text_descriptor IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      object_text_descriptor^.kind := llc$text;
      object_text_descriptor^.number_of_bytes := length;

      NEXT text: [1 .. length] IN output_file.sequence_pointer;
      IF text = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      text^.section_ordinal := section_ordinal;
      text^.offset := 0;

      RESET local_segment.sequence_pointer;
      NEXT byte: [1 .. length] IN local_segment.sequence_pointer;
      syp$advised_move_bytes (#LOC (byte^), #LOC (text^.byte), #SIZE (byte^), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


    PROCEND build_text_record;
?? OLDTITLE ??
?? NEWTITLE := 'build_segment_definitions', EJECT ??

    PROCEDURE build_segment_definitions
      (    output_segments: oct$output_segment_descriptor;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        segment: ^oct$output_segment_descriptor,
        length: ost$segment_length,
        section_kind: llt$section_kind;


      segment := output_segments.link;

      WHILE segment <> NIL DO
        IF (NOT segment^.retained_common_block) THEN
          length := i#current_sequence_position (segment^.segment.sequence_pointer);

          IF length > 0 THEN
            build_segment_definition (segment, length, section_kind, output_file, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF (segment^.number_of_bytes_written > 0) THEN
              build_text_record (segment^.section_ordinal, segment^.segment, segment^.number_of_bytes_written,
                    output_file, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;

          IFEND;
        IFEND;

        segment := segment^.link;
      WHILEND;


    PROCEND build_segment_definitions;
?? OLDTITLE ??
?? NEWTITLE := 'build_common_block_definitions', EJECT ??

    PROCEDURE build_common_block_definitions
      (    common_blocks: oct$common_block_item;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        common_block: ^oct$common_block_item,
        length: ost$segment_length,
        number_of_bytes_written: ost$segment_length,
        number_deferred_common_blocks: 0 .. llc$max_deferred_common_blocks,
        segment: ^oct$output_segment_descriptor;


      common_block := common_blocks.link;

      number_deferred_common_blocks := 0;
      WHILE common_block <> NIL DO
        IF (common_block^.section_item^.retained_common_block) AND
              (NOT common_block^.section_item^.deferred_common_block) THEN
          segment := common_block^.section_item^.output;
          length := i#current_sequence_position (segment^.segment.sequence_pointer);

          IF length > 0 THEN
            build_common_block_definition (common_block^.section_item, output_file, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF (segment^.number_of_bytes_written > 0) THEN

{ Remember this segment is "inside" another segment, so number written must be recomputed.

              number_of_bytes_written := segment^.number_of_bytes_written -
                    #OFFSET (segment^.segment.sequence_pointer);
              IF (number_of_bytes_written > 0) THEN
                build_text_record (segment^.section_ordinal, segment^.segment, number_of_bytes_written,
                      output_file, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              IFEND;
            IFEND;

            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        ELSEIF common_block^.section_item^.deferred_common_block THEN
          number_deferred_common_blocks := number_deferred_common_blocks + 1;
        IFEND;

        common_block := common_block^.link;
      WHILEND;

      IF number_deferred_common_blocks > 0 THEN
        build_deferred_common_block (common_blocks, number_deferred_common_blocks, output_file, status);
      IFEND;

    PROCEND build_common_block_definitions;
?? OLDTITLE ??
?? NEWTITLE := 'build_adr_records', EJECT ??

    PROCEDURE build_adr_records
      (    address_formulation_records: oct$object_record_list;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        address_formulation: ^llt$address_formulation,
        adr: ^oct$object_record_list,
        dest_relocation: ost$segment_offset,
        value_relocation: ost$segment_offset,
        i: integer;


      adr := address_formulation_records.link;

      WHILE adr <> NIL DO
        NEXT object_text_descriptor IN output_file.sequence_pointer;
        IF object_text_descriptor = NIL THEN
          osp$set_status_condition (oce$e_eof_on_generated_file, status);
          RETURN;
        IFEND;

        object_text_descriptor^.kind := llc$address_formulation;
        object_text_descriptor^.number_of_adr_items := UPPERBOUND (adr^.address_formulation^.item);

        NEXT address_formulation: [1 .. object_text_descriptor^.number_of_adr_items] IN
              output_file.sequence_pointer;
        IF address_formulation = NIL THEN
          osp$set_status_condition (oce$e_eof_on_generated_file, status);
          RETURN;
        IFEND;

        address_formulation^ := adr^.address_formulation^;
        convert_seg_to_section_ordinal (address_formulation^.dest_section, address_formulation^.dest_section,
              dest_relocation);
        convert_seg_to_section_ordinal (address_formulation^.value_section,
              address_formulation^.value_section, value_relocation);

        IF (dest_relocation <> 0) OR (value_relocation <> 0) THEN
          FOR i := 1 TO object_text_descriptor^.number_of_adr_items DO
            address_formulation^.item [i].dest_offset := address_formulation^.item [i].dest_offset -
                  dest_relocation;
            address_formulation^.item [i].value_offset := address_formulation^.item [i].value_offset -
                  value_relocation;
          FOREND;
        IFEND;

        adr := adr^.link;
      WHILEND;


    PROCEND build_adr_records;
?? OLDTITLE ??
?? NEWTITLE := 'build_external_records', EJECT ??

    PROCEDURE build_external_records
      (    unsatisfied_externals: oct$ext_reference_list;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        maximum: llt$object_text_descriptor,
        relocation_offset: ost$segment_offset,
        object_text_descriptor: ^llt$object_text_descriptor,
        external_linkage: ^llt$external_linkage,
        external: ^oct$ext_reference_list,
        item: ^oct$external_items;


      maximum.number_of_ext_items := UPPERVALUE (maximum.number_of_ext_items);

      external := unsatisfied_externals.link;

      WHILE (external <> NIL) DO
        object_text_descriptor := ^maximum;

        item := external^.items.link;

        WHILE (item <> NIL) DO
          IF (object_text_descriptor^.number_of_ext_items = UPPERVALUE (object_text_descriptor^.
                number_of_ext_items)) THEN
            NEXT object_text_descriptor IN output_file.sequence_pointer;
            IF object_text_descriptor = NIL THEN
              osp$set_status_condition (oce$e_eof_on_generated_file, status);
              RETURN;
            IFEND;

            object_text_descriptor^.kind := llc$external_linkage;
            object_text_descriptor^.number_of_ext_items := 1;

            NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN
                  output_file.sequence_pointer;
            IF (external_linkage = NIL) THEN
              osp$set_status_condition (oce$e_eof_on_generated_file, status);
              RETURN;
            IFEND;

            external_linkage^.name := external^.name;
            external_linkage^.language := external^.language;
            external_linkage^.declaration_matching_required := external^.declaration_matching_required;
            external_linkage^.declaration_matching := external^.declaration_matching;
          ELSE
            object_text_descriptor^.number_of_ext_items := object_text_descriptor^.number_of_ext_items + 1;

            RESET output_file.sequence_pointer TO external_linkage;
            NEXT external_linkage: [1 .. object_text_descriptor^.number_of_ext_items] IN
                  output_file.sequence_pointer;
            IF object_text_descriptor = NIL THEN
              osp$set_status_condition (oce$e_eof_on_generated_file, status);
              RETURN;
            IFEND;
          IFEND;

          convert_seg_to_section_ordinal (item^.output^.number, external_linkage^.
                item [object_text_descriptor^.number_of_ext_items].section_ordinal, relocation_offset);
          external_linkage^.item [object_text_descriptor^.number_of_ext_items].
                offset := #OFFSET (item^.address) - relocation_offset;
          external_linkage^.item [object_text_descriptor^.number_of_ext_items].kind := item^.kind;
          external_linkage^.item [object_text_descriptor^.number_of_ext_items].offset_operand :=
                item^.offset_operand;

          item := item^.link;
        WHILEND;

        external := external^.link;
      WHILEND;


    PROCEND build_external_records;
?? OLDTITLE ??
?? NEWTITLE := 'build_relocation_record', EJECT ??

    PROCEDURE build_relocation_record
      (    output_segments: oct$output_segment_descriptor;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        maximum: llt$object_text_descriptor,
        relocation_offset: ost$segment_offset,
        ignore: ost$segment_offset,
        object_text_descriptor: ^llt$object_text_descriptor,
        relocation_item: ^llt$relocation_item,
        segment: ^oct$output_segment_descriptor,
        section_ordinal: llt$section_ordinal,
        relocation_value: ^oct$segment_relocation_list;


      object_text_descriptor := ^maximum;
      object_text_descriptor^.number_of_rel_items := UPPERVALUE (object_text_descriptor^.number_of_rel_items);
      segment := output_segments.link;

      WHILE segment <> NIL DO
        convert_seg_to_section_ordinal (segment^.number, section_ordinal, relocation_offset);
        relocation_value := segment^.relocation_list.link;

        WHILE relocation_value <> NIL DO
          IF (object_text_descriptor^.number_of_rel_items = UPPERVALUE (object_text_descriptor^.
                number_of_rel_items)) THEN
            NEXT object_text_descriptor IN output_file.sequence_pointer;
            IF object_text_descriptor = NIL THEN
              osp$set_status_condition (oce$e_eof_on_generated_file, status);
              RETURN;
            IFEND;

            object_text_descriptor^.kind := llc$relocation;
            object_text_descriptor^.number_of_rel_items := 1;
          ELSE
            object_text_descriptor^.number_of_rel_items := object_text_descriptor^.number_of_rel_items + 1;
          IFEND;

          NEXT relocation_item IN output_file.sequence_pointer;
          IF object_text_descriptor = NIL THEN
            osp$set_status_condition (oce$e_eof_on_generated_file, status);
            RETURN;
          IFEND;

          relocation_item^.section_ordinal := section_ordinal;
          relocation_item^.offset := #OFFSET (relocation_value^.pva) + 2 - relocation_offset;
          convert_seg_to_section_ordinal (relocation_value^.pva^.seg, relocation_item^.relocating_section,
                ignore);
          relocation_item^.container := llc$four_bytes;
          relocation_item^.address := llc$byte_signed;

          relocation_value := relocation_value^.link;
        WHILEND;

        segment := segment^.link;
      WHILEND;


    PROCEND build_relocation_record;
?? OLDTITLE ??
?? NEWTITLE := 'heap_sort_deferred_entry_points', EJECT ??

{ PURPOSE:
{   Sort the deferred entry point list by name.

    PROCEDURE heap_sort_deferred_entry_points
      (VAR deferred_entry_points: llt$deferred_entry_points);


      VAR
        i: 0 .. llc$max_deferred_entry_points,
        j: 0 .. llc$max_deferred_entry_points,
        key: pmt$program_name,
        left: 0 .. llc$max_deferred_entry_points,
        number: 1 .. llc$max_deferred_entry_points,
        right: 0 .. llc$max_deferred_entry_points,
        temp: llt$deferred_entry_point;


      number := UPPERBOUND (deferred_entry_points);

      IF (number = 1) THEN
        RETURN;
      ELSEIF (number = 2) THEN
        IF (deferred_entry_points [1].name > deferred_entry_points [2].name) THEN
          temp := deferred_entry_points [1];
          deferred_entry_points [1] := deferred_entry_points [2];
          deferred_entry_points [2] := temp;
        IFEND;
        RETURN;
      IFEND;

      left := (number DIV 2) + 1;
      right := number;

    /outer_loop/
      WHILE (TRUE) DO
        IF (left > 1) THEN
          left := left - 1;
          temp := deferred_entry_points [left];
          key := deferred_entry_points [left].name;
        ELSE
          temp := deferred_entry_points [right];
          key := deferred_entry_points [right].name;
          deferred_entry_points [right] := deferred_entry_points [1];
          right := right - 1;
          IF (right = 1) THEN
            deferred_entry_points [right] := temp;
            RETURN;
          IFEND;
        IFEND;

        j := left;

      /inner_loop/
        WHILE (TRUE) DO
          i := j;
          j := j + j;

          IF (j < right) THEN
            IF (deferred_entry_points [j].name < deferred_entry_points [j + 1].name) THEN
              j := j + 1;
            IFEND;
          ELSEIF (j > right) THEN
            EXIT /inner_loop/;
          IFEND;

          IF (key >= deferred_entry_points [j].name) THEN
            EXIT /inner_loop/;
          IFEND;

          deferred_entry_points [i] := deferred_entry_points [j];
        WHILEND /inner_loop/;

        deferred_entry_points [i] := temp;
      WHILEND /outer_loop/;

    PROCEND heap_sort_deferred_entry_points;
?? OLDTITLE ??
?? NEWTITLE := 'build_deferred_entry_definition', EJECT ??

{ PURPOSE:
{   The purpose of this request is to build an object text record containing
{   all of the deferred entry points.
{ DESIGN:
{   Search entry point list for those that are deferred and build entry
{   definitions that include the segment number and offset of the entry
{   point.

    PROCEDURE build_deferred_entry_definition
      (    entry_points: oct$entry_points;
           number_of_deferred_entry_points: llt$section_ordinal;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);

      VAR
        deferred_entry_points: ^llt$deferred_entry_points,
        entry_point: ^oct$entry_points,
        entry_point_index: 0 .. llc$max_deferred_entry_points,
        ignore_relocation_offset: ost$segment_offset,
        object_text_descriptor: ^llt$object_text_descriptor;


      status.normal := TRUE;

{ Build object text records for the deferred common blocks.

      NEXT object_text_descriptor IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      object_text_descriptor^.kind := llc$deferred_entry_points;
      object_text_descriptor^.number_of_entry_points := number_of_deferred_entry_points;

      NEXT deferred_entry_points: [1 .. number_of_deferred_entry_points] IN output_file.sequence_pointer;
      IF deferred_entry_points = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      entry_point_index := 0;

      entry_point := entry_points.link;

      WHILE (entry_point <> NIL) AND (entry_point_index < number_of_deferred_entry_points) DO
        IF entry_point^.deferred THEN
          entry_point_index := entry_point_index + 1;

          deferred_entry_points^ [entry_point_index].address.ring := entry_point^.pva.ring;
          deferred_entry_points^ [entry_point_index].address.segment := entry_point^.pva.seg;
          deferred_entry_points^ [entry_point_index].address.offset := entry_point^.pva.offset;
          convert_seg_to_section_ordinal (entry_point^.pva.seg,
                deferred_entry_points^ [entry_point_index].section_ordinal, ignore_relocation_offset);
          deferred_entry_points^ [entry_point_index].attributes := entry_point^.attributes;
          deferred_entry_points^ [entry_point_index].name := entry_point^.name;
          deferred_entry_points^ [entry_point_index].language := entry_point^.language;
          deferred_entry_points^ [entry_point_index].declaration_matching_required :=
                entry_point^.declaration_matching_required;
          deferred_entry_points^ [entry_point_index].declaration_matching_value :=
                entry_point^.declaration_matching;
          deferred_entry_points^ [entry_point_index].source_type_checking := v$source_type_checking;
          deferred_entry_points^ [entry_point_index].binding_section_address.ring :=
                entry_point^.binding_section.ring;
          deferred_entry_points^ [entry_point_index].binding_section_address.segment :=
                entry_point^.binding_section.seg;
          deferred_entry_points^ [entry_point_index].binding_section_address.offset :=
                entry_point^.binding_section.offset;

        IFEND;

        entry_point := entry_point^.link;
      WHILEND;

      heap_sort_deferred_entry_points (deferred_entry_points^);
    PROCEND build_deferred_entry_definition;
?? OLDTITLE ??
?? NEWTITLE := 'build_entry_definition_records', EJECT ??

    PROCEDURE build_entry_definition_records
      (    entry_points: oct$entry_points;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        entry_definition: ^llt$entry_definition,
        ept: ^oct$entry_points,
        number_of_deferred_entry_points: 0 .. llc$max_deferred_entry_points,
        object_text_descriptor: ^llt$object_text_descriptor,
        relocation_offset: ost$segment_offset,
        segment_p: ^oct$output_segment_descriptor;

      ept := entry_points.link;

      number_of_deferred_entry_points := 0;
      WHILE ept <> NIL DO
        IF (NOT ept^.deferred) THEN
          NEXT object_text_descriptor IN output_file.sequence_pointer;
          IF object_text_descriptor = NIL THEN
            osp$set_status_condition (oce$e_eof_on_generated_file, status);
            RETURN;
          IFEND;

          object_text_descriptor^.kind := llc$entry_definition;
          object_text_descriptor^.unused := 0;

          NEXT entry_definition IN output_file.sequence_pointer;
          IF entry_definition = NIL THEN
            osp$set_status_condition (oce$e_eof_on_generated_file, status);
            RETURN;
          IFEND;

          segment_p := v$output_segment_list.link;

          WHILE (segment_p <> NIL) AND (segment_p^.number <> ept^.pva.seg) DO
            segment_p := segment_p^.link;
          WHILEND;

          IF (segment_p <> NIL) THEN
            entry_definition^.section_ordinal := segment_p^.section_ordinal;
            IF segment_p^.retained_common_block AND (segment_p^.extensible_attribute = occ$non_extensible)
                  THEN

{  This common block is defined inside of the scratch sequence so it has not been relocated.

              relocation_offset := 0;
            ELSE
              relocation_offset := #OFFSET (segment_p^.segment.sequence_pointer);
            IFEND;
          ELSE
            entry_definition^.section_ordinal := UPPERVALUE (ept^.pva.seg);
            relocation_offset := 0;
          IFEND;

          entry_definition^.offset := ept^.pva.offset - relocation_offset;
          entry_definition^.attributes := ept^.attributes;
          entry_definition^.name := ept^.name;
          entry_definition^.language := ept^.language;
          entry_definition^.declaration_matching_required := ept^.declaration_matching_required;
          entry_definition^.declaration_matching := ept^.declaration_matching;
        ELSE {ept^.deferred
          number_of_deferred_entry_points := number_of_deferred_entry_points + 1;
        IFEND;

        ept := ept^.link;
      WHILEND;

      IF number_of_deferred_entry_points > 0 THEN
        build_deferred_entry_definition (entry_points, number_of_deferred_entry_points, output_file, status);
      IFEND;

    PROCEND build_entry_definition_records;
?? OLDTITLE ??
?? NEWTITLE := 'build_transfer_symbol', EJECT ??

    PROCEDURE build_transfer_symbol
      (    name: pmt$program_name;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      VAR
        object_text_descriptor: ^llt$object_text_descriptor,
        transfer_symbol: ^llt$transfer_symbol;


      NEXT object_text_descriptor IN output_file.sequence_pointer;
      IF object_text_descriptor = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      object_text_descriptor^.kind := llc$transfer_symbol;
      object_text_descriptor^.unused := 0;

      NEXT transfer_symbol IN output_file.sequence_pointer;
      IF transfer_symbol = NIL THEN
        osp$set_status_condition (oce$e_eof_on_generated_file, status);
        RETURN;
      IFEND;

      transfer_symbol^.name := name;


    PROCEND build_transfer_symbol;
?? OLDTITLE ??
?? NEWTITLE := 'close_binary_output_file', EJECT ??

    PROCEDURE close_binary_output_file
      (    file_identifier: amt$file_identifier;
       VAR output_file: amt$segment_pointer;
       VAR status: ost$status);


      amp$set_segment_eoi (file_identifier, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fsp$close_file (file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


    PROCEND close_binary_output_file;
?? OLDTITLE ??
?? NEWTITLE := 'build_product_module', EJECT ??

    PROCEDURE build_product_module
      (    name: fst$file_reference;
       VAR status: ost$status);


      VAR
        file_identifier: amt$file_identifier,
        output_file: amt$segment_pointer,
        greatest_section_ordinal: llt$section_ordinal;


      open_binary_output_file (name, file_identifier, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      assign_section_ordinals (v$output_segment_list, greatest_section_ordinal);

      build_identification_record (name, v$module_kind, greatest_section_ordinal, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_libraries (v$number_of_libraries, v$library_list, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_segment_definitions (v$output_segment_list, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_common_block_definitions (v$common_block_table, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_adr_records (v$address_formulation_records, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_external_records (v$unsatisfied_externals, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_relocation_record (v$output_segment_list, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_entry_definition_records (v$entry_points, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      build_transfer_symbol (v$starting_procedure, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      close_binary_output_file (file_identifier, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


    PROCEND build_product_module;
?? OLDTITLE ??
?? EJECT ??

    CONST
      flush = TRUE,
      no_flush = FALSE;

    VAR
      current_message_module: ^oct$message_module_list,
      entry_point: ^oct$entry_points,
      link_map_close_status: ost$status,
      malfunction_descriptor: pmt$established_handler,
      map_malfunction: [STATIC, READ] pmt$condition := [pmc$user_defined_condition, loe$map_malfunction],
      reset_value: ^SEQ ( * ),
      v$output_buffer: string (120),
      v$output_pos: 1 .. 121;


    pmp$establish_condition_handler (map_malfunction, ^link_map_malfunction, ^malfunction_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$initialize_link_map (link_parameters.map_file^, link_parameters.build_level, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF link_parameters.debug_table <> NIL THEN
      v$generate_debug_tables := TRUE;
      ocp$dtb_initialize_debug_tables (link_parameters.build_level, link_parameters.input_debug_table,
            link_parameters.debug_table^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      v$generate_debug_tables := FALSE;
    IFEND;

    reset_value := ocv$vel_scratch_seq;

    osp$set_status_abnormal (oc, oce$i_generate_status, 'GENERATE completed - NO errors encountered',
          v$generate_status);

  /link_virtual_environment/
    BEGIN
      setup_link (status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      process_predefined_segments (ocv$predefined_segment_list, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      process_inboard_symbol_tables (link_parameters.symbol_tables_to_use, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      v$module_kind := llc$mi_virtual_state;

      add_object_files (link_parameters.object_files_to_add, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      IF v$starting_procedure = osc$null_name THEN
        v$starting_procedure := v$last_starting_procedure;
      IFEND;

      add_object_modules (link_parameters.modules_to_add, link_parameters.object_libraries_to_use, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      IF v$starting_procedure = osc$null_name THEN
        v$starting_procedure := v$last_starting_procedure;
      IFEND;

      satisfy_externals (link_parameters.object_libraries_to_use, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      search_entry_point_tree (v$starting_procedure, osc$invalid_ring, osc$max_ring, entry_point);
      IF entry_point <> NIL THEN
        IF entry_point^.deferred THEN
          entry_point^.deferred := FALSE;
        IFEND;
      IFEND;

      clean_up_residue_diagnostics;

{ Caution: The debug tables and the symbol table must be before
{          the system on the virtual memory image.  This is required because if they
{          follow the rest of the system, they may cause the length of the virtual memory
{          image to be a non integral multiple of 8 bytes which causes the 170 deadstart
{          tape generator to abort.  If they are at the beginning of the virtual memory
{          image, the code modules which follow them will start on an 8 byte boundary
{          which will result in a virtual memory image which also ends on an 8 byte boundary.

      IF v$generate_debug_tables THEN
        clean_up_debug_processing (link_parameters.debug_table_pointers, status);
        IF NOT status.normal THEN
          EXIT /link_virtual_environment/;
        IFEND;
      IFEND;

      current_message_module := link_parameters.message_module_list;
      WHILE current_message_module <> NIL DO
        initialize_message_module_ptr (link_parameters.object_libraries_to_use,
              current_message_module^.module_name, current_message_module^.pointer_name,
              current_message_module^.section_name, status);
        IF NOT status.normal THEN
          EXIT /link_virtual_environment/;
        IFEND;
        current_message_module := current_message_module^.link;
      WHILEND;

      generate_outboard_symbol_table (status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      initialize_symbol_table_ptrs (link_parameters.symbol_table_pointers,
            link_parameters.delete_declaration_matching, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      initialize_recovery_name_table (link_parameters.recovery_name_table_pointer,
            link_parameters.recovery_addresses, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      initialize_heap_pointers (link_parameters.heap_pointers, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      initialize_build_level_vars (link_parameters.build_level, link_parameters.build_level_variables);

      initialize_symbol_table_id (link_parameters.symbol_table_id, link_parameters.symbol_table_id_variable,
            status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      IF pmc$segment_map IN link_parameters.map_options THEN
        print_allocated_segment_map (v$output_segment_list);
        print_common_block_map (v$common_block_table);
      IFEND;

      IF NOT (pmc$no_load_map IN link_parameters.map_options) THEN
        print_starting_procedure (v$starting_entry_point);
      IFEND;

      build_symbol_table (link_parameters.symbol_table, status);
      IF NOT status.normal THEN
        EXIT /link_virtual_environment/;
      IFEND;

      CASE link_parameters.mode OF
      = occ$template =
        build_virtual_memory_image (link_parameters.virtual_image^, status);
      = occ$product =
        build_product_module (link_parameters.virtual_image^, status);
      = occ$mc68000 =
        build_68000_absolute (link_parameters.virtual_image^, status);
      CASEND;

    END /link_virtual_environment/;

    IF v$current_segment_number <= UPPERVALUE (ost$segment) THEN
      ocv$next_available_segment := v$current_segment_number;
    ELSE
      ocv$next_available_segment := occ$initial_segment_number;
    IFEND;

    IF NOT (pmc$no_load_map IN link_parameters.map_options) THEN
      ocp$generate_link_map_text (v$lm_diagnostic_summary);

      ocp$close_link_map (link_map_close_status);
    IFEND;

    IF NOT status.normal THEN
      ocv$vel_scratch_seq := reset_value;
      RETURN;
    IFEND;

    status := v$generate_status;


  PROCEND ocp$execute_the_ve_linker;
?? OLDTITLE ??
MODEND ocm$virtual_environment_linker;
*DECK DECK=OCP$ABORT_IF_ABNORMAL_STATUS EXPAND=FALSE

  PROCEDURE [XREF] ocp$abort_if_abnormal_status (status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=OCP$ABORT_IF_PREMATURE_EOF EXPAND=FALSE

  PROCEDURE [XREF] ocp$abort_if_premature_eof (segment_pointer: ^cell;
        file: clt$file);

?? PUSH (LISTEXT := ON) ??
*copyc clt$file
?? POP ??
*DECK DECK=OCP$ABORT_IF_SEGMENT_OVERFLOW EXPAND=FALSE

  PROCEDURE [XREF] ocp$abort_if_segment_overflow (pointer: ^cell);
*DECK DECK=OCP$ABORT_WITH_STRUCTURE_ERROR EXPAND=FALSE

  PROCEDURE [XREF] ocp$abort_with_structure_error (error: string ( * );
        file: clt$file);

?? PUSH (LISTEXT := ON) ??
*copyc clt$file
?? POP ??
*DECK DECK=OCP$ADD EXPAND=FALSE
  PROCEDURE [XREF] ocp$add ALIAS 'ocpadd' (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*DECK DECK=OCP$ADD_ADDITIONS_TO_NLM_LIST EXPAND=FALSE

  PROCEDURE [XREF] ocp$add_additions_to_nlm_list
    (    after: ^oct$new_library_module_list;
         addition_list: ^oct$nlm_modification_list);

?? PUSH (LISTEXT := ON) ??
*copyc oct$new_library_module_list
*copyc oct$nlm_modification_list
?? POP ??
*DECK DECK=OCP$ADD_AN_NLM EXPAND=FALSE

  PROCEDURE [XREF] ocp$add_an_nlm ALIAS 'ocpaan' (module_before:
    ^oct$new_library_module_list;
    new_nlm: ^oct$new_library_module_list);
*DECK DECK=OCP$ADD_AN_NLM_TO_LIST EXPAND=FALSE

  PROCEDURE [XREF] ocp$add_an_nlm_to_list ALIAS 'ocpantl' (module_before:
    ^oct$new_library_module_list;
    new_nlm: ^oct$new_library_module_list);
*DECK DECK=OCP$ADD_AN_NLM_TO_TREE EXPAND=FALSE

  PROCEDURE [XREF] ocp$add_an_nlm_to_tree ALIAS 'ocpantt' (new_nlm:
    ^oct$new_library_module_list);
*DECK DECK=OCP$ADD_TO_KNOWN_FILES EXPAND=FALSE

  PROCEDURE [XREF] ocp$add_to_known_files
    (    file_name: fst$file_reference;
     VAR known_file_list: oct$known_file_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc oct$known_file_list
*copyc ost$status
?? POP ??
*DECK DECK=OCP$ADD_TO_OBJECT_FILE_LIST EXPAND=FALSE

  PROCEDURE [XREF] ocp$add_to_object_file_list (ofd:
    ^oct$object_file_descriptor;
        object_file_list: ^oct$object_file_descriptor;
    VAR status: ost$status);
*DECK DECK=OCP$ADD_TO_PREDEFINED_SEGMENTS EXPAND=FALSE

  PROCEDURE [XREF] ocp$add_to_predefined_segments (segment_descriptor: ^oct$output_segment_descriptor;
    section_names: ^oct$section_name_list;
    VAR status: ost$status);
*DECK DECK=OCP$ADD_TO_SYMBOL_TABLE_LIST EXPAND=FALSE

  PROCEDURE [XREF] ocp$add_to_symbol_table_list (std:
    ^oct$symbol_table_descriptor;
        symbol_table_list: ^oct$symbol_table_descriptor;
    VAR status: ost$status);
*DECK DECK=OCP$ADJUST_ALLOTTED_SECTIONS EXPAND=FALSE
  PROCEDURE [XREF] ocp$adjust_allotted_sections (mod_dictionary_ocv: ^oct$offset_change_list;
        section_definitions: ^llt$object_text_descriptor;
        int_ol: ^ SEQ ( * ));

*copyc oct$offset_change_list
*copyc llt$object_text_descriptor
*DECK DECK=OCP$ANALYZE_LOAD_MODULE EXPAND=FALSE

  PROCEDURE [XREF] ocp$analyze_load_module (object_library: ^oct$object_library;
       module_item: ^oct$module_item;
       display_options: oct$anaol_display_options);
*DECK DECK=OCP$APPLY_CORRECTOR EXPAND=FALSE
  PROCEDURE [XREF] ocp$apply_corrector (corrector: ^SEQ (*);
        second_inter_ol: ^SEQ (*);
    VAR result: ^SEQ ( * ));

*DECK DECK=OCP$APPLY_MESSAGE_PREDICTOR EXPAND=FALSE
  PROCEDURE [XREF] ocp$apply_message_predictor
    (    p_module_predictor: ^SEQ ( * );
         module_dictionary: ^llt$module_dictionary;
         p_int_ol: ^SEQ ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc llt$module_dictionary
?? POP ??
*DECK DECK=OCP$APPLY_MODULE_PREDICTORS EXPAND=FALSE
  PROCEDURE [XREF] ocp$apply_module_predictors (predictor: ^SEQ ( * );
        first_intermediate_ol: ^SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OCP$APPLY_MOVE_ITEMS EXPAND=FALSE
  PROCEDURE [XREF] ocp$apply_move_items (first_intermediate_ol: ^SEQ ( * );
        move_items: ^oct$move_items;
        number_of_move_items: oct$breaklist_index;
    VAR second_intermediate_ol: ^SEQ ( * ));

*copyc oct$move_items
*copyc oct$breaklist

*DECK DECK=OCP$APPLY_OBJECT_CORRECTION EXPAND=FALSE
  PROCEDURE [XREF] ocp$apply_object_correction
    (    base_file: fst$file_reference;
         correction_file: fst$file_reference;
         target_file { output } : fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=OCP$BIND_MODULE EXPAND=FALSE
  PROCEDURE [XREF] ocp$bind_module ALIAS 'ocpbim' (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*DECK DECK=OCP$BIND_OBJECT_CODE_UTILITY EXPAND=TRUE
PROCEDURE bind_object_code_utilities, bind_object_code_utility, binocu (
  unbound_component, uc: file = $system.ocu.maintenance.unbound_component
  cybil_library, cl: file = $system.cybil.cyf$run_time_library
  math_library, ml: file = $system.common.mlf$library
  use_system_ocu, uso: boolean = false
  bound_product, bp: file = $user.ocu.bound_product
  map, m: file = $user.ocu.maintenance.map
  status)

  create_variable temp_anaol_file kind=string value=$unique
  create_variable temp_buirm_file kind=string value=$unique
  create_variable temp_comol_file kind=string value=$unique
  create_variable temp_con63_file kind=string value=$unique
  create_variable temp_creol_file kind=string value=$unique
  create_variable temp_disol_file kind=string value=$unique
  create_variable temp_disot_file kind=string value=$unique
  create_variable temp_linve_file kind=string value=$unique
  create_variable temp_meape_file kind=string value=$unique
  VAR
    temp_proru_file: file = $unique(:$local)
  VAREND
  create_variable anaol_map_string kind=string value=$unique
  create_variable buirm_map_string kind=string value=$unique
  create_variable comol_map_string kind=string value=$unique
  create_variable con63_map_string kind=string value=$unique
  create_variable creol_map_string kind=string value=$unique
  create_variable disol_map_string kind=string value=$unique
  create_variable disot_map_string kind=string value=$unique
  create_variable linve_map_string kind=string value=$unique
  create_variable meape_map_string kind=string value=$unique
  VAR
    proru_map_file: file = $unique(:$local)
  VAREND
  create_variable creol_line kind=string
  create_variable ignore_status kind=status
  create_variable temp_map_file kind=(string, $max_name) value=$unique
  create_variable binary_path kind=string value=$string($value(unbound_component))
  create_variable temp_lfn_string kind=string

  create_catalog $user.ocu status=ignore_status
  create_catalog_permit $user.ocu g=public am=(read execute) status=ignore_status
  create_catalog $user.ocu.maintenance status=ignore_status

  IF NOT $specified(bound_product) THEN
    temp_lfn_string = $unique
    create_file $user.ocu.bound_product local_file_name=$name(temp_lfn_string)
    detach_file $fname(temp_lfn_string)
  IFEND

  IF NOT $specified(map) THEN
    temp_lfn_string = $unique
    create_file $user.ocu.maintenance.map local_file_name=$name(temp_lfn_string)
    detach_file $fname(temp_lfn_string)
  IFEND

  IF $value(use_system_ocu) THEN
    creol_line = 'CREATE_OBJECT_LIBRARY'
  ELSE
    creol_line = 'execute_task library=($fname(binary_path), $value(cybil_library)) starting_procedure=ocp$_create_object_library'
  IFEND

  put_line ' --   Bind_Object_Code_Utility   --' output=$response


  "Kludge ... must delete aaf$44d_library from library list to prevent loading unbound_product into ring 4"
  set_program_attributes delete_library=$local.aaf$44d_library status=ignore_status

    include_command command=creol_line

    put_line ' --     Collect modules for OCM$ANALYZE_OBJECT_LIBRARY   --' output=$response

    add_module $value(unbound_component) ocm$analyze_object_library
    satisfy_external_references ($value(unbound_component), $value(cybil_library) , $value(math_library))
    generate_library $fname(temp_anaol_file)

    put_line ' --     Collect modules for OCM$REAL_MEMORY_BUILDER   --' output=$response

    add_module $value(unbound_component) ocm$rmb_command_handlers
    satisfy_external_references ($value(unbound_component), $value(cybil_library), $value(math_library))
    generate_library $fname(temp_buirm_file)

    put_line ' --     Collect modules for OCM$COMPARE_OBJECT_LIBRARY   --' output=$response

    add_module $value(unbound_component) ocm$compare_object_library
    satisfy_external_references ($value(unbound_component), $value(cybil_library), $value(math_library))
    generate_library $fname(temp_comol_file)

    put_line ' --     Collect modules for OCM$CONVERT_64_TO_32_BITS   --' output=$response

    add_module $value(unbound_component) ocm$convert_64_to_32_bits
    satisfy_external_references ($value(unbound_component), $value(cybil_library))
    generate_library $fname(temp_con63_file)

    put_line ' --     Collect modules for OCM$OBJECT_LIBRARY_GENERATOR   --' output=$response

    add_module $value(unbound_component) ocm$create_object_library
    satisfy_external_references ($value(unbound_component), $value(cybil_library), $value(math_library))
    generate_library $fname(temp_creol_file)

    put_line ' --     Collect modules for OCM$DISPLAY_OBJECT_LIBRARY   --' output=$response

    add_module $value(unbound_component) ocm$display_object_library
    satisfy_external_references ($value(unbound_component), $value(cybil_library), $value(math_library))
    generate_library $fname(temp_disol_file)

    put_line ' --     Collect modules for OCM$LIST_OBJECT_FILE   --' output=$response

    add_module $value(unbound_component) ocm$list_object_file
    satisfy_external_references ($value(unbound_component), $value(cybil_library), $value(math_library))
    generate_library $fname(temp_disot_file)

    put_line ' --     Collect modules for OCM$PRODUCT_REFERENCE_UTILITY    --' output=$response

    add_module unbound_component m=ocm$product_reference_utility
    satisfy_external_references (unbound_component, cybil_library, math_library)
    generate_library temp_proru_file

    put_line ' --     Collect modules for OCM$VIRTUAL_ENVIRONMENT_LINKER   --' output=$response

    add_module $value(unbound_component) ocm$ve_linker_command_handlers
    satisfy_external_references ($value(unbound_component), $value(cybil_library), $value(math_library))
    generate_library $fname(temp_linve_file)

    put_line ' --     Collect modules for PMM$MEASURE_PROGRAM_EXECUTION   --' output=$response

    add_module $value(unbound_component) pmm$mpe_command_handlers
    satisfy_external_references ($value(unbound_component), $value(cybil_library), $value(math_library))
    generate_library $fname(temp_meape_file)

    put_line ' --     Bind OCM$ANALYZE_OBJECT_LIBRARY   --' output=$response

    create_module ocm$analyze_object_library  component=$fname(temp_anaol_file) starting_procedure=ocp$_analyze_object_library..
           ibsm=true preset_value=zero output=$fname(anaol_map_string)
    change_module_attribute ocm$analyze_object_library omit_non_retained_entry_points=on
    change_module_attribute ocm$analyze_object_library omit_library=cyf$run_time_library
    add_copyright ocm$analyze_object_library

    put_line ' --     Bind OCM$REAL_MEMORY_BUILDER   --' output=$response

    create_module ocm$real_memory_builder component=$fname(temp_buirm_file) starting_procedure=ocp$build_real_memory ..
           ibsm=true preset_value=zero output=$fname(buirm_map_string)
    change_module_attribute ocm$real_memory_builder omit_non_retained_entry_points=on
    change_module_attribute ocm$real_memory_builder omit_library=cyf$run_time_library
    add_copyright ocm$real_memory_builder

    put_line ' --     Bind OCM$COMPARE_OBJECT_LIBRARY   --' output=$response

    create_module ocm$compare_object_library component=$fname(temp_comol_file) starting_procedure=ocp$compare_object_library ..
          ibsm=true preset_value=zero output=$fname(comol_map_string)
    change_module_attribute ocm$compare_object_library omit_non_retained_entry_points=on
    change_module_attribute ocm$compare_object_library omit_library=cyf$run_time_library
    add_copyright ocm$compare_object_library

    put_line ' --     Bind OCM$CONVERT_64_TO_32_BITS   --' output=$response

    create_module ocm$convert_64_to_32_bits component=$fname(temp_con63_file) starting_procedure=ocp$convert_64_to_32_bits ..
          ibsm=true preset_value=zero output=$fname(con63_map_string)
    change_module_attribute ocm$convert_64_to_32_bits omit_non_retained_entry_points=on
    change_module_attribute ocm$convert_64_to_32_bits omit_library=cyf$run_time_library
    add_copyright ocm$convert_64_to_32_bits

    put_line ' --     Bind OCM$OBJECT_LIBRARY_GENERATOR   --' output=$response

    create_module ocm$object_library_generator component=$fname(temp_creol_file) starting_procedure=ocp$_create_object_library ..
          ibsm=true preset_value=zero output=$fname(creol_map_string)
    change_module_attribute ocm$object_library_generator omit_non_retained_entry_points=on
    change_module_attribute ocm$object_library_generator omit_library=(cyf$run_time_library mlf$library)
    add_copyright ocm$object_library_generator

    add_module $value(unbound_component) ocp$create_linked_module
    add_copyright ocp$create_linked_module

    put_line ' --     Bind OCM$DISPLAY_OBJECT_LIBRARY   --' output=$response

    create_module ocm$display_object_library component=$fname(temp_disol_file) starting_procedure=ocp$_display_object_library ..
          ibsm=true preset_value=zero output=$fname(disol_map_string)
    change_module_attribute ocm$display_object_library omit_non_retained_entry_points=on
    change_module_attribute ocm$display_object_library omit_library=cyf$run_time_library
    add_copyright ocm$display_object_library

    put_line ' --     Bind OCM$LIST_OBJECT_FILE   --' output=$response

    create_module ocm$list_object_file component=$fname(temp_disot_file) starting_procedure=ocp$list_object_file ..
          ibsm=true preset_value=zero output=$fname(disot_map_string)
    change_module_attribute ocm$list_object_file omit_non_retained_entry_points=on
    change_module_attribute ocm$list_object_file omit_library=cyf$run_time_library
    add_copyright ocm$list_object_file

    put_line ' --     Bind OCM$PRODUCT_REFERENCE_UTILITY   --' output=$response

    create_module ocm$product_reference_utility component=temp_proru_file starting_procedure=ocp$_product_reference_utility ..
          ibsm=true preset_value=zero output=proru_map_file
    change_module_attribute ocm$product_reference_utility omit_non_retained_entry_points=on
    change_module_attribute ocm$product_reference_utility omit_library=cyf$run_time_library
    add_copyright ocm$product_reference_utility

    put_line ' --     Bind OCM$VIRTUAL_ENVIRONMENT_LINKER   --' output=$response

    create_module ocm$virtual_environment_linker component=$fname(temp_linve_file) starting_procedure=ocp$_link_virtual_environment ..
          ibsm=true preset_value=zero output=$fname(linve_map_string)
    change_module_attribute ocm$virtual_environment_linker omit_non_retained_entry_points=on
    change_module_attribute ocm$virtual_environment_linker omit_library=cyf$run_time_library
    add_copyright ocm$virtual_environment_linker

    put_line ' --     Bind PMM$MEASURE_PROGRAM_EXECUTION   --' output=$response

    create_module pmm$measure_program_execution component=$fname(temp_meape_file) starting_procedure=pmp$measure_program_execution ..
          ibsm=true preset_value=zero output=$fname(meape_map_string)
    change_module_attribute pmm$measure_program_execution omit_non_retained_entry_points=on
    change_module_attribute pmm$measure_program_execution omit_library=cyf$run_time_library
    add_copyright pmm$measure_program_execution

    put_line ' --     Generate bound product   --' output=$response

    generate_library $value(bound_product)

  QUIT


  "Kludge ... restore aaf$44d_library to library list"
  set_program_attributes add_library=$local.aaf$44d_library status=ignore_status

  put_line ' --     Perform clean up   --' output=$response

  detach_file $fname(temp_anaol_file) status=ignore_status
  detach_file $fname(temp_buirm_file) status=ignore_status
  detach_file $fname(temp_comol_file) status=ignore_status
  detach_file $fname(temp_con63_file) status=ignore_status
  detach_file $fname(temp_creol_file) status=ignore_status
  detach_file $fname(temp_disol_file) status=ignore_status
  detach_file $fname(temp_disot_file) status=ignore_status
  detach_file $fname(temp_linve_file) status=ignore_status
  detach_file $fname(temp_meape_file) status=ignore_status
  detach_file temp_proru_file status=ignore_status

  copy_file input=$fname(anaol_map_string) output=$fname(temp_map_file//'.$eoi')
  copy_file input=$fname(buirm_map_string) output=$fname(temp_map_file//'.$eoi')
  copy_file input=$fname(comol_map_string) output=$fname(temp_map_file//'.$eoi')
  copy_file input=$fname(con63_map_string) output=$fname(temp_map_file//'.$eoi')
  copy_file input=$fname(creol_map_string) output=$fname(temp_map_file//'.$eoi')
  copy_file input=$fname(disol_map_string) output=$fname(temp_map_file//'.$eoi')
  copy_file input=$fname(disot_map_string) output=$fname(temp_map_file//'.$eoi')
  copy_file input=$fname(linve_map_string) output=$fname(temp_map_file//'.$eoi')
  copy_file input=$fname(meape_map_string) output=$fname(temp_map_file//'.$eoi')
  copy_file input=proru_map_file output=$fname(temp_map_file//'.$eoi')

  detach_file $fname(temp_map_file) status=ignore_status
  detach_file $fname(anaol_map_string) status=ignore_status
  detach_file $fname(buirm_map_string) status=ignore_status
  detach_file $fname(comol_map_string) status=ignore_status
  detach_file $fname(con63_map_string) status=ignore_status
  detach_file $fname(creol_map_string) status=ignore_status
  detach_file $fname(disol_map_string) status=ignore_status
  detach_file $fname(disot_map_string) status=ignore_status
  detach_file $fname(linve_map_string) status=ignore_status
  detach_file $fname(meape_map_string) status=ignore_status
  detach_file proru_map_file status=ignore_status

  IF use_system_ocu THEN
    display_object_library library=$value(bound_product) display_options=all output=$fname(temp_map_file//'.$eoi')
  ELSE
    execute_task library=$fname(binary_path) starting_procedure=ocp$_display_object_library ..
          parameter='library=$value(bound_product) display_options=all output=$fname(temp_map_file//''.$eoi'')'
  IFEND

  copy_file input=$fname(temp_map_file) output=$value(map)

  delete_catalog $user.ocu.maintenance status=ignore_status
  delete_catalog $user.ocu  status=ignore_status

  put_line ' --   END bind_object_code_utility   --' output=$response

PROCEND bind_object_code_utilities
*DECK DECK=OCP$BUILD_CODE_SEC_DIRECTORY EXPAND=FALSE
  PROCEDURE [XREF] ocp$build_code_sec_directory (object_library: ^ SEQ (*);
    VAR code_section_directory: ^oct$code_section_directory;
    VAR module_code_sections: ^oct$module_code_sections);

?? PUSH (LISTEXT := ON) ??
*copyc oct$code_section_directory
?? POP ??


*DECK DECK=OCP$BUILD_CORRECTOR EXPAND=FALSE
  PROCEDURE [XREF] ocp$build_corrector
    (    old_breaklist: ^oct$breaklist;
         new_breaklist: ^oct$breaklist;
         second_inter_ol: ^SEQ ( * );
         new_ol: ^SEQ ( * );
         length_of_old_breaklist: oct$breaklist_length;
         length_of_new_breaklist: oct$breaklist_length;
     VAR corrector: ^SEQ ( * );
     VAR status: ost$status);

*copyc ost$status
*copyc oct$breaklist


*DECK DECK=OCP$BUILD_FILE_DIRECTORY EXPAND=FALSE

  PROCEDURE [XREF] ocp$build_file_directory
    (VAR sequence: ^SEQ ( * );
     VAR file_descriptor: ^oct$open_file_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oct$open_file_list
*copyc ost$status
?? POP ??
*DECK DECK=OCP$BUILD_FILE_DIR_FROM_TEMP EXPAND=FALSE

  PROCEDURE [XREF] ocp$build_file_dir_from_temp
    (VAR sequence { input, output } : ^SEQ ( * );
     VAR file_descriptor: ^oct$open_file_list);

?? PUSH (LISTEXT := ON) ??
*copyc oct$open_file_list
*copyc ost$status
?? POP ??
*DECK DECK=OCP$BUILD_FIRST_INTERMEDIATE_OL EXPAND=FALSE
  PROCEDURE [XREF] ocp$build_first_intermediate_ol (predictor: ^SEQ ( * );
        old_ol: ^SEQ ( * );
    VAR first_intermediate_ol: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??


*DECK DECK=OCP$BUILD_LIBRARY_DIRECTORY EXPAND=FALSE

  PROCEDURE [XREF] ocp$build_library_directory
    (VAR sequence: ^SEQ ( * );
     VAR file_descriptor: ^oct$open_file_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oct$open_file_list
*copyc ost$status
?? POP ??
*DECK DECK=OCP$BUILD_MODULE_ATTRIBUTES EXPAND=FALSE
  PROCEDURE [XREF] ocp$build_module_attributes
    (    attribute_keywords: oct$attribute_keyword_set;
     VAR module_description: {READ} oct$module_description;
         changed_info: ^oct$changed_info;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$work_area
*copyc clt$data_value
*copyc oct$attribute_keyword_set
*copyc oct$changed_info
*copyc oct$module_description
*copyc ost$status
?? POP ??

*DECK DECK=OCP$BUILD_MODULE_DIRECTORY EXPAND=FALSE

  PROCEDURE [XREF] ocp$build_module_directory ALIAS 'ocpbmd' (file_descriptor:
    ^oct$open_file_list;
    VAR status: ost$status);
*DECK DECK=OCP$BUILD_PANEL_DIRECTORY EXPAND=FALSE

   PROCEDURE [XREF] ocp$build_panel_directory (VAR sequence: ^SEQ( * );
     VAR file_descriptor: ^oct$open_file_list;
     VAR status: ost$status);
*DECK DECK=OCP$BUILD_SCL_DIRECTORY EXPAND=FALSE

  PROCEDURE [XREF] ocp$build_scl_directory (file_name: amt$local_file_name;
    file_descriptor: ^oct$open_file_list;
    VAR status: ost$status);
*DECK DECK=OCP$BUILD_SECOND_INTER_OL EXPAND=FALSE

  PROCEDURE [XREF] ocp$build_second_inter_ol
    (    first_intermediate_ol: ^SEQ ( * );
         new_breaklist: ^oct$breaklist;
         length_of_new_breaklist: oct$breaklist_length;
     VAR old_breaklist: ^oct$breaklist;
     VAR length_of_old_breaklist: oct$breaklist_length;
     VAR second_inter_ol: ^SEQ ( * );
     VAR scratch_segment: ^SEQ ( * );
     VAR move_items: ^oct$move_items;
     VAR number_of_move_items: oct$breaklist_index);

?? PUSH (LISTEXT := ON) ??
*copyc oct$breaklist
*copyc oct$move_items
?? POP ??
*DECK DECK=OCP$BUILD_SECTION_DIRECTORY EXPAND=FALSE
PROCEDURE [XREF] ocp$build_section_directory (module_predictor: ^oct$module_predictor;
        module_header: ^llt$load_module_header;
        object_library: ^SEQ ( * );
    VAR section_directory: ^oct$section_directory);

?? PUSH (LISTEXT := ON) ??
*copyc oct$single_module_predictor_hdr
*copyc oct$section_directory
*copyc llt$load_module_header
?? POP ??
*DECK DECK=OCP$CHANGE EXPAND=FALSE
  PROCEDURE [XREF] ocp$change alias 'ocpcha' (
    parameter_list: clt$parameter_list;
    VAR status: ost$status);

*DECK DECK=OCP$CHECKSUM EXPAND=FALSE
  FUNCTION [XREF] ocp$checksum (sequence: ^SEQ (*)): integer;

*DECK DECK=OCP$CLOSE_ALL_OPEN_FILES EXPAND=FALSE

  PROCEDURE [XREF] ocp$close_all_open_files ALIAS 'ocpcaof' (VAR
    open_file_list: oct$open_file_list);
*DECK DECK=OCP$CLOSE_LINKER_DEBUG_TABLE EXPAND=FALSE

  PROCEDURE [XREF] ocp$close_linker_debug_table
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oce$ve_linker_exceptions
*copyc ost$status
?? POP ??

*DECK DECK=OCP$CLOSE_LINKER_OBJECT_FILES EXPAND=FALSE

  PROCEDURE [XREF] ocp$close_linker_object_files (ofd:
    ^oct$object_file_descriptor);
*DECK DECK=OCP$CLOSE_LINKER_SYMBOL_TABLES EXPAND=FALSE

  PROCEDURE [XREF] ocp$close_linker_symbol_tables (std:
    ^oct$symbol_table_descriptor);
*DECK DECK=OCP$CLOSE_LINK_MAP EXPAND=FALSE

  PROCEDURE [XREF] ocp$close_link_map (VAR status: ost$status);
*DECK DECK=OCP$CLOSE_OUTPUT_FILE EXPAND=FALSE
  PROCEDURE [XREF] ocp$close_output_file (VAR status: ost$status);
*DECK DECK=OCP$CLOSE_PREDEFINED_SEGMENTS EXPAND=FALSE

  PROCEDURE [XREF] ocp$close_predefined_segments (sd:
    ^oct$output_segment_descriptor);
*DECK DECK=OCP$COMBINE EXPAND=FALSE
  PROCEDURE [XREF] ocp$combine alias 'ocpcom' (
    parameter_list: clt$parameter_list;
    VAR status: ost$status);

*DECK DECK=OCP$CONSTRUCT_BREAKLIST EXPAND=FALSE

  PROCEDURE [XREF] ocp$construct_breaklist
    (    object_library: ^SEQ ( * );
         module_directory: ^oct$module_directory;
         original_object_library: boolean;
         int_ol: ^SEQ ( * );
     VAR breaklist: ^oct$breaklist;
     VAR breaks: ^SEQ ( * );
     VAR number_of_breaklist_items: oct$breaklist_length;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oct$breaklist
*copyc oct$module_directory
*copyc ost$status
?? POP ??
*DECK DECK=OCP$CONVERT_INFORMATION_ELEMENT EXPAND=FALSE

  PROCEDURE [INLINE] ocp$convert_information_element (old_info_element_header:
      ^llt$info_element_header;
    VAR new_info_element_header: llt$info_element_header);

?? PUSH (LISTEXT := ON) ??

    VAR
      info_element_hdr: ^llt$info_element_hdr,
      info_element_header_1_0: ^llt$info_element_header_1_0;


    new_info_element_header.version := llc$info_element_version;

    IF (old_info_element_header^.version = llc$info_element_version_1_0) THEN
      info_element_header_1_0 := #LOC (old_info_element_header^);
      new_info_element_header.relocation_ptr := info_element_header_1_0^.relocation_ptr;
      new_info_element_header.number_of_rel_items := info_element_header_1_0^.number_of_rel_items;
      new_info_element_header.component_ptr := info_element_header_1_0^.component_ptr;
      new_info_element_header.number_of_components := info_element_header_1_0^.number_of_components;
      new_info_element_header.binding_template_ptr := info_element_header_1_0^.binding_template_ptr;
      new_info_element_header.number_of_template_items := info_element_header_1_0^.number_of_template_items;
      new_info_element_header.section_maps := info_element_header_1_0^.section_maps;
      new_info_element_header.number_of_section_maps := info_element_header_1_0^.number_of_section_maps;

    ELSE { Original version }
      info_element_hdr := #LOC (old_info_element_header^);
      new_info_element_header.relocation_ptr := info_element_hdr^.relocation_ptr;
      new_info_element_header.number_of_rel_items := info_element_hdr^.number_of_rel_items;
      new_info_element_header.component_ptr := info_element_hdr^.component_ptr;
      new_info_element_header.number_of_components := info_element_hdr^.number_of_components;
      new_info_element_header.binding_template_ptr := info_element_hdr^.binding_template_ptr;
      new_info_element_header.number_of_template_items := info_element_hdr^.number_of_template_items;
      new_info_element_header.number_of_section_maps := 0;
    IFEND;


  PROCEND ocp$convert_information_element;

*copyc llt$information_element
?? POP ??

*DECK DECK=OCP$COPY EXPAND=FALSE
  PROCEDURE [XREF] ocp$copy (old_ol: ^SEQ ( * );
    VAR new_ol: ^SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=OCP$CRACK_DISPLAY_TOGGLE_PARAMS EXPAND=FALSE

  PROCEDURE [XREF] ocp$crack_display_toggle_params (keyword:
    string ( * );
    VAR toggles: oct$display_toggles;
    VAR status: ost$status);
*DECK DECK=OCP$CRACK_PROGRAM_NAME EXPAND=FALSE

  PROCEDURE [XREF] ocp$crack_program_name (keyword: string (*);
        parameter: clt$value;
    VAR program_name: pmt$program_name;
    VAR status: ost$status);

*DECK DECK=OCP$CREATE_AN_NLM EXPAND=FALSE

  PROCEDURE [XREF] ocp$create_an_nlm
    (    module_description: ^oct$module_description;
     VAR nlm: ^oct$new_library_module_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oct$module_description
*copyc oct$new_library_module_list
*copyc ost$status
?? POP ??
*DECK DECK=OCP$CREATE_MODULE EXPAND=FALSE
  PROCEDURE [XREF] ocp$create_module alias 'ocpcrm' (
    parameter_list: clt$parameter_list;
    VAR status: ost$status);

*DECK DECK=OCP$CREATE_TRANSIENT_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] ocp$create_transient_segment (kind: amt$pointer_kind;
    VAR segment: amt$segment_pointer;
    VAR status: ost$status);

*copyc AMT$SEGMENT_POINTER
*copyc OST$STATUS
*DECK DECK=OCP$DEFINE_LINKER_DEBUG_TABLE EXPAND=FALSE

  PROCEDURE [XREF] ocp$define_linker_debug_table
    (    sequence_pointer: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oce$ve_linker_exceptions
*copyc ost$status
?? POP ??

*DECK DECK=OCP$DEFINE_PROGRAM EXPAND=FALSE
  PROCEDURE [XREF] ocp$define_program (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*DECK DECK=OCP$DELETE EXPAND=FALSE
  PROCEDURE [XREF] ocp$delete alias 'ocpdel' (
    parameter_list: clt$parameter_list;
    VAR status: ost$status);

*DECK DECK=OCP$DELETE_AN_NLM EXPAND=FALSE

  PROCEDURE [XREF] ocp$delete_an_nlm ALIAS 'ocpdan' (nlm:
    ^oct$new_library_module_list);
*DECK DECK=OCP$DELETE_LIST_FROM_NLM_LIST EXPAND=FALSE
  PROCEDURE [XREF] ocp$delete_list_from_nlm_list ALIAS 'ocpdlnl' (deletion_list: ^oct$nlm_modification_list);


*DECK DECK=OCP$DISPLAY_LIBRARY EXPAND=FALSE
  PROCEDURE [XREF] ocp$display_library alias 'ocpdlb' (
    parameter_list: clt$parameter_list;
    VAR status: ost$status);

*DECK DECK=OCP$DISPLAY_LIBRARY_ANALYSIS EXPAND=FALSE

  PROCEDURE [XREF] ocp$display_library_analysis (object_library: ^oct$object_library;
        display_options: oct$anaol_display_options;
        output: clt$file;
    VAR status: ost$status);
*DECK DECK=OCP$DISPLAY_MODULE EXPAND=FALSE
 PROCEDURE [XREF] ocp$display_module (display_toggles: oct$display_toggles;
    VAR module_description: oct$module_description;
        changed_info: ^oct$changed_info;
    VAR status: ost$status);
*DECK DECK=OCP$DISPLAY_MODULE_ANALYSIS EXPAND=FALSE

  PROCEDURE [XREF] ocp$display_module_analysis (object_library: ^oct$object_library;
        display_options: oct$anaol_display_options;
        output: clt$file;
    VAR status: ost$status);
*DECK DECK=OCP$DISPLAY_PERFORMANCE_ANAL EXPAND=FALSE

  PROCEDURE [XREF] ocp$display_performance_anal (object_library: ^oct$object_library;
        performance_problems: oct$anaol_performance_problems;
        display_options: oct$anaol_performance_options;
        output: clt$file;
    VAR status: ost$status);
*DECK DECK=OCP$DISPLAY_SECTION_USAGE EXPAND=FALSE

  PROCEDURE [XREF] ocp$display_section_usage (object_library: ^oct$object_library;
        section_kinds: oct$section_kinds;
        access_attributes: llt$section_access_attributes;
        section_name: pmt$program_name;
        output: clt$file;
    VAR status: ost$status);
*DECK DECK=OCP$DTB_CLOSE_DEBUG_TABLE EXPAND=FALSE

  PROCEDURE [XREF] ocp$dtb_close_debug_table (VAR status: ost$status);
*DECK DECK=OCP$DTB_DEFINE_ENTRY_POINT EXPAND=FALSE

  PROCEDURE [XREF] ocp$dtb_define_entry_point (name: pmt$program_name;
        pva: ost$pva;
    VAR status: ost$status);

*DECK DECK=OCP$DTB_DEFINE_MODULE EXPAND=FALSE

  PROCEDURE [XREF] ocp$dtb_define_module (identification: ^llt$identification;
    VAR status: ost$status);
*DECK DECK=OCP$DTB_DEFINE_SECTION EXPAND=FALSE

  PROCEDURE [XREF] ocp$dtb_define_section (section_item: pmt$section_item;
    VAR status: ost$status);
*DECK DECK=OCP$DTB_GET_DEBUG_TABLE EXPAND=FALSE

  PROCEDURE [XREF] ocp$dtb_get_debug_table (VAR debug_table: ^SEQ ( * );
    VAR status: ost$status);


*DECK DECK=OCP$DTB_INITIALIZE_DEBUG_TABLES EXPAND=FALSE

  PROCEDURE [XREF] 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);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc pmt$os_name
?? POP ??
*DECK DECK=OCP$DTB_REDEFINE_MODULE EXPAND=FALSE

  PROCEDURE [XREF] ocp$dtb_redefine_module (info_element_header: ^llt$info_element_header;
    VAR object_library: ^SEQ ( * );
    VAR status: ost$status);

*DECK DECK=OCP$DTB_TERMINATE_MODULE EXPAND=FALSE

  PROCEDURE [XREF] ocp$dtb_terminate_module (VAR status: ost$status);
*DECK DECK=OCP$DUPLICATE_FILE EXPAND=FALSE

  FUNCTION [XREF] ocp$duplicate_file
    (    file_name: fst$file_reference;
         known_file_list: oct$known_file_list): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc oct$known_file_list
?? POP ??

*DECK DECK=OCP$DUPLICATE_SECTION_NAME EXPAND=FALSE

  FUNCTION [XREF] ocp$duplicate_section_name (section_name: pmt$program_name): boolean;
*DECK DECK=OCP$DUPLICATE_SEGMENT_NUMBER EXPAND=FALSE

  FUNCTION [XREF] ocp$duplicate_segment_number (segment_number: oct$segment): boolean;
*DECK DECK=OCP$END EXPAND=FALSE
  PROCEDURE [XREF] ocp$end ALIAS 'ocpend' (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*DECK DECK=OCP$EXECUTE_THE_VE_LINKER EXPAND=FALSE

  PROCEDURE [XREF] ocp$execute_the_ve_linker (link_parameters: oct$link_parameters;
    VAR status: ost$status);
*DECK DECK=OCP$EXTRACT_NLM_FROM_LIST EXPAND=FALSE
  PROCEDURE [XREF] ocp$extract_nlm_from_list ALIAS 'ocpenfl' (nlm: ^oct$new_library_module_list);


*DECK DECK=OCP$EXTRACT_NLM_FROM_TREE EXPAND=FALSE
  PROCEDURE [XREF] ocp$extract_nlm_from_tree ALIAS 'ocpenft' (nlm: ^oct$new_library_module_list);


*DECK DECK=OCP$FIND_DEBUG_ADDRESS EXPAND=FALSE

  PROCEDURE [XREF] ocp$find_debug_address
    (    segment: ost$segment;
         offset: ost$segment_offset;
     VAR found: boolean;
     VAR module_name: pmt$program_name;
     VAR section_name: pmt$program_name;
     VAR offset_in_section: ost$segment_offset;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oce$ve_linker_exceptions
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$program_name
?? POP ??

*DECK DECK=OCP$FIND_DEBUG_ADDRESS_IN_CODE EXPAND=FALSE

  PROCEDURE [XREF] ocp$find_debug_address_in_code
    (    segment: ost$segment;
         offset: ost$segment_offset;
     VAR found: boolean;
     VAR module_name: pmt$program_name;
     VAR section_name: pmt$program_name;
     VAR offset_in_section: ost$segment_offset;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oce$ve_linker_exceptions
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$program_name
?? POP ??

*DECK DECK=OCP$FIND_DEBUG_ENTRY_POINT EXPAND=FALSE

  PROCEDURE [XREF] ocp$find_debug_entry_point
    (    entry_point: pmt$program_name;
     VAR found: boolean;
     VAR module_name: pmt$program_name;
     VAR segment: ost$segment;
     VAR offset: ost$segment_offset;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oce$ve_linker_exceptions
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$program_name
?? POP ??

*DECK DECK=OCP$FIND_DEBUG_ENTRY_PT_LENGTH EXPAND=FALSE

  PROCEDURE [XREF] ocp$find_debug_entry_pt_length
    (    entry_point: pmt$program_name;
     VAR entry_point_found: boolean;
     VAR module_name: pmt$program_name;
     VAR segment: ost$segment;
     VAR offset: ost$segment_offset;
     VAR length: ost$segment_length;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oce$ve_linker_exceptions
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=OCP$FIND_DEBUG_MODULE_ITEM EXPAND=FALSE

  PROCEDURE [XREF] ocp$find_debug_module_item
    (    name: pmt$program_name;
         occurrence: pmt$number_of_debug_items;
     VAR found: boolean;
     VAR module_item: ^pmt$module_item;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oce$ve_linker_exceptions
*copyc ost$status
*copyc pmt$program_name
*copyc pmt$linker_debug_table_header
?? POP ??

*DECK DECK=OCP$FREE_NLM_MODIFICATION_LIST EXPAND=FALSE

  PROCEDURE [XREF] ocp$free_nlm_modification_list
    (    modification_list: ^oct$nlm_modification_list);


?? PUSH (LISTEXT := ON) ??
*copyc oct$nlm_modification_list
?? POP ??
*DECK DECK=OCP$FREE_NLM_REPLACEMENT_LIST EXPAND=FALSE

  PROCEDURE [XREF] ocp$free_nlm_replacement_list
    (    replacement_list: ^oct$nlm_replacement_list);


?? PUSH (LISTEXT := ON) ??
*copyc oct$nlm_replacement_list
?? POP ??
*DECK DECK=OCP$GENERATE EXPAND=FALSE
  PROCEDURE [XREF] ocp$generate alias 'ocpgen' (
    parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copyc OST$STATUS
*copyc CLT$NAME
*DECK DECK=OCP$GENERATE_LINK_MAP_TEXT EXPAND=FALSE

  PROCEDURE [XREF] ocp$generate_link_map_text (link_map_data: lot$load_map_data);
?? PUSH (LISTEXT := ON) ??
*copyc LOT$LOAD_MAP_DATA
?? POP ??
*DECK DECK=OCP$GENERATE_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] ocp$generate_message (VAR status: ost$status);

*DECK DECK=OCP$GENERATE_METAPATCH EXPAND=FALSE
  PROCEDURE [XREF] ocp$generate_metapatch (old_object_library: amt$local_file_name;
        new_object_library: amt$local_file_name;
    VAR corrector: ^SEQ ( * );
    VAR size: oct$corrector_size;
    VAR status: ost$status);

*copyc amt$local_file_name
*copyc oct$corrector
*copyc ost$status

*DECK DECK=OCP$GENERATE_OBJECT_CORRECTION EXPAND=FALSE

  PROCEDURE [XREF] ocp$generate_object_correction
    (    old_file_name: fst$file_reference;
         new_file_name: fst$file_reference;
         calculate_checksums: boolean;
         old_file_checksum: rat$checksum;
         new_file_checksum: rat$checksum;
     VAR metapatch: ^SEQ ( * );
     VAR size: oct$corrector_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc oct$corrector
*copyc ost$status
*copyc rat$subproduct_info_types
?? POP ??
*DECK DECK=OCP$GENERATE_OL_PREDICTOR EXPAND=FALSE
  PROCEDURE [XREF] ocp$generate_ol_predictor
    (    old_file_name: fst$file_reference;
         new_file_name: fst$file_reference;
    VAR old_ol: amt$segment_pointer;
    VAR new_ol: amt$segment_pointer;
    VAR predictor: amt$segment_pointer;
    VAR module_directory: ^oct$module_directory;
    VAR status: ost$status);

*copyc ost$status
*copyc amt$segment_pointer
*copyc oct$module_directory
*copyc fst$file_reference
*DECK DECK=OCP$GENERATE_REAL_MEMORY EXPAND=FALSE

  PROCEDURE [XREF] ocp$generate_real_memory (build_options: oct$build_options;
        real_memory_image: amt$local_file_name;
    VAR status: ost$status);
*DECK DECK=OCP$GET_BINDING_SECTION_REFS EXPAND=FALSE

  PROCEDURE [XREF] ocp$get_binding_section_refs
    (    object_library: ^oct$object_library;
     VAR count: 0 .. llc$max_binding_items);

?? PUSH (LISTEXT := ON) ??
*copyc llt$information_element
*copyc oct$anaol_types
?? POP ??
*DECK DECK=OCP$GET_DEBUG_TABLE_HEADER EXPAND=FALSE

  PROCEDURE [XREF] ocp$get_debug_table_header
    (VAR debug_table_header: ^pmt$linker_debug_table_header;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oce$ve_linker_exceptions
*copyc ost$status
*copyc pmt$linker_debug_table_header
?? POP ??

*DECK DECK=OCP$GET_MODULE_FROM_WFL EXPAND=FALSE

  PROCEDURE [XREF] ocp$get_module_from_wfl
    (    working_file_list: oct$working_file_list;
     VAR module_name: pmt$program_name;
     VAR file_descriptor: ^oct$open_file_list);


?? PUSH (LISTEXT := ON) ??
*copyc oct$working_file_list
*copyc pmt$program_name
?? POP ??
*DECK DECK=OCP$GET_PLACEMENT_OF_ADDITIONS EXPAND=FALSE

  PROCEDURE [XREF] ocp$get_placement_of_additions (placement_keyword: string ( * );
    location_keyword: string ( * );
    VAR after: ^oct$new_library_module_list;
    VAR status: ost$status);


*DECK DECK=OCP$GET_RING_BRACKETS EXPAND=FALSE
  PROCEDURE [XREF] ocp$get_ring_brackets (file_name: amt$local_file_name;
    VAR ring_brackets: amt$ring_attributes;
    VAR status: ost$status);
*DECK DECK=OCP$HEXREP EXPAND=FALSE

  PROCEDURE [XREF] ocp$hexrep (VAR strng: string ( * );
    VAR l: integer;
        intger: integer);

*DECK DECK=OCP$INITIALIZE_LINK_MAP EXPAND=FALSE

  PROCEDURE [XREF] ocp$initialize_link_map
    (    map_file: fst$file_reference;
         build_level: pmt$os_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc pmt$os_name
*copyc ost$status
?? POP ??
*DECK DECK=OCP$INITIALIZE_OBJECT_LIBRARY EXPAND=FALSE

  PROCEDURE [XREF] ocp$initialize_object_library (file_structure_is_library: boolean;
        object_library: ^oct$object_library);
*DECK DECK=OCP$INITIALIZE_OC_ENVIRONMENT EXPAND=FALSE

  PROCEDURE [XREF] ocp$initialize_oc_environment (VAR status: ost$status);
*DECK DECK=OCP$INITIALIZE_OLG_WORKING_HEAP EXPAND=FALSE
  PROCEDURE [XREF] ocp$initialize_olg_working_heap;
*DECK DECK=OCP$INTERNAL_ERROR EXPAND=FALSE

  PROCEDURE [XREF] ocp$internal_error (error: string (*));

*DECK DECK=OCP$MAKE_ACCESS_ATTRIBUTES_VALU EXPAND=FALSE
  PROCEDURE [XREF] ocp$make_access_attributes_valu
    (    access_attributes: llt$section_access_attributes;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??
*copyc llt$section_access_attributes
*copyc clt$work_area
*copyc clt$data_value
?? POP ??
*DECK DECK=OCP$MAKE_ACCESS_CONTROL_VALUE EXPAND=FALSE
  PROCEDURE [XREF] ocp$make_access_control_value
    (    control: ost$segment_access_control;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??
*copyc ost$segment_access_control
*copyc clt$work_area
*copyc clt$data_value
?? POP ??
*DECK DECK=OCP$MAKE_DATE_TIME_VALUE EXPAND=FALSE
  PROCEDURE [XREF] ocp$make_date_time_value
    (    date: ost$date;
         time: ost$time;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date
*copyc ost$time
*copyc clt$work_area
*copyc clt$data_value
?? POP ??
*DECK DECK=OCP$MAKE_FILE_VALUE EXPAND=FALSE
  PROCEDURE [XREF] ocp$make_file_value
    (    file_name: string ( * );
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??
*copyc clt$work_area
*copyc clt$data_value
?? POP ??
*DECK DECK=OCP$MAKE_LIBRARY_MEMBER_KIND_VA EXPAND=FALSE
  PROCEDURE [XREF] ocp$make_library_member_kind_va
    (    library_member_kind: llt$library_member_kind;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??
*copyc llt$library_member_header
*copyc clt$work_area
*copyc clt$data_value
?? POP ??
*DECK DECK=OCP$MAKE_MODULE_GENERATOR_VALUE EXPAND=FALSE
  PROCEDURE [XREF] ocp$make_module_generator_value
    (    module_generator: llt$module_generator;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??
*copyc llt$module_generator
*copyc clt$work_area
*copyc clt$data_value
?? POP ??
*DECK DECK=OCP$MAKE_MODULE_KIND_VALUE EXPAND=FALSE
  PROCEDURE [XREF] ocp$make_module_kind_value
    (    kind: llt$module_kind;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??
*copyc llt$module_kind
*copyc clt$work_area
*copyc clt$data_value
?? POP ??
*DECK DECK=OCP$MAKE_SECTION_KIND_VALUE EXPAND=FALSE
  PROCEDURE [XREF] ocp$make_section_kind_value
    (    kind: llt$section_kind;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value);

?? PUSH (LISTEXT := ON) ??
*copyc llt$section_kind
*copyc clt$work_area
*copyc clt$data_value
?? POP ??
*DECK DECK=OCP$NEW_GLOBAL_OFFSET EXPAND=FALSE
  FUNCTION [XREF] ocp$new_global_offset (old_offset: llt$section_address_range;
        section_offset_cv: ^oct$offset_change_list):
            llt$section_address_range;

?? PUSH (LISTEXT := ON) ??
*copyc llt$section_address
*copyc oct$offset_change_list
?? POP ??

*DECK DECK=OCP$NEW_OFFSET EXPAND=FALSE
  FUNCTION [XREF] ocp$new_offset (old_offset: llt$section_address_range;
        section_offset_cv: ^oct$offset_change_list):
            llt$section_address_range;

?? PUSH (LISTEXT := ON) ??
*copyc llt$section_address
*copyc oct$offset_change_list
?? POP ??

*DECK DECK=OCP$NORMALIZE_BINDING_SEC_VALUE EXPAND=FALSE
  PROCEDURE [XREF] ocp$normalize_binding_sec_value (code_section_directory: oct$code_directory_item;
        module_code_section_directory: ^oct$module_code_sections;
        relocation: llt$relocation_item;
        module_directory: ^oct$section_directory;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oct$code_section_directory
*copyc llt$relocation
*copyc oct$section_directory
?? POP ??


*DECK DECK=OCP$OBTAIN_CODE_SECTION_IDS EXPAND=FALSE

  PROCEDURE [XREF] ocp$obtain_code_section_ids (VAR module_description:
    oct$module_description;
    VAR code_section_ids: oct$code_section_ids;
    VAR status: ost$status);
*DECK DECK=OCP$OBTAIN_COMPONENT_INFO EXPAND=FALSE

  PROCEDURE [XREF] ocp$obtain_component_info (VAR module_description:
    oct$module_description;
    VAR component_info: ^llt$component_information;
    VAR status: ost$status);
*DECK DECK=OCP$OBTAIN_HEADER EXPAND=FALSE

  PROCEDURE [XREF] ocp$obtain_header (VAR module_description:
    oct$module_description;
    changed_ino: ^oct$changed_info;
    VAR header: oct$header;
    VAR status: ost$status);
*DECK DECK=OCP$OBTAIN_LIBRARY_LIST EXPAND=FALSE
  PROCEDURE [XREF] ocp$obtain_library_list
    (VAR module_description: oct$module_description;
         changed_info: ^oct$changed_info;
     VAR library_list: oct$name_list;
         retain: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc occ$retain
*copyc oct$changed_info
*copyc oct$module_description
*copyc oct$name_list
*copyc ost$status
?? POP ??
*DECK DECK=OCP$OBTAIN_OBJECT_FILE EXPAND=FALSE

  PROCEDURE [XREF] ocp$obtain_object_file
    (    file_name: fst$file_reference;
     VAR file_descriptor: ^oct$open_file_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc oct$open_file_list
*copyc ost$status
?? POP ??
*DECK DECK=OCP$OBTAIN_WORKING_FILE_LIST EXPAND=FALSE

  PROCEDURE [XREF] ocp$obtain_working_file_list (file_keyword: string ( * );
    VAR working_file_list: oct$working_file_list;
    VAR status: ost$status);
*DECK DECK=OCP$OBTAIN_XDCL_LIST EXPAND=FALSE
  PROCEDURE [XREF] ocp$obtain_xdcl_list
    (    changed_info: ^oct$changed_info;
         retain: boolean;
         obtain_deferred_entry_points: boolean;
     VAR module_description: oct$module_description;
     VAR xdcl_list: oct$external_declaration_list;
     VAR starting_procedure: pmt$program_name;
     VAR deferred_entry_point_list: oct$external_declaration_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc occ$retain
*copyc oct$changed_info
*copyc oct$external_declaration_list
*copyc oct$module_description
*copyc ost$status
*copyc pmt$program_name
?? POP ??

*DECK DECK=OCP$OBTAIN_XREF_LIST EXPAND=FALSE
  PROCEDURE [XREF] ocp$obtain_xref_list
    (VAR module_description: oct$module_description;
     VAR xref_list: oct$external_reference_list;
         retain: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc occ$retain
*copyc oct$external_reference_list
*copyc oct$module_description
*copyc ost$status
?? POP ??
*DECK DECK=OCP$OPEN_INPUT_DEBUG_TABLE EXPAND=FALSE

  PROCEDURE [XREF] ocp$open_input_debug_table
    (    debug_table: fst$file_reference;
     VAR file_identifier: amt$file_identifier;
     VAR segment: amt$segment_pointer;
     VAR debug_table_header: ^pmt$linker_debug_table_header;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$segment_pointer
*copyc fst$file_reference
*copyc ost$status
*copyc pmt$linker_debug_table_header
?? POP ??
*DECK DECK=OCP$OPEN_LINKER_DEBUG_TABLE EXPAND=FALSE

  PROCEDURE [XREF] ocp$open_linker_debug_table
    (    debug_file_name: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc oce$ve_linker_exceptions
*copyc ost$status
?? POP ??

*DECK DECK=OCP$OPEN_LINKER_OBJECT_FILE EXPAND=FALSE

  PROCEDURE [XREF] ocp$open_linker_object_file (lfd: ^oct$object_file_descriptor;
    VAR status: ost$status);
*DECK DECK=OCP$OPEN_LINKER_SYMBOL_TABLE EXPAND=FALSE

  PROCEDURE [XREF] ocp$open_linker_symbol_table (std:
    ^oct$symbol_table_descriptor;
    VAR status: ost$status);
*DECK DECK=OCP$OPEN_OUTPUT_DEBUG_TABLE EXPAND=FALSE

  PROCEDURE [XREF] ocp$open_output_debug_table
    (    name: fst$file_reference;
     VAR file_identifier: amt$file_identifier;
     VAR segment: amt$segment_pointer;
     VAR debug_table_header: ^pmt$linker_debug_table_header;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$segment_pointer
*copyc fst$file_reference
*copyc ost$status
*copyc pmt$linker_debug_table_header
?? POP ??
*DECK DECK=OCP$OPEN_OUTPUT_FILE EXPAND=FALSE
  PROCEDURE [XREF] ocp$open_output_file
    (    output: fst$file_reference;
         page_header: ^string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=OCP$OPEN_OUTPUT_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] ocp$open_output_segment
    (    name: fst$file_reference;
     VAR file_identifier: amt$file_identifier;
     VAR segment: amt$segment_pointer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$segment_pointer
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=OCP$OPEN_RUNNING_DEBUG_TABLE EXPAND=FALSE

  PROCEDURE [XREF] ocp$open_running_debug_table
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oce$ve_linker_exceptions
*copyc ost$status
?? POP ??
*DECK DECK=OCP$OPEN_SEGMENT_FOR_68000 EXPAND=FALSE
 PROCEDURE [XREF] ocp$open_segment_for_68000 (
        segment_length: ost$segment_length;
    VAR mc68000_seq: ^SEQ ( * );
    VAR segment: amt$segment_pointer;
    VAR status: ost$status);
*DECK DECK=OCP$OUTPUT EXPAND=FALSE
  PROCEDURE [XREF] ocp$output (string_1: string ( * );
        string_2: string ( * );
        size: integer;
        end_of_line: boolean);
*DECK DECK=OCP$OUTPUT_ACCESS_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] ocp$output_access_attributes (attributes: llt$section_access_attributes;
    end_of_line: boolean);
*DECK DECK=OCP$OUTPUT_ACCESS_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] ocp$output_access_control (access_control: ost$segment_access_control;
        end_of_line: boolean);

*DECK DECK=OCP$OUTPUT_BOOLEAN EXPAND=FALSE
  PROCEDURE [XREF] ocp$output_boolean (boolean_value: boolean;
        end_of_line: boolean);
*DECK DECK=OCP$OUTPUT_CURRENT_LINE EXPAND=FALSE
  PROCEDURE [XREF] ocp$output_current_line (current_line: ^oct$output_line);
*DECK DECK=OCP$OUTPUT_DATE EXPAND=FALSE
  PROCEDURE [XREF] ocp$output_date (date: ^ost$date;
        end_of_line: boolean;
    VAR valid_foramt: boolean);
*DECK DECK=OCP$OUTPUT_LIBRARY_MEMBER_KIND EXPAND=FALSE
  PROCEDURE [XREF] ocp$output_library_member_kind (library_member_kind: ^llt$library_member_kind;
        end_of_line: boolean;
    VAR valid_kind: boolean);
*DECK DECK=OCP$OUTPUT_MODULE_GENERATOR EXPAND=FALSE
  PROCEDURE [XREF] ocp$output_module_generator (module_generator: ^llt$module_generator;
        end_of_line: boolean;
    VAR valid_module_generator: boolean);
*DECK DECK=OCP$OUTPUT_MODULE_KIND EXPAND=FALSE
  PROCEDURE [XREF] ocp$output_module_kind (kind: ^llt$module_kind;
        end_of_line: boolean;
    VAR valid_kind: boolean);
*DECK DECK=OCP$OUTPUT_SCL_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] ocp$output_scl_parameters (scl_procedure: ^SEQ ( * );
    VAR status: ost$status);
*DECK DECK=OCP$OUTPUT_SECTION_KIND EXPAND=FALSE
  PROCEDURE [XREF] ocp$output_section_kind (kind: ^llt$section_kind;
        end_of_line: boolean;
    VAR valid_kind: boolean);
*DECK DECK=OCP$OUTPUT_TIME EXPAND=FALSE
  PROCEDURE [XREF] ocp$output_time (time: ^ost$time;
        end_of_line: boolean;
    VAR valid_format: boolean);
*DECK DECK=OCP$PROCESS_B0_INSTRUCTIONS EXPAND=FALSE
  PROCEDURE [XREF] ocp$process_b0_instructions (module_predictor: ^SEQ ( * );
        module_dictionary: ^llt$module_dictionary;
        first_intermediate_ol: ^SEQ ( * );
    VAR status: ost$status);

*copyc llt$module_dictionary
*DECK DECK=OCP$PROCESS_BTI_RECORDS EXPAND=FALSE
  PROCEDURE [XREF] ocp$process_bti_records (module_predictor: ^oct$module_predictor;
        module_predictor_header: ^oct$single_module_predictor_hdr;
        module_directory: ^oct$section_directory;
        bti_records: ^llt$binding_section_template;
        number_of_template_items: 0 .. llc$max_binding_items);

?? PUSH (LISTEXT := ON) ??
*copyc oct$single_module_predictor_hdr
*copyc oct$section_directory
*copyc llt$information_element
?? POP ??

*DECK DECK=OCP$PROCESS_COMMAND_DICTIONARY EXPAND=FALSE
  PROCEDURE [XREF] ocp$process_command_dictionary (command_dictionary: ^llt$command_dictionary;
        mod_dictionary_ocv: ^oct$offset_change_list;
        object_library: ^SEQ ( * );
    VAR status: ost$status);

*copyc llt$command_dictionary
*copyc oct$offset_change_list
*DECK DECK=OCP$PROCESS_DICTIONARIES EXPAND=FALSE
  PROCEDURE [XREF] ocp$process_dictionaries (ol_dictionary_ocv: ^oct$offset_change_list;
        mod_dictionary_ocv: ^oct$offset_change_list;
        object_library: ^SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oct$offset_change_list
*copyc ost$status
?? POP ??
*DECK DECK=OCP$PROCESS_EPTS EXPAND=FALSE
  PROCEDURE [XREF] ocp$process_epts (int_ol: ^SEQ ( * );
        entry_points: ^llt$object_text_descriptor;
        module_directory: ^oct$section_directory);

*copyc llt$object_text_descriptor
*copyc oct$section_directory
*DECK DECK=OCP$PROCESS_EPT_DICTIONARY EXPAND=FALSE
  PROCEDURE [XREF] ocp$process_ept_dictionary (entry_point_dictionary: ^llt$entry_point_dictionary;
        mod_dictionary_ocv: ^oct$offset_change_list;
        object_library: ^SEQ ( * ));

*copyc llt$entry_point_dictionary
*copyc oct$offset_change_list
*DECK DECK=OCP$PROCESS_EXTS EXPAND=FALSE
  PROCEDURE [XREF] ocp$process_exts (int_ol: ^SEQ ( * );
        external_element: ^llt$object_text_descriptor;
        module_directory: ^oct$section_directory);

*copyc llt$object_text_descriptor
*copyc oct$section_directory
*DECK DECK=OCP$PROCESS_FUNCTION_DICTIONARY EXPAND=FALSE
  PROCEDURE [XREF] ocp$process_function_dictionary (function_dictionary: ^llt$function_dictionary;
        mod_dictionary_ocv: ^oct$offset_change_list;
        object_library: ^SEQ ( * ));

*copyc llt$function_dictionary
*copyc oct$offset_change_list
*DECK DECK=OCP$PROCESS_HELP_DICTIONARY EXPAND=FALSE
  PROCEDURE [XREF] ocp$process_help_dictionary (help_dictionary: ^llt$help_module_dictionary;
        mod_dictionary_ocv: ^oct$offset_change_list;
        object_library: ^SEQ ( * ));

*copyc llt$help_module_dictionary
*copyc oct$offset_change_list
*DECK DECK=OCP$PROCESS_INFO_ELEMENT EXPAND=FALSE
  PROCEDURE [XREF] ocp$process_info_element (module_predictor: ^SEQ ( * );
        first_intermediate_ol: ^SEQ ( * );
        code_section_directory: ^oct$code_section_directory;
        module_code_sections: ^oct$module_code_sections;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oct$code_section_directory
*copyc ost$status
?? POP ??
*DECK DECK=OCP$PROCESS_INTERP_ELEMENT EXPAND=FALSE
  PROCEDURE [XREF] ocp$process_interp_element (module_predictor: ^SEQ ( * );
        first_intermediate_ol: ^SEQ ( * ));
*DECK DECK=OCP$PROCESS_MESSAGE_DICTIONARY EXPAND=FALSE
  PROCEDURE [XREF] ocp$process_message_dictionary (message_dictionary: ^llt$message_module_dictionary;
        mod_dictionary_ocv: ^oct$offset_change_list;
        object_library: ^SEQ ( * ));

*copyc llt$message_module_dictionary
*copyc oct$offset_change_list
*DECK DECK=OCP$PROCESS_MODULE_DICTIONARY EXPAND=FALSE
  PROCEDURE [XREF] ocp$process_module_dictionary (module_dictionary: ^llt$module_dictionary;
        mod_dictionary_ocv: ^oct$offset_change_list;
        object_library: ^SEQ ( * );
    VAR status: ost$status);

*copyc llt$module_dictionary
*copyc oct$offset_change_list

*DECK DECK=OCP$PROCESS_PANEL_DICTIONARY EXPAND=FALSE
  PROCEDURE [XREF] ocp$process_panel_dictionary (panel_dictionary: ^llt$panel_dictionary;
        mod_dictionary_ocv: ^oct$offset_change_list;
        object_library: ^SEQ ( * ));

*copyc llt$panel_dictionary
*copyc oct$offset_change_list
*DECK DECK=OCP$PROCESS_REL_RECORDS EXPAND=FALSE
  PROCEDURE [XREF] ocp$process_rel_records (module_directory: ^oct$section_directory;
        relocation: ^llt$relocation;
        number_of_rel_items: 0 .. llc$max_rel_items;
        code_section_directory: oct$code_directory_item;
        module_code_sections: ^oct$module_code_sections;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oct$section_directory
*copyc oct$code_section_directory
*copyc ost$status
*copyc llt$relocation
?? POP ??

*DECK DECK=OCP$PROCESS_SECTIONS EXPAND=FALSE
  PROCEDURE [XREF] ocp$process_sections (int_ol: ^SEQ ( * );
        section_definitions: ^llt$object_text_descriptor;
        module_directory: ^oct$section_directory;
        mod_dictionary_ocv: ^oct$offset_change_list);

*copyc llt$object_text_descriptor
*copyc oct$section_directory
*copyc oct$offset_change_list
*DECK DECK=OCP$PROCESS_SECTION_MAPS EXPAND=FALSE
  PROCEDURE [XREF] ocp$process_section_maps (module_directory: ^oct$section_directory;
        mod_dictionary_ocv: ^oct$offset_change_list;
        section_maps: ^llt$section_maps;
        number_of_section_maps: llt$number_of_sections;
        intermediate_ol: ^SEQ ( * );
        module_predictor: ^SEQ ( * ));

*copyc oct$section_directory
*copyc oct$offset_change_list
*copyc llt$information_element
*DECK DECK=OCP$REORDER EXPAND=FALSE
  PROCEDURE [XREF] ocp$reorder alias 'ocpreo' (
    parameter_list: clt$parameter_list;
    VAR status: ost$status);

*DECK DECK=OCP$REORDER_NLM_LIST EXPAND=FALSE
  PROCEDURE [XREF] ocp$reorder_nlm_list
    (    after: ^oct$new_library_module_list;
         reorder_list: ^oct$nlm_modification_list);

?? PUSH (LISTEXT := ON) ??
*copyc oct$new_library_module_list
*copyc oct$nlm_modification_list
?? POP ??
*DECK DECK=OCP$REPLACE EXPAND=FALSE
  PROCEDURE [XREF] ocp$replace alias 'ocprep' (
    parameter_list: clt$parameter_list;
    VAR status: ost$status);

*DECK DECK=OCP$REPLACE_LIST_INTO_NLM_LIST EXPAND=FALSE
  PROCEDURE [XREF] ocp$replace_list_into_nlm_list ALIAS 'ocprlnl' (replacement_list:
    ^oct$nlm_replacement_list);


*DECK DECK=OCP$RETURN_FILES EXPAND=FALSE

  PROCEDURE [XREF] ocp$return_files;
*DECK DECK=OCP$REWIND_WORKING_FILE_LIST EXPAND=FALSE

  PROCEDURE [XREF] ocp$rewind_working_file_list
    (VAR working_file_list: {input/output} oct$working_file_list);


?? PUSH (LISTEXT := ON) ??
*copyc oct$working_file_list
?? POP ??
*DECK DECK=OCP$SATISFY EXPAND=FALSE
  PROCEDURE [XREF] ocp$satisfy alias 'ocpsat' (
    parameter_list: clt$parameter_list;
    VAR status: ost$status);

*DECK DECK=OCP$SEARCH_MODIFICATION_LIST EXPAND=FALSE

  PROCEDURE [XREF] ocp$search_modification_list ALIAS 'ocpsml' (module_name: pmt$program_name;
    modification_list: ^oct$nlm_modification_list;
    VAR element_before: ^oct$nlm_modification_list;
    VAR name_found: boolean);


*DECK DECK=OCP$SEARCH_MODULES_TO_ADD EXPAND=FALSE

  PROCEDURE [XREF] ocp$search_modules_to_add (VAR modules_to_add:
    oct$program_name_list;
        module_name: pmt$program_name;
    VAR module_found: boolean;
    VAR module_before: ^oct$program_name_list);
*DECK DECK=OCP$SEARCH_NLM_TREE EXPAND=FALSE
  PROCEDURE [XREF] ocp$search_nlm_tree ALIAS 'ocpsnt' (module_name: pmt$program_name;
    VAR nlm: ^oct$new_library_module_list;
    VAR module_found: boolean);


*DECK DECK=OCP$SEARCH_OBJECT_FILE EXPAND=FALSE
  PROCEDURE [XREF] ocp$search_object_file alias 'ocpsof' (module_name: pmt$program_name;
    VAR module_found: boolean;
    VAR file_descriptor: ^oct$open_file_list);

*DECK DECK=OCP$SEARCH_OPEN_FILE_LIST EXPAND=FALSE

  PROCEDURE [XREF] ocp$search_open_file_list ALIAS 'ocpsofl' (file_name:
    amt$local_file_name;
    VAR file_found: boolean;
    VAR file_descriptor: ^oct$open_file_list);
*DECK DECK=OCP$SEARCH_REPLACEMENT_LIST EXPAND=FALSE
  PROCEDURE [XREF] ocp$search_replacement_list ALIAS 'ocpsrl' (module_name: pmt$program_name;
    replacement_list: ^oct$nlm_replacement_list;
    VAR element_before: ^oct$nlm_replacement_list;
    VAR name_found: boolean);


*DECK DECK=OCP$SEARCH_WORKING_FILE_LIST EXPAND=FALSE

  PROCEDURE [XREF] ocp$search_working_file_list (module_name: pmt$program_name;
    VAR working_file_list: oct$working_file_list;
    VAR module_found: boolean);


*DECK DECK=OCP$SEARCH_XDCL_LIST EXPAND=FALSE

  PROCEDURE [XREF] ocp$search_xdcl_list ALIAS 'ocpsxl' (name: pmt$program_name;
    list: ^oct$external_declaration_list;
    VAR name_found: boolean;
    VAR element_before: ^oct$external_declaration_list);
*DECK DECK=OCP$SELECT_DISPLAY_LEVEL EXPAND=FALSE
  PROCEDURE [XREF] ocp$select_display_level alias 'ocpsdl' (
    parameter_list: clt$parameter_list;
    VAR status: ost$status);

*DECK DECK=OCP$SKIP_MODULE_ON_WFL EXPAND=FALSE

  PROCEDURE [XREF] ocp$skip_module_on_wfl (VAR working_file_list: oct$working_file_list);


*DECK DECK=OCP$SORT_NAME_LIST EXPAND=FALSE

  PROCEDURE [XREF] ocp$sort_name_list (VAR name_list: oct$name_list);

*DECK DECK=OCS$LITERALS EXPAND=FALSE

  SECTION
    ocs$literals: READ;

*DECK DECK=OCT$ACTUAL_PARAMETER_LIST EXPAND=FALSE

  TYPE
    oct$actual_parameter_list = record
      nnext: ^oct$actual_parameter_list,
      actual_parameter: ^llt$actual_parameters,
    recend;

*copyc llt$actual_parameters
*DECK DECK=OCT$ADDRESS_FORMULATION_ITEM EXPAND=FALSE
  TYPE
    oct$address_formulation_item = record
      link: ^oct$address_formulation_item,
      value_section: llt$section_ordinal,
      dest_section: llt$section_ordinal,
      item: llt$address_formulation_item,
    recend;

*copyc llt$address_formulation
*copyc llt$section_address
*DECK DECK=OCT$ADDRESS_FORMULATION_LIST EXPAND=FALSE

  TYPE
    oct$address_formulation_list = record
      link: ^oct$address_formulation_list,
      address_formulation: llt$address_formulation,
    recend;

*copyc llt$address_formulation
*copyc llt$section_address



*DECK DECK=OCT$ADDRESS_TYPE EXPAND=FALSE
*DECK DECK=OCT$ANAOL_TYPES EXPAND=FALSE

  TYPE
    oct$object_library = record
      file: clt$file,
      file_identifier: amt$file_identifier,
      sequence: ^SEQ ( * ),

      number_of_modules: integer,
      module_list:  ^oct$module_list,
      record_analysis: ^oct$record_analysis,
    recend;

  CONST
    occ$head_of_list = 0;

  TYPE
    oct$module_list = array [occ$head_of_list .. *] of oct$module_item,

    oct$module_item = record
      name: pmt$program_name,
      link: ^oct$module_item,

      load_module_header: ^llt$load_module_header,
      interpretive_records: ^llt$object_text_descriptor,
      record_analysis: ^oct$record_analysis,
    recend;

  TYPE
    oct$record_analysis = record
      total: integer,
      kind: array [llt$object_record_kind] of record
        number: integer,
        number_of_items: integer,
      recend,

      sections: ^oct$sections,
      performance_problems: oct$anaol_performance_problems,
    recend;

  TYPE
    oct$sections = array [0 .. *] of oct$section,

    oct$section = record
      unallocated_common_block: boolean,
      allotted: boolean,
      allotted_section: ost$relative_pointer,
      segment_definition: boolean,
      definition: ^llt$section_definition,
      bytes_initialized: integer,
      externals_in: integer,
      addresses_in: integer,
      addresses_to: integer,
      internal_binding_section_ptrs: integer,
    recend;
?? EJECT ??

  TYPE
    oct$anaol_display_option = (occ$display_number_of_modules, occ$display_record_analysis,
                                occ$display_section_analysis, occ$count_internal_binding_refs),

    oct$anaol_display_options = set of oct$anaol_display_option;

  TYPE
    oct$anaol_performance_problem = (occ$symbol_tables, occ$line_tables, occ$parameter_checking,
      occ$runtime_checking, occ$runtime_library_calls, occ$runtime_libraries,
      occ$opt_debug, occ$opt_low, occ$object_module, occ$load_module, occ$bound_module,
      occ$unreferenced_sections, occ$multiple_entry_points, occ$supplemental_debug_tables),

    oct$anaol_performance_problems = set of oct$anaol_performance_problem;

  TYPE
    oct$anaol_performance_option = (occ$display_description, occ$display_module_names,
          occ$display_commands),

    oct$anaol_performance_options = set of oct$anaol_performance_option;


  TYPE
    oct$performance_problem_count = array [oct$anaol_performance_problem] of 0 .. 0ffffff(16);


  TYPE
    oct$section_kinds = set of llt$section_kind;

  CONST
    occ$any_section_name = '******* Any Section Name ***** ';


?? EJECT ??
*copyc oce$anaol_exceptions

?? PUSH (LISTEXT := ON) ??
*copyc llt$object_module
*copyc llt$load_module
*copyc clt$file
*copyc amt$file_identifier
*copyc osd$virtual_address
?? POP ??
*DECK DECK=OCT$ATTRIBUTE_KEYWORD_SET EXPAND=FALSE
  TYPE
    oct$attribute_keyword_set = set of oct$module_attribute_keywords;

*copyc oct$module_attribute_keywords
*DECK DECK=OCT$BOUND_COMPONENTS EXPAND=FALSE

  TYPE
    oct$bound_components = array [1 .. * ] of ^oct$module_description;

*copyc oct$module_description
*DECK DECK=OCT$BOUND_MODULE_COMPONENTS EXPAND=FALSE

  TYPE
    oct$bound_module_components = record
      component: ^oct$module_description,
      link: ^oct$bound_module_components,
    recend;

*copyc oct$module_description
*DECK DECK=OCT$BOUND_MODULE_HEADER EXPAND=FALSE

  TYPE
    oct$bound_module_header = record
      identification: llt$identification,
      section_map: clt$file,
      xref_list: oct$external_reference_list,

      components: ^oct$bound_components,

      code_section_ids: oct$code_section_ids,

      preset_specified: boolean,
      preset_value: pmt$initialization_value,
      include_binary_section_maps: boolean,
    recend;

*copyc clt$file
*copyc llt$identification
*copyc oct$bound_components
*copyc oct$code_section_ids
*copyc oct$external_reference_list
*copyc pmt$initialization_value
*DECK DECK=OCT$BREAKLIST EXPAND=FALSE
  TYPE
    oct$breaklist = array [1 .. *] of oct$breaklist_item,

    oct$breaklist_item = record
      module_name: pmt$program_name,
      major_name: pmt$program_name,
      minor_name: pmt$program_name,
      offset: llt$section_offset,
      kind: oct$breaklist_kind,
      section_ordinal: llt$section_ordinal,
      secondary_section_ordinal: llt$section_offset,
      length: oct$breaklist_length,
    recend,

    oct$breaklist_kind = (occ$code, occ$idr, occ$read, occ$ept, occ$ext, occ$module_header,
          occ$adr, occ$text, occ$secdef, occ$object_library_header, occ$dictionary,
          occ$command_proc, occ$program_des, occ$info_element, occ$bti, occ$rel,
          occ$component, occ$section_map, occ$function_proc, occ$message_mod, occ$panel_mod,
          occ$library_member_header, occ$mtm_header, occ$mtm_cc, occ$mtm_cn, occ$mess_temp, occ$m68000,
          occ$app_program_des, occ$app_command_proc, occ$deferred_ept, occ$deferred_common_blk,
          occ$command_des, occ$function_des, occ$app_command_des),

    oct$breaklist_length = 0 .. 7fffffff(16);

  TYPE
    oct$breaklist_index = 0 .. occ$max_breaklist_items;

*copyc pmt$program_name
*copyc llt$section_address
*copyc occ$breaklist
*DECK DECK=OCT$BREAKLIST_SYMBOL_TABLE EXPAND=FALSE
*DECK DECK=OCT$BUILD_OPTIONS EXPAND=FALSE


  CONST
    rmb_utility_name = 'REAL_MEMORY_BUILDER            ',
    rmb_prompt_string = 'RMB',
    occ$max_retries = 100;


  TYPE
    oct$build_options = record
      page_size: ost$page_size,
      page_table_address: ost$real_memory_address,
      page_table_length: 4096 .. 1048576,
      load_address: ost$real_memory_address,
      load_offset: ost$real_memory_address,
      memory_map: clt$file,
      c170_memory_size: integer,
      ssr_size: integer,
      job_exchange_address: oct$exchange_name,
      monitor_exchange_address: oct$exchange_name,
      pp_address_array_address: oct$exchange_name,
      pages_loaded_address: oct$exchange_name,
      page_size_address: oct$exchange_name,
      define_commands: oct$define_command_list,
      load_files: oct$load_file_list,
      monitor_symbol_tables: oct$symbol_table_list,
      job_symbol_tables: oct$symbol_table_list,
      segment_commands: oct$segment_command_list,
      memory_commands: oct$memory_command_list,
      bytes_loaded_address: oct$exchange_name,
      building_ei: boolean,
    recend;


  TYPE
    oct$exchange_address = record
      address_space: oct$address_space_id,
      segment: ost$segment,
      segment_offset: ost$segment_offset,
    recend,


    oct$exchange_name = record
      address_space: oct$address_space_id,
      name: pmt$program_name,
    recend;


  TYPE
    oct$address_space_id = (occ$null, occ$mtr, occ$job, occ$both);


  TYPE
    oct$parameter = (occ$attributes, occ$ring_brackets, occ$asid, occ$gl_key),

    oct$parameters = set of oct$parameter,

    oct$display_memory_options = (occ$all, occ$page_table, occ$memory_map,
      occ$mps, occ$jps),

    oct$segment_command_kind = (occ$change, occ$share, occ$extend),

    oct$memory_command_kind = (occ$display_memory, occ$display_memory_address),

    oct$define_command_list = record
      parameters: oct$parameters,
      address_space: oct$address_space_id,
      segment_id: pmt$program_name,
      segment_number: ost$segment,
      address: ost$real_memory_address,
      length: ost$segment_length,
      contiguous_space: boolean,
      hardware_attributes: ost$segment_access_control,
      software_attributes: mmt$software_attribute_set,
      r1: ost$valid_ring,
      r2: ost$valid_ring,
      active_segment_id: ost$asid,
      key_lock: ost$key_lock,
      link: ^oct$define_command_list,
    recend,

    oct$segment_command_list = record
      address_space: oct$address_space_id,
      segment_number: ost$segment,
      link: ^oct$segment_command_list,

      case kind: oct$segment_command_kind of
      = occ$change =
        parameters: oct$parameters,
        address: ost$real_memory_address,
        length: ost$segment_length,
        hardware_attributes: ost$segment_access_control,
        software_attributes: mmt$software_attribute_set,
        r1: ost$valid_ring,
        r2: ost$valid_ring,
        active_segment_id: ost$asid,
        key_lock: ost$key_lock,

      = occ$share =
        new_address_space: oct$address_space_id,
        new_segment_number: ost$segment,

      = occ$extend =
        extend_length: ost$segment_length,
      casend,
    recend,

    oct$memory_command_list = record
      file_name_specified: boolean,
      link: ^oct$memory_command_list,
      output: clt$file,

      case kind: oct$memory_command_kind of
      = occ$display_memory =
        memory: oct$display_memory_options,

      = occ$display_memory_address =
        display_address: ost$real_memory_address,
        length: ost$real_memory_address,
      casend,
    recend;


  TYPE
    oct$load_file_list = record
      name: amt$local_file_name,
      address_space: oct$address_space_id,
      link: ^oct$load_file_list,
    recend;


  TYPE
    oct$file_descriptor = record
      name: amt$local_file_name,
      id: amt$file_identifier,
      segment: amt$segment_pointer,
    recend;


  TYPE
    oct$symbol_table_list = record
      name: amt$local_file_name,
      link: ^oct$symbol_table_list,
    recend;


  TYPE
    oct$page_table = array [ * ] of ost$page_table_entry,

    oct$real_memory_descriptor = record
      id: amt$file_identifier,
      segment: amt$segment_pointer,
      length: 0 .. 100000000(16),
      page_table: ^oct$page_table,
      page: ^array [0 .. * ] of record
        reserved: boolean,
        continue_bits: 0 .. 0ffffffff(16),
      recend,
      reserved_asids: oct$reserved_asids,
      next_free_page: ost$real_memory_address,
      pt_continue_bits: integer,
    recend;


  TYPE
    oct$segment_descriptor = record
      segment_id: pmt$program_name,
      ste: ost$segment_descriptor,
      software_attributes: mmt$software_attribute_set,
      pages: ^oct$page_descriptor,
      asid: ^oct$asid,
      segment_number: ost$segment,
      segment_length: ^ost$segment_length,
      link: ^oct$segment_descriptor,
    recend,


    oct$asid = record
      assigned: boolean,
      predefined: boolean,
      active_segment_id: ost$asid,
    recend;


  TYPE
    oct$segment_descriptors = array [1 .. * ] of oct$segment_descriptor;


  TYPE
    oct$page_descriptor = record
      offset: ost$real_memory_address,
      link: ^oct$page_descriptor,
    recend,

    oct$page_descriptors = array [0 .. * ] of oct$page_descriptor;


  TYPE
    oct$exchange_package_info = record
      p_address: ost$pva,
      binding_address: ost$pva,
      address_space: oct$address_space_id,
      exchange_address: oct$exchange_address,
      rma: ost$real_memory_address,
      segment_descriptor_list: oct$segment_descriptor,
      symbol_table: ^oct$symbol_table,
    recend;


  TYPE
    oct$symbol_table = array [1 .. * ] of oct$symbol_table_entry,

    oct$symbol_table_entry = record
      name: pmt$program_name,
      pva: ost$pva,
    recend;


  TYPE
    oct$reserved_asids = record
      asid: ost$asid,
      link: ^oct$reserved_asids,
    recend;


  TYPE
    oct$half_word = record
      case 0 .. 1 of
      = 0 =
        rma: ost$halfword,
      = 1 =
        address_1: 0 .. 0ffff(16),
        address_2: 0 .. 0ffff(16),
      casend,
    recend;


  TYPE
    oct$display_word = record
      upper_half: ost$halfword,
      lower_half: ost$halfword,
    recend;


  TYPE
    oct$pva = record
      case 0 .. 1 of
      = 0 =
        pva: ost$pva,
      = 1 =
        reg: ^cell,
      casend,
    recend;


?? EJECT ??



?? EJECT ??

*copyc OST$SEGMENT_ACCESS_CONTROL
*copyc OST$VIRTUAL_MACHINE_IDENTIFIER
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$SEGMENT_DESCRIPTOR
*copyc PMT$PROGRAM_DESCRIPTION
*copyc OST$STRING
*copyc MMT$ATTRIBUTE_KEYWORD
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$SEGMENT_POINTER
*DECK DECK=OCT$BYTES EXPAND=FALSE
  TYPE
    oct$one_byte = 0 .. 0ff(16),
    oct$two_bytes = 0 .. 0ffff(16),
    oct$three_bytes = 0 .. 0ffffff(16),
    oct$four_bytes = 0 .. 0ffffffff(16);
*DECK DECK=OCT$CHANGED_INFO EXPAND=FALSE

  TYPE
    oct$changed_info = record
      name: ^pmt$program_name,
      debug_tables_to_omit: oct$debug_tables,

      commentary: ^string (40),

      entry_points: ^oct$external_declaration_list,
      starting_procedure: pmt$program_name,

      new_libraries: boolean,
      library_list: ^oct$name_list,

      application_identifier: ^llt$application_identifier,
      cybil_parameter_checking: string (6),
    recend;

*copyc llt$application_identifier
*copyc oct$debug_tables
*copyc oct$external_declaration_list
*copyc oct$name_list
*copyc pmt$program_name
*DECK DECK=OCT$CHECKSUM EXPAND=FALSE
  TYPE
    oct$checksum = 0 .. 0ffffffff(16);

*DECK DECK=OCT$CODE_SECTION_DIRECTORY EXPAND=FALSE
  TYPE
    oct$code_section_directory = array [1 .. *] of oct$code_directory_item,

    oct$code_directory_item = record
      first_entry_number: llt$section_ordinal,
      last_entry_number: llt$section_ordinal,
    recend;

  TYPE
    oct$module_code_sections = array [1 .. *] of oct$code_section_item,

    oct$code_section_item = record
      section_ordinal: llt$section_ordinal,
      start_of_section: ^cell,
    recend;

  TYPE
    oct$q_field = -7fff(16) .. 7fff(16);

*copyc llt$section_address

*DECK DECK=OCT$CODE_SECTION_IDS EXPAND=FALSE

  TYPE
    oct$code_section_ids = record
      name: pmt$program_name,
      section_ordinal: llt$section_ordinal,
      link: ^oct$code_section_ids,
    recend;

*copyc llt$section_address
*copyc pmt$program_name
*DECK DECK=OCT$COMPONENT_INFORMATION EXPAND=FALSE

  TYPE
    oct$component_information = array [1 .. * ] of oct$component_description;

  TYPE
    oct$component_description = record
      new_component_number: 1 .. llc$max_components,
      description: llt$component_description,
    recend;

*copyc llt$information_element
*DECK DECK=OCT$COMPONENT_LIST EXPAND=FALSE

  TYPE
    oct$component_list = record
      module_description: ^oct$module_description,
      link: ^oct$component_list,
    recend;

*copyc oct$module_description
*DECK DECK=OCT$CORRECTOR EXPAND=FALSE

  TYPE
    oct$corrector_header = record
      version: string (28),  {occ$corrector_header_version
      number_of_correctors: oct$number_of_correctors,
      size: oct$corrector_size,
    recend,

    oct$number_of_correctors = 0 .. occ$max_number_of_correctors,

    oct$corrector_header_v1_0 = record
      number_of_correctors: oct$number_of_correctors_v1_0,
      size: oct$corrector_size,
    recend,

    oct$number_of_correctors_v1_0 = 0 .. 0ffff(16),

    oct$corrector_item = record
      bytes_ok: oct$offset,
      bytes_to_delete: - (7fffffff(16) + 1) .. 7fffffff(16),
      bytes_to_insert: - (7fffffff(16) + 1) .. 7fffffff(16),
    recend,

    oct$new_bytes = array [1 .. *] of 0 .. 0ff(16),

    oct$corrector_index = 1 .. occ$max_number_of_correctors,
    oct$corrector_size = 0 .. 7fffffff(16);

*copyc oct$offset
*copyc occ$corrector
*DECK DECK=OCT$CPU_OBJECT_MODULE_HEADER EXPAND=FALSE

  TYPE
    oct$cpu_object_module_header = record
      identification: ^llt$identification,
      application_identifier: ^llt$application_identifier,
    recend;

*copyc llt$application_identifier
*copyc llt$identification
*DECK DECK=OCT$DEBUG_TABLE EXPAND=FALSE

  TYPE
    oct$debug_table = (occ$line_table, occ$symbol_table,
          occ$parameter_checking, occ$supplemental_debug_table);


*DECK DECK=OCT$DEBUG_TABLES EXPAND=FALSE

  TYPE
    oct$debug_tables = set of oct$debug_table;

*copyc oct$debug_table
*DECK DECK=OCT$DIFFERENCE_ARRAY EXPAND=FALSE
*DECK DECK=OCT$DISPLAY_TOGGLES EXPAND=FALSE


  CONST
    oc = 'OC';

  CONST
    occ$generator_name = 'OBJECT LIBRARY GENERATOR ';

  CONST
    occ$end_of_line = TRUE,
    occ$continue = FALSE,

    occ$single_space = ' ',
    occ$double_space = '0',
    occ$triple_space = '-',
    occ$new_page = '1';

  CONST
    occ$min_shadow_size = 16384,
    occ$output_line_size = 256;

  TYPE
    oct$output_line_size = 0 .. occ$output_line_size;

  TYPE
    oct$output_line = record
      size: oct$output_line_size,
      text: string (occ$output_line_size),
    recend;


  TYPE
    oct$display_toggles = set of (occ$display_all, occ$display_time_date,
          occ$display_module_header, occ$display_component_info,
          occ$display_xdcls, occ$display_xrefs, occ$display_libraries);


*DECK DECK=OCT$ENTRY_DEFINITION_LIST EXPAND=FALSE

  TYPE
    oct$entry_definition_list = record
      link: ^oct$entry_definition_list,
      changed_name: ^pmt$program_name,
      entry_definition: llt$entry_definition,
      formal_parameter: ^llt$formal_parameters,
    recend;

*copyc llt$entry_definition
*copyc llt$formal_parameters
*copyc pmt$program_name
*DECK DECK=OCT$ENTRY_POINT_SORTED_LIST EXPAND=FALSE
  TYPE
    oct$entry_point_sorted_list = ^array [1 .. * ] of
          ^oct$entry_point_address_list;


  TYPE
    oct$entry_point_address_list = record
      name: pmt$program_name,
      link: ^oct$entry_point_address_list,

      case defined: boolean of
      = TRUE =
        section_ordinal: llt$section_ordinal,
        offset: llt$section_offset,

      = FALSE =
        component: ^oct$separated_module_header,
        old_binding_offset: llt$section_offset,

      casend,
    recend;

*copyc llt$section_address
*copyc oct$separated_module_header
*copyc pmt$program_name
*DECK DECK=OCT$EXTERNAL_DECLARATION_LIST EXPAND=FALSE

  TYPE
    oct$sorted_xdcl_list = ^array [1 .. * ] of ^oct$external_declaration_list;

  TYPE
    oct$external_declaration_list = record
      name: pmt$program_name,
      old_name: pmt$program_name,
      attributes: llt$entry_point_attributes,
      deferred: boolean,
      link: ^oct$external_declaration_list,
    recend;

*copyc llt$entry_point_attributes
*copyc pmt$program_name

*DECK DECK=OCT$EXTERNAL_LINKAGE_ITEM EXPAND=FALSE
  TYPE
    oct$external_linkage_item = record
      link: ^oct$external_linkage_item,
      name: pmt$program_name,
      language: llt$module_generator,
      declaration_matching_required: boolean,
      declaration_matching: llt$declaration_matching_value,
      item: llt$external_linkage_item,
      actual_parameter_list: ^oct$actual_parameter_list,
    recend;

*copyc llt$declaration_matching_value
*copyc llt$external_linkage
*copyc llt$module_generator
*copyc oct$actual_parameter_list
*copyc pmt$program_name

*DECK DECK=OCT$EXTERNAL_LINKAGE_LIST EXPAND=FALSE

  TYPE
    oct$external_linkage_list = record
      link: ^oct$external_linkage_list,
      actual_parameter_list: oct$actual_parameter_list,
      external_linkage: llt$external_linkage,
    recend;

*copyc llt$external_linkage
*copyc oct$actual_parameter_list





*DECK DECK=OCT$EXTERNAL_REFERENCE_LIST EXPAND=FALSE

  TYPE
    oct$sorted_xref_list = ^array [1 .. * ] of ^oct$external_reference_list;

  TYPE
    oct$external_reference_list = record
      name: pmt$program_name,
      link: ^oct$external_reference_list,
    recend;

*copyc pmt$program_name
*DECK DECK=OCT$FILE_TYPE EXPAND=FALSE

  TYPE
    oct$file_type = (occ$file, occ$library, occ$current);

*DECK DECK=OCT$FILL_SEQUENCE EXPAND=FALSE
  TYPE
    oct$fill_sequence = array [1 .. *] of 0 .. 0ff(16);

*DECK DECK=OCT$HEADER EXPAND=FALSE

  TYPE
    oct$header = record
      case oct$module_kind of
      = occ$cpu_object_module, occ$ppu_object_module, occ$load_module,
            occ$bound_module =
        identification: llt$identification,
        application_identifier: llt$application_identifier,
      = occ$program_description, occ$command_procedure, occ$function_procedure,
            occ$command_description, occ$function_description,
            occ$message_module, occ$panel_module =
        library_member_header: llt$library_member_header,
      = occ$applic_command_procedure, occ$applic_program_description,
            occ$applic_command_description =
        application_member_header: llt$application_member_header,
      casend,
    recend;

*copyc llt$application_identifier
*copyc llt$identification
*copyc llt$library_member_header
*copyc oct$module_kind
*DECK DECK=OCT$INTERRUPT_TYPES EXPAND=FALSE

  CONST
    occ$abort_condition = 'ABORT_CONDITION                ';

*DECK DECK=OCT$KNOWN_FILE_LIST EXPAND=FALSE

  TYPE
    oct$known_file_list = record
      name: ^fst$file_reference,
      link: ^oct$known_file_list,
    recend;

*copyc fst$file_reference

*DECK DECK=OCT$LIBRARY_LIST EXPAND=FALSE

  TYPE
    oct$library_list = record
      link: ^oct$library_list,
      libraries: ^llt$libraries,
    recend;

*copyc llt$libraries
*DECK DECK=OCT$LINK_PARAMETERS EXPAND=FALSE

  TYPE
    oct$link_parameters = record
      virtual_image: ^fst$file_reference,
      symbol_table: ^fst$file_reference,
      debug_table: ^fst$file_reference,

      symbol_table_id: ost$name,
      input_debug_table: ^fst$file_reference,

      heap_size_specified: boolean,
      heap_size: ost$segment_length,

      map_file: ^fst$file_reference,
      map_options: pmt$load_map_options,

      starting_segment: oct$segment,
      starting_procedure: pmt$program_name,
      linked_symbols: string (4),
      gate_ring_level: ost$ring,

      modules_to_add: oct$program_name_list,
      object_files_to_add: oct$object_file_descriptor,
      object_libraries_to_use: oct$object_file_descriptor,
      symbol_tables_to_use: oct$symbol_table_descriptor,

      exchange_package_variable: pmt$program_name,

      build_level: pmt$os_name,
      build_level_variables: oct$program_name_list,

      heap_pointers: oct$pointer_list,
      symbol_table_pointers: oct$pointer_list,
      symbol_table_id_variable: pmt$program_name,
      debug_table_pointers: oct$pointer_list,

      recovery_name_table_pointer: oct$pointer_list,
      recovery_addresses: oct$program_name_list,

      ignore_section_names: boolean,
      common_blocks_to_retain: oct$program_name_list,

      mode: oct$mode,
      mc68000_id: amt$file_identifier,
      mc68000_seq: ^SEQ ( * ),

      message_module_list: ^oct$message_module_list,

      delete_declaration_matching: oct$program_name_list,
      preset_value: pmt$initialization_value,

      create_only_predefined_segments: boolean,

      cybil_parameter_checking: string (6),
      defer_entry_points: ^oct$defer_name_list,
      defer_common_blocks: ^oct$defer_name_list,
    recend;

  TYPE
    oct$mode = (occ$template, occ$product, occ$mc68000);

  TYPE
    oct$pointer_list = record
      name: pmt$program_name,
      section_name: pmt$program_name,
      segment_number: ost$segment,
      link: ^oct$pointer_list,
    recend;

  TYPE
    oct$message_module_list = record
      module_name: pmt$program_name,
      pointer_name: pmt$program_name,
      section_name: pmt$program_name,
      segment_number: ost$segment,
      link: ^oct$message_module_list,
    recend;

  TYPE
    oct$defer_name_list = record
      case defer: oct$defer of
      = occ$defer_all, occ$defer_non_retained =
        ,
      = occ$defer, occ$defer_all_except =
        name_list: ^oct$defer_list,
      casend,
    recend,

    oct$defer = (occ$defer_all, occ$defer_non_retained, occ$defer,
          occ$defer_all_except),

    oct$defer_list = record
      name: pmt$program_name,
      name_found: boolean,
      link: ^oct$defer_list,
    recend;

*copyc pmt$program_name
*copyc amt$file_identifier
*copyc fst$file_reference
*copyc oct$object_file_descriptor
*copyc oct$program_name_list
*copyc oct$segment
*copyc oct$symbol_table_descriptor
*copyc osd$virtual_address
*copyc ost$name
*copyc pmt$initialization_value
*copyc pmt$os_name
*copyc pmt$program_description
*copyc pmt$program_name

*DECK DECK=OCT$LIST_OF_ENTRY_POINTS EXPAND=FALSE

  TYPE
    oct$list_of_entry_points = array [1 .. * ] of oct$entry_points,

    oct$entry_points = record
      name: pmt$program_name,
      ring_violation: boolean,
      inboard_symbol: boolean,
      deferred: boolean,
      gated: boolean,
      attributes: llt$entry_point_attributes,
      language: llt$module_generator,
      declaration_matching_required: boolean,
      declaration_matching: llt$declaration_matching_value,
      pva: ost$pva,
      binding_section: ost$pva,
      r1: ost$ring,
      r2: ost$ring,
      r3: ost$ring,
      global_key: ost$key_lock_value,
      local_key: ost$key_lock_value,
      r_link: ^oct$entry_points,
      l_link: ^oct$entry_points,
      link: ^oct$entry_points,
    recend;

*copyc llt$declaration_matching_value
*copyc llt$entry_point_attributes
*copyc llt$module_generator
*copyc osd$virtual_address
*copyc pmt$program_name
*DECK DECK=OCT$LOAD_MODULE_LIST EXPAND=FALSE

  TYPE
    oct$load_module_list = record
      name: pmt$program_name,
      description: ^oct$module_description,
      changed_info: ^oct$changed_info,
      link: ^oct$load_module_list,
    recend;

*copyc oct$changed_info
*copyc oct$module_description
*copyc pmt$program_name
*DECK DECK=OCT$METAPATCH_HEADER EXPAND=FALSE
  TYPE
    oct$metapatch_header = record
      object_library_name: pmt$program_name,
      old_checksum: oct$checksum,
      new_checksum: oct$checksum,
      size_of_metapatch: oct$offset,
      predictor_size: oct$predictor_size,
      predictor: REL (oct$metapatch) ^SEQ(*),
      number_of_move_items: oct$breaklist_index,
      move_items: REL (oct$metapatch) ^oct$move_items,
      corrector_size: oct$breaklist_length,
      corrector: REL (oct$metapatch) ^SEQ(*),
    recend;

  TYPE
    oct$metapatch = SEQ (*);

*copyc oct$predictor_size
*copyc oct$offset
*copyc oct$checksum
*copyc oct$move_items
*copyc oct$corrector
*copyc oct$breaklist

*DECK DECK=OCT$MODULE_ATTRIBUTE_KEYWORDS EXPAND=FALSE
  TYPE
    oct$module_attribute_keywords = 1 .. occ$kwd_maximum;

  CONST

{ The following are keywords for specific attributes.  These attributes
{ must stay sorted with the exception of name and kind which are to remain
{ first.

    occ$kwd_name = 1,
    occ$kwd_kind = 2,
    occ$kwd_abort_file = 3,
    occ$kwd_aliases = 4,
    occ$kwd_application_identifier = 5,
    occ$kwd_arithmetic_loss_of_sig = 6,
    occ$kwd_arithmetic_overflow = 7,
    occ$kwd_availability = 8,
    occ$kwd_comment = 9,
    occ$kwd_components = 10,
    occ$kwd_creation_date_time = 11,
    occ$kwd_debug_input = 12,
    occ$kwd_debug_mode = 13,
    occ$kwd_debug_output = 14,
    occ$kwd_divide_fault = 15,
    occ$kwd_entry_points = 16,
    occ$kwd_exponent_overflow = 17,
    occ$kwd_exponent_underflow = 18,
    occ$kwd_fp_indefinite = 19,
    occ$kwd_fp_loss_of_significance = 20,
    occ$kwd_generator = 21,
    occ$kwd_generator_version = 22,
    occ$kwd_invalid_bdp_data = 23,
    occ$kwd_libraries = 24,
    occ$kwd_load_map = 25,
    occ$kwd_load_map_options = 26,
    occ$kwd_log_option = 27,
    occ$kwd_module_kind = 28,
    occ$kwd_modules = 29,
    occ$kwd_natural_language = 30,
    occ$kwd_object_files = 31,
    occ$kwd_online_manual = 32,
    occ$kwd_preset_value = 33,
    occ$kwd_references = 34,
    occ$kwd_scope = 35,
    occ$kwd_stack_size = 36,
    occ$kwd_starting_procedure = 37,
    occ$kwd_status_codes = 38,
    occ$kwd_system_command_name = 39,
    occ$kwd_termination_error_level = 40,
    occ$kwd_text_kind = 41,
    occ$kwd_last_attribute = 41,

{ The following are group keywords.

    occ$kwd_program_attributes = 42,
    occ$kwd_header = 43,
    occ$kwd_all = 44,

    occ$kwd_maximum = 44;

*DECK DECK=OCT$MODULE_DESCRIPTION EXPAND=FALSE

  TYPE
    oct$module_description = record
      name: pmt$program_name,
      source: oct$file_type,
      file: ^SEQ ( * ),
      segment_relocation_info: ^oct$segment_relocation_info,

      case kind: oct$module_kind of
      = occ$cpu_object_module =
        cpu_object_module_header: ^oct$cpu_object_module_header,
      = occ$ppu_object_module =
        ppu_object_module_header: ^llt$identification,
      = occ$load_module =
        load_module_header: ^llt$load_module_header,
      = occ$program_description =
        program_description_header: ^llt$library_member_header,
      = occ$command_procedure =
        command_procedure_header: ^llt$library_member_header,
      = occ$command_description =
        command_description_header: ^llt$library_member_header,
      = occ$function_procedure =
        function_procedure_header: ^llt$library_member_header,
      = occ$function_description =
        function_description_header: ^llt$library_member_header,
      = occ$message_module =
        message_module_header: ^llt$library_member_header,
      = occ$panel_module =
        panel_module_header: ^llt$library_member_header,
      = occ$bound_module =
        bound_module_header: ^oct$bound_module_header,
      = occ$temporary_load_module =
        temporary_module_header: ^oct$temporary_module_header,
      = occ$applic_command_procedure =
        applic_command_procedure_header: ^llt$application_member_header,
      = occ$applic_program_description =
        applic_program_description_hdr: ^llt$application_member_header,
      = occ$applic_command_description =
        applic_command_description_hdr: ^llt$application_member_header,
      casend,
    recend;

*copyc llt$identification
*copyc llt$library_member_header
*copyc llt$load_module_header
*copyc oct$bound_module_header
*copyc oct$cpu_object_module_header
*copyc oct$file_type
*copyc oct$module_kind
*copyc oct$segment_relocation_info
*copyc oct$temporary_module_header
*copyc pmt$program_name

*DECK DECK=OCT$MODULE_DIRECTORY EXPAND=FALSE

  TYPE
    oct$module_directory = array [1 .. *] of oct$module_directory_item,

    oct$module_directory_item = record
      module_name: ost$name,
      bound_module: boolean,
      new_module_number: llt$module_index,
      last_section_ordinal: llt$section_ordinal,
      section_number_change_list: ^oct$section_number_change_list,
      number_of_components: 0 .. llc$max_components,
      number_of_rel_items: llt$number_of_info_elements,
    recend,

    oct$section_number_change_list = array [0 .. *] of llt$section_ordinal;

*copyc llt$information_element
*copyc llt$module_dictionary
*copyc llt$section_address


*DECK DECK=OCT$MODULE_KIND EXPAND=FALSE

  TYPE
    oct$module_kind = (occ$cpu_object_module, occ$ppu_object_module,
          occ$load_module, occ$program_description, occ$command_procedure,
          occ$function_procedure, occ$message_module, occ$panel_module,
          occ$bound_module, occ$temporary_load_module,
          occ$applic_command_procedure, occ$applic_program_description,
          occ$applic_command_description, occ$command_description,
          occ$function_description);

*DECK DECK=OCT$MODULE_KINDS EXPAND=FALSE


  TYPE
    oct$module_kinds = set of oct$module_kind;

*copyc oct$module_kind

*DECK DECK=OCT$MODULE_MAP EXPAND=FALSE
  TYPE
    oct$module_map = array [1 .. *] of oct$module_map_item,

    oct$module_map_item = record
      name: pmt$program_name,
      case kind: llt$library_module_kind of
      =llc$load_module=
        section_definitions: ^llt$object_text_descriptor,
        bound_module: boolean,
        section_maps: ^llt$section_maps,
        component_info: ^llt$component_information,
        greatest_section_ordinal: llt$section_ordinal,
        change_list: ^oct$change_list,
      =llc$ppu_object_module, llc$program_description, llc$command_procedure,
            llc$function_procedure, llc$message_module, llc$panel_module =
        ,
      casend,
    recend,

    oct$change_list = array [0 .. *] of llt$section_ordinal;

*copyc pmt$program_name
*copyc llt$module_dictionary
*copyc llt$object_text_descriptor
*copyc llt$section_address
*DECK DECK=OCT$MODULE_PREDICTOR_SIZE EXPAND=FALSE
  TYPE
    oct$module_predictor_size = 0 .. 7fffffff(16);
*DECK DECK=OCT$MOVE_ITEMS EXPAND=FALSE
  TYPE
    oct$move_items = array [1 .. *] of oct$move_item,

    oct$move_item = record
      old_offset: oct$offset,
      new_offset: oct$offset,
      length: oct$breaklist_length,
    recend;

*copyc oct$breaklist
*copyc occ$breaklist
*copyc oct$offset
*DECK DECK=OCT$NAME_INDEX_CHANGES EXPAND=FALSE
  TYPE
    oct$name_index_changes = array [0 .. * ] of ost$message_template_index;

*copyc ost$message_template_index
*DECK DECK=OCT$NAME_LIST EXPAND=FALSE

  TYPE
    oct$name_list = record
      name: pmt$program_name,
      link: ^oct$name_list,
    recend;

*copyc pmt$program_name
*DECK DECK=OCT$NEW_BINDING_TEMPLATE_LIST EXPAND=FALSE

  TYPE
    oct$new_binding_template_list = record
      link: ^oct$new_binding_template_list,
      binding_template: llt$binding_template,
    recend;

*copyc llt$binding_template
*DECK DECK=OCT$NEW_LIBRARY_MODULE_LIST EXPAND=FALSE

  TYPE
    oct$new_library_module_list = record
      name: pmt$program_name,

      description: ^oct$module_description,
      changed_info: ^oct$changed_info,

      f_link: ^oct$new_library_module_list,
      b_link: ^oct$new_library_module_list,
      l_link: ^oct$new_library_module_list,
      r_link: ^oct$new_library_module_list,
      t_link: ^oct$new_library_module_list,
    recend;

*copyc oct$changed_info
*copyc oct$module_description
*copyc pmt$program_name
*DECK DECK=OCT$NEW_ORDINAL_LIST EXPAND=FALSE
  TYPE
    oct$new_ordinal_list = array [0 .. * ] of llt$section_ordinal;

*copyc llt$section_address
*DECK DECK=OCT$NLM_MODIFICATION_LIST EXPAND=FALSE

  TYPE
    oct$nlm_modification_list = record
      nlm: ^oct$new_library_module_list,
      link: ^oct$nlm_modification_list,
    recend;

*copyc oct$new_library_module_list
*DECK DECK=OCT$NLM_REPLACEMENT_LIST EXPAND=FALSE

  TYPE
    oct$nlm_replacement_list = record
      nlm: ^oct$new_library_module_list,
      description: ^oct$module_description,
      link: ^oct$nlm_replacement_list,
    recend;

*copyc oct$module_description
*copyc oct$new_library_module_list
*DECK DECK=OCT$OBJECT_CODE_UTILITY_TYPES EXPAND=FALSE
*copyc occ$retain
*copyc oct$address_formulation_item
*copyc oct$address_formulation_list
*copyc oct$bound_components
*copyc oct$bound_module_components
*copyc oct$bound_module_header
*copyc oct$changed_info
*copyc oct$code_section_ids
*copyc oct$component_information
*copyc oct$component_list
*copyc oct$cpu_object_module_header
*copyc oct$debug_table
*copyc oct$debug_tables
*copyc oct$display_toggles
*copyc oct$entry_definition_list
*copyc oct$entry_point_sorted_list
*copyc oct$external_declaration_list
*copyc oct$external_linkage_item
*copyc oct$external_linkage_list
*copyc oct$external_reference_list
*copyc oct$file_type
*copyc oct$header
*copyc oct$library_list
*copyc oct$load_module_list
*copyc oct$module_description
*copyc oct$module_kind
*copyc oct$module_kinds
*copyc oct$name_list
*copyc oct$new_binding_template_list
*copyc oct$new_library_module_list
*copyc oct$nlm_modification_list
*copyc oct$nlm_replacement_list
*copyc oct$old_binding_template_list
*copyc oct$old_relocation_list
*copyc oct$old_section_list
*copyc oct$olg_scratch_seq
*copyc oct$olg_working_heap
*copyc oct$open_file_list
*copyc oct$relocation_item_list
*copyc oct$relocation_list
*copyc oct$section_definitions
*copyc oct$section_definition_list
*copyc oct$segment_relocation_info
*copyc oct$separated_components
*copyc oct$separated_module_header
*copyc oct$temporary_module_header
*copyc oct$text_insertion_list
*copyc oct$working_file_list
*DECK DECK=OCT$OBJECT_FILE_DESCRIPTOR EXPAND=FALSE

  TYPE
    oct$object_file_descriptor = record
      link: ^oct$object_file_descriptor,
      name: ^fst$file_reference,
      id: amt$file_identifier,
      segment: amt$segment_pointer,
      r1: ost$ring,
      r2: ost$ring,
      r3: ost$ring,
      global_key: ost$key_lock_value,
      local_key: ost$key_lock_value,
      execute_privilege: ost$execute_privilege,
      default_sections: ^oct$default_sections,

      case is_a_library: boolean of
      = TRUE =
        module_dictionary: ^llt$module_dictionary,
        entry_point_dictionary: ^llt$entry_point_dictionary,
      = FALSE =
        ,
      casend,
    recend;

  TYPE
    oct$default_sections = array [1 .. * ] of oct$default_section,

    oct$default_section = record
      name: pmt$program_name,
      attributes: llt$section_access_attributes,
    recend;

*copyc amt$file_identifier
*copyc amt$segment_pointer
*copyc fst$file_reference
*copyc llt$entry_point_dictionary
*copyc llt$module_dictionary
*copyc llt$section_access_attributes
*copyc osd$virtual_address
*copyc ost$segment_access_control
*DECK DECK=OCT$OBJECT_RECORD_LIST EXPAND=FALSE

  TYPE
    oct$object_record_list = record
      link: ^oct$object_record_list,

      case kind: llt$object_record_kind of
      = llc$identification =
        identification: ^llt$identification,

      = llc$libraries =
        libraries: ^llt$libraries,

      = llc$section_definition =
        section_definition: ^llt$section_definition,

      = llc$text =
        text: ^llt$text,

      = llc$replication =
        replication: ^llt$replication,

      = llc$bit_string_insertion =
        bit_string_insertion: ^llt$bit_string_insertion,

      = llc$entry_definition =
        entry_definition: ^llt$entry_definition,

      = llc$relocation =
        relocation: ^llt$relocation,

      = llc$address_formulation =
        address_formulation: ^llt$address_formulation,

      = llc$external_linkage =
        external_linkage: ^llt$external_linkage,

      = llc$formal_parameters =
        formal_parameters: ^llt$formal_parameters,

      = llc$actual_parameters =
        actual_parameters: ^llt$actual_parameters,

      = llc$cybil_symbol_table_fragment =
        debug_table_fragment: ^llt$debug_table_fragment,

      = llc$obsolete_line_table =
        obsolete_line_address_table: ^llt$obsolete_line_address_table,

      = llc$symbol_table =
        symbol_table: ^llt$symbol_table,

      = llc$line_table =
        line_address_table: ^llt$line_address_table,

      = llc$supplemental_debug_tables =
        supplemental_debug_tables: ^llt$supplemental_debug_tables,

      = llc$binding_template =
        binding_template: ^llt$binding_template,

      = llc$ppu_absolute =
        ppu_absolute: ^llt$ppu_absolute,

      = llc$68000_absolute =
        m68000_absolute: ^llt$68000_absolute,

      = llc$transfer_symbol =
        transfer_symbol: ^llt$transfer_symbol,
      casend,
    recend;

*copyc llt$object_module
*copyc llt$line_address_table
*copyc llt$obsolete_line_table
*DECK DECK=OCT$OFFSET EXPAND=FALSE
  TYPE
    oct$offset = 0 .. 0ffffffff(16);

*DECK DECK=OCT$OFFSET_CHANGE_LIST EXPAND=FALSE
  TYPE
    oct$offset_change_list = array [1 .. * ] of oct$change_items,

    oct$change_items = record
      offset: llt$section_offset,
      delta: llt$section_address_range,
    recend,

    oct$max_offset_changes = 0 .. 0ffff(16);

*copyc llt$section_address
*DECK DECK=OCT$OLD_BINDING_TEMPLATE_LIST EXPAND=FALSE

  TYPE
    oct$old_binding_template_list = ^array [0 .. * ] of
          oct$old_binding_template_item,

    oct$old_binding_template_item = record
      binding_template: ^llt$binding_template,
      case referenced_in_new_binding_sect: boolean of
      = TRUE =
        new_binding_section_offset: llt$section_offset,
      = FALSE =
        ,
      casend,
    recend;

*copyc llt$binding_template
*copyc llt$section_address
*DECK DECK=OCT$OLD_RELOCATION_LIST EXPAND=FALSE

  TYPE
    oct$old_relocation_list = record
      byte: oct$relocation_item_list,
      two_byte: oct$relocation_item_list,
      four_byte: oct$relocation_item_list,
      eight_byte: oct$relocation_item_list,
    recend;

*copyc oct$relocation_item_list
*DECK DECK=OCT$OLD_SECTION_LIST EXPAND=FALSE

  TYPE
    oct$old_section_list = record
      component: ^oct$separated_module_header,
      section_ordinal: llt$section_ordinal,
      link: ^oct$old_section_list,
    recend;

*copyc llt$section_address
*copyc oct$separated_module_header
*DECK DECK=OCT$OLG_SCRATCH_SEQ EXPAND=FALSE
  TYPE
    oct$olg_scratch_seq = SEQ ( * );

*DECK DECK=OCT$OLG_WORKING_HEAP EXPAND=FALSE
  TYPE
    oct$olg_working_heap = HEAP ( * );

*DECK DECK=OCT$OPEN_FILE_LIST EXPAND=FALSE

  TYPE
    oct$open_file_list = record
      name: amt$local_file_name,
      identifier: amt$file_identifier,
      kind: oct$file_type,

      current_module: 1 .. llc$max_modules_in_library + 1,
      directory: ^array [1 .. * ] of oct$module_description,

      entry_point_dictionary: ^llt$entry_point_dictionary,

      link: ^oct$open_file_list,
    recend;


*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc llt$entry_point_dictionary
*copyc llt$module_dictionary
*copyc oct$file_type
*copyc oct$module_description



*DECK DECK=OCT$OUTPUT_SEGMENT_DESCRIPTOR EXPAND=FALSE

  TYPE
    oct$output_segment_descriptor = record
      name: ost$name,
      used_attributes: oct$segment_attributes,
      unused_attributes: oct$segment_attributes,
      extensible_attribute: oct$extensible_attributes,
      r1: ost$ring,
      r2: ost$ring,
      r3: ost$ring,
      global_key: ost$key_lock_value,
      local_key: ost$key_lock_value,
      retained_common_block: boolean,
      number_predefined: boolean,
      number: oct$segment,
      binding_section_encountered: boolean,
      binding_section_segment: ost$segment,
      binding_section_offset: ost$segment_length,
      section_ordinal: llt$section_ordinal,
      number_of_bytes_written: ost$segment_length,
      relocation_list: oct$segment_relocation_list,
      sections_allocated: oct$program_name_list,
      inhibit_binding_check: boolean,
      cybil_default_heap: boolean,
      id: amt$file_identifier,
      segment: amt$segment_pointer,
      offset: 0 .. osc$max_segment_length - 1,
      link: ^oct$output_segment_descriptor,
    recend;

  TYPE
    oct$segment_relocation_list = record
      link: ^oct$segment_relocation_list,
      pva: ^ost$pva,
    recend;

  TYPE
    oct$extensible_attributes = (occ$unallocated_extensible,
          occ$allocated_extensible, occ$non_extensible);

*copyc amt$file_identifier
*copyc amt$segment_pointer
*copyc llt$section_address
*copyc oct$program_name_list
*copyc oct$segment
*copyc oct$segment_attributes
*copyc osd$virtual_address
*copyc ost$name
*DECK DECK=OCT$PREDICTOR_HEADER EXPAND=FALSE
  TYPE
    oct$predictor_header = record
      size_predictor: oct$predictor_size,
      number_module_predictors: llt$module_index,
      number_of_mod_ocv_elements: oct$max_offset_changes,
      mod_dictionary_ocv: REL (oct$predictor) ^oct$offset_change_list,
      number_of_ol_ocv_elements: oct$max_offset_changes,
      ol_dictionary_ocv: REL (oct$predictor) ^oct$offset_change_list,
    recend,

    oct$predictor = SEQ ( * );

*copyc llt$module_dictionary
*copyc oct$offset_change_list
*copyc oct$predictor_size
*DECK DECK=OCT$PREDICTOR_SIZE EXPAND=FALSE
  TYPE
    oct$predictor_size = 0 .. occ$max_predictor_size;

  CONST
    occ$max_predictor_size = 7fffffff(16);
*DECK DECK=OCT$PROGRAM_NAME_LIST EXPAND=FALSE

  TYPE
    oct$program_name_list = record
      name: pmt$program_name,
      link: ^oct$program_name_list,
    recend;

*copyc pmt$program_name
*DECK DECK=OCT$RELOCATION_ITEM_LIST EXPAND=FALSE

  TYPE
    oct$relocation_item_list = record
      item: ^llt$relocation_item,
      link: ^oct$relocation_item_list,
    recend;

*copyc llt$relocation
*DECK DECK=OCT$RELOCATION_LIST EXPAND=FALSE

  TYPE
    oct$relocation_list = record
      link: ^oct$relocation_list,
      relocation_item: llt$relocation_item,
    recend;

*copyc llt$relocation
*DECK DECK=OCT$RETURN_FILE_LIST EXPAND=FALSE

  TYPE
    oct$return_file_list = record
      file_name: ^fst$file_reference,
      link: ^oct$return_file_list,
    recend;

*copyc fst$file_reference
*DECK DECK=OCT$SECTION_DEFINITIONS EXPAND=FALSE

  TYPE
    oct$section_definitions = array [0 .. * ] of ^oct$section_definition,

    oct$section_definition = record
      section_definition: llt$section_definition,
      new: ^oct$section_definition_list,
      unallocated_common_block: boolean,
      allotted_section: boolean,
      allotted_section_length: ost$segment_length,
      new_section_offset: llt$section_offset,
      text: ^llt$code_element,
      text_insertion_records: oct$text_insertion_list,
      last_text_insertion_record: ^oct$text_insertion_list,
      last_text_insertion_point: ^oct$text_insertion_list,
      predefined_segment: boolean,
      predefined_segment_number: ost$segment,
      predefined_r1: ost$ring,
      predefined_r2: ost$ring,
      predefined_binding_ordinal: llt$section_ordinal,
      predefined_binding_offset: llt$section_address_range,
    recend;

*copyc llt$information_element
*copyc llt$section_address
*copyc llt$section_definition
*copyc oct$section_definition_list
*copyc oct$text_insertion_list
*copyc osd$virtual_address

*DECK DECK=OCT$SECTION_DEFINITION_LIST EXPAND=FALSE

  TYPE
    oct$section_definition_list = record
      link: ^oct$section_definition_list,
      section_definition: llt$section_definition,
      section_ptr: ^llt$code_element,
      old_sections: oct$old_section_list,
      last_old_section: ^oct$old_section_list,
      unallocated_common_block: boolean,
      allotted_section: boolean,
      allotted_section_length: ost$segment_length,
      text_insertion_records: oct$text_insertion_list,
      predefined_segment: boolean,
      predefined_segment_number: ost$segment,
      predefined_r1: ost$ring,
      predefined_r2: ost$ring,
      predefined_binding_ordinal: llt$section_ordinal,
      predefined_binding_offset: llt$section_address_range,
    recend;

*copyc llt$information_element
*copyc llt$section_address
*copyc llt$section_definition
*copyc oct$old_section_list
*copyc oct$text_insertion_list
*copyc osd$virtual_address
*DECK DECK=OCT$SECTION_DIRECTORY EXPAND=FALSE
  TYPE
    oct$section_directory = array [0 .. * ] of oct$section_directory_item,

    oct$section_directory_item = record
      new_section_number: llt$section_ordinal,
      section_offset_change_vector: ^oct$offset_change_list,
    recend;

*copyc llt$section_address
*copyc oct$offset_change_list
*DECK DECK=OCT$SECTION_LIST EXPAND=FALSE
  TYPE
    oct$section_list = array [0 .. * ] of oct$section_item,

    oct$section_item = record
      found: boolean,
      allotted: boolean,
      kind: llt$section_kind,
      access_attributes: llt$section_access_attributes,
      name: pmt$program_name,
    recend;

*copyc llt$section_kind
*copyc llt$section_access_attributes
*copyc pmt$program_name
*DECK DECK=OCT$SECTION_NAME_LIST EXPAND=FALSE

  TYPE
    oct$section_name_list = record
      name: pmt$program_name,
      segment_descriptor: ^oct$output_segment_descriptor,
      link: ^oct$section_name_list,
    recend;

*copyc pmt$program_name
*copyc oct$output_segment_descriptor
*DECK DECK=OCT$SECTION_OFFSET_CHANGES EXPAND=FALSE
  TYPE
    oct$section_offset_changes = record
      header: oct$section_info,
      change_list: oct$offset_change_list,
    recend,

    oct$section_info = record
      section_ordinal: llt$section_ordinal,
      number_of_socv_items: llt$section_length,
      section_kind: llt$section_kind,
    recend;

*copyc llt$section_address
*copyc llt$section_kind
*copyc oct$offset_change_list

*DECK DECK=OCT$SEGMENT EXPAND=FALSE

  TYPE
    oct$segment = 0 .. occ$null_seg_value;

  CONST
    occ$null_seg_value = 0ffff(16);

*DECK DECK=OCT$SEGMENT_ATTRIBUTES EXPAND=FALSE

  TYPE
    oct$segment_attribute = (occ$sa_read, occ$sa_read_kl, occ$sa_binding,
          occ$sa_write, occ$sa_write_kl, occ$sa_non_privileged,
          occ$sa_local_privilege, occ$sa_global_privilege, occ$sa_cache_bypass,
          occ$sa_extensible, occ$sa_wired, occ$sa_shared, occ$sa_fixed,
          occ$sa_stack, occ$sa_read_transfer_unit, occ$sa_free_behind,
          occ$sa_no_append),

    oct$segment_attributes = set of oct$segment_attribute;

*DECK DECK=OCT$SEGMENT_RELOCATION_INFO EXPAND=FALSE
  TYPE
    oct$segment_rel_information = record
      old_offset: ost$segment_length,
      new_offset: ost$segment_length,
      text: ^array [1 .. * ] of 0 .. 0ff(16),
    recend;

  TYPE
    oct$segment_relocation_info = array [0 .. * ] of
          oct$segment_rel_information;

*copyc osd$virtual_address
*DECK DECK=OCT$SEPARATED_COMPONENTS EXPAND=FALSE

  TYPE
    oct$separated_components = array [1 .. * ] of oct$separated_module_header;

*copyc oct$separated_module_header
*DECK DECK=OCT$SEPARATED_MODULE_HEADER EXPAND=FALSE

  TYPE
    oct$separated_module_header = record
      component_number: 1 .. llc$max_components,
      file: ^SEQ ( * ),
      header: ^llt$identification,
      application_identifier: ^llt$application_identifier,
      starting_procedure: pmt$program_name,

      library_list: oct$library_list,

      section_definitions: ^oct$section_definitions,
      deferred_common_blocks: ^llt$deferred_common_blocks,
      entry_definition_list: oct$entry_definition_list,
      deferred_entry_points: ^llt$deferred_entry_points,
      external_linkage_list: ^oct$external_linkage_list,
      actual_parameter_list: oct$actual_parameter_list,
      address_formulation_list: ^oct$address_formulation_list,

      miscellaneous_record_list: oct$object_record_list,

      relocation_list: oct$old_relocation_list,
      binding_template_list: oct$old_binding_template_list,
      number_of_template_items: llt$number_of_info_elements,

      components: ^oct$component_information,
      section_maps: ^llt$section_maps,
    recend;

*copyc llt$application_identifier
*copyc llt$deferred_common_blocks
*copyc llt$deferred_entry_points
*copyc llt$identification
*copyc llt$information_element
*copyc oct$actual_parameter_list
*copyc oct$address_formulation_list
*copyc oct$component_information
*copyc oct$entry_definition_list
*copyc oct$external_linkage_list
*copyc oct$library_list
*copyc oct$object_record_list
*copyc oct$old_binding_template_list
*copyc oct$old_relocation_list
*copyc oct$section_definitions
*copyc pmt$program_name
*DECK DECK=OCT$SINGLE_MODULE_PREDICTOR_HDR EXPAND=FALSE
  TYPE
    oct$single_module_predictor_hdr = record
      predictor_size: oct$module_predictor_size,
      module_name: pmt$program_name,
      CASE kind: llt$library_module_kind OF
      = llc$load_module =
        last_section_ordinal: llt$section_ordinal,
        section_number_cv: REL (oct$module_predictor) ^oct$new_ordinal_list,
        length_normal_section_ocv: llt$section_ordinal,
        section_offset_cv: REL (oct$module_predictor)
          ^oct$section_offset_changes,
        length_binding_socv: llt$section_ordinal,
        binding_section_ordinal: llt$section_ordinal,
        binding_section_ocv: REL (oct$module_predictor)
          ^oct$offset_change_list,
        length_component_index_cv: 0 .. llc$max_components,
        component_index_cv: REL (oct$module_predictor) ^array [1 .. * ] of 0 .. llc$max_components,
      = llc$message_module =
        last_name_index: ost$message_template_index,
        length_message_template_cv: llt$section_ordinal,
        message_template_cv: REL (oct$module_predictor) ^oct$offset_change_list,
      = llc$ppu_object_module, llc$program_description, llc$command_procedure,
            llc$function_procedure, llc$panel_module =
        ,
      CASEND,
    recend,

    oct$module_predictor = SEQ ( * );

*copyc pmt$program_name
*copyc llt$section_address
*copyc llt$library_module_kind
*copyc oct$new_ordinal_list
*copyc oct$module_predictor_size
*copyc oct$section_offset_changes
*copyc oct$offset_change_list
*copyc ost$message_template_index
*DECK DECK=OCT$SYMBOL_TABLE_DESCRIPTOR EXPAND=FALSE

  TYPE
    oct$symbol_table_descriptor = record
      name: ^fst$file_reference,
      id: amt$file_identifier,
      segment: amt$segment_pointer,
      header: ^oct$symbol_table_header,
      symbol_table: ^oct$list_of_entry_points,
      link: ^oct$symbol_table_descriptor,
    recend;

*copyc amt$file_identifier
*copyc amt$segment_pointer
*copyc fst$file_reference
*copyc oct$list_of_entry_points
*copyc oct$symbol_table_header
*DECK DECK=OCT$SYMBOL_TABLE_HEADER EXPAND=FALSE

  CONST
    occ$maximum_externals = 0ffffffff(16);

  TYPE
    oct$symbol_table_header = record
      version: string (9),
      id: ost$name,
      number_of_symbols: 0 .. occ$maximum_externals,
    recend;

*copyc ost$name
*DECK DECK=OCT$TASK_SERVICES_ENTRY_POINT EXPAND=FALSE
  TYPE
    oct$task_services_entry_point = record
      ep: lot$task_services_entry_point,
      fill: 0 .. 0ffffffffff(16),
    recend;

*copyc lot$task_services_entry_point
*DECK DECK=OCT$TEMPORARY_MODULE_HEADER EXPAND=FALSE

  TYPE
    oct$temporary_module_header = record
      identification: llt$identification,
      application_identifier: ^llt$application_identifier,
      starting_procedure: pmt$program_name,

      library_list: oct$name_list,

      section_definitions: oct$section_definition_list,
      deferred_common_blocks: ^llt$deferred_common_blocks,
      number_of_entry_definitions: llt$entry_point_index,
      entry_definition_list: oct$entry_definition_list,
      deferred_entry_points: ^llt$deferred_entry_points,
      actual_parameter_list: oct$actual_parameter_list,
      external_linkage_list: ^oct$external_linkage_list,
      external_linkage_items: oct$external_linkage_item,
      address_formulation_list: ^oct$address_formulation_list,
      address_formulation_items: oct$address_formulation_item,

      miscellaneous_record_list: oct$object_record_list,

      number_of_rel_items: llt$number_of_info_elements,
      relocation_list: oct$relocation_list,

      number_of_template_items: llt$number_of_info_elements,
      binding_template_list: oct$new_binding_template_list,

      component_info: ^llt$component_information,
      include_binary_section_maps: boolean,
    recend;

*copyc llt$application_identifier
*copyc llt$deferred_common_blocks
*copyc llt$deferred_entry_points
*copyc llt$entry_point_dictionary
*copyc llt$identification
*copyc llt$information_element
*copyc oct$actual_parameter_list
*copyc oct$address_formulation_item
*copyc oct$address_formulation_list
*copyc oct$entry_definition_list
*copyc oct$external_linkage_item
*copyc oct$external_linkage_list
*copyc oct$name_list
*copyc oct$new_binding_template_list
*copyc oct$object_record_list
*copyc oct$relocation_list
*copyc oct$section_definition_list
*copyc pmt$program_name
*DECK DECK=OCT$TEXT_INSERTION_LIST EXPAND=FALSE

  TYPE
    oct$text_insertion_list = record
      offset: llt$section_offset,
      bit_offset: 0 .. 7,
      length: 1 .. osc$max_segment_length,
      starting_bit_offset: integer,
      ending_bit_offset: integer,
      overlapped: boolean,
      link: ^oct$text_insertion_list,

      case kind: llt$object_record_kind of
      = llc$text =
        text: ^llt$text,

      = llc$replication =
        replication: ^llt$replication,

      = llc$bit_string_insertion =
        bit_string_insertion: ^llt$bit_string_insertion,

      casend,
    recend;

*copyc llt$bit_string_insertion
*copyc llt$object_record_kind
*copyc llt$replication
*copyc llt$section_address
*copyc llt$text
*copyc osd$virtual_address

*DECK DECK=OCT$WORKING_FILE_LIST EXPAND=FALSE
  TYPE
    oct$working_file_list = record
      current_file: ^oct$working_file,
      first_working_file: oct$working_file,
    recend;


  TYPE
    oct$working_file = record
      descriptor: ^oct$open_file_list,
      link: ^oct$working_file,
    recend;

*copyc oct$open_file_list
*DECK DECK=OCV$GLOBAL_DISPLAY_TOGGLES EXPAND=FALSE
  VAR
    ocv$global_display_toggles: [XREF] oct$display_toggles;

?? PUSH (LISTEXT := ON) ??
*copyc oct$display_toggles
?? POP ??
*DECK DECK=OCV$MODULE_ATTRIBUTE_KEYS EXPAND=FALSE
  VAR
    ocv$module_attribute_keys: [XREF, READ, ocs$literals] array
          [1 .. occ$kwd_maximum] of record
      attribute: oct$module_attribute_keywords,
      name: ost$name,
    recend;

*copyc ost$name
*copyc ocs$literals
*copyc oct$module_attribute_keywords
*DECK DECK=OCV$NEXT_AVAILABLE_SEGMENT EXPAND=FALSE

  VAR
    ocv$next_available_segment: [XREF] ost$segment;

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
?? POP ??
*DECK DECK=OCV$NLM_LIST EXPAND=FALSE
VAR
  ocv$nlm_list: [XREF] ^oct$new_library_module_list;
?? PUSH (LISTEXT := ON) ??
*copyc oct$new_library_module_list
?? POP ??
*DECK DECK=OCV$OLG_SCRATCH_SEQ EXPAND=FALSE
VAR
  ocv$olg_scratch_seq: [XREF] ^oct$olg_scratch_seq;

?? PUSH (LISTEXT := ON) ??
*copyc oct$olg_scratch_seq
?? POP ??
*DECK DECK=OCV$OLG_WORKING_HEAP EXPAND=FALSE
  VAR
    ocv$olg_working_heap: [XREF] ^oct$olg_working_heap;

?? PUSH (LISTEXT := ON) ??
*copyc oct$olg_working_heap
?? POP ??
*DECK DECK=OCV$OPEN_FILE_LIST EXPAND=FALSE
  VAR
    ocv$open_file_list: [XREF] oct$open_file_list;

?? PUSH (LISTEXT := ON) ??
*copyc oct$open_file_list
?? POP ??
*DECK DECK=OCV$PREDEFINED_SEGMENT_LIST EXPAND=FALSE

  VAR
    ocv$predefined_segment_list: [XREF] oct$output_segment_descriptor;

?? PUSH (LISTEXT := ON) ??
*copyc oct$output_segment_descriptor
?? POP ??
*DECK DECK=OCV$RETURN_FILE_LIST EXPAND=FALSE

  VAR
    ocv$return_file_list: [XREF] ^oct$return_file_list;

?? PUSH (LISTEXT := ON) ??
*copyc oct$return_file_list
?? POP ??
*DECK DECK=OCV$SECTION_NAME_LIST EXPAND=FALSE

  VAR
    ocv$section_name_list: [XREF] oct$section_name_list;

?? PUSH (LISTEXT := ON) ??
*copyc oct$section_name_list
?? POP ??
*DECK DECK=OCV$VEL_SCRATCH_SEQ EXPAND=FALSE

  VAR
    ocv$vel_scratch_seq: [XREF] ^SEQ ( * );

*DECK DECK=OFC$BASE_ERROR EXPAND=FALSE
*copyc ofc$condition_limits

  CONST
    ofc$base_error = ofc$min_ecc;
*DECK DECK=OFC$CONDITION_LIMITS EXPAND=FALSE

  CONST
*IF $true(osv$unix)
    ofc$min_ecc = (($INTEGER ('O') * 100(16)) +  $INTEGER ('F')) * 10000(16),
*ELSE
    ofc$min_ecc = (($INTEGER ('O') * 100(16)) +  $INTEGER ('F')) * 1000000(16),
*IFEND
    ofc$max_ecc = ofc$min_ecc + 4999;

*DECK DECK=OFC$MAX_DISPLAY_MESSAGE EXPAND=FALSE
  CONST
    ofc$max_display_message = 64;
*DECK DECK=OFC$MAX_MESSAGES_PER_JOB EXPAND=FALSE

  CONST
    ofc$max_messages_per_job = 5;
*DECK DECK=OFC$OPERATOR_BREAK_FLAG EXPAND=FALSE
*DECK DECK=OFC$OPERATOR_IDS EXPAND=FALSE

  CONST
    ofc$system_operator_id = 'SYSTEM_OPERATOR',
    ofc$tape_operator_id = 'TAPE_OPERATOR';
*DECK DECK=OFC$PAGE_WIDTH EXPAND=FALSE

  CONST
    ofc$page_width = 80;
*DECK DECK=OFC$SIGNAL_CONTENTS EXPAND=FALSE

{These values define the signal internal processing values.
{   ofc$break_id            is used for break processing.
{   ofc$operator_message_id is used to identify an operator message.

  CONST
    ofc$break_id = 220,
    ofc$operator_message_id = 240;
*DECK DECK=OFD$ERROR_TITLE EXPAND=FALSE

?? NEWTITLE := 'OFDECC  : Operator Facility       : ''OF'' 0 .. 9999' ??
*copyc OFE$ERROR_CODES
?? OLDTITLE ??
*DECK DECK=OFD$PDT_CHANGE_INIT_JOB_DISPLAY EXPAND=FALSE
{
{
{  PROCEDURE (osm$vedu_chaijd) change_initiated_job_display, chaijd (
{     name, n: name = $required
{     alias, a: (BY_NAME) name
{     delete_fields, delete_field, df: (BY_NAME) range of name
{     replace_fields, replace_field, rf: (BY_NAME) range of name
{     insert_before, ib: (BY_NAME) name
{     insert_after, ia: (BY_NAME) name
{     fields, field, f: (BY_NAME) list of record
{   field_name: key
{                    (active_io_pages, aip)
{                    (active_io_requests, air)
{                    (ajl_ordinal, ajlo, ao)
{                    (cpu_time_increment, cti)
{                    (cpu_time_job, ctj)
{                    (cpu_time_monitor, ctm)
{                    (cpu_time_total, ctt)
{                    (dispatching_priority, dp)
{                    (dispatching_priority_actual, dpa)
{                    (display_message, command, dm, c)
{                    (fill f)
{                    (guaranteed_service_remaining, gsr)
{                    (hung_task, ht)
{                    (ijl_ordinal, ijlo, io)
{                    (job_class, jc)
{                    (job_entry_status jes)
{                    (job_mode, jm)
{                    (job_priority, jp)
{                    (job_status, js)
{                    (job_swap_count, jsc)
{                    (last_think_time, ltt)
{                    (memory_pages, mp)
{                    (page_fault_count, pfc)
{                    (page_in, pi)
{                    (pages_assigned, pa)
{                    (pages_server, ps)
{                    (pages_reclaimed, pr)
{                    (percent_cpu_usage, pcu)
{                    (permanent_file_space, pfs)
{                    (ready_task_count, rtc)
{                    (service_accumulator, sa)
{                    (service_class, sc)
{                    (service_since_swap, sss)
{                    (system_job_name, sjn)
{                    (system_job_name_long, sjnl)
{                    (system_job_name_short, sjns)
{                    (swap_entry_status, ses)
{                    (swap_in_wait_time, siwt)
{                    (swap_reason, sr)
{                    (swap_status, ss)
{                    (temporary_file_space, tfs)
{                    (terminal_name, tn)
{                    (think_time, tt)
{                    (thrashing_flag, tf)
{                    (time_in_swap_state, tiss)
{                    (user_job_name, ujn)
{                    (working_set_size, wss)
{                      keyend
{         field_width: integer 1 .. 130 = $optional
{         field_title: string 1 .. 31 = $optional
{         scale: integer 1 .. 1000000000 = $optional
{         field_overflow_action: key (scale s) (maximum max) (asterisk a) keyend = $optional
{         numeric_display_mode: key (incremental i) (total t) keyend = $optional
{         field_selection: key (unconditional u) (active a) (swapped s) keyend = $optional
{         non_selection_action: key (skip s) (blank b) keyend = $optional
{       recend
{     job_selection, js: (BY_NAME) key
{          (active, a)  (initiated i) keyend
{     jobs_per_line, jpl: (BY_NAME) integer 1..130
{     display_system_line, dsl: (BY_NAME) boolean
{     display_blank_lines, dbl: (BY_NAME) boolean
{     title, t: (BY_NAME) string 1..130
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 28] of clt$pdt_parameter_name,
      parameters: array [1 .. 13] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$range_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$range_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 98] of clt$keyword_specification,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_5: clt$field_specification,
          element_type_spec_5: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 6] of clt$keyword_specification,
          recend,
          field_spec_6: clt$field_specification,
          element_type_spec_6: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 4] of clt$keyword_specification,
          recend,
          field_spec_7: clt$field_specification,
          element_type_spec_7: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 6] of clt$keyword_specification,
          recend,
          field_spec_8: clt$field_specification,
          element_type_spec_8: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 4] of clt$keyword_specification,
          recend,
        recend,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
      type11: record
        header: clt$type_specification_header,
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type13: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 9, 29, 13, 44, 41, 673],
    clc$command, 28, 13, 1, 0, 0, 0, 13, 'OSM$VEDU_CHAIJD'], [
    ['A                              ',clc$abbreviation_entry, 2],
    ['ALIAS                          ',clc$nominal_entry, 2],
    ['DBL                            ',clc$abbreviation_entry, 11],
    ['DELETE_FIELD                   ',clc$alias_entry, 3],
    ['DELETE_FIELDS                  ',clc$nominal_entry, 3],
    ['DF                             ',clc$abbreviation_entry, 3],
    ['DISPLAY_BLANK_LINES            ',clc$nominal_entry, 11],
    ['DISPLAY_SYSTEM_LINE            ',clc$nominal_entry, 10],
    ['DSL                            ',clc$abbreviation_entry, 10],
    ['F                              ',clc$abbreviation_entry, 7],
    ['FIELD                          ',clc$alias_entry, 7],
    ['FIELDS                         ',clc$nominal_entry, 7],
    ['IA                             ',clc$abbreviation_entry, 6],
    ['IB                             ',clc$abbreviation_entry, 5],
    ['INSERT_AFTER                   ',clc$nominal_entry, 6],
    ['INSERT_BEFORE                  ',clc$nominal_entry, 5],
    ['JOBS_PER_LINE                  ',clc$nominal_entry, 9],
    ['JOB_SELECTION                  ',clc$nominal_entry, 8],
    ['JPL                            ',clc$abbreviation_entry, 9],
    ['JS                             ',clc$abbreviation_entry, 8],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['REPLACE_FIELD                  ',clc$alias_entry, 4],
    ['REPLACE_FIELDS                 ',clc$nominal_entry, 4],
    ['RF                             ',clc$abbreviation_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 13],
    ['T                              ',clc$abbreviation_entry, 12],
    ['TITLE                          ',clc$nominal_entry, 12]],
    [
{ PARAMETER 1
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 12, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 12, clc$optional_parameter,
  0, 0],
{ PARAMETER 5
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 6
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 7
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 4760,
  clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 10
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 11
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 12
    [28, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 13
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$range_type], [5],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 4
    [[1, 0, clc$range_type], [5],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 5
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 6
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 7
    [[1, 0, clc$list_type], [4744, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$record_type], [8],
      ['FIELD_NAME                     ', clc$required_field, 3633], [[1, 0, clc$keyword_type], [98], [
        ['ACTIVE_IO_PAGES                ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['ACTIVE_IO_REQUESTS             ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['AIP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['AIR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['AJLO                           ', clc$alias_entry, clc$normal_usage_entry, 3],
        ['AJL_ORDINAL                    ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['AO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
        ['COMMAND                        ', clc$alias_entry, clc$normal_usage_entry, 10],
        ['CPU_TIME_INCREMENT             ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['CPU_TIME_JOB                   ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['CPU_TIME_MONITOR               ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['CPU_TIME_TOTAL                 ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['CTI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['CTJ                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['CTM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['CTT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
        ['DISPATCHING_PRIORITY           ', clc$nominal_entry, clc$normal_usage_entry, 8],
        ['DISPATCHING_PRIORITY_ACTUAL    ', clc$nominal_entry, clc$normal_usage_entry, 9],
        ['DISPLAY_MESSAGE                ', clc$nominal_entry, clc$normal_usage_entry, 10],
        ['DM                             ', clc$alias_entry, clc$normal_usage_entry, 10],
        ['DP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
        ['DPA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
        ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
        ['FILL                           ', clc$nominal_entry, clc$normal_usage_entry, 11],
        ['GSR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
        ['GUARANTEED_SERVICE_REMAINING   ', clc$nominal_entry, clc$normal_usage_entry, 12],
        ['HT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
        ['HUNG_TASK                      ', clc$nominal_entry, clc$normal_usage_entry, 13],
        ['IJLO                           ', clc$alias_entry, clc$normal_usage_entry, 14],
        ['IJL_ORDINAL                    ', clc$nominal_entry, clc$normal_usage_entry, 14],
        ['IO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
        ['JC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
        ['JES                            ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
        ['JM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
        ['JOB_CLASS                      ', clc$nominal_entry, clc$normal_usage_entry, 15],
        ['JOB_ENTRY_STATUS               ', clc$nominal_entry, clc$normal_usage_entry, 16],
        ['JOB_MODE                       ', clc$nominal_entry, clc$normal_usage_entry, 17],
        ['JOB_PRIORITY                   ', clc$nominal_entry, clc$normal_usage_entry, 18],
        ['JOB_STATUS                     ', clc$nominal_entry, clc$normal_usage_entry, 19],
        ['JOB_SWAP_COUNT                 ', clc$nominal_entry, clc$normal_usage_entry, 20],
        ['JP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
        ['JS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
        ['JSC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 20],
        ['LAST_THINK_TIME                ', clc$nominal_entry, clc$normal_usage_entry, 21],
        ['LTT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 21],
        ['MEMORY_PAGES                   ', clc$nominal_entry, clc$normal_usage_entry, 22],
        ['MP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 22],
        ['PA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 25],
        ['PAGES_ASSIGNED                 ', clc$nominal_entry, clc$normal_usage_entry, 25],
        ['PAGES_RECLAIMED                ', clc$nominal_entry, clc$normal_usage_entry, 27],
        ['PAGES_SERVER                   ', clc$nominal_entry, clc$normal_usage_entry, 26],
        ['PAGE_FAULT_COUNT               ', clc$nominal_entry, clc$normal_usage_entry, 23],
        ['PAGE_IN                        ', clc$nominal_entry, clc$normal_usage_entry, 24],
        ['PCU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 28],
        ['PERCENT_CPU_USAGE              ', clc$nominal_entry, clc$normal_usage_entry, 28],
        ['PERMANENT_FILE_SPACE           ', clc$nominal_entry, clc$normal_usage_entry, 29],
        ['PFC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 23],
        ['PFS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 29],
        ['PI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 24],
        ['PR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 27],
        ['PS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 26],
        ['READY_TASK_COUNT               ', clc$nominal_entry, clc$normal_usage_entry, 30],
        ['RTC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 30],
        ['SA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 31],
        ['SC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 32],
        ['SERVICE_ACCUMULATOR            ', clc$nominal_entry, clc$normal_usage_entry, 31],
        ['SERVICE_CLASS                  ', clc$nominal_entry, clc$normal_usage_entry, 32],
        ['SERVICE_SINCE_SWAP             ', clc$nominal_entry, clc$normal_usage_entry, 33],
        ['SES                            ', clc$abbreviation_entry, clc$normal_usage_entry, 37],
        ['SIWT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 38],
        ['SJN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 34],
        ['SJNL                           ', clc$abbreviation_entry, clc$normal_usage_entry, 35],
        ['SJNS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 36],
        ['SR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 39],
        ['SS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 40],
        ['SSS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 33],
        ['SWAP_ENTRY_STATUS              ', clc$nominal_entry, clc$normal_usage_entry, 37],
        ['SWAP_IN_WAIT_TIME              ', clc$nominal_entry, clc$normal_usage_entry, 38],
        ['SWAP_REASON                    ', clc$nominal_entry, clc$normal_usage_entry, 39],
        ['SWAP_STATUS                    ', clc$nominal_entry, clc$normal_usage_entry, 40],
        ['SYSTEM_JOB_NAME                ', clc$nominal_entry, clc$normal_usage_entry, 34],
        ['SYSTEM_JOB_NAME_LONG           ', clc$nominal_entry, clc$normal_usage_entry, 35],
        ['SYSTEM_JOB_NAME_SHORT          ', clc$nominal_entry, clc$normal_usage_entry, 36],
        ['TEMPORARY_FILE_SPACE           ', clc$nominal_entry, clc$normal_usage_entry, 41],
        ['TERMINAL_NAME                  ', clc$nominal_entry, clc$normal_usage_entry, 42],
        ['TF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 44],
        ['TFS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 41],
        ['THINK_TIME                     ', clc$nominal_entry, clc$normal_usage_entry, 43],
        ['THRASHING_FLAG                 ', clc$nominal_entry, clc$normal_usage_entry, 44],
        ['TIME_IN_SWAP_STATE             ', clc$nominal_entry, clc$normal_usage_entry, 45],
        ['TISS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 45],
        ['TN                             ', clc$abbreviation_entry, clc$normal_usage_entry, 42],
        ['TT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 43],
        ['UJN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 46],
        ['USER_JOB_NAME                  ', clc$nominal_entry, clc$normal_usage_entry, 46],
        ['WORKING_SET_SIZE               ', clc$nominal_entry, clc$normal_usage_entry, 47],
        ['WSS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 47]]
        ],
      ['FIELD_WIDTH                    ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1, 130, 10]],
      ['FIELD_TITLE                    ', clc$optional_field, 8], [[1, 0, clc$string_type], [1, 31, FALSE]],
      ['SCALE                          ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1, 1000000000,
  10]],
      ['FIELD_OVERFLOW_ACTION          ', clc$optional_field, 229], [[1, 0, clc$keyword_type], [6], [
        ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['ASTERISK                       ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['MAX                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['MAXIMUM                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['SCALE                          ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      ['NUMERIC_DISPLAY_MODE           ', clc$optional_field, 155], [[1, 0, clc$keyword_type], [4], [
        ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['INCREMENTAL                    ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['TOTAL                          ', clc$nominal_entry, clc$normal_usage_entry, 2]]
        ],
      ['FIELD_SELECTION                ', clc$optional_field, 229], [[1, 0, clc$keyword_type], [6], [
        ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['SWAPPED                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['UNCONDITIONAL                  ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      ['NON_SELECTION_ACTION           ', clc$optional_field, 155], [[1, 0, clc$keyword_type], [4], [
        ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['BLANK                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['SKIP                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ]
      ]
    ],
{ PARAMETER 8
    [[1, 0, clc$keyword_type], [4], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['INITIATED                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 9
    [[1, 0, clc$integer_type], [1, 130, 10]],
{ PARAMETER 10
    [[1, 0, clc$boolean_type]],
{ PARAMETER 11
    [[1, 0, clc$boolean_type]],
{ PARAMETER 12
    [[1, 0, clc$string_type], [1, 130, FALSE]],
{ PARAMETER 13
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$alias = 2,
      p$delete_fields = 3,
      p$replace_fields = 4,
      p$insert_before = 5,
      p$insert_after = 6,
      p$fields = 7,
      p$job_selection = 8,
      p$jobs_per_line = 9,
      p$display_system_line = 10,
      p$display_blank_lines = 11,
      p$title = 12,
      p$status = 13;

    VAR
      pvt: array [1 .. 13] of clt$parameter_value;
*DECK DECK=OFD$PDT_CREATE_INIT_JOB_DISPLAY EXPAND=FALSE
{
{    PROCEDURE (osm$vedu_creijd) create_initiated_job_display, creijd (
{       name, n: name = $required
{       alias, a: (BY_NAME) name
{       same_as, sa: (BY_NAME) name
{       fields, field, f: (BY_NAME) list of record
{    field_name: key
{     (active_io_pages, aip)
{     (active_io_requests, air)
{     (ajl_ordinal, ajlo, ao)
{     (cpu_time_increment, cti)
{     (cpu_time_job, ctj)
{     (cpu_time_monitor, ctm)
{     (cpu_time_total, ctt)
{     (dispatching_priority, dp)
{     (dispatching_priority_actual, dpa)
{     (display_message, command, dm, c)
{     (fill f)
{     (guaranteed_service_remaining, gsr)
{     (hung_task, ht)
{     (ijl_ordinal, ijlo, io)
{     (job_class, jc)
{     (job_entry_status jes)
{     (job_mode, jm)
{     (job_priority, jp)
{     (job_status, js)
{     (job_swap_count, jsc)
{     (last_think_time, ltt)
{     (memory_pages, mp)
{     (page_fault_count, pfc)
{     (page_in, pi)
{     (pages_assigned, pa)
{     (pages_server, ps)
{     (pages_reclaimed, pr)
{     (percent_cpu_usage, pcu)
{     (permanent_file_space, pfs)
{     (ready_task_count, rtc)
{     (service_accumulator, sa)
{     (service_class, sc)
{     (service_since_swap, sss)
{     (system_job_name, sjn)
{     (system_job_name_long, sjnl)
{     (system_job_name_short, sjns)
{     (swap_entry_status, ses)
{     (swap_in_wait_time, siwt)
{     (swap_reason, sr)
{     (swap_status, ss)
{     (temporary_file_space, tfs)
{     (terminal_name, tn)
{     (think_time, tt)
{     (thrashing_flag, tf)
{     (time_in_swap_state, tiss)
{     (user_job_name, ujn)
{     (working_set_size, wss)
{     keyend
{    field_width: integer 1 .. 130 = $optional
{    field_title: string 1 .. 31 = $optional
{    scale: integer 1 .. 1000000000 = $optional
{    field_overflow_action: key (scale s) (maximum max) (asterisk a) keyend = $optional
{    numeric_display_mode: key (incremental i) (total t) keyend = $optional
{    field_selection: key (unconditional u) (active a) (swapped s) keyend = $optional
{    non_selection_action: key (skip s) (blank b) keyend = $optional
{  recend
{       job_selection, js: (BY_NAME) key
{      (active, a) (initiated i)
{   keyend = active
{       jobs_per_line, jpl: (BY_NAME) integer 1..130 = 1
{       display_system_line, dsl: (BY_NAME) boolean = false
{       display_blank_lines, dbl: (BY_NAME) boolean = false
{       title, t: (BY_NAME) string 1..130
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 20] of clt$pdt_parameter_name,
      parameters: array [1 .. 10] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 98] of clt$keyword_specification,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_5: clt$field_specification,
          element_type_spec_5: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 6] of clt$keyword_specification,
          recend,
          field_spec_6: clt$field_specification,
          element_type_spec_6: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 4] of clt$keyword_specification,
          recend,
          field_spec_7: clt$field_specification,
          element_type_spec_7: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 6] of clt$keyword_specification,
          recend,
          field_spec_8: clt$field_specification,
          element_type_spec_8: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 4] of clt$keyword_specification,
          recend,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (6),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type7: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type8: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 9, 29, 13, 45, 14, 872],
    clc$command, 20, 10, 1, 0, 0, 0, 10, 'OSM$VEDU_CREIJD'], [
    ['A                              ',clc$abbreviation_entry, 2],
    ['ALIAS                          ',clc$nominal_entry, 2],
    ['DBL                            ',clc$abbreviation_entry, 8],
    ['DISPLAY_BLANK_LINES            ',clc$nominal_entry, 8],
    ['DISPLAY_SYSTEM_LINE            ',clc$nominal_entry, 7],
    ['DSL                            ',clc$abbreviation_entry, 7],
    ['F                              ',clc$abbreviation_entry, 4],
    ['FIELD                          ',clc$alias_entry, 4],
    ['FIELDS                         ',clc$nominal_entry, 4],
    ['JOBS_PER_LINE                  ',clc$nominal_entry, 6],
    ['JOB_SELECTION                  ',clc$nominal_entry, 5],
    ['JPL                            ',clc$abbreviation_entry, 6],
    ['JS                             ',clc$abbreviation_entry, 5],
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['SA                             ',clc$abbreviation_entry, 3],
    ['SAME_AS                        ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 10],
    ['T                              ',clc$abbreviation_entry, 9],
    ['TITLE                          ',clc$nominal_entry, 9]],
    [
{ PARAMETER 1
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 4760,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 6
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 7
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 8
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 9
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 10
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 4
    [[1, 0, clc$list_type], [4744, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$record_type], [8],
      ['FIELD_NAME                     ', clc$required_field, 3633], [[1, 0, clc$keyword_type], [98], [
        ['ACTIVE_IO_PAGES                ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['ACTIVE_IO_REQUESTS             ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['AIP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['AIR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['AJLO                           ', clc$alias_entry, clc$normal_usage_entry, 3],
        ['AJL_ORDINAL                    ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['AO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
        ['COMMAND                        ', clc$alias_entry, clc$normal_usage_entry, 10],
        ['CPU_TIME_INCREMENT             ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['CPU_TIME_JOB                   ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['CPU_TIME_MONITOR               ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['CPU_TIME_TOTAL                 ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['CTI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['CTJ                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['CTM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['CTT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
        ['DISPATCHING_PRIORITY           ', clc$nominal_entry, clc$normal_usage_entry, 8],
        ['DISPATCHING_PRIORITY_ACTUAL    ', clc$nominal_entry, clc$normal_usage_entry, 9],
        ['DISPLAY_MESSAGE                ', clc$nominal_entry, clc$normal_usage_entry, 10],
        ['DM                             ', clc$alias_entry, clc$normal_usage_entry, 10],
        ['DP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
        ['DPA                            ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
        ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
        ['FILL                           ', clc$nominal_entry, clc$normal_usage_entry, 11],
        ['GSR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 12],
        ['GUARANTEED_SERVICE_REMAINING   ', clc$nominal_entry, clc$normal_usage_entry, 12],
        ['HT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 13],
        ['HUNG_TASK                      ', clc$nominal_entry, clc$normal_usage_entry, 13],
        ['IJLO                           ', clc$alias_entry, clc$normal_usage_entry, 14],
        ['IJL_ORDINAL                    ', clc$nominal_entry, clc$normal_usage_entry, 14],
        ['IO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 14],
        ['JC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 15],
        ['JES                            ', clc$abbreviation_entry, clc$normal_usage_entry, 16],
        ['JM                             ', clc$abbreviation_entry, clc$normal_usage_entry, 17],
        ['JOB_CLASS                      ', clc$nominal_entry, clc$normal_usage_entry, 15],
        ['JOB_ENTRY_STATUS               ', clc$nominal_entry, clc$normal_usage_entry, 16],
        ['JOB_MODE                       ', clc$nominal_entry, clc$normal_usage_entry, 17],
        ['JOB_PRIORITY                   ', clc$nominal_entry, clc$normal_usage_entry, 18],
        ['JOB_STATUS                     ', clc$nominal_entry, clc$normal_usage_entry, 19],
        ['JOB_SWAP_COUNT                 ', clc$nominal_entry, clc$normal_usage_entry, 20],
        ['JP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 18],
        ['JS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 19],
        ['JSC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 20],
        ['LAST_THINK_TIME                ', clc$nominal_entry, clc$normal_usage_entry, 21],
        ['LTT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 21],
        ['MEMORY_PAGES                   ', clc$nominal_entry, clc$normal_usage_entry, 22],
        ['MP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 22],
        ['PA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 25],
        ['PAGES_ASSIGNED                 ', clc$nominal_entry, clc$normal_usage_entry, 25],
        ['PAGES_RECLAIMED                ', clc$nominal_entry, clc$normal_usage_entry, 27],
        ['PAGES_SERVER                   ', clc$nominal_entry, clc$normal_usage_entry, 26],
        ['PAGE_FAULT_COUNT               ', clc$nominal_entry, clc$normal_usage_entry, 23],
        ['PAGE_IN                        ', clc$nominal_entry, clc$normal_usage_entry, 24],
        ['PCU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 28],
        ['PERCENT_CPU_USAGE              ', clc$nominal_entry, clc$normal_usage_entry, 28],
        ['PERMANENT_FILE_SPACE           ', clc$nominal_entry, clc$normal_usage_entry, 29],
        ['PFC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 23],
        ['PFS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 29],
        ['PI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 24],
        ['PR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 27],
        ['PS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 26],
        ['READY_TASK_COUNT               ', clc$nominal_entry, clc$normal_usage_entry, 30],
        ['RTC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 30],
        ['SA                             ', clc$abbreviation_entry, clc$normal_usage_entry, 31],
        ['SC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 32],
        ['SERVICE_ACCUMULATOR            ', clc$nominal_entry, clc$normal_usage_entry, 31],
        ['SERVICE_CLASS                  ', clc$nominal_entry, clc$normal_usage_entry, 32],
        ['SERVICE_SINCE_SWAP             ', clc$nominal_entry, clc$normal_usage_entry, 33],
        ['SES                            ', clc$abbreviation_entry, clc$normal_usage_entry, 37],
        ['SIWT                           ', clc$abbreviation_entry, clc$normal_usage_entry, 38],
        ['SJN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 34],
        ['SJNL                           ', clc$abbreviation_entry, clc$normal_usage_entry, 35],
        ['SJNS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 36],
        ['SR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 39],
        ['SS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 40],
        ['SSS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 33],
        ['SWAP_ENTRY_STATUS              ', clc$nominal_entry, clc$normal_usage_entry, 37],
        ['SWAP_IN_WAIT_TIME              ', clc$nominal_entry, clc$normal_usage_entry, 38],
        ['SWAP_REASON                    ', clc$nominal_entry, clc$normal_usage_entry, 39],
        ['SWAP_STATUS                    ', clc$nominal_entry, clc$normal_usage_entry, 40],
        ['SYSTEM_JOB_NAME                ', clc$nominal_entry, clc$normal_usage_entry, 34],
        ['SYSTEM_JOB_NAME_LONG           ', clc$nominal_entry, clc$normal_usage_entry, 35],
        ['SYSTEM_JOB_NAME_SHORT          ', clc$nominal_entry, clc$normal_usage_entry, 36],
        ['TEMPORARY_FILE_SPACE           ', clc$nominal_entry, clc$normal_usage_entry, 41],
        ['TERMINAL_NAME                  ', clc$nominal_entry, clc$normal_usage_entry, 42],
        ['TF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 44],
        ['TFS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 41],
        ['THINK_TIME                     ', clc$nominal_entry, clc$normal_usage_entry, 43],
        ['THRASHING_FLAG                 ', clc$nominal_entry, clc$normal_usage_entry, 44],
        ['TIME_IN_SWAP_STATE             ', clc$nominal_entry, clc$normal_usage_entry, 45],
        ['TISS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 45],
        ['TN                             ', clc$abbreviation_entry, clc$normal_usage_entry, 42],
        ['TT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 43],
        ['UJN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 46],
        ['USER_JOB_NAME                  ', clc$nominal_entry, clc$normal_usage_entry, 46],
        ['WORKING_SET_SIZE               ', clc$nominal_entry, clc$normal_usage_entry, 47],
        ['WSS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 47]]
        ],
      ['FIELD_WIDTH                    ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1, 130, 10]],
      ['FIELD_TITLE                    ', clc$optional_field, 8], [[1, 0, clc$string_type], [1, 31, FALSE]],
      ['SCALE                          ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1, 1000000000,
  10]],
      ['FIELD_OVERFLOW_ACTION          ', clc$optional_field, 229], [[1, 0, clc$keyword_type], [6], [
        ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['ASTERISK                       ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['MAX                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['MAXIMUM                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['SCALE                          ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      ['NUMERIC_DISPLAY_MODE           ', clc$optional_field, 155], [[1, 0, clc$keyword_type], [4], [
        ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['INCREMENTAL                    ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['TOTAL                          ', clc$nominal_entry, clc$normal_usage_entry, 2]]
        ],
      ['FIELD_SELECTION                ', clc$optional_field, 229], [[1, 0, clc$keyword_type], [6], [
        ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['SWAPPED                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['UNCONDITIONAL                  ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      ['NON_SELECTION_ACTION           ', clc$optional_field, 155], [[1, 0, clc$keyword_type], [4], [
        ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['BLANK                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['SKIP                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ]
      ]
    ],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [4], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ACTIVE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['INITIATED                      ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'active'],
{ PARAMETER 6
    [[1, 0, clc$integer_type], [1, 130, 10],
    '1'],
{ PARAMETER 7
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 8
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 9
    [[1, 0, clc$string_type], [1, 130, FALSE]],
{ PARAMETER 10
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$alias = 2,
      p$same_as = 3,
      p$fields = 4,
      p$job_selection = 5,
      p$jobs_per_line = 6,
      p$display_system_line = 7,
      p$display_blank_lines = 8,
      p$title = 9,
      p$status = 10;

    VAR
      pvt: array [1 .. 10] of clt$parameter_value;
*DECK DECK=OFD$PDT_DELETE_INIT_JOB_DISPLAY EXPAND=FALSE
{
{       PROCEDURE (osm$vedu_delijd) delete_initiated_job_display, delijd (
{          name, n: name = $required
{          status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 12, 20, 17, 43, 296],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$VEDU_DELIJD'], [
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;
*DECK DECK=OFD$PDT_QUIT EXPAND=FALSE
{   PROCEDURE  quit (
{     status)

?? 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,
      recend,
    recend := [
    [1,
    [89, 5, 9, 16, 10, 29, 649],
    clc$command, 1, 1, 0, 0, 0, 0, 1, ''], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;
*DECK DECK=OFD$PDT_VED EXPAND=FALSE
{     PROCEDURE vedisplay, ved (
{       display_options, display_option, do:
{         any of name,
{           key
{             (active_jobs, aj)
{             (device_status, ds)
{             (critical_window_log, cwl)
{             (file_server, fs)
{             (general_statistics, gs)
{             (initiated_jobs, ij)
{             (initiated_jobs_detailed, ijd)
{             (io_summary, is)
{             (job_log, jl)
{             (mass_storage, ms)
{             (null)
{             (operator_message, om)
{             (pp_assignment, pa)
{             (special_statistics, ss)
{             (system_log, sl)
{             (tape_mount, tm)
{             (tape_reservations, tr)
{             (tape_status, ts)
{           keyend,
{         anyend  = $required
{       output, o:
{         any of
{           key
{             display_a
{             display_b
{           keyend
{           file
{         anyend = display_a
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 35] of clt$keyword_specification,
        recend,
      recend,
      type2: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
        default_value: string (9),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [96, 3, 20, 6, 12, 45, 370],
    clc$command, 6, 3, 1, 0, 0, 0, 3, ''], [
    ['DISPLAY_OPTION                 ',clc$alias_entry, 1],
    ['DISPLAY_OPTIONS                ',clc$nominal_entry, 1],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 1327, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 104, clc$optional_default_parameter, 0, 9],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]],
    1302, [[1, 0, clc$keyword_type], [35], [
      ['ACTIVE_JOBS                    ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['AJ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
      ['CRITICAL_WINDOW_LOG            ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['CWL                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
      ['DEVICE_STATUS                  ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['DS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
      ['FILE_SERVER                    ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['FS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
      ['GENERAL_STATISTICS             ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
      ['GS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
      ['IJ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
      ['IJD                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
      ['INITIATED_JOBS                 ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
      ['INITIATED_JOBS_DETAILED        ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
      ['IO_SUMMARY                     ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
      ['IS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
      ['JL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
      ['JOB_LOG                        ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
      ['MASS_STORAGE                   ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
      ['MS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
      ['NULL                           ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
      ['OM                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 12],
      ['OPERATOR_MESSAGE               ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
      ['PA                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 13],
      ['PP_ASSIGNMENT                  ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
      ['SL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 15],
      ['SPECIAL_STATISTICS             ', clc$nominal_entry,
  clc$normal_usage_entry, 14],
      ['SS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 14],
      ['SYSTEM_LOG                     ', clc$nominal_entry,
  clc$normal_usage_entry, 15],
      ['TAPE_MOUNT                     ', clc$nominal_entry,
  clc$normal_usage_entry, 16],
      ['TAPE_RESERVATIONS              ', clc$nominal_entry,
  clc$normal_usage_entry, 17],
      ['TAPE_STATUS                    ', clc$nominal_entry,
  clc$normal_usage_entry, 18],
      ['TM                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 16],
      ['TR                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 17],
      ['TS                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 18]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['DISPLAY_A                      ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['DISPLAY_B                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'display_a'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$display_options = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;
?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

*DECK DECK=OFD$TYPE_DEFINITION EXPAND=FALSE

  CONST
    ofc$operator_facility_id = 'OF',
    ofc$max_send_message = 64;

  TYPE
    oft$operator_id = ost$name;

*copyc ofc$operator_ids
*copyc ofc$max_display_message
*copyc OST$NAME
*DECK DECK=OFE$CONDITION_CODES EXPAND=FALSE
*copyc ofc$condition_limits
*copyc ofe$ecc_designer_screens
*DECK DECK=OFE$ECC_DESIGNER_SCREENS EXPAND=FALSE

?? NEWTITLE := 'OFE$ECC_DESIGNER_SCREENS         ''OF''  300 .. 399', EJECT ??
*copyc ofc$condition_limits
?? FMT (FORMAT := OFF) ??


  CONST
    ofe$same_as_and_field_error = ofc$min_ecc + 300,
    {E The SAME_AS and FIELDS parameters cannot both be specified.}

    ofe$unknown_field_name = ofc$min_ecc + 305,
    {E The field +P does not exist.}

    ofe$invalid_numeric_attribute = ofc$min_ecc + 310,
    {E Numeric attributes cannot be used for the +P field description.}

    ofe$unknown_display = ofc$min_ecc + 315,
    {E Display +P does not exist.}

    ofe$display_already_exists = ofc$min_ecc + 320,
    {E Display +P is already defined.}

    ofe$line_too_long = ofc$min_ecc + 325,
    {E Display line is too long. It must be less than  131 characters.}

    ofe$no_field_placement = ofc$min_ecc + 330,
    {E New fields specified but placement information is missing.}

    ofe$multiple_field_placement = ofc$min_ecc + 335,
    {E New field placement cannot be specified multiple times.}

    ofe$field_must_be_specified = ofc$min_ecc + 340,
    {E New fields must be specified.}

    ofe$display_must_have_fields = ofc$min_ecc + 345,
    {E A display must have one or more fields defined.}

    ofe$too_many_incremental_fields = ofc$min_ecc + 350,
    {E The display has too many INCREMENTAL fields.}

    ofe$field_name_not_in_display = ofc$min_ecc + 355,
    {E The field +P is not defined in the display.}

    ofe$invalid_window_id = ofc$min_ecc + 360,
    {E The window id is not valid.}

    ofe$duplicates_hard_coded_name = ofc$min_ecc + 365;
    {I The +P display has been redefined and is no longer accessible.}

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=OFE$ERROR_CODES EXPAND=FALSE
*copyc ofc$condition_limits

?? FMT (FORMAT := OFF) ??

{ Operator Facility Type 'E' Errors

  CONST

{ **************************************************************************
{
{ The following condition codes may be deleted when ofp$send_to_operator
{ and ofp$receive_from_operator are deleted.
{

    ofe$prior_response_not_cleared   = ofc$min_ecc + 1,
        {E A prior operator message has not been received by the task.}

    ofe$action_message_not_posted    = ofc$min_ecc + 2,
        {E There is no action message posted for job +P.}

    ofe$not_display_file             = ofc$min_ecc + 4,
        {E The file used is not a valid console file.}

    ofe$max_job_operator_actions     = ofc$min_ecc + 5,
        {E The maximum number of operator action messages has been exceeded.}

    ofe$previous_msg_not_cleared     = ofc$min_ecc + 6,
        {E The operator has not acted upon a previous message.}

    ofe$invalid_operator_id          = ofc$min_ecc + 7,
        {E The operator id, +P, is invalid.}

    ofe$operator_message_area        = ofc$min_ecc + 8,
        {E The operator message area was not found.}

    ofe$message_not_available        = ofc$min_ecc + 10,
        {E The task has not received an operator message.}

    ofe$improper_response_type       = ofc$min_ecc + 11,
        {E The +P command is an improper response to this action message. ..}
        {+E6The correct response is +P.}

{
{  End of condition codes to be deleted.
{
{  *************************************************************************

    ofe$allocate_structure_failed    = ofc$min_ecc + 3,
        {E The operator message buffer is full. Try again later.}

    ofe$message_too_long             = ofc$min_ecc + 9,
        {E An operator message may not exceed +P characters.}

    ofe$sou_not_active               = ofc$min_ecc + 12,
        {E The SYSTEM_OPERATOR_UTILITY must be active, with the ..}
        {+P capability selected, in order to execute this command.}

    ofe$invalid_operator_class       = ofc$min_ecc + 13,
        {E Operator class values may not exceed +P.}

    ofe$invalid_menu_id              = ofc$min_ecc + 14,
        {E The specified menu was not found.}

    ofe$no_menus_available           = ofc$min_ecc + 15,
        {I No menus are currently available for display.}

    ofe$one_menu_available           = ofc$min_ecc + 16,
        {I The current menu is the only menu available for display.}

    ofe$no_alarms_active             = ofc$min_ecc + 17,
        {I No operator action conditions currently exist.}

    ofe$no_response_available        = ofc$min_ecc + 18,
        {I No response has been received from the +P.}

    ofe$response_variable_too_small  = ofc$min_ecc + 19,
        {E The value of the RESPONSE parameter must be a string}
        { variable of at least 256 characters.}

    ofe$response_too_long            = ofc$min_ecc + 20,
        {E A response string may not exceed +P characters.}

    ofe$no_message_outstanding       = ofc$min_ecc + 21,
        {E No message is outstanding for the +P.}

    ofe$acknowledgement_not_allowed  = ofc$min_ecc + 22,
        {E Operator message +P may not be acknowledged.}

    ofe$invalid_message_id           = ofc$min_ecc + 23,
        {E The identifier +P is not assigned to any outstanding message.}

    ofe$max_job_operator_messages    = ofc$min_ecc + 24,
        {E The number of outstanding operator messages for a job may not}
        { exceed +P.}

    ofe$invalid_display_for_user     = ofc$min_ecc + 25,
        {E The +P display may only be displayed at the system console.}

    ofe$message_outstanding          = ofc$min_ecc + 26,
        {E An outstanding message exists for the +P}

    ofe$invalid_keyword_for_user     = ofc$min_ecc + 27,
        {E The +P1 keyword for the +P2 parameter may only be used at the}
        { system console.}

    ofe$menu_definition_error        = ofc$min_ecc + 28,
        {E The menu module +P is not properly defined.}

    ofe$response_param_must_be_var   = ofc$min_ecc + 29;
        {E The RESPONSE parameter must be a string variable. }

?? FMT (FORMAT := ON) ??
*DECK DECK=OFH$ACKNOWLEDGE_OPERATOR_MSG EXPAND=FALSE
{
{     The purpose of this request is to acknowledge an operator message and to
{ send a response to the message.
{
{       OFP$ACKNOWLEDGE_OPERATOR_MESSAGE (MESSAGE_ID, RESPONSE, STATUS)
{
{ MESSAGE_ID: (input) This parameter specifies the unique identifier of the
{       message being acknowledged.
{
{ RESPONSE: (input) This parameter specifies the response that was entered by
{       the operator.  If the operator acknowledged the message without
{       specifying a response message, the length of the string is 0.
{
{ STATUS: (output) This parameter specifies the request status.
{
{      CONDITION: ofe$acknowledgement_not_allowed
{                 ofe$invalid_message_id
{                 ofe$response_too_long
{
*DECK DECK=OFH$ACKNOWLEDGE_OPERATOR_MSG_R1 EXPAND=FALSE
{
{     The purpose of this request is to acknowledge an operator message and to
{ send a response to the message.
{
{       OFP$ACKNOWLEDGE_OPERATOR_MESSAGE_R1 (MESSAGE_ID, RESPONSE, STATUS)
{
{ MESSAGE_ID: (input) This parameter specifies the unique identifier of the
{       message being acknowledged.
{
{ ACTIVE_OPERATOR_CLASSES: (input) This parameter specifies the set of operator
{       classes in which the caller is active.
{
{ RESPONSE: (input) This parameter specifies the response that was entered by
{       the operator.  If the operator acknowledged the message without
{       specifying a response message, the length of the string is 0.
{
{ STATUS: (output) This parameter specifies the request status.
{
{      CONDITION: ofe$acknowledgement_not_allowed
{                 ofe$invalid_message_id
{
*DECK DECK=OFH$ADD_OPERATOR_MENU EXPAND=FALSE
{
{    The purpose of this procedure is to add a menu to the list of
{  operator action menus.
{
{       OFP$ADD_OPERATOR_MENU (MENU_SELECTIONS, NUMBER_OF_CHOICES,
{             OPERATOR_CLASS, MENU_ID, STATUS)
{
{ MENU_SELECTIONS: (input) This parameter specifies the text lines comprising
{       the menu to be displayed to an operator.
{
{ NUMBER_OF_DISPLAYABLE_LINES: (input) This parameter specifies the number of
{       text lines comprising the menu to be displayed to an operator.
{
{ NUMBER_OF_CHOICES: (input) This parameter specifies the number of choices
{       available on the menu.
{
{ OPERATOR_CLASS: (input) This parameter specifies the class of operator
{       allowed to display and respond to the menu. Currently this value
{       must be either ofc$removable_media_operator or ofc$system_operator.
{
{ MENU_ID: (output) This parameter specifies the unique identifier assigned
{       to the menu.
{
{ STATUS: (output) This parameter specifies the status of the request.
{
{       CONDITION: None
{
*DECK DECK=OFH$CANCEL_PRIOR_MESSAGE EXPAND=TRUE
{}
{    This procedure is used to cancel an active message that is currently
{ in the operator's message queue.  Upon the issueance of this command
{ the operator's message area and display operator actions display
{ will be updated to reflect that the message has been cancelled. The
{ user task will have to wait for operator acknowldgement of the
{ cancelled message before the next message can be answered.
{}
{       OFP$CANCEL_PRIOR_MESSAGE (STATUS);
{}
{ STATUS (output): This parameter will return the value of normal to
{           caller at all times. This reflects the fact that if there
{           was a message present that message was marked as cancelled.
{           If there was no outstanding message then the routine just
{           returns without any processing.
{}
{
*DECK DECK=OFH$CLEAR_HEADER_MESSAGE EXPAND=FALSE
{}
{   The purpose of this procedure is called by the system header display to reflect the
{ processing of the latest change in the operator action message.
{}
{       OFP$CLEAR_HEADER_MESSAGE
{}
*DECK DECK=OFH$CLEAR_OPERATOR_MESSAGE EXPAND=FALSE
{
{     The purpose of this request is to clear an outstanding operator message.
{ Clearing an operator message removes the message from operator displays.
{
{     An operator message is implicitly cleared when an operator acknowledges
{ the message or the task that sent the message terminates.
{
{       OFP$CLEAR_OPERATOR_MESSAGE (OPERATOR_CLASS, STATUS)
{
{ OPERATOR_CLASS: (input) This parameter specifies the class of operator for
{       which an outstanding operator message is to be cleared.
{
{ STATUS: (output) This parameter specifies the request status.
{
{      CONDITION: ofe$invalid_operator_class
{                 ofe$no_message_outstanding
{
*DECK DECK=OFH$CLEAR_OPERATOR_MESSAGE_R1 EXPAND=FALSE
{
{     The purpose of this request is to clear an outstanding operator message.
{ Clearing an operator message removes the message from operator displays.
{
{     An operator message is implicitly cleared when an operator acknowledges
{ the message or the task that sent the message terminates.
{
{       OFP$CLEAR_OPERATOR_MESSAGE_R1 (OPERATOR_CLASS, STATUS)
{
{ OPERATOR_CLASS: (input) This parameter specifies the class of operator for
{       which an outstanding operator message is to be cleared.
{
{ STATUS: (output) This parameter specifies the request status.
{
{      CONDITION: ofe$no_message_outstanding
{
*DECK DECK=OFH$CRITICAL_WINDOW_MANAGER EXPAND=FALSE
{
{   This procedure is the primary entry point for the task,
{ "critical_window_manager".
{
{       OFP$CRITICAL_WINDOW_MANAGER
{
{ (no parameters)
*DECK DECK=OFH$DELETE_OPERATOR_MENU EXPAND=FALSE
{
{    The purpose of this procedure is to delete a menu from the list of
{  operator action menus.
{
{       OFP$DELETE_OPERATOR_MENU (MENU_ID, STATUS)
{
{ MENU_ID: (input) This parameter specifies the unique identifier of the
{       menu to be deleted.
{
{ STATUS: (output) This parameter specifies the status of the request.
{
{       CONDITION: ofe$invalid_menu_id
{
*DECK DECK=OFH$DISPLAY_STATUS_MESSAGE EXPAND=FALSE
{}
{     The purpose of this request is to allow a job to maintain a
{ status message which reflects the current activity of the job.
{ This message is displayed on the operator's job display in order
{ to allow the operator to determine what a job is currently doing.
{ This message is also available to a NOS/VE interactive user through
{ the interactive job status request.
{
{       OFP$DISPLAY_STATUS_MESSAGE (DISPLAY_MESSAGE, STATUS)
{
{ DISPLAY_MESSAGE: (input) This parameter specifies the text
{       which will be displayed.  The maximum length of the message is
{       ofc$max_display_message characters.  If the message is longer
{       than ofc$max_display_message characters, a truncated message is
{       displayed and an ofe$message_too_long status condition is returned.
{
{ STATUS: (output) This parameter specifies the request status.
{
{      CONDITION: ofe$message_too_long
{
{      IDENTIFIER: ofc$operator_facility_id
{
*DECK DECK=OFH$FORMAT_OPERATOR_MENU EXPAND=FALSE
{
{    The purpose of this request is to get a formatted operator action menu
{ from a help module, display it, and obtain the operator choice.  Parameters to
{ be substituted into the menu are supplied via an array of pointers to string,
{ each string representing a particular message parameter.
{
{       OFP$FORMAT_OPERATOR_MENU (SEED_NAME, PARAMETER_NAMES, MESSAGE_PARAMETERS,
{         NUMBER_OF_CHOICES, OPERATOR_CLASS, CHOICE, RESPONSE_STRING, STATUS)
{
{ SEED_NAME: (input) This parameter specifies the name that is to be suffixed
{       with a $ and the name of the natural language to form the name of the
{       help module which contains the requested operator menu template.
{
{ PARAMETER_NAMES: (input) This parameter specifies the list of parameter names
{       that represent the choices in the menu.
{
{ MESSAGE_PARAMETERS: (input) This parameter specifies the items of text to be
{       substituted into the menu according to the parameter substitution
{       formatting codes in the message template.  If NIL is specified for this
{       parameter, all message parameters are considered to be null.  If NIL is
{       specified for any particular element of the array, the corresponding
{       message parameter is considered to be null.
{
{ NUMBER_OF_CHOICES: (input) This parameter specifies the number of choices
{       available on the menu. An operator must respond to the menu with a
{       choice in the range 1 .. number_of_choices.
{
{ OPERATOR_CLASS: (input) This parameter specifies the class of operator
{       allowed to display and respond to the menu. Currently this value
{       must be either ofc$removable_media_operator or ofc$system_operator.
{
{ CHOICE: (output) This parameter specifies the choice selected by the
{       operator.
{
{ RESPONSE_STRING: (output) This parameter specifies the response string,
{       if any, entered by the operator.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=OFH$GET_ACTIVE_OPERATOR_CLASSES EXPAND=FALSE
{
{     The purpose of this procedure is to return a set of the operator classes
{ currently active in the SYSTEM OPERATOR UTILITY.
{
{       OFP$GET_ACTIVE_OPERATOR_CLASSES (ACTIVE_OPERATOR_CLASSES)
{
{ ACTIVE_OPERATOR_CLASSES: (output) This parameter specifies the set of active
{       operator classes under the SYSTEM OPERATOR UTILITY.
{
*DECK DECK=OFH$GET_DISPLAY_STATUS_MESSAGE EXPAND=FALSE
{}
{   The purpose of this procedure is to get the last status message issued
{ by a specific job.
{}
{       OFP$GET_DISPLAY_STATUS_MESSAGE(JOB_SEQ_NUMBER,
{         DISPLAY_MESSAGE,STATUS)
{}
{ JOB_SEQ_NUMBER: (input) This parameter specifies the job sequence number
{       of the job for which the user wants the last issued status message.
{}
{ DISPLAY_MESSAGE: (output) This parameter will contain the value of
{       last issued display message for the job specified in job sequence
{       number provided the job is still in the system.
{}
{ STATUS: (output) This parameter returns a normal status if the
{       requesting job sequence number is still in the system. The value
{       will be abnormal if there are any errors while processing.
{}
*DECK DECK=OFH$GET_FIRST_OPERATOR_MENU EXPAND=FALSE
{
{    The purpose of this procedure is to obtain the first operator action
{  menu in the list of menus the caller is validated to display. The set
{  of validations active for the caller is determined, and then a call is
{  made to the ring 1 procedure which searches the menu list for the
{  appropriate menu.
{
{       OFP$GET_FIRST_OPERATOR_MENU (MENU_DESCRIPTOR, STATUS)
{
{ MENU_DESCRIPTOR: (output) This parameter specifies the descriptor of the
{       first menu in the list of menus which the caller is validated to
{       display.
{
{ STATUS: (output) This parameter specifies the status of the request.
{
{       CONDITION: ofe$no_menus_available
{
*DECK DECK=OFH$GET_FIRST_OPERATOR_MENU_R1 EXPAND=FALSE
{
{    The purpose of this procedure is to obtain the first operator action
{  menu descriptor in the list of menus which the caller is validated to
{  display. The menu list is searched from the beginning until a descriptor
{  is found whose operator_class attribute field is a subset of the input
{  parameter active_operator_classes.
{
{       OFP$GET_FIRST_OPERATOR_MENU_R1 (ACTIVE_OPERATOR_CLASSES,
{             MENU_DESCRIPTOR, STATUS)
{
{ ACTIVE_OPERATOR_CLASSES: (input) This parameter specifies the set of operator
{       classes in which the caller is active.
{
{ MENU_DESCRIPTOR: (output) This parameter specifies the descriptor of the
{       first menu in the list of menus which the caller is validated to
{       display.
{
{ STATUS: (output) This parameter specifies the status of the request.
{
{       CONDITION: ofe$no_menus_available
{
*DECK DECK=OFH$GET_MENU_CHOICE EXPAND=FALSE
{
{    The purpose of this procedure is to indicate to the caller whether
{  or not a choice has been made by the operator for a specific menu. If
{  the operator has responded to the menu, then the choice and the response
{  string (if any) are returned to the caller, and the menu is deleted from
{  the list.
{
{       OFP$GET_MENU_CHOICE (MENU_ID, CHOICE_MADE, CHOICE,
{             RESPONSE_STRING, STATUS)
{
{ MENU_ID: (input) This parameter specifies the unique identifier of the
{       menu to be checked for an operator choice.
{
{ CHOICE_MADE: (output) This parameter specifies whether or not a choice
{       has been made by the operator.
{
{ CHOICE: (output) This parameter specifies the choice selected by the
{       operator.
{
{ RESPONSE_STRING: (output) This parameter specifies the response string,
{       if any, entered by the operator when CHOICE = TRUE.
{
{ STATUS: (output) This parameter specifies the status of the request.
{
{       CONDITION: ofe$invalid_menu_id
{
*DECK DECK=OFH$GET_MENU_HELP_TEXT EXPAND=FALSE
{
{    The purpose of this procedure is to get the help information requested by
{  the operator.  A call is made to the ring 1 procedure to get the help text
{  stored in the menu descriptor.
{
{       OFP$GET_MENU_HELP_TEXT (MENU_ID, GLOBAL_TASK_ID, HELP_TEXT_P,
{             HELP_TEXT_FOUND, HELP_TEXT_LINE_COUNT, STATUS)
{
{ MENU_ID: (input) This parameter specifies the unique identifier of the menu
{       for which help was requested.
{
{ GLOBAL_TASK_ID: (input) This parameter specifies the global_task_id of the
{       task processing the menu.
{
{ HELP_TEXT_P: (output) This parameter specifies the pointer to the help text
{       that was requested.
{
{ HELP_TEXT_FOUND: (output) This parameter specifies whether or not help text
{       was found in the menu descriptor.
{
{ HELP_TEXT_LINE_COUNT: (output) This parameter specifies the number of lines
{       in the help text.
{
{ STATUS: (output) This parameter specifies the status of the request.
{
{       CONDITION: ofe$invalid_menu_id
{
*DECK DECK=OFH$GET_MENU_HELP_TEXT_R1 EXPAND=FALSE
{
{    The purpose of this procedure is to get the help information stored in a
{  menu descriptor.  This procedure executes in ring 1.
{
{       OFP$GET_MENU_HELP_TEXT_R1 (MENU_ID, GLOBAL_TASK_ID, HELP_TEXT_P,
{             HELP_TEXT_FOUND, HELP_TEXT_LINE_COUNT, STATUS)
{
{ MENU_ID: (input) This parameter specifies the unique identifier of the menu
{       for which help was requested.
{
{ GLOBAL_TASK_ID: (input) This parameter specifies the global_task_id of the
{       task processing the menu.
{
{ HELP_TEXT_P: (output) This parameter specifies the pointer to the help text
{       that was requested.
{
{ HELP_TEXT_FOUND: (output) This parameter specifies whether or not help text
{       was found in the menu descriptor.
{
{ HELP_TEXT_LINE_COUNT: (output) This parameter specifies the number of lines
{       in the help text.
{
{ STATUS: (output) This parameter specifies the status of the request.
{
{       CONDITION: ofe$invalid_menu_id
{
*DECK DECK=OFH$GET_NEXT_OPERATOR_MENU EXPAND=FALSE
{
{    The purpose of this procedure is to obtain the next operator action
{  menu in the list of menus which the caller is validated to display.
{  The set of validations active for the caller is determined, and then a
{  a call is made to the ring 1 procedure which searches the menu list
{  for the appropriate menu.
{
{       OFP$GET_NEXT_OPERATOR_MENU (CURRENT_MENU_ID, MENU_DESCRIPTOR, STATUS)
{
{ CURRENT_MENU_ID: (input) This parameter specifies the unique identifier of
{       current menu. The search for the next menu will begin at this menu.
{
{ MENU_DESCRIPTOR: (output) This parameter specifies the descriptor of the next
{       menu in the list of menus which the caller is validated to display.
{
{ STATUS: (output) This parameter specifies the status of the request.
{
{       CONDITION: ofe$no_menus_available
{                  ofe$one_menu_available
{
*DECK DECK=OFH$GET_NEXT_OPERATOR_MENU_R1 EXPAND=FALSE
{
{    The purpose of this procedure is to obtain the next operator action
{  menu in the list of menus which the caller is validated to display. The
{  menu list is searched from the beginning until the current_menu_id is
{  found. From that point a circular search is performed on the list until
{  the next menu for which the user is validated is found or until the
{  current menu is found again.
{
{       OFP$GET_NEXT_OPERATOR_MENU_R1 (CURRENT_MENU_ID,
{             ACTIVE_OPERATOR_CLASSES, MENU_DESCRIPTOR, STATUS)
{
{ CURRENT_MENU_ID: (input) This parameter specifies the unique identifier of
{       the menu after which the search for the next menu is to begin.
{
{ ACTIVE_OPERATOR_CLASSES: (input) This parameter specifies the set of operator
{       classes in which the caller is active.
{
{ MENU_DESCRIPTOR: (output) This parameter specifies the descriptor of the next
{       menu in the list of menus which the caller is validated to display.
{
{ STATUS: (output) This parameter specifies the status of the request.
{
{       CONDITION: ofe$no_menus_available
{                  ofe$one_menu_available
{
*DECK DECK=OFH$GET_OPERATOR_MENU EXPAND=FALSE
{
{    The purpose of this procedure is to get an operator menu contained in a
{  help module.  Parameters to be substituted into the menu are supplied via
{  an array of pointers to string, each string representing a particular
{  menu parameter.
{
{    The operator menu is returned in an array of string with each element of
{  the array representing a line in the menu.
{
{       OFP$GET_OPERATOR_MENU (SEED_NAME, CHOICE_NAMES, MESSAGE_PARAMETERS,
{             MAX_MESSAGE_LINE, OPERATOR_MENU, LINE_COUNT, STATUS)
{
{ SEED_NAME: (input) This parameter specifies the name that is to be suffixed
{       with a $ and the name of the natural language to form the name of the
{       help module which contains the message template for the menu.
{
{ CHOICE_NAMES: (input) This parameter specifies a list of names representing
{       choices to be presented in the operator menu.
{
{ MESSAGE_PARAMETERS: (input) This parameter specifies the items of text to be
{       substituted into the menu according to the parameter substitution
{       formatting codes in the message template.  If NIL is specified for this
{       parameter, all message parameters are considered to be null.  If NIL is
{       specified for any particular element of the array, the corresponding
{       message parameter is considered to be null.
{
{ MAX_MESSAGE_LINE: (input) This parameter specifies the maximum number of
{       characters that can be placed in a line produced by this request.  The
{       message formatter will try to "break" long lines at a delimiter; but if
{       this cannot be done, two dots will be placed at the end of the "broken"
{       line to mark its continuation.
{
{ OPERATOR_MENU: (output) This parameter specifies the array containing the
{       lines of the operator menu.
{
{ LINE_COUNT: (output) This parameter specifies the number of lines in the
{       operator menu.
{
{ STATUS: (output) This parameter specifies the status of the request.
{
*DECK DECK=OFH$GET_OPERATOR_MESSAGES EXPAND=FALSE
{
{     The purpose of this procedure is to return a subset of the operator action
{ messages and to return a count of the total number of messages outstanding.
{
{       OFP$GET_OPERATOR_MESSAGES (ACTIVE_OPERATOR_CLASSES, MESSAGE_ARRAY,
{             COUNT, STATUS)
{
{ ACTIVE_OPERATOR_CLASSES: (input) This parameter specifies the set of active
{       operator classes for which to obtain messages.
{
{ MESSAGE_ARRAY: (output) This parameter specifies the adaptable array in which
{       the operator messages will be returned. Unused entries in the array are
{       not initialized.
{
{ COUNT: (output) This parameter specifies the total number of operator
{       messages available in the set of active classes.
{
{ STATUS: (output) This parameter specifies the request status.
{
{      CONDITION: None
{
*DECK DECK=OFH$JOB_BEGIN EXPAND=FALSE
{}
{   The purpose of this procedure is to create the system
{ operator message table structure when the system job starts
{ processing. For all jobs in the system the operator internal
{ info field is created in mainframe pagable and initialized.
{ This structure controls the message being sent to the operator
{ as well as the messages being returned from the operator.
{ The user generated status messaged is also stored in this
{ structure.
{}
{       OFP$JOB_BEGIN
{}
*DECK DECK=OFH$JOB_END EXPAND=FALSE
{}
{   This procedure is called by job termination to clean up the
{ job message processing queue that exists for the current job.
{ All operator messages from this job are removed from the operator
{ message structure. Then the operator_internal_info is removed
{ from the mainframe pagable heap. Last the display refresh is
{ set to true to reflect any changes is operator message processing.
{}
{       OFP$JOB_END
{}
*DECK DECK=OFH$JOB_OPERATOR_MENUS_ACTIVE EXPAND=FALSE
{
{    The purpose of this function is to indicate whether or not any operator
{  action menus have been posted by a specified job.
{
{       OFP$JOB_OPERATOR_MENUS_ACTIVE (JOB_NAME)
{
{ JOB_NAME (input) This parameter specifies the system supplied job name to be
{       matched against the names of jobs which have originated operator menus.
{
*DECK DECK=OFH$JOB_OPERATOR_MSGS_ACTIVE EXPAND=FALSE
{
{     The purpose of this function is to return status indicating whether or
{ not there are any outstanding operator messages for a specific job.
{
{       OFP$JOB_OPERATOR_MSGS_ACTIVE (JOB_NAME)
{
{ JOB_NAME: (input) This parameter specifies the system supplied name of the
{       job to be checked for outstanding operator messages.
{
*DECK DECK=OFH$OPEN_DISPLAY EXPAND=FALSE

{
{    The purpose of this procedure is to perform the functions necessary to
{  open and initialize a display.  The display output may be to the system
{  console or a file.  If the display is to the system console the window
{  attributes and title are initialized.  If the display is to a file the
{  file is opened with the proper attributes.  Specifically sets file ring
{  attributes to user ring 2.  To close the display use the
{  clp$close_display interface.
{
{       OFP$OPEN_DISPLAY (FILE_NAME, WINDOW_ID, CLASS, KIND, TITLE,
{             DISPLAY_CONTROL, STATUS)
{
{ FILE_NAME: (input) Specifies file name for display output if not going
{       to the system console.
{
{ WINDOW_ID: (input) Specifies the window identifier if display going to
{       system console.
{ CLASS: (input) Specifies the window class if display going to system
{       console.
{
{ KIND: (input) Specifies the kind of window if display going to system
{       console.
{
{ TITLE: (input) Specifies the window title if display going to system
{       console.
{
{ DISPLAY_CONTROL: (output) File information needed for accessing the
{       output file is retuned in this value if display is to a file.
{
{ STATUS: (output) Request status is returned in this value.
{

*DECK DECK=OFH$PROCESS_OPERATOR_MENU EXPAND=FALSE
{
{    The purpose of this procedure is to notify an operator of a condition
{  requiring action, present a menu of possible actions, and obtain an
{  operator choice from the menu.
{
{       OFP$PROCESS_OPERATOR_MENU (MENU_SELECTIONS, NUMBER_OF_CHOICES,
{             OPERATOR_CLASS, CHOICE, RESPONSE_STRING, STATUS)
{
{ MENU SELECTIONS: (input) This parameter specifies the text lines comprising
{       the menu to be displayed to an operator. The menu should describe the
{       condition requiring action and the possible actions the operator may
{       choose.
{
{ NUMBER_OF_DISPLAYABLE_LINES: (input) This parameter specifies the number of
{       text lines comprising the menu to be displayed to an operator.
{
{ NUMBER_OF_CHOICES: (input) This parameter specifies the number of choices
{       available on the menu. An operator must respond to the menu with a
{       choice in the range 1 .. number_of_choices.
{
{ OPERATOR_CLASS: (input) This parameter specifies the class of operator
{       allowed to display and respond to the menu. Currently this value
{       must be either ofc$removable_media_operator or ofc$system_operator.
{
{ CHOICE: (output) This parameter specifies the choice selected by the
{       operator.
{
{ RESPONSE_STRING: (output) This parameter specifies the response string,
{       if any, entered by the operator.
{
{ STATUS: (output) This parameter specifies the status of the request.
{
{       CONDITION: ofe$invalid_operator_class
{
*DECK DECK=OFH$RECEIVE_FROM_OPERATOR EXPAND=FALSE
{
{     The purpose of this request is to allow a job to receive a
{ message from a system operator.  If a message is not available, an
{ option is provided to return status immediately rather than wait
{ until an operator message is available.  This request can be used in
{ conjunction with the OFP$SEND_TO_OPERATOR to solicit input from
{ a system operator.
{
{       OFP$RECEIVE_FROM_OPERATOR (WAIT, RECEIVE_MESSAGE,
{         OPERATOR_ID, STATUS)
{
{ WAIT: (input) This parameter specifies whether or not status will be
{       returned immediately if an operator message is not available.
{
{ RECEIVE_MESSAGE: (output) This parameter specifes the message text
{       which was sent by the operator.
{
{ OPERATOR_ID: (output) This parameter specifies the identification of
{       the operator which sent the message.
{
{ STATUS: (output) This parameter specifies the request status.
{
{      CONDITION: ofe$message_not_available
{                 ofe$system_unattended
{
{      IDENTIFIER: ofc$operator_facility_id
{
*DECK DECK=OFH$RECEIVE_OPERATOR_RESPONSE EXPAND=FALSE
{
{     The purpose of this request is to receive an operator's response to an
{ operator message.  This request may also be used to determine whether an
{ operator has acknowledged a message without returning a response.
{
{       OFP$RECEIVE_OPERATOR_RESPONSE (OPERATOR_CLASS, WAIT, RESPONSE, STATUS)
{
{ OPERATOR_CLASS: (input) This parameter specifies the class of operator for
{       which an operator message is outstanding.
{
{ WAIT: (input) This parameter specifies whether the request should wait for an
{       operator to respond to or acknowledge the outstanding operator message.
{       If osc$nowait is specified and the message is still outstanding, then
{       the request returns abnormal status with the condition
{       ofe$no_response_available.
{
{ RESPONSE: (output) This parameter specifies the response that was returned by
{       an operator.  If the operator acknowledged the message without
{       specifying a response message, the length of the returned string will
{       be 0.
{
{ STATUS: (output) This parameter specifies the request status.
{
{      CONDITION: ofe$invalid_operator_class
{                 ofe$no_response_available
{                 ofe$no_message_outstanding
{
*DECK DECK=OFH$RECEIVE_OPERATOR_RESP_R1 EXPAND=FALSE
{
{     The purpose of this request is to receive an operator's response to an
{ operator message.  This request may also be used to determine whether an
{ operator has acknowledged a message without returning a response.
{
{       OFP$RECEIVE_OPERATOR_RESP_R1 (OPERATOR_CLASS, RESPONSE, STATUS)
{
{ OPERATOR_CLASS: (input) This parameter specifies the class of operator for
{       which an operator message is outstanding.
{
{ RESPONSE: (output) This parameter specifies the response that was returned by
{       an operator.  If the operator acknowledged the message without
{       specifying a response message, the length of the returned string will
{       be 0.
{
{ STATUS: (output) This parameter specifies the request status.
{
{      CONDITION: ofe$no_response_available
{                 ofe$no_message_outstanding
{
*DECK DECK=OFH$RECEIVE_OPERATOR_RESP_R3 EXPAND=FALSE
{
{     The purpose of this request is to receive an operator's response to an
{ operator message.  This request may also be used to determine whether an
{ operator has acknowledged a message without returning a response.
{
{       OFP$RECEIVE_OPERATOR_RESP_R3 (OPERATOR_CLASS, RESPONSE, STATUS)
{
{ OPERATOR_CLASS: (input) This parameter specifies the class of operator for
{       which an operator message is outstanding.
{
{ RESPONSE: (output) This parameter specifies the response that was returned by
{       an operator.  If the operator acknowledged the message without
{       specifying a response message, the length of the returned string will
{       be 0.
{
{ STATUS: (output) This parameter specifies the request status.
{
{      CONDITION: ofe$invalid_operator_class
{                 ofe$no_response_available
{                 ofe$no_message_outstanding
{
*DECK DECK=OFH$SEND_FORMATTED_OPERATOR_MSG EXPAND=FALSE

{
{     The purpose of this request is to send a formatted message to an
{ operator.  Each operator message is sent to a specified class of operator.
{ A formatted message consists of eleven 80 character lines. This interface
{ provides control over where line breaks occur in the operator message while
{ OSP$SEND_OPERATOR_MESSAGE does the line breaking for you.
{
{     Only an operator of the specified class may display and/or act upon the
{ operator message.  Operators are classified according to the functions they
{ perform.  Messages may be sent to the following classes of operators:
{
{         system_operator: A system operator performs general functions
{             associated with the operation of the system (job status and
{             control, queue file status and control, system task status and
{             control, etc.).
{
{         removable_media_operator: A removable media operator performs
{             functions associated with the operation of removable media
{             devices (magnetic tape, optical disk, cartridge tape, etc.).
{
{     A task may have only one operator message outstanding per operator class.
{ That is, once a message has been sent to an operator, no other message may be
{ sent by the same task to an operator in the same class until the first
{ message has been acknowledged by the operator or cleared by the task.  The
{ ofp$receive_operator_response request may be used to determine whether an
{ operator has acknowledged a message.  The ofp$clear_operator_message request
{ may be used to clear a message.
{
{     A job may have up to ofc$max_messages_per_job operator messages
{ outstanding (each from a separate task).
{
{       OFP$SEND_OPERATOR_MESSAGE (FORMATTED_MESSAGE, OPERATOR_CLASS,
{             ACKNOWLEDGEMENT_ALLOWED, STATUS)
{
{ FORMATTED_MESSAGE: (input) This parameter specifies the message to be sent
{       to an operator.
{
{ OPERATOR_CLASS: (input) This parameter specifies the class of operator to
{       which the message is to be sent.
{
{ ACKNOWLEDGEMENT_ALLOWED: (input) This parameter specifies whether an
{       operator is allowed to acknowledge the message.  If operator
{       acknowledgement is not allowed, then the ofp$clear_operator_message
{       request must be used to clear the message when it no longer needs to be
{       displayed to an operator.
{
{ STATUS: (output) This parameter specifies the request status.
{
{      CONDITION: ofe$allocate_structure_failed
{                 ofe$invalid_operator_class
{                 ofe$max_job_operator_messages
{                 ofe$message_outstanding
{                 ofe$message_too_long
{
*DECK DECK=OFH$SEND_OPERATOR_MESSAGE EXPAND=FALSE
{
{     The purpose of this request is to send a message to an operator.  Each
{ operator message is sent to a specified class of operator.  Only an operator
{ of the specified class may display and/or act upon the operator message.
{
{     Operators are classified according to the functions they perform.
{ Messages may be sent to the following classes of operators:
{
{         system_operator: A system operator performs general functions
{             associated with the operation of the system (job status and
{             control, queue file status and control, system task status and
{             control, etc.).
{
{         removable_media_operator: A removable media operator performs
{             functions associated with the operation of removable media
{             devices (magnetic tape, optical disk, cartridge tape, etc.).
{
{     A task may have only one operator message outstanding per operator class.
{ That is, once a message has been sent to an operator, no other message may be
{ sent by the same task to an operator in the same class until the first
{ message has been acknowledged by the operator or cleared by the task.  The
{ ofp$receive_operator_response request may be used to determine whether an
{ operator has acknowledged a message.  The ofp$clear_operator_message request
{ may be used to clear a message.
{
{     A job may have up to ofc$max_messages_per_job operator messages
{ outstanding (each from a separate task).
{
{       OFP$SEND_OPERATOR_MESSAGE (MESSAGE, OPERATOR_CLASS,
{             ACKNOWLEDGEMENT_ALLOWED, STATUS)
{
{ MESSAGE: (input) This parameter specifies the message to be sent to an
{       operator.
{
{ OPERATOR_CLASS: (input) This parameter specifies the class of operator to
{       which the message is to be sent.
{
{ ACKNOWLEDGEMENT_ALLOWED: (input) This parameter specifies whether an
{       operator is allowed to acknowledge the message.  If operator
{       acknowledgement is not allowed, then the ofp$clear_operator_message
{       request must be used to clear the message when it no longer needs to be
{       displayed to an operator.
{
{ STATUS: (output) This parameter specifies the request status.
{
{      CONDITION: ofe$allocate_structure_failed
{                 ofe$invalid_operator_class
{                 ofe$max_job_operator_messages
{                 ofe$message_outstanding
{                 ofe$message_too_long
{
*DECK DECK=OFH$SEND_OPERATOR_MESSAGE_R1 EXPAND=FALSE
{
{     The purpose of this request is to send a message to an operator.  Each
{ operator message is sent to a specified class of operator.  Only an operator
{ of the specified class may display and/or act upon the operator message.
{
{     Operators are classified according to the functions they perform.
{ Messages may be sent to the following classes of operators:
{
{         system_operator: A system operator performs general functions
{             associated with the operation of the system (job status and
{             control, queue file status and control, system task status and
{             control, etc.).
{
{         removable_media_operator: A removable media operator performs
{             functions associated with the operation of removable media
{             devices (magnetic tape, optical disk, cartridge tape, etc.).
{
{     A task may have only one operator message outstanding per operator class.
{ That is, once a message has been sent to an operator, no other message may be
{ sent by the same task to an operator in the same class until the first
{ message has been acknowledged by the operator or cleared by the task.  The
{ ofp$receive_operator_response request may be used to determine whether an
{ operator has acknowledged a message.  The ofp$clear_operator_message request
{ may be used to clear a message.
{
{     A job may have up to ofc$max_actions_per_job operator messages
{ outstanding (each from a separate task).
{
{       OFP$SEND_OPERATOR_MESSAGE_R1 (FORMATTED_MESSAGE, OPERATOR_CLASS,
{             ACKNOWLEDGEMENT_ALLOWED, STATUS)
{
{ FORMATTED_MESSAGE: (input) This parameter specifies the message to be sent
{       to an operator.
{
{ OPERATOR_CLASS: (input) This parameter specifies the class of operator to
{       which the message is to be sent.
{
{ ACKNOWLEDGEMENT_ALLOWED: (input) This parameter specifies whether an
{       operator is allowed to acknowledge the message.  If operator
{       acknowledgement is not allowed, then the ofp$clear_operator_message
{       request must be used to clear the message when it no longer needs to be
{       displayed to an operator.
{
{ STATUS: (output) This parameter specifies the request status.
{
{      CONDITION: ofe$allocate_structure_failed
{                 ofe$max_job_operator_messages
{                 ofe$message_outstanding
{
*DECK DECK=OFH$SEND_TO_OPERATOR EXPAND=FALSE
{
{     The purpose of this request is to allow a job to send a message
{ to a specified system operator.  Another message cannot be sent
{ until the previous message has been cleared by a system operator.
{ The message is uniquely identified to the system operator by a
{ system assigned action identifier which the system operator specifies
{ when responding to the action message.
{
{       OFP$SEND_TO_OPERATOR (SEND_MESSAGE_TEXT, OPERATOR_ID, STATUS)
{
{ SEND_MESSAGE_TEXT: (input) This parameter specifes the text message
{       which will be sent to the system operator.  The maximum length
{       of the message is ofc$max_send_message characters.  If the message
{       is longer than ofc$max_send_message characters, a truncated message
{       is sent to the system operator and an ofe$message_too_long
{       status condition is returned.
{
{ OPERATOR_ID: (input) This parameter specifies the identification of
{       the operator to which the message will be sent.
{
{ STATUS: (output) This parameter specifies the request status.
{
{      CONDITION: ofe$message_too_long
{                 ofe$invalid_operator_id
{                 ofe$previous_message_not_cleared
{                 ofe$system_unattended
{
{      IDENTIFIER: ofc$operator_facility_id
{
*DECK DECK=OFH$STORE_MENU_CHOICE EXPAND=FALSE
{
{    The purpose of this procedure is to store a choice and a response string
{  into an action menu descriptor. The set of validations active for the caller
{  is determined, and then a call is made to the ring 1 procedure to store
{  the values into the descriptor.
{
{       OFP$STORE_MENU_CHOICE (MENU_ID, CHOICE, RESPONSE_STRING, STATUS)
{
{ MENU_ID: (input) This parameter specifies the unique identifier of the menu
{       descriptor into which the choice and response string are to be stored.
{
{ CHOICE: (input) This parameter specifies the choice to be stored in the
{       menu descriptor.
{
{ RESPONSE_STRING: (input) This parameter specifies the response string to be
{       stored in the menu descriptor.
{
{ STATUS: (output) This parameter specifies the status of the request.
{
{       CONDITION: ofe$invalid_menu_id
{
*DECK DECK=OFH$STORE_MENU_CHOICE_R1 EXPAND=FALSE
{
{    The purpose of this procedure is to store a choice and a response string
{  into an action menu descriptor.
{
{       OFP$STORE_MENU_CHOICE_R1 (MENU_ID, ACTIVE_OPERATOR_CLASSES, CHOICE,
{             RESPONSE_STRING, STATUS)
{
{ MENU_ID: (input) This parameter specifies the unique identifier of the menu
{       descriptor into which a choice is to be stored.
{
{ ACTIVE_OPERATOR_CLASSES: (input) This parameter specifies the set of operator
{       classes in which the caller is active.
{
{ CHOICE: (input) This parameter specifies the choice to be stored in the
{       menu descriptor.
{
{ RESPONSE_STRING: (input) This parameter specifies the response string to be
{       stored in the menu descriptor.
{
{ STATUS: (output) This parameter specifies the status of the request.
{
{       CONDITION: ofe$invalid_menu_id
{
*DECK DECK=OFH$STORE_MENU_HELP_TEXT EXPAND=FALSE
{
{    The purpose of this procedure is to store help information into a menu
{  descriptor.
{
{       OFP$STORE_MENU_HELP_TEXT (MENU_ID, HELP_TEXT, HELP_TEXT_LINE_COUNT,
{             STATUS)
{
{ MENU_ID: (input) This parameter specifies the unique identifier of the menu
{       for which help is requested.
{
{ HELP_TEXT: (output) This parameter specifies the help text to be stored in
{       the menu descriptor.
{
{ HELP_TEXT_LINE_COUNT: (output) This parameter specifies the number of lines
{       in the help text.
{
{ STATUS: (output) This parameter specifies the status of the request.
{
{       CONDITION: ofe$invalid_menu_id
{
*DECK DECK=OFH$TASK_END EXPAND=FALSE
{}
{   This procedure is used for the task end cleanup of operator messages.
{ When a task terminates this procedure checks to see if there are any
{ messages posted to the operator for this task.  If there is a message
{ then the message will be marked as cancelled. This is to let the operator
{ know that the message was sent to the operator but the originating
{ task is no longer in the system.
{}
{       OFP$TASK_END
{}
*DECK DECK=OFH$VE_DISPLAY_COMMAND EXPAND=FALSE
{ PURPOSE:
{   The purpose of this procedure is to process the command VEDISPLAY that
{   is entered by the operator.
{
{       OFP$VEDISPLAY_COMMAND (PARAMETER_LIST, STATUS);
{
{   PARAMETER_LIST: (input) This parameter contains the parameter list as
{     supplied by SCL when processing any command. It contains the display
{     type and the output file name.
{
{   STATUS: (output) This parameter specifies the request status.  A normal
{     status value will be returned to indicate that no error occurred while
{     processing the command.  An abnormal status indicates that an error
{     was detected in the processing of the command.  Since the display will
{     continue to execute after the command is terminated the status variable
{     will not reflect any errors that occur while the display processor is
{     executing.
*DECK DECK=OFK$KEYPOINTS EXPAND=FALSE

  CONST
    ofk$screen_input_fap = ofk$base + 1,
      {E 8.128 'ofp$screen_input_fap open operation'}
      {E 8.122 'ofp$screen_input_fap get_next_funtion'}
      {E 8.124 'ofp$screen_input_fap get_partial_funtion'}
      {E 8.119 'ofp$screen_input_fap get_direct_funtion'}
      {E 8.112 'ofp$screen_input_fap close_funtion'}
      {E 8.161 'ofp$screen_input_fap store_terminal'}
      {E 8.117 'ofp$screen_input_fap fetch_request'}
      {E 8.152 'ofp$screen_input_fap store_function'}
      {E 8.101 'ofp$screen_input_fap fetch_access_info'}
      {X 8.128 'ofp$screen_input_fap open_operation'}
      {X 8.122 'ofp$screen_input_fap get_next_function'}
      {X 8.124 'ofp$screen_input_fap get_partial_function'}
      {X 8.119 'ofp$screen_input_fap get_direct_fuction'}
      {X 8.112 'ofp$screen_input_fap close_function'}
      {X 8.161 'ofp$screen_input_fap store_terminal'}
      {X 8.117 'ofp$screen_input_fap fetch_function'}
      {X 8.152 'ofp$screen_input_fap store_function'}
      {X 8.101 'ofp$screen_input_fap fetch_access_info'}

    ofk$screen_output_fap = ofk$base + 2,
      {E 8.128 'ofp$screen_output_fap open_function'}
      {E 8.112 'ofp$screen_output_fap close_function'}
      {E 8.117 'ofp$screen_output_fap fetch_function'}
      {E 8.152 'ofp$screen_output_fap store function'}
      {E 8.135 'ofp$screen_output_fap put_partial_function'}
      {E 8.134 'ofp$screen_output_fap put_next_function'}
      {E 8.131 'ofp$screen_output_fap put_direct_function'}
      {X 8.128 'ofp$screen_output_fap open_function'}
      {X 8.112 'ofp$screen_output_fap close_function'}
      {X 8.117 'ofp$screen_output_fap fetch_function'}
      {X 8.152 'ofp$screen_output_fap store_function'}
      {X 8.135 'ofp$screen_output_fap put_partial_function'}
      {X 8.134 'ofp$screen_output_fap put_next_function'}
      {X 8.131 'ofp$screen_output_fap put_direct_function'}

    ofk$operator_facility_files = ofk$base + 3,
      {E 'ofp$operator_facility_files'}
      {X 'ofp$operator_facility_files'}

    ofk$send_to_operator = ofk$base + 4,
      {E 'ofp$send_to_operator'}
      {X 'ofp$send_to_operator'}

    ofk$display_status_message = ofk$base + 5,
      {E 'ofp$display_status_message'}
      {X 'ofp$display_status_message'}

    ofk$get_display_status_message = ofk$base + 6,
      {E 'ofp$get_display_status_message'}
      {X 'ofp$get_display_status_message'}

    ofk$reply_to_action = ofk$base + 7,
      {E 'ofp$reply_to_action'}
      {X 'ofp$reply_to_action'}

    ofk$handle_signal_processor = ofk$base + 8,
      {E 'ofp$handle_signal_processor'}
      {X 'ofp$handle_signal_processor'}

    ofk$receive_from_operator = ofk$base + 9,
      {E 'ofp$receive_from_operator'}
      {X 'ofp$receive_from_operator'}

    ofk$send_display_image = ofk$base + 10,
      {E 'ofp$send_display_image'}
      {X 'ofp$send_display_image'}

    ofk$scroll = ofk$base + 11,
      {E 'ofp$scroll'}
      {X 'ofp$scroll'}

    ofk$execute_display_task = ofk$base + 12,
      {E 'ofp$execute_display_task'}
      {X 'ofp$execute_display_task'}

    ofk$get_display_status = ofk$base + 13,
      {E 'ofp$get_display_status'}
      {X 'ofp$get_display_status'}

    ofk$alter_display = ofk$base + 14;
      {E 'ofp$alter_display'}
      {X 'ofp$alter_display'}

?? PUSH (LISTEXT := ON) ??
*copyc amk$base_keypoint_values
?? POP ??
*DECK DECK=OFM$ASYNC_TASK_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operator Facility : Asynchronous system task procedures' ??
MODULE ofm$async_task_interfaces;

{ PURPOSE:
{   This module contains procedures to execute the display task in an asynchronous task.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc fst$file_reference
*copyc dme$tape_errors
*copyc ofd$type_definition
*copyc ofe$error_codes
*copyc ofe$condition_codes
*copyc ofk$keypoints
*copyc oft$display_procedure
*copyc oft$operator_alarm
*copyc oft$operator_classes
*copyc oft$refreshing_displays
*copyc oft$screen_status
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc oss$task_shared
?? POP ??
*copyc avp$removable_media_admin
*copyc avp$removable_media_operator
*copyc avp$system_displays
*copyc avp$system_operator
*copyc clp$convert_str_to_path_handle
*copyc cmp$ved_display_configuration
*copyc cmp$ved_display_pp
*copyc dfp$file_server_display
*copyc dmp$display_mass_storage
*copyc dmp$tape_reservations_display
*copyc dmp$tape_status_display
*copyc dpp$change_window
*copyc dpp$open_window
*copyc dpp$set_title
*copyc dpp$set_180_operator_action
*copyc iop$log_usage_statistics
*copyc iop$tape_mounts_pending
*copyc jmp$system_job
*copyc jmp$purge_expired_file
*copyc jmp$purge_expired_queue_file
*copyc jmp$purge_printed_file
*copyc jmp$purge_processed_queue_file
*copyc ofp$critical_window_log_display
*copyc ofp$display
*copyc ofp$general_statistics_display
*copyc ofp$get_active_operator_classes
*copyc ofp$get_first_operator_menu_r1
*copyc ofp$get_operator_messages
*copyc ofp$job_log_display
*copyc ofp$operator_message_display
*copyc ofp$special_statistics_display
*copyc ofp$io_summary_display
*copyc ofp$tape_mount_display
*copyc ofp$system_header_display
*copyc ofp$system_log_display
*copyc ofp$verify_display_name
*copyc osp$change_date_time
*copyc osp$clear_signature_lock
*copyc osp$emit_os_statistics
*copyc osp$establish_condition_handler
*copyc osp$initialize_signature_lock
*copyc osp$set_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$test_signature_lock
*copyc osp$update_wait_frc
*copyc pmp$continue_to_cause
*copyc pmp$log
*copyc pmp$wait
*copyc qfp$ready_deferred_file
*copyc qfp$ready_deferred_job
*copyc qfp$ready_deferred_queue_file
?? EJECT ??
*copyc avv$validated_sou_capabilities
*copyc clv$standard_files
*copyc dpv$display_delay
*copyc dpv$system_core_display
*copyc iov$time_to_log_usage_stats
*copyc jmv$purge_expired_qfile_time
*copyc jmv$purge_processed_qfile_time
*copyc jmv$ready_deferred_qfile_time
*copyc jmv$time_to_purge_expired_file
*copyc jmv$time_to_purge_printed_file
*copyc jmv$time_to_ready_deferred_file
*copyc jmv$time_to_ready_deferred_job
*copyc osv$os_defaults
*copyc osv$time_to_emit_statistics
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    half_second = 500 {milliseconds},
    one_second = 1000 {milliseconds};

  VAR
    ofv$screen_status: [XDCL, oss$task_shared] oft$screen_status :=
          [REP 3 of [[0], 0, ofc$da_process_display,' ', ofc$du_no_one, NIL, FALSE, 0]],

    v$displays: [XDCL, #GATE, READ, oss$job_paged_literal] ARRAY [0 .. 15] OF RECORD
      long_name: string (31),
      short_name: string (4),
      procedure_p: oft$display_procedure,
    RECEND := [
{     } [' user defined ',     ' ud ', ^ofp$display],
{     } ['CRITICAL_WINDOW_LOG','CWL',  ^ofp$critical_window_log_display],
{     } ['JOB_LOG',            'JL ',  ^ofp$job_log_display],
{     } ['GENERAL_STATISTICS', 'GS ',  ^ofp$general_statistics_display],
{     } ['SPECIAL_STATISTICS', 'SS ',  ^ofp$special_statistics_display],
{     } ['IO_SUMMARY',         'IS ',  ^ofp$io_summary_display],
{     } ['SYSTEM_LOG',         'SL ',  ^ofp$system_log_display],
{     } ['MASS_STORAGE',       'MS ',  ^dmp$display_mass_storage],
{     } ['TAPE_STATUS',        'TS',   ^dmp$tape_status_display],
{     } ['TAPE_RESERVATIONS',  'TR',   ^dmp$tape_reservations_display],
{     } ['PP_ASSIGNMENT',      'PA',   ^cmp$ved_display_pp],
{     } ['DEVICE_STATUS',      'DS',   ^cmp$ved_display_configuration],
{     } ['FILE_SERVER',        'FS',   ^dfp$file_server_display],
{     } ['OPERATOR_MESSAGE',   'OM',   ^ofp$operator_message_display],
{     } ['TAPE_MOUNT',         'TM',   ^ofp$tape_mount_display],
{     } ['NULL',               'NULL',  NIL]],

    v$screen_name: [STATIC, READ, oss$job_paged_literal] ARRAY [oft$screen_files] OF ost$name :=
          ['DISPLAY_A', 'DISPLAY_B', 'OUTPUT'];

 VAR
    ofv$enable_user_displays: [XREF] boolean;

?? OLDTITLE ??
?? NEWTITLE := 'ofp$get_active_operator_alarms', EJECT ??

{ PURPOSE:
{   This procedure returns a set indicating the operator conditions currently requiring attention.

  PROCEDURE [XDCL, #GATE] ofp$get_active_operator_alarms
    (VAR active_operator_alarms: oft$operator_alarms);

    VAR
      active_operator_classes: oft$operator_classes,
      menu_descriptor: oft$operator_menu_descriptor,
      message_array: array [1 .. 1] of oft$operator_message_descriptor,
      message_count: integer,
      messages_active: boolean,
      mounts_pending: boolean,
      status: ost$status;

    active_operator_alarms := $oft$operator_alarms [];
    IF avp$system_displays () THEN
      active_operator_classes := -$oft$operator_classes [];
    ELSE
      ofp$get_active_operator_classes (active_operator_classes);
      IF active_operator_classes = $oft$operator_classes [] THEN
        RETURN;
      IFEND;
    IFEND;

    IF (ofc$removable_media_operator IN active_operator_classes) THEN
      REPEAT
        iop$tape_mounts_pending (mounts_pending, status);
        IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
          pmp$wait (one_second, one_second);
        IFEND;
      UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
      IF status.normal AND mounts_pending THEN
        active_operator_alarms := active_operator_alarms + $oft$operator_alarms [ofc$tape_mounts];
      IFEND;
    IFEND;

    ofp$get_first_operator_menu_r1 (active_operator_classes, menu_descriptor, status);
    IF status.normal THEN
      active_operator_alarms := active_operator_alarms + $oft$operator_alarms [ofc$menu_requests];
    IFEND;

    ofp$get_operator_messages (active_operator_classes, message_array, message_count, status);
    IF message_count <> 0 THEN
      active_operator_alarms := active_operator_alarms + $oft$operator_alarms [ofc$operator_messages];
    IFEND;
  PROCEND ofp$get_active_operator_alarms;
?? OLDTITLE ??
?? NEWTITLE := 'ofp$execute_display_task', EJECT ??

{ PURPOSE:
{   This procedure executes the requested procedure.  If a display file
{   is not requested as the output file the requested procedure is executed.
{   if a display file is requested as the output file then the display file
{   is set up so that during the system console task's main loop the
{   procedure will be executed.

  PROCEDURE [XDCL, #GATE] ofp$execute_display_task
    (    file_reference: fst$file_reference;
         xdisplay_name: ost$name;
     VAR status: ost$status);

    VAR
      di: integer,
      display_name: ost$name,
      ignore_file_reference: fst$evaluated_file_reference,
      new_screen_file: oft$screen_files,
      old_screen_file: oft$screen_files,
      operator_class_name: string (osc$max_string_size),
      operator_class_name_length: integer,
      path_handle_name: fst$path_handle_name,
      removable_media_admin_name: [READ, oss$job_paged_literal] string (30) :=
            'REMOVABLE_MEDIA_ADMINISTRATION',
      removable_media_operator_name: [READ, oss$job_paged_literal] string (25) := 'REMOVABLE_MEDIA_OPERATION',
      screen_file: oft$screen_files,
      screen_file_name: ost$name,
      system_displays_name: [READ, oss$job_paged_literal] string (19) := 'SYSTEM_DISPLAYS or ',
      system_operator_name: [READ, oss$job_paged_literal] string (16) := 'SYSTEM_OPERATION';

    status.normal := TRUE;
    di := 0;

    { Search the user defined display name list. If not found check for a hard-coded display name.
    { Error if name not found in either list.

    ofp$verify_display_name (xdisplay_name, display_name, status);
    IF NOT status.normal THEN
      ofp$search_for_display_name (xdisplay_name, di);
      IF di = 0 THEN
        RETURN;
      IFEND;
      display_name := v$displays [di].long_name;
    IFEND;

  /execute_task/
    BEGIN

      { The caller is validated for use of the requested display according to the
      { following set of rules:
      {
      { 1. The NULL, JOB_LOG, CRITICAL_WINDOW_LOG and SYSTEM_LOG display options are available only to
      {    the system console.
      { 2. The OPERATOR_MESSAGE display is available to callers with SYSTEM_OPERATION
      {    and/or REMOVABLE_MEDIA_OPERATION capability.
      { 3. The TAPE_RESERVATIONS display is available to callers with
      {    REMOVABLE_MEDIA_OPERATION capability.
      { 4. The TAPE_MOUNT and TAPE_STATUS displays are available to callers with
      {    REMOVABLE_MEDIA_ADMINISTRATION and/or REMOVABLE_MEDIA_OPERATION capability.
      { 5. All additional displays (those not covered in items 1 thru 4) require
      {    SYSTEM_OPERATION capability.
      { 6. If the caller has SYSTEM_DISPLAYS capability, then the rules specified
      {    in items 2 thru 5 do not apply, and those displays are available.

    /validate_for_display/
      BEGIN
        IF v$displays [di].procedure_p = NIL THEN
          IF NOT jmp$system_job () THEN
            osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_display_for_user, 'NULL', status);
            EXIT /execute_task/;
          IFEND;

          EXIT /validate_for_display/;
        IFEND;

        IF v$displays [di].procedure_p = ^ofp$job_log_display THEN
          IF NOT jmp$system_job () THEN
            osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_display_for_user, 'JOB_LOG',
                  status);
            EXIT /execute_task/;
          IFEND;
          EXIT /validate_for_display/;
        IFEND;

        IF v$displays [di].procedure_p = ^ofp$system_log_display THEN
          IF NOT jmp$system_job () THEN
            osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_display_for_user, 'SYSTEM_LOG',
                  status);
            EXIT /execute_task/;
          IFEND;
          EXIT /validate_for_display/;
        IFEND;

        IF v$displays [di].procedure_p = ^ofp$critical_window_log_display THEN
          IF NOT jmp$system_job () THEN
            osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_display_for_user,
                  'CRITICAL_WINDOW_LOG', status);
            EXIT /execute_task/;
          IFEND;
          EXIT /validate_for_display/;
        IFEND;

        IF NOT avp$system_displays () AND NOT ofv$enable_user_displays THEN
          operator_class_name := system_displays_name;
          operator_class_name_length := #SIZE(system_displays_name);
          IF v$displays [di].procedure_p = ^ofp$operator_message_display THEN
            IF NOT (avp$removable_media_operator () OR avp$system_operator ()) THEN
              operator_class_name (operator_class_name_length + 1, #SIZE (removable_media_operator_name)) :=
                    removable_media_operator_name;
              operator_class_name_length := operator_class_name_length + #SIZE(removable_media_operator_name);
              operator_class_name (operator_class_name_length + 1, 4) := ' or ';
              operator_class_name_length := operator_class_name_length + 4;
              operator_class_name (operator_class_name_length + 1, #SIZE (system_operator_name)) :=
                    system_operator_name;
              operator_class_name_length := operator_class_name_length + #SIZE(system_operator_name);
            ELSE
              EXIT /validate_for_display/;
            IFEND;

          ELSEIF v$displays [di].procedure_p = ^dmp$tape_reservations_display THEN
            IF avp$removable_media_operator () THEN
              EXIT /validate_for_display/;
            ELSE
              operator_class_name (operator_class_name_length + 1, #SIZE (removable_media_operator_name)) :=
                    removable_media_operator_name;
              operator_class_name_length := operator_class_name_length + #SIZE(removable_media_operator_name);
            IFEND;

          ELSEIF (v$displays [di].procedure_p = ^ofp$tape_mount_display) OR
                (v$displays [di].procedure_p = ^dmp$tape_status_display) THEN
            IF avp$removable_media_admin () OR avp$removable_media_operator () THEN
              EXIT /validate_for_display/;
            ELSE
              operator_class_name (operator_class_name_length + 1, #SIZE (removable_media_admin_name)) :=
                    removable_media_admin_name;
              operator_class_name_length := operator_class_name_length + #SIZE(removable_media_admin_name);
              operator_class_name (operator_class_name_length + 1, 4) := ' or ';
              operator_class_name_length := operator_class_name_length + 4;
              operator_class_name (operator_class_name_length + 1, #SIZE (removable_media_operator_name)) :=
                    removable_media_operator_name;
              operator_class_name_length := operator_class_name_length + #SIZE(removable_media_operator_name);
            IFEND;

          ELSE

            IF avp$system_operator () THEN
              EXIT /validate_for_display/;
            ELSE
              operator_class_name (operator_class_name_length + 1,
                    #SIZE (system_operator_name)) := system_operator_name;
              operator_class_name_length := operator_class_name_length + #SIZE (system_operator_name);
            IFEND;
          IFEND;

          osp$set_status_abnormal (ofc$operator_facility_id, ofe$sou_not_active,
                operator_class_name (1, operator_class_name_length), status);
          EXIT /execute_task/;
        IFEND;

      END /validate_for_display/;

      { Determine whether one of the screen files already has the requested display.
      { The main screen file will be used as the default.

      old_screen_file := ofc$sf_main_or_other;

    /search_for_old/
      FOR screen_file := ofc$sf_display_a TO ofc$sf_display_b DO
        osp$set_signature_lock (ofv$screen_status [screen_file].file_lock, osc$wait, status);
        IF ofv$screen_status [screen_file].display_name = display_name THEN
          old_screen_file := screen_file;
          osp$clear_signature_lock (ofv$screen_status [screen_file].file_lock, status);
          EXIT /search_for_old/;
        IFEND;
        osp$clear_signature_lock (ofv$screen_status [screen_file].file_lock, status);
      FOREND /search_for_old/;

      { Determine which screen file is being requested for the new display.

      clp$convert_str_to_path_handle (file_reference, FALSE, TRUE, TRUE, path_handle_name,
            ignore_file_reference, status);
      IF NOT status.normal THEN
        EXIT /execute_task/;
      IFEND;

      IF path_handle_name = clv$standard_files [clc$sf_display_a_file].path_handle_name THEN
        new_screen_file := ofc$sf_display_a;
      ELSEIF path_handle_name = clv$standard_files [clc$sf_display_b_file].path_handle_name THEN
        new_screen_file := ofc$sf_display_b;
      ELSE
        new_screen_file := ofc$sf_main_or_other;
      IFEND;

      { If the display procedure is NIL then terminate the window.

      IF v$displays [di].procedure_p = NIL THEN
        osp$set_signature_lock (ofv$screen_status [new_screen_file].file_lock, osc$wait, status);
        ofv$screen_status [new_screen_file].display_action := ofc$da_terminate_window;
        osp$clear_signature_lock (ofv$screen_status [new_screen_file].file_lock, status);
        EXIT /execute_task/;
      IFEND;

      IF old_screen_file <> new_screen_file THEN

        { Terminate the old display.

        osp$set_signature_lock (ofv$screen_status [old_screen_file].file_lock, osc$wait, status);
        ofv$screen_status [old_screen_file].display_action := ofc$da_terminate_window;
        osp$clear_signature_lock (ofv$screen_status [old_screen_file].file_lock, status);
      ELSEIF new_screen_file <> ofc$sf_main_or_other THEN

        { Same display requested, no need to rerequest the display it will be updated
        { during the operator display task.

        EXIT /execute_task/;
      IFEND;

      { If the file requested is the main screen or some other file then call the procedure.

      IF new_screen_file = ofc$sf_main_or_other THEN
        v$displays [di].procedure_p^ (0, display_name, path_handle_name, TRUE, status);
        EXIT /execute_task/;
      IFEND;

      { Wait for previous display to finish processing on the desired screen file.
      { Set the screen status so the screen file will be processed with the new display
      { in the system display manager task.

      WHILE TRUE DO
        osp$set_signature_lock (ofv$screen_status [new_screen_file].file_lock, osc$wait, status);
        IF ofv$screen_status [new_screen_file].display_user = ofc$du_no_one THEN
          ofv$screen_status [new_screen_file].display_procedure_p := v$displays [di].procedure_p;
          ofv$screen_status [new_screen_file].display_name := display_name;
          ofv$screen_status [new_screen_file].display_action := ofc$da_process_display;
          ofv$screen_status [new_screen_file].initial_call := TRUE;
          ofv$screen_status [new_screen_file].display_user := ofc$du_ve_display_user;
          osp$clear_signature_lock (ofv$screen_status [new_screen_file].file_lock, status);
          EXIT /execute_task/;
        ELSEIF ofv$screen_status [new_screen_file].display_user = ofc$du_file_user THEN
          osp$clear_signature_lock (ofv$screen_status [new_screen_file].file_lock, status);
          osp$set_status_abnormal ('OF', 1, 'display is busy', status);
          EXIT /execute_task/;
        ELSE
          ofv$screen_status [new_screen_file].display_action := ofc$da_new_display_requested;
          osp$clear_signature_lock (ofv$screen_status [new_screen_file].file_lock, status);
          pmp$wait (half_second, half_second);
        IFEND;
      WHILEND;

    END /execute_task/;

    #INLINE ('keypoint', osk$exit, 0, ofk$execute_display_task);

  PROCEND ofp$execute_display_task;
?? OLDTITLE ??
?? NEWTITLE := 'ofp$search_for_display_name', EJECT ??

{ PURPOSE:
{   Search standard display list for display name. If not found (di=0), assume its a user defined display.
{ NOTE:
{   The procedure is used by OFM$DESIGNER_SCREENS to check for duplicate display names

  PROCEDURE [XDCL, INLINE] ofp$search_for_display_name
    (     display_name: ost$name;
      VAR di: integer);

    di := UPPERBOUND (v$displays);

    WHILE (di > 0 ) AND (v$displays [di].long_name <> display_name)
        AND (v$displays [di].short_name <> display_name) DO
      di := di - 1;
    WHILEND;

 PROCEND ofp$search_for_display_name;
?? OLDTITLE ??
?? NEWTITLE := 'ofp$system_display_manager', EJECT ??

{ PURPOSE:
{   This procedure runs as an asynchronous task in the system job and creates the system console output.

  PROCEDURE [XDCL, #GATE] ofp$system_display_manager
    (    parameters: clt$parameter_list;
     VAR status: ost$status);

    VAR
      action_set: [STATIC, oss$task_private] boolean := FALSE,
      current_time: integer,
      delay_time: integer,
      screen_file: oft$screen_files,
      screen_file_index: oft$screen_files, {  Copy of 'screen_file'.
      screen_status_set_up: [STATIC, oss$task_shared] boolean := FALSE,
      unused_os_defaults: ost$operating_system_default;
?? NEWTITLE := 'clear_screen_file_lock', EJECT ??

{ PURPOSE:
{   This procedures is a condition handler established to clear the screen file lock if the system
{   display manager aborts.  The lock must be clear for the system display manager task to restart.
{
{ NOTE:
{   The variable 'screen_file_index' must be in memory for this condition handler to work.  Users
{   should use #SPOIL to ensure this.

    PROCEDURE clear_screen_file_lock
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        local_status: ost$status, {  Use local status, handler status has special meaning to condition.
        lock_status: ost$signature_lock_status;

      IF condition.selector = pmc$block_exit_processing THEN

        { This task is terminating, clear screen file lock if set.

        osp$initialize_signature_lock (ofv$screen_status [screen_file_index].file_lock,local_status);

      ELSE {  Ignore all other conditions.
        pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
      IFEND;

    PROCEND clear_screen_file_lock;
?? OLDTITLE ??
?? NEWTITLE := 'manage_alarm_fields', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to manage the fields on the main console
{   which alert the operator to conditions requiring operator action
{ NOTE:
{   If any alarm conditions exist to which the main console operator may respond,
{   then initiate the flashing attention field in the main window header. If the
{   attention field is currently flashing, but no alarm conditons exist, then
{   clear the field. The variable dpv$180_operator_action is managed similarly to
{   the attention field to ensure that an operator on a dual state system is
{   aware of any NOS/VE conditions requiring operator action.

    PROCEDURE manage_alarm_fields;

      VAR
        alarm_conditions_exist: boolean,
        capabilities: oft$operator_classes,
        capable: boolean,
        main_window_title:  string (80),
        menu_descriptor: oft$operator_menu_descriptor,
        message_array: array [1 .. 1] of oft$operator_message_descriptor,
        message_count: integer,
        mounts_pending: boolean;

      alarm_conditions_exist := FALSE;
      capabilities := $oft$operator_classes [];

     /check_for_alarm_conditions/
      BEGIN
        IF avc$cc_removable_media_operator IN avv$validated_sou_capabilities THEN
          REPEAT
            iop$tape_mounts_pending (mounts_pending, status);
            IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
              pmp$wait (one_second, one_second);
            IFEND;
          UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
          IF status.normal THEN
            IF mounts_pending THEN
              alarm_conditions_exist := TRUE;
              EXIT /check_for_alarm_conditions/;
            ELSE
              capabilities := $oft$operator_classes [ofc$removable_media_operator];
            IFEND;
          IFEND;
        IFEND;

        IF avc$cc_system_operator IN avv$validated_sou_capabilities THEN
          capabilities := capabilities + $oft$operator_classes [ofc$system_operator];
        IFEND;

        IF capabilities <> $oft$operator_classes [] THEN
          ofp$get_first_operator_menu_r1 (capabilities, menu_descriptor, status);
          IF status.normal THEN
            alarm_conditions_exist := TRUE;
            EXIT /check_for_alarm_conditions/;
          IFEND;

          ofp$get_operator_messages (capabilities, message_array, message_count, status);
          IF message_count <> 0 THEN
            alarm_conditions_exist := TRUE;
          IFEND;
        IFEND;
      END /check_for_alarm_conditions/;

      IF alarm_conditions_exist THEN
        IF NOT action_set THEN
          action_set := TRUE;
          main_window_title :=
                '                              Main Operator Window                       ACTION ';
          main_window_title (1, 1) := $CHAR (14);
          dpp$set_title (dpv$system_core_display, main_window_title, status);
          dpp$set_180_operator_action (TRUE);
        IFEND;
      ELSE
        IF action_set THEN
          action_set := FALSE;
          main_window_title :=
                '                              Main Operator Window                              ';
          dpp$set_title (dpv$system_core_display, main_window_title, status);
          dpp$set_180_operator_action (FALSE);
        IFEND;
      IFEND;

    PROCEND manage_alarm_fields;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    { Setup the screen status data.  Date and time must be updated once per deadstart to assure accuracy.
    { It is done at this point because it can handle the delay for top of minute once it enters the master
    { task loop.

    IF NOT screen_status_set_up THEN
      osp$change_date_time (FALSE, unused_os_defaults, status);
      screen_status_set_up := TRUE;
      FOR screen_file := ofc$sf_display_a TO ofc$sf_main_or_other DO
        IF screen_file = ofc$sf_main_or_other THEN
          ofv$screen_status [screen_file].window_id := dpv$system_core_display;
        ELSE
          dpp$open_window (dpc$wc_invisible, dpc$wk_table, v$screen_name [screen_file],
                ofv$screen_status [screen_file].window_id, status);
        IFEND;
        ofv$screen_status [screen_file].display_action := ofc$da_process_display;
        ofv$screen_status [screen_file].display_name := ' ';
        ofv$screen_status [screen_file].display_user := ofc$du_no_one;
        ofv$screen_status [screen_file].display_procedure_p := NIL;
        ofv$screen_status [screen_file].initial_call := FALSE;
        ofv$screen_status [screen_file].open_file_count := 0;
        osp$initialize_signature_lock (ofv$screen_status [screen_file].file_lock, status);
      FOREND;
    ELSE
      pmp$log (' Operator Display Task Restarted', status);

      osp$initialize_signature_lock (ofv$screen_status [screen_file].file_lock, status);

    IFEND;

    {  The following loop is the main processing loop for updating the operating displays.  It loops for the
    {  life of the operator display task.  Establish a condition handler to clear screen file lock if this
    {  task is aborted with screen file lock set.

    osp$establish_condition_handler (^clear_screen_file_lock, TRUE);

  /master_task_loop/
    WHILE TRUE DO

      { Display the display header and adjust time if necessary.

      ofp$system_header_display;

      manage_alarm_fields;

      { Refresh displays for each screen.

    /process_screen_file/
      FOR screen_file := ofc$sf_display_a TO ofc$sf_display_b DO
        screen_file_index := screen_file;
        #SPOIL (screen_file_index); {  Ensure that variable is in memory for use by the condition handler.

        osp$set_signature_lock (ofv$screen_status [screen_file].file_lock, osc$nowait, status);
        IF NOT status.normal THEN
          CYCLE /process_screen_file/;
        IFEND;

        IF ofv$screen_status [screen_file].display_action = ofc$da_process_display THEN

          { Process the display procedure if one exists.

          IF ofv$screen_status [screen_file].display_procedure_p = NIL THEN
            osp$clear_signature_lock (ofv$screen_status [screen_file].file_lock, status);
            CYCLE /process_screen_file/;
          IFEND;
          ofv$screen_status [screen_file].display_procedure_p^
                (ofv$screen_status [screen_file].window_id, ofv$screen_status [screen_file].display_name,
                v$screen_name [screen_file], ofv$screen_status [screen_file].initial_call, status);
          ofv$screen_status [screen_file].initial_call := FALSE;
          IF NOT status.normal THEN
            ofv$screen_status [screen_file].display_action := ofc$da_terminate_window;
          IFEND;
        ELSEIF ofv$screen_status [screen_file].display_user <> ofc$du_file_user THEN

          { The screen file is not terminated if the file user is still using the display.

          IF ofv$screen_status [screen_file].display_action = ofc$da_terminate_window THEN
            dpp$change_window (ofv$screen_status [screen_file].window_id, dpc$wc_invisible, dpc$wk_table,
                  status);
          IFEND;
          ofv$screen_status [screen_file].display_action := ofc$da_process_display;
          ofv$screen_status [screen_file].display_name := ' ';
          ofv$screen_status [screen_file].display_user := ofc$du_no_one;
          ofv$screen_status [screen_file].display_procedure_p := NIL;
        IFEND;
        osp$clear_signature_lock (ofv$screen_status [screen_file].file_lock, status);

      FOREND /process_screen_file/;

      current_time := #FREE_RUNNING_CLOCK (0);

      { Determine whether or not it is time to emit statistics.

      IF current_time >= osv$time_to_emit_statistics THEN
        osp$emit_os_statistics;
      IFEND;

      { Determine whether or not it is time to log usage statistics.

      IF current_time >= iov$time_to_log_usage_stats THEN
        iop$log_usage_statistics;
      IFEND;

      { Determine whether or not a deferred job has become a candidate for initiation.

      IF current_time >= jmv$time_to_ready_deferred_job THEN
        qfp$ready_deferred_job;
      IFEND;

      { Determine if a deferred print file has become available.

      IF current_time >= jmv$time_to_ready_deferred_file THEN
        qfp$ready_deferred_file;
      IFEND;

      { Determine if a deferred queue file has become available.

      IF current_time >= jmv$ready_deferred_qfile_time THEN
        qfp$ready_deferred_queue_file;
      IFEND;

      { Determine if an expired print file (latest print time) is in the queue.

      IF current_time >= jmv$time_to_purge_expired_file THEN
        jmp$purge_expired_file;
      IFEND;

      { Determine if a printed file needs to be purged (purge delay).

      IF current_time >= jmv$time_to_purge_printed_file THEN
        jmp$purge_printed_file;
      IFEND;

      { Determine if an expired queue file (latest run time) is in the queue.

      IF current_time >= jmv$purge_expired_qfile_time THEN
        jmp$purge_expired_queue_file;
      IFEND;

      { Determine if a processed queue file needs to be purged (purge delay).

      IF current_time >= jmv$purge_processed_qfile_time THEN
        jmp$purge_processed_queue_file;
      IFEND;

      { Wait for the next period to update the display.  If the hardware date/time needs to be updated at the
      { top of minute then adjust the delay time to assure that this task will wake up in time.  If the
      { current time is greater then the maximum wait time then adjust the maximum wait time by multiples of
      { one minute to be greater then current time.  If the current time is less then the minimum wait time
      { then adjust the delay time if necessary else the current time is between the minimum wait time and
      { the maximum wait time so no delay is necessary and the hardware date/time should be updated.

      IF osv$os_defaults.time_data.wait_to_change THEN
        current_time := #FREE_RUNNING_CLOCK (0);
        IF current_time >= osv$os_defaults.time_data.wait_frc.max THEN
          osp$update_wait_frc (current_time);
        IFEND;
        IF current_time < osv$os_defaults.time_data.wait_frc.min THEN
          delay_time := (osv$os_defaults.time_data.wait_frc.min - current_time) DIV 1000;
          IF delay_time < dpv$display_delay THEN
            pmp$wait (delay_time, delay_time);
          ELSE
            pmp$wait (dpv$display_delay, dpv$display_delay);
          IFEND;
        ELSE

          { Current time is between the minimum wait time and the maximum wait time so no delay should
          { be performed.

        IFEND;
      ELSE
        pmp$wait (dpv$display_delay, dpv$display_delay);
      IFEND;

    WHILEND /master_task_loop/;

  PROCEND ofp$system_display_manager;
?? OLDTITLE ??
MODEND ofm$async_task_interfaces;
*DECK DECK=OFM$BUILD_SYSTEM_LINE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: system_line_console_display' ??
MODULE ofm$build_system_line;

{ Purpose:
{         The purpose of this module is to provide a single, consistant
{         block of code which displays the system_console line to the
{         operator console.  Currently, the system console line consists of
{         the idle_statistics for each cpu that is in use, and the percentage
{         of time spent in NOS-170 mode.

?? TITLE := '  Types, XREF Variables, and XREF Procedures', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oft$system_line_info
*copyc osc$multiprocessor_constants
*copyc ost$cpu_idle_statistics
?? POP ??
*copyc mtv$total_nos_cpu_time
*copyc mtv$cst0
*copyc osv$cpus_physically_configured
*copyc osv$170_os_type


?? TITLE := 'binary_to_2_ascii', EJECT ??
{
{ The following inline procedure converts an integer to a 2 character
{ string. If the integer is < 0, then ' 0' is returned. If the integer
{ is > 99 then '99' is returned.

  PROCEDURE [INLINE] binary_to_2_ascii
    (    xn: integer;
     VAR s: string (2));

    VAR
      n: 0 .. 99;

    IF xn < 0 THEN
      s := ' 0';
    ELSEIF xn > 99 THEN
      s := '99';
    ELSE
      n := xn;
      s (2) := $CHAR ((n MOD 10) + $INTEGER ('0'));
      n := n DIV 10;
      IF n > 0 THEN
        s (1) := $CHAR (n + $INTEGER ('0'));
      IFEND;
    IFEND;

  PROCEND binary_to_2_ascii;

?? TITLE := 'ofp$build_system_line', EJECT ??

  PROCEDURE [XDCL] ofp$build_system_line
    (VAR last_info: oft$system_line_info;
     VAR s: string ( * <= 250));

    VAR
      clocktime: integer,
      cpu_index: integer,
      cpu_io_utilization: integer,
      cpu_stats: ost$cpu_idle_statistics,
      cpu_utilization: integer,
      i: integer,
      idletime: integer,
      idle_string: string (7),
      initialized: boolean,
      nostime: integer,
      nos_util: integer;

    s (1, * ) := ' CPU Idle:';

    clocktime := #FREE_RUNNING_CLOCK (0);
    nostime := mtv$total_nos_cpu_time.total;
    initialized := last_info.initialized;

    FOR i := 0 TO osv$cpus_physically_configured - 1 DO
      cpu_stats := mtv$cst0 [i].cpu_idle_statistics;
      idletime := cpu_stats.idle_io_active + cpu_stats.idle_no_io_active;
      IF (mtv$cst0 [i].processor_state = cmc$on) AND initialized THEN
        IF cpu_stats.idle_count = last_info.idle_count [i] THEN
          IF cpu_stats.idle_type = osc$not_idle THEN {cpu utilitization is really the IDLE time}
            idle_string := '  0/ 0,';
          ELSEIF cpu_stats.idle_type = osc$idle_no_io_active THEN
            idle_string := ' 99/ 0,';
          ELSE
            idle_string := ' 99/99,';
          IFEND;
        ELSE
          idle_string := '   /  ,';
          cpu_io_utilization := (((cpu_stats.idle_io_active - last_info.last_io_idletime [i]) * 100) DIV
                (clocktime - last_info.last_clocktime));
          cpu_utilization := (((idletime - last_info.last_idletime [i]) * 100) DIV
                (clocktime - last_info.last_clocktime));
          binary_to_2_ascii (cpu_utilization, idle_string (2, 2));
          binary_to_2_ascii (cpu_io_utilization, idle_string (5, 2));
        IFEND;
        s (i * 7 + 11, 7) := idle_string;
        cpu_index := i;
      IFEND;
      last_info.idle_count [i] := cpu_stats.idle_count;
      last_info.last_idletime [i] := idletime;
      last_info.last_io_idletime [i] := cpu_stats.idle_io_active;
    FOREND;

    IF initialized THEN
      s (cpu_index * 7 + 17) := ' ';
      IF osv$170_os_type <> osc$ot7_none THEN
        nos_util := (((nostime - last_info.last_nostime) * 100) DIV
              (clocktime - last_info.last_clocktime)) MOD 512;
        IF osv$170_os_type = osc$ot7_dual_state_nos_be THEN
          s (69, 4) := 'NBE:';
        ELSE
          s (69, 4) := 'NOS:';
        IFEND;
        binary_to_2_ascii (nos_util, s (74, 2));
      IFEND;
    IFEND;


    last_info.last_nostime := nostime;
    last_info.last_clocktime := clocktime;
    last_info.initialized := TRUE;

  PROCEND ofp$build_system_line;

MODEND ofm$build_system_line
*DECK DECK=OFM$CONSOLE_DISPLAYS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operator Facility : VED JL, SL, OM and TM Displays' ??
MODULE ofm$console_displays;

{   PURPOSE:
{     This module contains procedures that drive the operator displays.
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc clt$display_control
*copyc dme$tape_errors
*copyc dpt$number_of_window_lines
*copyc iot$no_of_tape_units
*copyc iot$rvl_entry_information
*copyc jmt$system_supplied_name
*copyc ofd$type_definition
*copyc ofe$error_codes
*copyc oft$operator_classes
*copyc oft$operator_message_descriptor
*copyc osc$multiprocessor_constants
*copyc oss$task_private
*copyc oss$task_shared
*copyc oss$job_paged_literal
*copyc ost$cpu_idle_statistics
*copyc ost$status
*copyc ost$string
*copyc pmt$ascii_logs
?? POP ??
*copyc avp$system_displays
*copyc clp$close_display
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$put_display
*copyc clp$trimmed_string_size
*copyc dpp$get_starting_line
*copyc dpp$put_next_line
*copyc i#current_sequence_position
*copyc ifp$invoke_pause_utility
*copyc iop$get_tape_mount_information
*copyc iop$tape_mount_count
*copyc jmp$get_ijle_p
*copyc jmp$system_job
*copyc lgp$get_critical_log_read_info
*copyc lgp$get_global_log_read_info
*copyc lgp$get_local_log_read_info
*copyc lgp$get_entry_from_critical_log
*copyc lgp$get_entry_from_global_log
*copyc lgp$get_entry_from_local_log
*copyc ofp$get_active_operator_classes
*copyc ofp$build_system_line
*copyc ofp$get_operator_messages
*copyc ofp$open_display
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pmp$binary_to_ascii_fit
*copyc pmp$continue_to_cause
*copyc pmp$get_os_version
*copyc pmp$long_term_wait

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    one_second = 1000 {milliseconds};

{  Global variables referenced by this module.

*copyc avv$active_sou_capabilities
*copyc jmv$ajl_p
*copyc jmv$ijl_p
*copyc jmv$max_ajl_ordinal_in_use
*copyc jsv$swap_status_id_array
*copyc mmv$gpql
*copyc tmv$display_actual_priority
*copyc mtv$cst0
*copyc osv$task_shared_heap

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    log_info = record
      log: pmt$ascii_logs,
      log_cycle: lgt$log_cycle,
      address: ^SEQ ( * ),
    recend;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ofp$critical_window_log_display', EJECT ??

{   The purpose of this procedure is to start up the display of an ascii log.
{ The task that this procedure is running under will periodically update the
{ header part of the display until another task takes over as the driver of
{ the console display.

  VAR
    cwl_info: [oss$task_shared] log_info;

  PROCEDURE [XDCL] ofp$critical_window_log_display
    (    wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

    display_log (wid, file_name, initial_call, 'Critical Window Log Display',
          {critical_window_message = } TRUE, cwl_info, status);

  PROCEND ofp$critical_window_log_display;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ofp$job_log_display', EJECT ??

{   The purpose of this procedure is to start up the display of an ascii log.
{ The task that this procedure is running under will periodically update the
{ header part of the display until another task takes over as the driver of
{ the console display.

  VAR
    jl_info: [oss$task_shared] log_info;

  PROCEDURE [XDCL] ofp$job_log_display
    (    wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);


    IF initial_call THEN
      jl_info.log := pmc$job_log;
    IFEND;

    display_log (wid, file_name, initial_call, 'Job Log Display            ',
          {critical_window_message = } FALSE, jl_info, status);

  PROCEND ofp$job_log_display;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ofp$operator_message_display', EJECT ??

{ PURPOSE:
{   This procedure displays messages which are awaiting action by the operator.

  PROCEDURE [XDCL] ofp$operator_message_display
    (    wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);
?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure provides clean-up processing when a task abort occurs.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF wid = 0 THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    VAR
      active_operator_classes: oft$operator_classes,
      blank_line: string (2),
      display_control: clt$display_control,
      display_line: string (80),
      ignore_status: ost$status,
      index: oft$number_of_displayable_lines,
      length: integer,
      line_index: dpt$number_of_window_lines,
      line_number: integer,
      lines_written: dpt$number_of_window_lines,
      message_array_entries: integer,
      message_array_p: ^ARRAY [1 .. *] OF oft$operator_message_descriptor,
      message_count: integer,
      message_id: string (8),
      message_index: integer,
      no_messages_line: [READ, oss$job_paged_literal] string (60) :=
            '                   *** No operator messages outstanding. ***',
      starting_line: integer,
      title_line: [READ, oss$job_paged_literal] string (24) := 'Operator Message Display';

    status.normal := TRUE;
    blank_line := ' ';

    { If this is the system job and the display is being written to DISPLAY_A or DISPLAY_B, then operator
    { messages are validated for display based upon the capabilities of the job synchronous task rather
    { than the capabilities of the executing task.

    IF jmp$system_job() AND (wid <> 0) THEN
      IF avc$cc_system_displays IN avv$active_sou_capabilities THEN
        active_operator_classes := -$oft$operator_classes [];
      ELSE
        IF avc$cc_system_operator IN avv$active_sou_capabilities THEN
          active_operator_classes := $oft$operator_classes [ofc$system_operator];
        ELSE
          active_operator_classes := $oft$operator_classes [];
        IFEND;
        IF avc$cc_removable_media_operator IN avv$active_sou_capabilities THEN
          active_operator_classes := active_operator_classes +
                $oft$operator_classes [ofc$removable_media_operator];
        IFEND;
      IFEND;
    ELSE
      IF avp$system_displays () THEN
        active_operator_classes := -$oft$operator_classes [];
      ELSE
        ofp$get_active_operator_classes (active_operator_classes);
      IFEND;
    IFEND;

    IF wid = 0 THEN
      osp$establish_block_exit_hndlr (^abort_handler);
    IFEND;
    IF initial_call THEN
      ofp$open_display (file_name, wid, dpc$wc_sharing, dpc$wk_table, title_line, display_control, status);
      IF NOT status.normal THEN
        IF wid = 0 THEN
          osp$disestablish_cond_handler;
        IFEND;
        RETURN;
      IFEND;
    IFEND;

   /display_opened/
    BEGIN
      IF wid = 0 THEN
        clp$put_display (display_control, blank_line, clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;
        IFEND;
      ELSE
        dpp$get_starting_line (wid, starting_line, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;
        IFEND;
        lines_written := 0;
      IFEND;

      { Get a copy of the messages that this operator is validated to display.  Loop until all messages
      { are retrieved.  Will probably only take two tries.

      message_array_entries := 0;
      message_count := 2;
      WHILE message_array_entries < message_count DO
        message_array_entries := message_count;
        PUSH message_array_p: [1 .. message_array_entries];
        ofp$get_operator_messages (active_operator_classes, message_array_p^, message_count, status);
        IF NOT status.normal THEN
          EXIT /display_opened/;
        IFEND;
        IF message_count = 0 THEN
          IF wid = 0 THEN
            clp$put_display (display_control, blank_line, clc$trim, status);
            IF NOT status.normal THEN
              EXIT /display_opened/;
            IFEND;
            clp$put_display (display_control, no_messages_line, clc$trim, status);
            IF NOT status.normal THEN
              EXIT /display_opened/;
            IFEND;
          ELSE
            dpp$put_next_line (wid, blank_line, status);
            IF NOT status.normal THEN
              EXIT /display_opened/;
            IFEND;
            dpp$put_next_line (wid, no_messages_line, status);
            IF NOT status.normal THEN
              EXIT /display_opened/;
            IFEND;
            lines_written := lines_written + 2;
            FOR line_index := (lines_written + 1) TO dpc$number_of_window_lines DO
              dpp$put_next_line (wid, blank_line, status);
              IF NOT status.normal THEN
                EXIT /display_opened/;
              IFEND;
            FOREND;
          IFEND;
          EXIT /display_opened/;
        IFEND;
      WHILEND;

      { Display the messages.  Each line of each message is checked to see if it falls within the range of
      { lines to be displayed (to support display paging).

      line_number := 1;
      FOR message_index := 1 TO message_count DO

        { Output message header line.

        display_line := ' Message #: ';
        STRINGREP (message_id, length, message_array_p^ [message_index].message_id);
        display_line (17 - length, length) := message_id;
        display_line (55, 6) := 'From: ';
        display_line (61, jmc$system_supplied_name_size) :=
              message_array_p^ [message_index].system_supplied_name;
        IF message_array_p^ [message_index].acknowledgement_allowed THEN
          display_line (22, 28) := 'Acknowledgement: REQUIRED'
        ELSE
          display_line (22, 28) := 'Acknowledgement: NOT ALLOWED'
        IFEND;
        IF wid = 0 THEN
          clp$put_display (display_control, display_line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /display_opened/;
          IFEND;
        ELSE
          IF starting_line <= line_number THEN
            dpp$put_next_line (wid, display_line, status);
            IF NOT status.normal THEN
              EXIT /display_opened/;
            IFEND;
            lines_written := lines_written + 1;
            IF lines_written >= dpc$number_of_window_lines THEN
              EXIT /display_opened/;
            IFEND;
          IFEND;
        IFEND;
        line_number := line_number + 1;

        { Output message line(s).

        FOR index := 1 TO message_array_p^ [message_index].number_of_message_lines DO
          IF wid = 0 THEN
            clp$put_display (display_control, message_array_p^ [message_index].formatted_message [index],
                  clc$trim, status);
            IF NOT status.normal THEN
              EXIT /display_opened/;
            IFEND;
          ELSE
            IF starting_line <= line_number THEN
              dpp$put_next_line (wid, message_array_p^ [message_index].formatted_message [index], status);
              IF NOT status.normal THEN
                EXIT /display_opened/;
              IFEND;
              lines_written := lines_written + 1;
              IF lines_written >= dpc$number_of_window_lines THEN
                EXIT /display_opened/;
              IFEND;
            IFEND;
          IFEND;
          line_number := line_number + 1;
        FOREND;

        { Output blank line.

        IF wid = 0 THEN
          clp$put_display (display_control, blank_line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /display_opened/;
          IFEND;
        ELSE
          IF starting_line <= line_number THEN
            dpp$put_next_line (wid, blank_line, status);
            IF NOT status.normal THEN
              EXIT /display_opened/;
            IFEND;
            lines_written := lines_written + 1;
            IF lines_written >= dpc$number_of_window_lines THEN
              EXIT /display_opened/;
            IFEND;
          IFEND;
        IFEND;
        line_number := line_number + 1;
      FOREND;

      { Clear the rest of the display window.

      IF wid <> 0 THEN
        IF lines_written < dpc$number_of_window_lines THEN
          FOR line_index := (lines_written + 1) TO dpc$number_of_window_lines DO
            dpp$put_next_line (wid, blank_line, status);
            IF NOT status.normal THEN
              EXIT /display_opened/;
            IFEND;
          FOREND;
        IFEND;
      IFEND;
    END /display_opened/;

    IF wid = 0 THEN
      clp$close_display (display_control, ignore_status);
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND ofp$operator_message_display;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ofp$system_log_display', EJECT ??

{   The purpose of this procedure is to start up the display of an ascii log.
{ The task that this procedure is running under will periodically update the
{ header part of the display until another task takes over as the driver of
{ the console display.

  VAR
    sl_info: [oss$task_shared] log_info;

  PROCEDURE [XDCL] ofp$system_log_display
    (    wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

    IF initial_call THEN
      sl_info.log := pmc$system_log;
    IFEND;

    display_log (wid, file_name, initial_call, 'System Log Display         ',
          {critical_window_message = } FALSE, sl_info, status);

  PROCEND ofp$system_log_display;
?? OLDTITLE ??
?? NEWTITLE := 'display_log', EJECT ??

  PROCEDURE display_log
    (    wid: dpt$window_id;
         file_name: amt$local_file_name;
         initial_call: boolean;
         title: string (27);
         critical_window_message: boolean;
     VAR info: log_info;
     VAR status: ost$status);
?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure provides clean-up processing when a task abort occurs.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF wid = 0 THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

{ The following constant defines the maximum number of entries that will be displayed before this procedure
{ gives up control.  This allows the operator to change displays even though the end of the log has not been
{ reached.

    CONST
      maximum_entries_to_display = 30;

    VAR
      display_control: clt$display_control,
      entry_count: integer,
      byte_address: amt$file_byte_address,
      ignore_status: ost$status,
      length: lgt$log_entry_size,
      line: string (255),
      eof: boolean;

    status.normal := TRUE;

    IF wid = 0 THEN
      osp$establish_block_exit_hndlr (^abort_handler);
    IFEND;
    IF initial_call THEN
      ofp$open_display (file_name, wid, dpc$wc_sharing, dpc$wk_log, title, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF critical_window_message THEN
        lgp$get_critical_log_read_info (30, info.log_cycle,
              info.address, byte_address, status);
      ELSEIF info.log = pmc$system_log THEN
        lgp$get_global_log_read_info (pmc$system_log, 30, info.log_cycle, info.address, byte_address, status);
      ELSE { info.log = pmc$job_log }
        lgp$get_local_log_read_info (pmc$job_log, 30, info.log_cycle, info.address, byte_address, status);
      IFEND;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    entry_count := 0;

  /main_loop/
    BEGIN
      REPEAT
        IF critical_window_message THEN
          lgp$get_entry_from_critical_log (info.log_cycle, info.address, length,
                #SEQ (line) ^, status);
        ELSEIF info.log = pmc$system_log THEN
          lgp$get_entry_from_global_log (pmc$system_log, info.log_cycle, info.address, length,
                #SEQ (line) ^, status);
        ELSE { info.log = pmc$job_log }
          lgp$get_entry_from_local_log (pmc$job_log, info.log_cycle, info.address, length,
                #SEQ (line) ^, status);
        IFEND;
        IF status.normal THEN
          IF length > #SIZE(line) THEN
            length := #SIZE(line);
          IFEND;
          IF wid <> 0 THEN
            dpp$put_next_line (wid, line (1, length), status);
          ELSE
            clp$put_display (display_control, line (1, length), clc$trim, status);
          IFEND;
        IFEND;

        entry_count := entry_count + 1;
      UNTIL (NOT status.normal) OR (entry_count > maximum_entries_to_display);
    END /main_loop/;
    IF NOT status.normal THEN
      IF status.condition = lge$end_of_log THEN
        status.normal := TRUE;
      ELSEIF status.condition = lge$log_cycles_do_not_match THEN
        status.normal := TRUE;
        IF critical_window_message THEN
          lgp$get_critical_log_read_info (0, info.log_cycle,
                info.address, byte_address, status);
        ELSEIF info.log = pmc$system_log THEN
          lgp$get_global_log_read_info (pmc$system_log, 0, info.log_cycle,
                info.address, byte_address, status);
        ELSE { info.log = pmc$job_log }
          lgp$get_local_log_read_info (pmc$job_log, 0, info.log_cycle, info.address, byte_address, status);
        IFEND;
        RESET info.address;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    IF wid = 0 THEN
      clp$close_display (display_control, status);
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND display_log;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ofp$tape_mount_display', EJECT ??

{ PURPOSE:
{   This procedure displays tape mount requests which are awaiting
{   action by the operator.

  PROCEDURE [XDCL] ofp$tape_mount_display
    (    wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure provides clean-up processing when a task abort occurs.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF wid = 0 THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE ??
?? NEWTITLE := '  output_line', EJECT ??
    PROCEDURE output_line
      (VAR status: ost$status);

      IF wid <> 0 THEN
        dpp$put_next_line (wid, display_line, status);
      ELSE
        clp$put_display (display_control, display_line, clc$trim, status);
      IFEND;

      display_line := ' ';
      col := 3;
    PROCEND output_line;
?? OLDTITLE ??
?? NEWTITLE := '  output_requestor_line', EJECT ??
    PROCEDURE output_requestor_line
      (VAR status: ost$status);

      CONST
        account_text = 'Account: ',
        account_text_size = 9,
        comma_text = ', ',
        comma_text_size = 2,
        family_text = 'Family: ',
        family_text_size = 8,
        project_text = 'Project: ',
        project_text_size = 9,
        user_text = 'User: ',
        user_text_size = 6;

      VAR
        size: 1 .. 31,
        name: ost$name;

      status.normal := TRUE;
      display_line := ' ';
      col := 3;

      IF (rvl_info_array_p^ [index].requested_volume_attributes.family <> osc$null_name) OR
            (rvl_info_array_p^ [index].requested_volume_attributes.user <> osc$null_name) OR
            (rvl_info_array_p^ [index].requested_volume_attributes.account <> osc$null_name) OR
            (rvl_info_array_p^ [index].requested_volume_attributes.project <> osc$null_name) THEN

        IF (rvl_info_array_p^ [index].requested_volume_attributes.family <> osc$null_name) THEN
          display_line (col, family_text_size) := family_text;
          col := col + family_text_size;
          name := rvl_info_array_p^ [index].requested_volume_attributes.family;
          size := clp$trimmed_string_size (name);
          display_line (col, size) := name (1, size);
          col := col + size;
        IFEND;

        IF rvl_info_array_p^ [index].requested_volume_attributes.user <> osc$null_name THEN
          IF col > 3 THEN
            display_line (col, comma_text_size) := comma_text;
            col := col + comma_text_size;
          IFEND;
          name := rvl_info_array_p^ [index].requested_volume_attributes.user;
          size := clp$trimmed_string_size (name);
          IF (col + user_text_size + size) > 80 THEN
            output_line (status);
          IFEND;
          IF status.normal THEN
            display_line (col, user_text_size) := user_text;
            col := col + user_text_size;
            display_line (col, size) := name (1, size);
            col := col + size;
          IFEND;
        IFEND;

        IF status.normal AND (rvl_info_array_p^ [index].requested_volume_attributes.account <> osc$null_name)
              THEN
          IF col > 3 THEN
            display_line (col, comma_text_size) := comma_text;
            col := col + comma_text_size;
          IFEND;
          name := rvl_info_array_p^ [index].requested_volume_attributes.account;
          size := clp$trimmed_string_size (name);
          IF (col + account_text_size + size) > 80 THEN
            output_line (status);
          IFEND;
          IF status.normal THEN
            display_line (col, account_text_size) := account_text;
            col := col + account_text_size;
            display_line (col, size) := name (1, size);
            col := col + size;
          IFEND;
        IFEND;

        IF status.normal AND (rvl_info_array_p^ [index].requested_volume_attributes.project <> osc$null_name)
              THEN
          IF col > 3 THEN
            display_line (col, comma_text_size) := comma_text;
            col := col + comma_text_size;
          IFEND;
          name := rvl_info_array_p^ [index].requested_volume_attributes.project;
          size := clp$trimmed_string_size (name);
          IF (col + project_text_size + size) > 80 THEN
            output_line (status);
          IFEND;
          IF status.normal THEN
            display_line (col, project_text_size) := project_text;
            col := col + project_text_size;
            display_line (col, size) := name (1, size);
            col := col + size;
          IFEND;
        IFEND;
        IF status.normal AND (col > 3) THEN
          output_line (status);
        IFEND;
      IFEND;

    PROCEND output_requestor_line;
?? OLDTITLE ??
?? NEWTITLE := '  output_rms_line', EJECT ??

    PROCEDURE output_rms_line
      (VAR status: ost$status);

      CONST
        comma_text = ', ',
        comma_text_size = 2,
        group_text = 'Group: ',
        group_text_size = 7,
        location_text = 'Location: ',
        location_text_size = 10,
        slot_text = 'Slot: ',
        slot_text_size = 6;

      VAR
        size: 1 .. 31,
        name: ost$name;

      display_line := ' ';
      col := 3;
      status.normal := TRUE;

      IF (rvl_info_array_p^ [index].requested_volume_attributes.removable_media_group <> osc$null_name) OR
            (rvl_info_array_p^ [index].requested_volume_attributes.removable_media_location <>
            osc$null_name) OR (rvl_info_array_p^ [index].requested_volume_attributes.slot <> osc$null_name)
            THEN

        IF (rvl_info_array_p^ [index].requested_volume_attributes.removable_media_group <> osc$null_name) THEN
          name := rvl_info_array_p^ [index].requested_volume_attributes.removable_media_group;
          size := clp$trimmed_string_size (name);
          display_line (col, group_text_size) := group_text;
          col := col + group_text_size;
          display_line (col, size) := name (1, size);
          col := col + size;
        IFEND;

        IF rvl_info_array_p^ [index].requested_volume_attributes.removable_media_location <>
              osc$null_name THEN
          IF col > 3 THEN
            display_line (col, comma_text_size) := comma_text;
            col := col + comma_text_size;
          IFEND;
          name := rvl_info_array_p^ [index].requested_volume_attributes.removable_media_location;
          size := clp$trimmed_string_size (name);
          IF (col + location_text_size + size) > 80 THEN
            output_line (status);
          IFEND;
          IF status.normal AND (size > 0) THEN
            display_line (col, location_text_size) := location_text;
            col := col + location_text_size;
            display_line (col, size) := name (1, size);
            col := col + size;
          IFEND;
        IFEND;

        IF status.normal AND (rvl_info_array_p^ [index].requested_volume_attributes.slot <> osc$null_name)
              THEN
          IF col > 3 THEN
            display_line (col, comma_text_size) := comma_text;
            col := col + comma_text_size;
          IFEND;
          name := rvl_info_array_p^ [index].requested_volume_attributes.slot;
          size := clp$trimmed_string_size (name);
          IF (col + slot_text_size + size) > 80 THEN
            output_line (status);
          IFEND;
          IF status.normal THEN
            display_line (col, slot_text_size) := slot_text;
            col := col + slot_text_size;
            display_line (col, size) := name (1, size);
            col := col + size;
          IFEND;
        IFEND;
        IF status.normal AND (col > 3) THEN
          output_line (status);
        IFEND;
      IFEND;

    PROCEND output_rms_line;

?? OLDTITLE ??
?? NEWTITLE := '  tape_mount_display_handler  ', EJECT ??

    PROCEDURE tape_mount_display_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      CASE condition.selector OF
      = ifc$interactive_condition =
        CASE condition.interactive_condition OF
        = ifc$pause_break, ifc$job_reconnect =
          ifp$invoke_pause_utility (ignore_status);
        = ifc$terminate_break =
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
                ignore_status);
          EXIT ofp$tape_mount_display;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;

    PROCEND tape_mount_display_handler;

?? OLDTITLE, EJECT ??
    VAR
      all_tape_mounts_found: boolean,
      col: 1 .. 80,
      current_element: iot$rvl_entry_information,
      display_control: clt$display_control,
      display_line: string (80),
      ending_index: integer,
      index: integer,
      ignore_status: ost$status,
      loop1_index: iot$no_of_tape_units,
      loop2_index: iot$no_of_tape_units,
      no_tape_mounts_line: [READ, oss$job_paged_literal] string (61) :=
            '                  *** No tape mount requests outstanding. ***',
      rvl_info_array_p: ^array [1 .. * ] of iot$rvl_entry_information,
      starting_index: integer,
      tape_mount_count: integer,
      title_line: [READ, oss$job_paged_literal] string (80) :=
            ' Mount  M Dens <--Operator Action--> A C System_Job_Name     Time  Prev   Next';

    status.normal := TRUE;

    IF wid = 0 THEN
      osp$establish_block_exit_hndlr (^abort_handler);
    IFEND;
    IF initial_call THEN
      ofp$open_display (file_name, wid, dpc$wc_sharing, dpc$wk_table, title_line, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    REPEAT
      iop$tape_mount_count (tape_mount_count, status);
      IF NOT status.normal THEN
        IF status.condition = dme$unable_to_lock_tape_table THEN
          osp$establish_condition_handler (^tape_mount_display_handler, {handle block exit} FALSE);
          pmp$long_term_wait (one_second, one_second);
          osp$disestablish_cond_handler;
        ELSE
          tape_mount_count := 0;
          status.normal := TRUE;
        IFEND;
      IFEND;
    UNTIL status.normal;

    IF wid <> 0 THEN
      dpp$get_starting_line (wid, starting_index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF starting_index <> 1 THEN
        IF tape_mount_count <> 0 THEN
          starting_index := starting_index MOD tape_mount_count;
          IF starting_index = 0 THEN
            starting_index := 1;
          IFEND;
        ELSE
          starting_index := 1;
        IFEND;
      IFEND;

      ending_index := starting_index + dpc$number_of_window_lines - 1;
      index := 0;
    ELSE
      display_line := '  ';
      clp$put_display (display_control, display_line, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ If there are active tape mount requests, then obtain all Requested VSN List
{ (rvl) entries for the active requests. To ensure we obtain all of the tape
{ mount requests for display, we repeatedly PUSH space on the run time stack
{ and call iop$get_tape_mount_information until all tape mount requests are
{ found. In theory this loop could be repeated and the run time stack could
{ become very large if new tape mount requests continue to occur each and every
{ time that iop$get_tape_mount_information is called without any of the old
{ requests ever being satisfied. But in actual practice this is a highly
{ unlikely scenario.

    IF tape_mount_count <> 0 THEN
      PUSH rvl_info_array_p: [LOWERBOUND (rvl_info_array_p^) .. tape_mount_count];

      REPEAT
        REPEAT
          iop$get_tape_mount_information (rvl_info_array_p, all_tape_mounts_found, status);
          IF NOT status.normal THEN
            IF status.condition = dme$unable_to_lock_tape_table THEN
              osp$establish_condition_handler (^tape_mount_display_handler, {handle block exit} FALSE);
              pmp$long_term_wait (one_second, one_second);
              osp$disestablish_cond_handler;
            ELSE
              RETURN;
            IFEND;
          IFEND;
        UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF NOT all_tape_mounts_found THEN
          tape_mount_count := tape_mount_count + 1;
          PUSH rvl_info_array_p: [LOWERBOUND (rvl_info_array_p^) .. tape_mount_count];
        IFEND;
      UNTIL all_tape_mounts_found;

{ Sort tape mount request array elements according to time the tape file was opened.

    /sort_mount_loop1/
      FOR loop1_index := LOWERBOUND (rvl_info_array_p^) TO UPPERBOUND (rvl_info_array_p^) - 1 DO
        IF rvl_info_array_p^ [loop1_index].null_entry THEN
          EXIT /sort_mount_loop1/;
        IFEND;
        index := loop1_index;
        current_element := rvl_info_array_p^ [loop1_index];

      /sort_mount_loop2/
        FOR loop2_index := (loop1_index + 1) TO UPPERBOUND (rvl_info_array_p^) DO
          IF rvl_info_array_p^ [loop2_index].null_entry THEN
            EXIT /sort_mount_loop2/;
          IFEND;
          IF rvl_info_array_p^ [loop2_index].time_of_mount_request <
                current_element.time_of_mount_request THEN
            index := loop2_index;
            current_element := rvl_info_array_p^ [loop2_index];
          IFEND;
        FOREND /sort_mount_loop2/;

        rvl_info_array_p^ [index] := rvl_info_array_p^ [loop1_index];
        rvl_info_array_p^ [loop1_index] := current_element;
      FOREND /sort_mount_loop1/;

      IF wid <> 0 THEN
        IF starting_index > UPPERBOUND (rvl_info_array_p^) THEN
          starting_index := 1;
          ending_index := starting_index + dpc$number_of_window_lines - 1;
        IFEND;
        IF ending_index > UPPERBOUND (rvl_info_array_p^) THEN
          ending_index := UPPERBOUND (rvl_info_array_p^);
        IFEND;
      ELSE
        starting_index := 1;
        ending_index := UPPERBOUND (rvl_info_array_p^);
      IFEND;

    /scan_rvl_info/
      FOR index := starting_index TO ending_index DO
        display_line := '  ';
        IF rvl_info_array_p^ [index].null_entry THEN
          IF wid <> 0 THEN
            dpp$put_next_line (wid, display_line, status);
          ELSE
            clp$put_display (display_control, display_line, clc$trim, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          EXIT /scan_rvl_info/;
        IFEND;

        display_line (2, 6) := rvl_info_array_p^ [index].current_vsn;
        display_line (42, 19) := rvl_info_array_p^ [index].ssn;
        display_line (62, 5) := rvl_info_array_p^ [index].time_of_mount_request;
        display_line (68, 6) := rvl_info_array_p^ [index].previous_vsn;
        display_line (75, 6) := rvl_info_array_p^ [index].next_vsn;

        IF rvl_info_array_p^ [index].requested_tape_characteristics.write_ring THEN
          display_line (9, 1) := 'W';
        ELSE
          display_line (9, 1) := 'R';
        IFEND;

        CASE rvl_info_array_p^ [index].requested_tape_characteristics.density OF
        = rmc$200 =
          display_line (11, 3) := '200';
        = rmc$556 =
          display_line (11, 3) := '556';
        = rmc$800 =
          display_line (11, 3) := '800';
        = rmc$1600 =
          display_line (11, 4) := '1600';
        = rmc$6250 =
          display_line (11, 4) := '6250';
        = rmc$38000 =
          display_line (11, 5) := '38000';
        ELSE

{ We have encountered an unknown tape density.

          display_line (12, 4) := '****'
        CASEND;
        IF (rvl_info_array_p^ [index].operator_assignment_type = ioc$expecting_manual_assignment) THEN
          display_line (16, 20) := 'ASSIGN_DEVICE needed';
        IFEND;

        CASE rvl_info_array_p^ [index].requested_tape_characteristics.label_type OF
          = amc$labeled =
            display_line (38, 1) := 'L';
          = amc$unlabeled =
            display_line (38, 1) := 'U';
          = amc$non_standard_labeled =
            display_line (38, 1) := 'N';
        ELSE
        CASEND;

        IF (rvl_info_array_p^ [index].requested_tape_characteristics.character_set = amc$ebcdic) THEN
          display_line (40, 1) := 'E';
        ELSE
          display_line (40, 1) := 'A';
        IFEND;

        output_line (status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ The following code adds optional fields to one or two additional lines in the display.
{ A blank field is ignored.  A line is omitted if all of its fields are blank.
          output_requestor_line (status);
          IF status.normal THEN
            output_rms_line (status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
      FOREND /scan_rvl_info/;
    IFEND;

    display_line := ' ';
    IF wid = 0 THEN
      IF tape_mount_count = 0 THEN
        clp$put_display (display_control, display_line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$put_display (display_control, no_tape_mounts_line, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    ELSE
      IF index < starting_index + dpc$number_of_window_lines - 1 THEN
        ending_index := starting_index + dpc$number_of_window_lines - 1;
      IFEND;

      IF tape_mount_count = 0 THEN
        dpp$put_next_line (wid, display_line, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        dpp$put_next_line (wid, no_tape_mounts_line, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        index := index + 2;
      IFEND;

      starting_index := index;
      FOR index := starting_index + 1 TO ending_index DO
        dpp$put_next_line (wid, display_line, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    IF wid = 0 THEN
      clp$close_display (display_control, status);
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND ofp$tape_mount_display;
?? OLDTITLE ??

 MODEND ofm$console_displays
*DECK DECK=OFM$CRITICAL_WINDOW_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE : operator facility' ??
MODULE ofm$critical_window_manager;

{  PURPOSE:
{    This module exists to provide entry points to run the asynchronous
{    critical window manager task.
{  DESIGN:
{    Entry point is declared.  The task which it defines will call a ring
{    1 procedure to log entries in the critical window into the critical
{    window log.  It will do this whenever there is something that needs
{    to be logged.

*copyc dpv$critical_msgs_need_logging
*copyc jmv$executing_within_system_job
*copyc ofp$log_critical_mtr_messages
*copyc pmp$wait

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ofp$critical_window_manager', EJECT ??

  PROCEDURE [XDCL, #GATE] ofp$critical_window_manager;

*copyc ofh$critical_window_manager

    IF NOT jmv$executing_within_system_job THEN
      RETURN;
    IFEND;

    WHILE TRUE DO
      IF dpv$critical_msgs_need_logging THEN
        ofp$log_critical_mtr_messages;
      IFEND;
      pmp$wait (10000, 10000);
    WHILEND;

  PROCEND ofp$critical_window_manager;
MODEND ofm$critical_window_manager;
*DECK DECK=OFM$DESIGNER_SCREENS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Designer Screens - Command Processors' ??
MODULE ofm$designer_screens;

{ PURPOSE:
{   This module contains the command processors for the VED UTILITY. This utility allows
{   each site/user to define their own operator displays such as the AJ, IJ or IJD.
{   display.  It also contains the DISPLAY_SITE_VED_NAMES command which displays
{   the names of the current available VED displays.
{
{   This module contains the following command processors::
{       VEDU  utility with the following subcommands:
{           CREATE_INITIATED_JOB_DISPLAY
{           DELETE_INITIATED_JOB_DISPLAY
{           CHANGE_INITIATED_JOB_DISPLAY
{           QUIT
{
{   Notes:
{       To add a new field that can be displayed on a display:
{              o Add a FIELD_ID to the TYPE oft$field_id (see deck OFT$DESIGNER_SCREENS_TYPES
{              o Make an entry for the field in the FIELD_NAME_ARRAY (see below)
{              o If the field is displayed left justified, add its field_id to
{                   the variable LEFT_JUSTIFIED_FIELDS (see below)
{              o Update the BUILD_LINE procedure in OFM$DESIGNER_SCREENS_R3 to
{                   display the new field.
{              o Update the PDT definitions in OFD$PDT_CREATE_INIT_JOB_DISPLAY and
{                   OFD$PDT_CHANGE_INIT_JOB_DISPLAY.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ofc$condition_limits
*copyc ofe$ecc_designer_screens
*copyc oft$designer_screens_types
*copyc oss$job_paged_literal
?? POP ??
*copyc clp$begin_utility
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_line
*copyc clp$include_file
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc ofp$access_display_description
*copyc ofp$display_site_ved_names
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition

*copyc ofv$displays_initialized
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

{ The following definitions are used by the CREIJD and CHAIJD command processors to call
{ common command processing routines. The definitions are used to specify the parameter
{ numbers of various parameters, ie. pvt_numbers_list [pn$title] contains p$title where
{ the value of p$title is command dependent.

  CONST
    pn$display_system_line = 0,
    pn$display_blank_lines = 1,
    pn$jobs_per_line = 2,
    pn$job_selection = 3,
    pn$title = 4,
    pn$alias = 5;

  TYPE
    pvt_numbers_list = array [0 .. 5] of 0 .. 255;


{ Utility definitions.

  VAR
    command_file: [STATIC, oss$job_paged_literal, READ] amt$local_file_name := clc$current_command_input,
    utility_name: [STATIC, oss$job_paged_literal, READ] string (31) := 'VIRTUAL_ENVIRO_DISPLAY_UTILITY',
    utility_attributes: [STATIC, oss$job_paged_literal, READ] array
          [1 .. 2] of clt$utility_attribute := [[clc$utility_command_table, ^command_table_entries],
          [clc$utility_prompt, [4, 'VEDU']]];



{ table command_table
{ command (change_initiated_job_display, chaijd )    ofp$_change_init_job_display
{ command (create_initiated_job_display, creijd)     ofp$_create_init_job_display
{ command (delete_initiated_job_display, delijd )    ofp$_delete_init_job_display
{ command (quit, qui)                                ofp$_quit
{ tablend

?? PUSH (LISTEXT := ON) ??

  VAR
    command_table: [STATIC, oss$job_paged_literal, READ] ^clt$command_table := ^command_table_entries,

    command_table_entries: [STATIC, oss$job_paged_literal, READ] array [1 .. 8] of
                 clt$command_table_entry := [
          {} ['CHAIJD                         ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^ofp$_change_init_job_display],
          {} ['CHANGE_INITIATED_JOB_DISPLAY   ', clc$nominal_entry, clc$normal_usage_entry, 1,
          clc$automatically_log, clc$linked_call, ^ofp$_change_init_job_display],
          {} ['CREATE_INITIATED_JOB_DISPLAY   ', clc$nominal_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^ofp$_create_init_job_display],
          {} ['CREIJD                         ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
          clc$automatically_log, clc$linked_call, ^ofp$_create_init_job_display],
          {} ['DELETE_INITIATED_JOB_DISPLAY   ', clc$nominal_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^ofp$_delete_init_job_display],
          {} ['DELIJD                         ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
          clc$automatically_log, clc$linked_call, ^ofp$_delete_init_job_display],
          {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^ofp$_quit],
          {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 4,
          clc$automatically_log, clc$linked_call, ^ofp$_quit]];

?? POP ??
?? TITLE := 'Parameter Table', EJECT ??

{
{ The following table defines display field names and default attributes for fields that
{ that can appear on displays.
{
{ Each entry in the table contains the following information:
{    o Name - MUST match the name defined in the command PDTs.
{    o Name abbreviation - MUST match the abbreviation defined in the command PDTs.
{    o Internal identifier for the field - ordinal type specified by OFT$FIELD_ID.
{    o Default field width.
{    o Default field scale. Numeric fields are divided by this number before being
{        displayed. For example, a value of 1000000 will convert an internal field
{        kept in microsecond to a displayed value in seconds.
{        Non-numeric fields must specify a value of ZERO.
{    o Boolean that indicated whether the field may be displayed
{        incrementally, ie., each time the field is displayed, the incremental change
{        in the field value is displayed.
{

  TYPE
    field_name_array_entry = record
      field_name: ost$name,
      field_name_abbrev: string (4),
      field_id: oft$field_id,
      default_width: 0 .. ofc$max_display_width,
      default_scale: oft$scale_divisor,
      incremental: boolean,
    recend;

?? FMT (FORMAT := OFF) ??

  TYPE
    field_name_array_index = 1..47;

{ The following set specifies the fields that are displayed left-justified.
  VAR
    left_justified_fields: [STATIC, oss$job_paged_literal, READ] SET OF oft$field_id :=
      [ofc$fi_ssn_full, ofc$fi_ssn_long, ofc$fi_ssn_short, ofc$fi_fill,
               ofc$fi_display_message, ofc$fi_user_job_name, ofc$fi_dispatching_priority,
               ofc$fi_dispatching_priority_act, ofc$fi_terminal_name],


    field_name_array: [STATIC, oss$job_paged_literal, READ] array [field_name_array_index]
             of field_name_array_entry :=
    [['ACTIVE_IO_PAGES                ', 'AIP ', ofc$fi_active_io_pages, 4, 1, FALSE],
     ['ACTIVE_IO_REQUESTS             ', 'AIR ', ofc$fi_active_io_requests, 4, 1, FALSE],
     ['AJL_ORDINAL                    ', 'AJLO', ofc$fi_ajl_ordinal, 4, 1, FALSE],
     ['CPU_TIME_INCREMENT             ', 'CTI ', ofc$fi_cp_time_increment, 7, 1000000, TRUE],
     ['CPU_TIME_JOB                   ', 'CTJ ', ofc$fi_cp_time_job, 7, 1000000, TRUE],
     ['CPU_TIME_MONITOR               ', 'CTM ', ofc$fi_cp_time_monitor, 7, 1000000, TRUE],
     ['CPU_TIME_TOTAL                 ', 'CTT ', ofc$fi_cp_time_total, 7, 1000000, TRUE],
     ['DISPATCHING_PRIORITY           ', 'DP  ', ofc$fi_dispatching_priority, 4, 0, FALSE],
     ['DISPATCHING_PRIORITY_ACTUAL    ', 'DPA ', ofc$fi_dispatching_priority_act, 4, 0, FALSE],
     ['DISPLAY_MESSAGE                ', 'DM  ', ofc$fi_display_message, 30, 0, FALSE],
     ['FILL                           ', '    ', ofc$fi_fill, 1, 0, FALSE],
     ['GUARANTEED_SERVICE_REMAINING   ', 'GSR ', ofc$fi_guaranteed_service_rem, 10, 1, TRUE],
     ['HUNG_TASK                      ', 'HT  ', ofc$fi_hung_task_in_job_flag, 3, 0, FALSE],
     ['IJL_ORDINAL                    ', 'IJLO', ofc$fi_ijl_ordinal, 4, 1, FALSE],
     ['JOB_CLASS                      ', 'JC  ', ofc$fi_job_class, 3, 0, FALSE],
     ['JOB_ENTRY_STATUS               ', 'JES ', ofc$fi_job_entry_status, 2, 0, FALSE],
     ['JOB_MODE                       ', 'JM  ', ofc$fi_job_mode, 3, 0, FALSE],
     ['JOB_PRIORITY                   ', 'JP  ', ofc$fi_job_priority, 10, 1, TRUE],
     ['JOB_STATUS                     ', 'JS  ', ofc$fi_job_status, 3, 0, FALSE],
     ['JOB_SWAP_COUNT                 ', 'JSC ', ofc$fi_job_swap_count, 6, 1, TRUE],
     ['LAST_THINK_TIME                ', 'LTT ', ofc$fi_last_think_time, 5, 1000000, FALSE],
     ['MEMORY_PAGES                   ', 'MP  ', ofc$fi_memory_pages, 5, 1, FALSE],
     ['PAGE_FAULT_COUNT               ', 'PFC ', ofc$fi_page_fault_count, 8, 1, TRUE],
     ['PERCENT_CPU_USAGE              ', 'PCU ', ofc$fi_percent_cp_usage, 4, 1, TRUE],
     ['PERMANENT_FILE_SPACE           ', 'PFS ', ofc$fi_permanent_file_space, 6, 1000000, FALSE],
     ['PAGES_ASSIGNED                 ', 'PA  ', ofc$fi_ps_pages_assigned, 8, 1, TRUE],
     ['PAGES_SERVER                   ', 'PS  ', ofc$fi_ps_pages_from_server, 8, 1, TRUE],
     ['PAGES_RECLAIMED                ', 'PR  ', ofc$fi_ps_pages_reclaimed, 8, 1, TRUE],
     ['PAGE_IN                        ', 'PI  ', ofc$fi_ps_page_in, 8, 1, TRUE],
     ['READY_TASK_COUNT               ', 'RTC ', ofc$fi_ready_task_count, 3, 1, FALSE],
     ['SERVICE_ACCUMULATOR            ', 'SA  ', ofc$fi_service_accumulator, 10, 1, TRUE],
     ['SERVICE_CLASS                  ', 'SC  ', ofc$fi_service_class, 3, 0, FALSE],
     ['SERVICE_SINCE_SWAP             ', 'SSS ', ofc$fi_service_since_swap, 10, 1, TRUE],
     ['SYSTEM_JOB_NAME                ', 'SJN ', ofc$fi_ssn_full, 20, 0, FALSE],
     ['SYSTEM_JOB_NAME_LONG           ', 'SJNL', ofc$fi_ssn_long, 10, 0, FALSE],
     ['SYSTEM_JOB_NAME_SHORT          ', 'SJNS', ofc$fi_ssn_short, 6, 0, FALSE],
     ['SWAP_ENTRY_STATUS              ', 'SES ', ofc$fi_swap_entry_status, 3, 0, FALSE],
     ['SWAP_IN_WAIT_TIME              ', 'SIWT', ofc$fi_swap_in_wait_time, 5, 1000000, FALSE],
     ['SWAP_REASON                    ', 'SR  ', ofc$fi_swap_reason, 3, 0, FALSE],
     ['SWAP_STATUS                    ', 'SS  ', ofc$fi_swap_status, 3, 0, FALSE],
     ['TEMPORARY_FILE_SPACE           ', 'TFS ', ofc$fi_temporary_file_space, 6, 1000000, FALSE],
     ['TERMINAL_NAME                  ', 'TN  ', ofc$fi_terminal_name, 32, 0, FALSE],
     ['THINK_TIME                     ', 'TT  ', ofc$fi_think_time, 5, 1000000, FALSE],
     ['THRASHING_FLAG                 ', 'TF  ', ofc$fi_thrashing_flag, 3, 0, FALSE],
     ['TIME_IN_SWAP_STATE             ', 'TISS', ofc$fi_time_in_swap_state, 5, 1000000, FALSE],
     ['USER_JOB_NAME                  ', 'UJN ', ofc$fi_user_job_name, 9, 0, FALSE],
     ['WORKING_SET_SIZE               ', 'WSS ', ofc$fi_working_set_size, 5, 1, FALSE]];

?? FMT (FORMAT := ON) ??
?? TITLE := 'convert_field_name_to_id ', EJECT ??

{ PURPOSE:
{    This procedure converts a string value of a field name to its ordinal value.
{ INPUT:
{    name: ascii value of the field name
{ OUTPUT:
{    field_id: ordinal value of the field name
{    fna_index: index into the FIELD_NAME_ARRAY of the entry for this field.
{    status: ofe$unknown_field_name
{


  PROCEDURE convert_field_name_to_id
    (    name: ost$name;
     VAR field_id: oft$field_id;
     VAR fna_index: field_name_array_index;
     VAR status: ost$status);

    VAR
      i: integer;

    status.normal := TRUE;
    i := UPPERBOUND (field_name_array);
    WHILE (i > 0) AND (field_name_array [i].field_name <> name) AND
          (field_name_array [i].field_name_abbrev <> name) DO
      i := i - 1;
    WHILEND;

    IF i = 0 THEN
      osp$set_status_abnormal ('OF', ofe$unknown_field_name, name, status);
    ELSE
      fna_index := i;
      field_id := field_name_array [i].field_id;
    IFEND;

  PROCEND convert_field_name_to_id;
?? TITLE := 'conv_field_name_to_descr_index ', EJECT ??

{ PURPOSE:
{    This procedure searches a display description for a field_id. If the field_id
{    is found, the index to the entry is returned.
{ INPUT:
{    name: ascii value of the field name
{    dd_p: pointer to the display description to be searched
{    field_count: number of field entries in dd_p that are actually in use.
{    start_search_index: index in dd_p of where to start the search
{ OUTPUT:
{    field_index: dd_p index to the field entry specified by <name>.
{    status: ofe$unknown_field_name
{            ofe$field_name_not_in_display


  PROCEDURE conv_field_name_to_descr_index
    (    name: ost$name;
         dd_p: ^oft$display_description;
         field_count: oft$field_count;
         start_search_index: oft$field_index;
     VAR field_index: oft$field_index;
     VAR status: ost$status);

    VAR
      field_id: oft$field_id,
      fna_index: field_name_array_index;

    status.normal := TRUE;

    convert_field_name_to_id (name, field_id, fna_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    field_index := start_search_index;
    WHILE (field_index <= field_count) DO
      IF dd_p^.fields [field_index].field_id = field_id THEN
        RETURN;
      IFEND;
      field_index := field_index + 1;
    WHILEND;

    osp$set_status_abnormal ('OF', ofe$field_name_not_in_display, name, status);

  PROCEND conv_field_name_to_descr_index;
?? TITLE := 'delete_fields ', EJECT ??

{ PURPOSE:
{    This procedure deletes a range of fields from a display description.
{ INPUT:
{    low_field_name, high_field_name: These parameters define the range of fields
{       to be deleted
{ INPUT/OUTPUT:
{    dd_p: pointer to the display description to be updated
{    field_count: number of field entries in dd_p that are actually in use.
{ OUTPUT:
{    start_field_index: display description index to first field deleted.
{

  PROCEDURE delete_fields
    (    low_field_name: ost$name;
         high_field_name: ost$name;
         dd_p: ^oft$display_description;
     VAR field_count: oft$field_count;
     VAR start_field_index: oft$field_index;
     VAR status: ost$status);


    VAR
      delta: integer,
      end_field_index: oft$field_index,
      field_id: oft$field_id,
      field_index: oft$field_index;

    conv_field_name_to_descr_index (low_field_name, dd_p, field_count, 1, start_field_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    conv_field_name_to_descr_index (high_field_name, dd_p, field_count, start_field_index, end_field_index,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    delta := end_field_index - start_field_index + 1;
    FOR field_index := start_field_index TO field_count - delta DO
      dd_p^.fields [field_index] := dd_p^.fields [field_index + delta];
    FOREND;

    field_count := field_count - delta;

  PROCEND delete_fields;
?? TITLE := 'process_field_description', EJECT ??

{ PURPOSE:
{    This procedure processes a field description entry from a command and makes
{    a table entry in the display description table.
{ INPUT:
{    field_values: pointer to the PVT record entry that defines the attributes of
{        the field.
{ OUTPUT:
{    field: field description entry for the display descriptor.
{    status
{
{ NOTES: percent CP usage is forced to be incremental since it has no other
{   meaning.

  PROCEDURE process_field_description
    (    field_values: ^array [1 .. * ] of clt$field_value;
     VAR field: oft$field_description;
     VAR status: ost$status);

    VAR
      field_name: ost$name,
      field_overflow_specified: boolean,
      field_width_specified: boolean,
      fna_index: field_name_array_index,
      i: integer,
      incremental_specified: boolean,
      scale_specified: boolean,
      strlen: 0 .. 132,
      title_p: ^clt$string_value;

    status.normal := TRUE;

    field_width_specified := FALSE;
    field_overflow_specified := FALSE;
    incremental_specified := FALSE;
    scale_specified := FALSE;
    title_p := NIL;

    field.incremental := FALSE;
    field.field_overflow_action := ofc$foa_scale;
    field.field_selection := ofc$fs_unconditional;
    field.non_selection_action := ofc$nsa_blank;

    FOR i := LOWERBOUND (field_values^) TO UPPERBOUND (field_values^) DO
      IF field_values^ [i].value <> NIL THEN
        IF field_values^ [i].name = 'FIELD_NAME' THEN
          field_name := field_values^ [i].value^.name_value;
        ELSEIF field_values^ [i].name = 'FIELD_WIDTH' THEN
          field_width_specified := TRUE;
          field.width := field_values^ [i].value^.integer_value.value;
        ELSEIF field_values^ [i].name = 'SCALE' THEN
          scale_specified := TRUE;
          field.scale := field_values^ [i].value^.integer_value.value;
        ELSEIF field_values^ [i].name = 'FIELD_TITLE' THEN
          title_p := field_values^ [i].value^.string_value;
        ELSEIF field_values^ [i].name = 'NUMERIC_DISPLAY_MODE' THEN
          incremental_specified := TRUE;
          IF field_values^ [i].value^.name_value = 'INCREMENTAL' THEN
            field.incremental := TRUE;
          IFEND;
        ELSEIF field_values^ [i].name = 'FIELD_SELECTION' THEN
          IF field_values^ [i].value^.name_value = 'UNCONDITIONAL' THEN
            field.field_selection := ofc$fs_unconditional;
          ELSEIF field_values^ [i].value^.name_value = 'ACTIVE' THEN
            field.field_selection := ofc$fs_active;
          ELSE
            field.field_selection := ofc$fs_swapped;
          IFEND;
        ELSEIF field_values^ [i].name = 'FIELD_OVERFLOW_ACTION' THEN
          IF field_values^ [i].value^.name_value = 'MAXIMUM' THEN
            field.field_overflow_action := ofc$foa_maximum;
          ELSEIF field_values^ [i].value^.name_value = 'ASTERISK' THEN
            field.field_overflow_action := ofc$foa_asterisk;
          IFEND;
        ELSEIF field_values^ [i].name = 'NON_SELECTION_ACTION' THEN
          IF field_values^ [i].value^.name_value = 'SKIP' THEN
            field.non_selection_action := ofc$nsa_skip;
          ELSE
            field.non_selection_action := ofc$nsa_blank;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

    convert_field_name_to_id (field_name, field.field_id, fna_index, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF field.field_id = ofc$fi_percent_cp_usage THEN
      field.incremental := TRUE;
    IFEND;

    IF (field_name_array [fna_index].default_scale = 0) AND
          (scale_specified OR incremental_specified OR field_overflow_specified) THEN
      osp$set_status_abnormal ('OF', ofe$invalid_numeric_attribute, field_name, status);
    IFEND;

    IF NOT field_width_specified THEN
      field.width := field_name_array [fna_index].default_width;
    IFEND;
    IF NOT scale_specified THEN
      field.scale := field_name_array [fna_index].default_scale;
    IFEND;

    IF title_p = NIL THEN
      title_p := ^field_name_array [fna_index].field_name_abbrev;
    IFEND;
    IF field.field_id IN left_justified_fields THEN
      field.field_title := title_p^;
    ELSE
      field.field_title := '';
      strlen := STRLENGTH (title_p^);
      WHILE (strlen > 1) AND (title_p^ (strlen) = ' ') DO
        strlen := strlen - 1;
      WHILEND;
      field.field_title (STRLENGTH (field.field_title) - strlen + 1, * ) := title_p^;
    IFEND;

  PROCEND process_field_description;


?? TITLE := 'process_field_descriptions', EJECT ??

{ PURPOSE:
{    This procedure processes all the PVT entries for display field definitions.
{    and builds an array of field descriptors in the display descriptor.
{ INPUT:
{    first_list_data_value: first data value from the PVT entry for the field
{        descriptions
{    dd_p: pointer to display description
{    starting_field_index: index to first entry in display description for
{        new field descriptions
{ OUTPUT:
{    count: number of field descriptions found

  PROCEDURE process_field_descriptions
    (    first_list_data_value: ^clt$data_value;
         dd_p: ^oft$display_description;
         starting_field_index: oft$field_index;
     VAR count: oft$field_count;
     VAR status: ost$status);

    VAR
      field_index: oft$field_index,
      i: integer,
      list_data_value: ^clt$data_value;

    status.normal := TRUE;
    field_index := starting_field_index;
    list_data_value := first_list_data_value;

    WHILE list_data_value <> NIL DO
      process_field_description (list_data_value^.element_value^.field_values, dd_p^.fields [field_index],
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      field_index := field_index + 1;
      list_data_value := list_data_value^.link;
    WHILEND;

    count := field_index - starting_field_index;

  PROCEND process_field_descriptions;
?? TITLE := 'process_header_parameters ', EJECT ??

{ PURPOSE:
{    This procedure processes the command parameters EXCEPT for field descriptions.
{    and builds the display description header record. This procedure is used by
{    both the CREATE and CHANGE commands. The CREATE command will use  default values
{    values of parameters; CHANGE uses only parameters explicitly specified
{ INPUT:
{    pvt - the PVT from the command
{    pvt_numbers - an array that maps logical parameters to PVT parameter numbers
{    accept_DEFAULTS - boolean to specify whether to use DEFAULT values from the PVT.
{ OUTPUT:
{    dd_p: pointer to the display description. This procedure fills in the
{           header parameter values
{    title_specified: boolean that indicates if the TITLE parameter was explicitly specified
{


  PROCEDURE process_header_parameters
    (VAR pvt {input} : array [1 .. * ] of clt$parameter_value;
         pvt_numbers: pvt_numbers_list;
         accept_defaults: boolean;
         dd_p: ^oft$display_description;
     VAR title_specified: boolean);

    IF accept_defaults OR pvt [pvt_numbers [pn$display_system_line]].specified THEN
      dd_p^.header.display_system_line := pvt [pvt_numbers [pn$display_system_line]].value^.boolean_value.
            value;
    IFEND;

    IF accept_defaults OR pvt [pvt_numbers [pn$display_blank_lines]].specified THEN
      dd_p^.header.display_blank_lines := pvt [pvt_numbers [pn$display_blank_lines]].value^.boolean_value.
            value;
    IFEND;

    IF pvt [pvt_numbers [pn$alias]].specified THEN
      dd_p^.header.display_name_abbrev := pvt [pvt_numbers [pn$alias]].value^.name_value;
    IFEND;

    IF accept_defaults OR pvt [pvt_numbers [pn$jobs_per_line]].specified THEN
      dd_p^.header.jobs_per_line := pvt [pvt_numbers [pn$jobs_per_line]].value^.integer_value.value;
    IFEND;

    IF accept_defaults OR pvt [pvt_numbers [pn$job_selection]].specified THEN
      IF pvt [pvt_numbers [pn$job_selection]].value^.keyword_value = 'ACTIVE' THEN
        dd_p^.header.job_selection := ofc$js_active;
      ELSE
        dd_p^.header.job_selection := ofc$js_initiated;
      IFEND;
    IFEND;

    title_specified := pvt [pvt_numbers [pn$title]].value <> NIL;
    IF title_specified THEN
      dd_p^.header.title := pvt [pvt_numbers [pn$title]].value^.string_value^;
    IFEND;


  PROCEND process_header_parameters;
?? TITLE := 'verify_display_description', EJECT ??

{
{ PURPOSE:
{    This procedure is called after a display_description is completed. This
{    procedure checks whether the description is valid. Items verified include things
{    such as display_too_wide, too_many_incremental_fields, etc.
{    This procedure also generates the display title if it was not explicitly specified.
{ INPUT:
{    dd_p - pointer to display description.
{    field_count - number of fields actually specified for the display
{    title_specified - boolean that indicates if the display TITLE was explicitly specified.
{ OUTPUT:
{    The following field are updated in the display decription:
{        title, column_width
{    status

  PROCEDURE verify_display_description
    (    dd_p: ^oft$display_description;
         field_count: oft$field_count;
         title_specified: boolean;
     VAR status: ost$status);

    VAR
      field_title: ost$name,
      i: oft$field_index,
      incremental_field_count: integer,
      title: string (ofc$max_display_width),
      title_index: integer,
      width: 1 .. ofc$max_display_width;

    status.normal := TRUE;

    title_index := 2;
    title := ' ';
    incremental_field_count := 0;
    FOR i := 1 TO field_count DO
      width := dd_p^.fields [i].width;
      IF (title_index + width) > (ofc$max_display_width + 2) THEN
        osp$set_status_condition (ofe$line_too_long, status);
        RETURN;
      IFEND;
      IF dd_p^.fields [i].incremental THEN
        incremental_field_count := incremental_field_count + 1;
      IFEND;
      IF (dd_p^.fields [i].field_selection <> ofc$fs_swapped) OR
            (dd_p^.fields [i].non_selection_action = ofc$nsa_blank) THEN
        IF dd_p^.fields [i].field_id = ofc$fi_fill THEN
          field_title := '';
        ELSE
          field_title := dd_p^.fields [i].field_title;
        IFEND;
        IF dd_p^.fields [i].field_id IN left_justified_fields THEN
          title (title_index, width) := field_title;
        ELSE
          title (title_index, width) := field_title (STRLENGTH (field_title) - width + 1, * );
        IFEND;
        title_index := title_index + width;
      IFEND;
    FOREND;

    IF incremental_field_count > ofc$max_incremental_fields THEN
      osp$set_status_condition (ofe$too_many_incremental_fields, status);
      RETURN;
    IFEND;

    IF title_specified THEN
      title(2,*) := dd_p^.header.title;
    IFEND;

    title_index := title_index - 1;
    IF dd_p^.header.jobs_per_line > 1 THEN
      IF (title_index * dd_p^.header.jobs_per_line - 1) > ofc$max_display_width THEN
        osp$set_status_condition (ofe$line_too_long, status);
        RETURN;
      IFEND;
      FOR i := 1 TO dd_p^.header.jobs_per_line - 1 DO
        title (i * title_index + 1, title_index) := title (1, title_index);
      FOREND;
    IFEND;

    dd_p^.header.title := title;
    dd_p^.header.column_width := title_index;

  PROCEND verify_display_description;
?? TITLE := 'ofp$_change_init_job_display ', EJECT ??

{ PURPOSE:
{   Processes the CHANGE_INITIATED_JOB_DISPLAY command .
{

  PROCEDURE ofp$_change_init_job_display
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*copyc ofd$pdt_change_init_job_display

    VAR
      count: oft$field_count,
      dd_p: ^oft$display_description,
      delta: integer,
      end_field_index: oft$field_index,
      field_id: oft$field_id,
      field_index: oft$field_index,
      field_count: oft$field_count,
      insertion_index: oft$field_index,
      list_data_value: ^clt$data_value,
      low_value: ost$name,
      high_value: ost$name,
      pvt_numbers: [STATIC, READ, oss$job_paged_literal] pvt_numbers_list :=
            [p$display_system_line, p$display_blank_lines, p$jobs_per_line, p$job_selection, p$title,
            p$alias],
      start_field_index: oft$field_index,
      title_specified: boolean;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    PUSH dd_p: [1 .. ofc$max_display_fields];

    dd_p^.header.display_name := pvt [p$name].value^.name_value;

    field_count := 0;
    ofp$access_display_description (ofc$adrc_get, dd_p, field_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    IF pvt [p$delete_fields].specified THEN
      delete_fields (pvt [p$delete_fields].value^.low_value^.name_value,
            pvt [p$delete_fields].value^.high_value^.name_value, dd_p, field_count, insertion_index, status);
    IFEND;

    IF pvt [p$replace_fields].specified THEN
      delete_fields (pvt [p$replace_fields].value^.low_value^.name_value,
            pvt [p$replace_fields].value^.high_value^.name_value, dd_p, field_count, insertion_index, status);
    IFEND;

    count := $INTEGER (pvt [p$replace_fields].specified) + $INTEGER (pvt [p$insert_before].specified) +
          $INTEGER (pvt [p$insert_after].specified);
    IF (count = 0) THEN
      IF pvt [p$fields].specified THEN
        osp$set_status_condition (ofe$no_field_placement, status);
        RETURN;
      IFEND;
    ELSEIF count > 1 THEN
      osp$set_status_condition (ofe$multiple_field_placement, status);
      RETURN;
    ELSEIF NOT pvt [p$fields].specified THEN
      osp$set_status_condition (ofe$field_must_be_specified, status);
      RETURN;
    IFEND;

    IF pvt [p$insert_after].specified THEN
      conv_field_name_to_descr_index (pvt [p$insert_after].value^.name_value, dd_p, field_count, 1,
            insertion_index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      insertion_index := insertion_index + 1;
    ELSEIF pvt [p$insert_before].specified THEN
      conv_field_name_to_descr_index (pvt [p$insert_before].value^.name_value, dd_p, field_count, 1,
            insertion_index, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    count := 0;
    list_data_value := pvt [p$fields].value;
    WHILE list_data_value <> NIL DO
      count := count + 1;
      list_data_value := list_data_value^.link;
    WHILEND;


    IF count > 0 THEN
      FOR field_index := field_count DOWNTO insertion_index DO
        dd_p^.fields [field_index + count] := dd_p^.fields [field_index];
      FOREND;
      field_count := field_count + count;

      process_field_descriptions (pvt [p$fields].value, dd_p, insertion_index, count, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    process_header_parameters (pvt, pvt_numbers, FALSE {accept defaults} , dd_p, title_specified);

    verify_display_description (dd_p, field_count, title_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF field_count = 0 THEN
      osp$set_status_condition (ofe$display_must_have_fields, status);
    ELSE
      ofp$access_display_description (ofc$adrc_change, dd_p, field_count, status);
    IFEND;

  PROCEND ofp$_change_init_job_display;
?? TITLE := 'ofp$_create_init_job_display ', EJECT ??

{ PURPOSE:
{   Processes the CREATE_INITIATED_JOB_DISPLAY command.
{

  PROCEDURE ofp$_create_init_job_display
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*copyc ofd$pdt_create_init_job_display

    VAR
      dd_p: ^oft$display_description,
      field_count: oft$field_count,
      pvt_numbers: [STATIC, READ, oss$job_paged_literal] pvt_numbers_list :=
            [p$display_system_line, p$display_blank_lines, p$jobs_per_line, p$job_selection, p$title,
            p$alias],
      title_specified: boolean;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    IF pvt [p$fields].specified AND pvt [p$same_as].specified THEN
      osp$set_status_condition (ofe$same_as_and_field_error, status);
      RETURN;
    IFEND;

    PUSH dd_p: [1 .. ofc$max_display_fields];

    IF pvt [p$fields].specified THEN
      process_field_descriptions (pvt [p$fields].value, dd_p, 1, field_count, status);
    ELSEIF pvt [p$same_as].specified THEN
      dd_p^.header.display_name := pvt [p$same_as].value^.name_value;
      field_count := 0;
      ofp$access_display_description (ofc$adrc_get, dd_p, field_count, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      osp$set_status_condition (ofe$display_must_have_fields, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dd_p^.header.display_name := pvt [p$name].value^.name_value;
    dd_p^.header.display_name_abbrev := dd_p^.header.display_name;

    process_header_parameters (pvt, pvt_numbers, NOT pvt [p$same_as].specified, dd_p, title_specified);

    verify_display_description (dd_p, field_count, title_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ofp$access_display_description (ofc$adrc_create, dd_p, field_count, status);

  PROCEND ofp$_create_init_job_display;
?? TITLE := 'ofp$_delete_init_job_display ', EJECT ??

{ PURPOSE:
{   Processes the DELETE_INITIATED_JOB_DISPLAY command.
{

  PROCEDURE ofp$_delete_init_job_display
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*copyc ofd$pdt_delete_init_job_display

    VAR
      dd_p: ^oft$display_description,
      field_count: oft$field_count;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    PUSH dd_p: [1 .. 1];

    dd_p^.header.display_name := pvt [p$name].value^.name_value;

    ofp$access_display_description (ofc$adrc_delete, dd_p, field_count, status);

  PROCEND ofp$_delete_init_job_display;
?? NEWTITLE := 'ofp$_display_site_ved_names ', EJECT ??

{ PURPOSE:
{   Processes the DISPLAY_SITE_VED_NAMES command.
{

  PROCEDURE [XDCL, #GATE] ofp$_display_site_ved_names
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (osm$dissvn) display_site_ved_names, dissvn (
{     output, o: file = $output
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [95, 5, 3, 8, 36, 2, 14],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$DISSVN'], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

*copyc clv$display_variables
*copyc clv$nil_display_control

    VAR
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      local_status: ost$status;

?? OLDTITLE ??
?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;

*copyc clp$new_page_procedure

?? OLDTITLE ??
?? NEWTITLE := '    put_subtitle', EJECT ??

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

{ The display_site_ved_names command has no subtitles, this
{ is merely a dummy routine used to keep the module consistent
{ with those that do produce subtitles.

    PROCEND put_subtitle;

?? OLDTITLE ??
    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    /display_site_ved_names/
    BEGIN
      display_control := clv$nil_display_control;
      #SPOIL (display_control);
      osp$establish_block_exit_hndlr (^abort_handler);
      default_ring_attributes.r1 := #RING (^default_ring_attributes);
      default_ring_attributes.r2 := #RING (^default_ring_attributes);
      default_ring_attributes.r3 := #RING (^default_ring_attributes);
      clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
            default_ring_attributes, display_control, status);
      IF NOT status.normal THEN
        EXIT /display_site_ved_names/;
      IFEND;
      clv$titles_built := FALSE;
      clv$command_name := 'DISPLAY_SITE_VED_NAMES';

      IF display_control.page_width < clc$narrow_page_width THEN
        clv$page_width := clc$narrow_page_width;
      ELSEIF display_control.page_width > clc$wide_page_width THEN
        clv$page_width := clc$wide_page_width;
      ELSE
        clv$page_width := display_control.page_width;
      IFEND;

      ofp$display_site_ved_names (display_control, status);

    END /display_site_ved_names/;

    clp$close_display (display_control, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;
    osp$disestablish_cond_handler;
  PROCEND ofp$_display_site_ved_names;

?? TITLE := 'ofp$_quit ', EJECT ??

{ PURPOSE:
{   Processes the QUIT command which exits the utility.
{   No special processing is done by this procedure. It simply exits the VEDU utility.
{

  PROCEDURE ofp$_quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

*copyc ofd$pdt_quit

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$end_include (utility_name, status);

  PROCEND ofp$_quit;
?? TITLE := '[XDCL] ofp$ved_utility', EJECT ??

{ PURPOSE:
{   Processes the VEDU command which starts up a utility to define/modify
{   VED display definitions used by the VED command.
{
{ NOTE:
{    o The first time this utility is called, it will create the default (AJ, IJ, IJD)
{      displays.
{

  PROCEDURE [XDCL, #GATE] ofp$_ved_utility
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE virtual_enviro_display_utility, vedu (
{    status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 10, 16, 21, 35, 0, 16], clc$command, 1, 1, 0, 0, 0, 0, 1, 'VEDU'],
            [['STATUS                         ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      dummy_status: ost$status,
      pvt: array [1 .. 1] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    IF NOT ofv$displays_initialized THEN
      create_default_displays (status);
    IFEND;

    IF status.normal THEN
      clp$include_file (command_file, '', utility_name, status);
    IFEND;

    clp$end_utility (utility_name, dummy_status);

  PROCEND ofp$_ved_utility;
?? TITLE := 'create_default_displays', EJECT ??
{
{  PURPOSE:
{    This procedure is called from the VEDU command processors to create
{    the default displays. This procedure is called only once - the first time
{    a VED or VEDU command is executed.
{
{  NOTE:
{    o Additional default displays can be created by adding a trivial amount of code to this procedure.
{

  PROCEDURE create_default_displays
    (VAR status: ost$status);

    VAR
      aj: [STATIC, READ, oss$job_paged_literal] string (246) :=
            'creijd active_jobs a=aj js=a dsl=on dbl=no' CAT
            ' f=((ajlo,, '' '') (f,,''.'') (sjnl,,'' '') (ujn,8, '' '') (ctm,6,''CPM'')' CAT
            ' (ctj 8 ''CPJ'') (pr,,''PRC'') (pa,,''PAS'') (pi 7 ''PIN'') (ss ,, ''  S'')' CAT
            ' (wss,,''WS'') (tf 1 '' '') (rtc 3 ''RT'') (pcu,,''PC'') f (dp))',

      ij: [STATIC, READ, oss$job_paged_literal] string (160) :=
            'creijd initiated_jobs a=ij js=i dsl=on jpl=2' CAT
            ' f=((sjn,, ''        SSN'') (ujn,8,''   UJN'') (jc 4 '' C'')' CAT
            '  (jes ,, ''  S'') (jp 4 ''PR'' 100) (f 2))',

      ijd: [STATIC, READ, oss$job_paged_literal] string (364) :=
            'creijd initiated_jobs_detailed a=ijd js=i dsl=on' CAT
            ' f=((ijlo 5 '' '') (f 1 ''.'') (ujn, 8,'' '' ) (ctm 7 ''CPM'') (ctj 8 ''CPJ'')' CAT
            '  (js 5 ''  S/R'' ,,,,a s) (sr 5 '' '',,,, s s) (wss,, ''WS'') (tf 1 '' '')' CAT
            '  (rtc 3 ''RT'',,,,a s) (sss 10 ''SERVICE'',,,, a s)' CAT
            '  (siwt 7 '' '',,,,s s) (sss 6 '' '',,,,s s)' CAT
            '  (jp 10 ''PRIORITY'') f (dp 4) (ses 5 ''  SES'' ,,,,s b))';

    clp$include_line (aj, FALSE, osc$null_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_line (ij, FALSE, osc$null_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_line (ijd, FALSE, osc$null_name, status);

  PROCEND create_default_displays;
?? TITLE := '[XDCL] ofp$create_default_displays', EJECT ??
{
{  PURPOSE:
{    This procedure is called from the VED command processor. If the default displays have not
{    already been created, this procedure invokes the VEDU command to create the default
{    displays. (Entering and exiting VEDU will create the default displays.
{


  PROCEDURE [XDCL] ofp$create_default_displays
    (VAR status: ost$status);

    IF NOT ofv$displays_initialized THEN
      clp$include_line ('VEDU ;QUIT', FALSE, osc$null_name, status);
    IFEND;

  PROCEND ofp$create_default_displays;

MODEND ofm$designer_screens;
*DECK DECK=OFM$DESIGNER_SCREENS_R3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'ofm$designer_screens_r3 - NOS/VE console display procedures.' ??
MODULE ofm$designer_screens_r3;

{   PURPOSE:
{     This module contains procedures that drive the operator displays.

{ Set the following variable TRUE to allow a version of this module to be compiled that
{ can be used for timimg runs to measure performance.
{ Note: you also have to delete the NOCOMPILE statement at the end of the module.
{     . compile with debug code
{     . install as job template
{     . Login to template
{     . Enter the following commands:
{         SOU
{         VED AJ
{         EXET SP=VEDTEST
{ The output shows the times to paint one screen full of IJ entries. The test code can be modified
{ if other screens need to be tested.

  ?VAR
    debug: boolean := FALSE?;

?? PUSH (LISTEXT := ON) ??
*copyc i#program_error
*copyc dpc$number_of_window_lines
*copyc dpt$window_id
*copyc jmc$null_ajl_ordinal
*copyc ofd$type_definition
*copyc ofe$ecc_designer_screens
*copyc oft$designer_screens_types
*copyc oft$display_procedure
*copyc oft$operator_classes
*copyc oft$operator_message_descriptor
*copyc osc$multiprocessor_constants
*copyc oss$task_shared
*copyc oss$job_paged_literal
*copyc ost$cpu_idle_statistics
*copyc pmt$condition

?? POP ??
*copyc clp$close_display
*copyc clp$put_display
*copyc dpp$get_starting_line
*copyc dpp$put_next_line
*copyc i#move
*copyc jmp$idetermine_job_class_abbrev
*copyc jmp$idetermine_serv_class_abbre
*copyc jmp$get_ijle_p
*copyc ofp$build_system_line
*copyc ofp$open_display
*copyc ofp$search_for_display_name
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$verify_system_privilege
*copyc osp$clear_job_signature_lock
*copyc osp$establish_condition_handler
*copyc osp$initialize_signature_lock
*copyc pmp$continue_to_cause

*copyc pmp$binary_to_ascii_fit
*copyc pmp$zero_out_table

{  Global variables referenced by this module.

*copyc jmv$ajl_p
*copyc jmv$ijl_p
*copyc jmv$kjlx_p
*copyc jmv$max_ajl_ordinal_in_use
*copyc jsv$swap_status_id_array
*copyc osv$task_shared_heap
?? NEWTITLE := 'STATIC data defined by this module', EJECT ??

  VAR
    ofv$displays_initialized: [XDCL, #GATE, oss$task_shared] boolean := FALSE,

    display_lock: [oss$task_shared] ost$signature_lock,

    display_descriptions_p: [oss$task_shared] oft$display_descriptions_p := NIL,

    job_mode_conversion: [STATIC, oss$job_paged_literal, READ] array [jmt$job_mode] of string (2) := ['B ',
          'I ', 'ID', 'IL', 'IS'],

    max_field_values: [STATIC, oss$job_paged_literal, READ] array [0 .. 20] of
          integer := [0, 0, 9, 99, 999, 9999, 99999, 999999, 9999999, 99999999, 999999999, 9999999999,
          99999999999, 999999999999, 9999999999999, 99999999999999, 999999999999999, 9999999999999999,
          99999999999999999, 999999999999999999, 9223372036854775807],

    entry_status_conversion: [STATIC, oss$job_paged_literal, READ] array [jmt$ijl_entry_status] of
          string (2) := ['  ', 'T ', 'NS', 'M ', 'SI', 'S ', 'OF', 'SF', 'JD', 'RT', 'SC'],

    swap_reasons_conversion: [STATIC, oss$job_paged_literal, READ] array [jmt$swapout_reasons] of
          string (2) := [' ', 'RO', 'RT', 'RP', 'RI', 'RW', 'RM', 'RD', '*R'];


?? OLDTITLE, NEWTITLE := 'BUILD_LINE', EJECT ??

  PROCEDURE build_line
    (    ijle_p: ^jmt$initiated_job_list_entry;
         ijl_number: integer;
         dd_p: oft$max_display_descriptions_p;
         ince_p: ^oft$save_incremental_data_entry;
         s: ^string (132));

    VAR
      ch: char,
      ch2: string (2),
      clock: ost$free_running_clock,
      cp_time: integer,
      dde_p: ^oft$field_description,
      field: oft$packed_field_attributes,
      field_index: 1 .. ofc$max_display_width,
      incremental_ok: boolean,
      info: record
        case boolean of
        = TRUE =
          p: ^oft$display_message_info,
        = FALSE =
          pva: ost$pva,
        casend,
      recend,
      int_index: 0 .. ofc$max_incremental_fields + 1,
      message_column,
      n: integer,
      pva_p: ^ost$pva,
      string_index: 1 .. ofc$max_display_width + 1,
      string_indexr: 0 .. ofc$max_display_width + 1,
      swap_status: oft$field_selection,
      width: 1 .. ofc$max_display_width;

    string_index := 1;
    int_index := 0;
    incremental_ok := ince_p^.ssn_id = ijle_p^.system_supplied_name (12, 8);
    ince_p^.ssn_id := ijle_p^.system_supplied_name (12, 8);
    IF ijle_p^.swap_status <= jmc$iss_swapped_no_io THEN
      swap_status := ofc$fs_active;
    ELSE
      swap_status := ofc$fs_swapped;
    IFEND;
    clock := #FREE_RUNNING_CLOCK (0);

  /build_line_loop/
    FOR field_index := 1 TO dd_p^.header.field_count DO
      dde_p := ^dd_p^.fields [field_index];
      field := dde_p^.pack;
      width := field.width;

      IF (field.field_selection <> ofc$fs_unconditional) AND (field.field_selection <> swap_status) THEN
        IF field.non_selection_action = ofc$nsa_blank THEN
          string_index := string_index + width;
        IFEND;
        CYCLE /build_line_loop/;
      IFEND;


      string_indexr := string_index + width - 1;
      CASE field.field_id OF
      = ofc$fi_active_io_pages =
        n := ijle_p^.active_io_page_count;
      = ofc$fi_active_io_requests =
        n := ijle_p^.active_io_requests;
      = ofc$fi_ajl_ordinal =
        n := ijle_p^.ajl_ordinal;
        IF (n = jmc$null_ajl_ordinal) OR (ijle_p <> jmv$ajl_p^ [n].ijle_p) THEN
          field.scale := 0;
        IFEND;
      = ofc$fi_cp_time_increment =

{       n := ijle_p^.statistics.cp_time.time_spent_in_mtr_mode +
{             ijle_p^.statistics.cp_time.time_spent_in_job_mode -
{             ijle_p^.cp_time_last_dc_reset;

      = ofc$fi_cp_time_job =
        n := ijle_p^.statistics.cp_time.time_spent_in_job_mode;
      = ofc$fi_cp_time_monitor =
        n := ijle_p^.statistics.cp_time.time_spent_in_mtr_mode;
      = ofc$fi_cp_time_total =
        n := ijle_p^.statistics.cp_time.time_spent_in_mtr_mode +
              ijle_p^.statistics.cp_time.time_spent_in_job_mode;
      = ofc$fi_dispatching_priority, ofc$fi_dispatching_priority_act =
        IF field.field_id = ofc$fi_dispatching_priority THEN
          n := ijle_p^.dispatching_control.dispatching_priority;
        ELSE
          n := ijle_p^.scheduling_dispatching_priority;
        IFEND;
        n := n - 1;
        s^ (string_index) := 'P';
        IF n >= 10 THEN
          s^ (string_index + 2) := $CHAR ((n MOD 10) + $INTEGER ('0'));
          n := n DIV 10;
        IFEND;
        s^ (string_index + 1) := $CHAR (n + $INTEGER ('0'));
      = ofc$fi_display_message =
        IF ijle_p^.display_message.display_message.size > 0 THEN
          n := 1;
          WHILE (ijle_p^.display_message.display_message.text (n) = ' ') AND
                (n < ijle_p^.display_message.display_message.size) DO
            n := n + 1;
          WHILEND;
          s^ (string_index, width) := ijle_p^.display_message.display_message.
                text (n, ijle_p^.display_message.display_message.size - n + 1);
          FOR message_column := string_index TO (string_index + width) DO
            CASE s^ (message_column) OF
            = $CHAR (0) .. $CHAR (31), $CHAR (127) =
              s^ (message_column) := '?';
            ELSE
              ;
            CASEND;
          FOREND;
        IFEND;
      = ofc$fi_fill =
        s^ (string_index, width) := dde_p^.field_title (1, width);
      = ofc$fi_guaranteed_service_rem =
        n := ijle_p^.job_scheduler_data.guaranteed_service_remaining;
        IF field.incremental THEN
          n := -n;
        IFEND;
      = ofc$fi_hung_task_in_job_flag =
        IF ijle_p^.hung_task_in_job THEN
          s^ (string_indexr) := '*';
        IFEND;
      = ofc$fi_ijl_ordinal =
        n := ijl_number;
      = ofc$fi_job_class =
        jmp$idetermine_job_class_abbrev (ijle_p^.job_scheduler_data.job_class, s^ (string_indexr - 1, 2));
      = ofc$fi_job_entry_status =
        IF ijle_p^.entry_status < jmc$ies_swapin_in_progress THEN
          ch := 'M';
        ELSEIF ijle_p^.entry_status = jmc$ies_swapin_in_progress THEN
          ch := 'I';
        ELSEIF ijle_p^.entry_status = jmc$ies_operator_force_out THEN
          ch := 'F';
        ELSE { entry_status = swapped }
          IF ijle_p^.job_scheduler_data.swapout_reason = jmc$sr_long_wait THEN
            ch := ' ';
          ELSEIF ijle_p^.job_scheduler_data.swapout_reason = jmc$sr_thrashing THEN
            ch := 'T';
          ELSEIF ijle_p^.job_scheduler_data.swapout_reason = jmc$sr_lower_priority THEN
            ch := 'P';
          ELSEIF ijle_p^.job_scheduler_data.swapout_reason = jmc$sr_idling_system_swapout THEN
            ch := 'L';
          ELSEIF ijle_p^.job_scheduler_data.swapout_reason = jmc$sr_idle_dispatching THEN
            ch := 'D';
          ELSE
            ch := 'U';
          IFEND;
        IFEND;
        s^ (string_indexr) := ch;
      = ofc$fi_job_status =
        IF ijle_p^.hung_task_in_job THEN
          ch2 := '*H';
        ELSEIF ijle_p^.job_damaged_during_recovery THEN
          ch2 := '*R';
        ELSEIF (ijle_p^.swap_status = jmc$iss_swapout_complete) OR
              (ijle_p^.swap_status = jmc$iss_swapped_io_complete) OR
              (ijle_p^.swap_status = jmc$iss_swapped_no_io) THEN
          ch2 := swap_reasons_conversion [ijle_p^.job_scheduler_data.swapout_reason];
        ELSE
          ch2 := jsv$swap_status_id_array [ijle_p^.swap_status];
        IFEND;
        s^ (string_indexr - 1, 2) := ch2;
      = ofc$fi_job_mode =
        s^ (string_indexr - 1, 2) := job_mode_conversion [ijle_p^.job_mode];
      = ofc$fi_job_priority =
        IF (ijle_p^.swap_status <= jmc$iss_swapped_no_io) OR
              (ijle_p^.entry_status = jmc$ies_swapin_candidate) THEN
          n := ijle_p^.job_scheduler_data.priority;
        ELSE
          field.scale := 0;
        IFEND;
      = ofc$fi_job_swap_count =
        n := ijle_p^.job_scheduler_data.job_swap_counts.long_wait +
              ijle_p^.job_scheduler_data.job_swap_counts.job_mode;
      = ofc$fi_last_think_time =
        n := ijle_p^.last_think_time;
        IF n = 0 THEN
          field.scale := 0;
        IFEND;
      = ofc$fi_memory_pages =
        n := ijle_p^.job_page_queue_list [mmc$pq_job_fixed].
              count + ijle_p^.job_page_queue_list [mmc$pq_job_io_error].
              count + ijle_p^.job_page_queue_list [mmc$pq_job_working_set].count;
      = ofc$fi_page_fault_count =
        n := ijle_p^.statistics.paging_statistics.page_fault_count;
      = ofc$fi_percent_cp_usage =
        cp_time := ijle_p^.statistics.cp_time.time_spent_in_job_mode +
              ijle_p^.statistics.cp_time.time_spent_in_mtr_mode;
        n := ((cp_time - ince_p^.int [int_index]) * 100) DIV (clock - ince_p^.last_clock);
        ince_p^.int [int_index] := cp_time;
        int_index := int_index + 1;
        field.incremental := FALSE;
        IF NOT incremental_ok THEN
          field.scale := 0;
        IFEND;
      = ofc$fi_permanent_file_space =
        n := ijle_p^.statistics.perm_file_space;
      = ofc$fi_ps_pages_assigned =
        n := ijle_p^.statistics.paging_statistics.new_pages_assigned;
      = ofc$fi_ps_pages_from_server =
        n := ijle_p^.statistics.paging_statistics.pages_from_server;
      = ofc$fi_ps_pages_reclaimed =
        n := ijle_p^.statistics.paging_statistics.pages_reclaimed_from_queue;
      = ofc$fi_ps_page_in =
        n := ijle_p^.statistics.paging_statistics.page_in_count;
      = ofc$fi_ready_task_count =
        IF ijle_p^.statistics.tasks_not_in_long_wait = 0 THEN
          field.scale := 0;
        ELSE
          n := ijle_p^.statistics.ready_task_count;
        IFEND;
      = ofc$fi_service_accumulator =
        n := ijle_p^.job_scheduler_data.service_accumulator;
      = ofc$fi_service_class =
        jmp$idetermine_serv_class_abbre (ijle_p^.job_scheduler_data.service_class, s^ (string_indexr - 1, 2));
      = ofc$fi_service_since_swap =
        n := ijle_p^.job_scheduler_data.service_accumulator_since_swap;
      = ofc$fi_ssn_full =
        s^ (string_index, jmc$system_supplied_name_size) := ijle_p^.system_supplied_name;
      = ofc$fi_ssn_long =
        s^ (string_index) := '$';
        s^ (string_index + 1, jmc$long_ssn_size - 1) := ijle_p^.system_supplied_name (12, 8);
      = ofc$fi_ssn_short =
        s^ (string_index) := '$';
        s^ (string_index + 1, jmc$short_ssn_size - 1) := ijle_p^.system_supplied_name (16, 4);
      = ofc$fi_swap_entry_status =
        IF ijle_p^.hung_task_in_job THEN
          ch2 := '*H';
        ELSEIF ijle_p^.job_damaged_during_recovery THEN
          ch2 := '*R';
        ELSE
          ch2 := entry_status_conversion [ijle_p^.entry_status];
        IFEND;
        s^ (string_indexr - 1, 2) := ch2;
      = ofc$fi_swap_in_wait_time =
        IF ijle_p^.entry_status = jmc$ies_swapin_candidate THEN
          n := #FREE_RUNNING_CLOCK (0) - ijle_p^.job_scheduler_data.swapin_q_priority_timestamp;
        ELSE
          field.scale := 0;
        IFEND;
      = ofc$fi_swap_reason =
        s^ (string_indexr - 1, 2) := swap_reasons_conversion [ijle_p^.job_scheduler_data.swapout_reason];
      = ofc$fi_swap_status =
        IF ijle_p^.hung_task_in_job THEN
          ch2 := '*H';
        ELSEIF ijle_p^.job_damaged_during_recovery THEN
          ch2 := '*R';
        ELSE
          ch2 := jsv$swap_status_id_array [ijle_p^.swap_status];
        IFEND;
        s^ (string_indexr - 1, 2) := ch2;
      = ofc$fi_temporary_file_space =
        n := ijle_p^.statistics.temp_file_space;
      = ofc$fi_terminal_name =
        s^ (string_index, width) := jmv$kjlx_p^ [ijle_p^.kjl_ordinal].terminal_name;
      = ofc$fi_think_time =
        IF ijle_p^.job_scheduler_data.swapout_reason = jmc$sr_long_wait THEN
          n := clock - (ijle_p^.estimated_ready_time - ijle_p^.last_think_time);
        ELSE
          field.scale := 0;
        IFEND;
      = ofc$fi_thrashing_flag =
        IF ijle_p^.maxws_aio_slowdown_display > 0 THEN
          s^ (string_indexr) := '*';
        IFEND;
      = ofc$fi_time_in_swap_state =
        n := clock - ijle_p^.swap_data.timestamp;
      = ofc$fi_user_job_name =
        s^ (string_index, width) := ijle_p^.job_name;
      = ofc$fi_working_set_size =
        IF swap_status = ofc$fs_active THEN
          n := ijle_p^.job_page_queue_list [mmc$pq_job_working_set].count;
        ELSE
          n := ijle_p^.swap_data.swapped_job_page_count;
        IFEND;

{Include all cases - dont put an ELSE, degrades performance

      CASEND;


      IF field.incremental AND NOT incremental_ok THEN
        ince_p^.int [int_index] := n;
        int_index := int_index + 1;
      ELSEIF field.scale > 0 THEN
        IF field.incremental THEN
          n := n - ince_p^.int [int_index];
          ince_p^.int [int_index] := ince_p^.int [int_index] + n;
          int_index := int_index + 1;
        IFEND;
        IF n < 0 THEN
          n := 0;
        IFEND;
        IF field.scale > 1 THEN
          n := n DIV field.scale;
        IFEND;
        IF (width > UPPERBOUND (max_field_values)) OR (n <= max_field_values [width]) OR
              (field.field_overflow_action = ofc$foa_maximum) THEN
          IF (width <= 19) AND ((n > max_field_values [width]) AND (field_index > 1) OR
                (n > max_field_values [width + 1])) THEN
            n := max_field_values [width];
          IFEND;
          REPEAT
            s^ (string_indexr) := $CHAR ((n MOD 10) + $INTEGER ('0'));
            n := n DIV 10;
            string_indexr := string_indexr - 1;
          UNTIL n = 0;
        ELSEIF field.field_overflow_action = ofc$foa_scale THEN
          pmp$binary_to_ascii_fit (n, 10, width - 1, width - 1, s^ (string_index + 1, width - 1));
        ELSE
          s^ (string_index, width) := ' *********************';
        IFEND;
      IFEND;

      string_index := string_index + width;

    FOREND /build_line_loop/;

    ince_p^.last_clock := clock;

  PROCEND build_line;
?? OLDTITLE, NEWTITLE := 'search_for_display_description', EJECT ??

  PROCEDURE [INLINE] search_for_display_description
    (    display_name: ost$name;
     VAR dd_pp: ^oft$display_descriptions_p);

    dd_pp := ^display_descriptions_p;
    WHILE (dd_pp^ <> NIL) AND (dd_pp^^.header.display_name <> display_name) AND
          (dd_pp^^.header.display_name_abbrev <> display_name) DO
      dd_pp := ^dd_pp^^.header.next_description_p;
    WHILEND;

  PROCEND search_for_display_description;

?? OLDTITLE, NEWTITLE := 'ofp$access_display_description', EJECT ??

  PROCEDURE [XDCL, #GATE] ofp$access_display_description
    (    request_code: oft$access_display_request_code;
         callers_dd_p: oft$display_descriptions_p;
     VAR field_count: oft$field_count;
     VAR status: ost$status);

    VAR
      abbrev_dd_pp: ^oft$display_descriptions_p,
      dd_pp: ^oft$display_descriptions_p,
      dd_p: ^oft$display_description,
      delete_dd_p: ^oft$display_description,
      index: integer,
      ok: boolean;

{ If request is to create or update an existing display, make sure the names do not
{ duplicate the names of one on the standard displays. (INDEX > 0 on search).
{ Return WARNING if duplicate name - however, create/update the display.

    osp$verify_system_privilege;
    delete_dd_p := NIL;
    IF (request_code = ofc$adrc_create) OR (request_code = ofc$adrc_change) THEN
      ofp$search_for_display_name (callers_dd_p^.header.display_name_abbrev, index);
      IF index > 0 THEN
        osp$set_status_abnormal ('OF', ofe$duplicates_hard_coded_name,
              callers_dd_p^.header.display_name_abbrev, status);
      IFEND;
      ofp$search_for_display_name (callers_dd_p^.header.display_name, index);
      IF index > 0 THEN
        osp$set_status_abnormal ('OF', ofe$duplicates_hard_coded_name, callers_dd_p^.header.display_name,
              status);
      IFEND;
      ALLOCATE dd_p: [1 .. field_count] IN osv$task_shared_heap^;
      i#move (callers_dd_p, dd_p, #SIZE (dd_p^));
      dd_p^.header.next_description_p := NIL;
      dd_p^.header.incremental_data_p := NIL;
      dd_p^.header.system_line_info.initialized := FALSE;
      dd_p^.header.field_count := field_count;
      WHILE (dd_p^.header.field_count > 1) AND (dd_p^.fields [dd_p^.header.field_count].field_id =
            ofc$fi_fill) AND (dd_p^.fields [dd_p^.header.field_count].field_title = ' ') DO
        dd_p^.header.field_count := dd_p^.header.field_count - 1;
      WHILEND;
      FOR index := 1 TO dd_p^.header.field_count DO
        dd_p^.fields [index].pack.width := dd_p^.fields [index].width;
        dd_p^.fields [index].pack.scale := dd_p^.fields [index].scale;
        dd_p^.fields [index].pack.field_id := dd_p^.fields [index].field_id;
        dd_p^.fields [index].pack.incremental := dd_p^.fields [index].incremental;
        dd_p^.fields [index].pack.field_overflow_action := dd_p^.fields [index].field_overflow_action;
        dd_p^.fields [index].pack.non_selection_action := dd_p^.fields [index].non_selection_action;
        dd_p^.fields [index].pack.field_selection := dd_p^.fields [index].field_selection;
      FOREND;
    IFEND;

    osp$set_job_signature_lock (display_lock);

    search_for_display_description (callers_dd_p^.header.display_name_abbrev, abbrev_dd_pp);
    search_for_display_description (callers_dd_p^.header.display_name, dd_pp);
    ok := dd_pp^ <> NIL;
    IF NOT ok THEN
      osp$set_status_abnormal ('OF', ofe$unknown_display, callers_dd_p^.header.display_name, status);
    IFEND;

    CASE request_code OF
    = ofc$adrc_get =
      IF ok THEN
        i#move (dd_pp^, callers_dd_p, #SIZE (dd_pp^^));
        field_count := UPPERBOUND (dd_pp^^.fields);
      IFEND;
    = ofc$adrc_create =
      IF ok OR (abbrev_dd_pp^ <> NIL) THEN
        osp$set_status_abnormal ('OF', ofe$display_already_exists, dd_p^.header.display_name, status);
        delete_dd_p := dd_p;
      ELSE
        dd_pp^ := dd_p;
        IF status.condition = ofe$unknown_display THEN
          status.normal := TRUE;
        IFEND;
      IFEND;
      ofv$displays_initialized := TRUE;
    = ofc$adrc_change =
      IF ok AND ((abbrev_dd_pp^ = NIL) OR (dd_pp = abbrev_dd_pp)) THEN
        delete_dd_p := dd_pp^;
        dd_p^.header.next_description_p := dd_pp^^.header.next_description_p;
        dd_pp^ := dd_p;
      ELSE
        delete_dd_p := dd_p;
      IFEND;
    = ofc$adrc_delete =
      IF ok THEN
        delete_dd_p := dd_pp^;
        dd_pp^ := dd_pp^^.header.next_description_p;
      IFEND;
    ELSE
    CASEND;

    osp$clear_job_signature_lock (display_lock);

    IF delete_dd_p <> NIL THEN
      IF delete_dd_p^.header.incremental_data_p <> NIL THEN
        FREE delete_dd_p^.header.incremental_data_p IN osv$task_shared_heap^;
      IFEND;
      FREE delete_dd_p IN osv$task_shared_heap^;
    IFEND;

  PROCEND ofp$access_display_description;

?? OLDTITLE, NEWTITLE := 'ofp$display', EJECT ??

  PROCEDURE [XDCL, #GATE] ofp$display
    (    wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);


    VAR
      ajlo: integer, {must be integer}
      clock: ost$free_running_clock,
      jobs_per_line_left: integer,
      job_selection: oft$job_selection,
      column_index: integer,
      dd_p: oft$max_display_descriptions_p,
      dd_pp: ^oft$display_descriptions_p,
      display_control: clt$display_control,
      ending_line: integer,
      entry_in_use: boolean,
      i: integer,
      ijl_bi: integer, {must be integer}
      ijl_bn: jmt$ijl_block_number,
      ijle_index_p: ^array [jmt$ijl_block_index] of jmt$initiated_job_list_entry,
      ijle_p: ^jmt$initiated_job_list_entry,
      ijl_number: integer,
      inc_p: ^oft$save_incremental_data,
      line_has_data: boolean,
      lines_to_write: integer,
      lines_written: integer,
      max_ijl_block_in_use: jmt$ijl_block_number,
      max_ijl_number: 0 .. jmc$max_ijl_entries + 1,
      s: string (255),
      skip_lines: integer,
      starting_line: integer;

  { PURPOSE:
  {  This procedure  is a condition handler established to clear the display_
  {  lock if the display manager aborts.

   PROCEDURE clear_display_lock
     (    condition: pmt$condition;
          cond_desc: ^pmt$condition_information;
          save:    ^ost$stack_frame_save_area;
     VAR status: ost$status);

     VAR
       local_status: ost$status,
       lock_status: ost$signature_lock_status;

     IF condition.selector = pmc$block_exit_processing THEN
       {This task is terminating so clear display lock}

       osp$initialize_signature_lock (display_lock, local_status);
     ELSE
      pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
     IFEND;
    PROCEND clear_display_lock;



    status.normal := TRUE;
    osp$establish_condition_handler (^clear_display_lock, TRUE);

    osp$verify_system_privilege;
    osp$set_job_signature_lock (display_lock);

    search_for_display_description (display_name, dd_pp);
    IF dd_pp^ = NIL THEN
      osp$clear_job_signature_lock (display_lock);
      osp$set_status_abnormal ('  ', ofe$unknown_display, display_name, status);
      RETURN;
    IFEND;

{ Form pointer to max display description. This is cheating  but is "safe" and improves
{ performance since fixed pointers are used instead of adaptable pointers.

    dd_p := #ADDRESS (1, #SEGMENT (dd_pp^), #OFFSET (dd_pp^));

    inc_p := dd_p^.header.incremental_data_p;

    max_ijl_block_in_use := jmv$ijl_p.max_block_in_use;
    max_ijl_number := (max_ijl_block_in_use + 1) * jmc$max_ijl_index_count;
    IF (inc_p = NIL) OR (UPPERBOUND (inc_p^) < max_ijl_number) THEN
      ALLOCATE dd_p^.header.incremental_data_p: [0 .. max_ijl_number] IN osv$task_shared_heap^;
      pmp$zero_out_table (#LOC (dd_p^.header.incremental_data_p^), #SIZE (dd_p^.header.incremental_data_p^));
      IF inc_p <> NIL THEN
        i#move (inc_p, dd_p^.header.incremental_data_p, #SIZE (inc_p^));
        FREE inc_p IN osv$task_shared_heap^;
      IFEND;
      inc_p := dd_p^.header.incremental_data_p;
    IFEND;

    IF initial_call THEN
      IF wid <> 0 THEN
        ?IF NOT debug THEN
          ofp$open_display (file_name, wid, dpc$wc_sharing, dpc$wk_table, dd_p^.header.title (2, 80),
                display_control, status);
        ?IFEND;
      ELSE
        ofp$open_display (file_name, wid, dpc$wc_sharing, dpc$wk_table, dd_p^.header.title (2, 80),
              display_control, status);
      IFEND;
    IFEND;

{ Determine starting and ending IJLO/AJLO for display. If output is to a file, all lines are
{ displayed. If output is to the console (wid>0), only the current page is generated.

    IF wid <> 0 THEN
      ?IF NOT debug THEN
        dpp$get_starting_line (wid, starting_line, status);
      ?ELSE
        starting_line := 1;
      ?IFEND;
      skip_lines := starting_line - 1;
      lines_to_write := 20; {This is current max window size.}
    ELSE
      skip_lines := 0;
      lines_to_write := 65535; {Max display size.
    IFEND;

    IF dd_p^.header.display_system_line THEN
      ofp$build_system_line (dd_p^.header.system_line_info, s (1, 80));
      IF wid <> 0 THEN
        ?IF debug THEN
          zdpp$put_next_line (wid, s (1, 80), status);
        ?ELSE
          dpp$put_next_line (wid, s (1, 80), status);
        ?IFEND;
      ELSE
        clp$put_display (display_control, s (1, 80), clc$trim, status);
        s (1) := ' ';
        clp$put_display (display_control, s (1, 1), clc$trim, status);
      IFEND;
      lines_written := 1;
    ELSE
      lines_written := 0;
      IF wid = 0 THEN
        s (1) := ' ';
        clp$put_display (display_control, s (1, 1), clc$trim, status);
      IFEND;
    IFEND;

    ajlo := LOWERVALUE (jmt$ajl_ordinal) - 1;
    ijl_bn := 0;
    ijl_bi := -1;
    jobs_per_line_left := dd_p^.header.jobs_per_line;
    column_index := 1;
    ijl_number := -1;
    line_has_data := FALSE;
    s := '';
    job_selection := dd_p^.header.job_selection;

  /build_display/
    WHILE lines_written < lines_to_write DO

      IF job_selection = ofc$js_active THEN
        ajlo := ajlo + 1;
        IF ajlo > jmv$max_ajl_ordinal_in_use THEN
          EXIT /build_display/;
        IFEND;
        ijle_p := jmv$ajl_p^ [ajlo].ijle_p;
        ijl_number := jmv$ajl_p^ [ajlo].ijl_ordinal.block_number * jmc$max_ijl_index_count +
              jmv$ajl_p^ [ajlo].ijl_ordinal.block_index;
        entry_in_use := (jmv$ajl_p^ [ajlo].in_use > 0) AND (ijl_number <= max_ijl_number)
              AND (ijle_p <> NIL);
      ELSE
        ijl_bi := ijl_bi + 1;
        ijl_number := ijl_number + 1;
        ?IF debug THEN
          IF wid <> 0 THEN
            ijl_bi := 0;
            ijl_number := 0;
          IFEND;
        ?IFEND;
        IF ijl_bi > UPPERVALUE (jmt$ijl_block_index) THEN
          ijl_bi := LOWERVALUE (jmt$ijl_block_index);
          ijl_bn := ijl_bn + 1;
          IF ijl_bn > max_ijl_block_in_use THEN
            EXIT /build_display/;
          IFEND;
        IFEND;
        entry_in_use := FALSE;
        IF jmv$ijl_p.block_p^ [ijl_bn].index_p <> NIL THEN
          ijle_index_p := jmv$ijl_p.block_p^ [ijl_bn].index_p;
          IF ijle_index_p <> NIL THEN
            ijle_p := ^ijle_index_p^ [ijl_bi];
            entry_in_use := ijle_p^.entry_status <> jmc$ies_entry_free;
          IFEND;
        IFEND;
      IFEND;

      IF entry_in_use AND (skip_lines = 0) THEN
        build_line (ijle_p, ijl_number, dd_p, ^inc_p^ [ijl_number], ^s (column_index, 132));
      IFEND;

      IF entry_in_use OR dd_p^.header.display_blank_lines THEN
        column_index := column_index + dd_p^.header.column_width;
        jobs_per_line_left := jobs_per_line_left - 1;
        line_has_data := TRUE;
      IFEND;

      IF jobs_per_line_left = 0 THEN
        IF skip_lines > 0 THEN
          skip_lines := skip_lines - 1;
        ELSE
          lines_written := lines_written + 1;
          IF line_has_data OR (wid <> 0) THEN
            IF wid <> 0 THEN
              ?IF debug THEN
                zdpp$put_next_line (wid, s (1, 80), status);
              ?ELSE
                dpp$put_next_line (wid, s (1, 80), status);
              ?IFEND;
            ELSE
              clp$put_display (display_control, s (1, column_index - 2), clc$trim, status);
            IFEND;
          IFEND;
        IFEND;
        line_has_data := FALSE;
        column_index := 1;
        jobs_per_line_left := dd_p^.header.jobs_per_line;
        s := '';
      IFEND;

    WHILEND /build_display/;

    IF line_has_data THEN
      IF wid <> 0 THEN
        ?IF debug THEN
          zdpp$put_next_line (wid, s (1, 80), status);
        ?ELSE
          dpp$put_next_line (wid, s (1, 80), status);
        ?IFEND;
      ELSE
        clp$put_display (display_control, s (1, column_index - 1), clc$trim, status);
      IFEND;
      lines_written := lines_written + 1;
    IFEND;

    IF wid = 0 THEN
      clp$close_display (display_control, status);
    ELSE
      s := ' ';
      FOR i := lines_written + 1 TO lines_to_write DO
        ?IF debug THEN
          zdpp$put_next_line (wid, s (1, 80), status);
        ?ELSE
          dpp$put_next_line (wid, s (1, 80), status);
        ?IFEND;
      FOREND;
    IFEND;

    osp$clear_job_signature_lock (display_lock);

  PROCEND ofp$display;
?? NEWTITLE := 'ofp$display_site_ved_names', EJECT ??

  PROCEDURE [XDCL, #GATE] ofp$display_site_ved_names
    (VAR display_control: clt$display_control;
     VAR status: ost$status);

{ Display the values of display_descriptions_p which contains the current
{ site defined ved names.

    VAR
      temp_display_description: oft$display_descriptions_p;

    IF display_descriptions_p = NIL THEN
      clp$put_display (display_control, ' No site VEDISPLAYS are currently defined.',
              {trim_option =} clc$no_trim, status);
    ELSE
      temp_display_description := display_descriptions_p;
      /display_site_ved_names/
      WHILE (temp_display_description <> NIL) DO
        clp$put_display (display_control, temp_display_description^.header.display_name,
              {trim_option =} clc$no_trim, status);
        IF NOT status.normal THEN
          EXIT /display_site_ved_names/;
        IFEND;
        temp_display_description := temp_display_description^.header.next_description_p;
      WHILEND /display_site_ved_names/;
    IFEND;

  PROCEND ofp$display_site_ved_names;
?? OLDTITLE, NEWTITLE := 'ofp$select_designer_display', EJECT ??

  PROCEDURE [XDCL, #GATE] ofp$verify_display_name
    (    display_name: ost$name;
     VAR long_name: ost$name;
     VAR status: ost$status);

    VAR
      dd_p: oft$display_descriptions_p,
      dd_pp: ^oft$display_descriptions_p;

    status.normal := TRUE;

    osp$verify_system_privilege;
    osp$set_job_signature_lock (display_lock);

    search_for_display_description (display_name, dd_pp);

    IF dd_pp^ <> NIL THEN
      dd_p := dd_pp^;
      dd_pp^ := dd_p^.header.next_description_p;
      dd_p^.header.next_description_p := display_descriptions_p;
      display_descriptions_p := dd_p;
      long_name := dd_p^.header.display_name;
    ELSE
      osp$set_status_abnormal ('  ', ofe$unknown_display, display_name, status);
    IFEND;

    osp$clear_job_signature_lock (display_lock);

  PROCEND ofp$verify_display_name;
?? NOCOMPILE ??
?? EJECT ??

  PROCEDURE [XDCL] zdpp$put_next_line
    (    wid: dpt$window_id;
         s: string ( * );
     VAR status: ost$status);

    status.normal := TRUE;
  PROCEND zdpp$put_next_line;
*copyc clp$put_job_command_response

  PROCEDURE [XDCL, #GATE] vedtest;

    VAR
      i,
      tot: integer,
      dn: ost$name,
      fn: amt$local_file_name,
      s: string (100),
      sl: integer,
      t: array [1 .. 100] of integer,
      status: ost$status;

    dn := 'IJ';
    FOR i := 1 TO 100 DO
      t [i] := #READ_REGISTER (0c9(16));
      ofp$display (1, dn, fn, i = 1, status);
      t [i] := t [i] - #READ_REGISTER (0c9(16));
    FOREND;
    tot := 0;
    FOR i := 1 TO 100 DO
      tot := tot + t [i];
      IF i < 11 THEN
        STRINGREP (s, sl, t [i]: 10, ' microseconds');
        clp$put_job_command_response (s (1, sl), status);
      IFEND;
    FOREND;
    STRINGREP (s, sl, tot DIV 10: 10, ' average microseconds');
    clp$put_job_command_response (s (1, sl), status);
  PROCEND vedtest;
?? COMPILE ??
MODEND ofm$designer_screens_r3
*DECK DECK=OFM$GENERAL_STATISTICS_DISPLAY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operator Facility : VED GS Display' ??
MODULE ofm$general_statistics_display;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc clt$display_control
*copyc jmt$system_supplied_name
*copyc jst$ijl_swap_queue_list
*copyc jsv$ijl_swap_queue_list
*copyc osc$multiprocessor_constants
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc oss$task_shared
*copyc ost$cpu_idle_statistics
*copyc ost$data_id
*copyc ost$status
*copyc ost$string
*copyc osv$task_shared_heap
?? POP ??
*copyc jmv$ijl_p
*copyc jmv$known_job_list
*copyc jmv$known_output_list
*copyc jmv$known_qfile_list
*copyc jmv$maximum_known_jobs
*copyc jmv$maximum_known_outputs
*copyc mtv$cst0
*copyc mtv$total_nos_cpu_time
*copyc tmv$total_task_count
*copyc qfv$current_kjl_limit
*copyc qfv$current_kol_limit
*copyc qfv$current_kql_limit
*copyc clp$close_display
*copy  clp$new_display_line
*copy  clp$put_display
*copyc dpp$clear_window
*copyc dpp$put_next_line
*copyc jmp$get_job_counts
*copyc ofp$build_system_line
*copyc ofp$open_display
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$get_pp_unit_count
*copyc osp$get_jm_mm_stats
*copyc osp$get_page_stats
*copyc osp$get_pio_unit_stats
*copyc osp$get_swap_stats
*copyc pmp$binary_to_ascii_fit
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ofp$general_statistics_display', EJECT ??

  PROCEDURE [XDCL] ofp$general_statistics_display
    (    wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure provides clean-up processing when a task abort occurs.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF wid = 0 THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    CONST
      max_lines = 19,
      non_incremental = FALSE;

    VAR
       iov$total_queue_calls: [XREF] integer,
       iov$actual_requests_resolved: [XREF] integer,
       iov$read_priority_invoked: [XREF] integer;

    VAR
      display_control: clt$display_control,
      pp_count, unit_count,
      i, j,
      swap_ins,
      swap_outs,
      total_tasks,
      total_reads,
      total_writes,
      total_disk_recovered_errors,
      total_disk_intermediate_errors,
      total_disk_unrecovered_errors,
      other_pf_data,
      queue_count,
      swap_file_size: integer,
      ignore_status: ost$status,
      job_counts: jmt$job_counts,
      jobs_in_long_wait_count: 0 .. jmc$max_ijl_entries,
      jobs_in_long_wait_cant_init_io: 0 .. jmc$max_ijl_entries,
      swapped_jobs_count: 0 .. jmc$max_ijl_entries,
      swap_resident_job_count: 0 .. jmc$max_ijl_entries,
      task_index: tmt$task_status,
      from_state: jmt$ijl_swap_status,
      pfd_p: ^ost$page_fault_stats,
      preads: integer,
      ptotal: integer,
      pactual: integer,
      server_pfd_p: ^ost$page_fault_stats,
      pio_unit_p: ^ost$disk_unit_stats,
      swapd_p: ^ost$swap_stats,
      jmmmd_p: ^ost$jm_mm_stats,
      title: [READ, oss$job_paged_literal] string (18) := 'General Statistics',
      str: array [1 .. max_lines] of string (80),
      previous_pf_data: [STATIC, oss$task_shared] ^ost$page_fault_stats := NIL,
      previous_server_pf_data: [STATIC, oss$task_shared] ^ost$page_fault_stats := NIL,
      previous_swap_data: [STATIC, oss$task_shared] ^ost$swap_stats := NIL,
      previous_total_reads: [STATIC, oss$task_shared] integer := 0,
      previous_total_writes: [STATIC, oss$task_shared] integer := 0,
      previous_data_for_display: [STATIC, oss$task_shared] boolean := FALSE,
      read_summary: integer,
      system_line_info: [STATIC, oss$task_shared] ^oft$system_line_info := NIL;

    status.normal := TRUE;

    IF wid = 0 THEN
      osp$establish_block_exit_hndlr (^abort_handler);
    IFEND;
    IF initial_call THEN
      ofp$open_display (file_name, wid, dpc$wc_sharing, dpc$wk_table, title, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Set up the labels.

    str [2] :=  ' PAGE QUEUES             JOBS                   SWAPPED JOBS';
    str [3] :=
                '        free:              interactive:            jobs in long wait:';
    str [4] :=
                '   available:          non-interactive:         long wait, disk down:';
    str [5] :=
                '   avail-mod:              input queue:           swap resident jobs:';
    str [6] :=  '       wired:                   active:              swapped to disk:';
    str [7] :=  '      shared:               known jobs:';
    str [8] :=  '      IO err:             output files:          number of swap outs:';
    str [9] :=  '       fixed:              queue files:               swap file size:';
    str [10] := '         JWS:';
    str [11] := '    swap-res:            TASKS                  DISK ERRORS';
    str [12] := '   long wait:                    total:              total_recovered:';
    str [13] := '                                 ready:           total_intermediate:';
    str [14] := ' PAGE FAULTS                ready/swap:            total_unrecovered:';
    str [15] := '   avail-mod:';
    str [16] := '         new:            INPUT/OUTPUT';
    str [17] := '        disk:                   writes:';
    str [18] := '       other:                    reads:';
{   str [19] := ' I/O PRIORITY';
{   str [20] := 'read prempts:             total calls:           actual issued:';
    str [19] := ' ';

    total_tasks := 0;
    PUSH jmmmd_p;

    osp$get_jm_mm_stats (non_incremental, jmmmd_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH pfd_p;
    PUSH server_pfd_p;
    osp$get_page_stats (non_incremental, pfd_p^, server_pfd_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    total_reads := 0;
    total_writes := 0;
    total_disk_recovered_errors := 0;
    total_disk_intermediate_errors := 0;
    total_disk_unrecovered_errors := 0;
    osp$get_pp_unit_count (pp_count, unit_count, status);
    IF unit_count = 0 THEN
      RETURN;
    IFEND;
    PUSH pio_unit_p: [1 .. unit_count];
    osp$get_pio_unit_stats (non_incremental, pio_unit_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    swap_file_size := 0;
    swap_ins := 0;
    swap_outs := 0;
    PUSH swapd_p;
    osp$get_swap_stats (non_incremental, swapd_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Establish base values for the general statistics display if they do not already
{ exist.

    IF NOT previous_data_for_display THEN
      ALLOCATE previous_pf_data IN osv$task_shared_heap^;
      previous_pf_data^ := pfd_p^;
      ALLOCATE system_line_info IN osv$task_shared_heap^;
      system_line_info^.initialized := FALSE;
      ALLOCATE previous_server_pf_data IN osv$task_shared_heap^;
      previous_server_pf_data^ := server_pfd_p^;
      ALLOCATE previous_swap_data IN osv$task_shared_heap^;
      previous_swap_data^ := swapd_p^;
      previous_data_for_display := TRUE;
    IFEND;

{ Set up the cpu idle-statistics and the NOS percentage.

    ofp$build_system_line (system_line_info^, str [1]);

{ Set up the page queue statistics.

    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_free],
          10, 7, 7, str[3](16, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_avail],
          10, 7, 7, str[4](16, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_avail_modified],
          10, 7, 7, str[5](16, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_wired],
          10, 7, 7, str[6](16, 7));
    j := 0;
    FOR i := mmc$pq_shared_first TO mmc$pq_shared_last DO
      j := j + jmmmd_p^.jm_mm_stats.page_q_counts.q_counts [i]; {get sum of all shared queues}
    FOREND;
    pmp$binary_to_ascii_fit (j, 10, 7, 7, str[7](16, 7));
    j := jmmmd_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_job_io_error] +
         jmmmd_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_shared_io_error] +
         jmmmd_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_swapped_io_error] +
         jmmmd_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_flawed];
    pmp$binary_to_ascii_fit (j, 10, 7, 7, str[8](16, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_job_fixed],
          10, 7, 7, str[9](16, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_job_working_set],
          10, 7, 7, str[10](16, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.swap_resident_count,
          10, 7, 7, str [11] (16, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.long_wait_count,
          10, 7, 7, str [12] (16, 7));

{ Set up the page fault statistics.  Currently, SERVER page_fault statistics are not displayed.

    pmp$binary_to_ascii_fit ((pfd_p^.pf_stats [1] +
          pfd_p^.pf_stats [2] - previous_pf_data^.pf_stats [1]
          - previous_pf_data^.pf_stats [2]), 10, 7, 7, str [15] (16, 7));
    pmp$binary_to_ascii_fit ((pfd_p^.pf_stats [10] -
          previous_pf_data^.pf_stats [10]), 10, 7, 7, str [16] (16, 7));
    pmp$binary_to_ascii_fit ((pfd_p^.pf_stats [7] -
          previous_pf_data^.pf_stats [7]), 10, 7, 7, str [17] (16, 7));
    other_pf_data := pfd_p^.pf_stats [3] +
          pfd_p^.pf_stats [4] + pfd_p^.pf_stats
          [5] + pfd_p^.pf_stats [6] + pfd_p^.pf_stats [8] +
          pfd_p^.pf_stats [9] + pfd_p^.pf_stats
          [11] + pfd_p^.pf_stats [12] + pfd_p^.
          pf_stats [13] + pfd_p^.pf_stats [14] +
          pfd_p^.pf_stats [15] - previous_pf_data^.pf_stats [3]
          - previous_pf_data^.pf_stats [4] - previous_pf_data^.pf_stats [5] -
          previous_pf_data^.pf_stats [6] - previous_pf_data^.pf_stats [8] -
          previous_pf_data^.pf_stats [9] - previous_pf_data^.pf_stats [11] -
          previous_pf_data^.pf_stats [12] - previous_pf_data^.pf_stats [13] -
          previous_pf_data^.pf_stats [14] - previous_pf_data^.pf_stats [15];
    pmp$binary_to_ascii_fit (other_pf_data, 10, 7, 7, str [18] (16, 7));

{ Set up the job statistics.

    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.
          total_interactive_jobs, 10, 5, 5, str [3] (41, 5));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.
          total_non_interactive_jobs, 10, 5, 5, str [4] (41, 5));
    jmp$get_job_counts (job_counts, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$binary_to_ascii_fit (job_counts.queued_jobs, 10, 5, 5, str [5] (41, 5));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.
          total_active_jobs, 10, 5, 5, str [6] (41, 5));

{ Set up the input/output/generic queue statistics.

    queue_count := qfv$current_kjl_limit - jmv$known_job_list.state_data
          [jmc$kjl_unused_entry].number_of_entries;
    pmp$binary_to_ascii_fit (queue_count, 10, 5, 5, str [7] (41, 5));
    IF (queue_count >= jmv$maximum_known_jobs) THEN
      str [7] (46, 1) := '*';
    IFEND;

    queue_count := qfv$current_kol_limit - jmv$known_output_list.state_data
          [jmc$kol_unused_entry].number_of_entries;
    pmp$binary_to_ascii_fit (queue_count, 10, 5, 5, str [8] (41, 5));
    IF (queue_count >= jmv$maximum_known_outputs) THEN
      str [8] (46, 1) := '*';
    IFEND;

    queue_count := qfv$current_kql_limit - jmv$known_qfile_list.state_data
          [jmc$kql_unused_entry].number_of_entries;
    pmp$binary_to_ascii_fit (queue_count, 10, 5, 5, str [9] (41, 5));

{ Set up the task statistics.

    total_tasks := total_tasks + tmv$total_task_count;
    pmp$binary_to_ascii_fit (total_tasks, 10, 5, 5, str [12] (41, 5));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.
          total_ready_tasks, 10, 5, 5, str [13] (41, 5));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.
          total_ready_but_swapped_tasks, 10, 5, 5, str [14] (41, 5));

{ Set up the input/output statistics.

    FOR i := 1 TO unit_count DO
      IF pio_unit_p^.disk_unit_stats [i].unit_used THEN
        total_writes := total_writes + pio_unit_p^.disk_unit_stats [i].write_requests +
                        pio_unit_p^.disk_unit_stats [i].swap_out_requests;
        total_reads := total_reads + pio_unit_p^.disk_unit_stats [i].read_requests +
                        pio_unit_p^.disk_unit_stats [i].swap_in_requests;
        total_disk_recovered_errors := total_disk_recovered_errors +
                        pio_unit_p^.disk_unit_stats [i].recovered_errors;
        total_disk_intermediate_errors := total_disk_intermediate_errors +
                        pio_unit_p^.disk_unit_stats [i].intermediate_errors;
        total_disk_unrecovered_errors := total_disk_unrecovered_errors +
                        pio_unit_p^.disk_unit_stats [i].unrecovered_errors;
      IFEND;
    FOREND;

    IF previous_total_reads = 0 THEN {First time through the display for this task}
      previous_total_reads := total_reads;
      previous_total_writes := total_writes;
    IFEND;

    pmp$binary_to_ascii_fit (total_writes - previous_total_writes, 10, 5, 5, str [17] (41, 5));
    pmp$binary_to_ascii_fit (total_reads - previous_total_reads, 10, 5, 5, str [18] (41, 5));
    pmp$binary_to_ascii_fit (total_disk_recovered_errors, 10, 5, 5, str [12] (71, 5));
    pmp$binary_to_ascii_fit (total_disk_intermediate_errors, 10, 5, 5, str [13] (71, 5));
    pmp$binary_to_ascii_fit (total_disk_unrecovered_errors, 10, 5, 5, str [14] (71, 5));

{ Set up the swapping statistics.

    IF (swapd_p^.swap_file_page_count.swap_count -
          previous_swap_data^.swap_file_page_count.swap_count) > 0 THEN
      swap_file_size := (swapd_p^.swap_file_page_count.
            page_count - previous_swap_data^.swap_file_page_count.page_count)
            DIV (swapd_p^.swap_file_page_count.swap_count -
            previous_swap_data^.swap_file_page_count.swap_count);
      pmp$binary_to_ascii_fit (swap_file_size, 10, 5, 5, str [9] (71, 5));
    ELSE
      swap_file_size := 0;
      pmp$binary_to_ascii_fit (swap_file_size, 10, 5, 5, str [9] (71, 5));
    IFEND;

    swap_outs := swapd_p^.swap_stats [jmc$iss_executing]
          [jmc$iss_job_idle_tasks_complete].count - previous_swap_data^.swap_stats
          [jmc$iss_executing] [jmc$iss_job_idle_tasks_complete].count +
          swapd_p^.swap_stats [jmc$iss_executing]
          [jmc$iss_swapped_no_io].count - previous_swap_data^.swap_stats
          [jmc$iss_executing] [jmc$iss_swapped_no_io].count +
          swapd_p^.swap_stats [jmc$iss_executing]
          [jmc$iss_flush_am_pages].count - previous_swap_data^.swap_stats
          [jmc$iss_executing] [jmc$iss_flush_am_pages].count;
    pmp$binary_to_ascii_fit (swap_outs, 10, 5, 5, str [8] (71, 5));

    jobs_in_long_wait_count := jsv$ijl_swap_queue_list [jsc$isqi_swapped_io_not_init].count;
    pmp$binary_to_ascii_fit (jobs_in_long_wait_count, 10, 5, 5, str [3] (71, 5));
    jobs_in_long_wait_cant_init_io := jsv$ijl_swap_queue_list [jsc$isqi_swapped_io_cannot_init].count;
    pmp$binary_to_ascii_fit (jobs_in_long_wait_cant_init_io, 10, 5, 5, str [4] (71, 5));
    swap_resident_job_count := jsv$ijl_swap_queue_list [jsc$isqi_swapped_io_completed].count;
    pmp$binary_to_ascii_fit (swap_resident_job_count, 10, 5, 5, str [5] (71, 5));
    swapped_jobs_count := jsv$ijl_swap_queue_list [jsc$isqi_swapped_out].count;
    pmp$binary_to_ascii_fit (swapped_jobs_count, 10, 5, 5, str [6] (71, 5));

{ Display I/O Priority information

{   preads := iov$read_priority_invoked;
{   pmp$binary_to_ascii_fit (preads, 10,10,10, str [20] (14,10));
{   ptotal := iov$total_queue_calls;
{   pmp$binary_to_ascii_fit (ptotal, 10,10,10, str [20] (39,10));
{   pactual := iov$total_queue_calls - iov$actual_requests_resolved;
{   pmp$binary_to_ascii_fit (pactual, 10,10,10, str [20] (64,10));

    previous_pf_data^ := pfd_p^;
    previous_server_pf_data^ := server_pfd_p^;
    previous_total_reads := total_reads;
    previous_total_writes := total_writes;
    previous_swap_data^ := swapd_p^;

{ Display the results.

    IF wid <> 0 THEN
      dpp$clear_window (wid, status);
      FOR i := 1 TO max_lines DO
        dpp$put_next_line (wid, str [i], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND
    ELSE
      FOR i := 1 TO max_lines DO
        clp$put_display (display_control, str [i], clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
      clp$close_display (display_control, status);
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND ofp$general_statistics_display;
?? OLDTITLE ??
?? OLDTITLE ??
MODEND ofm$general_statistics_display
*DECK DECK=OFM$IO_SUMMARY_DISPLAY EXPAND=TRUE


?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operator Facility : VED IS Display' ??
MODULE ofm$io_summary_display;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc clt$display_control
*copyc cmv$logical_unit_table
*copyc jmt$system_supplied_name
*copyc jst$ijl_swap_queue_list
*copyc jsv$ijl_swap_queue_list
*copyc rmt$recorded_vsn
*copyc osc$multiprocessor_constants
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc oss$task_shared
*copyc ost$cpu_idle_statistics
*copyc ost$data_id
*copyc ost$status
*copyc ost$string
*copyc osv$task_shared_heap
?? POP ??
*copyc jmv$ijl_p
*copyc jmv$known_job_list
*copyc jmv$known_output_list
*copyc jmv$known_qfile_list
*copyc jmv$maximum_known_jobs
*copyc jmv$maximum_known_outputs
*copyc mtv$cst0
*copyc mtv$total_nos_cpu_time
*copyc tmv$total_task_count
*copyc qfv$current_kjl_limit
*copyc qfv$current_kol_limit
*copyc qfv$current_kql_limit
*copyc clp$close_display
*copy  clp$new_display_line
*copy  clp$put_display
*copyc dpp$clear_window
*copyc dpp$put_next_line
*copyc jmp$get_job_counts
*copyc ofp$build_system_line
*copyc ofp$open_display
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$get_pp_unit_count
*copyc osp$get_jm_mm_stats
*copyc osp$get_page_stats
*copyc osp$get_pio_pp_stats
*copyc osp$get_pio_unit_stats
*copyc osp$get_swap_stats
*copyc pmp$binary_to_ascii_fit
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ofp$io_summary_display', EJECT ??

  PROCEDURE [XDCL] ofp$io_summary_display
    (    wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure provides clean-up processing when a task abort occurs.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF wid = 0 THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??



    TYPE
     unit_info = RECORD
               unit: iot$logical_unit,
               count: integer,
                 RECEND;


    CONST
      max_lines = 21,
      non_incremental = FALSE;

    VAR
       iov$lunvsns: [XREF] ARRAY [1 .. 100] of rmt$recorded_vsn,
       iov$reject_address_buffer_full: [XREF] integer,
       iov$reject_interlock_set: [XREF] integer,
       iov$reject_requests_full: [XREF] integer,
       iov$reject_unit_queue_limit: [XREF] integer,


       iov$total_queue_calls: [XREF] integer,
       iov$actual_requests_resolved: [XREF] integer,
       iov$read_priority_invoked: [XREF] integer,

       mmv$sq_mcount: [XREF] integer,
       mmv$sq_rcount: [XREF] integer,
       mmv$jws_mcount: [XREF] integer,
       mmv$jws_rcount: [XREF] integer;

    VAR
      display_control: clt$display_control,
      pp_count, unit_count,
      i, j, k,
      swap_ins,
      swap_outs,
      total_tasks,
      total_reads,
      total_writes,
      total_disk_recovered_errors,
      total_disk_intermediate_errors,
      total_disk_unrecovered_errors,
      other_pf_data,
      queue_count,
      swap_file_size: integer,
      ignore_status: ost$status,
      job_counts: jmt$job_counts,
      jobs_in_long_wait_count: 0 .. jmc$max_ijl_entries,
      jobs_in_long_wait_cant_init_io: 0 .. jmc$max_ijl_entries,
      lun: iot$logical_unit,
      left: boolean,
      increment: boolean,
      diskpp_p: ^ost$disk_pp_stats,
      swapped_jobs_count: 0 .. jmc$max_ijl_entries,
      swap_resident_job_count: 0 .. jmc$max_ijl_entries,
      task_index: tmt$task_status,
      from_state: jmt$ijl_swap_status,
      un: integer,
      ln: integer,
      pfd_p: ^ost$page_fault_stats,
      preads: integer,
      ptotal: integer,
      pactual: integer,
      server_pfd_p: ^ost$page_fault_stats,
      pio_unit_p: ^ost$disk_unit_stats,
      swapd_p: ^ost$swap_stats,
      jmmmd_p: ^ost$jm_mm_stats,
      title: [READ, oss$job_paged_literal] string (18) := 'I/O Summary',
      vsn: rmt$recorded_vsn,
      str: array [1 .. max_lines] of string (80),
      temp_str: string(80),
      previous_pf_data: [STATIC, oss$task_shared] ^ost$page_fault_stats := NIL,
      previous_server_pf_data: [STATIC, oss$task_shared] ^ost$page_fault_stats := NIL,
      previous_swap_data: [STATIC, oss$task_shared] ^ost$swap_stats := NIL,
      previous_total_reads: [STATIC, oss$task_shared] integer := 0,
      previous_total_writes: [STATIC, oss$task_shared] integer := 0,
      previous_data_for_display: [STATIC, oss$task_shared] boolean := FALSE,
      read_summary: integer,
      unit_interface_table: ^iot$unit_interface_table,
      uit: ^iot$unit_interface_table,
      units: integer,
      unit_data: array [1 .. 100] of unit_info,
      system_line_info: [STATIC, oss$task_shared] ^oft$system_line_info := NIL;

    status.normal := TRUE;

    IF wid = 0 THEN
      osp$establish_block_exit_hndlr (^abort_handler);
    IFEND;
    IF initial_call THEN
      ofp$open_display (file_name, wid, dpc$wc_sharing, dpc$wk_table, title, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Set up the labels.

    str [2] :=  '               QUEUE COUNT BY LUN  ';
    str [3] :=  '  01:       02:       03:       04:       05:       06:       ';
    str [4] :=  '  07:       08:       09:       10:       11:       12:       ';
    str [5] :=  '  13:       14:       15:       16:       17:       18:       ';
    str [6] :=  '  19:       20:       21:       22:       23:       24:       ';
    str [7] :=  '  25:       26:       27:       28:       29:       30:       ';
    str [8] :=  '  31:       32:       33:       34:       35:       36:       ';
    str [9] :=  '  37:       38:       39:       40:       41:       42:       ';
    str [10] := '                                                              ';
    str [11] := '                                                              ';
    str [12] := 'IOU     CH        PP         Total   Average Wait             ';
    str [13] := 'Name   Name       Util       Reqs     In queue                ';
    str [14] := '                                                              ';
    str [15] := '                                                              ';
    str [16] := '                                                              ';
    str [17] := '                                                              ';
    str [18] := '                                                              ';
    str [19] := '                                                              ';
    str [20] := '                                                              ';
    str [21] := ' ';

    total_tasks := 0;
    PUSH jmmmd_p;

    osp$get_jm_mm_stats (non_incremental, jmmmd_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH pfd_p;
    PUSH server_pfd_p;
    osp$get_page_stats (non_incremental, pfd_p^,server_pfd_p^,status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    total_reads := 0;
    total_writes := 0;
    total_disk_recovered_errors := 0;
    total_disk_intermediate_errors := 0;
    total_disk_unrecovered_errors := 0;
    osp$get_pp_unit_count (pp_count, unit_count, status);
    IF unit_count = 0 THEN
      RETURN;
    IFEND;
    PUSH pio_unit_p: [1 .. unit_count];
    osp$get_pio_unit_stats (non_incremental, pio_unit_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Establish base values for the general statistics display if they do not already
{ exist.

    IF NOT previous_data_for_display THEN
      ALLOCATE previous_pf_data IN osv$task_shared_heap^;
      previous_pf_data^ := pfd_p^;
      ALLOCATE system_line_info IN osv$task_shared_heap^;
      system_line_info^.initialized := FALSE;
      ALLOCATE previous_server_pf_data IN osv$task_shared_heap^;
      previous_server_pf_data^ := server_pfd_p^;
      previous_data_for_display := TRUE;
    IFEND;

{ Set up the cpu idle-statistics and the NOS percentage.

    ofp$build_system_line (system_line_info^, str [1]);



{ get the I/O queue counts by logical unit

    IF cmv$logical_unit_table = NIL THEN
      RETURN;
    IFEND;


    temp_str := ' ';
    units := 0;
    un := 0;
    ln := 3;
    FOR i := 1 TO UPPERBOUND (cmv$logical_unit_table^)  DO
        uit := cmv$logical_unit_table^ [i].unit_interface_table;
        IF uit <> NIL THEN
          IF (uit^.unit_type >= ioc$lowest_disk_unit) AND
                (uit^.unit_type <= ioc$highest_disk_unit) THEN
               lun := uit^.logical_unit;
               pmp$binary_to_ascii_fit (lun,10,2,2,str[ln](un+2,2));
               temp_str := str[ln];
               temp_str(un+4) := ':';
               str[ln] := temp_str;
               pmp$binary_to_ascii_fit (uit^.queue_count,10,3,3,str[ln](un+6,7));
           units := units + 1;
           IF (units = 7) THEN
              units := 0;
              un := 0;
              ln := ln + 1;
           ELSE
              un := un + 10;
           IFEND;
          IFEND;
        IFEND;
    FOREND;

{ Set up the input/output statistics.

    FOR i := 1 TO unit_count DO
      IF pio_unit_p^.disk_unit_stats [i].unit_used THEN
        total_writes := total_writes + pio_unit_p^.disk_unit_stats [i].write_requests +
                        pio_unit_p^.disk_unit_stats [i].swap_out_requests;
        total_reads := total_reads + pio_unit_p^.disk_unit_stats [i].read_requests +
                        pio_unit_p^.disk_unit_stats [i].swap_in_requests;
      IFEND;
    FOREND;

    IF previous_total_reads = 0 THEN {First time through the display for this task}
      previous_total_reads := total_reads;
      previous_total_writes := total_writes;
    IFEND;

    pmp$binary_to_ascii_fit (total_writes - previous_total_writes,10,5,5,str [15] (15, 5));
    pmp$binary_to_ascii_fit (total_reads - previous_total_reads,10,5,5,str[16](15, 5));



    previous_pf_data^ := pfd_p^;
    previous_server_pf_data^ := server_pfd_p^;
    previous_total_reads := total_reads;
    previous_total_writes := total_writes;

{ Display rejects

   pmp$binary_to_ascii_fit(iov$reject_requests_full,10,7,7,str[20] (14,7));
   pmp$binary_to_ascii_fit(iov$reject_unit_queue_limit,10,7,7,str[19] (14,7));

{ Display QuickSweep statistics, this is count of stale pages flushed during
{ the quicksweep cycle. First is the number of modified pages flushed and next
{ is the total flushed. These values are reset every ten minutes.

   pmp$binary_to_ascii_fit(mmv$sq_mcount,10,7,7,str[17] (34,7));
   pmp$binary_to_ascii_fit(mmv$sq_rcount,10,7,7,str[18] (34,7));
   pmp$binary_to_ascii_fit(mmv$jws_mcount,10,7,7,str[19] (34,7));
   pmp$binary_to_ascii_fit(mmv$jws_mcount,10,7,7,str[20] (34,7));





{ Display the results.

    IF wid <> 0 THEN
      dpp$clear_window (wid, status);
      FOR i := 1 TO max_lines DO
        dpp$put_next_line (wid, str [i], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND
    ELSE
      FOR i := 1 TO max_lines DO
        clp$put_display (display_control, str [i], clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
      clp$close_display (display_control, status);
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND ofp$io_summary_display;
?? OLDTITLE ??
MODEND ofm$io_summary_display

*DECK DECK=OFM$JOB_MESSAGE_PROCESSING EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operator Facility : Operator Message Management' ??
MODULE ofm$job_message_processing;

{     This module is placed on the following libraries
{        OSF$SYSTEM_CORE_113

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc ofc$base_error
*copyc ofc$max_messages_per_job
*copyc ofc$signal_contents
*copyc ofd$error_title
*copyc ofd$type_definition
*copyc ofe$error_codes
*copyc oft$operator_classes
*copyc oft$operator_message_descriptor
*copyc oft$display_message_info
*copyc osc$status_parameter_delimiter
*copyc tmc$signal_identifiers
?? POP ??
*copyc jmp$get_ijle_p
*copyc jmp$get_job_internal_info
*copyc osp$clear_mainframe_sig_lock
*copyc osp$reset_heap
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_job_names
*copyc pmp$ready_task
*copyc pmp$send_signal
*copyc dpv$enable_stop_key
*copyc oss$job_fixed
*copyc oss$mainframe_pageable
*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc jmv$kjlx_p
*copyc osv$mainframe_pageable_heap
*copyc osv$task_private_heap

  VAR
    ofv$message_queue_head_p: [STATIC, oss$mainframe_pageable] ^oft$operator_message_descriptor := NIL,
    ofv$message_queue_lock: [STATIC, oss$mainframe_pageable] ost$signature_lock := [0],
    ofv$message_structure_heap_p: [STATIC, oss$mainframe_pageable] ^HEAP
          (REP ofc$maximum_queue_messages of oft$operator_message_descriptor) := NIL;

  VAR

{ It is important that the operator class names in the following array are arranged
{ in ascending order according to their corresponding numeric definitions in the
{ oft$operator_class type definition.

    operator_class_names: [READ] array [0 .. ofc$max_valid_operator_class] of string (osc$max_name_size) :=
          ['Removable Media Operator', 'System Operator'];

?? TITLE := 'ofp$acknowledge_operator_msg_r1', EJECT ??
*copyc ofh$acknowledge_operator_msg_r1

  PROCEDURE [XDCL, #GATE] ofp$acknowledge_operator_msg_r1
    (    message_id: oft$operator_message_id;
         active_operator_classes: oft$operator_classes;
         response: ost$string;
     VAR status: ost$status);

    VAR
      message_id_string: string (osc$max_string_size),
      message_id_string_length: integer,
      message_descriptor_p: ^oft$operator_message_descriptor;

    status.normal := TRUE;
    STRINGREP (message_id_string, message_id_string_length, message_id);
    IF ofv$message_queue_head_p = NIL THEN
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_message_id,
            message_id_string (1, message_id_string_length), status);
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (ofv$message_queue_lock);
    message_descriptor_p := ofv$message_queue_head_p;

  /search_for_message/
    WHILE message_descriptor_p <> NIL DO
      IF (message_descriptor_p^.message_id = message_id) AND
            (message_descriptor_p^.message_class IN active_operator_classes) THEN
        IF message_descriptor_p^.acknowledgement_allowed THEN
          message_descriptor_p^.response_received := TRUE;
          message_descriptor_p^.response_message := response;
        ELSE
          osp$set_status_abnormal (ofc$operator_facility_id, ofe$acknowledgement_not_allowed,
                message_id_string (1, message_id_string_length), status);
        IFEND;
        EXIT /search_for_message/;
      IFEND;
      message_descriptor_p := message_descriptor_p^.next_descriptor_p;
    WHILEND /search_for_message/;

    osp$clear_mainframe_sig_lock (ofv$message_queue_lock);

    IF message_descriptor_p <> NIL THEN
      IF status.normal THEN
        pmp$ready_task (message_descriptor_p^.sending_task, status);
      IFEND;
    ELSE
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_message_id,
            message_id_string (1, message_id_string_length), status);
    IFEND;

  PROCEND ofp$acknowledge_operator_msg_r1;
?? TITLE := 'ofp$clear_operator_message_r1', EJECT ??
*copyc ofh$clear_operator_message_r1

  PROCEDURE [XDCL, #GATE] ofp$clear_operator_message_r1
    (    operator_class: oft$operator_class;
     VAR status: ost$status);

    VAR
      gtid: ost$global_task_id,
      message_descriptor_p: ^oft$operator_message_descriptor,
      previous_descriptor_p: ^oft$operator_message_descriptor;

    status.normal := TRUE;
    IF ofv$message_queue_head_p = NIL THEN
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$no_message_outstanding,
            operator_class_names [operator_class], status);
      RETURN;
    IFEND;

    pmp$get_executing_task_gtid (gtid);
    osp$set_mainframe_sig_lock (ofv$message_queue_lock);
    message_descriptor_p := ofv$message_queue_head_p;
    previous_descriptor_p := NIL;

  /search_for_message/
    WHILE message_descriptor_p <> NIL DO
      IF (message_descriptor_p^.sending_task = gtid) AND (message_descriptor_p^.message_class =
            operator_class) THEN
        IF previous_descriptor_p <> NIL THEN
          previous_descriptor_p^.next_descriptor_p := message_descriptor_p^.next_descriptor_p;
        ELSE
          ofv$message_queue_head_p := message_descriptor_p^.next_descriptor_p;
        IFEND;
        EXIT /search_for_message/;
      IFEND;
      previous_descriptor_p := message_descriptor_p;
      message_descriptor_p := message_descriptor_p^.next_descriptor_p;
    WHILEND /search_for_message/;

    osp$clear_mainframe_sig_lock (ofv$message_queue_lock);

    IF message_descriptor_p <> NIL THEN
      FREE message_descriptor_p IN ofv$message_structure_heap_p^;
    ELSE
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$no_message_outstanding,
            operator_class_names [operator_class], status);
    IFEND;

  PROCEND ofp$clear_operator_message_r1;
?? TITLE := 'ofp$get_operator_messages', EJECT ??
*copyc ofh$get_operator_messages

  PROCEDURE [XDCL, #GATE] ofp$get_operator_messages
    (    active_operator_classes: oft$operator_classes;
     VAR message_array: array [1 .. * ] of oft$operator_message_descriptor;
     VAR count: integer;
     VAR status: ost$status);

    VAR
      messages_with_responses: 0 .. ofc$maximum_queue_messages,
      message_descriptor_p: ^oft$operator_message_descriptor;

    status.normal := TRUE;
    count := 0;
    messages_with_responses := 0;
    IF ofv$message_queue_head_p = NIL THEN
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (ofv$message_queue_lock);
    message_descriptor_p := ofv$message_queue_head_p;

  /search_for_message/
    WHILE message_descriptor_p <> NIL DO
      IF (message_descriptor_p^.message_class IN active_operator_classes) THEN
        count := count + 1;
        IF count > ofc$maximum_queue_messages THEN
          osp$system_error ('OF message queue error', NIL);
          RETURN;
        IFEND;

        IF message_descriptor_p^.response_received THEN

{ If the message has received a response, then do not return it to the caller.

          messages_with_responses := messages_with_responses + 1;
        ELSE
          IF (count - messages_with_responses) <= UPPERBOUND (message_array) THEN
            message_array [count - messages_with_responses] := message_descriptor_p^;
          IFEND;
        IFEND;
      IFEND;

      message_descriptor_p := message_descriptor_p^.next_descriptor_p;
    WHILEND /search_for_message/;

    osp$clear_mainframe_sig_lock (ofv$message_queue_lock);

{ Return to the caller only the count of active messages.

    count := count - messages_with_responses;

  PROCEND ofp$get_operator_messages;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ofp$job_begin', EJECT ??
*copyc ofh$job_begin

  PROCEDURE [XDCL, #GATE] ofp$job_begin;

    VAR
      hp_p: ^ost$heap;

    IF ofv$message_structure_heap_p = NIL THEN
      ALLOCATE ofv$message_structure_heap_p IN osv$mainframe_pageable_heap^;
      hp_p := #LOC (ofv$message_structure_heap_p^);
      osp$reset_heap (hp_p, #SIZE (ofv$message_structure_heap_p^), TRUE, 2);
    IFEND;
  PROCEND ofp$job_begin;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ofp$job_end', EJECT ??
*copyc ofh$job_end

  PROCEDURE [XDCL, #GATE] ofp$job_end;

    VAR
      job_name: jmt$user_supplied_name,
      job_sequence: jmt$system_supplied_name,
      message_descriptor_p: ^oft$operator_message_descriptor,
      previous_descriptor_p: ^oft$operator_message_descriptor,
      status: ost$status;

    status.normal := TRUE;

    pmp$get_job_names (job_name, job_sequence, status);

    IF ofv$message_queue_head_p = NIL THEN
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (ofv$message_queue_lock);
    message_descriptor_p := ofv$message_queue_head_p;
    previous_descriptor_p := NIL;

    WHILE message_descriptor_p <> NIL DO
      IF message_descriptor_p^.system_supplied_name = job_sequence THEN
        IF previous_descriptor_p <> NIL THEN
          previous_descriptor_p^.next_descriptor_p := message_descriptor_p^.next_descriptor_p;
        ELSE
          ofv$message_queue_head_p := message_descriptor_p^.next_descriptor_p;
        IFEND;
        FREE message_descriptor_p IN ofv$message_structure_heap_p^;
        IF previous_descriptor_p <> NIL THEN
          message_descriptor_p := previous_descriptor_p^.next_descriptor_p;
        ELSE
          message_descriptor_p := ofv$message_queue_head_p;
        IFEND;
      ELSE
        previous_descriptor_p := message_descriptor_p;
        message_descriptor_p := message_descriptor_p^.next_descriptor_p;
      IFEND;
    WHILEND;

    osp$clear_mainframe_sig_lock (ofv$message_queue_lock);

    jmv$jcb.ijle_p^.display_message.display_message.size := 0;
    jmv$jcb.ijle_p^.display_message.display_message_lock.lock_id := 0;

  PROCEND ofp$job_end;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, UNSAFE] ofp$job_operator_msgs_active', EJECT ??
*copyc ofh$job_operator_msgs_active

  FUNCTION [XDCL, UNSAFE] ofp$job_operator_msgs_active
    (    job_name: jmt$system_supplied_name): boolean;

    VAR
      message_descriptor_p: ^oft$operator_message_descriptor;

    ofp$job_operator_msgs_active := FALSE;
    IF ofv$message_queue_head_p = NIL THEN
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (ofv$message_queue_lock);
    message_descriptor_p := ofv$message_queue_head_p;

  /search_for_message/
    WHILE message_descriptor_p <> NIL DO
      IF ((message_descriptor_p^.system_supplied_name = job_name) AND
            NOT message_descriptor_p^.response_received) THEN
        ofp$job_operator_msgs_active := TRUE;
        EXIT /search_for_message/;
      IFEND;

      message_descriptor_p := message_descriptor_p^.next_descriptor_p;
    WHILEND /search_for_message/;

    osp$clear_mainframe_sig_lock (ofv$message_queue_lock);

  FUNCEND ofp$job_operator_msgs_active;
?? TITLE := 'ofp$receive_operator_resp_r1', EJECT ??

*copyc ofh$receive_operator_resp_r1

  PROCEDURE [XDCL, #GATE] ofp$receive_operator_resp_r1
    (    operator_class: oft$operator_class;
     VAR response: ost$string;
     VAR status: ost$status);

    VAR
      gtid: ost$global_task_id,
      message_descriptor_p: ^oft$operator_message_descriptor,
      previous_descriptor_p: ^oft$operator_message_descriptor;

    status.normal := TRUE;
    pmp$get_executing_task_gtid (gtid);
    IF ofv$message_queue_head_p = NIL THEN
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$no_message_outstanding,
            operator_class_names [operator_class], status);
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (ofv$message_queue_lock);
    message_descriptor_p := ofv$message_queue_head_p;
    previous_descriptor_p := NIL;

  /search_for_message/
    WHILE message_descriptor_p <> NIL DO
      IF (message_descriptor_p^.message_class = operator_class) AND
            (message_descriptor_p^.sending_task = gtid) THEN
        IF message_descriptor_p^.response_received THEN
          response := message_descriptor_p^.response_message;
          IF previous_descriptor_p = NIL THEN
            ofv$message_queue_head_p := message_descriptor_p^.next_descriptor_p;
          ELSE
            previous_descriptor_p^.next_descriptor_p := message_descriptor_p^.next_descriptor_p;
          IFEND;
        ELSE
          osp$set_status_abnormal (ofc$operator_facility_id, ofe$no_response_available,
                operator_class_names [operator_class], status);
        IFEND;

        EXIT /search_for_message/;
      IFEND;

      previous_descriptor_p := message_descriptor_p;
      message_descriptor_p := message_descriptor_p^.next_descriptor_p;
    WHILEND /search_for_message/;

    osp$clear_mainframe_sig_lock (ofv$message_queue_lock);

    IF message_descriptor_p <> NIL THEN
      IF status.normal THEN
        FREE message_descriptor_p IN ofv$message_structure_heap_p^;
      IFEND;
    ELSE
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$no_message_outstanding,
            operator_class_names [operator_class], status);
    IFEND;

  PROCEND ofp$receive_operator_resp_r1;
?? TITLE := 'ofp$send_operator_message_r1', EJECT ??

*copyc ofh$send_operator_message_r1

  PROCEDURE [XDCL, #GATE] ofp$send_operator_message_r1
    (    formatted_message: oft$formatted_operator_message;
         number_of_message_lines: oft$number_of_displayable_lines;
         operator_class: oft$operator_class;
         acknowledgement_allowed: boolean;
     VAR status: ost$status);

    VAR
      gtid: ost$global_task_id,
      job_message_counter: 0 .. ofc$max_messages_per_job + 1,
      last_descriptor_p: ^oft$operator_message_descriptor,
      max_messages_string: string (osc$max_string_size),
      max_messages_string_length: integer,
      message_descriptor_p: ^oft$operator_message_descriptor,
      message_id: 0 .. ofc$max_message_ordinal,
      new_message_p: ^oft$operator_message_descriptor,
      next_message_id: [STATIC, oss$mainframe_pageable] 0 .. ofc$max_message_ordinal := 0,
      ssn: jmt$system_supplied_name,
      usn: jmt$user_supplied_name;

    status.normal := TRUE;
    pmp$get_executing_task_gtid (gtid);
    pmp$get_job_names (usn, ssn, status);
    ALLOCATE new_message_p IN ofv$message_structure_heap_p^;
    IF new_message_p = NIL THEN
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$allocate_structure_failed, ' ', status);
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (ofv$message_queue_lock);
    message_id := next_message_id;

  /queue_message/
    BEGIN

    /validate_message/
      WHILE TRUE DO
        job_message_counter := 0;
        last_descriptor_p := NIL;
        message_descriptor_p := ofv$message_queue_head_p;
        message_id := (message_id + 1) MOD ofc$max_message_ordinal;
        WHILE message_descriptor_p <> NIL DO
          IF message_descriptor_p^.message_id <> message_id THEN
            IF message_descriptor_p^.system_supplied_name = ssn THEN
              job_message_counter := job_message_counter + 1;
              IF job_message_counter > ofc$max_messages_per_job THEN
                STRINGREP (max_messages_string, max_messages_string_length, ofc$max_messages_per_job);
                osp$set_status_abnormal (ofc$operator_facility_id, ofe$max_job_operator_messages,
                      max_messages_string (1, max_messages_string_length), status);
                FREE new_message_p IN ofv$message_structure_heap_p^;
                EXIT /queue_message/;
              IFEND;
              IF (message_descriptor_p^.sending_task = gtid) AND
                    (message_descriptor_p^.message_class = operator_class) THEN
                osp$set_status_abnormal (ofc$operator_facility_id, ofe$message_outstanding,
                      operator_class_names [operator_class], status);
                FREE new_message_p IN ofv$message_structure_heap_p^;
                EXIT /queue_message/;
              IFEND;
            IFEND;
          ELSE
            CYCLE /validate_message/; {The message identifier is not unique.}
          IFEND;

          last_descriptor_p := message_descriptor_p;
          message_descriptor_p := message_descriptor_p^.next_descriptor_p;
        WHILEND;
        EXIT /validate_message/;
      WHILEND /validate_message/;

      IF last_descriptor_p = NIL THEN
        ofv$message_queue_head_p := new_message_p;
      ELSE
        last_descriptor_p^.next_descriptor_p := new_message_p;
      IFEND;

      next_message_id := message_id;
      new_message_p^.next_descriptor_p := NIL;
      new_message_p^.sending_task := gtid;
      new_message_p^.message_class := operator_class;
      new_message_p^.message_id := next_message_id;
      new_message_p^.acknowledgement_allowed := acknowledgement_allowed;
      new_message_p^.system_supplied_name := ssn;
      new_message_p^.formatted_message := formatted_message;
      new_message_p^.number_of_message_lines := number_of_message_lines;
      new_message_p^.response_received := FALSE;
    END /queue_message/;

    osp$clear_mainframe_sig_lock (ofv$message_queue_lock);

  PROCEND ofp$send_operator_message_r1;
?? TITLE := 'ofp$task_end_helper ', EJECT ??

  PROCEDURE [XDCL, #GATE] ofp$task_end_helper;

    VAR
      gtid: ost$global_task_id,
      message_descriptor_p: ^oft$operator_message_descriptor,
      previous_descriptor_p: ^oft$operator_message_descriptor,
      status: ost$status;

    pmp$get_executing_task_gtid (gtid);
    IF ofv$message_queue_head_p = NIL THEN
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (ofv$message_queue_lock);
    message_descriptor_p := ofv$message_queue_head_p;
    previous_descriptor_p := NIL;

    WHILE message_descriptor_p <> NIL DO
      IF message_descriptor_p^.sending_task = gtid THEN
        IF previous_descriptor_p <> NIL THEN
          previous_descriptor_p^.next_descriptor_p := message_descriptor_p^.next_descriptor_p;
        ELSE
          ofv$message_queue_head_p := message_descriptor_p^.next_descriptor_p;
        IFEND;
        FREE message_descriptor_p IN ofv$message_structure_heap_p^;
        IF previous_descriptor_p <> NIL THEN
          message_descriptor_p := previous_descriptor_p^.next_descriptor_p;
        ELSE
          message_descriptor_p := ofv$message_queue_head_p;
        IFEND;
      ELSE
        previous_descriptor_p := message_descriptor_p;
        message_descriptor_p := message_descriptor_p^.next_descriptor_p;
      IFEND;
    WHILEND;

    osp$clear_mainframe_sig_lock (ofv$message_queue_lock);

  PROCEND ofp$task_end_helper;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ofp$display_status_msg_helper', EJECT ??

  PROCEDURE [XDCL, #GATE] ofp$display_status_msg_helper
    (    text: string ( * );
     VAR status: ost$status);

    VAR
      message_size: integer,
      message_size_string: string (osc$max_string_size),
      message_size_string_length: integer;

    status.normal := TRUE;

    message_size := #SIZE (text);
    IF message_size > ofc$max_display_message THEN
      message_size := ofc$max_display_message;
    IFEND;

    osp$set_mainframe_sig_lock (jmv$jcb.ijle_p^.display_message.display_message_lock);
    jmv$jcb.ijle_p^.display_message.display_message.size := message_size;
    jmv$jcb.ijle_p^.display_message.display_message.text := text (1, message_size);
    osp$clear_mainframe_sig_lock (jmv$jcb.ijle_p^.display_message.display_message_lock);

    IF #SIZE (text) > message_size THEN
      STRINGREP (message_size_string, message_size_string_length, ofc$max_display_message);
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$message_too_long,
            message_size_string (1, message_size_string_length), status);
    IFEND;

  PROCEND ofp$display_status_msg_helper;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ofp$get_display_message_helper', EJECT ??

  PROCEDURE [XDCL, #GATE] ofp$get_display_message_helper
    (    job_seq_number: jmt$system_supplied_name;
     VAR display_message: oft$display_message;
     VAR status: ost$status);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      internal_info: jmt$job_internal_information;

    status.normal := TRUE;
    jmp$get_job_internal_info (job_seq_number, internal_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    jmp$get_ijle_p (internal_info.ijl_ordinal, ijle_p);
    display_message := ijle_p^.display_message.display_message;
  PROCEND ofp$get_display_message_helper;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ofp$enable_stop_key_help', EJECT ??

  PROCEDURE [XDCL, #GATE] ofp$enable_stop_key_help;

    dpv$enable_stop_key := TRUE;

  PROCEND ofp$enable_stop_key_help;

MODEND ofm$job_message_processing;
*DECK DECK=OFM$JOB_MESSAGE_ROUTINES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operator Facility : Operator Message Management' ??
MODULE ofm$job_message_routines;

{
{  This module is placed on the following libraries
{   OSF$JOB_TEMPLATE_23D

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ife$error_codes
*copyc jmt$system_supplied_name
*copyc ofc$signal_contents
*copyc ofd$type_definition
*copyc ofe$error_codes
*copyc ofk$keypoints
*copyc oft$operator_classes
*copyc oft$operator_message
*copyc oft$display_message_info
*copyc ost$system_flag
*copyc ost$wait
*copyc tmc$signal_identifiers
?? POP ??
*copyc clp$find_current_job_synch_task
*copyc ofp$acknowledge_operator_msg_r1
*copyc ofp$get_active_operator_classes
*copyc ofp$clear_operator_message_r1
*copyc ofp$display_status_msg_helper
*copyc ofp$enable_stop_key_help
*copyc ofp$get_display_message_helper
*copyc ofp$receive_operator_resp_r1
*copyc ofp$send_operator_message_r1
*copyc ofp$task_end_helper
*copyc osp$copy_local_status_to_status
*copyc osp$set_status_abnormal
*copyc pmp$dispose_interactive_cond
*copyc pmp$establish_condition_handler
*copyc pmp$get_global_task_id
*copyc pmp$log_ascii
*copyc pmp$send_signal

?? OLDTITLE ??
?? NEWTITLE := 'ofp$acknowledge_operator_msg', EJECT ??

*copyc ofh$acknowledge_operator_msg

  PROCEDURE [XDCL, #GATE] ofp$acknowledge_operator_msg
    (    message_id: oft$operator_message_id;
         response: ost$string;
     VAR status: ost$status);

    VAR
      active_operator_classes: oft$operator_classes,
      local_status: ost$status,
      parameter_error_string: string (16),
      parameter_error_string_length: integer;

    status.normal := TRUE;
    IF (response.size > osc$max_string_size) THEN
      STRINGREP (parameter_error_string, parameter_error_string_length, osc$max_string_size);
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$response_too_long,
            parameter_error_string (1, parameter_error_string_length), status);
    ELSEIF (message_id > ofc$max_message_ordinal) THEN
      STRINGREP (parameter_error_string, parameter_error_string_length, ofc$max_message_ordinal);
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_message_id,
            parameter_error_string (1, parameter_error_string_length), status);
    ELSE
      ofp$get_active_operator_classes (active_operator_classes);
      ofp$acknowledge_operator_msg_r1 (message_id, active_operator_classes, response, local_status);
      osp$copy_local_status_to_status (local_status, status);
    IFEND;
  PROCEND ofp$acknowledge_operator_msg;

?? NEWTITLE := 'ofp$clear_operator_message', EJECT ??

*copyc ofh$clear_operator_message

  PROCEDURE [XDCL, #GATE] ofp$clear_operator_message
    (    operator_class: oft$operator_class;
     VAR status: ost$status);

    VAR
      invalid_class_string: string (16),
      invalid_class_string_size: integer,
      local_status: ost$status;

    status.normal := TRUE;
    IF NOT ((operator_class >= 0) AND (operator_class <= ofc$max_valid_operator_class)) THEN
      STRINGREP (invalid_class_string, invalid_class_string_size, ofc$max_valid_operator_class);
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_operator_class,
            invalid_class_string (1, invalid_class_string_size), status);
    ELSE
      ofp$clear_operator_message_r1 (operator_class, local_status);
      osp$copy_local_status_to_status (local_status, status);
    IFEND;

  PROCEND ofp$clear_operator_message;
?? NEWTITLE := 'ofp$display_status_message', EJECT ??
*copyc ofh$display_status_message

  PROCEDURE [XDCL, #GATE] ofp$display_status_message
    (    display_message: string ( * );
     VAR status: ost$status);

    VAR
      local_message_p: ^string ( * ),
      local_status: ost$status;

    #KEYPOINT (osk$entry, 0, ofk$display_status_message);

    status.normal := TRUE;
    local_status.normal := TRUE;

    PUSH local_message_p: [#SIZE (display_message)];
    local_message_p^ := display_message;

    ofp$display_status_msg_helper (local_message_p^, local_status);
    osp$copy_local_status_to_status (local_status, status);

    #KEYPOINT (osk$exit, 0, ofk$display_status_message);

  PROCEND ofp$display_status_message;
?? NEWTITLE := 'ofp$enable_stop_key', EJECT ??

  PROCEDURE [XDCL, #GATE] ofp$enable_stop_key;

    ofp$enable_stop_key_help;

  PROCEND ofp$enable_stop_key;
?? NEWTITLE := 'ofp$get_display_status_message', EJECT ??
*copyc ofh$get_display_status_message

  PROCEDURE [XDCL, #GATE] ofp$get_display_status_message
    (    job_seq_number: jmt$system_supplied_name;
     VAR display_message: oft$display_message;
     VAR status: ost$status);

    #INLINE ('keypoint', osk$entry, 0, ofk$get_display_status_message);
    status.normal := TRUE;
    ofp$get_display_message_helper (job_seq_number, display_message, status);
    #INLINE ('keypoint', osk$exit, 0, ofk$get_display_status_message);

  PROCEND ofp$get_display_status_message;
?? NEWTITLE := 'ofp$handle_operator_break_flag', EJECT ??

  PROCEDURE [XDCL] ofp$handle_operator_break_flag
    (    flag_id: ost$system_flag);

    VAR
      tid: pmt$task_id,
      gid: ost$global_task_id,
      signal: pmt$signal,
      status: ost$status;

    clp$find_current_job_synch_task (tid, status);
    IF status.normal THEN
      pmp$get_global_task_id (tid, gid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      signal.identifier := ofc$signal;
      signal.contents [1] := ofc$break_id;
      pmp$send_signal (gid, signal, status);
    IFEND;
  PROCEND ofp$handle_operator_break_flag;
?? NEWTITLE := 'ofp$handle_signal_processor', EJECT ??

  PROCEDURE [XDCL] ofp$handle_signal_processor
    (    originator: ost$global_task_id;
         signal: pmt$signal);

    #INLINE ('keypoint', osk$entry, 0, ofk$handle_signal_processor);
    IF signal.contents [1] = ofc$break_id THEN
      pmp$dispose_interactive_cond (ifc$pause_break);
    IFEND;
    #INLINE ('keypoint', osk$exit, 0, ofk$handle_signal_processor);

  PROCEND ofp$handle_signal_processor;
?? NEWTITLE := 'ofp$receive_operator_resp_r3', EJECT ??

*copyc ofh$receive_operator_resp_r3

  PROCEDURE [XDCL, #GATE] ofp$receive_operator_resp_r3
    (    operator_class: oft$operator_class;
     VAR response: ost$string;
     VAR status: ost$status);

    VAR
      invalid_class_string: string (16),
      invalid_class_string_size: integer,
      local_response: ost$string,
      local_status: ost$status;

    status.normal := TRUE;
    IF (operator_class >= 0) AND (operator_class <= ofc$max_valid_operator_class) THEN
      ofp$receive_operator_resp_r1 (operator_class, local_response, local_status);
      response := local_response;
      osp$copy_local_status_to_status (local_status, status);
    ELSE
      STRINGREP (invalid_class_string, invalid_class_string_size, ofc$max_valid_operator_class);
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_operator_class,
            invalid_class_string (1, invalid_class_string_size), status);
    IFEND;

  PROCEND ofp$receive_operator_resp_r3;
?? NEWTITLE := 'ofp$send_formatted_operator_msg', EJECT ??

*copyc ofh$send_formatted_operator_msg

  PROCEDURE [XDCL, #GATE] ofp$send_formatted_operator_msg
    (    formatted_message: oft$formatted_operator_message;
         operator_class: oft$operator_class;
         acknowledgement_allowed: boolean;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      index: oft$number_of_displayable_lines,
      local_status: ost$status,
      message_error_string: string (16),
      message_error_string_length: integer,
      number_of_message_lines: oft$number_of_displayable_lines;

    status.normal := TRUE;
    IF NOT ((operator_class >= 0 ) AND (operator_class <= ofc$max_valid_operator_class)) THEN
      STRINGREP (message_error_string, message_error_string_length, ofc$max_valid_operator_class);
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_operator_class,
            message_error_string (1, message_error_string_length), status);
      RETURN;
    IFEND;

    number_of_message_lines := 1;

   /search_for_end_of_lines/
    FOR index := UPPERBOUND (formatted_message) DOWNTO LOWERBOUND (formatted_message) DO
      IF formatted_message [index] <> ' ' THEN
        number_of_message_lines := index;
        EXIT /search_for_end_of_lines/;
      IFEND;
    FOREND /search_for_end_of_lines/;

    ofp$send_operator_message_r1 (formatted_message, number_of_message_lines, operator_class,
          acknowledgement_allowed, local_status);
    osp$copy_local_status_to_status (local_status, status);
    IF status.normal THEN
      IF acknowledgement_allowed THEN
        pmp$log_ascii (' Message Sent to Operator - Acknowledgement Allowed:',
          $pmt$ascii_logset [pmc$system_log],  pmc$msg_origin_program, ignore_status);
      ELSE
        pmp$log_ascii (' Message Sent to Operator - Acknowledgement Not Allowed:',
          $pmt$ascii_logset [pmc$system_log],  pmc$msg_origin_program, ignore_status);
      IFEND;
      FOR index := LOWERBOUND (formatted_message) TO number_of_message_lines DO
        pmp$log_ascii (formatted_message [index], $pmt$ascii_logset [pmc$system_log], pmc$msg_origin_program,
          ignore_status);
      FOREND;
    IFEND;

  PROCEND ofp$send_formatted_operator_msg;

?? NEWTITLE := 'ofp$send_operator_message', EJECT ??

*copyc ofh$send_operator_message

  PROCEDURE [XDCL, #GATE] ofp$send_operator_message
    (    message: oft$operator_message;
         operator_class: oft$operator_class;
         acknowledgement_allowed: boolean;
     VAR status: ost$status);

    VAR
      ch: string(1),
      formatted_message: oft$formatted_operator_message,
      fragment_length: integer,
      fragment_start: integer,
      ignore_status: ost$status,
      index: integer,
      line_number: oft$number_of_displayable_lines,
      local_status: ost$status,
      message_error_string: string (16),
      message_error_string_length: integer,
      message_size: integer;

    status.normal := TRUE;
    IF #SIZE (message) > ofc$max_operator_message_size THEN
      STRINGREP (message_error_string, message_error_string_length, ofc$max_operator_message_size);
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$message_too_long,
            message_error_string (1, message_error_string_length), status);
      RETURN;
    IFEND;

    IF NOT ((operator_class >= 0 ) AND (operator_class <= ofc$max_valid_operator_class)) THEN
      STRINGREP (message_error_string, message_error_string_length, ofc$max_valid_operator_class);
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_operator_class,
            message_error_string (1, message_error_string_length), status);
      RETURN;
    IFEND;

    { Output message line(s).  The message will be broken into fragments of at most
    { 72 characters.  Each fragment will be broken at a separator character if such
    { a character appears in the last 31 characters of the fragment.  Otherwise,
    { the fragment will be broken on the 72nd character.

    line_number := 1;
    message_size := #SIZE(message);
    fragment_start := 1;
    REPEAT
      fragment_length := 72;
      IF (fragment_length + fragment_start) > message_size THEN
        fragment_length := message_size - fragment_start + 1;
      ELSEIF message(fragment_start+fragment_length,1) = ' ' THEN
        fragment_length := fragment_length + 1;
      ELSE

        { Search for a separator character in last 31 columns.

       /find_separator/
        FOR index := fragment_length DOWNTO fragment_length-31 DO
          ch := message(fragment_start+index-1,1);
          IF (ch = ' ') OR (ch = '_') OR (ch = '.') OR (ch = '-') THEN
            fragment_length := index;
            EXIT /find_separator/;
          IFEND;
        FOREND /find_separator/;
      IFEND;

      formatted_message [line_number] (1, 4) := ' ';
      formatted_message [line_number] (5, *) := message (fragment_start, fragment_length);
      line_number := line_number + 1;
      fragment_start := fragment_start + fragment_length;
    UNTIL fragment_start >= message_size;

    FOR index := line_number to UPPERBOUND(formatted_message) DO
      formatted_message[index] := ' ';
    FOREND;

    ofp$send_operator_message_r1 (formatted_message, (line_number - 1), operator_class,
          acknowledgement_allowed, local_status);
    IF local_status.normal THEN
      IF acknowledgement_allowed THEN
        pmp$log_ascii (' Message Sent to Operator - Acknowledgement Allowed:',
              $pmt$ascii_logset [pmc$system_log],  pmc$msg_origin_program, ignore_status);
      ELSE
        pmp$log_ascii (' Message Sent to Operator - Acknowledgement Not Allowed:',
              $pmt$ascii_logset [pmc$system_log],  pmc$msg_origin_program, ignore_status);
      IFEND;
      FOR index := 1 TO (line_number - 1) DO
        pmp$log_ascii (formatted_message [index], $pmt$ascii_logset [pmc$system_log], pmc$msg_origin_program,
              ignore_status);
      FOREND;
    IFEND;
    osp$copy_local_status_to_status (local_status, status);

  PROCEND ofp$send_operator_message;

?? NEWTITLE := 'ofp$send_to_operator', EJECT ??
*copyc ofh$send_to_operator

  PROCEDURE [XDCL, #GATE] ofp$send_to_operator
    (    send_message_text: string ( * );
         operator_id: oft$operator_id;
     VAR status: ost$status);

    VAR
      message_error_string: string (16),
      message_error_string_length: integer,
      message_length: integer;

    status.normal := TRUE;
    message_length := #SIZE (send_message_text);
    IF message_length > ofc$max_send_message THEN
      ofp$send_operator_message (send_message_text (1, ofc$max_send_message), ofc$system_operator,
            TRUE, status);
    ELSE
      ofp$send_operator_message (send_message_text (1, message_length), ofc$system_operator, TRUE, status);
    IFEND;

    IF status.normal AND (message_length > ofc$max_send_message) THEN
      STRINGREP (message_error_string, message_error_string_length, ofc$max_send_message);
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$message_too_long,
            message_error_string (1, message_error_string_length), status);
      RETURN;
    IFEND;

{  If an attempt was made to send too many messages from this job, then change
{  the error code returned from ring 3 so that this procedure remains compatible
{  with its functionality prior to implementation of the Remote Operator feature.

    IF NOT status.normal THEN
      IF status.condition = ofe$max_job_operator_messages THEN
        osp$set_status_abnormal (ofc$operator_facility_id, ofe$max_job_operator_actions, ' ', status);
      ELSEIF status.condition = ofe$message_outstanding THEN
        osp$set_status_abnormal (ofc$operator_facility_id, ofe$previous_msg_not_cleared, ' ', status);
      IFEND;
    IFEND;

  PROCEND ofp$send_to_operator;
?? NEWTITLE := 'ofp$task_end', EJECT ??
*copyc ofh$task_end

  PROCEDURE [XDCL] ofp$task_end;

    ofp$task_end_helper;

  PROCEND ofp$task_end;
MODEND ofm$job_message_routines;
*DECK DECK=OFM$LOG_CRITICAL_MTR_MESSAGES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE : operator facility' ??
MODULE ofm$log_critical_mtr_messages;

{  PURPOSE:
{    This module exists to log messages sent to the critical window by
{    tasks executing in monitor mode.
{  DESIGN:
{    This procedure will read the dpv$critical_messages variable and write
{    it to the critical window until no more messages are in it.

*copyc dpv$critical_messages
*copyc dpv$critical_msgs_need_logging
*copyc lgp$add_entry_to_critical_log
*copyc ost$status

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] ofp$log_critical_mtr_messages', EJECT ??

  PROCEDURE [XDCL, #GATE] ofp$log_critical_mtr_messages;

    VAR
      ignore_status: ost$status,
      msg_index: 1 .. 16;

    dpv$critical_msgs_need_logging := FALSE;
    msg_index := 1;
    WHILE (msg_index < 16) AND (dpv$critical_messages [msg_index].size <> 0) DO
      lgp$add_entry_to_critical_log (dpv$critical_messages [msg_index].
            value (1, dpv$critical_messages [msg_index].size), ignore_status);
      dpv$critical_messages [msg_index].size := 0;
      msg_index := msg_index + 1;
    WHILEND;

  PROCEND ofp$log_critical_mtr_messages;
MODEND ofm$log_critical_mtr_messages;
*DECK DECK=OFM$OPERATOR_ACTION_MENU EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operator Facility : Operator Menu Management' ??
MODULE ofm$operator_action_menu;

{ PURPOSE:
{   This module contains the procedures involved in displaying an operator
{   action menu and obtaining an operator choice from the menu.
{
{ DESIGN:
{   The procedures in this module call the system core procedures which
{   directly manipulate the list of operator action menus.
{
{ NOTES:
{   Because the output variables for the procedures in this module are
{   passed from the user's execution ring, and because the return values
{   must be determined at ring 1, local variables are defined within
{   these procedures and passed to the ring 1 routines. The values
{   returned from ring 1 are then stored in the output variable parameters.
{   In the case of status variables, the values returned from ring 1 are
{   stored via the osp$copy_local_status_to_status procedure as per the
{   NOS/VE coding standards.
{
{   The format of a menu should conform to the following guidelines:
{
{     Line   1 : < Description of the condition. >
{     Line   2 :
{     Line   3 :    You have the following choices:
{     Line   4 :
{     Line   5 :      1 - < Action to be taken if '1' is chosen. >
{     Line   6 :      2 - < Action to be taken if '2' is chosen. >
{       .      :                 .
{       .      :                 .
{       .      :                 .
{     Line n+4 :      n - < Action to be taken if 'n' is chosen. >

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ofd$type_definition
*copyc ofe$error_codes
*copyc oft$menu_selections
*copyc oft$operator_menu_descriptor
*copyc ost$parameter_help_names
*copyc ost$status
*copyc ost$string
?? POP ??
*copyc avp$system_displays
*copyc clp$convert_integer_to_rjstring
*copyc ifp$invoke_pause_utility
*copyc ofp$add_operator_menu
*copyc ofp$clear_operator_message
*copyc ofp$delete_operator_menu
*copyc ofp$display_status_message
*copyc ofp$format_operator_message
*copyc ofp$get_active_operator_classes
*copyc ofp$get_first_operator_menu_r1
*copyc ofp$get_menu_choice
*copyc ofp$get_menu_help_text_r1
*copyc ofp$get_next_operator_menu_r1
*copyc ofp$store_menu_choice_r1
*copyc ofp$store_menu_help_text
*copyc osp$clear_wait_message
*copyc osp$copy_local_status_to_status
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$find_brief_help_message
*copyc osp$find_help_module
*copyc osp$find_parameter_prompt
*copyc osp$format_help_message
*copyc osp$get_current_display_message
*copyc osp$get_full_help_message
*copyc osp$get_parameter_help_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc osp$system_error
*copyc pmp$continue_to_cause
*copyc pmp$log_ascii
*copyc pmp$long_term_wait
?? TITLE := 'ofp$format_operator_menu', EJECT ??
*copy ofh$format_operator_menu

  PROCEDURE [XDCL, #GATE] ofp$format_operator_menu
    (    seed_name: pmt$program_name;
         parameter_names: ^ost$parameter_help_names;
         message_parameters: ^ost$message_parameters;
         number_of_choices: oft$number_of_choices;
         operator_class: oft$operator_class;
     VAR choice: oft$number_of_choices;
     VAR response_string: ost$string;
     VAR status: ost$status);

?? NEWTITLE := 'menu_condition_handler', EJECT ??

{ PURPOSE:
{   This condition handler is intended to clean up the menu which
{   may have been posted by this task in the event that a block
{   exit occurs and to repost the menu if a job recovery takes
{   place since, in that case, the menu list will have been destroyed.

    PROCEDURE menu_condition_handler
      (    condition: pmt$condition;
           condition_info_p: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

   VAR
     ignore_status: ost$status,
     wait_message_displayed: boolean;

      CASE condition.selector OF

      = ifc$interactive_condition =

        CASE condition.interactive_condition OF
        = ifc$terminate_break =
          osp$set_status_from_condition (ofc$operator_facility_id, condition, save_area, status,
                ignore_status);
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          EXIT ofp$format_operator_menu;
        = ifc$pause_break =
          /process_pause_operator_menu/
          BEGIN
            osp$get_full_help_message (seed_name, message_parameters, operator_menu_line_width,
                  help_message, status);
            IF NOT status.normal THEN
              EXIT /process_pause_operator_menu/;
            IFEND;
            ofp$format_operator_message (help_message, 1, formatted_message, help_message_line_count);
            ofp$store_menu_help_text (menu_id, formatted_message, help_message_line_count, local_status);
            IF NOT local_status.normal THEN
              osp$copy_local_status_to_status (local_status, status);
              EXIT /process_pause_operator_menu/;
            IFEND;

            FOR i:= 1 to help_message_line_count DO
              pmp$log_ascii (formatted_message [i], $pmt$ascii_logset [pmc$system_log],
                   pmc$msg_origin_program, ignore_status);
            FOREND;
            choice_made := FALSE;
          END /process_pause_operator_menu/;
          ifp$invoke_pause_utility (ignore_status);
        = ifc$job_reconnect =
          ifp$invoke_pause_utility (ignore_status);
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;

      = pmc$block_exit_processing =

        ofp$delete_operator_menu (menu_id, condition_status);
        wait_message_displayed := TRUE;
        osp$clear_wait_message (original_message, wait_message_displayed);

      = pmc$user_defined_condition =

        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          ofp$format_operator_menu (seed_name, parameter_names, message_parameters, number_of_choices,
                operator_class, choice, response_string, status);
          EXIT ofp$format_operator_menu;
        IFEND;
      ELSE
      CASEND;
    PROCEND menu_condition_handler;
?? OLDTITLE, EJECT ??

    CONST
      five_minutes = 300000,
      operator_menu_line_width = 80,
      thirty_seconds = 30000;

    VAR
      choice_made: boolean,
      formatted_message: oft$formatted_operator_message,
      help_message: ost$status_message,
      help_message_line_count: oft$number_of_displayable_lines,
      i: oft$number_of_displayable_lines,
      ignore_status: ost$status,
      invalid_class_string: string (16),
      local_choice: oft$number_of_choices,
      local_response_string: ost$string,
      local_status: ost$status,
      log_string: string (80),
      menu_id: oft$menu_id,
      menu_selections: oft$menu_selections,
      number_of_displayable_lines: oft$number_of_displayable_lines,
      operator_response: ost$string,
      original_message: oft$display_message,
      string_size: integer,
      wait_message_displayed: boolean;

    status.normal := TRUE;

    IF NOT ((operator_class = ofc$removable_media_operator) OR (operator_class = ofc$system_operator)) THEN
      STRINGREP (invalid_class_string, string_size, ofc$max_valid_operator_class);
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_operator_class,
            invalid_class_string (1, string_size) , status);
      RETURN;
    IFEND;

    ofp$get_operator_menu (seed_name, parameter_names, message_parameters, operator_menu_line_width,
          menu_selections, number_of_displayable_lines, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF number_of_displayable_lines > 0 THEN
      osp$get_current_display_message (original_message);
      #SPOIL (original_message);

      FOR i:= 1 to number_of_displayable_lines DO
        pmp$log_ascii (menu_selections [i], $pmt$ascii_logset [pmc$system_log], pmc$msg_origin_program,
           ignore_status);
      FOREND;

    /process_operator_menu/
      BEGIN
        osp$establish_condition_handler (^menu_condition_handler, TRUE);

        ofp$display_status_message ('Waiting For Operator Action', local_status);
        ofp$add_operator_menu (^menu_selections, number_of_displayable_lines, number_of_choices,
              operator_class, menu_id, local_status);
        IF NOT local_status.normal THEN
          osp$copy_local_status_to_status (local_status, status);
          EXIT /process_operator_menu/;
        IFEND;

        REPEAT
          pmp$long_term_wait (five_minutes, thirty_seconds);
          ofp$get_menu_choice (menu_id, choice_made, local_choice, local_response_string, local_status);
          IF NOT local_status.normal THEN
            osp$system_error ('Posted operator action menu missing from menu list.', NIL);
          IFEND;

          IF choice_made AND (local_response_string.value (1, 1) = '?') THEN
            IF local_choice < ofc$max_menu_lines THEN
              STRINGREP (log_string, string_size, ' Operator Response: ', local_choice, ' ',
                local_response_string.value (1, local_response_string.size));
              pmp$log_ascii (log_string (1, string_size), $pmt$ascii_logset [pmc$system_log],
                pmc$msg_origin_program, ignore_status);
              IF parameter_names <> NIL THEN
                osp$get_parameter_help_message (seed_name, parameter_names^ [local_choice],
                      message_parameters, operator_menu_line_width, help_message, status);
                IF NOT status.normal THEN
                  EXIT /process_operator_menu/;
                IFEND;
              IFEND;
            ELSE { full help was requested }
              STRINGREP (log_string, string_size, ' Operator Response: ', ' ',
                local_response_string.value (1, local_response_string.size));
              pmp$log_ascii (log_string (1, string_size), $pmt$ascii_logset [pmc$system_log],
                pmc$msg_origin_program, ignore_status);
              osp$get_full_help_message (seed_name, message_parameters, operator_menu_line_width,
                    help_message, status);
              IF NOT status.normal THEN
                EXIT /process_operator_menu/;
              IFEND;
            IFEND;

            ofp$format_operator_message (help_message, 1, formatted_message, help_message_line_count);
            ofp$store_menu_help_text (menu_id, formatted_message, help_message_line_count, local_status);
            IF NOT local_status.normal THEN
              osp$copy_local_status_to_status (local_status, status);
              EXIT /process_operator_menu/;
            IFEND;

            FOR i:= 1 to help_message_line_count DO
              pmp$log_ascii (formatted_message [i], $pmt$ascii_logset [pmc$system_log],
                 pmc$msg_origin_program, ignore_status);
            FOREND;
            choice_made := FALSE;
          IFEND;

        UNTIL choice_made;

        choice := local_choice;
        response_string := local_response_string;
        STRINGREP (log_string, string_size, ' Operator Response: ', local_choice, ' ',
          local_response_string.value (1, local_response_string.size));
        pmp$log_ascii (log_string (1, string_size), $pmt$ascii_logset [pmc$system_log],
          pmc$msg_origin_program, ignore_status);
      END /process_operator_menu/;

      osp$disestablish_cond_handler;
      wait_message_displayed := TRUE;
      osp$clear_wait_message (original_message, wait_message_displayed);
    IFEND;

  PROCEND ofp$format_operator_menu;
?? TITLE := 'ofp$get_first_operator_menu', EJECT ??

*copyc ofh$get_first_operator_menu

  PROCEDURE [XDCL, #GATE] ofp$get_first_operator_menu
    (VAR menu_descriptor: oft$operator_menu_descriptor;
     VAR status: ost$status);

    VAR
      active_operator_classes: oft$operator_classes,
      local_menu_descriptor: oft$operator_menu_descriptor,
      local_status: ost$status;

    status.normal := TRUE;
    IF avp$system_displays () THEN
      active_operator_classes := -$oft$operator_classes [];
    ELSE
      ofp$get_active_operator_classes (active_operator_classes);
      IF active_operator_classes = $oft$operator_classes [] THEN
        osp$set_status_abnormal (ofc$operator_facility_id, ofe$no_menus_available, ' ', status);
        RETURN;
      IFEND;
    IFEND;

    ofp$get_first_operator_menu_r1 (active_operator_classes, local_menu_descriptor, local_status);
    IF local_status.normal THEN
      menu_descriptor := local_menu_descriptor;
    IFEND;

    osp$copy_local_status_to_status (local_status, status);

  PROCEND ofp$get_first_operator_menu;
?? TITLE := 'ofp$get_menu_help_text', EJECT ??

*copyc ofh$get_menu_help_text

  PROCEDURE [XDCL, #GATE] ofp$get_menu_help_text
    (    menu_id: oft$menu_id;
         global_task_id: ost$global_task_id;
         help_text_p: {input, output} ^oft$menu_selections;
     VAR help_text_found: boolean;
     VAR help_text_line_count: oft$number_of_displayable_lines;
     VAR status: ost$status);

    VAR
      local_help_text_p: ^oft$menu_selections,
      local_status: ost$status;

    status.normal := TRUE;

    PUSH local_help_text_p;

    ofp$get_menu_help_text_r1 (menu_id, global_task_id, local_help_text_p, help_text_found,
          help_text_line_count, local_status);
    IF local_status.normal THEN
      IF help_text_found AND (help_text_p <> NIL) THEN
        help_text_p^ := local_help_text_p^;
      IFEND;
    ELSE
      osp$copy_local_status_to_status (local_status, status);
    IFEND;

  PROCEND ofp$get_menu_help_text;
?? TITLE := 'ofp$get_next_operator_menu', EJECT ??

*copyc ofh$get_next_operator_menu

  PROCEDURE [XDCL, #GATE] ofp$get_next_operator_menu
    (    current_menu_id: oft$menu_id;
     VAR menu_descriptor: oft$operator_menu_descriptor;
     VAR status: ost$status);

    VAR
      active_operator_classes: oft$operator_classes,
      local_menu_descriptor: oft$operator_menu_descriptor,
      local_status: ost$status;

    status.normal := TRUE;
    IF avp$system_displays () THEN
      active_operator_classes := -$oft$operator_classes [];
    ELSE
      ofp$get_active_operator_classes (active_operator_classes);
      IF active_operator_classes = $oft$operator_classes [] THEN
        osp$set_status_abnormal (ofc$operator_facility_id, ofe$no_menus_available, ' ', status);
        RETURN;
      IFEND;
    IFEND;

    ofp$get_next_operator_menu_r1 (current_menu_id, active_operator_classes, local_menu_descriptor,
          local_status);
    IF local_status.normal THEN
      menu_descriptor := local_menu_descriptor;
    IFEND;

    osp$copy_local_status_to_status (local_status, status);

  PROCEND ofp$get_next_operator_menu;
?? TITLE := 'ofp$get_operator_menu', EJECT ??
*copy ofh$get_operator_menu

  PROCEDURE ofp$get_operator_menu
    (    seed_name: pmt$program_name;
         choice_names: ^ost$parameter_help_names;
         message_parameters: ^ost$message_parameters;
         max_message_line: ost$max_status_message_line;
     VAR operator_message: oft$formatted_operator_message;
     VAR line_count: oft$number_of_displayable_lines;
     VAR status: ost$status);

    CONST
      choice_number_size = 2;

    VAR
      choice: oft$number_of_choices,
      help_module: ^ost$help_module,
      message: ost$status_message,
      message_template: ^ost$message_template,
      natural_language: ost$natural_language,
      online_manual_name: ost$online_manual_name,
      starting_line: oft$number_of_displayable_lines,
      substitute_choice_numbers: boolean;

    osp$find_help_module (seed_name, help_module, online_manual_name, natural_language, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$find_brief_help_message (help_module, message_template, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF message_template = NIL THEN
      osp$set_status_abnormal ('OF', ofe$menu_definition_error, seed_name, status);
      RETURN;
    IFEND;

    osp$format_help_message (message_template, message_parameters, max_message_line, message, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ofp$format_operator_message (message, 1, operator_message, line_count);

    IF message_parameters^ [1] = NIL THEN
      PUSH message_parameters^ [1]: [choice_number_size];
      substitute_choice_numbers := TRUE;
    ELSE
      substitute_choice_numbers := FALSE;
    IFEND;

    FOR choice := 1 TO UPPERBOUND (choice_names^) DO
      IF substitute_choice_numbers THEN
        clp$convert_integer_to_rjstring (choice, 10, FALSE, ' ', message_parameters^ [1]^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      osp$find_parameter_prompt (help_module, choice_names^ [choice], message_template, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF message_template = NIL THEN
        osp$set_status_abnormal ('OF', ofe$menu_definition_error, seed_name, status);
        RETURN;
      IFEND;

      osp$format_help_message (message_template, message_parameters, max_message_line, message, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      starting_line := line_count + 1;
      ofp$format_operator_message (message, starting_line, operator_message, line_count);

    FOREND;

  PROCEND ofp$get_operator_menu;
?? TITLE := 'ofp$store_menu_choice', EJECT ??

*copyc ofh$store_menu_choice

  PROCEDURE [XDCL, #GATE] ofp$store_menu_choice
    (    menu_id: oft$menu_id;
         choice: oft$number_of_choices;
         response_string: ost$string;
     VAR status: ost$status);

    VAR
      active_operator_classes: oft$operator_classes,
      local_status: ost$status;

    status.normal := TRUE;
    ofp$get_active_operator_classes (active_operator_classes);
    IF active_operator_classes = $oft$operator_classes [] THEN
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_menu_id, ' ', status);
      RETURN;
    IFEND;

    ofp$store_menu_choice_r1 (menu_id, active_operator_classes, choice, response_string, local_status);
    osp$copy_local_status_to_status (local_status, status);

  PROCEND ofp$store_menu_choice;
MODEND ofm$operator_action_menu;
*DECK DECK=OFM$OPERATOR_ACTION_MENU_R1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operator Facility : Operator Menu Management' ??
MODULE ofm$operator_action_menu_r1;

{ PURPOSE:
{   This module contains the procedures to directly manipulate the list
{   of operator action menus for all tasks in the system.
{
{ DESIGN:
{   This is a system core module since the menu list is shared by all jobs
{   and must be interlocked at times. Each of its procedures locks the menu
{   list and then operates upon it by adding/deleting/modifying/obtaining
{   information from an entry as appropriate. The list is then unlocked
{   upon exit from the procedure.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmt$user_supplied_name
*copyc ofd$type_definition
*copyc ofe$error_codes
*copyc oft$menu_id
*copyc oft$operator_classes
*copyc oft$operator_menu_descriptor
*copyc ost$signature_lock
*copyc ost$status
?? POP ??
*copyc osp$clear_mainframe_sig_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_job_names
*copyc pmp$ready_task
*copyc osv$mainframe_pageable_heap
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    ofv$menu_list_lock: [oss$mainframe_pageable, STATIC] ost$signature_lock := [0],
    ofv$menu_list_p: [oss$mainframe_pageable, STATIC] ^oft$operator_menu_descriptor := NIL;

?? TITLE := 'ofp$add_operator_menu', EJECT ??

*copyc ofh$add_operator_menu

  PROCEDURE [XDCL, #GATE] ofp$add_operator_menu
    (    menu_selections_p: ^oft$menu_selections;
         number_of_displayable_lines: oft$number_of_displayable_lines,
         number_of_choices: oft$number_of_choices;
         operator_class: oft$operator_class;
     VAR menu_id: oft$menu_id;
     VAR status: ost$status);

    VAR
      global_task_id: ost$global_task_id,
      menu_descriptor_p: ^oft$operator_menu_descriptor,
      menu_p: ^oft$operator_menu_descriptor,
      next_menu_id: [oss$mainframe_pageable, STATIC] oft$menu_id := 0,
      system_name: jmt$system_supplied_name,
      user_name: jmt$user_supplied_name;

    status.normal := TRUE;
    pmp$get_job_names (user_name, system_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_executing_task_gtid (global_task_id);

{ Allocate space for the new menu, and fill in those fields in the descriptor
{ which can be stored without protection from the menu locking mechanism.

    ALLOCATE menu_p IN osv$mainframe_pageable_heap^;
    menu_p^.source_task := global_task_id;
    menu_p^.job_name := system_name;
    menu_p^.menu_class := operator_class;
    menu_p^.number_of_displayable_lines := number_of_displayable_lines;
    menu_p^.number_of_choices := number_of_choices;
    menu_p^.choice_made := FALSE;
    menu_p^.menu_text := menu_selections_p^;
    menu_p^.help_text_p := NIL;
    menu_p^.help_text_line_count := 0;

    osp$set_mainframe_sig_lock (ofv$menu_list_lock);

{ Calculate a menu identifier for the new menu, and ensure that it is unique.

    menu_descriptor_p := ofv$menu_list_p;
    next_menu_id := (next_menu_id + 1) MOD ofc$max_menu_id;
    WHILE menu_descriptor_p <> NIL DO
      IF menu_descriptor_p^.menu_id <> next_menu_id THEN
        menu_descriptor_p := menu_descriptor_p^.next_descriptor_p;
      ELSE

{ The calculated menu_id is not unique. Generate a new menu_id and redo the
{ check for uniqueness.

        next_menu_id := (next_menu_id + 1) MOD ofc$max_menu_id;
        menu_descriptor_p := ofv$menu_list_p;
      IFEND;
    WHILEND;

{ Link the new menu into the list of menus, and store the fields in the
{ descriptor which require protection from the locking mechanism. The menu
{ list is a push down stack linked to the front.

    menu_p^.menu_id := next_menu_id;
    menu_p^.next_descriptor_p := ofv$menu_list_p;
    ofv$menu_list_p := menu_p;
    menu_id := menu_p^.menu_id;

    osp$clear_mainframe_sig_lock (ofv$menu_list_lock);

  PROCEND ofp$add_operator_menu;
?? TITLE := 'ofp$delete_operator_menu', EJECT ??

*copyc ofh$delete_operator_menu

  PROCEDURE [XDCL, #GATE] ofp$delete_operator_menu
    (    menu_id: oft$menu_id;
     VAR status: ost$status);

    VAR
      global_task_id: ost$global_task_id,
      menu_p: ^oft$operator_menu_descriptor,
      menu_previous_p: ^oft$operator_menu_descriptor;

    status.normal := TRUE;
    pmp$get_executing_task_gtid (global_task_id);
    osp$set_mainframe_sig_lock (ofv$menu_list_lock);

    menu_p := ofv$menu_list_p;
    menu_previous_p := NIL;

  /find_matching_menu_item/
    WHILE menu_p <> NIL DO
      IF (menu_p^.menu_id = menu_id) AND (menu_p^.source_task = global_task_id) THEN
        IF menu_previous_p = NIL THEN
          ofv$menu_list_p := menu_p^.next_descriptor_p;
        ELSE
          menu_previous_p^.next_descriptor_p := menu_p^.next_descriptor_p;
        IFEND;
        EXIT /find_matching_menu_item/;
      IFEND;

      menu_previous_p := menu_p;
      menu_p := menu_p^.next_descriptor_p;
    WHILEND /find_matching_menu_item/;

    osp$clear_mainframe_sig_lock (ofv$menu_list_lock);

    IF menu_p = NIL THEN
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_menu_id, ' ', status);
    ELSE
      FREE menu_p IN osv$mainframe_pageable_heap^;
    IFEND;

  PROCEND ofp$delete_operator_menu;
?? TITLE := 'ofp$get_first_operator_menu_r1', EJECT ??

*copyc ofh$get_first_operator_menu_r1

  PROCEDURE [XDCL, #GATE] ofp$get_first_operator_menu_r1
    (    active_operator_classes: oft$operator_classes;
     VAR menu_descriptor: oft$operator_menu_descriptor;
     VAR status: ost$status);

    VAR
      menu_p: ^oft$operator_menu_descriptor;

    status.normal := TRUE;
    IF ofv$menu_list_p = NIL THEN
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$no_menus_available, ' ', status);
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (ofv$menu_list_lock);
    menu_p := ofv$menu_list_p;

  /find_first_available_menu/
    WHILE menu_p <> NIL DO
      IF ((menu_p^.menu_class IN active_operator_classes) AND NOT (menu_p^.choice_made)) THEN
        menu_descriptor := menu_p^;
        EXIT /find_first_available_menu/;
      IFEND;

      menu_p := menu_p^.next_descriptor_p;
    WHILEND /find_first_available_menu/;

    osp$clear_mainframe_sig_lock (ofv$menu_list_lock);
    IF menu_p = NIL THEN
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$no_menus_available, ' ', status);
    IFEND;

  PROCEND ofp$get_first_operator_menu_r1;
?? TITLE := 'ofp$get_menu_choice', EJECT ??

*copyc ofh$get_menu_choice

  PROCEDURE [XDCL, #GATE] ofp$get_menu_choice
    (    menu_id: oft$menu_id;
     VAR choice_made: boolean;
     VAR choice: oft$number_of_choices;
     VAR response_string: ost$string;
     VAR status: ost$status);

    VAR
      global_task_id: ost$global_task_id,
      menu_p: ^oft$operator_menu_descriptor,
      menu_previous_p: ^oft$operator_menu_descriptor;

    status.normal := TRUE;
    pmp$get_executing_task_gtid (global_task_id);
    osp$set_mainframe_sig_lock (ofv$menu_list_lock);

    menu_p := ofv$menu_list_p;
    menu_previous_p := NIL;

  /find_matching_menu_item/
    WHILE menu_p <> NIL DO
      IF (menu_p^.menu_id = menu_id) AND (menu_p^.source_task = global_task_id) THEN
        choice_made := menu_p^.choice_made;
        IF NOT choice_made THEN
          EXIT /find_matching_menu_item/;
        IFEND;

        choice := menu_p^.choice;
        response_string := menu_p^.response_string;
        IF response_string.value (1,1) = '?' THEN

{ Help was requested so the menu descriptor should be kept around but left in a state that allows another
{ choice to be made.

          menu_p^.choice_made := FALSE;
          menu_p^.response_string.value (1, *) := ' ';
        ELSE { help was not requested so menu can be deleted }
          IF menu_previous_p = NIL THEN
            ofv$menu_list_p := menu_p^.next_descriptor_p;
          ELSE
            menu_previous_p^.next_descriptor_p := menu_p^.next_descriptor_p;
          IFEND;
        IFEND;
        EXIT /find_matching_menu_item/;
      IFEND;

      menu_previous_p := menu_p;
      menu_p := menu_p^.next_descriptor_p;
    WHILEND /find_matching_menu_item/;

    osp$clear_mainframe_sig_lock (ofv$menu_list_lock);

    IF menu_p = NIL THEN
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_menu_id, ' ', status);
    ELSEIF menu_p^.choice_made THEN
      FREE menu_p IN osv$mainframe_pageable_heap^;
    IFEND;

  PROCEND ofp$get_menu_choice;
?? TITLE := 'ofp$get_menu_help_text_r1', EJECT ??

*copyc ofh$get_menu_help_text_r1

  PROCEDURE [XDCL, #GATE] ofp$get_menu_help_text_r1
    (    menu_id: oft$menu_id;
         global_task_id: ost$global_task_id;
         help_text_p: {input, output} ^oft$menu_selections;
     VAR help_text_found: boolean;
     VAR help_text_line_count: oft$number_of_displayable_lines;
     VAR status: ost$status);

    VAR
      menu_p: ^oft$operator_menu_descriptor;

    status.normal := TRUE;
    IF ofv$menu_list_p = NIL THEN
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_menu_id, ' ', status);
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (ofv$menu_list_lock);

    help_text_found := FALSE;
    menu_p := ofv$menu_list_p;

  /find_matching_menu_item/
    BEGIN
      WHILE menu_p <> NIL DO
        IF (menu_p^.menu_id = menu_id) AND (menu_p^.source_task = global_task_id) THEN
          IF menu_p^.help_text_p <> NIL THEN
            help_text_found := TRUE;
            help_text_p^ := menu_p^.help_text_p^;
            help_text_line_count := menu_p^.help_text_line_count;
          IFEND;
          EXIT /find_matching_menu_item/;
        ELSE
          menu_p := menu_p^.next_descriptor_p;
        IFEND;
      WHILEND;

      osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_menu_id, ' ', status);
    END /find_matching_menu_item/;

    osp$clear_mainframe_sig_lock (ofv$menu_list_lock);

  PROCEND ofp$get_menu_help_text_r1;
?? TITLE := 'ofp$get_next_operator_menu_r1', EJECT ??

*copyc ofh$get_next_operator_menu_r1

  PROCEDURE [XDCL, #GATE] ofp$get_next_operator_menu_r1
    (    current_menu_id: oft$menu_id;
         active_operator_classes: oft$operator_classes;
     VAR menu_descriptor: oft$operator_menu_descriptor;
     VAR status: ost$status);

    VAR
      menu_current_p: ^oft$operator_menu_descriptor,
      menu_next_p: ^oft$operator_menu_descriptor;

    status.normal := TRUE;
    IF ofv$menu_list_p = NIL THEN
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$no_menus_available, ' ', status);
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (ofv$menu_list_lock);

  /get_next_available_menu/
    BEGIN
      menu_current_p := ofv$menu_list_p;

    /search_for_current/
      WHILE menu_current_p <> NIL DO
        IF menu_current_p^.menu_id = current_menu_id THEN
          EXIT /search_for_current/;
        IFEND;
        menu_current_p := menu_current_p^.next_descriptor_p;
      WHILEND /search_for_current/;

{ If the current menu specified by the caller was found, then begin the search
{ for the next available menu from that point. If the current menu was not
{ located, then assume that another operator has responded to the "missing"
{ menu, and search the list of menus for the first one the caller is validated
{ to display.

      IF menu_current_p <> NIL THEN
        menu_next_p := menu_current_p^.next_descriptor_p;
      ELSE
        menu_next_p := ofv$menu_list_p;
        WHILE menu_next_p <> NIL DO
          IF ((menu_next_p^.menu_class IN active_operator_classes) AND NOT (menu_next_p^.choice_made)) THEN
            menu_descriptor := menu_next_p^;
            EXIT /get_next_available_menu/;
          IFEND;

          menu_next_p := menu_next_p^.next_descriptor_p;
        WHILEND;

        osp$set_status_abnormal (ofc$operator_facility_id, ofe$no_menus_available, ' ', status);
        EXIT /get_next_available_menu/;
      IFEND;

      WHILE TRUE DO
        IF menu_next_p = NIL THEN
          menu_next_p := ofv$menu_list_p;
        IFEND;

        IF menu_next_p = menu_current_p THEN

{ If the current menu is the only one in the menu list which the caller
{ may display and a choice has been made for that menu, then return an
{ error status indicating that no menus are available. This situation
{ can arise if the caller has successfully made a choice for the menu
{ and then attempts to get the next available one before the task which
{ sent the original menu gets the CPU back and acts to have it removed
{ from the list.

          IF menu_next_p^.choice_made THEN
            osp$set_status_abnormal (ofc$operator_facility_id, ofe$no_menus_available, ' ', status);
          ELSE
            osp$set_status_abnormal (ofc$operator_facility_id, ofe$one_menu_available, ' ', status);
          IFEND;

          EXIT /get_next_available_menu/;
        IFEND;

        IF ((menu_next_p^.menu_class IN active_operator_classes) AND NOT (menu_next_p^.choice_made)) THEN
          menu_descriptor := menu_next_p^;
          EXIT /get_next_available_menu/;
        IFEND;

        menu_next_p := menu_next_p^.next_descriptor_p;
      WHILEND;
    END /get_next_available_menu/;

    osp$clear_mainframe_sig_lock (ofv$menu_list_lock);

  PROCEND ofp$get_next_operator_menu_r1;
?? TITLE := 'ofp$job_operator_menus_active', EJECT ??

*copyc ofh$job_operator_menus_active

  FUNCTION [XDCL, UNSAFE] ofp$job_operator_menus_active
    (    job_name: jmt$system_supplied_name): boolean;

    VAR
      menu_p: ^oft$operator_menu_descriptor;

    ofp$job_operator_menus_active := FALSE;
    IF ofv$menu_list_p = NIL THEN
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (ofv$menu_list_lock);
    menu_p := ofv$menu_list_p;

  /search_for_active_menu/
    WHILE menu_p <> NIL DO
      IF ((menu_p^.job_name = job_name) AND NOT (menu_p^.choice_made)) THEN
        ofp$job_operator_menus_active := TRUE;
        EXIT /search_for_active_menu/;
      IFEND;

      menu_p := menu_p^.next_descriptor_p;
    WHILEND /search_for_active_menu/;

    osp$clear_mainframe_sig_lock (ofv$menu_list_lock);

  FUNCEND ofp$job_operator_menus_active;
?? TITLE := 'ofp$store_menu_choice_r1', EJECT ??

*copyc ofh$store_menu_choice_r1

  PROCEDURE [XDCL, #GATE] ofp$store_menu_choice_r1
    (    menu_id: oft$menu_id;
         active_operator_classes: oft$operator_classes;
         choice: oft$number_of_choices;
         response_string: ost$string;
     VAR status: ost$status);

    VAR
      menu_p: ^oft$operator_menu_descriptor;

    status.normal := TRUE;
    IF ofv$menu_list_p = NIL THEN
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_menu_id, ' ', status);
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (ofv$menu_list_lock);

    menu_p := ofv$menu_list_p;

  /find_matching_menu_item/
    BEGIN
      WHILE menu_p <> NIL DO
        IF ((menu_p^.menu_id = menu_id) AND NOT menu_p^.choice_made) THEN
          IF menu_p^.menu_class IN active_operator_classes THEN
            menu_p^.choice := choice;
            menu_p^.response_string := response_string;
            menu_p^.choice_made := TRUE;
            pmp$ready_task (menu_p^.source_task, status);
            EXIT /find_matching_menu_item/;
          ELSE
            osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_menu_id, ' ', status);
            EXIT /find_matching_menu_item/;
          IFEND;
        ELSE
          menu_p := menu_p^.next_descriptor_p;
        IFEND;
      WHILEND;

      osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_menu_id, ' ', status);
      EXIT /find_matching_menu_item/;
    END /find_matching_menu_item/;

    osp$clear_mainframe_sig_lock (ofv$menu_list_lock);

  PROCEND ofp$store_menu_choice_r1;
?? TITLE := 'ofp$store_menu_help_text', EJECT ??

*copyc ofh$store_menu_help_text

  PROCEDURE [XDCL, #GATE] ofp$store_menu_help_text
    (    menu_id: oft$menu_id;
         help_text: oft$menu_selections;
         help_text_line_count: oft$number_of_displayable_lines;
     VAR status: ost$status);

    CONST
      no_help_text = ' No help is available';

    VAR
      global_task_id: ost$global_task_id,
      menu_p: ^oft$operator_menu_descriptor;

    status.normal := TRUE;
    IF ofv$menu_list_p = NIL THEN
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_menu_id, ' ', status);
      RETURN;
    IFEND;

    pmp$get_executing_task_gtid (global_task_id);
    osp$set_mainframe_sig_lock (ofv$menu_list_lock);

    menu_p := ofv$menu_list_p;

  /find_matching_menu_item/
    BEGIN
      WHILE menu_p <> NIL DO
        IF (menu_p^.menu_id = menu_id) AND (menu_p^.source_task = global_task_id) THEN
          ALLOCATE menu_p^.help_text_p IN osv$mainframe_pageable_heap^;
          menu_p^.help_text_p^ := help_text;
          IF help_text_line_count = 0 THEN
            menu_p^.help_text_p^ [1] := no_help_text;
            menu_p^.help_text_line_count := 1;
          ELSE
            menu_p^.help_text_line_count := help_text_line_count;
          IFEND;
          EXIT /find_matching_menu_item/;
        ELSE
          menu_p := menu_p^.next_descriptor_p;
        IFEND;
      WHILEND;

      osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_menu_id, ' ', status);
    END /find_matching_menu_item/;

    osp$clear_mainframe_sig_lock (ofv$menu_list_lock);

  PROCEND ofp$store_menu_help_text;
MODEND ofm$operator_action_menu_r1;
*DECK DECK=OFM$OPERATOR_MESSAGE_PROCEDURES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operator Facility : Operator Message Processing' ??
MODULE ofm$operator_message_procedures;

{ PURPOSE:
{   This module contains (2,D,D) procedures for operator message
{   processing.

?? TITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ife$error_codes
*copyc ofd$type_definition
*copyc ofe$error_codes
*copyc oft$operator_classes
*copyc oft$operator_message_descriptor
*copyc ost$status
*copyc ost$wait
?? POP ??
*copyc clp$change_variable
*copyc clp$evaluate_parameters
*copyc clp$get_type_information
*copyc clp$get_value
*copyc clp$get_variable
*copyc clp$get_work_area
*copyc clp$put_job_command_response
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc clp$write_variable
*copyc ifp$invoke_pause_utility
*copyc ofp$acknowledge_operator_msg
*copyc ofp$clear_operator_message
*copyc ofp$receive_operator_resp_r3
*copyc ofp$send_operator_message
*copyc ofp$send_to_operator
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$establish_condition_handler
*copyc pmp$long_term_wait
?? TITLE := 'clp$request_op_action_command', EJECT ??

{ The following procedure has been moved from clm$request_op_action_command and
{ is being retained only for compatibility with previous releases of NOS/VE.

  PROCEDURE [XDCL] clp$request_op_action_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT request_op_action_pdt (
{   message, m : STRING 0 .. ofc$max_send_message = $REQUIRED
{   reply, r : VAR OF STRING = $OPTIONAL
{   STATUS)

?? PUSH (LISTEXT := ON) ??

    VAR
      request_op_action_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^request_op_action_pdt_names, ^request_op_action_pdt_params];

    VAR
      request_op_action_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
            clt$parameter_name_descriptor := [['MESSAGE', 1], ['M', 1], ['REPLY', 2], ['R', 2],
            ['STATUS', 3]];

    VAR
      request_op_action_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
            clt$parameter_descriptor := [

{ MESSAGE M }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$string_value, 0, ofc$max_send_message]],

{ REPLY R }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$string_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    PROCEDURE receive_from_operator_reply
      (    wait: ost$wait;
       VAR text: ost$string;
       VAR operator_id: oft$operator_id;
       VAR reply_received: boolean;
       VAR status: ost$status);

      VAR
        estab_handler: pmt$established_handler,
        condition: pmt$condition;

      PROCEDURE handle_break
        (    cond: pmt$condition;
             cd_p: ^pmt$condition_information;
             sa_p: ^ost$stack_frame_save_area;
         VAR proc_status: ost$status);

        VAR
          local_status: ost$status;

        IF cond.interactive_condition = ifc$pause_break THEN

          { start pause utility - pause break

          ifp$invoke_pause_utility (local_status);

          osp$set_status_abnormal (ofc$operator_facility_id, ife$pause_break_received, '', status);

        ELSEIF cond.interactive_condition = ifc$terminate_break THEN
          ofp$clear_operator_message (ofc$system_operator, local_status);

          osp$set_status_abnormal (ofc$operator_facility_id, ife$terminate_break_received, '', status);
          pmp$continue_to_cause (pmc$execute_standard_procedure, proc_status);
          EXIT receive_from_operator_reply;
        IFEND;

      PROCEND handle_break;

      status.normal := TRUE;
      condition.selector := pmc$condition_combination;
      condition.combination := $pmt$condition_combination [ifc$interactive_condition];
      pmp$establish_condition_handler (condition, ^handle_break, ^estab_handler, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


      REPEAT
        ofp$receive_from_operator (wait, text, operator_id, status);
      UNTIL status.normal OR NOT (status.condition = ife$pause_break_received);

      IF status.normal THEN
        reply_received := TRUE;
      IFEND;

    PROCEND receive_from_operator_reply;

    CONST
      ofc$system_operator_id = 'SYSTEM_OPERATOR                ';

    VAR
      ignore_operator_id: oft$operator_id,
      reply_area_p: ^SEQ (ost$string),
      reply_variable_p: ^array [1 .. * ] of cell,
      reply_response_p: ^string ( * ),
      reply_received: boolean,
      reply_p: ^ost$string,
      value_reply: clt$value,
      value_send: clt$value;

    status.normal := TRUE;
    reply_received := FALSE;

    clp$scan_parameter_list (parameter_list, request_op_action_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('MESSAGE', 1, 1, clc$low, value_send, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

      clp$get_value ('REPLY', 1, 1, clc$low, value_reply, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      PUSH reply_area_p;

      ofp$send_to_operator (value_send.str.value (1, value_send.str.size), ofc$system_operator_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    REPEAT
      #SPOIL (reply_received);
      status.normal := TRUE;

      RESET reply_area_p;
      NEXT reply_p IN reply_area_p;

      receive_from_operator_reply (osc$wait, reply_p^, ignore_operator_id, reply_received, status);
      IF NOT status.normal AND (status.condition <> ofe$message_not_available) THEN
        RETURN;
      IFEND;

    UNTIL reply_received;

    IF value_reply.kind = clc$variable_reference THEN

      RESET reply_area_p;
      NEXT reply_variable_p: [1 .. UPPERBOUND (value_reply.var_ref.value.string_value^)] IN reply_area_p;
      IF reply_p^.size > value_reply.var_ref.value.max_string_size THEN
        reply_p^.size := value_reply.var_ref.value.max_string_size;
      IFEND;
      value_reply.var_ref.value.string_value := reply_variable_p;
      clp$write_variable (value_reply.var_ref.reference.value (1, value_reply.var_ref.reference.size),
            value_reply.var_ref.value, status);

    ELSE

      PUSH reply_response_p: [1 + reply_p^.size];
      reply_response_p^ (1) := ' ';
      reply_response_p^ (2, reply_p^.size) := reply_p^.value (1, reply_p^.size);
      clp$put_job_command_response (reply_response_p^, status);

    IFEND;

  PROCEND clp$request_op_action_command;

?? TITLE := 'ofp$acknowledge_oper_msg_cmd', EJECT ??

{ PURPOSE:
{ The purpose of this procedure is to send an acknowledgement to an operator
{ message.

  PROCEDURE [XDCL, #GATE] ofp$acknowledge_oper_msg_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$ackom) acknowledge_operator_message, ackom (
{    message, m: integer 0 .. 0ffff(16) = $REQUIRED
{    response, r: string 1 .. 256 = $OPTIONAL
{    STATUS)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 11, 11, 55, 19, 328],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'OSM$ACKOM'], [
    ['M                              ',clc$abbreviation_entry, 1],
    ['MESSAGE                        ',clc$nominal_entry, 1],
    ['R                              ',clc$abbreviation_entry, 2],
    ['RESPONSE                       ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 0ffff(16), 10]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [1, 256, FALSE]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$message = 1,
      p$response = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      response_string: ost$string;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$response].specified THEN
      response_string.value := pvt [p$response].value^.string_value^;
      response_string.size := #SIZE (pvt [p$response].value^.string_value^);
    ELSE
      response_string.value := '';
      response_string.size := 0;
    IFEND;

    ofp$acknowledge_operator_msg (pvt [p$message].value^.integer_value.value, response_string, status);

  PROCEND ofp$acknowledge_oper_msg_cmd;
?? TITLE := 'ofp$receive_from_operator', EJECT ??

{ PURPOSE:
{ The following procedure is being retained only for compatibility with
{ previous versions of NOS/VE.

  PROCEDURE [XDCL, #GATE] ofp$receive_from_operator
    (    wait: ost$wait;
     VAR text: ost$string;
     VAR operator_id: oft$operator_id;
     VAR status: ost$status);

    status.normal := TRUE;
    ofp$receive_operator_response (ofc$system_operator, wait, text, status);

{ For compatibility with previous systems, a value conforming to the old
{ oft$operator_id type is returned to the caller. Also, any returned abnormal
{ status from ofp$receive_operator_response is mapped into the status which
{ was returned by previous systems (ofe$message_not_available).

    operator_id := ofc$system_operator_id;

    IF NOT status.normal THEN
      osp$set_status_abnormal (ofc$operator_facility_id, ofe$message_not_available, ' ', status);
    IFEND;

  PROCEND ofp$receive_from_operator;
?? TITLE := 'ofp$receive_operator_response', EJECT ??

*copyc ofh$receive_operator_response

  PROCEDURE [XDCL, #GATE] ofp$receive_operator_response
    (    operator_class: oft$operator_class;
         wait: ost$wait;
     VAR response: ost$string;
     VAR status: ost$status);

    status.normal := TRUE;

    REPEAT
      ofp$receive_operator_resp_r3 (operator_class, response, status);
      IF (NOT status.normal AND (status.condition = ofe$no_response_available)) AND (wait = osc$wait) THEN
        pmp$long_term_wait (300000, 30000);
      IFEND;
    UNTIL status.normal OR (wait = osc$nowait) OR (NOT status.normal AND
          (status.condition <> ofe$no_response_available));
  PROCEND ofp$receive_operator_response;
?? TITLE := 'ofp$send_operator_message_cmd', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to send a message to the operator.

  PROCEDURE [XDCL] ofp$send_operator_message_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (osm$senom) send_operator_message, senom (
{     message, m: string 1 .. 256 = $REQUIRED
{     response, r: (VAR) string = $OPTIONAL
{     operator_class, oc: key
{         (system_operator, so)
{         (removable_media_operator, rmo)
{       keyend = system_operator
{     STATUS)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (15),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 2, 10, 16, 54, 45, 470],
    clc$command, 7, 4, 1, 0, 0, 1, 4, 'OSM$SENOM'], [
    ['M                              ',clc$abbreviation_entry, 1],
    ['MESSAGE                        ',clc$nominal_entry, 1],
    ['OC                             ',clc$abbreviation_entry, 3],
    ['OPERATOR_CLASS                 ',clc$nominal_entry, 3],
    ['R                              ',clc$abbreviation_entry, 2],
    ['RESPONSE                       ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 15],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [1, 256, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['REMOVABLE_MEDIA_OPERATOR       ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['RMO                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SYSTEM_OPERATOR                ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'system_operator'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$message = 1,
      p$response = 2,
      p$operator_class = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      access_mode: clt$data_access_mode,
      class: clt$variable_class,
      condition: pmt$condition,
      establish_descriptor: pmt$established_handler,
      evaluation_method: clt$expression_eval_method,
      operator_class: oft$operator_class,
      response_p: ^ost$string,
      response_string_p: ^string ( * ),
      response_value: clt$data_value,
      type_information: clt$type_information,
      type_specification: ^clt$type_specification,
      value: ^clt$data_value,
      work_area_pp: ^^clt$work_area;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   This condition handler is intended to clean up the message that
{   may have been sent by this task in the event that a block exit
{   condition occurs.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_info_p: ^pmt$condition_information;
           stack_p: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      CASE condition.selector OF

      = pmc$block_exit_processing =

        ofp$clear_operator_message (operator_class, condition_status);
        condition_status.normal := TRUE; {Ignore the returned status.}
      ELSE
      CASEND;
    PROCEND condition_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$operator_class].value^.keyword_value = 'SYSTEM_OPERATOR')
          OR (pvt [p$operator_class].value^.keyword_value = 'SO') THEN
      operator_class := ofc$system_operator;
    ELSE
      operator_class := ofc$removable_media_operator;
    IFEND;

    IF pvt [p$response].specified THEN
      IF pvt [p$response].variable = NIL THEN
        osp$set_status_condition (ofe$response_param_must_be_var, status);
        RETURN;
      IFEND;

      clp$get_work_area (#RING(^work_area_pp), work_area_pp, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$get_variable (pvt [p$response].variable^, work_area_pp^, class, access_mode,
            evaluation_method, type_specification, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$get_type_information (type_specification, work_area_pp^, type_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF type_information.max_string_size < osc$max_string_size THEN
        osp$set_status_abnormal (ofc$operator_facility_id, ofe$response_variable_too_small,
              pvt [p$response].variable^, status);
        RETURN;
      IFEND;
    IFEND;

    condition.selector := pmc$block_exit_processing;
    condition.reason := $pmt$block_exit_reason [pmc$block_exit, pmc$program_termination, pmc$program_abort];
    pmp$establish_condition_handler (condition, ^condition_handler, ^establish_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    REPEAT
      ofp$send_operator_message (pvt [p$message].value^.string_value^, operator_class, TRUE, status);
      IF NOT status.normal THEN
        IF status.condition <> ofe$allocate_structure_failed THEN
          RETURN;
        IFEND;
        pmp$long_term_wait (4000, 4000);
      IFEND;
    UNTIL status.normal;

    PUSH response_p;
    ofp$receive_operator_response (operator_class, osc$wait, response_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$response].specified THEN
      response_value.kind := clc$string;
      response_value.string_value := ^response_p^.value(1, response_p^.size);
      clp$change_variable (pvt [p$response].variable^, ^response_value, status);
    ELSEIF response_p^.size > 0 THEN
      PUSH response_string_p: [1 + response_p^.size];
      response_string_p^ (1) := ' ';
      response_string_p^ (2, response_p^.size) := response_p^.value (1, response_p^.size);
      clp$put_job_command_response (response_string_p^, status);
    IFEND;

  PROCEND ofp$send_operator_message_cmd;
MODEND ofm$operator_message_procedures;
*DECK DECK=OFM$REPORT_STATUS_ERROR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operator Facility : Report Status Error' ??
MODULE ofm$report_status_error;

{ PURPOSE:
{   This module writes a status message to the job log.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc pmp$log
*copyc osp$unpack_status_condition

?? TITLE := 'ofp$report_status_error', EJECT ??

{ PURPOSE:
{   This procedure writes a status message to the job log.
{ DESIGN:
{   The format of the message is two lines. The first line is a
{   descriptive message on where the error occurred.  The second
{   line identifies the type of error by using the status_identifier
{   and status_condition of the passed status parameter.

  PROCEDURE [XDCL, #GATE] ofp$report_status_error
    (    error_status: ost$status;
         message: string ( * ));

    VAR
      identifier: ost$status_identifier,
      ignore_status: ost$status,
      log_message: ost$string,
      number: ost$status_condition_number,
      number_length: integer,
      number_string: string (10);

    { Write the message to the log.

    log_message.value := 'Status error on ';
    log_message.size := 16;
    log_message.value (log_message.size + 1, STRLENGTH (message)) := message;
    log_message.size := log_message.size + STRLENGTH (message);
    pmp$log (log_message.value (1, log_message.size), ignore_status);

    { Write the status identifier and condition code to the log.

    osp$unpack_status_condition (error_status.condition, identifier, number);
    STRINGREP (number_string, number_length, number);
    log_message.value := 'io=';
    log_message.size := 3;
    log_message.value (log_message.size + 1, #SIZE (identifier)) := identifier;
    log_message.size := log_message.size + #SIZE (identifier);
    log_message.value (log_message.size + 1, 7) := '; cond=';
    log_message.size := log_message.size + 7;
    log_message.value (log_message.size + 1, number_length) := number_string;
    log_message.size := log_message.size + number_length;
    pmp$log (log_message.value (1, log_message.size), ignore_status);

  PROCEND ofp$report_status_error;
MODEND ofm$report_status_error;
*DECK DECK=OFM$SCREEN_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operator Facility : Screen Manager' ??
MODULE ofm$screen_manager;

{ PURPOSE:
{   This module contains the FAP for the system console.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$device_class_validation
*copyc dpt$number_of_window_lines
*copyc dpt$window
*copyc ife$error_codes
*copyc ofc$page_width
*copyc ofk$keypoints
*copyc ost$stack_frame_save_area
*copyc pmt$condition
*copyc pmt$established_handler
?? POP ??
*copyc amp$access_method
*copyc amp$fetch_fap_pointer
*copyc amp$set_file_instance_abnormal
*copyc amp$store_fap_pointer
*copyc clp$new_display_page
*copyc clp$open_display_file
*copyc clp$put_display
*copyc clp$validate_name
*copyc dpp$change_window
*copyc dpp$clear_window
*copyc dpp$get_next_line
*copyc dpp$put_next_line
*copyc dpp$set_title
*copyc i#move
*copyc ifp$invoke_pause_utility
*copyc jmp$system_job
*copyc ofp$report_status_error
*copyc osp$clear_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pmp$continue_to_cause
*copyc pmp$establish_condition_handler
*copyc pmp$long_term_wait
*copyc pmp$wait
?? EJECT ??
*copyc clv$standard_files
*copyc dpv$system_core_display
*copyc ofv$screen_status
*copyc osv$task_private_heap
?? TITLE := 'Global Declarations Declared by this Module', EJECT ??

  TYPE
    screen_fap_information = record
      window_id: dpt$window_id,
      input_prompt: string (ifc$max_prompt_string_size),
      input_text: string (ofc$page_width),
      input_text_position: 0 .. ofc$page_width,
      output_list_window: boolean,
      output_screen_file: oft$screen_files,
      output_text: ost$string,
      last_operation: amt$fap_operation,
      last_status: ost$status,
    recend;

?? TITLE := 'fetch_access_information', EJECT ??

{ PURPOSE:
{   This procedure fetches access information about the screen file.

  PROCEDURE fetch_access_information
    (    file_identifier: amt$file_identifier;
         screen_fap_p: ^screen_fap_information;
         fap_type: (input_fap, output_fap);
         access_information_p: ^amt$access_information;
     VAR status: ost$status);

    VAR
      index: amt$access_info_keys;

    status.normal := TRUE;

    FOR index := LOWERBOUND (access_information_p^) TO UPPERBOUND (access_information_p^) DO
      access_information_p^ [index].item_returned := TRUE;
      CASE access_information_p^ [index].key OF
      = amc$error_status =
        access_information_p^ [index].error_status := screen_fap_p^.last_status.condition;
      = amc$file_position =
        IF (fap_type = input_fap) AND (screen_fap_p^.input_text_position <> 0) THEN
          access_information_p^ [index].file_position := amc$mid_record;
        ELSE
          access_information_p^ [index].file_position := amc$eor;
        IFEND;
      = amc$last_access_operation =
        access_information_p^ [index].last_access_operation := screen_fap_p^.last_operation;
      = amc$last_op_status =
        access_information_p^ [index].last_op_status := amc$complete;
      = amc$previous_record_length =
        access_information_p^ [index].previous_record_length := ofc$page_width;
      ELSE
        access_information_p^ [index].item_returned := FALSE;
      CASEND;
    FOREND;

  PROCEND fetch_access_information;
?? TITLE := 'get_from_screen', EJECT ??

{ PURPOSE:
{   This procedure retrieves text from the screen for the input FAP.

  PROCEDURE get_from_screen
    (    file_identifier: amt$file_identifier;
         skip_option: amt$skip_option;
         working_storage_length: amt$working_storage_length;
         working_storage_area_p: ^cell;
         transfer_count_p: ^amt$transfer_count;
         file_position_p: ^amt$file_position;
     VAR screen_fap_p: ^screen_fap_information;
     VAR status: ost$status);

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   This procedure handles interrupt conditions such as
{   pause break or terminate break.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_info_p: ^pmt$condition_information;
           stack_p: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        local_status: ost$status;

      condition_status.normal := TRUE;


      CASE condition.selector OF

      = ifc$interactive_condition =

        IF condition.interactive_condition = ifc$pause_break THEN
          ifp$invoke_pause_utility (local_status);
        ELSEIF condition.interactive_condition = ifc$terminate_break THEN
          osp$set_status_from_condition ('OF', condition, stack_p, status, local_status);
          EXIT get_from_screen;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IFEND
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;
    PROCEND condition_handler;
?? OLDTITLE ??

    VAR
      input_text: string (ofc$page_width),
      line_received: boolean;

    status.normal := TRUE;
    osp$establish_condition_handler (^condition_handler, FALSE);

    IF skip_option = amc$skip_to_eor THEN
      screen_fap_p^.input_text_position := 0;
    IFEND;

    IF screen_fap_p^.input_text_position = 0 THEN

      { Display prompt on console.

      IF screen_fap_p^.input_prompt <> ' ' THEN
        dpp$put_next_line (screen_fap_p^.window_id, screen_fap_p^.input_prompt, status);
        IF NOT status.normal THEN
          ofp$report_status_error (status, 'Screen Manager: put input prompt');
        IFEND;
      IFEND;

      { Wait for the input text.

      REPEAT
        dpp$get_next_line (screen_fap_p^.window_id, osc$nowait, input_text, line_received);
        IF NOT line_received THEN
          pmp$long_term_wait (500, 500);
        IFEND;
      UNTIL line_received;

      { Save the input text and display it on the console.

      screen_fap_p^.input_text := input_text;
      screen_fap_p^.input_text_position := 1;

      dpp$put_next_line (screen_fap_p^.window_id, input_text, status);
      IF NOT status.normal THEN
        ofp$report_status_error (status, 'Screen Manager: put input line');
      IFEND;
    IFEND;

    { Move the input text to the working storage area.

    IF working_storage_length <= (ofc$page_width - screen_fap_p^.input_text_position + 1) THEN
      transfer_count_p^ := working_storage_length;
    ELSE
      transfer_count_p^ := ofc$page_width - screen_fap_p^.input_text_position + 1;
    IFEND;
    i#move (#LOC (screen_fap_p^.input_text (screen_fap_p^.input_text_position)), working_storage_area_p,
          transfer_count_p^);

    { Find the file position.

    IF (screen_fap_p^.input_text_position + transfer_count_p^) > ofc$page_width THEN
      screen_fap_p^.input_text_position := 0;
      file_position_p^ := amc$eor;
    ELSE
      screen_fap_p^.input_text_position := screen_fap_p^.input_text_position + transfer_count_p^;
      file_position_p^ := amc$mid_record;
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND get_from_screen;
?? TITLE := 'input_close_screen', EJECT ??

{ PURPOSE:
{   This procedure closes the screen file for input.

  PROCEDURE input_close_screen
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR screen_fap_p: ^screen_fap_information;
     VAR status: ost$status);

    status.normal := TRUE;

    FREE screen_fap_p IN osv$task_private_heap^;
    amp$access_method (file_identifier, call_block, layer_number, status);
    IF NOT status.normal THEN
      ofp$report_status_error (status, 'Screen Manager: close input screen');
    IFEND;

  PROCEND input_close_screen;
?? TITLE := 'input_open_screen', EJECT ??

{ PURPOSE:
{   This procedure sets up the pointer to the screen FAP data and
{   sets up the screen window to be used for input.

  PROCEDURE input_open_screen
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      screen_fap_p: ^screen_fap_information;

    status.normal := TRUE;
    amp$access_method (file_identifier, call_block, layer_number, status);
    IF NOT status.normal THEN
      ofp$report_status_error (status, 'Screen Manager: open input screen');
      RETURN;
    IFEND;

    ALLOCATE screen_fap_p IN osv$task_private_heap^;
    screen_fap_p^.window_id := dpv$system_core_display;
    screen_fap_p^.input_prompt := '  ';
    screen_fap_p^.input_text := ' ';
    screen_fap_p^.input_text_position := 0;

    amp$store_fap_pointer (file_identifier, layer_number, screen_fap_p, status);
    IF NOT status.normal THEN
      ofp$report_status_error (status, 'Screen Manager: store input fap pointer');
    IFEND;

  PROCEND input_open_screen;
?? TITLE := 'output_close_screen', EJECT ??

{ PURPOSE:
{   This procedure closes the screen file for output.

  PROCEDURE output_close_screen
    (    file_identifier: amt$file_identifier;
         layer_number: amt$fap_layer_number;
         call_block: amt$call_block;
     VAR screen_fap_p: ^screen_fap_information;
     VAR status: ost$status);

    IF screen_fap_p^.output_text.size > 0 THEN
      put_data_on_screen (screen_fap_p, status);
    IFEND;

    IF screen_fap_p^.output_screen_file <> ofc$sf_main_or_other THEN
      osp$set_signature_lock (ofv$screen_status [screen_fap_p^.output_screen_file].file_lock, osc$wait,
            status);
      ofv$screen_status [screen_fap_p^.output_screen_file].
            open_file_count := ofv$screen_status [screen_fap_p^.output_screen_file].open_file_count - 1;
      IF ofv$screen_status [screen_fap_p^.output_screen_file].open_file_count = 0 THEN
        ofv$screen_status [screen_fap_p^.output_screen_file].display_user := ofc$du_no_one;
      IFEND;
      osp$clear_signature_lock (ofv$screen_status [screen_fap_p^.output_screen_file].file_lock, status);
    IFEND;

    FREE screen_fap_p IN osv$task_private_heap^;
    amp$access_method (file_identifier, call_block, layer_number, status);
    IF NOT status.normal THEN
      ofp$report_status_error (status, 'Screen Manager: close screen file');
    IFEND;

  PROCEND output_close_screen;
?? TITLE := 'output_open_screen', EJECT ??

{ PURPOSE:
{   This procedure sets up the pointer to the screen FAP data and
{   sets up the screen window to be used for output.

  PROCEDURE output_open_screen
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      access_call_block: amt$call_block,
      screen_fap_p: ^screen_fap_information,
      setup_main_window: [STATIC, oss$task_shared] boolean := TRUE,
      file_name: ost$name,
      valid_name: boolean,
      window_title: ost$name;

    status.normal := TRUE;

    { Determine that the local file name is valid.

    clp$validate_name (call_block.open.local_file_name, file_name, valid_name);
    IF NOT valid_name THEN
      ofp$report_status_error (status, 'Screen Manager: Invalid name on open');
      RETURN;
    IFEND;

    { Create the pointer to the file information.

    ALLOCATE screen_fap_p IN osv$task_private_heap^;

    { Determine if the window is a list type window.

    access_call_block.operation := amc$fetch_req;
    PUSH access_call_block.fetch.file_attributes: [1 .. 2];
    access_call_block.fetch.file_attributes^ [1].key := amc$file_contents;
    access_call_block.fetch.file_attributes^ [2].key := amc$user_info;
    amp$access_method (file_identifier, access_call_block, layer_number, status);
    IF NOT status.normal THEN
      ofp$report_status_error (status, 'Screen Manager: cannot fetch info from screen file');
      RETURN;
    IFEND;
    screen_fap_p^.output_list_window := (access_call_block.fetch.file_attributes^ [1].file_contents =
          amc$list);

    { Initialize the output text buffer.

    screen_fap_p^.output_text.value := ' ';
    screen_fap_p^.output_text.size := 0;

    { Determine which display file is being used.

    IF clv$standard_files [clc$sf_display_a_file].path_handle_name = file_name THEN
      screen_fap_p^.output_screen_file := ofc$sf_display_a;
      window_title := 'DISPLAY_A';
    ELSEIF clv$standard_files [clc$sf_display_b_file].path_handle_name = file_name THEN
      screen_fap_p^.output_screen_file := ofc$sf_display_b;
      window_title := 'DISPLAY_B';
    ELSE
      screen_fap_p^.output_screen_file := ofc$sf_main_or_other;
    IFEND;

    { Fetch the window id.

    IF screen_fap_p^.output_screen_file = ofc$sf_main_or_other THEN
      IF setup_main_window THEN
        dpp$set_title (dpv$system_core_display, 'Main Operator Window', status);
        setup_main_window := FALSE;
      IFEND;
      screen_fap_p^.window_id := dpv$system_core_display;
    ELSE

    /set_screen_action/
      WHILE TRUE DO
        osp$set_signature_lock (ofv$screen_status [screen_fap_p^.output_screen_file].file_lock, osc$wait,
              status);
        IF ofv$screen_status [screen_fap_p^.output_screen_file].display_user = ofc$du_ve_display_user THEN
          ofv$screen_status [screen_fap_p^.output_screen_file].display_action := ofc$da_new_display_requested;
          osp$clear_signature_lock (ofv$screen_status [screen_fap_p^.output_screen_file].file_lock, status);

          { Wait until the 'VED' user is finished with the display.

          pmp$wait (500, 500);
        ELSE

          { Assign the display to the file user and retrieve the window id.

          ofv$screen_status [screen_fap_p^.output_screen_file].display_user := ofc$du_file_user;
          ofv$screen_status [screen_fap_p^.output_screen_file].
                open_file_count := ofv$screen_status [screen_fap_p^.output_screen_file].open_file_count + 1;
          screen_fap_p^.window_id := ofv$screen_status [screen_fap_p^.output_screen_file].window_id;
          osp$clear_signature_lock (ofv$screen_status [screen_fap_p^.output_screen_file].file_lock, status);
          EXIT /set_screen_action/;
        IFEND;
      WHILEND /set_screen_action/;

      { Determine the type of display window and change the window to that type of display.

      IF access_call_block.fetch.file_attributes^ [2].user_info = 'TABLE' THEN
        dpp$change_window (screen_fap_p^.window_id, dpc$wc_sharing, dpc$wk_table, status);
      ELSE
        dpp$change_window (screen_fap_p^.window_id, dpc$wc_sharing, dpc$wk_log, status);
      IFEND;
      dpp$set_title (screen_fap_p^.window_id, window_title, status);
    IFEND;

    { Store the file fap information for later access.

    amp$store_fap_pointer (file_identifier, layer_number, screen_fap_p, status);
    IF NOT status.normal THEN
      ofp$report_status_error (status, 'Screen Manager: store fap pointer error');
    IFEND;

  PROCEND output_open_screen;
?? TITLE := 'put_data_on_screen', EJECT ??

{ PURPOSE:
{   This procedure writes data to the screen.

  PROCEDURE put_data_on_screen
    (    screen_fap_p: ^screen_fap_information;
     VAR status: ost$status);

    VAR
      first_character: char,
      screen_data_index: 1 .. 2;

    status.normal := TRUE;

    { Display the data on the screen.

    IF screen_fap_p^.output_text.size > 0 THEN
      screen_data_index := 1;
      first_character := ' ';
      IF screen_fap_p^.output_list_window THEN

        {  Outputting a list file, update output text control variables to not output carriage control
        {  character.  Output carriage control character if it is the only character and is a blank.

        first_character := screen_fap_p^.output_text.value (1);

        IF (screen_fap_p^.output_text.size > 1) OR (first_character <> ' ') THEN
          screen_fap_p^.output_text.size := screen_fap_p^.output_text.size - 1;
          screen_data_index := 2;
        IFEND;
      IFEND;
      CASE first_character OF
      = '0' =
        dpp$put_next_line (screen_fap_p^.window_id, ' ', status);
      = '-' =
        dpp$put_next_line (screen_fap_p^.window_id, ' ', status);
        dpp$put_next_line (screen_fap_p^.window_id, ' ', status);
      = '1' =
        dpp$clear_window (screen_fap_p^.window_id, status);
      ELSE
      CASEND;
      dpp$put_next_line (screen_fap_p^.window_id, screen_fap_p^.output_text.
            value (screen_data_index, screen_fap_p^.output_text.size), status);
    IFEND;

    screen_fap_p^.output_text.value := ' ';
    screen_fap_p^.output_text.size := 0;

  PROCEND put_data_on_screen;
?? TITLE := 'put_to_screen', EJECT ??

{ PURPOSE:
{   This procedure writes data to the screen.

  PROCEDURE put_to_screen
    (    screen_fap_p: ^screen_fap_information;
         working_storage_area_p: ^cell;
         working_storage_length: amt$working_storage_length;
         term_option: amt$term_option;
     VAR status: ost$status);

    VAR
      data_length: amt$working_storage_length,
      data_to_put: ost$string_size,
      length_available: ost$string_size,
      screen_data_p: ^string ( * ),
      screen_data_seq_p: ^SEQ ( * );

    status.normal := TRUE;

    IF term_option = amc$start THEN
      put_data_on_screen (screen_fap_p, status);
    IFEND;

    IF working_storage_length = 0 THEN
      data_length := 1;
      PUSH screen_data_seq_p: [[REP data_length OF cell]];
      RESET screen_data_seq_p;
      NEXT screen_data_p: [1] IN screen_data_seq_p;
      screen_data_p^ := ' ';
      RESET screen_data_seq_p;
    ELSE
      data_length := working_storage_length;
      PUSH screen_data_seq_p: [[REP data_length OF cell]];
      RESET screen_data_seq_p;
      i#move (working_storage_area_p, screen_data_seq_p, data_length);
      RESET screen_data_seq_p;
    IFEND;

    WHILE data_length > 0 DO
      IF screen_fap_p^.output_text.size = osc$max_string_size THEN
        put_data_on_screen (screen_fap_p, status);
      IFEND;
      length_available := osc$max_string_size - screen_fap_p^.output_text.size;
      IF data_length <= length_available THEN
        data_to_put := data_length;
      ELSE
        data_to_put := length_available;
      IFEND;
      NEXT screen_data_p: [data_to_put] IN screen_data_seq_p;
      screen_fap_p^.output_text.value ((screen_fap_p^.output_text.size + 1), data_to_put) :=
            screen_data_p^ (1, data_to_put);
      screen_fap_p^.output_text.size := screen_fap_p^.output_text.size + data_to_put;
      data_length := data_length - data_to_put;
    WHILEND;

    IF term_option = amc$terminate THEN
      put_data_on_screen (screen_fap_p, status);
    IFEND;

  PROCEND put_to_screen;
?? TITLE := 'store_terminal', EJECT ??

{ PURPOSE:
{   This procedure allows the user to change the prompt at the system console.

  PROCEDURE store_terminal
    (    file_identifier: amt$file_identifier;
         terminal_attributes_p: ^ift$connection_attributes;
     VAR screen_fap_p: ^screen_fap_information;
     VAR status: ost$status);

    VAR
      index: integer;

    status.normal := TRUE;

    FOR index := LOWERBOUND (terminal_attributes_p^) TO UPPERBOUND (terminal_attributes_p^) DO
      IF terminal_attributes_p^ [index].key = ifc$prompt_string THEN
        IF terminal_attributes_p^ [index].prompt_string.size = 0 THEN
          screen_fap_p^.input_prompt := '';
        ELSE
          screen_fap_p^.input_prompt := terminal_attributes_p^ [index].
                prompt_string.value (2, terminal_attributes_p^ [index].prompt_string.size - 1);
        IFEND;
        RETURN;
      IFEND;
    FOREND;

  PROCEND store_terminal;
?? TITLE := '[XDCL] ofp$open_display', EJECT ??
*copyc ofh$open_display

  PROCEDURE [XDCL] ofp$open_display
    (    file_name: amt$local_file_name;
         window_id: dpt$window_id;
         class: dpt$window_class;
         kind: dpt$window_kind;
         title: string ( * );
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      display_file_ring_attributes: amt$ring_attributes,
      file: clt$file;

    status.normal := TRUE;

    IF window_id = 0 THEN
      file.local_file_name := file_name;

      { Set up ring attributes for display file.

      display_file_ring_attributes.r1 := osc$user_ring_2;
      display_file_ring_attributes.r2 := osc$user_ring_2;
      display_file_ring_attributes.r3 := osc$user_ring_2;

      clp$open_display_file (file, NIL, fsc$list, display_file_ring_attributes, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$new_display_page (display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_display (display_control, title, clc$trim, status);
    ELSE
      dpp$change_window (window_id, class, kind, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      dpp$set_title (window_id, title, status);
    IFEND;

  PROCEND ofp$open_display;
?? TITLE := '[XDCL, #GATE] ofp$screen_input_fap', EJECT ??

{ PURPOSE:
{   This procedure translates input from the operator's console into standard BAM requests.

  PROCEDURE [XDCL, #GATE] ofp$screen_input_fap
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);


    VAR
      screen_fap_p: ^screen_fap_information;

    status.normal := TRUE;

    #INLINE ('keypoint', osk$entry, osk$m * call_block.operation, ofk$screen_input_fap);


    IF call_block.operation <> amc$open_req THEN
      amp$fetch_fap_pointer (file_identifier, layer_number, screen_fap_p, status);
      IF NOT status.normal THEN
        ofp$report_status_error (status, 'Screen Manager: fetch fap pointer error');
        RETURN;
      IFEND;
    IFEND;

    CASE call_block.operation OF

    = amc$open_req =
      input_open_screen (file_identifier, call_block, layer_number, status);

    = amc$get_next_req =
      get_from_screen (file_identifier, amc$skip_to_eor, call_block.getn.working_storage_length,
            call_block.getn.working_storage_area, call_block.getn.transfer_count,
            call_block.getn.file_position, screen_fap_p, status);

    = amc$get_partial_req =
      get_from_screen (file_identifier, call_block.getp.skip_option, call_block.getp.working_storage_length,
            call_block.getp.working_storage_area, call_block.getp.transfer_count,
            call_block.getp.file_position, screen_fap_p, status);

    = amc$get_direct_req =
      get_from_screen (file_identifier, amc$skip_to_eor, call_block.getd.working_storage_length,
            call_block.getd.working_storage_area, call_block.getd.transfer_count,
            call_block.getd.file_position, screen_fap_p, status);

    = ifc$store_terminal_req =
      store_terminal (file_identifier, call_block.store_terminal.terminal_attributes, screen_fap_p, status);

    = amc$fetch_req, amc$store_req =
      amp$access_method (file_identifier, call_block, layer_number, status);

    = amc$fetch_access_information_rq =
      fetch_access_information (file_identifier, screen_fap_p, input_fap, call_block.fai.access_information,
            status);

    = amc$seek_direct_req, amc$skip_req, amc$rewind_req, amc$write_end_partition_req, amc$write_tape_mark_req,
          amc$flush_req =

    = amc$replace_req =
      amp$set_file_instance_abnormal (file_identifier, ame$improper_fap_operation, call_block.operation,
            'console input', status);

    = amc$close_req =
      input_close_screen (file_identifier, call_block, layer_number, screen_fap_p, status);

    ELSE
      amp$set_file_instance_abnormal (file_identifier, ame$improper_device_class, call_block.operation,
            'console input', status);
    CASEND;

    IF (call_block.operation <> amc$close_req) AND (call_block.operation <> amc$open_req) THEN
      screen_fap_p^.last_operation := call_block.operation;
      screen_fap_p^.last_status := status;
    IFEND;


    #INLINE ('keypoint', osk$exit, osk$m * call_block.operation, ofk$screen_input_fap);

  PROCEND ofp$screen_input_fap;
?? TITLE := '[XDCL, #GATE] ofp$screen_output_fap', EJECT ??

{ PURPOSE:
{   This procedure translates output from standard BAM requests to the operator's console.

  PROCEDURE [XDCL, #GATE] ofp$screen_output_fap
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      screen_fap_p: ^screen_fap_information;

    status.normal := TRUE;

    IF NOT jmp$system_job () THEN
      RETURN;
    IFEND;

    #INLINE ('keypoint', osk$entry, osk$m * call_block.operation, ofk$screen_output_fap);

    IF call_block.operation <> amc$open_req THEN
      amp$fetch_fap_pointer (file_identifier, layer_number, screen_fap_p, status);
      IF NOT status.normal THEN
        ofp$report_status_error (status, 'Screen manager: fetch fap pointer error');
        RETURN;
      IFEND;
    IFEND;

    CASE call_block.operation OF
    = amc$close_req =
      output_close_screen (file_identifier, layer_number, call_block, screen_fap_p, status);

    = amc$open_req =
      output_open_screen (file_identifier, call_block, layer_number, status);

    = amc$put_direct_req =
      put_to_screen (screen_fap_p, call_block.putd.working_storage_area,
            call_block.putd.working_storage_length, amc$terminate, status);

    = amc$put_next_req =
      put_to_screen (screen_fap_p, call_block.putn.working_storage_area,
            call_block.putn.working_storage_length, amc$terminate, status);

    = amc$put_partial_req =
      put_to_screen (screen_fap_p, call_block.putp.working_storage_area,
            call_block.putp.working_storage_length, call_block.putp.term_option, status);

    = amc$fetch_req, amc$store_req =
      amp$access_method (file_identifier, call_block, layer_number, status);

    = amc$fetch_access_information_rq =
      fetch_access_information (file_identifier, screen_fap_p, output_fap, call_block.fai.access_information,
            status);

    = amc$flush_req, amc$seek_direct_req, amc$skip_req, amc$rewind_req, amc$write_end_partition_req,
          amc$write_tape_mark_req =

    = amc$replace_req =
      amp$set_file_instance_abnormal (file_identifier, ame$improper_fap_operation, call_block.operation,
            'console output', status);

    ELSE
      amp$set_file_instance_abnormal (file_identifier, ame$improper_device_class, call_block.operation,
            'console output', status);
    CASEND;

    IF (call_block.operation <> amc$close_req) AND (call_block.operation <> amc$open_req) THEN
      screen_fap_p^.last_operation := call_block.operation;
      screen_fap_p^.last_status := status;
    IFEND;

    #INLINE ('keypoint', osk$exit, osk$m * call_block.operation, ofk$screen_output_fap);

  PROCEND ofp$screen_output_fap;
?? OLDTITLE ??
?? OLDTITLE ??
MODEND ofm$screen_manager;
*DECK DECK=OFM$SPECIAL_STATISTICS_DISPLAY EXPAND=TRUE

?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operator Facility : VED SS Display' ??
MODULE ofm$special_statistics_display;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$value
*copyc clt$display_control
*copyc cmv$logical_unit_table
*copyc jmt$system_supplied_name
*copyc jst$ijl_swap_queue_list
*copyc jsv$ijl_swap_queue_list
*copyc rmt$recorded_vsn
*copyc osc$multiprocessor_constants
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc oss$task_shared
*copyc ost$cpu_idle_statistics
*copyc ost$data_id
*copyc ost$status
*copyc ost$string
*copyc osv$task_shared_heap
?? POP ??
*copyc jmv$ijl_p
*copyc jmv$known_job_list
*copyc jmv$known_output_list
*copyc jmv$known_qfile_list
*copyc jmv$maximum_known_jobs
*copyc jmv$maximum_known_outputs
*copyc mtv$cst0
*copyc mtv$total_nos_cpu_time
*copyc tmv$total_task_count
*copyc qfv$current_kjl_limit
*copyc qfv$current_kol_limit
*copyc qfv$current_kql_limit
*copyc clp$close_display
*copy  clp$new_display_line
*copy  clp$put_display
*copyc dpp$clear_window
*copyc dpp$put_next_line
*copyc jmp$get_job_counts
*copyc ofp$build_system_line
*copyc ofp$open_display
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$get_pp_unit_count
*copyc osp$get_jm_mm_stats
*copyc osp$get_page_stats
*copyc osp$get_rvsn_by_lun
*copyc osp$get_pio_unit_stats
*copyc osp$get_disk_space_stats
*copyc osp$get_swap_stats
*copyc pmp$binary_to_ascii_fit
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] ofp$special_statistics_display', EJECT ??

  PROCEDURE [XDCL] ofp$special_statistics_display
    (    wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure provides clean-up processing when a task abort occurs.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF wid = 0 THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??



    TYPE
     unit_info = RECORD
               unit: iot$logical_unit,
               count: integer,
                 RECEND;


    CONST
      max_lines = 21,
      non_incremental = FALSE;

    VAR
       iov$lunvsns: [XREF] ARRAY [1 .. 100] of rmt$recorded_vsn,
       iov$reject_address_buffer_full: [XREF] integer,
       iov$reject_interlock_set: [XREF] integer,
       iov$reject_requests_full: [XREF] integer,
       iov$reject_unit_queue_limit: [XREF] integer,


       iov$total_queue_calls: [XREF] integer,
       iov$actual_requests_resolved: [XREF] integer,
       iov$read_priority_invoked: [XREF] integer,

       mmv$sq_mcount: [XREF] integer,
       mmv$sq_rcount: [XREF] integer,
       mmv$jws_mcount: [XREF] integer,
       mmv$jws_rcount: [XREF] integer;

    VAR
      display_control: clt$display_control,
      pp_count, unit_count,
      i, j, k,
      swap_ins,
      swap_outs,
      strr,
      strm,
      strjr,
      strjm,
      total_tasks,
      total_reads,
      total_writes,
      total_disk_recovered_errors,
      total_disk_intermediate_errors,
      total_disk_unrecovered_errors,
      other_pf_data,
      queue_count,
      swap_file_size: integer,
      ignore_status: ost$status,
      job_counts: jmt$job_counts,
      jobs_in_long_wait_count: 0 .. jmc$max_ijl_entries,
      jobs_in_long_wait_cant_init_io: 0 .. jmc$max_ijl_entries,
      lun: iot$logical_unit,
      left: boolean,
      swapped_jobs_count: 0 .. jmc$max_ijl_entries,
      swap_resident_job_count: 0 .. jmc$max_ijl_entries,
      task_index: tmt$task_status,
      from_state: jmt$ijl_swap_status,
      found: boolean,
      pfd_p: ^ost$page_fault_stats,
      preads: integer,
      ptotal: integer,
      pactual: integer,
      server_pfd_p: ^ost$page_fault_stats,
      pio_unit_p: ^ost$disk_unit_stats,
      swapd_p: ^ost$swap_stats,
      jmmmd_p: ^ost$jm_mm_stats,
      diskd_p: ^ost$disk_space_stats,
      title: [READ, oss$job_paged_literal] string (18) := 'Special Statistics',
      vsn: rmt$recorded_vsn,
      str: array [1 .. max_lines] of string (80),
      temp_str: string(80),
      previous_pf_data: [STATIC, oss$task_shared] ^ost$page_fault_stats := NIL,
      previous_server_pf_data: [STATIC, oss$task_shared] ^ost$page_fault_stats := NIL,
      previous_swap_data: [STATIC, oss$task_shared] ^ost$swap_stats := NIL,
      previous_total_reads: [STATIC, oss$task_shared] integer := 0,
      previous_total_writes: [STATIC, oss$task_shared] integer := 0,
      previous_data_for_display: [STATIC, oss$task_shared] boolean := FALSE,
      read_summary: integer,
      unit_interface_table: ^iot$unit_interface_table,
      units: integer,
      unit_data: array [1 .. 100] of unit_info,
      system_line_info: [STATIC, oss$task_shared] ^oft$system_line_info := NIL;

    status.normal := TRUE;

    IF wid = 0 THEN
      osp$establish_block_exit_hndlr (^abort_handler);
    IFEND;
    IF initial_call THEN
      ofp$open_display (file_name, wid, dpc$wc_sharing, dpc$wk_table, title, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    strm := mmv$sq_mcount;
    strr := mmv$sq_rcount;
    strjm := mmv$jws_mcount;
    strjr := mmv$jws_rcount;

{ Set up the labels.

    str [2] :=  ' PAGE QUEUES               SITE SHARED QUEUES    QUEUE COUNT BY VSN ';
    str [3] :=  '       free:                   01:                            ';
    str [4] :=  '  available:                   02:                            ';
    str [5] :=  '  avail-mod:                   03:                            ';
    str [6] :=  'SYSTEM SHARED Qs               04:                            ';
    str [7] :=  'task services:                 05:                            ';
    str [8] :=  '   pf execute:                 06:                            ';
    str [9] :=  '   pf non-exe:                                                ';
    str [10] := ' device files:                                                ';
    str [11] := '  file server:                                                ';
    str [12] := '       flawed:                                                ';
    str [13] := 'swap i/o errs:                                                ';
    str [14] := 'disk page faults:                                             ';
    str [15] := '   read reqs:                                                 ';
    str [16] := '  write_reqs:          QUICK SWEEP                            ';
    str [17] := '    Q limit:             sq mod:                              ';
    str [18] := '   req full:             sq tot:                              ';
    str [19] := '                        jws mod:                              ';
    str [20] := '                        jws tot:                              ';
    str [21] := ' ';

    total_tasks := 0;
    PUSH jmmmd_p;

    osp$get_jm_mm_stats (non_incremental, jmmmd_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH pfd_p;
    PUSH server_pfd_p;
    osp$get_page_stats (non_incremental, pfd_p^,server_pfd_p^,status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    total_reads := 0;
    total_writes := 0;
    total_disk_recovered_errors := 0;
    total_disk_intermediate_errors := 0;
    total_disk_unrecovered_errors := 0;
    osp$get_pp_unit_count (pp_count, unit_count, status);
    IF unit_count = 0 THEN
      RETURN;
    IFEND;
    PUSH pio_unit_p: [1 .. unit_count];
    osp$get_pio_unit_stats (non_incremental, pio_unit_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
{ Establish base values for the general statistics display if they do not already
{ exist.

    IF NOT previous_data_for_display THEN
      ALLOCATE previous_pf_data IN osv$task_shared_heap^;
      previous_pf_data^ := pfd_p^;
      ALLOCATE system_line_info IN osv$task_shared_heap^;
      system_line_info^.initialized := FALSE;
      ALLOCATE previous_server_pf_data IN osv$task_shared_heap^;
      previous_server_pf_data^ := server_pfd_p^;
      previous_data_for_display := TRUE;
    IFEND;

{ Set up the cpu idle-statistics and the NOS percentage.

    ofp$build_system_line (system_line_info^, str [1]);

{ Set up the page queue statistics.

    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_free],
          10, 7, 7, str[3](16, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_avail],
          10, 7, 7, str[4](16, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_avail_modified],
          10, 7, 7, str[5](16, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_shared_task_service],
          10, 7, 7, str[7](16, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_shared_pf_execute],
          10, 7, 7, str[8](16, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_shared_pf_non_execute],
          10, 7, 7, str[9](16, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_shared_device_file],
          10, 7, 7, str[10](16, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_shared_file_server],
          10, 7, 7, str[11](16, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_flawed],
          10, 7, 7, str[12](16, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_swapped_io_error],
          10, 7, 7, str[13](16, 7));

    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_shared_site_01],
          10, 7, 7, str[3](36, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_shared_site_02],
          10, 7, 7, str[4](36, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_shared_site_03],
          10, 7, 7, str[5](36, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_shared_site_04],
          10, 7, 7, str[6](36, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_shared_site_05],
          10, 7, 7, str[7](36, 7));
    pmp$binary_to_ascii_fit (jmmmd_p^.jm_mm_stats.page_q_counts.q_counts[mmc$pq_shared_site_06],
          10, 7, 7, str[8](36, 7));




{ Set up the page fault statistics.  Currently, SERVER page_fault statistics are not displayed.

 {  pmp$binary_to_ascii_fit ((pfd_p^.pf_stats [1] +
 {        pfd_p^.pf_stats [2] - previous_pf_data^.pf_stats [1]
 {        - previous_pf_data^.pf_stats [2]), 10, 7, 7, str [09] (15, 7));
 {  pmp$binary_to_ascii_fit ((pfd_p^.pf_stats [10] -
 {        previous_pf_data^.pf_stats [10]), 10, 7, 7, str [10] (15, 7));
    pmp$binary_to_ascii_fit ((pfd_p^.pf_stats [7] -
          previous_pf_data^.pf_stats [7]), 10, 7, 7, str [14] (19, 7));
 {  other_pf_data := pfd_p^.pf_stats [3] +
 {        pfd_p^.pf_stats [4] + pfd_p^.pf_stats
 {        [5] + pfd_p^.pf_stats [6] + pfd_p^.pf_stats [8] +
 {        pfd_p^.pf_stats [9] + pfd_p^.pf_stats
 {        [11] + pfd_p^.pf_stats [12] + pfd_p^.
 {        pf_stats [13] + pfd_p^.pf_stats [14] +
 {        pfd_p^.pf_stats [15] - previous_pf_data^.pf_stats [3]
 {        - previous_pf_data^.pf_stats [4] - previous_pf_data^.pf_stats [5] -
 {        previous_pf_data^.pf_stats [6] - previous_pf_data^.pf_stats [8] -
 {        previous_pf_data^.pf_stats [9] - previous_pf_data^.pf_stats [11] -
 {        previous_pf_data^.pf_stats [12] - previous_pf_data^.pf_stats [13] -
 {        previous_pf_data^.pf_stats [14] - previous_pf_data^.pf_stats [15];
 {  pmp$binary_to_ascii_fit (other_pf_data, 10, 7, 7, str [12] (15, 7));



{ get the I/O queue counts by logical unit

    IF cmv$logical_unit_table = NIL THEN
      RETURN;
    IFEND;

    PUSH diskd_p: [1 .. unit_count];
    osp$get_disk_space_stats (diskd_p^);

    temp_str := ' ';

    j := 3;
    units := 0;
    Left := TRUE;
    FOR i := LOWERBOUND (cmv$logical_unit_table^) TO UPPERBOUND (cmv$logical_unit_table^) DO
      IF cmv$logical_unit_table^ [i].configured THEN
        unit_interface_table := cmv$logical_unit_table^ [i].unit_interface_table;
        IF unit_interface_table <> NIL THEN
          IF (unit_interface_table^.unit_type >= ioc$lowest_disk_unit) AND
                (unit_interface_table^.unit_type <= ioc$highest_disk_unit) THEN
              lun := unit_interface_table^.logical_unit;
               osp$get_rvsn_by_lun (lun,vsn, found);
                IF NOT found THEN
                 vsn := '      ';
                IFEND;
            IF NOT unit_interface_table^.unit_status.disabled  THEN
             IF left THEN
                temp_str := str[j];
                temp_str(46,6) := vsn(1,6);
                str[j] := temp_str;
               pmp$binary_to_ascii_fit (unit_interface_table^.queue_count,
               10,3,3, str[j](53,3));
               left := false;
             ELSE
                temp_str := str[j];
                temp_str(59,6) := vsn(1,6);
                str[j] := temp_str;
               pmp$binary_to_ascii_fit (unit_interface_table^.queue_count,
               10,3,3, str[j](66,3));
               left := true;
             IFEND;
               j := j + 1;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    FOREND;







{ Set up the input/output statistics.

    FOR i := 1 TO unit_count DO
      IF pio_unit_p^.disk_unit_stats [i].unit_used THEN
        total_writes := total_writes + pio_unit_p^.disk_unit_stats [i].write_requests +
                        pio_unit_p^.disk_unit_stats [i].swap_out_requests;
        total_reads := total_reads + pio_unit_p^.disk_unit_stats [i].read_requests +
                        pio_unit_p^.disk_unit_stats [i].swap_in_requests;
      IFEND;
    FOREND;

    IF previous_total_reads = 0 THEN {First time through the display for this task}
      previous_total_reads := total_reads;
      previous_total_writes := total_writes;
    IFEND;

    pmp$binary_to_ascii_fit (total_writes - previous_total_writes, 10, 5, 5, str [15] (15, 5));
    pmp$binary_to_ascii_fit (total_reads - previous_total_reads, 10, 5, 5, str [16] (15, 5));



{ Display I/O Priority information

{   preads := iov$read_priority_invoked;
{   pmp$binary_to_ascii_fit (preads, 10,10,10, str [20] (14,10));
{   ptotal := iov$total_queue_calls;
{   pmp$binary_to_ascii_fit (ptotal, 10,10,10, str [20] (39,10));
{   pactual := iov$total_queue_calls - iov$actual_requests_resolved;
{   pmp$binary_to_ascii_fit (pactual, 10,10,10, str [20] (64,10));

    previous_pf_data^ := pfd_p^;
    previous_server_pf_data^ := server_pfd_p^;
    previous_total_reads := total_reads;
    previous_total_writes := total_writes;

{ Display rejects

   pmp$binary_to_ascii_fit(iov$reject_requests_full,10,7,7,str[18] (14,7));
   pmp$binary_to_ascii_fit(iov$reject_unit_queue_limit,10,7,7,str[17] (14,7));

{ Display QuickSweep statistics, this is count of stale pages flushed during
{ the quicksweep cycle. First is the number of modified pages flushed and next
{ is the total flushed. These values are reset every ten minutes.


   pmp$binary_to_ascii_fit(strm,10,7,7,str[17] (34,7));
   pmp$binary_to_ascii_fit(strr,10,7,7,str[18] (34,7));
   pmp$binary_to_ascii_fit(strjm,10,7,7,str[19] (34,7));
   pmp$binary_to_ascii_fit(strjr,10,7,7,str[20] (34,7));





{ Display the results.

    IF wid <> 0 THEN
      dpp$clear_window (wid, status);
      FOR i := 1 TO max_lines DO
        dpp$put_next_line (wid, str [i], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND
    ELSE
      FOR i := 1 TO max_lines DO
        clp$put_display (display_control, str [i], clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
      clp$close_display (display_control, status);
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND ofp$special_statistics_display;
?? OLDTITLE ??
MODEND ofm$special_statistics_display

*DECK DECK=OFM$SYSTEM_HEADER_DISPLAY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operator Facility : System Header Display' ??
MODULE ofm$system_header_display;

{ This module contains the code that updates the system header line of the system console.
{ It also deals with updating time every day to assure its accuracy.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dpc$console_row_size
*copyc ose$default_process_exceptions
*copyc oss$task_private
?? POP ??
*copyc dpp$set_title
*copyc dsp$log_dft_top_of_hour
*copyc ofp$report_status_error
*copyc osp$change_date_time
*copyc osp$change_hardware_date_time
*copyc osp$clear_defaults_changed_flag
*copyc osp$initialize_date_time
*copyc osp$update_wait_frc
*copyc pmp$get_date
*copyc pmp$get_os_version
*copyc pmp$get_time
*copyc pmp$log_ascii
?? EJECT ??
*copyc dpv$critical_display_id
*copyc dsv$mainframe_type
*copyc osv$170_os_type
*copyc osv$date_time_update
*copyc osv$os_defaults
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    v$last_hour: [oss$task_private] string (2) := '00',
    v$title: [oss$task_private] string (dpc$console_row_size) := ' ';
?? OLDTITLE ??
?? NEWTITLE := 'ofp$system_header_display', EJECT ??

  PROCEDURE [XDCL] ofp$system_header_display;

    VAR
      current_time: ost$free_running_clock,
      date: ost$date,
      date_entry: string (78),
      date_entry_length: integer,
      hour: string (2),
      local_status: ost$status,
      time: ost$time,
      unused_os_defaults: ost$operating_system_default,
      version : pmt$os_name;

    { If, in dual state, the NOS operator has changed the date/time, OR if running on a Cyber 2000 mainframe
    { and the service processor has changed the date/time, update the NOS/VE date/time.  The hardware clock
    { has been updated by the NOS or by the service processor.

    IF osv$date_time_update AND ((osv$170_os_type <> osc$ot7_none) OR
          (dsv$mainframe_type = dsc$mt_2000_mainframe)) THEN
      osp$initialize_date_time (local_status);
      IF NOT local_status.normal THEN
        ofp$report_status_error (local_status, 'OFM$SYSTEM_HEADER_DISPLAY - initializing time and date');
      ELSE
        IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
          pmp$log_ascii ('System date/time changed by the service processor.',
                $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system, local_status);
        ELSE
          pmp$log_ascii ('System date/time changed by the NOS operator.',
                $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system, local_status);
        IFEND;
      IFEND;
    IFEND;

    { Update the hardware date/time at top of minute, if necessary.  If the current time is greater then
    { the maximum wait time then adjust the maximum wait time by multiples of one minute to be greater then
    { current time.  If the current time is between the minimum wait time and the maximum wait time then
    { change the hardware date/time.

    IF osv$os_defaults.time_data.wait_to_change THEN
      current_time := #FREE_RUNNING_CLOCK (0);
      IF current_time >= osv$os_defaults.time_data.wait_frc.max THEN
        osp$update_wait_frc (current_time);
      IFEND;
      IF (current_time >= osv$os_defaults.time_data.wait_frc.min) AND
            (current_time <= osv$os_defaults.time_data.wait_frc.max) THEN
        osp$change_hardware_date_time (local_status);
        IF NOT local_status.normal THEN
          ofp$report_status_error (local_status, 'OFM$SYSTEM_HEADER_DISPLAY - changing hardware date/time');
        IFEND;
      IFEND;
    IFEND;

    pmp$get_time (osc$hms_time, time, local_status);
    IF NOT local_status.normal THEN
      ofp$report_status_error (local_status, 'OFM$SYSTEM_HEADER_DISPLAY - getting time');
      hour := '00';
    ELSE
      v$title (44, 8) := time.hms;
      hour := time.hms (1, 2);
    IFEND;

    IF osv$os_defaults.defaults_changed THEN
      pmp$get_date (osc$mdy_date, date, local_status);
      IF NOT local_status.normal THEN
        ofp$report_status_error (local_status, 'OFM$SYSTEM_HEADER_DISPLAY - getting date');
      ELSE
        v$title (53, 10) := date.mdy;
      IFEND;
      pmp$get_os_version (version, local_status);
      IF NOT local_status.normal THEN
        ofp$report_status_error (local_status, 'OFM$SYSTEM_HEADER_DISPLAY - getting version');
      ELSE
        v$title (1, STRLENGTH(version)) := version;
      IFEND;
    IFEND;

    dpp$set_title (dpv$critical_display_id, v$title, local_status);
    IF NOT local_status.normal THEN
      ofp$report_status_error (local_status, 'OFM$SYSTEM_HEADER_DISPLAY - setting title');
    IFEND;

    IF osv$os_defaults.defaults_changed THEN
      osp$clear_defaults_changed_flag;
    IFEND;

    { Emit TOP-OF-HOUR statistics if the 'hour' part of the current time has changed and update the date/time
    { in the MRT if hour indicates midnight has occurred.

    IF hour <> v$last_hour THEN
      dsp$log_dft_top_of_hour;
      v$last_hour := hour;
      IF hour = '00' THEN
        osp$change_date_time (FALSE, unused_os_defaults, local_status);
        IF NOT local_status.normal AND (local_status.condition <> ose$not_allowed_in_dual_state) THEN
          ofp$report_status_error (local_status, 'OFM$SYSTEM_HEADER_DISPLAY - updating time at midnight');
        IFEND;
        pmp$get_date (osc$month_date, date, local_status);
        IF NOT local_status.normal THEN
          ofp$report_status_error (local_status, 'OFM$SYSTEM_HEADER_DISPLAY - getting date');
        IFEND;
        STRINGREP (date_entry, date_entry_length, '*********   CURRENT DATE IS NOW ', date.month);
        pmp$log_ascii (date_entry (1, date_entry_length), $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, local_status);
      IFEND;
    IFEND;

  PROCEND ofp$system_header_display;
?? OLDTITLE ??
MODEND ofm$system_header_display;
*DECK DECK=OFM$SYSTEM_OPERATOR_UTILITY_2DD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operator Facility : System Operator Utility' ??
MODULE ofm$system_operator_utility_2dd;

{ PURPOSE:
{   This module contains the command processing procedures for the System
{   Operator Utility (SOU).

?? TITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc clt$integer
*copyc ofd$type_definition
*copyc ofe$error_codes
*copyc oft$menu_selections
*copyc oft$operator_alarm
*copyc oft$operator_menu_descriptor
*copyc oss$job_paged_literal
*copyc ost$status
*copyc ost$string
?? POP ??
*copyc amp$get_next
*copyc amp$put_next
*copyc avp$accounting_administrator
*copyc avp$configuration_administrator
*copyc avp$family_administrator
*copyc avp$removable_media_admin
*copyc avp$removable_media_operator
*copyc avp$system_administrator
*copyc avp$system_displays
*copyc avp$system_operator
*copyc clp$close_display
*copyc clp$convert_string_to_file_ref
*copyc clp$evaluate_parameters
*copyc clp$evaluate_token
*copyc clp$get_value
*copyc clp$include_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$scan_parameter_list
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc ofp$get_active_operator_alarms
*copyc ofp$get_first_operator_menu
*copyc ofp$get_menu_help_text
*copyc ofp$get_next_operator_menu
*copyc ofp$store_menu_choice
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pmp$long_term_wait

?? TITLE := 'ofp$display_active_capabilities', EJECT ??

  PROCEDURE [XDCL, #GATE] ofp$display_active_capabilities
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$sysou_disac) display_active_capabilities (
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 7, 5, 12, 22, 6, 856], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$DISAC'],
            [['O                              ', clc$abbreviation_entry, 1],
            ['OUTPUT                         ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 2]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type], '$output'],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   The purpose of this command is to display a list of the capabilities that
{   are currently active within the System Operator Utility.
{

    PROCEDURE abort_handler
      (    ignore_condition: pmt$condition;
           ignore_condition_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF output_open THEN
        clp$close_display (display_control, handler_status);
        output_open := FALSE;
      IFEND;
      handler_status.normal := TRUE;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    CONST
      blank_line = ' ',
      title_line = 'The following SOU capabilities are currently active:';

    VAR
      capability_active: boolean,
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      local_status: ost$status,
      output: fst$parsed_file_reference,
      output_open: boolean;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$output].specified THEN
      clp$convert_string_to_file_ref (pvt [p$output].value^.file_value^, output, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      output.path := clc$standard_output;
    IFEND;

    output_open := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);
    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
    clp$open_display_reference (output.path, NIL, fsc$list, default_ring_attributes, display_control,
          status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

    output_open := TRUE;

  /display_capabilities/
    BEGIN
      clp$put_display (display_control, blank_line, clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_capabilities/;
      IFEND;

      clp$put_display (display_control, title_line, clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_capabilities/;
      IFEND;

      clp$put_display (display_control, blank_line, clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_capabilities/;
      IFEND;

      capability_active := FALSE;

      IF avp$accounting_administrator () THEN
        clp$put_display (display_control, '    accounting_administration', clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display_capabilities/;
        IFEND;

        capability_active := TRUE;
      IFEND;

      IF avp$configuration_administrator () THEN
        clp$put_display (display_control, '    configuration_administration', clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display_capabilities/;
        IFEND;

        capability_active := TRUE;
      IFEND;

      IF avp$family_administrator () THEN
        clp$put_display (display_control, '    family_administration', clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display_capabilities/;
        IFEND;

        capability_active := TRUE;
      IFEND;

      IF avp$removable_media_admin () THEN
        clp$put_display (display_control, '    removable_media_administration', clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display_capabilities/;
        IFEND;

        capability_active := TRUE;
      IFEND;

      IF avp$removable_media_operator () THEN
        clp$put_display (display_control, '    removable_media_operation', clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display_capabilities/;
        IFEND;

        capability_active := TRUE;
      IFEND;

      IF avp$system_administrator () THEN
        clp$put_display (display_control, '    system_administration', clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display_capabilities/;
        IFEND;

        capability_active := TRUE;
      IFEND;

      IF avp$system_displays () THEN
        clp$put_display (display_control, '    system_displays', clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display_capabilities/;
        IFEND;

        capability_active := TRUE;
      IFEND;

      IF avp$system_operator () THEN
        clp$put_display (display_control, '    system_operation', clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display_capabilities/;
        IFEND;

        capability_active := TRUE;
      IFEND;

      IF NOT capability_active THEN
        clp$put_display (display_control, '    *** NONE ***', clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display_capabilities/;
        IFEND;
      IFEND;

      clp$put_display (display_control, blank_line, clc$trim, status);
      IF NOT status.normal THEN
        EXIT /display_capabilities/;
      IFEND;

    END /display_capabilities/;

    clp$close_display (display_control, local_status);
    output_open := FALSE;
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND ofp$display_active_capabilities;

?? TITLE := 'ofp$display_operator_menus_cmd', EJECT ??

{ PURPOSE:
{   The purpose of this command is to display entries in the list of operator
{   action menus and to store an operator's choice from a menu.
{

  PROCEDURE [XDCL, #GATE] ofp$display_operator_menus_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$disoam) display_operator_action_menus, disoam (
{   STATUS)

?? PUSH (LISTEXT := ON) ??

  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,
      recend,
    recend := [
    [1,
    [88, 8, 15, 9, 40, 37, 856],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'OSM$DISOAM'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$status = 1;

  VAR
    pvt: array [1 .. 1] of clt$parameter_value;

    CONST
      title_line_size = 36;

    VAR
      blank_line: [READ, oss$job_paged_literal] string (2) := '  ',
      choice: clt$lexical_token,
      condition_cleared_message: [READ, oss$job_paged_literal] string (71) :=
            ' --INFORMATIVE-- The condition described by this menu no longer exists.',
      error_line_p: ^string ( * <= 80),
      file_position: amt$file_position,
      help_text_found: boolean,
      help_text_line_count: oft$number_of_displayable_lines,
      help_text_p: ^oft$menu_selections,
      iba: amt$file_byte_address,
      ignore_status: ost$status,
      index: clt$string_index,
      input: amt$file_identifier,
      invalid_input_message: [READ, oss$job_paged_literal] string (66) :=
            ' --ERROR-- You must enter +, QUIT, or the number of a menu choice.',
      menu_current: oft$menu_id,
      menu_descriptor: oft$operator_menu_descriptor,
      menu_line: 1 .. ofc$max_menu_lines,
      oba: amt$file_byte_address,
      one_menu_available_message: [READ, oss$job_paged_literal] string (64) :=
            ' --INFORMATIVE-- Only the current menu is available for display.',
      output: amt$file_identifier,
      press_return_line_advance: [READ, oss$job_paged_literal] string (42) :=
            ' Press RETURN to advance to the next menu.',
      press_return_line_continue: [READ, oss$job_paged_literal] string (37) :=
            ' Press RETURN when ready to continue.',
      prompt_line1: [READ, oss$job_paged_literal] string (64) :=
            ' Enter the number of your choice, + to advance, or QUIT to exit.',
      prompt_line2: [READ, oss$job_paged_literal] string (61) :=
            ' For help, enter ? or n? (where n is the number of a choice).',
      reply: string (80),
      response_string: ost$string,
      spaces_preceded_token: boolean,

{ If the size of the title is changed, the size of the title_line variable should also
{ be changed. The proper relationship is calculated as follows:
{
{            SIZE of title_line = SIZE of title + 1 + jmc$system_supplied_name_size

      title: [READ, oss$job_paged_literal] string (36) := '1NOS/VE Operator Action Menu for job',
      title_line: string (title_line_size + 1 + jmc$system_supplied_name_size),
      transfer_count: amt$transfer_count;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ofp$get_first_operator_menu (menu_descriptor, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$open_file (clc$standard_output, amc$record, NIL, NIL, NIL, NIL, NIL, output, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$open_file (clc$standard_input, amc$record, NIL, NIL, NIL, NIL, NIL, input, status);
    IF NOT status.normal THEN
      fsp$close_file (output, ignore_status);
      RETURN;
    IFEND;

    error_line_p := NIL;

{ The following loop is the main processing code for operator interaction with
{ the menu list. The code allows the operator to advance in a circular manner
{ through the list of menus. The normal exit from the loop occurs as  soon as the
{ operator makes a valid choice for one of the menus or when the operator types
{ the word QUIT.

  /display/
    WHILE TRUE DO
      IF error_line_p <> NIL THEN
        amp$put_next (output, error_line_p, #SIZE (error_line_p^), oba, status);
        IF NOT status.normal THEN
          EXIT /display/;
        IFEND;

        IF error_line_p <> ^condition_cleared_message THEN
          amp$put_next (output, ^press_return_line_continue, #SIZE (press_return_line_continue),
                oba, status);
          IF NOT status.normal THEN
            EXIT /display/;
          IFEND;

        ELSE
          amp$put_next (output, ^press_return_line_advance, #SIZE (press_return_line_advance),
                oba, status);
          IF NOT status.normal THEN
            EXIT /display/;
          IFEND;
        IFEND;

        amp$get_next (input, ^reply, #SIZE (reply), transfer_count, iba, file_position, status);
        IF NOT status.normal THEN
          EXIT /display/;
        IFEND;

        IF error_line_p = ^condition_cleared_message THEN
          menu_current := menu_descriptor.menu_id;
          ofp$get_next_operator_menu (menu_current, menu_descriptor, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        error_line_p := NIL;
      IFEND;

      title_line (1, #SIZE (title) + 1) := title;
      title_line (#SIZE (title) + 2, jmc$system_supplied_name_size) := menu_descriptor.job_name;
      amp$put_next (output, ^title_line, #SIZE (title_line), oba, status);
      IF NOT status.normal THEN
        EXIT /display/;
      IFEND;

      amp$put_next (output, ^blank_line, #SIZE (blank_line), oba, status);
      IF NOT status.normal THEN
        EXIT /display/;
      IFEND;

      FOR menu_line := 1 TO menu_descriptor.number_of_displayable_lines DO
        amp$put_next (output, ^menu_descriptor.menu_text [menu_line],
              #SIZE (menu_descriptor.menu_text [menu_line]), oba, status);
        IF NOT status.normal THEN
          EXIT /display/;
        IFEND;
      FOREND;

      amp$put_next (output, ^blank_line, #SIZE (blank_line), oba, status);
      IF NOT status.normal THEN
        EXIT /display/;
      IFEND;

      amp$put_next (output, ^prompt_line1, #SIZE (prompt_line1), oba, status);
      IF NOT status.normal THEN
        EXIT /display/;
      IFEND;

      amp$put_next (output, ^prompt_line2, #SIZE (prompt_line2), oba, status);
      IF NOT status.normal THEN
        EXIT /display/;
      IFEND;

      reply := ' ';
      amp$get_next (input, ^reply, #SIZE (reply), transfer_count, iba, file_position, status);
      IF NOT status.normal THEN
        EXIT /display/;
      IFEND;

      IF transfer_count = 0 THEN
        error_line_p := ^invalid_input_message;
        CYCLE /display/;
      IFEND;

      index := 1;
      clp$evaluate_token (reply, $clt$token_evaluation_options [], index, spaces_preceded_token, choice,
            status);
      IF NOT (status.normal AND (choice.text_size > 0)) THEN
        error_line_p := ^invalid_input_message;
        status.normal := TRUE;
        CYCLE /display/;
      IFEND;

      IF (choice.kind = clc$name_token) THEN
        IF (choice.str.value = 'QUIT') OR (choice.str.value = 'QUI') THEN
          EXIT /display/;
        ELSE
          error_line_p := ^invalid_input_message;
        IFEND;
      ELSEIF (choice.kind = clc$add_token) THEN
        menu_current := menu_descriptor.menu_id;
        ofp$get_next_operator_menu (menu_current, menu_descriptor, status);
        IF NOT status.normal THEN
          IF status.condition = ofe$one_menu_available THEN
            error_line_p := ^one_menu_available_message;
            status.normal := TRUE;
            CYCLE /display/;
          IFEND;
          EXIT /display/;
        IFEND;
      ELSE
        IF (choice.kind = clc$query_token) THEN
          response_string.size := 1;
          response_string.value (1, 1) := '?';
          choice.int.value := ofc$max_menu_lines;
        ELSEIF (choice.kind = clc$unsigned_integer_token) AND (choice.int.value > 0) AND
              (choice.int.value <= menu_descriptor.number_of_choices) THEN
          response_string.size := clp$trimmed_string_size (reply (index, 81 - index));
          IF response_string.size > 0 THEN
            response_string.value (1, response_string.size) := reply (index, response_string.size);
          ELSE
            response_string.value := '';
          IFEND;
        ELSE
          error_line_p := ^invalid_input_message;
          CYCLE /display/;
        IFEND;

{ The operator has made a valid choice from the menu. Store the choice in the
{ menu descriptor.

        ofp$store_menu_choice (menu_descriptor.menu_id, choice.int.value, response_string, status);
        IF NOT status.normal THEN
          IF status.condition = ofe$invalid_menu_id THEN
            error_line_p := ^condition_cleared_message;
            status.normal := TRUE;
            CYCLE /display/;
          IFEND;
          EXIT /display/;
        IFEND;

        IF response_string.value (1, 1) = '?' THEN
          PUSH help_text_p;
          REPEAT
            pmp$long_term_wait (500, 200);
            ofp$get_menu_help_text (menu_descriptor.menu_id, menu_descriptor.source_task, help_text_p,
                  help_text_found, help_text_line_count, status);
            IF NOT status.normal THEN
              IF status.condition = ofe$invalid_menu_id THEN
                error_line_p := ^condition_cleared_message;
                status.normal := TRUE;
                CYCLE /display/;
              IFEND;
              EXIT /display/;
            IFEND;
          UNTIL help_text_found;
          FOR menu_line := 1 TO help_text_line_count DO
            amp$put_next (output, ^help_text_p^ [menu_line], #SIZE (help_text_p^ [menu_line]), oba, status);
            IF NOT status.normal THEN
              EXIT /display/;
            IFEND;
          FOREND;
          amp$put_next (output, ^press_return_line_continue, #SIZE (press_return_line_continue),
                oba, status);
          IF NOT status.normal THEN
            EXIT /display/;
          IFEND;
          amp$get_next (input, ^reply, #SIZE (reply), transfer_count, iba, file_position, status);
          IF NOT status.normal THEN
            EXIT /display/;
          IFEND;

        ELSE
          ofp$get_next_operator_menu (menu_descriptor.menu_id, menu_descriptor, status);
          IF NOT status.normal THEN
            IF status.condition = ofe$no_menus_available THEN
              status.normal := TRUE;
            IFEND;
            EXIT /display/;
          IFEND;
        IFEND;
      IFEND;

    WHILEND /display/;

    fsp$close_file (output, ignore_status);
    fsp$close_file (input, ignore_status);

  PROCEND ofp$display_operator_menus_cmd;

?? TITLE := 'ofp$display_operator_status_cmd', EJECT ??

{ PURPOSE:
{   The purpose of this command is to inform the operator of any
{   existing conditions which require operator action.

  PROCEDURE [XDCL, #GATE] ofp$display_operator_status_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (osm$disoas) display_operator_action_status, disoas (
{    wait, w : boolean = FALSE
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 11, 15, 34, 53, 847],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$DISOAS'], [
    ['STATUS                         ',clc$nominal_entry, 2],
    ['W                              ',clc$abbreviation_entry, 1],
    ['WAIT                           ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 5],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type],
    'FALSE'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$wait = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      active_operator_alarms: oft$operator_alarms,
      blank_line: [READ, oss$job_paged_literal] string (2) := '  ',
      choice: string (80),
      choice_m: [READ, oss$job_paged_literal] string (35) := '      - M to process operator menus',
      choice_o: [READ, oss$job_paged_literal] string (38) := '      - O to process operator messages',
      choice_quit: [READ, oss$job_paged_literal] string (52) :=
            '      - QUIT to terminate operator action processing',
      choice_t: [READ, oss$job_paged_literal] string (40) := '      - T to process tape mount requests',
      choice_token: clt$lexical_token,
      display_op_action_menus_command: [READ, oss$job_paged_literal] string (29) :=
            'display_operator_action_menus',
      error_line_p: ^string ( * <= 80),
      file_position: amt$file_position,
      iba: amt$file_byte_address,
      ignore_status: ost$status,
      index: clt$string_index,
      input: amt$file_identifier,
      invalid_choice: [READ, oss$job_paged_literal] string (38) := ' --ERROR-- An invalid choice was made.',
      multiple_alarm_choice_header: [READ, oss$job_paged_literal] string (35) :=
            ' Please enter one of the following:',
      multiple_alarm_header: [READ, oss$job_paged_literal] string (43) :=
            '1Multiple operator action conditions exist.',
      oba: amt$file_byte_address,
      output: amt$file_identifier,
      press_return_line: [READ, oss$job_paged_literal] string (37) := ' Press RETURN when ready to continue.',
      spaces_preceeded_token: boolean,
      transfer_count: amt$transfer_count,
      vedisplay_om_command: [READ, oss$job_paged_literal] string (29) := 'vedisplay do=operator_message',
      vedisplay_tm_command: [READ, oss$job_paged_literal] string (23) := 'vedisplay do=tape_mount';

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ If the operator specified WAIT = TRUE, then the following loop will wait
{ until an alarm condition becomes active. Though the caller may terminate
{ the command in order to perform other tasks, the WAIT option is primarily
{ intended for remote operators (i.e. not the operator at the main console)
{ who intend to use their terminal strictly to process alarm conditions.

    REPEAT
      ofp$get_active_operator_alarms (active_operator_alarms);
      IF (active_operator_alarms = $oft$operator_alarms []) THEN
        IF NOT pvt [p$wait].value^.boolean_value.value THEN
          osp$set_status_abnormal (ofc$operator_facility_id, ofe$no_alarms_active, ' ', status);
          RETURN;
        ELSE
          pmp$long_term_wait (10000, 10000);
        IFEND;
      IFEND;
    UNTIL active_operator_alarms <> $oft$operator_alarms [];

    IF active_operator_alarms = $oft$operator_alarms [ofc$tape_mounts] THEN
      clp$include_line (vedisplay_tm_command, TRUE, osc$null_name, status);
      RETURN;
    ELSEIF active_operator_alarms = $oft$operator_alarms [ofc$menu_requests] THEN
      clp$include_line (display_op_action_menus_command, TRUE, osc$null_name, status);
      RETURN;
    ELSEIF active_operator_alarms = $oft$operator_alarms [ofc$operator_messages] THEN
      clp$include_line (vedisplay_om_command, TRUE, osc$null_name, status);
      RETURN;
    IFEND;

{ Multiple alarm conditions exist. Give the operator the opportunity to select the
{ condition to be processed.

    fsp$open_file (clc$standard_output, amc$record, NIL, NIL, NIL, NIL, NIL, output, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$open_file (clc$standard_input, amc$record, NIL, NIL, NIL, NIL, NIL, input, status);
    IF NOT status.normal THEN
      fsp$close_file (output, ignore_status);
      RETURN;
    IFEND;

    error_line_p := NIL;

  /process_alarms/
    WHILE TRUE DO
      IF error_line_p <> NIL THEN
        amp$put_next (output, error_line_p, #SIZE (error_line_p^), oba, status);
        IF NOT status.normal THEN
          EXIT /process_alarms/;
        IFEND;

        error_line_p := NIL;
        amp$put_next (output, ^press_return_line, #SIZE (press_return_line), oba, status);
        IF NOT status.normal THEN
          EXIT /process_alarms/;
        IFEND;

        amp$get_next (input, ^choice, #SIZE (choice), transfer_count, iba, file_position, status);
        IF NOT status.normal THEN
          EXIT /process_alarms/;
        IFEND;
      IFEND;

      amp$put_next (output, ^multiple_alarm_header, #SIZE (multiple_alarm_header), oba, status);
      IF NOT status.normal THEN
        EXIT /process_alarms/;
      IFEND;

      amp$put_next (output, ^multiple_alarm_choice_header, #SIZE (multiple_alarm_choice_header), oba, status);
      IF NOT status.normal THEN
        EXIT /process_alarms/;
      IFEND;

      amp$put_next (output, ^blank_line, #SIZE (blank_line), oba, status);
      IF NOT status.normal THEN
        EXIT /process_alarms/;
      IFEND;

      IF ofc$menu_requests IN active_operator_alarms THEN
        amp$put_next (output, ^choice_m, #SIZE (choice_m), oba, status);
        IF NOT status.normal THEN
          EXIT /process_alarms/;
        IFEND;
      IFEND;

      IF ofc$operator_messages IN active_operator_alarms THEN
        amp$put_next (output, ^choice_o, #SIZE (choice_o), oba, status);
        IF NOT status.normal THEN
          EXIT /process_alarms/;
        IFEND;
      IFEND;

      IF ofc$tape_mounts IN active_operator_alarms THEN
        amp$put_next (output, ^choice_t, #SIZE (choice_t), oba, status);
        IF NOT status.normal THEN
          EXIT /process_alarms/;
        IFEND;
      IFEND;

      amp$put_next (output, ^blank_line, #SIZE (blank_line), oba, status);
      IF NOT status.normal THEN
        EXIT /process_alarms/;
      IFEND;

      amp$put_next (output, ^choice_quit, #SIZE (choice_quit), oba, status);
      IF NOT status.normal THEN
        EXIT /process_alarms/;
      IFEND;

      choice := ' ';
      amp$get_next (input, ^choice, #SIZE (choice), transfer_count, iba, file_position, status);
      IF NOT status.normal THEN
        EXIT /process_alarms/;
      IFEND;

      index := 1;
      clp$evaluate_token (choice, $clt$token_evaluation_options [], index, spaces_preceeded_token,
            choice_token, status);
      IF ((NOT status.normal) AND (choice_token.text_size > 0)) OR (NOT (choice_token.kind = clc$name_token))
            THEN
        error_line_p := ^invalid_choice;
        CYCLE /process_alarms/;
      IFEND;

      IF (choice_token.str.value = 'QUIT') OR (choice_token.str.value = 'QUI') THEN
        EXIT /process_alarms/;
      IFEND;

      IF ((choice_token.str.value = 'M') AND (ofc$menu_requests IN active_operator_alarms)) THEN
        clp$include_line (display_op_action_menus_command, TRUE, osc$null_name, status);
        EXIT /process_alarms/;
      ELSEIF ((choice_token.str.value = 'O') AND (ofc$operator_messages IN active_operator_alarms)) THEN
        clp$include_line (vedisplay_om_command, TRUE, osc$null_name, status);
        EXIT /process_alarms/;
      ELSEIF ((choice_token.str.value = 'T') AND (ofc$tape_mounts IN active_operator_alarms)) THEN
        clp$include_line (vedisplay_tm_command, TRUE, osc$null_name, status);
        EXIT /process_alarms/;
      ELSE
        error_line_p := ^invalid_choice;
      IFEND;
    WHILEND /process_alarms/;

    fsp$close_file (output, ignore_status);
    fsp$close_file (input, ignore_status);

  PROCEND ofp$display_operator_status_cmd;
MODEND ofm$system_operator_utility_2dd;
*DECK DECK=OFM$SYSTEM_OPERATOR_UTILITY_R3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operator Facility : System Operator Utility' ??
MODULE ofm$system_operator_utility_r3;

{ PURPOSE:
{   This module contains the ring 3 support procedures for the System
{   Operator Utility (SOU).
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$redundancy_in_selections
*copyc oft$operator_classes
?? POP ??
*copyc avp$activate_capabilities
*copyc avp$check_for_console_operation
*copyc avp$configuration_administrator
*copyc avp$get_capability
*copyc avp$removable_media_admin
*copyc avp$removable_media_operator
*copyc avp$system_operator
*copyc avp$system_displays
*copyc clp$change_variable
*copyc clp$evaluate_parameters
*copyc clp$get_variable_value
*copyc osp$get_system_constant
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := 'Global declarations for this module', EJECT ??

{   Array indices for SCL record type for SELECTED variable.

    CONST
      i$accnt     = 1,        {accounting_administration index}
      i$config    = 2,        {configuration_administration index}
      i$fam       = 3,        {family_administration index}
      i$rma       = 4,        {removable_media_administration index}
      i$rmo       = 5,        {removable_media_operation index}
      i$sys_admin = 6,        {system_administration index}
      i$sys_disp  = 7,        {system_displays index}
      i$sys_oper  = 8,        {system_operation index}

      max_valid_capability_index = 8;
?? OLDTITLE ??
?? NEWTITLE := 'ofp$activate_sou_capabilities', EJECT ??

  PROCEDURE [XDCL, #GATE] ofp$activate_sou_capabilities
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{    PROCEDURE (osm$sysou_actsc) activate_sou_capabilities (
{      selected_capabilities: record
{          accounting_administration : boolean,
{          configuration_administration : boolean,
{          family_administration : boolean,
{          removable_media_administration : boolean,
{          removable_media_operation : boolean,
{          system_administration : boolean,
{          system_displays : boolean,
{          system_operation : boolean,
{        recend = $required
{      status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
        recend,
        field_spec_4: clt$field_specification,
        element_type_spec_4: record
          header: clt$type_specification_header,
        recend,
        field_spec_5: clt$field_specification,
        element_type_spec_5: record
          header: clt$type_specification_header,
        recend,
        field_spec_6: clt$field_specification,
        element_type_spec_6: record
          header: clt$type_specification_header,
        recend,
        field_spec_7: clt$field_specification,
        element_type_spec_7: record
          header: clt$type_specification_header,
        recend,
        field_spec_8: clt$field_specification,
        element_type_spec_8: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 6, 13, 49, 15, 510],
    clc$command, 2, 2, 1, 0, 0, 0, 2, 'OSM$SYSOU_ACTSC'], [
    ['SELECTED_CAPABILITIES          ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 319, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$record_type], [8],
    ['ACCOUNTING_ADMINISTRATION      ', clc$required_field, 3], [[1, 0,
  clc$boolean_type]],
    ['CONFIGURATION_ADMINISTRATION   ', clc$required_field, 3], [[1, 0,
  clc$boolean_type]],
    ['FAMILY_ADMINISTRATION          ', clc$required_field, 3], [[1, 0,
  clc$boolean_type]],
    ['REMOVABLE_MEDIA_ADMINISTRATION ', clc$required_field, 3], [[1, 0,
  clc$boolean_type]],
    ['REMOVABLE_MEDIA_OPERATION      ', clc$required_field, 3], [[1, 0,
  clc$boolean_type]],
    ['SYSTEM_ADMINISTRATION          ', clc$required_field, 3], [[1, 0,
  clc$boolean_type]],
    ['SYSTEM_DISPLAYS                ', clc$required_field, 3], [[1, 0,
  clc$boolean_type]],
    ['SYSTEM_OPERATION               ', clc$required_field, 3], [[1, 0,
  clc$boolean_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$selected_capabilities = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      capabilities: avt$conditional_capabilities;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the console operation only security option is enforced if on.

    avp$check_for_console_operation ('System operation', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    capabilities := $avt$conditional_capabilities [];

    IF pvt [p$selected_capabilities].value^.field_values^ [i$accnt].value^.boolean_value.value THEN
        capabilities := capabilities + $avt$conditional_capabilities [avc$cc_accounting_admin];
    IFEND;

    IF pvt [p$selected_capabilities].value^.field_values^ [i$config].value^.boolean_value.value THEN
        capabilities := capabilities + $avt$conditional_capabilities [avc$cc_configuration_admin];
    IFEND;

    IF pvt [p$selected_capabilities].value^.field_values^ [i$fam].value^.boolean_value.value THEN
        capabilities := capabilities + $avt$conditional_capabilities [avc$cc_family_admin];
    IFEND;

    IF pvt [p$selected_capabilities].value^.field_values^ [i$rma].value^.boolean_value.value THEN
        capabilities := capabilities + $avt$conditional_capabilities [avc$cc_removable_media_admin];
    IFEND;

    IF pvt [p$selected_capabilities].value^.field_values^ [i$rmo].value^.boolean_value.value THEN
        capabilities := capabilities + $avt$conditional_capabilities [avc$cc_removable_media_operator];
    IFEND;

    IF pvt [p$selected_capabilities].value^.field_values^ [i$sys_admin].value^.boolean_value.value THEN
        capabilities := capabilities + $avt$conditional_capabilities [avc$cc_system_admin];
    IFEND;

    IF pvt [p$selected_capabilities].value^.field_values^ [i$sys_disp].value^.boolean_value.value THEN
        capabilities := capabilities + $avt$conditional_capabilities [avc$cc_system_displays];
    IFEND;

    IF pvt [p$selected_capabilities].value^.field_values^ [i$sys_oper].value^.boolean_value.value THEN
        capabilities := capabilities + $avt$conditional_capabilities [avc$cc_system_operator];
    IFEND;

    avp$activate_capabilities (capabilities, 'SYSTEM_OPERATOR_UTILITY        ', status);

  PROCEND ofp$activate_sou_capabilities;
?? TITLE := 'ofp$evaluate_sou_capabilities', EJECT ??

  PROCEDURE [XDCL, #GATE] ofp$evaluate_sou_capabilities
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{       PROCEDURE (osm$sysou_evasc) evaluate_sou_capabilities (
{         selected_capabilities: (VAR) record
{             accounting_administration : boolean,
{             configuration_administration : boolean,
{             family_administration : boolean,
{             removable_media_administration : boolean,
{             removable_media_operation : boolean,
{             system_administration : boolean,
{             system_displays : boolean,
{             system_operation : boolean,
{           recend = $required
{         capabilities, capability, c: list of key
{             (accounting_administration, aa)
{             (configuration_administration, ca)
{             (family_administration, fa)
{             (removable_media_administration, rma)
{             (removable_media_operation, rmo)
{             (system_administration, sa)
{             (system_displays, sd)
{             (system_operation, so)
{           keyend = $optional
{         status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
        recend,
        field_spec_4: clt$field_specification,
        element_type_spec_4: record
          header: clt$type_specification_header,
        recend,
        field_spec_5: clt$field_specification,
        element_type_spec_5: record
          header: clt$type_specification_header,
        recend,
        field_spec_6: clt$field_specification,
        element_type_spec_6: record
          header: clt$type_specification_header,
        recend,
        field_spec_7: clt$field_specification,
        element_type_spec_7: record
          header: clt$type_specification_header,
        recend,
        field_spec_8: clt$field_specification,
        element_type_spec_8: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 16] of clt$keyword_specification,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 13, 15, 18, 27, 527],
    clc$command, 5, 3, 1, 0, 0, 1, 3, 'OSM$SYSOU_EVASC'], [
    ['C                              ',clc$abbreviation_entry, 2],
    ['CAPABILITIES                   ',clc$nominal_entry, 2],
    ['CAPABILITY                     ',clc$alias_entry, 2],
    ['SELECTED_CAPABILITIES          ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 319, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 615, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$record_type], [8],
    ['ACCOUNTING_ADMINISTRATION      ', clc$required_field, 3], [[1, 0,
  clc$boolean_type]],
    ['CONFIGURATION_ADMINISTRATION   ', clc$required_field, 3], [[1, 0,
  clc$boolean_type]],
    ['FAMILY_ADMINISTRATION          ', clc$required_field, 3], [[1, 0,
  clc$boolean_type]],
    ['REMOVABLE_MEDIA_ADMINISTRATION ', clc$required_field, 3], [[1, 0,
  clc$boolean_type]],
    ['REMOVABLE_MEDIA_OPERATION      ', clc$required_field, 3], [[1, 0,
  clc$boolean_type]],
    ['SYSTEM_ADMINISTRATION          ', clc$required_field, 3], [[1, 0,
  clc$boolean_type]],
    ['SYSTEM_DISPLAYS                ', clc$required_field, 3], [[1, 0,
  clc$boolean_type]],
    ['SYSTEM_OPERATION               ', clc$required_field, 3], [[1, 0,
  clc$boolean_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [599, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [16], [
      ['AA                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
      ['ACCOUNTING_ADMINISTRATION      ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['CA                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
      ['CONFIGURATION_ADMINISTRATION   ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['FA                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
      ['FAMILY_ADMINISTRATION          ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['REMOVABLE_MEDIA_ADMINISTRATION ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
      ['REMOVABLE_MEDIA_OPERATION      ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
      ['RMA                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
      ['RMO                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
      ['SA                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
      ['SD                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
      ['SO                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
      ['SYSTEM_ADMINISTRATION          ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
      ['SYSTEM_DISPLAYS                ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
      ['SYSTEM_OPERATION               ', clc$nominal_entry,
  clc$normal_usage_entry, 8]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$selected_capabilities = 1,
      p$capabilities = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      capable: boolean,
      index: integer,
      next_capability_p: ^clt$data_value,
      next_keyword_p: ^clt$data_value,
      selected_capabilities: clt$data_value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Verify that the console operation only security option is enforced if on.

    avp$check_for_console_operation ('System operation', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Initialize the selected_capabilities value such that each field value in the record is FALSE.

    selected_capabilities.kind := clc$record;
    PUSH selected_capabilities.field_values : [1 .. max_valid_capability_index];
    selected_capabilities.field_values^[i$accnt].name := 'ACCOUNTING_ADMINISTRATION';
    selected_capabilities.field_values^[i$config].name := 'CONFIGURATION_ADMINISTRATION';
    selected_capabilities.field_values^[i$fam].name := 'FAMILY_ADMINISTRATION';
    selected_capabilities.field_values^[i$rma].name := 'REMOVABLE_MEDIA_ADMINISTRATION';
    selected_capabilities.field_values^[i$rmo].name := 'REMOVABLE_MEDIA_OPERATION';
    selected_capabilities.field_values^[i$sys_admin].name := 'SYSTEM_ADMINISTRATION';
    selected_capabilities.field_values^[i$sys_disp].name := 'SYSTEM_DISPLAYS';
    selected_capabilities.field_values^[i$sys_oper].name := 'SYSTEM_OPERATION';

    FOR index := 1 TO max_valid_capability_index DO
      PUSH selected_capabilities.field_values^[index].value;
      selected_capabilities.field_values^[index].value^.kind := clc$boolean;
      selected_capabilities.field_values^[index].value^.boolean_value.value := FALSE;
      selected_capabilities.field_values^[index].value^.boolean_value.kind := clc$true_false_boolean;
    FOREND;

{ If the capabilities parameter is specified, verify that each keyword in the list is unique and return the
{ specified capabilities as the selected_capabilities.  Otherwise, return all the capabilities for which
{ the user is validated as the selected_capabilities.

    IF pvt [p$capabilities].specified THEN
      next_capability_p := pvt [p$capabilities].value;
      WHILE next_capability_p <> NIL DO
        next_keyword_p := next_capability_p^.link;
        WHILE next_keyword_p <> NIL DO
          IF next_capability_p^.element_value^.keyword_value =
                next_keyword_p^.element_value^.keyword_value THEN
            osp$set_status_abnormal ('CL', cle$redundancy_in_selections,
                  next_capability_p^.element_value^.keyword_value, status);
            RETURN;
          IFEND;
          next_keyword_p := next_keyword_p^.link;
        WHILEND;

        IF next_capability_p^.element_value^.keyword_value = 'ACCOUNTING_ADMINISTRATION' THEN
          selected_capabilities.field_values^ [i$accnt].value^.boolean_value.value := TRUE;
        ELSEIF next_capability_p^.element_value^.keyword_value = 'CONFIGURATION_ADMINISTRATION' THEN
          selected_capabilities.field_values^ [i$config].value^.boolean_value.value := TRUE;
        ELSEIF next_capability_p^.element_value^.keyword_value = 'FAMILY_ADMINISTRATION' THEN
          selected_capabilities.field_values^ [i$fam].value^.boolean_value.value := TRUE;
        ELSEIF next_capability_p^.element_value^.keyword_value = 'REMOVABLE_MEDIA_ADMINISTRATION' THEN
          selected_capabilities.field_values^ [i$rma].value^.boolean_value.value := TRUE;
        ELSEIF next_capability_p^.element_value^.keyword_value = 'REMOVABLE_MEDIA_OPERATION' THEN
          selected_capabilities.field_values^ [i$rmo].value^.boolean_value.value := TRUE;
        ELSEIF next_capability_p^.element_value^.keyword_value = 'SYSTEM_ADMINISTRATION' THEN
          selected_capabilities.field_values^ [i$sys_admin].value^.boolean_value.value := TRUE;
        ELSEIF next_capability_p^.element_value^.keyword_value = 'SYSTEM_DISPLAYS' THEN
          selected_capabilities.field_values^ [i$sys_disp].value^.boolean_value.value := TRUE;
        ELSEIF next_capability_p^.element_value^.keyword_value = 'SYSTEM_OPERATION' THEN
          selected_capabilities.field_values^ [i$sys_oper].value^.boolean_value.value := TRUE;
        IFEND;

        next_capability_p := next_capability_p^.link;
      WHILEND;

    ELSE
      avp$get_capability (avc$accounting_administration, avc$user, capable, status);
      selected_capabilities.field_values^ [i$accnt].value^.boolean_value.value := capable;
      avp$get_capability (avc$configuration_admin, avc$user, capable, status);
      selected_capabilities.field_values^ [i$config].value^.boolean_value.value := capable;
      avp$get_capability (avc$family_administration, avc$user, capable, status);
      selected_capabilities.field_values^ [i$fam].value^.boolean_value.value := capable;
      avp$get_capability (avc$removable_media_admin, avc$user, capable, status);
      selected_capabilities.field_values^ [i$rma].value^.boolean_value.value := capable;
      avp$get_capability (avc$removable_media_operation, avc$user, capable, status);
      selected_capabilities.field_values^ [i$rmo].value^.boolean_value.value := capable;
      avp$get_capability (avc$system_administration, avc$user, capable, status);
      selected_capabilities.field_values^ [i$sys_admin].value^.boolean_value.value := capable;
      avp$get_capability (avc$system_displays, avc$user, capable, status);
      selected_capabilities.field_values^ [i$sys_disp].value^.boolean_value.value := capable;
      avp$get_capability (avc$system_operation, avc$user, capable, status);
      selected_capabilities.field_values^ [i$sys_oper].value^.boolean_value.value := capable;
    IFEND;

    clp$change_variable (pvt [p$selected_capabilities].variable^, ^selected_capabilities, status);

  PROCEND ofp$evaluate_sou_capabilities;
?? TITLE := 'ofp$get_active_operator_classes', EJECT ??
*copyc ofh$get_active_operator_classes

  PROCEDURE [XDCL, #GATE] ofp$get_active_operator_classes
    (VAR active_operator_classes: oft$operator_classes);

    active_operator_classes := $oft$operator_classes [];
    IF avp$removable_media_operator () THEN
      active_operator_classes := active_operator_classes + $oft$operator_classes
            [ofc$removable_media_operator];
    IFEND;

    IF avp$system_operator () THEN
      active_operator_classes := active_operator_classes + $oft$operator_classes [ofc$system_operator];
    IFEND;

  PROCEND ofp$get_active_operator_classes;

?? TITLE := 'ofp$_get_system_attribute', EJECT ??
  PROCEDURE [XDCL, #GATE] ofp$_get_system_attribute
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE get_system_attribute, getsa (
{   name, n: name = $required
{   on, o: (VAR) boolean = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 7, 26, 13, 27, 58, 6],
    clc$command, 5, 3, 2, 0, 0, 1, 3, ''], [
    ['N                              ',clc$abbreviation_entry, 1],
    ['NAME                           ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['ON                             ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$required_parameter, 0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$boolean_type]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$name = 1,
      p$on = 2,
      p$status = 3;

    VAR
      bool_value_p: ^clt$data_value,
      constant: integer,
      index: integer,
      pvt: array [1 .. 3] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    index := 0;
    osp$get_system_constant (pvt [p$name].value^.name_value, index, constant,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH bool_value_p;
    bool_value_p^.kind := clc$boolean;
    bool_value_p^.boolean_value.value := constant = 1;
    bool_value_p^.boolean_value.kind := clc$true_false_boolean;

    clp$change_variable (pvt [p$on].variable^, bool_value_p, status);

  PROCEND ofp$_get_system_attribute;

MODEND ofm$system_operator_utility_r3;
*DECK DECK=OFM$SYSTEM_OPERATOR_UTL EXPAND=TRUE
PROCEDURE (osm$sysou) system_operator_utility, sysou, sou (
  capabilities, capability, c: list of key
      (accounting_administration, aa)
      (configuration_administration, ca)
      (family_administration, fa)
      (removable_media_administration, rma)
      (removable_media_operation, rmo)
      (system_administration, sa)
      (system_displays, sd)
      (system_operation, so)
    keyend = $optional
  input, i: file = $command
  status)

  VAR
    selected: record
      accounting_administration : boolean,
      configuration_administration : boolean,
      family_administration : boolean,
      removable_media_administration : boolean,
      removable_media_operation : boolean,
      system_administration : boolean,
      system_displays : boolean,
      system_operation : boolean,
    recend
    user_displays_enabled: boolean
    enaud_status: status
  VAREND

  TASK

    $system.osf$sou_library.ofp$evaluate_sou_capabilities selected capabilities

    UTILITY name=system_operator_utility prompt='sou' search_mode=global ..
          libraries=($system.osf$sou_library, $system.osf$builtin_library) ..
          termination_command_name=quit

" Add SOU support subcommands. These commands are available independent of
" the capabilities active.

      command (display_active_capabilities, display_active_capability, disac) ..
            processor=ofp$display_sou_capabilities
      command (quit, end_system_operator_utility, endsou, qui) processor=ofp$end_system_operator_utility

" Add commands that are available if only accounting_administration is active.

"     IF selected.accounting_administration THEN
"     IFEND

" Add commands that are available if only configuration_administration is active.

      IF selected.configuration_administration THEN
        command (activate_set, acts) processor=activate_set
        command (change_default_date_format, chaddf) processor=change_default_date_format
        command (change_default_time_format, chadtf) processor=change_default_time_format
        command (change_dual_state_environment, chadse) processor=change_dual_state_environment
        command (change_job_attribute_default, change_job_attribute_defaults, chajad) ..
              processor=change_job_attribute_default
        command (change_kill_job_action, chakja) processor=change_kill_job_action
        command (change_nam_attributes, change_nam_attribute, chana) processor=change_nam_attributes
        command (change_tape_scan_frequency, chatsf) processor=change_tape_scan_frequency
        command (change_tape_validation, chatv) processor=change_tape_validation
        command (manage_exception_policies, manep) processor=manage_exception_policies
        command (set_system_attribute, setsa) processor=set_system_attribute
      IFEND

" Add commands that are available if only family_administration is active.

"     IF selected.family_administration THEN
"     IFEND

" Add commands that are available if only removable_media_administration is active.

"     IF selected.removable_media_administration THEN
"     IFEND

" Add commands that are available if only removable_media_operation is active.

      IF selected.removable_media_operation THEN
        command (assign_device, assd) processor=assign_device
        command (create_blank_labeled_volume, creblv) processor=create_blank_labeled_volume
        command (create_blank_unlabeled_volume, crebuv) processor=create_blank_unlabeled_volume
        command (initialize_tape_volume, initv) processor=initialize_tape_volume
        command (label_tape_volumes, label_tape_volume, labtv) processor=label_tape_volumes
        command (reassign_device, read) processor=reassign_device
        command (terminate_tape_assignment, terta) processor=terminate_tape_assignment
      IFEND

" Add commands that are available if only system_administration is active.

      IF selected.system_administration THEN
        command (activate_archive_ve, actav) processor=activate_archive_ve
        command (administer_security_audit, admsa) processor=administer_security_audit
        command (backup_job_files, bacjf) processor=jmp$backup_job_files
        command (backup_output_files, bacof) processor=jmp$backup_output_files
        command (change_family) processor=change_family
        command (change_operation_password chaop) processor=change_operation_password
        command (create_aged_file_backup, creafb, archive_files, arcf) processor=create_aged_file_backup
        command (create_catalog_backup, crecb, backup_catalogs, bacc) processor=create_catalog_backup
        command (create_family) processor=create_family
        command (create_full_backup, crefb, full_backup, fulb) processor=create_full_backup
        command (create_partial_backup, crepb, partial_backup, parb) processor=create_partial_backup
        command (deactivate_archive_ve, deaav) processor=deactivate_archive_ve
        command (delete_expired_files, delef) processor=delete_expired_files
        command (disable_main_operator_window, dismow) processor=disable_main_operator_window
        command (display_all_files, disaf) processor=display_all_files
        command (display_unreconciled_files, disuf) processor=display_unreconciled_files
        command (enable_main_operator_window, enamow) processor=enable_main_operator_window
        command pup$construct_volume_list processor=pup$construct_volume_list a=hidden
        command pup$generate_backup_listing processor=pup$generate_backup_listing a=hidden
        command (restore_cataloged_files, rescf, restore, res) processor=restore_cataloged_files
        command (restore_job_files, resjf) processor=jmp$restore_job_files
        command (restore_output_files, resof) processor=jmp$restore_output_files
        command (restore_unreconciled_catalogs, resuc, restore_missing_catalogs, resmc) ..
              processor=restore_unreconciled_catalogs
        command (restore_unreconciled_files, resuf, restore_lost_cycles, reslc) ..
              processor=restore_unreconciled_files
        command (set_operation_password, setop) processor=set_operation_password
        command (set_operation_interval, setoi) processor=set_operation_interval
      IFEND

" Add commands that are available if ENABLE_USER_DISPLAYS system attribute is active.

      $system.osf$sou_library.ofp$_get_system_attribute enable_user_displays user_displays_enabled ..
            status=enaud_status
      IF NOT enaud_status.normal THEN
        display_value value=enaud_status output=output
        put_line ' User display commands will not be available.' output=output
      ELSEIF user_displays_enabled THEN
        command (display_all_input, disai) processor=display_all_input
        command (display_all_output, disao) processor=display_all_output
        command (display_site_ved_names, dissvn) processor=display_site_ved_names
        command (vedisplay, ved) processor=vedisplay
        command (ved_utility, vedu) processor=ved_utility
      IFEND

" Add commands that are available if only system_operation is active.

      IF selected.system_operation THEN
        command (activate_btfs) processor=activate_btfs
        command (activate_drje) processor=activate_drje
        command (activate_ftam_responder) processor=activate_ftam_responder
        command (activate_history_log, acthl) processor=activate_history_log
        command (activate_mail_delivery_agent, actmda) processor=activate_mail_delivery_agent
        command (activate_mail_gateway) processor=activate_mail_gateway
        command (activate_mailve) processor=activate_mailve
        command (activate_network_clock, actnc) processor=activate_network_clock
        command (activate_network_file_access, actnfa) processor=activate_network_file_access
        command (activate_network_initializer, actni) processor=activate_network_initializer
        command (activate_network_log, actnl) processor=activate_network_log
        command (activate_ntf) processor=activate_ntf
        command (activate_ntf_mail) processor=activate_ntf_mail
        command (activate_ptf) processor=activate_ptf
        command (activate_qtf) processor=activate_qtf
        command (activate_qtfs) processor=activate_qtfs
        command (activate_scf) processor=activate_scf
        command (activate_scfs) processor=activate_scfs
        command (activate_system_logging, actsl) processor=activate_system_logging
        command (activate_system_task, activate_system_tasks, actst) processor=activate_system_task
        command (activate_xtf) processor=activate_xtf
        command (change_date, chad) processor=change_date
        command (change_priority, chap) processor=change_priority
        command (change_time, chat) processor=change_time
        command (change_time_zone, chatz) processor=change_time_zone
        command (deactivate_btfs) processor=deactivate_btfs
        command (deactivate_drje) processor=deactivate_drje
        command (deactivate_ftam_responder) processor=deactivate_ftam_responder
        command (deactivate_history_log, deahl) processor=deactivate_history_log
        command (deactivate_mail_delivery_agent, deamda) processor=deactivate_mail_delivery_agent
        command (deactivate_mail_gateway) processor=deactivate_mail_gateway
        command (deactivate_mailve) processor=deactivate_mailve
        command (deactivate_network_clock, deanc) processor=deactivate_network_clock
        command (deactivate_network_file_access, deanfa) processor=deactivate_network_file_access
        command (deactivate_network_initializer, deani) processor=deactivate_network_initializer
        command (deactivate_network_log, deanl) processor=deactivate_network_log
        command (deactivate_ntf) processor=deactivate_ntf
        command (deactivate_ntf_mail) processor=deactivate_ntf_mail
        command (deactivate_ptf) processor=deactivate_ptf
        command (deactivate_qtf) processor=deactivate_qtf
        command (deactivate_qtfs) processor=deactivate_qtfs
        command (deactivate_scf) processor=deactivate_scf
        command (deactivate_scfs) processor=deactivate_scfs
        command (deactivate_system_logging, deasl) processor=deactivate_system_logging
        command (deactivate_system_task, deactivate_system_tasks, deast) processor=deactivate_system_task
        command (deactivate_xtf) processor=deactivate_xtf
        command (define_system_task, defst) processor=define_system_task a=hidden
        command (delete_system_task, delst, remove_system_task, remst) processor=delete_system_task a=hidden

" SET_JOB_CLASS_LIMIT is a hidden command that will not be supported in the future.

        command (set_job_class_limit, set_job_class_limits, setjcl) processor=set_job_class_limit a=hidden
        command (swap_in_job, swapin, swaij) processor=swap_in_job
        command (swap_out_job, swapout, swaoj) processor=swap_out_job
        command (terminate_system) processor=terminate_system

" Add the activate nqs command if the $system.nqs catalog exists.

        IF $wild_card_files($system.nqs, include_catalogs) <> () THEN
          command (activate_nqs) processor=activate_nqs
          command (deactivate_nqs) processor=deactivate_nqs
        IFEND
      IFEND

" Add commands that are available if either configuration_administration or
" system_displays is active.

      IF selected.configuration_administration OR selected.system_displays THEN
        command (display_kill_job_action, diskja) processor=display_kill_job_action
        command (display_nam_attributes, disna) processor=display_nam_attributes
        command (display_system_attribute, dissa) processor=display_system_attribute
        command (display_tape_scan_frequency, distsf) processor=display_tape_scan_frequency
        command (display_tape_validation, distv) processor=display_tape_validation
        command (manage_periodic_statistics, manps) processor=manage_periodic_statistics
      IFEND
" Add commands that are available if either removable_media_operation or system_operation is active.

      IF selected.removable_media_operation OR selected.system_operation THEN
        command (acknowledge_operator_message, ackom) processor=acknowledge_operator_message
      IFEND

" Add commands that are available if either system_displays or system_operation is active.

      IF selected.system_displays OR selected.system_operation THEN
        command (display_all_input, disai) processor=display_all_input
        command (display_all_output, disao) processor=display_all_output
        command (display_critical_window_log, discwl) processor=display_critical_window_log
        command (display_site_ved_names, dissvn) processor=display_site_ved_names
        command (display_system_log, dissl) processor=display_system_log
        command (display_system_task_data, disstd) processor=display_system_task_data
        command (ved_utility, vedu) processor=ved_utility
        command (manage_queue_file, manage_queue_files, manqf) processor=manage_queue_file
      IFEND

" Add commands that are available if any of accounting_administration, configuration_administration,
" or system_operation is active.

      IF selected.accounting_administration OR selected.configuration_administration OR ..
            selected.system_operation THEN
        command (activate_system_statistic, activate_system_statistics, actss) ..
              processor=activate_system_statistic
        command (deactivate_system_statistic, deactivate_system_statistics, deass) ..
              processor=deactivate_system_statistic
        command (terminate_log, terl) processor=terminate_log
      IFEND

" Add commands that are available if any of configuration_administration,
" removable_media_operation, system_displays, or system_operation is active.

      IF selected.configuration_administration OR selected.removable_media_operation OR selected..
.system_displays OR selected.system_operation THEN
        command (display_system_configuration, dissc) processor=display_system_configuration
        command (logical_configuration_utility, lcu) processor=logical_configuration_utility
      IFEND

" Add commands that are available if any of removable_media_administration, removable_media_operation,
" system_displays, or system_operation is active.

      IF selected.removable_media_administration OR selected.removable_media_operation OR selected..
.system_displays OR selected.system_operation THEN
        command (vedisplay, ved) processor=vedisplay
      IFEND

" Add commands that are available if any of removable_media_operation,
" system_displays, or system_operation is active.

      IF selected.removable_media_operation OR selected.system_displays OR selected.system_operation THEN
        command (display_operator_action_menu, display_operator_action_menus, disoam) ..
              processor=display_operator_action_menu
        command (display_operator_action_status, disoas) processor=display_operator_action_status
      IFEND

" Add commands that are available if system_administration or family_administration is selected.

      IF selected.system_administration OR selected.family_administration THEN
        command (compress_validation_file, comvf) processor=compress_validation_file
        command (move_classes, move_class, movc) processor=move_classes
        command (retrieve_qualified_files, retqf) processor=retrieve_qualified_files
      IFEND

" Add commands that are available if any of configuration_administration,
" system_displays, or system_operation is active.

      IF selected.configuration_administration OR selected.system_displays OR selected.system_operation THEN
        command (display_active_volumes, disav) processor=display_active_volumes
      IFEND
      tablend

      $system.osf$sou_library.ofp$activate_sou_capabilities selected
      delete_variable n=selected

      include_file f=input u=system_operator_utility
    UTILITYEND
  TASKEND

PROCEND system_operator_utility
*DECK DECK=OFM$TASK_PRIVATE_DATA EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operator Facility : Task Private Data', ??
MODULE ofm$task_private_data;

{ Purpose:
{ The purpose of this module is to declare [xdcl] the
{ task private data that is used by the operator facility.

?? TITLE := 'Global External Type Declarations', EJECT ??

?? PUSH (LIST := OFF) ??
*copyc oss$task_private
?? POP ??

  VAR
    ofv$task_display_open_count: [XDCL, oss$task_private] integer := 0;

MODEND ofm$task_private_data;
*DECK DECK=OFM$VEDISPLAY_COMMAND EXPAND=TRUE

?? RIGHT := 110 ??
MODULE ofm$vedisplay_command;

{ PURPOSE:
{   This module contains the processor for the VEDISPLAY (VED) command which is temporary until the
{   real operator display commands come along.
{
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc cld$parameter_list
*copyc ofc$page_width
*copyc ofd$type_definition
*copyc ofe$error_codes
*copyc oss$job_paged_literal
*copyc oss$task_shared
?? POP ??

?? NEWTITLE := 'Global Declarations Referenced by This Module' ??

{  Global procedures referenced by this module.

*copyc amp$get_file_attributes
*copyc amp$return
*copyc avp$system_displays
*copyc avp$system_operator
*copyc bap$file_command
*copyc clp$change_pdt
*copyc clp$evaluate_parameters
*copyc jmp$system_job
*copyc ofp$create_default_displays
*copyc ofp$execute_display_task
*copyc ofp$report_status_error
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc rmp$request_null_device
*copyc clp$include_line
*copyc ofv$displays_initialized

?? EJECT ??
*copyc clv$standard_files
?? TITLE := 'recreate_display_files', EJECT ??

{ PURPOSE:
{   This procedure recreates the display files DISPLAY_A and DISPLAY_B if they haved been destroyed.

  PROCEDURE recreate_display_files
    (VAR status: ost$status);

    CONST
      operator_file_page_length = 30;

    VAR
      contains_data: boolean,
      error_message: string (80),
      file: clt$standard_files,
      file_attributes: ARRAY [1 .. 5] OF amt$file_item,
      file_exists: boolean,
      file_name: string (16),
      file_previously_opened: boolean,
      gfa: ARRAY [1 .. 1] OF amt$get_item,
      message_length: integer;

    status.normal := TRUE;
    file_attributes [1].key := amc$file_contents;
    file_attributes [1].file_contents := amc$list;
    file_attributes [2].key := amc$page_format;
    file_attributes [2].page_format := amc$continuous_form;
    file_attributes [3].key := amc$user_info;
    file_attributes [3].user_info := 'LOG';
    file_attributes [4].key := amc$page_width;
    file_attributes [4].page_width := ofc$page_width - 1;
    file_attributes [5].key := amc$page_length;
    file_attributes [5].page_length := operator_file_page_length;

    gfa [1].key := amc$user_info;

    FOR file := clc$sf_display_a_file TO clc$sf_display_b_file DO
      IF file = clc$sf_display_a_file THEN
        file_name := '$local.display_a';
      ELSE
        file_name := '$local.display_b';
      IFEND;

      { Determine if the display file exists in the correct format.

      amp$get_file_attributes (file_name, gfa, file_exists, file_previously_opened, contains_data, status);
      IF NOT status.normal THEN
        STRINGREP (error_message, message_length, 'amp$get_file_attributes on file ', file_name);
        ofp$report_status_error (status, error_message (1, message_length));
        osp$system_error ('get failed', ^status);
        RETURN;
      IFEND;

      IF NOT file_exists OR (gfa [1].user_info <> 'LOG') THEN
        IF file_exists THEN
          amp$return (file_name, status);
          IF NOT status.normal THEN
            STRINGREP (error_message, message_length, 'amp$return on file ', file_name);
            ofp$report_status_error (status, error_message (1, message_length));
            osp$system_error ('return failed', ^status);
            RETURN;
          IFEND;
        IFEND;

        rmp$request_null_device (clv$standard_files [file].path_handle_name, status);
        IF NOT status.normal THEN
          STRINGREP (error_message, message_length, 'rmp$request_null_device on file ', file_name);
          ofp$report_status_error (status, error_message (1, message_length));
          osp$system_error ('request failed', ^status);
          RETURN;
        IFEND;

        bap$file_command (clv$standard_files [file].path_handle_name, ^file_attributes, status);
        IF NOT status.normal THEN
          STRINGREP (error_message, message_length, 'bap$file_command on file ', file_name);
          ofp$report_status_error (status, error_message (1, message_length));
          osp$system_error ('file command failed', ^status);
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND recreate_display_files;
?? TITLE := 'ofp$vedisplay_command', EJECT ??
*copyc ofh$ve_display_command

  PROCEDURE [XDCL, #GATE] ofp$vedisplay_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


*copyc ofd$pdt_ved

    VAR
      display_file_p: ^fst$file_reference,
      pdt_changes: array [1 .. 2] of clt$pdt_change,
      pdt_keyword_availability: array [1 .. 2] of clt$type_change,
      pdt_p: ^SEQ ( * );

    VAR
      temp: ^SEQ ( * );

    VAR
      file_display_a: [STATIC, READ, oss$job_paged_literal] string (16) := '$local.display_a',
      file_display_b: [STATIC, READ, oss$job_paged_literal] string (16) := '$local.display_b',
      file_$output: [STATIC, READ, oss$job_paged_literal] string (7) := '$output';


    status.normal := TRUE;

    IF jmp$system_job () THEN
      pdt_p := #SEQ (pdt);
    ELSE

{     Make a copy of the PDT so that it can be modified to change the definition of the OUTPUT parameter.
{     Make $output the default and make the display_a and display_b keywords hidden.

      PUSH pdt_p: [[REP #SIZE (pdt) OF cell]];
      temp := #SEQ (pdt);
      pdt_p^ := temp^;
{!  Convert the preceding two lines to the following when CILB454 is answered.
{!    pdt_p^ := #SEQ (pdt)^;

      pdt_changes [1].number := 2;
      pdt_changes [1].kind := clc$pdtc_default_value;
      pdt_changes [1].default_value := ^file_$output;

      pdt_changes [2].number := 2;
      pdt_changes [2].kind := clc$pdtc_type;
      pdt_changes [2].type_changes := ^pdt_keyword_availability;
      pdt_keyword_availability [1].kind := clc$tc_keyword_availability;
      pdt_keyword_availability [1].keyword := 'DISPLAY_A';
      pdt_keyword_availability [1].availability := clc$hidden_entry;
      pdt_keyword_availability [2].kind := clc$tc_keyword_availability;
      pdt_keyword_availability [2].keyword := 'DISPLAY_B';
      pdt_keyword_availability [2].availability := clc$hidden_entry;

      clp$change_pdt (pdt_p, pdt_changes, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Recreate the display files if necessary.

    IF jmp$system_job () THEN
      recreate_display_files (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    { Process the OUTPUT parameter.  If a keyword value is specified and this is the system job, then
    { convert to keyword to a file_reference for the appropriate $LOCAL file.  If a keyword value is
    { specified and this is NOT the system job, then return abnormal status.  If the OUTPUT parameter
    { is not specified, then send the display data to DISPLAY_A if this is the system job and to
    { $OUTPUT otherwise.

    IF pvt [p$output].specified THEN
      IF pvt [p$output].value^.kind = clc$file THEN
        display_file_p := pvt [p$output].value^.file_value;
      ELSE   {value is a keyword}
        IF jmp$system_job () THEN
          IF pvt [p$output].value^.keyword_value = 'DISPLAY_A' THEN
            display_file_p := ^file_display_a;
          ELSE
            display_file_p := ^file_display_b;
          IFEND;
        ELSE
          osp$set_status_abnormal (ofc$operator_facility_id, ofe$invalid_keyword_for_user,
              pvt [p$output].value^.keyword_value, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'OUTPUT', status);
          RETURN;
        IFEND;
      IFEND;
    ELSE
      IF jmp$system_job () THEN
        display_file_p := ^file_display_a;
      ELSE
        display_file_p := ^file_$output;
      IFEND;
    IFEND;

    IF (avp$system_displays ()) OR (avp$system_operator ()) THEN
      ofp$create_default_displays (status);
    IFEND;
    IF status.normal THEN
      ofp$execute_display_task (display_file_p^,
               pvt [p$display_options].value^.name_value, status);
    IFEND;

    IF NOT status.normal THEN
      ofp$report_status_error (status, 'display execution');
    IFEND;

    IF NOT ofv$displays_initialized THEN
      clp$include_line ('VEDU ;QUIT', FALSE, osc$null_name, status);
    IFEND;

  PROCEND ofp$vedisplay_command;

MODEND ofm$vedisplay_command;
*DECK DECK=OFP$ACCESS_DISPLAY_DESCRIPTION EXPAND=FALSE

  PROCEDURE [XREF] ofp$access_display_description
    (    request_code: oft$access_display_request_code;
         callers_dd_p: oft$display_descriptions_p;
       VAR field_count: oft$field_count;
       VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oft$designer_screens_types
*copyc ost$status
?? POP ??

*DECK DECK=OFP$ACKNOWLEDGE_OPERATOR_MSG EXPAND=FALSE

  PROCEDURE [XREF] ofp$acknowledge_operator_msg
    (    message_id: oft$operator_message_id;
         response: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ofe$error_codes
*copyc oft$operator_message_descriptor
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=OFP$ACKNOWLEDGE_OPERATOR_MSG_R1 EXPAND=FALSE

  PROCEDURE [XREF] ofp$acknowledge_operator_msg_r1
    (    message_id: oft$operator_message_id;
         active_operator_classes: oft$operator_classes;
         response: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ofe$error_codes
*copyc oft$operator_classes
*copyc oft$operator_message_descriptor
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=OFP$ACTIVATE_SOU_CAPABILITIES EXPAND=TRUE
create_command_description name=(ofp$activate_sou_capabilities) ..
      sp=ofp$activate_sou_capabilities availability=hidden
*DECK DECK=OFP$ADD_OPERATOR_MENU EXPAND=FALSE

  PROCEDURE [XREF] ofp$add_operator_menu
    (    menu_selections_p: ^oft$menu_selections;
         number_of_displayable_lines: oft$number_of_displayable_lines,
         number_of_choices: oft$number_of_choices;
         operator_class: oft$operator_class;
     VAR menu_id: oft$menu_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oft$menu_id
*copyc oft$menu_selections
*copyc oft$operator_class
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=OFP$BUILD_SYSTEM_LINE EXPAND=FALSE

  PROCEDURE [XREF] ofp$build_system_line
      (VAR last_info: oft$system_line_info;
       VAR s: string ( * <= 250));

?? PUSH (LISTEXT := ON) ??
*copyc oft$system_line_info
?? POP ??
*DECK DECK=OFP$CLEAR_OPERATOR_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] ofp$clear_operator_message
    (    operator_class: oft$operator_class;
     VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc ofe$error_codes
*copyc oft$operator_class
*copyc ost$status
?? POP ??
*DECK DECK=OFP$CLEAR_OPERATOR_MESSAGE_R1 EXPAND=FALSE

  PROCEDURE [XREF] ofp$clear_operator_message_r1
    (    operator_class: oft$operator_class;
     VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc ofe$error_codes
*copyc oft$operator_class
*copyc ost$status
?? POP ??
*DECK DECK=OFP$CP_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] ofp$cp_display
    (    window_id: dpt$window_id;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$status
?? POP ??
*DECK DECK=OFP$CREATE_DEFAULT_DISPLAYS EXPAND=FALSE

  PROCEDURE [XREF] ofp$create_default_displays (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=OFP$CRITICAL_WINDOW_LOG_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] ofp$critical_window_log_display
    (    wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=OFP$DELETE_OPERATOR_MENU EXPAND=FALSE

  PROCEDURE [XREF] ofp$delete_operator_menu
    (    menu_id: oft$menu_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oft$menu_id
*copyc ost$status
?? POP ??
*DECK DECK=OFP$DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] ofp$display
      (  wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=OFP$DISPLAY_MASS_STORAGE EXPAND=FALSE

  PROCEDURE [XREF] ofp$display_mass_storage
    (    window_id: dpt$window_id;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$status
?? POP ??
*DECK DECK=OFP$DISPLAY_SITE_VED_NAMES EXPAND=FALSE

  PROCEDURE [XREF] ofp$display_site_ved_names
    (VAR display_control: clt$display_control;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc ost$status
?? POP ??
*DECK DECK=OFP$DISPLAY_SOU_CAPABILITY EXPAND=TRUE
create_command_description name=(ofp$display_sou_capabilities) ..
      sp=ofp$display_active_capabilities
*DECK DECK=OFP$DISPLAY_STATUS_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] ofp$display_status_message ALIAS 'ofxdism' (text: string ( *
    );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OFD$TYPE_DEFINITION
*copyc OFE$ERROR_CODES
*copyc OST$STATUS
?? POP ??
*DECK DECK=OFP$DISPLAY_STATUS_MSG_HELPER EXPAND=FALSE

  PROCEDURE [XREF] ofp$display_status_msg_helper (text: string ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=OFP$ENABLE_STOP_KEY EXPAND=FALSE

  PROCEDURE [XREF] ofp$enable_stop_key;
*DECK DECK=OFP$ENABLE_STOP_KEY_HELP EXPAND=FALSE

  PROCEDURE [XREF] ofp$enable_stop_key_help;
*DECK DECK=OFP$END_SYSTEM_OPERATOR_UTILITY EXPAND=TRUE
PROCEDURE (osm$sysou_quit) ofp$end_system_operator_utility

  EXIT system_operator_utility

PROCEND ofp$end_system_operator_utility
*DECK DECK=OFP$EVALUATE_SOU_CAPABILITIES EXPAND=TRUE
create_command_description name=(ofp$evaluate_sou_capabilities) ..
      sp=ofp$evaluate_sou_capabilities availability=hidden

*DECK DECK=OFP$EXECUTE_DISPLAY_TASK EXPAND=FALSE

  PROCEDURE [XREF] ofp$execute_display_task
    (    file_reference: fst$file_reference;
         display: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=OFP$FORMAT_OPERATOR_MENU EXPAND=FALSE

  PROCEDURE [XREF] ofp$format_operator_menu
    (    seed_name: pmt$program_name;
         parameter_names: ^ost$parameter_help_names;
         message_parameters: ^ost$message_parameters;
         number_of_choices: oft$number_of_choices;
         operator_class: oft$operator_class;
     VAR choice: oft$number_of_choices;
     VAR response_string: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oft$menu_selections
*copyc oft$operator_class
*copyc ost$message_parameters
*copyc ost$parameter_help_names
*copyc ost$status
*copyc ost$string
*copyc pmt$program_name
?? POP ??
*DECK DECK=OFP$FORMAT_OPERATOR_MESSAGE EXPAND=FALSE

  PROCEDURE [INLINE] ofp$format_operator_message
    (    operator_message: ost$status_message;
         starting_line: oft$number_of_displayable_lines;
     VAR formatted_message: oft$formatted_operator_message;
     VAR line_count: oft$number_of_displayable_lines);

?? PUSH (LISTEXT := ON) ??

    VAR
      line_count_p: ^ost$status_message_line_count,
      line_number: ost$status_message_line_count,
      line_size_p: ^ost$status_message_line_size,
      message_line_p: ^ost$status_message_line,
      operator_message_p: ^ost$status_message;

    operator_message_p := ^operator_message;
    RESET operator_message_p;

    FOR line_number := starting_line TO ofc$max_menu_lines DO
      formatted_message [line_number] := ' ';
    FOREND;

    NEXT line_count_p IN operator_message_p;
    IF line_count_p^ <= ofc$max_menu_lines - (starting_line - 1) THEN
      line_count := line_count_p^;
    ELSE
      line_count := ofc$max_menu_lines - (starting_line - 1);
    IFEND;
    IF line_count > 0 THEN
      FOR line_number := starting_line TO (starting_line - 1) + line_count DO
        NEXT line_size_p IN operator_message_p;
        NEXT message_line_p: [line_size_p^] IN operator_message_p;
        formatted_message [line_number] := message_line_p^ (2, *);
      FOREND;
    IFEND;
    line_count := line_count + starting_line - 1;

  PROCEND ofp$format_operator_message;

*copyc oft$formatted_operator_message
*copyc ost$status_message
?? POP ??
*DECK DECK=OFP$GENERAL_STATISTICS_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] ofp$general_statistics_display
    (    window_id: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=OFP$GET_ACTIVE_OPERATOR_ALARMS EXPAND=FALSE

  PROCEDURE [XREF] ofp$get_active_operator_alarms
    (VAR active_operator_alarms: oft$operator_alarms);

?? PUSH (LISTEXT := ON) ??
*copyc oft$operator_alarm
?? POP ??

*DECK DECK=OFP$GET_ACTIVE_OPERATOR_CLASSES EXPAND=FALSE

  PROCEDURE [XREF] ofp$get_active_operator_classes
    (VAR active_operator_classes: oft$operator_classes);

?? PUSH (LISTEXT := ON) ??
*copyc oft$operator_classes
?? POP ??

*DECK DECK=OFP$GET_DISPLAY_MESSAGE_HELPER EXPAND=FALSE

  PROCEDURE [XREF] ofp$get_display_message_helper
    (    job_seq_number: jmt$system_supplied_name;
     VAR display_message: oft$display_message;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc oft$display_message_info
*copyc ost$status
?? POP ??
*DECK DECK=OFP$GET_DISPLAY_STATUS_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] ofp$get_display_status_message
    (    jsn: jmt$system_supplied_name;
     VAR display_message: oft$display_message;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc oft$display_message_info
*copyc ost$status
?? POP ??
*DECK DECK=OFP$GET_FIRST_OPERATOR_MENU EXPAND=FALSE

  PROCEDURE [XREF] ofp$get_first_operator_menu
    (VAR menu_descriptor: oft$operator_menu_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oft$operator_menu_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=OFP$GET_FIRST_OPERATOR_MENU_R1 EXPAND=FALSE

  PROCEDURE [XREF] ofp$get_first_operator_menu_r1
    (    active_operator_classes: oft$operator_classes;
     VAR menu_descriptor: oft$operator_menu_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oft$operator_classes
*copyc oft$operator_menu_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=OFP$GET_MENU_CHOICE EXPAND=FALSE

  PROCEDURE [XREF] ofp$get_menu_choice
    (    menu_id: oft$menu_id;
     VAR choice_made: boolean;
     VAR choice: oft$number_of_choices;
     VAR response_string: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oft$menu_id
*copyc oft$menu_selections
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=OFP$GET_MENU_HELP_TEXT EXPAND=FALSE

  PROCEDURE [XREF] ofp$get_menu_help_text
    (    menu_id: oft$menu_id;
         global_task_id: ost$global_task_id;
         help_text_p: {input, output} ^oft$menu_selections;
     VAR help_text_found: boolean;
     VAR help_text_line_count: oft$number_of_displayable_lines;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oft$menu_id
*copyc oft$menu_selections
*copyc ost$global_task_id
*copyc ost$status
?? POP ??
*DECK DECK=OFP$GET_MENU_HELP_TEXT_R1 EXPAND=FALSE

  PROCEDURE [XREF] ofp$get_menu_help_text_r1
    (    menu_id: oft$menu_id;
         global_task_id: ost$global_task_id;
         help_text_p: {input, output} ^oft$menu_selections;
     VAR help_text_found: boolean;
     VAR help_text_line_count: oft$number_of_displayable_lines;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oft$menu_id
*copyc oft$menu_selections
*copyc ost$global_task_id
*copyc ost$status
?? POP ??
*DECK DECK=OFP$GET_NEXT_OPERATOR_MENU EXPAND=FALSE

  PROCEDURE [XREF] ofp$get_next_operator_menu
    (    menu_id: oft$menu_id;
     VAR menu_descriptor: oft$operator_menu_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oft$menu_id
*copyc oft$operator_menu_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=OFP$GET_NEXT_OPERATOR_MENU_R1 EXPAND=FALSE

  PROCEDURE [XREF] ofp$get_next_operator_menu_r1
    (    menu_id: oft$menu_id;
         active_operator_classes: oft$operator_classes;
     VAR menu_descriptor: oft$operator_menu_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oft$menu_id
*copyc oft$operator_classes
*copyc oft$operator_menu_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=OFP$GET_OPERATOR_MESSAGES EXPAND=FALSE

  PROCEDURE [XREF] ofp$get_operator_messages
    (    active_operator_classes: oft$operator_classes;
     VAR message_array: array [1 .. * ] of oft$operator_message_descriptor;
     VAR count: integer;
     VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc ofe$error_codes
*copyc oft$operator_classes
*copyc oft$operator_message_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=OFP$HANDLE_OPERATOR_BREAK_FLAG EXPAND=TRUE

  PROCEDURE [XREF] ofp$handle_operator_break_flag (flag_id: ost$system_flag);
?? PUSH (LISTEXT := ON) ??
*copyc ost$system_flag
?? POP ??
*DECK DECK=OFP$HANDLE_SIGNAL_PROCESSOR EXPAND=FALSE


  PROCEDURE [XREF] ofp$handle_signal_processor (originator: ost$global_task_id;
        signal: pmt$signal);


?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc PMT$SIGNAL
?? POP ??
*DECK DECK=OFP$IJL_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] ofp$ijl_display
    (    window_id: dpt$window_id;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$status
?? POP ??
*DECK DECK=OFP$IO_SUMMARY_DISPLAY EXPAND=TRUE


  PROCEDURE [XREF] ofp$io_summary_display
    (    wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=OFP$JOB_BEGIN EXPAND=FALSE

  PROCEDURE [XREF] ofp$job_begin;

?? PUSH (LISTEXT := ON) ??
?? POP ??
*DECK DECK=OFP$JOB_END EXPAND=FALSE

  PROCEDURE [XREF] ofp$job_end;

?? PUSH (LISTEXT := ON) ??
?? POP ??
*DECK DECK=OFP$JOB_LOG_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] ofp$job_log_display
    (    window_id: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=OFP$JOB_OPERATOR_MENUS_ACTIVE EXPAND=FALSE

  FUNCTION [XREF, UNSAFE] ofp$job_operator_menus_active
    (    job_name: jmt$system_supplied_name): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
?? POP ??
*DECK DECK=OFP$JOB_OPERATOR_MSGS_ACTIVE EXPAND=FALSE

  FUNCTION [XREF, UNSAFE] ofp$job_operator_msgs_active
    (    job_name: jmt$system_supplied_name): boolean;

?? PUSH (LIST := OFF) ??
*copyc jmt$system_supplied_name
?? POP ??
*DECK DECK=OFP$LOG_CRITICAL_MTR_MESSAGES EXPAND=FALSE

  PROCEDURE [XREF] ofp$log_critical_mtr_messages;
*DECK DECK=OFP$OPEN_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] ofp$open_display
    (    file_name: amt$local_file_name;
         window_id: dpt$window_id;
         class: dpt$window_class;
         kind: dpt$window_kind;
         title: string ( * );
    VAR  display_control: clt$display_control;
    VAR  status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc clt$display_control
*copyc dpt$window_class
*copyc dpt$window_id
*copyc dpt$window_kind
*copyc ost$status
?? POP ??
*DECK DECK=OFP$OPERATOR_MESSAGE_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] ofp$operator_message_display
    (    window_id: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=OFP$PROCESS_OPERATOR_MENU EXPAND=FALSE

  PROCEDURE [XREF] ofp$process_operator_menu
    (    menu_selections_p: ^oft$menu_selections;
         number_of_displayable_lines: oft$number_of_displayable_lines,
         number_of_choices: oft$number_of_choices;
         operator_class: oft$operator_class;
     VAR choice: oft$number_of_choices;
     VAR response_string: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oft$menu_selections
*copyc oft$operator_class
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=OFP$RECEIVE_FROM_OPERATOR EXPAND=FALSE

  PROCEDURE [XREF] ofp$receive_from_operator ALIAS 'ofxrefo' (wait: ost$wait;
    VAR text: ost$string;
    VAR operator_id: oft$operator_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OFD$TYPE_DEFINITION
*copyc OFE$ERROR_CODES
*copyc OST$WAIT
*copyc OST$STRING
*copyc OST$STATUS
?? POP ??
*DECK DECK=OFP$RECEIVE_OPERATOR_RESPONSE EXPAND=FALSE

  PROCEDURE [XREF] ofp$receive_operator_response
    (    operator_class: oft$operator_class;
         wait: ost$wait;
     VAR response: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ofe$error_codes
*copyc oft$operator_class
*copyc ost$status
*copyc ost$string
*copyc ost$wait
?? POP ??
*DECK DECK=OFP$RECEIVE_OPERATOR_RESP_R1 EXPAND=FALSE

  PROCEDURE [XREF] ofp$receive_operator_resp_r1
    (    operator_class: oft$operator_class;
     VAR response: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ofe$error_codes
*copyc oft$operator_class
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=OFP$RECEIVE_OPERATOR_RESP_R3 EXPAND=FALSE

  PROCEDURE [XREF] ofp$receive_operator_resp_r3
    (    operator_class: oft$operator_class;
     VAR response: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ofe$error_codes
*copyc oft$operator_class
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=OFP$REPORT_STATUS_ERROR EXPAND=FALSE

  PROCEDURE [XREF] ofp$report_status_error
    (    status_error: ost$status;
         message: string ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OFP$SCREEN_INPUT_FAP EXPAND=FALSE

  PROCEDURE [XREF] ofp$screen_input_fap
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=OFP$SCREEN_OUTPUT_FAP EXPAND=FALSE

  PROCEDURE [XREF] ofp$screen_output_fap
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=OFP$SEARCH_FOR_DISPLAY_NAME EXPAND=FALSE

  PROCEDURE [XREF] ofp$search_for_display_name
    (     name: ost$name;
      VAR index: integer);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=OFP$SEND_FORMATTED_OPERATOR_MSG EXPAND=FALSE

  PROCEDURE [XREF] ofp$send_formatted_operator_msg
    (    formatted_message: oft$formatted_operator_message;
         operator_class: oft$operator_class;
         acknowledgement_allowed: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ofe$error_codes
*copyc oft$formatted_operator_message
*copyc oft$operator_class
*copyc ost$status
?? POP ??
*DECK DECK=OFP$SEND_OPERATOR_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] ofp$send_operator_message
    (    message: oft$operator_message;
         operator_class: oft$operator_class;
         acknowledgement_allowed: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ofe$error_codes
*copyc oft$operator_class
*copyc oft$operator_message
*copyc ost$status
?? POP ??
*DECK DECK=OFP$SEND_OPERATOR_MESSAGE_R1 EXPAND=FALSE

  PROCEDURE [XREF] ofp$send_operator_message_r1
    (    formatted_message: oft$formatted_operator_message;
         number_of_message_lines: oft$number_of_displayable_lines;
         operator_class: oft$operator_class;
         acknowledgement_allowed: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ofe$error_codes
*copyc oft$formatted_operator_message
*copyc oft$operator_class
*copyc ost$status
?? POP ??
*DECK DECK=OFP$SEND_TO_OPERATOR EXPAND=FALSE

  PROCEDURE [XREF] ofp$send_to_operator ALIAS 'ofxseto' (text:
    string(*);
    operator_id: oft$operator_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OFD$TYPE_DEFINITION
*copyc OFE$ERROR_CODES
*copyc OST$STATUS
?? POP ??
*DECK DECK=OFP$SPECIAL_STATISTICS_DISPLAY EXPAND=TRUE

  PROCEDURE [XREF] ofp$special_statistics_display
    (    wid: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=OFP$STORE_MENU_CHOICE EXPAND=FALSE

  PROCEDURE [XREF] ofp$store_menu_choice
    (    menu_id: oft$menu_id;
         choice: oft$number_of_choices;
         response_string: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oft$menu_id
*copyc oft$menu_selections
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=OFP$STORE_MENU_CHOICE_R1 EXPAND=FALSE

  PROCEDURE [XREF] ofp$store_menu_choice_r1
    (    menu_id: oft$menu_id;
         active_operator_classes: oft$operator_classes;
         choice: oft$number_of_choices;
         response_string: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oft$menu_id
*copyc oft$menu_selections
*copyc oft$operator_classes
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=OFP$STORE_MENU_HELP_TEXT EXPAND=FALSE

  PROCEDURE [XREF] ofp$store_menu_help_text
    (    menu_id: oft$menu_id;
         help_text: oft$menu_selections;
         help_text_line_count: oft$number_of_displayable_lines;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc oft$menu_id
*copyc oft$menu_selections
*copyc ost$status
?? POP ??
*DECK DECK=OFP$SYSTEM_HEADER_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] ofp$system_header_display;
*DECK DECK=OFP$SYSTEM_LOG_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] ofp$system_log_display
    (    window_id: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=OFP$TAPE_MOUNT_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] ofp$tape_mount_display
    (    window_id: dpt$window_id;
         display_name: ost$name;
         file_name: amt$local_file_name;
         initial_call: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=OFP$TASK_END EXPAND=FALSE

  PROCEDURE [XREF] ofp$task_end;

?? PUSH (LISTEXT := ON) ??
?? POP ??
*DECK DECK=OFP$TASK_END_HELPER EXPAND=FALSE

  PROCEDURE [XREF] ofp$task_end_helper;
*DECK DECK=OFP$VERIFY_DISPLAY_NAME EXPAND=FALSE

  PROCEDURE [XREF] ofp$verify_display_name
    (    display_name: ost$name;
     VAR long_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??

*DECK DECK=OFP$_GET_SYSTEM_ATTRIBUTE EXPAND=TRUE
create_command_description name=(ofp$_get_system_attribute) ..
      sp=ofp$_get_system_attribute availability=hidden
*DECK DECK=OFT$DESIGNER_SCREENS_TYPES EXPAND=FALSE
{ Common Deck OFT$DESIGNER_SCREENS_TYPES

  CONST
    ofc$max_display_fields = 100,
    ofc$max_display_width = 130,
    ofc$max_incremental_fields = 6;

  TYPE
    oft$access_display_request_code = (ofc$adrc_get, ofc$adrc_create, ofc$adrc_change,
        ofc$adrc_delete),

    oft$display_descriptions_p = ^oft$display_description,

    oft$max_display_descriptions_p = ^oft$max_display_description,

    oft$display_description_header = RECORD
      display_name: ost$name,
      display_name_abbrev: ost$name,
      next_description_p: oft$display_descriptions_p,
      incremental_data_p: ^oft$save_incremental_data,
      title: string (ofc$max_display_width + 1),
      jobs_per_line: 1 .. ofc$max_display_width,
      column_width: 1 .. ofc$max_display_width,
      job_selection: oft$job_selection,
      display_blank_lines: boolean,
      display_system_line: boolean,
      system_line_info: oft$system_line_info,
      field_count: oft$field_count,
    RECEND,

    oft$display_description = RECORD
      header: oft$display_description_header,
      fields: oft$field_descriptions,
    RECEND,

    oft$max_display_description = RECORD
      header: oft$display_description_header,
      fields: oft$max_field_descriptions,
    RECEND,

    oft$job_selection = (ofc$js_active, ofc$js_initiated),

    oft$field_descriptions = array [1 .. *] OF oft$field_description,
    oft$max_field_descriptions = array [1 .. 100] OF oft$field_description,

    oft$field_description = RECORD
      field_id: oft$field_id,
      field_title: ost$name,
      width: 1 .. ofc$max_display_width,
      scale: oft$scale_divisor,
      field_overflow_action: oft$field_overflow_action,
      incremental: boolean,
      field_selection: oft$field_selection,
      non_selection_action: oft$non_selection_action,
      pack: oft$packed_field_attributes,
    RECEND,

    oft$packed_field_attributes = PACKED RECORD
      field_id: oft$field_id,
      width: 1 .. ofc$max_display_width,
      scale: oft$scale_divisor,
      field_overflow_action: oft$field_overflow_action,
      incremental: boolean,
      field_selection: oft$field_selection,
      non_selection_action: oft$non_selection_action,
    RECEND,

    oft$scale_divisor = 0 .. 1000000000,

    oft$numeric_display_mode = (ofc$ndm_total, ofc$ndm_incremental),

    oft$field_selection = (ofc$fs_unconditional, ofc$fs_active,
         ofc$fs_swapped),

    oft$field_overflow_action = (ofc$foa_scale, ofc$foa_maximum,
        ofc$foa_asterisk),

    oft$non_selection_action = (ofc$nsa_skip, ofc$nsa_blank),

    oft$field_count = 0 .. ofc$max_display_fields,

    oft$field_index = 1 .. ofc$max_display_fields,

    oft$save_incremental_data = ARRAY [0 ..*] OF
        oft$save_incremental_data_entry,

     oft$save_incremental_data_entry =  RECORD
       ssn_id: string (8),
       last_clock: ost$free_running_clock,
       int: ARRAY [0 .. ofc$max_incremental_fields - 1] OF integer,
     RECEND,

    oft$field_id = (
        ofc$fi_active_io_pages,
        ofc$fi_active_io_requests,
        ofc$fi_ajl_ordinal,
        ofc$fi_cp_time_increment,
        ofc$fi_cp_time_job,
        ofc$fi_cp_time_monitor,
        ofc$fi_cp_time_total,
        ofc$fi_dispatching_priority,
        ofc$fi_dispatching_priority_act,
        ofc$fi_display_message,
        ofc$fi_fill,
        ofc$fi_guaranteed_service_rem,
        ofc$fi_hung_task_in_job_flag,
        ofc$fi_ijl_ordinal,
        ofc$fi_job_class,
        ofc$fi_job_entry_status,
        ofc$fi_job_mode,
        ofc$fi_job_priority,
        ofc$fi_job_status,
        ofc$fi_job_swap_count,
        ofc$fi_last_think_time,
        ofc$fi_memory_pages,
        ofc$fi_page_fault_count,
        ofc$fi_percent_cp_usage,
        ofc$fi_permanent_file_space,
        ofc$fi_ps_pages_assigned,
        ofc$fi_ps_pages_from_server,
        ofc$fi_ps_pages_reclaimed,
        ofc$fi_ps_page_in,
        ofc$fi_ready_task_count,
        ofc$fi_service_accumulator,
        ofc$fi_service_class,
        ofc$fi_service_since_swap,
        ofc$fi_ssn_full,
        ofc$fi_ssn_long,
        ofc$fi_ssn_short,
        ofc$fi_swap_entry_status,
        ofc$fi_swap_in_wait_time,
        ofc$fi_swap_reason,
        ofc$fi_swap_status,
        ofc$fi_temporary_file_space,
        ofc$fi_terminal_name,
        ofc$fi_think_time,
        ofc$fi_thrashing_flag,
        ofc$fi_time_in_swap_state,
        ofc$fi_user_job_name,
        ofc$fi_working_set_size);



*copyc oft$system_line_info
*copyc ost$free_running_clock
*copyc ost$name
*DECK DECK=OFT$DISPLAY_MESSAGE EXPAND=FALSE
  TYPE
    oft$display_message = record
      size: 0 .. ofc$max_display_message,
      text: string (ofc$max_display_message),
    recend;

*copyc ofc$max_display_message
*DECK DECK=OFT$DISPLAY_MESSAGE_INFO EXPAND=FALSE

  TYPE
    oft$display_message_info = record
      display_message_lock: ost$signature_lock,
      display_message: oft$display_message,
    recend;

*copyc oft$display_message
*copyc ost$signature_lock
*DECK DECK=OFT$DISPLAY_PROCEDURE EXPAND=FALSE

  TYPE
    oft$display_procedure = ^procedure
                               (    window_id: dpt$window_id;
                                    display_name: ost$name;
                                    file_name: amt$local_file_name;
                                    initial_call: boolean;
                                VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dpt$window_id
*copyc ost$status
?? POP ??

*DECK DECK=OFT$FORMATTED_OPERATOR_MESSAGE EXPAND=FALSE

TYPE
  oft$formatted_operator_message = oft$menu_selections;

?? PUSH (LISTEXT := ON) ??
*copyc oft$menu_selections
?? POP ??
*DECK DECK=OFT$MENU_ID EXPAND=FALSE

  CONST
    ofc$max_menu_id = 0ffff(16);

  TYPE
    oft$menu_id = 0 .. ofc$max_menu_id;
*DECK DECK=OFT$MENU_SELECTIONS EXPAND=FALSE


  CONST
    ofc$max_menu_lines = 18,
    ofc$max_display_lines = ofc$max_menu_lines + 1;

  TYPE
    oft$number_of_choices = 1 .. ofc$max_menu_lines,

    oft$number_of_displayable_lines = 0 .. ofc$max_menu_lines,

    oft$menu_selections = ARRAY [1 .. ofc$max_menu_lines] of string (80),

    oft$menu_display = ARRAY [1 .. ofc$max_display_lines] of string (80);
*DECK DECK=OFT$OPERATOR_ALARM EXPAND=FALSE

  TYPE
    oft$operator_alarm = (ofc$tape_mounts, ofc$menu_requests,
          ofc$operator_messages),
    oft$operator_alarms = set of oft$operator_alarm;

*DECK DECK=OFT$OPERATOR_CLASS EXPAND=FALSE
  TYPE
    oft$operator_class = 0 .. 255;

{ Valid values for oft$operator_class.

  CONST
    ofc$removable_media_operator = 0,
    ofc$system_operator = 1,

    ofc$max_valid_operator_class = 1;
*DECK DECK=OFT$OPERATOR_CLASSES EXPAND=FALSE

  TYPE
    oft$operator_classes = SET OF 0 .. ofc$max_valid_operator_class;

*copyc oft$operator_class
*DECK DECK=OFT$OPERATOR_MENU_DESCRIPTOR EXPAND=FALSE

  TYPE
    oft$operator_menu_descriptor = RECORD
      next_descriptor_p: ^oft$operator_menu_descriptor,
      menu_id: oft$menu_id,
      source_task: ost$global_task_id,
      job_name: jmt$system_supplied_name,
      menu_class: oft$operator_class,
      number_of_displayable_lines: oft$number_of_displayable_lines,
      number_of_choices: oft$number_of_choices,
      choice: oft$number_of_choices,
      choice_made: boolean,
      response_string: ost$string,
      menu_text: oft$menu_selections,
      help_text_p: ^oft$menu_selections,
      help_text_line_count: oft$number_of_displayable_lines,
    RECEND;

*copyc jmt$system_supplied_name
*copyc oft$menu_id
*copyc oft$menu_selections
*copyc oft$operator_class
*copyc ost$global_task_id
*copyc ost$string
*DECK DECK=OFT$OPERATOR_MESSAGE EXPAND=FALSE

  CONST
    ofc$max_operator_message_size = 256;

  TYPE
    oft$operator_message = string ( * <= ofc$max_operator_message_size);
*DECK DECK=OFT$OPERATOR_MESSAGE_DESCRIPTOR EXPAND=FALSE

  CONST
    ofc$maximum_queue_messages = 30,
    ofc$max_message_ordinal = 0ffff(16);

  TYPE
    oft$operator_message_descriptor = record
      next_descriptor_p: ^oft$operator_message_descriptor,
      sending_task: ost$global_task_id,
      message_class: oft$operator_class,
      message_id: oft$operator_message_id,
      acknowledgement_allowed: boolean,
      system_supplied_name: jmt$system_supplied_name,
      formatted_message: oft$formatted_operator_message,
      number_of_message_lines: oft$number_of_displayable_lines,
      response_received: boolean,
      response_message: ost$string,
    recend,

    oft$operator_message_id = 0 .. ofc$max_message_ordinal;

*copyc jmt$system_supplied_name
*copyc ofc$max_messages_per_job
*copyc oft$formatted_operator_message
*copyc oft$operator_class
*copyc ost$global_task_id
*copyc ost$string
*DECK DECK=OFT$REFRESHING_DISPLAYS EXPAND=FALSE
  TYPE
    oft$refreshing_displays = (ofc$null_display, ofc$ij_display,
          ofc$ijd_display, ofc$aj_display, ofc$jl_display, ofc$sl_display,
          ofc$ms_display, ofc$gs_display, ofc$ts_display, ofc$tr_display,
          ofc$pa_display, ofc$ac_display, ofc$file_server_display,
          ofc$om_display, ofc$tm_display);

*DECK DECK=OFT$REFRESH_RATE EXPAND=FALSE


  TYPE
    oft$refresh_rate = (ofc$no_refresh, ofc$on_request, ofc$slow_refresh,
      ofc$fast_refresh);
*DECK DECK=OFT$SCREEN_STATUS EXPAND=FALSE

  TYPE
    oft$screen_status = ARRAY [oft$screen_files] OF oft$screen_data,

    oft$screen_data = RECORD
      file_lock: ost$signature_lock,
      window_id: dpt$window_id,
      display_action: oft$display_action,
      display_name: ost$name,
      display_user: oft$display_user,
      display_procedure_p: oft$display_procedure,
      initial_call: boolean,
      open_file_count: integer,
    recend,

    oft$display_action = (ofc$da_process_display, ofc$da_terminate_window, ofc$da_new_display_requested),

    oft$display_user = (ofc$du_no_one, ofc$du_ve_display_user, ofc$du_file_user),

    oft$screen_files = (ofc$sf_display_a, ofc$sf_display_b, ofc$sf_main_or_other);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
*copyc oft$display_procedure
*copyc ost$name
*copyc ost$signature_lock
?? POP ??
*DECK DECK=OFT$SYSTEM_LINE_INFO EXPAND=FALSE

  TYPE
    oft$system_line_info = RECORD
      initialized: boolean,
      last_nostime: integer,
      last_clocktime: integer,
      last_idletime,
      last_io_idletime: ARRAY [0..(osc$max_number_of_processors - 1)] of integer,
      idle_count: ARRAY [0 .. (osc$max_number_of_processors - 1)] of 0 .. osc$max_idle_count,
    RECEND;

*copyc ost$cpu_idle_statistics
*copyc osc$multiprocessor_constants
*DECK DECK=OFV$COMPILE_FOR_180 EXPAND=FALSE
{this common deck is used to control the conditional assembly
{of the type declarations between cyber 170 mode and cyber 180
{mode.  this deck defines the 180 state for compilation.


  ?VAR
    ofv$compile_for_180: boolean := TRUE?;
*DECK DECK=OFV$DISPLAYS_INITIALIZED EXPAND=FALSE

  VAR
    ofv$displays_initialized: [XREF] boolean;
*DECK DECK=OFV$DISPLAY_MESSAGE_UPDATE EXPAND=FALSE

  VAR
    ofv$display_message_update: [XREF] boolean;

*DECK DECK=OFV$SCREEN_STATUS EXPAND=FALSE

  VAR
    ofv$screen_status: [XREF, oss$task_shared] oft$screen_status;

?? PUSH (LISTEXT := ON) ??
*copyc oft$screen_status
*copyc oss$task_shared
?? POP ??
*DECK DECK=OPERATE_STATION_ERS EXPAND=TRUE
\date=28 June 1989
\folio=station operator commands
\title=Station Operator Utility ERS
\headb
\autosec
\tablcon
\seth~
\block
\ 1 Batch Station Operator Commands
\ 2 Introduction
The NOS/VE batch i/o facilities are provided by CDCNET batch
i/o stations.  A CDCNET batch i/o station can be a public
station or can be a private station.  Files to be printed at a
private station carry a station operator's identity as an
attribute and can only be printed at a private station being
operated by that operator.
Jobs input from a private station carry the station operator's
user identity as an attribute (the control user attribute) and can be
statused and controlled by that user. The output of jobs
that are input from a batch station (public or private) is printed
at that same station by default.
Files to be printed at a public
station can be printed regardless of which operator (if any) is
operating the station.  Public stations can operate either with
or without an operator.  Private stations require an operator.
Station operation is done via the NOS/VE batch station operator
utility, operate_station.  Users can status but not control a station
with a subset utility, display_station.

This document describes NOS/VE batch station operator
utility commands.

This utility is not used to control NOS batch stations.

\ 2 References
\+item,n
 . Operate_Station Enhancements DAP (A8722)

 . NOS/VE Batch Support Phase II DAP (ARH7301)

 . Stand Alone Printer Support DAP (S5134)

 . Batch Device Support on NVE DAP (ARH6250)

 . NOS/VE Batch Device Support Design Direction

 . Status and Control Facility/DI ERS
\-
\ 2 Operate Station command
The purpose of this command is to invoke a copy of the Batch
Station Operator utility and to establish the requestor as the
operator of a batch station.

The requestor must be validated to operate the specified station
and the station must not already be under the control of an
operator.  For certain stations the requestor must also be using
a designated terminal.

\table;5,10,12,14,16
 ;operate_station, opes (
 ;;station_name, sn: name = $required
 ;;status)

\+flowtab;6,11

 ;station_name:  This parameter specifies the name of the
station to be operated.  In the case of a dynamic private
station (which does not have a known station name) the batch
station control facility name is used as the station name.

 ;status: See ERROR HANDLING.

\-

The user must be validated to operate the named station.

Note: For the 1.2.1 and 1.2.2 releases a user may be validated
to operate all stations or no stations, but not a particular
(list of) station(s).

\ 2 Display Station command

The purpose of this command is to invoke a restricted form of the Batch
Station Operator utility which does not establish the requestor as the
operator of a batch station.  Only the station status subcommands described
in section 1.9 are available.  These subcommands are:

\table;5,10,12,14,16
 ;display_batch_device_status
 ;display_station_queue_entry
 ;display_station_queue_status
 ;display_station_status
 ;quit

Some of the displays produced by the status subcommands are restricted to
only show data that applies to the user.  Multiple invocations of
display_station can be active on the same station at one time.  A site can
choose to restrict access to display_station.  Otherwise any NOS/VE user
can access it.

\table;5,10,12,14,16
 ;display_station, opes (
 ;;station_name, sn: name = $required
 ;;status)
\+flowtab;6,11

 ;station_name:  This parameter specifies the name of the
station to be statused.  In the case of a dynamic private
station (which does not have a known station name) the batch
station control facility name is used as the station name.

 ;status: See ERROR HANDLING.

\-
If a site defines a validation capability called scheduling_displays, the user
must be validated to status the named station.

\ 2 Quit Subcommand
The purpose of this subcommand is to relinquish operational
control of a batch i/o station and to terminate the current
instance of execution of the i/o station operator utility.

 ;quit, qui (
 ;;status)

\+flowtab;6,11

 ;status: See ERROR HANDLING.
\-
\ 2 Device Control Subcommands
\ 3 Change Batch Device Attributes
The purpose of this subcommand is to change the attributes of
a batch station device.

If an optional attribute parameter is omitted, that attribute of
the device remains unchanged.

Most of these attributes only have relevance for output devices.
Only external_characteristics_1, file_acknowledgement,
and terminal_model are meaningful for an input device.

 ;change_batch_device_attributes, chabda (
 ;;device_name, dn: name = $required
 ;;banner_highlight_field, bhf: key
 ;;;;comment_banner, cb
 ;;;;routing_banner, rb
 ;;;;site_banner, sb
 ;;;;user_file_name, ufn
 ;;;;user_name, un
 ;;;keyend
 ;;banner_page_count, bpc: integer 0..3
 ;;carriage_control_support, ccs: key
 ;;;;pre_print
 ;;;;post_print
 ;;;;(both, b)
 ;;;keyend
 ;;code_set, cs: key
 ;;;;ascii
 ;;;;ascii48
 ;;;;ascii64
 ;;;;ascii95
 ;;;;ascii128
 ;;;keyend
 ;;device_alias_1, da1: any of
 ;;;;name
 ;;;;key
 ;;;;;none
 ;;;;keyend
 ;;;anyend = $optional
 ;;device_alias_2, da2: any of
 ;;;;name
 ;;;;key
 ;;;;;none
 ;;;;keyend
 ;;;anyend = $optional
 ;;device_alias_3, da3: any of
 ;;;;name
 ;;;;key
 ;;;;;none
 ;;;;keyend
 ;;;anyend = $optional
 ;;external_characteristics_1, ec1: string 0..6
 ;;external_characteristics_2, ec2: string 0..6
 ;;external_characteristics_3, ec3: string 0..6
 ;;external_characteristics_4, ec4: string 0..6
 ;;file_acknowledgement, fa: boolean
 ;;forms_code_1, fc1: string 0..6
 ;;forms_code_2, fc2: string 0..6
 ;;forms_code_3, fc3: string 0..6
 ;;forms_code_4, fc4: string 0..6
 ;;forms_size, fs: string 1..4
 ;;maximum_file_size, mfs: integer 0..99999999
 ;;page_width, pw: integer 10..255
 ;;terminal_model, tm: name 1..25 = $optional
 ;;transmission_block_size, tbs: integer 0..65535
 ;;un_defined_fe_action, udfa: key
 ;;;;print_after_spacing, pas
 ;;;;print_before_spacing, pbs
 ;;;;discard_print_line, dpl
 ;;;keyend
 ;;un_supported_fe_action, usfa: key
 ;;;;print_after_spacing, pas
 ;;;;print_before_spacing, pbs
 ;;;;discard_print_line, dpl
 ;;;keyend
 ;;vertical_print_density, vpd: key
 ;;;;six_only
 ;;;;eight_only
 ;;;;six_any
 ;;;;eight_any
 ;;;keyend
 ;;vfu_load_procedure, vlp: name
 ;;status)

\+flowtab;6,11

 ;device_name: This parameter specifies the device
whose attributes are to be changed.

 ;banner_highlight_field:  This parameter specifies which of the
banner fields will be given prominence on this device.

 ;banner_page_count:  This parameter specifies the number of
copies of banner page that this device will include with the
file.

 ;carriage_control_support: This parameter specifies the types of
carriage control action that the device supports.

Pre_print indicates vertical positioning  prior to printing the
line.  Post_print indicates vertical positioning after printing
the line.

 ;code_set:  This parameter specifies how the
station software should fold (translate) characters before
sending them to the printer. ASCII and ASCII128 are synonymous
and indicate no folding. ASCII95 indicates that any characters
outside of the 95 character set are to be folded into characters
within the set. Likewise, ASCII64 and ASCII48 indicate
that any characters outside of the 64 or 48 character sets are
to be folded to characters within the indicated character set.
The exact translation to be performed in these cases is defined
in the CDCNET Terminal Support ERS.

 ;device_alias_n:  These parameters specify alternate names
by which the device can be referenced.  The same device alias
name can be assigned to more than one device within a station.
To cancel a previously established alias, use the keyword
'none'.

;external_characteristics_n:  These parameters specify
external_device_characteristic strings for which this device
provides support.

For output devices, these device attributes affect the
selection of files that will be printed on the device.  The
external characteristics attribute of a file must match one of
the external characteristics of the device in order for the file
to be printed on the device.

For card reader input devices, only external_characteristics_1
has meaning. External_characteristics_2, external_characteristics_3,
and external_characteristics_4 are ignored. External_characteristics_1
specifies the default code set of the card reader. String values
026 and 029 are defined.

When a NOS/VE job that generates a print file does not
specify an external device characteristics value (the usual
case) a value of 'NORMAL' is supplied for the file. Thus it is
expected that most files will need a printer with 'NORMAL'
as one of its values in order to be printed.

To cancel a previously established string, change it to spaces.

 ;file_acknowledgement:  This parameter specifies
whether or not file acknowledgement messages related to the
device are to be displayed on the station operator console.

The File Acknowledgement messages are purely informational
and do not cause suspension of a device.  They can be
selected or suppressed for the entire station via the station
definition commands.  If they are selected for the entire
station they cannot be suppressed for individual devices.  If
not selected for the station, they can be selectively activated
for a particular device via this subcommand.

If file acknowledgement is selected for an input device, a
message is sent to the operator at the completion of every job
transfer from that device. If file acknowledgement is
selected for an output device, a message is sent to the operator
at the beginning and end of every file transfer to that device.

 ;forms_code_n:  These parameters specify forms_code strings
for which this device provides support.

These device attributes affect the selection of files that
will be printed on the device.  The forms code attribute of the
file must match one of the forms codes of the device in order to
be printed on the device.

When a NOS/VE job that generates a print file does not
specify a forms code value (the usual case) a value of 'NORMAL' is
supplied for the file.  Thus it is expected that most files will
need a printer with 'NORMAL' as one of its values in order to be
printed.

To cancel a previously established string, change it to spaces.

 ;forms_size:  This parameter specifies the length in inches
of the form being used in the printer.  Strings representing
decimal numbers that are multiples of half inches from 0.5 to
31.0 are allowed.

This device attribute affects the selection of files that
will be printed on the device.

If the file's vertical print density is specified as six or
eight lines per inch, the file's page length attribute divided
by its vertical print density attribute must be less than or
equal to the forms size attribute of the device.

If the file's vertical print density is specified as 'any'
and the device's vertical print density is six_only or six_any,
then the file's page length divided by six must be less than or
equal to the forms size attribute of the device.  Similarily, if
the device's vertical print density is eight_only or eight_any,
then the file's page length divided by eight must be less than
or equal to the forms size attribute of the device.

 ;maximum_file_size:  This parameter specifies the maximum
size in bytes of output files that will be routed to this
device.

This device attribute affects the selection of files that
will be printed on the device. The byte length of
the file must be less than or equal to the maximum file size
attribute of the device in order for the file to be printed
on the device.

A value of zero indicates an unlimited file size.

 ;page_width: This parameter specifies the number of columns that
are construed to constitute a line for this device.

For printer devices,
this device attribute affects the selection of files that
will be printed on the device. The page width attribute of
the file must be less than or equal to the page width
attribute of the device in order for the file to be printed
on the device.

 ;terminal_model: This parameter specifies the model name of the
device.

 ;transmission_block_size: This parameter specifies the block size
(in bytes) to be used in transfering data for the device.

 ;un_defined_fe_action: This parameter specifies the action that
is to be taken with format effectors that are not defined. PAS
indicates print after spacing, PBS indicates print before spacing,
and DPL indicates discard print line.

 ;un_supported_fe_action: This parameter specifies the action that
is to be taken with format effectors that are defined but are not
supported by the device. PAS
indicates print after spacing, PBS indicates print before spacing,
and DPL indicates discard print line.

 ;vertical_print_density:  This parameter specifies the
vertical print density characteristics of a printer.  Six_only
indicates that the device can only print at six lines per inch.
Eight_only indicates that the device can only print at eight
lines per inch.  Six_any indicates that the device can print at
either six or eight lines per inch and will default to six if
the file being printed specifies a vertical print density value
of "any".  Eight_any indicates that the device can print at
either six or eight lines per inch and that it will default to
eight lines per inch if the file being printed specifies
a vertical print density value of "any".

This device attribute affects the selection of files that
will be printed on the device.

Files that specify six lines per inch will be printed on a
printer that specifies six_only, six_any, or eight_any.

Files that specify eight lines per inch will be printed on a
printer that specifies eight_only, six_any, or eight_any.

Files that specify a vertical print density value of "any"
will be printed on a printer that specifies six_only,
eight_only, six_any, or eight_any.

 ;vfu load_procedure:  This parameter specifies the name
of a vfu load procedure
that defines the default VFU Load
Image (VLI). This default VLI will
be loaded into the device if the file
being printed does not specify a vfu load procedure
defining a VLI that is to be loaded.

This attribute can not be changed by a station operator unless
the device was defined with a VFU_load_option value of OPER or
USER.

If a default VLI is never established for a device, the CDCNET
standard VLI will be used as the default VLI. The CDCNET standard
VLI is defined in a vfu load procedure named CDC_VFU.

 ;status: See ERROR HANDLING.

\-
\ 2 File Transfer Subcommands
\ 3 Position File
The purpose of this subcommand is to reposition an output
file with respect to an output device.

 ;position_file, posf (
 ;;device_name, dn: name = $required
 ;;location, l: any of
 ;;;;integer 0..65535
 ;;;;list 1..2 of string 1..255
 ;;;anyend = 1
 ;;units, u: key
 ;;;;(lines, line, l)
 ;;;;(pages, page, p)
 ;;;keyend = page
 ;;direction, d: key
 ;;;;(forward, f)
 ;;;;(backward, back, b)
 ;;;keyend = backward
 ;;starting_position, sp: key
 ;;;;(beginning,b)
 ;;;;(end,e)
 ;;;;(last_line_printed, llp)
 ;;;keyend = last_line_printed
 ;;preview, pv, p: integer 1..10 = $optional
 ;;status)
\+flowtab;6,11

 ;device_name: This parameter specifies a name of the device
which is to be positioned. The device must be an output device.

 ;location: This parameter specifies where the file is to be positioned.

Use of an integer indicates the number of lines or pages to
be moved forward or backward from the starting point (see
direction, units, and starting position parameters).

Use of a list of strings indicates positioning to a line containing
the desired string(s). A single string indicates positioning to a line
containing that string. Two strings indicates positioning to
a line containing the first string followed somewhere in the same line
with the second string. The starting point, units, and direction of search
parameters all affect the final location.

 ;units: This parameter specifies whether the location integer indicates
lines or pages.

The pages option also implies positioning to the
beginning of a page.  Thus, use of a location string together with
a units option of PAGES, indicates positioning to the top of the page
that contains the desired line.

A starting position of END together with a units option of PAGES
indicates starting at the beginning of an imaginary page following
the final page rather than at the beginning of the final page.
Similarily, a starting position of END together with a
units option of LINES indicates starting at an imaginary line
following the final line of the file.

Note that a location of zero pages backward or forward from
the LAST_LINE_PRINTED is the top of the page that was last being
printed.

 ;direction: This parameter specifies whether positioning is
to move forward or backward from the starting position.

 ;starting_position:  This parameter specifies the starting
point for the positioning. BEGINNING indicates starting from the beginning
of the file. END indicates starting from the end of the file.
LAST_LINE_PRINTED indicates starting from the last line that was printed.

 ;preview: This parameter specifies that the indicated number of
lines (starting at the selected new position) are to be displayed at
the station operators terminal.

The position_file subcommand causes the file transfer to be
suspended.  If the preview option is not specified the transfer
restarts automatically at the selected new position.  If the
preview option is specified the operator must restart the
transfer after the preview data has been displayed at the
operators terminal.  Alternatively, the operator can respond to
the previewed data with another position_file subcommand (in
which case the last_line_printed is construed to be the line
just positioned to).

 ;status: See ERROR HANDLING.
\-

If a location parameter integer specifies a position outside
the range of the file (example:  'position_file 50 pages back'
when printing page 48), the file will be positioned to the beginning
or end of the file as the case may be.  This is not
considered to be an error condition.  Nevertheless, if the
preview option is selected, a message indicating that the file
is positioned at the beginning or end will be prefixed at the
beginning of the preview data.

If a search string is given and the string is not found, the
file remains positioned at the last line printed.  In
this case a message indicating that the string was not found
will be prefixed at the beginning of the preview data. If
previewing is not selected, printing will then resume at the last
line printed.

This subcommand is primarily intended for use with printers.
For other output devices and for all transparent mode printers
the only positioning allowed is to the beginning or end of the
file.

\under
EXAMPLES
\nounder

The following equivalent subcommands will all position printer
PR2 to the top of the page preceeding the page that was last
being printed.

 ;;POSF PR2
 ;;POSF PR2 1
 ;;POSF PR2 1 PAGE
 ;;POSF PR2 1 PAGE BACK
 ;;POSF,DN=PR2,L=1,U=P,D=B,SP=LLP

The following subcommand will do the same as the above subcommands
plus it will show a two line preview of the new position on
the operators console.

 ;;POSF PR2 PV=2

The following subcommand will position back to the top of the
page that contains the string 'Page 5-29' and will show the
first four lines of that page on the operators console.

 ;;POSF PR2 'Page 5-29' PV=4

The following subcommand will position back ten lines from the
last line printed.

 ;;POSF PR2 10 LINES

The following subcommand will position the file forward by fifty
pages.

 ;;POSF PR2 50 PAGES FORWARD

The following subcommand will rewind the file.

 ;;POSF PR2 SP=BEGINNING

The following equivalent subcommands  will position the file to the top of
the final page.

 ;;POSF PR2 SP=B
 ;;POSF PR2 1 PAGE BACK SP=END

The following subcommand will position the file to the final line.

 ;;POSF PR2 SP=END U=LINE

The following subcommand will position the file at the end.

 ;;POSF PR2 SP=END L=0

\ 3 Suppress Carriage Control
The purpose of this subcommand is to suppress the
interpretation of carriage control characters in a file being
transferred to a printer.

This subcommand only affects a single file transfer. The device reverts
to interpreting carriage control characters when the next file transfer
begins.

While carriage control interpretation is being suppressed, the carriage
control character at the beginning of each line is included with the line
being printed.

 ;suppress_carriage_control, supcc (
 ;;device_name, dn: name = $required
 ;;status)
\+flowtab;6,11

 ;device_name: This parameter specifies the device
for which carriage control is to be suppressed. If the named
device is not a printer, the subcommand has no effect.

 ;status: See ERROR HANDLING.
\-
\ 3 Terminate transfer
The purpose of this subcommand is to terminate the transfer
of the file to or from the device and for output files to
optionally requeue the file for transfer at some later time.

 ;terminate_transfer, tert (
 ;;device_name, dn: name = $required
 ;;file_disposition, fd: key
 ;;;;requeue
 ;;;;drop
 ;;;;hold
 ;;;keyend = drop
 ;;status)
\+flowtab;6,11

 ;device_name: This parameter specifies the device for which
transfer is to be terminated.

 ;file_disposition:  This parameter specifies the disposition
of the file that was being transferred.
\+item
 . REQUEUE indicates that the file is to be requeued with its
current priority values.
 . DROP specifies that the file is to be discarded.
 . HOLD specifies that the file is to be requeued and is not to
be selected for transfer again until referenced by a SELECT_FILE
subcommand.
\-

An input file will always be dropped if its transfer is terminated
by this subcommand.

 ;status: See ERROR HANDLING.
\-
\ 3 Stop Batch Device

The purpose of this subcommand is to remove a device from service
until it is restarted with a start_batch_device subcommand. It may take
effect immediately (fd = r, d, h, or s) or at the end of the current
file transfer (fd = f).

 ;stop_batch_device, stobd, stop (
 ;;device_name, dn: name = $required
 ;;file_disposition, fd: key
 ;;;;requeue, r
 ;;;;drop, d
 ;;;;hold, h
 ;;;;finish, f
 ;;;;suspend, s
 ;;;keyend = suspend
 ;;status)
\+flowtab;6,11

 ;device_name: This parameter specifies the device
which is to be stopped.

 ;file_disposition:  This parameter specifies the disposition
of the file (if any) being transferred. If no file is being
transferred this parameter is ignored.
\+item
 . REQUEUE, DROP, and HOLD terminate the current file transfer.
Thus the device will be available for selection when it is
restarted. Output files receive the following disposition:
\+item
 . REQUEUE causes the file to be requeued with its
current priority values.
 . DROP causes the file to be discarded.
 . HOLD causes the file to be requeued and to not
be selected for transfer again until referenced by a SELECT_FILE
subcommand.
\-

      For input devices, REQUEUE, DROP, and HOLD all cause the
transfer to be terminated, the partially transmitted file
to be discarded, and the input device to be positioned to the next end
of file and then stopped.

 . FINISH allows the current transfer to continue to completion
before the device is stopped. Thus an output device will be available
for selection when it is restarted, and an input device will be available
to input additional files when it is restarted.
 . SUSPEND specifies that the file transfer is not terminated
but is only suspended. The file
remains assigned to the device and the transfer will be resumed
when the device is restarted.
\-

 ;status: See ERROR HANDLING.
\-
\ 3 Start Device
 The purpose of this subcommand is to resume any suspended transfer
to or from the device and/or to re-instate the device as a candidate
for selection.

 ;start_batch_device, stabd, start (
 ;;device_name, dn: name = $required
 ;;status)
\+flowtab;6,11

 ;device_name: This parameter specifies the device
which is to be started.

 ;status: See ERROR HANDLING.
\-
\ 2 File Selection Subcommands
\ 3 Select File
The purpose of this subcommand is to give the selected file the highest
possible priority within the station's queue of output files.

The file must be a candidate for printing at the station being operated.
That is, it must be present in the station's queue of output files.

 ;select_file, self (
 ;;name, n: name = $required
 ;;device_name, dn: name = $optional
 ;;status)

\+flowtab;6,11
 ;name: This parameter specifies the name of the file
being selected. Either the system supplied name or the
user supplied name may be used.

 ;device_name:  This parameter specifies the device to which
the file is to be transferred.  If this name is specified, the
normal selection rules for matching a file with a device, such
Rs forms code, page size, external device characteristics,
device type, etc., will be overridden (caveat selector).

If this parameter is omitted, the file will be moved to the
head of the priority chain but the normal device selection rules
for the station will be used to determine which, if any, of the
station's output devices matches the attributes of the file.

The device must be an output device.

 ;status: See ERROR HANDLING.
\-
\ 3 Terminate Queued Output
The purpose of this subcommand is to delete files from the station's output
queues.  After this command successfully executes, the file(s) will no longer
exist in any output queue.

 ;terminate_queued_output, terqo (
 ;;name, names, n: list of name = $required
 ;;status)

\+flowtab;6,11

 ;name:  This parameter specifies the queue file(s) to be terminated.
Name may be either the system supplied name or the user supplied name.

 ;status: See ERROR HANDLING.
\-
\ 2 Station Status Subcommands
\ 3 Display Batch Device Status
The purpose of this subcommand is to display the attributes
and status of a batch station device.

 ;display_batch_device_status, disbds (
 ;;device_name, dn: any of
 ;;;;list of name
 ;;;;key
 ;;;;;printers
 ;;;;;plotters
 ;;;;;punches
 ;;;;;readers
 ;;;;;all
 ;;;;keyend
 ;;;anyend = $required
 ;;display_option, do:key
 ;;;;all,a
 ;;;;brief, b
 ;;;keyend = brief
 ;;output, o: file reference = $output
 ;;status)

\+flowtab;6,11
 ;device_name: This parameter specifies the name of the device(s)
whose status is to be displayed.

 ;display_option: This parameter specifies which items are to be displayed.
ALL indicates that all the items are to be displayed. BRIEF indicates
that only device name, device status, transfer status, percent
complete, and last unsolicited message are to be displayed.

 ;output: This parameter specifies the file where
the output is to be displayed.

 ;status: See ERROR HANDLING.
\-

The following information will be displayed:
\+item
 . device name
 . device status
 . device type
 . external device characteristic strings
 . file acknowledgement status
 . last unsolicited message concerning the device
 . page width
 . terminal model
 . transfer status
\-
For output devices the following additional information
will be displayed:
\+item
 . banner highlight field
 . banner page count
 . code set
 . device aliases
 . forms size
 . forms code strings
 . maximum file size
 . page length
 . transmission block size
 . undefined fe action
 . unsupported fe action
 . vertical print density
 . vfu image load options (none, init, oper, user)
 . vfu load procedure
 . information about the file being transferred to the device
\+item
 - system supplied file name
 - user supplied file name *
 - system supplied job name of generating job *
 - user supplied job name of generating job *
 - login user name of generating job *
 - family name of generating job *
 - percent complete
\-
\-
For input devices the following additional information
will be displayed:
\+item
 . information about the file being transferred from the device
\+item
 - user job name *
 - destination name *
 - approximate lines transferred so far *
\-
\-
In the display_station utility, the items marked with an asterisk (*)
above will only be displayed when the user owns the associated file.
\ 3 Display Station Status
The purpose of this subcommand is to display the
status of the batch i/o station being operated.

 ;display_station_status, disss (
 ;;output, o: file reference = $output
 ;;status)

\+flowtab;6,11
 ;output: This parameter specifies the file where
the output is to be displayed.

 ;status: See ERROR HANDLING.
\-

The following information will be displayed:
\+item
 . Station name.
 . Control facility name.
 . Station alias list.
 . List of devices showing device type, device status,
and transfer status for each.
 . Number of files queued for the station.
 . File Acknowledgement required (yes/no)
 . Fixed console device name.
 . Station usage (public/private).
 . Default job destination.
 . Destination unavailable action.
 . PM message action.
 . Store and forward destination. (not in 1.2.1 or 1.2.2)
\-
\ 3 Display Station Queue Status
The purpose of this subcommand is to
display the status of the queue of output files destined
for the station.

 ;display_station_queue_status, dissqs (
 ;;display_option, do:key
 ;;;;all,a
 ;;;;brief, b
 ;;;keyend = brief
 ;;output, o: file reference = $output
 ;;status)

\+flowtab;6,11

 ;display_option: This parameter specifies which items are to be displayed.
ALL indicates that all the items are to be displayed. BRIEF indicates
that only the summaries for printers, plotters, and punches are to be
displayed.

 ;output: This parameter specifies the file where the
information is to be displayed.

 ;status: See ERROR HANDLING.
\-

The following information will be displayed:
\+item
 . Number of files in the queue.
 . Each of the external device characteristic strings in
the queue and the number of files with that string.
 . Each of the forms code strings in the queue with the number
of files for each.
 . Explicitly requested device names in the queue and the number
of files for each.
 . Each destination name (station name and station alias names)
and the number of files for each.
 . Each device type (printer, plotter,punch) and the number
of files for each.

In addition to the number of files, the total byte length in kilobytes,
the age of the oldest file, and the average file age will be
shown for each category.
\-
\ 3 Display Station Queue Entries
The purpose of this subcommand is to display information about
specific entries in the station output queue.

 ;display_station_queue_entry, dissqe (
 ;;name, names, n: any of
 ;;;;list of name
 ;;;;key
 ;;;;;top_ten
 ;;;;;all
 ;;;;keyend
 ;;;anyend = $required
 ;;display_option, do:key
 ;;;;all,a
 ;;;;brief, b
 ;;;keyend = brief
 ;;output, o: file reference = $output
 ;;status)

\+flowtab;6,11

 ;name:  This parameter specifies the queue file(s) about
which information is to be displayed.  Name may be either the
system supplied name or the user supplied name.  TOP_TEN
specifies that information is to be displayed about ten files
that are top candidates for transfer.  All indicates that
information is to be displayed about all the queue entries.

 ;display_option: This parameter specifies which items are to be displayed.
ALL indicates that all the items are to be displayed. BRIEF indicates
that only the system supplied file name, user file name, file owner
identification, and file length are to be displayed.

 ;output: This parameter specifies the file where the
information is to be displayed.

 ;status: See ERROR HANDLING.
\-

The following information will be displayed with each entry:
\+item
 . System supplied file name.
 . User file name.
 . System supplied job name.
 . User supplied job name.
 . Login family name and login user name of generating job.
 . Time enqueued (when file availability message was received
by SCFS.
 . Current position in queue.
 . Priority.
 . Destination name (i.e. station name or station alias name)
 . Copies requested.
 . Page format (continuous, burstable, non-burstable).
 . Device type (printer/plotter).
 . Data mode (coded, transparent).
 . Explicit device or alias name.
 . File length.
 . External device characteristics string.
 . Forms code string.
 . Page width.
 . Page length.
 . Vertical print density.
 . VFU load image name.
\-
In the display_station utility, only files that the user owns will be
displayed.
\ 2 Unsolicited Operator Messages.
Unsolicited messages to the operator can be caused by
the following events.
\+item,n
 . A PM message is encountered in an output file.
 . A file positioning preview message arrives.
 . A file acknowledgement message arrives.
 . An input file error (route_job or user validation) occurs.
 . An initial vfu load procedure error occurs.
 . A control facility failure/recovery message arrives.

\-

Users in the display_station utility will not receive any unsolicited
messages.

When a PM message is sent to the operator, the data transfer
to the affected device is automatically suspended.  The operator
must use the start subcommand to get the transfer restarted.  PM
messages can be selected or suppressed for a station via the
DEFIOS or DEFUIOS station definition commands.

When a file positioning preview message is sent to the operator
the file transfer is suspended until a start subcommand is given.
The operator can give an additional positioning subcommand at
this time instead of the start subcommand.

The File Acknowledgement messages are purely informational
and do not cause suspension of a device.  They can be selected
or suppressed via the station definition commands.  If they are
selected for the station they cannot be suppressed for
individual devices.  If not selected for the station, they can
be selectively chosen for each device via the
change_batch_device_attribute operator subcommand.

If an input file error message is received, the operator must
correct the route_job or login statement as appropriate
before the input file can be transferred successfully.

If an initial vfu load procedure error message is received
the operator must correct the statements within the vfu load
procedure before the device can be successfully initiated.

Control facility failure/recovery messages may require the
operator to wait for recovery to complete before issuing
further batch station subcommands.

If an operator issues a NOS/VE SCL command from within the i/o
station utility, the appearance of the unsolicited messages at
the operators terminal may be delayed until the SCL command
completes.
*DECK DECK=OSA$BASIC_REGISTER_EQUATES EXPAND=FALSE
.....................  begin common deck OSA$BASIC_REGISTER_EQUATES ................
.
.
.  Define Macros for definning X and A register equates.
.
          PROC
xreg      pname
f:(0,0)   equ    f:(2,0)
f:(0,0)   atrib  #regtyp,#xreg
          PEND
          PROC
areg      pname
f:(0,0)   equ    f:(2,0)
f:(0,0)   atrib  #regtyp,#areg
          PEND
.
.  Define A and X register usage
.
a_tos     areg     0
a_dsp     areg     0
a_csf     areg     1
a_psa     areg     2
a_bindin  areg     3
a_plist   areg     4
.
.
.
.....................  end common deck OSA$BASIC_REGISTER_EQUATES ....................
*DECK DECK=OSA$CYBIL_INTERFACE EXPAND=FALSE
         page
..
.
.  Common deck osa$cybil_interface
.  Defines macros for cracking the parameter list when called
.  from a Cybil program.
.
          proc
procedur  pname
xxxploc   set       0,0,0,0
          align     0,8
f:(0,0)   bss       0
          do        sn:(f:(2,0))=sn:(gated)
          defg      f:(0,0)
          else
          def       f:(0,0)
          dend
          pend
.
         proc
function pname
         do       sn:(f:(2,0))=sn:(integer)
xxxploc    set    0,1,1,8
yyyploc    set    0
         else
           do     sn:(f:(2,0))=sn:(subrange)
xxxploc      set  0,1,3,f:(2,1)
yyyploc      set  0
           else
             do   sn:(f:(2,0))=sn:(boolean)
xxxploc        set 0,1,4,1
yyyploc        set 0
             else
               do  sn:(f:(2,0))=sn:(pointer)
xxxploc          set 0,1,2,6
yyyploc          set 1
               else
               flag fatal  .unknown return type
               dend
             dend
           dend
         dend
         align    0,8
f:(0,0)  bss      0
         def      f:(0,0)
         pend
.
         proc
freturnx pname
          do     xxxploc[1]=1
          do     yyyploc=0
            do   #regtyp[f:(2,0)]=#xreg
              do   f:(2,0)=15
                return
              else
                cpyxx  xf,f:(2,0)
              dend
            else
              flag fatal       .Incorrect register usage
            dend
          else
            do   #regtyp[f:(2,0)]=#areg
              do f:(2,0)=15
                return
              else
                cpyaa  af,f:(2,0)
              dend
            else
              cpyxa     af,f:(2,0)
            dend
          dend
          return
          else
            flag fatal       .not in a function
          dend
         pend
.
          proc
param     pname
          local  data_t,param_t,param_l,field_l,offset
param_l   set    0
offset    set    0
          do     sn:(f:(2,1))=sn:(integer)
data_t    set    1
field_l   set    8
          dend
          do     sn:(f:(2,1))=sn:(pointer)
data_t    set    2
field_l   set    6
offset    set    2
          dend
          do     sn:(f:(2,1))=sn:(subrange)
data_t    set    3
field_l   set    f:(2,2)[0]
offset    set    8-f:(2,2)[0]
          dend
          do     sn:(f:(2,1))=sn:(boolean)
data_t    set    4
field_l   set    1
offset    set    7
          dend
          do     sn:(f:(2,1))=sn:(string)
            do     f:(2,2)<=8
data_t    set    5
field_l   set    f:(2,2)[0]
offset    set    8-f:(2,2)[0]
            dend
            do     f:(2,2)>8
data_t    set    6
field_l   set    6
param_l   set    f:(2,2)[0]
            dend
          dend
           do     sn:(f:(2,1))=sn:(astring)
data_t    set    7
field_l   set    8
          dend
.
          do     sn:(f:(2,0))=sn:(ref)
            do     data_t<=5
param_t   set    1
param_l   set    field_l
field_l   set    6
offset    set    0
            dend
          else
param_t   set    2
          dend
.
f:(0,0)   set    xxxploc[0]+offset,data_t,param_t,field_l,param_l
xxxploc[0]  set    xxxploc[0]+8
          pend
.
.
          proc
ploada    pname
          do     f:(2,1)[1]=6
f:(0,0)   la     f:(2,0),a_plist,f:(2,1)[0]
          else
            do     f:(2,1)[2]=1
              do     f:(2,1)[1]=2
f:(0,0)       la     amacsr,a_plist,f:(2,1)[0]
              la     f:(2,0),amacsr,0
              else
f:(0,0)         la     f:(2,0),a_plist,f:(2,1)[0]
              dend
            else
              do     f:(2,1)[1]=2
f:(0,0)       la     f:(2,0),a_plist,f:(2,1)[0]
              else
                flag  fatal    .Wrong macro usage
              dend
            dend
          dend
          pend
.
.
          proc
ploadx    pname
          do     f:(2,1)[1]=2
          flag   fatal       .Wrong macro usage
          else
            do     f:(2,1)[1]=6
            flag   fatal     .Wrong macro usage
            else
              do     f:(2,1)[1]=7
              flag   fatal    .Wrong macro usage
              dend
            dend
          dend
          do     f:(2,1)[2]=1
f:(0,0)   la     amacsr,a_plist,f:(2,1)[0]
          lbyts,f:(2,1)[4]  f:(2,0),amacsr,x0,0
          else
f:(0,0)   lbyts,f:(2,1)[3]  f:(2,0),a_plist,x0,f:(2,1)[0]
          dend
          pend
.
.    PSTRING  This macro is used only for adaptable strings.
.
          proc
pstring   pname
          do     f:(2,2)[1]=7
f:(0,0)   la     f:(2,0),a_plist,f:(2,2)[0]
          lbyts,2  f:(2,1),a_plist,x0,f:(2,2)[0]+6
          else
            flag   fatal    .Wrong macro usage
          dend
          pend
.
.
          proc
pstorxp   pname
          do        f:(2,1)[2]=1
f:(0,0)     la      amacscr,a_plist,f:(2,1)[0]
            sbyts,f:(2,1)[4]  f:(2,0),amacscr,x0,0
          else
            flag    fatal  .must be pointer type
          dend
          pend
.
          proc
pstorap   pname
          do        f:(2,1)[1]=2
            do f:(2,1)[4]=6
f:(0,0)       la    amacscr,a_plist,f:(2,1)[0]
              sa    f:(2,0),amacscr,0
            else
              flag   fatal  .param length must be 6
             dend
          else
            flag    fatal  .must be pointer type
          dend
          pend
.
.***  End common deck OSA$CYBIL_INTERFACE
*DECK DECK=OSA$DFT_CONSTANTS EXPAND=FALSE
.
.*** common deck OSA$DFT_CONSTANTS.

.
.        Define constants for DFT buffer.
.
dftbfl   equ       6*8                 .length of fixed portion of DFT buffer.
mecbl    equ       10*8                .length of mainframe element counters buffer.
.
.*** End common deck OSA$DFT_CONSTANTS.
*DECK DECK=OSA$DUAL_STATE_170_OS_STACK EXPAND=FALSE
*copy osa$ei_stack_frame
         page
..
.
.  Common deck osa$dual_state_170_os_stack
.
.  Additional static variables for processing of 170 traps when NOS/VE is
.  up and running.  The 170 trap handler is part of NOS/VE monitor when
.  NOS/VE is running.  When NOS/VE goes down the 170 trap handling
.  environment reverts back to the trap handler in EI.  The 170 trap
.  handler in EI knows nothing about these variables.
.

         use       stack
         org       static_size
ve_down  bss       8                   .0 if ve up, 1*2**30 set if VE down.  This
                                       . value is merged in with responses from the
                                       . 170 trap handler when processing 017
                                       . instructions that have to do with VE
                                       . operation.  The caller can than determine
                                       . that VE is down.
forcede  bss       2                   .forced entry flag
dispbuf  bss       6                   .current display buffer
.
.  MLI variables
.
         ALIGN     0,8
ic       bss       8                   .initial request count
pc       bss       8                   .polling request count
fc       bss       8                   .queue full count
nrc      bss       8                   .polling request not ready count
erc      bss       8                   .error count
xrc      bss       8                   .170 XR count
entry    bss       1                   .current entry index
.
         do        $>sf_wrk
         error     c'EI working storage overflow.'
         dend
.
         use       #lastsec
.
.***  End common deck OSA$DUAL_STATE_170_OS_STACK
*DECK DECK=OSA$DUAL_STATE_CONTROL_BLOCK EXPAND=FALSE
         page
..
.
.  Common Deck osa$dual_state_control_block
.  Defines the Dual State Control Block offsets.
.


..
.        DSCBW - Macro used to define offsets to the EI control block (EICB).
.
.        CALLING_SEQUENCE:
.symbol  dscbw     length
.
.        PARAMETERS:
.                  OFFSET_NAME = defines symbol that defines location in EICB of
.                                that value.
.                  LENGTH = length in words associated with symbol value.
.
.        NOTE: Offsets are defined in bytes.
.

         proc
dscbw    pname
f:(0)    equ       dscb_nxt*8
dscb_nxt set       dscb_nxt+f:(2)
         pend
dscb_nxt set       0
.
.
d7ty     dscbw     1                   .C170 OS type
d7jp     dscbw     2                   .C170 job information for cpu 0
d7st     dscbw     1                   .C170 operating system status
d7rs     dscbw     3                   .C170 SCD/MDD communication
d7cm     dscbw     2                   .central memory allocation
d7sv     dscbw     6                   .C170 save area
.
d8ty     dscbw     1                   .C180 operating system type
d8tm     dscbw     2                   .Time spend in C180 OS
d8jp     dscbw     2                   .C180 job parameters for cpu 0
d8st     dscbw     1                   .C180 operating system status
d8ds     dscbw     3                   .deadstart parameters
d8sv     dscbw     6                   .C180 OS scratch area
.
dscm     dscbw     5                   .control information block
dfcm     dscbw     11                  .fatal error message buffer displayed by SCD.

DSCBL    equ       dscb_nxt*8

.
.  Offsets for dual state deadstart.
.
ds_stat  equ       d8ds                .deadstart status
ds_flag  equ       d8ds+4              .deadstart flag
os_sfsa  equ       d8ds+8              .stack frame save area rma
os_jps   equ       d8ds+12             .OS JPS rma
ve_sfsa  equ       d8ds+16             .stack frame save area rma for VE
ve_jps   equ       d8ds+20             .VE JPS rma
.
.  Symbol definition for the concurrent CPU P address.  If running in
.  non-S1 concurrent CPUs, then the P address in the initial exchange
.  package for all CPUs except CPU 0 is set to this address.
.
ccpadd   equ       76(8)*8             .concurrent cpu P address
.
.  Byte offsets for use by MTAMTR.
.
np170ty  equ       d7ty                .date/time pointers, os type
np170pr  equ       d7jp+6              .Current 170 priority
np180pr  equ       d8jp+6              .Current 180 priority
npxtime  equ       d8tm                .Time not spent in NOS
dscbln   equ       dscbl               .dscb block length
.
.  Symbol definition for the EICB pointer word.  This is a real memory word
.  address relative to NOS or NOS/BE address space.
.
eicb_ptr equ       71(8)               .EICB pointer word
.
.  Symbol definitions for the system type and interface level.
.
*copyc syc$compass_os_levels
ost$ei   equ       1
ost$nos  equ       1
ost$nbe  equ       2
ost$nve  equ       2
ost$psr  equ       dft_psr

.  Define EICB interface version number.  I do not understand exactly what this
.  means but if its value is changed check the code in osm$os_environment_monitor
.  that references it.  Instruction retry is not attempted if less than this value.
.  Assume that it has something to to with the host system.

if_versn equ       2
if_level equ       2
.
.  symbol definitions for the dscm words.
.
c170_due equ       21(16)              .c170 due and due with no retry
c180_due equ       24(16)              .c180 due and due with no retry
retry_failed equ   01(16)              .c170=22, c180=25
retry_due equ      10(16)              .c170=32, c180=34
.
.***  End common deck OSA$DUAL_STATE_CONTROL_BLOCK
*DECK DECK=OSA$EI_CONSTANT_DEFINITIONS EXPAND=FALSE
         PAGE
.****************************************************************
.
.        osa$ei_constant_definitions
.
.***************************************************************
.
.        EI MONITOR REQUEST CODES.
.
EIRQC    EQU       1                   .C170 ERROR
DSTRTXR  EQU       2                   .DEADSRT C180 ENVIRONMENT
MTRR#STD EQU       2                   .    DITTO
DONTHING EQU       3                   .DO NOTHING
MTRR#IHF EQU       4                   .INJECT HARDWARE FAULT.
.
.        RESTART TABLE DEFINITIONS.
.
RRLN170  EQU       7                   .170 STATE RSTRT. REGS. LENGTH
RRLN180  EQU       5                   .180 STATE RSTRT. REGS. LENGTH
.
.        BRCR INSTRUCTION OPTION FIELD EQUATES.
.
BRONSET  EQU       2                   .BRANCH ON BIT SET, DO NOT CLEAR
.
.        ERROR CODE EQUATES
.
BADINST  EQU       0(8)                .ILLEGAL INSTRUCTION
AORERR   EQU       1(8)                .ADDRESS OUT-OFF-RANGE ERROR
PERROR   EQU       20(8)               .PROCESSOR DETECTED ERROR
GENCODE  EQU       67(8)               .GENERAL ERROR CODE
.
.        MASK GENERATING EQUATES
.
M18      EQU       3421(8)             .18 BIT MASK
.
.        MCR mask bit equates.
.
bit_48   EQU       8000(16)            .DUE / PIF
bit_49   EQU       4000(16)            .Unassigned / Unimplimented instruction
bit_50   EQU       2000(16)            .Short warning / Free flag
bit_51   EQU       1000(16)            .Instruction spec / PIT
bit_52   EQU       0800(16)            .Addr spec error / Inter-ring pop
bit_53   EQU       0400(16)            .170 exchange / Critical frame flag
bit_54   EQU       0200(16)            .Access violation / Keypoint
bit_55   EQU       0100(16)            .Env spec error / Divide fault
bit_56   EQU       0080(16)            .External interrupt / Debug
bit_57   EQU       0040(16)            .Page fault / Arithmetic overflow
bit_58   EQU       0020(16)            .System call / Exponent overflow
bit_59   EQU       0010(16)            .SIT / Exponent underflow
bit_60   EQU       0008(16)            .Invalid seg ring 0 / FP loss of Sig
bit_61   EQU       0004(16)            .Out call in return / FP indefinite
bit_62   EQU       0002(16)            .Soft error / Arithmetic loss of Sig
bit_63   EQU       0001(16)            .Trap exception / Invalid BDP data
.
.        monitor mask equates.
.
mcr_mask EQU       0ffff(16)-bit_50-bit_53-bit_59-bit_62
.
.        USER CONDITION BIT EQUATES.
.
PIFB     EQU       0                   .PRIVILAGED INSTRUCTION
UIIB     EQU       1                   .UNIMPLEMENTED INSTRUCTION
FRFB     EQU       2                   .FREE FLAG
TIMB     EQU       3                   .PROCESS INTERVAL TIMER
.
.        MONITOR CONDITION BIT EQUATES.
.
XINB     EQU       5                   .EXCHANGE REQUEST
.
.        Equates for the c180 exchange package.
.
xp_p     EQU       (0+0)*8+2           .P REGISTER
xp_vmid  equ       (1+0)*8             .virtual machine id
xp_a0    equ       (1+0)*8+2           .c180 register A0
xp_dsp   EQU       (1+0)*8+2           .DYNAMIC SPACE POINTER
xp_pnd   equ       (1+1)*8             .Process not damaged
xp_tef   equ       (1+1)*8+1           .trap enables flag
xp_um    EQU       (1+2)*8             .USER MASK
xp_mm    equ       (1+3)*8             .MONITOR MASK
xp_ucr   EQU       (1+4)*8             .USER CONDITION REGISTER
xp_mcr   equ       (1+5)*8             .monitor condition register
xp_pit   equ       (1+10)*8            .Processor interval timer
xp_x0    equ       (1+16)*8            .c180 X0 register
xp_sta   equ       (1+32+1)*8          .segment table address
xp_utp   equ       (1+32+1)*8+2        .untranslatable pointer
xp_tp    equ       (1+32+2)*8+2        .trap pointer
xp_rn1   equ       (1+32+4)*8+2        .top of stack for ring 1
.
.        equates for the C170 version of the C180 exchange package.
.
xp_em    EQU       (1+3)*8+2           .EXIT MODE SELECTION
xp_rac   EQU       (1+3)*8+5           .CM REFERENCE ADDRESS
xp_mf    EQU       (1+4)*8+3           .MONITOR FLAG
xp_flc   EQU       (1+4)*8+5           .CM FIELD LENGTH
xp_emhf  equ       (1+5)*8+3
xp_ma    equ       (1+5)*8+5
xp_rae   EQU       (1+6)*8+4           .ECS RA
xp_fle   EQU       (1+7)*8+4           .ECS FL
xp_ca0   EQU       (1+8)*8+5           .A0 REGISTER
xp_cb0   EQU       (1+16)*8+5          .B0 REGISTER
xp_cx0   EQU       (1+24)*8            .X0 REGISTER
.
.        BIT POSITION EQUATES FOR TSFS
BSCIF    EQU       2
.
.        BYTE POSITION EQUATES FOR TXPBUF.
.
ma_p     EQU       0*8+1               .P REGISTER
ma_a0    EQU       0*8+3               .A0 REGISTER
ma_b0    EQU       0*8+5               .B0 REGISTER
ma_rac   EQU       1*8+1               .CM REFERENCE ADDRESS
ma_flc   EQU       2*8+1               .CM FIELD LENGTH
ma_em    EQU       3*8                 .EXIT MODE SELECTION BITS
ma_hrdwe EQU       3*8+1               .HARDWARE ERROR FLAG
ma_rae   EQU       4*8                 .ECS REFERENCE ADDRESS
ma_fle   EQU       5*8                 .ECS FIELD LENGTH
ma_ma    EQU       6*8+1               .MONITOR ADDRESS
ma_x0    EQU       8*8                 .X0 REGISTER
.
.        BIT POSITION EQUATES FOR TXPBUF.
.
BMHDWRE  EQU       4                   .HARDWARE ERROR FLAG
.
.        BIT POSITION EQUATES FOR TJXP
.
BEMHF    EQU       7                   .EXIT MODE HALT FLAG
BMF      EQU       7                   .C170 MONITOR FLAG
.
.        REGISTER USAGE IN OSANTH.
.
a_static AREG      03(16)              .static storage
a_wrk    AREG      0d(16)              .working storage
a_jps    AREG      0b(16)              .pointer to tjxp within monitor
a_rac    AREG      0c(16)              .contains the RAC from the SFSA
a_nos    AREG      0e(16)              .pointer to NOS
a_dscb   AREG      0f(16)              .dual state block pointer
.
x_rac    xreg      0b(16)
x_reg1   XREG      0d(16)
x_reg2   XREG      0e(16)
x_flc    XREG      0f(16)
         space     4
..
.        EI MONITOR CALL PROCEDURE.
.
.        PARAMETERS
.                   P1 - REQUEST CODE,
.                   P2 - EXIT CONDITION CODE.
.
         PROC
EIMTRCAL PNAME
         LOCAL     HALTEI
         ente      x2,f:(2,0)*256+16
         shfc      x0,x2,x0,64-8
         ENTE      X2,F:(2,1)          .EXIT CONDITION CODE
         EXCHANGE
         DO        SN:(F:(2,2))=SN:(NOHLT)
         ELSE
HALTEI   BSS       0
         HALT
         BRREQ     X0,X0,HALTEI
         DEND
         PEND
.
.***  End common deck OSA$EI_CONSTANT_DEFINITIONS
*DECK DECK=OSA$EI_INTERFACE_CONSTANTS EXPAND=FALSE
         PAGE
..
.
.  Common deck osa$ei_interface_constants
.
.  Defines the EI interface constants for the Dual State environment.
.
.
.        DEADSTART FLAG IN STS170.
.
B180DST  EQU       5200(8)
.
.
.        180 STATUS CODES
.
NULL80S  EQU       0                   .NULL 180 STATUS
PRSTST   EQU       1                   .INTRFACE TABLE PRESET STATUS
SRTDSTS  EQU       2                   .START DEADSTART
CPUIDLS  EQU       3                   .CPU IDLING STATUS
NSFSAST  EQU       4                   .NEW STACK FRAME RMA SET STATUS
NSFSAIS  EQU       5                   .NEW STACK FRAME INITIALIZED STATUS
DSTRTSC  EQU       6                   .DEADSTART SYSTEM CORE
REST170  EQU       7                   .C170 RESTART ATTEMPTED STATUS
STP170S  EQU       252                 .C170 FATAL ERROR STATUS
CLNRCST  EQU       255                 .CLEAR RECOVERY STATUS
SSRSMAX  EQU       0200(16)            .MAX SSR FLAGS

.
.        SSR directory offset from beginning of stack segment.
.
ssrdir   equ       1000(16)
.
.................. End   common deck OSAEI8I .........................
*DECK DECK=OSA$EI_STACK_FRAME EXPAND=FALSE
         page
..
.
.  Common deck osa$ei_stack_frame
.
.
         use       stack
stack    bss       0
.
.        offsets relative to  a_wrk  within monitor.
.

xpsw              equ      52          .exchange package size in words.
sf_save_job       bss      xpsw*8      .area to save failing job xp.
sf_170_xp_buffer  bss      16*8
sf_retry          bss      8
sf_exit_condition bss      1
xtra_xj           bss      1
         align     0,8
wrk_size bss       0
.
.        offsets relative to working storage for a processor.
.
         org       stack
SF_MXP            bss      xpsw*8
SF_JXP            bss      xpsw*8
SF_WRK            bss      wrk_size
sf_monitor_stack  bss      2*33*8
sf_job_stack      bss      2*33*8
                  align    0,16
sf_size           bss      0
.
.        offsets relative to common working storage.
.
         org       stack
         bss       2
pva_of_os         bss      8
pva_due_handler   bss      8
pva_abort_job     bss      8
pva_halt_ei       bss      8
pva_segment_table bss      8
pva_of_first_dftb bss      8           .pva of first part of DFT buffer.
.
pva_table         bss      0
pva_of_dscb       bss      8
pva_1             bss      8            .OS definable pva
pva_2             bss      8            .OS definable pva
pva_3             bss      8            .OS definable pva
pva_of_dftb       bss      8            .pva of DFT buffer reading.
pva_table_len     equ       $-pva_table
.
dual_170          bss      1
.
         align     0,16
static_size     bss      0
.
         use       #lastsec
.
.***  End common deck OSA$EI_STACK_FRAME
*DECK DECK=OSA$KEYPOINT_CLASSES EXPAND=FALSE
.
.  Define keypoint class codes
.
oscdata   equ    0             .Data keypoint
oscunus   equ    1             .Unusual keypoint.
oscent    equ    2             .Entry keypoint.
oscexit   equ    3             .Exit keypoint.
oscdbug   equ    4             .Debug keypoint.
oscmtr    equ    5             .monitor entry/exit.
.
.         define bias for monitor exit keypoint.
.
oskxbias  equ    4096
.
.
.
.  Define keypoint codes used in OS assembly language decks.
.
.
oskpurg   equ    4000          .Used in OSAINX wil cache/map purge.
oskexc8   equ    4001          .Exchange to/from 180 job mode.
oskexc7   equ    4002          .Exchange to/from 170 job mode.
osktrpm   equ    4003          .Monitor mode trap.
osktrpj   equ    4004          .Job mode trap.
oskexc8x  equ    oskexc8+oskxbias
oskexc7x  equ    oskexc7+oskxbias
osktrpmx  equ    osktrpm+oskxbias
osktrpjx  equ    osktrpj+oskxbias
.
.
*DECK DECK=OSC$ASID_EI EXPAND=FALSE


{  Define reserved asid's for NOS, EI and EIE.

  CONST
    osc$asid_ei = 8000(16),
    osc$asid_eie = 8001(16),
    osc$asid_nos = 0ffff(16);
*DECK DECK=OSC$BASE_EXCEPTION EXPAND=FALSE

  CONST
*IF NOT $true(osv$unix)
    osc$min_ecc = (($INTEGER ('O') * 100(16)) + $INTEGER ('S')) *  1000000(16),
*ELSE
    osc$min_ecc = (($INTEGER ('O') * 100(16)) + $INTEGER ('S')) *  10000(16),
*IFEND
    osc$base_exception = osc$min_ecc;
*DECK DECK=OSC$BATCH_TRANSFER_SERVER EXPAND=FALSE

  CONST
    osc$batch_transfer_server = 'OSA$BATCH_TRANSFER_SERVER      ';
*DECK DECK=OSC$BUILD_LEVEL_SIZE EXPAND=FALSE

  CONST
    osc$build_level_size = 32;

*DECK DECK=OSC$COMPRESSION_IDENTIFIER EXPAND=FALSE

  CONST
    osc$compression_identifier = '%';
*DECK DECK=OSC$CYCLE_BUSY_COND EXPAND=FALSE
  CONST
    osc$cycle_busy_cond = 'OSC$CYCLE_BUSY                 ';

*DECK DECK=OSC$DATA_RESTORATION_COND EXPAND=FALSE
  CONST
    osc$data_restoration_cond = 'OSC$DATA_RESTORATION_REQUIRED  ';
*DECK DECK=OSC$DATA_RETRIEVAL_REQ_COND EXPAND=FALSE
  CONST
    osc$data_retrieval_req_cond = 'OSC$DATA_RETRIEVAL_REQUIRED    ';


*DECK DECK=OSC$DEADSTART EXPAND=FALSE

  CONST
    osc$deadstart = 'OSA$DEADSTART';
*DECK DECK=OSC$DEFAULT_UTP_RING EXPAND=FALSE

  CONST
    osc$default_utp_ring = 1,
    osc$default_utp_segment = 0fff(16),
    osc$default_utp_offset = 7fffffff(16);

*DECK DECK=OSC$DUAL_STATE_BATCH EXPAND=FALSE

  CONST
    osc$dual_state_batch = 'OSA$DUAL_STATE_BATCH';
*DECK DECK=OSC$DUAL_STATE_INTERACTIVE EXPAND=FALSE

  CONST
    osc$dual_state_interactive = 'OSA$DUAL_STATE_INTERACTIVE';
*DECK DECK=OSC$ECP_MAX_CATALOG_MOVES EXPAND=FALSE
  CONST
    osc$ecp_max_catalog_moves = 10;

*DECK DECK=OSC$EI_TABLES EXPAND=FALSE
.****************************************************************
.
.        DECK OSAEITB,  EI TABLES.
.
.***************************************************************
         USE       STACK
.
.
BGNEIWKS BSS       0                   .BEGIN EI WORKING STORAGE
.
.
.
.        WORKING STORAGE
.
         align     0,8
pvat     bss       0                   .pva table for the minilink
dscbp    bss       8                   .interface table pointer
c180segp bss       8                   .c180 segment pointer
ssrptr   bss       8                   .pointer to ssr
mfwptr   bss       8                   .pointer to mf wired
pvat_len equ       $-pvat
.
exitcnd  bss       1
xtra_xj  bss       1                   .flag to allow one state switch in erridle
         ALIGN     0,8                 .FORCE WORD BOUNDRY
.
.        STACK FRAME SAVE AREA
.
TSFS     BSS       264
.
.        C170 EXCHANGE PACKAGE BUFFER
.
TXPBUF   BSS       128                 .EXCHANGE PACKAGE BUFFER
TXPBUFL  EQU       $-TXPBUF            .LENGTH OF BUFFER
.
.
.        TRAP HANDLER VARIABLES.
.
         ALIGN     0,8
ve_down  bss       8                   .0 if VE up, 1*2^30 if VE down
c170sp   bss       8                   .c170 segment pointer
ERR_FLAG BSS       1                   .ERROR FLAG
XPCKGP   BSS       6                   .PVA OF C180 TASK'S EXCHG.PVA  PCKG.PVA
FORCEDE  BSS       1                   .FORCED ENTRY FLAG
CONNECT  BSS       6                   .CONNECT TABLE POINTER
KEYBUF   BSS       6                   .POINTER TO KEYBOARD BUFFER
DISPBUF  BSS       6                   .POINTER TO DISPLAY BUFFER
DAYFILEB BSS       6                   .POINTER TO DAYFILE BFR
CPBUFFER BSS       6                   .POINTER TO CP BUFFER
MLIPTR   BSS       6                   . MLI POINTER
.
. MLI VARIABLES
.
         ALIGN     0,8
IC       BSS       8                   . INITIAL REQUEST COUNT
PC       BSS       8                   . POLLING REQUEST COUNT
FC       BSS       8                   . QUEUE FULL COUNT
NRC      BSS       8                   . POLLING REQUEST NOT READY COUNT
ERC      BSS       8                   . ERROR COUNT
XRC      BSS       8                   . 170 XR COUNT
ENTRY    BSS       1                   . CURRENT ENTRY INDEX
.
.
.
.        SYSTEM STATUS RECORD STARTS HERE.
.
         ORG       SSRSBGN
         ALIGN     0,8
SSR      BSS       0
.
.        SSR STATUS BYTES.
.
SSRSF    BSS       SSRSMAX             .SSR STATUS FIELD
SSRDIR   BSS       0                   .SSR DIRECTORY
.
.
ENDEIWKS BSS       0                   .END EI WORKING STORAGE
         DO        (ENDEIWKS)>(X'1000')
         ERROR     C'EI                WORKING STORAGE OVER 4K BYTES'
         DEND
.
         use       #lastsec
.
.******  END DECK OSAEITB **********************************************
*DECK DECK=OSC$FILE_TRANSFER_SERVER EXPAND=FALSE
  CONST
    osc$file_transfer_server = 'OSA$FILE_TRANSFER_SERVER       ';
*DECK DECK=OSC$JOB_MONITOR_XCB_OFFSET EXPAND=FALSE

  CONST
    osc$job_monitor_xcb_offset = 100(16);
*DECK DECK=OSC$JOB_RECOVERY_CONDITION_NAME EXPAND=FALSE

  CONST
    osc$job_recovery_condition_name = 'OSC$JOB_RECOVERY               ';

*DECK DECK=OSC$KEYPOINT_BUFFER_PVA_OFFSET EXPAND=FALSE

{  Define offset of PVA for keypoint collection buffer.  This is an offset in
{  the page table segment.
{
{ NOTE:
{   This symbol is also defined in an Assemble common deck,
{   osc$keypoint_buffer_pva_offseta.

  CONST
    osc$keypoint_buffer_pva_offset = 50000000(16);

*DECK DECK=OSC$KEYPOINT_BUFFER_PVA_OFFSETA EXPAND=FALSE

.        Define offset of PVA for keypoint collection buffer.  This is an offset
.        in the page table segment.
.
.        NOTE:  This symbol is also defined in a Cybil common deck,
.            osc$keypoint_buffer_pva_offset.

keybpo   equ     50000000(16)          .PVA offset of keypoint colletion buffer.
*DECK DECK=OSC$KEYPOINT_CLASSES EXPAND=FALSE
.
.  Define keypoint class codes
.
oscdata   equ    0             .Data keypoint
oscunus   equ    1             .Unusual keypoint.
oscent    equ    2             .Entry keypoint.
oscexit   equ    3             .Exit keypoint.
oscdbug   equ    4             .Debug keypoint.
oscmtr    equ    5             .monitor entry/exit.
.
.         define bias for monitor exit keypoint.
.
oskxbias  equ    4096
.
.
.
.
.
.  Define keypoint codes used in OS assembly language decks.
.
.
oskpurg   equ    4000          .Used in OSAINX wil cache/map purge.
oskexc8   equ    4001          .Exchange to/from 180 job mode.
oskexc7   equ    4002          .Exchange to/from 170 job mode.
osktrpm   equ    4003          .Monitor mode trap.
osktrpj   equ    4004          .Job mode trap.
oskexc8x  equ    oskexc8+oskxbias
oskexc7x  equ    oskexc7+oskxbias
osktrpmx  equ    osktrpm+oskxbias
osktrpjx  equ    osktrpj+oskxbias
.
*DECK DECK=OSC$MAXIMUM_PROCESSORS EXPAND=FALSE

  CONST
    osc$maximum_processors = 2;
*DECK DECK=OSC$MAXIMUM_PROCESSOR_ID EXPAND=FALSE

  CONST
    osc$maximum_processor_id = 7;


*DECK DECK=OSC$MAXIMUM_PROCESSOR_NUMBER EXPAND=FALSE
  CONST
    osc$maximum_processor_number = osc$maximum_processors - 1;

*copyc osc$maximum_processors

*DECK DECK=OSC$MAX_CONDITION EXPAND=FALSE

  CONST
    osc$max_condition = osc$max_status_condition_code;

*copyc osc$max_status_condition_code
*DECK DECK=OSC$MAX_STATUS_CONDITION_CODE EXPAND=FALSE

  CONST
*IF NOT $true(osv$unix)
    osc$max_status_condition_code = 0ffffffffff(16);
*ELSE
    osc$max_status_condition_code = 7ffffffe(16);
*IFEND

*DECK DECK=OSC$MAX_STATUS_CONDITION_NUMBER EXPAND=FALSE

  CONST
*IF NOT $true(osv$unix)
    osc$max_status_condition_number = 0ffffff(16);
*ELSE
    osc$max_status_condition_number = 0ffff(16);
*IFEND

*DECK DECK=OSC$MAX_STATUS_MESSAGE EXPAND=FALSE

  CONST
    osc$max_status_message = osc$status_message_height *
          osc$status_message_width;

*copyc osc$status_message_height
*copyc osc$status_message_width
*DECK DECK=OSC$MAX_STATUS_MESSAGE_LINE EXPAND=FALSE

  CONST
    osc$max_status_message_line = 1 + osc$max_status_message;

*copyc osc$max_status_message
*DECK DECK=OSC$MAX_STATUS_MESSAGE_LINES EXPAND=FALSE

  CONST
    osc$max_status_message_lines = osc$max_status_message;

*copyc osc$max_status_message
*DECK DECK=OSC$MAX_SYSTEM_MESSAGE_MODULES EXPAND=FALSE

  CONST
    osc$max_system_message_modules = 34;
*DECK DECK=OSC$MIN_STATUS_MESSAGE_LINE EXPAND=FALSE

  CONST
    osc$min_status_message_line = 1 + osc$max_name_size;

*copyc ost$name
*DECK DECK=OSC$MONITOR_STACK_MULT EXPAND=FALSE

  CONST
    osc$monitor_stack_mult = 1010000(16);
*DECK DECK=OSC$MULTIPROCESSOR_CONSTANTS EXPAND=FALSE

 CONST
   osc$max_number_of_processors = osc$maximum_processors;

*copyc osc$maximum_processors
*DECK DECK=OSC$NOSVE_JOB_SCHEDULER EXPAND=FALSE

  CONST
    osc$nosve_job_scheduler = 'OSA$NOSVE_JOB_SCHEDULER        ';
*DECK DECK=OSC$NOSVE_SYSTEM_SET EXPAND=FALSE

  {common deck OSDSSET }
  CONST
    osc$nosve_system_set = 'NVESET                         ';

  {For release one there will only be one set}
*DECK DECK=OSC$PROCESSOR_DEFINED_REGISTERS EXPAND=FALSE
{This deck contains constant declarations for referencing processor
{defined registers.

  CONST
{                                     no write access }
    osc$pr_element_id = 10(16),
    osc$pr_maintenance_id = 11(16),
    osc$pr_options_installed = 12(16),
    osc$pr_virtual_machine_capab = 13(16),
    osc$pr_p_reg = 40(16),
    osc$pr_monitor_process_state = 41(16),
    osc$pr_monitor_condition_reg = 42(16),
    osc$pr_user_condition_reg = 43(16),
    osc$pr_untranslatable_pointer = 44(16),
    osc$pr_segment_table_length = 45(16),
    osc$pr_segment_table_address = 46(16),
    osc$pr_base_constant = 47(16),
    osc$pr_page_table_address = 48(16),
    osc$pr_page_table_length = 49(16),
    osc$pr_page_size_mask = 4a(16),

    osc$pr_model_dependent_flags = 50(16),
    osc$pr_model_dependent_word = 51(16),

{                                     monitor write access }
    osc$pr_monitor_mask_reg = 60(16),
    osc$pr_job_process_state = 61(16),
    osc$pr_system_interval_timer = 62(16),
    osc$pr_corrected_error_log = 92(16),

{                                     global write access }
    osc$pr_processor_test_mode = 0a0(16),

{                                     local write access }
    osc$pr_trap_disable = 0c0(16),
    osc$pr_trap_enable_delay = 0c3(16),
    osc$pr_trap_enable = 0c2(16),
    osc$pr_trap_pointer = 0c4(16),
    osc$pr_debug_list_pointer = 0c5(16),
    osc$pr_keypoint_mask = 0c6(16),
    osc$pr_keypoint_code = 0c7(16),
    osc$pr_keypoint_class_number = 0c8(16),
    osc$pr_process_interval_timer = 0c9(16),

{                                     unprivleged write access }
    osc$pr_set_critical_frame = 0e1(16),
    osc$pr_clear_critical_frame = 0e0(16),
    osc$pr_set_on_condition = 0e3(16),
    osc$pr_clear_on_condition = 0e2(16),
    osc$pr_debug_index = 0e4(16),
    osc$pr_debug_mask_reg = 0e5(16),
    osc$pr_user_mask_reg = 0e6(16);
*DECK DECK=OSC$PURGE_MAP_AND_CACHE EXPAND=FALSE
{Constants for use in the PURGE MAP and CACHE instructions.}

  CONST
    osc$sva_purge_512_cache = 0,
    osc$sva_purge_all_cache = 1,
    osc$purge_all_cache = 2,
    osc$pva_purge_512_cache = 3,
    osc$pva_purge_segment_cache = 7,

    osc$sva_purge_one_page_map = 8,
    osc$sva_purge_all_page_map = 9,
    osc$pva_purge_one_page_map = 10,
    osc$pva_purge_all_page_seg_map = 11,
    osc$purge_all_map = 15,
    osc$purge_all_page_seg_map = 15,

    osc$purge_instruction_stack = 4;
*DECK DECK=OSC$QUEUE_TRANSFER_CLIENT EXPAND=FALSE
CONST
  osc$queue_transfer_client = 'OSA$QUEUE_TRANSFER_CLIENT      ';

*DECK DECK=OSC$QUEUE_TRANSFER_SERVER EXPAND=FALSE
  CONST
    osc$queue_transfer_server = 'OSA$QUEUE_TRANSFER_SERVER      ';
*DECK DECK=OSC$REMOTE_HOST_OUTPUT EXPAND=FALSE

  CONST
    osc$remote_host_output = 'OSA$REMOTE_HOST_OUTPUT         ';
*DECK DECK=OSC$SERVER_JOB_RECOVERY_COND EXPAND=FALSE

  CONST
    osc$server_job_recovery_cond = 'OSC$SERVER_JOB_RECOVERY        ';


*DECK DECK=OSC$SERVER_STATE_CHANGE EXPAND=FALSE

  CONST
    osc$server_state_change = 'OSC$SERVER_STATE_CHANGE        ';

*DECK DECK=OSC$SPACE_UNAVAILABLE_CONDITION EXPAND=FALSE

  CONST
    osc$space_unavailable_condition = 'OSC$SPACE_UNAVAILABLE          ';
*DECK DECK=OSC$STATISTICS EXPAND=FALSE
{
{ This deck defines os statistics.
{

*copyc osc$base_exception
  CONST
    osc$statistic_identifier = 'OS';

  CONST
    osc$min_statistic = osc$base_exception,
    osc$hide_statistic = osc$base_exception + 9000,
    osc$max_statistic = osc$base_exception + 9999;

  CONST
    osc$job_and_memory_stats = osc$min_statistic + 0,
    osc$paging_and_mtr_stats = osc$min_statistic + 1,
    osc$io_pp_usage = osc$min_statistic + 2,
    osc$io_path_usage = osc$min_statistic + 3,
    osc$io_unit_usage = osc$min_statistic + 4,
    osc$io_disk_space = osc$min_statistic + 5,
    osc$cpu_stats = osc$min_statistic + 6,
    osc$service_class_stats = osc$min_statistic + 7,
    osc$job_class_stats = osc$min_statistic + 8,
    osc$system_job_stats = osc$min_statistic + 9,
    osc$system_task_stats = osc$min_statistic + 10,
    osc$memory_utilization_stats = osc$min_statistic + 11,
    osc$job_count_stats = osc$min_statistic + 12,
    osc$page_streaming_stats = osc$min_statistic + 13,
    osc$monitor_request_stats = osc$min_statistic + 14,
    osc$cpu_dispatching_stats = osc$min_statistic + 15,
    osc$page_fault_rejected_stats = osc$min_statistic + 16,
    osc$system_job_stats_hide  = osc$hide_statistic + 5,
    osc$swap_state_stats = osc$hide_statistic + 7,
    osc$swap_page_count_stats = osc$hide_statistic + 8,
    osc$aging_stats = osc$hide_statistic + 10,
    osc$mtr_req_stats = osc$hide_statistic + 11,
    osc$job_count_stats_hide = osc$hide_statistic + 13,
    osc$begin_os_emission_set = osc$max_statistic - 1,
    osc$end_os_emission_set = osc$max_statistic - 0;
*DECK DECK=OSC$STATUS_MESSAGE_HEIGHT EXPAND=FALSE

  CONST
    osc$status_message_height = 30;

*DECK DECK=OSC$STATUS_MESSAGE_WIDTH EXPAND=FALSE

  CONST
    osc$status_message_width = 132;

*DECK DECK=OSC$STATUS_PARAMETER_DELIMITER EXPAND=FALSE

  CONST
    osc$status_parameter_delimiter = $CHAR (31) {Unit Separator} ;

*DECK DECK=OSC$SUBMIT_JOB EXPAND=FALSE

  CONST
    osc$submit_job = 'OSA$SUBMIT_JOB';
*DECK DECK=OSC$SYSTEM_TABLE_LOCK_SET EXPAND=FALSE


{ This is the constant to determine if system table locks are set. It is
{ used to primarily differentiate between tasks which have system versus
{ subsystem locks set.

  CONST
    osc$system_table_lock_set = 256;
*DECK DECK=OSC$SYSTEM_UNSTEP_RESUME_FLAG EXPAND=FALSE
*DECK DECK=OSC$TABLE_LOCK_ACTIVITY EXPAND=FALSE

   CONST
     osc$subsystem_lock_activity = 1,
     osc$system_lock_activity = 256;
*DECK DECK=OSC$TIMESHARING EXPAND=FALSE

  CONST
    osc$timesharing = 'OSA$TIMESHARING                ';
*DECK DECK=OSC$TIMESHARING_TERMINAL_FILE EXPAND=FALSE

  CONST
    osc$timesharing_terminal_file = '$TERMINAL                      ';
*DECK DECK=OSC$UNSEEN_MAIL_CONDITION EXPAND=FALSE
  CONST
    osc$unseen_mail_condition = 'OSC$UNSEEN_MAIL_CONDITION      ';

*DECK DECK=OSC$VOLUME_UNAVAILABLE_COND EXPAND=FALSE

  CONST
    osc$volume_unavailable_cond = 'OSC$VOLUME_UNAVAILABLE         ';

*DECK DECK=OSC$XCB_ASEMBLY_CONSTANTS EXPAND=FALSE
.
.  OSAXCB - This deck defines assembly language equates for referencing
.     fields in the XCB. Equates defined in this deck MUST agree
.     with the CYBIL declaration of the XCB. ** Note that only a few
.     fields in the XCB are referenced by assembly language and that
.     the fields are kept at the beginning of the XCB.
.
xcbmflag   equ    416         .Monitor flags.
*DECK DECK=OSC$XTERM_APPLICATION_NAME EXPAND=FALSE

  CONST
    osc$xterm_application_name = 'OSA$XTERM                      ';

*DECK DECK=OSD$CODE_BASE_POINTER EXPAND=FALSE
{Code base pointer format }

  TYPE
    ost$internal_code_base_pointer = packed record
      fill1: 0 .. 0f(16),
      vmid: ost$virtual_machine_identifier,
      xp: boolean,
      fill2: 0 .. 7,
      r3: 0 .. 0f(16),
      code_pva: ALIGNED ^cell,
    recend,

    ost$external_code_base_pointer = packed record
      fill1: 0 .. 0f(16),
      vmid: ost$virtual_machine_identifier,
      xp: boolean,
      fill2: 0 .. 7,
      r3: 0 .. 0f(16),
      code_pva: ALIGNED ^cell,
      fill3: 0 .. 0ffff(16),
      binding_pva: ALIGNED ^cell,
    recend;

*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$VIRTUAL_MACHINE_IDENTIFIER
*DECK DECK=OSD$CONDITIONS EXPAND=FALSE


  TYPE
    ost$monitor_condition = (osc$detected_uncorrected_err,
      osc$not_assigned, osc$short_warning, osc$instruction_spec,
      osc$address_specification, osc$exchange_request, osc$access_violation,
      osc$environment_spec, osc$external_interrupt, osc$page_fault,
      osc$system_call, osc$system_interval_timer, osc$invalid_segment_ring_0,
      osc$out_call_in_return, osc$soft_error, osc$trap_exception),

    ost$monitor_conditions = set OF ost$monitor_condition;

  TYPE
    ost$user_condition = (osc$privileged_instruction,
      osc$unimplemented_instruction, osc$free_flag, osc$process_interval_timer,
      osc$inter_ring_pop, osc$critical_frame_flag, osc$keypoint,
      osc$divide_fault, osc$debug, osc$arithmetic_overflow,
      osc$exponent_overflow, osc$exponent_underflow, osc$fp_significance_loss,
      osc$fp_indefinite, osc$arithmetic_significance, osc$invalid_bdp_data),

    ost$user_conditions = set OF ost$user_condition;
*DECK DECK=OSD$CYBIL_STRUCTURE_DEFINITIONS EXPAND=FALSE

{ COMMON DECK OSDCYBL }

{ This common deck should not be used; it will eventually be deleted.
{ Common deck CYDCYBL should be used instead.

*copyc CYD$CYBIL_STRUCTURE_DEFINITIONS
*DECK DECK=OSD$DEFAULT_PRAGMATS EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, KEYW := UPPER, IDENT := LOWER) ??
?? SET (LIST := ON, LISTCTS := OFF) ??
*DECK DECK=OSD$EXCEPTIONS EXPAND=FALSE
*IF NOT $true(osv$unix)
*copyc SYE$CONDITION_CODES
*copyc AME$CONDITION_CODES
*copyc fde$condition_identifiers
*copyc fme$file_management_errors
*copyc FSE$CONDITION_CODES
*copyc CLE$EXCEPTION_CONDITION_CODES
*copyc jme$exception_condition_codes
*copyc lld$loader_execptions
*copyc MMDECC
*copyc osd$operating_system_exceptions
*copyc IODECC
*copyc dmt$error_codes
*copyc mld$error_codes
*copyc PFE$ERROR_CONDITION_CODES
*copyc PFE$SELECTION_ERRORS
*copyc PFE$EXTERNAL_ARCHIVE_CONDITIONS
*copyc PFE$INTERNAL_ERROR_CONDITIONS
*copyc STE$ERROR_CONDITION_CODES
*copyc PUE$ERROR_CONDITION_CODES
*copyc DFE$ERROR_CONDITION_CODES
*copyc pmd$program_mgmt_exceptions
*copyc RME$CONDITION_CODES
*copyc RME$ROBOTIC_INTERFACE_ERRORS
*copyc OFD$ERROR_TITLE
*copyc dpe$error_codes
*copyc AVE$CONDITION_CODES
*copyc lge$condition_codes
*copyc ICE$ERROR_CODES
*copyc rhd$condition_codes
*copyc ocd$object_code_exceptions
*copyc dse$error_codes
*copyc ift$title_for_error_codes
*copyc ife$interactive_exception_codes
*copyc SFE$CONDITION_CODES
*copyc CMDECC
*copyc ofe$condition_codes
*copyc rae$condition_codes
*copyc due$exception_condition_codes
*copyc due$symbolic_access_exceptions
*copyc ioe$tape_io_conditions
*copyc nae$condition_codes
*copyc rfe$condition_codes
*copyc nfe$exception_condition_codes
*copyc PTE$ECC_ANABL_EXCEPTIONS
*ELSE
*copyc ame$condition_codes
*copyc CLE$EXCEPTION_CONDITION_CODES
*copyc ese$out_of_file_space
*copyc ose$unix_command_error
*copyc ose$unix_system_error
*copyc pfe$condition_codes
*IFEND
*DECK DECK=OSD$EXCEPTION_POLICIES EXPAND=FALSE
  CONST
    osc$ecp_max_poll_frequency = 60 {seconds} * 60 {minutes} * 24 {hours} * 366
          {days} ,

    osc$ecp_number_of_conditions = 7;

  TYPE

{ Exception policies are stored in a sequence in mainframe pageable.  The
{ policies are stored in chronological order; the most recent and most
{ specific applicable policy is binding.

{ Applicability exists when the job affected by an exception condition
{ matches the "who", "what", and "which" aspects of an exception policy.  A
{ policy may consist of any combination of "who" and "what" aspects plus at
{ least one "which" aspect.

{ Within a given policy, the "who" and "what" aspects of the policy determine
{ which users and/or objects are covered by the policy.  These aspects are
{ listed in order of decreasing weight.  This determines the order that
{ applicability is investigated.  The "who" policies carry more weight than
{ "what" policies.  The "who" aspects are JOBS, LOGIN_USERS, JOB_MODE, and
{ JOB_CLASSES.  The "what" aspects are FILES, MASS_STORAGE_CLASSES, VOLUMES,
{ FAMILIES, and SETS.

{ Within a given policy, the "which" aspects of the policy define the
{ exception conditions covered by the policy.  The "which" aspects are
{ CATALOG_VOLUME_UNAVAILABLE, CYCLE_BUSY, CYCLE_RESTORATION_REQUIRED,
{ DATA_RETRIEVAL_REQUIRED, FILE_SERVER_INACTIVE, SPACE_UNAVAILABLE, and
{ VOLUME_UNAVAILABLE.

{ For an applicable policy, one or more "actions" are authorized.  "Actions"
{ are the values supplied for the parameter corresponding to the condition on
{ CHANGE_EXCEPTION_POLICIES.  If the option is to WAIT, the value specified
{ for the POLLING_FREQUENCY is used to control the polling frequency of an
{ affected job.

{ Each policy in the sequence is preceded by an ost$ecp_policy_header
{ followed by an optional range of bytes referred to as the "policy body".
{ The "policy body" contains the values of the specified aspects.  The
{ ost$ecp_policy_header contains a pointer to the next policy header.

    ost$ecp_header = record
      first_policy: ^ost$ecp_policy_header,
      last_accessed_policy: ost$non_negative_integers,
      last_policy: ^ost$ecp_policy_header,
      number_of_policies: ost$non_negative_integers,
      segment_p: amt$segment_pointer,
      system_default_policies: boolean,
    recend,

    ost$ecp_policy_header = record
      next_policy: ^ost$ecp_policy_header,

      {The following "who" aspects of the policy are ordered by decreasing
      { weight}
      jobs: ^ost$ecp_name_list,
      login_users: ^ost$ecp_login_users_list,
      job_mode: ost$ecp_job_mode,
      job_classes: ^ost$ecp_name_list,

      {The following "what" aspects of the policy are ordered by decreasing
      { weight}
      {NOTE: FILES=ALL has the least weight and a specific file has the most
      { weight}
      files: ost$ecp_files,
      mass_storage_classes: ost$ecp_ms_classes,
      volumes: ^ost$ecp_volume_list,
      families: ^ost$ecp_name_list,
      sets: ^ost$ecp_name_list,

      conditions: ost$ecp_conditions,

      polling_frequency: ost$ecp_polling_frequency,
    recend,

    ost$ecp_actions = set of ost$ecp_action,

    ost$ecp_action = (osc$ecp_delete, osc$ecp_enable_matching_image,
          osc$ecp_enable_nonmatch_image, osc$ecp_exit,
          osc$ecp_set_damage_condition, osc$ecp_wait),

    ost$ecp_conditions = array [ost$ecp_number_of_conditions] of
          ost$ecp_exception_condition,

    ost$ecp_criteria = record
      condition: fst$file_access_condition,
      family_path_name: ost$name,
      file: fst$path,
      job: jmt$system_supplied_name,
      job_class: ost$name,
      job_mode: jmt$job_mode,
      login_family: ost$name,
      login_user: ost$name,
      mass_storage_class: dmt$class_member,
      set_name: ost$name,
      volume_list: ^rmt$volume_list,
    recend,

    ost$ecp_exception_condition = record
      exception_name: ost$name,
      exception_ordinal: ost$ecp_function_param_ordinal,
      file_access_conditions: fst$file_access_conditions,
      case specified: boolean of
      = TRUE =
        actions: ost$ecp_actions,
      = FALSE =
      casend,
    recend,

    ost$ecp_files = record
      case specified: boolean of
      = TRUE =
        case all_specified: boolean of
        = TRUE =
          ,
        = FALSE =
          path_list: ^array [1 .. * ] of ost$ecp_file_entry,
        casend,
      casend,
    recend,

    ost$ecp_file_entry = record
      path: ^string ( * ),
      case file_reference_type: ost$ecp_file_reference_kind of
      = osc$ecp_evaluated_reference, osc$ecp_generic_reference =
        ,
      = osc$ecp_wild_card_reference =
        wild_card_pattern_type: clt$wild_card_pattern_type,
      casend,
    recend,

    ost$ecp_file_reference_kind = (osc$ecp_evaluated_reference,
          osc$ecp_generic_reference, osc$ecp_wild_card_reference),

    {A correspondence must be maintained between the integer value of these
    { ordinals and the order of the parameters of the CHANGE_EXCEPTION_POLICIES
    { subcommand.  This ensures that the order of the parameter values displayed
    { by DISPLAY_EXCEPTION_POLICIES and $EXCEPTION_POLICIES is the same as
    { CHAEP.

    ost$ecp_function_param_ordinal = (osc$fp_null, osc$fp_job_classes,
          osc$fp_job_mode, osc$fp_jobs, osc$fp_login_users, osc$fp_families,
          osc$fp_files, osc$fp_mass_storage_classes, osc$fp_sets,
          osc$fp_volumes, osc$fp_catalog_vol_unavailable, osc$fp_cycle_busy,
          osc$fp_cycle_restoration_req, osc$fp_data_retrieval_req,
          osc$fp_file_server_inactive, osc$fp_space_unavailable,
          osc$fp_volume_unavailable, osc$fp_polling_frequency),

    ost$ecp_job_mode = record
      case specified: boolean of
      = TRUE =
        value: jmt$job_mode,
      = FALSE =
      casend,
    recend,

    ost$ecp_login_users_list = array [1 .. * ] of ost$ecp_login_user,

    ost$ecp_login_user = record
      specified_fields: ost$ecp_specified_login_fields,
      {Ordered in terms of increasing weight}
      user_name: ost$name,
      family_name: ost$name,
      job_class: jmt$job_class_name,
      job_mode: jmt$job_mode,
    recend,

    ost$ecp_ms_classes = record
      case specified: boolean of
      = TRUE =
        value: dmt$class,
      = FALSE =
      casend,
    recend,

    ost$ecp_name_list = array [1 .. * ] of ost$name,

    ost$ecp_number_of_conditions = 1 .. osc$ecp_number_of_conditions,

    ost$ecp_policy_criteria = set of ost$ecp_policy_criterion,

    ost$ecp_policy_criterion = (osc$ecp_all_files, osc$ecp_job_classes,
          osc$ecp_job_mode, osc$ecp_jobs, osc$ecp_families,
          osc$ecp_list_of_files, osc$ecp_login_users,
          osc$ecp_mass_storage_classes, osc$ecp_sets, osc$ecp_volumes),

    ost$ecp_policy_weight = (osc$ecp_nonapplicable_policy,
          osc$ecp_all_files_priority, osc$ecp_set_priority,
          osc$ecp_family_priority, osc$ecp_ms_class_priority,
          osc$ecp_volume_priority, osc$ecp_specific_path_priority,
          osc$ecp_job_class_priority, osc$ecp_job_mode_priority,
          osc$ecp_lu_user_priority, osc$ecp_lu_family_priority,
          osc$ecp_lu_job_class_priority, osc$ecp_lu_job_mode_priority,
          osc$ecp_job_priority),

    ost$ecp_polling_frequency = record
      case specified: boolean of
      = TRUE =
        value: 1 .. osc$ecp_max_poll_frequency,
      = FALSE =
      casend,
    recend,

    ost$ecp_sequence_index = (osc$ecp_session_policies,
          osc$ecp_installed_policies),

    ost$ecp_specified_login_fields = set of ost$ecp_specified_login_field,

    { A correspondence must be maintained between the integer value of these
    { ordinals and the order of the fields of the LOGIN_USERS parameter of
    { the CHANGE_EXCEPTION_POLICIES subcommand.  This ensures that the order of
    { the
    { parameter values displayed  by DISPLAY_EXCEPTION_POLICIES and
    { $EXCEPTION_POLICIES is the same as CHAEP.
    ost$ecp_specified_login_field = (osc$lu_user_name, osc$lu_family_name,
          osc$lu_job_class, osc$lu_job_mode),

    ost$ecp_volume_list = array [1 .. * ] of rmt$recorded_vsn;

*copyc amt$segment_pointer
*copyc clt$wild_card_pattern_type
*copyc dmt$class
*copyc fsc$longest_wait_time
*copyc fst$evaluated_file_reference
*copyc fst$file_access_conditions
*copyc fst$file_reference
*copyc fst$path
*copyc jmt$job_class_name
*copyc jmt$job_mode
*copyc jmt$system_supplied_name
*copyc osd$integer_limits
*copyc ost$name
*copyc ost$status
*copyc rmt$volume_list
*DECK DECK=OSD$INTEGER_LIMITS EXPAND=FALSE

{ Integer Const and Type Definitions

CONST
*IF NOT $true(osv$unix)
  osc$min_integer = -7fffffffffffffff(16),
  osc$max_integer = 7fffffffffffffff(16);
*ELSE
    osc$min_integer = -osc$max_integer,
    osc$max_integer = 7fffffff(16);
*IFEND

TYPE
  ost$negative_integers = osc$min_integer .. -1,
  ost$non_positive_integers = osc$min_integer .. 0,
  ost$non_negative_integers = 0 .. osc$max_integer,
  ost$positive_integers = 1 .. osc$max_integer;

*DECK DECK=OSD$KEYPOINTS EXPAND=FALSE

*copyc OSK$KEYPOINTS
*DECK DECK=OSD$OPERATING_SYSTEM_EXCEPTIONS EXPAND=FALSE
?? NEWTITLE := 'OSDECC  : Operating System       : ''OS'' 0 .. 9999' ??
*copyc ose$undefined_condition
*copyc OSE$HEAP_FULL_EXCEPTIONS
*copyc ose$multipro_exceptions
*copyc ose$system_task_exceptions
*copyc ose$await_activity_exceptions
*copyc ose$job_recovery_exceptions
*copyc OSE$SYSTEM_DEBUG_UTILITY
*copyc ose$default_process_exceptions
*copyc ose$keypoint_conditions
*copyc ose$spi_conditions
*copyc ose$condition_exceptions
*copyc ose$message_gen_exceptions
*copyc ose$disk_ft_exceptions
?? OLDTITLE ??
*DECK DECK=OSD$RANDOM_NAME EXPAND=FALSE

  CONST
    osc$max_random_name = 0ffffffff(16);

  TYPE
    ost$randomized_name = 0 .. osc$max_random_name;
*DECK DECK=OSD$REGISTERS EXPAND=FALSE

  TYPE
    ost$register_number = 0 .. 0f(16),
    ost$x_register = integer;

  TYPE
    ost$p_register = PACKED record
      undefined1: 0 .. 3(16),
      global_key: ost$key_lock_value,
      undefined2: 0 .. 3(16),
      local_key: ost$key_lock_value,
      pva: ost$pva,
    recend;

*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=OSD$STATISTICS EXPAND=FALSE

*copyc avc$accounting_statistics
*copyc cll$comment_command
*copyc iot$disk_statistics
*copyc iot$tape_statistics
*copyc jml$user_id
*copyc osc$statistics
*copyc pmc$min_scc_program_execution

*DECK DECK=OSD$UNIQUE_NAME EXPAND=FALSE

  TYPE
    ost$unique_name = record
      case boolean of
      = TRUE =
        value: ost$name,
      = FALSE =
        dollar_sign: string (1),
        sequence_number: string (7),
        p: string (1),
        processor_model_number: string (1),
        s: string (1),
        processor_serial_number: string (4),
        d: string (1),
        year: string (4),
        month: string (2),
        day: string (2),
        t: string (1),
        hour: string (2),
        minute: string (2),
        second: string (2),
      casend,
    recend;

*copyc OST$NAME
*copyc ost$binary_unique_name
*DECK DECK=OSD$VIRTUAL_ADDRESS EXPAND=FALSE


{ NOS/VE address constants. }


  CONST


    { Ring names. }

    osc$min_ring = 1, { Lowest ring number (most privileged). }
    osc$max_ring = 15, { Highest ring number (least privileged). }
    osc$invalid_ring = 0,
    osc$os_ring_1 = 1, { Reserved for Operating System. }
    osc$tmtr_ring = 2, { Task Monitor. }
    osc$tsrv_ring = 3, { Task services. }
    osc$sj_ring_1 = 4, { Reserved for system job. }
    osc$sj_ring_2 = 5,
    osc$sj_ring_3 = 6,
    osc$application_ring_1 = 7, { Reserved for application subsystems.}
    osc$application_ring_2 = 8,
    osc$application_ring_3 = 9,
    osc$application_ring_4 = 10,
    osc$user_ring = 11, { Standard user task. }
    osc$user_ring_1 = 12, { Reserved for user...O.S. requests available.}
    osc$user_ring_2 = 13,
    osc$user_ring_3 = 14, { Reserved for user...O.S. requests not available. }
    osc$user_ring_4 = 15;


{ Virtual address space dimensions. }

  CONST
    osc$maximum_segment = 0fff(16),
    osc$maximum_offset = 7fffffff(16),
*IF NOT $true(osv$unix)
    osc$max_segment_length = osc$maximum_offset + 1;
*ELSE
    osc$max_segment_length = osc$maximum_offset;
*IFEND


{ Global-local key lock definition. }

  TYPE
    ost$key_lock = packed record
      global: boolean, { True if value is global key. }
      local: boolean, { True if value is local key. }
      value: ost$key_lock_value, { Key or lock value. }
    recend,

    ost$key_lock_value = 0 .. 3f(16),


    { CYBER 180 forty eight bit PVA definition. }

    ost$ring = osc$invalid_ring .. osc$max_ring, { Ring number. }
    ost$valid_ring = osc$min_ring .. osc$max_ring, { Valid Ring Number. }
    ost$segment = 0 .. osc$maximum_segment, { Segment number. }
    ost$segment_offset = - (osc$maximum_offset + 1) .. osc$maximum_offset,
    ost$valid_segment_offset = 0 .. osc$maximum_offset,

    ost$segment_length = 0 .. osc$max_segment_length,

    ost$relative_pointer = - 7fffffff(16) .. 7fffffff(16),
    ost$valid_relative_pointer = 0 .. 7fffffff(16),

    ost$pva = packed record
      ring: ost$ring,
      seg: ost$segment,
      offset: ost$segment_offset,
    recend;
*DECK DECK=OSD$WAIT EXPAND=FALSE

  CONST
    osc$maximum_wait_time = 0ffffffff(16);

  TYPE
    ost$wait_list = array [1 .. * ] of ost$activity,

    ost$activity = record
      case activity: ost$wait_activity of
      = osc$await_time =
        milliseconds: 0 .. osc$maximum_wait_time,
      = pmc$await_task_termination =
        task_id: pmt$task_id,
      = pmc$await_local_queue_message =
        qid: pmt$queue_connection,
      casend,
    recend,

    ost$wait_activity = (osc$null_activity, osc$await_time,
          pmc$await_task_termination, pmc$await_local_queue_message);

*copyc pmt$task_id
*copyc pmd$local_queues
*DECK DECK=OSE$AWAIT_ACTIVITY_EXCEPTIONS EXPAND=FALSE

*copyc OSC$BASE_EXCEPTION

  {OSDWERR : Await Activity Exceptions : 'OS' + 50}

  CONST
    ose$incorrect_activity = osc$base_exception + 50;
    {E Incorrect ost$wait_activity.}
*DECK DECK=OSE$CONDITION_EXCEPTIONS EXPAND=FALSE
*copyc OSC$BASE_EXCEPTION

  {OSDCERR : Set Status From Condition Exceptions : 'OS' 60 - 69}
  CONST
    ose$invalid_condition_selector = osc$base_exception + 60,
    {E Unknown condition selector - osp$set_status_from_condition.}

    ose$empty_system_condition = osc$base_exception + 61,
    {E No system condition specified - osp$set_status_from_condition.}

    ose$empty_block_exit_reason = osc$base_exception + 62,
    {E No block exit reason specified - osp$set_status_from_condition.}

    ose$unknown_segment_condition = osc$base_exception + 63,
    {E Undefined segment condition PVA=+P AT P=+P.}

    ose$invalid_save_area = osc$base_exception + 64,
    {E Incorrect save_area specified - osp$set_status_from_condition.}

    ose$condition_message_template = osc$base_exception + 65,
    {I +I +P +P.}

    ose$unknown_interactive_cond = osc$base_exception + 66;
    {E Undefined interactive condition.}
*DECK DECK=OSE$DEFAULT_PROCESS_EXCEPTIONS EXPAND=FALSE

*copyc OSC$BASE_EXCEPTION

  {OSE$DEFAULT_PROCESS_EXCEPTIONS : default processing exceptions : 'OS' 500 .. 599 }

  CONST
    ose$invalid_os_default_selected = osc$base_exception + 500,
    {E Invalid system default selected.}

    ose$not_allowed_in_dual_state   = osc$base_exception + 501,
    {E The date and time cannot be changed from NOS/VE in a dual ..
    { state environment.}

    ose$time_zone_data_not_saved    = osc$base_exception + 502;
    {W Due to the relocation of DFT, the time zone data cannot be ..
    {  updated.  To change the time zone data, reenter it with the ..
    {  SET_TIME_ZONE command when asked to enter system core commands ..
    {  during the next deadstart.}
*DECK DECK=OSE$DISK_FT_EXCEPTIONS EXPAND=FALSE
*copyc osc$base_exception
?? NEWTITLE := 'Disk Fault Tolerance Exceptions : ''OS'' 200 .. 299', EJECT ??

  CONST
    ose$condition_not_covered        = osc$base_exception + 200,
    {E One or more exception conditions are not covered by any..
    { of the policies defined within this utility session.  You..
    { must define policies to cover the following exception..
    { conditions: '+P1}

    ose$data_lost                    = osc$base_exception + 201,
    {F The data for file +F1 was lost.  The file has been deleted.}

    ose$eni_required_with_sdc        = osc$base_exception + 202,
    {E You specified the SET_DAMAGE_CONDITION option without also..
    { specifying the ENABLE_NONMATCHING_IMAGE option for this..
    { parameter.  The SET_DAMAGE_CONDITION option requires that ..
    { you also specify the ENABLE_NONMATCHING_IMAGE option.}

    ose$exception_policies_locked    = osc$base_exception + 203,
    {E The table of installed exception policies is currently locked.}

    ose$from_sequence_empty          = osc$base_exception + 204,
    {F The FROM_SEQUENCE given to OSP$COPY_EXCEPTION_POLICIES was not..
    { of sufficient size to NEXT the sequence header.}

    ose$internal_workspace_full      = osc$base_exception + 205,
    {F Insufficient space for +P1.}

    ose$no_applicable_policies       = osc$base_exception + 206,
    {F You specified the value EXCEPTION_POLICY_REFERENCES for the ..
    { CATALOG parameter of the CHANGE_CATALOG_CONTENTS (CHACC) command. ..
    { There are no files defined by the installed exception policies on ..
    { which to operate.  Either there are no applicable exception policies ..
    { installed or none of the applicable policies are defined using the ..
    { FILES, FAMILIES, MASS_STORAGE_CLASSES, SETS, or VOLUMES parameters.

    { A policy applies to CHACC if it references at least one of the..
    { following conditions: DATA_RETRIEVAL_REQUIRED, MEDIA_MISSING, or..
    { VOLUME_UNAVAILABLE, and it authorizes DELETE, ENABLE_MATCHING_IMAGE,..
    { or ENABLE_NONMATCHING_IMAGE.

    ose$no_policies_installed        = osc$base_exception + 207,
    {E There are no exception policies currently installed. +N..
    { Either use the MANEP subcommand INSTALL_DEFAULT_POLICIES..
    { to install the system default policies, or define your own..
    { policies using CHANGE_EXCEPTION_POLICIES and then install..
    { them using INSTALL_EXCEPTION_POLICIES.

    ose$no_session_policies_defined  = osc$base_exception + 208,
    {E No exception policies are currently defined within this utility..
    { session.

    ose$not_administrator            = osc$base_exception + 209,
    {F You must be either a System or Family Administrator to..
    { specify +P1 for the +P2 parameter of the +P3 command.}

    ose$not_system_administrator     = osc$base_exception + 210,
    {F You must be a System administrator to specify +P1 for the +P2..
    { parameter of the +P3 command.}

    ose$object_of_policy_missing     = osc$base_exception + 211,
    {E At least one of the following parameters is required:..
    { CATALOG_VOLUME_UNAVAILABLE, CYCLE_BUSY, CYCLE_RESTORATION_REQUIRED,..
    { DATA_RETRIEVAL_REQUIRED, FILE_SERVER_INACTIVE, SPACE_UNAVAILABLE,..
    { or VOLUME_UNAVAILABLE.  None of these parameters were specified.}

    ose$offline_condition            = osc$base_exception + 212,
    {F You specified a policy for the CYCLE_RESTORATION_REQUIRED and/or..
    { the DATA_RETRIEVAL_REQUIRED exception condition.  These..
    { conditions exist only when the file is not mass storage ..
    { resident.  Therefore, expressing the criteria for this policy ..
    { in terms of MASS_STORAGE_CLASSES or VOLUMES is inappropriate.

    ose$policies_require_privilege   = osc$base_exception + 213,
    {E To display or install system exception condition policies,..
    { you must execute within the System Operator Utility (SOU)..
    { with CONFIGURATION_ADMINISTRATION capability active.}

    ose$session_policies_defined     = osc$base_exception + 214,
    {E INSTALL_DEFAULT_POLICIES is not allowed while there are..
    { other policies defined within the current utility session. ..
    { To delete the session policies, use DELETE_EXCEPTION_POLICIES ..
    { DELETE_OPTION=ALL.

    ose$subject_of_policy_missing    = osc$base_exception + 216,
    {E At least one of the following parameters is required: JOB_CLASSES,..
    { JOB_MODE, JOBS, LOGIN_USERS, FAMILIES, FILES, MASS_STORAGE_CLASSES,..
    { SETS, or VOLUMES.  None of these parameters were specified.}

    ose$to_sequence_full             = osc$base_exception + 217,
    {F The TO_SEQUENCE given to OSP$COPY_EXCEPTION_POLICIES was not..
    { of sufficient size to copy all of the policies from the ..
    { FROM_SEQUENCE.}

    ose$log_deletion                 = osc$base_exception + 250,
    {I +N******************* Exception Condition Processing *******************+N..
    { FILE: +F1+N..
    { EXCEPTION_CONDITION: +P2+N..
    { DESCRIPTION: The mass storage image of the file was lost.  The file was deleted..
    { as instructed by an installed exception policy. +N..
    { EXCEPTION_STATUS:}

    ose$log_ending_status            = osc$base_exception + 251,
    {I +NThe following status was returned to the task:+N}

    ose$log_exit                     = osc$base_exception + 252,
    {I +N******************* Exception Condition Processing *******************+N..
    { FILE: +F1+N..
    { EXCEPTION_CONDITION: +P2+N..
    { DESCRIPTION: Access to the file was terminated as instructed by an installed..
    { exception policy. +N..
    { EXCEPTION_STATUS:}

    ose$log_matching_release         = osc$base_exception + 253,
    {I +N******************* Exception Condition Processing *******************+N..
    { FILE: +F1+N..
    { EXCEPTION_CONDITION: +P2+N..
    { DESCRIPTION: The mass storage image of the file was lost.  An installed exception..
    { policy has instructed the retrieval of an identical image from an..
    { archive medium. +N..
    { EXCEPTION_STATUS:}

    ose$log_non_matching_release     = osc$base_exception + 254,
    {I +N******************* Exception Condition Processing *******************+N..
    { FILE: +F1+N..
    { EXCEPTION_CONDITION: +P2+N..
    { DESCRIPTION:  The mass storage image of the file was lost.  An installed exception..
    { policy has instructed the retrieval of a previous version of the data..
    { from an archive medium.+N..
    { +X4Original Modification Date: +P3+N..
    { +X4Date of Previous Version  : +P4+N..
    { EXCEPTION_STATUS:}

    ose$log_wait                     = osc$base_exception + 255,
    {I +N******************* Exception Condition Processing *******************+N..
    { FILE: +F1+N..
    { EXCEPTION_CONDITION: +P2+N..
    { DESCRIPTION: The exception condition blocks access to the file.  An installed..
    { exception policy has instructed+N..
    { the job to wait.  The wait time specified by the waiting task is +P3 seconds.+N..
    { EXCEPTION_STATUS:}

    ose$log_catalog_move             = osc$base_exception + 256,
    {I +N******************* Exception Condition Processing *******************+N..
    { CATALOG: +F1+N..
    { EXCEPTION_CONDITION: +P2+N..
    { DESCRIPTION: The catalog was moved from volume +P3 to another volume..
    { having the same mass storage class.+N..
    { The catalog has been moved +P4 time(s) while processing this condition.+N..
    { EXCEPTION_STATUS:}

    ose$log_catalog_move_failure     = osc$base_exception + 257;
    {I +N******************* Exception Condition Processing *******************+N..
    { CATALOG: +F1+N..
    { EXCEPTION_CONDITION: +P2+N..
    { DESCRIPTION: An unsuccessful attempt was made to move the catalog to another..
    { volume.+N..
    { The reason for the failure is: +P3.+N..
    { EXCEPTION_STATUS:}

?? OLDTITLE ??

*DECK DECK=OSE$HEAP_FULL_EXCEPTIONS EXPAND=FALSE
*copyc OSC$BASE_EXCEPTION
?? NEWTITLE := '  OSDFERR : Heap Full Exceptions : ''OS'' 0 - 9', EJECT ??
  CONST
    ose$mainframe_wired_full = osc$base_exception + 0,
    {F +I +P - NOS/VE mainframe wired heap full.}

    ose$mainframe_pageable_full = osc$base_exception + 1,
    {F +I +P - NOS/VE mainframe pageable heap full.}

    ose$job_fixed_full = osc$base_exception + 2,
    {F +I +P - NOS/VE job fixed heap full.}

    ose$job_pageable_full = osc$base_exception + 3,
    {F +I +P - NOS/VE job pageable heap full.}

    ose$task_shared_full = osc$base_exception + 4,
    {F +I +P - NOS/VE task shared heap full.}

    ose$task_private_full = osc$base_exception + 5;
    {F +I +P - NOS/VE task private heap full.}
?? OLDTITLE ??

*DECK DECK=OSE$JOB_RECOVERY_EXCEPTIONS EXPAND=FALSE
*copyc osc$base_exception
 CONST

   ose$job_severely_damaged = osc$base_exception + 800,
   {C  The job is severely damaged, normal continuation, or termination may not finish. +P1 +P2 +P3 +P4 }

   ose$mem_link_not_available = osc$base_exception + 801,
   {E The job has an active connection to a Cyber 170 process that is not available in stand alone mode. }

   ose$path_table_locked = osc$base_exception + 802;
   {C  The job has file manager global locks set, recovery is not possible. +P1 +P2 +P3 +P4 }
*DECK DECK=OSE$KEYPOINT_CONDITIONS EXPAND=FALSE
?? RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc osc$base_exception
?? POP ??

?? NEWTITLE := 'ose$keypoint_conditions: Operating System: ''OS'' + 700..729' ??
  CONST
    osc$keypoint_base = osc$base_exception + 700,

    ose$kpt_not_enough_files_for_mp = osc$keypoint_base + 0,
    {E Not enough files were specified for the number of processors on this
    { mainframe.

    ose$kpt_kbs_too_large = osc$keypoint_base + 1,
    {E The value +P specified for keypoint_buffer_size exceeds the system
    { maximum of +P.

    ose$kpt_invalid_collection_file = osc$keypoint_base + 2,
    {E A collection file either was not a permanent file or was not writeable.

    ose$kpt_coll_term_io_error = osc$keypoint_base + 3,
    {E Keypoint collection was terminated due to an i/o error on a collection
    { file.

    ose$kpt_coll_term_mbs_error = osc$keypoint_base + 4,
    {E Keypoint collection was terminated because the maximum buffer size was
    { exceeded.

    ose$kpt_coll_term_max_kpts = osc$keypoint_base + 5,
    {W Keypoint collection was terminated because the maximum number of
    { keypoints had been reached.

    ose$kpt_environment_not_avail = osc$keypoint_base + 6,
    {E Another job is currently using the keypoint collection environment.

    ose$kpt_collect_already_started = osc$keypoint_base + 7,
    {W A start_keypoint_collection request was issued but collection has
    { already been started.

    ose$kpt_collect_already_stopped = osc$keypoint_base + 8,
    {W A stop_keypoint_collection request was issued but collection has already
    { been stopped.

    ose$kpt_illegal_request = osc$keypoint_base + 9,
    {E A keypoint environment request was issued, but the keypoint environment
    { has not been enabled.

    ose$kpt_wrong_hardware = osc$keypoint_base + 10,
    {E This mainframe does not support the requested type of keypoint
    { collection.

    ose$kpt_mp_required = osc$keypoint_base + 11,
    {E This collection request requires multiprocessor collection.

    ose$kpt_task_environ_incorrect = osc$keypoint_base + 12,
    {E The current job task environment will not allow keypoint collection.

    ose$kpt_not_all_proc_avail = osc$keypoint_base + 13,
    {E Keypoint collection cannot be started because not all processors are
    { available for use.

    ose$task_in_job_owns_env = osc$keypoint_base + 14,
    {E A task in this job already owns the keypoint environment.

    ose$job_kpt_invalid_mp_job = osc$keypoint_base + 15,
    {E Collecting single cpu keypoints in multiprocessing job is prohibited.


    ose$kpt_not_valid_in_task = osc$keypoint_base + 16,
    {E Keypoint activities in this task are invalid.

    ose$not_enough_procs_for_kpt = osc$keypoint_base + 17,
    {E The task's current processor selections are not such that
    {  multiprocessor keypoint collection is available.


    ose$fail_to_update_keyp_flags = osc$keypoint_base + 18;
    {E The keypoint flags were not successfully cleared in
    { all of the tasks in the system or job.

?? OLDTITLE ??

*DECK DECK=OSE$MESSAGE_GEN_EXCEPTIONS EXPAND=FALSE
*copyc OSC$BASE_EXCEPTION
?? NEWTITLE := 'OSDMERR : Message Generator : ''OS'' 100 .. 109', EJECT ??

  CONST
    ose$bad_message_level = osc$base_exception + 100,
    {E Unrecognizable message level.}

    ose$bad_natural_language = osc$base_exception + 101,
    {E Incorrect name for natural language: +P.}

    ose$bad_interaction_style = osc$base_exception + 102,
    {E Unrecognizable interaction style.}

    ose$bad_day_of_week       = osc$base_exception + 103,
    {E Incorrect day of week specified.}

    ose$improper_inter_item_value   = osc$base_exception + 104,
    {E Interaction information had improper value(s) in array element(s): +P. }

    ose$unknown_interaction_item    = osc$base_exception + 105;
    {E Interaction information had unknown key(s) in array element(s): +P.}

?? OLDTITLE ??
*DECK DECK=OSE$MULTIPRO_EXCEPTIONS EXPAND=TRUE
*copyc osc$base_exception
?? NEWTITLE := 'Multiprocessing Exceptions : ''OS'' 10 .. 19', EJECT ??

  CONST
    ose$job_has_active_child_tasks = osc$base_exception + 10,
    {E The job has active child tasks; +P }

    ose$multiprocessing_already_on = osc$base_exception + 11,
    {W Multiprocessing capabilities for job are already on; +P }

    ose$not_called_by_job_monitor = osc$base_exception + 12,
    {E Command was not called by job monitor: +P }

    ose$no_processor_selected = osc$base_exception + 13,
    {E No specific processor was chosen for the job; +P not executed }

    ose$processor_not_defined = osc$base_exception + 14,
    {E The processor is not defined in this configuration; +P not executed }

    ose$processor_not_on = osc$base_exception + 15,
    {E +P cannot select a processor that is down, off, dedicated to NOS, or not yet enabled for production }

    ose$no_multiprocessing_observed = osc$base_exception + 16,
    {E No multiprocessing was observed. }

    ose$no_multiprocessing_possible = osc$base_exception + 17,
    {E Multiprocessing is not possible on a single processor system. }

    ose$keypoint_not_active_on_proc = osc$base_exception + 18,
    {E Keypoint collection is not active on this processor. }

    ose$keypoint_active_on_proc = osc$base_exception + 19;
    {E Keypoint collection is active--can not deselect a processor.}
?? OLDTITLE ??

*DECK DECK=OSE$SPI_CONDITIONS EXPAND=FALSE
?? RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc osc$base_exception
?? POP ??

?? NEWTITLE := 'ose$spi_conditions: Operating System       : ''OS'' + 750 .. ''OS'' + 750' ??

  CONST

    osc$spi_base = osc$base_exception + 750,

    ose$spi_invalid_collection_file = osc$spi_base + 0,
    {E A collection file either was not a permanent file or was not able to be written.}

    ose$spi_environment_not_avail = osc$spi_base + 1,
    {E Another job is currently using the SPI collection environment.}

    ose$spi_illegal_request = osc$spi_base + 2,
    {E A SPI environment request was issued, but the SPI environment has not been enabled.}

    ose$collection_task_ended = osc$spi_base + 3,
    {E The SPI collection task has ended, therefore this request is not honored.}

    ose$job_has_spi_environment = osc$spi_base + 4;
    {E The current job has already reserved the SPI environment.}

?? OLDTITLE ??
*DECK DECK=OSE$SYSTEM_DEBUG_UTILITY EXPAND=FALSE
*copyc OSC$BASE_EXCEPTION
?? NEWTITLE := 'System Debug Utility Error Codes : ''OS'' 900 .. 999',
  EJECT ??

  CONST
    ose$address_not_readable = osc$base_exception + 900,
    {E Address not readable.}

    ose$address_not_writable = osc$base_exception + 901;
    {E Address not writable.}
?? OLDTITLE ??
*DECK DECK=OSE$SYSTEM_TASK_EXCEPTIONS EXPAND=FALSE
*copyc osc$base_exception
?? NEWTITLE := 'OSE$SYSTEM_TASK_EXCEPTIONS: System Task exceptions: 210020 - 210029', EJECT ??

  CONST
    ose$system_task_not_defined = osc$base_exception + 20,
    {E The system task +P is not defined.}

    ose$system_task_already_defined = osc$base_exception + 21,
    {E The system task +P is already defined.}

    ose$system_task_not_active = osc$base_exception + 22,
    {E The system task +P is not active.}

    ose$system_task_active = osc$base_exception + 23,
    {E The system task +P is currently active.}

    ose$system_task_still_running = osc$base_exception + 24,
    {E The system task +P has not terminated following deactivation.}

    ose$exec_ring_below_min_ring = osc$base_exception + 25,
    {E The specified EXECUTION_RING is less than the user's validated minimum
    { ring.}

    ose$task_not_under_oper_control = osc$base_exception + 26,
    {E The system task +P cannot be controlled via the command +P.}

    ose$terminated_by_idle_system = osc$base_exception + 27,
    {E The system task +P was terminated by an IDLE_SYSTEM or a
    { TERMINATE_SYSTEM command.}

    ose$not_system_job_monitor = osc$base_exception + 28;
    {E Only the system job monitor task may use +P.}

?? OLDTITLE ??
*DECK DECK=OSE$UNDEFINED_CONDITION EXPAND=FALSE
*copyc osc$base_exception
?? NEWTITLE := 'Undefined Condition : ''OS'' 9999', EJECT ??

  CONST
    ose$undefined_condition = osc$base_exception + 9999;
    {E ose$undefined_condition - - The following error was encountered,+N11..}
    {but no status condition existed to represent it:+N11..}
    {****************************************************************+N11+P}

?? OLDTITLE ??

*DECK DECK=OSH$ACTIVATE_SYSTEM_TASK EXPAND=FALSE
{
{   The purpose of this procedure is to activate a system task.
{
{   If this request is called in the system job monitor task (i.e., prior
{ to initiation of the console interaction task), then the system task is
{ executed.  Otherwise, the system job monitor task is readied so that it
{ may execute the system task.
{
{    OSP$ACTIVATE_SYSTEM_TASK (NAME, STATUS)
{
{ NAME: (input) This parameter specifies the name of the system task
{       to be activated.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             ofe$sou_not_active
{             ose$system_task_active
{             ose$system_task_not_defined
{             ose$system_task_still_running
{             ose$task_not_under_oper_control
{
*DECK DECK=OSH$APPEND_STATUS_FILE EXPAND=FALSE
{
{   The purpose of this request is to append the path name for  a  file  as  a
{ status  parameter  to the text of a status record.  Some editing of the path
{ name may be done prior to appending it to the  status  record  in  order  to
{ obtain  the minimal sized representation of the path name, assuming that the
{ status will be interpreted within the current  job.   This  request  assumes
{ that   the   status   record   has   been   initialized   by   a   call   to
{ osp$set_status_abnormal.
{
{       OSP$APPEND_STATUS_FILE (DELIMITER, FILE, STATUS)
{
{ DELIMITER: (input) This parameter specifies the character that will  precede
{       the path name supplied by this request in the text field of the status
{       being formed.  Depending on its value, this character may cause one of
{       two  effects  when  the  status  is formatted into a message.  If this
{       character is the same as the first character in the text  field,  then
{       the  integer  will  be  treated  as  a separate status parameter.  If,
{       however, this character is different from the first character  in  the
{       text  field,  then this character and the path name will be treated as
{       part of the preceding  status  parameter  (this  feature  permits  the
{       creation of a single status parameter from separate pieces of data).
{
{ FILE: (input)  This parameter specifies the path name (file) to be appended.
{
{ STATUS: (input, output) This parameter specifies the status record to  which
{       the text is to be appended.
{
*DECK DECK=OSH$APPEND_STATUS_INTEGER EXPAND=FALSE
{
{   The purpose of this request  is  to  convert  an  integer  to  its  string
{ representation and append that string as a status parameter to the text of a
{ status record.  This  request  assumes  that  the  status  record  has  been
{ initialized by a call to osp$set_status_abnormal.
{
{       OSP$APPEND_STATUS_INTEGER (DELIMITER, INT, RADIX,
{         INCLUDE_RADIX_SPECIFIER, STATUS)
{
{ DELIMITER:  (input) This parameter specifies the character that will precede
{       the integer supplied by this request in the text field of  the  status
{       being formed.  Depending on its value, this character may cause one of
{       two effects when the status is formatted  into  a  message.   If  this
{       character  is  the same as the first character in the text field, then
{       the integer will be treated  as  a  separate  status  parameter.   If,
{       however,  this  character is different from the first character in the
{       text field, then this character and the integer  will  be  treated  as
{       part  of  the  preceding  status  parameter  (this feature permits the
{       creation of a single status parameter from separate pieces of data).
{
{ INT: (input) This parameter specifies the integer to be converted.
{
{ RADIX: (input) This parameter specifies the radix  in  which  the  integer's
{       value is to be represented.
{
{ INCLUDE_RADIX_SPECIFIER:   (input)  This  parameter  specifies  whether  the
{       representation of the radix is to be included in the resulting  string
{       -- e.g.  (16) for a number with a radix of 16.
{
{ STATUS:  (input, output) This parameter specifies the status record to which
{       the text is to be appended.
{
*DECK DECK=OSH$APPEND_STATUS_PARAMETER EXPAND=FALSE
{
{   The purpose of this request is to append a status parameter to the text of
{ a  status  record.   This  request  assumes  that the status record has been
{ initialized by a call to osp$set_status_abnormal.
{
{       OSP$APPEND_STATUS_PARAMETER (DELIMITER, TEXT, STATUS)
{
{ DELIMITER: (input) This parameter specifies the character that will  precede
{       the  text  supplied  by  this  request in the text field of the status
{       being formed.  Depending on its value, this character may cause one of
{       two  effects  when  the  status  is formatted into a message.  If this
{       character is the same as the first character in the text  field,  then
{       the  new  text  will  be  treated as a separate status parameter.  If,
{       however, this character is different from the first character  in  the
{       text  field,  then  this character and the new text will be treated as
{       part of the preceding  status  parameter  (this  feature  permits  the
{       creation of a single status parameter from separate pieces of data).
{
{ TEXT:  (input) This parameter specifies the status parameter text.  Trailing
{       spaces in this text are not included in the status record.
{
{ STATUS: (input, output) This parameter specifies the status record to  which
{       the text is to be appended.
{
*DECK DECK=OSH$APPEND_STATUS_REAL EXPAND=FALSE
{
{   This request converts a real  number  to  its  string  representation  and
{ appends  that  string  as  a  status parameter to the text field of a status
{ record.  This request assumes that the status record has been initialized by
{ a call to osp$set_status_abnormal.
{
{       OSP$APPEND_STATUS_REAL (DELIMITER, REAL_NUMBER, NUMBER_OF_DIGITS,
{         STATUS)
{
{ DELIMITER:  (input) This parameter specifies the character that will precede
{       the real number supplied by this request in  the  text  field  of  the
{       status being formed.  Depending on its value, this character may cause
{       one of two effects when the status is formatted into  a  message.   If
{       this  character  is the same as the first character in the text field,
{       then the integer will be treated as a separate status parameter.   If,
{       however,  this  character is different from the first character in the
{       text field, then this character and the real number  will  be  treated
{       as  part  of  the preceding status parameter (this feature permits the
{       creation of a single status parameter from separate pieces of data).
{
{ REAL_NUMBER: (input) This is the real number to be appended.
{
{ NUMBER_OF_DIGITS: (input) This specifies the maximum  number  of  digits  to
{       include in the result.  There may be fewer digits than this since zero
{       digits to the right of the decimal point are not included.
{
{ STATUS:  (input, output) This parameter specifies the status record to which
{       the text is to be appended.
{
*DECK DECK=OSH$AWAIT_ACTIVITY EXPAND=FALSE

{
{    The purpose of this request is suspend execution of the requesting
{  task until the completion of one of the specified activities.
{
{      OSP$AWAIT_ACTIVITY (WAIT_LIST, READY_INDEX, COMPLETE, STATUS)
{
{  WAIT_LIST: (input) This parameter specifies the activities that the
{        task is awaiting completion.  The activity, osc$null_activity, can
{        be used as a filler to manage the list of activities.
{
{  READY_INDEX: (output) This parameter specifies the activity in the
{      WAIT_LIST which caused the task to resume execution.
{
{  COMPLETE: (output) This parameter specifies whether the request completed
{       or the request was interrupted and must be re-issued.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: ose$incorrect_activity.
{       IDENTIFIER: 'OS'.
{
{       CONDITION: pme$unknown_queue_identifier, pme$usage_bracket_error.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=OSH$AWAIT_ACTIVITY_COMPLETION EXPAND=FALSE

{
{    The purpose of this request is suspend execution of the requesting
{  task until the completion of one of the specified activities.
{
{      OSP$AWAIT_ACTIVITY_COMPLETION (WAIT_LIST, READY_INDEX, STATUS)
{
{  WAIT_LIST: (input) This parameter specifies the activities that the
{        task is awaiting completion.  The activity, osc$null_activity, can
{        be used as a filler to manage the list of activities.
{
{  READY_INDEX: (output) This parameter specifies the activity in the
{      WAIT_LIST which caused the task to resume execution.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: ose$incorrect_activity.
{       IDENTIFIER: 'OS'.
{
{       CONDITION: pme$unknown_queue_identifier, pme$usage_bracket_error.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=OSH$BEGIN_SUBSYSTEM_ACTIVITY EXPAND=FALSE

{
{      *** WARNING This interface is intended to be used carefully ***
{      ***     by subsystem writers ONLY. Misuse of this interface ***
{      ***     may cause a degradation in system performance or    ***
{      ***     (in worse case) a system failure.                   ***
{
{ This request is used to inform the operating system that the task has
{ entered a critical region where global resources may be interlocked.
{ This request will cause the system to give special dispatching/swapping
{ priority to the job and task while the task is in the critical region.
{
{ Critical regions may be nested. There is a counter for each task that is
{ incremented each time the task enters a critical region and decremented
{ each time the task exits the critical region. If the count is non-zero
{ the task is considered to be in a critical region. If the count exceeds
{ 255 the task is terminated.
{
{ Correct use of this request requires the following:
{    o the size of the critical region should be as small as possible.
{      Try to minimize the CP time spent in the critical region. Values
{      up to a couple of hundred of milliseconds are reasonable.
{    o Try to prevent  page faults while in the critical
{      region, especially to pages that may be on disk. If possible,
{      data structures that will be referenced from within the critical
{      region should be referenced prior to entering the critical region.
{    o Avoid calls to other parts of the operating system while in the
{      critical region.
{
{ NOSVE handles critical regions as follows:
{    o A task is guaranteed at least 1 full time slice after entering a
{      critical region before a task switch will occur because of end of
{      timeslice. (of course pmp$wait, page fault for page on disk, etc.
{      will cause a task switch sooner)
{    o A task in a critical region will execute for 5 time slices with
{      a high priority. After 5 time slices have elapsed, the task reverts
{      to its nominal priority. No further special dispatching
{      consideration is given to the task.
{    o If a PMP$READY_TASK or PMP$READY_TASK_AND_WAIT request is sent to
{      a task in a critical region, the priority of the task in the
{      critical region is set to the larger of its current priority or
{      the nominal priority of the task that issued the ready request.
{      The task will continue to execute with this priority until it
{      exits the critical region. At this time the priority reverts to
{      its original priority.
{
{
{  OSP$BEGIN_SUBSYSTEM_ACTIVITY;
{
{
*DECK DECK=OSH$CHANGE_INTERACTION_INFO EXPAND=FALSE
{
{   This request changes information describing the user's preferences for
{ interacting with the system and applications.  One or more of the following
{ items can be changed:
{
{       osc$interaction_style:  specifies a osc$line_interaction or
{             osc$screen_interaction (osc$desktop_interaction cannot be
{             selected via this interface)
{
{       osc$menu_rows:  specifies the number of rows of function key menus that
{             a screen style application should show
{
{       osc$extend_utility_interaction:  specifies whether command utilities
{             that do not provide their own specific screen or desktop
{             interface should be run using a generic such interface
{
{
{       OSP$CHANGE_INTERACTION_INFO (INTERACTION_INFORMATION, STATUS)
{
{ INTERACTION_INFORMATION: (input)  This parameter specifies the selected
{       interaction information.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:  ose$unknown_interaction_item
{                    ose$improper_inter_item_value
{
*DECK DECK=OSH$CHANGE_INTERACTION_STYLE EXPAND=FALSE

{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     **** This program interface is obsolete.  Modules presently using *****
{     *** it should be changed to use OSP$CHANGE_INTERACTION_INFO.      *****
{     ***********************************************************************
{     ***********************************************************************
{
{   This request changes the preferred interaction style selected for an
{ interactive job.
{
{       OSP$CHANGE_INTERACTION_STYLE (INTERACTION_STYLE, STATUS)
{
{ INTERACTION_STYLE: (input)  This parameter specifies the selected
{       interaction style.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:  ose$bad_interaction_style
{
*DECK DECK=OSH$CHECK_CLIENT_LEVELED_ACCESS EXPAND=FALSE
{    The purpose of the request is to determine if a local family is available
{ for leveled access to any client in a cluster.
{
{       OSP$CHECK_CLIENT_LEVELED_ACCESS ( FAMILY_NAME, LEVELED_ACCESS)
{
{ FAMILY_NAME: (input)  This parameter specifies a family name on the local
{       mainframe.
{
{ LEVELED_ACCESS: (output)  This parameter specifies whether or not the
{       specified family is available for leveled access to any client
{       mainframe in the cluster.
*DECK DECK=OSH$CLEAR_SIGNATURE_LOCK EXPAND=FALSE

{
{  The purpose of this procedure is to clear a signature lock that has
{  previously been set by OSP$SET_SIGNATURE_LOCK request.  If
{  the value of the lock is not equal to the current global
{  taskid then the current task is aborted.  If the lock is in the
{  mainframe wired or mainframe paged segment, the system
{  lock count in the current task's XCB is decremented.  If the
{  system lock count is zero and the GIVE UP CPU flag is set
{  in the XCB, a CYCLE request is issued to cause the task to give
{  up the cpu.
{
{    OSP$CLEAR_SIGNATURE_LOCK (LOCK, STATUS)
{
{  LOCK: (INPUT,OUTPUT) This parameter specifies the lock.
{
{  STATUS: (OUTPUT) This parameter specifies the request status.
{
*DECK DECK=OSH$COLLECTION_FILE_INFO EXPAND=FALSE
{
{  The purpose of this procedure is to store information about the
{ keypoint files in the global keypoint buffer. The PVAs and the
{ file identifiers for the files are stored.
{
{   OSP$COLLECTION_FILE_INFO (number_of_files, file_id_array, pva_array, status)
{
{ NUMBER_OF_FILES: (INPUT) This parameter specifies the number of keypoint files associated
{                  with this reservation of the keypoint utility. There must be one file
{                  associated with each processor on which keypoints will be active.
{
{ FILE_ID_ARRAY: (INPUT) This parameter specifies the file_identifier associated with each
{                  of the keypoint files.
{
{ PVA_ARRAY: (INPUT) This parameter specifies the PVA of each of the keypoint files.
{
{ STATUS: (OUTPUT) This parameter specifies the request status.
{
*DECK DECK=OSH$COMPRESS_FILE_REFERENCE EXPAND=FALSE
{
{    The purpose of this request is to compress a file_reference to a size less
{ than or equal to the size of the string specified as the
{ compressed_file_reference.  This representation of the file reference is not
{ useable as a file_reference but only as a string that is to be displayed
{ later and in which storage is limited.  (ie.  Placing file_references in a
{ status variable).  This representation is not directly useable for displaying
{ the file_reference, but osp$expand_file_reference must be called first.  The
{ result of calling osp$expand_file_reference will be to reverse some of the
{ encryption used by osp$compress_file_reference, but it may not reverse all of
{ it.  Therefore, the product of osp$compress_file_reference and/or
{ osp$expand_file_reference can never be used for anything other than
{ displaying a representation of the file_reference.  The call to
{ osp$expand_file_reference must be executed within the same job as
{ osp$compress_file_reference was executed to ensure correctness.  The
{ encryption algorithm used by osp$compress_file_reference may change and
{ therefore can not be relied upon.
{
{       OSP$COMPRESS_FILE_REFERENCE (FILE_REFERENCE, COMPRESSED_FILE_REFERENCE,
{             COMPRESSED_FILE_REFERENCE_SIZE, STATUS)
{
{ FILE_REFERENCE: (input)  This parameter specifies the file_reference that is
{       to be compressed.
{
{ COMPRESSED_FILE_REFERENCE:  (input/output) This parameter specifies the
{       string into which the compressed representation is to be placed.  The
{       size of the specified string determines the maximum size for the
{       compressed representation.
{
{ COMPRESSED_FILE_REFERENCE_SIZE: (output)  This parameter specifies the actual
{       size of the compressed representation.  This value may be smaller than
{       the size of the string specified as the COMPRESSED_FILE_REFERENCE, but
{       it can never be larger.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:  none.
{
*DECK DECK=OSH$COPY_LOCAL_STATUS_TO_STATUS EXPAND=FALSE
{
{   The purpose of this request is to copy a "local status" variable to a
{ procedure's request status.  Only the valid portion of the status record
{ is copied.
{
{        OSP$COPY_LOCAL_STATUS_TO_STATUS (LOCAL_STATUS, STATUS);
{
{ LOCAL_STATUS: (input) This is the procedure's local status variable that
{        is to be copied to the procedure's request status.  For performance
{        this parameter is a VAR parameter.  This will ALWAYS inhibit CYBIL
{        from making a copy of the local status value.
{
{ STATUS: (output) This is the procedure's request status.
{      CONDITIONS:
{        Any status conditions possible may be returned by this request.  Any
{        condition returned is the same as the condition passed in the local
{        status value.
*DECK DECK=OSH$DEACTIVATE_SYSTEM_TASK EXPAND=FALSE
{
{   The purpose of this request is to deactivate a system task.
{
{   If this request is called in the system job monitor task (i.e., prior
{ to initiation of the console interaction task), then the system task is
{ terminated.  Otherwise, the system job monitor task is readied so that it
{ may terminate the system task.
{
{    OSP$DEACTIVATE_SYSTEM_TASK (NAME, STATUS)
{
{ NAME: (input) This parameter specifies the name of the system task
{       to be deactivated.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             ofe$sou_not_active
{             ose$system_task_not_active
{             ose$system_task_not_defined
{             ose$task_not_under_oper_control
{
*DECK DECK=OSH$DEFINE_SYSTEM_TASK EXPAND=FALSE
{
{   The purpose of this request is to define a system task.
{
{   System tasks execute as callees of the system job monitor task. System tasks
{ are ordinary tasks but have the following special characteristics:
{     - they may be automatically restarted if they terminate.
{     - they are idled/terminated as part of system termination.
{
{   OSP$DEFINE_SYSTEM_TASK (NAME, AUTOMATIC_RESTART, DEACTIVATE_TASK_OPTION,
{         IDLE_TASK_OPTION, RESTART_AFTER_IDLE, SPY_IDENTIFIER, EXECUTION_RING,
{         PROGRAM_DESCRIPTION, PARAMETERS, STATUS)
{
{  NAME: (input) This parameter specifies the name of the system task. This
{        name is used to identify the task in subsequent requests.
{
{  AUTOMATIC_RESTART: (input) This parameter specifies whether the task
{        should automatically be restarted if it fails.
{
{  DEACTIVATE_TASK_OPTION: (input) This parameter specifies the method used
{        to terminate the task when it is deactivated.  The allowed values are:
{             . terminate - terminate via pmp$terminate
{             . prohibited - task cannot be deactivated by operator command
{             . voluntary - task will periodically test for system idle-down
{        Tasks that are not terminated must periodically check to determine if
{        the system is being idled.
{
{  IDLE_TASK_OPTION: (input) This parameter specifies the method used to
{        terminate the task during a system idle-down.  The allowed values are
{        the same as those on the DEACTIVATE_TASK_OPTION parameter.
{
{  RESTART_AFTER_IDLE: (input) This parameter specifies whether to restart the task
{        during a resume of a system which has been idled.
{
{  SPY_IDENTIFIER: (input) This parameter specifies the spy_identifier to be
{        used during the execution of this task.
{
{  EXECUTION_RING: (input) This parameter specifies the ring in which the task
{        is to start execution.  The specified ring must be greater than or
{        equal to the minimum_ring validation of the login user of the job in
{        in which this request is made.
{
{  PROGRAM_DESCRIPTION: (input) This parameter is a pointer to a program
{        description that defines the task to be executed.
{
{  PARAMETERS: (input) This parameter is a pointer to the parameters for the
{        task.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              ofe$sou_not_active
{              ose$exec_ring_below_min_ring
{              ose$system_task_already_defined
{
*DECK DECK=OSH$DELETE_SYSTEM_TASK EXPAND=FALSE
{
{   The purpose of this request is to delete a system task definition.
{
{   A system task may not be deleted if it is active.
{
{    OSP$DELETE_SYSTEM_TASK (NAME, STATUS)
{
{ NAME: (input) This parameter specifies the name of the system task to be
{       deleted.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             ofe$sou_not_active
{             ose$system_task_not_defined
{             ose$system_task_active
{             ose$system_task_still_running
{
*DECK DECK=OSH$DISESTABLISH_COND_HANDLER EXPAND=FALSE
{    The purpose of this request is to disestablish the condition handler in
{ the current procedure block that has been established via the
{ osp$establish_condition_handler or osp$establish_block_exit_hndlr request.
{
{    This procedure assumes that the caller is not an ADA critical frame
{ procedure nor a procedure whose stack frame is a DEBUG critical frame.  This
{ assumption is consistent with the OS use of the procedure.
{
{        OSP$DISESTABLISH_COND_HANDLER;
*DECK DECK=OSH$ESTABLISH_BLOCK_EXIT_HNDLR EXPAND=FALSE
{    The purpose of this request is to establish a condition handler for the
{ block exit condition.
{
{    Only one condition handler may be established in a procedure block with
{ this request.  This request is not compatible with the
{ pmp$establish_condition_handler request.  If this request is made multiple
{ times, the last request holds.
{
{    Each time this request is called the stack grows by several bytes so do
{ not use this request in a loop.
{
{       OSP$ESTABLISH_BLOCK_EXIT_HNDLR (CONDITION_HANDLER);
{
{ CONDITION_HANDLER: (input)  This is the condition handling procedure that is
{       to be given control in the current block.
*DECK DECK=OSH$ESTABLISH_CONDITION_HANDLER EXPAND=FALSE
{    The purpose of this request is to establish a condition handler for all
{ types of NOS/VE conditions except the process interval timer condition and
{ optionally the block exit condition.
{
{    Only one condition handler may be established in a procedure block with
{ this request.  This request is not compatible with the
{ pmp$establish_condition_handler request.  If this request is made multiple
{ times, the last request holds.
{
{    Each time this request is called the stack grows by several bytes so do
{ not use this request in a loop.
{
{       OSP$ESTABLISH_CONDITION_HANDLER (CONDITION_HANDLER, BLOCK_EXIT);
{
{ CONDITION_HANDLER: (input)  This is the condition handling procedure that is
{       to be given control in the current block.
{
{ BLOCK_EXIT: (input)  Indicates if the condition handler should be given
{       control for block exit processing.
*DECK DECK=OSH$EXPAND_FILE_REFERENCE EXPAND=FALSE
{
{    The purpose of this request is to reverse some of the encryption used by
{ osp$compress_file_reference, but it may not reverse all of it.  The product
{ of osp$expand_file_reference can never be used for anything other than
{ displaying a representation of the file_reference.  The call to
{ osp$expand_file_reference must be executed within the same job as
{ osp$compress_file_reference was executed to ensure correctness.  The
{ encryption algorithm used by osp$compress_file_reference may change and
{ therefore can not be relied upon.
{
{       OSP$EXPAND_FILE_REFERENCE (FILE_REFERENCE, EXPANDED_FILE_REFERENCE,
{             EXPANDED_FILE_REFERENCE_SIZE, STATUS)
{
{ FILE_REFERENCE: (input)  This parameter specifies the file_reference that is
{       to be expanded.  .
{
{ EXPANDED_FILE_REFERENCE:  (input/output) This parameter specifies the string
{       into which the expanded representation is to be placed.  If the size of
{       the specified string is not large enough to contain the
{       expanded_file_reference, then the reversing of the encryption will not
{       take place.
{
{ EXPANDED_FILE_REFERENCE_SIZE: (output)  This parameter specifies the actual
{       size of the expanded representation.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:  none.
{
*DECK DECK=OSH$EXPAND_PTL EXPAND=FALSE
{
{    This procedure expands the PTL.
{
{        OSP$EXPAND_PTL (UNCONDITIONALLY_EXPAND, STATUS)
{
{  UNCONDITIONALLY_EXPAND: (input) This boolean parameter specifies whether
{        or not the PTL will be expanded if there are already free entries
{        available.
{
{  STATUS: (output) This parameter specifies the result of the procedure.
{
*DECK DECK=OSH$FETCH_COLLECTION_FILE_INFO EXPAND=FALSE
{
{   The purpose of this request is to retrieve information about the
{ keypoint files associated with this reservation of the keypoint
{ environment. The file_identifier and the PVA of each of the files
{ is retrieved.
{
{   OSP$FETCH_COLLECTION_FILE_INFO (pva_array, file_id_array, number_of_files)
{
{ PVA_ARRAY: (OUTPUT) This parameter returns the PVA associated with each of the
{                     keypoint files. There must be one keypoint file for each
{                     processor on which keypoints are active.
{
{ FILE_ID_ARRAY: (OUTPUT) This parameter returns the file_identifier associated
{                     with each of the keypoint files.
{
{ NUMBER_OF_FILES: (OUTPUT) This parameter returns the number of keypoint files
{{                     associated with this reservation of the keypoint environment.
{
*DECK DECK=OSH$FETCH_SYSTEM_CONSTANT EXPAND=FALSE
{
{ This procedure is used to fetch the value of a system attribute that
{ was set via the SETSA command.
{
{     OSP$FETCH_SYSTEM_CONSTANT (NAME, INDEX, VALUE, STATUS)
{
{  NAME: {INPUT} This parameter specifies the name of the attribute.
{  INDEX: This parameter is reserved for internal use and should be
{         set to zero.
{  VALUE: {OUTPUT} This parameter will contain the value of the attribute
{
*DECK DECK=OSH$FIND_APPLICATION_MENU EXPAND=FALSE
{
{   The purpose of this request is to find a particular menu  description  for
{ an application within a help module.
{
{       OSP$FIND_APPLICATION_MENU (HELP_MODULE, MENU_NAME, MENU_CLASSES,
{         MENU_ITEMS, STATUS)
{
{ HELP_MODULE: (input) This parameter specifies the pointer to the help module
{       that is to be searched.
{
{ MENU_NAME: (input) This parameter specifies the name of the application menu
{       to be found.
{
{ MENU_CLASSES:   (output)   This  parameter  specifies  the  pointer  to  the
{       definition of the menu classes.  If the specified menu  could  not  be
{       found in the help module, NIL is returned.
{
{ MENU_ITEMS:  (output) This parameter specifies the pointer to the definition
{       of the menu items.  If the specified menu could not be  found  in  the
{       help module, NIL is returned.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=OSH$FIND_BRIEF_HELP_MESSAGE EXPAND=FALSE
{
{   The purpose of this request is to find the template  for  the  brief  help
{ message for an SCL command or function within a help module.
{
{       OSP$FIND_BRIEF_HELP_MESSAGE (HELP_MODULE, MESSAGE_TEMPLATE, STATUS)
{
{ HELP_MODULE: (input) This parameter specifies the pointer to the help module
{       that is to be searched.
{
{ MESSAGE_TEMPLATE: (output) This  parameter  specifies  the  pointer  to  the
{       template  for the message.  If no brief help message could be found in
{       the help module, NIL is returned.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=OSH$FIND_FULL_HELP_MESSAGE EXPAND=FALSE
{
{   The purpose of this request is to find the  template  for  the  full  help
{ message for an SCL command or function within a help module.
{
{       OSP$FIND_FULL_HELP_MESSAGE (HELP_MODULE, MESSAGE_TEMPLATE, STATUS)
{
{ HELP_MODULE: (input) This parameter specifies the pointer to the help module
{       that is to be searched.
{
{ MESSAGE_TEMPLATE: (output) This  parameter  specifies  the  pointer  to  the
{       template  for  the message.  If no full help message could be found in
{       the help module, NIL is returned.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=OSH$FIND_HELP_MODULE EXPAND=FALSE
{
{   The purpose of this request is to search for a help module.  Help  modules
{ reside  on object libraries and contain prompts and help information for SCL
{ commands and functions, and descriptions of menus for applications.  A  help
{ module may also contain status message descriptions.
{
{   A help module is located by searching each object library in  the  command
{ list for the name of the help module.  The name of the help module is formed
{ by using the seed name passed to this request and suffixing it with a dollar
{ sign  ($)  character  followed by the name of the preferred natural language
{ selected for the job.  If no module with the resulting name  is  found,  the
{ process  is  repeated,  this  time  using  the  name  of the default natural
{ language (US_English).
{
{       OSP$FIND_HELP_MODULE (SEED_NAME, HELP_MODULE, ONLINE_MANUAL_NAME,
{         NATURAL_LANGUAGE, STATUS)
{
{ SEED_NAME: (input) This parameter specifies the name that is to be  suffixed
{       with  a $ and the name of the natural language to form the name of the
{       module to be searched for.
{
{ HELP_MODULE: (output) This parameter  specifies  the  pointer  to  the  help
{       module.   This  pointer  is  used  as  input  to  requests that locate
{       specific messages within  the  help  module.   If  this  parameter  is
{       returned as NIL, the specified help module could not be found.
{
{ ONLINE_MANUAL_NAME: (output) This parameter specifies the name of the online
{       manual associated with the help module.  If the specified help  module
{       could not be found or if there is no online manual associated with the
{       help module, osc$null_name is returned.
{
{ NATURAL_LANGUAGE: (output) This parameter specifies the name of the  natural
{       language  in  which  the  messages, prompts and menus contained in the
{       help module are composed.  If the specified help module could  not  be
{       found, osc$null_name is returned.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=OSH$FIND_HELP_MODULE_IN_LIBRARY EXPAND=FALSE
{
{   The purpose of this request is to search for a help module on a  specified
{ object library.  A help module contains prompts and help information for SCL
{ commands and functions, and descriptions of menus for applications.  A  help
{ module may also contain status message descriptions.
{
{   A help module is located by searching the specified object library for the
{ name of the help module.  The name of the help module is formed by using the
{ seed name passed to this request and suffixing it with  a  dollar  sign  ($)
{ character  followed  by  the name of the preferred natural language selected
{ for the job.  If no module with the resulting name is found, the process  is
{ repeated,  this  time  using  the  name  of  the  default  natural  language
{ (US_English).
{
{       OSP$FIND_HELP_MODULE_IN_LIBRARY (OBJECT_LIBRARY, SEED_NAME,
{         HELP_MODULE, ONLINE_MANUAL_NAME, NATURAL_LANGUAGE, STATUS)
{
{ OBJECT_LIBRARY: (input) This parameter specifies the object  library  to  be
{       searched  for  the help module.  The caller is responsible for opening
{       and getting a segment pointer to the object library.
{
{ SEED_NAME: (input) This parameter specifies the name that is to be  suffixed
{       with  a $ and the name of the natural language to form the name of the
{       module to be searched for.
{
{ HELP_MODULE: (output) This parameter  specifies  the  pointer  to  the  help
{       module.   This  pointer  is  used  as  input  to  requests that locate
{       specific messages within  the  help  module.   If  this  parameter  is
{       returned as NIL, the specified help module could not be found.
{
{ ONLINE_MANUAL_NAME: (output) This parameter specifies the name of the online
{       manual associated with the help module.  If the specified help  module
{       could not be found or if there is no online manual associated with the
{       help module, osc$null_name is returned.
{
{ NATURAL_LANGUAGE: (output) This parameter specifies the name of the  natural
{       language  in  which  the  messages, prompts and menus contained in the
{       help module are composed.  If the specified help module could  not  be
{       found, osc$null_name is returned.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=OSH$FIND_PARAMETER_HELP_MESSAGE EXPAND=FALSE
{
{   The purpose of this request is to find the template for the  help  message
{ for a parameter for an SCL command or function within a help module.
{
{       OSP$FIND_PARAMETER_HELP_MESSAGE (HELP_MODULE, PARAMETER_NAME,
{         MESSAGE_TEMPLATE, STATUS)
{
{ HELP_MODULE: (input) This parameter specifies the pointer to the help module
{       that is to be searched.
{
{ PARAMETER_NAME: (input) This parameter specifies the name of the command  or
{       function parameter whose help message is to be found.
{
{ MESSAGE_TEMPLATE:  (output)  This  parameter  specifies  the  pointer to the
{       template for the message.  If no help message for the parameter  could
{       be found in the help module, NIL is returned.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=OSH$FIND_PARAMETER_PROMPT EXPAND=FALSE
{
{   The purpose of this request is to find the template for the prompt  for  a
{ parameter for an SCL command or function within a help module.
{
{       OSP$FIND_PARAMETER_PROMPT (HELP_MODULE, PARAMETER_NAME,
{         PROMPT_TEMPLATE, STATUS)
{
{ HELP_MODULE: (input) This parameter specifies the pointer to the help module
{       that is to be searched.
{
{ PARAMETER_NAME: (input) This parameter specifies the name of the command  or
{       function parameter whose prompt is to be found.
{
{ PROMPT_TEMPLATE:  (output)  This  parameter  specifies  the  pointer  to the
{       template for the prompt.  If no prompt  for  the  parameter  could  be
{       found in the help module, NIL is returned.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=OSH$FIND_PARAM_ASSIST_PROMPT EXPAND=FALSE
{
{   The purpose of this request is to find the  template  for  the  assistance
{ prompt for  a parameter for an SCL command or function within a help module.
{
{       OSP$FIND_PARAM_ASSIST_PROMPT (HELP_MODULE, PARAMETER_NAME,
{         PROMPT_TEMPLATE, STATUS)
{
{ HELP_MODULE: (input) This parameter specifies the pointer to the help module
{       that is to be searched.
{
{ PARAMETER_NAME:  (input) This parameter specifies the name of the command or
{       function parameter whose assistance prompt is to be found.
{
{ PROMPT_TEMPLATE: (output)  This  parameter  specifies  the  pointer  to  the
{       template  for  the  assistance prompt.  If no prompt for the parameter
{       could be found in the help module, NIL is returned.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=OSH$FIND_STATUS_MESSAGE_BY_CODE EXPAND=FALSE
{
{   The purpose of this request is to find  the  name,  severity  and  message
{ template for a status condition code within a help module.
{
{       OSP$FIND_STATUS_MESSAGE_BY_CODE (HELP_MODULE, CONDITION_CODE,
{         CONDITION_NAME, CONDITION_SEVERITY, MESSAGE_TEMPLATE, STATUS)
{
{ HELP_MODULE: (input) This parameter specifies the pointer to the help module
{       that is to be searched.
{
{ CONDITION_CODE: (input) This parameter specifies the status  condition  code
{       to be searched for.
{
{ CONDITION_NAME:  (output)  This  parameter  specifies the name of the status
{       condition.  If no name for the status  condition  could  be  found  in
{       the help module, the name 'UNKNOWN_CONDITION' is returned.
{
{ CONDITION_SEVERITY: (output) This parameter specifies the  severity  of  the
{       status  condition.   If  no severity for the status condition could be
{       found in the help module, OSC$ERROR_STATUS is returned.
{
{ MESSAGE_TEMPLATE:  (output)  This  parameter  specifies  the  pointer to the
{       template for the message.  If no  message  for  the  status  condition
{       could be found in the help module, NIL is returned.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=OSH$FIND_STATUS_MESSAGE_BY_NAME EXPAND=FALSE
{
{   The purpose of this request is to find  the  code,  severity  and  message
{ template for a status condition name within a help module.
{
{       OSP$FIND_STATUS_MESSAGE_BY_NAME (HELP_MODULE, CONDITION_NAME,
{         CONDITION_CODE, CONDITION_SEVERITY, MESSAGE_TEMPLATE, STATUS)
{
{ HELP_MODULE: (input) This parameter specifies the pointer to the help module
{       that is to be searched.
{
{ CONDITION_NAME: (input) This parameter specifies the status  condition  name
{       to be searched for.
{
{ CONDITION_CODE:  (output)  This  parameter  specifies the code of the status
{       condition.  If no code for the status  condition  could  be  found  in
{       the help module, zero is returned.
{
{ CONDITION_SEVERITY: (output) This parameter specifies the  severity  of  the
{       status  condition.   If  no severity for the status condition could be
{       found in the help module, OSC$ERROR_STATUS is returned.
{
{ MESSAGE_TEMPLATE:  (output)  This  parameter  specifies  the  pointer to the
{       template for the message.  If no  message  for  the  status  condition
{       could be found in the help module, NIL is returned.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=OSH$FORMAT_HELP_MESSAGE EXPAND=FALSE
{
{   The purpose of this request is to format a message according to a template
{ for  that  message.   The  template  consists of message text and formatting
{ codes that direct the formatting  process.   All  of  the  formatting  codes
{ available  for  status messages are also available to the messages processed
{ by this request.  Parameters to be substituted into the message are supplied
{ via  an  array of pointers to strings, each string representing a particular
{ message parameter.
{
{   The    message    is   returned   in   a   sequence   which   contains   a
{ ost$status_message_line_count followed by that  many  message  lines.   Each
{ message line consists of a ost$status_message_line_size followed by a string
{ of that size.  These lines can be written to  a  file  via  the  appropriate
{ interfaces.   Each  line begins with a space character to serve as a "format
{ effector" in the event the formatted message is written to a list file.
{
{       OSP$FORMAT_HELP_MESSAGE (MESSAGE_TEMPLATE, MESSAGE_PARAMETERS,
{         MAX_MESSAGE_LINE, MESSAGE, STATUS)
{
{ MESSAGE_TEMPLATE: (input) This parameter  specifies  the  template  for  the
{       message to be formatted.
{
{ MESSAGE_PARAMETERS: (input) This parameter specifies the items of text to be
{       substituted  into  the message according to the parameter substitution
{       formatting codes in the message template.  If  NIL  is  specified  for
{       this  parameter,  all  message  parameters are considerred to be null.
{       If NIL is specified for any  particular  element  of  the  array,  the
{       corresponding message parameter is considerred to be null.
{
{ MAX_MESSAGE_LINE:  (input)  This  parameter  specifies the maximum number of
{       characters that can be placed in a line produced by this request.  The
{       message  formatter  will try to "break" long lines at a delimiter; but
{       if this cannot be done, two dots will be placed  at  the  end  of  the
{       "broken" line to mark its continuation.
{
{ MESSAGE:  (output)  This parameter specifies the container for the formatted
{       message.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=OSH$FORMAT_MESSAGE EXPAND=FALSE
{
{   The purpose of this request is to return a  message  that  represents  the
{ status  condition.   The  message is returned in a sequence which contains a
{ ost$status_message_line_count followed by that  many  message  lines.   Each
{ message line consists of a ost$status_message_line_size followed by a string
{ of that size.  These lines  can  be  written  to  a  file  or  log  via  the
{ appropriate interfaces.  Each line begins with a space character to serve as
{ a "format effector" in the event the formatted message is written to a  list
{ file.
{
{   The  template  for  the status message is located by searching each object
{ library in the command list until a message module  containing  the  desired
{ template  is  found.   If  such  a  module is found but the module's natural
{ language is  not  the  one  currently  selected  for  the  job,  the  search
{ continues.   If  no template in the desired natural language is found, but a
{ template in the default natural language (US_English) was found, it is used.
{ If still no template has been picked, a "default template" is used which has
{ the effect of displaying the "raw" status record.
{
{       OSP$FORMAT_MESSAGE (MESSAGE_STATUS, MESSAGE_LEVEL, MAX_MESSAGE_LINE,
{         MESSAGE, STATUS)
{
{ MESSAGE_STATUS: (input) This parameter specifies the status to be formatted.
{       The condition field is used to locate a template for the message.  The
{       message is  then  formatted  under  control  of  this  template.   The
{       template  may  "request" information from the text field of the status
{       to be substituted into the formatted message.  To accomodate this, the
{       first  character  in  the  text  field  defines  the  status parameter
{       delimiter for the status record, i.e.  each sequence of characters  in
{       the text field that is preceded by the status parameter delimiter is a
{       separate status parameter that may be substituted into  the  formatted
{       message.
{
{ MESSAGE_LEVEL: (input) This parameter specifies the level for the message to
{       be formatted.
{
{ MAX_MESSAGE_LINE: (input) This parameter specifies  the  maximum  number  of
{       characters that can be placed in a line produced by this request.  The
{       message formatter will try to "break" long lines at a  delimiter;  but
{       if  this  cannot  be  done,  two dots will be placed at the end of the
{       "broken" line to mark its continuation.
{
{ MESSAGE: (output) This parameter specifies the container for  the  formatted
{       message.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{
*DECK DECK=OSH$FORMAT_MULTI_PART_MESSAGE EXPAND=FALSE
{
{   The purpose of this request is to format a message according to a template
{ for  that  message.   The  template  consists of message text and formatting
{ codes that direct the formatting process.  Parameters to be substituted into
{ the message are supplied  via  an  array of pointers to strings, each string
{ representing  a particular message parameter.  The formatting process may be
{ extended  by  supplying  a  procedure  that  retrieves another condition and
{ corresponding message parameters.
{
{   The    message    is   returned   in   a   sequence   which   contains   a
{ ost$status_message_line_count followed by that  many  message  lines.   Each
{ message line consists of a ost$status_message_line_size followed by a string
{ of that size.  These lines can be written to  a  file  via  the  appropriate
{ interfaces.   Each  line begins with a space character to serve as a "format
{ effector" in the event the formatted message is written to a list file.
{
{       OSP$FORMAT_MULT_PART_MESSAGE (MESSAGE_LEVEL, MESSAGE_HEADER_KIND,
{         MAX_MESSAGE_LINE, STATUS_CONDITION, MESSAGE_PARAMETERS,
{         GET_MESSAGE_PART, MESSAGE, STATUS)
{
{ MESSAGE_LEVEL: (input) This parameter specifies the level of message  to  be
{       formatted.
{
{ MESSAGE_HEADER_KIND: (input) This parameter specifies the form of the header
{       in the formatted message.  An OSC$STANDARD_STATUS_MESSAGE_HDR has  the
{       severity  in  upper  case  letters and is surrounded by dashes (if the
{       message_level is OSC$BRIEF_MESSAGE_LEVEL and  the  status_severity  is
{       OSC$INFORMATIVE_STATUS only dashes constitute the message header).  An
{       OSC$SUBDUED_STATUS_MESSAGE_HDR has the severity in lower  case  except
{       for  the  first  letter  and  is  terminated  with  a  colon  (if  the
{       status_severity  is  OSC$INFORMATIVE_STATUS  no  header is  included).
{       OSC$NO_STATUS_MESSAGE_HDR  suppresses  the  production  of  a  message
{       header.   Selecting  OSC$ERROR_STATUS_MESSAGE_HDR  is  like  selecting
{       OSC$STANDARD_STATUS_MESSAGE_HDR if status_severity is something  other
{       than  OSC$INFORMATIVE_STATUS  and  is  like  OSC$NO_STATUS_MESSAGE_HDR
{       otherwise.
{
{ MAX_MESSAGE_LINE:  (input)  This  parameter  specifies the maximum number of
{       characters that can be placed in a line produced by this request.  The
{       message  formatter  will try to "break" long lines at a delimiter; but
{       if this cannot be done, two dots will be placed  at  the  end  of  the
{       "broken" line to mark its continuation.
{
{ STATUS_CONDITION: (input) This parameter specifies the condition code of the
{       status whose message is to be formatted.
{
{ MESSAGE_PARAMETERS: (input) This parameter specifies the items of text to be
{       substituted  into  the message according to the parameter substitution
{       formatting codes in the message template.  If  NIL  is  specified  for
{       this  parameter,  all  message  parameters  are considered to be null.
{       If NIL is specified for any  particular  element  of  the  array,  the
{       corresponding message parameter is considered to be null.
{
{ GET_MESSAGE_PART:  (input) This parameter specifies a procedure to be called
{       to get an additional condition and corresponding  message  parameters.
{       Use of such a procedure allows the construction of  a  single  message
{       from  a  number  of  distinct templates.  In effect, the templates are
{       concatenated to form a single template; but the numbering  of  message
{       parameters  is  maintained  on  an  individual  template  basis.   The
{       procedure specified by this parameter is called  repeatedly  until  it
{       returns  FALSE for its end_of_message parameter. If FALSE is specified
{       for this parameter no additonal conditions and message parameters  are
{       used.
{
{ MESSAGE:  (output)  This parameter specifies the container for the formatted
{       message.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=OSH$FORMAT_SEGMENT_CONDITION EXPAND=FALSE
{
{     The purpose of this request is to format a specific segment access
{ condition into the standard message (status record) for that condition.
{
{       OSP$FORMAT_SEGMENT_CONDITION (IDENTIFIER, SEGMENT_ACCESS_CONDITION,
{         SAVE_AREA, MESSAGE, STATUS)
{
{ IDENTIFIER: (input) This parameter specifies the product identifier of the
{       requestor.
{
{ SEGMENT_ACCESS_CONDITION: (input) This parameter specifies the segment access
{       condition from which the message (status record) is to be formatted.
{
{ SAVE_AREA: (input) This parameter specifies the stack frame save area
{       associated with the condition.
{
{ MESSAGE: (output) This parameter specifies the formatted message (status
{       record).
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION: ose$unknown_segment_condition.
{       IDENTIFIER: 'OS'.
{
*DECK DECK=OSH$FORMAT_SYSTEM_CONDITION EXPAND=FALSE
{
{     The purpose of this request is to format a specific system condition
{ into the standard message (status record) for that condition.
{
{       OSP$FORMAT_SYSTEM_CONDITION (SYSTEM_CONDITION,
{         UNTRANSLATABLE_POINTER, SAVE_AREA, MESSAGE)
{
{ SYSTEM_CONDITION: (input) This parameter specifies the system condition from
{       which the message (status record) is to be formatted.
{
{ UNTRANSLATABLE_POINTER: (input) This parameter specifies the untranslatable
{       associated with the condition.
{
{ SAVE_AREA: (input) This parameter specifies the stack frame save area
{       associated with the condition.
{
{ MESSAGE: (output) This parameter specifies the formatted message (status
{       record).
{
*DECK DECK=OSH$FREE_HEAP_PAGES EXPAND=FALSE
{
{  The purpose of this procedure is to search through the free blocks in a heap,
{and free pages entirely contained within the blocks.
{  The heap descriptor for each block must remain in memory.  The first two
{words of each block contain the heap descriptor.  The heap descriptor will
{always begin on a (16 MOD 32) boundary.  This eliminates the need to
{specially consider end cases.
{  MMP$FREE_PAGES frees only pages entirely contained within the block.
{Therefore, the beginning pva or length of the block neednt be adjusted
{to page boundaries.
{
*DECK DECK=OSH$GENERATE_ERROR_MESSAGE EXPAND=FALSE
{
{   The purpose of this request is to  write  a  message  corresponding  to  a
{ status  to  the  clc$error_output  file.   The status message is produced in
{ osc$full_message_level independent of the job's osc$current_message_level.
{
{       OSP$GENERATE_ERROR_MESSAGE (MESSAGE_STATUS, STATUS)
{
{ MESSAGE_STATUS: (input) This parameter specifies the status to be  formatted
{       and written.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{
*DECK DECK=OSH$GENERATE_LOG_MESSAGE EXPAND=FALSE
{
{   The purpose of this request is to  write  a  message  corresponding  to  a
{ status  to the pmc$job_log and/or the pmc$system_log.  The status message is
{ produced   in    osc$full_message_level    independent    of    the    job's
{ osc$current_message_level.
{
{       OSP$GENERATE_LOG_MESSAGE (LOGS, MESSAGE_STATUS, STATUS)
{
{ LOGS:  (input)  This parameter specifies the logs to which the message is to
{       be written.  If the caller's ring is greater than  osc$tsrv_ring,  the
{       message will not be written to the system log.
{
{ MESSAGE_STATUS:  (input) This parameter specifies the status to be formatted
{       and written.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{
*DECK DECK=OSH$GENERATE_MESSAGE EXPAND=FALSE
{
{   The purpose of this request is to  write  a  message  corresponding  to  a
{ status to the job log and, for an interactive job, to the terminal.  This is
{ accomplished by writing the message to the clc$job_command_response file.
{
{       OSP$GENERATE_MESSAGE (MESSAGE_STATUS, STATUS)
{
{ MESSAGE_STATUS: (input) This parameter specifies the status to be  formatted
{       and written.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{
*DECK DECK=OSH$GENERATE_OUTPUT_MESSAGE EXPAND=FALSE
{
{   The purpose  of  this  request  is  to  write a message corresponding to a
{ status to the clc$job_output file.  The  status  message  is  produced  in
{ osc$brief_message_level independent of the job's osc$current_message_level.
{
{       OSP$GENERATE_OUTPUT_MESSAGE (MESSAGE_STATUS, STATUS)
{
{ MESSAGE_STATUS:  (input) This parameter specifies the status to be formatted
{       and written.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{       IDENTIFIER: 'CL'
{
*DECK DECK=OSH$GENERATE_UNIQUE_BINARY_NAME EXPAND=FALSE
{
{    The purpose of this procedure is to generate a unique binary name.
{
{        OSP$GENERATE_UNIQUE_BINARY_NAME (NAME, STATUS)
{
{ NAME: (output) This parameter is the generated unique name.
{
{ STATUS: (output) This parameter indicates the status of the request.
{   CONDITIONS:
{       none.
{
*DECK DECK=OSH$GET_ACCESSED_CLIENTS EXPAND=FALSE
{
{    The purpose of this request is to return a list of all the client
{ mainframes which have access to any family on the host (server) mainframe.
{
{       OSP$GET_ACCESSED_CLIENTS (P_BINARY_CLIENT_LIST, CLIENT_COUNT)
{
{ P_BINARY_CLIENT_LIST: (output) This parameter specifies an array of binary
{       mainframe IDs which can access a family on the host (server).
{
{ CLIENT_COUNT: (output) This parameter specifies the number of client
{       mainframes with access to one or more host families.
{
*DECK DECK=OSH$GET_ACCESSED_FAMILIES EXPAND=FALSE
{
{    The purpose of this request is to return a list of all the families
{ on the host mainframe which have any type of family access (except "NONE")
{ for any client mainframe.
{
{       OSP$GET_ACCESSED_FAMILIES (P_FAMILY_LIST, FAMILY_COUNT)
{
{ P_FAMILY_LIST: (output) This parameter specifies an array of names of
{       families which can be accessed by at least one client mainframe.
{
{ FAMILY_COUNT: (output) This parameter specifies the number of families
{       on the host mainframe whcih can be accessed. Note that this number
{       may be larger or smaller than the upper bound of p_family_list.
{
*DECK DECK=OSH$GET_CLIENT_FAMILY_ACCESS EXPAND=FALSE
{
{    The purpose of this request is to return the access allowed to a
{ certain family by a certain client mainframe.
{
{       OSP$GET_CLIENT_FAMILY_ACCESS (CLIENT_BINARY_ID, FAMILY_NAME,
{             FAMILY_ACCESS)
{
{ CLIENT_BINARY_ID: (input) This parameter specifies the binary ID of
{       the client mainframe.
{
{ FAMILY_NAME: (input) This parameter specifies the name of the family
{       which the client is to access.
{
{ FAMILY_ACCESS: (output) This parameter specifies the allowed access.
{
*DECK DECK=OSH$GET_DIAGNOSTIC_SEVERITY EXPAND=FALSE
{
{   The purpose of this request is to return the diagnostic severity level for
{ a  status condition.
{
{   The  libraries  in  the  command  list are searched until a message module
{ containing a description  for  the  condition  is  found  and  the  severity
{ contained  therein  is  returned.   If  the  condition  is  not found, error
{ severity is returned.
{
{       OSP$GET_DIAGNOSTIC_SEVERITY (CONDITION, SEVERITY, STATUS)
{
{ CONDITION: (input) This parameter specifies the condition code for which the
{       severity is to be returned.
{
{ SEVERITY: (output) This parameter specifies the diagnostic severity level.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{
*DECK DECK=OSH$GET_FAMILIES_FOR_CLIENT EXPAND=FALSE
{
{    The purpose of this request is to return the families which permit access
{ from a specified client mainframe and the access permitted by each family.
{
{       OSP$GET_FAMILIES_FOR_CLIENT (CLIENT_BINARY_ID, P_FAMILY_LIST,
{             P_ACCESS_LIST, FAMILY_COUNT)
{
{ CLIENT_BINARY_ID: (input) This parameter specifies the client mainframe
{       of interest.
{
{ P_FAMILY_LIST: (output) This parameter specifies the names of the families
{       which permit access from the specified client mainframe.
{
{ P_ACCESS_LIST: (output) This parameter specifies the access that the
{       corresponding entry in P_FAMILY_LIST will grant to the client.
{
{ FAMILY_COUNT: (output) This parameter specifies the total number of families
{       which permit access from the client.
*DECK DECK=OSH$GET_FULL_HELP_MESSAGE EXPAND=FALSE
{
{    The purpose of this request is to get the full help information for a
{ message within a help module.
{
{    The help message is returned in a sequence which contains an
{ ost$status_message_line_count followed by that many message lines.  Each
{ message line consists of an ost$status_message_line_size followed by a string
{ of that size.  These lines can be written to a file via the appropriate
{ interfaces.  Each line begins with a space character to serve as a "format
{ effector" in the event the formatted message is written to a list file.
{
{       OSP$GET_FULL_HELP_MESSAGE (SEED_NAME, MESSAGE_PARAMETERS,
{         MAX_MESSAGE_LINE, MESSAGE, STATUS)
{
{ SEED_NAME: (input) This parameter specifies the name that is to be suffixed
{       with a $ and the name of the natural language to form the name of the
{       help module which contains the template for the full help message.
{
{ MESSAGE_PARAMETERS: (input) This parameter specifies the items of text to be
{       substituted into the message according to the parameter substitution
{       formatting codes in the message template.  If NIL is specified for this
{       parameter, all message parameters are considered to be null.  If NIL is
{       specified for any particular element of the array, the corresponding
{       message parameter is considered to be null.
{
{ MAX_MESSAGE_LINE: (input) This parameter specifies the maximum number of
{       characters that can be placed in a line produced by this request.  The
{       message formatter will try to "break" long lines at a delimiter; but if
{       this cannot be done, two dots will be placed at the end of the "broken"
{       line to mark its continuation.
{
{ MESSAGE: (output) This parameter specifies the container for the formatted
{       help message.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=OSH$GET_HELP_MESSAGE EXPAND=FALSE
{
{    The purpose of this request is to get the formatted help message for a
{ parameter within a help module.  Parameters to be substituted into the
{ message are supplied via an array of pointers to string, each string
{ representing a particular message parameter.
{
{    The message is returned in a sequence which contains an
{ ost$status_message_line_count followed by that many message lines.  Each
{ message line consists of a ost$status_message_line_size followed by a string
{ of that size.  These lines can be written to a file via the appropriate
{ interfaces.  Each line begins with a space character to serve as a "format
{ effector" in the event the formatted message is written to a list file.
{
{       OSP$GET_HELP_MESSAGE (SEED_NAME, PARAMETER_NAME, MESSAGE_PARAMETERS,
{         MAX_MESSAGE_LINE, MESSAGE, STATUS)
{
{ SEED_NAME: (input) This parameter specifies the name that is to be suffixed
{       with a $ and the name of the natural language to form the name of the
{       help module which contains the message template for the parameter.
{
{ PARAMETER_NAME: (input) This parameter specifies the name of the parameter
{       whose help message is to be found.
{
{ MESSAGE_PARAMETERS: (input) This parameter specifies the items of text to be
{       substituted into the message according to the parameter substitution
{       formatting codes in the message template.  If NIL is specified for this
{       parameter, all message parameters are considered to be null.  If NIL is
{       specified for any particular element of the array, the corresponding
{       message parameter is considered to be null.
{
{ MAX_MESSAGE_LINE: (input) This parameter specifies the maximum number of
{       characters that can be placed in a line produced by this request.  The
{       message formatter will try to "break" long lines at a delimiter; but if
{       this cannot be done, two dots will be placed at the end of the "broken"
{       line to mark its continuation.
{
{ MESSAGE: (output) This parameter specifies the container for the formatted
{       message.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=OSH$GET_INTERACTION_INFORMATION EXPAND=FALSE
{
{   This request returns information describing the user's preferences for
{ interacting with the system and applications.  One or more of the following
{ items can be returned:
{
{       osc$interaction_style:  specifies osc$line_interaction,
{             osc$screen_interaction or osc$desktop_interaction
{
{       osc$menu_rows:  specifies the number of rows of function key menus that
{             a screen style application should show
{
{       osc$extend_utility_interaction:  specifies whether command utilities
{             that do not provide their own specific screen or desktop
{             interface should be run using a generic such interface
{
{   Applications that can support more than one interaction style should use
{ this request to determine the user's preference.  Applications that can
{ support a user choice of the number of menu rows should also use this request
{ to determine the user's preference.
{
{       OSP$GET_INTERACTION_INFORMATION (INTERACTION_INFORMATION, STATUS)
{
{ INTERACTION_INFORMATION: (input, output)  This parameter specifies the
{       requested interaction information.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: ose$unknown_interaction_item
{
*DECK DECK=OSH$GET_INTERACTION_STYLE EXPAND=FALSE
{
{   NOTE:
{     ***********************************************************************
{     ***********************************************************************
{     **** This program interface is obsolete.  Modules presently using *****
{     *** it should be changed to use OSP$GET_INTERACTION_INFORMATION.  *****
{     ***********************************************************************
{     ***********************************************************************
{
{   This request returns the preferred interaction style selected for an
{ interactive job.  Applications that can operate in more than one inter-
{ action style should use this request to determine the user's preference.
{
{       OSP$GET_INTERACTION_STYLE (INTERACTION_STYLE, STATUS)
{
{ INTERACTION_STYLE: (output)  This parameter specifies the prefered
{       interaction style.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=OSH$GET_LOCKED_VARIABLE_VALUE EXPAND=FALSE
{
{   The purpose of this request is to obtain the current value of a locked
{ variable.
{
{       OSP$GET_LOCKED_VARIABLE_VALUE (VARIABLE, EXPECTED_VALUE, ACTUAL_VALUE)
{
{ VARIABLE: (input, output)  This parameter specifies the locked variable to be
{       interrogated.
{
{ EXPECTED_VALUE: (input)  This parameter specifies the expected value of the
{       locked variable.
{
{ ACTUAL_VALUE: (output)  This parameter specifies the actual value of the
{       locked variable.
{
*DECK DECK=OSH$GET_MESSAGE_LEVEL EXPAND=FALSE
{
{   The purpose of this request is to get the message level currently  in  use
{ in the job.
{
{       OSP$GET_MESSAGE_LEVEL (MESSAGE_LEVEL, STATUS)
{
{ MESSAGE_LEVEL: (output)  This parameter specifies the current message level.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{
*DECK DECK=OSH$GET_NATURAL_LANGUAGE EXPAND=FALSE
{
{   The purpose of this request is to get the natural  language  currently  in
{ use in the job.
{
{       OSP$GET_NATURAL_LANGUAGE (NATURAL_LANGUAGE, STATUS)
{
{ NATURAL_LANGUAGE:  (output)  This  parameter  specifies  the current natural
{       language.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{
*DECK DECK=OSH$GET_PARAMETER_HELP_MESSAGE EXPAND=FALSE
{
{    The purpose of this request is to get the help information for a
{ parameter within a help module.
{
{    The help message is returned in a sequence which contains an
{ ost$status_message_line_count followed by that many message lines.  Each
{ message line consists of a ost$status_message_line_size followed by a string
{ of that size.  These lines can be written to a file via the appropriate
{ interfaces.  Each line begins with a space character to serve as a "format
{ effector" in the event the formatted message is written to a list file.
{
{       OSP$GET_PARAMETER_HELP_MESSAGE (SEED_NAME, PARAMETER_NAME,
{         MESSAGE_PARAMETERS, MAX_MESSAGE_LINE, MESSAGE, STATUS)
{
{ SEED_NAME: (input) This parameter specifies the name that is to be suffixed
{       with a $ and the name of the natural language to form the name of the
{       help module which contains the help message template for the parameter.
{
{ PARAMETER_NAME: (input) This parameter specifies the name of the parameter
{       whose help message is to be found.
{
{ MESSAGE_PARAMETERS: (input) This parameter specifies the items of text to be
{       substituted into the message according to the parameter substitution
{       formatting codes in the message template.  If NIL is specified for this
{       parameter, all message parameters are considered to be null.  If NIL is
{       specified for any particular element of the array, the corresponding
{       message parameter is considered to be null.
{
{ MAX_MESSAGE_LINE: (input) This parameter specifies the maximum number of
{       characters that can be placed in a line produced by this request.  The
{       message formatter will try to "break" long lines at a delimiter; but if
{       this cannot be done, two dots will be placed at the end of the "broken"
{       line to mark its continuation.
{
{ MESSAGE: (output) This parameter specifies the container for the formatted
{       help message.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=OSH$GET_PARAMETER_PROMPT EXPAND=FALSE
{
{    The purpose of this request is to get the formatted prompt message for a
{ parameter within a help module.  Parameters to be substituted into the
{ message are supplied via an array of pointers to string, each string
{ representing a particular message parameter.
{
{    The message is returned in a sequence which contains an
{ ost$status_message_line_count followed by that many message lines.  Each
{ message line consists of an ost$status_message_line_size followed by a string
{ of that size.  These lines can be written to a file via the appropriate
{ interfaces.  Each line begins with a space character to serve as a "format
{ effector" in the event the formatted message is written to a list file.
{
{       OSP$GET_PARAMETER_PROMPT (SEED_NAME, PARAMETER_NAME,
{         MESSAGE_PARAMETERS, MAX_MESSAGE_LINE, MESSAGE, STATUS)
{
{ SEED_NAME: (input) This parameter specifies the name that is to be suffixed
{       with a $ and the name of the natural language to form the name of the
{       help module which contains the message template for the parameter.
{
{ PARAMETER_NAME: (input) This parameter specifies the name of the parameter
{       whose prompt message is to be found.
{
{ MESSAGE_PARAMETERS: (input) This parameter specifies the items of text to be
{       substituted into the message according to the parameter substitution
{       formatting codes in the message template.  If NIL is specified for this
{       parameter, all message parameters are considered to be null.  If NIL is
{       specified for any particular element of the array, the corresponding
{       message parameter is considered to be null.
{
{ MAX_MESSAGE_LINE: (input) This parameter specifies the maximum number of
{       characters that can be placed in a line produced by this request.  The
{       message formatter will try to "break" long lines at a delimiter; but if
{       this cannot be done, two dots will be placed at the end of the "broken"
{       line to mark its continuation.
{
{ MESSAGE: (output) This parameter specifies the container for the formatted
{       prompt message.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{
*DECK DECK=OSH$GET_STATUS_CONDITION_CODE EXPAND=FALSE
{
{   The purpose of this request is to get the code  for  a  status  condition,
{ given its name.
{
{   The  libraries  in  the  command  list are searched until a message module
{ containing a description for the  condition  name  is  found  and  the  code
{ contained  therein is returned.  If the name is not found, a code of zero is
{ returned.
{
{       OSP$GET_STATUS_CONDITION_CODE (NAME, CODE, STATUS)
{
{ NAME: (input) This parameter specifies the name of the status condition.
{
{ CODE: (output) This parameter specifies the code for the status condition.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{
*DECK DECK=OSH$GET_STATUS_CONDITION_NAME EXPAND=FALSE
{
{   The purpose of this request is to get the name  for  a  status  condition,
{ given its code.
{
{   The  libraries  in  the  command  list are searched until a message module
{ containing a description for the  condition  code  is  found  and  the  name
{ contained  therein  is  returned.   If  the  code  is  not  found,  the name
{ UNKNOWN_CONDITION is returned.
{
{       OSP$GET_STATUS_CONDITION_NAME (CODE, NAME, STATUS)
{
{ CODE: (input) This parameter specifies the code for the status condition.
{
{ NAME: (output) This parameter specifies the name of the status condition.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{
*DECK DECK=OSH$GET_STATUS_CONDITION_STRING EXPAND=FALSE
{
{   The purpose of this request is to get  the  string  representation  for  a
{ status  condition,  given its code.  The returned string will be in the form
{ "XX n" where XX is the "product identifier" portion of  the  condition  code
{ and  n is the numeric portion.
{
{       OSP$GET_STATUS_CONDITION_STRING (CONDITION, STR, STATUS)
{
{ CONDITION:  (input)  This  parameter  specifies  the  code  for  the  status
{       condition.
{
{ STR:  (output)  This  parameter  specifies  the string representation of the
{       status condition.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{
*DECK DECK=OSH$GET_STATUS_MESSAGE_BY_CODE EXPAND=FALSE
{
{   The purpose of this request is to get the name, status severity,
{ diagnostic severity and message template for a status condition code.
{
{   The libraries in the command list are searched for a message module
{ containing the desired condition code.  If such a module is found but the
{ module's natural language is not the one currently selected for the job, the
{ search continues.  If no module in the desired natural language is found,
{ but a module in the default natural language (US_English) was found, it is
{ used.  If still no information for the condition code can be found, defaults
{ are returned (see the individual parameter descriptions, below).
{
{       OSP$GET_STATUS_MESSAGE_BY_CODE (CONDITION_CODE, CONDITION_NAME,
{         STATUS_SEVERITY, DIAGNOSTIC_SEVERITY, MESSAGE_TEMPLATE, STATUS)
{
{ CONDITION_CODE: (input)  This parameter specifies the condition code to be
{       searched for.
{
{ CONDITION_NAME: (output)  This parameter specifies the name of the
{       condition.  If the condition code could not be found, the name
{       'UNKNOWN_CONDITION' is returned.
{
{ STATUS_SEVERITY: (output)  This parameter specifies the status severity of
{       the condition.  If the condition code could not be found,
{       OSC$ERROR_STATUS is returned.
{
{ DIAGNOSTIC_SEVERITY: (output)  This parameter specifies the diagnostic
{       severity of the condition.  If the condition code could not be found,
{       OSC$ERROR_SEVERITY is returned.
{
{ MESSAGE_TEMPLATE: (output)  This parameter specifies the pointer to the
{       message template for the condition.  If the condition code could not
{       be found, NIL is returned.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{
*DECK DECK=OSH$GET_STATUS_SEVERITY EXPAND=FALSE
{
{   The purpose of this request is to return the status severity level for  a
{ status condition.
{
{   The  libraries  in  the  command  list are searched until a message module
{ containing a description  for  the  condition  is  found  and  the  severity
{ contained  therein  is  returned.   If  the  condition  is  not found, error
{ severity is returned.
{
{       OSP$GET_STATUS_SEVERITY (CONDITION, SEVERITY, STATUS)
{
{ CONDITION: (input) This parameter specifies the condition code for which the
{       severity is to be returned.
{
{ SEVERITY: (output) This parameter specifies the status severity level.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{
*DECK DECK=OSH$GET_UNIVERSAL_TASK_ID EXPAND=FALSE
{
{   The purpose of this request is to return the universal_task_id of a task in
{ which this call has been issued.
{
{       OSP$GET_UNIVERSAL_TASK_ID (UNIVERSAL_TASK_ID, STATUS)
{
{  UNIVERSAL_TASK_ID: (output)  This parameter returns the universal_task_id of
{        the the task.
{
{  STATUS: (output) This parameter specifies the request status.
{
{  CONDITIONS: none.
*DECK DECK=OSH$INITIALIZE_SIGNATURE_LOCK EXPAND=FALSE

{
{  The purpose of this procedure is to initialize a
{  signature lock.  This request is issued prior to the
{  OSP$SET_SIGNATURE_LOCK request unless the lock was
{  statically initialized.
{
{  An initialized lock has all fields of the lock set to ZERO.
{
{    OSP$INITIALIZE_SIGNATURE_LOCK (LOCK, STATUS)
{
{  LOCK: (OUTPUT) This parameter specifies the lock to
{                 be initialized.
{
{  STATUS: (OUTPUT) This parameter specifies the request status.
{
*DECK DECK=OSH$ISSUE_STRING_AS_KEYPOINT EXPAND=FALSE

{ OSH$ISSUE_STRING_AS_KEYPOINT
{
{ The purpose of this procedure is to place a
{user specified string into the keypoint collection
{file at the current position. The parameters for this
{procedure are:
{
{ DATA_STRING: (INPUT)    This parameter specifies a string
{                         (maximum 32 characters) which is to
{                         be placed into the keypoint file at
{                         the current position.
{
{ STATUS: (OUTPUT)        This parameter returns the status
{                         of the procedure.
*DECK DECK=OSH$I_AWAIT_ACTIVITY_COMPLETION EXPAND=FALSE
{    The purpose of this request is to wait for one or more events to occur.
{
{       OSP$I_AWAIT_ACTIVITY_COMPLETION (WAIT_LIST, READY_INDEX, STATUS);
{
{ WAIT_LIST: (input)  This is a list of events that the requesting process is
{       interested in.
{
{ READY_INDEX: (output)  This indicates the index in the wait list of the event
{       that occurred.  If status is abnormal the value of this parameter is
{       undefined.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{            none.
*DECK DECK=OSH$MONITOR_FAULT_TO_STATUS EXPAND=FALSE
{
{    The purpose of this request is to convert a monitor fault (from the
{ monitor fault buffer or a core condition handler) to a reasonable status
{ value.
{
{       OSP$MONITOR_FAULT_TO_STATUS (MONITOR_FAULT, MINIMUM_SAVE_AREA_P,
{             STATUS);
{
{ MONITOR_FAULT: (input)  This is the monitor fault that occured.
{
{ MINIMUM_SAVE_AREA_P: (input)  This is a pointer to the stack frame save area
{       that represents the procedure in which the fault occured.
{
{ STATUS: (output) This is the resultant status value from the monitor fault.
*DECK DECK=OSH$OUTPUT_STATUS_MESSAGE EXPAND=FALSE
{
{   The purpose  of  this  request  is  to  write a message corresponding to a
{ status to the specified file.  The  status  message  is  produced  in
{ osc$brief_message_level independent of the job's osc$current_message_level.
{
{       OSP$GENERATE_OUTPUT_MESSAGE (FILE_ID, MESSAGE_LEVEL, MESSAGE_HEADER_KIND,
{         MESSAGE_STATUS, STATUS)
{
{ FILE_ID: (input) This parameter specifies the file access
{       identifier established when the file was opened.
{
{ MESSAGE_LEVEL : (input) This parameter_specifies the level of the message to be
{       formatted.
{
{ MESSAGE_HEADER_KIND: (input) This parameter specifies the form of the header
{       in the formatted message.  An OSC$STANDARD_STATUS_MESSAGE_HDR has  the
{       severity  in  upper  case  letters and is surrounded by dashes (if the
{       message_level is OSC$BRIEF_MESSAGE_LEVEL and  the  status_severity  is
{       OSC$INFORMATIVE_STATUS only dashes constitute the message header).  An
{       OSC$SUBDUED_STATUS_MESSAGE_HDR has the severity in lower  case  except
{       for  the  first  letter  and  is  terminated  with  a  colon  (if  the
{       status_severity  is  OSC$INFORMATIVE_STATUS  no  header is  included).
{       OSC$NO_STATUS_MESSAGE_HDR  suppresses  the  production  of  a  message
{       header.   Selecting  OSC$ERROR_STATUS_MESSAGE_HDR  is  like  selecting
{       OSC$STANDARD_STATUS_MESSAGE_HDR if status_severity is something  other
{       than  OSC$INFORMATIVE_STATUS  and  is  like  OSC$NO_STATUS_MESSAGE_HDR
{       otherwise.
{
{ MESSAGE_STATUS:  (input) This parameter specifies the status to be formatted
{       and written.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: none
{       IDENTIFIER: 'CL'
{
*DECK DECK=OSH$PROCESS_NOS_170_REQUESTS EXPAND=FALSE
{
{  The purpose of this procedure is to process SYSTEM REQUESTS
{  issued by NOS170.  It validates the request code and calls
{  the corresponding request processor.
{
{    OSP$PROCESS_NOS_170_REQUESTS (XP_P)
{
{  XP_P: (INPUT) This parameter specifies the pointer to the NOS XP.
{
*DECK DECK=OSH$READY_UNIVERSAL_TASK EXPAND=FALSE
{
{
{   The purpose of this request is to make the task specified by the input
{ parameter a candidate for execution.  If the Universal_Task_ID indicates the
{ task resides on a different mainframe from the current one, the call is made
{ to the remote mainframe by the File Server.  The task indicated in the input
{ must be known otherwise the request returns an abnormal status.  This request
{ will only work for the Server mainframes that are directly connected.
{
{       OSP$READY_UNIVERSAL_TASK (UNIVERSAL_TASK_ID, STATUS)
{
{ UNIVERSAL_TASK_ID: (input)  This parameter specifies the task to be made
{       ready.
{
{ STATUS: (output) This parameter specifies the request status.
{
{       CONDITIONS: pme$unknown_recipient_task.
{                   dfe$mainframe_not_server
{                   dfe$server_has_terminated
{                   dfe$server_not_active
{
*DECK DECK=OSH$RECOVERABLE_SYSTEM_ERROR EXPAND=FALSE
{
{   The purpose of this procedure is to process recoverable system errors.  A
{ recoverable system error is a system error for which the integrity of the
{ system would be improved by allowing the procedure that detected the system
{ error to continue execution following the recording of the error.  The
{ caller p-register, input error message and input status message are recorded
{ in the system log to provide a record of the error for debugging purposes.
{ To facilitate system debugging, recoverable system errors invoke the
{ system core debugger when the error is detected at or below the system
{ debug ring. The system will be halted if the error is detected at or below
{ the haltring.
{
{       OSP$RECOVERABLE_SYSTEM_ERROR (ERROR_MESSAGE, P_STATUS)
{
{ ERROR_MESSAGE: (input) This parameter specifies a string that can be used to
{       help identify the nature of the system error.
{
{ P_STATUS: (input) This parameter is a pointer to a status variable that
{       further describes the nature of the system error.  This parameter
{       would typically be set to point to a status variable that returned
{       an unexpected value.  A NIL pointer is allowed for this parameter.
*DECK DECK=OSH$RELEASE_KEYPOINT_ENV EXPAND=FALSE

{ OSH$RELEASE_KEYPOINT_ENV
{
{  This procedure will terminate keypoint collection if it is still
{active.  If keypoint collection has already terminated, a status
{variable is returned defining the termination reason.  The parameters
{for this procedure are:
{
{ DATA_STRING: (INPUT)     This parameter specifies a string (maximum
{                          32 characters) to be placed into the keypoint
{                          file.
{
{ STATUS: (OUTPUT)         This parameter returns the status of the
{                          procedure.
*DECK DECK=OSH$RELEASE_SPI_ENVIRONMENT EXPAND=FALSE
{
{ Purpose:   The purpose of this procedure is to release the SPI
{            environment reservation and make it available for the
{            next user. The caller of this procedure must be the user
{            that origionally reserved the SPI environment.
{
{ Format:    OSP$RELEASE_SPI_ENVIRONMENT (VAR Status: ost$status);
{
{ Parameters: STATUS (OUTPUT): This parameter will return the status
{            for the procedure call.
{
*DECK DECK=OSH$RESERVE_KEYPOINT_ENV EXPAND=FALSE

{OSH$RESERVE_KEYPOINT_ENV
{
{  This procedure is responsible for reserving the keypoint collection
{  environment
{for a job. The parameters for this procedure are:
{
{ ENVIRONMENT: (INPUT)           This parameter specifies the environment in
{ which
{                                keypoints will be collected. The
{                                possibilities are
{                                job, system, system_sample, or job_sample. The
{                                default environment is job.
{
{ MONITOR_MASK: (INPUT)          This parameter specifies what class(es) of
{                                keypoints are to be collected during monitor
{                                mode execution.
{
{ JOB_MASK: (INPUT)              This parameter specifies what class(es) of
{                                keypoints are to be collected during job
{                                mode execution.
{
{ COLLECTION_FILE: (INPUT)       This parameter specifies a permanent file
{                                name for each processor on which keypoints
{                                are to be collected.
{
{ WAIT: (INPUT)                  This parameter specifies whether the command
{                                should wait indefinitely for the keypoint
{                                environment.
{
{ MULTI_PROC_OPTION: (INPUT)     This parameter specifies if the job should
{                                be configured to allow its tasks to run on
{                                one or all processors of a mainframe.
{
{ KEYPOINT_COUNT: (INPUT)        This parameter specifies the maximum number of
{                                keypoints to be collected.
{
{ KEYPOINT_BUFFER_SIZE: (INPUT)  This parameter specifies the maximum amount
{                                of keypoint buffer space to be allocated
{                                in real memory.
{
{ DATA_STRING: (INPUT)           This parameter specifies a string (maximum
{                                32 characters) to be placed into the
{                                keypoint file.
{
{ STATUS: (OUTPUT)               This parameter returns the status of the
{                                procedure.
*DECK DECK=OSH$RESERVE_SPI_ENVIRONMENT EXPAND=FALSE
{ Purpose: To reserve the SPI environment for the user job.
{
{ Format:  Osp$reserve_spi_environment (
{             spi_identifier: ost$spi_identifier;
{             collection_file: amt$local_file_name;
{             number_of_spi_samples: ost$number_of_spi_samples;
{             spi_sampling_interval: ost$spi_sampling_interval;
{             wait: ost$wait;
{             processor_id_set: ost$processor_id_set;
{             data_string: string(32);
{             VAR status: ost$status);
{
{ Parameters:
{
{      Spi_identifier: This parameter specifies the scope for the
{ collection routine. When the program instruction is sampled the
{ SPI identifier is examined. If the value of this parameter is
{ zero then all program samples will be recorded. If the value
{ specified is not zero then only the values equal to the parameter
{ will be recorded. In a multiprocessor system this inspection is
{ done for each processor that has been selected. The following spi
{ identifiers are reserved in the system.
{
{             50 IFEXEC
{             51 RHOUTPUT
{             52 RHINPUT
{             53 MLP$C170_MLI_HELPER
{             54 JMP$JOB_SCHEDULER
{             55 DMP$ADMINISTER_DEVICE_LOG
{             56 DMP$ADMINISTER_ALLOCATION_LOG
{             57 DMP$VOLUME_SPACE_MANAGEMENT
{             58 NAP$INITIALIZE_NETWORKS
{
{      Collection_file: This is the local file name for the file
{ that the SPI collector will write to. The file is opened and processed
{ in a seperate task with the job. The collection is done independently
{ from the rest of the job.
{
{      Number_of_spi_samples: This is the maximum number of SPI samples
{ that you want to collect for each processor. This number is only
{ approximate and will be rounded to the number of samples that
{ will fill full pages.
{
{    Spi_sampling_interval: This parameter specified the amount of time
{ between sampling intervals. The time specified is only an approximation
{ of the time requested. Accurate timing will not occur due to the
{ difference in timing of the processors and the possible interference
{ of system protocol with the processing of SPI data.
{
{     Wait: This parameter specifies if the procedure should wait
{ for the environment to become available. Normallly the environment
{ will not be set. In this case the routine will reserve the
{ environment but in a few cases the environment may already be set
{ by another user. If the value is osc$wait then the procedure will
{ wait for the environment to become available before returning to
{ the user. If on the other hand, the value of the wait parameter is
{ osc$no_wait then control will be return to the user and the
{ value of status will indicate that the environment was not
{ reserved.
{
{      Processor_id_set: This parameter is used to select the
{ processors that SPI will collect P address samples from. The null
{ will return an error code. The cpu does not check if the processor
{ element is on, off, or down. If the element is not on then there
{ will not be any data collection for that element.
{
{      Data_string: This parameter is a 32 charcater string that
{ is used to identify the run. This string is used in all reports
{ as part of the SPI header.
{
{      Status (OUTPUT): This parameter will contain the value of the
{ status for the routine. If normal then the value of status.normal
{ will be set to true else the value of the status.normal will be set
{ to false and the value of status.condition will contain the
{ error code.
{
*DECK DECK=OSH$RESET_HEAP EXPAND=FALSE


{
{   The purpose of this procedure is to reset or initialize heap information. The parameters
{to this procedure are:
{ XHP: (type: ^ost$heap)
{ HEAP_LENGTH: (type: integer)
{ LOCK_OPTION: (type: boolean)
{ ALGORITHM: (type: 0 .. 255)
{
{   A new field was added to the type ost$hp_heap. An integer field (range 0 ..
{255), algorithm eliminates the need to check for a NIL pointer on allocates in MP,
{W, MP, JF, JP, TS, and TP. If a full heap is encountered, a system_error is call
{ed.  The new field retains the value of the algorithm passed as a parameter
{into osp$reset_heap.
{
{ Algorithm definitions:
{  0: Run with traps enabled.  Used only by PF catalogs.  Return NIL on full.
{  1: Run with traps disabled.  Used by everybody else.  Call system error on full.
{     This is the default used by hpp$initialize
{  2: Run with traps disabled.  Used by networks.  Return NIL on full.
*DECK DECK=OSH$SET_CLIENT_ACCESS EXPAND=FALSE
{
{    The purpose of this request is to set the client access entries for
{ a particular family entry in the set/family table.
{
{       OSP$SET_CLIENT_ACCESS (FAMILY, FAMILY_ACCESS, ALL_CLIENTS,
{             P_BINARY_CLIENT_LIST, NUMBER_OF_CLIENTS, STATUS)
{
{ FAMILY: (input) This parameter specifies the name of the family of interest.
{
{ FAMILY_ACCESS: (input) This parameter specifies the family access to be
{       granted to the specified client mainframes.
{
{ ALL_CLIENTS: (input) This parameter specifies whether all clients are to
{       be granted the family access. If so, then the p_binary_client_list
{       is undefined.
{
{ P_BINARY_CLIENT_LIST: (input) This parameter specifies the binay IDs of the
{       clients to be granted the family access.
{
{ NUMBER_OF_CLIENTS: (input) This parameter specifies the number of valid
{       entries in P_BINARY_CLIENT_LIST. The value of this parameter is
{       undefined if ALL_CLIENTS = TRUE.
{
{ STATUS: (output) This parameter returns the request status.
{           CONDITION: pfe$unknown_family
{
*DECK DECK=OSH$SET_DESKTOP_INTERACTION EXPAND=FALSE
{
{   The purpose of this request is to set the job's interaction style
{ osc$desktop_interaction.  It is called automatically whenever a
{ task is initiated on behalf of Desktop/VE and may not be called
{ under any other circumstance.
{
{       OSP$SET_DESKTOP_INTERACTION (STATUS)
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=OSH$SET_MESSAGE_LEVEL EXPAND=FALSE
{
{   The purpose of this request is to set the message level for the job.
{
{       OSP$SET_MESSAGE_LEVEL (MESSAGE_LEVEL, STATUS)
{
{ MESSAGE_LEVEL: (output) This parameter specifies the new message level.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: ose$bad_message_level
{
*DECK DECK=OSH$SET_NATURAL_LANGUAGE EXPAND=FALSE
{
{   The purpose of this request is to set the natural language for the job.
{
{       OSP$SET_NATURAL_LANGUAGE (NATURAL_LANGUAGE, STATUS)
{
{ NATURAL_LANGUAGE:  (output)  This  parameter  specifies  the   new   natural
{       language.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: ose$bad_natural_language
{
*DECK DECK=OSH$SET_SIGNATURE_LOCK EXPAND=FALSE

{
{  The purpose of this procedure is to set a signature lock.
{  The global taskid of the current task is placed in the lock.  If
{  the lock is already set and a wait option has been specified
{  then this routine will CYCLE until the lock is free.  If the
{  lock is being set in the mainframe wired or mainframe paged
{  segment, the system lock count in the current task's XCB is
{  incremented.
{
{    OSP$SET_SIGNATURE_LOCK (LOCK, WAIT, STATUS)
{
{  LOCK: (OUTPUT) This parameter specifies the lock.
{
{  WAIT: (INPUT) This parameter specifies the wait or nowait option.
{
{  STATUS: (OUTPUT) This parameter specifies the error status.
{
*DECK DECK=OSH$SET_STATUS_ABNORMAL EXPAND=FALSE
{
{   The purpose of this request is to set  a  status  record  to  represent  a
{ message (usually describing some abnormal condition).
{
{   Additional    text    may    be   appended   to   the   status   via   the
{ osp$append_status_parameter,                      osp$append_status_integer,
{ osp$append_status_file, etc.  interfaces.
{
{   These  requests  provide  a basic capability for editing status parameters
{ into the status record's text field (e.g.  the removal  of  trailing  spaces
{ from the status parameters).
{
{   The  condition  code for the status may be specified as a single number or
{ via its "component parts", i.e.  the two character "product identifier"  and
{ the  "condition  number".  If the value given for the condition parameter is
{ within the bounds of a ost$status_condition_number, the identifier parameter
{ is  combined  with  it  to  form  the  condition  code in the status record;
{ otherwise the  condition  parameter  is  assumed  to  represent  the  entire
{ condition code and the identifier parameter is ignored.
{
{       OSP$SET_STATUS_ABNORMAL (IDENTIFIER, CONDITION, TEXT, STATUS)
{
{ IDENTIFIER:  (input) This parameter specifies the product identifier for the
{       condition.
{
{ CONDITION: (input) This parameter specifies the condition code (or condition
{       number) for the condition (see above).
{
{ TEXT: (input) This parameter specifies the first status parameter.  The text
{       field's size is initially set to zero (no text).  If this parameter is
{       not     the     null     string     (string     length    not    zero)
{       osp$append_status_parameter is called to add the parameter to the text
{       field  with  a  delimiter of osc$status_parameter_delimiter; otherwise
{       the text field is left empty.
{
{ STATUS: (output) This paraeter specifies the status record to be set.
{
*DECK DECK=OSH$SET_STATUS_CONDITION EXPAND=FALSE
{
{    The purpose of this request is to set a status variable to abnormal and
{ initialize the condition field to the specified condition.  The size of the
{ text field is set to zero.
{
{       OSP$SET_STATUS_CONDITION (CONDITION, STATUS);
{
{ CONDITION: (input)  This is the error status condition code.
{
{ STATUS: (output) This is the resultant abnormal status.
*DECK DECK=OSH$SET_STATUS_FROM_CONDITION EXPAND=FALSE
{
{   The purpose of this request is to construct an abnormal status record from
{ the information presented to a pmt$condition_handler procedure.  Attempts to
{ construct a status record for  condition  selectors  pmc$all_conditions  and
{ pmc$condition_combination are in error.
{
{       OSP$SET_STATUS_FROM_CONDITION (IDENTIFIER, CONDITION, SAVE_AREA,
{         CONDITION_STATUS, STATUS)
{
{ IDENTIFIER:  (input)  This  parameter  is  accepted  for  compatibility with
{       previous system versions but is ignored.
{
{ CONDITION: (input) This parameter specifies the  condition  from  which  the
{       status record is to be constructed.
{
{ SAVE_AREA:  (input)  This  parameter  specifies  the  stack  frame save area
{       associated with the condition.
{
{ CONDITION_STATUS: (output) This parameter specifies the  constructed  status
{       record.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION: ose$invalid_condition_selector, ose$empty_system_condition,
{             ose$empty_block_exit_reason, ose$unknown_segment_condition,
{             ose$invalid_save_area, ose$unknown_interactive_cond
{
*DECK DECK=OSH$START_KEYPOINT_COLLECTION EXPAND=FALSE

{ OSH$START_KEYPOINT_COLLECTION
{
{  This procedure will cause keypoint collection
{to begin. All tasks affected by the reserve_keypoint_
{environment will have keypoint data collected for
{them. The parameters for this procedure are:
{
{ DATA_STRING: (INPUT)    This parameter specifies a
{                         string (maximum 32 characters)
{                         to be placed into the keypoint
{                         collection file at the current
{                         point in the collection.
{
{ STATUS: (OUTPUT)        This parameter returns the status
{                         of the procedure.
*DECK DECK=OSH$START_SPI_COLLECTION EXPAND=FALSE
{
{ Purpose:  The purpose of this procedure is to activate the
{           collection of SPI data. The SPI environment must be
{           reserved prior to the issuance of this procedure.
{           The call to this procedure must be in the same task
{           as the procedure that called to reserve the SPI
{           environment.
{
{ Format:  OSP$START_SPI_COLLECTION
{             VAR STATUS: ost$status);
{
{ Parameters:
{
{       Status: This parameter will return the status for the
{            procedure call.
{
*DECK DECK=OSH$STATUS_CONDITION_CODE EXPAND=FALSE
{
{   This function returns a status condition code formed by combining the
{ specified status identifier and status number.
{
{       OSP$STATUS_CONDITION_CODE (IDENTIFIER, NUMBER): CONDITION
{
{ IDENTIFIER: (input)  This parameter specifies the status identifier.
{
{ NUMBER: (input)  This parameter specifies the status number.
{
{ CONDITION: (result)  The function's result specifies the status condition.
{
*DECK DECK=OSH$STATUS_CONDITION_NUMBER EXPAND=FALSE
{
{   This function returns the number component of a status condition code.
{
{       OSP$STATUS_CONDITION_NUMBER (CONDITION): NUMBER
{
{ CONDITION: (input)  This parameter specifies the status condition.
{
{ NUMBER: (result)  The function's result specifies the status number.
{
*DECK DECK=OSH$STOP_KEYPOINT_COLLECTION EXPAND=FALSE

{ OSH$STOP_KEYPOINT_COLLECTION
{
{  The purpose of this procedure is to stop keypoint collection for
{all tasks affected by the reserve_keypoint_environment command.
{Collection may be resumed using the start_keypoint_collection
{command. The parameters for this procedure are:
{
{ DATA_STRING: (INPUT)    This parameter specifies  a string (maximum
{                         32 characters) which is to be placed into the
{                         keypoint file at the current position.
{
{ STATUS: (OUTPUT)        This parameter returns the status of
{                         the procedure.
*DECK DECK=OSH$STOP_SPI_COLLECTION EXPAND=FALSE
{
{ Purpose:   The purpose of this procedure is to stop the
{            collection of SPI data. The SPI environment must be
{            reserved by the calling task and the collection of
{            SPI data must have started prior to the call to this
{            procedure. The collection of the data may have stopped
{            prior to the call to this procedure. This could be from
{            either a system error or the number of samples collected
{            has been reached.
{
{ Format:    OSP$STOP_SPI_COLLECTION (VAR status: ost$status);
{
{ Parameters: Status: (OUTPUT) This parameter returns to the caller
{             the value of the status from the procedure. The value of
{             status.normal = TRUE will indicate that the procedure
{             terminated normally.
{
*DECK DECK=OSH$STORE_SYSTEM_CONSTANT EXPAND=FALSE
{
{ This procedure is used to change the value of a system attribute.
{ Use of this interface requires special privilege.
{
{     OSP$STORE_SYSTEM_CONSTANT (NAME, INDEX, VALUE, STATUS)
{
{  NAME: {INPUT} This parameter specifies the name of the attribute.
{  INDEX: This parameter is reserved for internal use and should be
{         set to zero.
{  VALUE: {INPUT} This parameter contains the value of the attribute
{
*DECK DECK=OSH$SYSTEM_ERROR EXPAND=FALSE
.   The purpose of this procedure is to notify the system operator of
. a catastrophic error has occurred in the system. There is no
. point in passing the problem back up the caller-callee chain. All
. that can be done is notify the operator and stop.
.
.     OSP$SYSTEM_ERROR (ERROR_MESSAGE, STATUS)
.
. ERROR_MESSAGE: (input) This parameter specifies the error message
.     to be displayed. This parameter has been provided to indicate
.     the system area that failed without changing the status variable.
.
. STATUS: (input) This parameter specifies the status of the caller.
.     It is assumed to be abnormal and is not changed by this procedure.
.
. REGISTERS: (output) A14 - caller's P address.
.                     A15 - address of STATUS variable.
.
.                     X12 - current setting for STATUS.CONDITION
.            X13,X14,X15 - FIRST 24 bytes of ERROR_MESSAGE
.
*DECK DECK=OSH$TEST_SIGNATURE_LOCK EXPAND=FALSE

{
{  The purpose of this procedure is to test the signature
{  lock to see if it is unlocked, locked by current task
{  or locked by an alternate task.
{
{    OSP$TEST_SIGNATURE_LOCK (LOCK, LOCK_STATUS, STATUS)
{
{  LOCK: (INPUT) This parameter specifies the lock.
{
{  LOCK_STATUS: (OUTPUT) This parameter specifies the status
{                        of the lock.
{
{  STATUS: (OUTPUT) This parameter specifies the error status.
{
*DECK DECK=OSH$UNPACK_STATUS_CONDITION EXPAND=FALSE
{
{   This procedure returns the identifier and number components of
{ a status condition code.
{
{       OSP$UNPACK_STATUS_CONDITION (CONDITION, IDENTIFIER, NUMBER);
{
{ CONDITION: (input)  This parameter specifies the status condition.
{
{ IDENTIFIER: (output)  This parameter specifies the status identifier.
{
{ NUMBER: (output)  This parameter specifies the status number.
{
*DECK DECK=OSH$UNPACK_STATUS_IDENTIFIER EXPAND=FALSE
{
{   This procedure returns the identifier component of a status condition
{ code.
{
{       OSP$UNPACK_STATUS_IDENTIFIER (CONDITION, IDENTIFIER)
{
{ CONDITION: (input)  This parameter specifies the status condition.
{
{ IDENTIFIER: (output)  This parameter specifies the status identifier.
{
*DECK DECK=OSH$UNSTEP_RESUME_FLAG_HANDLER EXPAND=FALSE
{
{ The purpose of this procedure is to handle the UNSTEP/RESUME flag raised in monitor
{ when the system has restarted due to an unstep or a resume.  It logs a message to the
{ job_log and then causes the task to acknowledge the UNSTEP/RESUME condition.
{
{        OSP$UNSTEP_RESUME_FLAG_HANDLER (FLAG_ID);
{
{  FLAG_ID: (input) This parameter specifies the system flag that was set.
{
*DECK DECK=OSH$VERIFY_HEAP EXPAND=FALSE
{
{ This procedure will scan an OS heap and verify the heap linkage. If all linkage
{ is correct, the procedure will return a TRUE value for the parameter <OK>. If heap
{ linkage is bad, then either of the following may occur:
{       - a value of FALSE is returned for <OK>.
{       - a segment access condition or MCR fault will occur. In this case, the CALLERS
{         condition handler is invoked, ie. this procedure does NOT have a condition
{         handler.
{
{   OSP$VERIFY_HEAP (HEAP_P, OK)
{
{  HEAP_P: (input) This parameter specifies the heap to be verified.
{  OK:     (output) This parameter specifies whether the heap linkage is OK.
{
*DECK DECK=OSHRSER EXPAND=FALSE
{
{  This request is used by OSP$SYSTEM_ERROR to tell monitor that a
{  fatal system error occurred.
{
{  TYPE
{    OST$RB_SYSTEM_ERROR = RECORD
{      REQCODE,
{      FATAL,
{      STATUS,
{      CALLER_P_REGISTER,
{      STATUS_P,
{      TEXT_P,
{      CONDITION,
{      TEXT,
{    RECEND;
{
{  REQCODE: (input) The value of this parameter is SYC$RC_SYSTEM_ERROR.
{
{  FATAL: (input) This parameter specifies whether or not to halt the
{      system.
{
{  STATUS: (output) This specifies standard monitor status.
{
{  CALLER_P_REGISTER: (input) This parameter specifies the P register
{      where the problem occurred.
{
{  STATUS_P: (input)  This parameter specifies a pointer to a status
{      variable of possible importance to the error.
{
{  TEXT_P: (input) This parameter specifies a pointer to a text message
{      related to the failure.
{
{  CONDITION: (input) This parameter specifies the condition code found
{      in the status variable.
{
{  TEXT: (input) This parameter specifies the actual error message related
{      to the failure.
*DECK DECK=OSI$ASCII6_FOLDED EXPAND=FALSE
      [rep 33 of 0,
       1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13,
      14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26,
      27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39,
      40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52,
      53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 32, 33,
      34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46,
      47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59,
      60, 61, 62, rep 129 of 0]
*DECK DECK=OSI$ASCII6_STRICT EXPAND=FALSE
      [rep 33 of 0,
       1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13,
      14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26,
      27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39,
      40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52,
      53, 54, 55, 56, 57, 58, 59, 60, 61, 62, rep 161 of 0]
*DECK DECK=OSI$C170_CMU_EMULATION EXPAND=FALSE
         PAGE
.*******************************************************************
.
.        osi$c170_cmu_emulation
.
.******************************************************************
.
.
.        ADDRESS REGISTER ASSIGNMENTS
.
.        a_psa  = PVA OF TRAPPED STACK FRAME SAVE AREA
.        a_wrk = PVA OF EI DATA AREA
.        a_rac = RA OF JOB IN SFSA.
.        a_nos = PVA OF OPERATING SYSTEM
         PAGE
...
.        AOR        - ADDRESS OUT OF RANGE.
.
.        THIS SUBROUTINE IS CALLED WHEN ONE OR  MORE  CMU  INSTRUCTION
.        PARAMETERS  ARE  OUT-OF-RANGE.   THE EXIT MODE SELECTION BITS
.        ARE INTERROGATED TO DETERMINE WHETHER THE AOR  CONDITION  HAS
.        BEEN  SELECTED BY THE USER.  IF NOT, A BRANCH IS MADE BACK TO
.        THE TRAP INTERRUPT PROCESSOR AT TAG trap3 WHERE A  RETURN  TO
.        THE  USER  IS  MADE.   IF THE AOR CONDITION IS SELECTED, THIS
.        SUBROUTINE  SETS  A  REQUEST  CODE  INTO  X0,  THE  AOR  EXIT
.        CONDITION IN X2, AND EXECUTES A C180 EXCHANGE  TO  THE  ERROR
.        INTERFACE.   THE  ERROR  INTERFACE  WILL THEN SIMULATE A C170
.        ERROR EXCHANGE.
.
.        ENTRY-     (a_psa) = PVA OF TRAPPED PROCESS STACK FRAME SAVE AREA.
.
.        EXIT-      IF AOR NOT SELECTED, NONE.
.
.                   IF AOR SELECTED, (X0) =1, (X2) = 1.
.
.
AOR1     LX        X0,a_psa,xp_cx0     .RESTORE X0=C170 X0
AOR      LBYTS,2   X1,a_psa,X0,xp_em   .GET EXIT MODE SELECTION BITS
         SHFC      X1,X1,X0,63         .POSITION AOR SELECTION BIT
         BRXGE     X1,X0,trap3         .IF AOR NOT SELECTED
         EIMTRCAL  EIRQC,1             .ABORT JOB WITH MODE 1
         PAGE
...
.        IIP        - ILLEGAL INSTRUCTION PROCESSOR.
.
.        THIS SUBROUTINE GAINS CONTROL WHEN  A  CMU  INSTRUCTION  TRAP
.        OCCURS  BUT  THE INSTRUCTION DOES NOT OCCUR ON A WORD BOUNDRY
.        OR WHEN THE OPERATION CODE IS NOT CORRECT.   THIS  SUBROUTINE
.        SETS  A  REQUEST  CODE  IN  X0,  THE ILLEGAL INSTRUCTION EXIT
.        CONDITION IN X2, AND EXECUTES A C180 EXCHANGE  TO  THE  ERROR
.        INTERFACE.   THE  ERROR  INTERFACE  WILL THEN SIMULATE A C170
.        ERROR EXCHANGE.
.
.        ENTRY-     NONE.
.
.        EXIT-      (X0) = 1.
.                   (X2) = 0.
.
.
IIP      BSS       0
         EIMTRCAL  EIRQC,0             .ABORT JOB WITH MODE 0
         PAGE
...
.        PII        - PROCESS INSTRUCTION INTERRUPT.
.
.        THIS SUBROUTINE IS CALLED WHEN A C170 PPU EXCHANGE  INTERRUPT
.        MUST  BE  HONORED DURING THE SIMULATION OF A CMU INSTRUCTION.
.        PII SAVES THE POSITION OF  THE  SIMULATION  IN  THE  C170  X0
.        REGISTER  AND  RETURNS TO THE TRAP INTERRUPT PROCESSOR AT TAG
.        trap5.  WHEN THE INSTRUCTION IS SUBSEQUENTLY RE-EXECUTED  THE
.        SIMULATION WILL BE RESUMED AT THE POINT OF INTERRUPTION.
.
.        ENTRY-     (a_psa) = PVA OF TRAPPED PROCESS STACK FRAME SAVE AREA.
.                   (X1) = FIELD 1 NEXT BIT POSITION.
.                   (X7) = FIELD 1  RELATIVE WORD OFFSET.
.                   (X8) = FIELD 2 RELATIVE WORD OFFSET.
.
.        EXIT-      (       9) = FIELD 1 RELATIVE WORD OFFSET.
.                   (X0,50-53) = NEXT RELATIVE CHARACTER POSITION IN
.                                FIELD 1 RELATIVE WORD.
.                   (X0,54,63) = FIELD 2 RELATIVE WORD OFFSET.
.
.
PII      ENTP      X0,6
         DIVR      X1,X0               .C1 FOR RE-ENTRY
         ENTP      X2,10
         BRRNE     X1,X2,PII01         .IF NOT CHARACTER 10
         ENTP      X1,0                .C1 IS CHARACTER
         INCR      X7,1                .ADJUST FIELD 1 TO NEXT WORD
PII01    SHFX      X1,X1,X0,10         .C1 TO BITS 50 - 53
         SHFX      X7,X7,X0,14         .FIELD 1 OFFSET TO BITS 40 - 49
         IORX      X8,X1               .FIELD 2 OFFSET TO BITS 54 - 63
         IORX      X8,X7               .COMBINE EVERYTHING
         SX        X8,a_psa,xp_cx0     .STORE C170 X0 REGISTER
PII02    ENTP      X1,1
         ENTL      X0,BSCIF
         SBIT      X1,a_psa,xp_em+1,x0 .SET CMU INTERRUPTED FLAG
         BRREQ     X0,X0,trap5         .RETURN
         PAGE
...
.        CIS        - CMU INSTRUCTION SIMULATOR.
.
.        THIS  ROUTINE  SIMULATES THE EXECUTION OF CYBER 170 COMPARE /
.        MOVE INSTRUCTIONS.  CONTROL IS PASSED TO CIS  FROM  THE  TRAP
.        INTERRUPT  PROCESSOR  WHEN AN UNIMPLEMENETED INSTRUCTION TRAP
.        FROM C170 STATE OCCURS.  THIS ROUTINE AQUIRES THE P  REGISTER
.        OF  THE  TRAPPED  C170  PROCESS  AND ASSURES THAT THE TRAPPED
.        INSTRUCTION IS A CMU INSTRUCTION AND THAT IT OCCURS ON A C170
.        WORD BOUNDRY.  IF THE INSTRUCTION IS  AN  INDIRECT  MOVE  THE
.        ADDRESS  OF  THE DESCRIPTOR WORD IS CHECKED TO ASSURE THAT IT
.        IS IN RANGE AND THE DESCRIPTOR IS AQUIRED FROM THE C170  USER
.        FIELD  LENGTH.   OTHERWISE  THE DESCRIPTOR IS INCLUDED IN THE
.        INSTRUCTION WORD.  THE LENGTH DESCRIPTOR IS THEN ISOLATED AND
.        TESTED FOR A ZERO VALUE.  IF LENGTH IS ZERO, THE  INSTRUCTION
.        IS  A  NO-OP  AND  AN IMMEDIATE RETURN TO CALLER IS MADE.  IF
.        CHARACTER POSITIONS C1 OR C2 ARE GREATER THAN 9 OR IF  EITHER
.        FIELD  EXCEEDS  THE USER FIELD LENGTH AN ADDRESS-OUT-OF-RANGE
.        EXIT IS MADE.  IF THE INSTRUCTION IS A COLLATED  COMPARE  THE
.        COLLATING TABLE ADDRESS IS VERIFIED AS IN-RANGE.
.
.
.        IT  IS  THEN  DETERMINED  IF  THIS INSTRUCTION WAS PREVIOUSLY
.        INTERRUPTED AND IF SO THE PARAMETERS SAVED IN THE  C170  USER
.        X0 REGISTER AT THE TIME THE INTERRUPT WAS HONORED ARE USED AS
.        INPUT  PARAMETERS  TO  THE  PARTICULAR  INSTRUCTION SIMULATOR
.        SUBROUTINE.  IF THE  INSTRUCTION  WAS  NOT  PREVIOUSLY  BEING
.        SIMULATED THE INPUT PARAMETERS ARE THOSE FROM THE INSTRUCTION
.        DESCRIPTOR FIELD.
.
.        ANY RANGE ERRORS NOTED WILL CAUSE A BRANCH TO THE ROUTINE AOR
.        FOR  PROCESSING BASED ON THE USER EXIT MODE SELECTIONS.  IF A
.        CMU  INSTRUCTION  IS  NOT  ON  A  WORD  BOUNDRY  OR  IF   THE
.        INSTRUCTION  IS  NOT  RECOGNIZED AS A CMU OP-CODE A BRANCH IS
.        MADE TO IIP TO BE PROCESSED AS AN ILLEGAL INSTRUCTION.
.
.        IF  NO  ERRORS  ARE  ENCOUNTERED  THE  SIMULATION  SUBROUTINE
.        APPROPRIATE TO THE INSTRUCTION TYPE IS GIVEN  CONTROL.   WHEN
.        CONTROL  IS  RETURNED TO THIS ROUTINE AFTER THE SIMULATION IS
.        COMPLETE THE RETURN PARAMETER FROM THE SIMULATION  SUBROUTINE
.        IS  TRANSFERRED INTO THE C170 USER X0 REGISTER.  THIS ROUTINE
.        THEN RETURNS TO THE TRAP INTERRUPT PROCESSOR.
.
.        ENTRY-     (a_psa) = PVA OF TRAPPED PROCESS STACK FRAME SAVE AREA.
.                   (a_nos) = C170 SEGMENT PVA.
.                   (a_rac) = C170 job pva.
.                   (x_flc) = C170 USER FIELD LENGTH.
.
.        EXIT-      NONE.
.
.
CIS      lbyts,6   x1,a_psa,x0,xp_p    .PVA of trapped instruction
         ISOB      X2,X1,X0,7502(8)    .ISOLATE PARCEL DESCRIPTORS
         BRRNE     X2,X0,IIP           .IF NOT ON WORD BOUNDRY
         CPYXA     a9,X1
         LX        X1,a9,0             .GET TRAPPED INSTRUCTION
         ISOB      XC,X1,X0,0410(8)    .ISOLATE OPCODE
         ENTE      X3,464(8)
         SUBR      XC,X3               .INSTRUCTION TYPE
         ENTP      X3,3
         BRRGT     X0,XC,IIP           .IF NOT CMU INSTRUCTION
         BRRGT     XC,X3,IIP           .IF NOT CMU INSTRUCTION
         ENTE      X3,1502(8)
         BRRGT     XC,X0,CIS01         .IF NOT INDIRECT MOVE
         ISOB      X3,X1,X0,1502(8)    .B REGISTER DESIGNATOR
         ISOB      X4,X1,X0,2021(8)    .K FIELD FROM INSTRUCTION
         ISOM      XD,X0,5621(8)
         LXI       X3,a_psa,X3,xp_cb0/8*8 .B REGISTER CONTENTS
         ANDX      X3,XD
         SHFX      XE,X4,X0,-17
         SHFX      xa,X3,X0,-17
         ADDR      X4,XE               .FORM 2-S COMPLEMENT NUMBER
         ADDR      X3,xa
         ADDR      X3,X4
         ANDX      X3,XD               .TRIM ANY CARRY
         BRRGE     X3,x_flc,AOR        .IF DESCRIPTOR ADDRESS ERROR
         LXI       X1,a_rac,X3,0       .INDIRECT MOVE DESCRIPTOR WORD
         ENTE      X3,0710(8)
CIS01    ISOB      X3,X1,X3,0          .GET LU FIELD
         ISOB      XD,X1,X0,4203(8)    .GET LL FIELD
         SHFX      X3,X3,X0,4
         ADDR      XD,X3               .CHARACTER FIELD LENGTH L
         ISOB      XE,X1,X0,4603(8)    .FIELD 1 CHARACTER POSITION C1
         ISOB      xa,X1,X0,5203(8)    .FIELD 2 CHARACTER POSITION C2
         ENTP      X3,9
         ENTL      X0,0
         BRREQ     XD,X0,trap3         .IF L = 0, PASS
         BRRGT     XE,X3,AOR           .IF C1 LENGTH ERROR
         BRRGT     xa,X3,AOR           .IF C2 LENGTH ERROR
         ENTP      X3,10
         ADDRQ     X4,XE,9
         ADDR      X4,XD
         DIVR      X4,X3               .N1 = (C1+L+9)/10
         ADDRQ     X5,xa,9
         ADDR      X5,XD
         DIVR      X5,X3               .N2 = (C2+L+9)/10
         ISOB      X2,X1,X0,2021(8)    .FIELD 1 RELATIVE ADDRESS
         ISOB      X3,X1,X0,5621(8)    .FIELD 2 RELATIVE ADDRESS
         ADDR      X4,X2
         ADDR      X5,X3
         brrgt     X4,x_flc,AOR        .IF FIELD 1 ADDRESS ERROR
         brrgt     X5,x_flc,AOR        .IF FIELD 2 ADDRESS ERROR
         SHFX      X2,X2,X0,3          .FIELD 1 BYTE ADDRESS
         SHFX      X3,X3,X0,3          .FIELD 2 BYTE ADDRESS
         CPYAA     AA,a_rac
         CPYAA     AB,a_rac
         ADDAX     AA,X2               .PVA OF FIELD 1
         ADDAX     AB,X3               .PVA OF FIELD 2
         ENTP      X3,2
         BRRNE     XC,X3,CIS02         .IF NOT COLLATED COMPARE
         lbyts,3   x9,a_psa,x0,xp_ca0
         DECR      x_flc,8
         BRRGT     X9,x_flc,AOR        .IF COLLATING TABLE OUT-OF-RANGE
         CPYAA     a8,a_rac
         SHFX      X9,X9,X0,3
         ADDAX     a8,X9               .PVA OF COLLATING TABLE
CIS02    ENTL      X0,BSCIF
         cpyxx     xf,xa
         LBIT      XB,a_psa,xp_em+1,x0 .GET CMU INTERRUPTED FLAG
         BRREQ     XB,X0,CIS03         .IF NOT INSTRUCTION RESUME
         ENTP      XF,0                .C2 = 0
         SBIT      XF,a_psa,xp_em+1,x0 .CLEAR CIF
         CPYRR     X2,XE               .SAVE C1
         ISOB      XE,X8,X0,6203(8)    .C1 = P1
         ISOB      X7,X8,X0,5011(8)    .CURRENT FIELD 1 WORD = W1
         ISOB      X8,X8,X0,6611(8)    .CURRENT FIELD 2 WORD = W2
         MULRQ     X1,X7,10
         ADDR      X1,XE
         SUBR      X1,X2
         SUBR      XD,X1               .NUMBER OF CHARACTERS LEFT
         BRREQ     X0,X0,CIS04
.
CIS03    ENTP      X7,0
         ENTP      X8,0
CIS04    ENTP      X1,2
         BRRGE     XC,X1,SCI           .IF COMPARE INSTRUCTION
         BRREQ     X0,X0,SMI           .IF MOVE INSTRUCTION
         PAGE
...
.        SMI        - SIMULATE MOVE INSTRUCTION.
.
.        THIS SUBROUTINE SIMULATES THE EXECUTION OF THE CYBER 170  CMU
.        MOVE  INSTRUCTIONS DM AND IM.  THE MOVE PROCEEDS FROM LEFT TO
.        RIGHT  MOVING  CHARACTERS  FROM  THE  SOURCE  FIELD  TO   THE
.        DESTINATION  FIELD.   EACH TIME A BLOCK OF 260 CHARACTERS HAS
.        BEEN MOVED THIS SUBROUTINE WILL TEST THE CONDITION OF BIT  05
.        OF  THE  MONITOR  CONDITION REGISTER.  IF SET, THIS INDICATES
.        THAT A PPU HAS EXECUTED A CYBER 170 PPU EXCHANGE INSTRUCTION.
.        IN THIS CASE THE THE CPU MUST BE RELINQUISHED  TO  THE  CYBER
.        170  STATE ENVIRONMENT SO SMI EXITS TO ROUTINE PII.  WHEN THE
.        INSTRUCTION IS SUBSEQUENTLY RE-EXECUTED THE  SIMULATION  WILL
.        BE  RESUMED AT THE POINT OF INTERRUPTION.  WHEN COMPLETED THE
.        C180 X0 REGISTER WILL  BE  CLEARED  TO  ALL  ZEROS  AND  THIS
.        SUBROUTINE WILL RETURN TO ITS CALLER.
.
.        ENTRY-     (AA) = PVA OF SOURCE FIELD.
.                   (AB) = PVA OF DESTINATION FIELD.
.                   (a9) = PVA OF MOVE INSTRUCTION.
.                   (X7) = FIELD 1 RELATIVE WORD.
.                   (X8) = FIELD 2 RELATIVE WORD.
.                   (XD) = L, NUMBER OF CHARACTERS TO MOVE.
.                   (XE) = C1, FIRST CHARACTER POSITION IN WORD 1
.                              OF SOURCE FIELD.
.                   (XF) = C2, FIRST CHARACTER POSITION IN WORD 1
.                              OF DESTINATION FIELD.
.
.        EXIT-      IF THE SIMULATION HAS BEEN COMPLETED,
.                     (X0) = 0.
.                   IF THE MOVE WAS INTERRUPTED, SMI EXITS TO PII.
.
SMI      ENTE      X1,60
         ENTE      X0,600(8)
         MULR      XE,X0               .B1, FIRST SOURCE BIT
         MULR      XF,X0               .B2, FIRST DESTINATION BIT
         SHFX      X3,XF,X0,-6
.
.        COMPUTE BM = MAX (B1,B2)
.
         CPYRR     XC,XE
         BRRGE     XE,XF,SMI01         .IF B1 .GE. B2
         CPYRR     XC,XF
.
.        COMPUTE SL = 60-BM/64, NUMBER OF BITS FROM FIRST SOURCE WORD
.
SMI01    SHFX      XC,XC,X0,-6         .BM/64
         SUBR      X1,XC               .60-BM/64
         MULRQ     XD,XD,6             .LENGTH OF MOVE IN BITS
         ADDR      XD,X3               .LAST BIT + 1 IN DESTINATION
SMI02    ADDR      XE,X1
         DECR      XE,1                .ISOLATION MODIFIER FOR SOURCE
         ADDR      XF,X1
         DECR      XF,1                .INSERT MODIFIER FOR DESTINATION
         LXI       X2,AA,X7,0          .GET FIRST SOURCE WORD
         LXI       X3,AB,X8,0          .GET FIRST DESTINATION WORD
         INCR      X7,1                .INCREMENT SOURCE INDEX
         ISOB      X4,X2,XE,0400(8)    .ISOLATE SOURCE DATA
         INSB      X3,X4,XF,0400(8)    .INSERT INTO DESTINATION WORD
         BRRGE     XF,XE,SMI04         .IF DESTINATION WORD IS COMPLETE
         SHFX      XF,XF,X0,-6
         ADDR      XF,X1               .NEXT BIT IN DESTINATION WORD
         ENTE      X1,60
         SUBR      X1,XF               .SL, BITS NEEDED FROM NEXT WORD
         SHFX      XF,XF,X0,6
         LXI       X2,AA,X7,0          .NEXT SOURCE WORD
         INCR      X7,1                .INCREMENT SOURCE INDEX
         ADDR      XF,X1
         DECR      XF,1                .INSERT MODIFIER FOR DESTINATION
         CPYRR     XE,X1
         DECR      XE,1                .ISOLATION MODIFIER FOR SOURCE
         ISOB      X4,X2,XE,0400(8)    .ISOLATE SL SOURCE DATA BITS
         INSB      X3,X4,XF,0400(8)    .INSERT INTO DESTINATION WORD
         BRREQ     X0,X0,SMI05
.
SMI04    SHFX      XE,XE,X0,-6         .CALCULATE NEW SOURCE BIT POSITION
         ADDR      XE,X1
         CPYXX     X1,XE               .CALCULATE SHIFT AMOUNT
         DECR      XE,1                .ISOLATE MODIFIER
SMI05    ENTE      XB,60
         ENTE      XC,25
         ENTP      XA,0                .INITIALIZE WORD COUNT
         BRRGE     XB,XD,SMI08         .IF MOVE IS 60 BITS OR LESS
         BRREQ     X0,X0,SMI07
.
SMI06    SHFX      X3,X5,X1,0          .SHIFT IN PREVIOUS SOURCE
         ISOB      X4,X2,XE,0400(8)    .ISOLATE SL BITS FROM SOURCE
         IORX      X3,X4               .FILL OUT DESTINATION WORD
         BRRGE     XB,XD,SMI08         .IF 60 BITS OR LESS LEFT
SMI07    SXI       X3,AB,X8,0          .STORE DESTINATION WORD
         SUBR      XD,XB               .DECREMENT NUMBER OF BITS LEFT
         CPYXX     X5,X2
         INCR      X8,1                .INCREMENT DESTINATION INDEX
         LXI       X2,AA,X7,0          .GET NEXT SOURCE WORD
         INCR      X7,1                .INCREMENT SOURCE INDEX
         BRINC     XC,XA,SMI06         .IF 26 WORD BLOCK NOT DONE
         ENTP      XA,0                .RESET WORD COUNT
         BRCR      5,3,SMI06           .IF NOT C170 PP EXCHANGE
         DECR      X7,2
         BRREQ     X0,X0,PII
.
SMI08    LXI       X4,AB,X8,0          .GET LAST DESTINATION WORD
         ISOM      X5,XD,0300(8)       .MASK FOR LAST WORD
         ANDX      X3,X5
         INHX      X4,X5
         IORX      X3,X4               .LAST DESTINATION WORD
         SXI       X3,AB,X8,0
         ENTL      X0,0                .CLEAR X0 FOR RETURN
         BRREQ     X0,X0,trap3         .RETURN TO CALLER
         PAGE
...
.        SCI        - SIMULATE COMPARE INSTRUCTION.
.
.        THIS  SUBROUTINE SIMULATES THE EXECUTION OF THE CYBER 170 CMU
.        COMPARE  INSTRUCTIONS  CC  AND  CU.   THE  COMPARE   PROCEEDS
.        CHARACTER  BY  CHARACTER  FROM LEFT TO RIGHT THROUGH THE DATA
.        FIELDS TO BE COMPARED.  EACH TIME A BLOCK  OF  10  CHARACTERS
.        HAS BEEN COMPARED THIS ROUTINE WILL TEST THE CONDITION OF BIT
.        05  OF  THE MONITOR CONDITION REGISTER.  IF SET SCI WILL EXIT
.        TO  ROUTINE  PII.   WHEN  THE  INSTRUCTION  IS   SUBSEQUENTLY
.        RE-EXECUTED  THE  SIMULATION  WILL  RESUME  AT  THE  POINT OF
.        INTERRUPTION.  IN THE EVENT THAT A  PAIR  OF  CHARACTERS  ARE
.        FOUND   THAT  DO  NOT  COMPARE  THE  CORRESPONDING  COLLATING
.        CHARACTERS ARE AQUIRED  IF  THE  INSTRUCTION  IS  A  COLLATED
.        COMPARE.  IF THE INSTRUCTION IS NOT A COLLATED COMPARE, OR IF
.        THE  COLLATING  CHARACTERS  DO  NOT  COMPARE,  THE SIMULATION
.        TERMINATES AND THE STATUS OF THE COMPARE IS SET INTO THE C180
.        X0 REGISTER.  IF THE SIMULATION RUNS  TO  COMPLETION  WITHOUT
.        ENCOUNTERING  A  MIS-COMPARE, THE C180 X0 REGISTER IS CLEARED
.        TO ALL ZEROS.  IN EITHER CASE THIS SUBROUTINE THEN  EXITS  TO
.        ITS CALLER.
.
.        ENTRY-     (AA) = PVA OF DATA FIELD 1.
.                   (AB) = PVA OF DATA FIELD 2.
.                   (a8) = PVA OF COLLATING TABLE (IF COLLATED COMPARE).
.                   (a9) = PVA OF COMPARE INSTRUCTION.
.                   (X7) = FIELD 1 RELATIVE WORD.
.                   (X8) = FIELD 2 RELATIVE WORD.
.                   (XC) = INSTRUCTION TYPE.
.                          2 = COLLATED COMPARE, 3 = UNCOLLATED COMPARE.
.                   (XD) = L, LENGTH OF FIELDS TO COMPARE.
.                   (XE) = C1, FIRST CHARACTER IN WORD 1 OF FIELD 1.
.                   (XF) = C2, FIRST CHARACTER IN WORD 1 OF FIELD 2.
.
.        EXIT-      (X0) = STATUS OF COMPARE AS FOLLOWS-
.                          IF FIELD 1 .GT. FIELD 2,
.                             (X0) = L-CC.
.                          IF FIELD 1 .LT. FIELD 2,
.                             (X0) = ONES COMPLEMENT OF L-CC.
.                          IF ALL PAIRS COMPARE,
.                             (X0) = 0.
.                          IN THE ABOVE FORMULAS CC = NUMBER OF
.                          CHARACTER PAIRS COMPARING CORRECTLY BEFORE
.                          THE COMPARE FAILURE.
SCI      DECR      XC,2
         ENTP      X4,1
         ENTE      X0,600(8)           .INCREMENT VALUE
         MULR      XE,X0               .ISOLATION MODIFIER FOR FIELD 1
         MULR      XF,X0               .ISOLATION MODIFIER FOR FIELD 2
         ENTE      X1,7400(8)
         LXI       X2,AA,X7,0          .FIRST WORD OF FIELD 1
         LXI       X3,AB,X8,0          .FIRST WORD OF FIELD 2
         INCR      X7,1
         INCR      X8,1
SCI01    BRRGE     XE,X1,SCI05         .IF NO MORE DATA IN FIELD 1 WORD
SCI02    BRRGE     XF,X1,SCI06         .IF NO MORE DATA IN FIELD 2 WORD
SCI03    ISOB      X5,X2,XE,0405(8)    .GET CHARACTER OF FIELD 1
         ISOB      X6,X3,XF,0405(8)    .GET CHARACTER OF FIELD 2
         BRRNE     X5,X6,SCI08         .IF CHARACTERS NOT EQUAL
SCI04    ADDR      XE,X0               .INCREMENT ISOLATION MODIFIERS
         ADDR      XF,X0
         BRINC     XD,X4,SCI01         .IF MORE DATA TO COMPARE
         ENTP      X0,0                .FIELDS COMPARE
         BRREQ     X0,X0,trap3         .RETURN TO CALLER
.
SCI05    LXI       X2,AA,X7,0          .NEXT FIELD 1 WORD
         ENTP      XE,0                .RESET ISOLATION MODIFIER
         INCR      X7,1                .INCREMENT WORD INDEX
         BRREQ     X0,X0,SCI02
.
SCI06    BRCR      5,3,SCI07           .IF NO C170 PP EXCHANGE
         SHFX      X1,XE,X0,-6         .FIELD 1 BIT POSITION TO X1
         DECR      X7,1
         BRREQ     X0,X0,PII           .PROCESS INSTRUCTION INTERRUPT
.
SCI07    LXI       X3,AB,X8,0          .NEXT FIELD 2 WORD
         ENTP      XF,0                .RESET ISOLATION MODIFIER
         INCR      X8,1                .INCREMENT WORD INDEX
         BRREQ     X0,X0,SCI03
.
SCI08    BRRNE     XC,X0,SCI09         .IF NOT COLLATED COMPARE
         ENTP      X9,7
         ISOB      XA,X5,X0,7202(8)    .FIELD 1 COLLATING WORD OFFSET
         ANDX      X5,X9               .FIELD 1 COLLATING CHARACTER OFFSET
         ISOB      XB,X6,X0,7202(8)    .FIELD 2 COLLATING WORD OFFSET
         ANDX      X6,X9               .FIELD 2 COLLATING CHARACTER OFFSET
         MULR      X5,X0               .FIELD 1 ISOLATION MODIFIER
         MULR      X6,X0               .FIELD 2 ISOLATION MODIFIER
         LXI       XA,a8,XA,0          .FIELD 1 COLLATING WORD
         LXI       XB,a8,XB,0          .FIELD 2 COLLATING WORD
         ISOB      X5,XA,X5,0405(8)    .FIELD 1 COLLATING CHARACTER
         ISOB      X6,XB,X6,0405(8)    .FIELD 2 COLLATING CHARACTER
         BRREQ     X5,X6,SCI04         .IF COMPARE COLLATES
SCI09    SUBR      XD,X4
         ADDRQ     X0,XD,1             .COMPUTE L-CC
         BRRGT     X5,X6,SCI10         .IF FIELD 1 .GT. FIELD 2
         NOTX      X0,X0               .COMPLEMENT L-CC
SCI10    BRREQ     X0,X0,trap3         .RETURN TO CALLER
.
.***  End common deck OSI$C170_CMU_EMULATION
*DECK DECK=OSI$CMRW64 EXPAND=FALSE
          SPACE  1
*         COMMON DECK CMRW64.
          SPACE  1
************************************************************************
*         SUBROUTINE         CMR64
*
*         PURPOSE            READ DATA FROM CM IN 64-BIT FORMAT
*
*         ENTRY              A CONTAINS THE PPU INPUT BUFFER ADDRESS
*                            DADDR HOLDS THE ADDRESS OF THE CM ADDRESS
*                             OF THE CM BUFFER IN THE FORMAT --
*                                         DAU 00000000UUUU
*                                         DAM MMMMMMMMMMMM
*                                         DAL LLLLLLLLLLLL      WHERE
*                                      U, M, AND L ARE THE UPPER
*                                      MIDDLE AND LOWER BITS
                             CMXFR HOLDS THE NO. OF CM WORDS TO READ
*                            CMAI HOLDS AN OFFSET TO THE CM ADDRESS
*
*         EXIT               THE DATA HAS BEEN READ INTO THE PPU
*
************************************************************************
 CMR64    SUBR               ENTRY
          STM    CMR64.1     STORE PP ADDRESS IN READ
          LDD    DADDR
          RJM    CMADDR      FORMAT CM ADDRESS
          LDD    CMAI        GET ADDRESS INCREMENT (IF ANY)
          RJM    LINCMA      INCREMENT CM ADDRESS
          CRML   *,CMXFR     READ 64-BIT CM WORD INTO PP
          ORG    *-1
 CMR64.1  BSS    0           PP ADDRESS GOES HERE
          ORG    *+1
          ENDSUB CMR64       EXIT
          EJECT
          SPACE  1
************************************************************************
*         SUBROUTINE         CMW64
*
*         PURPOSE            WRITE DATA TO CM IN 64-BIT FORMAT
*
*         ENTRY              A CONTAINS THE PPU OUTPUT BUFFER ADDRESS
*                            DADDR HOLDS THE ADDRESS OF THE CM ADDRESS
*                             OF THE CM BUFFER IN THE FORMAT --
*                                         DAU 00000000UUUU
*                                         DAM MMMMMMMMMMMM
*                                         DAL LLLLLLLLLLLL      WHERE
*                                      U, M, AND L ARE THE UPPER
*                                      MIDDLE AND LOWER BITS
                             CMXFR HOLDS THE NO. OF CM WORDS TO WRITE
*                            CMAI HOLDS AN OFFSET TO THE CM ADDRESS
*
*         EXIT               THE DATA HAS BEEN WRITTEN TO CM
*
************************************************************************
 CMW64    SUBR               ENTRY
          STM    CMW64.1     STORE PP ADDRESS IN WRITE
          LDD    DADDR
          RJM    CMADDR      FORMAT CM ADDRESS
          LDD    CMAI        GET ADDRESS INCREMENT (IF ANY)
          RJM    LINCMA      INCREMENT CM ADDRESS
          CWML   *,CMXFR     WRITE 64-BIT CM WORD FROM PP
          ORG    *-1
 CMW64.1  BSS    0           PP ADDRESS GOES HERE
          ORG    *+1
          ENDSUB CMW64       EXIT
*DECK DECK=OSI$COBOL6_FOLDED EXPAND=FALSE
      [rep 33 of 0,
      34, 23,  5, 16,  2,  6,  7, 21, 13, 17, 15, 20, 18,
      12, 19, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 53,
      14, 24, 22,  9,  8,  1, 25, 26, 27, 28, 29, 30, 31,
      32, 33, 35, 36, 37, 38, 39, 40, 41, 42, 43, 45, 46,
      47, 48, 49, 50, 51, 52,  3, 10, 44, 11,  4,  1, 25,
      26, 27, 28, 29, 30, 31, 32, 33, 35, 36, 37, 38, 39,
      40, 41, 42, 43, 45, 46, 47, 48, 49, 50, 51, 52,  3,
      10, 44, 11, rep 129 of 0]
*DECK DECK=OSI$COBOL6_STRICT EXPAND=FALSE
      [rep 33 of 0,
      34, 23,  5, 16,  2,  6,  7, 21, 13, 17, 15, 20, 18,
      12, 19, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 53,
      14, 24, 22,  9,  8,  1, 25, 26, 27, 28, 29, 30, 31,
      32, 33, 35, 36, 37, 38, 39, 40, 41, 42, 43, 45, 46,
      47, 48, 49, 50, 51, 52,  3, 10, 44, 11,  4, rep 160 of 0]
*DECK DECK=OSI$DISPLAY63_FOLDED EXPAND=FALSE
      [rep 33 of 45,
      54, 52, 48, 43, 45, 55, 56, 41, 42, 39, 37, 46,
      38, 47, 40, 27, 28, 29, 30, 31, 32, 33, 34, 35,
      36, 51, 63, 58, 44, 59, 57, 60,  1,  2,  3,  4,
       5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15, 16,
      17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 49, 61,
      50, 62, 53, 60,  1,  2,  3,  4,  5,  6,  7,  8,
       9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20,
      21, 22, 23, 24, 25, 26, 49, 61, 50, 62,
      rep 129 of 45]
*DECK DECK=OSI$DISPLAY63_STRICT EXPAND=FALSE
      [rep 33 of 45,
      54, 52, 48, 43, 45, 55, 56, 41, 42, 39, 37, 46,
      38, 47, 40, 27, 28, 29, 30, 31, 32, 33, 34, 35,
      36, 51, 63, 58, 44, 59, 57, 60,  1,  2,  3,  4,
       5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15, 16,
      17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 49, 61,
      50, 62, 53, rep 160 of 45]
*DECK DECK=OSI$DISPLAY64_FOLDED EXPAND=FALSE
      [rep 33 of 45,
      54, 52, 48, 43, 51, 55, 56, 41, 42, 39, 37, 46,
      38, 47, 40, 27, 28, 29, 30, 31, 32, 33, 34, 35,
      36,  0, 63, 58, 44, 59, 57, 60,  1,  2,  3,  4,
       5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15, 16,
      17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 49, 61,
      50, 62, 53, 60,  1,  2,  3,  4,  5,  6,  7,  8,
       9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20,
      21, 22, 23, 24, 25, 26, 49, 61, 50, 62,
      rep 129 of 45]
*DECK DECK=OSI$DISPLAY64_STRICT EXPAND=FALSE
      [rep 33 of 45,
      54, 52, 48, 43, 51, 55, 56, 41, 42, 39, 37, 46,
      38, 47, 40, 27, 28, 29, 30, 31, 32, 33, 34, 35,
      36,  0, 63, 58, 44, 59, 57, 60,  1,  2,  3,  4,
       5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15, 16,
      17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 49, 61,
      50, 62, 53, rep 160 of 45]
*DECK DECK=OSI$EBCDIC EXPAND=FALSE
      [ 0,   1,   2,   3,  55,  45,  46,  47,  22,   5,  37,
       11,  12,  13,  14,  15,  16,  17,  18,  19,  60,  61,
       50,  38,  24,  25,  63,  39,  28,  29,  30,  31,  64,
       79, 127, 123,  91, 108,  80, 125,  77,  93,  92,  78,
      107,  96,  75,  97, 240, 241, 242, 243, 244, 245, 246,
      247, 248, 249, 122,  94,  76, 126, 110, 111, 124, 193,
      194, 195, 196, 197, 198, 199, 200, 201, 209, 210, 211,
      212, 213, 214, 215, 216, 217, 226, 227, 228, 229, 230,
      231, 232, 233,  74, 224,  90,  95, 109, 121, 129, 130,
      131, 132, 133, 134, 135, 136, 137, 145, 146, 147, 148,
      149, 150, 151, 152, 153, 162, 163, 164, 165, 166, 167,
      168, 169, 192, 106, 208, 161,   7,  32,  33,  34,  35,
       36,  21,   6,  23,  40,  41,  42,  43,  44,   9,  10,
       27,  48,  49,  26,  51,  52,  53,  54,   8,  56,  57,
       58,  59,   4,  20,  62, 225,  65,  66,  67,  68,  69,
       70,  71,  72,  73,  81,  82,  83,  84,  85,  86,  87,
       88,  89,  98,  99, 100, 101, 102, 103, 104, 105, 112,
      113, 114, 115, 116, 117, 118, 119, 120, 128, 138, 139,
      140, 141, 142, 143, 144, 154, 155, 156, 157, 158, 159,
      160, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179,
      180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190,
      191, 202, 203, 204, 205, 206, 207, 218, 219, 220, 221,
      222, 223, 234, 235, 236, 237, 238, 239, 250, 251, 252,
      253, 254, 255]
*DECK DECK=OSI$EBCDIC6_FOLDED EXPAND=FALSE
      [rep 33 of 0,
       5, 24, 20,  7, 15,  6, 22,  3,  9,  8,  4, 14, 12,
       1, 13, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 19,
      10,  2, 23, 17, 18, 21, 26, 27, 28, 29, 30, 31, 32,
      33, 34, 36, 37, 38, 39, 40, 41, 42, 43, 44, 46, 47,
      48, 49, 50, 51, 52, 53, 25, 45, 35, 11, 16, 21, 26,
      27, 28, 29, 30, 31, 32, 33, 34, 36, 37, 38, 39, 40,
      41, 42, 43, 44, 46, 47, 48, 49, 50, 51, 52, 53, 25,
      45, 35, 11, rep 133 of 0]
*DECK DECK=OSI$EBCDIC6_STRICT EXPAND=FALSE
      [rep 33 of 0,
       5, 24, 20,  7, 15,  6, 22,  3,  9,  8,  4,
      14, 12,  1, 13, 54, 55, 56, 57, 58, 59, 60,
      61, 62, 63, 19, 10,  2, 23, 17, 18, 21, 26,
      27, 28, 29, 30, 31, 32, 33, 34, 36, 37, 38,
      39, 40, 41, 42, 43, 44, 46, 47, 48, 49, 50,
      51, 52, 53, 25, 45, 35, 11, 16,
      rep 160 of 0]
*DECK DECK=OSI$FIND_APPLICABLE_POLICY EXPAND=FALSE
  PROCEDURE find_applicable_policy
    (    criteria: ost$ecp_criteria;
         policies_sequence_header: ^ost$ecp_header;
     VAR applicable_actions: ost$ecp_actions;
     VAR applicable_policy: ^ost$ecp_policy_header;
     VAR status: ost$status);


{ Design:
{ This is a common procedure used to find the applicable policy in a sequence
{ of exception condition policies.
{
{ Policies are stored in chronological order in the policies sequence.  Each
{ policy defines criteria such as "who" is accessing an object that has an
{ exception condition and "what" kind of object is accessed.  Policy criteria
{ are all weighted differently so that the best policy is applied in any given
{ situation.  All of the policies are visited in the order in which they were
{ defined, with the most recent policy that applies and whose criteria weight
{ is >= to that of any preceding policy being the chosen one.

{ The applicable policy is the one 1) that has any of its "who" or "what"
{ criteria parameters match the corresponding value of the CRITERIA parameter
{ of this procedure 2) that is the most specific (i.e., has the greatest
{ weight), and 3) that is the most recently specified policy.

{ Policy parameters are investigated in order of least weight to greatest
{ weight.  All policy criteria defined within the same CHAEP subcommand are
{ considered.  A policy with multiple criteria parameters specified is
{ processed in the same manner as if multiple commands were specified, each
{ with a single policy criteria, i.e.  it is sufficient that any single
{ policy criteria be satisfied for the policy to be considered a candidate.

{ The CRITERIA.CONDITION field could have been investigated either first or
{ last.  The decision to consider it first was made out of consideration for
{ performance; however, technically, CRITERIA.CONDITION is the most specific
{ aspect of the policy.


    VAR
      candidate: boolean,
      candidate_actions: ost$ecp_actions,
      candidate_policy_weight: ost$ecp_policy_weight,
      condition: ^ost$ecp_exception_condition,
      greatest_policy_weight: ost$ecp_policy_weight,
      i: ost$non_negative_integers,
      policy: ^ost$ecp_policy_header,
      policy_number: ost$non_negative_integers;

?? NEWTITLE := '  match_all_files', EJECT ??

    PROCEDURE match_all_files;

      IF policy^.files.specified THEN
        IF policy^.files.all_specified THEN
          candidate_policy_weight := osc$ecp_all_files_priority;
        IFEND;
      IFEND;
    PROCEND match_all_files;
?? OLDTITLE ??
?? NEWTITLE := '  match_condition', EJECT ??

    PROCEDURE match_condition;

?? NEWTITLE := 'find_exception_condition' ??

      PROCEDURE find_exception_condition
        (    policy: ^ost$ecp_policy_header;
             condition_ordinal: fst$file_access_condition;
         VAR condition_entry: ^ost$ecp_exception_condition);

        VAR
          i: ost$ecp_number_of_conditions;

        condition_entry := NIL;
        FOR i := 1 TO UPPERBOUND (policy^.conditions) DO
          IF condition_ordinal IN policy^.conditions [i].
                file_access_conditions THEN
            condition_entry := ^policy^.conditions [i];
            RETURN;
          IFEND;
        FOREND;
      PROCEND find_exception_condition;
?? OLDTITLE, EJECT ??

      candidate := FALSE;
      condition := NIL;

      find_exception_condition (policy, criteria.condition, condition);
      IF condition <> NIL THEN
        candidate := condition^.specified;
        IF candidate THEN
          candidate_actions := condition^.actions;
        IFEND;
      IFEND;
    PROCEND match_condition;
?? OLDTITLE ??
?? NEWTITLE := '  match_family_name', EJECT ??

    PROCEDURE match_family_name;

      IF (policy^.families <> NIL) AND (criteria.family_path_name <>
            osc$null_name) THEN
        FOR i := 1 TO UPPERBOUND (policy^.families^) DO
          IF criteria.family_path_name = policy^.families^ [i] THEN
            candidate_policy_weight := osc$ecp_family_priority;
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    PROCEND match_family_name;
?? OLDTITLE ??
?? NEWTITLE := '  match_specific_file', EJECT ??

    PROCEDURE match_specific_file;

      VAR
        evaluated_file_reference: fst$evaluated_file_reference,
        local_status: ost$status,
        match_info: clt$string_pattern_match_info,
        path: fst$path,
        path_size: fst$path_size,
        string_pattern: ^clt$string_pattern,
        target_path_size: 1 .. fsc$max_path_size,
        work_area: ^clt$work_area;

      PUSH work_area :[[REP (5 * fsc$max_path_size) OF CELL]];
      IF policy^.files.specified AND (NOT policy^.files.all_specified) AND
            (criteria.file <> osc$null_name) THEN
        target_path_size := clp$trimmed_string_size (criteria.file);
        FOR i := 1 TO UPPERBOUND (policy^.files.path_list^) DO
          path_size := STRLENGTH (policy^.files.path_list^ [i].path^);
          CASE policy^.files.path_list^ [i].file_reference_type OF
          = osc$ecp_evaluated_reference =
            IF target_path_size >= path_size THEN
              IF policy^.files.path_list^ [i].path^ (1, path_size) =
                    criteria.file (1, path_size) THEN
                candidate_policy_weight := osc$ecp_specific_path_priority;
                RETURN;
              IFEND;
            IFEND;

          = osc$ecp_generic_reference, osc$ecp_wild_card_reference =

            clp$evaluate_file_reference (policy^.files.path_list^ [i].path^,
                  $clt$file_ref_parsing_options [clc$multiple_reference_allowed]
                  , FALSE, evaluated_file_reference, local_status);
            IF local_status.normal THEN
              clp$convert_file_ref_to_string (evaluated_file_reference, TRUE,
                    path, path_size, local_status);
              IF local_status.normal THEN
                IF evaluated_file_reference.multiple_reference_specified THEN
                  clp$build_pattern_for_wild_card
                        (policy^.files.path_list^ [i].wild_card_pattern_type,
                        $clt$string_pattern_build_opts
                        [clc$sp_file_reference_pattern, clc$sp_match_at_right,
                        clc$sp_ignore_matched_substring], path (1, path_size),
                        work_area, string_pattern, local_status);
                  IF local_status.normal THEN
                    clp$match_string_pattern (criteria.
                          file (1, target_path_size), string_pattern,
                          clc$sp_anchored, clc$sp_quick_scan, match_info,
                          local_status);
                    IF local_status.normal THEN
                      IF match_info.result = clc$sp_success THEN
                        candidate_policy_weight :=
                              osc$ecp_specific_path_priority;
                        RETURN;
                      IFEND;
                    IFEND;
                  IFEND;
                ELSE
                  IF target_path_size >= path_size THEN
                    IF path (1, path_size) = criteria.file (1, path_size) THEN
                      candidate_policy_weight := osc$ecp_specific_path_priority;
                      RETURN;
                    IFEND;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          CASEND;
        FOREND;
      IFEND;
    PROCEND match_specific_file;
?? OLDTITLE ??
?? NEWTITLE := '  match_job', EJECT ??

    PROCEDURE match_job;

      IF policy^.jobs <> NIL THEN
        FOR i := 1 TO UPPERBOUND (policy^.jobs^) DO
          IF criteria.job = policy^.jobs^ [i] THEN
            candidate_policy_weight := osc$ecp_job_priority;
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    PROCEND match_job;
?? OLDTITLE ??
?? NEWTITLE := '  match_job_class', EJECT ??

    PROCEDURE match_job_class;

      IF policy^.job_classes <> NIL THEN
        FOR i := 1 TO UPPERBOUND (policy^.job_classes^) DO
          IF criteria.job_class = policy^.job_classes^ [i] THEN
            candidate_policy_weight := osc$ecp_job_class_priority;
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    PROCEND match_job_class;
?? OLDTITLE ??
?? NEWTITLE := '  match_job_mode', EJECT ??

    PROCEDURE match_job_mode;

      IF policy^.job_mode.specified THEN
        IF (criteria.job_mode = policy^.job_mode.value) THEN
          candidate_policy_weight := osc$ecp_job_mode_priority;
        IFEND;
      IFEND;
    PROCEND match_job_mode;
?? OLDTITLE ??
?? NEWTITLE := '  match_login_user', EJECT ??

    PROCEDURE match_login_user;

      VAR
        list_item_candidate: boolean,
        list_item_policy_weight: ost$ecp_policy_weight;

      IF policy^.login_users <> NIL THEN
        FOR i := 1 TO UPPERBOUND (policy^.login_users^) DO
          list_item_candidate := TRUE;
          list_item_policy_weight := osc$ecp_nonapplicable_policy;
          IF osc$lu_user_name IN policy^.login_users^ [i].specified_fields THEN
            list_item_candidate := list_item_candidate AND
                  (criteria.login_user = policy^.login_users^ [i].user_name);
            list_item_policy_weight := osc$ecp_lu_user_priority;
          IFEND;
          IF osc$lu_family_name IN policy^.login_users^ [i].
                specified_fields THEN
            list_item_candidate := list_item_candidate AND
                  (criteria.login_family = policy^.login_users^ [i].
                  family_name);
            list_item_policy_weight := osc$ecp_lu_family_priority;
          IFEND;
          IF osc$lu_job_class IN policy^.login_users^ [i].specified_fields THEN
            list_item_candidate := list_item_candidate AND
                  (criteria.job_class = policy^.login_users^ [i].job_class);
            list_item_policy_weight := osc$ecp_lu_job_class_priority;
          IFEND;
          IF osc$lu_job_mode IN policy^.login_users^ [i].specified_fields THEN
            list_item_candidate := list_item_candidate AND
                  (criteria.job_mode = policy^.login_users^ [i].job_mode);
            list_item_policy_weight := osc$ecp_lu_job_mode_priority;
          IFEND;
          IF list_item_candidate AND (list_item_policy_weight >=
                candidate_policy_weight) THEN
            candidate_policy_weight := list_item_policy_weight;
          IFEND;
        FOREND;
      IFEND;
    PROCEND match_login_user;
?? OLDTITLE ??
?? NEWTITLE := '  match_ms_class', EJECT ??

    PROCEDURE match_ms_class;

      IF policy^.mass_storage_classes.specified THEN
        IF (criteria.mass_storage_class IN policy^.mass_storage_classes.value)
              THEN
          candidate_policy_weight := osc$ecp_ms_class_priority;
        IFEND;
      IFEND;
    PROCEND match_ms_class;
?? OLDTITLE ??
?? NEWTITLE := '  match_set_name', EJECT ??

    PROCEDURE match_set_name;

      IF policy^.sets <> NIL THEN
        FOR i := 1 TO UPPERBOUND (policy^.sets^) DO
          IF criteria.set_name = policy^.sets^ [i] THEN
            candidate_policy_weight := osc$ecp_set_priority;
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    PROCEND match_set_name;
?? OLDTITLE ??
?? NEWTITLE := '  match_volume', EJECT ??

    PROCEDURE match_volume;

      VAR
        j: ost$positive_integers;

      IF (criteria.volume_list <> NIL) AND (policy^.volumes <> NIL) THEN
        FOR i := 1 TO UPPERBOUND (policy^.volumes^) DO
          FOR j := 1 TO UPPERBOUND (criteria.volume_list^) DO
            IF criteria.volume_list^ [j].recorded_vsn = policy^.
                  volumes^ [i] THEN
              candidate_policy_weight := osc$ecp_volume_priority;
              RETURN;
            IFEND;
          FOREND;
        FOREND;
      IFEND;
    PROCEND match_volume;
?? OLDTITLE ??
?? EJECT ??

    VAR
      local_status: ost$status;

    status.normal := TRUE;

    applicable_actions := $ost$ecp_actions [];
    candidate_actions := $ost$ecp_actions [];
    applicable_policy := NIL;
    greatest_policy_weight := osc$ecp_nonapplicable_policy;

    IF (policies_sequence_header <> NIL) THEN
      policy := policies_sequence_header^.first_policy;
      policy_number := 1;
      WHILE (policy <> NIL) AND (policy_number <=
            policies_sequence_header^.number_of_policies) DO

       candidate_policy_weight := osc$ecp_nonapplicable_policy;
        match_condition;
        IF candidate THEN
          match_all_files;
          match_set_name;
          match_family_name;
          match_ms_class;
          match_volume;
          match_specific_file;
          match_job_class;
          match_job_mode;
          match_login_user;
          match_job;
          IF (candidate_policy_weight >= greatest_policy_weight) AND
                 (candidate_policy_weight <> osc$ecp_nonapplicable_policy) THEN
            applicable_actions := candidate_actions;
            applicable_policy := policy;
            greatest_policy_weight := candidate_policy_weight;
          IFEND;
        IFEND;
        policy := policy^.next_policy;
        policy_number := policy_number + 1;
      WHILEND;
    IFEND;
  PROCEND find_applicable_policy;

*DECK DECK=OSI$PRIVILAGED_170_INSTRUCTIONS EXPAND=FALSE
         PAGE
.***********************************************************************
.
.        osi$privilaged_170_instructions
.
.***********************************************************************
.        PIF        PRIVILAGED INSTRUCTION FAULT HANDLER.
.
.        THIS ROUTINE PROCESSES INSTRUCTIONS OF THE FORM:
.
.        9/017 3/i 3/j 15/op 30/k
.
.        i  = OPTIONAL X REGISTER.
.        j  = OPTIONAL X REGISTER.
.        op = FUNCTION CODE.
.        k  = OPTIONAL CONSTANT PARAMETER.
.
.        The function codes handled by EI are the following:
.        0001 - SET INTERFACE BLOCK.
.        0002 - PREPARE FOR NOS/VE DEADSTART.
.        0040 - read and set pit.
.        0701 - ECS/CM TO CM COPY.
.        0702 - CM TO ECS/CM COPY.
.        0703 - CACHE INVALIDATE.
.        1001 - mini-link memory transfer.
.        1002 - initialize pvas for mini-link.
.        1003 - Return value of pva.
.        2777 - Inject hardware faults.
.
.        The function codes handled by NOS trap handler are the following:
.        0003 - Revert to NOS standalone operation.
.        1001 - Mini-link memory transfer.
.        2000 - Unprivilaged memory link.
.        2001 - Console display driver.
.        2002 - NOS/ve status.
.
.        REQUESTS 1,701,702 REQUIRE RA=0.  ALL REMAINING REQUESTS  ARE
.        VALIDATED  BASED  ON  THE  VALIDATION FIELD IN THE DUAL STATE
.        BLOCK.  THE VALIDATION ACCORDING TO THE FOLLOWING TABLE.
.
.            0 -   777  V1.
.         1000 -  1777  V2.
.         2000 -  3777  V3.
.         4000 -  7777  V4.
.        10000 - 17777  V5.
.        20000 - 37777  V6.
.        40000 - 77777  V7.
.
.        define symbolic names for function codes.
.
dscb     equ       1                   .define DSCB pointer
scpu     equ       2                   .stop CPU
rspt     equ       40(8)               .read and set pit
eccp     equ       701(8)              .ECS/CM to CM copy
cecp     equ       702(8)              .CM to ECS/CM copy
cinv     equ       703(8)              .cache invalidate
cpcm     equ       1001(8)             .Copy CM between C180 and C170
cpva     equ       1002(8)             .Define PVA for function cpcm
rpva     equ       1003(8)             .Return value of PVA
mliu     equ       2000(8)             .Memory Link Interface Unprivileged
nvst     equ       2002(8)             .NOS/ve status request
ihfu     equ       2777(8)             .Inject hardware fault
.
PIF      bss       0
.
.        VALIDATE INSTRUCTION POSITION.
.
         lbyts,6   X2,a_psa,x0,xp_p
         ISOB      X3,X2,X0,7502(8)    .ISOLATE PARCEL DESCRIPTOR
         BRRNE     X3,X0,IIP           .IF NOT AT PARCEL 0
.
.        VALIDATE TRAP017 INSTRUCTION FIELDS.
.
         CPYXA     a8,X2               .(a8) = P
         LX        xc,a8,0             .(xc) = TRAP017 INSTRUCTION
         ISOB      X5,xc,X0,2316(8)    .INSTRUCTION TYPE
         ISOB      x_reg1,xc,X0,1502(8)  .ISOLATE REGISTER NUMBER
         isob      x_reg2,xc,x0,2002(8)  .second register number
.
.        VERIFY ACCESS PERMISSION, EITHER RA=0 OR THE PROPER
.        BIT SET IN THE TRAP 180 FIELD IN THE D7JP WORD OF
.        THE DUAL STATE CONTROL BLOCK.
.
         brreq     x_rac,x0,pif2       .if RA=0 permission
.
.        CHECK PRIVILAGE BIT IS SET.
.
pif1     bss       0
         entl      x0,r_pid
         cpysx     x1,x0               .fetch processor number
         mulxq     x1,x1,8
         LBYTS,1   X6,a_dscb,x1,d7jp+5  .VALIDATION BITS
         SHFX      X9,X5,X0,-8
         ENTL      X0,1
         IORX      X9,X0
         ANDX      X6,X9
         BRRGT     X6,X9,IIP           .IF NOT VALIDATED
         ADDX      X6,X6
         BRRGE     X9,X6,IIP           .IF NOT VALIDATED
PIF2     BSS       0
         addpxq    a4,x0,reqtable
         sbyts,2   x5,a4,x0,req_end-reqtable
PIF3     lbyts,2   x6,a4,x0,4
         addaq     a4,a4,6
         brrne     x6,x5,pif3          .if not found
         brdir     a4,x0               .process routine
.
.        entry to process invalid functions.
.
pif4     entp      x0,1                .abort for invalid function
         SHFX      X0,X0,X0,47
         SX        X0,a_psa,xp_cx0     .STORE ILLEGAL FUNCTION BIT
         BRREQ     X0,X0,IIP
.
.        define macro FN017 to generate table of 017 functions.
.
fn017#v  set       0
.
         PROC
fn017    pname
         do        fn017#v=0
reqtable equ       $-4
fn017#v  set       1
         dend
         do        sn:(f:(2,0))=sn:(end)
req_end  vfd,16    0
         else
         vfd,16    f:(2,0)
         brreq     x0,x0,f:(2,1)
         dend
         PEND
         PAGE
...
.        BCM        - SIMULATE BLOCK CM MOVE.
.
.        THIS SUBROUTINE  SIMULATES  THE  EXECUTION  OF  THE  EXTENDED
.        011/012  *RE*/*WE* ECS INSTRUCTIONS.  THIS ROUTINE IS ENTERED
.        WHEN  A  017  TRAP  IS  OCCURS  AND  IT  VALIDATES  THAT  THE
.        INSTRUCTION IS ON A WORD BOUNDARY AND THAT THE SUBFUNCTION IS
.        EITHER A *RE* OR *WE* SIMULATED FUNCTION  CODE.   THIS  BLOCK
.        MOVE  PROVIDES FOR A CM TO ECS, ECS TO CM, AND CM TO CM COPY.
.        IN EVERY CASE, THE MOVE PROCEEDS FROM LOW TO HIGH MEMORY  AND
.        OVERLAPPING  MOVES  WHERE THE DESTINATION OVERLAPS THE SOURCE
.        ARE NOT PROVIDED FOR.  AFTER EVERY 56 WORD BLOCK A  CHECK  IS
.        MADE FOR A PP EXCHANGE.  IF THE PP EXCHANGE BIT IS SET IN THE
.        MCR,  A  RETURN  IS MADE TO THE C170 STATE AFTER FIRST SAVING
.        THE COUNT OF BLOCKS COPIED IN THE INSTRUCTION BITS 18-30  AND
.        SETTING  THE  RESUME  BIT  IN  THE EXIT MODE FLAGS.  WHEN THE
.        INSTRUCTION IS SUBSEQUENTLY RE-EXECUTED THE  SIMULATION  WILL
.        BE  RESUMED  AT THE POINT OF INTERRUPTION.  THE FORMAT OF THE
.        SIMULATED INSTRUCTION IS THE FOLLOWING.
.
.        9/017, 3/B, 3/0, 15/V, 9/R, 18/K
.
.        B = B-REGISTER TO  USE FOR COMPUTING TRANSFER LENGTH.
.        V = 00701 - FOR *RE*,  00702 - FOR *WE*.
.        R = BLOCKS TRANSFERED IF INTERRUPTED.
.        K = CONSTANT USED FOR COMPUTING TRANSFER LENGTH.
.
.        X0 = 1/C, 29/CM, 1/F, 29/ECS
.
.        C = FLAG FOR CM TO CM COPY.
.        CM= CM ADDRESS FOR TRANSFER.
.        F = FLAG REGISTER BIT.
.        ECS=ECS/CM ADDRESS FOR TRANSFER.
.
.        ENTRY CONDITIONS
.
.        (a_nos) = NOS os pva.
.        (a_rac) = Pva of job fl.
.        (a8)    = Pva of jobs program counter.
.        (x_reg1)= B-register designator.
.        (x_flc) = Fl of C170 job.
.        (xc)    = Instruction causing trap.
.        (x5)    = Function from instruction.
.        (x6)    = o'701'
.        (X8)    = C170 X0 REGISTER.
.
bcm      addxq     x5,x5,-701(8)       .set flag for 011/012
         ISOM      XB,X0,5621(8)       .FORM MASK FOR K-FIELD
         ANDX      xc,XB
.
.        form RAE and FLE.
.
         lbyts,4   x2,a_psa,x0,xp_fle
         lbyts,4   x4,a_psa,x0,xp_rae
         cpyaa     a6,a_nos
         shfx      x4,x4,x0,3
         addax     a6,x4
.
.        FORM WORD COUNT OF TRANSFER (BI+K).
.
         LXI       x4,a_psa,x_reg1,xp_cb0/8*8 .B REGISTER CONTENTS
         ANDX      X4,XB               .ADD B-REGISTER TO K USING
         SHFX      x9,xc,X0,-17        .ONES COMPLEMENT ARITHMETIC
         SHFX      XD,X4,X0,-17
         ADDR      xc,x9
         ADDR      X4,XD
         ADDR      xc,X4               .xc = LENGTH OF TRANSFER
         ANDX      xc,XB               .TRIM ANY CARRY
.
.        CHECK FOR ADDRESS OUT OF RANGE CONDITION.
.
         lx        x8,a_psa,xp_cx0     .fetch c170 X0
         ISOB      XA,X8,X0,0534(8)    .FWA OF MOVE
         SHFX      X4,XA,X0,3          .FORM BYTE ADDRESS
         ADDR      XA,xc
         BRRGT     XA,x_flc,AOR1       .IF LWA OF MOVE IS BEYOND FL
         ISOB      XA,X8,X0,4334(8)    .XA=FWA IN ECS/CM
         SHFX      X8,X8,X0,4
         BRXGE     X8,X0,BCM1          .IF ECS MOVE
         CPYXX     X2,x_flc            .USE CM RA/FL INSTEAD OF ECS
         CPYAA     A6,a_rac
BCM1     SHFX      X9,XA,X0,3          .X9=BYTE ADDRESS OF FWA IN ECS/CM
         ADDR      xa,xc               .LWA IN ECS
         BRRGT     XA,X2,AOR1          .IF LWA IN ECS BEYOND FL
.
.        SET SOURCE AND DESTINATION BASED ON INSTRUCTION TYPE.
.
         cpyaa     a4,a_rac
         ADDAX     A4,X4               .A4 = ABS FWA OF MOVE IN CM
         ADDAX     A6,X9               .A6 = ABS FWA OF MOVE IN ECS/CM
         BRREQ     X5,X0,BCM2          .IF *RE* INSTRUCTION
         CPYAA     A7,A4               .SWAP SOURCE AND DESTINATION
         CPYAA     A4,A6               .FOR COPY FROM ECS TO CM
         CPYAA     A6,A7
.
.        RESTART INSTRUCTION IN MID TRANSFER IF NECESSARY.
.
BCM2     ENTL      X0,BSCIF
         ENTP      X2,0
         LBIT      XB,a_psa,xp_em+1,x0 .GET INTERRUPTED FLAG
         SBIT      X2,a_psa,xp_em+1,x0 .AND ENSURE THAT IT IS CLEAR
         ENTE      X1,4*14*8           .BLOCK COUNT IN BYTES
         ENTE      X0,0110E(16)        .LOAD MULTIPLE DESCRIPTOR
         SHFX      xf,xc,X0,3          .XF = TRANSFER LENGTH IN BYTES
         CPYXA     A5,XF               .SAVE ORIGINAL TRANSFER LENGTH
         BRREQ     XB,X0,BCM3          .IF NOT INTERUPTED
         LX        XE,a8,0
         ISOB      X3,XE,X0,4213(8)    .ISOLATE BLOCK COUNT TO X3
         INSB      XE,X2,X0,4213(8)    .CLEAR BLOCK COUNT
         SX        XE,a8,0
         MULR      X3,X1               .WORDS ALREADY TRANSFERED
         SUBR      XF,X3               .DECREMENT WORDS TO TRANSFER
         ADDAX     A4,X3               .INCREMENT SOURCE ADDRESS
         ADDAX     A6,X3               .AND DESTINATION ADDRESS
.
.        MOVE LARGE CHUNKS OF 4*14 WORDS.
.
BCM3     BRRGT     X1,XF,BCM4          .IF SMALL BLOCK TO MOVE
         LMULT     X0,A6,0
         SMULT     X0,A4,0
         LMULT     X0,A6,14*8
         SMULT     X0,A4,14*8
         LMULT     X0,A6,2*14*8
         SMULT     X0,A4,2*14*8
         LMULT     X0,A6,3*14*8
         SMULT     X0,A4,3*14*8
         ENTE      X1,4*14*8           .BLOCK SIZE IN BYTES
         SUBR      XF,X1
         ADDAX     A4,X1               .INCREMENT ADDRESSES
         ADDAX     A6,X1
         BRCR      5,3,BCM3            .IF NO C170 PP EXCHANGE
         ENTL      X0,BMF
         LBIT      XB,a_psa,xp_mf,X0   .FETCH MONITOR FLAG
         ENTE      X0,0110E(16)
         BRRNE     XB,X0,BCM3          .IF MOVE IN MONITOR MODE
         CPYAX     X3,A5               .RETRIEVE STARTING WORD COUNT
         SUBR      X3,XF               .WORDS TRANSFERED
         DIVR      X3,X1               .FORM BLOCK COUNT
         LX        XF,a8,0             .INSTRUCTION
         INSB      XF,X3,X0,4213(8)    .INSERT BLOCK COUNT
         SX        XF,a8,0
         BRREQ     X0,X0,PII02
.
.        MOVE UP TO 3 CHUNKS OF 15 WORDS.
.
BCM4     ENTX      X1,14*8
         BRRGE     X1,XF,BCM6          .IF SMALLER THEN A SMALL CHUNK
BCM5     LMULT     X0,A6,0
         SMULT     X0,A4,0
         ENTX      X1,14*8
         ADDAX     A4,X1               .INCREMENT ADDRESSES
         ADDAX     A6,X1
         SUBR      XF,X1
         BRRGT     XF,X1,BCM5          .CHECK FOR MORE TRANSFERS
.
.        MOVE LAST CHUNK OF 0-14 WORDS.
.
BCM6     ENTE      X0,01100(16)
         BRREQ     XF,X0,trap4         .IF NO WORDS TO TRANSFER
         SHFX      XF,XF,X0,-3         .COUNT OF WORDS REMAINING
         IORX      X0,XF               .FORM DESCRIPTOR FOR LAST TRANSFER
         LMULT     X0,A6,0
         SMULT     X0,A4,0
         BRREQ     X0,X0,trap4         .RETURN WITH INSTRUCTION COMPLETE
         page
.
.        read_set_pit
.
.        This instruction allows the C170 monitor to more accuratly
.        track the time used by a 170 job running in dual state.
.
.        9/017, 3/0, 3/0, 15/00040, 30/0
.
.        X0 = Contents of PIT when read.
.
read_set_pit bss   0
         ente      x3,0c9(16)          .PIT register
         cpysx     x1,x3
         sxi       x1,a_psa,x0,xp_cx0
         entn      x1,1
         cpyxs     x1,x3               .reset PIT
         brreq     x0,x0,trap4         .return
         page
.
.        BMI       - Buffer Memory Invalidate.
.
.        This instruction allows the C170 monitor to purge cache.
.
.        9/017, 3/Xj, 3/Xk, 15/00703, 30/0
.
.        Xj = FWA of memory to purge relative to cyber 170 exchange package RA.
.        Xk = Length of memory (in words) to purge.
.
.        ENTRY CONDITIONS.
.
.        (a_nos) = NOS os pva.
.        (x_reg1)= ordinal of Xj.
.        (x_reg2)= ordinal of Xk.
.        (x_flc) = Field length of MONITOR.
.
bmi      lxi       x_reg1,a_psa,x_reg1,xp_cx0
         lxi       x_reg2,a_psa,x_reg2,xp_cx0
         isob      x_reg1,x_reg1,x0,0473(8)  .isolate 60 bits
         isob      x_reg2,x_reg2,x0,0473(8)  .isolate 60 bits
         brxge     x_reg1,x0,bmi1      .if cm cache purge
         lbyts,4   x6,a_psa,x0,xp_rae  .RA for ecs
         lbyts,4   x_flc,a_psa,x0,xp_fle .FL for ecs
         shfx      x6,x6,x0,3
         ents      x_reg1              .clear upper part of address
         cpyaa     a_rac,a_nos
         addax     a_rac,x6            .form pva for rae
bmi1     bss       0
         shfx      x8,x_reg2,x0,-9+3   .length in bytes/512.
         addx      x_reg2,x_reg1
         brrge     x_reg2,x_flc,aor    .if bad address combination
         shfx      x6,x_reg1,x0,3
         shfx      x7,x_reg2,x0,3
         cpyax     x5,a_rac
         ente      x_reg2,64
         addx      x6,x5
         addx      x7,x5
         brrge     x_reg2,x8,bmi2      .if purge of less than cache size.

.        Purging more than size of cache, purge all of cache, it is quicker.

         purge     x6,2                .purge all cache.
         brreq     x0,x0,trap4         .return.

bmi2     purge     x6,3                .purge cache for 512 block of cm
         addxq     x6,x6,512
         brrgt     x7,x6,bmi2          .if more cache to purge
         purge     x6,3
         brreq     x0,x0,trap4         .cache purge complete
         page
.
.        IHF - Inject hardware fault.
.                  This function issues the special instructions that will cause
.                  specific hardware faults.
.
.        DESIGN:
.                  Special microcode is required that actually causes the desired
.                  hardware fault.  The special microcode recoginizes specific
.                  unimplemented instructions that are issued and dependent on the
.                  J and K fields causes a specific fault.  The J field specifies the
.                  kind of hardware fault and the K field specifies an X register
.                  that contains the RMA of a word in memory with a parity error.
.                  This word in memory has to be preconditioned with a parity error
.                  before deadstart using CMSE or MDD.
.
.        ENTRY:
.                  9/017, 3/Xi, 3/Xj, 15/2777, 30/0
.                  Xi = 40/0,
.                       8/mode, =0 implies job, =1 implies monitor.
.                       8/traps enabled, =0 implies traps disabled, =1 implies traps
.                         enabled.
.                       8/fault kind.
.                  Xj = RMA of word in memory with parity error.
.
.                  (a_nos) = NOS os pva.
.                  (x_reg1) = ordinal of Xi.
.                  (x_reg2) = ordinal of Xj.
.
.        EXIT:
.                  Specified hardware fault is injected if no errors.
.
.                  Exit is to 'trap2' if control is returned after fault injected
.                  or errors in parameters, following values returned in X0 of
.                  callers stack frame (170):
.                     30/1, implies NOS/VE not up.
.                     30/error code, = 0 implies no error, = 1 implies unknown
.                        hardware fault kind.
.

ihf      bss       0
         lxi       x_reg1,a_psa,x_reg1,xp_cx0
         lxi       x_reg2,a_psa,x_reg2,xp_cx0  .RMA of word in memory with parity
                                               . error.
         isob      xa,x_reg1,x0,(40*64)+7  .Mode, monitor or job.
         isob      x6,x_reg1,x0,(48*64)+15  .Trap enable flag and fault kind.
         isob      x5,x_reg1,x0,(56*64)+7  .Fault kind.
         brreq     xa,x0,ihf5          .If job mode.

.        Cause error in monitor mode, issue request to monitor to cause error.  Format
.        of request is as follows:
.                  X0 = 16/0
.                       8/traps enabled flag.
.                       8/fault kind.
.                       32/monitor request code.
.                  X1 = RMA of parity error.

         entp      x0,mtrr#ihf
         shfc      x6,x6,x0,32
         cpyxx     x1,x_reg2           .RMA of parity error.
         iorx      x0,x6               .Monitor request code and parameters for
                                       . request.
         exchange                      .Process monitor request.
         brreq     x0,x0,ihf15         .Return with error status.

.        Inject desired fault in job mode.

ihf5     bss       0
         ente      xa,ihfpl            .jump table length.
         shfc      x5,x5,x0,1          .(jump table index)/2.
         entp      x2,0                .Set known hardware fault kind.
         brrge     xa,x5,ihf10         .If known hardware fault kind.
         entp      x2,1                .Set unknown hardware fault kind.
ihf10    bss     0
         brreq     x2,x0,ihf20         .If known hardware fault kind.

.        Return with error status.

ihf15    bss       0
         cpyxx     x0,x2
         brreq     x0,x0,trap2         .Return with error.

.        x2 = 0, no error.
.        x5 - (jump table index)/2.

ihf20    bss       0
         addpxq    aa,x5,ihfp          .address in jump table to process
                                       . hardware fault kind.
         brdir     aa,x0               .cause specified hardware fault.


.        Define a jump table for each hardware fault kind to cause.

ihfp     bss       0
         brreq     x0,x0,retry         .cause successful retry.
         brreq     x0,x0,exchange      .cause exchange fault.
         brreq     x0,x0,itrap         .cause trap fault.
         brreq     x0,x0,halt          .cause halt fault.
         brreq     x0,x0,pdm_halt      .cause pdm halt fault.
         brreq     x0,x0,swerr         .software error, error stop.
ihfpl    equ       $-ihfp              .length of jump table.


..
.        CMM - Clear synchronous bits in monitor mask register to force processor
.              halt in job mode.  This is required for error processing to work
.              correctly for some errors.
.
.        ENTRY:
.                  Aa = return address.
.
.        EXIT:
.                  The synchronous monitor mask bits in this task's exchange
.                  package are cleared.
.

cmm      bss       0                   .entry.
         ente      x6,80(16)           .subfunction request to clear synchronous
                                       . monitor mask bits.
         entp      x0,mtrr#ihf         .monitor request code.
         shfc      x6,x6,x0,32
         iorx      x0,x6
         exchange
         brdir     aa,x0               .Return.

.        Cause successful retry error.

retry    bss     0
         vfd,32    0fd0e0000(16)       .condition microcode.
         vfd,32    0fe0e0000(16)       .cause hardware fault.
         brreq     x0,x0,ihf15         .Return.

.        Cause exchange error.

exchange bss     0
         vfd,32    0fd1e0000(16)       .condition microcode.
         vfd,32    0fe1e0000(16)       .cause hardware fault.
         brreq     x0,x0,ihf15         .Return.

.        Cause trap error.

itrap    bss     0
         vfd,32    0fd2e0000(16)       .condition microcode.
         vfd,32    0fe2e0000(16)       .cause hardware fault.
         brreq     x0,x0,ihf15         .Return.

.        Cause halt error.

halt     bss     0
         addpxq    aa,x0,halt5         .return address.
         brreq     x0,x0,cmm           .clear bits in monitor mask to halt processor
                                       . on error.
halt5    bss       0
         vfd,32    0fd3e0000(16)       .condition microcode.
         vfd,32    0fe3e0000(16)       .cause hardware fault.
         brreq     x0,x0,ihf15         .Return.

.        Cause PDM halt error.

pdm_halt bss     0
         vfd,32    0fd4e0000(16)       .condition microcode.
         vfd,32    0fe4e0000(16)       .cause hardware fault.
         brreq     x0,x0,ihf15         .Return.

.        Cause software error, error stop.

swerr    bss     0
         addpxq    aa,x0,swerr5        .return address.
         brreq     x0,x0,cmm           .clear bits in monitor mask to halt processor
                                       . on error.
swerr5   bss       0
         halt
         brreq     x0,x0,ihf15         .Return.

         page
.
.        minilink - c170 | c180 memory transfer routine.
.
.        entry :
.
.        TRAP    Xi,Xj,1001
.
.        Xi = pointer to parameter block.
.        Xj = pointer to the data block.
.
.        Parameter block format.
.
. Xi +0  length = words of c170 data to be copied.
. Xi +1  packing type =
.           0 = nos to nos/ve, 60 to 64.
.           1 = nos/ve to nos, 64 to 60.
.           2 = nos to nos/ve, 32 to 64.
.           3 = nos/ve to nos, 64 to 32.
.           4 = nos to nos/ve, 60 to 60.
.           5 = nos/ve to nos, 60 to 60.
.           6 = clear nos/ve memory.
. Xi +2  address space descriptor in bits 56 to 63.
.           0 = from/to dual state control block.
.           1 = from/to NOS/VE proper.
.           2 = from/to SSR.
.           3 = from/to NOS/VE mainframe wired.
.           4 = from DFT buffer, pva must be established previously.
. Xi +3  Byte offset from C180 PVA.
.
. Xj +0  data area for copy.
.
minilink bss       0
.
.        fetch and verify x_reg1 and x_reg2.
.
         lxi       x8,a_psa,x_reg1,xp_cx0
         brrge     x8,x_flc,aor1       .if outside fl
         shfx      x9,x8,x0,3
         incr      x8,4
         brrge     x8,x_flc,aor1       .if outside fl
         lxi       x8,a_psa,x_reg2,xp_cx0 .fetch address of data
         brrge     x8,x_flc,aor1       .if outside fl
.
.        fetch data length and verify data block within fl.
.
         lbyts,2   xa,a_rac,x9,6       .fetch data length
         shfx      xb,x8,x0,3          .byte offset from ra
         addr      x8,xa
         brrgt     x8,x_flc,aor1       .if outside fl
         cpyaa     ab,a_rac
         addax     ab,xb               .start of data area
.
.        form pva descriptor.
.
         lbyts,1   x4,a_rac,x9,2*8+7   .fetch nos/ve pva descriptor
         ente      x2,pva_table_len
         shfx      x4,x4,x0,3
         brrge     x4,x2,iip           .if invalid pva
         lbyts,6   x7,a_static,x4,pva_table
         brxeq     x7,x0,iip           .if pva not defined
         cpyxa     aa,x7
.
.        fetch and verify packing type.
.
         lbyts,1   x7,a_rac,x9,8+7     .fetch packing type
         shfx      x7,x7,x0,1
         ente      x2,cptbll
         brrge     x7,x2,iip           .if not valid packing type
         addpxq    a7,x7,cptbl
.
.        fetch and verify offset to pva.
.
         lbyts,4   x8,a_rac,x9,3*8+4   .fetch offset to pva
         addax     aa,x8
         tpage     x1,aa
         brrge     x0,x1,aor1          .if page not present
         cpyaa     a8,aa
         shfx      x7,x7,x0,-2
         addpxq    a6,x0,cptbm         .multiplier for data length
         lbyts,1   x7,a6,x7,0
         mulr      x7,xa
         shfx      x9,x7,x0,-1
         decr      x9,1                .position of final byte
         addax     a8,x9
         tpage     x1,a8
         brrge     x0,x1,aor1          .if final page missing
         cpyax     x1,aa
         purge     x1,3                .purge cache at start of block
.
.        special case check for the DSCB.
.
         addr      x9,x8               .offset of last byte to move.
         brrne     x4,x0,mini1         .if source/dest not dscb
         ente      x2,dscbl+15         .add 15 to allow for even block size
         brrgt     x9,x2,aor1          .if outside dscb
         brreq     x0,x0,mini14        .complete transfer.
.
.        Verify address within DFT buffers.
.
mini1    bss       0
         ente      x6,4*8
         brrne     x4,x6,mini14        .if source not DFT buffer.
         lbyts,6   x3,a_static,x0,pva_of_first_dftb
         lbyts,2   x6,a_static,x4,pva_table-2  .DFT buffer index.
         brxeq     x3,x0,iip           .if pva not defined.
         cpyxa     a8,x3
         lxi       x7,a8,x6,0          .word to determine length of DFT buffer.
         brrne     x6,x0,mini11        .if not initial part of DFT buffer.
.
.        Determine length of fixed portion of DFT buffer.  This is done in one
.        of two ways depending on the DFT revision level.  Because the length
.        of the 170 CM block size must be an even number, 15 must be added to
.        the length in either case.
.
.        For revision level = 1 the length of the fixed DFT buffer equals
.            the number of maintenance register buffers (nbuf) * 8 + the length
.            of the mainframe element counters buffer (mecbl) + the length of
.            the fixed portion of the DFT buffer (dftbfl) + 15 (to allow for an
.            even block size).
.
.        For revision level > 1 the length of the fixed DFT buffer equals
.            the number of maintenance register buffers (nbuf) * 8 + the length
.            of the mainframe element counters buffer (mecbl) + the number of
.            pointer words (po) * 8 + 15 (to allow for an even block size).
.

         isob      x6,x7,x0,(40*100(8)+7)  .nbuf, number of maintenance
                                           .register buffers.

         isob      xb,x7,x0,(16*100(8)+7)  .DFT revision level.
         isob      x2,x7,x0,(4*100(8)+3)  .po, number of buffer pointers.
         ente      x7,dftbfl+mecbl+15  .initialize for revision level = 1.
         entp      x3,1
         brreq     x3,xb,mini9         .if revision level = 1.
         shfx      x2,x2,x0,3          .po*8.
         ente      x7,mecbl+15         .length of mainframe element counters.
         addr      x7,x2
mini9    shfx      x6,x6,x0,3          .nbuf*8.
         addr      x7,x6               .length of fixed part of DFT buffer.
         brrgt     x9,x7,aor1          .if outside of DFT buffer.
         brreq     x0,x0,mini14        .complete transfer.
.
.        Check if within variable portion of DFT buffer.
.
mini11   bss       0
         isob      x6,x7,x0,6017(8)
         shfx      x6,x6,x0,3
         ente      x7,15               .add 15 to allow for even block size
         addr      x6,x7
         brrgt     x9,x6,aor1          .if outside of variable part of DFT buffer.
.
.        preset and check for instruction interrupt.
.
mini14   entp      x6,0
         entp      x7,0
         entl      x0,bscif
         lbit      xb,a_psa,xp_em+1,x0 .fetch interrupted bit
         brreq     xb,x0,mini15        .if not interrupted
         entp      xb,0
         sbit      xb,a_psa,xp_em+1,x0 .clear interrupted bit
         lbyts,3   x6,a_psa,x0,xp_cx0+1
         lbyts,3   x7,a_psa,x0,xp_cx0+4
mini15   entp      x0,0
         brdir     a7,x0               .branch into table
.
cptbl    bss       0
         brreq     x0,x0,nv60to64      .pack 60 to 64
         brreq     x0,x0,vn64to60      .unpack 64 into 60
         brreq     x0,x0,nv32to64      .pack 32 into 64
         brreq     x0,x0,vn64to32      .unpack 64 into 32
         brreq     x0,x0,nv60to60      .copy nos to nos/ve
         brreq     x0,x0,vn60to60      .copy nos/ve to nos
         brreq     x0,x0,clearve       .clear nos/ve cm
cptbll   equ       $-cptbl
.
cptbm    bss       0
         vfd,8     15                  .60 - 64 bit packing
         vfd,8     8                   .32 - 64 bit packing
         vfd,8     16                  .60 - 60 bit packing
         vfd,8     16                  .memory clear
.
.
.
nv60to64 bss       0                   .pack 60 into 64
         isob      x9,xa,x0,7700(8)
         brrne     x9,x0,aor1          .if not even sized block
mini2    lxi       x3,ab,x6,0
         lxi       x2,ab,x6,8
         insb      x2,x3,x0,0003(8)
         shfx      x3,x3,x0,-4
         sbyts,7   x3,aa,x7,0
         sbyts,8   x2,aa,x7,7
         incr      x7,15
         incr      x6,2
         brrge     x6,xa,trap2         .if copy complete
         brcr      5,3,mini2           .if no pending exchange
         brreq     x0,x0,mini6         .process exchange interrupt
.
nv32to64 bss       0                   .pack 32 into 64
         lxi       x2,ab,x6,0
         sbyts,4   x2,aa,x7,0
         incr      x7,4
         incr      x6,1
         brrge     x6,xa,trap2         .if copy complete
         brcr      5,3,nv32to64        .if no exchange pending
         brreq     x0,x0,mini6         .process exchange interrupt
.
nv60to60 bss       0                   .copy 60 to 60
         isob      x1,x8,x0,7502(8)
         brrne     x1,x0,iip           .if invalid starting pva
mini3    bss       0
         lxi       x2,ab,x6,0
         isob      x2,x2,x0,(4*64)+59  .Ensure bits 0 to 3 are zero
         sxi       x2,aa,x7,0
         incr      x7,1
         incr      x6,1
         brrge     x6,xa,trap2         .if copy complete
         brcr      5,3,mini3           .if no exchange pending
         brreq     x0,x0,mini6         .process exchange interrupt
.
vn64to60 bss       0                   .pack 64 into 60
         isob      x9,xa,x0,7700(8)
         brrne     x9,x0,aor1          .if not even sized block
mini4    lbyts,8   x2,aa,x7,0
         lbyts,7   x3,aa,x7,8
         insb      x3,x2,x0,0403(8)
         shfx      x2,x2,x0,-4
         sxi       x2,ab,x6,0
         sxi       x3,ab,x6,8
         incr      x6,2
         incr      x7,15
         brrge     x6,xa,trap2         .if copy complete
         brcr      5,3,mini4           .if no exchange pending
         brreq     x0,x0,mini6         .process exchange interrupt
.
vn64to32 bss       0                   .pack 64 into 32
         lbyts,4   x2,aa,x7,0
         sxi       x2,ab,x6,0
         incr      x7,4
         incr      x6,1
         brrge     x6,xa,trap2         .if copy complete
         brcr      5,3,vn64to32        .if no exchange pending
         brreq     x0,x0,mini6         .process exchange interrupt
.
vn60to60 bss       0                   .copy data
         isob      x1,x8,x0,7502(8)
         brrne     x1,x0,iip           .if invalid starting pva
mini5    bss       0
         lxi       x2,aa,x7,0
         sxi       x2,ab,x6,0
         incr      x7,1
         incr      x6,1
         brrge     x6,xa,trap2         .if copy complete
         brcr      5,3,mini5           .if no exchange pending
         brreq     x0,x0,mini6         .process exchange interrupt
.
clearve  bss       0                   .clear nos/ve memory
         sbyts,8   x0,aa,x7,0
         incr      x6,1
         incr      x7,8
         brrge     x6,xa,trap2         .if copy complete
         brcr      5,3,clearve         .if no exchange pending
mini6    sbyts,3   x6,a_psa,x0,xp_cx0+1
         sbyts,3   x7,a_psa,x0,xp_cx0+4
         brreq     x0,x0,pii02         .do instruction interrupt
         page
.
.        fetch_pva - Return the value of the specified PVA into Xk.
.
.        Instruction format.
.        017jk 01003 0000000000
.
.        Xj = PVA descriptor.
.          0 = Environment Interface Communications block.
.          1 = Optional PVA 1.
.          2 = Optional PVA 2.
.          3 = Optional PVA 3.
.
fetch_pva bss      0
         lxi       x1,a_psa,x_reg1,xp_cx0  .fetch PVA descriptor
         shfx      x1,x1,x0,3
         brrgt     x0,x1,iip           .if illegal PVA
         ente      x3,pva_table_len
         brrge     x1,x3,iip           .if invalid PVA descriptor
         lbyts,6   x2,a_static,x1,pva_table
         ents      x2                  .clear ring and segment
         sxi       x2,a_psa,x_reg2,xp_cx0  .store PVA value
         brreq     x0,x0,trap2         .exit
.
.***  End common deck OSI$PRIVILAGED_170_INSTRUCTIONS
*DECK DECK=OSI$XCB_FOR_CURRENT_TASK EXPAND=FALSE
.
.  This macro calculates the address of the XCB of the current task.
.          laxcbp    ak,xj
.             ak - destination register for ^XCB.
.             xj - scratch register
.
         PROC
laxcbp   pname
f:(0)    ente      f:(2,1),r_bc      .Read base constant
         cpysx     f:(2,1),f:(2,1)
         shfx      f:(2,1),f:(2,1),x0,32
         addxq     f:(2,1),f:(2,1),1000(16)+snjfjob
         shfc      f:(2,1),f:(2,1),x0,32
         cpyxa     f:(2,0),f:(2,1)
         pend
.
*copyc SYA$CONSTANTS
*copyc sya$xp_and_sf_constants
*DECK DECK=OSK$COMMON_KEYPOINT_DEFINITIONS EXPAND=FALSE

  CONST

    {  Keypoint Classes :
    {
    {       The 16 keypoint classes supported by the hardware are partitioned
    {  between the System, Product Set and User as follows.

    osk$system_class = 0      {  0 ..  5 },
    osk$product_set_class = 6 {  6 .. 10 },
    osk$user_class = 11       { 11 .. 14 },
    osk$pmf_control = 15;


    {  Keypoint Multiplier:
    {
    {       By convention, the 32 bit keypoint code supported by the hardware
    {  is split into two fields.  The right field contains a keypoint
    {  identifier which is used to identify a function within a keypoint class.
    {  For example, if a particular keypoint class represents exit from a
    {  procedure, then the keypoint identifier might identify exit from
    {  procedure A versus exit from procedure B.
    {       The left field is used as a data parameter appropriate to the
    {  function identified by the keypoint identifier.  In the procedure exit
    {  example above, the data parameter field might be used to indicate the
    {  status of the procedure call.
    {       The keypoint multiplier is used to partition the keypoint code
    {  into the two fields.  The data parameter should be multiplied by the
    {  keypoint multiplier to prevent it from overlapping the keypoint
    {  identifier field.

  CONST
    osk$monitor_multiplier = 8192,
    osk$m = 4096;
*DECK DECK=OSK$KEYPOINTS EXPAND=FALSE

  CONST
    osk$generate_message = osk$base + 0,
      {E  'osp$generate_message'    }
      {X  'osp$generate_message'    }

    osk$format_message = osk$base + 1,
      {E  'osp$format_message'    }
      {X  'osp$format_message'    }

    osk$get_status_severity = osk$base + 2,
      {E  'osp$get_status_severity'    }
      {X  'osp$get_status_severity'    }

    osk$set_status_abnormal = osk$base + 3,
      {E  'osp$set_status_abnormal'    }
      {X  'osp$set_status_abnormal'    }

    osk$set_status_from_condition = osk$base + 6,
      {E  'osp$set_status_from_condition'    }
      {X  'osp$set_status_from_condition'    }

    osk$await_activity_completion = osk$base + 7,
      {E  'osp$await_activity_completion'    }
      {X  'osp$await_activity_completion'    }

    osk$get_message_level = osk$base + 8,
      {E  'osp$get_message_level'    }
      {X  'osp$get_message_level'    }

    osk$generate_error_message = osk$base + 9,
      {E  'osp$generate_error_message'    }
      {X  'osp$generate_error_message'    }

    osk$initialize_signature_lock = osk$base + 10,
      {E  'osp$initialize_signature_lock'    }
      {X  'osp$initialize_signature_lock'    }

    osk$set_signature_lock = osk$base + 11,
      {E  'osp$set_signature_lock'    }
      {X  'osp$set_signature_lock'    }

    osk$clear_signature_lock = osk$base + 12,
      {E  'osp$clear_signature_lock'    }
      {X  'osp$clear_signature_lock'    }

    osk$test_signature_lock = osk$base + 13,
      {E  'osp$test_signature_lock'    }
      {X  'osp$test_signature_lock'    }

    osk$recoverable_system_error = osk$base + 14,
      {E 'osp$recoverable_system_error' 'callring' I20 }
      {X 'osp$recoverable_system_error' }

    osk$i_await_activity_completion = osk$base + 15,
      {E  'osp$i_await_activity_completion'    }
      {X  'osp$i_await_activity_completion'    }


    osk$allocate = osk$base + 47,
      {D  'allocate' 'segment ' H16 }

    osk$free = osk$base + 48,
      {D  'free' 'segment ' H16 }

    osk$reset_heap = osk$base + 49;
      {D  'reset' 'segment ' H16 }


*copyc AMK$BASE_KEYPOINT_VALUES
*DECK DECK=OSK$KEYPOINT_CLASS_CODES EXPAND=FALSE
{Define KEYPOINT CLASS Codes.

  CONST
    osk$data = osk$system_class + 0, { OS - DATA keypoint}
    osk$unusual = osk$system_class + 1, {U OS - Unusual keypoint class.}
    osk$entry = osk$system_class + 2, {E OS - Standard keypoint (gated or major internal)}
    osk$exit = osk$system_class + 3, {X OS - Exit keypoint}
    osk$debug = osk$system_class + 4, {D OS - Debug keypoint.}
    osk$mtr = osk$system_class + 5, {R OS - monitor mode entry/exit}
    osk$performance = osk$system_class + 11; {R OS -performance keypoints}

*copyc OSK$COMMON_KEYPOINT_DEFINITIONS
*DECK DECK=OSK$TAPE_KEYPOINTS EXPAND=FALSE

  CONST
   base = iok$base+50,
    ioc$tape_exit_ioptun = base,
    ioc$tape_exit_ioptf = base+1,
    ioc$tape_exit_ioptqsu = base+2,
    ioc$tape_exit_ioptrqs = base+3,
    ioc$tape_exit_ioptwr = base+4,
    ioc$tape_exit_ioptwtm = base+5,
    ioc$tape_exit_ioptdse = base+6,
    ioc$tape_exit_iopte = base+7,
    ioc$tape_exit_ioptin = base+8,
    ioc$tape_exit_ioptqrq = base+9,
    ioc$tape_exit_ioptrd = base+10,
    ioc$tape_exit_ioptrew = base+11,
    ioc$tape_exit_ioptsb = base+12,
    ioc$tape_exit_ioptsf = base+13,
    ioc$tape_entry_iopterr = base+14,
    ioc$tape_entry_ioptqrq = base+15,
    ioc$tape_entry_ioptqsu = base+16,
    ioc$tape_entry_ioptitb = base+17,
    ioc$tape_exit_ioptitb = base+18,
    ioc$tape_entry_ioptf = base+19,
    ioc$tape_entry_ioptrqs = base+20,
    ioc$tape_entry_ioptun = base+21,
    ioc$tape_entry_ioptclr = base+22,
    ioc$tape_entry_ioptdnc = base+23,
    ioc$tape_entry_ioptdnu = base+24,
    ioc$tape_entry_ioptopm = base+25,
    ioc$tape_entry_ioptppe = base+26,
    ioc$tape_entry_ioptrio = base+27,
    ioc$tape_entry_ioptum = base+28,
    ioc$tape_entry_ioptuns = base+29,
    ioc$tape_entry_ioptrwr = base+30,
    ioc$tape_entry_ioptptr = base+31,
    ioc$tape_debug_ioptptr = base+33,
    ioc$tape_entry_ioptsck = base+34,
    ioc$tape_debug_ioptsck = base+35,
    ioc$tape_enter_ioptwr = base+36,
    ioc$tape_debug_ioptrsu = base+38,
    ioc$tape_entry_ioptrd = base+39,
    ioc$tape_exit_ioptrdb = base+40,
    ioc$tape_exit_ioptrpb = base+43,
    ioc$tape_exit_ioptrpf = base+44,
    ioc$tape_exit_ioptvp = base+45,
    ioc$tape_enter_iopterm = base+46,
    ioc$tape_exit_ioptgus = base+47,
    ioc$tape_entry_iomtirs = base+48,
    ioc$tape_exit_iomtirs = base+49;

*copyc OSK$KEYPOINTS
*DECK DECK=OSM$APPEND_STATUS_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Append File Parameter to Status' ??
MODULE osm$append_status_file;

{
{ PURPOSE:
{   This module contains the routine to append a path name to the text of a status record.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc fst$path
*copyc fst$path_index
*copyc fst$path_size
*IF NOT $true(osv$unix)
*copyc osc$compression_identifier
*IFEND
?? POP ??
*copyc clp$trimmed_string_size
*copyc osp$append_status_parameter

*IF NOT $true(osv$unix)
*copyc clv$user_identification
*IFEND
*copyc osv$lower_to_upper

  CONST
    local_path = ':$LOCAL.',
    local_path_size = 8,
*IF NOT $true(osv$unix)
    minimum_file_reference_length = 3,
    system_path = ':$SYSTEM.$SYSTEM.',
    system_path_size = 17;
*ELSE
    minimum_file_reference_length = 3;
*IFEND

?? TITLE := 'osp$append_status_file', EJECT ??
*copyc osh$append_status_file

  PROCEDURE [XDCL, #GATE] osp$append_status_file
    (    delimiter: char;
         file: fst$file_reference;
     VAR status {input, output} : ost$status);

    VAR
      allowed_path_size: ost$string_size,
      compressed_file_reference_size: fst$path_size,
      ignore_status: ost$status,
      status_text_size: ost$string_size;

    IF status.normal THEN
      RETURN;
    IFEND;

    status_text_size := status.text.size; {prevent value from changing.}
    allowed_path_size := (osc$max_string_size - status_text_size) DIV 2;
    IF allowed_path_size < minimum_file_reference_length THEN
      RETURN;
    IFEND;

    status_text_size := status_text_size + 1;
    status.text.value (status_text_size) := delimiter;
    osp$compress_file_reference (file, status.text.value (status_text_size + 1, allowed_path_size),
          compressed_file_reference_size, ignore_status);
    status.text.size := status_text_size + compressed_file_reference_size;

  PROCEND osp$append_status_file;

?? TITLE := 'osp$compress_file_reference', EJECT ??
*copyc osh$compress_file_reference

  PROCEDURE [XDCL, #GATE] osp$compress_file_reference
    (    file_reference: fst$file_reference;
     VAR compressed_file_reference: fst$file_reference;
     VAR compressed_file_reference_size: fst$path_size;
     VAR status: ost$status);

    VAR
      compressed_length: fst$path_size,
      compressed_file_index: fst$path_index,
      compression_character: char,
      remaining_compressed_length: fst$path_size,
      remaining_path_size: fst$path_size,
      file_reference_length: fst$path_size,
      path: fst$path,
      replaced_path_size: fst$path_size,
      split_size: fst$path_size;

    status.normal := TRUE;
*IF NOT $true(osv$unix)
    #TRANSLATE (osv$lower_to_upper, file_reference, path);
*ELSE
    path := file_reference;
*IFEND
    file_reference_length := clp$trimmed_string_size (file_reference);
    compressed_length := STRLENGTH (compressed_file_reference);

    IF compressed_length < minimum_file_reference_length THEN
      IF compressed_length > 0 THEN
        compressed_file_reference := '?';
        compressed_file_reference_size := 1;
      ELSE
        compressed_file_reference_size := 0;
      IFEND;
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    IF (file_reference_length >= local_path_size) AND (path (1, local_path_size) = local_path) THEN
      compression_character := 'L';
      replaced_path_size := local_path_size;
    ELSEIF (file_reference_length >= system_path_size) AND (path (1, system_path_size) = system_path) THEN
      compression_character := 'S';
      replaced_path_size := 17;
    ELSEIF (file_reference_length >= (clv$user_identification.family.size + 2)) AND (path (1) = ':') AND
          (path (2, clv$user_identification.family.size) = clv$user_identification.family.
          value (1, clv$user_identification.family.size)) AND
          (path (clv$user_identification.family.size + 2, 1) = '.') THEN
      compression_character := 'F';
      replaced_path_size := clv$user_identification.family.size + 2;
      IF (file_reference_length >= (clv$user_identification.family.size + clv$user_identification.user.size +
            3)) AND (path (clv$user_identification.family.size + 3,
            clv$user_identification.user.size) = clv$user_identification.user.
            value (1, clv$user_identification.user.size)) AND
            (path (clv$user_identification.family.size + clv$user_identification.user.size + 3) = '.') THEN
        compression_character := 'U';
        replaced_path_size := clv$user_identification.family.size + clv$user_identification.user.size + 3;
      IFEND;
    ELSE
*IFEND
      compression_character := ' ';
      replaced_path_size := 0;
*IF NOT $true(osv$unix)
    IFEND;
*IFEND

*IF NOT $true(osv$unix)
    IF (file_reference_length > compressed_length) AND (compression_character = ' ') THEN
      compression_character := 'C';
    IFEND;
*IFEND

*IF NOT $true(osv$unix)
    IF compression_character <> ' ' THEN
      compressed_file_reference (1, 1) := osc$compression_identifier;
      compressed_file_reference (2, 1) := compression_character;
      compressed_file_index := 3;
      remaining_compressed_length := compressed_length - 2;
    ELSE
*IFEND
      compressed_file_index := 1;
      remaining_compressed_length := compressed_length;
*IF NOT $true(osv$unix)
    IFEND;
*IFEND

    remaining_path_size := (file_reference_length - replaced_path_size);

    IF (remaining_compressed_length >= remaining_path_size) THEN
      compressed_file_reference (compressed_file_index, remaining_path_size) :=
            path (replaced_path_size + 1, remaining_path_size);
      compressed_file_reference_size := remaining_path_size + compressed_file_index - 1;
    ELSE
      compressed_file_reference_size := compressed_length;
      IF remaining_compressed_length >= 4 THEN
        split_size := (remaining_compressed_length - 2) DIV 2;
        compressed_file_reference (compressed_file_index, split_size) :=
              path (replaced_path_size + 1, split_size);
        compressed_file_reference (compressed_file_index + split_size, 2) := '..';
        compressed_file_index := compressed_file_index + split_size + 2;
        compressed_file_reference (compressed_file_index, compressed_length - compressed_file_index + 1) :=
              path (file_reference_length - split_size + 1, compressed_length - compressed_file_index + 1);
      ELSE
        compressed_file_reference (compressed_file_index, remaining_compressed_length) :=
              path (replaced_path_size + 1, remaining_compressed_length);
      IFEND;
    IFEND;

  PROCEND osp$compress_file_reference;

?? TITLE := 'osp$expand_file_reference', EJECT ??
*copyc osh$expand_file_reference

  PROCEDURE [XDCL, #GATE] osp$expand_file_reference
    (    file_reference: fst$file_reference;
     VAR expanded_file_reference: fst$file_reference;
     VAR expanded_file_reference_size: fst$path_size;
     VAR status: ost$status);

    VAR
      expanded_length: fst$path_size,
      file_reference_length: fst$path_size;

    status.normal := TRUE;
    expanded_length := STRLENGTH (expanded_file_reference);
    file_reference_length := clp$trimmed_string_size (file_reference);

    IF (file_reference_length < 1) OR (expanded_length < 1) THEN
      expanded_file_reference_size := 0;
      RETURN;
    IFEND;

*IF NOT $true(osv$unix)
    IF (file_reference (1) = osc$compression_identifier) AND (file_reference_length > 2) THEN
      CASE file_reference (2) OF
      = 'S' =
        IF (expanded_length >= system_path_size + file_reference_length - 2) THEN
          expanded_file_reference (1, system_path_size) := system_path;
          expanded_file_reference (system_path_size + 1, file_reference_length - 2) :=
                file_reference (3, file_reference_length - 2);
          expanded_file_reference_size := system_path_size + file_reference_length - 2;
          RETURN;
        IFEND;
      = 'U' =
        IF expanded_length >= (clv$user_identification.family.size + clv$user_identification.user.size +
              file_reference_length + 1) THEN
          expanded_file_reference (1, 1) := ':';
          expanded_file_reference (2, clv$user_identification.family.size) :=
                clv$user_identification.family.value (1, clv$user_identification.family.size);
          expanded_file_reference (clv$user_identification.family.size + 2, 1) := '.';
          expanded_file_reference (clv$user_identification.family.size + 3,
                clv$user_identification.user.size) := clv$user_identification.user.
                value (1, clv$user_identification.user.size);
          expanded_file_reference (clv$user_identification.family.size + clv$user_identification.user.size +
                3, 1) := '.';
          expanded_file_reference (clv$user_identification.family.size + clv$user_identification.user.size +
                4, file_reference_length - 2) := file_reference (3, file_reference_length - 2);
          expanded_file_reference_size := (clv$user_identification.family.size +
                clv$user_identification.user.size + file_reference_length + 1);
          RETURN;
        IFEND;
      = 'L' =
        IF expanded_length >= (local_path_size + file_reference_length - 2) THEN
          expanded_file_reference (1, local_path_size) := local_path;
          expanded_file_reference (local_path_size + 1, file_reference_length - 2) :=
                file_reference (3, file_reference_length - 2);
          expanded_file_reference_size := local_path_size + file_reference_length - 2;
          RETURN;
        IFEND;
      = 'F' =
        IF expanded_length >= (clv$user_identification.family.size + file_reference_length) THEN
          expanded_file_reference (1, 1) := ':';
          expanded_file_reference (2, clv$user_identification.family.size) :=
                clv$user_identification.family.value (1, clv$user_identification.family.size);
          expanded_file_reference (clv$user_identification.family.size + 2, 1) := '.';
          expanded_file_reference (clv$user_identification.family.size + 3,
                file_reference_length - 2) := file_reference (3, file_reference_length - 2);
          expanded_file_reference_size := (clv$user_identification.family.size + file_reference_length);
          RETURN;
        IFEND;
      = 'C' =
        IF expanded_length >= (file_reference_length - 2) THEN
          expanded_file_reference (1, (file_reference_length - 2)) :=
                file_reference (3, (file_reference_length - 2));
          expanded_file_reference_size := file_reference_length - 2;
          RETURN;
        IFEND;
      ELSE
      CASEND;
    IFEND;
*IFEND

    IF expanded_length >= file_reference_length THEN
      expanded_file_reference (1, file_reference_length) := file_reference (1, file_reference_length);
      expanded_file_reference_size := file_reference_length;
    ELSE
      expanded_file_reference (1, expanded_length) := file_reference (1, expanded_length);
      expanded_file_reference_size := expanded_length;
    IFEND;

  PROCEND osp$expand_file_reference;

MODEND osm$append_status_file;




*DECK DECK=OSM$APPEND_STATUS_REAL EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Append Real Number to Status Record' ??
MODULE osm$append_status_real;

{
{ PURPOSE:
{   This module contains the routine that appends a real number to the
{   text field of a status record.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$real_number_digit_count
*copyc osk$keypoints
*copyc ost$status
?? POP ??
*copyc clp$convert_real_to_string
*copyc osp$append_status_parameter

?? TITLE := 'osp$append_status_real', EJECT ??
*copyc osh$append_status_real

  PROCEDURE [XDCL, #GATE] osp$append_status_real
    (    delimiter: char;
         real_number: longreal;
         number_of_digits: clt$real_number_digit_count;
     VAR status {input, output} : ost$status);

    VAR
      ignore_status: ost$status,
      text: ost$string;

    clp$convert_real_to_string (real_number, number_of_digits, text, ignore_status);
    osp$append_status_parameter (delimiter, text.value (1, text.size), status);

  PROCEND osp$append_status_real;

MODEND osm$append_status_real;
*DECK DECK=OSM$AWAIT_ACTIVITY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Management - activity wait routines', EJECT ??
MODULE osm$await_activity;

{ PURPOSE:
{   The purpose of this request is to support the osp$await_activity_completion
{   request.
{
{ DESIGN:
{   The procedure contained in this module has an execution bracket
{   of 1, 3 and a call bracket of 13.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc osd$wait
*copyc ose$await_activity_exceptions
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc ost$hardware_subranges
*copyc ost$status
*copyc pmd$local_queues
*copyc pme$local_queue_exceptions
*copyc pmt$task_id
?? POP ??
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_condition
*copyc pmp$await_nonempty_queue
*copyc pmp$continue_to_cause
*copyc pmp$long_term_wait
*copyc pmp$remove_await_nonempty_queue
*copyc pmp$verify_current_child
?? NEWTITLE := '[XDCL, #GATE] osp$await_activity', EJECT ??
*copy osh$await_activity

  PROCEDURE [XDCL, #GATE] osp$await_activity
    (    wait_list: ost$wait_list;
     VAR ready_index: integer;
     VAR complete: boolean;
     VAR status: ost$status);

    TYPE
      activity_index = 0 .. osc$maximum_offset;

    CONST
      local_clock = 0;

    VAR
      activity: activity_index,
      await_complete: boolean,
      await_status: ost$status,
      current_time: ost$free_running_clock,
      elapsed_time: ost$free_running_clock,
      ignore_status: ost$status,
      null_list: boolean,
      requestor: ost$caller_identifier,
      start_time: ost$free_running_clock,
      wait_time: ost$free_running_clock;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF
      = pmc$block_exit_processing =
        remove_await_nonempty_queue (1, UPPERBOUND (wait_list));

      = ifc$interactive_condition, jmc$job_resource_condition =
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        EXIT osp$await_activity;

      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;
    PROCEND condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'remove_await_nonempty_queue', EJECT ??

    PROCEDURE remove_await_nonempty_queue
      (    starting_activity: activity_index;
           ending_activity: activity_index);

      VAR
        activity: activity_index;

      FOR activity := starting_activity TO ending_activity DO
        IF (wait_list [activity].activity = pmc$await_local_queue_message) THEN
          pmp$remove_await_nonempty_queue (wait_list [activity].qid);
        IFEND;
      FOREND;
    PROCEND remove_await_nonempty_queue;
?? OLDTITLE ??
?? EJECT ??

    #CALLER_ID (requestor);
    elapsed_time := 0;
    status.normal := TRUE;
    complete := FALSE;
    osp$establish_condition_handler (^condition_handler, {block_exit} TRUE);
    await_status.normal := TRUE;
    wait_time := UPPERVALUE (ost$free_running_clock);
    null_list := TRUE;
    REPEAT
      await_complete := FALSE;
      activity := 1;
      WHILE NOT await_complete AND (activity <= UPPERBOUND (wait_list)) AND await_status.normal DO
        CASE wait_list [activity].activity OF
        = osc$null_activity =
          ;

        = osc$await_time =
          null_list := FALSE;
          IF (elapsed_time >= (wait_list [activity].milliseconds * 1000)) THEN
            await_complete := TRUE;
            complete := TRUE;
          ELSEIF ((wait_list [activity].milliseconds * 1000) < wait_time) THEN
            wait_time := wait_list [activity].milliseconds * 1000;
          IFEND;

        = pmc$await_task_termination =
          null_list := FALSE;
          pmp$verify_current_child (wait_list [activity].task_id, await_complete);
          await_complete := NOT await_complete;
          complete := await_complete;

        = pmc$await_local_queue_message =
          null_list := FALSE;
          pmp$await_nonempty_queue (wait_list [activity].qid, requestor.ring, await_complete, await_status);
          IF await_status.normal THEN
            complete := await_complete;
          ELSE
            remove_await_nonempty_queue (1, (activity - 1));
          IFEND;

        ELSE
          osp$set_status_condition (ose$incorrect_activity, await_status);
        CASEND;
        IF NOT await_complete AND await_status.normal THEN
          activity := activity + 1;
        IFEND;
      WHILEND;
      IF await_status.normal THEN
        IF await_complete THEN
          ready_index := activity;
          remove_await_nonempty_queue (1, UPPERBOUND (wait_list));
        ELSEIF null_list THEN
          ready_index := 1;
          await_complete := TRUE;
          complete := TRUE;
        ELSE
          IF ((wait_time - elapsed_time) > 0) THEN
            start_time := #FREE_RUNNING_CLOCK (local_clock);
            pmp$long_term_wait ((wait_time - elapsed_time) DIV 1000, (wait_time - elapsed_time) DIV 1000);
            current_time := #FREE_RUNNING_CLOCK (local_clock);
            IF current_time > start_time THEN
              elapsed_time := elapsed_time + (current_time - start_time);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    UNTIL await_complete OR NOT await_status.normal;

    osp$disestablish_cond_handler;
    IF await_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := await_status;
    IFEND;
  PROCEND osp$await_activity;
?? OLDTITLE ??
MODEND osm$await_activity;
*DECK DECK=OSM$AWAIT_ACTIVITY_COMPLETE EXPAND=TRUE
?? SET (LISTCTS := OFF) ??
?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, KEYW := UPPER, IDENT := LOWER) ??
?? NEWTITLE := 'NOS/VE: Program Control Services' ??
?? NEWTITLE := '  Global System Declarations' ??
MODULE osm$await_activity_complete;
{   PURPOSE:
{     The purpose of this module is to support the osp$await_activity_completion
{     request.

{   DESIGN:
{     The procedure contained in this module has an execution bracket of 1, 13.

?? EJECT ??
?? SET (LIST := OFF) ??
*copyc OST$STATUS
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$HARDWARE_SUBRANGES
*copyc OSE$AWAIT_ACTIVITY_EXCEPTIONS
*copyc PMT$TASK_ID
*copyc PMD$LOCAL_QUEUES
*copyc PME$LOCAL_QUEUE_EXCEPTIONS
?? SET (LIST := ON) ??
*copyc OST$CALLER_IDENTIFIER
*copyc OSD$WAIT
*copyc osd$keypoints
?? TITLE := '  Global External Procedures' ??
?? EJECT ??
*copyc OSH$AWAIT_ACTIVITY
*copyc OSP$AWAIT_ACTIVITY
?? TITLE := '  [XDCL, #gate] osp$await_activiy_completion' ??
?? NEWTITLE := '    remove_await_nonempty_queue' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$await_activity_completion (wait_list: ost$wait_list;
    VAR ready_index: integer;
    VAR status: ost$status);

    VAR
      wait_complete: boolean;

    ready_index := 0;
    status.normal := TRUE;
    #inline ('keypoint', osk$entry, 0, osk$await_activity_completion);
    wait_complete := FALSE;
    REPEAT
      osp$await_activity (wait_list, ready_index, wait_complete, status);
    UNTIL wait_complete OR NOT status.normal;
    #inline ('keypoint', osk$exit, 0, osk$await_activity_completion);
  PROCEND;
MODEND osm$await_activity_complete;
*DECK DECK=OSM$BOOT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operating System : Boot' ??
MODULE osm$boot;

{ PURPOSE:
{   This module contains the starting boot procedure.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmt$allocation_size
*copyc dst$rb_logging_request
*copyc dst$rb_system_deadstart_status
*copyc iot$io_request
*copyc jmc$special_dispatch_priorities
*copyc mmt$segment_descriptor_table
*copyc mmt$segment_descriptor_table_ex
*copyc osc$processor_defined_registers
*copyc osc$purge_map_and_cache
*copyc oss$mainframe_pageable
*copyc ost$boot_update_page_table
*copyc ost$deadstart_phase
*copyc ost$processor_id_set
*copyc ost$recover_system_set_phase
*copyc rmt$recorded_vsn
*copyc std$set_name
*copyc syt$perf_keypoints_enabled
?? POP ??
*copyc cmp$configure_deadstart_device
*copyc cmp$de_configure_ds_device
*copyc cmp$vcmb_menu_manager
*copyc cmp$write_os_status
*copyc dpp$configure_system_console
*copyc dsp$boot_deadstart_loader
*copyc dsp$build_mainframe_information
*copyc dsp$fetch_mau_list
*copyc dsp$get_entry_from_ssr
*copyc dsp$get_ssr_data_rma
*copyc dsp$initialize_sys_msg_buffer
*copyc dsp$load_additional_dft
*copyc dsp$make_ssr_segment
*copyc dsp$retrieve_device_address
*copyc dsp$save_boot_data_pointer
*copyc dsp$save_sys_status_current_ds
*copyc dsp$save_sys_status_ds_file
*copyc dsp$setup_170_request_interlock
*copyc dsp$setup_load_ppu_interlocks
*copyc dsp$store_entry_in_ssr
*copyc i#call_monitor
*copyc iop$mass_storage_io
*copyc mmp$fetch_boot_memory_bounds
*copyc mmp$get_max_sdt_pointer
*copyc mmp$get_sdt_entry_p
*copyc mmp$initialize
*copyc mmp$initialize_boot_pages
*copyc osp$initialize_date_time
*copyc osp$initialize_signature_lock
*copyc osp$reset_heap
*copyc osp$system_error
*copyc pmp$find_executing_task_xcb
*copyc syp$check_system_level
*copyc syp$determine_mainframe_type
*copyc syp$display_deadstart_message
*copyc syp$prepare_deadstart_display
*copyc syp$process_deadstart_status
*copyc syp$trace_deadstart_message
?? EJECT ??
*copyc cmv$system_device_data
*copyc dsv$system_deadstart_status_p
*copyc jmv$jcb
*copyc jmv$jmtr_xcb
*copyc mmv$free_pages
*copyc mmv$next_free_page
*copyc mmv$pt_length
*copyc mmv$pt_p
*copyc osv$180_memory_limits
*copyc osv$mainframe_wired_heap
*copyc osv$page_size
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    dmv$retain_system_device_flaws: [XDCL] boolean := TRUE,
    dmv$system_device_recorded_vsn: [XDCL, #GATE] rmt$recorded_vsn := 'VSN006',
    osv$deadstart_phase: [XDCL, #GATE] ost$deadstart_phase := osc$normal_deadstart,
    osv$default_pit: [XDCL] integer := 7fffffff(16), {default value for PIT}
    osv$job_fixed_heap: [XREF] ^ost$heap,
    osv$job_pageable_heap: [XDCL, #GATE, oss$mainframe_pageable] ^ost$heap,
    osv$mainframe_pageable_heap: [XDCL, #GATE, oss$mainframe_pageable] ^ost$heap,
    osv$mainframe_wired_cb_heap: [XDCL, #GATE, oss$mainframe_pageable] ^ost$heap,
    osv$mph_length: [XDCL] integer, {! * * * kludge until ost$heap is a heap}
    osv$recover_system_set_phase: [XDCL, #GATE] ost$recover_system_set_phase := osc$recovery_not_required,
    osv$spi_response_processor: [XDCL, STATIC, #GATE, oss$mainframe_pageable] iot$response_processor := NIL,
    osv$system_device_cylinder_size: [XDCL] integer := 0,
    osv$task_private_heap: [XDCL, #GATE, oss$mainframe_pageable] ^ost$heap,
    stv$system_set_name: [XDCL, #GATE] stt$set_name,
    syv$enable_heap_trace: [XDCL, #GATE] boolean := TRUE,
    syv$perf_keypoints_enabled: [XDCL, #GATE] syt$perf_keypoints_enabled :=
          [FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE],
    syv$verify_heap_linkage: [XDCL, #GATE] boolean := FALSE;
?? OLDTITLE ??
?? NEWTITLE := 'jmp$job_monitor_xcb', EJECT ??

  FUNCTION [XDCL, #GATE] jmp$job_monitor_xcb: ^ost$execution_control_block;

    jmp$job_monitor_xcb := ^jmv$jmtr_xcb;

  FUNCEND jmp$job_monitor_xcb;
?? OLDTITLE ??
?? NEWTITLE := 'add_free_memory', EJECT ??

  PROCEDURE add_free_memory
    (VAR lower_memory_bound: integer;
     VAR upper_memory_bound: integer);

    VAR
      lower_memory_limits: integer,
      memory_limits_size: integer,
      message: string (80),
      message_length: integer,
      pft_rma: integer,
      temp_memory_limit: integer;

    lower_memory_limits := osv$180_memory_limits.lower DIV osv$page_size;
    memory_limits_size := osv$180_memory_limits.deadstart_upper DIV osv$page_size;
    IF (lower_memory_limits >= lower_memory_bound) AND (memory_limits_size <= upper_memory_bound) THEN
      RETURN;
    IFEND;

    STRINGREP (message, message_length, ' Adding memory: ', lower_memory_limits: #(16),
          ' - ', memory_limits_size: #(16));
    syp$trace_deadstart_message (message (1, message_length));

    { Find the current last free page.

    pft_rma := mmv$next_free_page;
    WHILE mmv$free_pages^ [pft_rma] <> 0 DO
      pft_rma := mmv$free_pages^ [pft_rma];
    WHILEND;

    IF upper_memory_bound < memory_limits_size THEN
      temp_memory_limit := upper_memory_bound;
      WHILE temp_memory_limit < memory_limits_size DO
        mmv$free_pages^ [pft_rma] := temp_memory_limit;
        pft_rma := temp_memory_limit;
        temp_memory_limit := temp_memory_limit + 1;
      WHILEND;
      upper_memory_bound := memory_limits_size;
    IFEND;

    IF lower_memory_limits < lower_memory_bound THEN
      temp_memory_limit := lower_memory_limits;
      WHILE temp_memory_limit < lower_memory_bound DO
        mmv$free_pages^ [pft_rma] := temp_memory_limit;
        pft_rma := temp_memory_limit;
        temp_memory_limit := temp_memory_limit + 1;
      WHILEND;
      lower_memory_bound := lower_memory_limits;
    IFEND;

  PROCEND add_free_memory;
?? OLDTITLE ??
?? NEWTITLE := 'write_image_file', EJECT ??

{ PURPOSE:
{   This procedure writes the memory image to the image file to recover the previously running system.  The
{   boot is always loaded right after the page table.  Before it is loaded SCI copies that memory to what is
{   referred to as the 'hole'.  The 'hole' is memory that is used by NOS/VE that is not needed for recovery,
{   the monitor segment and job fixed of the system job.  The image is written beginning at memory lower
{   bounds.  The image length is obtained from the SSR.  When copying memory to the image file the part of
{   memory where the boot is running is copied from the area of memory defined by memory bounds in the SSR,
{   thus the image file reflect memory before the boot was loaded except for memory that is not needed for
{   recovery.  A value in the SSR to determine if an image file should be written.  If it determines that one
{   should be written it writes the image file to the system device.  The majority of this procedure is
{   traversed regardless of whether an image file is to be written.  This is done so that the memory needed
{   to write the image file is accounted for during normal deadstarts so that a large enough space is
{   reserved to deadstart the boot during recovery deadstarts.
{
{ NOTE:
{   In the future it would be good to begin the image file write right after the page table.  If the image
{   length exceeds available memory start at lower bound of memory.  The current method could lead to a
{   problem when loading monitor segment and reserving memory for job fixed of system job which must be in
{   contiguous memory.  Large page tables move the load address of the boot up but may not increase the image
{   length.  It would also make it easier to understand.

  PROCEDURE write_image_file
    (VAR lower_memory_bound: integer;
     VAR upper_memory_bound: integer;
     VAR status: ost$status);

    VAR
      bytes_per_mau: integer,
      completion_status_p: ^iot$completion_status,
      copy_lower_bound: integer,
      copy_upper_bound: integer,
      current_copy_address: integer,
      current_mau: dmt$mau_count,
      current_rma: integer,
      device_address: dmt$ms_logical_device_address,
      first_block_transfer_size: integer,
      first_partial_block_exists: boolean,
      image_length: dst$ssr_entry,
      image_offset: dst$ssr_entry,
      image_state: dst$ssr_entry,
      image_table_size: integer,
      index: integer,
      last_rma: integer,
      length: integer,
      mau_count: dmt$mau_count,
      mau_list_p: ^dmt$mau_address_list,
      memory_image_sva: ost$system_virtual_address,
      message: string(80),
      message_length: integer,
      only_perform_allocates: boolean,
      page_count: integer,
      pva_p: ^cell,
      rma_list_p: ^ARRAY [1 .. *] OF integer,
      rma_p: ^ARRAY [ * ] OF cell,
      ste_p: ^mmt$segment_descriptor,
      ssr_data_rma: integer,
      ssr_data_size: integer,
      sva_count: integer,
      sva_found: boolean,
      sva_index: integer,
      transfer_length: dmt$maus_per_transfer,
      transfer_size: integer,
      transfer_size_used: integer,
      update: ost$boot_update_page_table,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;

    { Set up the limits of where the boot is running, during the copy this memory is actually copied from
    { area defined by memory bounds in the SSR.  The boot is always loaded right after the page table.  The
    { page table is copied to the image file but it is not used.

    mmp$fetch_boot_memory_bounds (current_copy_address, length);
    copy_lower_bound := #READ_REGISTER (osc$pr_page_table_address) + (mmv$pt_length * 8);
    copy_upper_bound := copy_lower_bound + length;

    { Set the first byte address of memory bounds, this is where the memory is that the boot was loaded over.

    dsp$get_entry_from_ssr (dsc$ssr_image_length, image_length);
    last_rma := osv$180_memory_limits.lower + image_length.whole_slot;
    IF (last_rma > osv$180_memory_limits.upper) OR (image_length.whole_slot = 0) THEN
      osv$180_memory_limits.deadstart_upper := osv$180_memory_limits.upper;
    ELSE
      osv$180_memory_limits.deadstart_upper := last_rma;
    IFEND;

    { Configure the disk to write the image file.

    cmp$configure_deadstart_device (cmc$sdt_disk_device, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Determine the last RMA from the SSR length.

    current_rma := osv$180_memory_limits.lower;
    dsp$get_ssr_data_rma (dsc$ssr_total_length, ssr_data_rma, ssr_data_size);
    ssr_data_rma := ssr_data_rma + ssr_data_size + osv$page_size - 1;
    IF ssr_data_rma < last_rma THEN
      last_rma := ssr_data_rma DIV osv$page_size * osv$page_size;
    IFEND;

    dsp$get_entry_from_ssr (dsc$ssr_image_offset, image_offset);
    image_table_size := image_offset.whole_slot;
    dsp$get_entry_from_ssr (dsc$ssr_image_state, image_state);

    { Fetch the MAU list for the image file.

    only_perform_allocates := (image_state.whole_slot > 1);
    dsp$fetch_mau_list (only_perform_allocates, dmc$dlf_image_entry, mau_list_p, mau_count,
          transfer_size, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH completion_status_p;
    PUSH rma_list_p: [1 .. (osv$system_device_cylinder_size DIV osv$page_size) + 2];

    { Have monitor add entries to the page table for this memory.  Round up to page boundary

    ALLOCATE rma_p: [1 .. ((UPPERBOUND (rma_list_p^) + 2) * osv$page_size)] IN osv$mainframe_wired_heap^;
    pva_p := #ADDRESS (#RING (rma_p), #SEGMENT (rma_p),
          (((#OFFSET (rma_p) + osv$page_size - 1) DIV osv$page_size) * osv$page_size));
    update.reqcode := 11;
    update.pva := pva_p;
    update.length := UPPERBOUND (rma_list_p^) * osv$page_size;
    i#call_monitor (#LOC (update), #SIZE (update));
    #PURGE_BUFFER (osc$purge_all_page_seg_map, pva_p);

    dsp$save_sys_status_current_ds (dsc$ssr_sds_sdas_continuation);

    { Check the image state to see if the image file needs to be written.

    IF (image_state.whole_slot <= 1) AND (image_length.whole_slot <> 0) THEN
      syp$display_deadstart_message ('Writing the image file ...');
      dsp$retrieve_device_address (transfer_size, device_address);
      device_address.write_translation := TRUE;
      device_address.au_was_previously_written := TRUE;
      device_address.maus_per_allocation_unit := device_address.transfer_length;
      transfer_length := device_address.transfer_length;
      device_address.preset_value := 0;

      current_mau := (image_table_size DIV transfer_size) + 1;
      bytes_per_mau := transfer_size DIV device_address.transfer_length;
      first_block_transfer_size := transfer_size - (image_table_size MOD transfer_size);

      { The first image file block is special when written.  It starts in the middle of transfer unit due to
      { the image tables that precede it.

      first_partial_block_exists := (first_block_transfer_size < transfer_size);

      WHILE current_rma < last_rma DO
        IF first_partial_block_exists THEN
          page_count := first_block_transfer_size DIV osv$page_size;
          device_address.transfer_mau_offset := (image_table_size MOD transfer_size) DIV bytes_per_mau;
          device_address.transfer_length := first_block_transfer_size DIV bytes_per_mau;
          transfer_size_used := first_block_transfer_size;
        ELSE
          page_count := transfer_size DIV osv$page_size;
          device_address.transfer_mau_offset := 0;
          device_address.transfer_length := transfer_length;
          transfer_size_used := transfer_size;
        IFEND;
        device_address.allocation_unit_mau_address := mau_list_p^ [current_mau];

        FOR index := 1 TO page_count DO
          IF first_partial_block_exists OR (current_rma < last_rma) THEN
            IF (current_rma >= copy_upper_bound) OR (current_rma < copy_lower_bound) THEN
              rma_list_p^ [index] := current_rma;
            ELSE

              { Copying memory where the boot is running, use memory bounds instead.

              rma_list_p^ [index] := current_copy_address;
              current_copy_address := current_copy_address + osv$page_size;
            IFEND;
            current_rma := current_rma + osv$page_size;
          ELSE

            { Special case end of memory that is not on a transfer unit boundary, just write the last
            { memory page for those pages.

            rma_list_p^ [index] := current_rma - osv$page_size;
            transfer_size_used := transfer_size_used - osv$page_size;
          IFEND;
        FOREND;

        { Change the RMA's in the page table entries to point to the image file.

        pmp$find_executing_task_xcb (xcb_p);
        ste_p := mmp$get_sdt_entry_p (xcb_p, #SEGMENT (pva_p));
        memory_image_sva.asid := ste_p^.ste.asid;
        memory_image_sva.offset := #OFFSET (pva_p);
        FOR index := 1 TO page_count DO
          IF (rma_list_p^ [index] MOD osv$page_size) <> 0 THEN
            osp$system_error ('RMA not on page boundary', #LOC (rma_list_p^));
          IFEND;
          #HASH_SVA (memory_image_sva, sva_index, sva_count, sva_found);
          IF NOT sva_found THEN
            osp$system_error ('Convert rma - pte not found', NIL);
          IFEND;
          mmv$pt_p^ [sva_index].rma := rma_list_p^ [index] DIV 512;
          memory_image_sva.offset := memory_image_sva.offset + osv$page_size;
        FOREND;
        #PURGE_BUFFER (osc$purge_all_page_seg_map, pva_p);

        STRINGREP (message, message_length, ' Image: ', rma_list_p^ [1]: #(16),
              rma_list_p^ [page_count]: #(16), current_mau, mau_count, mau_list_p^ [current_mau],
              transfer_size_used);
        syp$trace_deadstart_message (message (1, message_length));
        iop$mass_storage_io (pva_p, transfer_size_used, ioc$write_mass_storage, device_address,
              TRUE, completion_status_p, status);
        IF NOT status.normal THEN
          osp$system_error ('Cannot write image file', ^status);
        IFEND;
        current_mau := current_mau + 1;
        first_partial_block_exists := FALSE;
      WHILEND;

      { Change the image state to reflect the fact that the image file has been written.

      osv$180_memory_limits.upper := last_rma;
      image_state.whole_slot := 2;
      dsp$store_entry_in_ssr (dsc$ssr_image_state, dsc$ssr_whole_slot, image_state);

      { Change the current deadstart type in the System Deadstart Status data to note that an image file
      { has been written.

      dsp$save_sys_status_current_ds (dsc$ssr_sds_sdas_with_image);

    IFEND;

    { Free the pages so that they are not counted in the needed memory.  The memory was never used as
    { the page table entries were changed to point elsewhere.

    pmp$find_executing_task_xcb (xcb_p);
    ste_p := mmp$get_sdt_entry_p (xcb_p, #SEGMENT (pva_p));
    memory_image_sva.asid := ste_p^.ste.asid;
    memory_image_sva.offset := #OFFSET (pva_p);
    FOR index := 1 TO UPPERBOUND (rma_list_p^) DO
      #HASH_SVA (memory_image_sva, sva_index, sva_count, sva_found);
      IF NOT sva_found THEN
        osp$system_error ('Convert rma - pte not found', NIL);
      IFEND;
      mmv$pt_p^ [sva_index].v := FALSE;
      mmv$pt_p^ [sva_index].pageid.asid := 0;
      mmv$pt_p^ [sva_index].pageid.pagenum := 0;
      mmv$pt_p^ [sva_index].rma := 0;
      memory_image_sva.offset := memory_image_sva.offset + osv$page_size;
    FOREND;
    #PURGE_BUFFER (osc$purge_all_page_seg_map, pva_p);
    FREE rma_p IN osv$mainframe_wired_heap^;

    cmp$de_configure_ds_device (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    add_free_memory (lower_memory_bound, upper_memory_bound);

    FREE mau_list_p IN osv$mainframe_wired_heap^;

  PROCEND write_image_file;
?? OLDTITLE ??
?? NEWTITLE := 'osp$initialize', EJECT ??

{ PURPOSE:
{   This program is the starting procedure for the boot OS code.

  PROGRAM [XDCL] osp$initialize;

    VAR
      dft_rb: dst$rb_logging_request,
      lower_memory_bound: integer,
      rb: dst$rb_system_deadstart_status,
      sdt_p: mmt$max_sdt_p,
      status: ost$status,
      upper_memory_bound: integer,
      xcb_p: ^ost$execution_control_block;

    mmp$initialize;

    { Setup the job monitor exchange package.

    xcb_p := jmp$job_monitor_xcb ();
    mmp$get_max_sdt_pointer (xcb_p, sdt_p);
    sdt_p^.st [osc$segnum_job_fixed_heap] := sdt_p^.st [0a(16)];
    #PURGE_BUFFER (osc$purge_all_page_seg_map, xcb_p);
    xcb_p^.dispatching_priority := jmc$priority_system_job;
    xcb_p^.pit_count := 7fffffff(16);
    xcb_p^.iocb_p := NIL;
    xcb_p^.processor_selections := - $ost$processor_id_set [];
    xcb_p^.requested_processor_selections := $ost$processor_id_set [];
    xcb_p^.global_task_id.index := 1;
    xcb_p^.global_task_id.seqno := 1;
    xcb_p^.task_kind := osc$tk_nosve_task;

    jmv$jcb.cptime_next_age_working_set := 200000;
    jmv$jcb.max_working_set_size := 1000;
    jmv$jcb.signal_interval := 0ffffffff(16);

    { At this point memory manager is initialized to the point where a page fault can be
    { processed to extend existing segments (within 1mb).

    osp$reset_heap (osv$mainframe_wired_heap, 3fffffff(16), TRUE, 1);
    osv$mainframe_pageable_heap := osv$mainframe_wired_heap;
    osv$mainframe_wired_cb_heap := osv$mainframe_wired_heap;
    osv$job_pageable_heap := osv$mainframe_wired_heap;
    osv$job_fixed_heap := osv$mainframe_wired_heap;
    osv$task_private_heap := osv$mainframe_wired_heap;

    syp$determine_mainframe_type;

    { Set up the variables to the DFT block.

    dft_rb.reqcode := syc$rc_logging_request;
    dft_rb.action := dsc$rla_dft_setup_variables;
    i#call_monitor (#LOC (dft_rb), #SIZE (dft_rb));

    { Preparing the deadstart displays must be done very early to prepare the displays for output.
    { Anything done before this procedure will not be able to write to the screen.

    dpp$configure_system_console;
    syp$prepare_deadstart_display;
    dsp$make_ssr_segment;
    dsp$build_mainframe_information;

    { Initialize the system deadstart status in the SSR.

    ALLOCATE dsv$system_deadstart_status_p IN osv$mainframe_wired_heap^;
    dsp$save_boot_data_pointer (dsc$boot_system_ds_status, #SEQ (dsv$system_deadstart_status_p^));
    rb.reqcode := syc$rc_system_deadstart_status;
    rb.status.normal := TRUE;
    rb.action := dsc$rb_sds_initialize_data;
    rb.data_p := NIL;
    i#call_monitor (#LOC (rb), #SIZE (rb));

    { Initialize the signature lock variables used by the deadstart area.

    dsp$setup_load_ppu_interlocks;
    dsp$setup_170_request_interlock;

    { Initialize the buffer used to hold messages from monitor destined for the engineering log.

    dsp$initialize_sys_msg_buffer;

    osp$initialize_date_time (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Error:  Initialize date and time.', TRUE, status);
    IFEND;

    syp$display_deadstart_message ('Virtual CPU bootstrap initiated ...');

    dsp$load_additional_dft (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Unable to load secondary DFT.', TRUE, status);
    IFEND;

    { Chech the system level number in the SSR for compatability with system core.

    syp$check_system_level;

    { Initialize the boot pages.

    mmp$initialize_boot_pages (lower_memory_bound, upper_memory_bound);

    { Allow configuration of the deadstart and system device(s).

    cmp$vcmb_menu_manager;

    REPEAT
      write_image_file (lower_memory_bound, upper_memory_bound, status);
      IF NOT status.normal THEN
        cmp$write_os_status (' ', status);
        cmp$vcmb_menu_manager;
      IFEND;
    UNTIL status.normal;

    { Store the source of the deadstart file in the System Deadstart Status data.  If the tape is specified
    { then the source is the tape drive.

    IF cmv$system_device_data [cmc$sdt_tape_device].specified THEN
      dsp$save_sys_status_ds_file (dsc$ssr_sds_source_tape);
    ELSE
      dsp$save_sys_status_ds_file (dsc$ssr_sds_source_disk);
    IFEND;

    dsp$boot_deadstart_loader;

  PROCEND osp$initialize;
?? OLDTITLE ??
MODEND osm$boot;
*DECK DECK=OSM$BROKEN_JOB_DUMP EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Broken_Job Dump Support' ??
MODULE osm$broken_job_dump;

{  PURPOSE:
{    The purpose of the routines in this module is to support the
{    dumping of a job/task environment from within a broken task
{    to a perm file.

?? PUSH (LISTEXT := ON) ??
*copyc syc$monitor_request_codes
*copyc tmt$rb_delay
*copyc i#call_monitor
*copyc i#move
*copyc osp$clear_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osp$test_set_main_sig_lock
*copyc osp$test_sig_lock
*copyc pmp$get_executing_task_gtid
*copyc pmp$ready_task
*copyc osv$mainframe_pageable_heap
*copyc syv$debug_output_disposal_info
?? POP ??

  CONST
    buffer_size = 16 * 1024,

    text_output = 0,
    heading_output = 1;

  TYPE
    ost$broken_job_buffer = record
      status: ost$broken_job_buffer_status,
      hdr: ost$broken_job_dump_header,
      buf: array [1 .. buffer_size] of cell,
    recend,
    ost$broken_job_buffer_status = (osc$wait_data, osc$wait_dump),
    ost$broken_job_dump_header = record
      case dt: (osc$start_dump, osc$new_segment, osc$text, osc$segment_data,
        osc$end_dump) of
      = osc$start_dump =
        dum1: boolean,
      = osc$new_segment =
        seg_num: 0 .. 0fff(16),
        length: 0 .. 0ffffffff(16),
      = osc$text =
        text_length: 0 .. buffer_size,
      = osc$end_dump =
        dum2: boolean,
      casend,
    recend;

  VAR
    broken_job_dump_lock: ost$signature_lock,
    ctl: integer,
    dump_task_lock: ost$signature_lock,
    dump_active: boolean := FALSE,
    broken_job_dumper_gtid: ost$global_task_id,
    broken_job_buffer: ^ost$broken_job_buffer := NIL,
    broken_job_gtid: ost$global_task_id,
    osv$debugger_output_disposition: [XDCL, #GATE] syt$debug_output_disposal_info := [syc$dod_null, *];

?? NEWTITLE := '  RESPOND', EJECT ??

  PROCEDURE respond (s: ost$broken_job_buffer_status;
    VAR st: ost$status);

    VAR
      i: integer,
      osv$timeout_count: [XDCL] integer := 6;

    st.normal := TRUE;
    CASE s OF
    = osc$wait_data =
      broken_job_buffer^.status := osc$wait_data;
      pmp$ready_task (broken_job_gtid, st);
      IF NOT st.normal THEN
        RETURN;
      IFEND;
      WHILE broken_job_buffer^.status <> osc$wait_dump DO
        pause (10000);
      WHILEND;
    = osc$wait_dump =
      broken_job_buffer^.status := osc$wait_dump;
      pmp$ready_task (broken_job_dumper_gtid, st);
      IF NOT st.normal THEN
        RETURN;
      IFEND;
      i := 0;
      WHILE (broken_job_buffer^.status <> osc$wait_data) AND (i < osv$timeout_count) DO
        pause (10000);
        i := i + 1;
      WHILEND;
      IF broken_job_buffer^.status <> osc$wait_data THEN
        osp$set_status_abnormal ('OS', 0, 'Dump task not responding to presence of dump data', st);
      IFEND;
    CASEND;
  PROCEND respond;
?? OLDTITLE ??
?? NEWTITLE := '  OSP$BEGIN_TEXT_DUMP', EJECT ??
  PROCEDURE [XDCL] osp$begin_text_dump (VAR status: ost$status);

    VAR
      local_status: ost$status,
      ls: ost$signature_lock_status,
      locked: boolean,
      p: ^ost$broken_job_buffer;

    osp$test_sig_lock (broken_job_dump_lock, ls);
    IF ls = osc$sls_locked_by_current_task THEN
      osp$set_status_abnormal ('OS', 0, 'Dump to file/printer already in progress', status);
      RETURN;
    IFEND;
    osp$test_set_main_sig_lock (broken_job_dump_lock, locked);
    IF NOT locked THEN
      osp$set_status_abnormal ('OS', 0, 'Dump to file/printer already in progress', status);
      RETURN;
    IFEND;

    pmp$get_executing_task_gtid (broken_job_gtid);

    ALLOCATE p IN osv$mainframe_pageable_heap^;
    IF p = NIL THEN
      osp$set_status_abnormal ('OS', 0, 'cant allocate dump buffer', status);
      osp$clear_mainframe_sig_lock (broken_job_dump_lock);
      RETURN;
    IFEND;

    p^.status := osc$wait_data;
    broken_job_buffer := p;
    dump_active := TRUE;

    broken_job_buffer^.hdr.dt := osc$start_dump;
    respond (osc$wait_dump, local_status);
    IF NOT local_status.normal THEN
      dump_active := FALSE;
      FREE broken_job_buffer IN osv$mainframe_pageable_heap^;
      osp$clear_mainframe_sig_lock (broken_job_dump_lock);
      osp$set_status_abnormal ('OS', 0, 'dump task not present/reponding', status);
    ELSE
      ctl := 0;
      broken_job_buffer^.hdr.dt := osc$text;
    IFEND;
  PROCEND osp$begin_text_dump;
?? OLDTITLE ??
?? NEWTITLE := '  OSP$END_TEXT_DUMP', EJECT ??
  PROCEDURE [XDCL] osp$end_text_dump;

    VAR
      ls: ost$signature_lock_status,
      ignore_status: ost$status;

    osp$test_sig_lock (broken_job_dump_lock, ls);
    IF ls <> osc$sls_locked_by_current_task THEN
      RETURN;
    IFEND;

    IF ctl <> 0 THEN
      broken_job_buffer^.hdr.text_length := ctl;
      respond (osc$wait_dump, ignore_status);
      ctl := 0;
    IFEND;

    broken_job_buffer^.hdr.dt := osc$end_dump;
    respond (osc$wait_dump, ignore_status);

    FREE broken_job_buffer IN osv$mainframe_pageable_heap^;
    osp$clear_mainframe_sig_lock (broken_job_dump_lock);
  PROCEND osp$end_text_dump;
?? OLDTITLE ??
?? NEWTITLE := '  OSP$OUTPUT_DEBUG_TEXT', EJECT ??
  PROCEDURE [XDCL] osp$output_debug_text (s: ^string ( * );
    VAR status: ost$status);

    VAR
      zero: 0 .. 0ff(16),
      ps: 0 .. 0ffff(16);

    zero := text_output;

    IF broken_job_buffer = NIL THEN
      RETURN;
    IFEND;

    ps := STRLENGTH (s^);
    IF (ctl + ps + #SIZE (ps) + #SIZE (zero)) > buffer_size THEN
      broken_job_buffer^.hdr.text_length := ctl;
      broken_job_buffer^.hdr.dt := osc$text;
      respond (osc$wait_dump, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      ctl := 0;
    IFEND;

    i#move (#LOC (zero), #LOC (broken_job_buffer^.buf [ctl + 1]), #SIZE
          (zero));
    ctl := ctl + #SIZE (zero);


    i#move (#LOC (ps), #LOC (broken_job_buffer^.buf [ctl + 1]), #SIZE
          (ps));
    ctl := ctl + #SIZE (ps);
    i#move (#LOC (s^ (1)), #LOC (broken_job_buffer^.buf [ctl + 1]), ps);
    ctl := ctl + ps;

  PROCEND osp$output_debug_text;
?? OLDTITLE ??
?? NEWTITLE := '  OSP$OUTPUT_DEBUG_HEADING', EJECT ??
  PROCEDURE [XDCL] osp$output_debug_heading (s: ^string ( * );
    VAR status: ost$status);

    VAR
      one: 0 .. 0ff(16),
      ps: 0 .. 0ffff(16);

    one := heading_output;

    IF broken_job_buffer = NIL THEN
      RETURN;
    IFEND;

    ps := STRLENGTH (s^);
    IF (ctl + ps + #SIZE (ps) + #SIZE (one)) > buffer_size THEN
      broken_job_buffer^.hdr.text_length := ctl;
      broken_job_buffer^.hdr.dt := osc$text;
      respond (osc$wait_dump, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      ctl := 0;
    IFEND;

    i#move (#LOC (one), #LOC (broken_job_buffer^.buf [ctl + 1]), #SIZE
          (one));
    ctl := ctl + #SIZE (one);

    i#move (#LOC (ps), #LOC (broken_job_buffer^.buf [ctl + 1]), #SIZE
          (ps));
    ctl := ctl + #SIZE (ps);
    i#move (#LOC (s^ (1)), #LOC (broken_job_buffer^.buf [ctl + 1]), ps);
    ctl := ctl + ps;

  PROCEND osp$output_debug_heading;
?? OLDTITLE ??
?? NEWTITLE := '  OSP$DUMP_BROKEN_TASK', EJECT ??
  PROCEDURE [XDCL, #GATE] osp$dump_broken_task
    (    sp: ^array [1 .. 00fffffff(16)] OF cell;
     VAR dump_in_progress: boolean;
     VAR amount: integer);

    VAR
      ignore_status: ost$status,
      locked: boolean,
      status: ost$status,
      tl: integer;

    pmp$get_executing_task_gtid (broken_job_dumper_gtid);
    IF (NOT dump_active) OR (broken_job_buffer = NIL) THEN
      dump_in_progress := FALSE;
      RETURN;
    IFEND;
    wait_dump;
    osp$test_set_main_sig_lock (dump_task_lock, locked );
    dump_in_progress := TRUE;
    ignore_status.normal := TRUE;
    status.normal := TRUE;

  /dump/
    BEGIN
      CASE broken_job_buffer^.hdr.dt OF
      = osc$start_dump =

{ Tell the broken job dump task how the incoming data should be disposed of.

        osv$debugger_output_disposition := syv$debug_output_disposal_info;
        respond (osc$wait_data, status);
        dump_in_progress := status.normal;

      = osc$new_segment, osc$segment_data =
        respond (osc$wait_data, status);
        dump_in_progress := status.normal;

      = osc$text =
        tl := broken_job_buffer^.hdr.text_length;
        i#move (#LOC (broken_job_buffer^.buf), #LOC (sp^ [amount + 1]), tl);
        amount := amount + tl;
        respond (osc$wait_data, status);
        dump_in_progress := status.normal;

      = osc$end_dump =
        broken_job_buffer^.status := osc$wait_data;
        pmp$ready_task (broken_job_gtid, ignore_status);
        dump_in_progress := FALSE;
        dump_active := FALSE;
      CASEND;
    END /dump/;
    osp$clear_mainframe_sig_lock (dump_task_lock);

  PROCEND osp$dump_broken_task;
?? OLDTITLE ??
?? NEWTITLE := '  WAIT_DUMP', EJECT ??
  PROCEDURE wait_dump;

    WHILE broken_job_buffer^.status <> osc$wait_dump DO
      pause (10000);
    WHILEND;

  PROCEND wait_dump;
?? OLDTITLE ??
?? NEWTITLE := '  PAUSE', EJECT ??
  PROCEDURE pause (ms: 0 .. 0ffffffff(16));

    VAR
      delay: tmt$rb_delay;

    delay.reqcode := syc$rc_delay;
    delay.requested_wait_time := #free_running_clock (0) + ms * 1000;
    delay.expected_wait_time := delay.requested_wait_time;
    i#call_monitor (#LOC (delay), #SIZE (delay));

  PROCEND pause;
?? OLDTITLE, OLDTITLE ??
MODEND
*DECK DECK=OSM$BROKEN_JOB_DUMP_TASK EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Broken_Job Dump_Task' ??
MODULE osm$broken_job_dump_task;
?? PUSH (LISTEXT := ON) ??
*copyc amt$term_option
*copyc oss$job_paged_literal
*copyc pfe$error_condition_codes
*copyc pmt$program_parameters
*copyc syc$monitor_request_codes
*copyc tmc$wait_times
?? POP ??
?? NEWTITLE := '  External procedures and variables referenced in this module', EJECT ??
*copyc amp$close
*copyc amp$file
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$put_next
*copyc amp$put_partial
*copyc amp$return
*copyc amp$set_segment_eoi
*copyc clp$scan_command_line
*copyc i#move
*copyc osp$dump_broken_task
*copyc osp$generate_log_message
*copyc pfp$define
*copyc pmp$log
*copyc pmp$wait
*copyc tmp$set_task_priority
*copyc jmv$executing_within_system_job
*copyc osv$debugger_output_disposition
?? OLDTITLE ??
?? NEWTITLE := '  CONST definitions used in this module', EJECT ??
  CONST
    pfn = 'broken_job_pfn_lfn             ',
    lfn = 'broken_job_data_scratch        ';

?? OLDTITLE ??
?? NEWTITLE := '  OSP$BROKEN_JOB_DUMP_TASK', EJECT ??
  PROCEDURE [XDCL, #GATE] osp$broken_job_dump_task
    (    p: pmt$program_parameters;
     VAR status: ost$status);

    VAR
      command_line: string (90),
      dump_in_progress: boolean,
      ignore_status: ost$status,
      lfn_fid: amt$file_identifier,
      pa: ^array [1 .. 0fffffff(16)] of 0 .. 0ff(16),
      pfsp: amt$segment_pointer,
      pfn_fid: amt$file_identifier,
      total: integer;

    IF NOT jmv$executing_within_system_job THEN
      RETURN;
    IFEND;

    amp$return (lfn, status);
    amp$open (lfn, amc$segment, NIL, lfn_fid, status);
    IF NOT status.normal THEN
      osp$generate_log_message($pmt$ascii_logset[pmc$system_log,pmc$job_log], status, ignore_status);
      RETURN;
    IFEND;
    amp$get_segment_pointer (lfn_fid, amc$cell_pointer, pfsp, status);
    IF NOT status.normal THEN
      osp$generate_log_message($pmt$ascii_logset[pmc$system_log,pmc$job_log], status, ignore_status);
      RETURN;
    IFEND;

  /wait_for_broken_task/
    WHILE TRUE DO
      total := 0;
      REPEAT
        osp$dump_broken_task (pfsp.cell_pointer, dump_in_progress, total);
      UNTIL NOT dump_in_progress;
      IF total = 0 THEN
        pmp$wait (tmc$infinite_wait, tmc$infinite_wait);
        CYCLE /wait_for_broken_task/;
      ELSE
        pa := pfsp.cell_pointer;
        pfsp.cell_pointer := #LOC (pa^ [total]);
        amp$set_segment_eoi (lfn_fid, pfsp, status);
        pfsp.cell_pointer := pa;
        create_dump_file (pfn_fid, status);
        IF NOT status.normal THEN
          osp$generate_log_message($pmt$ascii_logset[pmc$system_log,pmc$job_log],status,ignore_status);
          CYCLE /wait_for_broken_task/;
        IFEND;
        copy_dump (pa, pfn_fid, total, status);
        IF NOT status.normal THEN
          osp$generate_log_message($pmt$ascii_logset[pmc$system_log,pmc$job_log], status,ignore_status);
          CYCLE /wait_for_broken_task/;
        IFEND;
        pmp$log (' **** BROKEN TASK DUMPED **** ', status);
        amp$close (pfn_fid, status);

        IF osv$debugger_output_disposition.output_destination = syc$dod_write_for_print THEN
          clp$scan_command_line ('$SYSTEM.PRIF $LOCAL.BROKEN_JOB_PFN_LFN', status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF osv$debugger_output_disposition.output_destination = syc$dod_save_on_pf THEN
          clp$scan_command_line ('$SYSTEM.CREC $SYSTEM.DUMPS', status);
          IF (NOT status.normal) AND (status.condition <> pfe$name_already_subcatalog) THEN
            clp$scan_command_line ('$SYSTEM.PRIF $LOCAL.BROKEN_JOB_PFN_LFN', ignore_status);
            RETURN;
          IFEND;

{!       '$SYSTEM.COPF $LOCAL.BROKEN_JOB_PFN_LFN $SYSTEM.DUMPS.DEBUG_OF_$0000_0000_AAA_0000.$NEXT
{!        1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890
{!                 1         2         3         4         5         6         7         8         9         0
          command_line := ' ';
          command_line (1, *) := '$SYSTEM.COPF $LOCAL.BROKEN_JOB_PFN_LFN $SYSTEM.DUMPS.DEBUG_OF_';
          command_line (63, *) := osv$debugger_output_disposition.job_and_file_name;
          command_line (82, *) := '.$NEXT';
          clp$scan_command_line (command_line, status);
          IF NOT status.normal THEN
            clp$scan_command_line ('$SYSTEM.PRIF $LOCAL.BROKEN_JOB_PFN_LFN', ignore_status);
            RETURN;
          IFEND;

{!       '$SYSTEM.CHAFA RA=(11 11 11) F=$SYSTEM.DUMPS.DEBUG_OF_$0000_0000_AAA_0000
{!        1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890
{!                 1         2         3         4         5         6         7         8         9         0
          command_line := ' ';
          command_line (1, *) := '$SYSTEM.CHAFA RA=(11 11 11) F=$SYSTEM.DUMPS.DEBUG_OF_';
          command_line (54, *) := osv$debugger_output_disposition.job_and_file_name;
          clp$scan_command_line (command_line, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{!       '$SYSTEM.CHACE NR=14 F=$SYSTEM.DUMPS.DEBUG_OF_$0000_0000_AAA_0000
{!        1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890
{!                 1         2         3         4         5         6         7         8         9         0
          command_line := ' ';
          command_line (1, *) := '$SYSTEM.CHACE NR=14 F=$SYSTEM.DUMPS.DEBUG_OF_';
          command_line (46, *) := osv$debugger_output_disposition.job_and_file_name;
          clp$scan_command_line (command_line, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF osv$debugger_output_disposition.output_destination = syc$dod_save_and_print THEN

          clp$scan_command_line ('$SYSTEM.PRIF $LOCAL.BROKEN_JOB_PFN_LFN', status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$scan_command_line ('$SYSTEM.CREC $SYSTEM.DUMPS', status);
          IF (NOT status.normal) AND (status.condition <> pfe$name_already_subcatalog) THEN
            RETURN;
          IFEND;

{!       '$SYSTEM.COPF $LOCAL.BROKEN_JOB_PFN_LFN $SYSTEM.DUMPS.DEBUG_OF_$0000_0000_AAA_0000.$NEXT'
{!        1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890
{!                 1         2         3         4         5         6         7         8         9         0
          command_line := ' ';
          command_line (1, *) := '$SYSTEM.COPF $LOCAL.BROKEN_JOB_PFN_LFN $SYSTEM.DUMPS.DEBUG_OF_';
          command_line (63, *) := osv$debugger_output_disposition.job_and_file_name;
          command_line (82, *) := '.$NEXT';
          clp$scan_command_line (command_line, status);
          IF NOT status.normal THEN
            clp$scan_command_line ('$SYSTEM.PRIF $LOCAL.BROKEN_JOB_PFN_LFN', ignore_status);
            RETURN;
          IFEND;

{!       '$SYSTEM.CHAFA RA=(11 11 11) F=$SYSTEM.DUMPS.DEBUG_OF_$0000_0000_AAA_0000
{!        1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890
{!                 1         2         3         4         5         6         7         8         9         0
          command_line := ' ';
          command_line (1, *) := '$SYSTEM.CHAFA RA=(11 11 11) F=$SYSTEM.DUMPS.DEBUG_OF_';
          command_line (54, *) := osv$debugger_output_disposition.job_and_file_name;
          clp$scan_command_line (command_line, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{!       '$SYSTEM.CHACE NR=14 F=$SYSTEM.DUMPS.DEBUG_OF_$0000_0000_AAA_0000
{!        1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890
{!                 1         2         3         4         5         6         7         8         9         0
          command_line := ' ';
          command_line (1, *) := '$SYSTEM.CHACE NR=14 F=$SYSTEM.DUMPS.DEBUG_OF_';
          command_line (46, *) := osv$debugger_output_disposition.job_and_file_name;
          clp$scan_command_line (command_line, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        amp$return (pfn, status);
      IFEND;
    WHILEND /wait_for_broken_task/;

  PROCEND osp$broken_job_dump_task;
?? OLDTITLE ??
?? NEWTITLE := '  CREATE_DUMP_FILE', EJECT ??
  PROCEDURE create_dump_file (VAR fid: amt$file_identifier;
    VAR status: ost$status);


    VAR
      file_attrs: ^amt$file_attributes;

    PUSH file_attrs: [1 .. 1];
    file_attrs^ [1].key := amc$file_contents;
    file_attrs^ [1].file_contents := 'LIST';
    amp$file (pfn, file_attrs^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    amp$open (pfn, amc$record, NIL, fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
  PROCEND create_dump_file;
?? OLDTITLE ??
?? NEWTITLE := '  COPY_DUMP', EJECT ??
  PROCEDURE copy_dump (p: ^array [1 .. 00fffffff(16)] OF 0 .. 0ff(16);
        fid: amt$file_identifier;
        total: integer;
    VAR status: ost$status);

    VAR
      current: integer,
      ll: 0 .. 0ffff(16),
      len: 0 .. 0ffff(16),
      c: ^char,
      blank: string (130),
      page: string (60),
      pcount: integer,
      leng: integer,
      heading: string (60),
      sp: string (1),
      hd: string (1),
      count: integer,
      bad: amt$file_byte_address;

    current := 0;
    count := 0;
    pcount := 0;
    heading := '    ';
    blank := '            ';
    sp := ' ';
    hd := '1';
    WHILE current < total DO
      page := '    ';
      current := current + 1;
      IF p^ [current] = 1 THEN
        i#move (#LOC (p^ [current + 1]), #LOC (len), #SIZE (len));
        current := current + #SIZE (len);
        i#move (#LOC (p^ [current + 1]), #LOC (heading), len);
        current := current + len;
        pcount := pcount + 1;
        STRINGREP (page, leng, '                           PAGE', pcount: 5);
        amp$put_partial (fid, #LOC (hd), #SIZE (hd), bad, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        amp$put_partial (fid, #LOC (heading), len, bad, amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        amp$put_partial (fid, #LOC (page), #SIZE (page), bad, amc$terminate,
         status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        amp$put_next (fid, #LOC (blank), #SIZE (blank), bad, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        count := 0;
      ELSE

        IF (count = 60) THEN
          pcount := pcount + 1;
          STRINGREP (page, leng, '                           PAGE', pcount: 5);
          amp$put_partial (fid, #LOC (hd), #SIZE (hd), bad, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          amp$put_partial (fid, #LOC (heading), len, bad, amc$continue,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          amp$put_partial (fid, #LOC (page), #SIZE (page), bad, amc$terminate,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          amp$put_next (fid, #LOC (blank), #SIZE (blank), bad, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          count := 0;
        IFEND;

        i#move (#LOC (p^ [current + 1]), #LOC (ll), #SIZE (ll));
        current := current + #SIZE (ll);
        c := #LOC (p^ [current + 1]);
        IF (c^ <> ' ') THEN
          amp$put_partial (fid, #LOC (sp), #SIZE (sp), bad, amc$start, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          amp$put_partial (fid, #LOC (p^ [current + 1]), ll, bad,
                amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          current := current + ll;
          count := count + 1;
        ELSE

          amp$put_next (fid, #LOC (p^ [current + 1]), ll, bad, status);
          current := current + ll;
          count := count + 1;
        IFEND;

        IF NOT status.normal THEN
          RETURN;
        IFEND;

      IFEND;

    WHILEND;

  PROCEND copy_dump;
?? OLDTITLE, OLDTITLE ??
MODEND osm$broken_job_dump_task
*DECK DECK=OSM$CHANGE_INTERACT_STYLE_CMND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Change Interactive Style Command' ??
MODULE osm$change_interact_style_cmnd;

{
{ PURPOSE:
{   This module contains the processor for the change_interactive_style command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$parameter_list
*copyc clt$work_area
*copyc ost$status
?? POP ??
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_data_to_string
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$get_work_area
*copyc clp$make_boolean_value
*copyc clp$make_keyword_value
*copyc clp$make_integer_value
*copyc clp$make_record_value
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_data_representation
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc clv$nil_display_control
*copyc ifp$fetch_context
*copyc osp$change_interaction_info
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$get_interaction_information
?? TITLE := 'osp$_change_interaction_informa', EJECT ??

  PROCEDURE [XDCL] osp$_change_interaction_informa
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$chais) change_interaction_information, change_interaction_style, chais, chaii (
{   style, s: key
{       (line, l)
{       (screen, s)
{     keyend = $optional
{   menu_rows, menu_row, mr: (BY_NAME) integer 0 .. csc$number_of_menu_rows = $optional
{   extend_utility_interaction, eui: (BY_NAME) boolean = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 25, 14, 8, 20, 851],
    clc$command, 8, 4, 0, 0, 0, 0, 4, 'OSM$CHAIS'], [
    ['EUI                            ',clc$abbreviation_entry, 3],
    ['EXTEND_UTILITY_INTERACTION     ',clc$nominal_entry, 3],
    ['MENU_ROW                       ',clc$alias_entry, 2],
    ['MENU_ROWS                      ',clc$nominal_entry, 2],
    ['MR                             ',clc$abbreviation_entry, 2],
    ['S                              ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['STYLE                          ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [4], [
    ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['LINE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SCREEN                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, csc$number_of_menu_rows, 10]],
{ PARAMETER 3
    [[1, 0, clc$boolean_type]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$style = 1,
      p$menu_rows = 2,
      p$extend_utility_interaction = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      index: 0 .. p$status - 1,
      interaction_information: ^ost$interaction_information,
      parameter_count: 0 .. p$status - 1;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    parameter_count := 0;
    FOR index := 1 TO p$status - 1 DO
      IF pvt [index].specified THEN
        parameter_count := parameter_count + 1;
      IFEND;
    FOREND;
    IF parameter_count = 0 THEN
      RETURN;
    IFEND;

    PUSH interaction_information: [1 .. parameter_count];
    index := 0;

    IF pvt [p$style].specified THEN
      index := index + 1;
      interaction_information^ [index].key := osc$interaction_style;
      IF pvt [p$style].value^.keyword_value = 'LINE' THEN
        interaction_information^ [index].style := osc$line_interaction;
      ELSE
        interaction_information^ [index].style := osc$screen_interaction;
      IFEND;
    IFEND;

    IF pvt [p$menu_rows].specified THEN
      index := index + 1;
      interaction_information^ [index].key := osc$menu_rows;
      interaction_information^ [index].menu_rows := pvt [p$menu_rows].value^.integer_value.value;
    IFEND;

    IF pvt [p$extend_utility_interaction].specified THEN
      index := index + 1;
      interaction_information^ [index].key := osc$extend_utility_interaction;
      interaction_information^ [index].extend_utility_interaction := pvt [p$extend_utility_interaction].
            value^.boolean_value.value;
    IFEND;

    osp$change_interaction_info (interaction_information^, status);

  PROCEND osp$_change_interaction_informa;
?? TITLE := 'osp$$interaction_style', EJECT ??

  PROCEDURE [XDCL] osp$$interaction_style
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$ints) $interaction_style (
{   option: key
{       style
{       (menu_rows, menu_row, mr)
{       (extend_utility_interaction, eui)
{       (last_operation_style, los)
{       (line, l)
{       (screen, s)
{       (desktop, dt, d)
{     keyend = style
{   )

?? 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$keyword_type_qualifier,
        keyword_specs: array [1 .. 15] of clt$keyword_specification,
        default_value: string (5),
      recend,
    recend := [
    [1,
    [90, 3, 3, 10, 25, 38, 558],
    clc$function, 1, 1, 0, 0, 0, 0, 0, 'OSM$$INTS'], [
    ['OPTION                         ',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, 562,
  clc$optional_default_parameter, 0, 5]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [15], [
    ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
    ['DESKTOP                        ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['DT                             ', clc$alias_entry, clc$normal_usage_entry, 7],
    ['EUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['EXTEND_UTILITY_INTERACTION     ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['LAST_OPERATION_STYLE           ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['LINE                           ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['LOS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['MENU_ROW                       ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['MENU_ROWS                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['MR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['SCREEN                         ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['STYLE                          ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'style']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$option = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      interactive_context: array [1 .. 1] of ift$fetch_context_attribute,
      interaction_information: array [1 .. 3] of ost$interaction_info_item,
      keyword: ost$name,
      style: ost$interaction_style,
      style_boolean: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    interaction_information [1].key := osc$interaction_style;
    interaction_information [2].key := osc$menu_rows;
    interaction_information [3].key := osc$extend_utility_interaction;
    osp$get_interaction_information (interaction_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$option].value^.keyword_value = 'STYLE' THEN
      IF interaction_information [1].style = osc$line_interaction THEN
        keyword := 'LINE';
      ELSEIF interaction_information [1].style = osc$screen_interaction THEN
        keyword := 'SCREEN';
      ELSE
        keyword := 'DESKTOP';
      IFEND;
      clp$make_keyword_value (keyword, work_area, result);

    ELSEIF pvt [p$option].value^.keyword_value = 'MENU_ROWS' THEN
      clp$make_integer_value (interaction_information [2].menu_rows, 10, FALSE, work_area, result);

    ELSEIF pvt [p$option].value^.keyword_value = 'EXTEND_UTILITY_INTERACTION' THEN
      clp$make_boolean_value (interaction_information [3].extend_utility_interaction, clc$true_false_boolean,
            work_area, result);

    ELSEIF pvt [p$option].value^.keyword_value = 'LAST_OPERATION_STYLE' THEN
      IF interaction_information [1].style = osc$desktop_interaction THEN
        keyword := 'DESKTOP';
      ELSE
        interactive_context [1].key := ifc$previous_mode;
        ifp$fetch_context (interactive_context, status);
        IF NOT status.normal THEN
          RETURN;
        ELSEIF interactive_context [1].previous_mode = ifc$screen THEN
          keyword := 'SCREEN';
        ELSE
          keyword := 'LINE';
        IFEND;
      IFEND;
      clp$make_keyword_value (keyword, work_area, result);

    ELSE
      CASE pvt [p$option].value^.keyword_value (1) OF
      = 'L' =
        style := osc$line_interaction;
      = 'S' =
        style := osc$screen_interaction;
      = 'D' =
        style := osc$desktop_interaction;
      CASEND;
      clp$make_boolean_value (interaction_information [1].style = style, clc$true_false_boolean, work_area,
            result);
    IFEND;

  PROCEND osp$$interaction_style;
?? TITLE := 'osp$$interaction_information', EJECT ??

  PROCEDURE [XDCL] osp$$interaction_information
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$inti) $interaction_information

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [90, 3, 5, 19, 0, 11, 415],
    clc$function, 0, 0, 0, 0, 0, 0, 0, 'OSM$$INTI']];

?? FMT (FORMAT := ON) ??
?? POP ??


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    make_info_record (work_area, result, status);

  PROCEND osp$$interaction_information;
?? TITLE := 'osp$_display_interaction_style', EJECT ??

  PROCEDURE [XDCL] osp$_display_interaction_inform
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$disis) display_interaction_information, disii (
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 3, 5, 13, 18, 23, 338],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$DISIS'], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

*copy clv$display_variables

    VAR
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      ignore_status: ^ost$status,
      representation: ^clt$data_representation,
      result: ^clt$data_value,
      work_area: ^^clt$work_area;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;


      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;
*copy clp$new_page_procedure
?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);


{ The display_interaction_style command has no subtitles.
{ This is a "dummy" routine to keep this module consistent
{ with those that do produce subtitles.

    PROCEND put_subtitle;
?? OLDTITLE, EJECT ??

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_work_area (#RING (^work_area), work_area, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    make_info_record (work_area^, result, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    osp$establish_block_exit_hndlr (^abort_handler);

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          default_ring_attributes, display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN
    IFEND;
    clv$titles_built := FALSE;
    clv$subtitles_built := FALSE;
    clv$command_name := 'display_interaction_style';

    IF display_control.page_width < clc$narrow_page_width THEN
      clv$page_width := clc$narrow_page_width;
    ELSEIF display_control.page_width > clc$wide_page_width THEN
      clv$page_width := clc$wide_page_width;
    ELSE
      clv$page_width := display_control.page_width;
    IFEND;

    clp$convert_data_to_string (result, clc$labeled_elem_representation, display_control.page_width,
          work_area^, representation, status);
    IF status.normal THEN
      clp$put_data_representation (display_control, representation, status);
    IFEND;

    IF status.normal THEN
      clp$close_display (display_control, status);
    ELSE
      PUSH ignore_status;
      clp$close_display (display_control, ignore_status^);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND osp$_display_interaction_inform;
?? TITLE := 'make_info_record', EJECT ??

  PROCEDURE make_info_record
    (VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

    VAR
      interaction_information: array [1 .. 3] of ost$interaction_info_item,
      interactive_context: array [1 .. 1] of ift$fetch_context_attribute,
      keyword: clt$keyword;


    interaction_information [1].key := osc$interaction_style;
    interaction_information [2].key := osc$menu_rows;
    interaction_information [3].key := osc$extend_utility_interaction;
    osp$get_interaction_information (interaction_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$make_record_value (4, work_area, result);

    result^.field_values^ [1].name := 'STYLE';
    IF interaction_information [1].style = osc$line_interaction THEN
      keyword := 'LINE';
    ELSEIF interaction_information [1].style = osc$screen_interaction THEN
      keyword := 'SCREEN';
    ELSE
      keyword := 'DESKTOP';
    IFEND;
    clp$make_keyword_value (keyword, work_area, result^.field_values^ [1].value);

    result^.field_values^ [2].name := 'MENU_ROWS';
    clp$make_integer_value (interaction_information [2].menu_rows, 10, FALSE, work_area,
          result^.field_values^ [2].value);

    result^.field_values^ [3].name := 'EXTEND_UTILITY_INTERACTION';
    clp$make_boolean_value (interaction_information [3].extend_utility_interaction, clc$yes_no_boolean,
          work_area, result^.field_values^ [3].value);

    result^.field_values^ [4].name := 'LAST_OPERATION_STYLE';
    IF interaction_information [1].style = osc$desktop_interaction THEN
      keyword := 'DESKTOP';
    ELSE
      interactive_context [1].key := ifc$previous_mode;
      ifp$fetch_context (interactive_context, status);
      IF NOT status.normal THEN
        RETURN;
      ELSEIF interactive_context [1].previous_mode = ifc$screen THEN
        keyword := 'SCREEN';
      ELSE
        keyword := 'LINE';
      IFEND;
    IFEND;
    clp$make_keyword_value (keyword, work_area, result^.field_values^ [4].value);

  PROCEND make_info_record;

MODEND osm$change_interact_style_cmnd;
*DECK DECK=OSM$CHANGE_OS_DEFAULTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operating System : Change OS Defaults' ??
MODULE osm$change_os_defaults;

{ PURPOSE:
{   This module contains the command handlers for:
{     CHANGE_DATE
{     CHANGE_DEFAULT_DATE_FORMAT
{     CHANGE_DEFAULT_TIME_FORMAT
{     CHANGE_OPERATING_SYSTEM_NAME
{     CHANGE_TIME
{     CHANGE_TIME_ZONE

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$log_comment
*copyc osp$change_os_default_ring_3
*copyc pmp$compute_date_time
*copyc pmp$get_date_time_at_timestamp
*copyc pmp$get_time_zone
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    v$log_array: [STATIC, READ, oss$job_paged_literal] ARRAY [1 .. 8] OF ost$name :=
          ['SYSTEM', 'STATISTIC', 'ENGINEERING', 'ACCOUNT', 'JOB', 'JOB_ACCOUNT', 'JOB_STATISTIC', 'HISTORY'];
?? OLDTITLE ??
?? NEWTITLE := 'osp$_change_date', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$_change_date
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (osm$sou_chad) change_date, chad (
{    month, m : integer 1 .. 12 = $required
{    day,   d : integer 1 .. 31 = $required
{    year, y  : integer 1900 .. 2155 = $required
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 9, 12, 32, 43, 623],
    clc$command, 7, 4, 3, 0, 0, 0, 4, 'OSM$SOU_CHAD'], [
    ['D                              ',clc$abbreviation_entry, 2],
    ['DAY                            ',clc$nominal_entry, 2],
    ['M                              ',clc$abbreviation_entry, 1],
    ['MONTH                          ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['Y                              ',clc$abbreviation_entry, 3],
    ['YEAR                           ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [1, 12, 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, 31, 10]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1900, 2155, 10]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$month = 1,
      p$day = 2,
      p$year = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      ignore_status: ost$status,
      os_default: ost$operating_system_default;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    os_default.kind := osc$date_time;
    os_default.free_running_clock := #FREE_RUNNING_CLOCK (0);
    pmp$get_date_time_at_timestamp (os_default.free_running_clock, pmc$use_system_local_time,
          os_default.date_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    os_default.date_time.month := pvt [p$month].value^.integer_value.value;
    os_default.date_time.day := pvt [p$day].value^.integer_value.value;
    os_default.date_time.year := pvt [p$year].value^.integer_value.value - 1900;

    osp$change_os_default_ring_3 (os_default, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$log_comment ('System date changed by operator.', v$log_array, ignore_status);

  PROCEND osp$_change_date;
?? OLDTITLE ??
?? NEWTITLE := 'osp$_change_default_date_format', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$_change_default_date_format
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (osm$sou_chaddf) change_default_date_format, chaddf (
{    format, f: key
{        month
{        mdy
{        dmy
{        isod
{        ordinal
{     keyend = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 9, 13, 15, 8, 465],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$SOU_CHADDF'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FORMAT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [5], [
    ['DMY                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['ISOD                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['MDY                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['MONTH                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['ORDINAL                        ', clc$nominal_entry, clc$normal_usage_entry, 5]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$format = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      ignore_status: ost$status,
      os_default: ost$operating_system_default;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    os_default.kind := osc$default_date_format;

    IF pvt [p$format].value^.keyword_value = 'MONTH' THEN
      os_default.default_date.date_format := osc$month_date;
      os_default.default_date.format_string := 'MN D2, Y4';
    ELSEIF pvt [p$format].value^.keyword_value = 'MDY' THEN
      os_default.default_date.date_format := osc$mdy_date;
      os_default.default_date.format_string := 'M2/D2/Y2';
    ELSEIF pvt [p$format].value^.keyword_value = 'DMY' THEN
      os_default.default_date.date_format := osc$dmy_date;
      os_default.default_date.format_string := 'D2.M2.Y2';
    ELSEIF pvt [p$format].value^.keyword_value = 'ISOD' THEN
      os_default.default_date.date_format := osc$iso_date;
      os_default.default_date.format_string := 'Y4-M2-D2';
    ELSEIF pvt [p$format].value^.keyword_value = 'ORDINAL' THEN
      os_default.default_date.date_format := osc$ordinal_date;
      os_default.default_date.format_string := 'Y4J3';
    ELSE
      RETURN;
    IFEND;

    osp$change_os_default_ring_3 (os_default, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$log_comment ('System default date format changed by operator.', v$log_array, ignore_status);

  PROCEND osp$_change_default_date_format;
?? OLDTITLE ??
?? NEWTITLE := 'osp$_change_default_time_format', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$_change_default_time_format
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (osm$sou_chadtf) change_default_time_format, chadtf(
{     format,f: key
{         ampm
{         hms
{         (millisecond, ms)
{         isot
{       keyend = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 9, 13, 24, 24, 441],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$SOU_CHADTF'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FORMAT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [5], [
    ['AMPM                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['HMS                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['ISOT                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['MILLISECOND                    ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['MS                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$format = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      ignore_status: ost$status,
      os_default: ost$operating_system_default;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    os_default.kind := osc$default_time_format;

    IF pvt [p$format].value^.keyword_value = 'AMPM' THEN
      os_default.default_time.time_format := osc$ampm_time;
      os_default.default_time.format_string := 'H12:MM AMORPM';
    ELSEIF pvt [p$format].value^.keyword_value = 'HMS' THEN
      os_default.default_time.time_format := osc$hms_time;
      os_default.default_time.format_string := 'H24:MM:SS';
    ELSEIF pvt [p$format].value^.keyword_value = 'MILLISECOND' THEN
      os_default.default_time.time_format := osc$millisecond_time;
      os_default.default_time.format_string := 'H24:MM:SS.S1000';
    ELSEIF pvt [p$format].value^.keyword_value = 'ISOT' THEN
      os_default.default_time.time_format := osc$millisecond_time;
      os_default.default_time.format_string := 'ISOT';
    ELSE
      RETURN;
    IFEND;

    osp$change_os_default_ring_3 (os_default, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$log_comment ('System default time format changed by operator.', v$log_array, ignore_status);

  PROCEND osp$_change_default_time_format;
?? OLDTITLE ??
?? NEWTITLE := 'osp$_change_operating_system_na', EJECT ??

  PROCEDURE [XDCL] osp$_change_operating_system_na
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (osm$chaosn) change_operating_system_name, chaosn(
{    operating_system_name, osn : string 1 .. 22 = $required
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 9, 12, 23, 32, 377],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$CHAOSN'], [
    ['OPERATING_SYSTEM_NAME          ',clc$nominal_entry, 1],
    ['OSN                            ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [1, 22, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$operating_system_name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      ignore_status: ost$status,
      os_default: ost$operating_system_default;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    os_default.kind := osc$os_name;
    os_default.os_name := pvt [p$operating_system_name].value^.string_value^;

    osp$change_os_default_ring_3 (os_default, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$log_comment ('System operating system name changed by operator.', v$log_array, ignore_status);

  PROCEND osp$_change_operating_system_na;
?? OLDTITLE ??
?? NEWTITLE := 'osp$_change_time', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$_change_time
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (osm$sou_chat) change_time, chat (
{    hour, h   : integer 0 .. 23 = $required
{    minute, m : integer 0 .. 59 = $required
{    second, s : integer 0 .. 59 = 0
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 9, 12, 52, 57, 807],
    clc$command, 7, 4, 2, 0, 0, 0, 4, 'OSM$SOU_CHAT'], [
    ['H                              ',clc$abbreviation_entry, 1],
    ['HOUR                           ',clc$nominal_entry, 1],
    ['M                              ',clc$abbreviation_entry, 2],
    ['MINUTE                         ',clc$nominal_entry, 2],
    ['S                              ',clc$abbreviation_entry, 3],
    ['SECOND                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 23, 10]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, 59, 10]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, 59, 10],
    '0'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$hour = 1,
      p$minute = 2,
      p$second = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      ignore_status: ost$status,
      os_default: ost$operating_system_default;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    os_default.kind := osc$date_time;
    os_default.free_running_clock := #FREE_RUNNING_CLOCK (0);
    pmp$get_date_time_at_timestamp (os_default.free_running_clock, pmc$use_system_local_time,
          os_default.date_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    os_default.date_time.hour := pvt [p$hour].value^.integer_value.value;
    os_default.date_time.minute := pvt [p$minute].value^.integer_value.value;
    os_default.date_time.second := pvt [p$second].value^.integer_value.value;
    os_default.date_time.millisecond := 0;

    osp$change_os_default_ring_3 (os_default, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$log_comment ('System time changed by operator.', v$log_array, ignore_status);

  PROCEND osp$_change_time;
?? OLDTITLE ??
?? NEWTITLE := 'osp$_change_time_zone', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$_change_time_zone
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (osm$sou_chatz) change_time_zone, chatz(
{    time_zone, tz: time_zone = $required
{    adjust_date_time, adt: boolean = $required
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 9, 13, 32, 20, 209],
    clc$command, 5, 3, 2, 0, 0, 0, 3, 'OSM$SOU_CHATZ'], [
    ['ADJUST_DATE_TIME               ',clc$nominal_entry, 2],
    ['ADT                            ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['TIME_ZONE                      ',clc$nominal_entry, 1],
    ['TZ                             ',clc$abbreviation_entry, 1]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$time_zone_type]],
{ PARAMETER 2
    [[1, 0, clc$boolean_type]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$time_zone = 1,
      p$adjust_date_time = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      current_time_zone: ost$time_zone,
      date_time: ost$date_time,
      ignore_status: ost$status,
      local_date_time: ost$date_time,
      os_default: ost$operating_system_default,
      time_zone: ost$time_zone,
      time_zone_increment: pmt$time_increment;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    time_zone := pvt [p$time_zone].value^.time_zone_value;
    IF pvt [p$adjust_date_time].value^.boolean_value.value THEN
      pmp$get_date_time_at_timestamp (#FREE_RUNNING_CLOCK (0), pmc$use_system_local_time, date_time, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      pmp$get_time_zone (current_time_zone, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    os_default.kind := osc$time_zone;
    os_default.time_zone := time_zone;

    osp$change_os_default_ring_3 (os_default, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$adjust_date_time].value^.boolean_value.value THEN
      IF time_zone.daylight_saving_time <> current_time_zone.daylight_saving_time THEN
        IF time_zone.daylight_saving_time THEN
          time_zone_increment.hour := 1;
        ELSE
          time_zone_increment.hour := -1;
        IFEND;

        time_zone_increment.minute := 0;
        time_zone_increment.second := 0;
        time_zone_increment.millisecond := 0;
        time_zone_increment.year := 0;
        time_zone_increment.month := 0;
        time_zone_increment.day := 0;
        pmp$compute_date_time (date_time, time_zone_increment, local_date_time, status);
        os_default.kind := osc$date_time;
        os_default.date_time := local_date_time;
        os_default.free_running_clock := #FREE_RUNNING_CLOCK (0);

        osp$change_os_default_ring_3 (os_default, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      clp$log_comment ('System time zone changed and time adjusted by operator.', v$log_array, ignore_status);
    ELSE
      clp$log_comment ('System time zone changed by operator.', v$log_array, ignore_status);
    IFEND;

  PROCEND osp$_change_time_zone;
?? OLDTITLE ??
MODEND osm$change_os_defaults;
*DECK DECK=OSM$CHANGE_OS_DEFAULTS_R3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operating System : Change OS Defaults Ring 3' ??
MODULE osm$change_os_defaults_r3;

{ PURPOSE:
{   This module contains the ring 3 interface for changing operating system defaults.

?? NEWTITLE := 'GLobal Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ofe$error_codes
*copyc ose$default_process_exceptions
?? POP ??
*copyc avp$configuration_administrator
*copyc avp$system_operator
*copyc osp$change_os_default_ring_1
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := 'osp$change_os_default_ring_3', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$change_os_default_ring_3
    (    os_default: ost$operating_system_default;
     VAR status: ost$status);

    status.normal := TRUE;

    CASE os_default.kind OF

    = osc$os_name, osc$date_time, osc$time_zone =
      IF NOT avp$system_operator () THEN
        osp$set_status_abnormal ('OF', ofe$sou_not_active, 'system_operator', status);
        RETURN;
      IFEND;

    = osc$default_date_format, osc$default_time_format =
      IF NOT avp$configuration_administrator () THEN
        osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_admininistrator', status);
        RETURN;
      IFEND;

    ELSE
        osp$set_status_abnormal ('OS', ose$invalid_os_default_selected, '', status);
    CASEND;

    osp$change_os_default_ring_1 (os_default, status);

  PROCEND osp$change_os_default_ring_3;
MODEND osm$change_os_defaults_r3;
*DECK DECK=OSM$CHANGE_OS_DEFAULTS_RING_1 EXPAND=TRUE
*DECK DECK=OSM$CHARACTER_TRANSLATION_MGR EXPAND=TRUE
?? RIGHT := 110 ??
MODULE osm$character_translation_mgr;

{ NOTE:  OSM$CHARACTER_TRANSLATION_MGR cannot be moved to system core because      }
{ the tables OSV$LOWER_TO_UPPER and OSV$UPPER_TO_LOWER must be able to be changed  }
{ on a job by job basis.                                                           }

*IF NOT $true(osv$unix)
*copyc oss$job_paged_literal
*copyc oss$task_shared
*IFEND

?? NEWTITLE := 'osv$lower_to_upper_26', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    osv$lower_to_upper_26: [XDCL, #GATE, READ, oss$job_paged_literal] string (256) := $CHAR (00) CAT
*ELSE
    osv$lower_to_upper_26: [XDCL, #GATE, READ] string (256) := $CHAR (00) CAT
*IFEND
          $CHAR (01) CAT $CHAR (02) CAT $CHAR (03) CAT $CHAR (04) CAT $CHAR (05) CAT $CHAR (06) CAT
          $CHAR (07) CAT $CHAR (08) CAT $CHAR (09) CAT $CHAR (10) CAT $CHAR (11) CAT $CHAR (12) CAT
          $CHAR (13) CAT $CHAR (14) CAT $CHAR (15) CAT $CHAR (16) CAT $CHAR (17) CAT $CHAR (18) CAT
          $CHAR (19) CAT $CHAR (20) CAT $CHAR (21) CAT $CHAR (22) CAT $CHAR (23) CAT $CHAR (24) CAT
          $CHAR (25) CAT $CHAR (26) CAT $CHAR (27) CAT $CHAR (28) CAT $CHAR (29) CAT $CHAR (30) CAT
          $CHAR (31) CAT ' !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`ABCDEFGHIJKLM' CAT
          'NOPQRSTUVWXYZ{|}~' CAT $CHAR (127) CAT $CHAR (128) CAT $CHAR (129) CAT $CHAR (130) CAT
          $CHAR (131) CAT $CHAR (132) CAT $CHAR (133) CAT $CHAR (134) CAT $CHAR (135) CAT $CHAR (136) CAT
          $CHAR (137) CAT $CHAR (138) CAT $CHAR (139) CAT $CHAR (140) CAT $CHAR (141) CAT $CHAR (142) CAT
          $CHAR (143) CAT $CHAR (144) CAT $CHAR (145) CAT $CHAR (146) CAT $CHAR (147) CAT $CHAR (148) CAT
          $CHAR (149) CAT $CHAR (150) CAT $CHAR (151) CAT $CHAR (152) CAT $CHAR (153) CAT $CHAR (154) CAT
          $CHAR (155) CAT $CHAR (156) CAT $CHAR (157) CAT $CHAR (158) CAT $CHAR (159) CAT $CHAR (160) CAT
          $CHAR (161) CAT $CHAR (162) CAT $CHAR (163) CAT $CHAR (164) CAT $CHAR (165) CAT $CHAR (166) CAT
          $CHAR (167) CAT $CHAR (168) CAT $CHAR (169) CAT $CHAR (170) CAT $CHAR (171) CAT $CHAR (172) CAT
          $CHAR (173) CAT $CHAR (174) CAT $CHAR (175) CAT $CHAR (176) CAT $CHAR (177) CAT $CHAR (178) CAT
          $CHAR (179) CAT $CHAR (180) CAT $CHAR (181) CAT $CHAR (182) CAT $CHAR (183) CAT $CHAR (184) CAT
          $CHAR (185) CAT $CHAR (186) CAT $CHAR (187) CAT $CHAR (188) CAT $CHAR (189) CAT $CHAR (190) CAT
          $CHAR (191) CAT $CHAR (192) CAT $CHAR (193) CAT $CHAR (194) CAT $CHAR (195) CAT $CHAR (196) CAT
          $CHAR (197) CAT $CHAR (198) CAT $CHAR (199) CAT $CHAR (200) CAT $CHAR (201) CAT $CHAR (202) CAT
          $CHAR (203) CAT $CHAR (204) CAT $CHAR (205) CAT $CHAR (206) CAT $CHAR (207) CAT $CHAR (208) CAT
          $CHAR (209) CAT $CHAR (210) CAT $CHAR (211) CAT $CHAR (212) CAT $CHAR (213) CAT $CHAR (214) CAT
          $CHAR (215) CAT $CHAR (216) CAT $CHAR (217) CAT $CHAR (218) CAT $CHAR (219) CAT $CHAR (220) CAT
          $CHAR (221) CAT $CHAR (222) CAT $CHAR (223) CAT $CHAR (224) CAT $CHAR (225) CAT $CHAR (226) CAT
          $CHAR (227) CAT $CHAR (228) CAT $CHAR (229) CAT $CHAR (230) CAT $CHAR (231) CAT $CHAR (232) CAT
          $CHAR (233) CAT $CHAR (234) CAT $CHAR (235) CAT $CHAR (236) CAT $CHAR (237) CAT $CHAR (238) CAT
          $CHAR (239) CAT $CHAR (240) CAT $CHAR (241) CAT $CHAR (242) CAT $CHAR (243) CAT $CHAR (244) CAT
          $CHAR (245) CAT $CHAR (246) CAT $CHAR (247) CAT $CHAR (248) CAT $CHAR (249) CAT $CHAR (250) CAT
          $CHAR (251) CAT $CHAR (252) CAT $CHAR (253) CAT $CHAR (254) CAT $CHAR (255);

?? TITLE := 'osv$upper_to_lower_26', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    osv$upper_to_lower_26: [XDCL, #GATE, READ, oss$job_paged_literal] string (256) := $CHAR (00) CAT
*ELSE
    osv$upper_to_lower_26: [XDCL, #GATE, READ] string (256) := $CHAR (00) CAT
*IFEND
          $CHAR (01) CAT $CHAR (02) CAT $CHAR (03) CAT $CHAR (04) CAT $CHAR (05) CAT $CHAR (06) CAT
          $CHAR (07) CAT $CHAR (08) CAT $CHAR (09) CAT $CHAR (10) CAT $CHAR (11) CAT $CHAR (12) CAT
          $CHAR (13) CAT $CHAR (14) CAT $CHAR (15) CAT $CHAR (16) CAT $CHAR (17) CAT $CHAR (18) CAT
          $CHAR (19) CAT $CHAR (20) CAT $CHAR (21) CAT $CHAR (22) CAT $CHAR (23) CAT $CHAR (24) CAT
          $CHAR (25) CAT $CHAR (26) CAT $CHAR (27) CAT $CHAR (28) CAT $CHAR (29) CAT $CHAR (30) CAT
          $CHAR (31) CAT ' !"#$%&''()*+,-./0123456789:;<=>?@abcdefghijklmnopqrstuvwxyz[\]^_`abcdefghijklm' CAT
          'nopqrstuvwxyz{|}~' CAT $CHAR (127) CAT $CHAR (128) CAT $CHAR (129) CAT $CHAR (130) CAT
          $CHAR (131) CAT $CHAR (132) CAT $CHAR (133) CAT $CHAR (134) CAT $CHAR (135) CAT $CHAR (136) CAT
          $CHAR (137) CAT $CHAR (138) CAT $CHAR (139) CAT $CHAR (140) CAT $CHAR (141) CAT $CHAR (142) CAT
          $CHAR (143) CAT $CHAR (144) CAT $CHAR (145) CAT $CHAR (146) CAT $CHAR (147) CAT $CHAR (148) CAT
          $CHAR (149) CAT $CHAR (150) CAT $CHAR (151) CAT $CHAR (152) CAT $CHAR (153) CAT $CHAR (154) CAT
          $CHAR (155) CAT $CHAR (156) CAT $CHAR (157) CAT $CHAR (158) CAT $CHAR (159) CAT $CHAR (160) CAT
          $CHAR (161) CAT $CHAR (162) CAT $CHAR (163) CAT $CHAR (164) CAT $CHAR (165) CAT $CHAR (166) CAT
          $CHAR (167) CAT $CHAR (168) CAT $CHAR (169) CAT $CHAR (170) CAT $CHAR (171) CAT $CHAR (172) CAT
          $CHAR (173) CAT $CHAR (174) CAT $CHAR (175) CAT $CHAR (176) CAT $CHAR (177) CAT $CHAR (178) CAT
          $CHAR (179) CAT $CHAR (180) CAT $CHAR (181) CAT $CHAR (182) CAT $CHAR (183) CAT $CHAR (184) CAT
          $CHAR (185) CAT $CHAR (186) CAT $CHAR (187) CAT $CHAR (188) CAT $CHAR (189) CAT $CHAR (190) CAT
          $CHAR (191) CAT $CHAR (192) CAT $CHAR (193) CAT $CHAR (194) CAT $CHAR (195) CAT $CHAR (196) CAT
          $CHAR (197) CAT $CHAR (198) CAT $CHAR (199) CAT $CHAR (200) CAT $CHAR (201) CAT $CHAR (202) CAT
          $CHAR (203) CAT $CHAR (204) CAT $CHAR (205) CAT $CHAR (206) CAT $CHAR (207) CAT $CHAR (208) CAT
          $CHAR (209) CAT $CHAR (210) CAT $CHAR (211) CAT $CHAR (212) CAT $CHAR (213) CAT $CHAR (214) CAT
          $CHAR (215) CAT $CHAR (216) CAT $CHAR (217) CAT $CHAR (218) CAT $CHAR (219) CAT $CHAR (220) CAT
          $CHAR (221) CAT $CHAR (222) CAT $CHAR (223) CAT $CHAR (224) CAT $CHAR (225) CAT $CHAR (226) CAT
          $CHAR (227) CAT $CHAR (228) CAT $CHAR (229) CAT $CHAR (230) CAT $CHAR (231) CAT $CHAR (232) CAT
          $CHAR (233) CAT $CHAR (234) CAT $CHAR (235) CAT $CHAR (236) CAT $CHAR (237) CAT $CHAR (238) CAT
          $CHAR (239) CAT $CHAR (240) CAT $CHAR (241) CAT $CHAR (242) CAT $CHAR (243) CAT $CHAR (244) CAT
          $CHAR (245) CAT $CHAR (246) CAT $CHAR (247) CAT $CHAR (248) CAT $CHAR (249) CAT $CHAR (250) CAT
          $CHAR (251) CAT $CHAR (252) CAT $CHAR (253) CAT $CHAR (254) CAT $CHAR (255);

?? TITLE := 'osv$lower_to_upper_full', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    osv$lower_to_upper_full: [XDCL, #GATE, READ, oss$job_paged_literal] string (256) := $CHAR (00) CAT
*ELSE
    osv$lower_to_upper_full: [XDCL, #GATE, READ] string (256) := $CHAR (00) CAT
*IFEND
          $CHAR (01) CAT $CHAR (02) CAT $CHAR (03) CAT $CHAR (04) CAT $CHAR (05) CAT $CHAR (06) CAT
          $CHAR (07) CAT $CHAR (08) CAT $CHAR (09) CAT $CHAR (10) CAT $CHAR (11) CAT $CHAR (12) CAT
          $CHAR (13) CAT $CHAR (14) CAT $CHAR (15) CAT $CHAR (16) CAT $CHAR (17) CAT $CHAR (18) CAT
          $CHAR (19) CAT $CHAR (20) CAT $CHAR (21) CAT $CHAR (22) CAT $CHAR (23) CAT $CHAR (24) CAT
          $CHAR (25) CAT $CHAR (26) CAT $CHAR (27) CAT $CHAR (28) CAT $CHAR (29) CAT $CHAR (30) CAT
          $CHAR (31) CAT ' !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_@ABCDEFGHIJKLM' CAT
          'NOPQRSTUVWXYZ[\]^' CAT $CHAR (127) CAT $CHAR (128) CAT $CHAR (129) CAT $CHAR (130) CAT
          $CHAR (131) CAT $CHAR (132) CAT $CHAR (133) CAT $CHAR (134) CAT $CHAR (135) CAT $CHAR (136) CAT
          $CHAR (137) CAT $CHAR (138) CAT $CHAR (139) CAT $CHAR (140) CAT $CHAR (141) CAT $CHAR (142) CAT
          $CHAR (143) CAT $CHAR (144) CAT $CHAR (145) CAT $CHAR (146) CAT $CHAR (147) CAT $CHAR (148) CAT
          $CHAR (149) CAT $CHAR (150) CAT $CHAR (151) CAT $CHAR (152) CAT $CHAR (153) CAT $CHAR (154) CAT
          $CHAR (155) CAT $CHAR (156) CAT $CHAR (157) CAT $CHAR (158) CAT $CHAR (159) CAT $CHAR (160) CAT
          $CHAR (161) CAT $CHAR (162) CAT $CHAR (163) CAT $CHAR (164) CAT $CHAR (165) CAT $CHAR (166) CAT
          $CHAR (167) CAT $CHAR (168) CAT $CHAR (169) CAT $CHAR (170) CAT $CHAR (171) CAT $CHAR (172) CAT
          $CHAR (173) CAT $CHAR (174) CAT $CHAR (175) CAT $CHAR (176) CAT $CHAR (177) CAT $CHAR (178) CAT
          $CHAR (179) CAT $CHAR (180) CAT $CHAR (181) CAT $CHAR (182) CAT $CHAR (183) CAT $CHAR (184) CAT
          $CHAR (185) CAT $CHAR (186) CAT $CHAR (187) CAT $CHAR (188) CAT $CHAR (189) CAT $CHAR (190) CAT
          $CHAR (191) CAT $CHAR (192) CAT $CHAR (193) CAT $CHAR (194) CAT $CHAR (195) CAT $CHAR (196) CAT
          $CHAR (197) CAT $CHAR (198) CAT $CHAR (199) CAT $CHAR (200) CAT $CHAR (201) CAT $CHAR (202) CAT
          $CHAR (203) CAT $CHAR (204) CAT $CHAR (205) CAT $CHAR (206) CAT $CHAR (207) CAT $CHAR (208) CAT
          $CHAR (209) CAT $CHAR (210) CAT $CHAR (211) CAT $CHAR (212) CAT $CHAR (213) CAT $CHAR (214) CAT
          $CHAR (215) CAT $CHAR (216) CAT $CHAR (217) CAT $CHAR (218) CAT $CHAR (219) CAT $CHAR (220) CAT
          $CHAR (221) CAT $CHAR (222) CAT $CHAR (223) CAT $CHAR (224) CAT $CHAR (225) CAT $CHAR (226) CAT
          $CHAR (227) CAT $CHAR (228) CAT $CHAR (229) CAT $CHAR (230) CAT $CHAR (231) CAT $CHAR (232) CAT
          $CHAR (233) CAT $CHAR (234) CAT $CHAR (235) CAT $CHAR (236) CAT $CHAR (237) CAT $CHAR (238) CAT
          $CHAR (239) CAT $CHAR (240) CAT $CHAR (241) CAT $CHAR (242) CAT $CHAR (243) CAT $CHAR (244) CAT
          $CHAR (245) CAT $CHAR (246) CAT $CHAR (247) CAT $CHAR (248) CAT $CHAR (249) CAT $CHAR (250) CAT
          $CHAR (251) CAT $CHAR (252) CAT $CHAR (253) CAT $CHAR (254) CAT $CHAR (255);

?? TITLE := 'osv$upper_to_lower_full', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    osv$upper_to_lower_full: [XDCL, #GATE, READ, oss$job_paged_literal] string (256) := $CHAR (00) CAT
*ELSE
    osv$upper_to_lower_full: [XDCL, #GATE, READ] string (256) := $CHAR (00) CAT
*IFEND
          $CHAR (01) CAT $CHAR (02) CAT $CHAR (03) CAT $CHAR (04) CAT $CHAR (05) CAT $CHAR (06) CAT
          $CHAR (07) CAT $CHAR (08) CAT $CHAR (09) CAT $CHAR (10) CAT $CHAR (11) CAT $CHAR (12) CAT
          $CHAR (13) CAT $CHAR (14) CAT $CHAR (15) CAT $CHAR (16) CAT $CHAR (17) CAT $CHAR (18) CAT
          $CHAR (19) CAT $CHAR (20) CAT $CHAR (21) CAT $CHAR (22) CAT $CHAR (23) CAT $CHAR (24) CAT
          $CHAR (25) CAT $CHAR (26) CAT $CHAR (27) CAT $CHAR (28) CAT $CHAR (29) CAT $CHAR (30) CAT
          $CHAR (31) CAT ' !"#$%&''()*+,-./0123456789:;<=>?`abcdefghijklmnopqrstuvwxyz{|}~_`abcdefghijklm' CAT
          'nopqrstuvwxyz{|}~' CAT $CHAR (127) CAT $CHAR (128) CAT $CHAR (129) CAT $CHAR (130) CAT
          $CHAR (131) CAT $CHAR (132) CAT $CHAR (133) CAT $CHAR (134) CAT $CHAR (135) CAT $CHAR (136) CAT
          $CHAR (137) CAT $CHAR (138) CAT $CHAR (139) CAT $CHAR (140) CAT $CHAR (141) CAT $CHAR (142) CAT
          $CHAR (143) CAT $CHAR (144) CAT $CHAR (145) CAT $CHAR (146) CAT $CHAR (147) CAT $CHAR (148) CAT
          $CHAR (149) CAT $CHAR (150) CAT $CHAR (151) CAT $CHAR (152) CAT $CHAR (153) CAT $CHAR (154) CAT
          $CHAR (155) CAT $CHAR (156) CAT $CHAR (157) CAT $CHAR (158) CAT $CHAR (159) CAT $CHAR (160) CAT
          $CHAR (161) CAT $CHAR (162) CAT $CHAR (163) CAT $CHAR (164) CAT $CHAR (165) CAT $CHAR (166) CAT
          $CHAR (167) CAT $CHAR (168) CAT $CHAR (169) CAT $CHAR (170) CAT $CHAR (171) CAT $CHAR (172) CAT
          $CHAR (173) CAT $CHAR (174) CAT $CHAR (175) CAT $CHAR (176) CAT $CHAR (177) CAT $CHAR (178) CAT
          $CHAR (179) CAT $CHAR (180) CAT $CHAR (181) CAT $CHAR (182) CAT $CHAR (183) CAT $CHAR (184) CAT
          $CHAR (185) CAT $CHAR (186) CAT $CHAR (187) CAT $CHAR (188) CAT $CHAR (189) CAT $CHAR (190) CAT
          $CHAR (191) CAT $CHAR (192) CAT $CHAR (193) CAT $CHAR (194) CAT $CHAR (195) CAT $CHAR (196) CAT
          $CHAR (197) CAT $CHAR (198) CAT $CHAR (199) CAT $CHAR (200) CAT $CHAR (201) CAT $CHAR (202) CAT
          $CHAR (203) CAT $CHAR (204) CAT $CHAR (205) CAT $CHAR (206) CAT $CHAR (207) CAT $CHAR (208) CAT
          $CHAR (209) CAT $CHAR (210) CAT $CHAR (211) CAT $CHAR (212) CAT $CHAR (213) CAT $CHAR (214) CAT
          $CHAR (215) CAT $CHAR (216) CAT $CHAR (217) CAT $CHAR (218) CAT $CHAR (219) CAT $CHAR (220) CAT
          $CHAR (221) CAT $CHAR (222) CAT $CHAR (223) CAT $CHAR (224) CAT $CHAR (225) CAT $CHAR (226) CAT
          $CHAR (227) CAT $CHAR (228) CAT $CHAR (229) CAT $CHAR (230) CAT $CHAR (231) CAT $CHAR (232) CAT
          $CHAR (233) CAT $CHAR (234) CAT $CHAR (235) CAT $CHAR (236) CAT $CHAR (237) CAT $CHAR (238) CAT
          $CHAR (239) CAT $CHAR (240) CAT $CHAR (241) CAT $CHAR (242) CAT $CHAR (243) CAT $CHAR (244) CAT
          $CHAR (245) CAT $CHAR (246) CAT $CHAR (247) CAT $CHAR (248) CAT $CHAR (249) CAT $CHAR (250) CAT
          $CHAR (251) CAT $CHAR (252) CAT $CHAR (253) CAT $CHAR (254) CAT $CHAR (255);

?? TITLE := 'osv$control_codes_to_quest_mark', EJECT ??

  VAR
*IF NOT $true(osv$unix)
    osv$control_codes_to_quest_mark: [XDCL, #GATE, READ, oss$job_paged_literal] string (256) :=
*ELSE
    osv$control_codes_to_quest_mark: [XDCL, #GATE, READ] string (256) :=
*IFEND
          '????????????' CAT '???????????????????? !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTU' CAT
          'VWXYZ[\]^_`abcdefghijkl' CAT 'mnopqrstuvwxyz{|}~?' CAT $CHAR (128) CAT $CHAR (129) CAT
          $CHAR (130) CAT $CHAR (131) CAT $CHAR (132) CAT $CHAR (133) CAT $CHAR (134) CAT $CHAR (135) CAT
          $CHAR (136) CAT $CHAR (137) CAT $CHAR (138) CAT $CHAR (139) CAT $CHAR (140) CAT $CHAR (141) CAT
          $CHAR (142) CAT $CHAR (143) CAT $CHAR (144) CAT $CHAR (145) CAT $CHAR (146) CAT $CHAR (147) CAT
          $CHAR (148) CAT $CHAR (149) CAT $CHAR (150) CAT $CHAR (151) CAT $CHAR (152) CAT $CHAR (153) CAT
          $CHAR (154) CAT $CHAR (155) CAT $CHAR (156) CAT $CHAR (157) CAT $CHAR (158) CAT $CHAR (159) CAT
          $CHAR (160) CAT $CHAR (161) CAT $CHAR (162) CAT $CHAR (163) CAT $CHAR (164) CAT $CHAR (165) CAT
          $CHAR (166) CAT $CHAR (167) CAT $CHAR (168) CAT $CHAR (169) CAT $CHAR (170) CAT $CHAR (171) CAT
          $CHAR (172) CAT $CHAR (173) CAT $CHAR (174) CAT $CHAR (175) CAT $CHAR (176) CAT $CHAR (177) CAT
          $CHAR (178) CAT $CHAR (179) CAT $CHAR (180) CAT $CHAR (181) CAT $CHAR (182) CAT $CHAR (183) CAT
          $CHAR (184) CAT $CHAR (185) CAT $CHAR (186) CAT $CHAR (187) CAT $CHAR (188) CAT $CHAR (189) CAT
          $CHAR (190) CAT $CHAR (191) CAT $CHAR (192) CAT $CHAR (193) CAT $CHAR (194) CAT $CHAR (195) CAT
          $CHAR (196) CAT $CHAR (197) CAT $CHAR (198) CAT $CHAR (199) CAT $CHAR (200) CAT $CHAR (201) CAT
          $CHAR (202) CAT $CHAR (203) CAT $CHAR (204) CAT $CHAR (205) CAT $CHAR (206) CAT $CHAR (207) CAT
          $CHAR (208) CAT $CHAR (209) CAT $CHAR (210) CAT $CHAR (211) CAT $CHAR (212) CAT $CHAR (213) CAT
          $CHAR (214) CAT $CHAR (215) CAT $CHAR (216) CAT $CHAR (217) CAT $CHAR (218) CAT $CHAR (219) CAT
          $CHAR (220) CAT $CHAR (221) CAT $CHAR (222) CAT $CHAR (223) CAT $CHAR (224) CAT $CHAR (225) CAT
          $CHAR (226) CAT $CHAR (227) CAT $CHAR (228) CAT $CHAR (229) CAT $CHAR (230) CAT $CHAR (231) CAT
          $CHAR (232) CAT $CHAR (233) CAT $CHAR (234) CAT $CHAR (235) CAT $CHAR (236) CAT $CHAR (237) CAT
          $CHAR (238) CAT $CHAR (239) CAT $CHAR (240) CAT $CHAR (241) CAT $CHAR (242) CAT $CHAR (243) CAT
          $CHAR (244) CAT $CHAR (245) CAT $CHAR (246) CAT $CHAR (247) CAT $CHAR (248) CAT $CHAR (249) CAT
          $CHAR (250) CAT $CHAR (251) CAT $CHAR (252) CAT $CHAR (253) CAT $CHAR (254) CAT $CHAR (255);

?? TITLE := 'osv$lower_to_upper', EJECT ??

{ This table is initially the same as osv$lower_to_upper_26. }

  VAR
*IF NOT $true(osv$unix)
    osv$lower_to_upper: [XDCL, #GATE, oss$task_shared] string (256) := $CHAR (00) CAT
*ELSE
    osv$lower_to_upper: [XDCL, #GATE] string (256) := $CHAR (00) CAT
*IFEND
          $CHAR (01) CAT $CHAR (02) CAT $CHAR (03) CAT $CHAR (04) CAT $CHAR (05) CAT $CHAR (06) CAT
          $CHAR (07) CAT $CHAR (08) CAT $CHAR (09) CAT $CHAR (10) CAT $CHAR (11) CAT $CHAR (12) CAT
          $CHAR (13) CAT $CHAR (14) CAT $CHAR (15) CAT $CHAR (16) CAT $CHAR (17) CAT $CHAR (18) CAT
          $CHAR (19) CAT $CHAR (20) CAT $CHAR (21) CAT $CHAR (22) CAT $CHAR (23) CAT $CHAR (24) CAT
          $CHAR (25) CAT $CHAR (26) CAT $CHAR (27) CAT $CHAR (28) CAT $CHAR (29) CAT $CHAR (30) CAT
          $CHAR (31) CAT ' !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`ABCDEFGHIJKLM' CAT
          'NOPQRSTUVWXYZ{|}~' CAT $CHAR (127) CAT $CHAR (128) CAT $CHAR (129) CAT $CHAR (130) CAT
          $CHAR (131) CAT $CHAR (132) CAT $CHAR (133) CAT $CHAR (134) CAT $CHAR (135) CAT $CHAR (136) CAT
          $CHAR (137) CAT $CHAR (138) CAT $CHAR (139) CAT $CHAR (140) CAT $CHAR (141) CAT $CHAR (142) CAT
          $CHAR (143) CAT $CHAR (144) CAT $CHAR (145) CAT $CHAR (146) CAT $CHAR (147) CAT $CHAR (148) CAT
          $CHAR (149) CAT $CHAR (150) CAT $CHAR (151) CAT $CHAR (152) CAT $CHAR (153) CAT $CHAR (154) CAT
          $CHAR (155) CAT $CHAR (156) CAT $CHAR (157) CAT $CHAR (158) CAT $CHAR (159) CAT $CHAR (160) CAT
          $CHAR (161) CAT $CHAR (162) CAT $CHAR (163) CAT $CHAR (164) CAT $CHAR (165) CAT $CHAR (166) CAT
          $CHAR (167) CAT $CHAR (168) CAT $CHAR (169) CAT $CHAR (170) CAT $CHAR (171) CAT $CHAR (172) CAT
          $CHAR (173) CAT $CHAR (174) CAT $CHAR (175) CAT $CHAR (176) CAT $CHAR (177) CAT $CHAR (178) CAT
          $CHAR (179) CAT $CHAR (180) CAT $CHAR (181) CAT $CHAR (182) CAT $CHAR (183) CAT $CHAR (184) CAT
          $CHAR (185) CAT $CHAR (186) CAT $CHAR (187) CAT $CHAR (188) CAT $CHAR (189) CAT $CHAR (190) CAT
          $CHAR (191) CAT $CHAR (192) CAT $CHAR (193) CAT $CHAR (194) CAT $CHAR (195) CAT $CHAR (196) CAT
          $CHAR (197) CAT $CHAR (198) CAT $CHAR (199) CAT $CHAR (200) CAT $CHAR (201) CAT $CHAR (202) CAT
          $CHAR (203) CAT $CHAR (204) CAT $CHAR (205) CAT $CHAR (206) CAT $CHAR (207) CAT $CHAR (208) CAT
          $CHAR (209) CAT $CHAR (210) CAT $CHAR (211) CAT $CHAR (212) CAT $CHAR (213) CAT $CHAR (214) CAT
          $CHAR (215) CAT $CHAR (216) CAT $CHAR (217) CAT $CHAR (218) CAT $CHAR (219) CAT $CHAR (220) CAT
          $CHAR (221) CAT $CHAR (222) CAT $CHAR (223) CAT $CHAR (224) CAT $CHAR (225) CAT $CHAR (226) CAT
          $CHAR (227) CAT $CHAR (228) CAT $CHAR (229) CAT $CHAR (230) CAT $CHAR (231) CAT $CHAR (232) CAT
          $CHAR (233) CAT $CHAR (234) CAT $CHAR (235) CAT $CHAR (236) CAT $CHAR (237) CAT $CHAR (238) CAT
          $CHAR (239) CAT $CHAR (240) CAT $CHAR (241) CAT $CHAR (242) CAT $CHAR (243) CAT $CHAR (244) CAT
          $CHAR (245) CAT $CHAR (246) CAT $CHAR (247) CAT $CHAR (248) CAT $CHAR (249) CAT $CHAR (250) CAT
          $CHAR (251) CAT $CHAR (252) CAT $CHAR (253) CAT $CHAR (254) CAT $CHAR (255);

?? TITLE := 'osv$upper_to_lower', EJECT ??

{ This table is initially the same as osv$upper_to_lower_26. }

  VAR
*IF NOT $true(osv$unix)
    osv$upper_to_lower: [XDCL, #GATE, oss$task_shared] string (256) := $CHAR (00) CAT
*ELSE
    osv$upper_to_lower: [XDCL, #GATE] string (256) := $CHAR (00) CAT
*IFEND
          $CHAR (01) CAT $CHAR (02) CAT $CHAR (03) CAT $CHAR (04) CAT $CHAR (05) CAT $CHAR (06) CAT
          $CHAR (07) CAT $CHAR (08) CAT $CHAR (09) CAT $CHAR (10) CAT $CHAR (11) CAT $CHAR (12) CAT
          $CHAR (13) CAT $CHAR (14) CAT $CHAR (15) CAT $CHAR (16) CAT $CHAR (17) CAT $CHAR (18) CAT
          $CHAR (19) CAT $CHAR (20) CAT $CHAR (21) CAT $CHAR (22) CAT $CHAR (23) CAT $CHAR (24) CAT
          $CHAR (25) CAT $CHAR (26) CAT $CHAR (27) CAT $CHAR (28) CAT $CHAR (29) CAT $CHAR (30) CAT
          $CHAR (31) CAT ' !"#$%&''()*+,-./0123456789:;<=>?@abcdefghijklmnopqrstuvwxyz[\]^_`abcdefghijklm' CAT
          'nopqrstuvwxyz{|}~' CAT $CHAR (127) CAT $CHAR (128) CAT $CHAR (129) CAT $CHAR (130) CAT
          $CHAR (131) CAT $CHAR (132) CAT $CHAR (133) CAT $CHAR (134) CAT $CHAR (135) CAT $CHAR (136) CAT
          $CHAR (137) CAT $CHAR (138) CAT $CHAR (139) CAT $CHAR (140) CAT $CHAR (141) CAT $CHAR (142) CAT
          $CHAR (143) CAT $CHAR (144) CAT $CHAR (145) CAT $CHAR (146) CAT $CHAR (147) CAT $CHAR (148) CAT
          $CHAR (149) CAT $CHAR (150) CAT $CHAR (151) CAT $CHAR (152) CAT $CHAR (153) CAT $CHAR (154) CAT
          $CHAR (155) CAT $CHAR (156) CAT $CHAR (157) CAT $CHAR (158) CAT $CHAR (159) CAT $CHAR (160) CAT
          $CHAR (161) CAT $CHAR (162) CAT $CHAR (163) CAT $CHAR (164) CAT $CHAR (165) CAT $CHAR (166) CAT
          $CHAR (167) CAT $CHAR (168) CAT $CHAR (169) CAT $CHAR (170) CAT $CHAR (171) CAT $CHAR (172) CAT
          $CHAR (173) CAT $CHAR (174) CAT $CHAR (175) CAT $CHAR (176) CAT $CHAR (177) CAT $CHAR (178) CAT
          $CHAR (179) CAT $CHAR (180) CAT $CHAR (181) CAT $CHAR (182) CAT $CHAR (183) CAT $CHAR (184) CAT
          $CHAR (185) CAT $CHAR (186) CAT $CHAR (187) CAT $CHAR (188) CAT $CHAR (189) CAT $CHAR (190) CAT
          $CHAR (191) CAT $CHAR (192) CAT $CHAR (193) CAT $CHAR (194) CAT $CHAR (195) CAT $CHAR (196) CAT
          $CHAR (197) CAT $CHAR (198) CAT $CHAR (199) CAT $CHAR (200) CAT $CHAR (201) CAT $CHAR (202) CAT
          $CHAR (203) CAT $CHAR (204) CAT $CHAR (205) CAT $CHAR (206) CAT $CHAR (207) CAT $CHAR (208) CAT
          $CHAR (209) CAT $CHAR (210) CAT $CHAR (211) CAT $CHAR (212) CAT $CHAR (213) CAT $CHAR (214) CAT
          $CHAR (215) CAT $CHAR (216) CAT $CHAR (217) CAT $CHAR (218) CAT $CHAR (219) CAT $CHAR (220) CAT
          $CHAR (221) CAT $CHAR (222) CAT $CHAR (223) CAT $CHAR (224) CAT $CHAR (225) CAT $CHAR (226) CAT
          $CHAR (227) CAT $CHAR (228) CAT $CHAR (229) CAT $CHAR (230) CAT $CHAR (231) CAT $CHAR (232) CAT
          $CHAR (233) CAT $CHAR (234) CAT $CHAR (235) CAT $CHAR (236) CAT $CHAR (237) CAT $CHAR (238) CAT
          $CHAR (239) CAT $CHAR (240) CAT $CHAR (241) CAT $CHAR (242) CAT $CHAR (243) CAT $CHAR (244) CAT
          $CHAR (245) CAT $CHAR (246) CAT $CHAR (247) CAT $CHAR (248) CAT $CHAR (249) CAT $CHAR (250) CAT
          $CHAR (251) CAT $CHAR (252) CAT $CHAR (253) CAT $CHAR (254) CAT $CHAR (255);

*IF NOT $true(osv$unix)
?? TITLE := 'osp$change_translation_tables', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc clt$name_folding_level
*copyc ost$status
?? POP ??

  PROCEDURE [XDCL, #GATE] osp$change_translation_tables
    (    name_folding_level: clt$name_folding_level;
     VAR status: ost$status);


    status.normal := TRUE;

    IF name_folding_level = clc$full_folding THEN
      osv$lower_to_upper := osv$lower_to_upper_full;
      osv$upper_to_lower := osv$upper_to_lower_full;
    ELSE
      osv$lower_to_upper := osv$lower_to_upper_26;
      osv$upper_to_lower := osv$upper_to_lower_26;
    IFEND;

  PROCEND osp$change_translation_tables;
*IFEND

MODEND osm$character_translation_mgr;
*DECK DECK=OSM$COLLATE_TABLES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats

MODULE osm$collate_tables;

{
{ PURPOSE:
{   This module contains the NOS/VE supplied collate tables.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
*copyc oss$job_paged_literal
?? POP ??

?? TITLE := 'osi$ascii6_folded', EJECT ??

  VAR
    osv$ascii6_folded: [XDCL, #GATE, READ, oss$job_paged_literal] amt$collate_table :=
*copy osi$ascii6_folded
      ;

?? TITLE := 'osi$ascii6_strict', EJECT ??

  VAR
    osv$ascii6_strict: [XDCL, #GATE, READ, oss$job_paged_literal] amt$collate_table :=
*copy osi$ascii6_strict
      ;

?? TITLE := 'osi$cobol6_folded', EJECT ??

  VAR
    osv$cobol6_folded: [XDCL, #GATE, READ, oss$job_paged_literal] amt$collate_table :=
*copy osi$cobol6_folded
      ;

?? TITLE := 'osi$cobol6_strict', EJECT ??

  VAR
    osv$cobol6_strict: [XDCL, #GATE, READ, oss$job_paged_literal] amt$collate_table :=
*copy osi$cobol6_strict
      ;

?? TITLE := 'osi$display63_folded', EJECT ??

  VAR
    osv$display63_folded: [XDCL, #GATE, READ, oss$job_paged_literal] amt$collate_table :=
*copy osi$display63_folded
      ;

?? TITLE := 'osi$display63_strict', EJECT ??

  VAR
    osv$display63_strict: [XDCL, #GATE, READ, oss$job_paged_literal] amt$collate_table :=
*copy osi$display63_strict
      ;

?? TITLE := 'osi$display64_folded', EJECT ??

  VAR
    osv$display64_folded: [XDCL, #GATE, READ, oss$job_paged_literal] amt$collate_table :=
*copy osi$display64_folded
      ;

?? TITLE := 'osi$display64_strict', EJECT ??

  VAR
    osv$display64_strict: [XDCL, #GATE, READ, oss$job_paged_literal] amt$collate_table :=
*copy osi$display64_strict
      ;

?? TITLE := 'osi$ebcdic', EJECT ??

  VAR
    osv$ebcdic: [XDCL, #GATE, READ, oss$job_paged_literal] amt$collate_table :=
*copy osi$ebcdic
      ;

?? TITLE := 'osi$ebcdic6_folded', EJECT ??

  VAR
    osv$ebcdic6_folded: [XDCL, #GATE, READ, oss$job_paged_literal] amt$collate_table :=
*copy osi$ebcdic6_folded
      ;

?? TITLE := 'osi$ebcdic6_strict', EJECT ??

  VAR
    osv$ebcdic6_strict: [XDCL, #GATE, READ, oss$job_paged_literal] amt$collate_table :=
*copy osi$ebcdic6_strict
      ;

MODEND osm$collate_tables;
*DECK DECK=OSM$CONSOLE_INTERACTION_TASK EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Console Interaction Task' ??
MODULE osm$console_interaction_task;

{ PURPOSE:
{   This module contains the main routine for the Console Interaction Task in System Job Monitor.  It
{   completes the system initialization as defined by the site and then processes commands from the
{   system console.  If the task terminates it will be restarted by the System Job Monitor in a slightly
{   different form.
{
{ NOTES:
{   This module is placed on the OSF$OPERATOR_LIBRARY (OSF$TASKS) library.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc avp$clear_active_capabilities
*copyc clp$include_file
*copyc clp$include_line
*copyc clp$set_primary_task
*copyc dsp$force_lock_of_window_23d
*copyc ofp$enable_stop_key
*copyc osp$check_for_desired_mf_class
*copyc osp$generate_message
*copyc osp$verify_system_privilege
*copyc rap$get_console_task_status
?? OLDTITLE ??
?? NEWTITLE := 'osp$console_interaction_task', EJECT ??
{
{ PURPOSE:
{   This procedure contains the main routine for the Console Interaction Task in System Job Monitor.  It
{   completes the system initialization as defined by the site and then processes commands from the
{   system console.  If the task terminates it will be restarted by the System Job Monitor in a slightly
{   different form.
{
{ NOTES:
{   WARNING!!!
{   If the NAME of this procedure is changed the following changes MUST also be made:
{     1. in the deck OSM$INITIALIZE_VIRTUAL_SYSTEM change the NAME of the starting procedure
{     2. in the deck OSM$SYSTEM_TASK_MAINT_23D change the procedures OSP$DEACTIVATE_SYSTEM_TASK
{        and OSP$ACTIVATE_SYSTEM_TASK to look for the new NAME in the system task table

  PROCEDURE [XDCL, #GATE] osp$console_interaction_task;

    VAR
      ignore_status: ost$status,
      initiate_command: string (70),
      length: integer,
      restricted_mainframe: boolean,
      status: ost$status,
      task_restarted: boolean;

    osp$verify_system_privilege;

    status.normal := TRUE;

    clp$set_primary_task (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$get_console_task_status (task_restarted);

    { If the task has been restarted then issue a call to clear all of the active capabilities for the task.
    { During deadstart the task must possess all capabilities for proper system initialization.

    IF task_restarted THEN
      avp$clear_active_capabilities (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    STRINGREP (initiate_command, length, '$system.osf$builtin_library.initiate_system ',
          'task_restarted=', task_restarted);
    clp$include_line (initiate_command (1, length), TRUE, osc$null_name, status);
    IF NOT status.normal THEN
      osp$generate_message (status, ignore_status);
    IFEND;

    { Force the locking of the main window.

    dsp$force_lock_of_window_23d;

    osp$check_for_desired_mf_class (osc$mc_china_or_soviet_class, restricted_mainframe);
    IF restricted_mainframe THEN
      ofp$enable_stop_key;
    IFEND;

    STRINGREP (initiate_command, length, '$system.osf$builtin_library.initiate_sou');
    clp$include_line (initiate_command (1, length), TRUE, osc$null_name, status);
    IF NOT status.normal THEN
      osp$generate_message (status, ignore_status);
    IFEND;

    clp$include_file ('$LOCAL.COMMAND', '', osc$null_name, status);

  PROCEND osp$console_interaction_task;
?? OLDTITLE ??
MODEND osm$console_interaction_task;
*DECK DECK=OSM$CPU_CONFIGURATION_MGR_R1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE OS : OSM$CPU_CONFIGURATION_MGR_R1' ??
MODULE osm$cpu_configuration_mgr_r1;

{ PURPOSE:
{   This module contains the ring one procedures which support software reconfiguration of CPUS.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cml$element_state_change
*copyc cmt$cpu_element_definition
*copyc cmt$element_state
*copyc dst$change_processor_state
*copyc dst$log_ele_state_change
*copyc osc$processor_defined_registers
*copyc ost$processor_id
*copyc ost$processor_id_set
*copyc ost$status
?? POP ??
*copyc cmp$get_cpu_element_r1
*copyc dsp$change_processor_state
*copyc dsp$log_sys_msg_help
*copyc osp$get_global_cpu_model_def
?? EJECT ??
*IF $variable(mmv$test_forced_use_cache_maps, declared) <> 'UNKNOWN'
*copyc mmv$force_use_of_cache_and_maps;
*ELSE
{ -------- Variable declarations for forcing the use of cache and maps omitted at compile time --------
*IFEND
*copyc mmv$multiple_caches
*copyc mmv$multiple_page_maps
*copyc mtv$cst0
*copyc mtv$scb
*copyc osv$cpus_logically_on
*copyc osv$multiprocessor_running
*copyc osv$cpus_physically_configured
*copyc tmv$multiple_cpus_active
?? OLDTITLE ??
?? NEWTITLE := 'process_cpu_state_change_r1', EJECT ??

{ PURPOSE:
{   This procedure makes a call to change the state of the specified processor in the Mainframe
{   Reconfiguration Table (MRT) and then logs an element state change statistic (CM200) to the
{   engineering log.

   VAR
     mtv$cy2000_sp_recovery: [XREF] boolean,
     mtv$reset_all_cache_now: [XREF] boolean;

  PROCEDURE process_cpu_state_change_r1
    (    processor_id: ost$processor_id);

    VAR
      cpu_element: cmt$cpu_element_definition,
      global_processor_model_def: ost$processor_model_definition,
      length: integer,
      local_status: ost$status,
      log_data_p: ^SEQ (*),
      logging_data: dst$log_ele_state_change,
      state_data: dst$change_processor_state,
      working_string: string (31);

    IF mtv$cy2000_sp_recovery THEN

{ The CPU has already been recovered by the Service Processor and
{ therefore the MRT has been updated. Just perform cleanup and exit.

      mmv$multiple_caches := global_processor_model_def.cache_present;
      mmv$multiple_page_maps := global_processor_model_def.maps_present;
      mtv$reset_all_cache_now := FALSE;
      mtv$cst0 [processor_id].cpu_alive_flag :=
            #FREE_RUNNING_CLOCK (0);
      mtv$scb.cpus.logically_on :=
            mtv$scb.cpus.logically_on + $ost$processor_id_set [processor_id];
      mtv$cst0 [processor_id].dispatching_priority_integer := 0;
      IF osv$cpus_logically_on  > 1 THEN
        tmv$multiple_cpus_active := TRUE;
      IFEND;
      state_data.state := mtv$cst0 [processor_id].processor_state;
      dsp$change_processor_state (processor_id, state_data, mtv$cy2000_sp_recovery);
      mtv$cy2000_sp_recovery := FALSE;
      RETURN;
    IFEND;

    { Make the request to change the processor state in the MRT.

    state_data.state := mtv$cst0 [processor_id].processor_state;
    IF mtv$cst0 [processor_id].processor_state = cmc$down THEN
      IF mtv$cst0 [processor_id].reason_for_current_state = osc$cdsr_downed_by_operator THEN
        state_data.down_reason := dsc$pdr_down_by_operator;
      ELSE
        state_data.down_reason := dsc$pdr_down_by_system;
      IFEND;
      state_data.halt_cpu_via_dft := (mtv$cst0 [processor_id].reason_for_current_state <>
            osc$cdsr_downed_by_dft);
    IFEND;
    dsp$change_processor_state (processor_id, state_data, FALSE);

    osp$get_global_cpu_model_def (global_processor_model_def);

    IF mtv$cst0 [processor_id].processor_state = cmc$on THEN

      { Determine whether cache and/or page maps are present for this processor model.  This code is
      { executed only when the second of two or more processors is restarted.

      mmv$multiple_caches := global_processor_model_def.cache_present;
      mmv$multiple_page_maps := global_processor_model_def.maps_present;

*IF $variable(mmv$test_forced_use_cache_maps, declared) <> 'UNKNOWN'
{ The following code is benchmark code to force use of cache and/or maps during benchmark runs.

      mmv$multiple_caches := mmv$multiple_caches OR mmv$force_use_of_cache_and_maps;
      mmv$multiple_page_maps := mmv$multiple_page_maps OR mmv$force_use_of_cache_and_maps;
*ELSE
{ -------- Code for forcing the use of cache and maps omitted at compile time --------
*IFEND
    IFEND;

    { Log the element state change to the engineering log.

    cmp$get_cpu_element_r1 (processor_id, {update_cst =} FALSE, cpu_element, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (working_string, length, processor_id);
    logging_data.element_name := ' ';
    logging_data.element_name (1, 2) := 'CP';
    logging_data.element_name (3) := working_string (2);

    logging_data.product_id.product_number := ' ';

    logging_data.product_id.product_number (3, 3) := global_processor_model_def.model_number_string (1, 3);

    logging_data.product_id.underscore := '_';

    STRINGREP (working_string, length, cpu_element.model_number:#(16));
    logging_data.product_id.model_number := '   ';
    logging_data.product_id.model_number (1, 2) := working_string (2, 2);

    STRINGREP (working_string, length, cpu_element.serial_number:#(10));
    logging_data.serial_number := '      ';
    logging_data.serial_number (1, 5) := working_string (2, (length - 1));

    logging_data.old_state := mtv$cst0 [processor_id].previous_processor_state;
    logging_data.new_state := mtv$cst0 [processor_id].processor_state;
    CASE cpu_element.reason_for_current_state OF
    = osc$cdsr_downed_by_operator =
      logging_data.initiator := 'op';
    = osc$cdsr_downed_by_dft, osc$cdsr_due_threshold_exceeded, osc$cdsr_cpu_timeout,
          osc$cdsr_downed_by_system =
      logging_data.initiator := 'fail';
    ELSE
    CASEND;
    log_data_p := #SEQ (logging_data);
    dsp$log_sys_msg_help (cml$element_state_change, log_data_p);

  PROCEND  process_cpu_state_change_r1;
?? OLDTITLE ??
?? NEWTITLE := 'syp$mfh_cpu_config_change', EJECT ??

{ PURPOSE:
{   This procedure is the monitor flag handler for CPU configuration changes which are processed in monitor.
{   This code looks through the cpu state table for information which must be logged due to the state change.

  PROCEDURE [XDCL] syp$mfh_cpu_config_change;

    VAR
      processor_id: ost$processor_id;

    { Look for any information that may have come from monitor recently.  No interlocks are required to read
    { this information since the system job_monitor task is the only task that will ever execute this code.

    FOR processor_id := 0 TO (osv$cpus_physically_configured - 1) DO
      IF mtv$cst0 [processor_id].log_cpu_state_change THEN
        process_cpu_state_change_r1 (processor_id);
        mtv$cst0 [processor_id].log_cpu_state_change := FALSE;
      IFEND;
    FOREND;

  PROCEND syp$mfh_cpu_config_change;
?? OLDTITLE ??
MODEND osm$cpu_configuration_mgr_r1;
*DECK DECK=OSM$CREATE_EI_LOAD_FILE EXPAND=TRUE
 PROGRAM CREATEEILOADFILE(VEBIN,BIN,INPUT);
 (**)
 TYPE
   HEX= 0..15;
   HEXWORD= PACKED ARRAY[0..14] OF HEX;
   MIXED= RECORD CASE BOOLEAN OF
     FALSE: (I: INTEGER);
     TRUE : (H: HEXWORD)
   END;
   COMMENTLINE= PACKED ARRAY[1..70] OF CHAR;
   IDENTTABLE = PACKED RECORD CASE BOOLEAN OF
     TRUE: (LIST: ARRAY[0..16B] OF INTEGER);
     FALSE
      ID, LENGTH: 0..7777B;
        FILL1: 0..777777777777B;
      NAME: ALFA;
      DATE: ALFA;
      TIME: ALFA;
      OSNAME: ALFA;
      PROCESSOR: ALFA;
      RECOMENDATIONS: ALFA;
      HARDWARE: ALFA;
      COMMENTS: COMMENTLINE;
             )
   END;
 (**)
 VAR
   BIN: FILE OF MIXED;
   VEBIN: FILE OF HEXWORD;
   NIBBLE: HEX;
   I, J, K: INTEGER;
 (**)
   IDTABLE: IDENTTABLE;
 (**)
   VPOS: INTEGER;
 (**)
   FUNCTION GETVE: HEX;
    BEGIN
     IF VPOS>14 THEN
      IF EOF(VEBIN) THEN
       GETVE:=0
      ELSE BEGIN
       GET(VEBIN); GETVE:=VEBIN^[1]; VPOS
      END
     ELSE BEGIN
      GETVE:=VEBIN^[VPOS]; VPOS:=VPOS+1
     END;
    END (* GETVE *);
 (**)
   PROCEDURE COPYBINS;
    BEGIN
     REPEAT
      FOR I:=0 TO 14 DO BIN^.H[I]:=GETVE;
      PUT(BIN);
     UNTIL EOF(VEBIN);
    END (* COPYBINS *);
 (**)
   PROCEDURE PUTBIN(I: INTEGER);
    BEGIN
     BIN^.I:=I;
     PUT(BIN);
    END;
 (**)
   PROCEDURE SHIFT(VAR A: ALFA);
    VAR I: INTEGER;
    BEGIN
     FOR I:= 1 TO 9 DO A[I]:=A[I+1];
     A[10]:=' ';
    END;
 (**)
   PROCEDURE READCOMMENTS(VAR C: COMMENTLINE);
    VAR I: INTEGER;
    BEGIN
     I:=1;
     WHILE NOT EOLN DO
       BEGIN READ(C[I]);
        I:=SUCC(I);
       END;
     FOR I:=I TO 70 DO C[I]:=COL;
     READLN;
    END (* READ COMMENTS *);
(**)
   PROCEDURE READALFA(VAR C: ALFA);
    VAR I: INTEGER;
    BEGIN
     I:=1;
     WHILE NOT EOLN DO
       BEGIN READ(C[I]);
        I:=SUCC(I);
       END;
     FOR I:=I TO 10 DO C[I]:=COL;
     READLN;
    END (* READ COMMENTS *);
(**)
 BEGIN
  REWRITE(BIN);
  RESET(VEBIN);
  VPOS:=1;
  FOR I:=1 TO 152*2 DO NIBBLE:=GETVE;
  IDTABLE.ID:=7700B; IDTABLE.LENGTH:=16B;
  IDTABLE.FILL1:=0;
  READALFA(IDTABLE.NAME);
  DATE(IDTABLE.DATE); TIME(IDTABLE.TIME);
  SHIFT(IDTABLE.DATE); SHIFT(IDTABLE.TIME);
  IDTABLE.OSNAME:='NOS   2.1 ';
  IDTABLE.PROCESSOR:= 'LOADEI    ';
  IDTABLE.RECOMENDATIONS:='     8X8X ';
  IDTABLE.HARDWARE:='H         ';
  IDTABLE.COMMENTS:=
   'EI VERSION 9, COPYRIGHT CONTROL DATA SYSTEMS INC. 1992                ';
  READCOMMENTS(IDTABLE.COMMENTS);
  FOR I:=0 TO 16B DO PUTBIN(IDTABLE.LIST[I]);
 (**)
  PUTBIN(50000000000000000000B);
  COPYBINS;
 END.
*DECK DECK=OSM$DATE_TIME_MANAGEMENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operating System : Date Time Management' ??
MODULE osm$date_time_management;

{ PURPOSE:
{   This module contains procedures needed to manage date and time in osf$system_core_113 and osf$boot_job.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_pageable
*copyc ost$os_defaults
?? POP ??
*IF NOT $true(osv$unix)
*copyc dsp$read_date_time_information
*copyc dsp$read_mrt_entry
*copyc osp$clear_mainframe_sig_lock
*copyc osp$set_mainframe_sig_lock
*copyc pmp$get_time
*copyc pmp$verify_compact_date
*copyc pmp$verify_compact_time
?? EJECT ??
*copyc dsv$mainframe_type
*copyc osv$base_system_time
*copyc osv$date_time_update
*IFEND
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR

    { The os name must not be part of the os defaults record because it is accessed by the linker.

    osv$os_defaults: [XDCL, #GATE, oss$mainframe_pageable] ost$os_defaults :=
          [[0], TRUE, [0, 0, FALSE], [osc$iso_date, 'Y4-M2-D2'], [osc$hms_time, 'HMS'],
           [FALSE, 0, [0, 0]]],

    osv$os_defaults_os_name: [XDCL, #GATE, oss$mainframe_pageable] ost$os_defaults_os_name :=
*IF NOT $true(osv$unix)
          'NOS/VE R1  12205 /3DX     ';
*ELSE
          '                          ';
*IFEND

?? OLDTITLE ??
*IF NOT $true(osv$unix)
?? NEWTITLE := 'osp$change_base_system_time', EJECT ??

{ PURPOSE:
{   This procedure will update the base system time.  It does NOT update the hardware clock (chip).

  PROCEDURE [XDCL, #GATE] osp$change_base_system_time
    (    free_running_clock: ost$free_running_clock;
         date_time: ost$date_time;
     VAR status: ost$status);

    VAR
      base_system_time: ost$base_system_time,
      time: ost$time;

    pmp$verify_compact_date (date_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$verify_compact_time (date_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    base_system_time.second := date_time.second;
    base_system_time.minute := date_time.minute;
    base_system_time.hour := date_time.hour;
    base_system_time.day := date_time.day;
    base_system_time.month := date_time.month;

{ This code allows NOS/VE to exist until 2079, if by chance it lasts longer,
{ then this code would have to be changed.

    IF date_time.year >= 80 THEN
      base_system_time.year := date_time.year + 1900;
    ELSE
      base_system_time.year := date_time.year + 2000;
    IFEND;
    base_system_time.corresponding_microsecond_clock := free_running_clock;

    { There is a small window here for errors.  If the following assignment is not completed before
    { another task or processor accesses OSV$BASE_SYSTEM_TIME from PMM$GET_COMPACT_DATE_TIME, unpredictable
    { results will occur.  Locking this variable is too expensive for the number of times its referenced.

    osv$base_system_time := base_system_time;

    { Clear the date/time update flag which is set by 170 or the Cyber 2000 Service Processor changing time.

    osv$date_time_update := FALSE;

    pmp$get_time (osc$hms_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (osv$os_defaults.lock);
    osv$os_defaults.defaults_changed := TRUE;
    osp$clear_mainframe_sig_lock (osv$os_defaults.lock);

  PROCEND osp$change_base_system_time;
?? OLDTITLE ??
?? NEWTITLE := 'osp$initialize_date_time', EJECT ??

{ PURPOSE
{   This procedure initializes the date/time from the MRT values.  This is done at deadstart time and
{   whenever NOS or the Service Processor changes the time.

  PROCEDURE [XDCL, #GATE] osp$initialize_date_time
    (VAR status: ost$status);

    VAR
      date_time: ost$date_time,
      date_time_information: dst$date_time_information,
      free_running_clock: integer,
      mrt_entry: dst$mrt_entry;

    status.normal := TRUE;
    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      dsp$read_date_time_information (date_time_information, status);
      IF NOT status.normal THEN
         RETURN;
      IFEND;
      date_time := date_time_information.bst_wcc;
      free_running_clock := date_time_information.bst_frc;
    ELSE
      dsp$read_mrt_entry (dsc$mrt_id_clock_data, 0, mrt_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      date_time.millisecond := 0;
      date_time.second := mrt_entry.clock_data.seconds.units + mrt_entry.clock_data.seconds.tens * 10;
      date_time.minute := mrt_entry.clock_data.minutes.units + mrt_entry.clock_data.minutes.tens * 10;
      date_time.hour := mrt_entry.clock_data.hours.units + mrt_entry.clock_data.hours.tens * 10;
      date_time.day := mrt_entry.clock_data.days.units + mrt_entry.clock_data.days.tens * 10;
      date_time.month := mrt_entry.clock_data.months.units + mrt_entry.clock_data.months.tens * 10;
      date_time.year := mrt_entry.clock_data.years.units + mrt_entry.clock_data.years.tens * 10;
      free_running_clock := mrt_entry.clock_data.frc_bits_52_63.frc_bits +
            mrt_entry.clock_data.frc_bits_40_51.frc_bits * 1000(16) +
            mrt_entry.clock_data.frc_bits_28_39.frc_bits * 1000000(16) +
            mrt_entry.clock_data.frc_bits_16_27.frc_bits * 1000000000(16) +
            mrt_entry.clock_data.frc_bits_4_15.frc_bits * 1000000000000(16);
    IFEND;

    osp$change_base_system_time (free_running_clock, date_time, status);

    osp$set_mainframe_sig_lock (osv$os_defaults.lock);
    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      osv$os_defaults.system_date_format := date_time_information.default_date;
      osv$os_defaults.system_time_format := date_time_information.default_time;
    IFEND;
    osv$os_defaults.defaults_changed := TRUE;
    osv$os_defaults.time_data.wait_count := 0;
    osv$os_defaults.time_data.wait_to_change := FALSE;
    osp$clear_mainframe_sig_lock (osv$os_defaults.lock);

  PROCEND osp$initialize_date_time;
?? OLDTITLE ??
*IFEND
MODEND osm$date_time_management;
*DECK DECK=OSM$DATE_TIME_MANAGEMENT_113 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operating System : Date Time Management 113' ??
MODULE osm$date_time_management_113;

{ PURPOSE:
{   This module contains procedures needed to manage date and time in osf$system_core_113.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ose$default_process_exceptions
*copyc dse$dft_errors
*copyc ost$operating_system_default
?? POP ??
*copyc dsp$change_date_time_info
*copyc dsp$update_hardware_date_time
*copyc dsp$update_time_zone
*copyc osp$change_base_system_time
*copyc osp$clear_mainframe_sig_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc pmp$get_date_time_at_timestamp
?? EJECT ??
*copyc dsv$cpu_pp_communication_block
*copyc dsv$mainframe_type
*copyc osv$170_os_type
*copyc osv$os_defaults
?? OLDTITLE ??
?? NEWTITLE := 'osp$change_date_time', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$change_date_time
    (    use_os_default: boolean;
         os_default: ost$operating_system_default;
     VAR status: ost$status);

    VAR
      date_time: ost$date_time,
      free_running_clock: ost$free_running_clock,
      second: 0 .. 59,
      wait_frc: ost$free_running_clock;

    status.normal := TRUE;

    IF osv$170_os_type <> osc$ot7_none THEN
      osp$set_status_abnormal ('OS', ose$not_allowed_in_dual_state, '', status);
      RETURN;
    IFEND;

    IF use_os_default THEN
      osp$change_base_system_time (os_default.free_running_clock, os_default.date_time, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      free_running_clock := os_default.free_running_clock;
      second := os_default.date_time.second;
    ELSE
      free_running_clock := #FREE_RUNNING_CLOCK (0);
      pmp$get_date_time_at_timestamp (free_running_clock, pmc$use_system_local_time, date_time, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      osp$change_base_system_time (free_running_clock, date_time, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      second := date_time.second;
    IFEND;

    IF second > 0 THEN
      osp$set_mainframe_sig_lock (osv$os_defaults.lock);
      osv$os_defaults.time_data.wait_to_change := TRUE;
      osv$os_defaults.time_data.wait_count := 0;
      wait_frc :=  free_running_clock + ((60 - second) * 1000 * 1000);
      osv$os_defaults.time_data.wait_frc.min := wait_frc;
      osv$os_defaults.time_data.wait_frc.max := wait_frc + (1000 * 1000);
      osp$clear_mainframe_sig_lock (osv$os_defaults.lock);
    ELSE
      osp$change_hardware_date_time (status);
    IFEND;

  PROCEND osp$change_date_time;
?? OLDTITLE ??
?? NEWTITLE := 'osp$change_hardware_date_time', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$change_hardware_date_time
    (VAR status: ost$status);

    VAR
      date_time_information: dst$date_time_information,
      redo_request: boolean;

    redo_request := FALSE;
    date_time_information.bst_frc := #FREE_RUNNING_CLOCK (0);

    pmp$get_date_time_at_timestamp (date_time_information.bst_frc, pmc$use_system_local_time,
          date_time_information.bst_wcc, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$change_base_system_time (date_time_information.bst_frc, date_time_information.bst_wcc, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN

{ This code is neccessary so the date will change on the service processor.
{ The SP doesn not accept anything greater than 99.

      date_time_information.bst_wcc.year := date_time_information.bst_wcc.year MOD 100;
      dsp$change_date_time_info ($dst$change_date_time_set [dsc$cdt_base_system_time], date_time_information,
            status);
      IF NOT status.normal THEN
        IF status.condition = dse$dft_reissue_request THEN
          redo_request := TRUE;
        ELSE
          RETURN;
        IFEND;
      IFEND;
    ELSE
      dsp$update_hardware_date_time (date_time_information.bst_frc, date_time_information.bst_wcc, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    osp$set_mainframe_sig_lock (osv$os_defaults.lock);
    IF redo_request AND (osv$os_defaults.time_data.wait_count < 5) THEN
      osv$os_defaults.time_data.wait_count := osv$os_defaults.time_data.wait_count + 1;
      status.normal := TRUE;
    ELSE
      osv$os_defaults.time_data.wait_count := 0;
      osv$os_defaults.time_data.wait_to_change := FALSE;
    IFEND;
    osp$clear_mainframe_sig_lock (osv$os_defaults.lock);

  PROCEND osp$change_hardware_date_time;
?? OLDTITLE ??
?? NEWTITLE := 'osp$change_os_default_ring_1', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$change_os_default_ring_1
    (    os_default: ost$operating_system_default;
     VAR status: ost$status);

    VAR
      date_time_information: dst$date_time_information;

    status.normal := TRUE;

    CASE os_default.kind OF
    = osc$os_name =
      osp$set_mainframe_sig_lock (osv$os_defaults.lock);
      osv$os_defaults_os_name := os_default.os_name;
      osv$os_defaults.defaults_changed := TRUE;
      osp$clear_mainframe_sig_lock (osv$os_defaults.lock);

    = osc$date_time =
      osp$change_date_time (TRUE, os_default, status);

    = osc$time_zone =
      CASE dsv$mainframe_type OF
      = dsc$mt_93x_mainframe =
        IF (dsv$cpu_pp_communication_block.relocation.dft_pp_number DIV 10(8)) =
              (dsv$cpu_pp_communication_block.relocation.dft_pp_at_deadstart DIV 10(8)) THEN
          dsp$update_time_zone (os_default.time_zone, status);
        ELSE
          osp$set_status_abnormal ('OS', ose$time_zone_data_not_saved, '', status);
        IFEND;
      ELSE
        dsp$update_time_zone (os_default.time_zone, status);
      CASEND;
      IF status.normal THEN
        osp$set_mainframe_sig_lock (osv$os_defaults.lock);
        osv$os_defaults.system_time_zone := os_default.time_zone;
        osv$os_defaults.defaults_changed := TRUE;
        osp$clear_mainframe_sig_lock (osv$os_defaults.lock);
      IFEND;

    = osc$default_date_format =
      osp$set_mainframe_sig_lock (osv$os_defaults.lock);
      osv$os_defaults.system_date_format := os_default.default_date;
      osv$os_defaults.defaults_changed := TRUE;
      osp$clear_mainframe_sig_lock (osv$os_defaults.lock);
      IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
        date_time_information.default_date := os_default.default_date;
        dsp$change_date_time_info ($dst$change_date_time_set[dsc$cdt_default_date_format],
              date_time_information, status);
      IFEND;

    = osc$default_time_format =
      osp$set_mainframe_sig_lock (osv$os_defaults.lock);
      osv$os_defaults.system_time_format := os_default.default_time;
      osv$os_defaults.defaults_changed := TRUE;
      osp$clear_mainframe_sig_lock (osv$os_defaults.lock);
      IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
        date_time_information.default_time := os_default.default_time;
        dsp$change_date_time_info ($dst$change_date_time_set[dsc$cdt_default_time_format],
              date_time_information, status);
      IFEND;

    ELSE
      osp$set_status_abnormal ('OS', ose$invalid_os_default_selected, '', status);
    CASEND;

  PROCEND osp$change_os_default_ring_1;
?? OLDTITLE ??
?? NEWTITLE := 'osp$clear_defaults_changed_flag', EJECT ??

{ PURPOSE:
{   This procedure exists so that a job_template_23d procedure can clear the variable
{   that denotes that the os defaults have been changed by a command.

  PROCEDURE [XDCL, #GATE] osp$clear_defaults_changed_flag;

    osp$set_mainframe_sig_lock (osv$os_defaults.lock);
    osv$os_defaults.defaults_changed := FALSE;
    osp$clear_mainframe_sig_lock (osv$os_defaults.lock);

  PROCEND osp$clear_defaults_changed_flag;
?? OLDTITLE ??
?? NEWTITLE := 'osp$update_wait_frc', EJECT ??

{ PURPOSE:
{   This procedure updates the wait free running clock in the os defaults variable for job_template_23d
{   procedure.

  PROCEDURE [XDCL, #GATE] osp$update_wait_frc
    (    current_time: integer);

    VAR
      addition: integer,
      minute_difference: integer;

    minute_difference := ((current_time - osv$os_defaults.time_data.wait_frc.max) DIV (60 * 1000 * 1000)) + 1;
    addition := minute_difference * (60 * 1000 * 1000);

    osp$set_mainframe_sig_lock (osv$os_defaults.lock);
    osv$os_defaults.time_data.wait_frc.min := osv$os_defaults.time_data.wait_frc.min + addition;
    osv$os_defaults.time_data.wait_frc.max := osv$os_defaults.time_data.wait_frc.max + addition;
    osp$clear_mainframe_sig_lock (osv$os_defaults.lock);

  PROCEND osp$update_wait_frc;
?? OLDTITLE ??
MODEND osm$date_time_management_113;
*DECK DECK=OSM$DEBUG_TABLES EXPAND=TRUE
?? RIGHT := 110 ??
MODULE osm$debug_tables;
*copyc pfd$catalog_alarm_table
VAR
  pft#catalog_alarm_entry: ^pft$catalog_alarm_entry;

*copyc pfd$queued_catalog_table
VAR
  pft#queued_catalog: ^pft$queued_catalog;

*copyc pfd$catalog_locator
VAR
  pft#catalog_locator: ^pft$catalog_locator;


MODEND osm$debug_tables;
*DECK DECK=OSM$DEFAULT_EXCEPTION_POLICIES EXPAND=TRUE

" This file is not used by NOS/VE.  However, it is provided as a template so
" that you may create your own exception policies for the
" MANAGE_EXCEPTION_POLICY utility.

" Exception policies are automatically installed after a deadstart by the
" ACTIVATE_PRODUCTION_ENVIRONMENT command.

" The NOS/VE system default exception policies are provided below.  You may
" want to change the default policies.  For example:

"   - If you feel that the system should not wait for cycle busy in a batch
"     job, you may want to add the following policy:

"         chaep job_mode=batch cycle_busy=exit

"   - If you have a missing or unavailable volume, you expect repair to
"     successfully reinstate the data, and you know approximately how long it
"     will take to repair the disk unit, you may want to adjust the polling
"     frequency to reduce unnecessary swaps of the affected jobs.  Each
"     affected job will retry access to the affected file or catalog every
"     POLLING_FREQUENCY seconds.

"   - Likewise, you may want to adjust the POLLING_FREQUENCY for other common
"     conditions such as CYCLE_BUSY, CYCLE_RESTORATION_REQUIRED, or
"     DATA_RETRIEVAL_REQUIRED.

" You may also want to create additional policies to address disaster
" situations.  It is recommended that you append additional policies after
" the set of default policies to ensure that all conditions will have a
" policy.  If multiple policies could apply for a particular condition, the
" last one defined takes effect.

" If you want to make any changes to the system default exception policies,
" this is the process we recommend:

"     1.  Copy this file to $SYSTEM.MAINFRAME.OSF$SITE_EXCEPTION_POLICIES,
"         if you have not previously done so.

"     2.  Edit $SYSTEM.MAINFRAME.OSF$SITE_EXCEPTION_POLICIES to add, modify,
"         or delete exception policies.

"     3.  Execute the command INSTALL_EXCEPTION_POLICIES from the command
"         library $SYSTEM.OSF$BUILTIN_LIBRARY.  (This step is only necessary
"         if you are installing exception policies after the system is
"         activated for production and do not plan an immediate deadstart.)

"     4.  NOS/VE will automatically execute the file
"         $SYSTEM.MAINFRAME.OSF$SITE_EXCEPTION_POLICIES when the
"         command ACTIVATE_PRODUCTION_ENVIRONMENT is executed.  This ensures
"         that policies that you define are carried across deadstarts.

"     5.  If you have defined exception policies for an emergency
"         situation, remember to delete the extraneous exception policies
"         after the emergency has passed.

" NOTES:

"   o It is not recommended that you change the policy for the System Job
"     unless absolutely necessary.  It is vital to your ability to get
"     through deadstart that the EXIT option be chosen for most conditions.
"     The WAIT option was selected for CYCLE_BUSY to allow the use of the
"     Removable Media Management System (RMS) from the System Console; if you
"     do not have this product installed, you may select the EXIT option
"     instead.

"   o The value selected for the POLLING_FREQUENCY is important to system
"     performance.

"       - A value of 7 seconds or greater will ensure that a job affected by
"         an exception condition will swap out while waiting for the
"         condition to clear.  A value less than 7 seconds may keep the job
"         in memory and it will take a share of the CPU as well.

"       - By selecting a wise value for POLLING_FREQUENCY you may improve the
"         performance of the system for certain conditions.  If you use a
"         large number of seconds, the user may have to wait almost that long
"         after the condition clears before regaining the CPU.  So be
"         careful.  If you expect the condition to last N seconds, you may
"         want to select a POLLING_FREQUENCY that is N/2 or N/4 to ensure
"         some responsiveness to the user when the condition clears.

SYSTEM_OPERATOR_UTILITY
  MANAGE_EXCEPTION_POLICIES

    " Policies for jobs other than the System Job
    change_exception_policies files=all catalog_volume_unavailable=wait ..
          cycle_restoration_required=wait volume_unavailable=wait ..
          polling_frequency=60

    change_exception_policies files=all data_retrieval_required=wait ..
          polling_frequency=35

    change_exception_policies files=all file_server_inactive=wait ..
          polling_frequency=30

    change_exception_policies files=all space_unavailable=wait ..
          polling_frequency=10

    change_exception_policies files=all cycle_busy=wait ..
          polling_frequency=7

    " Policies for the System Job
    change_exception_policies jobs=$aaa_0000 catalog_volume_unavailable=exit ..
          cycle_busy=wait cycle_restoration_required=exit ..
          data_retrieval_required=exit file_server_inactive=exit ..
          space_unavailable=wait volume_unavailable=exit polling_frequency=5

    "Insert your CHANGE_EXCEPTION_POLICY subcommands here"

    install_exception_policies
  QUIT
QUIT

*DECK DECK=OSM$DEFAULT_HANDLER_DESC EXPAND=TRUE
?? RIGHT := 110 ??
MODULE osm$default_handler_desc;
?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc oss$job_paged_literal
*copyc pmt$condition
*copyc pmt$established_handler
?? POP ??

  VAR
    osv$default_establish_desc: [XDCL, #GATE, READ, oss$job_paged_literal] pmt$established_handler :=
      [TRUE, NIL, NIL, [pmc$condition_combination, - $pmt$condition_combination
      [pmc$pit_condition, pmc$block_exit_processing]], [$pmt$system_conditions [], [0, NIL]]];

  VAR
    osv$default_block_exit_desc: [XDCL, #GATE, READ, oss$job_paged_literal] pmt$established_handler :=
      [TRUE, NIL, NIL, [pmc$condition_combination,  $pmt$condition_combination
      [pmc$block_exit_processing]], [$pmt$system_conditions [], [0, NIL]]];

MODEND osm$default_handler_desc;
*DECK DECK=OSM$DEFINE_CPU EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE OS : Define CPU' ??
MODULE osm$define_cpu;

{ PURPOSE:
{   This module defines tables and memory needed for multiple processors.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmt$request_block
*copyc dst$cpu_attributes
*copyc osc$monitor_stack_mult
*copyc osc$processor_defined_registers
*copyc osd$virtual_address
?? POP ??
*copyc i#call_monitor
?? EJECT ??
*copyc mtv$cst0
*copyc mtv$monitor_exchange_package
*copyc osv$monitor_stack_length
*copyc osv$page_size
?? OLDTITLE ??
?? NEWTITLE := 'osp$define_cpu', EJECT ??

  PROCEDURE [XDCL] osp$define_cpu
    (    cpu_attributes: dst$cpu_attributes);

    VAR
      first_cpu_started_id: ost$logical_processor_id,
      index: integer,
      mem_port_mask: ost$cpu_memory_port_mask,
      pva_offset: ost$segment_offset,
      rb: cmt$request_block,
      second_cpu_started_id: ost$logical_processor_id,
      xp_p: ^ost$exchange_package;

    { Send a request to monitor to assign the pages to monitor to contain the monitor exchange package and
    { the stack for the second CPU to be started.  Loop until enough memory has been retrieved, each call
    { to monitor retrieves one page.  The RMA value returned from the monitor call is only set on the first
    { call to monitor.  Once the RMA value is non-zero it is not changed.

    rb.request_code := syc$rc_config_mgmt_request;
    rb.kind := cmc$rbk_request_stack_memory;
    rb.rma := 0;
    pva_offset := osc$monitor_stack_mult;
    xp_p := ^mtv$monitor_exchange_package;

   /assign_loop/
    WHILE TRUE DO
      rb.status.normal := TRUE;
      rb.first_byte_address_p := #ADDRESS (#RING (xp_p), #SEGMENT (xp_p), pva_offset);
      i#call_monitor (#LOC (rb), #SIZE (rb));
      IF NOT rb.status.normal THEN
        CYCLE /assign_loop/;
      IFEND;
      pva_offset := pva_offset + osv$page_size;
      IF osv$monitor_stack_length > (pva_offset - osc$monitor_stack_mult) THEN
        CYCLE /assign_loop/;
      IFEND;
      EXIT /assign_loop/;
    WHILEND /assign_loop/;

    { Determine the CPU ids.

    first_cpu_started_id := #READ_REGISTER (osc$pr_maintenance_id);
    IF first_cpu_started_id = 0 THEN
      second_cpu_started_id := 1;
    ELSE
      second_cpu_started_id := 0;
    IFEND;

    { Determine the memory port mask of the second CPU to be started.

    mem_port_mask := 1;
    FOR index := 1 TO cpu_attributes.cpu [second_cpu_started_id].memory_port_number DO
      mem_port_mask := mem_port_mask * 2;
    FOREND;

    { Store the information retrieved in the CPU state table of the second CPU started.

    mtv$cst0 [second_cpu_started_id].memory_port_mask := mem_port_mask;
    mtv$cst0 [second_cpu_started_id].monitor_mps := rb.rma;
    mtv$cst0 [second_cpu_started_id].next_processor_state := cpu_attributes.cpu [second_cpu_started_id].state;
    mtv$cst0 [second_cpu_started_id].previous_processor_state :=
          cpu_attributes.cpu [second_cpu_started_id].state;
    mtv$cst0 [second_cpu_started_id].element_id := cpu_attributes.cpu [second_cpu_started_id].element_id;

    mtv$cst0 [0].termination_message := ' ';
    mtv$cst0 [1].termination_message := ' ';

  PROCEND osp$define_cpu;
?? OLDTITLE ??
MODEND osm$define_cpu;
*DECK DECK=OSM$DISK_FAULT_TOLERANCE_113 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Disk Fault Tolerance (113)' ??
MODULE osm$disk_fault_tolerance_113;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
*copyc ose$disk_ft_exceptions
?? POP ??
*copyc i#current_sequence_position
*copyc osp$clear_mainframe_sig_lock
*copyc osp$copy_exception_policies
*copyc osp$set_status_condition
*copyc osp$test_set_main_sig_lock
*copyc osp$test_sig_lock
*copyc osv$mainframe_pageable_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    exception_policies_lock: [oss$mainframe_pageable] ost$signature_lock := [0],
    osv$installed_policies: [XDCL, #GATE, oss$mainframe_pageable] ^SEQ ( * ) := NIL;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$r1_get_installed_policies', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$r1_get_installed_policies
    (VAR installed_policies: ^SEQ ( * );
     VAR status: ost$status);

    set_mainframe_sig_lock (exception_policies_lock, status);

    IF status.normal THEN
      IF osv$installed_policies <> NIL THEN
        IF (installed_policies <> NIL) AND (#SIZE (osv$installed_policies^) >=
              #SIZE (installed_policies)) THEN
          RESET installed_policies;
          osp$copy_exception_policies (osv$installed_policies, installed_policies, status);
        ELSE
          {Caller provided insufficient space; someone locked and replaced the installed policies
          {after the caller estimated the size of the policies by reading osv$installed_policies
          {without holding the lock.
          osp$set_status_condition (ose$exception_policies_locked, status);
        IFEND;
      ELSE
        osp$set_status_condition (ose$no_policies_installed, status);
      IFEND;
      clear_mainframe_sig_lock (exception_policies_lock);
    IFEND;

  PROCEND osp$r1_get_installed_policies;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$r1_install_exception_policy', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$r1_install_exception_policy
    (    session_policies: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      installed_sequence: ^SEQ ( * ),
      session_sequence: ^SEQ ( * ),
      size: ost$positive_integers;

    set_mainframe_sig_lock (exception_policies_lock, status);
    IF status.normal THEN
      size := i#current_sequence_position (session_policies);

      session_sequence := session_policies;
      RESET session_sequence;

      ALLOCATE installed_sequence: [[REP size OF cell]] IN osv$mainframe_pageable_heap^;
      RESET installed_sequence;

      osp$copy_exception_policies (session_sequence, installed_sequence, status);

      IF status.normal THEN
        IF osv$installed_policies <> NIL THEN
          FREE osv$installed_policies IN osv$mainframe_pageable_heap^;
        IFEND;
        RESET installed_sequence;
        osv$installed_policies := installed_sequence;
      IFEND;

      clear_mainframe_sig_lock (exception_policies_lock);
    IFEND;

  PROCEND osp$r1_install_exception_policy;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$r1_lock_policies', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$r1_lock_policies
    (VAR status: ost$status);

    set_mainframe_sig_lock (exception_policies_lock, status);

  PROCEND osp$r1_lock_policies;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$r1_unlock_policies', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$r1_unlock_policies;

    clear_mainframe_sig_lock (exception_policies_lock);

  PROCEND osp$r1_unlock_policies;
?? OLDTITLE ??
?? NEWTITLE := 'clear_mainframe_sig_lock', EJECT ??

  PROCEDURE clear_mainframe_sig_lock
    (VAR lock: ost$signature_lock);

    VAR
      lock_status: ost$signature_lock_status,
      locked: boolean;

    osp$test_sig_lock (lock, lock_status);
    IF lock_status = osc$sls_locked_by_current_task THEN
      osp$clear_mainframe_sig_lock (lock);
    IFEND;

  PROCEND clear_mainframe_sig_lock;

?? OLDTITLE ??
?? NEWTITLE := 'set_mainframe_sig_lock', EJECT ??

  PROCEDURE set_mainframe_sig_lock
    (VAR lock: ost$signature_lock;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      lock_status: ost$signature_lock_status,
      locked: boolean;

    status.normal := TRUE;

    osp$test_sig_lock (lock, lock_status);
    IF lock_status = osc$sls_locked_by_current_task THEN
      clear_mainframe_sig_lock (lock);
    ELSEIF lock_status = osc$sls_locked_by_another_task THEN
      osp$set_status_condition (ose$exception_policies_locked, status);
    IFEND;

    IF status.normal THEN
      osp$test_set_main_sig_lock (lock, locked);
      IF NOT locked THEN
        osp$set_status_condition (ose$exception_policies_locked, status);
      IFEND;
    IFEND;

  PROCEND set_mainframe_sig_lock;

?? OLDTITLE ??
MODEND osm$disk_fault_tolerance_113;
*DECK DECK=OSM$DISK_FAULT_TOLERANCE_13D EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Disk Fault Tolerance (1,3,D) :  Exception Policies Commands.' ??
MODULE osm$disk_fault_tolerance_13d;

{ PURPOSE:
{   This module contains internal interfaces used during the processing of
{   MANAGE_EXCEPTION_POLICIES.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ose$disk_ft_exceptions
?? POP ??
*copyc osd$exception_policies
*copyc osp$set_status_condition
?? NEWTITLE := '[XDCL, #GATE] osp$copy_exception_policies', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$copy_exception_policies
    (    from_sequence: ^SEQ ( * );
     VAR to_sequence: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      from_seq: ^SEQ ( * ),
      from_header: ^ost$ecp_header,
      from_policy: ^ost$ecp_policy_header,
      to_policy: ^ost$ecp_policy_header,
      to_header: ^ost$ecp_header;

?? NEWTITLE := 'copy_policy', EJECT ??

    PROCEDURE copy_policy;

?? NEWTITLE := 'copy_conditions ', EJECT ??

      PROCEDURE copy_conditions
        (    from_conditions: ost$ecp_conditions;
         VAR to_conditions: ost$ecp_conditions);

        VAR
          i: integer;

        FOR i := 1 TO UPPERBOUND (from_conditions) DO
          to_conditions [i] := from_conditions [i];
        FOREND;
      PROCEND copy_conditions;
?? OLDTITLE ??
?? NEWTITLE := 'copy_files', EJECT ??

      PROCEDURE copy_files
        (    from_files: ost$ecp_files;
         VAR to_files: ost$ecp_files);

        VAR
          i: ost$positive_integers;

        to_files.specified := from_files.specified;
        IF from_files.specified THEN
          to_files.all_specified := from_files.all_specified;
          IF NOT from_files.all_specified THEN
            NEXT to_files.path_list: [1 .. UPPERBOUND (from_files.path_list^)] IN to_sequence;
            IF to_files.path_list <> NIL THEN
              to_files.path_list^ := from_files.path_list^;

              FOR i := LOWERBOUND (from_files.path_list^) TO UPPERBOUND (from_files.path_list^) DO
                NEXT to_files.path_list^ [i].path: [STRLENGTH (from_files.path_list^ [i].path^)] IN
                      to_sequence;
                IF to_files.path_list^ [i].path <> NIL THEN
                  to_files.path_list^ [i].path^ := from_files.path_list^ [i].path^;
                ELSE
                  osp$set_status_condition (ose$to_sequence_full, status);
                  EXIT copy_policy;
                IFEND;
              FOREND;
            ELSE
              osp$set_status_condition (ose$to_sequence_full, status);
              EXIT copy_policy;
            IFEND;
          IFEND;
        IFEND;
      PROCEND copy_files;
?? OLDTITLE ??
?? NEWTITLE := 'copy_login_users', EJECT ??

      PROCEDURE copy_login_users
        (    from_list: ^ost$ecp_login_users_list;
         VAR to_list: ^ost$ecp_login_users_list);

        IF from_list <> NIL THEN
          NEXT to_list: [1 .. UPPERBOUND (from_list^)] IN to_sequence;
          IF to_list <> NIL THEN
            to_list^ := from_list^;
          ELSE
            osp$set_status_condition (ose$to_sequence_full, status);
            EXIT copy_policy;
          IFEND;
        ELSE
          to_list := NIL;
        IFEND;
      PROCEND copy_login_users;
?? OLDTITLE ??
?? NEWTITLE := 'copy_names', EJECT ??

      PROCEDURE copy_names
        (    from_list: ^ost$ecp_name_list;
         VAR to_list: ^ost$ecp_name_list);

        IF from_list <> NIL THEN
          NEXT to_list: [1 .. UPPERBOUND (from_list^)] IN to_sequence;
          IF to_list <> NIL THEN
            to_list^ := from_list^;
          ELSE
            osp$set_status_condition (ose$to_sequence_full, status);
            EXIT copy_policy;
          IFEND;
        ELSE
          to_list := NIL;
        IFEND;
      PROCEND copy_names;
?? OLDTITLE ??
?? NEWTITLE := 'copy_volumes', EJECT ??

      PROCEDURE copy_volumes
        (    from_list: ^ost$ecp_volume_list;
         VAR to_list: ^ost$ecp_volume_list);

        IF from_list <> NIL THEN
          NEXT to_list: [1 .. UPPERBOUND (from_list^)] IN to_sequence;
          IF to_list <> NIL THEN
            to_list^ := from_list^;
          ELSE
            osp$set_status_condition (ose$to_sequence_full, status);
            EXIT copy_policy;
          IFEND;
        ELSE
          to_list := NIL;
        IFEND;
      PROCEND copy_volumes;

?? OLDTITLE, EJECT ??

      copy_names (from_policy^.job_classes, to_policy^.job_classes);

      to_policy^.job_mode := from_policy^.job_mode;

      copy_names (from_policy^.jobs, to_policy^.jobs);

      copy_login_users (from_policy^.login_users, to_policy^.login_users);

      copy_names (from_policy^.families, to_policy^.families);

      copy_files (from_policy^.files, to_policy^.files);

      to_policy^.mass_storage_classes := from_policy^.mass_storage_classes;

      copy_names (from_policy^.sets, to_policy^.sets);

      copy_volumes (from_policy^.volumes, to_policy^.volumes);

      copy_conditions (from_policy^.conditions, to_policy^.conditions);

      to_policy^.polling_frequency := from_policy^.polling_frequency;

    PROCEND copy_policy;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    from_seq := from_sequence;

    RESET from_seq;
    RESET to_sequence;

    NEXT from_header IN from_seq;
    IF from_header <> NIL THEN
      NEXT to_header IN to_sequence;
      IF to_header <> NIL THEN

        to_header^.last_policy := NIL;
        to_header^.number_of_policies := 0;
        to_header^.segment_p.kind := amc$sequence_pointer;
        to_header^.segment_p.sequence_pointer := to_sequence;

        from_policy := from_header^.first_policy;

      /copy/
        WHILE (from_policy <> NIL) AND (to_header^.number_of_policies <= from_header^.number_of_policies) DO

          NEXT to_policy IN to_sequence;
          IF to_policy <> NIL THEN

            copy_policy;
            IF status.normal THEN

              IF from_policy = from_header^.first_policy THEN
                to_header^.first_policy := to_policy;
              IFEND;

              IF to_header^.last_policy <> NIL THEN
                to_header^.last_policy^.next_policy := to_policy;
              IFEND;

              to_header^.last_policy := to_policy;
              to_policy^.next_policy := NIL;

              to_header^.number_of_policies := to_header^.number_of_policies + 1;

              from_policy := from_policy^.next_policy;
            ELSE
              EXIT /copy/;
            IFEND;
          ELSE
            osp$set_status_condition (ose$to_sequence_full, status);
            EXIT /copy/;
          IFEND;
        WHILEND /copy/;
      IFEND;
    ELSE
      osp$set_status_condition (ose$from_sequence_empty, status);
    IFEND;

  PROCEND osp$copy_exception_policies;
?? OLDTITLE ??
MODEND osm$disk_fault_tolerance_13d;
*DECK DECK=OSM$DISK_FAULT_TOLERANCE_23D EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Disk Fault Tolerance (23D)' ??
MODULE osm$disk_fault_tolerance_23d;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fsc$max_path_size
*copyc fst$path_size
*copyc gft$file_kind
*copyc osd$exception_policies
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc ose$disk_ft_exceptions
*copyc ost$heap
?? POP ??
*copyc avp$configuration_administrator
*copyc clp$build_pattern_for_wild_card
*copyc clp$convert_file_ref_to_string
*copyc clp$evaluate_file_reference
*copyc clp$match_string_pattern
*copyc clp$trimmed_string_size
*copyc ifp$invoke_pause_utility
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$begin_system_activity
*copyc osp$copy_exception_policies
*copyc osp$end_system_activity
*copyc osp$establish_condition_handler
*copyc osp$log_system_status_message
*copyc osp$r1_get_applicable_policy
*copyc osp$r1_get_installed_policies
*copyc osp$r1_install_exception_policy
*copyc osp$r1_lock_policies
*copyc osp$r1_unlock_policies
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$verify_system_privilege
*copyc oss$task_private
*copyc osv$installed_policies
*copyc pmp$continue_to_cause
*copyc pmp$log_ascii
*copyc pmp$long_term_wait
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
    VAR
      osv$ecp_sequence_headers: [XDCL, #GATE, oss$task_private] array [ost$ecp_sequence_index] of
            ^ost$ecp_header := [NIL, NIL];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$r3_get_applicable_policy', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$r3_get_applicable_policy
    (    criteria: ost$ecp_criteria;
     VAR applicable_actions: ost$ecp_actions;
     VAR polling_frequency: ost$ecp_polling_frequency;
     VAR status: ost$status);

?? NEWTITLE := 'exit_handler', EJECT ??

  PROCEDURE exit_handler
    (    condition: pmt$condition;
         condition_info: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR condition_status: ost$status);

    VAR
      ignore_status: ost$status;

      case condition.selector of

      = pmc$block_exit_processing =
        osp$r1_unlock_policies;
        osp$end_system_activity;

    = ifc$interactive_condition =
      CASE condition.interactive_condition OF
      = ifc$terminate_break =
        osp$set_status_from_condition ('OS', condition, save_area, status,
              ignore_status);
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        EXIT osp$r3_get_applicable_policy;
      = ifc$pause_break, ifc$job_reconnect =
        ifp$invoke_pause_utility (ignore_status);
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;
    ELSE
      pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
    CASEND;

  PROCEND exit_handler;

?? OLDTITLE ??
*copy osi$find_applicable_policy

    CONST
      one_second = 1000;

    VAR
      ignore_status: ost$status,
      installed_header: ^ost$ecp_header,
      local_policy: ^ost$ecp_policy_header,
      policies: ^SEQ ( * );

    osp$verify_system_privilege;

    status.normal := TRUE;

    applicable_actions := $ost$ecp_actions [];
    polling_frequency.specified := FALSE;

    IF osv$installed_policies <> NIL THEN

    /lock_for_read/
      BEGIN
        osp$establish_condition_handler (^exit_handler, {block_exit=}TRUE);

        osp$begin_system_activity;
        REPEAT
          osp$r1_lock_policies (status);
          IF (NOT status.normal) AND (status.condition = ose$exception_policies_locked) THEN
            osp$end_system_activity;

            pmp$long_term_wait (one_second, one_second);

            osp$begin_system_activity;
          IFEND;
        UNTIL status.normal;

        policies := osv$installed_policies;

        IF policies <> NIL THEN
          RESET policies;
          NEXT installed_header IN policies;
          find_applicable_policy (criteria, installed_header, applicable_actions, local_policy, status);
          IF status.normal AND (local_policy <> NIL) THEN
            polling_frequency := local_policy^.polling_frequency;
          IFEND;
        IFEND;
      END /lock_for_read/;
    IFEND;

  PROCEND osp$r3_get_applicable_policy;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$r3_get_installed_policies', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$r3_get_installed_policies
    (VAR installed_policies {input, output} : ^SEQ ( * );
     VAR sequence_header: ^ost$ecp_header;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      segment_pointer: amt$segment_pointer;

    osp$verify_system_privilege;

    status.normal := TRUE;
    sequence_header := NIL;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
    IF status.normal THEN
      RESET segment_pointer.sequence_pointer;
      osp$r1_get_installed_policies (segment_pointer.sequence_pointer, status);

      IF status.normal THEN
        osp$copy_exception_policies (segment_pointer.sequence_pointer, installed_policies, status);
        RESET installed_policies;
        NEXT sequence_header IN installed_policies;
      IFEND;

      mmp$delete_scratch_segment (segment_pointer, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

  PROCEND osp$r3_get_installed_policies;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$r3_install_exception_policy', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$r3_install_exception_policy
    (    session_policies: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      segment_pointer: amt$segment_pointer;

    osp$verify_system_privilege;

    status.normal := TRUE;

    IF avp$configuration_administrator () THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
      IF status.normal THEN
        RESET segment_pointer.sequence_pointer;
        osp$copy_exception_policies (session_policies, segment_pointer.sequence_pointer, status);

        IF status.normal THEN
          osp$r1_install_exception_policy (segment_pointer.sequence_pointer, status);
        IFEND;

        mmp$delete_scratch_segment (segment_pointer, local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;
      IFEND;
    ELSE
      osp$set_status_condition (ose$policies_require_privilege, status);
    IFEND;

  PROCEND osp$r3_install_exception_policy;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$log_executed_policy', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$log_executed_policy
    (    status: ost$status);

    VAR
      ignore_status: ost$status;

    osp$log_system_status_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], status, ignore_status);

  PROCEND osp$log_executed_policy;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$log_io_read_error ', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$log_io_read_error
    (    path: string ( * );
         file_kind: gft$file_kind;
         pva: ^cell);

    CONST
      account = 'Account ',
      binding = 'Binding ',
      catalog = 'Catalog ',
      code = 'Code ',
      data = 'Data ',
      device = 'Device ',
      engineering = 'Engineering ',
      file = 'File ',
      history = 'History ',
      job = 'Job ',
      literals = 'Literals ',
      log = 'Log',
      prefix = '**UNRECOVERED READ ERROR - ',
      pva_prefix = ' PVA=',
      security = 'Security ',
      segment = 'Segment',
      shared = 'Shared ',
      stack = 'Stack ',
      statistic = 'Statistic ',
      system = 'System ',
      task = 'Task ',
      transient = 'Transient ';

    VAR
      ignore_status: ost$status,
      length: integer,
      log_text: string (fsc$max_path_size + 27 {prefix} + 23 {system engineering log} + 5 { pva=} +
            13 {ost$virtual_address});

    CASE #SEGMENT (pva) OF {Pageable Segment Numbers Assigned by Convention}
    = osc$segnum_mainframe_paged = {#2}
      STRINGREP (log_text, length, prefix, system, data, segment, ' (1, 3)', pva_prefix, pva);
    = osc$segnum_job_pageable_heap = {#4}
      STRINGREP (log_text, length, prefix, job, data, segment, ' (2, 3)', pva_prefix, pva);
    = osc$segnum_task_private_heap = {#5}
      STRINGREP (log_text, length, prefix, task, data, segment, ' (3, 13)', pva_prefix, pva);
    = osc$segnum_task_shared_heap = {#6}
      STRINGREP (log_text, length, prefix, task, data, segment, ' (3, 13)', pva_prefix, pva);
    = osc$segnum_system_dayfile = {#8}
      STRINGREP (log_text, length, prefix, system, log, pva_prefix, pva);
    = osc$segnum_job_dayfile = {#9}
      STRINGREP (log_text, length, prefix, job, log, pva_prefix, pva);
    = 11 {0B(16)} =
      STRINGREP (log_text, length, prefix, system, literals, segment, ' (2, 13)', pva_prefix, pva);
    = 13 {013(16)} =
      STRINGREP (log_text, length, prefix, system, code, segment, ' (1, 1, 3)', pva_prefix, pva);
    = 14 {0E(16)} =
      STRINGREP (log_text, length, prefix, system, binding, segment, ' (1, 13)', pva_prefix, pva);
    = 15 {0F(16)} =
      STRINGREP (log_text, length, prefix, job, stack, segment, ' (1, 1)', pva_prefix, pva);
    = 16 {10(16)} =
      STRINGREP (log_text, length, prefix, job, stack, segment, ' (2, 2)', pva_prefix, pva);
    = 17 {11(16)} =
      STRINGREP (log_text, length, prefix, job, stack, segment, ' (3, 3)', pva_prefix, pva);
    = 19 {13(16)} =
      STRINGREP (log_text, length, prefix, system, code, segment, ' (1, 3, 13)', pva_prefix, pva);
    = 20 {14(16)} =
      STRINGREP (log_text, length, prefix, system, code, segment, ' (1, 13, 13)', pva_prefix, pva);
    = 21 {15(16)} =
      STRINGREP (log_text, length, prefix, system, data, segment, ' (3, 3)', pva_prefix, pva);
    = 22 {16(16)} =
      STRINGREP (log_text, length, prefix, system, data, segment, ' (1, 1)', pva_prefix, pva);
    = 23 {17(16)} =
      STRINGREP (log_text, length, prefix, system, literals, segment, ' (11, 11)', pva_prefix, pva);
    = 26 {1A(16)} =
      STRINGREP (log_text, length, prefix, system, code, segment, ' (2, 2, 3)', pva_prefix, pva);
    = 27 {1B(16)} =
      STRINGREP (log_text, length, prefix, system, binding, segment, ' (2, 13)', pva_prefix, pva);
    = 28 {1C(16)} =
      STRINGREP (log_text, length, prefix, system, code, segment, ' (2, 3, 13)', pva_prefix, pva);
    = 29 {113(16)} =
      STRINGREP (log_text, length, prefix, system, code, segment, ' (2, 13, 13)', pva_prefix, pva);
    = osc$segnum_first_global_log = {#31, 01f(16)}
      STRINGREP (log_text, length, prefix, system, account, log, pva_prefix, pva);
    = osc$segnum_first_global_log - 6 = {#25, 019(16)}
      STRINGREP (log_text, length, prefix, system, engineering, log, pva_prefix, pva);
    = osc$segnum_first_global_log + 2 = {#33, 21f(16)}
      STRINGREP (log_text, length, prefix, system, job, history, log, pva_prefix, pva);
    = osc$segnum_first_global_log + 3 = {#34, 022(16)}
      STRINGREP (log_text, length, prefix, system, security, log, pva_prefix, pva);
    = osc$segnum_first_global_log + 4 = {#35, 023(16)}
      STRINGREP (log_text, length, prefix, system, statistic, log, pva_prefix, pva);
    ELSE
      CASE file_kind OF
      = gfc$fk_catalog =
        STRINGREP (log_text, length, prefix, catalog, path, pva_prefix, pva);
      = gfc$fk_device_file =
        STRINGREP (log_text, length, prefix, device, file, pva_prefix, pva);
      = gfc$fk_global_unnamed =
        STRINGREP (log_text, length, prefix, shared, transient, segment, pva_prefix, pva);
      = gfc$fk_job_local_file =
        STRINGREP (log_text, length, prefix, file, path, pva_prefix, pva);
      = gfc$fk_job_permanent_file =
        STRINGREP (log_text, length, prefix, file, path, pva_prefix, pva);
      = gfc$fk_unnamed_file =
        STRINGREP (log_text, length, prefix, job, transient, segment, pva_prefix, pva);
      ELSE {gfk$monitor_only_unnamed (wired segments), gfc$fk_save_2, gfc$fk_save_3}
        RETURN;
      CASEND;
    CASEND;

    pmp$log_ascii (log_text (1, length), $pmt$ascii_logset [pmc$job_log, pmc$system_log],
          pmc$msg_origin_system, ignore_status);

  PROCEND osp$log_io_read_error;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$store_sequence_headers', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$store_sequence_headers
    (    sequence_headers: array [ost$ecp_sequence_index] of ^ost$ecp_header;
     VAR status: ost$status);

    osp$verify_system_privilege;

    osv$ecp_sequence_headers := sequence_headers;

  PROCEND osp$store_sequence_headers;

?? OLDTITLE ??
MODEND osm$disk_fault_tolerance_23d;
*DECK DECK=OSM$DISK_FAULT_TOLERANCE_2DD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Disk Fault Tolerance (2DD)' ??
MODULE osm$disk_fault_tolerance_2dd;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$put_program_actions
*copyc bat$default_handler_params
*copyc dmt$subfile_index
*copyc fsc$wait_msg_module_name
*copyc fsc$wait_undefined_condition
*copyc fst$access_condition_entry
*copyc fst$file_access_conditions
*copyc fst$file_reference
*copyc fst$path
*copyc fst$path_size
*copyc fst$volume_condition_list
*copyc oft$display_message
*copyc osc$max_status_message_lines
*copyc osc$max_system_message_modules
*copyc osd$exception_policies
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc ose$disk_ft_exceptions
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc ost$ecp_exception_context
*copyc ost$message_parameters
*copyc ost$message_template
*copyc ost$name
*copyc ost$status
*copyc ost$status_message
*copyc ost$status_message_line
*copyc ost$status_message_line_count
*copyc pfe$error_condition_codes
*copyc pft$move_object_info
*copyc rmc$unspecified_file_class
*copyc rmt$mass_storage_class
*copyc rmt$volume_list
?? POP ??
*copyc amp$return
*copyc clp$convert_cyc_ref_to_cyc_sel
*copyc clp$convert_date_time_to_string
*copyc clp$trimmed_string_size
*copyc cmp$get_element_state_via_lun
*copyc cmp$get_ms_status_via_lun
*copyc cmp$get_ms_volumes
*copyc cmp$get_ms_volume_info
*copyc dfp$check_job_recovery
*copyc fsp$evaluate_file_reference
*copyc fsv$file_access_conditions
*copyc ifp$invoke_pause_utility
*copyc jmp$system_job
*copyc ofp$display_status_message
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$clear_wait_message
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$find_applicable_policy
*copyc osp$find_parameter_prompt
*copyc osp$file_access_condition
*copyc osp$format_help_message
*copyc osp$get_access_condition_entry
*copyc osp$get_current_display_message
*copyc osp$get_file_criteria
*copyc osp$get_installed_policies
*copyc osp$get_login_user_criteria
*copyc osp$log_executed_policy
*copyc osp$r3_get_applicable_policy
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$wait_on_condition
*copyc oss$task_private
*copyc osv$system_message_modules
*copyc pfp$convert_fs_to_pft$path
*copyc pfp$get_volumes_in_set
*copyc pfp$purge
*copyc pfp$r3_change
*copyc pfp$r3_get_move_obj_device_info
*copyc pfp$r3_physically_move_catalog
*copyc pfp$r3_release_data
*copyc pmp$cause_task_condition
*copyc pmp$continue_to_cause
*copyc pmp$delay
*copyc pmp$get_compact_date_time
*copyc pmp$get_microsecond_clock
*copyc pmp$get_task_cp_time
*copyc pmp$long_term_wait
*copyc pmp$wait
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
?? NEWTITLE := '[XDCL], osv$initial_exception_context' ??

?? FMT (FORMAT := OFF) ??
  VAR
    osv$initial_exception_context: [XDCL, #GATE, READ, oss$job_paged_literal] ost$ecp_exception_context := [
         [{when_handler_status.normal} TRUE,
          [{exception_status.normal} TRUE],
           {file_access_condition} fsc$null_file_access_condition,
           {object_name} osc$null_name,
           {file_segment_isolated} FALSE,
           {file_segment} 0
          ],
          {allowed_access_conditions} -$fst$file_access_conditions [],
          {caller_will_retrieve_file} FALSE,
          [
          {file} osc$ecp_file_reference,
          {file_reference} NIL
          ],
          {force_wait} FALSE,
          {initial_call} TRUE,
          {logging_allowed} TRUE,
          {password} osc$null_name,
          {catalog_move_count} 0,
          [{condition_status.normal} TRUE],
          {raised_conditions} $fst$file_access_conditions [],
          {wait} TRUE,
          {wait_time} fsc$longest_wait_time,
          {catalog_object} FALSE,
          {elapsed_wait_time} 0
          ];

?? FMT (FORMAT := ON) ??
  VAR
    enforce_except_policies_active: [oss$task_private] boolean := FALSE,
    exception_information: [oss$task_private] ost$condition_information;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$enforce_exception_policies', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$enforce_exception_policies
    (VAR context {input, output} : ost$ecp_exception_context);

    VAR
      access_condition_entry: fst$access_condition_entry,
      actions: ost$ecp_actions,
      applicable_poll_frequency: ost$ecp_polling_frequency,
      caller_id: ost$caller_identifier,
      criteria: ost$ecp_criteria,
      cycle_selector: clt$cycle_selector,
      evaluated_file_reference: fst$evaluated_file_reference,
      initial_status: ost$status,
      pf_path: ^pft$path,
      ring3_caller: boolean,
      volume_condition_list: ^fst$volume_condition_list;


?? NEWTITLE := '  enforce_exit_handler', EJECT ??

    PROCEDURE enforce_exit_handler
      (    ignore_condition: pmt$condition;
           ignore_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      {Recursion is only of concern in ring 3 or less
      IF ring3_caller THEN
        enforce_except_policies_active := FALSE;
      IFEND;

    PROCEND enforce_exit_handler;
?? OLDTITLE ??
?? NEWTITLE := '  execute_exception_policy', EJECT ??

    PROCEDURE execute_exception_policy;


?? NEWTITLE := 'remove_damage_condition', EJECT ??

      PROCEDURE remove_damage_condition;

        VAR
          delete_damage_conditions: ^array [1 .. 1] of pft$change_descriptor,
          ignore_status: ost$status;

        PUSH delete_damage_conditions;

        delete_damage_conditions^ [1].change_type := pfc$delete_damage_change;

        delete_damage_conditions^ [1].delete_damage_condition :=
              $fst$cycle_damage_symptoms [fsc$respf_modification_mismatch];

        pfp$r3_change (pf_path^, cycle_selector.value , context.password,
              delete_damage_conditions^, ignore_status);

      PROCEND remove_damage_condition;
?? OLDTITLE ??
?? NEWTITLE := '  report_delete', EJECT ??

      PROCEDURE report_delete;

        VAR
          log_status: ost$status;

        osp$set_status_condition (ose$log_deletion, log_status);

        report_context (log_status);

        osp$log_executed_policy (log_status);
        osp$log_executed_policy (initial_status);

      PROCEND report_delete;
?? OLDTITLE ??
?? NEWTITLE := '  report_exit', EJECT ??

      PROCEDURE report_exit;

        VAR
          log_status: ost$status;

        IF context.logging_allowed THEN
          osp$set_status_condition (ose$log_exit, log_status);

          report_context (log_status);

          osp$log_executed_policy (log_status);
          osp$log_executed_policy (initial_status);
        IFEND;

      PROCEND report_exit;
?? OLDTITLE ??
?? NEWTITLE := '  report_release', EJECT ??

      PROCEDURE report_release
        (    release_info: pft$release_data_info);

        VAR
          date_value: clt$date_time,
          date_string: ost$string,
          ignore_status: ost$status,
          log_status: ost$status;

        IF release_info.valid_archive_entry_found THEN
          osp$set_status_condition (ose$log_matching_release, log_status);
          report_context (log_status);
        ELSE
          osp$set_status_condition (ose$log_non_matching_release, log_status);

          report_context (log_status);

          date_value.date_specified := TRUE;
          date_value.time_specified := TRUE;

          date_string.size := 1;
          date_string.value := '';
          date_value.value := release_info.old_data_modification_date_time;
          clp$convert_date_time_to_string (date_value, 'ISOD.MILLISECOND', date_string, ignore_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, date_string.
                value (1, date_string.size), log_status);

          date_string.size := 1;
          date_string.value := '';
          date_value.value := release_info.new_data_modification_date_time;
          clp$convert_date_time_to_string (date_value, 'ISOD.MILLISECOND', date_string, ignore_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, date_string.
                value (1, date_string.size), log_status);
        IFEND;

        osp$log_executed_policy (log_status);
        osp$log_executed_policy (initial_status);

      PROCEND report_release;

?? OLDTITLE ??
?? NEWTITLE := '  report_wait', EJECT ??

      PROCEDURE report_wait;

        VAR
          log_status: ost$status;

        IF (access_condition_entry.file_access_condition IN -$fst$file_access_conditions
              [fsc$cycle_busy, fsc$data_retrieval_required]) AND context.logging_allowed THEN
          osp$set_status_condition (ose$log_wait, log_status);

          report_context (log_status);

          osp$append_status_integer (osc$status_parameter_delimiter, (context.wait_time DIV 1000), 10,
                {include_radix_specifier} FALSE, log_status);

          osp$log_executed_policy (log_status);
          osp$log_executed_policy (initial_status);

        IFEND;

      PROCEND report_wait;
?? OLDTITLE ??
?? NEWTITLE := '  wait_on_condition', EJECT ??

      PROCEDURE wait_on_condition;

        VAR
          original_display_message: oft$display_message,
          wait_message_displayed: boolean;

?? NEWTITLE := '    wait_handler', EJECT ??

        PROCEDURE wait_handler
          (    condition: pmt$condition;
               condition_information: ^pmt$condition_information;
               save_area: ^ost$stack_frame_save_area;
           VAR handler_status: ost$status);

          VAR
            local_status: ost$status;

          CASE condition.selector OF
          = pmc$block_exit_processing =
            osp$clear_wait_message (original_display_message, wait_message_displayed);
            #SPOIL (wait_message_displayed);
            context.wait := FALSE;
          = ifc$interactive_condition =
            CASE condition.interactive_condition OF
            = ifc$terminate_break =
              osp$set_status_from_condition ('AM', condition, save_area, context.condition_status,
                    local_status);
              pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
              EXIT wait_on_condition;
            = ifc$pause_break, ifc$job_reconnect =
              ifp$invoke_pause_utility (local_status);
            ELSE
              pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
            CASEND;
          ELSE
            pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          CASEND;

        PROCEND wait_handler;
?? OLDTITLE, EJECT ??
        CONST
          msec_per_sec = 1000;

        VAR
          display_status: ost$status,
          file_path: fst$path,
          ignore_status: ost$status,
          poll_time: 0 .. fsc$longest_wait_time,
          wait_message: oft$display_message;

        wait_message_displayed := FALSE;
        #SPOIL (wait_message_displayed);

        IF context.wait_time > 0 THEN
          IF applicable_poll_frequency.specified THEN
            poll_time := applicable_poll_frequency.value * msec_per_sec;
          ELSE
            poll_time := access_condition_entry.polling_interval;
          IFEND;

          IF poll_time > context.wait_time THEN
            poll_time := context.wait_time;
          IFEND;

          osp$get_current_display_message (original_display_message);
          osp$establish_condition_handler (^wait_handler, TRUE);

          file_path := criteria.file;
          IF criteria.file = osc$null_name THEN
            file_path := '<file not isolated>';
          IFEND;

          osp$format_wait_message (^access_condition_entry, ^file_path, criteria.mass_storage_class,
                volume_condition_list, criteria.volume_list, wait_message);

          ofp$display_status_message (wait_message.text (1, wait_message.size), display_status);
          IF display_status.normal THEN
            wait_message_displayed := TRUE;
            #SPOIL (wait_message_displayed);
          IFEND;

          IF ring3_caller AND NOT (access_condition_entry.file_access_condition IN
                $fst$file_access_conditions [fsc$cycle_busy, fsc$data_restoration_required,
                fsc$data_retrieval_required, fsc$file_server_inactive]) THEN
            pmp$delay(poll_time, ignore_status);
          ELSE

{ An extra wait is done to allow for the server case, where a previous ready
{ task has inhibited the subsequent wait.

            pmp$long_term_wait (1, 1);
            pmp$long_term_wait (poll_time, poll_time);
          IFEND;

          context.elapsed_wait_time := poll_time;
          context.wait_time := context.wait_time - poll_time;
          context.wait := context.wait_time > 0;

          osp$clear_wait_message (original_display_message, wait_message_displayed);
          #SPOIL (wait_message_displayed);
          osp$disestablish_cond_handler;
        IFEND;

      PROCEND wait_on_condition;
?? OLDTITLE, EJECT ??

      VAR
        data_released: boolean,
        external_info: ^ost$condition_information,
        ignore_entry_found : boolean,
        local_status: ost$status,
        p_release_data_info: ^pft$release_data_info,
        recovery_occurred: boolean;

      data_released := FALSE;
      recovery_occurred := FALSE;

      IF access_condition_entry.user_defined_condition = osc$volume_unavailable_cond THEN
        dfp$check_job_recovery (recovery_occurred);
      IFEND;

      IF context.initial_call AND (osc$ecp_enable_matching_image IN actions) OR
            (osc$ecp_enable_nonmatch_image IN actions) THEN
        IF (fsp$path_element (^evaluated_file_reference, 1) ^ <> fsc$local) THEN
          PUSH p_release_data_info;
          p_release_data_info^.perform_changes := TRUE;
          p_release_data_info^.release_attached_cycle_data := TRUE;
          p_release_data_info^.update_last_release_date_time := TRUE;
          p_release_data_info^.valid_archive_entry_required :=
                NOT (osc$ecp_enable_nonmatch_image IN actions);
          pfp$r3_release_data (pf_path^, cycle_selector.value, context.password, p_release_data_info,
                local_status);
          data_released := local_status.normal AND (NOT p_release_data_info^.cycle_attached);
          IF data_released THEN
            report_release (p_release_data_info^);
            IF NOT p_release_data_info^.valid_archive_entry_found THEN
              IF NOT (osc$ecp_set_damage_condition IN actions) THEN
                remove_damage_condition;
              IFEND;
            IFEND;
            {
            { Return a different status than the one provided by the caller to encourage retrieval.
            {
            osp$set_status_condition (pfe$cycle_data_resides_offline, context.condition_status);
            osp$append_status_parameter (osc$status_parameter_delimiter, criteria.file (1,
                  clp$trimmed_string_size (criteria.file)), context.condition_status);
            osp$append_status_integer (osc$status_parameter_delimiter, cycle_selector.value.cycle_number,
                   {radix} 10, {include_radix_specifier} FALSE, context.condition_status);
            {
            { Update the access_condition_entry to reflect the new condition and avoid subsequent
            { modification of this status variable by someone confused about the current condition
            {
            osp$get_access_condition_entry (context.condition_status, access_condition_entry,
                  ignore_entry_found);
          IFEND;
        IFEND;
      IFEND;

      IF (osc$ecp_wait IN actions) AND (NOT data_released) THEN
        IF (access_condition_entry.file_access_condition IN context.allowed_access_conditions) THEN
          IF (NOT recovery_occurred) AND context.wait THEN
            IF NOT (access_condition_entry.file_access_condition IN context.raised_conditions) THEN
              report_wait;
              context.raised_conditions := context.raised_conditions +
                    $fst$file_access_conditions [access_condition_entry.file_access_condition];
              IF ring3_caller THEN
                {The ring 3 stack is not readable in ring 11.  Therefore we must copy the information
                {into a pre-allocated task private variable.
                exception_information := context.externalized_info;
                pmp$cause_task_condition (access_condition_entry.user_defined_condition,
                      ^exception_information, {notify_scl=} TRUE, {notify_debug=} FALSE,
                      {propate_to_parent=} TRUE, {call_default_handler=} FALSE, local_status);
              ELSE
                pmp$cause_task_condition (access_condition_entry.user_defined_condition,
                      ^context.externalized_info, {notify_scl=} TRUE, {notify_debug=} FALSE,
                      {propate_to_parent=} TRUE, {call_default_handler=} FALSE, local_status);
              IFEND;
            IFEND;
            wait_on_condition;
          ELSE
            context.wait := FALSE;
          IFEND;
        ELSE
          context.wait := FALSE;
        IFEND;
      ELSEIF (osc$ecp_exit IN actions) AND (NOT data_released) THEN
        IF context.wait THEN
          report_exit;
        IFEND;
        context.wait := FALSE;
      ELSEIF (osc$ecp_delete IN actions) AND (NOT data_released) THEN
        IF (pf_path^ [1] <> fsc$local) THEN
          pfp$purge (pf_path^, cycle_selector.value, context.password, local_status);
          IF local_status.normal THEN
            report_delete;
            osp$set_status_condition (ose$data_lost, context.condition_status);
            osp$append_status_file (osc$status_parameter_delimiter, criteria.file,
                  context.condition_status);
            context.wait := FALSE;
          IFEND;
        ELSE {Temporary file}
          amp$return (criteria.file, local_status);
          IF local_status.normal THEN
            report_delete;
            osp$set_status_condition (ose$data_lost, context.condition_status);
            osp$append_status_file (osc$status_parameter_delimiter, criteria.file,
                  context.condition_status);
            context.wait := FALSE;
          IFEND;
        IFEND;
      IFEND;
      IF context.wait AND (context.condition_status.condition = pfe$cycle_data_resides_offline) THEN
        {
        { The data_retrieval_required_condition is the only condition that requires the participation of
        { the affected job to resolve.  All other conditions are satisfied as a result of human intervention.
        { If the calling interface is incapable of initiating the file retrieval, there is no reason to have
        { the job wait.  Someone else must be informed that the file requires retrieval.
        {
        context.wait := context.caller_will_retrieve_file;
      IFEND;

      IF NOT (access_condition_entry.file_access_condition IN context.allowed_access_conditions) THEN
        context.wait := FALSE;
      IFEND;

    PROCEND execute_exception_policy;
?? OLDTITLE ??

?? NEWTITLE := '  move_catalog', EJECT ??

    PROCEDURE move_catalog
      (    path: pft$path;
           criteria: ost$ecp_criteria;
       VAR catalog_moved: boolean);

?? NEWTITLE := 'initialize_set_volume_list', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to initialize information in the
{   SET_VOLUME_LIST which is contained in the MOVE_OBJECT_INFO structure.
{

      PROCEDURE initialize_set_volume_list
        (    set_volume_list_p: ^pft$mo_volume_list;
         VAR local_status: ost$status);

        VAR
          element_status: iot$unit_status,
          found: boolean,
          i: integer,
          j: integer,
          ms_volume_count: integer,
          ms_volumes_p: ^array [ * ] of cmt$mass_storage_volume,
          state: cmt$element_state;

        local_status.normal := TRUE;

        IF set_volume_list_p = NIL THEN
          RETURN;
        IFEND;

        { Obtain the class membership of each volume in the configuration which is ON and ENABLED.

        cmp$get_ms_volumes (ms_volume_count);
        PUSH ms_volumes_p: [1 .. ms_volume_count];
        cmp$get_ms_volume_info (ms_volumes_p);

      /process_volume/
        FOR i := 1 TO UPPERBOUND (set_volume_list_p^) DO
          found := FALSE;

          set_volume_list_p^ [i].available := FALSE;
          set_volume_list_p^ [i].bytes_moved_from := 0;
          set_volume_list_p^ [i].bytes_moved_to := 0;
          set_volume_list_p^ [i].bytes_released := 0;
          set_volume_list_p^ [i].catalogs_moved_from := 0;
          set_volume_list_p^ [i].catalogs_moved_to := 0;
          set_volume_list_p^ [i].cycles_moved_from := 0;
          set_volume_list_p^ [i].cycles_moved_to := 0;
          set_volume_list_p^ [i].cycles_released := 0;
          set_volume_list_p^ [i].logical_unit_number := 0;
          set_volume_list_p^ [i].mass_storage_available := 0;
          set_volume_list_p^ [i].mass_storage_before := 0;
          set_volume_list_p^ [i].mass_storage_capacity := 0;
          set_volume_list_p^ [i].move_bytes_threshold_exceeded := FALSE;
          set_volume_list_p^ [i].ms_class := $dmt$class [];
          set_volume_list_p^ [i].volume_type := pfc$unspecified_volume;

        /locate_volume/
          FOR j := 1 TO ms_volume_count DO
            IF set_volume_list_p^ [i].recorded_vsn = ms_volumes_p^ [j].recorded_vsn THEN
              found := TRUE;
              EXIT /locate_volume/;
            IFEND;
          FOREND /locate_volume/;

          IF NOT found THEN
            CYCLE /process_volume/;
          IFEND;

          cmp$get_element_state_via_lun (ms_volumes_p^ [j].lun, state);
          IF state <> cmc$on THEN
            CYCLE /process_volume/;
          IFEND;

          cmp$get_ms_status_via_lun (ms_volumes_p^ [j].lun, element_status);
          IF element_status.disabled THEN
            CYCLE /process_volume/;
          IFEND;

          set_volume_list_p^ [i].available := TRUE;
          set_volume_list_p^ [i].logical_unit_number := ms_volumes_p^ [j].lun;
          set_volume_list_p^ [i].ms_class := ms_volumes_p^ [j].class;

        FOREND /process_volume/;

      PROCEND initialize_set_volume_list;

?? OLDTITLE ??


?? NEWTITLE := 'report_move_status', EJECT ??

      PROCEDURE report_move_status
        (    move_status: pft$move_status);

        VAR
          log_status: ost$status;

        IF move_status.move_successful THEN
          osp$set_status_condition (ose$log_catalog_move, log_status);
          report_context (log_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, criteria.volume_list^ [1].recorded_vsn,
                log_status);

          osp$append_status_integer (osc$status_parameter_delimiter, context.catalog_move_count, 10,
                {include_radix_specifier} FALSE, log_status);

          osp$log_executed_policy (log_status);
        ELSEIF context.initial_call THEN
          osp$set_status_condition (ose$log_catalog_move_failure, log_status);
          report_context (log_status);
          CASE move_status.reason_for_move_failure OF
          = pfc$cycle_busy =
            osp$append_status_parameter (osc$status_parameter_delimiter, 'CYCLE_BUSY', log_status);
          = pfc$data_released =
            osp$append_status_parameter (osc$status_parameter_delimiter, 'DATA RELEASED', log_status);
          = pfc$device_class_not_ms =
            osp$append_status_parameter (osc$status_parameter_delimiter, 'DEVICE CLASS NOT MS', log_status);
          = pfc$insufficient_space =
            osp$append_status_parameter (osc$status_parameter_delimiter, 'INSUFFICIENT SPACE', log_status);
          = pfc$io_error =
            osp$append_status_parameter (osc$status_parameter_delimiter, 'IO ERROR', log_status);
          = pfc$no_available_space =
            osp$append_status_parameter (osc$status_parameter_delimiter, ' NO SPACE', log_status);
          = pfc$operator_skip =
            osp$append_status_parameter (osc$status_parameter_delimiter, 'OPERATOR SKIP', log_status);
          = pfc$operator_terminate =
            osp$append_status_parameter (osc$status_parameter_delimiter, 'OPERATOR TERMINATE', log_status);
          = pfc$set_threshold_exceeded =
            osp$append_status_parameter (osc$status_parameter_delimiter, 'SET THRESHOLD EXCEEDED',
                  log_status);
          = pfc$unexpected_abort =
            osp$append_status_parameter (osc$status_parameter_delimiter, 'UNEXPECTED_ABORT', log_status);
          = pfc$volume_threshold_exceeded =
            osp$append_status_parameter (osc$status_parameter_delimiter, 'VOLUME THRESHOLD EXCEEDED',
                  log_status);
          ELSE
          CASEND;
          osp$log_executed_policy (log_status);
        IFEND;
        osp$log_executed_policy (initial_status);
      PROCEND report_move_status;

?? OLDTITLE ??

      VAR
        ch: 'A' .. 'Z',
        default_movement_statistics: pft$movement_statistics,
        dest_volume_count: integer,
        element_count: integer,
        evaluated_file_reference: fst$evaluated_file_reference,
        i: integer,
        j: integer,
        local_status: ost$status,
        log_status: ost$status,
        move_object_info_p: ^pft$move_object_info,
        number_of_volumes_in_set: integer,
        set_volume_list_p: ^pft$mo_volume_list,
        source_volume_count: integer,
        volume_list_p: ^pft$volume_list,
        volume_list_size: ost$positive_integers;

      catalog_moved := FALSE;

      default_movement_statistics.abnormal_status := 0;
      default_movement_statistics.bytes_moved := 0;
      default_movement_statistics.bytes_released := 0;
      default_movement_statistics.cycle_busy := 0;
      default_movement_statistics.cycles_released := 0;
      default_movement_statistics.insufficient_space := 0;
      default_movement_statistics.no_available_space := 0;
      default_movement_statistics.objects_moved := 0;
      default_movement_statistics.objects_not_moved := 0;
      default_movement_statistics.unrecovered_read_error := 0;

      PUSH move_object_info_p;

      FOR ch := 'A' TO 'Z' DO
        move_object_info_p^.class_statistics [ch] := default_movement_statistics;
      FOREND;

      move_object_info_p^.dest_volume_list_p := NIL;
      move_object_info_p^.mass_storage_class := $dmt$class [];
      move_object_info_p^.move_bytes_threshold := 0;
      move_object_info_p^.overall_statistics := default_movement_statistics;
      move_object_info_p^.perform_move := TRUE;
      move_object_info_p^.performance_statistics.catalog_count := 0;
      move_object_info_p^.performance_statistics.cycle_count := 0;
      move_object_info_p^.performance_statistics.file_count := 0;
      move_object_info_p^.release_mass_storage := pfc$never;
      move_object_info_p^.set_name := osc$null_name;
      move_object_info_p^.set_volume_list_p := NIL;
      move_object_info_p^.source_volume_list_p := NIL;
      move_object_info_p^.update_available_space_total := 0;
      move_object_info_p^.volume_overflow_allowed := TRUE;
      move_object_info_p^.wait := TRUE;

      pmp$get_compact_date_time (move_object_info_p^.performance_statistics.initial_date_time, local_status);
      IF local_status.normal THEN
        pmp$get_microsecond_clock (move_object_info_p^.performance_statistics.initial_microsecond_clock,
              local_status);
        IF local_status.normal THEN
          pmp$get_task_cp_time (move_object_info_p^.performance_statistics.initial_task_cp_time,
                local_status);
          IF local_status.normal THEN
            volume_list_size := 2 * UPPERVALUE (dmt$subfile_index) * #SIZE (pft$subfile);
            PUSH move_object_info_p^.move_status.volume_list_storage_p: [[REP volume_list_size OF cell]];
            RESET move_object_info_p^.move_status.volume_list_storage_p;
            move_object_info_p^.move_status.move_successful := FALSE;
            move_object_info_p^.move_status.new_subfile_list_p := NIL;
            move_object_info_p^.move_status.old_subfile_list_p := NIL;
            move_object_info_p^.move_status.reason_for_move_failure := pfc$unexpected_abort;
            move_object_info_p^.set_name := criteria.set_name;

            number_of_volumes_in_set := 10;
            REPEAT
              PUSH volume_list_p: [1 .. number_of_volumes_in_set];
              pfp$get_volumes_in_set (criteria.set_name, volume_list_p^, number_of_volumes_in_set,
                    local_status);
            UNTIL (NOT local_status.normal OR (number_of_volumes_in_set <= UPPERBOUND (volume_list_p^)));
            IF local_status.normal THEN
              PUSH move_object_info_p^.set_volume_list_p: [1 .. number_of_volumes_in_set];
              FOR i := 1 TO number_of_volumes_in_set DO
                move_object_info_p^.set_volume_list_p^ [i].recorded_vsn := volume_list_p^ [i];
              FOREND;
              set_volume_list_p := move_object_info_p^.set_volume_list_p;

              initialize_set_volume_list (move_object_info_p^.set_volume_list_p, local_status);
              IF local_status.normal THEN
                move_object_info_p^.mass_storage_class := $dmt$class [criteria.mass_storage_class];
              IFEND;

              move_object_info_p^.perform_move := TRUE;

              PUSH move_object_info_p^.source_volume_list_p: [1 .. 1];
              element_count := 0;

              FOR i := 1 TO UPPERBOUND (set_volume_list_p^) DO
                IF criteria.volume_list^ [1].recorded_vsn = set_volume_list_p^ [i].recorded_vsn THEN
                  element_count := element_count + 1;
                  move_object_info_p^.source_volume_list_p^ [element_count] := ^set_volume_list_p^ [i];
                  set_volume_list_p^ [i].volume_type := pfc$source_volume;
                IFEND;
              FOREND;

              move_object_info_p^.release_mass_storage := pfc$never;
              move_object_info_p^.volume_overflow_allowed := FALSE;
              move_object_info_p^.wait := FALSE;

              dest_volume_count := 0;
              FOR i := 1 TO number_of_volumes_in_set DO
                IF set_volume_list_p^ [i].available AND (set_volume_list_p^ [i].volume_type =
                      pfc$unspecified_volume) AND ((move_object_info_p^.mass_storage_class *
                      set_volume_list_p^ [i].ms_class) <> $dmt$class []) THEN
                  dest_volume_count := dest_volume_count + 1;
                IFEND;
              FOREND;
              IF dest_volume_count > 0 THEN
                PUSH move_object_info_p^.dest_volume_list_p: [1 .. dest_volume_count];
                j := 1;
                FOR i := 1 TO number_of_volumes_in_set DO
                  IF set_volume_list_p^ [i].available AND (set_volume_list_p^ [i].volume_type =
                        pfc$unspecified_volume) AND ((move_object_info_p^.mass_storage_class *
                        set_volume_list_p^ [i].ms_class) <> $dmt$class []) THEN
                    set_volume_list_p^ [i].volume_type := pfc$destination_volume;
                    move_object_info_p^.dest_volume_list_p^ [j] := ^set_volume_list_p^ [i];
                    j := j + 1;
                  IFEND;
                FOREND;
                pfp$r3_get_move_obj_device_info (move_object_info_p, local_status);
                IF local_status.normal THEN
                  pfp$r3_physically_move_catalog (path, move_object_info_p, local_status);
                  IF local_status.normal AND move_object_info_p^.move_status.move_successful THEN
                    catalog_moved := TRUE;
                    context.catalog_move_count := context.catalog_move_count + 1;
                  IFEND;
                  report_move_status(move_object_info_p^.move_status);
                IFEND;
              ELSEIF context.initial_call THEN
                osp$set_status_condition (ose$log_catalog_move_failure, log_status);
                report_context (log_status);
                osp$append_status_parameter (osc$status_parameter_delimiter, 'NO DESTINATION VOLUMES',
                      log_status);
                osp$log_executed_policy (log_status);
                osp$log_executed_policy (initial_status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

    PROCEND move_catalog;

?? OLDTITLE ??
?? NEWTITLE := '  report_context', EJECT ??

    PROCEDURE report_context
      (VAR log_status {input, output} : ost$status);

      VAR
        text: string (31);

      osp$append_status_file (osc$status_parameter_delimiter, criteria.file, log_status);

      CASE access_condition_entry.file_access_condition OF
      = fsc$catalog_media_missing =
        text := 'CATALOG_MEDIA_MISSING';
      = fsc$catalog_volume_unavailable =
        text := 'CATALOG_VOLUME_UNAVAILABLE';
      = fsc$cycle_busy =
        text := 'CYCLE_BUSY';
      = fsc$data_restoration_required =
        text := 'CYCLE_RESTORATION_REQUIRED';
      = fsc$data_retrieval_required =
        text := 'CYCLE_RETRIEVAL_REQUIRED';
      = fsc$file_server_inactive =
        text := 'FILE_SERVER_INACTIVE';
      = fsc$media_missing =
        text := 'MEDIA_MISSING';
      = fsc$space_unavailable =
        text := 'SPACE_UNAVAILABLE';
      = fsc$volume_unavailable =
        text := 'VOLUME_UNAVAILABLE';
      ELSE
        text := 'UNKNOWN CONDITION';
      CASEND;

      osp$append_status_parameter (osc$status_parameter_delimiter, text, log_status);

    PROCEND report_context;
?? OLDTITLE ??
?? NEWTITLE := '  report_ending_status', EJECT ??
    PROCEDURE report_ending_status;

      VAR
        log_status: ost$status;

      IF context.logging_allowed THEN
        osp$set_status_condition (ose$log_ending_status, log_status);
        osp$log_executed_policy (log_status);
        osp$log_executed_policy (context.condition_status);
      IFEND;

    PROCEND report_ending_status;
?? OLDTITLE ??
?? EJECT ??

    CONST
      max_volume_number = 500;

    VAR
      catalog_moved: boolean,
      entry_found: boolean,
      local_status: ost$status,
      mapped_status_variable: boolean,
      problematic_volume: rmt$recorded_vsn,
      sequence: ^SEQ ( * ),
      seq_size: ost$positive_integers,
      string1: string (1);

    #caller_id (caller_id);

    ring3_caller := FALSE;

    IF enforce_except_policies_active = TRUE  THEN
      osp$wait_on_condition (context.condition_status.condition);
      RETURN;
    ELSE
      {Recursion is only of concern in ring 3 or less
      IF caller_id.ring <= osc$tsrv_ring THEN
        ring3_caller := TRUE;
        enforce_except_policies_active := TRUE;
      IFEND;
    IFEND;
    #SPOIL (ring3_caller);
    #SPOIL (enforce_except_policies_active);
    osp$establish_block_exit_hndlr (^enforce_exit_handler);
    context.elapsed_wait_time := 0;

    initial_status := context.condition_status;

    osp$get_access_condition_entry (context.condition_status, access_condition_entry, entry_found);
    IF entry_found THEN
      mapped_status_variable := context.condition_status.condition <> initial_status.condition;
      osp$get_login_user_criteria (criteria, local_status);
      IF local_status.normal THEN
        seq_size := #SIZE (fst$goi_object_information) + fsc$max_path_size + #SIZE (fst$goi_object) +
              #SIZE (fst$device_information) + (max_volume_number *
              (#SIZE (rmt$volume_descriptor) + #SIZE (fst$file_access_condition)));
        PUSH sequence: [[REP seq_size OF cell]];

        actions := $ost$ecp_actions [];
        criteria.condition := access_condition_entry.file_access_condition;
        criteria.mass_storage_class := rmc$unspecified_file_class;
        criteria.volume_list := NIL;
        volume_condition_list := NIL;

        osp$get_file_criteria (context.file, context.catalog_object, {catalog_space_unavailable}
             (initial_status.condition = pfe$catalog_full), context.password, sequence, criteria,
              volume_condition_list, local_status);
        IF local_status.normal THEN
          IF (initial_status.condition = pfe$catalog_volume_unavailable) AND
                (volume_condition_list = NIL) AND (criteria.volume_list = NIL) THEN
            PUSH volume_condition_list: [1..1];
            volume_condition_list^ [1] := fsc$catalog_volume_unavailable;
            PUSH criteria.volume_list: [1..1];
            criteria.volume_list^ [1].recorded_vsn := initial_status.text.value (2, 6);
            criteria.volume_list^ [1].external_vsn := initial_status.text.value (2, 6);
          IFEND;

          get_applicable_policy (criteria, actions, applicable_poll_frequency);
          IF (actions = $ost$ecp_actions []) THEN
            IF jmp$system_job () THEN
              IF (context.condition_status.condition = pfe$cycle_busy) OR
                 (context.condition_status.condition = ame$space_unavailable) THEN
                actions := $ost$ecp_actions [osc$ecp_wait];
              ELSE
                actions := $ost$ecp_actions [];
                context.wait := FALSE;
              IFEND;
            ELSE
              actions := $ost$ecp_actions [osc$ecp_wait];
            IFEND;
          IFEND;

          {Wait is implied if the actions consist only of "enable release" options
          IF ((actions * $ost$ecp_actions [osc$ecp_enable_matching_image, osc$ecp_enable_nonmatch_image,
                  osc$ecp_set_damage_condition]) <> $ost$ecp_actions []) AND
             ((actions - $ost$ecp_actions [osc$ecp_enable_matching_image, osc$ecp_enable_nonmatch_image,
                  osc$ecp_set_damage_condition]) = $ost$ecp_actions []) THEN
            actions := actions + $ost$ecp_actions [osc$ecp_wait];
          IFEND;

          context.externalized_info.when_handler_status := TRUE;
          context.externalized_info.exception_status := context.condition_status;
          context.externalized_info.file_access_condition := access_condition_entry.
                file_access_condition;

          IF criteria.file <> osc$null_name THEN
            fsp$evaluate_file_reference (criteria.file, {command_file_reference_allowed} FALSE,
                  evaluated_file_reference, local_status);
            pf_path := NIL;
            IF local_status.normal THEN
              PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
              pfp$convert_fs_to_pft$path (evaluated_file_reference, pf_path^);
              clp$convert_cyc_ref_to_cyc_sel (evaluated_file_reference.cycle_reference, cycle_selector);
                context.externalized_info.object_name := pf_path^
                      [evaluated_file_reference.number_of_path_elements];
            ELSE
              actions := actions * $ost$ecp_actions [osc$ecp_exit, osc$ecp_wait];
              IF actions = $ost$ecp_actions [] THEN
                actions := $ost$ecp_actions [osc$ecp_wait];
              IFEND;
            IFEND;
          ELSE
            actions := actions * $ost$ecp_actions [osc$ecp_exit, osc$ecp_wait];
            IF actions = $ost$ecp_actions [] THEN
              actions := $ost$ecp_actions [osc$ecp_wait];
            IFEND;
          IFEND;

          IF context.file.selector = osc$ecp_file_segment THEN
            context.externalized_info.file_segment_isolated := TRUE;
            context.externalized_info.file_segment := #SEGMENT (context.file.file_segment);
          IFEND;

          IF context.force_wait THEN
            actions := $ost$ecp_actions [osc$ecp_wait];
          IFEND;

          IF (initial_status.condition = pfe$catalog_full) AND (context.catalog_move_count <
                osc$ecp_max_catalog_moves) AND (criteria.volume_list <> NIL) THEN
            move_catalog (pf_path^, criteria, catalog_moved);
            IF NOT catalog_moved THEN
              execute_exception_policy;
            IFEND;
          ELSE
            execute_exception_policy;
          IFEND;

          IF osp$file_access_condition (context.condition_status) THEN

            CASE access_condition_entry.file_access_condition OF
            = fsc$catalog_media_missing, fsc$catalog_volume_unavailable =
              find_problematic_volume (volume_condition_list, criteria.volume_list, problematic_volume);
              osp$set_status_condition (context.condition_status.condition, local_status);
              osp$append_status_parameter (osc$status_parameter_delimiter, problematic_volume, local_status);
              context.condition_status := local_status;
            = fsc$media_missing, fsc$volume_unavailable =
              find_problematic_volume (volume_condition_list, criteria.volume_list, problematic_volume);
              osp$set_status_condition (context.condition_status.condition, local_status);
              osp$append_status_file (osc$status_parameter_delimiter, criteria.file, local_status);
              osp$append_status_parameter (osc$status_parameter_delimiter, problematic_volume, local_status);
              context.condition_status := local_status;
            = fsc$space_unavailable =
              osp$set_status_condition (context.condition_status.condition, local_status);
              osp$append_status_file (osc$status_parameter_delimiter, criteria.file, local_status);
              #UNCHECKED_CONVERSION (criteria.mass_storage_class, string1);
              IF criteria.mass_storage_class = rmc$unspecified_file_class THEN
                osp$append_status_parameter (osc$status_parameter_delimiter, '?', local_status);
              ELSE
                osp$append_status_parameter (osc$status_parameter_delimiter, string1, local_status);
              IFEND;
              context.condition_status := local_status;
            ELSE
            CASEND;
          IFEND;
        ELSE
          context.wait := FALSE;
        IFEND;
      ELSE
        context.wait := FALSE;
      IFEND;
      IF context.initial_call AND (mapped_status_variable OR (initial_status.text <>
            context.condition_status.text)) THEN
        report_ending_status;
      IFEND;
    ELSE
      context.wait := FALSE;
    IFEND;

    context.initial_call := FALSE;

  PROCEND osp$enforce_exception_policies;
?? OLDTITLE ??
?? NEWTITLE := '  get_applicable_policy', EJECT ??

  PROCEDURE get_applicable_policy
    (    criteria: ost$ecp_criteria;
     VAR applicable_actions: ost$ecp_actions;
     VAR polling_frequency: ost$ecp_polling_frequency);

    CONST
      one_second = 1000;

    VAR
      status: ost$status;

    status.normal := TRUE;

    REPEAT
      osp$r3_get_applicable_policy (criteria, applicable_actions, polling_frequency, status);
      IF (NOT status.normal) AND (status.condition = ose$exception_policies_locked) THEN
        pmp$wait (one_second, one_second);
      IFEND;
    UNTIL status.normal OR (status.condition <> ose$exception_policies_locked);

  PROCEND get_applicable_policy;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$format_wait_message', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$format_wait_message
    (    access_condition_entry: ^fst$access_condition_entry;
         file: ^fst$file_reference;
         mass_storage_class: rmt$mass_storage_class;
         volume_condition_list: ^fst$volume_condition_list;
         volume_list: ^rmt$volume_list;
     VAR wait_message: oft$display_message);

    CONST
      waiting_for = ' Waiting for';

    VAR
      local_status: ost$status,
      message_container: ost$status_message,
      message_container_ptr: ^ost$status_message,
      message_line: ^ost$status_message_line,
      message_line_count: ^ost$status_message_line_count,
      message_line_index: 1 .. osc$max_status_message_lines,
      message_line_size: ^ost$status_message_line_size,
      message_module: pmt$program_name,
      message_parameters: array [1 .. 1] of ^ost$message_parameter,
      message_template: ^ost$message_template,
      module_index: 1 .. osc$max_system_message_modules,
      problematic_volume: rmt$recorded_vsn,
      relevant_path_size: fst$path_size,
      string1: string (1),
      wait_message_name: clt$parameter_name;

    message_line_size := NIL;
    message_line := NIL;
    message_parameters [1] := NIL;

    IF access_condition_entry = NIL THEN
      wait_message_name := fsc$wait_undefined_condition;
    ELSE
      wait_message_name := access_condition_entry^.wait_message_name;
      CASE access_condition_entry^.file_access_condition OF
      = fsc$catalog_media_missing, fsc$catalog_volume_unavailable, fsc$media_missing, fsc$volume_unavailable =
        find_problematic_volume (volume_condition_list, volume_list, problematic_volume);
        message_parameters [1] := ^problematic_volume (1, clp$trimmed_string_size (problematic_volume));
      = fsc$space_unavailable =
        message_parameters [1] := ^string1;
        IF mass_storage_class = rmc$unspecified_file_class THEN
          string1 := '?';
        ELSE
          #UNCHECKED_CONVERSION (mass_storage_class, string1);
        IFEND;
      ELSE
      CASEND;
    IFEND;

{ Search table of system message modules defined in osm$message_module_pointers }
  /LOOP/
    FOR module_index := 1 TO osc$max_system_message_modules DO
      IF fsc$wait_msg_module_name = osv$system_message_modules [module_index].module_name THEN
        osp$find_parameter_prompt (osv$system_message_modules [module_index].module_pointer_p^,
              wait_message_name, message_template, local_status);
        IF local_status.normal THEN
          osp$format_help_message (message_template, ^message_parameters, osc$max_status_message_line,
                message_container, local_status);
          IF local_status.normal THEN
            message_container_ptr := ^message_container;
            RESET message_container_ptr;
            NEXT message_line_count IN message_container_ptr;

            IF message_line_count^ > 0 THEN
              NEXT message_line_size IN message_container_ptr;
              NEXT message_line: [message_line_size^] IN message_container_ptr;
              message_line_size^ := clp$trimmed_string_size (message_line^);
            IFEND;
          IFEND;
        IFEND;
        EXIT /loop/;
      IFEND;
    FOREND;

    IF message_line_size = NIL THEN
      PUSH message_line_size;
      message_line_size^ := STRLENGTH (waiting_for);
      PUSH message_line: [message_line_size^];
      message_line^ := waiting_for;
    IFEND;

    {Formatted messages have leading SPACE character which is not useful, so start at column 2
    wait_message.text := message_line^ (2, message_line_size^ - 1);
    wait_message.size := clp$trimmed_string_size (wait_message.text);

    IF file <> NIL THEN
      osp$get_relevant_path_string (file^, wait_message.text (wait_message.size + 2, * ), relevant_path_size);
      wait_message.size := wait_message.size + relevant_path_size + 1;
    IFEND;

  PROCEND osp$format_wait_message;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$get_relevant_path_string', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_relevant_path_string
    (    path: fst$file_reference;
     VAR relevant_path: fst$file_reference;
     VAR relevant_path_size: fst$path_size);

?? NEWTITLE := 'get_relevant_substring', EJECT ??

    PROCEDURE get_relevant_substring
      (    path: fst$file_reference;
       VAR relevant_path: fst$file_reference;
       VAR relevant_path_size: fst$path_size);

      CONST
        ellipsis = ' .. ';

      VAR
        constraint: fst$path_size,
        i: integer,
        index: integer,
        j: ost$positive_integers,
        local_path_size: fst$path_size,
        path_index: 0 .. (fsc$max_path_size + 1),
        path_parts: ^array [1 .. (fsc$max_path_size DIV 2)] of integer,
        result: boolean,
        select: ^packed array [0 .. 255] of 0 .. 1;

      constraint := STRLENGTH (relevant_path);
      path_size := STRLENGTH (path);

      IF path_size > constraint THEN
        PUSH path_parts;
        PUSH select;

        FOR i := 0 TO 255 DO
          select^ [i] := 0;
        FOREND;
        select^ [$INTEGER ('.')] := 1; {Scan for period only}

        i := 0;
        path_index := 0;

        REPEAT
          i := i + 1;
          #SCAN (select^, path (path_index + 1, path_size - path_index), index, result);
          path_index := path_index + index;
          path_parts^ [i] := path_index;
        UNTIL NOT result;

        IF i > 1 THEN
          IF constraint >= (path_parts^ [2] - 1) THEN
            {Full family/user path fits
            relevant_path_size := path_parts^ [2] - 1;
            relevant_path := path (1, relevant_path_size);

            IF (i >= 2) AND ((constraint - path_parts^ [2] + 1) >= STRLENGTH (ellipsis)) THEN
              relevant_path (path_parts^ [2], STRLENGTH (ellipsis)) := ellipsis;
              relevant_path_size := relevant_path_size + STRLENGTH (ellipsis);

              IF (i > 2) AND ((constraint - relevant_path_size) > 0) THEN
                {get as many full path parts from the rightmost part of the path as will fit
                FOR j := 3 TO i - 1 DO
                  IF (path_parts^ [i] - path_parts^ [j]) <= (constraint - relevant_path_size) THEN
                    relevant_path (relevant_path_size + 1, * ) := path (path_parts^ [j], * );
                    relevant_path_size := relevant_path_size + (path_parts^ [i] - path_parts^ [j]);
                    RETURN;
                  IFEND;
                FOREND;
              IFEND;
            IFEND;
          ELSE {Not enough room for full FAMILY/USER path}
            relevant_path := path;
            relevant_path_size := constraint;
          IFEND;
        ELSE {only a family path provided}
          relevant_path := path;
          relevant_path_size := constraint;
        IFEND;
      ELSE {path fits in string provided}
        relevant_path (1, constraint) := path;
        relevant_path_size := path_size;
      IFEND;
    PROCEND get_relevant_substring;
?? OLDTITLE ??
?? EJECT ??

    VAR
      ignore_path_size: fst$path_size,
      local_status: ost$status,
      path_size: fst$path_size;

    path_size := clp$trimmed_string_size (path);

    IF path_size > STRLENGTH (relevant_path) THEN
      get_relevant_substring (path (1, path_size), relevant_path, relevant_path_size);
    ELSE
      relevant_path (1, * ) := path (1, path_size);
      relevant_path_size := path_size;
    IFEND;

  PROCEND osp$get_relevant_path_string;
?? OLDTITLE ??
?? NEWTITLE := 'find_problematic_volume', EJECT ??

  PROCEDURE find_problematic_volume
    (    volume_condition_list: ^fst$volume_condition_list;
         volume_list: ^rmt$volume_list;
     VAR problematic_volume: rmt$recorded_vsn);

  VAR
    i: ost$positive_integers;

    problematic_volume := rmc$unspecified_vsn;

    IF (volume_condition_list <> NIL) AND (volume_list <> NIL) THEN

      FOR i := LOWERBOUND (volume_condition_list^) TO UPPERBOUND (volume_condition_list^) DO
        IF (volume_condition_list^ [i] IN $fst$file_access_conditions
              [fsc$catalog_media_missing, fsc$catalog_volume_unavailable, fsc$media_missing,
              fsc$volume_unavailable]) THEN
          problematic_volume := volume_list^ [i].recorded_vsn;
          RETURN;
        IFEND;
      FOREND;
    IFEND;

  PROCEND find_problematic_volume;
?? OLDTITLE ??
MODEND osm$disk_fault_tolerance_2dd;
*DECK DECK=OSM$DISV$US_ENGLISH EXPAND=TRUE
*DECK DECK=OSM$EMIT_OS_STATISTICS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Statistics : Emit Periodic Statistics' ??
MODULE osm$emit_os_statistics;

{ PURPOSE:
{         This module emits statistics to the global statistics log.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmt$dispatching_priority
*copyc jmt$job_class
*copyc mmt$page_frame_queue_id
*copyc mmt$page_pull_status
*copyc nac$statistics_codes
*copyc nlt$device_count
*copyc ofe$error_codes
*copyc osc$statistics
*copyc osc$processor_defined_registers
*copyc oss$task_private
*copyc oss$task_shared
*copyc ost$data_id
*copyc ost$emission_sets
*copyc ost$job_and_memory_stats
*copyc ost$paging_and_mtr_stats
?? POP ??
*copyc avp$configuration_administrator
*copyc avp$system_displays
*copyc clp$trimmed_string_size
*copyc nap$get_intranet_statistics
*copyc nap$get_namve_statistics
*copyc nap$get_osi_device_spec_stats
*copyc nap$get_osi_statistics
*copyc osp$copy_local_status_to_status
*copyc osp$get_aging_stats
*copyc osp$get_cpu_stats
*copyc osp$get_disk_space_stats
*copyc osp$get_jm_mm_stats
*copyc osp$get_job_class_stats
*copyc osp$get_job_stats
*copyc osp$get_mtr_stats
*copyc osp$get_page_stats
*copyc osp$get_paging_stats
*copyc osp$get_pio_pp_stats
*copyc osp$get_pio_unit_stats
*copyc osp$get_pp_unit_count
*copyc osp$get_service_class_stats
*copyc osp$get_swap_stats
*copyc osp$fetch_system_constant
*copyc osp$emit_os_statistics_r1
*copyc osp$read_emission_sets_r1
*copyc osp$release_manps_lock_r1
*copyc osp$reserve_manps_lock_r1
*copyc osp$set_status_abnormal
*copyc pmp$collect_raw_task_statistics
*copyc osp$write_emission_sets_r1
*copyc pmp$log
*copyc pmp$zero_out_table
*copyc sfp$emit_statistic
*copyc jmv$job_class_table_p
*copyc jmv$max_service_class_in_use
*copyc jmv$maximum_job_class_in_use
*copyc jmv$service_classes
*copyc nav$global_osi_statistics
*copyc nav$global_statistics
*copyc nav$namve_active
*copyc nav$statistics_enabled
*copyc osv$monitor_interlock_wait_time
*copyc osv$task_private_heap
*copyc osv$task_shared_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by this Module', EJECT ??

  VAR
    previous_cycle_time: [oss$task_shared] integer := 0,
    previous_wait_time: [oss$task_shared] integer := 0,
    previous_delay_time: [oss$task_shared] integer := 0,
    previous_write_mod_pages_time: [oss$task_shared] integer := 0,
    previous_cycle_count: [oss$task_shared] 0 .. 0ffffffff(16) := 0,
    previous_wait_count: [oss$task_shared] 0 .. 0ffffffff(16) := 0,
    previous_delay_count: [oss$task_shared] 0 .. 0ffffffff(16) := 0,
    previous_write_mod_pages_count: [oss$task_shared] 0 .. 0ffffffff(16) := 0;

  VAR
    intranet_statistic_p: [oss$task_private] ^ost$intranet_statistics := NIL,
    namve_statistic_p: [oss$task_private] ^ost$namve_statistics := NIL,
    osi_device_specific_statistic_p: [oss$task_private] ^ost$channel_device_statistics := NIL,
    osi_statistic_p: [oss$task_private] ^ost$namve_osi_statistics := NIL;

  VAR
    aborted_condition: [oss$task_shared] integer := 0;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$read_emission_sets', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to obtain a copy of the emission sets.

  PROCEDURE [XDCL, #GATE] osp$read_emission_sets
    (VAR emission_sets: array [ost$emission_set_names] of ost$emission_set;
     VAR status: ost$status);

    VAR
      emission_sets_copy: array [ost$emission_set_names] of ost$emission_set,
      local_status: ost$status;

    IF NOT (avp$configuration_administrator () OR avp$system_displays ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration or system_displays',
            status);
      RETURN;
    IFEND;
    osp$read_emission_sets_r1 (emission_sets_copy, local_status);
    osp$copy_local_status_to_status (local_status, status);
    emission_sets := emission_sets_copy;

  PROCEND osp$read_emission_sets;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$release_manps_lock', EJECT ??

{ PURPOSE:
{   The purpose of this request is to release the osv$manps_user_lock if
{   it is held by the calling task.

  PROCEDURE [XDCL, #GATE] osp$release_manps_lock;

    osp$release_manps_lock_r1;

  PROCEND osp$release_manps_lock;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$reserve_manps_lock', EJECT ??

{ PURPOSE:
{   The purpose of this request is to reserve the osv$manps_user_lock for
{   the calling task.

  PROCEDURE [XDCL, #GATE] osp$reserve_manps_lock
    (VAR status: ost$status);

    VAR
      local_status: ost$status;

    status.normal := TRUE;

    IF NOT (avp$configuration_administrator () ) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration',status);
      RETURN;
    IFEND;

    osp$reserve_manps_lock_r1 (local_status);
    osp$copy_local_status_to_status(local_status, status);

  PROCEND osp$reserve_manps_lock;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$write_emission_sets' , EJECT ??

{ PURPOSE:
{   This purpose of this procedure is to write the emission sets.  The calling
{   task must hold the manps_user_lock.

  PROCEDURE [XDCL, #GATE] osp$write_emission_sets
    (    emission_sets: array [ost$emission_set_names] of ost$emission_set;
     VAR status: ost$status);

    VAR
      emission_sets_copy: array [ost$emission_set_names] of ost$emission_set,
      local_status: ost$status;

    status.normal := TRUE;

    emission_sets_copy := emission_sets;
    osp$write_emission_sets_r1 (emission_sets_copy, local_status);
    osp$copy_local_status_to_status (local_status, status);

  PROCEND osp$write_emission_sets;
?? OLDTITLE ??
?? NEWTITLE := 'Statistic emitting procedures' ??
?? NEWTITLE := 'emit_job_and_memory_stats' ??
?? NEWTITLE := 'OS0' , EJECT ??

  PROCEDURE emit_job_and_memory_stats
    (VAR jm_mm_stats_ptr: ^ost$jm_mm_stats;
     VAR status: ost$status);

    VAR
      sum_shared: integer,
      i: 0 .. 255,
      siteq_active: 0 .. 255,
      count_p: ^ost$job_and_memory_stats;

    status.normal := TRUE;

    IF jm_mm_stats_ptr = NIL THEN
      ALLOCATE jm_mm_stats_ptr IN osv$task_private_heap^;
      osp$get_jm_mm_stats (FALSE, jm_mm_stats_ptr^, status);
      IF NOT status.normal THEN
        FREE jm_mm_stats_ptr IN osv$task_private_heap^;
        RETURN;
      IFEND;
    IFEND;

    sum_shared := 0;
    siteq_active := jm_mm_stats_ptr^.jm_mm_stats.page_q_counts.site_defined_queues_active;
    PUSH count_p: [1 .. osc$jms_shared_last_sys + siteq_active];
    IF siteq_active > 0 THEN
      FOR i := 0 TO siteq_active - 1 DO
        sum_shared := sum_shared + jm_mm_stats_ptr^.jm_mm_stats.page_q_counts.
              q_counts [i + mmc$pq_shared_first_site];
        count_p^ [osc$jms_shared_first_site + i] := jm_mm_stats_ptr^.jm_mm_stats.page_q_counts.
              q_counts [i + mmc$pq_shared_first_site];
      FOREND;
    IFEND;
    count_p^ [osc$jms_free_pages] := jm_mm_stats_ptr^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_free];
    count_p^ [osc$jms_available_pages] := jm_mm_stats_ptr^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_avail];
    count_p^ [osc$jms_avail_mod_pages] := jm_mm_stats_ptr^.jm_mm_stats.page_q_counts.
          q_counts [mmc$pq_avail_modified];
    count_p^ [osc$jms_wired_pages] := jm_mm_stats_ptr^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_wired];
    FOR i := 0 TO (osc$jms_shared_last_sys - osc$jms_shared_first) DO
      sum_shared := sum_shared + jm_mm_stats_ptr^.jm_mm_stats.page_q_counts.
            q_counts [i + mmc$pq_shared_first];
      count_p^ [osc$jms_shared_first + i] := jm_mm_stats_ptr^.jm_mm_stats.page_q_counts.
            q_counts [i + mmc$pq_shared_first];
    FOREND;
    count_p^ [osc$jms_shared_pages] := sum_shared;
    count_p^ [osc$jms_fixed_pages] := jm_mm_stats_ptr^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_job_fixed];
    count_p^ [osc$jms_io_error_pages] := jm_mm_stats_ptr^.jm_mm_stats.page_q_counts.
          q_counts [mmc$pq_job_io_error] + jm_mm_stats_ptr^.jm_mm_stats.page_q_counts.
          q_counts [mmc$pq_shared_io_error] + jm_mm_stats_ptr^.jm_mm_stats.page_q_counts.
          q_counts [mmc$pq_swapped_io_error] + jm_mm_stats_ptr^.jm_mm_stats.page_q_counts.
          q_counts [mmc$pq_flawed];
    count_p^ [osc$jms_job_working_set_pages] := jm_mm_stats_ptr^.jm_mm_stats.page_q_counts.
          q_counts [mmc$pq_job_working_set];
    count_p^ [osc$jms_swapped_jobs] := jm_mm_stats_ptr^.jm_mm_stats.total_swapped_jobs;
    count_p^ [osc$jms_ready_tasks] := jm_mm_stats_ptr^.jm_mm_stats.total_ready_tasks;
    count_p^ [osc$jms_total_interactive_jobs] := jm_mm_stats_ptr^.jm_mm_stats.total_interactive_jobs;
    count_p^ [osc$jms_tot_noninteractive_jobs] := jm_mm_stats_ptr^.jm_mm_stats.total_non_interactive_jobs;

    sfp$emit_statistic (osc$job_and_memory_stats, '', count_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND emit_job_and_memory_stats;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_paging_and_mtr_stats' ??
?? NEWTITLE := 'OS1' , EJECT ??

  PROCEDURE emit_paging_and_mtr_stats
    (VAR page_fault_stats_ptr: ^ost$page_fault_stats;
     VAR server_page_fault_stats_ptr: ^ost$page_fault_stats;
     VAR aging_stats_ptr: ^ost$aging_stats;
     VAR mtr_reqs_ptr: ^ost$mtr_stats;
     VAR paging_stats_ptr: ^ost$paging_stats;
     VAR status: ost$status);

    VAR
      allocate_pf_ptr: boolean,
      allocate_ps_ptr: boolean,
      allocate_server_pf_ptr: boolean,
      counters: ost$paging_and_mtr_stats,
      cycle_count,
      delay_count,
      wait_count,
      mod_page_count: integer;

    status.normal := TRUE;
    allocate_pf_ptr := FALSE;
    allocate_ps_ptr := FALSE;
    allocate_server_pf_ptr := FALSE;

    IF page_fault_stats_ptr = NIL THEN
      allocate_pf_ptr := TRUE;
      ALLOCATE page_fault_stats_ptr IN osv$task_private_heap^;
    IFEND;
    IF server_page_fault_stats_ptr = NIL THEN
      allocate_server_pf_ptr := TRUE;
      ALLOCATE server_page_fault_stats_ptr IN osv$task_private_heap^;
    IFEND;
    osp$get_page_stats (FALSE, page_fault_stats_ptr^, server_page_fault_stats_ptr^, status);
    IF NOT status.normal THEN
      IF allocate_pf_ptr THEN
        FREE page_fault_stats_ptr IN osv$task_private_heap^;
      IFEND;
      IF allocate_server_pf_ptr THEN
        FREE server_page_fault_stats_ptr IN osv$task_private_heap^;
      IFEND;
      RETURN;
    IFEND;

    IF paging_stats_ptr = NIL THEN
      allocate_ps_ptr := TRUE;
      ALLOCATE paging_stats_ptr IN osv$task_private_heap^;
    IFEND;
    osp$get_paging_stats (FALSE, paging_stats_ptr^, status);
    IF NOT status.normal THEN
      IF allocate_ps_ptr THEN
        FREE paging_stats_ptr IN osv$task_private_heap^;
      IFEND;
      RETURN;
    IFEND;

    IF mtr_reqs_ptr = NIL THEN
      ALLOCATE mtr_reqs_ptr IN osv$task_private_heap^;
      osp$get_mtr_stats (FALSE, mtr_reqs_ptr^, status);
      IF NOT status.normal THEN
        FREE mtr_reqs_ptr IN osv$task_private_heap^;
        RETURN;
      IFEND;
    IFEND;
    IF aging_stats_ptr = NIL THEN
      ALLOCATE aging_stats_ptr IN osv$task_private_heap^;
      osp$get_aging_stats (FALSE, aging_stats_ptr^, status);
      IF NOT status.normal THEN
        FREE aging_stats_ptr IN osv$task_private_heap^;
        RETURN;
      IFEND;
    IFEND;

{ Currently, SERVER page_fault statistics are not kept/emitted (server_page_fault_stats_ptr).

    counters [osc$pms_pf_avail] := page_fault_stats_ptr^.pf_stats [$INTEGER (ps_found_in_avail)];
    counters [osc$pms_pf_avail_mod] := page_fault_stats_ptr^.pf_stats [$INTEGER (ps_found_in_avail_modified)];
    counters [osc$pms_pf_disk_read] := page_fault_stats_ptr^.pf_stats [$INTEGER (ps_found_on_disk)];
    counters [osc$pms_pf_new_page] := page_fault_stats_ptr^.pf_stats [$INTEGER (ps_new_page_assigned)];
    counters [osc$pms_pf_locked] := page_fault_stats_ptr^.pf_stats [$INTEGER (ps_locked)];
    counters [osc$pms_pf_io_reject] := page_fault_stats_ptr^.pf_stats [$INTEGER (ps_io_temp_reject)];

    counters [osc$pms_force_aggr_aging] := aging_stats_ptr^.aging_stats.force_aggressive_aging;
    counters [osc$pms_aggr_age_shared_q] := aging_stats_ptr^.aging_stats.aggressive_age_shared_queue;
    counters [osc$pms_aggr_age_job_q] := aging_stats_ptr^.aging_stats.aggressive_age_job_queues;
    counters [osc$pms_aggr_age_failed] := aging_stats_ptr^.aging_stats.aggressive_aging_failed;
    counters [osc$pms_write_aged_page] := aging_stats_ptr^.aging_stats.page_written_to_disk;

    counters [osc$pms_mr_cycle] := mtr_reqs_ptr^.mtr_reqs [syc$rc_cycle].count;
    cycle_count := mtr_reqs_ptr^.mtr_reqs [syc$rc_cycle].count - previous_cycle_count;
    IF cycle_count = 0 THEN
      counters [osc$pms_mr_cycle_aver_duration] := 0;
    ELSE
      counters [osc$pms_mr_cycle_aver_duration] := (mtr_reqs_ptr^.mtr_reqs [syc$rc_cycle].total_cpu_time -
            previous_cycle_time) DIV (cycle_count);
    IFEND;
    previous_cycle_time := mtr_reqs_ptr^.mtr_reqs [syc$rc_cycle].total_cpu_time;
    previous_cycle_count := mtr_reqs_ptr^.mtr_reqs [syc$rc_cycle].count;
    counters [osc$pms_mr_delay] := mtr_reqs_ptr^.mtr_reqs [syc$rc_delay].count;
    delay_count := mtr_reqs_ptr^.mtr_reqs [syc$rc_delay].count - previous_delay_count;
    IF delay_count = 0 THEN
      counters [osc$pms_mr_delay_aver_duration] := 0;
    ELSE
      counters [osc$pms_mr_delay_aver_duration] := (mtr_reqs_ptr^.mtr_reqs [syc$rc_delay].total_cpu_time -
            previous_delay_time) DIV (delay_count);
    IFEND;
    previous_delay_time := mtr_reqs_ptr^.mtr_reqs [syc$rc_delay].total_cpu_time;
    previous_delay_count := mtr_reqs_ptr^.mtr_reqs [syc$rc_delay].count;
    counters [osc$pms_mr_wait] := mtr_reqs_ptr^.mtr_reqs [syc$rc_wait].count;
    wait_count := mtr_reqs_ptr^.mtr_reqs [syc$rc_wait].count - previous_wait_count;
    IF wait_count = 0 THEN
      counters [osc$pms_mr_wait_aver_duration] := 0;
    ELSE
      counters [osc$pms_mr_wait_aver_duration] := (mtr_reqs_ptr^.mtr_reqs [syc$rc_wait].total_cpu_time -
            previous_wait_time) DIV (wait_count);
    IFEND;
    previous_wait_time := mtr_reqs_ptr^.mtr_reqs [syc$rc_wait].total_cpu_time;
    previous_wait_count := mtr_reqs_ptr^.mtr_reqs [syc$rc_wait].count;
    counters [osc$pms_mr_write_mod_pages] := mtr_reqs_ptr^.mtr_reqs [syc$rc_write_modified_pages].count;
    mod_page_count := mtr_reqs_ptr^.mtr_reqs [syc$rc_write_modified_pages].count -
          previous_write_mod_pages_count;
    IF mod_page_count = 0 THEN
      counters [osc$pms_mr_wmp_aver_duration] := 0;
    ELSE
      counters [osc$pms_mr_wmp_aver_duration] := (mtr_reqs_ptr^.mtr_reqs [syc$rc_write_modified_pages].
            total_cpu_time - previous_write_mod_pages_time) DIV (mod_page_count);

    IFEND;
    previous_write_mod_pages_time := mtr_reqs_ptr^.mtr_reqs [syc$rc_write_modified_pages].total_cpu_time;
    previous_write_mod_pages_count := mtr_reqs_ptr^.mtr_reqs [syc$rc_write_modified_pages].count;

    counters [osc$pms_ps_prestream_initiated] := paging_stats_ptr^.p_stats.page_streaming.prestream_only +
          paging_stats_ptr^.p_stats.page_streaming.initiated;
    counters [osc$pms_ps_initiated] := paging_stats_ptr^.p_stats.page_streaming.initiated;
    counters [osc$pms_ps_prestream_only] := paging_stats_ptr^.p_stats.page_streaming.prestream_only;
    counters [osc$pms_ps_terminated] := paging_stats_ptr^.p_stats.page_streaming.terminated;
    counters [osc$pms_ps_pages_prestream] := paging_stats_ptr^.p_stats.page_streaming.pages_prestream;
    counters [osc$pms_ps_pages_streaming] := paging_stats_ptr^.p_stats.page_streaming.pages_streaming;
    counters [osc$pms_ps_task_slow] := paging_stats_ptr^.p_stats.page_streaming.task_slow;
    counters [osc$pms_ps_pages_faults_tu] := paging_stats_ptr^.p_stats.page_streaming.page_faults_tu;
    counters [osc$pms_ps_pages_freed_behind] := paging_stats_ptr^.p_stats.page_streaming.pages_freed_behind;
    counters [osc$pms_ps_random_faults] := paging_stats_ptr^.p_stats.page_streaming.random_faults;

    sfp$emit_statistic (osc$paging_and_mtr_stats, '', ^counters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND emit_paging_and_mtr_stats;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_pio_statistics' ??
?? NEWTITLE := 'OS2,OS3,OS4,OS5' , EJECT ??

  PROCEDURE emit_pio_statistics
    (    stat_entry: ost$stat_entry;
     VAR pio_pp_stats_p: ^ost$disk_pp_stats;
     VAR pio_unit_stats_p: ^ost$disk_unit_stats;
     VAR pio_disk_space_stats_p: ^ost$disk_space_stats;
     VAR status: ost$status);

    VAR
      disk_space_counters: array [1 .. 1] of integer,
      disk_space_descriptive_data: string (6),
      path_descriptive_data: string (19),
      path_stats_counters: array [1 .. 9] of integer,
      pp_descriptive_data: string (8),
      pp_stats_counters: array [1 .. 6] of integer,
      unit_stats_counters: array [1 .. 24] of integer,
      unit_descriptive_data: string (14);

    VAR
      concurrent_channel: string (1),
      controller_type: string (5),
      equip_index: integer,
      length: integer,
      loop_end: integer,
      loop_start: integer,
      path_usage_record: iot$path_usage,
      port: string (1),
      port_index: integer,
      pp_count: integer,
      pp_index: integer,
      unit_count: integer,
      unit_index: integer,
      unit_type: string (7);

    status.normal := TRUE;

    osp$get_pp_unit_count (pp_count, unit_count, status);
    IF (pp_count = 0) OR (unit_count = 0) THEN
      status.normal := FALSE;
      RETURN;
    IFEND;

    CASE stat_entry.stat OF

    = osc$io_pp_usage, osc$io_path_usage =

      IF pio_pp_stats_p = NIL THEN
        ALLOCATE pio_pp_stats_p: [1 .. pp_count] IN osv$task_private_heap^;
        osp$get_pio_pp_stats (FALSE, pio_pp_stats_p^, status);
        IF NOT status.normal THEN
          FREE pio_pp_stats_p IN osv$task_private_heap^;
          RETURN;
        IFEND;
      IFEND;

      IF stat_entry.first_index <> osc$all_stats THEN
        loop_start := stat_entry.first_index;
        loop_end := stat_entry.second_index;
      ELSE
        loop_start := 1;
        loop_end := pp_count;
      IFEND;

    /pp_loop/
      FOR pp_index := loop_start TO loop_end DO
        IF pio_pp_stats_p^.disk_pp_stats [pp_index].channel.concurrent THEN
          concurrent_channel := '1'
        ELSE
          concurrent_channel := '0'
        IFEND;
        IF stat_entry.stat = osc$io_pp_usage THEN
          pp_stats_counters [1] := pio_pp_stats_p^.disk_pp_stats [pp_index].computed_data_transfer_time;
          pp_stats_counters [2] := pio_pp_stats_p^.disk_pp_stats [pp_index].seek_and_latency_time;
          pp_stats_counters [3] := pio_pp_stats_p^.disk_pp_stats [pp_index].streamed_req_count_read;
          pp_stats_counters [4] := pio_pp_stats_p^.disk_pp_stats [pp_index].streamed_req_failed_count_read;
          pp_stats_counters [5] := pio_pp_stats_p^.disk_pp_stats [pp_index].streamed_req_count_write;
          pp_stats_counters [6] := pio_pp_stats_p^.disk_pp_stats [pp_index].streamed_req_failed_count_write;
          pp_descriptive_data := '';
          STRINGREP (pp_descriptive_data, length, pio_pp_stats_p^.disk_pp_stats [pp_index].iou_number: 2, ',',
                concurrent_channel: 1, ',', pio_pp_stats_p^.disk_pp_stats [pp_index].channel.number: 3);
          sfp$emit_statistic (osc$io_pp_usage, pp_descriptive_data (2, * ), ^pp_stats_counters, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        IF stat_entry.stat = osc$io_path_usage THEN

        /port_loop/
          FOR port_index := 0 TO 1 DO
            IF pio_pp_stats_p^.disk_pp_stats [pp_index].channel.concurrent THEN
              IF pio_pp_stats_p^.disk_pp_stats [pp_index].channel.port = cmc$unspecified_port THEN
                port := 'U';
              ELSE
                IF port_index = 0 THEN
                  port := 'A';
                ELSE
                  port := 'B';
                IFEND;
              IFEND;
            ELSE
              port := 'N';
            IFEND;

          /equipment_loop/
            FOR equip_index := 0 TO 7 DO
              IF pio_pp_stats_p^.disk_pp_stats [pp_index].path_usage [port_index] [equip_index].path_used THEN
                path_usage_record := pio_pp_stats_p^.disk_pp_stats [pp_index].path_usage [port_index]
                      [equip_index];
                path_stats_counters [1] := path_usage_record.read_requests;
                path_stats_counters [2] := path_usage_record.read_maus * path_usage_record.bytes_per_mau;
                path_stats_counters [3] := path_usage_record.write_requests;
                path_stats_counters [4] := path_usage_record.written_and_preset_maus *
                      path_usage_record.bytes_per_mau;
                path_stats_counters [5] := path_usage_record.total_request_qtime;
                path_stats_counters [6] := path_usage_record.intermediate_errors;
                path_stats_counters [7] := path_usage_record.recovered_errors;
                path_stats_counters [8] := path_usage_record.unrecovered_errors;
                path_stats_counters [9] := path_usage_record.bytes_per_mau;

                CASE path_usage_record.path_type OF
                = cmc$ms7154_x =
                  controller_type := '7154';
                = cmc$ms7155_1, cmc$ms7155_1x =
                  controller_type := '7155';
                = cmc$ms7165_2x =
                  controller_type := '7165';
                = cmc$ms7255_1_1, cmc$ms7255_1_2 =
                  controller_type := '7255';
                = cmc$mscm3_ct =
                  controller_type := 'CM3';
                = cmc$mshydra_ct =
                  controller_type := 'HYDRA';
                = cmc$ms5831_x =
                  controller_type := '5831';
                ELSE
                  controller_type := '     ';
                CASEND;

                STRINGREP (path_descriptive_data, length, pio_pp_stats_p^.disk_pp_stats [pp_index].
                      iou_number: 2, ',', concurrent_channel: 1, ',', pio_pp_stats_p^.
                      disk_pp_stats [pp_index].channel.number: 3, ',', port: 1, ',', equip_index: 2, ',',
                      controller_type: 5);

                sfp$emit_statistic (osc$io_path_usage, path_descriptive_data (2, * ), ^path_stats_counters,
                      status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              IFEND;
            FOREND /equipment_loop/;
          FOREND /port_loop/;
        IFEND;
      FOREND /pp_loop/;

    = osc$io_unit_usage =

      IF pio_unit_stats_p = NIL THEN
        ALLOCATE pio_unit_stats_p: [1 .. unit_count] IN osv$task_private_heap^;
        osp$get_pio_unit_stats (FALSE, pio_unit_stats_p^, status);
        IF NOT status.normal THEN
          FREE pio_unit_stats_p IN osv$task_private_heap^;
          RETURN;
        IFEND;
      IFEND;

      IF stat_entry.first_index <> osc$all_stats THEN
        loop_start := stat_entry.first_index;
        loop_end := stat_entry.second_index;
      ELSE
        loop_start := 1;
        loop_end := unit_count;
      IFEND;

    /unit_loop/
      FOR unit_index := loop_start TO loop_end DO
        IF (pio_unit_stats_p^.disk_unit_stats [unit_index].unit_used) THEN
          unit_stats_counters [1] := pio_unit_stats_p^.disk_unit_stats [unit_index].read_requests;
          unit_stats_counters [2] := pio_unit_stats_p^.disk_unit_stats [unit_index].read_qtime;
          unit_stats_counters [3] := pio_unit_stats_p^.disk_unit_stats [unit_index].read_mau_count *
                pio_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau;
          unit_stats_counters [4] := pio_unit_stats_p^.disk_unit_stats [unit_index].write_requests;
          unit_stats_counters [5] := pio_unit_stats_p^.disk_unit_stats [unit_index].write_qtime;
          unit_stats_counters [6] := pio_unit_stats_p^.disk_unit_stats [unit_index].write_data_mau_count *
                pio_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau;
          unit_stats_counters [7] := pio_unit_stats_p^.disk_unit_stats [unit_index].
                write_data_and_preset_maus * pio_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau;
          unit_stats_counters [8] := pio_unit_stats_p^.disk_unit_stats [unit_index].swap_in_requests;
          unit_stats_counters [9] := pio_unit_stats_p^.disk_unit_stats [unit_index].swap_in_qtime;
          unit_stats_counters [10] := pio_unit_stats_p^.disk_unit_stats [unit_index].swap_in_mau_count *
                pio_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau;
          unit_stats_counters [11] := pio_unit_stats_p^.disk_unit_stats [unit_index].swap_out_requests;
          unit_stats_counters [12] := pio_unit_stats_p^.disk_unit_stats [unit_index].swap_out_qtime;
          unit_stats_counters [13] := pio_unit_stats_p^.disk_unit_stats [unit_index].swap_out_data_mau_count *
                pio_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau;
          unit_stats_counters [14] := pio_unit_stats_p^.disk_unit_stats [unit_index].
                swap_out_data_and_preset_maus * pio_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau;
          unit_stats_counters [15] := pio_unit_stats_p^.disk_unit_stats [unit_index].streamed_req_count_read;
          unit_stats_counters [16] := pio_unit_stats_p^.disk_unit_stats [unit_index].
                streamed_req_failed_count_read;
          unit_stats_counters [17] := pio_unit_stats_p^.disk_unit_stats [unit_index].streamed_req_count_write;
          unit_stats_counters [18] := pio_unit_stats_p^.disk_unit_stats [unit_index].
                streamed_req_failed_count_write;
          unit_stats_counters [19] := pio_unit_stats_p^.disk_unit_stats [unit_index].
                requests_causing_skipped_cyl;
          unit_stats_counters [20] := pio_unit_stats_p^.disk_unit_stats [unit_index].total_cylinders_skipped;
          unit_stats_counters [21] := pio_unit_stats_p^.disk_unit_stats [unit_index].intermediate_errors;
          unit_stats_counters [22] := pio_unit_stats_p^.disk_unit_stats [unit_index].recovered_errors;
          unit_stats_counters [23] := pio_unit_stats_p^.disk_unit_stats [unit_index].unrecovered_errors;
          unit_stats_counters [24] := pio_unit_stats_p^.disk_unit_stats [unit_index].bytes_per_mau;

          CASE pio_unit_stats_p^.disk_unit_stats [unit_index].unit_type OF
          = ioc$dt_ms844_4x =
            unit_type := '  844';
          = ioc$dt_ms885_1x, ioc$dt_ms885_42 =
            unit_type := '  885';
          = ioc$dt_ms834_2 =
            unit_type := '  834';
          = ioc$dt_msfsd_2 =
            unit_type := '  FSD';
          = ioc$dt_ms895_2 =
            unit_type := '  895';
          = ioc$dt_mshydra =
            unit_type := '  887';
          = ioc$dt_ms9836_1 =
            unit_type := ' 9836';
          = ioc$dt_msxmd_3 =
            unit_type := ' 9853';
          = ioc$dt_ms5832_1 =
            unit_type := '5832_1';
          = ioc$dt_ms5832_2 =
            unit_type := '5832_2';
          = ioc$dt_ms5833_1 =
            unit_type := '5833_1';
          = ioc$dt_ms5833_1p =
            unit_type := '5833_1P';
          = ioc$dt_ms5833_2 =
            unit_type := '5833_2';
          = ioc$dt_ms5833_3p =
            unit_type := '5833_3P';
          = ioc$dt_ms5833_4 =
            unit_type := '5833_4';
          = ioc$dt_ms5838_1 =
            unit_type := '5838_1';
          = ioc$dt_ms5838_1p =
            unit_type := '5838_1P';
          = ioc$dt_ms5838_2 =
            unit_type := '5838_2';
          = ioc$dt_ms5838_3p =
            unit_type := '5838_3P';
          = ioc$dt_ms5838_4 =
            unit_type := '5838_4';
          = ioc$dt_ms47444_1 =
            unit_type := '47444_1';
          = ioc$dt_ms47444_1p =
            unit_type := '47444_1P';
          = ioc$dt_ms47444_2 =
            unit_type := '47444_2';
          = ioc$dt_ms47444_3p =
            unit_type := '47444_3P';
          = ioc$dt_ms47444_4 =
            unit_type := '47444_4';
          ELSE
            unit_type := '    ';
          CASEND;

          STRINGREP (unit_descriptive_data, length, pio_unit_stats_p^.disk_unit_stats [unit_index].
                recorded_vsn: 6, ',', unit_type: 7);

          sfp$emit_statistic (osc$io_unit_usage, unit_descriptive_data, ^unit_stats_counters, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND /unit_loop/;

    = osc$io_disk_space =

      IF pio_disk_space_stats_p = NIL THEN
        ALLOCATE pio_disk_space_stats_p: [1 .. unit_count] IN osv$task_private_heap^;
        pmp$zero_out_table (#LOC (pio_disk_space_stats_p^), #SIZE (pio_disk_space_stats_p^));
        osp$get_disk_space_stats (pio_disk_space_stats_p^);
      IFEND;

      IF stat_entry.first_index <> osc$all_stats THEN
        loop_start := stat_entry.first_index;
        loop_end := stat_entry.second_index;
      ELSE
        loop_start := 1;
        loop_end := unit_count;
      IFEND;

      FOR unit_index := loop_start TO loop_end DO
        IF pio_disk_space_stats_p^.disk_space [unit_index].unit_used THEN
          STRINGREP (disk_space_descriptive_data, length, pio_disk_space_stats_p^.disk_space [unit_index].
                recorded_vsn: 6);
          disk_space_counters [1] := pio_disk_space_stats_p^.disk_space [unit_index].available_space;
          sfp$emit_statistic (osc$io_disk_space, disk_space_descriptive_data, ^disk_space_counters, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND;

    ELSE

    CASEND;

  PROCEND emit_pio_statistics;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_cpu_statistics' ??
?? NEWTITLE := 'OS6' , EJECT ??

{ Statistic OS6 is a periodic statistic that contains a summary of the total CPU usage.

  PROCEDURE emit_cpu_statistics
    (VAR cpu_stats_p: ^ost$cpu_stats;
     VAR mtr_reqs_p: ^ost$mtr_stats;
     VAR status: ost$status);

    VAR
      counters: array [1 .. 15] of integer,
      cpu: integer,
      descriptive_data: string (10),
      dp: integer;

    status.normal := TRUE;

    IF cpu_stats_p = NIL THEN
      ALLOCATE cpu_stats_p IN osv$task_private_heap^;
      osp$get_cpu_stats (FALSE, cpu_stats_p^, status);
      IF NOT status.normal THEN
        FREE cpu_stats_p IN osv$task_private_heap^;
        RETURN;
      IFEND;
    IFEND;

    IF mtr_reqs_p = NIL THEN
      ALLOCATE mtr_reqs_p IN osv$task_private_heap^;
      osp$get_mtr_stats (FALSE, mtr_reqs_p^, status);
      IF NOT status.normal THEN
        FREE mtr_reqs_p IN osv$task_private_heap^;
        RETURN;
      IFEND;
    IFEND;


    counters [1] := 0;
    counters [2] := 0;
    counters [10] := 0;
    counters [11] := 0;
    counters [12] := 0;
    counters [13] := 0;
    counters [14] := 0;
    FOR cpu := 0 TO cpu_stats_p^.cpu_stats.cpu_count DO
      IF (cpu_stats_p^.cpu_stats.processor_defined [cpu]) THEN

{  Compute total idle time for all cpus

        counters [1] := counters [1] + cpu_stats_p^.cpu_stats.idle_stats [cpu].idle_no_io_active;
        counters [2] := counters [2] + cpu_stats_p^.cpu_stats.idle_stats [cpu].idle_io_active;

{  Report idle time for individual cpus .
{  Counters 11 and 12 report idle time for CP0 and counters 13 and 14 report idle time for CP1.

        CASE cpu OF
        = 0 =
          counters [11] := cpu_stats_p^.cpu_stats.idle_stats [cpu].idle_no_io_active;
          counters [12] := cpu_stats_p^.cpu_stats.idle_stats [cpu].idle_io_active;
        = 1 =
          counters [13] := cpu_stats_p^.cpu_stats.idle_stats [cpu].idle_no_io_active;
          counters [14] := cpu_stats_p^.cpu_stats.idle_stats [cpu].idle_io_active;
        ELSE  { not reported for more than 2 cpus}
        CASEND;

{  Increment number of cpus.

        counters [10] := counters [10] + 1;
      IFEND;
    FOREND;

    counters [3] := 0;
    counters [4] := 0;
    FOR dp := jmc$max_dispatching_priority DOWNTO jmc$min_dispatching_priority DO
      counters [3] := counters [3] + cpu_stats_p^.cpu_stats.cpu_execution_stats [dp].time_spent_in_job_mode;
      counters [4] := counters [4] + cpu_stats_p^.cpu_stats.cpu_execution_stats [dp].time_spent_in_mtr_mode;
    FOREND;

    IF cpu_stats_p^.cpu_stats.nos_stats.nos_on THEN
      counters [5] := cpu_stats_p^.cpu_stats.nos_stats.nos_time;
      counters [6] := cpu_stats_p^.cpu_stats.nos_stats.nos_time_ve_idle;
    ELSE
      counters [5] := 0;
      counters [6] := 0;
    IFEND;

    counters [7] := osv$monitor_interlock_wait_time.time;
    counters [8] := mtr_reqs_p^.mtr_reqs[syc$rc_switch_task].count;
    counters [9] := 0; {future - need queue length}
    counters [15] := mtr_reqs_p^.mtr_reqs[syc$rc_process_due].total_cpu_time +           {PROCESS_DUE}
                     mtr_reqs_p^.mtr_reqs[syc$rc_process_dft_block].total_cpu_time +     {PROCESS_DFT_ENTRY}
                     mtr_reqs_p^.mtr_reqs[syc$rc_swap_job].total_cpu_time +              {MONITOR_SWAP_REQS}
                     mtr_reqs_p^.mtr_reqs[syc$rc_periodic_call].total_cpu_time +         {PERIODIC_CALL}
                     mtr_reqs_p^.mtr_reqs[syc$rc_process_scd_block].total_cpu_time +     {PROCESS_SCD_BLOC}
                     mtr_reqs_p^.mtr_reqs[syc$rc_process_io_completions].total_cpu_time +{PROCESS_IO}
                     mtr_reqs_p^.mtr_reqs[syc$rc_monitor_system_status].total_cpu_time + {MONITOR_SYS_STATUS}
                     mtr_reqs_p^.mtr_reqs[syc$rc_switch_task].total_cpu_time;            {SWITCH_TASK}

    sfp$emit_statistic (osc$cpu_stats, '', ^counters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND emit_cpu_statistics;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_service_class_stats' ??
?? NEWTITLE := 'OS7', EJECT ??

{ PURPOSE:
{   Emit the OS7 statistic.

  PROCEDURE emit_service_class_stats
    (VAR status: ost$status);

    VAR
      counters: array [1 .. 18] of integer,
      service_class: jmt$service_class_index,
      service_class_stats_p: ^ost$service_class_stats;

    status.normal := TRUE;

    PUSH service_class_stats_p: [1 .. jmv$max_service_class_in_use];
    pmp$zero_out_table (service_class_stats_p, #SIZE (service_class_stats_p^));
    osp$get_service_class_stats (FALSE, service_class_stats_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR service_class := jmc$system_service_class TO UPPERBOUND (service_class_stats_p^.service_class_stats)
          DO
      IF (jmv$service_classes [service_class] <> NIL) AND jmv$service_classes [service_class]^.attributes.
            defined THEN
        counters [1] := service_class_stats_p^.service_class_stats [service_class].mtr_stats.cp_time.job_mode;
        counters [2] := service_class_stats_p^.service_class_stats [service_class].mtr_stats.cp_time.
              monitor_mode;
        counters [3] := service_class_stats_p^.service_class_stats [service_class].mtr_stats.page_faults.
              disk + service_class_stats_p^.service_class_stats [service_class].mtr_stats.page_faults.
              reclaimed + service_class_stats_p^.service_class_stats [service_class].mtr_stats.page_faults.
              assigned;
        counters [4] := service_class_stats_p^.service_class_stats [service_class].mtr_stats.page_faults.disk;
        counters [5] := service_class_stats_p^.service_class_stats [service_class].mtr_stats.page_faults.
              reclaimed;
        counters [6] := service_class_stats_p^.service_class_stats [service_class].mtr_stats.page_faults.
              assigned;
        counters [7] := service_class_stats_p^.service_class_stats [service_class].sched_stats.active_jobs;
        counters [8] := service_class_stats_p^.service_class_stats [service_class].sched_stats.
              swapin_queue_size;
        counters [9] := service_class_stats_p^.service_class_stats [service_class].mtr_stats.swap_stats.
              long_wait_swaps;
        counters [10] := service_class_stats_p^.service_class_stats [service_class].mtr_stats.swap_stats.
              job_mode_swaps;
        counters [11] := service_class_stats_p^.service_class_stats [service_class].sched_stats.memory_waits;
        counters [12] := service_class_stats_p^.service_class_stats [service_class].sched_stats.ajl_waits;
        counters [13] := service_class_stats_p^.service_class_stats [service_class].mtr_stats.swap_stats.
              swapped_pages;
        counters [14] := service_class_stats_p^.service_class_stats [service_class].mtr_stats.swap_stats.
              residence_time;
        counters [15] := service_class_stats_p^.service_class_stats [service_class].mtr_stats.swap_stats.
              swap_wait_time;
        counters [16] := service_class_stats_p^.service_class_stats [service_class].mtr_stats.swap_stats.
              scheduler_swapins;
        counters [17] := service_class_stats_p^.service_class_stats [service_class].mtr_stats.swap_stats.
              swap_to_ready_time;
        counters [18] := service_class_stats_p^.service_class_stats [service_class].mtr_stats.swap_stats.
              swap_to_ready_count;

        sfp$emit_statistic (osc$service_class_stats, service_class_stats_p^.
              service_class_stats [service_class].name (1, clp$trimmed_string_size
              (service_class_stats_p^.service_class_stats [service_class].name)), ^counters, status);

        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND emit_service_class_stats;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_job_class_stats' ??
?? NEWTITLE := 'OS8', EJECT ??

{ PURPOSE:
{   Emit the OS8 statistic.

  PROCEDURE emit_job_class_stats
    (VAR status: ost$status);

    VAR
      counters: array [1 .. 2] of integer,
      job_class: jmt$job_class,
      job_class_stats_p: ^ost$job_class_stats;

    status.normal := TRUE;

    PUSH job_class_stats_p: [1 .. jmv$maximum_job_class_in_use];
    pmp$zero_out_table (job_class_stats_p, #SIZE (job_class_stats_p^));
    osp$get_job_class_stats (FALSE, job_class_stats_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR job_class := 1 TO UPPERBOUND (job_class_stats_p^.job_class_stats) DO
      IF jmv$job_class_table_p^ [job_class].defined THEN
        counters [1] := job_class_stats_p^.job_class_stats [job_class].job_class_counters.queued_jobs;
        counters [2] := job_class_stats_p^.job_class_stats [job_class].job_class_counters.completed_jobs;

        sfp$emit_statistic (osc$job_class_stats, job_class_stats_p^.job_class_stats [job_class].
              job_class_names.name (1, clp$trimmed_string_size
              (job_class_stats_p^.job_class_stats [job_class].job_class_names.name)), ^counters, status);

        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND emit_job_class_stats;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_system_job_stats' ??
?? NEWTITLE := 'OS9' , EJECT ??

{ PURPOSE:
{   Emit the OS9 statistic.

  PROCEDURE emit_system_job_stats
    (VAR system_job_stats_p: ^ost$job_stats;
     VAR status: ost$status);

    VAR
      counters: array [1 .. 11] of integer;

    status.normal := TRUE;

    IF system_job_stats_p = NIL THEN
      ALLOCATE system_job_stats_p IN osv$task_private_heap^;
      osp$get_job_stats (FALSE, system_job_stats_p^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    counters [1] := system_job_stats_p^.job_data.cp_time.time_spent_in_job_mode;
    counters [2] := system_job_stats_p^.job_data.cp_time.time_spent_in_mtr_mode;
    counters [3] := system_job_stats_p^.job_data.paging_statistics.page_fault_count;
    counters [4] := system_job_stats_p^.job_data.paging_statistics.page_in_count;
    counters [5] := system_job_stats_p^.job_data.paging_statistics.pages_reclaimed_from_queue;
    counters [6] := system_job_stats_p^.job_data.paging_statistics.new_pages_assigned;
    counters [7] := system_job_stats_p^.job_data.paging_statistics.working_set_max_used;
    counters [8] := system_job_stats_p^.job_data.paging_statistics.pages_from_server;
    counters [9] := system_job_stats_p^.job_data.working_set_size;
    counters [10] := 0; {Will be used in the future for average working set}
    counters [11] := system_job_stats_p^.job_data.ready_task_count;

    sfp$emit_statistic (osc$system_job_stats, '', ^counters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND emit_system_job_stats;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_system_task_stats' ??
?? NEWTITLE := 'OS10' , EJECT ??

{ PURPOSE:
{   Emit the OS10 statistic.

  PROCEDURE emit_system_task_stats
    (VAR system_task_stats_p: ^ost$task_stats;
     VAR status: ost$status);

    VAR
      counters: array [1 .. 3] of integer,
      descriptive_data: string (31),
      task: 0 .. pmc$max_task_id;

    status.normal := TRUE;

    IF system_task_stats_p = NIL THEN
      ALLOCATE system_task_stats_p: [1 .. 100] IN osv$task_private_heap^;
      pmp$collect_raw_task_statistics (system_task_stats_p^.active_task_count,
            system_task_stats_p^.active_task_statistics);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF system_task_stats_p^.active_task_count > 100 THEN
        FREE system_task_stats_p IN osv$task_private_heap^;
        ALLOCATE system_task_stats_p: [1 .. system_task_stats_p^.active_task_count] IN osv$task_private_heap^;
        pmp$collect_raw_task_statistics (system_task_stats_p^.active_task_count,
              system_task_stats_p^.active_task_statistics);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    FOR task := 1 TO system_task_stats_p^.active_task_count DO
      counters [1] := system_task_stats_p^.active_task_statistics [task].cp_time.task_time;
      counters [2] := system_task_stats_p^.active_task_statistics [task].cp_time.monitor_time;
      counters [3] := system_task_stats_p^.active_task_statistics [task].page_fault_count;
      descriptive_data := '';
      descriptive_data := system_task_stats_p^.active_task_statistics [task].task_name;
      sfp$emit_statistic (osc$system_task_stats, descriptive_data, ^counters, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND emit_system_task_stats;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_memory_stats' ??
?? NEWTITLE := 'OS11' , EJECT ??

{ PURPOSE:
{   Emit the OS11 statistic.

  PROCEDURE emit_memory_stats
    (VAR jm_mm_stats_p: ^ost$jm_mm_stats;
     VAR status: ost$status);

    VAR
      available_memory: integer,
      counters: array [1 .. 22] of integer,
      descriptive_data: string (31),
      maximum_180_memory: string (18),
      memory_index: integer,
      queue_id: mmt$page_frame_queue_id,
      sum_of_site_shared_queues: integer,
      sum_of_system_shared_queues: integer;

    status.normal := TRUE;

    IF jm_mm_stats_p = NIL THEN
      ALLOCATE jm_mm_stats_p IN osv$task_private_heap^;
      osp$get_jm_mm_stats (FALSE, jm_mm_stats_p^, status);
      IF NOT status.normal THEN
        FREE jm_mm_stats_p IN osv$task_private_heap^;
        RETURN;
      IFEND;
    IFEND;

    maximum_180_memory := 'MAXIMUM_180_MEMORY';
    osp$fetch_system_constant (maximum_180_memory, memory_index, available_memory, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    counters [1] := available_memory;
    counters [2] := 512 * (128 - #READ_REGISTER (osc$pr_page_size_mask));
    counters [3] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_free];
    counters [4] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_avail];
    counters [5] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_avail_modified];
    counters [6] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_wired];

    sum_of_site_shared_queues := 0;
    FOR queue_id := mmc$pq_shared_first_site TO mmc$pq_shared_last_site DO
      sum_of_site_shared_queues := sum_of_site_shared_queues +
          jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [queue_id];
    FOREND;

    sum_of_system_shared_queues := 0;
    FOR queue_id := mmc$pq_shared_first TO mmc$pq_shared_last DO
      sum_of_system_shared_queues := sum_of_system_shared_queues +
            jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [queue_id];
    FOREND;

    counters [7] := sum_of_system_shared_queues + sum_of_site_shared_queues;
    counters [8] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_shared_io_error];
    counters [9] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_swapped_io_error];
    counters [10] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_job_fixed];
    counters [11] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_job_io_error];
    counters [12] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_job_working_set];
    counters [13] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.swap_resident_count;
    counters [14] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.long_wait_count;
    counters [15] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_shared_task_service];
    counters [16] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_shared_pf_execute];
    counters [17] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_shared_pf_non_execute];
    counters [18] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_shared_device_file];
    counters [19] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_shared_file_server];
    counters [20] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_shared_other];
    counters [21] := sum_of_site_shared_queues;
    counters [22] := jm_mm_stats_p^.jm_mm_stats.page_q_counts.q_counts [mmc$pq_flawed];

    sfp$emit_statistic (osc$memory_utilization_stats, '', ^counters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND emit_memory_stats;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_job_count_stats' ??
?? NEWTITLE := 'OS12' , EJECT ??

{ PURPOSE:
{   Emit the OS12 statistic.

  PROCEDURE emit_job_count_stats
    (VAR jm_mm_stats_p: ^ost$jm_mm_stats;
     VAR status: ost$status);

    VAR
      counters: array [1 .. 5] of integer;

    status.normal := TRUE;

    IF jm_mm_stats_p = NIL THEN
      ALLOCATE jm_mm_stats_p IN osv$task_private_heap^;
      osp$get_jm_mm_stats (FALSE, jm_mm_stats_p^, status);
      IF NOT status.normal THEN
        FREE jm_mm_stats_p IN osv$task_private_heap^;
        RETURN;
      IFEND;
    IFEND;

    counters [1] := jm_mm_stats_p^.jm_mm_stats.total_system_class;
    counters [2] := jm_mm_stats_p^.jm_mm_stats.total_interactive_jobs;
    counters [3] := jm_mm_stats_p^.jm_mm_stats.total_non_interactive_jobs -
          jm_mm_stats_p^.jm_mm_stats.total_system_class;
    counters [4] := jm_mm_stats_p^.jm_mm_stats.total_active_jobs;
    counters [5] := jm_mm_stats_p^.jm_mm_stats.total_swapped_jobs;

    sfp$emit_statistic (osc$job_count_stats, '', ^counters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND emit_job_count_stats;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_page_streaming_stats' ??
?? NEWTITLE := 'OS13' , EJECT ??

{ PURPOSE:
{   Emit the OS13 statistic.

  PROCEDURE emit_page_streaming_stats
    (VAR paging_stats_p: ^ost$paging_stats;
     VAR status: ost$status);

    VAR
      counters: array [1 .. 11] of integer;

    status.normal := TRUE;

    IF paging_stats_p = NIL THEN
      ALLOCATE paging_stats_p IN osv$task_private_heap^;
      osp$get_paging_stats (FALSE, paging_stats_p^, status);
      IF NOT status.normal THEN
        FREE paging_stats_p IN osv$task_private_heap^;
        RETURN;
      IFEND;
    IFEND;

    counters [1] := paging_stats_p^.p_stats.page_streaming.prestream_only +
          paging_stats_p^.p_stats.page_streaming.initiated;
    counters [2] := paging_stats_p^.p_stats.page_streaming.initiated;
    counters [3] := paging_stats_p^.p_stats.page_streaming.terminated;
    counters [4] := paging_stats_p^.p_stats.page_streaming.pages_prestream;
    counters [5] := paging_stats_p^.p_stats.page_streaming.pages_streaming;
    counters [6] := paging_stats_p^.p_stats.page_streaming.task_slow;
    counters [7] := paging_stats_p^.p_stats.page_streaming.random_faults;
    counters [8] := 0; {future will contain number of sequential page faults}
    counters [9] := 0; {future will contain number of random page faults}
    counters [10] := 0; {future will contain number of non-random page faults}
    counters [11] := 0; {future will contain number of page faults for tu=0}

    sfp$emit_statistic (osc$page_streaming_stats, '', ^counters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND emit_page_streaming_stats;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_system_mr_stats' ??
?? NEWTITLE := 'OS14' , EJECT ??

{ PURPOSE:
{   Emit the OS14 statistic.

  PROCEDURE emit_system_mr_stats
    (VAR mtr_reqs_p: ^ost$mtr_stats;
     VAR status: ost$status);

    VAR
      index: integer,
      counters: array [1 .. 21] of integer;

    status.normal := TRUE;

    IF mtr_reqs_p = NIL THEN
      ALLOCATE mtr_reqs_p IN osv$task_private_heap^;
      osp$get_mtr_stats (FALSE, mtr_reqs_p^, status);
      IF NOT status.normal THEN
        FREE mtr_reqs_p IN osv$task_private_heap^;
        RETURN;
      IFEND;
    IFEND;

    counters [1] := mtr_reqs_p^.mtr_reqs [syc$rc_cycle].count;
    counters [2] := mtr_reqs_p^.mtr_reqs [syc$rc_cycle].total_cpu_time;
    counters [3] := mtr_reqs_p^.mtr_reqs [syc$rc_cycle].max_time;
    counters [4] := mtr_reqs_p^.mtr_reqs [syc$rc_delay].count;
    counters [5] := mtr_reqs_p^.mtr_reqs [syc$rc_delay].total_cpu_time;
    counters [6] := mtr_reqs_p^.mtr_reqs [syc$rc_delay].max_time;
    counters [7] := mtr_reqs_p^.mtr_reqs [syc$rc_wait].count;
    counters [8] := mtr_reqs_p^.mtr_reqs [syc$rc_wait].total_cpu_time;
    counters [9] := mtr_reqs_p^.mtr_reqs [syc$rc_wait].max_time;
    counters [10] := mtr_reqs_p^.mtr_reqs [syc$rc_switch_task].count;
    counters [11] := mtr_reqs_p^.mtr_reqs [syc$rc_switch_task].total_cpu_time;
    counters [12] := mtr_reqs_p^.mtr_reqs [syc$rc_switch_task].max_time;
    counters [13] := mtr_reqs_p^.mtr_reqs [syc$rc_process_io_completions].count;
    counters [14] := mtr_reqs_p^.mtr_reqs [syc$rc_process_io_completions].total_cpu_time;
    counters [15] := mtr_reqs_p^.mtr_reqs [syc$rc_process_io_completions].max_time;
    counters [16] := mtr_reqs_p^.mtr_reqs [syc$rc_periodic_call].count;
    counters [17] := mtr_reqs_p^.mtr_reqs [syc$rc_periodic_call].total_cpu_time;
    counters [18] := mtr_reqs_p^.mtr_reqs [syc$rc_periodic_call].max_time;
    counters [19] := mtr_reqs_p^.mtr_reqs [syc$rc_ready_task].count;
    counters [20] := mtr_reqs_p^.mtr_reqs [syc$rc_ready_task].total_cpu_time;
    counters [21] := mtr_reqs_p^.mtr_reqs [syc$rc_ready_task].max_time;

    sfp$emit_statistic (osc$monitor_request_stats, '', ^counters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND emit_system_mr_stats;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_cpu_dispatching_stats' ??
?? NEWTITLE := 'OS15' , EJECT ??

{ PURPOSE:
{   Emit the OS15 statistic.

  PROCEDURE emit_cpu_dispatching_stats
    (VAR cpu_stats_p: ^ost$cpu_stats;
     VAR status: ost$status);

    VAR
      counters: array [1 .. 2*(jmc$max_dispatching_priority - 1)] of integer,
      dp: jmc$min_dispatching_priority .. jmc$max_dispatching_priority ,
      index: 1 .. 2*jmc$max_dispatching_priority ;

    status.normal := TRUE;

    IF cpu_stats_p = NIL THEN
      ALLOCATE cpu_stats_p IN osv$task_private_heap^;
      osp$get_cpu_stats (FALSE, cpu_stats_p^, status);
      IF NOT status.normal THEN
        FREE cpu_stats_p IN osv$task_private_heap^;
        RETURN;
      IFEND;
    IFEND;

{ Jmc$min_dispatching_priority equals 2 and corresponds to P1.
{ Jmc$max_dispatching_priority equals 15 and corresponds to P14.
{ Two counters are calculated for each dispatching priority so that a total of
{ 28 counters are emitted with the statistic.

    index := 1;
    FOR dp := jmc$min_dispatching_priority TO jmc$max_dispatching_priority DO
      counters [index] := cpu_stats_p^.cpu_stats.cpu_execution_stats [dp].time_spent_in_job_mode;
      counters [index + 1] := cpu_stats_p^.cpu_stats.cpu_execution_stats [dp].time_spent_in_mtr_mode;
      index := index + 2;
    FOREND;

    sfp$emit_statistic (osc$cpu_dispatching_stats, '', ^counters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND emit_cpu_dispatching_stats;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_page_faults_rejected_stats' ??
?? NEWTITLE := 'OS16' , EJECT ??

{ PURPOSE:
{   Emit the OS16 statistic.

  PROCEDURE emit_page_fault_rejected_stats
    (VAR page_fault_stats_p: ^ost$page_fault_stats;
     VAR server_page_fault_stats_p: ^ost$page_fault_stats;
     VAR status: ost$status);

    VAR
      allocate_pf_ptr: boolean,
      allocate_server_pf_ptr: boolean,
      counters: array [1 .. 11] of integer;

    status.normal := TRUE;
    allocate_pf_ptr := FALSE;
    allocate_server_pf_ptr := FALSE;

    IF page_fault_stats_p = NIL THEN
      allocate_pf_ptr := TRUE;
      ALLOCATE page_fault_stats_p IN osv$task_private_heap^;
    IFEND;
    IF server_page_fault_stats_p = NIL THEN
      allocate_server_pf_ptr := TRUE;
      ALLOCATE server_page_fault_stats_p IN osv$task_private_heap^;
    IFEND;
    osp$get_page_stats (FALSE, page_fault_stats_p^, server_page_fault_stats_p^, status);
    IF NOT status.normal THEN
      IF allocate_pf_ptr THEN
        FREE page_fault_stats_p IN osv$task_private_heap^;
      IFEND;
      IF allocate_server_pf_ptr THEN
        FREE server_page_fault_stats_p IN osv$task_private_heap^;
      IFEND;
      RETURN;
    IFEND;

    counters [1] := page_fault_stats_p^.pf_stats [$INTEGER (ps_no_memory)];
    counters [2] := page_fault_stats_p^.pf_stats [$INTEGER (ps_low_on_memory)];
    counters [3] := page_fault_stats_p^.pf_stats [$INTEGER (ps_locked)];
    counters [4] := page_fault_stats_p^.pf_stats [$INTEGER (ps_pt_full)];
    counters [5] := page_fault_stats_p^.pf_stats [$INTEGER (ps_io_temp_reject)];
    counters [6] := page_fault_stats_p^.pf_stats [$INTEGER (ps_beyond_file_limit)];
    counters [7] := page_fault_stats_p^.pf_stats [$INTEGER (ps_read_beyond_eoi)];
    counters [8] := page_fault_stats_p^.pf_stats [$INTEGER (ps_no_extend_permission)];
    counters [9] := page_fault_stats_p^.pf_stats [$INTEGER (ps_volume_unavailable)];
    counters [10] := page_fault_stats_p^.pf_stats [$INTEGER (ps_allocate_required_on_server)];
    counters [11] := page_fault_stats_p^.pf_stats [$INTEGER (ps_server_terminated)];

    sfp$emit_statistic (osc$page_fault_rejected_stats, '', ^counters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND emit_page_fault_rejected_stats;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_system_job_stats_hide' ??
?? NEWTITLE := 'OS9005', EJECT ??

  PROCEDURE emit_system_job_stats_hide
    (VAR status: ost$status);

    VAR
      counters: array [1 .. 9] of integer,
      job_data: ost$job_stats;

    status.normal := TRUE;
    osp$get_job_stats (FALSE, job_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    counters [1] := job_data.job_data.cp_time.time_spent_in_job_mode;
    counters [2] := job_data.job_data.cp_time.time_spent_in_mtr_mode;
    counters [3] := job_data.job_data.paging_statistics.page_in_count;
    counters [4] := job_data.job_data.paging_statistics.pages_reclaimed_from_queue;
    counters [5] := job_data.job_data.paging_statistics.new_pages_assigned;
    counters [6] := job_data.job_data.working_set_size;
    counters [7] := job_data.job_data.ready_task_count;
    counters [8] := job_data.job_data.paging_statistics.pages_from_server;
    counters [9] := job_data.job_data.paging_statistics.page_fault_count;

    sfp$emit_statistic (osc$system_job_stats_hide  , '', ^counters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND emit_system_job_stats_hide;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_swap_statistics' ??
?? NEWTITLE := 'OS9007,OS9008' , EJECT ??

  PROCEDURE emit_swap_statistics
    (    stat_entry: ost$stat_entry;
     VAR swap_stats_ptr: ^ost$swap_stats;
     VAR status: ost$status);

    VAR
      from_state,
      to_state: jmt$ijl_swap_status,
      loop_1_start: jmt$ijl_swap_status,
      loop_1_end: jmt$ijl_swap_status,
      loop_2_start: jmt$ijl_swap_status,
      loop_2_end: jmt$ijl_swap_status,
      counters: array [1 .. 3] of integer,
      counterp: array [1 .. 4] of integer,
      descriptive_data: string (10),
      length: integer;

    status.normal := TRUE;

    IF swap_stats_ptr = NIL THEN
      ALLOCATE swap_stats_ptr IN osv$task_private_heap^;
      osp$get_swap_stats (FALSE, swap_stats_ptr^, status);
      IF NOT status.normal THEN
        FREE swap_stats_ptr IN osv$task_private_heap^;
        RETURN;
      IFEND;
    IFEND;

    IF stat_entry.stat = osc$swap_state_stats THEN
      IF stat_entry.from_index <> jmc$iss_null THEN
        loop_1_start := stat_entry.from_index;
        loop_1_end := loop_1_start;
        loop_2_start := stat_entry.to_index;
        loop_2_end := loop_2_start;
      ELSE
        loop_1_start := LOWERVALUE (jmt$ijl_swap_status);
        loop_1_end := UPPERVALUE (jmt$ijl_swap_status);
        loop_2_start := LOWERVALUE (jmt$ijl_swap_status);
        loop_2_end := UPPERVALUE (jmt$ijl_swap_status);
      IFEND;

      FOR from_state := loop_1_start TO loop_1_end DO
        FOR to_state := loop_2_start TO loop_2_end DO

          IF (swap_stats_ptr^.swap_stats [from_state] [to_state].count > 0) OR
                (stat_entry.from_index <> jmc$iss_null) THEN
            counters [1] := swap_stats_ptr^.swap_stats [from_state] [to_state].total_time;
            counters [2] := swap_stats_ptr^.swap_stats [from_state] [to_state].maximum_time;
            counters [3] := swap_stats_ptr^.swap_stats [from_state] [to_state].count;

            descriptive_data := '';
            STRINGREP (descriptive_data, length, $INTEGER (from_state), '  ', $INTEGER (to_state));

            sfp$emit_statistic (osc$swap_state_stats, descriptive_data (2, * ), ^counters, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        FOREND;
      FOREND;

    ELSEIF stat_entry.stat = osc$swap_page_count_stats THEN

      counterp [1] := swap_stats_ptr^.swap_file_page_count.swap_count;
      counterp [2] := swap_stats_ptr^.swap_file_page_count.page_count;
      counterp [3] := 0;
      counterp [4] := 0;

      sfp$emit_statistic (osc$swap_page_count_stats, '', ^counterp, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND emit_swap_statistics;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_system_as_data' ??
?? NEWTITLE := 'OS9010' , EJECT ??

  PROCEDURE emit_system_as_data
    (VAR aging_stats_ptr: ^ost$aging_stats;
     VAR status: ost$status);

    VAR
      counters: array [1 .. 18] of integer;

    IF aging_stats_ptr = NIL THEN
      ALLOCATE aging_stats_ptr IN osv$task_private_heap^;
      osp$get_aging_stats (FALSE, aging_stats_ptr^, status);
      IF NOT status.normal THEN
        FREE aging_stats_ptr IN osv$task_private_heap^;
        RETURN;
      IFEND;
    IFEND;

    counters [1] := aging_stats_ptr^.aging_stats.force_aggressive_aging;
    counters [2] := aging_stats_ptr^.aging_stats.aggressive_age_shared_queue;
    counters [3] := aging_stats_ptr^.aging_stats.aggressive_age_job_queues;
    counters [4] := aging_stats_ptr^.aging_stats.aggressive_aging_failed;
    counters [5] := aging_stats_ptr^.aging_stats.age_cp_bound_job;
    counters [6] := aging_stats_ptr^.aging_stats.remove_unmodified_page_from_ws;
    counters [7] := aging_stats_ptr^.aging_stats.remove_modified_page_from_ws;
    counters [8] := aging_stats_ptr^.aging_stats.page_written_to_disk;
    counters [9] := aging_stats_ptr^.aging_stats.multiple_pages_written_to_disk;
    counters [10] := aging_stats_ptr^.aging_stats.calls_to_age_jws;
    counters [11] := aging_stats_ptr^.aging_stats.age_exceeds_aif;
    counters [12] := aging_stats_ptr^.aging_stats.age_exceeds_aic;
    counters [13] := aging_stats_ptr^.aging_stats.age_unused_page_in_shared_queue;
    counters [14] := aging_stats_ptr^.aging_stats.write_aged_out_page;
    counters [15] := aging_stats_ptr^.aging_stats.write_forced_out_page;
    counters [16] := aging_stats_ptr^.aging_stats.write_pt_full_page;
    counters [17] := aging_stats_ptr^.aging_stats.write_avail_mod_page;
    counters [18] := aging_stats_ptr^.aging_stats.write_page_failed;

    sfp$emit_statistic (osc$aging_stats, '', ^counters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND emit_system_as_data;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_system_mr_data' ??
?? NEWTITLE := 'OS9011' , EJECT ??

  PROCEDURE emit_system_mr_data
    (    stat_entry: ost$stat_entry;
     VAR mtr_reqs_ptr: ^ost$mtr_stats;
     VAR status: ost$status);

    VAR
      i: integer,
      loop_start: integer,
      loop_end: integer,
      counters: array [1 .. 6] of integer,
      descriptive_data: string (10),
      length: integer;

    IF mtr_reqs_ptr = NIL THEN
      ALLOCATE mtr_reqs_ptr IN osv$task_private_heap^;
      osp$get_mtr_stats (FALSE, mtr_reqs_ptr^, status);
      IF NOT status.normal THEN
        FREE mtr_reqs_ptr IN osv$task_private_heap^;
        RETURN;
      IFEND;
    IFEND;

    IF stat_entry.first_index <> osc$all_stats THEN
      loop_start := stat_entry.first_index;
      loop_end := stat_entry.second_index;
    ELSE
      loop_start := LOWERBOUND (mtr_reqs_ptr^.mtr_reqs);
      loop_end := UPPERBOUND (mtr_reqs_ptr^.mtr_reqs);
    IFEND;

    FOR i := loop_start TO loop_end DO
      IF (mtr_reqs_ptr^.mtr_reqs [i].count > 0) OR (stat_entry.first_index <> osc$all_stats) THEN
        counters [1] := mtr_reqs_ptr^.mtr_reqs [i].count;
        counters [2] := mtr_reqs_ptr^.mtr_reqs [i].total_cpu_time;
        counters [3] := mtr_reqs_ptr^.mtr_reqs [i].max_time;
        counters [4] := 0;
        counters [5] := 0;
        counters [6] := 0;

        descriptive_data := '';
        STRINGREP (descriptive_data, length, mtr_reqs_ptr^.mtr_reqs [i].req_code);

        sfp$emit_statistic (osc$mtr_req_stats, descriptive_data (2, * ), ^counters, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND emit_system_mr_data;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_job_count_stats_hide' ??
?? NEWTITLE := 'OS9013', EJECT ??

  PROCEDURE emit_job_count_stats_hide
    (VAR jm_mm_stats_p: ^ost$jm_mm_stats;
     VAR status: ost$status);

    VAR
      counters: array [1 .. 14] of integer;

    status.normal := TRUE;

    IF jm_mm_stats_p = NIL THEN
      ALLOCATE jm_mm_stats_p IN osv$task_private_heap^;
      osp$get_jm_mm_stats (FALSE, jm_mm_stats_p^, status);
      IF NOT status.normal THEN
        FREE jm_mm_stats_p IN osv$task_private_heap^;
        RETURN;
      IFEND;
    IFEND;

    counters [1] := jm_mm_stats_p^.jm_mm_stats.total_swapped_jobs;
    counters [2] := jm_mm_stats_p^.jm_mm_stats.total_ready_tasks;
    counters [3] := jm_mm_stats_p^.jm_mm_stats.total_ready_but_swapped_tasks;
    counters [4] := jm_mm_stats_p^.jm_mm_stats.total_active_jobs;
    counters [5] := jm_mm_stats_p^.jm_mm_stats.total_system_class;
    counters [6] := jm_mm_stats_p^.jm_mm_stats.total_interactive_jobs;
    counters [7] := jm_mm_stats_p^.jm_mm_stats.total_non_interactive_jobs;

    sfp$emit_statistic (osc$job_count_stats_hide, '', ^counters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND emit_job_count_stats_hide;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'emit_namve_statistics', EJECT ??

{ PURPOSE:
{   The purpose of this request is to get the data for the intranet statistic
{   counters, the namve statistic counters, osi device specific statistic counters
{   and the osi namve statistic counters and then emit the statistics to the
{   binary statistics log.

  PROCEDURE emit_namve_statistics
    (    stat_entry: ost$stat_entry;
     VAR status: ost$status);

    VAR
      counters: array [1 .. 61] of integer,
      descriptive_data: string (10),
      i: nlt$device_count,
      intranet_counters: array [1 .. 10] of integer,
      length: integer,
      networks_count: nlt$device_count,
      osi_counters: array [1 .. 25] of integer,
      osi_device_specific_counter: array [1 .. 25] of integer;

    status.normal := TRUE;
    IF stat_entry.stat = nac$intranet_stats THEN

{ Emit the intranet layer statistic for each directly connected network solution.

      networks_count := (UPPERBOUND (nav$global_statistics.intranet^) -
            LOWERBOUND (nav$global_statistics.intranet^)) + 1;

      IF intranet_statistic_p = NIL THEN
        IF networks_count > 0 THEN
          ALLOCATE intranet_statistic_p IN osv$task_private_heap^;
          ALLOCATE intranet_statistic_p^.stats: [1 .. networks_count] IN osv$task_private_heap^;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      nap$get_intranet_statistics (FALSE, intranet_statistic_p^);
      FOR i := 1 TO networks_count DO
        intranet_counters [1] := intranet_statistic_p^.stats^ [i].multicasts_received;
        intranet_counters [2] := intranet_statistic_p^.stats^ [i].multicasts_sent;
        intranet_counters [3] := intranet_statistic_p^.stats^ [i].receive.pdu_average;
        intranet_counters [4] := intranet_statistic_p^.stats^ [i].receive.pdu_total;
        intranet_counters [5] := intranet_statistic_p^.stats^ [i].receive_pdus_discarded;
        intranet_counters [6] := intranet_statistic_p^.stats^ [i].send.pdu_average_size;
        intranet_counters [7] := intranet_statistic_p^.stats^ [i].send.pdu_total;
        intranet_counters [8] := intranet_statistic_p^.stats^ [i].send_pdus_discarded;
        intranet_counters [9] := intranet_statistic_p^.stats^ [i].current_send_pdus_queued;
        intranet_counters [10] := intranet_statistic_p^.stats^ [i].send.pdu_fragment_average;

        STRINGREP (descriptive_data, length, intranet_statistic_p^.stats^ [i].network_id: #(16));
        sfp$emit_statistic (nac$intranet_stats, descriptive_data (1, length), ^intranet_counters, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    IF stat_entry.stat = nac$namve_stats THEN

{ Emit the NAM/VE statistic.

      IF namve_statistic_p = NIL THEN
        ALLOCATE namve_statistic_p IN osv$task_private_heap^;
      IFEND;

      nap$get_namve_statistics (FALSE, namve_statistic_p^);
      counters [1] := namve_statistic_p^.stats.internet.broadcasts_sent;
      counters [2] := namve_statistic_p^.stats.internet.pdus_received;
      counters [3] := namve_statistic_p^.stats.internet.pdus_sent;
      counters [4] := namve_statistic_p^.stats.internet.pdus_relayed;
      counters [5] := namve_statistic_p^.stats.internet.pdus_routed_locally;

      counters [6] := namve_statistic_p^.stats.transport.initiated_connections;
      counters [7] := namve_statistic_p^.stats.transport.active_connections;
      counters [8] := namve_statistic_p^.stats.transport.reference_number_wait;
      counters [9] := namve_statistic_p^.stats.transport.connections_terminated;
      counters [10] := namve_statistic_p^.stats.transport.data_packets_received;
      counters [11] := namve_statistic_p^.stats.transport.data_packets_sent;
      counters [12] := namve_statistic_p^.stats.transport.discarded_data_packets;
      counters [13] := namve_statistic_p^.stats.transport.duplicate_data_packets;
      counters [14] := namve_statistic_p^.stats.transport.xdata_packets_received;
      counters [15] := namve_statistic_p^.stats.transport.xdata_packets_sent;
      counters [16] := namve_statistic_p^.stats.transport.discarded_xdata_packets;
      counters [17] := namve_statistic_p^.stats.transport.duplicate_xdata_packets;
      counters [18] := namve_statistic_p^.stats.transport.acknowledgment_requests_recved;
      counters [19] := namve_statistic_p^.stats.transport.acknowledgment_requests_sent;
      counters [20] := namve_statistic_p^.stats.transport.acknowledgments_discarded;
      counters [21] := namve_statistic_p^.stats.transport.probe_packets_received;
      counters [22] := namve_statistic_p^.stats.transport.probe_packets_sent;
      counters [23] := namve_statistic_p^.stats.transport.probe_packets_discarded;
      counters [24] := namve_statistic_p^.stats.transport.retransmissions;
      counters [25] := namve_statistic_p^.stats.transport.error_packets_received;
      counters [26] := namve_statistic_p^.stats.transport.error_packets_sent;

      counters [27] := namve_statistic_p^.stats.session.synchronize_requests_received;
      counters [28] := namve_statistic_p^.stats.session.synchronize_requests_sent;
      counters [29] := namve_statistic_p^.stats.session.interrupt_requests_received;
      counters [30] := namve_statistic_p^.stats.session.interrupt_requests_sent;

      counters [31] := namve_statistic_p^.stats.routing.duplicate_received_ridus;
      counters [32] := namve_statistic_p^.stats.routing.ridus_received;
      counters [33] := namve_statistic_p^.stats.routing.ridus_sent;
      counters [34] := namve_statistic_p^.stats.routing.ridus_aged_out;
      counters [35] := namve_statistic_p^.stats.routing.table_recomputed_direct_network;
      counters [36] := namve_statistic_p^.stats.routing.table_recomputed_remote_network;
      counters [37] := namve_statistic_p^.stats.routing.table_partial_updates;

      counters [38] := namve_statistic_p^.stats.directory.current_registered_titles;
      counters [39] := namve_statistic_p^.stats.directory.current_cache_entries;
      counters [40] := namve_statistic_p^.stats.directory.directory_searches_active;
      counters [41] := namve_statistic_p^.stats.directory.directory_searches_initiated;
      counters [42] := namve_statistic_p^.stats.directory.translations_delivered;
      counters [43] := namve_statistic_p^.stats.directory.translations_found_in_local_dir;
      counters [44] := namve_statistic_p^.stats.directory.translations_found_in_cache;
      counters [45] := namve_statistic_p^.stats.directory.broadcast_translations_received;
      counters [46] := namve_statistic_p^.stats.directory.translations_broadcast;
      counters [47] := namve_statistic_p^.stats.directory.translations_received;
      counters [48] := namve_statistic_p^.stats.directory.translations_sent;
      counters [49] := namve_statistic_p^.stats.directory.translation_requests_broadcast;
      counters [50] := namve_statistic_p^.stats.directory.translation_requests_received;

      counters [51] := namve_statistic_p^.stats.file_access.active_connections;
      counters [52] := namve_statistic_p^.stats.file_access.file_access_requests;

      counters [53] := namve_statistic_p^.stats.buffer_manager.descriptor_pool_empty_count;
      counters [54] := namve_statistic_p^.stats.buffer_manager.containers_allocated [1]; {small containers}
      counters [55] := namve_statistic_p^.stats.buffer_manager.containers_allocated [2]; {large containers}
      counters [56] := namve_statistic_p^.stats.buffer_manager.containers_freed [1]; {small containers}
      counters [57] := namve_statistic_p^.stats.buffer_manager.containers_freed [2]; {large containers}

      counters [58] := namve_statistic_p^.stats.pp_buffer_pool.empty_pools_count [1]; {small containers}
      counters [59] := namve_statistic_p^.stats.pp_buffer_pool.empty_pools_count [2]; {large containers}
      counters [60] := namve_statistic_p^.stats.pp_buffer_pool.pools_replenished [1]; {small containers}
      counters [61] := namve_statistic_p^.stats.pp_buffer_pool.pools_replenished [2]; {large containers}

      sfp$emit_statistic (nac$namve_stats, '', ^counters, status);
    IFEND;

    IF stat_entry.stat = nac$osi_device_specific_stats THEN

{ Emit the osi_device_specific layer statistic for each directly connected network solution.

      networks_count := (UPPERBOUND (nav$global_osi_statistics.channel_connection_device^) -
            LOWERBOUND (nav$global_osi_statistics.channel_connection_device^)) + 1;

      IF osi_device_specific_statistic_p = NIL THEN
        IF networks_count > 0 THEN
          ALLOCATE osi_device_specific_statistic_p IN osv$task_private_heap^;
          ALLOCATE osi_device_specific_statistic_p^.statistics: [1 .. networks_count] IN
                osv$task_private_heap^;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      nap$get_osi_device_spec_stats (FALSE, osi_device_specific_statistic_p^);
      FOR i := 1 TO networks_count DO
        osi_device_specific_counter [1] := osi_device_specific_statistic_p^.statistics^ [i].
              credit_pdus_received;
        osi_device_specific_counter [2] := osi_device_specific_statistic_p^.statistics^ [i].credit_pdus_sent;
        osi_device_specific_counter [3] := osi_device_specific_statistic_p^.statistics^ [i].
              current_normal_connections;
        osi_device_specific_counter [4] := osi_device_specific_statistic_p^.statistics^ [i].
              current_priority_connections;
        osi_device_specific_counter [5] := osi_device_specific_statistic_p^.statistics^ [i].device_resets;
        osi_device_specific_counter [6] := osi_device_specific_statistic_p^.statistics^ [i].
              duplicate_connect_indications;
        osi_device_specific_counter [7] := osi_device_specific_statistic_p^.statistics^ [i].
              normal_send_pdus_queued;
        osi_device_specific_counter [8] := osi_device_specific_statistic_p^.statistics^ [i].
              pdus_processed_out_of_order;
        osi_device_specific_counter [9] := osi_device_specific_statistic_p^.statistics^ [i].priority_receive.
              pdu_average;
        osi_device_specific_counter [10] := osi_device_specific_statistic_p^.statistics^ [i].priority_receive.
              pdu_total;
        osi_device_specific_counter [11] := osi_device_specific_statistic_p^.statistics^ [i].
              priority_receive_expedited_pdus;
        osi_device_specific_counter [12] := osi_device_specific_statistic_p^.statistics^ [i].
              priority_receive_pdus_discarded;
        osi_device_specific_counter [13] := osi_device_specific_statistic_p^.statistics^ [i].priority_send.
              pdu_average;
        osi_device_specific_counter [14] := osi_device_specific_statistic_p^.statistics^ [i].priority_send.
              pdu_total;
        osi_device_specific_counter [15] := osi_device_specific_statistic_p^.statistics^ [i].
              priority_send_expedited_pdus;
        osi_device_specific_counter [16] := osi_device_specific_statistic_p^.statistics^ [i].
              priority_send_pdus_discarded;
        osi_device_specific_counter [17] := osi_device_specific_statistic_p^.statistics^ [i].
              priority_send_pdus_queued;
        osi_device_specific_counter [18] := osi_device_specific_statistic_p^.statistics^ [i].receive.
              pdu_average;
        osi_device_specific_counter [19] := osi_device_specific_statistic_p^.statistics^ [i].receive.
              pdu_total;
        osi_device_specific_counter [20] := osi_device_specific_statistic_p^.statistics^ [i].
              receive_pdus_discarded;
        osi_device_specific_counter [21] := osi_device_specific_statistic_p^.statistics^ [i].
              received_expedited_pdus;
        osi_device_specific_counter [22] := osi_device_specific_statistic_p^.statistics^ [i].send.pdu_average;
        osi_device_specific_counter [23] := osi_device_specific_statistic_p^.statistics^ [i].send.pdu_total;
        osi_device_specific_counter [24] := osi_device_specific_statistic_p^.statistics^ [i].
              send_expedited_pdus;
        osi_device_specific_counter [25] := osi_device_specific_statistic_p^.statistics^ [i].
              send_pdus_discarded;

        STRINGREP (descriptive_data, length, osi_device_specific_statistic_p^.statistics^ [i].
              network_id: #(16));
        sfp$emit_statistic (nac$osi_device_specific_stats, descriptive_data (1, length),
              ^osi_device_specific_counter, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    IF stat_entry.stat = nac$osi_stats THEN

{ Emit the NAM/VE OSI layer statistics.

      IF osi_statistic_p = NIL THEN
        ALLOCATE osi_statistic_p IN osv$task_private_heap^;
      IFEND;

      nap$get_osi_statistics (FALSE, osi_statistic_p^);
      osi_counters [1] := osi_statistic_p^.statistics.channel_connection.broadcast_connect_requests;
      osi_counters [2] := osi_statistic_p^.statistics.channel_connection.normal_connections;
      osi_counters [3] := osi_statistic_p^.statistics.channel_connection.priority_connections;

      osi_counters [4] := osi_statistic_p^.statistics.link_access_agent.current_saps_open;
      osi_counters [5] := osi_statistic_p^.statistics.link_access_agent.pdus_received;
      osi_counters [6] := osi_statistic_p^.statistics.link_access_agent.pdus_sent;
      osi_counters [7] := osi_statistic_p^.statistics.link_access_agent.total_bytes_received;
      osi_counters [8] := osi_statistic_p^.statistics.link_access_agent.total_bytes_sent;

      osi_counters [9] := osi_statistic_p^.statistics.network_access_agent.broadcasts_sent;
      osi_counters [10] := osi_statistic_p^.statistics.network_access_agent.pdus_received;
      osi_counters [11] := osi_statistic_p^.statistics.network_access_agent.pdus_sent;
      osi_counters [12] := osi_statistic_p^.statistics.network_access_agent.total_bytes_received;
      osi_counters [13] := osi_statistic_p^.statistics.network_access_agent.total_bytes_sent;

      osi_counters [14] := osi_statistic_p^.statistics.system_management_entity.cdna_address_route_unknown;
      osi_counters [15] := osi_statistic_p^.statistics.system_management_entity.
            cdna_address_select_device_reqs;
      osi_counters [16] := osi_statistic_p^.statistics.system_management_entity.
            noncdna_addr_select_device_reqs;
      osi_counters [17] := osi_statistic_p^.statistics.system_management_entity.noncdna_address_route_unknown;
      osi_counters [18] := osi_statistic_p^.statistics.system_management_entity.device_routing_queries;
      osi_counters [19] := osi_statistic_p^.statistics.system_management_entity.subnet_attribute_updates_rcvd;

      osi_counters [20] := osi_statistic_p^.statistics.transport_access_agent.data_pdus_received;
      osi_counters [21] := osi_statistic_p^.statistics.transport_access_agent.data_pdus_sent;
      osi_counters [22] := osi_statistic_p^.statistics.transport_access_agent.expedited_pdus_received;
      osi_counters [23] := osi_statistic_p^.statistics.transport_access_agent.expedited_pdus_sent;
      osi_counters [24] := osi_statistic_p^.statistics.transport_access_agent.total_bytes_received;
      osi_counters [25] := osi_statistic_p^.statistics.transport_access_agent.total_bytes_sent;

      sfp$emit_statistic (nac$osi_stats, '', ^osi_counters, status);
    IFEND;

  PROCEND emit_namve_statistics;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'Main procedure' ??
?? NEWTITLE := '[XDCL, #GATE] osp$emit_os_statistics' , EJECT ??

{ PURPOSE:
{   This procedure arranges for the system task to call again at the
{   appropriate time, and emits the correct statistic.

  PROCEDURE [XDCL, #GATE] osp$emit_os_statistics;

    VAR
      counter: array [1 .. 1] of integer,
      current_time: integer,
      emission_sets_copy: array [ost$emission_set_names] of ost$emission_set,
      emission_set: ost$emission_set_names,
      new_emit_time: integer,
      status: ost$status,
      stat_entry: 1 .. osc$max_stats_in_set;

    VAR
      aging_stats_p: ^ost$aging_stats,
      cpu_stats_p: ^ost$cpu_stats,
      jm_mm_stats_p: ^ost$jm_mm_stats,
      job_stats_p: ^ost$job_stats,
      mtr_reqs_p: ^ost$mtr_stats,
      page_fault_stats_p: ^ost$page_fault_stats,
      paging_stats_p: ^ost$paging_stats,
      pio_disk_space_stats_p: ^ost$disk_space_stats,
      pio_pp_stats_p: ^ost$disk_pp_stats,
      pio_unit_stats_p: ^ost$disk_unit_stats,
      server_page_fault_stats_p: ^ost$page_fault_stats,
      swap_stats_p: ^ost$swap_stats,
      system_job_stats_p: ^ost$job_stats,
      system_task_stats_p: ^ost$task_stats;

    status.normal := TRUE;

    aging_stats_p := NIL;
    cpu_stats_p := NIL;
    jm_mm_stats_p := NIL;
    job_stats_p:= NIL;
    mtr_reqs_p := NIL;
    page_fault_stats_p := NIL;
    paging_stats_p := NIL;
    pio_disk_space_stats_p := NIL;
    pio_pp_stats_p := NIL;
    pio_unit_stats_p := NIL;
    server_page_fault_stats_p := NIL;
    swap_stats_p := NIL;
    system_job_stats_p := NIL;
    system_task_stats_p := NIL;

    current_time := #FREE_RUNNING_CLOCK (0);
    counter [1] := current_time;

    sfp$emit_statistic (osc$begin_os_emission_set, '', ^counter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$emit_os_statistics_r1 (current_time, emission_sets_copy);

    FOR emission_set := LOWERVALUE (ost$emission_set_names) TO UPPERVALUE (ost$emission_set_names) DO
      IF (emission_sets_copy [emission_set].enabled) AND
            (emission_sets_copy [emission_set].next_emit_time <= current_time) THEN

        FOR stat_entry := 1 TO emission_sets_copy [emission_set].stat_count DO

          CASE emission_sets_copy [emission_set].stat_list [stat_entry].stat OF

          = nac$namve_stats .. nac$osi_device_specific_stats =
            IF nav$statistics_enabled AND nav$namve_active THEN
              emit_namve_statistics (emission_sets_copy [emission_set].stat_list [stat_entry], status);
            IFEND;

          = { OS0 } osc$job_and_memory_stats =
            emit_job_and_memory_stats (jm_mm_stats_p, status);

          = { OS1 } osc$paging_and_mtr_stats =
            emit_paging_and_mtr_stats (page_fault_stats_p, server_page_fault_stats_p, aging_stats_p,
                  mtr_reqs_p, paging_stats_p, status);

          = { OS2 - OS5 } osc$io_pp_usage .. osc$io_disk_space =
            emit_pio_statistics (emission_sets_copy [emission_set].stat_list [stat_entry],
                  pio_pp_stats_p, pio_unit_stats_p, pio_disk_space_stats_p, status);

          = { OS6 } osc$cpu_stats =
            emit_cpu_statistics (cpu_stats_p, mtr_reqs_p, status);

          = { OS7 } osc$service_class_stats =
            emit_service_class_stats (status);

          = { OS8 } osc$job_class_stats =
            emit_job_class_stats (status);

          = { OS9 } osc$system_job_stats =
            emit_system_job_stats (system_job_stats_p, status);

          = { OS10 } osc$system_task_stats =
            emit_system_task_stats (system_task_stats_p, status);

          = { OS11 } osc$memory_utilization_stats =
            emit_memory_stats (jm_mm_stats_p, status);

          = { OS12 } osc$job_count_stats =
            emit_job_count_stats (jm_mm_stats_p, status);

          = { OS13 } osc$page_streaming_stats =
            emit_page_streaming_stats (paging_stats_p, status);

          = { OS14 } osc$monitor_request_stats =
            emit_system_mr_stats (mtr_reqs_p, status);

          = { OS15 } osc$cpu_dispatching_stats =
            emit_cpu_dispatching_stats (cpu_stats_p,status);

          = { OS16 } osc$page_fault_rejected_stats =
            emit_page_fault_rejected_stats (page_fault_stats_p, server_page_fault_stats_p, status);

          = { OS9005 } osc$system_job_stats_hide  =
            emit_system_job_stats_hide (status);

          = { OS9007, OS9008 } osc$swap_state_stats, osc$swap_page_count_stats =
            emit_swap_statistics (emission_sets_copy [emission_set].stat_list [stat_entry],
                swap_stats_p, status);

          = { OS9010 } osc$aging_stats =
            emit_system_as_data (aging_stats_p, status);

          = { OS9011 } osc$mtr_req_stats =
            emit_system_mr_data (emission_sets_copy [emission_set].stat_list [stat_entry],
                mtr_reqs_p, status);

          = { OS9013 } osc$job_count_stats_hide =
            emit_job_count_stats_hide (jm_mm_stats_p, status);

          ELSE { No statistic is emitted }

          CASEND;

          IF NOT status.normal THEN
            aborted_condition := status.condition;
            pmp$log ('--An error ocurred while emitting periodic statistics--', status);
            status.normal := TRUE;
          IFEND;

        FOREND;
      IFEND;
    FOREND;

    sfp$emit_statistic (osc$end_os_emission_set, '', ^counter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Free buffers allocated by local procedures.

    IF aging_stats_p <> NIL THEN
      FREE aging_stats_p IN osv$task_private_heap^;
    IFEND;
    IF cpu_stats_p <> NIL THEN
      FREE cpu_stats_p IN osv$task_private_heap^;
    IFEND;
    IF jm_mm_stats_p <> NIL THEN
      FREE jm_mm_stats_p IN osv$task_private_heap^;
    IFEND;
    IF job_stats_p <> NIL THEN
      FREE job_stats_p IN osv$task_private_heap^;
    IFEND;
    IF mtr_reqs_p <> NIL THEN
      FREE mtr_reqs_p IN osv$task_private_heap^;
    IFEND;
    IF page_fault_stats_p <> NIL THEN
      FREE page_fault_stats_p IN osv$task_private_heap^;
    IFEND;
    IF paging_stats_p <> NIL THEN
      FREE paging_stats_p IN osv$task_private_heap^;
    IFEND;
    IF pio_disk_space_stats_p <> NIL THEN
      FREE pio_disk_space_stats_p IN osv$task_private_heap^;
    IFEND;
    IF pio_pp_stats_p <> NIL THEN
      FREE pio_pp_stats_p IN osv$task_private_heap^;
    IFEND;
    IF pio_unit_stats_p <> NIL THEN
      FREE pio_unit_stats_p IN osv$task_private_heap^;
    IFEND;
    IF server_page_fault_stats_p <> NIL THEN
      FREE server_page_fault_stats_p IN osv$task_private_heap^;
    IFEND;
    IF swap_stats_p <> NIL THEN
      FREE swap_stats_p in osv$task_private_heap^;
    IFEND;
    IF system_job_stats_p <> NIL THEN
      FREE system_job_stats_p in osv$task_private_heap^;
    IFEND;
    IF system_task_stats_p <> NIL THEN
      FREE system_task_stats_p in osv$task_private_heap^;
    IFEND;
    IF intranet_statistic_p <> NIL THEN
      IF intranet_statistic_p^.stats <> NIL THEN
        FREE intranet_statistic_p^.stats IN osv$task_private_heap^;
      IFEND;
      FREE intranet_statistic_p IN osv$task_private_heap^;
    IFEND;
    IF namve_statistic_p <> NIL THEN
      FREE namve_statistic_p IN osv$task_private_heap^;
    IFEND;
    IF osi_device_specific_statistic_p <> NIL THEN
      IF osi_device_specific_statistic_p^.statistics <> NIL THEN
        FREE osi_device_specific_statistic_p^.statistics IN osv$task_private_heap^;
      IFEND;
      FREE osi_device_specific_statistic_p IN osv$task_private_heap^;
    IFEND;
    IF osi_statistic_p <> NIL THEN
      FREE osi_statistic_p IN osv$task_private_heap^;
    IFEND;
  PROCEND osp$emit_os_statistics;
?? OLDTITLE ??
?? OLDTITLE ??
?? OLDTITLE ??
MODEND osm$emit_os_statistics;
*DECK DECK=OSM$EMIT_OS_STATISTICS_R1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Statistics : Emit Periodic Statistics' ??
MODULE osm$emit_os_statistics_r1;

{ PURPOSE:
{   This module manages the ring 1 data structures that control the emission
{   of the periodic statistics.
{ DESIGN:
{   This module contains interfaces to read and write the emission sets used
{   by the manage_periodic_statistics utility.  The procedures in this module
{   are called by procedures in the module osm$emit_os_statistics.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc nac$statistics_codes
*copyc lge$condition_codes
*copyc osc$processor_defined_registers
*copyc osc$statistics
*copyc ofe$error_codes
*copyc oss$mainframe_pageable
*copyc ost$data_id
*copyc ost$emission_sets
*copyc ost$execution_control_block
*copyc ost$heap
*copyc ost$signature_lock_status
*copyc syt$monitor_status
?? POP ??
*copyc osp$clear_mainframe_sig_lock
*copyc osp$initialize_sig_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_condition
*copyc osp$test_sig_lock
*copyc osv$mainframe_pageable_heap
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    osv$time_to_emit_statistics: [XDCL, #GATE, oss$mainframe_pageable] integer := osc$max_emit_time,
    osv$emission_sets_p: [oss$mainframe_pageable] ^array [ost$emission_set_names]
          of ost$emission_set := NIL,
    osv$emission_sets_lock: [oss$mainframe_pageable] ost$signature_lock := [0],
    osv$manps_user_lock: [oss$mainframe_pageable] ost$signature_lock := [0];

?? TITLE := 'initialize_emission_sets', EJECT ??

{ PURPOSE:
{   The purpose of this request is to allocate and initialize the data
{   structures for the os statistics emission_sets. Space is allocated in the
{   oss$mainframe_pageable_heap for the emission sets and the timing variables
{   in each of the emission sets are initialized.

  PROCEDURE initialize_emission_sets;

    VAR
      emission_set: ost$emission_set_names;

    ALLOCATE osv$emission_sets_p IN osv$mainframe_pageable_heap^;

    FOR emission_set := LOWERVALUE (ost$emission_set_names) TO UPPERVALUE (ost$emission_set_names) DO
      osv$emission_sets_p^ [emission_set].enabled := FALSE;
      osv$emission_sets_p^ [emission_set].period.hour := 23;
      osv$emission_sets_p^ [emission_set].period.minute := 59;
      osv$emission_sets_p^ [emission_set].period.second := 59;
      osv$emission_sets_p^ [emission_set].microsecond_period := (23 * 3600 + 59 * 60 + 59) * 100000;
      osv$emission_sets_p^ [emission_set].next_emit_time := osc$max_emit_time;
      osv$emission_sets_p^ [emission_set].stat_count := 0;
    FOREND;

  PROCEND initialize_emission_sets;
?? TITLE := '[XDCL, #GATE] osp$emit_os_statistics_r1', EJECT ??

{ PURPOSE:
{   The purpose of this request is to supply the caller with a copy of the
{   emission sets.  The emission sets are then checked to determine the next
{   emit time for each set and the next emit time for the sets.
{
{       OSP$EMIT_OS_STATISTICS_R1 (CURRENT_TIME, EMISSION_SETS_COPY)
{
{ CURRENT_TIME: (input)  This parameter specifies the current time.  It is used
{       to compute the next emit times.  This value is passed from the ring 3
{       code to insure that the two procedures use exactly the same value for
{       the current time.
{
{ EMISSION_SETS_COPY: (output)  This parameter specifies a copy of the emission
{       sets.

  PROCEDURE [XDCL, #GATE] osp$emit_os_statistics_r1
    (    current_time: integer;
     VAR emission_sets_copy: array [ost$emission_set_names] of ost$emission_set);

    VAR
      emission_set: ost$emission_set_names,
      new_emit_time: integer;

    osp$set_mainframe_sig_lock (osv$emission_sets_lock);

{ Copy the emission sets.

    emission_sets_copy := osv$emission_sets_p^;

{ Set the next time to emit statistics to max for now.

    osv$time_to_emit_statistics := osc$max_emit_time;

{ Update the next time to emit in each of the enabled sets.

    FOR emission_set := LOWERVALUE (ost$emission_set_names) TO UPPERVALUE (ost$emission_set_names) DO
      IF (osv$emission_sets_p^ [emission_set].enabled) THEN
        IF (osv$emission_sets_p^ [emission_set].next_emit_time <= current_time) THEN
          IF emission_set = osc$immediate_emission_set THEN
            osv$emission_sets_p^ [emission_set].enabled := FALSE;
            osv$emission_sets_p^ [emission_set].next_emit_time := osc$max_emit_time;
          ELSE
            new_emit_time := osv$emission_sets_p^ [emission_set].
                  next_emit_time + osv$emission_sets_p^ [emission_set].microsecond_period;
            IF new_emit_time > osc$max_emit_time THEN
              osv$emission_sets_p^ [emission_set].next_emit_time := osc$max_emit_time;
            ELSE
              osv$emission_sets_p^ [emission_set].next_emit_time := new_emit_time;
            IFEND;
          IFEND;
        IFEND;

{ Compute the next time to emit the periodic statistics.

        IF (osv$emission_sets_p^ [emission_set].next_emit_time < osv$time_to_emit_statistics) THEN
          osv$time_to_emit_statistics := osv$emission_sets_p^ [emission_set].next_emit_time;
        IFEND;
      IFEND;
    FOREND;

    osp$clear_mainframe_sig_lock (osv$emission_sets_lock);

  PROCEND osp$emit_os_statistics_r1;
?? TITLE := '[XDCL, #GATE] osp$read_emission_sets_r1', EJECT ??

{ PURPOSE:
{   The purpose of this request is to return a copy of the emission sets data.
{
{       OSP$READ_EMISSION_SETS_R1 (EMISSION_SETS_COPY, STATUS)
{
{ EMISSION_SETS_COPY: (output)  This parameter specifies a copy of the emission
{       sets.
{
{ STATUS: (output)  This parameter specifies the request status.

  PROCEDURE [XDCL, #GATE] osp$read_emission_sets_r1
    (VAR emission_sets_copy: array [ost$emission_set_names] of ost$emission_set;
     VAR status: ost$status);

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (osv$emission_sets_lock);
    IF osv$emission_sets_p = NIL THEN
      initialize_emission_sets;
    IFEND;
    emission_sets_copy := osv$emission_sets_p^;
    osp$clear_mainframe_sig_lock (osv$emission_sets_lock);

  PROCEND osp$read_emission_sets_r1;
?? TITLE := '[XDCL, #GATE] osp$release_manps_lock_r1', EJECT ??

{ PURPOSE:
{   The purpose of this request is to release the osv$manps_user_lock if
{   it is held by the calling task.
{
{       OSP$RELEASE_MANPS_LOCK_R1
{

  PROCEDURE [XDCL, #GATE] osp$release_manps_lock_r1;

    VAR
      lock_status: ost$signature_lock_status;

    osp$test_sig_lock (osv$manps_user_lock, lock_status);
    IF (lock_status = osc$sls_locked_by_current_task) THEN
      osp$clear_mainframe_sig_lock (osv$manps_user_lock);
    IFEND;

  PROCEND osp$release_manps_lock_r1;
?? TITLE := '[XDCL, #GATE] osp$reserve_manps_lock_r1', EJECT ??

{ PURPOSE:
{   The purpose of this request is to reserve the osv$manps_user_lock for
{   the calling task.
{
{       OSP$RESERVE_MANPS_LOCK_R1 (STATUS)
{
{ STATUS: (output)  This parameter specifies the request status.

  PROCEDURE [XDCL, #GATE] osp$reserve_manps_lock_r1
    (VAR status: ost$status);

    VAR
      lock_set_for_this_task: boolean,
      lock_status: ost$signature_lock_status;

    status.normal := TRUE;
    lock_set_for_this_task := FALSE;

    REPEAT
      osp$test_sig_lock (osv$manps_user_lock, lock_status);
      IF (lock_status = osc$sls_locked_by_current_task) THEN
        lock_set_for_this_task := TRUE;
      ELSEIF (lock_status = osc$sls_not_locked) THEN
        osp$set_mainframe_sig_lock (osv$manps_user_lock);
      ELSE                {(lock_status = osc$sls_locked_by_another_task)
        osp$set_status_condition (lge$write_privilege_reserved, status);
        RETURN;
      IFEND;
    UNTIL lock_set_for_this_task;

  PROCEND osp$reserve_manps_lock_r1;
?? TITLE := '[XDCL, #GATE] osp$write_emission_sets_r1', EJECT ??

{ PURPOSE:
{   This procedure updates the emission sets and the emission set emit times.
{   The new value for osv$time_to_emit_statistics indicates the next time
{   when osp$emit_os_statistics should be called.
{
{       OSP$WRITE_EMISSION_SETS_R1 (EMISSION_SETS, STATUS)
{
{ EMISSION_SETS: (input)  This parameter specifies the new value for the
{       emission sets.
{
{ STATUS: (output)  This parameter specifies the request status.

  PROCEDURE [XDCL, #GATE] osp$write_emission_sets_r1
    (VAR emission_sets: array [ost$emission_set_names] of ost$emission_set;
     VAR status: ost$status);

    VAR
      current_time: integer,
      local_time_to_emit_statistics: integer,
      lock_status: ost$signature_lock_status,
      new_emit_time: integer,
      period_has_changed: boolean,
      reset_emission_times: boolean,
      state_has_changed: boolean,
      test_emission_set: ost$emission_set_names;

    status.normal := TRUE;

    osp$test_sig_lock (osv$manps_user_lock, lock_status);
    IF NOT (lock_status = osc$sls_locked_by_current_task) THEN
      osp$set_status_condition (lge$write_priv_not_reserved, status);
      RETURN;
    IFEND;
    osp$set_mainframe_sig_lock (osv$emission_sets_lock);
    IF osv$emission_sets_p = NIL THEN
      initialize_emission_sets;
    IFEND;

    osv$time_to_emit_statistics := osc$max_emit_time;
    local_time_to_emit_statistics := osc$max_emit_time;
    current_time := #FREE_RUNNING_CLOCK (0);

{  The following FOR loop resets the next_time_to_emit for each enabled emission set
{  and keeps track of the minimum value to use as the next emission time.
{  If one of the two conditions occur the next_time_to_emit will be recalculated:
{  1)  the state has been changed from disabled to enabled.
{  2)  the period has been changed AND the next_time_to_emit is greater than the
{      current time
{  Otherwise one of two conditions could occur and the current value for
{  next_time_to_emit will be used.
{  1)  the period has not changed.
{  2)  the period has changed but the current value for next_time_to_emit is
{      less than or equal to the current time.  This means that an emission was about to occur.

    FOR test_emission_set := LOWERVALUE (ost$periodic_emission_sets)
          TO UPPERVALUE (ost$periodic_emission_sets) DO
      IF (emission_sets [test_emission_set].enabled) THEN
        period_has_changed := osv$emission_sets_p^ [test_emission_set].microsecond_period <>
              emission_sets [test_emission_set].microsecond_period;
        state_has_changed := osv$emission_sets_p^ [test_emission_set].enabled <>
              emission_sets [test_emission_set].enabled;
        IF state_has_changed OR
          (period_has_changed AND (osv$emission_sets_p^ [test_emission_set].next_emit_time > current_time))
          THEN
          new_emit_time := current_time + emission_sets [test_emission_set].microsecond_period;
          IF new_emit_time > osc$max_emit_time THEN
            emission_sets [test_emission_set].next_emit_time := osc$max_emit_time;
          ELSE
            emission_sets [test_emission_set].next_emit_time := new_emit_time;
          IFEND;
        ELSE
          emission_sets [test_emission_set].next_emit_time :=
                osv$emission_sets_p^ [test_emission_set].next_emit_time;
        IFEND;
        IF emission_sets [test_emission_set].next_emit_time < local_time_to_emit_statistics THEN
          local_time_to_emit_statistics := emission_sets [test_emission_set].next_emit_time;
        IFEND;
      IFEND;
    FOREND;

    IF emission_sets [osc$immediate_emission_set].enabled THEN
      emission_sets [osc$immediate_emission_set].next_emit_time := current_time;
      local_time_to_emit_statistics := current_time;
    IFEND;

    osv$emission_sets_p^ := emission_sets;
    osv$time_to_emit_statistics := local_time_to_emit_statistics;
    osp$clear_mainframe_sig_lock (osv$emission_sets_lock);

  PROCEND osp$write_emission_sets_r1;
?? OLDTITLE  ??
?? OLDTITLE  ??
MODEND osm$emit_os_statistics_r1;
*DECK DECK=OSM$EXCEPTION_CONDITION_CODES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc OSD$DEFAULT_PRAGMATS

MODULE osm$exception_condition_codes;

*copyc osd$exceptions

MODEND osm$exception_condition_codes;
*DECK DECK=OSM$FAMILY_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
MODULE osm$family_manager;
?? PUSH (LISTEXT := ON) ??
*copyc dft$family_access
*copyc dft$partner_mainframe_list
*copyc dft$served_family_table_index
*copyc osd$integer_limits
*copyc osp$clear_mainframe_sig_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc oss$mainframe_pageable
*copyc ost$family_table
*copyc ost$name
*copyc ost$status
*copyc ost$user_identification
*copyc osv$mainframe_wired_heap
*copyc pfe$error_condition_codes
*copyc pme$program_services_exceptions
*copyc pmt$binary_mainframe_id
*copyc pmt$family_name_count
*copyc pmt$family_name_list
*copyc std$set_name
?? POP ??

  VAR
    osv$family_table_lock: [STATIC, oss$mainframe_pageable] ost$signature_lock := [0],
    osv$family_table: [XDCL, #GATE, oss$mainframe_pageable] ^ost$family_table := NIL;

?? TITLE := 'PROCEDURE osp$add_family', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$add_family
    (    family: ost$name;
         set_name: stt$set_name;
     VAR status: ost$status);

*copyc osp$get_set_name

    VAR
      i: integer,
      ignore_set_name: stt$set_name,
      new_family_table: ^ost$family_table;

    osp$set_mainframe_sig_lock (osv$family_table_lock);

    IF osv$family_table = NIL THEN
      ALLOCATE osv$family_table: [1 .. 100] IN osv$mainframe_wired_heap^;
      FOR i := 1 TO 100 DO
        osv$family_table^ [i].family_name := osc$null_name;
      FOREND;
    IFEND;

    osp$get_set_name (family, ignore_set_name, status);
    IF status.normal THEN
      {If family already exists, error !
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$family_already_exists, family, status);
      osp$clear_mainframe_sig_lock (osv$family_table_lock);
      RETURN;
    IFEND;

    status.normal := TRUE;

    FOR i := 1 TO UPPERBOUND (osv$family_table^) DO
      IF osv$family_table^ [i].family_name = osc$null_name THEN
        osv$family_table^ [i].family_name := family;
        osv$family_table^ [i].set_name := set_name;
        osv$family_table^ [i].default_family_access := $dft$family_access [];
        osv$family_table^ [i].p_client_access_list := NIL;
        osp$clear_mainframe_sig_lock (osv$family_table_lock);
        RETURN;
      IFEND;
    FOREND;

    {Table is full, expand
    ALLOCATE new_family_table: [1 .. 2 * UPPERBOUND (osv$family_table^)] IN osv$mainframe_wired_heap^;
    FOR i := 1 TO UPPERBOUND (osv$family_table^) DO
      new_family_table^ [i] := osv$family_table^ [i];
    FOREND;
    FOR i := UPPERBOUND (osv$family_table^) + 1 TO UPPERBOUND (new_family_table^) DO
      new_family_table^ [i].family_name := osc$null_name;
    FOREND;

    new_family_table^ [UPPERBOUND (osv$family_table^) + 1].family_name := family;
    new_family_table^ [UPPERBOUND (osv$family_table^) + 1].set_name := set_name;
    new_family_table^ [UPPERBOUND (osv$family_table^) + 1].default_family_access := $dft$family_access [];
    new_family_table^ [UPPERBOUND (osv$family_table^) + 1].p_client_access_list := NIL;

    FREE osv$family_table IN osv$mainframe_wired_heap^;
    osv$family_table := new_family_table;
    osp$clear_mainframe_sig_lock (osv$family_table_lock);

  PROCEND osp$add_family;
?? TITLE := 'PROCEDURE [XDCL, #GATE] osp$check_client_leveled_access', EJECT ??
*copy osh$check_client_leveled_access

  PROCEDURE [XDCL, #GATE] osp$check_client_leveled_access
    (    family_name: ost$name;
     VAR leveled_access: boolean);

    VAR
      family_index: ost$non_negative_integers,
      p_current: ^dft$family_table_client_entry;

    leveled_access := FALSE;
    IF (osv$family_table = NIL) OR (family_name = osc$null_name) THEN
      RETURN;
    IFEND;

  /find_family/
    FOR family_index := 1 TO UPPERBOUND (osv$family_table^) DO
      IF (osv$family_table^ [family_index].family_name <> osc$null_name) AND
            (osv$family_table^ [family_index].family_name = family_name) THEN
        p_current := osv$family_table^ [family_index].p_client_access_list;

        WHILE (p_current <> NIL) AND (NOT leveled_access) DO
          leveled_access := (dfc$job_leveling_access IN p_current^.family_access);
          p_current := p_current^.p_next_client;
        WHILEND;

        EXIT /find_family/;
      IFEND;
    FOREND /find_family/;

  PROCEND osp$check_client_leveled_access;
?? TITLE := 'PROCEDURE osp$delete_family', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$delete_family
    (    family: ost$name;
     VAR status: ost$status);

    VAR
      i: integer,
      p_current: ^dft$family_table_client_entry,
      p_next: ^dft$family_table_client_entry;

    osp$set_mainframe_sig_lock (osv$family_table_lock);

    IF osv$family_table = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_family, family, status);
      osp$clear_mainframe_sig_lock (osv$family_table_lock);
      RETURN;
    IFEND;

    status.normal := TRUE;

    FOR i := 1 TO UPPERBOUND (osv$family_table^) DO
      IF osv$family_table^ [i].family_name = family THEN
        osv$family_table^ [i].family_name := osc$null_name;
        p_current := osv$family_table^ [i].p_client_access_list;

        WHILE p_current <> NIL DO
          p_next := p_current^.p_next_client;
          FREE p_current IN osv$mainframe_wired_heap^;
          p_current := p_next;
        WHILEND;

        osv$family_table^ [i].set_name := osc$null_name;
        osp$clear_mainframe_sig_lock (osv$family_table_lock);
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_family, family, status);
    osp$clear_mainframe_sig_lock (osv$family_table_lock);

  PROCEND osp$delete_family;
?? TITLE := 'PROCEDURE osp$get_accessed_clients', EJECT ??
*copy osh$get_accessed_clients

  PROCEDURE [XDCL, #GATE] osp$get_accessed_clients
    (    p_binary_client_list {output} : ^array [1 .. * ] of pmt$binary_mainframe_id;
     VAR client_count: 0 .. dfc$maximum_partner_mainframes);

    VAR
      client_index: 0 .. dfc$maximum_partner_mainframes,
      family_index: ost$non_negative_integers,
      match: boolean,
      p_current: ^dft$family_table_client_entry;

    client_count := 0;

  /search_families/
    FOR family_index := LOWERBOUND (osv$family_table^) TO UPPERBOUND (osv$family_table^) DO
      IF osv$family_table^ [family_index].family_name = osc$null_name THEN
        CYCLE /search_families/;
      IFEND;
      p_current := osv$family_table^ [family_index].p_client_access_list;

    /search_clients/
      WHILE p_current <> NIL DO
        match := FALSE;
      /check_for_match/
        FOR client_index := 1 to client_count DO
          IF p_current^.client_binary_id = p_binary_client_list^ [client_index] THEN
            match := TRUE;
            EXIT /check_for_match/;
          IFEND;
        FOREND /check_for_match/;
        IF NOT match THEN
          client_count := client_count + 1;
          IF p_binary_client_list <> NIL THEN
            IF UPPERBOUND (p_binary_client_list^) >= client_count THEN
              p_binary_client_list^ [client_count] := p_current^.client_binary_id;
            IFEND;
          IFEND;
        IFEND;
        p_current := p_current^.p_next_client;
      WHILEND /search_clients/;

    FOREND /search_families/;

  PROCEND osp$get_accessed_clients;
?? TITLE := 'PROCEDURE osp$get_accessed_families', EJECT ??
*copy osh$get_accessed_families

  PROCEDURE [XDCL, #GATE] osp$get_accessed_families
    (    p_family_list {output} : ^array [1 .. * ] of ost$family_name;
     VAR family_count: 0 .. dfc$max_family_ptr_array_size);

    VAR
      i: ost$non_negative_integers;

    family_count := 0;

    IF osv$family_table = NIL THEN
      RETURN;
    IFEND;

  /find_families/
    FOR i := 1 TO UPPERBOUND (osv$family_table^) DO
      IF osv$family_table^ [i].family_name = osc$null_name THEN
        CYCLE /find_families/;
      IFEND;
      IF (osv$family_table^ [i].default_family_access <> $dft$family_access []) OR
            (osv$family_table^ [i].p_client_access_list <> NIL) THEN
        family_count := family_count + 1;
        IF p_family_list <> NIL THEN
          IF family_count <= UPPERBOUND (p_family_list^) THEN
            p_family_list^ [family_count] := osv$family_table^ [i].family_name;
          IFEND;
        IFEND;
      IFEND;
    FOREND /find_families/;

  PROCEND osp$get_accessed_families;
?? TITLE := 'PROCEDURE osp$get_client_family_access', EJECT ??
*copy osh$get_client_family_access

  PROCEDURE [XDCL, #GATE] osp$get_client_family_access
    (    client_binary_id: pmt$binary_mainframe_id;
         family_name: ost$family_name;
     VAR family_access: dft$family_access);

    VAR
      family_index: ost$non_negative_integers,
      p_current: ^dft$family_table_client_entry;

    family_access := $dft$family_access [];
    IF osv$family_table = NIL THEN
      RETURN;
    IFEND;

  /find_family/
    FOR family_index := 1 TO UPPERBOUND (osv$family_table^) DO
      IF osv$family_table^ [family_index].family_name = family_name THEN
        family_access := osv$family_table^ [family_index].default_family_access;
        p_current := osv$family_table^ [family_index].p_client_access_list;

      /find_client/
        WHILE p_current <> NIL DO
          IF p_current^.client_binary_id = client_binary_id THEN
            family_access := p_current^.family_access;
            EXIT /find_client/;
          IFEND;
          p_current := p_current^.p_next_client;
        WHILEND /find_client/;

        EXIT /find_family/;
      IFEND;
    FOREND /find_family/;

  PROCEND osp$get_client_family_access;

?? TITLE := 'PROCEDURE osp$get_family_names_by_set', EJECT ??

{ PURPOSE:
{   This procedure returns a list of family names assigned to a
{   given set.


  PROCEDURE [XDCL, #GATE] osp$get_family_names_by_set
    (    set_name: stt$set_name;
     VAR family_names: pmt$family_name_list;
     VAR name_count: pmt$family_name_count;
     VAR status: ost$status);

    VAR
      i: integer;

    IF osv$family_table = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_family, '', status);
      RETURN;
    IFEND;
    status.normal := TRUE;
    name_count := 0;

    FOR i := 1 TO UPPERBOUND (osv$family_table^) DO
      IF (osv$family_table^ [i].family_name <> osc$null_name) AND
           (osv$family_table^ [i].set_name = set_name) THEN
        name_count := name_count + 1;
        IF name_count <= UPPERBOUND (family_names) THEN
          family_names [name_count] := osv$family_table^ [i].family_name;
        IFEND;
      IFEND;
    FOREND;

  PROCEND osp$get_family_names_by_set;

?? TITLE := 'PROCEDURE osp$get_family_names', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_family_names
    (VAR family_names: pmt$family_name_list;
     VAR name_count: pmt$family_name_count;
     VAR status: ost$status);

    VAR
      i: integer;

    IF osv$family_table = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_family, '', status);
      RETURN;
    IFEND;

    status.normal := TRUE;
    name_count := 0;

    FOR i := 1 TO UPPERBOUND (osv$family_table^) DO
      IF osv$family_table^ [i].family_name <> osc$null_name THEN
        name_count := name_count + 1;
        IF name_count <= UPPERBOUND (family_names) THEN
          family_names [name_count] := osv$family_table^ [i].family_name;
        IFEND;
      IFEND;
    FOREND;

  PROCEND osp$get_family_names;

?? TITLE := '  [XDCL, #GATE] osp$get_families_for_client', EJECT ??
*copy osh$get_families_for_client

  PROCEDURE [XDCL, #GATE] osp$get_families_for_client
    (    client_binary_id: pmt$binary_mainframe_id;
         p_family_list { output } : ^array [1 .. * ] of ost$family_name;
         p_access_list { output } : ^array [1 .. * ] of dft$family_access;
     VAR family_count: 0 .. dfc$max_family_ptr_array_size);


    VAR
      family_access: dft$family_access,
      family_index: integer,
      family_name: ost$family_name,
      p_current: ^dft$family_table_client_entry;

    family_count := 0;

  /search_families/
    FOR family_index := LOWERBOUND (osv$family_table^) TO UPPERBOUND (osv$family_table^) DO
      family_name := osv$family_table^ [family_index].family_name;
      IF family_name = osc$null_name THEN
        CYCLE /search_families/;
      IFEND;
      family_access := osv$family_table^ [family_index].default_family_access;
      p_current := osv$family_table^ [family_index].p_client_access_list;


    /search_clients/
      WHILE p_current <> NIL DO
        IF p_current^.client_binary_id = client_binary_id THEN
          family_access := p_current^.family_access;
          EXIT /search_clients/;
        IFEND;
        p_current := p_current^.p_next_client;
      WHILEND /search_clients/;

      IF family_access <> $dft$family_access [] THEN
        family_count := family_count + 1;
        IF p_family_list <> NIL THEN
          IF UPPERBOUND (p_family_list^) >= family_count THEN
            p_family_list^ [family_count] := family_name;
          IFEND;
        IFEND;
        IF p_access_list <> NIL THEN
          IF UPPERBOUND (p_access_list^) >= family_count THEN
            p_access_list^ [family_count] := family_access;
          IFEND;
        IFEND;
      IFEND;
    FOREND /search_families/;

  PROCEND osp$get_families_for_client;
?? TITLE := '    [XDCL, #GATE] osp$set_client_access', EJECT ??
*copy osh$set_client_access

  PROCEDURE [XDCL, #GATE] osp$set_client_access
    (    family: ost$family_name;
         family_access: dft$family_access;
         all_clients: boolean;
         p_binary_client_list: ^array [1 .. * ] of pmt$binary_mainframe_id;
         number_of_clients: 0 .. dfc$maximum_partner_mainframes;
     VAR status: ost$status);

    VAR
      family_index: integer,
      index: integer,
      p_client_entry: ^dft$family_table_client_entry,
      p_next_entry: ^dft$family_table_client_entry,
      p_set: ^array [1 .. * ] of boolean;

    IF osv$family_table = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_family, family, status);
      RETURN;
    IFEND;

    status.normal := TRUE;

  /find/
    FOR family_index := 1 TO UPPERBOUND (osv$family_table^) DO
      IF osv$family_table^ [family_index].family_name = family THEN
        EXIT /find/;
      IFEND;
    FOREND /find/;

    IF osv$family_table^ [family_index].family_name <> family THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_family, family, status);
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (osv$family_table_lock);

    IF all_clients AND (osv$family_table^ [family_index].p_client_access_list = NIL) THEN
      osv$family_table^ [family_index].default_family_access := family_access;
      osp$clear_mainframe_sig_lock (osv$family_table_lock);
      RETURN;
    IFEND;

    IF (osv$family_table^ [family_index].p_client_access_list = NIL) THEN
      ALLOCATE p_client_entry IN osv$mainframe_wired_heap^;
      p_client_entry^.client_binary_id := p_binary_client_list^ [1];
      p_client_entry^.family_access := family_access;
      p_client_entry^.p_next_client := NIL;
      osv$family_table^ [family_index].p_client_access_list := p_client_entry;
    ELSE
      p_client_entry := osv$family_table^ [family_index].p_client_access_list;
    IFEND;

    IF all_clients THEN
      osv$family_table^ [family_index].default_family_access := family_access;
      WHILE p_client_entry <> NIL DO
        p_client_entry^.family_access := family_access;
        p_client_entry := p_client_entry^.p_next_client;
      WHILEND;
      osp$clear_mainframe_sig_lock (osv$family_table_lock);
      RETURN;
    IFEND;

{ There is at least one unique entry in the client list chain and the
{  client list specified contains at least one unique entry - not ALL.

{ p_client_entry points to the first entry in the linked list.

    p_next_entry := p_client_entry;
    PUSH p_set: [1 .. number_of_clients];
    FOR index := 1 TO number_of_clients DO
      p_set^ [index] := FALSE;
    FOREND;


{For each entry in the linked list, check if that client id is specifed.
{If so, update family access and flag the input entry as beiing set

    WHILE p_next_entry <> NIL DO
      p_client_entry := p_next_entry;

    /set_linked/
      FOR index := 1 TO number_of_clients DO
        IF p_client_entry^.client_binary_id = p_binary_client_list^ [index] THEN
          p_client_entry^.family_access := family_access;
          p_set^ [index] := TRUE;
          EXIT /set_linked/;
        IFEND;
      FOREND /set_linked/;

      p_next_entry := p_client_entry^.p_next_client;
    WHILEND;

{Add to the linked list any specified clients which are not linked

    FOR index := 1 TO number_of_clients DO
      IF NOT p_set^ [index] THEN
        ALLOCATE p_next_entry IN osv$mainframe_wired_heap^;
        p_next_entry^.client_binary_id := p_binary_client_list^ [index];
        p_next_entry^.family_access := family_access;
        p_next_entry^.p_next_client := NIL;
        p_client_entry^.p_next_client := p_next_entry;
        p_client_entry := p_next_entry;
      IFEND;
    FOREND;

    osp$clear_mainframe_sig_lock (osv$family_table_lock);

  PROCEND osp$set_client_access;

MODEND osm$family_manager
*DECK DECK=OSM$FETCH_STATISTICAL_DATA EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operating System : fetch statistical data' ??
MODULE osm$fetch_statistical_data;


{
{  PURPOSE:
{     This module is used as an interface between modules in XLJ2DD
{     and those that can't be called from above ring 3.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ofe$error_codes
*copyc jmt$dispatching_priority
*copyc jmt$ijl_ordinal
*copyc jmt$job_class
*copyc jmt$job_scheduler_statistics
*copyc jmt$rb_service_class_statistics
*copyc jmt$service_class_index
*copyc ost$data_id
*copyc ost$hardware_subranges
*copyc oss$task_shared
*copyc ost$170_os_type
?? POP ??
*copyc jmv$job_class_table_p
*copyc jmv$job_counts
*copyc jmv$job_sched_serv_class_stats
*copyc jmv$job_scheduler_statistics
*copyc jmv$max_ajl_ordinal_in_use
*copyc jmv$maximum_job_class_in_use
*copyc jmv$max_service_class_in_use
*copyc jmv$service_classes
*copyc jmv$swapin_candidate_queue
*copyc i#call_monitor
*copyc iot$disk_usage
*copyc tmv$cpu_execution_statistics
*copyc jmv$ijl_p
*copyc mmv$paging_statistics
*copyc mmv$pf_statistics
*copyc mmv$df_read_server_pf_stats
*copyc mtv$request_table
*copyc mtv$total_nos_cpu_time
*copyc mmv$aging_statistics
*copyc osv$task_shared_heap
*copyc avp$configuration_administrator
*copyc avp$system_displays
*copyc jmp$get_ijle_p
*copyc tmp$fetch_job_statistics
*copyc syv$nos_system_time
*copyc syp$store_system_constant
*copyc syp$fetch_system_constant
*copyc jmp$get_job_counts
*copyc mmp$get_page_q_counts
*copyc jsv$swap_state_statistics
*copyc jsv$enable_swap_file_statistics
*copyc jsv$swap_file_statistics
*copyc jsv$ijl_swap_queue_list
*copyc jsv$swap_file_page_count
*copyc jmv$job_scheduler_statistics
*copyc jmt$active_job_list
*copyc mtv$cst0
*copyc osv$cpus_physically_configured
*copyc syp$reset_maximum_time
*copyc jsp$reset_maximum_time
*copyc osp$get_rvsn_by_lun
*copyc osp$set_status_abnormal
*copyc pmp$get_170_os_type
*copyc cmp$get_element_information
*copyc cmp$pc_get_logical_unit
*copyc cmt$element_descriptor
*copyc cmv$logical_unit_table
*copyc dmp$calculate_remaining_space
*copyc iov$disk_pp_usage_p
*copyc iov$disk_unit_usage_p
?? EJECT ??

  VAR
    c170_os_type_known: [STATIC] boolean := FALSE,
    c170_os_type: [STATIC] ost$170_os_type := osc$ot7_none,
    last_aging_stats_p: [STATIC, oss$task_shared] ^ost$aging_stats := NIL,
    last_cpu_stats_p: [STATIC, oss$task_shared] ^ost$cpu_stats := NIL,
    last_job_stats_p: [STATIC, oss$task_shared] ^ost$job_stats := NIL,
    last_mtr_stats_p: [STATIC, oss$task_shared] ^ost$mtr_stats := NIL,
    last_page_stats_p: [STATIC, oss$task_shared] ^ost$page_fault_stats := NIL,
    last_server_page_stats_p: [STATIC, oss$task_shared] ^ost$page_fault_stats := NIL,
    last_paging_stats_p: [STATIC, oss$task_shared] ^ost$paging_stats := NIL,
    last_pio_pp_stats_p: [STATIC, oss$task_shared] ^ost$disk_pp_stats := NIL,
    last_pio_unit_stats_p: [STATIC, oss$task_shared] ^ost$disk_unit_stats := NIL,
    last_sched_stats_p: [STATIC, oss$task_shared] ^ost$sched_stats := NIL,
    last_swap_stats_p: [STATIC, oss$task_shared] ^ost$swap_stats := NIL,
    last_swap_file_stats_p: [STATIC, oss$task_shared] ^ost$swap_file_stats := NIL;

?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_aging_stats
    (    incremental: boolean;
     VAR user_aging_stats: ost$aging_stats;
     VAR status: ost$status);

    VAR
      local_aging_stats: ost$aging_stats;

    status.normal := TRUE;
    local_aging_stats.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;
    local_aging_stats.aging_stats := mmv$aging_statistics;
    user_aging_stats := local_aging_stats;
    IF incremental AND (last_aging_stats_p <> NIL) THEN
      user_aging_stats.time := user_aging_stats.time - last_aging_stats_p^.time;
      user_aging_stats.aging_stats.force_aggressive_aging :=
            user_aging_stats.aging_stats.force_aggressive_aging -
            last_aging_stats_p^.aging_stats.force_aggressive_aging;
      user_aging_stats.aging_stats.aggressive_age_shared_queue :=
            user_aging_stats.aging_stats.aggressive_age_shared_queue -
            last_aging_stats_p^.aging_stats.aggressive_age_shared_queue;
      user_aging_stats.aging_stats.aggressive_age_job_queues :=
            user_aging_stats.aging_stats.aggressive_age_job_queues -
            last_aging_stats_p^.aging_stats.aggressive_age_job_queues;
      user_aging_stats.aging_stats.aggressive_aging_failed :=
            user_aging_stats.aging_stats.aggressive_aging_failed -
            last_aging_stats_p^.aging_stats.aggressive_aging_failed;
      user_aging_stats.aging_stats.age_cp_bound_job := user_aging_stats.aging_stats.age_cp_bound_job -
            last_aging_stats_p^.aging_stats.age_cp_bound_job;
      user_aging_stats.aging_stats.remove_unmodified_page_from_ws :=
            user_aging_stats.aging_stats.remove_unmodified_page_from_ws -
            last_aging_stats_p^.aging_stats.remove_unmodified_page_from_ws;
      user_aging_stats.aging_stats.remove_modified_page_from_ws :=
            user_aging_stats.aging_stats.remove_modified_page_from_ws -
            last_aging_stats_p^.aging_stats.remove_modified_page_from_ws;
      user_aging_stats.aging_stats.page_written_to_disk :=
            user_aging_stats.aging_stats.page_written_to_disk -
            last_aging_stats_p^.aging_stats.page_written_to_disk;
      user_aging_stats.aging_stats.multiple_pages_written_to_disk :=
            user_aging_stats.aging_stats.multiple_pages_written_to_disk -
            last_aging_stats_p^.aging_stats.multiple_pages_written_to_disk;
      user_aging_stats.aging_stats.calls_to_age_jws := user_aging_stats.aging_stats.calls_to_age_jws -
            last_aging_stats_p^.aging_stats.calls_to_age_jws;
      user_aging_stats.aging_stats.age_exceeds_aif := user_aging_stats.aging_stats.age_exceeds_aif -
            last_aging_stats_p^.aging_stats.age_exceeds_aif;
      user_aging_stats.aging_stats.age_exceeds_aic := user_aging_stats.aging_stats.age_exceeds_aic -
            last_aging_stats_p^.aging_stats.age_exceeds_aic;
      user_aging_stats.aging_stats.age_unused_page_in_shared_queue :=
            user_aging_stats.aging_stats.age_unused_page_in_shared_queue -
            last_aging_stats_p^.aging_stats.age_unused_page_in_shared_queue;
      user_aging_stats.aging_stats.write_aged_out_page := user_aging_stats.aging_stats.write_aged_out_page -
            last_aging_stats_p^.aging_stats.write_aged_out_page;
      user_aging_stats.aging_stats.write_forced_out_page :=
            user_aging_stats.aging_stats.write_forced_out_page -
            last_aging_stats_p^.aging_stats.write_forced_out_page;
      user_aging_stats.aging_stats.write_pt_full_page := user_aging_stats.aging_stats.write_pt_full_page -
            last_aging_stats_p^.aging_stats.write_pt_full_page;
      user_aging_stats.aging_stats.write_avail_mod_page :=
            user_aging_stats.aging_stats.write_avail_mod_page -
            last_aging_stats_p^.aging_stats.write_avail_mod_page;
      user_aging_stats.aging_stats.write_page_failed := user_aging_stats.aging_stats.write_page_failed -
            last_aging_stats_p^.aging_stats.write_page_failed;
    IFEND;
    IF incremental THEN
      IF last_aging_stats_p = NIL THEN
        ALLOCATE last_aging_stats_p IN osv$task_shared_heap^;
      IFEND;
      last_aging_stats_p^ := local_aging_stats;
    IFEND;
  PROCEND osp$get_aging_stats;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_cpu_stats
    (    incremental: boolean;
     VAR user_cpu_stats: ost$cpu_stats;
     VAR status: ost$status);

    VAR
      dp: jmt$dispatching_priority,
      frc: ost$free_running_clock,
      i: integer,
      idle_increment: integer,
      local_cpu_stats: ost$cpu_stats;


    frc := #FREE_RUNNING_CLOCK (0);
    local_cpu_stats.time := frc - syv$nos_system_time.corresponding_frc;

    IF NOT c170_os_type_known THEN
      pmp$get_170_os_type (c170_os_type, status);
      c170_os_type_known := TRUE;
    IFEND;

    status.normal := TRUE;
    IF c170_os_type <> osc$ot7_none THEN
      local_cpu_stats.cpu_stats.nos_stats.nos_on := TRUE;
      local_cpu_stats.cpu_stats.nos_stats.nos_time := mtv$total_nos_cpu_time.total;
      local_cpu_stats.cpu_stats.nos_stats.nos_time_ve_idle := mtv$total_nos_cpu_time.ve_idle;
    ELSE
      local_cpu_stats.cpu_stats.nos_stats.nos_on := FALSE;
    IFEND;

    FOR i := 0 TO (osv$cpus_physically_configured - 1) DO
      IF mtv$cst0 [i].processor_state = cmc$on THEN
        local_cpu_stats.cpu_stats.idle_stats [i] := mtv$cst0 [i].cpu_idle_statistics;
        local_cpu_stats.cpu_stats.processor_defined [i] := TRUE;

{ While it is clear that this code is executing in a processor, another CPU may be idle.  If so the idle
{ time must be updated to reflect the current time (i.e. an idle CPU should have a total idle time equal
{ to the idle time plus the time between the start of the current idle state and the current time.

        IF local_cpu_stats.cpu_stats.idle_stats [i].idle_type <> osc$not_idle THEN
          idle_increment := frc - local_cpu_stats.cpu_stats.idle_stats [i].idle_start_time;
          IF idle_increment > 0 THEN { should never be negative but lets be sure
            IF local_cpu_stats.cpu_stats.idle_stats [i].idle_type = osc$idle_with_io_active THEN
              local_cpu_stats.cpu_stats.idle_stats [i].idle_io_active :=
                    idle_increment + local_cpu_stats.cpu_stats.idle_stats [i].idle_io_active;
            ELSEIF local_cpu_stats.cpu_stats.idle_stats [i].idle_type = osc$idle_no_io_active THEN
              local_cpu_stats.cpu_stats.idle_stats [i].idle_no_io_active :=
                    idle_increment + local_cpu_stats.cpu_stats.idle_stats [i].idle_no_io_active;
            IFEND;
          IFEND;
        IFEND;
      ELSE
        local_cpu_stats.cpu_stats.processor_defined [i] := FALSE;
      IFEND;
    FOREND;
    local_cpu_stats.cpu_stats.cpu_count := i;
    local_cpu_stats.cpu_stats.cpu_execution_stats := tmv$cpu_execution_statistics;
    user_cpu_stats := local_cpu_stats;
    IF incremental AND (last_cpu_stats_p <> NIL) THEN
      user_cpu_stats.time := user_cpu_stats.time - last_cpu_stats_p^.time;
      FOR i := 0 TO (osv$cpus_physically_configured - 1) DO
        IF user_cpu_stats.cpu_stats.processor_defined [i] THEN
          user_cpu_stats.cpu_stats.idle_stats [i].idle_no_io_active := user_cpu_stats.cpu_stats.
                idle_stats [i].idle_no_io_active - last_cpu_stats_p^.cpu_stats.idle_stats [i].
                idle_no_io_active;
          user_cpu_stats.cpu_stats.idle_stats [i].idle_io_active :=
                user_cpu_stats.cpu_stats.idle_stats [i].idle_io_active -
                last_cpu_stats_p^.cpu_stats.idle_stats [i].idle_io_active;
          user_cpu_stats.cpu_stats.idle_stats [i].idle_count :=
                user_cpu_stats.cpu_stats.idle_stats [i].idle_count - last_cpu_stats_p^.cpu_stats.
                idle_stats [i].idle_count;
        IFEND;
      FOREND;

      IF user_cpu_stats.cpu_stats.nos_stats.nos_on THEN
        user_cpu_stats.cpu_stats.nos_stats.nos_time := user_cpu_stats.cpu_stats.nos_stats.nos_time -
              last_cpu_stats_p^.cpu_stats.nos_stats.nos_time;
        user_cpu_stats.cpu_stats.nos_stats.nos_time_ve_idle :=
              user_cpu_stats.cpu_stats.nos_stats.nos_time_ve_idle -
              last_cpu_stats_p^.cpu_stats.nos_stats.nos_time_ve_idle;
      IFEND;

      FOR dp := jmc$min_dispatching_priority TO jmc$max_dispatching_priority DO
        user_cpu_stats.cpu_stats.cpu_execution_stats [dp].time_spent_in_job_mode :=
              user_cpu_stats.cpu_stats.cpu_execution_stats [dp].time_spent_in_job_mode -
              last_cpu_stats_p^.cpu_stats.cpu_execution_stats [dp].time_spent_in_job_mode;
        user_cpu_stats.cpu_stats.cpu_execution_stats [dp].time_spent_in_mtr_mode :=
              user_cpu_stats.cpu_stats.cpu_execution_stats [dp].time_spent_in_mtr_mode -
              last_cpu_stats_p^.cpu_stats.cpu_execution_stats [dp].time_spent_in_mtr_mode;
      FOREND;
    IFEND;
    IF incremental THEN
      IF last_cpu_stats_p = NIL THEN
        ALLOCATE last_cpu_stats_p IN osv$task_shared_heap^;
      IFEND;
      last_cpu_stats_p^ := local_cpu_stats;
    IFEND;
  PROCEND osp$get_cpu_stats;

?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_swap_file_statistics
    (    incremental: boolean;
     VAR swap_file_stats_enabled: boolean;
     VAR user_swap_file_stats: ost$swap_file_stats;
     VAR status: ost$status);

    VAR
      local_swap_file_stats: ost$swap_file_stats,
      segnum: ost$segment;

    status.normal := TRUE;
    IF jsv$enable_swap_file_statistics THEN
      swap_file_stats_enabled := TRUE;
    ELSE
      swap_file_stats_enabled := FALSE;
      RETURN;
    IFEND;

    local_swap_file_stats.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;
    local_swap_file_stats.swap_file_stats := jsv$swap_file_statistics;
    user_swap_file_stats := local_swap_file_stats;

    IF incremental AND (last_swap_file_stats_p <> NIL) THEN
      user_swap_file_stats.time := user_swap_file_stats.time - last_swap_file_stats_p^.time;
      FOR segnum := 1 TO 40(16) DO
        user_swap_file_stats.swap_file_stats.total_pages_per_segment [segnum] :=
              user_swap_file_stats.swap_file_stats.total_pages_per_segment [segnum] -
              last_swap_file_stats_p^.swap_file_stats.total_pages_per_segment [segnum];
      FOREND;
      user_swap_file_stats.swap_file_stats.total_swaps := user_swap_file_stats.swap_file_stats.total_swaps -
            last_swap_file_stats_p^.swap_file_stats.total_swaps;
    IFEND;

    IF incremental THEN
      IF last_swap_file_stats_p = NIL THEN
        ALLOCATE last_swap_file_stats_p IN osv$task_shared_heap^;
      IFEND;
      last_swap_file_stats_p^ := local_swap_file_stats;
    IFEND;
  PROCEND osp$get_swap_file_statistics;

?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_disk_space_stats
    (VAR user_disk_space_stats: ost$disk_space_stats);

    VAR
      available_space: integer,
      element: cmt$element_descriptor,
      element_definition_p: ^cmt$element_definition,
      element_information: array [1 .. 1] of cmt$element_info_item,
      local_status: ost$status,
      logical_unit: iot$logical_unit,
      unit_found_count: integer;

    local_status.normal := TRUE;
    PUSH element_definition_p;
    unit_found_count := 0;

    FOR logical_unit := LOWERBOUND (cmv$logical_unit_table^) TO UPPERBOUND (cmv$logical_unit_table^) DO
      cmp$pc_get_logical_unit (logical_unit, element_definition_p, local_status);
      IF (local_status.normal AND (element_definition_p^.element_type = cmc$storage_device_element)) THEN
        element.element_type := cmc$storage_device_element;
        element.peripheral_descriptor.use_logical_identification := TRUE;
        element.peripheral_descriptor.element_name := element_definition_p^.element_name;
        element_information [1].selector := cmc$recorded_vsn;
        cmp$get_element_information (element, element_information, local_status);
        IF (element_information [1].item_returned AND local_status.normal) THEN
          dmp$calculate_remaining_space (logical_unit, available_space, local_status);
          IF local_status.normal THEN
            unit_found_count := unit_found_count + 1;
            IF unit_found_count > UPPERBOUND (user_disk_space_stats.disk_space) THEN
              RETURN;
            IFEND;
            user_disk_space_stats.disk_space [unit_found_count].recorded_vsn :=
                  element_information [1].recorded_vsn;
            user_disk_space_stats.disk_space [unit_found_count].available_space := available_space;
            user_disk_space_stats.disk_space [unit_found_count].unit_used := TRUE;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND osp$get_disk_space_stats;

?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_jm_mm_stats
    (    incremental: boolean;
     VAR user_jm_mm_stats: ost$jm_mm_stats;
     VAR status: ost$status);

    VAR
      from_state: jmt$ijl_swap_status,
      to_state: jmt$ijl_swap_status,
      local_jm_mm_stats: ost$jm_mm_stats;

    status.normal := TRUE;
    local_jm_mm_stats.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;
    get_jm_mm_statistics (local_jm_mm_stats.jm_mm_stats, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    user_jm_mm_stats := local_jm_mm_stats;

{
{   Do not save incremental data.
{

  PROCEND osp$get_jm_mm_stats;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_job_stats
    (    incremental: boolean;
     VAR user_job_stats: ost$job_stats;
     VAR status: ost$status);

    VAR
      local_job_stats: ost$job_stats;

    status.normal := TRUE;
    local_job_stats.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;
    tmp$fetch_job_statistics (local_job_stats.job_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    user_job_stats := local_job_stats;
    IF incremental AND (last_job_stats_p <> NIL) THEN
      user_job_stats.time := user_job_stats.time - last_job_stats_p^.time;
      user_job_stats.job_data.cp_time.time_spent_in_job_mode :=
            user_job_stats.job_data.cp_time.time_spent_in_job_mode -
            last_job_stats_p^.job_data.cp_time.time_spent_in_job_mode;
      user_job_stats.job_data.cp_time.time_spent_in_mtr_mode :=
            user_job_stats.job_data.cp_time.time_spent_in_mtr_mode -
            last_job_stats_p^.job_data.cp_time.time_spent_in_mtr_mode;
      user_job_stats.job_data.paging_statistics.page_in_count :=
            user_job_stats.job_data.paging_statistics.page_in_count -
            last_job_stats_p^.job_data.paging_statistics.page_in_count;
      user_job_stats.job_data.paging_statistics.pages_reclaimed_from_queue :=
            user_job_stats.job_data.paging_statistics.pages_reclaimed_from_queue -
            last_job_stats_p^.job_data.paging_statistics.pages_reclaimed_from_queue;
      user_job_stats.job_data.paging_statistics.new_pages_assigned :=
            user_job_stats.job_data.paging_statistics.new_pages_assigned -
            last_job_stats_p^.job_data.paging_statistics.new_pages_assigned;
      user_job_stats.job_data.paging_statistics.pages_from_server :=
            user_job_stats.job_data.paging_statistics.pages_from_server -
            last_job_stats_p^.job_data.paging_statistics.pages_from_server;
      user_job_stats.job_data.paging_statistics.page_fault_count :=
            user_job_stats.job_data.paging_statistics.page_fault_count -
            last_job_stats_p^.job_data.paging_statistics.page_fault_count;
      user_job_stats.job_data.paging_statistics.working_set_max_used :=
            user_job_stats.job_data.paging_statistics.incremental_max_ws;
    IFEND;
    IF incremental THEN
      IF last_job_stats_p = NIL THEN
        ALLOCATE last_job_stats_p IN osv$task_shared_heap^;
      IFEND;
      last_job_stats_p^ := local_job_stats;
    IFEND;
  PROCEND osp$get_job_stats;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_mtr_stats
    (    incremental: boolean;
     VAR user_mtr_stats: ost$mtr_stats;
     VAR status: ost$status);

    VAR
      i: integer,
      local_mtr_stats: ost$mtr_stats;

    status.normal := TRUE;
    local_mtr_stats.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;
    local_mtr_stats.mtr_reqs := mtv$request_table;
    user_mtr_stats := local_mtr_stats;
    IF incremental AND (last_mtr_stats_p <> NIL) THEN
      user_mtr_stats.time := user_mtr_stats.time - last_mtr_stats_p^.time;
      FOR i := LOWERBOUND (mtt$request_table) TO UPPERBOUND (mtt$request_table) DO
        user_mtr_stats.mtr_reqs [i].count := user_mtr_stats.mtr_reqs [i].
              count - last_mtr_stats_p^.mtr_reqs [i].count;
        user_mtr_stats.mtr_reqs [i].total_cpu_time := user_mtr_stats.mtr_reqs [i].total_cpu_time -
              last_mtr_stats_p^.mtr_reqs [i].total_cpu_time;
      FOREND;
    IFEND;
    IF incremental THEN
      IF last_mtr_stats_p = NIL THEN
        ALLOCATE last_mtr_stats_p IN osv$task_shared_heap^;
      IFEND;
      last_mtr_stats_p^ := local_mtr_stats;
    IFEND;
  PROCEND osp$get_mtr_stats;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_page_stats
    (    incremental: boolean;
     VAR user_page_stats: ost$page_fault_stats;
     VAR user_server_page_stats: ost$page_fault_stats;
     VAR status: ost$status);

    VAR
      i: integer,
      local_page_stats: ost$page_fault_stats,
      local_server_page_stats: ost$page_fault_stats;

    status.normal := TRUE;
    local_page_stats.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;
    local_page_stats.pf_stats := mmv$pf_statistics;
    user_page_stats := local_page_stats;
    local_server_page_stats.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;
    local_server_page_stats.pf_stats := mmv$df_read_server_pf_stats;
    user_server_page_stats := local_server_page_stats;
    IF incremental AND (last_page_stats_p <> NIL) AND (last_server_page_stats_p <> NIL) THEN
      user_page_stats.time := user_page_stats.time - last_page_stats_p^.time;
      user_server_page_stats.time := user_server_page_stats.time - last_server_page_stats_p^.time;
      FOR i := 1 TO UPPERBOUND (mmv$pf_statistics) DO
        user_page_stats.pf_stats [i] := user_page_stats.pf_stats [i] - last_page_stats_p^.pf_stats [i];
        user_server_page_stats.pf_stats [i] := user_server_page_stats.pf_stats [i] -
              last_server_page_stats_p^.pf_stats [i];
      FOREND;
    IFEND;
    IF incremental THEN
      IF last_page_stats_p = NIL THEN
        ALLOCATE last_page_stats_p IN osv$task_shared_heap^;
      IFEND;
      last_page_stats_p^ := local_page_stats;
      IF last_server_page_stats_p = NIL THEN
        ALLOCATE last_server_page_stats_p IN osv$task_shared_heap^;
      IFEND;
      last_server_page_stats_p^ := local_server_page_stats;
    IFEND;
  PROCEND osp$get_page_stats;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_paging_stats
    (    incremental: boolean;
     VAR paging_stats: ost$paging_stats;
     VAR status: ost$status);

    VAR
      i: integer,
      local_paging_stats: ost$paging_stats;

    status.normal := TRUE;
    local_paging_stats.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;
    local_paging_stats.p_stats := mmv$paging_statistics;
    paging_stats := local_paging_stats;
    IF incremental AND (last_paging_stats_p <> NIL) THEN
      paging_stats.time := paging_stats.time - last_paging_stats_p^.time;
      paging_stats.p_stats.pf_pages.disk := paging_stats.p_stats.pf_pages.disk -
            last_paging_stats_p^.p_stats.pf_pages.disk;
      paging_stats.p_stats.pf_pages.reclaim := paging_stats.p_stats.pf_pages.reclaim -
            last_paging_stats_p^.p_stats.pf_pages.reclaim;
      paging_stats.p_stats.pf_pages.new := paging_stats.p_stats.pf_pages.new -
            last_paging_stats_p^.p_stats.pf_pages.new;
      paging_stats.p_stats.pf_pages.server := paging_stats.p_stats.pf_pages.server -
            last_paging_stats_p^.p_stats.pf_pages.server;
      paging_stats.p_stats.ps_pages.disk := paging_stats.p_stats.ps_pages.disk -
            last_paging_stats_p^.p_stats.ps_pages.disk;
      paging_stats.p_stats.ps_pages.reclaim := paging_stats.p_stats.ps_pages.reclaim -
            last_paging_stats_p^.p_stats.ps_pages.reclaim;
      paging_stats.p_stats.ps_pages.new := paging_stats.p_stats.ps_pages.new -
            last_paging_stats_p^.p_stats.ps_pages.new;
      paging_stats.p_stats.ps_pages.server := paging_stats.p_stats.ps_pages.server -
            last_paging_stats_p^.p_stats.ps_pages.server;
      paging_stats.p_stats.ai_pages.disk := paging_stats.p_stats.ai_pages.disk -
            last_paging_stats_p^.p_stats.ai_pages.disk;
      paging_stats.p_stats.ai_pages.reclaim := paging_stats.p_stats.ai_pages.reclaim -
            last_paging_stats_p^.p_stats.ai_pages.reclaim;
      paging_stats.p_stats.ai_pages.new := paging_stats.p_stats.ai_pages.new -
            last_paging_stats_p^.p_stats.ai_pages.new;
      paging_stats.p_stats.ai_pages.server := paging_stats.p_stats.ai_pages.server -
            last_paging_stats_p^.p_stats.ai_pages.server;
      paging_stats.p_stats.page_streaming.initiated := paging_stats.p_stats.page_streaming.initiated -
            last_paging_stats_p^.p_stats.page_streaming.initiated;
      paging_stats.p_stats.page_streaming.prestream_only :=
            paging_stats.p_stats.page_streaming.prestream_only -
            last_paging_stats_p^.p_stats.page_streaming.prestream_only;
      paging_stats.p_stats.page_streaming.terminated := paging_stats.p_stats.page_streaming.terminated -
            last_paging_stats_p^.p_stats.page_streaming.terminated;
      paging_stats.p_stats.page_streaming.pages_prestream :=
            paging_stats.p_stats.page_streaming.pages_prestream -
            last_paging_stats_p^.p_stats.page_streaming.pages_prestream;
      paging_stats.p_stats.page_streaming.pages_streaming :=
            paging_stats.p_stats.page_streaming.pages_streaming -
            last_paging_stats_p^.p_stats.page_streaming.pages_streaming;
      paging_stats.p_stats.page_streaming.task_slow := paging_stats.p_stats.page_streaming.task_slow -
            last_paging_stats_p^.p_stats.page_streaming.task_slow;
      paging_stats.p_stats.page_streaming.page_faults_tu :=
            paging_stats.p_stats.page_streaming.page_faults_tu -
            last_paging_stats_p^.p_stats.page_streaming.page_faults_tu;
      paging_stats.p_stats.page_streaming.pages_freed_behind :=
            paging_stats.p_stats.page_streaming.pages_freed_behind -
            last_paging_stats_p^.p_stats.page_streaming.pages_freed_behind;
      paging_stats.p_stats.page_streaming.random_faults :=
            paging_stats.p_stats.page_streaming.random_faults -
            last_paging_stats_p^.p_stats.page_streaming.random_faults;
    IFEND;
    IF incremental THEN
      IF last_paging_stats_p = NIL THEN
        ALLOCATE last_paging_stats_p IN osv$task_shared_heap^;
      IFEND;
      last_paging_stats_p^ := local_paging_stats;
    IFEND;
  PROCEND osp$get_paging_stats;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_pio_pp_stats
    (    incremental: boolean;
     VAR user_pio_pp_stats: ost$disk_pp_stats;
     VAR status: ost$status);

    VAR
      index: integer,
      pp_found_index: integer,
      port_index: integer,
      equip_index: integer,
      pp_count: integer,
      unit_count: integer,
      local_pio_pp_stats_p: ^ost$disk_pp_stats;

    status.normal := TRUE;
    osp$get_pp_unit_count (pp_count, unit_count, status);
    IF (UPPERBOUND (user_pio_pp_stats.disk_pp_stats) <> pp_count) OR (pp_count = 0) THEN
      status.normal := FALSE;
      RETURN;
    IFEND;
    PUSH local_pio_pp_stats_p: [1 .. pp_count];
    pp_found_index := 0;
    local_pio_pp_stats_p^.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;
    FOR index := 1 TO UPPERBOUND (iov$disk_pp_usage_p^) DO
      IF iov$disk_pp_usage_p^ [index] <> NIL THEN
        pp_found_index := pp_found_index + 1;
        local_pio_pp_stats_p^.disk_pp_stats [pp_found_index] := iov$disk_pp_usage_p^ [index]^;
      IFEND;
    FOREND;
    user_pio_pp_stats := local_pio_pp_stats_p^;
    IF incremental AND (last_pio_pp_stats_p <> NIL) THEN
      user_pio_pp_stats.time := user_pio_pp_stats.time - last_pio_pp_stats_p^.time;
      FOR index := 1 TO pp_count DO
        user_pio_pp_stats.disk_pp_stats [index].computed_data_transfer_time :=
              user_pio_pp_stats.disk_pp_stats [index].computed_data_transfer_time -
              last_pio_pp_stats_p^.disk_pp_stats [index].computed_data_transfer_time;
        user_pio_pp_stats.disk_pp_stats [index].seek_and_latency_time := user_pio_pp_stats.
              disk_pp_stats [index].seek_and_latency_time - last_pio_pp_stats_p^.disk_pp_stats [index].
              seek_and_latency_time;
        user_pio_pp_stats.disk_pp_stats [index].streamed_req_count_read := user_pio_pp_stats.
              disk_pp_stats [index].streamed_req_count_read - last_pio_pp_stats_p^.disk_pp_stats [index].
              streamed_req_count_read;
        user_pio_pp_stats.disk_pp_stats [index].streamed_req_failed_count_read :=
              user_pio_pp_stats.disk_pp_stats [index].streamed_req_failed_count_read -
              last_pio_pp_stats_p^.disk_pp_stats [index].streamed_req_failed_count_read;
        user_pio_pp_stats.disk_pp_stats [index].streamed_req_count_write := user_pio_pp_stats.
              disk_pp_stats [index].streamed_req_count_write -
              last_pio_pp_stats_p^.disk_pp_stats [index].streamed_req_count_write;
        user_pio_pp_stats.disk_pp_stats [index].streamed_req_failed_count_write :=
              user_pio_pp_stats.disk_pp_stats [index].streamed_req_failed_count_write -
              last_pio_pp_stats_p^.disk_pp_stats [index].streamed_req_failed_count_write;
        FOR port_index := 0 TO 1 DO
          FOR equip_index := 0 TO 7 DO
            IF user_pio_pp_stats.disk_pp_stats [index].path_usage [port_index] [equip_index].path_used THEN
              user_pio_pp_stats.disk_pp_stats [index].path_usage [port_index] [equip_index].read_requests :=
                    user_pio_pp_stats.disk_pp_stats [index].path_usage [port_index] [equip_index].
                    read_requests - last_pio_pp_stats_p^.disk_pp_stats [index].path_usage [port_index]
                    [equip_index].read_requests;
              user_pio_pp_stats.disk_pp_stats [index].path_usage [port_index] [equip_index].read_maus :=
                    user_pio_pp_stats.disk_pp_stats [index].path_usage [port_index] [equip_index].read_maus -
                    last_pio_pp_stats_p^.disk_pp_stats [index].path_usage [port_index] [equip_index].
                    read_maus;
              user_pio_pp_stats.disk_pp_stats [index].path_usage [port_index] [equip_index].write_requests :=
                    user_pio_pp_stats.disk_pp_stats [index].path_usage [port_index] [equip_index].
                    write_requests - last_pio_pp_stats_p^.disk_pp_stats [index].path_usage [port_index]
                    [equip_index].write_requests;
              user_pio_pp_stats.disk_pp_stats [index].path_usage [port_index] [equip_index].
                    written_and_preset_maus := user_pio_pp_stats.disk_pp_stats [index].
                    path_usage [port_index] [equip_index].written_and_preset_maus -
                    last_pio_pp_stats_p^.disk_pp_stats [index].path_usage [port_index] [equip_index].
                    written_and_preset_maus;
              user_pio_pp_stats.disk_pp_stats [index].path_usage [port_index] [equip_index].
                    total_request_qtime := user_pio_pp_stats.disk_pp_stats [index].path_usage [port_index]
                    [equip_index].total_request_qtime - last_pio_pp_stats_p^.disk_pp_stats [index].
                    path_usage [port_index] [equip_index].total_request_qtime;
              user_pio_pp_stats.disk_pp_stats [index].path_usage [port_index] [equip_index].
                    intermediate_errors := user_pio_pp_stats.disk_pp_stats [index].path_usage [port_index]
                    [equip_index].intermediate_errors - last_pio_pp_stats_p^.disk_pp_stats [index].
                    path_usage [port_index] [equip_index].intermediate_errors;
              user_pio_pp_stats.disk_pp_stats [index].path_usage [port_index] [equip_index].
                    recovered_errors := user_pio_pp_stats.disk_pp_stats [index].path_usage [port_index]
                    [equip_index].recovered_errors - last_pio_pp_stats_p^.disk_pp_stats [index].
                    path_usage [port_index] [equip_index].recovered_errors;
              user_pio_pp_stats.disk_pp_stats [index].path_usage [port_index] [equip_index].
                    unrecovered_errors := user_pio_pp_stats.disk_pp_stats [index].path_usage [port_index]
                    [equip_index].unrecovered_errors - last_pio_pp_stats_p^.disk_pp_stats [index].
                    path_usage [port_index] [equip_index].unrecovered_errors;
            IFEND;
          FOREND;
        FOREND;
      FOREND;
    IFEND;
    IF incremental THEN
      IF last_pio_pp_stats_p = NIL THEN
        ALLOCATE last_pio_pp_stats_p: [1 .. pp_count] IN osv$task_shared_heap^;
      IFEND;
      last_pio_pp_stats_p^ := local_pio_pp_stats_p^;
    IFEND;
  PROCEND osp$get_pio_pp_stats;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_pio_unit_stats
    (    incremental: boolean;
     VAR user_pio_unit_stats: ost$disk_unit_stats;
     VAR status: ost$status);

    VAR
      index: integer,
      rvsn: rmt$recorded_vsn,
      entry_found: boolean,
      unit_count: integer,
      pp_count: integer,
      unit_found_index: integer,
      local_pio_unit_stats_p: ^ost$disk_unit_stats;

    status.normal := TRUE;
    osp$get_pp_unit_count (pp_count, unit_count, status);
    IF (UPPERBOUND (user_pio_unit_stats.disk_unit_stats) <> unit_count) OR (unit_count = 0) THEN
      status.normal := FALSE;
      RETURN;
    IFEND;
    PUSH local_pio_unit_stats_p: [1 .. unit_count];
    local_pio_unit_stats_p^.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;
    unit_found_index := 0;
    FOR index := 1 TO UPPERBOUND (iov$disk_unit_usage_p^) DO
      IF iov$disk_unit_usage_p^ [index] <> NIL THEN
        unit_found_index := unit_found_index + 1;
        local_pio_unit_stats_p^.disk_unit_stats [unit_found_index] := iov$disk_unit_usage_p^ [index]^;
        osp$get_rvsn_by_lun (index, rvsn, entry_found);
        IF entry_found THEN
          local_pio_unit_stats_p^.disk_unit_stats [unit_found_index].recorded_vsn := rvsn;
        ELSE
          local_pio_unit_stats_p^.disk_unit_stats [unit_found_index].recorded_vsn := '     ';
        IFEND;
      IFEND;
    FOREND;
    user_pio_unit_stats := local_pio_unit_stats_p^;
    IF incremental AND (last_pio_unit_stats_p <> NIL) THEN
      user_pio_unit_stats.time := user_pio_unit_stats.time - last_pio_unit_stats_p^.time;
      FOR index := 1 TO unit_count DO
        IF user_pio_unit_stats.disk_unit_stats [index].unit_used THEN
          user_pio_unit_stats.disk_unit_stats [index].read_requests := user_pio_unit_stats.
                disk_unit_stats [index].read_requests - last_pio_unit_stats_p^.disk_unit_stats [index].
                read_requests;
          user_pio_unit_stats.disk_unit_stats [index].read_qtime := user_pio_unit_stats.
                disk_unit_stats [index].read_qtime - last_pio_unit_stats_p^.disk_unit_stats [index].
                read_qtime;
          user_pio_unit_stats.disk_unit_stats [index].read_mau_count := user_pio_unit_stats.
                disk_unit_stats [index].read_mau_count - last_pio_unit_stats_p^.disk_unit_stats [index].
                read_mau_count;
          user_pio_unit_stats.disk_unit_stats [index].write_requests := user_pio_unit_stats.
                disk_unit_stats [index].write_requests - last_pio_unit_stats_p^.disk_unit_stats [index].
                write_requests;
          user_pio_unit_stats.disk_unit_stats [index].write_qtime := user_pio_unit_stats.
                disk_unit_stats [index].write_qtime - last_pio_unit_stats_p^.disk_unit_stats [index].
                write_qtime;
          user_pio_unit_stats.disk_unit_stats [index].write_data_mau_count :=
                user_pio_unit_stats.disk_unit_stats [index].write_data_mau_count -
                last_pio_unit_stats_p^.disk_unit_stats [index].write_data_mau_count;
          user_pio_unit_stats.disk_unit_stats [index].write_data_and_preset_maus :=
                user_pio_unit_stats.disk_unit_stats [index].write_data_and_preset_maus -
                last_pio_unit_stats_p^.disk_unit_stats [index].write_data_and_preset_maus;
          user_pio_unit_stats.disk_unit_stats [index].swap_in_requests :=
                user_pio_unit_stats.disk_unit_stats [index].swap_in_requests -
                last_pio_unit_stats_p^.disk_unit_stats [index].swap_in_requests;
          user_pio_unit_stats.disk_unit_stats [index].swap_in_qtime := user_pio_unit_stats.
                disk_unit_stats [index].swap_in_qtime - last_pio_unit_stats_p^.disk_unit_stats [index].
                swap_in_qtime;
          user_pio_unit_stats.disk_unit_stats [index].swap_in_mau_count :=
                user_pio_unit_stats.disk_unit_stats [index].swap_in_mau_count -
                last_pio_unit_stats_p^.disk_unit_stats [index].swap_in_mau_count;
          user_pio_unit_stats.disk_unit_stats [index].swap_out_requests :=
                user_pio_unit_stats.disk_unit_stats [index].swap_out_requests -
                last_pio_unit_stats_p^.disk_unit_stats [index].swap_out_requests;
          user_pio_unit_stats.disk_unit_stats [index].swap_out_qtime := user_pio_unit_stats.
                disk_unit_stats [index].swap_out_qtime - last_pio_unit_stats_p^.disk_unit_stats [index].
                swap_out_qtime;
          user_pio_unit_stats.disk_unit_stats [index].swap_out_data_mau_count :=
                user_pio_unit_stats.disk_unit_stats [index].swap_out_data_mau_count -
                last_pio_unit_stats_p^.disk_unit_stats [index].swap_out_data_mau_count;
          user_pio_unit_stats.disk_unit_stats [index].swap_out_data_and_preset_maus :=
                user_pio_unit_stats.disk_unit_stats [index].swap_out_data_and_preset_maus -
                last_pio_unit_stats_p^.disk_unit_stats [index].swap_out_data_and_preset_maus;
          user_pio_unit_stats.disk_unit_stats [index].streamed_req_count_read :=
                user_pio_unit_stats.disk_unit_stats [index].streamed_req_count_read -
                last_pio_unit_stats_p^.disk_unit_stats [index].streamed_req_count_read;
          user_pio_unit_stats.disk_unit_stats [index].streamed_req_failed_count_read :=
                user_pio_unit_stats.disk_unit_stats [index].streamed_req_failed_count_read -
                last_pio_unit_stats_p^.disk_unit_stats [index].streamed_req_failed_count_read;
          user_pio_unit_stats.disk_unit_stats [index].streamed_req_count_write :=
                user_pio_unit_stats.disk_unit_stats [index].streamed_req_count_write -
                last_pio_unit_stats_p^.disk_unit_stats [index].streamed_req_count_write;
          user_pio_unit_stats.disk_unit_stats [index].streamed_req_failed_count_write :=
                user_pio_unit_stats.disk_unit_stats [index].streamed_req_failed_count_write -
                last_pio_unit_stats_p^.disk_unit_stats [index].streamed_req_failed_count_write;
          user_pio_unit_stats.disk_unit_stats [index].requests_causing_skipped_cyl :=
                user_pio_unit_stats.disk_unit_stats [index].requests_causing_skipped_cyl -
                last_pio_unit_stats_p^.disk_unit_stats [index].requests_causing_skipped_cyl;
          user_pio_unit_stats.disk_unit_stats [index].total_cylinders_skipped :=
                user_pio_unit_stats.disk_unit_stats [index].total_cylinders_skipped -
                last_pio_unit_stats_p^.disk_unit_stats [index].total_cylinders_skipped;
          user_pio_unit_stats.disk_unit_stats [index].intermediate_errors :=
                user_pio_unit_stats.disk_unit_stats [index].intermediate_errors -
                last_pio_unit_stats_p^.disk_unit_stats [index].intermediate_errors;
          user_pio_unit_stats.disk_unit_stats [index].recovered_errors :=
                user_pio_unit_stats.disk_unit_stats [index].recovered_errors -
                last_pio_unit_stats_p^.disk_unit_stats [index].recovered_errors;
          user_pio_unit_stats.disk_unit_stats [index].unrecovered_errors :=
                user_pio_unit_stats.disk_unit_stats [index].unrecovered_errors -
                last_pio_unit_stats_p^.disk_unit_stats [index].unrecovered_errors;
        IFEND;
      FOREND;
    IFEND;
    IF incremental THEN
      IF last_pio_unit_stats_p = NIL THEN
        ALLOCATE last_pio_unit_stats_p: [1 .. unit_count] IN osv$task_shared_heap^;
      IFEND;
      last_pio_unit_stats_p^ := local_pio_unit_stats_p^;
    IFEND;
  PROCEND osp$get_pio_unit_stats;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_sched_stats
    (    incremental: boolean;
     VAR user_sched_stats: ost$sched_stats;
     VAR status: ost$status);

    VAR
      sched_stat_index: jmt$sched_statistic_elements,
      local_sched_stats: ost$sched_stats;

    status.normal := TRUE;
    local_sched_stats.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;
    local_sched_stats.job_scheduler_statistics := jmv$job_scheduler_statistics;
    user_sched_stats := local_sched_stats;
    IF incremental AND (last_sched_stats_p <> NIL) THEN
      user_sched_stats.time := user_sched_stats.time - last_sched_stats_p^.time;
      FOR sched_stat_index := LOWERBOUND (jmv$job_scheduler_statistics)
            TO UPPERBOUND (jmv$job_scheduler_statistics) DO
        user_sched_stats.job_scheduler_statistics [sched_stat_index] :=
              user_sched_stats.job_scheduler_statistics [sched_stat_index] -
              last_sched_stats_p^.job_scheduler_statistics [sched_stat_index];
      FOREND;
    IFEND;
    IF incremental THEN
      IF last_sched_stats_p = NIL THEN
        ALLOCATE last_sched_stats_p IN osv$task_shared_heap^;
      IFEND;
      last_sched_stats_p^ := local_sched_stats;
    IFEND;
  PROCEND osp$get_sched_stats;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$get_job_class_stats', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to get job class statistics for statistics emission.
{ DESIGN:
{   The procedure has been 'stubbed' for incremental displays.  When incremental displays are
{   implemented, the code to save the last values of the statistics will have to be added.

  PROCEDURE [XDCL, #GATE] osp$get_job_class_stats
    (    incremental: boolean;
     VAR user_job_class_stats: ost$job_class_stats;
     VAR status: ost$status);

    VAR
      job_class: jmt$job_class;

    status.normal := TRUE;

    user_job_class_stats.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;

    FOR job_class := jmc$system_job_class TO UPPERBOUND (user_job_class_stats.job_class_stats) DO
      IF job_class > jmv$maximum_job_class_in_use THEN
        RETURN;
      IFEND;
      IF jmv$job_class_table_p^ [job_class].defined THEN
        user_job_class_stats.job_class_stats [job_class].job_class_counters.queued_jobs :=
              jmv$job_counts.job_class_counts [job_class].queued_jobs;
        user_job_class_stats.job_class_stats [job_class].job_class_counters.initiated_jobs :=
              jmv$job_counts.job_class_counts [job_class].initiated_jobs;
        user_job_class_stats.job_class_stats [job_class].job_class_counters.swapped_jobs :=
              jmv$job_counts.job_class_counts [job_class].swapped_jobs;
        user_job_class_stats.job_class_stats [job_class].job_class_counters.completed_jobs :=
              jmv$job_counts.job_class_counts [job_class].completed_jobs;
        user_job_class_stats.job_class_stats [job_class].job_class_names.name :=
              jmv$job_class_table_p^ [job_class].name;
        user_job_class_stats.job_class_stats [job_class].job_class_names.abbreviation :=
              jmv$job_class_table_p^ [job_class].abbreviation;
      IFEND;
    FOREND;

  PROCEND osp$get_job_class_stats;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$get_service_class_stats', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to get service class statistics for statistics emission.
{ DESIGN:
{   The procedure has been 'stubbed' for incremental displays.  When incremental displays are
{   implemented, the code to save the last values of the statistics will have to be added.
{   A monitor request must be issued to update the monitor statistics accumulator, because
{   writing the monitor statistics variable must be synchronized via the monitor interrupt
{   processor lock.

  PROCEDURE [XDCL, #GATE] osp$get_service_class_stats
    (    incremental: boolean;
     VAR user_serv_class_stats: ost$service_class_stats;
     VAR status: ost$status);

    VAR
      request_block: jmt$rb_service_class_statistics,
      service_class: jmt$service_class_index;

    status.normal := TRUE;

    request_block.reqcode := syc$rc_service_class_statistics;
    i#call_monitor (#LOC (request_block), #SIZE (request_block));

    user_serv_class_stats.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;
    FOR service_class := jmc$system_service_class TO UPPERBOUND (user_serv_class_stats.service_class_stats) DO
      IF service_class > jmv$max_service_class_in_use THEN
        RETURN;
      IFEND;
      IF (jmv$service_classes [service_class] <> NIL) AND jmv$service_classes [service_class]^.attributes.
            defined THEN
        user_serv_class_stats.service_class_stats [service_class].
              mtr_stats := jmv$service_classes [service_class]^.statistics;
        user_serv_class_stats.service_class_stats [service_class].sched_stats.active_jobs :=
              jmv$job_counts.service_class_counts [service_class].scheduler_initiated_jobs -
              jmv$job_counts.service_class_counts [service_class].swapped_jobs;
        user_serv_class_stats.service_class_stats [service_class].sched_stats.swapin_queue_size :=
              jmv$swapin_candidate_queue [service_class].number_of_jobs_in_queue;
        user_serv_class_stats.service_class_stats [service_class].sched_stats.memory_waits :=
              jmv$job_sched_serv_class_stats [service_class].memory_wait;
        user_serv_class_stats.service_class_stats [service_class].sched_stats.ajl_waits :=
              jmv$job_sched_serv_class_stats [service_class].ajl_wait;
        user_serv_class_stats.service_class_stats [service_class].
              name := jmv$service_classes [service_class]^.attributes.name;
      IFEND;
    FOREND;

  PROCEND osp$get_service_class_stats;

?? OLDTITLE ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_swap_stats
    (    incremental: boolean;
     VAR user_swap_stats: ost$swap_stats;
     VAR status: ost$status);

    VAR
      from_state: jmt$ijl_swap_status,
      to_state: jmt$ijl_swap_status,
      local_swap_stats: ost$swap_stats;

    status.normal := TRUE;
    local_swap_stats.time := #FREE_RUNNING_CLOCK (0) - syv$nos_system_time.corresponding_frc;
    local_swap_stats.swap_stats := jsv$swap_state_statistics;
    local_swap_stats.swap_file_page_count := jsv$swap_file_page_count;
    user_swap_stats := local_swap_stats;
    IF incremental AND (last_swap_stats_p <> NIL) THEN
      user_swap_stats.time := user_swap_stats.time - last_swap_stats_p^.time;
      user_swap_stats.swap_file_page_count.swap_count := user_swap_stats.swap_file_page_count.swap_count -
            last_swap_stats_p^.swap_file_page_count.swap_count;
      user_swap_stats.swap_file_page_count.page_count := user_swap_stats.swap_file_page_count.page_count -
            last_swap_stats_p^.swap_file_page_count.page_count;

      FOR from_state := LOWERVALUE (jmt$ijl_swap_status) TO UPPERVALUE (jmt$ijl_swap_status) DO
        FOR to_state := LOWERVALUE (jmt$ijl_swap_status) TO UPPERVALUE (jmt$ijl_swap_status) DO
          user_swap_stats.swap_stats [from_state] [to_state].
                count := user_swap_stats.swap_stats [from_state] [to_state].count -
                last_swap_stats_p^.swap_stats [from_state] [to_state].count;
          user_swap_stats.swap_stats [from_state] [to_state].
                total_time := user_swap_stats.swap_stats [from_state] [to_state].total_time -
                last_swap_stats_p^.swap_stats [from_state] [to_state].total_time;
        FOREND;
      FOREND;
    IFEND;
    IF incremental THEN
      IF last_swap_stats_p = NIL THEN
        ALLOCATE last_swap_stats_p IN osv$task_shared_heap^;
      IFEND;
      last_swap_stats_p^ := local_swap_stats;
    IFEND;
  PROCEND osp$get_swap_stats;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_pp_unit_count
    (VAR pp_count: integer;
     VAR unit_count: integer;
     VAR status: ost$status);

    VAR
      index: integer;

    status.normal := TRUE;
    pp_count := 0;
    unit_count := 0;

    IF iov$disk_unit_usage_p <> NIL THEN
      FOR index := 1 TO UPPERBOUND (iov$disk_unit_usage_p^) DO
        IF iov$disk_unit_usage_p^ [index] <> NIL THEN
          unit_count := unit_count + 1;
        IFEND;
      FOREND;
    IFEND;

    IF iov$disk_pp_usage_p <> NIL THEN
      FOR index := 1 TO UPPERBOUND (iov$disk_pp_usage_p^) DO
        IF iov$disk_pp_usage_p^ [index] <> NIL THEN
          pp_count := pp_count + 1;
        IFEND;
      FOREND;
    IFEND;

  PROCEND osp$get_pp_unit_count;
?? OLDTITLE ??
?? EJECT, NEWTITLE := 'PROCEDURE osp$store_system_constant' ??

  PROCEDURE [XDCL, #GATE] osp$store_system_constant
    (    name: string ( * );
         index: integer;
         value: integer;
     VAR status: ost$status);

    IF NOT avp$configuration_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      RETURN;
    IFEND;

    syp$store_system_constant (name, index, value, status);
  PROCEND osp$store_system_constant;


?? OLDTITLE ??
?? EJECT, NEWTITLE := 'PROCEDURE osp$fetch_system_constant' ??

  PROCEDURE [XDCL, #GATE] osp$fetch_system_constant
    (VAR name: string ( * );
     VAR index: integer;
     VAR value: integer;
     VAR status: ost$status);

    IF NOT (avp$configuration_administrator () OR avp$system_displays ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration or system_displays',
            status);
      RETURN;
    IFEND;

    syp$fetch_system_constant (name, index, value, status);
  PROCEND osp$fetch_system_constant;

?? OLDTITLE ??
?? EJECT, NEWTITLE := 'PROCEDURE osp$get_system_constant' ??

  PROCEDURE [XDCL, #GATE] osp$get_system_constant
    (VAR name: string ( * );
     VAR index: integer;
     VAR value: integer;
     VAR status: ost$status);

    syp$fetch_system_constant (name, index, value, status);
  PROCEND osp$get_system_constant;

?? OLDTITLE ??
?? EJECT, NEWTITLE := 'PROCEDURE get_jm_mm_statistics' ??

  PROCEDURE get_jm_mm_statistics
    (VAR stats: ost$jm_mm_statistics;
     VAR status: ost$status);

    VAR
      index: integer,
      ijl_bn: jmt$ijl_block_number,
      ijl_bi: jmt$ijl_block_index,
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      job_counts: jmt$job_counts;

    status.normal := TRUE;

    mmp$get_page_q_counts (stats.page_q_counts);

    stats.total_swapped_jobs := jsv$ijl_swap_queue_list [jsc$isqi_swapped_out].count;

{ Determine the number of ready tasks, ready but swapped tasks, and active jobs.

    stats.total_ready_but_swapped_tasks := 0;
    stats.total_ready_tasks := 0;
    stats.total_active_jobs := 0;

    ijle_p := NIL;

  /scan_ijl/
    FOR ijl_bn := LOWERBOUND (jmv$ijl_p.block_p^) TO jmv$ijl_p.max_block_in_use DO
      IF (jmv$ijl_p.block_p^ [ijl_bn].index_p <> NIL) THEN
        ijl_ordinal.block_number := ijl_bn;
        FOR ijl_bi := LOWERVALUE (jmt$ijl_block_index) TO UPPERVALUE (jmt$ijl_block_index) DO
          ijl_ordinal.block_index := ijl_bi;
          jmp$get_ijle_p (ijl_ordinal, ijle_p);
          IF ijle_p^.entry_status >= jmc$ies_job_swapped THEN
            stats.total_ready_but_swapped_tasks := stats.total_ready_but_swapped_tasks +
                  ijle_p^.statistics.ready_task_count;
          ELSEIF ijle_p^.entry_status >= jmc$ies_job_in_memory THEN
            stats.total_ready_tasks := stats.total_ready_tasks + ijle_p^.statistics.ready_task_count;
            IF ijle_p^.swap_status = jmc$iss_executing THEN
              stats.total_active_jobs := stats.total_active_jobs + 1;
            IFEND;
          IFEND;
        FOREND;
      IFEND;
    FOREND /scan_ijl/;

{ Determine the number of jobs for each job class

    jmp$get_job_counts (job_counts, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    stats.total_system_class := job_counts.job_class_counts [jmc$system_job_class].initiated_jobs;
    stats.total_interactive_jobs := job_counts.interactive_jobs;
    stats.total_non_interactive_jobs := job_counts.initiated_jobs - job_counts.interactive_jobs;
    IF stats.total_non_interactive_jobs < 0 THEN
      stats.total_non_interactive_jobs := 0;
    IFEND;
  PROCEND get_jm_mm_statistics;

?? OLDTITLE ??
?? NEWTITLE := 'OSP$RESET_MAXIMUM_TIME' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$reset_maximum_time
    (    id: ost$data_id);

    CASE id OF
    = osc$mtr_requests =
      syp$reset_maximum_time;
    = osc$swap_statistics =
      jsp$reset_maximum_time;
    ELSE
      ;
    CASEND;
  PROCEND osp$reset_maximum_time;
MODEND osm$fetch_statistical_data;
*DECK DECK=OSM$FETCH_STAT_DATA_R1_HELPER EXPAND=TRUE
?? RIGHT := 110 ??
MODULE osm$fetch_stat_data_r1_helper;


{
{  PURPOSE:
{     This module is used as an interface between modules in XLJ23D
{     and those that can't be called from above ring 1.

?? EJECT ??
*copyc dmp$get_rvsn_by_lun
?? TITLE := '  [XDCL] osp$get_rvsn_by_lun', EJECT ??
  PROCEDURE [XDCL, #GATE] osp$get_rvsn_by_lun (lun: iot$logical_unit;
    VAR rvsn: rmt$recorded_vsn;
    VAR entry_found: boolean);

    dmp$get_rvsn_by_lun (lun, rvsn, entry_found);
  PROCEND osp$get_rvsn_by_lun;
MODEND osm$fetch_stat_data_r1_helper;
*DECK DECK=OSM$FILE_ACCESS_CONDITIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Disk Fault Tolerance (2DD)' ??
MODULE osm$file_access_conditions;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$put_program_actions
*copyc dfe$error_condition_codes
*copyc dmt$error_condition_codes
*copyc fsc$file_access_conditions_max
*copyc fsc$internal_conditions_max
*copyc fsc$wait_cycle_busy
*copyc fsc$wait_data_restoration
*copyc fsc$wait_for_retrieval
*copyc fsc$wait_for_space
*copyc fsc$wait_server_inactive
*copyc fsc$wait_volume_missing
*copyc fsc$wait_volume_unavailable
*copyc fst$access_condition_entry
*copyc fst$file_access_condition
*copyc fst$file_reference
*copyc ioe$st_errors
*copyc mme$condition_codes
*copyc osc$cycle_busy_cond
*copyc osc$data_restoration_cond
*copyc osc$data_retrieval_req_cond
*copyc osc$space_unavailable_condition
*copyc osc$volume_unavailable_cond
*copyc osd$integer_limits
*copyc oss$mainframe_paged_literal
*copyc ost$condition_information
*copyc ost$status
*copyc ost$status_condition_code
*copyc pfe$error_condition_codes
*copyc ste$error_condition_codes
*copyc pmt$condition_information
?? POP ??
*copyc osp$set_status_condition
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    one_second = 1000 {milliseconds} ;

?? NEWTITLE := '[XDCL], condition_mapping_table' ??

?? FMT (FORMAT := OFF) ??
  VAR
    condition_mapping_table: [READ,  oss$mainframe_paged_literal]
     array [1 .. fsc$internal_conditions_max] of record
           internal_status_condition: ost$status_condition_code,
           file_access_condition: fst$file_access_condition,
         recend := [
         [ame$space_unavailable,          fsc$space_unavailable          ],
         [dfe$server_not_active,          fsc$file_server_inactive       ],
         [dfe$server_request_terminated,  fsc$file_server_inactive       ],
         [dme$some_volumes_not_online,    fsc$media_missing              ],
         [dme$unable_to_alloc_all_space,  fsc$space_unavailable          ],
         [dme$volume_unavailable,         fsc$volume_unavailable         ],
         [ioe$unit_disabled ,             fsc$volume_unavailable         ],
         [mme$volume_unavailable,         fsc$volume_unavailable         ],
         [pfe$catalog_full,               fsc$space_unavailable          ],
         [pfe$catalog_volume_not_online,  fsc$catalog_media_missing      ],
         [pfe$catalog_volume_unavailable, fsc$catalog_volume_unavailable ],
         [pfe$cycle_busy,                 fsc$cycle_busy                 ],
         [pfe$cycle_data_resides_offline, fsc$data_retrieval_required    ],
         [pfe$undefined_data,             fsc$data_restoration_required  ],
         [pfe$volume_not_online,          fsc$media_missing              ],
         [pfe$volume_unavailable,         fsc$volume_unavailable         ],
         [ste$master_not_active,          fsc$media_missing              ],
         [ste$vol_not_found,              fsc$media_missing              ]
        ];
?? OLDTITLE ??
?? NEWTITLE := '[XDCL], file_access_conditions', EJECT ??
  VAR
    file_access_conditions: [XDCL,  READ,  oss$mainframe_paged_literal]
     array [1 .. fsc$file_access_conditions_max] of fst$access_condition_entry := [

         [fsc$catalog_media_missing,
            osc$volume_unavailable_cond,
            60 * one_second,
            pfe$catalog_volume_not_online,
            fsc$wait_volume_missing],
         [fsc$catalog_volume_unavailable,
            osc$volume_unavailable_cond,
            60 * one_second,
            pfe$catalog_volume_unavailable,
            fsc$wait_volume_unavailable],
         [fsc$cycle_busy,
            osc$cycle_busy_cond,
            7 * one_second,
            pfe$cycle_busy,
            fsc$wait_cycle_busy],
         [fsc$data_restoration_required,
            osc$data_restoration_cond,
            60 * one_second,
            pfe$undefined_data,
            fsc$wait_data_restoration],
         [fsc$data_retrieval_required,
            osc$data_retrieval_req_cond,
            35 * one_second,
            pfe$cycle_data_resides_offline,
            fsc$wait_for_retrieval],
         [fsc$file_server_inactive,
            osc$volume_unavailable_cond,
            30 * one_second,
            dfe$server_not_active,
            fsc$wait_server_inactive],
         [fsc$media_missing,
            osc$volume_unavailable_cond,
            60 * one_second,
            pfe$volume_not_online,
            fsc$wait_volume_missing],
         [fsc$space_unavailable,
            osc$space_unavailable_condition,
            10 * one_second,
            ame$space_unavailable,
            fsc$wait_for_space],
         [fsc$volume_unavailable,
            osc$volume_unavailable_cond,
            60 * one_second,
            pfe$volume_unavailable,
            fsc$wait_volume_unavailable]
                                      ];
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$file_access_condition', EJECT ??

  FUNCTION [XDCL, #GATE] osp$file_access_condition
    (    status: ost$status): boolean;

    VAR
      i: integer;

    osp$file_access_condition := FALSE;
    IF NOT status.normal THEN
      FOR i := LOWERBOUND (condition_mapping_table) TO UPPERBOUND (condition_mapping_table) DO
        IF condition_mapping_table [i].internal_status_condition = status.condition THEN
          osp$file_access_condition := TRUE;
          RETURN;
        IFEND;
      FOREND;
    IFEND;

  FUNCEND osp$file_access_condition;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$find_access_condition_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$find_access_condition_entry
    (    file_access_condition: fst$file_access_condition;
     VAR access_condition_entry: fst$access_condition_entry;
     VAR entry_found: boolean);

    VAR
      i: ost$positive_integers;

    entry_found := FALSE;
    FOR i := LOWERBOUND (file_access_conditions) TO UPPERBOUND (file_access_conditions) DO
      IF file_access_conditions [i].file_access_condition = file_access_condition THEN
        access_condition_entry := file_access_conditions [i];
        entry_found := TRUE;
        RETURN;
      IFEND;
    FOREND;

  PROCEND osp$find_access_condition_entry;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$get_access_condition_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_access_condition_entry
    (VAR status {input, output} : ost$status;
     VAR access_condition_entry: fst$access_condition_entry;
     VAR entry_found: boolean);

    VAR
      i: integer,
      local_status: ost$status;

    entry_found := FALSE;

    FOR i := LOWERBOUND (condition_mapping_table) TO UPPERBOUND (condition_mapping_table) DO
      IF condition_mapping_table [i].internal_status_condition = status.condition THEN
        osp$find_access_condition_entry (condition_mapping_table [i].file_access_condition,
              access_condition_entry, entry_found);

        IF (access_condition_entry.status_condition <> status.condition) THEN
          status.condition := access_condition_entry.status_condition;
        IFEND;
        RETURN;
      IFEND;
    FOREND;

  PROCEND osp$get_access_condition_entry;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$get_condition_status', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_condition_status
    (    condition_information: ^pmt$condition_information;
     VAR condition_status: ost$status);

{Purpose: This interface returns the abnormal status associated with a raised
{user-defined condition.

{Design:

{ When a user-defined file access exception condition is raised, a record of
{ TYPE ost$condition_information is implicitly passed to a condition handler
{ via the condition_information parameter.  The first field of this record is
{ the status of the condition which is NORMAL.  The remainder of the record
{ is assumed to follow this first field.  As a precaution, we check for the
{ validity of the input record by verifying that the status is normal and the
{ condition_status is in fact a file access exception condition.

    VAR
      exception_context: ^ost$condition_information;

    exception_context := condition_information;

    osp$set_status_condition (pfe$volume_not_online, condition_status);
    IF exception_context <> NIL THEN
      IF exception_context^.when_handler_status AND osp$file_access_condition
            (exception_context^.exception_status) THEN
        condition_status := exception_context^.exception_status;
      IFEND;
    IFEND;

  PROCEND osp$get_condition_status;
?? OLDTITLE ??
MODEND osm$file_access_conditions;

*DECK DECK=OSM$FLUSH_ALLOCATION_INFO EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE OS Interface : Device Log Flushing' ??
MODULE osm$flush_allocation_info;

{  PURPOSE:
{         This module contains the interface to force a flush of
{   modified pages in the device logs to disk at 'split allocation
{   log time', rather than waiting until 'device table update time',
{   thereby capturing allocation and initialization information
{   that might be lost in the event of a crash and recovery without
{   image. This interface cannot be used above ring 6. It has been
{   provided for use by the IMDM product to ensure more integrity
{   for the database.
{
{   NOTE:
{   There could be a negative performance impact if this interface
{   is used too often. Normally the logger task runs every 30 secs.
{   in which the allocation log is split and the modified pages in the
{   device logs are written to disk. A counter has been added to keep
{   track of use of this interface (dmv$flush_dev_log_pages_count).

?? PUSH (LISTEXT := ON) ??
*copyc dmp$split_allocation_log
?? POP ??

  PROCEDURE [XDCL, #GATE] osp$flush_allocation_info (VAR status: ost$status);

    VAR
      local_status: ost$status;

    status.normal := TRUE;

    dmp$split_allocation_log (TRUE, local_status);

  PROCEND osp$flush_allocation_info;

MODEND osm$flush_allocation_info;
*DECK DECK=OSM$GENERATE_MESSAGE_TEMPLATE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE message template generator' ??
MODULE osm$generate_message_template ALIAS 'genmt';

{
{ PURPOSE:
{   The purpose of this module is to generate a list of commands to create
{   message templates.  The commands include CREATE_MESSAGE_MODULE,
{   CREATE_STATUS_MESSAGE, and END_MESSAGE_MODULE.
{
{ DESIGN:
{
{   An input file of condition code definitions is processed.  The list of
{   generated commands is written to an output file.  An error file will
{   contain errors encountered by the GENMT program.
{
{   The GENMT program will terminate abnormally if a file cannot be accessed
{   properly, such as by open, read, or write.
{
{   The format and basic processing of the input file is described below:
{
{     Any line beginning with a CYBIL name where the third and fourth characters
{     are c$, c#, e$, or e# is considered a constant to be evaluated by the GENMT
{     program.  An e$ or e# constant is considered by GENMT to be the start of an
{     condition code definition and is processed accordingly.
{
{     A constant may be declared in the following ways:
{       constant = integer
{               OR
{       constant = string (only for c$ or c#)
{               OR
{       constant = constant
{               OR
{       constant = constant + integer
{               OR
{       constant = (($INTEGER ('x') * 100(16)) + $INTEGER ('y')) * 1000000(16)
{         where 'x' and 'y' are any one character
{               OR
{       constant = (($INTEGER ('x') * 100(16)) + $INTEGER ('y')) * 1000000(16) + integer
{
{     In the case of an e$ or e# constant the condition name and condition code are
{     defined at this point.
{
{    Only one constant declaration per line is recognized.  The constant declaration
{    must be contained on one line.  Only integer constants can be referenced in
{    other constant declarations.
{
{  * IF a constant is declared more than once the first definition is used in
{    future references of other constant declarations.
{
{    Any consecutive lines beginning with '{' directly following an e$ or e# constant
{    declaration are processed for the error severity level and message text.
{    The lines may contain a corresponding end bracket to signify the end of the
{    line or the end bracket may be excluded.  IF an end_bracket is found and is
{    preceeded by any blanks, an ellipsis is concatenated to the end of the blanks
{    as part of the message text.  If any of these lines contain all blanks (excluding
{    the beginning and end brackets) the searching for more message text is terminated.
{
{  * The severity level is the first character after '{' of the first line.  If
{    one is not found 'E' is assumed.  The first non-blank character found on the
{    line following the severity level is considered the start of the message text.
{
{    A condition definition will generate a CREATE_STATUS_MESSAGE command written to
{    the output file.  The message text will be printed line by line as found in the
{    input file.
{
{    Any line beginning with 'MODULE' OR 'MODEND' will generate a CREATE_MESSAGE_MODULE
{    or END_MESSAGE_MODULE command, respectively, written to the output file.
{
{    All other unprocessed lines and excessive characters of processed lines
{    are IGNORED.
{      Example: ignore_constant =1;              : This line is ignored.
{      Example: xxe$error = 10; {E message text  : the characters starting with ';'
{                                                  to the end of line are ignored.
{
{    Error messages are issued for all errors GENMT may find while processing a line.
{    At that point the constant declaration or complete condition definition is
{    ignored except for 2 errors noted above with '*'.
{
{  Any line to be printed to the output file whose length is longer than the file's
{  page width will be broken into multiple print lines.  Each print line except
{  the last one will be concatenated with an ellipsis.
{
{  One example of minimum information that GENMT will process correctly:
{    MODULE errors
{    xxc$one_thousand = 1000
{    xxc$one_thousand_ten = xxc$one_thousand + 10
{    xxe$first_error = xxc$one_thousand_ten + 1
{    {E xxxxxxxxx
{    {xxxxxxxxxxx
{    xxe$second_error = 1012
{    {E xxxxxxx
{    MODEND
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_mt_generator
*copyc clt$parameter_list
*copyc oss$job_paged_literal
*copyc ost$message_module_severity
*copyc ost$status
*copyc osv$lower_to_upper
?? POP ??
*copyc amp$fetch
*copyc amp$get_next
*copyc amp$put_next
*copyc clp$evaluate_parameters
*copyc clp$evaluate_token
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_parameter
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc osp$unpack_status_condition
?? EJECT ??

  TYPE
    work_files = (input_file, output_file, error_file),
    input_line_description = (module_line, modend_line, c$_or_c#_line, e$_or_e#_line, message_text_line,
          eoi_encountered);

  VAR
    file_identifier: array [work_files] of amt$file_identifier,
    error_file_attributes: array [1 .. 1] of amt$fetch_item,
    output_file_attributes: array [1 .. 1] of amt$fetch_item,
    ignore_byte_address: amt$file_byte_address,
    input_line: ost$string,
    input_line_type: input_line_description,
    processing_message_text: boolean,
    start_pos: clt$string_index;

?? TITLE := 'clp$generate_message_template', EJECT ??

{
{    The purpose of this request is to generate a list of commands to create
{  message templates.
{
{    Note: Memory is allocated for a linked list.  The memory is not freed in
{  this procedure.  It is expected to be freed at program termination.
{

  PROCEDURE [XDCL] clp$generate_message_template
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$genmt) generate_message_template, generate_message_templates, genmt (
{   input, i: file = $required
{   output, o: file = $required
{   error, e: file = $errors
{   product_identifier, identifier, pi: name 1..2 = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 10] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 27, 17, 48, 55, 890], clc$command, 10, 5, 2, 0, 0, 0, 5, 'OSM$GENMT'],
            [['E                              ', clc$abbreviation_entry, 3],
            ['ERROR                          ', clc$nominal_entry, 3],
            ['I                              ', clc$abbreviation_entry, 1],
            ['IDENTIFIER                     ', clc$alias_entry, 4],
            ['INPUT                          ', clc$nominal_entry, 1],
            ['O                              ', clc$abbreviation_entry, 2],
            ['OUTPUT                         ', clc$nominal_entry, 2],
            ['PI                             ', clc$abbreviation_entry, 4],
            ['PRODUCT_IDENTIFIER             ', clc$nominal_entry, 4],
            ['STATUS                         ', clc$nominal_entry, 5]], [

{ PARAMETER 1

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 3

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 4

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type]],

{ PARAMETER 2

      [[1, 0, clc$file_type]],

{ PARAMETER 3

      [[1, 0, clc$file_type], '$errors'],

{ PARAMETER 4

      [[1, 0, clc$name_type], [1, 2]],

{ PARAMETER 5

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$input = 1,
      p$output = 2,
      p$error = 3,
      p$product_identifier = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

?? NEWTITLE := 'process_base_expression', EJECT ??

{    This procedure will process the following expressions:
{      (($INTEGER ('x') * 100(16)) + $INTEGER ('y')) * 1000000(16)
{                                OR
{      (($INTEGER ('x') * 100(16)) + $INTEGER ('y')) * 1000000(16) + integer
{      where 'x' and 'y' are any one character.

    PROCEDURE process_base_expression;

?? NEWTITLE := 'get_character', EJECT ??

      PROCEDURE [INLINE] get_character;

        VAR
*IF NOT $true(osv$unix_tools_on_ve)
          offset: 100(16) .. 1000000(16);
*ELSE
          offset: 100(16) .. 10000(16);
*IFEND

      /ok/
        BEGIN
          clp$evaluate_token (input_line.value (1, input_line.size), evaluation_options, start_pos,
                ignore_preceding_spaces, token, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF NOT ((first_char = '') AND (token.kind = clc$left_parenthesis_token) OR
                (token.kind = clc$add_token)) THEN
            EXIT /ok/;
          IFEND;

          clp$evaluate_token (input_line.value (1, input_line.size), evaluation_options, start_pos,
                ignore_preceding_spaces, token, status);
          IF NOT status.normal THEN
            RETURN;
          ELSEIF (token.kind <> clc$name_token) OR (token.str.value (1, token.str.size) <> '$INTEGER') THEN
            EXIT /ok/;
          IFEND;

          clp$evaluate_token (input_line.value (1, input_line.size), evaluation_options, start_pos,
                ignore_preceding_spaces, token, status);
          IF NOT status.normal THEN
            RETURN;
          ELSEIF token.kind <> clc$left_parenthesis_token THEN
            EXIT /ok/;
          IFEND;

          clp$evaluate_token (input_line.value (1, input_line.size), evaluation_options, start_pos,
                ignore_preceding_spaces, token, status);
          IF NOT status.normal THEN
            RETURN;
          ELSEIF (token.kind <> clc$string_token) OR (token.str.size <> 1) THEN
            EXIT /ok/;
          IFEND;

          IF first_char = '' THEN
            first_char := token.str.value (1);
            offset := 100(16);
          ELSE
            second_char := token.str.value (1);
*IF NOT $true(osv$unix_tools_on_ve)
            offset := osc$max_status_condition_number + 1;
*ELSE
            offset := 65535 + 1;
*IFEND
            clp$evaluate_token (input_line.value (1, input_line.size), evaluation_options, start_pos,
                  ignore_preceding_spaces, token, status);
            IF NOT status.normal THEN
              RETURN;
            ELSEIF token.kind <> clc$right_parenthesis_token THEN
              EXIT /ok/;
            IFEND;
          IFEND;

          clp$evaluate_token (input_line.value (1, input_line.size), evaluation_options, start_pos,
                ignore_preceding_spaces, token, status);
          IF NOT status.normal THEN
            RETURN;
          ELSEIF token.kind <> clc$right_parenthesis_token THEN
            EXIT /ok/;
          IFEND;

          clp$evaluate_token (input_line.value (1, input_line.size), evaluation_options, start_pos,
                ignore_preceding_spaces, token, status);
          IF NOT status.normal THEN
            RETURN;
          ELSEIF token.kind <> clc$multiply_token THEN
            EXIT /ok/;
          IFEND;

          clp$evaluate_token (input_line.value (1, input_line.size), evaluation_options, start_pos,
                ignore_preceding_spaces, token, status);
          IF NOT status.normal THEN
            RETURN;
          ELSEIF (token.kind <> clc$unsigned_integer_token) OR (token.int.value <> offset) THEN
            EXIT /ok/;
          IFEND;

          IF second_char = '' THEN
            clp$evaluate_token (input_line.value (1, input_line.size), evaluation_options, start_pos,
                  ignore_preceding_spaces, token, status);
            IF NOT status.normal THEN
              RETURN;
            ELSEIF token.kind <> clc$right_parenthesis_token THEN
              EXIT /ok/;
            IFEND;
          IFEND;

          RETURN;

        END /ok/;

        osp$set_status_abnormal ('CL', cle$unrecognizable_ecc_base, name_token.str.
              value (1, name_token.str.size), status);

      PROCEND get_character;
?? OLDTITLE, EJECT ??

      VAR
        first_char: string (1),
        second_char: string (1),
        count: 1 .. 2;

      first_char := '';
      second_char := '';

      FOR count := 1 TO 2 DO
        get_character;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

      number := (($INTEGER (first_char) * 100(16)) + $INTEGER (second_char)) *
*IF NOT $true(osv$unix_tools_on_ve)
            (osc$max_status_condition_number + 1);
*ELSE
            (65535 + 1);
*IFEND
      process_plus_integer;

    PROCEND process_base_expression;
?? TITLE := 'process_plus_integer', EJECT ??

    PROCEDURE [INLINE] process_plus_integer;

      clp$evaluate_token (input_line.value (1, input_line.size), evaluation_options, start_pos,
            ignore_preceding_spaces, token, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (token.kind <> clc$signed_integer_token) OR (token.int.value <= 0) THEN
        IF token.kind = clc$add_token THEN
          clp$evaluate_token (input_line.value (1, input_line.size), evaluation_options, start_pos,
                ignore_preceding_spaces, token, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          osp$set_status_abnormal ('CL', cle$expecting_integer_value, token.descriptor, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, name_token.str.
                value (1, name_token.str.size), status);
        IFEND;
        RETURN;
      IFEND;

      IF (number + token.int.value) > osc$max_condition THEN
        osp$set_status_abnormal ('CL', cle$cond_code_too_large, name_token.str.value (1, name_token.str.size),
              status);
        RETURN;
      IFEND;
      number := number + token.int.value;

    PROCEND process_plus_integer;
?? TITLE := 'process_constant_expression', EJECT ??

    PROCEDURE [INLINE] process_constant_expression;

      search_for_defined_constant;
      IF status.normal THEN
        process_plus_integer;
      IFEND;

    PROCEND process_constant_expression;
?? TITLE := 'search_for_defined_constant', EJECT ??

    PROCEDURE [INLINE] search_for_defined_constant;

      IF (token.str.value (3, 2) = 'C$') OR (token.str.value (3, 2) = 'C#') THEN
        defined_constant := current_c$_or_c#_constant;
      ELSEIF (token.str.value (3, 2) = 'E$') OR (token.str.value (3, 2) = 'E#') THEN
        defined_constant := current_e$_or_e#_constant;
      ELSE
        defined_constant := NIL;
      IFEND;

      WHILE defined_constant <> NIL DO
        IF defined_constant^.name = token.str.value THEN
          number := defined_constant^.value;
          RETURN;
        IFEND;
        defined_constant := defined_constant^.next_defined_constant;
      WHILEND;

      osp$set_status_abnormal ('CL', cle$constant_not_defined, token.str.value (1, token.str.size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, name_token.str.
            value (1, name_token.str.size), status);

    PROCEND search_for_defined_constant;
?? TITLE := 'save_defined_constant', EJECT ??

    PROCEDURE [INLINE] save_defined_constant;

      IF input_line_type = c$_or_c#_line THEN
        defined_constant := current_c$_or_c#_constant;
      ELSE
        defined_constant := current_e$_or_e#_constant;
      IFEND;

      WHILE defined_constant <> NIL DO
        IF defined_constant^.name = name_token.str.value THEN
          osp$set_status_abnormal ('CL', cle$constant_already_defined, name_token.str.
                value (1, name_token.str.size), status);
          RETURN;
        IFEND;
        defined_constant := defined_constant^.next_defined_constant;
      WHILEND;

      ALLOCATE defined_constant;
      IF defined_constant = NIL THEN
        osp$set_status_abnormal ('CL', cle$constant_stack_overflow, name_token.str.
              value (1, name_token.str.size), status);
        RETURN;
      IFEND;
      defined_constant^.name := name_token.str.value;
      defined_constant^.value := number;
      IF input_line_type = c$_or_c#_line THEN
        defined_constant^.next_defined_constant := current_c$_or_c#_constant;
        current_c$_or_c#_constant := defined_constant;
      ELSE
        defined_constant^.next_defined_constant := current_e$_or_e#_constant;
        current_e$_or_e#_constant := defined_constant;
      IFEND;

    PROCEND save_defined_constant;
?? TITLE := 'determine_severity_level', EJECT ??

    PROCEDURE [INLINE] determine_severity_level;

      IF start_pos <= input_line.size THEN

      /get_severity_level/
        FOR severity_char := LOWERBOUND (severity_levels) TO UPPERBOUND (severity_levels) DO
          IF input_line.value (start_pos) = severity_levels [severity_char] THEN
            waiting_for_severity_level := FALSE;
            start_pos := start_pos + 1;
            WHILE (start_pos <= input_line.size) AND (input_line.value (start_pos) = ' ') DO
              start_pos := start_pos + 1;
            WHILEND;
            RETURN;
          IFEND;
        FOREND /get_severity_level/;
      ELSE
        severity_char := UPPERBOUND (severity_levels);
      IFEND;

      IF waiting_for_severity_level THEN
        osp$set_status_abnormal ('CL', cle$no_severity_level, name_token.str.value (1, name_token.str.size),
              status);
        print_error (status);
        waiting_for_severity_level := FALSE;
      IFEND;

    PROCEND determine_severity_level;
?? OLDTITLE, EJECT ??

    CONST
*IF NOT $true(osv$unix_tools_on_ve)
      cresm_command_line_size = 144; {Max number of characters in a   CRESM command without the message text.}
*ELSE
      cresm_command_line_size = 145; {Max number of characters in a   CRESM command without the message text.}
*IFEND

    TYPE
      constant_info = record
        name: ost$name,
        value: ost$status_condition,
        next_defined_constant: constant_ptr,
      recend,
      constant_ptr = ^constant_info;

    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      command_line: string (cresm_command_line_size),
      command_line_size: integer,
*IF NOT $true(osv$unix_tools_on_ve)
      condition_number: ost$status_condition_number,
*ELSE
      condition_number: ost$status_condition_code,
*IFEND
      current_c$_or_c#_constant: constant_ptr,
      current_e$_or_e#_constant: constant_ptr,
      default_creation_attributes: array [1 .. 2] of fst$file_cycle_attribute,
      defined_constant: constant_ptr,
      evaluation_options: clt$token_evaluation_options,
      file: work_files,
      file_names: array [work_files] of ^fst$file_reference,
      get_another_line: boolean,
      id_characters: ost$status_identifier,
      ignore_preceding_spaces: boolean,
      local_status: ost$status,
      name_token: clt$lexical_token,
      number: ost$status_condition,
      severity_char: ost$message_module_severity,
      severity_key: [STATIC, READ, oss$job_paged_literal] array [ost$message_module_severity] of
            ost$string := [[11, 'INFORMATIVE'], [7, 'WARNING'], [5, 'FATAL'], [12, 'CATASTROPHIC'], [12,
            'NON_STANDARD'], [9, 'DEPENDENT'], [5, 'ERROR']],
      severity_levels: [STATIC, READ, oss$job_paged_literal] array [ost$message_module_severity] of
            char := ['I', 'W', 'F', 'C', 'N', 'D', 'E'],
      token: clt$lexical_token,
      validation_attributes: array [1 .. 5] of fst$file_cycle_attribute,
      waiting_for_message_text: boolean,
      waiting_for_severity_level: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_names [input_file] := pvt [p$input].value^.file_value;
    file_names [output_file] := pvt [p$output].value^.file_value;
    file_names [error_file] := pvt [p$error].value^.file_value;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_options [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
    attachment_options [2].selector := fsc$open_share_modes;
    attachment_options [2].open_share_modes := $fst$file_access_options [fsc$read, fsc$execute];
    attachment_options [3].selector := fsc$create_file;
    attachment_options [3].create_file := FALSE;
    validation_attributes [1].selector := fsc$null_attribute;
    validation_attributes [2].selector := fsc$file_contents_and_processor;
    validation_attributes [2].file_contents := fsc$legible_data;
    validation_attributes [2].file_processor := osc$null_name;
    validation_attributes [3].selector := fsc$file_contents_and_processor;
    validation_attributes [3].file_contents := amc$legible;
    validation_attributes [3].file_processor := osc$null_name;
    validation_attributes [4].selector := fsc$file_contents_and_processor;
    validation_attributes [4].file_contents := fsc$data;
    validation_attributes [4].file_processor := osc$null_name;
    validation_attributes [5].selector := fsc$file_contents_and_processor;
    validation_attributes [5].file_contents := fsc$unknown_contents;
    validation_attributes [5].file_processor := osc$null_name;
    fsp$open_file (file_names [input_file]^, amc$record, ^attachment_options, NIL, NIL,
          ^validation_attributes, NIL, file_identifier [input_file], status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
    attachment_options [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options [1].share_modes.value := $fst$file_access_options [];
    attachment_options [2].selector := fsc$access_and_share_modes;
    attachment_options [2].access_modes.selector := fsc$specific_access_modes;
    attachment_options [2].access_modes.value := $fst$file_access_options [fsc$append];
    attachment_options [2].share_modes.selector := fsc$specific_share_modes;
    attachment_options [2].share_modes.value := $fst$file_access_options [];
    attachment_options [3].selector := fsc$open_share_modes;
    attachment_options [3].open_share_modes := -$fst$file_access_options [];
    validation_attributes [1].selector := fsc$file_contents_and_processor;
    validation_attributes [1].file_contents := fsc$legible_scl_include;
    validation_attributes [1].file_processor := osc$null_name;
    default_creation_attributes [1].selector := fsc$file_contents_and_processor;
    default_creation_attributes [1].file_contents := fsc$legible_scl_include;
    default_creation_attributes [1].file_processor := osc$null_name;
    default_creation_attributes [2].selector := fsc$page_format;
    default_creation_attributes [2].page_format := amc$untitled_form;
    fsp$open_file (file_names [output_file]^, amc$record, ^attachment_options, ^default_creation_attributes,
          NIL, ^validation_attributes, NIL, file_identifier [output_file], status);
    IF NOT status.normal THEN
      fsp$close_file (file_identifier [input_file], local_status);
      RETURN;
    IFEND;

    validation_attributes [1].file_contents := fsc$list;
    default_creation_attributes [1].file_contents := fsc$list;
    default_creation_attributes [1].file_processor := osc$null_name;
    default_creation_attributes [2].page_format := amc$continuous_form;
    fsp$open_file (file_names [error_file]^, amc$record, ^attachment_options, ^default_creation_attributes,
          NIL, ^validation_attributes, NIL, file_identifier [error_file], status);
    IF NOT status.normal THEN
      fsp$close_file (file_identifier [input_file], local_status);
      fsp$close_file (file_identifier [output_file], local_status);
      RETURN;
    IFEND;

  /generate_template/
    BEGIN
      output_file_attributes [1].key := amc$page_width;
      amp$fetch (file_identifier [output_file], output_file_attributes, status);
      IF status.normal THEN
        error_file_attributes [1].key := amc$page_width;
        amp$fetch (file_identifier [error_file], error_file_attributes, status);
      IFEND;

      IF NOT status.normal THEN
        EXIT /generate_template/;
      IFEND;

      IF output_file_attributes [1].page_width < osc$min_status_message_line THEN
        output_file_attributes [1].page_width := osc$min_status_message_line;
      IFEND;
      IF error_file_attributes [1].page_width > osc$max_status_message_line THEN
        error_file_attributes [1].page_width := osc$max_status_message_line;
      ELSEIF error_file_attributes [1].page_width < osc$min_status_message_line THEN
        error_file_attributes [1].page_width := osc$min_status_message_line;
      IFEND;

      current_c$_or_c#_constant := NIL;
      current_e$_or_e#_constant := NIL;
      get_another_line := TRUE;
      processing_message_text := FALSE;
      evaluation_options := $clt$token_evaluation_options [clc$ignore_spaces_before_token,
            clc$comment_is_token, clc$classify_name_token, clc$international_char_is_token];

    /process_input_file/
      WHILE TRUE DO

        IF NOT status.normal THEN
          print_error (status);
          IF NOT status.normal THEN
            EXIT /process_input_file/;
          IFEND;
        IFEND;

        IF get_another_line THEN
          get_input_line (status);
          IF NOT status.normal THEN
            EXIT /process_input_file/;
          IFEND
        ELSE
          get_another_line := TRUE;
        IFEND;

        CASE input_line_type OF
        = eoi_encountered =
          EXIT /process_input_file/;

        = c$_or_c#_line, e$_or_e#_line =
          clp$evaluate_token (input_line.value (1, input_line.size), evaluation_options, start_pos,
                ignore_preceding_spaces, name_token, status);
          IF NOT status.normal THEN
            CYCLE /process_input_file/;
          IFEND;
          IF name_token.kind <> clc$cybil_name_token THEN
            osp$set_status_abnormal ('CL', cle$expecting_name_value, input_line.
                  value (token.text_index, token.text_size), status);
            CYCLE /process_input_file/;
          IFEND;

          clp$evaluate_token (input_line.value (1, input_line.size), evaluation_options, start_pos,
                ignore_preceding_spaces, token, status);
          IF NOT status.normal THEN
            CYCLE /process_input_file/;
          IFEND;
          IF token.kind <> clc$equal_token THEN
            osp$set_status_abnormal ('CL', cle$expecting_equal_sign, token.descriptor, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, name_token.str.
                  value (1, name_token.str.size), status);
            CYCLE /process_input_file/;
          IFEND;

          clp$evaluate_token (input_line.value (1, input_line.size), evaluation_options, start_pos,
                ignore_preceding_spaces, token, status);
          IF NOT status.normal THEN
            CYCLE /process_input_file/;
          IFEND;

          CASE token.kind OF
          = clc$unsigned_integer_token =
            IF token.int.value > osc$max_condition THEN
              osp$set_status_abnormal ('CL', cle$cond_code_too_large, name_token.str.
                    value (1, name_token.str.size), status);
              CYCLE /process_input_file/;
            IFEND;
            number := token.int.value;

          = clc$left_parenthesis_token =
            process_base_expression;
            IF NOT status.normal THEN
              CYCLE /process_input_file/;
            IFEND;

          = clc$cybil_name_token, clc$simple_name_token =
            process_constant_expression;
            IF NOT status.normal THEN
              CYCLE /process_input_file/;
            IFEND;

          ELSE
            IF input_line_type = e$_or_e#_line THEN
              osp$set_status_abnormal ('CL', cle$invalid_integer_constant, name_token.str.
                    value (1, name_token.str.size), status);
            ELSEIF token.kind <> clc$string_token THEN
              osp$set_status_abnormal ('CL', cle$invalid_int_or_string_const, name_token.str.
                    value (1, name_token.str.size), status);
            IFEND;
            CYCLE /process_input_file/;
          CASEND;

          save_defined_constant;
          IF defined_constant = NIL THEN
            EXIT /process_input_file/;
          IFEND;
          IF input_line_type = c$_or_c#_line THEN
            CYCLE /process_input_file/;
          IFEND;

*IF NOT $true(osv$unix_tools_on_ve)
          IF number > osc$max_status_condition_number THEN
            osp$unpack_status_condition (number, id_characters, condition_number);
          ELSE
*IFEND
            id_characters := name_token.str.value (1, 2);
            condition_number := number;
*IF NOT $true(osv$unix_tools_on_ve)
          IFEND;
*IFEND
          IF pvt [p$product_identifier].specified THEN
            id_characters := pvt [p$product_identifier].value^.name_value (1, 2);
          IFEND;

          waiting_for_severity_level := TRUE;
          waiting_for_message_text := TRUE;
          processing_message_text := TRUE;

          WHILE processing_message_text DO
            get_input_line (status);
            IF NOT status.normal THEN
              EXIT /process_input_file/;
            IFEND;

            IF input_line_type = message_text_line THEN
              IF waiting_for_severity_level THEN
                determine_severity_level;
                IF NOT status.normal THEN
                  EXIT /process_input_file/;
                IFEND;
              IFEND;

              IF start_pos <= input_line.size THEN
                IF waiting_for_message_text THEN
                  waiting_for_message_text := FALSE;
                  STRINGREP (command_line, command_line_size, 'CREATE_STATUS_MESSAGE', '  NAME=',
                        name_token.str.value (1, name_token.str.size), '  IDENTIFIER=''', id_characters,
                        '''  CODE=', condition_number, '  SEVERITY=', severity_key [severity_char].
                        value (1, severity_key [severity_char].size), '  COLLECT_TEMPLATE_UNTIL=''**''');
                  print_line (command_line (1, command_line_size), status);
                  IF NOT status.normal THEN
                    EXIT /process_input_file/;
                  IFEND;
                IFEND;

                print_line (input_line.value (start_pos, input_line.size - start_pos + 1), status);
                IF NOT status.normal THEN
                  EXIT /process_input_file/;
                IFEND;
              IFEND;
            ELSE
              get_another_line := FALSE;
              IF waiting_for_message_text THEN
                IF waiting_for_severity_level THEN
                  osp$set_status_abnormal ('CL', cle$no_severity_level, name_token.str.
                        value (1, name_token.str.size), status);
                  print_error (status);
                  IF NOT status.normal THEN
                    EXIT /process_input_file/;
                  IFEND;
                IFEND;
                osp$set_status_abnormal ('CL', cle$no_message_text, name_token.str.
                      value (1, name_token.str.size), status);
                CYCLE /process_input_file/;
              ELSE
                command_line := '**';
                command_line_size := 2;
              IFEND;
            IFEND;
          WHILEND;

        = module_line =
          start_pos := start_pos + 6;

          clp$evaluate_token (input_line.value (1, input_line.size), evaluation_options, start_pos,
                ignore_preceding_spaces, token, status);
          IF NOT status.normal THEN
            CYCLE /process_input_file/;
          IFEND;
          IF NOT ((token.kind = clc$cybil_name_token) OR (token.kind = clc$simple_name_token)) THEN
            osp$set_status_abnormal ('CL', cle$expecting_module_name, token.descriptor, status);
            CYCLE /process_input_file/;
          IFEND;

          STRINGREP (command_line, command_line_size, 'CREATE_MESSAGE_MODULE  NAME=', token.str.
                value (1, token.str.size));

        = modend_line =
          command_line := 'END_MESSAGE_MODULE';
          command_line_size := 18;

        ELSE
          osp$set_status_abnormal ('CL', cle$internal_generator_error, name_token.str.
                value (1, name_token.str.size), status);
          CYCLE /process_input_file/;
        CASEND;

        print_line (command_line (1, command_line_size), status);
        IF NOT status.normal THEN
          EXIT /process_input_file/;
        IFEND;

      WHILEND /process_input_file/;
    END /generate_template/;

    FOR file := LOWERBOUND (file_names) TO UPPERBOUND (file_names) DO
      fsp$close_file (file_identifier [file], local_status);
      IF (NOT local_status.normal) AND status.normal THEN
        status := local_status;
      IFEND;
    FOREND;

  PROCEND clp$generate_message_template;
?? TITLE := 'get_input_line', EJECT ??

{
{    The purpose of this request is to repeatedly get the next line of a
{  specified input file until it finds one of six line types.
{
{    The input line types are:
{  module_line,
{  modend_line,
{  c$_or_c#_line,
{  e$_or_e#_line,
{  message_text_line,
{  eoi_encountered.
{

  PROCEDURE get_input_line
    (VAR status: ost$status);

    CONST
      max_upper_case_chars_size = 7;

    VAR
      end_pos: ost$string_size,
      save_pos: ost$string_size,
      position_of_file: amt$file_position,
      string_size: ost$string_size,
      transfer_count: amt$transfer_count,
      upper_case_chars: string (max_upper_case_chars_size);

  /get_next_line/
    WHILE TRUE DO
      amp$get_next (file_identifier [input_file], ^input_line.value, osc$max_string_size, transfer_count,
            ignore_byte_address, position_of_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF position_of_file = amc$eoi THEN
        input_line_type := eoi_encountered;
        processing_message_text := FALSE;
        RETURN;
      IFEND;

      start_pos := 1;
      end_pos := transfer_count;

    /find_non_blank_char/
      WHILE TRUE DO
        IF start_pos > end_pos THEN
          processing_message_text := FALSE;
          CYCLE /get_next_line/;
        IFEND;
        IF input_line.value (start_pos) = ' ' THEN
          start_pos := start_pos + 1;
        ELSE
          EXIT /find_non_blank_char/;
        IFEND;
      WHILEND /find_non_blank_char/;

      IF input_line.value (start_pos) = '{' THEN
        IF processing_message_text THEN
          start_pos := start_pos + 1;
          save_pos := start_pos;

        /find_end_pos/
          WHILE start_pos <= end_pos DO
            CASE input_line.value (end_pos) OF
            = ' ' =
              end_pos := end_pos - 1;

            = '}' =
              end_pos := end_pos - 1;
              IF input_line.value (end_pos) = ' ' THEN
                save_pos := end_pos;
                end_pos := end_pos - 1;
              IFEND;

            ELSE
              IF save_pos <> start_pos THEN
                input_line.value (save_pos + 1, 2) := '..';
                end_pos := save_pos + 2;
              IFEND;
              input_line_type := message_text_line;
              EXIT /get_next_line/;
            CASEND;
          WHILEND /find_end_pos/;
          processing_message_text := FALSE;
        IFEND;
      ELSE
        processing_message_text := FALSE;
        string_size := end_pos - start_pos + 1;

        IF string_size > 3 THEN
          IF string_size > max_upper_case_chars_size THEN
            string_size := max_upper_case_chars_size;
          IFEND;
          #TRANSLATE (osv$lower_to_upper, input_line.value (start_pos, string_size), upper_case_chars);

          IF (upper_case_chars (3, 2) = 'C$') OR (upper_case_chars (3, 2) = 'C#') THEN
            input_line_type := c$_or_c#_line;
            EXIT /get_next_line/;
          ELSEIF (upper_case_chars (3, 2) = 'E$') OR (upper_case_chars (3, 2) = 'E#') THEN
            input_line_type := e$_or_e#_line;
            EXIT /get_next_line/;
          ELSEIF upper_case_chars = 'MODULE ' THEN
            input_line_type := module_line;
            EXIT /get_next_line/;
          ELSEIF upper_case_chars = 'MODULE;' THEN
            input_line_type := module_line;
            EXIT /get_next_line/;
          ELSEIF upper_case_chars = 'MODEND ' THEN
            input_line_type := modend_line;
            EXIT /get_next_line/;
          ELSEIF upper_case_chars = 'MODEND;' THEN
            input_line_type := modend_line;
            EXIT /get_next_line/;
          IFEND;
        IFEND;
      IFEND;
    WHILEND /get_next_line/;

    input_line.size := end_pos;

  PROCEND get_input_line;
?? TITLE := 'print_line', EJECT ??

{
{    The purpose of this request is to print a line to a specified
{  output file.

  PROCEDURE print_line
    (    line: string ( * );
     VAR status: ost$status);

    VAR
      char_index: ost$string_size,
      found_other_characters: boolean,
      output_line: ^string ( * ),
      output_line_size: integer,
      page_width: amt$page_width,
      remaining_text: ost$string_size,
      start_index: ost$string_size;

    remaining_text := STRLENGTH (line);
    IF remaining_text <= output_file_attributes [1].page_width THEN
      amp$put_next (file_identifier [output_file], ^line, remaining_text, ignore_byte_address, status);
      RETURN;
    IFEND;

    PUSH output_line: [output_file_attributes [1].page_width];
    start_index := 1;

    WHILE TRUE DO
      found_other_characters := FALSE;
      page_width := output_file_attributes [1].page_width - 2;

    /determine_page_width/
      FOR char_index := (start_index + page_width - 1) DOWNTO start_index DO
        CASE line (char_index) OF
        = ' ' =
          page_width := char_index - start_index + 1;
          EXIT /determine_page_width/;

        = '.' =
          IF NOT found_other_characters THEN
            IF page_width > 1 THEN
              page_width := page_width - 1;
            ELSE
              page_width := output_file_attributes [1].page_width - 2;
            IFEND;
          IFEND;

        ELSE
          found_other_characters := TRUE;
        CASEND;
      FOREND /determine_page_width/;

      STRINGREP (output_line^, output_line_size, line (start_index, page_width), '..');
      amp$put_next (file_identifier [output_file], output_line, output_line_size, ignore_byte_address,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      remaining_text := remaining_text - page_width;
      start_index := start_index + page_width;

      IF remaining_text <= output_file_attributes [1].page_width THEN
        amp$put_next (file_identifier [output_file], ^line (start_index), remaining_text, ignore_byte_address,
              status);
        RETURN;
      IFEND;
    WHILEND;

  PROCEND print_line;
?? TITLE := 'print_error', EJECT ??

{
{    The purpose of this request is to print the status error message in a
{  specified error file.
{

  PROCEDURE print_error
    (VAR status: ost$status);

    VAR
      local_status: ost$status,
      message: ost$status_message,
      message_area: ^ost$status_message,
      message_line_count: ^ost$status_message_line_count,
      message_line_index: 1 .. osc$max_status_message_lines,
      message_line_size: ^ost$status_message_line_size,
      message_line: ^string ( * );


    osp$format_message (status, osc$full_message_level, error_file_attributes [1].page_width, message,
          local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

    message_area := ^message;
    RESET message_area;
    NEXT message_line_count IN message_area;
    FOR message_line_index := 1 TO message_line_count^ DO
      NEXT message_line_size IN message_area;
      NEXT message_line: [message_line_size^] IN message_area;
      amp$put_next (file_identifier [error_file], message_line, message_line_size^, ignore_byte_address,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND print_error;

MODEND osm$generate_message_template;
*DECK DECK=OSM$HEAP_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'Heap Management' ??
MODULE osm$heap_manager;

{ PURPOSE:
{   This module contains procedures to manage system heaps.  Its specific
{   functions are to allocate space in a heap, free space in a heap, reset a
{   heap, and verify a heap.

?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc dmt$error_condition_codes
*copyc osd$keypoints
*copyc oss$mainframe_pageable
*copyc ost$hardware_subranges
*copyc ost$heap
*copyc ost$prevalidate_free_result
*copyc ost$signature_lock
*copyc ost$stack_frame_save_area
*copyc ptk$performance_keypoints
?? POP ??
?? EJECT ??
*copyc i#real_memory_address
*copyc mmp$assign_contiguous_memory
*copyc mmp$free_pages
*copyc mmp$os_preallocate_file_space
*copyc mmp$verify_no_space_available
*copyc osp$initialize_sig_lock
*copyc osp$system_error
*copyc pmp$delay
*copyc pmp$get_executing_task_gtid
*copyc pmp$zero_out_table
*copyc osv$page_size
*copyc mmv$tables_initialized
*copyc syv$enable_heap_trace
*copyc syv$verify_heap_linkage

*copyc i#disable_traps
*copyc i#restore_traps
*copyc osp$clear_job_signature_lock
*copyc osp$clear_mainframe_sig_lock
*copyc osp$set_job_signature_lock
*copyc osp$set_mainframe_sig_lock

?? TITLE := '  Global Declarations Declared by this module', EJECT ??

  CONST
    min_algorithm = 0,
    traps_enabled_algorithm = 0,
    os_heap_algorithm = 1,
    max_algorithm = 2;

  CONST
    allocation_id = -45723,
    trace_allocation_id = 19813,
    heap_id = 213651(16), { used to validate heap pointer
    min_fragment_size = 3; { minimum size of fragment

  TYPE
    ost$hp_heap_space_desc = record
      link: ost$halfword,
      length: ost$halfword,
      case (free_b, busy_b, busy_b_trace) of
      = free_b =
        fwd: ost$halfword,
        bkw: ost$halfword,
      = busy_b =
        allocation_id: integer,
      = busy_b_trace =
        p_register: ost$pva,
        trace_allocation_id: 0 .. 0ffff(16),
      casend,
    recend,

    ost$hp_heap = record
      lock: ALIGNED [0 MOD 32] ost$signature_lock,
      unused: string (16),     {Retain for compatibility with previous systems.}
      id: ost$halfword,
      base: ost$halfword,
      desc_per_page: ost$halfword,
      lock_option: boolean,
      algorithm: 0 .. 255,
      sd: ALIGNED [0 MOD 32] array [0 .. 10000000] of ost$hp_heap_space_desc,
    recend;

  TYPE
    ptr_variant = record
      case t: (ptr, cy80, stringp) of
      = ptr =
        ptr: ^ost$hp_heap,
      = cy80 =
        ringseg: 0 .. 0ffff(16),
        bytenum: ost$halfword,
      = stringp =
        sp: ^string (255),
      casend,
    recend;

*copyc syv$perf_keypoints_enabled

?? OLDTITLE, EJECT ??

{ This procedure is used to remove a block from the free chain.

  PROCEDURE [INLINE] remove_block_from_free_chain
    (    i: integer;
         hp: ^ost$hp_heap);

    VAR
      inext: integer,
      iprev: integer;

    inext := hp^.sd [i].fwd;
    iprev := hp^.sd [i].bkw;
    hp^.sd [inext].bkw := iprev;
    hp^.sd [iprev].fwd := inext;
  PROCEND remove_block_from_free_chain;

?? SKIP := 2 ??

  PROCEDURE  check_heap
    (    hp: ^ost$hp_heap;
     VAR ok: boolean);

    VAR
      inext: integer;

    ok := TRUE;
    inext := 1;
    WHILE inext <> hp^.sd [0].bkw DO
      IF hp^.sd [hp^.sd [inext].length + inext].link <> inext THEN
        ok := FALSE;
        RETURN;
      IFEND;
      inext := hp^.sd [inext].length + inext;
    WHILEND;
  PROCEND check_heap;

?? NEWTITLE := '  preallocate_heap_space', EJECT ??

  PROCEDURE preallocate_heap_space
    (    block_index: ost$halfword;
         ptr_heap: {i^/o^} ^ost$hp_heap;
     VAR ok: boolean);

    CONST
      max_attempts = 3;

    VAR
      attempt: 1 .. max_attempts,
      maximum_wait_seconds: integer,
      no_space_available: boolean,
      status: ost$status;

    maximum_wait_seconds := 1;

  /preallocate_file_space/
    FOR attempt := 1 TO max_attempts DO
      mmp$os_preallocate_file_space (ptr_heap, #OFFSET (^ptr_heap^.sd [block_index]), maximum_wait_seconds,
            status);
      IF status.normal THEN
        ok := TRUE;
        RETURN;
      ELSEIF status.condition = dme$unable_to_alloc_all_space THEN
        mmp$verify_no_space_available (ptr_heap, no_space_available, status);
        IF NOT status.normal THEN
          EXIT /preallocate_file_space/;
        ELSEIF no_space_available THEN
          EXIT /preallocate_file_space/;
        IFEND;
      IFEND;
      maximum_wait_seconds := 60;
      pmp$delay (2000 {2 seconds}, status);

    FOREND /preallocate_file_space/;

    ok := FALSE;
  PROCEND preallocate_heap_space;

?? TITLE := '  [XDCL, #GATE] cyp$allocate', EJECT ??

  PROCEDURE [XDCL, #GATE] cyp$allocate
    (VAR up: ^ost$hp_heap_space_desc;
         length: ost$halfword;
         hp: ^ost$hp_heap;
         alignment_base: ost$halfword);

    VAR
      alength: 0 .. 0fffffff(16),
      alloc_size: integer,
      desc_in_page: integer,
      enable_heap_trace: boolean,
      system_error_message: string (80),
      i: integer,
      iprev: integer,
      iq: integer,
      off: 0 .. 0ffffff(16),
      ok: boolean,
      old_te: 0 .. 3,
      pagecross_size: integer,
      preg: ost$pva,
      psa: ^ost$stack_frame_save_area,
      seg: 0 .. 0ffffff(16),
      status: ost$status,
      taskid: ost$global_task_id;


{ Check heap id.  Abort if id is incorrect.  An incorrect id is caused by the user corrupting the heap
{ pointer, passing an incorrect pointer, or failing to reset the heap.

    IF hp^.id <> heap_id THEN
      osp$system_error ('HEAPMGR - bad heap pointer', NIL);
    IFEND;


{ Calculate the amount of space to allocate.  Space length is expressed in terms of number of descs of space
{ rounded to a multiple of the minimum allocatable unit of descs.  Block control info is included in the
{ length.

    alloc_size := ((length + 47) DIV 32) * 2;
    pagecross_size := alignment_base;
    IF pagecross_size <= 32 THEN
      pagecross_size := 0;
    ELSE
      IF pagecross_size > length THEN
        pagecross_size := length;
      IFEND;
{     IF pagecross_size > osv$page_size THEN
{       osp$system_error ('HEAPMGR - block gt pagesize', NIL);
{     IFEND;
      pagecross_size := ((pagecross_size + 47) DIV 32) * 2;
    IFEND;


{ Set the serialization lock on the heap.


    enable_heap_trace := (hp^.algorithm = os_heap_algorithm) AND syv$enable_heap_trace;
    IF hp^.algorithm > 0 THEN
      i#disable_traps (old_te);
    IFEND;
    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$set_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$set_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;
    IF syv$verify_heap_linkage THEN
      check_heap (hp, ok);
      IF NOT ok THEN
        osp$system_error ('HEAPMGR - heap linkage bad', NIL);
      IFEND;
    IFEND;


{ Search the free blocks in the heap for the first block that is greater than or equal to the required size.
{ Don't let the block cross a page boundary unless the user says it is ok.  If the block being assigned is the
{ last block in the heap and the preceding block is free, combine the two blocks.

    i := hp^.sd [0].fwd;

  /scanloop/
    WHILE i <> 0 DO
      IF hp^.sd [i].length >= alloc_size THEN
        IF pagecross_size = 0 THEN
          EXIT /scanloop/
        IFEND;
        desc_in_page := hp^.desc_per_page - ((i + hp^.base) MOD hp^.desc_per_page);
        IF desc_in_page >= pagecross_size THEN
          EXIT /scanloop/
        IFEND;
        IF (hp^.sd [i].length - desc_in_page) >= alloc_size THEN
          iprev := i;
          i := i + desc_in_page;
          hp^.sd [i].link := iprev;
          IF iprev <> hp^.sd [0].bkw THEN
            hp^.sd [iprev + hp^.sd [iprev].length].link := i;
          IFEND;
          hp^.sd [i].length := hp^.sd [iprev].length - desc_in_page;
          hp^.sd [iprev].length := desc_in_page;
          hp^.sd [i].fwd := hp^.sd [iprev].fwd;
          hp^.sd [iprev].fwd := i;
          hp^.sd [i].bkw := iprev;
          hp^.sd [hp^.sd [i].fwd].bkw := i;
          EXIT /scanloop/;
        IFEND;
      IFEND;
      i := hp^.sd [i].fwd;
    WHILEND /scanloop/;


{ If traps are enabled and more space is needed, then attempt to preallocate the block of space.

    IF i <> 0 THEN
      IF hp^.algorithm = traps_enabled_algorithm THEN
        IF (#offset (^hp^.sd [i + alloc_size]) DIV 16384) >
            (#offset (^hp^.sd [hp^.sd [0].bkw]) DIV 16384) THEN
          preallocate_heap_space (i + alloc_size, hp, ok);
          IF NOT ok THEN
            i := 0;
          IFEND;
        IFEND;
      IFEND;
    IFEND;


{ If the free space is about the same size as the required space, remove the block from the free chain.
{ If the block is a lot bigger than required, split it and leave the unused part in the free block chain.
{ If the selected block is the one and only block in the heap and assigning it would leave the free block
{ chain empty, reject the assignment.

    IF i <> 0 THEN
      IF hp^.sd [i].length < (min_fragment_size + alloc_size) THEN
        IF i = hp^.sd [0].bkw THEN
          i := 0;
        ELSE
          remove_block_from_free_chain (i, hp);
        IFEND;
      ELSE
        hp^.sd [i + alloc_size].length := hp^.sd [i].length - alloc_size;
        hp^.sd [i + alloc_size].link := i;
        hp^.sd [i + alloc_size].fwd := hp^.sd [i].fwd;
        hp^.sd [i + alloc_size].bkw := hp^.sd [i].bkw;
        IF i <> hp^.sd [0].bkw THEN
          hp^.sd [hp^.sd [i].length + i].link := i + alloc_size;
        IFEND;
        hp^.sd [i].length := alloc_size;
        hp^.sd [hp^.sd [i].fwd].bkw := i + alloc_size;
        hp^.sd [hp^.sd [i].bkw].fwd := i + alloc_size;
      IFEND;
    IFEND;


{ Store a unique identifier in the allocation id field; it helps detect bugs and is used in FREE to determine
{ if a block is allocated or free.

    IF i <> 0 THEN
      IF enable_heap_trace THEN
        hp^.sd [i].trace_allocation_id := trace_allocation_id;
        psa := #PREVIOUS_SAVE_AREA ();
        hp^.sd [i].p_register := psa^.minimum_save_area.p_register.pva;
      ELSE
        hp^.sd [i].allocation_id := allocation_id;
      IFEND;
      up := ^hp^.sd [i + 1];
      #KEYPOINT (osk$debug, #SEGMENT (up) * osk$m, osk$allocate);
      IF syv$perf_keypoints_enabled.heap_keypoints THEN
        psa := #PREVIOUS_SAVE_AREA ();
        preg := psa^.minimum_save_area.p_register.pva;
        alength := hp^.sd [i].length * #SIZE (ost$hp_heap_space_desc);
        pmp$get_executing_task_gtid (taskid);
        iq := taskid.index * 256 + taskid.seqno;
        seg := #SEGMENT (up);
        off := #OFFSET (up);
        #KEYPOINT (osk$performance, osk$m * iq, ptk$allocate_gtid);
        #KEYPOINT (osk$performance, osk$m * seg, ptk$allocate_segment);
        #KEYPOINT (osk$performance, osk$m * (off MOD 100000(16)), ptk$allocate_lower_offset);
        #KEYPOINT (osk$performance, osk$m * (off DIV 100000(16)), ptk$allocate_upper_offset);
        #KEYPOINT (osk$performance, osk$m * preg.seg, ptk$allocate_p_segment);
        #KEYPOINT (osk$performance, osk$m * (preg.offset MOD 100000(16)), ptk$allocate_p_lower_offset);
        #KEYPOINT (osk$performance, osk$m * (preg.offset DIV 100000(16)), ptk$allocate_p_upper_offset);
        #KEYPOINT (osk$performance, osk$m * alength, ptk$allocate_length);
      IFEND;
    ELSE
      up := NIL;
      #KEYPOINT (osk$debug, 0, osk$allocate);
    IFEND;


{ Clear the serialization lock on the heap.

    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$clear_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$clear_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;

    IF (i = 0) AND (hp^.algorithm = os_heap_algorithm) THEN
      psa := #PREVIOUS_SAVE_AREA ();
      preg := psa^.minimum_save_area.p_register.pva;
      STRINGREP (system_error_message, i, ' HEAPMGR - heap ',
        hp, ' is full - P caller = ',  preg.ring:#(16),
        preg.seg:#(16), preg.offset:#(16));
      osp$system_error (system_error_message (1, i), NIL);
    IFEND;

    IF hp^.algorithm > 0 THEN
      i#restore_traps (old_te);
    IFEND;
  PROCEND cyp$allocate;

?? TITLE := '  [XDCL, #GATE] cyp$free', EJECT ??

  PROCEDURE [XDCL, #GATE] cyp$free
    (    offset: ost$halfword;
         hp: ^ost$hp_heap);

    VAR
      alength: 0 .. 0ffffff(16),
      enable_heap_trace: boolean,
      i: integer,
      inext: integer,
      iprev: integer,
      ir: integer,
      j: integer,
      off: 0 .. 0ffffff(16),
      ok: boolean,
      old_te: 0 .. 3,
      preg: ost$pva,
      psa: ^ost$stack_frame_save_area,
      seg: 0 .. 0ffffff(16),
      system_error_message: string (128),
      taskid: ost$global_task_id,
      up: ^ost$hp_heap_space_desc;


{ Check heap id.  Abort if id is incorrect.  An incorrect id is caused by the user corrupting the heap
{ pointer, passing an incorrect pointer, or failing to reset the heap.

    IF hp^.id <> heap_id THEN
      osp$system_error ('HEAPMGR - bad heap pointer', NIL);
      RETURN;
    IFEND;


{ Generate the index of the block being freed.

    i := (offset - (#SIZE (hp^) - #SIZE (hp^.sd))) DIV 16;


{ Abort if the block does not look like an allocated block.

    enable_heap_trace := (hp^.algorithm = os_heap_algorithm) AND syv$enable_heap_trace;
    IF ((NOT enable_heap_trace) AND (hp^.sd [i].allocation_id <> allocation_id)) OR
          (enable_heap_trace AND (hp^.sd [i].trace_allocation_id <> trace_allocation_id)) THEN
      psa := #PREVIOUS_SAVE_AREA ();
      preg := psa^.minimum_save_area.p_register.pva;
      STRINGREP (system_error_message, j, ' HEAPMGR - heap ',
        hp, ' illegal free - P caller = ',   preg.ring:#(16),
        preg.seg:#(16), preg.offset:#(16), ' block index = ', i, ' Heap offset = ', offset:#(16));
      osp$system_error (system_error_message (1, j), NIL);
    IFEND;


{ Set the serialization lock on the heap.

    IF hp^.algorithm > 0 THEN
      i#disable_traps (old_te);
    IFEND;
    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$set_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$set_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;
    IF syv$verify_heap_linkage THEN
      check_heap (hp, ok);
      IF NOT ok THEN
        osp$system_error ('HEAPMGR - heap linkage bad', NIL);
      IFEND;
    IFEND;


{ Verify that the block being freed is a valid block.

    iprev := hp^.sd [i].link;
    inext := i + hp^.sd [i].length;
    IF (iprev <> 0) AND ((hp^.sd [iprev].length + iprev) <> i) OR
          (inext <> hp^.sd [0].bkw) AND (hp^.sd [inext].link <> i) THEN
      IF hp^.lock_option THEN
        IF #RING (hp) = 1 THEN
          osp$clear_mainframe_sig_lock (hp^.lock);
        ELSE
          osp$clear_job_signature_lock (hp^.lock);
        IFEND;
      IFEND;
      IF hp^.algorithm > 0 THEN
        i#restore_traps (old_te);
      IFEND;
      psa := #PREVIOUS_SAVE_AREA ();
      preg := psa^.minimum_save_area.p_register.pva;
      STRINGREP (system_error_message, i, ' HEAPMGR - heap ',
        hp, ' bad heap control info - P caller = ',
        preg.ring:#(16), preg.seg:#(16), preg.offset:#(16));
      osp$system_error (system_error_message (1, i), NIL);
    IFEND;


{ If the freed block and the free block immediately preceeding it are adjacent, combine them into one block.

    up := ^hp^.sd [i + 1];
    #KEYPOINT (osk$debug, #SEGMENT (up) * osk$m, osk$free);
    IF syv$perf_keypoints_enabled.heap_keypoints THEN
      psa := #PREVIOUS_SAVE_AREA ();
      preg := psa^.minimum_save_area.p_register.pva;
      pmp$get_executing_task_gtid (taskid);
      ir := taskid.index * 256 + taskid.seqno;
      alength := hp^.sd [i].length * #SIZE (ost$hp_heap_space_desc);
      seg := #SEGMENT (up);
      off := #OFFSET (up);
      #KEYPOINT (osk$performance, osk$m * ir, ptk$free_gtid);
      #KEYPOINT (osk$performance, osk$m * seg, ptk$free_segment);
      #KEYPOINT (osk$performance, osk$m * (off MOD 100000(16)), ptk$free_lower_offset);
      #KEYPOINT (osk$performance, osk$m * (off DIV 100000(16)), ptk$free_upper_offset);
      #KEYPOINT (osk$performance, osk$m * preg.seg, ptk$free_p_segment);
      #KEYPOINT (osk$performance, osk$m * (preg.offset MOD 100000(16)), ptk$free_p_lower_offset);
      #KEYPOINT (osk$performance, osk$m * (preg.offset DIV 100000(16)), ptk$free_p_upper_offset);
      #KEYPOINT (osk$performance, osk$m * alength, ptk$free_length);
    IFEND;

    IF (iprev <> 0) AND
          (((NOT enable_heap_trace) AND (hp^.sd [iprev].allocation_id <> allocation_id)) OR
          (enable_heap_trace AND (hp^.sd [iprev].trace_allocation_id <> trace_allocation_id))) AND
          ((hp^.sd [iprev].fwd <= UPPERBOUND(hp^.sd)) AND (hp^.sd [iprev].bkw <= UPPERBOUND(hp^.sd))) THEN
      hp^.sd [iprev].length := hp^.sd [iprev].length + hp^.sd [i].length;
      remove_block_from_free_chain (iprev, hp);
      hp^.sd [hp^.sd [i].length + i].link := iprev;
      hp^.sd [i].allocation_id := 0;
      i := iprev;
    IFEND;


{ If the block following the freed block is also free, combine them into a single larger block.  Link the
{ freed block (possibly combined with adjacent free blocks) to the head of the free block chain.
{ EXCEPTION: If the block following the freed block is the last block in the heap, combine the current block
{ with it but leave the resultant block at the end of the chain.

    IF hp^.sd [0].bkw = inext THEN
      hp^.sd [i].fwd := 0;
      hp^.sd [i].length := hp^.sd [i].length + hp^.sd [inext].length;
      hp^.sd [i].bkw := hp^.sd [inext].bkw;
      hp^.sd [hp^.sd [i].bkw].fwd := i;
      hp^.sd [0].bkw := i;
    ELSE
      IF (((NOT enable_heap_trace) AND (hp^.sd [inext].allocation_id <> allocation_id)) OR
            (enable_heap_trace AND (hp^.sd [inext].trace_allocation_id <> trace_allocation_id))) AND
            ((hp^.sd [inext].fwd <= UPPERBOUND(hp^.sd)) AND (hp^.sd [inext].bkw <= UPPERBOUND(hp^.sd))) THEN
        hp^.sd [i].length := hp^.sd [i].length + hp^.sd [inext].length;
        remove_block_from_free_chain (inext, hp);
        hp^.sd [hp^.sd [inext].length + inext].link := i;
      IFEND;
      hp^.sd [i].fwd := hp^.sd [0].fwd;
      hp^.sd [hp^.sd [0].fwd].bkw := i;
      hp^.sd [0].fwd := i;
      hp^.sd [i].bkw := 0;
    IFEND;


{ Clear the serialization lock on the heap.

    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$clear_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$clear_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;

    IF hp^.algorithm > 0 THEN
      i#restore_traps (old_te);
    IFEND;
  PROCEND cyp$free;

?? TITLE := '  [XDCL, #GATE] osp$extend_heap', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$extend_heap
    (    size: integer;
         heap_p: ^ost$heap;
     VAR new_page_boundary: ^cell);

    VAR
      hp: ^ost$hp_heap,
      page_boundary: ^cell,
      index: integer,
      status: ost$status,
      old_te: 0 .. 3,
      p: ^cell;

    hp := #LOC (heap_p^);

    IF hp^.algorithm > 0 THEN
      i#disable_traps (old_te);
    IFEND;
    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$set_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$set_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;

    index := hp^.sd [0].bkw;
    p := ^hp^.sd [index + 1];
    page_boundary := #ADDRESS (1, #segment (p), ((#offset (p) + osv$page_size -1) DIV
        osv$page_size) * osv$page_size);
    IF mmv$tables_initialized AND (size < 65536) THEN
      IF new_page_boundary <> page_boundary THEN
        mmp$free_pages (page_boundary, size + osv$page_size, osc$nowait, status);
        mmp$assign_contiguous_memory (page_boundary, size, status);
        new_page_boundary := page_boundary;
      IFEND;
    ELSE
      pmp$zero_out_table (page_boundary, size);
    IFEND;

    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$clear_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$clear_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;

      IF hp^.algorithm > 0 THEN
        i#restore_traps (old_te);
      IFEND;
  PROCEND osp$extend_heap;

?? TITLE := '  [XDCL, #GATE] osp$free_heap_pages', EJECT ??
*copy osh$free_heap_pages

  PROCEDURE [XDCL, #GATE] osp$free_heap_pages
    (    xhp: ^ost$heap);

    VAR
      desc_in_page: integer,
      hp: ^ost$hp_heap,
      index: integer,
      old_te: 0 .. 3,
      rma: integer,
      status: ost$status;

    status.normal := TRUE;
    hp := #LOC (xhp^);


{ Set the serializaton lock on the heap.

    IF hp^.algorithm > 0 THEN
      i#disable_traps (old_te);
    IFEND;
    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$set_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$set_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;


    index := hp^.sd [0].fwd;

  /scan_free_blocks/
    WHILE index <> 0 DO
      IF hp^.sd [index].length > hp^.desc_per_page THEN
        desc_in_page := hp^.desc_per_page - ((index + hp^.base) MOD hp^.desc_per_page);
        IF (hp^.sd [index].length - desc_in_page) > hp^.desc_per_page THEN
          mmp$free_pages (#LOC (hp^.sd [index]), hp^.sd [index].length * 16, osc$wait, status);
        IFEND;
      IFEND;
      index := hp^.sd [index].fwd;
    WHILEND /scan_free_blocks/;


{ Clear the serialization lock on the heap.

    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$clear_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$clear_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;

    IF hp^.algorithm > 0 THEN
      i#restore_traps (old_te);
    IFEND;
  PROCEND osp$free_heap_pages;

?? TITLE := '  [XDCL, #GATE] osp$prevalidate_free', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$prevalidate_free
    (    offset: ost$halfword;
         xhp: ^ost$heap;
     VAR result: ost$prevalidate_free_result);

    VAR
      enable_heap_trace: boolean,
      heap_locked: boolean,
      hp: ^ost$hp_heap,
      i: integer,
      inext: integer,
      iprev: integer,
      ok: boolean,
      old_te: 0 .. 3,
      traps_disabled: boolean;

    hp := #LOC (xhp^);
    heap_locked := FALSE;
    traps_disabled := FALSE;

    result := osc$heap_free_valid;

  /prevalidate_free/
    BEGIN

{ Return OSC$HEAP_POINTER_INVALID if the heap has an invalid heap id.

      IF hp^.id <> heap_id THEN
        result := osc$heap_pointer_invalid;
        EXIT /prevalidate_free/;
      IFEND;

{ Generate the index of the block being freed.

      i := (offset - (#SIZE (hp^) - #SIZE (hp^.sd))) DIV 16;

{ Return OSC$HEAP_ALLOCATION_ID_INVALID if the block has an invalid allocation id.

      enable_heap_trace := (hp^.algorithm = os_heap_algorithm) AND syv$enable_heap_trace;
      IF ((NOT enable_heap_trace) AND (hp^.sd [i].allocation_id <> allocation_id)) OR
            (enable_heap_trace AND (hp^.sd [i].trace_allocation_id <> trace_allocation_id)) THEN
        result := osc$heap_allocation_id_invalid;
        EXIT /prevalidate_free/;
      IFEND;

{ Set the serialization lock on the heap.

      IF hp^.algorithm > 0 THEN
        i#disable_traps (old_te);
        traps_disabled := TRUE;
      IFEND;
      IF hp^.lock_option THEN
        IF #RING (hp) = 1 THEN
          osp$set_mainframe_sig_lock (hp^.lock);
        ELSE
          osp$set_job_signature_lock (hp^.lock);
        IFEND;
        heap_locked := TRUE;
      IFEND;

{ Return OSC$HEAP_VERIFICATION_FAILURE if verification of heap linkage fails.

      IF syv$verify_heap_linkage THEN
        check_heap (hp, ok);
        IF NOT ok THEN
          result := osc$heap_verification_failure;
          EXIT /prevalidate_free/;
        IFEND;
      IFEND;

{ Return OSC$HEAP_LINKAGE_INVALID if the linkage of the block is bad.

      iprev := hp^.sd [i].link;
      inext := i + hp^.sd [i].length;
      IF (iprev <> 0) AND ((hp^.sd [iprev].length + iprev) <> i) OR
            (inext <> hp^.sd [0].bkw) AND (hp^.sd [inext].link <> i) THEN
        result := osc$heap_linkage_invalid;
        EXIT /prevalidate_free/;
      IFEND;

    END /prevalidate_free/;

{ Clear the serialization lock on the heap.

    IF heap_locked THEN
      IF #RING (hp) = 1 THEN
        osp$clear_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$clear_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;

    IF traps_disabled THEN
      IF hp^.algorithm > 0 THEN
        i#restore_traps (old_te);
      IFEND;
    IFEND;

  PROCEND osp$prevalidate_free;

?? TITLE := '  [XDCL, #GATE] osp$reset_heap', EJECT ??
*copy osh$reset_heap

  PROCEDURE [XDCL, #GATE] osp$reset_heap
    (    xhp: ^ost$heap;
         heap_length: integer;
         lock_option: boolean;
         algorithm: 0 .. 255);

    VAR
      hp: ^ost$hp_heap,
      i: integer,
      p: ptr_variant,
      status: ost$status;

    hp := #LOC (xhp^);


{ Verify heap starts on a 0 MOD 32 byte boundary.

    p.ptr := hp;
    IF (p.bytenum MOD 32) <> 0 THEN
      osp$system_error ('HEAPMGR - heap start not 0 mod 32', NIL);
    IFEND;
    IF (algorithm < min_algorithm) OR (algorithm > max_algorithm) THEN
      osp$system_error ('HEAPMGR - unsupported algorithm', NIL);
    IFEND;


{ Initialize the control information at the beginning of the heap.

    #KEYPOINT (osk$debug, osk$m * (p.ringseg MOD 1000(16)), osk$reset_heap);
    hp^.id := heap_id;
    osp$initialize_sig_lock (hp^.lock);
    hp^.algorithm := algorithm;
    hp^.lock_option := lock_option;
    hp^.sd [0].fwd := 1;
    hp^.sd [0].bkw := 1;
    hp^.sd [0].length := 0;
    hp^.sd [0].link := 0;
    hp^.sd [1].fwd := 0;
    hp^.sd [1].bkw := 0;
    hp^.sd [1].link := 0;
    i := heap_length - (#SIZE (hp^) - #SIZE (hp^.sd) + #SIZE (ost$hp_heap_space_desc));
    hp^.sd [1].length := (i - i MOD 32) DIV 16 - 1; {leave 1 entry at end}
    hp^.desc_per_page := osv$page_size DIV 16;
    hp^.base := (p.bytenum MOD osv$page_size) DIV 16 + (#SIZE (hp^) - #SIZE (hp^.sd) +
          #SIZE (ost$hp_heap_space_desc)) DIV 16;
  PROCEND osp$reset_heap;

?? TITLE := '  [XDCL, #GATE] osp$verify_heap', EJECT ??
*copy osh$verify_heap

  PROCEDURE [XDCL, #GATE] osp$verify_heap
     (    xhp: ^ost$heap;
      VAR ok: boolean);

    VAR
      hp: ^ost$hp_heap,
      old_te: 0 .. 3;


{ Check heap id.  Abort if id is incorrect.  An incorrect id is caused by the user corrupting the heap
{ pointer, passing an incorrect pointer, or failing to reset the heap.

    hp := #LOC (xhp^);
    IF hp^.id <> heap_id THEN
      ok := FALSE;
      RETURN;
    IFEND;


{ Set the serialization lock on the heap.

    IF hp^.algorithm > 0 THEN
      i#disable_traps (old_te);
    IFEND;
    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$set_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$set_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;


    check_heap (hp, ok);


{ Clear the serialization lock on the heap.

    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$clear_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$clear_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;

    IF hp^.algorithm > 0 THEN
      i#restore_traps (old_te);
    IFEND;
  PROCEND osp$verify_heap;

?? SKIP := 2 ??
MODEND osm$heap_manager;
*DECK DECK=OSM$IDLE_RESUME_SYSTEM EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operating System : System idle/resume processing' ??
MODULE osm$idle_resume_system;

{ PURPOSE:
{   This module contains various procedures used to idle, resume and terminate the system.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cml$system_continuation
*copyc jme$queued_file_conditions
*copyc mmt$rb_idle_system
*copyc ofe$error_codes
*copyc ose$system_task_exceptions
*copyc ost$free_running_clock
*copyc oss$job_paged_literal
*copyc ost$system_flag
*copyc ost$terminate_continue_stats
*copyc syc$monitor_request_codes
*copyc syt$180_idle_code
*copyc tmc$signal_identifiers
*copyc tmt$rb_update_job_task_enviro
?? POP ??
*copyc avp$system_operator
*copyc clp$include_line
*copyc clp$log_comment
*copyc clp$put_job_command_response
*copyc dfp$flush_served_family_table
*copyc dfv$job_recovery_enabled
*copyc dsp$attach_label_for_upgrade
*copyc dsp$attach_rdf_for_idle
*copyc dsp$detach_rdf_after_resume
*copyc dmp$idle_system
*copyc dmp$resume_system
*copyc dpp$put_critical_message
*copyc dsp$idle_system
*copyc dsp$log_system_message
*copyc dsp$resume_system
*copyc jmp$get_job_ijl_ordinal
*copyc i#call_monitor
*copyc jmp$system_job
*copyc dsp$log_system_message
*copyc mtv$idle_step_message
*copyc osp$check_sys_task_completions
*copyc osp$copy_local_status_to_status
*copyc osp$establish_condition_handler
*copyc osp$executing_in_job_monitor
*copyc osp$fatal_system_error
*copyc osp$generate_message
*copyc osp$get_cause_of_idle
*copyc osp$get_running_system_tasks
*copyc osp$idle_requested
*copyc osp$jt_begin_system_activity
*copyc osp$jt_end_system_activity
*copyc osp$set_status_abnormal
*copyc osp$terminate_system_r1
*copyc osp$terminate_system_task
*copyc osp$update_idle_state_r1
*copyc osp$verify_system_privilege
*copyc pmp$cause_task_condition
*copyc pmp$continue_to_cause
*copyc pmp$get_date_time_at_timestamp
*copyc pmp$wait
*copyc tmp$ready_system_task1
?? OLDTITLE, NEWTITLE := '[XDCL, #GATE] osp$update_idle_state', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$update_idle_state
    (    idle_state: ost$idle_state;
     VAR status: ost$status);

    status.normal := TRUE;
    IF NOT (jmp$system_job () AND osp$executing_in_job_monitor ()) THEN
      osp$set_status_abnormal ('  ', ose$not_system_job_monitor, 'osp$update_idle_state', status);
      RETURN;
    IFEND;

    osp$update_idle_state_r1 (idle_state);

  PROCEND osp$update_idle_state;
?? OLDTITLE, NEWTITLE := '[XDCL, #GATE] osp$terminate_system', EJECT ??

{  PURPOSE:
{     This procedure initiates the termination of the system.  Once the
{     process has been initiated, the procedure waits for a job recovery
{     condition to occur.  This is necessary to ensure that the
{     executing job is recoverable.
{

  PROCEDURE [XDCL, #GATE] osp$terminate_system
    (VAR status: ost$status);

    CONST
      one_second = 1000;

    VAR
      job_recovery_complete: boolean,
      prolog_status: ost$status;

?? NEWTITLE := '  abort_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF (condition.selector = pmc$user_defined_condition) AND (condition.user_condition_name =
            'OSC$JOB_RECOVERY') THEN
        job_recovery_complete := TRUE;
        #SPOIL (job_recovery_complete);
      IFEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    IF NOT avp$system_operator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'SYSTEM_OPERATION', status);
      RETURN;
    IFEND;

    dpp$put_critical_message ('Initiating system termination sequence', status);
    clp$include_line ('$system.osf$builtin_library.rap$run_initiation_commands icn=system_termination_prolog',
          TRUE, osc$null_name, prolog_status);
    IF NOT prolog_status.normal THEN
      osp$generate_message (prolog_status, status);
    IFEND;

    status.normal := TRUE;
    job_recovery_complete := FALSE;
    #SPOIL (job_recovery_complete);

{ Establish handler for job_recovery condition.

    osp$establish_condition_handler (^condition_handler, FALSE);

    osp$terminate_system_r1;
    tmp$ready_system_task (tmc$stid_job_monitor, {ignore} status);
    status.normal := TRUE;
    IF jmp$system_job () THEN
      RETURN;
    ELSE
{ Wait for job_recovery condition to occur.

      WHILE TRUE DO
        pmp$wait (20 * one_second, 20 * one_second);
        #SPOIL (job_recovery_complete);
        IF job_recovery_complete THEN
          RETURN;
        IFEND;
      WHILEND;
    IFEND;

  PROCEND osp$terminate_system;
?? OLDTITLE, NEWTITLE := '[XDCL, #GATE] osp$idle_resume_system_job', EJECT ??

{  PURPOSE:
{     This procedure is used to initiate the last phase of system idle-down,
{     the idle of the system job.  It is called within the job monitor task
{     of the system job after all other system activity has ceased.
{

  PROCEDURE [XDCL, #GATE] osp$idle_resume_system_job
    (VAR status: ost$status);

    CONST
      ten_milliseconds = 10,
      one_second = 1000,
      thirty_seconds = 30000000;

{ Text is defined below for each possible code.  However, most of the errors will be detected elsewhere
{ and thus only the codes marked "valid" should be seen by the operator.

?? FMT (FORMAT := OFF) ??
    VAR
      table: [STATIC, READ, oss$job_paged_literal] array [syt$180_idle_code] of string (40) := [
{ syc$ic_null                  } 'ERR=VEOS3599- Invalid IDLE CODE=      ',
{ syc$ic_system_terminated     } 'VEOS3500- Termination is complete.',
{ syc$ic_fatal_hardware_error  } 'ERR=VEOS3599- Invalid IDLE CODE=      ',
{ syc$ic_fatal_software_error  } 'ERR=VEOS3599- Invalid IDLE CODE=      ',
{ syc$ic_long_power            } ' ', { Message comes from monitor variable MTV$IDLE_STEP_MESSAGE }
{ syc$ic_hardware_idle         } ' ', { Message comes from monitor variable MTV$IDLE_STEP_MESSAGE }
{ syc$ic_idle_command          } 'VEOS3503- SYSTEM IDLED',
{ syc$ic_step_command          } 'ERR=VEOS3599- Invalid IDLE CODE=      ',
{ syc$ic_short_power           } 'ERR=VEOS3599- Invalid IDLE CODE=      ',
{ syc$ic_disk_error            } 'ERR=VEOS3599- Invalid IDLE CODE=      ',
{ syc$ic_software_breakpoint   } 'ERR=VEOS3599- Invalid IDLE CODE=      '];
?? FMT (FORMAT := ON) ??

    VAR
      change_sys_tasks_request_block: tmt$rb_update_job_task_enviro,
      endtime: integer,
      i: integer,
      idle_code: syt$180_idle_code,
      line: string (32),
      logs: array [1 .. 1] of ost$name,
      number_of_running_tasks: integer,
      request_block: mmt$rb_idle_system,
      running_tasks: ^array [1 .. * ] of ost$name,
      tasks_terminated: boolean;

    logs [1] := 'SYSTEM                         ';

    IF NOT (jmp$system_job () AND osp$executing_in_job_monitor ()) THEN
      osp$set_status_abnormal ('  ', ose$not_system_job_monitor, 'osp$idle_resume_system_job', status);
      RETURN;
    IFEND;

    IF dfv$job_recovery_enabled THEN
      dfp$flush_served_family_table ({ignore} status);
      status.normal := TRUE;
    IFEND;

{ Wait until all tasks which must terminate do so, or until thirty (30) seconds has elapsed.

    endtime := #FREE_RUNNING_CLOCK (0) + thirty_seconds;
    tasks_terminated := FALSE;
    PUSH running_tasks: [1 .. 1];

  /wait_for_tasks_to_complete/
    REPEAT
      osp$check_sys_task_completions;
      osp$get_running_system_tasks (running_tasks^, number_of_running_tasks);
      IF number_of_running_tasks > UPPERBOUND (running_tasks^) THEN
        PUSH running_tasks: [1 .. number_of_running_tasks];
        CYCLE /wait_for_tasks_to_complete/;
      ELSEIF number_of_running_tasks = 0 THEN
        EXIT /wait_for_tasks_to_complete/;
      ELSEIF NOT tasks_terminated THEN
        tasks_terminated := TRUE;
        FOR i := 1 TO number_of_running_tasks DO
          osp$terminate_system_task (running_tasks^ [i]);
        FOREND;
      IFEND;
      pmp$wait (one_second, one_second);
    UNTIL (#FREE_RUNNING_CLOCK (0) > endtime) OR (number_of_running_tasks = 0);

{ If there are still tasks running, inform the system log and the operator, and then wait for the
{ tasks to complete.

    IF number_of_running_tasks <> 0 THEN
      clp$log_comment ('The system was delayed during idle-down because', logs, status);
      clp$log_comment ('a system task would not terminate:', logs, status);
      clp$put_job_command_response (' ** System idle delayed due to a hung task: **', status);

      FOR i := 1 TO number_of_running_tasks DO
        clp$log_comment (running_tasks^ [i], logs, status);
        line := ' ';
        line (2, 31) := running_tasks^ [i];
        clp$put_job_command_response (line, status);
      FOREND;

      REPEAT
        osp$check_sys_task_completions;
        osp$get_running_system_tasks (running_tasks^, number_of_running_tasks);
        pmp$wait (2 * one_second, 2 * one_second);
      UNTIL (#FREE_RUNNING_CLOCK (0) > endtime) OR (number_of_running_tasks = 0);
    IFEND;

    osp$get_cause_of_idle (idle_code);
    CASE idle_code OF
    = syc$ic_system_terminated =
      clp$log_comment ('System idling due to TERMINATE_SYSTEM command', logs, status);
    = syc$ic_idle_command =
      clp$log_comment ('System idling due to IDLE_SYSTEM command', logs, status);
    = syc$ic_hardware_idle, syc$ic_long_power =
      clp$log_comment ('System idling due to hardware idle or long power', logs, status);
    ELSE
      clp$log_comment ('System idling due to fatal software error', logs, status);
    CASEND;

{ Call monitor to idle the other system tasks: Memory_link, etc., but NOT Device_Management.

    osp$jt_begin_system_activity;
    REPEAT
      change_sys_tasks_request_block.reqcode := syc$rc_update_job_task_enviro;
      change_sys_tasks_request_block.status.normal := TRUE;
      change_sys_tasks_request_block.subcode := tmc$ujte_idle_other_sys_tasks;
      i#call_monitor (#LOC (change_sys_tasks_request_block), #SIZE (change_sys_tasks_request_block));
      IF NOT change_sys_tasks_request_block.status.normal THEN
        pmp$wait (ten_milliseconds, ten_milliseconds);
      IFEND;
    UNTIL change_sys_tasks_request_block.status.normal;

{ Log the time and reason for the idle (or terminate).

    IF idle_code = syc$ic_system_terminated THEN
      osp$log_idle_resume (osc$terminate_statistic, idle_code, status);
    ELSE
      osp$log_idle_resume (osc$idle_statistic, idle_code, status);
    IFEND;

    dsp$attach_label_for_upgrade;
    dsp$attach_rdf_for_idle;
    dmp$idle_system;
    dsp$idle_system (idle_code = syc$ic_system_terminated);

{ At this point the system is idle, but not stepped. Update the status of the system.

    osp$update_idle_state (osc$system_idle, status);

{ Call monitor to process the STEP portion of IDLE_SYSTEM.

    request_block.reqcode := syc$rc_idle_system;
    request_block.idle_code := idle_code;

    CASE idle_code OF
    = syc$ic_system_terminated, syc$ic_idle_command =
      request_block.error_message := table [idle_code];
    = syc$ic_hardware_idle, syc$ic_long_power =
      request_block.error_message := mtv$idle_step_message (1, 71);
    ELSE
      request_block.error_message := table [idle_code];
      STRINGREP (request_block.error_message (33, 3), i, idle_code: 3);
      request_block.idle_code := syc$ic_fatal_software_error;
      i#call_monitor (#LOC (request_block), #SIZE (request_block));
    CASEND;

{ If system conditions are such that we don't need to idle (e.g. a long warning which did not
{ complete before a short warning occured, both of which cleared) we can resume immediately.

    IF osp$idle_requested () THEN
      i#call_monitor (#LOC (request_block), #SIZE (request_block));
    IFEND;

{ At this point the system is ready to resume. Update the status of the system.

    osp$update_idle_state (osc$resume_system_in_progress, status);

    dsp$resume_system;
    dmp$resume_system;
    dsp$detach_rdf_after_resume;

{ Call monitor to restart the system tasks which were previously idled in this procedure.

    change_sys_tasks_request_block.reqcode := syc$rc_update_job_task_enviro;
    change_sys_tasks_request_block.status.normal := TRUE;
    change_sys_tasks_request_block.subcode := tmc$ujte_restart_other_systasks;
    i#call_monitor (#LOC (change_sys_tasks_request_block), #SIZE (change_sys_tasks_request_block));
    osp$jt_end_system_activity;

  PROCEND osp$idle_resume_system_job;
?? OLDTITLE, NEWTITLE := '[XDCL, #GATE] osp$log_idle_resume', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$log_idle_resume
    (    statistic_type: ost$terminate_continue_stats;
         idle_code: syt$180_idle_code;
     VAR status: ost$status);

    VAR
      data_to_log_p: ^SEQ ( * ),
      terminate_continue_message: ost$terminate_continue_record;

    osp$verify_system_privilege;

    pmp$get_date_time_at_timestamp (#FREE_RUNNING_CLOCK (0), pmc$use_system_local_time,
          terminate_continue_message.date_time, status);

    terminate_continue_message.log_reason := idle_code;

    terminate_continue_message.log_statistic := statistic_type;

    CASE statistic_type OF
    = osc$idle_statistic =
      terminate_continue_message.log_message.value := 'SYSTEM IDLE';
      terminate_continue_message.log_message.size := 11;
    = osc$resume_statistic =
      terminate_continue_message.log_message.value := 'SYSTEM RESUME';
      terminate_continue_message.log_message.size := 13;
    = osc$terminate_statistic =
      terminate_continue_message.log_message.value := 'SYSTEM TERMINATE';
      terminate_continue_message.log_message.size := 16;
    ELSE
      ;
    CASEND;

    data_to_log_p := #SEQ (terminate_continue_message);
    dsp$log_system_message (cml$system_continuation, data_to_log_p, status);

  PROCEND osp$log_idle_resume;
?? OLDTITLE, NEWTITLE := '[XDCL, #GATE] osp$unstep_resume_flag_handler', EJECT ??
*copyc osh$unstep_resume_flag_handler

  PROCEDURE [XDCL, #GATE] osp$unstep_resume_flag_handler
    (    flag_id: ost$system_flag);

    VAR
      status: ost$status,
      log_name_selections: array [1 .. 1] of ost$name;

    osp$verify_system_privilege;

    log_name_selections [1] := 'JOB                            ';
    clp$log_comment (' *** SYSTEM UNSTEP/RESUME CONDITION OCCURRED. ***', log_name_selections, status);
    pmp$cause_task_condition ('SYSTEM_UNSTEP_RESUME           ', NIL, FALSE, FALSE, FALSE, TRUE, status);

  PROCEND osp$unstep_resume_flag_handler;
?? OLDTITLE ??
MODEND osm$idle_resume_system;
*DECK DECK=OSM$INITIALIZE_TABLES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operating System : initialize tables' ??
MODULE osm$initialize_tables;

{ MODULE: osm$initialize_tables
{
{ PURPOSE: This module contains the routines to initialize
{          dispatcher tables at deadstart time and the
{          routine to expand the PTL.
{
{ NOTES:   This module contains the following procedures:
{            osp$initialize_ptl - allocates and initializes PTL.
{            osp$expand_ptl - expands PTL by tmc$ptl_increment entries.
{            osp$reset_ptl - re-initializes PTL and DCT
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmt$dispatching_priority
*copyc jmt$initiated_job_list_entry
*copyc ost$heap
*copyc tmt$dispatching_control_sets
?? POP ??
*copyc i#call_monitor
*copyc jmv$ijle_size
*copyc jmv$maximum_service_classes
*copyc jmv$service_classes
*copyc osp$clear_mainframe_sig_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osv$mainframe_pageable_heap
*copyc pmp$zero_out_table
*copyc pmv$quantum
*copyc tme$monitor_mode_exceptions
*copyc tmt$primary_task_list
*copyc tmt$rb_update_job_task_enviro
*copyc tmv$dispatch_priority_integer
*copyc tmv$dispatching_control_sets
*copyc tmv$ptl_p
*copyc tmv$dct

*copyc osv$mainframe_wired_heap

?? TITLE := 'osp$initialize_ptl', EJECT ??

  PROCEDURE [XDCL] osp$initialize_ptl;

{ This routine is called at deadstart time to initialize PTL.
{
{ INPUT: none.
{
{ OUTPUT: none.
{
{ NOTES: This routine does the following:
{          . initializes the ijl entry size (This must be done when the ptl is allocated--
{            before any task switch can occur--because the ijl entry size is used by task switch.)
{          . initializes the dispatching control sets and initializes the array containing the
{            allocated dispatching priority integer for each dispatching priority.  The dispatching
{            priority integer is used to determine which dispatching priority is highest when the
{            CPU has been allocated among the various dispatching priorties.  Dispatching priorities
{            which have a "minimum to satisfy" have a higher integer priority than those that do not.
{            NOTE:  System dispatching priorities are always considered to have "minimums to satisfy",
{            so they are always the highest priority.
{          . allocate the PTL.
{          . initialize all the PTL entries into a free queue.
{

    VAR
      dp: jmt$dispatching_priority,
      local_set: tmt$dispatching_control_sets,
      i: integer,
      ijl_size_ptr: ^array [1 .. * ] of jmt$initiated_job_list_entry,
      max_ptlo: ost$task_index;

    PUSH ijl_size_ptr: [1 .. 2];
    jmv$ijle_size := #OFFSET (^ijl_size_ptr^ [2]) - #OFFSET (ijl_size_ptr);

{ Initialize the dispatching controls and determine the dispatching priority integers.

    tmv$dispatching_control_sets.minimums_to_satisfy := $jmt$dispatching_priority_set [1, 2, 3, 4, 5, 6];
    tmv$dispatching_control_sets.maximums_exceeded := $jmt$dispatching_priority_set [];
    tmv$dispatching_control_sets.enforce_maximums := $jmt$dispatching_priority_set [];

    local_set := tmv$dispatching_control_sets;

    FOR dp := jmc$min_dispatching_priority TO jmc$max_dispatching_priority DO
      local_set.ready_tasks := $jmt$dispatching_priority_set [jmc$dp_conversion - dp];
      local_set.minimums_to_satisfy := local_set.minimums_to_satisfy * local_set.ready_tasks;
      local_set.ready_tasks := local_set.ready_tasks XOR local_set.minimums_to_satisfy;
      #UNCHECKED_CONVERSION (local_set, tmv$dispatch_priority_integer [dp]);
    FOREND;

{ Allocate the ptl and service_class_table.  Some service class table fields are used by task
{ switch and must be initialized before any task switches occur.

    ALLOCATE tmv$ptl_p: [0 .. tmc$initial_ptl_size] IN osv$mainframe_wired_heap^;
    pmp$zero_out_table (#LOC (tmv$ptl_p^), #SIZE (tmv$ptl_p^));

    ALLOCATE jmv$service_classes [jmc$system_service_class] IN osv$mainframe_wired_heap^;

    pmp$zero_out_table (jmv$service_classes [jmc$system_service_class],
          #SIZE (jmv$service_classes [jmc$system_service_class]^));

    jmv$service_classes [jmc$system_service_class]^.attributes.
          dispatching_control [jmc$min_dispatching_control].dispatching_timeslice.minor := pmv$quantum;
    jmv$service_classes [jmc$system_service_class]^.attributes.
          dispatching_control [jmc$min_dispatching_control].dispatching_timeslice.major := pmv$quantum;

{ Link all the PTL entries into a free queue.

    max_ptlo := UPPERBOUND (tmv$ptl_p^);
    FOR i := 1 TO max_ptlo DO
      tmv$ptl_p^ [i].ptl_thread := i + 1;
    FOREND;
    tmv$ptl_p^ [max_ptlo].ptl_thread := 0;

{ Initialize the free queue control block.

    tmv$dct [jmc$null_dispatching_priority].queue_head := 1;
    tmv$dct [jmc$null_dispatching_priority].queue_tail := max_ptlo;
  PROCEND osp$initialize_ptl;
?? TITLE := 'osp$expand_ptl', EJECT ??

*copy osh$expand_ptl

  PROCEDURE [XDCL] osp$expand_ptl
    (    unconditionally_expand: boolean;
     VAR status: ost$status);

{ NOTES: This procedure is called by deadstart job recovery, job initialization,
{        and task initialization.  It does the following:
{          . allocates a new expanded PTL.
{          . calls monitor to copy the old PTL into the new PTL.
{          . frees the old PTL.
{

    CONST
      minimum_free = 10;

    VAR
      count: integer,
      expand_ptl_lock: [STATIC, oss$mainframe_pageable] ost$signature_lock,
      increment: integer,
      new_ptl_p: ^tmt$primary_task_list,
      next_index: ost$task_index,
      old_max_ptlo: ost$task_index,
      old_ptl_p: ^tmt$primary_task_list,
      rb: tmt$rb_update_job_task_enviro;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (expand_ptl_lock);
    old_ptl_p := tmv$ptl_p;
    old_max_ptlo := UPPERBOUND (tmv$ptl_p^);
    increment := tmc$ptl_increment;

    IF old_max_ptlo = tmc$maximum_ptl THEN
      osp$set_status_abnormal ('TM', tme$ptl_full, '', status);
      osp$clear_mainframe_sig_lock (expand_ptl_lock);
      RETURN;
    ELSEIF old_max_ptlo + tmc$ptl_increment > tmc$maximum_ptl THEN
      increment := tmc$maximum_ptl - old_max_ptlo;
    IFEND;

{  Check to see if some entries just freed up.

    count := 0;
    IF (tmv$dct [jmc$null_dispatching_priority].queue_head <> 0) AND (NOT unconditionally_expand) THEN
      count := 1;
      next_index := tmv$dct [jmc$null_dispatching_priority].queue_head;
      WHILE (tmv$ptl_p^ [next_index].ptl_thread <> 0) AND (count < minimum_free) DO
        count := count + 1;
        next_index := tmv$ptl_p^ [next_index].ptl_thread;
      WHILEND;
    IFEND;

    IF count <> minimum_free THEN
      ALLOCATE new_ptl_p: [0 .. old_max_ptlo + increment] IN osv$mainframe_wired_heap^;
      pmp$zero_out_table (#LOC (new_ptl_p^), #SIZE (new_ptl_p^));
      rb.reqcode := syc$rc_update_job_task_enviro;
      rb.subcode := tmc$ujte_expand_ptl;
      rb.ptl_p := new_ptl_p;
      i#call_monitor (#LOC (rb), #SIZE (rb));
      FREE old_ptl_p IN osv$mainframe_wired_heap^;
    IFEND;

    osp$clear_mainframe_sig_lock (expand_ptl_lock);

  PROCEND osp$expand_ptl;
?? TITLE := 'osp$reset_ptl', EJECT ??

{ This procedure is called at deadstart time after all tasks that run and terminate
{ before job recovery have completed and before tasks that stay around have been
{ initiated.

  PROCEDURE [XDCL, #GATE] osp$reset_ptl;

    VAR
      index: ost$task_index,
      max_ptlo: ost$task_index;

    max_ptlo := UPPERBOUND (tmv$ptl_p^);
    FOR index := 2 TO max_ptlo DO
      tmv$ptl_p^ [index].ptl_thread := index + 1;
    FOREND;
    tmv$ptl_p^ [max_ptlo].ptl_thread := 0;

    tmv$dct [jmc$null_dispatching_priority].queue_head := 2;
    tmv$dct [jmc$null_dispatching_priority].queue_tail := max_ptlo;

  PROCEND osp$reset_ptl;

MODEND osm$initialize_tables;
*DECK DECK=OSM$INITIALIZE_VIRTUAL_SYSTEM EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE System Initialization: Main Routine' ??
MODULE osm$initialize_virtual_system;

{ PURPOSE:
{   This module contains the procedures to complete the initialization of the system to the point where
{   deadstart completes and the System Loop is entered.
{
{ NOTES:
{   This module is located on the OSF$JOB_TEMPLATE_2DD library.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$deadstart_phase
*copyc ost$status
?? POP ??
*copyc clp$convert_string_to_file
*copyc clp$include_line
*copyc clp$log_comment
*copyc loc$task_services_library_name
*copyc osp$activate_system_task
*copyc osp$define_system_task
*copyc osp$generate_message
*copyc osp$scan_ijl_for_recovered_jobs
?? TITLE := '[XDCL] osp$initialize_virtual_system', EJECT ??

{ PURPOSE:
{   This interface initializes the system to the point where deadstart completes.  The system task Dump Broken
{   Job is defined and activated.  Then job classes are established and jobs recovered.  Finally, the system
{   task Console Interaction is defined (not activated).
{
{ NOTES:
{   Console Interaction is activated within the interface OSP$RUN_VIRTUAL_SYSTEM.

  PROCEDURE [XDCL] osp$initialize_virtual_system
    (    deadstart_phase: ost$deadstart_phase);

    VAR
      console_interaction_descriptor: ^llt$program_description,
      dump_broken_job_descriptor: ^llt$program_description,
      ignore_status: ost$status,
      libraries: ^llt$object_library_list,
      log_name_selections: array [1 .. 1] of ost$name,
      parameters: ^pmt$program_parameters,
      program_attributes: ^llt$program_attributes,
      status: ost$status,
      task_name: ost$name;

    status.normal := TRUE;

{ Define and activate the system task Dump Broken Job.

    PUSH dump_broken_job_descriptor: [[REP (#SIZE (llt$program_attributes) + #SIZE (clt$path_name)) OF
          cell]];
    RESET dump_broken_job_descriptor;
    PUSH parameters: [[REP 1 OF cell]];
    NEXT program_attributes IN dump_broken_job_descriptor;
    program_attributes^.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$library_list_specified, pmc$load_map_options_specified,
          pmc$term_error_level_specified];
    program_attributes^.starting_procedure := 'OSP$BROKEN_JOB_DUMP_TASK';
    program_attributes^.number_of_libraries := 1;
    NEXT libraries: [1 .. 1] IN dump_broken_job_descriptor;
    libraries^ [1] := loc$task_services_library_name;
    program_attributes^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    program_attributes^.termination_error_level := pmc$warning_load_errors;
    task_name := 'DUMP_BROKEN_JOB';

    osp$define_system_task (task_name, TRUE {auto restart} , osc$tt_terminate {deactivate option} ,
          osc$tt_terminate {idle option} , TRUE {restart after idle} , 0 {spy_identifier} ,
          osc$user_ring {execution_ring} , dump_broken_job_descriptor, parameters, status);
    IF NOT status.normal THEN
      osp$generate_message (status, ignore_status);
    IFEND;

    osp$activate_system_task (task_name, status);
    IF NOT status.normal THEN
      osp$generate_message (status, ignore_status);
    IFEND;

{ Establish job classes on a continuation deadstart.

    IF deadstart_phase = osc$normal_deadstart THEN
      clp$include_line ('$system.osf$builtin_library.rap$establish_job_classes initiate_jobs=FALSE',
            TRUE, osc$null_name, status);
      IF NOT status.normal THEN
        osp$generate_message (status, ignore_status);
      IFEND;
    IFEND;

{ Allow recoverable jobs to swap in or get rid of any jobs for which the job class of the job is not defined;
{ if this is not a recovery deadstart no jobs will be found, so nothing will happen.

    osp$scan_ijl_for_recovered_jobs;

{ Define the system task Console Interaction.

    PUSH console_interaction_descriptor: [[REP (#SIZE (llt$program_attributes) +
          2 * #SIZE (clt$path_name)) OF cell]];
    RESET console_interaction_descriptor;
    PUSH parameters: [[REP 1 OF cell]];
    NEXT program_attributes IN console_interaction_descriptor;
    program_attributes^.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$library_list_specified, pmc$load_map_options_specified,
          pmc$term_error_level_specified];
    program_attributes^.starting_procedure := 'OSP$CONSOLE_INTERACTION_TASK';
    program_attributes^.number_of_libraries := 2;
    NEXT libraries: [1 .. 2] IN console_interaction_descriptor;
    libraries^ [1] := loc$task_services_library_name;
    libraries^ [2] := '$SYSTEM.OSF$OPERATOR_LIBRARY';
    program_attributes^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    program_attributes^.termination_error_level := pmc$warning_load_errors;
    task_name := 'CONSOLE_INTERACTION';

    osp$define_system_task (task_name, TRUE {auto restart} , osc$tt_ignore_or_prohibited
          {deactivate option} , osc$tt_ignore_or_prohibited {idle option} , FALSE {restart after idle} , 0
          {spy_identifier} , osc$user_ring {execution_ring} , console_interaction_descriptor, parameters,
          status);
    IF NOT status.normal THEN
      osp$generate_message (status, ignore_status);
    IFEND;

    log_name_selections [1] := 'SYSTEM';
    clp$log_comment ('----  System Deadstart Completed ----', log_name_selections, status);
    IF NOT status.normal THEN
      osp$generate_message (status, ignore_status);
    IFEND;

  PROCEND osp$initialize_virtual_system;

MODEND osm$initialize_virtual_system;
*DECK DECK=OSM$INTERACTION_STYLE_HANDLERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Interpreter : Interaction Style Handlers' ??
MODULE osm$interaction_style_handlers;

{
{ PURPOSE:
{   This module contains the procedures to change and to retrieve the
{   interaction style for the job.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc clt$environment_object_size
*copyc clt$interaction_information
*IF NOT $true(osv$unix)
*copyc ife$error_codes
*copyc ose$message_gen_exceptions
*IFEND
*copyc ost$interaction_information
*copyc ost$interaction_style
*copyc ost$status
?? POP ??
*IF $true(osv$unix)
*copyc clp_getenv
*ELSE
*copyc clp$find_current_block
*copyc clp$convert_integer_to_string
*copyc jmv$executing_within_system_job
*copyc osp$append_status_parameter
*copyc osp$find_interaction_info
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$get_job_mode
?? TITLE := 'clp$get_command_mode', EJECT ??
{
{ NOTE:
{   The following type (clt$command_mode) and procedure (clp$get_command_mode)
{   can probably be deleted.  The XREF deck is long gone.  The procedure was
{   kept here on the off-chance that some product or application used it and
{   hasn't needed to be recompiled since the demise of the interface (which
{   was at release 1.2.1, I think).
{

?? SKIP := 3 ??

  TYPE
    clt$command_mode = (clc$normal_mode, clc$line_mode, clc$screen_mode);

?? SKIP := 3 ??

  PROCEDURE [XDCL, #GATE] clp$get_command_mode
    (VAR command_mode: clt$command_mode;
     VAR status: ost$status);

    VAR
      interaction_information: ^clt$interaction_information;


    status.normal := TRUE;

    osp$find_interaction_info (interaction_information);

    IF interaction_information^.style = osc$screen_interaction THEN
      command_mode := clc$screen_mode;
    ELSE
      command_mode := clc$line_mode;
    IFEND;

  PROCEND clp$get_command_mode;
*IFEND
?? TITLE := 'osp$eo_size_interaction_info', EJECT ??

  FUNCTION [XDCL] osp$eo_size_interaction_info: clt$environment_object_size;


    osp$eo_size_interaction_info := #SIZE (clt$interaction_information);

  FUNCEND osp$eo_size_interaction_info;
?? TITLE := 'osp$eo_init_interaction_info', EJECT ??

  PROCEDURE [XDCL] osp$eo_init_interaction_info
    (    object: ^clt$environment_object_contents);

    VAR
      interaction_info: ^clt$interaction_information;


    interaction_info := object;

    interaction_info^.style := osc$line_interaction;
    interaction_info^.menu_rows := 1;
    interaction_info^.extend_utility_interaction := FALSE;

  PROCEND osp$eo_init_interaction_info;
*IF NOT $true(osv$unix)
?? TITLE := 'osp$change_interaction_info', EJECT ??
*copyc osh$change_interaction_info

  PROCEDURE [XDCL, #GATE] osp$change_interaction_info
    (    interaction_information: ost$interaction_information;
     VAR status: ost$status);

    VAR
      current_interaction_info: ^clt$interaction_information,
      ignore_status: ost$status,
      index: integer,
      index_string: ost$string,
      interaction_key_is_good: boolean,
      interaction_value_is_good: boolean,
      number_of_items: integer;


    status.normal := TRUE;

    IF jmv$executing_within_system_job THEN
      osp$set_status_abnormal ('OS', ife$current_job_not_interactive, 'osp$change_interaction_style', status);
      RETURN;
    IFEND;

{ The same interaction information key can be specified more than once.  The last one specified
{ is used.

    number_of_items := UPPERBOUND (interaction_information);

  /validate_interaction_info/
    FOR index := 1 TO number_of_items DO
      interaction_key_is_good := TRUE;
      interaction_value_is_good := TRUE;

      CASE interaction_information [index].key OF
      = osc$null_interaction_info_item, osc$extend_utility_interaction =
        ;

      = osc$interaction_style =
        IF (interaction_information [index].style <> osc$line_interaction) AND
              (interaction_information [index].style <> osc$screen_interaction) THEN
          interaction_value_is_good := FALSE;
        IFEND;

      = osc$menu_rows =
        IF (interaction_information [index].menu_rows < 0) OR
              (interaction_information [index].menu_rows > csc$number_of_menu_rows) THEN
          interaction_value_is_good := FALSE;
        IFEND;

      ELSE
        interaction_key_is_good := FALSE;

      CASEND;

      IF NOT interaction_key_is_good THEN
        clp$convert_integer_to_string (index, 10, FALSE, index_string, ignore_status);
        IF status.normal OR (status.condition <> ose$unknown_interaction_item) THEN
          osp$set_status_abnormal ('OS', ose$unknown_interaction_item, index_string.value (index_string.size),
                status);
        ELSE
          osp$append_status_parameter (',', index_string.value (index_string.size), status);
        IFEND;
      ELSEIF NOT interaction_value_is_good THEN
        clp$convert_integer_to_string (index, 10, FALSE, index_string, ignore_status);
        IF status.normal THEN
          osp$set_status_abnormal ('OS', ose$improper_inter_item_value, index_string.
                value (index_string.size), status);
        ELSEIF status.condition = ose$improper_inter_item_value THEN
          osp$append_status_parameter (',', index_string.value (index_string.size), status);
        IFEND;
      IFEND;

    FOREND /validate_interaction_info/;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$find_interaction_info (current_interaction_info);

    FOR index := 1 TO number_of_items DO

      CASE interaction_information [index].key OF
      = osc$null_interaction_info_item =
        ;

      = osc$interaction_style =
        current_interaction_info^.style := interaction_information [index].style;

      = osc$menu_rows =
        current_interaction_info^.menu_rows := interaction_information [index].menu_rows;

      = osc$extend_utility_interaction =
        current_interaction_info^.extend_utility_interaction :=
              interaction_information [index].extend_utility_interaction;
      CASEND
    FOREND;

  PROCEND osp$change_interaction_info;
?? TITLE := 'osp$change_interaction_style', EJECT ??
*copyc osh$change_interaction_style

  PROCEDURE [XDCL, #GATE] osp$change_interaction_style
    (    interaction_style: ost$interaction_style;
     VAR status: ost$status);

    VAR
      interaction_information: ^clt$interaction_information;


    status.normal := TRUE;

    IF jmv$executing_within_system_job THEN
      osp$set_status_abnormal ('OS', ife$current_job_not_interactive, 'osp$change_interaction_style', status);
      RETURN;
    IFEND;

    IF (interaction_style <> osc$line_interaction) AND (interaction_style <> osc$screen_interaction) THEN
      osp$set_status_condition (ose$bad_interaction_style, status);
      RETURN;
    IFEND;

    osp$find_interaction_info (interaction_information);

    interaction_information^.style := interaction_style;

  PROCEND osp$change_interaction_style;
?? TITLE := 'osp$get_interaction_information', EJECT ??
*copyc osh$get_interaction_information

  PROCEDURE [XDCL, #GATE] osp$get_interaction_information
    (VAR interaction_information: ost$interaction_information;
     VAR status: ost$status);

    VAR
      current_interaction_info: ^clt$interaction_information,
      ignore_status: ost$status,
      index: integer,
      index_string: ost$string;

    status.normal := TRUE;

    osp$find_interaction_info (current_interaction_info);

    FOR index := 1 TO UPPERBOUND (interaction_information) DO

      CASE interaction_information [index].key OF

      = osc$null_interaction_info_item =
        ;

      = osc$interaction_style =
        interaction_information [index].style := current_interaction_info^.style;

      = osc$menu_rows =
        interaction_information [index].menu_rows := current_interaction_info^.menu_rows;

      = osc$extend_utility_interaction =
        interaction_information [index].extend_utility_interaction :=
              current_interaction_info^.extend_utility_interaction;

      ELSE
        clp$convert_integer_to_string (index, 10, FALSE, index_string, ignore_status);
        IF status.normal THEN
          osp$set_status_abnormal ('OS', ose$unknown_interaction_item, index_string.value (index_string.size),
                status);
        ELSE
          osp$append_status_parameter (',', index_string.value (index_string.size), status);
        IFEND;

      CASEND;
    FOREND;

  PROCEND osp$get_interaction_information;
*IFEND
?? TITLE := 'osp$get_interaction_style', EJECT ??
*copyc osh$get_interaction_style

  PROCEDURE [XDCL, #GATE] osp$get_interaction_style
    (VAR interaction_style: ost$interaction_style;
     VAR status: ost$status);

    VAR
*IF $true(osv$unix)
      value: ost_c_fixed_string,
      value_length: ost_c_integer,
      variable_name: ost_c_name;
*ELSE
      interaction_information: ^clt$interaction_information;
*IFEND


    status.normal := TRUE;

*IF NOT $true(osv$unix)
    osp$find_interaction_info (interaction_information);

    interaction_style := interaction_information^.style;
*ELSE
    variable_name := 'OSV_INTERACTION_STYLE' CAT $CHAR(0);
    clp_getenv (variable_name, value, value_length);
    IF (value_length > 0) AND (value(1,value_length) = 'line') THEN
      interaction_style := osc$line_interaction;
    ELSE
      interaction_style := osc$screen_interaction;
    IFEND
*IFEND

  PROCEND osp$get_interaction_style;
*IF NOT $true(osv$unix)
?? TITLE := 'osp$set_desktop_interaction', EJECT ??
*copyc osh$set_desktop_interaction

  PROCEDURE [XDCL, #GATE] osp$set_desktop_interaction
    (VAR status: ost$status);

    VAR
      block: ^clt$block,
      interaction_information: ^clt$interaction_information,
      job_mode: jmt$job_mode;


    status.normal := TRUE;

    pmp$get_job_mode (job_mode, status);
    IF NOT status.normal THEN
      RETURN;
    ELSEIF job_mode = jmc$batch THEN
      osp$set_status_abnormal ('OS', ife$current_job_not_interactive, 'osp$set_desktop_interaction', status);
      RETURN;
    IFEND;

    clp$find_current_block (block);
    IF (block^.kind <> clc$task_block) OR (block^.environment_object_info = NIL) OR
          (NOT block^.environment_object_info^.defined [clc$eo_interaction_information]) THEN
      osp$set_status_condition (ose$bad_interaction_style, status);
      RETURN;
    IFEND;

    osp$find_interaction_info (interaction_information);

    interaction_information^.style := osc$desktop_interaction;

  PROCEND osp$set_desktop_interaction;
*IFEND

MODEND osm$interaction_style_handlers;
*DECK DECK=OSM$INTRINSICS EXPAND=TRUE
OSAINX    IDENT
OSAINX    ALIAS    OSM$INTRINSICS
.
.
. This module contains procedures which
.    externalize machine instructions to the CYBIL programmer.
.    It is hoped that eventually these procedures can be replaced
.    by built-in functions in CYBIL.
.
.
.
. Register equates used thruout this module
.
xj       equ       12
xk       equ       13
aj       equ       12
ak       equ       13
amacscr  equ       15        .scratch a reg used by macros
.
xj       atrib     #regtyp,#xreg
xk       atrib     #regtyp,#xreg
aj       atrib     #regtyp,#areg
ak       atrib     #regtyp,#areg
amacscr  atrib     #regtyp,#areg
.
.  COMMON DECKS FOLLOW:
*copy osa$cybil_interface
*copy osa$basic_register_equates
         page
.
.    i#call_monitor
. Purpose:
.    This procedure is used to call MONITOR. The proc load the monitor
.    request block into the x registers, exchanges to monitor. When
.    monitor returns, the contents of the X registers are restored
.    to memory.
. Input:
.    param_p: Pointer to the monitor request block.
.    param_length: (1 .. 120) Length of the monitor request block in
.                  cells
. Output:
.    The request block may be modified by monitor during request
.    processing.
. Notes:
. -------------------------------------------------------------------"
.
.   PROCEDURE[XREF] i#call_monitor(rb_p:^cell;
.            rb_len:8 .. 120);
.
.   PROC[xdcl, code (ipl)] i#monitor_call (val p: ^cell; "ptr to req block"
.                val len: 1 .. 120);
.
.
.
icall    alias     I#CALL_MONITOR
icall    procedur
rb_p     param     val,pointer
rb_len   param     val,subrange,1
.
         ploada    aj,rb_p
         ploadx    x2,rb_len
         shfx      x2,x2,x0,-3
         addrq     xf,x2,1000(16)
         lmult     xf,aj,0
         exchange
         smult     xf,aj,0
         return
         page
. ---------------------------------------------------------------
. Name:
.    i#test_set_bit
. Purpose:
.    This procedure externalizes the 'Load Bit' instruction
.    Ref 124.
. Input:
.    P : pointer to byte containing the bit to be loaded.
.    bit_num : bit number within byte.Left most bit in the
.             byte is 0.
. Output:
.    This proc returns a boolean value.
.      true - bit was previously set
.      false  - bit was not previously set
. ---------------------------------------------------------------
.
.
.   PROCEDURE [XREF] i#test_set_bit(VAR p:^cell;
.         bit_num: 0 .. 255;
.     VAR bool: boolean);
.
.
.
ilbit    alias     I#TEST_SET_BIT
ilbit    procedur
p        param     val,pointer
bit_num  param     val,integer
bool     param     ref,boolean
.
         ploada    aj,p
         ploadx    x0,bit_num
         lbset     xk,aj,x0
         ents      xk
         pstorxp   xk,bool
         return
.
         page
. -------------------------------------------------------------------
. Name:
.    i#rel
. Purpose:
.    This function calculates the displacement of a pointer from a base
.    pointer. The results of the function are undefined if the segment
.    numbers in the two pointers are not the same.
. Input:
.    ptr: pointer expression
.    base_ptr: pointer expression
. Output:
.    xk: displacement of a pointer froma base pointer
. -------------------------------------------------------------------
.
.   FUNCTION[XREF] i#rel(ptr:^cell;
.           base_ptr:^cell):ost$relative_pointer
.
.
REL      alias    I#REL
rel      function integer
ptr      param    val,pointer
base_ptr param    val,pointer
.
         ploada   aj,ptr
         cpyax    xj,aj
         ploada   aj,base_ptr
         cpyax    xk,aj
         subr     xk,xj
         ents     xk
         freturnx xk
         page
. ------------------------------------------------------------------
. Name:
.    i#ptr
. Purpose:
.    This function calculates a pointer from a base pointer and a byte
.    displacement from the base pointer.
. Input:
.    disp: integer expression that specifies the byte displacement
.          from the base pointer
.    base_ptr: pointer expression
. Output:
.    ak: pointer
. -------------------------------------------------------------------
.
.   FUNCTION[XREF] i#ptr(disp: ost$relative_pointer;
.           base_ptr: ^cell): ^cell
.
.
PTRI     alias     I#PTR
ptri     function  pointer
disp     param     val,integer
baseptr  param     val,pointer
.
         ploada    ak,baseptr
         ploadx    xj,disp
         addax     ak,xj
         cpyax    xk,ak
         freturnx xk
           page
. -------------------------------------------------------------------
. Name:
.   i#real_memory_address
. Purpose:
.   This function externalizes the TPAGE instruction (REF 126).
. Input:
.   pva: pointer expression
. Output:
.   This instruction translates a PVA into a RMA and sets the 'used'
.   bit in the page table entry for the page. If the PVA can not be
.   translated because the page is not in real memory, the function
.   returns a negative number.
. -------------------------------------------------------------------
.
.   FUNCTION[XREF] i#real_memory_address(p:^cell):integer
.
tpva     alias     i#real_memory_address
tpva     procedur
pva      param     val,pointer
rma      param     ref,integer
.
         ploada    aj,pva
         tpage     xk,aj
         ents      xk
         pstorxp   xk,rma
         return
          page
. -------------------------------------------------------------------
. Name:
.   i#store_bit
. Purpose:
.   This procedure externalizes the SBIT instruction (REF 015).
. Input:
.   bit_value - boolean expression which specifies the value of the
.     bit to be written to memory
.   pointer - pointer to variable on which the SBIT instruction
.     performs the write operation
.   disp - displacement to the variable
. ___________________________________________________________________
.   PROCEDURE[XREF] i#store_bit(bitval: boolean;
.            p:^cell;  disp: integer);
.
STRBIT    alias      I#STORE_BIT
strbit    procedur
bitval    param       val,boolean
pt        param       val,pointer
disp      param       val,integer
.
          ploada      aj,pt
          ploadx      x0,disp
          ploadx      xk,bitval
          sbit        xk,aj,0,x0
          return
          page
. -------------------------------------------------------------------
. Name:
.   i#program_error
. Purpose:
.   This procedure is used to gererate a program error instruction.
.   (REF 121)
. -------------------------------------------------------------------
.
.   PROCEDURE[XREF] i#program_error;
.
.
phalt    alias   i#program_error
phalt    procedur
.
         halt
         return
         page
. -------------------------------------------------------------------
. Name:
.   i#sync
. Purpose:
.   This procedure is used to gererate a scope loop sync instruction.
.   (REF 194)
. -------------------------------------------------------------------
.
.   PROCEDURE [XREF] i#sync;
.
.
psync    alias   i#sync
psync    procedur
.
         sync
         return
         page
. --------------------------------------------------------------------
. Name:
.   i#compare
. Purpose:
.   This function compares two byte strings from left to right and
.   returns integer result that specifies the result of the comparison.
.   (REF 084)
. Input:
.   two byte strings with lengths and maximum of 256 bytes for each
. Notes:
.   when lengths are unequal, trailing space characters are used for
.   the shorter
. --------------------------------------------------------------------
.
.   FUNCTION[XREF] i#compare(p1, p2: ^string(*)):-1..1
.
comps     alias   i#compare
comps     function  integer
string1   param   val,astring
string2   param   val,astring
.
          pstring  aj,x0,string1
          pstring  ak,x1,string2
          CMPB,aj,x0  ak,x1   1,9,0,0   1,9,0,0
          shfx    x1,x1,x0,32
          shfx    x1,x1,x0,-62
          freturnx  x1
        page
. -------------------------------------------------------------------
. Name:
.   i#compare_collated
. Purpose:
.   This function does a collated comparison of two strings and
.   returns an integer result that specifies the result of the
.   comparison. (REF 085)
. Input:
.   Two byte strings with lengths and maximum of 256 bytes for each.
. -------------------------------------------------------------------
.
.   FUNCTION[XREF] i#compare_collated(p1,p2:^string(* <= 256);
.           table:^string(256)):-1..1
.
compcs   alias    i#compare_collated
compcs   function  integer
string1   param   val,astring
string2   param   val,astring
string3   param   val,string,256
.
          pstring  aj,x0,string1
          pstring  ak,x1,string2
          ploada  a3,string3
          CMPC,aj,x0  ak,x1,a3,0   1,9,0,0   1,9,0,0
          shfx    x1,x1,x0,32
          shfx    x1,x1,x0,-62
          freturnx  x1
         page
. -------------------------------------------------------------------
. Name:
.    i#build_adaptable_seq_pointer
. Purpose:
.    This proc builds a pointer to an adaptable seq. The caller supplies the
.    ring, segment, offset, and fixer sizes.
. Input:
.    rn: Ring number
.    sn: Segment number
.    bn: Byte number
.    seq_length: Length of the seq
.    next: offset to next entry
. Output:
.     seq_pointer: pointer to the adaptable seq
. -------------------------------------------------------------------
.
.   PROCEDURE[XREF] i#build_adaptable_seq_pointer (rn:0 .. 15;
.     SN:0 .. 4095;
.     bn:0 ..0FFFFFFFF(16);
.     seq_length: 0 .. 7fffffff(16);
.     next: 0 .. 7fffffff(16);
.   VAR seq_p: ^SEQ(*));
.
.
.
.
iseq     alias     I#BUILD_ADAPTABLE_SEQ_POINTER
iseq     procedur
rn       param     val,subrange,1
sn       param     val,subrange,2
bn       param     val,integer
len      param     val,integer
next     param     val,integer
ptr      param     ref,pointer
.
         ploadx    x1,rn
         ploadx    x2,sn
         ploadx    x3,bn
         insb     x3,x2,x0,2413(8)
         insb     x3,x1,x0,2003(8)
         ploadx    x5,len
         ploadx    x4,next
         insb   x4,x5,x0,0037(8)
         pstorxp   x3,ptr
         sbyts,8   x4,amacscr,x0,6
         return
         page
. -------------------------------------------------------------------
. Name:
.    i#current_sequence_position
. Purpose:
.    This function returns the current position in a sequence given an
.    adaptable sequence pointer.
. Input:
.    seq_p:^seq(*)
. Output:
.    current position in sequence
. -------------------------------------------------------------------
. Note:
.    The interface deck for this function now contains an INLINE
.    implementation.  The version of the function in this module is
.    being retained in support of any modules that have not recompiled
.    with the INLINE version.
. -------------------------------------------------------------------
.
.   FUNCTION [XREF] i#current_sequence_position (seq_p: ^seq(*)):integer;
.
.
icseqp   alias     I#CURRENT_SEQUENCE_POSITION
icseqp   function  integer
seq_p    param     val,pointer

         la        ak,a_plist,0
         lbyts,4   xk,ak,x0,10         .Current sequence position
         freturnx  xk
         page
. -------------------------------------------------------------------
. Name:
.    i#build_adaptable_heap_pointer
. Purpose:
.    This proc builds a pointer to an adaptable heap. The caller supplies the
.    ring, segment, offset, and fixer sizes.
. Input:
.    rn: Ring number
.    sn: Segment number
.    bn: Byte number
.    heap_length: Length of the heap
. Output:
.     heap_pointer: pointer to the adaptable heap
. -------------------------------------------------------------------
.
.   PROCEDURE[XREF] i#build_adaptable_heap_pointer (rn:0 .. 15;
.     SN:0 .. 4095;
.     bn:0 ..0FFFFFFFF(16);
.     heap_length: 0 .. 7fffffff(16);
.   VAR heap_p: ^SEQ(*));
.
.
.
.
iheap    alias     I#BUILD_ADAPTABLE_HEAP_POINTER
iheap    procedur
rn       param     val,subrange,1
sn       param     val,subrange,2
bn       param     val,integer
len      param     val,integer
ptr      param     ref,pointer
.
         ploadx    x1,rn
         ploadx    x2,sn
         ploadx    x3,bn
         insb     x3,x2,x0,2413(8)
         insb     x3,x1,x0,2003(8)
         ploadx    x4,len
         pstorxp   x3,ptr
         sbyts,4   x4,amacscr,x0,6
         return
         page
. -------------------------------------------------------------------
. Please note the following procedure will not compile with
. the CYBIL compiler version 88.1. The procedure
. i#build_adaptable_array_ptr will replace this
. procedure. It is functionally the same; however, the pointer
. parameter has become a reference parameter. Callers of the new
. procedure need to pass #LOC (pointer) instead of pointer.
.
. Name:
.    i#build_adaptable_array_pointer
. Purpose:
.    This proc builds a pointer to an adaptable array. The caller supplies the
.    ring, segment, offset, and fixer sizes.
. Input:
.    rn: Ring number
.    sn: Segment number
.    bn: Byte number
.    array_length: Length of the array
.    element_size: size of each element in the array
.    lower_bound: lower bound
. Output:
.     array_pointer: pointer to the adaptable array
. -------------------------------------------------------------------
.
.   PROCEDURE[XREF] i#build_adaptable_array_pointer (rn:0 .. 15;
.     SN:0 .. 4095;
.     bn:0 ..0FFFFFFFF(16);
.     array_length: 0 .. 7fffffff(16);
.     lower_bound: 0 .. 7fffffff(16);
.     element_size: 0 .. 7fffffff(16);
.     VAR array_p: ^cell);
.
.   PROC[xdcl] i#build_adaptable_array_pointer (val rn: 0 .. 15;
.   val sn: 0..4095; val bn: syt#halfword
.   val array_length: 0 .. 7fffffff(16);
.   val lower_bound: 0 .. 7fffffff(16);
.   val element_size: 0 .. 7fffffff(16);
.   ref array_p: ^cell);
.
.
iarray     alias     I#BUILD_ADAPTABLE_ARRAY_POINTER
iarray     procedur
rn       param     val,subrange,1
sn       param     val,subrange,2
bn       param     val,integer
as       param     val,integer
lb       param     val,integer
es       param     val,integer
ptr      param     ref,pointer
.
         ploadx    x1,rn
         ploadx    x2,sn
         ploadx    x3,bn
         insb     x3,x2,x0,2413(8)
         insb     x3,x1,x0,2003(8)
         ploadx    x4,as
         ploadx    x5,lb
         ploadx    x6,es
         pstorxp    x3,ptr
         sbyts,4   x4,amacscr,x0,6
         sbyts,4   x5,amacscr,x0,10
         sbyts,4   x6,amacscr,x0,14
         return
. -------------------------------------------------------------------
. Name:
.    i#build_adaptable_array_ptr
. Purpose:
.    This proc builds a pointer to an adaptable array. The caller supplies the
.    ring, segment, offset, and fixer sizes.
. Input:
.    rn: Ring number
.    sn: Segment number
.    bn: Byte number
.    array_length: Length of the array
.    element_size: size of each element in the array
.    lower_bound: lower bound
. Output:
.     array_pointer: pointer to the adaptable array
. -------------------------------------------------------------------
.
.   PROCEDURE[XREF] i#build_adaptable_array_ptr (rn:0 .. 15;
.     SN:0 .. 4095;
.     bn:0 ..0FFFFFFFF(16);
.     array_length: 0 .. 7fffffff(16);
.     lower_bound: 0 .. 7fffffff(16);
.     element_size: 0 .. 7fffffff(16);
.     array_p: ^^cell);
.
.   PROC[xdcl] i#build_adaptable_array_ptr (val rn: 0 .. 15;
.   val sn: 0..4095; val bn: syt#halfword
.   val array_length: 0 .. 7fffffff(16);
.   val lower_bound: 0 .. 7fffffff(16);
.   val element_size: 0 .. 7fffffff(16);
.   val array_p: ^^cell);
.
.
iarray2    alias     I#BUILD_ADAPTABLE_ARRAY_PTR
iarray2    procedur
rn       param     val,subrange,1
sn       param     val,subrange,2
bn       param     val,integer
as       param     val,integer
lb       param     val,integer
es       param     val,integer
ptr      param     val,pointer
.
         ploadx    x1,rn
         ploadx    x2,sn
         ploadx    x3,bn
         insb     x3,x2,x0,2413(8)
         insb     x3,x1,x0,2003(8)
         ploadx    x4,as
         ploadx    x5,lb
         ploadx    x6,es
         ploada    ak,ptr
         sbyts,6   x3,ak,x0,0
         sbyts,4   x4,ak,x0,6
         sbyts,4   x5,ak,x0,10
         sbyts,4   x6,ak,x0,14
         return
         end
*DECK DECK=OSM$I_AWAIT_ACTIVITY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'OSM$I_AWAIT_ACTIVITY' ??
MODULE osm$i_await_activity;

{   PURPOSE:
{     The purpose of this request is to support the osp$i_await_activity_completion
{     request.

{   DESIGN:
{     The procedure contained in this module has an execution bracket
{     of 1, 3 and a call bracket of 13.

?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$improper_file_id
*copyc nac$null_connection_id
*copyc nae$sk_socket_layer
*copyc osd$virtual_address
*copyc ose$await_activity_exceptions
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc ost$hardware_subranges
*copyc ost$i_wait
*copyc ost$status
*copyc pmd$local_queues
*copyc pme$local_queue_exceptions
*copyc pmt$task_id
?? POP ??
*copyc bap$validate_file_identifier
*copyc iip$vt_check_data_available
*copyc iip$xt_check_upline
*copyc iip$xt_is_xterm_file
*copyc nap$check_connection
*copyc nap$check_data_available
*copyc nap$check_server_response
*copyc nap$check_switch_accept
*copyc nap$check_switch_offer
*copyc nap$check_title_translation
*copyc nap$remove_network_waits
*copyc nlp$sk_await_socket_offer
*copyc nlp$sk_lock_job_socket
*copyc nlp$sk_tcp_await_clear_to_send
*copyc nlp$sk_tcp_await_data_available
*copyc nlp$sk_tcp_check_accept_socket
*copyc nlp$sk_unlock_job_socket
*copyc nlp$udp_await_clear_to_send
*copyc nlp$udp_await_data_available
*copyc osp$append_status_integer
*copyc osp$establish_condition_handler
*copyc osp$disestablish_cond_handler
*copyc osp$pop_inhibit_job_recovery
*copyc osp$push_inhibit_job_recovery
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$await_nonempty_queue
*copyc pmp$continue_to_cause
*copyc pmp$long_term_wait
*copyc pmp$remove_await_nonempty_queue
*copyc pmp$verify_current_child
*copyc rfp$check_for_event
*copyc rfp$remove_waits
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$i_await_activiy', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$i_await_activity
    (    wait_list: ost$i_wait_list;
     VAR ready_index: integer;
     VAR complete: boolean;
     VAR status: ost$status);

    TYPE
      activity_index = 0 .. osc$maximum_offset;

    CONST
      local_clock = 0;

    VAR
      active_rhfam_wait: boolean,
      activity: activity_index,
      await_complete: boolean,
      await_status: ost$status,
      current_time: ost$free_running_clock,
      elapsed_time: ost$free_running_clock,
      exit_on_ready_task: boolean,
      exit_save_activity_index: activity_index,
      file_instance: ^bat$task_file_entry,
      file_is_valid: boolean,
      ignore_status: ost$status,
      job_socket: ^nat$sk_job_socket,
      null_list: boolean,
      requestor: ost$caller_identifier,
      start_time: ost$free_running_clock,
      task_has_gone_ready: boolean,
      wait_time: ost$free_running_clock;

?? NEWTITLE := '[INLINE] cleanup_active_waits', EJECT ??

    PROCEDURE [INLINE] cleanup_active_waits;

      remove_await_nonempty_queue (1, UPPERBOUND (wait_list));
      nap$remove_network_waits (wait_list);
      remove_rhfam_waits;
    PROCEND cleanup_active_waits;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_of_condition', EJECT ??

    PROCEDURE dispose_of_condition
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF
      = ifc$interactive_condition, jmc$job_resource_condition =
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        EXIT osp$i_await_activity;
      = pmc$block_exit_processing =
        cleanup_active_waits;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND dispose_of_condition;
?? OLDTITLE ??
?? NEWTITLE := 'remove_await_nonempty_queue', EJECT ??

    PROCEDURE remove_await_nonempty_queue
      (    starting_activity: activity_index;
           ending_activity: activity_index);

      VAR
        activity: activity_index;

      FOR activity := starting_activity TO ending_activity DO
        IF (wait_list [activity].activity = pmc$i_await_local_queue_message) THEN
          pmp$remove_await_nonempty_queue (wait_list [activity].qid);
        IFEND;
      FOREND;
    PROCEND remove_await_nonempty_queue;
?? OLDTITLE ??
?? NEWTITLE := 'remove_rhfam_waits', EJECT ??

    PROCEDURE remove_rhfam_waits;

      IF active_rhfam_wait THEN
        rfp$remove_waits;
      IFEND;
    PROCEND remove_rhfam_waits;
?? OLDTITLE ??
?? EJECT ??

    #CALLER_ID (requestor);
    elapsed_time := 0;
    status.normal := TRUE;
    complete := FALSE;
    active_rhfam_wait := FALSE;
    osp$establish_condition_handler (^dispose_of_condition, {block_exit} TRUE);
    await_status.normal := TRUE;
    wait_time := UPPERVALUE (ost$free_running_clock);
    task_has_gone_ready := FALSE;
    exit_on_ready_task := FALSE;

    null_list := TRUE;
    REPEAT
      await_complete := FALSE;
      activity := 1;
      WHILE NOT await_complete AND (activity <= UPPERBOUND (wait_list)) AND await_status.normal DO
        CASE wait_list [activity].activity OF
        = osc$i_null_activity =
          ;

        = osc$i_await_time =
          null_list := FALSE;
          IF (elapsed_time >= (wait_list [activity].milliseconds * 1000)) THEN
            await_complete := TRUE;
            complete := TRUE;
          ELSEIF ((wait_list [activity].milliseconds * 1000) < wait_time) THEN
            wait_time := wait_list [activity].milliseconds * 1000;
          IFEND;

        = pmc$i_await_task_termination =
          null_list := FALSE;
          pmp$verify_current_child (wait_list [activity].task_id, await_complete);
          await_complete := NOT await_complete;
          complete := await_complete;

        = pmc$i_await_local_queue_message =
          null_list := FALSE;
          pmp$await_nonempty_queue (wait_list [activity].qid, requestor.ring, await_complete, await_status);
          IF await_status.normal THEN
            complete := await_complete;
          IFEND;

        = nac$i_await_server_response =
          null_list := FALSE;
          nap$check_server_response (wait_list [activity].file^, await_complete, await_status);
          IF await_status.normal THEN
            complete := await_complete;
          IFEND;

        = nac$i_await_switch_accept =
          null_list := FALSE;
          nap$check_switch_accept (wait_list [activity].file^, await_complete, await_status);
          IF await_status.normal THEN
            complete := await_complete;
          IFEND;

        = nac$i_await_connection =
          null_list := FALSE;
          nap$check_connection (wait_list [activity].server, await_complete, await_status);
          IF await_status.normal THEN
            complete := await_complete;
          IFEND;

        = nac$i_await_switch_offer =
          null_list := FALSE;
          nap$check_switch_offer (wait_list [activity].source, await_complete, await_status);
          IF await_status.normal THEN
            complete := await_complete;
          IFEND;

        = nac$i_await_activity_status =
          null_list := FALSE;
          IF wait_list [activity].activity_status^.complete THEN
            await_complete := TRUE;
            complete := await_complete;
          IFEND;

        = nac$i_await_data_available =
          null_list := FALSE;

          bap$validate_file_identifier (wait_list [activity].file_identifier, file_instance, file_is_valid);
          IF NOT file_is_valid THEN
            osp$set_status_condition (ame$improper_file_id, await_status);
          ELSE
            IF file_instance^.device_class = rmc$network_device THEN
              IF iip$xt_is_xterm_file (file_instance^.system_file_label) THEN
                iip$xt_check_upline (wait_list [activity].file_identifier, await_complete, await_status);
              ELSE {This is a not an xterm file.
                nap$check_data_available (wait_list [activity].file_identifier, await_complete,
                       await_status);
              IFEND;
            ELSE {rmc$terminal_device
              iip$vt_check_data_available (wait_list [activity].file_identifier, await_complete,
                    await_status);
            IFEND;
            IF await_status.normal THEN
                complete := await_complete;
            IFEND;
          IFEND;

        = nac$i_await_title_translation =
          null_list := FALSE;
          nap$check_title_translation (wait_list [activity].translation_request, await_complete,
                await_status);
          IF await_status.normal THEN
            complete := await_complete;
          IFEND;

        = nac$i_sk_await_clear_to_send =
          null_list := FALSE;
          osp$push_inhibit_job_recovery;
          nlp$sk_lock_job_socket (wait_list [activity].socket_identifier, job_socket);
          IF job_socket <> NIL THEN
            IF job_socket^.status = nac$sk_socket_open THEN
              IF job_socket^.socket_type = nac$sk_udp_socket THEN
                nlp$udp_await_clear_to_send (job_socket^.global_socket_id, {wait} TRUE,
                  await_complete);
              ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
                IF (job_socket^.tcp_socket_type = nlc$tcp_connect_socket) OR
                        (job_socket^.tcp_socket_type = nlc$tcp_accept_socket) THEN
                    nlp$sk_tcp_await_clear_to_send (job_socket^.connection_id, {wait} TRUE,
                      await_complete);
                ELSE { Either connect or listen not done.  Should this give a reject instead???
                  await_complete := TRUE;
                IFEND;
              IFEND;
            ELSE { Socket closed
              await_complete := TRUE;
            IFEND;
          ELSE { Unknown Socket
            osp$set_status_abnormal (nac$status_id, nae$sk_unknown_socket, '', await_status);
            osp$append_status_integer (osc$status_parameter_delimiter, wait_list [activity].socket_identifier,
                  10, TRUE, await_status);
          IFEND;
          nlp$sk_unlock_job_socket (wait_list [activity].socket_identifier);
          osp$pop_inhibit_job_recovery;

        = nac$i_sk_await_data_available =
          null_list := FALSE;
          osp$push_inhibit_job_recovery;
          nlp$sk_lock_job_socket (wait_list [activity].socket_id, job_socket);
          IF job_socket <> NIL THEN
            IF job_socket^.status = nac$sk_socket_open THEN
              IF job_socket^.socket_type = nac$sk_udp_socket THEN
                nlp$udp_await_data_available (job_socket^.global_socket_id, {wait} TRUE,
                  await_complete);
              ELSEIF job_socket^.socket_type = nac$sk_tcp_socket THEN
                IF (job_socket^.tcp_socket_type = nlc$tcp_connect_socket) OR
                      (job_socket^.tcp_socket_type = nlc$tcp_accept_socket) THEN
                  nlp$sk_tcp_await_data_available (job_socket^.connection_id, {wait} TRUE,
                    await_complete);
                ELSEIF job_socket^.tcp_socket_type = nlc$tcp_listen_socket THEN
                  nlp$sk_tcp_check_accept_socket (job_socket^.application, job_socket^.port,
                        job_socket^.bound_address, {wait} TRUE, await_complete);
                ELSE  { job_socket^.tcp_socket_type = nlc$tcp_null_socket
                  await_complete := TRUE;
                IFEND;
              IFEND;
            ELSE { Socket closed
              await_complete := TRUE;
            IFEND;
          ELSE { Unknown Socket
            osp$set_status_abnormal (nac$status_id, nae$sk_unknown_socket, '', await_status);
            osp$append_status_integer (osc$status_parameter_delimiter, wait_list [activity].socket_id, 10,
                  TRUE, await_status);
          IFEND;
          nlp$sk_unlock_job_socket (wait_list [activity].socket_id);
          osp$pop_inhibit_job_recovery;

        = nac$i_sk_await_socket_offer =
          null_list := FALSE;
          osp$push_inhibit_job_recovery;
          nlp$sk_await_socket_offer (wait_list [activity].source_job, {wait} TRUE, await_complete);
          osp$pop_inhibit_job_recovery;

        = rfc$i_await_server_response, rfc$i_await_incoming_connect, rfc$i_await_switch_offer,
              rfc$i_await_switch_accept, rfc$i_await_connection_event =
          null_list := FALSE;
          rfp$check_for_event (wait_list [activity], await_complete, await_status);
          IF await_status.normal THEN
            complete := await_complete;
            IF NOT await_complete THEN
              active_rhfam_wait := TRUE;
            IFEND;
          IFEND;

        = osc$i_await_unspecified_event =
          null_list := FALSE;
          IF task_has_gone_ready THEN
            exit_on_ready_task := TRUE;
            exit_save_activity_index := activity;
          IFEND;

        ELSE
          osp$set_status_condition (ose$incorrect_activity, await_status);
        CASEND;

        IF NOT await_complete AND await_status.normal THEN
          activity := activity + 1;
        IFEND;
      WHILEND;

      IF await_status.normal THEN

        IF await_complete THEN { this will exit the repeat loop
          ready_index := activity;
          complete := TRUE;

        ELSEIF exit_on_ready_task THEN { this will exit the repeat loop
          await_complete := TRUE;
          complete := TRUE;
          ready_index := exit_save_activity_index;

        ELSEIF null_list THEN
          ready_index := 1;
          await_complete := TRUE;
          complete := TRUE;

        ELSE
          IF ((wait_time - elapsed_time) > 0) THEN
            start_time := #FREE_RUNNING_CLOCK (local_clock);
            pmp$long_term_wait ((wait_time - elapsed_time) DIV 1000, (wait_time - elapsed_time) DIV 1000);
            current_time := #FREE_RUNNING_CLOCK (local_clock);
            IF current_time > start_time THEN
              elapsed_time := elapsed_time + (current_time - start_time);
            IFEND;
          IFEND;
          task_has_gone_ready := TRUE;
        IFEND;
      IFEND;
    UNTIL await_complete OR NOT await_status.normal;

    cleanup_active_waits;

    IF await_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := await_status;

{ If status is abnormal, return with the ready index of the item in the waitlist that failed.
{ This is for debugging purposes only - callers should not rely on this side effect being true.

      ready_index := activity;
    IFEND;
    osp$disestablish_cond_handler;
  PROCEND osp$i_await_activity;
MODEND osm$i_await_activity;
*DECK DECK=OSM$I_AWAIT_ACTIVITY_COMPLETE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Await Activity User Ring Interfaces', EJECT ??
MODULE osm$i_await_activity_complete;
{   PURPOSE:
{     The purpose of this module is to support the osp$i_await_activity_completion
{     request.

{   DESIGN:
{     The procedure contained in this module has an execution bracket of 1, 13.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osd$keypoints
*copyc ost$i_wait
*copyc ost$status
?? POP ??
*copyc osp$i_await_activity
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$i_await_activity_completion', EJECT ??
*copy osh$i_await_activity_completion

  PROCEDURE [XDCL, #GATE] osp$i_await_activity_completion
    (    wait_list: ost$i_wait_list;
     VAR ready_index: integer;
     VAR status: ost$status);

    VAR
      wait_complete: boolean;

    ready_index := 0;
    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, osk$i_await_activity_completion);
    wait_complete := FALSE;
    REPEAT
      osp$i_await_activity (wait_list, ready_index, wait_complete, status);
    UNTIL wait_complete OR NOT status.normal;
    #KEYPOINT (osk$exit, 0, osk$i_await_activity_completion);
  PROCEND osp$i_await_activity_completion;
?? OLDTITLE ??
MODEND osm$i_await_activity_complete;
*DECK DECK=OSM$JOB_RECOVERY_LOGGING EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE OS : Job Recovery Logging' ??
MODULE osm$job_recovery_logging;

{ PURPOSE:
{   This module contains those routines to help debug and display the status of jobs during active
{   job recovery.  In general these display data to the system log, job log, and system console.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc oss$job_paged_literal
?? POP ??
*copyc dpp$put_critical_message
*copyc osp$unpack_status_condition
*copyc osp$verify_system_privilege
*copyc pmp$get_user_identification
*copyc pmp$get_job_names
?? EJECT ??
*copyc pmp$log_ascii
*copyc osv$control_codes_to_quest_mark
?? OLDTITLE ??
?? NEWTITLE := 'format_text', EJECT ??

  PROCEDURE format_text
    (    page_width: ost$string_size;
     VAR remaining_text: string ( * );
     VAR remaining_text_length: ost$string_size;
     VAR print_line: string ( * );
     VAR print_line_length: ost$string_size);

    IF remaining_text_length <= page_width THEN
      print_line := remaining_text (1, remaining_text_length);
      print_line_length := remaining_text_length;
      remaining_text_length := 0;
    ELSE
      print_line_length := page_width + 1;
      WHILE (print_line_length > 0) AND (remaining_text (print_line_length) <> ' ') DO
        print_line_length := print_line_length - 1;
      WHILEND;

      IF print_line_length = 0 THEN
        print_line := remaining_text (1, page_width);
        print_line_length := page_width;
      ELSE
        print_line_length := print_line_length;
        print_line := remaining_text (1, print_line_length);
      IFEND;

      remaining_text := remaining_text (print_line_length + 1, * );
      remaining_text_length := remaining_text_length - print_line_length;
    IFEND;

  PROCEND format_text;
?? OLDTITLE ??
?? NEWTITLE := 'osp$log_job_recovery_message', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$log_job_recovery_message
    (    text: string ( * );
     VAR status: ost$status);

    CONST
      c$printer_width = 116;

    VAR
      found: boolean,
      local_status: ost$status,
      message_text: string (osc$max_string_size),
      message_text_length: integer,
      space_character: [oss$job_paged_literal, READ] PACKED ARRAY [0 .. 255] OF boolean :=
            [REP 32 of FALSE, TRUE, REP 223 of FALSE],
      user: ost$user_identification,
      user_job_length: integer,
      user_job_name: jmt$user_supplied_name,
      user_length: integer,
      print_line: string (c$printer_width),
      print_line_length: ost$string_size,
      remaining_text: string (osc$max_string_size),
      remaining_text_length: ost$string_size,
      system_job_name: jmt$system_supplied_name;

    status.normal := TRUE;
    osp$verify_system_privilege;

    pmp$get_user_identification (user, local_status);
    pmp$get_job_names (user_job_name, system_job_name, local_status);

    #SCAN (space_character, user.user, user_length, found);
    user_length := user_length - 1;
    #SCAN (space_character, user_job_name, user_job_length, found);
    user_job_length := user_job_length - 1;
    STRINGREP (message_text, message_text_length, user.user (1, user_length), ' ',
          user_job_name (1, user_job_length), ' ', system_job_name, ' ', text);

    remaining_text := message_text;
    remaining_text_length := message_text_length;
    REPEAT
      format_text (c$printer_width, remaining_text, remaining_text_length, print_line, print_line_length);
      pmp$log_ascii (print_line (1, print_line_length), $pmt$ascii_logset [pmc$system_log],
            pmc$msg_origin_system, local_status);
      IF NOT local_status.normal THEN
        status := local_status;
      IFEND;
      pmp$log_ascii (print_line (1, print_line_length), $pmt$ascii_logset [pmc$job_log],
            pmc$msg_origin_system, local_status);
      IF NOT local_status.normal THEN
        status := local_status;
      IFEND;
    UNTIL remaining_text_length = 0;

    dpp$put_critical_message (message_text (1, message_text_length), local_status);

  PROCEND osp$log_job_recovery_message;
?? OLDTITLE ??
?? NEWTITLE := 'osp$log_job_recovery_status', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$log_job_recovery_status
    (    recovery_status: ost$status;
     VAR status: ost$status);

    VAR
      condition_code: ost$status_condition_number,
      condition_identifier: ost$status_identifier,
      local_status: ost$status,
      message_size: integer,
      message_text: string (osc$max_string_size + 12);

    status.normal := TRUE;
    osp$verify_system_privilege;

    osp$unpack_status_condition (recovery_status.condition, condition_identifier, condition_code);
    #TRANSLATE (osv$control_codes_to_quest_mark, recovery_status.text.value (1, recovery_status.text.size),
          local_status.text.value (1, recovery_status.text.size));
    STRINGREP (message_text, message_size, condition_identifier, condition_code, ' ',
          local_status.text.value (1, recovery_status.text.size));
    osp$log_job_recovery_message (message_text (1, message_size), status);

  PROCEND osp$log_job_recovery_status;
?? OLDTITLE ??
MODEND osm$job_recovery_logging;
*DECK DECK=OSM$JOB_TEMPLATE_INITIALIZATION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operating System : Job Template Initialization' ??
MODULE osm$job_template_initialization;


?? NEWTITLE := 'Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc dsc$previous_recovery_type
*copyc jmc$system_family
*copyc jmt$executing_task_entry
*copyc jmt$task_to_execute_entry
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc ost$string
*copyc pfe$internal_error_conditions
*copyc pmt$spy_identifier
*copyc tmt$system_task_id
?? POP ??
*copyc avp$initialize
*copyc avp$validate_job
*copyc clp$create_variable
*copyc clp$log_comment
*copyc clp$operator_intervention
*copyc clp$put_job_output
*copyc clp$scan_command_line
*copyc clp$write_variable
*copyc cme$manage_interface_tables
*copyc cmp$configure_peripheral
*copyc cmp$get_mass_storage_info
*copyc cmp$initialize_dft
*copyc cmp$process_deadstart_signals
*copyc cmp$save_mf_configuration
*copyc cmp$set_post_ds_flag
*copyc dmp$build_sorted_dfl
*copyc dmp$recover_mainframe
*copyc dmp$save_recovery_info
*copyc dfp$recover_client_mainframes
*copyc dfp$recover_server_mainframes
*copyc dsp$advance_deadstart_sequence
*copyc dsp$allow_sys_msg_logging
*copyc dsp$enlarge_sys_msg_buffer
*copyc dsp$exit_deadstart
*copyc dsp$get_data_from_rdf
*copyc dsp$process_deadstart_files
*copyc dsp$recover_mf_wired
*copyc dsp$start_all_cpus
*copyc dsp$store_data_in_rdf
*copyc jmp$define_and_permit_catalogs
*copyc jmp$initialize_job_tables
*copyc jmp$initialize_scheduler_tables
*copyc jmp$initialize_ssn
*copyc jmp$recover_queues
*copyc lgp$install_global_logs
*copyc lgp$recover_global_logs
*copyc lgp$install_engineering_log
*copyc lgp$setup_recovery_logging
*copyc mlp$initialize
*copyc mmp$write_all_segments_to_disk
*copyc nlp$cl_recover_cid_seed
*copyc ocp$define_linker_debug_table
*copyc osp$activate_system_task
*copyc osp$complete_job_recovery
*copyc osp$define_system_task
*copyc osp$generate_message
*copyc osp$recover_executing_jobs
*copyc osp$reset_ptl
*copyc osp$verify_system_privilege
*copyc pfp$overhaul_set
*copyc pfp$recreate_system_catalog
*copyc pmp$delay
*copyc pmp$execute
*copyc pmp$get_date
*copyc pmp$set_spy_identifier
*copyc pmp$zero_out_table
*copyc sfp$init_system_routing_control
*copyc stp$activate_deadstart_sets
*copyc stp$build_family_list_for_set
*copyc stp$change_access_to_set
*copyc stp$initialize_sets
*copyc syp$disable_job_recovery
*copyc syp$display_deadstart_message
*copyc syp$initialize_jt_ptr_array
*copyc syp$initialize_syscore_template
*copyc syp$process_deadstart_status
*copyc syp$recover_executing_ajl_ord
*copyc syp$trace_deadstart_message
*copyc tmp$save_system_task_id
?? EJECT ??
*copyc cmv$logical_unit_table
*copyc dmv$reconcile_locator
*copyc fmv$initial_pdu_pointer
*copyc lgv$global_log_ctl
*copyc lgv$local_log_ctl
*copyc osv$deadstart_phase
*copyc osv$delete_unreconciled_files
*copyc osv$emergency_intervention
*copyc osv$operator_intervention
*copyc osv$reconcile_permanent_files
*copyc osv$recover_system_set_phase
*copyc osv$reorganize_permanent_files
*copyc osv$task_private_heap
*copyc osv$validate_active_sets
*copyc osv$validate_permanent_files
*copyc osv$170_os_type
*copyc rav$deadstart_intervention
*copyc stv$system_set_name
*copyc syv$job_recovery_option
*copyc syv$job_template_name
?? TITLE := 'Global Declarations Declared by this module', EJECT ??

  TYPE
    ost$system_task_id = (job_terminator, mli_helper, zdis, job_sched, job_sched_async,
          administer_device_logs, administer_allocation_logs, volume_space_management);

  VAR
    lgv$modify_log_segments: [XREF] boolean;

  VAR
    dsv$scl_enabled: [XDCL] boolean := FALSE,
    osv$debug_table: [XDCL, #GATE] ^SEQ ( * ) := NIL,
    osv$hang_task: [XDCL, STATIC] boolean := FALSE,
    osv$system_catalog_recreated: [STATIC, oss$task_shared] boolean := FALSE,
    osv$ignore_operator: [XDCL] boolean := FALSE,

    global_statistic_log_keywords: [READ, oss$job_paged_literal] array [1 .. 3] of ost$name := ['ACCOUNT',
          'STATISTIC', 'ENGINEERING'];

?? TITLE := 'phase1_installation', EJECT ??

  PROCEDURE phase1_installation
    (VAR status: ost$status);

    VAR
      date: ost$date,
      date_entry: string (60),
      date_entry_length: integer;

    syp$trace_deadstart_message ('initialize sets');
    stp$initialize_sets (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('initialize sets', TRUE, status);
    IFEND;

    syp$trace_deadstart_message ('pf initialization');
    pfp$overhaul_set (stv$system_set_name, $pft$set_overhaul_choices [], status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('pf initialization', TRUE, status);
    IFEND;

    syp$trace_deadstart_message ('accounting / validation initialize');
    avp$initialize (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('avp initialize', TRUE, status);
    IFEND;

    syp$trace_deadstart_message ('install global logs');
    lgp$install_global_logs (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('install global logs', TRUE, status);
    IFEND;

    dmp$save_recovery_info;

    dsp$advance_deadstart_sequence (dsc$dss_ssr_committed);

    syp$trace_deadstart_message ('initialize global stats');
    sfp$init_system_routing_control (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('initialize global stats', TRUE, status);
    IFEND;

    pmp$get_date (osc$month_date, date, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('initialize global stats', TRUE, status);
    IFEND;
    STRINGREP (date_entry, date_entry_length, '**********  INSTALLATION DEADSTART ON  ', date.month);
    clp$log_comment (date_entry (1, date_entry_length), global_statistic_log_keywords, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('initialize global stats', TRUE, status);
    IFEND;

    syp$trace_deadstart_message ('define and permit catalogs');
    jmp$define_and_permit_catalogs (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('define and permit catalogs', TRUE, status);
    IFEND;

  PROCEND phase1_installation;
?? TITLE := 'phase1_normal', EJECT ??

  PROCEDURE phase1_normal
    (VAR status: ost$status);

    syp$trace_deadstart_message ('setup recovery logging');
    lgp$setup_recovery_logging (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('setup rec logging', TRUE, status);
    IFEND;


    dmp$save_recovery_info;

    dsp$advance_deadstart_sequence (dsc$dss_ssr_committed);

{ ***WARNING*** Dont even think about using perm files here.

  PROCEND phase1_normal;
?? TITLE := 'phase2_installation', EJECT ??

  PROCEDURE phase2_installation
    (VAR status: ost$status);

    VAR
      set_overhaul_choices: pft$set_overhaul_choices;

    syp$trace_deadstart_message ('start multiple processors');
    dsp$start_all_cpus;

    syp$trace_deadstart_message ('configure peripheral environment');
    dsp$advance_deadstart_sequence (dsc$dss_idle_system_core);
    cmp$configure_peripheral (status);
    IF NOT status.normal THEN
      clp$operator_intervention (status);
    IFEND;

{ At this point the number of channels on the system is known so the system message buffer
{ can be enlarged.

    dsp$enlarge_sys_msg_buffer;

    recover_mainframe ({Installation } TRUE);

    dsp$advance_deadstart_sequence (dsc$dss_system_committed);
    syp$trace_deadstart_message ('system committed (installation)');
    cmp$process_deadstart_signals;

{ ********** System committed - installation deadstart *********

{ Build the sorted dfl and activate sets so that a recover system set deadstart
{ with multiple sets present works correctly!  Assume sets require recovery.

    dmp$build_sorted_dfl (stv$system_set_name, dmv$reconcile_locator, status);

    set_overhaul_choices := $pft$set_overhaul_choices [pfc$all_catalogs, pfc$validate_files,
          pfc$reorganize_catalogs, pfc$reconcile_fmds, pfc$recover_purged_files];
    stp$activate_deadstart_sets (set_overhaul_choices, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('activate sets', TRUE, status);
    IFEND;

{ Build the KJL, KOL - minimum sizes are one entry each.  This request must take place after the
{ volume space management task is started

    syp$trace_deadstart_message ('initialize job tables');
    jmp$initialize_job_tables (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('jmp initialize job tables', TRUE, status);
    IFEND;

    syp$trace_deadstart_message ('initialize scheduler tables');
    jmp$initialize_scheduler_tables (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('jmp initialize scheduler tables', TRUE, status);
    IFEND;

  PROCEND phase2_installation;
?? TITLE := 'phase2_normal', EJECT ??

  PROCEDURE phase2_normal
    (VAR status: ost$status);

    VAR
      date: ost$date,
      local_status: ost$status,
      reconcile_permanent_files: boolean,
      recovery_type: string (8),
      recovery_type_seq_p: ^SEQ ( * ),
      set_overhaul_choices: pft$set_overhaul_choices,
      swap_file_recovery_list_p: ^jmt$swap_file_recovery_list,
      swap_file_recovery_list_count: jmt$job_count_range,
      text: string (78),
      text_length: integer,
      validate_active_sets: boolean;

    syp$trace_deadstart_message ('start multiple processors');
    dsp$start_all_cpus;

    syp$trace_deadstart_message ('configure peripheral environment');
    dsp$advance_deadstart_sequence (dsc$dss_idle_system_core);
    cmp$configure_peripheral (status);
    IF NOT status.normal THEN
      clp$operator_intervention (status);
    IFEND;

{ At this point the number of channels on the system is known so the system message buffer
{ can be enlarged.

    dsp$enlarge_sys_msg_buffer;

    syp$trace_deadstart_message ('change access to set');
    stp$change_access_to_set (stv$system_set_name, stc$allow_access, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('change access to set', TRUE, status);
    IFEND;

    recover_mainframe ({Installation } FALSE);

    IF osv$emergency_intervention THEN
      clp$put_job_output (' Emergency Intervention', status);
      clp$operator_intervention (status);
    IFEND;

{ The next NLP$ call must be made before system commit.
    nlp$cl_recover_cid_seed;

{ Go recover the ajls of job/jobs executing at time of failure.
    syp$recover_executing_ajl_ord;

    pfp$recreate_system_catalog (status);
    IF NOT status.normal THEN
      IF status.condition = pfe$system_catalog_recreated THEN
        syp$trace_deadstart_message ('$SYSTEM master catalog recreated.');
        status.normal := TRUE;
        osv$system_catalog_recreated := TRUE;
      ELSE
        syp$process_deadstart_status ('Recreate system master catalog', TRUE, status);
      IFEND;
    IFEND;

    syp$trace_deadstart_message ('build dm/pf reconciliation list');
    dmp$build_sorted_dfl (stv$system_set_name, dmv$reconcile_locator, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Build dm/pf reconciliation list.', TRUE, status);
    IFEND;

{ Build the KJL, KOL.  This request must take place after the volume space management task is started.

    syp$trace_deadstart_message ('initialize job tables');
    jmp$initialize_job_tables (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('jmp initialize job tables', TRUE, status);
    IFEND;

{ Build the scheduler tables.  This request must take place before active jobs are recovered.

    syp$trace_deadstart_message ('initialize scheduler tables');
    jmp$initialize_scheduler_tables (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('jmp initialize scheduler tables', TRUE, status);
    IFEND;

{ NOTE: This call must always be made before system commit and job sched start.

    syp$trace_deadstart_message ('reconcile active jobs');
    osp$recover_executing_jobs (swap_file_recovery_list_p, swap_file_recovery_list_count, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('WARNING -- Job recovery not possible', FALSE, status);
      syp$disable_job_recovery;
      status.normal := TRUE;
    IFEND;
    cmp$set_post_ds_flag;
    dsp$advance_deadstart_sequence (dsc$dss_system_committed);
    syp$trace_deadstart_message ('system committed (normal)');

{ ********** System committed - normal (continuation) deadstart **********

    recovery_type_seq_p := #SEQ (recovery_type);
    dsp$get_data_from_rdf (dsc$rdf_previous_recovery_type, dsc$rdf_production, recovery_type_seq_p);
    IF (recovery_type = dsc$recovery_without_image) AND NOT osv$validate_active_sets THEN
      syp$trace_deadstart_message ('pf recovery is required due to missing image');
      validate_active_sets := TRUE;
    ELSE
      validate_active_sets := osv$validate_active_sets;
    IFEND;

    reconcile_permanent_files := osv$reconcile_permanent_files OR osv$reorganize_permanent_files OR
          osv$delete_unreconciled_files;

    set_overhaul_choices := $pft$set_overhaul_choices [];
    IF osv$validate_permanent_files OR reconcile_permanent_files OR validate_active_sets THEN
      syp$trace_deadstart_message ('pf recovery');

      set_overhaul_choices := $pft$set_overhaul_choices [pfc$all_catalogs];
      IF syv$job_recovery_option = syc$jre_enabled THEN
        syp$trace_deadstart_message ('- job recovery');
        set_overhaul_choices := set_overhaul_choices + $pft$set_overhaul_choices [pfc$recover_purged_files];
      IFEND;

      IF osv$validate_permanent_files OR validate_active_sets THEN
        syp$trace_deadstart_message ('- validate_permanent_files');
        set_overhaul_choices := set_overhaul_choices + $pft$set_overhaul_choices [pfc$validate_files];
      IFEND;

      IF osv$reorganize_permanent_files OR validate_active_sets THEN
        syp$trace_deadstart_message ('- reorganize_permanent_files');
        set_overhaul_choices := set_overhaul_choices + $pft$set_overhaul_choices [pfc$reorganize_catalogs];
      IFEND;

      IF reconcile_permanent_files OR validate_active_sets THEN
        syp$trace_deadstart_message ('- reconcile_permanent_files');
        set_overhaul_choices := set_overhaul_choices + $pft$set_overhaul_choices [pfc$reconcile_fmds];
      IFEND;

      IF osv$delete_unreconciled_files THEN
        syp$trace_deadstart_message ('- delete_unreconciled_files');
        set_overhaul_choices := set_overhaul_choices + $pft$set_overhaul_choices
              [pfc$delete_unreconciled_objects];
      IFEND;

      pfp$overhaul_set (stv$system_set_name, set_overhaul_choices, status);
      IF NOT status.normal THEN
        IF status.condition = pfe$recovery_summary THEN
          status.normal := TRUE;
        ELSE
          syp$process_deadstart_status ('pf recovery', TRUE, status);
        IFEND;
      IFEND;
    IFEND;

    recovery_type := dsc$recovery_completed_normally;
    dsp$store_data_in_rdf (dsc$rdf_previous_recovery_type, dsc$rdf_production, #SEQ (recovery_type));

    stp$build_family_list_for_set (stv$system_set_name,
          {activating_during_deadstart=} TRUE, {defer_input_queue} FALSE, status);

    stp$activate_deadstart_sets (set_overhaul_choices, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('activate sets', TRUE, status);
    IFEND;

    IF osv$emergency_intervention THEN
      clp$put_job_output (' Emergency Intervention', status);
      clp$operator_intervention (status);
    IFEND;

    syp$trace_deadstart_message ('accounting / validation initialize');
    avp$initialize (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('avp initialize', TRUE, status);
    IFEND;

    syp$trace_deadstart_message ('recover global logs');
    lgp$recover_global_logs (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('rec global logs', TRUE, status);
    IFEND;
    IF lgv$modify_log_segments THEN
     syp$trace_deadstart_message ('modifying log segments');
      lgp$install_eng_log (status);
    IFEND;

    syp$trace_deadstart_message ('initialize global stats');
    sfp$init_system_routing_control (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('initialize global stats', TRUE, status);
    IFEND;
    pmp$get_date (osc$month_date, date, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('initializ global stats', TRUE, status);
    IFEND;
    STRINGREP (text, text_length, '**********  RECOVERY DEADSTART ON  ', date.month);
    clp$log_comment (text (1, text_length), global_statistic_log_keywords, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('initializ global stats', TRUE, status);
    IFEND;

{ This request verifies that the input/output/swap queues exist and have the current permits.
{ PF recovery may, potentially, delete the queues.

    jmp$define_and_permit_catalogs (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('define and permit catalogs', FALSE, status);
    IFEND;

{ Recover the input and output queues.

    syp$trace_deadstart_message ('recover queues');
    jmp$recover_queues (swap_file_recovery_list_p, swap_file_recovery_list_count, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('error in queue recovery', FALSE, status);
    IFEND;

    dfp$recover_client_mainframes (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('error in file server client recovery', FALSE, status);
      status.normal := TRUE;
    IFEND;

    cmp$process_deadstart_signals;

  PROCEND phase2_normal;

?? TITLE := 'recover_mainfame', EJECT ??

  PROCEDURE recover_mainframe (installation: boolean);

    VAR
      status: ost$status;

{ All system tasks that run and terminate must be completed by now.  Re-initialize
{ the PTL and DCT free queue pointers. This is in case we need to perform job
{ recovery later.  Since there can be any number of tasks that run and terminate
{ before this point (in particular PCU/LCU) there is no way to know what taskid (PTL
{ ordinal) the following tasks will receive.  If they get different taskids then
{ what they had on the previous deadstart, it is possible that a recovering task
{ would have the same taskid as the new one assigned.

    osp$reset_ptl;

    syp$trace_deadstart_message ('start volume space management task');
    start_system_task (volume_space_management);

    dsp$recover_mf_wired;

    dsp$advance_deadstart_sequence (dsc$dss_recover_mainframe);

    dmp$recover_mainframe (status);

    IF status.normal THEN
      IF NOT installation THEN
        dfp$recover_server_mainframes (status);
        IF NOT status.normal THEN
          syp$process_deadstart_status ('error in file server server recovery', FALSE, status);
        IFEND;
      IFEND;

      dsp$advance_deadstart_sequence (dsc$dss_mainframe_recovered);
      dsp$advance_deadstart_sequence (dsc$dss_recovery_completed);
    ELSE
      syp$process_deadstart_status ('recover mainframe', TRUE, status);
    IFEND;

    syp$trace_deadstart_message ('start admin device log task');
    start_system_task (administer_device_logs);

    syp$trace_deadstart_message ('start admin allocation log task');
    start_system_task (administer_allocation_logs);

  PROCEND recover_mainframe;
?? TITLE := 'start_system_task', EJECT ??

  PROCEDURE start_system_task
    (    task: ost$system_task_id);

    VAR
      execute_status: ost$status,
      executing_task_p: ^jmt$executing_task_entry,
      ignore_status: ost$status,
      program_attributes: pmt$program_attributes,
      program_attributes_seq_p: ^SEQ ( * ),
      spy_id: [STATIC, READ, oss$job_paged_literal] array [ost$system_task_id] of pmt$spy_identifier :=
            [0, 53, 0, 54, 0, 55, 56, 57],
      task_param: SEQ (boolean),
      task_to_execute: [STATIC, READ, oss$job_paged_literal] array [ost$system_task_id] of
            jmt$task_to_execute_entry := [['JMP$JOB_TERMINATOR_ENTRY_POINT', TRUE, TRUE, FALSE],
            ['MLP$INVOKE_MLI_HELPER', TRUE, FALSE, FALSE], ['JMP$ZDIS_ENTRY_POINT', TRUE, FALSE, TRUE],
            ['JMP$JOB_SCHEDULER_ENTRY_POINT', TRUE, FALSE, FALSE],
            ['JMP$JOB_SCHED_ASYNC_ENTRY_PT', TRUE, FALSE, FALSE],
            ['DMP$ADMINISTER_DEVICE_LOG', TRUE, TRUE, TRUE], ['DMP$ADMINISTER_ALLOCATION_LOG', TRUE, TRUE,
            TRUE], ['DMP$VOLUME_SPACE_MANAGEMENT', TRUE, TRUE, TRUE]];

    ALLOCATE executing_task_p IN osv$task_private_heap^;
    pmp$zero_out_table (#LOC (executing_task_p^), #SIZE (executing_task_p^));

    executing_task_p^.task_name := task_to_execute [task].task_name;

    program_attributes.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$load_map_options_specified, pmc$term_error_level_specified];
    program_attributes.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    program_attributes.termination_error_level := pmc$warning_load_errors;
    program_attributes.starting_procedure := executing_task_p^.task_name;

    pmp$set_spy_identifier (spy_id [task], 0, ignore_status);

    program_attributes_seq_p := #SEQ (program_attributes);
    pmp$execute (program_attributes_seq_p^, task_param, osc$nowait, executing_task_p^.task_id,
          executing_task_p^.task_status, execute_status);

    IF NOT execute_status.normal THEN
      syp$process_deadstart_status ('Execute system task.', TRUE, execute_status);
    IFEND;

    pmp$set_spy_identifier (0, 0, ignore_status);

  PROCEND start_system_task;
?? TITLE := 'osp$get_job_template_name', EJECT ??

{ PURPOSE:
{   This procedure provides access to the "job template name" for the current job for code
{   running above ring 3.

  PROCEDURE [XDCL, #GATE] osp$get_job_template_name
    (VAR job_template_name: ost$name);

    job_template_name := syv$job_template_name;

  PROCEND osp$get_job_template_name;
?? TITLE := 'osp$initialize_sc_debugger', EJECT ??

{ PURPOSE:
{   The purpose of this routine is to initialize the system core debugger environment for this job.
{   It is called once for the NOS/VE job template during deadstart and once per job for other job templates.

  PROCEDURE [XDCL] osp$initialize_sc_debugger;

    VAR
      jt_debug_pointers_p: ^array [1 .. * ] of ^cell,
      local_status: ost$status;

    PUSH jt_debug_pointers_p: [1 .. 4];
    jt_debug_pointers_p^ [1] := #LOC (lgv$local_log_ctl);
    jt_debug_pointers_p^ [2] := #LOC (lgv$global_log_ctl);
    jt_debug_pointers_p^ [3] := #LOC (osv$hang_task);
    jt_debug_pointers_p^ [4] := #LOC (fmv$initial_pdu_pointer);
    syp$initialize_jt_ptr_array (jt_debug_pointers_p);
    ocp$define_linker_debug_table (osv$debug_table, local_status);

  PROCEND osp$initialize_sc_debugger;
?? TITLE := 'osp$job_template_init_ph1', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$job_template_init_ph1;

    VAR
      intervention_array: array [1 .. 1] of clt$boolean,
      intervention_scope: clt$variable_scope,
      intervention_variable: clt$variable_reference,
      phase_array: array [1 .. 2 {#SIZE(ost$string_size)} + osc$max_name_size] of cell,
      phase_scope: clt$variable_scope,
      phase_string: record
        size: ost$string_size,
        value: ost$name,
      recend,
      phase_variable: clt$variable_reference,
      reinitialize_array: array [1 .. 1] of clt$boolean,
      reinitialize_scope: clt$variable_scope,
      reinitialize_variable: clt$variable_reference,
      status: ost$status;

    tmp$save_system_task_id (tmc$stid_job_monitor, TRUE, status);

    osp$verify_system_privilege;

    dsp$advance_deadstart_sequence (dsc$dss_job_template_started);

    osp$initialize_sc_debugger;
    syp$initialize_syscore_template;

    CASE osv$deadstart_phase OF
    = osc$installation_deadstart =
      phase_string.size := 7;
      phase_string.value := 'INSTALL';
    = osc$recovery_deadstart, osc$normal_deadstart =
      phase_string.size := 6;
      phase_string.value := 'NORMAL';
    ELSE
      phase_string.size := 0;
      phase_string.value := '';
    CASEND;

{ Create the SCL variable for deadstart phase.

    #UNCHECKED_CONVERSION (phase_string, phase_array);
    phase_scope.kind := clc$job_variable;
    clp$create_variable ('OSV$DEADSTART_PHASE', clc$string_value, osc$max_name_size, 1, 1, phase_scope,
          phase_variable, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Create osv$deadstart_phase cl variable.', TRUE, status);
    IFEND;
    phase_variable.value.string_value := ^phase_array;
    clp$write_variable ('OSV$DEADSTART_PHASE', phase_variable.value, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Initialize osv$deadstart_phase cl variable.', TRUE, status);
    IFEND;

{ Create the SCL variable for operator intervention.

    intervention_scope.kind := clc$job_variable;
    clp$create_variable ('OSV$OPERATOR_INTERVENTION', clc$boolean_value, 0, 1, 1, intervention_scope,
          intervention_variable, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Create osv$operator_intervention cl variable.', TRUE, status);
    IFEND;
    intervention_array [1].kind := clc$true_false_boolean;
    intervention_array [1].value := osv$operator_intervention;
    intervention_variable.value.boolean_value := ^intervention_array;
    clp$write_variable ('OSV$OPERATOR_INTERVENTION', intervention_variable.value, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Initialize osv$operator_intervention cl variable.', TRUE, status);
    IFEND;

{ Create the SCL variable for system_deadstart_prolog to determine if this is an installation deadstart
{ where the system device is reinitialized.

    reinitialize_scope.kind := clc$job_variable;
    clp$create_variable ('OSV$REINITIALIZE_SYSTEM_DEVICE', clc$boolean_value, 0, 1, 1, reinitialize_scope,
          reinitialize_variable, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Create osv$reinitialize_system_device cl variable.', TRUE, status);
    IFEND;
    reinitialize_array [1].kind := clc$true_false_boolean;
    reinitialize_array [1].value := (osv$recover_system_set_phase = osc$reinitialize_system_device);
    reinitialize_variable.value.boolean_value := ^reinitialize_array;
    clp$write_variable ('OSV$REINITIALIZE_SYSTEM_DEVICE', reinitialize_variable.value, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Initialize osv$reinitiaize_system_device cl variable>', TRUE, status);
    IFEND;

    syp$trace_deadstart_message ('initializing cm device file table');
    cmp$initialize_dft (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Initialize cm device file table failed.', TRUE, status);
    IFEND;

    CASE osv$deadstart_phase OF
    = osc$installation_deadstart =
      phase1_installation (status);
    = osc$recovery_deadstart, osc$normal_deadstart =
      phase1_normal (status);
    ELSE
      syp$process_deadstart_status ('Bad deadstart phase.', TRUE, status);
    CASEND;

    dsp$advance_deadstart_sequence (dsc$dss_load_sitecp);
    dsp$process_deadstart_files ('MF_CONFIG_EPILOG ', FALSE);
    dsp$advance_deadstart_sequence (dsc$dss_sitecp_loaded);

    syp$trace_deadstart_message ('writing all segments to disk');
    mmp$write_all_segments_to_disk (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Write all segments failed.', TRUE, status);
    IFEND;

    dsv$scl_enabled := TRUE;
    pmp$delay (1000, status);

  PROCEND osp$job_template_init_ph1;
?? TITLE := 'osp$job_template_init_ph2', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$job_template_init_ph2
    (VAR deadstart_intervention: boolean;
     VAR deadstart_phase: ost$deadstart_phase);

    VAR
      count: integer,
      define_status: ost$status,
      index: integer,
      msi: cmt$mass_storage_information,
      parameters_p: ^pmt$program_parameters,
      program_attributes: llt$program_attributes,
      status: ost$status,
      task_name: ost$name;

    osp$verify_system_privilege;

    status.normal := TRUE;

    CASE osv$deadstart_phase OF
    = osc$installation_deadstart =
      phase2_installation (status);
      IF NOT status.normal THEN
        syp$process_deadstart_status ('Phase 2 installation', true, status);
      IFEND;
    = osc$recovery_deadstart, osc$normal_deadstart =
      phase2_normal (status);
      IF NOT status.normal THEN
        syp$process_deadstart_status ('Phase 2 normal', true, status);
      IFEND;
    ELSE
      syp$process_deadstart_status ('Bad ds phase in jti.', TRUE, status);
    CASEND;

    jmp$initialize_ssn (osv$deadstart_phase, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('initialize ssn', TRUE, status);
    IFEND;

{ Turn on the ability to log system messages into the engineering log.  This procedure MUST not be called
{ until the global statistics are initialized.

    dsp$allow_sys_msg_logging;

{ Activate the system display manager task.

    program_attributes.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$load_map_options_specified, pmc$term_error_level_specified];
    program_attributes.starting_procedure := 'OFP$SYSTEM_DISPLAY_MANAGER';
    program_attributes.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    program_attributes.termination_error_level := pmc$warning_load_errors;
    task_name := 'OPERATOR_DISPLAY_MANAGER';
    PUSH parameters_p: [[REP 1 OF cell]];
    osp$define_system_task (task_name, TRUE {auto restart} , osc$tt_ignore_or_prohibited
          {deactivate option} , osc$tt_ignore_or_prohibited {idle option} , FALSE {restart after idle} ,
          0 {spy_identifier} , osc$user_ring {execution_ring} , #SEQ (program_attributes), parameters_p,
          define_status);
    osp$activate_system_task (task_name, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Activate system display manager task.', TRUE, status);
    IFEND;

{ Activate the critical window manager task.

    program_attributes.starting_procedure := 'OFP$CRITICAL_WINDOW_MANAGER';
    task_name := 'CRITICAL_WINDOW_MANAGER';
    osp$define_system_task (task_name, TRUE {auto restart} , osc$tt_ignore_or_prohibited
          {deactivate option} , osc$tt_ignore_or_prohibited {idle option} , TRUE {restart after idle} ,
          0 {spy_identifier} , osc$user_ring {execution_ring} , #SEQ (program_attributes), parameters_p,
          define_status);
    osp$activate_system_task (task_name, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Activate critical window manager task.', TRUE, status);
    IFEND;

{ Activate the sweep disk units task.

    count := 0;

  /count_sweep_candidates/
    FOR index := LOWERBOUND (cmv$logical_unit_table^) TO UPPERBOUND (cmv$logical_unit_table^) DO
      IF cmv$logical_unit_table^ [index].configured THEN
        cmp$get_mass_storage_info (cmv$logical_unit_table^ [index].logical_unit_number, msi, status);
        IF NOT status.normal THEN
          CYCLE /count_sweep_candidates/;
        IFEND;
        CASE msi.unit_type OF
        = cmc$ms885_1x, cmc$ms885_4x, cmc$ms834_2, cmc$msfsd_2 =
          count := count + 1;
        ELSE
        CASEND;
      IFEND;
    FOREND /count_sweep_candidates/;

    IF count <> 0 THEN
      program_attributes.starting_procedure := 'IOP$SWEEP_DISK_UNITS';
      task_name := 'SWEEP_DISK_UNITS';
      osp$define_system_task (task_name, TRUE {auto restart} , osc$tt_ignore_or_prohibited
            {deactivate option} , osc$tt_terminate {idle option} , TRUE {restart after idle} , 0
            {spy_identifier} , osc$user_ring {execution_ring} , #SEQ (program_attributes), parameters_p,
            define_status);
      osp$activate_system_task (task_name, status);
      IF NOT status.normal THEN
        syp$process_deadstart_status ('Activate the sweep disk units task.', TRUE, status);
      IFEND;
    IFEND;

{ Activate the DAS head shift testing task.

    count := 0;

  /count_test_candidates/
    FOR index := LOWERBOUND (cmv$logical_unit_table^) TO UPPERBOUND (cmv$logical_unit_table^) DO
      IF cmv$logical_unit_table^ [index].configured THEN
        cmp$get_mass_storage_info (cmv$logical_unit_table^ [index].logical_unit_number, msi, status);
        IF NOT status.normal THEN
          IF (status.condition = cme$it_not_cip_device) OR
                (status.condition = cme$it_no_cip_access) OR
                (status.condition = cme$it_unusable_cip_access) THEN
            ;
          ELSE
            CYCLE /count_test_candidates/;
          IFEND;
        IFEND;
        CASE msi.unit_type OF
        = cmc$ms5833_1, cmc$ms5833_1p, cmc$ms5833_2, cmc$ms5833_3p, cmc$ms5833_4 =
          count := count + 1;
        ELSE
        CASEND;
      IFEND;
    FOREND /count_test_candidates/;

    IF count <> 0 THEN
      program_attributes.starting_procedure := 'IOP$DAS_HEAD_SHIFT_TEST';
      task_name := 'DAS_HEAD_SHIFT_TEST';
      osp$define_system_task (task_name, TRUE {auto restart} , osc$tt_ignore_or_prohibited
            {deactivate option} , osc$tt_terminate {idle option} , TRUE {restart after idle} , 0
            {spy_identifier} , osc$user_ring {execution_ring} , #SEQ (program_attributes), parameters_p,
            define_status);
      osp$activate_system_task (task_name, status);
      IF NOT status.normal THEN
        syp$process_deadstart_status ('Activate the DAS head shift testing task.', TRUE, status);
      IFEND;
    IFEND;

    syp$trace_deadstart_message ('av validate job');
    avp$validate_job (jmc$system_user, jmc$system_family, osc$null_name, osc$null_name, NIL, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('avp validate job', TRUE, status);
    IFEND;

    IF osv$170_os_type <> osc$ot7_none THEN
      syp$trace_deadstart_message ('mli init');
      mlp$initialize (status);
      IF NOT status.normal THEN
        syp$process_deadstart_status ('mlp init', TRUE, status);
      IFEND;
    IFEND;

    syp$trace_deadstart_message ('start job sched task');
    start_system_task (job_sched);

    deadstart_phase := osv$deadstart_phase;
    deadstart_intervention := rav$deadstart_intervention;

    dsp$advance_deadstart_sequence (dsc$dss_load_dstape_libraries);
    dsp$process_deadstart_files ('PRODUCT_EPILOG   ', TRUE);
    dsp$advance_deadstart_sequence (dsc$dss_dstape_libraries_loaded);

  PROCEND osp$job_template_init_ph2;
?? TITLE := 'osp$job_template_init_ph3', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$job_template_init_ph3;

    VAR
      define_status: ost$status,
      parameters_p: ^pmt$program_parameters,
      program_attributes: llt$program_attributes,
      local_status: ost$status,
      recovery_type: string (8),
      rss_command: string (85),
      status: ost$status,
      task_name: ost$name;

    osp$verify_system_privilege;

    status.normal := TRUE;

{ Activate the Tape Scanner task.

    program_attributes.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$load_map_options_specified, pmc$term_error_level_specified];
    program_attributes.starting_procedure := 'IOP$TAPE_SCANNER_EP';
    program_attributes.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    program_attributes.termination_error_level := pmc$warning_load_errors;
    task_name := 'TAPE_SCANNER';
    PUSH parameters_p: [[REP 1 OF cell]];
    osp$define_system_task (task_name, TRUE {auto restart} , osc$tt_ignore_or_prohibited
          {deactivate option} , osc$tt_ignore_or_prohibited {idle option} , FALSE {restart after idle} , 0
          {spy_identifier} , osc$user_ring {execution_ring} , #SEQ (program_attributes), parameters_p,
          define_status);
    osp$activate_system_task (task_name, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Activate the tape scanner task.', TRUE, status);
    IFEND;

    IF (osv$deadstart_phase <> osc$installation_deadstart) THEN
      syp$display_deadstart_message ('Begin job reconciliation ...');
      osp$complete_job_recovery (status);
      IF NOT status.normal THEN
        syp$process_deadstart_status ('WARNING -- Job recovery not possible', FALSE, status);
        syp$disable_job_recovery;
        status.normal := TRUE;
      IFEND;
    IFEND;

    cmp$save_mf_configuration (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('WARNING -- Update of $system.mainframe.configuration failed', FALSE,
            status);
      status.normal := TRUE;
    IFEND;

    IF osv$170_os_type <> osc$ot7_none THEN
      syp$trace_deadstart_message ('start mli helper task');
      start_system_task (mli_helper);
    IFEND;

    cmp$set_post_ds_flag;
    dsp$exit_deadstart (dsc$run_ve);
    dsp$advance_deadstart_sequence (dsc$dss_deadstart_completed);

    IF (osv$recover_system_set_phase = osc$reinitialize_system_device) OR osv$system_catalog_recreated THEN
      clp$scan_command_line ('change_file_attributes $local.osf$ds_library ra=(3 13 13)', status);
      IF NOT status.normal THEN
        osp$generate_message (status, local_status);
      IFEND;
      rss_command (1, 54) := '$local.osf$ds_library.pfp$recover_system_set set_name=';
      rss_command (55, 31) := stv$system_set_name;
      clp$scan_command_line (rss_command (1, 85), status);
      IF NOT status.normal THEN
        osp$generate_message (status, local_status);
      IFEND;
      recovery_type := dsc$recovery_without_image;
      dsp$store_data_in_rdf (dsc$rdf_previous_recovery_type, dsc$rdf_production, #SEQ (recovery_type));
    IFEND;

  PROCEND osp$job_template_init_ph3;
MODEND osm$job_template_initialization;
*DECK DECK=OSM$JOB_TEMPLATE_MANAGEMENT EXPAND=TRUE
MODULE osm$job_template_management;
?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc ost$name
*copyc osp$set_status_abnormal
*copyc fsp$open_file
*copyc fsp$close_file
*copyc amp$get_segment_pointer
*copyc clp$scan_parameter_list
*copyc clp$get_value
*copyc clp$get_set_count
*copyc jmp$determine_job_class
*copyc jmp$determine_job_class_name
*copyc syp$activate_job_template
*copyc syp$deactivate_job_template
*copyc osd$virtual_address
*copyc mmp$set_access_selections
*copyc jmp$system_job
*copyc sye$job_template_conditions
*copyc syv$user_templates
*copyc jme$queued_file_conditions
*copyc syp$set_job_debug_ring
?? POP ??

 {The purpose of this module is to provide job template support
 {for multiple job templates.  The interfaces are only available
 {to the system job.


?? TITLE := 'PROCEDURE osp$activate_job_template' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$activate_job_template
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT     activate_job_template (template_file, tf: file = $required
{           template_name, tn: name = $required
{           job_classes, jc: list of name = $required
{           job_unique_segments, jus: list of integer 0 .. 4095 = (4, 6)
{           task_unique_segments, tus: list of integer 0 .. 4095 = 5
{           status: var of status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    activate_job_template: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
  ^activate_job_template_names, ^activate_job_template_params];

  VAR
    activate_job_template_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 11] of
  clt$parameter_name_descriptor := [['TEMPLATE_FILE', 1], ['TF', 1], ['TEMPLATE_NAME', 2], ['TN', 2], [
  'JOB_CLASSES', 3], ['JC', 3], ['JOB_UNIQUE_SEGMENTS', 4], ['JUS', 4], ['TASK_UNIQUE_SEGMENTS', 5], ['TUS', 5
  ], ['STATUS', 6]];

  VAR
    activate_job_template_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 6] of
  clt$parameter_descriptor := [

{ TEMPLATE_FILE TF }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ TEMPLATE_NAME TN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ JOB_CLASSES JC }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
  osc$max_name_size]],

{ JOB_UNIQUE_SEGMENTS JUS }
    [[clc$optional_with_default, ^activate_job_template_dv4], 1, clc$max_value_sets,1, 1,
  clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 4095]],

{ TASK_UNIQUE_SEGMENTS TUS }
    [[clc$optional_with_default, ^activate_job_template_dv5], 1, clc$max_value_sets,1, 1,
  clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 4095]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    activate_job_template_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (6) := '(4, 6)';

  VAR
    activate_job_template_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '5';

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      ao: ^fst$attachment_options,
      i,
      j,
      k: integer,
      number_of_classes,
      number_of_segments: 0 .. clc$max_value_sets,
      job_classes: ^array [1 .. * ] of ost$name,
      job_class: jmt$job_class,
      job_class_name: jmt$job_class_name,
      file_identifier: amt$file_identifier,
      segment_pointer: amt$segment_pointer,
      template_file: ^SEQ ( * ),
      local_status: ost$status,
      job_unique_segments,
      task_unique_segments: ost$segment_set,
      template_name: ost$name,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, activate_job_template, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (NOT jmp$system_job ()) AND (NOT syv$user_templates) THEN
      osp$set_status_abnormal ('JM', jme$must_be_system_job, 'osp$activate_job_template', status);
      RETURN;
    IFEND;

    clp$get_value ('TEMPLATE_FILE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH ao: [1 .. 2];
    ao^ [1].selector := fsc$access_and_share_modes;
    ao^ [1].access_modes.selector := fsc$specific_access_modes;
    ao^ [1].access_modes.value := $fst$file_access_options [fsc$read];
    ao^ [1].share_modes.selector := fsc$specific_share_modes;
    ao^ [1].share_modes.value := $fst$file_access_options [fsc$read];
    ao^ [2].selector := fsc$create_file;
    ao^ [2].create_file := FALSE;

    fsp$open_file (value.file.local_file_name, amc$segment, ao, NIL, NIL, NIL,
          NIL, file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /file_open/
    BEGIN
      amp$get_segment_pointer (file_identifier, amc$sequence_pointer, segment_pointer,
            status);
      IF NOT status.normal THEN
        EXIT /file_open/;
      IFEND;
      template_file := segment_pointer.sequence_pointer;

      clp$get_value ('TEMPLATE_NAME', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /file_open/;
      IFEND;
      template_name := value.name.value;

      clp$get_set_count ('JOB_CLASSES', number_of_classes, status);
      IF NOT status.normal THEN
        EXIT /file_open/;
      IFEND;

      IF number_of_classes <= 0 THEN
        osp$set_status_abnormal (syc$system_core_id, sye$not_enough_classes, '', status);
        EXIT /file_open/;
      IFEND;

      PUSH job_classes: [1 .. number_of_classes];

      FOR i := 1 TO number_of_classes DO
        clp$get_value ('JOB_CLASSES', i, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /file_open/;
        IFEND;
        jmp$determine_job_class (value.name.value, job_class, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        jmp$determine_job_class_name (job_class, job_class_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        job_classes^ [i] := job_class_name;
      FOREND;

      clp$get_set_count ('JOB_UNIQUE_SEGMENTS', number_of_segments, status);
      IF NOT status.normal THEN
        EXIT /file_open/;
      IFEND;

      job_unique_segments := $ost$segment_set [];
      FOR i := 1 TO number_of_segments DO
        clp$get_value ('JOB_UNIQUE_SEGMENTS', i, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /file_open/;
        IFEND;
        job_unique_segments := job_unique_segments + $ost$segment_set
              [value.int.value];
      FOREND;

      clp$get_set_count ('TASK_UNIQUE_SEGMENTS', number_of_segments, status);
      IF NOT status.normal THEN
        EXIT /file_open/;
      IFEND;

      task_unique_segments := $ost$segment_set [];
      FOR i := 1 TO number_of_segments DO
        clp$get_value ('TASK_UNIQUE_SEGMENTS', i, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /file_open/;
        IFEND;
        task_unique_segments := task_unique_segments + $ost$segment_set
              [value.int.value];
      FOREND;

      mmp$set_access_selections (#ADDRESS (3, #SEGMENT (template_file), 0),
            mmc$as_sequential, status);

      syp$activate_job_template (template_file, template_name,
            job_unique_segments, task_unique_segments, job_classes, status);

    END /file_open/;

    fsp$close_file (file_identifier, local_status);
    IF status.normal THEN
      status := local_status;
    IFEND;

  PROCEND osp$activate_job_template;
?? TITLE := 'PROCEDURE osp$deactivate_job_template' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$deactivate_job_template
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PDT     deactivate_job_template (template_name, tn: name = $required
{             status: var of status)

?? PUSH (LISTEXT := ON) ??

  VAR
    deactivate_job_template: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^deactivate_job_template_names, ^deactivate_job_template_params];

  VAR
    deactivate_job_template_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['TEMPLATE_NAME', 1], ['TN', 1], ['STATUS', 2]];

  VAR
    deactivate_job_template_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
      clt$parameter_descriptor := [

{ TEMPLATE_NAME TN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
    VAR
      template_name: ost$name,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, deactivate_job_template, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (NOT jmp$system_job ()) AND (NOT syv$user_templates) THEN
      osp$set_status_abnormal ('JM', jme$must_be_system_job, 'osp$deactivate_job_template', status);
      RETURN;
    IFEND;

    clp$get_value ('TEMPLATE_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    template_name := value.name.value;

    syp$deactivate_job_template (template_name, status);

  PROCEND osp$deactivate_job_template;

?? TITLE := 'PROCEDURE osp$set_job_debug_ring_cmd' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$set_job_debug_ring_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT setjdr_pdt (job_debug_ring, jdr: integer 0 .. 15 = $required
{       status)

?? PUSH (LISTEXT := ON) ??

    VAR
      setjdr_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^setjdr_pdt_names, ^setjdr_pdt_params];

    VAR
      setjdr_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array
            [1 .. 3] of clt$parameter_name_descriptor :=
            [['JOB_DEBUG_RING', 1], ['JDR', 1], ['STATUS', 2]];

    VAR
      setjdr_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ JOB_DEBUG_RING JDR }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$integer_value, 0, 15]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed,
            clc$status_value]]];

?? POP ??

    VAR
      value: clt$value;

    clp$scan_parameter_list (parameter_list, setjdr_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    status.normal := TRUE;
    IF NOT syv$user_templates THEN
      RETURN;
    IFEND;

    clp$get_value ('JOB_DEBUG_RING', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    syp$set_job_debug_ring (value.int.value);

  PROCEND osp$set_job_debug_ring_cmd;
MODEND osm$job_template_management
*DECK DECK=OSM$KEYPOINT_DESCRIPTION_FILE EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
MODULE keypoint_description_file;
*copyc OSK$COMMON_KEYPOINT_DEFINITIONS
{$$$ START KEYPOINT CLASSES $$$}
*copyc OSK$KEYPOINT_CLASS_CODES
{$$$ END KEYPOINT CLASSES $$$}
{$$$ START KEYPOINT IDENTIFIER BASES $$$}
*copyc AMK$BASE_KEYPOINT_VALUES
{$$$ END KEYPOINT IDENTIFIER BASES $$$}
{$$$ START KEYPOINT DESCRIPTIONS $$$}
*copyc AMK$ACCESS_METHOD
*copyc BAK$BAP_PROCEDURE_KEYPOINTS
*copyc CLK$PROCEDURE_KEYPOINTS
*copyc CMK$KEYPOINTS
*copyc dfk$keypoints
*copyc CSK$TERMINAL_MANAGER_KEYPOINTS
*copyc dmt$keypoints
*copyc FDK$SCREEN_FORMATTING_KEYPOINTS
*copyc FMK$KEYPOINTS
*copyc FSK$KEYPOINTS
*copyc IFK$KEYPOINTS
*copyc IIK$KEYPOINTS
*copyc IIK$VT_KEYPOINTS
*copyc JMK$KEYPOINTS
*copyc LGK$LOG_ASCII
*copyc lok$keypoints
*copyc MLK$KEYPOINTS
*copyc MMK$MONITOR_MODE_KEYPOINTS
*copyc MMK$JOB_MODE_KEYPOINTS
*copyc MTK$KEYPOINTS
*copyc NAK$JOB_MODE_KEYPOINTS
*copyc NAK$MONITOR_MODE_KEYPOINTS
*copyc OFK$KEYPOINTS
*copyc OSK$KEYPOINTS
*copyc PFK$KEYPOINTS
*copyc PMK$KEYPOINTS
*copyc rfk$keypoints
*copyc SRK$KEYPOINTS
*copyc STK$KEYPOINTS
*copyc SYK$RETURN_JOBS_R1_RESOURCES
*copyc TMK$MONITOR_MODE_KEYPOINTS
*copyc JSK$KEYPOINTS
*copyc AVK$MONITOR_STATISTICS_HANDLER
*copyc IOK$KEYPOINTS
*copyc RMK$KEYPOINTS
*copyc ptk$performance_keypoints
{$$$ END KEYPOINT DESCRIPTIONS $$$}
MODEND keypoint_description_file;
*DECK DECK=OSM$KEYPOINT_SUPPORT EXPAND=TRUE
?? RIGHT := 110 ??
MODULE osm$keypoint_support;
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc osc$keypoint_buffer_pva_offset
*copyc osc$multiprocessor_constants
*copyc osc$status_parameter_delimiter
*copyc osd$default_pragmats
*copyc ose$keypoint_conditions
*copyc oss$job_fixed
*copyc oss$task_shared
*copyc ost$caller_identifier
*copyc ost$execution_control_block
*copyc ost$wait

*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc mtv$scb
*copyc osv$keypoint_control
*copyc osv$page_size
*copyc osv$task_shared_heap
*copyc syv$perf_keypoints_enabled
*copyc tmv$ptl_p

*copyc clp$log_comment
*copyc clp$put_job_command_response
*copyc i#call_monitor
*copyc i$real_memory_address
*copyc jmp$get_ijle_p
*copyc mmp$free_pages
*copyc mmp$set_segment_length
*copyc mmp$verify_access
*copyc ofp$display_status_message
*copyc osp$append_status_parameter
*copyc osp$clear_signature_lock
*copyc osp$collection_file_info_r1
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$fetch_keypoint_lock
*copyc osp$init_keypoints_for_proc
*copyc osp$processor_selections_r1
*copyc osp$release_keypoint_r1
*copyc osp$reserve_keypoint_r1
*copyc osp$reset_processor_r1
*copyc osp$set_signature_lock
*copyc osp$set_status_from_condition
*copyc osp$set_status_abnormal
*copyc osp$verify_system_privilege
*copyc pmp$continue_to_cause
*copyc pmp$deselect_processor
*copyc pmp$disestab_end_hndlr_in_ring
*copyc pmp$establish_end_hndlr_in_ring
*copyc pmp$find_executing_task_xcb
*copyc pmp$get_processor_descriptions
*copyc pmp$log_ascii
*copyc pmp$long_term_wait
*copyc pmp$select_processor
*copyc pmp$get_compact_date_time
*copyc syp$pop_inhibit_job_recovery
*copyc syp$push_inhibit_job_recovery
?? POP ??

?? TITLE := 'osp$reserve_keypoint_env', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$reserve_keypoint_env
    (   env:ost$keypoint_environment;
        mm,
        jm: ost$keypoint_class_mask;
        pva_array: ^array [ * ] OF ^cell;
        wait: ost$wait;
        mpo: ost$keypoint_multipro_option;
        kc: integer;
        kbs: integer;
        str: string (32);
        performance_keypoints: syt$perf_keypoints_enabled;
    VAR status: ost$status);

*copyc osh$reserve_keypoint_env
?? EJECT ??

    PROCEDURE ch
      (   cond: pmt$condition;
          ci: ^pmt$condition_information;
          sa: ^ost$stack_frame_save_area;
      VAR hs: ost$status);

      IF cond.selector = ifc$interactive_condition THEN
        IF cond.interactive_condition = ifc$terminate_break THEN
          osp$set_status_from_condition ('OS', cond, sa, status, hs);
          EXIT osp$reserve_keypoint_env;
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, hs);
      IFEND;
      hs.normal := TRUE;
    PROCEND ch;
?? EJECT ??

    VAR
      cid: ost$caller_identifier,
      cpu_selections: ost$processor_id_set,
      fap: integer,
      i: integer,
      ijle_p: ^jmt$initiated_job_list_entry,
      j: integer,
      job_xcb_list: [XREF, oss$job_fixed] record
        head: ^ost$execution_control_block,
        lock: ost$signature_lock,
      recend,
      jtc: integer,
      k: integer,
      lstatus: ost$status,
      max_buffer_size: integer,
      mes: string (10),
      mtr_req: ost$rb_keypoint_request,
      nap: integer,
      offset: integer,
      osv$keypoint_enable: [XREF] integer,
      osv$max_kpt_pages: [XREF] integer,
      pd: pmt$processor_descriptions,
      perf_keys: syt$perf_keypoints_enabled,
      pptu: integer,
      stl: integer,
      xcb: ^ost$execution_control_block,
      xjm: ost$keypoint_class_mask,
      xcb_p: ^ost$execution_control_block,
      xkc: integer,
      xmm: ost$keypoint_class_mask;

    mes := '  ';
    #caller_id (cid);
    lstatus := status;
    status := lstatus;
    pptu := 16384 DIV osv$page_size; {!!!!!!!!!!!}
    max_buffer_size := osv$max_kpt_pages DIV pptu;

    i := #read_register (osc$pr_keypoint_buffer_ptr);
    IF i = 0 THEN
      osp$set_status_abnormal ('OS', ose$kpt_wrong_hardware, '', status);
      RETURN;
    IFEND;

    IF osv$keypoint_enable = osc$kpt_disabled THEN
      osp$set_status_abnormal ('OS', ose$kpt_illegal_request, '', status);
      RETURN;
    IFEND;

    IF (kbs * pptu) > osv$max_kpt_pages THEN
      STRINGREP (mes, stl, kbs);
      osp$set_status_abnormal ('OS', ose$kpt_kbs_too_large, mes, status);
      STRINGREP (mes, stl, max_buffer_size);
      osp$append_status_parameter (osc$status_parameter_delimiter, mes, status);
      RETURN;
    IFEND;

    pmp$get_processor_descriptions (pd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    xcb := job_xcb_list.head;
    jtc := 0;
    WHILE xcb <> NIL DO
      jtc := jtc + 1;
      xcb := xcb^.link;
    WHILEND;

    IF ((env = osc$job_keypoints) AND (jmv$jcb.ijle_p^.multiprocessing_allowed)) AND
       NOT (mpo = osc$keypoints_multi_processor) THEN
      osp$set_status_abnormal ('OS', ose$job_kpt_invalid_mp_job, '', status);
      RETURN;
    IFEND;

    IF (mpo = osc$keypoints_multi_processor) OR (env = osc$system_keypoints) OR
       (env = osc$system_sample_keypoints) THEN
      nap := 0;
      FOR i := 0 TO pd.count - 1 DO
        IF pd.processor [i].state = cmc$on THEN
          nap := nap + 1;
        IFEND;
      FOREND;
    ELSE
      nap := 1;
    IFEND;

    IF ((env = osc$system_keypoints) OR (env = osc$system_sample_keypoints)) AND
       (nap > 1) THEN
      IF mpo <> osc$keypoints_multi_processor THEN
        osp$set_status_abnormal ('OS', ose$kpt_mp_required, '', status);
        RETURN;
      IFEND;
    IFEND;
    nap := nap - 1;

    pmp$find_executing_task_xcb (xcb_p);
    jmp$get_ijle_p (tmv$ptl_p^ [xcb_p^.global_task_id.index].ijl_ordinal, ijle_p);
    IF ijle_p^.job_scheduler_data.job_class = jmc$maintenance_job_class THEN
      cpu_selections := mtv$scb.cpus.logically_on;
    ELSE
      cpu_selections := mtv$scb.cpus.available_for_use;
    IFEND;
    IF (xcb_p^.processor_selections <> cpu_selections) AND ((env = osc$job_keypoints) OR
          (env = osc$job_sample_keypoints)) AND (mpo = osc$keypoints_multi_processor) THEN
      osp$set_status_abnormal ('OS', ose$not_enough_procs_for_kpt, '', status);
      RETURN;
    IFEND;

    IF UPPERBOUND (pva_array^) - LOWERBOUND (pva_array^) < nap THEN
      osp$set_status_abnormal ('OS', ose$kpt_not_enough_files_for_mp, '',
            status);
      RETURN;
    IFEND;

    FOR i := LOWERBOUND (pva_array^) TO LOWERBOUND (pva_array^) + nap DO
      IF NOT mmp$verify_access (#LOC (pva_array^ [i]), mmc$va_write) THEN
        osp$set_status_abnormal ('OS', ose$kpt_invalid_collection_file, '',
              status);
        RETURN;
      IFEND;

      { free pages associated with file ...
      { this prevents confusion between file pages in jws/aq/amq and kpt io
      {directly to file
      { kpt io goes directly to file WITHOUT using the FILE'S sva (awk!).

      mmp$free_pages (pva_array^ [i], UPPERVALUE (ost$byte_count), osc$wait,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    i := (kbs * pptu * osv$page_size) DIV 8;
    xkc := kc + (i - (kc MOD i));
    xmm := mm - $ost$keypoint_class_mask [15];
    xjm := jm - $ost$keypoint_class_mask [15];
    fap := 0;
    perf_keys := performance_keypoints;
    osp$establish_condition_handler (^ch, FALSE);

    REPEAT
      syp$push_inhibit_job_recovery;
      osp$reserve_keypoint_r1 (env, xmm, xjm, mpo, xkc, kbs * pptu, fap,
            perf_keys, status);
      IF NOT status.normal THEN
        syp$pop_inhibit_job_recovery;
        IF status.condition = ose$kpt_environment_not_avail THEN
          IF wait = osc$wait THEN
            ofp$display_status_message ('Waiting for keypoint environment', status);
            status.normal := FALSE;
            pmp$long_term_wait (30000, 30000);
          ELSE
            RETURN;
          IFEND;
        ELSE
          RETURN;
        IFEND;
      IFEND;
    UNTIL status.normal;

    osp$disestablish_cond_handler;

    mtr_req.reqcode := syc$rc_keypoint;
    mtr_req.sub_request := osc$kpt_mr_init;
    pmp$get_compact_date_time (mtr_req.kpt.date_time, status);
    mtr_req.kpt.microsecond_clock := #free_running_clock (0);
    mtr_req.kpt.user_data := str;
    mtr_req.kpt.keypoint.clock := mtr_req.kpt.microsecond_clock MOD
          10000000(16);
    mtr_req.kpt.keypoint.keypoint_class := 15;
    mtr_req.kpt.keypoint.keypoint_code := osc$keypoint_cl15_reserve;

    offset := osc$keypoint_buffer_pva_offset;

/processor_selections/
    FOR i := LOWERBOUND (pva_array^) TO LOWERBOUND (pva_array^) + nap DO
    /job/
      BEGIN
      IF (osv$keypoint_control.environment = osc$job_keypoints) OR
        (osv$keypoint_control.environment = osc$job_sample_keypoints) THEN
        IF osv$keypoint_control.processor_select_flag THEN
          FOR j := 0 TO pd.count - 1 DO
            IF (pd.processor [j].id IN osv$keypoint_control.processor_selections) AND
                (pd.processor [j].state = cmc$on) THEN
              pmp$select_processor (pd.processor [j].id, status);
              osp$init_keypoints_for_proc (pva_array^ [i], offset, mtr_req, pd.
                 processor [j].id, status);
              IF NOT status.normal THEN
                syp$pop_inhibit_job_recovery;
                reset_processor_selections (pd);
                RETURN;
              IFEND;
              offset := offset + osc$kpt_pva_increment;
            IFEND;
          FOREND;
          EXIT /processor_selections/;
        ELSE
          IF mpo = osc$keypoints_multi_processor THEN
            EXIT /job/;
          IFEND;
          IF (pd.count > 1) AND (pd.processor [1].state = cmc$on) THEN
            pmp$select_processor (pd.processor [1].id, status);
            osp$init_keypoints_for_proc (pva_array^ [i], offset, mtr_req, pd.
               processor [1].id, status);
          ELSE
            pmp$select_processor (pd.processor [0].id, status);
            osp$init_keypoints_for_proc (pva_array^ [i], offset, mtr_req, pd.
               processor [0].id, status);
          IFEND;
          IF NOT status.normal THEN
            syp$pop_inhibit_job_recovery;
            osp$release_keypoint_r1 (lstatus);
            RETURN;
          IFEND;
          EXIT /processor_selections/;
        IFEND;
      IFEND;
      END /job/;

      pmp$select_processor (pd.processor [fap].id, status);
      IF NOT status.normal THEN
        syp$pop_inhibit_job_recovery;
        osp$release_keypoint_r1 (lstatus);
        RETURN;
      IFEND;

      osp$init_keypoints_for_proc (pva_array^ [i], offset, mtr_req, pd.
            processor [fap].id, status);
      IF NOT status.normal THEN
        syp$pop_inhibit_job_recovery;
        reset_processor_selections (pd);
        RETURN;
      IFEND;
      offset := offset + osc$kpt_pva_increment;
      fap := fap + 1;

    FOREND /processor_selections/;
    IF mpo = osc$keypoints_multi_processor THEN
      { enable multi-processor collection
      pmp$deselect_processor (status);
    IFEND;

    pmp$establish_end_hndlr_in_ring (^end_handler, cid.ring, status);
    syp$pop_inhibit_job_recovery;

  PROCEND osp$reserve_keypoint_env;
?? TITLE := 'end_handler', EJECT ??

  PROCEDURE end_handler
    (    termination_status: ost$status;
     VAR status: ost$status);

    VAR
      file_id_array: array [1 .. osc$max_number_of_processors] of amt$file_identifier,
      number_of_files: 0 .. 0ff(16),
      pa: array [1 .. osc$max_number_of_processors] of ^cell;

    pmp$log_ascii ('KEYPOINT TERMINATION ABORT', $pmt$ascii_logset [pmc$system_log,
          pmc$job_log], pmc$msg_origin_system, status);
    osp$fetch_collection_file_info (pa, file_id_array, number_of_files);
    osp$release_keypoint_env (pa, 'TERMINATION ABORT !!!!!!!!!!!   ', status);

  PROCEND end_handler;
?? TITLE := 'reset_processor_selections', EJECT ??

  PROCEDURE reset_processor_selections
    (pd: pmt$processor_descriptions);

    VAR
      k: integer,
      status: ost$status;

    IF osv$keypoint_control.processor_select_flag THEN
      FOR k := 0 TO pd.count - 1 DO
        IF (pd.processor [k].id IN  osv$keypoint_control.processor_selections) THEN
          pmp$select_processor (pd.processor [k].id, status);
        IFEND;
      FOREND;
    ELSE
      osp$reset_processor_r1;
    IFEND;
    osp$release_keypoint_r1 (status);

  PROCEND reset_processor_selections;
?? TITLE := 'osp$release_keypoint_env', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$release_keypoint_env
    (VAR pva_array: array [1 .. osc$max_number_of_processors] of ^cell;
         str: string (32);
     VAR status: ost$status);
*copyc osh$release_keypoint_env

    PROCEDURE ch
      (   condition: pmt$condition;
          condition_info: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      IF handler_invoked THEN
        RETURN;
      IFEND;
      IF condition.selector = ifc$interactive_condition THEN
        IF condition.interactive_condition = ifc$pause_break THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          RETURN;
        IFEND;
      IFEND;
      handler_invoked := TRUE;
      pmp$deselect_processor (status);
      reset_processor_selections (pd);
      pmp$disestab_end_hndlr_in_ring (^end_handler, cid.ring, status);
      osp$set_status_from_condition ('OS', condition, save_area, status, handler_status);
      IF NOT status.normal THEN
        handler_status := status;
      IFEND;
      EXIT osp$release_keypoint_env;
    PROCEND ch;

    VAR
      cid: ost$caller_identifier,
      fap: -2 .. 31,
      handler_invoked: boolean,
      i: integer,
      idx: integer,
      j: integer,
      lap: -2 .. 31,
      lstatus: ost$status,
      mtr_req: ost$rb_keypoint_request,
      off: integer,
      off_save_array: array [0 .. 7] of integer,
      pd: pmt$processor_descriptions,
      xcb_p: ^ost$execution_control_block;

    #caller_id (cid);
    lstatus := status;
    status := lstatus;

    IF (osv$keypoint_control.environment = osc$job_keypoints) OR
      (osv$keypoint_control.environment = osc$job_sample_keypoints) THEN
      pmp$find_executing_task_xcb (xcb_p);
      IF (NOT xcb_p^.keypoint_enable) THEN
        osp$set_status_abnormal ('OS', ose$kpt_not_valid_in_task, '', status);
        RETURN;
      IFEND;
    IFEND;

    osp$fetch_keypoint_lock (i);
    IF (i = 0) OR (osv$keypoint_control.jsn <> jmv$jcb.system_name) THEN
      osp$set_status_abnormal ('OS', ose$kpt_illegal_request, '', status);
      RETURN;
    IFEND;

    IF (UPPERBOUND (pva_array) - LOWERBOUND (pva_array) + 1) <
          (osv$keypoint_control.last_active_processor - osv$keypoint_control.
          first_active_processor + 1) THEN
      osp$set_status_abnormal ('OS', ose$kpt_not_enough_files_for_mp, '',
            status);
      RETURN;
    IFEND;

    pmp$get_processor_descriptions (pd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    handler_invoked := FALSE;
    osp$establish_condition_handler(^ch, TRUE);
    osp$stop_keypoint_collection (str, status);

    mtr_req.reqcode := syc$rc_keypoint;
    mtr_req.sub_request := osc$kpt_mr_term;
    pmp$get_compact_date_time (mtr_req.kpt.date_time, status);
    mtr_req.kpt.microsecond_clock := #free_running_clock (0);
    mtr_req.kpt.user_data := str;
    mtr_req.kpt.keypoint.clock := mtr_req.kpt.microsecond_clock MOD
          10000000(16);
    mtr_req.kpt.keypoint.keypoint_class := 15;
    mtr_req.kpt.keypoint.keypoint_code := osc$keypoint_cl15_release;
    status.normal := TRUE;
    idx := LOWERBOUND (pva_array);
    FOR i := osv$keypoint_control.first_active_processor TO
          osv$keypoint_control.last_active_processor DO
      pmp$select_processor (osv$keypoint_control.cpus [i].pid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      REPEAT
        i#call_monitor (#LOC (mtr_req), #SIZE (mtr_req));
      UNTIL mtr_req.status.normal;
      IF (osv$keypoint_control.environment = osc$job_keypoints) OR
            (osv$keypoint_control.environment = osc$system_keypoints) THEN
        mmp$set_segment_length (pva_array [idx], 1, osv$keypoint_control.cpus [i].offset,
          status);
      ELSE
        mmp$set_segment_length (pva_array [idx], 1, 0, status);
      IFEND;
      idx := idx + 1;
    FOREND;

    reset_processor_selections (pd);

    pmp$disestab_end_hndlr_in_ring (^end_handler, cid.ring, lstatus);
    osp$disestablish_cond_handler;

  PROCEND osp$release_keypoint_env;
?? TITLE := 'osp$start_keypoint_collection', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$start_keypoint_collection
    (   str: string (32);
     VAR status: ost$status);
*copyc osh$start_keypoint_collection

    VAR
      i: integer,
      j: integer,
      mtr_req: ost$rb_keypoint_request,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    IF (osv$keypoint_control.environment = osc$job_keypoints) OR
      (osv$keypoint_control.environment = osc$job_sample_keypoints) THEN
      pmp$find_executing_task_xcb (xcb_p);
      IF (NOT xcb_p^.keypoint_enable) THEN
        osp$set_status_abnormal ('OS', ose$kpt_not_valid_in_task, '', status);
        RETURN;
      IFEND;
    IFEND;

    osp$fetch_keypoint_lock (i);
    IF (i = 0) OR (osv$keypoint_control.jsn <> jmv$jcb.system_name) THEN
      osp$set_status_abnormal ('OS', ose$kpt_illegal_request, '', status);
      RETURN;
    IFEND;
    IF osv$keypoint_control.active THEN
      osp$set_status_abnormal ('OS', ose$kpt_collect_already_started, '',
            status);
      RETURN;
    IFEND;
    IF osv$keypoint_control.termination_status <> osc$kp_term_not_stopped THEN
      osp$set_status_abnormal ('OS', osv$keypoint_control.termination_status,
            '', status);
      RETURN;
    IFEND;

    mtr_req.reqcode := syc$rc_keypoint;
    mtr_req.sub_request := osc$kpt_mr_start;
    pmp$get_compact_date_time (mtr_req.kpt.date_time, status);
    mtr_req.kpt.microsecond_clock := #free_running_clock (0);
    mtr_req.kpt.user_data := str;
    mtr_req.kpt.keypoint.clock := mtr_req.kpt.microsecond_clock MOD
          10000000(16);
    mtr_req.kpt.keypoint.keypoint_class := 15;
    mtr_req.kpt.keypoint.keypoint_code := osc$keypoint_cl15_start;
    status.normal := TRUE;

 { The following two FOR loops should not be combined. The monitor
 { activities must be done synchronously.

    FOR i := osv$keypoint_control.first_active_processor TO
          osv$keypoint_control.last_active_processor DO
      pmp$select_processor (i, status);
      i#call_monitor (#LOC (mtr_req), #SIZE (mtr_req));
      IF NOT mtr_req.status.normal THEN
        osp$set_status_abnormal ('OS', mtr_req.status.condition, '', status);
        RETURN;
      IFEND;
    FOREND;

    FOR i := osv$keypoint_control.first_active_processor TO
          osv$keypoint_control.last_active_processor DO
      pmp$select_processor (i, status);
      mtr_req.sub_request := osc$kpt_mr_go;
      i#call_monitor (#LOC (mtr_req), #SIZE (mtr_req));
      IF NOT mtr_req.status.normal THEN
        osp$set_status_abnormal ('OS', mtr_req.status.condition, '', status);
        RETURN;
      IFEND;
    FOREND;

    IF (osv$keypoint_control.mpo = osc$keypoints_multi_processor) THEN
      pmp$deselect_processor (status);
    IFEND;
  PROCEND osp$start_keypoint_collection;
?? TITLE := 'osp$stop_keypoint_collection', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$stop_keypoint_collection
    (   str: string (32);
     VAR status: ost$status);
*copyc osh$stop_keypoint_collection

    VAR
      i: integer,
      mtr_req: ost$rb_keypoint_request,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    IF (osv$keypoint_control.environment = osc$job_keypoints) OR
      (osv$keypoint_control.environment = osc$job_sample_keypoints) THEN
      pmp$find_executing_task_xcb (xcb_p);
      IF (NOT xcb_p^.keypoint_enable) THEN
        osp$set_status_abnormal ('OS', ose$kpt_not_valid_in_task, '', status);
        RETURN;
      IFEND;
    IFEND;

    osp$fetch_keypoint_lock (i);
    IF (i = 0) OR (osv$keypoint_control.jsn <> jmv$jcb.system_name) THEN
      osp$set_status_abnormal ('OS', ose$kpt_illegal_request, '', status);
      RETURN;
    IFEND;
    IF NOT osv$keypoint_control.active THEN
      IF osv$keypoint_control.termination_status <> osc$kp_term_not_stopped
            THEN
        osp$set_status_abnormal ('OS', osv$keypoint_control.termination_status,
              '', status);
      ELSE
        osp$set_status_abnormal ('OS', ose$kpt_collect_already_stopped, '',
              status);
      IFEND;
      RETURN;
    IFEND;

    mtr_req.reqcode := syc$rc_keypoint;
    mtr_req.sub_request := osc$kpt_mr_stop;
    pmp$get_compact_date_time (mtr_req.kpt.date_time, status);
    mtr_req.kpt.microsecond_clock := #free_running_clock (0);
    mtr_req.kpt.user_data := str;
    mtr_req.kpt.keypoint.clock := mtr_req.kpt.microsecond_clock MOD
          10000000(16);
    mtr_req.kpt.keypoint.keypoint_class := 15;
    mtr_req.kpt.keypoint.keypoint_code := osc$keypoint_cl15_stop;
    status.normal := TRUE;
    FOR i := osv$keypoint_control.first_active_processor TO
          osv$keypoint_control.last_active_processor DO
      pmp$select_processor (i, status);
      i#call_monitor (#LOC (mtr_req), #SIZE (mtr_req));
      IF NOT mtr_req.status.normal THEN
        osp$set_status_abnormal ('OS', mtr_req.status.condition, '', status);
      IFEND;
    FOREND;
    IF (osv$keypoint_control.mpo = osc$keypoints_multi_processor) THEN
      pmp$deselect_processor (status);
    IFEND;
  PROCEND osp$stop_keypoint_collection;
?? TITLE := 'osp$issue_keypoint_collection', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$issue_string_as_keypoint
    (   str: string (32);
     VAR status: ost$status);
*copyc osh$issue_string_as_keypoint

    VAR
      i: integer,
      j: integer,
      mtr_req: ost$rb_keypoint_request,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    IF (osv$keypoint_control.environment = osc$job_keypoints) OR
      (osv$keypoint_control.environment = osc$job_sample_keypoints) THEN
      pmp$find_executing_task_xcb (xcb_p);
      IF (NOT xcb_p^.keypoint_enable) THEN
        osp$set_status_abnormal ('OS', ose$kpt_not_valid_in_task, '', status);
        RETURN;
      IFEND;
    IFEND;

    osp$fetch_keypoint_lock (i);
    IF (i = 0) OR (osv$keypoint_control.jsn <> jmv$jcb.system_name) THEN
      osp$set_status_abnormal ('OS', ose$kpt_illegal_request, '', status);
      RETURN;
    IFEND;

    mtr_req.reqcode := syc$rc_keypoint;
    mtr_req.sub_request := osc$kpt_mr_issue;
    pmp$get_compact_date_time (mtr_req.kpt.date_time, status);
    mtr_req.kpt.microsecond_clock := #free_running_clock (0);
    mtr_req.kpt.user_data := str;
    mtr_req.kpt.keypoint.clock := mtr_req.kpt.microsecond_clock MOD
          10000000(16);
    mtr_req.kpt.keypoint.keypoint_class := 15;
    mtr_req.kpt.keypoint.keypoint_code := osc$keypoint_cl15_issue;
    status.normal := TRUE;
    FOR i := osv$keypoint_control.first_active_processor TO
          osv$keypoint_control.last_active_processor DO
      i#call_monitor (#LOC (mtr_req), #SIZE (mtr_req));
      IF NOT mtr_req.status.normal THEN
        osp$set_status_abnormal ('OS', mtr_req.status.condition, '', status);
      IFEND;
    FOREND;
  PROCEND osp$issue_string_as_keypoint;
?? TITLE := 'ost$display_keypoint_status', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$display_keypoint_status
    (VAR kc:ost$keypoint_control;
     VAR perf_keypoints: syt$perf_keypoints_enabled;
     VAR status: ost$status);

    VAR
      i: integer;

    status.normal := TRUE;
    osp$fetch_keypoint_lock (i);
    IF (i = 0) OR (osv$keypoint_control.jsn <> jmv$jcb.system_name) THEN
      osp$set_status_abnormal ('OS', ose$kpt_illegal_request, '', status);
      RETURN;
    IFEND;
    perf_keypoints := syv$perf_keypoints_enabled;
    kc := osv$keypoint_control;
    status.normal := TRUE;
  PROCEND osp$display_keypoint_status;
?? TITLE := 'osp$fetch_keypoint_buffer_rmas', EJECT ??

  PROCEDURE osp$fetch_keypoint_buffer_rmas
    (VAR rmas: array [ * ] OF integer;
     VAR number_of_pages: integer;
     VAR page_size: integer;
     VAR status: ost$status);

    VAR
      i: integer,
      idx: integer,
      pc: ^cell;

    number_of_pages := 0;
    osp$fetch_keypoint_lock (i);
    IF (i = 0) OR (osv$keypoint_control.jsn <> jmv$jcb.system_name) THEN
      osp$set_status_abnormal ('OS', ose$kpt_illegal_request, '', status);
      RETURN;
    IFEND;

    IF (osv$keypoint_control.environment <> osc$job_sample_keypoints) AND
          (osv$keypoint_control.environment <> osc$system_sample_keypoints)
          THEN
      osp$set_status_abnormal ('OS', ose$kpt_illegal_request,
        'must be trace mode', status);
      RETURN;
    IFEND;

    IF (UPPERBOUND (rmas) - LOWERBOUND (rmas) + 1) < osv$keypoint_control.
          max_pages THEN
      osp$set_status_abnormal ('OS', ose$kpt_illegal_request, '', status);
      RETURN;
    IFEND;

    idx := LOWERBOUND (rmas);
    pc := osv$keypoint_control.cpus [#read_register (osc$pr_processor_id)].
          collector_pva;

    FOR i := 1 TO osv$keypoint_control.max_pages DO
      i#real_memory_address (pc, rmas [idx]);
      pc := #address (#ring (pc), #segment (pc), #offset (pc) + osv$page_size);
      idx := idx + 1;
    FOREND;

    page_size := osv$page_size;
    number_of_pages := osv$keypoint_control.max_pages;
    status.normal := TRUE;
  PROCEND osp$fetch_keypoint_buffer_rmas;
?? TITLE := 'osp$collection_file_info', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$collection_file_info
    (   number_of_files: 0 .. 0ff(16);
        file_id_array: array [1 .. osc$max_number_of_processors] of amt$file_identifier;
        pva_array: array [1 .. osc$max_number_of_processors] of ^cell;
    VAR status: ost$status);

    VAR
       local_file_id_array: array [1 .. osc$max_number_of_processors] of amt$file_identifier,
       local_pva_array: array [1 .. osc$max_number_of_processors] of ^cell,
       local_number_of_files: 0 .. 0ff(16);

    status.normal := TRUE;
    local_pva_array := pva_array;
    local_file_id_array := file_id_array;
    local_number_of_files := number_of_files;
    osp$collection_file_info_r1 (local_pva_array, local_file_id_array, local_number_of_files);

  PROCEND osp$collection_file_info;

?? TITLE := 'osp$collection_file_info_r1', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$fetch_collection_file_info
    (VAR pva_array: array [1 ..    osc$max_number_of_processors] of ^cell;
     VAR file_id_array: array [1 .. osc$max_number_of_processors] of amt$file_identifier;
     VAR num_of_files: 0 .. 0ff(16));

    VAR
      i: integer;

    num_of_files := osv$keypoint_control.number_of_keypoint_files;
    FOR i := 1 TO num_of_files DO
      pva_array [i] := osv$keypoint_control.keypoint_pva_array [i];
      file_id_array [i] := osv$keypoint_control.keypoint_file_array [i];
    FOREND;

 PROCEND osp$fetch_collection_file_info;

?? TITLE := 'osp$handle_keyp_environ_change', EJECT ??

{ Purpose:
{   This procedure is called in response to a system flag being set as a result of a CPU state change while
{   keypoints are being run.  The job which has the keypoint environment has had the environment taken away
{   from under it, and must be informed using this procedure.

  PROCEDURE [XDCL, #GATE] osp$handle_keyp_environ_change
    (    flag_id: ost$system_flag);

    VAR
      status: ost$status,
      log_name_selections: array [1 .. 2] of ost$name;

    osp$verify_system_privilege;

    log_name_selections [1] := 'JOB                            ';
    log_name_selections [2] := 'SYSTEM                         ';
    clp$log_comment (' *** KEYPOINT ENVIRONMENT RELEASED DURING CPU STATE CHANGE ***', log_name_selections,
          status);
    clp$put_job_command_response ('-- WARNING -- Keypoint environment released due to CPU state change',
          status);

  PROCEND osp$handle_keyp_environ_change;
MODEND osm$keypoint_support;
*DECK DECK=OSM$KEYPOINT_SUPPORT_R1 EXPAND=TRUE
MODULE osm$keypoint_support_r1;
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc osc$multiprocessor_constants
*copyc osd$default_pragmats
*copyc ose$keypoint_conditions
*copyc ost$execution_control_block

*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc jmv$null_ijl_ordinal
*copyc mtv$scb
*copyc osv$keypoint_control
*copyc osv$mainframe_wired_cb_heap
*copyc osv$page_size
*copyc syv$perf_keypoints_enabled
*copyc syv$pmf_cb_rm_word_address
*copyc tmv$ptl_p

*copyc i#call_monitor
*copyc i$real_memory_address
*copyc jmp$get_ijle_p
*copyc dmp$allocate_file_space_r1
*copyc mmp$get_sdtx_entry_p
*copyc osp$fetch_locked_variable
*copyc osp$set_locked_variable
*copyc osp$set_status_abnormal
*copyc osp$fatal_system_error
*copyc pmp$delay
*copyc pmp$find_executing_task_xcb
?? POP ??

  VAR
    ppu_keypoint_control: ^ost$ppu_keypoint_control;

?? TITLE := 'osp$reserve_keypoint_r1', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$reserve_keypoint_r1
    (   env: ost$keypoint_environment;
        mm,
        jm: ost$keypoint_class_mask;
        mpo: ost$keypoint_multipro_option;
        kc: integer;
        kbs: integer;
        fap: integer;
        performance_keypoints: syt$perf_keypoints_enabled;
    VAR status: ost$status);

    VAR
      actual: integer,
      i: integer,
      locked: boolean,
      rma: integer;

    osp$set_locked_variable (osv$keypoint_control.lock, 0, 1, actual, locked);
    IF jmv$jcb.system_name = osv$keypoint_control.jsn THEN
      osp$set_status_abnormal ('OS', ose$task_in_job_owns_env, '', status);
      RETURN;
    IFEND;
    IF NOT locked THEN
      osp$set_status_abnormal ('OS', ose$kpt_environment_not_avail, '',
            status);
      RETURN;
    IFEND;
    osp$processor_selections_r1;
    osv$keypoint_control.environment := env;
    osv$keypoint_control.envjm := jm;
    osv$keypoint_control.envmm := mm;
    osv$keypoint_control.jm := $ost$keypoint_mask [];
    osv$keypoint_control.mm := $ost$keypoint_mask [];
    osv$keypoint_control.mpo := mpo;
    osv$keypoint_control.maximum_keypoints := kc;
    osv$keypoint_control.max_pages := kbs;
    osv$keypoint_control.ijlo := jmv$jcb.ijl_ordinal;
    osv$keypoint_control.periodic_requested := FALSE;
    osv$keypoint_control.jsn := jmv$jcb.system_name;
    osv$keypoint_control.first_active_processor := 31;
    osv$keypoint_control.last_active_processor := fap;
    osv$keypoint_control.termination_status := osc$kp_term_not_stopped;

    ALLOCATE ppu_keypoint_control IN osv$mainframe_wired_cb_heap^;
    ppu_keypoint_control^.number_of_processors := 0;
    ppu_keypoint_control^.pages_per_processor := kbs;
    ppu_keypoint_control^.page_size := osv$page_size;
    i#real_memory_address (ppu_keypoint_control, rma);
    syv$pmf_cb_rm_word_address := rma DIV 8;
    syv$perf_keypoints_enabled := performance_keypoints;
    status.normal := TRUE;
  PROCEND osp$reserve_keypoint_r1;
?? TITLE := 'osp$init_keypoints_for_proc', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$init_keypoints_for_proc
    (   collection_pva: ^cell;
        offset: integer;
        mtr_req: ost$rb_keypoint_request;
        pid: integer;
    VAR status: ost$status);

    VAR
      i: integer,
      j: integer,
      lpid: integer,
      ls: ost$status,
      pva: ^cell,
      rma: integer,
      sdtxe_p: ^mmt$segment_descriptor_extended,
      xcb_p: ^ost$execution_control_block;


    osp$fetch_locked_variable (osv$keypoint_control.lock, i);
    IF (i = 0) OR (osv$keypoint_control.jsn <> jmv$jcb.system_name) THEN
      osp$set_status_abnormal ('OS', ose$kpt_illegal_request, '', status);
      RETURN;
    IFEND;
    lpid := #read_register (osc$pr_processor_id);
    IF lpid <> pid THEN
      osp$fatal_system_error (' Init keypoints on wrong processor', NIL);
    IFEND;
    pmp$find_executing_task_xcb (xcb_p);
    sdtxe_p := mmp$get_sdtx_entry_p (xcb_p, #SEGMENT(collection_pva));
    osv$keypoint_control.cpus [lpid].sfid := sdtxe_p^.sfid;
    IF osv$keypoint_control.cpus [lpid].sfid.residence <>
          gfc$tr_system THEN
      osp$set_status_abnormal ('OS', ose$kpt_invalid_collection_file, '',
            status);
      RETURN;
    IFEND;
    IF (osv$keypoint_control.environment = osc$job_keypoints) OR
          (osv$keypoint_control.environment = osc$system_keypoints) THEN
      dmp$allocate_file_space_r1 (osv$keypoint_control.cpus [lpid].sfid, 0,
         osv$keypoint_control.maximum_keypoints * 8, 0, osc$wait, sfc$no_limit, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    IF lpid < osv$keypoint_control.first_active_processor THEN
      osv$keypoint_control.first_active_processor := lpid;
    IFEND;
    osv$keypoint_control.cpus [lpid].avail_count := 0;
    osv$keypoint_control.cpus [lpid].io_count := 0;
    osv$keypoint_control.cpus [lpid].in_use_count := 0;
    osv$keypoint_control.cpus [lpid].collector_pva := #address (1,
          osc$kpt_pva_segment, offset);
    osv$keypoint_control.cpus [lpid].pid := pid;
    osv$keypoint_control.cpus [lpid].offset := 0;
    REPEAT
      i#call_monitor (#LOC (mtr_req), #SIZE (mtr_req));
      IF NOT mtr_req.status.normal THEN
        pmp$delay (1000, status);
      IFEND;
    UNTIL mtr_req.status.normal;

    IF osv$keypoint_control.last_active_processor < lpid THEN
      osv$keypoint_control.last_active_processor := lpid;
    IFEND;

    pva := osv$keypoint_control.cpus [lpid].collector_pva;
    i := ppu_keypoint_control^.number_of_processors;
    FOR j := 1 TO ppu_keypoint_control^.pages_per_processor DO
      i#real_memory_address (pva, rma);
      ppu_keypoint_control^.cpus [i] [j] := rma DIV 8;
      pva := #address (#ring (pva), #segment (pva), #offset (pva) +
            osv$page_size);
    FOREND;
    ppu_keypoint_control^.number_of_processors :=
          ppu_keypoint_control^.number_of_processors + 1;
    status.normal := TRUE;
  PROCEND osp$init_keypoints_for_proc;
?? TITLE := 'osp$release_keypoint_r1', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$release_keypoint_r1
    (VAR status: ost$status);

    VAR
      actual: integer,
      i: integer,
      ls: ost$status,
      result: boolean;

    status.normal := TRUE;
    osp$fetch_locked_variable (osv$keypoint_control.lock, i);
    IF (i = 0) OR (osv$keypoint_control.jsn <> jmv$jcb.system_name) THEN
      osp$set_status_abnormal ('OS', ose$kpt_illegal_request, '', status);
      RETURN;
    IFEND;

    syv$pmf_cb_rm_word_address := 0;
    pmp$delay (10000, ls);
    FREE ppu_keypoint_control IN osv$mainframe_wired_cb_heap^;

    osv$keypoint_control.jsn := '     ';
    osv$keypoint_control.first_active_processor := - 2;
    osv$keypoint_control.last_active_processor := - 1;
    osv$keypoint_control.ijlo := jmv$null_ijl_ordinal;
    osv$keypoint_control.processor_select_flag := FALSE;
    syv$perf_keypoints_enabled.memory_keypoints := FALSE;
    syv$perf_keypoints_enabled.heap_keypoints := FALSE;
    syv$perf_keypoints_enabled.swapping_keypoints := FALSE;
    syv$perf_keypoints_enabled.aging_keypoints := FALSE;
    syv$perf_keypoints_enabled.swapping_stack_trace := FALSE;
    syv$perf_keypoints_enabled.aging_stack_trace := FALSE;
    syv$perf_keypoints_enabled.disk_cache := FALSE;
    syv$perf_keypoints_enabled.command_keypoints := FALSE;

    osp$set_locked_variable (osv$keypoint_control.lock, 1, 0, actual, result);

  PROCEND osp$release_keypoint_r1;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$fetch_keypoint_lock
    (VAR i: integer);

    osp$fetch_locked_variable (osv$keypoint_control.lock, i);

  PROCEND osp$fetch_keypoint_lock;

  PROCEDURE [XDCL, #GATE] osp$collection_file_info_r1
    (   pva_array: array [1 .. osc$max_number_of_processors] of ^cell;
        file_id_array: array [1 .. osc$max_number_of_processors] of amt$file_identifier;
        num_of_files: 0 .. 0ff(16));

    VAR
      i: integer;

    osv$keypoint_control.number_of_keypoint_files := num_of_files;
    FOR i := 1 TO num_of_files DO
      osv$keypoint_control.keypoint_pva_array [i] := pva_array [i];
      osv$keypoint_control.keypoint_file_array [i] := file_id_array [i];
    FOREND;
  PROCEND osp$collection_file_info_r1;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$processor_selections_r1;

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      processor_selections: ost$processor_id_set,
      xcb_p: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb_p);
    jmp$get_ijle_p (tmv$ptl_p^ [xcb_p^.global_task_id.index].ijl_ordinal, ijle_p);
    IF ijle_p^.job_scheduler_data.job_class = jmc$maintenance_job_class THEN
      processor_selections := mtv$scb.cpus.logically_on;
    ELSE
      processor_selections := mtv$scb.cpus.available_for_use;
    IFEND;
    osv$keypoint_control.processor_selections := xcb_p^.processor_selections;
    IF NOT (xcb_p^.processor_selections = processor_selections) THEN
      osv$keypoint_control.processor_select_flag := TRUE;
    IFEND;

  PROCEND osp$processor_selections_r1;
?? TITLE := 'OSP$RESET_PROCESSOR_R1', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$reset_processor_r1;

    VAR
      xcb: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb);
    xcb^.processor_selections := osv$keypoint_control.processor_selections;

  PROCEND osp$reset_processor_r1;
MODEND osm$keypoint_support_r1
*DECK DECK=OSM$LOCK_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
MODULE osm$lock_manager {deck := osmlok} ;

{
{  PURPOSE:
{     This module contains procedures to manage system table locks.
{

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc OSS$MAINFRAME_PAGEABLE
*copyc OST$EXECUTION_CONTROL_BLOCK
*copyc ost$signature_lock
*copyc OST$WAIT
*copyc OST$HEAP
*copyc OSC$PROCESSOR_DEFINED_REGISTERS
?? POP ??
*copyc OSP$SYSTEM_ERROR
*copyc mmp$mfh_for_segment_manager
*copyc PMP$CYCLE
*copyc PMP$DELAY



{Define constant that defines length of timeout to use when waiting for  a signature lock.


?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$set_signature_lock (VAR lock: ost$signature_lock;
        wait: ost$wait;
    VAR status: ost$status);

*copyc OSH$SET_SIGNATURE_LOCK

    VAR
      ring: integer,
      local_reject_count: integer,
      task_id: ost$global_task_id,
      xcb_p: ^ost$execution_control_block,
      new_value,
      actual_value: integer,
      ptr: ^cell,
      cs_status: 0 .. 2;

    status.normal := TRUE;

    xcb_p := #address (1, osc$segnum_job_fixed_heap, #read_register (osc$pr_base_constant));
    task_id := xcb_p^.global_task_id;
    new_value := task_id.index * 256 * #SIZE (task_id.seqno) + task_id.seqno;
    local_reject_count := 0;

    ptr := ^lock;
    ring := #ring (ptr);

  /lock_loop/
    WHILE TRUE DO

{      Check for lock on a system table.
      IF ring = 1 THEN
        xcb_p^.system_table_lock_count := xcb_p^.system_table_lock_count + 256;
      IFEND;

      local_reject_count := local_reject_count + 1;
      REPEAT
        #compare_swap (lock.lock_id, 0, new_value, actual_value, cs_status);
      UNTIL cs_status <> osc$cs_variable_locked;
      IF cs_status = osc$cs_successful THEN
        RETURN;
      IFEND;

      IF ring = 1 THEN
        xcb_p^.system_table_lock_count := xcb_p^.system_table_lock_count - 256;
      IFEND;

      IF new_value = actual_value THEN
        osp$system_error ('Lock already set by current task', NIL);
      IFEND;

      IF wait = osc$wait THEN
        pmp$cycle (status);
       CYCLE /lock_loop/;
    IFEND;


{  Unable to set the lock.

      IF (ring = 1) AND (xcb_p^.system_give_up_cpu) THEN
        pmp$cycle (status);
      IFEND;

{! The following may miss a count if a trap occurs during this line - so what.

      status.normal := FALSE;
      RETURN;
    WHILEND /lock_loop/;

  PROCEND osp$set_signature_lock;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$clear_signature_lock (VAR lock: ost$signature_lock;
    VAR status: ost$status);
*copyc OSH$CLEAR_SIGNATURE_LOCK

    VAR
      ring: integer,
      task_id: ost$global_task_id,
      xcb_p: ^ost$execution_control_block,
      actual_value,
      initial_value: integer,
      ptr: ^cell,
      cs_status: 0 .. 2;

    status.normal := TRUE;
    xcb_p := #address (1, osc$segnum_job_fixed_heap, #read_register (osc$pr_base_constant));
    task_id := xcb_p^.global_task_id;
    initial_value := task_id.index * 256 * #SIZE (task_id.seqno) + task_id.seqno;
    REPEAT
      #compare_swap (lock.lock_id, initial_value, 0, actual_value, cs_status);
    UNTIL cs_status <> osc$cs_variable_locked;
    IF cs_status <> osc$cs_successful THEN
      status.normal := FALSE;
      osp$system_error ('LOCKMGR - not locked', NIL);
    IFEND;

    ptr := ^lock;
    ring := #ring (ptr);
    IF ring = 1 THEN

{ Debug code.

      IF xcb_p^.system_table_lock_count < 256 THEN
        osp$system_error ('LOCKMGR - system_table_lock_count error', NIL);
      IFEND;

{ End debug code.

      xcb_p^.system_table_lock_count := xcb_p^.system_table_lock_count - 256;

{ Check for escaped allocation. If allocation occured while tables were locked, process
{ the allocation.

      IF xcb_p^.stlc_allocation AND (xcb_p^.system_table_lock_count < 256) THEN
        xcb_p^.stlc_allocation := FALSE;
        mmp$mfh_for_segment_manager;
      IFEND;

      IF (xcb_p^.system_table_lock_count <= 0) AND (xcb_p^.system_give_up_cpu) THEN
        pmp$cycle (status);
      IFEND;
    IFEND;

  PROCEND osp$clear_signature_lock;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$initialize_signature_lock (VAR lock: ost$signature_lock;
    VAR status: ost$status);

*copyc OSH$INITIALIZE_SIGNATURE_LOCK

    status.normal := TRUE;
    lock.lock_id := 0;


  PROCEND osp$initialize_signature_lock;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$test_signature_lock (VAR lock: ost$signature_lock;
    VAR lock_status: ost$signature_lock_status;
    VAR status: ost$status);

*copyc OSH$TEST_SIGNATURE_LOCK

    VAR
      cs_status: 0 .. 2,
      task_id: ost$global_task_id,
      xcb_p: ^ost$execution_control_block,
      actual_value,
      current_task_value: integer;

    status.normal := TRUE;

    REPEAT
      #compare_swap (lock.lock_id, 0, 0, actual_value, cs_status);
    UNTIL cs_status <> osc$cs_variable_locked;
    IF cs_status = osc$cs_successful THEN
      lock_status := osc$sls_not_locked;
    ELSE
      xcb_p := #address (1, osc$segnum_job_fixed_heap, #read_register (osc$pr_base_constant));
      task_id := xcb_p^.global_task_id;
      current_task_value := task_id.index * 256 * #SIZE (task_id.seqno) + task_id.seqno;
      IF actual_value = current_task_value THEN
        lock_status := osc$sls_locked_by_current_task;
      ELSE
        lock_status := osc$sls_locked_by_another_task;
      IFEND;
    IFEND;

  PROCEND osp$test_signature_lock;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$mfh_for_segment_manager;

    mmp$mfh_for_segment_manager;
  PROCEND osp$mfh_for_segment_manager;
MODEND osm$lock_manager;
*DECK DECK=OSM$LOG_CALLER EXPAND=TRUE
MODULE osm$log_caller;

*copyc osp$log_caller_r1



PROCEDURE [XDCL, #GATE] osp$log_caller;

  osp$log_caller_r1;

PROCEND osp$log_caller;
MODEND osm$log_caller;
*DECK DECK=OSM$LOG_CALLER_R1 EXPAND=TRUE
MODULE osm$log_caller_r1;

  VAR
    osv$switch_on: [XDCL] boolean := FALSE,
    id_table: array [1 .. 30] of RECORD
      p_address: ^cell,
      log_p: ^log_table,
      total: 0 .. 0ffffffff(16),
    RECEND := [REP 30 of [NIL, NIL, 0]];

  TYPE
    sfsa = RECORD
      fill1: string (2),
      p: ^cell,
      fill2: string (18),
      a2: ^sfsa,
    RECEND,
    log_table = array [1 .. 100] of RECORD
      fill1: 0 .. 0ffff(16),
      p_address: ^cell,
      count: integer,
    RECEND;

*copyc osv$mainframe_wired_heap

PROCEDURE [XDCL, #GATE] osp$log_caller_r1;

  VAR
    r1_p: ^sfsa,
    local_log_p: ^log_table,
    i,
    j: integer;

  IF osv$switch_on THEN
    r1_p := #previous_save_area ();
    i := 0;
    REPEAT
      i := i + 1;
    UNTIL (i > UPPERBOUND (id_table)) OR (r1_p^.a2^.p = id_table [i].
          p_address) OR (id_table [i].p_address = NIL);

    IF i > UPPERBOUND (id_table) THEN
      RETURN;
    IFEND;

    IF (id_table [i].p_address <> NIL) AND (id_table [i].log_p = NIL) THEN
      RETURN;
    IFEND;

    IF id_table [i].p_address = NIL THEN
      id_table [i].p_address := r1_p^.a2^.p;
      ALLOCATE local_log_p IN osv$mainframe_wired_heap^;
      FOR j := 1 TO 100 DO
        local_log_p^ [j].fill1 := 0;
        local_log_p^ [j].p_address := NIL;
        local_log_p^ [j].count := 0;
      FOREND;
      id_table [i].log_p := local_log_p;
    IFEND;

    id_table [i].total := id_table [i].total + 1;

    j := 0;
    REPEAT
      j := j + 1;
    UNTIL (j > UPPERBOUND (log_table)) OR (r1_p^.a2^.a2^.p = id_table [i].
          log_p^ [j].p_address) OR (id_table [i].log_p^ [j].p_address = NIL);

    IF j > UPPERBOUND (log_table) THEN
      RETURN;
    IFEND;

    IF id_table [i].log_p^ [j].p_address = NIL THEN
      id_table [i].log_p^ [j].p_address := r1_p^.a2^.a2^.p;
    IFEND;
    id_table [i].log_p^ [j].count := id_table [i].log_p^ [j].count + 1;
  IFEND;
PROCEND osp$log_caller_r1;
MODEND osm$log_caller_r1;

*DECK DECK=OSM$MANAGE_EXCEPTION_POLICIES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Disk Fault Tolerance:  Exception Policies Commands.' ??
MODULE osm$manage_exception_policies;

{ PURPOSE:
{   This module contains the command interfaces for establishing and displaying
{   disk fault tolerance exception processing policies.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$path_display_chunks
*copyc fsc$local
*copyc osd$exception_policies
*copyc ose$disk_ft_exceptions
*copyc ost$date
*copyc ost$ecp_file_identification
*copyc ost$heap
*copyc ost$time
*copyc rmc$unspecified_file_class
?? POP ??
*copyc amp$fetch
*copyc amp$get_segment_pointer
*copyc amv$nil_file_identifier
*copyc bap$find_open_file_via_segment
*copyc clp$begin_utility
*copyc clp$build_standard_title
*copyc clp$build_pattern_for_wild_card
*copyc clp$close_display
*copyc clp$convert_data_to_string
*copyc clp$convert_file_ref_to_string
*copyc clp$count_list_elements
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc clp$find_scl_options
*copyc clp$include_command
*copyc clp$include_file
*copyc clp$make_file_value
*copyc clp$make_integer_value
*copyc clp$make_keyword_value
*copyc clp$make_list_value
*copyc clp$make_name_value
*copyc clp$make_record_value
*copyc clp$make_unspecified_value
*copyc clp$match_string_pattern
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$open_display_reference
*copyc clp$put_data_representation
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$right_justify_string
*copyc clp$trimmed_string_size
*copyc clv$nil_display_control
*copyc fsp$convert_fs_structure_to_pf
*copyc fsp$default_file_class
*copyc jmp$get_job_attributes
*copyc jmp$validate_name
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$r3_get_installed_policies
*copyc osp$r3_install_exception_policy
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$file_access_condition
*copyc osp$generate_output_message
*copyc osp$get_access_condition_entry
*copyc osp$set_status_condition
*copyc osp$store_sequence_headers
*copyc oss$job_paged_literal
*copyc osv$ecp_sequence_headers
*copyc pfp$convert_pft$path_to_fs_str
*copyc pfp$get_object_information
*copyc pmp$wait
?? OLDTITLE, EJECT ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    all_keyword = 'ALL',
    batch = 'BATCH',
    family_keyword = 'FAMILY',
    interactive = 'INTERACTIVE',
    job_keyword = 'JOB',
    job_class_keyword = 'JOB_CLASS',
    job_mode_keyword = 'JOB_MODE',
    mass_storage_class_keyword = 'MASS_STORAGE_CLASS',
    max_volumes_per_file = 500,
    one_second = 1000,
    set_keyword = 'SET',
    user_keyword = 'USER',
    utility_name = 'MANAGE_EXCEPTION_POLICIES      ',
    utility_prompt = 'MEP',
    volumes_keyword = 'VOLUMES';

  CONST
    login_users_fields = 4,
    number_of_fields = 17;

  VAR

?? FMT (FORMAT := OFF) ??
    action_names: [READ, oss$job_paged_literal] array [ost$ecp_action] of ost$name :=
          ['DELETE                         ', 'ENABLE_MATCHING_IMAGE          ',
           'ENABLE_NONMATCHING_IMAGE       ', 'EXIT                           ',
           'SET_DAMAGE_CONDITION           ', 'WAIT                           '],

{ The following subcommand images are the system default exception condition policies.
{ Generally, our default policy is to wait for an exception condition.  However, we
{ have a policy of special-casing the System Job so that it waits only for cycle busy
{ conditions.  This ensures that we do not lock up the console terminal in disaster
{ situations.  We wait for cycle busy conditions in the System Job because of the
{ potential use of magnetic tapes from the console and the corresponding wait for the
{ REMOVABLE_MEDIA_MANAGEMENT_SYSTEM (RMS) data base.

    default_policies: [READ, oss$job_paged_literal] array [1 .. 6] of string (286) := [
        'change_exception_policies files=all catalog_volume_unavailable=wait cycle_restoration_required=wait '
  CAT   'volume_unavailable=wait polling_frequency=60                                                        '
  CAT   '                                                                  ',

        'change_exception_policies files=all data_retrieval_required=wait polling_frequency=35               '
  CAT   '                                                                                                    '
  CAT   '                                                                  ',

        'change_exception_policies files=all file_server_inactive=wait polling_frequency=30                  '
  CAT   '                                                                                                    '
  CAT   '                                                                  ',

        'change_exception_policies files=all space_unavailable=wait polling_frequency=10                     '
  CAT   '                                                                                                    '
  CAT   '                                                                  ',

        'change_exception_policies files=all cycle_busy=wait polling_frequency=7                             '
  CAT   '                                                                                                    '
  CAT   '                                                                  ',

        'change_exception_policies jobs=$aaa_0000 catalog_volume_unavailable=exit cycle_busy=wait            '
  CAT   'cycle_restoration_required=exit data_retrieval_required=exit file_server_inactive=exit              '
  CAT   'space_unavailable=wait volume_unavailable=exit polling_frequency=5'],

    function_field_names: [READ, oss$job_paged_literal] array [osc$fp_null .. osc$fp_volumes] of
          ost$name := ['NULL                           ', 'JOB_CLASSES                    ',
                       'JOB_MODE                       ', 'JOBS                           ',
                       'LOGIN_USERS                    ', 'FAMILIES                       ',
                       'FILES                          ', 'MASS_STORAGE_CLASSES           ',
                       'SETS                           ', 'VOLUMES                        '],

    header_initialization_record: [READ, oss$job_paged_literal] ost$ecp_header := [
     {first_policy} NIL,
     {last_accessed_policy} 0,
     {last_policy} NIL,
     {number_of_policies} 0,
     {segment_p} [amc$sequence_pointer, NIL],
     {system_default_policies} FALSE],

    policy_initialization_record: [READ, oss$job_paged_literal] ost$ecp_policy_header := [
     {next_policy} NIL,
     {jobs} NIL,
     {login_users} NIL,
     {job_mode.specified} [FALSE],
     {job_classes} NIL,
     {files.specified} [FALSE],
     {mass_storage_classes.specified} [FALSE],
     {volumes} NIL,
     {families} NIL,
     {sets} NIL,
     {conditions} [
    ['CATALOG_VOLUME_UNAVAILABLE     ', osc$fp_catalog_vol_unavailable,
     $fst$file_access_conditions [fsc$catalog_volume_unavailable, fsc$catalog_media_missing] , FALSE],
    ['CYCLE_BUSY                     ', osc$fp_cycle_busy,
     $fst$file_access_conditions [fsc$cycle_busy                                           ] , FALSE],
    ['CYCLE_RESTORATION_REQUIRED     ', osc$fp_cycle_restoration_req,
     $fst$file_access_conditions [fsc$data_restoration_required                            ] , FALSE],
    ['DATA_RETRIEVAL_REQUIRED        ', osc$fp_data_retrieval_req,
     $fst$file_access_conditions [fsc$data_retrieval_required                              ] , FALSE],
    ['FILE_SERVER_INACTIVE           ', osc$fp_file_server_inactive,
     $fst$file_access_conditions [fsc$file_server_inactive                                 ] , FALSE],
    ['SPACE_UNAVAILABLE              ', osc$fp_space_unavailable,
     $fst$file_access_conditions [fsc$space_unavailable                                    ] , FALSE],
    ['VOLUME_UNAVAILABLE             ', osc$fp_volume_unavailable,
     $fst$file_access_conditions [fsc$volume_unavailable, fsc$media_missing                ] , FALSE]],
     {polling_frequency.specified} [FALSE]],

    login_users_names: [READ, oss$job_paged_literal] array [ost$ecp_specified_login_field] of
          ost$name := ['USER                           ', 'FAMILY                         ',
                       'JOB_CLASS                      ', 'JOB_MODE                       '],

?? FMT (FORMAT := ON) ??
    polling_frequency_name: [READ, oss$job_paged_literal] ost$name := 'POLLING_FREQUENCY              ';

?? NEWTITLE := 'osp$_manage_exception_policies', EJECT ??

{ PURPOSE:
{   This is the starting procedure for the MANAGE_EXCEPTION_POLICIES utility.

  PROCEDURE [XDCL, #GATE] osp$_manage_exception_policies
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manep) manage_exception_policies, manep (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [92, 4, 3, 11, 13, 0, 973],
    clc$command, 1, 1, 0, 0, 0, 0, 1, ''], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

{ table n=man_ecp_subcommands t=command sn=oss$job_paged_literal
{ command n=(change_exception_policies, change_exception_policy, chaep)    ..
{   p=osp$_change_exception_policies cm=local a=normal_usage    ..
{   log=automatic
{ command n=(delete_exception_policy, delete_exception_policies, delep)    ..
{   p=osp$_delete_exception_policies cm=local a=normal_usage    ..
{   log=automatic
{ command n=(display_applicable_policy, disap)            ..
{   p=osp$_display_applicable_policy cm=local a=normal_usage    ..
{   log=automatic
{ command n=(display_exception_policy, display_exception_policies, disep)  ..
{   p=osp$_display_exception_policies cm=local a=normal_usage    ..
{   log=automatic
{ command n=(install_default_policies, install_default_policy, insdp)      ..
{   p=osp$_install_default_policies cm=local a=normal_usage    ..
{   log=automatic
{ command n=(install_exception_policies, install_exception_policy, insep)  ..
{   p=osp$_install_exception_policies cm=local a=normal_usage    ..
{   log=automatic
{ command n=(quit, end_manage_exception_policies, qui)            ..
{   p=osp$_end_manecp cm=local a=normal_usage log=automatic
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  man_ecp_subcommands: [STATIC, READ, oss$job_paged_literal]
      ^clt$command_table := ^man_ecp_subcommands_entries,

  man_ecp_subcommands_entries: [STATIC, READ, oss$job_paged_literal]
      array [1 .. 20] of clt$command_table_entry := [
  {} ['CHAEP                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^osp$_change_exception_policies],
  {} ['CHANGE_EXCEPTION_POLICIES      ', clc$nominal_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^osp$_change_exception_policies],
  {} ['CHANGE_EXCEPTION_POLICY        ', clc$alias_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^osp$_change_exception_policies],
  {} ['DELEP                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^osp$_delete_exception_policies],
  {} ['DELETE_EXCEPTION_POLICIES      ', clc$alias_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^osp$_delete_exception_policies],
  {} ['DELETE_EXCEPTION_POLICY        ', clc$nominal_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^osp$_delete_exception_policies],
  {} ['DISAP                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^osp$_display_applicable_policy],
  {} ['DISEP                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^osp$_display_exception_policies],
  {} ['DISPLAY_APPLICABLE_POLICY      ', clc$nominal_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^osp$_display_applicable_policy],
  {} ['DISPLAY_EXCEPTION_POLICIES     ', clc$alias_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^osp$_display_exception_policies],
  {} ['DISPLAY_EXCEPTION_POLICY       ', clc$nominal_entry,
        clc$normal_usage_entry, 4, clc$automatically_log, clc$linked_call,
        ^osp$_display_exception_policies],
  {} ['END_MANAGE_EXCEPTION_POLICIES  ', clc$alias_entry,
        clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
        ^osp$_end_manecp],
  {} ['INSDP                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
        ^osp$_install_default_policies],
  {} ['INSEP                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
        ^osp$_install_exception_policies],
  {} ['INSTALL_DEFAULT_POLICIES       ', clc$nominal_entry,
        clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
        ^osp$_install_default_policies],
  {} ['INSTALL_DEFAULT_POLICY         ', clc$alias_entry,
        clc$normal_usage_entry, 5, clc$automatically_log, clc$linked_call,
        ^osp$_install_default_policies],
  {} ['INSTALL_EXCEPTION_POLICIES     ', clc$nominal_entry,
        clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
        ^osp$_install_exception_policies],
  {} ['INSTALL_EXCEPTION_POLICY       ', clc$alias_entry,
        clc$normal_usage_entry, 6, clc$automatically_log, clc$linked_call,
        ^osp$_install_exception_policies],
  {} ['QUI                            ', clc$abbreviation_entry,
        clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
        ^osp$_end_manecp],
  {} ['QUIT                           ', clc$nominal_entry,
        clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
        ^osp$_end_manecp]];

?? POP ??
{ table n=man_ecp_functions t=function sn=oss$job_paged_literal
{ function n=$applicable_policy p=osp$$applicable_policy
{ function n=$criteria p=osp$$criteria
{ function n=$exception_policy p=osp$$exception_policy

?? PUSH (LISTEXT := ON) ??

    VAR
      man_ecp_functions: [STATIC, READ, oss$job_paged_literal] ^clt$function_processor_table :=
            ^man_ecp_functions_entries,

      man_ecp_functions_entries: [STATIC, READ, oss$job_paged_literal] array [1 .. 3] of
            clt$function_proc_table_entry := [
            {} ['$APPLICABLE_POLICY             ', clc$nominal_entry, clc$normal_usage_entry, 1,
            clc$linked_call, ^osp$$applicable_policy],
            {} ['$CRITERIA                      ', clc$nominal_entry, clc$normal_usage_entry, 2,
            clc$linked_call, ^osp$$criteria],
            {} ['$EXCEPTION_POLICY              ', clc$nominal_entry, clc$normal_usage_entry, 3,
            clc$linked_call, ^osp$$exception_policy]];

?? POP ??

?? EJECT ??

    VAR
      file_id: amt$file_identifier,
      manep_utility_attributes: ^clt$utility_attributes,
      sequence_headers: array [ost$ecp_sequence_index] of ^ost$ecp_header,
      segment_pointer: amt$segment_pointer;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF status.normal THEN

      PUSH manep_utility_attributes: [1 .. 3];
      manep_utility_attributes^ [1].key := clc$utility_prompt;
      manep_utility_attributes^ [1].prompt.value := utility_prompt;
      manep_utility_attributes^ [1].prompt.size := clp$trimmed_string_size
            (manep_utility_attributes^ [1].prompt.value);

      manep_utility_attributes^ [2].key := clc$utility_command_table;
      manep_utility_attributes^ [2].command_table := man_ecp_subcommands;

      manep_utility_attributes^ [3].key := clc$utility_function_proc_table;
      manep_utility_attributes^ [3].function_processor_table := man_ecp_functions;

      clp$begin_utility (utility_name, manep_utility_attributes^, status);

      IF status.normal THEN
        initialize_session_segment (sequence_headers [osc$ecp_session_policies], status);
        IF status.normal THEN
          initialize_installed_segment (sequence_headers [osc$ecp_installed_policies], status);
          IF status.normal THEN
            osp$store_sequence_headers (sequence_headers, status);
            IF status.normal THEN
              clp$include_file (clc$current_command_input, {ignore prompt} '', utility_name, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
      clp$end_utility (utility_name, status);
    IFEND;


  PROCEND osp$_manage_exception_policies;
?? OLDTITLE ??
?? NEWTITLE := 'osp$_change_exception_policies', EJECT ??

  PROCEDURE osp$_change_exception_policies
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ A correspondence must be maintained between the ordinal values of type
{ ost$ecp_function_param_ordinal and the order of the parameters of this
{ subcommand.  This ensures that the order of the parameter values
{ displayed by DISPLAY_EXCEPTION_POLICIES and $EXCEPTION_POLICIES is the
{ same as CHAEP.

{ A correspondence must also be maintained between the ordinal values of type
{ ost$ecp_specified_login_field and the order of the fields of the
{ LOGIN_USERS parameter of this subcommand.  This ensures that the order of
{ the parameter values displayed by DISPLAY_EXCEPTION_POLICIES and
{ $EXCEPTION_POLICIES is the same as CHAEP.

{ The CHECK_POLICY_SEMANTICS procedure depends on the order of the "who",
{ "what", and "which" parameters below remaining the same.  If you add a
{ parameter 1) before JOB_CLASSES, 2) after VOLUMES, or 3) after VOLUME_UNAVAILABLE,
{ you will have to change the use of the 'p$' constants in that procedure.

{ If you add ANY parameters to this subcommand, you must modify the ordinal type
{ ost$ecp_function_param_ordinal and review the preceding comments.

{ PROCEDURE (osm$manep_chaep) change_exception_policies, change_exception_policy, chaep (
{   job_classes, job_class, jc: (BY_NAME) list of name = $optional
{   job_mode, jm: (BY_NAME) key
{       (batch, b)
{       (interactive, i)
{     keyend = $optional
{   jobs, job, j: (BY_NAME) list of name = $optional
{   login_users, login_user, lu: (BY_NAME) list of record
{       user: name
{       family: name = $optional
{       job_class: name = $optional
{       job_mode: key
{         (batch, b)
{         (interactive, i)
{       keyend = $optional
{     recend = $optional
{   families, family, fn: (BY_NAME) list of name = $optional
{   files, c, catalog, catalogs, file, f: (BY_NAME) any of
{       key
{         all
{       keyend
{       list defer_expansion of file
{     anyend = $optional
{   mass_storage_classes, mass_storage_class, msc: (BY_NAME) any of
{       list of key
{         (nosve_defined, nd)
{         (site_defined, sd)
{         (system_catalogs, sc)
{         (system_critical_files, scf)
{         (system_objects, so)
{         (system_permanent_files, spf, system_files, sf)
{         (system_products, sp)
{         (temporary_files, tf)
{         (user_catalogs, uc)
{         (user_objects, uo)
{         (user_permanent_files, user_files, upf, uf)
{       keyend
{       list 1..25 of name 1..1
{     anyend = $optional
{   sets, set, s: (BY_NAME) list of name = $optional
{   volumes, volume, v: (BY_NAME) list of name 1..6 = $optional
{   catalog_volume_unavailable, catalog_media_missing, cmm, cvu: (BY_NAME) key
{       (exit, e)
{       (wait, w)
{     keyend = $optional
{   cycle_busy, cb: (BY_NAME) key
{       (exit, e)
{       (wait, w)
{     keyend = $optional
{   cycle_restoration_required, ud, undefined_data, crr: (BY_NAME, CHECK) any of
{       key
{         (wait, w)
{       keyend
{       list of key
{         (delete, d)
{         (enable_matching_image, emi)
{         (enable_nonmatching_image, eni)
{         (set_damage_condition, sdc)
{       keyend
{       list of key
{         (enable_matching_image, emi)
{         (enable_nonmatching_image, eni)
{         (exit, e)
{         (set_damage_condition, sdc)
{       keyend
{     anyend = $optional
{   data_retrieval_required, drr: (BY_NAME) key
{       (exit, e)
{       (wait, w)
{     keyend = $optional
{   file_server_inactive, fsi: (BY_NAME) key
{       (exit, e)
{       (wait, w)
{     keyend = $optional
{   space_unavailable, su: (BY_NAME) key
{       (exit, e)
{       (wait, w)
{     keyend = $optional
{   volume_unavailable, media_missing, mm, vu: (BY_NAME, CHECK) any of
{       key
{         (wait, w)
{       keyend
{       list of key
{         (delete, d)
{         (enable_matching_image, emi)
{         (enable_nonmatching_image, eni)
{         (set_damage_condition, sdc)
{       keyend
{       list of key
{         (enable_matching_image, emi)
{         (enable_nonmatching_image, eni)
{         (exit, e)
{         (set_damage_condition, sdc)
{       keyend
{     anyend = $optional
{   polling_frequency, pf: integer 1..31622400 = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 52] of clt$pdt_parameter_name,
      parameters: array [1 .. 18] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 4] of clt$keyword_specification,
          recend,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type6: 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,
          recend,
        recend,
      recend,
      type7: 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$list_type_qualifier_v2,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 26] of clt$keyword_specification,
          recend,
        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$name_type_qualifier,
          recend,
        recend,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type12: 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 .. 2] 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 .. 8] of clt$keyword_specification,
          recend,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: 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 .. 8] of clt$keyword_specification,
          recend,
        recend,
      recend,
      type13: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type14: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type15: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type16: 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 .. 2] 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 .. 8] of clt$keyword_specification,
          recend,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: 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 .. 8] of clt$keyword_specification,
          recend,
        recend,
      recend,
      type17: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type18: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 12, 20, 17, 40, 22, 585],
    clc$command, 52, 18, 0, 0, 0, 0, 18, 'OSM$MANEP_CHAEP'], [
    ['C                              ',clc$alias_entry, 6],
    ['CATALOG                        ',clc$alias_entry, 6],
    ['CATALOGS                       ',clc$alias_entry, 6],
    ['CATALOG_MEDIA_MISSING          ',clc$alias_entry, 10],
    ['CATALOG_VOLUME_UNAVAILABLE     ',clc$nominal_entry, 10],
    ['CB                             ',clc$abbreviation_entry, 11],
    ['CMM                            ',clc$alias_entry, 10],
    ['CRR                            ',clc$abbreviation_entry, 12],
    ['CVU                            ',clc$abbreviation_entry, 10],
    ['CYCLE_BUSY                     ',clc$nominal_entry, 11],
    ['CYCLE_RESTORATION_REQUIRED     ',clc$nominal_entry, 12],
    ['DATA_RETRIEVAL_REQUIRED        ',clc$nominal_entry, 13],
    ['DRR                            ',clc$abbreviation_entry, 13],
    ['F                              ',clc$abbreviation_entry, 6],
    ['FAMILIES                       ',clc$nominal_entry, 5],
    ['FAMILY                         ',clc$alias_entry, 5],
    ['FILE                           ',clc$alias_entry, 6],
    ['FILES                          ',clc$nominal_entry, 6],
    ['FILE_SERVER_INACTIVE           ',clc$nominal_entry, 14],
    ['FN                             ',clc$abbreviation_entry, 5],
    ['FSI                            ',clc$abbreviation_entry, 14],
    ['J                              ',clc$abbreviation_entry, 3],
    ['JC                             ',clc$abbreviation_entry, 1],
    ['JM                             ',clc$abbreviation_entry, 2],
    ['JOB                            ',clc$alias_entry, 3],
    ['JOBS                           ',clc$nominal_entry, 3],
    ['JOB_CLASS                      ',clc$alias_entry, 1],
    ['JOB_CLASSES                    ',clc$nominal_entry, 1],
    ['JOB_MODE                       ',clc$nominal_entry, 2],
    ['LOGIN_USER                     ',clc$alias_entry, 4],
    ['LOGIN_USERS                    ',clc$nominal_entry, 4],
    ['LU                             ',clc$abbreviation_entry, 4],
    ['MASS_STORAGE_CLASS             ',clc$alias_entry, 7],
    ['MASS_STORAGE_CLASSES           ',clc$nominal_entry, 7],
    ['MEDIA_MISSING                  ',clc$alias_entry, 16],
    ['MM                             ',clc$alias_entry, 16],
    ['MSC                            ',clc$abbreviation_entry, 7],
    ['PF                             ',clc$abbreviation_entry, 17],
    ['POLLING_FREQUENCY              ',clc$nominal_entry, 17],
    ['S                              ',clc$abbreviation_entry, 8],
    ['SET                            ',clc$alias_entry, 8],
    ['SETS                           ',clc$nominal_entry, 8],
    ['SPACE_UNAVAILABLE              ',clc$nominal_entry, 15],
    ['STATUS                         ',clc$nominal_entry, 18],
    ['SU                             ',clc$abbreviation_entry, 15],
    ['UD                             ',clc$alias_entry, 12],
    ['UNDEFINED_DATA                 ',clc$alias_entry, 12],
    ['V                              ',clc$abbreviation_entry, 9],
    ['VOLUME                         ',clc$alias_entry, 9],
    ['VOLUMES                        ',clc$nominal_entry, 9],
    ['VOLUME_UNAVAILABLE             ',clc$nominal_entry, 16],
    ['VU                             ',clc$abbreviation_entry, 16]],
    [
{ PARAMETER 1
    [28, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [31, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 337,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 83, clc$optional_parameter,
  0, 0],
{ PARAMETER 7
    [34, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1026,
  clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [42, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 9
    [50, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 10
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 12
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 743,
  clc$optional_parameter, 0, 0],
{ PARAMETER 13
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 14
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 15
    [43, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 16
    [51, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 743,
  clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [39, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 18
    [44, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BATCH                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['INTERACTIVE                    ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 3
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 4
    [[1, 0, clc$list_type], [321, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [4],
      ['USER                           ', clc$required_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['FAMILY                         ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['JOB_CLASS                      ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['JOB_MODE                       ', clc$optional_field, 155], [[1, 0, clc$keyword_type], [4], [
        ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['BATCH                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['INTERACTIVE                    ', clc$nominal_entry, clc$normal_usage_entry, 2]]
        ]
      ]
    ],
{ PARAMETER 5
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 6
    [[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]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, TRUE, FALSE],
        [[1, 0, clc$file_type]]
      ]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$list_type],
    FALSE, 2],
    985, [[1, 0, clc$list_type], [969, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [26], [
        ['ND                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['NOSVE_DEFINED                  ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['SC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['SCF                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['SD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['SF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['SITE_DEFINED                   ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['SO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['SP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
        ['SPF                            ', clc$alias_entry, clc$normal_usage_entry, 6],
        ['SYSTEM_CATALOGS                ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['SYSTEM_CRITICAL_FILES          ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['SYSTEM_FILES                   ', clc$alias_entry, clc$normal_usage_entry, 6],
        ['SYSTEM_OBJECTS                 ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['SYSTEM_PERMANENT_FILES         ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['SYSTEM_PRODUCTS                ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['TEMPORARY_FILES                ', clc$nominal_entry, clc$normal_usage_entry, 8],
        ['TF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
        ['UC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
        ['UF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
        ['UO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
        ['UPF                            ', clc$alias_entry, clc$normal_usage_entry, 11],
        ['USER_CATALOGS                  ', clc$nominal_entry, clc$normal_usage_entry, 9],
        ['USER_FILES                     ', clc$alias_entry, clc$normal_usage_entry, 11],
        ['USER_OBJECTS                   ', clc$nominal_entry, clc$normal_usage_entry, 10],
        ['USER_PERMANENT_FILES           ', clc$nominal_entry, clc$normal_usage_entry, 11]]
        ]
      ],
    21, [[1, 0, clc$list_type], [5, 1, 25, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, 1]]
      ]
    ],
{ PARAMETER 8
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 9
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, 6]]
    ],
{ PARAMETER 10
    [[1, 0, clc$keyword_type], [4], [
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['EXIT                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['WAIT                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 11
    [[1, 0, clc$keyword_type], [4], [
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['EXIT                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['WAIT                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 12
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 3],
    81, [[1, 0, clc$keyword_type], [2], [
      ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['WAIT                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    319, [[1, 0, clc$list_type], [303, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [8], [
        ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['DELETE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['EMI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['ENABLE_MATCHING_IMAGE          ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['ENABLE_NONMATCHING_IMAGE       ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['ENI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['SDC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['SET_DAMAGE_CONDITION           ', clc$nominal_entry, clc$normal_usage_entry, 4]]
        ]
      ],
    319, [[1, 0, clc$list_type], [303, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [8], [
        ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['EMI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['ENABLE_MATCHING_IMAGE          ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['ENABLE_NONMATCHING_IMAGE       ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['ENI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['EXIT                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['SDC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['SET_DAMAGE_CONDITION           ', clc$nominal_entry, clc$normal_usage_entry, 4]]
        ]
      ]
    ],
{ PARAMETER 13
    [[1, 0, clc$keyword_type], [4], [
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['EXIT                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['WAIT                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 14
    [[1, 0, clc$keyword_type], [4], [
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['EXIT                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['WAIT                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 15
    [[1, 0, clc$keyword_type], [4], [
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['EXIT                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['WAIT                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 16
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 3],
    81, [[1, 0, clc$keyword_type], [2], [
      ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['WAIT                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    319, [[1, 0, clc$list_type], [303, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [8], [
        ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['DELETE                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['EMI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['ENABLE_MATCHING_IMAGE          ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['ENABLE_NONMATCHING_IMAGE       ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['ENI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['SDC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['SET_DAMAGE_CONDITION           ', clc$nominal_entry, clc$normal_usage_entry, 4]]
        ]
      ],
    319, [[1, 0, clc$list_type], [303, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [8], [
        ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['EMI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['ENABLE_MATCHING_IMAGE          ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['ENABLE_NONMATCHING_IMAGE       ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['ENI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['EXIT                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['SDC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['SET_DAMAGE_CONDITION           ', clc$nominal_entry, clc$normal_usage_entry, 4]]
        ]
      ]
    ],
{ PARAMETER 17
    [[1, 0, clc$integer_type], [1, 31622400, 10]],
{ PARAMETER 18
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$job_classes = 1,
      p$job_mode = 2,
      p$jobs = 3,
      p$login_users = 4,
      p$families = 5,
      p$files = 6,
      p$mass_storage_classes = 7,
      p$sets = 8,
      p$volumes = 9,
      p$catalog_volume_unavailable = 10,
      p$cycle_busy = 11,
      p$cycle_restoration_required = 12,
      p$data_retrieval_required = 13,
      p$file_server_inactive = 14,
      p$space_unavailable = 15,
      p$volume_unavailable = 16,
      p$polling_frequency = 17,
      p$status = 18;

    VAR
      pvt: array [1 .. 18] of clt$parameter_value;


    VAR
      header_p: ^ost$ecp_policy_header;

?? NEWTITLE := 'check_policy_semantics', EJECT ??

  PROCEDURE check_policy_semantics
    (    pvt: ^clt$parameter_value_table;
         which_parameter: clt$which_parameter;
     VAR status: ost$status);

    VAR
      actions: ost$ecp_actions,
      at_least_one_specified: boolean,
      i: p$job_classes .. p$volume_unavailable,
      node: ^clt$data_value;

{ Design:  This procedure validates that at least one "who" or "what" parameter is
{ specified and at least one exception condition or "which" parameter is specified.
{ It also validates that if SET_DAMAGE_CONDITION is specified so must the
{ ENABLE_NONMATCHING_IMAGE option.

{ This procedure assumes that all of the "who" and "what" parameters are contiguous
{ in the PDT starting with JOB_CLASSES and ending with VOLUMES.  It also assumes
{ that all of the "which" parameters are contiguous in the PDT starting with
{ CATALOG_VOLUME_UNAVAILABLE and ending with VOLUME_UNAVAILABLE.

    status.normal := TRUE;

    IF which_parameter.specific THEN
      actions := $ost$ecp_actions [];
      IF pvt^ [which_parameter.number].value^.kind = clc$list THEN
        node := pvt^ [which_parameter.number].value;
        WHILE node <> NIL DO
          IF node^.element_value^.keyword_value = action_names [osc$ecp_enable_nonmatch_image] THEN
            actions := actions + $ost$ecp_actions [osc$ecp_enable_nonmatch_image];
          ELSEIF node^.element_value^.keyword_value = action_names [osc$ecp_set_damage_condition] THEN
            actions := actions + $ost$ecp_actions [osc$ecp_set_damage_condition];
          IFEND;
          node := node^.link;
        WHILEND;
      IFEND;
      IF (osc$ecp_set_damage_condition IN actions) AND NOT (osc$ecp_enable_nonmatch_image IN actions) THEN
        osp$set_status_condition (ose$eni_required_with_sdc, status);
      IFEND;
    ELSE {Verify overall semantics of command}
      {1. There must be at least one condition specified and at least one criterion
      at_least_one_specified := FALSE;

      FOR i := p$job_classes TO p$volumes DO
        at_least_one_specified := at_least_one_specified OR pvt^ [i].specified;
      FOREND;

      IF at_least_one_specified THEN
        at_least_one_specified := FALSE;
        FOR i := p$catalog_volume_unavailable TO p$volume_unavailable DO
          at_least_one_specified := at_least_one_specified OR pvt^ [i].specified;
        FOREND;
        IF NOT at_least_one_specified THEN
          osp$set_status_condition (ose$object_of_policy_missing, status);
          RETURN;
        IFEND;
      ELSE
        osp$set_status_condition (ose$subject_of_policy_missing, status);
        RETURN;
      IFEND;

      { Offline conditions should not have criteria that require the file to be online
      IF pvt^ [p$cycle_restoration_required].specified OR pvt^ [p$data_retrieval_required].specified THEN
        IF pvt^ [p$mass_storage_classes].specified OR pvt^ [p$volumes].specified THEN
          osp$set_status_condition (ose$offline_condition, status);
          RETURN;
        IFEND;
      IFEND;
    IFEND;

  PROCEND check_policy_semantics;
?? OLDTITLE ??
?? NEWTITLE := 'process_exception_condition', EJECT ??

    PROCEDURE process_exception_condition
      (    parameter_number: ost$positive_integers);

      VAR
        i: ost$ecp_number_of_conditions,
        node: ^clt$data_value;

      FOR i := 1 TO UPPERBOUND (header_p^.conditions) DO
        IF parameter_number = $INTEGER (header_p^.conditions [i].exception_ordinal) THEN

          header_p^.conditions [i].specified := TRUE;
          header_p^.conditions [i].actions := $ost$ecp_actions [];

          IF pvt [parameter_number].value^.kind = clc$keyword THEN
            IF pvt [parameter_number].value^.keyword_value = action_names [osc$ecp_delete] THEN
              header_p^.conditions [i].actions := header_p^.conditions [i].
                    actions + $ost$ecp_actions [osc$ecp_delete];
            ELSEIF pvt [parameter_number].value^.keyword_value = action_names [osc$ecp_exit] THEN
              header_p^.conditions [i].actions := header_p^.conditions [i].
                    actions + $ost$ecp_actions [osc$ecp_exit];
            ELSEIF pvt [parameter_number].value^.keyword_value = action_names [osc$ecp_wait] THEN
              header_p^.conditions [i].actions := header_p^.conditions [i].
                    actions + $ost$ecp_actions [osc$ecp_wait];
            IFEND;
          ELSE {list of key}
            node := pvt [parameter_number].value;
            WHILE node <> NIL DO
              IF node^.element_value^.keyword_value = action_names [osc$ecp_delete] THEN
                header_p^.conditions [i].actions := header_p^.conditions [i].
                      actions + $ost$ecp_actions [osc$ecp_delete];
              ELSEIF node^.element_value^.keyword_value = action_names [osc$ecp_enable_matching_image] THEN
                header_p^.conditions [i].actions := header_p^.conditions [i].
                      actions + $ost$ecp_actions [osc$ecp_enable_matching_image];
              ELSEIF node^.element_value^.keyword_value = action_names [osc$ecp_enable_nonmatch_image] THEN
                header_p^.conditions [i].actions := header_p^.conditions [i].
                      actions + $ost$ecp_actions [osc$ecp_enable_nonmatch_image];
              ELSEIF node^.element_value^.keyword_value = action_names [osc$ecp_exit] THEN
                header_p^.conditions [i].actions := header_p^.conditions [i].
                      actions + $ost$ecp_actions [osc$ecp_exit];
              ELSEIF node^.element_value^.keyword_value = action_names [osc$ecp_set_damage_condition] THEN
                header_p^.conditions [i].actions := header_p^.conditions [i].
                      actions + $ost$ecp_actions [osc$ecp_set_damage_condition];
              IFEND;
              node := node^.link;
            WHILEND;
          IFEND;
        IFEND;
      FOREND;
    PROCEND process_exception_condition;
?? OLDTITLE ??
?? NEWTITLE := 'process_files', EJECT ??

    PROCEDURE process_files
      (VAR files {output} : ost$ecp_files;
       VAR policies_p {input, output} : ^SEQ ( * ));

{ Design:

{ File paths are fully evaluated by clp$evaluate_parameters unless the file
{ path evaluation is deferred, i.e.  it 1) begins with :$USER, :$FAMILY, or
{ 2) contains a WILD CARD reference and evaluation is DEFERRED (as it is here).

{ This procedure classifies a file reference as 1) an evaludated file reference,
{ 2) a generic file reference, or 3) a WILD CARD reference.  Classifications
{ 2 and 3 are stored in an unevaluated form until an exception condition
{ occurs; then these two file expressions are "evaluated" within the affected
{ job's environment for a possible match with the affected file path.

      VAR
        count: clt$list_size,
        evaluated_file_reference: fst$evaluated_file_reference,
        file_node: ^clt$data_value,
        i: ost$positive_integers,
        ignore_path_size: fst$path_size,
        path: fst$path,
        path_size: fst$path_size,
        scl_options: ^clt$scl_options;

      files.specified := TRUE;
      IF pvt [p$files].value^.kind = clc$keyword THEN
        files.all_specified := TRUE;
      ELSE {list of file}
        files.all_specified := FALSE;
        count := clp$count_list_elements (pvt [p$files].value);

        NEXT files.path_list: [1 .. count] IN policies_p;
        IF files.path_list <> NIL THEN
          file_node := pvt [p$files].value;
          FOR i := 1 TO count DO
            clp$evaluate_file_reference (file_node^.element_value^.file_value^,
                  $clt$file_ref_parsing_options [clc$multiple_reference_allowed], FALSE,
                  evaluated_file_reference, status);
            IF status.normal THEN
              clp$convert_file_ref_to_string (evaluated_file_reference, TRUE, path, ignore_path_size, status);
              IF status.normal THEN
                path_size := clp$trimmed_string_size (file_node^.element_value^.file_value^);
                NEXT files.path_list^ [i].path: [path_size] IN policies_p;
                IF files.path_list^ [i].path <> NIL THEN
                  files.path_list^ [i].path^ := file_node^.element_value^.file_value^ (1, path_size);

                  IF evaluated_file_reference.multiple_reference_specified THEN
                    clp$find_scl_options (scl_options);
                    files.path_list^ [i].file_reference_type := osc$ecp_wild_card_reference;
                    files.path_list^ [i].wild_card_pattern_type := scl_options^.wild_card_pattern_type;
                  ELSE
                    IF path (1, path_size) = file_node^.element_value^.file_value^ (1, path_size) THEN
                      files.path_list^ [i].file_reference_type := osc$ecp_evaluated_reference;
                    ELSE
                      files.path_list^ [i].file_reference_type := osc$ecp_generic_reference;
                    IFEND;
                  IFEND;
                IFEND;
              ELSE
                RESET osv$ecp_sequence_headers [osc$ecp_session_policies]^.segment_p.
                      sequence_pointer TO header_p;
                EXIT osp$_change_exception_policies;
              IFEND;
            IFEND;
            file_node := file_node^.link;
          FOREND;
        ELSE
          osp$set_status_condition (ose$internal_workspace_full, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'MANAGE_EXCEPTION_POLICIES - process_files', status);
          EXIT osp$_change_exception_policies;
        IFEND;
      IFEND;

    PROCEND process_files;
?? OLDTITLE ??
?? NEWTITLE := 'process_job_mode', EJECT ??

    PROCEDURE process_job_mode
      (VAR job_mode: ost$ecp_job_mode);

      job_mode.specified := TRUE;
      IF pvt [p$job_mode].value^.keyword_value = batch THEN
        job_mode.value := jmc$batch;
      ELSE {INTERACTIVE}
        job_mode.value := jmc$interactive_connected;
      IFEND;

    PROCEND process_job_mode;
?? OLDTITLE ??
?? NEWTITLE := 'process_login_users', EJECT ??

    PROCEDURE process_login_users
      (VAR login_users: ^ost$ecp_login_users_list;
       VAR policies_p {input, output} : ^SEQ ( * ));

      VAR
        count: clt$list_size,
        i: ost$positive_integers,
        j: ost$positive_integers,
        name_list: ^ost$ecp_name_list,
        node: ^clt$data_value;

      login_users := NIL;
      count := clp$count_list_elements (pvt [p$login_users].value);

      NEXT login_users: [1 .. count] IN policies_p;
      IF login_users <> NIL THEN
        node := pvt [p$login_users].value;
        FOR i := 1 TO count DO
          login_users^ [i].specified_fields := $ost$ecp_specified_login_fields [osc$lu_user_name];
          FOR j := 1 TO UPPERBOUND (node^.element_value^.field_values^) DO
            IF node^.element_value^.field_values^ [j].name = user_keyword THEN
              login_users^ [i].user_name := node^.element_value^.field_values^ [j].value^.name_value;
            ELSEIF node^.element_value^.field_values^ [j].name = family_keyword THEN
              IF node^.element_value^.field_values^ [j].value <> NIL THEN
                login_users^ [i].specified_fields := login_users^ [i].specified_fields +
                      $ost$ecp_specified_login_fields [osc$lu_family_name];
                login_users^ [i].family_name := node^.element_value^.field_values^ [j].value^.name_value;
              IFEND;
            ELSEIF node^.element_value^.field_values^ [j].name = job_class_keyword THEN
              IF node^.element_value^.field_values^ [j].value <> NIL THEN
                login_users^ [i].specified_fields := login_users^ [i].specified_fields +
                      $ost$ecp_specified_login_fields [osc$lu_job_class];
                login_users^ [i].job_class := node^.element_value^.field_values^ [j].value^.name_value;
              IFEND;
            ELSE {JOB_MODE}
              IF node^.element_value^.field_values^ [j].value <> NIL THEN
                login_users^ [i].specified_fields := login_users^ [i].specified_fields +
                      $ost$ecp_specified_login_fields [osc$lu_job_mode];
                IF node^.element_value^.field_values^ [j].value^.keyword_value = batch THEN
                  login_users^ [i].job_mode := jmc$batch;
                ELSE {INTERACTIVE}
                  login_users^ [i].job_mode := jmc$interactive_connected;
                IFEND;
              IFEND;
            IFEND;
          FOREND;
          node := node^.link;
        FOREND;
      ELSE
        osp$set_status_condition (ose$internal_workspace_full, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              'MANAGE_EXCEPTION_POLICIES - process_login_users', status);
        RESET osv$ecp_sequence_headers [osc$ecp_session_policies]^.segment_p.sequence_pointer TO header_p;
        EXIT osp$_change_exception_policies;
      IFEND;

    PROCEND process_login_users;
?? OLDTITLE ??
?? NEWTITLE := 'process_ms_classes', EJECT ??

    PROCEDURE process_ms_classes
      (VAR ms_classes: ost$ecp_ms_classes);

      VAR
        name_node: ^clt$data_value;

      ms_classes.specified := TRUE;
      ms_classes.value := $dmt$class [];
      name_node := pvt [p$mass_storage_classes].value;
      WHILE name_node <> NIL DO
        IF name_node^.element_value^.kind = clc$keyword THEN
          IF name_node^.element_value^.keyword_value = 'NOSVE_DEFINED' THEN
            ms_classes.value := ms_classes.value + $dmt$class ['J', 'K', 'L', 'M', 'N', 'P', 'Q'];
          ELSEIF name_node^.element_value^.keyword_value = 'SITE_DEFINED' THEN
            ms_classes.value := ms_classes.value + $dmt$class ['U', 'V', 'W', 'X', 'Y', 'Z'];
          ELSEIF name_node^.element_value^.keyword_value = 'SYSTEM_CATALOGS' THEN
            ms_classes.value := ms_classes.value + $dmt$class ['J'];
          ELSEIF name_node^.element_value^.keyword_value = 'SYSTEM_CRITICAL_FILES' THEN
            ms_classes.value := ms_classes.value + $dmt$class ['Q'];
          ELSEIF name_node^.element_value^.keyword_value = 'SYSTEM_OBJECTS' THEN
            ms_classes.value := ms_classes.value + $dmt$class ['J', 'K', 'P', 'Q'];
          ELSEIF name_node^.element_value^.keyword_value = 'SYSTEM_PERMANENT_FILES' THEN
            ms_classes.value := ms_classes.value + $dmt$class ['K', 'P'];
          ELSEIF name_node^.element_value^.keyword_value = 'SYSTEM_PRODUCTS' THEN
            ms_classes.value := ms_classes.value + $dmt$class ['P'];
          ELSEIF name_node^.element_value^.keyword_value = 'TEMPORARY_FILES' THEN
            ms_classes.value := ms_classes.value + $dmt$class ['N'];
          ELSEIF name_node^.element_value^.keyword_value = 'USER_CATALOGS' THEN
            ms_classes.value := ms_classes.value + $dmt$class ['L'];
          ELSEIF name_node^.element_value^.keyword_value = 'USER_OBJECTS' THEN
            ms_classes.value := ms_classes.value + $dmt$class ['L', 'M', 'N'];
          ELSEIF name_node^.element_value^.keyword_value = 'USER_PERMANENT_FILES' THEN
            ms_classes.value := ms_classes.value + $dmt$class ['M'];
          ELSE
          IFEND;
        ELSE {name}
          ms_classes.value := ms_classes.value + $dmt$class [name_node^.element_value^.name_value (1, 1)];
        IFEND;
        name_node := name_node^.link;
      WHILEND;

    PROCEND process_ms_classes;
?? OLDTITLE ??
?? NEWTITLE := 'process_names', EJECT ??

    PROCEDURE process_names
      (    parameter_ordinal: ost$positive_integers;
       VAR policies_p {input, output} : ^SEQ ( * );
       VAR result_p {output} : ^ost$ecp_name_list);

      VAR
        count: clt$list_size,
        i: ost$positive_integers,
        name_node: ^clt$data_value;

      result_p := NIL;
      count := clp$count_list_elements (pvt [parameter_ordinal].value);

      NEXT result_p: [1 .. count] IN policies_p;
      IF result_p <> NIL THEN
        name_node := pvt [parameter_ordinal].value;
        FOR i := 1 TO count DO
          result_p^ [i] := name_node^.element_value^.name_value;
          name_node := name_node^.link;
        FOREND;
      ELSE
        osp$set_status_condition (ose$internal_workspace_full, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              'MANAGE_EXCEPTION_POLICIES - process_names', status);
        RESET osv$ecp_sequence_headers [osc$ecp_session_policies]^.segment_p.sequence_pointer TO header_p;
        EXIT osp$_change_exception_policies;
      IFEND;

    PROCEND process_names;
?? OLDTITLE ??
?? NEWTITLE := 'process_volumes', EJECT ??

    PROCEDURE process_volumes
      (VAR policies_p {input, output} : ^SEQ ( * );
       VAR volumes {output} : ^ost$ecp_volume_list);

      VAR
        count: clt$list_size,
        i: ost$positive_integers,
        name_node: ^clt$data_value;

      name_node := pvt [p$volumes].value;
      count := clp$count_list_elements (pvt [p$volumes].value);

      NEXT volumes: [1 .. count] IN policies_p;
      IF volumes <> NIL THEN
        name_node := pvt [p$volumes].value;
        FOR i := 1 TO count DO
          volumes^ [i] := name_node^.element_value^.name_value (1, 6);
          name_node := name_node^.link;
        FOREND;
      ELSE
        osp$set_status_condition (ose$internal_workspace_full, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              'MANAGE_EXCEPTION_POLICIES - process_volumes', status);
        RESET osv$ecp_sequence_headers [osc$ecp_session_policies]^.segment_p.sequence_pointer TO header_p;
        EXIT osp$_change_exception_policies;
      IFEND;

    PROCEND process_volumes;
?? OLDTITLE ??
?? EJECT ??

    VAR
      i: ost$positive_integers,
      jm_name: jmt$name,
      validated_name: jmt$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_policy_semantics, ^pvt, status);
    IF status.normal THEN

    /process_command/
      BEGIN
        NEXT header_p IN osv$ecp_sequence_headers [osc$ecp_session_policies]^.segment_p.sequence_pointer;
        header_p^ := policy_initialization_record;

        { Process "who" parameters
        IF pvt [p$job_classes].specified THEN
          process_names (p$job_classes, osv$ecp_sequence_headers [osc$ecp_session_policies]^.segment_p.
                sequence_pointer, header_p^.job_classes);
        IFEND;
        IF pvt [p$job_mode].specified THEN
          process_job_mode (header_p^.job_mode);
        IFEND;
        IF pvt [p$jobs].specified THEN
          process_names (p$jobs, osv$ecp_sequence_headers [osc$ecp_session_policies]^.segment_p.
                sequence_pointer, header_p^.jobs);
          FOR i := 1 TO UPPERBOUND (header_p^.jobs^) DO
            jm_name.kind := jmc$system_supplied_name;
            jm_name.system_supplied_name := header_p^.jobs^ [i];
            jmp$validate_name (jm_name, validated_name, status);
            IF status.normal THEN
              header_p^.jobs^ [i] := validated_name.system_supplied_name;
            ELSE
              EXIT /process_command/;
            IFEND;
          FOREND;
        IFEND;

        IF pvt [p$login_users].specified THEN
          process_login_users (header_p^.login_users, osv$ecp_sequence_headers [osc$ecp_session_policies]^.
                segment_p.sequence_pointer);
        IFEND;

        { Process "what" parameters
        IF pvt [p$families].specified THEN
          process_names (p$families, osv$ecp_sequence_headers [osc$ecp_session_policies]^.segment_p.
                sequence_pointer, header_p^.families);
        IFEND;
        IF pvt [p$files].specified THEN
          process_files (header_p^.files, osv$ecp_sequence_headers [osc$ecp_session_policies]^.segment_p.
                sequence_pointer);
        IFEND;
        IF pvt [p$mass_storage_classes].specified THEN
          process_ms_classes (header_p^.mass_storage_classes);
        IFEND;
        IF pvt [p$sets].specified THEN
          process_names (p$sets, osv$ecp_sequence_headers [osc$ecp_session_policies]^.segment_p.
                sequence_pointer, header_p^.sets);
        IFEND;
        IF pvt [p$volumes].specified THEN
          process_volumes (osv$ecp_sequence_headers [osc$ecp_session_policies]^.segment_p.sequence_pointer,
                header_p^.volumes);
        IFEND;

        { Process "exception" parameters
        IF pvt [p$catalog_volume_unavailable].specified THEN
          process_exception_condition (p$catalog_volume_unavailable);
        IFEND;
        IF pvt [p$cycle_busy].specified THEN
          process_exception_condition (p$cycle_busy);
        IFEND;
        IF pvt [p$cycle_restoration_required].specified THEN
          process_exception_condition (p$cycle_restoration_required);
        IFEND;
        IF pvt [p$data_retrieval_required].specified THEN
          process_exception_condition (p$data_retrieval_required);
        IFEND;
        IF pvt [p$file_server_inactive].specified THEN
          process_exception_condition (p$file_server_inactive);
        IFEND;
        IF pvt [p$space_unavailable].specified THEN
          process_exception_condition (p$space_unavailable);
        IFEND;
        IF pvt [p$volume_unavailable].specified THEN
          process_exception_condition (p$volume_unavailable);
        IFEND;

        IF pvt [p$polling_frequency].specified THEN
          header_p^.polling_frequency.specified := TRUE;
          header_p^.polling_frequency.value := pvt [p$polling_frequency].value^.integer_value.value;
        IFEND;

        IF (osv$ecp_sequence_headers [osc$ecp_session_policies] <> NIL) THEN
          IF osv$ecp_sequence_headers [osc$ecp_session_policies]^.first_policy = NIL THEN
            osv$ecp_sequence_headers [osc$ecp_session_policies]^.first_policy := header_p;
          IFEND;
          header_p^.next_policy := NIL;
          IF osv$ecp_sequence_headers [osc$ecp_session_policies]^.last_policy <> NIL THEN
            osv$ecp_sequence_headers [osc$ecp_session_policies]^.last_policy^.next_policy := header_p;
          IFEND;
          osv$ecp_sequence_headers [osc$ecp_session_policies]^.last_policy := header_p;
          osv$ecp_sequence_headers [osc$ecp_session_policies]^.number_of_policies :=
                osv$ecp_sequence_headers [osc$ecp_session_policies]^.number_of_policies + 1;
          osv$ecp_sequence_headers [osc$ecp_session_policies]^.last_accessed_policy :=
                osv$ecp_sequence_headers [osc$ecp_session_policies]^.last_accessed_policy + 1;
        IFEND;
      END /process_command/;
    IFEND; {parameter evaluation}

  PROCEND osp$_change_exception_policies;
?? OLDTITLE ??
?? NEWTITLE := 'osp$_delete_exception_policies', EJECT ??

  PROCEDURE osp$_delete_exception_policies
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manep_delep) delete_exception_policy, delete_exception_policies, delep (
{   delete_option, do: key
{       (all, a)
{       (last, ldp, last_defined_policy, l)
{     keyend = last
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 6, 25, 9, 42, 4, 335],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$MANEP_DELEP'], [
    ['DELETE_OPTION                  ',clc$nominal_entry, 1],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [6], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['LAST                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['LAST_DEFINED_POLICY            ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['LDP                            ', clc$alias_entry, clc$normal_usage_entry, 2]]
    ,
    'last'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$delete_option = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      policy: ^ost$ecp_policy_header,
      policy_number: ost$positive_integers,
      reset_policy: ^ost$ecp_policy_header,
      session_segment: amt$segment_pointer;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);

    IF status.normal THEN
      IF (osv$ecp_sequence_headers [osc$ecp_session_policies] <> NIL) AND
            (osv$ecp_sequence_headers [osc$ecp_session_policies]^.number_of_policies > 0) THEN
        IF (pvt [p$delete_option].value^.keyword_value = all_keyword) OR
              (osv$ecp_sequence_headers [osc$ecp_session_policies]^.number_of_policies = 1) THEN
          session_segment := osv$ecp_sequence_headers [osc$ecp_session_policies]^.segment_p;
          reset_policy := osv$ecp_sequence_headers [osc$ecp_session_policies]^.first_policy;
          osv$ecp_sequence_headers [osc$ecp_session_policies]^ := header_initialization_record;
          osv$ecp_sequence_headers [osc$ecp_session_policies]^.segment_p := session_segment;
          RESET osv$ecp_sequence_headers [osc$ecp_session_policies]^.segment_p.
                sequence_pointer TO reset_policy;
        ELSE
          policy := osv$ecp_sequence_headers [osc$ecp_session_policies]^.first_policy;

          WHILE policy^.next_policy <> osv$ecp_sequence_headers [osc$ecp_session_policies]^.last_policy DO
            policy := policy^.next_policy;
          WHILEND;

          RESET osv$ecp_sequence_headers [osc$ecp_session_policies]^.segment_p.
                sequence_pointer TO osv$ecp_sequence_headers [osc$ecp_session_policies]^.last_policy;
          policy^.next_policy := NIL;
          osv$ecp_sequence_headers [osc$ecp_session_policies]^.last_policy := policy;
          osv$ecp_sequence_headers [osc$ecp_session_policies]^.number_of_policies :=
                osv$ecp_sequence_headers [osc$ecp_session_policies]^.number_of_policies - 1;
          osv$ecp_sequence_headers [osc$ecp_session_policies]^.last_accessed_policy := 0;
        IFEND;
      ELSE
        osp$set_status_condition (ose$no_session_policies_defined, status);
      IFEND;
    IFEND;

  PROCEND osp$_delete_exception_policies;

?? OLDTITLE ??
?? NEWTITLE := 'osp$_display_applicable_policy', EJECT ??

  PROCEDURE osp$_display_applicable_policy
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manep_disap) display_applicable_policy, disap (
{   criteria, c: record
{       condition: key
{         (catalog_volume_unavailable, catalog_media_missing, cmm, cvu)
{         (cycle_busy, cb)
{         (cycle_restoration_required, ud, undefined_data, crr)
{         (data_retrieval_required, drr)
{         (file_server_inactive, fsi)
{         (space_unavailable, su)
{         (volume_unavailable, media_missing, mm, vu)
{       keyend
{       family_path_name: name
{       file: file
{       job: name
{       job_class: name
{       job_mode: key
{         (batch, b)
{         (interactive, i)
{       keyend
{       login_family: name
{       login_user: name
{       mass_storage_class: name 1..1 = $optional
{       set: name = $optional
{       volumes: list of name 1..6 = $optional
{     recend = $required
{   source, s: key
{       (installed_policies, ip)
{       (utility_session, us)
{     keyend = utility_session
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 20] of clt$keyword_specification,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
        recend,
        field_spec_4: clt$field_specification,
        element_type_spec_4: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_5: clt$field_specification,
        element_type_spec_5: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_6: clt$field_specification,
        element_type_spec_6: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        field_spec_7: clt$field_specification,
        element_type_spec_7: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_8: clt$field_specification,
        element_type_spec_8: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_9: clt$field_specification,
        element_type_spec_9: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_10: clt$field_specification,
        element_type_spec_10: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_11: clt$field_specification,
        element_type_spec_11: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier_v2,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (15),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [93, 1, 17, 16, 15, 57, 605],
    clc$command, 7, 4, 1, 0, 0, 0, 4, 'OSM$MANEP_DISAP'], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CRITERIA                       ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['S                              ',clc$abbreviation_entry, 2],
    ['SOURCE                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1364,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 15],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$record_type], [11],
    ['CONDITION                      ', clc$required_field, 747], [[1, 0, clc$keyword_type], [20], [
      ['CATALOG_MEDIA_MISSING          ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['CATALOG_VOLUME_UNAVAILABLE     ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['CB                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['CMM                            ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['CRR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['CVU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['CYCLE_BUSY                     ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['CYCLE_RESTORATION_REQUIRED     ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['DATA_RETRIEVAL_REQUIRED        ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['DRR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['FILE_SERVER_INACTIVE           ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['FSI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['MEDIA_MISSING                  ', clc$alias_entry, clc$normal_usage_entry, 7],
      ['MM                             ', clc$alias_entry, clc$normal_usage_entry, 7],
      ['SPACE_UNAVAILABLE              ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['SU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['UD                             ', clc$alias_entry, clc$normal_usage_entry, 3],
      ['UNDEFINED_DATA                 ', clc$alias_entry, clc$normal_usage_entry, 3],
      ['VOLUME_UNAVAILABLE             ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['VU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7]]
      ],
    ['FAMILY_PATH_NAME               ', clc$required_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['FILE                           ', clc$required_field, 3], [[1, 0, clc$file_type]],
    ['JOB                            ', clc$required_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['JOB_CLASS                      ', clc$required_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['JOB_MODE                       ', clc$required_field, 155], [[1, 0, clc$keyword_type], [4], [
      ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['BATCH                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['INTERACTIVE                    ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    ['LOGIN_FAMILY                   ', clc$required_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['LOGIN_USER                     ', clc$required_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['MASS_STORAGE_CLASS             ', clc$optional_field, 5], [[1, 0, clc$name_type], [1, 1]],
    ['SET                            ', clc$optional_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['VOLUMES                        ', clc$optional_field, 21], [[1, 0, clc$list_type], [5, 0,
  clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, 6]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['INSTALLED_POLICIES             ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['IP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['US                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['UTILITY_SESSION                ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'utility_session'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$criteria = 1,
      p$source = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

*copy clv$display_variables
?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;

*copy clp$new_page_procedure
?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle ', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

      {The presence of this procedure is required by clp$put_display but subtitling
      {is not desired.

    PROCEND put_subtitle;
?? OLDTITLE, EJECT ??

    VAR
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      empty_display: boolean,
      local_status: ost$status,
      representation: ^clt$data_representation,
      result: ^clt$data_value,
      scratch_segment: amt$segment_pointer,
      work_area: ^clt$work_area;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);

    IF status.normal THEN
      display_control := clv$nil_display_control;
      #SPOIL (display_control);
      osp$establish_block_exit_hndlr (^abort_handler);

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, scratch_segment, status);
      IF status.normal THEN
        work_area := scratch_segment.sequence_pointer;
        default_ring_attributes.r1 := #RING (^default_ring_attributes);
        default_ring_attributes.r2 := #RING (^default_ring_attributes);
        default_ring_attributes.r3 := #RING (^default_ring_attributes);

        clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
              default_ring_attributes, display_control, status);
        IF status.normal THEN
          clv$titles_built := FALSE;
          clv$command_name := 'DISPLAY_APPLICABLE_POLICY';

          IF display_control.page_width < clc$narrow_page_width THEN
            clv$page_width := clc$narrow_page_width;
          ELSEIF display_control.page_width > clc$wide_page_width THEN
            clv$page_width := clc$wide_page_width;
          ELSE
            clv$page_width := display_control.page_width;
          IFEND;

          make_$applicable_policy (p$criteria, pvt, p$source, empty_display, result, work_area, status);

          IF status.normal AND (result <> NIL) AND (NOT empty_display) THEN
            IF (display_control.page_format = amc$burstable_form) OR
                  (display_control.page_format = amc$non_burstable_form) THEN
              clp$new_display_page (display_control, status);
            IFEND;

            IF status.normal THEN
              clp$convert_data_to_string (result, clc$labeled_elem_representation, display_control.
                    page_width, work_area, representation, status);
              IF status.normal THEN
                clp$put_data_representation (display_control, representation, status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
        mmp$delete_scratch_segment (scratch_segment, local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;
      IFEND;
    IFEND;

    IF display_control.file_id <> amv$nil_file_identifier THEN
      clp$close_display (display_control, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND osp$_display_applicable_policy;
?? OLDTITLE ??
?? NEWTITLE := 'osp$_display_exception_policies', EJECT ??

  PROCEDURE osp$_display_exception_policies
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manep_disep) display_exception_policy, display_exception_policies, disep (
{   display_option, do: any of
{       key
{         (all, a)
{         (first, f)
{         (last, last_accessed_policy, lap, l)
{         (next, n)
{       keyend
{       integer
{     anyend = last
{   source, s: key
{       (installed_policies, ip)
{       (utility_session, us)
{     keyend = utility_session
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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 .. 10] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (15),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 6, 23, 12, 14, 59, 276],
    clc$command, 7, 4, 0, 0, 0, 0, 4, 'OSM$MANEP_DISEP'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 1],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['S                              ',clc$abbreviation_entry, 2],
    ['SOURCE                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 417,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 15],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    377, [[1, 0, clc$keyword_type], [10], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['FIRST                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['LAP                            ', clc$alias_entry, clc$normal_usage_entry, 3],
      ['LAST                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['LAST_ACCESSED_POLICY           ', clc$alias_entry, clc$normal_usage_entry, 3],
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['NEXT                           ', clc$nominal_entry, clc$normal_usage_entry, 4]]
      ],
    20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]]
    ,
    'last'],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['INSTALLED_POLICIES             ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['IP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['US                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['UTILITY_SESSION                ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'utility_session'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$display_option = 1,
      p$source = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

*copy clv$display_variables

    VAR
      policy_number: ost$positive_integers;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;

*copy clp$new_page_procedure
?? OLDTITLE ??
?? TITLE := 'put_subtitle ', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

      {The presence of this procedure is required by clp$put_display but subtitling
      {is not desired.

    PROCEND put_subtitle;
?? OLDTITLE, EJECT ??

    CONST
      max_subtitle_length = 30;

    VAR
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      empty_display: boolean,
      length: integer,
      local_status: ost$status,
      representation: ^clt$data_representation,
      result: ^clt$data_value,
      scratch_segment: amt$segment_pointer,
      subtitle: string (max_subtitle_length),
      work_area: ^clt$work_area;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);

    IF status.normal THEN
      display_control := clv$nil_display_control;
      #SPOIL (display_control);
      osp$establish_block_exit_hndlr (^abort_handler);

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, scratch_segment, status);
      IF status.normal THEN
        work_area := scratch_segment.sequence_pointer;
        default_ring_attributes.r1 := #RING (^default_ring_attributes);
        default_ring_attributes.r2 := #RING (^default_ring_attributes);
        default_ring_attributes.r3 := #RING (^default_ring_attributes);

        clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
              default_ring_attributes, display_control, status);
        IF status.normal THEN
          clv$titles_built := FALSE;
          clv$command_name := 'DISPLAY_EXCEPTION_POLICY';

          IF display_control.page_width < clc$narrow_page_width THEN
            clv$page_width := clc$narrow_page_width;
          ELSEIF display_control.page_width > clc$wide_page_width THEN
            clv$page_width := clc$wide_page_width;
          ELSE
            clv$page_width := display_control.page_width;
          IFEND;

          make_$exception_policies (p$display_option, pvt, p$source, empty_display, result, work_area,
                status);

          IF status.normal AND (result <> NIL) AND (NOT empty_display) THEN
            IF (display_control.page_format = amc$burstable_form) OR
                  (display_control.page_format = amc$non_burstable_form) THEN
              clp$new_display_page (display_control, status);
            IFEND;

            IF status.normal THEN
              IF result^.kind = clc$list THEN
                policy_number := 1;

                WHILE status.normal AND (result <> NIL) DO
                  clp$convert_data_to_string (result^.element_value, clc$labeled_elem_representation,
                        display_control.page_width, work_area, representation, status);
                  IF status.normal THEN
                    STRINGREP (subtitle, length, 'Policy Number:', policy_number);
                    clp$put_display (display_control, subtitle (1, length), clc$trim, status);
                    IF status.normal THEN
                      clp$new_display_line (display_control, {skip_count} 1, status);
                      IF status.normal THEN
                        clp$put_data_representation (display_control, representation, status);
                        result := result^.link;
                        IF result <> NIL THEN
                          clp$new_display_line (display_control, {skip_count} 2, status);
                          IF status.normal THEN
                            policy_number := policy_number + 1;
                          IFEND;
                        IFEND;
                      IFEND;
                    IFEND;
                  IFEND;
                WHILEND;
              ELSE
                clp$convert_data_to_string (result, clc$labeled_elem_representation,
                      display_control.page_width, work_area, representation, status);
                IF status.normal THEN
                  clp$put_data_representation (display_control, representation, status);
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
        mmp$delete_scratch_segment (scratch_segment, status);
      IFEND;
    IFEND;

    IF display_control.file_id <> amv$nil_file_identifier THEN
      clp$close_display (display_control, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND osp$_display_exception_policies;
?? OLDTITLE ??
?? NEWTITLE := 'osp$_end_manecp', EJECT ??

  PROCEDURE osp$_end_manecp
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manep_qui) quit, qui (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [92, 4, 3, 13, 30, 14, 105],
    clc$command, 1, 1, 0, 0, 0, 0, 1, ''], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF status.normal THEN
      clp$end_include (utility_name, status);
    IFEND;

  PROCEND osp$_end_manecp;
?? OLDTITLE ??
?? NEWTITLE := 'osp$_install_default_policies', EJECT ??

  PROCEDURE osp$_install_default_policies
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manep_insdp) install_default_policies, insdp (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [92, 6, 1, 10, 43, 35, 561],
    clc$command, 1, 1, 0, 0, 0, 0, 1, ''], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      obsolete_segment: amt$segment_pointer,
      sequence_headers: array [ost$ecp_sequence_index] of ^ost$ecp_header;

?? NEWTITLE := 'install_default_policies', EJECT ??

    PROCEDURE install_default_policies
      (VAR status: ost$status);

      VAR
        i: ost$positive_integers;

      FOR i := 1 TO UPPERBOUND (default_policies) DO
        clp$include_command (default_policies [i], {enable_echoing} FALSE, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

      osv$ecp_sequence_headers [osc$ecp_session_policies]^.system_default_policies := TRUE;

      install_exception_policies (osv$ecp_sequence_headers [osc$ecp_session_policies]^.segment_p.
            sequence_pointer, status);

    PROCEND install_default_policies;
?? OLDTITLE, EJECT ??
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF status.normal THEN
      IF (osv$ecp_sequence_headers [osc$ecp_session_policies] = NIL) OR
            (osv$ecp_sequence_headers [osc$ecp_session_policies]^.number_of_policies = 0) THEN
        install_default_policies (status);
        IF status.normal THEN
          IF osv$ecp_sequence_headers [osc$ecp_installed_policies] <> NIL THEN
            obsolete_segment := osv$ecp_sequence_headers [osc$ecp_installed_policies]^.segment_p;
          ELSE
            obsolete_segment.sequence_pointer := NIL;
          IFEND;
          sequence_headers [osc$ecp_installed_policies] := osv$ecp_sequence_headers
                [osc$ecp_session_policies];
          IF obsolete_segment.sequence_pointer <> NIL THEN
            mmp$delete_scratch_segment (obsolete_segment, status);
          IFEND;
          IF status.normal THEN
            initialize_session_segment (sequence_headers [osc$ecp_session_policies], status);
            IF status.normal THEN
              osp$store_sequence_headers (sequence_headers, status);
            IFEND;
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (ose$session_policies_defined, status);
      IFEND;
    IFEND;

  PROCEND osp$_install_default_policies;
?? OLDTITLE ??
?? NEWTITLE := 'osp$_install_exception_policies', EJECT ??

  PROCEDURE osp$_install_exception_policies
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$manep_insep) install_exception_policies, insep (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [92, 4, 17, 14, 7, 3, 980],
    clc$command, 1, 1, 0, 0, 0, 0, 1, ''], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      exception_conditions: ost$ecp_conditions,
      ignore_policy_criteria: ost$ecp_policy_criteria,
      obsolete_segment: amt$segment_pointer,
      sequence_headers: array [ost$ecp_sequence_index] of ^ost$ecp_header;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF status.normal THEN
      IF (osv$ecp_sequence_headers [osc$ecp_session_policies] <> NIL) AND
            (osv$ecp_sequence_headers [osc$ecp_session_policies]^.number_of_policies > 0) THEN
        osp$get_union_of_policies (osv$ecp_sequence_headers [osc$ecp_session_policies], exception_conditions,
              ignore_policy_criteria, status);
        IF status.normal THEN
          analyze_policy_coverage (exception_conditions, status);
          IF status.normal THEN
            install_exception_policies (osv$ecp_sequence_headers [osc$ecp_session_policies]^.segment_p.
                  sequence_pointer, status);
            IF status.normal THEN
              IF osv$ecp_sequence_headers [osc$ecp_installed_policies] <> NIL THEN
                obsolete_segment := osv$ecp_sequence_headers [osc$ecp_installed_policies]^.segment_p;
              ELSE
                obsolete_segment.sequence_pointer := NIL;
              IFEND;
              sequence_headers [osc$ecp_installed_policies] :=
                    osv$ecp_sequence_headers [osc$ecp_session_policies];
              IF obsolete_segment.sequence_pointer <> NIL THEN
                mmp$delete_scratch_segment (obsolete_segment, status);
              IFEND;
              IF status.normal THEN
                initialize_session_segment (sequence_headers [osc$ecp_session_policies], status);
                IF status.normal THEN
                  osp$store_sequence_headers (sequence_headers, status);
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (ose$no_session_policies_defined, status);
      IFEND;
    IFEND;

  PROCEND osp$_install_exception_policies;
?? OLDTITLE ??
?? NEWTITLE := 'osp$$applicable_policy', EJECT ??

  PROCEDURE osp$$applicable_policy
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $applicable_policy (
{   criteria: record
{       condition: key
{         (catalog_volume_unavailable, catalog_media_missing, cmm, cvu)
{         (cycle_busy, cb)
{         (cycle_restoration_required, ud, undefined_data, crr)
{         (data_retrieval_required, drr)
{         (file_server_inactive, fsi)
{         (space_unavailable, su)
{         (volume_unavailable, media_missing, mm, vu)
{       keyend
{       family_path_name: name
{       file: file
{       job: name
{       job_class: name
{       job_mode: key
{         (batch, b)
{         (interactive, i)
{       keyend
{       login_family: name
{       login_user: name
{       mass_storage_class: name 1..1
{       set: name
{       volumes: list of name 1..6
{     recend = $required
{   source: key
{       (installed_policies, ip)
{       (utility_session, us)
{     keyend = utility_session
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 20] of clt$keyword_specification,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
        recend,
        field_spec_4: clt$field_specification,
        element_type_spec_4: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_5: clt$field_specification,
        element_type_spec_5: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_6: clt$field_specification,
        element_type_spec_6: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        field_spec_7: clt$field_specification,
        element_type_spec_7: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_8: clt$field_specification,
        element_type_spec_8: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_9: clt$field_specification,
        element_type_spec_9: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_10: clt$field_specification,
        element_type_spec_10: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        field_spec_11: clt$field_specification,
        element_type_spec_11: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier_v2,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (15),
      recend,
    recend := [
    [1,
    [92, 8, 17, 12, 40, 29, 848],
    clc$function, 2, 2, 1, 0, 0, 0, 0, ''], [
    ['CRITERIA                       ',clc$nominal_entry, 1],
    ['SOURCE                         ',clc$nominal_entry, 2]],
    [
{ 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, 1364,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, 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, 155,
  clc$optional_default_parameter, 0, 15]],
{ PARAMETER 1
    [[1, 0, clc$record_type], [11],
    ['CONDITION                      ', clc$required_field, 747], [[1, 0, clc$keyword_type], [20], [
      ['CATALOG_MEDIA_MISSING          ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['CATALOG_VOLUME_UNAVAILABLE     ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['CB                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['CMM                            ', clc$alias_entry, clc$normal_usage_entry, 1],
      ['CRR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['CVU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['CYCLE_BUSY                     ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['CYCLE_RESTORATION_REQUIRED     ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['DATA_RETRIEVAL_REQUIRED        ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['DRR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['FILE_SERVER_INACTIVE           ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['FSI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['MEDIA_MISSING                  ', clc$alias_entry, clc$normal_usage_entry, 7],
      ['MM                             ', clc$alias_entry, clc$normal_usage_entry, 7],
      ['SPACE_UNAVAILABLE              ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['SU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['UD                             ', clc$alias_entry, clc$normal_usage_entry, 3],
      ['UNDEFINED_DATA                 ', clc$alias_entry, clc$normal_usage_entry, 3],
      ['VOLUME_UNAVAILABLE             ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['VU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7]]
      ],
    ['FAMILY_PATH_NAME               ', clc$required_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['FILE                           ', clc$required_field, 3], [[1, 0, clc$file_type]],
    ['JOB                            ', clc$required_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['JOB_CLASS                      ', clc$required_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['JOB_MODE                       ', clc$required_field, 155], [[1, 0, clc$keyword_type], [4], [
      ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['BATCH                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['INTERACTIVE                    ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    ['LOGIN_FAMILY                   ', clc$required_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['LOGIN_USER                     ', clc$required_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['MASS_STORAGE_CLASS             ', clc$required_field, 5], [[1, 0, clc$name_type], [1, 1]],
    ['SET                            ', clc$required_field, 5], [[1, 0, clc$name_type], [1, osc$max_name_size]
  ],
    ['VOLUMES                        ', clc$required_field, 21], [[1, 0, clc$list_type], [5, 0,
  clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, 6]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['INSTALLED_POLICIES             ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['IP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['US                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['UTILITY_SESSION                ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'utility_session']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$criteria = 1,
      p$source = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      ignore_empty_display: boolean;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);

    IF status.normal THEN
      make_$applicable_policy (p$criteria, pvt, p$source, ignore_empty_display, result, work_area, status);
    IFEND;

  PROCEND osp$$applicable_policy;
?? OLDTITLE ??
?? NEWTITLE := 'osp$$criteria', EJECT ??

  PROCEDURE osp$$criteria
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $criteria (
{   condition: key
{       (catalog_volume_unavailable, catalog_media_missing, cmm, cvu)
{       (cycle_busy, cb)
{       (cycle_restoration_required, ud, undefined_data, crr)
{       (data_retrieval_required, drr)
{       (file_server_inactive, fsi)
{       (space_unavailable, su)
{       (volume_unavailable, media_missing, mm, vu)
{     keyend = $required
{   file: file = $required
{   job_mode: key
{       (batch, b)
{       (interactive, i)
{     keyend = $optional
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 20] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
    recend := [
    [1,
    [92, 4, 27, 12, 13, 10, 726],
    clc$function, 3, 3, 2, 0, 0, 0, 0, ''], [
    ['CONDITION                      ',clc$nominal_entry, 1],
    ['FILE                           ',clc$nominal_entry, 2],
    ['JOB_MODE                       ',clc$nominal_entry, 3]],
    [
{ 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, 747,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, 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, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [3, 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, 155,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [20], [
    ['CATALOG_MEDIA_MISSING          ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['CATALOG_VOLUME_UNAVAILABLE     ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['CB                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['CMM                            ', clc$alias_entry, clc$normal_usage_entry, 1],
    ['CRR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['CVU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CYCLE_BUSY                     ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['CYCLE_RESTORATION_REQUIRED     ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['DATA_RETRIEVAL_REQUIRED        ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['DRR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['FILE_SERVER_INACTIVE           ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['FSI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['MEDIA_MISSING                  ', clc$alias_entry, clc$normal_usage_entry, 7],
    ['MM                             ', clc$alias_entry, clc$normal_usage_entry, 7],
    ['SPACE_UNAVAILABLE              ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['SU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['UD                             ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['UNDEFINED_DATA                 ', clc$alias_entry, clc$normal_usage_entry, 3],
    ['VOLUME_UNAVAILABLE             ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['VU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7]]
    ],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BATCH                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['INTERACTIVE                    ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$condition = 1,
      p$file = 2,
      p$job_mode = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

?? POP ??

    CONST
      condition = 1,
      family_path_name = 2,
      file = 3,
      job = 4,
      job_class = 5,
      job_mode = 6,
      login_family = 7,
      login_user = 8,
      mass_storage_class = 9,
      set_name = 10,
      volume_list = 11,

      number_of_fields = 11;

    VAR
      criteria: ost$ecp_criteria,
      file_identifier: ost$ecp_file_identification,
      i: ost$positive_integers,
      ignore_volume_cond_list: ^fst$volume_condition_list,
      name1: string (1),
      node: ^^clt$data_value,
      sequence: ^SEQ ( * ),
      seq_size: ost$positive_integers;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);

    IF status.normal THEN
      file_identifier.selector := osc$ecp_file_reference;
      file_identifier.file_reference := pvt [p$file].value^.file_value;

      seq_size := #SIZE (fst$goi_object_information) + fsc$max_path_size + #SIZE (fst$goi_object) +
            #SIZE (fst$device_information) + (max_volumes_per_file * (#SIZE (rmt$volume_descriptor) +
            #SIZE (fst$file_access_condition)));
      PUSH sequence: [[REP seq_size OF cell]];

      osp$get_login_user_criteria (criteria, status);
      IF status.normal THEN
        osp$get_file_criteria (file_identifier, {catalog_object} FALSE, {catalog_space_unavailable} FALSE,
               {password} osc$null_name, sequence, criteria, ignore_volume_cond_list, status);

        IF status.normal THEN
          clp$make_record_value (number_of_fields, work_area, result);

          node := ^result^.field_values^ [condition].value;
          result^.field_values^ [condition].name := 'CONDITION';
          clp$make_keyword_value (pvt [p$condition].value^.keyword_value, work_area, node^);

          node := ^result^.field_values^ [family_path_name].value;
          result^.field_values^ [family_path_name].name := 'FAMILY_PATH_NAME';
          clp$make_name_value (criteria.family_path_name, work_area, node^);

          node := ^result^.field_values^ [file].value;
          result^.field_values^ [file].name := 'FILE';
          IF criteria.file <> osc$null_name THEN
            clp$make_file_value (criteria.file, work_area, node^);
          ELSE
            clp$make_unspecified_value (work_area, node^);
          IFEND;

          node := ^result^.field_values^ [job].value;
          result^.field_values^ [job].name := job_keyword;
          clp$make_name_value (criteria.job, work_area, node^);

          node := ^result^.field_values^ [job_class].value;
          result^.field_values^ [job_class].name := job_class_keyword;
          clp$make_name_value (criteria.job_class, work_area, node^);

          node := ^result^.field_values^ [job_mode].value;
          result^.field_values^ [job_mode].name := job_mode_keyword;
          IF pvt [p$job_mode].specified THEN
            IF pvt [p$job_mode].value^.keyword_value = batch THEN
              criteria.job_mode := jmc$batch;
            ELSE {INTERACTIVE}
              criteria.job_mode := jmc$interactive_connected;
            IFEND;
          IFEND;
          IF criteria.job_mode = jmc$batch THEN
            clp$make_keyword_value (batch, work_area, node^);
          ELSE
            clp$make_keyword_value (interactive, work_area, node^);
          IFEND;

          node := ^result^.field_values^ [login_family].value;
          result^.field_values^ [login_family].name := 'LOGIN_FAMILY';
          clp$make_name_value (criteria.login_family, work_area, node^);

          node := ^result^.field_values^ [login_user].value;
          result^.field_values^ [login_user].name := 'LOGIN_USER';
          clp$make_name_value (criteria.login_user, work_area, node^);

          node := ^result^.field_values^ [mass_storage_class].value;
          result^.field_values^ [mass_storage_class].name := mass_storage_class_keyword;
          IF criteria.mass_storage_class <> rmc$unspecified_file_class THEN
            #UNCHECKED_CONVERSION (criteria.mass_storage_class, name1);
            clp$make_name_value (name1, work_area, node^);
          ELSE
            clp$make_unspecified_value (work_area, node^);
          IFEND;

          node := ^result^.field_values^ [set_name].value;
          result^.field_values^ [set_name].name := set_keyword;
          IF criteria.set_name <> osc$null_name THEN
            clp$make_name_value (criteria.set_name, work_area, node^);
          ELSE
            clp$make_unspecified_value (work_area, node^);
          IFEND;

          node := ^result^.field_values^ [volume_list].value;
          result^.field_values^ [volume_list].name := volumes_keyword;
          IF criteria.volume_list <> NIL THEN
            FOR i := 1 TO UPPERBOUND (criteria.volume_list^) DO
              clp$make_list_value (work_area, node^);
              clp$make_name_value (criteria.volume_list^ [i].recorded_vsn, work_area, node^^.element_value);
              node := ^node^^.link;
            FOREND;
          ELSE
            clp$make_unspecified_value (work_area, node^);
          IFEND;

        IFEND;
        IF result = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '$CRITERIA', status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND osp$$criteria;
?? OLDTITLE ??
?? NEWTITLE := 'osp$$exception_policy', EJECT ??

  PROCEDURE osp$$exception_policy
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $exception_policy (
{   policy: any of
{       key
{         (all, a)
{         (first, f)
{         (last, last_accessed_policy, lap, l)
{         (next, n)
{       keyend
{       integer
{     anyend = last
{   source: key
{       (installed_policies, ip)
{       (utility_session, us)
{     keyend = utility_session
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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 .. 10] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (15),
      recend,
    recend := [
    [1,
    [92, 6, 23, 12, 16, 18, 13],
    clc$function, 2, 2, 0, 0, 0, 0, 0, ''], [
    ['POLICY                         ',clc$nominal_entry, 1],
    ['SOURCE                         ',clc$nominal_entry, 2]],
    [
{ 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, 417,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [2, 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, 155,
  clc$optional_default_parameter, 0, 15]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    377, [[1, 0, clc$keyword_type], [10], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['FIRST                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['LAP                            ', clc$alias_entry, clc$normal_usage_entry, 3],
      ['LAST                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['LAST_ACCESSED_POLICY           ', clc$alias_entry, clc$normal_usage_entry, 3],
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['NEXT                           ', clc$nominal_entry, clc$normal_usage_entry, 4]]
      ],
    20, [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]]
    ,
    'last'],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['INSTALLED_POLICIES             ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['IP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['US                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['UTILITY_SESSION                ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'utility_session']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$policy = 1,
      p$source = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      ignore_empty_display: boolean;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);

    IF status.normal THEN
      make_$exception_policies (p$policy, pvt, p$source, ignore_empty_display, result, work_area, status);
    IFEND;

  PROCEND osp$$exception_policy;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$chacc_applicable_policy', EJECT ??

  FUNCTION [XDCL, #GATE] osp$chacc_applicable_policy
    (    policy: ^ost$ecp_policy_header): boolean;

    VAR
      i: ost$positive_integers,
      ok: boolean,
      temp_file_count: ost$non_negative_integers;

    osp$chacc_applicable_policy := FALSE;
    IF policy <> NIL THEN
      ok := (policy^.jobs = NIL) AND (NOT policy^.job_mode.specified) AND (policy^.job_classes = NIL);
      IF ok THEN
        IF (policy^.login_users <> NIL) THEN
          FOR i := LOWERBOUND (policy^.login_users^) TO UPPERBOUND (policy^.login_users^) DO
            IF (policy^.login_users^ [i].specified_fields * $ost$ecp_specified_login_fields
                  [osc$lu_job_class, osc$lu_job_mode]) <> $ost$ecp_specified_login_fields [] THEN
              RETURN;
            IFEND;
          FOREND;
        IFEND;

        IF policy^.files.specified AND (NOT policy^.files.all_specified) THEN
          temp_file_count := 0;
          FOR i := LOWERBOUND (policy^.files.path_list^) TO UPPERBOUND (policy^.files.path_list^) DO
            IF policy^.files.path_list^ [i].file_reference_type <> osc$ecp_generic_reference THEN
              IF temporary_file (policy^.files.path_list^ [i].path^) THEN
                temp_file_count := temp_file_count + 1;
              IFEND;
            IFEND;
          FOREND;
          {If the policy's file list consists only of temporary files, it does not apply to CHACC
          IF temp_file_count = UPPERBOUND (policy^.files.path_list^) THEN
            RETURN;
          IFEND;
        IFEND;

        FOR i := 1 TO UPPERBOUND (policy^.conditions) DO
          IF policy^.conditions [i].specified THEN
            IF (($fst$file_access_conditions [fsc$data_restoration_required, fsc$volume_unavailable,
                  fsc$media_missing] * policy^.conditions [i].file_access_conditions) =
                  $fst$file_access_conditions []) THEN
              RETURN;
            ELSEIF (($ost$ecp_actions [osc$ecp_delete, osc$ecp_enable_matching_image,
                  osc$ecp_enable_nonmatch_image] * policy^.conditions [i].actions) = $ost$ecp_actions []) THEN
              RETURN;
            IFEND;
          IFEND;
        FOREND;
        osp$chacc_applicable_policy := TRUE;
      IFEND;
    IFEND;

  FUNCEND osp$chacc_applicable_policy;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$find_applicable_policy', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$find_applicable_policy
    (    criteria: ost$ecp_criteria;
         policies_sequence_header: ^ost$ecp_header;
     VAR applicable_actions: ost$ecp_actions;
     VAR applicable_policy: ^ost$ecp_policy_header;
     VAR status: ost$status);

*copyc osi$find_applicable_policy

    find_applicable_policy (criteria, policies_sequence_header, applicable_actions, applicable_policy,
          status);

  PROCEND osp$find_applicable_policy;
?? OLDTITLE ??
?? NEWTITLE := 'osp$get_file_criteria', EJECT ??

   PROCEDURE [XDCL, #GATE] osp$get_file_criteria
    (    file: ost$ecp_file_identification;
         catalog_object: boolean;
         catalog_space_unavailable: boolean;
         password: pft$name;
     VAR work_area {input, output} : ^SEQ ( * );
     VAR criteria: ost$ecp_criteria;
     VAR volume_condition_list: ^fst$volume_condition_list;
     VAR status: ost$status);

?? NEWTITLE := 'get_relevant_object_attributes', EJECT ??

    PROCEDURE get_relevant_object_attributes
      (    file_reference: fst$file_reference;
           validation_criteria: ^fst$goi_validation_criteria;
       VAR object_condition: fst$file_access_condition;
       VAR object_type: fst$goi_object_type;
       VAR mass_storage_class: dmt$class_member;
       VAR resolved_path: fst$path;
       VAR set_name: ost$name;
       VAR volume_condition_list: ^fst$volume_condition_list;
       VAR volume_list: ^rmt$volume_list;
       VAR status: ost$status);

      VAR
        information_request: fst$goi_information_request,
        object: ^fst$goi_object_information;

      status.normal := TRUE;
      object_condition := fsc$null_file_access_condition;
      object_type := fsc$goi_file_object;
      mass_storage_class := rmc$unspecified_file_class;
      resolved_path := osc$null_name;
      resolved_path (1, STRLENGTH (file_reference)) := file_reference (1, STRLENGTH (file_reference));
      set_name := osc$null_name;
      volume_condition_list := NIL;
      volume_list := NIL;

      RESET work_area;

      information_request.catalog_depth.depth_specification := fsc$specific_depth;
      information_request.catalog_depth.depth := 1;
      information_request.object_information_requests := $fst$goi_object_info_requests
            [fsc$goi_catalog_device_info, fsc$goi_cycle_device_info, fsc$goi_set_name];

      pfp$get_object_information (file_reference, information_request, validation_criteria, work_area,
            status);

      IF status.normal THEN
        RESET work_area;
        NEXT object IN work_area;
        IF object <> NIL THEN
          resolved_path := object^.resolved_path^;
          object_type := object^.object^.object_type;
          CASE object^.object^.object_type OF
          = fsc$goi_catalog_object =
            IF object^.object^.catalog_device_information <> NIL THEN
              IF object^.object^.catalog_device_information^.mass_storage_device_info.resides_online THEN
                object_condition := object^.object^.catalog_device_information^.mass_storage_device_info.
                      object_condition;
                mass_storage_class := object^.object^.catalog_device_information^.
                      mass_storage_device_info.mass_storage_class;
                volume_condition_list := object^.object^.catalog_device_information^.mass_storage_device_info.
                      volume_condition_list;
                volume_list := object^.object^.catalog_device_information^.mass_storage_device_info.
                      volume_list;
                set_name := object^.set_name;
              IFEND;
            IFEND;
          = fsc$goi_cycle_object =
            IF object^.object^.cycle_device_class = rmc$mass_storage_device THEN
              IF object^.object^.cycle_device_information <> NIL THEN
                IF object^.object^.cycle_device_information^.mass_storage_device_info.resides_online THEN
                  object_condition := object^.object^.cycle_device_information^.mass_storage_device_info.
                        object_condition;
                  mass_storage_class := object^.object^.cycle_device_information^.
                        mass_storage_device_info.mass_storage_class;
                  volume_condition_list := object^.object^.cycle_device_information^.mass_storage_device_info.
                        volume_condition_list;
                  volume_list := object^.object^.cycle_device_information^.mass_storage_device_info.
                        volume_list;
                  set_name := object^.set_name;
                IFEND;
              IFEND;
            IFEND;
          ELSE
          CASEND;
        IFEND;
      IFEND;
    PROCEND get_relevant_object_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'set_defaults_from_path', EJECT ??

  PROCEDURE set_defaults_from_path
    (    pf_path: ^pft$path);

    IF pf_path <> NIL THEN
      criteria.family_path_name := pf_path^ [pfc$family_name_index];
      criteria.mass_storage_class := fsp$default_file_class (pf_path^);
      IF catalog_object THEN
        CASE criteria.mass_storage_class OF
        = rmc$msc_system_permanent_files =
          criteria.mass_storage_class := rmc$msc_system_catalogs;
        = rmc$msc_user_permanent_files =
          criteria.mass_storage_class := rmc$msc_user_catalogs;
        ELSE
        CASEND;
      IFEND;
    IFEND;
  PROCEND set_defaults_from_path;
?? OLDTITLE ??

    VAR
      access_condition_entry: fst$access_condition_entry,
      entry_found: boolean,
      evaluated_file_reference: fst$evaluated_file_reference,
      fetch_attributes: ^array [1 .. 1] of amt$fetch_item,
      file_reference: ^fst$path,
      fs_path: ^fst$path,
      fs_path_size: fst$path_size,
      i: 1 .. fsc$max_path_size,
      ignore_file_instance: ^bat$task_file_entry,
      ignore_resolved_path: fst$path,
      local_status: ost$status,
      object_condition: fst$file_access_condition,
      object_type: fst$goi_object_type,
      original_file_ref: ^fst$path,
      parental_set_name: ost$name,
      pf_path: ^pft$path,
      resolved_file_reference: ^fst$resolved_file_reference,
      size: integer,
      validation_criteria: ^fst$goi_validation_criteria;

    status.normal := TRUE;

    criteria.family_path_name := osc$null_name;
    criteria.file := '';
    criteria.mass_storage_class := rmc$unspecified_file_class;
    criteria.set_name := osc$null_name;
    criteria.volume_list := NIL;

    volume_condition_list := NIL;

    pf_path := NIL;

    PUSH fs_path;

    CASE file.selector OF

    = osc$ecp_evaluated_file_ref =
      clp$convert_file_ref_to_string (file.evaluated_file_reference, {include_open_position} FALSE, fs_path^,
            fs_path_size, local_status);
      IF local_status.normal THEN
        criteria.file := fs_path^ (1, fs_path_size);
      IFEND;
      PUSH pf_path: [1 .. file.evaluated_file_reference.number_of_path_elements];
      fsp$convert_fs_structure_to_pf (file.evaluated_file_reference, pf_path);

    = osc$ecp_file_identifier =
      PUSH fetch_attributes;
      PUSH resolved_file_reference;
      fetch_attributes^ [1].key := amc$resolved_file_reference;
      fetch_attributes^ [1].resolved_file_reference := resolved_file_reference;

      amp$fetch (file.file_identifier, fetch_attributes^, local_status);
      IF local_status.normal THEN
        criteria.file := resolved_file_reference^.path (1, resolved_file_reference^.complete_path_size);
        clp$evaluate_file_reference (criteria.file, $clt$file_ref_parsing_options [], FALSE,
              evaluated_file_reference, local_status);
        IF local_status.normal THEN
          PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
          fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);
        IFEND;
      IFEND;

    = osc$ecp_file_reference =
      IF file.file_reference <> NIL THEN
        criteria.file := file.file_reference^;
        clp$evaluate_file_reference (file.file_reference^, $clt$file_ref_parsing_options [], FALSE,
              evaluated_file_reference, local_status);
        IF local_status.normal THEN
          PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
          fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);
        IFEND;
      ELSE
        criteria.file := osc$null_name;
      IFEND;

    = osc$ecp_file_segment =
      bap$find_open_file_via_segment (#SEGMENT (file.file_segment), ignore_file_instance, fs_path^,
            fs_path_size, entry_found);
      IF entry_found THEN
        criteria.file := fs_path^ (1, fs_path_size);
        clp$evaluate_file_reference (criteria.file, $clt$file_ref_parsing_options [], FALSE,
              evaluated_file_reference, local_status);
        IF local_status.normal THEN
          PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
          fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);
        IFEND;
      IFEND;

    = osc$ecp_pf_path =
      IF file.pf_path <> NIL THEN
        pf_path := file.pf_path;
        pfp$convert_pft$path_to_fs_str (file.pf_path^, evaluated_file_reference);
        IF catalog_object THEN
          evaluated_file_reference.cycle_reference.specification := fsc$cycle_omitted;
        ELSE
          CASE file.cycle_selector.cycle_option OF
          = pfc$highest_cycle =
            evaluated_file_reference.cycle_reference.specification := fsc$high_cycle;
          = pfc$lowest_cycle =
            evaluated_file_reference.cycle_reference.specification := fsc$low_cycle;
          = pfc$specific_cycle =
            evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
            evaluated_file_reference.cycle_reference.cycle_number := file.cycle_selector.cycle_number;
          ELSE
            evaluated_file_reference.cycle_reference.specification := fsc$high_cycle;
          CASEND;
        IFEND;
        clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} FALSE, fs_path^,
              fs_path_size, local_status);
        IF local_status.normal THEN
          criteria.file := fs_path^ (1, fs_path_size);
        IFEND;
      ELSE
        criteria.file := osc$null_name;
      IFEND;
    ELSE
    CASEND;

    IF (criteria.file <> osc$null_name) AND catalog_space_unavailable THEN
      { Isolate the parental catalog}
      PUSH file_reference;
      FOR i := 1 TO (UPPERBOUND (pf_path^) - 1) DO
        IF i > 1 THEN
          size := clp$trimmed_string_size (file_reference^ (1, size));
          STRINGREP (file_reference^, size, file_reference^ (1, size), '.', pf_path^ [i]);
        ELSE
          STRINGREP (file_reference^, size, ':', pf_path^ [i]);
        IFEND;
      FOREND;
      criteria.file := file_reference^ (1, size);
      clp$evaluate_file_reference (criteria.file, $clt$file_ref_parsing_options [], FALSE,
             evaluated_file_reference, local_status);
      IF local_status.normal THEN
        PUSH pf_path: [1 .. evaluated_file_reference.number_of_path_elements];
        fsp$convert_fs_structure_to_pf (evaluated_file_reference, pf_path);
      IFEND;
    IFEND;

    IF local_status.normal AND (criteria.file <> osc$null_name) THEN
      set_defaults_from_path (pf_path);

      IF password <> osc$null_name THEN
        PUSH validation_criteria: [1 .. 1];
        validation_criteria^ [1].validation_selection := fsc$goi_password;
        validation_criteria^ [1].password := password;
      ELSE
        validation_criteria := NIL;
      IFEND;
      get_relevant_object_attributes (criteria.file, validation_criteria, object_condition, object_type,
            criteria.mass_storage_class, criteria.file, criteria.set_name, volume_condition_list,
            criteria.volume_list, local_status);
      IF (NOT local_status.normal) AND osp$file_access_condition (local_status) THEN
        {
        { PFP$GET_OBJECT_INFORMATION returns abnormal status if a catalog in the path is missing or
        { unavailable, so we need to find that missing or unavailable catalog
        {
        osp$get_access_condition_entry (local_status, access_condition_entry, entry_found);
        IF entry_found THEN
          CASE access_condition_entry.file_access_condition OF
          = fsc$catalog_media_missing, fsc$catalog_volume_unavailable =
            PUSH file_reference;
            FOR i := 1 TO UPPERBOUND (pf_path^) DO
              IF i > 1 THEN
                size := clp$trimmed_string_size (file_reference^ (1, size));
                STRINGREP (file_reference^, size, file_reference^ (1, size), '.', pf_path^ [i]);
              ELSE
                STRINGREP (file_reference^, size, ':', pf_path^ [i]);
              IFEND;
              get_relevant_object_attributes (file_reference^ (1, size), validation_criteria,
                    object_condition, object_type, criteria.mass_storage_class, criteria.file,
                    criteria.set_name, volume_condition_list, criteria.volume_list, local_status);
              IF local_status.normal AND (object_condition <> fsc$null_file_access_condition) THEN
                RETURN;
              IFEND;
            FOREND;
          ELSE
          CASEND;
        IFEND;
      ELSEIF (NOT local_status.normal) AND (pf_path^ [1] <> fsc$local) THEN
        {
        { Isolate a possible space unavailable condition on the parental catalog during creation of a
        { catalog or file.
        {
        PUSH original_file_ref;
        original_file_ref^ := criteria.file;
        PUSH file_reference;
        FOR i := 1 TO (UPPERBOUND (pf_path^) - 1) DO
          IF i > 1 THEN
            size := clp$trimmed_string_size (file_reference^ (1, size));
            STRINGREP (file_reference^, size, file_reference^ (1, size), '.', pf_path^ [i]);
          ELSE
            STRINGREP (file_reference^, size, ':', pf_path^ [i]);
          IFEND;
        FOREND;
        get_relevant_object_attributes (file_reference^ (1, size), validation_criteria,
              object_condition, object_type, criteria.mass_storage_class, criteria.file,
              criteria.set_name, volume_condition_list, criteria.volume_list, local_status);
        IF (NOT local_status.normal) OR (object_type <> fsc$goi_catalog_object) OR (object_condition <>
              fsc$space_unavailable) THEN
          criteria.file := original_file_ref^;
          parental_set_name := criteria.set_name;
          get_relevant_object_attributes (original_file_ref^, validation_criteria, object_condition,
                object_type, criteria.mass_storage_class, ignore_resolved_path, criteria.set_name,
                volume_condition_list, criteria.volume_list, local_status);
          IF (NOT local_status.normal) OR (criteria.mass_storage_class = rmc$unspecified_file_class) THEN
            {
            { This covers the case of an attempted creation when a space
            { unavailable condition occurs.  This implies there is no volume
            { of the class to which the object can be assigned.  This is
            { different than the condition that occurs on catalog expansion
            { when out of space.
            {
            set_defaults_from_path (pf_path);
            IF criteria.set_name = osc$null_name THEN
              criteria.set_name := parental_set_name;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND osp$get_file_criteria;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$get_installed_policies', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_installed_policies
    (VAR installed_policies {input, output} : ^SEQ ( * );
     VAR sequence_header: ^ost$ecp_header;
     VAR status: ost$status);

   status.normal := TRUE;

   REPEAT
     osp$r3_get_installed_policies (installed_policies, sequence_header, status);
     IF (NOT status.normal) AND (status.condition = ose$exception_policies_locked) THEN
       pmp$wait (one_second, one_second);
     IFEND;
   UNTIL status.normal OR (status.condition <> ose$exception_policies_locked);

  PROCEND osp$get_installed_policies;
?? OLDTITLE ??
?? NEWTITLE := 'osp$get_login_user_criteria', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_login_user_criteria
    (VAR criteria: ost$ecp_criteria;
     VAR status: ost$status);

    CONST
      job = 1,
      job_class = 2,
      job_mode = 3,
      login_family = 4,
      login_user = 5;

    VAR
      job_attributes: array [job .. login_user] of jmt$job_attribute_result;

    job_attributes [job].key := jmc$system_job_name;
    job_attributes [job_class].key := jmc$job_class;
    job_attributes [job_mode].key := jmc$job_mode;
    job_attributes [login_family].key := jmc$login_family;
    job_attributes [login_user].key := jmc$login_user;

    jmp$get_job_attributes (^job_attributes, status);

    IF status.normal THEN
      criteria.job := job_attributes [job].system_job_name;
      criteria.job_class := job_attributes [job_class].job_class;
      criteria.job_mode := job_attributes [job_mode].job_mode;
      criteria.login_family := job_attributes [login_family].login_family;
      criteria.login_user := job_attributes [login_user].login_user;
    IFEND;

  PROCEND osp$get_login_user_criteria;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$get_policy', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_policy
    (    policy_number: ost$positive_integers;
         policies_sequence_header: ost$ecp_header;
     VAR policy: ^ost$ecp_policy_header);

    VAR
      i: ost$positive_integers;

    policy := NIL;
    IF (policy_number <= policies_sequence_header.number_of_policies) THEN
      IF policy_number = 1 THEN
        policy := policies_sequence_header.first_policy;
      ELSEIF policy_number = policies_sequence_header.number_of_policies THEN
        policy := policies_sequence_header.last_policy;
      ELSE
        policy := policies_sequence_header.first_policy;
        i := 1;
        WHILE (policy <> NIL) AND (i < policy_number) DO
          policy := policy^.next_policy;
          i := i + 1;
        WHILEND;
      IFEND;
    IFEND;

  PROCEND osp$get_policy;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$get_policy_list', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_policy_list
    (    policies_sequence_header: ost$ecp_header;
     VAR result: ^clt$data_value;
     VAR work_area {input, output} : ^clt$work_area);

    VAR
      node: ^^clt$data_value,
      policy: ^ost$ecp_policy_header,
      policy_number: ost$non_negative_integers;

    result := NIL;
    node := ^result;

    IF policies_sequence_header.number_of_policies > 0 THEN
      node := ^result;
      policy := policies_sequence_header.first_policy;
      policy_number := 1;
      WHILE policy_number <= policies_sequence_header.number_of_policies DO
        clp$make_list_value (work_area, node^);
        osp$get_policy (policy_number, policies_sequence_header, policy);
        IF policy <> NIL THEN
          make_policy_record (policy, work_area, node^^.element_value);
        ELSE
          RETURN;
        IFEND;
        policy_number := policy_number + 1;
        node := ^node^^.link;
      WHILEND;
    IFEND;

  PROCEND osp$get_policy_list;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$get_union_of_policies', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_union_of_policies
    (    policies_sequence_header: ^ost$ecp_header;
     VAR exception_conditions: ost$ecp_conditions;
     VAR policy_criteria: ost$ecp_policy_criteria;
     VAR status: ost$status);

    VAR
      i: ost$ecp_number_of_conditions,
      j: ost$positive_integers,
      number_of_policies: ost$non_negative_integers,
      policy: ^ost$ecp_policy_header,
      single_policy_criteria: ost$ecp_policy_criteria;

    status.normal := TRUE;
    number_of_policies := 0;

    FOR i := 1 TO UPPERBOUND (exception_conditions) DO
      exception_conditions [i] := policy_initialization_record.conditions [i];
    FOREND;

    policy_criteria := $ost$ecp_policy_criteria [];

    IF (policies_sequence_header <> NIL) AND (policies_sequence_header^.first_policy <> NIL) THEN
      policy := policies_sequence_header^.first_policy;
      WHILE (policy <> NIL) AND (number_of_policies <= policies_sequence_header^.number_of_policies) DO
        FOR i := 1 TO UPPERBOUND (exception_conditions) DO
          IF policy^.conditions [i].specified THEN
            IF exception_conditions [i].specified THEN
              exception_conditions [i].actions := exception_conditions [i].actions +
                    policy^.conditions [i].actions;
            ELSE
              exception_conditions [i] := policy^.conditions [i];
            IFEND;
          IFEND;
        FOREND;

        single_policy_criteria := $ost$ecp_policy_criteria [];
        IF policy^.jobs <> NIL THEN
          single_policy_criteria := single_policy_criteria + $ost$ecp_policy_criteria [osc$ecp_jobs];
        IFEND;

        IF policy^.login_users <> NIL THEN
          single_policy_criteria := single_policy_criteria + $ost$ecp_policy_criteria [osc$ecp_login_users];
        IFEND;

        IF policy^.job_mode.specified THEN
          single_policy_criteria := single_policy_criteria + $ost$ecp_policy_criteria [osc$ecp_job_mode];
        IFEND;

        IF policy^.job_classes <> NIL THEN
          single_policy_criteria := single_policy_criteria + $ost$ecp_policy_criteria [osc$ecp_job_classes];
        IFEND;

        IF policy^.files.specified THEN
          IF policy^.files.all_specified THEN
            single_policy_criteria := single_policy_criteria + $ost$ecp_policy_criteria [osc$ecp_all_files];
          ELSE

            FOR j := LOWERBOUND (policy^.files.path_list^) TO UPPERBOUND (policy^.files.path_list^) DO
              IF policy^.files.path_list^ [j].file_reference_type = osc$ecp_generic_reference THEN
                {A reference such as $USER implies scanning all files}
                single_policy_criteria := single_policy_criteria + $ost$ecp_policy_criteria
                      [osc$ecp_all_files];
              IFEND;
            FOREND;
            IF NOT (osc$ecp_all_files IN single_policy_criteria) THEN
              single_policy_criteria := single_policy_criteria +
                    $ost$ecp_policy_criteria [osc$ecp_list_of_files];
            IFEND;
          IFEND;
        IFEND;
        IF policy^.volumes <> NIL THEN
          single_policy_criteria := single_policy_criteria + $ost$ecp_policy_criteria [osc$ecp_volumes];
        IFEND;
        IF policy^.families <> NIL THEN
          single_policy_criteria := single_policy_criteria + $ost$ecp_policy_criteria [osc$ecp_families];
        IFEND;
        IF policy^.sets <> NIL THEN
          single_policy_criteria := single_policy_criteria + $ost$ecp_policy_criteria [osc$ecp_sets];
        IFEND;

        IF policy^.mass_storage_classes.specified THEN
          IF (single_policy_criteria * $ost$ecp_policy_criteria
                [osc$ecp_families, osc$ecp_list_of_files, osc$ecp_sets,
                osc$ecp_volumes]) = $ost$ecp_policy_criteria [] THEN
            {A policy based on mass_storage_classes alone must consider all files}
            single_policy_criteria := single_policy_criteria + $ost$ecp_policy_criteria [osc$ecp_all_files];
          IFEND;
          single_policy_criteria := single_policy_criteria +
                $ost$ecp_policy_criteria [osc$ecp_mass_storage_classes];
        IFEND;

        policy_criteria := policy_criteria + single_policy_criteria;
        policy := policy^.next_policy;
        number_of_policies := number_of_policies + 1;
      WHILEND;
    IFEND;

  PROCEND osp$get_union_of_policies;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$remove_policy', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$remove_policy
    (    policy: ^ost$ecp_policy_header;
     VAR policies_sequence_header {input, output} : ost$ecp_header);

    VAR
      prior_policy: ^ost$ecp_policy_header;

    IF policy <> NIL THEN
      IF policy = policies_sequence_header.first_policy THEN
        policies_sequence_header.first_policy := policy^.next_policy;
        policies_sequence_header.number_of_policies := policies_sequence_header.number_of_policies - 1;
      ELSE
        prior_policy := policies_sequence_header.first_policy;
        WHILE (prior_policy^.next_policy <> NIL) AND (policy <> prior_policy^.next_policy) DO
          prior_policy := prior_policy^.next_policy;
        WHILEND;
        IF (prior_policy^.next_policy <> NIL) THEN
          prior_policy^.next_policy := policy^.next_policy;
          IF policy^.next_policy = NIL THEN
            policies_sequence_header.last_policy := prior_policy;
          IFEND;
          policies_sequence_header.number_of_policies := policies_sequence_header.number_of_policies - 1;
        IFEND;
      IFEND;
    IFEND;

  PROCEND osp$remove_policy;
?? OLDTITLE ??
?? NEWTITLE := 'analyze_policy_coverage', EJECT ??

  PROCEDURE analyze_policy_coverage
    (    exception_policies: ost$ecp_conditions;
     VAR status: ost$status);

    VAR
      i: ost$non_negative_integers,
      ignore_status: ost$status,
      length: integer,
      missing_condition: string (33);

    status.normal := TRUE;

    FOR i := 1 TO UPPERBOUND (exception_policies) DO
      IF NOT exception_policies [i].specified THEN
        IF status.normal THEN
          osp$set_status_condition (ose$condition_not_covered, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                policy_initialization_record.conditions [i].exception_name
                (1, clp$trimmed_string_size (policy_initialization_record.conditions [i].exception_name)),
                status);
        ELSE
          STRINGREP (missing_condition, length, ' ', policy_initialization_record.conditions [i].
                exception_name (1, clp$trimmed_string_size (policy_initialization_record.conditions [i].
                exception_name)));
          osp$append_status_parameter (',', missing_condition (1, length), status);
        IFEND;
      IFEND;
    FOREND;

  PROCEND analyze_policy_coverage;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_installed_segment', EJECT ??

  PROCEDURE initialize_installed_segment
    (VAR installed_header: ^ost$ecp_header;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      installed_sequence: amt$segment_pointer,
      local_status: ost$status,
      policy_header: ^ost$ecp_policy_header,
      segment_pointer: amt$segment_pointer;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
    IF status.normal THEN
      RESET segment_pointer.sequence_pointer;

      NEXT installed_header IN segment_pointer.sequence_pointer;
      IF installed_header <> NIL THEN
        installed_header^ := header_initialization_record;
        installed_header^.segment_p := segment_pointer;
        installed_header^.last_accessed_policy := 0;
        NEXT policy_header IN segment_pointer.sequence_pointer;
        IF policy_header <> NIL THEN
          RESET installed_header^.segment_p.sequence_pointer TO policy_header;
        IFEND;
      IFEND;

      RESET segment_pointer.sequence_pointer;
      osp$get_installed_policies (segment_pointer.sequence_pointer, installed_header, local_status);
      IF (NOT local_status.normal) AND (local_status.condition <> ose$no_policies_installed) THEN
        osp$generate_output_message (local_status, ignore_status);
      IFEND;
    IFEND;

  PROCEND initialize_installed_segment;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_session_segment', EJECT ??

  PROCEDURE initialize_session_segment
    (VAR session_header: ^ost$ecp_header;
     VAR status: ost$status);

    VAR
      policy_header: ^ost$ecp_policy_header,
      segment_pointer: amt$segment_pointer;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
    IF status.normal THEN
      RESET segment_pointer.sequence_pointer;

      NEXT session_header IN segment_pointer.sequence_pointer;
      IF session_header <> NIL THEN
        session_header^ := header_initialization_record;
        session_header^.segment_p := segment_pointer;
        session_header^.last_accessed_policy := 0;
        NEXT policy_header IN segment_pointer.sequence_pointer;
        IF policy_header <> NIL THEN
          RESET session_header^.segment_p.sequence_pointer TO policy_header;
        IFEND;
      IFEND;
    IFEND;
  PROCEND initialize_session_segment;
?? OLDTITLE ??
?? NEWTITLE := 'install_exception_policies', EJECT ??

  PROCEDURE install_exception_policies
    (    session_policies: ^SEQ ( * );
     VAR status: ost$status);

   status.normal := TRUE;

   REPEAT
     osp$r3_install_exception_policy (session_policies, status);
     IF (NOT status.normal) AND (status.condition = ose$exception_policies_locked) THEN
       pmp$wait (one_second, one_second);
     IFEND;
   UNTIL status.normal OR (status.condition <> ose$exception_policies_locked);

  PROCEND install_exception_policies;
?? OLDTITLE ??
?? NEWTITLE := 'make_policy_record', EJECT ??

  PROCEDURE make_policy_record
    (    policy: ^ost$ecp_policy_header;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value);


?? NEWTITLE := 'make_condition_fields', EJECT ??

    PROCEDURE make_condition_fields;

      VAR
        condition: ost$ecp_number_of_conditions,
        node: ^^clt$data_value;

?? NEWTITLE := 'make_condition_value', EJECT ??

      PROCEDURE make_condition_value
        (    condition: ost$ecp_number_of_conditions);

        VAR
          j: ost$ecp_action;

        IF policy^.conditions [condition].specified THEN
          IF policy^.conditions [condition].actions = $ost$ecp_actions [osc$ecp_exit] THEN
            clp$make_keyword_value (action_names [osc$ecp_exit], work_area, node^);
          ELSEIF policy^.conditions [condition].actions = $ost$ecp_actions [osc$ecp_wait] THEN
            clp$make_keyword_value (action_names [osc$ecp_wait], work_area, node^);
          ELSEIF (fsc$catalog_volume_unavailable IN policy^.conditions [condition].file_access_conditions) AND
                (osc$ecp_delete IN policy^.conditions [condition].actions) THEN
            clp$make_keyword_value (action_names [osc$ecp_delete], work_area, node^);
          ELSE
            FOR j := osc$ecp_delete TO osc$ecp_set_damage_condition DO
              IF j IN policy^.conditions [condition].actions THEN
                clp$make_list_value (work_area, node^);
                clp$make_keyword_value (action_names [j], work_area, node^^.element_value);
                node := ^node^^.link;
              IFEND;
            FOREND;
          IFEND;
        ELSE
          clp$make_unspecified_value (work_area, node^);
        IFEND;

      PROCEND make_condition_value;
?? OLDTITLE, EJECT ??

      FOR condition := 1 TO UPPERBOUND (policy^.conditions) DO
        node := ^result^.field_values^ [$INTEGER (policy^.conditions [condition].exception_ordinal)].value;
        result^.field_values^ [$INTEGER (policy^.conditions [condition].exception_ordinal)].
              name := policy^.conditions [condition].exception_name;
        make_condition_value (condition);
      FOREND;

    PROCEND make_condition_fields;
?? OLDTITLE ??
?? NEWTITLE := 'make_files_field', EJECT ??

    PROCEDURE make_files_field;

      VAR
        i: ost$positive_integers,
        node: ^^clt$data_value;

      node := ^result^.field_values^ [$INTEGER (osc$fp_files)].value;
      result^.field_values^ [$INTEGER (osc$fp_files)].name := function_field_names [osc$fp_files];

      IF policy^.files.specified THEN
        IF policy^.files.all_specified THEN
          clp$make_keyword_value (all_keyword, work_area, node^);
        ELSEIF policy^.files.path_list <> NIL THEN
          FOR i := 1 TO UPPERBOUND (policy^.files.path_list^) DO
            clp$make_list_value (work_area, node^);
            clp$make_file_value (policy^.files.path_list^ [i].path^, work_area, node^^.element_value);
            node := ^node^^.link;
          FOREND;
        IFEND;
      ELSE
        clp$make_unspecified_value (work_area, node^);
      IFEND;

    PROCEND make_files_field;
?? OLDTITLE ??
?? NEWTITLE := 'make_job_mode_field', EJECT ??

    PROCEDURE make_job_mode_field;

      VAR
        i: ost$positive_integers,
        node: ^^clt$data_value;

      node := ^result^.field_values^ [$INTEGER (osc$fp_job_mode)].value;
      result^.field_values^ [$INTEGER (osc$fp_job_mode)].name := function_field_names [osc$fp_job_mode];

      IF policy^.job_mode.specified THEN
        IF policy^.job_mode.value = jmc$batch THEN
          clp$make_keyword_value (batch, work_area, node^);
        ELSE
          clp$make_keyword_value (interactive, work_area, node^);
        IFEND;
      ELSE
        clp$make_unspecified_value (work_area, node^);
      IFEND;

    PROCEND make_job_mode_field;
?? OLDTITLE ??
?? NEWTITLE := 'make_login_users_field', EJECT ??

    PROCEDURE make_login_users_field;

      CONST
        login_user_field_count = 4;

      VAR
        i: ost$positive_integers,
        j: ost$ecp_specified_login_field,
        node: ^^clt$data_value;

      node := ^result^.field_values^ [$INTEGER (osc$fp_login_users)].value;
      result^.field_values^ [$INTEGER (osc$fp_login_users)].name := function_field_names [osc$fp_login_users];

      IF policy^.login_users <> NIL THEN
        FOR i := 1 TO UPPERBOUND (policy^.login_users^) DO
          clp$make_list_value (work_area, node^);
          clp$make_record_value (login_user_field_count, work_area, node^^.element_value);
          FOR j := osc$lu_user_name TO osc$lu_job_mode DO
            node^^.element_value^.field_values^ [$INTEGER (j) + 1].name := login_users_names [j];
            IF j IN policy^.login_users^ [i].specified_fields THEN
              CASE j OF
              = osc$lu_user_name =
                clp$make_name_value (policy^.login_users^ [i].user_name, work_area,
                      node^^.element_value^.field_values^ [$INTEGER (j) + 1].value);
              = osc$lu_family_name =
                clp$make_name_value (policy^.login_users^ [i].family_name, work_area,
                      node^^.element_value^.field_values^ [$INTEGER (j) + 1].value);
              = osc$lu_job_class =
                clp$make_name_value (policy^.login_users^ [i].job_class, work_area,
                      node^^.element_value^.field_values^ [$INTEGER (j) + 1].value);
              = osc$lu_job_mode =
                IF policy^.login_users^ [i].job_mode = jmc$batch THEN
                  clp$make_keyword_value (batch, work_area, node^^.element_value^.
                        field_values^ [$INTEGER (j) + 1].value);
                ELSE
                  clp$make_keyword_value (interactive, work_area, node^^.element_value^.
                        field_values^ [$INTEGER (j) + 1].value);
                IFEND;
              ELSE
              CASEND;
            ELSE
              clp$make_unspecified_value (work_area, node^^.element_value^.field_values^ [$INTEGER (j) +
                    1].value);
            IFEND;
          FOREND;
          node := ^node^^.link;
        FOREND;
      ELSE
        clp$make_unspecified_value (work_area, node^);
      IFEND;

    PROCEND make_login_users_field;
?? OLDTITLE ??
?? NEWTITLE := 'make_ms_classes_field', EJECT ??

    PROCEDURE make_ms_classes_field;

      VAR
        i: 'B' .. 'Z',
        node: ^^clt$data_value,
        string1: string (1);

      node := ^result^.field_values^ [$INTEGER (osc$fp_mass_storage_classes)].value;
      result^.field_values^ [$INTEGER (osc$fp_mass_storage_classes)].
            name := function_field_names [osc$fp_mass_storage_classes];

      IF policy^.mass_storage_classes.specified THEN
        FOR i := 'B' TO 'Z' DO
          IF i IN policy^.mass_storage_classes.value THEN
            clp$make_list_value (work_area, node^);
            #UNCHECKED_CONVERSION (i, string1);
            clp$make_name_value (string1, work_area, node^^.element_value);
            node := ^node^^.link;
          IFEND;
        FOREND;
      ELSE
        clp$make_unspecified_value (work_area, node^);
      IFEND;

    PROCEND make_ms_classes_field;
?? OLDTITLE ??
?? NEWTITLE := 'make_name_field', EJECT ??

    PROCEDURE make_name_field
      (    field_number: ost$ecp_function_param_ordinal;
           name_array: ^ost$ecp_name_list);

      VAR
        i: ost$positive_integers,
        node: ^^clt$data_value;

      node := ^result^.field_values^ [$INTEGER (field_number)].value;
      result^.field_values^ [$INTEGER (field_number)].name := function_field_names [field_number];

      IF name_array <> NIL THEN
        FOR i := 1 TO UPPERBOUND (name_array^) DO
          clp$make_list_value (work_area, node^);
          clp$make_name_value (name_array^ [i], work_area, node^^.element_value);
          node := ^node^^.link;
        FOREND;
      ELSE
        clp$make_unspecified_value (work_area, node^);
      IFEND;

    PROCEND make_name_field;
?? OLDTITLE ??
?? NEWTITLE := 'make_poll_frequency_field', EJECT ??

    PROCEDURE make_poll_frequency_field;

      VAR
        node: ^^clt$data_value;

      node := ^result^.field_values^ [$INTEGER (osc$fp_polling_frequency)].value;
      result^.field_values^ [$INTEGER (osc$fp_polling_frequency)].name := polling_frequency_name;

      IF policy^.polling_frequency.specified THEN
        clp$make_integer_value (policy^.polling_frequency.value, {radix} 10, {radix_specified} FALSE,
              work_area, node^);
      ELSE
        clp$make_unspecified_value (work_area, node^);
      IFEND;

    PROCEND make_poll_frequency_field;
?? OLDTITLE ??
?? NEWTITLE := 'make_volumes_field', EJECT ??

    PROCEDURE make_volumes_field;

      VAR
        i: ost$positive_integers,
        node: ^^clt$data_value;

      node := ^result^.field_values^ [$INTEGER (osc$fp_volumes)].value;
      result^.field_values^ [$INTEGER (osc$fp_volumes)].name := function_field_names [osc$fp_volumes];

      IF policy^.volumes <> NIL THEN
        FOR i := 1 TO UPPERBOUND (policy^.volumes^) DO
          clp$make_list_value (work_area, node^);
          clp$make_name_value (policy^.volumes^ [i], work_area, node^^.element_value);
          node := ^node^^.link;
        FOREND;
      ELSE
        clp$make_unspecified_value (work_area, node^);
      IFEND;

    PROCEND make_volumes_field;
?? OLDTITLE, EJECT ??

    result := NIL;
    IF policy <> NIL THEN
      clp$make_record_value (number_of_fields, work_area, result);

      make_name_field (osc$fp_job_classes, policy^.job_classes);
      make_job_mode_field;
      make_name_field (osc$fp_jobs, policy^.jobs);
      make_login_users_field;
      make_name_field (osc$fp_families, policy^.families);
      make_files_field;
      make_ms_classes_field;
      make_name_field (osc$fp_sets, policy^.sets);
      make_volumes_field;
      make_condition_fields;
      make_poll_frequency_field;
    IFEND;

  PROCEND make_policy_record;
?? OLDTITLE ??
?? NEWTITLE := 'make_$applicable_policy', EJECT ??

  PROCEDURE make_$applicable_policy
    (    c_param: ost$positive_integers;
         pvt: clt$parameter_value_table;
         s_param: ost$positive_integers;
     VAR empty_display: boolean;
     VAR result: ^clt$data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      applicable_policy: ^ost$ecp_policy_header,
      count: clt$list_size,
      criteria: ost$ecp_criteria,
      i: ost$positive_integers,
      ignore_applicable_actions: ost$ecp_actions,
      j: ost$positive_integers,
      jm_name: jmt$name,
      name_node: ^clt$data_value,
      sequence_index: ost$ecp_sequence_index,
      validated_name: jmt$name;

    status.normal := TRUE;
    empty_display := FALSE;
    result := NIL;

    criteria.mass_storage_class := rmc$unspecified_file_class;
    criteria.set_name := osc$null_name;
    criteria.volume_list := NIL;

  /make_result/
    BEGIN
      IF pvt [s_param].value^.keyword_value = 'UTILITY_SESSION' THEN
        sequence_index := osc$ecp_session_policies;
      ELSE
        sequence_index := osc$ecp_installed_policies;
      IFEND;

      FOR i := 1 TO UPPERBOUND (pvt [c_param].value^.field_values^) DO
        IF pvt [c_param].value^.field_values^ [i].name = 'CONDITION' THEN
          IF pvt [c_param].value^.field_values^ [i].value^.keyword_value = 'CATALOG_VOLUME_UNAVAILABLE' THEN
            criteria.condition := fsc$catalog_volume_unavailable;
          ELSEIF pvt [c_param].value^.field_values^ [i].value^.keyword_value = 'CYCLE_BUSY' THEN
            criteria.condition := fsc$cycle_busy;
          ELSEIF pvt [c_param].value^.field_values^ [i].value^.keyword_value =
                'CYCLE_RESTORATION_REQUIRED' THEN
            criteria.condition := fsc$data_restoration_required;
          ELSEIF pvt [c_param].value^.field_values^ [i].value^.keyword_value = 'DATA_RETRIEVAL_REQUIRED' THEN
            criteria.condition := fsc$data_retrieval_required;
          ELSEIF pvt [c_param].value^.field_values^ [i].value^.keyword_value = 'FILE_SERVER_INACTIVE' THEN
            criteria.condition := fsc$file_server_inactive;
          ELSEIF pvt [c_param].value^.field_values^ [i].value^.keyword_value = 'SPACE_UNAVAILABLE' THEN
            criteria.condition := fsc$space_unavailable;
          ELSEIF pvt [c_param].value^.field_values^ [i].value^.keyword_value = 'VOLUME_UNAVAILABLE' THEN
            criteria.condition := fsc$volume_unavailable;
          IFEND;
        ELSEIF pvt [c_param].value^.field_values^ [i].name = 'FAMILY_PATH_NAME' THEN
          criteria.family_path_name := pvt [c_param].value^.field_values^ [i].value^.name_value;
        ELSEIF pvt [c_param].value^.field_values^ [i].name = 'FILE' THEN
          criteria.file := pvt [c_param].value^.field_values^ [i].value^.file_value^;
        ELSEIF pvt [c_param].value^.field_values^ [i].name = job_keyword THEN
          jm_name.kind := jmc$system_supplied_name;
          jm_name.system_supplied_name := pvt [c_param].value^.field_values^ [i].value^.name_value;
          jmp$validate_name (jm_name, validated_name, status);
          IF status.normal THEN
            criteria.job := validated_name.system_supplied_name;
          ELSE
            EXIT /make_result/;
          IFEND;
        ELSEIF pvt [c_param].value^.field_values^ [i].name = job_class_keyword THEN
          criteria.job_class := pvt [c_param].value^.field_values^ [i].value^.name_value;
        ELSEIF pvt [c_param].value^.field_values^ [i].name = job_mode_keyword THEN
          IF pvt [c_param].value^.field_values^ [i].value^.keyword_value = batch THEN
            criteria.job_mode := jmc$batch;
          ELSE {INTERACTIVE}
            criteria.job_mode := jmc$interactive_connected;
          IFEND;
        ELSEIF pvt [c_param].value^.field_values^ [i].name = 'LOGIN_FAMILY' THEN
          criteria.login_family := pvt [c_param].value^.field_values^ [i].value^.name_value;
        ELSEIF pvt [c_param].value^.field_values^ [i].name = 'LOGIN_USER' THEN
          criteria.login_user := pvt [c_param].value^.field_values^ [i].value^.name_value;
        ELSEIF pvt [c_param].value^.field_values^ [i].name = mass_storage_class_keyword THEN
          IF pvt [c_param].value^.field_values^ [i].value^.kind <> clc$unspecified THEN
            #UNCHECKED_CONVERSION (pvt [c_param].value^.field_values^ [i].value^.name_value (1, 1),
                  criteria.mass_storage_class);
          IFEND;
        ELSEIF pvt [c_param].value^.field_values^ [i].name = set_keyword THEN
          IF pvt [c_param].value^.field_values^ [i].value^.kind <> clc$unspecified THEN
            criteria.set_name := pvt [c_param].value^.field_values^ [i].value^.name_value;
          IFEND;
        ELSEIF pvt [c_param].value^.field_values^ [i].name = volumes_keyword THEN
          IF pvt [c_param].value^.field_values^ [i].value^.kind <> clc$unspecified THEN
            count := clp$count_list_elements (pvt [c_param].value^.field_values^ [i].value);
            PUSH criteria.volume_list: [1 .. count];
            IF criteria.volume_list <> NIL THEN
              name_node := pvt [c_param].value^.field_values^ [i].value;
              FOR j := 1 TO count DO
                criteria.volume_list^ [j].external_vsn := name_node^.element_value^.name_value (1, 6);
                criteria.volume_list^ [j].recorded_vsn := name_node^.element_value^.name_value (1, 6);
                name_node := name_node^.link;
              FOREND;
            IFEND;
          IFEND;
        IFEND;
      FOREND;

      osp$find_applicable_policy (criteria, osv$ecp_sequence_headers [sequence_index],
            ignore_applicable_actions, applicable_policy, status);

      IF status.normal AND (applicable_policy <> NIL) THEN
        make_policy_record (applicable_policy, work_area, result);
        IF result = NIL THEN
          osp$set_status_abnormal ('CL', cle$work_area_overflow, '$APPLICABLE_POLICY', status);
        IFEND;
      ELSE
        empty_display := TRUE;
        make_policy_record (^policy_initialization_record, work_area, result);
      IFEND;
    END /make_result/;

  PROCEND make_$applicable_policy;
?? OLDTITLE ??
?? NEWTITLE := 'make_$exception_policies', EJECT ??

  PROCEDURE make_$exception_policies
    (    do_param: ost$positive_integers;
         pvt: clt$parameter_value_table;
         s_param: ost$positive_integers;
     VAR empty_display: boolean;
     VAR result: ^clt$data_value;
     VAR work_area {input, output} : ^clt$work_area;
     VAR status: ost$status);

    VAR
      ending_policy: ost$non_negative_integers,
      node: ^^clt$data_value,
      policy: ^ost$ecp_policy_header,
      policy_number: ost$non_negative_integers,
      sequence_index: ost$ecp_sequence_index,
      starting_policy: ost$non_negative_integers;

    status.normal := TRUE;
    empty_display := FALSE;
    result := NIL;

    IF pvt [s_param].value^.keyword_value = 'UTILITY_SESSION' THEN
      sequence_index := osc$ecp_session_policies;
    ELSE
      sequence_index := osc$ecp_installed_policies;
    IFEND;

    IF osv$ecp_sequence_headers [sequence_index] <> NIL THEN
      IF pvt [do_param].value^.kind = clc$keyword THEN
        IF pvt [do_param].value^.keyword_value = all_keyword THEN
          starting_policy := 1;
          ending_policy := osv$ecp_sequence_headers [sequence_index]^.number_of_policies;
        ELSEIF pvt [do_param].value^.keyword_value = 'FIRST' THEN
          starting_policy := 1;
          ending_policy := 1;
        ELSEIF pvt [do_param].value^.keyword_value = 'NEXT' THEN
          starting_policy := osv$ecp_sequence_headers [sequence_index]^.last_accessed_policy + 1;
          ending_policy := osv$ecp_sequence_headers [sequence_index]^.last_accessed_policy + 1;
        ELSEIF pvt [do_param].value^.keyword_value = 'LAST' THEN
          IF osv$ecp_sequence_headers [sequence_index]^.last_accessed_policy <> 0 THEN
            starting_policy := osv$ecp_sequence_headers [sequence_index]^.last_accessed_policy;
            ending_policy := osv$ecp_sequence_headers [sequence_index]^.last_accessed_policy;
          ELSE
            starting_policy := 1;
            ending_policy := 1;
          IFEND;
        IFEND;
      ELSE {last N, where N is an integer}
        IF pvt [do_param].value^.integer_value.value >= osv$ecp_sequence_headers [sequence_index]^.
              number_of_policies THEN
          starting_policy := 1;
          ending_policy := osv$ecp_sequence_headers [sequence_index]^.number_of_policies;
        ELSE
          starting_policy := (osv$ecp_sequence_headers [sequence_index]^.number_of_policies -
                pvt [do_param].value^.integer_value.value) + 1;
          ending_policy := osv$ecp_sequence_headers [sequence_index]^.number_of_policies;
        IFEND;
      IFEND;

      IF starting_policy > ending_policy THEN
        make_policy_record (^policy_initialization_record, work_area, result);
      ELSEIF (ending_policy - starting_policy) > 0 THEN
        node := ^result;
        policy_number := starting_policy;
        REPEAT
          clp$make_list_value (work_area, node^);
          osp$get_policy (policy_number, osv$ecp_sequence_headers [sequence_index]^, policy);
          IF policy <> NIL THEN
            make_policy_record (policy, work_area, node^^.element_value);
          ELSE
            make_policy_record (^policy_initialization_record, work_area, result);
          IFEND;
          policy_number := policy_number + 1;
          node := ^node^^.link;
        UNTIL (policy_number > ending_policy) OR (policy = NIL);
      ELSE
        osp$get_policy (starting_policy, osv$ecp_sequence_headers [sequence_index]^, policy);
        IF policy <> NIL THEN
          make_policy_record (policy, work_area, result);
        ELSE
          make_policy_record (^policy_initialization_record, work_area, result);
          empty_display := TRUE;
        IFEND;
      IFEND;

      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '$EXCEPTION_POLICY', status);
      ELSE
        osv$ecp_sequence_headers [sequence_index]^.last_accessed_policy := ending_policy;
      IFEND;
    ELSE
      make_policy_record (^policy_initialization_record, work_area, result);
      empty_display := TRUE;
    IFEND;
  PROCEND make_$exception_policies;
?? OLDTITLE ??
?? NEWTITLE := 'temporary_file', EJECT ??

  FUNCTION temporary_file
    (    file: fst$file_reference): boolean;

    temporary_file := FALSE;

    IF STRLENGTH (file (2, * )) >= fsc$local_size THEN
      IF file (2, fsc$local_size) = fsc$local THEN
        temporary_file := TRUE;
      IFEND;
    IFEND;

  FUNCEND temporary_file;
?? OLDTITLE ??
MODEND osm$manage_exception_policies;
*DECK DECK=OSM$MESSAGE_MODULE_POINTERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Message Module Pointers' ??
MODULE osm$message_module_pointers;

{
{ PURPOSE:
{   This module initializes the pointers to message modules used internally by
{   the system.  It also contains a table of these pointers and their
{   corresponding seed names.  OSP$FIND_HELP_MODULE searches this table when it
{   is unable to find a module name in the job's command list entries.
{
{ DESIGN:
{   To add another system-defined HELP message module, you must do the following:
{
{     1. Create an XDCL variable below that is initialized by the linker
{     2. Define a string constant identifier containing the name of the HELP message
{        module.  OSP$FIND_HELP_MODULE searches by this name to find the address of
{        HELP module whose address is initialized by the linker in the
{        osv$system_message_modules array below
{     3. Add an entry to the osv$system_message_modules array below that relates
{        HELP module name to address
{     4. Add one to the value of the constant osc$max_system_message_modules in the
{        deck by the same name
{     5. Add a linker command to deck RAF$JOB_TEMPLATE_LINKER_COMNDS to cause the
{        linker to initialize the address in the osv$system_message_modules array
{     6. Create a HELP message module; for an example refer to
{        RMM$RESOURCE_HELP_MESSAGES.  The name of the module is composed of a seed
{        name followed by $US_ENGLISH.  The seed name is the value of the constant
{        identifier defined in (2) above.
{     7. Recompile deck CLM$HELP_MESSAGE_INTERFACES
{
?? PUSH (LISTEXT := ON) ??
*copyc clc$system_messages_module
*copyc cmc$action_messages
*copyc fsc$wait_msg_module_name
*copyc osc$max_system_message_modules
*copyc oss$job_paged_literal
*copyc ost$help_module
*copyc ost$name
*copyc pfc$chacc_help_module_name
*copyc pfc$movc_insuf_space
*copyc pfc$movc_no_space
*copyc puc$delete_all_files_message
*copyc rmc$action_messages
*copyc rmc$dedicated_maintenance
*copyc rmc$extend_labeled_vol_list
*copyc rmc$extend_unlabeled_vol_list
*copyc rmc$generic_error_recovery
*copyc rmc$incorrect_recorded_vsn
*copyc rmc$initv_menu_names
*copyc rmc$job_status_messages
*copyc rmc$loadpoint_error_recovery
*copyc rmc$manual_tape_maintenance
*copyc rmc$reserve_tape
*copyc rmc$robotic_element_monopoly
*copyc rmc$robotic_tape_maintenance
*copyc rmc$robotic_write_disabled
*copyc rmc$vol_classification_module
*copyc rmc$write_error_recovery
*copyc rmc$wrong_label_type
*copyc rsc$extend_labeled_message
*copyc rsc$extend_unlabeled_message
?? POP ??

  VAR

{ The following variables are initialized at system link time to point to the
{ help modules containing the default parameter prompts in US_English.

{ The following variable defines the pointer to message module containing
{ the automatic reconfiguration operator action messages.

    cmv$action_messages: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,

    clv$system_messages_module: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,

    fsv$wait_messages: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,

    pfv$chacc_output: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    pfv$movc_insuf_space: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    pfv$movc_no_space: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,

{ The following variable defines the menu module pointer used by
{ the BACPF subcommand DELETE_ALL_FILES.

    puv$delete_all_files_message: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,

{ The following variables define the menu module pointer used by
{ INITIALIZE_TAPE_VOLUME.

    rmv$crebuv_buv_menu: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$crebuv_le_menu: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$crebuv_lu_menu: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$crebuv_urv_menu: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$crebuv_uv_menu: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$initv_ul_menu: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$initv_exp_menu: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$initv_unexp_menu: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$initv_re_menu: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,

{ The following variables define the pointers to the message modules containing
{ system operator menus.

    rmv$dedicated_maintenance: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$extend_labeled_vol_list: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$extend_unlabeled_vol_list: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$generic_error_recovery: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$incorrect_recorded_vsn: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$loadpoint_error_recovery: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$manual_tape_maintenance: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$reserve_tape: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$robotic_element_monopoly: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$robotic_tape_maintenance: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$robotic_write_disabled: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$write_error_recovery: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rmv$wrong_label_type: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,

{ The following variable defines the pointer to the message module containing
{ operator action messages.

    rmv$action_messages: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,

{ The following variable defines the pointer to the message module containing
{ job status messages.

    rmv$job_status_messages: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,

{ The following variable defines the pointer to the message module containing
{ the template for the output of the DISPLAY_VOLUME_CLASSIFICATION command.

    rmv$volume_classification: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,

{ The following variables are used for tape menus for RMS.

    rsv$extend_labeled_message: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL,
    rsv$extend_unlabeled_message: [XDCL, READ, oss$job_paged_literal] ^ost$help_module := NIL;
?? FMT (FORMAT := OFF) ??

?? NEWTITLE := 'osv$system_message_modules', EJECT ??

{ The following table of message modules is searched by osp$find_help_module
{ if it is unable to find the supplied module name in the job's command list.

  VAR
    osv$system_message_modules: [XDCL, READ, oss$job_paged_literal] array
          [1 .. osc$max_system_message_modules] of record
      module_name: ost$name,
      module_pointer_p: ^^ost$help_module,
    recend := [
          [clc$system_messages_module,     ^clv$system_messages_module],
          [cmc$action_messages,            ^cmv$action_messages],
          [fsc$wait_msg_module_name,       ^fsv$wait_messages],
          [pfc$chacc_help_module_name,     ^pfv$chacc_output],
          [pfc$movc_insuf_space,           ^pfv$movc_insuf_space],
          [pfc$movc_no_space,              ^pfv$movc_no_space],
          [puc$delete_all_files_message,   ^puv$delete_all_files_message],
          [rmc$action_messages,            ^rmv$action_messages],
          [rmc$crebuv_buv_menu,            ^rmv$crebuv_buv_menu],
          [rmc$crebuv_le_menu,             ^rmv$crebuv_le_menu],
          [rmc$crebuv_lu_menu,             ^rmv$crebuv_lu_menu],
          [rmc$crebuv_urv_menu,            ^rmv$crebuv_urv_menu],
          [rmc$crebuv_uv_menu,             ^rmv$crebuv_uv_menu],
          [rmc$dedicated_maintenance,      ^rmv$dedicated_maintenance],
          [rmc$extend_labeled_vol_list,    ^rmv$extend_labeled_vol_list],
          [rmc$extend_unlabeled_vol_list,  ^rmv$extend_unlabeled_vol_list],
          [rmc$generic_error_recovery,     ^rmv$generic_error_recovery],
          [rmc$incorrect_recorded_vsn,     ^rmv$incorrect_recorded_vsn],
          [rmc$initv_exp_menu,             ^rmv$initv_exp_menu],
          [rmc$initv_re_menu,              ^rmv$initv_re_menu],
          [rmc$initv_ul_menu,              ^rmv$initv_ul_menu],
          [rmc$initv_unexp_menu,           ^rmv$initv_unexp_menu],
          [rmc$job_status_messages,        ^rmv$job_status_messages],
          [rmc$loadpoint_error_recovery,   ^rmv$loadpoint_error_recovery],
          [rmc$manual_tape_maintenance,    ^rmv$manual_tape_maintenance],
          [rmc$reserve_tape,               ^rmv$reserve_tape],
          [rmc$robotic_element_monopoly,   ^rmv$robotic_element_monopoly],
          [rmc$robotic_tape_maintenance,   ^rmv$robotic_tape_maintenance],
          [rmc$robotic_write_disabled,     ^rmv$robotic_write_disabled],
          [rmc$vol_classification_module,  ^rmv$volume_classification],
          [rmc$write_error_recovery,       ^rmv$write_error_recovery],
          [rmc$wrong_label_type,           ^rmv$wrong_label_type],
          [rsc$extend_labeled_message,     ^rsv$extend_labeled_message],
          [rsc$extend_unlabeled_message,   ^rsv$extend_unlabeled_message]
          ];

MODEND osm$message_module_pointers;
*DECK DECK=OSM$MESSAGE_TEMPLATE_MODULE EXPAND=TRUE
MODULE osm$message_template_module;
*copyc osd$exceptions
*IF $true(osv$unix)
*copyc ese$condition_codes
*copyc sce$condition_codes
*IFEND
MODEND osm$message_template_module;
*DECK DECK=OSM$MISC_SERVICES_13D EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operating System : Miscellaneous Services 13D Routines' ??
MODULE osm$misc_services_13d;

{ PURPOSE:
{   This module contains procedures to interface 1dd procedures to 113 procedures and variables.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cml$system_error
*copyc ost$monitor_fault
*copyc ost$system_error_statistic
?? POP ??
*copyc dsp$log_sys_msg_help
*copyc syp$establish_condition_handler
*copyc syp$process_job_rcv_failure
?? EJECT ??
*copyc syv$job_recovery_step
?? TITLE := 'osp$check_for_job_recovery', EJECT ??

{ PURPOSE:
{   This procedure checks if job recovery is in progress for this job.  If it is
{   syv$recovering_job_count will be decremented and the job will be hung.

  PROCEDURE [XDCL, #GATE] osp$check_for_job_recovery
    (    message: string(*));

    VAR
      status: ost$status;

    status.normal := TRUE;
    IF (syv$job_recovery_step > syc$jrs_initial_step) AND
          (syv$job_recovery_step < syc$jrs_recovery_complete) THEN
      syp$process_job_rcv_failure (message, status);
    IFEND;

  PROCEND osp$check_for_job_recovery;
?? TITLE := 'osp$log_system_error', EJECT ??

{ Purpose:
{   This procedure will log the system error statistic.

  PROCEDURE [XDCL, #GATE] osp$log_system_error
    (    error_message: string ( * );
         text: string ( * ));

?? NEWTITLE := 'ch', EJECT ??

  PROCEDURE ch
    (    mf: ost$monitor_fault;
         msa_p: ^ost$minimum_save_area;
     VAR continue: syt$continue_option);

    error_statistic_p := #SEQ (error_statistic);
    dsp$log_sys_msg_help (cml$system_error, error_statistic_p);
    EXIT osp$log_system_error;

  PROCEND ch;

?? OLDTITLE, EJECT ??

  TYPE
    sfsa_type = RECORD
      fill1: 0 .. 0ffff(16),
      p: ^cell,
      a0: integer,
      a1: integer,
      fill2: 0 .. 0ffff(16),
      a2: ^sfsa_type, {previous save area pointer}
    RECEND,

    variant_trick = RECORD
      CASE 0 .. 1 OF
      = 0 =
        word: integer,
      = 1 =
        fill: 0 .. 0ffff(16),
        pva: ^cell,
      CASEND,
    RECEND;

  VAR
    converter: variant_trick,
    error_statistic: ost$system_error_statistic,
    error_statistic_p: ^SEQ ( * ),
    length: integer,
    sfsa_p: ^sfsa_type,
    stack: 0 .. osc$stacks_to_display,
    status: ost$status,
    temp_text: string (osc$system_error_stat_msg_size);

  FOR stack := 1 to osc$stacks_to_display DO
    error_statistic.counter [stack] := 0ffff80000000(16);
  FOREND;
  converter.word := 0;

  syp$establish_condition_handler (^ch);

  STRINGREP (temp_text, length, text, error_message);
  error_statistic.text := temp_text (1, length);

  sfsa_p := #PREVIOUS_SAVE_AREA ();

  /display_p/
  FOR stack := 1 to osc$stacks_to_display DO
    converter.pva := sfsa_p^.p;
    error_statistic.counter [stack] := converter.word;
    sfsa_p := sfsa_p^.a2;
    IF sfsa_p = NIL THEN
      EXIT /display_p/
    IFEND;
  FOREND /display_p/;

  error_statistic_p := #SEQ (error_statistic);
  dsp$log_sys_msg_help (cml$system_error, error_statistic_p);

  PROCEND osp$log_system_error;
MODEND osm$misc_services_13d;
*DECK DECK=OSM$MISC_TEST_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE OS: Miscellaneous Test Commands', EJECT ??
MODULE osm$misc_test_commands;

{ PURPOSE:
{   This module contains misc commands useful for testing the hardware.
{ NOTE:
{   Extensive use of this module is made by the SVS system. Please check with the SVS group before making any
{   changes to this module.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cls$pdt_sections
*copyc clt$command_line_size
*copyc clt$lexical_kinds
*copyc clt$token
*copyc osd$code_base_pointer
*copyc oss$job_paged_literal
*copyc ost$name
*copyc ost$stack_frame_save_area
*copyc ost$virtual_machine_identifier
*copyc pme$system_exceptions
*copyc pmt$program_parameters
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc clp$evaluate_parameters
*copyc clp$put_job_command_response
*copyc clp$scan_token
*copyc dfi$display
*copyc fsp$open_file
*copyc i#disable_traps
*copyc i#program_error
*copyc i#restore_traps
*copyc i#sync
*copyc mmp$check_io_status
*copyc mmp$create_scratch_segment
*copyc mmp$free_pages
*copyc mmp$initiate_shadowing
*copyc mmp$read
*copyc mmp$terminate_shadowing
*copyc mmp$write
*copyc mmp$write_modified_pages
*copyc osp$set_status_abnormal
*copyc pfp$convert_pft$path_to_fs_path
*copyc pfp$define
*copyc pfp$define_catalog
*copyc pmp$binary_to_ascii_fit
*copyc pmp$cycle
*copyc pmp$delay
*copyc pmp$execute
*copyc pmp$exit
*copyc pmp$get_unique_name
*copyc pmp$get_user_identification
*copyc pmp$wait
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    err_testmem_id: [STATIC, cls$pdt, READ] string (23) := ' UTL Testmem - id error',
    err_testmem_rc: [STATIC, cls$pdt, READ] string (30) := ' UTL Testmem - rec count error',
    err_testmove_chars: [STATIC, cls$pdt, READ] string (37) := ' UTL Testmove - character field error',
    err_testmove_id: [STATIC, cls$pdt, READ] string (24) := ' UTL Testmove - id error',
    err_testmove_rc: [STATIC, cls$pdt, READ] string (31) := ' UTL Testmove - rec count error',
    err_utl_invalidcommand: [STATIC, cls$pdt, READ] string (22) := ' UTL - Invalid command',
    err_utl_noparams: [STATIC, cls$pdt, READ] string (16) := ' UTL - No params';
?? OLDTITLE ??
?? NEWTITLE := 'adrspec_command', EJECT ??

{ PURPOSE:
{   This test will cause an ADRSPEC error.
{         ADRSPEC

  PROCEDURE adrspec_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

    TYPE
      t$adrspec_record = RECORD
        ch: char,
        cs: integer,
      RECEND;

    VAR
      ok: 0 .. 2,
      old: integer,
      rec: t$adrspec_record;

    status.normal := TRUE;

    #COMPARE_SWAP (rec.cs, 0, 1, old, ok);

  PROCEND adrspec_command;
?? OLDTITLE ??
?? NEWTITLE := 'ageset_command', EJECT ??

{ PURPOSE:
{   This test will cause the task to create a working set equal to <pages> pages. After the working set is
{   created, the task will loop referencing each page up to the ageset pages <agews> to keep it in the working
{   set.  A unique ID is stored in each page. The task continually verifies the ID. If swapping (or other
{   memory manager bugs) exist that cause the ID to be invalid, the test will abort.  At the end of each pass
{   thru the loop, the test issues a pmp$wait request for <waittime> milliseconds. If this time exceeds the
{   long_wait swap time, the job will be swapped out.  This makes this test valuable for checking swapping.
{   If <readpage> is not equal to 1, each page is updated on each pass thru the loop. This causes more paging
{   IO under certain conditions.
{         AGESET,pages,totaltime,waittime,readpage,agews,age_pass

  PROCEDURE ageset_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int6_pdt

    TYPE
      t$page_record = RECORD
        id: integer,
        index: integer,
        pass: integer,
        fill: integer,
      RECEND;

    VAR
      age_pass: integer,
      age_pass_count: integer,
      age_time: integer,
      age_working_set: integer,
      current_working_set: integer,
      debug_p: ^cell,
      error_mess: string (80),
      error_size: integer,
      etime: integer,
      index: integer,
      id: integer,
      page_fac: integer,
      page_p: ^ARRAY [0 .. 65000000] OF t$page_record,
      pass: integer,
      purge_p: ^cell,
      read_page: boolean,
      time: integer,
      wait_time: integer,
      working_set: integer,
      working_set_size: integer;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    time := #FREE_RUNNING_CLOCK (0);
    working_set := pvt [p$p1].value^.integer_value.value;
    etime := time + 1000 * pvt [p$p2].value^.integer_value.value;
    wait_time := pvt [p$p3].value^.integer_value.value;
    read_page := pvt [p$p4].value^.integer_value.value = 1;
    age_working_set := pvt [p$p5].value^.integer_value.value;
    age_pass := pvt [p$p6].value^.integer_value.value;

    page_fac := (512 * (128 - #READ_REGISTER (4a(16)))) DIV 32;
    get_segment (command_type, #LOC (page_p), status);
    IF NOT status.normal THEN
      display_status (status);
      i#program_error;
      RETURN;
    IFEND;

    current_working_set := 0;
    id := #FREE_RUNNING_CLOCK (0);
    pass := 0;

    WHILE current_working_set < working_set DO
      pass := pass + 1;
      page_p^ [current_working_set * page_fac].id := id;
      page_p^ [current_working_set * page_fac].index := current_working_set;
      page_p^ [current_working_set * page_fac].pass := pass;
      current_working_set := current_working_set + 1;
      FOR index := 0 TO current_working_set - 1 DO
        IF (page_p^ [index * page_fac].id <> id) OR (page_p^ [index * page_fac].index <> index) OR
              (NOT read_page AND (page_p^ [index * page_fac].pass <> pass)) THEN
          clp$put_job_command_response (' Ageset failure - actual/expected', status);
          STRINGREP (error_mess, error_size, ' Ageset ', ' id ', page_p^ [index * page_fac].id, id, ' index ',
                page_p^ [index * page_fac].index, index, ' pass ', page_p^ [index * page_fac].pass, pass);
          clp$put_job_command_response (error_mess (1, error_size), status);
          debug_p := ^page_p^ [index * page_fac].id;
          STRINGREP (error_mess, error_size, ' Pva id rec', debug_p, ' cws ', current_working_set, ' Read',
                read_page);
          clp$put_job_command_response (error_mess (1, error_size), status);
          i#program_error;
        IFEND;
        IF NOT read_page THEN
          page_p^ [index * page_fac].pass := pass + 1;
        IFEND;
      FOREND;
      purge_p := ^page_p^ [0];
      #PURGE_BUFFER (4, purge_p);
    WHILEND;

    age_pass_count := 0;

    WHILE time < etime DO
      pass := pass + 1;
      age_pass_count := age_pass_count + 1;
      pmp$wait (wait_time, wait_time);
      IF age_pass_count >= age_pass THEN
        working_set_size := current_working_set - 1;
        age_pass_count := 0;
      ELSE
        working_set_size := age_working_set - 1;
      IFEND;
      FOR index := 0 TO working_set_size DO
        IF (page_p^ [index * page_fac].id <> id) OR (page_p^ [index * page_fac].index <> index) OR
              (NOT read_page AND (page_p^ [index * page_fac].pass <> pass)) THEN
          clp$put_job_command_response (' Ageset failure - actual/expected', status);
          STRINGREP (error_mess, error_size, ' Ageset ', ' id ', page_p^ [index * page_fac].id, id, ' index ',
                page_p^ [index * page_fac].index, index, ' pass ', page_p^ [index * page_fac].pass, pass);
          clp$put_job_command_response (error_mess (1, error_size), status);
          debug_p := ^page_p^ [index * page_fac].id;
          STRINGREP (error_mess, error_size, ' Pva id rec', debug_p, ' aws ', age_working_set, ' Read',
                read_page);
          clp$put_job_command_response (error_mess (1, error_size), status);
          i#program_error;
        IFEND;
        IF NOT read_page THEN
          page_p^ [index * page_fac].pass := pass + 1;
        IFEND;
      FOREND;
      purge_p := ^page_p^ [0];
      #PURGE_BUFFER (4, purge_p);
      time := #FREE_RUNNING_CLOCK (0);
    WHILEND;

  PROCEND ageset_command;
?? OLDTITLE ??
?? NEWTITLE := 'arovfl_command', EJECT ??

{ PURPOSE:
{   This test will cause an arithmetic overflow.
{         AROVFL

  PROCEDURE arovfl_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

    VAR
      i: integer,
      j: integer,
      mes: string (30);

    i := 07fffffff(16);
    i := i * 100000000(16);
    i := i + 0ffffffff(16);
    j := i;
    i := i + 1;
    IF (j + i) <> -1 THEN
      mes := ' UTL Arovfl error';
      clp$put_job_command_response (mes, status);
      osp$set_status_abnormal ('UT', 987654, mes, status);
      pmp$exit (status);
    IFEND;

  PROCEND arovfl_command;
?? OLDTITLE ??
?? NEWTITLE := 'bigseg_command', EJECT ??

{ PURPOSE:
{   This test causes creation of a segment <bc> bytes long. If <bc> is big, this test can be used to cause
{   disk full conditions or other interesting DM problems.  This test runs quickly because only 1 page is
{   actually written to the segment. DM, however, allocates space for all pages up thru the page specified
{   by <bc>.
{         BIGSEGP,bc               (for permanent files)
{         BIGSEG,bc                (for scratch files)

  PROCEDURE bigseg_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int1_pdt

    VAR
      segment_p: ^ARRAY [0 .. 7fffffff(16)] OF char;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_segment (command_type, #LOC (segment_p), status);
    IF NOT status.normal THEN
      display_status (status);
      i#program_error;
      RETURN;
    IFEND;

    segment_p^ [pvt [p$p1].value^.integer_value.value] := 'a';
    mmp$write_modified_pages (segment_p, 7fffffff(16), osc$wait, status);
    IF NOT status.normal THEN
      display_status (status);
      i#program_error;
      RETURN;
    IFEND;

  PROCEND bigseg_command;
?? OLDTITLE ??
?? NEWTITLE := 'bulk_command', EJECT ??

{ PURPOSE:
{   This test initiates execution of a predetermined list of UUTL tests.  If <async> is > 0, each pass thru
{   the loop will run the tests as asynchronous tasks.  The total pass count is specified by <passes>.  The
{   test set run by BULKNTC is selected so that all test terminate normally, ie. its OK to run with HALTRING
{   = 15.
{         BULK,passes,asyn
{         BULKNTC,passes,asyn

  PROCEDURE bulk_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int2_pdt

    TYPE
      t$bulk_list = RECORD
        command: string (19),
        status_condition: ost$status_condition,
      RECEND;

    VAR
      bulk_list_size: integer,
      command: string (20),
      error_list: ARRAY [1 .. 20] OF integer,
      error_msg: string (40),
      index: integer,
      info: string (40),
      list_p: ^ARRAY [1 .. * ] OF t$bulk_list,
      loop_count: integer,
      ok_msg: string (40),
      param_string_p: ^ost$string,
      program_attributes_p: ^pmt$program_attributes,
      task_status_p: ^ARRAY [1 .. * ] OF pmt$task_status,
      taskid: pmt$task_id,
      uutl_helper_p: ^pmt$program_description,
      uutl_helper_params_p: ^pmt$program_parameters,
      wait: ost$wait,

      v$bulk_list: [STATIC, cls$pdt, READ] ARRAY [1 .. 16] OF t$bulk_list := [
            ['loop,5             ', 0],
            ['timeout,5          ', 0],
            ['cycle,5            ', 0],
            ['recurse,25         ', 0],
            ['testmem,50000      ', 0],
            ['testmove,10000     ', 0],
            ['return,1           ', pme$system_condition],
            ['return,2           ', pme$system_condition],
            ['divflt             ', pme$system_condition],
            ['insspec            ', pme$system_condition],
            ['adrspec            ', pme$system_condition],
            ['envspec            ', pme$system_condition],
            ['privins            ', pme$system_condition],
            ['la,257800000000(16)', pme$system_condition],
            ['sa,100200000000(16)', pme$system_condition],
            ['arovfl             ', pme$system_condition]],

      v$bulkntc_list: [STATIC, cls$pdt, READ] ARRAY [1 .. 9] OF t$bulk_list := [
            ['loop,500           ', 000000(16)],
            ['loop,5             ', 000000(16)],
            ['timeout,5,500      ', 000000(16)],
            ['cycle,500          ', 000000(16)],
            ['recurse,5000       ', 000000(16)],
            ['loop,10            ', 000000(16)],
            ['testmem,100000     ', 000000(16)],
            ['testmove,100000    ', 000000(16)],
            ['loop,1000          ', 000000(16)]];

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF command_type = '2' THEN
      list_p := ^v$bulkntc_list;
    ELSE
      list_p := ^v$bulk_list;
    IFEND;

    bulk_list_size := UPPERBOUND (list_p^);
    IF pvt [p$p2].value^.integer_value.value = 1 THEN
      wait := osc$wait;
    ELSE
      wait := osc$nowait;
    IFEND;

    PUSH task_status_p: [1 .. bulk_list_size];

    info := ' UUTL    ...pass 00000 of 00000 completed';
    pmp$binary_to_ascii_fit (pvt [p$p1].value^.integer_value.value, 10, 31, 5, info);

    error_msg := '                      failed 00000 times';
    ok_msg := '*** all tests ran as expected ***       ';

    FOR index := 1 TO bulk_list_size DO
      error_list [index] := 0;
    FOREND;

    PUSH uutl_helper_p: [[REP 1 OF pmt$program_attributes]];
    RESET uutl_helper_p;
    NEXT program_attributes_p IN uutl_helper_p;
    program_attributes_p^.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$load_map_options_specified, pmc$term_error_level_specified];
    program_attributes_p^.starting_procedure := 'UUTL';
    program_attributes_p^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    program_attributes_p^.termination_error_level := pmc$warning_load_errors;

    PUSH uutl_helper_params_p: [[REP 1 OF ost$string]];
    RESET uutl_helper_params_p;
    NEXT param_string_p IN uutl_helper_params_p;

    FOR loop_count := 1 TO pvt [p$p1].value^.integer_value.value DO
      FOR index := 1 TO bulk_list_size DO
        command (1) := ' ';
        command (2, * ) := list_p^ [index].command;
        clp$put_job_command_response (command, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        param_string_p^.size := #SIZE (list_p^ [index].command);
        param_string_p^.value := list_p^ [index].command;
        pmp$execute (uutl_helper_p^, uutl_helper_params_p^, wait, taskid, task_status_p^ [index], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

      FOR index := 1 TO bulk_list_size DO
        WHILE NOT task_status_p^ [index].complete DO
          pmp$delay (500, status);
        WHILEND;
        IF task_status_p^ [index].status.normal THEN
          IF list_p^ [index].status_condition <> 0 THEN
            error_list [index] := error_list [index] + 1;
          IFEND;
        ELSE
          IF (task_status_p^ [index].status.condition <> list_p^ [index].status_condition) THEN
            error_list [index] := error_list [index] + 1;
          IFEND;
        IFEND;
      FOREND;

      pmp$binary_to_ascii_fit (loop_count, 10, 22, 5, info);
      clp$put_job_command_response (info, status);
    FOREND;

    FOR index := 1 TO bulk_list_size DO
      IF error_list [index] > 0 THEN
        error_msg (1, 19) := list_p^ [index].command;
        pmp$binary_to_ascii_fit (error_list [index], 10, 34, 5, error_msg);
        clp$put_job_command_response (error_msg, status);
      IFEND;
    FOREND;

    IF error_msg (30, 5) = '00000' THEN
      clp$put_job_command_response (ok_msg, status);
    IFEND;

  PROCEND bulk_command;
?? OLDTITLE ??
?? NEWTITLE := 'caller_command', EJECT ??

{ PURPOSE:
{    This test will make asynchronous calls to the program specified by <name>. A total of <count> instances
{    of the task are initiated. Eack task is passed the parameters specified by <string>.
{    Example:
{      exet sp=uutl p='CALLER,UUTL,25,''LOOP,30000''' will initiate 25 instances of UUTL, each will execute
{      a CP bound loop for 30 seconds.
{          CALLER,name,count,string

  PROCEDURE caller_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_call_pdt

    VAR
      callee_p: ^pmt$program_description,
      callee_params_p: ^pmt$program_parameters,
      index: integer,
      param_string_p: ^ost$string,
      program_attributes_p: ^pmt$program_attributes,
      task_status: pmt$task_status,
      taskid: pmt$task_id;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH callee_p: [[REP 1 OF pmt$program_attributes]];
    RESET callee_p;
    NEXT program_attributes_p IN callee_p;
    program_attributes_p^.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$load_map_options_specified, pmc$term_error_level_specified];
    program_attributes_p^.starting_procedure := pvt [p$pn].value^.name_value;
    program_attributes_p^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    program_attributes_p^.termination_error_level := pmc$warning_load_errors;

    PUSH callee_params_p: [[REP 1 OF ost$string]];
    RESET callee_params_p;
    NEXT param_string_p IN callee_params_p;
    param_string_p^.value := pvt [p$param].value^.string_value^;
    param_string_p^.size := #SIZE (pvt [p$param].value^.string_value^);

    FOR index := 1 TO pvt [p$number].value^.integer_value.value DO
      pmp$execute (callee_p^, callee_params_p^, osc$nowait, taskid, task_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND caller_command;
?? OLDTITLE ??
?? NEWTITLE := 'cp_wait_command', EJECT ??

{ PURPOSE:
{   This test will cause the task to execute a CP bound loop for one second, and then wait one second.  This
{   cycle repeats for <t> milliseconds.
{         CP_WAIT,t

  PROCEDURE cp_wait_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int1_pdt

    VAR
      etime: integer,
      execute_time: integer,
      time: integer;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    time := #FREE_RUNNING_CLOCK (0);
    etime := time + 1000 * pvt [p$p1].value^.integer_value.value;
    WHILE time < etime DO
      execute_time := #FREE_RUNNING_CLOCK (0);
      WHILE ((#FREE_RUNNING_CLOCK (0) - execute_time ) < 1000000) DO
      WHILEND;
      time := #FREE_RUNNING_CLOCK (0);
      pmp$delay (1000, status);
    WHILEND;

  PROCEND cp_wait_command;
?? OLDTITLE ??
?? NEWTITLE := 'cycle_command', EJECT ??

{ PURPOSE:
{   This test will execute pmp$cycle requests of <t1> milliseconds for a total wallclock time equal to <t2>
{   milliseconds.
{         CYCLE,t1,t2

  PROCEDURE cycle_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int1_pdt

    VAR
      etime: integer,
      time: integer;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    time := #FREE_RUNNING_CLOCK (0);
    etime := time + 1000 * pvt [p$p1].value^.integer_value.value;
    WHILE time < etime DO
      pmp$cycle (status);
      time := #FREE_RUNNING_CLOCK (0);
    WHILEND;

  PROCEND cycle_command;
?? OLDTITLE ??
?? NEWTITLE := 'divflt_command', EJECT ??

{ PURPOSE:
{   This test will cause a divide fault.
{         DIVFLT

  PROCEDURE divflt_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

    VAR
      i: integer,
      mes: string (30);

    status.normal := TRUE;
    i := 0;
    i := 6 DIV i;
    IF i <> 6 THEN
      mes := ' UTL Divflt error';
      clp$put_job_command_response (mes, status);
      osp$set_status_abnormal ('UT', 987654, mes, status);
      pmp$exit (status);
    IFEND;

  PROCEND divflt_command;
?? OLDTITLE ??
?? NEWTITLE := 'envspec_command', EJECT ??

{ PURPOSE:
{   This test will cause an ENV-SPEC error.
{         ENCSPEC

  PROCEDURE envspec_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

    TYPE
      t$psa = RECORD
        p_register: ost$p_register,
        vmid: 0 .. 0ff(16),
        fil0: 0 .. 0ff(16),
        a0: ost$pva,
        fil1: 0 .. 0ffff(16),
        a1: ost$pva,
        fil2: 0 .. 0ffff(16),
        a2: ost$pva,
      RECEND;

    VAR
      psa_p: ^t$psa;

    status.normal := TRUE;
    psa_p := #PREVIOUS_SAVE_AREA ();
    psa_p^.a0.offset := 3;

  PROCEND envspec_command;
?? OLDTITLE ??
?? NEWTITLE := 'get_segment', EJECT ??

  PROCEDURE get_segment
    (    command_type: char;
         xp_p: ^^cell;
     VAR status: ost$status);

    VAR
      attachment_options_p: ^fst$attachment_options,
      cycle_selector: pft$cycle_selector,
      file_identifier: amt$file_identifier,
      fpath: ARRAY [1 .. 4] OF pft$name,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      password: ost$name,
      path: ARRAY [1 .. 3] OF pft$name,
      segment_pointer: amt$segment_pointer,
      server_fpath: ARRAY [1 .. 4] OF pft$name,
      uname: ost$name,
      user_id: ost$user_identification;

    status.normal := TRUE;

    CASE command_type OF
    = 'T' =
      mmp$create_scratch_segment (amc$cell_pointer, mmc$as_random, segment_pointer, status);

    = 'P' =
      pmp$get_unique_name (uname, status);
      path [1] := ' ';
      path [2] := ' ';
      path [3] := 'UUTL_TEST_CATALOG';
      pfp$define_catalog (path, status);
      fpath [1] := ' ';
      fpath [2] := ' ';
      fpath [3] := 'UUTL_TEST_CATALOG';
      fpath [4] := uname;
      password := ' ';
      cycle_selector.cycle_option := pfc$lowest_cycle;
      pfp$define (uname, fpath, cycle_selector, password, 1, pfc$no_log, status);
      IF status.normal THEN
        amp$open (uname, amc$segment, NIL, file_identifier, status);
        IF status.normal THEN
          amp$get_segment_pointer (file_identifier, amc$cell_pointer, segment_pointer, status);
        IFEND;
      IFEND;

    = 'S' =
      pmp$get_unique_name (uname, status);
      path [1] := 'TESTING';
      path [2] := ' ';
      path [3] := 'UUTL_KRUNCHS_TEST_CATALOG';
      pfp$define_catalog (path, status);
      server_fpath [1] := 'TESTING';
      server_fpath [2] := ' ';
      server_fpath [3] := 'UUTL_KRUNCHS_TEST_CATALOG';
      server_fpath [4] := uname;
      password := ' ';
      cycle_selector.cycle_option := pfc$lowest_cycle;
      pfp$define (uname, server_fpath, cycle_selector, password, 1, pfc$no_log, status);
      IF status.normal THEN
        amp$open (uname, amc$segment, NIL, file_identifier, status);
        IF status.normal THEN
          amp$get_segment_pointer (file_identifier, amc$cell_pointer, segment_pointer, status);
        IFEND;
      IFEND;

    = 'X' =
      pmp$get_unique_name (uname, status);
      pmp$get_user_identification (user_id, status);
      path [1] := user_id.family;
      path [2] := user_id.user;
      path [3] := 'UUTL_KRUNCHX_TEST_CATALOG';
      pfp$define_catalog (path, status);
      fpath [1] := user_id.family;
      fpath [2] := user_id.user;
      fpath [3] := 'UUTL_KRUNCHX_TEST_CATALOG';
      fpath [4] := uname;
      PUSH attachment_options_p: [1 .. 2];
      attachment_options_p^ [1].selector := fsc$access_and_share_modes;
      attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options_p^ [1].access_modes.value :=
            $fst$file_access_options [fsc$read, fsc$append, fsc$shorten, fsc$modify, fsc$execute];
      attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;
      attachment_options_p^ [1].share_modes.value := $fst$file_access_options [];
      attachment_options_p^ [2].selector := fsc$exception_detection;
      attachment_options_p^ [2].exception_detection :=
            $fst$cycle_damage_symptoms [fsc$media_image_inconsistent];
      pfp$convert_pft$path_to_fs_path (fpath, fs_path, fs_path_size);
      fsp$open_file (fs_path (1, fs_path_size), amc$segment, attachment_options_p, NIL, NIL, NIL, NIL,
            file_identifier, status);
      IF status.normal THEN
        amp$get_segment_pointer (file_identifier, amc$cell_pointer, segment_pointer, status);
      IFEND;

    = 'N' =
      pmp$get_unique_name (uname, status);
      pmp$get_user_identification (user_id, status);
      path [1] := user_id.family;
      path [2] := user_id.user;
      path [3] := 'UUTL_KRUNCHN_TEST_CATALOG';
      pfp$define_catalog (path, status);
      fpath [1] := user_id.family;
      fpath [2] := user_id.user;
      fpath [3] := 'UUTL_KRUNCHN_TEST_CATALOG';
      fpath [4] := uname;
      PUSH attachment_options_p: [1 .. 2];
      attachment_options_p^ [1].selector := fsc$access_and_share_modes;
      attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options_p^ [1].access_modes.value :=
            $fst$file_access_options [fsc$read, fsc$append, fsc$shorten, fsc$modify, fsc$execute];
      attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;
      attachment_options_p^ [1].share_modes.value :=
            $fst$file_access_options [fsc$read, fsc$append, fsc$shorten, fsc$modify, fsc$execute];
      attachment_options_p^ [2].selector := fsc$exception_detection;
      attachment_options_p^ [2].exception_detection :=
            $fst$cycle_damage_symptoms [fsc$media_image_inconsistent];
      pfp$convert_pft$path_to_fs_path (fpath, fs_path, fs_path_size);
      fsp$open_file (fs_path (1, fs_path_size), amc$segment, attachment_options_p, NIL, NIL, NIL, NIL,
            file_identifier, status);
      IF status.normal THEN
        amp$get_segment_pointer (file_identifier, amc$cell_pointer, segment_pointer, status);
      IFEND;

    = 'A' =
      pmp$get_unique_name (uname, status);
      pmp$get_user_identification (user_id, status);
      path [1] := user_id.family;
      path [2] := user_id.user;
      path [3] := 'UUTL_KRUNCHA_TEST_CATALOG';
      pfp$define_catalog (path, status);
      fpath [1] := user_id.family;
      fpath [2] := user_id.user;
      fpath [3] := 'UUTL_KRUNCHA_TEST_CATALOG';
      fpath [4] := uname;
      PUSH attachment_options_p: [1 .. 3];
      attachment_options_p^ [1].selector := fsc$access_and_share_modes;
      attachment_options_p^ [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options_p^ [1].access_modes.value :=
            $fst$file_access_options [fsc$read, fsc$append, fsc$shorten, fsc$modify, fsc$execute];
      attachment_options_p^ [1].share_modes.selector := fsc$specific_share_modes;
      attachment_options_p^ [1].share_modes.value := $fst$file_access_options [];
      attachment_options_p^ [2].selector := fsc$exception_detection;
      attachment_options_p^ [2].exception_detection :=
            $fst$cycle_damage_symptoms [fsc$media_image_inconsistent];
      attachment_options_p^ [3].selector := fsc$allowed_exceptions;
      attachment_options_p^ [3].allowed_exceptions.damage_symptoms :=
            $fst$cycle_damage_symptoms [fsc$media_image_inconsistent];
      attachment_options_p^ [3].allowed_exceptions.access_conditions := $fst$file_access_conditions [];
      pfp$convert_pft$path_to_fs_path (fpath, fs_path, fs_path_size);
      fsp$open_file (fs_path (1, fs_path_size), amc$segment, attachment_options_p, NIL, NIL, NIL, NIL,
            file_identifier, status);
      IF status.normal THEN
        amp$get_segment_pointer (file_identifier, amc$cell_pointer, segment_pointer, status);
      IFEND;
    ELSE
      status.normal := FALSE;
    CASEND;

    IF status.normal THEN
      xp_p^ := segment_pointer.cell_pointer;
    IFEND;

  PROCEND get_segment;
?? OLDTITLE ??
?? NEWTITLE := 'insspec_command', EJECT ??

{ PURPOSE:
{   This test will cause an instruction-spec error.
{         INSSPEC

  PROCEDURE insspec_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

    VAR
      cs: integer,
      ok: 0 .. 2,
      old: integer;

    status.normal := TRUE;

    #COMPARE_SWAP (cs, 0, -1, old, ok);

  PROCEND insspec_command;
?? OLDTITLE ??
?? NEWTITLE := 'iotest_command', EJECT ??

{ PURPOSE:
{   This test is used to put a heavy load on the disk channels by doing the following:
{   . It creates <segments> and writes data into several pages of each segment.
{   . It randomly reads, writes, and checks data in pages of the segments and will abort if any data is bad.
{   . Periodically the test will wait for <waittime> milliseconds. If this time is large enough the job will
{     be swapped out.
{   . The test runs for total time of <totaltime> milliseconds.
{   NOTE: test currently requires ring 6 privilege.  For max IO load, do NOT exceed 50 segments.
{         IOTEST,segs,totaltime,waittime,pages_per_seg
{         IOTESTP,segs,totaltime,waittime,pages_per_seg

  PROCEDURE iotest_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int4_pdt

    TYPE
      t$blk_record = RECORD
        p: ^t$id_record,
        id_rec: t$id_record,
        rw: (rw_read, rw_write),
        wle: mmt$io_status,
      RECEND,

      t$id_record = RECORD
        id: integer,
        time: integer,
        count: integer,
      RECEND;

    VAR
      blk_p: ^ARRAY [1 .. * ] OF t$blk_record,
      count: integer,
      error_mess: string (80),
      error_size: integer,
      etime: integer,
      i: integer,
      ix: integer,
      j: integer,
      local_status: ost$status,
      null_id_rec: [STATIC, READ, oss$job_paged_literal] t$id_record := [0, 0, 0],
      p: ^cell,
      pageseg: integer,
      pagesize: integer,
      segments: integer,
      waittime: integer,
      wl_p: ^mmt$io_status_pointer_array;

?? NEWTITLE := 'update_block', EJECT ??

    PROCEDURE update_block
      (    i: integer);

      IF blk_p^ [i].p^ <> blk_p^ [i].id_rec THEN
        clp$put_job_command_response (' iotest update_block failure ', status);
        stringrep (error_mess, error_size, ' i ', i, ' pva ', blk_p^ [i].p);
        clp$put_job_command_response (error_mess (1, error_size), status);
        stringrep (error_mess, error_size, ' Expected id, time, count ', blk_p^ [i].id_rec.id,
              blk_p^ [i].id_rec.time, blk_p^ [i].id_rec.count);
        clp$put_job_command_response (error_mess (1, error_size), status);
        stringrep (error_mess, error_size, ' Actual id, time, count ', blk_p^ [i].p^.id, blk_p^ [i].p^.time,
              blk_p^ [i].p^.count);
        clp$put_job_command_response (error_mess (1, error_size), status);
        i#program_error;
      IFEND;
      blk_p^ [i].id_rec.count := blk_p^ [i].id_rec.count + 1;
      blk_p^ [i].id_rec.time := #FREE_RUNNING_CLOCK (0);
      blk_p^ [i].p^ := blk_p^ [i].id_rec;

    PROCEND update_block;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    segments := pvt [p$p1].value^.integer_value.value;
    etime := pvt [p$p2].value^.integer_value.value * 1000;
    waittime := pvt [p$p3].value^.integer_value.value;
    IF waittime > 1 THEN
      count := 500;
    ELSE
      count := 7fffffffffff(16);
    IFEND;
    pageseg := pvt [p$p4].value^.integer_value.value;

    PUSH wl_p: [1 .. segments * pageseg];
    PUSH blk_p: [1 .. segments * pageseg];
    pagesize := 512 * (128 - #READ_REGISTER (4a(16)));

    ix := 1;
    FOR i := 1 TO segments DO
      get_segment (command_type, #LOC (p), status);
      IF NOT status.normal THEN
        display_status (status);
        i#program_error;
        RETURN;
      IFEND;
      FOR j := 1 TO pageseg DO
        blk_p^ [ix].p := #ADDRESS (1, #SEGMENT (p), pagesize * (j - 1));
        blk_p^ [ix].id_rec.id := #FREE_RUNNING_CLOCK (0);
        blk_p^ [ix].id_rec.time := 0;
        blk_p^ [ix].id_rec.count := 0;
        blk_p^ [ix].p^ := blk_p^ [ix].id_rec;
        blk_p^ [ix].rw := rw_write;
        blk_p^ [ix].wle.request_status := mmc$irs_none;
        wl_p^ [ix] := ^blk_p^ [ix].wle;
        mmp$write_modified_pages (p, 1000, osc$wait, status);
        IF NOT status.normal THEN
          stringrep (error_mess, error_size, 'mmp$write_modified_pages in iotest', ' Address ', p);
          clp$put_job_command_response (error_mess (1, error_size), local_status);
          display_status (status);
          i#program_error;
        IFEND;
        mmp$write (blk_p^ [ix].p, pagesize, TRUE, wl_p^ [ix], osc$nowait, status);
        IF NOT status.normal THEN
          stringrep (error_mess, error_size, 'mmp$write in iotest', ' Address ', blk_p^ [ix].p);
          clp$put_job_command_response (error_mess (1, error_size), local_status);
          display_status (status);
          i#program_error;
        IFEND;
        ix := ix + 1;
      FOREND;
    FOREND;

    etime := etime + #FREE_RUNNING_CLOCK (0);
    WHILE #FREE_RUNNING_CLOCK (0) < etime DO
      count := count - 1;
      IF count = 0 THEN
        pmp$wait (waittime, waittime);
        count := 500;
      IFEND;
      mmp$check_io_status (wl_p^, 100000000, i, status);
      IF NOT status.normal THEN
        clp$put_job_command_response (' mmp$check_io_status iotest_command', local_status);
        display_status (status);
        i#program_error;
      IFEND;
      IF blk_p^ [i].rw = rw_read THEN
        update_block (i);
        blk_p^ [i].rw := rw_write;
        mmp$write (blk_p^ [i].p, pagesize, TRUE, wl_p^ [i], osc$nowait, status);
        IF NOT status.normal THEN
          stringrep (error_mess, error_size, 'mmp$write in iotest', ' Address ', blk_p^ [i].p);
          clp$put_job_command_response (error_mess (1, error_size), local_status);
          display_status (status);
          i#program_error;
        IFEND;
      ELSE
        mmp$free_pages (blk_p^ [i].p, pagesize, osc$wait, status);
        mmp$read (blk_p^ [i].p, pagesize, wl_p^ [i], osc$nowait, status);
        IF NOT status.normal THEN
          stringrep (error_mess, error_size, 'mmp$read in iotest', ' Address ', blk_p^ [i].p);
          clp$put_job_command_response (error_mess (1, error_size), local_status);
          display_status (status);
          i#program_error;
        IFEND;
        blk_p^ [i].rw := rw_read;
      IFEND;
    WHILEND;

  PROCEND iotest_command;
?? OLDTITLE ??
?? NEWTITLE := 'krunch_command', EJECT ??

{ PURPOSE:
{   This test is used to put a heavy load on the system by doing the following:
{   . It creates <segments> and writes data into several pages of each segment.
{   . It randomly reads, writes, and checks data in pages of the segments and will abort if any data is bad.
{   . Periodically the test will wait for <waittime> milliseconds. If this time is large enough the job will
{     be swapped out.
{   . The test runs for total time of <totaltime> milliseconds.
{         KRUNCH,segments,totaltime,waittime,readopt         (for scratch files)
{         KRUNCHP,segments,totaltime,waittime,readopt        (for permanent files)
{         KRUNCHS,segments,totaltime,waittime,readopt        (for permanent SERVER files)
{         KRUNCHX,segments,totaltime,waittime,readopt        (for media_image_inconsistent files)
{         KRUNCHN,segments,totaltime,waittime,readopt        (for media_image_inconsistent files)
{         KRUNCHA,segments,totaltime,waittime,readopt        (for media_image_inconsistent files)

  PROCEDURE krunch_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int4_pdt

    TYPE
      t$d_record = RECORD
        p: ^t$id_record,
        id_rec: t$id_record,
      RECEND,

      t$id_record = RECORD
        id: integer,
        time: integer,
        count: integer,
        offset: integer,
      RECEND;

    VAR
      blocksize: integer,
      c_check: integer,
      d_p: ^ARRAY [1 .. 4096] OF t$d_record,
      error_mess: string (80),
      error_size: integer,
      etime: integer,
      i: integer,
      j: integer,
      pagesize: integer,
      p: amt$segment_pointer,
      ran: integer,
      seed: integer,
      segments: integer,
      time: integer,
      wait_time: integer;

?? NEWTITLE := 'random', EJECT ??

    PROCEDURE random
      (    max: integer;
       VAR i: integer);

      seed := (seed * 1953125) MOD 100000000(16);
      i := 1 + (seed * max) DIV 100000000(16);

    PROCEND random;
?? OLDTITLE ??
?? NEWTITLE := 'store_id_record', EJECT ??

    PROCEDURE store_id_record
      (    i: integer);

      VAR
        id_rec: t$id_record,
        p: ^t$id_record;

      id_rec := d_p^ [i].id_rec;
      p := d_p^ [i].p;
      WHILE #OFFSET (p) < blocksize DO
        id_rec.offset := #OFFSET (p);
        p^ := id_rec;
        p := #ADDRESS (1, #SEGMENT (p), #OFFSET (p) + pagesize);
      WHILEND;

    PROCEND store_id_record;
?? OLDTITLE ??
?? NEWTITLE := 'check_block', EJECT ??

    PROCEDURE check_block
      (    i: integer);

      VAR
        id_rec: t$id_record,
        p: ^t$id_record;

      p := d_p^ [i].p;
      id_rec := d_p^ [i].id_rec;
      WHILE #OFFSET (p) < blocksize DO
        id_rec.offset := #OFFSET (p);
        IF id_rec <> p^ THEN
          clp$put_job_command_response (' krunch  check_block failure ', status);
          stringrep (error_mess, error_size, ' I ', i, ' Pva ', p);
          clp$put_job_command_response (error_mess (1, error_size), status);
          stringrep (error_mess, error_size, ' Expected id, time, count, offset ', id_rec.id, id_rec.time,
                id_rec.count, id_rec.offset);
          clp$put_job_command_response (error_mess (1, error_size), status);
          stringrep (error_mess, error_size, ' Actual id, time, count, offset ', p^.id, p^.time, p^.count,
                p^.offset);
          clp$put_job_command_response (error_mess (1, error_size), status);
          i#program_error;
        IFEND;
        p := #ADDRESS (1, #SEGMENT (p), #OFFSET (p) + pagesize);
      WHILEND;

    PROCEND check_block;
?? OLDTITLE ??
?? NEWTITLE := 'update_block', EJECT ??

    PROCEDURE update_block
      (    i: integer);

      check_block (i);
      d_p^ [i].id_rec.count := d_p^ [i].id_rec.count + 1;
      d_p^ [i].id_rec.time := #FREE_RUNNING_CLOCK (0);
      store_id_record (i);

    PROCEND update_block;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    time := #FREE_RUNNING_CLOCK (0);
    segments := pvt [p$p1].value^.integer_value.value;
    etime := time + 1000 * pvt [p$p2].value^.integer_value.value;
    wait_time := pvt [p$p3].value^.integer_value.value;
    c_check := pvt [p$p4].value^.integer_value.value;

    seed := 61429387;
    PUSH d_p;
    pagesize := 512 * (128 - #READ_REGISTER (4a(16)));
    blocksize := 32768;

    FOR i := 1 TO segments DO
      get_segment (command_type, #LOC (d_p^ [i].p), status);
      IF NOT status.normal THEN
        display_status (status);
        i#program_error;
        RETURN;
      IFEND;
      d_p^ [i].id_rec.id := #FREE_RUNNING_CLOCK (0);
      d_p^ [i].id_rec.time := 0;
      d_p^ [i].id_rec.count := 0;
      store_id_record (i);
    FOREND;

    WHILE #FREE_RUNNING_CLOCK (0) < etime DO
      FOR i := 1 TO 50 DO
        random (100, ran);
        random (segments, j);
        IF ran > c_check THEN
          check_block (j);
        ELSE
          update_block (j);
        IFEND;
      FOREND;
      pmp$wait (wait_time, wait_time);
    WHILEND;

  PROCEND krunch_command;
?? OLDTITLE ??
?? NEWTITLE := 'la_command', EJECT ??

{ PURPOSE:
{   This test will execute a LA instruction for the PVA specified by <pva>. Depending on the value of <pva>,
{   this test can be used to generate various failures such as invalid segment, ring zero, page fault, page
{   fault beyond EOI, etc.
{         LA,pva

  PROCEDURE la_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int1_pdt

    TYPE
      t$la_record = RECORD
        CASE boolean OF
        = TRUE =
          data_p: ^char,
        = FALSE =
          data_integer: 0 .. 0ffffffffffff(16),
        CASEND,
      RECEND;

    VAR
      character_data: char,
      la_record: t$la_record;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    la_record.data_integer := pvt [p$p1].value^.integer_value.value;
    character_data := la_record.data_p^;

  PROCEND la_command;
?? OLDTITLE ??
?? NEWTITLE := 'loop_command', EJECT ??

{ PURPOSE:
{   This test will cause the task to execute a CP bound loop for <t> milliseconds.
{         LOOP,t

  PROCEDURE loop_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int1_pdt

    VAR
      etime: integer,
      index: integer,
      time: integer;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    time := #FREE_RUNNING_CLOCK (0);
    etime := time + 1000 * pvt [p$p1].value^.integer_value.value;
    WHILE time < etime DO
      FOR index := 1 TO 100 DO
        time := etime;
      FOREND;
      time := #FREE_RUNNING_CLOCK (0);
    WHILEND;

  PROCEND loop_command;
?? OLDTITLE ??
?? NEWTITLE := 'privins_command', EJECT ??

{ PURPOSE:
{   This test will cause a privileged instruction fault.
{         PRIVINS

  PROCEDURE privins_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

    status.normal := TRUE;

    { Write to the SIT.

    #WRITE_REGISTER (80(16), 8);

  PROCEND privins_command;
?? OLDTITLE ??
?? NEWTITLE := 'recurse_command', EJECT ??

{ PURPOSE:
{   This test will cause a recursive procedure <count> times. This test is useful for causing large stack
{   segments to be created.
{         RECURSE,count

  PROCEDURE recurse_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int1_pdt

?? NEWTITLE := 'recurser', EJECT ??

    PROCEDURE recurser
      (    recurser_index: integer);

      IF recurser_index > 0 THEN
        recurser (recurser_index - 1);
      IFEND;

    PROCEND recurser;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    recurser (pvt [p$p1].value^.integer_value.value);

  PROCEND recurse_command;
?? OLDTITLE ??
?? NEWTITLE := 'repeat_command', EJECT ??

{ PURPOSE:
{   This test will make repeated calls to the program specified by <name>. A total of <count> instances of the
{   task are initiated. Eack task is passed the parameters specified by <string>.
{   Example:
{     exet sp=uutl p='caller,uutl,25,''loop,30000''' will initiate 25 instances of UUTL, each will execute a
{     CP bound loop for 30 seconds.
{         REPEAT,name,count,string

  PROCEDURE repeat_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_call_pdt

    VAR
      index: integer,
      task_status: pmt$task_status,
      taskid: pmt$task_id,
      param_string_p: ^ost$string,
      program_attributes_p: ^pmt$program_attributes,
      repeat_callee_p: ^pmt$program_description,
      repeat_callee_params_p: ^pmt$program_parameters;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH repeat_callee_p: [[REP 1 OF pmt$program_attributes]];
    RESET repeat_callee_p;
    NEXT program_attributes_p IN repeat_callee_p;
    program_attributes_p^.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$load_map_options_specified, pmc$term_error_level_specified];
    program_attributes_p^.starting_procedure := pvt [p$pn].value^.name_value;
    program_attributes_p^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    program_attributes_p^.termination_error_level := pmc$warning_load_errors;

    PUSH repeat_callee_params_p: [[REP 1 OF ost$string]];
    RESET repeat_callee_params_p;
    NEXT param_string_p IN repeat_callee_params_p;
    param_string_p^.value := pvt [p$param].value^.string_value^;
    param_string_p^.size := #SIZE (pvt [p$param].value^.string_value^);

    FOR index := 1 TO pvt [p$number].value^.integer_value.value DO
      pmp$execute (repeat_callee_p^, repeat_callee_params_p^, osc$wait, taskid, task_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND repeat_command;
?? OLDTITLE ??
?? NEWTITLE := 'return_command', EJECT ??

{ PURPOSE:
{   This test will execute the RETURN instruction. Prior to executing the RETURN instruction, the test damages
{   the stack so that a fault will occur on the RETURN. The value of <id> is used to specify the specific
{   fault to be generated.
{     1 - adrspec - A2 <> 0 mod 8
{     2 - adrspec - A2 (bit 32) = 1
{     3 - invseg - A2
{     4 - accvio - A2 not readable
{     5 - invseg - p
{     6 - adrspec - P <> 0 mod 2
{     7 - adrspec - P (bit 32 = 1
{     8 - accvio - P not exec
{     9 - envspec - final A0 <> A2
{     10 - envspec - VMID error
{     11 - inward return
{     12 - Return to 170 mode and see what fails
{         RETURN,id

  PROCEDURE return_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int1_pdt

    TYPE
      t$psa = RECORD
        p_register: ost$p_register,
        vmid: 0 .. 0ff(16),
        fil0: 0 .. 0ff(16),
        a0: ost$pva,
        fil1: 0 .. 0ffff(16),
        a1: ost$pva,
        fil2: 0 .. 0ffff(16),
        a2: ost$pva,
      RECEND,

      t$psa_or_pva = RECORD
        CASE boolean OF
        = TRUE =
          pva: ost$pva,
        = FALSE =
          psa_p: ^t$psa,
        CASEND,
      RECEND;

    VAR
      psa: t$psa_or_pva,
      pva_p: ost$pva;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    psa.psa_p := #PREVIOUS_SAVE_AREA ();

    CASE pvt [p$p1].value^.integer_value.value OF
    = 1 =
      psa.psa_p^.a2.offset := psa.psa_p^.a2.offset + 1; {adrspec - A2 <> 0 mod 8
    = 2 =
      psa.psa_p^.a2.offset := -7fff0000(16); {adrspec - A2 (bit 32) = 1
    = 3 =
      psa.psa_p^.a2.seg := psa.psa_p^.a2.seg + 1024; {invseg - A2
    = 4 =
      psa.psa_p^.a2.seg := 0; {accvio - A2 not readable
    = 5 =
      psa.psa_p^.p_register.pva.seg := 1000; {invseg - p
    = 6 =
      psa.psa_p^.p_register.pva.offset := 10000001; {adrspec - P <> 0 mod 2
    = 7 =
      psa.psa_p^.p_register.pva.offset := -7fff8000(16);
      {adrspec - P (bit 32 = 1
    = 8 =
      psa.psa_p^.p_register.pva.seg := psa.psa_p^.a0.seg; {accvio - P not exec
    = 9 =
      psa.psa_p^.a0.offset := psa.psa_p^.a0.offset + 8; {envspec - final A0 <> A2
    = 10 =
      psa.psa_p^.vmid := 2; {envspec - VMID error
    = 11 =
      pva_p := psa.psa_p^.a2;
      psa.pva := pva_p;
      psa.psa_p^.p_register.pva.ring := 3;
    = 12 =
      psa.psa_p^.vmid := 1; {Return to 170 mode and see what fails
    ELSE
    CASEND;

  PROCEND return_command;
?? OLDTITLE ??
?? NEWTITLE := 'sa_command', EJECT ??

{ PURPOSE:
{   This test will execute a SA instruction for the PVA specified by <pva>. Depending on the value of <pva>,
{   this test can be used to generate various failures such as invalid segment, ring zero, page fault, page
{   fault beyond EOI, etc.
{         SA,pva

  PROCEDURE sa_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int1_pdt

    TYPE
      t$sa_record = RECORD
        CASE boolean OF
        = TRUE =
          data_p: ^char,
        = FALSE =
          data_integer: 0 .. 0ffffffffffff(16),
        CASEND,
      RECEND;

    VAR
      character_data: char,
      sa_record: t$sa_record;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sa_record.data_integer := pvt [p$p1].value^.integer_value.value;
    sa_record.data_p^ := $CHAR (0);

  PROCEND sa_command;
?? OLDTITLE ??
?? NEWTITLE := 'shadow_command', EJECT ??

{ PURPOSE:
{   This test is used to test shadow files
{   . It creates <segments> and writes data into several pages of each segment.
{   . It creates a shadow for these segments.
{   . Periodically update the file (e.g. shadow).
{   . The test runs for total time of <totaltime> milliseconds.
{   . Terminate the shadow.
{         SHADOW,segments,totaltime,waittime,pagesize        (for scratch files)
{         SHADOWP,segments,totaltime,waittime,pagesize       (for permanent files)

  PROCEDURE shadow_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int4_pdt

    TYPE
      t$d_record = RECORD
        p: ^ARRAY [0 .. 0fffffff(16)] OF integer,
      RECEND,

      t$id_record = RECORD
        id: integer,
        time: integer,
        count: integer,
        offset: integer,
      RECEND;

    VAR
      blocksize: integer,
      cell_p: ^cell,
      d_p: ^ARRAY [1 .. 4096] OF t$d_record,
      error_mess: string (80),
      error_size: integer,
      etime: integer,
      i: integer,
      j: integer,
      local_status: ost$status,
      p: amt$segment_pointer,
      pagesize: integer,
      ran: integer,
      seed: integer,
      segments: integer,
      sp: amt$segment_pointer,
      time: integer,
      vfy_p: ^ARRAY [*] OF integer,
      wait_time: integer;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    time := #FREE_RUNNING_CLOCK (0);
    segments := pvt [p$p1].value^.integer_value.value;
    etime := time + 1000 * pvt [p$p2].value^.integer_value.value;
    wait_time := pvt [p$p3].value^.integer_value.value;
    pagesize := pvt [p$p4].value^.integer_value.value;
    IF pagesize = 1 THEN
      pagesize := 16384;
    IFEND;
    blocksize := pagesize * 10;

    PUSH d_p;

    FOR i := 1 TO segments DO
      get_segment (command_type, #LOC (d_p^ [i].p), status);
      IF NOT status.normal THEN
        display_status (status);
        i#program_error;
        RETURN;
      IFEND;
      FOR j := 0 TO (blocksize DIV 8) DO
        d_p^ [i].p^ [j] := 0ffffffff(16);
      FOREND;
      mmp$initiate_shadowing (#LOC (d_p^ [i].p^), status);
      IF NOT status.normal THEN
        stringrep (error_mess, error_size, ' mmp$initiate_shadowing ', #LOC (d_p^ [i].p^));
        clp$put_job_command_response (error_mess (1, error_size), local_status);
        display_status (status);
        i#program_error;
        RETURN;
      IFEND;
    FOREND;

    WHILE #FREE_RUNNING_CLOCK (0) < etime DO
      FOR i := 1 TO segments DO
        FOR j := 0 TO (blocksize DIV pagesize) DO
          d_p^ [i].p^ [j * pagesize DIV 8] := d_p^ [i].p^ [j * pagesize DIV 8] + 1;
        FOREND;
      FOREND;
      pmp$wait (wait_time, wait_time);
    WHILEND;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, sp, status);
    IF NOT status.normal THEN
      display_status (status);
      i#program_error;
      RETURN;
    IFEND;

    { Make a copy of the active before terminate shadow.

    FOR i := 1 TO segments DO
      RESET sp.sequence_pointer;
      NEXT vfy_p: [0 .. blocksize DIV 8] IN sp.sequence_pointer;
      FOR j := 0 TO (blocksize DIV 8) DO
        vfy_p^ [j] := d_p^ [i].p^ [j];
      FOREND;
      mmp$terminate_shadowing (#LOC (d_p^ [i].p^), TRUE, status);
      IF NOT status.normal THEN
        stringrep (error_mess, error_size, ' mmp$terminate_shadowing ', #LOC (d_p^ [i].p^));
        clp$put_job_command_response (error_mess (1, error_size), local_status);
        display_status (status);
        i#program_error;
        RETURN;
      IFEND;
      FOR j := 0 TO (blocksize DIV 8) DO
        IF d_p^ [i].p^ [j] <> vfy_p^ [j] THEN
          clp$put_job_command_response (' Shadow test failure ', status);
          cell_p := ^d_p^ [i].p^ [j];
          stringrep (error_mess, error_size, ' Pva ', cell_p);
          clp$put_job_command_response (error_mess (1, error_size), status);
          i#program_error;
        IFEND;
      FOREND;
    FOREND;

  PROCEND shadow_command;
?? OLDTITLE ??
?? NEWTITLE := 'sparse_command', EJECT ??

{ PURPOSE:
{   This test is used to put a heavy load on the system by doing the following:
{   . It creates <segments> and writes data into several pages of each segment.
{   . It randomly reads, writes, and checks data in pages of the segments and will abort if any data is bad.
{   . Periodically the test will wait for <waittime> milliseconds. If this time is large enough the job will
{     be swapped out.
{   . The test runs for total time of <totaltime> milliseconds.
{         SPARSE,segments,totaltime,waittime,pagesize        (for scratch files)
{         SPARSEP,segments,totaltime,waittime,pagesize       (for permanent files)

  PROCEDURE sparse_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int4_pdt

    TYPE
      t$d_record = RECORD
        p: ^t$id_record,
        id_rec: t$id_record,
      RECEND,

      t$id_record = RECORD
        id: integer,
        time: integer,
        count: integer,
        offset: integer,
      RECEND;

    VAR
      blocksize: integer,
      d_p: ^ARRAY [1 .. 4096] OF t$d_record,
      error_mess: string (80),
      error_size: integer,
      etime: integer,
      i: integer,
      j: integer,
      p: amt$segment_pointer,
      pagesize: integer,
      ran: integer,
      seed: integer,
      segments: integer,
      time: integer,
      wait_time: integer;

?? NEWTITLE := 'random', EJECT ??

    PROCEDURE random
      (    max: integer;
       VAR i: integer);

      seed := (seed * 1953125) MOD 100000000(16);
      i := 1 + (seed * max) DIV 100000000(16);

    PROCEND random;
?? OLDTITLE ??
?? NEWTITLE := 'store_id_record', EJECT ??

    PROCEDURE store_id_record
      (    i: integer);

      VAR
        id_rec: t$id_record,
        p: ^t$id_record;

      id_rec := d_p^ [i].id_rec;
      p := d_p^ [i].p;
      WHILE #OFFSET (p) < blocksize DO
        id_rec.offset := #OFFSET (p);
        p^ := id_rec;
        p := #ADDRESS (1, #SEGMENT (p), #OFFSET (p) + pagesize);
      WHILEND;

    PROCEND store_id_record;
?? OLDTITLE ??
?? NEWTITLE := 'check_block', EJECT ??

    PROCEDURE check_block
      (    i: integer);

      VAR
        id_rec: t$id_record,
        p: ^t$id_record;

      p := d_p^ [i].p;
      id_rec := d_p^ [i].id_rec;
      WHILE #OFFSET (p) < blocksize DO
        id_rec.offset := #OFFSET (p);
        IF id_rec <> p^ THEN
          clp$put_job_command_response (' sparse check block failure ', status);
          stringrep (error_mess, error_size, ' i ', i, ' Pva ', p);
          clp$put_job_command_response (error_mess (1, error_size), status);
          stringrep (error_mess, error_size, ' Expected id, time, count, offset ', id_rec.id, id_rec.time,
                id_rec.count, id_rec.offset);
          clp$put_job_command_response (error_mess (1, error_size), status);
          stringrep (error_mess, error_size, ' Actual id, time, count, offset ', p^.id, p^.time, p^.count,
                p^.offset);
          clp$put_job_command_response (error_mess (1, error_size), status);
          i#program_error;
        IFEND;
        p := #ADDRESS (1, #SEGMENT (p), #OFFSET (p) + pagesize);
      WHILEND;

    PROCEND check_block;
?? OLDTITLE ??
?? NEWTITLE := 'update_block', EJECT ??

    PROCEDURE update_block
      (    i: integer);

      check_block (i);
      d_p^ [i].id_rec.count := d_p^ [i].id_rec.count + 1;
      d_p^ [i].id_rec.time := #FREE_RUNNING_CLOCK (0);
      store_id_record (i);

    PROCEND update_block;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    time := #FREE_RUNNING_CLOCK (0);
    segments := pvt [p$p1].value^.integer_value.value;
    etime := time + 1000 * pvt [p$p2].value^.integer_value.value;
    wait_time := pvt [p$p3].value^.integer_value.value;
    pagesize := pvt [p$p4].value^.integer_value.value;
    IF pagesize = 1 THEN
      pagesize := 16384;
    IFEND;
    blocksize := pagesize * 10;

    seed := 61429387;
    PUSH d_p;

    FOR i := 1 TO segments DO
      get_segment (command_type, #LOC (d_p^ [i].p), status);
      IF NOT status.normal THEN
        display_status (status);
        i#program_error;
        RETURN;
      IFEND;
      d_p^ [i].id_rec.id := #FREE_RUNNING_CLOCK (0);
      d_p^ [i].id_rec.time := 0;
      d_p^ [i].id_rec.count := 0;
      store_id_record (i);
    FOREND;

    WHILE #FREE_RUNNING_CLOCK (0) < etime DO
      FOR i := 1 TO 50 DO
        random (100, ran);
        random (segments, j);
        update_block (j);
      FOREND;
      pmp$wait (wait_time, wait_time);
    WHILEND;

  PROCEND sparse_command;
?? OLDTITLE ??
?? NEWTITLE := 'sync_command', EJECT ??

{ PURPOSE:
{   This test initiates execution of the Cyber 180 instruction SYNC (see reference 194 of the MIGDS).  It
{   executes the SYNC instruction <passes> number of times.  If <traps> is > 0, each pass to call the SYNC
{   instruction will be executed with traps enabled.  If <traps> is = 0, each pass thru the loop runs the
{   test with traps disabled.
{         SYNC,passes,traps

  PROCEDURE sync_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int2_pdt

    VAR
      index: integer,
      old_te: 0..3;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$p1].value^.integer_value.value < 1 THEN
      RETURN;
    IFEND;

    IF pvt [p$p2].value^.integer_value.value = 0 THEN
      i#disable_traps (old_te);
    IFEND;

    FOR index := 1 TO pvt [p$p1].value^.integer_value.value DO
      i#sync;
    FOREND;

    IF pvt [p$p2].value^.integer_value.value = 0 THEN
      i#restore_traps (old_te);
    IFEND;

  PROCEND sync_command;
?? OLDTITLE ??
?? NEWTITLE := 'testmem_command', EJECT ??

{ PURPOSE:
{   This test will push an array <bc> bytes long onto the stack and write a unique data pattern into each
{   element of the array (each element is 17 bytes long). After writing each element, the test then reads
{   each element back to verify the data. If <bc> is large, this test will cause lots of paging activity.
{   This test is structure so that it uses LBYTS and SBYTS instructions to access the array.
{         TESTMEM,bc

  PROCEDURE testmem_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int1_pdt

    TYPE
      t$testmem_record = RECORD
        id: integer,
        n: integer,
        fill: char, {make rec len prime to force more end points.
      RECEND;

    VAR
      array_p: ^ARRAY [1 .. * ] OF t$testmem_record,
      index: integer,
      rec_count: integer,
      time: integer;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    time := #FREE_RUNNING_CLOCK (0);
    rec_count := pvt [p$p1].value^.integer_value.value DIV 17 + 1;

    PUSH array_p: [1 .. rec_count];
    FOR index := 1 TO rec_count DO
      array_p^ [index].id := time;
      array_p^ [index].n := index;
    FOREND;

    FOR index := rec_count DOWNTO 1 DO
      IF array_p^ [index].n <> index THEN
        clp$put_job_command_response (err_testmem_rc, status);
        i#program_error;
      IFEND;
      IF array_p^ [index].id <> time THEN
        clp$put_job_command_response (err_testmem_id, status);
        i#program_error;
      IFEND;
    FOREND;

  PROCEND testmem_command;
?? OLDTITLE ??
?? NEWTITLE := 'testmove_command', EJECT ??

{ PURPOSE:
{   This test will push an array <bc> bytes long onto the stack and write a unique data pattern into each
{   element of the array (each element is 255 bytes long). After writing each element, the test then reads
{   each element back to verify the data. If <bc> is large, this test will cause lots of paging activity.
{   This test is structure so that it uses MOVB and CMPB instructions to access the array.
{         TESTMOVE,bc

  PROCEDURE testmove_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int1_pdt

    TYPE
      t$arrayer = ^ARRAY [1 .. * ] OF RECORD
        id: integer,
        n: integer,
        fill: string (239),
      RECEND;

    VAR
      characs: [READ, cls$pdt] ARRAY [1 .. 1] OF string (239) :=
            ['ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ' CAT
             '0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnop' CAT
             'qrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopq'],
      i: integer,
      p: t$arrayer,
      p1: t$arrayer,
      rec_count: integer,
      time: integer;

?? NEWTITLE := 'print_rec', EJECT ??

    PROCEDURE print_rec
      (    i: integer;
           ptr: t$arrayer);

      VAR
        j: integer,
        k: integer,
        strng: string (63);

      strng (1, 50) := ' Record no.          , record no. field =         ';
      pmp$binary_to_ascii_fit (i, 10, 20, 9, strng);
      pmp$binary_to_ascii_fit (ptr^ [i].n, 10, 50, 8, strng);
      clp$put_job_command_response (strng, status);
      strng (1, 40) := ' time record created =                  ';
      pmp$binary_to_ascii_fit (ptr^ [i].id, 10, 40, 17, strng);
      clp$put_job_command_response (strng, status);

      j := 1;
      WHILE j < STRLENGTH (ptr^ [i].fill) DO
        strng (1) := ' ';
        k := STRLENGTH (ptr^ [i].fill) - j;
        IF k > 62 THEN
          k := 62;
        IFEND;
        strng (2, k) := ptr^ [i].fill (j, k);
        j := j + 62;
        clp$put_job_command_response (strng, status);
      WHILEND;

    PROCEND print_rec;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    time := #FREE_RUNNING_CLOCK (0);
    rec_count := pvt [p$p1].value^.integer_value.value DIV 255 * 2 + 1;

    PUSH p: [1 .. rec_count];
    PUSH p1: [1 .. rec_count];
    FOR i := 1 TO rec_count DO
      p^ [i].id := time;
      p^ [i].n := i;
      p^ [i].fill := characs [1];
      p1^ [rec_count - i + 1].fill := p^ [i].fill;
      p1^ [rec_count - i + 1].id := p^ [i].id;
      p1^ [rec_count - i + 1].n := p^ [i].n;
    FOREND;

    FOR i := rec_count DOWNTO 1 DO
      IF p^ [i].n <> i THEN
        print_rec (i, p);
        clp$put_job_command_response (err_testmove_rc, status);
        i#program_error;
      IFEND;
      IF p^ [i].id <> time THEN
        print_rec (i, p);
        clp$put_job_command_response (err_testmove_id, status);
        i#program_error;
      IFEND;
      IF ((p^ [i].fill <> characs [1]) OR (p1^ [rec_count - i + 1].fill <> characs [1])) THEN
        print_rec (i, p);
        print_rec (rec_count - i + 1, p1);
        clp$put_job_command_response (err_testmove_chars, status);
        i#program_error;
      IFEND;
    FOREND;

    FOR i := 1 TO rec_count DO
      IF p^ [i] <> p1^ [rec_count - i + 1] THEN
        clp$put_job_command_response (err_testmove_chars, status);
        i#program_error;
      IFEND;
    FOREND;

  PROCEND testmove_command;
?? OLDTITLE ??
?? NEWTITLE := 'timeout_command', EJECT ??

{ PURPOSE:
{   This test will execute pmp$delay requests of <t1> milliseconds for a total wallclock time equal to <t2>
{   milliseconds.
{         TIMEOUT,t1,t2

  PROCEDURE timeout_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int2_pdt

    VAR
      etime: integer,
      time: integer;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    time := #FREE_RUNNING_CLOCK (0);
    etime := time + 1000 * pvt [p$p2].value^.integer_value.value;
    WHILE time < etime DO
      pmp$delay (pvt [p$p1].value^.integer_value.value, status);
      time := #FREE_RUNNING_CLOCK (0);
    WHILEND;

  PROCEND timeout_command;
?? OLDTITLE ??
?? NEWTITLE := 'workset_command', EJECT ??

{ PURPOSE:
{   This test will cause the task to create a working set equal to <pages> pages. After the working set is
{   created, the task will loop referencing each page to keep it in the working set.  A unique ID is stored
{   in each page. The task continually verifies the ID. If swapping (or other memory manager bugs) exist that
{   cause the ID to be invalid, the test will abort.  At the end of each pass thru the loop, the test issues
{   a pmp$wait request for <waittime> milliseconds. If this time exceeds the long_wait swap time, the job will
{   be swapped out.  This makes this test valuable for checking swapping.  If <readpage> is not equal to 1,
{   each page is updated on each pass thru the loop. This causes more paging IO under certain conditions.
{         WORKSET,pages,totaltime,waittime,readpage

  PROCEDURE workset_command
    (    parameter_list: clt$parameter_list;
         command_type: char;
     VAR status: ost$status);

*copy osv$misc_test_commands_int4_pdt

    TYPE
      t$a_record = RECORD
        id: integer,
        num: integer,
        pass: integer,
        fill: integer,
      RECEND;

    VAR
      a_p: ^ARRAY [0 .. 65000000] OF t$a_record,
      ch: char,
      current_working_set: integer,
      error_mess: string (80),
      error_size: integer,
      etime: integer,
      i: integer,
      id: integer,
      p: ^cell,
      p_debug: ^cell,
      page_fac: integer,
      pass: integer,
      read_page: boolean,
      time: integer,
      wait_time: integer,
      working_set: integer;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    time := #FREE_RUNNING_CLOCK (0);
    working_set := pvt [p$p1].value^.integer_value.value;
    etime := time + 1000 * pvt [p$p2].value^.integer_value.value;
    wait_time := pvt [p$p3].value^.integer_value.value;
    read_page := (pvt [p$p4].value^.integer_value.value = 1);

    page_fac := (512 * (128 - #READ_REGISTER (4a(16)))) DIV 32;
    get_segment (command_type, #LOC (a_p), status);
    IF NOT status.normal THEN
      display_status (status);
      i#program_error;
      RETURN;
    IFEND;

    current_working_set := 0;
    id := #FREE_RUNNING_CLOCK (0);
    WHILE time < etime DO
      pass := pass + 1;
      IF current_working_set < working_set THEN
        a_p^ [current_working_set * page_fac].id := id;
        a_p^ [current_working_set * page_fac].num := current_working_set;
        a_p^ [current_working_set * page_fac].pass := pass;
        current_working_set := current_working_set + 1;
      ELSE
        pmp$wait (wait_time, wait_time);
      IFEND;
      FOR i := 0 TO current_working_set - 1 DO
        IF (a_p^ [i * page_fac].id <> id) OR (a_p^ [i * page_fac].num <> i) OR
              (NOT read_page AND (a_p^ [i * page_fac].pass <> pass)) THEN
          clp$put_job_command_response (' Workset failure - actual/expected', status);
          STRINGREP (error_mess, error_size, ' Workset ', ' id ', a_p^ [i * page_fac].id, id,
                ' num ', a_p^ [i * page_fac].num, i, ' pass ', a_p^ [i * page_fac].pass, pass);
          clp$put_job_command_response (error_mess (1, error_size), status);
          p_debug := ^a_p^ [i * page_fac].id;
          STRINGREP (error_mess, error_size, ' Pva id rec', p_debug, ' cws ', current_working_set,
                ' Read', read_page);
          clp$put_job_command_response (error_mess (1, error_size), status);
          i#program_error;
        IFEND;
        IF NOT read_page THEN
          a_p^ [i * page_fac].pass := pass + 1;
        IFEND;
      FOREND;
      p := ^a_p^ [0];
      #PURGE_BUFFER (4, p);
      time := #FREE_RUNNING_CLOCK (0);
    WHILEND;

  PROCEND workset_command;
?? OLDTITLE ??
?? NEWTITLE := 'uutl', EJECT ??

  PROCEDURE [XDCL, #GATE] uutl
    (    program_parameters: pmt$program_parameters;
     VAR status: ost$status);

    CONST
      c$max_commands = 39;

    TYPE
      t$command_procedure = procedure
                              (    parameter_list: clt$parameter_list;
                                   command_type: char;
                               VAR status: ost$status),

      t$command_table = RECORD
        command_name: string (8),
        command_type: char,
        command_procedure_p: ^t$command_procedure,
      RECEND;

    VAR
      command: ost$name,
      command_index: 1 .. c$max_commands + 1,
      parameter_block_p: ^pmt$program_parameters,
      string_length_p: ^clt$command_line_size,
      string_p: ^string ( * ),
      temp_string: string (255),
      token: clt$token,
      token_index: ost$string_index,

      v$command_table: [STATIC, cls$pdt, READ] ARRAY [1 .. c$max_commands] OF t$command_table := [
            ['ADRSPEC ', ' ', ^adrspec_command],
            ['AGESET  ', 'T', ^ageset_command],
            ['AGESETP ', 'P', ^ageset_command],
            ['AROVFL  ', ' ', ^arovfl_command],
            ['BIGSEG  ', 'T', ^bigseg_command],
            ['BIGSEGP ', 'P', ^bigseg_command],
            ['BULK    ', '1', ^bulk_command],
            ['BULKNTC ', '2', ^bulk_command],
            ['CALLER  ', ' ', ^caller_command],
            ['CP_WAIT ', ' ', ^cp_wait_command],
            ['CYCLE   ', ' ', ^cycle_command],
            ['DIVFLT  ', ' ', ^divflt_command],
            ['ENVSPEC ', ' ', ^envspec_command],
            ['INSSPEC ', ' ', ^insspec_command],
            ['IOTEST  ', 'T', ^iotest_command],
            ['IOTESTP ', 'P', ^iotest_command],
            ['KRUNCH  ', 'T', ^krunch_command],
            ['KRUNCHA ', 'A', ^krunch_command],
            ['KRUNCHN ', 'N', ^krunch_command],
            ['KRUNCHP ', 'P', ^krunch_command],
            ['KRUNCHS ', 'S', ^krunch_command],
            ['KRUNCHX ', 'X', ^krunch_command],
            ['LA      ', ' ', ^la_command],
            ['LOOP    ', ' ', ^loop_command],
            ['PRIVINS ', ' ', ^privins_command],
            ['RECURSE ', ' ', ^recurse_command],
            ['REPEAT  ', ' ', ^repeat_command],
            ['RETURN  ', ' ', ^return_command],
            ['SA      ', ' ', ^sa_command],
            ['TESTMEM ', ' ', ^testmem_command],
            ['TIMEOUT ', ' ', ^timeout_command],
            ['TESTMOVE', ' ', ^testmove_command],
            ['WORKSET ', 'T', ^workset_command],
            ['WORKSETP', 'P', ^workset_command],
            ['SHADOW  ', 'T', ^shadow_command],
            ['SHADOWP ', 'P', ^shadow_command],
            ['SPARSE  ', 'T', ^sparse_command],
            ['SPARSEP ', 'P', ^sparse_command],
            ['SYNC    ', ' ', ^sync_command]];

    status.normal := TRUE;

    string_p := NIL;
    parameter_block_p := ^program_parameters;
    RESET parameter_block_p;
    NEXT string_length_p IN parameter_block_p;
    IF (string_length_p <> NIL) AND (string_length_p^ <= clc$max_command_line_size) THEN
      NEXT string_p: [string_length_p^] IN parameter_block_p;
    IFEND;
    IF string_p = NIL THEN
      clp$put_job_command_response (err_utl_noparams, status);
      osp$set_status_abnormal ('UT', 987654, err_utl_noparams, status);
      pmp$exit (status);
    IFEND;

    token_index := 1;
    clp$scan_token (string_p^ (1, string_length_p^), token_index, token, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    command := token.name.value;

    clp$scan_token (string_p^ (1, string_length_p^), token_index, token, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (token.kind = clc$space_token) OR (token.kind = clc$comma_token) THEN
      temp_string := string_p^ (token_index, *);
      string_p^ (1, string_length_p^) := temp_string;
    ELSEIF token.kind = clc$eol_token THEN
      string_p^ (1, string_length_p^) := ' ';
    ELSE
      clp$put_job_command_response (err_utl_invalidcommand, status);
      osp$set_status_abnormal ('UT', 987654, err_utl_invalidcommand, status);
      pmp$exit (status);
    IFEND;

    FOR command_index := 1 TO c$max_commands DO
      IF command (1, 8) = v$command_table [command_index].command_name THEN
        v$command_table [command_index].command_procedure_p^ (parameter_block_p^,
              v$command_table [command_index].command_type, status);
        RETURN;
      IFEND;
    FOREND;

    clp$put_job_command_response (err_utl_invalidcommand, status);
    osp$set_status_abnormal ('UT', 987654, err_utl_invalidcommand, status);
    pmp$exit (status);

  PROCEND uutl;
MODEND osm$misc_test_commands;
*DECK DECK=OSM$MONITOR_BOOT EXPAND=TRUE
MODULE osm$monitor_boot;
?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc gft$locked_file_desc_entry_p
*copyc jmt$active_job_list
*copyc jmt$ijl_ordinal
*copyc jmt$ijl_p
*copyc ost$page_size
*copyc mmt$make_pt_entry_status
*copyc ost$segment_access_control
*copyc ost$cpu_state_table
*copyc pmt$initialization_value
*copyc mmt$page_frame_index
*copyc mmt$active_segment_table
*copyc mmt$segment_descriptor_table
*copyc mmt$segment_descriptor_table_ex
*copyc ost$heap
*copyc mtp$error_stop
*copyc osv$180_memory_limits
*copyc ost$rb_system_error
*copyc osc$purge_map_and_cache
*copyc syt$debug_control
*copyc tmt$ptl_lock
*copyc mmt$buffer_descriptor
*copyc iot$io_function
*copyc i#real_memory_address
*copyc iot$logical_unit
*copyc iot$tape_collected_pp_response
*copyc rmt$recorded_vsn
*copyc iot$io_error
*copyc mmt$rma_list
*copyc syt$monitor_status
*copyc mtp$error_stop
*copyc mmt$io_identifier
*copyc ost$execution_control_block
*copyc dft$queue_interface_directory
*copyc mmt$page_frame_table
*copyc mtp$cst_p
*copyc tmt$rb_delay
*copyc tmt$rb_cycle
*copyc tmt$primary_task_list
*copyc tmt$system_task_id
*copyc mmp$preset_real_memory
*copyc mtv$monitor_segment_table
*copyc ost$cpu_state_table
*copyc ost$boot_update_page_table
*copyc ost$cpu_definitions
?? POP ??

*copyc mmp$get_sdt_entry_p
*copyc mmp$get_sdtx_entry_p


  VAR
    dfv$file_server_info_enabled: [XDCL] boolean := FALSE,
    dfv$monitor_io_start_time: [XDCL] integer,
    dfv$p_queue_interface_directory: [XDCL] dft$p_queue_interface_directory
         := NIL,
    dmv$external_interrupt_selector: [XDCL, #GATE] 0 .. 0ff(16) := 1,
    jmv$ajl_p: [XDCL, #GATE] ^jmt$active_job_list := NIL,
    jmv$null_ijl_ordinal: [XDCL, #GATE] jmt$ijl_ordinal := [0, 0],
    mmv$pt_length: [XDCL, #GATE] integer,
    mmv$pt_p: [XDCL, #GATE] ^ost$page_table,
    mmv$tables_initialized: [XDCL, #GATE] boolean := FALSE,
    syv$debug_control: [XDCL, #GATE] syt$debug_control,
    null_pva: 0 .. 0ffffffffffff(16),
    tmv$system_job_monitor_gtid: [XDCL] ost$global_task_id,
    mmv$next_free_page: [XDCL] integer := 0,
    mmv$free_pages: [XDCL] ^array [ * ] of 0 .. osc$max_page_frames := NIL,
    mmv$multiple_caches: [XDCL] boolean := FALSE,
    mmv$multiple_page_maps: [XDCL] boolean := FALSE,
    mtv$operator_console_hung: [XDCL] boolean := FALSE,
    osv$multiprocessor_running: [XDCL] boolean := FALSE,
    osv$page_size: [XDCL, #GATE] ost$page_size;

{ The following variables are stubs.

  VAR
    jmv$ijl_p: [XDCL] jmt$ijl_p := [NIL, 0, 0],
    mmv$pages_to_dump_p: [XDCL] ^packed array [0 .. *] of boolean,
    osv$cpus_logically_on: [XDCL] 0 .. osc$max_number_of_processors;

?? EJECT ??

  PROCEDURE [INLINE] clear_continue_bits (xpti: ost$page_table_index);


    VAR
      pfti: mmt$page_frame_index,
      ipti: integer;


{Clear 'continue' bits as required.  No bits can be cleared if the 'continue'
{bit in the entry just cleared
{is set or if the actual index to the entry is the same as the hash index.
{Otherwise, scan backward from
{the current entry and clear all
{'continue' bits until either an entry with a zero 'contiue
{Bit' is reached or until another 'moved' entry is found.

    ipti := xpti;
    WHILE TRUE DO
      ipti := ipti - 1;
      IF ipti < 0 THEN
        ipti := mmv$pt_length - 1;
      IFEND;
      IF NOT mmv$pt_p^ [ipti].c THEN
        RETURN
      IFEND;
      mmv$pt_p^ [ipti].c := FALSE;
      IF mmv$pt_p^ [ipti].pageid.asid <> 0 THEN
        pfti := mmv$pt_p^ [ipti].rma * 512 DIV osv$page_size;
{!!  HELP. What do the following really mean?
{!!     IF NOT mmv$initial_hash_table_p^ [ipti] THEN
{!!       RETURN;
{!!     IFEND;
      IFEND;
    WHILEND;

  PROCEND clear_continue_bits;
?? EJECT ??

  PROCEDURE pf_proc_tables_not_initialized (xcb_p:
    ^ost$execution_control_block);

    VAR
      sva: ost$system_virtual_address,
      ste_p: ^mmt$segment_descriptor,
      mpt_status: mmt$make_pt_entry_status,
      pfte: mmt$page_frame_table_entry,
      aste: mmt$active_segment_table_entry,
      last_rma: [STATIC] integer := 0ffffffffffff(16),
      pte_rma: integer,
      full_scan_has_been_done: boolean,
      pt_length: integer,
      pt_p: ^ost$page_table,
      pti: 0 .. osc$max_page_table_entries;

    pt_p := mmv$pt_p;
    pt_length := mmv$pt_length;
    aste.pages_in_memory := 0;
    ste_p := mmp$get_sdt_entry_p (xcb_p, xcb_p^.xp.untranslatable_pointer.seg);
    sva.asid := ste_p^.ste.asid;
    sva.offset := xcb_p^.xp.untranslatable_pointer.offset;
    sva.offset := (sva.offset DIV osv$page_size) * osv$page_size;

    IF mmv$free_pages = NIL THEN
      full_scan_has_been_done := FALSE;
      REPEAT
        IF last_rma >= osv$180_memory_limits.deadstart_upper THEN
          IF full_scan_has_been_done THEN
            mtp$error_stop ('MM - not enough mem to deadstart');
          IFEND;
          last_rma := osv$180_memory_limits.lower;
          full_scan_has_been_done := TRUE;
          pti := pt_length;
          REPEAT
            pti := pti - 1;
            IF (pt_p^ [pti].pageid.asid <> 0) AND (pt_p^ [pti].rma * 512 >
                  last_rma) AND (pt_p^ [pti].rma * 512 < osv$180_memory_limits.deadstart_upper) THEN
              last_rma := pt_p^ [pti].rma * 512;
            IFEND;
          UNTIL pti = 0;
        IFEND;
        last_rma := last_rma + osv$page_size;
        pti := 0;
        pte_rma := last_rma DIV 512;
        WHILE (pti < pt_length) AND ((pte_rma <> pt_p^ [pti].rma) OR (pt_p^
              [pti].pageid.asid = 0)) DO
          pti := pti + 1;
        WHILEND;
      UNTIL pti = pt_length;
    ELSE
      IF mmv$next_free_page = 0 THEN
        mtp$error_stop ('No free pages');
      IFEND;
      last_rma := mmv$next_free_page * osv$page_size;
      mmv$next_free_page := mmv$free_pages^ [mmv$next_free_page];
    IFEND;

    aste.in_use := TRUE;
    mmp$make_pt_entry (sva, last_rma DIV osv$page_size, ^aste, ^pfte,
          mpt_status);
    IF mpt_status <> mmc$mpt_done THEN
      mtp$error_stop ('MM - make PT entry reject');
    IFEND;
    mmp$preset_real_memory (sva, pmc$initialize_to_zero);
    mmv$pt_p^ [pfte.pti].v := TRUE;

  PROCEND pf_proc_tables_not_initialized;

  ?? EJECT ??

  VAR
    mmv$page_table_miss_count: [XDCL] array [1 .. 34] of integer;



  PROCEDURE [XDCL] mmp$make_pt_entry (sva: ost$system_virtual_address;
        pfti: mmt$page_frame_index;
        aste_p: ^mmt$active_segment_table_entry;
        pfte_p: ^mmt$page_frame_table_entry;
    VAR mpt_status: mmt$make_pt_entry_status);

    VAR
      default_pte: [STATIC, READ] ost$page_table_entry := [FALSE, FALSE, TRUE,
        FALSE, [0, 0], 0],
      pte: ost$page_table_entry,
      pt_p: ^ost$page_table,
      c32: boolean,
      ipti: integer,
      count: 1 .. 32,
      found: boolean;



{Calculate the hash index for the page table entry and determine if the page
{already exists. Return an error
{code if an entry already exists.

    #hash_sva (sva, ipti, count, found);
    IF found THEN
      mpt_status := mmc$mpt_page_already_exists;
      RETURN;
    IFEND;
    ipti := ipti - count + 1;
    IF ipti < 0 THEN
      ipti := ipti + mmv$pt_length;
    IFEND;

{Set up page table entry word, and SVA of page.

    pte := default_pte;
    pte.pageid.asid := sva.asid;
    pte.pageid.pagenum := sva.offset DIV 512;
    pte.rma := pfti * osv$page_size DIV 512;



{Find an available slot for the new page table entry. Set 'continue' bits as
{required.  Return error if no
{space is found within 32 entries.

    count := 1;
    pt_p := mmv$pt_p;
    WHILE pt_p^ [ipti].pageid.asid <> 0 DO
      IF count >= 31 THEN
        IF count = 31 THEN
          c32 := pt_p^ [ipti].c;
        ELSE
          mpt_status := mmc$mpt_page_table_full;
          mmv$page_table_miss_count [33] := mmv$page_table_miss_count [33] + 1;
          IF NOT c32 THEN
            clear_continue_bits (ipti);
          IFEND;
          RETURN;
        IFEND;
      IFEND;
      count := count + 1;
      pt_p^ [ipti].c := TRUE;
      ipti := ipti + 1;
      IF ipti = mmv$pt_length THEN
        ipti := 0;
      IFEND;
    WHILEND;
    mmv$page_table_miss_count [count] := mmv$page_table_miss_count [count] + 1;


{Make the new page table entry, preserving the 'continue' bit in the old page
{table entry.

    pte.c := pt_p^ [ipti].c;
    pt_p^ [ipti] := pte;
    pfte_p^.pti := ipti;
    IF NOT aste_p^.in_use THEN
      mtp$error_stop ('MM--MAKE_PT_ENTRY--AST NOT IN USE');
    IFEND;
    aste_p^.pages_in_memory := aste_p^.pages_in_memory + 1;
    mpt_status := mmc$mpt_done;

  PROCEND mmp$make_pt_entry;
  ?? EJECT ??

  PROCEDURE [XDCL] pr_pf (dummy: ^cell;
        cst_p: ^ost$cpu_state_table);

    pf_proc_tables_not_initialized (cst_p^.xcb_p);

  PROCEND pr_pf;
?? EJECT ??

  PROCEDURE [XDCL] mmp$unlock_rma_list (iotype: iot$io_function;
        list_p: ^mmt$rma_list;
        list_length: mmt$rma_list_length;
        io_identifier: mmt$io_identifier;
        mf_job_file: boolean;
    VAR normal: iot$io_error;
    VAR status: syt$monitor_status);

    status.normal := TRUE;

  PROCEND mmp$unlock_rma_list;
?? EJECT ??

  PROCEDURE [XDCL] mmp$build_lock_rma_list (buffer_descriptor:
    mmt$buffer_descriptor;
        length: ost$byte_count;
        iotype: iot$io_function;
        list_p: ^mmt$rma_list;
        list_length: mmt$rma_list_length;
    VAR status: syt$monitor_status);

    VAR
      list_i: mmt$rma_list_index,
      hash_count: 1 .. 32,
      found: boolean,
      page_count: integer,
      io_error: iot$io_error,
      ioid: mmt$io_identifier,
      page_offset: 0 .. 65535,
      sva: ost$system_virtual_address,
      pti: integer;


    status.normal := TRUE;
    list_i := 1;


{  Lock the pages depending on format of the buffer descriptor.

    CASE buffer_descriptor.buffer_descriptor_type OF

    = mmc$bd_paging_io, mmc$bd_explicit_io =
      sva := buffer_descriptor.sva;
      page_offset := sva.offset MOD osv$page_size;
      page_count := ((page_offset + length - 1) DIV osv$page_size) + 1;
      IF list_length < page_count THEN
        mtp$error_stop ('MM - rma list too small');
      IFEND;

    /lp/
      WHILE TRUE DO
        #hash_sva (sva, pti, hash_count, found);
        IF NOT found THEN
          EXIT /lp/
        IFEND;

        list_p^ [list_i].rma := (mmv$pt_p^ [pti].rma * 512) + page_offset;
        page_count := page_count - 1;
        IF page_count <= 0 THEN
          list_p^ [list_i].length := ((buffer_descriptor.sva.offset + length -
                1) MOD osv$page_size) - page_offset + 1;
          IF list_i < list_length THEN
            list_p^ [list_i + 1].length := 0;
          IFEND;
          RETURN
        IFEND;
        list_p^ [list_i].length := osv$page_size - page_offset;
        sva.offset := sva.offset + osv$page_size;
        page_offset := 0;
        list_i := list_i + 1;
      WHILEND /lp/;


{Control gets here only if a page frame is not assigned to a page that is being
{locked.  Unlock the pages (if
{any) that have already been locked.

      IF list_i > 1 THEN
        ioid.specified := false;
        io_error := ioc$no_error;
        mmp$unlock_rma_list (ioc$no_io, list_p, list_i - 1, ioid,
              {mf_job_file} FALSE, io_error, status);
      IFEND;
      mtp$error_stop ('Page frame not assigned - lock rma list');

    ELSE
      mtp$error_stop ('Bad buffer descr in lock rma list');
    CASEND;

  PROCEND mmp$build_lock_rma_list;

?? EJECT ??

  PROCEDURE [XDCL] mmp$build_lock_rma_list_tape (
         tape_request_p: ^iot$wired_tape_request;   {input/output
     VAR status: syt$monitor_status);

    VAR
      command_index: iot$tape_command_index,
      found: boolean,
      hash_count: 1 .. 32,
      length: ost$byte_count,
      list_i: mmt$rma_list_index,
      list_p: ^mmt$rma_list,
      loop_count_index: 1 .. 2,
      page_count: integer,
      page_offset: 0 .. 65535,
      pti: integer,
      pva: ^cell,
      rma: integer,
      sva: ost$system_virtual_address,
      total_list_entries: mmt$rma_list_index;

    status.normal := TRUE;
    total_list_entries := 1;
    list_p := #LOC (tape_request_p^.wired_command_heap_p^.rma_list [1]);

    IF NOT (tape_request_p^.io_type = ioc$explicit_read) THEN
      mtp$error_stop ('MM - boot lock tape rma list, write not supported');
    IFEND;

    FOR loop_count_index := 1 TO 2 DO

    /lock_loop/
      FOR command_index := 1 TO tape_request_p^.no_of_data_commands DO
        list_i := 1;
        IF loop_count_index = 1 THEN {data buffer
          length := tape_request_p^.max_input_count;
          pva := tape_request_p^.wired_read_description_p^ [command_index].buffer_area;
        ELSE {store transfer count buffer
          length := 8;
          pva := tape_request_p^.wired_read_description_p^ [command_index].block_transfer_length;
        IFEND;
        mmp$xtask_pva_to_sva (pva, sva, status);
        IF NOT status.normal THEN
          mtp$error_stop ('MM - boot lock tape rma list, pva to sva convert error');
        IFEND;

        page_offset := sva.offset MOD osv$page_size;
        page_count := ((page_offset + length - 1) DIV osv$page_size) + 1;
        IF page_count + total_list_entries - 1 > tape_request_p^.allocated_address_pair_count THEN
          mtp$error_stop ('MM - boot lock tape rma list, list too small');
        IFEND;

        REPEAT
          #HASH_SVA (sva, pti, hash_count, found);
          IF NOT found THEN
            mtp$error_stop ('MM - boot lock tape rma list, page frame not assigned');
          IFEND;

          list_p^ [total_list_entries].rma := (mmv$pt_p^ [pti].rma * 512) + page_offset;
          page_count := page_count - 1;
          IF page_count > 0 THEN
            list_p^ [total_list_entries].length := osv$page_size - page_offset;
            sva.offset := sva.offset + osv$page_size;
            page_offset := 0;
            list_i := list_i + 1;
          ELSE
            list_p^ [total_list_entries].length := ((sva.offset + length - 1) MOD osv$page_size) -
                  page_offset + 1;
          IFEND;
          total_list_entries := total_list_entries + 1;
        UNTIL page_count <= 0;

        IF loop_count_index = 1 THEN
          i#real_memory_address (^list_p^ [total_list_entries - list_i], rma);
          tape_request_p^.request.tape_command [command_index * 2].address := rma;
          tape_request_p^.request.tape_command [command_index * 2].length := list_i * 8;
        ELSE
          tape_request_p^.request.tape_command [command_index * 2 + 1].address := list_p^
                [total_list_entries - 1].rma;
          EXIT /lock_loop/;
        IFEND;
      FOREND /lock_loop/;

    FOREND;

    IF total_list_entries - 1 < tape_request_p^.allocated_address_pair_count THEN
      list_p^ [total_list_entries].length := 0;
    IFEND;

    tape_request_p^.list_p := list_p;
    tape_request_p^.address_pair_count := total_list_entries - 1;

  PROCEND mmp$build_lock_rma_list_tape;

?? EJECT ??

  PROCEDURE [XDCL] mmp$xtask_pva_to_sva (p: ^cell;
    VAR sva: ost$system_virtual_address;
    VAR status: syt$monitor_status);

    VAR
      cst_p: ^ost$cpu_state_table,
      ste_p: ^mmt$segment_descriptor,
      stxe_p: ^mmt$segment_descriptor_extended,
      aste_p: ^mmt$active_segment_table_entry;

    status.normal := TRUE;
    mtp$cst_p (cst_p);
    mmp$convert_pva (p, cst_p, sva, aste_p, ste_p, stxe_p);

  PROCEND mmp$xtask_pva_to_sva;

  PROCEDURE mmp$convert_pva (p: ^cell;
        cst_p: ^ost$cpu_state_table;
    VAR sva: ost$system_virtual_address;
    VAR aste_p: ^mmt$active_segment_table_entry;
    VAR ste_p: ^mmt$segment_descriptor;
    VAR stxe_p: ^mmt$segment_descriptor_extended);


    VAR
      asid: ost$asid,
      asti: mmt$ast_index,
      segnum: ost$segment;


    segnum := #segment (p);
    ste_p := mmp$get_sdt_entry_p (cst_p^.xcb_p, segnum);
    stxe_p := mmp$get_sdtx_entry_p (cst_p^.xcb_p, segnum);

    IF (segnum > cst_p^.xcb_p^.xp.segment_table_length) OR
          (ste_p^.ste.vl = osc$vl_invalid_entry) THEN
      mtp$error_stop ('MM - invalid PVA');
    IFEND;
    sva.asid := ste_p^.ste.asid;
    sva.offset := #offset (p);
    aste_p := NIL;
  PROCEND mmp$convert_pva;
?? EJECT ??

  PROCEDURE [XDCL] mmp$periodic_call;
  PROCEND mmp$periodic_call;

  PROCEDURE [XDCL] dmp$transfer_unit_completed ALIAS 'dmxtuc' (
        job_id: jmt$ijl_ordinal;
        system_file_id: dmt$system_file_id;
        byte_address: amt$file_byte_address;
        write_tu_status: dmt$write_tu_status;
        au_was_previously_written: boolean;
        media_error: boolean;
        cylinder: iot$cylinder;
        mau_offset_in_cylinder: dmt$maus_per_position;
        iotype: iot$io_function;
    VAR status: syt$monitor_status);
    status.normal := TRUE;
  PROCEND dmp$transfer_unit_completed;
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmt$system_file_id
*copyc syt$monitor_request_code
*copyc jmt$ijl_ordinal
*copyc dmt$ms_logical_device_address
*copyc iot$cylinder
*copyc dmt$minimum_allocation_unit
*copyc iot$io_function
  ?? POP ??

  PROCEDURE [XDCL] mmp$mtr_process_io_completion (io_id: mmt$io_identifier;
        io_function: iot$io_function;
        io_status: syt$monitor_status);
  PROCEND mmp$mtr_process_io_completion;

?? PUSH (LISTEXT := ON) ??
*copyc mmt$io_identifier
*copyc syt$monitor_status
?? POP ??

  PROCEDURE [XDCL] mmp$mtr_process_server_complete (
        remote_request: dft$remote_request;
        io_id: mmt$io_identifier;
        server_iocb_p: ^mmt$server_iocb_entry;
        io_status: syt$monitor_status );
  PROCEND mmp$mtr_process_server_complete;

?? PUSH (LISTEXT:=ON) ??
*copyc dft$remote_request
*copyc mmt$io_identifier
*copyc mmt$server_io_control_block
*copyc syt$monitor_status
?? POP ??

  PROCEDURE [XDCL] mmp$process_read_ahead_complete
    (    io_id: mmt$io_identifier;
     VAR status: syt$monitor_status);
    status.normal := TRUE;
  PROCEND mmp$process_read_ahead_complete;


?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc pmt$signal
*copyc syt$monitor_status
?? POP ??

  PROCEDURE [XDCL] tmp$send_signal
    (    recipient: ost$global_task_id;
         signal: pmt$signal;
     VAR status: syt$monitor_status);

    status.normal := TRUE;
  PROCEND tmp$send_signal;


?? PUSH (LISTEXT := ON) ??
*copyc mmt$io_identifier
*copyc syt$monitor_status
?? POP ??

  PROCEDURE [XDCL] dfp$process_error_log_response
    (    p_fs_pp_response: ^dft$fs_pp_response;
         p_fs_error_log_response: ^dft$fs_error_log_response;
         pp_number: 1 .. ioc$pp_count;
     VAR status: syt$monitor_status);
    status.normal := TRUE;
  PROCEND dfp$process_error_log_response;

?? PUSH (LISTEXT := ON) ??
*copyc dft$fs_pp_response
*copyc dft$fs_error_log_response
*copyc iot$pp_interface_table
*copyc syt$monitor_status
?? POP ??

  PROCEDURE [XDCL] dmp$read ALIAS 'dmxread'
    (    fde_p: gft$locked_file_desc_entry_p;
         byte_address: amt$file_byte_address;
         length: amt$file_byte_address;
     VAR device_address: dmt$ms_logical_device_address;
     VAR status: syt$monitor_status);
    status.normal := TRUE;
  PROCEND dmp$read;
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmt$system_file_id
*copyc jmt$ijl_ordinal
*copyc dmt$ms_logical_device_address
*copyc syt$monitor_request_code
  ?? POP ??

  PROCEDURE [XDCL] dmp$write ALIAS 'dmxwrit'
    (    fde_p: gft$locked_file_desc_entry_p;
         byte_address: amt$file_byte_address;
         length: amt$file_byte_address;
         io_function: iot$io_function;
     VAR device_address: dmt$ms_logical_device_address;
     VAR status: syt$monitor_status);
    status.normal := TRUE;
  PROCEND dmp$write;
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc jmt$ijl_ordinal
*copyc dmt$system_file_id
*copyc dmt$ms_logical_device_address
*copyc syt$monitor_request_code
  ?? POP ??
?? EJECT ??

  PROCEDURE [XDCL] tmp$delay (VAR rb: tmt$rb_delay;
        cst_p: ^ost$cpu_state_table);

    rb.status.normal := TRUE;
    cst_p^.max_cptime := 20000;

  PROCEND tmp$delay;

  PROCEDURE [XDCL] tmp$cycle (VAR rb: tmt$rb_cycle;
        cst_p: ^ost$cpu_state_table);

    cst_p^.max_cptime := 20000;

  PROCEND tmp$cycle;

  VAR
    tmv$ptl_lock: [XDCL, #GATE] tmt$ptl_lock := [FALSE, 0];

  PROCEDURE [XDCL] tmp$switch_task (dummy: ^cell;
        cst_p: ^ost$cpu_state_table);

    cst_p^.max_cptime := 20000;

  PROCEND tmp$switch_task;

  PROCEDURE [XDCL] pr_ascii_coded_keyboard (line: string ( * ));
  PROCEND pr_ascii_coded_keyboard;

  PROCEDURE [XDCL] mtp$deconfigure_divide_unit
    (    processor_id: ost$processor_id);
  PROCEND mtp$deconfigure_divide_unit;

  PROCEDURE [XDCL] mtp$manage_processor_with_due
    (    processor_id: ost$processor_id);
  PROCEND mtp$manage_processor_with_due;
?? PUSH (LISTEXT := ON) ??
*copyc ost$processor_id
?? POP ??

  PROCEDURE [XDCL] mtp$monitor_processor_status;
  PROCEND mtp$monitor_processor_status;
?? EJECT ??

  PROCEDURE [XDCL] tmp$set_system_flag (task_id {input} : ost$global_task_id;
        flag_id {input} : ost$system_flag;
    VAR status {output} : syt$monitor_status);
    status.normal := TRUE;
  PROCEND tmp$set_system_flag;

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc ost$system_flag
*copyc syt$monitor_request_code
?? POP ??
?? EJECT ??

  PROCEDURE [XDCL] tmp$flag_all_tasks (flag_id {input} : ost$system_flag;
    VAR status {output} : syt$monitor_status);
    status.normal := TRUE;
  PROCEND tmp$flag_all_tasks;
?? PUSH (LISTEXT := ON) ??
*copyc ost$system_flag
*copyc syt$monitor_status
?? POP ??
?? EJECT ??

  PROCEDURE [XDCL] tmp$process_task_mcr_fault;

    VAR
      cst_p: ^ost$cpu_state_table,
      xcb_p: ^ost$execution_control_block,
      preg: ost$pva,
      pregp: ^^cell,
      mcrp: ^0 .. 0ffff(16),
      st: string (80),
      stl: integer,
      mcr: ost$monitor_conditions,
      zero_pva: [STATIC] ost$pva := [0, 0, 0];


    mtp$cst_p (cst_p);
    xcb_p := cst_p^.xcb_p;
    preg := xcb_p^.xp.p_register.pva;
    pregp := #LOC (preg);
    mcr := xcb_p^.xp.monitor_condition_register;
    mcrp := #LOC (mcr);
    STRINGREP (st, stl, 'Job mode mcr fault: ', pregp^: 16: #(16), mcrp^: 6:
          #(16));
    mtp$error_stop (st (1, stl));
  PROCEND tmp$process_task_mcr_fault;

  PROCEDURE [XDCL] tmp$mtr_process_system_error (rb: ost$rb_system_error);

    VAR
      cst_p: ^ost$cpu_state_table,
      st: string (80),
      stl: integer;


    mtp$cst_p (cst_p);
    STRINGREP (st, stl, rb.text);
    mtp$error_stop (st (1, stl));

  PROCEND tmp$mtr_process_system_error;

  PROCEDURE [XDCL] tmp$process_unknown_req_fault;

    VAR
      cst_p: ^ost$cpu_state_table,
      st: string (80),
      stl: integer;


    mtp$cst_p (cst_p);
    STRINGREP (st, stl, 'Unknown monitor request');
    mtp$error_stop (st (1, stl));

  PROCEND tmp$process_unknown_req_fault;

  PROCEDURE [XDCL] dpp$process_monitor_command (line: string (*));
  PROCEND dpp$process_monitor_command;

  PROCEDURE [XDCL] tmp$check_taskid (taskid: ost$global_task_id;
        option: tmt$option;
    VAR status: syt$monitor_status);
    status.normal := TRUE;
  PROCEND tmp$check_taskid;

  PROCEDURE [XDCL] tmp$monitor_ready_system_task (stid: tmt$system_task_id;
    VAR status: syt$monitor_status);
    status.normal := TRUE;
  PROCEND tmp$monitor_ready_system_task;

  PROCEDURE [XDCL] tmp$set_task_ready (task_id: ost$global_task_id;
        readying_task_priority: jmt$dispatching_priority;
        ready_condition: tmt$ready_condition);
  PROCEND tmp$set_task_ready;

  PROCEDURE [XDCL] osp$boot_update_page_table (VAR rb: ost$boot_update_page_table;
        cst_p: ^ost$cpu_state_table);

    VAR
      sva: ost$system_virtual_address,
      ste_p: ^mmt$segment_descriptor,
      pfte: mmt$page_frame_table_entry,
      mpt_status: mmt$make_pt_entry_status,
      aste: mmt$active_segment_table_entry,
      length: integer;

    length := rb.length;
    aste.pages_in_memory := 0;
    aste.in_use := TRUE;
    ste_p := mmp$get_sdt_entry_p (cst_p^.xcb_p, #segment (rb.pva));
    sva.asid := ste_p^.ste.asid;
    sva.offset := #offset (rb.pva);
    sva.offset := (sva.offset DIV osv$page_size) * osv$page_size;

    WHILE length > 0 DO
      mmp$make_pt_entry (sva, 0, ^aste, ^pfte, mpt_status);
      IF mpt_status = mmc$mpt_page_table_full THEN
        mtp$error_stop ('Page table full');
      IFEND;
      IF mpt_status = mmc$mpt_done THEN
        mmv$pt_p^ [pfte.pti].v := TRUE;
      IFEND;
      sva.offset := sva.offset + osv$page_size;
      length := length - osv$page_size;
    WHILEND;

  PROCEND osp$boot_update_page_table;

{ The following procedure is a stub for mtp$process_due_errors.

  PROCEDURE [XDCL] tmp$cause_task_switch;
  PROCEND tmp$cause_task_switch;

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
?? POP ??

  PROCEDURE [XDCL] dmp$volume_up (lun: iot$logical_unit);
  PROCEND dmp$volume_up;

  PROCEDURE [XDCL] dmp$volume_down
    (    lun: iot$logical_unit;
         VAR critical: boolean);
    mtp$error_stop ('A disk volume has failed');
  PROCEND dmp$volume_down;

  PROCEDURE [XDCL] dmp$get_recorded_vsn
    (    lun: iot$logical_unit;
         VAR recorded_vsn: rmt$recorded_vsn);
    recorded_vsn := '      ';
  PROCEND dmp$get_recorded_vsn;

  PROCEDURE [XDCL] mmp$determine_error_state (
         list_p: ^mmt$rma_list;
         list_length: mmt$rma_list_length;
     VAR io_error: boolean);

    io_error := FALSE;

  PROCEND mmp$determine_error_state;

  PROCEDURE [XDCL] mmp$include_p_reg_in_dump;

  PROCEND mmp$include_p_reg_in_dump;

  PROCEDURE [XDCL] mmp$mark_page_flawed
    (    pfti: mmt$page_frame_index_32);

  PROCEND mmp$mark_page_flawed;

MODEND osm$monitor_boot;
*DECK DECK=OSM$MONITOR_KEYPOINT_SUPPORT EXPAND=TRUE
?? RIGHT := 110 ??
MODULE osm$monitor_keypoint_support;
?? TITLE := 'Monitor Mode Keypoint Support ' ??
?? PUSH (LISTEXT := ON) ??
*copyc dmt$error_condition_codes
*copyc gft$locked_file_desc_entry_p
*copyc ioe$st_errors
*copyc mmt$keypoint_page_fault_status
*copyc mtc$job_fixed_segment
*copyc osc$purge_map_and_cache
*copyc osd$default_pragmats
*copyc ose$keypoint_conditions
*copyc ost$processor_id
*copyc ost$stack_frame_save_area
*copyc tmv$ptl_lock
*copyc tmv$ptl_p

{ Common decks for global variables referenced by this module.

*copyc jmv$ijl_p
*copyc jmv$null_ijl_ordinal
*copyc jmv$system_ijl_ordinal
*copyc mmv$ast_p
*copyc mmv$multiple_page_maps
*copyc mmv$pt_p
*copyc mmv$pft_p
*copyc mmv$reassignable_page_frames
*copyc mmv$time_to_call_mem_mgr
*copyc mtv$cst0
*copyc mtv$monitor_segment_table
*copyc mtv$scb
*copyc osv$mainframe_wired_cb_heap
*copyc osv$page_size
*copyc osv$ppu_keypoint_control
*copyc osv$time_to_check_asyn
*copyc syv$perf_keypoints_enabled
*copyc syv$pmf_cb_rm_word_address

{Common decks for procedures referenced by this module.

*copyc gfp$mtr_get_locked_fde_p
*copyc i#mtr_disable_traps
*copyc i#move
*copyc i#mtr_restore_traps
*copyc iop$pager_io
*copyc jmp$get_ijle_p
*copyc jmp$unlock_ajl
*copyc mmp$assign_page_to_monitor
*copyc mmp$asti
*copyc mmp$convert_pva
*copyc mmp$delete_page_from_monitor
*copyc mmp$dump_shared_queue
*copyc mmp$get_avail_page_frame
*copyc mmp$link_page_to_segment
*copyc mmp$relink_page_frame
*copyc mmp$unlink_page_from_segment
*copyc mtp$cst_p
*copyc mtp$error_stop
*copyc osp$fetch_locked_variable
*copyc osp$set_locked_variable
*copyc tmp$cause_task_switch
*copyc tmp$clear_lock
*copyc tmp$find_next_xcb
*copyc tmp$get_xcb_access_status
*copyc tmp$get_xcb_p
*copyc tmp$reissue_monitor_request
*copyc tmp$set_lock
*copyc tmp$set_system_flag
*copyc sft$file_space_limit_kind
*copyc ost$keypoint_control
*copyc ost$keypoint_environment
?? POP ??

  VAR
    cl15_enabled: boolean := TRUE,
    dummy_align: integer,

{ The following two variables MUST be kept together. The dummy alignment variable
{ resolves an alignment problem.

    dummy_alignment_variable: [XDCL] integer := 0,
    keypoint_lock: tmt$ptl_lock := [FALSE, 0],
    keypoint_stats: record
      in_count,
      out_count,
      mtr_pf,
      mtr_pf_skip,
      periodic: integer,
    recend := [0, 0, 0, 0, 0],
    null_sva: ost$system_virtual_address := [0, 0],
    osv$keypoint_control: [XDCL, #GATE] ost$keypoint_control := [FALSE, FALSE,
      $ost$keypoint_mask [], $ost$keypoint_mask [], $ost$keypoint_mask [],
      $ost$keypoint_mask [], * , * , 0, 0, 0, * , [0, 0], - 2, - 1, 0, 0,
      [REP osc$max_number_of_processors of *], [REP osc$max_number_of_processors of NIL],
      $ost$processor_id_set [ ], FALSE,
      [REP 8 of [0, * , 0, * , 0, * , NIL, * , 0, FALSE, 999]]],
    osv$keypoint_enable: [XDCL, #GATE] integer := osc$kpt_normal,
    osv$max_kpt_pages: [XDCL, #GATE] integer := osc$max_kpt_pages,
    termination_in_progress: [STATIC] boolean := FALSE;

?? NEWTITLE := 'osp$setup_keypoint_pages', EJECT ??

  PROCEDURE osp$setup_keypoint_pages
    (VAR status: syt$monitor_status);

    VAR
      astep: ^mmt$active_segment_table_entry,
      cstp: ^ost$cpu_state_table,
      fde_entry_p: gft$locked_file_desc_entry_p,
      found: boolean,
      hc: integer,
      i: integer,
      incr: integer,
      ipti: integer,
      lpid: integer,
      offset: integer,
      pfti: integer,
      pkc: ^ost$processor_keypoint_control,
      pr: ost$read_register,
      pva: ^cell,
      sva: ost$system_virtual_address,
      step: ^mmt$segment_descriptor,
      stxep: ^mmt$segment_descriptor_extended,
      tstatus: syt$monitor_status;

    lpid := #read_register (osc$pr_processor_id);
    pkc := ^osv$keypoint_control.cpus [lpid];

    status.normal := TRUE;
    tmp$set_lock (keypoint_lock);
    IF pkc^.active THEN
      tmp$clear_lock (keypoint_lock);
      RETURN;
    IFEND;
    termination_in_progress := FALSE;
    pva := pkc^.collector_pva;
    IF osv$keypoint_enable = osc$kpt_test_mode THEN
      { force all keypoints to cause page faults - mtr checkout only
      pr.pva := pva;
      pr.fill := 0;
      #write_register (osc$pr_keypoint_buffer_ptr, pr.i);
      pkc^.active := TRUE;
      tmp$clear_lock (keypoint_lock);
      RETURN;
    IFEND;
    mmp$assign_page_to_monitor (pva, osv$keypoint_control.max_pages, TRUE, status);
    incr := osv$keypoint_control.max_pages * osv$page_size;
    offset := #offset (pva);
    WHILE NOT status.normal DO
      offset := offset + incr;

{ each processor can use a range of osc$kpt_pva_increment bytes but must not go
{ closer to the next
{ (processor's) range than 1 page so that a page fault will always be generated
{ at the end of each range (i.e. dont let one range spill over into the next

      IF (offset + incr) > (osc$kpt_pva_increment - osv$page_size) THEN
        { exceeded pva range for a processor - cant get pages
        tmp$clear_lock (keypoint_lock);
        RETURN;
      IFEND;
      pva := #address (1, #segment (pva), #offset (pva) + incr);
      mmp$assign_page_to_monitor (pva, osv$keypoint_control.max_pages, TRUE, status);
    WHILEND;
    pkc^.collector_pva := pva;

{ find pfti and pti of initial pages

    mtp$cst_p (cstp);
    mmp$convert_pva (pva, cstp, sva, fde_entry_p, astep, step, stxep);
    FOR i := 1 TO osv$keypoint_control.max_pages DO
      #hash_sva (sva, ipti, hc, found);
      IF NOT found THEN
        mtp$error_stop ('KP - setup #hash');
      IFEND;
      pfti := mmv$pt_p^ [ipti].rma DIV (osv$page_size DIV 512);
      pkc^.in_use_pfti [i] := pfti;
      sva.offset := sva.offset + osv$page_size;
    FOREND;
    pkc^.in_use_count := osv$keypoint_control.max_pages;
    keypoint_stats.in_count := keypoint_stats.in_count +
          osv$keypoint_control.max_pages;

    fill_avail (pkc, status);
    IF NOT status.normal THEN
      mmp$delete_page_from_monitor (pva, osv$keypoint_control.max_pages,
            tstatus);
      keypoint_stats.in_count := keypoint_stats.in_count -
            osv$keypoint_control.max_pages;
      RETURN;
    IFEND;
    pkc^.active := TRUE;
    pr.pva := pva;
    pr.fill := 0;
    #write_register (osc$pr_keypoint_buffer_ptr, pr.i);
    IF (osv$keypoint_control.environment = osc$job_keypoints) OR
        (osv$keypoint_control.environment = osc$job_sample_keypoints) THEN
      cstp^.xcb_p^.keypoint_enable := TRUE;
    IFEND;
    tmp$clear_lock (keypoint_lock);
  PROCEND osp$setup_keypoint_pages;
?? TITLE := 'fill_avail', EJECT ??

  PROCEDURE fill_avail
    (pkc: ^ost$processor_keypoint_control;
     VAR status: syt$monitor_status);

    VAR
      i: integer,
      j: integer,
      pfti: mmt$page_frame_index;

    IF pkc^.avail_count <> 0 THEN
      mtp$error_stop ('KP - avail not zero');
    IFEND;

    IF termination_in_progress THEN
      status.normal := FALSE;
      status.condition := ose$kpt_coll_term_mbs_error;
      RETURN;
    IFEND;

    IF mmv$reassignable_page_frames.now < osv$keypoint_control.max_pages THEN
      mmp$dump_shared_queue (osv$keypoint_control.max_pages);
    IFEND;

  /get_avail_pages/
    FOR i := 1 TO osv$keypoint_control.max_pages DO
      mmp$get_avail_page_frame (pfti);
      IF pfti = 0 THEN

{ pages not available - return

        FOR j := 1 TO (i - 1) DO
          mmp$relink_page_frame (pkc^.avail_pfti [j], mmc$pq_free);
        FOREND;
        pkc^.avail_count := 0;
        status.normal := FALSE;
        status.condition := ose$kpt_coll_term_mbs_error;
        RETURN;
      IFEND;
      mmp$relink_page_frame (pfti, mmc$pq_wired);
      mmv$pft_p^ [pfti].sva := null_sva;
      pkc^.avail_count := pkc^.avail_count + 1;
      pkc^.avail_pfti [i] := pfti;
    FOREND /get_avail_pages/;
    keypoint_stats.in_count := keypoint_stats.in_count +
          osv$keypoint_control.max_pages;
    status.normal := TRUE;
  PROCEND fill_avail;
?? TITLE := 'osp$process_keypoint_page_fault', EJECT ??

  PROCEDURE [XDCL] osp$process_keypoint_page_fault
    (    utp_offset: integer;
     VAR keypoint_page_fault_status: mmt$keypoint_page_fault_status);

    VAR
      cstp: ^ost$cpu_state_table,
      i,
      j: integer,
      lpid: integer,
      pkc: ^ost$processor_keypoint_control,
      pr: ost$read_register,
      pva: ost$pva,
      trick: ost$read_register,
      utp: ^cell;

    lpid := #read_register (osc$pr_processor_id);
    pkc := ^osv$keypoint_control.cpus [lpid];

    trick.i := #read_register (osc$pr_keypoint_buffer_ptr);
    i := #offset (trick.pva);

    keypoint_page_fault_status := mmc$kpfs_normal;

    IF  (utp_offset <> (#offset (pkc^.collector_pva) +
          (osv$keypoint_control.max_pages * osv$page_size))) THEN
      keypoint_page_fault_status := mmc$kpfs_invalid_keypoint;
      RETURN;
    ELSEIF (NOT osv$keypoint_control.active) AND (osv$keypoint_control.ijlo <> jmv$null_ijl_ordinal) THEN
      mtp$cst_p (cstp);
      IF cstp^.xcb_p <> NIL THEN
        cstp^.xcb_p^.keypoint_register_enable := FALSE;
      IFEND;
      keypoint_page_fault_status := mmc$kpfs_disable_keypoints;
      RETURN;
    ELSEIF (i <> (#offset (pkc^.collector_pva) + (osv$keypoint_control.max_pages * osv$page_size))) THEN

{ This condition handles the case of a job mode page fault. The job mode page fault processing causes
{ a monitor page fault. The monitor page fault is satisfied first, and satisfies the job mode fault.
{ However, the job mode page fault will still be processed, and therefore we simply return in this case.

      RETURN;
    IFEND;

    IF osv$keypoint_control.termination_status <> osc$kp_term_not_stopped THEN
      keypoint_page_fault_status := mmc$kpfs_disable_keypoints;
      RETURN;
    IFEND;

    IF osv$keypoint_enable = osc$kpt_test_mode THEN
      mtp$cst_p (cstp);
      cstp^.xcb_p^.xp.p_register.pva.offset := cstp^.xcb_p^.xp.p_register.pva.
            offset + 4;
      RETURN;
    IFEND;

    pr.i := #read_register (osc$pr_keypoint_buffer_ptr);

    IF (#offset (pr.pva) - #offset (pkc^.collector_pva)) <> (osv$page_size *
          osv$keypoint_control.max_pages) THEN
      { assume kbp (etc) has already been reset
      { e.g. job mode pf, mtr pf trap, process mtr pf, process job mode pf.
      RETURN;
    IFEND;

    tmp$set_lock (keypoint_lock);

{ process trace keypoints specially

    IF (osv$keypoint_control.environment = osc$system_sample_keypoints) OR
          (osv$keypoint_control.environment = osc$job_sample_keypoints) THEN
      pr.pva := pkc^.collector_pva;
      pr.fill := 0;
      #write_register (osc$pr_keypoint_buffer_ptr, pr.i);
      pkc^.offset := pkc^.offset + (osv$page_size * osv$keypoint_control.
            max_pages);
      IF (pkc^.offset DIV 8) >= osv$keypoint_control.maximum_keypoints THEN
        terminate_keypoint_collection (ose$kpt_coll_term_max_kpts);
        keypoint_page_fault_status := mmc$kpfs_disable_keypoints;
      IFEND;
      tmp$clear_lock (keypoint_lock);
      RETURN;
    IFEND;

{ move in_use to io

    IF pkc^.io_count <> 0 THEN
      { i/o has fallen behind collection - stop collection
      terminate_keypoint_collection (ose$kpt_coll_term_mbs_error);
      keypoint_page_fault_status := mmc$kpfs_disable_keypoints;
      tmp$clear_lock (keypoint_lock);
      RETURN;
    IFEND;
    FOR i := 1 TO pkc^.in_use_count DO
      pkc^.io_pfti [i] := pkc^.in_use_pfti [i];
    FOREND;
    pkc^.io_count := pkc^.in_use_count;
    pkc^.in_use_count := 0;

{ check for keypoint collection done

    IF (pkc^.offset + (pkc^.io_count * osv$page_size)) DIV 8 >=
          osv$keypoint_control.maximum_keypoints THEN

{ terminating--need to unlink the io (=in_use) pages from the segment

      FOR i := 1 TO pkc^.io_count DO
        mmp$unlink_page_from_segment (^mmv$pft_p^ [pkc^.io_pfti [i]], mmv$pft_p^ [pkc^.
              io_pfti [i]].aste_p);
      FOREND;
      terminate_keypoint_collection (ose$kpt_coll_term_max_kpts);
      keypoint_page_fault_status := mmc$kpfs_disable_keypoints;
    ELSE

{ move avail to in use

      IF pkc^.avail_count > 0 THEN
        FOR i := 1 TO pkc^.avail_count DO
          pkc^.in_use_pfti [i] := pkc^.avail_pfti [i];

{ Unlink the old (io) page frame from the segemnt, copy fields from the old (io) pft to
{ the new (in_use) pft as required, and link the new (in_use) page frame to the segment.

          mmp$unlink_page_from_segment (^mmv$pft_p^ [pkc^.io_pfti [i]], mmv$pft_p^ [pkc^.
                io_pfti [i]].aste_p);
          mmv$pft_p^ [pkc^.in_use_pfti [i]].ijl_ordinal := mmv$pft_p^ [pkc^.
                io_pfti [i]].ijl_ordinal;
          mmv$pft_p^ [pkc^.in_use_pfti [i]].age := mmv$pft_p^ [pkc^.io_pfti
                [i]].age;
          mmv$pft_p^ [pkc^.in_use_pfti [i]].aste_p := mmv$pft_p^ [pkc^.io_pfti
                [i]].aste_p;
          mmv$pft_p^ [pkc^.in_use_pfti [i]].sva := mmv$pft_p^ [pkc^.io_pfti
                [i]].sva;
          mmv$pft_p^ [pkc^.in_use_pfti [i]].pti := mmv$pft_p^ [pkc^.io_pfti
                [i]].pti;
          mmp$link_page_to_segment (pkc^.in_use_pfti [i], ^mmv$pft_p^ [pkc^.in_use_pfti [i]],
                mmv$pft_p^ [pkc^.in_use_pfti [i]].aste_p);

{ change the page table rma

          mmv$pt_p^ [mmv$pft_p^ [pkc^.in_use_pfti [i]].pti].rma := (pkc^.
                in_use_pfti [i] * osv$page_size) DIV 512;
        FOREND;
        #purge_buffer (osc$pva_purge_all_page_seg_map, pkc^.collector_pva);
        pkc^.in_use_count := pkc^.avail_count;
        pkc^.avail_count := 0;
      ELSE

{ terminating--need to unlink the io (=in_use) pages from the segment

        FOR i := 1 TO pkc^.io_count DO
          mmp$unlink_page_from_segment (^mmv$pft_p^ [pkc^.io_pfti [i]], mmv$pft_p^ [pkc^.
                io_pfti [i]].aste_p);
        FOREND;
        terminate_keypoint_collection (ose$kpt_coll_term_mbs_error);
        keypoint_page_fault_status := mmc$kpfs_disable_keypoints;
      IFEND;
    IFEND;
    osv$keypoint_control.periodic_requested := TRUE;
    mmv$time_to_call_mem_mgr := 0;
    mtp$cst_p (cstp);
    cstp^.dispatch_control.asynchronous_interrupts_pending := TRUE;
    osv$time_to_check_asyn := 0;
    { reset KBP
    pr.pva := pkc^.collector_pva;
    pr.fill := 0;
    #write_register (osc$pr_keypoint_buffer_ptr, pr.i);

    tmp$clear_lock (keypoint_lock);
  PROCEND osp$process_keypoint_page_fault;
?? TITLE := 'osp$process_keypoint_periodic', EJECT ??

  PROCEDURE [XDCL] osp$process_keypoint_periodic;

    CONST
      allow_allocation = TRUE;

    VAR
      bd: mmt$buffer_descriptor,
      chapter_offset: integer,
      fde_entry_p: gft$locked_file_desc_entry_p,
      ijle_p: ^jmt$initiated_job_list_entry,
      io_id: mmt$io_identifier,
      j: integer,
      lpid: integer,
      max_pages_per_io: integer,
      offset: integer,
      osv$keypoint_periodic_lpid: [XDCL] integer := 9999,
      pkc: ^ost$processor_keypoint_control,
      ppio: integer,
      status: syt$monitor_status;

    tmp$set_lock (keypoint_lock);
    io_id.specified := FALSE;
    io_id.io_function := ioc$keypoint_io;
    keypoint_stats.periodic := keypoint_stats.periodic + 1;
    osv$keypoint_control.periodic_requested := FALSE;

    IF (osv$keypoint_control.environment = osc$system_keypoints) OR
          (osv$keypoint_control.environment = osc$job_keypoints) THEN

    /write_to_disk/
      FOR lpid := osv$keypoint_control.first_active_processor TO
            osv$keypoint_control.last_active_processor DO
        pkc := ^osv$keypoint_control.cpus [lpid];
        IF pkc^.avail_count = 0 THEN
          fill_avail (pkc, status);
          { ignore status - stop only on page fault
        IFEND;
        offset := #offset (pkc^.collector_pva);
        jmp$get_ijle_p (osv$keypoint_control.ijlo, ijle_p);
        gfp$mtr_get_locked_fde_p (pkc^.sfid, ijle_p, fde_entry_p);
        max_pages_per_io := fde_entry_p^.allocation_unit_size DIV osv$page_size;
        WHILE pkc^.io_count > 0 DO
          IF pkc^.io_count > max_pages_per_io THEN
            ppio := max_pages_per_io;
          ELSE
            ppio := pkc^.io_count;
          IFEND;

          bd.buffer_descriptor_type := mmc$bd_paging_io;
          bd.sva.offset := offset;
          bd.sva.asid := mmv$pt_p^ [mmv$pft_p^ [pkc^.io_pfti [1]].pti].pageid.
                asid;
          bd.page_count := ppio;
          osv$keypoint_periodic_lpid := lpid;
          iop$pager_io (fde_entry_p, pkc^.offset, bd,
                ppio * osv$page_size, ioc$keypoint_io, io_id, status);
          IF NOT status.normal THEN
            IF (status.condition = dme$transient_error) OR
               (status.condition = ioe$requests_full) THEN
              osv$keypoint_control.periodic_requested := TRUE;
              CYCLE /write_to_disk/;
            ELSE
              terminate_keypoint_collection (status.condition);
            IFEND;
          IFEND;
          IF pkc^.io_count > ppio THEN
            { shift io pfti's to the start of the list for the next iteration
            FOR j := (ppio + 1) TO pkc^.io_count DO
              pkc^.io_pfti [j - ppio] := pkc^.io_pfti [j];
            FOREND;
          IFEND;
          pkc^.offset := pkc^.offset + (ppio * osv$page_size);
          offset := offset + (ppio * osv$page_size);
          keypoint_stats.out_count := keypoint_stats.out_count + pkc^.
                io_count;
          pkc^.io_count := pkc^.io_count - ppio;
        WHILEND;
      FOREND /write_to_disk/;
    IFEND;

    osv$keypoint_periodic_lpid := 9999;
    tmp$clear_lock (keypoint_lock);
  PROCEND osp$process_keypoint_periodic;
?? TITLE := 'terminate_keypoint_collection', EJECT ??

  PROCEDURE terminate_keypoint_collection
    (reason: integer);

    VAR
      cst_p: ^ost$cpu_state_table;

{ stop keypoint collection -
{    stop IMMEDIATELY for this processor in MTR mode

    tmp$set_lock (keypoint_lock);
    osv$keypoint_control.jm := $ost$keypoint_mask [];
    osv$keypoint_control.mm := $ost$keypoint_mask [];
    osv$keypoint_control.termination_status := reason;
    osv$keypoint_control.active := FALSE;
    tmp$clear_lock (keypoint_lock);
    #write_register (osc$pr_clear_keypoint_enable,
          osc$pr_clear_keypoint_enable);
    mtp$cst_p (cst_p);
    IF cst_p^.xcb_p <> NIL THEN
      cst_p^.xcb_p^.keypoint_register_enable := FALSE;
    IFEND;

  PROCEND terminate_keypoint_collection;
?? TITLE := 'propagate_keypoint_masks', EJECT ??

  PROCEDURE propagate_keypoint_masks
    (VAR status: syt$monitor_status);

    VAR
      cstp: ^ost$cpu_state_table,
      kef: boolean,
      lmm: ^0 .. 0ffff(16),
      mm: ost$keypoint_mask;

    status.normal := TRUE;
    mtp$cst_p (cstp);
    IF (osv$keypoint_control.environment = osc$system_keypoints) OR
          (osv$keypoint_control.environment = osc$system_sample_keypoints) OR
          (osv$keypoint_control.ijlo = cstp^.ijl_ordinal) THEN
      mm := osv$keypoint_control.mm;
    ELSE
      mm := $ost$keypoint_mask [];
    IFEND;

    lmm := #LOC (mm);
    #write_register (osc$pr_keypoint_mask, lmm^);
    kef := (mm <> $ost$keypoint_mask []) OR (osv$keypoint_control.jm <> $ost$keypoint_mask []);
    IF kef THEN
      #write_register (osc$pr_set_keypoint_enable, osc$pr_set_keypoint_enable);
    ELSE
      #write_register (osc$pr_clear_keypoint_enable,
            osc$pr_clear_keypoint_enable);
    IFEND;
    change_tasks_keypoint_masks (kef, cstp, status);

  PROCEND propagate_keypoint_masks;
?? TITLE := 'change_tasks_keypoint_masks', EJECT ??

  PROCEDURE change_tasks_keypoint_masks
    (    keypoint_enabled_flag: boolean;
         cst_p: ^ost$cpu_state_table;
     VAR status: syt$monitor_status);

    VAR
      inhibit_access: boolean,
      ijle_p: ^jmt$initiated_job_list_entry,
      j: integer,
      max_ptlo: ost$task_index,
      ptlo: ost$task_index,
      swapped: boolean,
      xcbp: ^ost$execution_control_block,
      xcb_state: tmt$find_next_xcb_state;


    status.normal := TRUE;
    IF (osv$keypoint_control.environment = osc$system_keypoints) OR
          (osv$keypoint_control.environment = osc$system_sample_keypoints) THEN
      tmp$set_lock (tmv$ptl_lock);
      max_ptlo := UPPERBOUND (tmv$ptl_p^);
      FOR ptlo := 1 TO max_ptlo DO
        IF tmv$ptl_p^ [ptlo].status <> tmc$ts_null THEN
          jmp$get_ijle_p (tmv$ptl_p^ [ptlo].ijl_ordinal, ijle_p);
          IF (tmv$ptl_p^ [ptlo].status = tmc$ts_executing) AND (ptlo <> cst_p^.taskid.index) THEN
            xcbp := #ADDRESS (1, ijle_p^.ajl_ordinal + mtc$job_fixed_segment, tmv$ptl_p^ [ptlo].xcb_offset);
            IF (keypoint_enabled_flag AND (NOT xcbp^.keypoint_register_enable)) OR
              (NOT keypoint_enabled_flag AND (xcbp^.keypoint_register_enable)) THEN
              status.normal := FALSE;
              status.condition := ose$fail_to_update_keyp_flags;
            IFEND;
          ELSE
            tmp$get_xcb_access_status (ijle_p, tmv$ptl_p^ [ptlo].ijl_ordinal, inhibit_access);
            IF inhibit_access THEN
              ijle_p^.delayed_swapin_work := ijle_p^.delayed_swapin_work +
                  $jmt$delayed_swapin_work [jmc$dsw_update_keypoint_masks];
            ELSE
              xcbp := #ADDRESS (1, ijle_p^.ajl_ordinal + mtc$job_fixed_segment, tmv$ptl_p^ [ptlo].xcb_offset);
              IF keypoint_enabled_flag THEN
                xcbp^.xp.flags := xcbp^.xp.flags + $ost$flags [osc$keypoint_enable];
                xcbp^.keypoint_register_enable := TRUE;
              ELSE
                xcbp^.xp.flags := xcbp^.xp.flags - $ost$flags [osc$keypoint_enable];
                xcbp^.keypoint_register_enable := FALSE;
              IFEND;
              xcbp^.xp.keypoint_mask := osv$keypoint_control.jm;
              jmp$unlock_ajl (ijle_p);
            IFEND;
          IFEND;
        IFEND;
      FOREND;
      tmp$clear_lock (tmv$ptl_lock);
    ELSEIF (osv$keypoint_control.environment = osc$job_keypoints) OR
        (osv$keypoint_control.environment = osc$job_sample_keypoints) THEN
      jmp$get_ijle_p (osv$keypoint_control.ijlo, ijle_p);
      tmp$find_next_xcb (tmc$fnx_job, ijle_p, osv$keypoint_control.ijlo, xcb_state, xcbp);
      WHILE xcbp <> NIL DO
        IF xcbp^.keypoint_enable THEN
          IF keypoint_enabled_flag THEN
            xcbp^.xp.flags := xcbp^.xp.flags + $ost$flags [osc$keypoint_enable];
            xcbp^.keypoint_register_enable := TRUE;
          ELSE
            xcbp^.xp.flags := xcbp^.xp.flags - $ost$flags [osc$keypoint_enable];
            xcbp^.keypoint_register_enable := FALSE;
          IFEND;
          xcbp^.xp.keypoint_mask := osv$keypoint_control.jm;
        IFEND;
        tmp$find_next_xcb (tmc$fnx_continue, NIL, osv$keypoint_control.ijlo, xcb_state, xcbp);
      WHILEND;
    IFEND;

  PROCEND change_tasks_keypoint_masks;
?? TITLE := 'osp$update_job_keypoint_mask', EJECT ??

  PROCEDURE [XDCL] osp$update_job_keypoint_mask
    (ijle_p: ^jmt$initiated_job_list_entry;
     ijl_ordinal: jmt$ijl_ordinal);

{ This procedure is called by the job swapper at swapin time if
{ jmc$dsw_update_keypoint_masks was set in the ijl delayed_swapin_work
{ field for the job being swapped in.

    VAR
      jm: ost$keypoint_mask,
      kef: boolean,
      xcbp: ^ost$execution_control_block,
      xcb_state: tmt$find_next_xcb_state;

    tmp$set_lock (keypoint_lock);
    IF osv$keypoint_control.active THEN
      IF (osv$keypoint_control.environment = osc$system_keypoints) OR
            (osv$keypoint_control.environment = osc$system_sample_keypoints)
            THEN
        jm := osv$keypoint_control.jm;
      ELSE
{ check if correct job
        IF osv$keypoint_control.ijlo = ijl_ordinal THEN
{ correct - update masks
          jm := osv$keypoint_control.jm;
        ELSE
{ different - clear masks
          jm := $ost$keypoint_mask [];
        IFEND;
      IFEND;
    ELSE
      jm := $ost$keypoint_mask [];
    IFEND;
    kef := jm <> $ost$keypoint_mask [];
    tmp$find_next_xcb (tmc$fnx_job, ijle_p, ijl_ordinal, xcb_state, xcbp);
    WHILE xcbp <> NIL DO
      IF kef THEN
        xcbp^.xp.flags := xcbp^.xp.flags + $ost$flags [osc$keypoint_enable];
        xcbp^.keypoint_register_enable := TRUE;
      ELSE
        xcbp^.xp.flags := xcbp^.xp.flags - $ost$flags [osc$keypoint_enable];
        xcbp^.keypoint_register_enable := FALSE;
      IFEND;
      xcbp^.xp.keypoint_mask := jm;
      tmp$find_next_xcb (tmc$fnx_continue, NIL, jmv$null_ijl_ordinal, xcb_state, xcbp);
    WHILEND;
    tmp$clear_lock (keypoint_lock);
  PROCEND osp$update_job_keypoint_mask;
?? TITLE := 'osp$process_job_keypoint_req', EJECT ??

  PROCEDURE [XDCL] osp$process_job_keypoint_req
    (VAR rb:ost$rb_keypoint_request);

    VAR
      cst_p: ^ost$cpu_state_table,
      lpid: integer,
      pr: ost$read_register,
      status: syt$monitor_status;

    mtp$cst_p (cst_p);
    rb.status.normal := TRUE;
    lpid := #READ_REGISTER (osc$pr_processor_id);
    CASE rb.sub_request OF
    = osc$kpt_mr_init =
      osp$setup_keypoint_pages (rb.status);
      IF rb.status.normal THEN
        put_stuff_in_buffer (lpid, rb);
      IFEND;
    = osc$kpt_mr_start =
      IF (osv$keypoint_control.environment = osc$job_keypoints) OR
          (osv$keypoint_control.environment = osc$job_sample_keypoints) THEN
        IF NOT cst_p^.xcb_p^.keypoint_enable THEN
          rb.status.normal := FALSE;
          rb.status.condition := ose$kpt_illegal_request;
          RETURN;
        IFEND;
      IFEND;
      IF termination_in_progress THEN
        rb.status.normal := FALSE;
        rb.status.condition := ose$kpt_illegal_request;
        RETURN;
      IFEND;
      IF osv$keypoint_control.termination_status = osc$kp_term_not_stopped THEN
        put_stuff_in_buffer (lpid, rb);
      ELSE
        rb.status.normal := FALSE;
        rb.status.condition := osv$keypoint_control.termination_status;
      IFEND;
    = osc$kpt_mr_stop =
      IF (osv$keypoint_control.environment = osc$job_keypoints) OR
          (osv$keypoint_control.environment = osc$job_sample_keypoints) THEN
        IF NOT cst_p^.xcb_p^.keypoint_enable THEN
          rb.status.normal := FALSE;
          rb.status.condition := ose$kpt_illegal_request;
          RETURN;
        IFEND;
      IFEND;
      IF termination_in_progress THEN
        rb.status.normal := FALSE;
        rb.status.condition := ose$kpt_illegal_request;
        RETURN;
      IFEND;
      osv$keypoint_control.jm := $ost$keypoint_mask [];
      osv$keypoint_control.mm := $ost$keypoint_mask [];
      osv$keypoint_control.active := FALSE;

{ The STOP request will propagate masks to as many tasks as possible. This request is not concerned
{ with bad status being returned from the propagate_keypoint_masks procedure. Any
{ tasks which have not had the keypoint masks modified, will have them modified the
{ next time they page fault.

      propagate_keypoint_masks (status);
      put_stuff_in_buffer (lpid, rb);
    = osc$kpt_mr_issue =
      IF (osv$keypoint_control.environment = osc$job_keypoints) OR
          (osv$keypoint_control.environment = osc$job_sample_keypoints) THEN
        IF NOT cst_p^.xcb_p^.keypoint_enable THEN
          rb.status.normal := FALSE;
          rb.status.condition := ose$kpt_illegal_request;
          RETURN;
        IFEND;
      IFEND;
      IF termination_in_progress THEN
        rb.status.normal := FALSE;
        rb.status.condition := ose$kpt_illegal_request;
        RETURN;
      IFEND;
      put_stuff_in_buffer (lpid, rb);
    = osc$kpt_mr_term =

{ The additional clause is required in this statement because this code is
{ executed for each processor. The other job mode requests are only executed
{ once, no matter how many processors keypoints are active on.

      IF ((osv$keypoint_control.environment = osc$job_keypoints) OR
          (osv$keypoint_control.environment = osc$job_sample_keypoints)) AND
           NOT (osv$keypoint_control.mpo = osc$keypoints_multi_processor) THEN
        IF NOT cst_p^.xcb_p^.keypoint_enable THEN
          rb.status.normal := FALSE;
          rb.status.condition := ose$kpt_illegal_request;
          RETURN;
        IFEND;
      IFEND;
      put_stuff_in_buffer (lpid, rb);
      osp$terminate_keypoint_collect (rb.status);
    = osc$kpt_mr_go =
      IF (osv$keypoint_control.environment = osc$job_keypoints) OR
          (osv$keypoint_control.environment = osc$job_sample_keypoints) THEN
        IF NOT cst_p^.xcb_p^.keypoint_enable THEN
          rb.status.normal := FALSE;
          rb.status.condition := ose$kpt_illegal_request;
          RETURN;
        IFEND;
      IFEND;
      IF termination_in_progress THEN
        rb.status.normal := FALSE;
        rb.status.condition := ose$kpt_illegal_request;
        RETURN;
      IFEND;
      IF osv$keypoint_control.termination_status = osc$kp_term_not_stopped THEN
        osv$keypoint_control.jm := osv$keypoint_control.envjm;
        osv$keypoint_control.mm := osv$keypoint_control.envmm;
        osv$keypoint_control.active := TRUE;
        propagate_keypoint_masks (rb.status);
        IF (NOT rb.status.normal) AND (rb.status.condition = ose$fail_to_update_keyp_flags) THEN
          tmp$reissue_monitor_request;
          tmp$cause_task_switch;
        IFEND;
      ELSE
        rb.status.normal := FALSE;
        rb.status.condition := osv$keypoint_control.termination_status;
      IFEND;
    ELSE
    CASEND;
  PROCEND osp$process_job_keypoint_req;
?? TITLE := 'osp$terminate_keypoint_collect', EJECT ??

  PROCEDURE osp$terminate_keypoint_collect
    (VAR status: syt$monitor_status);

    VAR
      asid: ost$asid,
      astep: ^mmt$active_segment_table_entry,
      asti: mmt$ast_index,
      found: boolean,
      hc: integer,
      i: integer,
      ijlep: ^jmt$initiated_job_list_entry,
      ipti: integer,
      j: integer,
      lpid: integer,
      pfti: mmt$page_frame_index,
      pftis: array [1 .. osc$max_kpt_pages] of mmt$page_frame_index,
      pi: ^array [0 .. 100000] of integer,
      pkc: ^ost$processor_keypoint_control,
      sva: ost$system_virtual_address,
      trick: ost$read_register,
      xcbp: ^ost$execution_control_block,
      xcb_state: tmt$find_next_xcb_state;

    status.normal := TRUE;
    lpid := #read_register (osc$pr_processor_id);
    pkc := ^osv$keypoint_control.cpus [lpid];
    tmp$set_lock (keypoint_lock);
    IF NOT pkc^.active THEN
      tmp$clear_lock (keypoint_lock);
      RETURN;
    IFEND;
    IF osv$keypoint_control.active THEN
      mtp$error_stop ('KP - term while active');
    IFEND;
    propagate_keypoint_masks (status);
    IF (NOT status.normal) AND (status.condition = ose$fail_to_update_keyp_flags) THEN

{ Dont clear the lock before re-issueing the monitor request-it will crash when the request completes
{ normally.

      tmp$reissue_monitor_request;
      tmp$cause_task_switch;
    IFEND;
    termination_in_progress := TRUE;
    osp$process_keypoint_periodic;
    IF pkc^.io_count <> 0 THEN
      FOR j := 1 TO pkc^.io_count DO
        mmp$relink_page_frame (pkc^.io_pfti [j], mmc$pq_free);
      FOREND;
      keypoint_stats.out_count := keypoint_stats.out_count + pkc^.
            io_count;
    IFEND;

    IF pkc^.in_use_count > 0 THEN

{ clear the remainder of the collection pages

      trick.i := #read_register (osc$pr_keypoint_buffer_ptr);
      i := #offset (trick.pva);
      i := i - #offset (pkc^.collector_pva);
      IF i <> 0 THEN
        pi := pkc^.collector_pva;
        FOR j := (i DIV 8) TO ((osv$keypoint_control.max_pages * osv$page_size)
              DIV 8) - 1 DO
          pi^ [j] := 0;
        FOREND;
      IFEND;

{     flush in use pages to disk

      FOR j := 1 TO pkc^.in_use_count DO
        pkc^.io_pfti [j] := pkc^.in_use_pfti [j];
        mmp$unlink_page_from_segment (^mmv$pft_p^ [pkc^.io_pfti [j]], mmv$pft_p^
              [pkc^.io_pfti [j]].aste_p);
      FOREND;
      pkc^.io_count := pkc^.in_use_count;
      pkc^.in_use_count := 0;
      osp$process_keypoint_periodic;
      IF pkc^.io_count <> 0 THEN
        FOR j := 1 TO pkc^.io_count DO
          mmp$relink_page_frame (pkc^.io_pfti [j], mmc$pq_free);
        FOREND;
        keypoint_stats.out_count := keypoint_stats.out_count + pkc^.
              io_count;
      IFEND;
    IFEND;

    FOR j := 1 TO pkc^.avail_count DO
      mmp$relink_page_frame (pkc^.avail_pfti [j], mmc$pq_free);
    FOREND;
    keypoint_stats.out_count := keypoint_stats.out_count + pkc^.
          avail_count;
    pkc^.avail_count := 0;

    asid := mtv$monitor_segment_table.st [osc$segnum_page_table].ste.asid;
    mmp$asti (asid, asti);
    astep := ^mmv$ast_p^ [asti];
    sva.asid := asid;
    sva.offset := #OFFSET (pkc^.collector_pva);

    { Return page table entries - requires valid pft entry

  /get_avail_pages/
    FOR i := 1 TO osv$keypoint_control.max_pages DO
      mmp$get_avail_page_frame (pfti);
      IF pfti = 0 THEN
{ pages not available - return
        FOR j := 1 TO (i - 1) DO
          mmp$relink_page_frame (pftis [j], mmc$pq_free);
        FOREND;
        status.normal := FALSE;
        status.condition := ose$kpt_coll_term_mbs_error;
        tmp$clear_lock (keypoint_lock);
        RETURN;
      IFEND;
      mmp$relink_page_frame (pfti, mmc$pq_wired);
      mmv$pft_p^ [pfti].sva := null_sva;
      pftis [i] := pfti;
    FOREND /get_avail_pages/;

    FOR i := 1 TO osv$keypoint_control.max_pages DO
      #hash_sva (sva, ipti, hc, found);
      IF NOT found THEN
        mtp$error_stop ('KP - term #hash');
      IFEND;
      mmv$pft_p^ [pftis [i]].ijl_ordinal := astep^.ijl_ordinal;
      mmv$pft_p^ [pftis [i]].age := 1;
      mmv$pft_p^ [pftis [i]].aste_p := astep;
      mmv$pft_p^ [pftis [i]].sva := sva;
      mmv$pft_p^ [pftis [i]].pti := ipti;
      mmv$pt_p^ [ipti].rma := (pftis [i] * osv$page_size) DIV 512;
      sva.offset := sva.offset + osv$page_size;
    FOREND;

    trick.i := #read_register (osc$pr_keypoint_buffer_ptr);
    i := #offset (trick.pva);
    i := i - #offset (pkc^.collector_pva);
    IF i <> 0 THEN
      pkc^.offset := pkc^.offset - ((osv$keypoint_control.max_pages *
            osv$page_size) - i);
    IFEND;
    IF osv$keypoint_enable = osc$kpt_test_mode THEN
      pkc^.offset := 0;
    IFEND;

    trick.pva := NIL;
    trick.fill := 0;
    #write_register (osc$pr_keypoint_buffer_ptr, trick.i);
    #purge_buffer (osc$pva_purge_all_page_seg_map, pkc^.collector_pva);
    mmp$delete_page_from_monitor (pkc^.collector_pva, osv$keypoint_control.
          max_pages, status);
    #purge_buffer (osc$pva_purge_all_page_seg_map, pkc^.collector_pva);
    pkc^.active := FALSE;
    osv$keypoint_control.periodic_requested := FALSE;
    IF (osv$keypoint_control.environment = osc$job_keypoints) OR
        (osv$keypoint_control.environment = osc$job_sample_keypoints) THEN
      jmp$get_ijle_p ( osv$keypoint_control.ijlo, ijlep);
      tmp$find_next_xcb (tmc$fnx_job, ijlep, osv$keypoint_control.ijlo, xcb_state, xcbp);
      WHILE xcbp <> NIL DO
        xcbp^.keypoint_enable := FALSE;
        tmp$find_next_xcb (tmc$fnx_continue, NIL, jmv$null_ijl_ordinal, xcb_state, xcbp);
      WHILEND;
    IFEND;
    tmp$clear_lock (keypoint_lock);
  PROCEND osp$terminate_keypoint_collect;

?? TITLE := 'osp$process_keypoint_io_error', EJECT ??

  PROCEDURE [XDCL] osp$process_keypoint_io_error;

    tmp$set_lock (keypoint_lock);
    terminate_keypoint_collection (ose$kpt_coll_term_io_error);
    tmp$clear_lock (keypoint_lock);

  PROCEND osp$process_keypoint_io_error;
?? TITLE := 'osp$process_mtr_page_fault', EJECT ??

  PROCEDURE [XDCL] osp$process_mtr_page_fault
    (psa: ^ost$stack_frame_save_area;
     VAR halt: boolean);

    VAR
      cst_p: ^ost$cpu_state_table,
      keypoint_page_fault_status: mmt$keypoint_page_fault_status,
      lpid: integer,
      offset: integer,
      pkc: ^ost$processor_keypoint_control,
      p_opcode: ^0 .. 0ff(16),
      status: syt$monitor_status;


    keypoint_stats.mtr_pf := keypoint_stats.mtr_pf + 1;
    p_opcode := #address (1, psa^.minimum_save_area.p_register.pva.seg, psa^.
          minimum_save_area.p_register.pva.offset);
    IF p_opcode^ <> 0b1(16) THEN
      halt := TRUE;
      RETURN;
    IFEND;
    IF osv$keypoint_enable = osc$kpt_test_mode THEN
      keypoint_stats.mtr_pf_skip := keypoint_stats.mtr_pf_skip + 1;
      psa^.minimum_save_area.p_register.pva.offset := psa^.minimum_save_area.
            p_register.pva.offset + 4;
      halt := FALSE;
      RETURN;
    IFEND;
    IF NOT osv$keypoint_control.active THEN
      mtp$cst_p (cst_p);
      #write_register (osc$pr_clear_keypoint_enable,
            osc$pr_clear_keypoint_enable);
      IF cst_p^.xcb_p <> NIL THEN
        cst_p^.xcb_p^.keypoint_register_enable := FALSE;
      IFEND;
      keypoint_stats.mtr_pf_skip := keypoint_stats.mtr_pf_skip + 1;
      psa^.minimum_save_area.p_register.pva.offset := psa^.minimum_save_area.
            p_register.pva.offset + 4;
    ELSE
      lpid := #read_register (osc$pr_processor_id);
      pkc := ^osv$keypoint_control.cpus [lpid];
      offset := #offset (pkc^.collector_pva) + (osv$keypoint_control.max_pages * osv$page_size);
      osp$process_keypoint_page_fault (offset, keypoint_page_fault_status);
      IF keypoint_page_fault_status <> mmc$kpfs_normal THEN
        psa^.minimum_save_area.p_register.pva.offset := psa^.minimum_save_area.
              p_register.pva.offset + 4;
      IFEND;
    IFEND;
    halt := FALSE;
  PROCEND osp$process_mtr_page_fault;
?? TITLE := 'osp$executing_for_other_cpu', EJECT ??
  FUNCTION [INLINE] osp$executing_for_other_cpu
    (    processor_id: ost$processor_id): boolean;

    IF processor_id = #read_register(osc$pr_processor_id) THEN
      osp$executing_for_other_cpu := FALSE;
    ELSE
      osp$executing_for_other_cpu := TRUE;
    IFEND;

  FUNCEND osp$executing_for_other_cpu;

?? TITLE := 'osp$alert_keyp_cpu_state_chng ', EJECT ??

  PROCEDURE [XDCL] osp$alert_keyp_cpu_state_chng
    (    cpu_with_state_change: ost$processor_id);

  VAR
    actual: integer,
    cpu: ost$processor_id,
    cst_p: ^ost$cpu_state_table,
    i: integer,
    ignore_status: syt$monitor_status,
    ijlep: ^jmt$initiated_job_list_entry,
    processor_selections: ost$processor_id_set,
    pseudo_rb: ost$rb_keypoint_request,
    result: boolean,
    status: syt$monitor_status,
    xcbp: ^ost$execution_control_block,
    xcb_state: tmt$find_next_xcb_state;

    IF termination_in_progress THEN
      RETURN;
    IFEND;
    xcbp := NIL;
    tmp$set_lock (keypoint_lock);
    IF osv$keypoint_control.ijlo <> jmv$null_ijl_ordinal THEN
      IF (cpu_with_state_change <= osv$keypoint_control.last_active_processor) AND
        (cpu_with_state_change >= osv$keypoint_control.first_active_processor) THEN
        termination_in_progress := TRUE;
        FOR cpu := osv$keypoint_control.first_active_processor TO
               osv$keypoint_control.last_active_processor DO
          IF osv$keypoint_control.active THEN
            osv$keypoint_control.jm := $ost$keypoint_mask [ ];
            osv$keypoint_control.mm := $ost$keypoint_mask [ ];
            osv$keypoint_control.active := FALSE;
            IF osp$executing_for_other_cpu (cpu_with_state_change) THEN
              cst_p := ^mtv$cst0 [cpu_with_state_change];
              change_tasks_keypoint_masks (FALSE, cst_p, ignore_status);
            ELSE
              propagate_keypoint_masks (ignore_status);
              pseudo_rb.kpt.microsecond_clock := #free_running_clock (0);
              pseudo_rb.kpt.user_data := '  ';
              pseudo_rb.kpt.keypoint.clock := pseudo_rb.kpt.microsecond_clock MOD
                 10000000(16);
              pseudo_rb.kpt.keypoint.keypoint_class := 15;
              pseudo_rb.kpt.keypoint.keypoint_code := osc$keypoint_cl15_stop;
              put_stuff_in_buffer (cpu, pseudo_rb);
            IFEND;
          IFEND;
        FOREND;



        IF NOT osp$executing_for_other_cpu (cpu_with_state_change) THEN
          FOR cpu := osv$keypoint_control.first_active_processor TO
                osv$keypoint_control.last_active_processor DO
            pseudo_rb.kpt.microsecond_clock := #free_running_clock (0);
            pseudo_rb.kpt.user_data := '  ';
            pseudo_rb.kpt.keypoint.clock := pseudo_rb.kpt.microsecond_clock MOD
                 10000000(16);
            pseudo_rb.kpt.keypoint.keypoint_class := 15;
            pseudo_rb.kpt.keypoint.keypoint_code := osc$keypoint_cl15_release;
            put_stuff_in_buffer (cpu, pseudo_rb);
            osp$terminate_keypoint_collect (ignore_status);
          FOREND;
        IFEND;

  { Reset the processor_selections if necessary.}
  { Need to do this for all tasks in the job.

        IF (osv$keypoint_control.environment = osc$job_keypoints) OR
              (osv$keypoint_control.environment = osc$job_sample_keypoints) THEN
          jmp$get_ijle_p (osv$keypoint_control.ijlo, ijlep);
          IF osv$keypoint_control.processor_select_flag THEN
            processor_selections := $ost$processor_id_set [ ];
            FOR cpu := 0 TO 7 DO
              IF cpu IN osv$keypoint_control.processor_selections THEN
                processor_selections := processor_selections + $ost$processor_id_set [cpu];
              IFEND;
            FOREND;
          ELSE
            IF ijlep^.job_scheduler_data.job_class = jmc$maintenance_job_class THEN
              processor_selections := mtv$scb.cpus.logically_on;
            ELSE
              processor_selections := mtv$scb.cpus.available_for_use;
            IFEND;
          IFEND;
          tmp$find_next_xcb (tmc$fnx_job, ijlep, osv$keypoint_control.ijlo, xcb_state, xcbp);
          WHILE xcbp <> NIL DO
            xcbp^.keypoint_enable := FALSE;
            xcbp^.processor_selections := processor_selections;
            tmp$set_system_flag (xcbp^.global_task_id, osc$keyp_environ_change_flag, ignore_status);
            tmp$find_next_xcb (tmc$fnx_continue, NIL, jmv$null_ijl_ordinal, xcb_state, xcbp);
          WHILEND;
        IFEND;

{ If the job collecting keypoints hasn't been notified about the change in keypoint environement (done if
{ collecting job/job sample keypoints above) inform the $JOBMONITOR task in the job.

        IF xcbp = NIL THEN
          jmp$get_ijle_p (osv$keypoint_control.ijlo, ijlep);
          tmp$set_system_flag (ijlep^.job_monitor_taskid, osc$keyp_environ_change_flag, ignore_status);
        IFEND;

        syv$pmf_cb_rm_word_address := 0;
{       FREE osv$ppu_keypoint_control IN osv$mainframe_wired_cb_heap^;
        osv$keypoint_control.jsn := '     ';
        osv$keypoint_control.first_active_processor := -2;
        osv$keypoint_control.last_active_processor := -1;
        osv$keypoint_control.ijlo := jmv$null_ijl_ordinal;
        osv$keypoint_control.processor_select_flag := FALSE;
        syv$perf_keypoints_enabled.memory_keypoints := FALSE;
        syv$perf_keypoints_enabled.heap_keypoints := FALSE;
        syv$perf_keypoints_enabled.swapping_keypoints := FALSE;
        syv$perf_keypoints_enabled.aging_keypoints := FALSE;
        syv$perf_keypoints_enabled.swapping_stack_trace := FALSE;
        syv$perf_keypoints_enabled.aging_stack_trace := FALSE;
        syv$perf_keypoints_enabled.disk_cache := FALSE;
        syv$perf_keypoints_enabled.command_keypoints := FALSE;
        osp$fetch_locked_variable (osv$keypoint_control.lock, i);
        osp$set_locked_variable (osv$keypoint_control.lock, i, 0, actual, result);
      IFEND;
    IFEND;

    tmp$clear_lock (keypoint_lock);
  PROCEND osp$alert_keyp_cpu_state_chng;
?? TITLE := 'put_stuff_in_buffer', EJECT ??

  PROCEDURE put_stuff_in_buffer
    (    lpid: integer;
     VAR rb: ost$rb_keypoint_request);

    VAR
      cbo: integer,
      dp: ^cell,
      keypoint_page_fault_status: mmt$keypoint_page_fault_status,
      l: integer,
      mbs: integer,
      modl: integer,
      offset: integer,
      pkc: ^ost$processor_keypoint_control,
      pr: ost$read_register,
      sp: ^cell,
      status: syt$monitor_status,
      te: 0 .. 3,
      xl: integer;

    IF (NOT cl15_enabled) OR (osv$keypoint_enable = osc$kpt_test_mode) THEN
      RETURN;
    IFEND;

    l := #SIZE (rb.kpt);
    sp := #LOC (rb.kpt);
    mbs := osv$keypoint_control.max_pages * osv$page_size;

    i#mtr_disable_traps (te);

  /copy/
    BEGIN
      REPEAT
        IF osv$keypoint_control.termination_status <> osc$kp_term_not_stopped
              THEN
          EXIT /copy/;
        IFEND;
        pr.i := #read_register (osc$pr_keypoint_buffer_ptr);
        dp := pr.pva;
        IF (l MOD 8) <> 0 THEN
          modl := l + (8 - (l MOD 8));
        ELSE
          modl := l;
        IFEND;
        cbo := #offset (dp) - #offset (osv$keypoint_control.cpus
              [lpid].collector_pva);
        IF (mbs - cbo) >= modl THEN
          i#move (sp, dp, l);
          dp := #address (#ring (dp), #segment (dp), #offset (dp) + modl);
          pr.pva := dp;
          pr.fill := 0;
          #write_register (osc$pr_keypoint_buffer_ptr, pr.i);
          l := 0;
        ELSE
          xl := mbs - cbo;
          IF xl > 0 THEN
            i#move (sp, dp, xl);
            dp := #address (#ring (dp), #segment (dp), #offset (dp) + xl);
            pr.pva := dp;
            pr.fill := 0;
            #write_register (osc$pr_keypoint_buffer_ptr, pr.i);
            l := l - xl;
            sp := #address (#ring (sp), #segment (sp), #offset (sp) + xl);
          IFEND;
          pkc := ^osv$keypoint_control.cpus [lpid];
          offset := #offset (pkc^.collector_pva) + (osv$keypoint_control.max_pages * osv$page_size);
          osp$process_keypoint_page_fault (offset, keypoint_page_fault_status);
          IF keypoint_page_fault_status <> mmc$kpfs_normal THEN
            rb.status.normal := FALSE;
            EXIT /copy/;
          IFEND;
        IFEND;
      UNTIL l = 0;
    END /copy/;
    i#mtr_restore_traps (te);
  PROCEND put_stuff_in_buffer;
?? OLDTITLE, OLDTITLE ??
MODEND osm$monitor_keypoint_support
*DECK DECK=OSM$MULTIPRO_INTERFACE_R1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE OS : Ring One Multiprocessing Options Handler' ??
MODULE osm$multipro_interface_r1;

{ PURPOSE:
{   This module contains the Ring 1 procedures that set up multiprocessing and allows for the manipulation of
{   jobs by several processors.  All of these procedures are called from Ring 3 procedures of approximately
{   the same name contained in the deck 'osm$multipro_interface_r3'.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH ( LISTEXT := ON ) ??
*copyc ose$multipro_exceptions
*copyc ost$cpu_definitions
*copyc osc$multiprocessor_constants
*copyc oss$job_fixed
*copyc pmt$processor_descriptions
?? POP ??
*copyc jmp$get_ijle_p
*copyc osp$set_status_abnormal
*copyc pmp$cycle
*copyc pmp$delay
*copyc pmp$find_executing_task_xcb
*copyc pmp$get_executing_task_gtid
*copyc mmp$job_multiprocessing_control
?? EJECT ??
*copyc mtv$cst0
*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc mtv$dual_state_cpu_number
*copyc mtv$scb
*copyc osv$170_os_type
*copyc osv$keypoint_control
*copyc osv$cpus_physically_configured
*copyc tmv$dedicate_a_cpu_to_nos
*copyc tmv$ptl_p
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

{  This variable should be defined locally when system generator supports sections properly.

  VAR
    job_xcb_list: [XREF, oss$job_fixed] RECORD
      head: ^ost$execution_control_block,
      lock: ost$signature_lock,
    RECEND;
?? OLDTITLE ??
?? NEWTITLE := 'add_processor_r1', EJECT ??

{ PURPOSE:
{   This procedure will allow a task to add the processor that it needs to execute on.  If the processor that
{   is chosen is DOWN or OFF, an error status is returned.  If the task is not a maintenance-class task and
{   the processor chosen is ON but only available for maintenance-class tasks, an error status is returned.
{   Once a task has added a processor to run on, its child tasks will inherit its processor selection until
{   they select their own processor selection.

  PROCEDURE add_processor_r1
    (    processor_id: ost$processor_id;
     VAR status: ost$status);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      processor_selections: ost$processor_id_set,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;

    IF processor_id > (osv$cpus_physically_configured - 1) THEN
      osp$set_status_abnormal ('OS', ose$processor_not_defined, 'ADD_PROCESSOR', status);
      RETURN;
    IFEND;

    pmp$find_executing_task_xcb (xcb_p);
    jmp$get_ijle_p (tmv$ptl_p^ [xcb_p^.global_task_id.index].ijl_ordinal, ijle_p);
    IF ijle_p^.job_scheduler_data.job_class = jmc$maintenance_job_class THEN
      processor_selections := mtv$scb.cpus.logically_on;
    ELSE
      processor_selections := mtv$scb.cpus.available_for_use;
    IFEND;

    IF (mtv$cst0 [processor_id].processor_state <> cmc$on) OR NOT (processor_id IN processor_selections) THEN
      osp$set_status_abnormal ('OS', ose$processor_not_on, 'ADD_PROCESSOR', status);
      RETURN;
    IFEND;

    { The following checks are to eliminate the possibility of a task in which keypoints are active adding a
    { processor which keypoints are NOT being collected on.  The first check is for jobs/tasks which have made
    { processor selections prior to activating keypoints.  The second check is for jobs/tasks which have made
    { no prior processor selections.

    IF xcb_p^.keypoint_enable AND (osv$keypoint_control.mpo <> osc$keypoints_multi_processor) THEN
      IF (osv$keypoint_control.processor_select_flag AND
            NOT (processor_id IN osv$keypoint_control.processor_selections)) OR
            ((processor_id < osv$keypoint_control.first_active_processor) OR
            (processor_id > osv$keypoint_control.last_active_processor)) THEN
        osp$set_status_abnormal ('OS', ose$keypoint_not_active_on_proc, 'ADD PROCESSOR', status);
        RETURN;
      IFEND;
    IFEND;

    xcb_p^.requested_processor_selections :=
          xcb_p^.requested_processor_selections + $ost$processor_id_set [processor_id];
    xcb_p^.processor_selections := xcb_p^.processor_selections + $ost$processor_id_set [processor_id];
    pmp$cycle (status);

  PROCEND add_processor_r1;
?? OLDTITLE ??
?? NEWTITLE := 'remove_processor_r1', EJECT ??

{ PURPOSE:
{   This procedure will allow a task to remove the processor that it no longer needs to execute on.

  PROCEDURE remove_processor_r1
    (    processor_id: ost$processor_id;
     VAR status: ost$status);

    VAR
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_xcb (xcb_p);
    IF (osv$170_os_type <> osc$ot7_none) AND tmv$dedicate_a_cpu_to_nos AND
          (xcb_p^.processor_selections - $ost$processor_id_set [processor_id] =
          $ost$processor_id_set [mtv$dual_state_cpu_number]) THEN
      osp$set_status_abnormal ('OS', ose$processor_not_on, 'REMOVE_PROCESSOR', status);
      RETURN;
    IFEND;

    xcb_p^.requested_processor_selections :=
          xcb_p^.requested_processor_selections - $ost$processor_id_set [processor_id];
    xcb_p^.processor_selections := xcb_p^.processor_selections - $ost$processor_id_set [processor_id];
    pmp$cycle (status);

  PROCEND remove_processor_r1;
?? OLDTITLE ??
?? NEWTITLE := 'jmp$get_multipro_options_r1', EJECT ??

  PROCEDURE [XDCL, #GATE] jmp$get_multipro_options_r1
    (VAR multipro_toggled: boolean;
     VAR status: ost$status);

    status.normal := TRUE;
    multipro_toggled := jmv$jcb.ijle_p^.multiprocessing_allowed;

  PROCEND jmp$get_multipro_options_r1;
?? OLDTITLE ??
?? NEWTITLE := 'jmp$set_multi_processing_r1', EJECT ??

{ PURPOSE:
{   This procedure allows a job to specify whether it's tasks may be multi-processed (execute simultaneously
{   on different processors).  The basic procedure changes the 'multiprocessing_allowed' field in the JCB.
{   The first parameter specifies whether the next state of multiprocessing for a job should be on or off.
{   The second parameter specifies the new set of processors to be used for the job.

  PROCEDURE [XDCL, #GATE] jmp$set_multiprocessing_r1
    (    new_multiprocessing_state: ost$name;
         processor_id_set: ost$processor_id_set;
     VAR status: ost$status);

    VAR
      id: ost$global_task_id,
      processor_id: ost$processor_id,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$get_executing_task_gtid (id);

    { Enforce job monitor task execution.

    IF id <> jmv$jcb.job_monitor_id THEN
      osp$set_status_abnormal ('OS', ose$not_called_by_job_monitor, 'SET_MULTIPROCESSING_OPTIONS', status);
      RETURN;
    IFEND;

    { Find the execution control block for the task.

    pmp$find_executing_task_xcb (xcb_p);

    { Insure no child tasks are alive.

    IF (xcb_p^.link <> NIL) OR (job_xcb_list.head <> xcb_p) THEN
      osp$set_status_abnormal ('OS', ose$job_has_active_child_tasks,
            'cannot change multiprocessing permission', status);
      RETURN;
    IFEND;

    { Check desired multiprocessing state.

    IF new_multiprocessing_state (1, 3) = 'OFF' THEN
      jmv$jcb.ijle_p^.multiprocessing_allowed := FALSE;
      mmp$job_multiprocessing_control (FALSE, status);
    ELSE
      jmv$jcb.ijle_p^.multiprocessing_allowed := TRUE;
      mmp$job_multiprocessing_control (TRUE, status);
    IFEND;

    IF processor_id_set = $ost$processor_id_set[] THEN
      RETURN;
    IFEND;

    { If specified, add the desired processors.

    FOR processor_id := 0 TO osc$maximum_processor_id DO
      IF processor_id IN processor_id_set THEN
        add_processor_r1 (processor_id ,status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    { Remove the undesired processors.  The above loop must be executed first, so there exists a processor
    { to run this code!

    FOR processor_id := 0 TO osc$maximum_processor_id DO
      IF NOT (processor_id IN processor_id_set) THEN
        remove_processor_r1 (processor_id ,status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND jmp$set_multiprocessing_r1;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$select_processors_w_divide1', EJECT ??

{ PURPOSE:
{   This procedure is called when an UNIMPLEMENTED INSTRUCTION fault occurs on a vector divide instruction
{   and the task may have been executing on a CPU that has had the divide unit degraded. This procedure will
{   change the processor selections so that the task will execute only on CPUs that do not have a degraded
{   divide unit.  This procedure is called (thru the ring 3 interface procedure) directly from the assembly
{   language job trap handler.  A boolean is returned that indicates if the processor switch was successful.
{   Keypoint selection by current job may prevent processor switch.  Switch will also fail if all active
{   processors have degraded divide units.

  PROCEDURE [XDCL, #GATE] osp$select_processors_w_divide1
     (VAR switched: boolean);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      local_status: ost$status,
      new_selections: ost$processor_id_set,
      xcb_p: ^ost$execution_control_block;

    switched := FALSE;
    pmp$find_executing_task_xcb (xcb_p);
    jmp$get_ijle_p (tmv$ptl_p^ [xcb_p^.global_task_id.index].ijl_ordinal, ijle_p);
    IF ijle_p^.job_scheduler_data.job_class = jmc$maintenance_job_class THEN
      new_selections := mtv$scb.cpus.logically_on - mtv$scb.vector_simulation_control.vector_divide_degraded;
    ELSE
      new_selections := mtv$scb.cpus.available_for_use -
            mtv$scb.vector_simulation_control.vector_divide_degraded;
    IFEND;
    IF new_selections = $ost$processor_id_set [] THEN
      RETURN;
    IFEND;

    IF (osv$170_os_type <> osc$ot7_none) AND tmv$dedicate_a_cpu_to_nos AND
          (new_selections = $ost$processor_id_set [mtv$dual_state_cpu_number]) THEN
      RETURN;
    IFEND;

    { The following checks are to eliminate the possibility of a task in which keypoints are active selecting
    { a processor which keypoints are NOT being collected on.  The check is for jobs/tasks which have made
    { processor selections prior to activating keypoints.

    IF xcb_p^.keypoint_enable AND
          (new_selections - xcb_p^.processor_selections <> $ost$processor_id_set []) THEN
      RETURN;
    IFEND;

    switched := TRUE;
    xcb_p^.requested_processor_selections := new_selections;
    xcb_p^.processor_selections := new_selections;
    pmp$delay (20, local_status);     {Force switch to new processor}

  PROCEND osp$select_processors_w_divide1;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$deselect_processor_r1', EJECT ??

{ PURPOSE:
{   This procedure is used to negate a previous request for execution on a specific processor.  The requesting
{   task is allowed to execute on any available processor.  If no processor selection is currently active for
{   the requesting task, an error will be returned.

  PROCEDURE [XDCL, #GATE] pmp$deselect_processor_r1
    (VAR status: ost$status);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_xcb (xcb_p);

    IF xcb_p^.processor_selections = - $ost$processor_id_set [] THEN
      osp$set_status_abnormal ('OS', ose$no_processor_selected, 'DESELECT_PROCESSOR', status);
      RETURN;
    IFEND;

    { The following checks are to eliminate the possibility of a task in which keypoints are active
    { deselecting a processor.

    IF xcb_p^.keypoint_enable AND (osv$keypoint_control.mpo <> osc$keypoints_multi_processor) THEN
      osp$set_status_abnormal ('OS', ose$keypoint_active_on_proc, 'DESELECT PROC', status);
      RETURN;
    IFEND;

    xcb_p^.requested_processor_selections := $ost$processor_id_set [ ];

    jmp$get_ijle_p (tmv$ptl_p^ [xcb_p^.global_task_id.index].ijl_ordinal, ijle_p);
    IF ijle_p^.job_scheduler_data.job_class = jmc$maintenance_job_class THEN
      xcb_p^.processor_selections := mtv$scb.cpus.logically_on;
    ELSE
      xcb_p^.processor_selections := mtv$scb.cpus.available_for_use;
    IFEND;

  PROCEND pmp$deselect_processor_r1;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_processor_descrip_r1', EJECT ??

{ PURPOSE:
{   This procedure is used to get the id's, serial numbers, model numbers, and states of all the processors
{   configured on the mainframe.

  PROCEDURE [XDCL, #GATE] pmp$get_processor_descrip_r1
    (VAR processor_descriptions: pmt$processor_descriptions;
     VAR status: ost$status);

    VAR
      index: 0 .. osc$max_number_of_processors;

    status.normal := TRUE;
    processor_descriptions.count := osv$cpus_physically_configured;
    FOR index := 0 TO (processor_descriptions.count - 1) DO
      processor_descriptions.processor [index].id := mtv$cst0 [index].cst_index;
      processor_descriptions.processor [index].element_id := mtv$cst0 [index].element_id;
      processor_descriptions.processor [index].state := mtv$cst0 [index].processor_state;
    FOREND;

  PROCEND pmp$get_processor_descrip_r1;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$select_processor_r1', EJECT ??

{ PURPOSE:
{   This procedure can be used only by maintenance-class tasks.  It will allow a task to select the processor
{   that it needs to execute on, and it may also be used to change a previous selection.  If the processor
{   that is chosen is DOWN, OFF, or DEDICATED TO NOS, an error status is returned.  If the task is not a
{   maintenance-class task and the processor chosen is ON but only available for maintenance-class tasks, an
{   error status is returned.  Once a task has selected a processor to run on, its child tasks will inherit
{   its processor selection until they do their own PMP$SELECT_PROCESSOR.

  PROCEDURE [XDCL, #GATE] pmp$select_processor_r1
    (    processor_id: ost$logical_processor_id;
     VAR status: ost$status);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      processor_selections: ost$processor_id_set,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;

    IF processor_id > (osv$cpus_physically_configured - 1) THEN
      osp$set_status_abnormal ('OS', ose$processor_not_defined, 'SELECT_PROCESSOR', status);
      RETURN;
    IFEND;

    pmp$find_executing_task_xcb (xcb_p);
    jmp$get_ijle_p (tmv$ptl_p^ [xcb_p^.global_task_id.index].ijl_ordinal, ijle_p);
    IF ijle_p^.job_scheduler_data.job_class = jmc$maintenance_job_class THEN
      processor_selections := mtv$scb.cpus.logically_on;
    ELSE
      processor_selections := mtv$scb.cpus.available_for_use;
    IFEND;

    IF (mtv$cst0 [processor_id].processor_state <> cmc$on) OR
          ((osv$170_os_type <> osc$ot7_none) AND tmv$dedicate_a_cpu_to_nos AND
          ($ost$processor_id_set [processor_id] = $ost$processor_id_set [mtv$dual_state_cpu_number])) OR
          NOT (processor_id IN processor_selections) THEN
      osp$set_status_abnormal ('OS', ose$processor_not_on, 'SELECT_PROCESSOR', status);
      RETURN;
    IFEND;

    { The following checks are to eliminate the possibility of a task in which keypoints are active selecting
    { a processor which keypoints are NOT being collected on.  The first check is for jobs/tasks which have
    { made processor selections prior to activating keypoints.  The second check is for jobs/tasks which have
    { made no prior processor selections.

    IF xcb_p^.keypoint_enable AND (osv$keypoint_control.mpo <> osc$keypoints_multi_processor) THEN
      IF (osv$keypoint_control.processor_select_flag AND
            NOT (processor_id IN osv$keypoint_control.processor_selections)) OR
            ((processor_id < osv$keypoint_control.first_active_processor) OR
            (processor_id > osv$keypoint_control.last_active_processor)) THEN
        osp$set_status_abnormal ('OS', ose$keypoint_not_active_on_proc, 'SELECT PROCESSOR', status);
        RETURN;
      IFEND;
    IFEND;

    xcb_p^.requested_processor_selections := $ost$processor_id_set [processor_id];
    xcb_p^.processor_selections := $ost$processor_id_set [processor_id];
    pmp$delay (20, status);

  PROCEND pmp$select_processor_r1;
?? OLDTITLE ??
MODEND osm$multipro_interface_r1
*DECK DECK=OSM$MULTIPRO_INTERFACE_R3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE OS : Intermediate Calls For Multiprocessing' ??
MODULE osm$multipro_interface_r3;

{ PURPOSE:
{   This module contains the calls to the procedures that set up and display the multiprocessing environment.
{   This module also contains procedures for selecting processor for execution.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc pmk$keypoints
?? POP ??
*copyc jmp$get_multipro_options_r1
*copyc jmp$set_multiprocessing_r1
*copyc osp$select_processors_w_divide1
*copyc osp$verify_system_privilege
*copyc pmp$deselect_processor_r1
*copyc pmp$get_processor_descrip_r1
*copyc pmp$select_processor_r1
?? OLDTITLE ??
?? NEWTITLE := 'jmp$get_multipro_options_r3', EJECT ??
  PROCEDURE [XDCL, #GATE] jmp$get_multipro_options_r3
    (VAR multipro_toggled: boolean;
     VAR status: ost$status);

    status.normal := TRUE;
    jmp$get_multipro_options_r1 (multipro_toggled, status);

  PROCEND jmp$get_multipro_options_r3;
?? OLDTITLE ??
?? NEWTITLE := 'jmp$set_multiprocessing_r3', EJECT ??
  PROCEDURE [XDCL, #GATE] jmp$set_multiprocessing_r3
    (    multiprocessing_state: ost$name;
         processor_id_set: ost$processor_id_set;
     VAR status: ost$status);

    status.normal := TRUE;
    jmp$set_multiprocessing_r1 (multiprocessing_state, processor_id_set, status);

  PROCEND jmp$set_multiprocessing_r3;
?? OLDTITLE ??
?? NEWTITLE := 'osp$select_processors_w_divide', EJECT ??
  FUNCTION [XDCL, #GATE, UNSAFE] osp$select_processors_w_divide: boolean;

   VAR
     switched: boolean;

    osp$verify_system_privilege;
    osp$select_processors_w_divide1 (switched);
    osp$select_processors_w_divide := switched;

  FUNCEND osp$select_processors_w_divide;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$deselect_processor', EJECT ??
  PROCEDURE [XDCL, #GATE] pmp$deselect_processor
    (VAR status: ost$status);

    #keypoint (osk$entry, 0, pmk$deselect_processor);
    status.normal := TRUE;
    pmp$deselect_processor_r1 (status);
    #keypoint (osk$exit, 0, pmk$deselect_processor);

  PROCEND pmp$deselect_processor;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_processor_descriptions', EJECT ??
  PROCEDURE [XDCL, #GATE] pmp$get_processor_descriptions
    (VAR processor_descriptions: pmt$processor_descriptions;
     VAR status: ost$status);

    status.normal := TRUE;
    pmp$get_processor_descrip_r1 (processor_descriptions, status);

  PROCEND pmp$get_processor_descriptions;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$select_processor', EJECT ??
  PROCEDURE [XDCL, #GATE] pmp$select_processor
    (    id: ost$logical_processor_id;
     VAR status: ost$status);

    #keypoint (osk$entry, 0, pmk$select_processor);
    status.normal := TRUE;
    pmp$select_processor_r1 (id, status);
    #keypoint (osk$exit, 0, pmk$select_processor);

  PROCEND pmp$select_processor;
?? OLDTITLE ??
MODEND osm$multipro_interface_r3
*DECK DECK=OSM$NATURAL_LANGUAGE_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Get / Set Natural Language Interfaces' ??
MODULE osm$natural_language_manager;

{
{  PURPOSE:
{    This module contains the ring 3 code to process the natural language.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc clt$environment_object_size
*copyc clt$env_object_pop_reason
*copyc ose$message_gen_exceptions
*copyc ost$natural_language
*copyc ost$status
?? POP ??
*copyc clp$clear_message_cache
*copyc clp$validate_name
*copyc osp$find_natural_language
*copyc osp$set_status_abnormal
?? TITLE := 'osp$eo_size_natural_language', EJECT ??

  FUNCTION [XDCL] osp$eo_size_natural_language: clt$environment_object_size;


    osp$eo_size_natural_language := #SIZE (ost$natural_language);

  FUNCEND osp$eo_size_natural_language;
?? TITLE := 'osp$eo_init_natural_language', EJECT ??

  PROCEDURE [XDCL] osp$eo_init_natural_language
    (    object: ^clt$environment_object_contents);

    VAR
      natural_language: ^ost$natural_language;


    natural_language := object;

    natural_language^ := osc$default_natural_language;

  PROCEND osp$eo_init_natural_language;
?? TITLE := 'osp$eo_pop_natural_language', EJECT ??

  PROCEDURE [XDCL] osp$eo_pop_natural_language
    (    pop_reason: clt$env_object_pop_reason;
         object: ^clt$environment_object_contents;
         object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);


    status.normal := TRUE;

    clp$clear_message_cache;

  PROCEND osp$eo_pop_natural_language;
?? TITLE := 'osp$set_natural_language', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$set_natural_language
    (    natural_language: ost$natural_language;
     VAR status: ost$status);

    VAR
      name_is_valid: boolean,
      natural_language_ptr: ^ost$natural_language,
      validated_name: ost$name;


    status.normal := TRUE;

    clp$validate_name (natural_language, validated_name, name_is_valid);
    IF NOT name_is_valid THEN
      osp$set_status_abnormal ('OS', ose$bad_natural_language, natural_language, status);
      RETURN;
    IFEND;

    osp$find_natural_language (natural_language_ptr);

    IF validated_name = natural_language_ptr^ THEN
      RETURN;
    IFEND;

    clp$clear_message_cache;

    natural_language_ptr^ := validated_name;

  PROCEND osp$set_natural_language;
?? TITLE := 'osp$get_natural_language', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_natural_language
    (VAR natural_language: ost$natural_language;
     VAR status: ost$status);

    VAR
      natural_language_ptr: ^ost$natural_language;


    status.normal := TRUE;

    osp$find_natural_language (natural_language_ptr);

    natural_language := natural_language_ptr^;

  PROCEND osp$get_natural_language;

MODEND osm$natural_language_manager;
*DECK DECK=OSM$OS_ENVIRONMENT_MONITOR EXPAND=TRUE
osm$os_environment_monitor IDENT
         list      1,1,0
         title     c'OS environment monitor routine'
         space     4
.        TRADE SECRET - PROPRIETARY NOTICE.
.        COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
.        The material contained herein is the property of Control Data
.        Systems Inc and is intended soley for use in the  performance
.        of  contracted  Maintenance  under a Control Data maintenance
.        services agreement.  This material is proprietary to  Control
.        Data  Systems Inc  and  is  not to be disclosed other than to
.        employees  of  Control  Data  Systems Inc  or  other  persons
.        specifically authorized to have access to  this  material  in
.        accordance  with  the  terms and conditions of a Control Data
.        maintenance services agreement.
         page
*copy asmregs
*copy osa$dual_state_control_block
*copy osa$ei_interface_constants
*copy osa$ei_constant_definitions
*copy osa$ei_stack_frame
*copyc sya$xp_and_sf_constants
         page
C180EI   SECTION   working,read+execute+write,,0,8
         USE       C180EI
         space     4
..
.        monitor_mode_ei

         def       osp$monitor_mode_ei
osp$monitor_mode_ei   bss   0
         tpage     x1,a_jps
         ente      x2,r_jps            .jps register
         cpyxs     x1,x2               .update jps
         la        a_nos,a_static,pva_of_os
         PAGE
..
.        PMC        - PROCESS MONITOR CONDITION
.        THIS ROUTINE GAINS CONTROL AS  THE  RESULT  OF  AN  INTERRUPT
.        CONDITION  OCCURRING  IN  THE  C170  VIRTUAL  MACHINE.  THESE
.        INTERRUPTS CAUSE AN EXCHANGE TO OCCUR,  FORCING  THE  MACHINE
.        INTO  THE  MONITOR  STATE  OF THE C180 VIRTUAL MACHINE.  THIS
.        ROUTINE MUST DETERMINE WHAT ERROR CONDITION HAS OCCURRED  AND
.        SIMULATE THE ACTION THAT WOULD BE TAKEN BY C170 HARDWARE.
.
.        ENTRY-     REGISTERS AS DEFINED BY (TMXP)
.
.                   C170 ENVIORNMENT AT THE TIME OF INTERRUPT
.                   CONTAINED IN C180 EXCHANGE PACKAGE TJXP
.
.
PMC      BSS       0
         ENTP      X1,1
         sbyts,1   x1,a_jps,x0,xp_vmid
         entp      x1,2
         SBYTS,1   X1,a_jps,X0,xp_tef  .SET TRAP ENABLES
pmc01    BSS       0
         ENTP      X3,0                .CLEAR X3
         SBYTS,2   X3,a_jps,X0,xp_mcr  .CLEAR MCR
         SBYTS,2   X3,a_jps,X0,xp_ucr  .CLEAR UCR
pmc02    EXCHANGE                      .EXCHANGE TO C180 JOB PROCESS
         CPYAX     X1,a_jps
         PURGE     X1,7                .PURGE CACHE FOR EI SEGMENT
         la        a_dscb,a_static,pva_of_dscb  .fetch dscb pointer
         lbyts,1   x4,a_jps,x0,xp_vmid .get VMID from JPS
         LBYTS,2   X5,a_jps,X0,xp_mcr  .GET MCR OF PROCESS CAUSING  XJ

         shfx      x6,x5,x0,48
         addpxq    a8,x0,pmc03         .exit address if no retry.
         addpxq    a7,x0,pmc01         .exit address when retry
         ente      x3,c170_due
         brxgt     x0,x6,attempt_retry .if DUE set, attempt retry.
.
.        Check if cyber 180 system call.
.
pmc03    ente      x6,mcr_mask
         andx      x6,x5               .clear unimportant bits from MCR
         ente      x1,bit_58
         brrne     x1,x6,pec00         .if not a system call
         brrne     x4,x0,pmc01         .if not C180 system call, ignore interrupt
.
.        PROCESS EXCHANGE REQUEST AS PER REQUEST NUMBER IN JOB'S X0.
.
pmc04    LBYTS,8   X1,a_jps,X0,xp_x0   .GET REQUEST CODE
         ENTE      X2,EIRQC
         BRREQ     X2,X1,pec01         .IF A170 ERROR REQUEST
         ENTE      X2,MTRR#STD         .AWAIT C180 DST REQUEST CODE
         brreq     x2,x1,state_switch  .if deadstart request
         entp      x2,mtrr#ihf
         brreq     x2,x1,ihf           .if inject hardware fault request

.        The 'donothing' request is not checked for.  That and unknown monitor
.        requests fall through to 'stop170'.

.
.        THE  C170  VIRTUAL MACHINE WAS EXECUTING IN MONITOR MODE WHEN
.        THE EXIT CONDITION OCCURRED.  ALL C170 ERRORS  OF  THIS  TYPE
.        CAUSE THE C170 CPU TO STOP, AND THEREFORE WE WILL END IT HERE
.        BY HANGING THE C180 CPU.
.
STOP170  BSS       0
         la        a7,a_static,pva_halt_ei
         brdir     a7,x0
         page
..
.        attempt_retry - check if process is retryable and retry it if
.          retry count is not exceeded.
.
.        ENTRY -   A_DSCB = PVA of EICB.
.                  A_JPS = address of exchange package or stack frame save area that
.                          got DUE.
.                  A7 = return address if retry is attempted.
.                  A8 = return address if no retry attempted.
.                  X3 = source of DUE error, cyber 170 or cyber 180.
.
.

attempt_retry bss  0
         purge     x0,2                .purge all of cache to clear cache
.                                       parity errors.
         purge     x0,15               .purge all maps too.
         lx        x6,a_dscb,d7ty      .fetch 170 interface level
         isob      x6,x6,x0,52*64+5
         entp      x1,if_versn
         brrgt     x1,x6,rty04         .if interface level less than 2
         entp      x0,3                .process not damaged bit
         lbit      x6,a_jps,xp_pnd,x0
         entp      x2,0                .clear retry count
         brreq     x6,x0,rty02         .if process damaged
         incr      x3,retry_failed
         lx        x6,a_jps,xp_p/8*8
         lbyts,4   x1,a_wrk,x0,sf_retry+4  .byte offset of previous retry
         brrne     x1,x6,rty01         .if different pva
         lbyts,4   x2,a_wrk,x0,sf_retry  .current retry count
rty01    incr      x2,1                .increment retry count
         sbyts,4   x2,a_wrk,x0,sf_retry
         sbyts,4   x6,a_wrk,x0,sf_retry+4
         entp      x1,8                .maximum retry count
         brrgt     x2,x1,rty02         .if retry count exceeded
         cpyaa     a8,a7               .set retry return pva
         incr      x3,retry_due-retry_failed
.
rty02    entl      x0,11(16)           .get processor id
         cpysx     x6,x0
         addr      x6,x6               .multiply by 2
         addaq     a5,a_dscb,dscm
         cpyax     x1,a5
         purge     x1,3                .purge cache at error word in EICB.
         lbyts,1   x1,a5,x6,3
         brreq     x0,x1,rty03         .if no previous status
         brrge     x3,x1,rty04         .if previous error was worse
rty03    entp      x0,63-59            .Update the interface block
         lbset     x1,a5,x0
         brrne     x1,x0,rty03         .If interlock not set
         sbyts,1   x3,a_dscb,x6,dscm+3 .store status
         sbyts,1   x2,a_dscb,x6,dscm+2 .store retry count
         entp      x0,0
         sbyts,1   x0,a_dscb,x0,dscm   .clear interlock.
rty04    brdir     a8,x0               .continue processing
         page
..
.        state_switch - process a state switch to dual state mode.
.
.        This routine gains control as the result of a request from
.        a validated job in the C170 OS requesting a deadstart to dual
.        state mode.
.
state_switch bss   0
.
.        PROCESS THE HALT IN EI REQUEST FOR DUAL STATE DEADSTART.
.
         ADDAQ     a5,a_dscb,ds_flag
         CPYAX     X7,a5
         PURGE     X7,3
         tpage     x1,a_jps
         sbyts,4   x1,a_dscb,x0,os_jps .save jps rma
.
         ENTE      X5,CPUIDLS
         sbyts,1   x5,a_dscb,x0,ds_stat+3
         lbyts,4   xf,a5,x0,0          .fetch deadstart flag
         mulr      XF,XF
         sbyts,4   xf,a5,x0,0          .store response
.
idl01    PURGE     X7,3
         lbyts,4   x6,a5,x0,0
         BRRNE     X6,X0,idl01         .IF CONTINUE WITH IDLE
         entp      x1,1
         sbyts,1   x1,a_wrk,x0,xtra_xj .allow one extra state switch
         CPYAX     X7,a_jps
         PURGE     X7,3                .PURGE CACHE FOR EI SEGMENT
         BRREQ     X0,X0,pmc01         .RETURN TO EI JOB MODE
         page
..
.        PEC       - Process Error Conditions.
.
.
.
pec00    addpxq    a8,x0,pec02         .return address
         la        a7,a_static,pva_due_handler
         brdir     a7,x0
.
pec01    addpxq    a8,x0,pec02         .return address
         la        a7,a_static,pva_abort_job
         brdir     a7,x0
.
.        If this is concurrent C170 (both CPUs may run concurrently in C170
.        state), then the monitor mode interlock must be obtained before
.        continuing on.  The monitor mode interlock bit is defined either
.        in the segment descriptor table or in low core word 71(8), bit 4.
.        If the monitor mode interlock bit is defined in word 71(8), bit 4,
.        then bit 5 must first be checked to see if the second CPU is
.        actually in use.  Otherwise, setting the interlock bit could cause
.        problems in NOS/BE.
.
pec02    lbyts,1   x7,a_static,x0,dual_170
         brreq     x7,x0,pmc           .if not on a concurrent C170
         entp      x1,1
         brreq     x7,x1,pec04         .if monitor mode bit in SDT
.
.        The monitor mode bit is defined in low core word 71(8), bit 4.
.
         addaq     a7,a_nos,eicb_ptr*8
         entp      x0,5                .check bit 5 to see if second CPU in use
         lbit      x1,a7,0,x0
         brreq     x1,x0,pmc           .if second CPU not in use
pec03    entp      x0,4                .check bit 4
         lbset     x1,a7,x0
         brrne     x1,x0,pec03         .if monitor mode interlock not obtained
         PURGE     x0,2                 .purge all entries in cache
         brreq     x0,x0,pmc           .restart c170
.
.        The monitor mode bit is defined in the SDT.
.
pec04    lbyts,1   x7,a_jps,x0,xp_p+1  .fetch os segment number
         shfx      x7,x7,x0,3
         la        a7,a_static,pva_segment_table
         addax     a7,x7               .os segment table entry pva
pec05    entp      x0,2                .check bit 2
         lbset     x1,a7,x0
         brrne     x1,x0,pec05         .if monitor mode interlock not obtained


         brreq     x0,x0,pmc           .restart c170
         page
..
.        osp$mtr_trap_handler - processes traps in EI monitor mode.
.                  Currently the only errors processed are DUEs.
.                  Traps are disabled when trap handler is entered.
.

         def       osp$mtr_trap_handler
         align     0,16
osp$mtr_trap_handler bss 0
         entp      x0,0
         lbit      x3,a_psa,sfsa_mcr,x0  .DUE bit from MCR in SFSA.
         addpxq    a8,x0,trp02         .if no retry
         addpxq    a7,x0,trp01         .if attempt at retry
         brreq     x3,x0,trp02         .if not DUE.
         cpyaa     a_jps,a_psa         .address of SFSA with DUE.
         ente      x3,c180_due
         brreq     x0,x0,attempt_retry
.
trp01    entl      x0,r_ted
         cpyxs     x0,x0               .set tef and ted
         return
.
trp02    cpyaa     a0,a2               .update tos register
         pop
         entl      x0,r_te             .set tef
         cpyxs     x0,x0
         brreq     x0,x0,stop170       .bring things to a close
         page
..
.        IHF - inject hardware fault.  This procedure processes the inject
.        hardware fault monitor request to inject hardware faults in monitor
.        mode.
.
. DESIGN:
.   Special microcode is required that actually causes the desired hardware fault.
.   The special microcode recoginizes specific unimplemented instructions that are
.   issued and dependent on the J K fields causes a specific fault.  The J field
.   specifies the kind of hardware fault and the K field specifies an X register
.   that contains the RMA of a word in memory with a parity error.  This word in
.   memory has to be preconditioned with a parity error before IPL.
.
.        ENTRY:
.                  a_jps = PVA of job mode exchange package.
.                  X1 = Word 0 of monitor request.
.
.        INPUT (format of monitor request):
.                  Monitor request in X0 and X1 of job exchange package.
.                  X0 = 16/0
.                       8/traps enabled, = 0 implies traps disabled, = 1 implies traps
.                         enabled.
.                       8/fault kind.  A fault kind of 80(16) or greater is a request
.                         to perform some subfunction.  These subfunctions are:
.                         = 80(16) - clear synchronous bits in monitor mask register
.                                    of job exchange package.
.                       32/monitor request code.
.                  X1 = RMA of parity error.
.
.        EXIT:
.                  Specified fault is caused.
.                  Error status is returned in X2 of job exchange package.  Non zero
.                  value implies an error.
.

ihf      bss       0                   .Entry.
         lbyts,8   xe,a_jps,x0,xp_x0+8  .RMA of parity error.
         isob      x5,x1,x0,(24*64)+7  .Fault kind.
         ente      xa,80(16)
         isob      x6,x1,x0,(16*64)+7  .Traps enabled flag.
         brrge     x5,xa,ihf25         .If subfunction request.
         shfc      x5,x5,x0,1          .(jump table index)/2.
         ente      xa,ihfpl            .jump table length.
         entp      x7,1                .Set error status.
         brrgt     x5,xa,ihf20         .If unknown hardware fault kind.
ihf5     bss     0
         brrne     x6,x0,ihf10         .If traps enabled.
         entl      x0,r_td             .Disable traps.
         cpyxs     x0,x0
ihf10    bss       0
         addpxq    aa,x5,ihfp          .address in jump table to process
                                       . hardware fault kind.
         entp      x7,0                .Set no error.
         brdir     aa,x0               .cause specified hardware fault.

.        Fault injection processors return here if control returned after
.        error injected.

ihf15    bss       0
         brrne     x6,x0,ihf20         .If traps enabled.
         entl      x0,r_te             .Reenable traps.
         cpyxs     x0,x0
ihf20    bss       0
         sbyts,8   x7,a_jps,x0,xp_x0+(2*8)  .Return error status in X2.
         brreq     x0,x0,pmc01         .Return to job.

.        Process subfunction requests.
.
.        ENTRY:
.                  a_jps = PVA of job mode exchange package.
.                  X5 = subfunction request code.
.
.        EXIT:
.                  Subfunction processed.
.

ihf25    bss       0
         ente      xa,80(16)
         entp      x7,1                .Set error.
         brrne     x5,xa,ihf20         .If not known subfunction request.

.        Process subfunction to clear synchronous bits in calling task's
.        exchange package.

         lbyts,2   xa,a_jps,x0,xp_mm   .Monitor mask from job exchange package.
         ente      x9,ihfa
         inhx      xa,x9               .Clear synchronous bits in monitor mask.
         entp      x7,0                .Set no error.
         sbyts,2   xa,a_jps,x0,xp_mm   .Update monitor mask in job exchange package.
         brreq     x0,x0,ihf20         .Return.


.        Define synchronous bits in the monitor mask register.

ihfa     equ       bit_48+bit_49+bit_51+bit_52+bit_54+bit_55+bit_60+bit_61

.        Define a jump table for each hardware fault kind to cause.

ihfp     bss       0
         brreq     x0,x0,retry         .cause successful retry.
         brreq     x0,x0,exchange      .cause exchange fault.
         brreq     x0,x0,itrap         .cause trap fault.
         brreq     x0,x0,halt          .cause halt fault.
         brreq     x0,x0,pdm_halt      .cause pdm halt fault.
         brreq     x0,x0,swerr         .software error, error stop.
ihfpl    equ       $-ihfp              .length of jump table.

.        Cause successful retry error.

retry    bss     0
         vfd,32    0fd0e0000(16)       .condition microcode.
         vfd,32    0fe0e0000(16)       .cause hardware fault.
         brreq     x0,x0,ihf15         .Return.

.        Cause exchange error.

exchange bss     0
         vfd,32    0fd1e0000(16)       .condition microcode.
         vfd,32    0fe1e0000(16)       .cause hardware fault.
         brreq     x0,x0,ihf15         .Return.

.        Cause trap error.

itrap    bss     0
         vfd,32    0fd2e0000(16)       .condition microcode.
         vfd,32    0fe2e0000(16)       .cause hardware fault.
         brreq     x0,x0,ihf15         .Return.

.        Cause halt error.

halt     bss     0
         vfd,32    0fd3e0000(16)       .condition microcode.
         vfd,32    0fe3e0000(16)       .cause hardware fault.
         brreq     x0,x0,ihf15         .Return.

.        Cause PDM halt error.

pdm_halt bss     0
         vfd,32    0fd4e0000(16)       .condition microcode.
         vfd,32    0fe4e0000(16)       .cause hardware fault.
         brreq     x0,x0,ihf15         .Return.

.        Cause software error, error stop.

swerr    bss     0
         halt
         brreq     x0,x0,ihf15         .Return.

.
         END
*DECK DECK=OSM$OS_TRAP_HANDLER EXPAND=TRUE
osm$os_trap_handler        IDENT
         list      1,1,0
         title     c'Environment Interface trap handler for the OS'
         space     4
.        TRADE SECRET - PROPRIETARY NOTICE.
.        COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
.        The material contained herein is the property of Control Data
.        Systems Inc and is intended soley for use in the  performance
.        of  contracted  Maintenance  under a Control Data maintenance
.        services agreement.  This material is proprietary to  Control
.        Data  Systems Inc  and  is  not to be disclosed other than to
.        employees  of  Control  Data  Systems Inc  or  other  persons
.        specifically authorized to have access to  this  material  in
.        accordance  with  the  terms and conditions of a Control Data
.        maintenance services agreement.
         page
*copy asmregs
*copy osa$dual_state_control_block
*copy osa$ei_interface_constants
*copy osa$ei_constant_definitions
*copy osa$ei_stack_frame
*copyc osa$dft_constants
*copy sya$xp_and_sf_constants
         PAGE
C180EI   SECTION   working,read+execute+write,,0,8
         USE       C180EI
         space     4
...
.        trap       - TRAP INTERRUPT PROCESSOR.
.
.        THIS  SUBROUTINE  GAINS  CONTROL IN C180 PROGRAM STATE AS THE
.        RESULT OF A UCR TRAP FROM  A  C170  PROCESS.   THE  (UCR)  IS
.        AQUIRED  AND  A  TEST  IS  MADE  TO DETERMINE IF THE TRAP WAS
.        CAUSED BY AN UNIMPLEMENTED INSTRUCTION (BIT 49 IN  THE  UCR).
.        IF SO, A BRANCH IS MADE TO THE CMU INSTRUCTION SIMULATOR.  IF
.        NOT,  THE PROCESS INTERVAL TIMER (PIT) BIT IS TESTED.  IF THE
.        PIT BIT (BIT 51)  IS  CLEAR,  THE  TRAPPED  ROUTINE  WILL  BE
.        ABORTED  WITH  THE  GENERAL ERROR CODE OF 67(8).  IF SET, THE
.        (PIT) IS RESET TO ALL ONES AND A RETURN TO THE  C170  PROCESS
.        IS  ACCOMPLISHED.   THE CMU INSTRUCTION SIMULATOR AND THE AOR
.        ROUTINE RETURN TO THIS SUBROUTINE  AT  TAG  trap3  WHERE  THE
.        P-REGISTER  IS  INCREMENTED,  X0  IS  STORED,  AND THE PIT IS
.        RESET.  THE ROUTINE PII EXITS VIA TAG trap5 WHICH ONLY RESETS
.        THE PIT AND DOES NOT INCREMENT P.  AFTER  THE  TRAP  TO  THIS
.        SUBROUTINE  OCCURS TRAPS ARE AUTOMATICALLY DISABLED, AND THEY
.        REMAIN DISABLED UNTIL THE RETURN BACK TO THE C170 PROCESS.
.
.        ENTRY-     (A2) = PVA OF TRAPPED PROCESS STACK FRAME SAVE AREA.
.
.        EXIT-      NONE.
.
.
         ALIGN     0,8                 .FORCE WORD BOUNDRY
         def       osp$os_trap_handler
osp$os_trap_handler  bss  0
trap     ENTL      X0,0
         la        a_nos,a_static,pva_of_os .SET a_nos TO OS PVA
         la        a_dscb,a_static,pva_of_dscb .set a_dscb to the dual state control block
         SBYTS,3   X0,A2,X0,xp_cb0     .CLEAR C170 B0 REGISTER
         lbyts,3   x_rac,a_psa,x0,xp_rac
         shfx      x_rac,x_rac,x0,3
         cpyaa     a_rac,a_nos
         addax     a_rac,x_rac
         cpyax     x_flc,a4
         LBYTS,2   X1,A2,X0,xp_ucr     .GET USER CONDITION REGISTER
         shfc      x2,x1,x0,48         .UCR bit 48
         BRXGT     X0,x2,PIF           .IF privilaged instruction fault
         shfc      x2,x1,x0,49         .UCR bit 49
         BRXGT     X0,x2,CIS           .IF UNIMPLEMENTED INSTRUCTION
         shfc      x2,x1,x0,51         .UCR bit 51
         BRXGT     X0,x2,trap5         .IF PROCESS INTERVAL TIMER
         EIMTRCAL  EIRQC,GENCODE       .ABORT JOB WITH GENERAL ERROR
.
trap2    entp      x1,1                .set ve not active bit
         shfx      x1,x1,x0,30
         iorx      x0,x1
trap3    SX        X0,A2,xp_cx0        .STORE USER X0 REGISTER
trap4    LA        A8,A2,xp_p          .INCREMENT AND STORE P-REGISTER
         ADDAQ     A8,A8,8
         SA        A8,A2,xp_p
trap5    ENTL      X0,0C3(16)
         CPYXS     X0,X0               .SET TEF AND TED
         RETURN                        .RETURN WITH TRAPS ENABLED
*copy osi$c170_cmu_emulation
*copy osi$privilaged_170_instructions
.
.        request table for EI.
.
         fn017     rspt,read_set_pit   .read and set pit register
         fn017     cinv,bmi            .cache invalidate
         fn017     cpcm,minilink
         fn017     eccp,bcm            .block copy
         fn017     cecp,bcm
         fn017     dscb,sip            .store EI communications block pointer
         fn017     cpva,srapva
         fn017     rpva,fetch_pva
         fn017     scpu,hlt
         fn017     ihfu,ihf            .inject hardware fault
         fn017     3,downc180
         fn017     2002(8),status_ve
         fn017     end
.
         brreq     x0,x0,pif4          .invalid function
         page
.
.        srapva - set reference addresses.
.
.        entry:
.
.        TRAP      Xi,Xj,1002
.
.        Xi = address space descriptor in bits 56 to 63.
.           0 = illegal.
.           1 = Start of NOS/VE memory.
.           2 = Start of SSR.
.           3 = Start of Mainframe wired.
.           4 = Start of DFT buffer.  Bits 48 to 55 are an index into the first DFT
.                buffer of the buffer to dump.  If the DFT revision level is 3 or
.                less, the maximum buffer index is 3.  For DFT revision level 4 or
.                greater, the value in the "PO" field of the DFT control word is
.                used as the maximum buffer index.
.        Xj = Word address for the pointer.
.
srapva   bss       0
         lxi       x1,a_psa,x_reg1,xp_cx0 .fetch address space descriptor
         lxi       x2,a_psa,x_reg2,xp_cx0 .fetch word address
         cpyaa     a8,a_nos
         cpyxx     x4,x1
         shfx      x2,x2,x0,3          .byte address.
         isob      x1,x1,x0,7007(8)    .address space descriptor.
         addax     a8,x2
         shfx      x1,x1,x0,3
         brreq     x1,x0,iip           .if attempt to change DSCB
         ente      x3,pva_table_len
         brrge     x1,x3,iip           .if invalid address descriptor
         brreq     x2,x0,srapva15      .if clearing pva
         ente      x5,4*8
         brreq     x5,x1,srapva5       .if setting DFT buffer pva.
         lx        x3,a_dscb,d7cm+8
         isob      x4,x3,x0,2027(8)    .isolate fwa
         isob      x5,x3,x0,5027(8)    .isolate lwa
         shfx      x4,x4,x0,9+3
         shfx      x5,x5,x0,9+3
         brrge     x2,x5,aor           .if address too large
         brrgt     x4,x2,aor           .if address too small
         sai       a8,a_static,x1,pva_table
         brreq     x0,x0,trap2         .exit
.
.        Set pva of DFT buffer and DFT buffer index.
.
srapva5  bss       0
         lx        x5,a_dscb,d7ty      .170 OS type.
         isob      x4,x4,x0,6007(8)    .DFT buffer index.
         entp      x6,3
         isob      x5,x5,x0,6405(8)    .EICB version number.
         brrgt     x6,x5,iip           .if EICB version does not have DFT pointer.
.
.        Set pva of fixed portion of DFT buffer in all cases.
.
         lx        x3,a_dscb,dscm+(3*8)  .DFT OS buffer pointer, r-register format.
         cpyaa     a8,a_nos
         isob      x7,x3,x0,2017(8)    .r_upper.
         isob      x5,x3,x0,4017(8)    .r_lower.
         shfx      x7,x7,x0,12+6       .r_upper * 100(8).
         shfx      x5,x5,x0,6          .r_lower * 100(8).
         isob      x6,x3,x0,0413(8)    .DFT buffer offset relative to r pointer.
         iorx      x5,x7               .combine r_upper and r_lower.
         isob      x7,x3,x0,6017(8)    .length of DFT block.
         addr      x5,x6               .word offset of DFT block.
         brreq     x7,x0,iip           .if DFT block not defined.
         shfx      x5,x5,x0,3          .byte offset of DFT block.
         addax     a8,x5               .pva of fixed portion of DFT buffer.
         entp      x6,3                .initialize maximum DFT buffer index for
                                       .DFT revision 3.

         lbyts,1   x3,a8,x0,2          .DFT revision level.
         entp      x8,4
         brrgt     x8,x3,srapva7       .if DFT revision level < 4.
         lbyts,1   x6,a8,x0,0          .get maximum buffer index from po field.
srapva7  brrgt     x4,x6,iip           .if DFT buffer index exceeded.
         cpyaa     a6,a8
         brreq     x4,x0,srapva10      .if setting pva of fixed portion.
.
.        Set pva of specified DFT buffer.
.
         lxi       x3,a8,x4,0          .DFT buffer pointer, r-register format.
         cpyaa     a6,a_nos
         isob      x7,x3,x0,2017(8)    .r_upper.
         isob      x5,x3,x0,4017(8)    .r_lower.
         shfx      x7,x7,x0,12+6       .r_upper * 100(8).
         shfx      x5,x5,x0,6          .r_lower * 100(8).
         isob      x6,x3,x0,0413(8)    .DFT buffer offset relative to r pointer.
         iorx      x5,x7               .combine r_upper and r_lower.
         isob      x7,x3,x0,6017(8)    .length of DFT buffer.
         addr      x5,x6               .word offset of DFT block.
         shfx      x5,x5,x0,3          .byte offset of DFT buffer.
         addax     a6,x5               .pva of DFT buffer.
srapva10 bss       0
         brreq     x7,x0,iip           .if length = zero.
         brreq     x5,x0,iip           .if offset = zero.
         sai       a6,a_static,x1,pva_table  .set DFT buffer pointer.
         sbyts,2   x4,a_static,x1,pva_table-2  .set DFT buffer index.
         sa        a8,a_static,pva_of_first_dftb  .set pva of first DFT buffer.
         brreq     x0,x0,trap2         .exit
.
srapva15 sbyts,6   x2,a_static,x1,pva_table    .clear pva
         brreq     x0,x0,trap2         .exit
         page
...
.        SIP        -SET INTERFACE POINTER.
.
.        INSTRUCTION FORMAT.
.        017ij 00001 0000000000
.
.        (Xi) = ADDRESS OF DUAL STATE INTERFACE BLOCK.
.        (Xj) = IGNORED.
.
.        THE C170 OPERATING SYSTEM USES THIS REQUEST TO  TELL  EI  THE
.        LOCATION  OF THE DUAL STATE INTERFACE BLOCK.  THIS BLOCK MUST
.        BE DEFINED  TO  IF  OTHER  DUAL  STATE  REQUESTS  ARE  TO  BE
.        VALIDATED AND HONORED.
.
SIP      LXI       X3,A2,x_reg1,xp_cx0 .FETCH REGISTER WITH ADDRESS
         SHFX      X3,X3,X0,3          .FORM BYTE ADDRESS
         cpyaa     a_dscb,a_nos
         ADDAX     a_dscb,X3           .FORM PVA for the dual state control block
         SA        a_dscb,a_static,pva_of_dscb
         addpxq    a4,x0,ei_version
         la        a4,a4,0
         lbyts,1   x3,a4,x0,3          .EI version number.
         lbyts,3   x6,a4,x0,0          .version and level of interface block.
         shfx      x3,x3,x0,18
         iorx      x6,x3
         SX        X6,a_dscb,D8TY
         entp      x0,0
         sx        x0,a_dscb,d8jp      .clear nos/ve priority
         sx        x0,a_dscb,d8jp+8
         BRREQ     X0,X0,trap4         .EXIT AND INCREMENT P
         SPACE     10
..
.        HLT        - HALT PROCESSOR IN C180 MODE.
.
.        INSTRUCTION FORMAT.
.        017 ij 00002 0000000000
.
.        REQUEST  THE  EI  TO  IDLE IN C180 MODE.  Xi, Xj ARE IGNORED.
.        WHEN EI IS IDLED, NOS/VE WILL HALT THE PROCESSOR  AND  CHANGE
.        THE ENVIRONMENT TO USE THE NOS/VE TRAP HANDLER INSTEAD.  WHEN
.        NOS/VE IS BROUGHT DOWN, EI'S STACK FRAME IS RESET TO THE LAST
.        VALID C170 EXCHANGE PACKAGE AND EI IS RESTARTED USING THE MPS
.        PACKAGE.   EVENTUALLY  A RETURN IS MADE TO C170 STATE THROUGH
.        THIS ROUTINE.
.
HLT      BSS       0
         LA        a8,A2,xp_p          .INCREMENT AND STORE P-REGISTER
         ADDAQ     a8,a8,8
         SA        a8,A2,xp_p
         LBYTS,2   X4,A2,X0,xp_p       .SAVE RING/SEGM # OF P
         ENTE      X1,SRTDSTS          .SET D/S INITIATED STATUS
         sbyts,1   x1,a_dscb,x0,ds_stat+3
         ENTN      X1,1                .SET DEADSTART INITIATED
         sbyts,4   x1,a_dscb,x0,ds_flag
.
         lbyts,4   x1,a_dscb,x0,ve_sfsa
         brreq     x1,x0,hlt01         .if no RMA to copy to
         cpyaa     a8,a_nos
         addax     a8,x1               .form PVA of ve stack
         movb,a2,x0  a8,x1  0,0,25*8,0    0,9,25*8,0
         movb,a2,x0  a8,x1  0,0,27*8,25*8 0,9,27*8,25*8
hlt01    tpage     x1,a2
         sbyts,4   x1,a_dscb,x0,os_sfsa .save sfsa rma
         entp      x1,0
         sbyts,4   x1,a_dscb,x0,ve_jps  .ensure ve jps is cleared
.
         ente      x5,0c9(16)          .PIT register number
         cpysx     x3,x5               .save PIT
.
         EIMTRCAL  MTRR#STD,0,NOHLT
.
.        RETURN FROM 180 MONITOR MODE.
.
         CPYAX     X1,a_dscb
         PURGE     X1,3
         ADDXQ     X1,X1,D8SV
         PURGE     X1,3
         ENTP      X0,0
         sx        x0,a_dscb,d8jp      .clear c180 priority
         sx        x0,a_dscb,d8jp+8
.
.        Reset EI version number and version and level number of dual state control
.        block in the dual state control block.
.
         addpxq    a4,x0,ei_version
         la        a4,a4,0
         lbyts,1   x3,a4,x0,3          .EI version number.
         lbyts,3   x6,a4,x0,0          .version and level of interface block.
         shfx      x3,x3,x0,18
         iorx      x6,x3
         SX        X6,a_dscb,D8TY
.
         lx        x6,a_dscb,ve_sfsa
         brreq     x6,x0,hlt02         .if ve_jps is 0
         lbyts,2   x2,a_nos,x6,xp_pit  .upper 32 bits of pit
         lbyts,2   x3,a_nos,x6,xp_pit+8
         insb      x3,x2,x0,4017(8)
         cpyxs     x3,x5               .update PIT
         lbyts,1   x1,a_nos,x6,xp_vmid
         brrne     x1,x0,hlt03         .if vmid at ve_jps is 1
hlt02    shfc      x6,x6,x0,32
         brreq     x6,x0,hlt05         .if no sfsa
hlt03    cpyaa     a8,a_nos
         addax     a8,x6
         movb,a8,x0  a2,x1  0,0,16*8,17*8  0,0,16*8,17*8
.
         ente      x6,xp_x0
         entp      x5,0
hlt04    lbyts,6   x1,a8,x5,xp_p
         sbyts,6   x1,a2,x5,xp_p
         incr      x5,8
         brrne     x5,x6,hlt04         .if more A registers to copy
.
hlt05    SBYTS,2   X4,A2,X0,xp_p       .RESET RING NUMBER OF P
         SA        A2,A2,xp_a0         .RESET A0
         SA        A2,A2,xp_a0+8       .RESET A1
         ENTN      X1,1
         SBYTS,6   X1,A2,X0,xp_a0+16   .RESET A2
.
         BRREQ     X0,X0,trap5         .EXIT WITHOUT INCREMENT OF P
         PAGE
.        downc180   - TERMINATE NOSVE ENVIRONMENT.
.                  In EI this function only returns ve down status.
.
downc180 BSS       0
         brreq     x0,x0,trap2         .exit with ve down status
         space      4
.        status_ve - get the current running status of ve.
.
status_ve bss      0
         entp      x2,1                .return ve down
         shfx      x2,x2,x0,30
         sxi       x2,a_psa,x_reg1,xp_cx0
         brreq     x0,x0,trap2         .return ve down
.
         ref       osv$ei_version
ei_version  address  p,osv$ei_version
.
         end
*DECK DECK=OSM$PREPARE_OS_ENVIRONMENT EXPAND=TRUE
osm$prepare_os_environment  IDENT
         list      1,1,0
         title     c'OS environment interface preset and CTI interface.'
         space     4
.        TRADE SECRET - PROPRIETARY NOTICE.
.        COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
.        The material contained herein is the property of Control Data
.        Systems Inc and is intended soley for use in the  performance
.        of  contracted  Maintenance  under a Control Data maintenance
.        services agreement.  This material is proprietary to  Control
.        Data  Systems Inc  and  is  not to be disclosed other than to
.        employees  of  Control  Data  Systems Inc  or  other  persons
.        specifically authorized to have access to  this  material  in
.        accordance  with  the  terms and conditions of a Control Data
.        maintenance services agreement.
         page
...
.        CEI       - A170 Environment Interface.
.
.        A. E. Murray  11-1-77
.        B. R. Hanson   -1-80
.        G. I. Matkovitz  7-1-80
.        B. R. Hanson     8-12-81
.
.        This program provides  the  necessary  interface  between  an
.        operating  system  using  the  C170  virtual  machine and the
.        native mode error processing  of  the  C180  computer.   This
.        program  also  provides an interface to C170 NOS/ve deadstart
.        programs when NOS/ve is not present.  The primary purpose  is
.        to  simulate  with software running in executive state of the
.        C180 to achieve the following  things.   1)  The  effects  of
.        errors occurring in the C170 virtual machine that differ from
.        those  of  the  C170  Hardware.  2) The deadstart of the C170
.        virtual machine.  3) The presence of  the  CMU  on  the  C170
.        hardware.  4)  The  presence of  a block move instruction for
.        storage move.  5) The  C170 OS-NOS/ve  interface  through the
.        017 instruction.
         page
*copy asmregs
*copy osa$ei_constant_definitions
*copy osa$dual_state_control_block
*copy osa$ei_stack_frame
*copy sya$xp_and_sf_constants
         PAGE
C180EI   SECTION   working,read+execute+write,,0,8
         USE       C180EI
ei_pva   bss       0                   .pva for EI
         space     4
...
.        LIT       - Load Interface Table.
.
.        The load interface table provides the information required
.        by CTI to load and initially start EI executing.
.
.        Define the load size of EI.
.
         def       osv$ei_load_size_in_bytes
osv$ei_load_size_in_bytes bss 0
EI_LBA   vfd,32    2000(16)
.
.        Define the EI version number and the version and level of
.        the dual state control block.  The format of this is rigidly
.        defined.  If it is changed the utility that packages EI for CIP
.        tapes must also be modified.
.
         def       osv$ei_version
osv$ei_version bss 0
         vfd,6     0                   .filler
         vfd,6     ost$ei              .os type = EI
         vfd,6     if_versn            .Interface version
         vfd,6     if_level            .Interface level
.
.        The version number is a decimal number that is put in hex for convenience
.        when checking version number in memory.
.
         vfd,8     030(16)             .EI version number
.
.        DEFINE STOP C170 ADDRESS.
.
         def       osp$ei_halt
         align     0,8
osp$ei_halt bss    0
         brreq     X0,X0,osp$ei_halt    .STOP THE MUSIC
.
.        Date OSAEI deck changed.
.
         def       osv$ei_assembly_date
osv$ei_assembly_date bss 0
*put '  vfd,32 '//$substr($date(iso),6,2)//$substr($date(iso),9,2)//$substr($date(iso),1,4)//'(16)'

.        Relative byte offset of MPS and CTI request word.
.
         def       osv$ei_mps_offset
osv$ei_mps_offset bss 0
         vfd,32    tmxp
         vfd,32    cti_req
         space     10
..
.        cti_req   - CTI request block.
.
         def       osv$ei_cti_request_block
osv$ei_cti_request_block bss 0
CTI_REQ  vfd,16    0                   .function code
         vfd,16    0                   .parameter 0
         vfd,32    0                   .parameter 2
         vfd,64    0                   .parameter 3 mrt_frc
         vfd,64    0                   .parameter 4 mrt_wcc
         vfd,64    0                   .parameter 5 hdw_wcc
         vfd,64    0                   .parameter 6 returned value
million  vfd,64    1000000             .one million constant
sec_year vfd,64    31536000            .seconds in a non leap year
sec_day  vfd,64    86400               .seconds in a day
delta    vfd,64    1209600000000       .two week delta
dual_cpu equ       2                   .defines if C170 state can use both CPUs
cpus     equ       3
rbl      equ       50                  .response buffer length.
         PAGE
..
.        PRS       - Environment Interface Preset.
.
.        EI is entered here under two conditions, to initially preset
.        the environment and to do some utility functions for CTI after
.        a system failure without reloading EI.  When EI is restarted
.        none of the initialization is required because its environment
.        has already been initialized.
.
.        The initial environment when starting from scratch that is
.        provided by CTI includes only two page table entries - one for the
.        first page of the page table, and one for the first page of EI.
.        All the preset code must fit within 512 bytes to be able to work
.        with any page size.  EI is entered with traps disabled; traps are
.        enabled when initialized to the point where it can take traps.
.        CTI sets up the PTA, PSM, PTL and MPS registers
.        and changes the segment table address within the preset monitor
.        exchange package (MXP).  EI must build the page table by adding
.        page table entries for the page table, EI's code segment, EI's
.        stack segment, and the OS segment.   EI also creates a monitor and
.        job exchange package for each processor and defines their respective
.        monitor and job stack frame save area.
.
         def       osp$prepare_os_environment
osp$prepare_os_environment equ $
prs0     ente      x3,0                .EI preset complete flag, this instruction is
                                       . modified when initialization complete, set
                                       . to a nonzero value.
prs_comp equ       prs0+2
         ente      x1,r_psm            .page size mask
         brrne     x3,x0,re_ei         .if reentering EI.
         cpysx     x2,x1
         isom      xf,x0,47
         shfx      x2,x2,x0,9
         iorx      xf,x2               .form mask for page offset and ASID from SVA
         notx      xe,xf
         incx      xe,1                .page size in bytes
         ente      x1,r_ptl            .page table length
         cpysx     x2,x1
         ente      xa,3f(16)           .form page table segment offset
         notx      xa,xa
         andx      xa,x2
         shfc      xa,xa,x0,21
         incr      x2,1
         shfx      xd,x2,x0,12         .page table length in bytes
         lbyts,2   x3,a5,x0,pt_asid
         shfx      x3,x3,x0,32         .SVA for Page Table segment
         iorx      x3,xa
         addax     a6,xa               .set conditional offset for large memory
         cpyrr     x5,xa
         tpage     x6,a6
         addpxq    a7,x0,prs1
         brreq     x0,x0,cseg          .create PT entry for page 0 with continue bit.

.        Create page table entry for real page 0 of page table but page 1 relative to the SVA.

prs1     cpyrr     xc,x3               .save SVA of page 1 of page table.
         isob      xb,x3,x0,37*64+26
         brrgt     xd,xb,prs2          .if page table is larger than 1 page.
         cpyrr     x3,xd
         iorx      x3,xa
prs2     cpyrr     x5,x3               .last byte address of first page or page table
         tpage     x6,a6               .RMA of the page table
         addpxq    a7,x0,prs3
         brreq     x0,x0,cseg          .create PT entry for page 0 of page table again

.        Now there are 2 page table entries for page 0 of the page table, one with an offset
.        of zero relative to the PVA and another one with the page size as an offset relative
.        to the PVA.  Clear page table entry with PVA offset of zero in the page table.

prs3     addax     a6,xe               .new PVA for the page table, page 0
         entp      x8,0                .invalid no continue
         cpyrr     x3,xa               .set starting SVA
         cpyrr     x5,xc               .set segment length, 1 page
         addpxq    a7,x0,prs4
         brreq     x0,x0,cseg0         .clear PT entry for page 0 of page table.

.        Define all page table entries for page table relative to offset of page size
.        for the PVA.

prs4     addr      x5,xd               .set page table lba
         tpage     x6,a6
         addpxq    a7,x0,prs5
         brreq     x0,x0,cseg          .define full page table segment
.
prs5     addax     a_static,x3         .start of static shared variables
         lbyts,2   x3,a5,x0,ei_asid
         shfx      x3,x3,x0,32         .create SVA for EI segment
         tpage     x6,a5               .RMA of EI segment
         lbyts,4   x5,a5,x0,osv$ei_load_size_in_bytes .EI segment length
         addaq     a_tos,a_static,static_size
         addpxq    a7,x0,wait_for_request  .set return address
         brreq     x0,x0,cseg          .create EI segment
         page
..
.        CSEG - Create Segment.
.                  This procedure creates the page table entries for the specified
.                  segment. It can also be entered at CSEG0 but the caller is
.                  responsible for providing the valid and continue bits for the
.                  page table entry.
.
.        Entry conditions:
.                  x3 = SVA of start of segment.
.                  x6 = RMA of start of segment.
.                  x5 = LBA of segment.
.                  x8 = page table entry valid and continue bits if entered at CSEG0.
.                  xe = page size in bytes.
.                  xf = page offset mask.
.                  a7 = return address.
.
.        Exit conditions:
.                  x3 = SVA of page following segment created.
.                  x6 = RMA of page following segment created.
.
.        uses registers.
.                  x - 1, 2, 3, 4, 6, 8.
.
cseg     entp      x8,3                .valid + continue bit
         shfx      x8,x8,x0,62-0
cseg0    lpage     x2,x3,x1
         cpyxx     x1,x3
         andx      x1,xf               .form segment/page identifier
         shfx      x4,x6,x0,-9         .form page frame address
         shfr      x1,x1,x0,1          .trim sign bit from offset
         shfx      x1,x1,x0,22-9-1
         iorx      x1,x4
         iorx      x1,x8
         sbyts,8   x1,a6,x2,0          .store page table entry
         addr      x6,xe               .update RMA
         addr      x3,xe               .update SVA
         brrgt     x5,x3,cseg0         .if more entries to build
         brdir     a7,x0               .return

pof      bss       0                   .page overflow check.
         error,pof>511  c'EI initialization overflows minimum page size.'

.        End of code that must fit in 512 bytes.  Page table entries created for
.        the page table and the EI code segment.

         PAGE
..
.                  EI preset loop.  This is where EI waits for the next request from
.                  CTI.  After request is processed control is returned to
.                  'complete_function' by each request processor.
.
.        INPUT: complete_function
.                  a5 = PVA of first byte address of EI code segment.
.                  a7 = PVA of response buffer.
.                  a9 = address of where continue function should go to complete
.                       function.
.                  x7 = byte length of response buffer.
.
.        INPUT: wait_for_request
.                  a_rac = OS segment pointer.
.                  a_static = pointer to static shared variables.
.                  x_flc = last byte offset + 1 of OS field length.
.

complete_function bss 0
         tpage     x1,a7
         sbyts,4   x1,a5,x0,cti_req+4  .save rma of response block
         shfx      x7,x7,x0,-2         .response buffer length in half words.
         sbyts,2   x7,a5,x0,cti_req+2  .save block size in half words.
         entp      x2,0
         sbyts,2   x2,a5,x0,cti_req    .clear function code

.        INPUT: wait for request.
.                  a5 = PVA of first byte address of EI code segment.

wait_for_request bss 0
         cpyax     x1,a5
         purge     x1,3
         lbyts,2   x2,a5,x0,cti_req    .check for request
         brreq     x2,x0,wait_for_request
         entp      x1,list_entries
         brrge     x2,x1,osp$ei_halt   .if invalid function
         entp      x7,0                .initialize response buffer length.
         shfx      x2,x2,x0,1
         incr      x2,1
         brrel     x2
.
.        Table of CTI request processors.
.

list     bss       0
         brreq     x0,x0,complete_function
         brreq     x0,x0,init_stack
         brreq     x0,x0,scan_cm
         brreq     x0,x0,check_cm
         brreq     x0,x0,continue
         brreq     x0,x0,fetch_frc
         brreq     x0,x0,cfv
         brreq     x0,x0,cnf
         brreq     x0,x0,cpi
list_entries equ ($-list)/4
         page
..
.        init_stack - initialize stack and OS (NOS or NOS/BE) segments.
.                  Create stack segments for EI and initialize.  Create segment
.                  for the OS.  Initialize monitor and job exchange package for
.                  each CPU.  Traps are enabled before exiting this procedure.
.                  Values are saved that are needed for reentering EI.
.
.        ENTRY:
.                  a_static = pointer to static shared variables.
.                  a5 = pointer to first byte of EI code segment.
.                  x7 = 0, response buffer length.
.
.        EXIT:
.                  a_csf = initilized to top of stack for remainder of execution.
.                  a7 = response buffer address.
.                  x7 = byte length of response buffer.
.                  x_flc = last byte offset + 1 of OS field length.
.                  (a7) = RMAs of first byte of EI stack (last byte address + 1 of
.                         host operating system) and all EI exchange packages.  The
.                         RMA of region right after the last exchange package stack
.                         is returned as the beginning of the CTI reserved area.
.

init_stack bss     0
         sa        a_static,a5,pcbp+8+2  .update code based pointers
         sa        a_static,a5,mcbp+8+2
         sa        a_static,a5,ocbp+8+2

         cpyax     x2,a_static
         lbyts,2   x3,a5,x0,sf_asid    .stack frame asid
         shfx      x3,x3,x0,32
         cpyrr     x3,x2               .SVA for stack segment
.
.        calculate size of stack segment based on number of cpus.
.
         lbyts,1   xc,a5,x0,cti_req+cpus
         mulxq     x5,xc,sf_size       .stack frame size per processor
         addrq     x5,x5,static_size+dscbl-1
         lbyts,4   xa,a5,x0,cti_req+4
         addr      x5,xa               .add cti block size
         tpage     x6,a5               .RMA of EI segment
         subx      x6,x5
         isom      x9,x0,50
         andx      x9,xf               .form mask >= 8192
         andx      x6,x9               .form multiple of 8192
         addr      x5,x3
         cpyxx     x7,x6
         addpxq    a7,x0,ini1
         brreq     x0,x0,cseg          .create stack segment
.
ini1     tpage     x5,a_static         .LBA of OS segment
         subr      x6,x7
         subr      x6,xa               .ignore CTI save area
         shfx      x7,x6,x0,-3         .length of stack segment in words
         lbyts,2   x3,a5,x0,os_asid
         shfx      x3,x3,x0,32         .SVA of OS segment
         entp      x6,0                .RMA of OS segment
         addpxq    a7,x0,ini2
         brreq     x0,x0,cseg          .create OS segment
.
ini2     entp      x0,0
         entp      x1,0
         decr      x7,1
ini3     sxi       x0,a_static,x1,0    .clear stack segment
         brinc     x7,x1,ini3

         sbyts,8   x0,a_static,x0,pva_of_first_dftb
.
         addpxq    a9,x0,osp$halt_ei   .Set pva of EI halt routine.
         sa        a9,a_static,pva_halt_ei
         addpxq    a9,x0,osp$segment_table  .Set pva of EI's segment table.
         sa        a9,a_static,pva_segment_table
         la        a9,a5,osp$afe
         sa        a9,a_static,pva_due_handler
         la        a9,a5,osp$aaj
         sa        a9,a_static,pva_abort_job
         lbyts,1   x1,a5,x0,cti_req+dual_cpu
         sbyts,1   x1,a_static,x0,dual_170
.
         sa        a_nos,a_static,pva_of_os  .Set pva of OS.
.
         cpyxx     x_flc,x5
         cpyaa     a_csf,a_tos         .Set address for first monitor xp.
         addaq     a7,a_tos,sf_wrk     .Set response buffer address.
         tpage     x5,a_static
         sbyts,4   x5,a7,x0,0
         sbyts,1   xc,a5,x0,nop        .Save number of processors.
         sa        a_csf,a5,mxp0_p     .Save address of monitor xp for cpu 0.
         entp      x7,4                .Set index for next value in response buffer.
         addpxq    a9,x0,ini4          .Set return address.
         brreq     x0,x0,ixp           .Initialize EI exchange packages and stacks.

ini4     bss       0
         cpyaa     a_dscb,a_csf        .pointer to fake dscb
         sa        a_dscb,a_static,pva_of_dscb
         addaq     a_csf,a_dscb,dscbl  .pointer to CTI reserved area
         tpage     x5,a_csf
         sbyts,4   x5,a7,x7,0          .return RMA of CTI reserved area.
         incr      x7,4

.        Update A_TOS in the running exchange package so that the monitor exchange
.        package just created will not be overwritten when traps are taken.  Use
.        the stack of first monitor xp created for this value.  Also update in
.        the initial exchange package for use when EI reentered.

         addaq     a_tos,a_tos,sf_monitor_stack
         sa        a_tos,a5,tmxp+xp_a0 .save sfsa of monitor's stack
         sa        a_tos,a5,tmxp+xp_rn1  .store top of stack
         sxi       x_flc,a5,x0,tmxp+xp_x0+(0f(16)*8)  .Save x_flc in x_flc of xp
                                       . that is used when EI is reentered.
         ente      x0,r_te             .enable traps
         sa        a_static,a5,tmxp+xp_a0+(3*8)  .Save a_static in a_static of xp
                                       . that is used when EI is reentered.
         sbyts,2   x0,a5,x0,prs_comp   .Set initialization complete, this module
                                       . can now be reenetered by restarting the
                                       . running EI with P set to
                                       . 'osp$prepare_os_environment' and MPS set
                                       . to exchange package at TMXP.

.        Environment is now set up to allow traps, enable traps.

         cpyxs     x0,x0

         addpxq    a9,x0,complete_function  .return address for function complete.
         brdir     a9,x0               .return.
         page
..
.        ixp - Initializes the EI exchange packages.  Space is also reserved
.              for the ring 1 stack for each exchange package.
.
.        INPUT:
.                  a5 = pointer to first byte of EI code segment.
.                  a7 = response buffer address.
.                  a9 = return address.
.                  a_csf = pointer to area for exchange packages and stacks
.                          that are to be initialized.
.                  a_static = pointer to static shared variables.
.                  x7 = current response buffer length.
.                  xc = number of processors.
.
.        OUTPUT:
.                  (a7) = RMAs of exchange packages initialized.
.                  a_csf = pointer region right after last stack reserved.
.                  x7 = byte length of response buffer.
.

ixp      bss       0                   .Initialize exchange package.
         entp      x5,2
         sbyts,1   x5,a5,x0,tmxp+xp_tef  .Set traps enabled in initial xp temporarily.
         entp      x3,0                .indicate CPU 0

.        If concurrent CPUs (C170 can run in both CPUs) on a non-S1 mainframe,
.        then the external interrupt bit must be set in the monitor mask register
.        in the job exchange package.

         lbyts,1   x2,a_static,x0,dual_170  .get concurrent CPU flag
         entp      x1,2
         brrne     x1,x2,ixp5          .if not non-S1 concurrent CPUs
         entp      x5,1                .set the external interrupt bit
         entp      x0,0                .interrupt bit is bit 0
         sbit      x5,a5,tjxp+xp_mm+1,x0

.        Loop to initialize monitor and job exchange package and stacks.

ixp5     bss       0
         tpage     x5,a_csf
         sbyts,4   x5,a7,x7,0          .return RMA of monitor xp.
         incr      x7,4

.        Move monitor and job exchange packages to MPS or JPS respectively.
.        Some values in exchange packages are initialized.  This is done
.        for each CPU.

         movb,a5,x0  a_csf,x1  0,9,17*8,tmxp  0,9,17*8,0  .copy monitor package
         movb,a5,x0  a_csf,x1  0,9,18*8,tmxp+xp_sta  0,9,18*8,xp_sta

.        Update values in moved monitor exchange package.

         la        a8,a5,ei_monitor_pva
         sa        a8,a_csf,xp_p
         addpxq    a8,x0,mcbp          .update trap pointer
         sa        a8,a_csf,xp_tp
         sa        a_static,a_csf,xp_a0+3*8
         addaq     a8,a_csf,sf_monitor_stack      .Set monitor stack frame TOS pva.
         sa        a8,a_csf,xp_a0      .store register A0
         sa        a8,a_csf,xp_rn1     .store TOS Ring 1
         addaq     a_wrk,a_csf,sf_wrk
         sa        a_wrk,a_csf,xp_a0+0d(16)*8  .Set AD to work area in stack segment.
         addaq     a_jps,a_csf,sf_jxp
         sa        a_jps,a_csf,xp_a0+0b(16)*8  .Set AB to pva of job exchange package.
.
         movb,a5,x0  a_jps,x1  0,9,17*8,tjxp  0,9,17*8,0  .create job exchange
                                                          . package.
         movb,a5,x0  a_jps,x1  0,9,18*8,tmxp+xp_sta  0,9,18*8,xp_sta

.        Update values in moved job exchange package.

         addpxq    a8,x0,ocbp          .update trap pointer
         sa        a8,a_jps,xp_tp
         addaq     a8,a_csf,sf_job_stack  .job stack PVA
         sa        a8,a_jps,xp_a0      .store register A0
         sa        a8,a_jps,xp_rn1     .store TOS Ring 1

.        If processing a CPU other than CPU 0 and if running on non-S1 concurrent
.        CPUs, then the exchange package P address must be set to 76(8)*8.

         brreq     x3,x0,ixp10         .if currently processing CPU0
         entp      x1,2
         brrne     x1,x2,ixp10         .if not non-S1 concurrent CPUs
         ente      x5,ccpadd
         sbyts,4   x5,a_jps,x0,xp_p+2
ixp10    bss       0
         entp      x3,1                .indicate not CPU 0
         addaq     a_csf,a_csf,sf_size
         decx      xc,1
         brxgt     xc,x0,ixp5          .if more sfsa's to preset
         entp      x5,0
         sbyts,1   x5,a5,x0,tmxp+xp_tef  .reset traps disabled in initial xp.
         brdir     a9,x0               .Return.



         ref       osp$a170_fatal_error
osp$afe  address   p,osp$a170_fatal_error
         ref       osp$abort_a170_job
osp$aaj  address   p,osp$abort_a170_job
         page
..
.        re_ei - EI has been reentered by CTI.  Initialize environment to wait
.        for CTI requests.
.
.        INPUT:
.                  a5 = pointer to first byte of EI code segment.
.                  a_static = pointer to common EI variables in stack.
.                  x_flc = last byte offset + 1 of OS code segment.
.
.        OUTPUT:
.                  Environment initialized to wait for CTI requests.
.
.        EXIT:
.                  Exit to wait_for_request.
.

re_ei    bss       0
         addpxq    a8,x0,pcbp          .trap pointer for processing CTI requests.
         entl      x0,r_tp
         lbyts,1   xc,a5,x0,nop        .number of processors.
         la        a_csf,a5,mxp0_p     .address of monitor xp for cpu 0.
         cpyax     x3,a8
         entp      x1,0                .initialize exchange package pointer index.
         cpyaa     a7,a_tos            .use tos for response buffer.
         entp      x7,0                .index for first entry in response buffer.
         ente      x2,9a(16)           .clear global priviledge in 170 code segment
                                       . segment table entry.  This is used as the
                                       . concurrent 170 monitor interlock flag.
         cpyxs     x3,x0               .update trap pointer in active exchange
                                       . package.
         sbyts,1   x2,a5,x0,os_seg
         addpxq    a9,x0,re_ei5        .Set return address.
         brreq     x0,x0,ixp           .Initialize EI exchange packages.

.        Zero out the area for saving failing job mode exchange packages in the
.        work area for each monitor exchange package.  Do not want to leave
.        residue around that could be confusing when looking at dumps.

re_ei5   bss       0
         la        a7,a5,mxp0_p        .address of monitor xp for cpu 0.
         lbyts,1   xc,a5,x0,nop        .number of processors.
         entp      x5,0
         la        a9,a7,xp_a0+(0d(16)*8)  .a_wrk from monitor xp.
         ente      x9,xpsw-1           .index of last word to zero out.
re_ei10  bss       0
         sxi       x5,a9,x9,sf_save_job  .zero word.
         decx      x9,1
         brxge     x9,x0,re_ei10       .if area not zeroed out.
         decx      xc,1                .decrement number of processors.
         addaq     a7,a7,sf_size       .address of monitor xp for next processor.
         brxge     x0,xc,re_ei15       .if all processor save areas initialized.
         la        a9,a7,xp_a0+(0d(16)*8)  .a_wrk from monitor xp.
         ente      x9,xpsw-1           .index of last word to zero out.
         brreq     x0,x0,re_ei10       .initialize for next processor.

re_ei15  bss       0
         entl      x0,r_te
         la        a_csf,a5,tmxp+xp_a0+(1*8)   .Reset CSF to initial value.
         cpyxs     x0,x0               .enable traps.
         brreq     x0,x0,wait_for_request  .go wait for CTI requests.

         page
..
.        scan_cm   check central memory for unrecovered hardware errors.
.
.        ENTRY:
.                  a_rac = OS segment pointer.
.                  a_static = pointer to static shared variables.
.                  x_flc = last byte offset + 1 of OS field length.
.                  x7 = 0, response buffer length.
.
.        EXIT:
.                  a7 = response buffer address.
.                  a9 = reentry address on continue function.
.                  x7 = byte length of response buffer.
.

scan_cm  bss       0
         addaq     a7,a_tos,sf_job_stack-sf_monitor_stack
         addpxq    a9,x0,sca2          .re-entry address on continue
         entp      xa,0
         cpyxx     x9,x7               .index of last entry in response buffer.
         sx        x7,a7,0             .zero out first entry in response buffer.
sca1     lbyts,8   x1,a_rac,xa,0       .try to read cm
sca2     incr      xa,8
         sbyts,4   xa,a5,x0,cti_req+4  .tell cti of address being checked
         brrgt     x_flc,xa,sca1
         brreq     x0,x0,complete_function
         page
..
.        check_cm  run a memory test on central memory.
.
.        ENTRY:
.                  a_rac = OS segment pointer.
.                  a_static = pointer to static shared variables.
.                  x_flc = last byte offset + 1 of OS field length.
.                  x7 = 0, response buffer length.
.
.        EXIT:
.                  a7 = response buffer address.
.                  a9 = reentry address on continue function.
.                  x7 = byte length of response buffer.
.

check_cm bss       0
         addaq     a7,a_tos,sf_job_stack-sf_monitor_stack
         addpxq    a9,x0,che2
         entp      xa,0
         entn      xb,1
         cpyxx     x9,x7               .index of last entry in response buffer.
         sx        x7,a7,0             .zero out first entry in response buffer.
che1     shfx      x2,xa,x0,-3
         sxi       xb,a_rac,x2,0
         lxi       x1,a_rac,x2,0
         brrne     x1,xb,che3          .if data does not compare
che2     incr      xa,8
         sbyts,4   xa,a5,x0,cti_req+4  .tell cti of address being checked
         brrgt     x_flc,xa,che1       .if more to preset
         brreq     x0,x0,complete_function
.
che3     lxi       x1,a5,x_flc,0       .cause page fault
         page
..
.        continue  Continue the previous function where it left off.
.
.        ENTRY:
.                  a9 = 0, response buffer length.
.                  x7 = 0, response buffer length.
.
.        EXIT:
.                  a7 = response buffer address.
.                  x7 = 0, response buffer length.
.                  First word of response buffer is set to zero.
.

continue bss       0
         addaq     a7,a_tos,sf_job_stack-sf_monitor_stack
         lx        x9,a7,rbl*8         .last entry in response buffer.
         sx        x9,a7,0             .set first entry in response buffer to
                                       . last entry to avoid returning
                                       . duplicate errors.
         cpyxx     x9,x7               .index of last entry in response buffer.
         brdir     a9,x0               .re-enter routine
         page
..
.        fetch_frc fetch free running counter.
.
.        ENTRY:
.                  x7 = 0, response buffer length.
.
.        EXIT:
.                  a7 = response buffer address.
.                  x7 = byte length of response buffer.
.

fetch_frc bss      0
         addaq     a7,a_tos,sf_job_stack-sf_monitor_stack
         entp      x7,8
         cpytx     x1,x0               .read free running counter
         sx        x1,a7,0
         brreq     x0,x0,complete_function

         page
..
.        calculate new free running counter value.
.
.        ENTRY:
.                  a5 = pointer to requests.
.
.        EXIT:
.                  returned result parameter is the new frc value.
.

cnf      bss       0
         entp      x0,0
         entc      x1,0024
         addpxq    a9,x0,cnf1
         brreq     x0,x0,cwc           .convert hdw wcc to seconds
cnf1     cpyxx     x6,x3
         entc      x1,0016             .mrt wcc
         addpxq    a9,x0,cnf2
         brreq     x0,x0,cwc           .convert mrt wcc to seconds
cnf2     cpyxx     x7,x3
         brxgt     x7,x6,bad_year      .if mrt > hdw time
         lbyts,1   x1,a5,x0,cti_req+26 .hdw wcc year
         lbyts,1   x2,a5,x0,cti_req+18 .mrt wcc year
         brxne     x1,x2,cnf3          .if not same year
         subx      x6,x3
         lx        x1,a5,cti_req+8     .mrt frc
         lx        xc,a5,million
         mulx      x6,xc
         addx      x1,x6
         sx        x1,a5,cti_req+32    .store new frc
         entp      x2,0
         sbyts,2   x2,a5,x0,cti_req    .clear function code
         brreq     x0,x0,wait_for_request   .return
cnf3     entc      x1,0024             .hdw wcc
         addpxq    a9,x0,cnf4
         brreq     x0,x0,norm          .normalize hdw year
cnf4     cpyxx     x8,x3               .hdw year
         entc      x1,0016             .mrt wcc
         addpxq    a9,x0,cnf5
         brreq     x0,x0,norm          .normalize mrt year
cnf5     cpyxx     x9,x3               .mrt year
         entp      x5,0                .year days
         cpyxx     x3,x8
         subx      x3,x9
         entp      x4,1
         brreq     x3,x4,cnf8          .if delta years = 1 year
         cpyxx     x2,x8               .end year
         cpyxx     x3,x9               .start year
         incr      x3,1
cnf6     cpyxx     xa,x3
         entp      x4,4
         divx      xa,x4
         mulxq     xa,xa,4
         brreq     xa,x3,cnf_leap      .if leap year
         addrq     x5,x5,365
cnf7     incr      x3,1
         brreq     x2,x3,cnf8          .start = end years
         brreq     x0,x0,cnf6          .next year
cnf_leap addrq     x5,x5,366
         brreq     x0,x0,cnf7
cnf8     lx        xc,a5,sec_day
         mulx      x5,xc               .seconds in year
         lx        xb,a5,sec_year
         lbyts,1   x2,a5,x0,cti_req+18 .mrt year
         entp      x4,4
         divx      x2,x4
         mulxq     x2,x2,4
         lbyts,1   x4,a5,x0,cti_req+18 .mrt year
         brreq     x2,x4,cnf9          .if leap year
         brreq     x0,x0,cnf10
cnf9     lx        xe,a5,sec_day
         addx      xb,xe
cnf10    subx      xb,x7               .seconds in year - mrt seconds
         addx      xb,x5               .seconds in potential years in between
         addx      xb,x6               .total seconds from mrt wcc to hdw wcc
         lx        x1,a5,cti_req+8     .mrt frc
         addx      x1,xb
         lx        xc,a5,million
         mulx      x1,xc
save_res sx        x1,a5,cti_req+32    .return new frc value
         entp      x2,0
         sbyts,2   x2,a5,x0,cti_req    .clear function code
cnf11    brreq     x0,x0,wait_for_request .return
bad_year entp      x1,0
         brreq     x0,x0,save_res


         page
..
.        calculate validity of free running counter value.
.
.        ENTRY:
.                  a5 = pointer to requests.
.
.        EXIT:
.                  returned result parameter is 1 if valid.
.                  returned result parameter is zero if value is invalid.
.

cfv      bss     0
         cpytx   x1,x0                 .read free running counter
         lx      x2,a5,cti_req+8       .get mrt frc
         brxge   x1,x2,cfv1            .if hdw frc >= mrt frc
cfv0     entp    x1,0                  .mark as invalid
         brreq   x0,x0,cfv2
cfv1     lx      x3,a5,delta           .2 weeks
         addx    x2,x3
         brxgt   x1,x2,cfv0            .if greater than delta also invalid
         entp    x1,1                  .mark as valid
cfv2     sx      x1,a5,cti_req+32
         entp    x0,0
         entp    x2,0
         sbyts,2 x2,a5,x0,cti_req      .clear function code
         brreq   x0,x0,wait_for_request .return

         page
..
.        convert wall clock format to seconds.
.
.        ENTRY:
.                  a5 = pointer to requests.
.                  x1 = offset to wcc cti request word.
.
.        EXIT:
.                  x3 = total seconds
.
cwc      bss     0
         lbyts,1 x2,a5,x1,cti_req+3    .get month
         decr    x2,1                  .for table look up
         cpyxx   x3,x1
         entc    x1,0012
         brrgt   x2,x1,osp$ei_halt     .invalid month
         cpyxx   x1,x3
         mulxq   x2,x2,2
         lbyts,2 x3,a5,x2,day_table    .number of days in year by month
         lbyts,1 x2,a5,x1,cti_req+2    .year
         entp    x4,4
         divx    x2,x4
         mulxq   x2,x2,4
         lbyts,1 x4,a5,x1,cti_req+2    .year
         brreq   x2,x4,leap            .if leap year
seconds  lbyts,1 x2,a5,x1,cti_req+7    .seconds
         lbyts,1 x5,a5,x1,cti_req+6    .minutes
         mulrq   x5,x5,60
         addx    x2,x5
         lbyts,1 x5,a5,x1,cti_req+5    .hours
         mulrq   x5,x5,3600
         addx    x2,x5
         lbyts,1 x5,a5,x1,cti_req+4    .days in this month
         decr    x5,1                  .not through this day yet
         addx    x3,x5                 .add to total days this year
         lx      xc,a5,sec_day
         mulx    x3,xc
         addx    x3,x2
         brdir   a9,x0                 .return
leap     lbyts,1 x2,a5,x1,cti_req+3    .get month
         decx    x2,3
         brxge   x2,x0,leap1
         brreq   x0,x0,seconds         .if before feb 29
leap1    addrq   x3,x3,1               .bump for leap year
         brreq   x0,x0,seconds         .calculate total seconds

day_table bss    0
         vfd,16  0                     .jan 1
         vfd,16  31                    .feb 1
         vfd,16  59                    .mar 1
         vfd,16  90                    .apr 1
         vfd,16  120                   .may 1
         vfd,16  151                   .jun 1
         vfd,16  181                   .jly 1
         vfd,16  212                   .aug 1
         vfd,16  243                   .sep 1
         vfd,16  273                   .oct 1
         vfd,16  304                   .nov 1
         vfd,16  334                   .dec 1
entries  equ     ($-day_table)/2


..
.        normalize year in clock format to 19xx or 20xx.
.
.        ENTRY:
.                  a5 = pointer to requests.
.                  x1 = offset to wcc cti request word.
.
.        EXIT:
.                  x3 = year.
.

norm     bss     0
         lbyts,1 x2,a5,x1,cti_req+2    .get year
         entc    x1,90
         cpyxx   x3,x2
         subx    x3,x1
         brxge   x3,x0,norm1           .if before year 2000
         addrq   x3,x2,2000            .20xx
         brdir   a9,x0                 .return
norm1    addrq   x3,x2,1900            .19xx
         brdir   a9,x0                 .return

         page
..
.        calculate the page table length.
.
.        ENTRY:
.                  a5 = pointer to requests.
.
.        EXIT:
.                  returned result parameter is the page table length.
.

cpi      bss       0
         lx        x1,a5,cti_req+8     .Get CM size in Mb (1Mb to 1Gb)
         lx        x2,a5,cti_req+16    .Page size (2k, 4k, 8k, 16k)
         lx        x3,a5,cti_req+24    .Page table entries (2, 4, 8 entries per page)
         divx      x1,x2               .(CM size / Page size)
         mulx      x1,x3               .* Page table entries
         cpyxx     x2,x1               .Insure modulo 2
         entp      x3,1
         subx      x2,x3               .PTL - 1
         addx      x2,x1               .PTL + PTL - 1
         entp      x3,0                .Initialize shift count
cpi1     shfc      x2,x2,x0,1          .Find most significant bit
         incr      x3,1                .Bump shift count
         brxge     x2,x0,cpi1          .If not found yet
         ente      x2,63
         subx      x2,x3               .Form final shift count
         entp      x1,1
         shfc      x1,x1,x2,0          .Final PTL value
         sx        x1,a5,cti_req+32    .Result
         entp      x2,0
         sbyts,2   x2,a5,x0,cti_req    .clear function code
         brreq     x0,x0,wait_for_request .Return

         page
..
.        osp$halt_ei - This procedure hangs EI when an error condition is encountered
.                  that can not be recovered from.  During initialization the address
.                  of this procedure is stored in 'pva_halt_ei'.  This procedure
.                  moves an error message to the EICB and then hangs EI.
.
.        ENTRY:
.                  a_static = PVA of common working storage area.
.
.        EXIT:     Branch to osp$ei_halt which is a loop on itself.
.

osp$halt_ei bss    0
         la        a_dscb,a_static,pva_of_dscb  .PVA of EICB.
         ente      x1,eml              .set message length.
         lx        x6,a_dscb,d7ty
         isob      x6,x6,x0,52*64+5    .EICB version number.
         decx      x6,4
         brrgt     x0,x6,ohe5          .If EICB version less than 4.

.        EICB version of 4 or greater, has space for a message in the EICB.  Move the
.        message to the EICB and set values to reflect message length and indicate
.        that there is a new message.

         addpxq    a6,x0,damm          .PVA of error message.
         cpyxx     x0,x1               .set source field length.
         movb,a6,x0  a_dscb,x1  1,9,0,0  1,9,0,dfcm+(1*8)  .move message to EICB.
         sbyts,2   x1,a_dscb,x0,dfcm+2 .set message length.

.        Update the processor and model number in the message stored in the EICB.

         entl      x0,r_pid
         entx      x1,c'C'             .processor 0 value.
         cpysx     x6,x0               .get processor number.
         entl      x0,r_eid
         addx      x6,x1               .set character for processor.
         cpysx     x0,x0               .element id.
         sbyts,1   x6,a_dscb,x0,dfcm+(1*8)+14  .update processor in message.
         isob      x6,x0,x0,(40*64)+3  .high order 4 bits of model number.
         entp      x2,9
         entx      x1,c'0'
         brrge     x2,x6,ohe2          .if digit 0 through 9.
         decx      x6,10
         entx      x1,c'A'
ohe2     bss       0
         addx      x6,x1               .convert digit to ascii.
         sbyts,1   x6,a_dscb,x0,dfcm+(1*8)+15  .update high order 4 bits of
                                       . model number.
         isob      x6,x0,x0,(44*64)+3  .low order 4 bits of model number.
         entx      x1,c'0'
         brrge     x2,x6,ohe4          .if digit 0 through 9.
         decx      x6,10
         entx      x1,c'A'
ohe4     bss       0
         addx      x6,x1               .convert digit to ascii.
         lbyts,2   x1,a_dscb,x0,dfcm+6  .set new message in EICB.
         sbyts,1   x6,a_dscb,x0,dfcm+(1*8)+16  .update low order 4 bits of
                                       . model number.
         incx      x1,1
         sbyts,2   x1,a_dscb,x0,dfcm+6 .indicate new message in EICB.
ohe5     bss       0
         brreq     x0,x0,osp$ei_halt   .Hang EI.

eml      equ       24                  .error message length, bytes.

.        Define error message put in EICB.  The error code, "damm" is defined
.        in deck cti$dft_analysis_codes.  If more messages are added the codes
.        should be added to that deck.  The fault symptom code format is
.        'Temmxxx' with the following meaning:
.                   'T' - Environment interface (EI) identifier.
.                   'e' - Processor number, C through F.
.                   'mm' - Model number.
.                   'xxx' - Error code.

damm     vfd,eml*8  c'         ERR=Temm60D    '  .170 mcr fault in monitor mode.
         page
..
.        trap_handler  - This trap handler is set up to process traps for uncorrected
.                  memory errors, all traps are assumed to be uncorrected memory
.                  errors.  The RMA of memory errors are rounded to the minimum page
.                  size boundary.
.
.        INPUT:
.                  a7 = address of response buffer.
.                  a9 = return address if response buffer not full.
.                  x7 = index into response buffer for next entry.
.                  x9 = index of last entry in response buffer.
.                  xa = RMA of bad address.
.
.        EXIT:
.                  x7 = index of next entry in response buffer.
.                  x9 = index of last entry in response buffer.
.                  Return to (a9) if response buffer not full.  Returns to
.                  'complete_function' if buffer is full.
.

         align     0,8
trap_handler bss   0
         lbyts,4   x8,a7,x9,0          .last RMA stored.
         isom      x1,x0,0*64+54
         andx      xa,x1               .round to minimum page size boundary.
         brreq     x8,x1,tmp5          .if in same page as previous error.
         sbyts,4   xa,a7,x7,0          .store rma of bad address
         cpyxx     x9,x7               .save index of last entry.
         incr      x7,4
         ente      x1,(rbl+1)*8
         brrgt     x1,x7,tmp5          .if buffer is not full.
         addpxq    a9,x0,complete_function
tmp5     cpyaa     a0,a2               .update tos register
         pop
         ente      x0,r_te
         cpyxs     x0,x0               .set tef
         brdir     a9,x0
         PAGE
.*******************************************************************
.
.        EI segment and exchange package tables plus some other values
.        that are needed upon reentry of EI.
.
.******************************************************************

nop      bss       1                   .number of processors.
mxp0_p   bss       6                   .pointer to monitor xp, processor 0.

.
.        pva of ei_monitor.
.
         ref       osp$monitor_mode_ei
ei_monitor_pva address  p,osp$monitor_mode_ei

.
.        SEGMENT DESCRIPTOR TABLE.
.
         align     0,8
         def       osp$segment_table
osp$segment_table bss 0
pt_seg   vfd,16    8a11(16)            .Page table entry
pt_asid  vfd,16    4000(16)
         vfd,32    0
.
         vfd,16    0000(16)            .Null segment entry
         vfd,16    00000(16)
         vfd,32    0
.
os_cb_sg vfd,16    0da11(16)           .OS cache bypass segment
         vfd,16    0ffff(16)
         vfd,32    0
.
OS_SEG   vfd,16    9a11(16)            .OS segment entry
OS_ASID  vfd,16    0ffff(16)
         vfd,32    0
.
SF_SEG   vfd,16    8a11(16)            .Stack segment entry
SF_ASID  vfd,16    0c000(16)
         vfd,32    0
.
EI_SEG   vfd,16    0be11(16)           .EI segment entry
EI_ASID  vfd,16    8000(16)
         vfd,32    0
         space     4
.        Define the page table segment ring=1, segment=0
.
pgtable  section   working,read+write
         use       pgtable
pt_pva   bss       0
ring1    bss       0
         use       #lastsec
         space     4
.        Define the OS cache bypass segment ring=1, segment=3
.
os_cache_bypass section   working,read+write
         use       os_cache_bypass
os_cb_pva bss      0
         use       #lastsec
         space     4
.        Define the OS segment ring=1, segment=3
.
osseg    section   working,read+write+execute
         use       osseg
os_pva   bss       0
         use       #lastsec
         space     4
.        Define the stack segment ring=1, segment=4
.
stackseg section   working,read+write
         use       stackseg
stack_pva bss      0
         use       #lastsec
         space     4
.        code based pointers to trap handlers.
.
PCBP     address   ce,trap_handler
         ref       osp$mtr_trap_handler
MCBP     address   ce,osp$mtr_trap_handler
         ref       osp$os_trap_handler
OCBP     address   ce,osp$os_trap_handler
         SPACE     4
..
.        DEFINE NIL POINTER ATTRIBUTE.
.
NIL      EQU       20078
UM       EQU       0FE00(16)           .USER MASK
MM       EQU       mcr_mask            .MONITOR MASK VALUE
PIT      EQU       0FFFF(16)           .INITIAL PIT VALUE
..
.        DEFINE MACRO FOR ADDRESS REGISTERS IN THE C180 EXCHANGE PACKAGE.
.
         PROC
adrg     PNAME
F:(0)    vfd,16    F:(1,1)             .UPPER 16 BIT FIELD
         DO        SC:(F:(2,1))=0
         DO        SN:(F:(2,0))=SN:(NIL)
         vfd,20,28 0FFFF8(16),0        .NIL POINTER
.        ADVF      1
         ELSE
         ADDRESS   R,F:(2,0)
.        ADVF      1
         DEND
         ELSE
         vfd,16,32 F:(2,0),F:(2,1)
.        ADVF      2
         DEND
         PEND
         page
..
.        Define initial contents of EI monitor exchange package.
.        This is the xp that is initially entered by CTI for
.        initialization and when reentering EI.  Some registers
.        are initialized for reentering EI during the initialization.
.

         align     0,16
TMXP     BSS       0                   .MONITOR EXCHANGE PACKAGE
         def       osp$monitor_exchange_package
osp$monitor_exchange_package bss 0
         adrg,0    osp$prepare_os_environment           .P
         adrg,0    stack_pva           .VMID,UVMID, A0
         adrg,0    NIL                 .FLAGS, TRAPS DISABLED, A1
         adrg,UM   NIL                 .USER MASK, A2
         adrg,MM   stack_pva           .MONITOR MASK, A3, a_static
         adrg,0    NIL                 .UCR, A4
         adrg,0    ei_pva              .MCR, A5
         adrg,0    pt_pva              .KEYPOINT CLASS, LPID, A6
         adrg,0    NIL                 .KEYPOINT MASK, A7
         adrg,0    NIL                 .KEYPOINT CODE, A8
         adrg,0    NIL                 .KEYPOINT CODE, A9
         adrg,PIT  NIL                 .PIT, AA
         adrg,PIT  NIL                 .PIT, AB, a_jps
         adrg,0    os_cb_pva           .AC, a_rac
         adrg,0    NIL                 .AD, a_wrk
         adrg,0    os_pva              .AE, a_nos
         adrg,6    NIL                 .PTL, AF, a_dscb
         bss       17*8                .reserve space for X registers
toslst   adrg,0    NIL                 .segment table address
         adrg,osp$segment_table pcbp   .STA, TRAP POINTER
         adrg,0    NIL                 .DEBUG INFORMATION
         adrg,1    NIL                 .LARGEST RING NUMBER, TOS1
         adrg,0    NIL
         adrg,0    NIL
         adrg,0    NIL
         adrg,0    NIL
         adrg,0    NIL
         adrg,0    NIL
         adrg,0    NIL
         adrg,0    NIL
         adrg,0    NIL
         adrg,0    NIL
         adrg,0    NIL
         adrg,0    NIL
         adrg,0    NIL
         adrg,0    NIL
         space     4
.
.        JOB EXCHANGE PACKAGE.
.
TJXP     BSS       0                   .JOB PROCESS EXCHANGE PACKAGE
         def       osp$job_exchange_package
osp$job_exchange_package bss 0
         adrg,0    os_pva              .C170 P
         adrg,0100(16)  NIL            .job stack PVA
         adrg,2    NIL                 .FLAGS, TRAP ENABLES, A1
         adrg,UM   NIL                 .USER MASK, A2
         adrg,MM   ring1+0             .MONITOR MASK, rac
         adrg,0    ring1+200000(8)     .UCR, flc
         adrg,0    ring1               .A5
         adrg,0    ring1               .A6
         adrg,0    ring1               .A7
         adrg,0    ring1               .A8
         adrg,0    ring1               .A9
         adrg,PIT  ring1               .PIT, AA
         adrg,PIT  ring1               .PIT, AB
         adrg,0    ring1               .AC
         adrg,0    ring1               .AD
         adrg,0    ring1               .AE
         adrg,6    ring1               .STL, AF

         end       osp$prepare_os_environment
*DECK DECK=OSM$PROCESSOR_MODEL_EQUATES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Program Management: Processor Model Number and Type Equates' ??
MODULE osm$processor_model_equates;

{ PURPOSE:
{   This module provides a single location for all CPU model-dependent information which the system needs
{   at one time or another.  The variable V$PROCESSOR_MODEL_DEFINITIONS is a table which contains information
{   detailing each CPU model's respective name, class, and attributes which the system software will need for
{   execution.  This table reflects some of the information in Table 1.5-2 of the MIGDS and should be updated
{   each time there is a change in the number of CPU models which Control Data Corporation supports.
{
{   Any additional CPU model-dependent information which is needed should be added to the TYPEs declared below
{   and the table should be updated accordingly.  To update the table, add the required information to the
{   table.  The last entry must always remain the UNKNOWN processor model entry.
{
{ NOTE:
{   Several mainframes have the same hardware processor model number but have different characteristics which
{   make the mainframe unique.  (Example:  The CYBER 2000V mainframe has a hardware processor model number of
{   48(16) and a hardware memory model number of 48(16).  A mainframe with a hardware processor model number
{   of 48(16) amd a hardware memory model number of 46(16) is referred to as a CYBER 2000U mainframe.)  To
{   keep mainframes with the same hardware processor model number separate and unique, pseudo model numbers
{   have been created.  Pseudo model numbers exist as place holders in the V$PROCESSOR_MODEL_DEFINITIONS
{   array.  When a call is made to procedures in this module to return a processor definition, a change is
{   made in the caller's definition to contain the real hardware model number rather then the pseudo model
{   number.  This module should be the only area that uses the pseudo model number.
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osc$processor_defined_registers
*copyc oss$mainframe_pageable
*copyc oss$mainframe_paged_literal
*copyc ost$iou_model_number
*copyc ost$mainframe_classes
*copyc ost$processor_model_definitions
*copyc ost$processor_model_number
*copyc pmt$processor_model_number
*copyc pmt$processor_model_type
?? POP ??
*copyc dsp$retrieve_mf_element_entry
*copyc osp$system_error
?? EJECT ??
*copyc dsv$sub_mainframe_type
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  CONST
    c$max_processor_model_index = 43;

  TYPE
    t$processor_model_index = 0 .. c$max_processor_model_index,

    t$processor_model_definitions = ARRAY [t$processor_model_index] OF ost$processor_model_definition;
?? EJECT ??
?? FMT (FORMAT := OFF) ??
  VAR
    v$global_processor_model_def: [oss$mainframe_pageable] ost$processor_model_definition,
    v$iou_model_number: [oss$mainframe_pageable] ost$processor_model_number,
    v$memory_model_number: [oss$mainframe_pageable] ost$processor_model_number,
    v$processor_model_definitions: [READ, oss$mainframe_paged_literal] t$processor_model_definitions := [

{11}      [osc$cyber_180_model_815,     osc$cyber_180_model_815,     pmc$cyber_180_model_815,
           pmc$cyber_180_model_815_class,   pmc$cyber_180_model_815_class,
           60000, 300000, FALSE, TRUE,  pmc$no_vectors],

{12}      [osc$cyber_180_model_825,     osc$cyber_180_model_825,     pmc$cyber_180_model_825,
           pmc$cyber_180_model_825_class,   pmc$cyber_180_model_825_class,
           50000, 200000, FALSE, TRUE,  pmc$no_vectors],

{13}      [osc$cyber_180_model_830,     osc$cyber_180_model_830,     pmc$cyber_180_model_830,
           pmc$cyber_180_model_830_class,   pmc$cyber_180_model_830_class,
           50000, 200000, FALSE, TRUE,  pmc$no_vectors],

{14}      [osc$cyber_180_model_810,     osc$cyber_180_model_810,     pmc$cyber_180_model_810,
           pmc$cyber_180_model_810_class,   pmc$cyber_180_model_810_class,
           60000, 300000, FALSE, TRUE,  pmc$no_vectors],

{20}      [osc$cyber_180_model_835,     osc$cyber_180_model_835,     pmc$cyber_180_model_835,
           pmc$cyber_180_model_835_class,   pmc$cyber_180_model_835_class,
           40000, 100000, TRUE,  TRUE,  pmc$no_vectors],

{30}      [osc$cyber_180_model_855,     osc$cyber_180_model_855,     pmc$cyber_180_model_855,
           pmc$cyber_180_model_855_class,   pmc$cyber_180_model_855_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

{31}      [osc$cyber_180_model_845,     osc$cyber_180_model_845,     pmc$cyber_180_model_845,
           pmc$cyber_180_model_845_class,   pmc$cyber_180_model_845_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

          { A dual-cpu 860 is an 870 class machine.}

{32}      [osc$cyber_180_model_860,     osc$cyber_180_model_860,     pmc$cyber_180_model_860,
           pmc$cyber_180_model_860_class,   pmc$cyber_180_model_870_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

{33}      [osc$cyber_180_model_850,     osc$cyber_180_model_850,     pmc$cyber_180_model_850,
           pmc$cyber_180_model_850_class,   pmc$cyber_180_model_850_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

{34}      [osc$cyber_180_model_840,     osc$cyber_180_model_840,     pmc$cyber_180_model_840,
           pmc$cyber_180_model_840_class,   pmc$cyber_180_model_840_class,
           40000, 100000, TRUE,  TRUE,  pmc$no_vectors],

{35}      [osc$cyber_180_model_845s,    osc$cyber_180_model_845s,    pmc$cyber_180_model_845s,
           pmc$cyber_180_model_845s_class,  pmc$cyber_180_model_845s_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

{36}      [osc$cyber_180_model_855s,    osc$cyber_180_model_855s,    pmc$cyber_180_model_855s,
           pmc$cyber_180_model_855s_class,  pmc$cyber_180_model_855s_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

{37}      [osc$cyber_180_model_840s,    osc$cyber_180_model_840s,    pmc$cyber_180_model_840s,
           pmc$cyber_180_model_840s_class,  pmc$cyber_180_model_840s_class,
           30000, 50000,  FALSE, FALSE, pmc$no_vectors],

          { A dual-cpu 9603 is a 960-32 machine.}

{3A}      [osc$cyber_900_model_9603,    osc$cyber_900_model_9603,    pmc$cyber_900_model_9603,
           pmc$cyber_900_model_96031_class, pmc$cyber_900_model_96032_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

{3B}      [osc$cyber_900_model_9601,    osc$cyber_900_model_9601,    pmc$cyber_900_model_9601,
           pmc$cyber_900_model_96011_class, pmc$cyber_900_model_96011_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

{3C}      [osc$cyber_900_model_960d,    osc$cyber_900_model_960d,    pmc$cyber_900_model_960d,
           pmc$cyber_900_model_96031_class, pmc$cyber_900_model_96032_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

{3D}      [osc$cyber_900_model_960c,    osc$cyber_900_model_960c,    pmc$cyber_900_model_960c,
           pmc$cyber_900_model_96011_class, pmc$cyber_900_model_96011_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

          { A dual-cpu 990 is a 995 class machine.}

{40}      [osc$cyber_180_model_990,     osc$cyber_180_model_990,     pmc$cyber_180_model_990,
           pmc$cyber_180_model_990_class,   pmc$cyber_180_model_995_class,
           30000, 50000,  TRUE,  TRUE,  pmc$standard_vectors],

          { A dual-cpu 990E is a 995 class machine.}

{41}      [osc$cyber_180_model_990e,    osc$cyber_180_model_990e,    pmc$cyber_180_model_990e,
           pmc$cyber_180_model_990_class,   pmc$cyber_180_model_995_class,
           30000, 50000,  TRUE,  TRUE,  pmc$standard_vectors],

          { A dual-cpu 992 is a 992-32 class machine.}

{42}      [osc$cyber_900_model_992,     osc$cyber_900_model_992,     pmc$cyber_900_model_992,
           pmc$cyber_900_model_99231_class, pmc$cyber_900_model_99232_class,
           30000, 50000,  TRUE,  TRUE,  pmc$standard_vectors],

{43}      [osc$cyber_900_model_992a,    osc$cyber_900_model_992a,    pmc$cyber_900_model_992a,
           pmc$cyber_900_model_99231_class, pmc$cyber_900_model_99232_class,
           30000, 50000,  TRUE,  TRUE,  pmc$standard_vectors],

          { A dual-cpu 994 is a 994-32 class machine.}

{44}      [osc$cyber_900_model_994,     osc$cyber_900_model_994,     pmc$cyber_900_model_994,
           pmc$cyber_900_model_99431_class, pmc$cyber_900_model_99432_class,
           30000, 50000,  TRUE,  TRUE,  pmc$standard_vectors],

{46}      [osc$cyber_2000_model_20s1,   osc$cyber_2000_model_20s1,   pmc$cyber_2000_model_20s1,
           pmc$cyber_2000_model_20s1_class, pmc$cyber_2000_model_20s2_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

{47}      [osc$cyber_2000_model_20u1,   osc$cyber_2000_model_20v1,   pmc$cyber_2000_model_20u1,
           pmc$cyber_2000_model_20u1_class, pmc$cyber_2000_model_20u2_class,
           30000, 50000,  TRUE,  TRUE,  pmc$extended_vectors],

{48}      [osc$cyber_2000_model_20v1,   osc$cyber_2000_model_20v1,   pmc$cyber_2000_model_20v1,
           pmc$cyber_2000_model_20v1_class, pmc$cyber_2000_model_20v2_class,
           30000, 50000,  TRUE,  TRUE,  pmc$extended_vectors],

{51}      [osc$cyber_180_model_930d,    osc$cyber_180_model_930d,    pmc$cyber_180_model_930d,
           pmc$cyber_180_model_930d_class,  pmc$cyber_180_model_930d_class,
           50000, 200000, TRUE,  TRUE,  pmc$no_vectors],

{52}      [osc$cyber_180_model_9303,    osc$cyber_180_model_9303,    pmc$cyber_180_model_9303,
           pmc$cyber_180_model_93031_class, pmc$cyber_180_model_93031_class,
           40000, 100000, TRUE,  TRUE,  pmc$no_vectors],

{53}      [osc$cyber_180_model_9301,    osc$cyber_180_model_9301,    pmc$cyber_180_model_9301,
           pmc$cyber_180_model_93011_class, pmc$cyber_180_model_93011_class,
           50000, 200000, TRUE,  TRUE,  pmc$no_vectors],

{54}      [osc$cyber_900_model_9323,    osc$cyber_900_model_9323,    pmc$cyber_900_model_9323,
           pmc$cyber_900_model_93231_class, pmc$cyber_900_model_93232_class,
           40000, 100000, TRUE,  FALSE, pmc$no_vectors],

{55}      [osc$cyber_900_model_9321,    osc$cyber_900_model_9321,    pmc$cyber_900_model_9321,
           pmc$cyber_900_model_93211_class, pmc$cyber_900_model_93211_class,
           50000, 200000, TRUE,  FALSE, pmc$no_vectors],

{5B}      [osc$cyber_180_model_930a,    osc$cyber_180_model_930a,    pmc$cyber_180_model_930a,
           pmc$cyber_180_model_930a_class,  pmc$cyber_180_model_930a_class,
           50000, 200000, TRUE,  TRUE,  pmc$no_vectors],

{5C}      [osc$cyber_900_model_932a,    osc$cyber_900_model_932a,    pmc$cyber_900_model_932a,
           pmc$cyber_900_model_932a_class,  pmc$cyber_900_model_932a_class,
           40000, 100000, TRUE,  FALSE, pmc$no_vectors],

{5D}      [osc$cyber_180_model_930b,    osc$cyber_180_model_930b,    pmc$cyber_180_model_930b,
           pmc$cyber_180_model_930b_class,  pmc$cyber_180_model_930b_class,
           40000, 100000, TRUE,  TRUE,  pmc$no_vectors],

{5E}      [osc$cyber_180_model_930c,    osc$cyber_180_model_930c,    pmc$cyber_180_model_930c,
           pmc$cyber_180_model_930c_class,  pmc$cyber_180_model_930c_class,
           50000, 200000, TRUE,  TRUE,  pmc$no_vectors],

{5F}      [osc$cyber_900_model_932b,    osc$cyber_900_model_932b,    pmc$cyber_900_model_932b,
           pmc$cyber_900_model_932b_class,  pmc$cyber_900_model_932b_class,
           40000, 100000, TRUE,  FALSE, pmc$no_vectors],

{F8}      [osc$cyber_900_model_9703,    osc$cyber_900_model_9603,    pmc$cyber_900_model_9703,
           pmc$cyber_900_model_97031_class, pmc$cyber_900_model_97032_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

{F9}      [osc$cyber_900_model_9701,    osc$cyber_900_model_9601,    pmc$cyber_900_model_9701,
           pmc$cyber_900_model_97011_class, pmc$cyber_900_model_97011_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

{FA}      [osc$cyber_900_model_970d,    osc$cyber_900_model_960d,    pmc$cyber_900_model_970d,
           pmc$cyber_900_model_97031_class, pmc$cyber_900_model_97032_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

{FB}      [osc$cyber_900_model_970c,    osc$cyber_900_model_960c,    pmc$cyber_900_model_970c,
           pmc$cyber_900_model_97011_class, pmc$cyber_900_model_97011_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

{FC}      [osc$cyber_900_model_9723,    osc$cyber_900_model_9603,    pmc$cyber_900_model_9723,
           pmc$cyber_900_model_97231_class, pmc$cyber_900_model_97232_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

{FD}      [osc$cyber_900_model_9721,    osc$cyber_900_model_9601,    pmc$cyber_900_model_9721,
           pmc$cyber_900_model_97211_class, pmc$cyber_900_model_97211_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

{FE}      [osc$cyber_900_model_972d,    osc$cyber_900_model_960d,    pmc$cyber_900_model_972d,
           pmc$cyber_900_model_97231_class, pmc$cyber_900_model_97232_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

{FF}      [osc$cyber_900_model_972c,    osc$cyber_900_model_960c,    pmc$cyber_900_model_972c,
           pmc$cyber_900_model_97211_class, pmc$cyber_900_model_97211_class,
           30000, 50000,  TRUE,  TRUE,  pmc$no_vectors],

{UNKNOWN} [osc$cyber_180_model_unknown, osc$cyber_180_model_unknown, pmc$cyber_180_model_unknown,
           pmc$cyber_180_unknown_class,     pmc$cyber_180_unknown_class,
           30000, 50000,  FALSE, FALSE, pmc$no_vectors]];
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
?? NEWTITLE := 'convert_to_pseudo_model_number', EJECT ??

{ PURPOSE:
{   This procedure converts the real hardware model number into the pseudo model number.
{
{   1)  A Cyber 2000 mainframe with a CPU model number of 48(16) and a Memory model number of 46(16)
{       becomes known as a '20U1' mainframe.
{
{   2)  The 960x group of mainframes with a Memory model number of 35(16) and an Iou model number of 40(16)
{       becomes known as 970x mainframes.
{
{   3)  The 960x group of mainframes with a Memory model number of 35(16) and an Iou model number of 44(16)
{       becomes known as 972x mainframes.

  PROCEDURE convert_to_pseudo_model_number
    (    real_hardware_model_number: ost$processor_model_number;
     VAR pseudo_model_number: ost$processor_model_number);

    CONST
      c$memory_model_35 = 35(16),  {4 mega bit DRAM chip.
      c$memory_model_46 = 46(16);

    pseudo_model_number := real_hardware_model_number;

    { Determine the pseudo_model_number for mainframes with a Memory model number 35(16).

    IF v$memory_model_number = c$memory_model_35 THEN

      { 960x mainframes with a memory model 35(16) and a I4 primary IOU are referred to as 970x mainframes.

      IF v$iou_model_number = osc$imn_40 THEN
        IF real_hardware_model_number = osc$cyber_900_model_9603 THEN
          pseudo_model_number := osc$cyber_900_model_9703;
        ELSEIF real_hardware_model_number = osc$cyber_900_model_9601 THEN
          pseudo_model_number := osc$cyber_900_model_9701;
        ELSEIF real_hardware_model_number = osc$cyber_900_model_960d THEN
          pseudo_model_number := osc$cyber_900_model_970d;
        ELSEIF real_hardware_model_number = osc$cyber_900_model_960c THEN
          pseudo_model_number := osc$cyber_900_model_970c;
        IFEND;

      { 960x mainframes with a memory model 35(16) and a I4C primary IOU are referred to as 972x mainframes.

      ELSEIF v$iou_model_number = osc$imn_44 THEN
        IF real_hardware_model_number = osc$cyber_900_model_9603 THEN
          pseudo_model_number := osc$cyber_900_model_9723;
        ELSEIF real_hardware_model_number = osc$cyber_900_model_9601 THEN
          pseudo_model_number := osc$cyber_900_model_9721;
        ELSEIF real_hardware_model_number = osc$cyber_900_model_960d THEN
          pseudo_model_number := osc$cyber_900_model_972d;
        ELSEIF real_hardware_model_number = osc$cyber_900_model_960c THEN
          pseudo_model_number := osc$cyber_900_model_972c;
        IFEND;
      IFEND;

    { Determine the pseudo_model_number for 2000 mainframes with a CPU model number 48(16) and a Memory model
    { number 46(16).

    ELSEIF (real_hardware_model_number = osc$cyber_2000_model_20v1) AND
          (v$memory_model_number = c$memory_model_46) THEN
      pseudo_model_number := osc$cyber_2000_model_20u1;

    IFEND;

  PROCEND convert_to_pseudo_model_number;
?? OLDTITLE ??
?? NEWTITLE := 'osp$check_for_desired_mf_class', EJECT ??

{ PURPOSE:
{   This procedure determines if the mainframe currently running is of the desired class.

  PROCEDURE [XDCL, #GATE] osp$check_for_desired_mf_class
    (    desired_class: ost$mainframe_classes;
     VAR desired_class_found: boolean);

    CASE desired_class OF
    = osc$mc_china_class =
      desired_class_found := (dsv$sub_mainframe_type = dsc$smt_china_mainframe);
    = osc$mc_soviet_class =
      desired_class_found := (dsv$sub_mainframe_type = dsc$smt_soviet_mainframe);
    = osc$mc_china_or_soviet_class =
      desired_class_found := ((dsv$sub_mainframe_type = dsc$smt_china_mainframe) OR
            (dsv$sub_mainframe_type = dsc$smt_soviet_mainframe));
    ELSE
      desired_class_found := FALSE;
    CASEND;

  PROCEND osp$check_for_desired_mf_class;
?? OLDTITLE ??
?? NEWTITLE := 'osp$convert_to_real_model_num', EJECT ??

{ PURPOSE:
{   This procedure converts the pseudo cpu model number into the real hardware cpu model number.

  PROCEDURE [XDCL, #GATE] osp$convert_to_real_model_num
    (    pseudo_model_number: ost$processor_model_number;
     VAR real_model_number: ost$processor_model_number);

    IF (pseudo_model_number = osc$cyber_900_model_9703) OR
          (pseudo_model_number = osc$cyber_900_model_9723) THEN
      real_model_number := osc$cyber_900_model_9603;
    ELSEIF (pseudo_model_number = osc$cyber_900_model_9701) OR
          (pseudo_model_number = osc$cyber_900_model_9721) THEN
      real_model_number := osc$cyber_900_model_9601;
    ELSEIF (pseudo_model_number = osc$cyber_900_model_970d) OR
          (pseudo_model_number = osc$cyber_900_model_972d) THEN
      real_model_number := osc$cyber_900_model_960d;
    ELSEIF (pseudo_model_number = osc$cyber_900_model_970c) OR
          (pseudo_model_number = osc$cyber_900_model_972c) THEN
      real_model_number := osc$cyber_900_model_960c;
    ELSEIF pseudo_model_number = osc$cyber_2000_model_20u1 THEN
      real_model_number := osc$cyber_2000_model_20v1;
    ELSE
      real_model_number := pseudo_model_number;
    IFEND;

  PROCEND osp$convert_to_real_model_num;
?? OLDTITLE ??
?? NEWTITLE := 'osp$get_cpu_model_definition', EJECT ??

{ PURPOSE:
{   This procedure retrieves the processor model definition for a specific model number.  Searching by real
{   model number is only valid when running on the actual machine.

  PROCEDURE [XDCL, #GATE] osp$get_cpu_model_definition
    (    search_data: ost$processor_search_data;
     VAR definition_found: boolean;
     VAR processor_model_definition: ost$processor_model_definition);

    VAR
      index: t$processor_model_index,
      pseudo_model_number: ost$processor_model_number;

    definition_found := FALSE;

    IF search_data.search_mode = osc$psm_by_pseudo_model_number THEN
      FOR index := LOWERBOUND (v$processor_model_definitions) TO UPPERBOUND (v$processor_model_definitions) DO
        IF v$processor_model_definitions [index].pseudo_model_number = search_data.pseudo_model_number THEN
          definition_found := TRUE;
          processor_model_definition := v$processor_model_definitions [index];
          RETURN;
        IFEND;
      FOREND;

    ELSEIF search_data.search_mode = osc$psm_by_real_model_number THEN
      convert_to_pseudo_model_number (search_data.real_model_number, pseudo_model_number);
      FOR index := LOWERBOUND (v$processor_model_definitions) TO UPPERBOUND (v$processor_model_definitions) DO
        IF v$processor_model_definitions [index].pseudo_model_number = pseudo_model_number THEN
          definition_found := TRUE;
          processor_model_definition := v$processor_model_definitions [index];
          RETURN;
        IFEND;
      FOREND;

    ELSE  {search_data.search_mode = osc$psm_by_model_number_string}
      FOR index := LOWERBOUND (v$processor_model_definitions) TO UPPERBOUND (v$processor_model_definitions) DO
        IF v$processor_model_definitions [index].model_number_string = search_data.model_number_string THEN
          definition_found := TRUE;
          processor_model_definition := v$processor_model_definitions [index];
          RETURN;
        IFEND;
      FOREND;
    IFEND;

  PROCEND osp$get_cpu_model_definition;
?? OLDTITLE ??
?? NEWTITLE := 'osp$get_global_cpu_model_def', EJECT ??

{ PURPOSE:
{   This procedure retrieves the global processor model definition.

  PROCEDURE [XDCL, #GATE] osp$get_global_cpu_model_def
    (VAR global_processor_model_def: ost$processor_model_definition);

    global_processor_model_def := v$global_processor_model_def;

  PROCEND osp$get_global_cpu_model_def;
?? OLDTITLE ??
?? NEWTITLE := 'osp$set_global_cpu_model_def', EJECT ??

{ PURPOSE:
{   This procedure sets the global processor model information definition.

  PROCEDURE [XDCL, #GATE] osp$set_global_cpu_model_def;

    TYPE
      t$integer_or_element_id = RECORD
        CASE boolean OF
        = TRUE =
          integer_part: integer,
        = FALSE =
          rfu: 0 .. 0ffffffff(16),
          element_number: 0 .. 0ff(16),
          model_number: 0 .. 0ff(16),
          serial_number: 0 .. 0ffff(16),
        CASEND,
      RECEND;

    VAR
      definition_found: boolean,
      element_entry: dst$mf_element_table_entry,
      integer_or_element_id: t$integer_or_element_id,
      local_status: ost$status,
      search_data: ost$processor_search_data;

    dsp$retrieve_mf_element_entry (0, dsc$dftb_eid_memory_element, element_entry, local_status);
    IF NOT local_status.normal THEN
      osp$system_error (' Memory element entry not found.', NIL);
    IFEND;
    v$memory_model_number := element_entry.model_number;

    dsp$retrieve_mf_element_entry (0, dsc$dftb_eid_iou0_element, element_entry, local_status);
    IF NOT local_status.normal THEN
      osp$system_error (' IOU element entry not found.', NIL);
    IFEND;
    v$iou_model_number := element_entry.model_number;

    integer_or_element_id.integer_part := #READ_REGISTER (osc$pr_element_id);

    search_data.search_mode := osc$psm_by_real_model_number;
    search_data.real_model_number := integer_or_element_id.model_number;
    osp$get_cpu_model_definition (search_data, definition_found, v$global_processor_model_def);
    IF NOT definition_found THEN
      osp$system_error (' Processor model number unsupported.', NIL);
    IFEND;

  PROCEND osp$set_global_cpu_model_def;
?? OLDTITLE ??
MODEND osm$processor_model_equates;
*DECK DECK=OSM$PROCESS_ERROR_CONDITIONS EXPAND=TRUE
osm$process_error_conditions IDENT
         list      1,1,0
         title     c'Process OS error conditions'
         space     4
.        TRADE SECRET - PROPRIETARY NOTICE.
.        COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
.        The material contained herein is the property of Control Data
.        Systems Inc and is intended soley for use in the  performance
.        of  contracted  Maintenance  under a Control Data maintenance
.        services agreement.  This material is proprietary to  Control
.        Data  Systems Inc  and  is  not to be disclosed other than to
.        employees  of  Control  Data  Systems Inc  or  other  persons
.        specifically authorized to have access to  this  material  in
.        accordance  with  the  terms and conditions of a Control Data
.        maintenance services agreement.
         page
*copy asmregs
*copy osa$ei_constant_definitions
*copy osa$ei_stack_frame
         page
C180EI   SECTION   working,read+execute+write,,0,8
         USE       C180EI
         space     4
..
.        OSP$A170_FATAL_ERROR - This module is called to process 170 OS
.        error conditions.  It is not called with a CALL instruction but
.        by branching here with the return address set in an A register.
.
.        Entry conditions:
.
.        a2    = pointer to previous save area, NIL if called from EI and
.                non NIL if called from NOS/VE.  This module has to be
.                able to determine in which mode it is running.
.        a8    = pva to return to.
.        a_jps = PVA OF TJXP
.        a_static = PVA of EI static storage, not set when called from NOS/VE.
.        a_wrk = PVA OF EI DATA AREA
.        a_nos = PVA OF OPERATING SYSTEM
.        X4    = VMID of JPS package.
.        X6    = Masked MCR.
.
.        Exit conditions:
.
.        x6 = 0 if non fatal error, = 1 if fatal error.
.

         def       osp$a170_fatal_error
osp$a170_fatal_error bss 0             .entry to process fatal error
         shfx      x1,x6,x0,48         .mcr bit 48
         ente      x8,perror
         brxgt     x0,x1,mcr01         .if DUE error
         ente      x8,gencode
mcr01    brreq     x4,x0,abp01         .if failure in 180 process.
         ente      x1,mcr_mask-bit_57
         andx      x1,x6
         brrne     x1,x0,abp03         .if unusual MCR bit set except page fault.
         brrne     x6,x0,mcr02         .if page fault set

.        No interesting MCR bits set, assume UCR bit set.

         entl      x0,BEMHF
         lbit      x1,a_jps,xp_emhf,X0 .GET EXIT MODE HALT FLAG
         brreq     x1,x0,abp03         .if exit mode halt not set

.        Fatal error in 170 monitor mode, halt the process.

stop170  bss       0
         cpyax     x3,a2
         brrgt     x0,x3,stop170_5     .if running in 170 standalone mode.

.        Running in dual state mode, set error flag and return.

         entp      x6,1                .set 170 fatal error.
         brdir     a8,x0               .return to caller.

.        Running in 170 standalone mode.

stop170_5 bss      0
         la        a7,a_static,pva_halt_ei
         brdir     a7,x0               .fake cpu halt
.
.  Process page fault on C170 process.
.
mcr02    la        aa,a_jps,xp_p       .load and verify P
         tpage     x3,aa
         brrgt     x0,x3,abp03         .if page fault on P
         isob      x1,x3,x0,7501(8)    .parcel number
         ente      x2,100(8)*15
         shfx      x3,x3,x0,-3         .form word address relative to C170
         mulx      x2,x1
         lxi       x1,a_nos,x3,0       .fetch word with instruction
         isob      x1,x1,x2,0410(8)    .isolate instruction opcode
         entp      x2,014(8)
         brrne     x2,x1,abp03         .if not and ECS instruction
         entp      x8,1                .set mode 1
         entp      x0,7
         lbit      x1,a_jps,xp_em+1,x0 .fetch mode 1 bit
         brrne     x1,x0,abp03         .if job should be aborted
         addaq     aa,aa,2             .increment and update P
         sa        aa,a_jps,xp_p
         entp      x6,0                .set 170 non fatal error.
         brdir     a8,x0               .restart job
         space     4
..       Abort A170 job with predefined error.  The request to abort the job
.        came from the 180 process.  The jps exchange package contains a 180
.        process and the 170 process registers are in the previous stack frame
.        save area.
.

         def       osp$abort_a170_job
osp$abort_a170_job bss 0               .entry to process system call
         LX        x8,a_jps,xp_x0+2*8  .EXIT CONDITION IN C180 x8
         space     4
..
.        ABP       - Abort process.  There are 2 entry points into this routine:
.                       abp01 - if failure in the 180 process.  This sort of failire
.                               occurs in the 170 trap handler which is a 180 process.
.                       abp03 - if failure in the 170 process.
.
.        Entry conditions.
.                  a_jps = PVA of failing 170 exchange package.
.                  a_nos = PVA of first byte of host operating system.
.                  a_wrk = pointer to EI data area.
.                  a8 = pva to return to.
.                  x8 = mode error number.
.                  x4 = VMID of process.
.



.        Abort process that failed in 180.  Failure is in the 170 trap handler.
.        Save the failing process in the save area and then move the 170 process
.        to the job exchange package.


abp01    bss       0

.        Move the job exchange package to the save area, this is a 180 process.

         movb,a_jps,x0  a_wrk,x1  0,9,25*8,0  0,9,25*8,sf_save_job+0
         movb,a_jps,x0  a_wrk,x1  0,0,27*8,25*8  0,9,27*8,sf_save_job+25*8

.        Move the Stack Frame Save Area contents of the 170 process to the job
.        exchange package.

         la        aa,a_jps,xp_a0+2*8  .get stack pointer
         MOVB,aa,X0  a_jps,X1 0,9,123,xp_x0  0,9,123,xp_x0
         ente      x2,xp_x0
         entp      X3,0
abp02    lbyts,6   X1,aa,X3,xp_p
         sbyts,6   X1,a_jps,X3,xp_p
         incr      X3,8
         brrne     x3,x2,abp02         .if more to move
         entp      x1,1
         sbyts,1   x1,a_jps,x0,xp_vmid .set vmid to 1

.        Now abort the 170 process that invoked the 180 process.


.        Abort the 170 process.  Store 170 error information at RA+0 of process.

abp03    sbyts,1   x8,a_wrk,x0,sf_exit_condition
         lbyts,4   X1,a_jps,X0,xp_p+2  .GET C170 P ADDRESS + RA
         lbyts,3   X2,a_jps,X0,xp_rac  .GET C170 RA
         SHFX      X1,X1,X0,-3         .C170 P WORD ADDRESS + RA
         SUBX      X1,X2               .C170 P WORD ADDRESS
         SHFC      X8,X8,X0,63-15      .EXIT CONDITION TO BITS 48 - 53
         SHFC      X1,X1,X0,63-33      .P REGISTER TO BITS 30 - 47
         IORX      X8,X1               .merge exit condition.
         ente      x1,15(8)            .'M' in display code.
         brrne     x6,x0,abp10         .if MCR has bits set.

.        MCR is zero, store UCR.

         lbyts,2   x6,a_jps,x0,xp_ucr  .UCR from failing xp.
         ente      x1,25(8)            .'U' in display code.
abp10    bss       0
         iorx      X8,X6               .merge MCR or UCR.
         shfc      x1,x1,x0,18         .position UCR/MCR designator.
         iorx      x8,x1               .merge UCR/MCR designator.
         SXI       X8,a_nos,X2,0       .STORE ERROR EXIT WORD AT RA
         entl      X0,BMF              .C170 MONITOR FLAG BIT ADDRESS
         lbit      xf,a_jps,xp_mf,X0   .GET C170 MONITOR FLAG
         sbit      xf,a_jps,xp_emhf,x0 .set exit mode halt flag
         brrne     xf,x0,stop170       .if monitor flag set
         brreq     x4,x0,pjec0         .if exchange package already copied
         movb,a_jps,x0  a_wrk,x1  0,9,25*8,0  0,9,25*8,sf_save_job+0
         movb,a_jps,x0  a_wrk,x1  0,0,27*8,25*8  0,9,27*8,sf_save_job+25*8
         brreq     x0,x0,pjec0         .emulate c170 exchange
         PAGE
...
.
.        THE  C170  VIRTUAL MACHINE WAS EXECUTING IN PROGRAM MODE WHEN
.        THE EXIT CONDITION OCCURRED.  THIS  REQUIRES  THAT  THE  C170
.        EXCHANGE  PACKAGE  LOCATED  AT THE ADDRESS IN THE MA FIELD OF
.        THE C180 EXCHANGE PACKAGE  MUST  BE  SWAPPED  WITH  THE  C170
.        EXCHANGE  PACKAGE CONTAINED IN THE C180 PACKAGE.  THE MONITOR
.        FLAG MUST BE SET IN THE C180 PACKAGE  AND  THE  MCR  MUST  BE
.        CLEARED.   When this processing is complete the routine goes
.        to the PVA in A8 where EI exchanges back to the C170 process.
.
pjec0    ADDAQ     aa,a_wrk,sf_170_xp_buffer
         CPYAX     X7,a_dscb
.
.        Purge all cache so that no stale C170 data is picked up from
.        cache.
.
         PURGE     x7,2                .Purge all cache
.
.        pack job exchange package to buffer.
.
         MOVB,a_jps,X0  AA,X1 0,9,64,xp_cx0  0,9,64,ma_x0
.
.        GET ALL OTHER REGISTERS AND INFO FROM TJXP, COMBINE THIS IN
.        C170 EXCHANGE PACKAGE FORMAT, AND STORE RESULTING 8 WORDS
.        into the buffer.
.
         ENTE      X0,0100F(16)
         LMULT     X0,a_jps,xp_ca0/8*8    .GET A AND B REGISTERS FROM XP
         INSB      X8,X0,X0,M18        .COMBINE A AND B REGS, P=0
         INSB      X9,X1,X0,M18
         INSB      XA,X2,X0,M18
         INSB      XB,X3,X0,M18
         INSB      XC,X4,X0,M18
         INSB      XD,X5,X0,M18
         INSB      XE,X6,X0,M18
         INSB      XF,X7,X0,M18
         ISOM      X1,X0,3443(8)
         ANDX      X8,X1
         ANDX      X9,X1
         ANDX      XA,X1
         ANDX      XB,X1
         ANDX      XC,X1
         ANDX      XD,X1
         ANDX      XE,X1
         ANDX      XF,X1
         LBYTS,3   X2,a_jps,X0,xp_rac  .GET RA
         SHFX      X1,X2,X0,3          .SAVE RA BYTE OFFSET
         SHFX      X2,X2,X0,36
         IORX      X9,X2               .RA,A1,B1
         LBYTS,3   X7,a_jps,X0,xp_flc  .GET FL
         SHFX      X7,X7,X0,36
         IORX      XA,X7               .FL,A2,B2
         LBYTS,2   X2,a_jps,X0,xp_em   .GET EXIT MODE SELECTIONS
         ISOB      X2,X2,X0,6413(8)
         INSB      XB,X2,X0,0413(8)    .EM, A3, B3
         LBYTS,3   x3,a_jps,X0,xp_ma   .GET MONITOR ADDRESS
         shfx      x2,x3,x0,3          .save ma byte address
         SHFX      x3,x3,X0,36
         IORX      XE,X3               .MA, A6, B6
         LBYTS,4   X7,a_jps,X0,xp_rae  .GET ECS RA
         SHFX      X7,X7,X0,36
         IORX      XC,X7               .RAE, A4, B4
         LBYTS,4   X7,a_jps,X0,xp_fle  .GET ECS FL
         SHFX      X7,X7,X0,36
         IORX      XD,X7               .FLE, A5, B5
         ENTE      X3,0180F(16)
         SMULT     X3,AA,0             .STORE 1ST 8 WORDS OF C170 XP
         entl      x0,3                .bit 3 = 00010000 = 20(8)
         lbit      x5,a_wrk,sf_exit_condition,x0 .fetch hardware error bit
         ENTL      X0,BMHDWRE
         SBIT      X5,AA,ma_hrdwe,X0   .SET HARDWARE ERROR FLAG
.
.        NOW MOVE THE A, B, X, AND ENVIRONMENT REGISTERS FROM TXPBUF
.        TO THE C180 XP AT TJXP.
.
         CPYAA     AA,a_nos
         ADDAX     aa,x2               .pva for MA
PJEC1    ENTN      XF,7                .INITIALIZE LOOP COUNTER
         ENTP      XC,0                .BYTE OFFSET
PJEC2    LBYTS,3   XA,aa,XC,ma_b0      .GET B REGISTER FIELD
         ISOB      XA,XA,X0,5621(8)    .ISOLATE B REGISTER
         SBYTS,3   XA,a_jps,XC,xp_cb0  .STORE B REGISTER IN TJXP
         INCR      XC,8
         BRINC     X0,XF,PJEC2         .IF MORE B REGISTERS
         ENTP      XC,0
         ENTN      XF,7
PJEC3    LBYTS,3   XA,aa,XC,ma_a0      .GET A REGISTER FIELD
         ISOB      XA,XA,X0,5421(8)
         SBYTS,3   XA,a_jps,XC,xp_ca0  .STORE A REGISTER IN TJXP
         INCR      XC,8
         BRINC     X0,XF,PJEC3         .IF MORE A REGISTERS
         ENTP      XC,0
         ENTN      XF,7
PJEC4    LBYTS,8   XA,aa,XC,ma_x0      .GET X REGISTER
         SHFX      XA,XA,X0,4          .SIGN EXTEND X REGISTER
         SHFX      XA,XA,X0,-4
         SBYTS,8   XA,a_jps,XC,xp_cx0  .STORE X REGISTER IN TJXP
         INCR      XC,8
         BRINC     X0,XF,PJEC4         .IF MORE X REGISTERS
         LX        XB,aa,ma_rac/8*8    .GET RAC FIELD
         ISOB      XB,XB,X0,0724(8)
         SBYTS,3   XB,a_jps,X0,xp_rac  .STORE RAC IN TJXP
         LX        XA,aa,ma_flc/8*8    .GET FLC FIELD
         ISOB      XA,XA,X0,0724(8)
         SBYTS,3   XA,a_jps,X0,xp_flc  .STORE FLC IN TJXP
         LBYTS,3   XA,aa,X0,ma_p       .GET P REGISTER
         ISOB      XA,XA,X0,5221(8)
         ADDX      XA,XB               .ADD REFERENCE ADDRESS
         SHFX      XA,XA,X0,3          .CHANGE TO BYTE ADDRESS
         sbyts,4   xa,a_jps,x0,xp_p+2
         LBYTS,3   XA,aa,X0,ma_ma      .GET MONITOR ADDRESS
         ISOB      XA,XA,X0,5221(8)
         SBYTS,3   XA,a_jps,X0,xp_ma   .STORE MA IN TJXP
         LBYTS,2   XB,aa,X0,ma_em      .GET EXIT MODE BITS
         LX        XF,a_jps,xp_em/8*8  .FETCH WORD WITH EM
         INSB      XF,XB,X0,2413(8)    .INSERT NEW EXIT MODE
         SX        XF,a_jps,xp_em/8*8    .STORE EM INTO TJXP
         LBYTS,4   XB,aa,X0,ma_rae     .GET RAE FIELD
         SHFX      XB,XB,X0,27-31
         SBYTS,4   XB,a_jps,X0,xp_rae  .STORE RAE IN TJXP
         LBYTS,4   XA,aa,X0,ma_fle     .GET FLE FIELD
         SHFX      XA,XA,X0,27-31
         SBYTS,4   XA,a_jps,X0,xp_fle  .STORE FLE IN TJXP
         ENTL      X0,BMF
         ENTP      XF,01(16)
         SBIT      XF,a_jps,xp_mf,X0   .SET C170 MONITOR FLAG
.
.        copy exchange package in buffer to (ma).
.
         movb,a_wrk,x0  aa,x1  0,9,16*8,sf_170_xp_buffer  0,9,16*8,0
         entp      x6,0                .set 170 non fatal error.
         brdir     a8,x0               .return to caller
.
         end
*DECK DECK=OSM$RECOVERABLE_SYSTEM_ERROR EXPAND=TRUE
?? RIGHT := 110 ??
MODULE osm$recoverable_system_error;

{ PURPOSE:
{   This module contains procedures necessary to process recoverable system
{ errors.  A recoverable system error is a system error for which the
{ integrity of the system would be improved by allowing the procedure that
{ detected the error to continue execution following the recording of the
{ error.  System debugging is facilitated by invoking the system core debugger
{ when the error is detected at or below the debug ring.
{
{ DESIGN:
{   The procedures of this module are required to have a ring bracket of
{ (2, 3, D) to allow access to the haltring and the system log while being
{ callable from all job template code.

?? TITLE := 'Global External Procedures', EJECT ??
*copyc clp$convert_integer_to_rjstring
*copyc clp$get_processing_phase
*copyc ocp$find_debug_address
*copyc osp$log_system_error
*copyc osp$system_error
*copyc osp$unpack_status_condition
*copyc pfp$log_ascii
*copyc pmp$log_ascii
*copyc syp$invoke_system_debugger
?? TITLE := 'Global External Type Declarations', EJECT ??
*copyc mtv$halt_cpu_ring_number
*copyc osd$registers
*copyc osk$keypoints
*copyc ost$caller_identifier
*copyc osv$control_codes_to_quest_mark
*copyc tmv$halt_on_hung_task
  TYPE
    sfsa_type = record
      fill1: 0 .. 0ffff(16),
      p: ^cell,
      a0: integer,
      a1: integer,
      fill2: 0 .. 0ffff(16),
      a2: ^sfsa_type, {previous save area pointer}
    recend;
?? TITLE := '*** OSP$LOG_UNFORMATTED_STATUS ***', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$log_unformatted_status
    (    p_status: ^ost$status;
         ascii_logset: pmt$ascii_logset;
         message_origin: pmt$log_msg_origin;
         critical_message: boolean);

    VAR
      condition_code: ost$status_condition_number,
      condition_identifier: ost$status_identifier,
      local_status: ost$status,
      message_size: integer,
      message_text: string (osc$max_string_size + 12);

    IF p_status <> NIL THEN
      osp$unpack_status_condition (p_status^.condition, condition_identifier, condition_code);
      #TRANSLATE (osv$control_codes_to_quest_mark, p_status^.text.value (1, p_status^.text.size),
            local_status.text.value (1, p_status^.text.size));
      STRINGREP (message_text, message_size, condition_identifier, condition_code, ' ',
            local_status.text.value (1, p_status^.text.size));
      pfp$log_ascii (message_text (1, message_size), ascii_logset, message_origin, critical_message,
            local_status);
    IFEND;
  PROCEND osp$log_unformatted_status;
?? TITLE := '*** OSP$RECOVERABLE_SYSTEM_ERROR ***', EJECT ??
*copyc osh$recoverable_system_error

  PROCEDURE [XDCL, #GATE] osp$recoverable_system_error
    (    error_message: string ( * );
         p_status: ^ost$status);

    CONST
      critical_message = TRUE,
      number_of_calls_to_display = 16;

    VAR
      caller_id: ost$caller_identifier,
      local_status: ost$status,
      logset: pmt$ascii_logset,
      p_caller_p_register: ^ost$p_register,
      processing_phase: clt$processing_phase,
      stack: integer,
      sfsa_p: ^sfsa_type; {pointer to previous stack frame save area}

    #caller_id (caller_id);
    #keypoint (osk$entry, osk$m * caller_id.ring, osk$recoverable_system_error);
    IF caller_id.ring <= mtv$halt_cpu_ring_number THEN
      osp$system_error (error_message, p_status);
    IFEND;
    osp$log_system_error (error_message, 'RECOVERABLE SYSTEM ERROR - ');
    p_caller_p_register := #previous_save_area ();
    log_p_register (p_caller_p_register^, $pmt$ascii_logset [pmc$system_log], local_status);

    clp$get_processing_phase (processing_phase, local_status);
    IF local_status.normal AND (processing_phase > clc$job_begin_phase)
         AND (processing_phase < clc$job_end_phase) THEN
      logset := $pmt$ascii_logset [pmc$system_log, pmc$job_log];
    ELSE
      logset := $pmt$ascii_logset [pmc$system_log];
    IFEND;

    sfsa_p := #previous_save_area ();

    /display_calls/
    FOR stack :=  1 to number_of_calls_to_display DO
      log_stack_pva (stack, sfsa_p^.p, logset, local_status);
      sfsa_p := sfsa_p^.a2; { Move to the next previous save area }
      IF sfsa_p = NIL THEN
        exit /display_calls/
      IFEND;
    FOREND /display_calls/;

    IF caller_id.ring <= tmv$system_debug_ring THEN
      syp$invoke_system_debugger (error_message, 0, local_status);
    IFEND;

    pmp$log_ascii ('*** RECOVERABLE SYSTEM ERROR ***', logset, pmc$msg_origin_system, local_status);

    IF local_status.normal THEN
      pmp$log_ascii (error_message, logset, pmc$msg_origin_system, local_status);
    IFEND;

    IF local_status.normal THEN
      osp$log_unformatted_status (p_status, logset, pmc$msg_origin_system, NOT critical_message);
    IFEND;

    IF NOT local_status.normal THEN
      osp$system_error (error_message, p_status);
    IFEND;

    #keypoint (osk$exit, 0, osk$recoverable_system_error);
  PROCEND osp$recoverable_system_error;
?? TITLE := '*** LOG_P_REGISTER ***', EJECT ??

  PROCEDURE log_p_register
    (    p_register: ost$p_register;
         logset: pmt$ascii_logset;
     VAR status: ost$status);

    VAR
      message: string (18);

    message := 'P = 0 000 00000000';
    clp$convert_integer_to_rjstring (p_register.pva.ring, 16, FALSE, '0', message (5), status);
    IF status.normal THEN
      clp$convert_integer_to_rjstring (p_register.pva.seg, 16, FALSE, '0', message (7, 3), status);
    IFEND;
    IF status.normal THEN
      clp$convert_integer_to_rjstring (p_register.pva.offset, 16, FALSE, '0', message (11, 8), status);
    IFEND;
    IF status.normal THEN
      pmp$log_ascii (message, logset, pmc$msg_origin_system, status);
    IFEND;
  PROCEND log_p_register;
?? TITLE := '*** LOG_STACK_PVA ***', EJECT ??

  PROCEDURE log_stack_pva
    (    stack: integer;
         pva: ^cell;
         logset: pmt$ascii_logset;
     VAR status: ost$status);

    VAR
      found: boolean,
      length: integer,
      message: string (120),
      module_name: ost$name,
      offset_in_section: ost$segment_offset,
      section_name: ost$name;

      status.normal := TRUE;
      ocp$find_debug_address (#SEGMENT(pva), #OFFSET(pva), found, module_name, section_name,
            offset_in_section, status);
      IF found AND status.normal THEN
        STRINGREP (message, length, 'SF', stack:3, ' P=', pva, ' ', section_name, ' +',
              offset_in_section:#(16));
      ELSE
        STRINGREP (message, length, 'SF', stack:3, ' P=', pva);
      IFEND;

      pmp$log_ascii (message (1, length), logset, pmc$msg_origin_system, status);
  PROCEND log_stack_pva;
?? SKIP := 2 ??
MODEND osm$recoverable_system_error;
*DECK DECK=OSM$RUN_VIRTUAL_SYSTEM EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operating System : System job monitor main loop' ??
MODULE osm$run_virtual_system;

{ PURPOSE:
{   This module contains the main system job_monitor routine which monitors system tasks and acts
{   upon requests to change their status'.  It also is the starting point of system idle-down and resume.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ose$system_task_exceptions
?? POP ??
*copyc cap$prepare_for_idle_system
*copyc clp$log_comment
*copyc clp$put_job_command_response
*copyc clp$set_primary_task
*copyc dfp$prepare_for_idle_system
*copyc dsp$check_interval_23d
*copyc jmp$idle_system
*copyc jmp$resume_system
*copyc jmp$system_job
*copyc jmp$update_last_used_ssn
*copyc osp$activate_system_task
*copyc osp$executing_in_job_monitor
*copyc osp$generate_message
*copyc osp$get_cause_of_idle_r3
*copyc osp$idle_requested
*copyc osp$log_idle_resume
*copyc osp$manage_system_tasks
*copyc osp$set_status_abnormal
*copyc osp$update_idle_state
*copyc pmp$get_microsecond_clock
*copyc pmp$wait
?? OLDTITLE ??
?? NEWTITLE := 'osp$run_virtual_system', EJECT ??

{ PURPOSE:
{   The purpose of this request is to manage system tasks while waiting for a request to
{   idle the system.

  PROCEDURE [XDCL] osp$run_virtual_system
    (    system_restart: boolean;
     VAR status: ost$status);

    CONST
      c$one_hour_wait = 3600000,    {one hour in milleseconds.
      c$one_second_wait = 1000,     {one second in milleseconds.
      c$ten_second_wait = 10000;    {ten seconds in milleseconds.

    VAR
      current_time: integer,
      first_time_for_message: boolean,
      idle_code: syt$180_idle_code,
      ignore_status: ost$status,
      log_name_selections: ARRAY [1 .. 1] OF ost$name,
      short_wait: boolean,
      task_name: ost$name,
      time_to_check_interval: integer,
      wait_time: integer,
      work_was_done: boolean;

    IF NOT (jmp$system_job () AND osp$executing_in_job_monitor ()) THEN
      osp$set_status_abnormal ('  ', ose$not_system_job_monitor, 'osp$run_virtual_system', status);
      RETURN;
    IFEND;

    log_name_selections [1] := 'SYSTEM';
    work_was_done := TRUE;
    first_time_for_message := TRUE;
    short_wait := FALSE;

    IF NOT system_restart THEN

      { Activate the console interaction task. This system task is defined by OSP$INITIALIZE_VIRTUAL_SYSTEM.

      task_name := 'CONSOLE_INTERACTION';
      osp$activate_system_task (task_name, status);
      IF NOT status.normal THEN
        osp$generate_message (status, ignore_status);
        status.normal := TRUE;
      IFEND;
    IFEND;

    osp$update_idle_state (osc$system_not_idle, status);
    IF NOT status.normal THEN
      osp$generate_message (status, ignore_status);
    IFEND;

    time_to_check_interval := 0;

  /run_system/
    WHILE TRUE DO

      { Check if the System Operation Interval has expired, if it has then the system will step.

      pmp$get_microsecond_clock (current_time, ignore_status);
      IF current_time >= time_to_check_interval THEN
        dsp$check_interval_23d;
        time_to_check_interval := current_time + (c$one_hour_wait * 1000);
      IFEND;

      IF work_was_done THEN
        work_was_done := FALSE;
        IF NOT first_time_for_message THEN
          pmp$wait (c$one_second_wait, c$one_second_wait);
        IFEND;
      ELSE
        IF system_restart AND first_time_for_message THEN
          clp$log_comment ('----------   Resume_System Completed   ----------', log_name_selections, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$put_job_command_response (' ----- RESUME_SYSTEM COMPLETE  -----', status);
          clp$put_job_command_response (' /', status);
          osp$update_idle_state (osc$system_not_idle, status);

          { Log the time for the resume.

          osp$log_idle_resume (osc$resume_statistic, syc$ic_null, status);
        IFEND;
        first_time_for_message := FALSE;
        IF short_wait THEN
          wait_time := c$ten_second_wait;
        ELSE
          wait_time := c$one_hour_wait;
        IFEND;
        pmp$wait (wait_time, wait_time);
      IFEND;

      { The following request should proceed IDLE - The reason being that if a job gets submitted and
      { routed to another mainframe and the last system_supplied_name assigned does not get updated
      { we may, inadvertently, re-assign the same name - this is fatal.

      jmp$update_last_used_ssn (status);

      IF osp$idle_requested () THEN
        osp$update_idle_state (osc$idle_system_in_progress, status);
        EXIT /run_system/
      IFEND;

      { Perform any actions necessary to support system task execution.

      osp$manage_system_tasks (short_wait, ignore_status);

      jmp$resume_system (ignore_status);
    WHILEND /run_system/;

    clp$set_primary_task (status);

    osp$get_cause_of_idle_r3 (idle_code);
    dfp$prepare_for_idle_system (idle_code, ignore_status);
    cap$prepare_for_idle_system (idle_code, ignore_status);

    jmp$idle_system (ignore_status);

  PROCEND osp$run_virtual_system;
?? OLDTITLE ??
MODEND osm$run_virtual_system;
*DECK DECK=OSM$SET_MESSAGE_LEVEL EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Message Generator : Set Message Level' ??
MODULE osm$set_message_level;

{
{ PURPOSE:
{   This module contains the procedure that changes the default for style
{   of formatting messages.
{
?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc clt$environment_object_size
*copyc ose$message_gen_exceptions
*copyc ost$status
*copyc ost$status_message_level
?? POP ??
*copyc osp$find_status_message_level
*copyc osp$set_status_condition
?? TITLE := 'osp$eo_size_message_level', EJECT ??

  FUNCTION [XDCL] osp$eo_size_message_level: clt$environment_object_size;


    osp$eo_size_message_level := #SIZE (ost$status_message_level);

  FUNCEND osp$eo_size_message_level;
?? TITLE := 'osp$eo_init_message_level', EJECT ??

  PROCEDURE [XDCL] osp$eo_init_message_level
    (    object: ^clt$environment_object_contents);

    VAR
      status_message_level: ^ost$status_message_level;


    status_message_level := object;
    status_message_level^ := osc$full_message_level;

  PROCEND osp$eo_init_message_level;
?? TITLE := 'osp$set_message_level', EJECT ??
*copyc osh$set_message_level

  PROCEDURE [XDCL, #GATE] osp$set_message_level
    (    message_level: ost$status_message_level;
     VAR status: ost$status);

    VAR
      message_level_ptr: ^ost$status_message_level;


    status.normal := TRUE;

    IF (message_level < LOWERVALUE (ost$status_message_level)) OR
          (message_level > UPPERVALUE (ost$status_message_level)) THEN
      osp$set_status_condition (ose$bad_message_level, status);
      RETURN;
    IFEND;

    osp$find_status_message_level (message_level_ptr);

    message_level_ptr^ := message_level;

  PROCEND osp$set_message_level;

MODEND osm$set_message_level;
*DECK DECK=OSM$SET_STATUS_ABNORMAL EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Status Record Setting Routines' ??
MODULE osm$set_status_abnormal ALIAS 'osmssa';

{
{ PURPOSE:
{   This module contains routines that provide a convenient means for
{   defining the contents of an ost$status record.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
*IF NOT $true(osv$unix)
?? PUSH (LISTEXT := ON) ??
*copyc mmc$first_transient_segment
*copyc mmd$segment_access_condition
*copyc mme$condition_codes
*copyc osc$processor_defined_registers
*copyc ose$condition_exceptions
*copyc osk$keypoints
*copyc ost$monitor_fault
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc ost$status_identifier
*copyc pme$broken_task_exceptions
*copyc pme$condition_exceptions
*copyc pme$system_exceptions
*copyc tmt$broken_task_monitor_fault
*copyc tmt$mcr_faults
?? POP ??
*copyc clp$convert_integer_to_rjstring
*ELSE
*copyc clp$trimmed_string_size
*copyc ose$unix_system_error
*copyc osp$set_status_condition
*copyc ost$status
*copyc ost$status_identifier
*copyc ost_c_integer
*IFEND
*copyc clp$convert_integer_to_string
*copyc osp$status_condition_code

?? OLDTITLE ??
?? NEWTITLE := 'osp$set_status_abnormal', EJECT ??
*copyc osh$set_status_abnormal

  PROCEDURE [XDCL, #GATE] osp$set_status_abnormal ALIAS 'ospssa'
    (    identifier: ost$status_identifier;
         condition: ost$status_condition_code;
         text: string ( * <= osc$max_string_size);
     VAR status: ost$status);

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, 0, osk$set_status_abnormal);
*IFEND

    status.normal := FALSE;

    status.condition := osp$status_condition_code (identifier, condition);

    status.text.size := 0;
    IF STRLENGTH (text) > 0 THEN
      osp$append_status_parameter (osc$status_parameter_delimiter, text, status);
    IFEND;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, 0, osk$set_status_abnormal);
*IFEND

  PROCEND osp$set_status_abnormal;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE, XDCL, #GATE] osp$append_status_parameter', EJECT ??
*copy osh$append_status_parameter

  PROCEDURE [INLINE, XDCL, #GATE] osp$append_status_parameter ALIAS 'ospasp'
    (    delimiter: char;
         text: string ( * <= osc$max_string_size);
     VAR status {input, output} : ost$status);

    CONST
      space_constant = ' ';

    VAR
      space: char,
      status_text_size: ost$string_size,
      text_size: ost$string_size;

    IF status.normal THEN
      RETURN;
    IFEND;

    status_text_size := status.text.size;
    IF status_text_size >= osc$max_string_size THEN
      RETURN;
    IFEND;
    text_size := STRLENGTH (text);

{ By assigning the value space to a char the CYBIL compiler will place this value in a register.
{ In addition, code motion will move the register load out of the loop.  This should significantly,
{ improve the "stripping" of trailing characters.

    space := space_constant;
    WHILE (text_size > 0) AND (text (text_size) = space) DO
      text_size := text_size - 1;
    WHILEND;
    status_text_size := status_text_size + 1;
    status.text.value (status_text_size) := delimiter;
    IF text_size > osc$max_string_size - status_text_size THEN
      text_size := osc$max_string_size - status_text_size;
    IFEND;
    status.text.value (status_text_size + 1, text_size) := text (1, text_size);
    status.text.size := status_text_size + text_size;


  PROCEND osp$append_status_parameter;
?? OLDTITLE ??
?? NEWTITLE := 'osp$append_status_integer', EJECT ??
*copyc osh$append_status_integer

  PROCEDURE [XDCL, #GATE] osp$append_status_integer ALIAS 'ospasi'
    (    delimiter: char;
         int: integer;
         radix: 2 .. 16;
         include_radix_specifier: boolean;
     VAR status {input, output} : ost$status);

    VAR
      ignore_status: ost$status,
      text: ost$string;


    clp$convert_integer_to_string (int, radix, include_radix_specifier, text, ignore_status);
    osp$append_status_parameter (delimiter, text.value (1, text.size), status);

  PROCEND osp$append_status_integer;
?? OLDTITLE ??
*IF $true(osv$unix)
?? NEWTITLE := '[XDCL, #GATE] osp$set_status_from_errno', EJECT ??
*copyc osh$set_status_from_errno

  PROCEDURE [XDCL, #GATE] osp$set_status_from_errno
    (    system_call: string ( * <= osc$max_string_size);
         stat: ost_c_integer;
         syserrlist_message: string ( * <= osc$max_string_size);
     VAR status: ost$status);

    osp$set_status_condition (ose$unix_system_error, status);
    osp$append_status_integer (osc$status_parameter_delimiter, stat, 10, FALSE, status);
    osp$append_status_parameter (osc$status_parameter_delimiter, system_call, status);
    IF syserrlist_message <> ' ' THEN
      osp$append_status_parameter (osc$status_parameter_delimiter, syserrlist_message (1,
            clp$trimmed_string_size (syserrlist_message)), status);
    IFEND;

  PROCEND osp$set_status_from_errno;
?? OLDTITLE ??
*IFEND
*IF NOT $true(osv$unix)
?? NEWTITLE := '[XDCL, #GATE] osp$monitor_fault_to_status', EJECT ??
*copy osh$monitor_fault_to_status

  PROCEDURE [XDCL, #GATE] osp$monitor_fault_to_status
    (    monitor_fault: ost$monitor_fault;
         minimum_save_area_p: ^ost$minimum_save_area;
     VAR status: ost$status);

?? NEWTITLE := 'append_address_to_status', EJECT ??

    PROCEDURE append_address_to_status
      (    address: ost$pva;
       VAR status {input, output} : ost$status);

      osp$append_status_integer (osc$status_parameter_delimiter, address.ring, 16, FALSE, status);
      osp$append_status_integer (' ', address.seg, 16, FALSE, status);
      osp$append_status_integer (' ', address.offset, 16, FALSE, status);
    PROCEND append_address_to_status;
?? OLDTITLE ??
?? NEWTITLE := 'handle_broken_task_fault', EJECT ??

    PROCEDURE handle_broken_task_fault;

      VAR
        broken_task: ^tmt$broken_task_monitor_fault,
        broken_task_dsp: ^ost$pva,
        broken_task_mcr: ^0 .. 0ffff(16),
        broken_task_ucr: ^0 .. 0ffff(16),
        executing_ring: ost$ring,
        executing_segment: ^ost$p_register,
        p_register: integer;

      broken_task := #LOC (monitor_fault.contents);
      broken_task_mcr := #LOC (broken_task^.monitor_condition_register);
      CASE broken_task^.broken_task_condition OF
      = tmc$btc_mntr_fault_buffer_full =
        osp$set_status_abnormal (pmc$program_management_id, pme$monitor_fault_buffer_full, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER(broken_task^.monitor_fault_id),
             10, FALSE, status);
        append_address_to_status (broken_task^.p.pva, status);
        osp$append_status_integer (osc$status_parameter_delimiter, broken_task_mcr^, 16, FALSE, status);
        broken_task_ucr := #LOC (broken_task^.user_condition_register);
        osp$append_status_integer (osc$status_parameter_delimiter, broken_task_ucr^, 16, FALSE, status);

      = tmc$btc_mf_traps_disabled =
        osp$set_status_abnormal (pmc$program_management_id, pme$fault_with_traps_disabled, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER(broken_task^.monitor_fault_id),
              10, FALSE, status);
        append_address_to_status (broken_task^.p.pva, status);
        broken_task_dsp := #LOC (broken_task^.a0);
        append_address_to_status (broken_task_dsp^, status);
        osp$append_status_integer (osc$status_parameter_delimiter, broken_task_mcr^, 16, FALSE, status);

      = tmc$btc_invalid_a0 =
        p_register := #READ_REGISTER (osc$pr_p_reg);
        executing_segment := #LOC (p_register);

{ If the error occurred in an NOS/VE segment report the error as a DSP error otherwise
{ report the error as an "inconsistent stack."

{ NOTE: The procedure tmp$dispose_of_broken_task relies on the status condition
{       pme$inconsistent_stack.

        IF minimum_save_area_p^.p_register.pva.seg < mmc$first_loader_predefined_seg THEN
          broken_task_dsp := #LOC (broken_task^.a0);
          osp$set_status_abnormal (pmc$program_management_id, pme$invalid_dynamic_space_ptr, '', status);
          append_address_to_status (broken_task_dsp^, status);
          append_address_to_status (broken_task^.p.pva, status);
          osp$append_status_integer (osc$status_parameter_delimiter, broken_task_mcr^, 16, FALSE, status);
          broken_task_ucr := #LOC (broken_task^.user_condition_register);
          osp$append_status_integer (osc$status_parameter_delimiter, broken_task_ucr^, 16, FALSE, status);
        ELSE
          osp$set_status_abnormal (pmc$program_management_id, pme$inconsistent_stack, '', status);
        IFEND;

      = tmc$btc_invalid_p =
        osp$set_status_abnormal (pmc$program_management_id, pme$invalid_p_register, '', status);
        append_address_to_status (broken_task^.p.pva, status);
        append_address_to_status (broken_task_dsp^, status);
        osp$append_status_integer (osc$status_parameter_delimiter, broken_task_mcr^, 16, FALSE, status);
        broken_task_ucr := #LOC (broken_task^.user_condition_register);
        osp$append_status_integer (osc$status_parameter_delimiter, broken_task_ucr^, 16, FALSE, status);

      = tmc$btc_mcr_traps_disabled =
        osp$set_status_abnormal (pmc$program_management_id, pme$mcr_with_traps_disabled, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, broken_task_mcr^, 16, FALSE, status);
        append_address_to_status (broken_task^.p.pva, status);

      = tmc$btc_ucr_traps_disabled =
        osp$set_status_abnormal (pmc$program_management_id, pme$ucr_with_traps_disabled, '', status);
        broken_task_ucr := #LOC (broken_task^.user_condition_register);
        osp$append_status_integer (osc$status_parameter_delimiter, broken_task_ucr^, 16, FALSE, status);
        append_address_to_status (broken_task^.p.pva, status);

      = tmc$btc_system_error =
        osp$set_status_abnormal (pmc$program_management_id, pme$system_error, '', status);

      ELSE
        osp$set_status_abnormal (pmc$program_management_id, pme$undefined_broken_task, '', status);
        append_address_to_status (broken_task^.p.pva, status);
      CASEND;

    PROCEND handle_broken_task_fault;
?? OLDTITLE ??
?? NEWTITLE := 'handle_mcr_fault', EJECT ??

    PROCEDURE handle_mcr_fault;

      CONST
        default_mcr_message = 'MCR fault - MCR = 0000',
        mcr_message_length = 22,
        mcr_length = 4;

      VAR
        mcr_faults: ^tmt$mcr_faults,
        mcr_faults_mcr_register: ^0 .. 0ffff(16),
        mcr_message: string (mcr_message_length),
        mcr_string: string (mcr_length);

      mcr_faults := #LOC (monitor_fault.contents);
      mcr_faults_mcr_register := #LOC (mcr_faults^.faults);
      clp$convert_integer_to_rjstring (mcr_faults_mcr_register^, 16, FALSE, '0', mcr_string,
            { ignore } status);
      mcr_message := default_mcr_message;
      mcr_message (mcr_message_length - mcr_length + 1, mcr_length) := mcr_string;

      osp$set_status_abnormal (pmc$program_management_id, pme$system_condition, mcr_message, status);
      append_address_to_status (minimum_save_area_p^.p_register.pva, status);
      osp$append_status_parameter (' ', 'PVA', status);
      osp$append_status_integer ('=', mcr_faults^.untranslatable_pointer.ring, 16, FALSE, status);
      osp$append_status_integer (' ', mcr_faults^.untranslatable_pointer.seg, 16, FALSE, status);
      osp$append_status_integer (' ', mcr_faults^.untranslatable_pointer.offset, 16, FALSE, status);

    PROCEND handle_mcr_fault;
?? OLDTITLE ??
?? NEWTITLE := 'handle_segment_fault', EJECT ??

    PROCEDURE handle_segment_fault;

      VAR
        error_pva: ost$pva,
        segment_access_condition: ^mmt$segment_access_condition;

      segment_access_condition := #LOC (monitor_fault.contents);
      error_pva.ring := #RING (segment_access_condition^.segment);
      error_pva.seg := #SEGMENT (segment_access_condition^.segment);
      error_pva.offset := #OFFSET (segment_access_condition^.segment);

      CASE segment_access_condition^.identifier OF
      = mmc$sac_io_read_error =
        osp$set_status_abnormal (pmc$program_management_id, mme$io_read_error, '', status);
      = mmc$sac_read_beyond_eoi =
        osp$set_status_abnormal (pmc$program_management_id, mme$read_beyond_eoi, '', status);
      = mmc$sac_read_write_beyond_msl =
        osp$set_status_abnormal (pmc$program_management_id, mme$read_write_beyond_msl, '', status);
      = mmc$sac_segment_access_error =
        osp$set_status_abnormal (pmc$program_management_id, mme$segment_access_error, '', status);
      = mmc$sac_ring_violation =
        osp$set_status_abnormal (pmc$program_management_id, mme$ring_violation, '', status);
      = mmc$sac_no_append_permission =
        osp$set_status_abnormal (pmc$program_management_id, mme$write_beyond_eoi_no_append, '', status);
      = mmc$sac_file_server_terminated =
        osp$set_status_abnormal (pmc$program_management_id, mme$file_server_terminated, '', status);
      = mmc$sac_pf_space_limit_exceeded =
        osp$set_status_abnormal (pmc$program_management_id, mme$pf_space_limit_exceeded, '', status);
      = mmc$sac_tf_space_limit_exceeded =
        osp$set_status_abnormal (pmc$program_management_id, mme$tf_space_limit_exceeded, '', status);
      ELSE
        osp$set_status_abnormal ('OS', ose$unknown_segment_condition, '', status);
      CASEND;
      append_address_to_status (error_pva, status);
      append_address_to_status (minimum_save_area_p^.p_register.pva, status);
    PROCEND handle_segment_fault;
?? OLDTITLE ??
?? EJECT ??

    CASE monitor_fault.identifier OF
    = tmc$broken_task_fault_id =
      handle_broken_task_fault;

    = tmc$mcr_fault =
      handle_mcr_fault;

    = mmc$segment_fault_processor_id =
      handle_segment_fault;

    = tmc$unknown_system_req_fault =
      osp$set_status_abnormal (pmc$program_management_id, pme$unknown_system_request, '', status);
      append_address_to_status (minimum_save_area_p^.p_register.pva, status);

    ELSE
      osp$set_status_abnormal (pmc$program_management_id, pme$unknown_monitor_fault, '', status);
      append_address_to_status (minimum_save_area_p^.p_register.pva, status);
    CASEND;
  PROCEND osp$monitor_fault_to_status;
?? OLDTITLE ??
*IFEND

MODEND osm$set_status_abnormal;
*DECK DECK=OSM$SET_STATUS_FROM_CONDITION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Control - Program Conditions' ??
MODULE osm$set_status_from_condition;

{   PURPOSE:
{     This module restricts the knowledge of disposing of conditions.
{     The module contains the procedures to dispose of all conditions.

{   DESIGN:
{     The procedures in this module are designed to have an execute
{     bracket of 2, 13 and a call bracket of 13.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$work_area_overflow
*copyc ife$interactive_exception_codes
*copyc jme$job_management_conditions
*copyc llc$unlinked_pointer_ring
*copyc mmc$first_transient_segment
*copyc mmd$segment_access_condition
*copyc mme$condition_codes
*copyc osc$default_utp_ring
*copyc osc$processor_defined_registers
*copyc osd$code_base_pointer
*copyc osd$keypoints
*copyc ose$condition_exceptions
*copyc oss$job_paged_literal
*copyc ost$name
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc ost$status_identifier
*copyc pme$system_exceptions
*copyc pmt$condition
?? POP ??
*copyc bap$format_segment_condition
*copyc clp$convert_integer_to_string
*copyc clv$work_areas
*copyc mmp$fetch_segment_attributes
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$call_ring_crossing_proc
*copyc pmp$establish_condition_handler
*copyc pmp$get_binary_mainframe_id
*copyc pmp$validate_previous_save_area
*copyc sfp$get_job_limit_name
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    ring_crossing_routine: [STATIC, READ, oss$job_paged_literal] record
      case pointer_type: (proc_pointer, code_based_pointer) of
      = proc_pointer =
        procedure_pointer: ^procedure,
      = code_based_pointer =
        code_based_pointer: ^ost$external_code_base_pointer,
      casend,
    recend := [proc_pointer, ^pmp$call_ring_crossing_proc];

  VAR
    nil_pva: [STATIC, READ, oss$job_paged_literal] ost$pva :=
          [osc$max_ring, osc$maximum_segment, -(osc$maximum_offset + 1)],
    ring_0_or_access_violation: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
          [pmc$system_conditions, $pmt$system_conditions [pmc$invalid_segment_ring_0,
          pmc$access_violation], *];

?? OLDTITLE ??
?? NEWTITLE := 'append_address_to_message', EJECT ??

{ PURPOSE:
{   Appends the address as a new status field.

  PROCEDURE append_address_to_message
    (    address: ost$pva;
     VAR message {input, output} : ost$status);

    VAR
      text: ost$string;

    text.size := 0;
    append_pva_to_string (address, text);
    osp$append_status_parameter (osc$status_parameter_delimiter, text.value (1, text.size), message);
  PROCEND append_address_to_message;
?? OLDTITLE ??
?? NEWTITLE := 'append_pva_to_message', EJECT ??

{ PURPOSE:
{   Adds the pva to the message with the specified label.

  PROCEDURE append_pva_to_message
    (    label: string ( * <= 10);
         pva: ost$pva;
     VAR message {input, output} : ost$status);

    VAR
      text: ost$string;

    text.value := label;
    text.size := STRLENGTH (label) + 1;
    text.value (text.size) := '=';
    append_pva_to_string (pva, text);
    osp$append_status_parameter (' ', text.value (1, text.size), message);
  PROCEND append_pva_to_message;
?? OLDTITLE ??
?? NEWTITLE := 'append_pva_to_string', EJECT ??

{ PURPOSE:
{   Appends a PVA to a string.

  PROCEDURE append_pva_to_string
    (    pva: ost$pva;
     VAR str {input, output} : ost$string);

    VAR
      ignore_status: ost$status,
      text: ost$string;

    clp$convert_integer_to_string (pva.ring, 16, FALSE, text, ignore_status);
    str.value (str.size + 1, * ) := text.value (1, text.size);
    str.size := str.size + text.size;

    clp$convert_integer_to_string (pva.seg, 16, FALSE, text, ignore_status);
    str.value (str.size + 1, 1) := ' ';
    str.value (str.size + 2, * ) := text.value (1, text.size);
    str.size := str.size + text.size + 1;

    clp$convert_integer_to_string (pva.offset, 16, FALSE, text, ignore_status);
    str.value (str.size + 1, 1) := ' ';
    str.value (str.size + 2, * ) := text.value (1, text.size);
    str.size := str.size + text.size + 1;
  PROCEND append_pva_to_string;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] osp$format_segment_condition', EJECT ??
*copyc osh$format_segment_condition

  PROCEDURE [XDCL] osp$format_segment_condition
    (    identifier: string (2);
         segment_access_condition: mmt$segment_access_condition;
         save_area: ^ost$stack_frame_save_area;
     VAR message: ost$status;
     VAR status: ost$status);

?? NEWTITLE := 'dispose_of_sfsa_condition', EJECT ??

{ PURPOSE:
{   The purpose of this condition handler is to diagnose an erroneous
{   save_area parameter.

    PROCEDURE dispose_of_sfsa_condition
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR ignore_status: ost$status);

      osp$set_status_condition (ose$invalid_save_area, message);
      EXIT osp$format_segment_condition;
    PROCEND dispose_of_sfsa_condition;
?? OLDTITLE ??

    VAR
      descriptor: pmt$established_handler,
      error_pva: ost$pva,
      ignore_status: ost$status,
      this_is_a_stack: boolean;

    status.normal := TRUE;
    message.normal := TRUE;
    error_pva.ring := #RING (segment_access_condition.segment);
    error_pva.seg := #SEGMENT (segment_access_condition.segment);
    error_pva.offset := #OFFSET (segment_access_condition.segment);
    bap$format_segment_condition (identifier, segment_access_condition, save_area, error_pva, message);
    IF message.normal THEN

      CASE segment_access_condition.identifier OF
      = mmc$sac_io_read_error =
        osp$set_status_condition (mme$io_read_error, message);
      = mmc$sac_read_beyond_eoi =
        osp$set_status_condition (mme$read_beyond_eoi, message);
      = mmc$sac_read_write_beyond_msl =
        stack_segment (error_pva, this_is_a_stack);
        IF this_is_a_stack THEN
          osp$set_status_condition (mme$stack_overflow, message);
        ELSEIF scl_work_area_segment (error_pva) THEN
          osp$set_status_condition (cle$work_area_overflow, message);
        ELSE
          osp$set_status_condition (mme$read_write_beyond_msl, message);
        IFEND;
      = mmc$sac_segment_access_error =
        osp$set_status_condition (mme$segment_access_error, message);
      = mmc$sac_ring_violation =
        osp$set_status_condition (mme$ring_violation, message);
      = mmc$sac_no_append_permission =
        osp$set_status_condition (mme$write_beyond_eoi_no_append, message);
      = mmc$sac_file_server_terminated =
        osp$set_status_condition (mme$file_server_terminated, message);
      = mmc$sac_pf_space_limit_exceeded =
        osp$set_status_condition (mme$pf_space_limit_exceeded, message);
      = mmc$sac_tf_space_limit_exceeded =
        osp$set_status_condition (mme$tf_space_limit_exceeded, message);
      ELSE
        osp$set_status_abnormal ('OS', ose$unknown_segment_condition, '', status);
        append_address_to_message (error_pva, status);
        append_address_to_message (save_area^.minimum_save_area.p_register.pva, status);
      CASEND;

      pmp$establish_condition_handler (ring_0_or_access_violation, ^dispose_of_sfsa_condition, ^descriptor,
            ignore_status);
      append_address_to_message (error_pva, message);
      resolve_p_address (save_area, message);
    IFEND;

  PROCEND osp$format_segment_condition;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] osp$format_system_condition', EJECT ??
*copyc osh$format_system_condition

  PROCEDURE [XDCL] osp$format_system_condition
    (    system_condition: pmt$system_condition;
         untranslatable_pointer: ost$pva;
         save_area: ^ost$stack_frame_save_area;
     VAR message: ost$status);

?? NEWTITLE := 'dispose_of_sfsa_condition', EJECT ??

{ PURPOSE:
{   The purpose of this condition handler is to diagnose an erroneous
{   save_area parameter.

    PROCEDURE dispose_of_sfsa_condition
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR ignore_status: ost$status);

      osp$set_status_condition (ose$invalid_save_area, message);
      EXIT osp$format_system_condition;
    PROCEND dispose_of_sfsa_condition;
?? OLDTITLE, EJECT ??

    CONST
      identifier = pmc$program_management_id;

    TYPE
      op_code = 0 .. 0ff(16);



    VAR
      descriptor: pmt$established_handler,
      ignore_status: ost$status,
      mainframe_id: pmt$binary_mainframe_id,
      op_code_pointer: ^op_code,
      p_address: ^cell,
      ring_0_utp: [STATIC, READ, oss$job_paged_literal] ost$pva :=
            [osc$default_utp_ring, osc$default_utp_segment, osc$default_utp_offset];

    pmp$establish_condition_handler (ring_0_or_access_violation, ^dispose_of_sfsa_condition, ^descriptor,
          ignore_status);

    CASE system_condition OF
    = pmc$detected_uncorrected_err =
      osp$set_status_abnormal (identifier, pme$system_condition, 'uncorrected mainframe hardware error',
            message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
      IF (untranslatable_pointer <> ring_0_utp) THEN
        append_pva_to_message ('PVA', untranslatable_pointer, message);
      IFEND;
    = pmc$ua_unselectable =
      osp$set_status_abnormal (identifier, pme$system_condition, 'not assigned', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$sw_unselectable =
      osp$set_status_abnormal (identifier, pme$system_condition, 'short warning', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$address_specification =
      osp$set_status_abnormal (identifier, pme$system_condition, 'address specification error', message);
      resolve_p_address (save_area, message);
      append_pva_to_message ('PVA', untranslatable_pointer, message);
    = pmc$xr_unselectable =
      osp$set_status_abnormal (identifier, pme$system_condition, 'C170 exchange request', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$access_violation =
      osp$set_status_abnormal (identifier, pme$system_condition, 'access violation', message);
      resolve_p_address (save_area, message);
      append_pva_to_message ('PVA', untranslatable_pointer, message);
    = pmc$instruction_specification =
      osp$set_status_abnormal (identifier, pme$system_condition, 'instruction specification error', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$environment_specification =
      osp$set_status_abnormal (identifier, pme$system_condition, 'environment specification error', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$xi_unselectable =
      osp$set_status_abnormal (identifier, pme$system_condition, 'external interrupt', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$pf_unselectable =
      osp$set_status_abnormal (identifier, pme$system_condition, 'page table search without find', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
      append_pva_to_message ('PVA', untranslatable_pointer, message);
    = pmc$sc_unselectable =
      osp$set_status_abnormal (identifier, pme$system_condition, 'system call', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$sit_unselectable =
      osp$set_status_abnormal (identifier, pme$system_condition, 'system interval timer', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$invalid_segment_ring_0 =
      IF (untranslatable_pointer = ring_0_utp) OR ((untranslatable_pointer.ring =
            llc$unlinked_pointer_ring) AND (untranslatable_pointer.seg = llc$unlinked_pointer_segment)) THEN
        osp$set_status_abnormal (identifier, pme$system_condition, 'ring number zero', message);
        append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
      ELSE
        osp$set_status_abnormal (identifier, pme$system_condition, 'invalid segment', message);
        resolve_p_address (save_area, message);
        append_pva_to_message ('PVA', untranslatable_pointer, message);
      IFEND;
    = pmc$out_call_in_return =
      osp$set_status_abnormal (identifier, pme$system_condition, 'outward call / inward return', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$sel_unselectable =
      osp$set_status_abnormal (identifier, pme$system_condition, 'soft error', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$tx_unselectable =
      osp$set_status_abnormal (identifier, pme$system_condition, 'trap exception', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$privileged_instruction =
      osp$set_status_abnormal (identifier, pme$system_condition, 'privileged instruction fault', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$unimplemented_instruction =
      p_address := #ADDRESS (save_area^.minimum_save_area.p_register.pva.ring,
            save_area^.minimum_save_area.p_register.pva.seg, save_area^.minimum_save_area.p_register.pva.
            offset);
      op_code_pointer := p_address;
      pmp$get_binary_mainframe_id (mainframe_id, ignore_status);
      IF (op_code_pointer^ >= 40(16)) AND (op_code_pointer^ <= 5E(16)) THEN
        osp$set_status_abnormal (identifier, pme$system_condition,
              'unimplemented instruction - vector instruction simulation is disabled', message);
      ELSE
        osp$set_status_abnormal (identifier, pme$system_condition, 'unimplemented instruction', message);
      IFEND;
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$ff_unselectable =
      osp$set_status_abnormal (identifier, pme$system_condition, 'free flag', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$pit_unselectable =
      osp$set_status_abnormal (identifier, pme$system_condition, 'process interval timer', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$inter_ring_pop =
      osp$set_status_abnormal (identifier, pme$system_condition, 'inter ring pop', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$cff_unselectable =
      osp$set_status_abnormal (identifier, pme$system_condition, 'critical frame flag', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$kypt_unselectable =
      osp$set_status_abnormal (identifier, pme$system_condition, 'keypoint', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$divide_fault =
      osp$set_status_abnormal (identifier, pme$system_condition, 'divide fault', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$debug_unselectable =
      osp$set_status_abnormal (identifier, pme$system_condition, 'debug', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$arithmetic_overflow =
      osp$set_status_abnormal (identifier, pme$system_condition, 'arithmetic overflow', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$exponent_overflow =
      osp$set_status_abnormal (identifier, pme$system_condition, 'exponent overflow', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$exponent_underflow =
      osp$set_status_abnormal (identifier, pme$system_condition, 'exponent underflow', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$fp_significance_loss =
      osp$set_status_abnormal (identifier, pme$system_condition, 'F. P. significance loss', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$fp_indefinite =
      osp$set_status_abnormal (identifier, pme$system_condition, 'F. P. indefinite', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$arithmetic_significance =
      osp$set_status_abnormal (identifier, pme$system_condition, 'arithmetic loss of significance', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    = pmc$invalid_bdp_data =
      osp$set_status_abnormal (identifier, pme$system_condition, 'invalid BDP data', message);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, message);
    CASEND;
  PROCEND osp$format_system_condition;
?? OLDTITLE ??
?? NEWTITLE := 'resolve_p_address', EJECT ??

{ PURPOSE:
{   An error has occurred which may be in the system code.  This routine needs
{   to append to the status message the location of the error and the location
{   in the user code which first entered the system code.  To assist in the
{   location of system failures, the p from the following frames will be
{   reported.
{      P of the failure.
{      Trace back of system calls:
{        P of the frame prior to the failure.
{        P of the first frame of each ring.
{        P of the first frame after the user frame.
{      P of the last user frame before system calls.
{

  PROCEDURE resolve_p_address
    (    condition_save_area: ^ost$stack_frame_save_area;
     VAR message: ost$status);


    VAR
      actual_p: ost$pva,
      newest_p: ost$pva,
      previous_p: ost$pva,
      ring_crossing_p: ost$pva,
      sfsa: ^ost$stack_frame_save_area,
      frame_count: integer,
      status: ost$status,
      str: ost$string;


    status.normal := TRUE;

    sfsa := condition_save_area;
    actual_p := sfsa^.minimum_save_area.p_register.pva;
    previous_p := actual_p;
    append_address_to_message (actual_p, message);

    str.value := 'TB=';
    str.size := 3;
    frame_count := 0;
    ring_crossing_p.offset := #OFFSET (ring_crossing_routine.code_based_pointer^.code_pva);
    ring_crossing_p.seg := #SEGMENT (ring_crossing_routine.code_based_pointer^.code_pva);
    ring_crossing_p.ring := previous_p.ring;

    pmp$validate_previous_save_area (sfsa, status);
    sfsa := sfsa^.minimum_save_area.a2_previous_save_area;

    WHILE (status.normal) AND (sfsa <> NIL) AND (previous_p.seg < mmc$first_loader_predefined_seg) DO
      newest_p := sfsa^.minimum_save_area.p_register.pva;
      IF newest_p <> ring_crossing_p THEN
        IF (previous_p.ring < newest_p.ring) OR ((newest_p.seg >= mmc$first_loader_predefined_seg)) OR
              (frame_count = 1) THEN
          IF frame_count > 0 THEN
            append_pva_to_string (previous_p, str);
            str.value (str.size + 1) := '/';
            str.size := str.size + 1;
          IFEND;
        IFEND;
        previous_p := newest_p;
        frame_count := frame_count + 1;
        ring_crossing_p.ring := previous_p.ring;
      IFEND;
      pmp$validate_previous_save_area (sfsa, status);
      sfsa := sfsa^.minimum_save_area.a2_previous_save_area;
    WHILEND;

    IF str.size > 3 THEN
      osp$append_status_parameter (' ', str.value (1, str.size - 1), message);
    IFEND;

    IF status.normal AND (frame_count > 0) AND (newest_p.seg >= mmc$first_loader_predefined_seg) THEN
      append_pva_to_message ('Users P', previous_p, message);
    IFEND;

  PROCEND resolve_p_address;
?? OLDTITLE, EJECT ??
?? NEWTITLE := '[XDCL, #GATE] osp$set_status_from_condition', EJECT ??
*copyc osh$set_status_from_condition

  PROCEDURE [XDCL, #GATE] osp$set_status_from_condition
    (    identifier: ost$status_identifier;
         condition: pmt$condition;
         save_area: ^ost$stack_frame_save_area;
     VAR condition_status: ost$status;
     VAR status: ost$status);

?? NEWTITLE := 'dispose_of_sfsa_condition', EJECT ??

{ PURPOSE:
{

    PROCEDURE dispose_of_sfsa_condition
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR ignore_status: ost$status);

{The purpose of this condition handler is to diagnose an erroneous save_area parameter.

      osp$set_status_condition (ose$invalid_save_area, status);
      #KEYPOINT (osk$exit, osk$m * 1, osk$set_status_from_condition);
      EXIT osp$set_status_from_condition;
    PROCEND dispose_of_sfsa_condition;
?? OLDTITLE, EJECT ??

    VAR
      system_condition: pmt$system_condition,
      descriptor: pmt$established_handler,
      limit_name: ost$name,
      ignore_status: ost$status;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, osk$set_status_from_condition);
    pmp$establish_condition_handler (ring_0_or_access_violation, ^dispose_of_sfsa_condition, ^descriptor,
          ignore_status);
    CASE condition.selector OF
    = pmc$system_conditions =
      IF (condition.system_conditions <> $pmt$system_conditions []) THEN
        system_condition := pmc$detected_uncorrected_err;
        REPEAT
          IF NOT (system_condition IN condition.system_conditions) THEN
            system_condition := SUCC (system_condition);
          IFEND;
        UNTIL system_condition IN condition.system_conditions;
        osp$format_system_condition (system_condition, condition.untranslatable_pointer, save_area,
              condition_status);
      ELSE
        osp$set_status_condition (ose$empty_system_condition, status);
      IFEND;
    = pmc$block_exit_processing =
      IF (condition.reason <> $pmt$block_exit_reason []) THEN
        IF (pmc$block_exit IN condition.reason) THEN
          osp$set_status_abnormal (identifier, ose$condition_message_template, 'BLOCK EXIT - RETURN/POP',
                condition_status);
        ELSEIF (pmc$program_termination IN condition.reason) THEN
          osp$set_status_abnormal (identifier, ose$condition_message_template,
                'BLOCK EXIT - PROGRAM TERMINATION', condition_status);
        ELSEIF (pmc$program_abort IN condition.reason) THEN
          osp$set_status_abnormal (identifier, ose$condition_message_template, 'BLOCK EXIT - PROGRAM ABORT',
                condition_status);
        IFEND;
        osp$append_status_parameter (' ', 'AT P=', condition_status);
        append_address_to_message (save_area^.minimum_save_area.p_register.pva, condition_status);
      ELSE
        osp$set_status_condition (ose$empty_block_exit_reason, status);
      IFEND;
    = mmc$segment_access_condition =
      osp$format_segment_condition (identifier, condition.segment_access_condition, save_area,
            condition_status, status);
    = jmc$job_resource_condition =
      IF condition.job_resource_condition = jmc$time_limit_condition THEN
        osp$set_status_condition (jme$time_limit_condition, condition_status);
      ELSE
        sfp$get_job_limit_name (condition.job_resource_condition, limit_name, ignore_status);
        osp$set_status_abnormal (identifier, jme$resource_condition, limit_name, condition_status);
      IFEND;
    = pmc$user_defined_condition =
      osp$set_status_abnormal (identifier, ose$condition_message_template, 'USER DEFINED CONDITION: ',
            condition_status);
      osp$append_status_parameter (osc$status_parameter_delimiter, condition.user_condition_name,
            condition_status);
    = ifc$interactive_condition =
      CASE condition.interactive_condition OF
      = ifc$pause_break =
        osp$set_status_condition (ife$pause_break, condition_status);
      = ifc$terminate_break =
        osp$set_status_condition (ife$terminate_break, condition_status);
      = ifc$terminal_connection_broken =
        osp$set_status_condition (ife$terminal_connection_broken, condition_status);
      = ifc$job_reconnect =
        osp$set_status_condition (ife$job_reconnect, condition_status);
      ELSE
        osp$set_status_condition (ose$unknown_interactive_cond, status);
      CASEND;
    = pmc$pit_condition =
      osp$set_status_abnormal (identifier, ose$condition_message_template, 'PROCESS INTERVAL TIMER',
            condition_status);
      osp$append_status_parameter (' ', 'AT P=', condition_status);
      append_address_to_message (save_area^.minimum_save_area.p_register.pva, condition_status);
    ELSE
      osp$set_status_condition (ose$invalid_condition_selector, status);
    CASEND;
    #KEYPOINT (osk$exit, 0, osk$set_status_from_condition);
  PROCEND osp$set_status_from_condition;
?? OLDTITLE ??
?? NEWTITLE := 'stack_segment', EJECT ??

{ PURPOSE:
{   Check if the pva is in a stack segment.

  PROCEDURE stack_segment
    (    pva: ost$pva;
     VAR stack: boolean);


    VAR
      attribute: array [1 .. 1] of mmt$attribute_descriptor,
      local_status: ost$status;


    attribute [1].keyword := mmc$kw_software_attributes;
    mmp$fetch_segment_attributes (#ADDRESS (pva.ring, pva.seg, 0), attribute, local_status);

    stack := ((local_status.normal) AND (mmc$sa_stack IN attribute [1].software_attri_set));

  PROCEND stack_segment;
?? OLDTITLE ??
?? NEWTITLE := 'scl_work_area_segment', EJECT ??

{ PURPOSE:
{   Check if the pva is in an SCL work area segment.

  FUNCTION [INLINE] scl_work_area_segment
    (    pva: ost$pva): boolean;

    VAR
      ring: ost$ring;


    FOR ring := LOWERBOUND (clv$work_areas) TO UPPERBOUND (clv$work_areas) DO
      IF (clv$work_areas [ring].breakdown <> NIL) AND
            (pva.seg = #SEGMENT (clv$work_areas [ring].breakdown^.pva)) THEN

        scl_work_area_segment := TRUE;
        RETURN;

      IFEND;
    FOREND;

    scl_work_area_segment := FALSE;

  FUNCEND scl_work_area_segment;
?? OLDTITLE ??

MODEND osm$set_status_from_condition;
*DECK DECK=OSM$SIMULATE_DISK_FAULT EXPAND=TRUE
MODULE osm$simulate_disk_fault;
?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc clp$scan_parameter_list
*copyc clp$get_value
*copyc cld$parameter_list
*copyc osv$simulated_disk_fault
*copyc clp$get_fs_path_elements
*copyc fsp$convert_fs_structure_to_pf
*copyc clp$convert_cyc_ref_to_cyc_sel
*copyc jmp$system_job
*copyc pfp$dm_attach_item
*copyc pfp$dm_return_item
*copyc osp$generate_message
*copyc mmp$lock_segment
*copyc mmp$write_modified_pages
*copyc mmp$unlock_segment
*copyc mmp$open_file_by_sfid
*copyc mmp$close_device_file
*copyc osp$simulate_disk_fault_r1
*copyc osp$clear_disk_faults_r1

  VAR
    osv$disk_fault_simulation: [XREF] boolean;

?? POP ??

{ Purpose:
{  This module processes operator commands that set and clear mass storage
{ faults.
{  It runs in ring 3 and interfaces with the permanent file system.
{ Design:
{  iom$process_io_completions looks at a table maintained by this module to
{ determine
{  if a particular i/o request should be considered as completing in error
{ (even
{  though it completed normally).
{ Notes:
{  Only the operator (system job) can execute these commands.
{  No interlocking is performed.


?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$simulate_disk_fault
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ Purpose:
{  To attach a pf or catalog and put the sfid into the table looked at
{  by iom$process_io_completions.
{ Design:
{  A special PF interface is used to attach a file or catalog.
{  Pages of the file must be flushed from memory so that disk i/o
{  will actually take place.
{  A ring 1 interface is used to maintain entries in the table.
{  The file is normally left attached until a clear_mass_storage_fault
{  command so that the sfid will remain valid.



{    PDT sdf_pdt (
{      file,f: file
{      sfid: integer
{      skip_count,sc: integer = 0
{      count,c: integer = 1
{      read_fault,rf: boolean = true
{      write_fault,wf: boolean = true
{      locked_page,lp: boolean = false
{      first_byte,fb: integer = 0
{      last_byte,lb: integer = 7fffffff(16)
{      error_type,et: key media, unrecovered, down = down)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    sdf_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^sdf_pdt_names, ^sdf_pdt_params];

  VAR
    sdf_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 19] of
  clt$parameter_name_descriptor := [['FILE', 1], ['F', 1], ['SFID', 2], ['SKIP_COUNT', 3], ['SC', 3], ['COUNT'
  , 4], ['C', 4], ['READ_FAULT', 5], ['RF', 5], ['WRITE_FAULT', 6], ['WF', 6], ['LOCKED_PAGE', 7], ['LP', 7],
  ['FIRST_BYTE', 8], ['FB', 8], ['LAST_BYTE', 9], ['LB', 9], ['ERROR_TYPE', 10], ['ET', 10]];

  VAR
    sdf_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 10] of clt$parameter_descriptor := [

{ FILE F }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ SFID }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, clc$min_integer,
  clc$max_integer]],

{ SKIP_COUNT SC }
    [[clc$optional_with_default, ^sdf_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, clc$min_integer, clc$max_integer]],

{ COUNT C }
    [[clc$optional_with_default, ^sdf_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, clc$min_integer, clc$max_integer]],

{ READ_FAULT RF }
    [[clc$optional_with_default, ^sdf_pdt_dv5], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ WRITE_FAULT WF }
    [[clc$optional_with_default, ^sdf_pdt_dv6], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ LOCKED_PAGE LP }
    [[clc$optional_with_default, ^sdf_pdt_dv7], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ FIRST_BYTE FB }
    [[clc$optional_with_default, ^sdf_pdt_dv8], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, clc$min_integer, clc$max_integer]],

{ LAST_BYTE LB }
    [[clc$optional_with_default, ^sdf_pdt_dv9], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, clc$min_integer, clc$max_integer]],

{ ERROR_TYPE ET }
    [[clc$optional_with_default, ^sdf_pdt_dv10], 1, 1, 1, 1, clc$value_range_not_allowed, [^sdf_pdt_kv10,
  clc$keyword_value]]];

  VAR
    sdf_pdt_kv10: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of ost$name := ['MEDIA',
  'UNRECOVERED','DOWN'];

  VAR
    sdf_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    sdf_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '1';

  VAR
    sdf_pdt_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

  VAR
    sdf_pdt_dv6: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

  VAR
    sdf_pdt_dv7: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';

  VAR
    sdf_pdt_dv8: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    sdf_pdt_dv9: [STATIC, READ, cls$pdt_names_and_defaults] string (12) := '7fffffff(16)';

  VAR
    sdf_pdt_dv10: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'down';

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      sfid_converter: record
        case boolean of
        = TRUE =
          int: 0 .. 0ffffffff(16),
        = FALSE =
          sfid: gft$system_file_identifier,
        casend,
      recend,
      cycle_selector: clt$cycle_selector,
      efr: fst$evaluated_file_reference,
      path: ^pft$path,
      sdf: ost$simulated_disk_fault,
      ls: ost$status,
      segment: ost$segment,
      open,
      locked: boolean,
      value: clt$value;

    IF NOT jmp$system_job () THEN
      RETURN;
    IFEND;

    IF NOT osv$disk_fault_simulation THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, sdf_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('FILE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind = clc$unknown_value THEN
      clp$get_value ('SFID', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.kind = clc$unknown_value THEN
        osp$set_status_abnormal ('XX', 0, 'Either FILE or SFID is required',
              status);
        RETURN;
      IFEND;
      sfid_converter.int := value.int.value;
      sdf.sfid := sfid_converter.sfid;
      sdf.direct_sfid := TRUE;
    ELSE
      clp$get_fs_path_elements (value.file.local_file_name, efr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      PUSH path: [1 .. efr.number_of_path_elements];
      fsp$convert_fs_structure_to_pf (efr, path);
      clp$convert_cyc_ref_to_cyc_sel (efr.cycle_reference, cycle_selector);
      pfp$dm_attach_item (path^, cycle_selector.value, sdf.sfid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      sdf.direct_sfid := FALSE;
    IFEND;

    open := FALSE;
    locked := FALSE;

  /file_attached/
    BEGIN
      clp$get_value ('SKIP_COUNT', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /file_attached/
      IFEND;
      sdf.skip_count := value.int.value;

      clp$get_value ('COUNT', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /file_attached/
      IFEND;
      sdf.count := value.int.value;

      clp$get_value ('LOCKED_PAGE', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /file_attached/;
      IFEND;
      sdf.locked_page := value.bool.value;
      IF sdf.locked_page THEN
        sdf.count := value.int.value;
        sdf.read_fault := FALSE;
        sdf.write_fault := FALSE;
        sdf.error_type := ioc$no_error;
        sdf.in_use := TRUE;
        osp$simulate_disk_fault_r1 (sdf, status);
        IF status.normal THEN
          { Normal exit for "locked_page" option.
          RETURN;
        ELSE
          EXIT /file_attached/;
        IFEND;
      IFEND;

      clp$get_value ('READ_FAULT', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /file_attached/
      IFEND;
      sdf.read_fault := value.bool.value;

      clp$get_value ('WRITE_FAULT', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /file_attached/
      IFEND;
      sdf.write_fault := value.bool.value;

      clp$get_value ('FIRST_BYTE', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /file_attached/
      IFEND;
      sdf.first_byte := value.int.value;

      clp$get_value ('LAST_BYTE', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /file_attached/
      IFEND;
      sdf.last_byte := value.int.value;

      clp$get_value ('ERROR_TYPE', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /file_attached/
      IFEND;
      IF value.name.value = 'MEDIA' THEN
        sdf.error_type := ioc$media_error;
      ELSEIF value.name.value = 'UNRECOVERED' THEN
        sdf.error_type := ioc$unrecovered_error;
      ELSE
        sdf.error_type := ioc$unrecovered_error_unit_down;
      IFEND;

      mmp$open_file_by_sfid (sdf.sfid, 3, 3, mmc$as_random,
            mmc$sar_write_extend, segment, status);
      IF NOT status.normal THEN
        EXIT /file_attached/;
      IFEND;
      open := TRUE;
      mmp$lock_segment (#ADDRESS (3, segment, 0), mmc$lus_lock_for_write,
            osc$wait, status);
      IF NOT status.normal THEN
        EXIT /file_attached/;
      IFEND;
      locked := TRUE;
      mmp$write_modified_pages (#ADDRESS (3, segment, 0), 7fffffff(16),
            osc$wait, status);
      IF NOT status.normal THEN
        EXIT /file_attached/;
      IFEND;
      mmp$unlock_segment (#ADDRESS (3, segment, 0), mmc$lus_free, osc$wait,
            status);
      IF NOT status.normal THEN
        EXIT /file_attached/;
      IFEND;
      locked := FALSE;
      mmp$close_device_file (segment, status);
      IF NOT status.normal THEN
        EXIT /file_attached/;
      IFEND;
      open := FALSE;

      sdf.in_use := TRUE;
      osp$simulate_disk_fault_r1 (sdf, status);
      IF status.normal THEN
        {Normal exit
        RETURN;
      IFEND;

    END /file_attached/;

    {Error exit

    IF locked THEN
      mmp$unlock_segment (#ADDRESS (3, segment, 0), mmc$lus_none, osc$wait,
            ls);
      IF NOT ls.normal THEN
        osp$generate_message (ls, ls);
      IFEND;
      locked := FALSE;
    IFEND;
    IF open THEN
      mmp$close_device_file (segment, ls);
      IF NOT ls.normal THEN
        osp$generate_message (ls, ls);
      IFEND;
      open := FALSE;
    IFEND;
    IF NOT sdf.direct_sfid THEN
      pfp$dm_return_item (sdf.sfid, ls);
      IF NOT ls.normal THEN
        osp$generate_message (ls, ls);
      IFEND;
    IFEND;


  PROCEND osp$simulate_disk_fault;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$clear_disk_faults
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ Purpose:
{  To remove (clear) all disk faults that are currently set.
{ Design:
{  A special PF interface is used to detach the file.
{  A ring 1 routine is called to invalidate the entries.

{ PDT clemsf_pdt

?? PUSH (LISTEXT := ON) ??

    VAR
      clemsf_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [NIL, NIL];

?? POP ??

    VAR
      ls: ost$status,
      sdf: array [1 .. osc$max_simulated_faults] of ost$simulated_disk_fault,
      i: integer;

    IF NOT jmp$system_job () THEN
      RETURN;
    IFEND;

    IF NOT osv$disk_fault_simulation THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, clemsf_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sdf := osv$simulated_disk_fault;
    osp$clear_disk_faults_r1;
    FOR i := LOWERBOUND (sdf) TO UPPERBOUND (sdf) DO
      IF sdf [i].in_use THEN
        IF NOT sdf [i].direct_sfid THEN
          pfp$dm_return_item (sdf [i].sfid, status);
          IF NOT status.normal THEN
            osp$generate_message (status, ls);
          IFEND;
        IFEND;
      IFEND;
    FOREND;

    status.normal := true;
  PROCEND osp$clear_disk_faults;

MODEND osm$simulate_disk_fault
*DECK DECK=OSM$SIMULATE_DISK_FAULT_R1 EXPAND=TRUE
MODULE osm$simulate_disk_fault_r1;
?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc osv$simulated_disk_fault
*copyc osp$set_status_abnormal
?? POP ??

{ Purpose:
{  To manage the mainframe wired table associated with disk fault simulation.
{ Design:
{ Notes:
{  No interlocking is performed.
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$simulate_disk_fault_r1
    (    sdf: ost$simulated_disk_fault;
     VAR status: ost$status);

    VAR
      i: integer;

    FOR i := LOWERBOUND (osv$simulated_disk_fault)
          TO UPPERBOUND (osv$simulated_disk_fault) DO
      IF NOT osv$simulated_disk_fault [i].in_use THEN
        osv$simulated_disk_fault [i] := sdf;
        status.normal := TRUE;
        RETURN;
      IFEND;
    FOREND;
    osp$set_status_abnormal ('XX', 1, 'Simulated disk fault table full', status);
  PROCEND osp$simulate_disk_fault_r1;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$clear_disk_faults_r1;

    VAR
      i: integer;

    FOR i := LOWERBOUND (osv$simulated_disk_fault)
          TO UPPERBOUND (osv$simulated_disk_fault) DO
      osv$simulated_disk_fault [i].in_use := FALSE;
    FOREND;
  PROCEND osp$clear_disk_faults_r1;
MODEND osm$simulate_disk_fault_r1
*DECK DECK=OSM$SPI_DATA_COLLECTOR EXPAND=TRUE
MODULE osm$spi_data_collector;
?? PUSH (LISTEXT := ON) ??
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc amp$set_segment_position
*copyc cld$parameter_list
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osd$default_pragmats
*copyc osp$collect_spi_data
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$free_spi_environment
*copyc osp$initialize_spi_environment
*copyc ost$spi_control
*copyc ost$spi_data_header
*copyc ost$status
*copyc pmp$get_legible_date_time
*copyc pmp$long_term_wait
?? POP ??

?? TITLE := 'PROCEDURE osp$spi_data_collector', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$spi_data_collector
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      collection_file_id: amt$file_identifier,
      collection_file_is_open: boolean,
      collection_file_pointer: amt$segment_pointer,
      end_of_information_set: boolean,
      file_header_information: ^ost$spi_data_header,
      first_time: boolean,
      local_status: ost$status,
      spi_collection_running: boolean,
      spi_control: ost$spi_control,
      spi_environment_is_free: boolean;

?? TITLE := 'PROCEDURE handler', EJECT ??

    PROCEDURE handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

{
{ This procedure is the block exit handler for the SPI data collector.
{ It will try to clean up the SPI collector environment if the collector
{ task abnormally terminates.
{
{ All statements are executed in order. Status is not checked since
{ we are trying to clean up the environment and all procedures must
{ be called.
{
      IF spi_collection_running THEN
        osp$collect_spi_data (collection_file_pointer.cell_pointer,
              spi_collection_running, status);
        amp$set_segment_position (collection_file_id, collection_file_pointer,
              status);
        IF NOT end_of_information_set THEN
          amp$set_segment_eoi (collection_file_id, collection_file_pointer,
                status);
          end_of_information_set := TRUE;
        IFEND;
        spi_collection_running := FALSE;
      IFEND;

      IF collection_file_is_open THEN
        fsp$close_file (collection_file_id, status);
        collection_file_is_open := FALSE;
      IFEND;

      IF NOT spi_environment_is_free THEN
        osp$free_spi_environment (status);
        spi_environment_is_free := FALSE;
      IFEND;
      handler_status.normal := TRUE;

    PROCEND handler;

?? TITLE := 'PROCEDURE osp$spi_data_collector', EJECT ??
{
{ This procedure is the main control procedure for collecting SPI data.
{ This task is an asynchronous task. It gets data from the parent task and
{ gives it to the PP and takes the PP driver data and places it into a segment
{ access file.
{
    collection_file_is_open := FALSE;
    end_of_information_set := FALSE;
    spi_collection_running := FALSE;
    spi_environment_is_free := FALSE;

    osp$establish_condition_handler (^handler, TRUE);
    osp$initialize_spi_environment (spi_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

    fsp$open_file (spi_control.collection_file, amc$segment, NIL, NIL, NIL,
          NIL, NIL, collection_file_id, status);
    IF NOT status.normal THEN
      fsp$close_file (collection_file_id, local_status);
      osp$free_spi_environment (local_status);
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    collection_file_is_open := TRUE;

    amp$get_segment_pointer (collection_file_id, amc$cell_pointer,
          collection_file_pointer, status);
    IF NOT status.normal THEN
      fsp$close_file (collection_file_id, local_status);
      osp$free_spi_environment (local_status);
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;

{ Set up the header information for the SPI collection file.

    file_header_information := collection_file_pointer.cell_pointer;
    file_header_information^.number_of_spi_samples :=
          spi_control.number_of_spi_samples;
    file_header_information^.spi_sampling_interval :=
          spi_control.spi_sampling_interval;
    file_header_information^.spi_identifier := spi_control.spi_identifier;
    file_header_information^.run_comments := spi_control.data_string;
    file_header_information^.number_of_samples_collected := 0;
    pmp$get_legible_date_time (osc$month_date,
          file_header_information^.sample_date, osc$ampm_time,
          file_header_information^.sample_time, status);
    collection_file_pointer.cell_pointer :=
          #ADDRESS (#RING (collection_file_pointer.cell_pointer),
          #SEGMENT (collection_file_pointer.cell_pointer),
          #OFFSET (collection_file_pointer.cell_pointer) +
          #SIZE (ost$spi_data_buffer));

{
{ This loop is the main collection loop for the collection of SPI data.
{ It is taken out of wait by interrupts from the SPI PP driver or by
{ the parent task issuing a ready task in response to a SPI command.
{
    spi_collection_running := TRUE;

  /data_collection_loop/
    WHILE TRUE DO
      osp$collect_spi_data (collection_file_pointer.cell_pointer,
            spi_collection_running, status);
      amp$set_segment_position (collection_file_id, collection_file_pointer,
            status);
      IF NOT spi_collection_running THEN
        EXIT /data_collection_loop/;
      IFEND;
      pmp$long_term_wait (30000, 30000);
    WHILEND /data_collection_loop/;
{
{ Now the collection of SPI data has finished. Close the collection file
{ and free the SPI environment for the next user.
{
    amp$set_segment_eoi (collection_file_id, collection_file_pointer, status);
    end_of_information_set := TRUE;
    fsp$close_file (collection_file_id, status);
    collection_file_is_open := FALSE;
    osp$free_spi_environment (status);
    spi_environment_is_free := TRUE;
    osp$disestablish_cond_handler;

  PROCEND osp$spi_data_collector;

MODEND osm$spi_data_collector;

*DECK DECK=OSM$SPI_DATA_COLLECTOR_R1 EXPAND=TRUE
MODULE osm$spi_data_collector_r1;

*copyc osd$default_pragmats
*copyc osv$spi_control
*copyc pmp$ready_task
*copyc pmp$get_executing_task_gtid


?? TITLE := 'PROCEDURE osp$free_spi_environment_r1', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$free_spi_environment_r1
    (VAR status: ost$status);

    status.normal := TRUE;
    osv$spi_control.collector_task.index := 0;
    osv$spi_control.collector_task.seqno := 0;
    osv$spi_control.operation_status := osc$spi_process_complete;
    osv$spi_control.number_of_spi_samples := 0;
    osv$spi_control.max_pages := 0;
    osv$spi_control.spi_sampling_interval := 0;
    osv$spi_control.spi_identifier := 0;
    osv$spi_control.collection_file := ' ';
    osv$spi_control.data_string := ' ';

    pmp$ready_task (osv$spi_control.initiator_task, status);

  PROCEND osp$free_spi_environment_r1;

?? TITLE := 'PROCEDURE osp$initialize_spi_collector_r1 ', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$initialize_spi_collector_r1
    (VAR spi_control: ost$spi_control;
     VAR status: ost$status);

    status.normal := TRUE;
    osv$spi_control.pp_available := TRUE;

    pmp$get_executing_task_gtid (osv$spi_control.collector_task);

    pmp$ready_task (osv$spi_control.initiator_task, status);

    spi_control := osv$spi_control;

  PROCEND osp$initialize_spi_collector_r1;

MODEND osm$spi_data_collector_r1;

*DECK DECK=OSM$SPI_DATA_COLLECTOR_R3 EXPAND=TRUE
MODULE osm$spi_data_collector_r3;
?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc cmp$idle_pp
*copyc cmp$execute_pp_program
*copyc cmp$release_element
*copyc cmp$reserve_element
*copyc i#real_memory_address
*copyc i#move
*copyc mmp$create_user_segment
*copyc mmp$delete_user_segment
*copyc ofp$display_status_message
*copyc osp$free_spi_environment_r1
*copyc osp$initialize_spi_collector_r1
*copyc pmp$ready_task
*copyc pmp$zero_out_table
*copyc oss$task_private
*copyc ost$spi_communication_buffer
*copyc ost$spi_control
*copyc osv$spi_control
*copyc osv$external_interrupt_selector
?? POP ??

  VAR
    osv$spi_communication_buffer: [XDCL, #GATE,
          oss$task_private] ^ost$spi_communication_buffer;

?? TITLE := 'PROCEDURE osp$initialize_spi_environment', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$initialize_spi_environment
    (VAR spi_control: ost$spi_control;
     VAR status: ost$status);

    VAR
      buffer_offset: ost$segment_offset,
      buffer_pages: ost$number_of_spi_buffers,
      buffer_ring: ost$ring,
      buffer_segment: ost$segment,
      collector_buffer_segment: amt$segment_pointer,
      communication_segment: ^SEQ (ost$spi_communication_buffer),
      element_reservation: array [1 .. 1] of cmt$element_reservation,
      ignore_status : ost$status,
      pp_program_description: array [1 .. 1] of cmt$pp_program_description,
      real_memory_address: integer,
      segment_attributes_p: ^array [1 .. 3] of mmt$user_attribute_descriptor;

    status.normal := TRUE;
{
{  This part of the initialization routine requests any available PP in the
{  system for the SPI PP driver.
{
    ofp$display_status_message ('Waiting for a PP to be assigned to SPI.', status);
    element_reservation [1].element_type := cmc$pp_element;
    element_reservation [1].pp_reservation.selector := cmc$choose_any_pp;
    cmp$reserve_element (element_reservation, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{
{  Now a request is made to load the SPI PP driver into the PP reserved
{  in the lines above. The communication buffer is returned as part of
{  this request.
{

    pp_program_description [1].pp_identification :=
          element_reservation [1].pp_reservation.acquired_pp_identification;
    pp_program_description [1].iou_program_name := 'SPI';
    pp_program_description [1].pp_program := NIL;
    pp_program_description [1].master_pp := TRUE;
    pp_program_description [1].element_access := NIL;
    pp_program_description [1].communication_buffer_length :=
          #SIZE (ost$spi_communication_buffer);
    cmp$execute_pp_program (pp_program_description, status);
    IF NOT status.normal THEN
      cmp$release_element (element_reservation, ignore_status);
      RETURN;
    IFEND;
    ofp$display_status_message ('SPI PP is ready to collect data.', status);
    communication_segment := pp_program_description [1].communication_buffer;
    RESET communication_segment;
    NEXT osv$spi_communication_buffer IN communication_segment;
    PUSH segment_attributes_p;
{
{  A wired segment is next requested for the SPI data buffers. This area
{  must be wired because the PP deals with RMA addresses that are fixed.
{
    segment_attributes_p^ [1].keyword := mmc$ua_wired_segment;
    segment_attributes_p^ [1].wired_segment_length := #SIZE (ost$spi_buffers);
    segment_attributes_p^ [1].contiguous_real_memory := FALSE;
    segment_attributes_p^ [2].keyword := mmc$ua_ring_numbers;
    segment_attributes_p^ [2].r1 := osc$user_ring;
    segment_attributes_p^ [2].r2 := osc$user_ring;
    segment_attributes_p^ [3].keyword := mmc$ua_max_segment_length;
    segment_attributes_p^ [3].max_length := #SIZE (ost$spi_buffers);

    mmp$create_user_segment (segment_attributes_p, amc$cell_pointer,
          mmc$as_random, collector_buffer_segment, status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;
    osp$initialize_spi_collector_r1 (spi_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
{
{  This area initializes the CP - PP communication area. The PP waits
{  until the CP status contains osc$wait_for_start. At that time it
{  knows that the communication buffer has all the necessary data in it.
{
    osv$spi_communication_buffer^.element_reservation := element_reservation;
    osv$spi_communication_buffer^.current_pp_buffer := osc$first_spi_buffer;
    osv$spi_communication_buffer^.current_byte_offset := 0;
    osv$spi_communication_buffer^.current_cp_buffer := osc$first_spi_buffer;
    osv$spi_communication_buffer^.spi_identifier := spi_control.spi_identifier;
    osv$spi_communication_buffer^.number_of_spi_samples :=
          spi_control.number_of_spi_samples;
    osv$spi_communication_buffer^.spi_sampling_interval :=
          spi_control.spi_sampling_interval;
    buffer_ring := #RING (collector_buffer_segment.cell_pointer);
    buffer_segment := #SEGMENT (collector_buffer_segment.cell_pointer);
    buffer_offset := #OFFSET (collector_buffer_segment.cell_pointer);
{
{  Each page is initialized. Note that the SPI page is only 2k. This is
{  to permit SPI to work on any hardware size page set by the operating system.
{
    FOR buffer_pages := LOWERVALUE (buffer_pages)
          TO UPPERVALUE (buffer_pages) DO
      osv$spi_communication_buffer^.spi_data_buffer_control [buffer_pages].
            current_word_offset := 0;
      osv$spi_communication_buffer^.spi_data_buffer_control [buffer_pages].
            current_buffer_status := osc$spi_buffer_available;
      osv$spi_communication_buffer^.spi_data_buffer_control [buffer_pages].
            pva_of_buffer := #ADDRESS (buffer_ring, buffer_segment,
            buffer_offset);
{
{  The following statement is to access the page and wire it down.
{
      osv$spi_communication_buffer^.spi_data_buffer_control [buffer_pages].
            pva_of_buffer^.buffer [1] := 0;
      i#real_memory_address (#ADDRESS (buffer_ring, buffer_segment,
            buffer_offset), real_memory_address);
      osv$spi_communication_buffer^.spi_data_buffer_control [buffer_pages].
            rma_of_buffer := real_memory_address;
      buffer_offset := buffer_offset + #SIZE (ost$spi_data_buffer);
    FOREND;
    osv$spi_communication_buffer^.processor_0_select :=
          osv$spi_control.processor_0_select;
    osv$spi_communication_buffer^.processor_1_select :=
          osv$spi_control.processor_1_select;
    osv$spi_communication_buffer^.processor_2_select :=
          osv$spi_control.processor_2_select;
    osv$spi_communication_buffer^.processor_3_select :=
          osv$spi_control.processor_3_select;
    osv$spi_communication_buffer^.processor_4_select :=
          osv$spi_control.processor_4_select;
    osv$spi_communication_buffer^.processor_5_select :=
          osv$spi_control.processor_5_select;
    osv$spi_communication_buffer^.current_cp_status := osc$spi_wait_for_start;
    osv$spi_communication_buffer^.current_pp_status :=
          osc$spi_pp_waiting_for_start;

  PROCEND osp$initialize_spi_environment;

?? TITLE := 'PROCEDURE osp$collect_spi_data', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$collect_spi_data
    (VAR collection_file_pointer: ^cell;
     VAR spi_collection_running: boolean;
     VAR status: ost$status);

{
{  This procedure moves all available data from the SPI data buffers into
{  a segment for the data file. The copied data buffers are freed for reuse
{  by the SPI PP driver. This routine also updates the current PP interrupt
{  port mask, the current CP status to the PP and terminates the collector
{  task when the PP is finished.
{

    VAR
      buffer: ost$number_of_spi_buffers,
      cp_buffer: ost$number_of_spi_buffers,
      offset_of_collection_file: ost$segment_offset,
      pp_buffer: ost$number_of_spi_buffers,
      ring_of_collection_file: ost$ring,
      segment_of_collection_file: ost$segment,
      work_is_done: boolean;

    status.normal := TRUE;
    spi_collection_running := TRUE;

  /collection_loop/
    REPEAT
      work_is_done := TRUE;
{
{  This is the termination control part of the collector. The task will
{  terminate when all the data buffers are free and the PP has terminated
{  execution. Any other condition the collector continues execution.
{
      IF osv$spi_communication_buffer^.current_pp_buffer =
            osv$spi_communication_buffer^.current_cp_buffer THEN
        IF osv$spi_communication_buffer^.current_pp_status =
              osc$spi_pp_terminated THEN
          spi_collection_running := FALSE;
        IFEND;
        EXIT /collection_loop/;
      IFEND;

      cp_buffer := osv$spi_communication_buffer^.current_cp_buffer;
      pp_buffer := osv$spi_communication_buffer^.current_pp_buffer;
      ring_of_collection_file := #RING (collection_file_pointer);
      segment_of_collection_file := #SEGMENT (collection_file_pointer);
      offset_of_collection_file := #OFFSET (collection_file_pointer);
{
{  This next part of code is executed when the PP buffer has looped
{  around the circular buffer and the CP has to catch up.
{
      IF osv$spi_communication_buffer^.current_pp_buffer <
            osv$spi_communication_buffer^.current_cp_buffer THEN

      /data_collection_loop/
        FOR buffer := osv$spi_communication_buffer^.
              current_cp_buffer TO osc$last_spi_buffer DO
          IF osv$spi_communication_buffer^.spi_data_buffer_control [buffer].
                current_buffer_status <> osc$spi_buffer_has_data THEN
            EXIT /data_collection_loop/;
          IFEND;
          work_is_done := FALSE;
          i#move (osv$spi_communication_buffer^.
                spi_data_buffer_control [buffer].pva_of_buffer,
                collection_file_pointer, #SIZE (ost$spi_data_buffer));
          offset_of_collection_file := offset_of_collection_file +
                (osv$spi_communication_buffer^.spi_data_buffer_control
                [buffer].current_word_offset * 8);
          collection_file_pointer := #ADDRESS (ring_of_collection_file,
                segment_of_collection_file, offset_of_collection_file);
          pmp$zero_out_table (osv$spi_communication_buffer^.
                spi_data_buffer_control [buffer].
                pva_of_buffer, #SIZE (ost$spi_data_buffer));
          osv$spi_communication_buffer^.spi_data_buffer_control [buffer].
                current_word_offset := 0;
          osv$spi_communication_buffer^.spi_data_buffer_control [buffer].
                current_buffer_status := osc$spi_buffer_available;
          IF buffer = osc$last_spi_buffer THEN
            cp_buffer := osc$first_spi_buffer;
          ELSE
            cp_buffer := buffer + 1;
          IFEND;
        FOREND /data_collection_loop/;
      IFEND;
      osv$spi_communication_buffer^.current_cp_buffer := cp_buffer;
{
{ This part of the code moves any available data from the PP buffer to
{ the collection file and updates the control information.
{

    /data_collection_loop_2/
      FOR buffer := osv$spi_communication_buffer^.
            current_cp_buffer TO osc$last_spi_buffer DO
        IF osv$spi_communication_buffer^.spi_data_buffer_control [buffer].
              current_buffer_status <> osc$spi_buffer_has_data THEN
          EXIT /data_collection_loop_2/;
        IFEND;
        work_is_done := FALSE;
        i#move (osv$spi_communication_buffer^.spi_data_buffer_control [buffer].
              pva_of_buffer, collection_file_pointer,
              #SIZE (ost$spi_data_buffer));
        offset_of_collection_file := offset_of_collection_file +
              (osv$spi_communication_buffer^.spi_data_buffer_control [buffer].
              current_word_offset * 8);
        collection_file_pointer := #ADDRESS (ring_of_collection_file,
              segment_of_collection_file, offset_of_collection_file);
        pmp$zero_out_table (osv$spi_communication_buffer^.
              spi_data_buffer_control [buffer].
              pva_of_buffer, #SIZE (ost$spi_data_buffer));
        osv$spi_communication_buffer^.spi_data_buffer_control [buffer].
              current_word_offset := 0;
        osv$spi_communication_buffer^.spi_data_buffer_control [buffer].
              current_buffer_status := osc$spi_buffer_available;
        IF buffer = osc$last_spi_buffer THEN
          cp_buffer := osc$first_spi_buffer;
        ELSE
          cp_buffer := buffer + 1;
        IFEND;
      FOREND /data_collection_loop_2/;
      osv$spi_communication_buffer^.current_cp_buffer := cp_buffer;
    UNTIL work_is_done;
{
{  Before exiting the procedure the CP status and current interrupt port mask
{  is updated to the SPI PP driver.
{
    osv$spi_communication_buffer^.current_cp_status :=
          osv$spi_control.operation_status;
    osv$spi_communication_buffer^.interrupt_port_selector :=
          osv$external_interrupt_selector;
    IF osv$spi_communication_buffer^.current_pp_status = osc$spi_pp_terminated THEN
      ofp$display_status_message ('The SPI data collector has terminated.', status);
    IFEND;

  PROCEND osp$collect_spi_data;

?? TITLE := 'PROCEDURE osp$free_spi_environment', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$free_spi_environment
    (VAR status: ost$status);

    VAR
      buffer_pointer: ^cell,
      collector_buffer_segment: amt$segment_pointer,
      element_reservation: array [1 .. 1] of cmt$element_reservation,
      pp_memory_size: cmt$pp_memory_length,
      pp_registers: cmt$pp_registers,
      pp_software_idled: boolean;

    status.normal := TRUE;
{
{  The following two lines must be executed before the call to idle_pp.
{  Status is ignored on all of the system calls since all the system calls
{  must be executed to return all system resources.
{
    buffer_pointer := osv$spi_communication_buffer^.
          spi_data_buffer_control [1].pva_of_buffer;
    element_reservation := osv$spi_communication_buffer^.element_reservation;
    cmp$idle_pp (element_reservation [1].pp_reservation.
          acquired_pp_identification, FALSE, TRUE, NIL, pp_memory_size,
          pp_registers, pp_software_idled, status);

    cmp$release_element (element_reservation, status);

    collector_buffer_segment.kind := amc$cell_pointer;
    collector_buffer_segment.cell_pointer := buffer_pointer;
    mmp$delete_user_segment (collector_buffer_segment, status);

    osp$free_spi_environment_r1 (status);

  PROCEND osp$free_spi_environment;

MODEND osm$spi_data_collector_r3;

*DECK DECK=OSM$SPI_MONITOR_MODE EXPAND=TRUE
MODULE osm$spi_monitor_mode;
*copyc iot$io_request
*copyc osd$default_pragmats
*copyc oss$mainframe_wired
*copyc ost$spi_control
*copyc tmp$check_taskid
*copyc tmp$set_task_ready

?? TITLE := 'PROCEDURE osp$spi_response_processor', EJECT ??

  PROCEDURE [XDCL] osp$spi_response_processor
    (    pp_response_p: ^iot$pp_response;
         detailed_status_p: ^iot$detailed_status;
         pp: 1 .. ioc$pp_count;
     VAR status: syt$monitor_status);

{
{ Purpose:
{
{ The purpose of this module is to ready the SPI data collector task when
{ the PP issues an unsolicited interupt.
{

    VAR
      osv$spi_response_processor: [XDCL, STATIC, #GATE, oss$mainframe_wired]
            iot$response_processor := ^osp$spi_response_processor,
      osv$spi_control: [XDCL, STATIC, #GATE, oss$mainframe_wired]
            ost$spi_control;

    status.normal := TRUE;

{
{ The collector task may have terminated by this time. First check to see
{ if the task is still running. If it is still running then ready the task.
{
    tmp$check_taskid (osv$spi_control.collector_task, tmc$opt_return, status);

    IF NOT status.normal THEN
      status.normal := TRUE;
      RETURN;
    IFEND;

    tmp$set_task_ready (osv$spi_control.collector_task, 0 {readying_task_priority},
          tmc$rc_ready_conditional_wi);

  PROCEND osp$spi_response_processor;

MODEND osm$spi_monitor_mode;
*DECK DECK=OSM$SPI_PP_DRIVER EXPAND=TRUE
          IDENT SPI
          CIPPU
          TITLE OSM$SPI PP DRIVER
          COMMENT *SMD* LVL=01
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE 4
**  NAME SPI, DECK NAME IS OSM$SPI_PP_DRIVER.
*
** PURPOSE: THE PURPOSE OF THIS PROGRAM IS TO READ THE CPU
*         PROGRAM REGISTER FROM THE MAINTENANCE CHANNEL AND  PLACE THE RESULT
*         IN A CENTRAL MEMORY BUFFER.
*
** DETAILS: THE PP GETS ITS INSTRUCTION FROM ONE OF TWO PLACES.
*         1) THE PP INTERFACE TABLE FOR IDLE AND RESUME.
*         2) THE COMMUNICATION BUFFER FOR SPI DATA COLLECTION.
*
*         THE COMMUNICATION BUFFER INITIALLY PROVIDES THE INFORMATION ON THE
*         TYPE OF COLLECTION THAT WILL BE PROCESSED BY THE PP. THIS INCLUDES
*         THE SPI IDENTIFIER FOR SELECTED SAMPLES, THE NUMBER OF SAMPLES,
*         THE INTERVAL BETWEEN SAMPLES, THE PP INTERRUPT PORT AND THE LOCATION
*         OF THE CENTRAL MEMORY BUFFERS. AS TIME PROGRESSES THE CP STATUS WILL
*         CHANGE TO ONE OF THE FOLLOWING STATES: 1) START 2) STOP OR
*         3) TERMINATE. THE PP WILL RESPOND TO THE CP STATES BY PLACING THE
*         PP STATE IN THE PP STATUS WORD OF THE COMMUNICATION BUFFER. THE DATA
*         COLLECTION WILL BE TO A POOL OF 2O48 BYTE BUFFERS. EACH BUFFER WILL BE
*         WITHIN A SINGLE PAGE. WHEN THE BUFFER IS FILLED THE STATUS IS CHANGED
*         TO FILLED WITH DATA, AN INTERRUPT IS GIVEN TO THE CP AND THE NEXT
*         BUFFER IS SELECTED. IF THE STATE OF THE NEXT BUFFER IS NOT AVAILABLE
*         FOR USE THEN THE PP WAITS FOR THE BUFFER TO BECOME AVAILABLE.
*         THE PAUSE LOOP IS MACHINE DEPENDENT AND ANY CHANGES TO THAT ROUTINE
*         SHOULD TAKE THE MACHINE DEPENDENCIES INTO ACCOUNT. THIS PROGRAM WAS
*         WRITTEN TO BE EASILY CHANGED WHEN VE SUPPORTS MORE THAN 2 PROGESSORS
*         ON A SINGLE CLUSTER.
          SPACE   4
*copyc IODMAC1 "{RECORD DEFINITION MACROS}
*copyc IODMAC2 "{LOAD/STORE MACROS}
*copyc IODMAC3 "{GENERAL MACROS}
*copyc IODMAC4 "{GENERAL MACROS}
*copyc dsi$maintenance_register_macros
*copyc dsa$hardware_table_definitions
*copyc dsi$pp_macros
*COPYC DSC$PP_MR_AND_TPM_CONSTANTS
*COPYC CTI$DFT_ANALYSIS_CODES
*COPYC CTC$EI_CONTROL_BLOCK
          EJECT


* EQUATES

 C.CHCNT  EQU    37          NUMBER OF REQUESTS TO PROCESS BEFORE
                             CLEARING CHANNEL LOCK
 RR       EQU    400000B     R-REGISTER ACTIVATION

* INTERFACE ERROR CODES.
 E501     EQU    2401B       INVALID COMMAND CODE
          SPACE  10
* SS TABLE DEFINITIONS. INFORMATION SAVED FOR EACH UNIT.

 SS       RECORD PACKED

* WORD 1

 CHAN     SUBRANGE 0,77B     CHANNEL NUMBER
 FILL1    SUBRANGE 0,77B
 SEEK     BOOLEAN            SEEK ISSUED
 CUR      BOOLEAN            CURRENT REQUEST HAS BEEN SELECTED (IF SET)
 DV       SUBRANGE 0,3       DEVICE TYPE

* WORDS 2 - 6 = PARAMETERS FOR LOAD COMMAND BLOCK FUNCTION.

 FILL2    SUBRANGE 0,7
 SMALL    BOOLEAN            512 BYTE SECTOR, IF SET
 PRIOV    BOOLEAN            PRIORITY OVERRIDE IF SET
 FILL3    SUBRANGE 0,37B
 CMOD     SUBRANGE 0,7       CONTROL MODULE NUMBER
 UNIT     SUBRANGE 0,7       UNIT NUMBER
*
 FUNC     PPWORD             FUNCTION CODE
*
 CYL      PPWORD             CYLINDER ADDRESS
*
 TRACK    SUBRANGE 0,377B    TRACK ADDRESS
 SECTOR   SUBRANGE 0,377B    SECTOR ADDRESS
*
 TLFLG    BOOLEAN            NONZERO MEANS USE TRANSFER LENGTH
 LENGTH   SUBRANGE 0,77777B  TRANSFER LENGTH

* WORD 7 - END = SAVED INFORMATION PER UNIT.

 FNC      PPWORD             FUNCTION CODE  READ = 0
                                            WRITE = 1
                                            WRITE INITIALIZE = 2
 REQ      STRUCT 4           CURRENT REQUEST (UNFORMATTED RMA)
 PVA      STRUCT 6           PVA OF CURRENT REQUEST

 LASTC    PPWORD             OFFSET OF COMMAND IN REQUEST
 QSEL     PPWORD             REQUEST SELECTION ALGORITHM
 FRST     PPWORD             = 0, IF FIRST TIME THROUGH UNCMND
 NUMCM    PPWORD             NUMBER OF COMMANDS LEFT TO PROCESS IN
                             THIS REQUEST
 LISTL    PPWORD             NUMBER OF CM WORDS IN ADDRESS-LENGTH PAIR LIST.
                             (INCLUDES THE NUMBER OF WORDS WHICH HAVENT
                             BEEN READ FROM CM.)
 TOTAL    STRUCT 4           TOTAL CM WORDS LEFT TO TRANSFER BEFORE TERMINATING
 FCOMRQ   STRUCT 4           FIRST COMPLETED REQUEST (RMA)
 CURRQ    STRUCT 4           CURRENT REQUEST (RMA)
 PRERQ    STRUCT 4           PREVIOUS REQUEST (RMA)
 NCOMRQ   PPWORD             NUMBER OF COMPLETED REQUESTS
 NCOMW    PPWORD             NUMBER OF COMPLETED WRITE REQUESTS
 CURTRK   PPWORD             CURRENT TRACK
 CURSEC   PPWORD             CURRENT SECTOR
 SWFLG    PPWORD             NONZERO IF A STREAMING REQUEST SWITCH WAS MADE
 RVCNT    PPWORD             COUNT OF RECOVERED ERRORS PER REQUEST
 RQTRY    PPWORD             REQUEST RETRY COUNT
 ADERR    PPWORD             ADAPTER ERROR
 NR       PPWORD             NOT READY RETRY COUNT
 LAD      PPWORD             LOAD ADAPTER RETRY COUNTER
 CMLD     PPWORD             CM LOAD RETRY COUNTER
 PRELD    PPWORD             PRELOAD OF CONTROL MODULE IF NONZERO
 DIAG     PPWORD             NONZERO IF RUNNING LEVEL II DIAGNOSTICS
 DIAGS    PPWORD             NONZERO IF RUNNING DIAGNOSTICS COMMAND 72
 RECOV    PPWORD             NONZERO IF IN RECOVERY


* CURRENT REQUEST.  MUST BE ALIGNED ON A WORD BOUNDARY.

          ALIGN  0,64
 RQ       STRUCT 40          REQUEST

 CMLIST   STRUCT 8           CURRENT DATA ADDRESS OR CURRENT COMMAND

* RESPONSE.

 RS       STRUCT 152         RESPONSE
          MGEN   N.CUR
 M.CUR    EQU    MASK$
          MGEN   N.SEEK
 M.SEEK   EQU    MASK$
          MASKP  SEEK
 K.SEEK   EQU    MSK
          MASKP  CUR
 K.CUR    EQU    MSK
          MGEN   N.CHAN
 M.CHAN   EQU    MASK$
          MGEN   N.DV
 M.DV     EQU    MASK$
          MASKP  SMALL
 K.SMALL  EQU    MSK
          MGEN   N.SMALL
 M.SMALL  EQU    MASK$
          MASKP  PRIOV
 K.PRIOV  EQU    MSK
          MGEN   N.UNIT
 M.UNIT   EQU    MASK$
          MASKP  UNIT
 K.UNIT   EQU    MSK
          MASKP  CMOD
 K.CMOD   EQU    MSK
          MGEN   N.CMOD
 M.CMOD   EQU    MASK$
          MGEN   N.TRACK
 M.TRACK  EQU    MASK$
          MGEN   N.SECTOR
 M.SECTOR EQU    MASK$

 SS       RECEND
          SPACE  6
* PP TABLE.

 PT       RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 PART     PPWORD             PARTNER PP NUMBER
 PIT      RMA                PP INTERFACE TABLE ADDRESS (RMA)
 PITPVA   STRUCT 24          PP INTERFACE TABLE ADDRESS (PVA)

 PT       RECEND
          SPACE  6
* PP INTERFACE TABLE
 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
          ALIGN  0,64
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER
          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)
          ALIGN  32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          SPACE  6
* PP REQUESTS.

 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS
                               0 - ATTEMPT RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
          ALIGN  0,64
 SWIT     BOOLEAN            SWITCH TO NEXT REQUEST
          ALIGN  16,64
 CYL      PPWORD             CYLINDER ADDRESS
 TRACK    PPWORD             TRACK ADDRESS
 SECTOR   PPWORD             SECTOR ADDRESS
 CMND     INTEGER            COMMAND SEQUENCE


          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$

 RQ       RECEND
          SPACE  6
* PP COMMAND.

 CM       RECORD PACKED

 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$

 CM       RECEND
          SPACE  6
* COMMAND CODES.

 C.IDLE   EQU    4           IDLE
 C.RESUME EQU    5           RESUME
          SPACE  6
* PP RESPONSE.

 RS       RECORD PACKED

* WORD 1.
          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST

* WORD 2.
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST  (NOT USED)

* WORD 3.
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST) (NOT USED)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)  (NOT USED)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS  (NOT USED)
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY  (NOT USED)
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

* WORD 4.
          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED  (NOT USED)
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE INTERFACE
                             ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
                             (NOT USED)
 CHERR    BOOLEAN            CHANNEL PARITY ERROR
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION
                             OCCURRED ON INPUT OR INADEQUATE DATA RATE ON OUTPUT
                             (NOT USED)
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT  (NOT USED)
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A
                             HARDWARE MALFUNCTION.  EX: UNIT NOT READY,
                             UNIT NOT CONNECTED.  (NOT USED)
 FTO      BOOLEAN            FUNCTION TIMEOUT
 CHERO    BOOLEAN            CHANNEL OUTPUT PARITY ERROR
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
                               1 - RECOVERED ERROR
                               2 - COMMAND HAD EXPLICIT RESPONSE FLAG SET
                               3 - BOTH CONDITIONS 1 AND 2
 K.REC    EQU    1           RECOVERED ERROR
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE  (NOT USED)
                               1 - UNIT CHANGED FROM READY TO NOT READY
                               2 - UNIT CHANGED FROM NOT READY TO READY
                               3 - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
                               4 - CONTROLLER RESERVED
                               5 - UNIT RESERVED TO ANOTHER ACCESS
                               6 - RECOVERED ABNORMAL CONDITION
          ALIGN  49,64       ALERT CONDITIONS
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
                             (NOT USED)

* WORD 5.
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)

 CHAN     PPWORD             CHANNEL NUMBER
 SCYL     PPWORD             STARTING CYLINDER
 STRK     PPWORD             STARTING TRACK
 SSEC     PPWORD             STARTING SECTOR

 UNIT     PPWORD             UNIT NUMBER
 RTRY     PPWORD             REQUEST RETRY COUNT
 FTRK     PPWORD             FAILING TRACK
 FSEC     PPWORD             FAILING SECTOR

 DET      PPWORD             =1, IF DETAILED STATUS PRESENT
 ID       PPWORD             ERROR IDENTIFIER
 K.CMLD   EQU    1           RELOAD OF CONTROL MODULE WAS ATTEMPTED
 K.CMLDS  EQU    2           CONTROL MODULE RELOADED SUCCESSFULLY
 K.XD     EQU    4           EXECUTING LEVEL II DIAGNOSTICS
 K.XDP    EQU    10B         LEVEL II DIAGNOSTICS PASSED
 K.PU     EQU    20B         POWERING UP SPINDLE
 K.PUC    EQU    40B         SPINDLE POWERED UP
 K.PTO    EQU    100B        PP TIMED OUT A COMMAND
 K.UDN    EQU    20000B      UNIT DOWN
 K.CMDN   EQU    40000B      CONTROL MODULE DOWN
 K.CHDN   EQU    100000B     CHANNEL DOWN
 FILL2    PPWORD
 STRY     PPWORD             SECTOR RETRY COUNT

 GENST1   PPWORD             GENERAL STATUS OF THE FIRST TIME ERROR
                               WAS ENCOUNTERED
 GENST2   PPWORD             GENERAL STATUS OF THE LAST TIME ERROR
                               WAS ENCOUNTERED
 FUNTO    PPWORD             FUNCTION CODE IF FUNCTION TIMEOUT ERROR
 ERRID    PPWORD             ERROR IDENTIFIER
 K.IST    EQU    1           INCOMPLETE SECTOR TRANSFER
 K.CRES   EQU    2           CLEAR UNIT RESERVE ON OPPOSITE ACCESS
 K.RAM    EQU    4           RAM PARITY ERROR
 K.CLOAD  EQU    10B         CONTROLWARE LOAD WAS ATTEMPTED
 K.AFT    EQU    20B         AUTOLOAD FUNCTION TIMEOUT
 K.CEMPT  EQU    40B         CHANNEL DOESNT GO EMPTY AFTER SENDING
                             PARAMETERS / DATA
 K.CINAC  EQU    100B        CHANNEL NOT INACTIVE AFTER
                             RECEIVING PARAMETERS / DATA
 K.MEDIA  EQU    200B        MEDIA FAILURE, REREAD SECTOR
 K.UNMED  EQU    400B        UNRECOVERED MEDIA ERROR
 K.RERR   EQU    1000B       READ ERROR.  STATUS BEFORE SUSPEND/TERMINATE .NE.
                             4XXXB.
 K.CF     EQU    2000B       POLL STATUS NONZERO AFTER SENDING CONTROLWARE
 K.DE     EQU    4000B       POLL STATUS NONZERO AFTER LOADING ATTENTION DELAY
 K.NR     EQU    10000B      NOT READY
 K.URS    EQU    20000B      UNIT RESERVED
 K.CRS    EQU    40000B      CONTROLLER RESERVED
 K.ADPT   EQU    100000B     ADAPTER CONTROLWARE ERROR
          ALIGN  0,64
 DETAIL   STRUCT 40          DETAILED STATUS OF THE FIRST TIME ERROR
                             WAS ENCOUNTERED
 DET2     STRUCT 40          DETAILED STATUS OF THE LAST TIME ERROR
                             WAS ENCOUNTERED.


          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$
          MASKP  INTERR
 K.INTERR EQU    MSK
          MASKP  DATOV
 K.DATOV  EQU    MSK
          MASKP  DATERR
 K.DATERR EQU    MSK
          MASKP  HDWR
 K.HDWR   EQU    MSK
          MASKP  CHERR
 K.CHERR  EQU    MSK
          MASKP  CHERO
 K.CHERO  EQU    MSK
          MASKP  NRDY
 K.NRDY   EQU    MSK
          MASKP  FTO
 K.FTO    EQU    MSK

 RS       RECEND
          SPACE  6
* RESPONSE CODES.
 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    1           INTERMEDIATE RESPONSE
 R.NRM    EQU    2           NORMAL REQUEST TERMINATION
 R.ABN    EQU    3           ABNORMAL REQUEST TERMINATION
          SPACE  10
* PP COMMUNICATION BUFFER.

 CB       RECORD PACKED

 PPBUF    PPWORD             BUFFER NUMBER BEING PROCESSED BY PP
 B.LOW    EQU    1           VALUE OF THE LOWEST BUFFER NUMBER
 B.HIGH   EQU    16D         VALUE OF THE HIGHEST BUFFER NUMBER
 PPOFF    PPWORD             OFFSET INTO PP BUFFER
 PPSTAT   PPWORD             PP GENERAL OPERATION STATUS
 S.PWAIT  EQU    6           WAITING TO START PROCESSING
 S.PCOL   EQU    7           COLLECTING DATA
 S.PSTOP  EQU    8           STOPPED COLLECTING DATA
 S.PTERM  EQU    9           TERMINATED DATA COLLECTING
          PPWORD

* SECOND WORD OF CB

 CPBUF    PPWORD             BUFFER NUMBER LAT PROCESSED BY CP
 CPSTAT   PPWORD             CP COLLECTOR STATUS REQUEST
 S.INIT   EQU    1           COMMUNICATION BUFFER IS INITIALIZED
 S.START  EQU    2           START COLLECTING
 S.STOP   EQU    3           STOP COLLECTING
 S.TERM   EQU    4           TERMINATE COLLECTING
 S.COMP   EQU    5           PROCESS COMPLETE
 SPIID    PPWORD             SPI ID NUMBER
 P0       BOOLEAN            PROCESSOR SELECT FLAG
 P1       BOOLEAN            PROCESSOR SELECT FLAG
 P2       BOOLEAN            PROCESSOR SELECT FLAG FUTURE USE
 P3       BOOLEAN            PROCESSOR SELECT FLAG FUTURE USE
 P4       BOOLEAN            PROCESSOR SELECT FLAG FUTURE USE
 P5       BOOLEAN            PROCESSOR SELECT FLAG FUTURE USE
 P6       BOOLEAN            PROCESSOR SELECT FLAG FUTURE USE
 P7       BOOLEAN            PROCESSOR SELECT FLAG FUTURE USE
 IPORT    CHARC              INTERRUPT PORT FOR INTERRUPT INSTRUCTION

* THIRD WORD OF CB

 SAMP     STRUCT 4           NUMBER OF SPI SAMPLES
 TIME     STRUCT 4           TIME BETWEEN SAMPLES

* FOURTH WORD OF CB

 BOFF1    PPWORD             OFFSET IN BUFFER
 BST1     PPWORD             STATUS OF BUFFER
 S.AVAIL  EQU    1           BUFFER IS AVAILABLE FOR PP USE
 S.INUSE  EQU    2           BUFFER IN USE BY PP
 S.DATA   EQU    3           BUFFER HAS DATA FOR CPU TO COPY
 BRMA1    RMA                RMA OF BUFFER
 BPVA1    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF2    PPWORD             OFFSET IN BUFFER
 BST2     PPWORD             STATUS OF BUFFER
 BRMA2    RMA                RMA OF BUFFER
 BPVA2    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF3    PPWORD             OFFSET IN BUFFER
 BST3     PPWORD             STATUS OF BUFFER
 BRMA3    RMA                RMA OF BUFFER
 BPVA3    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF4    PPWORD             OFFSET IN BUFFER
 BST4     PPWORD             STATUS OF BUFFER
 BRMA4    RMA                RMA OF BUFFER
 BPVA4    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF5    PPWORD             OFFSET IN BUFFER
 BST5     PPWORD             STATUS OF BUFFER
 BRMA5    RMA                RMA OF BUFFER
 BPVA5    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF6    PPWORD             OFFSET IN BUFFER
 BST6     PPWORD             STATUS OF BUFFER
 BRMA6    RMA                RMA OF BUFFER
 BPVA6    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF7    PPWORD             OFFSET IN BUFFER
 BST7     PPWORD             STATUS OF BUFFER
 BRMA7    RMA                RMA OF BUFFER
 BPVA7    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF8    PPWORD             OFFSET IN BUFFER
 BST8     PPWORD             STATUS OF BUFFER
 BRMA8    RMA                RMA OF BUFFER
 BPVA8    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF9    PPWORD             OFFSET IN BUFFER
 BST9     PPWORD             STATUS OF BUFFER
 BRMA9    RMA                RMA OF BUFFER
 BPVA9    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF10   PPWORD             OFFSET IN BUFFER
 BST10    PPWORD             STATUS OF BUFFER
 BRMA10   RMA                RMA OF BUFFER
 BPVA10   STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF11   PPWORD             OFFSET IN BUFFER
 BST11    PPWORD             STATUS OF BUFFER
 BRMA11   RMA                RMA OF BUFFER
 BPVA11   STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF12   PPWORD             OFFSET IN BUFFER
 BST12    PPWORD             STATUS OF BUFFER
 BRMA12   RMA                RMA OF BUFFER
 BPVA12   STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF13   PPWORD             OFFSET IN BUFFER
 BST13    PPWORD             STATUS OF BUFFER
 BRMA13   RMA                RMA OF BUFFER
 BPV13    STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF14   PPWORD             OFFSET IN BUFFER
 BST14    PPWORD             STATUS OF BUFFER
 BRMA14   RMA                RMA OF BUFFER
 BPVA14   STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF15   PPWORD             OFFSET IN BUFFER
 BST15    PPWORD             STATUS OF BUFFER
 BRMA15   RMA                RMA OF BUFFER
 BPVA15   STRUCT 6           PVA OF BUFFER
          PPWORD

 BOFF16   PPWORD             OFFSET IN BUFFER
 BST16    PPWORD             STATUS OF BUFFER
 BRMA16   RMA                RMA OF BUFFER
 BPVA16   STRUCT 6           PVA OF BUFFER
          PPWORD

 CB       RECEND
          EJECT
          CON    INIT-1


* DIRECT CELLS

 CM.PIT   BSSZ   3           CM ADDRESS OF PP INTERFACE TABLE (REFORMATED)

 T1       BSSZ   1
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1
 CM       BSSZ   4

 CMADR    BSSZ   3           CM ADDRESS
 CHAN     BSSZ   1           CHANNEL NUMBER
 P0       BSSZ   1           P SERIES USED BY PP DRIVER CODE
 W0       EQU    P0          W SERIES USED BY THE DEADSTART CODE
 P1       BSSZ   1
 W1       EQU    P1
 P2       BSSZ   1
 W2       EQU    P2
 P3       BSSZ   1
 W3       EQU    P3
 P4       BSSZ   1
 W4       EQU    P4
 P5       BSSZ   1
 W5       EQU    P5
 P6       BSSZ   1
 W6       EQU    P6
 WC       BSSZ   1           WORD COUNT TO READ/WRITE CM WORDS
 TM       BSSZ   2           TIMER COUNT DOWN UNTIL NEXT SAMPLE
 BN       BSSZ   1           CURRENT PROCESSING BUFFER NUMBER
 BA       BSSZ   1           ADDRESS OF REFORMATTED CENTRAL BUFFER
 FNC      BSSZ   1           FUNCTION CODE (INTERNAL)
 RESPC    BSSZ   1           RESPONSE CODE
 SSUN     CON    7777B       UX VALUE OF CURRENT SS TABLE
 CHLOCK   BSSZ   1           SET NONZERO IF CHANNEL LOCK IS SET
 IDLE     BSSZ   1           NONZERO IF IDLE COMMAND RECEIVED,
                               RESUME COMMAND RESETS IT TO 0
 PPRQ     BSSZ   1           PP REQUEST FLAG
 EC       BSSZ   1           MAINTENANCE REGISTER EQUIPEMENT CODE
 EC0      BSSZ   1           EQUIPEMNT CODE FOR PROCESSOR 0
 EC1      BSSZ   1           EQUIPMENT CODE FOR PROCESSOR 1
 MD       BSSZ   1           MODEL NUMBER
 RN       BSSZ   1           REGISTER NUMBER
 IB       BSSZ   2           EICB ACCESS
 HP       BSSZ   2           HOLD R REGISTER
 LFF00    BSSZ   1
          SPACE  3
          ORG    72B

 DSRTP    CON    0           HCS REAL MEMORY WORD-ADDRESS
          CON    1
 NODEL    EQU    DSRTP       DON'T DELINK REQUEST FLAG
 INPNT    EQU    DSRTP+1     IN POINTER FOR RESPONSE BUFFER
 LIM      BSSZ   1           LIMIT OF RESPONSE BUFFER (IN 8-BIT BYTES)
 PPNO     CON    1           LOGICAL PP NUMBER
          ORG    76B
          CON    5           TEMPORARY, PP TYPE USED BY DEADSTART
 LDCMF    EQU    76B         LOAD CONTROL MODULE, IF NONZERO
 ON       CON    1           CONSTANT 1 MAINLY USED FOR SINGLE WORD TRANSFERS
          EJECT
          ORG    100B
 START    LJM    INIT
          SPACE  6
 CM.CB    BSSZ   3           CM ADDRESS OF PP COMMUNICATION BUFFER (REFORMATTED)
 CM.RS    BSSZ   3           CM ADDRESS OF RESPONSE BUFFER (REFORMATTED)
 CM.INT   BSSZ   3           CM ADDRESS OF INTERRUPT WORD
 CM.CHAN  BSSZ   3           CM ADDRESS OF CHANNEL INTERLOCK TABLE
 CM.BF1   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF2   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF3   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF4   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF5   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF6   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF7   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF8   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF9   BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF10  BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF11  BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF12  BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF13  BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF14  BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF15  BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.BF16  BSSZ   3           CM ADDRESS OF SPI DATA BUFFER (REFORMATTED)
 CM.CBUF  BSSZ   3           CM ADDRESS OF CURRENT SPI BUFFER (REFORMATTED)
 BUFS     BSSZ   4
 MAXOFF   CON    256D        MAXIMUM NUMBER OF WORDS IN ONE SPI COLLECTION PAGE
 RDATA    BSSZ   8           CONTENTS OF P REGISTER
          BSSZ   3           REQUIRED TO BE BEFORE HBUF. DO NOT CHANGE OR MOVE.
 HBUF     BSSZ   CMXLEN      HARDWARE ELEMENT BUFFER
          SPACE  2
          EJECT
 SPI      BSS

** NAME - MAIN   THE MAIN PROCESSING LOOP
*
** PURPOSE THIS IS THE MAIN PROCESSING LOOP FO THE SPI DATA COLLECTOR.
*         IT CHECKS FOR ANY COMMANDS ON THE PP REQUEST QUEUE AND WILL
*         PROCESS THOSE REQUESTS. IF THE PP HAS NOT BEEN IDLED THEN
*         THE PP WILL COLLECT P REGISTER SAMPLES. AFTER THAT IT WILL
*         WAIT FOR 1 MS BEFORE TRYING AGAIN. THE ONLY VALID COMMANDS
*         FOR THIS PP FROM THE PP INTERFACE TABLE ARE IDLE AND RESUME.
*
** USES   MACRO PAUSE


 MAIN10   BSS
          RJM    PPREQ       CHECK FOR ANY PP REQUESTS
          ZJN    MAIN40      IF NO PP REQUESTS
          RJM    SRESP       SET UP RESPONSE BUFFER
 MAIN20   RJM    UNCMND      GET PP COMMAND AND SET UP TO PROCESS
          ZJN    MAIN35      IF NO MORE COMMANDS
          LDML   UCMDPR,FNC  GET COMMAND PROCESSOR. FNC SET BY UNCMND.
          STML   MAINA
          RJM    **          PROCESS COMMAND
 MAINA    EQU    *-1
          LDDL   RESPC       CHECK FOR ABNORMAL RESPONSE CODE
          SBN    R.ABN
          NJK    MAIN20      IF NO ERROR, LOOK FOR ANOTHER COMMAND

 MAIN35   RJM    TERMP       SEND TERMINATION RESPONSE

 MAIN40   BSS
          LDDL   IDLE
          NJK    MAIN10      IF IDLE COMMAND, ONLY PROCESS PP REQUESTS

          RJM    COLP        COLLECT P SAMPLES
          PAUSE  1000D       WAIT 1 MS BEFORE TRYING AGAIN
          UJK    MAIN10


* PP COMMAND PROCESSORS.

 UCMDPR   BSS
          CON    IDLEP       IDLE
          CON    RESUME      RESUME
          EJECT
** NAME-- SRESP
*
** PURPOSE-- SET UP STATUS RESPONSE BUFFER.
          SPACE  6
 SREX     LJM    **
 SRESP    EQU    *-1
          RJM    ZRESP         ZERO OUT RESPONSE BUFFER
          LDML   SS+/SS/P.PVA  PUT PVA OF REQUEST IN RESPONSE BUFFER
          STML   RS+/RS/P.PVA
          LDML   SS+/SS/P.PVA+1
          STML   RS+/RS/P.PVA+1
          LDML   SS+/SS/P.PVA+2
          STML   RS+/RS/P.PVA+2
*
          LDN    0
          STML   RS+/RS/P.XFER  CLEAR TRANSFER COUNT
          STML   RS+/RS/P.XFER+1
          UJK    SREX           RETURN
          EJECT
** NAME-- UNCMND
*
** PURPOSE-- GET NEXT COMMAND.
*
** INPUT-- NUMCM, FRST, RS+/RS/P.LASTC
*
** OUTPUT-- CMLIST, FNC, RQ+/RQ/P.CMND
*           LISTL.
*
** EXIT-- (A) = 0, IF NO MORE COMMANDS.
*         (A) .NE. 0, IF NEXT COMMAND PRESENT.
*         EXIT VIA ATERM IF COMMAND IS NOT IDLE OR RESUME
          SPACE  6
 UNCX     LJM    **
 UNCMND   EQU    *-1
          LDML   SS+/SS/P.NUMCM
          ZJN    UNCX        IF NO MORE COMMANDS, EXIT, A REGISTER = 0
          SOML   SS+/SS/P.NUMCM  DECREMENT COMMAND COUNT
          LDML   SS+/SS/P.FRST  HAS FIRST COMMAND BEEN PROCESSED
          ZJN    UNC10       IF FIRST COMMAND HASN'T BEEN PROCESSED

*         READ NEXT COMMAND FROM CM.

          AOML   SS+/SS/P.LASTC  INCREMENT OFFSET OF LAST COMMAND
          LDN    C.CM
          STDL   WC
          LOADF  SS+/SS/P.REQ  LOAD CM ADDRESS AND REFORMAT
          ADML   SS+/SS/P.LASTC  ADD OFFSET OF COMMAND
          CRML   CMD,WC       READ COMMAND FROM CM

*         IF INDIRECT ADDRESS, READ CM ADDRESS LIST.

 UNC10    BSS
          LDML   CMD+/CM/P.LEN  MAKE SURE IT IS AN EVEN NUMBER OF CM WORDS
          ADN    7
          SCN    7
          STML   CMD+/CM/P.LEN
          STML   CMLIST+/CM/P.LEN
          SHN    -3          CHANGE BYTE COUNT TO WORD COUNT
          STML   SS+/SS/P.LISTL  LENGTH OF CM ADDRESS AREA  (CM WORDS)
          LDML   CMD+/CM/P.INDIR
          SHN    /CM/L.INDIR+2
          MJN    UNC15       IF INDIRECT ADDRESS
          LDN    1
          STML   SS+/SS/P.LISTL  IF NOT INDIRECT, ONLY 1 COMMAND.
          LDML   CMD+/CM/P.RMA
          STML   CMLIST+/CM/P.RMA
          LDML   CMD+/CM/P.RMA+1
          STML   CMLIST+/CM/P.RMA+1
          UJN    UNC20

 UNC15    BSS
          RJM    GLIST       GET CM ADDRESS LIST OF DATA AREA

* IF SWITCH FLAG IS SET, EXIT.

 UNC20    BSS

*         SET UP INTERNAL FUNCTION CODE, FNC.

          LDN    0
          STDL   FNC         SET UP INTERNAL FUNCTION CODE
 UNC30    LDML   CMD+/CM/P.CODE  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          ERRNZ  /CM/L.CODE
          SBML   UCMD,FNC    COMPARE COMMAND CODE
          ZJN    UNC40       IF COMMAND FOUND
          AODL   FNC
          SBN    UCMDL
          MJN    UNC30       IF MORE COMMANDS TO CHECK
 UNC35    BSS
          LDC    E501        ERROR IN COMMAND CODE
          RJM    ATERM       ABNORMAL TERMINATION (NO RETURN)
*         (NO RETURN FROM ATERM)

 UNC40    BSS
          LDDL   FNC
          STML   SS+/SS/P.FNC  SAVE COMMAND CODE
          AOML   SS+/SS/P.FRST  SET FIRST COMMAND FLAG NONZERO
          UJK    UNCX        RETURN A REGISTER NONZERO

* PP COMMANDS.

 UCMD     BSS
          CON    C.IDLE
          CON    C.RESUME
 UCMDL    EQU    *-UCMD
          EJECT
** NAME -- COLP COLLECT P REGISTER VALUES
*
** PURPOSE COLLECT P REGISTER SAMPLES
*
** READS COMMUNICATION BUFFER FOR OPERATING STATUS
*  READS THE P VALUE AT THE APPROPRIATE TIME
*  UPDATE THE SPI DATA BUFFER IN CENTRAL MEMORY
*  GET NEXT BUFFER WHEN NEEDED.

 COLPX    LJM    **
 COLP     EQU    *-1
          LDM    CBT+/CB/P.PPSTAT GET PP SURRENT STATUS
          SBN    /CB/S.PTERM
          ZJN    COLPX       IF THE PP STATUS IS PP TERMINATED
          LOADC  CM.CB       LOAD R REGISTER WITH ADDRESS COMMUNICATION BUFFER
          ADN    /CB/C.CPBUF
          CRML   CBT+/CB/P.CPBUF,ON  GET CP OPERATION STATUS
          LDM    CBT+/CB/P.CPSTAT
          SBN    /CB/S.TERM
          MJN    COLP1       IF CP STATUS IS INITIALIZE START OR STOP

* PROCESS TERMINATION REQUEST

          LDN    /CB/S.PTERM SET PP STATUS TO TERMINATE
          STM    CBT+/CB/P.PPSTAT SET THE CURRENT PP STATUS
          LOADC  CM.CB       LOAD ADDRESS OF CM COMMUNICATION BUFFER
          ADN    /CB/C.PPBUF  ADD OFFSET FOR PP STATUS
          CWML   CBT+/CB/P.PPBUF,ON  UPDATE PP STATUS
          RJM    GNB         WRITE OUT CURRENT BUFFER
          UJN    COLP4       UPDATE PP STATUS

* DETERMINE START REQUEST

 COLP1    ADN    /CB/S.TERM-/CB/S.START
          MJN    COLP4       IF CP STATUS IS TABLE INITIALIZED
          NJN    COLP2       IF STATUS IS NOT START
          LDK    /CB/S.PCOL  SET PP STATUS TO COLLECTING
          UJN    COLP3

* PROCESS STOP REQUEST

 COLP2    LDK    /CB/S.PSTOP  SET THE STATUS TO STOP COLLECTING

* UPDATE PP STATUS WORD IN COMMUNICATION BUFFER

 COLP3    STM    CBT+/CB/P.PPSTAT SET THE CURRENT PP STATUS
          LOADC  CM.CB       LOAD ADDRESS OF CM COMMUNICATION BUFFER
          ADN    /CB/C.PPBUF  ADD OFFSET FOR PP STATUS
          CWML   CBT+/CB/P.PPBUF,ON  UPDATE PP STATUS
          LDM    CBT+/CB/P.PPSTAT
          SBN    /CB/S.PCOL  SUBTRACT COLLECTION STATUS
          ZJN    COLP5       IF PP STATUS IS COLLECTING P DATA
 COLP4    LJM    COLPX       EXIT COLP

* CHECK IF IT IS TIME TO COLLECT P SAMPLES

 COLP5    SODL   TM+1        DECREMENT TIMER COUNT
          PJN    COLP4       IF NOT TIME TO COLLECT P SAMPLE
          AOML   TM+1        RESET TO MAXIMUM INTEGER
          SODL   TM          DECREMENT TIMER COUNT
          PJN    COLP4       IF NOT TIME TO COLLECT P SAMPLE

* RESTORE TIMMER COUNT TO INITIAL VALUE FOR NEXT SAMPLE

          LDML   CBT+/CB/P.TIME
          STDL   TM
          LDML   CBT+/CB/P.TIME+1
          STDL   TM+1        RESET THE COUNT DOWN TIMER

*  READ AND PROCESS THE P REGISTER FOR PROCESSOR 0

          LDD    EC0         GET CONNECT CODE FOR PROCESSOR 0
          ZJK    COLP9       IF DONT COLLECT FOR PROCESSOR 0
          STD    EC          SAVE CONNECT CODE
          READMR RDATA       READ P REGISTER
          LDM    CBT+/CB/P.SPIID GET THE SPI IDENTIFIER
          ZJN    COLP6       IF PROCESS ANY SPI IDENTIFIER
          SBM    RDATA       SUBTRACT THE GLOBAL KEY OF THE P REGISTER
          NJK    COLP9
 COLP6    STM    RDATA+1     STORE PROCESSOR NUMBER IN LOCAL LOCKS
          RJM    PAC         PACK THE P REGISTER INTO 4 PP WORDS

* UPDATE THE CENTRAL MEMORY BUFFER

          LOADC  CM.CBUF     LOAD R REGISTER WITH CURRENT BUFFER ADDRESS
          ADM    CBT+/CB/P.PPOFF ADD IN THE WORD OFFSET COUNT TO CENTRAL MEMORY
          CWML   MRVAL,ON    WRITE P TO CENTRAL MEMORY
          SOML   CBT+/CB/P.SAMP+1
          PJN    COLP7       IF NOT END OF COLLECTION COUNT
          AOML   CBT+/CB/P.SAMP+1
          SOML   CBT+/CB/P.SAMP
          PJN    COLP7       IF NOT END OF COLLECTION COUNT
          LDN    /CB/S.PTERM
          STML   CBT+/CB/P.PPSTAT SET THE PP STATUS TO TERMINATE
          RJM    GNB         CLEAR OUT CURRENT BUFFER
          LJM    COLPX       FINISED PROCESSING

* CHECK BUFFER POSITION FOR END OF BUFFER

 COLP7    AOM    CBT+/CB/P.PPOFF INCREMENT OFFSET TO NEXT WORD
          SBM    MAXOFF      SUBTRACT OFF PAGE BOUNDRY
          NJN    COLP9       IF NOT END OF BUFFER
 COLP8    RJM    GNB         GET NEXT BUFFER

*  READ AND PROCESS THE P REGISTER FOR PROCESSOR 1

 COLP9    LDD    EC1         GET CONNECT CODE FOR PROCESSOR 1
          ZJK    COLP13      IF DONT COLLECT FOR PROCESSOR 1
          STD    EC          SAVE CONNECT CODE
          READMR RDATA       READ P REGISTER
          LDM    CBT+/CB/P.SPIID GET THE SPI IDENTIFIER
          ZJN    COLP10      IF PROCESS ANY SPI IDENTIFIER
          SBM    RDATA       SUBTRACT THE GLOBAL KEY OF THE P REGISTER
          NJK    COLP13
 COLP10   LDN    1
          STM    RDATA+1     STORE PROCESSOR NUMBER IN LOCAL LOCK
          RJM    PAC         PACK THE P REGISTER INTO 4 PP BYTES

* UPDATE THE CENTRAL MEMORY BUFFER

          LOADC  CM.CBUF     LOAD R REGISTER WITH CURRENT BUFFER ADDRESS
          ADM    CBT+/CB/P.PPOFF ADD IN THE WORD OFFSET COUNT TO CENTRAL MEMORY
          CWML   MRVAL,ON    WRITE P TO CENTRAL MEMORY
          SOML   CBT+/CB/P.SAMP+1
          PJN    COLP11      IF NOT END OF COLLECTION COUNT
          AOML   CBT+/CB/P.SAMP+1
          SOML   CBT+/CB/P.SAMP
          PJN    COLP11      IF NOT END OF COLLECTION COUNT
          LDN    /CB/S.PTERM
          STML   CBT+/CB/P.PPSTAT SET THE PP STATUS TO TERMINATE
          UJN    COLP12      GET NEXT BUFFER AND TERMINATE PROCESS

* CHECK BUFFER POSITION FOR END OF BUFFER

 COLP11   AOM    CBT+/CB/P.PPOFF INCREMENT OFFSET TO NEXT WORD
          SBM    MAXOFF      SUBTRACT OFF PAGE BOUNDRY
          NJN    COLP13      IF NOT END OF BUFFER
 COLP12   RJM    GNB         GET NEXT BUFFER
 COLP13   LJM    COLPX       EXIT
          EJECT
** NAME MRERR  MAINTENANCE REGISTER ERROR ROUTINE
*
* PURPOSE - ERROR RECOVERY FOR READMR OF P ADDRESS VALUE

 MRERR    SOM    COLPA       DECREMENT MAXIMUM ERROR COUNT
          PJN    COLP13      CONTINUE PROCESSING
          LDN    /CB/S.PTERM
          STML   CBT+/CB/P.PPSTAT SET THE PP STATUS TO TERMINATE
          UJN    COLP12

 COLPA    CON    100D        MAXIMUM NUMBER OF P REGISTER READ ERRORS

          EJECT
** NAME-- GNB GET NEXT BUFFER
*
** PURPOSE
*   1) UPDATE CURRENT BUFFER STATUS CONTROL
*   2) ISSUE INTERRUPT TO CENTRAL VIA UNSOLICITED RESPONSE
*   3) GET NEXT AVAILABLE BUFFER
*   4) UPDATE ADDRESS POINTERS
*
** EXIT  (BA) = POINTER TO RMA OF NEXT CENTRAL MEMORY BUFFER
*

 GNBX    LJM    **
 GNB     EQU    *-1
         LDM    CBT+/CB/P.PPBUF LOAD CURRENT BUFFER
         SBN    /CB/B.HIGH+1 SUBTRACT HIGHEST POSSIBLE BUFFER PLUS ONE
         PJK    GNB1         IF FIRST TIME INTO GET NEXT BUFFER
         LDK    /CB/S.DATA
         STM    BUFS+1       SET BUFFER STATUS TO HAVE DATA
         LDM    CBT+/CB/P.PPOFF
         STM    BUFS         SET BUFFER OFFSET TO CURRENT OFFSET

* UPDATE CURRENT BUFFER STATUS TO HAS DATA AND SEND UNSOLICITED MESSAGE

         LOADC  CM.CB        SET CENTRAL ADDRESS OF COMMUNICATIONS BUFFER
         ADK    /CB/C.BOFF1  ADD FIRST BUFFER OFFSET
         ADD    BN           ADD IN BUFFER NUMBER (0 .. 15)
         ADD    BN           ADD IN BUFFER NUMBER
         CWML   BUFS,ON      UPDATE BUFFER STATUS

* SET UP INTERRUPT INSTRUCTION BASED ON THE INTERRUPT PORT NUMBER

         LOAD   CBT,CB,IPORT GET THE INTERRUPT PORT MASK
         NJN    GNB0         IF INTERRUPT THEN ISSUE A INTERRUPT INSTUCTION
         LDC    2400B        2400 IS PASS INSTUCTION
         UJN    GNB00
 GNB0    ADC    102600B      ADD IN THE OPCODE FOR INTERRUPT INSTUCTION
 GNB00   STML   INTPRC       STORE INTERRUPT OR PASS INSTURCTION IN RESPIN
         RJM    SNMSG        SEND UNSOLICITED RESPONSE

*  POSITION TO NEXT BUFFER

         AOD    BN           INCREMENT TO NEXT BUFFER NUMBER
         SBN    /CB/B.HIGH
         MJN    GNB2         IF NOT PAST LAST BUFFER IN POOL

* PAST END POSITION FO FIRST BUFFER

 GNB1    LDC    CM.BF1       GET ADDRESS OF FIRST REFORMATTED ADDRESS
         STD    BA           SET POINTER TO FIRST REFORMATTED BUFFER ADDRESS
         LDN    0
         STD    BN           SET BUFFER NUMBER TO 0
         STM    CBT+/CB/P.PPBUF

*  GET UNFORMATTED RMA OF NEW BUFFER

 GNB2    LDIL   BA
         STML   CM.CBUF       UPDATE CM BUFFER ADDRESS
         AOD    BA
         LDIL   BA
         STML   CM.CBUF+1     UPDATE SECOND PART OF BUFFER ADDRESS
         AOD    BA
         LDIL   BA
         STML   CM.CBUF+2     UPDATE THIRD PART OF BUFFER ADDRESS
         AOD    BA            INCREMENT POINTER TO NEXT BUFFER ADDRESS

* WAIT FOR NEXT BUFFER TO BECOME AVAILABLE

 GNB3    LOADC  CM.CB         GET ADDRESS OF COMMUNICATIONS BUFFER
         ADK    /CB/C.BOFF1   ADD OFFSET TO FIRST BUFFER CONTROL
         ADD    BN
         ADD    BN            HAVE OFFSET TO CURRENT BUFFER CONTROL
         CRML   BUFS,ON       READ CURRENT BUFFER STATUS
         LDM    BUFS+1        GET CURRENT BUFFER STATUS
         SBN    /CB/S.AVAIL
         ZJN    GNB4          IF CURRENT BUFFER STATUS IS AVIALABLE
         PAUSE  1000          WAIT FOR BUFFER STATUS
         UJN    GNB3          TRY BUFFER STATUS AGAIN

* SET BUFFER STATUS TO IN USE BY PP

 GNB4    LDK    /CB/S.INUSE
         STM    BUFS+1        SET BUFFER STATUS TO IN USE BY PP
         LDN    0             SET OFFSET TO ZERO
         STM    CBT+/CB/P.PPOFF
         STM    BUFS
         LOADC  CM.CB         LOAD COMMUNICATION BUFFER ADDRESS
         ADK    /CB/C.BOFF1   ADD IN OFFSET TO FIRST BUFFER
         ADD    BN
         ADD    BN            NOW HAVE OFFSET OF CURRENT BUFFER CONTROL
         CWML   BUFS,ON       UPDATE BUFFER STATUS

* UPDATE PP STATUS TO INDICATE NEW BUFFER IN USE

         AOM    CBT+/CB/P.PPBUF UPDATE PP BUFFER STATUS IN COMMUNICATION BUFFER
         LOADC  CM.CB
         CWML   CBT+/CB/P.PPBUF,ON        UPDATE PP STATUS TO CENTRAL
         LJM    GNBX

         EJECT
** NAME-- GLIST
*
** PURPOSE-- READ THE CM ADDRESS LIST PORTION OF A COMMAND.
*
** INPUT-- LISTL
*
** OUTPUT-- CMLIST, CMD+/CM/P.RMA
          SPACE  6
 GLIX     LJM    **
 GLIST    EQU    *-1
          LDML   SS+/SS/P.LISTL  NO OF CM WORDS IN ADDRESS-LENGTH-PAIR LIST
          ZJN    GLIX        IF NO WORDS TO READ
          LOADF  CMD+/CM/P.RMA  LOAD CM ADDRESS AND REFORMAT
          CRML   CMLIST,ON
          LDN    8
          RAML   CMD+/CM/P.RMA+1  UPDATE RMA ADDRESS FOR NEXT READ
          SHN    -16
          RAML   CMD+/CM/P.RMA
          LDML   CMLIST+/CM/P.LEN  MAKE SURE IT IS AN EVEN NUMBER OF CM WORDS
          ADN    7
          SCN    7
          STML   CMLIST+/CM/P.LEN
          UJK    GLIX
          EJECT
** NAME-- ATERM
*
** PURPOSE-- ABNORMAL TERMINATION FOR INTERFACE ERRORS.
          SPACE  6
 ATERM    CON    0
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LDK    /RS/K.INTERR
          STDL   T1          SAVE ERROR ID
          LMC    -0
          STDL   T2
          LDML   RS+/RS/P.CHERR
          LPDL   T2
          ADDL   T1          ADD ERROR FLAG
          STML   RS+/RS/P.CHERR SAVE ERROR CODE
          LDK    C.RS*8
          STML   RS+/RS/P.RESPL RESPONSE LENGTH
          LDML   RS+/RS/P.PVA
          ADML   RS+/RS/P.PVA+1
          ADML   RS+/RS/P.PVA+2
          NJN    ATERM10        IF UNRECOVERED REQUEST
          RJM    SNMSG          SEND UNSOLICITED MESSAGE
          LJM    MAIN35

 ATERM10  BSS
          LDN    R.ABN          ABNORMAL TERMINATION
          STDL   RESPC          RESPONSE CODE
          LJM    MAIN35
          EJECT
** NAME-- TERMP
*
** PURPOSE-- TERMINATE PP REQUEST.
*
** OUTPUT-- RS+/RS/P.RC = RESPONSE CODE
          SPACE  6
 TERX     LJM    **
 TERMP    EQU    *-1
          RJM    PUTRC       PUT RESPONSE CODES IN RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
          LDN    0
          STDL   PPRQ        ZERO OUT PP REQUEST FLAG
          RJM    ZRESP       ZERO OUT RESPONSE BUFFER
          UJK    TERX
          EJECT
** NAME-- PUTRC
*
** PURPOSE-- PUT RESPONSE CODES IN RESPONSE
          SPACE  6
 PUTRCX   LJM    **
 PUTRC    EQU    *-1
          LDDL   RESPC       RESPONSE CODE
          SHN    /RS/L.RCON-/RS/L.RC+/RS/N.RCON-/RS/N.RC
          ADML   RCON        RESPONSE CONDITION
          SHN    /RS/L.URC-/RS/L.RCON+/RS/N.URC-/RS/N.RCON
          ERRNZ  /RS/P.URC-/RS/P.RCON
          ERRNZ  /RS/P.RC-/RS/P.URC
          STML   RS+/RS/P.URC
          UJK    PUTRCX
          EJECT
** NAME-- RESP
*
** PURPOSE-- WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
*
** INPUT-- CM.PIT, CM.RS, LIM, /PIT/IN, /PIT/OUT, RS+/RS/P.RESPL
*
** OUTPUT-- /PIT/IN, RESPONSE BUFFER
          SPACE  6
          SPACE  6
 RESPX    LJM    **
 RESP     EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDN    0
          STML   STORS       SET FLAG TO STORE RESPONSE
          LDML   CMD+/CM/P.STOR  CHECK IF CALLER WANTS RESPONSE
          SHN    /CM/L.STOR+2
          MJN    RESP10      IF STORE RESPONSE FLAG IS SET
          LDDL   RESPC       CHECK FOR NORMAL RESPONSE
          SBN    R.NRM
          NJN    RESP10      IF NOT NORMAL RESPONSE, STORE RESPONSE
          AOML   STORS       NONZERO MEANS DO NOT STORE RESPONSE
 RESP5    UJK    RESPX

* READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RESP10   BSS
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF 'IN' POINTER
          CRDL   P1          READ 'IN' POINTER

* CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDN    0
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE
          LDDL   P4
          SBDL   P5
          MJN    RESP20      IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   P5
 RESP20   LDML   RS+/RS/P.RESPL  GET RESPONSE LENGTH
          ZJK    RESP5       IF RESPONSE LENGTH = 0
          ADDL   P4
          STDL   INPNT       IN + RESPONSE LENGTH
          SBDL   P5          CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          PJK    RESP10      IF NOT ENOUGH ROOM IN BUFFER, LOOP
          LDDL   P4
          SHN    -3
          STDL   T3          'IN' POINTER IN WORDS
          LDML   RS+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          LDDL   INPNT
          SBDL   LIM
          MJN    RESP50      IF IN + RESPONSE LENGTH .LT. LIMIT
                             ONLY 1 BLOCK WRITE
          STDL   INPNT       IN + RESPONSE LENGTH - LIMIT = NEW 'IN' POINTER
          SHN    -3
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE

* WRITE RESPONSE TO CM.

          LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   P4
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADC    RS
          STML   RESPA       RESPONSE ADDRESS FOR 2ND BLOCK WRITE
 RESP50   BSS
          LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD 'IN' OFFSET
          CWML   RS,T4       WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          ZJN    RESP70      IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          LMC    400000B
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
                             (BEGINNING OF RESPONSE BUFFER)
 RESPA    EQU    *-1

 RESP70   BSS
          LJM    RESPX
          EJECT
** NAME-- RESPIN
*
** PURPOSE-- UPDATE THE 'IN' POINTER IN THE CM RESPONSE BUFFER.
*
** INPUT-- INPNT = NEW 'IN' POINTER.
          SPACE  6
 RESNX    LJM    **
 RESPIN   EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDML   STORS       CHECK IF CALLER WANTS RESPONSE
          NJK    RESNX       IF NO RESPONSE WAS SENT

* UPDATE THE 'IN' POINTER.

          LDN    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDDL   INPNT       NEW 'IN' POINTER
          STDL   P4
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   P1          WRITE NEW 'IN' POINTER TO CM

* INTERRUPT PROCESSOR. RESP ROUTINE SETS UP THIS INSTRUCTION.

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   PPNO-3      SET LAST BYTE NONZERO
          LDN    0           CLEAR A-REGISTER FOR S0 HARDWARE PROBLEM
 INTPRC   INPN   1           THIS INSTRUCTION IS MODIFIED BY GNB
          CRDL   T1          THIS INSTRUCTION IS BECAUSE OF AN 810/830 PROBLEM
          UJK    RESNX
          EJECT
** NAME SNMSG - SEND UNSOLICITED MESSAGE.
*
** PURPOSE-- SEND AN UNSOLICITED MEAAGE TO THE CENTRAL PROCESSOR
          SPACE  6
 SNMSGX   LJM    **
 SNMSG    EQU    *-1
          LDK    C.RS*8      SET RESPONSE LENGTH FOR ERROR
          STML   RS+/RS/P.RESPL
          LDN    0           UNSOLICITED MESSAGE
          STDL   RESPC       RESPONSE CODE
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          RJM    TERMP       SEND RESPONSE TO CM
          UJK    SNMSGX
          EJECT
** NAME-- ZRESP
*
** PURPOSE-- ZERO OUT PART OF THE RESPONSE BUFFER.
*
** NOTE-- THIS ROUTINE IS ALSO CALLED FOR RECOVERED ERROR RESPONSES.
          SPACE  6
 ZREX     LJM    **
 ZRESP    EQU    *-1
          LDN    0
          STML   RCON        RESPONSE CONDITION
          STDL   NODEL       DON'T DELINK REQUEST FLAG
          STML   RS+/RS/P.HDWR  ABNORMAL STATUS
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE

          LDK    P.RS-/RS/P.FTRK
          STDL   T1
 ZER10    LDN    0
          STML   RS+/RS/P.FTRK-1,T1 ZERO OUOT PART OF RESPONSE BUFFER
          SODL   T1
          NJN    ZER10
          LDK    /RS/C.LASTC*8+8  SET RESPONSE LENGTH FOR NORMAL RESPONSE
          STML   RS+/RS/P.RESPL
          LDN    R.NRM       SET RESPONSE CODE = NORMAL
          STDL   RESPC
          SHN    16-/RS/N.RC-/RS/L.RC
          STML   RS+/RS/P.RC  PUT REPONSE CODE IN RESPONSE
          UJK    ZREX
          EJECT
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
*
** EXIT-- (A) = 0, IF LOCK WAS SUCCESSFULLY SET.
*         (A) .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SCL40    LDN    0           SET LOCK SUCCESSFUL
 SCLX     LJM    **
 SCLOCK   EQU    *-1
          LDDL   CHLOCK
          NJN    SCL40       IF CHANNEL LOCK IS NOT SET

 SCL10    BSS
          LDK    C.CHCNT
          STML   CHLCNT      NUMBER OF REQUESTS TO PROCESS BEFORE
                             GIVING UP CHANNEL
          LDN    6           SET TIMEOUT DELAY TO 5 SECONDS ON S1
          STDL   P1
          STDL   P2
 SCL20    BSS
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCKW       SET LOCKWORD
          NJN    SCL30       IF LOCK WAS NOT SET
          AODL   CHLOCK      SET FLAG IF LOCK WAS SET
          UJK    SCL40       EXIT, LOCK WAS SET

 SCL30    BSS
          SODL   P1
          NJK    SCL20
          SODL   P2
          NJK    SCL20
          LDN    1           TIMEOUT ON TRYING TO GET CHANNEL LOCK
          UJK    SCLX        EXIT A REGISTER NONZERO
          EJECT
** NAME-- SPLOCK
*
** PURPOSE-- SETS THE PP REQUEST QUEUE LOCK IN THE
*            PP INTERFACE TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  6
 SPLX     LJM    **
 SPLOCK   EQU    *-1
          LDC    7777B
          STDL   SSUN        INVALIDATE SS TABLE
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    LOCKW       SET THE LOCKWORD
          NJK    SPLX        IF LOCK COULD NOT BE SET
          RJM    SCLOCK      SET CHANNEL LOCK
          UJK    SPLX
          EJECT
** NAME-- LOCKW SET CENTRAL LOCK WORD
*
** PURPOSE-- TO SET CENTRAL LOCK WORD

 LOCKX    LJM    **
 LOCKW    EQU    *-1

* SET LOCK BIT.

          LDC    100000B     SET UNIT LOCK BIT
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          SET LOCK BIT IN UNIT LOCKWORD

* CHECK IF LOCK WAS OBTAINED.

          LDDL   T1
          ADDL   T4
          ZJN    LOCK20      IF LOCK COULD BE SET
          LDDL   T4
          SBDL   PPNO        CHECK IF LOCK ALREADY SET
          NJN    LOCK10      IF LOCK COULD NOT BE SET, EXIT A .NE. 0
          LDDL   T1
          ADC    -100000B
 LOCK10   UJK    LOCKX       EXIT WITH LOCK VALUE

* SET PP NUMBER IN LOCKWORD.

 LOCK20   BSS
          LDDL   PPNO
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    RR
          RDSL   T1          SET PP NUMBER IN LOCKWORD

* CHECK IF LOCK WAS CORRECT BEFORE LAST RDSL OPERATION.

          LDDL   T1
          ADC    -100000B
          NJN    LOCK40
          LDDL   T4
          ZJK    LOCK10      IF NO ERROR, EXIT

 LOCK30   UJN    *           ERROR IN LOCKWORD

* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

 LOCK40   BSS
          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          NJN    LOCK30
          AODL   LFF00
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          UJK    LOCK20
          EJECT
** NAME-- CCLOCK
*
** PURPOSE-- CLEARS CHANNEL LOCK.
*
          SPACE  6
 CCLX     LJM    **
 CCLOCK   EQU    *-1
          LDDL   CHLOCK
          ZJK    CCLX        IF CHANNEL LOCK WAS NOT SET
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   T7
          LDDL   CHAN        CHANNEL NUMBER = OFFSET IN TABLE
          STDL   T5
          RJM    CLOCK       CLEAR CHANNEL LOCKWORD
          LDN    0
          STDL   CHLOCK      CLEAR CHANNEL LOCK FLAG
          UJK    CCLX
          EJECT
** NAME-- CPLOCK
*
** PURPOSE-- CLEARS THE PP QUEUE LOCK IN THE PP INTERFACE TABLE.
*
          SPACE  6
 CPLX     LJM    **
 CPLOCK   EQU    *-1
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T7
          LDN    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWROD
          UJK    CPLX
          EJECT
** NAME - CLOCK
*
** PURPOSE - CLEAR A CENTRAL LOCK
*
** EXIT CONDITIONS - (A) = 0 IF LOCK IS CLEARED
*                    (A) .NE. 0 IF LOCK NOT CLEARED

 CLKX     LJM    **
 CLOCK    EQU    *-1

* MAKE SURE THIS PP IS THE ONE WHO HAS THE LOCK SET.

 CLK10    BSS
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          CRDL   T1          READ UNIT LOCK
          LDDL   T4          CHECK PP NUMBER
          SBDL   PPNO
          ZJN    CLK30       IF THIS PP HAS THE LOCK SET

* CHECK IF LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          NJN    CLK20       ERROR, THIS PP DOES NOT HAVE THE UNIT RESERVED
          AODL   LFF00
          UJK    CLK10

 CLK20    BSS
          UJK    CLKX        EXIT, A REGISTER = 0, IF LOCK WAS CLEARED
                             EXIT, A REGISTER .NE. 0, IF LOCK COULD NOT
                               BE CLEARED

* CLEAR UNIT LOCKWORD IN UNIT INTERFACE TABLE.

 CLK30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK
          LMC    RR
          RDCL   T1          CLEAR LOCK

* CHECK IF LOCK WAS CORRECT BEFORE THE CLEAR OPERATION.

          LDDL   T1
          ADC    -100000B
          NJN    CLK50
          LDDL   PPNO
          SBDL   T4
          ZJK    CLK20       IF LOCK WAS OK
 CLK40    BSS
          UJN    *           LOCK WAS MESSED UP

* CHECK IF LOCKWORD = FFFF FFFF XXXX XXXX(16).

 CLK50    BSS
          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          NJK    CLK40
          AODL   LFF00
          UJK    CLK30
          EJECT
** NAME-- FORMA
*
** PURPOSE-- FORMAT A CM REAL MEMORY ADDRESS.
*
** CALLING SEQUENCE-- LDC    ADDRESS
*                     RJM    FORMA
*
** INPUT-- - A REGISTER- IS THE ADDRESS OF A 2-WORD CM BYTE ADDRESS.
*
** OUTPUT-- -CMADR- IS THE ADDRESS OF THE RESULTING 3-WORD REFORMATED
*                CM ADDRESS.  THE FORMAT CAN BE USED BY THE LOADC MACRO.
*           -ADDRESS-, WORD 0, BITS 0-13 AND
*                      WORD 1, BITS 3-15, ARE REFORMATTED TO-
*           -CMADR-,   WORD 0, BITS 0-9,
*                      WORD 1, BITS 0-11,
*                      WORD 2, BITS 0-5.
*
          SPACE  6
 FORX     LJM    **
 FORMA    EQU    *-1
          STDL   T1
          LDML   1,T1
          LPN    7
          NJN    *           RMA ADDRESS ERROR, PERMANENT HALT
          LDIL   T1
          LPN    37B
          SHN    16
          LMML   1,T1
          SHN    9
          STD    CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   T1
          SHN    -5
          STD    CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMC    RR
          UJK    FORX
          EJECT
** NAME-- PAUS
*
** PURPOSE-- DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*            MICROSECONDS.
*
** INPUT-- A REGISTER (BITS 00-06) SPECIFIES NUMBER OF MICROSECONDS
*          TO BE DELAYED.
*
** NOTE-- THIS CODE IS MODIFIED BY THE INITIALIZATION ROUTINE.
*         THE INSTRUCTION ARE DEPENDANT ON THE TYPE OF MAINFRAME
*         THE CODE IS EXECUTED ON.
*
** CODE SEQUENCE FOR THE DIFFERENT MACHINES.
*         FOR THE S0
*         ENTRY
*         WAIT    (101700)
*         PASS
*         EXIT
*
*         FOR THE S1
*         ENTRY
* LOOP    SUBTRACT 1
*         GO TO LOOP IF NOT ZERO
*         EXIT
*
*         FOR OTHER MACHINES
*         ENTRY
* LOOP    SUBTRACT 1
*         PASS
*         PASS
*         GO TO LOOP IF NOT ZERO
*         EXIT
*

          SPACE  6
 PAUSX    LJM    **
 PAUS     EQU    *-1
*         THE FOLLOWING INSTRUCTION BECOMES A WAIT ON AN S0.
*         A WAIT IS AN 101700 INSTRUCTION
 PAUS10   SBN    1           EACH ITERATION OF THIS SBN-(PASS-PASS)-NJN LOOP
*         THE FOLLOWING INSTRUCTION BECOMES A PASS ON ANY NON S1 MACHINES.
 PAUS20   NJN    PAUS10      UTILIZES 1 MICROSECOND
*         THE FOLLOWING INSTRUCTION BECOMES A PASS ON ANY I2 OR I4 MACHINES
 PAUS30   UJK    PAUSX       EXIT FOR S0 AND S1 MACHINES
          NJN    PAUS10      UTILIZES 1 MICROSECOND ON AN I2 OR I4
          UJK    PAUSX       EXIT FOR S2, S3, AND THETA MACHINES
          EJECT
*copyc dsa$hardware_table_definitions
*copyc dsi$find_cip_module
*copyc dsi$get_hardware_element
*copyc dsi$maintenance_register_access
*copyc dsi$pack_unpack_registers
*copyc dsi$pp_utility_subroutines
          EJECT
** NAME-- PPREQ
*
** PURPOSE-- CHECK FOR ANY PP REQUESTS ON THE PP QUEUE.
*
** EXIT-- (A) = 0, IF NO PP REQUESTS.
*         (A) .NE. 0, IF A PP REQUEST WAS FOUND
          SPACE  6
 PPRQX    LJM    **
 PPREQ    EQU    *-1
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.PPQ  CM ADDRESS OF PP REQUEST QUEUE POINTER
          CRDL   P1          READ PP QUEUE POINTER
          LDDL   P3          RMA OF NEXT QUEUED PP REQUEST
          ADDL   P4
          ZJN    PPRQX       IF NO PP REQUESTS

* SET PP QUEUE LOCKWORD.

          RJM    SPLOCK      SET PP QUEUE LOCKWORD
          ZJN    PPRQ20      IF LOCK WAS SET

 PPRQ15   BSS
          LDN    0
          UJK    PPRQX       EXIT, A REGISTER = 0

* GET THE RMA OF THE FIRST PP REQUEST IN THE CHAIN.

 PPRQ20   BSS
          LDN    2
          STDL   WC
          LOADC  CM.PIT
          ADN    /PIT/C.PPQPVA
          CRML   T1,WC       READ PVA AND RMA OF FIRST REQUEST IN CHAIN

* PUT PVA AND RMA OF REQUEST IN SS TABLE.

          LDDL   T2          PUT PVA OF REQUEST IN SS TABLE
          STML   SS+/SS/P.PVA
          LDDL   T3
          STML   SS+/SS/P.PVA+1
          LDDL   T4
          STML   SS+/SS/P.PVA+2
          LDDL   T7          PUT RMA OF REQUEST IN SS TABLE
          STML   SS+/SS/P.REQ
          LDDL   T8
          STML   SS+/SS/P.REQ+1
          LDN    0
          STML   SS+/SS/P.FRST  SET FLAG WHEN REQUEST IS READ

* READ THE PP REQUEST.

          LDN    C.RQ
          STDL   P1
          LOADF  T7          CM ADDRESS OF FIRST PP REQUEST
          CRML   RQ,P1       READ PP REQUEST

* DELINK THE FIRST PP REQUEST FROM THE CHAIN.

 PPRQ30   BSS
          LOADC  CM.PIT
          ADN    /PIT/C.PPQPVA  CM ADDRESS OF PP QUEUE POINTER
          CWML   RQ,WC       WRITE PVA AND RMA POINTERS OF NEXT REQUEST
          RJM    CPLOCK      CLEAR PP QUEUE LOCKWORD
          LDML   RQ+/RQ/P.LEN  DETERMINE NUMBER OF COMMANDS
          SHN    -3
          SBN    /RQ/C.CMND
          STML   SS+/SS/P.NUMCM  NUMBER OF COMMANDS

          AODL   PPRQ        SET PP REQUEST FLAG
          UJK    PPRQX       EXIT, A REGISTER NONZERO
          EJECT
** NAME-- IDLEP
*
** PURPOSE-- PROCESS IDLE COMMAND.
          SPACE  6
 IDLX     LJM    **
 IDLEP    EQU    *-1
          AODL   IDLE        SET IDLE FLAG
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          UJK    IDLX
          EJECT
** NAME-- RESUME
*
** PURPOSE-- PROCESS RESUME COMMAND.
          SPACE  6
 RESX     LJM    **
 RESUME   EQU    *-1
          LDN    0
          STDL   IDLE        CLEAR IDLE FLAG
          UJK    RESX



 IPIT     EQU    *           PP INTERFACE TABLE
 CBT      EQU    IPIT+P.PIT
          ORG    CBT+P.CB
 STORS    BSSZ   1           STORE RESPONSE FLAG (USED BY RESPIN)
                               = 0, IF A RESPONSE IS SENT TO CM
                               = NONZERO, IF NO RESPONSE WAS SENT TO CM
 RCON     BSSZ   1           ADDITIONAL RESPONSE CONDITION
 CHLCNT   BSSZ   1           NUMBER OF REQUESTS TO PROCESS BEFORE
                             CLEARING CHANNEL LOCK
 SS       BSSZ   P.SS        INFORMATION SAVED IN UNIT COMMUNICATION BUFFER
 RQ       EQU    SS+/SS/P.RQ  REQUEST
 CMD      EQU    RQ+/RQ/P.CMND  CURRENT COMMAND
 CMLIST   EQU    SS+/SS/P.CMLIST  INDIRECT RMA LIST
 RS       EQU    SS+/SS/P.RS  RESPONSE BUFFER
          BSSZ   3           MUST FOLLOW RS, FOR ZEROING OUT RS

          EJECT
** NAME-- INIT
*
** PURPOSE-- INITIALIZE THE DRIVER AFTER DEADSTART.
*
** INPUT-- DSRTP = CM BYTE-ADDRESS OF THE PP INTERFACE TABLE.
          SPACE  6
 INIT     BSS
          RJM    PIB         PREPARE INTERFACE BLOCK
          RJM    PHT         PREPARE HARDWARE TABLES
          LDN    PROCID
          RJM    FHE         FIND PROCESSOR IN MRT
          MJN    *           HANG HERE, CANT FIND PROCESSOR CODE
          LDM    HBUF+CPRPC
          STD    EC0         SAVE EQUIPMENT CONNECT CODE
          LDM    HBUF+CPRE+EM
          SHN    -8
          STD    MD          SAVE MAINFRAME MODEL NUMBER
          SBN    5
          ZJN    INIT10      IF MODEL IS S0 THEN
          LDC    PPRG
          UJN    INIT11      PROCESS NON S0 MODEL NUMBER
 INIT10   LDC    S0PPRG
 INIT11   STD    RN          SAVE P REGISTER NUMBER
          LDC    PROCID1
          RJM    FHE         FIND HARDWARE ELEMENT FOR PROCESSOR 1
          MJN    INIT15      PROCESSOR 1 DOES NOT EXIST
          LDM    HBUF+CPRPC
          STD    EC1         SAVE CONNECT CODE FOR PROCESSOR 1

 INIT15   REFAD  DSRTP,CM.PIT   REFORMAT ADDRESS OF PP INTERFACE TABLE
                               AND SAVE.


* REFORMAT ADDRESS OF COMMUNICATION BUFFER.
* INITIALIZE CM.CB.

          LOADC  CM.PIT      ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.CBUF  OFFSET OF PP COMMUNICATION BUFFER ADDRESS
          CRDL   P1          READ ADDRESS OF PP COMMUNICATION BUFFER
          REFAD  P3,CM.CB    REFORMAT CM ADDRESS OF PP COMMUNICATION BUFFER

* READ COMMUNICATION BUFFER AND PROCESS WHEN BUFFER IS INITIALIZED.

 INIT20   LDN    C.CB
          STD    WC          SAVE WORD COUNT FOR COMMUNICATION BUFFER
          LOADC  CM.CB       ADDRESS OF COMMUNICATION BUFFER
          CRML   CBT,WC      READ COMMUNICATION BUFFER
          LDML   CBT+/CB/P.CPSTAT GET CP STATUS OF COMMUNICATION BUFFER
          SBN    /CB/S.INIT
          ZJN    INIT30      IF COMMUNICATION BUFFER INITIALIZED
          PAUSE  1000
          UJN    INIT20

* NOTE, DO NOT USE BUFFERS BEFORE THIS POINT, UNLESS THE PP IS
* HALTED AFTERWARD.

 INIT30   LDK    P.RS        ZERO OUT FULL RESPONSE BUFFER
          STDL   T1
 INIT98   BSS
          LDN    0
          STML   RS-1,T1     ZERO OUT RESPONSE BUFFER
          SODL   T1
          NJN    INIT98

          RJM    ZRESP       ZERO OUT RESPONSE BUFFER

* READ PP_INTERFACE_TABLE.

          LDN    C.PIT
          STDL   WC
          LOADC  CM.PIT      LOAD CM ADDRESS OF PP INTERFACE TABLE
          CRML   IPIT,WC     READ PP INTERFACE TABLE
          LDML   IPIT+/PIT/P.PPNO  GET PP NUMBER
          STDL   PPNO

* REFORMAT ADDRESS OF RESPONSE BUFFER.
* INITIALIZE CM.RS, LIM.

 INIT80   BSS
          REFAD  IPIT+/PIT/P.RSBUF,CM.RS  REFORMAT CM ADDRESS OF RESPONSE
                             BUFFER
          LDML   IPIT+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STDL   LIM

* REFORMAT ADDRESS OF INTERRUPT WORD.

          REFAD  IPIT+/PIT/P.INT,CM.INT  REFORMAT CM ADDRESS OF
                             INTERRUPT WORD

* REFORMAT ADDRESS OF CHANNEL TABLE.

          REFAD  IPIT+/PIT/P.CHAN,CM.CHAN  REFORMAT CM ADDRESS OF
                             CHANNEL TABLE

* REFORMAT ADDRESS OF CM BUFFERS
* INITIALIZE CM.BF1 TO CM.BF16

          REFAD  CBT+/CB/P.BRMA1,CM.BF1
          REFAD  CBT+/CB/P.BRMA2,CM.BF2
          REFAD  CBT+/CB/P.BRMA3,CM.BF3
          REFAD  CBT+/CB/P.BRMA4,CM.BF4
          REFAD  CBT+/CB/P.BRMA5,CM.BF5
          REFAD  CBT+/CB/P.BRMA6,CM.BF6
          REFAD  CBT+/CB/P.BRMA7,CM.BF7
          REFAD  CBT+/CB/P.BRMA8,CM.BF8
          REFAD  CBT+/CB/P.BRMA9,CM.BF9
          REFAD  CBT+/CB/P.BRMA10,CM.BF10
          REFAD  CBT+/CB/P.BRMA11,CM.BF11
          REFAD  CBT+/CB/P.BRMA12,CM.BF12
          REFAD  CBT+/CB/P.BRMA13,CM.BF13
          REFAD  CBT+/CB/P.BRMA14,CM.BF14
          REFAD  CBT+/CB/P.BRMA15,CM.BF15
          REFAD  CBT+/CB/P.BRMA16,CM.BF16

* ZERO OUT CONNECT CODES FOR PROCESSORS NOT SELECTED

          LOAD   CBT,CB,P0   LOAD PROCESSOR ZERO SELECT FLAG
          NJN    INIT83      IF PROCESSOR IS SELECTED
          STD    EC0         DESELECT PROCESSOR ZERO
 INIT83   LOAD   CBT,CB,P1   LOAD PROCESSOR ONE SELECT FLAG
          NJN    INIT85      IF PROCESSOR IS SELECTED
          STD    EC1         DESELECT PROCESSOR ONE

* STORE THE NAME SPI IN WORDS 100 AND 101

 INIT85   LDC    2R_SP
          STML   START
          LDC    2R_I
          STML   START+1

* COPY OVER THE INITIAL TIMMER VALUE AND SET UP THE SPI IDENTIFIER
* FOR THE PROPER MAINFRAME.

          LDML   CBT+/CB/P.TIME
          STDL   TM
          LDML   CBT+/CB/P.TIME+1
          STDL   TM+1
          LDD    MD          GET THE MACHINE IDENTIFIER
          SBN    5           SUBTRACT THE S0 IDENTIFIER
          NJN    INIT90      IF NOT S0 TYPE MAINFRAME
          STML   CBT+/CB/P.SPIID ON S0 ONLY USE SPI ID OF ZERO

*  INITIALIZE PP STATUS OF COMMUNICATION BUFFER

 INIT90   LDN    /CB/B.HIGH+1 SET THE PP BUFFER NUMBER FOR START OF PROGRAM
          STM    CBT+/CB/P.PPBUF
          LDN    /CB/S.PWAIT SET THE STATUS TO IN USE
          STM    CBT+/CB/P.PPSTAT
          LDN    0           SET THE BUFFER OFFSET TO START OF BUFFER
          STM    CBT+/CB/P.PPOFF
          RJM    GNB         GET THE FIRST BUFFER

* SET ERROR ADDRESS PROCESSING FOR READMR ROUTINE

          EXITMR MRERR       SET ERROR EXIT ADDRESS

* THIS PART OF THE CODE INITIALIZES THE PAUSE DELAY LOOP FOR THE
* MACHINE THE CODE IS EXECUTED ON. THE INSTRUCTION MODIFICATION IS
* BASED ON THE MACHINE MODEL NUMBER OBTAINED ABOVE.

          LDD    MD          GET THE MACHINE MODEL NUMBER
          SBN    1
          ZJK    INIT94      IF THE SYSTEM IS ANY TYPE OF S1
          SBN    5-1
          ZJK    INIT92      IF THE SYSTEM IS AN S0

* SET UP PAUSE INSTRUCTIONS FOR I2 AND I4

          LDN    0           OP CODE FOR PASS INSTRUCTION
          STM    PAUS20      REPLACE NON ZERO JUMP WITH PASS INSTRUCTION
          STM    PAUS30      REPLACE EXIT JUMP WITH PASS INSTUCTION
          UJK    INIT94

* SET UP PAUSE INSTUCTIONS FOR S0

 INIT92   STM    PAUS20      REPLACE NON ZERO JUMP WITH PASS INSTRUCTION
          LDC    101700B     LOAD OP CODE FOR HOLD INSTRUCTION
          STML   PAUS10      REPLACE SUBTRACT WITH HOLD INSTRUCTION
 INIT94   LJM    SPI
          EJECT
 SAVAX    LJM    **
 SAVAD    EQU    *-1
          STML   2,T2
          LDDL   CMADR
          STI    T2
          LDDL   CMADR+1
          STML   1,T2
          UJK    SAVAX
 CONCH2   BSS
 TDC+40B  HERE
 T40B+DC  HERE
 TDC      HERE
          CON    0
          END    SPI
/EOR
*DECK DECK=OSM$SPI_SUPPORT EXPAND=TRUE
MODULE osm$spi_support;

?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc amt$local_file_name
*copyc jmv$jcb
*copyc ofp$display_status_message
*copyc osp$establish_condition_handler
*copyc osp$disestablish_cond_handler
*copyc osp$fetch_spi_lock
*copyc osp$release_spi_r1_support
*copyc osp$reserve_spi_r1_support
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc osp$start_spi_collection_r1
*copyc osp$stop_spi_collection_r1
*copyc oss$task_private
*copyc ost$caller_identifier
*copyc ost$keypoint_control
*copyc ost$execution_control_block
*copyc ost$processor_id_set
*copyc ost$spi_types
*copyc ost$wait
*copyc osv$page_size
*copyc osv$spi_control
*copyc osv$task_private_heap
*copyc pmp$continue_to_cause
*copyc pmp$disestab_end_hndlr_in_ring
*copyc pmp$establish_end_hndlr_in_ring
*copyc pmp$execute_with_less_privilege
*copyc pmp$get_compact_date_time
*copyc pmp$get_cpu_attributes
*copyc pmp$log
*copyc pmp$log_ascii
*copyc pmp$long_term_wait
*copyc pmp$terminate

?? POP ??

  VAR
    osv$spi_task_data_p: [oss$task_private] ^ost$spi_task_data;

  TYPE
    ost$spi_task_data = record
      task_id: pmt$task_id,
      task_status: pmt$task_status,
    recend;


?? TITLE := 'PROCEDURE [XDCL, #GATE] osp$reserve_spi_environment', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$reserve_spi_environment
    (    spi_identifier: ost$spi_identifier;
         collection_file: amt$local_file_name;
         number_of_spi_samples: ost$number_of_spi_samples;
         spi_sampling_interval: ost$spi_sampling_interval;
         wait: ost$wait;
         processor_id_set: ost$processor_id_set;
         data_string: string (32);
     VAR status: ost$status);

*copyc osh$reserve_spi_environment

    PROCEDURE handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           stack_frame_save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      handler_status.normal := TRUE;
      IF condition.selector = ifc$interactive_condition THEN
        IF condition.interactive_condition = ifc$terminate_break THEN
          osp$set_status_from_condition ('OS', condition, stack_frame_save,
                status, handler_status);
          EXIT osp$reserve_spi_environment;
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
      handler_status.normal := TRUE;
    PROCEND handler;

?? EJECT ??

    VAR
      available_processor_set: ost$processor_id_set,
      caller_id: ost$caller_identifier,
      cpu_attributes: pmt$cpu_attributes,
      lstatus: ost$status,
      new_processor_id_set: ost$processor_id_set,
      parameter: cell,
      parameter_list: ^pmt$program_parameters,
      processor: ost$processor_id,
      program_attributes: ^pmt$program_attributes,
      program_description: ^pmt$program_description;

    status.normal := TRUE;
    #CALLER_ID (caller_id);
    osp$establish_condition_handler (^handler, FALSE);

{  A check is made on the state of the CPU's configured on the system.
{  A set is constructed to contain only those CPU's that are configured
{  and ON.  A new processor_id_set is then constructed to be the intersection
{  of the CPU's chosen by the user and the CPU's that are configured and ON.
{  This will prevent SPI from trying to sample a CPU that is not active.

   pmp$get_cpu_attributes(cpu_attributes, status);
   IF NOT status.normal THEN
     RETURN;
   IFEND;

   FOR processor:= 0 TO cpu_attributes.highest_defined_cpu_number DO
     IF cpu_attributes.cpu[processor].state = pmc$processor_state_on THEN
       available_processor_set := available_processor_set + $ost$processor_id_set[processor];
     IFEND;
   FOREND;

   new_processor_id_set := processor_id_set * available_processor_set;

    REPEAT
      osp$reserve_spi_r1_support (spi_identifier, collection_file,
            number_of_spi_samples, spi_sampling_interval, new_processor_id_set,
            data_string, status);

      IF NOT status.normal THEN
        IF status.condition = ose$spi_environment_not_avail THEN
          IF wait = osc$wait THEN
            ofp$display_status_message ('waiting for SPI environment',
                  lstatus);
            pmp$long_term_wait (30000, 30000);
          ELSE
            RETURN;
          IFEND;
        ELSEIF status.condition = ose$job_has_spi_environment THEN
          RETURN;
        ELSE
          RETURN;
        IFEND;
      IFEND;
    UNTIL status.normal;

    ALLOCATE osv$spi_task_data_p IN osv$task_private_heap^;
    PUSH program_description: [[REP #SIZE (pmt$program_attributes) OF cell]];
    RESET program_description;
    NEXT program_attributes IN program_description;
    program_attributes^.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified];
    program_attributes^.starting_procedure := 'OSP$SPI_DATA_COLLECTOR';
    parameter_list := #SEQ (parameter);
    ofp$display_status_message ('Waiting for spi collector to start.', status);
    pmp$execute_with_less_privilege (caller_id.ring, program_description^, parameter_list^,
          osc$nowait, FALSE, osv$spi_task_data_p^.task_id, osv$spi_task_data_p^.task_status,
          status);
    IF status.normal AND osv$spi_task_data_p^.task_status.complete THEN
      IF NOT osv$spi_task_data_p^.task_status.status.normal THEN
{
{ CAUTION !!! The copy of status must occur before the call to
{ osp$release_spi_environment which frees osv$spi_stask_data_p.
{
        status := osv$spi_task_data_p^.task_status.status;
        osp$release_spi_environment (lstatus);
        osp$disestablish_cond_handler;
        RETURN;
      IFEND;
    IFEND;

    REPEAT
      pmp$long_term_wait (100000000, 100000000);
    UNTIL osv$spi_control.pp_available OR
       osv$spi_task_data_p^.task_status.complete;
    IF osv$spi_task_data_p^.task_status.complete THEN
      IF NOT osv$spi_task_data_p^.task_status.status.normal THEN
{
{ CAUTION !!! The copy of status must occur before the call to
{ osp$release_spi_environment which frees osv$spi_stask_data_p.
{
        status := osv$spi_task_data_p^.task_status.status;
        osp$release_spi_environment (lstatus);
        osp$disestablish_cond_handler;
        RETURN;
      IFEND;
    IFEND;
    osp$disestablish_cond_handler;

    pmp$establish_end_hndlr_in_ring (^end_handler, caller_id.ring, lstatus);

  PROCEND osp$reserve_spi_environment;
?? TITLE := 'PROCEDURE end_handler', EJECT ??

  PROCEDURE end_handler
    (    termination_status: ost$status;
     VAR status: ost$status);

    status.normal := TRUE;
    pmp$log_ascii ('SPI COLLECTION ABORTED', $pmt$ascii_logset
          [pmc$system_log, pmc$job_log], pmc$msg_origin_system, status);

    osp$release_spi_environment (status);

  PROCEND end_handler;


?? TITLE := 'PROCEDURE [XDCL, #GATE] osp$release_spi_environment', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$release_spi_environment
    (VAR status: ost$status);

*copyc osh$release_spi_environment

    PROCEDURE handler
      (    condition: pmt$condition;
           condition_info: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      handler_status.normal := TRUE;
      IF handler_invoked THEN
        RETURN;
      IFEND;
      IF condition.selector = ifc$interactive_condition THEN
        IF condition.interactive_condition = ifc$terminate_break THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure,
                handler_status);
          RETURN;
        IFEND;
      IFEND;
      handler_invoked := TRUE;
      pmp$disestab_end_hndlr_in_ring (^end_handler, caller_id.ring, status);
      osp$set_status_from_condition ('OS', condition, save_area, status,
            handler_status);
      IF NOT status.normal THEN
        handler_status := status;
      IFEND;
      EXIT osp$release_spi_environment;
    PROCEND handler;

?? EJECT ??

    VAR
      caller_id: ost$caller_identifier,
      i: integer,
      handler_invoked: boolean,
      lstatus: ost$status,
      OFF: integer;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    lstatus.normal := TRUE;
    osp$fetch_spi_lock (i);
    IF (i = 0) OR (osv$spi_control.jsn <> jmv$jcb.system_name) THEN
      osp$set_status_abnormal ('OS', ose$spi_illegal_request, '', status);
      RETURN;
    IFEND;

    handler_invoked := FALSE;
    osp$establish_condition_handler (^handler, TRUE);

    IF ((osv$spi_control.operation_status = osc$spi_wait_for_start) OR
          (osv$spi_control.operation_status = osc$spi_start_collecting)) THEN
      osp$stop_spi_collection_r1 (status);
    IFEND;
    osp$release_spi_r1_support (status);
    IF status.normal THEN
      pmp$long_term_wait (40000, 40000);
    IFEND;
    IF NOT osv$spi_task_data_p^.task_status.complete THEN
      pmp$terminate (osv$spi_task_data_p^.task_id, status);
    IFEND;
    pmp$disestab_end_hndlr_in_ring (^end_handler, caller_id.ring, lstatus);
    osp$disestablish_cond_handler;
    FREE osv$spi_task_data_p IN osv$task_private_heap^;
  PROCEND osp$release_spi_environment;

?? TITLE := 'PROCEDURE [XDCL, #GATE] osp$start_spi_collection', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$start_spi_collection
    (VAR status: ost$status);

*copyc osh$start_spi_collection

    VAR
      i: integer;

    status.normal := TRUE;
    osp$fetch_spi_lock (i);
    IF (i = 0) OR (osv$spi_control.jsn <> jmv$jcb.system_name) THEN
      osp$set_status_abnormal ('OS', ose$spi_illegal_request, '', status);
      RETURN;
    IFEND;
    osp$start_spi_collection_r1 (status);

  PROCEND osp$start_spi_collection;

?? TITLE := 'PROCEDURE [XDCL, #GATE] osp$stop_spi_collection', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$stop_spi_collection
    (VAR status: ost$status);

*copyc osh$stop_spi_collection

    VAR
      i: integer;

    status.normal := TRUE;
    osp$fetch_spi_lock (i);
    IF (i = 0) OR (osv$spi_control.jsn <> jmv$jcb.system_name) THEN
      osp$set_status_abnormal ('OS', ose$spi_illegal_request, '', status);
      RETURN;
    IFEND;
    osp$stop_spi_collection_r1 (status);

  PROCEND osp$stop_spi_collection;

MODEND osm$spi_support;
*DECK DECK=OSM$SPI_SUPPORT_R1 EXPAND=TRUE
MODULE osm$spi_support_r1;
?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc amt$local_file_name
*copyc dmp$allocate_file_space_r1
*copyc i#call_monitor
*copyc i#real_memory_address
*copyc jmv$jcb
*copyc mmp$get_segment_sfid
*copyc osc$multiprocessor_constants
*copyc ose$spi_conditions
*copyc osp$fetch_locked_variable
*copyc osp$set_locked_variable
*copyc osp$set_status_abnormal
*copyc ost$execution_control_block
*copyc ost$processor_id_set
*copyc osv$spi_control
*copyc osv$page_size
*copyc osv$mainframe_wired_heap
*copyc pmp$delay
*copyc pmp$find_executing_task_xcb
*copyc pmp$get_executing_task_gtid
*copyc pmp$ready_task
?? POP ??

?? TITLE := 'PROCEDURE osp$reserve_spi_r1_support', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$reserve_spi_r1_support
    (    spi_identifier: ost$spi_identifier;
         collection_file: amt$local_file_name;
         number_of_spi_samples: ost$number_of_spi_samples;
         spi_sampling_interval: ost$spi_sampling_interval;
         processor_id_set: ost$processor_id_set;
         data_string: string (32);
     VAR status: ost$status);

    VAR
      actual: integer,
      locked: boolean,
      i: integer,
      rma: integer;

    status.normal := TRUE;
    osp$set_locked_variable (osv$spi_control.lock, 0, 1, actual, locked);
    IF NOT locked THEN
      IF osv$spi_control.jsn = jmv$jcb.system_name THEN
        osp$set_status_abnormal ('OS', ose$job_has_spi_environment, '',
              status);
      ELSE
        osp$set_status_abnormal ('OS', ose$spi_environment_not_avail, '',
              status);
      IFEND;
      RETURN;
    IFEND;

    osv$spi_control.number_of_spi_samples := number_of_spi_samples;
    osv$spi_control.ijle_p := jmv$jcb.ijle_p;
    osv$spi_control.jsn := jmv$jcb.system_name;
    osv$spi_control.operation_status := osc$spi_wait_for_start;
    osv$spi_control.spi_sampling_interval := spi_sampling_interval;
    osv$spi_control.spi_identifier := spi_identifier;
    osv$spi_control.collection_file := collection_file;
    osv$spi_control.data_string := data_string;
    osv$spi_control.processor_0_select := 0 IN processor_id_set;
    osv$spi_control.processor_1_select := 1 IN processor_id_set;
    osv$spi_control.processor_2_select := 2 IN processor_id_set;
    osv$spi_control.processor_3_select := 3 IN processor_id_set;
    osv$spi_control.processor_4_select := 4 IN processor_id_set;
    osv$spi_control.processor_5_select := 5 IN processor_id_set;
    osv$spi_control.pp_available := FALSE;
    pmp$get_executing_task_gtid (osv$spi_control.initiator_task);

  PROCEND osp$reserve_spi_r1_support;

?? TITLE := 'PROCEDURE osp$release_spi_r1_support', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$release_spi_r1_support
    (VAR status: ost$status);

    VAR
      actual: integer,
      i: integer,
      local_status: ost$status,
      result: boolean;

    status.normal := TRUE;
    osp$fetch_locked_variable (osv$spi_control.lock, i);
    IF (i = 0) OR (osv$spi_control.jsn <> jmv$jcb.system_name) THEN
      osp$set_status_abnormal ('OS', ose$spi_illegal_request, '', status);
      RETURN;
    IFEND;

    IF osv$spi_control.operation_status <> osc$spi_process_complete THEN
      osv$spi_control.operation_status := osc$spi_termination_requested;
    IFEND;

{   Wake up the collector task to process termination status.

    pmp$ready_task (osv$spi_control.collector_task, status);
    osv$spi_control.jsn := '   ';
    osv$spi_control.ijle_p := NIL;

    osp$set_locked_variable (osv$spi_control.lock, 1, 0, actual, result);

  PROCEND osp$release_spi_r1_support;

?? TITLE := 'PROCEDURE osp$start_spi_collection_r1', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$start_spi_collection_r1
    (VAR status: ost$status);

    status.normal := TRUE;
    IF osv$spi_control.operation_status = osc$spi_process_complete THEN
      osp$set_status_abnormal ('OS', ose$collection_task_ended, '', status);
      RETURN;
    IFEND;

    osv$spi_control.operation_status := osc$spi_start_collecting;
    pmp$ready_task (osv$spi_control.collector_task, status);

  PROCEND osp$start_spi_collection_r1;

?? TITLE := 'PROCEDURE osp$stop_spi_collection_r1', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$stop_spi_collection_r1
    (VAR status: ost$status);

    status.normal := TRUE;
    IF osv$spi_control.operation_status = osc$spi_process_complete THEN
      osp$set_status_abnormal ('OS', ose$collection_task_ended, '', status);
      RETURN;
    IFEND;

    osv$spi_control.operation_status := osc$spi_stop_collecting;
    pmp$ready_task (osv$spi_control.collector_task, status);

  PROCEND osp$stop_spi_collection_r1;


?? TITLE := 'PROCEDURE osp$fetch_spi_lock', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$fetch_spi_lock
    (VAR i: integer);

    osp$fetch_locked_variable (osv$spi_control.lock, i);

  PROCEND osp$fetch_spi_lock;

MODEND osm$spi_support_r1;
*DECK DECK=OSM$SYSTEM_CONTROL_SERVICES_R1 EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
MODULE osm$system_control_services_r1;
{
{ This module contains miscellaneous service routines used while controlling
{ the system via the monitor commands IDLE_SYSTEM, RESUME_SYSTEM, and TERMINATE_SYSTEM.
{ This module is located on the following library:
{        OSF$SYSTEM_CORE_113
{

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*copyc jmv$jcb
*copyc ose$multipro_exceptions
*copyc oss$mainframe_pageable
*copyc ost$global_task_id
*copyc ost$wait
*copyc mtv$nosve_control_status
*copyc mtv$scb
*copyc mtt$system_update_requests
*copyc ost$idle_state
*copyc osp$begin_system_activity
*copyc osp$end_system_activity
*copyc osp$set_status_abnormal
?? EJECT ??
  FUNCTION [XDCL, #GATE] osp$idle_requested_r1: boolean;

    osp$idle_requested_r1 := (mtv$scb.nos_180_status.system_status.idle_status_block.requested_status =
          mtc$idled_system);

  FUNCEND osp$idle_requested_r1;

  PROCEDURE [XDCL, #GATE] osp$update_idle_state_r1 (idle_state: ost$idle_state);

    CASE idle_state OF
    = osc$system_not_idle =
      mtv$nosve_control_status.idle_state := mtc$system_not_idle;
      mtv$scb.nos_180_status.system_status.idle_status_block.actual_status := mtc$running_system;
    = osc$system_idle =
      mtv$nosve_control_status.idle_state := mtc$system_idle;
      mtv$scb.nos_180_status.system_status.idle_status_block.actual_status := mtc$idled_system;
    = osc$idle_system_in_progress =
      mtv$nosve_control_status.idle_state := mtc$idle_system_in_progress;
    = osc$resume_system_in_progress =
      mtv$nosve_control_status.idle_state := mtc$resume_system_in_progress;
    ELSE
      ;
    CASEND;

  PROCEND osp$update_idle_state_r1;

  PROCEDURE [XDCL, #GATE] osp$terminate_system_r1;

    mtv$scb.nos_180_status.system_status.idle_status_block.requested_status := mtc$idled_system;
    mtv$scb.nos_180_status.cause_of_idle := syc$ic_system_terminated;

  PROCEND osp$terminate_system_r1;

  PROCEDURE [XDCL, #GATE] osp$get_cause_of_idle (VAR idle_code: syt$180_idle_code);

    idle_code := mtv$scb.nos_180_status.cause_of_idle;

  PROCEND osp$get_cause_of_idle;

  PROCEDURE [XDCL, #GATE] osp$jt_begin_system_activity;

    osp$begin_system_activity;

  PROCEND osp$jt_begin_system_activity;

  PROCEDURE [XDCL, #GATE] osp$jt_end_system_activity;

    osp$end_system_activity;

  PROCEND osp$jt_end_system_activity;
MODEND osm$system_control_services_r1;
*DECK DECK=OSM$SYSTEM_CONTROL_SERVICES_R3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operating System : System Control Services for Ring 3' ??
MODULE osm$system_control_services_r3;

{ PURPOSE:
{   This module contains calls to miscellaneous service routines used while
{   controlling the system via IDLE_SYSTEM, RESUME_SYSTEM, and TERMINATE_SYSTEM.
{   This module is located on the following library:  OSF$SYSTEM_CORE_13D

*copyc osp$get_cause_of_idle
*copyc osp$idle_requested_r1

?? TITLE := 'osp$get_cause_of_idle_r3', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$get_cause_of_idle_r3
    (VAR idle_code: syt$180_idle_code);

    osp$get_cause_of_idle (idle_code);

  PROCEND osp$get_cause_of_idle_r3;
?? TITLE := 'osp$idle_requested', EJECT ??

  FUNCTION [XDCL, #GATE] osp$idle_requested: boolean;

    osp$idle_requested := osp$idle_requested_r1 ();

  FUNCEND osp$idle_requested;
MODEND osm$system_control_services_r3;
*DECK DECK=OSM$SYSTEM_DEBUG_UTILITY EXPAND=TRUE
MODULE osm$system_debug_utility;
MODEND osm$system_debug_utility;
*DECK DECK=OSM$SYSTEM_ERROR_PROCESSORS EXPAND=TRUE

?? RIGHT := 110 ??
MODULE osm$system_error_processors;
{
{ This module contains routines that are called to process system errors
{
?? PUSH (LISTEXT := ON) ??
*copyc OSD$REGISTERS
*copyc OSE$HEAP_FULL_EXCEPTIONS
*copyc OST$RB_SYSTEM_ERROR


?? POP ??
*copyc I#CALL_MONITOR
*copyc osp$check_for_job_recovery
*copyc osp$log_system_error

?? TITLE := 'osp$system_error', EJECT ??
  PROCEDURE [XDCL, #GATE] osp$system_error (text: string ( * );
        status_p: ^ost$status);

    VAR
      p_reqister_p: ^ost$p_register,
      rb: ost$rb_system_error,
      status: ost$status;

    osp$log_system_error (text, 'SYSTEM ERROR - ');

    p_reqister_p := #previous_save_area ();
    rb.reqcode := syc$rc_system_error;
    rb.fatal := FALSE;
    rb.caller_p_register := p_reqister_p^;
    rb.text := text;
    rb.text_p := ^text;
    rb.status_p := status_p;
    IF status_p <> NIL THEN
      rb.condition := status_p^.condition;
    IFEND;

{ Check if job is in job recovery.  If it is, control will not return here.

    osp$check_for_job_recovery ('SYSTEM ERROR during job recovery');

    WHILE TRUE DO
      i#call_monitor (#LOC (rb), #SIZE (rb));
    WHILEND;

  PROCEND osp$system_error;
?? TITLE := 'osp$fatal_system_error', EJECT ??
  PROCEDURE [XDCL] osp$fatal_system_error (text: string ( * );
        status_p: ^ost$status);

    VAR
      p_reqister_p: ^ost$p_register,
      rb: ost$rb_system_error;

    osp$log_system_error (text, 'FATAL SYSTEM ERROR - ');

    p_reqister_p := #previous_save_area ();
    rb.reqcode := syc$rc_system_error;
    rb.fatal := TRUE;
    rb.caller_p_register := p_reqister_p^;
    rb.text := text;
    rb.text_p := ^text;
    rb.status_p := status_p;
    IF status_p <> NIL THEN
      rb.condition := status_p^.condition;
    IFEND;

    WHILE TRUE DO
      i#call_monitor (#LOC (rb), #SIZE (rb));
    WHILEND;

  PROCEND osp$fatal_system_error;
?? TITLE := 'PROCEDURE cyp$error', EJECT ??

  PROCEDURE [XDCL] cyp$error (ec: integer;
        line: integer;
        module_p: ^string (31));

    VAR
      s: string (63),
      k: integer;

    s := 'CYBIL ERROR xx AT LINE xxxxx OF mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm';
    s (14) := CHR ((ec MOD 10) + ORD ('0'));
    s (13) := CHR ((ec DIV 10) + ORD ('0'));
    s (28) := CHR ((line MOD 10) + ORD ('0'));
    s (27) := CHR (((line MOD 100) DIV 10) + ORD ('0'));
    s (26) := CHR (((line MOD 1000) DIV 100) + ORD ('0'));
    s (25) := CHR (((line MOD 10000) DIV 1000) + ORD ('0'));
    s (24) := CHR ((line DIV 10000) + ORD ('0'));
    s (33, 31) := module_p^;

    osp$system_error (s, NIL);
  PROCEND cyp$error;
?? SKIP := 2 ??

  PROCEDURE [XDCL] cyp$nil;

    osp$system_error ('CYP$NIL called in system core', NIL);

  PROCEND cyp$nil;

MODEND
*DECK DECK=OSM$SYSTEM_MESSAGE_GENERATOR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE System Message Generator' ??
MODULE osm$system_message_generator;

{
{ PURPOSE:
{   This module contains the procedure responsible for processing the ost$status record
{   for human consumption.  This involves locating a message_module_dictionary entry corresponding
{   to a status condition code or status condition name and either formatting a message or
{   retrieving the condition's severity level, name, or code.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
*copyc osc$compression_identifier
*copyc oss$job_paged_literal
*copyc ost$get_message_part
*copyc ost$max_status_message_line
*copyc ost$message_parameters
*copyc ost$message_template_module
*copyc ost$status
*copyc ost$status_identifier
*copyc ost$status_message
*copyc ost$status_message_header_kind
*copyc ost$status_message_level
*copyc ost$status_message_line
*copyc ost$status_message_line_count
*copyc ost$status_message_line_size
*copyc ost$status_severity
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*IF NOT $true(osv$unix)
*copyc cyd$run_time_error_condition
*copyc fst$path
*copyc lle$load_map_diagnostics
*copyc osk$keypoints
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc ost$caller_identifier
*IFEND
?? POP ??
*IF NOT $true(osv$unix)
*copyc amp$fetch
*copyc amp$put_next
*IFEND
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_unsigned_decimal
*IF NOT $true(osv$unix)
*copyc clp$extract_msg_module_contents
*copyc clp$find_command_list
*IFEND
*copyc clp$get_path_name
*copyc clp$get_system_file_id
*IF NOT $true(osv$unix)
*copyc clp$get_system_message_mod_ptr
*copyc clp$put_error_output
*IFEND
*copyc clp$put_job_command_response
*IF NOT $true(osv$unix)
*copyc clp$put_job_output
*copyc clp$search_module_for_code
*IFEND
*copyc clp$search_msg_library_via_code
*copyc clp$search_msg_library_via_name
*copyc clp$trimmed_string_size
*IF NOT $true(osv$unix)
*copyc osp$convert_to_diagnos_severity
*IFEND
*copyc osp$convert_to_status_severity
*IF NOT $true(osv$unix)
*copyc osp$enforce_exception_policies
*copyc osp$establish_condition_handler
*copyc osp$expand_file_reference
*copyc osp$file_access_condition
*copyc osp$find_status_message_level
*copyc osp$set_status_from_condition
*copyc osp$status_condition_code
*IFEND
*copyc osp$unpack_status_condition
*copyc osp$unpack_status_identifier
*IF NOT $true(osv$unix)
*copyc osp$verify_system_privilege
*copyc osv$initial_exception_context
*copyc pmp$continue_to_cause
*copyc pmp$load
*copyc pmp$log_ascii
*ELSE
*copyc amt$file_identifier
*copyc clt$standard_files
*copyc fst$path_size
*copyc fst$path
*copyc osk$keypoints
*copyc ost$caller_identifier
*IFEND
?? EJECT ??

  CONST
    osc$parameter_delimiter_limit = osc$max_string_size;

  TYPE
    ost$status_text = string ( * <= osc$max_string_size);

  VAR
    osv$severities: [XDCL, READ, oss$job_paged_literal] array [ost$status_severity] of record
      size: 5 .. 12,
      value: string (12),
    recend := [[11, 'INFORMATIVE'], [7, 'WARNING'], [5, 'ERROR'], [5, 'FATAL'], [12, 'CATASTROPHIC']];

  VAR
    subdued_severities: [STATIC, READ, oss$job_paged_literal] array [ost$status_severity] of record
      size: 5 .. 18,
      value: string (18),
    recend := [[11, 'Informative'], [7, 'Warning'], [5, 'Error'], [11, 'Fatal error'], [18,
          'Catastrophic error']];

  VAR
    default_template: [STATIC, READ, oss$job_paged_literal] string (19) := 'CC=+C TEXT=+T';

?? TITLE := 'get_template_info_via_code', EJECT ??

  PROCEDURE get_template_info_via_code
    (    code: ost$status_condition_code;
         search_by_language: boolean;
     VAR name: ost$status_condition_name;
     VAR severity: ost$message_module_severity;
     VAR template: ^ost$message_template;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
*IF NOT $true(osv$unix)
      command_list: ^clt$command_list,
      current_entry: ^clt$command_list_entry,
*IFEND
      entry_found: boolean,
      i: integer,
      ignore_cmnd_list_found_in_task: boolean,
      local_library_name: amt$local_file_name,
      saved_default: boolean,
      search_cache: boolean,
      system_message_library_searched: boolean;

*IF NOT $true(osv$unix)
?? TITLE := 'search_msg_library_via_code', EJECT ??

    PROCEDURE [INLINE] search_msg_library_via_code;

    VAR
      context: ^ost$ecp_exception_context;

      context := NIL;

      REPEAT
        clp$search_msg_library_via_code (caller_id.ring, code, search_by_language, search_cache,
              local_library_name, name, severity, template, entry_found, saved_default, status);
        IF osp$file_access_condition (status) THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_file_reference;
            context^.file.file_reference := ^local_library_name;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
    PROCEND search_msg_library_via_code;

*IFEND


    status.normal := TRUE;
*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND
    severity := osc$mm_error_severity;
*IF NOT $true(osv$unix)
    template := NIL;
*IFEND
    name := 'UNKNOWN_CONDITION';
    search_cache := TRUE;
    saved_default := FALSE;
    entry_found := FALSE;
    system_message_library_searched := FALSE;

*IF NOT $true(osv$unix)
    clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);
    current_entry := command_list^.entries.first_entry;

    WHILE current_entry <> NIL DO
      CASE current_entry^.kind OF

      = clc$library_commands =
        IF current_entry^.library_contains.message_modules AND NOT current_entry^.unaccessible_entry THEN
          local_library_name := current_entry^.local_file_name;
          search_msg_library_via_code;
          search_cache := FALSE;
          status.normal := TRUE {ignore bad status from search} ;
        IFEND;

      = clc$system_commands =
        IF (command_list^.system_command_library_lfn <> osc$null_name) AND
              command_list^.system_library_contains.message_modules THEN
          local_library_name := command_list^.system_command_library_lfn;
          search_msg_library_via_code;
          search_cache := FALSE;
          status.normal := TRUE {ignore bad status from search} ;
        IFEND;
        IF NOT entry_found THEN
          local_library_name := osc$null_name;
          search_msg_library_via_code;
          search_cache := FALSE;
          status.normal := TRUE {ignore bad status from search} ;
        IFEND;
        system_message_library_searched := TRUE;

      = clc$sub_commands =
        IF current_entry^.utility_info^.auxiliary_libraries <> NIL THEN
          FOR i := 1 TO UPPERBOUND (current_entry^.utility_info^.auxiliary_libraries^) DO
            IF current_entry^.utility_info^.auxiliary_libraries^ [i].contains.message_modules THEN
              local_library_name := current_entry^.utility_info^.auxiliary_libraries^ [i].name;
              search_msg_library_via_code;
              search_cache := FALSE;
              status.normal := TRUE {ignore bad status from search} ;
              IF entry_found THEN
                RETURN;
              IFEND;
            IFEND;
          FOREND;
        IFEND;

      ELSE
        ;
      CASEND;

      IF entry_found THEN
        RETURN;
      IFEND;
      current_entry := current_entry^.next_entry;
    WHILEND;

    IF NOT system_message_library_searched THEN
      IF (command_list^.system_command_library_lfn <> osc$null_name) AND
            command_list^.system_library_contains.message_modules THEN
        local_library_name := command_list^.system_command_library_lfn;
        search_msg_library_via_code;
        status.normal := TRUE {ignore bad status from search} ;
      IFEND;
      IF NOT entry_found THEN
        local_library_name := osc$null_name;
        search_msg_library_via_code;
        status.normal := TRUE {ignore bad status from search} ;
      IFEND;
    IFEND;
*ELSE
    local_library_name := osc$null_name;
    clp$search_msg_library_via_code (caller_id.ring, code, search_by_language, search_cache,
          local_library_name, name, severity, template, entry_found, saved_default, status);
    search_cache := FALSE;
    status.normal := TRUE {ignore bad status from search} ;
*IFEND

  PROCEND get_template_info_via_code;
?? TITLE := 'get_template_info_via_name', EJECT ??

  PROCEDURE get_template_info_via_name
    (    name: ost$status_condition_name;
         search_by_language: boolean;
     VAR code: ost$status_condition_code;
     VAR severity: ost$message_module_severity;
     VAR template: ^ost$message_template;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
*IF NOT $true(osv$unix)
      command_list: ^clt$command_list,
      current_entry: ^clt$command_list_entry,
*IFEND
      entry_found: boolean,
      i: integer,
      ignore_cmnd_list_found_in_task: boolean,
      local_library_name: amt$local_file_name,
      saved_default: boolean,
      search_cache: boolean,
      system_message_library_searched: boolean;

*IF NOT $true(osv$unix)
?? TITLE := 'search_msg_library_via_name', EJECT ??


    PROCEDURE [INLINE] search_msg_library_via_name;

    VAR
      context: ^ost$ecp_exception_context;

      context := NIL;

      REPEAT
        clp$search_msg_library_via_name (caller_id.ring, name, search_by_language, search_cache,
              local_library_name, code, severity, template, entry_found, saved_default, status);
        IF osp$file_access_condition (status) THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_file_reference;
            context^.file.file_reference := ^local_library_name;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
    PROCEND search_msg_library_via_name;

*IFEND


    status.normal := TRUE;
*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND
    system_message_library_searched := FALSE;
    search_cache := TRUE;
    saved_default := FALSE;
    entry_found := FALSE;
    code := 0;
    severity := osc$mm_error_severity;
*IF NOT $true(osv$unix)
    template := NIL;

    clp$find_command_list (command_list, ignore_cmnd_list_found_in_task);
    current_entry := command_list^.entries.first_entry;

    WHILE current_entry <> NIL DO
      CASE current_entry^.kind OF

      = clc$library_commands =
        IF current_entry^.library_contains.message_modules AND NOT current_entry^.unaccessible_entry THEN
          local_library_name := current_entry^.local_file_name;
          search_msg_library_via_name;
          search_cache := FALSE;
          status.normal := TRUE {ignore bad status from search} ;
        IFEND;

      = clc$system_commands =
        IF (command_list^.system_command_library_lfn <> osc$null_name) AND
              command_list^.system_library_contains.message_modules THEN
          local_library_name := command_list^.system_command_library_lfn;
          search_msg_library_via_name;
          status.normal := TRUE {ignore bad status from search} ;
        IFEND;
        IF NOT entry_found THEN
          local_library_name := osc$null_name;
          search_msg_library_via_name;
          search_cache := FALSE;
          status.normal := TRUE {ignore bad status from search} ;
        IFEND;
        system_message_library_searched := TRUE;

      = clc$sub_commands =
        IF current_entry^.utility_info^.auxiliary_libraries <> NIL THEN
          FOR i := 1 TO UPPERBOUND (current_entry^.utility_info^.auxiliary_libraries^) DO
            IF current_entry^.utility_info^.auxiliary_libraries^ [i].contains.message_modules THEN
              local_library_name := current_entry^.utility_info^.auxiliary_libraries^ [i].name;
              search_msg_library_via_name;
              search_cache := FALSE;
              status.normal := TRUE {ignore bad status from search} ;
              IF entry_found THEN
                RETURN;
              IFEND;
            IFEND;
          FOREND;
        IFEND;

      ELSE
        ;
      CASEND;

      IF entry_found THEN
        RETURN;
      IFEND;
      current_entry := current_entry^.next_entry;
    WHILEND;

    IF NOT system_message_library_searched THEN
      IF (command_list^.system_command_library_lfn <> osc$null_name) AND
            command_list^.system_library_contains.message_modules THEN
        local_library_name := command_list^.system_command_library_lfn;
        search_msg_library_via_name;
        status.normal := TRUE {ignore bad status from search} ;
      IFEND;
      IF NOT entry_found THEN
        local_library_name := osc$null_name;
        status.normal := TRUE {ignore bad status from search} ;
        search_msg_library_via_name;
      IFEND;
    IFEND;
*ELSE
    local_library_name := osc$null_name;
    clp$search_msg_library_via_name (caller_id.ring, name, search_by_language, search_cache,
          local_library_name, code, severity, template, entry_found, saved_default, status);
    status.normal := TRUE {ignore bad status from search} ;
*IFEND

  PROCEND get_template_info_via_name;
*IF NOT $true(osv$unix)
?? TITLE := 'osp$format_multi_part_message', EJECT ??
*copy osh$format_multi_part_message

  PROCEDURE [XDCL, #GATE] osp$format_multi_part_message
    (    message_level: ost$format_message_level;
         message_header_kind: ost$status_message_header_kind;
         max_message_line: ost$status_message_line_size;
         status_condition: ost$status_condition;
         message_parameters: ^ost$message_parameters;
         get_message_part: ost$get_message_part;
     VAR message: SEQ ( * );
     VAR status: ost$status);

    VAR
      condition_name: ost$status_condition_name,
      message_module_severity: ost$message_module_severity,
      message_template: ^ost$message_template,
      status_identifier: ost$status_identifier,
      status_severity: ost$status_severity,
      template: ^ost$message_template,
      actual_message_level: ost$status_message_level,
      current_message_level: ^ost$status_message_level;


    status.normal := TRUE;

    IF message_level = osc$current_message_level THEN
      osp$find_status_message_level (current_message_level);
      actual_message_level := current_message_level^;
    ELSE
      actual_message_level := message_level;
    IFEND;

    get_template_info_via_code (status_condition, TRUE, condition_name, message_module_severity, template,
          status);
    IF (NOT status.normal) OR (template = NIL) OR (STRLENGTH (template^) = 0) THEN
      template := ^default_template;
    IFEND;

    status_severity := osp$convert_to_status_severity (message_module_severity);

    format_message (actual_message_level, message_header_kind, max_message_line,
          osp$status_condition_code (status_identifier, status_condition), status_severity, template,
          message_parameters, get_message_part, osc$status_parameter_delimiter, message, status);

  PROCEND osp$format_multi_part_message;
*IFEND
?? TITLE := 'format_message', EJECT ??

  PROCEDURE format_message
    (    message_level: ost$status_message_level;
         message_header_kind: ost$status_message_header_kind;
         max_line_size: osc$min_status_message_line - 1 .. osc$max_status_message_line - 1;
         status_condition: ost$status_condition_code,
         status_severity: ost$status_severity;
         original_template: ^ost$message_template;
         original_parameters: ^ost$message_parameters;
         get_message_part: ost$get_message_part;
         parameter_delimiter: char;
     VAR message: SEQ ( * );
     VAR status: ost$status);

    VAR
      delimiter_set: [STATIC, READ, oss$job_paged_literal] packed array [char] of boolean := [
            {---} REP 32 of FALSE,
            {' '} TRUE,
            {---} REP 11 of FALSE,
            {-,-} TRUE,
            {---} REP 211 of FALSE],
      non_delimiter_set: [STATIC, READ, oss$job_paged_literal] packed array [char] of boolean := [
            {---} REP 32 of TRUE,
            {' '} FALSE,
            {---} REP 11 of TRUE,
            {-,-} FALSE,
            {---} REP 211 of TRUE];

    VAR
      empty_string: ^string ( * ),
      indent_amount: integer,
      keep_pending: boolean,
      last_parameter: 0 .. osc$parameter_delimiter_limit,
      last_space_hard: boolean,
      line_count: ^ost$status_message_line_count,
      message_area: ^SEQ ( * ),
      message_parameters: ^ost$message_parameters,
      message_parameters_exhausted: boolean,
      next_line: string (osc$max_status_message_line),
      next_line_break_index: ost$status_message_line_size,
      next_line_secondary_break_index: ost$status_message_line_size,
      next_line_size: ost$status_message_line_size,
      template: ^ost$message_template,
      template_index: ost$message_template_index,
      soft_eol_pending: boolean;

?? NEWTITLE := 'put_standard_message_header', EJECT ??

    PROCEDURE [INLINE] put_standard_message_header;


      IF (message_level > osc$brief_message_level) OR (status_severity > osc$informative_status) OR
            (template = ^default_template) THEN
        put_string ('--');
        put_string (osv$severities [status_severity].value (1, osv$severities [status_severity].size));
        IF (message_level > osc$brief_message_level) AND (template <> ^default_template) THEN
          put_character (' ');
          osp$get_status_condition_string (status_condition, status_condition_string, status);
          IF NOT status.normal THEN
            EXIT format_message;
          IFEND;
          put_string (status_condition_string.value (1, status_condition_string.size));
        IFEND;
      IFEND;
      put_string ('--  ');

    PROCEND put_standard_message_header;
?? TITLE := 'put_subdued_message_header', EJECT ??

    PROCEDURE [INLINE] put_subdued_message_header;


      IF (status_severity > osc$informative_status) OR (template = ^default_template) THEN
        put_string (subdued_severities [status_severity].value (1, subdued_severities [status_severity].
              size));
        IF (message_level > osc$brief_message_level) AND (template <> ^default_template) THEN
          put_character (' ');
          osp$get_status_condition_string (status_condition, status_condition_string, status);
          IF NOT status.normal THEN
            EXIT format_message;
          IFEND;
          put_string (status_condition_string.value (1, status_condition_string.size));
        IFEND;
        put_string (': ');
      IFEND;

    PROCEND put_subdued_message_header;
?? TITLE := 'process_file_parameter', EJECT ??

    PROCEDURE [INLINE] process_file_parameter
      (    text: ost$message_parameter);

      VAR
        scan_index: 0 .. osc$max_string_size,
        scan_found_char: boolean,
        starting_position: 0 .. osc$max_string_size,
        end_position: 0 .. osc$max_string_size,
        file: fst$path;


      scan_index := 0;
      end_position := 0;
      starting_position := 0;

      WHILE ((end_position + 1) <= clp$trimmed_string_size (text)) DO
        #SCAN (non_delimiter_set, text (end_position + 1, * ), scan_index, scan_found_char);
        IF scan_found_char THEN
          IF starting_position <> 0 THEN
            put_string (', ');
          IFEND;
          starting_position := scan_index + end_position;
        ELSE
          IF (starting_position = 0) AND (starting_position <> end_position) THEN
            file := text;
            put_file_reference (file);
          IFEND;
          RETURN;
        IFEND;

        #SCAN (delimiter_set, text (starting_position, * ), scan_index, scan_found_char);
        IF scan_found_char THEN
          end_position := scan_index + starting_position - 1;
          file := text (starting_position, end_position - starting_position);
          put_file_reference (file);
        ELSE
          file := text (starting_position, * );
          put_file_reference (file);
          RETURN;
        IFEND;
      WHILEND;

    PROCEND process_file_parameter;
?? TITLE := 'put_file_reference', EJECT ??

    PROCEDURE [INLINE] put_file_reference
      (    file: fst$file_reference);

      VAR
        file_reference: fst$path,
        file_reference_size: fst$path_size,
        ignore_status: ost$status;

      IF (file (1) = ':') THEN
        put_string (file (1, clp$trimmed_string_size (file)));
      ELSE
*IF NOT $true(osv$unix)
        IF (file (1) = osc$compression_identifier) THEN
          osp$expand_file_reference (file, file_reference, file_reference_size, ignore_status);
        ELSE
*IFEND
          clp$get_path_name (file, osc$full_message_level, file_reference);
*IF NOT $true(osv$unix)
          file_reference_size := clp$trimmed_string_size (file_reference)
        IFEND;
*ELSE
          file_reference_size := clp$trimmed_string_size (file_reference);
*IFEND
        put_string (file_reference (1, file_reference_size));
      IFEND;

    PROCEND put_file_reference;
?? TITLE := 'put_string', EJECT ??

    PROCEDURE [INLINE] put_string
      (    s: string ( * ));

      VAR
        i: integer;


      FOR i := 1 TO STRLENGTH (s) DO
        put_character (s (i));
      FOREND;

    PROCEND put_string;
?? TITLE := 'put_character', EJECT ??

    PROCEDURE [INLINE] put_character
      (    c: char);


      IF next_line_size >= max_line_size THEN
        break_line;
      IFEND;

{ It is possible that indent_amount + extra_chars_length computed by break_line could be = max_line_size,
{ so check if the line needs to be broken again.  The check is '>=' for safety's sake.

      IF next_line_size >= max_line_size THEN
        break_line;
      IFEND;

      next_line_size := next_line_size + 1;
      CASE c OF

      = $CHAR (0) .. $CHAR (31), $CHAR (127) =
        next_line (next_line_size) := '?';
        IF NOT (soft_eol_pending OR keep_pending) THEN
          next_line_break_index := next_line_size;
        IFEND;

      = 'A' .. 'Z', 'a' .. 'z', '0' .. '9', '$', '#', '@', '[', '\', ']', '^', '`', '{', '|', '}', '~' =
        next_line (next_line_size) := c;

      = '_', '.', '(', ':' =
        next_line (next_line_size) := c;
        next_line_secondary_break_index := next_line_size;

      ELSE
        next_line (next_line_size) := c;
        IF NOT (soft_eol_pending OR keep_pending) THEN
          next_line_break_index := next_line_size;
        IFEND;

      CASEND;

    PROCEND put_character;
?? TITLE := 'break_line', EJECT ??

    PROCEDURE break_line;

      VAR
        extra_chars: string (osc$max_status_message_line),
        extra_chars_length: 0 .. osc$max_status_message_line,
        i: 1 .. osc$max_status_message_line,
        put_enabled: boolean;


      IF next_line_break_index = 0 THEN
        next_line_break_index := next_line_secondary_break_index;
      IFEND;

      IF next_line_break_index = 0 THEN
        extra_chars_length := 2;
        extra_chars := next_line (max_line_size - 1, 2);
        next_line (max_line_size - 1, 2) := '..';

      ELSEIF next_line_break_index < max_line_size THEN
        extra_chars_length := max_line_size - next_line_break_index;
        extra_chars := next_line (next_line_break_index + 1, * );
        next_line_size := next_line_break_index;

      ELSE
        extra_chars_length := 0;
      IFEND;

      flush_line;

      put_enabled := indent_amount > 0;
      FOR i := 1 TO extra_chars_length DO
        IF extra_chars (i) <> ' ' THEN
          put_enabled := TRUE;
        IFEND;
        IF put_enabled THEN
          put_character (extra_chars (i));
        IFEND;
      FOREND;

    PROCEND break_line;
?? TITLE := 'flush_line', EJECT ??

*IF NOT $true(osv$unix)
    PROCEDURE [INLINE] flush_line;
*ELSE
    PROCEDURE flush_line;
*IFEND

      VAR
*IF $true(osv$unix)
        l:string(256),
        s:integer,
*IFEND
        line: ^string ( * ),
        line_size: ^ost$status_message_line_size;


      IF NOT last_space_hard THEN
        WHILE (next_line_size > 0) AND (next_line (next_line_size) = ' ') DO
          next_line_size := next_line_size - 1;
        WHILEND;
      IFEND;

      NEXT line_size IN message_area;
      IF line_size = NIL THEN
        EXIT format_message;
      IFEND;
      NEXT line: [next_line_size + 1] IN message_area;
      IF line = NIL THEN
        EXIT format_message;
      IFEND;

      line_count^ := line_count^ +1;
      line_size^ := next_line_size + 1;
      line^ (1) := ' ';
      line^ (2, next_line_size) := next_line (1, next_line_size);

      IF indent_amount >= max_line_size THEN
        next_line_size := max_line_size;
      ELSE
        next_line_size := indent_amount;
      IFEND;

      soft_eol_pending := FALSE;
      next_line_break_index := 0;
      next_line_secondary_break_index := 0;
      next_line := '';

    PROCEND flush_line;
?? TITLE := 'get_parameter', EJECT ??

    PROCEDURE [INLINE] get_parameter
      (    count: integer;
       VAR parameter: ^ost$message_parameter);


      parameter := empty_string;

      IF message_parameters = NIL THEN
        message_parameters_exhausted := TRUE;
        RETURN;

      ELSEIF count <= 0 THEN {get next parameter
        IF last_parameter >= UPPERBOUND (message_parameters^) THEN
          message_parameters_exhausted := TRUE;
          RETURN;
        IFEND;

        last_parameter := last_parameter + 1;
        message_parameters_exhausted := last_parameter = UPPERBOUND (message_parameters^);

      ELSE {get a specific parameter
        IF count > UPPERBOUND (message_parameters^) THEN
          RETURN;
        IFEND;

        last_parameter := count;
      IFEND;

      IF message_parameters^ [last_parameter] = NIL THEN
        RETURN;
      IFEND;

      parameter := ^message_parameters^ [last_parameter]^ (1,
            clp$trimmed_string_size (message_parameters^ [last_parameter]^));

    PROCEND get_parameter;
?? TITLE := 'get_count', EJECT ??

    PROCEDURE [INLINE] get_count
      (VAR count_given: boolean;
       VAR count: integer);

      VAR
*IF NOT $true(osv$unix)
        integer_size: 0 .. osc$max_status_message,
        user_conditions: ost$user_conditions;
*ELSE
        integer_size: 0 .. osc$max_status_message;
*IFEND


      count := 0;
      integer_size := 0;
      template_index := template_index + 2;

      WHILE ((template_index + integer_size) <= STRLENGTH (template^)) AND
            ('0' <= template^ (template_index + integer_size)) AND
            (template^ (template_index + integer_size) <= '9') DO
        integer_size := integer_size + 1;
      WHILEND;

      count_given := integer_size > 0;
      IF count_given THEN
        clp$evaluate_unsigned_decimal (template^ (template_index, integer_size), count, status);

{ status intentionally ignored

        status.normal := TRUE;
        template_index := template_index + integer_size;
      IFEND;

    PROCEND get_count;
?? OLDTITLE, EJECT ??

    VAR
      condition: ost$status_condition_code,
      condition_name: ost$status_condition_name,
      count: integer,
      count_given: boolean,
      current_character: char,
      end_of_message: boolean,
*IF NOT $true(osv$unix)
      file_reference: fst$path,
*IFEND
      last_character: char,
*IF NOT $true(osv$unix)
      local_file_name: fst$path,
*IFEND
      message_module_severity: ost$message_module_severity,
      next_character: char,
      number_string: ost$string,
      parameter: ^ost$message_parameter,
      repeat_info: boolean,
      status_condition_string: ost$string,
      status_identifier: ost$status_identifier;


    status.normal := TRUE;

    message_area := ^message;
    RESET message_area;
    NEXT line_count IN message_area;
    line_count^ := 0;

    IF original_template = NIL THEN
      RETURN;
    IFEND;

    template := original_template;
    message_parameters := original_parameters;
    condition := status_condition;
    next_line_size := 0;
    next_line := '';
    next_line_break_index := 0;
    next_line_secondary_break_index := 0;
    indent_amount := 0;
    soft_eol_pending := FALSE;
    keep_pending := FALSE;
    template_index := 1;
    last_parameter := 0;
    last_space_hard := FALSE;
    repeat_info := FALSE;
    message_parameters_exhausted := FALSE;
    PUSH empty_string: [0];

    WHILE (template_index <= STRLENGTH (template^)) AND (template^ (template_index) = ' ') DO
      template_index := template_index + 1;
    WHILEND;

    IF (message_header_kind = osc$standard_status_message_hdr) OR
          ((message_header_kind = osc$error_status_message_hdr) AND
          (status_severity > osc$informative_status)) THEN
      put_standard_message_header;
    ELSEIF message_header_kind = osc$subdued_status_message_hdr THEN
      put_subdued_message_header;
    IFEND;

  /process_individual_template/
    WHILE TRUE DO

      REPEAT
        current_character := ' ';
        WHILE template_index <= STRLENGTH (template^) DO
          last_character := current_character;
          current_character := template^ (template_index);
          IF template_index = STRLENGTH (template^) THEN
            next_character := ' ';
          ELSE
            next_character := template^ (template_index + 1);
          IFEND;
          IF current_character = '+' THEN
            CASE next_character OF

            = 'C', 'c' = {condition code of status
              template_index := template_index + 2;
              osp$get_status_condition_string (condition, status_condition_string, status);
              IF NOT status.normal THEN
                EXIT format_message;
              IFEND;
              put_string (status_condition_string.value (1, status_condition_string.size));

            = 'E', 'e' = {soft eol (end of line)
              get_count (count_given, count);
              soft_eol_pending := TRUE;
              next_line_break_index := next_line_size;
              indent_amount := count;

            = 'F', 'f' = {message parameter interpreted  as file name
              get_count (count_given, count);
              get_parameter (count, parameter);
              process_file_parameter (parameter^);

            = 'H', 'h' = {insert spaces to column
              get_count (count_given, count);
              IF NOT count_given THEN
                count := 8 - (next_line_size MOD 8);
              ELSEIF next_line_size >= count THEN
                count := 1;
              ELSE
                count := count - next_line_size - 1;
              IFEND;
              IF (next_line_size + count) < max_line_size THEN
                next_line_size := next_line_size + count;
              ELSE
                indent_amount := 0;
                flush_line;
              IFEND;

            = 'I', 'i' = {product identifier of status
              template_index := template_index + 2;
              osp$unpack_status_identifier (condition, status_identifier);
              put_string (status_identifier);

            = 'K', 'k' = {toggle keeping together of a group of characters
              template_index := template_index + 2;
              keep_pending := NOT keep_pending;

            = 'N', 'n' = {hard eol (end of line)
              get_count (count_given, count);
              next_line_break_index := next_line_size;
              indent_amount := count;
              flush_line;
              indent_amount := 0;

            = 'P', 'p' = {message parameter
              get_count (count_given, count);
              get_parameter (count, parameter);
              put_string (parameter^);

            = 'R', 'r' = {begin repeating information
              IF NOT repeat_info THEN
                IF message_parameters <> NIL THEN
                  message_parameters_exhausted := last_parameter+1 >= UPPERBOUND (message_parameters^);
                ELSE
                  message_parameters_exhausted := TRUE;
                IFEND;
                IF NOT message_parameters_exhausted THEN
                  repeat_info := TRUE;
                IFEND;
                template := ^template^ ((template_index + 2), * );
                template_index := 1;
                current_character := ' ';
              IFEND;

            = 'S', 's' = {severity of status
              template_index := template_index + 2;
              put_string (osv$severities [status_severity].value (1, osv$severities [status_severity].size));

            = 'T', 't' = {all of text field from message_status record, i.e. all message parameters
              template_index := template_index + 2;
              IF message_parameters <> NIL THEN
                FOR count := 1 TO UPPERBOUND (message_parameters^) DO
                  put_character (parameter_delimiter);
                  put_string (message_parameters^ [count]^);
                FOREND;
              IFEND;

            = 'X', 'x' = {expand count as blanks
              get_count (count_given, count);
              IF NOT count_given THEN
                count := 1;
              IFEND;
              IF (next_line_size + count) < max_line_size THEN
                next_line_size := next_line_size + count;
                last_space_hard := TRUE;
              ELSE
                indent_amount := 0;
                flush_line;
              IFEND;

            = '+' = {the control sequence ++ => +
              template_index := template_index + 2;
              put_character ('+');

            = '-' = {NULL sequence (to allow for concatenation)
              template_index := template_index + 2;

            ELSE {this '+' is just another character
              template_index := template_index + 1;
              put_character ('+');
            CASEND;

          ELSEIF (last_character = ' ') AND (current_character = ' ') THEN
            template_index := template_index + 1;
            last_space_hard := TRUE;
          ELSE
            template_index := template_index + 1;
            put_character (current_character);
            last_space_hard := current_character = ' ';
          IFEND;

        WHILEND;
        IF repeat_info THEN
          template_index := 1;
        IFEND;
      UNTIL (NOT repeat_info) OR message_parameters_exhausted;

      IF get_message_part = NIL THEN
        EXIT /process_individual_template/;
      IFEND;
      get_message_part^ (condition, message_parameters, end_of_message, status);
      IF (NOT status.normal) OR (end_of_message) THEN
        EXIT /process_individual_template/;
      IFEND;

      get_template_info_via_code (condition, TRUE, condition_name, message_module_severity, template, status);
      IF (NOT status.normal) OR (template = NIL) OR (STRLENGTH (template^) = 0) THEN
        template := ^default_template;
      IFEND;

      keep_pending := FALSE;
      template_index := 1;
      last_parameter := 0;
      repeat_info := FALSE;
      message_parameters_exhausted := FALSE;
    WHILEND /process_individual_template/;

    IF next_line_size > 0 THEN
      flush_line;
    IFEND;

  PROCEND format_message;
?? TITLE := 'setup_status_message_formatting', EJECT ??

  PROCEDURE [INLINE] setup_status_message_formatting
    (    message_status: ^ost$status;
         message_level: ost$format_message_level;
     VAR actual_message_level: ost$status_message_level;
     VAR severity: ost$status_severity;
     VAR text: ^ost$status_text;
     VAR delimiter_count: 0 .. osc$parameter_delimiter_limit;
     VAR parameter_delimiter: char;
     VAR template: ^ost$message_template);

    VAR
      current_message_level: ^ost$status_message_level,
      message_status_text_size: ost$string_size,
      condition_name: ost$status_condition_name,
      message_module_severity: ost$message_module_severity,
      text_index: ost$string_index,
      status: ost$status;


*IF NOT $true(osv$unix)
    IF message_level = osc$current_message_level THEN
      osp$find_status_message_level (current_message_level);
      actual_message_level := current_message_level^;
    ELSE
      actual_message_level := message_level;
    IFEND;
*ELSE
    actual_message_level := osc$full_message_level;
*IFEND

    get_template_info_via_code (message_status^.condition, TRUE, condition_name, message_module_severity,
          template, status);
    IF (NOT status.normal) OR (template = NIL) OR (STRLENGTH (template^) = 0) THEN
      template := ^default_template;
    IFEND;

    severity := osp$convert_to_status_severity (message_module_severity);

    IF message_status^.text.size > osc$max_string_size THEN
      message_status_text_size := 0;
    ELSE
      message_status_text_size := message_status^.text.size;
    IFEND;

    text := ^message_status^.text.value (1, message_status_text_size);
    parameter_delimiter := message_status^.text.value (1);
    delimiter_count := 0;
    FOR text_index := 1 TO message_status_text_size DO
      IF text^ (text_index) = parameter_delimiter THEN
        delimiter_count := delimiter_count + 1;
      IFEND;
    FOREND;

  PROCEND setup_status_message_formatting;
?? TITLE := 'setup_status_message_parameters', EJECT ??

  PROCEDURE [INLINE] setup_status_message_parameters
    (    text: ^ost$status_text;
         parameter_delimiter: char;
     VAR message_parameters {input, output} : ost$message_parameters);

    VAR
      empty_string: ^string ( * ),
      message_parameter_index: integer,
      parameter_size: ost$string_size,
      start_of_parameter: ost$string_index,
      text_index: ost$string_index;


    PUSH empty_string: [0];
    FOR message_parameter_index := 1 TO UPPERBOUND (message_parameters) DO
      message_parameters [message_parameter_index] := empty_string;
    FOREND;
    parameter_size := 0;
    start_of_parameter := 2;
    message_parameter_index := 1;

  /fill_in_message_parameters/
    FOR text_index := 2 TO STRLENGTH (text^) DO
      IF text^ (text_index) <> parameter_delimiter THEN
        parameter_size := parameter_size + 1;
      ELSE
        IF message_parameter_index > UPPERBOUND (message_parameters) THEN
          EXIT /fill_in_message_parameters/;
        IFEND;
        message_parameters [message_parameter_index] := ^text^ (start_of_parameter, parameter_size);
        message_parameter_index := message_parameter_index + 1;
        parameter_size := 0;
        start_of_parameter := text_index + 1;
      IFEND;
    FOREND /fill_in_message_parameters/;
    IF (parameter_size > 0) AND (message_parameter_index <= UPPERBOUND (message_parameters)) THEN
      message_parameters [message_parameter_index] := ^text^ (start_of_parameter, parameter_size);
    IFEND;

  PROCEND setup_status_message_parameters;
?? TITLE := 'osp$format_message', EJECT ??
*copy osh$format_message

  PROCEDURE [XDCL, #GATE] osp$format_message ALIAS 'ospfmsg'
    (    message_status: ost$status;
         message_level: ost$format_message_level;
         max_message_line: ost$max_status_message_line;
     VAR message: ost$status_message;
     VAR status: ost$status);

    VAR
      actual_message_level: ost$status_message_level,
      delimiter_count: 0 .. osc$parameter_delimiter_limit,
      format_message_level: ost$format_message_level,
      identifier: ost$status_identifier,
      line_count: ^ost$status_message_line_count,
      local_status: ost$status,
      maximum_message_line: ost$max_status_message_line,
      message_area: ^ost$status_message,
      message_parameters: ^ost$message_parameters,
      parameter_delimiter: char,
      severity: ost$status_severity,
      template: ^ost$message_template,
*IF $true(osv$unix)
      temp_template: string (256),
*IFEND
      text: ^ost$status_text;


    #KEYPOINT (osk$entry, 0, osk$format_message);

    status.normal := TRUE;
    local_status.normal := TRUE;
*IF $true(osv$unix)
    PUSH template: [256];
{   template := ^temp_template;
*IFEND

    IF message_status.normal THEN
      message_area := ^message;
      RESET message_area;
      NEXT line_count IN message_area;
      line_count^ := 0;

    ELSE
      IF (message_level < LOWERVALUE (ost$format_message_level)) OR
            (message_level > UPPERVALUE (ost$format_message_level)) THEN
        format_message_level := osc$current_message_level;
      ELSE
        format_message_level := message_level;
      IFEND;

      IF max_message_line < LOWERVALUE (ost$max_status_message_line) THEN
        maximum_message_line := LOWERVALUE (ost$max_status_message_line);
      ELSEIF max_message_line > UPPERVALUE (ost$max_status_message_line) THEN
        maximum_message_line := UPPERVALUE (ost$max_status_message_line);
      ELSE
        maximum_message_line := max_message_line;
      IFEND;

      setup_status_message_formatting (^message_status, format_message_level, actual_message_level, severity,
            text, delimiter_count, parameter_delimiter, template);
      IF delimiter_count = 0 THEN
        message_parameters := NIL;
      ELSE
        PUSH message_parameters: [1 .. delimiter_count];
        setup_status_message_parameters (text, parameter_delimiter, message_parameters^);
      IFEND;
      format_message (actual_message_level, osc$standard_status_message_hdr, maximum_message_line - 1,
            message_status.condition, severity, template, message_parameters, NIL, parameter_delimiter,
            message, local_status);
      IF NOT local_status.normal THEN
        status := local_status;
      IFEND;
    IFEND;

    #KEYPOINT (osk$exit, 0, osk$format_message);

  PROCEND osp$format_message;
*IF NOT $true(osv$unix)
?? TITLE := 'osp$format_help_message', EJECT ??
*copyc osh$format_help_message

  PROCEDURE [XDCL, #GATE] osp$format_help_message
    (    message_template: ^ost$message_template;
         message_parameters: ^ost$message_parameters;
         max_message_line: ost$max_status_message_line;
     VAR message: ost$status_message;
     VAR status: ost$status);

    VAR
      maximum_message_line: ost$max_status_message_line;


    status.normal := TRUE;

    IF max_message_line < LOWERVALUE (ost$max_status_message_line) THEN
      maximum_message_line := LOWERVALUE (ost$max_status_message_line);
    ELSEIF max_message_line > UPPERVALUE (ost$max_status_message_line) THEN
      maximum_message_line := UPPERVALUE (ost$max_status_message_line);
    ELSE
      maximum_message_line := max_message_line;
    IFEND;

    format_message (osc$brief_message_level, osc$no_status_message_hdr, maximum_message_line - 1, 0,
          osc$informative_status, message_template, message_parameters, NIL, osc$status_parameter_delimiter,
          message, status);

  PROCEND osp$format_help_message;
*IFEND
?? TITLE := 'osp$generate_message', EJECT ??
*copyc osh$generate_message

  PROCEDURE [XDCL, #GATE] osp$generate_message ALIAS 'ospgmsg'
    (    message_status: ost$status;
     VAR status: ost$status);


    #KEYPOINT (osk$entry, 0, osk$generate_message);

*IF NOT $true(osv$unix)
    generate_message (clc$job_command_response, ^clp$put_job_command_response, osc$current_message_level,
*ELSE
    generate_message (clc$job_output, ^clp$put_job_command_response, osc$current_message_level,
*IFEND
          osc$standard_status_message_hdr, message_status, status);

    #KEYPOINT (osk$exit, 0, osk$generate_message);

  PROCEND osp$generate_message;
*IF NOT $true(osv$unix)
?? TITLE := 'osp$generate_error_message', EJECT ??
*copyc osh$generate_error_message

  PROCEDURE [XDCL, #GATE] osp$generate_error_message ALIAS 'ospgemg'
    (    message_status: ost$status;
     VAR status: ost$status);


    #KEYPOINT (osk$entry, 0, osk$generate_error_message);

    generate_message (clc$error_output, ^clp$put_error_output, osc$full_message_level,
          osc$standard_status_message_hdr, message_status, status);

    #KEYPOINT (osk$exit, 0, osk$generate_error_message);

  PROCEND osp$generate_error_message;
?? TITLE := 'osp$generate_log_message', EJECT ??
*copyc osh$generate_log_message

  PROCEDURE [XDCL, #GATE] osp$generate_log_message ALIAS 'ospglgm'
    (    logs: pmt$ascii_logset;
         message_status: ost$status;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      destination_logs: pmt$ascii_logset;

?? SKIP := 2 ??

    PROCEDURE put_log_line
      (    text: string ( * );
       VAR status: ost$status);


      pmp$log_ascii (text, destination_logs, pmc$msg_origin_system, status);

    PROCEND put_log_line;
?? SKIP := 2 ??

*IF NOT $true(osv$unix)
    #CALLER_ID (caller_id);
*ELSE
    caller_id.ring := osc$user_ring;
*IFEND
    status.normal := TRUE;

    IF (caller_id.ring > osc$tsrv_ring) THEN
      destination_logs := logs - $pmt$ascii_logset [pmc$system_log];
    ELSE
      destination_logs := logs;
    IFEND;

    IF destination_logs <> $pmt$ascii_logset [] THEN
      generate_message (osc$null_name, ^put_log_line, osc$full_message_level, osc$standard_status_message_hdr,
            message_status, status);
    IFEND;

  PROCEND osp$generate_log_message;
?? TITLE := 'osp$generate_output_message', EJECT ??
*copyc osh$generate_output_message

  PROCEDURE [XDCL, #GATE] osp$generate_output_message
    (    message_status: ost$status;
     VAR status: ost$status);


    generate_message (clc$job_output, ^clp$put_job_output, osc$current_message_level,
          osc$subdued_status_message_hdr, message_status, status);

  PROCEND osp$generate_output_message;
*IFEND
?? TITLE := 'generate_message', EJECT ??

  PROCEDURE generate_message
    (    local_file_name: amt$local_file_name;
         output_procedure: ^procedure (    text: string ( * );
                                       VAR status: ost$status);
         message_level: ost$format_message_level;
         message_header_kind: ost$status_message_header_kind;
         message_status: ost$status;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
?? NEWTITLE := 'abort_condition_handler', EJECT ??

    PROCEDURE abort_condition_handler
      (    condition: pmt$condition;
           run_time_status: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        run_time_message_status: ^ost$status,
        ignore_status: ost$status;


      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
        EXIT generate_message;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          run_time_message_status := run_time_status;
          status := run_time_message_status^;
          EXIT generate_message;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_condition_handler;
?? OLDTITLE, EJECT ??
*IFEND

    VAR
      actual_message_level: ost$status_message_level,
      delimiter_count: 0 .. osc$parameter_delimiter_limit,
*IF NOT $true(osv$unix)
      file_attributes: array [1 .. 1] of amt$fetch_item,
*IFEND
      file_id: amt$file_identifier,
      message: ost$status_message,
      message_area: ^ost$status_message,
      message_line: ^string ( * ),
      message_line_count: ^ost$status_message_line_count,
      message_line_index: 1 .. osc$max_status_message_lines,
      message_line_size: ^ost$status_message_line_size,
      message_parameters: ^ost$message_parameters,
      parameter_delimiter: char,
      severity: ost$status_severity,
      template: ^ost$message_template,
      text: ^ost$status_text;


    status.normal := TRUE;
*IF NOT $true(osv$unix)
    osp$establish_condition_handler (^abort_condition_handler, FALSE);

    file_attributes [1].key := amc$page_width;
    IF local_file_name = osc$null_name THEN
      file_attributes [1].page_width := osc$max_status_message_line;
    ELSE
*IFEND
      clp$get_system_file_id (local_file_name, file_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
*IF NOT $true(osv$unix)
      amp$fetch (file_id, file_attributes, status);
      IF (NOT status.normal) OR (file_attributes [1].page_width < osc$min_status_message_line) THEN
        file_attributes [1].page_width := osc$min_status_message_line;
      ELSEIF file_attributes [1].page_width > osc$max_status_message_line THEN
        file_attributes [1].page_width := osc$max_status_message_line;
      IFEND;
    IFEND;
*ELSE
    PUSH template: [256];
    template^ := ' ';
*IFEND

    message_area := ^message;
    RESET message_area;
    NEXT message_line_count IN message_area;

    IF message_status.normal THEN
      message_line_count^ := 0;
      RETURN;
    IFEND;

    setup_status_message_formatting (^message_status, message_level, actual_message_level, severity, text,
          delimiter_count, parameter_delimiter, template);
    IF delimiter_count = 0 THEN
      message_parameters := NIL;
    ELSE
      PUSH message_parameters: [1 .. delimiter_count];
      setup_status_message_parameters (text, parameter_delimiter, message_parameters^);
    IFEND;
*IF NOT $true(osv$unix)
    format_message (actual_message_level, message_header_kind, file_attributes [1].page_width - 1,
*ELSE
    format_message (actual_message_level, message_header_kind, 80,
*IFEND
          message_status.condition, severity, template, message_parameters, NIL, parameter_delimiter,
          message, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR message_line_index := 1 TO message_line_count^ DO
      NEXT message_line_size IN message_area;
      NEXT message_line: [message_line_size^] IN message_area;
      output_procedure^ (message_line^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND generate_message;
?? TITLE := 'osp$get_status_severity', EJECT ??
*copy osh$get_status_severity

  PROCEDURE [XDCL, #GATE] osp$get_status_severity ALIAS 'ospgss'
    (    condition: ost$status_condition;
     VAR severity: ost$status_severity;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      condition_name: ost$status_condition_name,
      message_module_severity: ost$message_module_severity,
      template: ^ost$message_template;


    #KEYPOINT (osk$entry, 0, osk$get_status_severity);

    status.normal := TRUE;

*IF $true(osv$unix)
    PUSH template: [256];
*IFEND
    get_template_info_via_code (condition, FALSE, condition_name, message_module_severity, template,
          local_status);
    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    severity := osp$convert_to_status_severity (message_module_severity);

    #KEYPOINT (osk$exit, 0, osk$get_status_severity);

  PROCEND osp$get_status_severity;
*IF NOT $true(osv$unix)
?? TITLE := 'osp$get_diagnostic_severity', EJECT ??
*copy osh$get_diagnostic_severity

  PROCEDURE [XDCL, #GATE] osp$get_diagnostic_severity ALIAS 'ospgss'
    (    condition: ost$status_condition;
     VAR severity: ost$diagnostic_severity;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      condition_name: ost$status_condition_name,
      message_module_severity: ost$message_module_severity,
      template: ^ost$message_template;


    #KEYPOINT (osk$entry, 1, osk$get_status_severity);

    status.normal := TRUE;

    get_template_info_via_code (condition, FALSE, condition_name, message_module_severity, template,
          local_status);
    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    severity := osp$convert_to_diagnos_severity (message_module_severity);

    #KEYPOINT (osk$exit, 1, osk$get_status_severity);

  PROCEND osp$get_diagnostic_severity;
?? TITLE := 'osp$get_status_message_by_code', EJECT ??
*copyc osh$get_status_message_by_code

  PROCEDURE [XDCL, #GATE] osp$get_status_message_by_code
    (    condition_code: ost$status_condition_code;
     VAR condition_name: ost$status_condition_name;
     VAR status_severity: ost$status_severity;
     VAR diagnostic_severity: ost$diagnostic_severity;
     VAR message_template: ^ost$message_template;
     VAR status: ost$status);

    VAR
      severity: ost$message_module_severity;


    status.normal := TRUE;

    get_template_info_via_code (condition_code, TRUE, condition_name, severity, message_template, status);

    status_severity := osp$convert_to_status_severity (severity);
    diagnostic_severity := osp$convert_to_diagnos_severity (severity);

  PROCEND osp$get_status_message_by_code;
*IFEND
?? TITLE := 'osp$get_status_condition_name', EJECT ??
*copyc osh$get_status_condition_name

  PROCEDURE [XDCL, #GATE] osp$get_status_condition_name ALIAS 'ospgscn'
    (    code: ost$status_condition_code;
     VAR name: ost$status_condition_name;
     VAR status: ost$status);

    VAR
      severity: ost$message_module_severity,
      template: ^ost$message_template;

    status.normal := TRUE;

*IF $true(osv$unix)
    PUSH template: [256];
*IFEND
    get_template_info_via_code (code, FALSE, name, severity, template, status);

  PROCEND osp$get_status_condition_name;
?? TITLE := 'osp$get_status_condition_code', EJECT ??
*copyc osh$get_status_condition_code

  PROCEDURE [XDCL, #GATE] osp$get_status_condition_code
    (    name: ost$status_condition_name;
     VAR code: ost$status_condition_code;
     VAR status: ost$status);

    VAR
      severity: ost$message_module_severity,
      template: ^ost$message_template;


    status.normal := TRUE;

*IF $true(osv$unix)
    PUSH template: [256];
*IFEND
    get_template_info_via_name (name, FALSE, code, severity, template, status);

  PROCEND osp$get_status_condition_code;
?? TITLE := 'osp$get_status_condition_string', EJECT ??
*copyc osh$get_status_condition_string

  PROCEDURE [XDCL, #GATE] osp$get_status_condition_string
    (    condition: ost$status_condition_code;
     VAR str: ost$string;
     VAR status: ost$status);

    VAR
      identifier: ost$status_identifier,
      number: ost$status_condition_number,
      str_length: integer,
      str_value: ost$name;


    status.normal := TRUE;

    osp$unpack_status_condition (condition, identifier, number);

    #SPOIL (identifier); { !!! NEEDED TO GET AROUND CYBIL INSTRUCTION SCHEDULING BUG !!! }

    IF (' ' <= identifier (1)) AND (identifier (1) <= '~') AND (' ' <= identifier (2)) AND (identifier (2) <=
          '~') THEN
      STRINGREP (str_value, str_length, identifier, number);
      str.size := str_length;
      str.value := str_value;
    ELSE
      clp$convert_integer_to_string (condition, 10, FALSE, str, status);
    IFEND;

  PROCEND osp$get_status_condition_string;
*IF NOT $true(osv$unix)
?? TITLE := 'osp$get_message_level', EJECT ??
*copyc osh$get_message_level

  PROCEDURE [XDCL, #GATE] osp$get_message_level
    (VAR message_level: ost$status_message_level;
     VAR status: ost$status);

    VAR
      message_level_ptr: ^ost$status_message_level;


    #KEYPOINT (osk$entry, 0, osk$get_message_level);

    status.normal := TRUE;

    osp$find_status_message_level (message_level_ptr);
    message_level := message_level_ptr^;

    #KEYPOINT (osk$exit, 0, osk$get_message_level);

  PROCEND osp$get_message_level;
*IF NOT $true(osv$unix)
?? TITLE := 'osp$log_system_status_message', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$log_system_status_message
    (    logs: pmt$ascii_logset;
         message_status: ost$status;
     VAR status: ost$status);

    VAR
      actual_message_level: ost$status_message_level,
      caller_id: ost$caller_identifier,
      delimiter_count: 0 .. osc$parameter_delimiter_limit,
      found: boolean,
      ignore_status: ost$status,
      language: ost$natural_language,
      message: ost$status_message,
      message_area: ^ost$status_message,
      message_line: ^string ( * ),
      message_line_count: ^ost$status_message_line_count,
      message_line_index: 1 .. osc$max_status_message_lines,
      message_line_size: ^ost$status_message_line_size,
      message_module: ^ost$message_template_module,
      message_parameters: ^ost$message_parameters,
      message_status_text_size: ost$string_size,
      name: ost$status_condition_name,
      parameter_delimiter: char,
      severity: ost$message_module_severity,
      status_severity: ost$status_severity,
      template: ^ost$message_template,
      text: ^ost$status_text,
      text_index: ost$string_index;

    osp$verify_system_privilege;
    status.normal := TRUE;
    #CALLER_ID (caller_id);

    IF (caller_id.ring <= osc$tsrv_ring) THEN
      IF (logs <> $pmt$ascii_logset []) AND (NOT message_status.normal) THEN
        language := osc$us_english;
        clp$get_system_message_mod_ptr (message_module);
        IF message_module <> NIL THEN
          clp$search_module_for_code (message_module, message_status.condition, language, name, severity,
                template, found, ignore_status);
          IF found THEN
            status_severity := osp$convert_to_status_severity (severity);
            message_area := ^message;
            RESET message_area;
            NEXT message_line_count IN message_area;

            IF message_status.text.size > osc$max_string_size THEN
              message_status_text_size := 0;
            ELSE
              message_status_text_size := message_status.text.size;
            IFEND;

            text := ^message_status.text.value (1, message_status_text_size);
            parameter_delimiter := message_status.text.value (1);
            delimiter_count := 0;
            FOR text_index := 1 TO message_status_text_size DO
              IF text^ (text_index) = parameter_delimiter THEN
                delimiter_count := delimiter_count + 1;
              IFEND;
            FOREND;

            IF delimiter_count = 0 THEN
              message_parameters := NIL;
            ELSE
              PUSH message_parameters: [1 .. delimiter_count];
              setup_status_message_parameters (text, parameter_delimiter, message_parameters^);
            IFEND;
            format_message (actual_message_level, osc$standard_status_message_hdr,
                  osc$max_status_message_line - 1, message_status.condition, status_severity, template,
                  message_parameters, {get_message_part} NIL, parameter_delimiter, message, status);
            IF status.normal THEN
              FOR message_line_index := 1 TO message_line_count^ DO
                NEXT message_line_size IN message_area;
                NEXT message_line: [message_line_size^] IN message_area;
                pmp$log_ascii (message_line^, logs, pmc$msg_origin_system, ignore_status);
              FOREND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND osp$log_system_status_message;
*IFEND
?? TITLE := 'osp$output_status_message', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$output_status_message
    (    file_id: amt$file_identifier;
         message_level: ost$format_message_level;
         message_header_kind: ost$status_message_header_kind;
         message_status: ost$status;
     VAR status: ost$status);

*copyc osh$output_status_message
?? NEWTITLE := 'abort_condition_handler', EJECT ??

    PROCEDURE abort_condition_handler
      (    condition: pmt$condition;
           run_time_status: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        run_time_message_status: ^ost$status,
        ignore_status: ost$status;


      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        osp$set_status_from_condition ('CL', condition, save_area, status, ignore_status);
        EXIT osp$output_status_message;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          run_time_message_status := run_time_status;
          status := run_time_message_status^;
          EXIT osp$output_status_message;
        IFEND;
      ELSE
        ;
      CASEND;

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

    PROCEND abort_condition_handler;
?? OLDTITLE, EJECT ??

    VAR
      actual_message_level: ost$status_message_level,
      byte_address: amt$file_byte_address,
      delimiter_count: 0 .. osc$parameter_delimiter_limit,
      file_attributes: array [1 .. 1] of amt$fetch_item,
      message: ost$status_message,
      message_area: ^ost$status_message,
      message_line: ^string ( * ),
      message_line_count: ^ost$status_message_line_count,
      message_line_index: 1 .. osc$max_status_message_lines,
      message_line_size: ^ost$status_message_line_size,
      message_parameters: ^ost$message_parameters,
      parameter_delimiter: char,
      severity: ost$status_severity,
      template: ^ost$message_template,
      text: ^ost$status_text;


    status.normal := TRUE;
    osp$establish_condition_handler (^abort_condition_handler, FALSE);

    file_attributes [1].key := amc$page_width;
    amp$fetch (file_id, file_attributes, status);
    IF (NOT status.normal) OR (file_attributes [1].page_width < osc$min_status_message_line) THEN
      file_attributes [1].page_width := osc$min_status_message_line;
    ELSEIF file_attributes [1].page_width > osc$max_status_message_line THEN
      file_attributes [1].page_width := osc$max_status_message_line;
    IFEND;

    message_area := ^message;
    RESET message_area;
    NEXT message_line_count IN message_area;

    IF message_status.normal THEN
      message_line_count^ := 0;
      RETURN;
    IFEND;

    setup_status_message_formatting (^message_status, message_level, actual_message_level, severity, text,
          delimiter_count, parameter_delimiter, template);
    IF delimiter_count = 0 THEN
      message_parameters := NIL;
    ELSE
      PUSH message_parameters: [1 .. delimiter_count];
      setup_status_message_parameters (text, parameter_delimiter, message_parameters^);
    IFEND;
    format_message (actual_message_level, message_header_kind, file_attributes [1].page_width - 1,
          message_status.condition, severity, template, message_parameters, NIL, parameter_delimiter,
          message, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR message_line_index := 1 TO message_line_count^ DO
      NEXT message_line_size IN message_area;
      NEXT message_line: [message_line_size^] IN message_area;
      amp$put_next (file_id, message_line, message_line_size^, byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND osp$output_status_message;
*IFEND

MODEND osm$system_message_generator;
*DECK DECK=OSM$SYSTEM_TASK_MAINT_113 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operating System : System Task Management - Ring 1' ??
MODULE osm$system_task_maint_113;

{ PURPOSE:
{   This module contains all procedures that access the system task table.
{
{   The system task table is a system-wide data structure that contains the definition and current status
{   of all system tasks.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc llt$program_description
*copyc osd$virtual_address
*copyc ose$system_task_exceptions
*copyc oss$mainframe_pageable
*copyc ost$name
*copyc ost$system_task_data_criteria
*copyc ost$system_task_display_data
*copyc ost$system_task_work_to_do
*copyc ost$termination_type
*copyc pme$execution_exceptions
*copyc pmt$spy_identifier
*copyc pmt$task_status
?? POP ??
*copyc osp$append_status_parameter
*copyc osp$clear_mainframe_sig_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osv$mainframe_pageable_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by this Module', EJECT ??

  TYPE
    ost$system_task_table_entry = record
      next_entry: ^ost$system_task_table_entry,
      task_name: ost$name,
      automatic_restart: boolean,
      deactivate_task_option: ost$termination_type,
      idle_task_option: ost$termination_type,
      restart_after_idle: boolean,
      spy_identifier: pmt$spy_identifier,
      execution_ring: ost$valid_ring,
      active: boolean,
      task_has_been_started: boolean,
      task_has_been_terminated: boolean,
      program_description: ^llt$program_description,
      parameters: ^clt$parameter_list,
      task_status: pmt$task_status
    recend;

{ NOTE: It is assumed that the program_description and parameters fields (and the values pointed to)
{       may NOT be changed while task_status.complete is FALSE.

  VAR
    system_task_table_lock: [oss$mainframe_pageable] ost$signature_lock := [0],
    system_task_table: [oss$mainframe_pageable] ^ost$system_task_table_entry := NIL;

?? OLDTITLE ??
?? NEWTITLE := 'find_system_task_entry', EJECT ??

{ PURPOSE:
{   The purpose of this request is to return a pointer to the system task table entry for a specified
{   system task.  A NIL pointer is returned if no entry exists for the task.
{ NOTES:
{   This request assumes the caller has interlocked the system task table.

  PROCEDURE find_system_task_entry
    (    name: ost$name;
     VAR entry: ^ost$system_task_table_entry);

    entry := system_task_table;
    WHILE entry <> NIL DO
      IF entry^.task_name = name THEN
        RETURN;
      IFEND;
      entry := entry^.next_entry;
    WHILEND;

  PROCEND find_system_task_entry;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$activate_system_task_r1', EJECT ??

{ PURPOSE:
{   The purpose of this request is to update the system task table when a system task is activated.
{ NOTES:
{   When called in the system job monitor task, this request returns the values needed to execute the
{   system task and updates the system task table to indicate that the task has been executed.  It is assumed
{   the caller will execute the system task.

  PROCEDURE [XDCL, #GATE] osp$activate_system_task_r1
    (    name: ost$name;
         system_job_monitor: boolean;
     VAR program_description: ^llt$program_description;
     VAR parameters: ^clt$parameter_list;
     VAR spy_identifier: pmt$spy_identifier;
     VAR execution_ring: ost$valid_ring;
     VAR status: ost$status);

    VAR
      entry: ^ost$system_task_table_entry;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (system_task_table_lock);
    find_system_task_entry (name, entry);
    IF entry = NIL THEN
      osp$set_status_abnormal ('  ', ose$system_task_not_defined, name, status);
    ELSEIF entry^.active THEN
      osp$set_status_abnormal ('  ', ose$system_task_active, name, status);
    ELSEIF NOT entry^.task_status.complete THEN
      osp$set_status_abnormal ('  ', ose$system_task_still_running, name, status);
    ELSEIF (entry^.task_name = 'CONSOLE_INTERACTION') AND (NOT system_job_monitor) THEN
      osp$set_status_abnormal ('  ', ose$task_not_under_oper_control, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'ACTIVATE_SYSTEM_TASK', status);
    ELSE
      entry^.active := TRUE;
      entry^.task_has_been_started := FALSE;
      IF system_job_monitor THEN

{ The following code must modify the system task table entry in EXACTLY the same way as does
{ osp$scan_system_table when it finds a task to be executed.

        entry^.task_status.complete := FALSE;
        entry^.task_has_been_terminated := FALSE;
        entry^.task_has_been_started := TRUE;
        program_description := entry^.program_description;
        parameters := entry^.parameters;
        spy_identifier := entry^.spy_identifier;
        execution_ring := entry^.execution_ring;
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (system_task_table_lock);

  PROCEND osp$activate_system_task_r1;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE, UNSAFE] osp$active_system_task_r1', EJECT ??

{ PURPOSE:
{   The purpose of this function is to return a boolean value indicating whether a specified system task
{   is defined and active.

  FUNCTION [XDCL, #GATE, UNSAFE] osp$active_system_task_r1
    (    task_name: ost$name): boolean;

    VAR
      entry: ^ost$system_task_table_entry;

    osp$set_mainframe_sig_lock (system_task_table_lock);
    find_system_task_entry (task_name, entry);
    osp$clear_mainframe_sig_lock (system_task_table_lock);
    IF entry = NIL THEN
      osp$active_system_task_r1 := FALSE;
    ELSE
      osp$active_system_task_r1 := entry^.active;
    IFEND;

  FUNCEND osp$active_system_task_r1;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$deactivate_system_task_r1', EJECT ??

{ PURPOSE:
{   The purpose of this request is to update the system task table when a system task is deactivated.

  PROCEDURE [XDCL, #GATE] osp$deactivate_system_task_r1
    (    name: ost$name;
         system_job_monitor: boolean;
     VAR status: ost$status);

    VAR
      entry: ^ost$system_task_table_entry;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (system_task_table_lock);
    find_system_task_entry (name, entry);
    IF entry = NIL THEN
      osp$set_status_abnormal ('  ', ose$system_task_not_defined, name, status);
    ELSEIF NOT entry^.active THEN
      osp$set_status_abnormal ('  ', ose$system_task_not_active, name, status);
    ELSEIF entry^.deactivate_task_option = osc$tt_ignore_or_prohibited THEN
      osp$set_status_abnormal ('  ', ose$task_not_under_oper_control, name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'DEACTIVATE_SYSTEM_TASK', status);
    ELSE
      entry^.active := FALSE;
      IF system_job_monitor THEN

{ The following code must modify the system task table entry in EXACTLY the same way as does
{ osp$scan_system_table when it finds a task to be terminated.

        entry^.task_has_been_terminated := TRUE;
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (system_task_table_lock);

  PROCEND osp$deactivate_system_task_r1;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$define_system_task_r1', EJECT ??

{ PURPOSE:
{   The purpose of this request is to update the system task table when a system task is defined.

  PROCEDURE [XDCL, #GATE] osp$define_system_task_r1
    (    name: ost$name;
         automatic_restart: boolean;
         deactivate_task_option: ost$termination_type;
         idle_task_option: ost$termination_type;
         restart_after_idle: boolean;
         spy_identifier: pmt$spy_identifier;
         execution_ring: ost$valid_ring;
         program_description: ^llt$program_description;
         parameters: ^clt$parameter_list;
     VAR status: ost$status);

    VAR
      entry: ^ost$system_task_table_entry,
      existing_entry: ^ost$system_task_table_entry;

    status.normal := TRUE;

{ Allocate and initialize a new system task table entry.

    ALLOCATE entry IN osv$mainframe_pageable_heap^;
    entry^.task_name := name;
    entry^.automatic_restart := automatic_restart;
    entry^.deactivate_task_option := deactivate_task_option;
    entry^.idle_task_option := idle_task_option;
    entry^.restart_after_idle := restart_after_idle;
    entry^.spy_identifier := spy_identifier;
    entry^.execution_ring := execution_ring;
    entry^.active := FALSE;
    ALLOCATE entry^.program_description: [[REP (#SIZE (program_description^)) OF cell]] IN
          osv$mainframe_pageable_heap^;
    entry^.program_description^ := program_description^;
    ALLOCATE entry^.parameters: [[REP (#SIZE (parameters^)) OF cell]] IN osv$mainframe_pageable_heap^;
    entry^.parameters^ := parameters^;
    entry^.task_status.complete := TRUE;
    entry^.task_status.status.normal := TRUE;

{ Verify that the system task name is unique and link the new entry into the system task table.

    osp$set_mainframe_sig_lock (system_task_table_lock);
    find_system_task_entry (name, existing_entry);
    IF existing_entry = NIL THEN
      entry^.next_entry := system_task_table;
      system_task_table := entry;
    IFEND;
    osp$clear_mainframe_sig_lock (system_task_table_lock);

    IF existing_entry <> NIL THEN
      osp$set_status_abnormal ('  ', ose$system_task_already_defined, name, status);
      FREE entry IN osv$mainframe_pageable_heap^;
    IFEND;

  PROCEND osp$define_system_task_r1;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$delete_system_task_r1', EJECT ??

{ PURPOSE:
{   The purpose of this request is to update the system task table when a system task is deleted.

  PROCEDURE [XDCL, #GATE] osp$delete_system_task_r1
    (    name: ost$name;
     VAR task_executing: boolean;
     VAR status: ost$status);

    VAR
      entry: ^ost$system_task_table_entry,
      ptr_to_entry: ^^ost$system_task_table_entry;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (system_task_table_lock);

    entry := system_task_table;
    ptr_to_entry := ^system_task_table;
    WHILE (entry <> NIL) AND (entry^.task_name <> name) DO
      ptr_to_entry := ^entry^.next_entry;
      entry := entry^.next_entry;
    WHILEND;

    IF entry = NIL THEN
      osp$set_status_abnormal ('  ', ose$system_task_not_defined, name, status);
    ELSEIF entry^.active THEN
      osp$set_status_abnormal ('  ', ose$system_task_active, name, status);
    ELSEIF entry^.task_status.complete THEN
      task_executing := FALSE;
      ptr_to_entry^ := entry^.next_entry;
    ELSE
      task_executing := TRUE;
    IFEND;
    osp$clear_mainframe_sig_lock (system_task_table_lock);

    IF status.normal AND (task_executing = FALSE) THEN
      FREE entry IN osv$mainframe_pageable_heap^;
    IFEND;

  PROCEND osp$delete_system_task_r1;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$get_running_system_tasks', EJECT ??

{ PURPOSE:
{   The purpose of this request is to return the names of all executing system tasks.
{ NOTES:
{   This request assumes that it is called while the system is being idled.  The termination status of any
{   system task that was terminated by its parent (the system job monitor task) is changed to indicate that
{   the task was terminated due to a system idle request.  The task will then be restarted when the system
{   is resumed.

  PROCEDURE [XDCL, #GATE] osp$get_running_system_tasks
    (VAR running_tasks: array [1 .. * ] of ost$name;
     VAR number_of_running_tasks: integer);

    VAR
      entry: ^ost$system_task_table_entry;

    number_of_running_tasks := 0;
    osp$set_mainframe_sig_lock (system_task_table_lock);
    entry := system_task_table;
    WHILE entry <> NIL DO
      IF (entry^.idle_task_option = osc$tt_terminate) AND (NOT entry^.task_status.complete) THEN
        number_of_running_tasks := number_of_running_tasks + 1;
        IF number_of_running_tasks <= UPPERBOUND (running_tasks) THEN
          running_tasks [number_of_running_tasks] := entry^.task_name;
        IFEND;
      ELSEIF (entry^.idle_task_option = osc$tt_terminate) AND entry^.task_status.complete AND
            (NOT entry^.task_status.status.normal AND (entry^.task_status.status.condition =
            pme$terminated_by_parent)) THEN
        entry^.task_status.status.condition := ose$terminated_by_idle_system;
      IFEND;
      entry := entry^.next_entry;
    WHILEND;
    osp$clear_mainframe_sig_lock (system_task_table_lock);

  PROCEND osp$get_running_system_tasks;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL,#GATE] osp$get_system_task_data_r1', EJECT ??

{ PURPOSE:
{   The purpose of this request is to return display information for one or all system tasks.
{ NOTES:
{   If display information is requested for all tasks, this request always returns a count of the number of
{   executing system tasks.  This allows the caller to allocate a data structure sufficiently large to hold
{   display information for all tasks.

  PROCEDURE [XDCL, #GATE] osp$get_system_task_data_r1
    (    criteria: ost$system_task_data_criteria;
     VAR system_task_data: ost$system_task_display_data;
     VAR system_task_count: integer;
     VAR status: ost$status);

    VAR
      entry: ^ost$system_task_table_entry;

    status.normal := TRUE;
    system_task_count := 0;
    osp$set_mainframe_sig_lock (system_task_table_lock);
    entry := system_task_table;

  /scan_system_task_table/
    WHILE entry <> NIL DO
      IF (criteria.all_tasks) OR (entry^.task_name = criteria.task_name) THEN
        system_task_count := system_task_count + 1;
        IF system_task_count <= UPPERBOUND (system_task_data) THEN
          system_task_data [system_task_count].task_name := entry^.task_name;
          system_task_data [system_task_count].automatic_restart := entry^.automatic_restart;
          system_task_data [system_task_count].deactivate_task_option := entry^.deactivate_task_option;
          system_task_data [system_task_count].idle_task_option := entry^.idle_task_option;
          system_task_data [system_task_count].restart_after_idle := entry^.restart_after_idle;
          system_task_data [system_task_count].spy_identifier := entry^.spy_identifier;
          system_task_data [system_task_count].execution_ring := entry^.execution_ring;
          system_task_data [system_task_count].active := entry^.active;
          system_task_data [system_task_count].task_status := entry^.task_status;
        IFEND;
        IF NOT criteria.all_tasks THEN
          EXIT /scan_system_task_table/;
        IFEND;
      IFEND;
      entry := entry^.next_entry;
    WHILEND /scan_system_task_table/;
    osp$clear_mainframe_sig_lock (system_task_table_lock);
    IF (NOT criteria.all_tasks) AND (system_task_count = 0) THEN
      osp$set_status_abnormal ('  ', ose$system_task_not_defined, criteria.task_name, status);
    IFEND;

  PROCEND osp$get_system_task_data_r1;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$scan_system_task_table', EJECT ??

{ PURPOSE:
{   The purpose of this request is to scan the system task table to determine whether there is an action that
{   needs to be performed.  If an action is required, it must be performed in ring 3; the request returns a
{   valuing indicating the action to be performed and updates the data structure assuming that the action
{   will be performed.
{ NOTES:
{   This procedure assumes that the program_description and parameters pointers in a system task table entry
{   may not be changed while the value of task_status.complete is FALSE.  This assumption allows these
{   pointers to be (returned to and) used by ring 3 while the system task table is NOT locked.  This
{   assumption is currently satisfied by the fact that a system task table entry cannot be deleted while
{   task_status.complete is FALSE.

  PROCEDURE [XDCL, #GATE] osp$scan_system_task_table
    (VAR work_to_do: ost$system_task_work_to_do);

    VAR
      entry: ^ost$system_task_table_entry;

    work_to_do.kind := osc$st_no_work_to_do;
    work_to_do.log_task_status := FALSE;
    osp$set_mainframe_sig_lock (system_task_table_lock);
    entry := system_task_table;
    WHILE (entry <> NIL) AND (work_to_do.kind = osc$st_no_work_to_do) DO
      IF entry^.active THEN
        IF entry^.task_status.complete THEN
          work_to_do.task_name := entry^.task_name;
          IF (NOT entry^.task_has_been_started) OR (entry^.automatic_restart AND
                (entry^.task_status.status.normal OR (entry^.task_status.status.condition <>
                ose$terminated_by_idle_system))) OR (entry^.restart_after_idle AND
                (NOT entry^.task_status.status.normal AND (entry^.task_status.status.condition =
                ose$terminated_by_idle_system))) THEN

{ Task needs to be (re)started.

            work_to_do.kind := osc$st_execute_task;
            IF entry^.task_has_been_started AND (entry^.task_status.status.normal OR
                  ((entry^.task_status.status.condition <> pme$terminated_by_parent) AND
                  (entry^.task_status.status.condition <> ose$terminated_by_idle_system))) THEN
              work_to_do.log_task_status := TRUE;
              work_to_do.task_status := entry^.task_status.status;
            IFEND;

            entry^.task_status.complete := FALSE;
            entry^.task_has_been_terminated := FALSE;
            work_to_do.first_execution := NOT entry^.task_has_been_started;
            entry^.task_has_been_started := TRUE;
            work_to_do.spy_identifier := entry^.spy_identifier;
            work_to_do.execution_ring := entry^.execution_ring;
            work_to_do.program_description := entry^.program_description;
            work_to_do.parameters := entry^.parameters;

          ELSE

{ Task has completed, but is not to be restarted.  Notify the operator and deactivate the task so that
{ the operator can activate (manually restart) or delete the task.

            work_to_do.kind := osc$st_deactivate_task;
            IF NOT entry^.task_status.status.normal THEN
              work_to_do.log_task_status := TRUE;
              work_to_do.task_status := entry^.task_status.status;
            IFEND;
            entry^.active := FALSE;
          IFEND;
        IFEND;
      ELSE

{ Task has been deactivated.  If the task is still executing and has not already been terminated,
{ then terminate it.

        IF (NOT entry^.task_status.complete) AND (entry^.deactivate_task_option = osc$tt_terminate) AND
              (NOT entry^.task_has_been_terminated) THEN
          work_to_do.kind := osc$st_terminate_task;
          work_to_do.task_name := entry^.task_name;
          entry^.task_has_been_terminated := TRUE;
        IFEND;

      IFEND;
      entry := entry^.next_entry;
    WHILEND;
    osp$clear_mainframe_sig_lock (system_task_table_lock);

  PROCEND osp$scan_system_task_table;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$set_system_task_restart', EJECT ??

{ PURPOSE:
{   The purpose of this request is to update the automatic_restart field in the system task table
{   entry for a specified system task.

  PROCEDURE [XDCL, #GATE] osp$set_system_task_restart
    (    name: ost$name;
         automatic_restart: boolean;
     VAR status: ost$status);

    VAR
      entry: ^ost$system_task_table_entry;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (system_task_table_lock);
    find_system_task_entry (name, entry);
    IF entry = NIL THEN
      osp$set_status_abnormal ('  ', ose$system_task_not_defined, name, status);
    ELSE
      entry^.automatic_restart := automatic_restart;
    IFEND;
    osp$clear_mainframe_sig_lock (system_task_table_lock);

  PROCEND osp$set_system_task_restart;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$store_system_task_status', EJECT ??

{ PURPOSE:
{   The purpose of this request is to update the system task table when a system task completes
{   execution.  The task's termination status is stored in the table so that it may be displayed and
{   acted upon (by osp$scan_system_task_table).

  PROCEDURE [XDCL, #GATE] osp$store_system_task_status
    (    name: ost$name;
         status: ost$status);

    VAR
      entry: ^ost$system_task_table_entry;

    osp$set_mainframe_sig_lock (system_task_table_lock);
    find_system_task_entry (name, entry);
    IF entry = NIL THEN
      osp$system_error ('System task tables out of synch', NIL);
    IFEND;
    entry^.task_status.status := status;
    entry^.task_status.complete := TRUE;
    osp$clear_mainframe_sig_lock (system_task_table_lock);

  PROCEND osp$store_system_task_status;
?? OLDTITLE ??
MODEND osm$system_task_maint_113;





*DECK DECK=OSM$SYSTEM_TASK_MAINT_23D EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operating System : System Task Management - Ring 3' ??
MODULE osm$system_task_maint_23d;

{ PURPOSE:
{   This module contains the procedures that manage the definition and execution of system tasks.
{
{   All procedures that access the system task execution table reside in this module.  The system task
{   execution table contains the task_id and task_status variable for each executing system tasks.
{   The task status variable cannot reside in the (ring 1) system task table since this variable is
{   written by (ring 3) task termination code.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc jme$queued_file_conditions
*copyc loc$task_services_library_name
*copyc ofe$error_codes
*copyc ose$system_task_exceptions
*copyc oss$task_shared
*copyc ost$name
*copyc pmt$task_id
*copyc pmt$task_status
?? POP ??
*copyc avp$ring_min
*copyc avp$system_displays
*copyc avp$system_operator
*copyc clp$convert_string_to_file
*copyc clp$log_comment
*copyc clp$put_job_command_response
*copyc jmp$system_job
*copyc osp$activate_system_task_r1
*copyc osp$active_system_task_r1
*copyc osp$clear_job_signature_lock
*copyc osp$copy_local_status_to_status
*copyc osp$deactivate_system_task_r1
*copyc osp$define_system_task_r1
*copyc osp$delete_system_task_r1
*copyc osp$executing_in_job_monitor
*copyc osp$get_system_task_data_r1
*copyc osp$scan_system_task_table
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$store_system_task_status
*copyc osp$system_error
*copyc osv$task_shared_heap
*copyc pmp$execute_with_less_privilege
*copyc pmp$get_task_id
*copyc pmp$log
*copyc pmp$set_spy_identifier
*copyc pmp$terminate_task_without_wait
*copyc tmp$ready_system_task1
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by this Module', EJECT ??

  TYPE
    ost$system_task_execution_entry = record
      next_entry: ^ost$system_task_execution_entry,
      task_name: ost$name,
      task_id: pmt$task_id,
      task_status: pmt$task_status
    recend;

  VAR
    system_task_execution_lock: [oss$task_shared] ost$signature_lock := [0],
    system_task_execution_table: [oss$task_shared] ^ost$system_task_execution_entry := NIL;

?? OLDTITLE ??
?? NEWTITLE := 'convert_program_description', EJECT ??

{ PURPOSE:
{   The purpose of this request is to convert a program description from type llt$program_description
{   to type pmt$program_description.
{ NOTES:
{   The conversion consists of converting each file path name to a file path handle.
{
{   This request assumes that its caller has allocated a pmt$program_description of sufficient size to
{   contain the converted program description.

  PROCEDURE convert_program_description
    (    original_program_description: ^llt$program_description;
         converted_program_description: ^pmt$program_description;
     VAR status: ost$status);

    VAR
      enable_inhibit_conditions: ^pmt$enable_inhibit_conditions,
      file_index: 1 .. pmc$max_object_file_list,
      library_enable_inhib_conditions: ^pmt$enable_inhibit_conditions,
      library_index: 1 .. pmc$max_library_list,
      library_module_list: ^pmt$module_list,
      library_object_file_list: ^llt$object_file_list,
      library_object_library_list: ^llt$object_library_list,
      library_program_attributes: ^llt$program_attributes,
      library_program_description: ^llt$program_description,
      module_list: ^pmt$module_list,
      object_file_list: ^pmt$object_file_list,
      object_library_list: ^pmt$object_library_list,
      program_attributes: ^pmt$program_attributes,
      program_description: ^pmt$program_description,
      program_file: clt$file;

    status.normal := TRUE;
    library_program_description := original_program_description;
    RESET library_program_description;
    NEXT library_program_attributes IN library_program_description;
    program_description := converted_program_description;
    RESET program_description;
    NEXT program_attributes IN program_description;

    program_attributes^.contents := library_program_attributes^.contents;
    IF pmc$starting_proc_specified IN program_attributes^.contents THEN
      program_attributes^.starting_procedure := library_program_attributes^.starting_procedure;
    IFEND;

    IF pmc$object_file_list_specified IN program_attributes^.contents THEN
      program_attributes^.number_of_object_files := library_program_attributes^.number_of_object_files;
      NEXT library_object_file_list: [1 .. program_attributes^.number_of_object_files] IN
            library_program_description;
      NEXT object_file_list: [1 .. program_attributes^.number_of_object_files] IN program_description;
      FOR file_index := 1 TO program_attributes^.number_of_object_files DO
        clp$convert_string_to_file (library_object_file_list^ [file_index], program_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        object_file_list^ [file_index] := program_file.local_file_name;
      FOREND;
    IFEND;

    IF pmc$module_list_specified IN program_attributes^.contents THEN
      program_attributes^.number_of_modules := library_program_attributes^.number_of_modules;
      NEXT library_module_list: [1 .. program_attributes^.number_of_modules] IN library_program_description;
      NEXT module_list: [1 .. program_attributes^.number_of_modules] IN program_description;
      module_list^ := library_module_list^;
    IFEND;

    IF pmc$library_list_specified IN program_attributes^.contents THEN
      program_attributes^.number_of_libraries := library_program_attributes^.number_of_libraries;
      NEXT library_object_library_list: [1 .. program_attributes^.number_of_libraries] IN
            library_program_description;
      NEXT object_library_list: [1 .. program_attributes^.number_of_libraries] IN program_description;
      FOR library_index := 1 TO program_attributes^.number_of_libraries DO
        IF library_object_library_list^ [library_index] = loc$task_services_library_name THEN
          object_library_list^ [library_index] := loc$task_services_library_name;
        ELSE
          clp$convert_string_to_file (library_object_library_list^ [library_index], program_file, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          object_library_list^ [library_index] := program_file.local_file_name;
        IFEND;
      FOREND;
    IFEND;

    IF pmc$condition_specified IN program_attributes^.contents THEN
      NEXT library_enable_inhib_conditions IN library_program_description;
      NEXT enable_inhibit_conditions IN program_description;
      enable_inhibit_conditions^ := library_enable_inhib_conditions^;
    IFEND;

    IF pmc$load_map_file_specified IN program_attributes^.contents THEN
      clp$convert_string_to_file (library_program_attributes^.load_map_file, program_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      program_attributes^.load_map_file := program_file.local_file_name;
    IFEND;

    IF pmc$load_map_options_specified IN program_attributes^.contents THEN
      program_attributes^.load_map_options := library_program_attributes^.load_map_options;
    IFEND;

    IF pmc$term_error_level_specified IN program_attributes^.contents THEN
      program_attributes^.termination_error_level := library_program_attributes^.termination_error_level;
    IFEND;

    IF pmc$preset_specified IN program_attributes^.contents THEN
      program_attributes^.preset := library_program_attributes^.preset;
    IFEND;

    IF pmc$max_stack_size_specified IN program_attributes^.contents THEN
      program_attributes^.maximum_stack_size := library_program_attributes^.maximum_stack_size;
    IFEND;

    IF pmc$debug_input_specified IN program_attributes^.contents THEN
      clp$convert_string_to_file (library_program_attributes^.debug_input, program_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      program_attributes^.debug_input := program_file.local_file_name;
    IFEND;

    IF pmc$debug_output_specified IN program_attributes^.contents THEN
      clp$convert_string_to_file (library_program_attributes^.debug_output, program_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      program_attributes^.debug_output := program_file.local_file_name;
    IFEND;

    IF pmc$abort_file_specified IN program_attributes^.contents THEN
      clp$convert_string_to_file (library_program_attributes^.abort_file, program_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      program_attributes^.abort_file := program_file.local_file_name;
    IFEND;

    IF pmc$debug_mode_specified IN program_attributes^.contents THEN
      program_attributes^.debug_mode := library_program_attributes^.debug_mode;
    IFEND;

  PROCEND convert_program_description;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$activate_system_task', EJECT ??
*copyc osh$activate_system_task

  PROCEDURE [XDCL, #GATE] osp$activate_system_task
    (    name: ost$name;
     VAR status: ost$status);

    VAR
      execution_ring: ost$valid_ring,
      local_name: ost$name,
      local_status: ost$status,
      parameters: ^clt$parameter_list,
      program_description: ^llt$program_description,
      spy_identifier: pmt$spy_identifier,
      system_job_monitor: boolean;

    status.normal := TRUE;
    IF NOT avp$system_operator () THEN
      osp$set_status_abnormal ('  ', ofe$sou_not_active, 'SYSTEM_OPERATION', status);
      RETURN;
    IFEND;

    local_name := name;
    system_job_monitor := jmp$system_job () AND osp$executing_in_job_monitor ();
    osp$activate_system_task_r1 (local_name, system_job_monitor, program_description, parameters,
          spy_identifier, execution_ring, local_status);
    IF local_status.normal THEN

{ If the system job monitor task is activating the task, then execute the task immediately.
{ Otherwise, ready the system job monitor task so that it may execute the activated task.

      IF system_job_monitor THEN
        osp$execute_system_task (name, program_description, parameters, spy_identifier, execution_ring,
              local_status);
      ELSE
        tmp$ready_system_task (tmc$stid_job_monitor, local_status);
      IFEND;
    IFEND;
    osp$copy_local_status_to_status (local_status, status);

  PROCEND osp$activate_system_task;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE, UNSAFE] osp$active_system_task', EJECT ??

{ PURPOSE:
{   The purpose of this function is to return a boolean value indicating whether the executing task
{   is an active system task.

  FUNCTION [XDCL, #GATE, UNSAFE] osp$active_system_task: boolean;

    VAR
      entry: ^ost$system_task_execution_entry,
      ignored_status: ost$status,
      task_id: pmt$task_id;

    osp$active_system_task := FALSE;

{ If the executing task is not in the system job, it cannot be a system task.

    IF NOT jmp$system_job () THEN
      RETURN;
    IFEND;

{ Get the system task name of the executing task.

    pmp$get_task_id (task_id, ignored_status);
    osp$set_job_signature_lock (system_task_execution_lock);
    entry := system_task_execution_table;
    WHILE (entry <> NIL) AND (entry^.task_id <> task_id) DO
      entry := entry^.next_entry;
    WHILEND;
    osp$clear_job_signature_lock (system_task_execution_lock);
    IF entry = NIL THEN
      RETURN;
    IFEND;

{ Check the system task table to see if the system task has been deactivated.

    osp$active_system_task := osp$active_system_task_r1 (entry^.task_name);

  FUNCEND osp$active_system_task;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] osp$check_sys_task_completions', EJECT ??

{ PURPOSE:
{   The purpose of this request is to check to task_status variables of all executing system tasks to
{   determine if any task has terminated.  If a task has terminated, its termination status is recorded
{   in the system task table.
{ NOTES:
{   This request should only be called in the system job.  It is a no-op if called in another job.

  PROCEDURE [XDCL] osp$check_sys_task_completions;

    VAR
      entry: ^ost$system_task_execution_entry,
      ptr_to_entry: ^^ost$system_task_execution_entry;

    osp$set_job_signature_lock (system_task_execution_lock);
    entry := system_task_execution_table;
    ptr_to_entry := ^system_task_execution_table;
    WHILE entry <> NIL DO
      IF entry^.task_status.complete THEN
        osp$store_system_task_status (entry^.task_name, entry^.task_status.status);
        ptr_to_entry^ := entry^.next_entry;
        FREE entry IN osv$task_shared_heap^;
        entry := ptr_to_entry^;
      ELSE
        ptr_to_entry := ^entry^.next_entry;
        entry := entry^.next_entry;
      IFEND;
    WHILEND;
    osp$clear_job_signature_lock (system_task_execution_lock);

  PROCEND osp$check_sys_task_completions;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$deactivate_system_task', EJECT ??
*copyc osh$deactivate_system_task

  PROCEDURE [XDCL, #GATE] osp$deactivate_system_task
    (    name: ost$name;
     VAR status: ost$status);

    VAR
      local_name: ost$name,
      local_status: ost$status,
      system_job_monitor: boolean;

    status.normal := TRUE;
    IF NOT avp$system_operator () THEN
      osp$set_status_abnormal ('  ', ofe$sou_not_active, 'SYSTEM_OPERATION', status);
      RETURN;
    IFEND;

    local_name := name;
    system_job_monitor := jmp$system_job () AND osp$executing_in_job_monitor ();
    osp$deactivate_system_task_r1 (local_name, system_job_monitor, local_status);
    IF local_status.normal THEN

{ If the system job monitor task is deactivating the task, then terminate the task immediately.
{ Otherwise, ready the system job monitor task so that it may terminate the deactivated task.

      IF system_job_monitor THEN
        osp$terminate_system_task (name);
      ELSE
        tmp$ready_system_task (tmc$stid_job_monitor, local_status);
      IFEND;
    IFEND;
    osp$copy_local_status_to_status (local_status, status);

  PROCEND osp$deactivate_system_task;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$define_system_task', EJECT ??
*copyc osh$define_system_task

  PROCEDURE [XDCL, #GATE] osp$define_system_task
    (    name: ost$name;
         automatic_restart: boolean;
         deactivate_task_option: ost$termination_type;
         idle_task_option: ost$termination_type;
         restart_after_idle: boolean;
         spy_identifier: pmt$spy_identifier;
         execution_ring: ost$valid_ring;
         program_description: ^llt$program_description;
         parameters: ^clt$parameter_list;
     VAR status: ost$status);

    VAR
      local_automatic_restart: boolean,
      local_deactivate_task_option: ost$termination_type,
      local_execution_ring: ost$valid_ring,
      local_idle_task_option: ost$termination_type,
      local_name: ost$name,
      local_parameters: ^clt$parameter_list,
      local_program_description: ^llt$program_description,
      local_restart_after_idle: boolean,
      local_spy_identifier: pmt$spy_identifier,
      local_status: ost$status;

    status.normal := TRUE;
    IF NOT avp$system_operator () THEN
      osp$set_status_abnormal ('  ', ofe$sou_not_active, 'SYSTEM_OPERATION', status);
      RETURN;
    ELSEIF execution_ring < avp$ring_min () THEN
      osp$set_status_abnormal ('  ', ose$exec_ring_below_min_ring, '', status);
      RETURN;
    IFEND;

    local_name := name;
    local_automatic_restart := automatic_restart;
    local_deactivate_task_option := deactivate_task_option;
    local_idle_task_option := idle_task_option;
    local_restart_after_idle := restart_after_idle;
    local_spy_identifier := spy_identifier;
    local_execution_ring := execution_ring;
    IF program_description = NIL THEN
      local_program_description := NIL;
    ELSE
      PUSH local_program_description: [[REP #SIZE (program_description^) OF cell]];
      local_program_description^ := program_description^;
    IFEND;
    IF parameters = NIL THEN
      local_parameters := NIL;
    ELSE
      PUSH local_parameters: [[REP #SIZE (parameters^) OF cell]];
      local_parameters^ := parameters^;
    IFEND;
    osp$define_system_task_r1 (local_name, local_automatic_restart, local_deactivate_task_option,
          local_idle_task_option, local_restart_after_idle, local_spy_identifier, local_execution_ring,
          local_program_description, local_parameters, local_status);
    osp$copy_local_status_to_status (local_status, status);

  PROCEND osp$define_system_task;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$delete_system_task', EJECT ??
*copyc osh$delete_system_task

  PROCEDURE [XDCL, #GATE] osp$delete_system_task
    (    name: ost$name;
     VAR status: ost$status);

    CONST
      one_half_second = 500;

    VAR
      endtime: integer,
      local_name: ost$name,
      local_status: ost$status,
      task_executing: boolean;

    status.normal := TRUE;
    IF NOT avp$system_operator () THEN
      osp$set_status_abnormal ('  ', ofe$sou_not_active, 'SYSTEM_OPERATION', status);
      RETURN;
    IFEND;

{ Wait up to 20 seconds for task to complete if it is still executing.

    local_name := name;
    endtime := #FREE_RUNNING_CLOCK (0) + 20000000;
    REPEAT
      osp$delete_system_task_r1 (local_name, task_executing, local_status);
      IF NOT local_status.normal THEN
        osp$copy_local_status_to_status (local_status, status);
        RETURN;
      ELSEIF NOT task_executing THEN
        RETURN;
      IFEND;
    UNTIL endtime < #FREE_RUNNING_CLOCK (0);

    osp$set_status_abnormal ('  ', ose$system_task_still_running, name, status);

  PROCEND osp$delete_system_task;
?? OLDTITLE ??
?? NEWTITLE := 'osp$execute_system_task', EJECT ??

{ PURPOSE:
{   The purpose of this request is to execute a system task.
{ NOTES:
{   This request must be called only in the system job monitor task.

  PROCEDURE osp$execute_system_task
    (    name: ost$name;
         program_description: ^llt$program_description;
         parameters: ^clt$parameter_list;
         spy_identifier: pmt$spy_identifier;
         execution_ring: ost$valid_ring;
     VAR status: ost$status);

    VAR
      condition_count: 0 .. 1,
      converted_program_description: ^pmt$program_description,
      entry: ^ost$system_task_execution_entry,
      file_count: 0 .. pmc$max_object_file_list,
      ignored_status: ost$status,
      library_count: 0 .. pmc$max_library_list,
      module_count: 0 .. pmc$max_module_list,
      original_program_attributes: ^llt$program_attributes,
      original_program_description: ^llt$program_description;

    status.normal := TRUE;

{ Allocate and initialize a new system task execution table entry.

    ALLOCATE entry IN osv$task_shared_heap^;
    entry^.task_name := name;

{ Convert program description to the form required by pmp$execute_task.

    original_program_description := program_description;
    RESET original_program_description;
    NEXT original_program_attributes IN original_program_description;
    IF pmc$object_file_list_specified IN original_program_attributes^.contents THEN
      file_count := original_program_attributes^.number_of_object_files;
    ELSE
      file_count := 0;
    IFEND;
    IF pmc$module_list_specified IN original_program_attributes^.contents THEN
      module_count := original_program_attributes^.number_of_modules;
    ELSE
      module_count := 0;
    IFEND;
    IF pmc$library_list_specified IN original_program_attributes^.contents THEN
      library_count := original_program_attributes^.number_of_libraries;
    ELSE
      library_count := 0;
    IFEND;
    IF pmc$condition_specified IN original_program_attributes^.contents THEN
      condition_count := 1;
    ELSE
      condition_count := 0;
    IFEND;
    PUSH converted_program_description: [[REP #SIZE (pmt$program_attributes) +
          (file_count * #SIZE (amt$local_file_name)) + (module_count *
          #SIZE (pmt$program_name)) + (library_count * #SIZE (amt$local_file_name)) +
          (condition_count * #SIZE (pmt$enable_inhibit_conditions)) OF cell]];
    convert_program_description (original_program_description, converted_program_description, status);

    IF status.normal THEN
      IF spy_identifier <> 0 THEN
        pmp$set_spy_identifier (spy_identifier, 0, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      pmp$execute_with_less_privilege (execution_ring, converted_program_description^, parameters^,
            osc$nowait, FALSE, entry^.task_id, entry^.task_status, status);
      IF spy_identifier <> 0 THEN
        pmp$set_spy_identifier (0, 0, ignored_status);
      IFEND;
    IFEND;

    IF NOT status.normal THEN

{ Store the abnormal status as the task termination status.  Storing it in the system task execution table
{ (rather than the system task table) allows other tasks to be processed on this pass thru the main loop of
{ osp$manage_system_tasks.  The abnormal status must also be returned to the caller.

      entry^.task_status.status := status;
      entry^.task_status.complete := TRUE;
    IFEND;

{ Link the new entry into the system task execution table.

    osp$set_job_signature_lock (system_task_execution_lock);
    entry^.next_entry := system_task_execution_table;
    system_task_execution_table := entry;
    osp$clear_job_signature_lock (system_task_execution_lock);

  PROCEND osp$execute_system_task;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$get_system_task_data', EJECT ??

{ PURPOSE:
{   The purpose of this request is to return display information for one or all system tasks.
{ NOTES:
{   If display information is requested for all tasks, this request always returns a count of the number of
{   executing system tasks.  This allows the caller to allocate a data structure sufficiently large to hold
{   display information for all tasks.

  PROCEDURE [XDCL, #GATE] osp$get_system_task_data
    (    criteria: ost$system_task_data_criteria;
     VAR system_task_data: ost$system_task_display_data;
     VAR system_task_count: integer;
     VAR status: ost$status);

    VAR
      local_criteria: ost$system_task_data_criteria,
      local_status: ost$status,
      local_system_task_count: integer,
      local_system_task_data: ^ost$system_task_display_data;

    status.normal := TRUE;
    IF NOT (avp$system_operator () OR avp$system_displays ()) THEN
      osp$set_status_abnormal ('  ', ofe$sou_not_active, 'SYSTEM_OPERATION or SYSTEM_DISPLAYS', status);
      RETURN;
    IFEND;
    IF UPPERBOUND (system_task_data) < 1 THEN
      RETURN;
    ELSE
      PUSH local_system_task_data: [1 .. UPPERBOUND (system_task_data)];
    IFEND;
    local_criteria := criteria;
    osp$get_system_task_data_r1 (local_criteria, local_system_task_data^, local_system_task_count,
          local_status);
    system_task_data := local_system_task_data^;
    system_task_count := local_system_task_count;
    osp$copy_local_status_to_status (local_status, status);

  PROCEND osp$get_system_task_data;
?? OLDTITLE ??
?? NEWTITLE := 'osp$log_terminated_task', EJECT ??

{ PURPOSE:
{   The purpose of this request is to generate a system log entry reporting the unexpected
{   termination of a system task.

  PROCEDURE osp$log_terminated_task
    (    task_name: ost$name;
         termination_status: ost$status;
     VAR status: ost$status);

    CONST
      separator_1 = ' $!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$',
      separator_2 = ' $!$!$-------------------------------------------------------$!$!$';

    VAR
      length: integer,
      line: string (80),
      log_name_selections: array [1 .. 1] of ost$name,
      status_condition: string (11);

    line := ' ';
    log_name_selections [1] := 'SYSTEM';
    IF NOT termination_status.normal THEN
      clp$log_comment (separator_1, log_name_selections, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      line := ' $!$!$                                 terminated with';
      line (8, 31) := task_name;
      clp$log_comment (line, log_name_selections, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      line := ' $!$!$    ERROR:  CONDITION= xx ';
      line (30) := $CHAR ((termination_status.condition DIV 1000000(16)) DIV 100(16));
      line (31) := $CHAR ((termination_status.condition DIV 1000000(16)) MOD 100(16));
      STRINGREP (status_condition, length, (termination_status.condition MOD 1000000(16)));
      line (33, length) := status_condition;
      line (33 + length, * ) := ', TEXT=';
      clp$log_comment (line, log_name_selections, status);
      clp$log_comment (termination_status.text.value (1, termination_status.text.size), log_name_selections,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$log_comment (separator_2, log_name_selections, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE { normal termination }
      clp$log_comment (separator_1, log_name_selections, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      line := ' $!$!$                                 terminated with NORMAL status.';
      line (8, 31) := task_name;
      clp$log_comment (line, log_name_selections, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$log_comment (separator_2, log_name_selections, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND osp$log_terminated_task;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$manage_system_tasks', EJECT ??

{ PURPOSE:
{   The purpose of this request is to perform any actions that are needed to support system task execution.
{   Both the system task table and the system task execution table are scanned for events that require
{   action.
{ DESIGN:
{   First, the termination status of any system that has completed is moved from the system task execution
{   table to the system task table.  Then, a ring 1 helper is called to examine the system task table to
{   determine if any action is required.  If an action is required, the helper returns a description of the
{   action required and updates the system task table to indicate that the action has been taken.  This
{   procedure then performs the required action.  The helper is called repeatedly until no actions are
{   required.
{ NOTES:
{   This request must be called only in the system job monitor task.

  PROCEDURE [XDCL, #GATE] osp$manage_system_tasks
    (VAR short_wait: boolean;
     VAR status: ost$status);

    CONST
      line_template = ' ---- Task                                                 ----';

    VAR
      line: string (65),
      work_to_do: ost$system_task_work_to_do;

    status.normal := TRUE;
    short_wait := FALSE;
    IF NOT (jmp$system_job () AND osp$executing_in_job_monitor ()) THEN
      osp$set_status_abnormal ('  ', ose$not_system_job_monitor, 'osp$manage_system_tasks', status);
      RETURN;
    IFEND;

    osp$check_sys_task_completions;

    WHILE TRUE DO
      osp$scan_system_task_table (work_to_do);
      IF work_to_do.log_task_status THEN
        osp$log_terminated_task (work_to_do.task_name, work_to_do.task_status, {ignore} status);
        status.normal := TRUE;
      IFEND;
      CASE work_to_do.kind OF
      = osc$st_no_work_to_do =
        RETURN;
      = osc$st_execute_task =
        osp$execute_system_task (work_to_do.task_name, work_to_do.program_description,
              work_to_do.parameters, work_to_do.spy_identifier, work_to_do.execution_ring, status);
        IF NOT status.normal THEN
          short_wait := TRUE;
          status.normal := TRUE;
        IFEND;
        IF work_to_do.first_execution THEN
          line := line_template;
          line (12, 8) := 'started:';
          line (26, 31) := work_to_do.task_name;
          pmp$log (line, {ignore} status);
          status.normal := TRUE;
        ELSE
          line := line_template;
          line (12, 10) := 'restarted:';
          line (26, 31) := work_to_do.task_name;
          clp$put_job_command_response (line, {ignore} status);
          status.normal := TRUE;
        IFEND;

      = osc$st_terminate_task =
        osp$terminate_system_task (work_to_do.task_name);

      = osc$st_deactivate_task =
        line := line_template;
        line (12, 12) := 'deactivated:';
        line (26, 31) := work_to_do.task_name;
        clp$put_job_command_response (line, {ignore} status);
        status.normal := TRUE;
      CASEND;
    WHILEND;

  PROCEND osp$manage_system_tasks;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] osp$terminate_system_task', EJECT ??

{ PURPOSE:
{   The purpose of this request is to terminate an executing system task.
{ NOTES:
{   This request must be called only in the system job monitor task.

  PROCEDURE [XDCL] osp$terminate_system_task
    (    name: ost$name);

    VAR
      entry: ^ost$system_task_execution_entry,
      ignore_status: ost$status,
      task_id: pmt$task_id;

    osp$set_job_signature_lock (system_task_execution_lock);
    entry := system_task_execution_table;
    WHILE (entry <> NIL) AND (entry^.task_name <> name) DO
      entry := entry^.next_entry;
    WHILEND;
    osp$clear_job_signature_lock (system_task_execution_lock);
    IF entry = NIL THEN
      osp$system_error ('System task tables out of synch', NIL);
    ELSE
      task_id := entry^.task_id;
      pmp$terminate_task_without_wait (task_id, ignore_status);
    IFEND;

  PROCEND osp$terminate_system_task;
?? OLDTITLE ??
MODEND osm$system_task_maint_23d;
*DECK DECK=OSM$S_AND_D_SYS_ATTRS EXPAND=TRUE
MODULE osm$s_and_d_sys_attrs;


{
{  PURPOSE:
{     This is the command language interface to set and display system
{     attributes.


?? RIGHT := 110 ??
*copyc CLP$CHECK_NAME_FOR_BOOLEAN
*copyc CLP$OPEN_DISPLAY
*copyc CLP$PUT_DISPLAY
*copyc CLP$CLOSE_DISPLAY
*copyc CLP$SCAN_PARAMETER_LIST
*copyc CLP$GET_VALUE
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc OSP$STORE_SYSTEM_CONSTANT
*copyc OSP$FETCH_SYSTEM_CONSTANT
*copyc PMP$BINARY_TO_ASCII



?? EJECT, TITLE := 'PROCEDURE osp$set_system_attribute' ??

  PROCEDURE [XDCL, #GATE] osp$set_system_attribute (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{ PDT setsa_pdt (
{      name, n: NAME = $REQUIRED
{      value, v: INTEGER OR KEY on, off, true, false = $REQUIRED
{      status)

?? PUSH (LISTEXT := ON) ??

  VAR
    setsa_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^setsa_pdt_names,
      ^setsa_pdt_params];

  VAR
    setsa_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['NAME', 1], ['N', 1], ['VALUE', 2], ['V', 2], ['STATUS', 3]];

  VAR
    setsa_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ NAME N }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ VALUE V }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^setsa_pdt_kv2, clc$integer_value,
      clc$min_integer, clc$max_integer]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    setsa_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := ['ON', 'OFF',
      'TRUE', 'FALSE'];

?? POP ??

    VAR
      i: integer,
      bool: clt$boolean,
      value: clt$value,
      dummy: boolean,
      tempname: string (31);

    clp$scan_parameter_list (parameter_list, setsa_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    tempname := value.name.value;

    clp$get_value ('VALUE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.kind = clc$name_value THEN
      clp$check_name_for_boolean (value.name.value, bool, dummy);
      value.kind := clc$integer_value;
      value.int.value := ORD (bool.value);
    IFEND;



    osp$store_system_constant (tempname, 1, value.int.value, status);

  PROCEND osp$set_system_attribute;

?? EJECT, TITLE := 'PROCEDURE osp$display_system_attribute' ??

  PROCEDURE [XDCL, #GATE] osp$display_system_attribute (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT dissa_pdt (
{      name, n: NAME = $REQUIRED
{      output, o: FILE = $output
{      status)

?? PUSH (LISTEXT := ON) ??

  VAR
    dissa_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^dissa_pdt_names,
      ^dissa_pdt_params];

  VAR
    dissa_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['NAME', 1], ['N', 1], ['OUTPUT', 2], ['O', 2], ['STATUS', 3]];

  VAR
    dissa_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ NAME N }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ OUTPUT O }
    [[clc$optional_with_default, ^dissa_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    dissa_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$output';

?? POP ??

?? EJECT ??

    PROCEDURE abort_handler (condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);

      IF output_open THEN
        clp$close_display (display_control, ignore_status);
        output_open := FALSE;
      IFEND;

    PROCEND abort_handler;
?? EJECT ??

    PROCEDURE squeeze_out_spaces (VAR line: string (64));

      VAR
        counter,
        i,
        j: integer;

      counter := 1;
      i := 1;
      REPEAT
        WHILE (line (i, 2) = '  ') AND (counter < 64) DO {shift line down and add a space at end}
          FOR j := i + 1 TO 63 DO
            line (j) := line (j + 1);
          FOREND;
          line (64) := ' ';
          counter := counter + 1;
        WHILEND;
        i := i + 1;
      UNTIL (counter = 64) OR (i = 64);

    PROCEND squeeze_out_spaces;
?? EJECT ??

    VAR
      i,
      constant: integer,
      value: clt$value,
      display_all: boolean,
      display_control: clt$display_control,
      display_everything: boolean,
      ignore_status: ost$status,
      line: string (64),
      index: integer,
      tempname: string (31),
      output_open: boolean;

    clp$scan_parameter_list (parameter_list, dissa_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_all := FALSE;
    display_everything := FALSE;
    clp$get_value ('NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    tempname := value.name.value;
    IF tempname = 'EVERYTHING' THEN
      display_everything := TRUE;
      index := 1;
    ELSEIF tempname = 'ALL' THEN
      display_all := TRUE;
      index := 1;
    ELSE
      index := 0;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_open := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

    clp$open_display (value.file, NIL, display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    output_open := TRUE;

  /display/
    REPEAT
       osp$fetch_system_constant (tempname, index, constant, status);
       IF NOT status.normal THEN
         RETURN;
       IFEND;

       IF tempname <> 'dummy' THEN
          line (1, * ) := '   ';
          line (2, 32) := tempname;
          line (33, 3) := ' = ';
          pmp$binary_to_ascii (constant, line, 10, 64);
          squeeze_out_spaces (line);

          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /display/;
          IFEND;
       IFEND;

       IF display_everything THEN
         tempname := 'EVERYTHING';
       ELSEIF display_all THEN
         tempname := 'ALL';
       IFEND;

    UNTIL index = 0 {/display/} ;

    clp$close_display (display_control, ignore_status);

    osp$disestablish_cond_handler;

  PROCEND osp$display_system_attribute;

MODEND osm$s_and_d_sys_attrs;
*DECK DECK=OSM$TRANSLATE_BYTES EXPAND=TRUE
OSM$TRANSLATE_BYTES ident
         list      1,2,0
.
.FUNCTION          Execute the C180 TRANB instruction, but
.                  without the 256 byte field limitation
.
.        COPYRIGHT, 1986, BY CONTROL DATA SYSTEMS INC. 1992
.
.        This is a duplicate of MLPTRAN, copied on FEB. 10, 1986.
.
.        CONTROL DATA SYSTEMS INC PROPRIETARY PRODUCT
         title     c'OSP$TRANSLATE_BYTES'
         use       binding
.
         defg      ENTRY
ENTRY    alias     OSP$TRANSLATE_BYTES
         page
.
.        DOES CYBIL CONFORM TO THE SIS?
.          0 = no
.          1 = yes
.
SIS      set       1
.
.
.
.        PARAMETER LIST OFFSETS (BYTE)
.
.
         DO        SIS
.
SOURCE   SET       2                   . ^CELL
SLENGTH  SET       8                   . OST$STRING_LENGTH
TARGET   SET       18                  . ^CELL
TLENGTH  SET       24                  . OST$STRING_LENGTH
TABLE    SET       34                  . ^CELL
STATUS   SET       40                  . VAR OST$ERROR
.
         ELSE
.
SOURCE   SET       0                   . ^CELL
SLENGTH  SET       6                   . OST$STRING_LENGTH
TARGET   SET       10                  . ^CELL
TLENGTH  SET       16                  . OST$STRING_LENGTH
TABLE    SET       20                  . ^CELL
STATUS   SET       26                  . VAR OST$ERROR
.
         DEND
.
.
.
.        ERROR STATUS VALUES
.
NOERROR  equ       0                   . OSE$NO_ERROR
INVALID  equ       1                   . OSE$INVALID_BDP_DATA
LOSS     equ       2                   . OSE$LOSS_OF_SIGNIFICANCE
OVERFLOW equ       3                   . OSE$OVERFLOW
UNDRFLOW equ       4                   . OSE$UNDERFLOW
INDEF    equ       5                   . OSE$INDEFINITE
INFINITE equ       6                   . OSE$INFINITE
BADPARM  equ       7                   . OSE$BAD_PARAMETERS
NODIGITS equ       8                   . OSE$NO_DIGITS
.
         page
         use       code
.
ENTRY    align     0,8
.
.        LOAD PARAMETERS
.          A5 = SOURCE                 A6 = TARGET
.          A7 = TRANSLATION TABLE      A8 = STATUS
.          X2 = SOURCE_LENGTH          X3 = TARGET_LENGTH
.
         la        a5,a4,SOURCE
         la        a6,a4,TARGET
         la        a7,a4,TABLE
         la        a8,a4,STATUS
.
.
         DO        SIS
.
         lx        x2,a4,SLENGTH
         lx        x3,a4,TLENGTH
.
         ELSE
.
         lbyts,4   x2,a4,x0,SLENGTH
         lbyts,4   x3,a4,x0,TLENGTH
.
         DEND
.
.
.
.        WE MUST ALLOW FOR FIELDS BIGGER THAN 256, SO WE SET UP
.        A LOOP STRUCTURE FOR HANDLING LARGE FIELD LENGTHS
.
.         1) SET INITIAL PARAMETERS
.
         ente      x4,256              . max allowed length
.
.         2) FIX SOURCE LENGTH FOR HARDWARE
.
LOOP     brxge     x4,x2,LOOP1
         subx      x2,x4               .  x2 := x2 - 256
         cpyxx     x0,x4               . for hardware, length = 256
         brxeq     x0,x0,LOOP2
.
LOOP1    cpyxx     x0,x2               . use actual source_length
         entp      x2,0                . reset length to zero
.
.
.         3) FIX TARGET LENGTH FOR HARDWARE
.
LOOP2    brxge     x4,x3,LOOP3
         subx      x3,x4               . x3 := x3 - 256
         cpyxx     x1,x4
         brxeq     x0,x0,DOIT
.
LOOP3    cpyxx     x1,x3               . use actual target_length
         entp      x3,0                . reset length to 0
.
.         4) EXECUTE THE C180 TRANB INSTRUCTION
.
DOIT     tranb,a5,x0 a6,x1,a7,0 1,9,0,0 1,9,0,0
         addax     a5,x4               . adjust source pointer
         addax     a6,x4               . adjust target pointer
.
.         5) IF THE TARGET FIELD IS FILLED, WE CAN QUIT
.
         brxne     x3,x0,LOOP
.
.
.        SET STATUS = OSE$NO_ERROR
.
         entp      x1,noerror
         sbyts,1   x1,a8,x0,0
         return
.
         end
*DECK DECK=OSM$TRANSLATE_TABLES EXPAND=TRUE
MODULE osm$translate_tables;
?? LEFT := 1, RIGHT := 110 ??
*copyc oss$job_paged_literal

  VAR osv$ascii_to_ebcdic: [ XDCL, #GATE, READ, oss$job_paged_literal] array [0 .. 255] of 0 .. 255 := [
      000(16), 001(16), 002(16), 003(16), 037(16), 02D(16), 02E(16), 02F(16),
      016(16), 005(16), 025(16), 00B(16), 00C(16), 00D(16), 00E(16), 00F(16),
      010(16), 011(16), 012(16), 013(16), 03C(16), 03D(16), 032(16), 026(16),
      018(16), 019(16), 03F(16), 027(16), 01C(16), 01D(16), 01E(16), 01F(16),
      040(16), 04F(16), 07F(16), 07B(16), 05B(16), 06C(16), 050(16), 07D(16),
      04D(16), 05D(16), 05C(16), 04E(16), 06B(16), 060(16), 04B(16), 061(16),
      0F0(16), 0F1(16), 0F2(16), 0F3(16), 0F4(16), 0F5(16), 0F6(16), 0F7(16),
      0F8(16), 0F9(16), 07A(16), 05E(16), 04C(16), 07E(16), 06E(16), 06F(16),
      07C(16), 0C1(16), 0C2(16), 0C3(16), 0C4(16), 0C5(16), 0C6(16), 0C7(16),
      0C8(16), 0C9(16), 0D1(16), 0D2(16), 0D3(16), 0D4(16), 0D5(16), 0D6(16),
      0D7(16), 0D8(16), 0D9(16), 0E2(16), 0E3(16), 0E4(16), 0E5(16), 0E6(16),
      0E7(16), 0E8(16), 0E9(16), 04A(16), 0E0(16), 05A(16), 05F(16), 06D(16),
      079(16), 081(16), 082(16), 083(16), 084(16), 085(16), 086(16), 087(16),
      088(16), 089(16), 091(16), 092(16), 093(16), 094(16), 095(16), 096(16),
      097(16), 098(16), 099(16), 0A2(16), 0A3(16), 0A4(16), 0A5(16), 0A6(16),
      0A7(16), 0A8(16), 0A9(16), 0C0(16), 06A(16), 0D0(16), 0A1(16), 007(16),
      020(16), 021(16), 022(16), 023(16), 024(16), 015(16), 006(16), 017(16),
      028(16), 029(16), 02A(16), 02B(16), 02C(16), 009(16), 00A(16), 01B(16),
      030(16), 031(16), 01A(16), 033(16), 034(16), 035(16), 036(16), 008(16),
      038(16), 039(16), 03A(16), 03B(16), 004(16), 014(16), 03E(16), 0E1(16),
      041(16), 042(16), 043(16), 044(16), 045(16), 046(16), 047(16), 048(16),
      049(16), 051(16), 052(16), 053(16), 054(16), 055(16), 056(16), 057(16),
      058(16), 059(16), 062(16), 063(16), 064(16), 065(16), 066(16), 067(16),
      068(16), 069(16), 070(16), 071(16), 072(16), 073(16), 074(16), 075(16),
      076(16), 077(16), 078(16), 080(16), 08A(16), 08B(16), 08C(16), 08D(16),
      08E(16), 08F(16), 090(16), 09A(16), 09B(16), 09C(16), 09D(16), 09E(16),
      09F(16), 0A0(16), 0AA(16), 0AB(16), 0AC(16), 0AD(16), 0AE(16), 0AF(16),
      0B0(16), 0B1(16), 0B2(16), 0B3(16), 0B4(16), 0B5(16), 0B6(16), 0B7(16),
      0B8(16), 0B9(16), 0BA(16), 0BB(16), 0BC(16), 0BD(16), 0BE(16), 0BF(16),
      0CA(16), 0CB(16), 0CC(16), 0CD(16), 0CE(16), 0CF(16), 0DA(16), 0DB(16),
      0DC(16), 0DD(16), 0DE(16), 0DF(16), 0EA(16), 0EB(16), 0EC(16), 0ED(16),
      0EE(16), 0EF(16), 0FA(16), 0FB(16), 0FC(16), 0FD(16), 0FE(16), 0FF(16)];

  ?? EJECT ??
  VAR osv$ebcdic_to_ascii: [ XDCL, #GATE, READ, oss$job_paged_literal] array [0 .. 255] of 0 .. 255 := [
      000(16), 001(16), 002(16), 003(16), 09C(16), 009(16), 086(16), 07F(16),
      097(16), 08D(16), 08E(16), 00B(16), 00C(16), 00D(16), 00E(16), 00F(16),
      010(16), 011(16), 012(16), 013(16), 09D(16), 085(16), 008(16), 087(16),
      018(16), 019(16), 092(16), 08F(16), 01C(16), 01D(16), 01E(16), 01F(16),
      080(16), 081(16), 082(16), 083(16), 084(16), 00A(16), 017(16), 01B(16),
      088(16), 089(16), 08A(16), 08B(16), 08C(16), 005(16), 006(16), 007(16),
      090(16), 091(16), 016(16), 093(16), 094(16), 095(16), 096(16), 004(16),
      098(16), 099(16), 09A(16), 09B(16), 014(16), 015(16), 09E(16), 01A(16),
      020(16), 0A0(16), 0A1(16), 0A2(16), 0A3(16), 0A4(16), 0A5(16), 0A6(16),
      0A7(16), 0A8(16), 05B(16), 02E(16), 03C(16), 028(16), 02B(16), 021(16),
      026(16), 0A9(16), 0AA(16), 0AB(16), 0AC(16), 0AD(16), 0AE(16), 0AF(16),
      0B0(16), 0B1(16), 05D(16), 024(16), 02A(16), 029(16), 03B(16), 05E(16),
      02D(16), 02F(16), 0B2(16), 0B3(16), 0B4(16), 0B5(16), 0B6(16), 0B7(16),
      0B8(16), 0B9(16), 07C(16), 02C(16), 025(16), 05F(16), 03E(16), 03F(16),
      0BA(16), 0BB(16), 0BC(16), 0BD(16), 0BE(16), 0BF(16), 0C0(16), 0C1(16),
      0C2(16), 060(16), 03A(16), 023(16), 040(16), 027(16), 03D(16), 022(16),
      0C3(16), 061(16), 062(16), 063(16), 064(16), 065(16), 066(16), 067(16),
      068(16), 069(16), 0C4(16), 0C5(16), 0C6(16), 0C7(16), 0C8(16), 0C9(16),
      0CA(16), 06A(16), 06B(16), 06C(16), 06D(16), 06E(16), 06F(16), 070(16),
      071(16), 072(16), 0CB(16), 0CC(16), 0CD(16), 0CE(16), 0CF(16), 0D0(16),
      0D1(16), 07E(16), 073(16), 074(16), 075(16), 076(16), 077(16), 078(16),
      079(16), 07A(16), 0D2(16), 0D3(16), 0D4(16), 0D5(16), 0D6(16), 0D7(16),
      0D8(16), 0D9(16), 0DA(16), 0DB(16), 0DC(16), 0DD(16), 0DE(16), 0DF(16),
      0E0(16), 0E1(16), 0E2(16), 0E3(16), 0E4(16), 0E5(16), 0E6(16), 0E7(16),
      07B(16), 041(16), 042(16), 043(16), 044(16), 045(16), 046(16), 047(16),
      048(16), 049(16), 0E8(16), 0E9(16), 0EA(16), 0EB(16), 0EC(16), 0ED(16),
      07D(16), 04A(16), 04B(16), 04C(16), 04D(16), 04E(16), 04F(16), 050(16),
      051(16), 052(16), 0EE(16), 0EF(16), 0F0(16), 0F1(16), 0F2(16), 0F3(16),
      05C(16), 09F(16), 053(16), 054(16), 055(16), 056(16), 057(16), 058(16),
      059(16), 05A(16), 0F4(16), 0F5(16), 0F6(16), 0F7(16), 0F8(16), 0F9(16),
      030(16), 031(16), 032(16), 033(16), 034(16), 035(16), 036(16), 037(16),
      038(16), 039(16), 0FA(16), 0FB(16), 0FC(16), 0FD(16), 0FE(16), 0FF(16)];

MODEND osm$translate_tables;
*DECK DECK=OSM$UNIQUE_NAME_MANAGEMENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Binary Name Management' ??
MODULE osm$unique_name_management;

{ Purpose: The purpose of this module is to generate binary unique names.
{          Binary unique names are unique and can only occur once.

{ Design:  Binary unique names contain an identification of a processor ( model/serial) and
{          the date and time that they are created - down to the microsecond.

?? NEWTITLE := '    Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_paged_literal
*copyc ost$binary_unique_name
*copyc ost$date_time
*copyc ost$date_time
*copyc ost$processor_element_id
*copyc ost$status
*copyc pmt$system_time
?? POP ??
*copyc pmp$get_binary_processor_id
*copyc pmp$get_date_time_at_timestamp
*copyc pmp$get_system_time
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] osp$generate_unique_binary_name', EJECT ??
*copyc osh$generate_unique_binary_name

  PROCEDURE [XDCL, #GATE] osp$generate_unique_binary_name
    (VAR name: ost$binary_unique_name;
     VAR status: ost$status);

    VAR
      processor_element_id: ost$processor_element_id,
      free_running_clock: ost$free_running_clock,
      free_running_clock_modulus: integer,
      universal_time: ost$date_time;

    status.normal := TRUE;

{ Free_running_clock_modulus is used to take the least_significant bits of the
{ free_running_clock and place them into the binary unique name as the sequence.
{ The sequence represents the microsecond and millisecond time of day.

    free_running_clock_modulus := UPPERVALUE (name.sequence_number) + 1;

    pmp$get_binary_processor_id (processor_element_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    name.serial_number := processor_element_id.serial_number;
    name.model_number := processor_element_id.model_number;

    free_running_clock := #FREE_RUNNING_CLOCK (0);

    pmp$get_date_time_at_timestamp (free_running_clock, pmc$use_universal_time, universal_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    name.year := universal_time.year + 1900;
    name.month := universal_time.month;
    name.day := universal_time.day;
    name.hour := universal_time.hour;
    name.minute := universal_time.minute;
    name.second := universal_time.second;
    name.sequence_number := free_running_clock MOD free_running_clock_modulus;
    name.fill := 0;
  PROCEND osp$generate_unique_binary_name;
?? OLDTITLE ??
MODEND osm$unique_name_management;

*DECK DECK=OSM$UNIVERSAL_TASK_SUPPORT EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Universal Task Support Procedures' ??
MODULE osm$universal_task_support;

{  PURPOSE:
{    This module contains service routines involving universal task id.

?? NEWTITLE := '    Global Declarations Referenced by this Module' ??

?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_parameters
*copyc dft$rpc_queue_entry_location
*copyc dft$server_location
*copyc ost$df_ready_task_with_utid
*copyc ost$global_task_id
*copyc ost$status
*copyc ost$universal_task_id
*copyc ost$universal_task_id_mask
*copyc pmt$binary_mainframe_id
*copyc pmt$mainframe_id
*copyc pmt$task_id
?? POP ??
?? EJECT ??
*copyc dfp$send_remote_procedure_call
*copyc osp$set_status_from_condition
*copyc pmp$convert_binary_mainframe_id
*copyc pmp$get_binary_mainframe_id
*copyc pmp$get_executing_task_gtid
*copyc pmp$ready_task

?? TITLE := '[XDCL, #GATE] osp$get_universal_task_id', EJECT ??
*copy osh$get_universal_task_id

  PROCEDURE [XDCL, #GATE] osp$get_universal_task_id
    (VAR universal_task_id: ost$universal_task_id;
     VAR status: ost$status);

    VAR
      converted_task_id: ost$universal_task_id_mask;


    status.normal := TRUE;
    converted_task_id.padding := 0;

    pmp$get_executing_task_gtid (converted_task_id.global_task_id);
    pmp$get_binary_mainframe_id (converted_task_id.binary_mainframe_id, status);
    IF status.normal THEN
      universal_task_id := converted_task_id.universal_task_id;
    IFEND;

  PROCEND osp$get_universal_task_id;
?? TITLE := '[XDCL, #GATE] osp$ready_universal_task', EJECT ??
*copy osh$ready_universal_task

  PROCEDURE [XDCL, #GATE] osp$ready_universal_task
    (    universal_task_id: ost$universal_task_id;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT osp$ready_universal_task;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      binary_mainframe_id: pmt$binary_mainframe_id,
      global_task_id: ost$global_task_id,
      ignore_status: ost$status,
      mainframe_id: pmt$mainframe_id,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: ^ost$df_ready_task_with_utid_inp,
      p_send_to_server_params: dft$p_send_parameters,
      parameter_size: dft$send_parameter_size,
      queue_entry_location: dft$rpc_queue_entry_location,
      server_location: dft$server_location,
      utid_converter: ost$universal_task_id_mask;

    status.normal := TRUE;

    utid_converter.universal_task_id := universal_task_id;
    pmp$get_binary_mainframe_id (binary_mainframe_id, ignore_status);
    IF utid_converter.binary_mainframe_id = binary_mainframe_id THEN
      pmp$ready_task (utid_converter.global_task_id, status);

    ELSE {Task executes on a different mainframe}
      server_location.server_location_selector := dfc$mainframe_id;
      pmp$convert_binary_mainframe_id (utid_converter.binary_mainframe_id, server_location.server_mainframe,
           status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      dfp$begin_ch_remote_proc_call (server_location, { Allowed when deactivated = } FALSE,
           queue_entry_location, p_send_to_server_params, p_send_data, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      NEXT p_send_parameters IN p_send_to_server_params;
      p_send_parameters^.utid_converter := utid_converter;
      parameter_size := #SIZE (utid_converter);
      dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_ready_univ_tsk,
           parameter_size, 0, p_receive_from_server_params, p_receive_data, status);
      IF status.normal THEN
        dfp$end_ch_remote_proc_call (queue_entry_location, status);
      ELSE
        dfp$end_ch_remote_proc_call (queue_entry_location, ignore_status);
      IFEND;
    IFEND;
  PROCEND osp$ready_universal_task;
?? TITLE := '[XDCL] osp$server_ready_task', EJECT ??

  PROCEDURE [XDCL] osp$server_ready_task
    (VAR p_params_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_params_to_server {^Output} : dft$p_send_parameters;
     VAR p_data_to_server {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_input_params: ^ost$df_ready_task_with_utid_inp;

    status.normal := TRUE;
    send_data_size := 0;
    send_parameters_size := 0;

    NEXT p_input_params IN p_params_from_client;
    pmp$ready_task (p_input_params^.utid_converter.global_task_id, status);

  PROCEND osp$server_ready_task;

MODEND osm$universal_task_support;
*DECK DECK=OSM$WAIT_ON_CONDITION EXPAND=TRUE
?? RIGHT := 110 ??
MODULE osm$wait_on_condition;

{ PURPOSE:
{   This module contains the procedures that wait on a condition and display
{   the appropriate message for the job status display.
{   File server job recovery is initiated from this routine.

?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dmt$error_condition_codes
*copyc ioe$st_errors
*copyc mme$condition_codes
*copyc osd$virtual_address
*copyc ost$caller_identifier
*copyc ost$status
*copyc ost$status_condition_code
*copyc dfp$check_job_recovery
*copyc ofp$display_status_message
*copyc ofp$get_display_status_message
*copyc pmp$cause_task_condition
*copyc pmp$delay
*copyc pmp$get_job_names
*copyc pmp$long_term_wait
?? POP ??

?? TITLE := '[XDCL, #GATE] osp$clear_wait_message', EJECT ??
  PROCEDURE [XDCL, #GATE] osp$clear_wait_message
    (    original_display_message: oft$display_message;
     VAR wait_message_displayed: {i/o} boolean);

    CONST
      continuing_message = 'Continuing: ',
      continuing_message_size = 12;

    VAR
      ignored_status: ost$status,
      message_length: integer,
      message_string: string (ofc$max_display_message);

    IF wait_message_displayed THEN
      IF original_display_message.text (1,
            continuing_message_size) = continuing_message THEN
        message_length := original_display_message.size;
        message_string := original_display_message.text (1, message_length);
      ELSE
        message_string := continuing_message;
        IF (continuing_message_size + original_display_message.size) >
              ofc$max_display_message THEN
          message_length := ofc$max_display_message;
        ELSE
          message_length := continuing_message_size +
                original_display_message.size;
        IFEND;
        message_string (continuing_message_size + 1, * ) :=
              original_display_message.text (1, original_display_message.size);
      IFEND;
      ofp$display_status_message (message_string (1, message_length),
            ignored_status);
      wait_message_displayed := FALSE;
      #SPOIL (wait_message_displayed);
    IFEND;

  PROCEND osp$clear_wait_message;

?? TITLE := '[XDCL, #GATE] osp$get_current_display_message', EJECT ??
  PROCEDURE [XDCL, #GATE] osp$get_current_display_message
    (VAR current_display_message: oft$display_message);

    VAR
      local_display_message: oft$display_message,
      local_status: ost$status,
      system_supplied_name: jmt$system_supplied_name,
      user_name: jmt$user_supplied_name;

    pmp$get_job_names (user_name, system_supplied_name, {ignore}local_status);

    ofp$get_display_status_message (system_supplied_name,
          local_display_message, local_status);
    IF NOT local_status.normal THEN
      local_display_message.size := 7;
      local_display_message.text := 'UNKNOWN';
    IFEND;
    current_display_message := local_display_message;
  PROCEND osp$get_current_display_message;

?? TITLE := '[XDCL, #GATE] osp$wait_on_condition', EJECT ??
  PROCEDURE [XDCL, #GATE] osp$wait_on_condition
    (    condition: ost$status_condition_code);

    CONST
      delay = 30000;

    VAR
      caller_id: ost$caller_identifier,
      original_display_message: oft$display_message,
      recovery_occurred: boolean,
      status: ost$status,
      strl: integer,
      str: string (80),
      wait_message_displayed: boolean;

    #CALLER_ID (caller_id);

    osp$get_current_display_message (original_display_message);

    IF condition = dme$unable_to_alloc_all_space THEN
      pmp$cause_task_condition ('OSC$SPACE_UNAVAILABLE          ', NIL, TRUE, FALSE,
        TRUE, FALSE, status);
      ofp$display_status_message (' Waiting for space.', status);
    ELSE
      pmp$cause_task_condition ('OSC$VOLUME_UNAVAILABLE         ', NIL, TRUE, FALSE,
        TRUE, FALSE, status);
      IF condition = ioe$unit_disabled THEN
        ofp$display_status_message (' Waiting for disabled unit.', status);
      ELSEIF condition = dfe$server_not_active THEN
        ofp$display_status_message (' Waiting for unavailable server', status);
      ELSEIF condition = dfe$server_has_terminated THEN
        { We should not be waiting on this condition.
        ofp$display_status_message (' Waiting for terminated server', status);
      ELSE
        ofp$display_status_message (' Waiting for unavailable volume.', status);
      IFEND;
    IFEND;
    wait_message_displayed := TRUE;
    {
    { Note. Currently we must do this on all conditions, because the monitor
    {  path always uses the condition of unavailable volume.
    {
    dfp$check_job_recovery (recovery_occurred);

    IF NOT recovery_occurred THEN
      IF caller_id.ring <= osc$tsrv_ring THEN
        {Cannot allow interruption of OS code
        pmp$delay (delay, status);
      ELSE
        {The following extra wait is required to "eat" xcb.wait_inhibited
        pmp$long_term_wait (1, 1);
        pmp$long_term_wait (30000, 30000);
      IFEND;
    IFEND;

    osp$clear_wait_message (original_display_message, wait_message_displayed);

  PROCEND osp$wait_on_condition;
MODEND osm$wait_on_condition;

*DECK DECK=OSP$ACTIVATE_OS_STATISTICS EXPAND=FALSE

 PROCEDURE [XREF] osp$activate_os_statistics (jms_interval: integer;
        jps_interval: integer;
    VAR status: ost$status);

*copyc ost$status
*DECK DECK=OSP$ACTIVATE_SYSTEM_TASK EXPAND=FALSE

  PROCEDURE [XREF] osp$activate_system_task (name: ost$name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=OSP$ACTIVATE_SYSTEM_TASK_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$activate_system_task_r1 (name: ost$name;
        system_job_monitor: boolean;
    VAR program_description: ^llt$program_description;
    VAR parameters: ^clt$parameter_list;
    VAR spy_identifier: pmt$spy_identifier;
    VAR execution_ring: ost$valid_ring;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc llt$program_description
*copyc clt$parameter_list
*copyc pmt$spy_identifier
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=OSP$ACTIVE_SYSTEM_TASK EXPAND=FALSE

  FUNCTION [XREF, UNSAFE] osp$active_system_task: boolean;

*DECK DECK=OSP$ACTIVE_SYSTEM_TASK_R1 EXPAND=FALSE

  FUNCTION [XREF, UNSAFE] osp$active_system_task_r1
    (    task_name: ost$name): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=OSP$ADD_FAMILY EXPAND=FALSE
PROCEDURE [XREF] osp$add_family (family: ost$name;
  set_name: stt$set_name;
  VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc std$set_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=OSP$ADD_TO_LOCKED_VARIABLE EXPAND=TRUE
   PROCEDURE [INLINE] osp$add_to_locked_variable (VAR variable:{Input, Output} integer;
         initial_best_guess: integer;
         amount_to_add: integer;
     VAR actual: integer);

    VAR
      initial: integer,
      result: 0 .. 2;

    initial := initial_best_guess;
  /swap_in_addition/
    REPEAT
      #compare_swap (variable, initial, initial + amount_to_add, initial, result);
    UNTIL result = 0;
    actual := initial + amount_to_add;
  PROCEND osp$add_to_locked_variable;
*DECK DECK=OSP$ALERT_KEYP_CPU_STATE_CHNG EXPAND=FALSE

  PROCEDURE [XREF] osp$alert_keyp_cpu_state_chng
    (    cpu_with_state_change: ost$processor_id);

?? PUSH (LISTEXT := ON) ??
*copyc ost$processor_id
?? POP ??
*DECK DECK=OSP$ALERT_KEYP_OF_FAILING_CPU EXPAND=FALSE
*DECK DECK=OSP$APPEND_STATUS_FILE EXPAND=FALSE

  PROCEDURE [XREF] osp$append_status_file
    (    delimiter: char;
         file: fst$file_reference;
     VAR status {input, output} : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc fst$file_reference
*copyc osc$status_parameter_delimiter
*copyc ost$status
?? POP ??
*DECK DECK=OSP$APPEND_STATUS_INTEGER EXPAND=FALSE

  PROCEDURE [XREF] osp$append_status_integer ALIAS 'ospasi'
    (    delimiter: char;
         int: integer;
         radix: 2 .. 16;
         include_radix_specifier: boolean;
     VAR status {input, output} : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osc$status_parameter_delimiter
*copyc ost$status
?? POP ??
*DECK DECK=OSP$APPEND_STATUS_PARAMETER EXPAND=FALSE

  PROCEDURE [XREF] osp$append_status_parameter ALIAS 'ospasp'
    (    delimiter: char;
         text: string ( * <= osc$max_string_size);
     VAR status {input, output} : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osc$status_parameter_delimiter
*copyc ost$status
*copyc ost$string
?? POP ??
*DECK DECK=OSP$APPEND_STATUS_REAL EXPAND=FALSE

  PROCEDURE [XREF] osp$append_status_real
    (    delimiter: char;
         real_number: longreal;
         number_of_digits: clt$real_number_digit_count;
     VAR status {input, output} : ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$real_number_digit_count
*copyc ost$status
?? POP ??
*DECK DECK=OSP$AWAIT_ACTIVITY EXPAND=FALSE

  PROCEDURE [XREF] osp$await_activity (wait_list: ost$wait_list;
    VAR ready_index: integer;
    VAR complete: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OSD$WAIT
*copyc OST$STATUS
*copyc OSE$AWAIT_ACTIVITY_EXCEPTIONS
*copyc PME$LOCAL_QUEUE_EXCEPTIONS
?? POP ??
*DECK DECK=OSP$AWAIT_ACTIVITY_COMPLETION EXPAND=FALSE

  PROCEDURE [XREF] osp$await_activity_completion (wait_list: ost$wait_list;
    VAR ready_index: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OSD$WAIT
*copyc OST$STATUS
*copyc OSE$AWAIT_ACTIVITY_EXCEPTIONS
*copyc PME$LOCAL_QUEUE_EXCEPTIONS
?? POP ??
*DECK DECK=OSP$BEGIN_AAM_ACTIVITY EXPAND=FALSE
  PROCEDURE [XREF] osp$begin_aam_activity;


*DECK DECK=OSP$BEGIN_AAM_ACTIVITY_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$begin_aam_activity_r1;
*DECK DECK=OSP$BEGIN_SUBSYSTEM_ACTIVITY EXPAND=FALSE

PROCEDURE [XREF] osp$begin_subsystem_activity;
*DECK DECK=OSP$BEGIN_SYSTEM_ACTIVITY EXPAND=FALSE

  PROCEDURE [XREF] osp$begin_system_activity;
*DECK DECK=OSP$BEGIN_TEXT_DUMP EXPAND=FALSE

  PROCEDURE [XREF] osp$begin_text_dump
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=OSP$CALLED_BY_SYSTEM_CODE EXPAND=FALSE

  FUNCTION [INLINE] osp$called_by_system_code
    (    caller_id: ost$caller_identifier): boolean;

{   This function utilizes the system privilege bit map to determine whether
{ or not the caller of this function was called by system code.

    osp$called_by_system_code := osv$system_privilege_map [caller_id.segnum];
  FUNCEND osp$called_by_system_code;

*copyc ost$caller_identifier
*copyc osv$system_privilege_map
*DECK DECK=OSP$CHACC_APPLICABLE_POLICY EXPAND=FALSE
  FUNCTION [XREF] osp$chacc_applicable_policy
    (    policy: ^ost$ecp_policy_header): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc osd$exception_policies
?? POP ??
*DECK DECK=OSP$CHANGE_BASE_SYSTEM_TIME EXPAND=FALSE

  PROCEDURE [XREF] osp$change_base_system_time
    (    free_running_clock: ost$free_running_clock;
         date_time: ost$date_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$free_running_clock
*copyc ost$status
?? POP ??
*DECK DECK=OSP$CHANGE_DATE_TIME EXPAND=FALSE

  PROCEDURE [XREF] osp$change_date_time
    (    use_os_default: boolean;
         os_default: ost$operating_system_default;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$operating_system_default
*copyc ost$status
?? POP ??
*DECK DECK=OSP$CHANGE_HARDWARE_DATE_TIME EXPAND=FALSE

  PROCEDURE [XREF] osp$change_hardware_date_time
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$CHANGE_INTERACTION_INFO EXPAND=FALSE

  PROCEDURE [XREF] osp$change_interaction_info
    (    interaction_information: ost$interaction_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ose$message_gen_exceptions
*copyc ost$interaction_information
*copyc ost$status
?? POP ??
*DECK DECK=OSP$CHANGE_INTERACTION_STYLE EXPAND=FALSE

  PROCEDURE [XREF] osp$change_interaction_style
    (    interaction_style: ost$interaction_style;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$interaction_style
*copyc ost$status
?? POP ??
*DECK DECK=OSP$CHANGE_OS_DEFAULT_RING_1 EXPAND=FALSE

  PROCEDURE [XREF] osp$change_os_default_ring_1
    (    os_default: ost$operating_system_default;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$operating_system_default
*copyc ost$status
?? POP ??
*DECK DECK=OSP$CHANGE_OS_DEFAULT_RING_3 EXPAND=FALSE

  PROCEDURE [XREF] osp$change_os_default_ring_3
    (    os_default: ost$operating_system_default;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$operating_system_default
*copyc ost$status
?? POP ??
*DECK DECK=OSP$CHANGE_TRANSLATION_TABLES EXPAND=FALSE

  PROCEDURE [XREF] osp$change_translation_tables
    (    name_folding_level: clt$name_folding_level;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$name_folding_level
*copyc ost$status
?? POP ??
*DECK DECK=OSP$CHECK_CLIENT_LEVELED_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] osp$check_client_leveled_access
    (    family_name: ost$name;
     VAR leveled_access: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=OSP$CHECK_FOR_DESIRED_MF_CLASS EXPAND=FALSE

  PROCEDURE [XREF] osp$check_for_desired_mf_class
    (    desired_class: ost$mainframe_classes;
     VAR desired_class_found: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc ost$mainframe_classes
?? POP ??
*DECK DECK=OSP$CHECK_FOR_JOB_RECOVERY EXPAND=FALSE

  PROCEDURE [XREF] osp$check_for_job_recovery
    (    message: string (*));

*DECK DECK=OSP$CHECK_SYS_TASK_COMPLETIONS EXPAND=FALSE

  PROCEDURE [XREF] osp$check_sys_task_completions;
*DECK DECK=OSP$CLEAR_DEFAULTS_CHANGED_FLAG EXPAND=FALSE

  PROCEDURE [XREF] osp$clear_defaults_changed_flag;
*DECK DECK=OSP$CLEAR_DISK_FAULTS_R1 EXPAND=FALSE
  PROCEDURE [XREF] osp$clear_disk_faults_r1;
*DECK DECK=OSP$CLEAR_JOB_SIGNATURE_LOCK EXPAND=FALSE
  PROCEDURE [INLINE] osp$clear_job_signature_lock
    (VAR lock: ost$signature_lock);

?? PUSH (LISTEXT := ON) ??
*copyc clc$compiling_for_test_harness
*copyc fsc$compiling_for_test_harness
*copyc sfc$compiling_for_test_harness

*IF NOT $true(osv$unix)
    ?IF NOT (clc$compiling_for_test_harness OR fsc$compiling_for_test_harness OR
          sfc$compiling_for_test_harness) THEN

      VAR
        task_id: ost$global_task_id,
        xcb_p: ^ost$execution_control_block,
        actual_value: integer,
        initial_value: integer,
        cs_status: 0 .. 2;

      xcb_p := #ADDRESS (1, osc$segnum_job_fixed_heap,
            #READ_REGISTER (osc$pr_base_constant));
      task_id := xcb_p^.global_task_id;
      initial_value := task_id.index * 256 * #SIZE (task_id.seqno) + task_id.
            seqno;

      REPEAT
        #COMPARE_SWAP (lock.lock_id, initial_value, 0, actual_value,
              cs_status);
      UNTIL cs_status <> osc$cs_variable_locked;
      IF cs_status <> osc$cs_successful THEN
        osp$system_error ('LOCKMGR - not locked', NIL);
      IFEND;
    ?ELSE
*IFEND
      IF lock.lock_id <> 12 THEN
*IF NOT $true(osv$unix)
        osp$system_error (' lock not set', NIL);
*ELSE
        RETURN;
*IFEND
      IFEND;
      lock.lock_id := 0;
*IF NOT $true(osv$unix)
    ?IFEND
*IFEND

  PROCEND osp$clear_job_signature_lock;
*copyc ost$execution_control_block
*copyc ost$heap
*copyc osc$processor_defined_registers
*copyc ost$signature_lock
*IF NOT $true(osv$unix)
*copyc osp$system_error
?? POP ??
*IFEND
*DECK DECK=OSP$CLEAR_LOCKED_VARIABLE EXPAND=FALSE

  PROCEDURE [INLINE] osp$clear_locked_variable
    (VAR variable: {Input, Output} integer;
         initial_best_guess: integer);

    VAR
      initial: integer,
      result: 0 .. 2;

    initial := initial_best_guess;

  /swap_in_zero/
    REPEAT
      #COMPARE_SWAP (variable, initial, 0, initial, result);
    UNTIL result = 0;
  PROCEND osp$clear_locked_variable;

*DECK DECK=OSP$CLEAR_MAINFRAME_SIG_LOCK EXPAND=FALSE
  PROCEDURE [INLINE] osp$clear_mainframe_sig_lock
    (VAR lock: ost$signature_lock);

?? PUSH (LISTEXT := ON) ??
*copyc clc$compiling_for_test_harness
*copyc fsc$compiling_for_test_harness
*copyc sfc$compiling_for_test_harness

    ?IF NOT (clc$compiling_for_test_harness OR fsc$compiling_for_test_harness OR
          sfc$compiling_for_test_harness) THEN

      VAR
        task_id: ost$global_task_id,
        xcb_p: ^ost$execution_control_block,
        actual_value: integer,
        initial_value: integer,
        cs_status: 0 .. 2;

      xcb_p := #ADDRESS (1, osc$segnum_job_fixed_heap,
            #READ_REGISTER (osc$pr_base_constant));
      task_id := xcb_p^.global_task_id;
      initial_value := task_id.index * 256 * #SIZE (task_id.seqno) + task_id.
            seqno;
      REPEAT
        #COMPARE_SWAP (lock.lock_id, initial_value, 0, actual_value,
              cs_status);
      UNTIL cs_status <> osc$cs_variable_locked;
      IF cs_status <> osc$cs_successful THEN
        osp$system_error ('LOCKMGR - not locked', NIL);
      IFEND;

{ Debug code.

      IF xcb_p^.system_table_lock_count < 256 THEN
        osp$system_error ('LOCKMGR - system_table_lock_count error', NIL);
      IFEND;

{ End debug code.

      xcb_p^.system_table_lock_count := xcb_p^.system_table_lock_count - 256;

{ Check for escaped allocation. If allocation occured while tables were locked,
{ process the allocation.

      IF xcb_p^.stlc_allocation AND (xcb_p^.system_table_lock_count < 256) THEN
        xcb_p^.stlc_allocation := FALSE;
        osp$mfh_for_segment_manager;
      IFEND;

      IF (xcb_p^.system_table_lock_count <= 0) AND (xcb_p^.system_give_up_cpu) THEN
        syp$cycle_for_lock (tmc$cyc_clear_sys_lock, ^lock);
      IFEND;
    ?ELSE
      IF lock.lock_id <> 12 THEN
        osp$system_error (' lock not set', NIL);
      IFEND;
      lock.lock_id := 0;
    ?IFEND

  PROCEND osp$clear_mainframe_sig_lock;
*copyc osp$mfh_for_segment_manager
*copyc ost$execution_control_block
*copyc syp$cycle_for_lock
*copyc ost$heap
*copyc osc$processor_defined_registers
*copyc ost$signature_lock
*copyc osp$system_error
?? POP ??
*DECK DECK=OSP$CLEAR_SIGNATURE_LOCK EXPAND=FALSE

  PROCEDURE [XREF] osp$clear_signature_lock (VAR lock: ost$signature_lock;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc ost$signature_lock
?? POP ??
*DECK DECK=OSP$CLEAR_WAIT_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$clear_wait_message
    (    original_display_message: oft$display_message;
     VAR wait_message_displayed: {i/o} boolean);

?? PUSH (LISTEXT := ON) ??
*copyc oft$display_message
?? POP ??

*DECK DECK=OSP$COLLECTION_FILE_INFO EXPAND=FALSE

  PROCEDURE [XREF] osp$collection_file_info
    (    number_of_files: 0 .. 0ff(16);
         file_id_array: array [1 .. osc$max_number_of_processors] of
          amt$file_identifier;
         pva_array: array [1 .. osc$max_number_of_processors] of ^cell;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
?? POP ??
*DECK DECK=OSP$COLLECTION_FILE_INFO_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$collection_file_info_r1 (
        pva_array: array [1 .. osc$max_number_of_processors] of ^cell;
        file_id_array: array [1 .. osc$max_number_of_processors] of amt$file_identifier;
        num_of_files: 0 .. 0ff(16));


?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc osc$multiprocessor_constants
?? POP ??
*DECK DECK=OSP$COLLECT_SPI_DATA EXPAND=FALSE
  PROCEDURE [XREF] osp$collect_spi_data
    (VAR collection_file_pointer: ^cell;
     VAR spi_collection_running: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$segment_pointer
*copyc ost$status
?? POP ??
*DECK DECK=OSP$COMPLETE_JOB_RECOVERY EXPAND=FALSE

  PROCEDURE [XREF] osp$complete_job_recovery
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$COMPRESS_FILE_REFERENCE EXPAND=FALSE

  PROCEDURE [XREF] osp$compress_file_reference
    (    file_reference: fst$file_reference;
     VAR compressed_file_reference: fst$file_reference;
     VAR compressed_file_reference_size: fst$path_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc fst$path_size
*copyc ost$status
?? POP ??



*DECK DECK=OSP$CONSOLE_INTERACTION EXPAND=FALSE

  PROCEDURE [XREF] osp$console_interaction;

*DECK DECK=OSP$CONVERT_TO_DIAGNOS_SEVERITY EXPAND=FALSE

  FUNCTION [INLINE] osp$convert_to_diagnos_severity
    (    severity: ost$message_module_severity): ost$diagnostic_severity;

?? PUSH (LISTEXT := ON) ??

    CASE severity OF
    = osc$mm_informative_severity =
      osp$convert_to_diagnos_severity := osc$informative_severity;
    = osc$mm_warning_severity =
      osp$convert_to_diagnos_severity := osc$warning_severity;
    = osc$mm_error_severity =
      osp$convert_to_diagnos_severity := osc$error_severity;
    = osc$mm_fatal_severity =
      osp$convert_to_diagnos_severity := osc$fatal_severity;
    = osc$mm_catastrophic_severity =
      osp$convert_to_diagnos_severity := osc$catastrophic_severity;
    = osc$mm_non_standard_severity =
      osp$convert_to_diagnos_severity := osc$non_standard_severity;
    = osc$mm_dependent_severity =
      osp$convert_to_diagnos_severity := osc$dependent_severity;
    ELSE
      ;
    CASEND;

  FUNCEND osp$convert_to_diagnos_severity;

*copyc ost$diagnostic_severity
*copyc ost$message_module_severity
?? POP ??
*DECK DECK=OSP$CONVERT_TO_REAL_MODEL_NUM EXPAND=FALSE

  PROCEDURE [XREF] osp$convert_to_real_model_num
    (    pseudo_model_number: ost$processor_model_number;
     VAR real_model_number: ost$processor_model_number);

?? PUSH (LISTEXT := ON) ??
*copyc ost$processor_model_number
?? POP ??
*DECK DECK=OSP$CONVERT_TO_STATUS_SEVERITY EXPAND=FALSE

  FUNCTION [INLINE] osp$convert_to_status_severity
    (    severity: ost$message_module_severity): ost$status_severity;

?? PUSH (LISTEXT := ON) ??

    CASE severity OF
    = osc$mm_informative_severity =
      osp$convert_to_status_severity := osc$informative_status;
    = osc$mm_warning_severity =
      osp$convert_to_status_severity := osc$warning_status;
    = osc$mm_error_severity =
      osp$convert_to_status_severity := osc$error_status;
    = osc$mm_fatal_severity =
      osp$convert_to_status_severity := osc$fatal_status;
    = osc$mm_catastrophic_severity =
      osp$convert_to_status_severity := osc$catastrophic_status;
    = osc$mm_non_standard_severity =
      osp$convert_to_status_severity := osc$informative_status;
    = osc$mm_dependent_severity =
      osp$convert_to_status_severity := osc$informative_status;
    ELSE
      ;
    CASEND;

  FUNCEND osp$convert_to_status_severity;

*copyc ost$message_module_severity
*copyc ost$status_severity
?? POP ??
*DECK DECK=OSP$COPY_EXCEPTION_POLICIES EXPAND=FALSE
  PROCEDURE [XREF] osp$copy_exception_policies
    (    from_sequence: ^SEQ ( * );
     VAR to_sequence: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$COPY_INSTALLED_POLICIES EXPAND=FALSE
*DECK DECK=OSP$COPY_LOCAL_STATUS_TO_STATUS EXPAND=FALSE

  PROCEDURE [INLINE] osp$copy_local_status_to_status
    (VAR local_status { input } : ost$status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
  PROCEND osp$copy_local_status_to_status;

*copy osh$copy_local_status_to_status

*copyc ost$status
?? POP ??
*DECK DECK=OSP$DEACTIVATE_OS_STATISTICS EXPAND=FALSE

 PROCEDURE [XREF] osp$deactivate_os_statistics (VAR status: ost$status);

*copyc ost$status
*DECK DECK=OSP$DEACTIVATE_SYSTEM_TASK EXPAND=FALSE

  PROCEDURE [XREF] osp$deactivate_system_task (name: ost$name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=OSP$DEACTIVATE_SYSTEM_TASK_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$deactivate_system_task_r1 (name: ost$name;
        system_job_monitor: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=OSP$DECREMENT_LOCKED_VARIABLE EXPAND=FALSE
 PROCEDURE [INLINE] osp$decrement_locked_variable (VAR variable: integer;
        initial_best_guess: integer;
    VAR actual: integer;
    VAR error: boolean);

{Actual will contain the final contents of the variable.

?? PUSH (LISTEXT := ON) ??

    VAR
      initial: integer,
      result: 0 .. 2;

    error := FALSE;
*IF NOT $true(osv$unix)
    IF initial_best_guess <= 0 THEN
      initial := 1;
    ELSE
      initial := initial_best_guess;
    IFEND;
    REPEAT
      #compare_swap (variable, initial, initial - 1, initial, result);
    UNTIL (result = 0) OR (initial = 0);
    IF result = 0 THEN
      actual := initial - 1;
    ELSE
      error := TRUE;
      actual := 0;
    IFEND;
*ELSE

    IF variable > 0 THEN
      variable := variable - 1;
      actual := variable;
    ELSE
      error := TRUE;
      actual := 0;
    IFEND;

*IFEND
  PROCEND osp$decrement_locked_variable;
?? POP ??
*DECK DECK=OSP$DEFINE_CPU EXPAND=FALSE

  PROCEDURE [XREF] osp$define_cpu
    (    cpu_attributes: dst$cpu_attributes);

?? PUSH (LISTEXT := ON) ??
*copyc dst$cpu_attributes
?? POP ??
*DECK DECK=OSP$DEFINE_SYSTEM_TASK EXPAND=FALSE

  PROCEDURE [XREF] osp$define_system_task (name: ost$name;
        automatic_restart: boolean;
        deactivate_task_option: ost$termination_type;
        idle_task_option: ost$termination_type;
        restart_after_idle: boolean;
        spy_identifier: pmt$spy_identifier;
        execution_ring: ost$valid_ring;
        program_description: ^llt$program_description;
        parameters: ^clt$parameter_list;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc llt$program_description
*copyc osd$virtual_address
*copyc ost$name
*copyc pmt$spy_identifier
*copyc ost$status
*copyc ost$termination_type
?? POP ??
*DECK DECK=OSP$DEFINE_SYSTEM_TASK_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$define_system_task_r1 (name: ost$name;
        automatic_restart: boolean;
        deactivate_task_option: ost$termination_type;
        idle_task_option: ost$termination_type;
        restart_after_idle: boolean;
        spy_identifier: pmt$spy_identifier;
        execution_ring: ost$valid_ring;
        program_description: ^llt$program_description;
        parameters: ^clt$parameter_list;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$termination_type
*copyc pmt$spy_identifier
*copyc osd$virtual_address
*copyc llt$program_description
*copyc clt$parameter_list
*copyc ost$status
?? POP ??

*DECK DECK=OSP$DELETE_FAMILY EXPAND=FALSE
  PROCEDURE [XREF] osp$delete_family
    (    family: ost$name;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=OSP$DELETE_SYSTEM_TASK EXPAND=FALSE

  PROCEDURE [XREF] osp$delete_system_task (name: ost$name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=OSP$DELETE_SYSTEM_TASK_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$delete_system_task_r1 (name: ost$name;
    VAR task_executing: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=OSP$DISESTABLISH_COND_HANDLER EXPAND=FALSE
  PROCEDURE [INLINE] osp$disestablish_cond_handler;

?? PUSH (LISTEXT := ON) ??

    VAR
      psa: ^cell,
      c: cell;

    #WRITE_REGISTER (osc$pr_clear_on_condition, osc$pr_clear_on_condition);
    #WRITE_REGISTER (osc$pr_clear_critical_frame, osc$pr_clear_critical_frame);

  PROCEND osp$disestablish_cond_handler;

*copy osh$disestablish_cond_handler

*copyc osc$processor_defined_registers
?? POP ??


*DECK DECK=OSP$DISPLAY_KEYPOINT_STATUS EXPAND=FALSE

   PROCEDURE [XREF] osp$display_keypoint_status
     (VAR keypoint_control: ost$keypoint_control;
      VAR perf_keypoints: syt$perf_keypoints_enabled;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$keypoint_control
*copyc ost$status
*copyc syt$perf_keypoints_enabled
?? POP ??
*DECK DECK=OSP$DUMP_BROKEN_TASK EXPAND=FALSE

  PROCEDURE [XREF] osp$dump_broken_task
    (    sp: ^array [1 .. 00fffffff(16)] OF cell;
     VAR dump_in_progress: boolean;
     VAR amount: integer);

*DECK DECK=OSP$EMIT_OS_STATISTICS EXPAND=FALSE

 PROCEDURE [XREF] osp$emit_os_statistics;

*DECK DECK=OSP$EMIT_OS_STATISTICS_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$emit_os_statistics_r1
    (    current_time: integer;
     VAR emission_sets_copy: ARRAY [ost$emission_set_names] of ost$emission_set);

?? PUSH (LISTEXT := ON) ??
*copyc osc$statistics
*copyc ost$emission_sets
?? POP ??

*DECK DECK=OSP$END_AAM_ACTIVITY EXPAND=FALSE
  PROCEDURE [XREF] osp$end_aam_activity;

*DECK DECK=OSP$END_AAM_ACTIVITY_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$end_aam_activity_r1;
*DECK DECK=OSP$END_SUBSYSTEM_ACTIVITY EXPAND=FALSE

PROCEDURE [XREF] osp$end_subsystem_activity;
*DECK DECK=OSP$END_SYSTEM_ACTIVITY EXPAND=FALSE

  PROCEDURE [XREF] osp$end_system_activity;
*DECK DECK=OSP$END_TEXT_DUMP EXPAND=FALSE

  PROCEDURE [XREF] osp$end_text_dump;

*DECK DECK=OSP$ENFORCE_EXCEPTION_POLICIES EXPAND=FALSE
  PROCEDURE [XREF] osp$enforce_exception_policies
    (VAR exception_context {input, output} : ost$ecp_exception_context);

?? PUSH (LISTEXT := ON) ??
*copyc ost$ecp_exception_context
?? POP ??
*DECK DECK=OSP$EO_INIT_INTERACTION_INFO EXPAND=FALSE

  PROCEDURE [XREF] osp$eo_init_interaction_info
    (    object: ^clt$environment_object_contents);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
?? POP ??
*DECK DECK=OSP$EO_INIT_MESSAGE_LEVEL EXPAND=FALSE

  PROCEDURE [XREF] osp$eo_init_message_level
    (    object: ^clt$environment_object_contents);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
?? POP ??
*DECK DECK=OSP$EO_INIT_NATURAL_LANGUAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$eo_init_natural_language
    (    object: ^clt$environment_object_contents);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
?? POP ??
*DECK DECK=OSP$EO_POP_NATURAL_LANGUAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$eo_pop_natural_language
    (    pop_reason: clt$env_object_pop_reason;
         object: ^clt$environment_object_contents;
         object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc clt$env_object_pop_reason
*copyc ost$status
?? POP ??
*DECK DECK=OSP$EO_SIZE_INTERACTION_INFO EXPAND=FALSE

  FUNCTION [XREF] osp$eo_size_interaction_info: clt$environment_object_size;

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_size
?? POP ??
*DECK DECK=OSP$EO_SIZE_MESSAGE_LEVEL EXPAND=FALSE

  FUNCTION [XREF] osp$eo_size_message_level: clt$environment_object_size;

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_size
?? POP ??
*DECK DECK=OSP$EO_SIZE_NATURAL_LANGUAGE EXPAND=FALSE

  FUNCTION [XREF] osp$eo_size_natural_language: clt$environment_object_size;

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_size
?? POP ??
*DECK DECK=OSP$ESTABLISH_BLOCK_EXIT_HNDLR EXPAND=FALSE
  PROCEDURE [INLINE] osp$establish_block_exit_hndlr
    (    condition_handler: pmt$condition_handler);

?? PUSH (LISTEXT := ON) ??

{ NOTE:
{   If this procedure or any of the types it uses changes, the procedure
{   pmp$intercept_call_procedure in pmm$intercept_procedures which establishes
{   its own block exit condition handler must also be changed.

    VAR
      stack_frame_word: pmt$os_stack_frame_word,
      os_stack_frame_word: ^pmt$os_stack_frame_word,
      osv$default_block_exit_desc: [XREF] pmt$established_handler,
      establish_descriptor: ^pmt$established_handler;

    PUSH establish_descriptor;

    os_stack_frame_word := #CURRENT_STACK_FRAME ();

    establish_descriptor^ := osv$default_block_exit_desc;
    establish_descriptor^.handler := condition_handler;
    stack_frame_word.established_handler := establish_descriptor;
    stack_frame_word.terminate_inhibit_frame := FALSE;
    stack_frame_word.ada_critical_frame := FALSE;
    stack_frame_word.block_exit_frame := TRUE;
    stack_frame_word.debug_cff_frame := FALSE;
    stack_frame_word.ada_critical_frame_count := 0;
    os_stack_frame_word^ := stack_frame_word;

    #WRITE_REGISTER (osc$pr_set_critical_frame, osc$pr_set_critical_frame);
    #WRITE_REGISTER (osc$pr_set_on_condition, osc$pr_set_on_condition);

  PROCEND osp$establish_block_exit_hndlr;

*copy osh$establish_block_exit_hndlr

*copyc pmt$condition
*copyc pmt$condition_handler
*copyc pmt$established_handler
*copyc pmt$os_stack_frame_word
*copyc osc$processor_defined_registers
*copyc ost$stack_frame_save_area
?? POP ??

*DECK DECK=OSP$ESTABLISH_CONDITION_HANDLER EXPAND=FALSE
  PROCEDURE [INLINE] osp$establish_condition_handler
    (    condition_handler: pmt$condition_handler;
         block_exit: boolean);

?? PUSH (LISTEXT := ON) ??

*IF NOT $true(osv$unix)

    VAR
      stack_frame_word: pmt$os_stack_frame_word,
      os_stack_frame_word: ^pmt$os_stack_frame_word,
      osv$default_establish_desc: [XREF] pmt$established_handler,
      establish_descriptor: ^pmt$established_handler;

    PUSH establish_descriptor;

    os_stack_frame_word := #CURRENT_STACK_FRAME ();

    establish_descriptor^ := osv$default_establish_desc;
    establish_descriptor^.handler := condition_handler;
    stack_frame_word.established_handler := establish_descriptor;
    stack_frame_word.terminate_inhibit_frame := FALSE;
    stack_frame_word.block_exit_frame := FALSE;
    stack_frame_word.debug_cff_frame := FALSE;
    stack_frame_word.ada_critical_frame := FALSE;
    stack_frame_word.ada_critical_frame_count := 0;
    os_stack_frame_word^ := stack_frame_word;

    IF block_exit THEN
      establish_descriptor^.established_conditions.combination :=
            establish_descriptor^.established_conditions.combination +
            $pmt$condition_combination [pmc$block_exit_processing];
      os_stack_frame_word^.block_exit_frame := TRUE;
      #WRITE_REGISTER (osc$pr_set_critical_frame, osc$pr_set_critical_frame);
    IFEND;

    #WRITE_REGISTER (osc$pr_set_on_condition, osc$pr_set_on_condition);

*IFEND

  PROCEND osp$establish_condition_handler;

*copy osh$establish_condition_handler

*copyc pmt$condition
*copyc pmt$condition_handler
*copyc pmt$established_handler
*copyc osc$processor_defined_registers
*copyc ost$stack_frame_save_area
*copyc pmt$os_stack_frame_word
?? POP ??

*DECK DECK=OSP$EXECUTING_IN_JOB_MONITOR EXPAND=FALSE

  FUNCTION [INLINE] osp$executing_in_job_monitor: boolean;

?? PUSH (LISTEXT := ON) ??

    osp$executing_in_job_monitor := #READ_REGISTER (osc$pr_base_constant) =
          osc$job_monitor_xcb_offset;
  FUNCEND osp$executing_in_job_monitor;

*copyc osc$job_monitor_xcb_offset
*copyc osc$processor_defined_registers
?? POP ??
*DECK DECK=OSP$EXPAND_FILE_REFERENCE EXPAND=FALSE

  PROCEDURE [XREF] osp$expand_file_reference
    (    file_reference: fst$file_reference;
     VAR expanded_file_reference: fst$file_reference;
     VAR expanded_file_reference_size: fst$path_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc fst$path_size
*copyc ost$status
?? POP ??
*DECK DECK=OSP$EXPAND_PTL EXPAND=FALSE

  PROCEDURE [XREF] osp$expand_ptl
    (    unconditionally_expand: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$EXTEND_HEAP EXPAND=FALSE

  PROCEDURE [XREF] osp$extend_heap
    (    size: integer;
         heap_p: ^ost$heap;
     VAR page_boundary: ^cell);

?? PUSH (LISTEXT := ON) ??
*copyc ost$heap
?? POP ??
*DECK DECK=OSP$FATAL_SYSTEM_ERROR EXPAND=FALSE

  PROCEDURE [XREF] osp$fatal_system_error (error_message: string ( * );
        status: ^ost$status);
*DECK DECK=OSP$FETCH_COLLECTION_FILE_INFO EXPAND=FALSE

  PROCEDURE [XREF] osp$fetch_collection_file_info
    (VAR pva_array: array [1 .. osc$max_number_of_processors] of ^cell;
     VAR file_id_array: array [1 .. osc$max_number_of_processors] of
          amt$file_identifier;
     VAR num_of_files: 0 .. 0ff(16));

?? PUSH (LISTEXT := ON) ??
*copyc osc$multiprocessor_constants
*copyc amt$file_identifier
?? POP ??
*DECK DECK=OSP$FETCH_KEYPOINT_LOCK EXPAND=FALSE

   PROCEDURE [XREF] osp$fetch_keypoint_lock
     (VAR i: integer);
*DECK DECK=OSP$FETCH_LOCKED_STRING EXPAND=FALSE

 PROCEDURE [INLINE] osp$fetch_locked_string (VAR variable: string (8);
    VAR value: string (8));

?? PUSH (LISTEXT := ON) ??

    VAR
      word_in: string (8),
      result: 0 .. 2;

    { Note: Variable required by cybil.
    word_in := 'DOGDOGDO';

    REPEAT
      #compare_swap (variable, word_in, word_in, value, result);
    UNTIL result <> 2;
    IF result = 0 THEN
      value := '        ';
    IFEND;
  PROCEND osp$fetch_locked_string;
?? POP ??
*DECK DECK=OSP$FETCH_LOCKED_VARIABLE EXPAND=FALSE
 PROCEDURE [INLINE] osp$fetch_locked_variable (VAR variable: integer;
    VAR value: integer);

?? PUSH (LISTEXT := ON) ??

    VAR
      result: 0 .. 2;

*IF NOT $true(osv$unix)
    REPEAT
      #compare_swap (variable, 613, 613, value, result);
    UNTIL result <> 2;
    IF result = 0 THEN
      value := 613;
    IFEND;
*ELSE

    value := variable;

*IFEND
  PROCEND osp$fetch_locked_variable;
?? POP ??
*DECK DECK=OSP$FETCH_MAU_LIST EXPAND=FALSE

 PROCEDURE [XREF] osp$fetch_mau_list
   (    label_file: dmt$deadstart_label_files;
    VAR mau_list_p: ^dmt$mau_address_list;
    VAR mau_count: dmt$mau_count;
    VAR transfer_size: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$deadstart_label_files
*copyc dmt$mau_list
*copyc ost$status
?? POP ??
*DECK DECK=OSP$FETCH_SPI_LOCK EXPAND=FALSE
  PROCEDURE [XREF] osp$fetch_spi_lock
    (VAR i: integer);

*DECK DECK=OSP$FETCH_SYSTEM_CONSTANT EXPAND=FALSE

  PROCEDURE [XREF] osp$fetch_system_constant (VAR name: string ( * );
    VAR index: integer;
    VAR value: integer;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=OSP$FILE_ACCESS_CONDITION EXPAND=FALSE
  FUNCTION [XREF] osp$file_access_condition
    (    status: ost$status): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=OSP$FIND_ACCESS_CONDITION_ENTRY EXPAND=FALSE
  PROCEDURE [XREF] osp$find_access_condition_entry
    (    file_access_condition: fst$file_access_condition;
     VAR access_condition_entry: fst$access_condition_entry;
     VAR entry_found: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc fst$access_condition_entry
*copyc fst$file_access_condition
?? POP ??

*DECK DECK=OSP$FIND_APPLICABLE_POLICY EXPAND=FALSE
  PROCEDURE [XREF] osp$find_applicable_policy
    (    criteria: ost$ecp_criteria;
         policies_sequence_header: ^ost$ecp_header;
     VAR applicable_actions: ost$ecp_actions;
     VAR applicable_policy: ^ost$ecp_policy_header;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$exception_policies
*copyc ost$status
?? POP ??
*DECK DECK=OSP$FIND_APPLICATION_MENU EXPAND=FALSE

  PROCEDURE [XREF] osp$find_application_menu
    (    help_module: ^ost$help_module;
         menu_name: ost$application_menu_name;
     VAR menu_classes: cst$menu_class;
     VAR menu_items: cst$menu_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cst$menu_class
*copyc cst$menu_list
*copyc ost$application_menu_name
*copyc ost$help_module
*copyc ost$status
?? POP ??
*DECK DECK=OSP$FIND_BRIEF_HELP_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$find_brief_help_message
    (    help_module: ^ost$help_module;
     VAR message_template: ^ost$message_template;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$help_module
*copyc ost$message_template
*copyc ost$status
?? POP ??
*DECK DECK=OSP$FIND_FULL_HELP_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$find_full_help_message
    (    help_module: ^ost$help_module;
     VAR message_template: ^ost$message_template;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$help_module
*copyc ost$message_template
*copyc ost$status
?? POP ??
*DECK DECK=OSP$FIND_HELP_MODULE EXPAND=FALSE

  PROCEDURE [XREF] osp$find_help_module
    (    seed_name: pmt$program_name;
     VAR help_module: ^ost$help_module;
     VAR online_manual_name: ost$online_manual_name;
     VAR natural_language: ost$natural_language;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$help_module
*copyc ost$name
*copyc ost$natural_language
*copyc ost$online_manual_name
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=OSP$FIND_HELP_MODULE_IN_LIBRARY EXPAND=FALSE

  PROCEDURE [XREF] osp$find_help_module_in_library
    (    object_library: ^SEQ ( * );
         seed_name: pmt$program_name;
     VAR help_module: ^ost$help_module;
     VAR online_manual_name: ost$online_manual_name;
     VAR natural_language: ost$natural_language;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$help_module
*copyc ost$name
*copyc ost$natural_language
*copyc ost$online_manual_name
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=OSP$FIND_INTERACTION_INFO EXPAND=FALSE

  PROCEDURE [INLINE] osp$find_interaction_info
    (VAR interaction_information: ^clt$interaction_information);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_object_in_current_task: boolean,
      object: ^clt$environment_object_contents;


    clp$find_environment_object (clc$eo_interaction_information, object,
          ignore_object_in_current_task);

    interaction_information := object;

  PROCEND osp$find_interaction_info;

*copyc clt$interaction_information
?? POP ??
*copyc clp$find_environment_object
*DECK DECK=OSP$FIND_INTER_INFO_FIRST_TIME EXPAND=FALSE
*DECK DECK=OSP$FIND_MSG_LEVEL_FIRST_TIME EXPAND=FALSE
*DECK DECK=OSP$FIND_NATURAL_LANGUAGE EXPAND=FALSE

  PROCEDURE [INLINE] osp$find_natural_language
    (VAR natural_language: ^ost$natural_language);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_object_in_current_task: boolean,
      object: ^clt$environment_object_contents;


    clp$find_environment_object (clc$eo_natural_language, object,
          ignore_object_in_current_task);

    natural_language := object;

  PROCEND osp$find_natural_language;

*copyc ost$natural_language
?? POP ??
*copyc clp$find_environment_object
*DECK DECK=OSP$FIND_NAT_LANG_FIRST_TIME EXPAND=FALSE
*DECK DECK=OSP$FIND_PARAMETER_HELP_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$find_parameter_help_message
    (    help_module: ^ost$help_module;
         parameter_name: clt$parameter_name;
     VAR message_template: ^ost$message_template;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_name
*copyc ost$help_module
*copyc ost$message_template
*copyc ost$status
?? POP ??
*DECK DECK=OSP$FIND_PARAMETER_PROMPT EXPAND=FALSE

  PROCEDURE [XREF] osp$find_parameter_prompt
    (    help_module: ^ost$help_module;
         parameter_name: clt$parameter_name;
     VAR prompt_template: ^ost$message_template;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_name
*copyc ost$help_module
*copyc ost$message_template
*copyc ost$status
?? POP ??
*DECK DECK=OSP$FIND_PARAM_ASSIST_PROMPT EXPAND=FALSE

  PROCEDURE [XREF] osp$find_param_assist_prompt
    (    help_module: ^ost$help_module;
         parameter_name: clt$parameter_name;
     VAR prompt_template: ^ost$message_template;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_name
*copyc ost$help_module
*copyc ost$message_template
*copyc ost$status
?? POP ??
*DECK DECK=OSP$FIND_STATUS_MESSAGE_BY_CODE EXPAND=FALSE

  PROCEDURE [XREF] osp$find_status_message_by_code
    (    help_module: ^ost$help_module;
         condition_code: ost$status_condition_code;
     VAR condition_name: ost$status_condition_name;
     VAR condition_severity: ost$status_severity;
     VAR message_template: ^ost$message_template;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$help_module
*copyc ost$message_template
*copyc ost$status
*copyc ost$status_condition_code
*copyc ost$status_condition_name
*copyc ost$status_severity
?? POP ??
*DECK DECK=OSP$FIND_STATUS_MESSAGE_BY_NAME EXPAND=FALSE

  PROCEDURE [XREF] osp$find_status_message_by_name
    (    help_module: ^ost$help_module;
         condition_name: ost$status_condition_name;
     VAR condition_code: ost$status_condition_code;
     VAR condition_severity: ost$status_severity;
     VAR message_template: ^ost$message_template;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$help_module
*copyc ost$message_template
*copyc ost$status
*copyc ost$status_condition_code
*copyc ost$status_condition_name
*copyc ost$status_severity
?? POP ??
*DECK DECK=OSP$FIND_STATUS_MESSAGE_LEVEL EXPAND=FALSE

  PROCEDURE [INLINE] osp$find_status_message_level
    (VAR status_message_level: ^ost$status_message_level);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_object_in_current_task: boolean,
      object: ^clt$environment_object_contents;


    clp$find_environment_object (clc$eo_message_level, object,
          ignore_object_in_current_task);

    status_message_level := object;

  PROCEND osp$find_status_message_level;

*copyc ost$status_message_level
?? POP ??
*copyc clp$find_environment_object
*DECK DECK=OSP$FLUSH_ALLOCATION_INFO EXPAND=FALSE

PROCEDURE [XREF] osp$flush_allocation_info (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=OSP$FORCE_ACCESS_VIOLATION EXPAND=FALSE

  PROCEDURE [INLINE] osp$force_access_violation;

?? PUSH (LISTEXT := ON) ??
    CONST
      bad_offset = 0bad0ca0(16);

    VAR
      p: ^integer;

{ Form an illegal address.

    p := #ADDRESS (1, 0, bad_offset);

{ Cause an access violation by dereferencing the pointer.

    p^ := 0;
  PROCEND osp$force_access_violation;
?? POP ??
*DECK DECK=OSP$FORMAT_HELP_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$format_help_message
    (    message_template: ^ost$message_template;
         message_parameters: ^ost$message_parameters;
         max_message_line: ost$max_status_message_line;
     VAR message: ost$status_message;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$max_status_message_line
*copyc ost$message_parameters
*copyc ost$message_template
*copyc ost$status
*copyc ost$status_message
?? POP ??
*DECK DECK=OSP$FORMAT_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$format_message ALIAS 'ospfmsg'
    (    message_status: ost$status;
         message_level: ost$format_message_level;
         max_message_line: ost$max_status_message_line;
     VAR message: ost$status_message;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$format_message_level
*copyc ost$max_status_message_line
*copyc ost$status
*copyc ost$status_message
?? POP ??
*DECK DECK=OSP$FORMAT_MULTI_PART_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$format_multi_part_message
    (    message_level: ost$format_message_level;
         message_header_kind: ost$status_message_header_kind;
         max_message_line: ost$status_message_line_size;
         status_condition: ost$status_condition;
         message_parameters: ^ost$message_parameters;
         get_message_part: ost$get_message_part;
     VAR message: SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$format_message_level
*copyc ost$get_message_part
*copyc ost$message_parameters
*copyc ost$status
*copyc ost$status_condition_code
*copyc ost$status_message_header_kind
*copyc ost$status_message_line_size
?? POP ??
*DECK DECK=OSP$FORMAT_SEGMENT_CONDITION EXPAND=FALSE

  PROCEDURE [XREF] osp$format_segment_condition (identifier: string (2);
        segment_access_condition: mmt$segment_access_condition;
        save_area: ^ost$stack_frame_save_area;
    VAR message: ost$status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc MMD$SEGMENT_ACCESS_CONDITION
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc OST$STATUS
*copyc OSE$CONDITION_EXCEPTIONS
?? POP ??
*DECK DECK=OSP$FORMAT_SYSTEM_CONDITION EXPAND=FALSE

  PROCEDURE [XREF] osp$format_system_condition (system_condition: pmt$system_condition;
        untranslatable_pointer: ost$pva;
        save_area: ^ost$stack_frame_save_area;
    VAR message: ost$status);

*copyc PMT$CONDITION
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc OST$STATUS
*DECK DECK=OSP$FORMAT_WAIT_MESSAGE EXPAND=FALSE
  PROCEDURE [XREF] osp$format_wait_message
    (    access_condition_entry: ^fst$access_condition_entry;
         file: ^fst$file_reference;
         mass_storage_class: rmt$mass_storage_class;
         volume_condition_list: ^fst$volume_condition_list;
         volume_list: ^rmt$volume_list;
     VAR wait_message: oft$display_message);

?? PUSH (LISTEXT := ON) ??
*copyc fst$access_condition_entry
*copyc fst$file_reference
*copyc fst$volume_condition_list
*copyc oft$display_message
*copyc rmt$mass_storage_class
*copyc rmt$volume_list
?? POP ??
*DECK DECK=OSP$FREE_EMISSION_SETS EXPAND=FALSE


  PROCEDURE [XREF] osp$free_emission_sets (VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc osc$statistics
*copyc ost$status
?? POP ??
*DECK DECK=OSP$FREE_HEAP_PAGES EXPAND=FALSE



  PROCEDURE [XREF] osp$free_heap_pages (xhp: ^ost$heap);

?? PUSH (LISTEXT := ON) ??
*copyc ost$heap
?? POP ??
*DECK DECK=OSP$FREE_SPI_ENVIRONMENT EXPAND=FALSE
  PROCEDURE [XREF] osp$free_spi_environment
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$FREE_SPI_ENVIRONMENT_R1 EXPAND=FALSE
  PROCEDURE [XREF] osp$free_spi_environment_r1
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GENERATE_ERROR_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$generate_error_message ALIAS 'ospgemg'
    (    message_status: ost$status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GENERATE_LOG_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$generate_log_message ALIAS 'ospglgm'
    (    logs: pmt$ascii_logset;
         message_status: ost$status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmd$system_log_interface
?? POP ??
*DECK DECK=OSP$GENERATE_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$generate_message ALIAS 'ospgmsg'
    (    message_status: ost$status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GENERATE_OUTPUT_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$generate_output_message
    (    message_status: ost$status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GENERATE_UNIQUE_BINARY_NAME EXPAND=FALSE
  PROCEDURE [XREF] osp$generate_unique_binary_name
    (VAR name: ost$binary_unique_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$unique_name
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GET_ACCESSED_CLIENTS EXPAND=FALSE

  PROCEDURE [XREF] osp$get_accessed_clients
    (    p_binary_client_list {output} : ^array [1 .. * ] of
          pmt$binary_mainframe_id;
     VAR client_count: 0 .. dfc$maximum_partner_mainframes);

?? PUSH (LISTEXT := ON) ??
*copyc dft$partner_mainframe_list
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=OSP$GET_ACCESSED_FAMILIES EXPAND=FALSE
  PROCEDURE [XREF] osp$get_accessed_families
    (    p_family_list {output} : ^array [1 .. * ] of ost$family_name;
     VAR family_count: 0 .. dfc$max_family_ptr_array_size);


?? PUSH (LISTEXT := ON) ??
*copyc dft$served_family_table_index
*copyc ost$user_identification
?? POP ??
*DECK DECK=OSP$GET_ACCESS_CONDITION_ENTRY EXPAND=FALSE
  PROCEDURE [XREF] osp$get_access_condition_entry
    (VAR status {input, output} : ost$status;
     VAR access_condition_entry: fst$access_condition_entry;
     VAR entry_found: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc fst$access_condition_entry
*copyc fst$file_access_condition
*copyc ost$status
?? POP ??

*DECK DECK=OSP$GET_AGING_STATS EXPAND=FALSE

  PROCEDURE [XREF] osp$get_aging_stats (
        incremental: boolean;
    VAR user_aging_stats: ost$aging_stats;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$DATA_ID
?? POP ??
*DECK DECK=OSP$GET_CAUSE_OF_IDLE EXPAND=FALSE

  PROCEDURE [XREF] osp$get_cause_of_idle (VAR idle_code: syt$180_idle_code);

?? PUSH (LISTEXT := ON) ??
*copyc syt$180_idle_code
?? POP ??
*DECK DECK=OSP$GET_CAUSE_OF_IDLE_R3 EXPAND=FALSE
  PROCEDURE [XREF] osp$get_cause_of_idle_r3
     (VAR idle_code: syt$180_idle_code);

?? PUSH (LISTEXT := ON) ??
*copyc syt$180_idle_code
?? POP ??

*DECK DECK=OSP$GET_CLIENT_FAMILY_ACCESS EXPAND=FALSE
  PROCEDURE [XREF] osp$get_client_family_access (
        client_binary_id: pmt$binary_mainframe_id;
        family_name: ost$family_name;
    VAR family_access: dft$family_access);

?? PUSH (LISTEXT := ON)??
*copyc dft$family_access
*copyc ost$user_identification
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=OSP$GET_CONDITION_STATUS EXPAND=FALSE
  PROCEDURE [XREF] osp$get_condition_status
    (    exception_context: ^cell;
     VAR condition_status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$ecp_exception_context
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GET_CPU_MODEL_DEFINITION EXPAND=FALSE

  PROCEDURE [XREF] osp$get_cpu_model_definition
    (    search_data: ost$processor_search_data;
     VAR definition_found: boolean;
     VAR processor_model_definition: ost$processor_model_definition);

?? PUSH (LISTEXT := ON) ??
*copyc ost$processor_model_definitions
?? POP ??
*DECK DECK=OSP$GET_CPU_STATS EXPAND=FALSE

  PROCEDURE [XREF] osp$get_cpu_stats (
        incremental: boolean;
    VAR user_cpu_stats: ost$cpu_stats;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$DATA_ID
?? POP ??
*DECK DECK=OSP$GET_CURRENT_DISPLAY_MESSAGE EXPAND=FALSE
  PROCEDURE [XREF] osp$get_current_display_message
    (VAR current_display_message: oft$display_message);

?? PUSH (LISTEXT := ON) ??
*copyc oft$display_message
?? POP ??

*DECK DECK=OSP$GET_DIAGNOSTIC_SEVERITY EXPAND=FALSE

  PROCEDURE [XREF] osp$get_diagnostic_severity ALIAS 'ospgsv'
    (    condition: ost$status_condition;
     VAR severity: ost$diagnostic_severity;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$diagnostic_severity
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GET_DISK_SPACE_STATS EXPAND=FALSE

  PROCEDURE [XREF] osp$get_disk_space_stats (
     VAR user_disk_space_stats: ost$disk_space_stats);

?? PUSH (LISTEXT := ON) ??
*copyc OST$DATA_ID
?? POP ??
*DECK DECK=OSP$GET_FAMILIES_FOR_CLIENT EXPAND=FALSE

  PROCEDURE [XREF] osp$get_families_for_client
    (    client_binary_id: pmt$binary_mainframe_id;
         p_family_list { output } : ^array [1 .. * ] of ost$family_name;
         p_access_list { output } : ^array [1 .. * ] of dft$family_access;
     VAR family_count: 0 .. dfc$max_family_ptr_array_size);

?? PUSH (LISTEXT := ON) ??
*copyc dft$family_access
*copyc dft$served_family_table_index
*copyc ost$user_identification
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=OSP$GET_FAMILY_NAMES EXPAND=FALSE
  PROCEDURE [XREF] osp$get_family_names (
    VAR family_names: pmt$family_name_list;
    VAR name_count: pmt$family_name_count;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$program_services_exceptions
*copyc pmt$family_name_count
*copyc pmt$family_name_list
?? POP ??
*DECK DECK=OSP$GET_FAMILY_NAMES_BY_SET EXPAND=FALSE

  PROCEDURE [XREF] osp$get_family_names_by_set
    (    set_name: stt$set_name;
     VAR family_names: pmt$family_name_list;
     VAR name_count: pmt$family_name_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$program_services_exceptions
*copyc pmt$family_name_count
*copyc pmt$family_name_list
?? POP ??
*DECK DECK=OSP$GET_FILE_CRITERIA EXPAND=FALSE
  PROCEDURE [XREF] osp$get_file_criteria
    (    file: ost$ecp_file_identification;
         catalog_object: boolean;
         catalog_space_unavailable: boolean;
         password: pft$name;
     VAR work_area {input, output} : ^SEQ ( * );
     VAR criteria: ost$ecp_criteria;
     VAR volume_condition_list: ^fst$volume_condition_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$goi_object
*copyc fst$goi_object_information
*copyc fst$volume_condition_list
*copyc osd$exception_policies
*copyc pfd$permanent_file_definitions
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GET_FULL_HELP_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$get_full_help_message
    (    seed_name: pmt$program_name;
         message_parameters: ^ost$message_parameters;
         max_message_line: ost$max_status_message_line;
     VAR message: ost$status_message;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$max_status_message_line
*copyc ost$message_parameters
*copyc ost$status
*copyc ost$status_message
*copyc pmt$program_name
?? POP ??
*DECK DECK=OSP$GET_GLOBAL_CPU_MODEL_DEF EXPAND=FALSE

  PROCEDURE [XREF] osp$get_global_cpu_model_def
    (VAR global_processor_model_def: ost$processor_model_definition);

?? PUSH (LISTEXT := ON) ??
*copyc ost$processor_model_definitions
?? POP ??
*DECK DECK=OSP$GET_HELP_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$get_help_message
    (    seed_name: pmt$program_name;
         parameter_name: clt$parameter_name;
         message_parameters: ^ost$message_parameters;
         max_message_line: ost$max_status_message_line;
     VAR message: ost$status_message;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_name
*copyc ost$max_status_message_line
*copyc ost$message_parameters
*copyc ost$status
*copyc ost$status_message
*copyc pmt$program_name
?? POP ??
*DECK DECK=OSP$GET_INSTALLED_POLICIES EXPAND=FALSE
  PROCEDURE [XREF] osp$get_installed_policies
    (VAR installed_policies: ^SEQ ( * );
     VAR sequence_header: ^ost$ecp_header;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$exception_policies
*copyc ost$status
?? POP ??

*DECK DECK=OSP$GET_INTERACTION_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] osp$get_interaction_information
    (VAR interaction_information {input, output}: ost$interaction_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ose$message_gen_exceptions
*copyc ost$interaction_information
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GET_INTERACTION_STYLE EXPAND=FALSE

  PROCEDURE [XREF] osp$get_interaction_style
    (VAR interaction_style: ost$interaction_style;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$interaction_style
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GET_JM_MM_STATS EXPAND=FALSE

  PROCEDURE [XREF] osp$get_jm_mm_stats (
        incremental: boolean;
    VAR user_jm_mm_stats: ost$jm_mm_stats;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$DATA_ID
?? POP ??
*DECK DECK=OSP$GET_JOB_CLASS_STATS EXPAND=FALSE


  PROCEDURE [XREF] osp$get_job_class_stats
    (    incremental: boolean;
     VAR user_job_class_stats: ost$job_class_stats;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$data_id
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GET_JOB_STATS EXPAND=FALSE

  PROCEDURE [XREF] osp$get_job_stats (
        incremental: boolean;
    VAR user_job_stats: ost$job_stats;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$DATA_ID
?? POP ??
*DECK DECK=OSP$GET_JOB_TEMPLATE_NAME EXPAND=FALSE

  PROCEDURE [XREF] osp$get_job_template_name
    (VAR job_template_name: ost$name);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=OSP$GET_LOCKED_VARIABLE_VALUE EXPAND=FALSE

  PROCEDURE [INLINE] osp$get_locked_variable_value
    (VAR variable: integer;
         expected_value: integer;
     VAR actual_value: integer);

?? PUSH (LISTEXT := ON) ??
*copy osh$get_locked_variable_value

    VAR
      initial: integer,
      result: 0 .. 2;

    IF expected_value < 0 THEN
      initial := 0;
    ELSE
      initial := expected_value;
    IFEND;

    REPEAT
      #COMPARE_SWAP (variable, initial, initial, actual_value, result);
    UNTIL (result <> 2);

  PROCEND osp$get_locked_variable_value;
?? POP ??
*DECK DECK=OSP$GET_LOGIN_USER_CRITERIA EXPAND=FALSE
  PROCEDURE [XREF] osp$get_login_user_criteria
    (VAR criteria: ost$ecp_criteria;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$exception_policies
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GET_MESSAGE_LEVEL EXPAND=FALSE

  PROCEDURE [XREF] osp$get_message_level
    (VAR message_level: ost$status_message_level;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$status_message_level
?? POP ??
*DECK DECK=OSP$GET_MTR_STATS EXPAND=FALSE

  PROCEDURE [XREF] osp$get_mtr_stats (
        incremental: boolean;
    VAR user_mtr_stats: ost$mtr_stats;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$DATA_ID
?? POP ??
*DECK DECK=OSP$GET_NATURAL_LANGUAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$get_natural_language
    (VAR natural_language: ost$natural_language;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$natural_language
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GET_PAGE_STATS EXPAND=FALSE

  PROCEDURE [XREF] osp$get_page_stats (
        incremental: boolean;
    VAR user_page_stats: ost$page_fault_stats;
    VAR user_server_page_stats: ost$page_fault_stats;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$DATA_ID
?? POP ??
*DECK DECK=OSP$GET_PAGING_STATS EXPAND=TRUE

  PROCEDURE [XREF] osp$get_paging_stats (
        incremental: boolean;
    VAR user_paging_stats: ost$paging_stats;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$DATA_ID
?? POP ??
*DECK DECK=OSP$GET_PARAMETER_HELP_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$get_parameter_help_message
    (    seed_name: pmt$program_name;
         parameter_name: clt$parameter_name;
         message_parameters: ^ost$message_parameters;
         max_message_line: ost$max_status_message_line;
     VAR message: ost$status_message;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_name
*copyc ost$max_status_message_line
*copyc ost$message_parameters
*copyc ost$status
*copyc ost$status_message
*copyc pmt$program_name
?? POP ??
*DECK DECK=OSP$GET_PARAMETER_PROMPT EXPAND=FALSE

  PROCEDURE [XREF] osp$get_parameter_prompt
    (    seed_name: pmt$program_name;
         parameter_name: clt$parameter_name;
         message_parameters: ^ost$message_parameters;
         max_message_line: ost$max_status_message_line;
     VAR message: ost$status_message;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_name
*copyc ost$max_status_message_line
*copyc ost$message_parameters
*copyc ost$status
*copyc ost$status_message
*copyc pmt$program_name
?? POP ??
*DECK DECK=OSP$GET_PIO_PP_STATS EXPAND=FALSE

  PROCEDURE [XREF] osp$get_pio_pp_stats (
        incremental: boolean;
    VAR user_pio_pp_stats: ost$disk_pp_stats;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$DATA_ID
?? POP ??
*DECK DECK=OSP$GET_PIO_UNIT_STATS EXPAND=FALSE

  PROCEDURE [XREF] osp$get_pio_unit_stats (
        incremental: boolean;
    VAR user_pio_unit_stats: ost$disk_unit_stats;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$DATA_ID
?? POP ??
*DECK DECK=OSP$GET_PIO_USAGE_STATS EXPAND=FALSE

  PROCEDURE [XREF] osp$get_pio_usage_stats (
        incremental: boolean;
    VAR user_pio_usage_stats: ost$disk_usage_stats;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$DATA_ID
?? POP ??
*DECK DECK=OSP$GET_POLICY EXPAND=FALSE
  PROCEDURE [XREF] osp$get_policy
    (    policy_number: ost$positive_integers;
         policies_sequence_header: ost$ecp_header;
     VAR policy: ^ost$ecp_policy_header);

?? PUSH (LISTEXT := ON) ??
*copyc osd$exception_policies
*copyc osd$integer_limits
?? POP ??
*DECK DECK=OSP$GET_POLICY_LIST EXPAND=FALSE
  PROCEDURE [XREF] osp$get_policy_list
    (    policies_sequence_header: ost$ecp_header;
     VAR result: ^clt$data_value;
     VAR work_area {input, output} : ^clt$work_area);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc clt$work_area
*copyc osd$exception_policies
?? POP ??
*DECK DECK=OSP$GET_PP_UNIT_COUNT EXPAND=FALSE

  PROCEDURE [XREF] osp$get_pp_unit_count (
    VAR pp_count: integer;
    VAR unit_count: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GET_RELEVANT_PATH_STRING EXPAND=FALSE
  PROCEDURE [XREF] osp$get_relevant_path_string
    (    path: fst$file_reference;
     VAR relevant_path: fst$file_reference;
     VAR relevant_path_size: fst$path_size);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc fst$path_size
?? POP ??
*DECK DECK=OSP$GET_RUNNING_SYSTEM_TASKS EXPAND=FALSE

  PROCEDURE [XREF] osp$get_running_system_tasks (
    VAR running_tasks: array [1 .. *] of ost$name;
    VAR number_of_running_tasks: integer);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=OSP$GET_RVSN_BY_LUN EXPAND=FALSE

  PROCEDURE [XREF] osp$get_rvsn_by_lun (lun: iot$logical_unit;
    VAR rvsn: rmt$recorded_vsn;
    VAR entry_found: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=OSP$GET_SCHED_STATS EXPAND=FALSE

  PROCEDURE [XREF] osp$get_sched_stats (
        incremental: boolean;
    VAR user_sched_stats: ost$sched_stats;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$DATA_ID
?? POP ??
*DECK DECK=OSP$GET_SERVICE_CLASS_STATS EXPAND=FALSE

  PROCEDURE [XREF] osp$get_service_class_stats
    (    incremental: boolean;
     VAR user_serv_class_stats: ost$service_class_stats;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$data_id
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GET_SET_NAME EXPAND=FALSE
  PROCEDURE [INLINE] osp$get_set_name
    (    family: ost$name;
     VAR set_name: stt$set_name;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??

    VAR
      i: integer;

    status.normal := TRUE;

    IF osv$family_table <> NIL THEN
      FOR i := 1 TO UPPERBOUND (osv$family_table^) DO
        IF osv$family_table^ [i].family_name = family THEN
          set_name := osv$family_table^ [i].set_name;
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_family, family, status);
  PROCEND osp$get_set_name;
*copyc pfe$error_condition_codes
*copyc osp$set_status_abnormal
*copyc osv$family_table
?? POP ??
*DECK DECK=OSP$GET_STATUS_CONDITION_CODE EXPAND=FALSE

  PROCEDURE [XREF] osp$get_status_condition_code
    (    name: ost$status_condition_name;
     VAR code: ost$status_condition_code;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$status_condition_code
*copyc ost$status_condition_name
?? POP ??
*DECK DECK=OSP$GET_STATUS_CONDITION_NAME EXPAND=FALSE

  PROCEDURE [XREF] osp$get_status_condition_name
    (    code: ost$status_condition_code;
     VAR name: ost$status_condition_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$status_condition_code
*copyc ost$status_condition_name
?? POP ??
*DECK DECK=OSP$GET_STATUS_CONDITION_STRING EXPAND=FALSE

  PROCEDURE [XREF] osp$get_status_condition_string
    (    condition: ost$status_condition_code;
     VAR str: ost$string;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$status_condition_code
*copyc ost$string
?? POP ??
*DECK DECK=OSP$GET_STATUS_MESSAGE_BY_CODE EXPAND=FALSE

  PROCEDURE [XREF] osp$get_status_message_by_code
    (    condition_code: ost$status_condition_code;
     VAR condition_name: ost$status_condition_name;
     VAR status_severity: ost$status_severity;
     VAR diagnostic_severity: ost$diagnostic_severity;
     VAR message_template: ^ost$message_template;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$diagnostic_severity
*copyc ost$message_template
*copyc ost$status
*copyc ost$status_condition_code
*copyc ost$status_condition_name
*copyc ost$status_severity
?? POP ??
*DECK DECK=OSP$GET_STATUS_SEVERITY EXPAND=FALSE

  PROCEDURE [XREF] osp$get_status_severity ALIAS 'ospgsv'
    (    condition: ost$status_condition;
     VAR severity: ost$status_severity;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$status_severity
?? POP ??
*DECK DECK=OSP$GET_SWAP_FILE_STATISTICS EXPAND=FALSE

  PROCEDURE [XREF] osp$get_swap_file_statistics (
        incremental: boolean;
    VAR swap_file_stats_enabled: boolean;
    VAR user_swap_file_stats: ost$swap_file_stats;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$data_id
?? POP ??
*DECK DECK=OSP$GET_SWAP_STATS EXPAND=FALSE

  PROCEDURE [XREF] osp$get_swap_stats (
        incremental: boolean;
    VAR user_swap_stats: ost$swap_stats;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$DATA_ID
?? POP ??
*DECK DECK=OSP$GET_SYSTEM_CONSTANT EXPAND=FALSE

  PROCEDURE [XREF] osp$get_system_constant
    (VAR name: string ( * );
     VAR index: integer;
     VAR value: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GET_SYSTEM_TASK_DATA EXPAND=FALSE

  PROCEDURE [XREF] osp$get_system_task_data
    (    criteria: ost$system_task_data_criteria;
     VAR system_task_data: ost$system_task_display_data;
     VAR system_task_count: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$system_task_data_criteria
*copyc ost$system_task_display_data
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GET_SYSTEM_TASK_DATA_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$get_system_task_data_r1
    (    criteria: ost$system_task_data_criteria;
     VAR system_task_data: ost$system_task_display_data;
     VAR system_task_count: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$system_task_data_criteria
*copyc ost$system_task_display_data
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GET_UNION_OF_POLICIES EXPAND=FALSE
  PROCEDURE [XREF] osp$get_union_of_policies
    (    policies_sequence_header: ^ost$ecp_header;
     VAR exception_conditions: ost$ecp_conditions;
     VAR policy_criteria: ost$ecp_policy_criteria;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$exception_policies
*copyc ost$status
?? POP ??
*DECK DECK=OSP$GET_UNIVERSAL_TASK_ID EXPAND=FALSE
 PROCEDURE [XREF] osp$get_universal_task_id
    (VAR universal_task_id: ost$universal_task_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$universal_task_id
?? POP ??
*DECK DECK=OSP$GET_VOLUME_CONDITION EXPAND=FALSE

  FUNCTION [INLINE] osp$get_volume_condition
    (    unique_volume_desc: pft$unique_volume_desc): fst$file_access_condition;

?? PUSH (LISTEXT := ON) ??

    VAR
      avt_index: ost$non_negative_integers;

    osp$get_volume_condition := fsc$media_missing;

  /avt_loop/
    FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^)
          TO UPPERBOUND (dmv$p_active_volume_table^) DO
      IF (NOT dmv$p_active_volume_table^ [avt_index].entry_available) AND
            (dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn =
            unique_volume_desc.recorded_vsn) THEN

        IF (dmv$p_active_volume_table^ [avt_index].mass_storage.internal_vsn =
              unique_volume_desc.internal_vsn) THEN
          IF dmv$p_active_volume_table^ [avt_index].mass_storage.volume_unavailable THEN
            osp$get_volume_condition := fsc$volume_unavailable;
          ELSEIF dmv$p_active_volume_table^ [avt_index].mass_storage.space_gone THEN
            osp$get_volume_condition := fsc$space_unavailable;
          ELSE
            osp$get_volume_condition := fsc$null_file_access_condition;
          IFEND;
          EXIT /avt_loop/;
        IFEND;
      IFEND;
    FOREND /avt_loop/;

  FUNCEND osp$get_volume_condition;

*copyc dmv$active_volume_table
*copyc fst$file_access_condition
*copyc osd$integer_limits
*copyc pft$unique_volume_desc
?? POP ??
*DECK DECK=OSP$HANDLE_KEYP_ENVIRON_CHANGE EXPAND=FALSE

  PROCEDURE [XREF] osp$handle_keyp_environ_change
    (    flag_id: ost$system_flag);

?? PUSH (LISTEXT := ON) ??
*copyc ost$system_flag
?? POP ??
*DECK DECK=OSP$IDLE_REQUESTED EXPAND=FALSE

  FUNCTION [XREF] osp$idle_requested: boolean;
*DECK DECK=OSP$IDLE_REQUESTED_R1 EXPAND=FALSE

  FUNCTION [XREF] osp$idle_requested_r1: boolean;

*DECK DECK=OSP$IDLE_RESUME_SYSTEM_JOB EXPAND=FALSE

  PROCEDURE [XREF] osp$idle_resume_system_job (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$INCREMENT_LOCKED_VARIABLE EXPAND=FALSE
 PROCEDURE [INLINE] osp$increment_locked_variable (VAR variable: integer;
        initial_best_guess: integer;
    VAR actual: integer);

{Actual will contain the final contents of the variable.

?? PUSH (LISTEXT := ON) ??

    VAR
      initial: integer,
      result: 0 .. 2;

*IF NOT $true(osv$unix)
    IF initial_best_guess < 0 THEN
      initial := 0;
    ELSE
      initial := initial_best_guess;
    IFEND;
    REPEAT
      #compare_swap (variable, initial, initial + 1, initial, result);
    UNTIL result = 0;
    actual := initial + 1;
*ELSE

    variable := variable + 1;
    actual := variable;

*IFEND
  PROCEND osp$increment_locked_variable;
?? POP ??
*DECK DECK=OSP$INITIALIZE_DATE_TIME EXPAND=FALSE

  PROCEDURE [XREF] osp$initialize_date_time
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$INITIALIZE_PTL EXPAND=FALSE

  PROCEDURE [XREF] osp$initialize_ptl;
*DECK DECK=OSP$INITIALIZE_SC_DEBUGGER EXPAND=FALSE
PROCEDURE [XREF] osp$initialize_sc_debugger;
*DECK DECK=OSP$INITIALIZE_SIGNATURE_LOCK EXPAND=FALSE

  PROCEDURE [XREF] osp$initialize_signature_lock (VAR lock: ost$signature_lock;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc ost$signature_lock
?? POP ??
*DECK DECK=OSP$INITIALIZE_SIG_LOCK EXPAND=FALSE
procedure [INLINE] osp$initialize_sig_lock (var lock: ost$signature_lock);
??PUSH (LISTEXT := ON) ??

*copyc osh$initialize_signature_lock
lock.lock_id := 0;
procend osp$initialize_sig_lock;
*copyc ost$signature_lock
??POP??
*DECK DECK=OSP$INITIALIZE_SPI_COLLECTOR_R1 EXPAND=FALSE
  PROCEDURE [XREF] osp$initialize_spi_collector_r1
    (VAR spi_control: ost$spi_control;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$spi_control
?? POP ??
*DECK DECK=OSP$INITIALIZE_SPI_ENVIRONMENT EXPAND=FALSE
  PROCEDURE [XREF] osp$initialize_spi_environment
    (VAR spi_control: ost$spi_control;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$spi_control
*copyc ost$status
?? POP ??
*DECK DECK=OSP$INITIALIZE_VIRTUAL_SYSTEM EXPAND=FALSE

  PROCEDURE [XREF] osp$initialize_virtual_system
    (    deadstart_phase: ost$deadstart_phase);

?? PUSH (LISTEXT := ON) ??
*copyc ost$deadstart_phase
?? POP ??
*DECK DECK=OSP$INIT_KEYPOINTS_FOR_PROC EXPAND=FALSE

  PROCEDURE [XREF] osp$init_keypoints_for_proc
    (   file: ^cell;
        o: integer;
        mr: ost$rb_keypoint_request;
        pid: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$keypoint_control
*copyc ost$status
?? POP ??
*DECK DECK=OSP$INSTALL_EXCEPTION_POLICIES EXPAND=TRUE
PROCEDURE install_exception_policies, insep (
  exception_policies, ep: file = $system.mainframe.osf$site_exception_policies
  status)

  VAR
    default: string = 'Installed system default exception policies.'
    default_error: string = 'System error - unable to install default exception ..
    policies.'
    failure: string ='Exception Policies FAILED to install successfully from file '..
    //$string(exception_policies)//'.  The following STATUS was returned:'
    local_status: status
    policies_installed: boolean = false
    success: string='Exception Policies successfully installed from file '//..
    $string(exception_policies)
  VAREND

  WHEN any_fault exit terminate DO
    " Entering condition handler
    IF NOT policies_installed THEN
      SYSTEM_OPERATOR_UTILITY
        MANAGE_EXCEPTION_POLICIES
          install_default_policies status=local_status
          IF local_status.normal THEN
            $system.display_value default o=$job_log
            $system.display_value default o=$output
            policies_installed = true
          ELSE
            $system.display_value default_error o=$job_log
            $system.send_operator_message default_error
          IFEND
        QUIT
      QUIT
    IFEND
    EXIT install_exception_policies WITH osv$status
  WHENEND

  " The use of DISFA is to overcome a bug with $FILE_ATTRIBUTES for a
  " non-existing file in a catalog to which the referencee is not given
  " CYCLE permission

  $system.display_file_attributes exception_policies ..
        display_options=registered output=$null status=local_status
  IF local_status.normal AND ..
        $file_attributes(exception_policies registered)(1).registered THEN
    include_file exception_policies status=local_status
    IF local_status.normal THEN
      $system.display_value success o=$job_log
      $system.display_value success o=$output
      policies_installed = true
    ELSE
      $system.display_value failure o=$job_log
      $system.display_value failure o=$output
      $system.display_value local_status o=$output
    IFEND
  IFEND

PROCEND install_exception_policies
*DECK DECK=OSP$ISSUE_STRING_AS_KEYPOINT EXPAND=FALSE
 PROCEDURE [XREF] osp$issue_string_as_keypoint (s: string (32);
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ose$keypoint_conditions
?? POP ??
*DECK DECK=OSP$IS_CALLER_SYSTEM_PRIVILEGED EXPAND=FALSE

  FUNCTION [INLINE] osp$is_caller_system_privileged: boolean;

?? PUSH (LISTEXT := ON) ??
    VAR
      caller_id: ost$caller_identifier;

{ Get the callers segment number.

    #CALLER_ID (caller_id);

{ If it is a special segment the caller is system privileged.

    osp$is_caller_system_privileged := osv$system_privilege_map
          [caller_id.segnum];
  FUNCEND osp$is_caller_system_privileged;

*copyc ost$caller_identifier
*copyc osv$system_privilege_map
?? POP ??
*DECK DECK=OSP$I_AWAIT_ACTIVITY EXPAND=FALSE


  PROCEDURE [XREF] osp$i_await_activity (wait_list: ost$i_wait_list;
    VAR ready_index: integer;
    VAR complete: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$i_wait
*copyc OST$STATUS
?? POP ??
*DECK DECK=OSP$I_AWAIT_ACTIVITY_COMPLETION EXPAND=FALSE


  PROCEDURE [XREF] osp$i_await_activity_completion (wait_list: ost$i_wait_list;
    VAR ready_index: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$i_wait
*copyc OST$STATUS
*copyc OSE$AWAIT_ACTIVITY_EXCEPTIONS
*copyc PME$LOCAL_QUEUE_EXCEPTIONS
?? POP ??
*DECK DECK=OSP$JOB_TEMPLATE_INIT_PH1 EXPAND=FALSE

  PROCEDURE [XREF] osp$job_template_init_ph1;
*DECK DECK=OSP$JOB_TEMPLATE_INIT_PH2 EXPAND=FALSE

  PROCEDURE [XREF] osp$job_template_init_ph2
    (VAR deadstart_intervention: boolean;
     VAR deadstart_phase: ost$deadstart_phase);

?? PUSH (LISTEXT := ON) ??
*copyc ost$deadstart_phase
?? POP ??
*DECK DECK=OSP$JOB_TEMPLATE_INIT_PH3 EXPAND=FALSE

  PROCEDURE [XREF] osp$job_template_init_ph3;
*DECK DECK=OSP$JT_BEGIN_SYSTEM_ACTIVITY EXPAND=FALSE

  PROCEDURE [XREF] osp$jt_begin_system_activity;

*DECK DECK=OSP$JT_END_SYSTEM_ACTIVITY EXPAND=FALSE

  PROCEDURE [XREF] osp$jt_end_system_activity;

*DECK DECK=OSP$LOG_CALLER EXPAND=FALSE

PROCEDURE [XREF] osp$log_caller;


*DECK DECK=OSP$LOG_CALLER_R1 EXPAND=FALSE

 PROCEDURE [XREF] osp$log_caller_r1;


*DECK DECK=OSP$LOG_EXECUTED_POLICY EXPAND=FALSE
  PROCEDURE [XREF] osp$log_executed_policy
    (    status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$LOG_IDLE_RESUME EXPAND=FALSE

  PROCEDURE [XREF] osp$log_idle_resume (statistic_type: ost$terminate_continue_stats;
        idle_code: syt$180_idle_code;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$terminate_continue_stats
*copyc syt$180_idle_code
*copyc ost$status
?? POP ??
*DECK DECK=OSP$LOG_IO_READ_ERROR EXPAND=FALSE
  PROCEDURE [XREF] osp$log_io_read_error
    (    path: string ( * );
         file_kind: gft$file_kind;
         segment: ^cell);

?? PUSH (LISTEXT := ON) ??
*copyc gft$file_kind
?? POP ??
*DECK DECK=OSP$LOG_JOB_RECOVERY_MESSAGE EXPAND=FALSE

 PROCEDURE [XREF] osp$log_job_recovery_message
   (    text: string ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$LOG_JOB_RECOVERY_STATUS EXPAND=FALSE

 PROCEDURE [XREF] osp$log_job_recovery_status
   (    recovery_status: ost$status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$LOG_SYSTEM_ERROR EXPAND=FALSE

  PROCEDURE [XREF] osp$log_system_error
    (    error_message: string ( * );
         text: string ( * ));
*DECK DECK=OSP$LOG_SYSTEM_STATUS_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$log_system_status_message
    (    logs: pmt$ascii_logset;
         message_status: ost$status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmd$system_log_interface
?? POP ??
*DECK DECK=OSP$LOG_UNFORMATTED_STATUS EXPAND=FALSE

  PROCEDURE [XREF] osp$log_unformatted_status
    (    p_status: ^ost$status;
         ascii_logset: pmt$ascii_logset;
         message_origin: pmt$log_msg_origin;
         critical_message: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmd$system_log_interface
?? POP ??
*DECK DECK=OSP$MANAGE_SYSTEM_TASKS EXPAND=FALSE

  PROCEDURE [XREF] osp$manage_system_tasks
    (VAR short_wait: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$MFH_FOR_SEGMENT_MANAGER EXPAND=FALSE

   PROCEDURE [XREF] osp$mfh_for_segment_manager;
*DECK DECK=OSP$MONITOR_FAULT_TO_STATUS EXPAND=FALSE

  PROCEDURE [XREF] osp$monitor_fault_to_status
    (    monitor_fault: ost$monitor_fault;
         minimum_save_area_p: ^ost$minimum_save_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$monitor_fault
*copyc ost$stack_frame_save_area
*copyc ost$status
?? POP ??
*DECK DECK=OSP$OUTPUT_DEBUG_HEADING EXPAND=FALSE

  PROCEDURE [XREF] osp$output_debug_heading
    (    s: ^string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$OUTPUT_DEBUG_TEXT EXPAND=FALSE

  PROCEDURE [XREF] osp$output_debug_text
    (    s: ^string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=OSP$OUTPUT_STATUS_MESSAGE EXPAND=FALSE
  PROCEDURE [XREF] osp$output_status_message (file_id: amt$file_identifier;
        message_level: ost$format_message_level;
        message_header_kind: ost$status_message_header_kind;
        message_status: ost$status;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
*copyc ost$status_message_header_kind
*copyc ost$status_message_level
?? POP ??
*DECK DECK=OSP$POP_INHIBIT_JOB_RECOVERY EXPAND=FALSE
 PROCEDURE [INLINE] osp$pop_inhibit_job_recovery;

    VAR
      osv$inhibit_job_recovery_count: [XREF] integer;

    osv$inhibit_job_recovery_count := osv$inhibit_job_recovery_count - 1;
  PROCEND osp$pop_inhibit_job_recovery;
*DECK DECK=OSP$PRESS_RETURN_TO_CONTINUE EXPAND=FALSE

  PROCEDURE [INLINE] osp$press_return_to_continue
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      byte_address: amt$file_byte_address,
      file_position: amt$file_position,
      input_fid: amt$file_identifier,
      line: string (1),
      transfer_count: amt$transfer_count;

    clp$put_job_output (' Press RETURN/NEXT to continue.', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    fsp$open_file (clc$job_input, amc$record, NIL, NIL, NIL, NIL, NIL,
          input_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    amp$get_next (input_fid, ^line, #SIZE (line), transfer_count, byte_address,
          file_position, {ignore} status);
    status.normal := TRUE;
    fsp$close_file (input_fid, status);

  PROCEND osp$press_return_to_continue;

*copyc amp$get_next
*copyc clc$standard_file_names
*copyc clp$put_job_output
*copyc fsp$close_file
*copyc fsp$open_file
?? POP ??

*DECK DECK=OSP$PREVALIDATE_FREE EXPAND=FALSE

  PROCEDURE [XREF] osp$prevalidate_free
    (    offset: ost$halfword;
         xhp: ^ost$heap;
     VAR result: ost$prevalidate_free_result);

?? PUSH (LISTEXT := ON) ??
*copyc ost$halfword
*copyc ost$heap
*copyc ost$prevalidate_free_result
?? POP ??
*DECK DECK=OSP$PROCESSOR_SELECTIONS_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$processor_selections_r1;
*DECK DECK=OSP$PROCESS_KEYPOINT_IO_ERROR EXPAND=FALSE
 PROCEDURE [XREF] osp$process_keypoint_io_error;
*DECK DECK=OSP$PROCESS_KEYPOINT_PAGE_FAULT EXPAND=FALSE

  PROCEDURE [XREF] osp$process_keypoint_page_fault
    (    utp_offset: integer;
     VAR keypoint_page_fault_status: mmt$keypoint_page_fault_status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$keypoint_page_fault_status
?? POP ??
*DECK DECK=OSP$PROCESS_KEYPOINT_PERIODIC EXPAND=FALSE
 PROCEDURE [XREF] osp$process_keypoint_periodic;
*DECK DECK=OSP$PUSH_INHIBIT_JOB_RECOVERY EXPAND=FALSE
 PROCEDURE [INLINE] osp$push_inhibit_job_recovery;

    VAR
      osv$inhibit_job_recovery_count: [XREF] integer;

    osv$inhibit_job_recovery_count := osv$inhibit_job_recovery_count + 1;
  PROCEND osp$push_inhibit_job_recovery;
*DECK DECK=OSP$PUT_CRITICAL_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$put_critical_message (message: string(*);
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=OSP$R1_COPY_INSTALLED_POLICIES EXPAND=FALSE
*DECK DECK=OSP$R1_GET_APPLICABLE_POLICY EXPAND=FALSE
  PROCEDURE [XREF] osp$r1_get_applicable_policy
    (    criteria: ost$ecp_criteria;
     VAR applicable_actions: ost$ecp_actions;
     VAR polling_frequency: ost$ecp_polling_frequency;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$exception_policies
*copyc ost$status
?? POP ??
*DECK DECK=OSP$R1_GET_INSTALLED_POLICIES EXPAND=FALSE
  PROCEDURE [XREF] osp$r1_get_installed_policies
    (VAR installed_policies: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$R1_INSTALL_EXCEPTION_POLICY EXPAND=FALSE
  PROCEDURE [XREF] osp$r1_install_exception_policy
    (    session_policies: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$R1_LOCK_POLICIES EXPAND=FALSE
  PROCEDURE [XREF] osp$r1_lock_policies
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$R1_UNLOCK_POLICIES EXPAND=FALSE
  PROCEDURE [XREF] osp$r1_unlock_policies;

*DECK DECK=OSP$R3_COPY_INSTALLED_POLICIES EXPAND=FALSE
*DECK DECK=OSP$R3_GET_APPLICABLE_POLICY EXPAND=FALSE
  PROCEDURE [XREF] osp$r3_get_applicable_policy
    (    criteria: ost$ecp_criteria;
     VAR applicable_actions: ost$ecp_actions;
     VAR polling_frequency: ost$ecp_polling_frequency;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$exception_policies
*copyc ost$status
?? POP ??

*DECK DECK=OSP$R3_GET_INSTALLED_POLICIES EXPAND=FALSE
  PROCEDURE [XREF] osp$r3_get_installed_policies
    (VAR installed_policies: ^SEQ ( * );
     VAR sequence_header: ^ost$ecp_header;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$exception_policies
*copyc ose$disk_ft_exceptions
*copyc ost$status
?? POP ??
*DECK DECK=OSP$R3_INSTALL_EXCEPTION_POLICY EXPAND=FALSE
  PROCEDURE [XREF] osp$r3_install_exception_policy
    (    session_policies: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$RANDOMIZE_NAME EXPAND=FALSE

  PROCEDURE [INLINE] osp$randomize_name (name: ost$name;
    VAR randomized_name: ost$randomized_name);

?? PUSH (LISTEXT := ON) ??
*copyc OST$NAME
*copyc osd$random_name
?? POP ??

    TYPE
      template = record
        case boolean of
        = TRUE =
          name: ost$name,

        = FALSE =
          half_word: array [1 .. 7] of ost$randomized_name,
          remainder: 0 .. 0ffffff(16),
        casend,
      recend;

    VAR
      i: 1 .. 7,
      intermediate_result: integer,
      temp_name: template;

    temp_name.name := name;

    intermediate_result := temp_name.remainder;
    FOR i := 1 TO 7 DO
      intermediate_result := intermediate_result + temp_name.half_word [i];
    FOREND;

    randomized_name := intermediate_result MOD (osc$max_random_name + 1);

  PROCEND osp$randomize_name;
*DECK DECK=OSP$READY_UNIVERSAL_TASK EXPAND=FALSE

 PROCEDURE [XREF] osp$ready_universal_task
    (    universal_task_id: ost$universal_task_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$universal_task_id
*copyc pme$unknown_recipient_task
?? POP ??
*DECK DECK=OSP$READ_EMISSION_SETS EXPAND=FALSE

  PROCEDURE [XREF] osp$read_emission_sets
    (VAR emission_sets_copy: ARRAY [ost$emission_set_names] of ost$emission_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osc$statistics
*copyc ost$emission_sets
*copyc ost$status
?? POP??
*DECK DECK=OSP$READ_EMISSION_SETS_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$read_emission_sets_r1
    (VAR emission_sets_copy: ARRAY [ost$emission_set_names] of ost$emission_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osc$statistics
*copyc ost$emission_sets
*copyc ost$status
?? POP ??

*DECK DECK=OSP$RECOVERABLE_SYSTEM_ERROR EXPAND=FALSE

  PROCEDURE [XREF] osp$recoverable_system_error {OSXRSE} (error_message: string
    ( * );
        p_status: ^ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=OSP$RECOVERY_SWAP_IO_ERROR EXPAND=FALSE

  PROCEDURE [XREF] osp$recovery_swap_io_error;

*DECK DECK=OSP$RECOVER_EXECUTING_JOBS EXPAND=FALSE

  PROCEDURE [XREF] osp$recover_executing_jobs
    (VAR swap_file_recovery_list: ^jmt$swap_file_recovery_list;
     VAR swap_file_recovery_list_count: jmt$job_count_range;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_count_range
*copyc jmt$swap_file_recovery_list
*copyc ost$status
?? POP ??
*DECK DECK=OSP$RECOVER_JOB EXPAND=FALSE
  PROCEDURE [XREF] osp$recover_job;
*DECK DECK=OSP$RELEASE_KEYPOINT_ENV EXPAND=FALSE
 PROCEDURE [XREF] osp$release_keypoint_env (VAR collection_files: array [1 ..
       osc$max_number_of_processors] of ^cell;
       data_string: string (32);
   VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osc$multiprocessor_constants
*copyc ost$status
*copyc ose$keypoint_conditions
?? POP ??

*DECK DECK=OSP$RELEASE_KEYPOINT_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$release_keypoint_r1
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$RELEASE_MANPS_LOCK EXPAND=FALSE

  PROCEDURE [XREF] osp$release_manps_lock;

*DECK DECK=OSP$RELEASE_MANPS_LOCK_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$release_manps_lock_r1;

*DECK DECK=OSP$RELEASE_SPI_ENVIRONMENT EXPAND=FALSE
  PROCEDURE [XREF] osp$release_spi_environment
    (VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$RELEASE_SPI_R1_SUPPORT EXPAND=FALSE
  PROCEDURE [XREF] osp$release_spi_r1_support
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$REMOVE_POLICY EXPAND=FALSE
  PROCEDURE [XREF] osp$remove_policy
    (    policy: ^ost$ecp_policy_header;
     VAR policies_sequence_header {input, output} : ost$ecp_header);

?? PUSH (LISTEXT := ON) ??
*copyc osd$exception_policies
?? POP ??
*DECK DECK=OSP$RESERVE_KEYPOINT_ENV EXPAND=FALSE
 PROCEDURE [XREF] osp$reserve_keypoint_env (environment:
  ost$keypoint_environment;
        monitor_mask: ost$keypoint_class_mask;
        job_mask: ost$keypoint_class_mask;
        collection_files: ^array [ * ] OF ^cell,
        wait: ost$wait;
        multi_processor: ost$keypoint_multipro_option;
        keypoint_count: integer;
        keypoint_buffer_size: integer;
        data_string: string (32);
        performance_keypoints: syt$perf_keypoints_enabled;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$keypoint_environment
*copyc ost$status
*copyc ost$wait
*copyc ose$keypoint_conditions
*copyc syt$perf_keypoints_enabled
?? POP ??

*DECK DECK=OSP$RESERVE_KEYPOINT_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$reserve_keypoint_r1
    (   env: ost$keypoint_environment;
        mm: ost$keypoint_class_mask;
        jm: ost$keypoint_class_mask;
        mpo: ost$keypoint_multipro_option;
        kc: integer;
        kbs: integer;
        fap: integer;
        performance_keypoints: syt$perf_keypoints_enabled;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$keypoint_control
*copyc ost$keypoint_environment
*copyc ost$status
*copyc syt$perf_keypoints_enabled
?? POP ??
*DECK DECK=OSP$RESERVE_MANPS_LOCK EXPAND=FALSE
  PROCEDURE [XREF] osp$reserve_manps_lock
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP??

*DECK DECK=OSP$RESERVE_MANPS_LOCK_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$reserve_manps_lock_r1
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=OSP$RESERVE_SPI_ENVIRONMENT EXPAND=FALSE
  PROCEDURE [XREF] osp$reserve_spi_environment
    (    spi_identifier: ost$spi_identifier;
         collection_file: amt$local_file_name;
         number_of_spi_samples: ost$number_of_spi_samples;
         spi_sampling_interval: ost$spi_sampling_interval;
         wait: ost$wait;
         processor_id_set: ost$processor_id_set;
         data_string: string (32);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$wait
*copyc ost$processor_id_set
*copyc ose$spi_conditions
*copyc ost$spi_types
*copyc amt$local_file_name
?? POP ??
*DECK DECK=OSP$RESERVE_SPI_R1_SUPPORT EXPAND=FALSE
  PROCEDURE [XREF] osp$reserve_spi_r1_support
    (    spi_identifier: ost$spi_identifier;
         collection_file: amt$local_file_name;
         number_of_spi_samples: ost$number_of_spi_samples;
         spi_sampling_interval: ost$spi_sampling_interval;
         processor_id_set: ost$processor_id_set;
         data_string: string (32);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$spi_types
*copyc ost$processor_id_set
*copyc amt$local_file_name
?? POP ??
*DECK DECK=OSP$RESET_HEAP EXPAND=FALSE

  PROCEDURE [XREF] osp$reset_heap (hp: ^ost$heap;
    heap_length: integer;
    lock_option: boolean;
    algorithm: 0 .. 255);

?? PUSH (LISTEXT := ON) ??
*copyc ost$heap
?? POP ??

*DECK DECK=OSP$RESET_MAXIMUM_TIME EXPAND=FALSE

  PROCEDURE [XREF] osp$reset_maximum_time (id: ost$data_id);

?? PUSH (LISTEXT := ON) ??
*copyc ost$data_id
?? POP ??
*DECK DECK=OSP$RESET_PROCESSOR_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$reset_processor_r1;
*DECK DECK=OSP$RESET_PTL EXPAND=FALSE

  PROCEDURE [XREF] osp$reset_ptl;
*DECK DECK=OSP$RUN_VIRTUAL_SYSTEM EXPAND=FALSE

  PROCEDURE [XREF] osp$run_virtual_system (system_restart: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$SCAN_IJL_FOR_RECOVERED_JOBS EXPAND=FALSE

  PROCEDURE [XREF] osp$scan_ijl_for_recovered_jobs;

*DECK DECK=OSP$SCAN_SYSTEM_TASK_TABLE EXPAND=FALSE

  PROCEDURE [XREF] osp$scan_system_task_table (
    VAR work_to_do: ost$system_task_work_to_do);

?? PUSH (LISTEXT := ON) ??
*copyc ost$system_task_work_to_do
?? POP ??
*DECK DECK=OSP$SELECT_PROCESSORS_W_DIVIDE1 EXPAND=FALSE

  PROCEDURE [XREF] osp$select_processors_w_divide1
     (VAR switched: boolean);
*DECK DECK=OSP$SERVER_READY_TASK EXPAND=FALSE

 PROCEDURE [XREF] osp$server_ready_task
    (VAR p_params_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_params_to_server {^Output} : dft$p_send_parameters;
     VAR p_data_to_server {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_parameters
*copyc ost$status
?? POP ??
*DECK DECK=OSP$SET_CLIENT_ACCESS EXPAND=FALSE
  PROCEDURE [XREF] osp$set_client_access
    (    family: ost$family_name;
         family_access: dft$family_access;
         all_clients: boolean;
         p_binary_client_list: ^array [1 .. * ] of pmt$binary_mainframe_id;
         number_of_clients: 0 .. dfc$maximum_partner_mainframes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$family_access
*copyc dft$partner_mainframe_list
*copyc ost$status
*copyc ost$user_identification
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=OSP$SET_DESKTOP_INTERACTION EXPAND=FALSE

  PROCEDURE [XREF] osp$set_desktop_interaction
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ose$message_gen_exceptions
*copyc ost$status
?? POP ??
*DECK DECK=OSP$SET_GLOBAL_CPU_MODEL_DEF EXPAND=FALSE

  PROCEDURE [XREF] osp$set_global_cpu_model_def;
*DECK DECK=OSP$SET_JOB_SIGNATURE_LOCK EXPAND=FALSE
  PROCEDURE [INLINE] osp$set_job_signature_lock
    (VAR lock: ost$signature_lock);

?? PUSH (LISTEXT := ON) ??
*copyc clc$compiling_for_test_harness
*copyc fsc$compiling_for_test_harness
*copyc sfc$compiling_for_test_harness

*IF NOT $true(osv$unix)
    ?IF NOT (clc$compiling_for_test_harness OR fsc$compiling_for_test_harness OR
          sfc$compiling_for_test_harness) THEN

      VAR
        task_id: ost$global_task_id,
        xcb_p: ^ost$execution_control_block,
        new_value: integer,
        actual_value: integer,
        cs_status: 0 .. 2;

      xcb_p := #ADDRESS (1, osc$segnum_job_fixed_heap,
            #READ_REGISTER (osc$pr_base_constant));
      task_id := xcb_p^.global_task_id;
      new_value := task_id.index * 256 * #SIZE (task_id.seqno) + task_id.seqno;

    /lock_loop/
      WHILE TRUE DO
        REPEAT
          #COMPARE_SWAP (lock.lock_id, 0, new_value, actual_value, cs_status);
        UNTIL cs_status <> osc$cs_variable_locked;
        IF cs_status = osc$cs_successful THEN
          RETURN;
        IFEND;

        IF new_value = actual_value THEN
          osp$system_error ('Lock already set by current task', NIL);
        IFEND;
        syp$cycle_for_lock (tmc$cyc_set_job_lock, ^lock);
      WHILEND /lock_loop/;
    ?ELSE
*IFEND
      IF lock.lock_id <> 0 THEN
*IF NOT $true(osv$unix)
        osp$system_error (' lock  set', NIL);
*ELSE
        RETURN;
*IFEND
      IFEND;
      lock.lock_id := 12;
*IF NOT $true(osv$unix)
    ?IFEND
*IFEND

  PROCEND osp$set_job_signature_lock;
*copyc ost$execution_control_block
*copyc ost$heap
*copyc osc$processor_defined_registers
*copyc ost$signature_lock
*IF NOT $true(osv$unix)
*copyc osp$system_error
*copyc syp$cycle_for_lock
*IFEND
?? POP ??
*DECK DECK=OSP$SET_LOCKED_VARIABLE EXPAND=FALSE
 PROCEDURE [INLINE] osp$set_locked_variable (VAR variable: integer;
        initial: integer;
        final: integer;
    VAR actual: integer;
    VAR succeeded: boolean);
{
{   The purpose of this procedure is to set a compare_swap lock
{  when the user knows the initial contents of the lock.
{  This procedure has been generated to help users avoid problems
{  with #compare_swap.
{  CAUTION: Variables referenced by this procedure may not be
{  referenced (read or written) any way other than by the
{  following procedures:
{                             osp$increment_locked_variable
{                             osp$decrement_locked_variable
{                             osp$fetch_locked_variable
{        and the intrinsic    #compare_swap.
{
{     OSP$SET_LOCKED_VARIABLE (VARIABLE, INITIAL, FINAL, ACTUAL, SUCCEEDED)
{
{  VARIABLE: (input,output) This parameter is the variable on which the
{                     compare_swap operation is to be performed.
{  INITIAL: (input) This parameter is the value that the variable must contain
{                     initial content of the lock must be for the swap
{                     operation to be successful.
{  FINAL: (input) This parameter is the variable that specifies the value to be
{                     stored in the lock if the swap is successful.
{  ACTUAL: (output) This parameter is the variable into which the initial
{                     contents of the lock is returned.
{  SUCCEEDED: (output) This parameter specifies whether the swap was successful
{                     or not.
{

?? PUSH (LISTEXT := ON) ??

    VAR
      result: 0 .. 2;

    succeeded := FALSE;
    REPEAT
      #compare_swap (variable, initial, final, actual, result);
    UNTIL result <> 2;
    IF result = 0 THEN
      actual := final;
      succeeded := TRUE;
    IFEND;
  PROCEND osp$set_locked_variable;
?? POP ??
*DECK DECK=OSP$SET_MAINFRAME_SIG_LOCK EXPAND=FALSE
  PROCEDURE [INLINE] osp$set_mainframe_sig_lock
    (VAR lock: ost$signature_lock);

?? PUSH (LISTEXT := ON) ??
*copyc clc$compiling_for_test_harness
*copyc fsc$compiling_for_test_harness
*copyc sfc$compiling_for_test_harness

    ?IF NOT (clc$compiling_for_test_harness OR fsc$compiling_for_test_harness OR
          sfc$compiling_for_test_harness) THEN

      VAR
        task_id: ost$global_task_id,
        xcb_p: ^ost$execution_control_block,
        new_value: integer,
        actual_value: integer,
        cs_status: 0 .. 2;

      xcb_p := #ADDRESS (1, osc$segnum_job_fixed_heap,
            #READ_REGISTER (osc$pr_base_constant));
      task_id := xcb_p^.global_task_id;
      new_value := task_id.index * 256 * #SIZE (task_id.seqno) + task_id.seqno;

    /lock_loop/
      WHILE TRUE DO
        xcb_p^.system_table_lock_count := xcb_p^.system_table_lock_count + 256;
        REPEAT
          #COMPARE_SWAP (lock.lock_id, 0, new_value, actual_value, cs_status);
        UNTIL cs_status <> osc$cs_variable_locked;
        IF cs_status = osc$cs_successful THEN
          RETURN;
        IFEND;

        xcb_p^.system_table_lock_count := xcb_p^.system_table_lock_count - 256;
        syp$cycle_for_lock (tmc$cyc_set_sys_lock, ^lock);
        IF new_value = actual_value THEN
          osp$system_error ('Lock already set by current task', NIL);
        IFEND;
      WHILEND /lock_loop/;
    ?ELSE
      IF lock.lock_id <> 0 THEN
        osp$system_error (' lock  set', NIL);
      IFEND;
      lock.lock_id := 12;
    ?IFEND

  PROCEND osp$set_mainframe_sig_lock;
*copyc ost$execution_control_block
*copyc ost$heap
*copyc ost$signature_lock
*copyc osp$system_error
*copyc syp$cycle_for_lock
*copyc osc$processor_defined_registers
?? POP ??
*DECK DECK=OSP$SET_MESSAGE_LEVEL EXPAND=FALSE

  PROCEDURE [XREF] osp$set_message_level
    (    message_level: ost$status_message_level;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ose$message_gen_exceptions
*copyc ost$status
*copyc ost$status_message_level
?? POP ??
*DECK DECK=OSP$SET_NATURAL_LANGUAGE EXPAND=FALSE

  PROCEDURE [XREF] osp$set_natural_language
    (    natural_language: ost$natural_language;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ose$message_gen_exceptions
*copyc ost$natural_language
*copyc ost$status
?? POP ??
*DECK DECK=OSP$SET_SIGNATURE_LOCK EXPAND=FALSE

  PROCEDURE [XREF] osp$set_signature_lock (VAR lock: ost$signature_lock;
        wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
*copyc OST$WAIT
*copyc OST$STATUS
?? POP ??
*DECK DECK=OSP$SET_STATUS_ABNORMAL EXPAND=FALSE

  PROCEDURE [XREF] osp$set_status_abnormal ALIAS 'ospssa'
    (    identifier: ost$status_identifier;
         condition: ost$status_condition_code;
         text: string ( * <= osc$max_string_size);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$status_condition_code
*copyc ost$status_identifier
*copyc ost$string
?? POP ??
*DECK DECK=OSP$SET_STATUS_CONDITION EXPAND=FALSE

  PROCEDURE [INLINE] osp$set_status_condition
    (    condition: ost$status_condition_code;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
    status.normal := FALSE;
    status.condition := condition;
    status.text.size := 0;
  PROCEND osp$set_status_condition;

*copy osh$set_status_condition

*copyc ost$status
*copyc ost$status_condition_code
?? POP ??
*DECK DECK=OSP$SET_STATUS_FROM_CONDITION EXPAND=FALSE

  PROCEDURE [XREF] osp$set_status_from_condition (identifier:
    ost$status_identifier,
    condition: pmt$condition;
    save_area: ^ost$stack_frame_save_area;
    VAR condition_status: ost$status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS_IDENTIFIER
*copyc PMT$CONDITION
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc OST$STATUS
*copyc OSE$CONDITION_EXCEPTIONS
?? POP ??
*DECK DECK=OSP$SET_STATUS_FROM_MTR_STATUS EXPAND=FALSE
  PROCEDURE [inline] osp$set_status_from_mtr_status (monitor_status: syt$monitor_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
    status.normal := monitor_status.normal;
    IF NOT status.normal THEN
      status.condition := monitor_status.condition;
      status.text.size := 0;
    IFEND;

  PROCEND osp$set_status_from_mtr_status;
*copyc ost$status
*copyc syt$monitor_request_code
?? POP ??
*DECK DECK=OSP$SET_SYSTEM_TASK_RESTART EXPAND=FALSE

  PROCEDURE [XREF] osp$set_system_task_restart
    (    name: ost$name;
         automatic_restart: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??

*DECK DECK=OSP$SIMULATE_DISK_FAULT_R1 EXPAND=FALSE
  PROCEDURE [XREF] osp$simulate_disk_fault_r1
    (    sdf: ost$simulated_disk_fault;
     VAR status: ost$status);
*copyc ost$simulated_disk_fault

*DECK DECK=OSP$SPI_COLLECTION_INFO EXPAND=FALSE
  PROCEDURE [XREF] osp$spi_collection_info
    (    file_id: amt$file_identifier;
         pva_array: ^cell;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$file_identifier
*copyc osc$multiprocessor_constants
?? POP ??
*DECK DECK=OSP$START_KEYPOINT_COLLECTION EXPAND=FALSE
 PROCEDURE [XREF] osp$start_keypoint_collection (data_string: string (32);
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ose$keypoint_conditions
?? POP ??
*DECK DECK=OSP$START_SPI_COLLECTION EXPAND=FALSE
  PROCEDURE [XREF] osp$start_spi_collection
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ose$spi_conditions
?? POP ??
*DECK DECK=OSP$START_SPI_COLLECTION_R1 EXPAND=FALSE
  PROCEDURE [XREF] osp$start_spi_collection_r1
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$STATUS_CONDITION_CODE EXPAND=FALSE

  FUNCTION [INLINE] osp$status_condition_code
    (    identifier: ost$status_identifier;
         number: ost$status_condition_code): ost$status_condition_code;

?? PUSH (LISTEXT := ON) ??

    VAR
      condition_code: ost$status_condition_code,
      code_breakdown: record
        identifier: ost$status_identifier,
        number: ost$status_condition_number,
      recend;

    IF number <= osc$max_status_condition_number THEN
      code_breakdown.identifier := identifier;
      code_breakdown.number := number;
      #UNCHECKED_CONVERSION (code_breakdown, condition_code);
      osp$status_condition_code := condition_code;
    ELSE
      osp$status_condition_code := number;
    IFEND;

  FUNCEND osp$status_condition_code;

*copyc ost$status_condition_code
*copyc ost$status_condition_number
*copyc ost$status_identifier
?? POP ??
*DECK DECK=OSP$STATUS_CONDITION_NUMBER EXPAND=FALSE

  FUNCTION [INLINE] osp$status_condition_number
    (    condition: ost$status_condition_code): ost$status_condition_number;

?? PUSH (LISTEXT := ON) ??

    VAR
      code_breakdown: record
        identifier: ost$status_identifier,
        number: ost$status_condition_number,
      recend;

    #UNCHECKED_CONVERSION (condition, code_breakdown);
    osp$status_condition_number := code_breakdown.number;

  FUNCEND osp$status_condition_number;

*copyc ost$status_condition_code
*copyc ost$status_condition_number
*copyc ost$status_identifier
?? POP ??
*DECK DECK=OSP$STATUS_MESSAGE_TEXT EXPAND=FALSE

  FUNCTION [INLINE] osp$status_message_text
    (    message: ^ost$status_message): ^ost$status_message_line;

?? PUSH (LISTEXT := ON) ??

    VAR
      message_text: ^ost$status_message_line,
      message_area: ^ost$status_message,
      message_line_count: ^ost$status_message_line_count,
      message_text_size: ^ost$status_message_line_size;


    message_area := message;
    RESET message_area;
    NEXT message_line_count IN message_area;
    IF message_line_count^ = 0 THEN
      RESET message_area;
      NEXT message_text: [1] IN message_area;
    ELSE
      NEXT message_text_size IN message_area;
      NEXT message_text: [message_text_size^] IN message_area;
    IFEND;
    osp$status_message_text := ^message_text^ (2, * );

  FUNCEND osp$status_message_text;

*copyc ost$status_message
*copyc ost$status_message_line
*copyc ost$status_message_line_count
*copyc ost$status_message_line_size
?? POP ??
*DECK DECK=OSP$STOP_KEYPOINT_COLLECTION EXPAND=FALSE
 PROCEDURE [XREF] osp$stop_keypoint_collection (data_string: string (32);
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ose$keypoint_conditions
?? POP ??
*DECK DECK=OSP$STOP_SPI_COLLECTION EXPAND=FALSE
  PROCEDURE [XREF] osp$stop_spi_collection
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ose$spi_conditions
?? POP ??
*DECK DECK=OSP$STOP_SPI_COLLECTION_R1 EXPAND=FALSE
  PROCEDURE [XREF] osp$stop_spi_collection_r1
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=OSP$STORE_SEQUENCE_HEADERS EXPAND=FALSE
  PROCEDURE [XREF] osp$store_sequence_headers
    (    sequence_headers: array [ost$ecp_sequence_index] of ^ost$ecp_header;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$exception_policies
*copyc ose$disk_ft_exceptions
*copyc ost$status
?? POP ??
*DECK DECK=OSP$STORE_SYSTEM_CONSTANT EXPAND=FALSE

  PROCEDURE [XREF] osp$store_system_constant (name: string ( * );
        index: integer;
        value: integer;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=OSP$STORE_SYSTEM_TASK_STATUS EXPAND=FALSE

  PROCEDURE [XREF] osp$store_system_task_status (name: ost$name;
        status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=OSP$SUB_FROM_LOCKED_VARIABLE EXPAND=FALSE
   PROCEDURE [INLINE] osp$sub_from_locked_variable (VAR variable:{Input, Output} integer;
         initial_best_guess: integer;
         amount_to_subtract: integer;
     VAR actual: integer;
     VAR error: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      initial: integer,
      result: 0 .. 2;

    error := FALSE;
    IF initial_best_guess >= amount_to_subtract THEN
      initial := initial_best_guess;
    ELSE
      initial := amount_to_subtract;
    IFEND;

  /swap_in_subtraction/
    REPEAT
      #compare_swap (variable, initial, initial - amount_to_subtract, initial, result);
    UNTIL (result = 0) OR (initial < amount_to_subtract);
    IF result = 0 THEN
      actual := initial - amount_to_subtract;
    ELSE
      error := TRUE;
      actual := 0;
    IFEND;
  PROCEND osp$sub_from_locked_variable;
?? POP ??
*DECK DECK=OSP$SYSTEM_ERROR EXPAND=FALSE

  PROCEDURE [XREF] osp$system_error (error_message: string ( * );
        status: ^ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=OSP$TERMINATE_REQUESTED EXPAND=FALSE

  FUNCTION [XREF] osp$terminate_requested: boolean;

*DECK DECK=OSP$TERMINATE_REQUESTED_R1 EXPAND=FALSE

  FUNCTION [XREF] osp$terminate_requested_r1: boolean;

*DECK DECK=OSP$TERMINATE_SYSTEM EXPAND=FALSE

  PROCEDURE [XREF] osp$terminate_system (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=OSP$TERMINATE_SYSTEM_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$terminate_system_r1;
*DECK DECK=OSP$TERMINATE_SYSTEM_TASK EXPAND=FALSE

  PROCEDURE [XREF] osp$terminate_system_task (name: ost$name);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=OSP$TEST_AAM_ACTIVITY EXPAND=FALSE
  PROCEDURE [XREF] osp$test_aam_activity;

*DECK DECK=OSP$TEST_AAM_ACTIVITY_R1 EXPAND=FALSE


  PROCEDURE [XREF] osp$test_aam_activity_r1;
*DECK DECK=OSP$TEST_SET_JOB_SIG_LOCK EXPAND=FALSE
  PROCEDURE [INLINE] osp$test_set_job_sig_lock
    (VAR lock: ost$signature_lock;
     VAR locked: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc clc$compiling_for_test_harness
*copyc fsc$compiling_for_test_harness

    ?IF NOT (clc$compiling_for_test_harness OR fsc$compiling_for_test_harness)
          THEN

      VAR
        task_id: ost$global_task_id,
        xcb_p: ^ost$execution_control_block,
        new_value: integer,
        actual_value: integer,
        cs_status: 0 .. 2;

      xcb_p := #ADDRESS (1, osc$segnum_job_fixed_heap,
            #READ_REGISTER (osc$pr_base_constant));
      task_id := xcb_p^.global_task_id;
      new_value := task_id.index * 256 * #SIZE (task_id.seqno) + task_id.seqno;
      locked := TRUE;
      REPEAT
        #COMPARE_SWAP (lock.lock_id, 0, new_value, actual_value, cs_status);
      UNTIL cs_status <> osc$cs_variable_locked;
      IF cs_status = osc$cs_successful THEN
        RETURN;
      IFEND;

      IF new_value = actual_value THEN
        osp$system_error ('Lock already set by current task', NIL);
      IFEND;
      locked := FALSE;
    ?ELSE
      locked := lock.lock_id <> 0;
      IF NOT locked THEN
        osp$set_job_signature_lock (lock);
      IFEND;
    ?IFEND

  PROCEND osp$test_set_job_sig_lock;
*copyc ost$execution_control_block
*copyc ost$heap
*copyc osc$processor_defined_registers
*copyc ost$signature_lock
*copyc osp$system_error
*copyc osp$set_job_signature_lock
?? POP ??
*DECK DECK=OSP$TEST_SET_MAIN_SIG_LOCK EXPAND=FALSE
  PROCEDURE [INLINE] osp$test_set_main_sig_lock
    (VAR lock: ost$signature_lock;
     VAR locked: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc clc$compiling_for_test_harness
*copyc fsc$compiling_for_test_harness

    ?IF NOT (clc$compiling_for_test_harness OR fsc$compiling_for_test_harness)
          THEN

      VAR
        new_value: integer,
        actual_value: integer,
        cs_status: 0 .. 2,
        task_id: ost$global_task_id,
        xcb_p: ^ost$execution_control_block;

      xcb_p := #ADDRESS (1, osc$segnum_job_fixed_heap,
            #READ_REGISTER (osc$pr_base_constant));
      task_id := xcb_p^.global_task_id;
      new_value := task_id.index * 256 * #SIZE (task_id.seqno) + task_id.seqno;
      locked := TRUE;
      xcb_p^.system_table_lock_count := xcb_p^.system_table_lock_count + 256;
      REPEAT
        #COMPARE_SWAP (lock.lock_id, 0, new_value, actual_value, cs_status);
      UNTIL cs_status <> osc$cs_variable_locked;

      IF cs_status = osc$cs_successful THEN
        RETURN;
      IFEND;
      xcb_p^.system_table_lock_count := xcb_p^.system_table_lock_count - 256;
      IF (xcb_p^.system_table_lock_count <= 0) AND xcb_p^.system_give_up_cpu THEN
        syp$cycle_for_lock (tmc$cyc_tstset_sys_lock, ^lock);
      IFEND;
      locked := FALSE;
      IF new_value = actual_value THEN
        osp$system_error ('Lock already set by current task', NIL);
      IFEND;
    ?ELSE
      locked := lock.lock_id <> 0;
    ?IFEND

  PROCEND osp$test_set_main_sig_lock;
*copyc ost$execution_control_block
*copyc syp$cycle_for_lock
*copyc osc$processor_defined_registers
*copyc ost$heap
*copyc ost$signature_lock
*copyc osp$system_error
?? POP ??
*DECK DECK=OSP$TEST_SIGNATURE_LOCK EXPAND=FALSE

  PROCEDURE [XREF] osp$test_signature_lock (VAR lock: ost$signature_lock;
    VAR lock_status: ost$signature_lock_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
*copyc OST$STATUS
?? POP ??
*DECK DECK=OSP$TEST_SIG_LOCK EXPAND=FALSE
 procedure [INLINE] osp$test_sig_lock(var lock: ost$signature_lock;
  var lock_status: ost$signature_lock_status);
?? PUSH (LISTEXT := ON) ??

var
cs_status : 0.. 2,
task_id : ost$global_task_id,
xcb_p: ^ost$execution_control_block,
actual_value: integer,
current_task_value : integer;

repeat
#compare_swap (lock.lock_id, 0,0, actual_value, cs_status);
until cs_status <> osc$cs_variable_locked;
if cs_status = osc$cs_successful then
lock_status := osc$sls_not_locked;
else
xcb_p := #address(1, osc$segnum_job_fixed_heap, #read_register
 (osc$pr_base_constant));
task_id := xcb_p^.global_task_id;
current_task_value := task_id.index * 256 * #SIZE(task_id.seqno) + task_id.seqno;
if actual_value = current_task_value then
lock_status := osc$sls_locked_by_current_task;
else
lock_status := osc$sls_locked_by_another_task;
ifend;
ifend;
procend osp$test_sig_lock;

*copyc osh$test_signature_lock
*copyc ost$signature_lock
*copyc ost$heap
*copyc osc$processor_defined_registers
*copyc ost$execution_control_block

?? POP ??
*DECK DECK=OSP$TRANSLATE_BYTES EXPAND=FALSE

  PROCEDURE [XREF] osp$translate_bytes (source: ^cell;
        source_length: ost$string_length;
        target: ^cell;
        target_length: ost$string_length;
        translation_table: ^cell;
    VAR status: ost$error);

  { FUNCTION: Provide access to the translate bytes (TRANB) C180
  {hardware instruction without restricting the source or target to
  {a maximum of 256 bytes.
  {
  { STATUS will always be OSE$NO_ERROR.

?? PUSH (LISTEXT := ON) ??
  CONST
    osc$min_string_length = 0,
    osc$max_string_length = 7fffffff(16);

  TYPE
    ost$string_length = osc$min_string_length .. osc$max_string_length;

  TYPE
    ost$error = (ose$no_error, ose$invalid_bdp_data,
      ose$loss_of_significance, ose$overflow, ose$underflow,
      ose$indefinite, ose$infinite, ose$bad_parameters,
      ose$no_digits);

*copyc osv$ascii_to_ebcdic
*copyc osv$ebcdic_to_ascii
?? POP ??

*DECK DECK=OSP$UNPACK_STATUS_CONDITION EXPAND=FALSE

  PROCEDURE [INLINE] osp$unpack_status_condition
    (    condition: ost$status_condition_code;
     VAR identifier: ost$status_identifier;
     VAR number: ost$status_condition_number);

?? PUSH (LISTEXT := ON) ??

    VAR
      code_breakdown: record
        identifier: ost$status_identifier,
        number: ost$status_condition_number,
      recend;

    #UNCHECKED_CONVERSION (condition, code_breakdown);
    identifier := code_breakdown.identifier;
    number := code_breakdown.number;

  PROCEND osp$unpack_status_condition;

*copyc ost$status_condition_code
*copyc ost$status_condition_number
*copyc ost$status_identifier
?? POP ??
*DECK DECK=OSP$UNPACK_STATUS_IDENTIFIER EXPAND=FALSE

  PROCEDURE [INLINE] osp$unpack_status_identifier
    (    condition: ost$status_condition_code;
     VAR identifier: ost$status_identifier);

?? PUSH (LISTEXT := ON) ??

    VAR
      code_breakdown: record
        identifier: ost$status_identifier,
        number: ost$status_condition_number,
      recend;

    #UNCHECKED_CONVERSION (condition, code_breakdown);
    identifier := code_breakdown.identifier;

  PROCEND osp$unpack_status_identifier;

*copyc ost$status_condition_code
*copyc ost$status_condition_number
*copyc ost$status_identifier
?? POP ??
*DECK DECK=OSP$UNSTEP_RESUME_FLAG_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] osp$unstep_resume_flag_handler (flag_id: ost$system_flag);

?? PUSH (LISTEXT := ON) ??
*copyc ost$system_flag
?? POP ??
*DECK DECK=OSP$UPDATE_IDLE_STATE EXPAND=FALSE

  PROCEDURE [XREF] osp$update_idle_state (idle_state: ost$idle_state;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$idle_state
*copyc ost$status
?? POP ??
*DECK DECK=OSP$UPDATE_IDLE_STATE_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$update_idle_state_r1 (idle_state: ost$idle_state);

?? PUSH (LISTEXT := ON) ??
*copyc ost$idle_state
?? POP ??

*DECK DECK=OSP$UPDATE_JOB_KEYPOINT_MASK EXPAND=FALSE

 PROCEDURE [XREF] osp$update_job_keypoint_mask
   (    ijle_p: ^jmt$initiated_job_list_entry;
        ijl_ordinal: jmt$ijl_ordinal);
*DECK DECK=OSP$UPDATE_WAIT_FRC EXPAND=FALSE

  PROCEDURE [XREF] osp$update_wait_frc
    (    current_time: integer);
*DECK DECK=OSP$VERIFY_HEAP EXPAND=FALSE


  PROCEDURE [XREF] osp$verify_heap
     (    hp: ^ost$heap;
      VAR ok: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc ost$heap
?? POP ??
*DECK DECK=OSP$VERIFY_SYSTEM_PRIVILEGE EXPAND=FALSE
  PROCEDURE [INLINE] osp$verify_system_privilege;

{ This inline procedure utilizes the system privilege bit map
{ to verify that the caller has system privilege, defined as: if
{ segment(caller) is a system segment, then proceed.  Otherwise,
{ force the task to abort via an access violation.

?? PUSH (LISTEXT := ON) ??
*copyc osv$system_privilege_map
*copyc ost$caller_identifier
?? POP ??
  CONST
    bad_offset = 0bad0ca0(16);

  VAR
    id : ost$caller_identifier,
    p : ^integer;

{ Begin executable statements.

{ Get the caller's segment number.

  #caller_id(id);

{ Check the bit map.

  IF NOT osv$system_privilege_map[id.segnum] THEN

{ Form an illegal address.

    p := #address( 1, 0, bad_offset );

{ Cause an access violation by dereferencing the pointer.

    p^ := 0;

  IFEND;

  PROCEND osp$verify_system_privilege;
*DECK DECK=OSP$VERIFY_SYSTEM_SEGMENT EXPAND=FALSE

  PROCEDURE [INLINE] osp$verify_system_segment
    (    pva: ^cell);

{ This inline procedure utilizes the system privilege bit map to verify that
{ the specified address is in a system segment.  If so, proceed; otherwise,
{ force the task to abort via an access violation.

?? PUSH (LISTEXT := ON) ??

    IF NOT osv$system_privilege_map [#SEGMENT (pva)] THEN
      osp$force_access_violation;
    IFEND;

  PROCEND osp$verify_system_segment;

*copyc osp$force_access_violation
*copyc osv$system_privilege_map
?? POP ??
*DECK DECK=OSP$VOLUME_DOWN EXPAND=FALSE
*DECK DECK=OSP$WAIT_FOR_UNAVAILABLE_VOLUME EXPAND=FALSE
*DECK DECK=OSP$WAIT_ON_CONDITION EXPAND=FALSE

  PROCEDURE [XREF] osp$wait_on_condition
    (    condition: ost$status_condition_code);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status_condition_code
?? POP ??
*DECK DECK=OSP$WRITE_EMISSION_SETS EXPAND=FALSE

  PROCEDURE [XREF] osp$write_emission_sets
    (    emission_sets_copy: ARRAY [ost$emission_set_names] of ost$emission_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osc$statistics
*copyc ost$emission_sets
*copyc ost$status
?? POP ??
*DECK DECK=OSP$WRITE_EMISSION_SETS_R1 EXPAND=FALSE

  PROCEDURE [XREF] osp$write_emission_sets_r1
    (VAR emission_sets_copy: ARRAY [ost$emission_set_names] of ost$emission_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osc$statistics
*copyc ost$emission_sets
*copyc ost$status
?? POP ??

*DECK DECK=OSS$JOB_FIXED EXPAND=FALSE

  SECTION
    oss$job_fixed: write;
*DECK DECK=OSS$JOB_FIXED_LITERAL EXPAND=FALSE

  SECTION
    oss$job_fixed_literal: READ;
*DECK DECK=OSS$JOB_PAGEABLE EXPAND=FALSE

  SECTION
    oss$job_pageable: write;
*DECK DECK=OSS$JOB_PAGED_LITERAL EXPAND=FALSE

  SECTION
    oss$job_paged_literal: READ;
*DECK DECK=OSS$MAINFRAME_PAGEABLE EXPAND=FALSE

  SECTION
    oss$mainframe_pageable: write;
*DECK DECK=OSS$MAINFRAME_PAGED_LITERAL EXPAND=FALSE

  SECTION
    oss$mainframe_paged_literal: READ;
*DECK DECK=OSS$MAINFRAME_WIRED EXPAND=FALSE

  SECTION
    oss$mainframe_wired: write;
*DECK DECK=OSS$MAINFRAME_WIRED_CB EXPAND=FALSE
  SECTION
    oss$mainframe_wired_cb: write;
*DECK DECK=OSS$MAINFRAME_WIRED_LITERAL EXPAND=FALSE

  SECTION
    oss$mainframe_wired_literal: READ;
*DECK DECK=OSS$NETWORK_PAGED EXPAND=FALSE

  SECTION
    oss$network_paged: write;

*DECK DECK=OSS$NETWORK_WIRED EXPAND=FALSE

  SECTION
    oss$network_wired: WRITE;

*DECK DECK=OSS$TASK_PRIVATE EXPAND=FALSE

  SECTION
    oss$task_private: write;
*DECK DECK=OSS$TASK_SHARED EXPAND=FALSE

  SECTION
    oss$task_shared: write;
*DECK DECK=OST$170_OS_TERMINATION_STATUS EXPAND=FALSE

  TYPE
    ost$170_os_termination_status = (osc$ots7_running, osc$ots7_moded_out, osc$ots7_fatal_due);
*DECK DECK=OST$170_OS_TYPE EXPAND=FALSE

  TYPE
    ost$170_os_type = (osc$ot7_none, osc$ot7_dual_state_nos,
          osc$ot7_dual_state_nos_be);


*DECK DECK=OST$ACTIVE_DRIVER_TABLE_ENTRY EXPAND=FALSE
*DECK DECK=OST$ACTIVITY_STATUS EXPAND=FALSE
  TYPE
    ost$activity_status = record
      complete: boolean,
      status: ost$status,
    recend;

*copyc ost$status
*DECK DECK=OST$AGING_INTERVAL EXPAND=FALSE

  CONST
*IF NOT $true(osv$unix)
    osc$aging_interval_maximum = 0ffffffff(16);
*ELSE
    osc$aging_interval_maximum = 7fffffff(16);
*IFEND

  TYPE
    ost$aging_interval = 0..osc$aging_interval_maximum;

*DECK DECK=OST$APPLICATION_MENU_NAME EXPAND=FALSE

  TYPE
    ost$application_menu_name = ost$name;

*copyc ost$name
*DECK DECK=OST$BASE_SYSTEM_TIME EXPAND=FALSE


{  NOTE:  If this type definition is changed the allocation of this
{  variable in 'mtamtr' must also be changed.

  TYPE
    ost$base_system_time = record
      second: 0 .. 59,
      minute: 0 .. 59,
      hour: 0 .. 23,
      day: 1 .. 31,
      month: 1 .. 12,
      year: 0 .. 4095,
      corresponding_microsecond_clock: ost$free_running_clock,
    recend;

*copyc OST$HARDWARE_SUBRANGES
*DECK DECK=OST$BINARY_DATE_AND_TIME EXPAND=FALSE

  TYPE
    ost$binary_date_and_time = record
      year: 0..255,  {year minus 1900, e.g. 80 = 1980}
      month: 1..12,
      day: 1..31,
      hour: 0..23,
      minute: 0..59,
      second: 0..59,
      millisecond: 0..999,
    recend;

*DECK DECK=OST$BINARY_UNIQUE_NAME EXPAND=FALSE

{ Note: Changing the size (in bytes) of this structure will result in a
{       permanent file breakage and a reload will be required.

  TYPE
    ost$binary_unique_name = packed record
      serial_number: ost$processor_serial_number,
      model_number: ost$processor_model_number,
      year: 1980 .. 2047,
      month: 1 .. 12,
      day: 1 .. 31,
      hour: 0 .. 23,
      minute: 0 .. 59,
      second: 0 .. 59,
      sequence_number: 0 .. 9999999,

{ the field fill pads this value to an even 11 bytes - this is for performance

      fill: 0 .. 7,
    recend;

*copyc ost$processor_model_number
*copyc ost$processor_serial_number
*DECK DECK=OST$BOOT_UPDATE_PAGE_TABLE EXPAND=FALSE
  TYPE
    ost$boot_update_page_table = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      pva: ^cell,
      length: integer,
    recend;
*copyc syt$monitor_request_code
*copyc syc$monitor_request_codes
*DECK DECK=OST$BYTE EXPAND=FALSE
  TYPE
    ost$byte = 0 .. 0ff(16);
*DECK DECK=OST$CALLER_IDENTIFIER EXPAND=FALSE

{Define the identifier that defines the caller of a program.

  TYPE
    ost$caller_identifier = packed record
      undefined: 0 .. 3,
      global_key: ost$key_lock_value,
      undefined2: 0 .. 3,
      local_key: ost$key_lock_value,
      ring: ost$ring,
      segnum: ost$segment,
    recend;

*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=OST$CENTRAL_MEMORY_MODEL_NUMBER EXPAND=FALSE

  TYPE
    ost$central_memory_model_number = osc$cmmn_min .. osc$cmmn_max;

  CONST
    osc$cmmn_min = 0,
    osc$cmmn_max = 0ff(16),
    osc$cmmn_11 = 11(16),
    osc$cmmn_12 = 12(16),
    osc$cmmn_13 = 13(16),
    osc$cmmn_14 = 14(16),
    osc$cmmn_20 = 20(16),
    osc$cmmn_30 = 30(16),
    osc$cmmn_31 = 31(16),
    osc$cmmn_40 = 40(16),
    osc$cmmn_41 = 41(16),
    osc$cmmn_42 = 42(16),
    osc$cmmn_46 = 46(16),
    osc$cmmn_48 = 48(16);
*DECK DECK=OST$CLEAR_FILE_SPACE EXPAND=FALSE


{ Secure memory/file parameter }

TYPE
  ost$clear_file_space = boolean;
*DECK DECK=OST$CONDITION_INFORMATION EXPAND=FALSE
{ when_handler_status: Always normal.  This specifies to SCL when handling that
{                      the condition is informational and not an error.
{ exception_status: The status of the exception condition that is being reported.
{ file_access_condition: The type of exception condition reported.
{ object_name: Specifies the name of the file or catalog object that encountered the condition.
{              If the object_name is osc$null_name, the name of the object could not be isolated.
{ file_segment_isolated: Specifies whether or not the condition was successfully
{                        isolated to a segment.  If not, the file_segment should
{                        be ignored.
{ file_segment: Specifies the segment that encountered the condition.  Ignore if
{           NOT file_segment_isolated.

  TYPE
    ost$condition_information = PACKED record
      when_handler_status: boolean,
      exception_status: ost$status,
      file_access_condition: fst$file_access_condition,
      object_name: ost$name,
      file_segment_isolated: boolean,
      file_segment: ost$segment,
    recend;

*copyc fst$file_access_condition
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
*DECK DECK=OST$CPU_DEFINITIONS EXPAND=FALSE

{ declarations for cpus }

  TYPE
    ost$cpu_element_id = ost$processor_element_id,
    ost$cpu_memory_port_number = 0 .. 1f(16),
    ost$cpu_memory_port_mask = 0 .. 1f(16),
    ost$logical_processor_id = 0 .. osc$maximum_processor_number,
    ost$next_processor_state = (osc$null, osc$off, osc$down);

?? PUSH (LISTEXT := ON) ??
*copyc osc$maximum_processor_number
*copyc osc$multiprocessor_constants
*copyc ost$processor_element_id
?? POP ??
*DECK DECK=OST$CPU_DOWN_STATE_REASON EXPAND=FALSE

{ TYPE declaration: OST$CPU_DOWN_STATE_REASON

  TYPE
    ost$cpu_down_state_reason = (osc$cdsr_null, osc$cdsr_downed_by_dft,
          osc$cdsr_due_threshold_exceeded, osc$cdsr_cpu_timeout,
          osc$cdsr_downed_by_operator, osc$cdsr_downed_by_system);

*DECK DECK=OST$CPU_IDLE_STATISTICS EXPAND=FALSE
 CONST
    osc$max_idle_count = 0ffffffffffffff(16);

 TYPE
    ost$cpu_idle_statistics = record
      idle_no_io_active: integer,
      idle_io_active: integer,
      idle_start_time: integer,
      idle_type: ost$idle_type,
      idle_count: 0 .. osc$max_idle_count,
    recend;

*copyc ost$idle_type
*DECK DECK=OST$CPU_STATE EXPAND=FALSE

  TYPE
    ost$cpu_state = RECORD
      current_state,
      next_state: ost$cpu_running_or_stepped,
    RECEND,

    ost$cpu_running_or_stepped = (osc$cpu_running, osc$cpu_stepped);

*DECK DECK=OST$CPU_STATE_REASON EXPAND=FALSE
*DECK DECK=OST$CPU_STATE_TABLE EXPAND=FALSE

{         WARNING! WARNING! WARNING! WARNING! WARNING! WARNING! WARNING!
{ If this type is changed the type MTA$CPU_STATE_TABLE must reflect a
{ corresponding change!
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
    ost$state_tables = array [0 .. osc$max_number_of_processors - 1] of ost$cpu_state_table;

  TYPE
    ost$cpu_state_table = record
      fill: ALIGNED [0 MOD 8] 0 .. 0ff(16),
      dispatching_priority: jmt$dispatching_priority,
      dual_state_prior_subpriority: tmt$dual_state_priority_entry,
      memory_port_mask: ost$cpu_memory_port_mask,
      cst_index: ost$logical_processor_id,
      processor_state: cmt$element_state,
      next_processor_state: cmt$element_state,
      cpu_alive_flag: ALIGNED [0 MOD 8] integer,
      taskid: ALIGNED [0 MOD 8] ost$global_task_id,
      ajlo: jmt$ajl_ordinal,
      dual_state_jps: 0 .. 0ffffffff(16),
      jcb_p: ALIGNED [0 MOD 8] ^jmt$job_control_block,
      cpu_state: ost$cpu_state,
      xcb_p: ALIGNED [0 MOD 8] ^ost$execution_control_block,
      xcb_rma: ALIGNED [0 MOD 8] integer,
      dispatch_control: ALIGNED [0 MOD 8] tmt$dispatch_control,
      max_cptime: ALIGNED [0 MOD 8] integer,
      accumulated_job_cptime: ALIGNED [0 MOD 8] integer,
      accumulated_monitor_cptime: ALIGNED [0 MOD 8] integer,
      ext_int_request: ALIGNED [0 MOD 8] ost$external_interrupt_request,
      idle_code: syt$180_idle_code,
      cst_index_x_8: 0 .. 255,
      time_last_cache_purge: ALIGNED [0 MOD 8] integer,
      time_last_map_request: ALIGNED [0 MOD 8] integer,
      monitor_mps: ALIGNED [0 MOD 8] ost$real_memory_address,
      aborted_task_count: ost$parcel,
      due_count: ost$parcel,
      element_id: ALIGNED [0 MOD 8] ost$cpu_element_id,
      ijl_ordinal: ALIGNED [0 MOD 8] jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      cpu_idle_statistics: ALIGNED [0 MOD 8] ost$cpu_idle_statistics,
      trace_control: ALIGNED [0 MOD 8] ost$cst_trace_control,
      termination_message: ALIGNED [0 MOD 8] string (80),
      reason_for_current_state: ALIGNED [0 MOD 8] ost$cpu_down_state_reason,
      pre_processed_for_reconfig: ost$pre_processed_for_reconfig,
      unused: boolean,
      previous_processor_state: cmt$element_state,
      log_cpu_state_change: boolean,
      next_ptlo_to_dispatch: ost$task_index,
      fill_ff: 0 .. 0ff(16),
      dispatching_priority_integer: ALIGNED [0 MOD 8] integer,
      async_limit: ALIGNED [0 MOD 8] integer,
    recend;

*copyc cmt$element_state
*copyc jmt$ajl_ordinal
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc jmt$job_control_block
*copyc ost$cpu_definitions
*copyc ost$cpu_idle_statistics
*copyc ost$cpu_state
*copyc ost$cpu_down_state_reason
*copyc ost$execution_control_block
*copyc ost$external_interrupt_request
*copyc ost$global_task_id
*copyc ost$hardware_subranges
*copyc ost$pre_processed_for_reconfig
*copyc ost$segment_descriptor
*copyc ost$cst_trace_control
*copyc syt$180_idle_code
*copyc tmt$dispatch_control
*copyc tmt$dual_state_dispatch_prior
*DECK DECK=OST$CPU_STATISTICS EXPAND=FALSE

  TYPE
    ost$cpu_statistics = RECORD
      idle_stats: ARRAY [0 .. (osc$max_number_of_processors - 1)] OF ost$cpu_idle_statistics,
      processor_defined: ARRAY [0 .. (osc$max_number_of_processors - 1)] OF boolean,
      cpu_count: 0 .. (osc$max_number_of_processors - 1),
      nos_stats: ost$nos_stats,
      cpu_execution_stats: tmt$cpu_execution_statistics,
    RECEND,

    ost$nos_stats = RECORD
      nos_on: boolean,
      nos_time: integer,
      nos_time_ve_idle: integer,
    RECEND;

*copyc jmt$dispatching_priority
*copyc ost$cpu_idle_statistics
*copyc tmt$cpu_execution_statistics
*DECK DECK=OST$CP_TIME EXPAND=FALSE

{Define cp time statistics record.
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
*IF NOT $true(osv$unix)
    ost$cp_time_value = 0 .. 0ffffffffff(16),
*ELSE
    ost$cp_time_value = 0 .. 7fffffff(16),
*IFEND

    ost$cp_time = record
      time_spent_in_job_mode: ost$cp_time_value,
      time_spent_in_mtr_mode: ost$cp_time_value,
    recend;
*DECK DECK=OST$CST_TRACE_CONTROL EXPAND=FALSE
 TYPE
    ost$cst_trace_control = packed record
      fill: 0 .. 0ffff(16),
      buffer_p: ^cell,
    recend;
*DECK DECK=OST$DATA_ID EXPAND=FALSE
 TYPE
    ost$data_id = (osc$page_faults, osc$mtr_requests, osc$job_data,
      osc$aging_statistics, osc$jm_mm_statistics, osc$swap_statistics,
      osc$cpu_statistics, osc$pio_stats, osc$job_sched_statistics,
      osc$swap_file_statistics, nac$namve_statistics, nac$intranet_statistics,
      nac$osi_statistics, nac$osi_device_spec_statistics),

    ost$data_id_set = set of ost$data_id;

  TYPE
    ost$display_format = (osc$incremental, osc$total);


  TYPE
    ost$page_fault_stats = record
      time: ost$free_running_clock,
      pf_stats: mmt$pf_statistics,
    recend,

    ost$paging_stats = record
      time: ost$free_running_clock,
      p_stats: mmt$paging_statistics,
    recend,

    ost$mtr_stats = record
      time: ost$free_running_clock,
      mtr_reqs: mtt$request_table,
    recend,

    ost$aging_stats = record
      time: ost$free_running_clock,
      aging_stats: mmt$aging_statistics,
    recend,

    ost$job_stats = record
      time: ost$free_running_clock,
      job_data: jmt$job_statistics,
    recend,

    ost$task_stats = record
      time: ost$free_running_clock,
      active_task_count: 0..pmc$max_task_id,
      active_task_statistics: array [1..*] of pmt$raw_task_statistics,
    recend,

    ost$jm_mm_stats = record
      time: ost$free_running_clock,
      jm_mm_stats: ost$jm_mm_statistics,
    recend,

    ost$swap_stats = record
      time: ost$free_running_clock,
      swap_stats: jst$swap_state_statistics,
      swap_file_page_count: jst$swap_file_page_count,
    recend,

    ost$swap_file_stats = record
      time: ost$free_running_clock,
      swap_file_stats: jst$swap_file_statistics,
    recend,

    ost$cpu_stats = record
      time: ost$free_running_clock,
      cpu_stats: ost$cpu_statistics,
    recend,

    ost$disk_unit_stats = record
      time: ost$free_running_clock,
      disk_unit_stats: array [1 .. *] of iot$disk_unit_usage,
    recend,

    ost$disk_pp_stats = record
      time: ost$free_running_clock,
      disk_pp_stats: array [1 .. *] of
           iot$disk_pp_usage,
    recend,


    ost$sched_stats = record
      time: ost$free_running_clock,
      job_scheduler_statistics: jmt$job_scheduler_statistics,
    recend;

  TYPE
    ost$disk_space = record
      recorded_vsn: rmt$recorded_vsn,
      available_space: integer,
      unit_used: boolean,
    recend,

    ost$disk_space_stats = record
      time: ost$free_running_clock,
      disk_space: array [1 .. *] of
           ost$disk_space,
    recend;

  TYPE
    ost$namve_statistics = record
      time: ost$free_running_clock,
      stats: record
        internet: ALIGNED [0 MOD 8] nat$internet_statistics,
        transport: nat$transport_statistics,
        session: nat$session_statistics,
        routing: nat$routing_statistics,
        directory: nat$directory_statistics,
        file_access: nat$file_access_me_statistics,
        buffer_manager: nat$buffer_manager_statistics,
        pp_buffer_pool: nat$pp_buffer_pool_statistics,
      recend,
    recend;

  TYPE
    ost$intranet_statistics = record
      time: ost$free_running_clock,
      stats: ^array [1 .. * ] of nat$intranet_statistic,
    recend;

  TYPE
    ost$namve_osi_statistics = record
      time: ost$free_running_clock,
      statistics: record
        channel_connection: ALIGNED [0 MOD 8] nat$channel_connection_stats,
        link_access_agent: nat$link_access_statistics,
        network_access_agent: nat$network_access_statistics,
        system_management_entity: nat$system_mgmt_entity_stats,
        transport_access_agent: nat$transport_access_statistics,
      recend,
    recend;

  TYPE
    ost$channel_device_statistics = record
      time: ost$free_running_clock,
      statistics: nat$channel_device_statistics,
    recend;

  TYPE
    ost$service_class_stats = record
      time: ost$free_running_clock,
      service_class_stats: jmt$service_class_stats,
    recend;

  TYPE
    ost$job_class_stats = record
      time: ost$free_running_clock,
      job_class_stats: jmt$job_class_stats,
    recend;

*copyc osc$multiprocessor_constants
*copyc iot$disk_usage
*copyc iot$pp_interface_table
*copyc jmt$job_class_stats
*copyc jmt$job_scheduler_statistics
*copyc jmt$job_statistics
*copyc jmt$service_class_stats
*copyc jst$swap_file_page_count
*copyc jst$swap_state_statistics
*copyc jst$swap_file_statistics
*copyc mmt$aging_statistics
*copyc mmt$page_streaming_statistics
*copyc mmt$paging_statistics
*copyc mmt$pf_statistics
*copyc mtt$request_table
*copyc nat$buffer_manager_statistics
*copyc nat$channel_connection_stats
*copyc nat$channel_device_statistics
*copyc nat$directory_statistics
*copyc nat$file_access_me_statistics
*copyc nat$internet_statistics
*copyc nat$intranet_statistics
*copyc nat$link_access_statistics
*copyc nat$network_access_statistics
*copyc nat$pp_buffer_pool_statistics
*copyc nat$routing_statistics
*copyc nat$session_statistics
*copyc nat$system_mgmt_entity_stats
*copyc nat$transport_access_statistics
*copyc nat$transport_statistics
*copyc ost$cpu_statistics
*copyc ost$free_running_clock
*copyc ost$hardware_subranges
*copyc ost$jm_mm_statistics
*copyc ost$status
*copyc pmt$raw_task_statistics
*copyc pmt$task_id

*DECK DECK=OST$DATE EXPAND=FALSE


{ Date request return value. }

  TYPE
    ost$date = record
      case date_format: ost$date_formats of
      = osc$month_date =
        month: ost$month_date, { month DD, YYYY }
      = osc$mdy_date =
        mdy: ost$mdy_date, { MM/DD/YY }
      = osc$iso_date =
        iso: ost$iso_date, { YYYY-MM-DD }
      = osc$ordinal_date =
        ordinal: ost$ordinal_date, { YYYYDDD }
      = osc$dmy_date =
        dmy: ost$dmy_date { DD.MM.YY }
      casend,
    recend,

    ost$date_formats = (osc$default_date, osc$month_date, osc$mdy_date,
      osc$iso_date, osc$ordinal_date, osc$dmy_date),

    ost$month_date = string (18),
    ost$mdy_date = string (8),
    ost$iso_date = string (10),
    ost$ordinal_date = string (7),
    ost$dmy_date = string (8);
*DECK DECK=OST$DATE_TIME EXPAND=FALSE

  TYPE
    ost$date_time = record
      year: 0..255,  {year minus 1900, e.g. 80 = 1980}
      month: 1..12,
      day: 1..31,
      hour: 0..23,
      minute: 0..59,
      second: 0..59,
      millisecond: 0..999,
    recend;

*DECK DECK=OST$DAY_OF_WEEK EXPAND=FALSE

  TYPE
    ost$day_of_week = (osc$monday, osc$tuesday, osc$wednesday, osc$thursday,
          osc$friday, osc$saturday, osc$sunday);

*DECK DECK=OST$DEADSTART_PHASE EXPAND=FALSE

  TYPE
    ost$deadstart_phase = (osc$installation_deadstart, osc$recovery_deadstart,
      osc$normal_deadstart),

    ost$image_file_status = (osc$recovery_complete, osc$empty);
*DECK DECK=OST$DEBUG_CODE EXPAND=FALSE

  TYPE
    ost$debug_code = (osc$data_read, osc$data_write, osc$instruction_fetch,
      osc$branching_instruction, osc$call_instruction, osc$end_of_list,
      osc$dc_6, osc$dc_7);

*DECK DECK=OST$DEBUG_LIST EXPAND=FALSE

  TYPE
    ost$debug_list_entry = packed record
      debug_code: ALIGNED[0 MOD 16] packed array [ost$debug_code] of boolean,
      low_fill: 0 .. 0fff(16),
      seg: ost$segment,
      low_bn: ost$segment_offset,
*IF NOT $true(osv$unix)
      high_fill: 0 .. 0ffffffff(16),
*ELSE
      high_fill_1: 0 .. 0ffff(16),
      high_fill_2: 0 .. 0ffff(16),
*IFEND
      high_bn: ost$segment_offset,
    recend,

    ost$debug_list = array [0 .. 31] of ost$debug_list_entry;

*copyc OST$DEBUG_CODE
*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=OST$DEBUG_MASK EXPAND=FALSE

  TYPE
    ost$debug_mask = packed record
      end_of_list_seen_flag: boolean,
      scan_in_progress: boolean,
      codes: packed array [osc$data_read .. osc$call_instruction] of boolean,
    recend;

*copyc OST$DEBUG_CODE
*DECK DECK=OST$DEFAULT_DATE_FORMAT EXPAND=FALSE

  TYPE
    ost$default_date_format = RECORD
      date_format: ost$date_formats,
      format_string: string (9),
    RECEND;

*copyc ost$date
*DECK DECK=OST$DEFAULT_TIME_FORMAT EXPAND=FALSE

  TYPE
    ost$default_time_format = RECORD
      time_format: ost$time_formats,
      format_string: string (15),
    RECEND;

*copyc ost$time
*DECK DECK=OST$DF_READY_TASK_WITH_UTID EXPAND=FALSE

{ Parameters send from CLIENT to SERVER.

  TYPE
    ost$df_ready_task_with_utid_inp = record
      utid_converter: ost$universal_task_id_mask,
    recend;

*copyc ost$universal_task_id_mask
*DECK DECK=OST$DIAGNOSTIC_SEVERITY EXPAND=FALSE

  TYPE
    ost$diagnostic_severity = (osc$non_standard_severity,
          osc$dependent_severity, osc$informative_severity,
          osc$warning_severity, osc$error_severity, osc$fatal_severity,
          osc$catastrophic_severity);

*DECK DECK=OST$ECP_EXCEPTION_CONTEXT EXPAND=FALSE
  TYPE
    ost$ecp_exception_context = record
      { Information contained in the following record is externalized to an
      { end-user's condition handler for user-defined conditions.
      externalized_info {input, output} : ost$condition_information,

      {The following information is private to the processing of conditions:
      {
      { CALLER_WILL_RETRIEVE_FILE is only set when fsp$open_file or pfp$attach
      { call osp$enforce_exception_policies because these are the only
      { interfaces that will retreive an archived file.  All other callers
      { must not be allowed to wait on a data_retrieval_required condition.
      {
      { CATALOG_MOVE_COUNT specifies the number of times that a space unavailable
      { condition on a catalog has caused the catalog to be moved.  When the count
      { reaches osc$max_catalog_moves, the catalog will no longer be moved and the
      { space must be made available on the catalog's current device.
      {
      { CATALOG_OBJECT is only set when we are attempting to create a catalog.
      { It is used to properly diagnose the mass_storage_class of a nonexistant
      { object.
      {
      { FORCE_WAIT is only set to FALSE when we are processing a segment fault
      { such as volume_unavailable or space_unavailable.  The installed
      { exception policies are ignored at this time.  By forcing a wait, we
      { raise the condition so the accessor may process it.  We do not support
      { an exit policy at this time to prevent recursion in ring 3 on setting
      { a lock.
      {
      { INITIAL_CALL is set to TRUE when the context is initialized and is
      { set to FALSE by OSP$ENFORCE_EXCEPTION_POLICIES each time this context
      { is processed.
      {
      { LOGGING_ALLOWED is only set to FALSE when we are processing a
      { segment fault such as volume_unavailable or space_unavailable.  This
      { prevents filling the log.  In other situations, we maintain this
      { context record throughout successive wait periods.  However for segment
      { faults, we cannot maintain a context; it is lost every time we exit
      { from wait.

      allowed_access_conditions {input} : fst$file_access_conditions,
      caller_will_retrieve_file {input} : boolean,
      file {input} : ost$ecp_file_identification,
      force_wait {input} : boolean,
      initial_call {input} : boolean,
      logging_allowed {input} : boolean,
      password {input} : pft$name,

      catalog_move_count {input, output} : 0 .. osc$ecp_max_catalog_moves,
      condition_status {input, output} : ost$status,
      raised_conditions {input, output} : fst$file_access_conditions,
      wait {input, output} : boolean,
      wait_time {input, output} : 0 .. fsc$longest_wait_time,

      catalog_object {input} : boolean,
      elapsed_wait_time {output} : 0 .. fsc$longest_wait_time,
    recend;

*copyc fsc$longest_wait_time
*copyc fst$file_access_conditions
*copyc osc$ecp_max_catalog_moves
*copyc ost$condition_information
*copyc ost$ecp_file_identification
*copyc ost$status
*DECK DECK=OST$ECP_FILE_IDENTIFICATION EXPAND=FALSE
  TYPE
    ost$ecp_file_identification = record
      case selector: ost$ecp_file_identifier of
      = osc$ecp_evaluated_file_ref =
        evaluated_file_reference: fst$evaluated_file_reference,
      = osc$ecp_file_identifier =
        file_identifier: amt$file_identifier,
      = osc$ecp_file_reference =
        file_reference: ^fst$file_reference,
      = osc$ecp_file_segment =
        file_segment: ^cell,
      = osc$ecp_pf_path =
        pf_path: ^pft$path,
        cycle_selector: pft$cycle_selector,
      casend,
    recend;

*copyc amt$file_identifier
*copyc fst$evaluated_file_reference
*copyc fst$file_reference
*copyc ost$ecp_file_identifier
*copyc pfd$permanent_file_definitions
*DECK DECK=OST$ECP_FILE_IDENTIFIER EXPAND=FALSE
  TYPE
    ost$ecp_file_identifier = (osc$ecp_evaluated_file_ref,
          osc$ecp_file_identifier, osc$ecp_file_reference, osc$ecp_file_segment,
          osc$ecp_pf_path);

*DECK DECK=OST$EMISSION_SETS EXPAND=FALSE

    CONST
      osc$max_stats_in_set = 50,
      osc$max_emit_time = 0ffffffffffff(16);

    TYPE
      ost$stat_entry = RECORD
        CASE stat : nac$min_statistic..osc$max_statistic OF
        = nac$namve_stats..nac$osi_device_specific_stats,
              osc$min_statistic .. osc$swap_state_stats-1,
              osc$swap_state_stats+1..osc$max_statistic =
          first_index : -1..100,
          second_index : -1..100,
        = osc$swap_state_stats =
          from_index : jmt$ijl_swap_status,
          to_index : jmt$ijl_swap_status,
        CASEND,
      RECEND;

    TYPE
      ost$emission_set = RECORD
        enabled : boolean,
        period : pmt$time_increment,
        microsecond_period : 1 .. osc$max_emit_time,
        next_emit_time : 0..osc$max_emit_time,
        stat_count : 0..osc$max_stats_in_set,
        stat_list : ARRAY [1..osc$max_stats_in_set] of ost$stat_entry
    RECEND;

    TYPE
      ost$emission_set_names = (osc$set_1, osc$set_2, osc$set_3, osc$set_4,
                       osc$immediate_emission_set),
      ost$periodic_emission_sets = osc$set_1..osc$set_4;

    CONST
      osc$all_stats = -1;

*copyc pmt$time_increment
*DECK DECK=OST$EXCHANGE_PACKAGE EXPAND=FALSE



{CYBER 180 processor exchange package.

  TYPE
    ost$exchange_package = packed record
      p_register: ost$p_register,
      undefined1: 0 .. 0f(16),
      vmid: ost$virtual_machine_identifier,
      undefined2: 0 .. 0f(16),
      uvmid: ost$virtual_machine_identifier,
      a0_dynamic_space_pointer: ^cell,
      flags: ost$flags,
      undefined3: 0 .. 03ff(16),
      trap_enable: ost$trap_enable,
      a1_current_stack_frame: ^cell,
      user_mask: ALIGNED ost$user_conditions,
      a2_previous_save_area: ^ost$minimum_save_area,
      monitor_mask: ALIGNED ost$monitor_conditions,
      a3: ^cell,
      user_condition_register: ost$user_conditions,
      a4: ^cell,
      monitor_condition_register: ost$monitor_conditions,
      a5: ^cell,
      undefined4: 0 .. 0f(16),
      keypoint_class_number: ost$keypoint_class,
      last_processor_id: 0 .. 0ff(16),
      a6: ^cell,
      keypoint_mask: ALIGNED ost$keypoint_mask,
      a7: ^cell,
      keypoint_code_1: 0 .. 0ffff(16),
      a8: ^cell,
      keypoint_code_2: 0 .. 0ffff(16),
      a9: ^cell,
      process_interval_timer_1: 0 .. 0ffff(16),
      aa: ^cell,
      process_interval_timer_2: 0 .. 0ffff(16),
      ab: ^cell,
      base_constant_1: 0 .. 0ffff(16),
      ac: ^cell,
      base_constant_2: 0 .. 0ffff(16),
      ad: ^cell,
      model_dependent_flags: 0 .. 0ffff(16),
      ae: ^cell,
      undefined5: 0 .. 0f(16),
      segment_table_length: ost$segment,
      af: ^cell,
      x_registers: array [ost$register_number] of ost$x_register,
      model_dependent_word: integer {ost$word} ,
      segment_table_address_1: 0 .. 0ffff(16),
      untranslatable_pointer: ost$pva,
      segment_table_address_2: 0 .. 0ffff(16),
      trap_pointer: ^cell,
      debug_index: 0 .. 63,
      undefined6: 0 .. 7,
      debug_mask_register: ost$debug_mask,
      debug_list_pointer: ^ost$debug_list,
      tos_registers: array [ost$valid_ring] of ost$top_of_stack_pointer,
    recend;

  TYPE
    ost$flags = set of (osc$critical_frame, osc$on_condition,
          osc$keypoint_enable, osc$process_not_damaged);

  TYPE
    ost$top_of_stack_pointer = packed record
      undefined: 0 .. 0fff(16),
      largest_ring_number: ost$ring, {only present in ring 1 TOS}
      pva: ost$pva,
    recend;

*copyc osd$virtual_address
*copyc osd$registers
*copyc ost$virtual_machine_identifier
*copyc ost$keypoint_class
*copyc osd$conditions
*copyc ost$trap_enable
*copyc ost$stack_frame_save_area
*copyc ost$debug_list
*copyc ost$debug_mask
*copyc ost$debug_code
*DECK DECK=OST$EXECUTION_CONTROL_BLOCK EXPAND=FALSE
{Declaration for the EXECUTION CONTROL BLOCK
{     *** If you add fields to this TYPE, make sure the constant in      ***
{     *** in SYA$CONSTANTS for XCBSIZE is >= actual size of this record  ***



  TYPE
    ost$execution_control_block = record
      xp: ALIGNED [0 MOD 416] ost$exchange_package,
      monitor_flags: syt$monitor_flags,
      processor_selections: ost$processor_id_set,
      requested_processor_selections: ost$processor_id_set,
      last_lpid_for_task: ost$processor_id,
{ End of fields referenced in assembly language
      system_task_id: tmt$system_task_id,
      critical_task: boolean,
      task_has_terminated: boolean,
      stlc_allocation: boolean,
      special_trap_count: 0 .. 0ff(16),
      global_task_id: ost$global_task_id,
      parent_global_task_id: ost$global_task_id,
      wait_inhibited: boolean,
      system_table_lock_count: ALIGNED [0 MOD 8] ost$cs_lock,
      system_flags: ALIGNED [0 MOD 8] tmt$system_flags,
      received_message_list: ALIGNED [0 MOD 8] nat$received_message_list,
      task_kind: ost$task_kind,
      task_is_terminating: boolean,
      task_has_been_rethreaded: boolean,
      system_give_up_cpu: boolean,
      subsystem_give_up_cpu: boolean,
      subsystem_lock_priority_count: 0 .. 0ff(16),
      dispatching_priority: jmt$dispatching_priority,
      dispatching_priority_bias_id: (jmc$dpb_positive, jmc$dpb_negative, jmc$dpb_absolute),
      dispatching_priority_bias: jmt$dispatching_priority,
      system_error_count: 0 .. 0ff(16),
      link: ^ost$execution_control_block,
      task_control_block: ^cell,
      task_id: pmt$task_id,
      stack_pages_saved: PACKED ARRAY [0 .. 15] of boolean,
      sdt_offset: ost$valid_relative_pointer,
      sdtx_offset: ost$valid_relative_pointer,
      pit_count: ost$free_running_clock,
      cp_time: ost$cp_time,
      page_wait_info: mmt$xcb_page_wait_info,
      timeslice: jmt$time_slice_values,
      relative_task_priority: 0 .. 255,
      ring1_termination_reason: ost$ring1_termination_reason,
      maxws_aio_slowdown: 0..0ffffff(16),
      monitor_faults: tmt$monitor_fault_buffer,
      signals: tmt$signal_buffer,
      paging_statistics: ost$paging_statistics,
      save9: string (31), { * * * currently used for task name * * * }
      iocb_p: ^cell,
      keypoint_enable: boolean,
      keypoint_register_enable: boolean,
      time_last_due: ost$cp_time_value,
      proc_malf_count: 0 .. 255,
      shadow_reference_info: mmt$shadow_reference_info,
      assign_active_sfid: gft$system_file_identifier
    recend;

*copyc gft$system_file_identifier
*copyc jmt$dispatching_priority
*copyc jmt$service_class_attributes
*copyc mmt$segment_descriptor_table
*copyc mmt$segment_descriptor_table_ex
*copyc mmt$shadow_reference_info
*copyc mmt$xcb_page_wait_info
*copyc nat$received_message_list
*copyc osd$conditions
*copyc osd$virtual_address
*copyc ost$cp_time
*copyc ost$exchange_package
*copyc ost$hardware_subranges
*copyc ost$name
*copyc ost$paging_statistics
*copyc ost$processor_id_set
*copyc ost$quantum
*copyc ost$ring1_termination_reason
*copyc ost$signature_lock
*copyc ost$task_id
*copyc ost$task_kind
*copyc pmt$task_id
*copyc syt$monitor_flags
*copyc tmt$monitor_fault_buffer
*copyc tmt$signal_buffer
*copyc tmt$system_flags
*copyc tmt$system_task_id
*DECK DECK=OST$EXTERNAL_INTERRUPT_REQUEST EXPAND=FALSE

{ OSDEIR - define external interrupt request for multi processors
{          if these definitions are changed, code in MTACST
{          must also be changed.

  TYPE
    ost$external_interrupt_request = packed record
      task_switch: boolean,
      purge_cache: boolean,
      purge_map: boolean,
      step_processor: boolean,
    recend;
*DECK DECK=OST$FAMILY_TABLE EXPAND=FALSE
  TYPE
    ost$family_table = array [1 .. * ] of record
      family_name: ost$name,
      set_name: stt$set_name,
      default_family_access: dft$family_access,
      p_client_access_list: ^dft$family_table_client_entry,
    recend;

*copyc dft$family_access
*copyc dft$family_table_client_entry
*copyc std$set_name
*copyc ost$name
*DECK DECK=OST$FORMAT_MESSAGE_LEVEL EXPAND=FALSE

  TYPE
    ost$format_message_level = (osc$current_message_level,
          osc$brief_message_level, osc$full_message_level);

*DECK DECK=OST$FREE_RUNNING_CLOCK EXPAND=FALSE

{ This represents the values attainable by the cyber 180 microsecond clock.

  TYPE
    ost$free_running_clock = 0 .. osc$free_running_clock_maximum;

  CONST
*IF NOT $true(osv$unix)
    osc$free_running_clock_maximum = 0ffffffffffff(16);
*ELSE
    osc$free_running_clock_maximum = 7fffffff(16);
*IFEND

*DECK DECK=OST$GET_MESSAGE_PART EXPAND=FALSE

  TYPE
    ost$get_message_part = ^procedure (VAR code: ost$status_condition_code;
                                       VAR message_parameters:
                                       ^ost$message_parameters;
                                       VAR end_of_message: boolean;
                                       VAR status: ost$status);

*copyc ost$message_parameters
*copyc ost$status
*DECK DECK=OST$GLOBAL_TASK_ID EXPAND=FALSE

  TYPE
    ost$global_task_id = record
      index: ost$task_index,
      seqno: 0 .. 255,
    recend;

  TYPE
    ost$task_index = 0 .. osc$max_tasks;

  CONST
    osc$max_tasks = 4095;
*DECK DECK=OST$HALFWORD EXPAND=FALSE
  TYPE
*IF NOT $true(osv$unix)
    ost$halfword = 0 .. 0ffffffff(16);
*ELSE
    ost$halfword = 0 .. 0ffff(16);
*IFEND
*DECK DECK=OST$HARDWARE_SUBRANGES EXPAND=FALSE
{Hardware defined subranges and container sizes.}

  TYPE
*IF NOT $true(osv$unix)
    ost$real_memory_address = 0 .. 0ffffffff(16),
*ELSE
    ost$real_memory_address = 0 .. 7fffffff(16),
*IFEND
    ost$real_memory_word_address = 0 .. 0fffffff(16),
    ost$byte_count = 0 .. 7fffffff(16);

{Define SVA.}

  TYPE
    ost$system_virtual_address = packed record
      asid: ost$asid,
      offset: ost$segment_offset,
    recend,

    ost$asid = 0 .. 0ffff(16);

*copyc OSD$VIRTUAL_ADDRESS
*copyc ost$byte
*copyc ost$free_running_clock
*copyc ost$halfword
*copyc ost$parcel
*copyc ost$word
*DECK DECK=OST$HEAP EXPAND=FALSE

*IF $true(osv$unix)
  CONST
{   osc$heap_size = 5FFFFF(16);
    osc$heap_size = 100000;

{Define Type declaration for the OS heaps.

  TYPE
    ost$heap = HEAP (ARRAY [1 .. osc$heap_size] of cell);

*ELSE
{Define segment numbers for system heaps and reserved segments.

  CONST
    osc$segnum_page_table = 0,
    osc$segnum_mainframe_wired = 1,
    osc$segnum_mainframe_wired_cb = 12(16),
    osc$segnum_mainframe_paged = 2,
    osc$segnum_job_fixed_heap = 3,
    osc$segnum_job_pageable_heap = 4,
    osc$segnum_task_private_heap = 5,
    osc$segnum_task_shared_heap = 6,
    osc$segnum_task_private_ring_11 = 7,
    osc$segnum_system_dayfile = 8,
    osc$segnum_job_dayfile = 9,

{ The following constant defines the segment number of the first global log
{  FOLLOWING the system dayfile.  The segment numbers are sequential starting
{  there

    osc$segnum_first_global_log = 1f(16);

{Define Type declaration for the OS heaps.

  TYPE
    ost$heap = HEAP (REP 3ffffff(16) of cell);
*IFEND
*DECK DECK=OST$HELP_MODULE EXPAND=FALSE

  TYPE
    ost$help_module = SEQ ( * );

*DECK DECK=OST$IDLE_STATE EXPAND=FALSE
{
{ Common deck OST$IDLE_STATE
{ This type describes the possible IDLE_STATES of the system.
{

  TYPE
    ost$idle_state = (osc$system_not_idle, osc$idle_system_in_progress,
          osc$resume_system_in_progress, osc$system_idle);
*DECK DECK=OST$IDLE_TYPE EXPAND=FALSE
 TYPE
    ost$idle_type = (osc$not_idle, osc$idle_with_io_active,
      osc$idle_no_io_active);
*DECK DECK=OST$INFORMATIVE_MESSAGE_RECORD EXPAND=FALSE

  TYPE
    ost$informative_message_record = RECORD
      message_type: integer,
      message: string (osc$max_string_size),
    RECEND;

*copyc ost$string
*DECK DECK=OST$INTERACTION_INFORMATION EXPAND=FALSE

  TYPE
    ost$interaction_information = array [1 .. * ] of ost$interaction_info_item;

*copyc ost$interaction_info_item
*DECK DECK=OST$INTERACTION_INFO_ITEM EXPAND=FALSE

  TYPE
    ost$interaction_info_item = record
      case key: ost$interaction_info_item_kind of
      = osc$null_interaction_info_item =
        ,
      = osc$interaction_style =
        style: ost$interaction_style,
      = osc$menu_rows =
        menu_rows: cst$number_of_menu_rows,
      = osc$extend_utility_interaction =
        extend_utility_interaction: boolean,
      = osc$rsrvd_interaction_info_item =
        reserved: ost$name,
      casend,
    recend;

*copyc cst$number_of_menu_rows
*copyc ost$interaction_info_item_kind
*copyc ost$interaction_style
*copyc ost$name
*DECK DECK=OST$INTERACTION_INFO_ITEM_KIND EXPAND=FALSE

  TYPE
    ost$interaction_info_item_kind = 0 .. 255;

  CONST
    osc$null_interaction_info_item = 0,
    osc$interaction_style = 1,
    osc$menu_rows = 2,
    osc$extend_utility_interaction = 3,
    osc$max_interaction_info_item = 3,
    osc$rsrvd_interaction_info_item = 255;

*DECK DECK=OST$INTERACTION_STYLE EXPAND=FALSE

  TYPE
    ost$interaction_style = (osc$line_interaction, osc$screen_interaction,
          osc$desktop_interaction);

*DECK DECK=OST$IOU_MODEL_NUMBER EXPAND=FALSE

{  Define the different IOU model numbers.

  TYPE
    osc$iou_model_number = osc$imn_min .. osc$imn_max;

  CONST
    osc$imn_min = 0,
    osc$imn_10 = 10(16),
    osc$imn_11 = 11(16),
    osc$imn_12 = 12(16),
    osc$imn_13 = 13(16),
    osc$imn_14 = 14(16),
    osc$imn_20 = 20(16),
    osc$imn_40 = 40(16),
    osc$imn_42 = 42(16),
    osc$imn_44 = 44(16),
    osc$imn_46 = 46(16),
    osc$imn_50 = 50(16),
    osc$imn_51 = 51(16),
    osc$imn_52 = 52(16),
    osc$imn_53 = 53(16),
    osc$imn_54 = 54(16),
    osc$imn_55 = 55(16),
    osc$imn_5B = 5B(16),
    osc$imn_5C = 5C(16),
    osc$imn_5D = 5D(16),
    osc$imn_5E = 5E(16),
    osc$imn_5F = 5F(16),
    osc$imn_max = 0ff(16);

*DECK DECK=OST$I_WAIT EXPAND=FALSE

  TYPE
    ost$i_wait_list = array [1 .. *] OF ost$i_activity,

    ost$i_activity = record
      case activity: ost$i_wait_activity OF
      =osc$i_null_activity=
        ,
      =osc$i_await_time=
        milliseconds: 0 .. 0ffffffff(16),
      =pmc$i_await_task_termination=
        task_id: pmt$task_id,
      =pmc$i_await_local_queue_message=
        qid: pmt$queue_connection,
      =nac$i_await_server_response, nac$i_await_switch_accept=
        file: ^fst$file_reference,
      =nac$i_await_connection=
        server: nat$application_name,
      =nac$i_await_switch_offer=
        source: jmt$system_supplied_name,
      =nac$i_await_activity_status=
        activity_status: ^ost$activity_status,
      =nac$i_await_data_available=
        file_identifier: amt$file_identifier,
      =nac$i_await_title_translation=
        translation_request: nat$directory_search_identifier,
      =nac$i_sk_await_clear_to_send=
        socket_identifier: nat$sk_socket_identifier,
      =nac$i_sk_await_data_available=
        socket_id: nat$sk_socket_identifier,
      =nac$i_sk_await_socket_offer=
        source_job: jmt$system_supplied_name,
      =rfc$i_await_server_response, rfc$i_await_switch_accept=
        connection_file: ^fst$file_reference,
      =rfc$i_await_incoming_connect, rfc$i_await_switch_offer=
        application_name: rft$application_name,
      =rfc$i_await_connection_event=
        connection_file_identifier: amt$file_identifier,
        event_type: rft$connection_events,
      =osc$i_await_unspecified_event=
        ,
    casend,
  recend,

    ost$i_wait_activity = (osc$i_null_activity, osc$i_await_time,
      pmc$i_await_task_termination, pmc$i_await_local_queue_message,
      nac$i_await_server_response, nac$i_await_connection,
      nac$i_await_switch_offer, nac$i_await_switch_accept,
      nac$i_await_activity_status, nac$i_await_data_available,
      nac$i_await_title_translation, rfc$i_await_server_response,
      rfc$i_await_incoming_connect, rfc$i_await_switch_offer,
      rfc$i_await_switch_accept, rfc$i_await_connection_event,
      osc$i_await_unspecified_event, iic$i_await_data_available,
      nac$i_sk_await_clear_to_send, nac$i_sk_await_data_available,
      nac$i_sk_await_socket_offer);
*copyc amt$file_identifier
*copyc fst$file_reference
*copyc jmt$system_supplied_name
*copyc nat$application_name
*copyc nat$directory_search_identifier
*copyc nat$sk_socket_identifier
*copyc ost$activity_status
*copyc PMD$LOCAL_QUEUES
*copyc pmt$task_id
*copyc rft$external_interface
*DECK DECK=OST$JM_MM_STATISTICS EXPAND=FALSE
 TYPE
    ost$jm_mm_statistics = record
      page_q_counts: mmt$page_q_counts,
      total_swapped_jobs: 0 .. 0ffff(16),
      total_ready_tasks: 0 .. tmc$maximum_ptl,
      total_ready_but_swapped_tasks: 0 .. tmc$maximum_ptl,
      total_active_jobs: 0 .. 0ffff(16),
      total_system_class: 0 .. 0ffff(16),
      total_interactive_jobs: 0 .. 0ffff(16),
      total_non_interactive_jobs: 0 .. 0ffff(16),
    recend;

*copyc mmt$page_q_counts
*copyc tmt$primary_task_list
*DECK DECK=OST$JOB_AND_MEMORY_STATS EXPAND=FALSE
{
{ This deck defines the types and constants used in the emitting of
{ system-wide job and page queue count information.
{

  TYPE
    ost$job_and_memory_stats = array [1 .. *] of integer;

  CONST
    osc$jms_free_pages = 1,
    osc$jms_available_pages = 2,
    osc$jms_avail_mod_pages = 3,
    osc$jms_wired_pages = 4,
    osc$jms_shared_pages = 5,  {sum of shared queues}
    osc$jms_fixed_pages = 6,
    osc$jms_io_error_pages = 7,
    osc$jms_job_working_set_pages = 8,
    osc$jms_swapped_jobs = 9,
    osc$jms_ready_tasks = 10,
    osc$jms_total_interactive_jobs = 11,
    osc$jms_tot_noninteractive_jobs = 12,

{ NOTE: Any additions to this deck must be made before this point.  The shared queues  defined below must
{       be the last definitions because the number of shared_site_defined queues varies.  Although the
{       individual shared queues need not be defined, they are listed here for convenience:
{           task_service        = 13
{           executable_file     = 14
{           non_executable_file = 15
{           device_file         = 16
{           file_server         = 17
{           Other               = 18
{           First_site_defined  = 19

    osc$jms_shared_first            = 13,
    osc$jms_shared_last_sys         = osc$jms_shared_first + mmc$pq_shared_last_sys - mmc$pq_shared_first,
    osc$jms_shared_first_site       = osc$jms_shared_last_sys + 1;

*copyc mmt$page_frame_queue_id
*DECK DECK=OST$KEYPOINT_CLASS EXPAND=FALSE

  TYPE
    ost$keypoint_class = 0 .. 0f(16),

    ost$keypoint_mask = set of ost$keypoint_class;
*DECK DECK=OST$KEYPOINT_CONTROL EXPAND=FALSE
 CONST
    osc$pr_processor_id = 11(16),
    osc$pr_keypoint_buffer_ptr = 63(16),
    osc$pr_set_keypoint_enable = 0cb(16),
    osc$pr_clear_keypoint_enable = 0ca(16),
    osc$kp_term_not_stopped = 0,

    osc$kpt_disabled = 0,
{ to use test mode .......
{ the keypoint in module mtm$monitor_interrupt_handler, between labels
{ BCRIT1 and ECRIT1 must be no-op'd. the original instruction is: B1511FA1
{ change it to: 95000000
    osc$kpt_test_mode = 1,
    osc$kpt_normal = 2,
    osc$kpt_normal_mp = 3,

    osc$kpt_pva_increment = 1000000(16),
    osc$max_kpt_pages = 128,
    osc$kpt_pva_segment = 0;

  TYPE
    ost$processor_keypoint_control = record
      avail_count: integer,
      avail_pfti: array [1 .. osc$max_kpt_pages] of mmt$page_frame_index,
      io_count: integer,
      io_pfti: array [1 .. osc$max_kpt_pages] of mmt$page_frame_index,
      in_use_count: integer,
      in_use_pfti: array [1 .. osc$max_kpt_pages] of mmt$page_frame_index,
      collector_pva: ^cell,
      sfid: gft$system_file_identifier,
      offset: integer,
      active: boolean,
      pid: integer,
    recend,
    ost$keypoint_control = record
      periodic_requested,
      active: boolean,
      envjm,
      envmm,
      jm,
      mm: ost$keypoint_mask,
      environment: ost$keypoint_environment,
      mpo: ost$keypoint_multipro_option,
      max_pages: integer,
      maximum_keypoints: integer,
      termination_status: integer,
      jsn: jmt$system_supplied_name,
      ijlo: jmt$ijl_ordinal,
      first_active_processor,
      last_active_processor: - 2 .. 31,
      lock: ALIGNED [0 MOD 8] integer,
      number_of_keypoint_files: 0 .. 0ff(16),
      keypoint_file_array: array [1 .. osc$max_number_of_processors] of amt$file_identifier,
      keypoint_pva_array: array [1 .. osc$max_number_of_processors] of ^cell,
      processor_selections: ost$processor_id_set,
      processor_select_flag: boolean,
      cpus: array [0 .. 7] of ost$processor_keypoint_control,
    recend,
    ost$ppu_keypoint_control = record
{ used by a pp - must not span pages
      number_of_processors: ALIGNED [0 MOD 1024] integer,
      pages_per_processor,
      page_size: integer,
      cpus: array [0 .. 7] of array [1 .. osc$max_kpt_pages] of integer,
    recend,
    ost$rb_keypoint_request = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      sub_request: (osc$kpt_mr_start, osc$kpt_mr_stop, osc$kpt_mr_issue,
        osc$kpt_mr_init, osc$kpt_mr_term, osc$kpt_mr_test, osc$kpt_mr_go),
      kpt: ost$class_15_keypoint,
    recend,
    ost$read_register = record
      case 0 .. 1 of
      = 0 =
        i: integer,
      = 1 =
        fill: 0 .. 0ffff(16),
        pva: ^cell,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$processor_id_set
*copyc osc$multiprocessor_constants
*copyc ost$page_table
*copyc ost$keypoint_environment
*copyc dmt$system_file_id
*copyc jmt$system_supplied_name
*copyc jmt$initiated_job_list_entry
*copyc syt$monitor_status
*copyc syt$monitor_request_code
*copyc syc$monitor_request_codes
*copyc ost$keypoint_class
*copyc ose$keypoint_conditions
*copyc ost$signature_lock
?? POP ??
*DECK DECK=OST$KEYPOINT_ENVIRONMENT EXPAND=FALSE
 TYPE
    ost$keypoint_environment = (osc$job_keypoints, osc$system_keypoints,
      osc$job_sample_keypoints, osc$system_sample_keypoints,
      osc$spare1_keypoints, osc$spare2_keypoints),
    ost$keypoint_class_mask = set of 0 .. 15,
    ost$keypoint_multipro_option = (osc$keypoints_single_processor,
      osc$keypoints_multi_processor),

{ OS keypoint definitions

    ost$keypoint = packed record
      clock: 0 .. 0fffffff(16),
      keypoint_class: 0 .. 0f(16),
      keypoint_data: 0 .. 0fffff(16),
      keypoint_code: 0 .. 0fff(16),
    recend,

{ CYBIL definition of general class 15 keypoint

    ost$class_15_keypoint = record
      keypoint: ost$keypoint,
      date_time: ost$date_time,
      microsecond_clock: integer,
      user_data: string (32),
    recend;

{ Keypoint code values for class 15 keypoints

  CONST
    osc$keypoint_cl15_reserve = 0,
    osc$keypoint_cl15_release = 1,
    osc$keypoint_cl15_start = 2,
    osc$keypoint_cl15_stop = 3,
    osc$keypoint_cl15_issue = 4;

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
?? POP ??
*DECK DECK=OST$MAINFRAME_CLASSES EXPAND=FALSE

  TYPE
    ost$mainframe_classes = (osc$mc_china_class,
          osc$mc_soviet_class, osc$mc_china_or_soviet_class);
*DECK DECK=OST$MAX_STATUS_MESSAGE_LINE EXPAND=FALSE

  TYPE
    ost$max_status_message_line = osc$min_status_message_line ..
          osc$max_status_message_line;

*copyc osc$max_status_message_line
*copyc osc$min_status_message_line
*DECK DECK=OST$MESSAGE_MODULE_SEVERITY EXPAND=FALSE
{
{ The type OST$MESSAGE_MODULE_SEVERITY is used to represent status and
{ diagnostic severities associated with a condition code in a message module
{ on an object library.  This type is not intended to be used outside of this
{ context.  The types OST$STATUS_SEVERITY and OST$DIAGNOSTIC_SEVERITY should
{ be used instead.  OST$STATUS_SEVERITY is used to represent the severity of
{ status conditions (i.e. in the context of the OST$STATUS record.
{ OST$DIAGNOSTIC_SEVERITY is used to represent the severity of diagnostics
{ produced by programs such as compilers.
{
{ The following table shows the mapping between the severity types.
{
{      MESSAGE MODULE        STATUS                DIAGNOSTIC
{
{      informative           informative           informative
{      warning               warning               warning
{      error                 error                 error
{      fatal                 fatal                 fatal
{      catastrophic          catastrophic          catastrophic
{      non_standard          informative           non_standard
{      dependent             informative           dependent
{

  TYPE
    ost$message_module_severity = (osc$mm_informative_severity,
          osc$mm_warning_severity, osc$mm_error_severity,
          osc$mm_fatal_severity, osc$mm_catastrophic_severity,
          osc$mm_non_standard_severity, osc$mm_dependent_severity);

*DECK DECK=OST$MESSAGE_PARAMETER EXPAND=FALSE

  TYPE
    ost$message_parameter = string ( * );

*DECK DECK=OST$MESSAGE_PARAMETERS EXPAND=FALSE

  TYPE
    ost$message_parameters = array [1 .. * ] of ^ost$message_parameter;

*copyc ost$message_parameter
*DECK DECK=OST$MESSAGE_TEMPLATE EXPAND=FALSE

  TYPE
    ost$message_template = string ( * );

*DECK DECK=OST$MESSAGE_TEMPLATE_INDEX EXPAND=FALSE

  TYPE
    ost$message_template_index = 0 .. osc$max_status_condition_code;

*copyc osc$max_status_condition_code
*DECK DECK=OST$MESSAGE_TEMPLATE_KIND EXPAND=FALSE

  TYPE
    ost$message_template_kind = (osc$status_message, osc$brief_help,
          osc$full_help, osc$application_menu, osc$parameter_prompt,
          osc$parameter_assistance_prompt, osc$parameter_help);

*DECK DECK=OST$MESSAGE_TEMPLATE_MODULE EXPAND=FALSE

  TYPE
    ost$message_template_module = SEQ ( * );

{
{ An ost$message_template_module contains an ost$mtm_header followed by:
{ - an array [0 .. header.number_of_codes - 1] of ost$mtm_condition_code,
{ (if header.number_of_codes > 0)
{ - an array [0 .. header.number_of_names - 1] of ost$mtm_condition_name,
{ - strings for each message template located via the template field of the
{ appropriate names array entry.
{ The codes array (if present) is sorted by the code field.
{ The names array is sorted by both the name and kind fields with name as
{ the primary sort key.
{

*copyc ost$mtm_condition_codes
*copyc ost$mtm_condition_names
*copyc ost$mtm_header
*DECK DECK=OST$MONITOR_FAULT EXPAND=FALSE

{ Declarations for a MONITOR FAULT
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
    ost$monitor_fault = record
      pva: ost$pva,
      a0,
      a1: ^cell,
      a2: ^ost$minimum_save_area,
      CASE identifier: tmt$monitor_fault_identifiers  OF
      = tmc$broken_task_fault_id =
        broken_task_fault: tmt$broken_task_monitor_fault,
      = tmc$mcr_fault =
        mcr_fault: tmt$mcr_faults,
      = mmc$segment_fault_processor_id =
        segment_access_fault: mmt$segment_access_condition,
      = syc$system_core_condition =
        system_core_condition: syt$system_core_condition,
      = tmc$dummy_fault =
        contents: ost$monitor_fault_contents,
      CASEND,
    recend,

    ost$monitor_fault_contents = array [1 .. osc$max_fault_contents] of 0 .. 0ff(16);

  CONST
    osc$max_fault_id = 63;

  CONST
    osc$max_fault_contents = 24;

*copyc ost$stack_frame_save_area
*copyc osd$registers
*copyc syt$system_core_condition
*copyc tmt$monitor_fault_buffer

*DECK DECK=OST$MONITOR_STACK EXPAND=FALSE
{  declarations for monitor stack other than processor zero.

  CONST
    osc$mtr_stack_length = 6500,
    osc$mtr_stack_frame_length = 32;

  TYPE
    ost$monitor_stack = record
      xp: ost$exchange_package,
      stack: array [1 .. osc$mtr_stack_frame_length] of 0 .. 0ff(16),
      csf: array [1 .. osc$mtr_stack_length - osc$mtr_stack_frame_length] of 0
        .. 0ff(16),
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc OST$EXCHANGE_PACKAGE
?? POP ??
*DECK DECK=OST$MTM_CONDITION_CODE EXPAND=FALSE

  TYPE
    ost$mtm_condition_code = record
      code: ost$status_condition_code,
      name_index: ost$message_template_index,
    recend;

*copyc ost$message_template_index
*copyc ost$status_condition_code
*DECK DECK=OST$MTM_CONDITION_CODES EXPAND=FALSE

  TYPE
    ost$mtm_condition_codes = array [0 .. * ] of ost$mtm_condition_code;

*copyc ost$mtm_condition_code
*DECK DECK=OST$MTM_CONDITION_NAME EXPAND=FALSE

  TYPE
    ost$mtm_condition_name = record
      name: ost$status_condition_name,
*IF NOT $true(osv$unix)
      template: REL (ost$message_template_module) ^ost$message_template,
      case kind: ost$message_template_kind of
      = osc$status_message =
        code: ost$status_condition_code,
        severity: ost$message_module_severity,
      = osc$brief_help, osc$full_help =
        { For these message kinds the name field is set to osc$null_name. } ,
      = osc$parameter_prompt, osc$parameter_assistance_prompt,
            osc$parameter_help =
        ,
      = osc$application_menu =
        { For this message kind the template field, above, is not used. }
        { Instead the following field is used to locate the menu data. }
        menu_header: REL (ost$message_template_module) ^ost$mtm_menu_header,
      casend,
*ELSE
      code: ost$status_condition_code,
      severity: ost$message_module_severity,
      template: string (256),
*IFEND
    recend;

*copyc ost$message_template
*copyc ost$message_template_kind
*copyc ost$message_template_module
*IF NOT $true(osv$unix)
*copyc ost$mtm_menu_header
*IFEND
*copyc ost$status_condition_code
*copyc ost$status_condition_name
*copyc ost$message_module_severity
*DECK DECK=OST$MTM_CONDITION_NAMES EXPAND=FALSE

  TYPE
    ost$mtm_condition_names = array [0 .. * ] of ost$mtm_condition_name;

*copyc ost$mtm_condition_name
*DECK DECK=OST$MTM_HEADER EXPAND=FALSE

  TYPE
    ost$mtm_header = record
      version: string (4),
      language: ost$natural_language,
      online_manual_name: ost$online_manual_name,
      number_of_codes: 0 .. osc$max_status_condition_code + 1,
      number_of_names: 0 .. osc$max_status_condition_code + 1,
    recend;

{
{ A llc$message_module (llc$help_module) is entered in the message module
{ dictionary if the number_of_codes field of its header is greater than zero.
{
{ A llc$help_module (llc$message_module) is entered in the help module
{ dictionary if the number_of_names field of its header is greater than the
{ number_of_codes field of its header.
{

*copyc osc$max_status_condition_code
*copyc ost$natural_language
*copyc ost$online_manual_name
*DECK DECK=OST$MTM_MENU_HEADER EXPAND=FALSE

  TYPE
    ost$mtm_menu_header = record
      number_of_menu_items: cst$menu_item_number,
      number_of_classes: cst$max_classes,
    recend;

*copyc cst$max_classes
*copyc cst$menu_item_number
*DECK DECK=OST$NAME EXPAND=FALSE

  CONST
    osc$max_name_size = 31,
    osc$null_name = '                               ';

  TYPE
    ost$name_size = 1 .. osc$max_name_size;

  TYPE
    ost$name = string (osc$max_name_size);
*DECK DECK=OST$NAME_REFERENCE EXPAND=FALSE

  TYPE
    ost$name_reference = string ( * <= osc$max_name_size);

*copyc ost$name
*DECK DECK=OST$NATURAL_LANGUAGE EXPAND=FALSE

  TYPE
    ost$natural_language = ost$name;

?? FMT (FORMAT := OFF) ??

  CONST
    osc$danish                      = 'DANISH                         ',
    osc$dutch                       = 'DUTCH                          ',
    osc$english                     = 'ENGLISH                        ',
    osc$finnish                     = 'FINNISH                        ',
    osc$flemish                     = 'FLEMISH                        ',
    osc$french                      = 'FRENCH                         ',
    osc$german                      = 'GERMAN                         ',
    osc$italian                     = 'ITALIAN                        ',
    osc$norwegian                   = 'NORWEGIAN                      ',
    osc$portuguese                  = 'PORTUGUESE                     ',
    osc$spanish                     = 'SPANISH                        ',
    osc$swedish                     = 'SWEDISH                        ',
    osc$us_english                  = 'US_ENGLISH                     ',

    osc$default_natural_language    = osc$us_english,

    osc$current_natural_language    = osc$null_name;

?? FMT (FORMAT := ON) ??

*copyc ost$name
*DECK DECK=OST$ONLINE_MANUAL_NAME EXPAND=FALSE

  TYPE
    ost$online_manual_name = ost$name;

*copyc ost$name
*DECK DECK=OST$OPERATING_SYSTEM_DEFAULT EXPAND=FALSE

  TYPE
    ost$operating_system_default = RECORD
      CASE kind: ost$os_default_kind OF
      = osc$os_name =
        os_name: pmt$os_name,
      = osc$date_time =
        free_running_clock: ost$free_running_clock,
        date_time: ost$date_time,
      = osc$default_date_format =
        default_date: ost$default_date_format,
      = osc$default_time_format =
        default_time: ost$default_time_format,
      = osc$time_zone =
        time_zone: ost$time_zone,
      CASEND,
    RECEND;

*copyc ost$date_time
*copyc ost$default_date_format
*copyc ost$default_time_format
*copyc ost$hardware_subranges
*copyc ost$os_default_kind
*copyc ost$time_zone
*copyc pmt$os_name
*DECK DECK=OST$OS_DEFAULTS EXPAND=FALSE

  TYPE
    ost$os_defaults = RECORD
      lock: ost$signature_lock,
      defaults_changed: boolean,
      system_time_zone: ost$time_zone,
      system_date_format: ost$default_date_format,
      system_time_format: ost$default_time_format,
      time_data: ost$os_defaults_time_data,
    RECEND,

    ost$os_defaults_os_name = pmt$os_name,

    ost$os_defaults_time_data = RECORD
      wait_to_change: boolean,
      wait_count: 0 .. 5,
      wait_frc: ost$os_defaults_wait_frc,
    RECEND,

    ost$os_defaults_wait_frc = RECORD
      min: ost$free_running_clock,
      max: ost$free_running_clock,
    RECEND;

*copyc ost$default_date_format
*copyc ost$default_time_format
*copyc ost$free_running_clock
*copyc ost$signature_lock
*copyc ost$time
*copyc ost$time_zone
*copyc pmt$os_name
*DECK DECK=OST$OS_DEFAULT_KIND EXPAND=FALSE

  TYPE
    ost$os_default_kind = (osc$os_name, osc$date_time, osc$default_date_format, osc$default_time_format,
          osc$time_zone);
*DECK DECK=OST$PAGE_SIZE EXPAND=FALSE

  TYPE

    {page size in bytes}

    ost$page_size = osc$min_page_size .. osc$max_page_size;

  CONST
    osc$min_page_size = 512,
    osc$max_page_size = 65536;

*DECK DECK=OST$PAGE_TABLE EXPAND=FALSE
{Page Table definitions - (hardware defined)}

  CONST
    osc$max_page_frames = 0ffff(16),
    osc$max_page_table_entries = 131072 * 2;

  TYPE
    ost$page_table_index = 0 .. osc$max_page_table_entries - 1,

    ost$page_id = packed record
      asid: 0 .. 0ffff(16),
      pagenum: 0 .. 3fffff(16),
    recend,

    ost$page_table_entry = packed record
      v: boolean,
      c: boolean,
      u: boolean,
      m: boolean,
      pageid: ost$page_id,
      rma: 0 .. 3fffff(16),
    recend,

    ost$page_table = array [ost$page_table_index] of ost$page_table_entry;
*DECK DECK=OST$PAGING_AND_MTR_STATS EXPAND=FALSE
{
{ This deck defines the types and constants used in the emitting of
{ paging (page fault + paging stats) and monitor request information.
{

  TYPE
    ost$paging_and_mtr_stats = array [1 .. 29] of integer;

  CONST
    osc$pms_pf_avail = 1,
    osc$pms_pf_avail_mod = 2,
    osc$pms_pf_disk_read = 3,
    osc$pms_pf_new_page = 4,
    osc$pms_pf_locked = 5,
    osc$pms_pf_io_reject = 6,
    osc$pms_force_aggr_aging = 7,
    osc$pms_aggr_age_shared_q = 8,
    osc$pms_aggr_age_job_q = 9,
    osc$pms_aggr_age_failed = 10,
    osc$pms_write_aged_page = 11,
    osc$pms_mr_cycle = 12,
    osc$pms_mr_cycle_aver_duration = 13,
    osc$pms_mr_delay = 14,
    osc$pms_mr_delay_aver_duration = 15,
    osc$pms_mr_wait = 16,
    osc$pms_mr_wait_aver_duration = 17,
    osc$pms_mr_write_mod_pages = 18,
    osc$pms_mr_wmp_aver_duration = 19,
    osc$pms_ps_prestream_initiated = 20,
    osc$pms_ps_initiated = 21,
    osc$pms_ps_prestream_only = 22,
    osc$pms_ps_terminated = 23,
    osc$pms_ps_pages_prestream = 24,
    osc$pms_ps_pages_streaming = 25,
    osc$pms_ps_task_slow = 26,
    osc$pms_ps_pages_faults_tu = 27,
    osc$pms_ps_pages_freed_behind = 28,
    osc$pms_ps_random_faults  = 29;
*DECK DECK=OST$PAGING_STATISTICS EXPAND=FALSE

{ OSDPFST - Type declarations for paging statistics record. }
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
    ost$paging_statistics = record
*IF NOT $true(osv$unix)
      page_in_count: 0 .. 0ffffffff(16),
      pages_reclaimed_from_queue: 0 .. 0ffffffff(16),
      new_pages_assigned: 0 .. 0ffffffff(16),
      pages_from_server:  0 .. 0ffffffff(16),
      page_fault_count:   0 .. 0ffffffffffff(16),
*ELSE
      page_in_count: 0 .. 7fffffff(16),
      pages_reclaimed_from_queue: 0 .. 7fffffff(16),
      new_pages_assigned: 0 .. 7fffffff(16),
      pages_from_server:  0 .. 7fffffff(16),
      page_fault_count:   0 .. 7fffffff(16),
*IFEND
      working_set_max_used: 0 .. 0ffff(16),
      incremental_max_ws: 0 .. 0ffff(16),
    recend;
*DECK DECK=OST$PARAMETER_HELP_NAMES EXPAND=FALSE

  TYPE
    ost$parameter_help_names = ARRAY [1 .. *] of ost$name;

*copyc ost$name
*DECK DECK=OST$PARCEL EXPAND=FALSE
  TYPE
    ost$parcel = 0 .. 0ffff(16);
*DECK DECK=OST$PHYSICAL_CHANNEL_NUMBER EXPAND=FALSE

{  Define cybil constants and types for 180 IOU subsystem CHANNEL numbers.

  CONST
    osc$max_channel_number = 31;

  TYPE
    ost$physical_channel_number = 0 .. osc$max_channel_number;

*DECK DECK=OST$PHYSICAL_PP_NUMBER EXPAND=FALSE

{  Define cybil constants and types for 180 IOU subsystem PP numbers.

  CONST
    osc$max_pp_number = 31(8);

  TYPE
    ost$physical_pp_number = 0 .. osc$max_pp_number;

*DECK DECK=OST$PP_SIZE EXPAND=FALSE

{  Define cybil constants and types for 180 IOU subsystem memory sizes.

  CONST
    osc$max_pp_size {size in PP bytes (16 bits per PP byte)}  = 37777(8);

  TYPE
    ost$pp_size = 0 .. osc$max_pp_size,
    ost$pp_byte_size = 0 .. 0ffff(16);
*DECK DECK=OST$PREVALIDATE_FREE_RESULT EXPAND=FALSE

  TYPE
    ost$prevalidate_free_result = (osc$heap_allocation_id_invalid, osc$heap_free_valid,
          osc$heap_linkage_invalid, osc$heap_pointer_invalid, osc$heap_verification_failure);

*DECK DECK=OST$PRE_PROCESSED_FOR_RECONFIG EXPAND=FALSE

  TYPE
    ost$pre_processed_for_reconfig = (osc$ppfr_not_processed, osc$ppfr_processing_in_progress,
          osc$ppfr_processing_complete);

*DECK DECK=OST$PROCESSOR_ELEMENT_ID EXPAND=FALSE
  TYPE
    ost$processor_element_id = record
      fill: ost$halfword,
      element_number: ost$processor_element_number,
      model_number: ost$processor_model_number,
      serial_number: ost$processor_serial_number,
    recend;

*copyc ost$halfword
*copyc ost$processor_element_number
*copyc ost$processor_model_number
*copyc ost$processor_serial_number
*DECK DECK=OST$PROCESSOR_ELEMENT_NUMBER EXPAND=FALSE

  TYPE
    ost$processor_element_number = 0 .. 0ff(16);
*DECK DECK=OST$PROCESSOR_ID EXPAND=FALSE

{ TYPE declaration: ost$processor_id

  TYPE
    ost$processor_id = 0 .. osc$maximum_processor_id;

*copyc osc$maximum_processor_id
*DECK DECK=OST$PROCESSOR_ID_SET EXPAND=FALSE

{ TYPE declaration: ost$processor_id_set

 TYPE
   ost$processor_id_set = SET OF ost$processor_id;

*copyc ost$processor_id
*DECK DECK=OST$PROCESSOR_MODEL_DEFINITIONS EXPAND=FALSE

  TYPE
    ost$processor_model_definition = RECORD
      pseudo_model_number: ost$processor_model_number,
      real_model_number: ost$processor_model_number,
      model_number_string: pmt$processor_model_number,
      processor_model_type: pmt$processor_model_type,
      multiple_processor_model_type: pmt$processor_model_type,
      quantum: integer,
      tick_time: integer,
      cache_present: boolean,
      maps_present: boolean,
      vector_capability: pmt$vector_capability,
    RECEND,

    ost$processor_search_data = RECORD
      CASE search_mode: ost$processor_search_modes OF
      = osc$psm_by_pseudo_model_number =
        pseudo_model_number: ost$processor_model_number,
      = osc$psm_by_real_model_number =
        real_model_number: ost$processor_model_number,
      = osc$psm_by_model_number_string =
        model_number_string: pmt$processor_model_number,
      CASEND,
    RECEND,

    { NOTE: The search mode of osc$psm_by_real_model_number is only
    { valid when retrieving the model definition of the machine that
    { is running the retrieving code.

    ost$processor_search_modes = (osc$psm_by_pseudo_model_number,
          osc$psm_by_real_model_number, osc$psm_by_model_number_string);

*copyc ost$processor_model_number
*copyc pmt$processor_model_number
*copyc pmt$processor_model_type
*copyc pmt$vector_capability
*DECK DECK=OST$PROCESSOR_MODEL_NUMBER EXPAND=FALSE

  TYPE
    ost$processor_model_number = 0 .. 0ff(16);

  CONST
    osc$cyber_180_model_unknown = 000(16),
    osc$cyber_180_model_815     = 011(16),
    osc$cyber_180_model_825     = 012(16),
    osc$cyber_180_model_830     = 013(16),
    osc$cyber_180_model_810     = 014(16),
    osc$cyber_180_model_835     = 020(16),
    osc$cyber_180_model_855     = 030(16),
    osc$cyber_180_model_845     = 031(16),
    osc$cyber_180_model_860     = 032(16),
    osc$cyber_180_model_850     = 033(16),
    osc$cyber_180_model_840     = 034(16),
    osc$cyber_180_model_845s    = 035(16),
    osc$cyber_180_model_855s    = 036(16),
    osc$cyber_180_model_840s    = 037(16),
    osc$cyber_900_model_9603    = 03a(16),
    osc$cyber_900_model_9601    = 03b(16),
    osc$cyber_900_model_960d    = 03c(16),   { Soviet Nuclear Safety System.
    osc$cyber_900_model_960c    = 03d(16),   { Soviet Nuclear Safety System.
    osc$cyber_180_model_990     = 040(16),
    osc$cyber_180_model_990e    = 041(16),
    osc$cyber_900_model_992     = 042(16),
    osc$cyber_900_model_992a    = 043(16),   { China Weather System.
    osc$cyber_900_model_994     = 044(16),
    osc$cyber_2000_model_20s1   = 046(16),   { CPU 46, CM 46, IOU 46.
    osc$cyber_2000_model_20u1   = 047(16),   { CPU 48, CM 46, IOU 46.
    osc$cyber_2000_model_20v1   = 048(16),   { CPU 48, CM 48, IOU 46.
    osc$cyber_180_model_930d    = 051(16),
    osc$cyber_180_model_9303    = 052(16),
    osc$cyber_180_model_9301    = 053(16),
    osc$cyber_900_model_9323    = 054(16),
    osc$cyber_900_model_9321    = 055(16),
    osc$cyber_180_model_930a    = 05b(16),
    osc$cyber_900_model_932a    = 05c(16),
    osc$cyber_180_model_930b    = 05d(16),
    osc$cyber_180_model_930c    = 05e(16),
    osc$cyber_900_model_932b    = 05f(16),

    osc$cyber_900_model_9703    = 0f8(16),   { CPU 3A, CM 35, IOU 40.
    osc$cyber_900_model_9701    = 0f9(16),   { CPU 3B, CM 35, IOU 40.
    osc$cyber_900_model_970d    = 0fa(16),   { CPU 3C, CM 35, IOU 40; Soviet.
    osc$cyber_900_model_970c    = 0fb(16),   { CPU 3D, CM 35, IOU 40; Soviet.
    osc$cyber_900_model_9723    = 0fc(16),   { CPU 3A, CM 35, IOU 44.
    osc$cyber_900_model_9721    = 0fd(16),   { CPU 3B, CM 35, IOU 44.
    osc$cyber_900_model_972d    = 0fe(16),   { CPU 3C, CM 35, IOU 44; Soviet.
    osc$cyber_900_model_972c    = 0ff(16);   { CPU 3D, CM 35, IOU 44; Soviet.

  CONST
    osc$cyber_180_model_992     = 042(16),   { Retained for compatibility only.
    osc$cyber_180_model_994     = 044(16),   { Retained for compatibility only.
    osc$cyber_180_model_9321    = 055(16),   { Retained for compatibility only.
    osc$cyber_180_model_9323    = 054(16),   { Retained for compatibility only.
    osc$cyber_180_model_932a    = 05c(16),   { Retained for compatibility only.
    osc$cyber_180_model_932b    = 05f(16),   { Retained for compatibility only.
    osc$cyber_180_model_9601    = 03b(16),   { Retained for compatibility only.
    osc$cyber_180_model_9603    = 03a(16);   { Retained for compatibility only.

*copyc pmt$processor_attributes
*DECK DECK=OST$PROCESSOR_SERIAL_NUMBER EXPAND=FALSE

  TYPE
    ost$processor_serial_number = 0 .. 0ffff(16);
*DECK DECK=OST$QUANTUM EXPAND=FALSE

  TYPE
    ost$quantum = 0 .. 7fffffff(16);
*DECK DECK=OST$RB_SYSTEM_ERROR EXPAND=FALSE
  TYPE
    ost$rb_system_error = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      fatal: boolean,
      status: syt$monitor_status,
      caller_p_register: ost$p_register,
      status_p: ^ost$status,
      text_p: ^string (*),
      condition: ost$status_condition,
      text: string(64),
    recend;
*copyc OST$STATUS
*copyc SYC$MONITOR_REQUEST_CODES
*copyc SYT$MONITOR_REQUEST_CODE
*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=OST$RECOVER_SYSTEM_SET_PHASE EXPAND=FALSE

  TYPE
    ost$recover_system_set_phase = (osc$recovery_not_required,
      osc$reinitialize_system_device);
*DECK DECK=OST$RING1_TERMINATION_REASON EXPAND=FALSE

  TYPE
    ost$ring1_termination_reason = (osc$rtr_non, osc$rtr_sft_full);
*DECK DECK=OST$SEGMENT_ACCESS_CONTROL EXPAND=FALSE

  TYPE
    ost$segment_access_control = record
      cache_bypass: boolean,
      execute_privilege: ost$execute_privilege,
      read_privilege: ost$read_privilege,
      write_privilege: ost$write_privilege,
    recend,

    ost$execute_privilege = (osc$non_executable, osc$non_privileged,
      osc$local_privilege, osc$global_privilege),

    ost$read_privilege = (osc$non_readable, osc$read_key_lock_controlled,
      osc$read_uncontrolled, osc$binding_segment),

    ost$write_privilege = (osc$non_writable, osc$write_key_lock_controlled,
      osc$write_uncontrolled, osc$wp_reserved);
*DECK DECK=OST$SEGMENT_DESCRIPTOR EXPAND=FALSE
{Segment descriptor word : describes a single segment.}
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
    ost$segment_descriptor = packed record
      vl: (osc$vl_invalid_entry, osc$vl_reserved, osc$vl_regular_segment, osc$vl_cache_bypass),
      xp: ost$execute_privilege,
      rp: ost$read_privilege,
      wp: ost$write_privilege,
      r1: ost$ring,
      r2: ost$ring,
      asid: ost$asid,
      key_lock: ost$key_lock,
    recend;

*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$HARDWARE_SUBRANGES
*copyc OST$SEGMENT_ACCESS_CONTROL
*DECK DECK=OST$SEGMENT_SET EXPAND=FALSE
TYPE
  ost$segment_set = set of ost$segment;
?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
?? POP ??
*DECK DECK=OST$SIGNATURE_LOCK EXPAND=FALSE

{Define lock word for COMPARE SWAP operations.}

  TYPE
    ost$compare_swap_lock = integer,
    ost$cs_lock = integer, {* * HCS compatibility * * *}
    ost$signature_lock = record
      lock_id: ALIGNED [0 MOD 8] integer,
    recend,


{Define lock byte for TEST_SET bit operations.}

    ost$byte_lock = packed array [0 .. 7] of boolean;

*copyc ost$signature_lock_status
*DECK DECK=OST$SIGNATURE_LOCK_STATUS EXPAND=FALSE
{  Define status values for compare-swap operations.
{  NOTE: this deck use to define types for OST$SIGNATURE_LOCK. These
{  definitions were removed from this deck and put in a non
{  program-interface deck OST$SIGNATURE_LOCK. The declarations have been
{ changed
{  for NOSVE internal use and were removed from this deck to minimize the
{ chance
{  of unexpected breakages. The original declarations are commented out and
{ given
{  below. Products that need these definitions should copy the following
{ declarations
{  into their own decks.
{
{            ost$compare_swap_lock = integer,
{            ost$cs_lock = integer, {* * HCS compatibility * * *}
{            ost$signature_lock = record
{              lock_id: ALIGNED [0 MOD 8] ost$cs_lock,
{              lock_count: integer,
{              reject_count: integer,
{            recend,
{


  CONST
    osc$cs_successful = 0,
    osc$cs_failed = 1,
    osc$cs_variable_locked = 2;

  TYPE
    ost$signature_lock_status = (osc$sls_not_locked,
          osc$sls_locked_by_another_task, osc$sls_locked_by_current_task);

*DECK DECK=OST$SIMULATED_DISK_FAULT EXPAND=FALSE
  CONST
    osc$max_simulated_faults = 5;

  TYPE
    ost$simulated_disk_fault = record
      in_use: boolean,
      sfid: dmt$system_file_id,
      direct_sfid: boolean,
      read_fault,
      write_fault: boolean,
      locked_page: boolean,
      first_byte,
      last_byte,
      skip_count,
      count: integer,
      error_type: iot$io_error,
    recend;
?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc iot$io_error
*copyc amt$local_file_name
*copyc pfd$catalog_locator
?? POP ??
*DECK DECK=OST$SPAA_ENTRY EXPAND=FALSE
{This deck defines the format of the SYSTEM POINTER ADDRESS ARRAY.

  TYPE
    ost$spaa_entry = packed record
      fill1: 0 .. 0ffff(16),
      address_type: 0 .. 0ffff(16),
      word_rma: 0 .. 0ffffffff(16),
      fill2: 0 .. 0ffff(16),
      table_p: ^cell,
    recend;


{Define constants for ADDRESS_TYPE.

  CONST
    osc$spid_pmf_interface_block = 1,
    osc$spid_7154_driver = 2,
    osc$spid_7155_1_driver = 3,
    osc$spid_7155_1x_driver = 4,
    osc$spid_7155_4x_driver = 5,
    osc$spid_7021_3x_driver = 6,
    osc$spid_7155_4x_16_bit_driver = 7,
    osc$spid_mfi_driver = 8,
    osc$spid_7021_4x_driver = 9,
    osc$spid_unused_driver_10 = 10,
    osc$spid_unused_driver_11 = 11,
    osc$spid_unused_driver_12 = 12,
    osc$spid_ismt_s0_driver_13 = 13,
    osc$spid_cm3_driver_14 = 14,
    osc$spid_map_driver = 15,
    osc$spid_console_input_buffer = 16,
    osc$spid_ica_driver = 17,
    osc$spid_lcn_driver = 18,
    osc$spid_mti_driver = 19,
    osc$spid_mdi_driver = 20,
    osc$spid_698_xx_driver = 21,
    osc$spid_fs_driver = 22,
    osc$spid_5698_xx_driver = 23,
    osc$spid_expresslink_driver = 24,
    osc$spid_5680_xx_driver = 25,
    osc$spid_hps_driver = 26,
    osc$spid_deadstart_tape_inp = 32,
    osc$spid_hcs_display_table = 48,
    osc$spid_deadstart_panel = 64,
    osc$spid_hcs_pp_commun_buffer = 80,
    osc$spid_deadstart_options = 96,
    osc$spid_scb_buffer = 128,
    osc$spid_memory_limits = 129,
    osc$spid_cti_parameters = 130,
    osc$spid_list_termination = 0;
*DECK DECK=OST$SPI_COMMUNICATION_BUFFER EXPAND=FALSE
  TYPE
    ost$spi_communication_buffer = packed record
{
{  First word is the PP portion of the communication buffer.
{
      current_pp_buffer: ost$parcel,
      current_byte_offset: ost$parcel,
      current_pp_status: ost$parcel,
      pp_word_filler: ost$parcel,
{
{  Second word is the CP portion of the communication buffer.
{
      current_cp_buffer: ost$parcel,
      current_cp_status: ost$parcel,
      spi_identifier: ost$parcel,
      processor_0_select: boolean,
      processor_1_select: boolean,
      processor_2_select: boolean,
      processor_3_select: boolean,
      processor_4_select: boolean,
      processor_5_select: boolean,
      processor_6_select: boolean,
      processor_7_select: boolean,
      interrupt_port_selector: ost$byte,
{
{ Third word is the control information for the SPI collection.
{
      number_of_spi_samples: ost$halfword,
      spi_sampling_interval: ost$halfword,
{
{ Fourth word starts the buffer control area for the SPI collection.
{
      spi_data_buffer_control: array [ost$number_of_spi_buffers] of
            ost$spi_data_buffer_control,
      element_reservation: array [1 .. 1] of cmt$element_reservation,
    recend,

    ost$number_of_spi_buffers = osc$first_spi_buffer .. osc$last_spi_buffer,
    ost$bytes_in_spi_buffer = 0 .. 2047,
    ost$words_in_spi_buffer = 0 .. 255,
    ost$spi_data_buffer_control = record
      current_word_offset: ost$parcel,
      current_buffer_status: ost$parcel,
      rma_of_buffer: ost$real_memory_address,
      pva_of_buffer: ^ost$spi_data_buffer,
      buffer_filler: ost$parcel,
    recend,
    ost$spi_data_buffer = record
      buffer: array [ost$words_in_spi_buffer] of integer,
    recend,
    ost$spi_buffers = array [ost$number_of_spi_buffers] of ost$spi_data_buffer;

  CONST
{
{  Values for the limits on the number of SPI buffers.
{
    osc$first_spi_buffer = 1,
    osc$last_spi_buffer = 16,
{
{  Values for CP Operation Status.
{
    osc$spi_wait_for_start = 1,
    osc$spi_start_collecting = 2,
    osc$spi_stop_collecting = 3,
    osc$spi_termination_requested = 4,
    osc$spi_process_complete = 5,
{
{ Values for PP Operation Status.
{
    osc$spi_pp_waiting_for_start = 6,
    osc$spi_pp_collecting_data = 7,
    osc$spi_pp_stopped_collecting = 8,
    osc$spi_pp_terminated = 9,
{
{  Values for Buffer Status.
{
    osc$spi_buffer_available = 1,
    osc$spi_buffer_in_user = 2,
    osc$spi_buffer_has_data = 3;

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_reservation
*copyc ost$byte
*copyc ost$halfword
*copyc ost$hardware_subranges
*copyc ost$parcel
*copyc ost$spi_types
?? POP ??
*DECK DECK=OST$SPI_CONTROL EXPAND=FALSE
  TYPE
    ost$spi_control = record
      lock: ALIGNED [0 MOD 8] integer,
      number_of_spi_samples: ost$number_of_spi_samples,
      max_pages: integer,
      ijle_p: ^jmt$initiated_job_list_entry,
      jsn: jmt$system_supplied_name,
      operation_status: ost$parcel,
      spi_sampling_interval: ost$spi_sampling_interval,
      spi_identifier: ost$spi_identifier,
      collection_file: amt$local_file_name,
      spi_environment: ost$spi_environment,
      data_string: string (32),
      initiator_task: ost$global_task_id,
      collector_task: ost$global_task_id,
      processor_0_select: boolean,
      processor_1_select: boolean,
      processor_2_select: boolean,
      processor_3_select: boolean,
      processor_4_select: boolean,
      processor_5_select: boolean,
      processor_6_select: boolean,
      processor_7_select: boolean,
      pp_available: boolean,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dmt$system_file_id
*copyc jmt$initiated_job_list_entry
*copyc jmt$system_supplied_name
*copyc mmt$page_frame_index
*copyc ose$spi_conditions
*copyc ost$global_task_id
*copyc ost$page_table
*copyc ost$parcel
*copyc ost$signature_lock
*copyc ost$spi_communication_buffer
*copyc ost$spi_types
?? POP ??
*DECK DECK=OST$SPI_DATA_HEADER EXPAND=FALSE
  TYPE
    ost$spi_data_header = record
      number_of_spi_samples: ost$number_of_spi_samples,
      spi_sampling_interval: ost$spi_sampling_interval,
      spi_identifier: ost$spi_identifier,
      run_comments: string (32),
      sample_date: ost$date,
      sample_time: ost$time,
      number_of_samples_collected: ost$number_of_spi_samples,
    recend;

*DECK DECK=OST$SPI_TYPES EXPAND=FALSE
  TYPE
    ost$spi_sampling_interval = 0 .. 100000,
    ost$number_of_spi_samples = 0 .. 100000000,
    ost$spi_identifier = 0 .. 0ff(16),
    ost$spi_environment = boolean,
    ost$spi_collection_header = record
      spi_identifier: ost$spi_identifier,
      date_time: ost$date_time,
      spi_sampling_interval: ost$spi_sampling_interval,
      data_string: string (32),
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
?? POP ??
*DECK DECK=OST$STACK_FRAME_SAVE_AREA EXPAND=FALSE

  TYPE
    ost$stack_frame_save_area = record
      minimum_save_area: ost$minimum_save_area,
      undefined: 0 .. 0ffff(16),
      a3: ^cell,
      user_condition_register: ost$user_conditions,
      a4: ^cell,
      monitor_condition_register: ost$monitor_conditions,
      a5: ^cell,
      a_registers: array[6 .. 0f(16)] OF record
        undefined: 0 .. 0ffff(16),
        a_register: ^cell,
      recend,
      x_registers: array [ost$register_number] OF ost$x_register,
    recend;

  TYPE
    ost$frame_descriptor = packed record
      critical_frame_flag: boolean,
      on_condition_flag: boolean,
      undefined: 0 .. 3(16),
      x_starting: ost$register_number,
      a_terminating: ost$register_number,
      x_terminating: ost$register_number,
    recend;

  TYPE
    ost$minimum_save_area = packed record
      p_register: ost$p_register,
      vmid: ost$virtual_machine_identifier,
      undefined: 0 .. 0fff(16),
      a0_dynamic_space_pointer: ^cell,
      frame_descriptor: ost$frame_descriptor,
      a1_current_stack_frame: ^cell,
      user_mask: ost$user_conditions,
      a2_previous_save_area: ^ost$stack_frame_save_area,
    recend;

*copyc OSD$REGISTERS
*copyc OSD$CONDITIONS
*copyc OST$VIRTUAL_MACHINE_IDENTIFIER
*DECK DECK=OST$STATUS EXPAND=FALSE

  TYPE
    ost$status = record
      case normal: boolean of
      = FALSE =
        condition: ost$status_condition_code,
        text: ost$string,
      = TRUE =
        ,
      casend,
    recend;

*copyc osc$max_condition
*copyc osc$status_parameter_delimiter
*copyc ost$status_condition
*copyc ost$status_condition_code
*copyc ost$string
*DECK DECK=OST$STATUS_CONDITION EXPAND=FALSE

  TYPE
    ost$status_condition = ost$status_condition_code;

*copyc ost$status_condition_code
*DECK DECK=OST$STATUS_CONDITION_CODE EXPAND=FALSE

  TYPE
    ost$status_condition_code = 0 .. osc$max_status_condition_code;

*copyc osc$max_status_condition_code
*DECK DECK=OST$STATUS_CONDITION_NAME EXPAND=FALSE

  TYPE
    ost$status_condition_name = ost$name;

*copyc ost$name
*DECK DECK=OST$STATUS_CONDITION_NUMBER EXPAND=FALSE

  TYPE
    ost$status_condition_number = 0 .. osc$max_status_condition_number;

*copyc osc$max_status_condition_number
*DECK DECK=OST$STATUS_IDENTIFIER EXPAND=FALSE

  TYPE
    ost$status_identifier = string (2);

*DECK DECK=OST$STATUS_MESSAGE EXPAND=FALSE

  TYPE
    ost$status_message = SEQ (ost$status_message_line_count,
          {} REP osc$status_message_height of ost$status_message_line_size,
          {} REP osc$status_message_height * (1 + osc$status_message_width) of
          char);

*copyc osc$status_message_height
*copyc osc$status_message_width
*copyc ost$status_message_line
*copyc ost$status_message_line_count
*copyc ost$status_message_line_size
*DECK DECK=OST$STATUS_MESSAGE_HEADER_KIND EXPAND=FALSE

  TYPE
    ost$status_message_header_kind = (osc$no_status_message_hdr,
          osc$subdued_status_message_hdr, osc$error_status_message_hdr,
          osc$standard_status_message_hdr);

*DECK DECK=OST$STATUS_MESSAGE_LEVEL EXPAND=FALSE

  TYPE
    ost$status_message_level = osc$brief_message_level ..
      osc$full_message_level;

*copyc ost$format_message_level
*DECK DECK=OST$STATUS_MESSAGE_LINE EXPAND=FALSE

  TYPE
    ost$status_message_line = string ( * <= osc$max_status_message_line);

*copyc osc$max_status_message_line
*DECK DECK=OST$STATUS_MESSAGE_LINE_COUNT EXPAND=FALSE

  TYPE
    ost$status_message_line_count = 0 .. osc$max_status_message_lines;

*copyc osc$max_status_message_lines
*DECK DECK=OST$STATUS_MESSAGE_LINE_SIZE EXPAND=FALSE

  TYPE
    ost$status_message_line_size = 0 .. osc$max_status_message_line;

*copyc osc$max_status_message_line
*DECK DECK=OST$STATUS_SEVERITY EXPAND=FALSE

  TYPE
    ost$status_severity = (osc$informative_status, osc$warning_status,
      osc$error_status, osc$fatal_status, osc$catastrophic_status);
*DECK DECK=OST$STRING EXPAND=FALSE

  CONST
    osc$max_string_size = 256;

  TYPE
    ost$string_size = 0 .. osc$max_string_size;

  TYPE
    ost$string_index = 1 .. osc$max_string_size + 1;

  TYPE
    ost$string = record
      size: ost$string_size,
      value: string (osc$max_string_size),
    recend;

*DECK DECK=OST$SYSTEM_ERROR_STATISTIC EXPAND=FALSE

  CONST
    osc$stacks_to_display = 8,
    osc$system_error_stat_msg_size = osc$max_string_size - pmc$mainframe_id_size - 1;

  TYPE
    ost$system_error_statistic = RECORD
      text: string (osc$system_error_stat_msg_size),
      counter: ARRAY [1 .. osc$stacks_to_display] OF integer,
    RECEND;

*copyc ost$string
*copyc pmt$mainframe_id
*DECK DECK=OST$SYSTEM_FLAG EXPAND=FALSE

  TYPE
    ost$system_flag = (pmc$kill_task_flag, avc$monitor_statistics_flag,
          pmc$sf_terminate_task, jmc$terminate_job_flag,
          tmc$mainframe_linked_signals, jmc$logout_flag_id, jmc$kill_job_flag,
          dsc$retrieve_system_message, nac$network_input_received,
          osc$keyp_environ_change_flag, tmc$flag_available_10,
          nac$channelnet_local_event, tmc$flag_available_12,
          syc$job_recovery_flag, ioc$subsystem_io_completed,
          dsc$log_dft_flag_id, ofc$operator_break_flag,
          osc$system_unstep_resume_flag, nlc$cc_work_list_flag,
          rfc$pp_response_available, mmc$failed_file_alloc_flag,
          mmc$volume_unavailable_flag, jmc$message_waiting_flag_id,
          tmc$flag_available_23, tmc$flag_available_24, tmc$flag_available_25,
          tmc$flag_available_26, tmc$flag_available_27, tmc$flag_available_28,
          tmc$flag_available_29, tmc$flag_available_30, tmc$flag_available_31);

  CONST
    tmc$first_system_flag = pmc$kill_task_flag,
    tmc$last_system_flag = tmc$flag_available_31,
    tmc$last_flag_id_assigned = 31;

  CONST
    osc$maximum_system_flag = 31;

*DECK DECK=OST$SYSTEM_PRIVILEGE_MAP EXPAND=FALSE
{ *copyc ost$system_privilege_map
{ Type for bit map to determine system privilege ( osp$verify_system_privilege )

  TYPE
    ost$system_privilege_map =
      PACKED ARRAY [ 0 .. mmc$default_sdt_length ] OF BOOLEAN;
*copyc mmc$default_sdt_length

*DECK DECK=OST$SYSTEM_TASK_DATA_CRITERIA EXPAND=FALSE

  TYPE
    ost$system_task_data_criteria = record
      case all_tasks: boolean of
      = FALSE =
        task_name: ost$name,
      = TRUE =
        { }
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=OST$SYSTEM_TASK_DISPLAY_DATA EXPAND=FALSE

  TYPE
    ost$system_task_display_data = array [1 .. * ] of
          ost$system_task_display_item,

    ost$system_task_display_item = record
      task_name: ost$name,
      automatic_restart: boolean,
      deactivate_task_option: ost$termination_type,
      idle_task_option: ost$termination_type,
      restart_after_idle: boolean,
      spy_identifier: pmt$spy_identifier,
      execution_ring: ost$valid_ring,
      active: boolean,
      task_status: pmt$task_status,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$termination_type
*copyc pmt$spy_identifier
*copyc osd$virtual_address
*copyc pmt$task_status
?? POP ??
*DECK DECK=OST$SYSTEM_TASK_WORK_TO_DO EXPAND=FALSE
  TYPE
    ost$system_task_work_to_do = record
      task_name: ost$name,
      log_task_status: boolean,
      task_status: ost$status,
      case kind: ost$st_work_to_do_kind of
      = osc$st_no_work_to_do =
        ,
      = osc$st_terminate_task =
        ,
      = osc$st_deactivate_task =
        ,
      = osc$st_execute_task =
        program_description: ^llt$program_description,
        parameters: ^clt$parameter_list,
        spy_identifier: pmt$spy_identifier,
        execution_ring: ost$valid_ring,
        first_execution: boolean,
      casend,
    recend,

    ost$st_work_to_do_kind = (osc$st_no_work_to_do, osc$st_execute_task,
          osc$st_terminate_task, osc$st_deactivate_task);

*copyc osd$virtual_address
*copyc ost$name
*copyc llt$program_description
*copyc clt$parameter_list
*copyc pmt$spy_identifier
*copyc ost$status
*DECK DECK=OST$TASK_ID EXPAND=FALSE

  TYPE
    ost$task_id = record
      global: ost$global_task_id,
      local: pmt$task_id,
    recend;

*copyc OST$GLOBAL_TASK_ID
*copyc PMT$TASK_ID
*DECK DECK=OST$TASK_KIND EXPAND=FALSE

  TYPE
    ost$task_kind = (osc$tk_nosve_task, osc$tk_unix_task);
*DECK DECK=OST$TASK_TIME_SLICE EXPAND=FALSE

  CONST
*IF NOT $true(osv$unix)
    osc$task_time_slice_maximum = 0ffffffff(16);
*ELSE
    osc$task_time_slice_maximum = 7fffffff(16);
*IFEND

  TYPE
    ost$task_time_slice = 0 .. osc$task_time_slice_maximum;
*DECK DECK=OST$TERMINATE_CONTINUE_STATS EXPAND=FALSE

{ The following type describes the kinds of statistics which are kept on NOS/VE system control.

  TYPE
    ost$terminate_continue_stats = (osc$idle_statistic, osc$step_statistic,
          osc$unstep_statistic, osc$resume_statistic, osc$terminate_statistic);

  TYPE
    ost$terminate_continue_record = RECORD
      date_time: ost$date_time,
      log_reason: syt$180_idle_code,
      log_statistic: ost$terminate_continue_stats,
      log_message: ost$string,
    RECEND;

*copyc ost$date_time
*copyc ost$string
*copyc syt$180_idle_code
*DECK DECK=OST$TERMINATION_TYPE EXPAND=FALSE

  TYPE
    ost$termination_type = (osc$tt_terminate, osc$tt_voluntary,
          osc$tt_ignore_or_prohibited);

*DECK DECK=OST$TIME EXPAND=FALSE

{ Time request return value. }

TYPE
  ost$time = record
    CASE time_format: ost$time_formats OF
    =osc$ampm_time=
      ampm: ost$ampm_time, { H12:MM AMORPM }
    =osc$hms_time=
      hms: ost$hms_time, { H24:MM:SS }
    =osc$millisecond_time=
      millisecond: ost$millisecond_time, { H24:MM:SS.S1000 }
    CASEND,
  recend,

  ost$time_formats = (osc$default_time, osc$ampm_time, osc$hms_time,
    osc$millisecond_time),

  ost$ampm_time = string (8),
  ost$hms_time = string (8),
  ost$millisecond_time = string (12);
*DECK DECK=OST$TIME_ZONE EXPAND=FALSE

  TYPE
    ost$time_zone = record
      hours_from_gmt: -12 .. 12,
      minutes_offset: -30 .. 30,
      daylight_saving_time: boolean,
    recend;

*DECK DECK=OST$TRAP_ENABLE EXPAND=FALSE

  TYPE
    ost$trap_enable = (osc$traps_disabled, osc$traps_undefined,
          osc$traps_enabled, osc$traps_enabled_delay);

*DECK DECK=OST$UNIVERSAL_TASK_ID EXPAND=FALSE

  TYPE
    ost$universal_task_id = integer;
*DECK DECK=OST$UNIVERSAL_TASK_ID_MASK EXPAND=FALSE

  TYPE
    ost$universal_task_id_mask = record
      CASE boolean of
      = TRUE =
        universal_task_id: ost$universal_task_id,
      = FALSE =
        binary_mainframe_id: pmt$binary_mainframe_id,
        global_task_id: ost$global_task_id,
        padding: 0 .. 0ffff(16),
     CASEND,
    recend;

*copyc pmt$binary_mainframe_id
*copyc ost$global_task_id
*copyc ost$universal_task_id
*DECK DECK=OST$USER_IDENTIFICATION EXPAND=FALSE
  TYPE
    ost$user_identification = record
      user: ost$user_name,
      family: ost$family_name,
    recend,

    ost$user_name = ost$name,

    ost$family_name = ost$name;

*copyc OST$NAME

*DECK DECK=OST$VECTOR_SIMULATION_CONTROL EXPAND=FALSE

{ * * * * WARNING - This record is contained in the SCB and is referenced * * *
{ * * * *           from assembly language trap handlers. Dont change     * * *
{ * * * *           this record without understanding the implications.   * * *

  TYPE
    ost$vector_simulation_control = record
      vector_simulation_attribute: pmt$vector_simulation,
      vector_divide_degraded: ost$processor_id_set,
      all_vector_divides_degraded: boolean,
    recend;

*copyc ost$processor_id_set
*copyc pmt$vector_simulation
*DECK DECK=OST$VIRTUAL_MACHINE_IDENTIFIER EXPAND=FALSE

  TYPE
    ost$virtual_machine_identifier = (osc$cyber_180_mode, osc$cyber_170_mode,
      osc$50_reserved, osc$51_reserved, osc$52_reserved, osc$53_reserved,
      osc$54_reserved, osc$55_reserved, osc$56_reserved, osc$57_reserved,
      osc$58_reserved, osc$59_reserved, osc$60_reserved, osc$61_reserved,
      osc$62_reserved, osc$63_reserved);
*DECK DECK=OST$WAIT EXPAND=FALSE


{ Asynchronous request parameter: used by all NOS/180 requests that }
{ can be performed asynchronously to indicate whether the caller }
{ wishes to execute the request synchronously or asynchronously. }

TYPE
  ost$wait = (osc$wait, osc$nowait);
*DECK DECK=OST$WAIT_FOR_LOCK EXPAND=FALSE
 TYPE
    ost$wait_for_lock = (osc$wait_for_lock, osc$nowait_for_lock);
*DECK DECK=OST$WORD EXPAND=FALSE
  TYPE
    ost$word = integer;
*DECK DECK=OSV$170_OS_TERMINATION_STATUS EXPAND=FALSE
{ Define termination status for 170 operating system.

  VAR
    osv$170_os_termination_status: [XREF] ost$170_os_termination_status;

?? PUSH (LISTEXT := ON) ??
*copyc ost$170_os_termination_status
?? POP ??
*DECK DECK=OSV$170_OS_TYPE EXPAND=FALSE

  VAR
    osv$170_os_type: [XREF, READ] ost$170_os_type;

?? PUSH (LISTEXT := ON) ??
*copyc ost$170_os_type
?? POP ??
*DECK DECK=OSV$180_MEMORY_LIMITS EXPAND=FALSE
{This variable specifies the lower and upper RMA addresses available to NOSVE.

  VAR
    osv$180_memory_limits: [XREF] record
      lower: 0 .. 0ffffffff(16),
      deadstart_upper: 0 .. 0ffffffff(16),  {  Upper limit of memory during deadstart.
      upper: 0 .. 0ffffffff(16),
    recend;

*DECK DECK=OSV$ADTT_PTR EXPAND=FALSE
*DECK DECK=OSV$ASCII6_FOLDED EXPAND=FALSE

  VAR
    osv$ascii6_folded: [XREF, READ] amt$collate_table;

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
?? POP ??
*DECK DECK=OSV$ASCII6_STRICT EXPAND=FALSE

  VAR
    osv$ascii6_strict: [XREF, READ] amt$collate_table;

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
?? POP ??
*DECK DECK=OSV$ASCII_TO_EBCDIC EXPAND=FALSE

VAR osv$ascii_to_ebcdic: [XREF, READ] array [0 .. 255] of 0 .. 255;
*DECK DECK=OSV$BASE_SYSTEM_TIME EXPAND=FALSE

  VAR
    osv$base_system_time: [XREF, oss$mainframe_wired] ost$base_system_time;

?? PUSH (LISTEXT := ON) ??
*copyc OST$BASE_SYSTEM_TIME
*copyc OSS$MAINFRAME_WIRED
?? POP ??
*DECK DECK=OSV$BOOT EXPAND=FALSE

  VAR
    osv$boot: [XREF] boolean;
*DECK DECK=OSV$BOOT_IS_EXECUTING EXPAND=FALSE

  { This variable contains a boolean value that tells whether
  { the boot is executing.  This variable is set up in
  { dsm$boot_interrupt_handler and mtm$monitor_interrupt_handler.
  { It is set to true in dsm$boot_interrupt_handler and false
  { in mtm$monitor_interrupt_handler.

  VAR
    osv$boot_is_executing: [XREF] boolean;
*DECK DECK=OSV$BOOT_SDTE EXPAND=FALSE

  VAR
    osv$boot_sdte: [XREF] mmt$segment_descriptor;
?? PUSH (LISTEXT := ON) ??
*copyc mmt$segment_descriptor_table
?? POP ??
*DECK DECK=OSV$BUILD_LEVEL EXPAND=FALSE

  VAR
    osv$build_level: [XREF, oss$mainframe_wired] string ( osc$build_level_size );

*copyc oss$mainframe_wired
*copyc osc$build_level_size
*DECK DECK=OSV$CATALOG_NAME_SECURITY EXPAND=FALSE

  VAR
    osv$catalog_name_security: [XREF] boolean;

*DECK DECK=OSV$COBOL6_FOLDED EXPAND=FALSE

  VAR
    osv$cobol6_folded: [XREF, READ] amt$collate_table;

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
?? POP ??
*DECK DECK=OSV$COBOL6_STRICT EXPAND=FALSE

  VAR
    osv$cobol6_strict: [XREF, READ] amt$collate_table;

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
?? POP ??
*DECK DECK=OSV$CONTROL_CODES_TO_QUEST_MARK EXPAND=FALSE
 VAR
    osv$control_codes_to_quest_mark: [XREF, READ] string (256);

*DECK DECK=OSV$CPUS_LOGICALLY_ON EXPAND=FALSE

  VAR
    osv$cpus_logically_on: [XREF] 0 .. osc$max_number_of_processors;

?? PUSH (LISTEXT := ON) ??
*copyc osc$multiprocessor_constants
?? POP ??
*DECK DECK=OSV$CPUS_PHYSICALLY_CONFIGURED EXPAND=FALSE

  VAR
    osv$cpus_physically_configured: [XREF] 1 .. osc$max_number_of_processors;

?? PUSH (LISTEXT := ON) ??
*copyc osc$multiprocessor_constants
?? POP ??
*DECK DECK=OSV$DATE_TIME_UPDATE EXPAND=FALSE

  VAR
    osv$date_time_update: [XREF] boolean;
*DECK DECK=OSV$DEADSTART_DEVICE_LUN EXPAND=FALSE

  VAR
    osv$deadstart_device_lun: [XREF] iot$logical_unit;

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
?? POP ??
*DECK DECK=OSV$DEADSTART_PHASE EXPAND=FALSE

  VAR
    osv$deadstart_phase: [XREF] ost$deadstart_phase;

?? PUSH (LISTEXT := ON) ??
*copyc OST$DEADSTART_PHASE
?? POP ??
*DECK DECK=OSV$DEBUGGER_OUTPUT_DISPOSITION EXPAND=FALSE

  VAR
    osv$debugger_output_disposition: [XREF] syt$debug_output_disposal_info;

?? PUSH (LISTEXT := ON) ??
*copyc syt$debug_output_disposal_info
?? POP ??
*DECK DECK=OSV$DEFAULT_SYSTEM_DATE_FORMAT EXPAND=FALSE
*DECK DECK=OSV$DEFAULT_SYSTEM_TIME_FORMAT EXPAND=FALSE
*DECK DECK=OSV$DELETE_UNRECONCILED_FILES EXPAND=FALSE

  VAR
    osv$delete_unreconciled_files: [XREF] boolean;

*DECK DECK=OSV$DISPLAY63_FOLDED EXPAND=FALSE

  VAR
    osv$display63_folded: [XREF, READ] amt$collate_table;

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
?? POP ??
*DECK DECK=OSV$DISPLAY63_STRICT EXPAND=FALSE

  VAR
    osv$display63_strict: [XREF, READ] amt$collate_table;

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
?? POP ??
*DECK DECK=OSV$DISPLAY64_FOLDED EXPAND=FALSE

  VAR
    osv$display64_folded: [XREF, READ] amt$collate_table;

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
?? POP ??
*DECK DECK=OSV$DISPLAY64_STRICT EXPAND=FALSE

  VAR
    osv$display64_strict: [XREF, READ] amt$collate_table;

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
?? POP ??
*DECK DECK=OSV$DUMP_WHEN_DEBUG EXPAND=FALSE

  VAR
    osv$dump_when_debug: [XREF] boolean;

*DECK DECK=OSV$EBCDIC EXPAND=FALSE

  VAR
    osv$ebcdic: [XREF, READ] amt$collate_table;

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
?? POP ??
*DECK DECK=OSV$EBCDIC6_FOLDED EXPAND=FALSE

  VAR
    osv$ebcdic6_folded: [XREF, READ] amt$collate_table;

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
?? POP ??
*DECK DECK=OSV$EBCDIC6_STRICT EXPAND=FALSE

  VAR
    osv$ebcdic6_strict: [XREF, READ] amt$collate_table;

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
?? POP ??
*DECK DECK=OSV$EBCDIC_TO_ASCII EXPAND=FALSE

VAR osv$ebcdic_to_ascii: [XREF, READ] array [0 .. 255] of 0 .. 255;
*DECK DECK=OSV$ECP_SEQUENCE_HEADERS EXPAND=FALSE

  VAR
    osv$ecp_sequence_headers: [XREF] array [ost$ecp_sequence_index] of
          ^ost$ecp_header;

?? PUSH (LISTEXT := ON) ??
*copyc ose$disk_ft_exceptions
?? POP ??
*DECK DECK=OSV$EMERGENCY_INTERVENTION EXPAND=FALSE

  VAR
    osv$emergency_intervention: [XREF] boolean;
*DECK DECK=OSV$ENABLE_HYPERCHANNEL EXPAND=FALSE

   CONST
     osc$segment_for_hyperchannel = 0a(16);

   VAR
     osv$enable_hyperchannel: [XREF] boolean;

*DECK DECK=OSV$EXTERNAL_INTERRUPT_SELECTOR EXPAND=FALSE

{ This variable indicates to which processor external interrupts should be  sent.

  VAR
    osv$external_interrupt_selector: [XREF] 0 .. 0ff(16);

*DECK DECK=OSV$FAMILY_TABLE EXPAND=FALSE
VAR
  osv$family_table: [XREF] ^ost$family_table;
?? PUSH (LISTEXT := ON) ??
*copyc ost$family_table
?? POP ??
*DECK DECK=OSV$GLOBAL_PROCESSOR_MODEL_INFO EXPAND=FALSE
*DECK DECK=OSV$IMAGE_FILE_ADTT_PTR EXPAND=FALSE
*DECK DECK=OSV$INITIAL_EXCEPTION_CONTEXT EXPAND=FALSE
  VAR
    osv$initial_exception_context: [XREF] ost$ecp_exception_context;

?? PUSH (LISTEXT := ON) ??
*copyc ost$ecp_exception_context
?? POP ??
*DECK DECK=OSV$INITIAL_MONITOR_XP EXPAND=FALSE

  VAR
    osv$initial_monitor_xp: [XREF] ost$exchange_package;

?? PUSH (LISTEXT := ON) ??
*copyc OST$EXCHANGE_PACKAGE
?? POP ??
*DECK DECK=OSV$INSTALLED_POLICIES EXPAND=FALSE
  VAR
    osv$installed_policies: [XREF] ^SEQ ( * );

*DECK DECK=OSV$INSTALL_JOB_TEMPLATES EXPAND=FALSE
VAR
  osv$install_job_templates: [XREF] boolean;
*DECK DECK=OSV$INTERACTION_INFORMATION EXPAND=FALSE
*DECK DECK=OSV$IOU_EXTERNAL_INTERRUPT EXPAND=FALSE
  VAR
    osv$iou_external_interrupt: [XREF] integer;


*DECK DECK=OSV$JOB_FIXED_HEAP EXPAND=FALSE

  VAR
    osv$job_fixed_heap: [XREF, READ, oss$job_fixed] ^ost$heap;

?? PUSH (LISTEXT := ON) ??
*copyc OST$HEAP
*copyc OSS$JOB_FIXED
?? POP ??
*DECK DECK=OSV$JOB_PAGEABLE_HEAP EXPAND=FALSE

  VAR
    osv$job_pageable_heap: [XREF, READ, oss$job_pageable] ^ost$heap;

?? PUSH (LISTEXT := ON) ??
*copyc OST$HEAP
*copyc OSS$JOB_PAGEABLE
?? POP ??
*DECK DECK=OSV$KEYPOINT_CONTROL EXPAND=FALSE
 VAR
    osv$keypoint_control: [XREF] ost$keypoint_control;

?? PUSH (LISTEXT := ON) ??
*copyc ost$keypoint_control
?? POP ??
*DECK DECK=OSV$LOWER_TO_UPPER EXPAND=FALSE

  VAR
    osv$lower_to_upper: [XREF] string (256);

*DECK DECK=OSV$LOWER_TO_UPPER_26 EXPAND=FALSE

  VAR
    osv$lower_to_upper_26: [XREF, READ] string (256);

*DECK DECK=OSV$LOWER_TO_UPPER_INTERNATIONL EXPAND=FALSE

  VAR
    osv$lower_to_upper_internationl: [XREF, READ] string (256);

*DECK DECK=OSV$MAINFRAME_PAGEABLE_HEAP EXPAND=FALSE

  VAR
    osv$mainframe_pageable_heap: [XREF, READ, oss$mainframe_pageable] ^ost$heap;

?? PUSH (LISTEXT := ON) ??
*copyc OST$HEAP
*copyc OSS$MAINFRAME_PAGEABLE
?? POP ??
*DECK DECK=OSV$MAINFRAME_WIRED_CB_HEAP EXPAND=FALSE
  VAR
    osv$mainframe_wired_cb_heap: [XREF] ^ost$heap;

?? PUSH (LISTEXT := ON) ??
*copyc OST$HEAP
?? POP ??
*DECK DECK=OSV$MAINFRAME_WIRED_HEAP EXPAND=FALSE

  VAR
    osv$mainframe_wired_heap: [XREF, READ, oss$mainframe_wired] ^ost$heap;

?? PUSH (LISTEXT := ON) ??
*copyc OST$HEAP
*copyc OSS$MAINFRAME_WIRED
?? POP ??
*DECK DECK=OSV$MISC_TEST_COMMANDS_CALL_PDT EXPAND=FALSE

{ PROCEDURE call_pdt (
{   pn: name = $required
{   number, n: integer 1..7FFFFFFF(16) = 1
{   param: string = ''
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (2),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 8, 20, 10, 19, 57, 344],
    clc$command, 5, 4, 1, 0, 0, 0, 4, ''], [
    ['N                              ',clc$abbreviation_entry, 2],
    ['NUMBER                         ',clc$nominal_entry, 2],
    ['PARAM                          ',clc$nominal_entry, 3],
    ['PN                             ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, 7FFFFFFF(16), 10],
    '1'],
{ PARAMETER 3
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE],
    ''''''],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$pn = 1,
      p$number = 2,
      p$param = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;
*DECK DECK=OSV$MISC_TEST_COMMANDS_INT1_PDT EXPAND=FALSE

{ PROCEDURE int1_pdt (
{   p1: integer 0..0FFFFFFFFFFFF(16) = 1
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 8, 20, 10, 20, 1, 700],
    clc$command, 2, 2, 0, 0, 0, 0, 2, ''], [
    ['P1                             ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 0FFFFFFFFFFFF(16), 10],
    '1'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$p1 = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;
*DECK DECK=OSV$MISC_TEST_COMMANDS_INT2_PDT EXPAND=FALSE

{ PROCEDURE int2_pdt (
{   p1: integer 0..0FFFFFFFFFFFF(16) = 1
{   p2: integer 0..0FFFFFFFFFFFF(16) = 1
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 8, 20, 10, 20, 5, 410],
    clc$command, 3, 3, 0, 0, 0, 0, 3, ''], [
    ['P1                             ',clc$nominal_entry, 1],
    ['P2                             ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 0FFFFFFFFFFFF(16), 10],
    '1'],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, 0FFFFFFFFFFFF(16), 10],
    '1'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$p1 = 1,
      p$p2 = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;
*DECK DECK=OSV$MISC_TEST_COMMANDS_INT4_PDT EXPAND=FALSE

{ PROCEDURE int4_pdt (
{   p1: integer 0..0FFFFFFFFFFFF(16) = 1
{   p2: integer 0..0FFFFFFFFFFFF(16) = 1
{   p3: integer 0..0FFFFFFFFFFFF(16) = 1
{   p4: integer 0..0FFFFFFFFFFFF(16) = 1
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 8, 20, 10, 20, 13, 609],
    clc$command, 5, 5, 0, 0, 0, 0, 5, ''], [
    ['P1                             ',clc$nominal_entry, 1],
    ['P2                             ',clc$nominal_entry, 2],
    ['P3                             ',clc$nominal_entry, 3],
    ['P4                             ',clc$nominal_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 0FFFFFFFFFFFF(16), 10],
    '1'],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, 0FFFFFFFFFFFF(16), 10],
    '1'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, 0FFFFFFFFFFFF(16), 10],
    '1'],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [0, 0FFFFFFFFFFFF(16), 10],
    '1'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$p1 = 1,
      p$p2 = 2,
      p$p3 = 3,
      p$p4 = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;
*DECK DECK=OSV$MISC_TEST_COMMANDS_INT6_PDT EXPAND=FALSE

{ PROCEDURE int6_pdt (
{   p1: integer 0..0FFFFFFFFFFFF(16) = 1
{   p2: integer 0..0FFFFFFFFFFFF(16) = 1
{   p3: integer 0..0FFFFFFFFFFFF(16) = 1
{   p4: integer 0..0FFFFFFFFFFFF(16) = 1
{   p5: integer 0..0FFFFFFFFFFFF(16) = 1
{   p6: integer 0..0FFFFFFFFFFFF(16) = 1
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 8, 21, 7, 11, 10, 771],
    clc$command, 7, 7, 0, 0, 0, 0, 7, ''], [
    ['P1                             ',clc$nominal_entry, 1],
    ['P2                             ',clc$nominal_entry, 2],
    ['P3                             ',clc$nominal_entry, 3],
    ['P4                             ',clc$nominal_entry, 4],
    ['P5                             ',clc$nominal_entry, 5],
    ['P6                             ',clc$nominal_entry, 6],
    ['STATUS                         ',clc$nominal_entry, 7]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 5
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 6
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 7
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [0, 0FFFFFFFFFFFF(16), 10],
    '1'],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [0, 0FFFFFFFFFFFF(16), 10],
    '1'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, 0FFFFFFFFFFFF(16), 10],
    '1'],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [0, 0FFFFFFFFFFFF(16), 10],
    '1'],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [0, 0FFFFFFFFFFFF(16), 10],
    '1'],
{ PARAMETER 6
    [[1, 0, clc$integer_type], [0, 0FFFFFFFFFFFF(16), 10],
    '1'],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$p1 = 1,
      p$p2 = 2,
      p$p3 = 3,
      p$p4 = 4,
      p$p5 = 5,
      p$p6 = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;
*DECK DECK=OSV$MONITOR_INTERLOCK_WAIT_TIME EXPAND=FALSE
{ The XDCL for the following variable is in deck mtm$monitor_interrupt_handler.

  VAR
    osv$monitor_interlock_wait_time: [XREF] record
      time: integer,
      count: integer
    recend;

*DECK DECK=OSV$MONITOR_STACK_LENGTH EXPAND=FALSE

  VAR
    osv$monitor_stack_length: [XREF] integer;
*DECK DECK=OSV$MULTIPLE_CPUS_POSSIBLE EXPAND=FALSE
*DECK DECK=OSV$MULTIPROCESSOR_RUNNING EXPAND=FALSE
{ This variable is a flag that indicates whether or not NOS/VE
{ is running in multiple processors.

  VAR
    osv$multiprocessor_running: [XREF] boolean;

*DECK DECK=OSV$NATURAL_LANGUAGE EXPAND=FALSE
*DECK DECK=OSV$OPERATOR_INTERVENTION EXPAND=FALSE

  VAR
    osv$operator_intervention: [XREF] boolean;
*DECK DECK=OSV$OS_DEFAULTS EXPAND=FALSE

  VAR
    osv$os_defaults: [XREF] ost$os_defaults,

    osv$os_defaults_os_name: [XREF] ost$os_defaults_os_name;

?? PUSH (LISTEXT := ON) ??
*copyc ost$os_defaults
?? POP ??
*DECK DECK=OSV$OS_DEFAULTS_LOCK EXPAND=FALSE
*DECK DECK=OSV$PAGE_SIZE EXPAND=FALSE
{System page size.}

  VAR
    osv$page_size: [XREF] ost$page_size;

?? PUSH (LISTEXT := ON) ??
*copyc OST$PAGE_SIZE
?? POP ??
*DECK DECK=OSV$PPU_KEYPOINT_CONTROL EXPAND=FALSE

  VAR
    osv$ppu_keypoint_control: [XREF] ost$ppu_keypoint_control;

*copyc ost$keypoint_control
*DECK DECK=OSV$PROCESSOR_MODEL_DEFINITIONS EXPAND=FALSE
*DECK DECK=OSV$RECONCILE_PERMANENT_FILES EXPAND=FALSE

   VAR
     osv$reconcile_permanent_files: [XREF] boolean;

*DECK DECK=OSV$RECOVER_AT_ALL_COSTS EXPAND=FALSE

  VAR
    osv$recover_at_all_costs: [XREF] boolean;
*DECK DECK=OSV$RECOVER_SYSTEM_SET_PHASE EXPAND=FALSE

  VAR
    osv$recover_system_set_phase: [XREF] ost$recover_system_set_phase;

?? PUSH (LISTEXT := ON) ??
*copyc ost$recover_system_set_phase
?? POP ??
*DECK DECK=OSV$REORGANIZE_PERMANENT_FILES EXPAND=FALSE

   VAR
     osv$reorganize_permanent_files: [XREF] boolean;

*DECK DECK=OSV$SEVERITIES EXPAND=FALSE

  VAR
    osv$severities: [XREF, READ, oss$job_paged_literal] array
      [ost$status_severity] of record
      size: 5 .. 12,
      value: string (12),
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS_SEVERITY
*copyc oss$job_paged_literal
?? POP ??
*DECK DECK=OSV$SIMULATED_DISK_FAULT EXPAND=FALSE
  VAR
    osv$simulated_disk_fault: [XREF] array [1 .. 5] of ost$simulated_disk_fault;
?? PUSH (LISTEXT := ON) ??
*copyc ost$simulated_disk_fault
?? POP ??
*DECK DECK=OSV$SPAA EXPAND=FALSE
{Define SYSTEM POINTER ADDRESS ARRAY.
{The SPAA contains real memory word addresses and PVAs of system tables referenced by the IOU.
{NOTE - array is terminated by an entry with an ADDRESS_TYPE equal to
{       osc$spid_list_termination, NOT by the 255th entry.

  VAR
    osv$spaa: [XREF] array [0 .. 255] of ost$spaa_entry;

?? PUSH (LISTEXT := ON) ??
*copyc OST$SPAA_ENTRY
?? POP ??
*DECK DECK=OSV$SPECIAL_AAM_TRAP EXPAND=FALSE

  VAR
    osv$special_aam_trap: [XREF] boolean;
*DECK DECK=OSV$SPI_CONTROL EXPAND=FALSE

  VAR
    osv$spi_control: [XREF] ost$spi_control;

?? PUSH (LISTEXT := ON) ??
*copyc ost$spi_control
?? POP ??

*DECK DECK=OSV$SPI_RESPONSE_PROCESSOR EXPAND=FALSE
  VAR
    osv$spi_response_processor: [XREF] iot$response_processor;

?? PUSH (LISTEXT := ON) ??
*copyc iot$io_request
?? POP ??
*DECK DECK=OSV$STATUS_MESSAGE_LEVEL EXPAND=FALSE
*DECK DECK=OSV$SYSTEM_DEFAULT_FAMILY EXPAND=FALSE

  VAR
    osv$system_default_family: [XREF, READ, oss$mainframe_pageable]
          ost$family_name;

?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_pageable
*copyc ost$user_identification
?? POP ??
*DECK DECK=OSV$SYSTEM_DEVICE_CYLINDER_SIZE EXPAND=FALSE

  VAR
    osv$system_device_cylinder_size: [XREF] integer;
*DECK DECK=OSV$SYSTEM_FAMILY_NAME EXPAND=FALSE

{ This variable contains the name of the system family.

  VAR
    osv$system_family_name: [XREF] ost$name;


*DECK DECK=OSV$SYSTEM_MESSAGE_MODULES EXPAND=FALSE

  VAR
    osv$system_message_modules: [XREF] array [1 .. osc$max_system_message_modules] of record
      module_name: ost$name,
      module_pointer_p: ^^ost$help_module,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc osc$max_system_message_modules
*copyc ost$help_module
*copyc ost$name
?? POP ??
*DECK DECK=OSV$SYSTEM_PRIVILEGE_MAP EXPAND=FALSE
{ *copyc osv$system_privilege_map
{ Bit map used to determine system privilege ( osp$verify_system_privilege )

  VAR
    osv$system_privilege_map : [XREF] ost$system_privilege_map;
*copyc ost$system_privilege_map

*DECK DECK=OSV$SYSTEM_TIME_ZONE EXPAND=FALSE
*DECK DECK=OSV$TASK_PRIVATE_HEAP EXPAND=FALSE

  VAR
    osv$task_private_heap: [XREF, READ, oss$job_pageable] ^ost$heap;

?? PUSH (LISTEXT := ON) ??
*copyc OST$HEAP
*copyc OSS$JOB_PAGEABLE
?? POP ??
*DECK DECK=OSV$TASK_SHARED_HEAP EXPAND=FALSE

  VAR
*IF NOT $true(osv$unix)
    osv$task_shared_heap: [XREF, READ, oss$job_pageable] ^ost$heap;
*ELSE
    osv$task_shared_heap: [XREF, READ] ^ost$heap;
*IFEND

?? PUSH (LISTEXT := ON) ??
*copyc OST$HEAP
*IF NOT $true(osv$unix)
*copyc OSS$JOB_PAGEABLE
*IFEND
?? POP ??
*DECK DECK=OSV$TIME_TO_CHECK_ASYN EXPAND=FALSE
  VAR
    osv$time_to_check_asyn: [XREF] integer;

*DECK DECK=OSV$TIME_TO_EMIT_STATISTICS EXPAND=FALSE
{ The XDCL for the following variable is in deck osm$emit_os_statistics.

  VAR
    osv$time_to_emit_statistics: [XREF] integer;
*DECK DECK=OSV$UPPER_TO_LOWER EXPAND=FALSE

  VAR
    osv$upper_to_lower: [XREF] string (256);

*DECK DECK=OSV$UPPER_TO_LOWER_26 EXPAND=FALSE

  VAR
    osv$upper_to_lower_26: [XREF, READ] string (256);

*DECK DECK=OSV$UPPER_TO_LOWER_INTERNATIONL EXPAND=FALSE

  VAR
    osv$upper_to_lower_internationl: [XREF, READ] string (256);

*DECK DECK=OSV$VALIDATE_ACTIVE_SETS EXPAND=FALSE

   VAR
     osv$validate_active_sets: [XREF] boolean;

*DECK DECK=OSV$VALIDATE_PERMANENT_FILES EXPAND=FALSE

   VAR
     osv$validate_permanent_files: [XREF] boolean;

*DECK DECK=PFC$CHACC_HELP_MODULE_NAME EXPAND=FALSE
  CONST
    pfc$chacc_help_module_name = 'PFM$CHACC_OUTPUT               ';

*DECK DECK=PFC$DEVICE_CLASS EXPAND=FALSE
                                                                                                              
  CONST                                                                                                       
    pfc$connected_file_device = 0,                                                                            
    pfc$interstate_link_device = 1,                                                                           
    pfc$local_queue_device = 2,                                                                               
    pfc$log_device = 3,                                                                                       
    pfc$magnetic_tape_device = 4,                                                                             
    pfc$mass_storage_device = 5,                                                                              
    pfc$memory_resident_device = 6,                                                                           
    pfc$network_device = 7,                                                                                   
    pfc$null_device = 8,                                                                                      
    pfc$pipeline_device = 9,                                                                                  
    pfc$rhfam_device = 10,                                                                                    
    pfc$terminal_device = 11;                                                                                 
*DECK DECK=PFC$MAX_LOCKED_CATALOGS EXPAND=FALSE
  CONST
    pfc$max_locked_catalogs = 3;
*DECK DECK=PFC$MAX_SHARED_QUEUE EXPAND=FALSE

  CONST
    pfc$max_shared_queue = 25;
*DECK DECK=PFC$MIN_ECC EXPAND=FALSE

  CONST
*IF $true(osv$unix)
    pfc$min_ecc = (($INTEGER ('P') * 100(16)) + $INTEGER ('F')) * 10000(16);
*ELSE
    pfc$min_ecc = (($INTEGER ('P') * 100(16)) + $INTEGER ('F')) * 1000000(16);
*IFEND

*DECK DECK=PFC$MOVC_INSUF_SPACE EXPAND=FALSE
 CONST
   pfc$movc_insuf_space = 'PFM$MOVC_INSUF_SPACE           ';
*DECK DECK=PFC$MOVC_NO_SPACE EXPAND=FALSE
 CONST
   pfc$movc_no_space = 'PFM$MOVC_NO_SPACE              ';
*DECK DECK=PFC$MOVE_CLASSES EXPAND=FALSE
*DECK DECK=PFC$NULL_SHARED_QUEUE EXPAND=FALSE

  CONST
    pfc$null_shared_queue = 0;
*DECK DECK=PFC$NULL_SITE_ARCHIVE_OPTION EXPAND=FALSE

  CONST
    pfc$null_site_archive_option = 0;
*DECK DECK=PFC$NULL_SITE_BACKUP_OPTION EXPAND=FALSE

  CONST
    pfc$null_site_backup_option = 0;
*DECK DECK=PFC$NULL_SITE_RELEASE_OPTION EXPAND=FALSE

  CONST
    pfc$null_site_release_option = 0;
*DECK DECK=PFC$SHARED_QUEUES EXPAND=FALSE

  CONST
    pfc$sq_site_01 = 1,
    pfc$sq_site_02 = 2,
    pfc$sq_site_03 = 3,
    pfc$sq_site_04 = 4,
    pfc$sq_site_05 = 5,
    pfc$sq_site_06 = 6,
    pfc$sq_site_07 = 7,
    pfc$sq_site_08 = 8,
    pfc$sq_site_09 = 9,
    pfc$sq_site_10 = 10,
    pfc$sq_site_11 = 11,
    pfc$sq_site_12 = 12,
    pfc$sq_site_13 = 13,
    pfc$sq_site_14 = 14,
    pfc$sq_site_15 = 15,
    pfc$sq_site_16 = 16,
    pfc$sq_site_17 = 17,
    pfc$sq_site_18 = 18,
    pfc$sq_site_19 = 19,
    pfc$sq_site_20 = 20,
    pfc$sq_site_21 = 21,
    pfc$sq_site_22 = 22,
    pfc$sq_site_23 = 23,
    pfc$sq_site_24 = 24,
    pfc$sq_site_25 = 25;

*DECK DECK=PFC$SYSTEM_SHARED_QUEUE_NAME EXPAND=FALSE

  CONST
    pfc$system_shared_queue_name = 'SYSTEM';
*DECK DECK=PFC$TEST_JR_CONSTANTS EXPAND=FALSE
{ If attempting to use these constants for a served file the command
{ set_job_recovery_test must be sent to the server via the
{ file server driver_test_utility test command send_remote_command_line

  CONST
    {File system range 200 .. 255
    { Permanent files 200 .. 229,  File Manager 230 .. 255

   { Do bacpf of file
    pfc$tjr_utility_attach = 200,

    { Will cause file known to device manager but not pf.
    pfc$tjr_define = 201,

    { Will cause file known to pf but not device manager.
    pfc$tjr_purge = 202,

    { In pfp$internal_return_file after dmp$detach_file but before closing
    { catalog and releasing attached pf table entry.
    pfc$tjr_return = 203,

    { If this is set the return file is allowed in the awaiting recovery state.
    { This will allow a file known on the server but not the client.
    pfc$tjr_allow_return_await_rec = 204,

    {This is a restartable request.
    pfc$tjr_permit = 205,

    { This is a non-restartable request but does not make the job unrecoverable.
    pfc$tjr_delete_permit = 206,

    { After dm_attach and before catalog flushed
    pfc$tjr_reattach_permanent_file  = 207,

    pfc$tjr_last = 229;
*DECK DECK=PFD$ARCHIVE_DEFINITIONS EXPAND=FALSE

  TYPE
    pft$archive_entry_version = (pfc$archive_entry_version_1,
      pfc$archive_entry_version_2, pfc$archive_entry_version_3,
      pfc$archive_entry_version_4, pfc$archive_entry_version_5,
      pfc$archive_entry_version_6, pfc$archive_entry_version_7,
      pfc$archive_entry_version_8),

    pft$archive_identification = record
      application_identifier: ost$name,
      media_identifier: pft$archive_media_identifier,
    recend,

    pft$archive_media_identifier = record
      media_device_class: ost$name,
      media_volume_identifier: string(osc$max_name_size),
    recend,

    pft$release_candidate = record
      case releasable: boolean OF
      = TRUE =
        mark_date_time: ost$date_time,
      = FALSE =
        ,
      casend,
    recend,

    pft$retrieval_status = record
      retrieval_date_time: ost$date_time,
      case normal: boolean of
      = TRUE =
        ,
      = FALSE =
        condition: ost$status_condition_code,
      casend,
    recend,

    pft$amd = SEQ(*),

    pft$p_amd = ^pft$amd;

*copyc ost$date_time
*copyc ost$name
*copyc ost$status_condition_code
*DECK DECK=PFD$ATTACHED_PERMANENT_FILE_ID EXPAND=FALSE

  TYPE
    {APFID}
    pft$attached_permanent_file_id = record
      case family_location: pft$family_location of
      = pfc$local_mainframe =
        attached_pf_table_index: pft$attached_pf_table_index,
      = pfc$server_mainframe =
        server_attached_pf_table_index: pft$attached_pf_table_index,
        served_family_table_index: dft$served_family_table_index,
        server_lifetime: dft$lifetime,
      casend,
    recend;

*copyc dft$lifetime
*copyc dft$served_family_table_index
*copyc pft$attached_pf_table_index
*copyc pft$family_location

*DECK DECK=PFD$ATTACHED_PF_TABLE EXPAND=FALSE

  { There is an attached pf table for each job.  There is an attached pf table
  { entry for each instance of the attach.  Thus, if a permanent file is
  { attached twice within the same job, it will have two seperate entries.  The
  { attached pf table entry deals with a particular cycle of a permanent file.
  { The index into the attached pf table is the APFID
  { (pft$attached_permanent_file_id).

  TYPE
    pft$p_attached_pf_table = ^pft$attached_pf_table,
    pft$attached_pf_table = array [1 .. * ] of pft$attached_pf_header,

    pft$attached_pf_header = record
      case entry_type: pft$attached_pf_entry_type of
      = pfc$attached_pf_entry_valid =
        p_attached_pf_entry: pft$p_attached_pf_entry,
      = pfc$attached_pf_entry_unused =
        ,
      casend,
    recend,

    pft$attached_pf_entry_type = (pfc$attached_pf_entry_unused,
      pfc$attached_pf_entry_valid),

    pft$p_attached_pf_entry = ^pft$attached_pf_entry,

    pft$attached_pf_entry = record
      sfid_status: pft$sfid_status,
      update_catalog: boolean,
      update_cycle_statistics: boolean,
      usage_selections: pft$usage_selections,
      share_selections: pft$share_selections,
      media_image_inconsistent: boolean,
      media_damage_detection_enabled: boolean,
      allowed_exception_conditions: fst$cycle_damage_symptoms,
      p_external_path: pft$p_complete_path,
      cycle_number: pft$cycle_number,
      device_class: rmt$device_class,
      internal_cycle_path: pft$internal_cycle_path,
    recend,

    pft$sfid_status = record
      case recovery_state: pft$attached_pf_recovery_state of
      = pfc$attached_pf_normal, pfc$attached_pf_awaiting_client =
        sfid: dmt$system_file_id,
        { In the pfc$attached_pf_awaiting_client state the file is attached
        { in the catalog, and in the attached_permanent_file_table, but
        { has not been updated in the file manager table.  The file is
        { awaiting the client job to re-obtain the information for the file.
      = pfc$attached_pf_in_job_recovery =
        { A new sfid is not assigned after a system failure.
        { The internal cycle path should not be referenced, because it contains
        { the old internal names (global file names) for the catalogs.  When
        { the catalog is changed to uncouple the internal name of an object
        { with the physical device manager global file name, reference to this
        { unique path will be used.
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc fst$cycle_damage_symptoms
*copyc ost$signature_lock
*copyc pfd$complete_path
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc pft$attached_pf_recovery_state
*copyc rmt$device_class
*copyc std$set_name
?? POP ??
*DECK DECK=PFD$AUTHORITY EXPAND=FALSE

{Authority Definitions}

  TYPE
    pft$authority = record
      ownership: pft$ownership,
      family: ost$family_name,
      user: ost$user_name,
      account: avt$account_name,
      project: avt$project_name,
    recend,

    pft$owner_types = (pfc$system_owner, pfc$set_owner, pfc$family_owner,
      pfc$master_catalog_owner),

    pft$ownership = set of pft$owner_types;

?? PUSH (LISTEXT := ON) ??
*copyc ost$user_identification
*copyc avt$account_name
*copyc avt$project_name
?? POP ??
*DECK DECK=PFD$CATALOG EXPAND=FALSE

  { Catalog File Definitions }

  CONST
    pfc$average_share_history = 7fff(16) {dmc$maximum_share_history / 2} ,
    pfc$catalog_allocation_size = 4000(16), {16K}
    pfc$catalog_ring = 2,
    pfc$catalog_version = 'CATALOG_VERSION_003',
    pfc$maximum_catalog_length = 80000000(16) {2**31 JF default} ,
    pfc$maximum_pf_length = 80000000(16),
    pfc$number_of_catalog_attr = 4;

  TYPE
    pft$catalog_file = record
      physical_catalog_header: pft$physical_catalog_header,
      catalog_heap: ALIGNED [0 MOD 32] pft$catalog_heap,
    recend,

    pft$p_catalog_file = ^pft$catalog_file,

    pft$physical_catalog_header = record
      checksum: pft$checksum,
      catalog_header: pft$catalog_header,
    recend,

    pft$p_physical_catalog_header = ^pft$physical_catalog_header,

    pft$catalog_header = record
      valid: boolean,
      version: pft$name,
      object_list_locator: pft$object_list_locator,
      reserved_catalog_header_space: array [1 .. 48] of boolean,
    recend,

    pft$catalog_heap = ost$heap,
    pft$p_catalog_heap = ^pft$catalog_heap;

?? SKIP := 2 ??

  { Object List Definitions }

  CONST
    pfc$maximum_object_count = 0ffffffff(16),
    pfc$object_sort_threshold = 24;

  TYPE
    pft$object_list = array [1 .. * ] of pft$physical_object,
    pft$object_index = 1 .. pfc$maximum_object_count,
    pft$object_count = 0 .. pfc$maximum_object_count,
    pft$p_object_list = ^pft$object_list,
    pft$p_object = ^pft$physical_object,

    pft$physical_object = record
      checksum: pft$checksum,
      object_entry: pft$object_entry,
    recend,

    pft$object_list_locator = record
      object_count: pft$object_count,
      relative_cell_pointer: pft$relative_cell_pointer,
      sorted_object_count: pft$object_count,
      free_sorted_object_count: pft$object_count,
    recend,

    pft$object_entry = record
      external_object_name: pft$name,
      internal_object_name: pft$internal_name,
      permit_list_locator: pft$permit_list_locator,
      charge_id: pft$charge_id,
      reserved_object_entry_space: array [1 .. 6] of integer,
      case object_type: pft$object_types of
      = pfc$free_object =
        ,
      = pfc$file_object, pfc$purged_file_object =
        password: pft$password,
        logging_selection: pft$log,
        log_list_locator: pft$log_list_locator,
        cycle_list_locator: pft$cycle_list_locator,
        reserved_file_entry_space: array [1 .. 48] of boolean,
      = pfc$catalog_object, pfc$purged_catalog_object =
        catalog_object_locator: pft$catalog_object_locator,
        catalog_recreated_by_restore: boolean,
        reserved_catalog_entry_space: array [1 .. 47] of boolean,
      casend,
    recend,

    pft$object_types = (pfc$free_object, pfc$file_object,
          pfc$purged_file_object, pfc$catalog_object,
          pfc$purged_catalog_object),

    pft$object_selections = set of pft$object_types;

?? SKIP := 2 ??

  { Catalog Object Locator Definitions }

  TYPE
    pft$catalog_object_locator = record
      case catalog_type: pft$catalog_types of
      = pfc$internal_catalog =
        object_list_locator: pft$object_list_locator,
      = pfc$external_catalog =
        fmd_locator: pft$fmd_locator,
        global_file_name: dmt$global_file_name,
      casend,
    recend;

?? SKIP := 2 ??

  { Permit List Definitions }

  CONST
    pfc$maximum_permit_count = 0ffff(16),
    pfc$permit_expansion_count = 2,
    pfc$permit_contraction_count = 2 * pfc$permit_expansion_count;

  TYPE
    pft$permit_list = array [1 .. * ] of pft$physical_permit,
    pft$permit_index = 1 .. pfc$maximum_permit_count,
    pft$permit_count = 0 .. pfc$maximum_permit_count,
    pft$p_permit_list = ^pft$permit_list,
    pft$p_permit = ^pft$physical_permit,

    pft$physical_permit = record
      checksum: pft$checksum,
      permit_entry: pft$permit_entry,
    recend,

    pft$permit_list_locator = record
      permit_count: pft$permit_count,
      relative_cell_pointer: pft$relative_cell_pointer,
    recend,

    pft$permit_entry = record
      case entry_type: pft$permit_entry_types of
      = pfc$free_permit_entry =
        ,
      = pfc$normal_permit_entry =
        group: pft$group,
        usage_permissions: pft$permit_selections,
        share_requirements: pft$share_requirements,
        application_info: pft$application_info,
      casend,
    recend,

    pft$permit_entry_types = (pfc$free_permit_entry, pfc$normal_permit_entry);

?? SKIP := 2 ??

  { Log List Definitions }

  CONST
    pfc$log_expansion_count = 5,
    pfc$log_contraction_count = 2 * pfc$log_expansion_count,
    pfc$maximum_log_count = 0ffffff(16);

  TYPE
    pft$log_list = array [1 .. * ] of pft$physical_log,
    pft$log_index = 1 .. pfc$maximum_log_count,
    pft$log_count = 0 .. pfc$maximum_log_count,
    pft$p_log_list = ^pft$log_list,
    pft$p_log = ^pft$physical_log,

    pft$physical_log = record
      checksum: pft$checksum,
      log_entry: pft$log_entry,
    recend,

    pft$log_list_locator = record
      log_count: pft$log_count,
      relative_cell_pointer: pft$relative_cell_pointer,
    recend,

    pft$log_entry = record
      case entry_type: pft$log_entry_types of
      = pfc$free_log_entry =
        ,
      = pfc$normal_log_entry =
        user_id: ost$user_identification,
        access_date_time: ost$date_time,
        access_count: pft$access_count,
        last_cycle: pft$cycle_number,
      casend,
    recend,

    pft$log_entry_types = (pfc$free_log_entry, pfc$normal_log_entry);

?? SKIP := 2 ??

  { Cycle List Definitions }

  CONST
    pfc$cycle_expansion_count = 5,
    pfc$cycle_contraction_count = 2 * pfc$cycle_expansion_count;

  TYPE
    pft$cycle_list = array [1 .. * ] of pft$physical_cycle,
    pft$cycle_index = 1 .. pfc$maximum_cycle_count,
    pft$p_cycle_list = ^pft$cycle_list,
    pft$p_cycle = ^pft$physical_cycle,

    pft$physical_cycle = record
      checksum: pft$checksum,
      cycle_entry: pft$cycle_entry,
    recend,

    pft$cycle_list_locator = record
      cycle_count: pft$cycle_count,
      relative_cell_pointer: pft$relative_cell_pointer,
    recend,

    pft$cycle_entry = record
      internal_cycle_name: pft$internal_name,
      case entry_type: pft$cycle_entry_types of
      = pfc$free_cycle_entry =
        ,
      = pfc$normal_cycle_entry, pfc$purged_cycle_entry =
        cycle_number: pft$cycle_number,
        cycle_statistics: pft$cycle_statistics,
        expiration_date_time: ost$date_time,
        attach_status: pft$attach_status,
        cycle_damage_symptoms: fst$cycle_damage_symptoms,
        fmd_locator: pft$fmd_locator,
        global_file_name: dmt$global_file_name,
        file_label_locator: pft$file_label_locator,
        archive_list_locator: pft$archive_list_locator,
        data_residence: pft$data_residence,
        first_mainframe_usage_entry: pft$mainframe_usage_entry,
        mainframe_usage_list_locator: pft$mainframe_list_locator,
        data_modification_date_time: ost$date_time,
        device_information: pft$cycle_device_information,
        shared_queue_info: pft$shared_queue_info,
        retrieve_option: pft$retrieve_option,
        site_backup_option: pft$site_backup_option,
        site_archive_option: pft$site_archive_option,
        site_release_option: pft$site_release_option,
        reserved_cycle_entry_space: array [1 .. 34] of boolean,
      casend,
    recend,

    pft$cycle_entry_types = (pfc$free_cycle_entry, pfc$normal_cycle_entry,
          pfc$purged_cycle_entry),

    pft$attach_status = record
      attach_count: pft$usage_count,
      usage_counts: array [pft$usage_options] of pft$usage_count,
      prevent_usage_counts: array [pft$share_options] of pft$usage_count,
    recend,

    pft$cycle_device_information = packed record
      case device_class_defined: boolean of
      = FALSE =
        ,
      = TRUE =
        case device_class: pft$device_class of
        = pfc$connected_file_device =
          ,
        = pfc$interstate_link_device =
          ,
        = pfc$local_queue_device =
          ,
        = pfc$log_device =
          ,
        = pfc$magnetic_tape_device =
          ,
        = pfc$mass_storage_device =
          eoi: ALIGNED amt$file_byte_address,
          bytes_allocated: ALIGNED amt$file_byte_address,

        = pfc$memory_resident_device =
          ,
        = pfc$network_device =
          ,
        = pfc$null_device =
          ,
        = pfc$pipeline_device =
          ,
        = pfc$rhfam_device =
          ,
        = pfc$terminal_device =
          ,
        casend,
      casend,
    recend,

    pft$usage_count = 0 .. 0ffff(16);

?? SKIP := 2 ??

  { Archive List Definitions }

  CONST
    pfc$maximum_archive_count = 0ff(16);

  TYPE
    pft$archive_list = array [1 .. * ] of pft$physical_archive,
    pft$archive_count = 0 .. pfc$maximum_archive_count,
    pft$archive_index = 1 .. pfc$maximum_archive_count,
    pft$p_archive_list = ^pft$archive_list,
    pft$p_archive = ^pft$physical_archive,

    pft$physical_archive = record
      checksum: pft$checksum,
      archive_entry: pft$archive_entry,
    recend,

    pft$archive_list_locator = record
      archive_count: pft$archive_count,
      relative_cell_pointer: pft$relative_cell_pointer,
    recend,

    pft$archive_entry = record
      version: pft$archive_entry_version,
      archive_date_time: ost$date_time,
      archive_identification: pft$archive_identification,
      file_size: amt$file_length,
      last_release_date_time: ost$date_time,
      last_retrieval_status: pft$retrieval_status,
      modification_date_time: ost$date_time,
      release_candidate: pft$release_candidate,
      amd_locator: pft$amd_locator,
      reserved_archive_entry_space: array [1 .. 48] of boolean,
    recend;

?? SKIP := 2 ??

  { Archive Media Descriptor Definitions }

    CONST
      pfc$max_amd_size = 0ffff(16);

    TYPE
      pft$amd_size = 0 .. pfc$max_amd_size,

      pft$p_physical_amd = ^pft$physical_amd,

      pft$physical_amd = record
        checksum: pft$checksum,
        amd: pft$amd,
      recend,

      pft$amd_locator = record
        amd_size: pft$amd_size,
        relative_cell_pointer: pft$relative_cell_pointer,
      recend;

?? SKIP := 2 ??

  { File Media Descriptor (FMD) Definitions }

  CONST
    pfc$maximum_fmd_size = 0ffff(16);

  TYPE
    pft$fmd_size = 0 .. pfc$maximum_fmd_size,

    pft$fmd = dmt$stored_fmd,
    pft$p_fmd = ^pft$fmd,
    pft$p_physical_fmd = ^pft$physical_fmd,

    pft$physical_fmd = record
      checksum: pft$checksum,
      fmd: pft$fmd,
    recend,

    pft$fmd_locator = record
      fmd_size: pft$fmd_size,
      relative_cell_pointer: pft$relative_cell_pointer,
    recend;

?? SKIP := 2 ??

  { File Label Definitions }

  CONST
    pfc$maximum_file_label_size = 0ffffff(16);

  TYPE
    pft$file_label_size = 0 .. pfc$maximum_file_label_size,

    pft$p_stored_file_label = ^pft$physical_file_label,

    pft$physical_file_label = record
      checksum: pft$checksum,
      file_label: fmt$file_label,
    recend,

    pft$file_label_locator = record
      file_label_size: pft$file_label_size,
      relative_cell_pointer: pft$relative_cell_pointer,
    recend;

?? SKIP := 2 ??

  { Mainframe Usage List Entries }

  TYPE
    pft$physical_mainframe_usage = record
      checksum: pft$checksum,
      mainframe_usage: pft$mainframe_usage_entry,
    recend,

    pft$mainframe_usage_entry = record
      case entry_type: pft$mainframe_entry_type of
      = pfc$free_mainframe_entry =
        ,
      = pfc$normal_mainframe_entry =
        mainframe_id: pmt$binary_mainframe_id,
        attach_count: pft$usage_count,
        write_count: pft$usage_count,
      casend,
    recend,

    pft$mainframe_entry_type = (pfc$free_mainframe_entry,
          pfc$normal_mainframe_entry),

    pft$mainframe_list_locator = record
      mainframe_count: pft$mainframe_count,
      relative_cell_pointer: pft$relative_cell_pointer,
    recend,

    pft$mainframe_count = 0 .. 0ffff(16),
    pft$mainframe_usage_index = 1 .. 0ffff(16),

    pft$mainframe_usage_list = array [1 .. * ] of pft$physical_mainframe_usage;

?? SKIP := 2 ??

  { Relative Pointer Definitions }

  TYPE
    pft$relative_cell_pointer = REL (pft$catalog_file) ^cell,

    pft$sequence = SEQ (REP 7fffffff(16) of cell),

    pft$p_sequence = ^pft$sequence,

    pft$sequence_record = record
      sequence: pft$sequence,
    recend,

    pft$p_sequence_record = ^pft$sequence_record;

*copyc amt$file_byte_address
*copyc amt$file_length
*copyc dmt$global_file_name
*copyc dmt$stored_fmd
*copyc fmt$file_label
*copyc fst$cycle_damage_symptoms
*copyc ost$date_time
*copyc ost$heap
*copyc ost$user_identification
*copyc pfd$archive_definitions
*copyc pfd$charge_id
*copyc pfd$cycle_statistics
*copyc pfd$internal_name
*copyc pfd$permanent_file_definitions
*copyc pft$catalog_types
*copyc pft$checksum
*copyc pft$cycle_count
*copyc pft$data_residence
*copyc pft$device_class
*copyc pft$shared_queue_info
*copyc pft$site_archive_option
*copyc pft$site_backup_option
*copyc pft$site_release_option
*copyc pft$retrieve_option
*copyc pmt$binary_mainframe_id
*DECK DECK=PFD$CATALOG_ACCESS EXPAND=FALSE

{ Internal Catalog Access Definitions

  TYPE
    pft$collected_info_entry_types = (pfc$free, pfc$used),
    pft$directory_array_index = ost$non_negative_integers,
    pft$cycle_array_index = 0 .. pfc$maximum_cycle_number,

    pft$collected_info_entry = record
      case entry_type: pft$collected_info_entry_types of
      = pfc$free =
        ,
      = pfc$used =
        file_selections: pft$file_selections,
        file_id: amt$file_identifier,
        p_directory_array: pft$p_directory_array,
        directory_array_index: pft$directory_array_index,
        info_type: pft$file_information,
        selection_position: pft$selection_position,
        case cycle_numbers_selected: boolean of
        = FALSE =
          ,
        = TRUE =
          p_body: pft$p_info,
          p_cycle_array: pft$p_cycle_array,
          cycle_array_index: pft$cycle_array_index,
        casend,
      casend,
    recend,

    pft$collected_info_array = array [1 .. pfc$max_selection_id_ordinal] of
      pft$collected_info_entry,
    pft$p_collected_info_array = ^pft$collected_info_array;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc osd$integer_limits
*copyc pfd$catalog_info
*copyc pfd$information_selections
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFD$CATALOG_ALARM_TABLE EXPAND=FALSE

  CONST
    pfc$highest_alarm_table_index = 0ffff(16);

  TYPE
    pft$p_catalog_alarm_table = ^pft$catalog_alarm_table,

    pft$catalog_alarm_table = array [1 .. * ] of pft$catalog_alarm_entry,

    pft$catalog_alarm_table_index = 1 .. pfc$highest_alarm_table_index,

    pft$catalog_alarm_entry = record
      case entry_type: pft$catalog_alarm_entry_type of
      = pfc$catalog_alarm_entry_free =
        ,
      = pfc$catalog_alarm_entry_valid =
        internal_catalog_name: pft$internal_catalog_name,
        global_file_name: ost$binary_unique_name,
        destroy_on_last_detach: boolean,

        { The following fields provide statistics on catalog alarm frequency
        displayable_time: ost$hms_time,
        time_of_alarm_setting: ost$date_time,
        external_catalog_name: pft$name,
        alarm_count: ost$positive_integers,
        search_count: ost$non_negative_integers,
      casend,
    recend,

    pft$catalog_alarm_entry_type = (pfc$catalog_alarm_entry_free,
      pfc$catalog_alarm_entry_valid);

?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
*copyc ost$binary_unique_name
*copyc ost$date_time
*copyc ost$time
*copyc pfd$internal_name
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFD$CATALOG_INFO EXPAND=FALSE
{ *** PFD$CATALOG_INFO  Permanent File Get_info, Put_info definitions


{INFO SELECTION Definitions

  TYPE
    pft$catalog_info_options = (pfc$catalog_directory, pfc$catalog_description,
          pfc$catalog_permits, pfc$indirect_catalog_permits,
          pfc$catalog_media_descriptor, pfc$reserved_catalog_info_opt1,
          pfc$reserved_catalog_info_opt2, pfc$reserved_catalog_info_opt3,
          pfc$reserved_catalog_info_opt4, pfc$reserved_catalog_info_opt5,
          pfc$reserved_catalog_info_opt6, pfc$reserved_catalog_info_opt7,
          pfc$reserved_catalog_info_opt8, pfc$reserved_catalog_info_opt9,
          pfc$reserved_catalog_info_opt10, pfc$reserved_catalog_info_opt11),

    pft$catalog_info_selections = set of pft$catalog_info_options,

    pft$file_info_options = (pfc$file_directory, pfc$file_description,
          pfc$file_permits, pfc$indirect_file_permits, pfc$file_cycles,
          pfc$file_log, pfc$cycle_media_descriptor, pfc$cycle_label_descriptor,
          pfc$archive_descriptors, pfc$reserved_file_info_option1,
          { Renamed pfc$file_cycles_version_2 }

{ Currently unsupported

    pfc$reserved_file_info_option2, pfc$reserved_file_info_option3,
          pfc$reserved_file_info_option4, pfc$reserved_file_info_option5,
          pfc$reserved_file_info_option6, pfc$reserved_file_info_option7,
          pfc$reserved_file_info_option8, pfc$reserved_file_info_option9,
          pfc$reserved_file_info_option10, pfc$reserved_file_info_option11,
          pfc$reserved_file_info_option12, pfc$reserved_file_info_option13,
          pfc$reserved_file_info_option14, pfc$reserved_file_info_option15,
          pfc$reserved_file_info_option16, pfc$reserved_file_info_option17,
          pfc$reserved_file_info_option18, pfc$reserved_file_info_option19,
          pfc$reserved_file_info_option20, pfc$reserved_file_info_option21,
          pfc$reserved_file_info_option22);

  CONST
    pfc$file_cycles_version_2 = pfc$reserved_file_info_option1;

  TYPE
    pft$file_info_selections = set of pft$file_info_options;


?? SKIP := 4 ??

{INFO RECORD Definitions

  TYPE
    pft$info = SEQ ( * ),

    pft$p_info = ^pft$info,

    pft$info_record_type = (pfc$family_info_record,
          pfc$master_catalog_info_record, pfc$item_info_record,
          pfc$multi_item_info_record, pfc$directory_array_record,
          pfc$catalog_group_record, pfc$catalog_description_record,
          pfc$file_group_record, pfc$file_description_record,
          pfc$cycle_array_record, pfc$log_array_record,
          pfc$permit_array_record, pfc$catalog_media_record,
          pfc$cycle_array_extended_record, pfc$cycle_directory_record,
          pfc$cycle_info_record, pfc$cycle_media_record,
          pfc$cycle_label_record, pfc$archive_entry, { Obsolete }
          pfc$archive_media, { Obsolete }
          pfc$archive_processor, { Obsolete }
          pfc$archive_list, { Obsolete }
          pfc$archive_group, { Obsolete }
          pfc$archive_label, { Obsolete }
          pfc$reserved_info_archive_1, { Renamed pfc$archive_info_record }
          pfc$reserved_info_archive_2, { Renamed pfc$archive_entry_record }
          pfc$reserved_info_archive_3, { Renamed
          {pfc$archive_array_entry_record }
          pfc$reserved_info_archive_4, { Renamed pfc$archive_amd_record }

{ Reserved for archiving

    pfc$reserved_info_archive_5, pfc$reserved_info_archive_6,
          pfc$reserved_info_archive_7, pfc$reserved_info_archive_8,
          pfc$reserved_info_archive_9, pfc$reserved_info_archive_10,
          pfc$reserved_info_archive_11, pfc$reserved_info_record1,
          { Renamed pfc$cycle_array_version_2_rec }

{ Reserved for future use

    pfc$reserved_info_record2, pfc$reserved_info_record3,
          pfc$reserved_info_record4, pfc$reserved_info_record5,
          pfc$reserved_info_record6, pfc$reserved_info_record7,
          pfc$reserved_info_record8, pfc$reserved_info_record9,
          pfc$reserved_info_record10, pfc$reserved_info_record11,
          pfc$reserved_info_record12, pfc$reserved_info_record13,
          pfc$reserved_info_record14, pfc$reserved_info_record15,
          pfc$reserved_info_record16, pfc$reserved_info_record17,
          pfc$reserved_info_record18, pfc$reserved_info_record19,
          pfc$reserved_info_record20, pfc$reserved_info_record21,
          pfc$reserved_info_record22, pfc$reserved_info_record23,
          pfc$reserved_info_record24, pfc$reserved_info_record25,
          pfc$reserved_info_record26, pfc$reserved_info_record28,
          pfc$reserved_info_record29, pfc$reserved_info_record30,
          pfc$reserved_info_record31, pfc$reserved_info_record32,
          pfc$reserved_info_record33, pfc$reserved_info_record34,
          pfc$reserved_info_record35, pfc$reserved_info_record36,
          pfc$reserved_info_record38, pfc$reserved_info_record39,
          pfc$reserved_info_record40, pfc$reserved_info_record41,
          pfc$reserved_info_record42, pfc$reserved_info_record43,
          pfc$reserved_info_record44, pfc$reserved_info_record45,
          pfc$reserved_info_record46, pfc$reserved_info_record48,
          pfc$reserved_info_record49, pfc$reserved_info_record50,
          pfc$reserved_info_record51, pfc$reserved_info_record52,
          pfc$reserved_info_record53, pfc$reserved_info_record54,
          pfc$reserved_info_record55, pfc$reserved_info_record56,
          pfc$reserved_info_record58, pfc$reserved_info_record59,
          pfc$reserved_info_record60, pfc$reserved_info_record61,
          pfc$reserved_info_record62, pfc$reserved_info_record63,
          pfc$reserved_info_record64, pfc$reserved_info_record65,
          pfc$reserved_info_record66, pfc$reserved_info_record68,
          pfc$reserved_info_record69, pfc$reserved_info_record70,
          pfc$reserved_info_record71, pfc$reserved_info_record72,
          pfc$reserved_info_record73, pfc$reserved_info_record74,
          pfc$reserved_info_record75, pfc$reserved_info_record76,
          pfc$reserved_info_record78, pfc$reserved_info_record79,
          pfc$reserved_info_record80, pfc$reserved_info_record81,
          pfc$reserved_info_record82, pfc$reserved_info_record83,
          pfc$reserved_info_record84, pfc$reserved_info_record85,
          pfc$reserved_info_record86, pfc$reserved_info_record88,
          pfc$reserved_info_record89, pfc$reserved_info_record90,
          pfc$reserved_info_record91, pfc$reserved_info_record92,
          pfc$reserved_info_record93, pfc$reserved_info_record94,
          pfc$reserved_info_record95, pfc$reserved_info_record96,
          pfc$reserved_info_record98, pfc$reserved_info_record99);

{ In order to support binary compatability of users of this type,
{ Aliases may be added. For example
{   CONST
{     pfc$shoe_size_info_record = pfc$reserved_info_record98;
{ All users would reference pfc$shoe_size_info_record not
{ pfc$reserved_info_record98.

  CONST
    pfc$archive_amd_record = pfc$reserved_info_archive_4,
    pfc$archive_array_entry_record = pfc$reserved_info_archive_3,
    pfc$archive_entry_record = pfc$reserved_info_archive_2,
    pfc$archive_info_record = pfc$reserved_info_archive_1,
    pfc$cycle_array_version_2_rec = pfc$reserved_info_record1;

  TYPE
    pft$info_record = record
      record_type: pft$info_record_type,
      body_size: pft$info_record_body_size,
      body: pft$info,
    recend,

    pft$p_info_record = ^pft$info_record,

    pft$info_record_body_size = 0 .. 7fffffff(16),

    pft$info_offset = pft$info_record_body_size;


?? SKIP := 4 ??

{DIRECTORY RECORD Definitions

  TYPE
    pft$name_type = (pfc$catalog_name, pfc$file_name),

    pft$directory_array_entry = record
      name: pft$name,
      name_type: pft$name_type,
      info_offset: pft$info_offset,
    recend,

    pft$directory_array = array [1 .. * ] of pft$directory_array_entry,

    pft$p_directory_array_entry = ^pft$directory_array_entry,

    pft$p_directory_array = ^pft$directory_array;

?? SKIP := 4 ??

{CATALOG DESCRIPTION Definitions

  TYPE
    pft$catalog_description = record
      name: pft$name,
      charge_id: pft$charge_id,
    recend,

    pft$p_catalog_description = ^pft$catalog_description;

?? SKIP := 4 ??

{FILE DESCRIPTION Definitions

  TYPE
    pft$file_description = record
      name: pft$name,
      password: pft$password,
      charge_id: pft$charge_id,
      logging_selection: pft$log,
    recend,

    pft$p_file_description = ^pft$file_description;

?? SKIP := 4 ??

{CYCLE ARRAY Definitions

  TYPE
    pft$cycle_array_entry = record
      cycle_number: pft$cycle_number,
      cycle_statistics: pft$cycle_statistics,
      expiration_date_time: ost$date_time,
    recend,

    pft$cycle_array = array [1 .. * ] of pft$cycle_array_entry,

    pft$p_cycle_array_entry = ^pft$cycle_array_entry,

    pft$p_cycle_array = ^pft$cycle_array;

  TYPE
    pft$cycle_array_entry_version_2 = record
      bytes_allocated: amt$file_byte_address,
      cycle_damage_symptoms: fst$cycle_damage_symptoms,
      cycle_number: pft$cycle_number,
      cycle_statistics: pft$cycle_statistics,
      data_modification_date_time: ost$date_time,
      data_residence: pft$data_residence,
      device_class: rmt$device_class,
      eoi: amt$file_byte_address,
      expiration_date_time: ost$date_time,
      original_unique_name: ost$binary_unique_name,
      sparse_allocation: boolean,
      cycle_reservation: pft$cycle_reservation,
      shared_queue_info: pft$shared_queue_info,
      retrieve_option: pft$retrieve_option,
      site_backup_option: pft$site_backup_option,
      site_archive_option: pft$site_archive_option,
      site_release_option: pft$site_release_option,
      reserved_cycle_array_entry_sp: array [1 .. 46] of boolean,
    recend,

    pft$cycle_array_version_2 = array [1 .. * ] of
          pft$cycle_array_entry_version_2,

    pft$cycle_reservation = record
      case cycle_reserved: boolean of
      = FALSE =
        ,
      = TRUE =
          reserved_cycle_index: ost$non_negative_integers,
      casend,
    recend;

?? SKIP := 4 ??

  TYPE
    pft$cycle_directory_array_entry = record
      internal_name: ost$binary_unique_name,
      cycle_number: pft$cycle_number,
      info_offset: pft$info_offset,
    recend,

    pft$cycle_directory_array = array [1 .. * ] of
          pft$cycle_directory_array_entry,

    pft$p_cycle_directory_entry = ^pft$cycle_directory_array_entry,

    pft$p_cycle_directory_array = ^pft$cycle_directory_array;

?? SKIP := 4 ??

  TYPE
    pft$backup_file_version = (pfc$backup_file_version_1,
          pfc$backup_file_version_2, pfc$backup_file_version_3,
          pfc$backup_file_version_4, pfc$backup_file_version_5,
          pfc$backup_file_version_6, pfc$backup_file_version_7);

?? SKIP := 4 ??

{LOG ARRAY Definitions

  TYPE
    pft$log_array_entry = record
      user_id: ost$user_identification,
      access_date_time: ost$date_time,
      access_count: pft$access_count,
      last_cycle: pft$cycle_number,
    recend,

    pft$log_array = array [1 .. * ] of pft$log_array_entry,

    pft$p_log_array_entry = ^pft$log_array_entry,

    pft$p_log_array = ^pft$log_array;

?? SKIP := 4 ??

{PERMIT ARRAY Definitions

  TYPE
    pft$permit_type = (pfc$direct_permit, pfc$indirect_permit),

    pft$permit_array_entry = record
      permit_type: pft$permit_type,
      group: pft$group,
      usage_permissions: pft$permit_selections,
      share_requirements: pft$share_requirements,
      application_info: pft$application_info,
    recend,

    pft$permit_array = array [1 .. * ] of pft$permit_array_entry,

    pft$p_permit_array_entry = ^pft$permit_array_entry,

    pft$p_permit_array = ^pft$permit_array;

?? SKIP := 4 ??

{ARCHIVE ARRAY Definitions

  TYPE
    pft$archive_array_entry = record
      version: pft$archive_entry_version,
      archive_date_time: ost$date_time,
      archive_identification: pft$archive_identification,
      file_size: amt$file_length,
      last_release_date_time: ost$date_time,
      last_retrieval_status: pft$retrieval_status,
      modification_date_time: ost$date_time,
      release_candidate: pft$release_candidate,
      reserved_archive_array_entry_sp: array [1 .. 48] of boolean,
    recend,

    pft$archive_array = array [1 .. * ] of pft$archive_array_entry,

    pft$p_archive_array_entry = ^pft$archive_array_entry,

    pft$p_archive_array = ^pft$archive_array;

*copyc amt$file_length
*copyc osd$integer_limits
*copyc ost$binary_unique_name
*copyc ost$date_time
*copyc ost$user_identification
*copyc pfd$archive_definitions
*copyc pfd$charge_id
*copyc pfd$cycle_statistics
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc pft$data_residence
*copyc pft$shared_queue_info
*copyc pft$site_backup_option
*copyc pft$site_archive_option
*copyc pft$site_release_option
*copyc pft$retrieve_option
*copyc rmt$device_class
*DECK DECK=PFD$CATALOG_LOCATOR EXPAND=FALSE

  TYPE
    pft$catalog_locator = record
      set_name: stt$set_name,
      internal_catalog_name: pft$internal_catalog_name,
      global_file_name: ost$binary_unique_name,
      recorded_vsn: rmt$recorded_vsn,
      new_catalog: boolean,
      queuing_info: pft$catalog_queueing_info,
      case attached: boolean of
      = FALSE =
        ,
      = TRUE =
        system_file_id: dmt$system_file_id,
        case open: boolean of
        = FALSE =
          ,
        = TRUE =
          CASE locked: boolean of
          = FALSE =
            ,
          = TRUE =
            abort_catalog_operation: boolean,
            access_kind: pft$access_kind,
            flush_catalog_pages: boolean,
            object_list_descriptor: pft$object_list_descriptor,
            p_catalog_file: ^pft$catalog_file,
          casend,
        casend,
      casend,
    recend,

    pft$catalog_queueing_info = record
      set_catalog_alarm: boolean,
      case attach_queued: boolean of
      = FALSE =
        ,
      = TRUE =
        parent_catalog_internal_name: pft$internal_catalog_name,
        external_catalog_name: pft$name,
        charge_id: pft$charge_id,
        case access_queued: boolean of
        = FALSE =
          ,
        = TRUE =
          { The following points to the list of all queued internal catalogs.
          p_internal_catalog_list: ^pft$queued_internal_catalog,
          { The following is the direct permit for the job.
          permit: pft$permit_entry,
        casend,
      casend,
    recend,

    pft$access_kind = (pfc$read_access, pfc$write_access),

    pft$object_list_descriptor = record
      p_object_list: ^pft$object_list,
      sorted_object_count: pft$object_count,
      free_sorted_object_count: pft$object_count,
      case catalog_type: pft$catalog_types of
      = pfc$internal_catalog =
        { The following points to the parent's catalog object.
        p_parent_catalog: ^pft$physical_object,
      = pfc$external_catalog =
        { This is equivalent to ^p_catalog_file^.physical_catalog_header.
        p_physical_catalog_header: ^pft$physical_catalog_header,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc pfd$catalog
*copyc pfd$charge_id
*copyc pfd$permanent_file_definitions
*copyc pfd$queued_internal_catalog
*copyc rmt$recorded_vsn
*copyc std$set_name
?? POP ??
*DECK DECK=PFD$CHARGE_ID EXPAND=FALSE

 TYPE
    pft$charge_id = record
      account: avt$account_name,
      project: avt$project_name,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc avt$account_name
*copyc avt$project_name
?? POP ??
*DECK DECK=PFD$COMPLETE_PATH EXPAND=FALSE

{Path Definitions}

  CONST
    pfc$set_path_index = 1,
    pfc$family_path_index = pfc$set_path_index + 1,
    pfc$master_catalog_path_index = pfc$family_path_index + 1,
    pfc$subcatalog_path_index = pfc$master_catalog_path_index + 1,

    pfc$maximum_catalog_depth = 100; {excludes set, includes family}

  TYPE
    pft$catalog_path_index = 1 .. pfc$maximum_catalog_depth + 1,
    pft$file_path_index = 1 .. pfc$maximum_catalog_depth + 2,

    pft$complete_path = array [1 .. * ] of pft$name,
    pft$p_complete_path = ^pft$complete_path,

    pft$internal_path = array [1 .. * ] of pft$internal_name,
    pft$p_internal_path = ^pft$internal_path,

    pft$internal_cycle_path = record
      cycle_name: pft$internal_name,
      path: pft$internal_path,
    recend,

    pft$p_internal_cycle_path = ^pft$internal_cycle_path,

    pft$p_path = ^pft$path;

*copyc pfd$internal_name
*copyc pfd$permanent_file_definitions
*DECK DECK=PFD$CYCLE_STATISTICS EXPAND=FALSE

 TYPE
    pft$cycle_statistics = record
      creation_date_time: ost$date_time,
      modification_date_time: ost$date_time,
      access_date_time: ost$date_time,
      access_count: pft$access_count,
    recend,
    pft$access_count = 0 .. 0ffff(16);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
?? POP ??
*DECK DECK=PFD$INFORMATION_SELECTIONS EXPAND=FALSE

{ Catalog Access Definitions

  CONST
    pfc$max_selection_id_ordinal = 32;

  TYPE
    pft$file_information = (pfc$catalog_names, pfc$file_names,
      pfc$cycle_numbers),

    pft$file_selections = set of pft$file_information,

    pft$selection_id_ordinal = 1 .. pfc$max_selection_id_ordinal,
    pft$selection_id_sequence = amt$file_id_sequence,

    pft$selection_identifier = record
      ordinal: pft$selection_id_ordinal,
      sequence: pft$selection_id_sequence,
    recend,

    pft$selection_record = record
      case kind: pft$file_information of
      = pfc$catalog_names =
        catalog_name: pft$name,
      = pfc$file_names =
        file_name: pft$name,
      = pfc$cycle_numbers =
        cycle_number: pft$cycle_number,
      casend,
    recend,

    pft$selection_position = (pfc$end_of_record, pfc$end_of_information);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFD$INTERNAL_NAME EXPAND=FALSE

 TYPE
    pft$internal_name = ost$binary_unique_name,
    pft$internal_catalog_name = pft$internal_name,
    pft$p_internal_catalog_name = ^pft$internal_catalog_name;

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
?? POP ??
*DECK DECK=PFD$MANDATED_MODIFICATION_TIME EXPAND=FALSE


  TYPE
    pft$modification_time_options = (pfc$verify_modification_time,
      pfc$replace_modification_time,
      pfc$no_verify_modification_time);

  TYPE
    pft$mandated_modification_time = record
      existing_modification_time: {output} ost$date_time,
      case verify_option :{input} pft$modification_time_options of
      = pfc$no_verify_modification_time =
        ,
      = pfc$replace_modification_time,  pfc$verify_modification_time =
        specified_modification_time :{input} ost$date_time,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
?? POP ??
*DECK DECK=PFD$PASSWORD_SELECTOR EXPAND=FALSE


  TYPE
    pft$password_selector_option = (pfc$default_password_option,
      pfc$specific_password_option);

  TYPE
    pft$password_selector = record
      case password_specified: pft$password_selector_option of
      = pfc$default_password_option =
        { For the system or family administrator, or file owner this defaults
        { to the correct value; for all others, this defaults to osc$null_name.
        ,
      = pfc$specific_password_option =
        password: pft$password,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFD$PERMANENT_FILE_ATTRIBUTES EXPAND=FALSE
?? SKIP := 4 ??
{Permanent File Attributes}


  TYPE
    pft$application_info = string (osc$max_name_size),

    pft$permit_options = (pfc$read, pfc$shorten, pfc$append, pfc$modify,
      pfc$execute, pfc$cycle, pfc$control),

    pft$usage_options = pfc$read .. pfc$execute,
    pft$usage_selections = set of pft$usage_options,

    pft$share_options = pfc$read .. pfc$execute,
    pft$share_selections = set of pft$share_options;
?? PUSH (LISTEXT := ON) ??
*copyc OST$NAME
?? POP ??
*DECK DECK=PFD$PERMANENT_FILE_DEFINITIONS EXPAND=FALSE
?? SKIP := 4 ??
{Permanent File Definitions}


  CONST
    pfc$minimum_cycle_number = 1,
    pfc$maximum_cycle_number = 999,

    pfc$minimum_retention = 1,
    pfc$maximum_retention = 999,

    pfc$family_name_index = 1,
    pfc$master_catalog_name_index = pfc$family_name_index + 1,
    pfc$subcatalog_name_index = pfc$master_catalog_name_index + 1;

  TYPE
    pft$array_index = 1 .. 7FFFFFFF(16),

    pft$name = ost$name,

    pft$path = array [ 1 .. * ] of pft$name,

    pft$cycle_number = pfc$minimum_cycle_number .. pfc$maximum_cycle_number,

    pft$cycle_options = (pfc$lowest_cycle, pfc$highest_cycle,
      pfc$specific_cycle),
    pft$cycle_selector = record
      case cycle_option: pft$cycle_options of
      = pfc$lowest_cycle =
        ,
      = pfc$highest_cycle =
        ,
      = pfc$specific_cycle =
        cycle_number: pft$cycle_number,
      casend,
    recend,

    pft$password = pft$name,

    pft$retention = pfc$minimum_retention .. pfc$maximum_retention,

    pft$log = (pfc$log, pfc$no_log),

    pft$change_type = (pfc$pf_name_change, pfc$password_change,
      pfc$cycle_number_change, pfc$retention_change, pfc$log_change,
      pfc$charge_change, pfc$delete_damage_change),
    pft$change_list = array [ 1 .. * ] of pft$change_descriptor,
    pft$change_descriptor = record
      case change_type: pft$change_type of
      = pfc$pf_name_change =
        pfn: pft$name,
      = pfc$password_change =
        password: pft$password,
      = pfc$cycle_number_change =
        cycle_number: pft$cycle_number,
      = pfc$retention_change =
        retention: pft$retention,
      = pfc$log_change =
        log: pft$log,
      = pfc$charge_change =
        ,
      = pfc$delete_damage_change =
        delete_damage_condition: fst$cycle_damage_symptoms,
      casend,
    recend,

    pft$wait = (pfc$wait, pfc$no_wait),


    pft$permit_selections = set of pft$permit_options,
    pft$share_requirements = set of pft$share_options,


    pft$group_types = (pfc$public, pfc$family, pfc$account,
      pfc$project, pfc$user, pfc$user_account, pfc$member),
    pft$group = record
      case group_type: pft$group_types of
      = pfc$public =
        ,
      = pfc$family =
        family_description: record
          family: ost$family_name,
        recend,
      = pfc$account =
        account_description: record
          family: ost$family_name,
          account: avt$account_name,
        recend,
      = pfc$project =
        project_description: record
          family: ost$family_name,
          account: avt$account_name,
          project: avt$project_name,
        recend,
      = pfc$user =
        user_description: record
          family: ost$family_name,
          user: ost$user_name,
        recend,
      = pfc$user_account =
        user_account_description: record
          family: ost$family_name,
          account: avt$account_name,
          user: ost$user_name,
        recend,
      = pfc$member =
        member_description: record
          family: ost$family_name,
          account: avt$account_name,
          project: avt$project_name,
          user: ost$user_name,
        recend,
      casend,
    recend;

*copyc PFD$PERMANENT_FILE_ATTRIBUTES
?? PUSH (LISTEXT := ON) ??
*copyc OST$NAME
*copyc OST$USER_IDENTIFICATION
*copyc AVT$ACCOUNT_NAME
*copyc AVT$PROJECT_NAME
*copyc fst$cycle_damage_symptoms
?? POP ??
*DECK DECK=PFD$QUEUED_CATALOG_TABLE EXPAND=FALSE

{Queued Catalog Definitions}

  TYPE
    pft$queued_catalog_table = array [1 .. * ] of pft$queued_catalog,
    pft$p_queued_catalog_table = ^pft$queued_catalog_table,

    pft$queued_catalog = record
      p_next_newest: ^pft$queued_catalog,
      p_next_oldest: ^pft$queued_catalog,
      case valid_catalog: boolean of
      = FALSE =
        ,
      = TRUE =
        set_name: stt$set_name,
        parent_catalog_internal_name: pft$internal_catalog_name,
        external_catalog_name: pft$name,
        internal_catalog_name: pft$internal_catalog_name,
        global_file_name: ost$binary_unique_name,
        recorded_vsn: rmt$recorded_vsn,
        charge_id: pft$charge_id,
        system_file_id: dmt$system_file_id,
        case access_queued: boolean of
        = FALSE =
          ,
        = TRUE =
          { The following points to the list of all queued internal catalogs.
          p_internal_catalog_list: ^pft$queued_internal_catalog,
          { The following is the direct permit for the job.
          permit: pft$queued_permit_entry,
        casend,
      casend,
    recend,

    pft$queued_permit_entry = record
      case entry_type: pft$permit_entry_types of
      = pfc$free_permit_entry =
        ,
      = pfc$normal_permit_entry =
        group_type: pft$group_types,
        usage_permissions: pft$permit_selections,
        share_requirements: pft$share_requirements,
        application_info: pft$application_info,
      casend,
    recend,

    pft$p_queued_catalog = ^pft$queued_catalog;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc pfd$catalog
*copyc pfd$charge_id
*copyc pfd$internal_name
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc pfd$queued_internal_catalog
*copyc rmt$recorded_vsn
*copyc std$set_name
?? POP ??
*DECK DECK=PFD$QUEUED_INTERNAL_CATALOG EXPAND=FALSE

  TYPE
    pft$p_queued_internal_catalog = ^pft$queued_internal_catalog,

    pft$queued_internal_catalog = record
      { The parent catalog name is needed for internal catalogs because of the
      { possibility of multiple nested internal catalogs.
      parent_catalog_name: pft$internal_catalog_name,
      external_catalog_name: pft$name,
      internal_catalog_name: pft$internal_catalog_name,
      charge_id: pft$charge_id,
      permit: pft$permit_entry,
      p_next_internal_catalog: ^pft$queued_internal_catalog,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
*copyc pfd$charge_id
*copyc pfd$internal_name
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFD$ROOT EXPAND=FALSE
{ PFDROOT - Permanent File Root Definitions.

  TYPE
    pft$root = SEQ ( * ),
    pft$p_root = ^pft$root,
    pft$root_size = 0 .. 0ffffffff(16);
*DECK DECK=PFD$SHARE_SELECTOR EXPAND=FALSE


  {PFDSHAR - Share Selector Definitions}

  TYPE

    pft$share_selector_options = (pfc$default_share_option, pfc$specific_share_option),

    pft$share_selector = record
      case option: pft$share_selector_options of
      = pfc$default_share_option =
        ,
      = pfc$specific_share_option =
        share_selections: pft$share_selections,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
?? POP ??
*DECK DECK=PFD$TABLE_INFO EXPAND=FALSE
 TYPE
    pft$table_info = SEQ ( * ),

    pft$p_table_info = ^pft$table_info,

    pft$table_name = string (32),

    pft$record_id = string (8);
*DECK DECK=PFD$USAGE_SELECTOR EXPAND=FALSE


  {PFDUSE - Usage Selector Definitions}

  TYPE

    pft$usage_selector_options = (pfc$default_usage_option, pfc$specific_usage_option),

    pft$usage_selector = record
      case option: pft$usage_selector_options of
      = pfc$default_usage_option =
        ,
      = pfc$specific_usage_option =
        usage_selections: pft$usage_selections,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
?? POP ??
*DECK DECK=PFE$ERROR_CONDITION_CODES EXPAND=FALSE
?? FMT (FORMAT := OFF) ??
?? NEWTITLE := 'Permanent File Manager : 0000 .. 2599' ??
*copyc pfc$min_ecc

  CONST
    pfc$permanent_file_manager_id = 'PF',
    pfc$lowest_error = pfc$min_ecc,
    pfc$highest_error = pfc$min_ecc + 9999,

    {Permanent File Exception Condition Codes}

    pfe$allocation_mismatch = pfc$lowest_error + 50,
    {E File +F cannot be attached because it has overflowed to different}
    { allocation sizes.}
    {+N3 The file must be deleted and restored.}

    pfe$allowed_damage_mismatch = pfc$lowest_error + 75,
    {E File +F is currently attached to this job with
    { ALLOWED_EXCEPTION_CONDITIONS of +P2.}
    {+N3 All concurrent attaches within a job must be made with the same value}
    {+E3 for ALLOWED_EXCEPTION_CONDITIONS.}

    pfe$bad_account_name = pfc$lowest_error + 105,
    {E Account name "+P" is improper.}

    pfe$bad_change_type = pfc$lowest_error + 111,
    {E Permanent file change type "+P" is improper.}

    pfe$bad_cycle_number = pfc$lowest_error + 116,
    {E File cycle number "+P" is out of range.  It must be between 1 and 999.}

    pfe$bad_cycle_option = pfc$lowest_error + 122,
    {E File cycle option "+P" is improper.}

    pfe$bad_family_name = pfc$lowest_error + 127,
    {E Family name "+P" is improper.}

    pfe$bad_group_type = pfc$lowest_error + 133,
    {E Permanent file group type "+P" is improper.}

    pfe$bad_last_subcatalog_name = pfc$lowest_error + 138,
    {E Subcatalog name "+P" is improper.}

    pfe$bad_local_file_name = pfc$lowest_error + 144,
    {E Local file name "+P" is improper.}

    pfe$bad_log_option = pfc$lowest_error + 150,
    {E Permanent file log option "+P" is improper.}

    pfe$bad_master_catalog_name = pfc$lowest_error + 155,
    {E Master catalog name "+P" is improper.}

    pfe$bad_nth_subcatalog_name = pfc$lowest_error + 161,
    {E Subcatalog name "+P" is improper.}

    pfe$bad_password = pfc$lowest_error + 166,
    {E Permanent file password "+P" is improper.}

    pfe$bad_permanent_file_name = pfc$lowest_error + 172,
    {E File name "+P" is improper.}

    pfe$bad_project_name = pfc$lowest_error + 177,
    {E Project name "+P" is improper.}

    pfe$bad_retention_period = pfc$lowest_error + 183,
    {E Permanent file retention period "+P" is improper.}

    pfe$bad_user_name = pfc$lowest_error + 188,
    {E User name "+P" is improper.}

    pfe$bad_wait_option = pfc$lowest_error + 194,
    {E Permanent file wait option "+P" is improper.}

    pfe$cannot_purge_master_catalog = pfc$lowest_error + 207,
    {E A master catalog cannot be deleted using this command or program}
    { interface.}

    pfe$catalog_full = pfc$lowest_error + 214,
    {E Permanent file catalog +P1 is full.  +P2}

    pfe$catalog_move_not_supported = pfc$lowest_error + 220,
    {E The movement of catalogs is not currently supported.  This capability}
    { will be supported in a future release.}

    pfe$catalog_not_empty = pfc$lowest_error + 228,
    {E Permanent file catalog +P is not empty.}

    pfe$catalog_volume_not_online = pfc$lowest_error + 232,
    {E Catalog volume +P1 not on-line +P2 +P3.}

    pfe$catalog_volume_unavailable = pfc$lowest_error + 234,
    {E Catalog volume +P1 unavailable +P2 +P3.}

    pfe$change_requires_privilege = pfc$lowest_error + 236,
    {E System or Family Administration privilege is required to change}
    { the RETRIEVE_OPTION from ADMINISTRATIVE_RETRIEVE_ONLY to +P1.}

    pfe$cycle_busy = pfc$lowest_error + 242,
    {E Cycle number +P2 of permanent file +P1 is busy.}
    {+N3 +P3}

    { Describe the possible reasons for pfe$cycle_busy.
    pfc$current_job_usage_conflict = 'Requested usage conflicts with how' CAT
          ' the job currently has the cycle attached.',
    pfc$current_job_share_conflict = 'Requested sharing conflicts with how' CAT
          ' the job is currently sharing the cycle.',
    pfc$multiple_job_usage_conflict = 'Requested usage conflicts with how' CAT
          ' other jobs are willing to share the cycle.',
    pfc$multiple_job_share_conflict  = 'Requested sharing conflicts with' CAT
          ' how other jobs are using the cycle.',
    pfc$another_mainframe_writer = 'Another mainframe is writing the cycle.',
    pfc$another_mainframe_user = 'Requested write usage, but another' CAT
          ' mainframe is using the cycle.',

    pfe$cycle_data_resides_offline = pfc$lowest_error + 250,
    {E Cycle +P2 of file +P1 is unavailable because its data resides off-line.}

    pfe$explicit_retrieve_required = pfc$lowest_error + 252,
    {E Implicit retrieval of cycle +P2 of file +P1 is not allowed because it has}
    { a RETRIEVE_OPTION of EXPLICIT_RETRIEVE_ONLY.}

    pfe$cycle_overflow = pfc$lowest_error + 257,
    {E The highest possible cycle number already exists for file +F.}

    pfe$cycle_underflow = pfc$lowest_error + 271,
    {E The lowest possible cycle number already exists for file +F.}

    pfe$cycles_media_missing = pfc$lowest_error + 285,
    {E File +P resides on a medium that is missing.}
    {+N3 Either delete the cycle, restore it, or wait for the volume to be}
    {+E3 reinstalled.}

    pfe$duplicate_cycle = pfc$lowest_error + 350,
    {E Cycle number +P2 already exists for permanent file +P1.}

    pfe$duplicate_offline_cycle = pfc$lowest_error + 355,
    {E Offline data already exists for cycle +P2 of permanent file +P1.}

    pfe$duplicate_purged_cycle = pfc$lowest_error + 375,
    {E Cycle +P has been deleted but is currently attached to this job.}
    {+N3 The cycle can be accessed using the local_file_name or a path}
    {+E3 specification that includes the cycle number. +E3 Until this cycle is}
    {+E3 detached, an identical cycle cannot be created by this job.}

    pfe$family_already_exists = pfc$lowest_error + 550,
    {E Family "+P" already exists.}

    pfe$incorrect_damage_condition = pfc$lowest_error + 825,
    {E Incorrect damage condition.  The +P}

    pfe$incorrect_password = pfc$lowest_error + 850,
    {E The password provided is incorrect for permanent file +P.}

    pfe$invalid_class_on_dest_vol = pfc$lowest_error + 857,
    {E Mass storage class +P1 is not represented on any of the specified}
    { destination volumes.}

    pfe$invalid_class_on_source_vol = pfc$lowest_error + 858,
    {E Mass storage class +P1 is present on one or more of the specified}
    { source volumes.}

    pfe$invalid_group = pfc$lowest_error + 860,
    {E You do not have authority to create a permit with a +P other than your}
    { own.}

    pfe$invalid_group_type = pfc$lowest_error + 865,
    {E You do not have authority to create a permit with a group type of +P.}

    pfe$invalid_input_file_format = pfc$lowest_error + 868,
    {E The format of input file is invalid.  The only valid input to the}
    { EXTRACT_FILE_LIST command is an output file of the MOVE_CLASSES command.}

    pfe$invalid_mass_storage_class = pfc$lowest_error + 870,
    {E Mass storage classes A, C, N & Q are invalid selections for the}
    { MASS_STORAGE_CLASSES parameter.}

    pfe$invalid_ring_access = pfc$lowest_error + 875,
    {E The task is executing with insufficient ring privilege for the}
    { requested access to permanent file +P.}

    pfe$invalid_shared_queue_name = pfc$lowest_error + 880,
    {E Shared queue name "+P" is invalid.}

    pfe$invalid_shared_queue_ord = pfc$lowest_error + 885,
    {E Shared queue ordinal "+P" is invalid.}

    pfe$last_name_not_subcatalog = pfc$lowest_error + 1133,
    {E +P is expected to be the name of a subcatalog, but it is a permanent}
    { file.}

    pfe$lfn_in_use = pfc$lowest_error + 1166,
    {E Local file name "+P" is already in use.}

    pfe$media_image_inconsistent = pfc$lowest_error + 1230,
    {E +F has been corrupted by a system interrupt.}
    {+N3 Use change_catalog_entry}
    {+E3 delete_damage_condition=media_image_inconsistent to clear this error.}

    pfe$movc_parameter_conflict_1 = pfc$lowest_error + 1260,
    {E Either the SOURCE_VOLUMES parameter or the DESTINATION_VOLUMES parameter}
    { must be specified.}

    pfe$movc_parameter_conflict_2 = pfc$lowest_error + 1261,
    {E When the +P1 parameter is specified, neither the FILES parameter nor the}
    { CATALOGS parameter may be specified.}

    pfe$movc_no_source_volumes = pfc$lowest_error + 1262,
    {E No source volumes were found because all volumes in the +P1 set were}
    { included in the DESTINATION_VOLUMES list.}

    pfe$movc_no_destination_volumes = pfc$lowest_error + 1263,
    {E No destination volumes with the specified mass storage classes were found}
    { in the +P1 set.}

    pfe$movc_invalid_device_class = pfc$lowest_error + 1264,
    {E MOVE_CLASSES cannot move file +P1 because it has a device class of +P2.}

    pfe$movc_subfile_list_seq_size = pfc$lowest_error + 1265,
    {E MOVE_CLASSES cannot move +P1 +P2 because the sequence for the subfile}
    { list is too small.}

    pfe$movc_ms_class_conflict = pfc$lowest_error + 1266,
    {E MOVE_CLASSES cannot move +P1 +P2 because it belongs to mass storage}
    { class +P3 which was not included in the specified mass storage classes.}

    pfe$movc_not_on_source_volumes = pfc$lowest_error + 1267,
    {E MOVE_CLASSES cannot move +P1 +P2 because it does not reside on the}
    { specified source volumes.}

    pfe$movc_insufficient_space = pfc$lowest_error + 1268,
    {E There is insufficient space of mass storage class +P1 on set +P2}
    { to move +P3 +P4.}

    pfe$movc_no_available_space = pfc$lowest_error + 1269,
    {E There is no available space of mass storage class +P1 on set +P2}
    { to move +P3 +P4.}

    pfe$movc_family_not_in_set = pfc$lowest_error + 1270,
    {E The family administrator's login family +P1 is not in set +P2.}

    pfe$movc_operator_termination = pfc$lowest_error + 1271,
    {E Due to insufficient mass storage space, the operator selected the}
    { menu option to terminate the MOVE_CLASSES command.}

    pfe$movc_volume_unavailable = pfc$lowest_error + 1272,
    {E +P1 +P2 is not in the ON state.}

    pfe$movc_sys_set_root_not_moved = pfc$lowest_error + 1273,
    {E The root catalog of the system set (+P1) cannot be moved.}

    pfe$name_already_permanent_file = pfc$lowest_error + 1314,
    {E +F is already being used as the name of a file.}

    pfe$name_already_subcatalog = pfc$lowest_error + 1328,
    {E +P is already being used as the name of a permanent file subcatalog.}

    pfe$name_already_used = pfc$lowest_error + 1342,
    {E Name "+P" is already being used.}

    pfe$name_not_permanent_file = pfc$lowest_error + 1357,
    {E +F is expected to be the name of a file, but it is a catalog.}

    pfe$no_access_before_commit = pfc$lowest_error + 1364,
    {E Access to permanent files is not allowed prior to system commit.}

    pfe$no_permit_deleted = pfc$lowest_error + 1367,
    {W There is no permit of the specified group type to delete.}

    pfe$no_site_option_validation = pfc$lowest_error + 1368,
    {E You are not validated to use a value of +P2 for +P1.}

    pfe$non_owner_tape_file_create = pfc$lowest_error + 1369,
    {E You are not allowed to create tape files in catalog +P1.}
    {+N3 Creation of tape files is restricted to the catalog owner.}

    pfe$no_space_for_master_catalog = pfc$lowest_error + 1370,
    {E No catalog space is available to create a master catalog for user +P1 on family +P2.}

    pfe$not_master_catalog_owner = pfc$lowest_error + 1371,
    {E You are not the owner of master catalog +P1 of family +P2.}

    pfe$nth_name_not_subcatalog = pfc$lowest_error + 1385,
    {E +P is expected to be the name of a subcatalog, but it is a permanent}
    { file.}

    pfe$null_access_not_allowed = pfc$lowest_error + 1390,
    {E File +P cannot be attached with no modes of access.}

    pfe$parent_catalog_restored = pfc$lowest_error + 1525,
    {E File +P resides in a catalog that was restored.}
    {+N3 Your file attributes, file permits, access log, modification date}
    {+E3 time, or access date time may be inaccurate.}
    {+N3 Use change_catalog_entry}
    {+E3 delete_damage_condition=parent_catalog_restored to clear this error.}

    pfe$path_too_long = pfc$lowest_error + 1529,
    {E The path (or new path) is too long.}

    pfe$path_too_short = pfc$lowest_error + 1533,
    {E The "+P3" parameter requires at least +P2 names; +P1 was given.}

    pfe$pf_system_error = pfc$lowest_error + 1566,
    {E A system error has occurred.}

    pfe$process_storage_errors = pfc$lowest_error + 1583,
    {W PROCESS_STORAGE detected +P error(s).  Examine $ERRORS file.}

    pfe$redundant_volume_spec = pfc$lowest_error + 1590,
    {E Volume +P1 was specified on both the SOURCE_VOLUMES parameter and}
    { the DESTINATION_VOLUMES parameter.}

    pfe$replace_cycle_data_busy = pfc$lowest_error + 1591,
    {E Data for +P1 cannot be replaced because the file is attached.}

    pfe$resides_on_dest_volumes = pfc$lowest_error + 1600,
    {E +P1 +P2 was not moved because it already resides entirely on the}
    { destination volume(s).}

    pfe$respf_modification_mismatch = pfc$lowest_error + 1750,
    {E File +P1 has been restored.}
    {+N3 Changes made between +P2 +P3 and a failure have been lost.}
    {+N3 Use change_catalog_entry}
    {+E3 delete_damage_condition=respf_modification_mismatch to clear this}
    {+E3 error.}

    pfe$retrieve_requires_privilege = pfc$lowest_error + 1760,
    {E Administrative privilege is required to retrieve cycle +P2 of file +P1}
    { because it has a RETRIEVE_OPTION of ADMINISTRATIVE_RETRIEVE_ONLY.}

    pfe$sharing_not_permitted = pfc$lowest_error + 1850,
    {E To access permanent file +P1, you are required to allow sharing of +P2,}
    { not the intended sharing of +P3.}

    pfe$skipped_catalog = pfc$lowest_error + 1867,
    {W +P1 skipped catalog +F2 due to following error.}

    pfe$skipped_file = pfc$lowest_error + 1875,
    {W +P1 skipped file +F2 cycle +P3 due to following error.}

    pfe$too_many_catalogs_in_path = pfc$lowest_error + 1950,
    {E A path may be composed of no more than +P2 catalogs.  +P3 catalogs were}
    { specified in path +P1.}

    pfe$undefined_data = pfc$lowest_error + 2011,
    {E No data is defined for cycle +P2 of permanent file +P1.}

    pfe$unknown_cycle = pfc$lowest_error + 2022,
    {E Cycle number "+P2" of permanent file +P1 does not exist.}

    pfe$unknown_family = pfc$lowest_error + 2033,
    {E Family name +P does not exist or you are not permitted for any access.}

    pfe$unknown_last_subcatalog = pfc$lowest_error + 2044,
    {E Subcatalog name +P does not exist or you are not permitted for any}
    { access.}

    pfe$unknown_master_catalog = pfc$lowest_error + 2055,
    {E Master catalog name +P does not exist or you are not permitted for any}
    { access.}

    pfe$unknown_nth_subcatalog = pfc$lowest_error + 2066,
    {E Subcatalog name +P does not exist or you are not permitted for any}
    { access.}

    pfe$unknown_permanent_file = pfc$lowest_error + 2077,
    {E File +F does not exist or you are not permitted for any access.}

    pfe$usage_not_permitted = pfc$lowest_error + 2088,
    {E You are only permitted access to permanent file +P1 for +P2 usage, not}
    { the requested usage of +P3.  +P4}

    { If the owner of a file denies all permission to the file for
    { himself and then attempts to open a cycle of the file using
    { fsc$permitted_access_modes, then the above error will contain "null set"
    { for both +P2 and +P3, which is confusing.  In this case +P4 will be
    { replaced by the following text.

    pfc$usage_self_denied = 'That is, you have denied yourself permission' CAT
          ' to the file.',

    pfe$volume_not_online = pfc$lowest_error + 2095,
    {E Volume +P2 not on-line for file +F1.}

    pfe$volume_unavailable = pfc$lowest_error + 2099;
    {E Volume +P2 unavailable for file +F1.}

?? OLDTITLE ??
?? FMT (FORMAT := ON) ??
*DECK DECK=PFE$EXTERNAL_ARCHIVE_CONDITIONS EXPAND=FALSE
?? FMT (FORMAT := OFF) ??
?? NEWTITLE := 'pfe$external_archive_conditions : 4800 .. 4899' ??
*copyc pfc$min_ecc

  CONST
    pfc$lowest_ext_archive_error = pfc$min_ecc + 4800,
    pfc$highest_ext_archive_error = pfc$min_ecc + 4899,


    pfe$bad_archive_identification = pfc$lowest_ext_archive_error + 1,
    {E Archive application name "+P" is improper.}

    pfe$unknown_archive_application = pfc$lowest_ext_archive_error + 2,
    {E No archive entry found in the info record for archive application +P.}

    pfe$unknown_archive_entry = pfc$lowest_ext_archive_error + 3,
    {E No archive entry found in the info record.}

    pfe$unknown_archive_ident = pfc$lowest_ext_archive_error + 4,
    {E Archive identification +P not found.}

    pfe$unknown_archive_info = pfc$lowest_ext_archive_error + 5,
    {E No archive info found in the info record.}

    pfe$unknown_archive_media_desc = pfc$lowest_ext_archive_error + 6,
    {E No archive media descriptor found in the info record.}

    pfe$empty_archive_list = pfc$lowest_ext_archive_error + 7,
    {E No archive list found.}

    pfe$data_not_releasable = pfc$lowest_ext_archive_error + 8;
    {E Data is not releasable for cycle +P2 of file +P1.}

?? OLDTITLE ??
?? FMT (FORMAT := ON) ??
*DECK DECK=PFE$GET_OBJECT_INFO_ERRORS EXPAND=FALSE
?? FMT (FORMAT := OFF) ??
?? NEWTITLE := 'pfe$get_object_info_errors : 4700 .. 4799' ??
*copyc pfc$min_ecc

  CONST
    pfc$get_object_info_error_base = pfc$min_ecc + 4700,

    pfe$bad_object_info_requests = pfc$get_object_info_error_base + 4,
    {E The object information requests provided are improper.}

    pfe$bad_validation_selection = pfc$get_object_info_error_base + 6,
    {E Validation selection +P is improper.}

    pfe$catalogs_have_no_password = pfc$get_object_info_error_base + 8,
    {E A password was specified, but catalogs do not have passwords.}

    pfe$neither_owner_nor_admin = pfc$get_object_info_error_base + 50,
    {E Only the owner or an administrator of the object may specify a subject}
    { permit.}

    pfe$temporary_files_have_no_pw = pfc$get_object_info_error_base + 74;
    {E A password was specified, but $local files do not have passwords.}

?? OLDTITLE ??
?? FMT (FORMAT := ON) ??
*DECK DECK=PFE$INTERNAL_ERROR_CONDITIONS EXPAND=FALSE
?? FMT (FORMAT := OFF) ??
?? NEWTITLE := 'Permanent File Manager : 5000 .. 7599' ??
*copyc pfc$min_ecc

  CONST
    pfc$lowest_internal_error = pfc$min_ecc + 5000,
    pfc$highest_internal_error = pfc$min_ecc + 9999,

    {Internal Permanent File Exception Condition Codes}

    pfe$bad_catalog_heap = pfc$lowest_internal_error + 111,
    {E The heap for catalog +P is damaged.}

    pfe$bad_info_record_format = pfc$lowest_internal_error + 122,
    {E The info record provided as input was in an unexpected format. +P}

    pfe$bad_item_name = pfc$lowest_internal_error + 133,
    {E Item name +P is improper.}

    pfe$bad_ring_number = pfc$lowest_internal_error + 144,
    {E Ring number +P is improper.}

    pfe$bad_root_catalog_header = pfc$lowest_internal_error + 156,
    {E Improper root catalog header for +P.}

    pfe$bad_set_name = pfc$lowest_internal_error + 167,
    {E Set name +P is improper.}

    pfe$bad_share_selector_option = pfc$lowest_internal_error + 178,
    {E Share selector option +P is improper.}

    pfe$bad_usage_selector_option = pfc$lowest_internal_error + 189,
    {E Usage selector option +P is improper.}

    pfe$catalog_access_retry = pfc$lowest_internal_error + 200,
    {I Internal: Catalog access blocked - procedure call must be reissued.}

    pfe$corrupted_catalog_heap = pfc$lowest_internal_error + 210,
    {E Corrupted catalog heap detected by +P1.}

    pfe$cycle_attached_on_client = pfc$lowest_internal_error + 250,
    {I Internal: Recheck client mainframe to get attached info.}

    pfe$data_already_defined = pfc$lowest_internal_error + 325,
    {E Data is already defined for cycle +P2 of permanent file +P1.}

    pfe$delete_needs_reconcile = pfc$lowest_internal_error + 340,
    {E If deletion of unreconciled files is chosen, then reconciliation must}
    { also be chosen.}

    pfe$duplicate_family_catalog = pfc$lowest_internal_error + 350,
    {E Family catalog name +P already exists.}

    pfe$duplicate_master_catalog = pfc$lowest_internal_error + 375,
    {E Master catalog name +P already exists.}

    pfe$info_full = pfc$lowest_internal_error + 820,
    {E The info container provided was not large enough to hold the}
    { information requested. +P}

    pfe$info_offset_range_error = pfc$lowest_internal_error + 840,
    {E The info_offset (+P1) is outside the range of the info record provided}
    { as input (+P2 .. +P3).}

    pfe$invalid_apfid = pfc$lowest_internal_error + 860,
    {E The attached permanent file id parameter is invalid.}

    pfe$invalid_free = pfc$lowest_internal_error + 870,
    {E Attempt to free a +P1 associated with +P2 +P3 detected catalog}
    { corruption of type +P4 at offset +P5.}

    pfe$invalid_or_unusable_pva = pfc$lowest_internal_error + 880,
    {E Invalid PVA specified or access to segment from present ring denied:}
    {  PVA = +P1 +P2 +P3}

    pfe$modification_time_mismatch = pfc$lowest_internal_error + 1250,
    {E The modification time supplied does not match the stored modification}
    { time for cycle +P2 of permanent file +P1.}

    pfe$nil_pointer = pfc$lowest_internal_error + 1325,
    {E Unexpected NIL pointer specified.}

    pfe$no_operation = pfc$lowest_internal_error + 1337,
    {W The issued request resulted in no operation being performed.}

    pfe$no_media_image_inconsistent = pfc$lowest_internal_error + 1344,
    {E Unable to clear MEDIA_IMAGE_INCONSISTENT damage condition for file +P1}
    { because it is not set.}

    pfe$no_queued_catalog_found = pfc$lowest_internal_error + 1350,
    {I No catalog in the internal path was found in the queued_catalog_table.}

    pfe$not_all_pfs_recovered = pfc$lowest_internal_error + 1362,
    {F +P permanent files not recovered in job.}

    pfe$not_family_owner = pfc$lowest_internal_error + 1375,
    {E You are not the owner of family +P.}

    pfe$not_set_owner = pfc$lowest_internal_error + 1387,
    {E You are not the owner of set +P.}

    pfe$not_system_administrator = pfc$lowest_internal_error + 1391,
    {E You must be the system administrator to use the +P request.}

    pfe$not_system_operator = pfc$lowest_internal_error + 1395,
    {E You must be the system operator to use the +P request.}

    pfe$overhaul_catalog_failed = pfc$lowest_internal_error + 1450,
    {E Overhaul of catalog +P failed.  Check job log.}

    pfe$recheck_client_mainframe = pfc$lowest_internal_error + 1716,
    {I Internal: Cycle unresolvable - recheck client mainframe.}

    pfe$recovery_summary = pfc$lowest_internal_error + 1733,
    {W +P1 +P2 occurred during permanent file recovery.}
    {+N3 +P3 +P4 +E3 +P5 +P6 +E3 +P7 +P8 +E3 +P9 +P10 +E3 +P11 +P12 +E3 +P13}
    { +P14 +E3 +P15 +P16 +E3 +P17 +P18 +E3 +P19 +P20 +E3 +P21 +P22 +E3 +P23}
    { +P24 +E3 +P25 +P26 +E3 +P27 +P28 +E3 +P29 +P30 +E3 +P31 +P32}

    pfe$reorganize_needs_reconcile = pfc$lowest_internal_error + 1766,
    {E If reorganization is chosen, then reconciliation must also be chosen.}

    pfe$reserved_cycle_table_locked = pfc$lowest_internal_error + 1774,
    {E The reserved cycle table is currently locked by another task.}

    pfe$restore_not_selected = pfc$lowest_internal_error + 1782,
    {E File: +P1 not selected for restore - +P2.}

    pfe$server_file_attached = pfc$lowest_internal_error + 1912,
    {E Job has server file attached.}

    pfe$sparse_allocation_format = pfc$lowest_internal_error + 1925,
    {E File cycle cannot be restored because it is in sparse allocation format
    { on the backup file.

    pfe$system_catalog_recreated = pfc$lowest_internal_error + 1950,
    {E $SYSTEM master catalog was recreated.}

    pfe$tape_attached_on_client = pfc$lowest_internal_error + 1975,
    {I Tape file cycle is attached by the client mainframe.}

    pfe$unimplemented_server_call = pfc$lowest_internal_error + 2001,
    {E The +P request has not been implemented for the file server yet.}

    pfe$unknown_catalog_media = pfc$lowest_internal_error + 2004,
    {E No catalog media was found in the info record provided as input. +P}

    pfe$unknown_cycle_array = pfc$lowest_internal_error + 2020,
    {E No cycle array was found in the info record provided as input. +P}

    pfe$unknown_cycle_label = pfc$lowest_internal_error + 2025,
    {E No cycle label was found in the cycle info record provided as input. +P}

    pfe$unknown_cycle_media = pfc$lowest_internal_error + 2030,
    {E No cycle media was found in the cycle info record provided as input. +P}

    pfe$unknown_info_record = pfc$lowest_internal_error + 2040,
    {E There were no info subrecords in the info record provided as input. +P}

    pfe$unknown_item = pfc$lowest_internal_error + 2060,
    {E Item name +P is unknown.}

    pfe$unknown_set = pfc$lowest_internal_error + 2080,
    {E Set name +P is unknown.}

    pfe$unsupported_device_class = pfc$lowest_internal_error + 2090,
    {E File cycle cannot be restored because it resides on a device class that}
    { is not supported by this release.

    pfe$unreconciled_catalog = pfc$lowest_internal_error + 2100,
    {W The disk image with global file name +P2 which contains the catalog}
    { information for catalog +F1, does not exist.

    pfe$unreconciled_file = pfc$lowest_internal_error + 2110;
    {W Due to recovery without image or a system error, the disk image with}
    { global file name +P2 which contains the data for file +F1, does not}
    { exist.


?? OLDTITLE ??
?? FMT (FORMAT := ON) ??
*DECK DECK=PFE$SELECTION_ERRORS EXPAND=FALSE
?? FMT (FORMAT := OFF) ??
?? NEWTITLE := 'Permanent File Mgr (Info Selections) : 4900 .. 4999' ??
*copyc pfc$min_ecc

  CONST
    pfc$selection_error_base = pfc$min_ecc + 4900,


    pfe$collection_limit_exceeded = pfc$selection_error_base + 9,
    {E Limit of +P1 concurrent collections per task exceeded.}

    pfe$get_next_at_eoi = pfc$selection_error_base + 23,
    {E PFP$GET_NEXT_FILE_SELECTION attempted, but the last selection record}
    { has already been gotten.}

    pfe$improper_selection_id = pfc$selection_error_base + 32,
    {E Improper selection_id parameter specified.}

    pfe$no_records_collected = pfc$selection_error_base + 51,
    {W There was no information of the selected type(s) in the catalog.}

    pfe$null_file_selections = pfc$selection_error_base + 53;
    {E Null set specified for file_selections parameter.}

?? OLDTITLE ??
?? FMT (FORMAT := ON) ??
*DECK DECK=PFH$ATTACH EXPAND=FALSE
{
{   The purpose of this request is to attach a permanent file to a job for its
{ use.  A local file name, to be used for all references to the file by the
{ attaching job, is also assigned.  All input/output operations made within the
{ attaching job will be directly from/to the file.
{
{   Access control information is retrieved from the catalogs identified by the
{ path parameter and is used to validate that the user may access the file as
{ requested.  The usage and share selections are verified to ensure that the
{ request does not conflict with current file usage.  NOS/VE allows file
{ sharing among jobs as well as multiple attaches within a job under different
{ local file names as long as no sharing conflicts occur.  This request
{ provides an option to place the requestor into a wait state if the file is
{ unavailable.  The requesting task will remain in the wait state until the
{ attach operation can be completed as requested.  An abort of a waiting task
{ (e.g.  due to an operator termination) will cause termination of the wait
{ state.  Other requests to attach the file that don't conflict with current
{ file usage will be allowed even though a task is waiting for the file.
{
{   If the data for the cycle has been duplicated on archive media and released
{ from mass storage, PFP$RETRIEVE_ARCHIVED_FILE is called to retrieve the data.
{ The task then waits until the retrieval completes before attempting to
{ reattach the file.
{
{       PFP$ATTACH (LFN, PATH, CYCLE_SELECTOR, PASSWORD, USAGE_SELECTIONS,
{         SHARE_SELECTIONS, WAIT, STATUS)
{
{ LFN: (input)  This parameter specifies the local file name to be used within
{       the job to reference the permanent file while attached.  If the lfn is
{       already in use by the job the request is terminated and an error status
{       is returned.
{
{ PATH: (input)  This parameter specifies the identification of the permanent
{       file.  The path parameter consists of an array of names which identify
{       the path leading through a catalog hierarchy to the desired file.  The
{       first two names specify the family name and master catalog name portion
{       of the path.  By convention, the name of a user's master catalog is the
{       same as the user name.  Subsequent names would specify subcatalogs as
{       applicable.  The last name in the path specifies the permanent file
{       that is to be attached.  Null names are allowed only for the family
{       name and master catalog name.  If the family name is OSC$NULL_NAME, the
{       family name of the job making the request will be used.  If the master
{       catalog name is OSC$NULL_NAME, the user name of the job making the
{       request will be used.
{
{ CYCLE_SELECTOR: (input)  This parameter selects the permanent file cycle that
{       is to be attached.  If PFC$LOWEST_CYCLE is specified, the lowest cycle
{       of the file will be attached.  If PFC$HIGHEST_CYCLE is specified, the
{       highest cycle of the file will be attached.  If a specific cycle is
{       specified, that cycle will be attached.
{
{ PASSWORD: (input)  This parameter specifies a password that must match the
{       password registered with the file.  If a blank password is specified,
{       it will only match if no password was registered with the file.
{
{ USAGE_SELECTIONS: (input)  This parameter specifies how the requestor would
{       like to be able to use the file.
{
{ SHARE_SELECTIONS: (input)  This parameter specifies how the requestor is
{       willing to share the file with other requestors.
{
{ WAIT: (input)  This parameter specifies the action to be taken if the
{       permanent file is not available.  If PFC$NO_WAIT is specified, the
{       request will not be performed and an immediate return to the requestor
{       will be made.  If PFC$WAIT is specified, the requestor will be held up
{       until the file is available, at which time the request will be
{       performed and a return to the requestor will be made.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: pfe$bad_cycle_number
{                   pfe$bad_cycle_option
{                   pfe$bad_family_name
{                   pfe$bad_last_subcatalog_name
{                   pfe$bad_local_file_name
{                   pfe$bad_master_catalog_name
{                   pfe$bad_nth_subcatalog_name
{                   pfe$bad_password
{                   pfe$bad_permanent_file_name
{                   pfe$bad_wait_option
{                   pfe$catalog_full
{                   pfe$cycle_busy
{                   pfe$cycles_media_missing
{                   pfe$incorrect_password
{                   pfe$invalid_ring_access
{                   pfe$lfn_in_use
{                   pfe$name_not_permanent_file
{                   pfe$nth_name_not_subcatalog
{                   pfe$path_too_short
{                   pfe$pf_system_error
{                   pfe$respf_modification_mismatch
{                   pfe$sharing_not_permitted
{                   pfe$undefined_data
{                   pfe$unknown_cycle
{                   pfe$unknown_family
{                   pfe$unknown_last_subcatalog
{                   pfe$unknown_master_catalog
{                   pfe$unknown_nth_subcatalog
{                   pfe$unknown_permanent_file
{                   pfe$usage_not_permitted
{
*DECK DECK=PFH$BEGIN_SYSTEM_AUTHORITY EXPAND=FALSE
{
{       PFP$BEGIN_SYSTEM_AUTHORITY
{
{   The purpose of this request is to request that the task be given system
{ authority to manipulate catalogs and files belonging to the $system user.
{   This request will remain in effect until either a corresponding call to
{ pfp$end_system_authority or a call to pfp$clear_system_authority is made by
{ the task.
{   If this request is called from above ring 3, it will cause the task to
{ abort.
{   This request has no parameters.
{
{       PFP$BEGIN_SYSTEM_AUTHORITY
{
*DECK DECK=PFH$BUILD_SORTED_DFL EXPAND=FALSE
{
{   The purpose of this request is to build a device manager sorted device
{ file list for use by subsequent pfp$put_catalog_media_info and
{ pfp$put_file_media_info calls.  This request is only provided for internal
{ use by the restore_permanent_file utility and is only available to the
{ system administrator.  Only one current sorted device file list may be
{ maintained in the job at a time.  The sorted device file list may be
{ released via pfp$release_sorted_dfl.
{
{       PFP$BUILD_SORTED_DFL (STATUS)
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{             pfe$not_system_administrator
{             pfe$restore_missing_cat_limit
{
*DECK DECK=PFH$CHANGE EXPAND=FALSE
{
{   The purpose of this request is to alter the permanent file name, cycle
{ number, password, log selection, retention period and/or charge attributes
{ associated with a permanent file.  The permanent file name, password, log
{ selection and charge identifications are attributes which are common to all
{ cycles of a permanent file.  The cycle number and retention period are
{ attributes which are unique for each cycle of a permanenet file.
{
{   This request can only be issued by a user with CONTROL permission.
{
{       PFP$CHANGE (PATH, CYCLE_SELECTOR, PASSWORD, CHANGE_LIST, STATUS)
{
{ PATH: (input) This parameter specifies the identification of the permanent
{       file.  The path parameter consists of an array of names which identify
{       the path leading through a catalog hierarchy to the desired file.  The
{       first two names specify the family name and master catalog name
{       portion of the path.  By convention, the name of a user's master
{       catalog is the same as the user name.  Subsequent names would specify
{       subcatalogs as applicable.  The last name specifies the permanent
{       file that is to be changed.  Null names are allowed only for the
{       family name and master catalog name.  If the family name is
{       OSC$NULL_NAME, the family name of the job making the request will
{       be used.  If the master catalog name is OSC$NULL_NAME, the user name
{       of the job making the request will be used.
{
{ CYCLE_SELECTOR: (input) This parameter selects the permanent file cycle that
{       is to be changed.  If PFC$LOWEST_CYCLE is specified, the lowest cycle
{       of the file will be changed.  If PFC$HIGHEST_CYCLE is specified, the
{       highest cycle of the file will be changed.  If a specific cycle is
{       specified, that cycle will be changed.  Cycle selection is only
{       applicable for changes to cycle related information such as cycle
{       number and retention period.
{
{ PASSWORD: (input) This parameter specifies a password that must match the
{       password registered with the file.  If a blank password is specified,
{       it will only match if no password was registered with the file.
{
{ CHANGE_LIST: (input) This parameter specifies an array of change
{       descriptors.  Each change descriptor specifies which attribute
{       is to be changed and what the new value of the attribute is to
{       be.  The attributes that can be changed are:  permanent file
{       name, password, cycle number, retention period, logging selection,
{       charge information and cycle damage conditions.
{       If a charge change is specified, the
{       account and project of the job making the request will be used as
{       the new ones to be charged for the file.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$bad_change_type
{                    pfe$bad_cycle_number
{                    pfe$bad_cycle_option
{                    pfe$bad_family_name
{                    pfe$bad_log_option
{                    pfe$bad_master_catalog_name
{                    pfe$bad_nth_subcatalog_name
{                    pfe$bad_password
{                    pfe$bad_permanent_file_name
{                    pfe$bad_permanent_file_name
{                    pfe$bad_retention_period
{                    pfe$catalog_full
{                    pfe$duplicate_cycle
{                    pfe$incorrect_damage_condition
{                    pfe$incorrect_password
{                    pfe$name_already_permanent_file
{                    pfe$name_already_subcatalog
{                    pfe$name_already_used
{                    pfe$name_not_permanent_file
{                    pfe$nth_name_not_subcatalog
{                    pfe$path_too_short
{                    pfe$pf_system_error
{                    pfe$unknown_cycle
{                    pfe$unknown_family
{                    pfe$unknown_master_catalog
{                    pfe$unknown_nth_subcatalog
{                    pfe$unknown_permanent_file
{                    pfe$usage_not_permitted
{
{        IDENTIFIER: pfc$permanent_file_manager_id
{
*DECK DECK=PFH$CHANGE_FAMILY_NAME EXPAND=FALSE
{
{   The purpose of this request is to change the name of a family in the
{ permanent file system.   This request may only be issued by the
{ set owner, the system administrator or the family administrator.  The family
{ specified by new_family_name must not already exist in the permanent file
{ system. This request should only be issued in an idle system, since it
{ will cause jobs not to recover in the event of a system failure.
{
{       PFP$CHANGE_FAMILY_NAME (SET_NAME, FAMILY_NAME, NEW_FAMILY_NAME, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set for which
{       the family is going to be changed.
{
{ FAMILY_NAME: (input) This parameter specifies the current name of the family.
{       If this parameter is all
{       blanks, the family name of the job making the request will be used.
{
{ NEW_FAMILY_NAME: (input) This parameter specifies the new name for the
{       family. If this parameter is all
{       blanks, the family name of the job making the request will be used.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{           pfe$bad_family_name
{           pfe$bad_set_name
{           pfe$duplicate_family_catalog
{           pfe$not_family_owner
{           pfe$pf_system_error
{           pfe$unknown_family
{           pfe$unknown_set
{
{       IDENTIFIER: pfc$permanent_file_manager_id
{
*DECK DECK=PFH$CHANGE_RES_TO_RELEASABLE EXPAND=FALSE
{
{    The purpose of this request is to change the residence of permanent file
{ cycle from 'offline' to 'releasable' after data for the cycle has been
{ successfully retrieved to mass storage.  The cycle only becomes available
{ when the residence has been changed to 'releasable'.  After an unsuccessful
{ retrieval, the residence remains 'offline' to prevent access to a partially
{ retrieved cycle which can occur as the result of an error while restoring the
{ data.
{
{       PFP$CHANGE_RES_TO_RELEASABLE (PATH, CYCLE_SELECTOR, PASSWORD, STATUS)
{
{ PATH: (input)  This parameter specifies the identification of the permanent
{       file.  The path parameter consists of an array of names which identify
{       the path leading through a catalog hierarchy to the desired file.  The
{       first two names specify the family name and master catalog name portion
{       of the path.  By convention, the name of a user's master catalog is the
{       same as the user name.  Subsequent names would specify subcatalogs as
{       applicable.  The last name specifies the permanent file that is to be
{       purged.  Null names are allowed only for the family name and master
{       catalog name.  If the family name is OSC$NULL_NAME, the family name of
{       the job making the request will be used.  If the master catalog name is
{       OSC$NULL_NAME, the user name of the job making the request will be
{       used.
{
{ CYCLE_SELECTOR: (input)  This parameter selects the permanent file cycle for
{       which the residence is to be changed.  If PFC$LOWEST_CYCLE is
{       specified, the residence of the lowest cycle of the file will be
{       changed to releasable.  If PFC$HIGHEST_CYCLE is specified, the highest
{       cycle of the file will be changed to releasable.  If a specific cycle
{       is specified, that cycle will be changed to releasable
{
{ PASSWORD: (input)  This parameter specifies a password that must match the
{       password registered with the file.  If a blank password is specified,
{       it will only match if no password was registered with the file.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDTIONS:  pfe$bad_cycle_number
{                    pfe$bad_cycle_option
{                    pfe$bad_family_name
{                    pfe$bad_master_catalog_name
{                    pfe$bad_nth_subcatalog_name
{                    pfe$bad_password
{                    pfe$bad_permanent_file_name
{                    pfe$data_not_immediate_released
{                    pfe$data_not_releasable
{                    pfe$incorrect_password
{                    pfe$invalid_ring_access
{                    pfe$name_not_permanent_file
{                    pfe$nth_name_not_subcatalog
{                    pfe$path_too_short
{                    pfe$pf_system_error
{                    pfe$unknown_cycle
{                    pfe$unknown_family
{                    pfe$unknown_master_catalog
{                    pfe$unknown_nth_subcatalog
{                    pfe$unknown_permanent_file
{                    pfe$usage_not_permitted
{
*DECK DECK=PFH$CHOOSE_RELEVANT_CYCLES EXPAND=FALSE
{
{   The purpose of this procedure is to choose the cycles in a cycle array
{ which should be restored based on various criteria.
{
{   Each element of an array of booleans is set to TRUE or FALSE based on
{ checks made against the corresponding element of the cycle array.  One set
{ of criteria is the date/time criteria established by the INCLUDE_CYCLES
{ subcommand of the RESTORE_PERMANENT_FILES utility and passed to this routine.
{ Another criterion is whether archive information should be restored.
{
{       PFP$CHOOSE_RELEVANT_CYCLES (P_FILE_INFO_RECORD, P_CYCLE_ARRAY,
{             SELECTION_CRITERIA, RESTORE_ARCHIVE_INFORMATION, P_CHOSEN_CYCLES,
{             CHOSEN_CYCLES_COUNT, STATUS)
{
{ P_FILE_INFO_RECORD: (input) This parameter specifies an info record
{       containing information about the file whose cycles are to be restored.
{
{ P_CYCLE_ARRAY: (input) This parameter specifies the cycle array from which
{       the cycles to be restored are chosen.
{
{ SELECTION_CRITERIA: (input) This parameter specifies a date/time selection
{       criteria record as defined in RESTORE_PERMANENT_FILES by the
{       INCLUDE_CYCLES subcommand.
{
{ RESTORE_ARCHIVE_INFORMATION: (input) This parameter specifies whether or not
{       archive information is to be restored.  When its value is FALSE, cycles
{       which have archive information but no data to restore will not be
{       chosen.
{
{ P_CHOSEN_CYCLES: (output) This parameter specifies an array of booleans with
{       the same dimensions as P_CYCLE_ARRAY.  Each array element indicates
{       whether or not the corresponding cycle was chosen to be restored.
{
{ CHOSEN_CYCLES_COUNT: (output) This parameter specifies the number of cycles
{       chosen to be restored.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS:
{             pfe$bad_info_record_format
{             pfe$info_offset_range_error
{             pfe$invalid_or_unusable_pva
{             pfe$nil_pointer
{             pfe$unknown_info_record
{
*DECK DECK=PFH$CLEAR_SYSTEM_AUTHORITY EXPAND=FALSE
{
{       PFP$CLEAR_SYSTEM_AUTHORITY
{
{   The purpose of this request is to undo the effect of all previous calls to
{ pfp$begin_system_authority within the task.
{   If this request is called from above ring 3, it will cause the task to
{ abort.
{   This request has no parameters.
{
{       PFP$CLEAR_SYSTEM_AUTHORITY
{
*DECK DECK=PFH$COLLECT_FILE_INFORMATION EXPAND=FALSE
{       PFP$COLLECT_FILE_INFORMATION
{
{
{   The purpose of this request is to collect information about files and
{ sub-catalogs that appear in a catalog.  This request selects what
{ information to collect.  After collecting the information, the user enters
{ a PFP$GET_NEXT_FILE_SELECTION request to extract the collected information.
{   Information will only be collected for one level of catalog.  Repeated
{ calls to pfp$collect_file_information must be made to traverse the catalog
{ structure.
{
{       PFP$COLLECT_FILE_INFORMATION (PATH, FILE_SELECTIONS, SELECTION_ID,
{                                     STATUS)
{
{ PATH: (input) This parameter specifies the identification of a catalog.
{       The path parameter consists of an array of names which identify the
{       path in the catalog hierarchy to the desired catalog.  The first name
{       specifies the family name.  The second name specifies the master
{       catalog name.  By convention the name of a user's master catalog
{       name is the same as the user name.  Subsequent names specify any
{       additional sub-catalogs.  The last name in the path specifies the
{       catalog to which the file selections will apply.  Null names are
{       allowed only for the family name and the master catalog name.  If the
{       family name is OSC$NULL_NAME, the family name of the job making the
{       request will be used.  If the master catalog name is OSC$NULL_NAME,
{       the user name of the job making the request will be used.
{
{ FILE_SELECTIONS: (input) This parameter specifies what information is to be
{       collected.  If there is no information of the selected type(s) in the
{       catalog, the error pfe$no_records_collected will be returned.  The
{       following selections are available:
{
{           Selection            Meaning
{
{           pfc$catalog_names    Collect sub-catalog names.
{           pfc$file_names       Collect file names.
{           pfc$file_cycles      Collect file names and cycle numbers.
{
{ SELECTION_ID: (output) This parameter returns the identifier assigned to
{       this instance of the pfp$collect_file_information request.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: pfe$collection_limit_exceeded
{                   pfe$no_records_collected
{                   pfe$null_file_selections
{
{       IDENTIFIER: pfc$permanent_file_manager_id
{
*DECK DECK=PFH$CONVERT_FS_PATH_TO_PF_PATH EXPAND=FALSE
{
{    This request is used to convert an fst$path to a pft$path.  It also
{ converts an fst$cycle_reference to a clt$cycle_selector.  The results are
{ intended for use as input to a PF request.
{
{       PFP$CONVERT_FS_PATH_TO_PF_PATH (FS_PATH_STRING, CYCLE_REFERENCE,
{             PF_PATH, CYCLE_SELECTOR, STATUS)
{
{ FS_PATH_STRING: (input)  This parameter specifies the path to be converted.
{       It MUST have been obtained via the pfp$convert_string_to_fs_path
{       request.
{
{ CYCLE_REFERENCE: (input)  This parameter specifies the cycle reference to be
{       converted.
{
{ PF_PATH: (input, output)  This parameter specifies the resulting path.  The
{       caller must first push this array, utilizing the
{       NUMBER_OF_PATH_ELEMENTS obtained from a previous call to
{       pfp$convert_string_to_fs_path.
{
{ CYCLE_SELECTOR: (output)  This parameter specifies the resulting cycle
{       selector.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=PFH$CONVERT_STRING_TO_FS_PATH EXPAND=FALSE
{
{    This request is used to convert a string to the appropriate components
{ required to obtain a pft$path via the pfp$convert_fs_path_to_pf_path request.
{
{       PFP$CONVERT_STRING_TO_FS_PATH (STR, FS_PATH_STRING,
{             NUMBER_OF_PATH_ELEMENTS, CYCLE_REFERENCE, OPEN_POSITION, STATUS)
{
{ STR: (input)  This parameter specifies the string, representing a file
{       expression, to be converted.
{
{ FS_PATH_STRING: (output)  This parameter specifies the resulting path in a
{       form recognizable by pfp$convert_fs_path_to_pf_path.  This format is
{       NOT directly usable for any other purposes.
{
{ NUMBER_OF_PATH_ELEMENTS: (output)  This parameter specifies the number of
{       path elements of the file reference.
{
{ CYCLE_REFERENCE: (output)  This parameter specifies the cycle reference for
{       the file reference.
{
{ OPEN_POSITION: (output)  This parameter specifies the open position of the
{       file reference.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=PFH$DEFINE EXPAND=FALSE
{
{   The purpose of this request is to establish a new empty permanent
{ file.  As a result of this function, the permanent file is registered
{ in the specified user's catalog.
{
{   The file can be the initial cycle or an additional cycle of the
{ specified permanent file.  Only a user with CYCLE permission to a
{ file may add cycles to the file.  Only a user with CYCLE permission
{ to the catalog in which a new file is registered can create the initial
{ cycle of a permanent file.
{
{   This request records the file name, password and log selections
{ in a catalog entry when defining the initial file cycle.  These
{ attributes are the same for all cycles of the permanent file.
{ This request also creates a cycle descriptor in the catalog entry
{ that contains the cycle number, creation date and expiration
{ date associated with the new file cycle.
{
{   The permanent file name and cycle must be a unique identifier
{ relative to the catalog in which it is registered.  Otherwise
{ the request is terminated and an error is returned.
{
{   In addition to registering the new file in a catalog this request
{ attaches the file for access within the requesting job.  The usage
{ and share selections associated with this attachment allow ALL usage
{ and no sharing.
{
{       PFP$DEFINE (LFN, PATH, CYCLE_SELECTOR, PASSWORD, RETENTION, LOG, STATUS)
{
{ LFN: (input) This parameter specifies a local file name.  The new
{       empty permanent file cycle is left attached for access within the
{       job via this local file name.  If this lfn is already assigned
{       by the job the request is terminated and an error status is returned.
{       A blank name is not allowed.
{
{ PATH: (input) This parameter specifies the identification of a permanent
{       file.  The path parameter consists of an array of names which
{       identify the path leading through a catalog hierarchy.  The first
{       two names specify the family name and master catalog name portion
{       of the path.  By convention, the name of a user's master catalog
{       is the same as the user name.  Subsequent names would specify
{       subcatalogs as applicable.  The last name in the path specifies the
{       permanent file being defined or to which a new cycle is to be added.
{       Null names are allowed only for the family name and master catalog
{       name.  If the family name is OSC$NULL_NAME, the family name of the
{       job making the request will be used.  If the master catalog name is
{       OSC$NULL_NAME, the user name of the job making the request will be
{       used.
{
{ CYCLE_SELECTOR: (input) This parameter selects the permanent file cycle that
{       is to be defined.  If PFC$LOWEST_CYCLE is specified, a cycle one less
{       than the current lowest cycle will be defined.  If PFC$HIGHEST_CYCLE
{       is specified, a cycle one greater than the current highest cycle will
{       be defined.  If a specific cycle is specified, that cycle will be
{       defined.  If the specific cycle already exists, an error will be
{       returned.  If the file does not exist, both PFC$LOWEST_CYCLE and
{       PFC$HIGHEST_CYCLE will cause cycle one to be created.
{
{ PASSWORD: (input) If the permanent file does not already exist, this
{       parameter specifies a password to be registered with the file.  A
{       blank password specifies that no password is to be registered.  If
{       the permanent file  does already exist, this parameter specifies a
{       password that must match the password registered with the file.  If
{       a blank password is specified, it will only match if no password
{       was registered with the file.
{
{ RETENTION: (input) This parameter specifies the number of days (1-999) from
{       the current date that the file is to be retained.  999 indicates an
{       infinite retention period.  This parameter is used to determine an
{       expiration date for the file cycle.
{
{ LOG: (input) This parameter specifies if the system should record the
{       identification of each user that accesses the file, the number of
{       accesses for each type of usage (read, shorten, append, modify,
{       and execute) and the date and time of the last access.  This
{       parameter will be ignored if the file already exists and a new
{       cycle is merely being added.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$bad_cycle_number
{                    pfe$bad_cycle_option
{                    pfe$bad_family_name
{                    pfe$bad_local_file_name
{                    pfe$bad_log_option
{                    pfe$bad_master_catalog_name
{                    pfe$bad_nth_subcatalog_name
{                    pfe$bad_password
{                    pfe$bad_permanent_file_name
{                    pfe$bad_retention_period
{                    pfe$catalog_full
{                    pfe$cycle_overflow
{                    pfe$cycle_underflow
{                    pfe$duplicate_cycle
{                    pfe$incorrect_password
{                    pfe$lfn_in_use
{                    pfe$name_already_subcatalog
{                    pfe$nth_name_not_subcatalog
{                    pfe$path_too_short
{                    pfe$pf_system_error
{                    pfe$unknown_family
{                    pfe$unknown_master_catalog
{                    pfe$unknown_nth_subcatalog
{                    pfe$usage_not_permitted
{
{        IDENTIFIER: pfc$permanent_file_manager_id
*DECK DECK=PFH$DEFINE_CATALOG EXPAND=FALSE
{       PFP$DEFINE_CATALOG
{
{   The purpose of this request is to create a new empty subcatalog.  The name
{ of the new subcatalog is identified by the last name of the path parameter.
{ The new subcatalog is registered in the catalog identified by the remainder
{ of the path parameter.
{
{   This request only allows subcatalogs to be registered in a catalog owned
{ by the user making the request.  In addition, this request does not allow
{ creation of master catalogs.  Master catalogs are created as a function of
{ the administer utility.
{
{ PFP$DEFINE_CATALOG (PATH, STATUS)
{
{ PATH: (input) This parameter specifies the identification of a subcatalog.
{       The path parameter consists of an array of names which identify the
{       path leading through a catalog hierarchy to the desired subcatalog.
{       The first two names specify the family name and master catalog name
{       portion of the path.  By convention, the name of a user's master
{       catalog is the same as the user name.  Subsequent names would specify
{       subcatalogs as applicable.  The last name in the path specifies the
{       new subcatalog that is to be created.  Null names are allowed only
{       for the family name and master catalog name.  If the family name is
{       OSC$NULL_NAME, the family name of the job making the request will be
{       used.  If the master catalog name is OSC$NULL_NAME, the user name of
{       the job making the request will be used.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: pfe$bad_family_name
{                   pfe$bad_last_subcatalog_name
{                   pfe$bad_master_catalog_name
{                   pfe$bad_nth_subcatalog_name
{                   pfe$name_already_permanent_file
{                   pfe$name_already_subcatalog
{                   pfe$not_master_catalog_owner
{                   pfe$nth_name_not_subcatalog
{                   pfe$path_too_short
{                   pfe$pf_system_error
{                   pfe$too_many_catalogs_in_path
{                   pfe$unknown_family
{                   pfe$unknown_master_catalog
{                   pfe$unknown_nth_subcatalog
{
{       IDENTIFIER: pfc$permanent_file_manager_id
{
*DECK DECK=PFH$DEFINE_DATA EXPAND=FALSE
{
{   The purpose of this request is to define data for an existing permanent
{ file cycle.  The cycle must not already have data defined for it, or an error
{ condition will be returned.  File cycles with undefined data are created
{ using put_info requests.  This request does not update the file log.
{
{   A user must have CYCLE permission to the file or an error condition will be
{ returned.  The cycle created by this request is left attached with the
{ specified local file name.  The usage and share selections associated with
{ this attachment allow ALL usage and no sharing.
{
{       PFP$DEFINE_DATA (LFN, PATH, CYCLE_SELECTOR, UPDATE_CYCLE_STATISTICS,
{         PASSWORD_SELECTOR, P_MASS_STORAGE_REQUEST_INFO, P_VOLUME_LIST,
{         RESTORE_SELECTIONS, WAIT_ON_VOLUME, MANDATED_MODIFICATION_TIME,
{         DATA_RESIDENCE, STATUS)
{
{ LFN: (input)  This parameter specifies a local file name.  The new empty
{       permanent file cycle is left attached for access within the job via
{       this local file name.  If this lfn is already assigned by the job, an
{       error condition will be returned.  A blank name is not allowed.
{
{ PATH: (input)  This parameter specifies the identification of a permanent
{       file.  The path parameter consists of an array of names which identify
{       the path leading through a catalog hierarchy.  The first two names
{       specify the family name and master catalog name portion of the path.
{       By convention, the name of a user's master catalog is the same as the
{       user name.  Subsequent names would specify subcatalogs as applicable.
{       The last name in the path specifies the parmanent file for which cycle
{       data is to be defined.  Null names are allowed only for the family name
{       and master catalog name.  If the family name is OSC$NULL_NAME, the
{       family name of the job making the request will be used.  If the master
{       catalog name is OSC$NULL_NAME, the user name of the job making the
{       request will be used.
{
{ CYCLE_SELECTOR: (input)  this parameter selects the permanent file cycle for
{       which data is to be defined.  If the cycle does not exist, an error
{       condition will be returned.
{
{ UPDATE_CYCLE_STATISTICS: (input)  This parameter tells the permanent file
{       manager whether the cycles access date, and modification date and time
{       should be updated with the current time when the cycle is detached.
{       The cycles creation date and time and file log are not changed.
{
{ PASSWORD_SELECTOR: (input)  This parameter specifies a password that must
{       match the password registered with the file.  If
{       pfc$default_password_option is specified, it will only match for the
{       system or family administrator, or file owner, or for the non-owner if
{       no password is registered with the file.  If
{       pfc$specific_password_option is selected, the supplied password must
{       match the password registered with the file.
{
{ P_MASS_STORAGE_REQUEST_INFO: (input)  This parameter specifies additional
{       information used to assign the file to a particular mass storage device
{       with particular attributes.  A NIL pointer indicates no
{       mass_storage_request_info is supplied.  The fields of this data
{       structure are described below:
{
{       ALLOCATION_SIZE:  This field specifies the amount of contiguous mass
{             storage space, in bytes, which is to be allocated to the file
{             each time additional space is needed.
{
{   The value rmc$unspecified_allocation_size will cause the allocation size to
{ be determined by the ESTIMATED_FILE_SIZE field.
{
{       ESTIMATED_FILE_SIZE:  This field specifies the likely size of the file
{             in bytes.  This information is used to select the allocation size
{             which would minimize the amount of mass storage space assigned to
{             the file should it ultimately reach the estimated size.
{
{   The value rmc$unspecified_file_size will cause the allocation size to be
{ determined by the ALLOCATION_SIZE field.
{
{       FILE_CLASS:  This field specifies the class of the file which is to be
{             assigned.  NOS/VE supports up to 26 classes of files.  Each class
{             is identified by an alphabetic character (upper and lower cases
{             are equivalent).  NOS/VE will select a volume which belongs to
{             the class specified by this parameter; abnormal status will be
{             returned if no candidate volume belongs to the specified class.
{
{   The value rmc$unspecified_file_class will cause the candidate volume to be
{ selected independently of file class.  Specification of any non-alphabetic
{ character will cause abnormal status to be returned.
{
{       INITIAL_VOLUME:  This field specifies the identification of a specific
{             mass storage volume to which this file is to be assigned.  If
{             this volume is not affiliated with the FILE_CLASS specified, the
{             volume is full, or the volume does not exist in the active
{             configuration, this request will be rejected.  If volume overflow
{             is not allowed, the entire file will reside on this volume;
{             otherwise, this volume will be the initial volume assigned to the
{             file.  Refer to the VOLUME_OVERFLOW_ALLOWED field.
{
{   The value rmc$unspecified_vsn will cause the consideration of all candidate
{ volumes.
{
{       VOLUME_OVERFLOW_ALLOWED:  This field specifies whether or not the file
{             can be assigned to more than one volume.  If TRUE is specified,
{             the file may span any volume subject to validation and FILE_CLASS
{             constraints.  If FALSE is specified, the file will be confined to
{             the initial volume to which it is assigned.
{
{   Specification of FALSE is permitted only in a job which has system
{ administrative privilege or maintenance privilege.
{
{ P_VOLUME_LIST: (input)  This parameter specifies a list of VSN's of mass
{       storage volumes on which the file is to reside.
{
{ RESTORE_SELECTIONS: (input)  This parameter specifies the set of conditions
{       which must be present in order to restore data for a file cycle.
{
{ WAIT_ON_VOLUME: (input)  This parameter specifies whether to wait when a
{       volume is unavailable, off-line, disabled, unknown, or inactive, when
{       the server is inactive, or when there isn't enough space.
{
{ MANDATED_MODIFICATION_TIME: (input, output)  This parameter specifies whether
{       the modification date stored with the cycle must match a specified
{       value.  pfc$no_verify_modification_time - The specified modification
{       time field need not be set.  The data is restored, and the modification
{       time in the catalog is retained.  pfc$verify_modification_time - The
{       data is only defined if the specified modification time agrees with the
{       stored time.  pfc$replace_modification_time - The data is defined and,
{       if the specified modification time is not equal to the time already
{       stored in the catalog, the cycle damage symptom of
{       fsc$respf_modification_mismatch is set, and the specified time is
{       stored.
{
{ DATA_RESIDENCE: (output)  This parameter returns the data residence of the
{       file cycle prior to the restore of the cycle's data.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: dfe$server_not_active
{                   pfe$bad_cycle_number
{                   pfe$bad_cycle_option
{                   pfe$bad_family_name
{                   pfe$bad_last_subcatalog_name
{                   pfe$bad_local_file_name
{                   pfe$bad_master_catalog_name
{                   pfe$bad_nth_subcatalog_name
{                   pfe$bad_password
{                   pfe$bad_permanent_file_name
{                   pfe$catalog_full
{                   pfe$catalog_volume_not_online
{                   pfe$catalog_volume_unavailable
{                   pfe$data_already_defined
{                   pfe$incorrect_password
{                   pfe$lfn_in_use
{                   pfe$modification_time_mismatch
{                   pfe$name_not_permanent_file
{                   pfe$nth_name_not_subcatalog
{                   pfe$path_too_short
{                   pfe$pf_system_error
{                   pfe$restore_not_selected
{                   pfe$unknown_cycle
{                   pfe$unknown_family
{                   pfe$unknown_last_subcatalog
{                   pfe$unknown_master_catalog
{                   pfe$unknown_nth_subcatalog
{                   pfe$unknown_permanent_file
{                   pfe$usage_not_permitted
{                   pfe$volume_not_online
{                   pfe$volume_unavailable
{                   rme$file_class_not_valid
{                   rme$vsn_not_part_of_set
{
*DECK DECK=PFH$DEFINE_MASS_STORAGE_CATALOG EXPAND=FALSE
{
{   The purpose of this request is to create a new empty subcatalog.  This
{ request is only provided for fault tolerance testing; normal users should
{ use the PFP$DEFINE_CATALOG program interface.  This procedure differs from
{ PFP$DEFINE_CATALOG by allowing the caller to specify device characteristics
{ of the mass storage catalog being created.  Callers should refer to the
{ RMP$REQUEST_MASS_STORAGE procedure for a description of the mass storage
{ parameters.  Callers may also make the new catalog an internal catalog, in which
{ case no new physical catalog is created and the other mass storage attribute
{ parameters are not used.  If, the catalog is internal, it is contained
{ physically within its parent's physical catalog.
{
{       PFP$DEFINE_MASS_STORAGE_CATALOG (PATH, CATALOG_TYPE, ALLOCATION_SIZE,
{             P_MASS_STORAGE_REQUEST_INFO, STATUS)
{
{ PATH: (input) This parameter specifies the identification of the subcatalog.
{
{ CATALOG_TYPE:(input) This parameter specifies whether the new catalog will
{       reside in a separate device manager file or be contained within the
{       parent catalog.
{
{ P_MASS_STORAGE_REQUEST_INFO: (input) This parameter specifies the mass
{       storage attributes used when creating the catalog.  Refer to
{       RMP$VALIDATE_MASS_STORAGE_INFO for a description of this parameter.
{
{ STATUS: (output) This parameter returns the request status.
{
{     CONDITIONS:
{           pfe$too_many_catalogs_in_path
{
*DECK DECK=PFH$DEFINE_MASTER_CATALOG EXPAND=FALSE
{   The purpose of this request is to create an empty master catalog for the
{ specified family on the specified set.  This request may only be issued by a
{ system administrator or the owner of the set upon which the master catalog
{ is created.
{
{       PFP$DEFINE_MASTER_CATALOG (SET_NAME, FAMILY_NAME, MASTER_CATALOG_NAME,
{                                    CHARGE_ID, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set on which the
{       master catalog is to be created.  A blank name is not allowed.
{
{ FAMILY_NAME: (input) This parameter specifies the name of the family for
{       which a master catalog is to be created.  If this parameter is all
{       blanks, the family name of the job making the request will be used.
{
{ MASTER_CATALOG_NAME: (input) This parameter specifies the name of the
{       master catalog that is to be created.  Be convention, the name of
{       a user's master catalog is the same as the user name.  If this
{       parameter is all blanks, the user name of the job making the request
{       will be used.
{
{ CHARGE_ID: (input) This parameter specifies an account name and project name
{       to be associated with the master catalog.  This charge_id will be used
{       as the charge_id for any files that may be created in the master
{       catalog by a user other than the owner of the master catalog.   If the
{       account field of this parameter is all blanks, the account name of the
{       job making the request will be used.  If the project field of this
{       parameter is all blanks, the project name of the job making the request
{       will be used.
{
{ STATUS: (output) This parameter specifies the request status.
{
{        CONDITIONS: pfe$pf_system_error
{                    pfe$bad_account_name
{                    pfe$bad_project_name
{                    pfe$bad_set_name
{                    pfe$bad_family_name
{                    pfe$bad_master_catalog_name
{                    pfe$unknown_set
{                    pfe$duplicate_master_catalog
{                    pfe$not_family_owner
{
{        IDENTIFIER: pfc$permanent_file_manager_id
{
*DECK DECK=PFH$DELETE_ALL_ARCHIVE_ENTRIES EXPAND=FALSE
{
{   The purpose of this request is to delete all archive entries for the
{ specified file cycle.
{
{       PFP$DELETE_ALL_ARCHIVE_ENTRIES (PATH, CYCLE_SELECTOR, STATUS)
{
{ PATH: (input)  This parameter specifies the identification of a file for
{       which all archive entries are to be deleted.  The path parameter
{       consists of an array of names which identify the path leading through a
{       catalog hierarchy to the desired file.  The first two names specify the
{       family name and master catalog name portion of the path.  By
{       convention, the name of a user's master catalog is the same as the user
{       name.  Subsequent names would specify subcatalogs as applicable.  The
{       last name in the path specifies the file for which all archive entries
{       are to be deleted.  Null names are allowed only for the family name and
{       master catalog name.  If the family name is osc$null_name, the family
{       name of the job making the request will be used.  If the master catalog
{       name is osc$null_name, the user name of the job making the request will
{       be used.  The file must already exist.
{
{ CYCLE_SELECTOR: (input)  This parameter selects the permanent file cycle for
{       which all archive entries are to be deleted.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$bad_cycle_number
{                    pfe$bad_cycle_option
{                    pfe$bad_family_name
{                    pfe$bad_last_subcatalog_name
{                    pfe$bad_master_catalog_name
{                    pfe$bad_nth_subcatalog_name
{                    pfe$bad_permanent_file_name
{                    pfe$name_not_permanent_file
{                    pfe$nth_name_not_subcatalog
{                    pfe$path_too_short
{                    pfe$pf_system_error
{                    pfe$unknown_archive_info
{                    pfe$unknown_cycle
{                    pfe$unknown_family
{                    pfe$unknown_last_subcatalog
{                    pfe$unknown_master_catalog
{                    pfe$unknown_nth_subcatalog
{                    pfe$unknown_permanent_file
{
*DECK DECK=PFH$DELETE_ARCHIVE_ENTRY EXPAND=FALSE
{
{   The purpose of this request is to delete the first archive entry in a file
{ cycle's archive list which has an archive identification which matches the
{ archive identification specified by the ARCHIVE_IDENTIFICATION parameter.
{
{       PFP$DELETE_ARCHIVE_ENTRY (PATH, CYCLE_SELECTOR, ARCHIVE_IDENTIFICATION,
{         STATUS)
{
{ PATH: (input)  This parameter specifies the identification of a file for
{       which archive entries are to be deleted.  The path parameter consists
{       of an array of names which identify the path leading through a catalog
{       hierarchy to the desired file.  The first two names specify the family
{       name and master catalog name portion of the path.  By convention, the
{       name of a user's master catalog is the same as the user name.
{       Subsequent names would specify subcatalogs as applicable.  The last
{       name in the path specifies the file for which archive entries are to be
{       deleted.  Null names are allowed only for the family name and master
{       catalog name.  If the family name is osc$null_name, the family name of
{       the job making the request will be used.  If the master catalog name is
{       osc$null_name, the user name of the job making the request will be
{       used.  The file must already exist.
{
{ CYCLE_SELECTOR: (input)  This parameter selects the permanent file cycle for
{       which an archive entry is to be deleted.
{
{ ARCHIVE_IDENTIFICATION: (input)  This parameter specifies the identification
{       of the archiving application.  The identification consists of an
{       application identifier and a media identifier.  The application
{       identifier identifies the archiving application.  The media identifier
{       consists of a media device class and a media volume identifier.  The
{       entire archive identification is used to locate the archive entry which
{       is to be deleted.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$bad_archive_identification
{                    pfe$bad_cycle_number
{                    pfe$bad_cycle_option
{                    pfe$bad_family_name
{                    pfe$bad_last_subcatalog_name
{                    pfe$bad_master_catalog_name
{                    pfe$bad_nth_subcatalog_name
{                    pfe$bad_permanent_file_name
{                    pfe$invalid_archive_appl_name
{                    pfe$name_not_permanent_file
{                    pfe$nth_name_not_subcatalog
{                    pfe$path_too_short
{                    pfe$pf_system_error
{                    pfe$unknown_archive_application
{                    pfe$unknown_archive_ident
{                    pfe$unknown_family
{                    pfe$unknown_last_subcatalog
{                    pfe$unknown_master_catalog
{                    pfe$unknown_nth_subcatalog
{                    pfe$unknown_permanent_file
{
*DECK DECK=PFH$DELETE_CATALOG_PERMIT EXPAND=FALSE
{
{   The purpose of this request is to delete an access control entry that was
{ previously established for a catalog.  An access control entry can only be
{ deleted for a catalog belonging to the user making the request.
{
{       PFP$DELETE_CATALOG_PERMIT (PATH, GROUP, STATUS)
{
{ PATH: (input) This parameter specifies the identification of a catalog.  The
{       path parameter consists of an array of names which identify the path
{       leading through a catalog hierarchy to the desired catalog.  The first
{       two names specify the family name and master catalog name portion of
{       the path.  By convention, the name of a user's master catalog is the
{       same as the user name.  Subsequent names would specify subcatalogs as
{       applicable.  The last name in the path specifies the catalog for which
{       an access control entry is to be deleted.  Null names are allowed only
{       for the family name and master catalog name.  If the family name is
{       osc$null_name, the family name of the job making the request will be
{       used.  If the master catalog name is osc$null_name, the user name of
{       the job making the request will be used.
{
{ GROUP: (input) This parameter describes the user or group of users for whom
{       the access control entry is to be deleted.  The group can include all
{       users (public), all users of a particular family, all users of a
{       particular account, all users of a particular project, a specific user,
{       a specific user while running under a specific account, or a specific
{       user while running under a specific account and project.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS:
{             pfe$bad_account_name
{             pfe$bad_family_name
{             pfe$bad_group_type
{             pfe$bad_last_subcatalog_name
{             pfe$bad_master_catalog_name
{             pfe$bad_nth_subcatalog_name
{             pfe$bad_project_name
{             pfe$bad_user_name
{             pfe$last_name_not_subcatalog
{             pfe$no_permit_deleted
{             pfe$not_master_catalog_owner
{             pfe$nth_name_not_subcatalog
{             pfe$path_too_short
{             pfe$pf_system_error
{             pfe$unknown_family
{             pfe$unknown_last_subcatalog
{             pfe$unknown_master_catalog
{             pfe$unknown_nth_subcatalog
{
*DECK DECK=PFH$DELETE_CYCLE_DATA EXPAND=TRUE
{
{   The purpose of this request is to delete the data for a cycle while
{   preserving the file cycle entry.
{
{   Only a user with control access permission may delete a file cycle data.
{
{   If the file cycle is in use at the time the delete_cycle_data is requested,
{ the data will not be deleted.
{
{       PFP$DELETE_CYCLE_DATA (PATH, CYCLE_SELECTOR, PASSWORD, PURGE_CYCLE_OPTIONS, STATUS)
{
{ PATH: (input) This parameter specifies the identification of the permanent
{       file.  The path parameter consists of an array of names which identify
{       the path leading through a catalog hierarchy to the desired file.  The
{       first two names specify the family name and master catalog name
{       portion of the path.  By convention, the name of a user's master
{       catalog is the same as the user name.  Subsequent names would specify
{       subcatalogs as applicable.  The last name specifies the permanent file
{       whose data is to be deleted. Null names are allowed only for the family
{       name and master catalog name.  If the family name is osc$null_name,
{       the family name of the job making the request will be used.  If the
{       master catalog name is osc$null_name, the user name of the job making
{       the request will be used.
{
{ CYCLE_SELECTOR: (input) This parameter selects the permanent file cycle whose
{       data is to be deleted.
{
{ PASSWORD: (input) This parameter specifies a password that must match the
{       password registered with the file.  If a blank password is specified,
{       it will only match if no password was registered with the file.
{
{ PURGE_CYCLE_OPTIONS: (input) This parameter specifies whether the cycle entry
{       is to be preserved or not, and if to be preserved, also specifies other
{       attributes like label, archive entries and modification date time that
{       are to be preserved.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS:
{             ame$damaged_file_attributes
{             pfe$bad_cycle_number
{             pfe$bad_cycle_option
{             pfe$bad_family_name
{             pfe$bad_last_subcatalog_name
{             pfe$bad_master_catalog_name
{             pfe$bad_nth_subcatalog_name
{             pfe$bad_password
{             pfe$bad_permanent_file_name
{             pfe$incorrect_password
{             pfe$invalid_ring_access
{             pfe$last_name_not_subcatalog
{             pfe$name_not_permanent_file
{             pfe$nth_name_not_subcatalog
{             pfe$path_too_short
{             pfe$pf_system_error
{             pfe$unknown_cycle
{             pfe$unknown_family
{             pfe$unknown_last_subcatalog
{             pfe$unknown_master_catalog
{             pfe$unknown_nth_subcatalog
{             pfe$unknown_permanent_file
{             pfe$usage_not_permitted
{
*DECK DECK=PFH$DELETE_PERMIT EXPAND=FALSE
{
{   The purpose of this request is to delete an access control entry that was
{ previously established for a permanent file.  An access control entry can
{ only be deleted for a file belonging to the user making the request.
{
{       PFP$DELETE_PERMIT (PATH, GROUP, STATUS)
{
{ PATH: (input) This parameter specifies the identification of the permanent
{       file.  The path parameter consists of an array of names which identify
{       the path leading through a catalog hierarchy to the desired file.  The
{       first two names specify the family name and master catalog name portion
{       of the path.  By convention, the name of a user's master catalog is the
{       same as the user name.  Subsequent names would specify subcatalogs as
{       applicable.  The last name in the path specifies the permanent file for
{       which an access control entry is to be deleted.  Null names are allowed
{       only for the family name and master catalog name.  If the family name
{       is osc$null_name, the family name of the job making the request will be
{       used.  If the master catalog name is osc$null_name, the user name of
{       the job making the request will be used.
{
{ GROUP: (input) This parameter describes the user or group of users for whom
{       the access control entry is to be deleted.  The group can include all
{       users (public), all users of a particular family, all users of a
{       particular account, all users of a particular project, a specific user,
{       a specific user while running under a specific account, or a specific
{       user while running under a specific account and project.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS:
{             pfe$bad_account_name
{             pfe$bad_family_name
{             pfe$bad_group_type
{             pfe$bad_master_catalog_name
{             pfe$bad_nth_subcatalog_name
{             pfe$bad_permanent_file_name
{             pfe$bad_project_name
{             pfe$bad_user_name
{             pfe$name_not_permanent_file
{             pfe$no_permit_deleted
{             pfe$not_master_catalog_owner
{             pfe$nth_name_not_subcatalog
{             pfe$path_too_short
{             pfe$pf_system_error
{             pfe$unknown_family
{             pfe$unknown_master_catalog
{             pfe$unknown_nth_subcatalog
{             pfe$unknown_permanent_file
{
*DECK DECK=PFH$DETACH_JOBS_CATALOGS EXPAND=FALSE
{
{   The purpose of this request is to detach (in the device manager sense)
{ all catalogs queued within the job.  This request is only provided for
{ fault tolerance testing.  As a result of this request no catalogs are
{ queued, though additional catalog requests will cause catalogs to begin
{ being queued again.
{
{       PFP$DETACH_JOBS_CATALOGS
{
*DECK DECK=PFH$DETACH_RESERVED_CYCLES EXPAND=FALSE
{
{   The purpose of this procedure is to detach all cycles reserved
{ (i.e. attached) by a previous call to pfp$get_reserved_item_info.
{
{       PFP$DETACH_RESERVED_CYCLES (STATUS)
{
{ STATUS: (output) This parameter specifies the request status.
{
{       CONDITIONS:
{            pfe$last_name_not_subcatalog
{            pfe$not_system_administrator
{            pfe$nth_name_not_subcatalog
{            pfe$path_too_short
{            pfe$pf_system_error
{            pfe$unknown_family
{            pfe$unknown_last_subcatalog
{            pfe$unknown_master_catalog
{            pfe$unknown_nth_subcatalog
{
*DECK DECK=PFH$DM_ATTACH_ITEM EXPAND=TRUE
{ This interface is ONLY PROVIDED FOR FAULT TOLERANCE TESTING.
{   The purpuse of this request is to a  tell device manager to
{ attach a permanent file catalog, or cycle.  No update of the catalog
{ is made, nor is any validation of concurrent usage.  The file
{ is not left attached in the file manager or permanent file sense
{ only in the device manager sense.  This request is only available
{ to the system owner.  A file such attached, may only be returned
{ by the pfp$dm_return_file request. The catalog or file attached is not
{ open.  This request is only available on the mainframe where the
{ file resides, that is the request is not supported in the file server case.
{
{    PFP$DM_ATTACH_ITEM (PATH, CYCLE_SELECTOR, SFID, STATUS)
{
{ PATH: (input) This parameter specifies the path of the file or
{    catalog to attach.  If this path contains only the family name
{    the root catalog will be attached.
{
{ CYCLE_SELECTOR: (input) When the path parameter describes a permanent
{    file, this parameter is used to select the cycle to attach.
{
{ SFID: (Output) This parameter returns the device manager system file
{    identifier.
{
{ STATUS: (Output) This parameter returns the request status.
{

*DECK DECK=PFH$DM_RETURN_ITEM EXPAND=TRUE
{
{ THIS INTERFACE IS ONLY PROVIDED FOR FAULT TOLERANCE TESTING.
{   The purpose of this request is to return a file or catalog that was
{ previously attached by the PFP$DM_ATTACH_ITEM request.
{
{ PFP$DM_RETURN_ITEM  (SFID, STATUS)
{
{ SFID: (input) This parameter specifies the device manager system file id.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=PFH$END_SYSTEM_AUTHORITY EXPAND=FALSE
{
{       PFP$END_SYSTEM_AUTHORITY
{
{   The purpose of this request is to undo the effect of the most recent, and
{ only the most recent, call to pfp$begin_system_authority within the task.
{   If this request is called from above ring 3, it will cause the task to
{ abort.
{   This request has no parameters.
{
{       PFP$END_SYSTEM_AUTHORITY
{
*DECK DECK=PFH$FIND_ARCHIVE_INFO EXPAND=FALSE
{
{   The purpose of this request is to find the archive info record contained in
{ the cycle array for a file cycle.  The archive info record contains all of
{ the archive entries for the file cycle.
{
{       PFP$FIND_ARCHIVE_INFO (P_CYCLE_INFO_RECORD, P_INFO_RECORD, STATUS)
{
{ P_CYCLE_INFO_RECORD: (input)  This parameter specifies the cycle info record
{       in which the archive info record is to be found.
{
{ P_INFO_RECORD: (output)  This parameter returns the pointer to the archive
{       info record.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$bad_info_record_format
{                    pfe$invalid_or_unusable_pva
{                    pfe$nil_pointer
{                    pfe$unknown_archive_info
{
*DECK DECK=PFH$FIND_CATALOG_DESCRIPTION EXPAND=FALSE
{
{   The purpose of this request is to find a catalog description sub-record
{ within an info record and return a pointer to it.
{
{       PFP$FIND_CATALOG_DESCRIPTION (P_INFO_RECORD, P_CATALOG_DESCRIPTION,
{                                       STATUS)
{
{ P_INFO_RECORD: (input) This parameter specifies the info record in which
{       the catalog description sub-record is to be found.
{
{ P_CATALOG_DESCRIPTION: (output) This parameter returns a pointer to the
{       desired catalog description.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$unknown_catalog_description
{                    pfe$bad_info_record_format
{
*DECK DECK=PFH$FIND_CATALOG_MEDIA EXPAND=FALSE
{
{   The purpose of this request is to find a catalog media description
{ sub-record within an catalog group info record and return a pointer to it.
{ If the catalog is an external catalog, the pointer to the catalog fmd is
{ also returned.
{
{       PFP$FIND_CATALOG_MEDIA (P_CATALOG_GROUP_INFO_RECORD,
{             P_CATALOG_MEDIA_DESCRIPTION, P_CATALOG_FMD,  STATUS)
{
{ P_CATALOG_GROUP_INFO_RECORD: (input) This parameter specifies the info record
{       in which the catalog description sub-record is to be found.
{
{ P_CATALOG_MEDIA_DESCRIPTION: (output) This parameter returns a pointer to the
{       desired catalog media description.
{
{ P_CATALOG_FMD: (output) This parameter returns a pointer to the file media
{       descriptor for the catalog if the catalog is an external catalog.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS:
{            pfe$bad_info_record_format
{            pfe$unknown_catalog_media
{
*DECK DECK=PFH$FIND_CYCLE_ARRAY EXPAND=FALSE
{
{   The purpose of this request is to find a cycle array sub-record within
{ an info record and return a pointer to it.
{
{       PFP$FIND_CYCLE_ARRAY (P_INFO_RECORD, P_CYCLE_ARRAY, STATUS)
{
{ P_INFO_RECORD: (input) This parameter specifies the info record in which
{       the cycle array sub-record is to be found.
{
{ P_CYCLE_ARRAY: (output) This parameter returns a pointer to the desired
{       cycle array.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$unknown_cycle_array
{                    pfe$bad_info_record_format
{
*DECK DECK=PFH$FIND_CYCLE_ARRAY_EXTENDED EXPAND=FALSE
{
{   The purpose of this request is to find the cycle array extended info
{ record within the file group record.  This output is used as input to
{ the PFP$FIND_CYCLE_DIRECTORY procedure, and the body of this record may
{ be used with PFP$FIND_DIRECT_INFO_RECORD.
{
{      PFP$FIND_CYCLE_ARRAY_EXTENDED (P_FILE_GROUP_INFO_RECORD,
{            P_CYCLE_ARRAY_EXTENDED_RECORD, STATUS)
{
{ P_FILE_GROUP_INFO_RECORD: (input) This parameter specifies the info record
{       in which to search.
{
{ P_CYCLE_ARRAY_EXTENDED_RECORD: (output) This parameter returns the pointer
{       to the cyycle arrray record.
{
{ STATUS: (output) This parameter returns the request status.
{      CONDITIONS:
{          pfe$unknown_cycle_array
{
*DECK DECK=PFH$FIND_CYCLE_ARRAY_VERSION_2 EXPAND=FALSE
{                                                                                                             
{   The purpose of this request is to find a version 2 cycle array subrecord                                  
{ within an info record and return a pointer to it.  The version 2 cycle array                                
{ subrecord contains more information than the cycle array which is returned                                  
{ by PFP$FIND_CYCLE_ARRAY.                                                                                    
{                                                                                                             
{       PFP$FIND_CYCLE_ARRAY_VERSION_2 (P_INFO_RECORD, P_CYCLE_ARRAY, STATUS)                                 
{                                                                                                             
{ P_INFO_RECORD: (input)  This parameter specifies the info record in which the                               
{       cycle array subrecord is to be found.                                                                 
{                                                                                                             
{ P_CYCLE_ARRAY: (output)  This parameter returns a pointer to the desired                                    
{       cycle array.                                                                                          
{                                                                                                             
{ STATUS: (output) This parameter returns the request status.                                                 
{                                                                                                             
{       CONDITIONS:                                                                                           
{             pfe$unknown_cycle_array                                                                         
{             pfe$bad_info_record_format                                                                      
{                                                                                                             
*DECK DECK=PFH$FIND_CYCLE_DIRECTORY EXPAND=FALSE
{
{    The purpose of this request is to find the cycle directory within the
{ cycle array extended record.  The cycle array extended record may be found
{ by use of the PFP$FIND_CYCLE_ARRAY_EXTENDED procedure.  The cycle directory
{ may be used in conjunction with the PFP$FIND_DIRECT_INFO_RECORD procedure
{ to get a pointer to the cycle info.
{
{      PFP$FIND_CYCLE_DIRECTORY (P_CYCLE_ARRAY_EXTENDED_RECORD,
{           P_CYCLE_DIRECTORY_ARRAY, STATUS)
{
{ P_CYCLE_ARRAY_EXTENDED_RECORD: (input) This parameter specifies the info
{      record to search for the directory in.
{
{ P_CYCLE_DIRECTORY_ARRAY: (output) This parameter returns the pointer to
{     cycle directory. This may be NIL if there are no cycles.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS: pfe$bad_info_record_format
{                   pfe$unknown_info_record
{
*DECK DECK=PFH$FIND_CYCLE_ENTRY EXPAND=FALSE
{
{   The purpose of this request is to find the cycle entry for a particular
{ cycle from among those contained in a cycle array.  The array index for the
{ selected cycle is returned.
{
{       PFP$FIND_CYCLE_ENTRY (P_CYCLE_ARRAY, CYCLE_SELECTOR, CYCLE_INDEX,
{                               STATUS)
{
{ P_CYCLE_ARRAY: (input) This parameter specifies the cycle array that is to
{       be searched to find a particular cycle entry.
{
{ CYCLE_SELECTOR: (input) This parameter selects the permanent file cycle for
{       which the cycle entry is desired.  If PFC$LOWEST_CYCLE is specified,
{       the cycle entry for the lowest numbered cycle in the cycle array will
{       be found.  If PFC$HIGHEST_CYCLE is specified, the cycle entry for the
{       highest numbered cycle in the cycle array will be found.  If a specific
{       cycle is specified, the cycle entry for that cycle number will be found
{       in the cycle array.
{
{ CYCLE_INDEX: (output) This parameter returns the index into the cycle array
{       of the desired cycle entry.
{
{ STATUS: (output) This parameter returns the request status.
{       If the pfe$unknown_cycle condition is returned, it is the callers
{       responsibility to reset the status to correctly set both file name
{       and cycle number.
{
{        CONDITIONS: pfe$unknown_cycle
{                    pfe$bad_cycle_option
{                    pfe$bad_cycle_number
{
*DECK DECK=PFH$FIND_CYCLE_ENTRY_VERSION_2 EXPAND=FALSE
{                                                                                                             
{   The purpose of this request is to find the cycle entry for a particular                                   
{ cycle from among those contained in a cycle array.  The array index for the                                 
{ selected cycle is returned.  The version 2 cycle array subrecord contains                                   
{ more information than the cycle array which is returned by                                                  
{ PFP$FIND_CYCLE_ENTRY.                                                                                       
{                                                                                                             
{       PFP$FIND_CYCLE_ENTRY_VERSION_2 (P_CYCLE_ARRAY, CYCLE_SELECTOR,                                        
{             CYCLE_INDEX, STATUS)                                                                            
{                                                                                                             
{ P_CYCLE_ARRAY: (input)  This parameter specifies the cycle array that is to                                 
{       be searched to find a particular cycle entry.                                                         
{                                                                                                             
{ CYCLE_SELECTOR: (input)  This parameter selects the permanent file cycle for                                
{       which the cycle entry is desired.  If PFC$LOWEST_CYCLE is specified,                                  
{       the cycle entry for the lowest numbered cycle in the cycle array will                                 
{       be found.  If PFC$HIGHEST_CYCLE is specified, the cycle entry for the                                 
{       highest numbered cycle in the cycle array will be found.  If a specific                               
{       cycle is specified, the cycle entry for that cycle number will be found                               
{       in the cycle array.                                                                                   
{                                                                                                             
{ CYCLE_INDEX: (output)  This parameter returns the index into the cycle array                                
{       of the desired cycle entry.                                                                           
{                                                                                                             
{ STATUS: (output) This parameter returns the request status.                                                 
{       If the pfe$unknown_cycle condition is returned, it is the callers                                     
{       responsibility to reset the status to correctly set both file name                                    
{       and cycle number.                                                                                     
{                                                                                                             
{       CONDITIONS:                                                                                           
{             pfe$unknown_cycle                                                                               
{             pfe$bad_cycle_option                                                                            
{             pfe$bad_cycle_number                                                                            
{                                                                                                             
*DECK DECK=PFH$FIND_CYCLE_LABEL EXPAND=FALSE
{
{   The purpose of this request is to find the cycle label within the cycle
{ info for a particular cycle.
{
{       PFP$FIND_CYCLE_LABEL (P_CYCLE_INFO_RECORD, P_CYCLE_LABEL, STATUS)
{
{ P_CYCLE_INFO_RECORD: (input) This parameter specifies the cycle info record
{       in which to search for the cycle label.
{
{ P_CYCLE_LABEL: (output) This parameter returns a pointer to the cycle label.
{       The label includes the checksum for the label,
{       followed by the cycle label itself.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS:
{           pfe$unknown_cycle_label
{
*DECK DECK=PFH$FIND_CYCLE_MEDIA EXPAND=FALSE
{
{   The purpose of this request is to find the cycle media description within
{ the cycle info for a particular cycle.
{
{       PFP$FIND_CYCLE_MEDIA (P_CYCLE_INFO_RECORD, P_CYCLE_MEDIA_DESCRIPTION,
{             STATUS)
{
{ P_CYCLE_INFO_RECORD: (input) This parameter specifies the cycle info record
{       in which to search for the cycle media.
{
{ P_CYCLE_MEDIA_DESCRIPTION: (output) This parameter returns a pointer to the
{       cycle media description.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS:
{             pfe$unknown_cycle_media

*DECK DECK=PFH$FIND_DIRECTORY_ARRAY EXPAND=FALSE
{
{   The purpose of this request is to obtain a pointer to the directory array
{ for the information contained within an info record.  The directory array
{ contains the name and type of each item described in the info record.  In
{ addition, the directory entries contain an INFO_OFFSET field that can be
{ used to access detailed information for each item.
{
{       PFP$FIND_DIRECTORY_ARRAY (P_INFO_RECORD, P_DIRECTORY_ARRAY, STATUS)
{
{ P_INFO_RECORD: (input) This parameter specifies the info record in which the
{       directory array is located.
{
{ P_DIRECTORY_ARRAY: (output) This parameter returns a pointer to the directory
{       array for the specified info record.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$unknown_directory_array
{                    pfe$bad_info_record_format
{
*DECK DECK=PFH$FIND_DIRECT_INFO_RECORD EXPAND=FALSE
{
{   The purpose of this request is to build a pointer to the info record that
{ is located in the info sequence specified by P_INFO at the offset specified
{ by INFO_OFFSET.
{
{       PFP$FIND_DIRECT_INFO_RECORD (P_INFO, INFO_OFFSET, P_INFO_RECORD, STATUS)
{
{ P_INFO: (input) This parameter specifies the info sequence in which the info
{       record is to be found.
{
{ INFO_OFFSET: (input) This parameter specifies the offset within the info
{       sequence of the info record that is to be found.  This parameter
{       would be obtained from the directory array entry for an item. This
{       request would then be used to find the info record describing the
{       item.
{
{ P_INFO_RECORD: (output) This parameter returns a pointer to the info record
{       that is found.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$info_offset_range_error
{                    pfe$bad_info_record_format
{
*DECK DECK=PFH$FIND_FILE_DESCRIPTION EXPAND=FALSE
{
{   The purpose of this request is to find a file description sub-record
{ within an info record and return a pointer to it.
{
{       PFP$FIND_FILE_DESCRIPTION (P_INFO_RECORD, P_FILE_DESCRIPTION, STATUS)
{
{ P_INFO_RECORD: (input) This parameter specifies the info record in which
{       the file description sub-record is to be found.
{
{ P_FILE_DESCRIPTION: (output) This parameter returns a pointer to the desired
{       file description.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$unknown_file_description
{                    pfe$bad_info_record_format
{
*DECK DECK=PFH$FIND_LOG_ARRAY EXPAND=FALSE
{
{   The purpose of this request is to find a log array sub-record  within an
{ info record and return a pointer to it.
{
{       PFP$FIND_LOG_ARRAY (P_INFO_RECORD, P_LOG_ARRAY, STATUS)
{
{ P_INFO_RECORD: (input) This parameter specifies the info record in which
{       the log array sub-record is to be found.
{
{ P_LOG_ARRAY: (output) This parameter returns a pointer to the desired log
{       array.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$unknown_log_array
{                    pfe$bad_info_record_format
{
*DECK DECK=PFH$FIND_NEXT_ARCHIVE_ENTRY EXPAND=FALSE
{
{   The purpose of this request is to build a pointer to the next archive entry
{ contained in the info sequence specified by the P_INFO parameter.  The
{ archive entry in the info sequence must have an archive identification which
{ matches the archive identification specified by the ARCHIVE_IDENTIFICATION
{ parameter.  The info sequence is left positioned following the info record so
{ that a subsequent PFP$FIND_NEXT_ARCHIVE_ENTRY call will find the next archive
{ entry.
{
{       PFP$FIND_NEXT_ARCHIVE_ENTRY (ARCHIVE_IDENTIFICATION, P_INFO,
{         P_INFO_RECORD, P_ARCHIVE_ARRAY_ENTRY, P_AMD, STATUS);
{
{ ARCHIVE_IDENTIFICATION: (input)  This parameter specifies the identification
{       of the archiving application.  The identification consists of an
{       application identifier and a media identifier.  The application
{       identifier identifies the archiving application.  The media identifier
{       consists of a media device class and a media volume identifier.  The
{       archive identification is used to locate the next archive entry in the
{       sequence with a matching archive identification.  If the application
{       identifier is specified as OSC$NULL_NAME, the next archive entry in the
{       sequence will be located.  If the application identifier is not
{       specified as OSC$NULL_NAME, the next archive entry in the sequence
{       which has a matching application identifier will be located.  If the
{       media device class is specified as OSC$NULL_NAME, a matching media
{       device classs is not required; otherwise a matching media device class
{       is required.  If the media volume identifier is specified as a null
{       string, a matching media volume identifier is not required; otherwise a
{       matching media volume identifier is required.
{
{ P_INFO:  (input/output) This parameter specifies the info sequence in which
{       the next archive entry is to be found.  The parameter is updated so
{       that the info sequence is positioned following the archive entry that
{       was found.
{
{ P_INFO_RECORD: (output)  This parameter returns the pointer to the archive
{       entry that was found.
{
{ P_ARCHIVE_ARRAY_ENTRY: (output)  This parameter returns the pointer to the
{       archive array entry for the archive entry.
{
{ P_AMD: (output)  This parameter returns the pointer to the archive media
{       descriptor for the archive entry.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$bad_info_record_format
{                    pfe$bad_archive_identification
{                    pfe$invalid_or_unusable_pva
{                    pfe$nil_pointer
{                    pfe$unknown_archive_entry
{                    pfe$unknown_archive_media_desc
{                    pfe$unknown_info_record
{
*DECK DECK=PFH$FIND_NEXT_INFO_RECORD EXPAND=FALSE
{
{   The purpose of this request is to build a pointer to the next info record
{ contained in the info sequence specified by the P_INFO parameter.  The info
{ sequence is left positioned following the info record.
{
{       PFP$FIND_NEXT_INFO_RECORD (P_INFO, P_INFO_RECORD, STATUS)
{
{ P_INFO: (input/output) This parameter specifies the info sequence in which
{       the next info record is to be found.  The parameter is updated so
{       that the info sequence is positioned following the info record that
{       is found.
{
{ P_INFO_RECORD: (output) This parameter returns a pointer to the info record
{       that is found.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$unknown_info_record
{                    pfe$bad_info_record_format
{
*DECK DECK=PFH$FIND_PERMIT_ARRAY EXPAND=FALSE
{
{   The purpose of this request is to find a permit array sub-record within
{ an info record and return a pointer to it.
{
{       PFP$FIND_PERMIT_ARRAY (P_INFO_RECORD, P_PERMIT_ARRAY, STATUS)
{
{ P_INFO_RECORD: (input) This parameter specifies the info record in which
{       the permit array sub-record is to be found.
{
{ P_PERMIT_ARRAY: (output) This parameter returns a pointer to the desired
{       permit array.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$unknown_permit_array
{                    pfe$bad_info_record_format
{
*DECK DECK=PFH$GET_CATALOG_SEGMENT EXPAND=FALSE
{
{   The purpose of this request is return an image of the segment for
{ the specified catalog.  The full catalog is copied to the container
{ specified by p_info.  This is intended primarily for system debugging.
{ Only the system administrator, or the owner of the requested catalog
{ may successfully use this request.
{
{       PFP$GET_CATALOG_SEGMENT (PATH, P_INFO, STATUS)
{
{ PATH: (input) This parameter specifies the name of the catalog desired.
{
{ P_INFO: (output) This parameter specifies the container to hold the
{       catalog segment copy.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=PFH$GET_FAMILY_INFO EXPAND=FALSE
{
{   The purpose of this request is to provide information about the family
{ catalogs registered in a specified set.  This request may only be issued
{ by a system administrator or the owner of the set.
{
{       PFP$GET_FAMILY_INFO (SET_NAME, CATALOG_INFO_SELECTIONS, P_INFO, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set for which
{       family catalog information is desired.
{
{ CATALOG_INFO_SELECTIONS: (input) This parameter specifies a set of the
{       possible pieces of family catalog information that is to be returned
{       by the request.
{
{ P_INFO: (output) This parameter specifies the container to hold the
{       information returned by the request.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$pf_system_error
{                    pfe$bad_set_name
{                    pfe$unknown_set
{                    pfe$not_set_owner
{                    pfe$info_full
{
{        IDENTIFIER: pfc$permanent_file_manager_id
{
*DECK DECK=PFH$GET_ITEM_INFO EXPAND=FALSE
{
{   The purpose of this request is to provide information about an item in the
{ permanent file system.  The item may be a catalog or a file.  If the item is
{ a catalog, the catalog_info_selections parameter determines what information
{ will be returned for the catalog.  If the item is a file, the
{ file_info_selections parameter determines what information will be returned
{ for the file.  If the type of the item is not known by the program making
{ the request, options from both the catalog_info_selections and the
{ file_info_selections can be selected.  The type of the item can then be
{ determined from the directory information returned by the request.
{
{   Information will be returned for a catalog item only if the user making
{ the request is the owner of the catalog or has been granted access, via the
{ permit mechanism, to one or more files registered in the catalog or a
{ subcatalog below it in the permanent file system tree.  Information will be
{ returned for a file item only if the user making the request is the owner
{ of the file or has been granted access to the file via the permit mechanism.
{ Only the owner of an item will be given information relative to another user.
{
{       PFP$GET_ITEM_INFO (PATH, GROUP, CATALOG_INFO_SELECTIONS,
{                            FILE_INFO_SELECTIONS, P_INFO, STATUS)
{
{ PATH: (input) This parameter specifies the identification of an item for
{       which information is to be provided.  The path parameter consists of
{       an array of names which identify the path leading through a catalog
{       hierarchy to the desired item.  The first two names specify the
{       family name and master catalog name portion of the path.  By
{       convention, the name of a user's master catalog is the same as the
{       user name.  Subsequent names would specify subcatalogs as applicable.
{       The last name in the path specifies the item for which information is
{       to be provided.  The item may be a catalog or a file.  Null names are
{       allowed only for the family name and master catalog name.  If the
{       family name is osc$null_name, the family name of the job making the
{       request will be used.  If the master catalog name is osc$null_name,
{       the name of the job making the request will be used.
{
{ GROUP: (input) This parameter allows the information returned to be limited
{       to that pertaining to a user or group of users.  The group can include
{       all users (public), all users of a particular family, all users of a
{       particular account, all users of a particular project, a specific user,
{       a specific user while running under a specific account, or a specific
{       user while running under a specific account and project.  Only the
{       owner of an item will be given information relative to another user.
{
{ CATALOG_INFO_SELECTIONS: (input) This parameter specifies a set of the
{       possible pieces of catalog information that is to be returned by the
{       request if the item is a catalog.
{
{ FILE_INFO_SELECTIONS: (input) This parameter specifies a set of the possible
{       pieces of file information that is to be returned by the request if
{       the item is a file.
{
{ P_INFO: (output) This parameter specifies a container to hold the information
{       returned by the request.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$pf_system_error
{                    pfe$bad_family_name
{                    pfe$bad_user_name
{                    pfe$bad_account_name
{                    pfe$bad_project_name
{                    pfe$bad_group_type
{                    pfe$bad_master_catalog_name
{                    pfe$bad_nth_subcatalog_name
{                    pfe$unknown_family
{                    pfe$unknown_master_catalog
{                    pfe$unknown_nth_subcatalog
{                    pfe$nth_name_not_subcatalog
{                    pfe$path_too_short
{                    pfe$bad_item_name
{                    pfe$unknown_item
{                    pfe$info_full
{
*DECK DECK=PFH$GET_MASTER_CATALOG_INFO EXPAND=FALSE
{
{   The purpose of this request is to provide information about the master
{ catalogs registered to a specified family.  This request may only be issued
{ by a system administrator or the owner of the set.
{
{       PFP$GET_MASTER_CATALOG_INFO (SET_NAME, FAMILY_NAME,
{                                      CATALOG_INFO_SELECTIONS, P_INFO, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set on which
{       the desired family resides.
{
{ FAMILY_NAME: (input) This parameter specifies the name of the family for
{       which master catalog information is desired.
{
{ CATALOG_INFO_SELECTIONS: (input) This parameter specifies a set of the
{       possible pieces of master catalog information that is to be returned
{       by the request.
{
{ P_INFO: (output) This parameter specifies the container to hold the
{       information returned by the request.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$pf_system_error
{                    pfe$bad_set_name
{                    pfe$bad_family_name
{                    pfe$unknown_set
{                    pfe$unknown_family
{                    pfe$not_set_owner
{                    pfe$info_full
{
{        IDENTIFIER: pfc$permanent_file_manager_id
{
*DECK DECK=PFH$GET_MULTI_ITEM_INFO EXPAND=FALSE
{
{   The purpose of this request is to provide information about the items
{ registered in a catalog.  The catalog selected is determined by the path
{ parameter.  Information may be requested for subcatalogs, files or both.
{ The catalog_info_selections parameter determines what information will be
{ returned for the subcatalogs registered in the catalog.  The
{ file_info_selections parameter determines what information will be returned
{ for the files registered in the catalog.
{
{   Information will be returned for a subcatalog item only if the user making
{ the request is the owner of the catalog or has been granted access, via the
{ permit mechanism, to one or more files registered in the subcatalog or a
{ subcatalog below it in the permanent file system tree.  Information will be
{ returned for a file item only if the user making the request is the owner
{ of the catalog or has been granted access to the file via the permit
{ mechanism.  Only the owner of an item will be given information relative to
{ another user.
{
{       PFP$GET_MULTI_ITEM_INFO (PATH, GROUP, CATALOG_INFO_SELECTIONS,
{                                  FILE_INFO_SELECTIONS, P_INFO, STATUS)
{
{ PATH: (input) This parameter specifies the identification of the desired
{       catalog.  The path parameter consists of an array of names which
{       identify the path leading through a catalog hierarchy to the desired
{       catalog.  The first two names specify the family name and master
{       catalog name portion of the path.  By convention, the name of a
{       user's master catalog is the same as the user name.  Subsequent
{       names would specify subcatalogs as applicable.  Information is
{       returned for items registered in the catalog specified by the last
{       name in the path.  Null names are allowed only for the family name
{       and master catalog name.  If the family name is osc$null_name, the
{       family name of the job making the request will be used.  If the
{       master catalog name is osc$null_name, the user name of the job making
{       the request will be used.
{
{ GROUP: (input) This parameter allows the information returned to be limited
{       to that pertaining to a user or group of users.  The group can include
{       all users (public), all users of a particular family, all users of a
{       particular account, all users of a particular project, a specific user,
{       a specific user while running under a specific account, or a specific
{       user while running under a specific account and project.  Only the
{       owner of an item will be given information relative to another user.
{
{ CATALOG_INFO_SELECTIONS: (input) This parameter specifies a set of the
{       possible pieces of catalog information that is to be returned by the
{       request for subcatalog items registered in the selected catalog.
{
{ FILE_INFO_SELECTIONS: (input) This parameter specifies a set of the possible
{       pieces of file information that is to be returned by the request for
{       file items registered in the selected catalog.
{
{ P_INFO: (output) This parameter specifies a container to hold the information
{       returned by the request.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$pf_system_error
{                    pfe$bad_family_name
{                    pfe$bad_user_name
{                    pfe$bad_account_name
{                    pfe$bad_project_name
{                    pfe$bad_group_type
{                    pfe$bad_master_catalog_name
{                    pfe$bad_nth_subcatalog_name
{                    pfe$bad_last_subcatalog_name
{                    pfe$unknown_family
{                    pfe$unknown_master_catalog
{                    pfe$unknown_nth_subcatalog
{                    pfe$unknown_last_subcatalog
{                    pfe$nth_name_not_subcatalog
{                    pfe$last_name_not_subcatalog
{                    pfe$path_too_short
{                    pfe$info_full
{
*DECK DECK=PFH$GET_NEXT_FILE_SELECTION EXPAND=FALSE
{       PFP$GET_NEXT_FILE_SELECTION
{
{
{   The purpose of this request is to return sequentially, record by record,
{ the information collected by a pfp$collect_file_information request.  A
{ record type field in each record identifies the particular information
{ returned.  This record type corresponds to a selection specified in the
{ pfp$collect_file_information request.
{
{       PFP$GET_NEXT_FILE_SELECTION (SELECTION_ID, SELECTION_RECORD,
{                                    SELECTION_POSITION, STATUS)
{
{ SELECTION_ID: (input) This parameter specifies the instance of the
{       pfp$collect_file_information request for which the user wants to get
{       file information.
{
{ SELECTION_RECORD: (output) This parameter returns the next record from the
{       collection of information.  The collected information is returned
{       using the following rules:
{       * Sub-catalog names appear before file names.
{       * If file cycle information is returned, file cycle records will
{         appear after the associated file name record.
{
{ SELECTION_POSITION: (output) This parameter informs the requestor when all
{       collected records have been returned.  A value of
{       pfc$end_of_information indicates that all records have been returned.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: pfe$get_next_at_eoi
{                   pfe$improper_selection_id
{
{       IDENTIFIER: pfc$permanent_file_manager_id
{
*DECK DECK=PFH$GET_OBJECT_INFORMATION EXPAND=FALSE
{
{   The purpose of this request is to get information about a set, catalog,
{ file, or cycle.
{
{       PFP$GET_OBJECT_INFORMATION (FILE_REFERENCE, INFORMATION_REQUEST,
{             P_VALIDATION_CRITERIA, P_OBJECT_INFORMATION, STATUS);
{
{ FILE_REFERENCE: (input) This parameter identifies the catalog, file, or cycle
{       about which information is to be returned.  If a cycle reference is
{       included and fsc$cycle_object_list is requested, then the cycle
{       reference will be ignored.  (See documentation for the
{       information_request parameter.)
{
{ INFORMATION_REQUEST: (input) This parameter is a record specifying what type
{       or types of information are to be returned.  Catalog_depth is ignored
{       when any subject permit is specified.  (See documentation for the
{       p_validation_criteria parameter for subject_permit information.)  A
{       catalog_depth of one (1) means that all of the requested information
{       about the catalog identified by the file_reference parameter will be
{       returned.  If any of the object lists are requested, the applicable
{       names, cycle numbers, global file names, and device classes of the
{       objects will be returned.  A catalog_depth of two (2) means that, in
{       addition to the information returned for a depth of one, all of the
{       requested information about the objects contained in the catalog
{       identified by the file_reference parameter will be returned.  (See the
{       deck containing the declaration of type fst$goi_object_info_request for
{       more information.)
{
{       Currently catalog_depth is not supported.
{
{ P_VALIDATION_CRITERIA: (input, output) This parameter specifies a pointer to
{       an array of validation criterion.
{
{       password: (input) If a password is specified and the object identified
{             by the file_reference parameter is a catalog, then an abnormal
{             status will be returned.
{
{             A password only has meaning with respect to the file label and
{             the job environment information.  If either or both of these
{             types of information are requested and a password is specified,
{             then the password specified must match the password registered
{             with the file identified by the file_reference parameter,
{             otherwise the file label and the job environment information will
{             not be returned.  If either or both of these types of information
{             are requested, a password is not specified, and the file
{             identified by the file_reference parameter is attached within the
{             job, then the file label and the job environment information will
{             be returned.  If either or both of these types of information are
{             requested, a password is not specified, and the file identified
{             by the file_reference parameter is not attached within the job
{             but is password protected, then the file label and the job
{             environment information will not be returned.
{
{             If more than one password is specified, then the first one
{             specified will be used.
{
{       validation_ring: (input) The validation ring only has meaning with
{             respect to the file label and the job environment information.
{             If the validation ring is greater than ring r3 of the cycle, then
{             the file label and the job environment information will not be
{             returned.
{
{             If more than one validation_ring is specified, then the first one
{             specified will be used.  The value specified must be greater than
{             or equal to the lesser of the ring of the caller and the minimum
{             ring of the user.
{
{             Omission causes the lesser of the ring of the caller and the
{             minimum ring of the user to be used.
{
{       subject_permit: (input, output) If this request is being made by the
{             system or an application on behalf of a user but does not
{             originate from within the environment of that user, then one or
{             more subject permits should be provided in the array.  The
{             permit_type and group must be provided as input.  Each subject
{             specified must be permitted to the object identified by the
{             file_reference parameter or an abnormal status will be returned.
{             If any subject permit is specified, then catalog_depth will be
{             ignored.
{
{             A direct permit refers to the permit which would be used in
{             determining how the subject may access the object identified by
{             the file_reference parameter if only the permits created for the
{             object are considered.
{
{             An indirect permit refers to the permit which would be used in
{             determining how the subject may access the object identified by
{             the file_reference parameter regardless of whether the permit was
{             created for the object or for one of its parental catalogs.
{
{             Only the owner or an administrator of the object identified by
{             the file_reference parameter may specify a subject permit.
{
{ P_OBJECT_INFORMATION: (input, output) This parameter specifies a pointer to a
{       sequence in which the requested information will be returned.  This
{       pointer must be reset by the caller prior to calling this routine, and
{       again prior to "reading" the sequence, as pfp$get_object_information
{       never resets this pointer.  A sequence large enough to hold all of the
{       requested information should be provided, otherwise this request will
{       terminate prematurely with an abnormal status.  It is recommended that
{       a sequence pointer to a scratch segment, created via
{       mmp$create_scratch_segment, be specified whenever a "large" amount of
{       information is being requested.  All pointers returned within the
{       sequence will be process virtual addresses.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS:
{             ame$damaged_file_attributes
{             ame$file_not_known
{             ame$ring_validation_error
{             pfe$bad_account_name
{             pfe$bad_cycle_number
{             pfe$bad_cycle_option
{             pfe$bad_family_name
{             pfe$bad_group_type
{             pfe$bad_last_subcatalog
{             pfe$bad_master_catalog_name
{             pfe$bad_nth_subcatalog_name
{             pfe$bad_object_info_requests
{             pfe$bad_password
{             pfe$bad_permanent_file_name
{             pfe$bad_project_name
{             pfe$bad_user_name
{             pfe$bad_validation_selection
{             pfe$catalogs_have_no_password
{             pfe$incorrect_password
{             pfe$info_full
{             pfe$invalid_ring_access
{             pfe$neither_owner_nor_admin
{             pfe$not_family_owner
{             pfe$nth_name_not_subcatalog
{             pfe$pf_system_error
{             pfe$unknown_cycle
{             pfe$unknown_family
{             pfe$unknown_item
{             pfe$unknown_last_subcatalog
{             pfe$unknown_master_catalog
{             pfe$unknown_nth_subcatalog
{             pfe$unknown_permanent_file
{
*DECK DECK=PFH$GET_RESERVED_ITEM_INFO EXPAND=FALSE
{
{   The purpose of this request is to provide information about the items
{ registered in a catalog.  The catalog selected is determined by the path
{ parameter.  Information may be requested for subcatalogs, files or both.
{ The catalog_info_selections parameter determines what information will be
{ returned for the subcatalogs registered in the catalog.  The
{ file_info_selections parameter determines what information will be returned
{ for the files registered in the catalog.
{
{   Information will be returned for a subcatalog item only if the user making
{ the request is the owner of the catalog or has been granted access, via the
{ permit mechanism, to one or more files registered in the subcatalog or a
{ subcatalog below it in the permanent file system tree.  Information will be
{ returned for a file item only if the user making the request is the owner
{ of the catalog or has been granted access to the file via the permit
{ mechanism.  Only the owner of an item will be given information relative to
{ another user.
{
{   In addition to returning information about items in a catalog this
{ interface will attach each cycle that satisfies the criteria specified
{ in the p_cycle_reservation_criteria parameter.  The cycles will be attached
{ with access_mode=(read) and share_mode=(read execute).  These attachments
{ are registered in the catalog only, the ATTACHED_PF_TABLE and BAM tables
{ are not modified.  Cycles attached in this manner must be detached using
{ the pfp$detach_reserved_cycles interface.
{
{   This interface is designed to improve the performance of the
{ BACKUP_PERMANENT_FILES utility and should not be used by any other product
{ without permission of the PERMANENT_FILES project.
{
{       PFP$GET_RESERVED_ITEM_INFO (PATH, GROUP, CATALOG_INFO_SELECTIONS,
{             FILE_INFO_SELECTIONS, P_CYCLE_RESERVATION_CRITERIA, P_INFO,
{             STATUS)
{
{ PATH: (input) This parameter specifies the identification of the desired
{       catalog.  The path parameter consists of an array of names which
{       identify the path leading through a catalog hierarchy to the desired
{       catalog.  The first two names specify the family name and master
{       catalog name portion of the path.  By convention, the name of a
{       user's master catalog is the same as the user name.  Subsequent
{       names would specify subcatalogs as applicable.  Information is
{       returned for items registered in the catalog specified by the last
{       name in the path.  Null names are allowed only for the family name
{       and master catalog name.  If the family name is osc$null_name, the
{       family name of the job making the request will be used.  If the
{       master catalog name is osc$null_name, the user name of the job making
{       the request will be used.
{
{ GROUP: (input) This parameter allows the information returned to be limited
{       to that pertaining to a user or group of users.  The group can include
{       all users (public), all users of a particular family, all users of a
{       particular account, all users of a particular project, a specific user,
{       a specific user while running under a specific account, or a specific
{       user while running under a specific account and project.  Only the
{       owner of an item will be given information relative to another user.
{
{ CATALOG_INFO_SELECTIONS: (input) This parameter specifies a set of the
{       possible pieces of catalog information that is to be returned by the
{       request for subcatalog items registered in the selected catalog.
{
{ FILE_INFO_SELECTIONS: (input) This parameter specifies a set of the possible
{       pieces of file information that is to be returned by the request for
{       file items registered in the selected catalog.
{
{ P_CYCLE_RESERVATION_CRITERIA: (input) This parameter specifies the criteria
{       which will determine if cycles in the specified catalog will be
{       reserved.  If a NIL pointer is supplied for this parameter, no cycles
{       will be reserved.
{
{ P_INFO: (output) This parameter specifies a container to hold the information
{       returned by the request.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{            pfe$bad_account_name
{            pfe$bad_family_name
{            pfe$bad_group_type
{            pfe$bad_last_subcatalog_name
{            pfe$bad_master_catalog_name
{            pfe$bad_nth_subcatalog_name
{            pfe$bad_project_name
{            pfe$bad_user_name
{            pfe$info_full
{            pfe$last_name_not_subcatalog
{            pfe$nth_name_not_subcatalog
{            pfe$path_too_short
{            pfe$pf_system_error
{            pfe$unknown_family
{            pfe$unknown_last_subcatalog
{            pfe$unknown_master_catalog
{            pfe$unknown_nth_subcatalog
{
*DECK DECK=PFH$GET_RESTORE_STATUS EXPAND=FALSE
{
{   The purpose of this request is to determine if the restore of missing
{ catalogs has completed.  This will always return false after permanent
{ file recovery.  The restore of missing catalogs
{ is marked complete by the SET_RESTORE_MISSING_CATALOG_END subcommand
{ of the restore_permanent_files utility. This request is only available
{ from the operator job.
{
{       PFP$GET_RESTORE_STATUS (RESTORE_MISSING_CATALOGS_DONE)
{
{ RESTORE_MISSING_CATALOGS_DONE: (output) This parameter returns whether
{       the restore missing catalogs has completed.
{
{ STATUS: (output)  This parameter returns the request status.
{        CONDITIONS:
{         pfe$not_system_operator
{
*DECK DECK=PFH$GET_STORED_FMD EXPAND=FALSE
{
{   The purpose of this request is to return information pertaining to
{ the device residence of the given permanent file or catalog.  This request returns
{ both the global_file_name, and the  file_media_descriptor
{ (fmd) associated with the permanent file.  If no fmd is associated with
{ the file an error status is returned.
{   This request is intended only for system debugging.  Only the owner
{ of the file or the system administrator may issue this request.
{
{       PFP$GET_STORED_FMD (PATH, CYCLE_SELECTOR, CATALOG, CATALOG_RECREATED,
{             GLOBAL_FILE_NAME, STORED_FMD, STATUS)
{
{ PATH: (input) This parameter specifies the identification of the
{       permanent file.
{
{ CYCLE_SELECTOR: (input) This parameter specifies the permanent file
{       cycle for which the information is to be obtained for.
{
{ CATALOG: (output) This parameter returns whether the item found is a catalog.
{
{ CATALOG_RECREATED: (output) This parameter returns whether the catalog was
{        recreated by restore_missing_catalog.
{
{ GLOBAL_FILE_NAME: (output) This parameter returns the global_file_name
{       associated with the permanent file.  This was originally assigned
{       on file creation.
{
{ STORED_FMD: (output) This parameter returns the  fmd.
{       The input sequence must be of the same size as the stored fmd,
{       or an error status is returned.
{
{ STATUS: (output) This parameter returns the request status.
*DECK DECK=PFH$GET_STORED_FMD_SIZE EXPAND=FALSE
{
{   The purpose of this request is to return information pertaining to
{ the device residence of the given permanent file.  This request returns
{ both the global_file_name, and the size of the file_media_descriptor
{ (fmd) associated with the permanent file.  If no fmd is associated with
{ the file an error status is returned.
{   This request is intended only for system debugging.  Only the owner
{ of the file or the system administrator may issue this request.
{
{       PFP$GET_STORED_FMD_SIZE (PATH, CYCLE_SELECTOR, GLOBAL_FILE_NAME,
{             STORED_FMD_SIZE, STATUS)
{
{ PATH: (input) This parameter specifies the identification of the
{       permanent file.
{
{ CYCLE_SELECTOR: (input) This parameter specifies the permanent file
{       cycle for which the information is to be obtained for.
{
{ GLOBAL_FILE_NAME: (output) This parameter returns the global_file_name
{       associated with the permanent file.  This was originally assigned
{       on file creation.
{
{ STORED_FMD_SIZE: (output) This parameter returns the size of the fmd.
{
{ STATUS: (output) This parameter returns the request status.
*DECK DECK=PFH$MARK_RELEASE_CANDIDATE EXPAND=FALSE
{
{   The purpose of this request is to mark a file cycle which has been
{ duplicated on archive media as a candidate for release.  The mark can be used
{ by an archiving application to indicate that the data for the file cycle can
{ be released after the integrity of the archive media has been established.
{ For example, marking for release is used when archiving to the NOS/170
{ permanent file base to indicate that the NOS/170 file which contains a copy
{ of the file has been backed up.  Data is actually released from mass storage
{ by calling PFP$RELEASE_DATA.  Note that PFP$RELEASE_DATA does not require
{ that the file cycle be marked in order to release it's data from mass
{ storage.
{
{       PFP$MARK_RELEASE_CANDIDATE (PATH, CYCLE_SELECTOR, PASSWORD,
{         ARCHIVE_IDENTIFICATION, STATUS)
{
{ PATH: (input)  This parameter specifies the identification of the permanent
{       file.  The path parameter consists of an array of names which identify
{       the path leading through a catalog hierarchy to the desired file.  The
{       first two names specify the family name and master catalog name portion
{       of the path.  By convention, the name of a user's master catalog is the
{       same as the user name.  Subsequent names would specify subcatalogs as
{       applicable.  The last name specifies the permanent file that is to be
{       purged.  Null names are allowed only for the family name and master
{       catalog name.  If the family name is OSC$NULL_NAME, the family name of
{       the job making the request will be used.  If the master catalog name is
{       OSC$NULL_NAME, the user name of the job making the request will be
{       used.
{
{ CYCLE_SELECTOR: (input)  This parameter selects the permanent file cycle that
{       is to be released.  If PFC$LOWEST_CYCLE is specified, the lowest cycle
{       of the file will be released.  If PFC$HIGHEST_CYCLE is specified, the
{       highest cycle of the file will be released.  If a specific cycle is
{       specified, that cycle will be released.
{
{ PASSWORD: (input)  This parameter specifies a password that must match the
{       password registered with the file.  If a blank password is specified,
{       it will be considered a match only if no password was registered with
{       the file.
{
{ ARCHIVE_IDENTIFICATION: (input)  This parameter specifies the identification
{       of the archiving application.  The identification consists of an
{       application identifier and a media identifier.  The application
{       identifier identifies the archiving application.  The media identifier
{       consists of a media device class and a media volume identifier.  The
{       entire archive identification is used to locate the archive entry which
{       is to be marked.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDTIONS:  pfe$bad_archive_identification
{                    pfe$bad_cycle_number
{                    pfe$bad_cycle_option
{                    pfe$bad_family_name
{                    pfe$bad_master_catalog_name
{                    pfe$bad_nth_subcatalog_name
{                    pfe$bad_password
{                    pfe$bad_permanent_file_name
{                    pfe$incorrect_password
{                    pfe$name_not_permanent_file
{                    pfe$nth_name_not_subcatalog
{                    pfe$path_too_short
{                    pfe$pf_system_error
{                    pfe$unknown_cycle
{                    pfe$unknown_family
{                    pfe$unknown_master_catalog
{                    pfe$unknown_nth_subcatalog
{                    pfe$unknown_permanent_file
{                    pfe$usage_not_permitted
{
*DECK DECK=PFH$OPEN_FILE_SEGMENT EXPAND=FALSE
{
{   The purpose of this request is to open a file for segment level access.
{
{       PFP$OPEN_FILE_SEGMENT (SYSTEM_FILE_ID, VALIDATION_RING,
{             SEGMENT_POINTER, STATUS);
{
{ SYSTEM_FILE_ID: (input) This parameter specifies the system_file_identifier
{       of file to be opened as a segment.
{
{ VALIDATION_RING: (input) This parameter specifies the ring of execution for
{       whom the segment is being opened.
{
{ SEGMENT_POINTER: (output) This parameter specifies a PVA to the beginning of
{       the segment.  The byte offset of the PVA is set to zero.
{
{ STATUS: (output) This parameter specifies the request status.
{
{       CONDITIONS:
{            dme$unable_to_get_fd_lock
{            dme$unable_to_locate_fde
{            mme$address_not_0_mod_16384
{            mme$asid_specified
{            mme$binding_attribute_invalid
{            mme$contig_mem_seg_violation
{            mme$execute_global_invalid
{            mme$invalid_asid_specified
{            mme$invalid_length_requested
{            mme$invalid_pva
{            mme$invalid_ring_brackets
{            mme$invalid_shadow_segment
{            mme$invalid_shared_taskid
{            mme$length_not_0_mod_16384
{            mme$pages_already_assigned
{            mme$ref_to_unrecovered_file
{            mme$ring_violation
{            mme$segment_number_is_in_use
{            mme$segment_number_not_in_use
{            mme$segment_number_too_big
{            mme$segment_origin_invalid
{            mme$segment_table_is_full
{            mme$software_attribute_invalid
{            mme$unable_to_assign_contig_mem
{            mme$unsupported_keyword
{            pfe$not_system_administrtor
{
*DECK DECK=PFH$OVERHAUL_CATALOG EXPAND=FALSE
{       PFP$OVERHAUL_CATALOG
{
{   The purpose of this request is to perform one or more of the following:
{   . process the entire subtree of the specified catalog;
{   . recover purged files;
{   . validate data in the catalog by using checksums.
{
{       PFP$OVERHAUL_CATALOG (PATH, CATALOG_OVERHAUL_CHOICES, STATUS)
{
{ PATH: (input) This parameter specifies the identification of a catalog.  The
{       path parameter consists of an array of names which identify the path
{       leading through a catalog hierarchy to the desired catalog.  The first
{       two names specify the family name and master catalog name portion of
{       the path.  By convention, the name of a user's master catalog is the
{       same as the user name.  Subsequent names would specify subcatalogs as
{       applicable.  The last name in the path specifies the catalog that is
{       to be overhauled.  Null names are allowed only for the family name and
{       master catalog name.  If a null name is specified for the family name,
{       the family name of the job making the request will be used.  If a null
{       name is specified for the master catalog name, the user name of the
{       job making the request will be used.
{
{ CATALOG_OVERHAUL_CHOICES: (input) This parameter specifies the set of
{       catalog overhaul options to be used.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: pfe$bad_family_name
{                   pfe$bad_last_subcatalog_name
{                   pfe$bad_master_catalog_name
{                   pfe$bad_nth_subcatalog_name
{                   pfe$catalog_defective
{                   pfe$no_operation
{                   pfe$not_master_catalog_owner
{                   pfe$nth_name_not_subcatalog
{                   pfe$overhaul_catalog_failed
{                   pfe$path_too_short
{                   pfe$pf_system_error
{                   pfe$recovery_summary
{                   pfe$unknown_family
{                   pfe$unknown_master_catalog
{                   pfe$unknown_nth_subcatalog
{
*DECK DECK=PFH$OVERHAUL_SET EXPAND=FALSE
{       PFP$OVERHAUL_SET
{
{   The purpose of this request is to perform one or more of the following:
{   . process all catalogs on the set;
{   . recover purged files;
{   . validate data in the catalogs by using checksums;
{   . reorganize catalogs to improve locality of reference;
{   . reconcile catalog FMDs and file cycle FMDs with device management;
{   . delete irreconcilable catalogs and file cycles.
{
{   If reorganization, reconciliation, or deletion are chosen, then write
{ access will be used; otherwise read access will be used.
{   If either reorganization or deletion is chosen, then reconciliation must
{ also be chosen.
{
{       PFP$OVERHAUL_SET (SET_NAME, SET_OVERHAUL_CHOICES, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set to be
{       overhauled.  A null name is not allowed.
{
{ SET_OVERHAUL_CHOICES: (input) This parameter specifies the set of set
{       overhaul options to be used.
{
{ STATUS: (output) This parameter specifies the request status.
{
{       CONDITIONS: pfe$bad_root_catalog_header
{                   pfe$bad_set_name
{                   pfe$catalog_full
{                   pfe$delete_needs_reconcile
{                   pfe$not_set_owner
{                   pfe$pf_system_error
{                   pfe$recovery_summary
{                   pfe$reorganize_needs_reconcile
{                   pfe$unknown_set
{
*DECK DECK=PFH$PERMIT EXPAND=FALSE
{
{   The purpose of this request is to establish or modify an access control
{ entry for a permanent file.  An access control entry can only be established
{ or modified for a permanent file belonging to the user making the request.
{ Permission can be established for specific users or groups of users
{ associated with a specific family, account, or project.  If an access control
{ entry already exists for the specified user or group of users, then the
{ specified permit selections and share requirements replace the values
{ currently defined.
{
{   Access control entries can also be established at a catalog level to
{ control access to all files registered relative to the catalog.  (See the
{ PFP$PERMIT_CATALOG request for further information.)
{
{   Multiple access control entries may apply to a user requesting access (e.g.
{ one relative to the user's family, one relative to the user).  In this case,
{ the entry associated with the most restrictive group is used.  If multiple
{ entries specify the same group, the entry from the lowest level in the master
{ catalog, subcatalog, file hierarchy is used.
{
{       PFP$PERMIT (PATH, GROUP, PERMIT_SELECTIONS, SHARE_REQUIREMENTS,
{             APPLICATION_INFO, STATUS)
{
{ PATH: (input) This parameter specifies the identification of the permanent
{       file.  The path parameter consists of an array of names which identify
{       the path leading through a catalog hierarchy to the desired file.  The
{       first two names specify the family name and master catalog name portion
{       of the path.  By convention, the name of a user's master catalog is the
{       same as the user name.  Subsequent names would specify subcatalogs as
{       applicable.  The last name in the path specifies the permanent file to
{       which the access control entry will apply.  Null names are allowed only
{       for the family name and master catalog name.  If the family name is
{       OSC$NULL_NAME, the family name of the job making the request will be
{       used.  If the master catalog name is OSC$NULL_NAME, the user name of
{       the job making the request will be used.
{
{ GROUP: (input) This parameter describes the user or group of users to whom
{       the access control entry applies.  The group can include all users
{       (public), all users of a particular family, all users of a particular
{       account, all users of a particular project, a specific user, a specific
{       user while running under a specific account, or a specific user while
{       running under a specific account and project.
{
{ PERMIT_SELECTIONS: (input) This parameter specifies the permit selections
{       granted by the access control entry.
{
{ SHARE_REQUIREMENTS: (input) This parameter specifies the share selections
{       that must be specified when granted access by the access control entry.
{
{ APPLICATION_INFO: (input) This parameter specifies information to be included
{       in the permit entry for use by application programs for additional
{       access controls they impose.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS: pfe$bad_account_name
{                   pfe$bad_family_name
{                   pfe$bad_group_type
{                   pfe$bad_master_catalog_name
{                   pfe$bad_nth_subcatalog_name
{                   pfe$bad_permanent_file_name
{                   pfe$bad_project_name
{                   pfe$bad_user_name
{                   pfe$catalog_full
{                   pfe$invalid_group
{                   pfe$invalid_group_type
{                   pfe$name_not_permanent_file
{                   pfe$not_master_catalog_owner
{                   pfe$nth_name_not_subcatalog
{                   pfe$path_too_short
{                   pfe$pf_system_error
{                   pfe$unknown_family
{                   pfe$unknown_master_catalog
{                   pfe$unknown_nth_subcatalog
{                   pfe$unknown_permanent_file
{
*DECK DECK=PFH$PERMIT_CATALOG EXPAND=FALSE
{
{   The purpose of this request is to establish or modify an access control
{ entry for a catalog.  This request allows the catalog owner to specify a
{ general permission that applies to attempts to access any file registered
{ relative to the specified catalog.  An access control entry can only be
{ established or modified for a catalog belonging to the user making the
{ request.  Permission can be established for specific users or for groups of
{ users associated with a specific family, account, or project.  If an access
{ control entry already exists for the specified user or group of users, then
{ the specified permit selections and share requirements replace the values
{ currently defined.
{
{   Multiple access control entries may apply to a user requesting access to a
{ file (e.g.  one relative to the user's family, one relative to the user).  In
{ this case, the entry associated with the most restrictive group is used.  If
{ multiple entries specify the same group, the entry from the lowest level in
{ the master catalog, subcatalog, file hierarchy is used.
{
{       PFP$PERMIT_CATALOG (PATH, GROUP, PERMIT_SELECTIONS, SHARE_REQUIREMENTS,
{             APPLICATION_INFO, STATUS)
{
{ PATH: (input) This parameter specifies the identification of the catalog.
{       The path parameter consists of an array of names which identify the
{       path leading through a catalog hierarchy to the desired catalog.  The
{       first two names specify the family name and master catalog name portion
{       of the path.  By convention, the name of a user's master catalog is the
{       same as the user name.  Subsequent names would specify subcatalogs as
{       applicable.  The last name in the path specifies the catalog to which
{       the access control entry will apply.  Null names are allowed only for
{       the family name and master catalog name.  If the family name is
{       OSC$NULL_NAME, the family name of the job making the request will be
{       used.  If the master catalog name is OSC$NULL_NAME, the user name of
{       the job making the request will be used.
{
{ GROUP: (input) This parameter describes the user or group of users to whom
{       the access control entry applies.  The group can include all users
{       (public), all users of a particular family, all users of a particular
{       account, all users of a particular project, a specific user, a specific
{       user while running under a specific account, or a specific user while
{       running under a specific account and project.
{
{ PERMIT_SELECTIONS: (input) This parameter specifies the permit selections
{       granted by the access control entry.
{
{ SHARE_REQUIREMENTS: (input) This parameter specifies the share selections
{       that must be specified when granted access by the access control entry.
{
{ APPLICATION_INFO: (input) This parameter specifies information to be included
{       in the permit entry for use by application programs for additional
{       access controls they impose.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS: pfe$bad_account_name
{                   pfe$bad_family_name
{                   pfe$bad_group_type
{                   pfe$bad_last_subcatalog_name
{                   pfe$bad_master_catalog_name
{                   pfe$bad_nth_subcatalog_name
{                   pfe$bad_project_name
{                   pfe$bad_user_name
{                   pfe$catalog_full
{                   pfe$invalid_group
{                   pfe$invalid_group_type
{                   pfe$last_name_not_subcatalog
{                   pfe$not_master_catalog_owner
{                   pfe$nth_name_not_subcatalog
{                   pfe$path_too_short
{                   pfe$pf_system_error
{                   pfe$unknown_family
{                   pfe$unknown_last_subcatalog
{                   pfe$unknown_master_catalog
{                   pfe$unknown_nth_subcatalog
{
*DECK DECK=PFH$PROCESS_JOB_END EXPAND=FALSE
{   The purpose of this procedure is to allow permanent file manager to perform
{ cleanup of the permanent file environment that is maintained between calls to
{ other permanent file procedures.  This procedure must be called at a point in
{ time when no further permanent file activity is to occur within the job and
{ while the permanent file tables are still usable.
{
{       PFP$PROCESS_JOB_END (RETURN_FILES_OPTION)
{
{ RETURN_FILES_OPTION: (input, output)  This parameter specifies whether files
{   should be returned as a result of this request.
{   On a single mainframe the return of files should have been accomplished
{     by the fmp$job_exit request, so there is no need to return them now.
{   On the file server this request may be used when the client mainframe
{     has terminated abnormally and it is desired to cleanup up that mainframe's
{     environment on the server.  On the server a call to
{     pfp$set_task_environment must be performed first.
{     return_files specifies whether to return files.
{       log_returned_files:  This indicates whether the names of files that
{         were returned should be recorded in the system and job logs.
{       wait_for_down_volume
{       IF TRUE then the permanent file manager will wait for
{         the volume to come online before returning files on a down volume.
{       IF FALSE then all files that can be returned will be returned and
{         the files_on_down_device count will indicate how many files
{         are left attached because they reside on a down device.
{       For the file server it is suggested that the first call not wait for
{       down volumes, so that as many files be returned as possible.  It is
{       suggested that on the second pass that wait is specified.
*DECK DECK=PFH$PURGE EXPAND=FALSE
{
{   The purpose of this request is to delete a permanent file cycle.
{
{   Only a user with control access permission may delete a file cycle.
{
{   If the file cycle is in use at the time the purge is requested, the actual
{ deletion is not done until all accessors have detached the cycle.  Permanent
{ file requests to access the cycle will not be accepted once a purge has been
{ initiated.  Once all cycles of the file have been deleted, the file is no
{ longer registered in the catalog.
{
{       PFP$PURGE (PATH, CYCLE_SELECTOR, PASSWORD, STATUS)
{
{ PATH: (input) This parameter specifies the identification of the permanent
{       file.  The path parameter consists of an array of names which identify
{       the path leading through a catalog hierarchy to the desired file.  The
{       first two names specify the family name and master catalog name
{       portion of the path.  By convention, the name of a user's master
{       catalog is the same as the user name.  Subsequent names would specify
{       subcatalogs as applicable.  The last name specifies the permanent file
{       that is to be purged.  Null names are allowed only for the family
{       name and master catalog name.  If the family name is osc$null_name,
{       the family name of the job making the request will be used.  If the
{       master catalog name is osc$null_name, the user name of the job making
{       the request will be used.
{
{ CYCLE_SELECTOR: (input) This parameter selects the permanent file cycle that
{       is to be purged.  If pfc$lowest_cycle is specified, the lowest cycle
{       of the file will be purged.  If pfc$highest_cycle is specified, the
{       highest cycle of the file will be purged.  If a specific cycle is
{       specified, that cycle will be purged.
{
{ PASSWORD: (input) This parameter specifies a password that must match the
{       password registered with the file.  If a blank password is specified,
{       it will only match if no password was registered with the file.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS:
{             ame$damaged_file_attributes
{             pfe$bad_cycle_number
{             pfe$bad_cycle_option
{             pfe$bad_family_name
{             pfe$bad_last_subcatalog_name
{             pfe$bad_master_catalog_name
{             pfe$bad_nth_subcatalog_name
{             pfe$bad_password
{             pfe$bad_permanent_file_name
{             pfe$incorrect_password
{             pfe$invalid_ring_access
{             pfe$last_name_not_subcatalog
{             pfe$name_not_permanent_file
{             pfe$nth_name_not_subcatalog
{             pfe$path_too_short
{             pfe$pf_system_error
{             pfe$unknown_cycle
{             pfe$unknown_family
{             pfe$unknown_last_subcatalog
{             pfe$unknown_master_catalog
{             pfe$unknown_nth_subcatalog
{             pfe$unknown_permanent_file
{             pfe$usage_not_permitted
{
*DECK DECK=PFH$PURGE_CATALOG EXPAND=FALSE
{
{   The purpose of this request is to purge a subcatalog from a catalog.  The
{ name of the subcatalog is identified by the last name of the path parameter.
{ The catalog in which the subcatalog is registered is identified by the
{ remainder of the path parameter.
{
{   Before a catalog may be purged, it must be empty.  This can be achieved
{ by purging all files and subcatalogs registered in it.
{
{   This request only allows subcatalogs to be purged from a catalog owned by
{ the user making the request.  In addition, this request does not allow a
{ master catalog to be purged.  Master catalogs are purged as a function of
{ the administer_validations utility.
{
{       PFP$PURGE_CATALOG (PATH, STATUS)
{
{ PATH: (input) This parameter specifies the identification of a subcatalog.
{       The path parameter consists of an array of names which identify the
{       path leading through a catalog hierarchy to the desired subcatalog.
{       The first two names specify the family name and master catalog name
{       portion of the path.  By convention, the name of a user's master
{       catalog is the same as the user name.  Subsequent names would specify
{       subcatalogs as applicable.  The last name in the path specifies the
{       subcatalog that is to be deleted.  Null names are allowed only for
{       the family name and master catalog name.  If the family name is
{       osc$null_name, the family name of the job making the request will
{       be used.  If the master catalog name is osc$null_name, the user name
{       of the job making the request will be used.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS:
{             pfe$bad_family_name
{             pfe$bad_last_subcatalog_name
{             pfe$bad_master_catalog_name
{             pfe$bad_nth_subcatalog_name
{             pfe$cannot_purge_master_catalog
{             pfe$catalog_not_empty
{             pfe$last_name_not_subcatalog
{             pfe$not_master_catalog_owner
{             pfe$nth_name_not_subcatalog
{             pfe$path_too_short
{             pfe$pf_system_error
{             pfe$unknown_family
{             pfe$unknown_last_subcatalog
{             pfe$unknown_master_catalog
{             pfe$unknown_nth_subcatalog
{
*DECK DECK=PFH$PURGE_CATALOG_CONTENTS EXPAND=FALSE
{
{   The purpose of this request is to purge the contents from a catalog.  The
{ name of the catalog is identified by the last name of the path parameter.
{ The residence of the catalog is identified by the remainder of the path
{ parameter.
{
{   This request only allows contents to be purged from a catalog owned by the
{ user making the request.  In addition, this request does not allow a master
{ catalog to be purged.
{
{       PFP$PURGE_CATALOG_CONTENTS (PATH, PURGE_CATALOG, STATUS)
{
{ PATH: (input) This parameter specifies the identification of a (sub)catalog.
{       The path parameter consists of an array of names which identify the
{       path leading through a catalog hierarchy to the desired (sub)catalog.
{       The first two names specify the family name and master catalog name
{       portion of the path.  By convention, the name of a user's master
{       catalog is the same as the user name.  Subsequent names would specify
{       subcatalogs as applicable.  The last name in the path specifies the
{       (sub)catalog that is to be deleted.
{
{ PURGE_CATALOG: (input) This parameter specifies whether or not the
{       (sub)catalog, whose contents are to be purged, should be purged along
{       with its contents.  This request does not allow purging of a master
{       catalog; however, it does allow the purging of a master catalog's
{       contents.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS:
{             pfe$bad_family_name
{             pfe$bad_last_(sub)catalog_name
{             pfe$bad_master_catalog_name
{             pfe$bad_nth_(sub)catalog_name
{             pfe$cannot_purge_master_catalog
{             pfe$catalog_not_empty
{             pfe$last_name_not_(sub)catalog
{             pfe$not_master_catalog_owner
{             pfe$nth_name_not_(sub)catalog
{             pfe$path_too_short
{             pfe$pf_system_error
{             pfe$cannot_purge_master_catalog
{             pfe$unknown_family
{             pfe$unknown_last_subcatalog
{             pfe$unknown_master_catalog
{             pfe$unknown_nth_subcatalog
{
*DECK DECK=PFH$PURGE_MASTER_CATALOG EXPAND=FALSE
{   The purpose of this request is to remove the master catalog for the
{ specified family from the specified set.  This request may be issued by
{ a system administrator or the owner of the set, but only when all files
{ and subcatalogs registered in the master catalog have been purged.
{
{       PFP$PURGE_MASTER_CATALOG (SET_NAME, FAMILY_NAME, MASTER_CATALOG_NAME,
{                                   STATUS)
{
{ SET_NAME: (input) This parameter specifies the set name from which the
{       master catalog is to be purged.  A blank name is not allowed.
{
{ FAMILY_NAME: (input) This parameter specifies the name of the family for
{       which a master catalog is to be purged.  If this parameter is all
{       blanks, the family name of the job making the request will be used.
{
{ MASTER_CATALOG_NAME: (input) This parameter specifies the name of the
{       master catalog that is to be purged.  Be convention, the name of
{       a user's master catalog is the same as the user name.  If this
{       parameter is all blanks, the user name of the job making the request
{       will be used.
{
{ STATUS: (output) This parameter specifies the request status.
{
{        CONDITIONS: pfe$pf_system_error
{                    pfe$catalog_not_empty
{                    pfe$bad_set_name
{                    pfe$bad_family_name
{                    pfe$bad_master_catalog_name
{                    pfe$unknown_set
{                    pfe$unknown_family
{                    pfe$unknown_master_catalog
{                    pfe$not_family_owner
{
{        IDENTIFIER: pfc$permanent_file_manager_id
{
*DECK DECK=PFH$PUT_ARCHIVE_ENTRY EXPAND=FALSE
{
{   The purpose of this request is to add an archive entry to the archive list
{ for a specified file cycle.  The archive entry is placed at the front of the
{ list of archive entries for the file cycle (the archive media descriptor
{ which is associated with the archive entry is stored in a separate container
{ in the permanent file catalog).
{
{       PFP$PUT_ARCHIVE_ENTRY (PATH, CYCLE_SELECTOR, P_ARCHIVE_ARRAY_ENTRY,
{         P_AMD, STATUS)
{
{ PATH: (input)  This parameter specifies the identification of a file for
{       which an archive entry is to be stored in the permanent file catalog.
{       The path parameter consists of an array of names which identify the
{       path leading through a catalog hierarchy to the desired file.  The
{       first two names specify the family name and master catalog name portion
{       of the path.  By convention, the name of a user's master catalog is the
{       same as the user name.  Subsequent names would specify subcatalogs as
{       applicable.  The last name in the path specifies the file for which an
{       archive entry is to be stored in the permanent file catalog.  Null
{       names are allowed only for the family name and master catalog name.  If
{       the family name is OSC$NULL_NAME, the family name of the job making the
{       request will be used.  If the master catalog name is OSC$NULL_NAME, the
{       user name of the job making the request will be used.  The file must
{       already exist.
{
{ CYCLE_SELECTOR: (input)  This parameter selects the permanent file cycle for
{       which an archive entry is to be added to the archive list.
{
{ P_ARCHIVE_ARRAY_ENTRY: (input)  This parameter specifies a pointer to the
{       archive entry which is to be stored in the catalog.  The entry pointed
{       to is in the format in which PFP$GET_ITEM_INFO retrieves it.
{
{ P_AMD: (input)  This parameter specifies a pointer to the archive media
{       descriptor which is to be stored with the archive entry.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$bad_archive_identification
{                    pfe$bad_cycle_number
{                    pfe$bad_cycle_option
{                    pfe$bad_family_name
{                    pfe$bad_last_subcatalog_name
{                    pfe$bad_master_catalog_name
{                    pfe$bad_nth_subcatalog_name
{                    pfe$bad_permanent_file_name
{                    pfe$catalog_full
{                    pfe$name_not_permanent_file
{                    pfe$nth_name_not_subcatalog
{                    pfe$path_too_short
{                    pfe$pf_system_error
{                    pfe$unknown_archive_application
{                    pfe$unknown_archive_ident
{                    pfe$unknown_family
{                    pfe$unknown_last_subcatalog
{                    pfe$unknown_master_catalog
{                    pfe$unknown_nth_subcatalog
{                    pfe$unknown_permanent_file
{
*DECK DECK=PFH$PUT_ARCHIVE_INFO EXPAND=FALSE
{
{   The purpose of this request is to put archive entries contained in an info
{ record into the permanent file catalog for a file cycle.  The format of the
{ info record is the the same as the format of the list returned by
{ PFP$GET_ITEM_INFO.  The info record may contain one or more archive entries
{ created by one or more archiving applications.  If one or more archive
{ entries already exist for the file cycle, normal status is returned and the
{ existing archive entries will be unchanged.
{
{       PFP$PUT_ARCHIVE_INFO (PATH, CYCLE_SELECTOR, P_INFO_RECORD, STATUS)
{
{ PATH: (input)  This parameter specifies the identification of a file for
{       which archive entries are to be placed in the permanent file catalog.
{       The path parameter consists of an array of names which identify the
{       path leading through a catalog hierarchy to the desired file.  The
{       first two names specify the family name and master catalog name portion
{       of the path.  By convention, the name of a user's master catalog is the
{       same as the user name.  Subsequent names would specify subcatalogs as
{       applicable.  The last name in the path specifies the file for which
{       archive entries are to be placed in the permanent file catalog.  Null
{       names are allowed only for the family name and master catalog name.  If
{       the family name is osc$null_name, the family name of the job making the
{       request will be used.  If the master catalog name is osc$null_name, the
{       user name of the job making the request will be used.  The file must
{       already exist.
{
{ CYCLE_SELECTOR: (input)  This parameter selects the permanent file cycle for
{       which information is to be registered.  The cycle number determined by
{       this parameter will be used rather than the cycle number contained in
{       the cycle_array_entry parameter.
{
{ P_INFO_RECORD: (input)  This parameter specifies a pointer to the archive
{       list which is to be placed in the permanent file catalog.  The list in
{       the same format as the information returned by PFP$GET_ITEM_INFO.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$bad_archive_identification
{                    pfe$bad_cycle_number
{                    pfe$bad_cycle_option
{                    pfe$bad_family_name
{                    pfe$bad_last_subcatalog_name
{                    pfe$bad_master_catalog_name
{                    pfe$bad_nth_subcatalog_name
{                    pfe$bad_permanent_file_name
{                    pfe$catalog_full
{                    pfe$name_not_permanent_file
{                    pfe$nth_name_not_subcatalog
{                    pfe$path_too_short
{                    pfe$pf_system_error
{                    pfe$unknown_archive_application
{                    pfe$unknown_archive_ident
{                    pfe$unknown_family
{                    pfe$unknown_last_subcatalog
{                    pfe$unknown_master_catalog
{                    pfe$unknown_nth_subcatalog
{                    pfe$unknown_permanent_file
{
*DECK DECK=PFH$PUT_CATALOG_MEDIA_INFO EXPAND=FALSE
{
{   The purpose of this request is to put media information about a
{ catalog into the permanent file system.  This request is intended to be
{ used only by the restore_permanent_files utility when restoring on loss
{ of a catalog device.  This request may only
{ be issued by the system administrator and only after a call to
{ PFP$BUILD_SORTED_DFL is issued.  The media information was obtained by
{ doing a pfp$get_item_item and including pfc$catalog_description and
{ pfc$catalog_media_descriptor in the catalog_info_selections.
{   If the catalog already exists and it is on an active device, no change
{ in the catalog will occur.  If the catalog already exists and it is on
{ an inactive device, the catalog will be recreated.  If the parent catalog media
{ has been recreated by a previous pfp$put_catalog_media_info, then if the
{ file media descriptor in the catalog information describes an active device
{ manager file, that media will be restored.  If the fmd describes an inactive
{ file, the catalog will be recreated.
{
{       PFP$PUT_CATALOG_MEDIA_INFO (PATH, P_CATALOG_GROUP, SET_NAME, RESTORE_CATALOG_STATUS,
{             STATUS)
{
{ PATH: (input) This parameter specifies the name of the catalog being restored.
{
{ P_CATALOG_GROUP: (input) This parameter specifies the catalog information
{       in which the catalog description and media reside.
{
{ SET_NAME: (input) This parameter specifies the set name of the restored item
{       as specified by the backup file.  It must match the set name currently
{       defined for the family.
{
{ RESTORE_CATALOG_STATUS: (output) This parameter returns the status of whether
{       the catalog's location was restored, or the catalog was recreated.
{
{ STATUS: (output) The parameter resturns the request status.  Abnormal
{       status here may be as a result of the parent not existing.  Also if the
{       parent was not recreated, and the catalog was not found then this
{       status will indicate an unknown catalog.
{        CONDITIONS:
{               pfe$last_name_not_subcatalog
{               pfe$unknown_last_subcatalog
{               pfe$unknown_nth_subcatalog
*DECK DECK=PFH$PUT_CYCLE_INFO EXPAND=FALSE
{
{   The purpose of this request is to put information about a file cycle into
{ the permanent file system.  The cycle will be created in an "undefined data"
{ state.  It will not be possible to attach the cycle until a "define_data"
{ request is used to establish data for the cycle.
{
{       PFP$PUT_CYCLE_INFO (PATH, CYCLE_SELECTOR, PASSWORD_SELECTOR,
{             CYCLE_ARRAY_ENTRY, STATUS)
{
{ PATH: (input) This parameter specifies the identification of a file for which
{       cycle information is to be registered.  The path parameter consists of
{       an array of names which identify the path leading through a catalog
{       hierarchy to the desired file.  The first two names specify the family
{       name and master catalog name portion of the path.  By convention, the
{       name of a user's master catalog is the same as the user name.
{       Subsequent names would specify subcatalogs as applicable.  The last
{       name in the path specifies the file for which cycle information is to
{       be registered.  Null names are allowed only for the family name and
{       master catalog name.  If the family name is osc$null_name, the family
{       name of the job making the request will be used.  If the master
{       catalog name is osc$null_name, the user name of the job making the
{       request will be used.
{       If the file does not currently exist it will be created.
{
{ CYCLE_SELECTOR: (input) This parameter selects the permanent file cycle for
{       which information is to be registered.  The cycle number determined by
{       this parameter will be used rather than the cycle number contained in
{       the cycle_array_entry parameter.  If PFC$LOWEST_CYCLE is specified, a
{       cycle one less than the current lowest cycle will be created.  If
{       PFC$HIGHEST_CYCLE is specified, a cycle one greater than the current
{       highest cycle will be created.  If a specific cycle is specified, that
{       cycle will be created.
{
{ PASSWORD_SELECTOR: (input) This parameter specifies a password that must match the
{       password registered with the file.  If pfc$default_password_option is
{       specified,  it will only match for the system or family administrator,
{       or file owner, or for the non-owner if no password is registered
{       with the file.  If pfc$specific_password_option is selected, the
{       supplied password must match the password registered with the
{       file.
{
{ CYCLE_ARRAY_ENTRY: (input) This parameter specifies the information about a
{       cycle that is to be registered for the file identified by the path
{       parameter.  The cycle number field of this parameter is ignored.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$bad_cycle_number
{                    pfe$bad_cycle_option
{                    pfe$bad_family_name
{                    pfe$bad_master_catalog_name
{                    pfe$bad_nth_subcatalog_name
{                    pfe$bad_password
{                    pfe$bad_permanent_file_name
{                    pfe$catalog_full
{                    pfe$cycle_overflow
{                    pfe$cycle_underflow
{                    pfe$duplicate_cycle
{                    pfe$incorrect_password
{                    pfe$name_not_permanent_file
{                    pfe$nth_name_not_subcatalog
{                    pfe$path_too_short
{                    pfe$pf_system_error
{                    pfe$unknown_family
{                    pfe$unknown_master_catalog
{                    pfe$unknown_nth_subcatalog
{                    pfe$unknown_permanent_file
{
{        IDENTIFIER: pfc$permanent_file_manager_id
{
*DECK DECK=PFH$PUT_FAMILY_INFO EXPAND=FALSE
{
{   The purpose of this request is to put information about a family
{ into the permanent file system.  This request may only be issued by the
{ set owner, the system administrator or the family administrator. The specified
{ family must not already exist in the permanent file system.
{
{       PFP$PUT_FAMILY_INFO (SET_NAME, FAMILY_NAME, P_INFO_RECORD, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set for which
{       family catalog information is to be registered.
{
{ FAMILY_NAME: (input) This parameter specifies the family to be created.
{       If this family name is different than the name recorded in P_INFO_RECORD
{       this name will be used. If this parameter is all
{       blanks, the family name of the job making the request will be used.
{
{ P_INFO_RECORD: (input) This parameter specifies an info record containing
{       information about family catalogs that are to be registered on the
{       set identified by the set_name parameter.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$bad_account_name
{                    pfe$bad_family_name
{                    pfe$bad_group_type
{                    pfe$bad_info_record_format
{                    pfe$bad_project_name
{                    pfe$bad_set_name
{                    pfe$bad_user_name
{                    pfe$catalog_full
{                    pfe$duplicate_family
{                    pfe$not_family_owner
{                    pfe$pf_system_error
{                    pfe$unknown_catalog_description
{                    pfe$unknown_set
{
{        IDENTIFIER: pfc$permanent_file_manager_id
{
*DECK DECK=PFH$PUT_ITEM_INFO EXPAND=FALSE
{
{   The purpose of this request is to put information about an item into the
{ permanent file system.  The item may be either a catalog or a file, depending
{ on the contents of the info record specified with the p_info_record
{ parameter.  The name of the item is determined from the path parameter.  If
{ the item is a catalog, an empty catalog is created.  If the item is a file,
{ each cycle of the file will be created in an "undefined data" state, depending
{ on the cycle_selection_criteria parameter.  If archive information is
{ contained in the info record, it is only placed in the catalog entry for the
{ file cycle if the RESTORE_ARCHIVE_INFORMATION parameter is specified as TRUE.
{ Unless a current archive entry exists for a cycle (permitting retrieval of its
{ data from an archive media), it will not be possible to attach the cycle until
{ a PFP$DEFINE_DATA request is used to establish data for it.
{
{   This request only allows subcatalogs to be registered in a catalog owned by
{ the user making the request.  In addition, this request does not allow
{ creation of master catalogs.  Master catalogs are created as a function of
{ the administer utility.
{
{       PFP$PUT_ITEM_INFO (PATH, P_INFO_RECORD, RESTORE_ARCHIVE_INFORMATION,
{         CYCLE_SELECTION_CRITERIA, STATUS)
{
{ PATH: (input)  This parameter specifies the identification of an item for
{       which information is to be registered.  The path parameter consists of
{       an array of names which identify the path leading through a catalog
{       hierarchy to the desired item.  The first two names specify the family
{       name and master catalog name portion of the path.  By convention, the
{       name of a user's master catalog is the same as the user name.
{       Subsequent names would specify subcatalogs as applicable.  The last
{       name in the path specifies the item for which information is to be
{       registered.  Null names are allowed only for the family name and master
{       catalog name.  If the family name is osc$null_name, the family name of
{       the job making the request will be used.  If the master catalog name is
{       osc$null_name, the user name of the job making the request will be
{       used.
{
{ P_INFO_RECORD: (input)  This parameter specifies an info record containing
{       information about an item that is to be registered in the permanent
{       file system.  The info record may be of type pfc$item_info_record,
{       pfc$catalog_group_record or pfc$file_group_record.  This parameter
{       determines if the item to be registered is to be a catalog or a file.
{
{ RESTORE_ARCHIVE_INFORMATION: (input)  This parameter specifies whether or not
{       archive information contained in the info record is to be put into the
{       catalog entry for the file.
{
{ CYCLE_SELECTION_CRITERIA: (input)  This parameter specifies the date and time
{       criteria to be checked when creating the cycles of a file item.  If none
{       of the file's cycles meet the criteria, the file item will be removed.
{       For more information about these criteria, refer to the description of
{       the INCLUDE_CYCLES subcommand of the RESTORE_PERMANENT_FILES utility.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: pfe$bad_account_name
{                   pfe$bad_cycle_number
{                   pfe$bad_family_name
{                   pfe$bad_group_type
{                   pfe$bad_info_record_format
{                   pfe$bad_item_name
{                   pfe$bad_log_option
{                   pfe$bad_master_catalog_name
{                   pfe$bad_nth_subcatalog_name
{                   pfe$bad_password
{                   pfe$bad_project_name
{                   pfe$bad_user_name
{                   pfe$catalog_full
{                   pfe$info_offset_range_error
{                   pfe$name_already_permanent_file
{                   pfe$name_already_subcatalog
{                   pfe$nth_name_not_subcatalog
{                   pfe$path_too_short
{                   pfe$pf_system_error
{                   pfe$too_many_catalogs_in_path
{                   pfe$unknown_catalog_description
{                   pfe$unknown_cycle
{                   pfe$unknown_cycle_array
{                   pfe$unknown_family
{                   pfe$unknown_file_description
{                   pfe$unknown_info_record
{                   pfe$unknown_master_catalog
{                   pfe$unknown_nth_subcatalog
{
*DECK DECK=PFH$PUT_MASTER_CATALOG_INFO EXPAND=FALSE
{
{   The purpose of this request is to put information about a master catalog
{ into the permanent file system.  This request may only be issued by the set
{ owner, the system administrator or the family administrator. The specified
{ master catalog must not already exist in the permanent file system.
{
{       PFP$PUT_MASTER_CATALOG_INFO (SET_NAME, FAMILY_NAME, MASTER_CATALOG_NAME,
{                                      P_INFO_RECORD, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set for which
{       master catalog info is to be registered.
{
{ FAMILY_NAME: (input) This parameter specifies the name of the family for
{       which master catalog info is to be registered. If this parameter is all
{       blanks, the family name of the job making the request will be used.
{
{ MASTER_CATALOG_NAME: (input) This parameter specifies the name of the user
{       to be created.  IF this name is different than that recorded in the
{       P_INFO_RECORD sequence, then this name is used. If this parameter is all
{       blanks, the user name of the job making the request will be used.
{
{ P_INFO_RECORD: (input) This parameter specifies an info record containing
{       information about the master catalog that is to be registered on the
{       family identified by the family_name parameter.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$bad_family_name
{                    pfe$bad_info_record_format
{                    pfe$bad_set_name
{                    pfe$catalog_full
{                    pfe$duplicate_master_catalog
{                    pfe$not_family_owner
{                    pfe$pf_system_error
{                    pfe$unknown_catalog_description
{                    pfe$unknown_family
{                    pfe$unknown_set
{
{        IDENTIFIER: pfc$permanent_file_manager_id
{
*DECK DECK=PFH$R3_ATTACH EXPAND=FALSE
{       PFP$R3_ATTACH
{
{   The purpose of this request is to attach a permanent file to a job for its
{ use.  A local file name is also assigned.  All input/output operations made
{ within the attaching job will be directly from/to the file.
{
{   Access control information is retrieved from the catalogs identified by the
{ path parameter and is used to validate that the user may access the file as
{ requested.  The usage and share selections are verified to ensure that the
{ request does not conflict with current file usage.  NOS/VE allows file
{ sharing among jobs as well as multiple attaches within a job under different
{ local file names as long as no usage or sharing conflicts occur.
{
{ PFP$ATTACH (LFN, PATH, CYCLE_SELECTOR, PASSWORD, USAGE_SELECTIONS,
{       SHARE_SELECTIONS, CYCLE_NUMBER, STATUS)
{
{ LFN: (input) This parameter specifies the local file name to be used
{       within the job to reference the permanent file while attached.
{       If the lfn is already in use by the job the request is terminated
{       and an error status is returned.
{
{ PATH: (input) This parameter specifies the identification of the permanent
{       file.  The path parameter consists of an array of names which identify
{       the path leading through a catalog hierarchy to the desired file.  The
{       first two names specify the family name and master catalog name
{       portion of the path.  By convention, the name of a user's master
{       catalog is the same as the user name.  Subsequent names would specify
{       subcatalogs as applicable.  The last name in the path specifies the
{       permanent file that is to be attached.  Null names are allowed only
{       for the family name and master catalog name.  If the family name is
{       OSC$NULL_NAME, the family name of the job making the request will be
{       used.  If the master catalog name is OSC$NULL_NAME, the user name of
{       the job making the request will be used.
{
{ CYCLE_SELECTOR: (input) This parameter selects the permanent file cycle that
{       is to be attached.  If PFC$LOWEST_CYCLE is specified, the lowest cycle
{       of the file will be attached.  If PFC$HIGHEST_CYCLE is specified, the
{       highest cycle of the file will be attached.  If a specific cycle is
{       specified, that cycle will be attached.
{
{ PASSWORD: (input) This parameter specifies a password that must match the
{       password registered with the file.  If a blank password is specified,
{       it will only match if no password was registered with the file.
{
{ USAGE_SELECTIONS: (input) This parameter specifies how the requestor
{       would like to be able to use the file.
{
{ SHARE_SELECTIONS: (input) This parameter specifies how the requestor
{       is willing to share the file with other requestors.
{
{ CYCLE_NUMBER: (output) This parameter returns the number of the attached
{       cycle.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: pfe$bad_cycle_number
{                   pfe$bad_cycle_option
{                   pfe$bad_family_name
{                   pfe$bad_local_file_name
{                   pfe$bad_master_catalog_name
{                   pfe$bad_nth_subcatalog_name
{                   pfe$bad_password
{                   pfe$bad_permanent_file_name
{                   pfe$catalog_full
{                   pfe$cycle_busy
{                   pfe$incorrect_password
{                   pfe$invalid_ring_access
{                   pfe$lfn_in_use
{                   pfe$name_not_permanent_file
{                   pfe$nth_name_not_subcatalog
{                   pfe$path_too_short
{                   pfe$pf_system_error
{                   pfe$sharing_not_permitted
{                   pfe$undefined_data
{                   pfe$unknown_cycle
{                   pfe$unknown_family
{                   pfe$unknown_master_catalog
{                   pfe$unknown_nth_subcatalog
{                   pfe$unknown_permanent_file
{                   pfe$usage_not_permitted
{                   pfe$user_not_permitted
{
{       IDENTIFIER: pfc$permanent_file_manager_id
{
*DECK DECK=PFH$R3_ATTACH_OR_CREATE_FILE EXPAND=FALSE
{       PFP$R3_ATTACH_OR_CREATE_FILE
{
{   The purpose of this interface is to either attach an existing permanent
{ "phase 1" file or to optionally create a new file of the given name.  This
{ interface is intended as an internal interface for BAM's use only.  This
{ interface resides in the job_template_23D library.
{
{ PFP$R3_ATTACH_OR_CREATE_FILE (VALIDATION_RING, P_ATTACHMENT_OPTIONS,
{       P_FILE_LABEL, EVALUATED_FILE_REFERENCE, ALLOWED_ACCESS "phase 1",
{       SELECTED_ACCESS, REQUIRED_SHARING "phase 1", SELECTED_SHARING,
{       PATH_HANDLE_NAME, FILE_CREATED, LABEL_USED, STATUS)
{
{ VALIDATION_RING: (input) This parameter specifies the ring number of the
{       direct caller.
{
{ P_ATTACHMENT_OPTIONS: (input) This parameter specifies the option(s) to be
{       used on the attach or create of the file.  Only the following cases are
{       used by this interface:
{       = fsc$access_and_share_modes =
{         If more than one access_and_share_modes records are specified, then
{         the first record is considered to be the most preferred one, the
{         second record the next most preferred, etc.  If the access_mode is
{         permitted_access_modes and it implies mode(s) for which the requestor
{         is not ring validated, then access_mode will be reduced to include
{         only those implied mode(s) for which the requestor is ring validated.
{         All access_and_share_modes records, except the last one, which
{         specify an access_mode or a share_mode for which the requestor is not
{         permitted, will be ignored.  Omission will cause an access_mode of
{         permitted_access_modes and a share_mode of
{         determine_from_access_modes to be used.
{       = fsc$create_file =
{         This option may be used to authorize (true) or to prevent (false) the
{         creation of a new file or file cycle in the event that the file
{         specified by the path parameter does not exist.  Cycle permission is
{         required to create a file.  Omission will cause true to be used,
{         unless cycle $HIGH or $LOW was specified by the path parameter, in
{         which case omission will cause false to be used.
{       = fsc$password =
{         If the file is being attached, the specified password must match the
{         preserved password.  If the file is being created, the specified
{         password will be preserved with the file and will be required on all
{         subsequent attaches.  Omission will cause no password to be used.
{       = fsc$validation_ring =  "phase 2"
{         This option specifies the ring number to be used in validating the
{         requested usage for the file.  The value specified may be the ring
{         number of the direct caller, the ring number of the end user, or any
{         other ring number that is greater than or equal to the value
{         specified by the validation_ring parameter.  This ring, the rings
{         stored in the label, and the access_mode from the selected
{         access_and_share_modes record of the attachment_options parameter,
{         are used to verify that the caller has the necessary permission.
{       Note: The wait choice is ignored here.  If the cycle is busy, the
{       condition pfe$cycle_busy is returned to the caller, who must then wait.
{
{ P_FILE_LABEL: (input) This parameter specifies the file label to be
{       associated with the file.  If the label already exists, this parameter
{       is ignored and the label in the catalog entry is passed to the
{       fmp$attach_file interface.  If the label does not already exist (the
{       file may or may not already exist) and the caller has control
{       permission, then the specified label is stored in the permanent file
{       catalog and is passed to the fmp$(attach/create)_file interface and
{       LABEL_USED is set to true.
{
{ EVALUATED_FILE_REFERENCE: (input/output) This parameter identifies the file.
{
{ ALLOWED_ACCESS: (output) "phase 1" This parameter indicates the access modes
{       permitted.  (This is not necessarily the same set as the modes for
{       which the file is attached, i.e. it is a superset of the modes of
{       attachment.)
{
{ SELECTED_ACCESS: (output) This parameter indicates the access modes for which
{       the file is attached.
{
{ REQUIRED_SHARING: (output) "phase 1" This parameter indicates the share modes
{       which are required.  (This is not necessarily the same set as the modes
{       for which this attachment is willing to share the file, i.e. it is a
{       subset of the modes for which this attachment is willing to share the
{       file.)
{
{ SELECTED_SHARING: (output) This parameter indicates the share modes for which
{       this attachment is willing to share the file.
{
{ PATH_HANDLE_NAME: (output) This parameter identifies the path and cycle
{       description entries which represent the attachment of a specific cycle.
{       There is a one-to-one correspondence between the path_handle_name and
{       the file cycle.
{
{ ACTION_TAKEN: (output) This parameter indicates whether a cycle was newly
{       attached, already attached, or created as a result of this operation.
{
{ LABEL_USED: (output) This parameter indicates whether or not the file label
{       supplied was used as a result of this operation.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=PFH$REATTACH_FILES_FOR_CLIENT EXPAND=FALSE
{    This procedure executes on the server mainframe and rebuilds the attached
{ permanent file table from the old attached permanent file table that is
{ recovered in the client_mainframe_file.  This code takes place during system
{ recovery on the server mainframe.
{
{    The old attached permanent file table must not be written by this
{ procedure, but is copied to a new attached permanent file table.  All new
{ structures are allocated.  This procedure must assign the same apfid in the
{ new attached permanent file table as was assigned in the old.  Valid
{ attached file entries found, must be re-attached in the catalog.  This
{ reattach is performed by pfp$reattach_permanent_file.  A new device manager
{ system_file_id is assigned and stored in the new attached permanent file
{ table entry.  The new attached permanent file table entry is left in the
{ awaiting_client state.
{
{    If a file cannot be reattached it will be removed from the new attached
{ file table.  The job will detect this file when in performs
{ fmp$recover_server_files.
{
{       PFP$REATTACH_FILES_FOR_CLIENT (CLIENT_MAINFRAME_ID,
{             P_OLD_ATTACHED_PF_TABLE, FILES_REATTACHED, FILES_NOT_REATTACHED,
{             STATUS)
{
{ CLIENT_MAINFRAME_ID: (input)  This parameter specifies the mainframe for
{       which the attachment is being done for.
{
{ P_OLD_ATTACHED_PF_TABLE: (input)  This parameter specifies location of the
{       old attached permanent file table.  This table may be referenced but
{       must not be changed.  Pointers pointed to from this table may be
{       referenced directly.
{
{ FILES_REATTACHED: (output)  This parameter returns how many files in the job
{       were reattached.
{
{ FILES_NOT_REATTACHED: (output)  This parameter returns how many files in the
{       job were NOT reattached.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=PFH$REATTACH_PERMANENT_FILE EXPAND=FALSE
{
{    The purpose of this procedure is to re-attach (in the device management
{ sense) the specified permanent file.  The apfid and internal_cycle_name
{ (global_file_name) are used to verify that file manager and permanent files
{ are talking about the same file.  The catalog is accessed, and the fmd for
{ the file is used to re-attach the file.  The new sfid is stored in the
{ attached permanent file table.  File manager must update its tables with this
{ new sfid, and must notify the system of this new sfid.
{
{    In this version the catalog is reaccessed with the external path of
{ catalog names stored in the attached permanent file table.  This is NOT the
{ final solution, because this will not work if the name of the catalog has
{ been changed since attach time (not currently supported), or if the catalog
{ is a 'purged' catalog.  This assumes that the attach counts were cleared
{ during recovery.  They are incremented here.  This has the advantage of
{ allowing this code to be transmitted earlier than the catalog changes.  It
{ has the disadvantage of not allowing other new jobs to attach the file
{ asynchrounously to this process, since they might cause the file to go busy.
{ The internal path in the attached permanent file cannot currently be used to
{ search the catalogs since the internal catalog names are currently the global
{ file name, thus coupled physically with device manager.  Reconcilliation has
{ reassigned these names.  The final solution, I believe is to have an internal
{ catalog name that is NOT coupled with the DM global file name.  Thus this
{ internal path could be stored in the attached permanent file table, and used
{ for searching even after reconcilliation/ recovery.  In the version when we
{ have the job name and job's usage in the catalog we should verify that the
{ usage and share in the attached permanent file table match that in the
{ catalog (unless the update_catalog flag in the attached_pf_table is false)
{ and indicate an error if they do not match.  It will probably be possible for
{ the job to have the file attached multiple times.
{
{    If this is called by the client (fmp$recover_files) for a server permanent
{ file this request merely rebuilds the system file table on the client
{ mainframe (see pfp$reattach_server_file).  When the server job recovery
{ executes (fmp$recover_server_files) it calls pfp$relink_server_file which
{ causes the system file table entry to be completed on the client mainframe.
{ On the server mainframe during recovery, this interface is called to reattach
{ all permanent files on behalf of all client jobs on the client mainframe (see
{ pfp$reattach_files_for_client).
{
{       PFP$REATTACH_PERMANENT_FILE (APFID, INTERNAL_NAME, MAINFRAME_ID,
{             USAGE_SELECTIONS, SHARE_SELECTIONS, NEW_SFID, STATUS)
{
{  APFID: (input)  This parameter specifies the attached permenent file to
{        reattach.
{
{ INTERNAL_NAME: (input)  This parameter specifies the global_file_name of the
{       permanent file to re-attach.  This is used for verification.
{
{ MAINFRAME_ID: (input)  This parameter specifies the mainframe on whose behalf
{       is being done for.
{
{ USAGE_SELECTIONS: (input)  This parameter specifies the usage selections that
{       were used on the original attach.  This value should match the value
{       stored in the attached pf table.
{
{ SHARE_SELECTIONS: (input)  This parameter specifies the share selections that
{       were used on the original attach.  This value should match the value
{       stored in the attached pf table.
{
{ NEW_SFID: (output)  This parameter returns the new system_file_id assigned by
{       device manager.
{
{ STATUS: (output) This parameter returns the request status.
*DECK DECK=PFH$RECONCILE_FMD EXPAND=FALSE
{
{ PURPOSE:  This procedure reconciles the fmd of a file cycle using the
{       reconcile_list created by deadstart.  A new fmd will be stored in the
{       catalog if the cycle is attached in write mode and the Device Manager
{       does not have the file attached.  This situation indicates that the
{       system crashed while the cycle was attached in write mode.  This
{       procedure should only be called for file cycles with a device class of
{       mass storage.
{
{       PFP$RECONCILE_FMD (P_PATH, INTERNAL_CYCLE_NAME, EXISTING_SFT_ENTRY,
{         UPDATE_CATALOG, P_CATALOG_FILE, P_CYCLE, P_PHYSICAL_FMD, STATUS)
{
{   P_PATH: (input)  This parameter specifies the path of file cycle.
{
{   INTERNAL_CYCLE_NAME: (input)  This parameter specifies the
{         internal_cycle_name (i.e.  global_file_name) of the cycle.
{
{   EXISTING_SFT_ENTRY: (input)  This parameter indicates the presence of an
{         entry in the system_file_table for the cycle.
{
{   UPDATE_CATALOG: (input)  This parameter specifies if the catalog should be
{         modified.  If the fmd is being reconciled prior to the point of
{         commitment during a continuaton deadstart the catalog cannot be
{         modified.
{
{   P_CATALOG_FILE: (input, output)  This parameter specifies the location of
{         the catalog that contains the cycle.
{
{   P_CYCLE: (input, output)  This parameter specifies the location of the
{         cycle whose fmd will be reconciled.  The attach_counts and stored_fmd
{         in the cycle may be modified.
{
{   P_PHYSICAL_FMD: (input, output)  This parameter returns the reconciled fmd.
{
{   STATUS: (output) This parameter returns the request status.
{
*DECK DECK=PFH$RELEASE_DATA EXPAND=FALSE
{   The purpose of this request is to release the file data associated with a
{ cycle entry. The release of the cycle file data will not be done unless
{ all 'release' criteria associated with the cycle is satisfied, i.e,
{ archiving for
{ the file agreed to release the file.  Only a user with CONTROL access
{ permission may release the file.
{
{   If the file is in use at the time the request is processed, the actual
{ release of the cycle data is not done until the last user returns the file.
{
{       PFP$RELEASE_DATA (PATH, CYCLE_SELECTOR, PASSWORD, STATUS)
{
{ PATH: (input) This parameter specifies the identification of the permanent
{       file.  The path parameter consists of an array of names which identify
{       the path leading through a catalog hierarchy to the desired file.  The
{       first two names specify the family name and master catalog name
{       portion of the path.  By convention, the name of a user's master
{       catalog is the same as the user name.  Subsequent names would specify
{       subcatalogs as applicable.  The last name specifies the permanent file
{       that is to be purged.  Null names are allowed only for the family
{       name and master catalog name.  If the family name is OSC$NULL_NAME,
{       the family name of the job making the request will be used.  If the
{       master catalog name is OSC$NULL_NAME, the user name of the job making
{       the request will be used.
{
{ CYCLE_SELECTOR: (input) This parameter selects the permanent file cycle that
{       is to be released. If PFC$LOWEST_CYCLE is specified, the lowest cycle
{       of the file will be released.  If PFC$HIGHEST_CYCLE is specified, the
{       highest cycle of the file will be released.  If a specific cycle is
{       specified, that cycle will be released.
{
{ PASSWORD: (input) This parameter specifies a password that must match the
{       password registered with the file.  If a blank password is specified,
{       it will only match if no password was registered with the file.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDTIONS:  pfe$bad_cycle_number
{                    pfe$bad_cycle_option
{                    pfe$bad_family_name
{                    pfe$bad_master_catalog_name
{                    pfe$bad_nth_subcatalog_name
{                    pfe$bad_password
{                    pfe$bad_permanent_file_name
{                    pfe$data_not_immediate_released
{                    pfe$data_not_releasable
{                    pfe$incorrect_password
{                    pfe$invalid_ring_access
{                    pfe$name_not_permanent_file
{                    pfe$nth_name_not_subcatalog
{                    pfe$path_too_short
{                    pfe$pf_system_error
{                    pfe$unknown_cycle
{                    pfe$unknown_family
{                    pfe$unknown_master_catalog
{                    pfe$unknown_nth_subcatalog
{                    pfe$unknown_permanent_file
{                    pfe$usage_not_permitted
{
*DECK DECK=PFH$RELINK_SERVER_FILE EXPAND=FALSE
{
{    The purpose of this procedure is to relink a file from the client to the
{ server during server job recovery.  This involves going over to the server,
{ and verifying that the file is still attached on the server.  If the file IS
{ still attached on the server, all the information required to update the
{ device manager and file manager tables on the client is returned back to the
{ client.  The result of the operation on the server (see
{ pfp$relink_file_to_client) is to mark the file as no longer waiting for the
{ client job to recover.  As a result of this operation the lifetime of the
{ file on the client is advanced to the lifetime of the now active server, and
{ access may proceed to the file.  The file manager must set the memory manager
{ access_state to mmc$sas_allow_access.
{
{       PFP$RELINK_SERVER_FILE (OLD_APFID, INTERNAL_NAME, OLD_SFID, NEW_APFID,
{             NEW_SFID, STATUS)
{
{  OLD_APFID:  (Input) This parameter specified the attached permanent file
{        identifier previously associated with the file.
{
{ INTERNAL_NAME:(Input) This parameter specified the global file name for the
{       cycle.
{
{ OLD_SFID:  (Input) This parameter specified the system file identifier that
{       is used to describe the file on the client mainframe.
{
{ NEW_APFID:  (Output) This parameter returns the new attached pf table entry
{       used.
{
{ NEW_SFID:  (Output) This parameter returns the new sfid.  For now this is
{       assumed to be the same as the old sfid and it is not required to
{       replace if.
{
{ STATUS: (output) This parameter returns the request status.
{   If status is abnormal then the file must be changed to indicate that
{    access to the file is terminated.
{
*DECK DECK=PFH$REPLACE_ARCHIVE_ENTRY EXPAND=FALSE
{
{   The purpose of this request is to replace the first archive entry in the
{ archive list for the file cycle which has an archive identification which
{ matches the archive identification specified by the ARCHIVE_IDENTIFICATION
{ parameter.
{
{       PFP$REPLACE_ARCHIVE_ENTRY (PATH, CYCLE_SELECTOR,
{         ARCHIVE_IDENTIFICATION, P_ARCHIVE_ARRAY_ENTRY, P_AMD, STATUS)
{
{ PATH: (input)  This parameter specifies the identification of a file for
{       which an archive entry is to be replaced in the permanent file catalog.
{       The path parameter consists of an array of names which identify the
{       path leading through a catalog hierarchy to the desired file.  The
{       first two names specify the family name and master catalog name portion
{       of the path.  By convention, the name of a user's master catalog is the
{       same as the user name.  Subsequent names would specify subcatalogs as
{       applicable.  The last name in the path specifies the file for which an
{       archive entry is to be replaced in the permanent file catalog.  Null
{       names are allowed only for the family name and master catalog name.  If
{       the family name is OSC$NULL_NAME, the family name of the job making the
{       request will be used.  If the master catalog name is OSC$NULL_NAME, the
{       user name of the job making the request will be used.  The file must
{       already exist.
{
{ CYCLE_SELECTOR: (input)  This parameter selects the permanent file cycle for
{       which an archive entry is to be replaced in the permanent file catalog.
{       The cycle number determined by this parameter will be used rather than
{       the cycle number contained in the cycle_array_entry parameter.
{
{ ARCHIVE_IDENTIFICATION: (input)  This parameter specifies the identification
{       of the archiving application.  The identification consists of the
{       archive application name and a media identifier.  The archive
{       identification is used to locate an archive entry which belongs to the
{       archiving application which owns one of the archive entries for the
{       file.  The media identifier consists of a media device class and a
{       media volume identifier.  If the media device class is specified as
{       OSC$NULL_NAME, the most recently created archive entry belonging to the
{       archive application will be replaced.  If the media volume identifier
{       is specified as OSC$NULL_NAME, it will be ignored in the search for a
{       matching archive entry.  If the media device class and the media volume
{       identifier are both not OSC$NULL_NAME, the most recently created
{       archive entry which matches both will be replaced.
{
{ P_ARCHIVE_ARRAY_ENTRY: (input)  This parameter specifies a pointer to the
{       archive entry which is to replace the existing archiving entry in the
{       catalog.  The entry pointed to is in the format in which
{       PFP$GET_ITEM_INFO retrieves it.
{
{ P_AMD: (input)  This parameter specifies a pointer to the archive media
{       descriptor which is to replace the existing archive media descriptor
{       associated with the archive entry.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: pfe$bad_archive_identification
{                    pfe$bad_cycle_number
{                    pfe$bad_cycle_option
{                    pfe$bad_family_name
{                    pfe$bad_last_subcatalog_name
{                    pfe$bad_master_catalog_name
{                    pfe$bad_nth_subcatalog_name
{                    pfe$bad_permanent_file_name
{                    pfe$catalog_full
{                    pfe$name_not_permanent_file
{                    pfe$nth_name_not_subcatalog
{                    pfe$path_too_short
{                    pfe$pf_system_error
{                    pfe$unknown_archive_application
{                    pfe$unknown_archive_ident
{                    pfe$unknown_family
{                    pfe$unknown_last_subcatalog
{                    pfe$unknown_master_catalog
{                    pfe$unknown_nth_subcatalog
{                    pfe$unknown_permanent_file
{
*DECK DECK=PFH$REPLACE_REM_MEDIA_FMD EXPAND=FALSE
{
{   The purpose of this procedure is to store an FMD in the catalog for a cycle
{ of a permanent tape file.  It cannot be used on a mass storage file.  It
{ allows the restore permanent files utility to store the FMD obtained from the
{ backup file into the catalog.
{
{       PFP$REPLACE_REM_MEDIA_FMD (PATH, CYCLE_SELECTOR, PASSWORD_SELECTOR,
{         P_FMD, STATUS)
{
{ PATH: (input)  This parameter specifies the identification of a permanent
{       file.  The path parameter consists of an array of names which identify
{       the path leading through a catalog hierarchy.  The first two names
{       specify the family name and master catalog name portion of the path.
{       By convention, the name of a user's master catalog is the same as the
{       user name.  Subsequent names would specify subcatalogs as applicable.
{       The last name in the path specifies the permanent file for which cycle
{       data is to be defined.  Null names are allowed only for the family name
{       and master catalog name.  If the family name is OSC$NULL_NAME, the
{       family name of the job making the request will be used.  If the master
{       catalog name is OSC$NULL_NAME, the user name of the job making the
{       request will be used.
{
{ CYCLE_SELECTOR: (input)  This parameter selects the permanent file cycle for
{       which the file label is to be saved.
{
{ PASSWORD_SELECTOR: (input)  This parameter specifies a password that must
{       match the password registered with the file.  If
{       pfc$default_password_option is specified, it will be considered a match
{       for the system or family administrator, the file owner, or a non-owner
{       if no password is registered with the file.  If
{       pfc$specific_password_option is selected, the supplied password must
{       match the password registered with the file.
{
{ P_FMD: (input)  This parameter specifies the FMD that is to be stored in the
{       catalog for the file cycle.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: pfe$bad_cycle_number
{                   pfe$bad_cycle_option
{                   pfe$bad_family_name
{                   pfe$bad_item_name
{                   pfe$bad_last_subcatalog_name
{                   pfe$bad_master_catalog_name
{                   pfe$bad_nth_subcatalog_name
{                   pfe$bad_password
{                   pfe$bad_permanent_file_name
{                   pfe$catalog_full
{                   pfe$duplicate_family_catalog
{                   pfe$duplicate_master_catalog
{                   pfe$incorrect_password
{                   pfe$last_name_not_subcatalog
{                   pfe$name_already_permanent_file
{                   pfe$name_already_subcatalog
{                   pfe$name_not_permanent_file
{                   pfe$nth_name_not_subcatalog
{                   pfe$path_too_short
{                   pfe$pf_system_error
{                   pfe$sharing_not_permitted
{                   pfe$unknown_cycle
{                   pfe$unknown_family
{                   pfe$unknown_item
{                   pfe$unknown_last_subcatalog
{                   pfe$unknown_master_catalog
{                   pfe$unknown_nth_subcatalog
{                   pfe$unknown_permanent_file
{                   pfe$usage_not_permitted
{
*DECK DECK=PFH$RESTRICTED_ATTACH EXPAND=FALSE
{
{   The purpose of this procedure is to provide an attach which does NOT
{ modify the permanent file catalog.  This attach is to be used ONLY by the
{ system job, prior to normal permanent file recovery, and committment.
{ A call to pfp$validate_catalog may be made first to determine if the
{ catalog in which the file resides may be read.
{ If we were to write in the catalog prior to committment, modified pages
{ might not get flushed, and the memory image could NOT be used to extract
{ the pages, thus the possibility of a half updated catalog would exist.
{ This same possibility also exists when we are recovering without an
{ image file.  This attach could also be used by the system in cases where
{ the caller could be certain there would be NO subsequent conflicting
{ usage or no subsequent deletions. There is a slight performance improvement
{ associated with use of this attach.
{   The usage and share are NOT used to verify that the requested usage does not
{ conflict with prior usage.
{ Great care should be taken to insure that the file is NOT deleted during
{ the period the file is attached with the restricted attach.
{ When the file is returned no catalog access is made.
{ The file should be returned prior to recovery.
{ Volume overflow, or underflow of the file is prohibited, and a system error
{ is returned if this occurrs on amp$return. Update of the file label
{ (change_file_attributes) is NOT allowed.
{ The file must reside on the mainframe that is making the request.  This
{ request will NOT cause access to the file server to occur.
{
{
{  PFP$RESTRICTED_ATTACH (LFN, PATH, CYCLE_SELECTOR, PASSWORD, USAGE_SELECTIONS,
{             SHARE_SELECTIONS, STATUS)
{
*DECK DECK=PFH$RETRIEVE_ARCHIVED_FILE EXPAND=FALSE
{
{   The purpose of this procedure is to restore data on mass storage for a file
{ cycle which has been duplicated on archive media and the mass storage space
{ released.  After the data for the file has been restored to mass storage and
{ the permanent file catalog updated, control is returned to the calling
{ procedure which must re-issue the attach in order access the file on mass
{ storage.
{
{       PFP$RETRIEVE_ARCHIVED_FILE (PATH, CYCLE_NUMBER, PASSWORD, WAIT, STATUS)
{
{ PATH: (input)  This parameter specifies the identification of the permanent
{       file.  The path parameter consists of an array of names which identify
{       the path leading through a catalog hierarchy to the desired file.  The
{       first two names specify the family name and master catalog name portion
{       of the path.  By convention, the name of a user's master catalog is the
{       same as the user name.  Subsequent names would specify subcatalogs as
{       applicable.  The last name in the path specifies the permanent file
{       that is to be attached.  Null names are allowed only for the family
{       name and master catalog name.  If the family name is OSC$NULL_NAME, the
{       family name of the job making the request will be used.  If the master
{       catalog name is OSC$NULL_NAME, the user name of the job making the
{       request will be used.
{
{ CYCLE_NUMBER: (input)  This parameter is the cycle number of the file that is
{       to be retrieved.
{
{ PASSWORD: (input)  This parameter specifies a password that must match the
{       password registered with the file.  If a blank password is specified,
{       it will only be considered a match if no password was registered with
{       the file.
{
{ WAIT: (input)  This parameter specifies whether or not to wait for retrieval
{       to mass storage to complete.  If PFC$NO_WAIT is specified, the request
{       to retrieve the file cycle will be queued and an immediate return to
{       the caller will be made.  If PFC$WAIT is specified, a return to the
{       caller will not be made until the retrieval to mass storage is
{       complete.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDTIONS:  pfe$bad_cycle_number
{                    pfe$bad_cycle_option
{                    pfe$bad_family_name
{                    pfe$bad_master_catalog_name
{                    pfe$bad_nth_subcatalog_name
{                    pfe$bad_password
{                    pfe$bad_permanent_file_name
{                    pfe$incorrect_password
{                    pfe$invalid_ring_access
{                    pfe$name_not_permanent_file
{                    pfe$nth_name_not_subcatalog
{                    pfe$path_too_short
{                    pfe$pf_system_error
{                    pfe$unknown_cycle
{                    pfe$unknown_family
{                    pfe$unknown_master_catalog
{                    pfe$unknown_nth_subcatalog
{                    pfe$unknown_permanent_file
{                    pfe$usage_not_permitted
{
*DECK DECK=PFH$RETURN_FILE_INFORMATION EXPAND=FALSE
{       PFP$RETURN_FILE_INFORMATION
{
{
{   The purpose of this request is to return the resources held as a result
{ of a pfp$collect_file_information request, and to invalidate the
{ selection_id.
{
{       PFP$RETURN_FILE_INFORMATION (SELECTION_ID, STATUS)
{
{ SELECTION_ID: (input) This parameter specifies the instance of the
{       pfp$collect_file_information request for which the user wants to
{       return resources.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: pfe$improper_selection_id
{
{       IDENTIFIER: pfc$permanent_file_manager_id
{
*DECK DECK=PFH$RETURN_PERMANENT_FILE EXPAND=FALSE

{
{    The purpose of this request is to return an attached permanent file.
{
{       PFP$RETURN_PERMANENT_FILE (APFID, SYSTEM_FILE_ID,
{            USAGE_SELECTIONS, STATUS)
{
{ APFID: (input) This parameter specifies the permanent file identifier
{       of the attached file to be returned.
{
{ SYSTEM_FILE_ID: (input) This parameter specifies the device manager
{       system file table index.  This is currently only used when the
{       file being returned resides on a server mainframe, in which case the
{       system_file_id indicates the file table entry on the client
{       mainframe.
{
{ USAGE_SELECTIONS: (input) This parameter specifies how the file was attached.

{ STATUS: (output) This parameter returns the request status.
{       If there is an internal error such that the cycle cannot be
{         found in the catalog, the apfid is invalidated.
{       If the status indicated the volume is down, the file is not
{         returned, and the apfid remains valid.  The file may be returned
{         at a later time, when the device is available.
{       If the status indicated the server is terminated, the file tables
{         on the client are removed.
{       If the status indicates an error on the detach, as a result
{         for example, of an mme$io_write_error, the catalog is updated
{         to indicate the current usage is complete and the apfid is
{         invalidated.
{

*DECK DECK=PFH$SAVE_FILE_LABEL EXPAND=FALSE
{   The purpose of this request is to save a label for an attached permanent
{ file.  The label specified with this request replaces any label previously
{ saved for the file.  This request will only be processed for a user having
{ CONTROL permission to the file.
{
{       PFP$SAVE_FILE_LABEL (APFID, P_FILE_LABEL, STATUS)
{
{ APFID: (input) This parameter specifies the attached permanent file
{       identifier of the file for which a label is to be saved.
{
{ P_FILE_LABEL: (input) This parameter specifies the label that is to be saved
{       for the file.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: pfe$catalog_full
{                   pfe$invalid_apfid
{                   pfe$nil_pointer
{                   pfe$pf_system_error
{                   pfe$usage_not_permitted
{                   pfe$user_not_permitted
{
{       IDENTIFIER: pfc$permanent_file_manager_id
{
*DECK DECK=PFH$SAVE_RELEASED_FILE_LABEL EXPAND=FALSE
{
{   The purpose of this procedure is to store the label in the catalog for a
{ permanent file cycle which is not attached.  It allows the label for a file
{ cycle which has had it's mass storage data released to be stored in the
{ catalog by the restore permanent files utility.  This request will only be
{ processed for user's having CONTROL permission on the file.
{
{       PFP$SAVE_RELEASED_FILE_LABEL (PATH, CYCLE_SELECTOR,
{         UPDATE_CYCLE_STATISTICS, PASSWORD_SELECTOR, P_FILE_LABEL, STATUS)
{
{ PATH: (input)  This parameter specifies the identification of a permanent
{       file.  The path parameter consists of an array of names which identify
{       the path leading through a catalog hierarchy.  The first two names
{       specify the family name and master catalog name portion of the path.
{       By convention, the name of a user's master catalog is the same as the
{       user name.  Subsequent names would specify subcatalogs as applicable.
{       The last name in the path specifies the permanent file for which cycle
{       data is to be defined.  Null names are allowed only for the family name
{       and master catalog name.  If the family name is OSC$NULL_NAME, the
{       family name of the job making the request will be used.  If the master
{       catalog name is OSC$NULL_NAME, the user name of the job making the
{       request will be used.
{
{ CYCLE_SELECTOR: (input)  This parameter selects the permanent file cycle for
{       which the file label is to be saved.
{
{ UPDATE_CYCLE_STATISTICS: (input)  This parameter specifies whether or not the
{       cycle's access date/time and modification date/time are to be updated
{       to the current date/time.  The cycle's creation date/time and file log
{       are not changed.
{
{ PASSWORD_SELECTOR: (input)  This parameter specifies a password that must
{       match the password registered with the file.  If
{       pfc$default_password_option is specified, it will be considered a match
{       for the system or family administrator, the file owner, or a non-owner
{       if no password is registered with the file.  If
{       pfc$specific_password_option is selected, the supplied password must
{       match the password registered with the file.
{
{ P_FILE_LABEL: (input)  This parameter specifies the label that is to be
{       stored in the catalog for the file cycle.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: pfe$bad_cycle_number
{                   pfe$bad_cycle_option
{                   pfe$bad_family_name
{                   pfe$bad_item_name
{                   pfe$bad_last_subcatalog_name
{                   pfe$bad_master_catalog_name
{                   pfe$bad_nth_subcatalog_name
{                   pfe$bad_password
{                   pfe$bad_permanent_file_name
{                   pfe$catalog_full
{                   pfe$duplicate_family_catalog
{                   pfe$duplicate_master_catalog
{                   pfe$incorrect_password
{                   pfe$last_name_not_subcatalog
{                   pfe$name_already_permanent_file
{                   pfe$name_already_subcatalog
{                   pfe$name_not_permanent_file
{                   pfe$nth_name_not_subcatalog
{                   pfe$path_too_short
{                   pfe$pf_system_error
{                   pfe$sharing_not_permitted
{                   pfe$unknown_cycle
{                   pfe$unknown_family
{                   pfe$unknown_item
{                   pfe$unknown_last_subcatalog
{                   pfe$unknown_master_catalog
{                   pfe$unknown_nth_subcatalog
{                   pfe$unknown_permanent_file
{                   pfe$usage_not_permitted
{
*DECK DECK=PFH$SET_RESTORE_STATUS EXPAND=FALSE
{
{    he purpose of this request is to set the state of the restore_missing_catalogs
{ process.  This is only provided for the restore_permanent_files utility and
{ is only available for the console job. TRUE indicates that
{ the restore_missing_catalogs process is complete and will cause the
{ 'parent_catalog_recreated' field to be cleared on the next continuation
{ deadstart.  FALSE indicates that the restore_missing_catalogs
{ process has started, and no change will be made during the continuation
{ deadstart.
{
{       PFP$SET_RESTORE_STATUS (RESTORE_MISSING_CATALOGS_DONE, STATUS)
{
{ RESTORE_MISSING_CATALOGS_DONE: (input) This parameter specifies whether the
{      restore_missing_catalogs process is complete.
{
{ STATUS: (output) This parameter returns the request status.
{        CONDITIONS:
{            pfe$not_system_administrator
{
*DECK DECK=PFH$SET_TASK_ENVIRONMENT EXPAND=FALSE
{
{     The purpose of this request is to set up the permanent file
{ environment for a task.  The task is made to look as if it is running
{ on behalf of the user and job described in the client job space
{ parameter.  Previoously established values will not be preserved.
{    This request allows the file server clone tasks on the server, to
{ execute on behalf of a job on the client.
{
{     PFP$SET_TASK_ENVIRONMENT  (P_CLIENT_JOB_SPACE)
{
{  P_CLIENT_JOB_SPACE: (input) This parameter specifies the client
{      environment.  No values in this pointer are changed, however
{      task pointers are constructured to fields in this structure so
{      the values must survive this request.
{
*DECK DECK=PFH$UTILITY_ATTACH EXPAND=FALSE
{   This is an internal interface and should NOT be used out side of the
{ NOS/VE operating system.
{   The purpose of this request is identical to pfp$attach except that cycle
{ statistics for the cycle are not updated.  The log is still updated if logging
{ has been selected for the file.  Callers of this interface may also allow
{ attachment of cycles not normally allowed by pfp$attach.
{
{       PFP$UTILITY_ATTACH (LFN, PATH, CYCLE_SELECTOR, PASSWORD, USAGE_SELECTION,
{             SHARE_SELECTIONS, WAIT, ALLOWED_CYCLE_DAMAGE_SYMPTOMS,
{             CYCLE_DAMAGE_SYMPTOMS, CYCLE_NUMBER, STATUS)
{
{ ALLOWED_CYCLE_DAMAGE_SYMPTOMS:  (input) This parameter specifies that the
{       attach processor should attempt to attach a cycle, even if any of the
{       specified cycle damage symptoms are set.  Some cycle damage symptoms
{       are considered fatal and the cycle will not be attached even if
{       specified in this set.  Fatal cycle damaged symptoms =
{       [fsc$media_missing]
{
{ CYCLE_DAMAGE_SYMPTOMS:  (output) This parameter returns the cycle damage
{       symptoms associated with the cycle.  This parameter is returned even if
{       the file is not attachable due to a fatal cycle damage symptom, or a
{       not allowed cycle damage symptom.
{
{ CYCLE_NUMBER:  (output) This parameter returns the actual cycle number of the
{       cycle attached.
{
*DECK DECK=PFH$VALIDATE_LOCAL_FAMILY EXPAND=TRUE
{
{   The purpose of this request is to validate that the specified family
{ resides in the local mainframe catalog structure.  No request will be
{ made to the server mainframe.  All sets need to be checked for the
{ occurence of this family.
{
{    PFP$VALIDATE_LOCAL_FAMILY (FAMILY_NAME, STATUS)
{
{ FAMILY_NAME: (input) This parameter specifies the family name to validate.
{
{ STATUS: (output) This parameter returns the request status.
{       Conditions:
{          pfe$unknown_family
{
*DECK DECK=PFH$VALIDATE_SITE_OPTIONS EXPAND=FALSE
{
{    The purpose of this procedure is to verify that the user is validated to
{ create a file cycle with the specified SITE_BACKUP_OPTION,
{ SITE_ARCHIVE_OPTION and SITE_RELEASE_OPTION.
{
{    Validation for SITE_BACKUP_OPTION nnn requires the creation of a user name
{ field of SITE_BACKUP_OPTIONS which contains a value of SITE_nnn in one of
{ it's list of values.  Similar validation is required for SITE_ARCHIVE_OPTION
{ and SITE_RELEASE_OPTION.
{
{       PFP$VALIDATE_SITE_OPTIONS (FAMILY_NAME, SITE_ARCHIVE_OPTION,
{             SITE_BACKUP_OPTION, SITE_RELEASE_OPTION, STATUS)
{
{ FAMILY_NAME: (input)  This parameter specifies the name of the family to
{       which the file belongs.
{
{ SITE_ARCHIVE_OPTION: (input)  This parameter specifies the
{       site_archive_option value for the file cycle.
{
{ SITE_BACKUP_OPTION: (input)  This parameter specifies the site_backup_option
{       value for the file cycle.
{
{ SITE_RELEASE_OPTION: (input)  This parameter specifies the
{       site_release_option value for the file cycle.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{           pfe$no_site_option_validation
{
{       IDENTIFIER: pfc$permanent_file_manager_id
{
*DECK DECK=PFI$CONVERT_CYCLE_REFERENCE EXPAND=FALSE

  PROCEDURE [INLINE] pfi$convert_cycle_reference
    (    cycle_reference: fst$cycle_reference;
     VAR cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

    CASE cycle_reference.specification OF
    = fsc$cycle_omitted, fsc$high_cycle, fsc$next_cycle =
      cycle_selector.cycle_option := pfc$highest_cycle;
    = fsc$low_cycle =
      cycle_selector.cycle_option := pfc$lowest_cycle;
    = fsc$cycle_number =
      cycle_selector.cycle_option := pfc$specific_cycle;
      cycle_selector.cycle_number := cycle_reference.cycle_number;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, fse$system_error,
            '', status);
      #keypoint (osk$unusual, 0, fsk$invalid_cycle_specification);
    CASEND;
  PROCEND pfi$convert_cycle_reference;

?? PUSH (LISTEXT := ON) ??
*copyc fse$system_conditions
*copyc fsk$keypoints
*copyc fst$cycle_reference
*copyc osp$set_status_abnormal
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFI$CONVERT_PASSWORD EXPAND=FALSE

  PROCEDURE [INLINE] pfi$convert_password
    (    password: pft$password;
     VAR converted_password: pft$password;
     VAR status: ost$status);

    IF password = osc$null_name THEN
      converted_password := password;
      status.normal := TRUE;
    ELSE
      clp$validate_name (password, converted_password, status.normal);
      IF NOT status.normal THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id,
              pfe$bad_password, password, status);
      IFEND;
    IFEND;
  PROCEND pfi$convert_password;

?? PUSH (LISTEXT := ON) ??
*copyc clp$validate_name
*copyc osp$set_status_abnormal
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFI$GET_CREATE_FILE_OPTION EXPAND=FALSE

  PROCEDURE [INLINE] pfi$get_create_file_option (
        p_attachment_options: {input} ^fst$attachment_options;
        cycle_reference: fst$cycle_reference;
    VAR create_file: boolean);

    VAR
      options_index: ost$positive_integers;

    IF p_attachment_options <> NIL THEN
      FOR options_index := 1 TO UPPERBOUND (p_attachment_options^) DO
        IF p_attachment_options^ [options_index].selector = fsc$create_file THEN
          create_file := p_attachment_options^ [options_index].create_file;
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    create_file := ((cycle_reference.specification <> fsc$high_cycle) AND
          (cycle_reference.specification <> fsc$low_cycle));
  PROCEND pfi$get_create_file_option;

?? PUSH (LISTEXT := ON) ??
*copyc fst$attachment_options
*copyc fst$cycle_reference
*copyc osd$integer_limits
?? POP ??
*DECK DECK=PFI$GET_FAMILY_FROM_FS_STRUCT EXPAND=FALSE
  PROCEDURE [INLINE] pfi$get_family_from_fs_struct
    (    evaluated_file_reference: fst$evaluated_file_reference;
     VAR family_name: ost$family_name);

    family_name := evaluated_file_reference.
          path_structure (2, $INTEGER (evaluated_file_reference.
          path_structure (1)));
  PROCEND pfi$get_family_from_fs_struct;
*DECK DECK=PFI$GET_PASSWORD EXPAND=FALSE

  PROCEDURE [INLINE] pfi$get_password (
        p_attachment_options: {input} ^fst$attachment_options;
    VAR found: boolean;
    VAR password: pft$password);

    VAR
      options_index: ost$positive_integers;

    IF p_attachment_options <> NIL THEN
      FOR options_index := 1 TO UPPERBOUND (p_attachment_options^) DO
        IF p_attachment_options^ [options_index].selector = fsc$password THEN
          found := TRUE;
          password := p_attachment_options^ [options_index].password;
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    found := FALSE;
    password := osc$null_name;
  PROCEND pfi$get_password;

?? PUSH (LISTEXT := ON) ??
*copyc fst$attachment_options
*copyc osd$integer_limits
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFI$STORE_FILE_MEDIA_DESCRIPTOR EXPAND=FALSE

  PROCEDURE [INLINE] pfi$store_file_media_descriptor
    (    p_fmd: {input^} ^SEQ ( * );
         p_catalog_file: {i^/o^} ^pft$catalog_file;
         p_cycle: {i^/o^} pft$p_cycle;
     VAR status: ost$status);

    VAR
      new_stored_fmd: boolean,
      p_new_stored_fmd: pft$p_physical_fmd,
      p_old_stored_fmd: pft$p_physical_fmd;

    status.normal := TRUE;

    pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, p_catalog_file, p_old_stored_fmd);
    IF (p_old_stored_fmd = NIL) OR (#SIZE (p_fmd^) <> #SIZE (p_old_stored_fmd^.fmd)) THEN
      ALLOCATE p_new_stored_fmd: [[REP (#SIZE (p_fmd^)) OF cell]] IN p_catalog_file^.catalog_heap;
      IF p_new_stored_fmd = NIL THEN
        new_stored_fmd := FALSE;
        osp$set_status_condition (pfe$catalog_full, status);
      ELSE
        p_new_stored_fmd^.fmd := p_fmd^;
        pfp$compute_checksum (#LOC (p_fmd^), #SIZE (p_fmd^), p_new_stored_fmd^.checksum);
        new_stored_fmd := TRUE;
      IFEND;
    ELSE
      p_old_stored_fmd^.fmd := p_fmd^;
      pfp$compute_checksum (#LOC (p_fmd^), #SIZE (p_fmd^), p_old_stored_fmd^.checksum);
      new_stored_fmd := FALSE;
    IFEND;

    IF status.normal AND new_stored_fmd THEN
      pfp$build_fmd_locator (p_new_stored_fmd, p_catalog_file, p_cycle^.cycle_entry.fmd_locator);
      pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
      IF p_old_stored_fmd <> NIL THEN
        FREE p_old_stored_fmd IN p_catalog_file^.catalog_heap;
      IFEND;
    IFEND;

  PROCEND pfi$store_file_media_descriptor;

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
*copyc pfp$build_fmd_locator
*copyc pfp$build_fmd_pointer
*copyc pfp$compute_checksum
?? POP ??
*DECK DECK=PFK$KEYPOINTS EXPAND=FALSE

{ This deck contains all of the permanent file manager keypoint constants.

  CONST

    { ENTRY/EXIT CLASS KEYPOINTS }

    pfk$attach = pfk$base,
    {E 'pfp$attach'}
    {X 'pfp$attach'}

    pfk$change = pfk$base + 1,
    {E 'pfp$change' 'callring' I20}
    {X 'pfp$change'}

    pfk$change_family_name = pfk$base + 2,
    {E 'pfp$change_family_name'}
    {X 'pfp$change_family_name'}

    pfk$clear_catalog_alarm = pfk$base + 3,
    {E 'pfp$clear_catalog_alarm'}
    {X 'pfp$clear_catalog_alarm'}

    pfk$collect_file_information = pfk$base + 4,
    {E 'pfp$collect_file_information' 'callring' I20}
    {X 'pfp$collect_file_information'}

    pfk$define = pfk$base + 5,
    {E 'pfp$define' 'callring' I20}
    {X 'pfp$define'}

    pfk$define_catalog = pfk$base + 6,
    {E 'pfp$define_catalog' 'callring' I20}
    {X 'pfp$define_catalog'}

    pfk$define_data = pfk$base + 7,
    {E 'pfp$define_data' 'callring' I20}
    {X 'pfp$define_data'}

    pfk$define_mass_storage_catalog = pfk$base + 8,
    {E 'pfp$define_mass_storage_catalog'}
    {X 'pfp$define_mass_storage_catalog'}

    pfk$define_master_catalog = pfk$base + 9,
    {E 'pfp$define_master_catalog' 'callring' I20}
    {X 'pfp$define_master_catalog'}

    pfk$delete_all_archive_entries = pfk$base + 10,
    {E 'pfp$delete_all_archive_entries' 'callring' I20}
    {X 'pfp$delete_all_archive_entries'}

    pfk$delete_archive_entry = pfk$base + 11,
    {E 'pfp$delete_archive_entry' 'callring' I20}
    {X 'pfp$delete_archive_entry'}

    pfk$delete_catalog_permit = pfk$base + 12,
    {E 'pfp$delete_catalog_permit' 'callring' I20}
    {X 'pfp$delete_catalog_permit'}

    pfk$delete_permit = pfk$base + 13,
    {E 'pfp$delete_permit' 'callring' I20}
    {X 'pfp$delete_permit'}

    pfk$find_archive_info = pfk$base + 14,
    {E 'pfp$find_archive_info'}
    {X 'pfp$find_archive_info'}

    pfk$find_catalog_description = pfk$base + 15,
    {E 'pfp$find_catalog_description'}
    {X 'pfp$find_catalog_description'}

    pfk$find_cycle_array = pfk$base + 16,
    {E 'pfp$find_cycle_array'}
    {X 'pfp$find_cycle_array'}

    pfk$find_cycle_array_version_2 = pfk$base + 17,
    {E 'pfp$find_cycle_array_version_2'}
    {X 'pfp$find_cycle_array_version_2'}

    pfk$find_cycle_entry = pfk$base + 18,
    {E 'pfp$find_cycle_entry'}
    {X 'pfp$find_cycle_entry'}

    pfk$find_cycle_entry_version_2 = pfk$base + 19,
    {E 'pfp$find_cycle_entry_version_2'}
    {X 'pfp$find_cycle_entry_version_2'}

    pfk$find_cycle_label = pfk$base + 20,
    {E 'pfp$find_cycle_label'}
    {X 'pfp$find_cycle_label'}

    pfk$find_direct_info_record = pfk$base + 21,
    {E 'pfp$find_direct_info_record'}
    {X 'pfp$find_direct_info_record'}

    pfk$find_directory_array = pfk$base + 22,
    {E 'pfp$find_directory_array'}
    {X 'pfp$find_directory_array'}

    pfk$find_file_description = pfk$base + 23,
    {E 'pfp$find_file_description'}
    {X 'pfp$find_file_description'}

    pfk$find_log_array = pfk$base + 24,
    {E 'pfp$find_log_array'}
    {X 'pfp$find_log_array'}

    pfk$find_media = pfk$base + 25,
    {E 'pfp$find_catalog/cycle_media'}
    {X 'pfp$find_catalog/cycle_media'}

    pfk$find_next_archive_entry = pfk$base + 26,
    {E 'pfp$find_next_archive_entry'}
    {X 'pfp$find_next_archive_entry'}

    pfk$find_next_info_record = pfk$base + 27,
    {E 'pfp$find_next_info_record'}
    {X 'pfp$find_next_info_record'}

    pfk$find_permit_array = pfk$base + 28,
    {E 'pfp$find_permit_array'}
    {X 'pfp$find_permit_array'}

    pfk$get_attached_pf_table = pfk$base + 29,
    {E 'pfp$get_attached_pf_table'}
    {X 'pfp$get_attached_pf_table'}

    pfk$get_catalog = pfk$base + 30,
    {E 'pfp$get_catalog' 'pathleng' I20}
    {X 'pfp$get_catalog'}

    pfk$get_catalog_alarm_table = pfk$base + 31,
    {E 'pfp$get_catalog_alarm_table'}
    {X 'pfp$get_catalog_alarm_table'}

    pfk$get_catalog_segment = pfk$base + 32,
    {E 'pfp$get_catalog_segment' 'callring' I20}
    {X 'pfp$get_catalog_segment'}

    pfk$get_family_info = pfk$base + 33,
    {E 'pfp$get_family_info' 'callring' I20}
    {X 'pfp$get_family_info'}

    pfk$get_family_set = pfk$base + 34,
    {E 'pfp$get_family_set' 'callring' I20}
    {X 'pfp$get_family_set'}

    pfk$get_item_info = pfk$base + 35,
    {E 'pfp$get_item_info' 'callring' I20}
    {X 'pfp$get_item_info'}

    pfk$get_master_catalog_info = pfk$base + 36,
    {E 'pfp$get_master_catalog_info' 'callring' I20}
    {X 'pfp$get_master_catalog_info'}

    pfk$get_multi_item_info = pfk$base + 37,
    {E 'pfp$get_multi_item_info' 'callring' I20}
    {X 'pfp$get_multi_item_info'}

    pfk$get_next_file_selection = pfk$base + 38,
    {E 'pfp$get_next_file_selection' 'callring' I20}
    {X 'pfp$get_next_file_selection'}

    pfk$get_object_information = pfk$base + 39,
    {E 'pfp$get_object_information'}
    {X 'pfp$get_object_information'}

    pfk$get_queued_catalog_table = pfk$base + 40,
    {E 'pfp$get_queued_catalog_table'}
    {X 'pfp$get_queued_catalog_table'}

    pfk$get_stored_fmd = pfk$base + 41,
    {E 'pfk$get_stored_fmd' 'callring' I20}
    {X 'pfk$get_stored_fmd'}

    pfk$get_stored_fmd_size = pfk$base + 42,
    {E 'pfk$get_stored_fmd_size' 'callring' I20}
    {X 'pfk$get_stored_fmd_size'}

    pfk$internal_locate_object = pfk$base + 43,
    {E 'pfp$internal_locate_object'}
    {X 'pfp$internal_locate_object' 'index' I20}

    pfk$locate_object = pfk$base + 44,
    {E 'pfp$locate_object'}
    {X 'pfp$locate_object' 'index' I20}

    pfk$mark_release_candidate = pfk$base + 45,
    {E 'pfp$mark_release_candidate' 'callring' I20}
    {X 'pfp$mark_release_candidate'}

    pfk$overhaul_catalog = pfk$base + 46,
    {E 'pfp$overhaul_catalog' 'callring' I20}
    {X 'pfp$overhaul_catalog'}

    pfk$overhaul_set = pfk$base + 47,
    {E 'pfp$overhaul_set' 'callring' I20}
    {X 'pfp$overhaul_set'}

    pfk$permit = pfk$base + 48,
    {E 'pfp$permit' 'callring' I20}
    {X 'pfp$permit'}

    pfk$permit_catalog = pfk$base + 49,
    {E 'pfp$permit_catalog' 'callring' I20}
    {X 'pfp$permit_catalog'}

    pfk$purge = pfk$base + 50,
    {E 'pfp$purge' 'callring' I20}
    {X 'pfp$purge'}

    pfk$purge_catalog = pfk$base + 51,
    {E 'pfp$purge_catalog' 'callring' I20}
    {X 'pfp$purge_catalog'}

    pfk$purge_master_catalog = pfk$base + 52,
    {E 'pfp$purge_master_catalog' 'callring' I20}
    {X 'pfp$purge_master_catalog'}

    pfk$put_archive_entry = pfk$base + 53,
    {E 'pfp$put_archive_entry' 'callring' I20}
    {X 'pfp$put_archive_entry'}

    pfk$put_archive_info = pfk$base + 54,
    {E 'pfp$put_archive_info' 'callring' I20}
    {X 'pfp$put_archive_info'}

    pfk$put_catalog_media_info = pfk$base + 55,
    {E 'pfp$put_catalog_media_info'}
    {X 'pfp$put_catalog_media_info'}

    pfk$put_cycle_info = pfk$base + 56,
    {E 'pfp$put_cycle_info' 'callring' I20}
    {X 'pfp$put_cycle_info'}

    pfk$put_family_info = pfk$base + 57,
    {E 'pfp$put_family_info' 'callring' I20}
    {X 'pfp$put_family_info'}

    pfk$put_file_media_info = pfk$base + 58,
    {E 'pfp$put_file_media_info'}
    {X 'pfp$put_file_media_info'}

    pfk$put_item_info = pfk$base + 59,
    {E 'pfp$put_item_info' 'callring' I20}
    {X 'pfp$put_item_info'}

    pfk$put_master_catalog_info = pfk$base + 60,
    {E 'pfp$put_master_catalog_info' 'callring' I20}
    {X 'pfp$put_master_catalog_info'}

    pfk$r3_attach_or_create_file = pfk$base + 61,
    {E 'pfp$r3_attach_or_create_file' 'callring' I20}
    {X 'pfp$r3_attach_or_create_file'}

    pfk$reattach_permanent_file = pfk$base + 62,
    {E 'pfp$reattach_permanent_file' 'apfid' I20}
    {X 'pfp$reattach_permanent_file'}

    pfk$release_data = pfk$base + 63,
    {E 'pfp$release_data' 'callring' I20}
    {X 'pfp$release_data'}

    pfk$replace_archive_entry = pfk$base + 64,
    {E 'pfp$replace_archive_entry' 'callring' I20}
    {X 'pfp$replace_archive_entry'}

    pfk$restricted_attach = pfk$base + 65,
    {E 'pfp$restricted_attach' 'callring' I20}
    {X 'pfp$restricted_attach'}

    pfk$return_file_information = pfk$base + 66,
    {E 'pfp$return_file_information' 'callring' I20}
    {X 'pfp$return_file_information'}

    pfk$return_permanent_file = pfk$base + 67,
    {E 'pfp$return_permanent_file' 'apfid' I20}
    {X 'pfp$return_permanent_file'}

    pfk$save_file_label = pfk$base + 68,
    {E 'pfp$save_file_label' 'apfid' I20}
    {X 'pfp$save_file_label'}

    pfk$save_released_file_label = pfk$base + 69,
    {E 'pfp$save_released_file_label' 'callring' I20}
    {X 'pfp$save_released_file_label'}

    pfk$set_catalog_alarm = pfk$base + 70,
    {E 'pfp$set_catalog_alarm'}
    {X 'pfp$set_catalog_alarm' 'index' I20}

    pfk$start_retrieve = pfk$base + 71,
    {E 'pfp$retrieve_archived_file'}
    {X 'pfp$retrieve_archived_file'}

    pfk$utility_attach = pfk$base + 72,
    {E 'pfp$utility_attach'}
    {X 'pfp$utility_attach'}

    pfk$verify_pva = pfk$base + 73,
    {E 'pfp$verify_pva' 'callring' I20}
    {X 'pfp$verify_pva'}


    { UNUSUAL CLASS KEYPOINTS }

    pfk$invalid_amd = pfk$base + 28,
    {U 'invalid archive media descriptor'}

    pfk$invalid_archive_entry = pfk$base + 29,
    {U 'invalid archive entry'}

    pfk$invalid_catalog_header = pfk$base + 30,
    {U 'invalid catalog header'}

    pfk$invalid_cycle_entry = pfk$base + 31,
    {U 'invalid cycle_entry'}

    pfk$invalid_file_label_entry = pfk$base + 32,
    {U 'invalid file label entry'}

    pfk$invalid_fmd_entry = pfk$base + 33,
    {U 'invalid fmd entry'}

    pfk$invalid_log_entry = pfk$base + 34,
    {U 'invalid log entry'}

    pfk$invalid_object_entry = pfk$base + 35,
    {U 'invalid object entry'}

    pfk$invalid_permit_entry = pfk$base + 36,
    {U 'invalid permit entry'}

    pfk$job_pageable_full = pfk$base + 38,
    {U 'job pageable heap full'}

    pfk$unknown_internal_cycle = pfk$base + 78,
    {U 'unknown internal cycle'}

    pfk$unknown_internal_path = pfk$base + 79,
    {U 'unknown internal path'}


    { DEBUG CLASS KEYPOINTS }

    pfk$apfid_assigned = pfk$base + 1,
    {D 'apfid assigned' 'apfid' I20}

    pfk$attach_last_queued_catalog = pfk$base + 2,
    {D 'pfp$attach_last_queued_catalog' 'pathindx' I20}

    pfk$file_server_request = pfk$base + 20,
    {D 'PF file server request' 'sfti' I20}

    pfk$invalid_apfid = pfk$base + 32,
    {D 'invalid apfid' 'apfid' I20}

    pfk$queued_catalog_found = pfk$base + 62,
    {D 'catalog found queued'}

    pfk$record_dm_file_parameters = pfk$base + 66;
    {D 'pfp$record_dm_file_parameters'}

?? PUSH (LISTEXT := ON) ??
*copyc amk$base_keypoint_values
?? POP ??
*DECK DECK=PFM$ACTION_MESSAGES EXPAND=TRUE
~"CREATE_MESSAGE_MODULE PFM$MOVC_INSUF_SPACE$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                     NOS/VE MOVE_CLASSES Insufficient Space Menu

  Status             : Insufficient mass storage space to move a ~P1.
  Job Name           : ~P2
  Mass Storage Class : ~P3
  Mass Storage Set   : ~P4
  Path               : ~P5
  Allocated Size     : ~P6

    You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=RETRY_MOVE
       1 - Retry.  Make additional class ~P3 space available before you respond.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=SKIP_OBJECT
       2 - Skip the ~P1 and continue the MOVE_CLASSES command.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TERMINATE_COMMAND
       3 - Terminate the MOVE_CLASSES command.
~"**
~"CREATE_FULL_HELP_MESSAGE
      This menu is presented because a job executing the MOVE_CLASSES
      command attempted to move a file or catalog but sufficient mass storage
      space of the required mass storage class was not available on the set.
      Additional mass storage space may be made available by adding the class
      to another volume in the set, by adding a new volume to the set, by
      deleting files or catalogs in the set, or by releasing the mass storage
      image of duplicated files that reside on the set.

~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=RETRY_MOVE
      This choice notifies the job that another attempt to move the file or
      catalog should be made.  If the move fails due to insufficient mass
      storage space, this menu will be presented again.

~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=SKIP_OBJECT
     This choice notifies the job to skip the file or catalog and attempt
     to move the next file or catalog.  If the move fails on the next file
     or catalog due to insufficient mass storage space, this menu will be
     presented again.

~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=TERMINATE_COMMAND
     This choice notifies the job to terminate the MOVE_CLASSES command.

~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"CREATE_MESSAGE_MODULE PFM$MOVC_NO_SPACE$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                     NOS/VE MOVE_CLASSES Out of Space Menu

  Status             : No remaining mass storage space to move a ~P1.
  Job Name           : ~P2
  Mass Storage Class : ~P3
  Mass Storage Set   : ~P4
  Path               : ~P5
  Allocated Size     : ~P6

    You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=RETRY_MOVE
       1 - Retry.  Make additional class ~P3 space available before you respond.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=SKIP_OBJECT
       2 - Skip the ~P1 and continue the MOVE_CLASSES command. No objects
           of class ~P3 can be moved unless additional space is made available.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TERMINATE_COMMAND
       3 - Terminate the MOVE_CLASSES command.
~"**
~"CREATE_FULL_HELP_MESSAGE
      This menu is presented because a job executing the MOVE_CLASSES
      command attempted to move a file or catalog but no remaining mass storage
      space of the required mass storage class was available on the set.
      Additional mass storage space may be made available by adding the class
      to another volume in the set, by adding a new volume to the set, by
      deleting files or catalogs in the set, or by releasing the mass storage
      image of duplicated files that reside on the set.

~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=RETRY_MOVE
      This choice notifies the job that another attempt to move the file or
      catalog should be made.  If the move fails due to no available mass
      storage space, this menu will be presented again.

~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=SKIP_OBJECT
     This choice notifies the job to skip the file or catalog and attempt
     to move the next file or catalog.  If the move fails on the next file
     or catalog due to no available mass storage space, this menu will be
     presented again.

~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=TERMINATE_COMMAND
     This choice notifies the job to terminate the MOVE_CLASSES command.

~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
*DECK DECK=PFM$ARCHIVE_RETRIEVE_CONTROL EXPAND=TRUE
*copyc osd$default_pragmats
?? RIGHT := 110 ??
MODULE pfm$archive_retrieve_control;
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_command_processing
*copyc pfd$permanent_file_definitions
*copyc pfd$catalog
*copyc pfd$catalog_info
*copyc pfe$selection_errors
*copyc pfk$keypoints
*copyc ost$wait
?? POP ??

*copyc clp$include_line
*copyc pfp$convert_pf_cy_path_to_strng
*copyc pmp$get_job_names
*copyc ofp$display_status_message
*copyc ofp$get_display_status_message

?? TITLE := '*** PFP$RETRIEVE_ARCHIVED_FILE ***', EJECT ??
*copy pfh$retrieve_archived_file

  PROCEDURE [XDCL, #GATE] pfp$retrieve_archived_file
    (    path: pft$path;
         cycle_number: pft$cycle_number;
         password: pft$password;
         wait: ost$wait;
     VAR status: ost$status);

    VAR
      original_display_message: oft$display_message,
      password_value: pft$password,
      path_string: ost$string,
      retrieve_call: string (500),
      retrieve_call_length: integer,
      wait_value: boolean;

    #KEYPOINT (osk$entry, 0, pfk$start_retrieve);

    status.normal := TRUE;

  /process_request/
    BEGIN

      IF wait = osc$wait THEN
        get_current_display_message (original_display_message);
        display_retrieval_message (path [UPPERBOUND (path)], cycle_number);
      IFEND;

      pfp$convert_pf_cy_path_to_strng (path, cycle_number, path_string);

      IF password = osc$null_name THEN
        password_value := 'none';
      ELSE
        password_value := password;
      IFEND;

      IF wait = osc$wait THEN
        wait_value := TRUE;
      ELSEIF wait = osc$nowait THEN
        wait_value := FALSE;
      IFEND;

      STRINGREP (retrieve_call, retrieve_call_length, '$system.osf$command_library.retrieve_file',
            ' file=', path_string.value (1, path_string.size), ' password=', password_value, ' wait=',
            wait_value);

      clp$include_line (retrieve_call (1, retrieve_call_length), { enable_echoing } TRUE,
            { utility } osc$null_name, status);


      IF NOT status.normal AND (status.condition = cle$file_dot_cmnd_not_allowed) THEN

{ If we cannot call $system.osf$command_library.retrieve_file, try to call
{ it using a simple retrieve_file call.  This is done so a site can have a
{ fence defined for their users and still be able to make implicit calls
{ to retrieve_file.

        STRINGREP (retrieve_call, retrieve_call_length, 'retrieve_file',
              ' file=', path_string.value (1, path_string.size), ' password=', password_value, ' wait=',
              wait_value);

        clp$include_line (retrieve_call (1, retrieve_call_length), { enable_echoing } TRUE,
              { utility } osc$null_name, status);
      IFEND;

      IF wait = osc$wait THEN
        clear_wait_message (original_display_message);
      IFEND;

    END /process_request/;

    #KEYPOINT (osk$exit, 0, pfk$start_retrieve);

  PROCEND pfp$retrieve_archived_file;

?? TITLE := '*** CLEAR_WAIT_MESSAGE ***', EJECT ??

  PROCEDURE clear_wait_message
    (    original_display_message: oft$display_message);

    CONST
      continuing_message = 'Continuing: ',
      continuing_message_size = 12;

    VAR
      ignored_status: ost$status,
      message_length: integer,
      message_string: string (ofc$max_display_message);

    IF original_display_message.text (1, continuing_message_size) = continuing_message THEN
      message_length := original_display_message.size;
      message_string := original_display_message.text (1, message_length);
    ELSE
      STRINGREP (message_string, message_length, continuing_message, original_display_message.
            text (1, original_display_message.size));
    IFEND;

    ofp$display_status_message (message_string (1, message_length), ignored_status);

  PROCEND clear_wait_message;

?? TITLE := '*** DISPLAY_RETRIEVAL_MESSAGE ***', EJECT ??

  PROCEDURE display_retrieval_message
    (    file_name: pft$name;
         cycle_number: pft$cycle_number);

    VAR
      ignored_status: ost$status,
      message_length: integer,
      message_string: string (ofc$max_display_message);

    STRINGREP (message_string, message_length, 'Retrieving cycle ', cycle_number, ' of file ', file_name);

    ofp$display_status_message (message_string (1, message_length), ignored_status);

  PROCEND display_retrieval_message;

?? TITLE := '*** GET_CURRENT_DISPLAY_MESSAGE ***', EJECT ??

  PROCEDURE get_current_display_message
    (VAR current_display_message: oft$display_message);

    VAR
      local_status: ost$status,
      system_supplied_name: jmt$system_supplied_name,
      user_name: jmt$user_supplied_name;

    pmp$get_job_names (user_name, system_supplied_name, local_status);
    IF NOT local_status.normal THEN
      current_display_message.size := 7;
      current_display_message.text := 'UNKNOWN';
      RETURN;
    IFEND;

    ofp$get_display_status_message (system_supplied_name, current_display_message, local_status);
    IF NOT local_status.normal THEN
      current_display_message.size := 7;
      current_display_message.text := 'UNKNOWN';
    IFEND;

  PROCEND get_current_display_message;

MODEND pfm$archive_retrieve_control;

*DECK DECK=PFM$ATTACHED_PF_TABLE EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
MODULE pfm$attached_pf_table;

{
{ PURPOSE:
{   This module manages the attached pf table.  The pointer to the attached
{   pf table as well as the table lock are static variables in this module.
{   This module must reside in ring 2.
{ DESIGN:
{   This module assumes that locking of the requests is accomplished by
{   use of the file manager locking, and is done outside of this module.

?? PUSH (LISTEXT := ON) ??
*copyc dfi$display
*copyc dfv$file_server_debug_enabled
*copyc ofp$display_status_message
*copyc ose$job_recovery_exceptions
*copyc osp$append_status_integer
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$log_job_recovery_message
*copyc osp$log_job_recovery_status
*copyc osp$set_status_abnormal
*copyc oss$task_shared
*copyc ost$heap
*copyc ost$status
*copyc osv$initial_exception_context
*copyc pfd$attached_pf_table
*copyc pfd$attached_permanent_file_id
*copyc pfd$table_info
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pfk$keypoints
*copyc pfp$catalog_access_retry_wait
*copyc pfp$convert_cycle_path_to_strng
*copyc pfp$internal_return_file
*copyc pfp$process_unexpected_status
*copyc pfp$reattach_permanent_file
*copyc pft$attached_pf_table_index
*copyc pft$return_files_option
*copyc pfv$p_p_attached_pf_table
*copyc pfv$p_p_job_heap
*copyc pmp$log_ascii
*copyc pmt$binary_mainframe_id
?? POP ??

  VAR
    pfv$p_attached_pf_table: [XDCL, #GATE, oss$task_shared] pft$p_attached_pf_table := NIL;

?? TITLE := '*** PFP$ASSIGN_LOCKED_APFID *** ', EJECT ??

{ PURPOSE:
{   This procedure gets an unused entry in the attached pf table,
{   and stores a NIL for the pointer to the attached pf entry.

  PROCEDURE [XDCL] pfp$assign_locked_apfid
    (VAR apfid: pft$attached_pf_table_index;
     VAR status: ost$status);

    get_unused_apft_entry (apfid, status);
    IF status.normal THEN
      pfv$p_p_attached_pf_table^^ [apfid].entry_type := pfc$attached_pf_entry_valid;
      pfv$p_p_attached_pf_table^^ [apfid].p_attached_pf_entry := NIL;
      #KEYPOINT (osk$debug, osk$m * apfid, pfk$apfid_assigned);
    IFEND;

  PROCEND pfp$assign_locked_apfid;
?? TITLE := '*** PFP$COMPLETE_JOB_RECOVERY ***', EJECT ??

{  This procedure verifies that all files that permanent files knows about
{  as being attached have been reattached by the file manager.
{  Possible states for the file at this time are:
{  - normal cycle
{    The file is attached in the catalog and file manager cycle description
{    knows about it.
{ - attached_pf_in_job_recovery
{    The file has no cycle description, is not attached in the catalog, but
{    an entry exists in the attached pf table, that must be removed.
{ - attached_pf_awaiting_client
{   The file has no cycle description, is attached in the catalog and in the
{   attached pf table.  The file must be detached from the catalog.

  PROCEDURE [XDCL, #GATE] pfp$complete_job_recovery
    (     mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

    VAR
      apft_index: pft$attached_pf_table_index,
      authority: pft$authority,
      bytes_allocated_change: sft$counter,
      log_status: ost$status,
      p_complete_path: ^pft$complete_path,
      path_string: ost$string,
      return_status: ost$status,
      unrecovered_pf_count: integer;

    status.normal := TRUE;
    unrecovered_pf_count := 0;
    IF pfv$p_p_attached_pf_table^ <> NIL THEN

    /verify_all_files/
      FOR apft_index := LOWERBOUND (pfv$p_p_attached_pf_table^^)
            TO UPPERBOUND (pfv$p_p_attached_pf_table^^) DO
        IF pfv$p_p_attached_pf_table^^ [apft_index].entry_type = pfc$attached_pf_entry_valid THEN
          CASE pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.sfid_status.recovery_state OF
          = pfc$attached_pf_in_job_recovery =
            unrecovered_pf_count := unrecovered_pf_count + 1;
            { The permanent file has NOT been reattached.
            { The attachement will be broken when:
            { this particular attach causes a cycle busy, OR
            { on the next pf recovery.
            { Alternately we could reaccess the catalog and decrement the access
            { count. This may be preferable since this would allow the current
            { job to continue, and re-attach the file, without making
            { the file busy itself.
            osp$log_job_recovery_message (' Permanent file not reattached', log_status);
            p_complete_path :=  pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.
                  p_external_path;
            pfp$convert_cycle_path_to_strng (p_complete_path^,
                  pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.
                  cycle_number, path_string);
            osp$log_job_recovery_message (path_string.value (1, path_string.size), log_status);
            FREE pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.p_external_path IN
                  pfv$p_p_job_heap^^;
            FREE pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry IN pfv$p_p_job_heap^^;
            pfv$p_p_attached_pf_table^^ [apft_index].entry_type := pfc$attached_pf_entry_unused;
          = pfc$attached_pf_awaiting_client =
            unrecovered_pf_count := unrecovered_pf_count + 1;
            { The file is actually attached in the device manager and catalog manager sense.
            IF dfv$file_server_debug_enabled THEN
              p_complete_path :=  pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.
                    p_external_path;
              pfp$convert_cycle_path_to_strng (p_complete_path^,
                     pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.
                  cycle_number, path_string);
              display (' File not found on client ');
              display (path_string.value  (1, path_string.size));
            IFEND;
            { Set the sfid status to 'normal' to allow the standard return to work.
            pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.sfid_status.recovery_state
               := pfc$attached_pf_normal;
            pfp$internal_return_file (apft_index, mainframe_id, authority, bytes_allocated_change,
                return_status);
            IF NOT return_status.normal AND dfv$file_server_debug_enabled THEN
              display_status (return_status);
            IFEND;
          ELSE { Normal cycle - Its been recovered.
          CASEND;
        IFEND;
      FOREND /verify_all_files/;
      IF unrecovered_pf_count > 0 THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$not_all_pfs_recovered,
              'complete job recovery', status);
        osp$append_status_integer (osc$status_parameter_delimiter, unrecovered_pf_count, 10, FALSE, status);
      IFEND;
    IFEND;
  PROCEND pfp$complete_job_recovery;
?? TITLE := '*** PFP$DETACH_ALL_FILES ***', EJECT ??

  PROCEDURE [XDCL] pfp$detach_all_files
    (    files_binary_mainframe_id: pmt$binary_mainframe_id;
     VAR return_files_option: pft$return_files_option);

    VAR
      apft_index: pft$attached_pf_table_index,
      authority: pft$authority,
      bytes_allocated_change: sft$counter,
      context: ^ost$ecp_exception_context,
      display_status: ost$status,
      p_complete_path: ^pft$complete_path,
      path_string: ost$string,
      status: ost$status;

    IF return_files_option.wait_for_down_volume THEN
      PUSH context;
    ELSE
      return_files_option.files_on_down_device := 0;
    IFEND;

    return_files_option.files_returned := 0;

    IF pfv$p_p_attached_pf_table^ <> NIL THEN
      IF return_files_option.log_returned_files THEN
        pmp$log_ascii ('Returning permanent files', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, display_status);
      IFEND;

    /detach_all_files/
      FOR apft_index := LOWERBOUND (pfv$p_p_attached_pf_table^^)
            TO UPPERBOUND (pfv$p_p_attached_pf_table^^) DO
        IF (pfv$p_p_attached_pf_table^^ [apft_index].entry_type = pfc$attached_pf_entry_valid) AND
            ((pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.sfid_status.recovery_state =
              pfc$attached_pf_normal)
             OR (pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.sfid_status.recovery_state =
             pfc$attached_pf_awaiting_client)) THEN
          IF return_files_option.log_returned_files THEN
            p_complete_path :=  pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.
                  p_external_path;
            pfp$convert_cycle_path_to_strng (p_complete_path^,
                  pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.
                  cycle_number, path_string);
            pmp$log_ascii (path_string.value (1, path_string.size), $pmt$ascii_logset
                  [pmc$system_log, pmc$job_log], pmc$msg_origin_system, display_status);
          IFEND;

          pfp$internal_return_file (apft_index, files_binary_mainframe_id, authority, bytes_allocated_change,
                status);
          IF status.normal THEN
            return_files_option.files_returned := return_files_option.files_returned + 1;
          ELSEIF osp$file_access_condition (status) THEN
            IF return_files_option.wait_for_down_volume THEN

              context^ := osv$initial_exception_context;
            /wait_for_unavailable_volume/
              REPEAT
                context^.condition_status := status;
                osp$enforce_exception_policies (context^);
                IF context^.wait THEN
                  pfp$internal_return_file (apft_index, files_binary_mainframe_id, authority,
                        bytes_allocated_change, status);
                ELSE
                  status := context^.condition_status;
                IFEND;
              UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

              IF status.normal THEN
                return_files_option.files_returned := return_files_option.files_returned + 1;
              ELSE
                pfp$process_unexpected_status (status);
              IFEND;
              ofp$display_status_message ('Continuing: detach_all_files ', display_status);
            ELSE
              return_files_option.files_on_down_device := return_files_option.files_on_down_device + 1;
            IFEND;
          ELSEIF (status.condition <> mme$io_write_error) THEN
            pfp$report_unexpected_status (status);
          IFEND;
        IFEND;
      FOREND /detach_all_files/;
    IFEND;
  PROCEND pfp$detach_all_files;
?? TITLE := '*** PFP$LOCATE_ATTACHED_FILE ***', EJECT ??

{ Note: This procedure assumes that there are no
{ asynchronous attaches, defines, opens (attach_or_create), or
{ returns, occuring in the job during the search.

  PROCEDURE [XDCL] pfp$locate_attached_file
    (    internal_cycle_name: pft$internal_name;
     VAR apfid: pft$attached_pf_table_index;
     VAR p_attached_pf_entry: pft$p_attached_pf_entry;
     VAR cycle_found: boolean);

    IF pfv$p_p_attached_pf_table^ <> NIL THEN

    /locate_cycle/
      FOR apfid := LOWERBOUND (pfv$p_p_attached_pf_table^^) TO UPPERBOUND (pfv$p_p_attached_pf_table^^) DO
        IF (pfv$p_p_attached_pf_table^^ [apfid].entry_type = pfc$attached_pf_entry_valid) AND
              (pfv$p_p_attached_pf_table^^ [apfid].p_attached_pf_entry <> NIL) AND
              (pfv$p_p_attached_pf_table^^ [apfid].p_attached_pf_entry^.internal_cycle_path.cycle_name =
              internal_cycle_name) THEN
          p_attached_pf_entry := pfv$p_p_attached_pf_table^^ [apfid].p_attached_pf_entry;
          cycle_found := TRUE;
          RETURN;
        IFEND;
      FOREND /locate_cycle/;
    IFEND;
    cycle_found := FALSE;
  PROCEND pfp$locate_attached_file;

?? TITLE := '*** PFP$LOCK_APFID ***', EJECT ??

{ PURPOSE:
{   This procedure locks an attached pf entry (waits if necessary)
{   This also retrieves the p_attached_pf_entry stored in the table.

  PROCEDURE [XDCL] pfp$lock_apfid
    (    apfid: pft$attached_pf_table_index;
     VAR p_attached_pf_entry: pft$p_attached_pf_entry;
     VAR status: ost$status);

    validate_apfid (apfid, status);
    IF status.normal THEN
      p_attached_pf_entry := pfv$p_p_attached_pf_table^^ [apfid].p_attached_pf_entry;
    IFEND;
  PROCEND pfp$lock_apfid;
?? TITLE := '*** PFP$R2_GET_ATTACHED_PF_TABLE ***', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_get_attached_pf_table
    (VAR p_info: pft$p_table_info;
     VAR status: ost$status);

    VAR
      afpt_entry: integer,
      p_attached_pf_entry: pft$p_attached_pf_entry,
      p_entry_number: ^integer,
      p_entry_size: ^integer,
      p_external_path: ^pft$path,
      p_record_id: ^pft$record_id,
      p_table: pft$p_attached_pf_table,
      p_table_name: ^pft$table_name,
      p_table_size: ^integer;

    status.normal := TRUE;
    NEXT p_table_name IN p_info;
    IF p_table_name = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'table name', status);
      RETURN;
    IFEND;
    p_table_name^ := 'ATTACHED_PF_TABLE';

    NEXT p_record_id IN p_info;
    IF p_record_id = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
      RETURN;
    IFEND;
    NEXT p_record_id IN p_info;
    IF p_record_id = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
      RETURN;
    IFEND;
    p_record_id^ := 'TABLSIZE';

    NEXT p_table_size IN p_info;
    IF p_table_size = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'table size', status);
      RETURN;
    IFEND;
    IF pfv$p_p_attached_pf_table^ = NIL THEN
      p_table_size^ := 0;
    ELSE
      p_table_size^ := UPPERBOUND (pfv$p_p_attached_pf_table^^);

      NEXT p_record_id IN p_info;
      IF p_record_id = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
        RETURN;
      IFEND;
      p_record_id^ := 'APFTABLE';

      NEXT p_table: [1 .. p_table_size^] IN p_info;
      IF p_table = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'table', status);
        RETURN;
      IFEND;
      p_table^ := pfv$p_p_attached_pf_table^^;

    /get_all_entries/
      FOR afpt_entry := 1 TO UPPERBOUND (pfv$p_p_attached_pf_table^^) DO
        NEXT p_record_id IN p_info;
        IF p_record_id = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
          RETURN;
        IFEND;
        p_record_id^ := 'APFIDNUM';

        NEXT p_entry_number IN p_info;
        IF p_entry_number = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'entry number', status);
          RETURN;
        IFEND;
        p_entry_number^ := afpt_entry;

        NEXT p_record_id IN p_info;
        IF p_record_id = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
          RETURN;
        IFEND;
        p_record_id^ := 'ENTRYSIZ';

        NEXT p_entry_size IN p_info;
        IF p_entry_size = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'entry szie', status);
          RETURN;
        IFEND;
        IF pfv$p_p_attached_pf_table^^ [afpt_entry].entry_type = pfc$attached_pf_entry_unused THEN
          p_entry_size^ := 0;
        ELSE { valid entry
          p_entry_size^ := UPPERBOUND (pfv$p_p_attached_pf_table^^ [afpt_entry].p_attached_pf_entry^.
                internal_cycle_path.path);

          NEXT p_attached_pf_entry: [1 .. p_entry_size^] IN p_info;
          IF p_attached_pf_entry = NIL THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'attached pf entry',
                  status);
            RETURN;
          IFEND;
          p_attached_pf_entry^ := pfv$p_p_attached_pf_table^^ [afpt_entry].p_attached_pf_entry^;

          NEXT p_record_id IN p_info;
          IF p_record_id = NIL THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
            RETURN;
          IFEND;
          p_record_id^ := 'EXTERCAT';

          NEXT p_external_path: [1 .. p_entry_size^] IN p_info;
          IF p_external_path = NIL THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'external', status);
            RETURN;
          IFEND;
          p_external_path^ := pfv$p_p_attached_pf_table^^ [afpt_entry].p_attached_pf_entry^.p_external_path^;
        IFEND;
      FOREND /get_all_entries/;
    IFEND;
  PROCEND pfp$r2_get_attached_pf_table;
?? TITLE := '*** PFP$REATTACH_FILES_FOR_CLIENT ***', EJECT ??
*copyc pfh$reattach_files_for_client
  PROCEDURE [XDCL, #GATE] pfp$reattach_files_for_client
    (    client_mainframe_id: pmt$binary_mainframe_id;
         p_old_attached_pf_table: ^pft$attached_pf_table;
     VAR files_reattached : ost$non_negative_integers;
     VAR files_not_reattached : ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      apfid: pft$attached_permanent_file_id,
      apft_index: pft$attached_pf_table_index,
      new_sfid: dmt$system_file_id,
      p_complete_path: ^pft$complete_path,
      path_string: ost$string,
      reattach_status: ost$status;

    status.normal := TRUE;
    files_reattached := 0;
    files_not_reattached := 0;
    IF p_old_attached_pf_table = NIL THEN
      RETURN;
    IFEND;
    { Allocate and copy the full table.
    ALLOCATE pfv$p_p_attached_pf_table^: [1 .. UPPERBOUND (p_old_attached_pf_table^)] IN pfv$p_p_job_heap^^;
    IF pfv$p_p_attached_pf_table^ = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, ose$job_severely_damaged,
            'Too many attached files - Allocate expanded apft', status);
      RETURN;
    IFEND;
    pfv$p_p_attached_pf_table^^ := p_old_attached_pf_table^;
    apfid.family_location := pfc$local_mainframe;

  /reattach_all_files/
    FOR apft_index := LOWERBOUND (p_old_attached_pf_table^) TO UPPERBOUND (p_old_attached_pf_table^) DO
      IF p_old_attached_pf_table^ [apft_index].entry_type = pfc$attached_pf_entry_valid THEN
        IF p_old_attached_pf_table^ [apft_index].p_attached_pf_entry <> NIL THEN
          { Copy the old attached pf table entry to the new attached pf table entry.
          { pfp$reattach_permanent_file will use the new entry
          { by virtue of the fact that the task pointers (pfv$p_p_attached_pf_table) are
          { pointing to the NEW table.
          ALLOCATE pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry:
                [1 .. UPPERBOUND (p_old_attached_pf_table^ [apft_index].p_attached_pf_entry^.
                internal_cycle_path.path)] IN pfv$p_p_job_heap^^;
          IF pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry = NIL THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, ose$job_severely_damaged,
                  '  Cant allocate attached pf entry', status);
            RETURN;
          IFEND;
          pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^ :=
                p_old_attached_pf_table^ [apft_index].p_attached_pf_entry^;
          ALLOCATE pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.p_external_path:
                [1 .. UPPERBOUND (p_old_attached_pf_table^ [apft_index].p_attached_pf_entry^.
                p_external_path^)] IN pfv$p_p_job_heap^^;
          IF pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.p_external_path = NIL THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, ose$job_severely_damaged,
                  '  Cant allocate attached external path', status);
            RETURN;
          IFEND;
          pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.p_external_path^ :=
                p_old_attached_pf_table^ [apft_index].p_attached_pf_entry^.p_external_path^;
          apfid.attached_pf_table_index := apft_index;
          IF dfv$file_server_debug_enabled THEN
            p_complete_path := pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.
                  p_external_path;
            pfp$convert_cycle_path_to_strng (p_complete_path^,
                  pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.cycle_number, path_string);
          IFEND;
        /reattach_permanent_file/
          WHILE TRUE DO
            pfp$reattach_permanent_file (apfid,
                  pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.device_class,
                  pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.
                  internal_cycle_path.cycle_name, client_mainframe_id,
                  pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.usage_selections,
                  pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.share_selections,
                  new_sfid, reattach_status);
            IF reattach_status.normal OR (reattach_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /reattach_permanent_file/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$REATTACH_PERMANENT_FILE');
            IFEND;
          WHILEND /reattach_permanent_file/;
          IF reattach_status.normal THEN
            files_reattached := files_reattached + 1;
          ELSE
            { Dont issue an error.  The client will discover this file
            {   when it reconciles the file manager table with the attached file table.
            files_not_reattached := files_not_reattached + 1;
            IF dfv$file_server_debug_enabled THEN
              display (path_string.value (1, path_string.size));
              display_status (reattach_status);
            IFEND;
            { The ALLOCATED pieces have been FREED by pfp$reattach_permanent_file
            pfv$p_p_attached_pf_table^^ [apft_index].entry_type := pfc$attached_pf_entry_unused;
          IFEND;
        IFEND;
      IFEND;
    FOREND /reattach_all_files/;

  PROCEND pfp$reattach_files_for_client;
?? TITLE := '*** PFP$RELEASE_LOCKED_APFID *** ', EJECT ??

{ PURPOSE:
{   This procedure releases a previosly assigned attached pf table
{   entry from the attached pf table.
{   This does NOT free the pointer to the attached pf entry.

  PROCEDURE [XDCL] pfp$release_locked_apfid
    (    apfid: pft$attached_pf_table_index;
     VAR status: ost$status);

    validate_apfid (apfid, status);
    IF status.normal THEN
      pfv$p_p_attached_pf_table^^ [apfid].entry_type := pfc$attached_pf_entry_unused;
    IFEND;

  PROCEND pfp$release_locked_apfid;
?? TITLE := '*** PFP$SETUP_ATTACHED_PF_RECOVERY ***', EJECT ??

{ This procedure initiated the permanent file part of recovery of
{ files within a job. This verifies that the attached permanent
{ file table may be read, and marks each attached file, as being in
{ the process of being recovered. The pfp$reattach_permanent_file
{ interface will mark the file as being normal again, and the
{ pfp$complete_job_recovery processing check that all files have been
{ re-attached.

  PROCEDURE [XDCL, #GATE] pfp$setup_attached_pf_recovery
    (     file_recovery_state: pft$attached_pf_recovery_state;
     VAR status: ost$status);

    VAR
      apft_index: pft$attached_pf_table_index,
      display_status: ost$status;

    IF pfv$p_p_attached_pf_table^ <> NIL THEN

    /setup_all_files/
      FOR apft_index := LOWERBOUND (pfv$p_p_attached_pf_table^^)
            TO UPPERBOUND (pfv$p_p_attached_pf_table^^) DO
        IF pfv$p_p_attached_pf_table^^ [apft_index].entry_type = pfc$attached_pf_entry_valid THEN
          IF pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry <> NIL THEN
            pfv$p_p_attached_pf_table^^ [apft_index].p_attached_pf_entry^.sfid_status.recovery_state :=
                  file_recovery_state;
          IFEND;
        IFEND;
      FOREND /setup_all_files/;
    IFEND;

  PROCEND pfp$setup_attached_pf_recovery;
?? TITLE := '*** PFP$UNLOCK_APFID ***', EJECT ??

{ PURPOSE:
{   This procedure stores the pointer to the attached pf entry in the
{   attached pf table, and unlocks the entry.

  PROCEDURE [XDCL] pfp$unlock_apfid
    (    apfid: pft$attached_pf_table_index;
         p_attached_pf_entry: pft$p_attached_pf_entry;
     VAR status: ost$status);

    validate_apfid (apfid, status);
    IF status.normal THEN
      pfv$p_p_attached_pf_table^^ [apfid].p_attached_pf_entry := p_attached_pf_entry;
    IFEND;

  PROCEND pfp$unlock_apfid;
?? TITLE := '     *** GET_UNUSED_APFT_ENTRY ***', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is
{   to get an unused entry in the attached pf table, this includes initially
{   creating the table, expanding the table if necessary, and
{   searching for an unused entry.
{   The only possible error condition is if the job pageable heap
{   is full and the table cannot be expanded.

  PROCEDURE get_unused_apft_entry
    (VAR apfid: pft$attached_pf_table_index;
     VAR status: ost$status);

    CONST
      pfc$expand_apft_amount = 8,
      pfc$initial_apft_size = 30;

    VAR
      p_new_attached_pf_table: pft$p_attached_pf_table,
      p_old_attached_pf_table: pft$p_attached_pf_table,
      space_found: boolean;

?? NEWTITLE := '*** SEARCH_APFT_FOR_UNUSED ***', EJECT ??

{ PURPOSE:
{   This procedure searches the attached pf table looking for an unused
{   table entry.  The unused index number (APFID) is returned.

    PROCEDURE [INLINE] search_apft_for_unused
      (    p_attached_pf_table: pft$p_attached_pf_table;
       VAR apfid: pft$attached_pf_table_index;
       VAR unused_found: boolean);

      IF p_attached_pf_table <> NIL THEN

      /search_for_unused/
        FOR apfid := LOWERBOUND (p_attached_pf_table^) TO UPPERBOUND (p_attached_pf_table^) DO
          IF p_attached_pf_table^ [apfid].entry_type = pfc$attached_pf_entry_unused THEN
            unused_found := TRUE;
            RETURN;
          IFEND;
        FOREND /search_for_unused/;
      IFEND;
      unused_found := FALSE;
    PROCEND search_apft_for_unused;
?? OLDTITLE ??
?? NEWTITLE := '*** INITIALIZE_APFT_TO_UNUSED ***', EJECT ??

{ PURPOSE:
{   This procedure initializes an attached pf table to indicate that
{   all entries are unused.

    PROCEDURE [INLINE] initialize_apft_to_unused
      (    p_attached_pf_table: pft$p_attached_pf_table);

      VAR
        apfid: pft$attached_pf_table_index;

      IF p_attached_pf_table <> NIL THEN

      /initialize_all_entries/
        FOR apfid := LOWERBOUND (p_attached_pf_table^) TO UPPERBOUND (p_attached_pf_table^) DO
          p_attached_pf_table^ [apfid].entry_type := pfc$attached_pf_entry_unused;
        FOREND /initialize_all_entries/;
      IFEND;
    PROCEND initialize_apft_to_unused;
?? OLDTITLE ??
?? NEWTITLE := '*** TRANSFER_OLD_TO_NEW_APFT ***', EJECT ??

{ PURPOSE:
{   This procedure transfers an old attached pf table, to a new one.  The
{   new table must be as large as or larger than the old table.  If the new table
{   is larger, additional entries are initialized to indicate they are unused.

    PROCEDURE [INLINE] transfer_old_to_new_apft
      (    p_old_attached_pf_table: pft$p_attached_pf_table;
           p_new_attached_pf_table: pft$p_attached_pf_table);


      VAR
        apfid: pft$attached_pf_table_index;

    /copy_old_entries/
      FOR apfid := LOWERBOUND (p_old_attached_pf_table^) TO UPPERBOUND (p_old_attached_pf_table^) DO
        p_new_attached_pf_table^ [apfid] := p_old_attached_pf_table^ [apfid];
      FOREND /copy_old_entries/;

    /initialize_new_entries/
      FOR apfid := (UPPERBOUND (p_old_attached_pf_table^) + 1) TO UPPERBOUND (p_new_attached_pf_table^) DO
        p_new_attached_pf_table^ [apfid].entry_type := pfc$attached_pf_entry_unused;
      FOREND /initialize_new_entries/;
    PROCEND transfer_old_to_new_apft;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    space_found := FALSE;
    IF pfv$p_p_attached_pf_table^ = NIL THEN
{     ALLOCATE A NEW ATTACHED PF TABLE
      ALLOCATE pfv$p_p_attached_pf_table^: [1 .. pfc$initial_apft_size] IN pfv$p_p_job_heap^^;
      IF pfv$p_p_attached_pf_table^ = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'Too many attached files - Allocate initial apft', status);
        #KEYPOINT (osk$unusual, 0, pfk$job_pageable_full);
      ELSE
        initialize_apft_to_unused (pfv$p_p_attached_pf_table^);
        apfid := 1;
      IFEND;
    ELSE
      search_apft_for_unused (pfv$p_p_attached_pf_table^, apfid, space_found);
      IF NOT space_found THEN {expand the old table }
        ALLOCATE p_new_attached_pf_table: [1 .. (UPPERBOUND (pfv$p_p_attached_pf_table^^) +
              pfc$expand_apft_amount)] IN pfv$p_p_job_heap^^;
        IF p_new_attached_pf_table = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                'Too many attached files - Allocate expanded apft', status);
          #KEYPOINT (osk$unusual, 0, pfk$job_pageable_full);
        ELSE
          p_old_attached_pf_table := pfv$p_p_attached_pf_table^;
          apfid := UPPERBOUND (p_old_attached_pf_table^) + 1;
          transfer_old_to_new_apft (p_old_attached_pf_table, p_new_attached_pf_table);
          pfv$p_p_attached_pf_table^ := p_new_attached_pf_table;
          FREE p_old_attached_pf_table IN pfv$p_p_job_heap^^;
        IFEND;
      IFEND;
    IFEND;
  PROCEND get_unused_apft_entry;

?? TITLE := '*** VALIDATE APFID ***', EJECT ??

{ PURPOSE:
{   This procedure validates that the input apfid is  valid.

  PROCEDURE [INLINE] validate_apfid
    (    apfid: pft$attached_pf_table_index;
     VAR status: ost$status);


    IF (pfv$p_p_attached_pf_table^ <> NIL) AND (apfid <= UPPERBOUND (pfv$p_p_attached_pf_table^^)) AND
          (apfid >= LOWERBOUND (pfv$p_p_attached_pf_table^^)) AND
          (pfv$p_p_attached_pf_table^^ [apfid].entry_type = pfc$attached_pf_entry_valid) THEN
      status.normal := TRUE;
    ELSE {invalid apfid}
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_apfid, '', status);
      #KEYPOINT (osk$debug, osk$m * apfid, pfk$invalid_apfid);
    IFEND;
  PROCEND validate_apfid;

MODEND pfm$attached_pf_table;
*DECK DECK=PFM$CATALOG_ACCESS EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
??
FMT (FORMAT := ON, keyw := upper, ident := lower) ??
?? SET (LISTCTS := OFF) ??
MODULE pfm$catalog_access;
?? PUSH (LISTEXT := ON) ??
*copyc amp$close
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc osp$append_status_integer
*copyc osp$set_status_abnormal
*copyc ost$caller_identifier
*copyc pfd$catalog_access
*copyc pfd$information_selections
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$selection_errors
*copyc pfk$keypoints
*copyc pfp$find_cycle_array
*copyc pfp$find_direct_info_record
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_multi_item_info
*copyc pfp$process_unexpected_status
*copyc pfp$report_unexpected_status
*copyc pmp$get_unique_name
?? POP ??
?? SKIP := 4 ??

  VAR
    p_collected_info_array: [STATIC] pft$p_collected_info_array := NIL;

?? TITLE := '*** PFP$COLLECT_FILE_INFORMATION ***', EJECT ??

*copyc pfh$collect_file_information

  PROCEDURE [XDCL, #GATE] pfp$collect_file_information (path: pft$path;
        file_selections: pft$file_selections;
    VAR selection_id: pft$selection_identifier;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      catalog_info_selections: pft$catalog_info_selections,
      close_status: ost$status,
      file_id: amt$file_identifier,
      file_info_selections: pft$file_info_selections,
      group: pft$group,
      local_status: ost$status,
      p_directory_array: pft$p_directory_array,
      p_info_record: pft$p_info_record,
      sequence_pointer: ^SEQ ( * ),
      selection_id_ordinal: pft$selection_id_ordinal;


    PROCEDURE find_free_entry (VAR id_ordinal: pft$selection_id_ordinal;
      VAR status: ost$status);

      VAR
        local_id_ordinal: 1 .. pfc$max_selection_id_ordinal + 1;

      IF p_collected_info_array = NIL THEN
        ALLOCATE p_collected_info_array;
        IF p_collected_info_array = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error, 'Unable to allocate.',
                status);
          RETURN;
        IFEND;

        FOR local_id_ordinal := 1 TO pfc$max_selection_id_ordinal DO
          p_collected_info_array^ [local_id_ordinal].entry_type := pfc$free;
        FOREND;
      IFEND;

      local_id_ordinal := 1;
      WHILE (local_id_ordinal <= pfc$max_selection_id_ordinal) AND (p_collected_info_array^
            [local_id_ordinal].entry_type = pfc$used) DO
        local_id_ordinal := local_id_ordinal + 1;
      WHILEND;

      IF local_id_ordinal > pfc$max_selection_id_ordinal THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$collection_limit_exceeded, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, pfc$max_selection_id_ordinal, 10, FALSE,
              status);
      ELSE
        id_ordinal := local_id_ordinal;
        status.normal := TRUE;
      IFEND;
    PROCEND find_free_entry;


    #caller_id (caller_id);
    #keypoint (osk$entry, osk$m * caller_id.ring, pfk$collect_file_information);
    local_status.normal := TRUE;

    IF file_selections = $pft$file_selections [] THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$null_file_selections, '', local_status);
    ELSE
      find_free_entry (selection_id_ordinal, local_status);
    IFEND;

    IF local_status.normal THEN
      create_scratch_sequence (sequence_pointer, file_id, local_status);
    IFEND;

    IF local_status.normal THEN
      group.group_type := pfc$public;

      IF pfc$catalog_names IN file_selections THEN
        catalog_info_selections := $pft$catalog_info_selections [pfc$catalog_description];
      ELSE
        catalog_info_selections := $pft$catalog_info_selections [];
      IFEND;

      IF pfc$file_names IN file_selections THEN
        file_info_selections := $pft$file_info_selections [pfc$file_description];
      ELSE
        file_info_selections := $pft$file_info_selections [];
      IFEND;

      IF pfc$cycle_numbers IN file_selections THEN
        file_info_selections := file_info_selections + $pft$file_info_selections [pfc$file_description,
              pfc$file_cycles];
      IFEND;

      pfp$get_multi_item_info (path, group, catalog_info_selections, file_info_selections, sequence_pointer,
            local_status);

      IF local_status.normal THEN
        RESET sequence_pointer;
        pfp$find_next_info_record (sequence_pointer, p_info_record, local_status);
        IF local_status.normal AND (p_info_record = NIL) THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_info_record returned.', local_status);
        IFEND;
      IFEND;

      IF local_status.normal THEN
        pfp$find_directory_array (p_info_record, p_directory_array, local_status);
        IF local_status.normal AND (p_directory_array = NIL) THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$no_records_collected, '', local_status);
        IFEND;
      IFEND;

      IF local_status.normal THEN
        p_collected_info_array^ [selection_id_ordinal].entry_type := pfc$used;
        p_collected_info_array^ [selection_id_ordinal].file_selections := file_selections;
        p_collected_info_array^ [selection_id_ordinal].file_id := file_id;
        p_collected_info_array^ [selection_id_ordinal].p_directory_array := p_directory_array;
        p_collected_info_array^ [selection_id_ordinal].directory_array_index := 0;

        IF pfc$catalog_names IN file_selections THEN
          p_collected_info_array^ [selection_id_ordinal].info_type := pfc$catalog_names;
        ELSE
          p_collected_info_array^ [selection_id_ordinal].info_type := pfc$file_names;
        IFEND;

        IF pfc$cycle_numbers IN file_selections THEN
          p_collected_info_array^ [selection_id_ordinal].cycle_numbers_selected := TRUE;
          p_collected_info_array^ [selection_id_ordinal].p_body := ^p_info_record^.body;
          p_collected_info_array^ [selection_id_ordinal].p_cycle_array := NIL;
          p_collected_info_array^ [selection_id_ordinal].cycle_array_index := 0;
        ELSE
          p_collected_info_array^ [selection_id_ordinal].cycle_numbers_selected := FALSE;
        IFEND;

        find_next_info_index (p_collected_info_array^ [selection_id_ordinal], local_status);
      IFEND;

      IF local_status.normal THEN
        selection_id.ordinal := selection_id_ordinal;
        selection_id.sequence := file_id.sequence;
      ELSE
        p_collected_info_array^ [selection_id_ordinal].entry_type := pfc$free;
        amp$close (file_id, close_status);
        pfp$process_unexpected_status (close_status);
      IFEND;
    IFEND;

    IF local_status.normal THEN
      #keypoint (osk$exit, 0, pfk$collect_file_information);
    ELSE
      #keypoint (osk$exit, 0, pfk$collect_file_information);
    IFEND;
    status := local_status;
  PROCEND pfp$collect_file_information;
?? TITLE := '*** PFP$GET_NEXT_FILE_SELECTION ***', EJECT ??

*copyc pfh$get_next_file_selection

  PROCEDURE [XDCL, #GATE] pfp$get_next_file_selection (selection_id: pft$selection_identifier;
    VAR selection_record: pft$selection_record;
    VAR selection_position: pft$selection_position;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      cycle_array_index: pft$cycle_array_index,
      directory_array_index: pft$directory_array_index,
      local_selection_record: pft$selection_record,
      local_status: ost$status;

    #caller_id (caller_id);
    #keypoint (osk$entry, osk$m * caller_id.ring, pfk$get_next_file_selection);
    local_status.normal := TRUE;

    verify_selection_id (selection_id, local_status);

    IF local_status.normal AND (p_collected_info_array^ [selection_id.ordinal].selection_position =
          pfc$end_of_information) THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$get_next_at_eoi, '', local_status);
    IFEND;

    IF local_status.normal THEN
      CASE p_collected_info_array^ [selection_id.ordinal].info_type OF
      = pfc$catalog_names =
        directory_array_index := p_collected_info_array^ [selection_id.ordinal].directory_array_index;
        local_selection_record.kind := pfc$catalog_names;
        local_selection_record.catalog_name := p_collected_info_array^ [selection_id.ordinal].
              p_directory_array^ [directory_array_index].name;

      = pfc$file_names =
        directory_array_index := p_collected_info_array^ [selection_id.ordinal].directory_array_index;
        local_selection_record.kind := pfc$file_names;
        local_selection_record.file_name := p_collected_info_array^ [selection_id.ordinal].p_directory_array^
              [directory_array_index].name;

      = pfc$cycle_numbers =
        cycle_array_index := p_collected_info_array^ [selection_id.ordinal].cycle_array_index;
        local_selection_record.kind := pfc$cycle_numbers;
        local_selection_record.cycle_number := p_collected_info_array^ [selection_id.ordinal].p_cycle_array^
              [cycle_array_index].cycle_number;

      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error, 'Bad info_type.',
              local_status);
      CASEND;
    IFEND;

    IF local_status.normal THEN
      find_next_info_index (p_collected_info_array^ [selection_id.ordinal], local_status);
    IFEND;

    IF local_status.normal THEN
      selection_record := local_selection_record;
      selection_position := p_collected_info_array^ [selection_id.ordinal].selection_position;
    IFEND;

    IF local_status.normal THEN
      #keypoint (osk$exit, 0, pfk$get_next_file_selection);
    ELSE
      #keypoint (osk$exit, 0, pfk$get_next_file_selection);
    IFEND;
    status := local_status;
  PROCEND pfp$get_next_file_selection;
?? TITLE := '*** PFP$RETURN_FILE_INFORMATION ***', EJECT ??

*copyc pfh$return_file_information

  PROCEDURE [XDCL, #GATE] pfp$return_file_information (selection_id: pft$selection_identifier;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      close_status: ost$status,
      local_status: ost$status;

    #caller_id (caller_id);
    #keypoint (osk$entry, osk$m * caller_id.ring, pfk$return_file_information);
    local_status.normal := TRUE;

    verify_selection_id (selection_id, local_status);

    IF local_status.normal THEN
      amp$close (p_collected_info_array^ [selection_id.ordinal].file_id, close_status);
      pfp$process_unexpected_status (close_status);

      p_collected_info_array^ [selection_id.ordinal].entry_type := pfc$free;
    IFEND;

    IF local_status.normal THEN
      #keypoint (osk$exit, 0, pfk$return_file_information);
    ELSE
      #keypoint (osk$exit, 0, pfk$return_file_information);
    IFEND;
    status := local_status;
  PROCEND pfp$return_file_information;
?? TITLE := ' *** CREATE_SCRATCH_SEQUENCE  *** ', EJECT ??

  PROCEDURE create_scratch_sequence (VAR sequence_pointer: ^SEQ ( * );
    VAR file_identifier: amt$file_identifier;
    VAR status: ost$status);

{  The purpose of this procedure is to create a scratch sequence.
{  The file containing the sequence is returned when the file is closed.

    VAR
      file_attribute: array [1 .. 1] of amt$access_selection,
      file_name: amt$local_file_name,
      segment_pointer: amt$segment_pointer;

    pmp$get_unique_name (file_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_attribute [1].key := amc$return_option;
    file_attribute [1].return_option := amc$return_at_close;
    amp$open (file_name, amc$segment, ^file_attribute, file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_identifier, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET segment_pointer.sequence_pointer;
    sequence_pointer := segment_pointer.sequence_pointer;
  PROCEND create_scratch_sequence;
?? TITLE := '*** FIND_NEXT_INFO_INDEX ***', EJECT ??

  PROCEDURE find_next_info_index (VAR collected_info: pft$collected_info_entry;
    VAR status: ost$status);

    VAR
      directory_array_index: pft$directory_array_index,
      info_type: pft$file_information,
      name_type: pft$name_type,
      p_cycle_array: pft$p_cycle_array,
      p_info_record: pft$p_info_record,
      upper_info_type: pft$file_information;

    directory_array_index := collected_info.directory_array_index;

    IF collected_info.cycle_numbers_selected AND (collected_info.cycle_array_index = 0) AND (collected_info.
          info_type = pfc$file_names) AND (directory_array_index <> 0) THEN
      pfp$find_direct_info_record (collected_info.p_body, collected_info.p_directory_array^
            [directory_array_index].info_offset, p_info_record, status);
      IF NOT status.normal THEN
        pfp$report_unexpected_status (status);
        RETURN;
      ELSEIF p_info_record = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
          'NIL p_info_record returned.', status);
        RETURN;
      IFEND;

      pfp$find_cycle_array (p_info_record, p_cycle_array, status);
      IF NOT status.normal THEN
        pfp$report_unexpected_status (status);
        RETURN;
      ELSEIF p_cycle_array = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
          'NIL p_cycle_array returned.', status);
        RETURN;
      IFEND;

      collected_info.info_type := pfc$cycle_numbers;
      collected_info.p_cycle_array := p_cycle_array;
    IFEND;

    status.normal := TRUE;

    IF collected_info.info_type = pfc$cycle_numbers THEN
      IF collected_info.cycle_array_index = UPPERBOUND (collected_info.p_cycle_array^) THEN
        collected_info.info_type := pfc$file_names;
        collected_info.p_cycle_array := NIL;
        collected_info.cycle_array_index := 0;
      ELSE
        collected_info.cycle_array_index := collected_info.cycle_array_index + 1;
        RETURN;
      IFEND;
    IFEND;

    IF collected_info.file_selections = $pft$file_selections [pfc$catalog_names] THEN
      upper_info_type := pfc$catalog_names;
    ELSE
      upper_info_type := pfc$file_names;
    IFEND;

    FOR info_type := collected_info.info_type TO upper_info_type DO
      FOR directory_array_index := directory_array_index + 1 TO UPPERBOUND (collected_info.p_directory_array^)
            DO
        name_type := collected_info.p_directory_array^ [directory_array_index].name_type;
        IF ((name_type = pfc$catalog_name) AND (info_type = pfc$catalog_names)) OR ((name_type =
              pfc$file_name) AND (info_type = pfc$file_names)) THEN
          collected_info.directory_array_index := directory_array_index;
          collected_info.info_type := info_type;
          collected_info.selection_position := pfc$end_of_record;
          RETURN;
        IFEND;
      FOREND;

      directory_array_index := 0;
    FOREND;

    collected_info.selection_position := pfc$end_of_information;
  PROCEND find_next_info_index;
?? TITLE := '*** VERIFY_SELECTION_ID ***', EJECT ??

  PROCEDURE verify_selection_id (selection_id: pft$selection_identifier;
    VAR status: ost$status);

    IF (selection_id.ordinal < 1) OR (pfc$max_selection_id_ordinal < selection_id.ordinal) OR
          (p_collected_info_array = NIL) OR (p_collected_info_array^ [selection_id.ordinal].entry_type =
          pfc$free) OR (selection_id.sequence <> p_collected_info_array^ [selection_id.ordinal].file_id.
          sequence) THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$improper_selection_id, '', status);
    ELSE
      status.normal := TRUE;
    IFEND;
  PROCEND verify_selection_id;
?? SKIP := 4 ??
MODEND pfm$catalog_access;
*DECK DECK=PFM$CATALOG_ACCESS_METHODS EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Permanent Files : Catalog Access Methods' ??
MODULE pfm$catalog_access_methods;

{ PURPOSE:
{   This module contains the interfaces to access the various pieces contained
{   in the catalogs.

?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc dfd$file_server_info
*copyc dfk$file_server_info_keypoints
*copyc oss$job_paged_literal
*copyc pfd$authority
*copyc pfd$catalog
*copyc pfd$catalog_info
*copyc pfd$password_selector
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pfk$keypoints
*copyc pft$selections_string
?? POP ??
?? EJECT ??
*copyc dfv$file_server_info_enabled
*copyc i#move
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$recoverable_system_error
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc osv$catalog_name_security
*copyc osv$system_family_name
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc pfp$allocate_cycle_list
*copyc pfp$attach_catalog
*copyc pfp$attach_last_queued_catalog
*copyc pfp$attach_root_catalog
*copyc pfp$build_fmd_pointer
*copyc pfp$build_object_list_locator
*copyc pfp$build_object_list_pointer
*copyc pfp$build_permit_list_pointer
*copyc pfp$compute_checksum
*copyc pfp$convert_pf_path_to_fs_path
*copyc pfp$establish_free_object_entry
*copyc pfp$get_queued_catalog
*copyc pfp$get_root_attached
*copyc pfp$locate_object
*copyc pfp$locate_specific_cycle
*copyc pfp$log_ascii
*copyc pfp$log_path
*copyc pfp$open_attached_catalog
*copyc pfp$physically_attach_catalog
*copyc pfp$process_unexpected_status
*copyc pfp$release_locked_apfid
*copyc pfp$report_system_error
*copyc pfp$return_catalog
*copyc pfp$set_status_abnormal
*copyc pfv$locked_apfid
*copyc pfv$locked_catalog_list
*copyc pfv$p_p_job_heap
*copyc pmp$continue_to_cause
*copyc pmp$get_account_project
*copyc pmp$get_user_identification
*copyc stp$get_set_owner

?? TITLE := '  Global Declarations Declared by this module', EJECT ??

  CONST
    include_radix = TRUE,
    radix = 10;

  VAR
    null_permit_entry: [oss$job_paged_literal, READ] pft$permit_entry := [pfc$free_permit_entry];

?? TITLE := '  [XDCL] pfp$access_last_object', EJECT ??

  PROCEDURE [XDCL] pfp$access_last_object
   (    path: pft$complete_path;
        authority: pft$authority;
        valid_objects: pft$object_selections;
    VAR catalog_locator: {i/o} pft$catalog_locator;
    VAR permit_entry: {i/o} pft$permit_entry;
    VAR p_object: {output} pft$p_object;
    VAR internal_name: pft$internal_name;
    VAR status: ost$status);

    VAR
      extracted_permit: pft$permit_entry,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      last_index: pft$array_index,
      new_valid_objects: pft$object_selections;

    last_index := UPPERBOUND (path);

    {
    { This call to access_next_object is to locate objects that already exist.
    { Therefore, pfc$free_object is deleted from the set of valid objects. If the
    { object does not exist a call to pfp$establish_free_object_entry will be used
    { to locate a free object.
    {
    new_valid_objects := (valid_objects - $pft$object_selections [pfc$free_object]) +
          $pft$object_selections [pfc$file_object, pfc$catalog_object];

    access_next_object (catalog_locator.object_list_descriptor, path [last_index],
          new_valid_objects, authority, catalog_locator.p_catalog_file, p_object, extracted_permit);
    IF p_object <> NIL THEN
      pfp$reduce_permits (permit_entry, extracted_permit, permit_entry);
    IFEND;

    IF (p_object <> NIL) AND ((authority.ownership <> $pft$ownership []) OR ((permit_entry.entry_type =
          pfc$normal_permit_entry) AND (permit_entry.usage_permissions <> $pft$permit_selections [])) OR
          (p_object^.object_entry.object_type = pfc$catalog_object)) THEN
      { known and (permitted_object or catalog)
      IF p_object^.object_entry.object_type IN valid_objects THEN
        internal_name := p_object^.object_entry.internal_object_name;
        status.normal := TRUE;
      ELSE
        pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);

        IF valid_objects = $pft$object_selections [pfc$catalog_object] THEN
          IF osv$catalog_name_security AND (authority.ownership = $pft$ownership []) AND
                ((permit_entry.entry_type = pfc$free_permit_entry) OR
                (permit_entry.usage_permissions = $pft$permit_selections [])) THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_last_subcatalog,
                  fs_path (1, fs_path_size), status);
          ELSE
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$last_name_not_subcatalog,
                  fs_path (1, fs_path_size), status);
          IFEND;
        ELSEIF valid_objects = $pft$object_selections [pfc$file_object] THEN
          IF osv$catalog_name_security AND (authority.ownership = $pft$ownership []) AND
                ((permit_entry.entry_type = pfc$free_permit_entry) OR
                (permit_entry.usage_permissions = $pft$permit_selections [])) THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_permanent_file,
                  fs_path (1, fs_path_size), status);
          ELSE
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$name_not_permanent_file,
                  fs_path (1, fs_path_size), status);
          IFEND;
        ELSEIF p_object^.object_entry.object_type = pfc$file_object THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$name_already_permanent_file, fs_path (1,
                fs_path_size), status);
        ELSE
          CASE last_index OF
          = pfc$family_path_index =
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$duplicate_family_catalog, fs_path (1,
                  fs_path_size), status);
          = pfc$master_catalog_path_index =
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$duplicate_master_catalog, fs_path (1,
                  fs_path_size), status);
          ELSE
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$name_already_subcatalog, fs_path (1,
                  fs_path_size), status);
          CASEND;
        IFEND;
      IFEND;
    ELSE {unknown object or unpermitted file}
      IF (p_object = NIL) AND (pfc$free_object IN valid_objects) THEN
        pfp$establish_free_object_entry (^path, catalog_locator.p_catalog_file,
              catalog_locator.object_list_descriptor, p_object, status);
      ELSEIF valid_objects <= $pft$object_selections [pfc$catalog_object, pfc$purged_catalog_object] THEN
        IF (p_object <> NIL) AND (p_object^.object_entry.object_type IN valid_objects) THEN
          internal_name := p_object^.object_entry.internal_object_name;
          status.normal := TRUE;
        ELSE
          pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
          CASE last_index OF
          = pfc$family_path_index =
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_family, fs_path (1,
                  fs_path_size), status);
          = pfc$master_catalog_path_index =
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_master_catalog, fs_path (1,
                  fs_path_size), status);
          ELSE
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_last_subcatalog, fs_path (1,
                  fs_path_size), status);
          CASEND;
        IFEND;
      ELSE
        pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);

        IF valid_objects <= $pft$object_selections [pfc$file_object, pfc$purged_file_object] THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_permanent_file, fs_path (1,
                fs_path_size), status);
        ELSEIF p_object = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_item, fs_path (1, fs_path_size),
                status);
        ELSE
          CASE last_index OF
          = pfc$family_path_index =
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$duplicate_family_catalog, fs_path (1,
                  fs_path_size), status);
          = pfc$master_catalog_path_index =
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$duplicate_master_catalog, fs_path (1,
                  fs_path_size), status);
          ELSE
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_permanent_file, fs_path (1,
                  fs_path_size), status);
          CASEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pfp$access_last_object;

?? TITLE := '  [XDCL] pfp$access_next_catalog', EJECT ??

  PROCEDURE [XDCL] pfp$access_next_catalog
    (    access_kind: pft$access_kind;
         last_catalog_locator: pft$catalog_locator;
         p_catalog_object: {input} pft$p_object;
         catalog_remote: boolean;
     VAR next_catalog_locator: pft$catalog_locator;
     VAR status: ost$status);

    VAR
      p_physical_fmd: pft$p_physical_fmd;

    IF p_catalog_object^.object_entry.catalog_object_locator.catalog_type = pfc$internal_catalog THEN
      next_catalog_locator := last_catalog_locator;
      pfp$build_object_list_pointer (p_catalog_object^.object_entry.catalog_object_locator.
            object_list_locator, last_catalog_locator.p_catalog_file,
            next_catalog_locator.object_list_descriptor.p_object_list);
      next_catalog_locator.object_list_descriptor.sorted_object_count :=
            p_catalog_object^.object_entry.catalog_object_locator.object_list_locator.sorted_object_count;
      next_catalog_locator.object_list_descriptor.free_sorted_object_count :=
            p_catalog_object^.object_entry.catalog_object_locator.object_list_locator.
            free_sorted_object_count;
      next_catalog_locator.object_list_descriptor.catalog_type := pfc$internal_catalog;
      next_catalog_locator.object_list_descriptor.p_parent_catalog := p_catalog_object;
      status.normal := TRUE;
    ELSE {external catalog}
      pfp$build_fmd_pointer (p_catalog_object^.object_entry.catalog_object_locator.fmd_locator,
            last_catalog_locator.p_catalog_file, p_physical_fmd);
      IF p_physical_fmd = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              ' NIL catalog FMD in pfp$access_next_catalog', status);
      ELSE
        pfp$attach_catalog (^p_physical_fmd^.fmd, last_catalog_locator.set_name,
              p_catalog_object^.object_entry.internal_object_name,
              p_catalog_object^.object_entry.catalog_object_locator.global_file_name,
              access_kind, catalog_remote, next_catalog_locator, status);
      IFEND;
    IFEND;

  PROCEND pfp$access_next_catalog;

?? TITLE := '  [XDCL] pfp$access_object', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to establish access to the object
{   specified by the path parameter.  This includes extracting permit
{   information that may apply.
{
{ DESIGN:
{   The valid_objects parameter allows the selection of object type checking
{   options.  If the type of the object does not match the valid types, an
{   appropriate abnormal status is returned.  If the object is unknown and a
{   free object is selected as valid, the p_object parameter is set to point to
{   a free object entry.  This feature can be used to create new, uniquely
{   named, objects.  An internal path of internal names, starting with the
{   unique set name, is also built in this routine.

  PROCEDURE [XDCL] pfp$access_object
    (    path: pft$complete_path;
         access_kind: pft$access_kind;
         authority: pft$authority;
         valid_objects: pft$object_selections;
     VAR parent_charge_id: pft$charge_id;
     VAR catalog_locator: pft$catalog_locator;
     VAR p_physical_object: {output} ^pft$physical_object;
     VAR internal_path: pft$internal_path;
     VAR permit_entry: pft$permit_entry;
     VAR status: ost$status);

    PROCEDURE access_object_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        variant_path: pft$variant_path,
        status_id: ost$status_identifier,
        local_status: ost$status;

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := ^path;

      IF NOT process_non_local_exit THEN
        pfp$log_ascii ('***PF Condition Handler***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, {critical_message} FALSE, local_status);
        pfp$log_path (variant_path, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
              {critical_message} FALSE, local_status);
      IFEND;

      CASE condition.selector OF
      = pmc$system_conditions, pmc$block_exit_processing, mmc$segment_access_condition =
        IF process_non_local_exit THEN
          RETURN;
        IFEND;

        IF catalog_locator.attached THEN
          catalog_locator.abort_catalog_operation := TRUE;
          pfp$return_catalog (catalog_locator, local_status);
          IF NOT local_status.normal THEN
            pfp$report_system_error (local_status);
          IFEND;
        IFEND;

        osp$set_status_from_condition (status_id, condition, p_sfsa, local_status, handler_status);
        osp$recoverable_system_error ('UNEXPECTED STATUS', ^local_status);

        status := local_status;
        initiate_non_local_exit;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
         {syp$invalidate_open_sfid (catalog_locator.system_file_id, local_status);
          initiate_non_local_exit;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND access_object_handler;

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$access_object;
    PROCEND initiate_non_local_exit;

    VAR
      last_catalog_index: pft$catalog_path_index,
      local_status: ost$status,
      p_parent_path: ^pft$complete_path,
      path_index: pft$catalog_path_index,
      process_non_local_exit: boolean,
      variant_path: pft$variant_path;

    { Check parameters.
    {
    IF valid_objects = $pft$object_selections [] THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'No object selections specified.', status);
      RETURN;
    IFEND;
    IF (pfc$free_object IN valid_objects) AND (access_kind = pfc$read_access) THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'Free object selected with read access.', status);
      RETURN;
    IFEND;

    last_catalog_index := UPPERBOUND (path) - 1;
    PUSH p_parent_path: [1 .. last_catalog_index];
    FOR path_index := 1 TO last_catalog_index DO
      p_parent_path^ [path_index] := path [path_index];
    FOREND;

    catalog_locator.attached := FALSE;
    osp$establish_condition_handler (^access_object_handler, {block_exit} TRUE);

    pfp$get_catalog (p_parent_path^, access_kind, authority, internal_path, parent_charge_id, permit_entry,
          catalog_locator, status);
    IF status.normal THEN
      pfp$access_last_object (path, authority, valid_objects, catalog_locator, permit_entry,
            p_physical_object, internal_path [UPPERBOUND (internal_path)], status);
      IF NOT status.normal THEN
        catalog_locator.flush_catalog_pages := FALSE;
        pfp$return_catalog (catalog_locator, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;
    ELSEIF (status.condition = pfe$unknown_last_subcatalog) AND ((pfc$free_object IN valid_objects) OR
          (pfc$catalog_object IN valid_objects) OR (pfc$purged_catalog_object IN valid_objects)) THEN
      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := p_parent_path;
      pfp$set_status_abnormal (variant_path, pfe$unknown_nth_subcatalog, status);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND pfp$access_object;

?? TITLE := '  [XDCL] pfp$build_permit_selections_str', EJECT ??

  PROCEDURE [XDCL] pfp$build_permit_selections_str (permit_selections: pft$permit_selections;
    VAR permit_string: pft$selections_string);

    VAR
      first_match: boolean,
      permit_option: pft$permit_options;

    IF permit_selections = $pft$permit_selections [] THEN
      permit_string.value := 'null set';
      permit_string.size := 8;
    ELSE
      first_match := TRUE;

      FOR permit_option := pfc$read TO pfc$control DO
        IF permit_option IN permit_selections THEN
          IF first_match THEN
            permit_string.value := '[';
            permit_string.size := 1;
            first_match := FALSE;
          ELSE
            STRINGREP (permit_string.value, permit_string.size, permit_string.value (1, permit_string.size),
              ', ');
          IFEND;

          CASE permit_option OF
          = pfc$read =
            permit_string.value (2, 4) := 'READ';
            permit_string.size := 5;
          = pfc$shorten =
            STRINGREP (permit_string.value, permit_string.size, permit_string.value (1, permit_string.size),
              'SHORTEN');
          = pfc$append =
            STRINGREP (permit_string.value, permit_string.size, permit_string.value (1, permit_string.size),
              'APPEND');
          = pfc$modify =
            STRINGREP (permit_string.value, permit_string.size, permit_string.value (1, permit_string.size),
              'MODIFY');
          = pfc$execute =
            STRINGREP (permit_string.value, permit_string.size, permit_string.value (1, permit_string.size),
              'EXECUTE');
          = pfc$cycle =
            STRINGREP (permit_string.value, permit_string.size, permit_string.value (1, permit_string.size),
              'CYCLE');
          = pfc$control =
            STRINGREP (permit_string.value, permit_string.size, permit_string.value (1, permit_string.size),
              'CONTROL');
          ELSE
            STRINGREP (permit_string.value, permit_string.size, permit_string.value (1, permit_string.size),
              'invalid option');
          CASEND;
        IFEND;
      FOREND;

      STRINGREP (permit_string.value, permit_string.size, permit_string.value (1, permit_string.size), ']');
    IFEND;
  PROCEND pfp$build_permit_selections_str;

?? TITLE := '  [XDCL] pfp$build_share_selections_str', EJECT ??

  PROCEDURE [XDCL] pfp$build_share_selections_str (share_selections: pft$share_selections;
    VAR share_string: pft$selections_string);

    VAR
      first_match: boolean,
      share_option: pft$share_options;

    IF share_selections = $pft$share_selections [] THEN
      share_string.value := 'null set';
      share_string.size := 8;
    ELSE
      first_match := TRUE;

      FOR share_option := pfc$read TO pfc$execute DO
        IF share_option IN share_selections THEN
          IF first_match THEN
            share_string.value := '[';
            share_string.size := 1;
            first_match := FALSE;
          ELSE
            STRINGREP (share_string.value, share_string.size, share_string.value (1, share_string.size),
              ', ');
          IFEND;

          CASE share_option OF
          = pfc$read =
            share_string.value (2, 4) := 'READ';
            share_string.size := 5;
          = pfc$shorten =
            STRINGREP (share_string.value, share_string.size, share_string.value (1, share_string.size),
              'SHORTEN');
          = pfc$append =
            STRINGREP (share_string.value, share_string.size, share_string.value (1, share_string.size),
              'APPEND');
          = pfc$modify =
            STRINGREP (share_string.value, share_string.size, share_string.value (1, share_string.size),
              'MODIFY');
          = pfc$execute =
            STRINGREP (share_string.value, share_string.size, share_string.value (1, share_string.size),
              'EXECUTE');
          ELSE
            STRINGREP (share_string.value, share_string.size, share_string.value (1, share_string.size),
              'invalid option');
          CASEND;
        IFEND;
      FOREND;

      STRINGREP (share_string.value, share_string.size, share_string.value (1, share_string.size), ']');
    IFEND;
  PROCEND pfp$build_share_selections_str;

?? TITLE := '  [XDCL] pfp$determine_new_cycle_number', EJECT ??

  PROCEDURE [XDCL] pfp$determine_new_cycle_number (path: pft$complete_path;
        p_cycle_list: {input} pft$p_cycle_list;
        cycle_selector: pft$cycle_selector;
    VAR new_cycle_number: pft$cycle_number;
    VAR status: ost$status);

    VAR
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      p_cycle: pft$p_cycle;

    CASE cycle_selector.cycle_option OF
    = pfc$lowest_cycle =
      locate_lowest_cycle (p_cycle_list, p_cycle);
      IF p_cycle = NIL THEN
        status.normal := TRUE;
        new_cycle_number := pfc$minimum_cycle_number;
      ELSE
        IF p_cycle^.cycle_entry.cycle_number > pfc$minimum_cycle_number THEN
          status.normal := TRUE;
          new_cycle_number := p_cycle^.cycle_entry.cycle_number - 1;
        ELSE
          pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_underflow, fs_path (1,
                fs_path_size), status);
        IFEND;
      IFEND;

    = pfc$highest_cycle =
      locate_highest_cycle (p_cycle_list, p_cycle);
      IF p_cycle = NIL THEN
        status.normal := TRUE;
        new_cycle_number := pfc$minimum_cycle_number;
      ELSE
        IF p_cycle^.cycle_entry.cycle_number < pfc$maximum_cycle_number THEN
          status.normal := TRUE;
          new_cycle_number := p_cycle^.cycle_entry.cycle_number + 1;
        ELSE
          pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_overflow, fs_path (1,
                fs_path_size), status);
        IFEND;
      IFEND;

    = pfc$specific_cycle =
      pfp$locate_specific_cycle (p_cycle_list, cycle_selector.cycle_number, p_cycle);
      IF p_cycle = NIL THEN
        status.normal := TRUE;
        new_cycle_number := cycle_selector.cycle_number;
      ELSE
        pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$duplicate_cycle, fs_path (1,
              fs_path_size), status);
        osp$append_status_integer (osc$status_parameter_delimiter, cycle_selector.cycle_number, 10, FALSE,
              status);
      IFEND;
    CASEND;
  PROCEND pfp$determine_new_cycle_number;

?? TITLE := '  [XDCL] pfp$establish_free_cycle_entry', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to establish a free cycle entry in a cycle
{   list.
{
{ DESIGN:
{   This is accomplished by either finding an existing free entry or by
{   expanding the cycle list to create a free entry.  If it is necessary to
{   expand the cycle list, a new larger cycle list is created and the old list
{   is copied to the new list.

  PROCEDURE [XDCL] pfp$establish_free_cycle_entry (p_catalog_heap: {output^} pft$p_catalog_heap;
    VAR p_cycle_list: {i/o} pft$p_cycle_list;
    VAR p_new_cycle_list: {output} pft$p_cycle_list;
    VAR new_cycle_list: {output} boolean;
    VAR p_cycle: {output} pft$p_cycle;
    VAR status: ost$status);

    VAR
      cycle_index: pft$cycle_index,
      free_physical_cycle: pft$physical_cycle;


    PROCEDURE [INLINE] locate_free_cycle_entry (p_cycle_list: {input} pft$p_cycle_list;
      VAR p_cycle: {output} pft$p_cycle);

      VAR
        cycle_index: pft$cycle_index;

      IF p_cycle_list <> NIL THEN
        FOR cycle_index := 1 TO UPPERBOUND (p_cycle_list^) DO
          IF p_cycle_list^ [cycle_index].cycle_entry.entry_type = pfc$free_cycle_entry THEN
            p_cycle := ^p_cycle_list^ [cycle_index];
            RETURN;
          IFEND;
        FOREND;
      IFEND;

      p_cycle := NIL;
    PROCEND locate_free_cycle_entry;


    status.normal := TRUE;
    new_cycle_list := FALSE;

    IF p_cycle_list = NIL THEN
      pfp$allocate_cycle_list (0, p_catalog_heap, p_new_cycle_list, status);
      IF status.normal THEN
        free_physical_cycle.cycle_entry.entry_type := pfc$free_cycle_entry;
        pfp$compute_checksum (#LOC (free_physical_cycle.cycle_entry), #SIZE (pft$cycle_entry),
              free_physical_cycle.checksum);

        FOR cycle_index := 1 TO UPPERBOUND (p_new_cycle_list^) DO
          p_new_cycle_list^ [cycle_index] := free_physical_cycle;
        FOREND;

        p_cycle := ^p_new_cycle_list^ [1];
        new_cycle_list := TRUE;
      IFEND;
    ELSE { A cycle list already exists.
      locate_free_cycle_entry (p_cycle_list, p_cycle);
      IF p_cycle = NIL THEN
        pfp$allocate_cycle_list (UPPERBOUND (p_cycle_list^), p_catalog_heap, p_new_cycle_list, status);
        IF status.normal THEN
          i#move (#LOC (p_cycle_list^), #LOC (p_new_cycle_list^), #SIZE (p_cycle_list^));

          free_physical_cycle.cycle_entry.entry_type := pfc$free_cycle_entry;
          pfp$compute_checksum (#LOC (free_physical_cycle.cycle_entry), #SIZE (pft$cycle_entry),
                free_physical_cycle.checksum);

          FOR cycle_index := UPPERBOUND (p_cycle_list^) + 1 TO UPPERBOUND (p_new_cycle_list^) DO
            p_new_cycle_list^ [cycle_index] := free_physical_cycle;
          FOREND;

          p_cycle := ^p_new_cycle_list^ [UPPERBOUND (p_cycle_list^) + 1];
          new_cycle_list := TRUE;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pfp$establish_free_cycle_entry;

?? TITLE := '  [XDCL] pfp$extract_permit_entry', EJECT ??

  PROCEDURE [XDCL] pfp$extract_permit_entry (p_permit_list: pft$p_permit_list;
        authority: pft$authority;
    VAR permit_entry: pft$permit_entry);

    VAR
      group_not_selected: boolean,
      permit: pft$permit_entry,
      permit_index: pft$permit_index,
      selected_group_type: pft$group_types;


    FUNCTION group_applies (group: pft$group;
          authority: pft$authority): boolean;

      CASE group.group_type OF
      = pfc$public =
        group_applies := TRUE;
      = pfc$family =
        group_applies := group.family_description.family = authority.family;
      = pfc$account =
        group_applies := (group.account_description.family = authority.family) AND (group.account_description.
              account = authority.account);
      = pfc$project =
        group_applies := (group.project_description.family = authority.family) AND (group.project_description.
              account = authority.account) AND (group.project_description.project = authority.project);
      = pfc$user =
        group_applies := (group.user_description.family = authority.family) AND (group.user_description.user =
              authority.user);
      = pfc$user_account =
        group_applies := (group.user_account_description.family = authority.family) AND (group.
              user_account_description.account = authority.account) AND (group.user_account_description.user =
              authority.user);
      = pfc$member =
        group_applies := (group.member_description.family = authority.family) AND (group.member_description.
              account = authority.account) AND (group.member_description.project = authority.project) AND
              (group.member_description.user = authority.user);
      ELSE
        group_applies := FALSE;
      CASEND;
    FUNCEND group_applies;


    group_not_selected := TRUE;
    permit_entry := null_permit_entry;
    selected_group_type := LOWERVALUE (pft$group_types);

    IF p_permit_list <> NIL THEN
      FOR permit_index := 1 TO UPPERBOUND (p_permit_list^) DO
        permit := p_permit_list^ [permit_index].permit_entry;
        IF (permit.entry_type = pfc$normal_permit_entry) AND (group_not_selected OR (permit.group.group_type >
              selected_group_type)) AND group_applies (permit.group, authority) THEN
          permit_entry := permit;
          selected_group_type := permit.group.group_type;
          group_not_selected := FALSE;
        IFEND;
      FOREND;
    IFEND;
  PROCEND pfp$extract_permit_entry;

?? TITLE := '  [XDCL] pfp$get_catalog', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to access the catalog identified by the
{   path.
{
{ NOTE:
{   If the path identifies an internal catalog, then the charge_id may be
{   different than the catalog_locator.queuing_info.charge_id.  The former is
{   the charge_id of the catalog identified by the path and the latter is the
{   charge_id of the last external catalog in the path.

  PROCEDURE [XDCL] pfp$get_catalog
    (    path: pft$complete_path;
         access_kind: pft$access_kind;
         authority: pft$authority;
     VAR internal_path: pft$internal_path;
     VAR charge_id: pft$charge_id;
     VAR permit_entry: pft$permit_entry;
     VAR catalog_locator: pft$catalog_locator;
     VAR status: ost$status);

    PROCEDURE get_catalog_ch
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        variant_path: pft$variant_path,
        status_id: ost$status_identifier,
        local_status: ost$status;

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := ^path;

      IF NOT process_non_local_exit THEN
        pfp$log_ascii ('***PF Condition Handler***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, {critical_message} FALSE, local_status);
        pfp$log_path (variant_path, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
              {critical_message} FALSE, local_status);
      IFEND;

      CASE condition.selector OF
      = pmc$system_conditions, pmc$block_exit_processing, mmc$segment_access_condition =
        IF process_non_local_exit THEN
          RETURN;
        IFEND;

        IF catalog_locator.attached THEN
          catalog_locator.abort_catalog_operation := TRUE;
          pfp$return_catalog (catalog_locator, local_status);
          IF NOT local_status.normal THEN
            pfp$report_system_error (local_status);
          IFEND;
        IFEND;

        IF parent_catalog_locator.attached THEN
          parent_catalog_locator.abort_catalog_operation := TRUE;
          pfp$return_catalog (parent_catalog_locator, local_status);
          IF NOT local_status.normal THEN
            pfp$report_system_error (local_status);
          IFEND;
        IFEND;

        osp$set_status_from_condition (status_id, condition, p_sfsa, local_status, handler_status);
        osp$recoverable_system_error ('UNEXPECTED STATUS', ^local_status);

        status := local_status;
        initiate_non_local_exit;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
         {syp$invalidate_open_sfid (catalog_locator.system_file_id, local_status);
          initiate_non_local_exit;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND get_catalog_ch;

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$get_catalog;
    PROCEND initiate_non_local_exit;

    CONST
      queue_internal_catalogs = TRUE;

    VAR
      catalog_attach_queued: boolean,
      extracted_permit: pft$permit_entry,
      internal_catalog_name: pft$internal_catalog_name,
      keypoint_catalog_summary: dft$keypoint_catalog_summary,
      i: 0..255,
      last_accessed_catalog_index: 0 .. pfc$maximum_catalog_depth,
      last_external_catalog_index: pft$catalog_path_index,
      local_status: ost$status,
      object_type: pft$object_types,
      p_new_path: ^pft$complete_path,
      parent_catalog_internal_name: pft$internal_catalog_name,
      parent_catalog_locator: pft$catalog_locator,
      path_index: pft$catalog_path_index,
      process_non_local_exit: boolean,
      search_access_kind: pft$access_kind,
      search_index: pft$catalog_path_index,
      variant_path: pft$variant_path;

    #KEYPOINT (osk$entry, osk$m * UPPERBOUND (path), pfk$get_catalog);
    permit_entry := null_permit_entry;
    process_non_local_exit := FALSE;
    catalog_locator.attached := FALSE;
    parent_catalog_locator.attached := FALSE;

  /get_catalog/
    BEGIN
      IF dfv$file_server_info_enabled THEN
        keypoint_catalog_summary.remote_catalog := path [pfc$family_path_index] <> osv$system_family_name;
        keypoint_catalog_summary.catalog_owner := pfc$master_catalog_owner IN authority.ownership;
        IF UPPERBOUND (path) <= 0f(16) THEN
          keypoint_catalog_summary.catalog_depth := UPPERBOUND (path);
        ELSE
          keypoint_catalog_summary.catalog_depth := 0f(16);
        IFEND;
        keypoint_catalog_summary.read_access := access_kind = pfc$read_access;
        #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_catalog_summary.keypoint_data,
              dfk$catalog_access_info);
      IFEND;

      osp$establish_condition_handler (^get_catalog_ch, {block_exit} TRUE);

      pfp$get_root_attached (path [pfc$set_path_index], catalog_locator, status);
      IF NOT status.normal THEN
        EXIT /get_catalog/;
      IFEND;

      internal_path [pfc$set_path_index] := catalog_locator.internal_catalog_name;
      charge_id.account := osc$null_name;
      charge_id.project := osc$null_name;
      last_external_catalog_index := pfc$set_path_index;
      parent_catalog_internal_name := catalog_locator.internal_catalog_name;
      last_accessed_catalog_index := 0;
      parent_catalog_locator := catalog_locator;

      { Get the last catalog in an attached state.

    /search_catalogs/
      FOR search_index := pfc$family_path_index TO UPPERBOUND (path) DO
        IF search_index = UPPERBOUND (path) THEN
          search_access_kind := access_kind;
        ELSE
          search_access_kind := pfc$read_access;
        IFEND;
        get_next_catalog (path, search_index, authority, search_access_kind, parent_catalog_internal_name,
              parent_catalog_locator, last_external_catalog_index, last_accessed_catalog_index, object_type,
              internal_catalog_name, charge_id, extracted_permit, catalog_locator, status);
        IF NOT status.normal THEN
          {
          { Update catalog_locator for cleanup.
          {
          catalog_locator := parent_catalog_locator;
          EXIT /search_catalogs/;
        IFEND;

        pfp$reduce_permits (permit_entry, extracted_permit, permit_entry);
        IF object_type = pfc$free_object THEN { Subcatalog not found in parent.
          PUSH p_new_path: [1 .. search_index];
          FOR path_index := 1 TO search_index DO
            p_new_path^ [path_index] := path [path_index];
          FOREND;
          variant_path.complete_path := TRUE;
          variant_path.p_complete_path := p_new_path;

          IF search_index = pfc$family_path_index THEN
            pfp$set_status_abnormal (variant_path, pfe$unknown_family, status);
          ELSEIF search_index = pfc$master_catalog_path_index THEN
            pfp$set_status_abnormal (variant_path, pfe$unknown_master_catalog, status);
          ELSEIF search_index = UPPERBOUND (path) THEN
            pfp$set_status_abnormal (variant_path, pfe$unknown_last_subcatalog, status);
          ELSE
            pfp$set_status_abnormal (variant_path, pfe$unknown_nth_subcatalog, status);
          IFEND;

          EXIT /search_catalogs/;
        ELSEIF object_type <> pfc$catalog_object THEN
          PUSH p_new_path: [1 .. search_index];
          FOR path_index := 1 TO search_index DO
            p_new_path^ [path_index] := path [path_index];
          FOREND;
          variant_path.complete_path := TRUE;
          variant_path.p_complete_path := p_new_path;

          IF (authority.ownership = $pft$ownership []) AND ((permit_entry.entry_type =
                pfc$free_permit_entry) OR (permit_entry.usage_permissions = $pft$permit_selections [])) THEN
            IF search_index = UPPERBOUND (path) THEN
              pfp$set_status_abnormal (variant_path, pfe$unknown_last_subcatalog, status);
            ELSE
              pfp$set_status_abnormal (variant_path, pfe$unknown_nth_subcatalog, status);
            IFEND;
          ELSE
            IF search_index = UPPERBOUND (path) THEN
              IF osv$catalog_name_security AND (authority.ownership = $pft$ownership []) AND
                    ((permit_entry.entry_type = pfc$free_permit_entry) OR
                    (permit_entry.usage_permissions = $pft$permit_selections [])) THEN
                pfp$set_status_abnormal (variant_path, pfe$unknown_last_subcatalog, status);
              ELSE
                pfp$set_status_abnormal (variant_path, pfe$last_name_not_subcatalog, status);
              IFEND;
            ELSE
              IF osv$catalog_name_security AND (authority.ownership = $pft$ownership []) AND
                    ((permit_entry.entry_type = pfc$free_permit_entry) OR
                    (permit_entry.usage_permissions = $pft$permit_selections [])) THEN
                pfp$set_status_abnormal (variant_path, pfe$unknown_nth_subcatalog, status);
              ELSE
                pfp$set_status_abnormal (variant_path, pfe$nth_name_not_subcatalog, status);
              IFEND;
            IFEND;
          IFEND;

          EXIT /search_catalogs/;
        IFEND;

        internal_path [search_index] := internal_catalog_name;
        IF search_index < UPPERBOUND (path) THEN
          parent_catalog_internal_name := internal_catalog_name;
        IFEND;

        IF catalog_locator.internal_catalog_name <> parent_catalog_locator.internal_catalog_name THEN
          {
          { The new catalog represents a different physical catalog. Return the
          { parent.
          {
          pfp$return_catalog (parent_catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
        IFEND;

        parent_catalog_locator := catalog_locator;
      FOREND /search_catalogs/;

      IF status.normal AND NOT catalog_locator.open THEN
        pfp$open_attached_catalog (access_kind, catalog_locator, status);
        last_accessed_catalog_index := last_external_catalog_index;
      IFEND;

      IF status.normal AND (last_external_catalog_index < UPPERBOUND (path)) AND
            (last_accessed_catalog_index < UPPERBOUND (path)) THEN
        {
        { The last external catalog must be opened and searched again for this
        { internal catalog. This catalog has already been attached but possibly
        { not accessed; e.g. pfp$get_catalog called with just a family path.
        {
        catalog_attach_queued := FALSE;
        get_next_catalog_from_parent (path, UPPERBOUND (path), authority, access_kind,
              NOT queue_internal_catalogs, parent_catalog_internal_name, catalog_locator,
              last_external_catalog_index, last_accessed_catalog_index, catalog_attach_queued, charge_id,
              catalog_locator, object_type, internal_catalog_name, extracted_permit, status);
      IFEND;

      IF NOT status.normal THEN
        pfp$return_catalog (catalog_locator, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;
    END /get_catalog/;

    osp$disestablish_cond_handler;

    #KEYPOINT (osk$exit, 0, pfk$get_catalog);
  PROCEND pfp$get_catalog;

?? TITLE := '  [XDCL] pfp$internal_access_object', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to establish access to the object
{   specified by the internal path parameter.
{
{ NOTES:
{   The internal path is assumed to start with the unique set name.  This
{   routine is not used to locate cycles.

  PROCEDURE [XDCL] pfp$internal_access_object (set_name: stt$set_name;
        internal_path: pft$internal_path;
        access_kind: pft$access_kind;
        authority: pft$authority;
        extract_permits: boolean;
        catalog_remote: boolean;
    VAR p_object: {output} pft$p_object;
    VAR catalog_locator: pft$catalog_locator;
    VAR permit_entry: pft$permit_entry;
    VAR status: ost$status);

    VAR
      catalog_index: pft$array_index,
      starting_catalog_index: pft$array_index,
      last_catalog_index: pft$array_index,
      file_index: pft$array_index,
      found_catalog_index: pft$array_index,
      keypoint_catalog_summary: dft$keypoint_catalog_summary,
      local_status: ost$status,
      new_permit_entry: pft$permit_entry,
      p_permit_list: pft$p_permit_list,
      parent_catalog_locator: pft$catalog_locator,
      search_access_kind: pft$access_kind;

    status.normal := TRUE;
    permit_entry := null_permit_entry;
    starting_catalog_index := pfc$set_path_index;
    last_catalog_index := UPPERBOUND (internal_path) - 1;
    IF dfv$file_server_info_enabled THEN
      keypoint_catalog_summary.remote_catalog := catalog_remote;
      keypoint_catalog_summary.catalog_owner := (pfc$master_catalog_owner IN authority.ownership);
      IF last_catalog_index <= 0f(16) THEN
        keypoint_catalog_summary.catalog_depth := last_catalog_index;
      ELSE
        keypoint_catalog_summary.catalog_depth := 0f(16);
      IFEND;
      keypoint_catalog_summary.read_access := FALSE;
      #keypoint (dfk$file_server_info_class, osk$m * keypoint_catalog_summary.keypoint_data,
            dfk$catalog_access_info);
    IFEND;
    {
    { Search for catalog objects.
    {
    IF NOT extract_permits THEN
      {
      { Only need to access the last catalog. Attempt fast access.
      {
      pfp$attach_last_queued_catalog (set_name, internal_path, last_catalog_index, access_kind,
            found_catalog_index, catalog_locator, status);
      IF status.normal THEN
        starting_catalog_index := found_catalog_index + 1;
      ELSEIF (status.condition = pfe$no_queued_catalog_found) THEN
        status.normal := TRUE;
      IFEND;
    IFEND;

    IF status.normal THEN
      IF starting_catalog_index = pfc$set_path_index THEN
        pfp$attach_root_catalog (set_name, pfc$read_access, catalog_locator, status);
        starting_catalog_index := pfc$family_path_index;
      IFEND;
    IFEND;

    IF status.normal THEN

    /search_remaining_catalogs/
      FOR catalog_index := starting_catalog_index TO last_catalog_index DO
        pfp$internal_locate_object (catalog_locator.object_list_descriptor.p_object_list, internal_path
              [catalog_index], p_object);
        IF p_object = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL catalog object pointer.', status);
          #keypoint (osk$unusual, 0, pfk$unknown_internal_path);
          pfp$return_catalog (catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
          RETURN;
        IFEND;

        IF extract_permits THEN
          pfp$build_permit_list_pointer (p_object^.object_entry.permit_list_locator, catalog_locator.
                p_catalog_file, p_permit_list);
          pfp$extract_permit_entry (p_permit_list, authority, new_permit_entry);
          pfp$reduce_permits (permit_entry, new_permit_entry, permit_entry);
        IFEND;

        parent_catalog_locator := catalog_locator;
        IF catalog_index = last_catalog_index THEN
          search_access_kind := access_kind;
        ELSE
          search_access_kind := pfc$read_access;
        IFEND;

        pfp$access_next_catalog (search_access_kind, parent_catalog_locator, p_object, catalog_remote,
              catalog_locator, status);
        IF NOT status.normal THEN
          pfp$return_catalog (parent_catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
          RETURN;
        IFEND;

        IF catalog_locator.object_list_descriptor.catalog_type = pfc$external_catalog THEN
          pfp$return_catalog (parent_catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
        IFEND;
      FOREND /search_remaining_catalogs/;
      {
      { Search for file object.
      {
      file_index := UPPERBOUND (internal_path);
      pfp$internal_locate_object (catalog_locator.object_list_descriptor.p_object_list, internal_path
            [file_index], p_object);
      IF p_object = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_permanent_file, '', status);
        #keypoint (osk$unusual, 0, pfk$unknown_internal_path);
        pfp$return_catalog (catalog_locator, local_status);
        pfp$process_unexpected_status (local_status);
        RETURN;
      IFEND;

      IF extract_permits THEN
        pfp$build_permit_list_pointer (p_object^.object_entry.permit_list_locator, catalog_locator.
              p_catalog_file, p_permit_list);
        pfp$extract_permit_entry (p_permit_list, authority, new_permit_entry);
        pfp$reduce_permits (permit_entry, new_permit_entry, permit_entry);
      IFEND;
    IFEND;
  PROCEND pfp$internal_access_object;

?? TITLE := '  [XDCL] pfp$internal_locate_object', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to search an object list for an object
{   with the specified internal name.  If the object cannot be found, a NIL
{   p_object pointer is returned.

  PROCEDURE [XDCL] pfp$internal_locate_object (p_object_list: {input} pft$p_object_list;
        internal_object_name: pft$internal_name;
    VAR p_object: {output} pft$p_object);

    VAR
      object_index: pft$object_index;

    #keypoint (osk$entry, 0, pfk$internal_locate_object);

    IF p_object_list <> NIL THEN
      FOR object_index := 1 TO UPPERBOUND (p_object_list^) DO
        p_object := ^p_object_list^ [object_index];
        IF (p_object^.object_entry.object_type <> pfc$free_object) AND (p_object^.object_entry.
              internal_object_name = internal_object_name) THEN
          #keypoint (osk$exit, osk$m * object_index, pfk$internal_locate_object);
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    p_object := NIL;
    #keypoint (osk$exit, 0, pfk$internal_locate_object);
  PROCEND pfp$internal_locate_object;

?? TITLE := '  [XDCL] pfp$locate_cycle', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to locate the selected cycle entry for the
{   specified file object.  If the selected cycle cannot be found, an abnormal
{   status is returned.

  PROCEDURE [XDCL] pfp$locate_cycle
   (    path: pft$complete_path;
        p_cycle_list: {input} pft$p_cycle_list;
        cycle_selector: pft$cycle_selector;
    VAR p_cycle: {output} pft$p_cycle;
    VAR status: ost$status);

    VAR
      variant_path: pft$variant_path;

    CASE cycle_selector.cycle_option OF
    = pfc$lowest_cycle =
      locate_lowest_cycle (p_cycle_list, p_cycle);
    = pfc$highest_cycle =
      locate_highest_cycle (p_cycle_list, p_cycle);
    = pfc$specific_cycle =
      pfp$locate_specific_cycle (p_cycle_list, cycle_selector.cycle_number, p_cycle);
    CASEND;

    IF p_cycle <> NIL THEN
      status.normal := TRUE;
    ELSE
      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := ^path;
      CASE cycle_selector.cycle_option OF
      = pfc$lowest_cycle, pfc$highest_cycle =
        pfp$set_status_abnormal (variant_path, pfe$unknown_permanent_file, status);
      = pfc$specific_cycle =
        pfp$set_status_abnormal (variant_path, pfe$unknown_cycle, status);
        osp$append_status_integer (osc$status_parameter_delimiter, cycle_selector.cycle_number, radix,
              NOT include_radix, status);
      CASEND;
    IFEND;
  PROCEND pfp$locate_cycle;

?? TITLE := '  [XDCL] pfp$locate_log_entry', EJECT ??

  PROCEDURE [XDCL] pfp$locate_log_entry (p_log_list: {input} pft$p_log_list;
        user_id: ost$user_identification;
    VAR p_log: {output} pft$p_log);

    VAR
      log_index: pft$log_index;

    IF p_log_list <> NIL THEN
      FOR log_index := 1 TO UPPERBOUND (p_log_list^) DO
        IF (p_log_list^ [log_index].log_entry.entry_type = pfc$normal_log_entry) AND (user_id = p_log_list^
              [log_index].log_entry.user_id) THEN
          p_log := ^p_log_list^ [log_index];
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    p_log := NIL;
  PROCEND pfp$locate_log_entry;

?? TITLE := '  [XDCL] pfp$reduce_permits', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to reduce two permit entries into a single
{   entry by picking the one with the more selective group.  In the case of
{   equally selective groups, the low level entry will become the reduced
{   permit entry.

  PROCEDURE [XDCL] pfp$reduce_permits (high_level_permit_entry: pft$permit_entry;
        low_level_permit_entry: pft$permit_entry;
    VAR reduced_permit_entry: pft$permit_entry);

    IF high_level_permit_entry.entry_type = pfc$normal_permit_entry THEN
      IF low_level_permit_entry.entry_type = pfc$normal_permit_entry THEN
        IF low_level_permit_entry.group.group_type >= high_level_permit_entry.group.group_type THEN
          reduced_permit_entry := low_level_permit_entry;
        ELSE
          reduced_permit_entry := high_level_permit_entry;
        IFEND;
      ELSE
        reduced_permit_entry := high_level_permit_entry;
      IFEND;
    ELSE
      reduced_permit_entry := low_level_permit_entry;
    IFEND;
  PROCEND pfp$reduce_permits;

?? TITLE := '  [XDCL] pfp$validate_default_password', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to validate a possibly defaulted password.
{
{ DESIGN:
{   If the password selector indicates a default password, then this interface
{   will return normal status for the system, family, and master catalog
{   owners.  For non-owners osc$null_name will be used as the default password.
{   This is not a security violation because the owner may use the
{   DISPLAY_CATALOG_ENTRY command to determine the file password.  If a
{   specific password is specified, the password must pass the rules in
{   pfp$validate_password.

  PROCEDURE [XDCL] pfp$validate_default_password (path: pft$complete_path;
        authority: pft$authority;
        access_password: pft$password_selector;
        p_file_object: {input^} pft$p_object;
    VAR status: ost$status);

    IF access_password.password_specified = pfc$default_password_option THEN
      IF (pfc$master_catalog_owner IN authority.ownership) OR (pfc$family_owner IN authority.ownership) OR
            (pfc$system_owner IN authority.ownership) THEN
        status.normal := TRUE;
      ELSE
        pfp$validate_password (path, authority, osc$null_name, p_file_object, status);
      IFEND;
    ELSE
      pfp$validate_password (path, authority, access_password.password, p_file_object, status);
    IFEND;
  PROCEND pfp$validate_default_password;

?? TITLE := '  [XDCL] pfp$validate_family_ownership', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to validate that the authority specified
{   grants ownership rights to the specified family.  Ownership rights are
{   granted to the set owner, system administrators, and family administrators
{   for the specified family.

  PROCEDURE [XDCL] pfp$validate_family_ownership (family_name: ost$family_name;
        authority: pft$authority;
    VAR status: ost$status);

    IF (pfc$family_owner IN authority.ownership) OR (pfc$set_owner IN authority.ownership) OR
          (pfc$system_owner IN authority.ownership) THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$not_family_owner, family_name, status);
    IFEND;
  PROCEND pfp$validate_family_ownership;

?? TITLE := '  [XDCL] pfp$validate_file_permission', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to validate that the file access described
{   by the usage_intentions and share_intentions parameters is permitted by the
{   permit_entry parameter.  If the access is not allowed, an abnormal status
{   is returned.

  PROCEDURE [XDCL] pfp$validate_file_permission (path: pft$complete_path;
        authority: pft$authority;
        permit_entry: pft$permit_entry;
        usage_intentions: pft$permit_selections;
        share_intentions: pft$share_selections;
    VAR status: ost$status);

    VAR
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      selections_string: pft$selections_string;

    IF (pfc$family_owner IN authority.ownership) OR (pfc$system_owner IN authority.ownership) THEN
      status.normal := TRUE;
    ELSEIF (permit_entry.entry_type = pfc$free_permit_entry) OR (permit_entry.usage_permissions =
          $pft$permit_selections []) THEN
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_permanent_file, fs_path (1,
            fs_path_size), status);
    ELSE
      IF usage_intentions <= permit_entry.usage_permissions THEN
        IF share_intentions >= permit_entry.share_requirements THEN
          status.normal := TRUE;
        ELSE
          pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$sharing_not_permitted, fs_path (1,
                fs_path_size), status);
          pfp$build_share_selections_str (permit_entry.share_requirements, selections_string);
          osp$append_status_parameter (osc$status_parameter_delimiter, selections_string.value (1,
                selections_string.size), status);
          pfp$build_share_selections_str (share_intentions, selections_string);
          osp$append_status_parameter (osc$status_parameter_delimiter, selections_string.value (1,
                selections_string.size), status);
        IFEND;
      ELSE
        pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$usage_not_permitted, fs_path (1,
              fs_path_size), status);
        pfp$build_permit_selections_str (permit_entry.usage_permissions, selections_string);
        osp$append_status_parameter (osc$status_parameter_delimiter, selections_string.value (1,
              selections_string.size), status);
        pfp$build_permit_selections_str (usage_intentions, selections_string);
        osp$append_status_parameter (osc$status_parameter_delimiter, selections_string.value (1,
              selections_string.size), status);
      IFEND;
    IFEND;
  PROCEND pfp$validate_file_permission;

?? TITLE := '  [XDCL] pfp$validate_ored_permission', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to validate that at least one of the
{   permit options specified by the usage_intentions parameter is permitted by
{   the permit_entry parameter and that the share_intentions parameter is
{   permitted by the permit_entry parameter.
{
{ DESIGN:
{   If the access is not allowed, an abnormal status is returned.

  PROCEDURE [XDCL] pfp$validate_ored_permission
    (    path: pft$complete_path;
         authority: pft$authority;
         permit_entry: pft$permit_entry;
         usage_intentions: pft$permit_selections;
         share_intentions: pft$share_selections;
     VAR status: ost$status);

    VAR
      fs_path_size: fst$path_size,
      p_fs_path: ^fst$path,
      p_selections_string: ^pft$selections_string;

    IF (pfc$family_owner IN authority.ownership) OR (pfc$system_owner IN authority.ownership) THEN
      status.normal := TRUE;
    ELSEIF (permit_entry.entry_type = pfc$free_permit_entry) OR
          (permit_entry.usage_permissions = $pft$permit_selections []) THEN
      PUSH p_fs_path;
      pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_permanent_file,
            p_fs_path^ (1, fs_path_size), status);
    ELSEIF usage_intentions * permit_entry.usage_permissions = $pft$permit_selections [] THEN
      PUSH p_fs_path;
      pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$usage_not_permitted,
            p_fs_path^ (1, fs_path_size), status);
      PUSH p_selections_string;
      pfp$build_permit_selections_str (permit_entry.usage_permissions, p_selections_string^);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            p_selections_string^.value (1, p_selections_string^.size), status);
      build_ored_permit_string (usage_intentions, p_selections_string^);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            p_selections_string^.value (1, p_selections_string^.size), status);
    ELSEIF permit_entry.share_requirements <= share_intentions THEN
      status.normal := TRUE;
    ELSE
      PUSH p_fs_path;
      pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$sharing_not_permitted,
            p_fs_path^ (1, fs_path_size), status);
      PUSH p_selections_string;
      pfp$build_share_selections_str (permit_entry.share_requirements, p_selections_string^);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            p_selections_string^.value (1, p_selections_string^.size), status);
      pfp$build_share_selections_str (share_intentions, p_selections_string^);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            p_selections_string^.value (1, p_selections_string^.size), status);
    IFEND;
  PROCEND pfp$validate_ored_permission;

?? TITLE := '  [XDCL] pfp$validate_ownership', EJECT ??

  PROCEDURE [XDCL] pfp$validate_ownership (authority: pft$authority;
        path: pft$complete_path;
    VAR status: ost$status);

    IF (pfc$master_catalog_owner IN authority.ownership) OR (pfc$family_owner IN authority.ownership) OR
          (pfc$system_owner IN authority.ownership) THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$not_master_catalog_owner, path
            [pfc$master_catalog_path_index], status);
      osp$append_status_parameter (osc$status_parameter_delimiter, path [pfc$family_path_index], status);
    IFEND;
  PROCEND pfp$validate_ownership;

?? TITLE := '  [XDCL, #GATE] pfp$validate_password', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to validate that the access_password
{   parameter matches the password contained in the catalog.  If the passwords
{   do not match, an abnormal status is returned.

  PROCEDURE [XDCL, #GATE] pfp$validate_password (
        path: pft$complete_path;
        authority: pft$authority;
        access_password: pft$password;
        p_file_object: {input^} pft$p_object;
    VAR status: ost$status);

    VAR
      fs_path: fst$path,
      fs_path_size: fst$path_size;

    IF (access_password = p_file_object^.object_entry.password) OR (pfc$family_owner IN authority.ownership)
          OR (pfc$system_owner IN authority.ownership) THEN
      status.normal := TRUE;
    ELSE
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$incorrect_password,
            fs_path (1, fs_path_size), status);
    IFEND;
  PROCEND pfp$validate_password;

?? TITLE := '  [XDCL] pfp$validate_set_owner', EJECT ??

  PROCEDURE [XDCL] pfp$validate_set_owner (set_name: stt$set_name;
        authority: pft$authority;
    VAR status: ost$status);

    IF (pfc$set_owner IN authority.ownership) OR (pfc$system_owner IN authority.ownership) THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$not_set_owner, set_name, status);
    IFEND;
  PROCEND pfp$validate_set_owner;

?? TITLE := '  access_next_object', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to establish access to the next object
{   along a path through the catalog tree.  This includes extracting permit
{   information that may apply.

  PROCEDURE access_next_object
    (    object_list_descriptor: pft$object_list_descriptor;
         next_object_name: pft$name;
         valid_objects: pft$object_selections;
         authority: pft$authority;
         p_catalog_file: {input^} pft$p_catalog_file;
     VAR p_next_object: {output} pft$p_object;
     VAR extracted_permit_entry: pft$permit_entry);

    VAR
      p_permit_list: pft$p_permit_list;

    pfp$locate_object (next_object_name, valid_objects, object_list_descriptor, p_next_object);
    IF p_next_object = NIL THEN
      extracted_permit_entry := null_permit_entry;
    ELSE
      pfp$build_permit_list_pointer (p_next_object^.object_entry.permit_list_locator, p_catalog_file,
            p_permit_list);
      pfp$extract_permit_entry (p_permit_list, authority, extracted_permit_entry);
    IFEND;
  PROCEND access_next_object;

?? TITLE := '  build_ored_permit_string', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to build a string containing each of the
{   permit options, specified by the permit_selections parameter, as an
{   individual set, with each set separated by an "or".

  PROCEDURE build_ored_permit_string
    (    permit_selections: pft$permit_selections;
     VAR permit_string: pft$selections_string);

    VAR
      first_match: boolean,
      permit_option: pft$permit_options;

    IF permit_selections = $pft$permit_selections [] THEN
      permit_string.value := 'null set';
      permit_string.size := 8;
    ELSE
      first_match := TRUE;

      FOR permit_option := pfc$read TO pfc$control DO
        IF permit_option IN permit_selections THEN
          IF first_match THEN
            permit_string.value := '';
            permit_string.size := 0;
            first_match := FALSE;
          ELSE
            STRINGREP (permit_string.value, permit_string.size, permit_string.value (1, permit_string.size),
                  ' or ');
          IFEND;

          CASE permit_option OF
          = pfc$read =
            permit_string.value (1, 6) := '[READ]';
            permit_string.size := 6;
          = pfc$shorten =
            STRINGREP (permit_string.value, permit_string.size, permit_string.value (1, permit_string.size),
                  '[SHORTEN]');
          = pfc$append =
            STRINGREP (permit_string.value, permit_string.size, permit_string.value (1, permit_string.size),
                  '[APPEND]');
          = pfc$modify =
            STRINGREP (permit_string.value, permit_string.size, permit_string.value (1, permit_string.size),
                  '[MODIFY]');
          = pfc$execute =
            STRINGREP (permit_string.value, permit_string.size, permit_string.value (1, permit_string.size),
                  '[EXECUTE]');
          = pfc$cycle =
            STRINGREP (permit_string.value, permit_string.size, permit_string.value (1, permit_string.size),
                  '[CYCLE]');
          = pfc$control =
            STRINGREP (permit_string.value, permit_string.size, permit_string.value (1, permit_string.size),
                  '[CONTROL]');
          ELSE
            STRINGREP (permit_string.value, permit_string.size, permit_string.value (1, permit_string.size),
                  'invalid option');
          CASEND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND build_ored_permit_string;

?? TITLE := '  get_next_catalog', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to traverse the catalog to the next lower
{   catalog.  The result of this procedure is to get the next lower catalog in
{   an attached state and to obtain the permit for that catalog.
{
{ DESIGN:
{   The desired catalog, as designated by the path and search_index, is first
{   looked for in the catalog queue.  If the catalog is not queued, then it
{   becomes necessary to open and search the parent catalog for the desired
{   catalog.  If the catalog is not found or proves to be a file object, a
{   normal status is returned but the object type indicates a non-catalog
{   object.  The caller is responsible for deciding whether or not to set an
{   appropriate condition.
{
{ NOTE:
{   If the path identifies an internal catalog, then the charge_id may be
{   different than the catalog_locator.queuing_info.charge_id.  The former is
{   the charge_id of the catalog identified by the path and the latter is the
{   charge_id of the last external catalog in the path.

  PROCEDURE get_next_catalog
    (    path: pft$complete_path;
         search_index: pft$array_index;
         authority: pft$authority;
         search_access_kind: pft$access_kind;
         parent_catalog_internal_name: pft$internal_catalog_name;
     VAR parent_catalog_locator: {i/o} pft$catalog_locator;
     VAR last_external_catalog_index: {i/o} pft$catalog_path_index;
     VAR last_accessed_catalog_index: {i/o} 0 .. pfc$maximum_catalog_depth;
     VAR object_type: pft$object_types;
     VAR internal_catalog_name: pft$internal_catalog_name;
     VAR charge_id: pft$charge_id;
     VAR extracted_permit: pft$permit_entry;
     VAR catalog_locator: pft$catalog_locator;
     VAR status: ost$status);

    CONST
      queue_internal_catalogs = TRUE;

    VAR
      catalog_access_queued: boolean,
      catalog_attach_queued: boolean,
      p_queued_internal_catalog: ^pft$queued_internal_catalog;

    status.normal := TRUE;
    p_queued_internal_catalog := NIL;

    IF parent_catalog_locator.queuing_info.access_queued THEN
      {
      { Check internal catalog queue.
      {
      locate_internal_catalog (path [search_index], parent_catalog_internal_name,
            parent_catalog_locator.queuing_info.p_internal_catalog_list, p_queued_internal_catalog);
    IFEND;

    IF p_queued_internal_catalog <> NIL THEN
      {
      { The internal catalog is queued. The alarm is not set on this catalog.
      { If it were, the parent would be alarmed and not access queued.
      {
      object_type := pfc$catalog_object;
      internal_catalog_name := p_queued_internal_catalog^.internal_catalog_name;
      charge_id := p_queued_internal_catalog^.charge_id;
      extracted_permit := p_queued_internal_catalog^.permit;
      catalog_locator := parent_catalog_locator;
    ELSE
      {
      { Try queued catalog access.
      {
      pfp$get_queued_catalog (path [search_index], parent_catalog_internal_name, catalog_attach_queued,
            catalog_access_queued, catalog_locator, status);
      IF status.normal THEN
        IF catalog_access_queued THEN
          last_external_catalog_index := search_index;
          internal_catalog_name := catalog_locator.internal_catalog_name;
          charge_id := catalog_locator.queuing_info.charge_id;
          extracted_permit := catalog_locator.queuing_info.permit;
          object_type := pfc$catalog_object;
        ELSE
          {
          { Catalog access not queued. Access parent catalog to obtain permit.
          {
          IF NOT parent_catalog_locator.open THEN
            {
            { The parent catalog should always be opened for read access except
            { when it is the next to the last catalog and the last catalog is an
            { internal catalog, in which case the parent catalog would be opened
            { for the same access as the last catalog.  Currently the only
            { internal catalog is the family catalog.  If any additional internal
            { catalogs are created in the future, this code could prove to be a
            { problem.
            {
            IF UPPERBOUND (path) = pfc$family_path_index THEN
              pfp$open_attached_catalog (search_access_kind, parent_catalog_locator, status);
            ELSE
              pfp$open_attached_catalog (pfc$read_access, parent_catalog_locator, status);
            IFEND;
            IF status.normal THEN
              last_accessed_catalog_index := last_external_catalog_index;
            ELSEIF status.condition <> pfe$catalog_access_retry THEN
              pfp$report_unexpected_status (status);
            IFEND;
          IFEND;

          IF status.normal THEN
            get_next_catalog_from_parent (path, search_index, authority, search_access_kind,
                  queue_internal_catalogs, parent_catalog_internal_name, parent_catalog_locator,
                  last_external_catalog_index, last_accessed_catalog_index, catalog_attach_queued, charge_id,
                  catalog_locator, object_type, internal_catalog_name, extracted_permit, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND get_next_catalog;

?? TITLE := '  get_next_catalog_from_parent', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to search the parent catalog looking for
{   the search catalog.  As a result of this procedure, the desired catalog
{   will be in an attached state and the permit information for the desired
{   catalog will have been obtained fresh from the parent.
{
{ DESIGN:
{   The search begins with the currently accessed catalog and continues through
{   all internal catalogs to the desired catalog.  When the desired catalog is
{   found, an attempt will be made to queue the access, so subsequent accesses,
{   to the return catalog, will not have to re-access the catalog.
{
{ NOTE:
{   If the path identifies an internal catalog, then the charge_id may be
{   different than the catalog_locator.queuing_info.charge_id.  The former is
{   the charge_id of the catalog identified by the path and the latter is the
{   charge_id of the last external catalog in the path.

  PROCEDURE get_next_catalog_from_parent
    (    path: pft$complete_path;
         search_index: pft$catalog_path_index;
         authority: pft$authority;
         search_access_kind: pft$access_kind;
         queue_internal_catalogs: boolean;
         parent_catalog_name: pft$internal_catalog_name;
     VAR parent_catalog_locator: {i/o} pft$catalog_locator;
     VAR last_external_catalog_index: {i/o} pft$catalog_path_index;
     VAR last_accessed_catalog_index: {i/o} 0 .. pfc$maximum_catalog_depth;
     VAR catalog_attach_queued: {i/o} boolean;
     VAR charge_id: {i/o} pft$charge_id;
     VAR catalog_locator: {i(if catalog_attach_queued)/o} pft$catalog_locator;
     VAR object_type: pft$object_types;
     VAR internal_catalog_name: pft$internal_catalog_name;
     VAR extracted_permit: pft$permit_entry;
     VAR status: ost$status);

    VAR
      catalog_index: pft$catalog_path_index,
      p_physical_fmd: ^pft$physical_fmd,
      p_physical_object: ^pft$physical_object,
      parent_catalog_internal_name: pft$internal_catalog_name,
      return_status: ost$status;

    status.normal := TRUE;
    parent_catalog_internal_name := parent_catalog_name;

  /access_last_catalog/
    FOR catalog_index := last_accessed_catalog_index + 1 TO search_index DO
      access_next_object (parent_catalog_locator.object_list_descriptor, path [catalog_index],
            $pft$object_selections [pfc$catalog_object, pfc$file_object], authority,
            parent_catalog_locator.p_catalog_file, p_physical_object, extracted_permit);
      IF p_physical_object = NIL THEN
        object_type := pfc$free_object;
      ELSE
        object_type := p_physical_object^.object_entry.object_type;
      IFEND;

      IF object_type <> pfc$catalog_object THEN
        IF catalog_attach_queued THEN
          catalog_attach_queued := FALSE;
          pfp$return_catalog (catalog_locator, status);
        IFEND;
        catalog_locator := parent_catalog_locator;
        EXIT /access_last_catalog/;
      IFEND;
      {
      { Found a desired catalog along the way.
      {
      internal_catalog_name := p_physical_object^.object_entry.internal_object_name;
      IF p_physical_object^.object_entry.catalog_object_locator.catalog_type = pfc$internal_catalog THEN
        {
        { Build the new internal object list pointer.
        {
        pfp$access_next_catalog (search_access_kind, parent_catalog_locator, p_physical_object,
              (path [pfc$family_path_index] <> osv$system_family_name), parent_catalog_locator, status);
        IF NOT status.normal THEN
          EXIT /access_last_catalog/;
        IFEND;
        last_accessed_catalog_index := catalog_index;
        IF catalog_index = search_index THEN
          {
          { Found the desired catalog.
          {
          charge_id := p_physical_object^.object_entry.charge_id;
          IF parent_catalog_locator.queuing_info.access_queued AND queue_internal_catalogs THEN
            insert_internal_catalog (parent_catalog_internal_name, path [catalog_index],
                  internal_catalog_name, charge_id, extracted_permit,
                  parent_catalog_locator.queuing_info.p_internal_catalog_list);
          IFEND;
          catalog_locator := parent_catalog_locator;
        ELSE
          parent_catalog_internal_name := internal_catalog_name;
        IFEND;
      ELSE {external catalog}
        IF catalog_attach_queued THEN
          IF internal_catalog_name <> catalog_locator.internal_catalog_name THEN
            {
            { Wrong catalog found. This can happen when a delete catalog is
            { followed by a create catalog of the same external name from a
            { different job.
            {
            catalog_locator.queuing_info.attach_queued := FALSE;
            catalog_attach_queued := FALSE;
            catalog_locator.queuing_info.set_catalog_alarm := TRUE;
            pfp$return_catalog (catalog_locator, return_status);
            pfp$process_unexpected_status (return_status);
          IFEND;

          IF p_physical_object^.object_entry.catalog_object_locator.global_file_name <>
                catalog_locator.global_file_name THEN
            {
            { This catalog was moved by a MOVE_CLASSES command executed in a differnet
            { job while the catalog was attached and queued in this job.
            {
            catalog_locator.queuing_info.attach_queued := FALSE;
            catalog_attach_queued := FALSE;
            catalog_locator.queuing_info.set_catalog_alarm := TRUE;
            pfp$return_catalog (catalog_locator, return_status);
            pfp$process_unexpected_status (return_status);
          IFEND;
        IFEND;

        last_external_catalog_index := catalog_index;
        IF NOT catalog_attach_queued THEN
          pfp$build_fmd_pointer (p_physical_object^.object_entry.catalog_object_locator.fmd_locator,
                parent_catalog_locator.p_catalog_file, p_physical_fmd);
          IF p_physical_fmd = NIL THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                  ' NIL catalog FMD in get_next_catalog_from_parent', status);
          ELSE
            pfp$physically_attach_catalog (parent_catalog_locator.set_name, internal_catalog_name,
                  p_physical_object^.object_entry.catalog_object_locator.global_file_name,
                  ^p_physical_fmd^.fmd, (path [pfc$family_path_index] <> osv$system_family_name),
                  catalog_locator, status);
          IFEND;
          IF status.normal THEN
            charge_id := p_physical_object^.object_entry.charge_id;
            {
            { Build locator fields to make the attach and access queuable.
            {
            catalog_locator.queuing_info.set_catalog_alarm := FALSE;
            catalog_locator.queuing_info.attach_queued := TRUE;
            catalog_locator.queuing_info.parent_catalog_internal_name := parent_catalog_internal_name;
            catalog_locator.queuing_info.external_catalog_name := path [catalog_index];
            catalog_locator.queuing_info.charge_id := charge_id;
            catalog_locator.queuing_info.access_queued := TRUE;
            catalog_locator.queuing_info.p_internal_catalog_list := NIL;
            catalog_locator.queuing_info.permit := extracted_permit;
          IFEND;
        IFEND;
      IFEND;

      IF NOT status.normal THEN
        EXIT /access_last_catalog/;
      IFEND;
    FOREND /access_last_catalog/;
  PROCEND get_next_catalog_from_parent;

?? TITLE := '  [INLINE] insert_internal_catalog', EJECT ??

  PROCEDURE [INLINE] insert_internal_catalog
    (    parent_catalog_name: pft$internal_catalog_name;
         external_catalog_name: pft$name;
         internal_catalog_name: pft$internal_catalog_name;
         charge_id: pft$charge_id;
         permit_entry: pft$permit_entry;
     VAR p_internal_catalog: {i/o} ^pft$queued_internal_catalog);

    VAR
      p_old_internal_catalog: ^pft$queued_internal_catalog;

    p_old_internal_catalog := p_internal_catalog;

    ALLOCATE p_internal_catalog IN pfv$p_p_job_heap^^;
    IF p_internal_catalog <> NIL THEN
      p_internal_catalog^.parent_catalog_name := parent_catalog_name;
      p_internal_catalog^.external_catalog_name := external_catalog_name;
      p_internal_catalog^.internal_catalog_name := internal_catalog_name;
      p_internal_catalog^.charge_id := charge_id;
      p_internal_catalog^.permit := permit_entry;
      p_internal_catalog^.p_next_internal_catalog := p_old_internal_catalog;
    IFEND;
  PROCEND insert_internal_catalog;

?? TITLE := '  [INLINE] locate_highest_cycle', EJECT ??

  PROCEDURE [INLINE] locate_highest_cycle (p_cycle_list: {input} pft$p_cycle_list;
    VAR p_highest_cycle_entry: {output} pft$p_cycle);

    VAR
      cycle_index: pft$cycle_index,
      highest_cycle_number: pft$cycle_number;

    p_highest_cycle_entry := NIL;

    IF p_cycle_list <> NIL THEN
      highest_cycle_number := pfc$minimum_cycle_number;

      FOR cycle_index := 1 TO UPPERBOUND (p_cycle_list^) DO
        IF (p_cycle_list^ [cycle_index].cycle_entry.entry_type = pfc$normal_cycle_entry) AND (p_cycle_list^
              [cycle_index].cycle_entry.cycle_number >= highest_cycle_number) THEN
          highest_cycle_number := p_cycle_list^ [cycle_index].cycle_entry.cycle_number;
          p_highest_cycle_entry := ^p_cycle_list^ [cycle_index];
        IFEND;
      FOREND;
    IFEND;
  PROCEND locate_highest_cycle;

?? TITLE := '  [INLINE] locate_internal_catalog', EJECT ??

  PROCEDURE [INLINE] locate_internal_catalog (catalog: pft$name;
        parent: pft$internal_catalog_name;
        p_internal_catalog_list: {input} pft$p_queued_internal_catalog;
    VAR found_internal_catalog: pft$p_queued_internal_catalog);

    found_internal_catalog := p_internal_catalog_list;

    WHILE found_internal_catalog <> NIL DO
      IF (found_internal_catalog^.external_catalog_name = catalog) AND (found_internal_catalog^.
            parent_catalog_name = parent) THEN { Catalog found.
        RETURN;
      ELSE
        found_internal_catalog := found_internal_catalog^.p_next_internal_catalog;
      IFEND;
    WHILEND;
  PROCEND locate_internal_catalog;

?? TITLE := '  [INLINE] locate_lowest_cycle', EJECT ??

  PROCEDURE [INLINE] locate_lowest_cycle (p_cycle_list: {input} pft$p_cycle_list;
    VAR p_lowest_cycle_entry: {output} pft$p_cycle);

    VAR
      cycle_index: pft$cycle_index,
      lowest_cycle_number: pft$cycle_number;

    p_lowest_cycle_entry := NIL;

    IF p_cycle_list <> NIL THEN
      lowest_cycle_number := pfc$maximum_cycle_number;

      FOR cycle_index := 1 TO UPPERBOUND (p_cycle_list^) DO
        IF (p_cycle_list^ [cycle_index].cycle_entry.entry_type = pfc$normal_cycle_entry) AND (p_cycle_list^
              [cycle_index].cycle_entry.cycle_number <= lowest_cycle_number) THEN
          lowest_cycle_number := p_cycle_list^ [cycle_index].cycle_entry.cycle_number;
          p_lowest_cycle_entry := ^p_cycle_list^ [cycle_index];
        IFEND;
      FOREND;
    IFEND;
  PROCEND locate_lowest_cycle;

?? OLDTITLE, SKIP := 2 ??
MODEND pfm$catalog_access_methods;
*DECK DECK=PFM$CATALOG_ALARM_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE pfm$catalog_alarm_manager;

{ PURPUSE:
{   This module manages keeping track of what catalogs have been
{   marked as alarmed on a system wide basis.
{   A catalog may be marked as alarmed by another job,
{   and these routines provide a mechanism for determining current status
{   of a catalog.  These routines also maintain statistics on the
{   number and duration of catalog alarms.
{   This module does NOT decide what an alarmed
{   catalog is NOR does it decide when to no longer include a catalog
{   as alarmed.

?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
*copyc osp$clear_mainframe_sig_lock
*copyc osp$clear_signature_lock
*copyc osp$initialize_signature_lock
*copyc osp$set_signature_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc osp$test_signature_lock
*copyc osv$mainframe_pageable_heap
*copyc pfd$table_info
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pfk$keypoints
*copyc pmp$format_compact_time
*copyc pmp$get_compact_date_time
*copyc tmv$ptl_p
*copyc tmv$null_global_task_id
?? POP ??
?? TITLE := '*** MODULE DEFINITIONS ***', EJECT ??

  VAR
    pfv$catalog_alarm_table_lock: [XDCL] ost$signature_lock := [0],

    pfv$number_of_alarm_sets: [XDCL] ost$non_negative_integers := 0,
    { This variable is a counter of the number of alarms set
    { since the last recovery.

    pfv$p_catalog_alarm_table: [XDCL] ^pft$catalog_alarm_table := NIL,

    highest_valid_entry: 0 .. pfc$highest_alarm_table_index := 0;

?? EJECT ??
*copyc pfd$catalog_alarm_table

?? OLDTITLE ??
?? NEWTITLE := ' pfp$check_catalog_alarm', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$check_catalog_alarm
    (    global_file_name: ost$binary_unique_name;
     VAR catalog_alarm_set: boolean;
     VAR destroy_on_last_detach: boolean);

    VAR
      catalog_alarm_table_index: pft$catalog_alarm_table_index;

    set_catalog_alarm_table_lock;

    search_catalog_alarm_table (global_file_name, catalog_alarm_set, catalog_alarm_table_index);
    destroy_on_last_detach := FALSE;
    IF catalog_alarm_set THEN
      pfv$p_catalog_alarm_table^ [catalog_alarm_table_index].
            search_count := pfv$p_catalog_alarm_table^ [catalog_alarm_table_index].search_count + 1;
      destroy_on_last_detach := pfv$p_catalog_alarm_table^ [catalog_alarm_table_index].destroy_on_last_detach;
    IFEND;

    clear_catalog_alarm_table_lock;
  PROCEND pfp$check_catalog_alarm;

?? OLDTITLE ??
?? NEWTITLE := ' pfp$clear_catalog_alarm', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$clear_catalog_alarm
    (    global_file_name: ost$binary_unique_name);

    VAR
      catalog_alarm_table_index: pft$catalog_alarm_table_index,
      catalog_found: boolean;

    #KEYPOINT (osk$entry, 0, pfk$clear_catalog_alarm);
    set_catalog_alarm_table_lock;

    search_catalog_alarm_table (global_file_name, catalog_found, catalog_alarm_table_index);
    IF catalog_found THEN
      pfv$p_catalog_alarm_table^ [catalog_alarm_table_index].external_catalog_name := 'free';
      pfv$p_catalog_alarm_table^ [catalog_alarm_table_index].entry_type := pfc$catalog_alarm_entry_free;
      IF catalog_alarm_table_index = highest_valid_entry THEN

      /set_new_highest_valid_entry/
        FOR highest_valid_entry := (catalog_alarm_table_index - 1) DOWNTO 1 DO
          IF (pfv$p_catalog_alarm_table^ [highest_valid_entry].entry_type =
                pfc$catalog_alarm_entry_valid) THEN
            EXIT /set_new_highest_valid_entry/;
          IFEND;
        FOREND /set_new_highest_valid_entry/;

        IF (highest_valid_entry = 1) AND (pfv$p_catalog_alarm_table^ [highest_valid_entry].entry_type =
              pfc$catalog_alarm_entry_free) THEN
          highest_valid_entry := 0;
        IFEND;
      IFEND;
    IFEND;

    clear_catalog_alarm_table_lock;
    #KEYPOINT (osk$exit, 0, pfk$clear_catalog_alarm);
  PROCEND pfp$clear_catalog_alarm;

?? OLDTITLE ??
?? NEWTITLE := ' pfp$r1_get_catalog_alarm_table', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r1_get_catalog_alarm_table
    (VAR p_table_info: pft$p_table_info;
     VAR status: ost$status);

    VAR
      p_number_of_alarms: ^integer,
      p_record_id: ^pft$record_id,
      p_table: pft$p_catalog_alarm_table,
      p_table_lock: ^ost$signature_lock,
      p_table_name: ^pft$table_name,
      p_table_size: ^integer;

    status.normal := TRUE;
    NEXT p_table_name IN p_table_info;
    IF p_table_name = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'table name', status);
      RETURN;
    IFEND;
    p_table_name^ := 'CATALOG_ALARM_TABLE';

    NEXT p_record_id IN p_table_info;
    IF p_record_id = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
      RETURN;
    IFEND;
    p_record_id^ := 'TABLLOCK';

    NEXT p_table_lock IN p_table_info;
    IF p_table_lock = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'table lock', status);
      RETURN;
    IFEND;
    p_table_lock^ := pfv$catalog_alarm_table_lock;

    NEXT p_record_id IN p_table_info;
    IF p_record_id = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
      RETURN;
    IFEND;
    p_record_id^ := 'HIGHENTR';

    NEXT p_number_of_alarms IN p_table_info;
    IF p_number_of_alarms = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'high entry', status);
      RETURN;
    IFEND;
    p_number_of_alarms^ := highest_valid_entry;

    NEXT p_record_id IN p_table_info;
    IF p_record_id = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
      RETURN;
    IFEND;
    p_record_id^ := 'ALARMSET';

    NEXT p_number_of_alarms IN p_table_info;
    IF p_number_of_alarms = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'alarms set', status);
      RETURN;
    IFEND;
    p_number_of_alarms^ := pfv$number_of_alarm_sets;

    NEXT p_record_id IN p_table_info;
    IF p_record_id = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
      RETURN;
    IFEND;
    p_record_id^ := 'TABLSIZE';

    NEXT p_table_size IN p_table_info;
    IF p_table_size = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'table size', status);
      RETURN;
    IFEND;
    IF pfv$p_catalog_alarm_table = NIL THEN
      p_table_size^ := 0;
    ELSE
      p_table_size^ := UPPERBOUND (pfv$p_catalog_alarm_table^);

      NEXT p_record_id IN p_table_info;
      IF p_record_id = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
        RETURN;
      IFEND;
      p_record_id^ := 'ALARMTBL';

      NEXT p_table: [1 .. p_table_size^] IN p_table_info;
      IF p_table = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'table', status);
        RETURN;
      IFEND;
      p_table^ := pfv$p_catalog_alarm_table^;
    IFEND;
  PROCEND pfp$r1_get_catalog_alarm_table;

?? OLDTITLE ??
?? NEWTITLE := ' pfp$set_catalog_alarm', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$set_catalog_alarm
    (    global_file_name: ost$binary_unique_name;
         internal_catalog_name: pft$internal_catalog_name;
         external_catalog_name: pft$name;
         destroy_on_last_detach: boolean);

    VAR
      alarm_table_index: pft$catalog_alarm_table_index,
      catalog_already_alarmed: boolean,
      ignored_status: ost$status,
      time: ost$time;

    #KEYPOINT (osk$entry, 0, pfk$set_catalog_alarm);
    set_catalog_alarm_table_lock;

    pfv$number_of_alarm_sets := pfv$number_of_alarm_sets + 1;

    search_catalog_alarm_table (global_file_name, catalog_already_alarmed, alarm_table_index);
    IF catalog_already_alarmed THEN
      pfv$p_catalog_alarm_table^ [alarm_table_index].alarm_count :=
            pfv$p_catalog_alarm_table^ [alarm_table_index].alarm_count + 1;
      pfv$p_catalog_alarm_table^ [alarm_table_index].destroy_on_last_detach :=
            pfv$p_catalog_alarm_table^ [alarm_table_index].destroy_on_last_detach OR destroy_on_last_detach;
    ELSE
      get_free_alarm_table_entry (alarm_table_index);
      pfv$p_catalog_alarm_table^ [alarm_table_index].entry_type := pfc$catalog_alarm_entry_valid;
      pfv$p_catalog_alarm_table^ [alarm_table_index].internal_catalog_name := internal_catalog_name;
      pfv$p_catalog_alarm_table^ [alarm_table_index].global_file_name := global_file_name;
      pfv$p_catalog_alarm_table^ [alarm_table_index].destroy_on_last_detach := destroy_on_last_detach;

      pmp$get_compact_date_time (pfv$p_catalog_alarm_table^ [alarm_table_index].time_of_alarm_setting,
            ignored_status);
      IF ignored_status.normal THEN
        pmp$format_compact_time (pfv$p_catalog_alarm_table^ [alarm_table_index].time_of_alarm_setting,
              osc$hms_time, time, ignored_status);
        pfv$p_catalog_alarm_table^ [alarm_table_index].displayable_time := time.hms;
      IFEND;
      pfv$p_catalog_alarm_table^ [alarm_table_index].external_catalog_name := external_catalog_name;
      pfv$p_catalog_alarm_table^ [alarm_table_index].alarm_count := 1;
      pfv$p_catalog_alarm_table^ [alarm_table_index].search_count := 0;

      IF alarm_table_index > highest_valid_entry THEN
        highest_valid_entry := alarm_table_index;
      IFEND;
    IFEND;

    clear_catalog_alarm_table_lock;
    #KEYPOINT (osk$exit, osk$m * alarm_table_index, pfk$set_catalog_alarm);
  PROCEND pfp$set_catalog_alarm;

?? OLDTITLE ??
?? NEWTITLE := ' clear_catalog_alarm_table_lock', EJECT ??

  PROCEDURE [INLINE] clear_catalog_alarm_table_lock;

    osp$clear_mainframe_sig_lock (pfv$catalog_alarm_table_lock);
  PROCEND clear_catalog_alarm_table_lock;

?? OLDTITLE ??
?? NEWTITLE := ' get_free_alarm_table_entry', EJECT ??

  PROCEDURE get_free_alarm_table_entry
    (VAR catalog_alarm_table_index: pft$catalog_alarm_table_index);

{  PURPOSE:
{    The purpose of this procedure is
{    to get a free entry in the catalog alarm table; this includes initially
{    creating the table, expanding the table if necessary, and
{    searching for an free entry.
{    The only possible error condition is if the mainframe pageable heap
{    is full, and the table can not be expanded.


    CONST
      pfc$expand_alarm_table_amount = 8,
      pfc$initial_alarm_table_size = 8;

    VAR
      p_new_catalog_alarm_table: pft$p_catalog_alarm_table,
      p_old_catalog_alarm_table: pft$p_catalog_alarm_table,
      space_found: boolean,
      status: ost$status;

?? OLDTITLE ??
?? NEWTITLE := ' find_free_alarm_table_entry', EJECT ??

    PROCEDURE find_free_alarm_table_entry
      (    p_catalog_alarm_table: pft$p_catalog_alarm_table;
       VAR catalog_alarm_table_index: pft$catalog_alarm_table_index;
       VAR free_found: boolean);

{  PURPOSE:
{    This procedure searches the catalog alarm table looking for a free
{    table entry.  The free index number is returned.

      free_found := FALSE;
      IF p_catalog_alarm_table <> NIL THEN

      /search_for_free/
        FOR catalog_alarm_table_index := 1 TO UPPERBOUND (p_catalog_alarm_table^) DO
          IF p_catalog_alarm_table^ [catalog_alarm_table_index].entry_type =
                pfc$catalog_alarm_entry_free THEN
            free_found := TRUE;
            EXIT /search_for_free/;
          IFEND;
        FOREND /search_for_free/;
      IFEND;
    PROCEND find_free_alarm_table_entry;

?? OLDTITLE ??
?? NEWTITLE := ' initialize_alarm_table', EJECT ??

    PROCEDURE initialize_alarm_table
      (    p_catalog_alarm_table: pft$p_catalog_alarm_table);

{  PURPOSE:
{    This procedure initializes a catalog alarm  table to indicate that
{    all entries are free.

      VAR
        catalog_alarm_table_index: pft$catalog_alarm_table_index;

      IF p_catalog_alarm_table <> NIL THEN
        FOR catalog_alarm_table_index := LOWERBOUND (p_catalog_alarm_table^)
              TO UPPERBOUND (p_catalog_alarm_table^) DO
          p_catalog_alarm_table^ [catalog_alarm_table_index].external_catalog_name := 'free';
          p_catalog_alarm_table^ [catalog_alarm_table_index].entry_type := pfc$catalog_alarm_entry_free;
        FOREND;
      IFEND;
    PROCEND initialize_alarm_table;

?? OLDTITLE ??
?? NEWTITLE := ' transfer_old_to_new_alarm_table', EJECT ??

    PROCEDURE transfer_old_to_new_alarm_table
      (    p_old_catalog_alarm_table: pft$p_catalog_alarm_table;
           p_new_catalog_alarm_table: pft$p_catalog_alarm_table);

{  PURPOSE:
{    This procedure transfers an old catalog alarm table to a new one.  The
{    new table must be equal to or larger than the old table.  If the new table
{    is larger, additional entries are initialized to indicate they are free.

      VAR
        catalog_alarm_table_index: pft$catalog_alarm_table_index;

    /copy_existing_entries/
      FOR catalog_alarm_table_index := LOWERBOUND (p_old_catalog_alarm_table^)
            TO UPPERBOUND (p_old_catalog_alarm_table^) DO
        p_new_catalog_alarm_table^ [catalog_alarm_table_index] :=
              p_old_catalog_alarm_table^ [catalog_alarm_table_index];
      FOREND /copy_existing_entries/;

    /initialize_new_entries/
      FOR catalog_alarm_table_index := (UPPERBOUND (p_old_catalog_alarm_table^) + 1)
            TO UPPERBOUND (p_new_catalog_alarm_table^) DO
        p_new_catalog_alarm_table^ [catalog_alarm_table_index].external_catalog_name := 'free';
        p_new_catalog_alarm_table^ [catalog_alarm_table_index].entry_type := pfc$catalog_alarm_entry_free;
      FOREND /initialize_new_entries/;
    PROCEND transfer_old_to_new_alarm_table;
?? OLDTITLE ??
?? EJECT ??

    space_found := FALSE;
    IF pfv$p_catalog_alarm_table = NIL THEN
      ALLOCATE pfv$p_catalog_alarm_table: [1 .. pfc$initial_alarm_table_size] IN
            osv$mainframe_pageable_heap^;
      IF pfv$p_catalog_alarm_table = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'full mainframe pageable', status);
        osp$system_error (' PF - FULL MAINFRAME HEAP', ^status);
      ELSE
        initialize_alarm_table (pfv$p_catalog_alarm_table);
        find_free_alarm_table_entry (pfv$p_catalog_alarm_table, catalog_alarm_table_index, space_found);
      IFEND;
    ELSE
      find_free_alarm_table_entry (pfv$p_catalog_alarm_table, catalog_alarm_table_index, space_found);
      IF NOT space_found THEN {expand the old table }
        ALLOCATE p_new_catalog_alarm_table: [1 .. (UPPERBOUND (pfv$p_catalog_alarm_table^) +
              pfc$expand_alarm_table_amount)] IN osv$mainframe_pageable_heap^;
        IF p_new_catalog_alarm_table = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                'full mainframe pageable', status);
          osp$system_error (' PF - FULL MAINFRAME HEAP', ^status);
        ELSE
          transfer_old_to_new_alarm_table (pfv$p_catalog_alarm_table, p_new_catalog_alarm_table);
          p_old_catalog_alarm_table := pfv$p_catalog_alarm_table;
          pfv$p_catalog_alarm_table := p_new_catalog_alarm_table;
          FREE p_old_catalog_alarm_table IN osv$mainframe_pageable_heap^;
          find_free_alarm_table_entry (pfv$p_catalog_alarm_table, catalog_alarm_table_index, space_found);
        IFEND;
      IFEND;
    IFEND;
  PROCEND get_free_alarm_table_entry;

?? OLDTITLE ??
?? NEWTITLE := ' search_catalog_alarm_table', EJECT ??

  PROCEDURE [INLINE] search_catalog_alarm_table
    (    global_file_name: ost$binary_unique_name;
     VAR catalog_found: boolean;
     VAR catalog_alarm_table_index: pft$catalog_alarm_table_index);

    catalog_found := FALSE;
    IF pfv$p_catalog_alarm_table = NIL THEN
      RETURN;
    IFEND;

  /search_for_catalog/
    FOR catalog_alarm_table_index := 1 TO highest_valid_entry DO
      IF pfv$p_catalog_alarm_table^[catalog_alarm_table_index].entry_type = pfc$catalog_alarm_entry_valid THEN
        IF pfv$p_catalog_alarm_table^ [catalog_alarm_table_index].global_file_name = global_file_name THEN
          catalog_found := TRUE;
          RETURN;
        IFEND;
      IFEND;
    FOREND /search_for_catalog/;

  PROCEND search_catalog_alarm_table;

?? OLDTITLE ??
?? NEWTITLE := ' set_catalog_alarm_table_lock', EJECT ??

  PROCEDURE [INLINE] set_catalog_alarm_table_lock;

    osp$set_mainframe_sig_lock (pfv$catalog_alarm_table_lock);
  PROCEND set_catalog_alarm_table_lock;

MODEND pfm$catalog_alarm_manager;
*DECK DECK=PFM$CATALOG_MAINTENANCE_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Permanent Files : Catalog Maintenance' ??
MODULE pfm$catalog_maintenance_manager;

{ PURPOSE:
{   This module contains the procedures to perform pf recovery during a
{   continuation deadstart.

?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc fmt$mass_storage_request_info
*copyc fst$cycle_damage_symptoms
*copyc mme$condition_codes
*copyc osd$integer_limits
*copyc oss$job_paged_literal
*copyc ost$prevalidate_free_result
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pfk$keypoints
*copyc pft$overhaul_choices
*copyc ste$error_condition_codes
?? POP ??
?? EJECT ??
*copyc dmp$allocate_file_space_r1
*copyc dmp$attach_file
*copyc dmp$build_sorted_dfl
*copyc dmp$destroy_permanent_file
*copyc dmp$dev_mgmt_table_update
*copyc dmp$device_file_list_update
*copyc dmp$get_reconciled_fmd
*copyc dmp$get_stored_fmd
*copyc dmp$get_stored_fmd_size
*copyc dmp$reconcile_fmd
*copyc dmv$reconcile_locator
*copyc dpp$get_next_line
*copyc dpp$put_next_line
*copyc dpv$system_core_display
*copyc i#move
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc mmp$get_segment_length
*copyc mmp$set_segment_length
*copyc mmp$write_modified_pages
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$prevalidate_free
*copyc osp$reset_heap
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$verify_heap
*copyc osv$lower_to_upper
*copyc osv$system_family_name
*copyc pfp$access_next_catalog
*copyc pfp$access_object
*copyc pfp$attach_catalog
*copyc pfp$attach_root_catalog
*copyc pfp$build_amd_locator
*copyc pfp$build_amd_pointer
*copyc pfp$build_archive_list_locator
*copyc pfp$build_archive_list_pointer
*copyc pfp$build_cycle_list_locator
*copyc pfp$build_cycle_list_pointer
*copyc pfp$build_file_label_locator
*copyc pfp$build_file_label_pointer
*copyc pfp$build_fmd_locator
*copyc pfp$build_fmd_pointer
*copyc pfp$build_log_list_locator
*copyc pfp$build_log_list_pointer
*copyc pfp$build_mainfram_list_locator
*copyc pfp$build_mainfram_list_pointer
*copyc pfp$build_object_list_locator
*copyc pfp$build_object_list_pointer
*copyc pfp$build_permit_list_locator
*copyc pfp$build_permit_list_pointer
*copyc pfp$check_archive_entries
*copyc pfp$compute_checksum
*copyc pfp$convert_device_class_to_rm
*copyc pfp$convert_pf_path_to_fs_path
*copyc pfp$create_catalog
*copyc pfp$cycle_attached_for_write
*copyc pfp$destroy_catalog
*copyc pfp$detach_all_catalogs
*copyc pfp$detach_permanent_file
*copyc pfp$display_memory_to_log
*copyc pfp$get_authority
*copyc pfp$get_family_set
*copyc pfp$get_restore_status
*copyc pfp$log_ascii
*copyc pfp$log_error
*copyc pfp$process_unexpected_status
*copyc pfp$record_dm_file_parameters
*copyc pfp$report_invalid_free
*copyc pfp$report_unexpected_status
*copyc pfp$return_catalog
*copyc pfp$set_restore_status
*copyc pfp$set_status_abnormal
*copyc pfp$sort_object_list
*copyc pfp$system_path
*copyc pfp$update_obj_list_descriptor
*copyc pfp$update_object_list_locator
*copyc pfp$update_stale_cycle_entry
*copyc pfp$validate_ownership
*copyc pfp$validate_set_owner
*copyc pfv$sort_catalog_object_list
*copyc pfv$space_character
*copyc pmp$continue_to_cause
*copyc pmp$convert_binary_unique_name
*copyc pmp$delay
*copyc pmp$date_time_compare
*copyc pmp$format_compact_time
*copyc pmp$get_compact_date_time
*copyc pmp$get_date_time_at_timestamp
*copyc stp$clear_root_recreated
*copyc stp$get_pf_root
*copyc stp$get_pf_root_size
*copyc stp$get_volumes_in_set
*copyc stp$store_pf_root
*copyc syp$invoke_system_debugger
*copyc syp$process_deadstart_status
*copyc syv$nosve_internal_operations

?? TITLE := '  Global Declarations Declared by this module', EJECT ??

  CONST
    include_radix = TRUE,
    radix = 10;

  TYPE
    pft$catalog_or_cycle = record
      case cycle_specified: boolean of
      = FALSE =
        ,
      = TRUE =
        cycle_number: pft$cycle_number,
      casend,
    recend,

    pft$string = record
      size: integer,
      value: string (osc$max_string_size + fsc$max_path_size),
    recend;

  VAR
    pfv$catalogs_missing_media: [XDCL] ost$non_negative_integers := 0,
    pfv$catalogs_moved: [XDCL] ost$non_negative_integers := 0,
    pfv$catalogs_not_in_set: [XDCL] ost$non_negative_integers := 0,
    pfv$clear_catalog_recreated: [XDCL] boolean := FALSE,
    pfv$cycles_missing_media: [XDCL] ost$non_negative_integers := 0,
    pfv$cycles_not_in_set: [XDCL] ost$non_negative_integers := 0,
    pfv$immovable_catalogs: [XDCL] ost$non_negative_integers := 0,
    pfv$overhaul_catalog_options: [XDCL] pft$set_overhaul_choices := $pft$set_overhaul_choices[],
    pfv$overhaul_errors: [XDCL] ost$non_negative_integers := 0,
    pfv$overhaul_set_options: [XDCL] pft$set_overhaul_choices := $pft$set_overhaul_choices[],
    pfv$purged_catalogs_deleted: [XDCL] ost$non_negative_integers := 0,
    pfv$recreated_catalogs_cleared: [XDCL] ost$non_negative_integers := 0,
    pfv$reinstalled_device_cycles: [XDCL] ost$non_negative_integers := 0,
    pfv$unreconciled_catalogs: [XDCL] ost$non_negative_integers := 0,
    pfv$unreconciled_cats_deleted: [XDCL] ost$non_negative_integers := 0,
    pfv$unreconciled_cycle_data_del: [XDCL] ost$non_negative_integers := 0,
    pfv$unreconciled_cycle_released: [XDCL] ost$non_negative_integers := 0,
    pfv$unreconciled_cycle_retained: [XDCL] ost$non_negative_integers := 0,
    pfv$unreconciled_cycles_deleted: [XDCL] ost$non_negative_integers := 0,
    pfv$unreconciled_files: [XDCL] ost$non_negative_integers := 0,
    pfv$unreorganized_catalogs: [XDCL] ost$non_negative_integers := 0;

  VAR
    ascii_logset: pmt$ascii_logset,
    catalog_moved: boolean := FALSE,
    critical_message: boolean := FALSE,
    message_origin: pmt$log_msg_origin := pmc$msg_origin_system,
    out_of_space: boolean := FALSE,
    previous_master_catalog: pft$name := osc$null_name,
    previous_timestamp: integer;

?? TITLE := '  [XDCL, #GATE] pfp$r2_overhaul_catalog', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_overhaul_catalog
    (    path: pft$complete_path;
         catalog_overhaul_choices: pft$catalog_overhaul_choices;
     VAR status: ost$status);

    CONST
      block_exit = TRUE,
      catalog_remote = TRUE,
      system_privilege = TRUE,
      validation_ring = 2;

    VAR
      authority: pft$authority,
      catalog_overhaul_option: pft$catalog_overhaul_options,
      catalog_segment_length: ost$segment_length,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      moved_or_destroyed_child: boolean,
      new_catalog_locator: pft$catalog_locator,
      old_catalog_accessed: boolean,
      old_catalog_locator: pft$catalog_locator,
      p_fs_path: ^fst$path,
      p_internal_path: ^pft$internal_path,
      p_physical_catalog_object: ^pft$physical_object,
      p_physical_fmd: ^pft$physical_fmd,
      parent_accessed: boolean,
      parent_catalog_locator: pft$catalog_locator,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      scratch_segment_pointer: amt$segment_pointer,
      set_overhaul_choices: pft$set_overhaul_choices,
      text: pft$string,
      variant_path: pft$variant_path;


    PROCEDURE condition_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      IF (condition.selector = pmc$system_conditions) OR
            (condition.selector = mmc$segment_access_condition) THEN
        osp$set_status_from_condition (pfc$permanent_file_manager_id, condition, p_sfsa, status,
              local_status);
        IF local_status.normal THEN
          pfp$log_error (status, ascii_logset, message_origin, critical_message);
        ELSE
          pfp$log_error (local_status, ascii_logset, message_origin, critical_message);
          status := local_status;
        IFEND;

        pfv$overhaul_errors := pfv$overhaul_errors + 1;
        osp$set_status_condition (pfe$recovery_summary, status);
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$overhaul_errors, radix,
              NOT include_radix, status);
        IF pfv$overhaul_errors = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'error', status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter, 'errors', status);
        IFEND;
        {
        { Return accessed catalogs.
        {
        IF old_catalog_accessed THEN
          pfp$return_catalog (old_catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
        IFEND;

        IF parent_accessed THEN
          pfp$return_catalog (parent_catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
        IFEND;

        EXIT pfp$r2_overhaul_catalog;
      ELSE
        {
        { Ignore the condition.
        {
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND condition_handler;


    parent_accessed := FALSE;
    old_catalog_accessed := FALSE;
    ascii_logset := $pmt$ascii_logset [pmc$job_log];

    #SPOIL (parent_accessed, old_catalog_accessed);
    osp$establish_condition_handler (^condition_handler, NOT block_exit);

    pfp$get_authority (path, NOT system_privilege, authority, status);

    IF status.normal THEN
      pfp$validate_ownership (authority, path, status);
    IFEND;

    IF status.normal THEN
      set_overhaul_choices := $pft$set_overhaul_choices [];
      FOR catalog_overhaul_option := LOWERVALUE (catalog_overhaul_option)
            TO UPPERVALUE (catalog_overhaul_option) DO
        IF catalog_overhaul_option IN catalog_overhaul_choices THEN
          set_overhaul_choices := set_overhaul_choices + $pft$set_overhaul_choices [catalog_overhaul_option];
        IFEND;
      FOREND;
      validate_overhaul_choices (set_overhaul_choices, authority.ownership, set_overhaul_choices, status);
    IFEND;

    IF status.normal THEN
      pfv$overhaul_catalog_options := set_overhaul_choices;
      pfp$log_ascii (' *  overhaul catalog options: ', ascii_logset, message_origin, critical_message,
             local_status);
      log_overhaul_options (set_overhaul_choices, local_status);
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$read_access, authority, $pft$object_selections [pfc$catalog_object],
            parent_charge_id, parent_catalog_locator, p_physical_catalog_object, p_internal_path^,
            permit_entry, status);
    IFEND;

    IF status.normal THEN
      #SPOIL (parent_catalog_locator);
      parent_accessed := TRUE;
      #SPOIL (parent_accessed);

      IF pfc$reconcile_fmds IN set_overhaul_choices THEN
        pfp$access_next_catalog (pfc$write_access, parent_catalog_locator, p_physical_catalog_object,
              NOT catalog_remote, old_catalog_locator, status);
      ELSE
        pfp$access_next_catalog (pfc$read_access, parent_catalog_locator, p_physical_catalog_object,
              NOT catalog_remote, old_catalog_locator, status);
      IFEND;

      IF status.normal THEN
        old_catalog_accessed := TRUE;
        #SPOIL (old_catalog_accessed);
        previous_timestamp := #free_running_clock (0);

        overhaul_physical_catalog (set_overhaul_choices, path, dmv$reconcile_locator, authority,
              old_catalog_locator, new_catalog_locator, moved_or_destroyed_child, status);
        scratch_segment_pointer.kind := amc$cell_pointer;
        scratch_segment_pointer.cell_pointer := new_catalog_locator.p_catalog_file;

        IF status.normal OR (status.condition = pfe$recovery_summary) THEN
          IF NOT status.normal THEN
            osp$append_status_integer (osc$status_parameter_delimiter, pfv$overhaul_errors, radix,
                  NOT include_radix, status);
            IF pfv$overhaul_errors = 1 THEN
              osp$append_status_parameter (osc$status_parameter_delimiter, 'error', status);
            ELSE
              osp$append_status_parameter (osc$status_parameter_delimiter, 'errors', status);
            IFEND;
            pfp$log_error (status, ascii_logset, message_origin, critical_message);
          IFEND;

          pfp$return_catalog (old_catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
          old_catalog_accessed := FALSE;
          #SPOIL (old_catalog_accessed);
        ELSE
          {
          { The catalog could not be successfully overhauled because of a
          { system error, because permanent storage was unavailable, or
          { because of a system or segment access condition. The old catalog
          { will continue to be used and the new catalog will be destroyed.
          {
          IF status.condition = pfe$pf_system_error THEN
            PUSH p_fs_path;
            pfp$convert_pf_path_to_fs_path ( path, p_fs_path^, fs_path_size);
            STRINGREP (text.value, text.size, ' System error while overhauling catalog ',
                  p_fs_path^(1, fs_path_size));
            pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message,
                  local_status);
          IFEND;
          IF (pfc$reorganize_catalogs IN set_overhaul_choices) AND
            (scratch_segment_pointer.cell_pointer <> NIL) THEN
             mmp$delete_scratch_segment (scratch_segment_pointer, local_status);
             pfp$process_unexpected_status (local_status);
          IFEND;
          pfp$log_error (status, ascii_logset, message_origin, critical_message);
          pfp$return_catalog (old_catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
          #SPOIL (old_catalog_accessed);
          old_catalog_accessed := FALSE;
          #SPOIL (old_catalog_accessed);
          variant_path.complete_path := TRUE;
          variant_path.p_complete_path := ^path;
          pfp$set_status_abnormal (variant_path, pfe$overhaul_catalog_failed, status);
          pfp$log_error (status, ascii_logset, message_origin, critical_message);
        IFEND;
      IFEND;

      pfp$return_catalog (parent_catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_overhaul_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$r2_overhaul_set', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_overhaul_set
    (    set_name: stt$set_name;
         set_overhaul_choices: pft$set_overhaul_choices;
     VAR status: ost$status);

    CONST
      block_exit = TRUE,
      fatal_status = TRUE,
      purge_catalog = TRUE,
      system_privilege = TRUE,
      validation_ring = 2;

    VAR
      authority: pft$authority,
      catalog_segment_length: ost$segment_length,
      found: boolean,
      fs_path_size: fst$path_size,
      getsl_wrimc_status: ost$status,
      local_status: ost$status,
      mass_storage_classes: dmt$class,
      moved_or_destroyed_child: boolean,
      new_catalog_locator: pft$catalog_locator,
      new_set_overhaul_choices: pft$set_overhaul_choices,
      old_catalog_locator: pft$catalog_locator,
      p_fs_path: ^fst$path,
      p_new_physical_fmd: ^pft$physical_fmd,
      p_root_fmd: ^pft$fmd,
      path: array [1 .. pfc$set_path_index] of pft$name,
      resides_on_system_device: boolean,
      root_size: pft$root_size,
      scratch_segment_pointer: amt$segment_pointer,
      space_index: 1 .. osc$max_name_size + 1,
      text: pft$string;



    PROCEDURE condition_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      IF (condition.selector = pmc$system_conditions) OR
            (condition.selector = mmc$segment_access_condition) THEN
        osp$set_status_from_condition (pfc$permanent_file_manager_id, condition, p_sfsa, status,
              local_status);
        IF local_status.normal THEN
          pfp$log_error (status, ascii_logset, message_origin, critical_message);
        ELSE
          pfp$log_error (local_status, ascii_logset, message_origin, critical_message);
          status := local_status;
        IFEND;

        EXIT pfp$r2_overhaul_set;
      ELSE
        {
        { Ignore the condition.
        {
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND condition_handler;

    ascii_logset := - $pmt$ascii_logset [];

    path [pfc$set_path_index] := set_name;
    pfp$get_authority (path, NOT system_privilege, authority, status);

    IF status.normal THEN
      pfp$validate_set_owner (set_name, authority, status);
    IFEND;

    IF status.normal THEN
      validate_overhaul_choices (set_overhaul_choices, authority.ownership, new_set_overhaul_choices, status);
    IFEND;

    IF status.normal THEN
      pfv$overhaul_set_options := new_set_overhaul_choices;
      pfp$log_ascii (' *  overhaul set options: ', ascii_logset, message_origin, {critical_message} FALSE,
             local_status);
      log_overhaul_options (new_set_overhaul_choices, local_status);
      stp$get_pf_root_size (set_name, root_size, status);
      IF NOT status.normal THEN
        IF status.condition = ste$pf_root_not_stored THEN
          create_root_catalog (set_name, authority, status);
        ELSE
          pfp$report_unexpected_status (status);
        IFEND;
      ELSE
        pfp$get_restore_status (pfv$clear_catalog_recreated);
        IF pfc$reconcile_fmds IN new_set_overhaul_choices THEN
          attach_reconciled_root_catalog (set_name, NOT purge_catalog, pfc$write_access, p_root_fmd,
                resides_on_system_device, mass_storage_classes, old_catalog_locator, status);
        ELSE
          pfp$attach_root_catalog (set_name, pfc$read_access, old_catalog_locator, status);
        IFEND;

        IF status.normal THEN
          IF pfc$reconcile_fmds IN new_set_overhaul_choices THEN
            message_origin := pmc$msg_origin_recovery;
            critical_message := TRUE;

            IF NOT (pfc$reorganize_catalogs IN new_set_overhaul_choices) THEN
              osp$establish_condition_handler (^condition_handler, NOT block_exit);
              osp$verify_heap (^old_catalog_locator.p_catalog_file^.catalog_heap, status.normal);
              osp$disestablish_cond_handler;
            IFEND;
          IFEND;

          IF status.normal THEN
            previous_timestamp := #free_running_clock (0);
            IF pfv$clear_catalog_recreated THEN
              stp$clear_root_recreated (set_name, local_status);
              pfp$process_unexpected_status (local_status);
            IFEND;
            overhaul_physical_catalog (new_set_overhaul_choices, path, dmv$reconcile_locator,
                  authority, old_catalog_locator, new_catalog_locator, moved_or_destroyed_child, status);
          ELSE
            #SCAN (pfv$space_character, set_name, space_index, found);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_catalog_heap,
                  set_name (1, space_index - 1), status);
            pfp$log_ascii ('* * * * * * * * * * * * * * * * * * * * *', ascii_logset, message_origin,
                  {critical_message} FALSE, local_status);
            pfp$log_ascii ('* The heap for the set is damaged.', ascii_logset, message_origin,
                  critical_message, local_status);
            pfp$log_ascii ('* REDEADSTART using System Core Command:', ascii_logset, message_origin,
                  critical_message, local_status);
            pfp$log_ascii ('* SETSA REORGANIZE_PERMANENT_FILES 1', ascii_logset, message_origin,
                  critical_message, local_status);
            pfp$log_ascii ('* * * * * * * * * * * * * * * * * * * * *', ascii_logset, message_origin,
                  {critical_message} FALSE, local_status);
          IFEND;

          IF status.normal OR (status.condition = pfe$recovery_summary) THEN
            pfp$set_restore_status ({restore_missing_catalogs_done} FALSE, local_status);
            pfp$process_unexpected_status (local_status);

            IF pfc$reconcile_fmds IN new_set_overhaul_choices THEN
              IF pfc$reorganize_catalogs IN new_set_overhaul_choices THEN
                mmp$get_segment_length (new_catalog_locator.p_catalog_file, validation_ring,
                      catalog_segment_length, getsl_wrimc_status);
                IF getsl_wrimc_status.normal THEN
                  {
                  { The root/set catalog can never grow as a result of
                  { reconciliation, because it contains no files.  Thus
                  { preallocation is unnecessary.
                  {
                  { Rewrite the "old" catalog with the reorganized, scratch
                  { catalog.
                  {
                  mmp$set_segment_length (old_catalog_locator.p_catalog_file, validation_ring,
                         {segment_length} 0, local_status);
                  IF NOT local_status.normal THEN
                    pfp$process_unexpected_status (local_status);
                  IFEND;
                  i#move (new_catalog_locator.p_catalog_file, old_catalog_locator.p_catalog_file,
                        catalog_segment_length);
                IFEND;
              ELSE
                mmp$get_segment_length (old_catalog_locator.p_catalog_file, validation_ring,
                      catalog_segment_length, getsl_wrimc_status);
              IFEND;

              IF getsl_wrimc_status.normal THEN
                {
                { Force the "new" catalog to be written to disk now.
                {
                write_modified_catalog (set_overhaul_choices, path, resides_on_system_device,
                      mass_storage_classes, catalog_segment_length, dmv$reconcile_locator,
                      p_root_fmd, authority, {p_parent_catalog_file} NIL, {p_catalog_object} NIL,
                      p_new_physical_fmd, old_catalog_locator, catalog_moved, getsl_wrimc_status);
                IF NOT getsl_wrimc_status.normal THEN
                  pfp$log_ascii (('Unable to flush the root catalog to disk.  An initialization deadstart' CAT
                        ' followed by a full reload of the permanent file base must be performed.'),
                        ascii_logset, message_origin, critical_message, local_status);
                IFEND;
              ELSEIF moved_or_destroyed_child THEN
                pfp$log_error (getsl_wrimc_status, ascii_logset, message_origin, {critical_message} FALSE);
                pfp$log_ascii ('Previous error from mmp$get_segment_length.', ascii_logset, message_origin,
                      {critical_message} FALSE, local_status);
                pfp$log_ascii (('Unable to flush the root catalog to disk.  An initialization deadstart' CAT
                      ' followed by a full reload of the permanent file base must be performed.'),
                      ascii_logset, message_origin, critical_message, local_status);
              ELSEIF pfc$reorganize_catalogs IN new_set_overhaul_choices THEN
                pfp$log_error (local_status, ascii_logset, message_origin, {critical_message} FALSE);
                pfp$log_ascii ('Previous error from mmp$get_segment_length.', ascii_logset, message_origin,
                      {critical_message} FALSE, local_status);
                pfp$log_ascii ('Unable to reorganize the root catalog.', ascii_logset, message_origin,
                      {critical_message} FALSE, local_status);
                pfv$unreorganized_catalogs := pfv$unreorganized_catalogs + 1;
                getsl_wrimc_status.normal := TRUE;
              ELSE
                pfp$log_error (local_status, ascii_logset, message_origin, {critical_message} FALSE);
                pfp$log_ascii ('Previous error from mmp$get_segment_length.', ascii_logset, message_origin,
                      {critical_message} FALSE, local_status);
                pfp$log_ascii ('Reverting to unmodified root catalog.', ascii_logset, message_origin,
                      {critical_message} FALSE, local_status);
                getsl_wrimc_status.normal := TRUE;
              IFEND;

              IF pfc$reorganize_catalogs IN new_set_overhaul_choices THEN
                scratch_segment_pointer.kind := amc$cell_pointer;
                scratch_segment_pointer.cell_pointer := new_catalog_locator.p_catalog_file;
                mmp$delete_scratch_segment (scratch_segment_pointer, local_status);
                pfp$process_unexpected_status (local_status);
              IFEND;

              IF pfc$delete_unreconciled_objects IN new_set_overhaul_choices THEN
                dmp$device_file_list_update (set_name, local_status);
                pfp$process_unexpected_status (local_status);
              IFEND;
              {
              { Rebuild the sorted dfl so it contains the correct entries for
              { the catalogs that have moved as a result of reorganization.
              {
              IF catalog_moved THEN
                dmp$build_sorted_dfl (set_name, dmv$reconcile_locator, local_status);
                pfp$process_unexpected_status (local_status);
              IFEND;

              log_recovery_summary_status (status);
              IF NOT getsl_wrimc_status.normal THEN
                status := getsl_wrimc_status;
              IFEND;
            ELSE
              log_recovery_summary_status (status);
            IFEND;

          ELSEIF status.condition = pfe$bad_root_catalog_header THEN
            {
            { Force the deadstart to hang so the root catalog will still be in
            { memory, in case a dump is taken.
            {
            syp$process_deadstart_status (('The root catalog is damaged.  An initialization deadstart' CAT
                  ' followed by a full reload of the permanent file base must be performed.'), fatal_status,
                  status);
          IFEND;

          IF status.condition = pfe$pf_system_error THEN
            STRINGREP (text.value, text.size, ' System error while overhauling set ', set_name);
            pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin,
                  {critical_message} FALSE, local_status);
          IFEND;
          pfp$return_catalog (old_catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
          pfp$detach_all_catalogs;

          IF pfc$reconcile_fmds IN new_set_overhaul_choices THEN
            message_origin := pmc$msg_origin_system;
            critical_message := FALSE;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pfp$r2_overhaul_set;

?? TITLE := '  attach_reconciled_root_catalog', EJECT ??

  PROCEDURE attach_reconciled_root_catalog
    (    set_name: stt$set_name;
         purge_catalog: boolean;
         access_kind: pft$access_kind;
     VAR p_fmd: ^pft$fmd;
     VAR resides_on_system_device: boolean;
     VAR mass_storage_classes: dmt$class;
     VAR catalog_locator: pft$catalog_locator;
     VAR status: ost$status);

    CONST
      best_root_size_estimate = 0ff(16),
      catalog_remote = TRUE;

    VAR
      p_internal_catalog_name: ^pft$internal_catalog_name,
      p_root_container: ^pft$root,
      p_stored_fmd_size: ^dmt$stored_fmd_size,
      root_size: pft$root_size;

    root_size := best_root_size_estimate;

    REPEAT
      PUSH p_root_container: [[REP root_size OF cell]];
      RESET p_root_container;
      stp$get_pf_root (set_name, root_size, p_root_container^, status);
    UNTIL status.normal OR (status.condition <> ste$incorrect_root_size);

    IF status.normal THEN
      RESET p_root_container;
      NEXT p_internal_catalog_name IN p_root_container;
      NEXT p_stored_fmd_size IN p_root_container;
      NEXT p_fmd: [[REP p_stored_fmd_size^ OF cell]] IN p_root_container;
      dmp$reconcile_fmd (dmv$reconcile_locator, p_internal_catalog_name^, p_fmd^, purge_catalog,
            mass_storage_classes, p_stored_fmd_size^, resides_on_system_device, status);
      IF status.normal THEN
        pfp$attach_catalog (p_fmd, set_name, p_internal_catalog_name^, p_internal_catalog_name^,
              access_kind, NOT catalog_remote, catalog_locator, status);
      IFEND;
    ELSE
      pfp$report_unexpected_status (status);
    IFEND;
  PROCEND attach_reconciled_root_catalog;

?? TITLE := '  create_root_catalog', EJECT ??

  PROCEDURE create_root_catalog
    (    set_name: stt$set_name;
         authority: pft$authority;
     VAR status: ost$status);

    VAR
      catalog_locator: pft$catalog_locator,
      local_status: ost$status,
      p_internal_catalog_name: ^pft$internal_catalog_name,
      p_root: ^pft$root,
      p_stored_fmd: ^dmt$stored_fmd,
      p_stored_fmd_size: ^dmt$stored_fmd_size,
      set_path: array [1 .. 1] of pft$name,
      stored_fmd_size: dmt$stored_fmd_size;

    set_path[1] := set_name;
    pfp$create_catalog (set_path, {p_mass_storage_request_info} NIL, authority, {lock_catalog} FALSE,
          catalog_locator, status);

    IF status.normal THEN
      {
      { The design assumes that the file media descriptor does not change for
      { the catalog while the system is up.
      {
      dmp$get_stored_fmd_size (catalog_locator.system_file_id, stored_fmd_size, status);
      IF status.normal THEN
        PUSH p_root: [[REP 1 OF pft$internal_catalog_name, REP 1 OF dmt$stored_fmd_size,
              REP stored_fmd_size OF cell]];
        RESET p_root;
        NEXT p_internal_catalog_name IN p_root;
        p_internal_catalog_name^ := catalog_locator.global_file_name;
        NEXT p_stored_fmd_size IN p_root;
        p_stored_fmd_size^ := stored_fmd_size;
        NEXT p_stored_fmd: [[REP stored_fmd_size OF cell]] IN p_root;
        dmp$get_stored_fmd (catalog_locator.system_file_id, p_stored_fmd^, status);
        IF status.normal THEN
          stp$store_pf_root (set_name, p_root^, status);
          IF status.normal THEN
            pfp$return_catalog (catalog_locator, status);
          ELSE
            pfp$destroy_catalog (catalog_locator, local_status);
            pfp$process_unexpected_status (local_status);
          IFEND;
        ELSE
          pfp$report_unexpected_status (status);
        IFEND;
      ELSE
        pfp$report_unexpected_status (status);
      IFEND;
    ELSE
      pfp$report_unexpected_status (status);
    IFEND;
  PROCEND create_root_catalog;

?? TITLE := '  delete_catalog_object', EJECT ??

  PROCEDURE delete_catalog_object
    (    p_path: ^pft$complete_path;
         p_catalog_object: {i^/o^} ^pft$physical_object;
     VAR new_parent_catalog_locator: {i/o} pft$catalog_locator;
     VAR p_permit_list: {i/o} ^pft$permit_list);

    VAR
      prevalidate_free_result: ost$prevalidate_free_result;

    pfp$update_obj_list_descriptor (p_catalog_object, new_parent_catalog_locator.object_list_descriptor);
    p_catalog_object^.object_entry.object_type := pfc$free_object;
    pfp$compute_checksum (#LOC (p_catalog_object^.object_entry), #SIZE (pft$object_entry),
          p_catalog_object^.checksum);
    IF p_permit_list <> NIL THEN
      osp$prevalidate_free ((#OFFSET(p_permit_list) -
            #OFFSET(^new_parent_catalog_locator.p_catalog_file^.catalog_heap) - 16),
            ^new_parent_catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
      IF prevalidate_free_result = osc$heap_free_valid THEN
        FREE p_permit_list IN new_parent_catalog_locator.p_catalog_file^.catalog_heap;
      ELSE
        pfp$report_invalid_free (p_path, {p_cycle_number} NIL, 'PERMIT_LIST', 'catalog',
              prevalidate_free_result, #OFFSET(p_permit_list));
        p_permit_list := NIL;
      IFEND;
    IFEND;
  PROCEND delete_catalog_object;

?? TITLE := '  initialize_catalog_locator', EJECT ??

  PROCEDURE initialize_catalog_locator
    (    old_catalog_locator: pft$catalog_locator;
         p_cell: {input} ^cell;
     VAR new_catalog_locator: pft$catalog_locator);

    CONST
      algorithm = 0,
      lock = TRUE;

    new_catalog_locator.set_name := old_catalog_locator.set_name;
    new_catalog_locator.new_catalog := TRUE;
    new_catalog_locator.queuing_info.set_catalog_alarm := FALSE;
    new_catalog_locator.queuing_info.attach_queued := FALSE;
    new_catalog_locator.internal_catalog_name := old_catalog_locator.internal_catalog_name;
    new_catalog_locator.attached := TRUE;
    new_catalog_locator.open := TRUE;
    new_catalog_locator.locked := TRUE;
    {
    { The "new" catalog is not actually locked, but the fields within the
    { "locked" subrecord are to be used.
    {
    new_catalog_locator.access_kind := pfc$write_access;
    new_catalog_locator.p_catalog_file := p_cell;
    osp$reset_heap (^new_catalog_locator.p_catalog_file^.catalog_heap,
          #SIZE (new_catalog_locator.p_catalog_file^.catalog_heap), NOT lock, algorithm);
    new_catalog_locator.p_catalog_file^.physical_catalog_header.catalog_header.valid :=
          old_catalog_locator.p_catalog_file^.physical_catalog_header.catalog_header.valid;
    new_catalog_locator.p_catalog_file^.physical_catalog_header.catalog_header.version :=
          old_catalog_locator.p_catalog_file^.physical_catalog_header.catalog_header.version;
    new_catalog_locator.p_catalog_file^.physical_catalog_header.catalog_header.
          reserved_catalog_header_space := old_catalog_locator.p_catalog_file^.physical_catalog_header.
          catalog_header.reserved_catalog_header_space;
    pfp$build_object_list_locator ({sorted_object_count} 0, {free_sorted_object_count} 0, {p_object_list} NIL,
          {p_catalog_file} NIL, new_catalog_locator.p_catalog_file^.physical_catalog_header.
          catalog_header.object_list_locator);
    pfp$compute_checksum (#LOC (new_catalog_locator.p_catalog_file^.physical_catalog_header.catalog_header),
          #SIZE (pft$catalog_header), new_catalog_locator.p_catalog_file^.physical_catalog_header.checksum);
    new_catalog_locator.object_list_descriptor.p_object_list := NIL;
    new_catalog_locator.object_list_descriptor.sorted_object_count := 0;
    new_catalog_locator.object_list_descriptor.free_sorted_object_count := 0;
    new_catalog_locator.object_list_descriptor.catalog_type := pfc$external_catalog;
    new_catalog_locator.object_list_descriptor.p_physical_catalog_header :=
          ^new_catalog_locator.p_catalog_file^.physical_catalog_header;
    new_catalog_locator.flush_catalog_pages := TRUE;
    new_catalog_locator.abort_catalog_operation := FALSE;
  PROCEND initialize_catalog_locator;

?? TITLE := '  log_deleted_catalog_object', EJECT ??

  PROCEDURE log_deleted_catalog_object
    (    path: pft$complete_path;
         critical_message: boolean;
     VAR status: ost$status);

    VAR
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      text: pft$string;

    pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
    STRINGREP (text.value, text.size, 'Catalog ', fs_path (1, fs_path_size), ' deleted.');
    pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
    osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
  PROCEND log_deleted_catalog_object;

?? TITLE := '  log_overhaul_options', EJECT ??

  PROCEDURE log_overhaul_options
    (    overhaul_options: pft$set_overhaul_choices;
     VAR status: ost$status);

    VAR
      overhaul_choices: pft$set_overhaul_options,
      overhaul_options_string: ost$string;


    FOR overhaul_choices := LOWERVALUE(pft$set_overhaul_options) TO UPPERVALUE(pft$set_overhaul_options) DO
      IF overhaul_choices IN overhaul_options THEN
        CASE overhaul_choices OF
          = pfc$all_catalogs =
            overhaul_options_string.size := 22;
            overhaul_options_string.value := ' *    pfc$all_catalogs';
          = pfc$recover_purged_files =
            overhaul_options_string.size := 30;
            overhaul_options_string.value := ' *    pfc$recover_purged_files';
          = pfc$validate_files=
            overhaul_options_string.size := 24;
            overhaul_options_string.value := ' *    pfc$validate_files';
          = pfc$reorganize_catalogs =
            overhaul_options_string.size := 29;
            overhaul_options_string.value := ' *    pfc$reorganize_catalogs';
          = pfc$reconcile_fmds =
            overhaul_options_string.size := 24;
            overhaul_options_string.value := ' *    pfc$reconcile_fmds';
          = pfc$delete_unreconciled_objects =
            overhaul_options_string.size := 37;
            overhaul_options_string.value := ' *    pfc$delete_unreconciled_objects';
        ELSE
        CASEND;
        pfp$log_ascii (overhaul_options_string.value (1, overhaul_options_string.size),
              ascii_logset, message_origin, {critical_message} FALSE, status);
      IFEND;
    FOREND;

  PROCEND log_overhaul_options;
?? TITLE := '  log_recovery_summary_status', EJECT ??

  PROCEDURE log_recovery_summary_status
    (VAR status: ost$status);

    IF status.normal AND ((pfv$catalogs_missing_media > 0) OR (pfv$catalogs_moved > 0) OR
          (pfv$catalogs_not_in_set > 0) OR (pfv$cycles_missing_media > 0) OR (pfv$cycles_not_in_set > 0) OR
          (pfv$immovable_catalogs > 0) OR (pfv$overhaul_errors > 0) OR (pfv$purged_catalogs_deleted > 0) OR
          (pfv$recreated_catalogs_cleared > 0) OR (pfv$reinstalled_device_cycles > 0) OR
          (pfv$unreconciled_cats_deleted > 0) OR (pfv$unreconciled_cycles_deleted > 0) OR
          (pfv$unreconciled_catalogs > 0) OR (pfv$unreconciled_files > 0) OR
          (pfv$unreconciled_cats_deleted > 0) OR (pfv$unreconciled_cycle_data_del > 0) OR
          (pfv$unreconciled_cycle_released > 0) OR (pfv$unreconciled_cycle_retained > 0) OR
          (pfv$unreconciled_cycles_deleted > 0)  OR (pfv$unreorganized_catalogs > 0)) THEN

      osp$set_status_condition (pfe$recovery_summary, status);
    IFEND;

    IF (NOT status.normal) AND (status.condition = pfe$recovery_summary) THEN
      osp$append_status_integer (osc$status_parameter_delimiter, pfv$overhaul_errors, radix,
            NOT include_radix, status);
      IF pfv$overhaul_errors = 1 THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'error', status);
      ELSE
        osp$append_status_parameter (osc$status_parameter_delimiter, 'errors', status);
      IFEND;

      IF pfv$catalogs_missing_media > 0 THEN
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$catalogs_missing_media, radix,
              NOT include_radix, status);
        IF pfv$catalogs_missing_media = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'catalog resides on an unavailable device.', status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'catalogs reside on one or more unavailable devices.', status);
        IFEND;
      IFEND;

      IF pfv$cycles_missing_media > 0 THEN
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$cycles_missing_media, radix,
              NOT include_radix, status);
        IF pfv$cycles_missing_media = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'cycle resides on an unavailable device.', status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'cycles reside on one or more unavailable devices.', status);
        IFEND;
      IFEND;

      IF pfv$catalogs_moved > 0 THEN
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$catalogs_moved, radix,
              NOT include_radix, status);
        IF pfv$catalogs_moved = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'catalog was moved from a non catalog device to a catalog device.', status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter, ('catalogs were moved from one or' CAT
                ' more non catalog devices to one or more catalog devices.'), status);
        IFEND;
      IFEND;

      IF pfv$immovable_catalogs > 0 THEN
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$immovable_catalogs, radix,
              NOT include_radix, status);
        IF pfv$immovable_catalogs = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'catalog could not be moved from a non catalog device to a catalog device.', status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter, ('catalogs could not be moved from' CAT
                ' one or more non catalog devices to one or more catalog devices.'), status);
        IFEND;
      IFEND;

      IF pfv$catalogs_not_in_set > 0 THEN
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$catalogs_not_in_set, radix,
              NOT include_radix, status);
        IF pfv$catalogs_not_in_set = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'catalog resides on a volume which is not a member of any set.', status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'catalogs reside on one or more volumes which are not members of any set.', status);
        IFEND;
      IFEND;

      IF pfv$cycles_not_in_set > 0 THEN
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$cycles_not_in_set, radix,
              NOT include_radix, status);
        IF pfv$cycles_not_in_set = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'cycle resides on a volume which is not a member of any set.', status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'cycles reside on one or more volumes which are not members of any set.', status);
        IFEND;
      IFEND;

      IF pfv$unreorganized_catalogs > 0 THEN
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$unreorganized_catalogs, radix,
              NOT include_radix, status);
        IF pfv$unreorganized_catalogs = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'catalog could not be reorganized.',
                status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter, 'catalogs could not be reorganized.',
                status);
        IFEND;
      IFEND;

      IF pfv$purged_catalogs_deleted > 0 THEN
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$purged_catalogs_deleted, radix,
              NOT include_radix, status);
        IF pfv$purged_catalogs_deleted = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'purged catalog was deleted.', status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter, 'purged catalogs were deleted.',
                status);
        IFEND;
      IFEND;

      IF pfv$recreated_catalogs_cleared > 0 THEN
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$recreated_catalogs_cleared, radix,
              NOT include_radix, status);
        IF pfv$recreated_catalogs_cleared = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 're-created catalog was cleared.',
                status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter, 're-created catalogs were cleared.',
                status);
        IFEND;
      IFEND;

      IF pfv$reinstalled_device_cycles > 0 THEN
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$reinstalled_device_cycles, radix,
              NOT include_radix, status);
        IF pfv$reinstalled_device_cycles = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'cycle resides on one or more reinstalled devices.', status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'cycles reside on one or more reinstalled devices.', status);
        IFEND;
      IFEND;

      IF pfv$unreconciled_catalogs > 0 THEN
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$unreconciled_catalogs, radix,
              NOT include_radix, status);
        IF pfv$unreconciled_catalogs = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'unreconciled catalog was detected.',
                status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter, 'unreconciled catalogs were detected.',
                status);
        IFEND;
      IFEND;

      IF pfv$unreconciled_cats_deleted > 0 THEN
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$unreconciled_cats_deleted, radix,
              NOT include_radix, status);
        IF pfv$unreconciled_cats_deleted = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'unreconciled catalog was deleted.',
                status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter, 'unreconciled catalogs were deleted.',
                status);
        IFEND;
      IFEND;

      IF pfv$unreconciled_cycles_deleted > 0 THEN
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$unreconciled_cycles_deleted, radix,
              NOT include_radix, status);
        IF pfv$unreconciled_cycles_deleted = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'unreconciled cycle was deleted.',
                status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter, 'unreconciled cycles were deleted.',
                status);
        IFEND;
      IFEND;

      IF pfv$unreconciled_cycle_released > 0 THEN
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$unreconciled_cycle_released, radix,
              NOT include_radix, status);
        IF pfv$unreconciled_cycle_released = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'unreconciled cycle was released.',
                status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter, 'unreconciled cycles were released.',
                status);
        IFEND;
      IFEND;

      IF pfv$unreconciled_cycle_retained > 0 THEN
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$unreconciled_cycle_retained, radix,
              NOT include_radix, status);
        IF pfv$unreconciled_cycle_retained = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'unreconciled cycle with archive images for older version was retained.', status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'unreconciled cycles with archive images for older version were retained.',
                status);
        IFEND;
      IFEND;

      IF pfv$unreconciled_cycle_data_del > 0 THEN
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$unreconciled_cycle_data_del, radix,
              NOT include_radix, status);
        IF pfv$unreconciled_cycle_data_del = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'cycle with data lost due to recovery without image.', status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter,
                'cycles with data lost due to recovery without image.', status);
        IFEND;
      IFEND;

      IF pfv$unreconciled_files > 0 THEN
        osp$append_status_integer (osc$status_parameter_delimiter, pfv$unreconciled_files, radix,
              NOT include_radix, status);
        IF pfv$unreconciled_files = 1 THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'unreconciled file was detected.',
                status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter, 'unreconciled files were detected.',
                status);
        IFEND;
      IFEND;
      pfp$log_error (status, ascii_logset, message_origin, critical_message);
    IFEND;
  PROCEND log_recovery_summary_status;

?? TITLE := '  overhaul_archive_list', EJECT ??

  PROCEDURE overhaul_archive_list
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
         cycle_number: pft$cycle_number;
         p_old_catalog_file: {input^} pft$p_catalog_file;
         p_new_catalog_file: {i^/o^} pft$p_catalog_file;
     VAR p_old_archive_list: {i^/o} pft$p_archive_list;
     VAR p_new_archive_list: {output} pft$p_archive_list;
     VAR status: ost$status);

    VAR
      archive_index: pft$archive_index,
      checksum: pft$checksum,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      new_archive_index: pft$archive_index,
      p_catalog_path: pft$p_complete_path,
      p_new_amd: pft$p_physical_amd,
      p_new_catalog_heap: pft$p_catalog_heap,
      p_old_amd: pft$p_physical_amd,
      path_index: pft$catalog_path_index,
      prevalidate_free_result: ost$prevalidate_free_result,
      text: pft$string,
      valid_archive_count: pft$archive_count,
      valid_archive_entry: boolean,
      validation_status: ost$status;

    status.normal := TRUE;
    p_new_catalog_heap := ^p_new_catalog_file^.catalog_heap;

    IF pfc$validate_files IN set_overhaul_choices THEN
      FOR archive_index := 1 TO UPPERBOUND (p_old_archive_list^) DO
        validate_archive_entry (path, cycle_number, ^p_old_archive_list^ [archive_index], validation_status);
        IF NOT validation_status.normal THEN
          IF status.normal THEN
            status := validation_status;
          IFEND;
        ELSE
          pfp$build_amd_pointer (p_old_archive_list^ [archive_index].archive_entry.amd_locator,
                p_old_catalog_file, p_old_amd);
          validate_amd (path, cycle_number, p_old_amd, validation_status);
          IF (NOT validation_status.normal) AND status.normal THEN
            status := validation_status;
          IFEND;
        IFEND;
      FOREND;
    IFEND;

    IF pfc$reconcile_fmds IN set_overhaul_choices THEN
      valid_archive_count := 0;

      FOR archive_index := 1 TO UPPERBOUND (p_old_archive_list^) DO
        pfp$compute_checksum (#LOC (p_old_archive_list^ [archive_index].archive_entry),
              #SIZE (pft$archive_entry), checksum);
        IF checksum = p_old_archive_list^ [archive_index].checksum THEN
          pfp$build_amd_pointer (p_old_archive_list^ [archive_index].archive_entry.amd_locator,
                p_old_catalog_file, p_old_amd);
          IF p_old_amd <> NIL THEN
            pfp$compute_checksum (#LOC (p_old_amd^.amd), #SIZE (p_old_amd^.amd), checksum);
            IF checksum = p_old_amd^.checksum THEN
              valid_archive_count := valid_archive_count + 1;
            IFEND;
          IFEND;
        IFEND;
      FOREND;

      IF valid_archive_count = 0 THEN
        p_new_archive_list := NIL;
      ELSE
        ALLOCATE p_new_archive_list: [1 .. valid_archive_count] IN p_new_catalog_heap^;

        IF p_new_archive_list = NIL THEN
          PUSH p_catalog_path: [1 .. UPPERBOUND (path) - 1];
          FOR path_index := 1 TO UPPERBOUND (path) - 1 DO
            p_catalog_path^ [path_index] := path [path_index];
          FOREND;
          pfp$convert_pf_path_to_fs_path (p_catalog_path^, fs_path, fs_path_size);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, fs_path (1, fs_path_size),
                status);
          RETURN;
        IFEND;

        new_archive_index := 1;
        FOR archive_index := 1 TO UPPERBOUND (p_old_archive_list^) DO
          pfp$compute_checksum (#LOC (p_old_archive_list^ [archive_index].archive_entry),
                #SIZE (pft$archive_entry), checksum);

          IF checksum = p_old_archive_list^ [archive_index].checksum THEN
            pfp$build_amd_pointer (p_old_archive_list^ [archive_index].archive_entry.amd_locator,
                  p_old_catalog_file, p_old_amd);

            IF p_old_amd <> NIL THEN
              pfp$compute_checksum (#LOC (p_old_amd^.amd), #SIZE (p_old_amd^.amd), checksum);

              IF checksum = p_old_amd^.checksum THEN
                p_new_archive_list^ [new_archive_index] := p_old_archive_list^ [archive_index];
                ALLOCATE p_new_amd: [[REP (#SIZE (p_old_amd^.amd)) OF cell]] IN p_new_catalog_heap^;

                IF p_new_amd = NIL THEN
                  PUSH p_catalog_path: [1 .. UPPERBOUND (path) - 1];
                  FOR path_index := 1 TO UPPERBOUND (path) - 1 DO
                    p_catalog_path^ [path_index] := path [path_index];
                  FOREND;
                  pfp$convert_pf_path_to_fs_path (p_catalog_path^, fs_path, fs_path_size);
                  osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full,
                        fs_path (1, fs_path_size), status);
                  RETURN;
                IFEND;

                p_new_amd^ := p_old_amd^;
                pfp$build_amd_locator (p_new_amd, p_new_catalog_file,
                      p_new_archive_list^ [new_archive_index].archive_entry.amd_locator);
                pfp$compute_checksum (#LOC (p_new_archive_list^ [new_archive_index].archive_entry),
                      #SIZE (pft$archive_entry), p_new_archive_list^ [new_archive_index].checksum);
                new_archive_index := new_archive_index + 1;
              IFEND;
            IFEND;
          IFEND;
        FOREND;
      IFEND;

      FOR archive_index := 1 TO UPPERBOUND (p_old_archive_list^) DO
        valid_archive_entry := FALSE;

        pfp$compute_checksum (#LOC (p_old_archive_list^ [archive_index].archive_entry),
              #SIZE (pft$archive_entry), checksum);
        IF checksum = p_old_archive_list^ [archive_index].checksum THEN
          pfp$build_amd_pointer (p_old_archive_list^ [archive_index].archive_entry.amd_locator,
                p_old_catalog_file, p_old_amd);
          IF p_old_amd <> NIL THEN
            pfp$compute_checksum (#LOC (p_old_amd^.amd), #SIZE (p_old_amd^.amd), checksum);
            IF checksum = p_old_amd^.checksum THEN
              valid_archive_entry := TRUE;
            IFEND;

            IF NOT (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
              osp$prevalidate_free ((#OFFSET(p_old_amd) - #OFFSET(p_new_catalog_heap) - 16),
                    p_new_catalog_heap, prevalidate_free_result);
              IF prevalidate_free_result = osc$heap_free_valid THEN
                FREE p_old_amd IN p_new_catalog_heap^;
              ELSE
                pfp$report_invalid_free (^path, ^cycle_number, 'ARCHIVE_MEDIA_DESCRIPTOR', 'file',
                      prevalidate_free_result, #OFFSET(p_old_amd));
                p_old_amd := NIL;
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        IF NOT valid_archive_entry THEN
          pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
          STRINGREP (text.value, text.size, 'Archive entry deleted for cycle ', fs_path (1, fs_path_size),
                cycle_number, '.');
          text.value (33 + fs_path_size) := '.';
          pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
        IFEND;
      FOREND;

      IF NOT (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
        osp$prevalidate_free ((#OFFSET(p_old_archive_list) - #OFFSET(p_new_catalog_heap) - 16),
              p_new_catalog_heap, prevalidate_free_result);
        IF prevalidate_free_result = osc$heap_free_valid THEN
          FREE p_old_archive_list IN p_new_catalog_heap^;
        ELSE
          pfp$report_invalid_free (^path, ^cycle_number, 'ARCHIVE_LIST', 'file', prevalidate_free_result,
                #OFFSET(p_old_archive_list));
          p_old_archive_list := NIL;
        IFEND;
      IFEND;
    IFEND;
  PROCEND overhaul_archive_list;

?? TITLE := '  overhaul_catalog_content', EJECT ??

  PROCEDURE overhaul_catalog_content
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
         reconcile_locator: dmt$reconcile_locator;
         p_old_catalog_file: {input^} ^pft$catalog_file;
         authority: pft$authority;
     VAR object_list_descriptor: {i/o} pft$object_list_descriptor;
     VAR new_catalog_locator: pft$catalog_locator;
     VAR moved_or_destroyed_child: {i/o} boolean;
     VAR p_new_object_list: ^pft$object_list;
     VAR status: ost$status);

    VAR
      catalog_status: ost$status,
      fs_path_size: fst$path_size,
      new_path_index: pft$file_path_index,
      object_index: pft$object_index,
      p_fs_path: ^fst$path,
      p_new_path: ^pft$complete_path,
      p_object: ^pft$physical_object,
      path_index: pft$catalog_path_index,
      temp_set_overhaul_choices: pft$set_overhaul_choices,
      text: pft$string;

    temp_set_overhaul_choices := set_overhaul_choices + $pft$set_overhaul_choices [pfc$recover_purged_files];
    IF (object_list_descriptor.sorted_object_count > 0) OR pfv$sort_catalog_object_list OR
          (pfc$object_sort_threshold <= UPPERBOUND (object_list_descriptor.p_object_list^)) THEN
      overhaul_sorted_object_list (temp_set_overhaul_choices, path, object_list_descriptor,
            new_catalog_locator, p_new_object_list, status);
    ELSE
      new_catalog_locator.object_list_descriptor.sorted_object_count := 0;
      new_catalog_locator.object_list_descriptor.free_sorted_object_count := 0;
      overhaul_object_list (temp_set_overhaul_choices, path, object_list_descriptor, new_catalog_locator,
            p_new_object_list, status);
    IFEND;

    IF (NOT status.normal) AND (status.condition = pfe$catalog_full) THEN
      p_new_object_list := NIL;
      RETURN;
    IFEND;
    {
    { The new object list now contains objects with pointers to items in the
    { old catalog. The processing will be done from the new object list,
    { because in the case of reorganization the new object list is known to be
    { valid, but the old object list may contain invalid objects.
    {
    new_path_index := UPPERBOUND (path) + 1;
    PUSH p_new_path: [1 .. new_path_index];
    FOR path_index := 1 TO UPPERBOUND (path) DO
      p_new_path^ [path_index] := path [path_index];
    FOREND;

  /overhaul_objects/
    FOR object_index := 1 TO UPPERBOUND (p_new_object_list^) DO
      p_object := ^p_new_object_list^ [object_index];
      CASE p_object^.object_entry.object_type OF
      = pfc$free_object =
        {
        { Do nothing.
        {

      = pfc$file_object, pfc$purged_file_object =
        p_new_path^ [new_path_index] := p_object^.object_entry.external_object_name;
        overhaul_file_object (set_overhaul_choices, p_new_path^, reconcile_locator, p_old_catalog_file,
              p_object, new_catalog_locator, moved_or_destroyed_child, catalog_status);
        IF NOT catalog_status.normal THEN
          status := catalog_status;
          IF (status.condition = pfe$catalog_full) OR (status.condition = pfe$pf_system_error) THEN
            EXIT /overhaul_objects/;
          IFEND;
        IFEND;

      = pfc$catalog_object, pfc$purged_catalog_object =
        p_new_path^ [new_path_index] := p_object^.object_entry.external_object_name;
        overhaul_catalog_object (set_overhaul_choices, p_new_path^, reconcile_locator, p_old_catalog_file,
              authority, p_object, new_catalog_locator, moved_or_destroyed_child, catalog_status);
        IF NOT catalog_status.normal THEN
          status := catalog_status;
          IF (status.condition = pfe$bad_catalog_heap) OR (status.condition = pfe$catalog_full) OR
                (status.condition = pfe$pf_system_error) THEN
            EXIT /overhaul_objects/;
          IFEND;
        IFEND;

      ELSE { An invalid object type passed the checksum validation test.
        p_new_path^ [new_path_index] := p_object^.object_entry.external_object_name;
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (p_new_path^, p_fs_path^, fs_path_size);
        IF pfc$reconcile_fmds IN set_overhaul_choices THEN
          p_object^.object_entry.object_type := pfc$free_object;
          pfp$compute_checksum (#LOC (p_object^.object_entry), #SIZE (pft$object_entry), p_object^.checksum);
          STRINGREP (text.value, text.size, 'Invalid object type; catalog/file ',
                p_fs_path^ (1, fs_path_size), ' deleted.');
          IF object_index <= new_catalog_locator.object_list_descriptor.sorted_object_count THEN
            new_catalog_locator.object_list_descriptor.free_sorted_object_count :=
                  new_catalog_locator.object_list_descriptor.free_sorted_object_count + 1;
          IFEND;
        ELSE
          STRINGREP (text.value, text.size, 'Invalid object type for catalog/file ',
                p_fs_path^ (1, fs_path_size), '.');
        IFEND;
        pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
        osp$set_status_condition (pfe$recovery_summary, status);
        pfv$overhaul_errors := pfv$overhaul_errors + 1;
        #KEYPOINT (osk$unusual, 0, pfk$invalid_object_entry);
      CASEND;
    FOREND /overhaul_objects/;
  PROCEND overhaul_catalog_content;

?? TITLE := '  overhaul_catalog_object', EJECT ??

  PROCEDURE overhaul_catalog_object
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
         reconcile_locator: dmt$reconcile_locator;
         p_old_parent_catalog_file: {input^} ^pft$catalog_file;
         authority: pft$authority;
         p_new_catalog_object: {i^/o^} ^pft$physical_object;
     VAR new_parent_catalog_locator: pft$catalog_locator;
     VAR moved_or_destroyed_child: {i/o} boolean;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      p_new_permit_list: ^pft$permit_list,
      p_old_permit_list: ^pft$permit_list,
      p_physical_fmd: ^pft$physical_fmd,
      prevalidate_free_result: ost$prevalidate_free_result,
      temp_set_overhaul_choices: pft$set_overhaul_choices;

    status.normal := TRUE;
    p_new_permit_list := NIL;

    pfp$build_permit_list_pointer (p_new_catalog_object^.object_entry.permit_list_locator,
          p_old_parent_catalog_file, p_old_permit_list);
    IF p_old_permit_list = NIL THEN
      IF pfv$clear_catalog_recreated AND p_new_catalog_object^.object_entry.catalog_recreated_by_restore THEN
        pfv$recreated_catalogs_cleared := pfv$recreated_catalogs_cleared + 1;
        p_new_catalog_object^.object_entry.catalog_recreated_by_restore := FALSE;
        pfp$compute_checksum (#LOC (p_new_catalog_object^.object_entry), #SIZE (pft$object_entry),
              p_new_catalog_object^.checksum);
      IFEND;
    ELSE
      IF p_new_catalog_object^.object_entry.object_type = pfc$catalog_object THEN
        overhaul_permit_list (set_overhaul_choices, path, p_new_catalog_object^.object_entry.object_type,
              p_old_permit_list, ^new_parent_catalog_locator.p_catalog_file^.catalog_heap, p_new_permit_list,
              status);
      IFEND;
      IF pfc$reconcile_fmds IN set_overhaul_choices THEN
        IF status.normal THEN
          pfp$build_permit_list_locator (p_new_permit_list, new_parent_catalog_locator.p_catalog_file,
                p_new_catalog_object^.object_entry.permit_list_locator);
          IF pfv$clear_catalog_recreated AND
                p_new_catalog_object^.object_entry.catalog_recreated_by_restore THEN
            pfv$recreated_catalogs_cleared := pfv$recreated_catalogs_cleared + 1;
            p_new_catalog_object^.object_entry.catalog_recreated_by_restore := FALSE;
          IFEND;
          pfp$compute_checksum (#LOC (p_new_catalog_object^.object_entry), #SIZE (pft$object_entry),
                p_new_catalog_object^.checksum);
        ELSEIF status.condition = pfe$catalog_full THEN
          RETURN;
        ELSE
          {
          { A permit entry is defective. Remove the catalog so that
          { unauthorized users may not access the file. (Because permit groups
          { have precedence over catalog/file permit hierarchies, either all
          { permits in the subtree of the highest level, permit containing
          { catalog in the path must be deleted, or this catalog must be
          { deleted. The latter option has been chosen.)
          {
          IF p_new_catalog_object^.object_entry.catalog_object_locator.catalog_type = pfc$external_catalog
                THEN
            pfp$build_fmd_pointer (p_new_catalog_object^.object_entry.catalog_object_locator.fmd_locator,
                  p_old_parent_catalog_file, p_physical_fmd);
            IF p_physical_fmd <> NIL THEN
              IF NOT (pfc$delete_unreconciled_objects IN set_overhaul_choices) THEN
                dmp$destroy_permanent_file (new_parent_catalog_locator.global_file_name,
                      p_physical_fmd^.fmd, local_status);
                IF local_status.normal THEN
                  moved_or_destroyed_child := TRUE;
                  out_of_space := FALSE;
                IFEND;
              IFEND;
              IF NOT (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
                {
                { The fmd still exists in the "new", parent catalog. (It will not
                { have been allocated in the new, parent catalog when reorganizing.)
                {
                osp$prevalidate_free ((#OFFSET(p_physical_fmd) -
                      #OFFSET(^new_parent_catalog_locator.p_catalog_file^.catalog_heap) - 16),
                      ^new_parent_catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
                IF prevalidate_free_result = osc$heap_free_valid THEN
                  FREE p_physical_fmd IN new_parent_catalog_locator.p_catalog_file^.catalog_heap;
                ELSE
                  pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'FILE_MEDIA_DESCRIPTOR', 'catalog',
                        prevalidate_free_result, #OFFSET(p_physical_fmd));
                  p_physical_fmd := NIL;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
          delete_catalog_object (^path, p_new_catalog_object, new_parent_catalog_locator, p_new_permit_list);
          log_deleted_catalog_object (path, critical_message, status);
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      CASE p_new_catalog_object^.object_entry.catalog_object_locator.catalog_type OF
      = pfc$internal_catalog =
        overhaul_internal_catalog (set_overhaul_choices, path, reconcile_locator, p_old_parent_catalog_file,
              authority, p_new_catalog_object, new_parent_catalog_locator, moved_or_destroyed_child, status);

      = pfc$external_catalog =
        IF pfc$all_catalogs IN set_overhaul_choices THEN
          overhaul_external_catalog (set_overhaul_choices, path, reconcile_locator, p_old_parent_catalog_file,
                authority, p_new_catalog_object, new_parent_catalog_locator, p_new_permit_list,
                moved_or_destroyed_child, status);
        IFEND;

      ELSE
        pfp$log_ascii ('Invalid catalog type.', ascii_logset, message_origin, critical_message, status);
        IF pfc$reconcile_fmds IN set_overhaul_choices THEN
          delete_catalog_object (^path, p_new_catalog_object, new_parent_catalog_locator, p_new_permit_list);
          log_deleted_catalog_object (path, critical_message, status);
        ELSE
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
        IFEND;
        pfv$overhaul_errors := pfv$overhaul_errors + 1;
        #KEYPOINT (osk$unusual, 0, pfk$invalid_object_entry);
      CASEND;
    IFEND;
  PROCEND overhaul_catalog_object;

?? TITLE := '  overhaul_cycle_list', EJECT ??

  PROCEDURE overhaul_cycle_list
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
         reconcile_locator: dmt$reconcile_locator;
         p_cycle_list: {input} ^pft$cycle_list;
         p_old_catalog_file: {input^} ^pft$catalog_file;
         p_new_catalog_file: {i^/o^} ^pft$catalog_file;
         p_catalog_heap: {i/o^} ^pft$catalog_heap;
     VAR cycle_destroyed: {i/o} boolean;
     VAR p_new_cycle_list: ^pft$cycle_list;
     VAR empty_cycle_list: boolean;
     VAR normal_or_recovered_cycles: boolean;
     VAR status: ost$status);

    CONST
      cycle_expansion_count = 1,
      purge_cycle = TRUE;

    VAR
      cycle_count: pft$cycle_count,
      cycle_index: pft$cycle_index,
      cycle_status: ost$status,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      high_cycle_index: pft$cycle_index,
      new_cycle_index: pft$cycle_index,
      p_catalog_path: ^pft$complete_path,
      p_old_physical_fmd: ^pft$physical_fmd,
      path_index: pft$catalog_path_index,
      physical_cycle: pft$physical_cycle,
      text: pft$string;

    high_cycle_index := UPPERBOUND (p_cycle_list^);

    IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
      cycle_count := 0;

      FOR cycle_index := 1 TO high_cycle_index DO
        CASE p_cycle_list^ [cycle_index].cycle_entry.entry_type OF
        = pfc$free_cycle_entry =
          {
          { Do nothing.
          {

        = pfc$normal_cycle_entry =
          cycle_count := cycle_count + 1;

        = pfc$purged_cycle_entry =
          {
          { It is possible for a purged cycle entry to have an attach count of
          { zero during a running system, if all jobs which wished to reattach
          { the cycle during the previous recovery were unrecoverable.
          {
          IF (pfc$recover_purged_files IN set_overhaul_choices) AND
                (p_cycle_list^ [cycle_index].cycle_entry.attach_status.attach_count > 0) THEN
            cycle_count := cycle_count + 1;
          IFEND;

        ELSE
          {
          { Do nothing. This error will be processed later.
          {
        CASEND;
      FOREND;

      IF cycle_count + cycle_expansion_count < high_cycle_index THEN
        ALLOCATE p_new_cycle_list: [1 .. cycle_count + cycle_expansion_count] IN p_catalog_heap^;
      ELSE
        ALLOCATE p_new_cycle_list: [1 .. high_cycle_index] IN p_catalog_heap^;
      IFEND;

      IF p_new_cycle_list = NIL THEN
        PUSH p_catalog_path: [1 .. UPPERBOUND (path) - 1];
        FOR path_index := 1 TO UPPERBOUND (p_catalog_path^) DO
          p_catalog_path^ [path_index] := path [path_index];
        FOREND;
        pfp$convert_pf_path_to_fs_path (p_catalog_path^, fs_path, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, fs_path (1, fs_path_size),
              status);
        pfp$log_error (status, ascii_logset, message_origin, critical_message);
      ELSE
        status.normal := TRUE;
      IFEND;
    ELSE
      p_new_cycle_list := p_cycle_list;
      status.normal := TRUE;
    IFEND;

    empty_cycle_list := status.normal AND (pfc$reconcile_fmds IN set_overhaul_choices);
    normal_or_recovered_cycles := NOT empty_cycle_list;

    IF status.normal THEN
      new_cycle_index := 1;

      FOR cycle_index := 1 TO high_cycle_index DO
        cycle_status.normal := TRUE;

        CASE p_cycle_list^ [cycle_index].cycle_entry.entry_type OF
        = pfc$free_cycle_entry =
          {
          { Do nothing.
          {

        = pfc$normal_cycle_entry =
          IF pfc$validate_files IN set_overhaul_choices THEN
            validate_cycle_entry (set_overhaul_choices, path, ^p_cycle_list^ [cycle_index], cycle_status);
          IFEND;
          IF cycle_status.normal THEN
            IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
              p_new_cycle_list^ [new_cycle_index] := p_cycle_list^ [cycle_index];
              overhaul_file_cycle (set_overhaul_choices, path, reconcile_locator, NOT purge_cycle,
                    p_old_catalog_file, p_new_catalog_file, ^p_new_cycle_list^ [new_cycle_index],
                    cycle_destroyed, empty_cycle_list, normal_or_recovered_cycles, cycle_status);
              new_cycle_index := new_cycle_index + 1;
            ELSE
              overhaul_file_cycle (set_overhaul_choices, path, reconcile_locator, NOT purge_cycle,
                    p_old_catalog_file, p_new_catalog_file, ^p_cycle_list^ [cycle_index], cycle_destroyed,
                    empty_cycle_list, normal_or_recovered_cycles, cycle_status);
            IFEND;
            IF NOT cycle_status.normal THEN
              status := cycle_status;
              IF status.condition = pfe$catalog_full THEN
                RETURN;
              IFEND;
            IFEND;
          ELSE
            IF pfc$reconcile_fmds IN set_overhaul_choices THEN
              pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
              STRINGREP (text.value, text.size, 'Cycle ', fs_path (1, fs_path_size),
                    p_cycle_list^ [cycle_index].cycle_entry.cycle_number, ' deleted.');
              text.value (7 + fs_path_size) := '.';
              IF NOT (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
                p_cycle_list^ [cycle_index].cycle_entry.entry_type := pfc$free_cycle_entry;
                pfp$compute_checksum (#LOC (p_cycle_list^ [cycle_index].cycle_entry), #SIZE (pft$cycle_entry),
                      p_cycle_list^ [cycle_index].checksum);
              IFEND;
              pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message,
                    status);
            IFEND;
            status := cycle_status;
          IFEND;

        = pfc$purged_cycle_entry =
          IF pfc$validate_files IN set_overhaul_choices THEN
            validate_cycle_entry (set_overhaul_choices, path, ^p_cycle_list^ [cycle_index], cycle_status);
          IFEND;
          IF cycle_status.normal THEN
            IF (pfc$recover_purged_files IN set_overhaul_choices) AND
                  (p_cycle_list^ [cycle_index].cycle_entry.attach_status.attach_count > 0) THEN
              IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
                p_new_cycle_list^ [new_cycle_index] := p_cycle_list^ [cycle_index];
                overhaul_file_cycle (set_overhaul_choices, path, reconcile_locator, NOT purge_cycle,
                      p_old_catalog_file, p_new_catalog_file, ^p_new_cycle_list^ [new_cycle_index],
                      cycle_destroyed, empty_cycle_list, normal_or_recovered_cycles, cycle_status);
                new_cycle_index := new_cycle_index + 1;
              ELSE
                overhaul_file_cycle (set_overhaul_choices, path, reconcile_locator, NOT purge_cycle,
                      p_old_catalog_file, p_new_catalog_file, ^p_cycle_list^ [cycle_index], cycle_destroyed,
                      empty_cycle_list, normal_or_recovered_cycles, cycle_status);
              IFEND;
              IF NOT cycle_status.normal THEN
                status := cycle_status;
                IF status.condition = pfe$catalog_full THEN
                  RETURN;
                IFEND;
              IFEND;
            ELSE
              IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
                p_new_cycle_list^ [new_cycle_index] := p_cycle_list^ [cycle_index];
                overhaul_file_cycle (set_overhaul_choices, path, reconcile_locator, purge_cycle,
                      p_old_catalog_file, p_new_catalog_file, ^p_new_cycle_list^ [new_cycle_index],
                      cycle_destroyed, empty_cycle_list, normal_or_recovered_cycles, cycle_status);
              ELSE
                overhaul_file_cycle (set_overhaul_choices, path, reconcile_locator, purge_cycle,
                      p_old_catalog_file, p_new_catalog_file, ^p_cycle_list^ [cycle_index], cycle_destroyed,
                      empty_cycle_list, normal_or_recovered_cycles, cycle_status);
                IF pfc$reconcile_fmds IN set_overhaul_choices THEN
                  p_cycle_list^ [cycle_index].cycle_entry.entry_type := pfc$free_cycle_entry;
                  pfp$compute_checksum (#LOC (p_cycle_list^ [cycle_index].cycle_entry),
                        #SIZE (pft$cycle_entry), p_cycle_list^ [cycle_index].checksum);
                IFEND;
              IFEND;
              IF NOT cycle_status.normal THEN
                status := cycle_status;
              IFEND;
            IFEND;
          ELSE
            IF pfc$reconcile_fmds IN set_overhaul_choices THEN
              pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
              STRINGREP (text.value, text.size, 'Cycle ', fs_path (1, fs_path_size),
                    p_cycle_list^ [cycle_index].cycle_entry.cycle_number, ' deleted.');
              text.value (7 + fs_path_size) := '.';
              IF NOT (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
                p_cycle_list^ [cycle_index].cycle_entry.entry_type := pfc$free_cycle_entry;
                pfp$compute_checksum (#LOC (p_cycle_list^ [cycle_index].cycle_entry), #SIZE (pft$cycle_entry),
                      p_cycle_list^ [cycle_index].checksum);
              IFEND;
              pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message,
                    status);
            IFEND;
            status := cycle_status;
          IFEND;

        ELSE
          pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
          IF pfc$reconcile_fmds IN set_overhaul_choices THEN
            IF NOT (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
              p_cycle_list^ [cycle_index].cycle_entry.entry_type := pfc$free_cycle_entry;
              pfp$compute_checksum (#LOC (p_cycle_list^ [cycle_index].cycle_entry), #SIZE (pft$cycle_entry),
                    p_cycle_list^ [cycle_index].checksum);
            IFEND;
            STRINGREP (text.value, text.size, 'Invalid cycle entry type; cycle ', fs_path (1, fs_path_size),
                  '.? deleted.');
          ELSE
            STRINGREP (text.value, text.size, 'Invalid cycle entry type for cycle ',
                  fs_path (1, fs_path_size), '.?.');
          IFEND;
          pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
          pfv$overhaul_errors := pfv$overhaul_errors + 1;
          #KEYPOINT (osk$unusual, 0, pfk$invalid_cycle_entry);
        CASEND;
      FOREND;

      IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
        {
        { Initialize remaining cycle entries.
        {
        physical_cycle.cycle_entry.entry_type := pfc$free_cycle_entry;
        pfp$compute_checksum (#LOC (physical_cycle.cycle_entry), #SIZE (pft$cycle_entry),
              physical_cycle.checksum);
        FOR cycle_index := new_cycle_index TO UPPERBOUND (p_new_cycle_list^) DO
          p_new_cycle_list^ [cycle_index] := physical_cycle;
        FOREND;
      IFEND;
    IFEND;
  PROCEND overhaul_cycle_list;

?? TITLE := '  overhaul_external_catalog', EJECT ??

  PROCEDURE overhaul_external_catalog
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
         reconcile_locator: dmt$reconcile_locator;
         p_old_parent_catalog_file: {input^} ^pft$catalog_file;
         authority: pft$authority;
         p_new_catalog_object: {i^/o^} ^pft$physical_object;
     VAR new_parent_catalog_locator: {i/o} pft$catalog_locator;
     VAR p_new_permit_list: {i/o} ^pft$permit_list;
     VAR moved_or_destroyed_catalog: {i/o} boolean;
     VAR status: ost$status);

    CONST
      block_exit = TRUE,
      byte_address = 0,
      catalog_remote = TRUE,
      chapter = 0,
      max_reply_length = 119,
      purge_catalog = TRUE,
      validation_ring = 2;

    TYPE
      pft$previous_reorganization = record
        case operator_already_queried: boolean of
        = FALSE =
          ,
        = TRUE =
          already_attempted: boolean,
        casend,
      recend;

    VAR
      catalog_or_cycle: pft$catalog_or_cycle,
      catalog_segment_length: ost$segment_length,
      conditions: pmt$condition,
      established_handler: pmt$established_handler,
      fs_path_size: fst$path_size,
      getsl_allfs_status: ost$status,
      ignore_unreconciled_file: boolean,
      global_file_name: ost$binary_unique_name,
      internal_catalog_name: pft$internal_catalog_name,
      line_received: boolean,
      local_status: ost$status,
      mass_storage_classes: dmt$class,
      moved_or_destroyed_child: boolean,
      new_catalog_locator: pft$catalog_locator,
      old_catalog_locator: pft$catalog_locator,
      p_fs_path: ^fst$path,
      p_new_parent_catalog_file: ^pft$catalog_file,
      p_new_physical_fmd: ^pft$physical_fmd,
      p_old_physical_fmd: ^pft$physical_fmd,
      prevalidate_free_result: ost$prevalidate_free_result,
      previous_reorganization: [STATIC] pft$previous_reorganization := [FALSE],
      reply: string (max_reply_length),
      resides_on_system_device: boolean,
      scratch_segment_pointer: amt$segment_pointer,
      temp_set_overhaul_choices: pft$set_overhaul_choices,
      text: pft$string,
      uc_reply: string (max_reply_length),
      verify_heap: boolean;


    PROCEDURE condition_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      IF (condition.selector = pmc$system_conditions) OR
            (condition.selector = mmc$segment_access_condition) THEN
        osp$set_status_from_condition (pfc$permanent_file_manager_id, condition, p_sfsa, status,
              local_status);
        IF local_status.normal THEN
          pfp$log_error (status, ascii_logset, message_origin,
                (critical_message OR syv$nosve_internal_operations));
        ELSE
          pfp$log_error (local_status, ascii_logset, message_origin,
                (critical_message OR syv$nosve_internal_operations));
          status := local_status;
        IFEND;

        IF NOT verify_heap THEN
          IF syv$nosve_internal_operations THEN
            pfp$log_ascii (('Invoking system core debugger, from overhaul_external_catalog, due to unexpected'
                  CAT ' condition.'), ascii_logset, message_origin, {critical_message} TRUE, local_status);
            pfp$log_ascii ('Contact PF project.', ascii_logset, message_origin, {critical_message} TRUE,
                  local_status);
            syp$invoke_system_debugger ('', 0, local_status);
          IFEND;

          IF pfc$reconcile_fmds IN set_overhaul_choices THEN
            delete_catalog_object (^path, p_new_catalog_object, new_parent_catalog_locator,
                  p_new_permit_list);
            log_deleted_catalog_object (path, critical_message, status);
          IFEND;

          pfv$overhaul_errors := pfv$overhaul_errors + 1;
          previous_timestamp := #free_running_clock (0);
          EXIT overhaul_external_catalog;
        IFEND;
      ELSE
        {
        { Ignore the condition.
        {
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND condition_handler;

    PROCEDURE revert_to_old_catalog;

      VAR
        fs_path: fst$path,
        p_new_physical_fmd: ^pft$physical_fmd;

      replace_catalog (path, old_catalog_locator, p_new_parent_catalog_file, p_new_catalog_object,
            p_new_physical_fmd, local_status);
      IF local_status.normal THEN
        status.normal := TRUE;
        pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
        STRINGREP (text.value, text.size, 'Unable to reorganize catalog ', fs_path (1, fs_path_size), '.');
        pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message,
              local_status);
        pfv$unreorganized_catalogs := pfv$unreorganized_catalogs + 1;
      ELSE
        pfp$log_ascii ('Previous error from replace_catalog.', ascii_logset, message_origin,
              critical_message, local_status);
        dmp$destroy_permanent_file (new_catalog_locator.global_file_name, p_old_physical_fmd^.fmd,
              local_status);
        out_of_space := out_of_space AND NOT local_status.normal;
        delete_catalog_object (^path, p_new_catalog_object, new_parent_catalog_locator, p_new_permit_list);
        IF p_new_physical_fmd <> NIL THEN
          osp$prevalidate_free ((#OFFSET(p_new_physical_fmd) -
                #OFFSET(^p_new_parent_catalog_file^.catalog_heap) - 16),
                ^p_new_parent_catalog_file^.catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_new_physical_fmd IN p_new_parent_catalog_file^.catalog_heap;
          ELSE
            pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'FILE_MEDIA_DESCRIPTOR',
                  'catalog', prevalidate_free_result, #OFFSET(p_new_physical_fmd));
            p_new_physical_fmd := NIL;
          IFEND;
        IFEND;
        log_deleted_catalog_object (path, critical_message, status);
        pfv$overhaul_errors := pfv$overhaul_errors + 1;
        moved_or_destroyed_catalog := TRUE;
      IFEND;
    PROCEND revert_to_old_catalog;

    status.normal := TRUE;
    verify_heap := FALSE;
    #SPOIL (verify_heap);
    osp$establish_condition_handler (^condition_handler, NOT block_exit);

    p_new_parent_catalog_file := new_parent_catalog_locator.p_catalog_file;
    pfp$build_fmd_pointer (p_new_catalog_object^.object_entry.catalog_object_locator.fmd_locator,
          p_old_parent_catalog_file, p_old_physical_fmd);
    IF p_old_physical_fmd <> NIL THEN
      internal_catalog_name := p_new_catalog_object^.object_entry.internal_object_name;
      global_file_name := p_new_catalog_object^.object_entry.catalog_object_locator.global_file_name;
      catalog_or_cycle.cycle_specified := FALSE;
      IF p_new_catalog_object^.object_entry.object_type = pfc$purged_catalog_object THEN
        {
        { Purged catalogs are currently unrecoverable, if reconciliation is
        { chosen, because job recovery will be unable to attach the catalog
        { due to its use of the external catalog name.
        {
        overhaul_fmd (set_overhaul_choices, path, catalog_or_cycle, rmc$mass_storage_device,
              global_file_name, reconcile_locator, purge_catalog,
              ^p_new_parent_catalog_file^.catalog_heap, p_old_physical_fmd, p_new_physical_fmd,
              resides_on_system_device, mass_storage_classes, ignore_unreconciled_file, status);
      ELSE
        overhaul_fmd (set_overhaul_choices, path, catalog_or_cycle, rmc$mass_storage_device,
              global_file_name, reconcile_locator, NOT purge_catalog,
              ^p_new_parent_catalog_file^.catalog_heap, p_old_physical_fmd, p_new_physical_fmd,
              resides_on_system_device, mass_storage_classes, ignore_unreconciled_file, status);
      IFEND;

      IF status.normal THEN
        IF pfc$reconcile_fmds IN set_overhaul_choices THEN
          pfp$attach_catalog (^p_old_physical_fmd^.fmd, path [pfc$set_path_index], internal_catalog_name,
                global_file_name, pfc$write_access, NOT catalog_remote, old_catalog_locator, status);
        ELSE
          pfp$attach_catalog (^p_old_physical_fmd^.fmd, path [pfc$set_path_index], internal_catalog_name,
                global_file_name, pfc$read_access, NOT catalog_remote, old_catalog_locator, status);
        IFEND;

        IF status.normal THEN
          IF (pfc$reconcile_fmds IN set_overhaul_choices) AND
                NOT (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
            verify_heap := TRUE;
            #SPOIL (verify_heap);
            osp$verify_heap (^old_catalog_locator.p_catalog_file^.catalog_heap, status.normal);
            #SPOIL (verify_heap);
            verify_heap := FALSE;
            #SPOIL (verify_heap);
          IFEND;

          IF status.normal THEN
            IF (p_new_catalog_object^.object_entry.object_type = pfc$purged_catalog_object) AND
                  (pfc$reconcile_fmds IN set_overhaul_choices) THEN
              temp_set_overhaul_choices := set_overhaul_choices -
                    $pft$set_overhaul_choices [pfc$recover_purged_files];
            ELSE
              temp_set_overhaul_choices := set_overhaul_choices;
            IFEND;

            overhaul_physical_catalog (temp_set_overhaul_choices, path, reconcile_locator, authority,
                  old_catalog_locator, new_catalog_locator, moved_or_destroyed_child, status);
            IF status.normal OR (status.condition = pfe$recovery_summary) OR
                  (status.condition = pfe$catalog_full) THEN
              IF p_new_catalog_object^.object_entry.object_type = pfc$purged_catalog_object THEN
                IF pfc$reconcile_fmds IN set_overhaul_choices THEN
                  {
                  { Purged catalogs are currently unrecoverable, if
                  { reconciliation is chosen, because job recovery will be
                  { unable to attach the catalog due to its use of the
                  { external catalog name.
                  {
                  delete_catalog_object (^path, p_new_catalog_object, new_parent_catalog_locator,
                        p_new_permit_list);
                  IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
                    IF p_new_physical_fmd <> NIL THEN
                      osp$prevalidate_free ((#OFFSET(p_new_physical_fmd) -
                            #OFFSET(^p_new_parent_catalog_file^.catalog_heap) - 16),
                            ^p_new_parent_catalog_file^.catalog_heap, prevalidate_free_result);
                      IF prevalidate_free_result = osc$heap_free_valid THEN
                        FREE p_new_physical_fmd IN p_new_parent_catalog_file^.catalog_heap;
                      ELSE
                        pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'FILE_MEDIA_DESCRIPTOR',
                              'catalog', prevalidate_free_result, #OFFSET(p_new_physical_fmd));
                        p_new_physical_fmd := NIL;
                      IFEND;
                    IFEND;
                  ELSE
                    {
                    { In this case the "new" and "old" parent catalogs are
                    { actually the same catalog since reorganization was not
                    { selected. We are deleting the catalog from the old parent.
                    {
                    osp$prevalidate_free ((#OFFSET(p_old_physical_fmd) -
                          #OFFSET(^p_new_parent_catalog_file^.catalog_heap) - 16),
                          ^p_new_parent_catalog_file^.catalog_heap, prevalidate_free_result);
                    IF prevalidate_free_result = osc$heap_free_valid THEN
                      FREE p_old_physical_fmd IN p_new_parent_catalog_file^.catalog_heap;
                    ELSE
                      pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'FILE_MEDIA_DESCRIPTOR',
                            'catalog', prevalidate_free_result, #OFFSET(p_old_physical_fmd));
                      p_old_physical_fmd := NIL;
                    IFEND;
                  IFEND;
                  IF NOT (pfc$delete_unreconciled_objects IN set_overhaul_choices) THEN
                    dmp$destroy_permanent_file (new_catalog_locator.global_file_name,
                          p_old_physical_fmd^.fmd, local_status);
                    out_of_space := out_of_space AND NOT local_status.normal;
                  IFEND;

                  IF pfc$recover_purged_files IN set_overhaul_choices THEN
                    PUSH p_fs_path;
                    pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
                    STRINGREP (text.value, text.size, 'Purged catalog ', p_fs_path^ (1, fs_path_size),
                          ' deleted.');
                    pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin,
                          {critical_message} FALSE, status);
                    pfv$purged_catalogs_deleted := pfv$purged_catalogs_deleted + 1;
                  IFEND;

                  IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
                    scratch_segment_pointer.kind := amc$cell_pointer;
                    scratch_segment_pointer.cell_pointer := new_catalog_locator.p_catalog_file;
                    mmp$delete_scratch_segment (scratch_segment_pointer, local_status);
                    pfp$process_unexpected_status (local_status);
                  IFEND;
                IFEND;
              ELSEIF pfc$reconcile_fmds IN set_overhaul_choices THEN
                IF (status.normal OR (status.condition = pfe$recovery_summary)) AND
                      (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
                  mmp$get_segment_length (new_catalog_locator.p_catalog_file, validation_ring,
                        catalog_segment_length, getsl_allfs_status);
                  IF getsl_allfs_status.normal THEN
                    dmp$allocate_file_space_r1 (old_catalog_locator.system_file_id, byte_address,
                          catalog_segment_length, chapter, osc$nowait, sfc$no_limit, getsl_allfs_status);
                    IF (NOT getsl_allfs_status.normal) AND
                          ((getsl_allfs_status.condition = dme$unable_to_alloc_all_space) OR
                          (getsl_allfs_status.condition = dme$volume_unavailable) OR
                          (getsl_allfs_status.condition = dme$some_volumes_not_online)) AND
                          NOT out_of_space THEN
                      {
                      { The MAT may be out of space.  Allow it a chance to be
                      { refilled from the DAT and try again.
                      {
                      pmp$delay (1000 {1 second}, local_status);
                      dmp$allocate_file_space_r1 (old_catalog_locator.system_file_id, byte_address,
                            catalog_segment_length, chapter, osc$nowait, sfc$no_limit, getsl_allfs_status);
                      IF (NOT getsl_allfs_status.normal) AND
                            ((getsl_allfs_status.condition = dme$unable_to_alloc_all_space) OR
                            (getsl_allfs_status.condition = dme$volume_unavailable) OR
                            (getsl_allfs_status.condition = dme$some_volumes_not_online)) THEN
                        {
                        { Allow the logger a chance to run and try again.
                        {
                        pmp$delay (90000 {1.5 minutes}, local_status);
                        dmp$allocate_file_space_r1 (old_catalog_locator.system_file_id, byte_address,
                              catalog_segment_length, chapter, osc$nowait, sfc$no_limit, getsl_allfs_status);
                        out_of_space := (NOT getsl_allfs_status.normal) AND
                              ((getsl_allfs_status.condition = dme$unable_to_alloc_all_space) OR
                              (getsl_allfs_status.condition = dme$volume_unavailable) OR
                              (getsl_allfs_status.condition = dme$some_volumes_not_online));
                      IFEND;
                    IFEND;

                    IF getsl_allfs_status.normal THEN
                      {
                      { Rewrite the "old" catalog with the reorganized, scratch
                      { catalog.
                      {
                      mmp$set_segment_length (old_catalog_locator.p_catalog_file, validation_ring,
                             {segment_length} 0, local_status);
                      i#move (new_catalog_locator.p_catalog_file, old_catalog_locator.p_catalog_file,
                            catalog_segment_length);
                    ELSE
                      pfp$log_error (getsl_allfs_status, ascii_logset, message_origin, critical_message);
                      pfp$log_ascii ('Previous error from dmp$allocate_file_space_r1.', ascii_logset,
                            message_origin, critical_message, local_status);
                      revert_to_old_catalog;
                    IFEND;
                  ELSE
                    pfp$log_error (getsl_allfs_status, ascii_logset, message_origin, critical_message);
                    pfp$log_ascii ('Previous error from mmp$get_segment_length.', ascii_logset,
                          message_origin, critical_message, local_status);
                    revert_to_old_catalog;
                  IFEND;
                ELSEIF pfc$reorganize_catalogs IN set_overhaul_choices THEN
                  {
                  { Ran out of scratch segment space.
                  {
                  revert_to_old_catalog;
                  getsl_allfs_status.normal := FALSE;
                ELSE
                  mmp$get_segment_length (old_catalog_locator.p_catalog_file, validation_ring,
                        catalog_segment_length, getsl_allfs_status);
                  IF getsl_allfs_status.normal THEN
                    status.normal := status.normal OR (status.condition = pfe$catalog_full);
                  ELSEIF moved_or_destroyed_child THEN
                    {
                    { It is impossible to revert to using the old catalog.
                    {
                    pfp$log_error (getsl_allfs_status, ascii_logset, message_origin, critical_message);
                    pfp$log_ascii ('Previous error from mmp$get_segment_length.', ascii_logset,
                          message_origin, critical_message, local_status);
                    dmp$destroy_permanent_file (new_catalog_locator.global_file_name,
                          p_old_physical_fmd^.fmd, local_status);
                    out_of_space := out_of_space AND NOT local_status.normal;
                    delete_catalog_object (^path, p_new_catalog_object, new_parent_catalog_locator,
                          p_new_permit_list);
                    osp$prevalidate_free ((#OFFSET(p_old_physical_fmd) -
                          #OFFSET(^p_new_parent_catalog_file^.catalog_heap) - 16),
                          ^p_new_parent_catalog_file^.catalog_heap, prevalidate_free_result);
                    IF prevalidate_free_result = osc$heap_free_valid THEN
                      FREE p_old_physical_fmd IN p_new_parent_catalog_file^.catalog_heap;
                    ELSE
                      pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'FILE_MEDIA_DESCRIPTOR',
                            'catalog', prevalidate_free_result, #OFFSET(p_old_physical_fmd));
                      p_old_physical_fmd := NIL;
                    IFEND;
                    log_deleted_catalog_object (path, critical_message, status);
                    pfv$overhaul_errors := pfv$overhaul_errors + 1;
                    moved_or_destroyed_catalog := TRUE;
                  ELSE
                    pfp$log_error (getsl_allfs_status, ascii_logset, message_origin,
                          {critical_message} FALSE);
                    pfp$log_ascii ('Previous error from mmp$get_segment_length.', ascii_logset,
                          message_origin, {critical_message} FALSE, local_status);
                    PUSH p_fs_path;
                    pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
                    STRINGREP (text.value, text.size, 'Reverting to unmodified version of catalog ',
                          p_fs_path^ (1, fs_path_size), '.');
                    pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin,
                          {critical_message} FALSE, local_status);
                  IFEND;
                IFEND;

                IF getsl_allfs_status.normal THEN
                  {
                  { Force the "new" catalog to be written to disk now.
                  {
                  write_modified_catalog (set_overhaul_choices, path, resides_on_system_device,
                        mass_storage_classes, catalog_segment_length, reconcile_locator,
                        ^p_old_physical_fmd^.fmd, authority, p_new_parent_catalog_file, p_new_catalog_object,
                        p_new_physical_fmd, old_catalog_locator, moved_or_destroyed_catalog, local_status);
                  IF NOT local_status.normal THEN
                    {
                    { It is impossible to revert to using the old catalog.
                    {
                    dmp$destroy_permanent_file (new_catalog_locator.global_file_name,
                          p_old_physical_fmd^.fmd, local_status);
                    out_of_space := out_of_space AND NOT local_status.normal;
                    delete_catalog_object (^path, p_new_catalog_object, new_parent_catalog_locator,
                          p_new_permit_list);
                    IF p_new_physical_fmd <> NIL THEN
                      osp$prevalidate_free ((#OFFSET(p_new_physical_fmd) -
                            #OFFSET(^p_new_parent_catalog_file^.catalog_heap) - 16),
                            ^p_new_parent_catalog_file^.catalog_heap, prevalidate_free_result);
                      IF prevalidate_free_result = osc$heap_free_valid THEN
                        FREE p_new_physical_fmd IN p_new_parent_catalog_file^.catalog_heap;
                      ELSE
                        pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'FILE_MEDIA_DESCRIPTOR',
                              'catalog', prevalidate_free_result, #OFFSET(p_new_physical_fmd));
                        p_new_physical_fmd := NIL;
                      IFEND;
                    IFEND;
                    log_deleted_catalog_object (path, critical_message, status);
                    pfv$overhaul_errors := pfv$overhaul_errors + 1;
                    moved_or_destroyed_catalog := TRUE;
                  IFEND;
                IFEND;

                IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
                  scratch_segment_pointer.kind := amc$cell_pointer;
                  scratch_segment_pointer.cell_pointer := new_catalog_locator.p_catalog_file;
                  mmp$delete_scratch_segment (scratch_segment_pointer, local_status);
                  pfp$process_unexpected_status (local_status);
                IFEND;
              IFEND;

            ELSE { Overhaul_physical_catalog failed.
              IF pfc$reconcile_fmds IN set_overhaul_choices THEN
                IF status.condition <> pfe$bad_catalog_heap THEN
                  delete_catalog_object (^path, p_new_catalog_object, new_parent_catalog_locator,
                        p_new_permit_list);
                  log_deleted_catalog_object (path, critical_message, status);
                IFEND;
              ELSEIF status.condition = pfe$bad_root_catalog_header THEN
                osp$set_status_condition (pfe$recovery_summary, status);
              IFEND;
              pfv$overhaul_errors := pfv$overhaul_errors + 1;
            IFEND;

          ELSE { Osp$verify_heap failed.
            IF NOT previous_reorganization.operator_already_queried THEN
              dpp$put_next_line (dpv$system_core_display,
                    ' Has a deadstart WITH REORGANIZATION been tried since the system was last up?',
                    local_status);
              IF local_status.normal THEN
                dpp$put_next_line (dpv$system_core_display, ' Enter yes or no: ', local_status);
              IFEND;
              IF local_status.normal THEN
                REPEAT
                  dpp$get_next_line (dpv$system_core_display, osc$wait, reply, line_received);
                  IF line_received THEN
                    dpp$put_next_line (dpv$system_core_display, reply, local_status);
                    #TRANSLATE (osv$lower_to_upper, reply, uc_reply);
                    IF (uc_reply = 'Y') OR (uc_reply (1, 3) = 'YES') THEN
                      previous_reorganization.operator_already_queried := TRUE;
                      previous_reorganization.already_attempted := TRUE;
                    ELSEIF (uc_reply = 'N') OR (uc_reply (1, 2) = 'NO') THEN
                      previous_reorganization.operator_already_queried := TRUE;
                      previous_reorganization.already_attempted := FALSE;
                    ELSE
                      dpp$put_next_line (dpv$system_core_display, '--ERROR--  Please enter yes or no: ',
                            local_status);
                    IFEND;
                  ELSE
                    dpp$put_next_line (dpv$system_core_display, reply, local_status);
                    previous_reorganization.operator_already_queried := TRUE;
                    previous_reorganization.already_attempted := FALSE;
                  IFEND;
                UNTIL previous_reorganization.operator_already_queried;
              IFEND;
            IFEND;
            IF previous_reorganization.already_attempted THEN
              pfp$log_ascii ('Bad catalog heap encountered.', ascii_logset, message_origin, critical_message,
                    local_status);
              delete_catalog_object (^path, p_new_catalog_object, new_parent_catalog_locator,
                    p_new_permit_list);
              log_deleted_catalog_object (path, critical_message, status);
              pfv$overhaul_errors := pfv$overhaul_errors + 1;
            ELSE
              PUSH p_fs_path;
              pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_catalog_heap,
                    p_fs_path^ (1, fs_path_size), status);
              pfp$log_ascii ('* * * * * * * * * * * * * * * * * * * * *', ascii_logset, message_origin,
                    {critical_message} FALSE, local_status);
              pfp$log_ascii ('* REDEADSTART using System Core Command:', ascii_logset, message_origin,
                    critical_message, local_status);
              pfp$log_ascii ('* SETSA REORGANIZE_PERMANENT_FILES 1', ascii_logset, message_origin,
                    critical_message, local_status);
              pfp$log_ascii ('* * * * * * * * * * * * * * * * * * * * *', ascii_logset, message_origin,
                    {critical_message} FALSE, local_status);
            IFEND;
          IFEND;

          pfp$return_catalog (old_catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);

        ELSE { Pfp$attach_catalog failed.
          pfp$log_error (status, ascii_logset, message_origin, critical_message);
          IF pfc$reconcile_fmds IN set_overhaul_choices THEN
            delete_catalog_object (^path, p_new_catalog_object, new_parent_catalog_locator,
                  p_new_permit_list);
            log_deleted_catalog_object (path, critical_message, status);
          IFEND;
          pfv$overhaul_errors := pfv$overhaul_errors + 1;
        IFEND;

      ELSE { Overhaul_fmd failed.
        IF pfc$reconcile_fmds IN set_overhaul_choices THEN
          IF p_new_catalog_object^.object_entry.object_type = pfc$purged_catalog_object THEN
            delete_catalog_object (^path, p_new_catalog_object, new_parent_catalog_locator,
                  p_new_permit_list);
            log_deleted_catalog_object (path, {critical_message} FALSE, status);
            pfv$purged_catalogs_deleted := pfv$purged_catalogs_deleted + 1;

          ELSEIF status.condition = dme$some_volumes_not_online THEN
            PUSH p_fs_path;
            pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
            STRINGREP (text.value, text.size, 'Catalog ', p_fs_path^ (1, fs_path_size),
                  ' resides on an off-line device.');
            pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, {critical_message} FALSE,
                  local_status);
            IF pfc$delete_unreconciled_objects IN set_overhaul_choices THEN
              delete_catalog_object (^path, p_new_catalog_object, new_parent_catalog_locator,
                    p_new_permit_list);
              log_deleted_catalog_object (path, {critical_message} FALSE, status);
              pfv$unreconciled_cats_deleted := pfv$unreconciled_cats_deleted + 1;
            ELSE
              IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
                pfp$build_fmd_locator (p_new_physical_fmd, p_new_parent_catalog_file,
                        p_new_catalog_object^.object_entry.catalog_object_locator.fmd_locator);
                pfp$compute_checksum (#LOC (p_new_catalog_object^.object_entry), #SIZE (pft$object_entry),
                        p_new_catalog_object^.checksum);
              IFEND;
              osp$set_status_condition (pfe$recovery_summary, status);
              pfv$catalogs_missing_media := pfv$catalogs_missing_media + 1;
            IFEND;

          ELSEIF (status.condition = dme$volume_unavailable) OR
                (status.condition = ste$master_not_active) THEN
            PUSH p_fs_path;
            pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
            STRINGREP (text.value, text.size, 'Catalog ', p_fs_path^ (1, fs_path_size),
                  ' resides on an unavailable device.');
            pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, {critical_message} FALSE,
                  local_status);
            osp$set_status_condition (pfe$recovery_summary, status);
            IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
              pfp$build_fmd_locator (p_new_physical_fmd, p_new_parent_catalog_file,
                      p_new_catalog_object^.object_entry.catalog_object_locator.fmd_locator);
              pfp$compute_checksum (#LOC (p_new_catalog_object^.object_entry), #SIZE (pft$object_entry),
                      p_new_catalog_object^.checksum);
            IFEND;

          ELSEIF status.condition = ste$vol_not_found THEN
            PUSH p_fs_path;
            pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
            STRINGREP (text.value, text.size, 'Catalog ', p_fs_path^ (1, fs_path_size),
                  ' resides on a volume which is not a member of any set.');
            pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, {critical_message} FALSE,
                  local_status);
            IF pfc$delete_unreconciled_objects IN set_overhaul_choices THEN
              delete_catalog_object (^path, p_new_catalog_object, new_parent_catalog_locator,
                    p_new_permit_list);
              log_deleted_catalog_object (path, {critical_message} FALSE, status);
              pfv$unreconciled_cats_deleted := pfv$unreconciled_cats_deleted + 1;
            ELSE
              IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
                pfp$build_fmd_locator (p_new_physical_fmd, p_new_parent_catalog_file,
                        p_new_catalog_object^.object_entry.catalog_object_locator.fmd_locator);
                pfp$compute_checksum (#LOC (p_new_catalog_object^.object_entry), #SIZE (pft$object_entry),
                        p_new_catalog_object^.checksum);
              IFEND;
              osp$set_status_condition (pfe$recovery_summary, status);
              pfv$catalogs_not_in_set := pfv$catalogs_not_in_set + 1;
            IFEND;

          ELSEIF pfc$delete_unreconciled_objects IN set_overhaul_choices THEN
            delete_catalog_object (^path, p_new_catalog_object, new_parent_catalog_locator,
                  p_new_permit_list);
            log_deleted_catalog_object (path, {critical_message} FALSE, status);
            pfv$unreconciled_cats_deleted := pfv$unreconciled_cats_deleted + 1;

          ELSEIF pfc$reorganize_catalogs IN set_overhaul_choices THEN
            pfp$build_fmd_locator (p_new_physical_fmd, p_new_parent_catalog_file,
                    p_new_catalog_object^.object_entry.catalog_object_locator.fmd_locator);
            pfp$compute_checksum (#LOC (p_new_catalog_object^.object_entry), #SIZE (pft$object_entry),
                    p_new_catalog_object^.checksum);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND overhaul_external_catalog;

?? TITLE := '  overhaul_file_cycle', EJECT ??

  PROCEDURE overhaul_file_cycle
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
         reconcile_locator: dmt$reconcile_locator;
         purge_cycle: boolean;
         p_old_catalog_file: {input^} ^pft$catalog_file;
         p_new_catalog_file: {i^/o^} ^pft$catalog_file;
         p_cycle: {i^/o^} ^pft$physical_cycle;
     VAR cycle_destroyed: {i/o} boolean;
     VAR empty_cycle_list: {i/o} boolean;
     VAR normal_or_recovered_cycles: {i/o} boolean;
     VAR status: ost$status);

    VAR
      catalog_or_cycle: pft$catalog_or_cycle,
      device_class: rmt$device_class,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      initial_attach_status: [oss$job_paged_literal, READ] pft$attach_status :=
            [0, [REP 5 of 0], [REP 5 of 0]],
      local_status: ost$status,
      mass_storage_classes: dmt$class,
      p_mainframe_usage_list: ^pft$mainframe_usage_list,
      p_new_archive_list: ^pft$archive_list,
      p_new_physical_fmd: ^pft$physical_fmd,
      p_new_stored_file_label: ^pft$physical_file_label,
      p_old_archive_list: ^pft$archive_list,
      p_old_physical_fmd: ^pft$physical_fmd,
      p_old_stored_file_label: ^pft$physical_file_label,
      path_index: pft$catalog_path_index,
      prevalidate_free_result: ost$prevalidate_free_result,
      resides_on_system_device: boolean,
      text: pft$string,
      unreconciled_file: boolean,
      valid_archive_entry_exists: boolean;

?? OLDTITLE ??
?? NEWTITLE := '  delete_cycle_and_log_deletion', EJECT ??

    PROCEDURE delete_cycle_and_log_deletion;

      IF purge_cycle THEN
        STRINGREP (text.value, text.size, 'Purged cycle ', fs_path (1, fs_path_size),
              p_cycle^.cycle_entry.cycle_number, ' deleted.');
        text.value (14 + fs_path_size) := '.';
      ELSE
        STRINGREP (text.value, text.size, 'Cycle ', fs_path (1, fs_path_size),
              p_cycle^.cycle_entry.cycle_number, ' deleted.');
        text.value (7 + fs_path_size) := '.';
        pfv$unreconciled_cycles_deleted := pfv$unreconciled_cycles_deleted + 1;
        osp$set_status_condition (pfe$recovery_summary, status);
      IFEND;
      p_cycle^.cycle_entry.entry_type := pfc$free_cycle_entry;
      pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
      pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, {critical_message} FALSE,
            local_status);
    PROCEND delete_cycle_and_log_deletion;

?? OLDTITLE ??
?? NEWTITLE := '  delete_fmd_and_file_label', EJECT ??

    PROCEDURE delete_fmd_and_file_label;

      {
      { The fmd and file label still exist in the catalog. (They will not
      { have been allocated in the new catalog when reorganizing.)
      {
      IF p_new_physical_fmd = NIL THEN
        osp$prevalidate_free ((#OFFSET(p_old_physical_fmd) -
              #OFFSET(^p_old_catalog_file^.catalog_heap) - 16),
              ^p_old_catalog_file^.catalog_heap, prevalidate_free_result);
        IF prevalidate_free_result = osc$heap_free_valid THEN
          FREE p_old_physical_fmd IN p_old_catalog_file^.catalog_heap;
        ELSE
          pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'FILE_MEDIA_DESCRIPTOR',
                'file', prevalidate_free_result, #OFFSET(p_old_physical_fmd));
          p_old_physical_fmd := NIL;
        IFEND;
      ELSE
        osp$prevalidate_free ((#OFFSET(p_new_physical_fmd) -
              #OFFSET(^p_old_catalog_file^.catalog_heap) - 16),
              ^p_old_catalog_file^.catalog_heap, prevalidate_free_result);
        IF prevalidate_free_result = osc$heap_free_valid THEN
          FREE p_new_physical_fmd IN p_old_catalog_file^.catalog_heap;
        ELSE
          pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'FILE_MEDIA_DESCRIPTOR',
                'file', prevalidate_free_result, #OFFSET(p_new_physical_fmd));
          p_new_physical_fmd := NIL;
        IFEND;
      IFEND;
      pfp$build_file_label_pointer (p_cycle^.cycle_entry.file_label_locator, p_old_catalog_file,
            p_old_stored_file_label);
      IF p_old_stored_file_label <> NIL THEN
        osp$prevalidate_free ((#OFFSET(p_old_stored_file_label) -
              #OFFSET(^p_old_catalog_file^.catalog_heap) - 16),
              ^p_old_catalog_file^.catalog_heap, prevalidate_free_result);
        IF prevalidate_free_result = osc$heap_free_valid THEN
          FREE p_old_stored_file_label IN p_old_catalog_file^.catalog_heap;
        ELSE
          pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'FILE_LABEL', 'file',
                prevalidate_free_result, #OFFSET(p_old_stored_file_label));
          p_old_stored_file_label := NIL;
        IFEND;
      IFEND;
    PROCEND delete_fmd_and_file_label;

?? OLDTITLE ??
?? NEWTITLE := '  relese_cycle', EJECT ??

    PROCEDURE release_cycle;

      VAR
        archive_index: pft$archive_index,
        comparison_result: pmt$comparison_result,
        release_date_time: ost$date_time;

      p_cycle^.cycle_entry.data_residence := pfc$offline_data;
      p_cycle^.cycle_entry.attach_status := initial_attach_status;
      IF p_new_physical_fmd = NIL THEN
        IF p_old_physical_fmd <> NIL THEN
          osp$prevalidate_free ((#OFFSET(p_old_physical_fmd) -
                #OFFSET(^p_old_catalog_file^.catalog_heap) - 16),
                ^p_old_catalog_file^.catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_old_physical_fmd IN p_old_catalog_file^.catalog_heap;
          ELSE
            pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'FILE_MEDIA_DESCRIPTOR',
                  'file', prevalidate_free_result, #OFFSET(p_old_physical_fmd));
            p_old_physical_fmd := NIL;
          IFEND;
        IFEND;
      ELSE
        osp$prevalidate_free ((#OFFSET(p_new_physical_fmd) -
              #OFFSET(^p_new_catalog_file^.catalog_heap) - 16),
              ^p_new_catalog_file^.catalog_heap, prevalidate_free_result);
        IF prevalidate_free_result = osc$heap_free_valid THEN
          FREE p_new_physical_fmd IN p_new_catalog_file^.catalog_heap;
        ELSE
          pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'FILE_MEDIA_DESCRIPTOR', 'file',
                prevalidate_free_result, #OFFSET(p_new_physical_fmd));
          p_new_physical_fmd := NIL;
        IFEND;
      IFEND;
      p_old_physical_fmd := NIL;

      pfp$build_fmd_locator (p_new_physical_fmd, p_new_catalog_file, p_cycle^.cycle_entry.fmd_locator);
      pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);

      IF p_new_archive_list <> NIL THEN

        pmp$get_compact_date_time (release_date_time, local_status);
      /set_release_date_time/
        FOR archive_index := 1 TO UPPERBOUND (p_new_archive_list^) DO
          pmp$date_time_compare (p_new_archive_list^ [archive_index].archive_entry.modification_date_time,
                p_cycle^.cycle_entry.data_modification_date_time, comparison_result, local_status);
          IF NOT local_status.normal THEN
            CYCLE /set_release_date_time/;
          IFEND;

          IF comparison_result = pmc$equal THEN
            p_new_archive_list^ [archive_index].archive_entry.last_release_date_time := release_date_time;
            pfp$compute_checksum (#LOC (p_new_archive_list^ [archive_index].archive_entry),
                  #SIZE (p_new_archive_list^ [archive_index].archive_entry),
                  p_new_archive_list^ [archive_index].checksum);
          IFEND;
        FOREND /set_release_date_time/;
      IFEND;

      STRINGREP (text.value, text.size, 'Cycle ', fs_path (1, fs_path_size),
            p_cycle^.cycle_entry.cycle_number, ' released.');
      text.value (7 + fs_path_size) := '.';
      pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, {critical_message} FALSE,
            local_status);
      pfv$unreconciled_cycle_released := pfv$unreconciled_cycle_released + 1;

    PROCEND release_cycle;

?? OLDTITLE ??
?? NEWTITLE := '  retain_cycle', EJECT ??

    PROCEDURE retain_cycle;

      VAR
        p_parent_catalog_path: ^pft$complete_path;

      ALLOCATE p_new_physical_fmd: [[REP #SIZE (p_old_physical_fmd^.fmd) OF cell]]
            IN p_new_catalog_file^.catalog_heap;
      IF p_new_physical_fmd = NIL THEN
        PUSH p_parent_catalog_path: [1 .. UPPERBOUND (path) - 1];
        FOR path_index := 1 TO UPPERBOUND (path) - 1 DO
          p_parent_catalog_path^ [path_index] := path [path_index];
        FOREND;
        pfp$convert_pf_path_to_fs_path (p_parent_catalog_path^, fs_path, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, fs_path (1, fs_path_size),
              status);
        pfp$log_error (status, ascii_logset, message_origin, critical_message);
      ELSE
        p_cycle^.cycle_entry.attach_status := initial_attach_status;
        p_new_physical_fmd^ := p_old_physical_fmd^;
        pfp$build_fmd_locator (p_new_physical_fmd, p_new_catalog_file, p_cycle^.cycle_entry.fmd_locator);
        pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
        STRINGREP (text.value, text.size, 'Cycle ', fs_path (1, fs_path_size),
              p_cycle^.cycle_entry.cycle_number, ' with archive images for older version retained.');
        text.value (7 + fs_path_size) := '.';
        pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, {critical_message} FALSE,
              local_status);
        pfv$unreconciled_cycle_retained := pfv$unreconciled_cycle_retained + 1;
      IFEND;

    PROCEND retain_cycle;

?? OLDTITLE ??
?? EJECT ??

    {
    { Overhaul the archive list.
    {
    pfp$build_archive_list_pointer (p_cycle^.cycle_entry.archive_list_locator, p_old_catalog_file,
          p_old_archive_list);
    IF p_old_archive_list <> NIL THEN
      overhaul_archive_list (set_overhaul_choices, path, p_cycle^.cycle_entry.cycle_number,
            p_old_catalog_file, p_new_catalog_file, p_old_archive_list, p_new_archive_list, local_status);
      IF NOT local_status.normal THEN
        IF local_status.condition = pfe$catalog_full THEN
          status := local_status;
          RETURN;
        ELSEIF status.normal THEN
          status := local_status;
        IFEND;
      IFEND;
      IF pfc$reconcile_fmds IN set_overhaul_choices THEN
        pfp$build_archive_list_locator (p_new_archive_list, p_new_catalog_file,
              p_cycle^.cycle_entry.archive_list_locator);
        pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
      IFEND;
    IFEND;

    {
    { Overhaul the File Media Descriptor (FMD).
    {
    pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, p_old_catalog_file, p_old_physical_fmd);
    IF p_old_physical_fmd = NIL THEN
      empty_cycle_list := FALSE;
      normal_or_recovered_cycles := TRUE;
      status.normal := TRUE;
    ELSE
      catalog_or_cycle.cycle_specified := TRUE;
      catalog_or_cycle.cycle_number := p_cycle^.cycle_entry.cycle_number;
      IF p_cycle^.cycle_entry.device_information.device_class_defined THEN
        pfp$convert_device_class_to_rm (p_cycle^.cycle_entry.device_information.device_class, device_class);
      ELSE
        device_class := rmc$mass_storage_device;
      IFEND;
      overhaul_fmd (set_overhaul_choices, path, catalog_or_cycle, device_class,
            p_cycle^.cycle_entry.internal_cycle_name, reconcile_locator, purge_cycle,
            ^p_new_catalog_file^.catalog_heap, p_old_physical_fmd, p_new_physical_fmd,
            resides_on_system_device, mass_storage_classes, unreconciled_file, status);

      IF status.normal THEN
        IF pfc$reconcile_fmds IN set_overhaul_choices THEN
          IF purge_cycle THEN
            IF NOT (pfc$delete_unreconciled_objects IN set_overhaul_choices) THEN
              IF device_class = rmc$mass_storage_device THEN
                IF p_new_physical_fmd = NIL THEN
                  dmp$destroy_permanent_file (p_cycle^.cycle_entry.internal_cycle_name,
                        p_old_physical_fmd^.fmd, local_status);
                ELSE
                  dmp$destroy_permanent_file (p_cycle^.cycle_entry.internal_cycle_name,
                        p_new_physical_fmd^.fmd, local_status);
                IFEND;
                IF local_status.normal THEN
                  cycle_destroyed := TRUE;
                  out_of_space := FALSE;
                IFEND;
              ELSEIF device_class = rmc$magnetic_tape_device THEN
                cycle_destroyed := TRUE;
              IFEND;
            IFEND;

            IF NOT (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
              delete_fmd_and_file_label;
            IFEND;
            pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
            delete_cycle_and_log_deletion;
            RETURN;
          ELSE
            IF p_new_physical_fmd <> NIL THEN
              pfp$build_fmd_locator (p_new_physical_fmd, p_new_catalog_file,
                    p_cycle^.cycle_entry.fmd_locator);
              IF (device_class = rmc$mass_storage_device) AND pfp$cycle_attached_for_write (p_cycle) THEN
                update_stale_eoi (^path, p_new_physical_fmd, p_cycle, p_new_catalog_file);
              IFEND;
            IFEND;
            p_cycle^.cycle_entry.attach_status := initial_attach_status;
          IFEND;
        IFEND;
      ELSE
        CASE status.condition OF
        = dme$some_volumes_not_online =
          pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
          STRINGREP (text.value, text.size, 'Cycle ', fs_path (1, fs_path_size),
                p_cycle^.cycle_entry.cycle_number, ' resides on one or more off-line devices.');
          text.value (7 + fs_path_size) := '.';
          pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, {critical_message} FALSE,
                local_status);
          IF pfc$delete_unreconciled_objects IN set_overhaul_choices THEN
            IF (p_old_archive_list <> NIL) AND (p_new_archive_list <> NIL) THEN
              pfp$check_archive_entries (p_new_catalog_file, p_cycle, valid_archive_entry_exists,
                    local_status);
              IF local_status.normal THEN
                IF valid_archive_entry_exists THEN
                  release_cycle;
                ELSE
                  retain_cycle;
                IFEND;
              IFEND;
            ELSE
              IF NOT (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
                delete_fmd_and_file_label;
              IFEND;
              p_cycle^.cycle_entry.entry_type := pfc$free_cycle_entry;
              pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
              pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
              STRINGREP (text.value, text.size, 'Cycle ', fs_path (1, fs_path_size),
                    p_cycle^.cycle_entry.cycle_number, ' deleted.');
              text.value (7 + fs_path_size) := '.';
              pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin,
                    {critical_message} FALSE, local_status);
              pfv$unreconciled_cycles_deleted := pfv$unreconciled_cycles_deleted + 1;
              status.normal := TRUE;
              RETURN;
            IFEND;
          ELSE
            p_cycle^.cycle_entry.attach_status := initial_attach_status;
            pfp$build_fmd_locator (p_new_physical_fmd, p_new_catalog_file, p_cycle^.cycle_entry.fmd_locator);
            pfv$cycles_missing_media := pfv$cycles_missing_media + 1;
          IFEND;

        = pfe$recovery_summary =
          IF unreconciled_file THEN
            delete_fmd_and_file_label;
            pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
            IF (pfc$delete_unreconciled_objects IN set_overhaul_choices) OR purge_cycle THEN
              delete_cycle_and_log_deletion;
              RETURN;
            ELSEIF pfc$reconcile_fmds IN set_overhaul_choices THEN
              p_cycle^.cycle_entry.attach_status := initial_attach_status;
              pfp$build_fmd_locator ({p_new_physical_fmd} NIL, p_new_catalog_file,
                    p_cycle^.cycle_entry.fmd_locator);
              STRINGREP (text.value, text.size, 'Cycle ', fs_path (1, fs_path_size),
                    p_cycle^.cycle_entry.cycle_number,
                    ' data deleted for unreconciled file - recovery without image or system error.');
              text.value (7 + fs_path_size) := '.';
              pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin,
                    {critical_message} FALSE, local_status);
              pfv$unreconciled_cycle_data_del := pfv$unreconciled_cycle_data_del + 1;
            IFEND;
          IFEND;

        = dme$volume_unavailable, ste$master_not_active =
          {
          { This can only occur if the volume went down after volume or set
          { activation, respectively, so the cycle must not be deleted.
          {
          pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
          STRINGREP (text.value, text.size, 'Cycle ', fs_path (1, fs_path_size),
                p_cycle^.cycle_entry.cycle_number, ' resides on one or more unavailable devices.');
          text.value (7 + fs_path_size) := '.';
          pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, {critical_message} FALSE,
                local_status);
          p_cycle^.cycle_entry.attach_status := initial_attach_status;
          pfp$build_fmd_locator (p_new_physical_fmd, p_new_catalog_file, p_cycle^.cycle_entry.fmd_locator);

        = pfe$catalog_full =
          IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
            RETURN;
          ELSE
            status.normal := TRUE;
          IFEND;

        = ste$vol_not_found =
          pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
          STRINGREP (text.value, text.size, 'Cycle ', fs_path (1, fs_path_size),
                p_cycle^.cycle_entry.cycle_number, ' resides on a volume which is not a member of any set.');
          text.value (7 + fs_path_size) := '.';
          pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, {critical_message} FALSE,
                local_status);
          IF pfc$delete_unreconciled_objects IN set_overhaul_choices THEN
            IF NOT (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
              delete_fmd_and_file_label;
            IFEND;
            delete_cycle_and_log_deletion;
            RETURN;
          ELSE
            p_cycle^.cycle_entry.attach_status := initial_attach_status;
            pfp$build_fmd_locator (p_new_physical_fmd, p_new_catalog_file, p_cycle^.cycle_entry.fmd_locator);
            pfv$cycles_not_in_set := pfv$cycles_not_in_set + 1;
          IFEND;

        ELSE
          IF (pfc$delete_unreconciled_objects IN set_overhaul_choices) OR purge_cycle THEN
            IF NOT (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
              delete_fmd_and_file_label;
            IFEND;
            pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
            delete_cycle_and_log_deletion;
            RETURN;
          ELSEIF pfc$reconcile_fmds IN set_overhaul_choices THEN
            p_cycle^.cycle_entry.attach_status := initial_attach_status;
            pfp$build_fmd_locator (p_new_physical_fmd, p_new_catalog_file, p_cycle^.cycle_entry.fmd_locator);
          IFEND;
        CASEND;

        status.normal := TRUE;
      IFEND;

      empty_cycle_list := FALSE;
      normal_or_recovered_cycles := TRUE;
    IFEND;

    {
    { Overhaul the file label.
    {
    pfp$build_file_label_pointer (p_cycle^.cycle_entry.file_label_locator, p_old_catalog_file,
          p_old_stored_file_label);
    IF p_old_stored_file_label <> NIL THEN
      overhaul_file_label (set_overhaul_choices, path, p_cycle^.cycle_entry.cycle_number,
            p_old_stored_file_label, ^p_new_catalog_file^.catalog_heap, p_new_stored_file_label, status);
      IF status.normal THEN
        IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
          pfp$build_file_label_locator (p_new_stored_file_label, p_new_catalog_file,
                p_cycle^.cycle_entry.file_label_locator);
        IFEND;
      ELSEIF status.condition = pfe$catalog_full THEN
        RETURN;
      ELSEIF pfc$reconcile_fmds IN set_overhaul_choices THEN
        pfp$build_file_label_locator (NIL, p_new_catalog_file, p_cycle^.cycle_entry.file_label_locator);
      IFEND;
    IFEND;

    IF pfc$reconcile_fmds IN set_overhaul_choices THEN
      {
      { Remove mainframe usage.
      {
      p_cycle^.cycle_entry.first_mainframe_usage_entry.entry_type := pfc$free_mainframe_entry;
      IF NOT (pfc$reorganize_catalogs IN set_overhaul_choices) AND
            (p_old_catalog_file^.physical_catalog_header.catalog_header.version = pfc$catalog_version) THEN
        {
        { For upward and downward compatibility, only do this if this is the
        { current level of the catalog.
        {
        pfp$build_mainfram_list_pointer (p_cycle^.cycle_entry.mainframe_usage_list_locator,
              p_old_catalog_file, p_mainframe_usage_list);
        IF p_mainframe_usage_list <> NIL THEN
          osp$prevalidate_free ((#OFFSET(p_mainframe_usage_list) -
                #OFFSET(^p_new_catalog_file^.catalog_heap) - 16),
                ^p_new_catalog_file^.catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_mainframe_usage_list IN p_new_catalog_file^.catalog_heap;
          ELSE
            pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'MAINFRAME_USAGE_LIST',
                  'file', prevalidate_free_result, #OFFSET(p_mainframe_usage_list));
            p_mainframe_usage_list := NIL;
          IFEND;
        IFEND;
      IFEND;
      pfp$build_mainfram_list_locator ({p_mainframe_list} NIL, {p_catalog_file} NIL,
            p_cycle^.cycle_entry.mainframe_usage_list_locator);
      pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
    IFEND;
  PROCEND overhaul_file_cycle;

?? TITLE := '  overhaul_file_label', EJECT ??

  PROCEDURE overhaul_file_label
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
         cycle_number: pft$cycle_number;
         p_old_stored_file_label: {input^} ^pft$physical_file_label;
         p_new_catalog_heap: {output^} ^pft$catalog_heap;
     VAR p_new_stored_file_label: ^pft$physical_file_label;
     VAR status: ost$status);

    VAR
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      p_catalog_path: ^pft$complete_path,
      path_index: pft$catalog_path_index;

    IF pfc$validate_files IN set_overhaul_choices THEN
      validate_file_label (path, cycle_number, p_old_stored_file_label, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      status.normal := TRUE;
    IFEND;

    IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
      ALLOCATE p_new_stored_file_label: [[REP (#SIZE (p_old_stored_file_label^.file_label)) OF cell]] IN
            p_new_catalog_heap^;
      IF p_new_stored_file_label <> NIL THEN
        p_new_stored_file_label^ := p_old_stored_file_label^;
      ELSE
        PUSH p_catalog_path: [1 .. UPPERBOUND (path) - 1];
        FOR path_index := 1 TO UPPERBOUND (path) - 1 DO
          p_catalog_path^ [path_index] := path [path_index];
        FOREND;
        pfp$convert_pf_path_to_fs_path (p_catalog_path^, fs_path, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, fs_path (1, fs_path_size),
              status);
        pfp$log_error (status, ascii_logset, message_origin, critical_message);
      IFEND;
    IFEND;
  PROCEND overhaul_file_label;

?? TITLE := '  overhaul_file_object', EJECT ??

  PROCEDURE overhaul_file_object
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
         reconcile_locator: dmt$reconcile_locator;
         p_old_catalog_file: {input^} ^pft$catalog_file;
         p_new_file_object: {i^/o^} ^pft$physical_object;
     VAR new_catalog_locator: {i/o} pft$catalog_locator;
     VAR cycle_destroyed: {i/o} boolean;
     VAR status: ost$status);

    VAR
      empty_cycle_list: boolean,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      normal_or_recovered_cycles: boolean,
      p_cycle_list: ^pft$cycle_list,
      p_log_list: ^pft$log_list,
      p_new_catalog_file: ^pft$catalog_file,
      p_new_catalog_heap: ^pft$catalog_heap,
      p_new_cycle_list: ^pft$cycle_list,
      p_new_log_list: ^pft$log_list,
      p_new_permit_list: ^pft$permit_list,
      p_permit_list: ^pft$permit_list,
      prevalidate_free_result: ost$prevalidate_free_result,
      text: pft$string;


    PROCEDURE delete_file_object;

      IF NOT (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
        pfp$build_log_list_pointer (p_new_file_object^.object_entry.log_list_locator, p_old_catalog_file,
              p_log_list);
      IFEND;

      pfp$update_obj_list_descriptor (p_new_file_object, new_catalog_locator.object_list_descriptor);
      p_new_file_object^.object_entry.object_type := pfc$free_object;
      pfp$compute_checksum (#LOC (p_new_file_object^.object_entry), #SIZE (pft$object_entry),
            p_new_file_object^.checksum);

      IF NOT (pfc$reorganize_catalogs IN set_overhaul_choices) AND (p_log_list <> NIL) THEN
        osp$prevalidate_free ((#OFFSET(p_log_list) - #OFFSET(^p_new_catalog_file^.catalog_heap) - 16),
              ^p_new_catalog_file^.catalog_heap, prevalidate_free_result);
        IF prevalidate_free_result = osc$heap_free_valid THEN
          FREE p_log_list IN p_new_catalog_file^.catalog_heap;
        ELSE
          pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'LOG_LIST', 'file',
                prevalidate_free_result, #OFFSET(p_log_list));
          p_log_list := NIL;
        IFEND;
      IFEND;

      IF p_new_permit_list <> NIL THEN
        osp$prevalidate_free ((#OFFSET(p_new_permit_list) - #OFFSET(p_new_catalog_heap) - 16),
              p_new_catalog_heap, prevalidate_free_result);
        IF prevalidate_free_result = osc$heap_free_valid THEN
          FREE p_new_permit_list IN p_new_catalog_heap^;
        ELSE
          pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'PERMIT_LIST', 'file',
                prevalidate_free_result, #OFFSET(p_new_permit_list));
          p_new_permit_list := NIL;
        IFEND;
      IFEND;
    PROCEND delete_file_object;


    PROCEDURE log_deleted_file_object;

      STRINGREP (text.value, text.size, 'File ', fs_path (1, fs_path_size), ' deleted.');
      pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
    PROCEND log_deleted_file_object;


    p_new_catalog_file := new_catalog_locator.p_catalog_file;
    p_new_catalog_heap := ^p_new_catalog_file^.catalog_heap;
    p_new_permit_list := NIL;

    pfp$build_permit_list_pointer (p_new_file_object^.object_entry.permit_list_locator, p_old_catalog_file,
          p_permit_list);
    IF p_permit_list <> NIL THEN
      overhaul_permit_list (set_overhaul_choices, path, p_new_file_object^.object_entry.object_type,
            p_permit_list, p_new_catalog_heap, p_new_permit_list, status);
      IF pfc$reconcile_fmds IN set_overhaul_choices THEN
        IF status.normal THEN
          pfp$build_permit_list_locator (p_new_permit_list, p_new_catalog_file,
                p_new_file_object^.object_entry.permit_list_locator);
        ELSEIF status.condition = pfe$catalog_full THEN
          RETURN;
        ELSE
          {
          { A permit entry is defective. Remove the file so that unauthorized
          { users may not access the file. (Because permit groups have
          { precedence over catalog/file permit hierarchies, either all
          { permits in the subtree of the highest level, permit containing
          { catalog in the path must be deleted, or all cycles of the file
          { must be deleted. The latter option has been chosen.)
          {
          pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
          delete_file_object;
          log_deleted_file_object;
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    pfp$build_cycle_list_pointer (p_new_file_object^.object_entry.cycle_list_locator, p_old_catalog_file,
          p_cycle_list);
    IF p_cycle_list = NIL THEN
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      STRINGREP (text.value, text.size, 'File ', fs_path (1, fs_path_size), ' has no cycles.');
      pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
      IF pfc$reconcile_fmds IN set_overhaul_choices THEN
        delete_file_object;
        log_deleted_file_object;
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
      IFEND;
      pfv$overhaul_errors := pfv$overhaul_errors + 1;
      RETURN;
    ELSE
      overhaul_cycle_list (set_overhaul_choices, path, reconcile_locator, p_cycle_list, p_old_catalog_file,
            p_new_catalog_file, p_new_catalog_heap, cycle_destroyed, p_new_cycle_list, empty_cycle_list,
            normal_or_recovered_cycles, status);
      IF (NOT status.normal) AND ((status.condition = pfe$catalog_full) OR
            (status.condition = pfe$pf_system_error)) THEN
        RETURN;
      IFEND;
      {
      { The new cycle list contains pointers to items in the old catalog file
      { at this point. The following routines use the cycle entries from the
      { new cycle list, because in the case of reorganization the new cycle
      { list entries are known to be valid.
      {
      IF pfc$reconcile_fmds IN set_overhaul_choices THEN
        pfp$build_cycle_list_locator (p_new_cycle_list, p_new_catalog_file,
              p_new_file_object^.object_entry.cycle_list_locator);
        {
        { Deleted, unreconciled cycle entries; unrecovered, purged cycle
        { entries; and cycle entries with defective file media descriptors
        { have all become free cycle entries. If the cycle list contains only
        { free entries, free the cycle list and delete the file. Log the
        { deletion only if there was a normal cycle residing on an available
        { device or if there was a purged cycle and recovery was chosen.
        {
        IF empty_cycle_list THEN
          osp$prevalidate_free ((#OFFSET(p_new_cycle_list) - #OFFSET(p_new_catalog_heap) - 16),
                p_new_catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_new_cycle_list IN p_new_catalog_heap^;
          ELSE
            pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'CYCLE_LIST', 'file',
                  prevalidate_free_result, #OFFSET(p_new_cycle_list));
            p_new_cycle_list := NIL;
          IFEND;
          delete_file_object;
          IF normal_or_recovered_cycles THEN
            pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
            STRINGREP (text.value, text.size, 'File ', fs_path (1, fs_path_size), ' has no cycles.');
            pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
            log_deleted_file_object;
            pfv$overhaul_errors := pfv$overhaul_errors + 1;
          IFEND;
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    pfp$build_log_list_pointer (p_new_file_object^.object_entry.log_list_locator, p_old_catalog_file,
          p_log_list);
    IF p_log_list <> NIL THEN
      overhaul_log_list (set_overhaul_choices, path, p_log_list, p_new_catalog_heap, p_new_log_list, status);
      {
      { Errors in log entries are not considered serious enough to delete a
      { file.
      {
      IF pfc$reconcile_fmds IN set_overhaul_choices THEN
        status.normal := status.normal OR (status.condition = pfe$catalog_full);
        pfp$build_log_list_locator (p_new_log_list, p_new_catalog_file,
              p_new_file_object^.object_entry.log_list_locator);
      ELSE
        RETURN;
      IFEND;
    IFEND;

    IF pfc$reconcile_fmds IN set_overhaul_choices THEN
      pfp$compute_checksum (#LOC (p_new_file_object^.object_entry), #SIZE (pft$object_entry),
            p_new_file_object^.checksum);
    IFEND;
  PROCEND overhaul_file_object;

?? TITLE := '  overhaul_fmd', EJECT ??

  PROCEDURE overhaul_fmd
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
         catalog_or_cycle: pft$catalog_or_cycle;
         device_class: rmt$device_class;
         global_file_name: pft$internal_name;
         reconcile_locator: dmt$reconcile_locator;
         purge_object: boolean;
         p_parent_catalog_heap: {output^} ^pft$catalog_heap;
     VAR p_old_physical_fmd: {i^/o} ^pft$physical_fmd;
     VAR p_new_physical_fmd: ^pft$physical_fmd;
     VAR resides_on_system_device: boolean;
     VAR mass_storage_classes: dmt$class;
     VAR unreconciled_file: boolean;
     VAR status: ost$status);

    VAR
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      global_file_string: ost$name,
      local_status: ost$status,
      p_parent_catalog_path: pft$p_complete_path,
      path_index: pft$catalog_path_index,
      stored_fmd_size: dmt$stored_fmd_size;

    p_new_physical_fmd := NIL;
    unreconciled_file := FALSE;

    IF pfc$validate_files IN set_overhaul_choices THEN
      validate_fmd (path, catalog_or_cycle, p_old_physical_fmd, status);
      IF NOT status.normal THEN
        unreconciled_file := TRUE;
        RETURN;
      IFEND;
    IFEND;

    IF pfc$reconcile_fmds IN set_overhaul_choices THEN
      IF device_class = rmc$mass_storage_device THEN
        {
        { Reconciliation must always be done, even for purged objects.
        {
        dmp$reconcile_fmd (reconcile_locator, global_file_name, p_old_physical_fmd^.fmd, purge_object,
              mass_storage_classes, stored_fmd_size, resides_on_system_device, status);
        IF status.normal THEN
          IF (NOT catalog_or_cycle.cycle_specified) OR purge_object THEN
            RETURN;
          IFEND;
        ELSEIF purge_object AND catalog_or_cycle.cycle_specified AND (status.condition <> dme$update_fmd) THEN
          status.normal := TRUE;
          RETURN;
        ELSE
          CASE status.condition OF
          = dme$update_fmd =
            IF catalog_or_cycle.cycle_specified THEN
              PUSH p_parent_catalog_path: [1 .. UPPERBOUND (path) - 1];
              FOR path_index := 1 TO UPPERBOUND (path) - 1 DO
                p_parent_catalog_path^ [path_index] := path [path_index];
              FOREND;
              update_fmd (set_overhaul_choices, p_parent_catalog_path^, ^catalog_or_cycle.cycle_number,
                    global_file_name, reconcile_locator, stored_fmd_size, purge_object, p_parent_catalog_heap,
                    p_old_physical_fmd, p_new_physical_fmd, status);
            IFEND;
            RETURN;

          = dme$some_volumes_not_online, ste$vol_not_found =
            pfp$log_error (status, ascii_logset, message_origin, {critical_message} FALSE);
            IF (pfc$delete_unreconciled_objects IN set_overhaul_choices) OR purge_object THEN
              RETURN;
            IFEND;

          = dme$volume_unavailable =
            pfp$log_error (status, ascii_logset, message_origin, {critical_message} FALSE);
            IF purge_object THEN
              RETURN;
            IFEND;

          = dme$unknown_file =
            pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
            IF catalog_or_cycle.cycle_specified THEN
              unreconciled_file := TRUE;
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unreconciled_file,
                    fs_path (1, fs_path_size), status);
              pfv$unreconciled_files := pfv$unreconciled_files + 1;
            ELSE
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unreconciled_catalog,
                    fs_path (1, fs_path_size), status);
              pfv$unreconciled_catalogs := pfv$unreconciled_catalogs + 1;
            IFEND;
            pmp$convert_binary_unique_name (global_file_name, global_file_string, local_status);
            osp$append_status_parameter (osc$status_parameter_delimiter, global_file_string, status);
            pfp$log_error (status, ascii_logset, message_origin, {critical_message} FALSE);
            osp$set_status_condition (pfe$recovery_summary, status);
            IF (pfc$delete_unreconciled_objects IN set_overhaul_choices) OR purge_object OR
                  unreconciled_file THEN
              RETURN;
            IFEND;

          ELSE
            IF status.condition = dme$invalid_fmd THEN
              #KEYPOINT (osk$unusual, 0, pfk$invalid_fmd_entry);
            IFEND;
            pfp$log_error (status, ascii_logset, message_origin, critical_message);
            pfp$log_ascii ('Previous error from dmp$reconcile_fmd.', ascii_logset, message_origin,
                  critical_message, local_status);
            osp$set_status_condition (pfe$recovery_summary, status);
            pfv$overhaul_errors := pfv$overhaul_errors + 1;
            IF (pfc$delete_unreconciled_objects IN set_overhaul_choices) OR purge_object THEN
              RETURN;
            IFEND;
          CASEND;
        IFEND;
      ELSE
        status.normal := TRUE;
      IFEND;

      IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
        stored_fmd_size := #SIZE (p_old_physical_fmd^.fmd);
        ALLOCATE p_new_physical_fmd: [[REP stored_fmd_size OF cell]] IN p_parent_catalog_heap^;
        IF p_new_physical_fmd = NIL THEN
          PUSH p_parent_catalog_path: [1 .. UPPERBOUND (path) - 1];
          FOR path_index := 1 TO UPPERBOUND (path) - 1 DO
            p_parent_catalog_path^ [path_index] := path [path_index];
          FOREND;
          pfp$convert_pf_path_to_fs_path (p_parent_catalog_path^, fs_path, fs_path_size);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, fs_path (1, fs_path_size),
                status);
          pfp$log_error (status, ascii_logset, message_origin, critical_message);
        ELSE
          p_new_physical_fmd^ := p_old_physical_fmd^;
        IFEND;
      IFEND;
    ELSE
      status.normal := TRUE;
    IFEND;
  PROCEND overhaul_fmd;

?? TITLE := '  overhaul_internal_catalog', EJECT ??

  PROCEDURE overhaul_internal_catalog
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
         reconcile_locator: dmt$reconcile_locator;
         p_old_parent_catalog_file: {input^} ^pft$catalog_file;
         authority: pft$authority;
         p_new_catalog_object: {i^/o^} ^pft$physical_object;
     VAR new_parent_catalog_locator: pft$catalog_locator;
     VAR moved_or_destroyed_child: {i/o} boolean;
     VAR status: ost$status);

    VAR
      catalog_status: ost$status,
      fs_path_size: fst$path_size,
      internal_catalog_locator: pft$catalog_locator,
      object_list_descriptor: pft$object_list_descriptor,
      p_fs_path: ^fst$path,
      p_new_object_list: ^pft$object_list,
      p_object_list: ^pft$object_list,
      temp_set_overhaul_choices: pft$set_overhaul_choices,
      text: pft$string;

    pfp$build_object_list_pointer (p_new_catalog_object^.object_entry.catalog_object_locator.
          object_list_locator, p_old_parent_catalog_file, p_object_list);
    IF p_object_list <> NIL THEN
      IF (p_new_catalog_object^.object_entry.object_type = pfc$purged_catalog_object) AND
            (pfc$reconcile_fmds IN set_overhaul_choices) THEN
        temp_set_overhaul_choices := set_overhaul_choices -
              $pft$set_overhaul_choices [pfc$recover_purged_files];
      ELSE
        temp_set_overhaul_choices := set_overhaul_choices;
      IFEND;
      internal_catalog_locator := new_parent_catalog_locator;

      object_list_descriptor.p_object_list := p_object_list;
      object_list_descriptor.sorted_object_count := 0;
      object_list_descriptor.free_sorted_object_count := 0;
      object_list_descriptor.catalog_type := pfc$internal_catalog;
      object_list_descriptor.p_parent_catalog := p_new_catalog_object;

      overhaul_catalog_content (temp_set_overhaul_choices, path, reconcile_locator, p_old_parent_catalog_file,
            authority, object_list_descriptor, internal_catalog_locator, moved_or_destroyed_child,
            p_new_object_list, catalog_status);
      IF (p_new_catalog_object^.object_entry.object_type = pfc$purged_catalog_object) AND
            (pfc$reconcile_fmds IN set_overhaul_choices) THEN
        {
        { Purged catalogs are currently unrecoverable, if reconciliation is
        { chosen, because job recovery will be unable to attach the catalog
        { due to its use of the external catalog name.
        {
        pfp$update_obj_list_descriptor (p_new_catalog_object,
              new_parent_catalog_locator.object_list_descriptor);
        p_new_catalog_object^.object_entry.object_type := pfc$free_object;
        pfp$compute_checksum (#LOC (p_new_catalog_object^.object_entry), #SIZE (pft$object_entry),
              p_new_catalog_object^.checksum);
        IF pfc$recover_purged_files IN set_overhaul_choices THEN
          PUSH p_fs_path;
          pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
          STRINGREP (text.value, text.size, 'Purged catalog ', p_fs_path^ (1, fs_path_size), ' deleted.');
          pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, {critical_message} FALSE,
                status);
          pfv$purged_catalogs_deleted := pfv$purged_catalogs_deleted + 1;
        IFEND;
      IFEND;

      IF (catalog_status.normal OR (catalog_status.condition = pfe$recovery_summary)) AND
            (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
        internal_catalog_locator.object_list_descriptor.p_object_list := NIL;
        internal_catalog_locator.object_list_descriptor.catalog_type := pfc$internal_catalog;
        internal_catalog_locator.object_list_descriptor.p_parent_catalog := p_new_catalog_object;
        pfp$update_object_list_locator (^path, p_new_object_list, internal_catalog_locator.p_catalog_file,
              internal_catalog_locator.object_list_descriptor);
      IFEND;

      IF NOT catalog_status.normal THEN
        status := catalog_status;
      IFEND;
    IFEND;
  PROCEND overhaul_internal_catalog;

?? TITLE := '  overhaul_log_list', EJECT ??

  PROCEDURE overhaul_log_list
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
         p_log_list: {i^/o^} ^pft$log_list;
         p_catalog_heap: {output^} ^pft$catalog_heap;
     VAR p_new_log_list: ^pft$log_list;
     VAR status: ost$status);

    VAR
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      high_log_index: pft$log_index,
      log_count: pft$log_count,
      log_index: pft$log_index,
      log_status: ost$status,
      new_log_index: pft$log_index,
      p_catalog_path: ^pft$complete_path,
      physical_log: pft$physical_log,
      path_index: pft$catalog_path_index,
      text: pft$string;

    high_log_index := UPPERBOUND (p_log_list^);

    IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
      log_count := 0;

      FOR log_index := 1 TO high_log_index DO
        IF p_log_list^ [log_index].log_entry.entry_type = pfc$normal_log_entry THEN
          log_count := log_count + 1;
        IFEND;
      FOREND;

      ALLOCATE p_new_log_list: [1 .. log_count] IN p_catalog_heap^;
      IF p_new_log_list = NIL THEN
        PUSH p_catalog_path: [1 .. UPPERBOUND (path) - 1];
        FOR path_index := 1 TO UPPERBOUND (p_catalog_path^) DO
          p_catalog_path^ [path_index] := path [path_index];
        FOREND;
        pfp$convert_pf_path_to_fs_path (p_catalog_path^, fs_path, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, fs_path (1, fs_path_size),
              status);
        pfp$log_error (status, ascii_logset, message_origin, {critical_message} FALSE);
      ELSE
        status.normal := TRUE;
      IFEND;
    ELSE
      p_new_log_list := p_log_list;
      status.normal := TRUE;
    IFEND;

    IF status.normal THEN
      new_log_index := 1;

    /overhaul_logs/
      FOR log_index := 1 TO high_log_index DO
        CASE p_log_list^ [log_index].log_entry.entry_type OF
        = pfc$free_log_entry =
          {
          { Do nothing.
          {

        = pfc$normal_log_entry =
          IF pfc$validate_files IN set_overhaul_choices THEN
            validate_log_entry (path, ^p_log_list^ [log_index], log_status);
            IF NOT log_status.normal THEN
              status := log_status;
              IF (pfc$reconcile_fmds IN set_overhaul_choices) AND
                    NOT (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
                p_log_list^ [log_index].log_entry.entry_type := pfc$free_log_entry;
                pfp$compute_checksum (#LOC (p_log_list^ [log_index].log_entry), #SIZE (pft$log_entry),
                      p_log_list^ [log_index].checksum);
              IFEND;
              CYCLE /overhaul_logs/;
            IFEND;
          IFEND;
          IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
            p_new_log_list^ [new_log_index] := p_log_list^ [log_index];
            new_log_index := new_log_index + 1;
          IFEND;

        ELSE
          IF (pfc$reconcile_fmds IN set_overhaul_choices) AND
                NOT (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
            p_log_list^ [log_index].log_entry.entry_type := pfc$free_log_entry;
            pfp$compute_checksum (#LOC (p_log_list^ [log_index].log_entry), #SIZE (pft$log_entry),
                  p_log_list^ [log_index].checksum);
          IFEND;
          pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
          STRINGREP (text.value, text.size, 'Invalid log entry type for file ', fs_path (1, fs_path_size),
                '.');
          pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
          pfv$overhaul_errors := pfv$overhaul_errors + 1;
          #KEYPOINT (osk$unusual, 0, pfk$invalid_log_entry);
        CASEND;
      FOREND /overhaul_logs/;

      IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
        physical_log.log_entry.entry_type := pfc$free_log_entry;
        pfp$compute_checksum (#LOC (physical_log.log_entry), #SIZE (pft$log_entry), physical_log.checksum);
        FOR log_index := new_log_index TO UPPERBOUND (p_new_log_list^) DO
          p_new_log_list^ [log_index] := physical_log;
        FOREND;
      IFEND;
    IFEND;
  PROCEND overhaul_log_list;

?? TITLE := '  overhaul_object_list', EJECT ??

  PROCEDURE overhaul_object_list
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
         old_object_list_descriptor: pft$object_list_descriptor;
         new_catalog_locator: pft$catalog_locator;
     VAR p_new_object_list: ^pft$object_list;
     VAR status: ost$status);

    CONST
      object_expansion_count = 2;

    VAR
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      high_object_index: pft$object_index,
      new_object_index: pft$object_index,
      new_path_index: pft$file_path_index,
      object_count: pft$object_count,
      object_index: pft$object_index,
      object_status: ost$status,
      p_new_path: ^pft$complete_path,
      p_object_list: pft$p_object_list,
      path_index: pft$catalog_path_index,
      physical_object: pft$physical_object,
      text: pft$string;

    p_object_list := old_object_list_descriptor.p_object_list;
    high_object_index := UPPERBOUND (p_object_list^);

    IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
      object_count := 0;
      {
      { Count the number of objects in the object list. To increase
      { performance the objects are not validated during the counting process.
      { If validation has been selected, the objects will be validated prior
      { to moving them to the new object list. If an object is invalid, the
      { object list may contain more free entries than computed during the
      { count process.
      {
      FOR object_index := 1 TO high_object_index DO
        CASE p_object_list^ [object_index].object_entry.object_type OF
        = pfc$free_object =
          {
          { Do nothing.
          {
        = pfc$file_object, pfc$purged_file_object, pfc$catalog_object, pfc$purged_catalog_object =
          object_count := object_count + 1;
        ELSE
          {
          { Do nothing. This error will be processed later.
          {
        CASEND;
      FOREND;

      IF object_count + object_expansion_count < high_object_index THEN
        ALLOCATE p_new_object_list: [1 .. object_count + object_expansion_count] IN
              new_catalog_locator.p_catalog_file^.catalog_heap;
      ELSE
        ALLOCATE p_new_object_list: [1 .. high_object_index] IN
              new_catalog_locator.p_catalog_file^.catalog_heap;
      IFEND;

      IF p_new_object_list = NIL THEN
        pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, fs_path (1, fs_path_size),
              status);
        pfp$log_error (status, ascii_logset, message_origin, critical_message);
      ELSE
        status.normal := TRUE;
      IFEND;
    ELSE
      p_new_object_list := p_object_list;
      status.normal := TRUE;
    IFEND;

    IF status.normal THEN
      new_path_index := UPPERBOUND (path) + 1;
      PUSH p_new_path: [1 .. new_path_index];
      FOR path_index := 1 TO new_path_index - 1 DO
        p_new_path^ [path_index] := path [path_index];
      FOREND;
      new_object_index := 1;

    /overhaul_objects/
      FOR object_index := 1 TO high_object_index DO
        CASE p_object_list^ [object_index].object_entry.object_type OF
        = pfc$free_object =
          {
          { Do nothing.
          {

        = pfc$file_object, pfc$purged_file_object, pfc$catalog_object, pfc$purged_catalog_object =
          IF pfc$validate_files IN set_overhaul_choices THEN
            p_new_path^ [new_path_index] := p_object_list^ [object_index].object_entry.external_object_name;
            validate_object_entry (p_new_path^, ^p_object_list^ [object_index], object_status);
            IF NOT object_status.normal THEN
              status := object_status;
              IF pfc$reconcile_fmds IN set_overhaul_choices THEN
                CASE p_object_list^ [object_index].object_entry.object_type OF
                = pfc$file_object, pfc$purged_file_object =
                  STRINGREP (text.value, text.size, 'File ');
                = pfc$catalog_object, pfc$purged_catalog_object =
                  STRINGREP (text.value, text.size, 'Catalog ');
                ELSE
                  STRINGREP (text.value, text.size, 'Catalog/file ');
                CASEND;
                p_new_path^ [new_path_index] := p_object_list^ [object_index].object_entry.
                      external_object_name;
                IF NOT (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
                  p_object_list^ [object_index].object_entry.object_type := pfc$free_object;
                  pfp$compute_checksum (#LOC (p_object_list^ [object_index].object_entry),
                        #SIZE (pft$object_entry), p_object_list^ [object_index].checksum);
                IFEND;
                pfp$convert_pf_path_to_fs_path (p_new_path^, fs_path, fs_path_size);
                STRINGREP (text.value, text.size, text.value (1, text.size), fs_path (1, fs_path_size),
                      ' deleted.');
                pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message,
                      status);
              IFEND;
              CYCLE /overhaul_objects/;
            IFEND;
          IFEND;
          IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
            p_new_object_list^ [new_object_index] := p_object_list^ [object_index];
            new_object_index := new_object_index + 1;
          IFEND;

        ELSE
          p_new_path^ [new_path_index] := p_object_list^ [object_index].object_entry.external_object_name;
          pfp$convert_pf_path_to_fs_path (p_new_path^, fs_path, fs_path_size);
          IF pfc$reconcile_fmds IN set_overhaul_choices THEN
            IF NOT (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
              p_object_list^ [object_index].object_entry.object_type := pfc$free_object;
              pfp$compute_checksum (#LOC (p_object_list^ [object_index].object_entry),
                    #SIZE (pft$object_entry), p_object_list^ [object_index].checksum);
            IFEND;
            STRINGREP (text.value, text.size, 'Invalid object type; catalog/file ', fs_path (1, fs_path_size),
                  ' deleted.');
          ELSE
            STRINGREP (text.value, text.size, 'Invalid object type for catalog/file ',
                  fs_path (1, fs_path_size), '.');
          IFEND;
          pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
          pfv$overhaul_errors := pfv$overhaul_errors + 1;
          #KEYPOINT (osk$unusual, 0, pfk$invalid_object_entry);
        CASEND;
      FOREND /overhaul_objects/;

      IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
        physical_object.object_entry.object_type := pfc$free_object;
        pfp$compute_checksum (#LOC (physical_object.object_entry), #SIZE (pft$object_entry),
              physical_object.checksum);
        FOR object_index := new_object_index TO UPPERBOUND (p_new_object_list^) DO
          p_new_object_list^ [object_index] := physical_object;
        FOREND;
      IFEND;
    IFEND;
  PROCEND overhaul_object_list;

?? TITLE := '  overhaul_permit_list', EJECT ??

  PROCEDURE overhaul_permit_list
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
         object_type: pft$object_types;
         p_permit_list: {input^} ^pft$permit_list;
         p_catalog_heap: {output^} ^pft$catalog_heap;
     VAR p_new_permit_list: ^pft$permit_list;
     VAR status: ost$status);

    VAR
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      high_permit_index: pft$permit_index,
      new_permit_index: pft$permit_index,
      p_catalog_path: ^pft$complete_path,
      path_index: pft$catalog_path_index,
      permit_count: pft$permit_count,
      permit_index: pft$permit_index,
      physical_permit: pft$physical_permit,
      text: pft$string;

    high_permit_index := UPPERBOUND (p_permit_list^);

    IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
      permit_count := 0;

      FOR permit_index := 1 TO high_permit_index DO
        IF p_permit_list^ [permit_index].permit_entry.entry_type = pfc$normal_permit_entry THEN
          permit_count := permit_count + 1;
        IFEND;
      FOREND;

      IF permit_count = 0 THEN
        p_new_permit_list := NIL;
        status.normal := TRUE;
        RETURN;
      IFEND;

      ALLOCATE p_new_permit_list: [1 .. permit_count] IN p_catalog_heap^;
      IF p_new_permit_list = NIL THEN
        IF object_type IN $pft$object_selections [pfc$catalog_object, pfc$purged_catalog_object] THEN
          pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
        ELSE
          PUSH p_catalog_path: [1 .. UPPERBOUND (path) - 1];
          FOR path_index := 1 TO UPPERBOUND (p_catalog_path^) DO
            p_catalog_path^ [path_index] := path [path_index];
          FOREND;
          pfp$convert_pf_path_to_fs_path (p_catalog_path^, fs_path, fs_path_size);
        IFEND;
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, fs_path (1, fs_path_size),
              status);
        pfp$log_error (status, ascii_logset, message_origin, critical_message);
      ELSE
        status.normal := TRUE;
      IFEND;
    ELSE
      p_new_permit_list := p_permit_list;
      status.normal := TRUE;
    IFEND;

    IF status.normal THEN
      new_permit_index := 1;

      FOR permit_index := 1 TO high_permit_index DO
        CASE p_permit_list^ [permit_index].permit_entry.entry_type OF
        = pfc$free_permit_entry =
          {
          { Do nothing.
          {

        = pfc$normal_permit_entry =
          IF pfc$validate_files IN set_overhaul_choices THEN
            validate_permit_entry (path, object_type, ^p_permit_list^ [permit_index], status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
          IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
            p_new_permit_list^ [new_permit_index] := p_permit_list^ [permit_index];
            new_permit_index := new_permit_index + 1;
          IFEND;

        ELSE
          CASE object_type OF
          = pfc$file_object, pfc$purged_file_object =
            STRINGREP (text.value, text.size, 'Invalid permit entry type for file ');
          = pfc$catalog_object, pfc$purged_catalog_object =
            STRINGREP (text.value, text.size, 'Invalid permit entry type for catalog ');
          ELSE
            STRINGREP (text.value, text.size, 'Invalid permit entry type for catalog/file ');
          CASEND;
          pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
          STRINGREP (text.value, text.size, text.value (1, text.size), fs_path (1, fs_path_size), '.');
          pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
          pfv$overhaul_errors := pfv$overhaul_errors + 1;
          IF pfc$reconcile_fmds IN set_overhaul_choices THEN
            RETURN;
          IFEND;
        CASEND;
      FOREND;

      IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
        physical_permit.permit_entry.entry_type := pfc$free_permit_entry;
        pfp$compute_checksum (#LOC (physical_permit.permit_entry), #SIZE (pft$permit_entry),
              physical_permit.checksum);
        FOR permit_index := new_permit_index TO UPPERBOUND (p_new_permit_list^) DO
          p_new_permit_list^ [permit_index] := physical_permit;
        FOREND;
      IFEND;
    IFEND;
  PROCEND overhaul_permit_list;

?? TITLE := '  overhaul_physical_catalog', EJECT ??

  PROCEDURE overhaul_physical_catalog
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
         reconcile_locator: dmt$reconcile_locator;
         authority: pft$authority;
     VAR old_catalog_locator: {i/o} pft$catalog_locator;
     VAR new_catalog_locator: pft$catalog_locator;
     VAR moved_or_destroyed_child: boolean;
     VAR status: ost$status);

    CONST
      block_exit = TRUE,
      microseconds_per_minute = 1000000 {mics/sec} * 60 {sec/min} ,
      minimum_timestamp_interval = 3 * microseconds_per_minute {3 minutes in microseconds} ,
      maximum_timestamp_interval = 5 * microseconds_per_minute {5 minutes in microseconds} ;

    VAR
      conditions: pmt$condition,
      current_date_time: ost$date_time,
      current_time: ost$time,
      current_timestamp: integer,
      found: boolean,
      fs_path_size: fst$path_size,
      established_handler: pmt$established_handler,
      local_status: ost$status,
      p_fs_path: ^fst$path,
      p_new_object_list: ^pft$object_list,
      scratch_segment_pointer: amt$segment_pointer,
      space_index: 1 .. osc$max_name_size + 1,
      text: pft$string;


    PROCEDURE condition_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      IF (condition.selector = pmc$system_conditions) OR
            (condition.selector = mmc$segment_access_condition) THEN
        osp$set_status_from_condition (pfc$permanent_file_manager_id, condition, p_sfsa, status,
              local_status);
        IF local_status.normal THEN
          pfp$log_error (status, ascii_logset, message_origin,
                (critical_message OR syv$nosve_internal_operations));
        ELSE
          pfp$log_error (local_status, ascii_logset, message_origin,
                (critical_message OR syv$nosve_internal_operations));
          status := local_status;
        IFEND;

        IF syv$nosve_internal_operations THEN
          pfp$log_ascii (
                'Invoking system core debugger, from overhaul_physical_catalog, due to unexpected condition.',
                ascii_logset, message_origin, {critical_message} TRUE, local_status);
          pfp$log_ascii ('Contact PF project.', ascii_logset, message_origin, {critical_message} TRUE,
                local_status);
          syp$invoke_system_debugger ('', 0, local_status);
        IFEND;

        previous_timestamp := #free_running_clock (0);
        EXIT overhaul_physical_catalog;
      ELSE
        {
        { Ignore the condition.
        {
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    PROCEND condition_handler;


    current_timestamp := #free_running_clock (0);
    IF ((UPPERBOUND (path) = pfc$master_catalog_path_index) AND
          (previous_timestamp + minimum_timestamp_interval <= current_timestamp)) OR
          (previous_timestamp + maximum_timestamp_interval <= current_timestamp) THEN
      STRINGREP (text.value, text.size, '    Recovering ');
      IF UPPERBOUND (path) = pfc$master_catalog_path_index THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        STRINGREP (text.value, text.size, text.value (1, text.size), p_fs_path^ (1, fs_path_size), '.');
        previous_master_catalog := path [pfc$master_catalog_path_index];
      ELSE
        #SCAN (pfv$space_character, path [pfc$family_path_index], space_index, found);
        STRINGREP (text.value, text.size, text.value (1, text.size), ':',
              path [pfc$family_path_index] (1, space_index - 1), '.');
        IF UPPERBOUND (path) = pfc$family_path_index THEN
          previous_master_catalog := osc$null_name;
        ELSE
          #SCAN (pfv$space_character, path [pfc$master_catalog_path_index], space_index, found);
          STRINGREP (text.value, text.size, text.value (1, text.size),
                path [pfc$master_catalog_path_index] (1, space_index - 1), '.');
          IF path [pfc$master_catalog_path_index] = previous_master_catalog THEN
            #SCAN (pfv$space_character, path [UPPERBOUND (path)], space_index, found);
            STRINGREP (text.value, text.size, text.value (1, text.size), '..',
                  path [UPPERBOUND (path)] (1, space_index - 1), '.');
          ELSE
            previous_master_catalog := path [pfc$master_catalog_path_index];
          IFEND;
        IFEND;
      IFEND;
      pmp$get_date_time_at_timestamp (current_timestamp, pmc$use_system_local_time, current_date_time,
            local_status);
      IF local_status.normal THEN
        pmp$format_compact_time (current_date_time, osc$hms_time, current_time, local_status);
        IF local_status.normal THEN
          STRINGREP (text.value, text.size, text.value (1, text.size - 1), ' at ', current_time.hms (1, 5),
                '.');
        IFEND;
      IFEND;
      dpp$put_next_line (dpv$system_core_display, text.value (1, text.size), local_status);
      pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, {critical_message} FALSE,
            local_status);
      previous_timestamp := current_timestamp;
    IFEND;

    moved_or_destroyed_child := FALSE;
    osp$establish_condition_handler (^condition_handler, NOT block_exit);

    IF pfc$validate_files IN set_overhaul_choices THEN
      validate_catalog_header (path, ^old_catalog_locator.p_catalog_file^.physical_catalog_header, status);
    ELSE
      status.normal := TRUE;
    IFEND;

    IF status.normal THEN
      IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
        {
        { Create a scratch catalog in which the old catalog data will be
        { reorganized.
        {
        mmp$create_scratch_segment (amc$cell_pointer, mmc$as_random, scratch_segment_pointer, status);
        IF status.normal THEN
          initialize_catalog_locator (old_catalog_locator, scratch_segment_pointer.cell_pointer,
                new_catalog_locator);
        ELSE
          pfp$report_unexpected_status (status);
        IFEND;
      ELSE
        new_catalog_locator := old_catalog_locator;
      IFEND;

      IF status.normal THEN
        IF old_catalog_locator.object_list_descriptor.p_object_list <> NIL THEN
          overhaul_catalog_content (set_overhaul_choices, path, reconcile_locator,
                old_catalog_locator.p_catalog_file, authority, old_catalog_locator.object_list_descriptor,
                new_catalog_locator, moved_or_destroyed_child, p_new_object_list, status);
        ELSE
          p_new_object_list := NIL;
        IFEND;
        IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
          IF status.normal OR (status.condition = pfe$recovery_summary) THEN
            new_catalog_locator.object_list_descriptor.p_object_list := NIL;
            pfp$update_object_list_locator (^path, p_new_object_list, new_catalog_locator.p_catalog_file,
                  new_catalog_locator.object_list_descriptor);
          ELSE
            scratch_segment_pointer.cell_pointer := new_catalog_locator.p_catalog_file;
            mmp$delete_scratch_segment (scratch_segment_pointer, local_status);
            pfp$process_unexpected_status (local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND overhaul_physical_catalog;

?? TITLE := '  overhaul_sorted_object_list', EJECT ??

  PROCEDURE overhaul_sorted_object_list
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
     VAR object_list_descriptor: {i/o} pft$object_list_descriptor;
     VAR new_catalog_locator: pft$catalog_locator;
     VAR p_new_object_list: ^pft$object_list;
     VAR status: ost$status);

    VAR
      fs_path_size: fst$path_size,
      new_path_index: pft$file_path_index,
      object_count: pft$object_count,
      object_index: pft$object_index,
      object_status: ost$status,
      p_fs_path: ^fst$path,
      p_new_path: ^pft$complete_path,
      p_object_list: ^pft$object_list,
      path_index: pft$catalog_path_index,
      sort_object_list: boolean,
      text: pft$string;

    status.normal := TRUE;
    p_object_list := object_list_descriptor.p_object_list;
    sort_object_list := pfv$sort_catalog_object_list;

    new_path_index := UPPERBOUND (path) + 1;
    PUSH p_new_path: [1 .. new_path_index];
    FOR path_index := 1 TO UPPERBOUND (path) DO
      p_new_path^ [path_index] := path [path_index];
    FOREND;
    {
    { Validate each object in the old object list.
    {
    FOR object_index := 1 TO UPPERBOUND (p_object_list^) DO
      CASE p_object_list^ [object_index].object_entry.object_type OF
      = pfc$free_object =
        {
        { Do nothing.
        {

      = pfc$file_object, pfc$purged_file_object, pfc$catalog_object, pfc$purged_catalog_object =
        IF pfc$validate_files IN set_overhaul_choices THEN
          p_new_path^ [new_path_index] := p_object_list^ [object_index].object_entry.external_object_name;
          validate_object_entry (p_new_path^, ^p_object_list^ [object_index], object_status);
          IF NOT object_status.normal THEN
            status := object_status;
            IF pfc$reconcile_fmds IN set_overhaul_choices THEN
              CASE p_object_list^ [object_index].object_entry.object_type OF
              = pfc$file_object, pfc$purged_file_object =
                STRINGREP (text.value, text.size, 'File ');
              = pfc$catalog_object, pfc$purged_catalog_object =
                STRINGREP (text.value, text.size, 'Catalog ');
              ELSE
                STRINGREP (text.value, text.size, 'Catalog/file ');
              CASEND;
              p_object_list^ [object_index].object_entry.object_type := pfc$free_object;
              pfp$compute_checksum (#LOC (p_object_list^ [object_index].object_entry),
                    #SIZE (pft$object_entry), p_object_list^ [object_index].checksum);
              IF object_index <= object_list_descriptor.sorted_object_count THEN
                object_list_descriptor.free_sorted_object_count :=
                      object_list_descriptor.free_sorted_object_count + 1;
              IFEND;
              PUSH p_fs_path;
              pfp$convert_pf_path_to_fs_path (p_new_path^, p_fs_path^, fs_path_size);
              STRINGREP (text.value, text.size, text.value (1, text.size), p_fs_path^ (1, fs_path_size),
                    ' deleted.');
              pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message,
                    status);
            IFEND;
          IFEND;
        IFEND;

      ELSE
        p_new_path^ [new_path_index] := p_object_list^ [object_index].object_entry.external_object_name;
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (p_new_path^, p_fs_path^, fs_path_size);
        IF pfc$reconcile_fmds IN set_overhaul_choices THEN
          p_object_list^ [object_index].object_entry.object_type := pfc$free_object;
          pfp$compute_checksum (#LOC (p_object_list^ [object_index].object_entry),
                #SIZE (pft$object_entry), p_object_list^ [object_index].checksum);
          IF object_index <= object_list_descriptor.sorted_object_count THEN
            object_list_descriptor.free_sorted_object_count :=
                  object_list_descriptor.free_sorted_object_count + 1;
          IFEND;
          STRINGREP (text.value, text.size, 'Invalid object type; catalog/file ',
                p_fs_path^ (1, fs_path_size), ' deleted.');
        ELSE
          STRINGREP (text.value, text.size, 'Invalid object type for catalog/file ',
                p_fs_path^ (1, fs_path_size), '.');
        IFEND;
        pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
        osp$set_status_condition (pfe$recovery_summary, status);
        pfv$overhaul_errors := pfv$overhaul_errors + 1;
        #KEYPOINT (osk$unusual, 0, pfk$invalid_object_entry);
      CASEND;
      {
      { Verify the sorted portion of the object is actually sorted. If it
      { isn't, force sorting to occur.
      {
      IF (object_index > 1) AND (object_index <= object_list_descriptor.sorted_object_count) AND
            (p_object_list^ [object_index].object_entry.external_object_name <
            p_object_list^ [object_index - 1].object_entry.external_object_name) THEN
        sort_object_list := TRUE;
      IFEND;
    FOREND;

    IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
      {
      { Allocate space in the new catalog for the object list; sort the object
      { list, if necessary; and move the objects from the old object list to
      { the new object list.
      {
      ALLOCATE p_new_object_list: [1 .. UPPERBOUND (p_object_list^)] IN
            new_catalog_locator.p_catalog_file^.catalog_heap;
      IF p_new_object_list = NIL THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full,
              p_fs_path^ (1, fs_path_size), status);
        pfp$log_error (status, ascii_logset, message_origin, critical_message);
      ELSE
        status.normal := TRUE;
      IFEND;

      IF sort_object_list OR (object_list_descriptor.sorted_object_count = 0) THEN
        pfp$sort_object_list (p_object_list, p_new_object_list, new_catalog_locator.object_list_descriptor);
      ELSE
        FOR object_index := 1 to UPPERBOUND (p_object_list^) DO
          p_new_object_list^ [object_index] := p_object_list^ [object_index];
        FOREND;

        new_catalog_locator.object_list_descriptor.p_object_list := p_new_object_list;
        new_catalog_locator.object_list_descriptor.sorted_object_count :=
              object_list_descriptor.sorted_object_count;
        new_catalog_locator.object_list_descriptor.free_sorted_object_count :=
              object_list_descriptor.free_sorted_object_count;
      IFEND;
    ELSE
      p_new_object_list := p_object_list;
    IFEND;
  PROCEND overhaul_sorted_object_list;

?? TITLE := '  replace_catalog', EJECT ??

  PROCEDURE replace_catalog
    (    path: pft$complete_path;
         new_catalog_locator: pft$catalog_locator;
         p_parent_catalog_file: {output^} ^pft$catalog_file;
         p_catalog_object: {output^} ^pft$physical_object;
     VAR p_new_physical_fmd: {output} ^pft$physical_fmd;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      p_internal_catalog_name: ^pft$internal_catalog_name,
      p_physical_fmd: ^pft$physical_fmd,
      p_root: ^pft$root,
      p_stored_fmd: ^dmt$stored_fmd,
      p_stored_fmd_size: ^dmt$stored_fmd_size,
      stored_fmd_size: dmt$stored_fmd_size;

    p_new_physical_fmd := NIL;
    IF UPPERBOUND (path) = pfc$set_path_index THEN
      dmp$get_stored_fmd_size (new_catalog_locator.system_file_id, stored_fmd_size, status);
      IF status.normal THEN
        {
        { Update the file media descriptor for the root catalog.
        {
        PUSH p_root: [[REP 1 OF pft$internal_catalog_name, REP 1 OF dmt$stored_fmd_size,
              REP stored_fmd_size OF cell]];
        RESET p_root;
        NEXT p_internal_catalog_name IN p_root;
        p_internal_catalog_name^ := new_catalog_locator.global_file_name;
        NEXT p_stored_fmd_size IN p_root;
        p_stored_fmd_size^ := stored_fmd_size;
        NEXT p_stored_fmd: [[REP stored_fmd_size OF cell]] IN p_root;
        dmp$get_stored_fmd (new_catalog_locator.system_file_id, p_stored_fmd^, status);
        IF status.normal THEN
          {
          { Update Device Management tables to make sure the new catalog
          { structure is permanently recorded before changing the root. This
          { update prevents the loss of any catalogs should the system crash
          { and require recovery without image before periodic update occurs.
          {
          dmp$dev_mgmt_table_update;
          stp$store_pf_root (path [pfc$set_path_index], p_root^, status);
          pfp$process_unexpected_status (status);
        ELSE
          pfp$report_unexpected_status (status);
        IFEND;
      ELSE
        pfp$report_unexpected_status (status);
      IFEND;
    ELSE
      {
      { Update the file media descriptor for a subcatalog in a parent catalog.
      {
      pfp$record_dm_file_parameters (^path, {p_cycle_number} NIL, new_catalog_locator.system_file_id,
            {device_class} rmc$mass_storage_device, {p_removable_media_req_info} NIL,
            {p_volume_list} NIL, ^p_parent_catalog_file^.catalog_heap, p_new_physical_fmd, status);
      IF status.normal THEN
        p_catalog_object^.object_entry.catalog_object_locator.global_file_name :=
              new_catalog_locator.global_file_name;
        pfp$build_fmd_locator (p_new_physical_fmd, p_parent_catalog_file,
              p_catalog_object^.object_entry.catalog_object_locator.fmd_locator);
        pfp$compute_checksum (#LOC (p_catalog_object^.object_entry), #SIZE (pft$object_entry),
              p_catalog_object^.checksum);
      IFEND;
    IFEND;
  PROCEND replace_catalog;

?? TITLE := '  update_fmd', EJECT ??

  PROCEDURE update_fmd
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
         p_cycle_number: ^pft$cycle_number;
         global_file_name: pft$internal_name;
         reconcile_locator: dmt$reconcile_locator;
         new_stored_fmd_size: dmt$stored_fmd_size;
         purge_object: boolean;
         p_catalog_heap: {output^} ^pft$catalog_heap;
     VAR p_old_physical_fmd: {i^/o} ^pft$physical_fmd;
     VAR p_new_physical_fmd: ^pft$physical_fmd;
     VAR status: ost$status);

    VAR
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      prevalidate_free_result: ost$prevalidate_free_result;

    ALLOCATE p_new_physical_fmd: [[REP new_stored_fmd_size OF cell]] IN p_catalog_heap^;
    IF p_new_physical_fmd = NIL THEN
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, fs_path (1, fs_path_size),
            status);
      pfp$log_error (status, ascii_logset, message_origin, critical_message);
    ELSE
      dmp$get_reconciled_fmd (reconcile_locator, global_file_name, p_old_physical_fmd^.fmd,
            p_new_physical_fmd^.fmd, status);
      IF status.normal THEN
        pfp$compute_checksum (#LOC (p_new_physical_fmd^.fmd), #SIZE (p_new_physical_fmd^.fmd),
              p_new_physical_fmd^.checksum);
        IF NOT (pfc$reorganize_catalogs IN set_overhaul_choices) THEN
          {
          { The fmd still exists in the "new" catalog. (It will not have been
          { allocated in the new catalog when reorganizing.)
          {
          osp$prevalidate_free ((#OFFSET(p_old_physical_fmd) - #OFFSET(p_catalog_heap) - 16),
                p_catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_old_physical_fmd IN p_catalog_heap^;
          ELSE
            pfp$report_invalid_free (^path, p_cycle_number, 'FILE_MEDIA_DESCRIPTOR', 'file',
                  prevalidate_free_result, #OFFSET(p_old_physical_fmd));
            p_old_physical_fmd := NIL;
          IFEND;
        IFEND;
      ELSEIF NOT purge_object THEN
        pfp$log_error (status, ascii_logset, message_origin, critical_message);
        pfp$log_ascii ('Previous error from dmp$get_reconciled_fmd.', ascii_logset, message_origin,
              critical_message, status);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
        pfv$overhaul_errors := pfv$overhaul_errors + 1;
      IFEND;
    IFEND;
  PROCEND update_fmd;

?? TITLE := '  update_stale_eoi', EJECT ??

  PROCEDURE update_stale_eoi
    (    p_path: ^pft$complete_path;
         p_physical_fmd: ^pft$physical_fmd;
         p_cycle: ^pft$physical_cycle;
         p_catalog_file: ^pft$catalog_file);

    VAR
      existing_sft_entry: dmt$existing_sft_entry,
      file_damaged: boolean,
      file_info: dmt$file_information,
      fmd_modified: boolean,
      local_status: ost$status,
      system_file_id: gft$system_file_identifier;

    IF (p_physical_fmd = NIL) OR (p_cycle = NIL) OR (p_catalog_file = NIL) THEN
      RETURN;
    IFEND;

    dmp$attach_file (p_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file, p_physical_fmd^.fmd,
          $pft$usage_selections [pfc$read], $pft$share_selections [pfc$read], pfc$average_share_history,
          pfc$maximum_pf_length, {restricted_attach} FALSE, {exit_on_unknown_file} FALSE,
          {server_file} FALSE, mmc$null_shared_queue, file_damaged, system_file_id, existing_sft_entry,
          local_status);

    IF local_status.normal AND (existing_sft_entry = dmc$restricted_attach_entry) THEN
      dmp$attach_file (p_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file,
            p_physical_fmd^.fmd, $pft$usage_selections [pfc$read], $pft$share_selections [pfc$read],
            pfc$average_share_history, pfc$maximum_pf_length, {restricted_attach} TRUE,
            {exit_on_unknown_file} FALSE, {server_file} FALSE, mmc$null_shared_queue, file_damaged,
            system_file_id,  existing_sft_entry, local_status);
    IFEND;

    IF local_status.normal THEN
      p_cycle^.cycle_entry.attach_status.attach_count := 0;
      pfp$update_stale_cycle_entry (system_file_id, p_cycle, local_status);
      pfp$detach_permanent_file (p_path, system_file_id, $pft$usage_selections [pfc$read],
            {catalog_access_allowed} TRUE, p_cycle, p_catalog_file, fmd_modified, file_info, local_status);
    IFEND;
  PROCEND update_stale_eoi;

?? TITLE := '  validate_amd', EJECT ??

  PROCEDURE validate_amd
    (    path: pft$complete_path;
         cycle_number: pft$cycle_number;
         p_amd: pft$p_physical_amd;
     VAR status: ost$status);

    VAR
      checksum: pft$checksum,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      text: pft$string;

    IF p_amd <> NIL THEN
      pfp$compute_checksum (#LOC (p_amd^.amd), #SIZE (p_amd^.amd), checksum);
      IF checksum = p_amd^.checksum THEN
        status.normal := TRUE;
        RETURN;
      IFEND;
    IFEND;

    pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
    STRINGREP (text.value, text.size, 'Invalid archive media descriptor for cycle ',
          fs_path (1, fs_path_size), cycle_number, '.');
    text.value (44 + fs_path_size) := '.';
    pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
    pfp$display_memory_to_log (#LOC (p_amd^.amd), #SIZE (p_amd^.amd));
    osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
    pfv$overhaul_errors := pfv$overhaul_errors + 1;
    #KEYPOINT (osk$unusual, 0, pfk$invalid_amd);
  PROCEND validate_amd;

?? TITLE := '  validate_archive_entry', EJECT ??

  PROCEDURE validate_archive_entry
    (    path: pft$complete_path;
         cycle_number: pft$cycle_number;
         p_archive: pft$p_archive;
     VAR status: ost$status);

    VAR
      checksum: pft$checksum,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      text: pft$string;

    pfp$compute_checksum (#LOC (p_archive^.archive_entry), #SIZE (pft$archive_entry), checksum);
    IF checksum = p_archive^.checksum THEN
      status.normal := TRUE;
    ELSE
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      STRINGREP (text.value, text.size, 'Invalid archive entry for cycle ', fs_path (1, fs_path_size),
            cycle_number, '.');
      text.value (33 + fs_path_size) := '.';
      pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
      pfp$display_memory_to_log (#LOC (p_archive^.archive_entry), #SIZE (pft$archive_entry));
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
      pfv$overhaul_errors := pfv$overhaul_errors + 1;
      #KEYPOINT (osk$unusual, 0, pfk$invalid_archive_entry);
    IFEND;
  PROCEND validate_archive_entry;

?? TITLE := '  validate_catalog_header', EJECT ??

  PROCEDURE validate_catalog_header
    (    path: pft$complete_path;
         p_physical_catalog_header: {input^} ^pft$physical_catalog_header;
     VAR status: ost$status);

    VAR
      checksum: pft$checksum,
      found: boolean,
      fs_path_size: fst$path_size,
      p_fs_path: ^fst$path,
      space_index: 1 .. osc$max_name_size + 1,
      text: pft$string;

    pfp$compute_checksum (#LOC (p_physical_catalog_header^.catalog_header), #SIZE (pft$catalog_header),
          checksum);
    IF checksum = p_physical_catalog_header^.checksum THEN
      status.normal := TRUE;
    ELSE
      IF UPPERBOUND (path) = pfc$set_path_index THEN
        #SCAN (pfv$space_character, path [pfc$set_path_index], space_index, found);
      pfp$display_memory_to_log (#LOC (p_physical_catalog_header^.catalog_header),
            #SIZE (pft$catalog_header));
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_root_catalog_header,
              path [pfc$set_path_index] (1, space_index - 1), status);
      ELSE
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        STRINGREP (text.value, text.size, 'Invalid catalog header for catalog ',
              p_fs_path^ (1, fs_path_size));
        pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
        pfp$display_memory_to_log (#LOC (p_physical_catalog_header^.catalog_header),
               #SIZE (pft$catalog_header));
        {
        { Temporarily set the status to pfe$bad_root_catalog_header;
        { overhaul_external_catalog will map it to pfe$recovery_summary.
        {
        osp$set_status_condition (pfe$bad_root_catalog_header, status);
      IFEND;
      #KEYPOINT (osk$unusual, 0, pfk$invalid_catalog_header);
    IFEND;
  PROCEND validate_catalog_header;

?? TITLE := '  validate_cycle_entry', EJECT ??

  PROCEDURE validate_cycle_entry
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
         p_cycle: {input^} ^pft$physical_cycle;
     VAR status: ost$status);

    VAR
      checksum: pft$checksum,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      text: pft$string;

    pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), checksum);
    IF checksum = p_cycle^.checksum THEN
      status.normal := TRUE;
    ELSE
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      IF (p_cycle^.cycle_entry.entry_type = pfc$normal_cycle_entry) OR
            ((p_cycle^.cycle_entry.entry_type = pfc$purged_cycle_entry) AND
            (pfc$recover_purged_files IN set_overhaul_choices)) THEN
        STRINGREP (text.value, text.size, 'Invalid cycle entry for cycle ', fs_path (1, fs_path_size),
              p_cycle^.cycle_entry.cycle_number);
        text.value (31 + fs_path_size) := '.';
      ELSE
        STRINGREP (text.value, text.size, 'Invalid cycle entry for cycle ', fs_path (1, fs_path_size), '.?');
      IFEND;
      pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
      pfp$display_memory_to_log (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry));
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
      pfv$overhaul_errors := pfv$overhaul_errors + 1;
      #KEYPOINT (osk$unusual, 0, pfk$invalid_cycle_entry);
    IFEND;
  PROCEND validate_cycle_entry;

?? TITLE := '  validate_file_label', EJECT ??

  PROCEDURE validate_file_label
    (    path: pft$complete_path;
         cycle_number: pft$cycle_number;
         p_stored_file_label: {input^} ^pft$physical_file_label;
     VAR status: ost$status);

    VAR
      checksum: pft$checksum,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      text: pft$string;

    pfp$compute_checksum (#LOC (p_stored_file_label^.file_label), #SIZE (p_stored_file_label^.file_label),
          checksum);
    IF checksum = p_stored_file_label^.checksum THEN
      status.normal := TRUE;
    ELSE
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      STRINGREP (text.value, text.size, 'Invalid file label for cycle ', fs_path (1, fs_path_size),
            cycle_number, '.');
      text.value (30 + fs_path_size) := '.';
      pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
      pfp$display_memory_to_log (#LOC (p_stored_file_label^.file_label),
             #SIZE (p_stored_file_label^.file_label));
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
      pfv$overhaul_errors := pfv$overhaul_errors + 1;
      #KEYPOINT (osk$unusual, 0, pfk$invalid_file_label_entry);
    IFEND;
  PROCEND validate_file_label;

?? TITLE := '  validate_fmd', EJECT ??

  PROCEDURE validate_fmd
    (    path: pft$complete_path;
         catalog_or_cycle: pft$catalog_or_cycle;
         p_physical_fmd: {input^} ^pft$physical_fmd;
     VAR status: ost$status);

    VAR
      checksum: pft$checksum,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      text: pft$string;

    pfp$compute_checksum (#LOC (p_physical_fmd^.fmd), #SIZE (p_physical_fmd^.fmd), checksum);
    IF checksum = p_physical_fmd^.checksum THEN
      status.normal := TRUE;
    ELSE
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      IF catalog_or_cycle.cycle_specified THEN
        STRINGREP (text.value, text.size, 'Invalid FMD for cycle ', fs_path (1, fs_path_size),
              catalog_or_cycle.cycle_number, '.');
        text.value (23 + fs_path_size) := '.';
      ELSE
        STRINGREP (text.value, text.size, 'Invalid FMD for catalog ', fs_path (1, fs_path_size), '.');
      IFEND;
      pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
      pfp$display_memory_to_log (#LOC (p_physical_fmd^.fmd), #SIZE (p_physical_fmd^.fmd));
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
      pfv$overhaul_errors := pfv$overhaul_errors + 1;
      #KEYPOINT (osk$unusual, 0, pfk$invalid_fmd_entry);
    IFEND;
  PROCEND validate_fmd;

?? TITLE := '  validate_log_entry', EJECT ??

  PROCEDURE validate_log_entry
    (    path: pft$complete_path;
         p_log: {input^} ^pft$physical_log;
     VAR status: ost$status);

    VAR
      checksum: pft$checksum,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      log_name: fst$path,
      log_path: array [1 .. 3] of pft$name,
      log_size: fst$path_size,
      set_name: stt$set_name,
      text: pft$string;

    pfp$compute_checksum (#LOC (p_log^.log_entry), #SIZE (pft$log_entry), checksum);
    IF checksum = p_log^.checksum THEN
      status.normal := TRUE;
    ELSE
      IF p_log^.log_entry.entry_type = pfc$normal_log_entry THEN
        pfp$get_family_set (p_log^.log_entry.user_id.family, set_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        log_path [1] := set_name;
        log_path [2] := p_log^.log_entry.user_id.family;
        log_path [3] := p_log^.log_entry.user_id.user;
        pfp$convert_pf_path_to_fs_path (log_path, log_name, log_size);
      ELSE
        log_name := '?';
        log_size := 1;
      IFEND;
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      STRINGREP (text.value, text.size, 'Invalid log entry for user ', log_name (1, log_size), ' for file ',
            fs_path (1, fs_path_size));
      pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
      pfp$display_memory_to_log (#LOC (p_log^.log_entry), #SIZE (pft$log_entry));
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
      pfv$overhaul_errors := pfv$overhaul_errors + 1;
      #KEYPOINT (osk$unusual, 0, pfk$invalid_log_entry);
    IFEND;
  PROCEND validate_log_entry;

?? TITLE := '  validate_object_entry', EJECT ??

  PROCEDURE validate_object_entry
    (    path: pft$complete_path;
         p_object: {input^} ^pft$physical_object;
     VAR status: ost$status);

    VAR
      checksum: pft$checksum,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      text: pft$string;

    pfp$compute_checksum (#LOC (p_object^.object_entry), #SIZE (pft$object_entry), checksum);
    IF checksum = p_object^.checksum THEN
      status.normal := TRUE;
    ELSE
      CASE p_object^.object_entry.object_type OF
      = pfc$file_object, pfc$purged_file_object =
        STRINGREP (text.value, text.size, 'Invalid object entry for file ');
      = pfc$catalog_object, pfc$purged_catalog_object =
        STRINGREP (text.value, text.size, 'Invalid object entry for catalog ');
      ELSE
        STRINGREP (text.value, text.size, 'Invalid object entry for catalog/file ');
      CASEND;
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      STRINGREP (text.value, text.size, text.value (1, text.size), fs_path (1, fs_path_size), '.');
      pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
      pfp$display_memory_to_log (#LOC (p_object^.object_entry), #SIZE (pft$object_entry));
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
      pfv$overhaul_errors := pfv$overhaul_errors + 1;
      #KEYPOINT (osk$unusual, 0, pfk$invalid_object_entry);
    IFEND;
  PROCEND validate_object_entry;

?? TITLE := '  validate_overhaul_choices', EJECT ??

  PROCEDURE validate_overhaul_choices
    (    set_overhaul_choices: pft$set_overhaul_choices;
         ownership: pft$ownership;
     VAR new_set_overhaul_choices: pft$set_overhaul_choices;
     VAR status: ost$status);

    IF NOT (pfc$reconcile_fmds IN set_overhaul_choices) THEN
      IF pfc$delete_unreconciled_objects IN set_overhaul_choices THEN
        {
        { By definition, deletion of irreconcilable catalogs and cycles cannot
        { be done without reconciliation.
        {
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$delete_needs_reconcile, '', status);
      ELSEIF pfc$reorganize_catalogs IN set_overhaul_choices THEN
        {
        { Currently reorganization cannot be done without reconciliation,
        { because the file media descriptors cannot be updated without
        { reconciliation.
        {
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$reorganize_needs_reconcile, '', status);
      IFEND;
    ELSEIF pfc$system_owner IN ownership THEN
      new_set_overhaul_choices := set_overhaul_choices;
      status.normal := TRUE;
    ELSEIF pfc$reorganize_catalogs IN set_overhaul_choices THEN
      {
      { If the caller chooses reorganization and is not the system
      { administrator, then recovery of purged files will be performed as well.
      {
      new_set_overhaul_choices := set_overhaul_choices + $pft$set_overhaul_choices [pfc$recover_purged_files];
      status.normal := TRUE;
    ELSEIF set_overhaul_choices <= $pft$set_overhaul_choices [pfc$all_catalogs, pfc$recover_purged_files] THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$no_operation, '', status);
    IFEND;
  PROCEND validate_overhaul_choices;

?? TITLE := '  validate_permit_entry', EJECT ??

  PROCEDURE validate_permit_entry
    (    path: pft$complete_path;
         object_type: pft$object_types;
         p_permit: {input^} ^pft$physical_permit;
     VAR status: ost$status);

    VAR
      checksum: pft$checksum,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      text: pft$string;

    pfp$compute_checksum (#LOC (p_permit^.permit_entry), #SIZE (pft$permit_entry), checksum);
    IF checksum = p_permit^.checksum THEN
      status.normal := TRUE;
    ELSE
      CASE object_type OF
      = pfc$file_object, pfc$purged_file_object =
        STRINGREP (text.value, text.size, 'Invalid permit for file ');
      = pfc$catalog_object, pfc$purged_catalog_object =
        STRINGREP (text.value, text.size, 'Invalid permit for catalog ');
      ELSE
        STRINGREP (text.value, text.size, 'Invalid permit for catalog/file ');
      CASEND;
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      STRINGREP (text.value, text.size, text.value (1, text.size), fs_path (1, fs_path_size), '.');
      pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, critical_message, status);
      pfp$display_memory_to_log (#LOC (p_permit^.permit_entry), #SIZE (pft$permit_entry));
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recovery_summary, '', status);
      pfv$overhaul_errors := pfv$overhaul_errors + 1;
      #KEYPOINT (osk$unusual, 0, pfk$invalid_permit_entry);
    IFEND;
  PROCEND validate_permit_entry;

?? TITLE := '  write_modified_catalog', EJECT ??

  PROCEDURE write_modified_catalog
    (    set_overhaul_choices: pft$set_overhaul_choices;
         path: pft$complete_path;
         resides_on_system_device: boolean;
         mass_storage_classes: dmt$class;
         catalog_segment_length: ost$segment_length;
         reconcile_locator: dmt$reconcile_locator;
         p_catalog_fmd: {input^} ^pft$fmd;
         authority: pft$authority;
         p_parent_catalog_file: {output^} ^pft$catalog_file;
         p_catalog_object: {output^} ^pft$physical_object;
     VAR p_new_physical_fmd: {output} ^pft$physical_fmd;
     VAR old_catalog_locator: {i/o} pft$catalog_locator;
     VAR moved_or_destroyed_catalog: boolean;
     VAR status: ost$status);

    CONST
      byte_address = 0,
      chapter = 0,
      max_attempts = 3,
      purge_catalog = TRUE;

    VAR
      attempt_count: [STATIC] 1 .. max_attempts := 1,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      local_mass_storage_classes: dmt$class,
      local_resides_on_system_device: boolean,
      local_status: ost$status,
      master_info: stt$volume_info,
      member_count: stt$number_of_members,
      member_list: ^stt$volume_list,
      move_catalog: boolean,
      move_root_message: string(61),
      new_catalog_locator: pft$catalog_locator,
      p_mass_storage_request_info: ^fmt$mass_storage_request_info,
      stored_fmd_size: dmt$stored_fmd_size,
      system_catalog: boolean,
      text: pft$string;

    p_new_physical_fmd := NIL;

    IF UPPERBOUND (path) = pfc$set_path_index THEN
      {
      { Just need master vsn.
      {
      PUSH member_list: [1 .. 1];
      stp$get_volumes_in_set (path [pfc$set_path_index], master_info, member_list^, member_count, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      PUSH p_mass_storage_request_info;
      p_mass_storage_request_info^.allocation_size := rmc$unspecified_allocation_size;
      p_mass_storage_request_info^.estimated_file_size := rmc$unspecified_file_size;
      p_mass_storage_request_info^.mass_storage_class := rmc$msc_system_catalogs;
      p_mass_storage_request_info^.initial_volume := master_info.recorded_vsn;
      p_mass_storage_request_info^.maintenance_job := FALSE;
      p_mass_storage_request_info^.transfer_size := rmc$unspecified_transfer_size;
      p_mass_storage_request_info^.user_privilege := rmc$system_user;
      p_mass_storage_request_info^.volume_overflow_allowed := FALSE;

      move_catalog := NOT resides_on_system_device;
      IF move_catalog THEN
        move_root_message (1,54) := 'INFORMATIVE: Moving root catalog to set master volume ';
        move_root_message (55, 6) := master_info.recorded_vsn;
        move_root_message (61, 1) := '.';
        pfp$log_ascii (move_root_message (1,61), ascii_logset, message_origin, critical_message, status);
      IFEND;
      local_resides_on_system_device := TRUE;
      local_mass_storage_classes := mass_storage_classes + $dmt$class [rmc$msc_system_critical_files];
    ELSE
      p_mass_storage_request_info := NIL;
      system_catalog := pfp$system_path (path);
      move_catalog := (system_catalog AND NOT (rmc$msc_system_catalogs IN mass_storage_classes)) OR
            ((NOT system_catalog) AND NOT (rmc$msc_user_catalogs IN mass_storage_classes));
      local_resides_on_system_device := resides_on_system_device;
      local_mass_storage_classes := mass_storage_classes +
            $dmt$class [rmc$msc_system_catalogs, rmc$msc_user_catalogs];
    IFEND;

    IF NOT move_catalog THEN
      mmp$write_modified_pages (old_catalog_locator.p_catalog_file, catalog_segment_length, osc$wait,
            status);
    IFEND;

    IF move_catalog OR ((NOT status.normal) AND (attempt_count < max_attempts)) THEN
      {
      { Create a new catalog and allocate the necessary space.
      {
      pfp$create_catalog (path, p_mass_storage_request_info, authority, {lock_catalog} FALSE,
            new_catalog_locator, status);
      IF status.normal THEN
        dmp$allocate_file_space_r1 (new_catalog_locator.system_file_id, byte_address, catalog_segment_length,
              chapter, osc$nowait, sfc$no_limit, status);
        IF (NOT status.normal) AND ((status.condition = dme$unable_to_alloc_all_space) OR
              (status.condition = dme$volume_unavailable) OR (status.condition = dme$some_volumes_not_online))
              AND NOT out_of_space THEN
          {
          { The MAT may be out of space.  Allow it a chance to be refilled from
          { the DAT and try again.
          {
          pmp$delay (1000 {1 second}, status);
          dmp$allocate_file_space_r1 (new_catalog_locator.system_file_id, byte_address,
                catalog_segment_length, chapter, osc$nowait, sfc$no_limit, status);
          IF (NOT status.normal) AND ((status.condition = dme$unable_to_alloc_all_space) OR
                (status.condition = dme$volume_unavailable) OR
                (status.condition = dme$some_volumes_not_online)) THEN
            {
            { Allow the logger a chance to run and try again.
            {
            pmp$delay (90000 {1.5 minutes}, status);
            dmp$allocate_file_space_r1 (new_catalog_locator.system_file_id, byte_address,
                  catalog_segment_length, chapter, osc$nowait, sfc$no_limit, status);
            out_of_space := (NOT status.normal) AND ((status.condition = dme$unable_to_alloc_all_space) OR
                  (status.condition = dme$volume_unavailable) OR
                  (status.condition = dme$some_volumes_not_online));
          IFEND;
        IFEND;
      IFEND;
      {
      { Copy the reconciled/reorganized catalog to the new catalog and call
      { write_modified_catalog to try again.
      {
      IF status.normal THEN
        i#move (old_catalog_locator.p_catalog_file, new_catalog_locator.p_catalog_file,
              catalog_segment_length);
        IF NOT move_catalog THEN
          attempt_count := attempt_count + 1;
        IFEND;
        write_modified_catalog (set_overhaul_choices, path, local_resides_on_system_device,
              local_mass_storage_classes, catalog_segment_length, reconcile_locator, p_catalog_fmd,
              authority, p_parent_catalog_file, p_catalog_object, p_new_physical_fmd,
              new_catalog_locator, moved_or_destroyed_catalog, status);
        IF NOT move_catalog THEN
          attempt_count := attempt_count - 1;
        IFEND;

        IF status.normal AND (attempt_count = 1) THEN
          replace_catalog (path, new_catalog_locator, p_parent_catalog_file, p_catalog_object,
                p_new_physical_fmd, status);
          IF status.normal THEN
            IF pfc$delete_unreconciled_objects IN set_overhaul_choices THEN
              dmp$reconcile_fmd (reconcile_locator, old_catalog_locator.global_file_name, p_catalog_fmd^,
                    purge_catalog, local_mass_storage_classes, stored_fmd_size,
                    local_resides_on_system_device, local_status);
            ELSE
              dmp$destroy_permanent_file (old_catalog_locator.global_file_name, p_catalog_fmd^,
                    local_status);
            IFEND;

            catalog_moved := TRUE;
            moved_or_destroyed_catalog := TRUE;
            IF move_catalog THEN
              pfv$catalogs_moved := pfv$catalogs_moved + 1;
            IFEND;
          IFEND;
        IFEND;

        IF status.normal THEN
          pfp$return_catalog (old_catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
          old_catalog_locator := new_catalog_locator;
        ELSE
          pfp$destroy_catalog (new_catalog_locator, local_status);
        IFEND;
      ELSE
        IF move_catalog AND (p_mass_storage_request_info <> NIL) THEN
          pfp$log_ascii ('INFORMATIVE: Unable to move root catalog to set master volume.',
                ascii_logset, message_origin, critical_message, status);
          status.normal := TRUE;
        ELSE
          pfp$log_error (status, ascii_logset, message_origin, critical_message);
        IFEND;
      IFEND;
    ELSEIF NOT status.normal THEN
        pfp$log_error (status, ascii_logset, message_origin, critical_message);
    ELSEIF pfc$reorganize_catalogs IN set_overhaul_choices THEN
      {
      { The file media descriptor (fmd) must be allocated in the new, parent
      { catalog. (The fmd still exists in the parent catalog when not
      { reorganizing.)
      {
      replace_catalog (path, old_catalog_locator, p_parent_catalog_file, p_catalog_object,
            p_new_physical_fmd, status);
    IFEND;

    IF (NOT status.normal) AND (attempt_count = 1) THEN
      pfp$log_ascii ('Previous error from write_modified_catalog.', ascii_logset, message_origin,
            critical_message, local_status);
      IF move_catalog THEN
        mmp$write_modified_pages (old_catalog_locator.p_catalog_file, catalog_segment_length, osc$wait,
              status);
        IF status.normal THEN
          IF pfc$reorganize_catalogs IN set_overhaul_choices THEN
            {
            { The file media descriptor (fmd) must be allocated in the new,
            { parent catalog. (The fmd still exists in the parent catalog when
            { not reorganizing.)
            {
            replace_catalog (path, old_catalog_locator, p_parent_catalog_file, p_catalog_object,
                  p_new_physical_fmd, status);
          IFEND;
          IF status.normal THEN
            pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
            STRINGREP (text.value, text.size, 'Unable to move catalog ', fs_path (1, fs_path_size),
                  ' to a catalog device; it will continue to reside on a non catalog device.');
            pfp$log_ascii (text.value (1, text.size), ascii_logset, message_origin, {critical_message} FALSE,
                  local_status);
            pfv$immovable_catalogs := pfv$immovable_catalogs + 1;
          IFEND;
        ELSE
          pfp$log_error (status, ascii_logset, message_origin, critical_message);
          pfp$log_ascii ('Previous error from write_modified_catalog.', ascii_logset, message_origin,
                critical_message, local_status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND write_modified_catalog;

?? OLDTITLE, SKIP := 2 ??
MODEND pfm$catalog_maintenance_manager;
*DECK DECK=PFM$CHANGE_CATALOG_CONTENTS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE pfm$change_catalog_contents;
?? NEWTITLE := 'NOS/VE Permanent Files : CHANGE_CATALOG_CONTENTS Command Processor' ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_parameter_list
*copyc fsc$local
*copyc fse$path_exception_conditions
*copyc fst$file_access_condition
*copyc fst$path_element_index
*copyc oft$display_message
*copyc osd$exception_policies
*copyc osd$integer_limits
*copyc ose$disk_ft_exceptions
*copyc oss$job_paged_literal
*copyc ost$status
*copyc ost$string
*copyc ost$user_identification
*copyc pfc$chacc_help_module_name
*copyc pfe$external_archive_conditions
?? POP ??
?? EJECT ??
*copyc amp$get_next
*copyc amp$return
*copyc amv$nil_file_identifier
*copyc avp$family_administrator
*copyc avp$system_administrator
*copyc clp$build_path_subtitle
*copyc clp$change_variable
*copyc clp$close_display
*copyc clp$convert_data_to_string
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_integer_to_rjstring
*copyc clp$count_list_elements
*copyc clp$create_procedure_variable
*copyc clp$delete_variable
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc clp$get_fs_path_elements
*copyc clp$get_value
*copyc clp$get_work_area
*copyc clp$horizontal_tab_display
*copyc clp$include_file
*copyc clp$make_file_value
*copyc clp$make_list_value
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_data_representation
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$trimmed_string_size
*copyc fsp$change_cycle_damage
*copyc fsp$convert_fs_structure_to_pf
*copyc fsp$open_file
*copyc fsp$path_element
*copyc i#current_sequence_position
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc ofp$display_status_message
*copyc osp$append_status_parameter
*copyc osp$chacc_applicable_policy
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$file_access_condition
*copyc osp$find_access_condition_entry
*copyc osp$find_applicable_policy
*copyc osp$find_help_module
*copyc osp$find_parameter_prompt
*copyc osp$format_help_message
*copyc osp$format_wait_message
*copyc osp$generate_log_message
*copyc osp$get_installed_policies
*copyc osp$get_login_user_criteria
*copyc osp$get_policy
*copyc osp$get_policy_list
*copyc osp$get_relevant_path_string
*copyc osp$get_union_of_policies
*copyc osp$remove_policy
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osv$task_shared_heap
*copyc pfp$check_archive_entries
*copyc pfp$convert_pft$path_to_fs_str
*copyc pfp$convert_pft$path_to_string
*copyc pfp$get_families_in_set
*copyc pfp$get_family_set
*copyc pfp$get_object_information
*copyc pfp$get_volumes_set_name
*copyc pfp$purge
*copyc pfp$r3_change
*copyc pfp$r3_get_object_information
*copyc pfp$r3_release_data
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pmp$get_family_names
*copyc pmp$get_unique_name
*copyc pmp$log_ascii
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    max_damage_string_size = 27,
    max_header_text_size = 7,
    max_exception_string_size = 19,
    max_files_per_command = 100,
    max_message_params = 9,
    minimum_line_size = path_column_number + osc$max_name_size + 3,
    path_column_number = 59,
    retrieve_files_command = 'RETRIEVE_FILES WAIT=NO FILES=(..';

  TYPE
    administrator_types = (family_administrator, system_administrator),

    blank_line_option = (blank_line_before, blank_line_before_and_after, blank_line_after,
          only_template_lines),

    boolean_values = (false_value, true_value),

    catalog_options = (co_all, co_policies, co_list),

    chacc_control_info = record
      criteria: ost$ecp_criteria,
      delete_damage_conditions: array [1 .. 1] of pft$change_descriptor,
      exception_policies: ^ost$ecp_header,
      family_sequence: ^SEQ ( * ),
      master_catalog_sequence: ^SEQ ( * ),
      message_parameters: array [1 .. max_message_params] of ^ost$message_parameter,
      message_templates: array [message_ordinals] of ^ost$message_template,
      object_list: ^chacc_object_list_entry,
      object_stats: chacc_statistics,
      output_info: clt$display_control,
      perform_changes: boolean,
      retrieve_info: chacc_retrieve_info,
      summary_count: ost$non_negative_integers,
      union_of_actions: ost$ecp_actions,
      union_of_policies: ost$ecp_policy_criteria,
    recend,

    chacc_object_list_entry = record
      file_reference: fst$path,
      object_kind: object_kind,
      number_of_path_elements: fst$path_element_index,
      next_object: ^chacc_object_list_entry,
    recend,

    chacc_retrieve_info = record
      display_info: clt$display_control,
      case automatic_retrieval: boolean of
      = TRUE =
        current_command_file_count: ost$non_negative_integers,
        include_file_info: clt$display_control,
        unique_file_name: fst$path,

      = FALSE =
        ,
      casend,
    recend,

    chacc_statistics = record
      busy_damaged_cycles: ost$non_negative_integers,
      damage_cleared: chacc_damage_statistics,
      delete_pending: ost$non_negative_integers,
      deleted: chacc_exception_statistics,
      objects_scanned: chacc_object_statistics,
      release_pending: ost$non_negative_integers,
      released_with_emi: chacc_exception_statistics,
      released_with_eni: chacc_exception_statistics,
    recend,

    chacc_damage_statistics = record
      media_image_inconsistent: ost$non_negative_integers,
      parent_catalog_restored: ost$non_negative_integers,
      respf_modification_mismatch: ost$non_negative_integers,
    recend,

    chacc_exception_statistics = record
      media_missing: ost$non_negative_integers,
      undefined_data: ost$non_negative_integers,
      volume_unavailable: ost$non_negative_integers,
    recend,

    chacc_object_statistics = record
      families: ost$non_negative_integers,
      master_catalogs: ost$non_negative_integers,
      subcatalogs: ost$non_negative_integers,
      files: ost$non_negative_integers,
      cycles: ost$non_negative_integers,
      maximum_catalog_nesting: ost$non_negative_integers,
      maximum_files_per_catalog: ost$non_negative_integers,
      maximum_cycles_per_file: ost$non_negative_integers,
    recend,

    damage_symptoms = (none, media_image_inconsistent, parent_catalog_restored, respf_modification_mismatch),

    exception_conditions = (media_missing, undefined_data, volume_unavailable),

    header_types = (actions, summary),

    message_ordinals = (mt#administrator_notes, mt#all_referenced, mt#applic_exception_policies,
          mt#busy_cycles_deleted, mt#busy_cycles_released, mt#busy_damaged_cycles, mt#cleared_condition,
          mt#conditions_cleared, mt#counts_by_condition, mt#cycle_busy_damage, mt#cycle_busy_delete,
          mt#cycle_busy_release, mt#cycles_deleted, mt#delete_option, mt#deleted_cycle,
          mt#emi_cycles_released, mt#enabled_matching_image, mt#enabled_nonmatching_image,
          mt#eni_cycles_released, mt#header_line, mt#login_users_applicable, mt#modification_dates_and_times,
          mt#no_changes, mt#object_error, mt#object_warning, mt#objects_scanned, mt#parameters, mt#path_part,
          mt#release_option, mt#set_damage_condition, mt#total_cycles_applicable, mt#total_cycles_released,
          mt#totals, mt#undefined_object, mt#unexpected_abnormal_status, mt#user_notes),

    object_kind = (catalog_object, family_object, file_object, set_object, volume_object);

?? OLDTITLE ??
?? NEWTITLE := 'Global Variables Declared by This Module', EJECT ??
?? FMT (FORMAT := OFF) ??
?? EJECT ??
    VAR
      administrator_names: [oss$job_paged_literal, READ] array [administrator_types] OF string (6) := [
            'FAMILY',
            'SYSTEM'],
      boolean_names: [oss$job_paged_literal, READ] array [boolean_values] OF string (5) := [
            'FALSE',
            'TRUE '],

      catalog_option_names: [oss$job_paged_literal, READ] array [catalog_options] OF string (27)
          := [
            'ALL                        ',
            'EXCEPTION_POLICY_REFERENCES',
            '"list of catalogs"         '],

      damage_symptom_names: [oss$job_paged_literal, READ] array [damage_symptoms] OF string
          (max_damage_string_size) := [
            'NONE                       ',
            'MEDIA_IMAGE_INCONSISTENT   ',
            'PARENT_CATALOG_RESTORED    ',
            'RESPF_MODIFICATION_MISMATCH'],

      exception_condition_names: [oss$job_paged_literal, READ] array [exception_conditions] OF string
          (max_exception_string_size) := [
            'MEDIA_MISSING      ',
            'UNDEFINED_DATA     ',
            'VOLUME_UNAVAILABLE '],

      header_text: [oss$job_paged_literal, READ] array [header_types] OF string
          (max_header_text_size) := [
            'Actions',
            'Summary'],

      initial_control_info: [oss$job_paged_literal, READ] chacc_control_info := [
            {criteria} *,
            {delete_damage_conditions} [[pfc$delete_damage_change, $fst$cycle_damage_symptoms[]]],
            {exception_policies} NIL,
            {family_sequence} NIL,
            {master_catalog_sequence} NIL,
            {message_parameters}*,
            {message_templates} *,
            {object_list} NIL,
            {object_stats} *,
            {output_info} *,
            {perform_changes} FALSE,
            {retrieve_info}[
               {retrieve_file_list_info} *,
               {automatic_retrieval} FALSE],
            {summary_count} 0,
            {union_of_actions} $ost$ecp_actions [],
            {union_of_policies} $ost$ecp_policy_criteria []],

      initial_damage_stats: [oss$job_paged_literal, READ] chacc_damage_statistics := [
            {media_image_inconsistent} 0,
            {parent_catalog_restored} 0,
            {respf_modification_mismatch} 0],

      initial_exception_stats: [oss$job_paged_literal, READ] chacc_exception_statistics := [
            {media_missing} 0,
            {undefined_data} 0,
            {volume_unavailable} 0],

      initial_object_stats: [oss$job_paged_literal, READ] chacc_object_statistics := [
            {families} 0,
            {master_catalogs} 0,
            {subcatalogs} 0,
            {files} 0,
            {cycles} 0,
            {maximum_catalog_nesting} 0,
            {maximum_files_per_catalog} 0,
            {maximum_cycles_per_file} 0],

      object_names: [oss$job_paged_literal, READ] array [object_kind] of string (7) :=
           [
            'Catalog',
            'Family ',
            'File   ',
            'Set    ',
            'Volume '],

      parameter_prompt_names: [oss$job_paged_literal, READ] array [message_ordinals] of pmt$program_name :=
           [
            'ADMINISTRATOR_NOTES            ',
            'ALL_REFERENCED                 ',
            'APPLICABLE_EXCEPTION_POLICIES  ',
            'BUSY_CYCLES_DELETED            ',
            'BUSY_CYCLES_RELEASED           ',
            'BUSY_DAMAGED_CYCLES            ',
            'CLEARED_CONDITION              ',
            'CONDITIONS_CLEARED             ',
            'COUNTS_BY_CONDITION            ',
            'CYCLE_BUSY_DAMAGE              ',
            'CYCLE_BUSY_DELETE              ',
            'CYCLE_BUSY_RELEASE             ',
            'CYCLES_DELETED                 ',
            'DELETE_OPTION                  ',
            'DELETED_CYCLE                  ',
            'EMI_CYCLES_RELEASED            ',
            'ENABLED_MATCHING_IMAGE         ',
            'ENABLED_NONMATCHING_IMAGE      ',
            'ENI_CYCLES_RELEASED            ',
            'HEADER_LINE                    ',
            'LOGIN_USERS_APPLICABLE         ',
            'MODIFICATION_DATES_AND_TIMES   ',
            'NO_CHANGES                     ',
            'OBJECT_ERROR                   ',
            'OBJECT_WARNING                 ',
            'OBJECTS_SCANNED                ',
            'PARAMETERS                     ',
            'PATH_PART                      ',
            'RELEASE_OPTION                 ',
            'SET_DAMAGE_CONDITION           ',
            'TOTAL_CYCLES_APPLICABLE        ',
            'TOTAL_CYCLES_RELEASED          ',
            'TOTALS                         ',
            'UNDEFINED_OBJECT               ',
            'UNEXPECTED_ABNORMAL_STATUS     ',
            'USER_NOTES                     '];
?? FMT (FORMAT := ON) ??
?? NEWTITLE := '[XDCL] pfp$change_catalog_contents_cmd ', EJECT ??

  PROCEDURE [XDCL] pfp$change_catalog_contents_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? EJECT ??
{ Design:

{    This module is packaged in task services.  As a result, a new task is
{    not created each time the CHANGE_CATALOG_CONTENTS command is executed.
{    This implies that the command is responsible for closing all of its
{    files.  Thus extensive use of block-exit condition handling is
{    required.

{    Because condition handlers are executed asynchronously with respect to
{    the program, it is necessary for the program to #SPOIL any variable
{    used in both the program and the condition handler each time the
{    variable is updated by an assignment statement within the program.
{    Note that passing the variable as a VAR parameter does an automatic
{    #SPOIL.  This is why variables such as CONTROL_INFO are passed as VAR
{    parameters in most situations.

{    This command is implemented using recursive programming.  The variable
{    CONTROL_INFO contains control information which is common to all levels
{    of nesting within the program.  Do not add fields to this record to
{    define data which is temporary in nature (i.e.  not global to the
{    program); otherwise, the recursive nature of the program will create a
{    problem.

{    The recursion is performed in the procedure CHANGE_CATALOG.  Within
{    this procedure, files are processed first and then catalogs.  If you
{    change the order of processing, you will run into trouble because the
{    PATH information necessary to process cycles is stored in
{    CONTROL_INFO.CRITERIA.FILE which changes as one recurses.

{ Purpose:

{    The purpose of this procedure is to implement the
{    CHANGE_CATALOG_CONTENTS command.  This command is used by both a normal
{    user and FAMILY/SYSTEM administrators.  When a normal user uses this
{    command, he is limited to operating on files for which he has CONTROL
{    permission.  An administrator implicitly has CONTROL permission to
{    all files for which the administrator is responsible.

?? EJECT ??
{ PROCEDURE (osm$chacc) change_catalog_contents, chacc (
{   catalog, catalogs, c: (CHECK) any of
{       key
{         all
{         (exception_policy_references, epr)
{       keyend
{       list of file
{     anyend = exception_policy_references
{   delete_damage_condition, delete_damage_conditions, ddc: list of key
{       (media_image_inconsistent, mii)
{       (parent_catalog_restored, pcr)
{       (respf_modification_mismatch, rmm)
{     keyend = $optional
{   output, o: (BY_NAME) file = $output
{   perform_changes, pc: (BY_NAME) boolean = $confirm true
{   retrieve_files, rf: (BY_NAME) boolean = false
{   retrieve_file_list, rfl: (BY_NAME) file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 15] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] 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 .. 3] 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,
          recend,
        recend,
        default_value: string (27),
      recend,
      type2: 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 .. 6] of clt$keyword_specification,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type5: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 10, 21, 14, 29, 55, 760],
    clc$command, 15, 7, 0, 0, 0, 0, 7, 'OSM$CHACC'], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CATALOG                        ',clc$nominal_entry, 1],
    ['CATALOGS                       ',clc$alias_entry, 1],
    ['DDC                            ',clc$abbreviation_entry, 2],
    ['DELETE_DAMAGE_CONDITION        ',clc$nominal_entry, 2],
    ['DELETE_DAMAGE_CONDITIONS       ',clc$alias_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['PC                             ',clc$abbreviation_entry, 4],
    ['PERFORM_CHANGES                ',clc$nominal_entry, 4],
    ['RETRIEVE_FILES                 ',clc$nominal_entry, 5],
    ['RETRIEVE_FILE_LIST             ',clc$nominal_entry, 6],
    ['RF                             ',clc$abbreviation_entry, 5],
    ['RFL                            ',clc$abbreviation_entry, 6],
    ['STATUS                         ',clc$nominal_entry, 7]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 157,
  clc$optional_default_parameter, 0, 27],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 245,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$confirm_default_parameter, 0, 4],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 7
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['EPR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['EXCEPTION_POLICY_REFERENCES    ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$file_type]]
      ]
    ,
    'exception_policy_references'],
{ PARAMETER 2
    [[1, 0, clc$list_type], [229, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [6], [
      ['MEDIA_IMAGE_INCONSISTENT       ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['MII                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['PARENT_CATALOG_RESTORED        ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['PCR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['RESPF_MODIFICATION_MISMATCH    ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['RMM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 5
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 6
    [[1, 0, clc$file_type]],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$catalog = 1,
      p$delete_damage_condition = 2,
      p$output = 3,
      p$perform_changes = 4,
      p$retrieve_files = 5,
      p$retrieve_file_list = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;


    VAR
      current_object: ^chacc_object_list_entry,
      exception_actions: ost$ecp_actions,
      ignore_status: ost$status,
      control_info: chacc_control_info;

?? NEWTITLE := 'add_one', EJECT ??

    PROCEDURE [INLINE] add_one
      (VAR integer_value {input, output} : ost$non_negative_integers);

      integer_value := integer_value + 1;

    PROCEND add_one;
?? OLDTITLE ??
?? NEWTITLE := 'allocate_catalog_segments', EJECT ??

    PROCEDURE allocate_catalog_segments;

      VAR
        segment_pointer: amt$segment_pointer;

      segment_pointer.kind := amc$sequence_pointer;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
      IF status.normal THEN
        control_info.family_sequence := segment_pointer.sequence_pointer;
        #SPOIL (control_info);

        mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
        IF status.normal THEN
          control_info.master_catalog_sequence := segment_pointer.sequence_pointer;
          #SPOIL (control_info);
        IFEND;
      IFEND;

      IF NOT status.normal THEN
        EXIT pfp$change_catalog_contents_cmd;
      IFEND;
    PROCEND allocate_catalog_segments;
?? OLDTITLE ??
?? NEWTITLE := 'chacc_cmd_block_exit_handler', EJECT ??

    PROCEDURE chacc_cmd_block_exit_handler
      (    condition: pmt$condition;
           ignore_condition_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status,
        segment_pointer: amt$segment_pointer;

      IF control_info.exception_policies <> NIL THEN
        segment_pointer.kind := amc$cell_pointer;
        segment_pointer.cell_pointer := control_info.exception_policies;
        mmp$delete_scratch_segment (segment_pointer, ignore_status);
        control_info.exception_policies := NIL;
        #SPOIL (control_info);
      IFEND;

      IF control_info.family_sequence <> NIL THEN
        segment_pointer.kind := amc$cell_pointer;
        segment_pointer.cell_pointer := control_info.family_sequence;
        mmp$delete_scratch_segment (segment_pointer, ignore_status);
        control_info.family_sequence := NIL;
        #SPOIL (control_info);
      IFEND;

      IF control_info.master_catalog_sequence <> NIL THEN
        segment_pointer.kind := amc$cell_pointer;
        segment_pointer.cell_pointer := control_info.master_catalog_sequence;
        mmp$delete_scratch_segment (segment_pointer, ignore_status);
        control_info.master_catalog_sequence := NIL;
        #SPOIL (control_info);
      IFEND;

      IF control_info.object_list <> NIL THEN
        segment_pointer.kind := amc$cell_pointer;
        segment_pointer.cell_pointer := control_info.object_list;
        mmp$delete_scratch_segment (segment_pointer, ignore_status);
        control_info.object_list := NIL;
        #SPOIL (control_info);
      IFEND;

      IF control_info.output_info.file_id <> amv$nil_file_identifier THEN
        clp$close_display (control_info.output_info, ignore_status);
        control_info.output_info.file_id := amv$nil_file_identifier;
        #SPOIL (control_info);
      IFEND;

      IF control_info.retrieve_info.display_info.file_id <> amv$nil_file_identifier THEN
        clp$close_display (control_info.retrieve_info.display_info, ignore_status);
        control_info.retrieve_info.display_info.file_id := amv$nil_file_identifier;
        #SPOIL (control_info);
      IFEND;

      IF control_info.retrieve_info.automatic_retrieval THEN
        IF control_info.retrieve_info.unique_file_name <> '' THEN
          amp$return (control_info.retrieve_info.unique_file_name, ignore_status);
          control_info.retrieve_info.unique_file_name := '';
          #SPOIL (control_info);
        IFEND;
      IFEND;

    PROCEND chacc_cmd_block_exit_handler;

?? OLDTITLE ??
?? NEWTITLE := 'change_catalog_contents', EJECT ??



    PROCEDURE change_catalog_contents;

      VAR
        current_object: ^chacc_object_list_entry,
        totals: chacc_statistics;

?? NEWTITLE := 'accumulate_statistics', EJECT ??

      PROCEDURE accumulate_statistics;

?? NEWTITLE := 'accumulate_damage_stats', EJECT ??

        PROCEDURE accumulate_damage_stats
          (    add_damaged: chacc_damage_statistics;
           VAR total_damaged: chacc_damage_statistics);

          total_damaged.media_image_inconsistent := total_damaged.media_image_inconsistent +
                add_damaged.media_image_inconsistent;

          total_damaged.parent_catalog_restored := total_damaged.parent_catalog_restored +
                add_damaged.parent_catalog_restored;

          total_damaged.respf_modification_mismatch := total_damaged.respf_modification_mismatch +
                add_damaged.respf_modification_mismatch;

        PROCEND accumulate_damage_stats;
?? OLDTITLE ??
?? NEWTITLE := 'accumulate_exception_stats', EJECT ??

        PROCEDURE accumulate_exception_stats
          (    add_exceptions: chacc_exception_statistics;
           VAR total_exceptions: chacc_exception_statistics);

          total_exceptions.media_missing := total_exceptions.media_missing + add_exceptions.media_missing;

          total_exceptions.undefined_data := total_exceptions.undefined_data + add_exceptions.undefined_data;

          total_exceptions.volume_unavailable := total_exceptions.volume_unavailable +
                add_exceptions.volume_unavailable;

        PROCEND accumulate_exception_stats;
?? OLDTITLE ??
?? NEWTITLE := 'accumulate_objects_scanned', EJECT ??

        PROCEDURE accumulate_objects_scanned
          (    subtotal_scanned: chacc_object_statistics;
           VAR total_scanned: chacc_object_statistics);

          total_scanned.families := total_scanned.families + subtotal_scanned.families;
          total_scanned.master_catalogs := total_scanned.master_catalogs + subtotal_scanned.master_catalogs;
          total_scanned.subcatalogs := total_scanned.subcatalogs + subtotal_scanned.subcatalogs;
          total_scanned.files := total_scanned.files + subtotal_scanned.files;
          total_scanned.cycles := total_scanned.cycles + subtotal_scanned.cycles;

          IF total_scanned.maximum_catalog_nesting < subtotal_scanned.maximum_catalog_nesting THEN
            total_scanned.maximum_catalog_nesting := subtotal_scanned.maximum_catalog_nesting;
          IFEND;

          IF total_scanned.maximum_files_per_catalog < subtotal_scanned.maximum_files_per_catalog THEN
            total_scanned.maximum_files_per_catalog := subtotal_scanned.maximum_files_per_catalog;
          IFEND;

          IF total_scanned.maximum_cycles_per_file < subtotal_scanned.maximum_cycles_per_file THEN
            total_scanned.maximum_cycles_per_file := subtotal_scanned.maximum_cycles_per_file;
          IFEND;

        PROCEND accumulate_objects_scanned;
?? OLDTITLE ??
?? EJECT ??

        totals.busy_damaged_cycles := totals.busy_damaged_cycles +
              control_info.object_stats.busy_damaged_cycles;

        accumulate_damage_stats (control_info.object_stats.damage_cleared, totals.damage_cleared);

        totals.delete_pending := totals.delete_pending + control_info.object_stats.delete_pending;

        accumulate_exception_stats (control_info.object_stats.deleted, totals.deleted);

        accumulate_exception_stats (control_info.object_stats.released_with_emi, totals.released_with_emi);

        accumulate_exception_stats (control_info.object_stats.released_with_eni, totals.released_with_eni);

        totals.release_pending := totals.release_pending + control_info.object_stats.release_pending;

        accumulate_objects_scanned (control_info.object_stats.objects_scanned, totals.objects_scanned);

        #SPOIL (totals);

      PROCEND accumulate_statistics;
?? OLDTITLE ??
?? NEWTITLE := 'build_file_reference ', EJECT ??

      PROCEDURE [INLINE] build_file_reference
        (    input_path: fst$file_reference;
             next_node: pft$name;
         VAR path: string ( * <= fsc$max_path_size);
         VAR path_size: integer);

        STRINGREP (path, path_size, input_path, '.', next_node (1, clp$trimmed_string_size (next_node)));
        path (path_size + 1, * ) := ' ';

      PROCEND build_file_reference;
?? OLDTITLE ??
?? NEWTITLE := 'chacc_block_exit_handler', EJECT ??

      PROCEDURE chacc_block_exit_handler
        (    condition: pmt$condition;
             ignore_condition_information: ^pmt$condition_information;
             ignore_save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);

        VAR
          ignore_status: ost$status,
          segment_pointer: amt$segment_pointer;

        IF control_info.output_info.file_id <> amv$nil_file_identifier THEN
          terminate_chacc ({normal_termination} FALSE);
        IFEND;

      PROCEND chacc_block_exit_handler;

?? OLDTITLE ??
?? NEWTITLE := 'change_catalog ', EJECT ??

      PROCEDURE change_catalog
        (    catalog_reference: ^fst$file_reference;
             catalog_depth: fst$path_element_index;
         VAR control_info: chacc_control_info);

        VAR
          actions: ost$ecp_actions,
          change_index: ost$non_negative_integers,
          cycle_damage_symptoms: fst$cycle_damage_symptoms,
          cycle_entry: ost$non_negative_integers,
          cycle_selector: pft$cycle_selector,
          delete_damage_condition: boolean,
          data_released: boolean,
          file_entry: ost$positive_integers,
          file_access_condition: fst$file_access_condition,
          ignore_status: ost$status,
          include_volume: boolean,
          index: integer,
          object_list: ^fst$goi_object_list,
          path_size: integer,
          p_new_path: ^pft$path,
          p_release_data_info: ^pft$release_data_info;

?? NEWTITLE := 'build_path ', EJECT ??

        PROCEDURE build_path
          (    file: ^fst$file_reference;
           VAR path: ^pft$path);

          VAR
            evaluated_file_reference: fst$evaluated_file_reference;

          clp$evaluate_file_reference (file^, $clt$file_ref_parsing_options [], FALSE,
                evaluated_file_reference, status);

          IF status.normal THEN
            fsp$convert_fs_structure_to_pf (evaluated_file_reference, path);
          ELSE
            EXIT pfp$change_catalog_contents_cmd;
          IFEND;
        PROCEND build_path;

?? OLDTITLE ??
?? NEWTITLE := 'display_file_action', EJECT ??

        PROCEDURE display_file_action
          (    cycle_number: pft$cycle_number,
               message_template: ^ost$message_template;
               text: string ( * <= max_damage_string_size);
           VAR control_info: chacc_control_info);

          VAR
            cycle_string: string (4),
            i: 0 .. fsc$max_path_elements,
            ignore_status: ost$status,
            length: integer,
            local_message_template: ^ost$message_template,
            chunk_count: 0 .. fsc$max_path_elements,
            cycle_reference: fst$path,
            display_chunks: clt$path_display_chunks,
            suffix: string (2);

          initialize_message_parameters;

          cycle_reference := control_info.criteria.file (1, path_size);
          STRINGREP (cycle_string, length, cycle_number);

          IF (path_size + length) <= fsc$max_path_size THEN
            STRINGREP (cycle_reference, length, control_info.criteria.file (1, path_size),
                  cycle_string (1, length));
            cycle_reference (path_size + 1, 1) := '.';
          IFEND;

          clp$build_path_subtitle (cycle_reference, length, control_info.output_info.page_width -
                path_column_number, chunk_count, display_chunks);

          local_message_template := message_template;
          control_info.message_parameters [1] := ^text;

          FOR i := 1 TO chunk_count DO
            control_info.message_parameters [2] := ^cycle_reference
                  (display_chunks [i].position, display_chunks [i].length);
            IF i = chunk_count THEN
              suffix := '';
            ELSE
              suffix := '..';
            IFEND;
            control_info.message_parameters [3] := ^suffix;

            format_and_output_lines (only_template_lines, local_message_template, control_info);
            local_message_template := control_info.message_templates [mt#path_part];
          FOREND;

        PROCEND display_file_action;
?? OLDTITLE ??
?? NEWTITLE := 'get_applicable_policy', EJECT ??

        PROCEDURE get_applicable_policy
          (VAR applicable_actions: ost$ecp_actions);

          VAR
            ignore_applicable_policy: ^ost$ecp_policy_header,
            ignore_wait: boolean,
            local_actions: ost$ecp_actions,
            local_status: ost$status,
            access_condition_entry: fst$access_condition_entry,
            cycle_reference: fst$path,
            cycle_string: string (4),
            entry_found: boolean,
            length: integer,
            wait_message: oft$display_message;

          applicable_actions := $ost$ecp_actions [];

          CASE file_access_condition OF
          = fsc$data_restoration_required, fsc$media_missing, fsc$volume_unavailable =
            control_info.criteria.condition := file_access_condition;
            control_info.criteria.family_path_name := p_new_path^ [pfc$family_name_index];

            IF avp$system_administrator () OR avp$family_administrator () THEN
              control_info.criteria.login_family := p_new_path^ [pfc$family_name_index];
              control_info.criteria.login_user := p_new_path^ [pfc$master_catalog_name_index];
            IFEND;

            IF file_access_condition <> fsc$data_restoration_required THEN
              control_info.criteria.mass_storage_class := cycle_list^ [cycle_entry].cycle_device_information^.
                    mass_storage_device_info.mass_storage_class;
              control_info.criteria.volume_list := cycle_list^ [cycle_entry].cycle_device_information^.
                    mass_storage_device_info.volume_list;
            IFEND;

            osp$find_applicable_policy (control_info.criteria, control_info.exception_policies, local_actions,
                  ignore_applicable_policy, local_status);
            IF local_status.normal THEN
              applicable_actions := local_actions;
              osp$find_access_condition_entry (file_access_condition, access_condition_entry, entry_found);
              IF entry_found THEN
                cycle_reference := control_info.criteria.file (1, path_size);
                STRINGREP (cycle_string, length, cycle_selector.cycle_number);

                IF (path_size + length) <= fsc$max_path_size THEN
                  STRINGREP (cycle_reference, length, control_info.criteria.file (1, path_size),
                        cycle_string (1, length));
                  cycle_reference (path_size + 1, 1) := '.';
                IFEND;
                osp$format_wait_message (^access_condition_entry, ^control_info.criteria.file,
                      control_info.criteria.mass_storage_class, cycle_list^ [cycle_entry].
                      cycle_device_information^.mass_storage_device_info.volume_condition_list,
                      control_info.criteria.volume_list, wait_message);
              IFEND;
            IFEND;
          ELSE
          CASEND;

        PROCEND get_applicable_policy;
?? OLDTITLE ??


?? NEWTITLE := 'remove_damage_condition', EJECT ??

      PROCEDURE remove_damage_condition;

        VAR
          delete_damage_conditions: ^array [1 .. 1] of pft$change_descriptor;

        PUSH delete_damage_conditions;

        delete_damage_conditions^ [1].change_type := pfc$delete_damage_change;

        delete_damage_conditions^ [1].delete_damage_condition :=
              $fst$cycle_damage_symptoms [fsc$respf_modification_mismatch];

        pfp$r3_change (p_new_path^, cycle_selector, object_list^ [file_entry].password,
              delete_damage_conditions^, local_status);

      PROCEND remove_damage_condition;
?? OLDTITLE ??
?? NEWTITLE := 'report_busy_change', EJECT ??

        PROCEDURE report_busy_change;

          add_one (control_info.object_stats.busy_damaged_cycles);

          display_file_action (cycle_selector.cycle_number, control_info.
                message_templates [mt#cycle_busy_damage], '', control_info);

        PROCEND report_busy_change;
?? OLDTITLE ??
?? NEWTITLE := 'report_damage_deletion', EJECT ??

        PROCEDURE report_damage_deletion
            (    mmi_present: boolean);

          IF mmi_present THEN
            add_one (control_info.object_stats.damage_cleared.media_image_inconsistent);
            #SPOIL (control_info);
?? FMT (FORMAT := OFF) ??
            display_file_action (cycle_selector.cycle_number,
                  control_info.message_templates [mt#cleared_condition],
                  damage_symptom_names [media_image_inconsistent], control_info);
?? FMT (FORMAT := ON) ??
          IFEND;

          IF (fsc$parent_catalog_restored IN cycle_list^ [cycle_entry].cycle_information^.damage_symptoms) AND
                (fsc$parent_catalog_restored IN control_info.delete_damage_conditions [1].
                delete_damage_condition) THEN
            add_one (control_info.object_stats.damage_cleared.parent_catalog_restored);
            #SPOIL (control_info);
?? FMT (FORMAT := OFF) ??
            display_file_action (cycle_selector.cycle_number,
                  control_info.message_templates [mt#cleared_condition],
                  damage_symptom_names [parent_catalog_restored], control_info);
?? FMT (FORMAT := ON) ??
          IFEND;

          IF (fsc$respf_modification_mismatch IN cycle_list^ [cycle_entry].cycle_information^.
                damage_symptoms) AND (fsc$respf_modification_mismatch IN
                control_info.delete_damage_conditions [1].delete_damage_condition) THEN
            add_one (control_info.object_stats.damage_cleared.respf_modification_mismatch);
            #SPOIL (control_info);
            display_file_action (cycle_selector.cycle_number, control_info.
                  message_templates [mt#cleared_condition], damage_symptom_names
                  [respf_modification_mismatch], control_info);
          IFEND;

        PROCEND report_damage_deletion;

?? OLDTITLE ??
?? NEWTITLE := 'report_delete', EJECT ??

        PROCEDURE report_delete;

          VAR
            text: string (max_exception_string_size);

          update_exception_statistic (file_access_condition, control_info.object_stats.deleted, text);

          display_file_action (cycle_selector.cycle_number, control_info.message_templates [mt#deleted_cycle],
                text, control_info);

          IF cycle_list^ [cycle_entry].cycle_information^.outstanding_access_modes <> $pft$usage_selections
                [] THEN
            text := exception_condition_names [volume_unavailable];
            add_one (control_info.object_stats.release_pending);

            display_file_action (cycle_selector.cycle_number, control_info.
                  message_templates [mt#cycle_busy_delete], text, control_info);
          IFEND;

        PROCEND report_delete;
?? OLDTITLE ??
?? NEWTITLE := 'report_release', EJECT ??

        PROCEDURE report_release;

?? NEWTITLE := 'add_file_to_command', EJECT ??

          PROCEDURE add_file_to_command;

            VAR
              length: integer,
              line: string (fsc$max_path_size + 3) {for ' ..'} ;

            IF control_info.retrieve_info.current_command_file_count = max_files_per_command THEN
              clp$put_display (control_info.retrieve_info.include_file_info, ')', clc$no_trim, status);
              control_info.retrieve_info.current_command_file_count := 0;
              #SPOIL (control_info);
            IFEND;

            IF status.normal THEN
              IF (control_info.retrieve_info.current_command_file_count = 0) THEN
                clp$put_display (control_info.retrieve_info.include_file_info, retrieve_files_command,
                      clc$no_trim, status);
              IFEND;
              IF status.normal THEN
                STRINGREP (line, length, control_info.criteria.file (1, path_size), ' ..');
                clp$put_display (control_info.retrieve_info.include_file_info, line (1, length),
                      clc$no_trim, status);
              IFEND;
            IFEND;

            IF status.normal THEN
              add_one (control_info.retrieve_info.current_command_file_count);
              #SPOIL (control_info);
            ELSE
              EXIT pfp$change_catalog_contents_cmd;
            IFEND;

          PROCEND add_file_to_command;
?? OLDTITLE ??
?? NEWTITLE := 'convert_date_time', EJECT ??

          PROCEDURE convert_date_time
            (    date_time: ost$date_time;
             VAR str: ost$string);

            VAR
              date: ost$date,
              local_status: ost$status,
              time: ost$time;

            IF (date_time.year >= UPPERVALUE (date_time.year)) AND
                  (date_time.month >= UPPERVALUE (date_time.month)) AND
                  (date_time.day >= UPPERVALUE (date_time.day)) AND
                  (date_time.hour >= UPPERVALUE (date_time.hour)) AND
                  (date_time.minute >= UPPERVALUE (date_time.minute)) AND
                  (date_time.second >= UPPERVALUE (date_time.second)) AND
                  (date_time.millisecond >= UPPERVALUE (date_time.millisecond)) THEN
              str.size := 4;
              str.value := 'NONE';
              RETURN;
            IFEND;

            pmp$format_compact_date (date_time, osc$iso_date, date, local_status);
            IF local_status.normal THEN
              str.size := STRLENGTH (date.iso);
              str.value (1, str.size) := date.iso;
            ELSE
              str.size := 10;
              str.value (1, 10) := '????-??-??';
            IFEND;

            str.value (str.size + 1) := ' ';
            pmp$format_compact_time (date_time, osc$millisecond_time, time, local_status);
            IF local_status.normal THEN
              str.value (str.size + 2, STRLENGTH (time.millisecond)) := time.millisecond;
              str.size := str.size + 1 + STRLENGTH (time.millisecond);
            ELSE
              str.value (str.size + 2, 12) := '??:??:??.???';
              str.size := str.size + 1 + 12;
            IFEND;

          PROCEND convert_date_time;
?? OLDTITLE ??
?? EJECT ??

          VAR
            evaluated_file_reference: fst$evaluated_file_reference,
            new_date_string: ost$string,
            old_date_string: ost$string,
            text: string (max_exception_string_size);

          IF p_release_data_info^.valid_archive_entry_found THEN
            update_exception_statistic (file_access_condition, control_info.object_stats.released_with_emi,
                  text);
            display_file_action (cycle_selector.cycle_number, control_info.
                  message_templates [mt#enabled_matching_image], text, control_info);
          ELSE
            update_exception_statistic (file_access_condition, control_info.object_stats.released_with_eni,
                  text);
?? FMT (FORMAT := OFF) ??
            display_file_action (cycle_selector.cycle_number,
                  control_info.message_templates [mt#enabled_nonmatching_image], text, control_info);
?? FMT (FORMAT := ON) ??

            convert_date_time (p_release_data_info^.old_data_modification_date_time, old_date_string);
            convert_date_time (p_release_data_info^.new_data_modification_date_time, new_date_string);
            control_info.message_parameters [1] := ^old_date_string.value (1, old_date_string.size);
            control_info.message_parameters [2] := ^new_date_string.value (1, new_date_string.size);

            format_and_output_lines (only_template_lines, control_info.
                  message_templates [mt#modification_dates_and_times], control_info);
          IFEND;

          IF p_release_data_info^.cycle_attached THEN
            text := exception_condition_names [volume_unavailable];
            add_one (control_info.object_stats.release_pending);

            display_file_action (cycle_selector.cycle_number, control_info.
                  message_templates [mt#cycle_busy_release], text, control_info);
          IFEND;

          IF control_info.retrieve_info.display_info.file_id <> amv$nil_file_identifier THEN
            clp$put_display (control_info.retrieve_info.display_info, control_info.criteria.
                  file (1, path_size), clc$no_trim, status);
            IF status.normal AND control_info.retrieve_info.automatic_retrieval THEN
              add_file_to_command;
            IFEND;
          IFEND;

          IF NOT status.normal THEN
            EXIT pfp$change_catalog_contents_cmd;
          IFEND;

        PROCEND report_release;
?? OLDTITLE ??
?? NEWTITLE := 'report_damage_setting', EJECT ??

      PROCEDURE report_damage_setting;

        format_and_output_lines (only_template_lines, control_info.
              message_templates [mt#set_damage_condition], control_info);

      PROCEND report_damage_setting;
?? OLDTITLE ??
?? NEWTITLE := 'update_exception_statistic', EJECT ??

        PROCEDURE update_exception_statistic
          (    file_access_condition: fst$file_access_condition;
           VAR exception_statistic: chacc_exception_statistics;
           VAR text: string (max_exception_string_size));

          CASE file_access_condition OF

          = fsc$data_restoration_required =
            text := exception_condition_names [undefined_data];
            add_one (exception_statistic.undefined_data);

          = fsc$media_missing =
            text := exception_condition_names [media_missing];
            add_one (exception_statistic.media_missing);

          = fsc$volume_unavailable =
            text := exception_condition_names [volume_unavailable];
            add_one (exception_statistic.volume_unavailable);
          ELSE
          CASEND;

        PROCEND update_exception_statistic;
?? OLDTITLE ??
?? EJECT ??

        CONST
          message_prefix = 'CHACC',
          message_prefix_size = 5;

        VAR
          catalog: ost$positive_integers,
          cycle_count: ost$positive_integers,
          cycle_list: ^fst$goi_object_list,
          file_count: ost$positive_integers,
          header: ^fst$goi_object_information,
          information_request: fst$goi_information_request,
          local_status: ost$status,
          mmi_present: boolean,
          next_catalog_object: ^SEQ ( * ),
          path: ^fst$path,
          relevant_path_size: fst$path_size,
          switch: 0 .. 4,
          wait_message: oft$display_message;

        CASE catalog_depth OF
        = 1 =
          add_one (control_info.object_stats.objects_scanned.families);
        = 2 =
          add_one (control_info.object_stats.objects_scanned.master_catalogs);
        ELSE
          add_one (control_info.object_stats.objects_scanned.subcatalogs);
        CASEND;

        IF control_info.object_stats.objects_scanned.maximum_catalog_nesting < catalog_depth THEN
          control_info.object_stats.objects_scanned.maximum_catalog_nesting := catalog_depth;
        IFEND;
        #SPOIL (control_info);

        information_request.catalog_depth.depth_specification := fsc$specific_depth;
        information_request.catalog_depth.depth := 1;
        information_request.object_information_requests := $fst$goi_object_info_requests
              [fsc$goi_catalog_object_list, fsc$goi_file_object_list, fsc$goi_cycle_object_list,
              fsc$goi_cycle_info, fsc$goi_cycle_device_info, fsc$goi_set_name];

        next_catalog_object := control_info.master_catalog_sequence;
        pfp$get_object_information (catalog_reference^, information_request, {validation_criteria} NIL,
              control_info.master_catalog_sequence, local_status);
        IF local_status.normal THEN
          NEXT header IN next_catalog_object;
          IF header <> NIL THEN
            IF (header^.object <> NIL) AND (header^.object^.object_type = fsc$goi_catalog_object) AND
                  (header^.object^.subcatalog_and_file_object_list <> NIL) THEN
              control_info.criteria.set_name := header^.set_name;

              object_list := header^.object^.subcatalog_and_file_object_list;

              file_count := (UPPERBOUND (object_list^) - LOWERBOUND (object_list^)) + 1;
              IF control_info.object_stats.objects_scanned.maximum_files_per_catalog < file_count THEN
                control_info.object_stats.objects_scanned.maximum_files_per_catalog := file_count;
              IFEND;
              #SPOIL (control_info);

            /file_object_loop/
              FOR file_entry := LOWERBOUND (object_list^) TO UPPERBOUND (object_list^) DO
                IF (object_list^ [file_entry].object_type = fsc$goi_file_object) AND
                      (object_list^ [file_entry].cycle_object_list <> NIL) THEN
                  add_one (control_info.object_stats.objects_scanned.files);
                  #SPOIL (control_info);

                  build_file_reference (header^.resolved_path^, object_list^ [file_entry].file_name,
                        control_info.criteria.file, path_size);

                  IF (control_info.object_stats.objects_scanned.files MOD 100) = 0 THEN
                    wait_message.text := message_prefix;
                    osp$get_relevant_path_string (control_info.criteria.file, wait_message.
                          text (message_prefix_size + 2, * ), relevant_path_size);
                    wait_message.size := message_prefix_size + relevant_path_size + 1;
                    ofp$display_status_message (wait_message.text (1, wait_message.size), ignore_status);

                  IFEND;

                  PUSH p_new_path: [1 .. catalog_depth + 1];
                  build_path (^control_info.criteria.file (1, path_size), p_new_path);

                  cycle_list := object_list^ [file_entry].cycle_object_list;
                  cycle_count := (UPPERBOUND (cycle_list^) - LOWERBOUND (cycle_list^)) + 1;
                  control_info.object_stats.objects_scanned.cycles :=
                        control_info.object_stats.objects_scanned.cycles + cycle_count;
                  #SPOIL (control_info);

                  IF control_info.object_stats.objects_scanned.maximum_cycles_per_file < cycle_count THEN
                    control_info.object_stats.objects_scanned.maximum_cycles_per_file := cycle_count;
                  IFEND;
                  #SPOIL (control_info);

                /cycle_object_loop/
                  FOR cycle_entry := LOWERBOUND (cycle_list^) TO (UPPERBOUND (cycle_list^)) DO
                    cycle_selector.cycle_option := pfc$specific_cycle;
                    cycle_selector.cycle_number := cycle_list^ [cycle_entry].cycle_number;
                    #SPOIL (control_info);

                    IF cycle_list^ [cycle_entry].cycle_device_class = rmc$mass_storage_device THEN
                      IF control_info.delete_damage_conditions [1].delete_damage_condition <>
                            $fst$cycle_damage_symptoms [] THEN

                        delete_damage_condition :=
                              (((control_info.delete_damage_conditions [1].delete_damage_condition *
                              cycle_list^ [cycle_entry].cycle_information^.damage_symptoms) <>
                              $fst$cycle_damage_symptoms []) OR
                              (fsc$media_image_inconsistent IN
                              control_info.delete_damage_conditions [1].delete_damage_condition));

                        IF delete_damage_condition THEN
                          mmi_present := FALSE;
                          IF control_info.perform_changes THEN
                            pfp$r3_change (p_new_path^, cycle_selector, object_list^ [file_entry].password,
                                  control_info.delete_damage_conditions, local_status);
                            IF (fsc$media_image_inconsistent IN
                                  control_info.delete_damage_conditions [1].delete_damage_condition) THEN
                              IF local_status.normal THEN
                                mmi_present := cycle_list^ [cycle_entry].cycle_device_information^.
                                      mass_storage_device_info.resides_online;
                              ELSE
                                local_status.normal :=
                                      local_status.condition = pfe$no_media_image_inconsistent;
                              IFEND;
                            IFEND;
                          IFEND;

                          IF local_status.normal THEN
                            report_damage_deletion (mmi_present);
                          ELSEIF (local_status.condition = pfe$cycle_busy) THEN
                            report_busy_change;
                          ELSEIF NOT osp$file_access_condition (local_status) THEN
                            CASE local_status.condition OF
                            = pfe$incorrect_password, pfe$usage_not_permitted =
                            ELSE
                              output_log_message (^control_info.criteria.file,
                                    'CHANGE_CATALOG - PFP$R3_CHANGE',
                                    mt#unexpected_abnormal_status, local_status);
                            CASEND;
                          IFEND;
                        IFEND; {delete damage condition worthwhile}
                      IFEND; {delete damage condition requested}

                      IF (control_info.exception_policies <> NIL) THEN

                        file_access_condition := cycle_list^ [cycle_entry].cycle_device_information^.
                              mass_storage_device_info.object_condition;

                        IF file_access_condition IN $fst$file_access_conditions
                              [fsc$data_restoration_required, fsc$media_missing, fsc$volume_unavailable] THEN

                          get_applicable_policy (actions);

                          IF actions <> $ost$ecp_actions [] THEN
                            data_released := FALSE;
                            IF (osc$ecp_enable_matching_image IN actions) OR
                                  (osc$ecp_enable_nonmatch_image IN actions) THEN
                              PUSH p_release_data_info;
                              p_release_data_info^.perform_changes := control_info.perform_changes;
                              p_release_data_info^.release_attached_cycle_data := TRUE;
                              p_release_data_info^.update_last_release_date_time := TRUE;
                              p_release_data_info^.valid_archive_entry_required :=
                                    NOT (osc$ecp_enable_nonmatch_image IN actions);
                              pfp$r3_release_data (p_new_path^, cycle_selector,
                                    object_list^ [file_entry].password, p_release_data_info, local_status);
                              data_released := local_status.normal;
                              IF local_status.normal THEN
                                report_release;
                                IF (NOT p_release_data_info^.valid_archive_entry_required) AND
                                      (NOT p_release_data_info^.valid_archive_entry_found) AND
                                      (p_release_data_info^.new_data_modification_date_time <>
                                      p_release_data_info^.old_data_modification_date_time) THEN
                                  IF osc$ecp_set_damage_condition IN actions THEN
                                    report_damage_setting;
                                  ELSE
                                    remove_damage_condition;
                                  IFEND;
                                IFEND;
                              ELSE
                                CASE local_status.condition OF
                                = pfe$data_not_releasable, pfe$empty_archive_list, pfe$incorrect_password,
                                  pfe$usage_not_permitted =

                                ELSE
                                  output_log_message (^control_info.criteria.file,
                                       'CHANGE_CATALOG - PFP$R3_RELEASE_DATA', mt#unexpected_abnormal_status,
                                       local_status);
                               CASEND;
                             IFEND;
                           IFEND; {release test}

                           IF (osc$ecp_delete IN actions) AND (NOT data_released) THEN
                             IF control_info.perform_changes THEN
                               pfp$purge (p_new_path^, cycle_selector, object_list^ [file_entry].password,
                                     local_status);
                             ELSE
                               local_status.normal := TRUE;
                             IFEND;
                             IF local_status.normal THEN
                               report_delete;
                             ELSE
                               CASE local_status.condition OF
                               = pfe$incorrect_password, pfe$usage_not_permitted =

                               ELSE
                                 output_log_message (^control_info.criteria.file,
                                       'CHANGE_GETALOG - PFP$PURGE',
                                       mt#unexpected_abnormal_status, local_status);
                               CASEND;
                             IFEND;
                           IFEND; {delete test}
                         IFEND; {applicable policy exists test}
                       IFEND; {file access condition is relevant test}
                     IFEND; {applicable policies may exist test}
                   IFEND; {mass storage cycle test}
                 FOREND /cycle_object_loop/;
               IFEND; {file object with cycles test}
             FOREND /file_object_loop/;

             PUSH path;
             FOR catalog := LOWERBOUND (object_list^) TO UPPERBOUND (object_list^) DO
               IF object_list^ [catalog].object_type = fsc$goi_catalog_object THEN
                 build_file_reference (header^.resolved_path^, object_list^ [catalog].catalog_name, path^,
                       path_size);
                 change_catalog (^path^ (1, path_size), catalog_depth + 1, control_info);
               IFEND;
             FOREND;

           IFEND; {is it a nonempty catalog object}
         ELSE {header = NIL}
           output_log_message (catalog_reference, 'CHANGE_CATALOG - NEXT failed', mt#object_error,
                 local_status);
         IFEND;
       ELSE {abnormal getoi local_status}
         CASE local_status.condition OF
         = pfe$unknown_item =
           {Ignore.  User had visibility to catalog names but no permission to catalog contents}
         = pfe$catalog_volume_not_online =
           output_object_warning ('PFE$CATALOG_VOLUME_NOT_ONLINE', catalog_reference);
         = pfe$catalog_volume_unavailable =
           output_object_warning ('PFE$CATALOG_VOLUME_UNAVAILABLE', catalog_reference);
         ELSE
           output_log_message (catalog_reference, 'CHANGE_CATALOG - GETOI', mt#object_error, local_status);
         CASEND;
       IFEND;
     PROCEND change_catalog;
?? OLDTITLE ??

?? NEWTITLE := 'change_family', EJECT ??

     PROCEDURE change_family
       (    file_reference: ^fst$file_reference;
        VAR control_info: chacc_control_info);

       VAR
         family_catalog: ^fst$goi_object,
         i: ost$positive_integers,
         ignore_path_size: integer,
         information_request: fst$goi_information_request,
         local_status: ost$status,
         master_catalog: ^fst$goi_object,
         master_catalog_path: string (64),
         object: ^fst$goi_object_information;

       RESET control_info.family_sequence;

       information_request.catalog_depth.depth_specification := fsc$specific_depth;
       information_request.catalog_depth.depth := 1;
       information_request.object_information_requests := $fst$goi_object_info_requests
             [fsc$goi_catalog_object_list];

       pfp$get_object_information (file_reference^, information_request, {validation_criteria} NIL,
             control_info.family_sequence, local_status);

       IF local_status.normal THEN
         RESET control_info.family_sequence;

         NEXT object IN control_info.family_sequence;
         IF object <> NIL THEN
           family_catalog := object^.object;

           FOR i := LOWERBOUND (family_catalog^.subcatalog_and_file_object_list^)
                 TO UPPERBOUND (family_catalog^.subcatalog_and_file_object_list^) DO
             master_catalog := ^family_catalog^.subcatalog_and_file_object_list^ [i];
             build_file_reference (object^.resolved_path^, master_catalog^.catalog_name, master_catalog_path,
                   ignore_path_size);

             RESET control_info.master_catalog_sequence;
             change_catalog (^master_catalog_path, {catalog_depth} 2, control_info);

           FOREND;
         ELSE {header = NIL}
           output_log_message (file_reference, 'CHANGE_FAMILY - NEXT failed', mt#object_error, local_status);
         IFEND;
       ELSE {abnormal status from GETOI}
         output_log_message (file_reference, 'CHANGE_FAMILY - GETOI', mt#object_error, local_status);
       IFEND;
     PROCEND change_family;
?? OLDTITLE ??
?? NEWTITLE := 'terminate_chacc', EJECT ??

     PROCEDURE terminate_chacc
       (    normal_termination: boolean);

       VAR
         ignore_status: ost$status,
         segment_pointer: amt$segment_pointer;

       IF NOT normal_termination AND (current_object <> NIL) THEN
         were_changes_made;
         output_header (current_object^, header_text [summary], control_info);
         output_summary (control_info.object_stats);
         accumulate_statistics;
       IFEND;

       IF control_info.summary_count > 1 THEN
         initialize_message_parameters;
         format_and_output_lines (blank_line_before_and_after, control_info.message_templates [mt#totals],
               control_info);
         output_summary (totals);
         control_info.summary_count := 0;
         #SPOIL (control_info);
       IFEND;

       IF normal_termination AND control_info.retrieve_info.automatic_retrieval THEN
         IF control_info.retrieve_info.include_file_info.file_id <> amv$nil_file_identifier THEN
           IF (control_info.retrieve_info.current_command_file_count > 0) THEN
             clp$put_display (control_info.retrieve_info.include_file_info, ')', clc$no_trim, ignore_status);
             control_info.retrieve_info.current_command_file_count := 0;
             #SPOIL (control_info);
           IFEND;
           clp$close_display (control_info.retrieve_info.include_file_info, ignore_status);
           control_info.retrieve_info.include_file_info.file_id := amv$nil_file_identifier;
           #SPOIL (control_info);
           IF control_info.perform_changes THEN
             clp$include_file (control_info.retrieve_info.unique_file_name, {prompt} '',
                   {utility_name} osc$null_name, ignore_status);
           IFEND;
         IFEND;
       IFEND;

     PROCEND terminate_chacc;
?? OLDTITLE ??
?? EJECT ??
     initialize_statistics (totals);

     current_object := control_info.object_list;
     #SPOIL (current_object);

     WHILE (current_object <> NIL) DO
       output_header (current_object^, header_text [actions], control_info);

       IF current_object^.object_kind = family_object THEN
         add_one (control_info.object_stats.objects_scanned.families);
         #SPOIL (control_info);
         change_family (^current_object^.file_reference, control_info);
       ELSE
         RESET control_info.master_catalog_sequence;
         change_catalog (^current_object^.file_reference, current_object^.number_of_path_elements,
               control_info);
       IFEND;

       were_changes_made;
       output_header (current_object^, header_text [summary], control_info);
       output_summary (control_info.object_stats);

       current_object := current_object^.next_object;
       #SPOIL (current_object);
       accumulate_statistics;
       initialize_statistics (control_info.object_stats);
       #SPOIL (control_info);
     WHILEND;
     terminate_chacc ({normal_termination} TRUE);
     osp$disestablish_cond_handler;

   PROCEND change_catalog_contents;
?? OLDTITLE ??
?? NEWTITLE := 'count_damage_conditions', EJECT ??

   FUNCTION [INLINE] count_damage_conditions
     (    damage_conditions: chacc_damage_statistics): integer;

     count_damage_conditions := damage_conditions.media_image_inconsistent +
           damage_conditions.parent_catalog_restored + damage_conditions.respf_modification_mismatch;

   FUNCEND count_damage_conditions;
?? OLDTITLE ??
?? NEWTITLE := 'count_exceptions', EJECT ??

   FUNCTION [INLINE] count_exceptions
     (    exception_statistics: chacc_exception_statistics): integer;

     count_exceptions := exception_statistics.media_missing + exception_statistics.undefined_data +
           exception_statistics.volume_unavailable;

   FUNCEND count_exceptions;
?? OLDTITLE ??
?? NEWTITLE := 'count_scanned', EJECT ??

   FUNCTION [INLINE] count_scanned
     (    objects_scanned: chacc_object_statistics): ost$non_negative_integers;

     count_scanned := objects_scanned.families + objects_scanned.master_catalogs +
           objects_scanned.subcatalogs + objects_scanned.files + objects_scanned.cycles;
   FUNCEND count_scanned;
?? OLDTITLE ??
?? NEWTITLE := 'evaluate_parameters', EJECT ??

   PROCEDURE evaluate_parameters;

{Design:  This procedure is responsible for evaluating all of the explicitly
{and implicitly specified parameters to CHANGE_CATALOG_CONTENTS.  Implicit
{parameters are provided through exception condition policies defined by the
{MANAGE_EXCEPTION_POLICIES utility.

{An SCL "check" procedure is used for the CATALOG parameter.  This improves
{the usability of the command by validating the parameter values while the
{interactive user still has a chance to correct mistakes.

{The variable OBJECT_LIST is a global variable to the nested procedures that
{follow because:

{ 1) All explicitly specified catalog paths must first be evaluated to
{    perform the necessary validation in the "check" procedure.  Because the
{    evaluated_file_reference is useful to CHANGE_CATALOG, it is saved in
{    the OBJECT_LIST segment to avoid redundant calls to
{    CLP$EVALUATE_FILE_REFERENCE.

{ 2) For uniformity, all catalogs implicitly specified by the keywords ALL
{    and EXCEPTION_POLICY_REFERENCES are also processed and stored in the
{    OBJECT_LIST segment.  However, this processing is not necessary in the
{    "check" procedure and is done at the end of EVALUATE_PARAMETERS.

{ 3) Because it is not good practice to call anything prior to
{    CLP$EVALUATE_FILE_REFERENCE that could return abnormal status, the
{    "check" procedure creates the OBJECT_LIST segment and initializes the
{    OBJECT_LIST segment pointer variable below.  This segment is then used
{    to perform the process defined in (2) above.  The segment remains
{    allocated throughout this command and is deleted by the
{    block exit handler defined for PFP$CHANGE_CATALOG_CONTENTS_CMD.

     VAR
       object_list: amt$segment_pointer;

?? NEWTITLE := 'append_catalog_object', EJECT ??

     PROCEDURE append_catalog_object
       (    evaluated_file_reference: ^fst$evaluated_file_reference);

       VAR
         ignore_path_size: fst$path_size,
         insertion: ^^chacc_object_list_entry,
         node: ^chacc_object_list_entry,
         path: fst$path;

       clp$convert_file_ref_to_string (evaluated_file_reference^, FALSE, path, ignore_path_size, status);
       IF status.normal THEN
         IF control_info.object_list <> NIL THEN
           node := control_info.object_list;
           REPEAT
             IF (node^.object_kind = catalog_object) AND (node^.file_reference = path) THEN
               RETURN;
             ELSEIF node^.next_object = NIL THEN
               insertion := ^node^.next_object;
             IFEND;
             node := node^.next_object;
           UNTIL node = NIL;
         ELSE
           insertion := ^control_info.object_list;
         IFEND;

         NEXT insertion^ IN object_list.sequence_pointer;
         insertion^^.file_reference := path;
         insertion^^.object_kind := catalog_object;
         insertion^^.number_of_path_elements := evaluated_file_reference^.number_of_path_elements;
         insertion^^.next_object := NIL;

       ELSE
         EXIT pfp$change_catalog_contents_cmd;
       IFEND;

     PROCEND append_catalog_object;
?? OLDTITLE ??
?? NEWTITLE := 'append_family_object', EJECT ??

     PROCEDURE append_family_object
       (    family_name: ost$name);

       VAR
         evaluated_file_reference: fst$evaluated_file_reference,
         family_path: string (32),
         insertion: ^^chacc_object_list_entry,
         node: ^chacc_object_list_entry,
         path_size: integer;

       STRINGREP (family_path, path_size, ':', family_name);

       IF control_info.object_list <> NIL THEN
         node := control_info.object_list;
         REPEAT
           IF (node^.object_kind = family_object) AND (node^.file_reference = family_path) THEN
             RETURN;
           ELSEIF node^.next_object = NIL THEN
             insertion := ^node^.next_object;
           IFEND;
           node := node^.next_object;
         UNTIL node = NIL;
       ELSE
         insertion := ^control_info.object_list;
       IFEND;

       NEXT insertion^ IN object_list.sequence_pointer;
       insertion^^.file_reference := family_path;
       insertion^^.object_kind := family_object;
       insertion^^.number_of_path_elements := 1;
       insertion^^.next_object := NIL;

     PROCEND append_family_object;
?? OLDTITLE ??
?? NEWTITLE := 'check_catalog_parameter', EJECT ??

     PROCEDURE check_catalog_parameter
       (    pvt: ^clt$parameter_value_table;
            which_parameter: clt$which_parameter;
        VAR status: ost$status);


?? NEWTITLE := 'analyze_exception_policies', EJECT ??

       PROCEDURE analyze_exception_policies;


{ Design:
{ The purpose of this procedure is to determine whether any of the installed
{ exception policies pertain to the exception conditions PFE$UNDEFINED_DATA,
{ PFE$VOLUME_UNAVAILABLE, or PFE$VOLUME_NOT_ONLINE (or status conditons mapped to
{ these conditions).  If such policies exist and these policies have selected
{ any of the following actions, this session of CHACC will implement them, if
{ applicable: DELETE, ENABLE_MATCHING_IMAGE, ENABLE_NONMATCHING_IMAGE.

         VAR
           actions: ost$ecp_actions,
           exceptions: ost$ecp_conditions,
           i: ost$ecp_number_of_conditions,
           ignore_status: ost$status,
           installed_header: ^ost$ecp_header,
           local_status: ost$status,
           policy_criteria: ost$ecp_policy_criteria,
           segment_pointer: amt$segment_pointer;

?? NEWTITLE := 'anaep_block_exit_handler', EJECT ??

         PROCEDURE anaep_block_exit_handler
           (    condition: pmt$condition;
                ignore_condition_information: ^pmt$condition_information;
                ignore_save_area: ^ost$stack_frame_save_area;
            VAR handler_status: ost$status);

           IF segment_pointer.sequence_pointer <> NIL THEN
             mmp$delete_scratch_segment (segment_pointer, ignore_status);
             segment_pointer.sequence_pointer := NIL;
           IFEND;

         PROCEND anaep_block_exit_handler;
?? OLDTITLE ??
?? NEWTITLE := 'prune_exception_policies', EJECT ??

         PROCEDURE prune_exception_policies;

           VAR
             i: ost$positive_integers,
             policy: ^ost$ecp_policy_header;

           i := 1;
           REPEAT
             osp$get_policy (i, installed_header^, policy);
             IF (policy <> NIL) THEN
               IF (osp$chacc_applicable_policy (policy)) THEN
                 i := i + 1;
               ELSE
                 osp$remove_policy (policy, installed_header^);
               IFEND;
             IFEND;
           UNTIL policy = NIL;

         PROCEND prune_exception_policies;
?? OLDTITLE ??
?? EJECT ??
         segment_pointer.kind := amc$sequence_pointer;
         segment_pointer.sequence_pointer := NIL;
         #SPOIL (segment_pointer);

         actions := $ost$ecp_actions [];

         osp$establish_block_exit_hndlr (^anaep_block_exit_handler);

         mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
         IF status.normal THEN
           RESET segment_pointer.sequence_pointer;
           osp$get_installed_policies (segment_pointer.sequence_pointer, installed_header, local_status);
           IF local_status.normal THEN
             prune_exception_policies;
             osp$get_union_of_policies (installed_header, exceptions, policy_criteria, local_status);
             IF local_status.normal THEN
               FOR i := 1 TO UPPERBOUND (exceptions) DO
                 IF exceptions [i].specified THEN
                   actions := actions + exceptions [i].actions;
                 IFEND;
               FOREND;
             IFEND;
           IFEND;
         ELSE
           EXIT pfp$change_catalog_contents_cmd;
         IFEND;

         IF actions <> $ost$ecp_actions [] THEN
           control_info.union_of_actions := actions;
           control_info.union_of_policies := policy_criteria * $ost$ecp_policy_criteria
                 [osc$ecp_all_files, osc$ecp_families, osc$ecp_list_of_files, osc$ecp_mass_storage_classes,
                 osc$ecp_sets, osc$ecp_volumes];
           control_info.exception_policies := installed_header;
           #SPOIL (control_info);
         ELSE
           mmp$delete_scratch_segment (segment_pointer, ignore_status);
           segment_pointer.sequence_pointer := NIL;
           #SPOIL (segment_pointer);
         IFEND;

         osp$disestablish_cond_handler;

       PROCEND analyze_exception_policies;
?? OLDTITLE ??
?? NEWTITLE := 'validate_object_list', EJECT ??

       PROCEDURE validate_object_list;

         VAR
           current_catalog: ^clt$data_value,
           evaluated_file_reference: fst$evaluated_file_reference,
           family_name: ost$name,
           i: ost$positive_integers,
           information_request: fst$goi_information_request;

         current_catalog := pvt^ [p$catalog].value;

         FOR i := 1 TO clp$count_list_elements (pvt^ [p$catalog].value) DO
           clp$evaluate_file_reference (current_catalog^.element_value^.file_value^,
                 $clt$file_ref_parsing_options [], FALSE, evaluated_file_reference, status);
           IF status.normal THEN
             IF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
               osp$set_status_abnormal ('CL', cle$file_position_not_allowed, '', status);
             ELSEIF fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local THEN
               IF evaluated_file_reference.number_of_path_elements = 1 THEN
                 osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_cat, '', status);
               ELSE
                 osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_file, '', status);
               IFEND;
             ELSEIF (evaluated_file_reference.number_of_path_elements = 1) AND
                   (NOT (avp$system_administrator () OR avp$family_administrator ())) THEN
               osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$not_family_owner,
                     current_catalog^.element_value^.file_value^, status);
             ELSEIF evaluated_file_reference.cycle_reference.specification <> fsc$cycle_omitted THEN
               osp$set_status_abnormal ('CL', fse$catalogs_do_not_have_cycles,
                     current_catalog^.element_value^.file_value^, status);
             ELSE {valid path}
               RESET control_info.family_sequence;

               information_request.catalog_depth.depth_specification := fsc$specific_depth;
               information_request.catalog_depth.depth := 1;
               information_request.object_information_requests :=
                     $fst$goi_object_info_requests [fsc$goi_catalog_identity];

               pfp$r3_get_object_information (evaluated_file_reference, information_request,
                     {validation_criteria} NIL, control_info.family_sequence, status);

               IF status.normal THEN
                 IF (evaluated_file_reference.number_of_path_elements = 1) THEN
                   family_name := fsp$path_element (^evaluated_file_reference, 1) ^;
                   append_family_object (family_name);
                 ELSE
                   append_catalog_object (^evaluated_file_reference);
                 IFEND;
               ELSE
                 RETURN;
               IFEND;
             IFEND;
           ELSE
             RETURN;
           IFEND;
           current_catalog := current_catalog^.link;
         FOREND;

       PROCEND validate_object_list;
?? OLDTITLE ??
?? EJECT ??
{Design: This procedure assumes that the CATALOG parameter is the only parameter
{ to have a CHECK attribute.

       IF which_parameter.specific THEN
         analyze_exception_policies;

         mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, object_list, status);
         IF status.normal THEN
           RESET object_list.sequence_pointer;
           IF pvt^ [which_parameter.number].value^.kind = clc$keyword THEN
             IF pvt^ [p$catalog].value^.keyword_value = catalog_option_names [co_all] THEN
               IF NOT (avp$system_administrator () OR avp$family_administrator ()) THEN
                 osp$set_status_condition (ose$not_administrator, status);
                 osp$append_status_parameter (osc$status_parameter_delimiter,
                       catalog_option_names [co_all] (1, clp$trimmed_string_size
                       (catalog_option_names [co_all])), status);
                 osp$append_status_parameter (osc$status_parameter_delimiter, 'CATALOG', status);
                 osp$append_status_parameter (osc$status_parameter_delimiter, 'CHANGE_CATALOG_CONTENTS',
                       status);
               IFEND;
             ELSEIF pvt^ [p$catalog].value^.keyword_value = catalog_option_names [co_policies] THEN
               IF (avp$system_administrator ()) THEN
                 IF (control_info.union_of_actions = $ost$ecp_actions []) OR
                       (control_info.union_of_policies = $ost$ecp_policy_criteria []) THEN
                   osp$set_status_condition (ose$no_applicable_policies, status);
                 IFEND;
               ELSE
                 osp$set_status_condition (ose$not_system_administrator, status);
                 osp$append_status_parameter (osc$status_parameter_delimiter,
                       catalog_option_names [co_policies], status);
                 osp$append_status_parameter (osc$status_parameter_delimiter, 'CATALOG', status);
                 osp$append_status_parameter (osc$status_parameter_delimiter, 'CHANGE_CATALOG_CONTENTS',
                       status);
               IFEND;
             IFEND;
           ELSE
             validate_object_list;
           IFEND;
         IFEND;
       IFEND;
     PROCEND check_catalog_parameter;
?? OLDTITLE ??
?? NEWTITLE := 'get_all_families', EJECT ??

     PROCEDURE get_all_families;

       VAR
         family_count: pmt$family_name_count,
         family_name_list: ^pmt$family_name_list,
         i: ost$positive_integers;

       PUSH family_name_list: [1 .. pmc$family_name_count_maximum];
       pmp$get_family_names (family_name_list^, family_count, status);

       IF status.normal THEN
         FOR i := 1 TO family_count DO
           append_family_object (family_name_list^ [i]);
         FOREND;
       ELSE
         EXIT pfp$change_catalog_contents_cmd;
       IFEND;
     PROCEND get_all_families;

?? OLDTITLE ??
?? NEWTITLE := 'get_login_family', EJECT ??

     PROCEDURE get_login_family;

       VAR
         criteria: ost$ecp_criteria;

       osp$get_login_user_criteria (criteria, status);
       IF status.normal THEN
         append_family_object (criteria.login_family);
       IFEND;

     PROCEND get_login_family;

?? OLDTITLE ??
?? NEWTITLE := 'get_referenced_object_list', EJECT ??

     PROCEDURE get_referenced_object_list;

       VAR
         policy: ^ost$ecp_policy_header,
         policy_number: ost$positive_integers;

?? NEWTITLE := 'process_referenced_files', EJECT ??

       PROCEDURE process_referenced_files;

         CONST
           path_size = 1 {colon} + fsc$max_path_size {family_name} + 1 {period} + fsc$max_path_size
                 {master_catalog_name} ;

         VAR
           evaluated_file_reference: fst$evaluated_file_reference,
           family: ost$name,
           i: ost$non_negative_integers,
           local_status: ost$status,
           only_family: boolean;

         FOR i := LOWERBOUND (policy^.files.path_list^) TO UPPERBOUND (policy^.files.path_list^) DO
           CASE policy^.files.path_list^ [i].file_reference_type OF
           = osc$ecp_evaluated_reference, osc$ecp_wild_card_reference =
             clp$evaluate_file_reference (policy^.files.path_list^ [i].
                   path^, $clt$file_ref_parsing_options [clc$multiple_reference_allowed], FALSE,
                   evaluated_file_reference, local_status);

             IF local_status.normal THEN
               family := fsp$path_element (^evaluated_file_reference, 1) ^;
               IF family <> fsc$local THEN
                 only_family := (evaluated_file_reference.number_of_path_elements = 1);
                 only_family := only_family OR ((policy^.files.path_list^ [i].file_reference_type =
                       osc$ecp_wild_card_reference) AND (evaluated_file_reference.number_of_path_elements =
                       2));
                 IF only_family THEN
                   append_family_object (family);
                 ELSE
                   append_catalog_object (^evaluated_file_reference);
                 IFEND;
               IFEND;
             ELSE
               output_undefined_object_msg (file_object, policy^.files.path_list^ [i].path^);
             IFEND;
           ELSE {osc$ecp$generic_reference causes scope of ALL files}
           CASEND;
         FOREND;

       PROCEND process_referenced_files;
?? OLDTITLE ??
?? NEWTITLE := 'process_referenced_sets', EJECT ??

       PROCEDURE process_referenced_set
         (    set_name: stt$set_name);

         VAR
           i: ost$non_negative_integers,
           number_of_families: 0 .. pmc$family_name_count_maximum,
           family_list: ^array [1 .. * ] of ost$name,
           local_status: ost$status;

         PUSH family_list: [1 .. pmc$family_name_count_maximum];
         { If SET is not defined, normal status is returned and number_of_families is zero}
         pfp$get_families_in_set (set_name, family_list^, number_of_families, local_status);

         IF local_status.normal THEN
           IF number_of_families > 0 THEN
             FOR i := 1 TO number_of_families DO
               append_family_object (family_list^ [i]);
             FOREND;
           ELSE
             output_undefined_object_msg (set_object, set_name);
           IFEND;
         ELSE
           EXIT pfp$change_catalog_contents_cmd;
         IFEND;

       PROCEND process_referenced_set;
?? OLDTITLE ??
?? NEWTITLE := 'process_referenced_volumes', EJECT ??

       PROCEDURE process_referenced_volumes;

         VAR
           i: ost$non_negative_integers,
           local_status: ost$status,
           set_name: stt$set_name;

         FOR i := LOWERBOUND (policy^.volumes^) TO UPPERBOUND (policy^.volumes^) DO
           pfp$get_volumes_set_name (policy^.volumes^ [i], set_name, local_status);
           IF local_status.normal THEN
             process_referenced_set (set_name);
           ELSE
             output_undefined_object_msg (volume_object, policy^.volumes^ [i]);
           IFEND;
         FOREND;

       PROCEND process_referenced_volumes;
?? OLDTITLE ??

       VAR
         i: ost$non_negative_integers,
         local_set_name: stt$set_name,
         local_status: ost$status;

       policy_number := 1;

       REPEAT
         osp$get_policy (policy_number, control_info.exception_policies^, policy);

         IF policy <> NIL THEN
           IF policy^.families <> NIL THEN
             FOR i := LOWERBOUND (policy^.families^) TO UPPERBOUND (policy^.families^) DO
               pfp$get_family_set (policy^.families^ [i], local_set_name, local_status);
               IF local_status.normal THEN
                 append_family_object (policy^.families^ [i]);
               ELSE
                 output_undefined_object_msg (family_object, policy^.families^ [i]);
               IFEND;
             FOREND;
           IFEND;

           IF policy^.files.specified AND (NOT policy^.files.all_specified) THEN
             process_referenced_files;
           IFEND;

           IF policy^.sets <> NIL THEN
             FOR i := LOWERBOUND (policy^.sets^) TO UPPERBOUND (policy^.sets^) DO
               process_referenced_set (policy^.sets^ [i]);
             FOREND;
           IFEND;

           IF policy^.volumes <> NIL THEN
             process_referenced_volumes;
           IFEND;

           policy_number := policy_number + 1;
         IFEND;

       UNTIL policy = NIL;

     PROCEND get_referenced_object_list;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_output_file', EJECT ??

     PROCEDURE initialize_output_file;

       VAR
         default_ring_attributes: amt$ring_attributes;

       default_ring_attributes.r1 := #RING (^default_ring_attributes);
       default_ring_attributes.r2 := #RING (^default_ring_attributes);
       default_ring_attributes.r3 := #RING (^default_ring_attributes);

       clp$open_display_reference (pvt [p$output].value^.file_value^, NIL, fsc$list, default_ring_attributes,
             control_info.output_info, status);
       IF status.normal THEN
         IF control_info.output_info.page_width < minimum_line_size THEN
           control_info.output_info.page_width := minimum_line_size;
           #SPOIL (control_info);
         IFEND;
       ELSE
         EXIT pfp$change_catalog_contents_cmd;
       IFEND;

     PROCEND initialize_output_file;
?? OLDTITLE ??
?? NEWTITLE := 'output_exception_actions', EJECT ??

     PROCEDURE output_exception_actions;

       initialize_message_parameters;

       format_and_output_lines (blank_line_before_and_after, control_info.
             message_templates [mt#applic_exception_policies], control_info);

       IF osc$ecp_login_users IN control_info.union_of_policies THEN
         IF avp$system_administrator () THEN
           control_info.message_parameters [1] := ^administrator_names [system_administrator];

           format_and_output_lines (blank_line_after, control_info.
                 message_templates [mt#login_users_applicable], control_info);

         ELSEIF avp$family_administrator () THEN
           control_info.message_parameters [1] := ^administrator_names [family_administrator];
           format_and_output_lines (blank_line_after, control_info.
                 message_templates [mt#login_users_applicable], control_info);
         IFEND;
       IFEND;

       IF (osc$ecp_enable_matching_image IN control_info.union_of_actions) OR
             (osc$ecp_enable_nonmatch_image IN control_info.union_of_actions) THEN
         format_and_output_lines (blank_line_after, control_info.message_templates [mt#release_option],
               control_info);
       IFEND;

       IF osc$ecp_delete IN control_info.union_of_actions THEN
         format_and_output_lines (blank_line_after, control_info.message_templates [mt#delete_option],
               control_info);
       IFEND;

     PROCEND output_exception_actions;
?? OLDTITLE ??
?? NEWTITLE := 'output_parameters', EJECT ??


     PROCEDURE output_parameters;

       VAR
         delete_damage: string (osc$max_string_size),
         delete_damage_size: integer,
         displayed_damage_condition: boolean;

?? NEWTITLE := 'add_damage_condition', EJECT ??

       PROCEDURE add_damage_condition
         (    damage_condition_string: string ( * <= osc$max_name_size);
          VAR {i/o} displayed_damage_condition: boolean;
          VAR {i/o} delete_damage: string ( * <= osc$max_string_size);
          VAR {i/o} delete_damage_size: integer);

         VAR
           temp_length: integer;

         temp_length := delete_damage_size;
         IF displayed_damage_condition THEN
           STRINGREP (delete_damage, delete_damage_size, delete_damage (1, temp_length), ', ',
                 damage_condition_string (1, clp$trimmed_string_size (damage_condition_string)));
         ELSE
           displayed_damage_condition := TRUE;
           STRINGREP (delete_damage, delete_damage_size, delete_damage (1, temp_length),
                 damage_condition_string (1, clp$trimmed_string_size (damage_condition_string)));
         IFEND;


       PROCEND add_damage_condition;
?? OLDTITLE ??
?? EJECT ??
       initialize_message_parameters;
       displayed_damage_condition := FALSE;
       delete_damage := ' ';
       delete_damage_size := 1;

       IF pvt [p$catalog].value^.kind = clc$keyword THEN
         IF pvt [p$catalog].value^.keyword_value = catalog_option_names [co_all] THEN
           control_info.message_parameters [1] := ^catalog_option_names [co_all];
         ELSEIF pvt [p$catalog].value^.keyword_value = catalog_option_names [co_policies] THEN
           control_info.message_parameters [1] := ^catalog_option_names [co_policies];
         IFEND;
       ELSE
         control_info.message_parameters [1] := ^catalog_option_names [co_list];
       IFEND;

       IF control_info.delete_damage_conditions [1].delete_damage_condition <> $fst$cycle_damage_symptoms
             [] THEN
         IF fsc$media_image_inconsistent IN control_info.delete_damage_conditions [1].
               delete_damage_condition THEN
           add_damage_condition (damage_symptom_names [media_image_inconsistent], displayed_damage_condition,
                 delete_damage, delete_damage_size);
         IFEND;

         IF fsc$parent_catalog_restored IN control_info.delete_damage_conditions [1].
               delete_damage_condition THEN
           add_damage_condition (damage_symptom_names [parent_catalog_restored], displayed_damage_condition,
                 delete_damage, delete_damage_size);
         IFEND;
         IF fsc$respf_modification_mismatch IN control_info.delete_damage_conditions [1].
               delete_damage_condition THEN
           add_damage_condition (damage_symptom_names [respf_modification_mismatch],
                 displayed_damage_condition, delete_damage, delete_damage_size);
         IFEND;
       ELSE
         STRINGREP (delete_damage, delete_damage_size, delete_damage (1, delete_damage_size),
               damage_symptom_names [none]);
       IFEND;

       control_info.message_parameters [2] := ^delete_damage (2, delete_damage_size);

       IF control_info.perform_changes THEN
         control_info.message_parameters [3] := ^boolean_names [true_value];
       ELSE
         control_info.message_parameters [3] := ^boolean_names [false_value];
       IFEND;

       IF control_info.retrieve_info.automatic_retrieval THEN
         control_info.message_parameters [4] := ^boolean_names [true_value];
       ELSE
         control_info.message_parameters [4] := ^boolean_names [false_value];
       IFEND;

       IF pvt [p$retrieve_file_list].specified THEN
         control_info.message_parameters [5] := ^pvt [p$retrieve_file_list].value^.file_value^;
       ELSE
         control_info.message_parameters [5] := ^damage_symptom_names [none];
       IFEND;

       format_and_output_lines (only_template_lines, control_info.message_templates [mt#parameters],
             control_info);

     PROCEND output_parameters;
?? OLDTITLE ??
?? EJECT ??

     VAR
       damage_conditions: ^clt$data_value;

     clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_catalog_parameter, ^pvt, status);

     IF status.normal THEN
       control_info.perform_changes := pvt [p$perform_changes].value^.boolean_value.value;
       control_info.retrieve_info.automatic_retrieval := pvt [p$retrieve_files].value^.boolean_value.value;

       IF control_info.retrieve_info.automatic_retrieval THEN
         control_info.retrieve_info.current_command_file_count := 0;
         control_info.retrieve_info.include_file_info.file_id := amv$nil_file_identifier;
         control_info.retrieve_info.unique_file_name := '';
       IFEND;

       IF pvt [p$delete_damage_condition].specified THEN
         damage_conditions := pvt [p$delete_damage_condition].value;

         WHILE damage_conditions <> NIL DO
           IF damage_conditions^.element_value^.keyword_value =
                 damage_symptom_names [media_image_inconsistent] THEN
             control_info.delete_damage_conditions [1].delete_damage_condition :=
                   control_info.delete_damage_conditions [1].delete_damage_condition +
                   $fst$cycle_damage_symptoms [fsc$media_image_inconsistent];
           ELSEIF damage_conditions^.element_value^.keyword_value =
                 damage_symptom_names [respf_modification_mismatch] THEN
             control_info.delete_damage_conditions [1].delete_damage_condition :=
                   control_info.delete_damage_conditions [1].delete_damage_condition +
                   $fst$cycle_damage_symptoms [fsc$respf_modification_mismatch];
           ELSEIF damage_conditions^.element_value^.keyword_value =
                 damage_symptom_names [parent_catalog_restored] THEN
             control_info.delete_damage_conditions [1].delete_damage_condition :=
                   control_info.delete_damage_conditions [1].delete_damage_condition +
                   $fst$cycle_damage_symptoms [fsc$parent_catalog_restored];
           IFEND;
           damage_conditions := damage_conditions^.link;
         WHILEND;
       IFEND;

       initialize_output_file;

       output_parameters;

       IF (control_info.union_of_actions <> $ost$ecp_actions []) THEN
         output_exception_actions;
       IFEND;

       IF pvt [p$catalog].value^.keyword_value = catalog_option_names [co_all] THEN
         IF avp$system_administrator () THEN
           get_all_families;
         ELSEIF avp$family_administrator () THEN
           get_login_family;
         IFEND;
       ELSEIF pvt [p$catalog].value^.keyword_value = catalog_option_names [co_policies] THEN
         IF osc$ecp_all_files IN control_info.union_of_policies THEN
           format_and_output_lines (blank_line_after, control_info.message_templates [mt#all_referenced],
                 control_info);
           get_all_families;
         ELSE
           get_referenced_object_list;
         IFEND;
       IFEND;
     ELSE
       #SPOIL (control_info);
       EXIT pfp$change_catalog_contents_cmd;
     IFEND;
     #SPOIL (control_info);

   PROCEND evaluate_parameters;
?? OLDTITLE ??
?? NEWTITLE := 'format_and_output_lines', EJECT ??

   PROCEDURE format_and_output_lines
     (    blank_line_option: blank_line_option;
          message_template: ^ost$message_template;
      VAR control_info: chacc_control_info);

?? NEWTITLE := 'prefix_blank_line', EJECT ??

     FUNCTION prefix_blank_line: boolean;

       prefix_blank_line := FALSE;
       CASE blank_line_option OF
       = blank_line_before, blank_line_before_and_after =
         prefix_blank_line := TRUE;
       ELSE
       CASEND;

     FUNCEND prefix_blank_line;
?? OLDTITLE ??
?? NEWTITLE := 'suffix_blank_line', EJECT ??

     FUNCTION suffix_blank_line: boolean;

       suffix_blank_line := FALSE;
       CASE blank_line_option OF
       = blank_line_after, blank_line_before_and_after =
         suffix_blank_line := TRUE;
       ELSE
       CASEND;

     FUNCEND suffix_blank_line;
?? OLDTITLE ??

     VAR
       message_container: ost$status_message,
       message_container_ptr: ^ost$status_message,
       message_line: ^ost$status_message_line,
       message_line_count: ^ost$status_message_line_count,
       message_line_index: 1 .. osc$max_status_message_lines,
       message_line_size: ^ost$status_message_line_size;

{ Design:
{ The process of generating the HELP module used to generate the OUTPUT file of this
{ command does not handle blank lines properly.  Blank lines at the end of the template
{ are deleted and a single blank line at the beginning of the template becomes two
{ blank lines when output.  However, an embedded blank line is retained.  Because of
{ these idiosynchrasies, blank lines are handled outside of the message template.
{
     osp$format_help_message (message_template, ^control_info.message_parameters, osc$max_status_message_line,
           message_container, status);

     IF status.normal THEN
       IF prefix_blank_line () THEN
         clp$put_display (control_info.output_info, ' ', clc$no_trim, status);
       IFEND;

       IF status.normal THEN
         message_container_ptr := ^message_container;
         RESET message_container_ptr;
         NEXT message_line_count IN message_container_ptr;

       /output_lines/
         FOR message_line_index := 1 TO message_line_count^ DO
           NEXT message_line_size IN message_container_ptr;
           NEXT message_line: [message_line_size^] IN message_container_ptr;

           clp$put_display (control_info.output_info, message_line^ (2, (message_line_size^ -1)), clc$no_trim,
                 status);
           IF NOT status.normal THEN
             EXIT pfp$change_catalog_contents_cmd;
           IFEND;
         FOREND /output_lines/;
       IFEND;
     IFEND;

     IF status.normal AND suffix_blank_line () THEN
       clp$put_display (control_info.output_info, ' ', clc$no_trim, status);
     IFEND;

     IF NOT status.normal THEN
       EXIT pfp$change_catalog_contents_cmd;
     IFEND;

   PROCEND format_and_output_lines;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_control_info', EJECT ??

   PROCEDURE initialize_control_info;

?? NEWTITLE := 'initialize_message_templates', EJECT ??

     PROCEDURE initialize_message_templates;

       VAR
         i: message_ordinals,
         ignore_online_manual_name: ost$online_manual_name,
         ignore_natural_language: ost$natural_language,
         message_module: pmt$program_name,
         message_module_ptr: ^ost$help_module;

       osp$find_help_module (pfc$chacc_help_module_name, message_module_ptr, ignore_online_manual_name,
             ignore_natural_language, status);
       IF status.normal THEN
         FOR i := LOWERBOUND (control_info.message_templates)
               TO UPPERBOUND (control_info.message_templates) DO
           osp$find_parameter_prompt (message_module_ptr, parameter_prompt_names [i],
                 control_info.message_templates [i], status);
           IF NOT status.normal THEN
             EXIT pfp$change_catalog_contents_cmd;
           IFEND;
         FOREND;
       ELSE
         EXIT pfp$change_catalog_contents_cmd;
       IFEND;

     PROCEND initialize_message_templates;
?? OLDTITLE ??
?? EJECT ??
     control_info := initial_control_info;

     osp$get_login_user_criteria (control_info.criteria, status);
     IF status.normal THEN
       control_info.criteria.condition := fsc$null_file_access_condition;
       control_info.criteria.family_path_name := osc$null_name;
       control_info.criteria.file := osc$null_name;
       control_info.criteria.mass_storage_class := rmc$unspecified_file_class;
       control_info.criteria.set_name := osc$null_name;
       control_info.criteria.volume_list := NIL;

       control_info.output_info.file_id := amv$nil_file_identifier;
       control_info.retrieve_info.display_info.file_id := amv$nil_file_identifier;

       initialize_message_parameters;
       initialize_message_templates;
       initialize_statistics (control_info.object_stats);
     ELSE
       EXIT pfp$change_catalog_contents_cmd;
     IFEND;

   PROCEND initialize_control_info;

?? OLDTITLE ??
?? NEWTITLE := 'initialize_message_parameters', EJECT ??

   PROCEDURE [INLINE] initialize_message_parameters;

     VAR
       i: integer;

     FOR i := LOWERBOUND (control_info.message_parameters) TO UPPERBOUND (control_info.message_parameters) DO
       control_info.message_parameters [i] := NIL;
     FOREND;

   PROCEND initialize_message_parameters;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_retrieve_info', EJECT ??

   PROCEDURE [INLINE] initialize_retrieve_info;

     VAR
       default_ring_attributes: amt$ring_attributes,
       ignore_length: integer,
       unique_name: ost$name;

     default_ring_attributes.r1 := #RING (^default_ring_attributes);
     default_ring_attributes.r2 := #RING (^default_ring_attributes);
     default_ring_attributes.r3 := #RING (^default_ring_attributes);

     IF pvt [p$retrieve_file_list].specified THEN
       clp$open_display_reference (pvt [p$retrieve_file_list].value^.file_value^, {new_page_procedure} NIL,
             fsc$legible_data, default_ring_attributes, control_info.retrieve_info.display_info, status);
     IFEND;

     IF status.normal THEN
       pmp$get_unique_name (unique_name, status);
       IF status.normal THEN
         STRINGREP (control_info.retrieve_info.unique_file_name, ignore_length, ':$LOCAL.', unique_name);
         #SPOIL (control_info);
         IF control_info.retrieve_info.automatic_retrieval THEN
           clp$open_display_reference (control_info.retrieve_info.unique_file_name, {new_page_procedure} NIL,
                 fsc$legible_scl_include, default_ring_attributes,
                 control_info.retrieve_info.include_file_info, status);
           #SPOIL (control_info);
         IFEND;
       IFEND;
     IFEND;

     IF NOT status.normal THEN
       EXIT pfp$change_catalog_contents_cmd;
     IFEND;

   PROCEND initialize_retrieve_info;
?? OLDTITLE ??
?? NEWTITLE := 'initialize_statistics', EJECT ??

   PROCEDURE initialize_statistics
     (VAR statistics: chacc_statistics);

     statistics.busy_damaged_cycles := 0;
     statistics.damage_cleared := initial_damage_stats;
     statistics.delete_pending := 0;
     statistics.deleted := initial_exception_stats;
     statistics.objects_scanned := initial_object_stats;
     statistics.release_pending := 0;
     statistics.released_with_emi := initial_exception_stats;
     statistics.released_with_eni := initial_exception_stats;

   PROCEND initialize_statistics;
?? OLDTITLE ??
?? NEWTITLE := 'output_applicable_policies', EJECT ??

   PROCEDURE output_applicable_policies;

?? NEWTITLE := 'outap_handler', EJECT ??

     PROCEDURE outap_handler
       (    condition: pmt$condition;
            condition_information: ^pmt$condition_information;
            save_area: ^ost$stack_frame_save_area;
        VAR handler_status: ost$status);

       VAR
         ignore_status: ost$status;

       mmp$delete_scratch_segment (scratch_segment, ignore_status);

     PROCEND outap_handler;
?? OLDTITLE ??
?? EJECT ??

*copy clv$display_variables

     CONST
       max_subtitle_length = 30;

     VAR
       length: integer,
       local_status: ost$status,
       policy_number: ost$positive_integers,
       representation: ^clt$data_representation,
       result: ^clt$data_value,
       scratch_segment: amt$segment_pointer,
       subtitle: string (max_subtitle_length),
       work_area: ^clt$work_area;

     osp$establish_block_exit_hndlr (^outap_handler);

     mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, scratch_segment, status);
     IF status.normal THEN
       work_area := scratch_segment.sequence_pointer;
       policy_number := 1;

       osp$get_policy_list (control_info.exception_policies^, result, work_area);

       WHILE (result <> NIL) DO
         clp$convert_data_to_string (result^.element_value, clc$labeled_elem_representation,
               control_info.output_info.page_width, work_area, representation, status);
         IF status.normal THEN
           STRINGREP (subtitle, length, 'Policy Number:', policy_number);
           clp$put_display (control_info.output_info, subtitle (1, length), clc$trim, status);
           IF status.normal THEN
             clp$new_display_line (control_info.output_info, {skip_count} 1, status);
             IF status.normal THEN
               clp$put_data_representation (control_info.output_info, representation, status);
               result := result^.link;
               IF result <> NIL THEN
                 clp$new_display_line (control_info.output_info, {skip_count} 2, status);
                 IF status.normal THEN
                   policy_number := policy_number + 1;
                 IFEND;
               IFEND;
             IFEND;
           IFEND;
         IFEND;
       WHILEND;
     IFEND;

   PROCEND output_applicable_policies;
?? OLDTITLE ??
?? NEWTITLE := 'output_header', EJECT ??

   PROCEDURE output_header
     (    object: chacc_object_list_entry;
          text: string ( * <= max_header_text_size);
      VAR control_info: chacc_control_info);

     VAR
       fs_path: fst$path,
       fs_path_size: fst$path_size;

     initialize_message_parameters;

     control_info.message_parameters [1] := ^text;

     CASE object.object_kind OF
     = family_object =
       control_info.message_parameters [2] := ^object_names [family_object];
     = catalog_object =
       control_info.message_parameters [2] := ^object_names [catalog_object];
     ELSE
     CASEND;

     IF status.normal THEN
       control_info.message_parameters [3] := ^object.file_reference;
     ELSE
       EXIT pfp$change_catalog_contents_cmd;
     IFEND;

     format_and_output_lines (blank_line_before_and_after, control_info.message_templates [mt#header_line],
           control_info);

   PROCEND output_header;
?? OLDTITLE ??
?? NEWTITLE := 'output_log_message', EJECT ??

   PROCEDURE output_log_message
     (    file: ^fst$file_reference;
          optional_log_text: string ( * );
          message_ordinal: message_ordinals;
          status: ost$status);

     CONST
       asterisks = '*********************************************************************************',
       internal_error = '***************** CHANGE_CATALOG_CONTENTS Internal Error. ***********************',
       write_psr = '****************Please print this job log and submit a PSR. *********************';

     VAR
       ignore_status: ost$status;

     initialize_message_parameters;

     control_info.message_parameters [1] := file;

     format_and_output_lines (blank_line_before_and_after, control_info.message_templates [message_ordinal],
           control_info);

     pmp$log_ascii (asterisks, $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, ignore_status);
     pmp$log_ascii (internal_error, $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, ignore_status);
     pmp$log_ascii (write_psr, $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, ignore_status);

     IF optional_log_text <> ' ' THEN
       pmp$log_ascii (optional_log_text, $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system,
             ignore_status);
     IFEND;

     IF file <> NIL THEN
       pmp$log_ascii (file^(1, clp$trimmed_string_size (file^)),
             $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, ignore_status);
     IFEND;

     IF NOT status.normal THEN
       osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
     IFEND;

     pmp$log_ascii (asterisks, $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, ignore_status);

   PROCEND output_log_message;
?? OLDTITLE ??
?? NEWTITLE := 'output_object_warning', EJECT ??

   PROCEDURE output_object_warning
     (    status_condition: string ( * );
          path: ^fst$file_reference);

     initialize_message_parameters;

     control_info.message_parameters [1] := ^status_condition;
     control_info.message_parameters [2] := ^path^ (1, clp$trimmed_string_size (path^));

     format_and_output_lines (blank_line_after, control_info.message_templates [mt#object_warning],
           control_info);

   PROCEND output_object_warning;
?? OLDTITLE ??
?? NEWTITLE := 'output_summary', EJECT ??

   PROCEDURE output_summary
     (    object_stats: chacc_statistics);


     VAR
       most_significant_digit: ost$positive_integers,
       number_of_digits: ost$positive_integers;

?? NEWTITLE := 'output_damage_summary', EJECT ??

     PROCEDURE output_damage_summary;

       VAR
         i: damage_symptoms,
         values: array [media_image_inconsistent .. respf_modification_mismatch] of string (8);

       initialize_message_parameters;

       clp$convert_integer_to_rjstring (count_damage_conditions (object_stats.damage_cleared), {radix} 10,
             {include_radix_specifier} FALSE, ' ', total_string, status);
       IF status.normal THEN
         control_info.message_parameters [1] := ^total_string (most_significant_digit, number_of_digits);
         FOR i := LOWERBOUND (values) TO UPPERBOUND (values) DO
           CASE i OF
           = media_image_inconsistent =
             clp$convert_integer_to_rjstring (object_stats.damage_cleared.media_image_inconsistent,
                   {radix} 10, {include_radix_specifier} FALSE, ' ', values [i], status);
           = parent_catalog_restored =
             clp$convert_integer_to_rjstring (object_stats.damage_cleared.parent_catalog_restored, {radix} 10,
                   {include_radix_specifier} FALSE, ' ', values [i], status);
           = respf_modification_mismatch =
             clp$convert_integer_to_rjstring (object_stats.damage_cleared.respf_modification_mismatch,
                   {radix} 10, {include_radix_specifier} FALSE, ' ', values [i], status);
           ELSE
           CASEND;

           IF status.normal THEN
             control_info.message_parameters [$INTEGER (i) + 1] := ^values [i] (most_significant_digit,
                   number_of_digits);
           ELSE
             EXIT pfp$change_catalog_contents_cmd;
           IFEND;
         FOREND;
         format_and_output_lines (blank_line_after, control_info.message_templates [mt#conditions_cleared],
               control_info);

       ELSE
         EXIT pfp$change_catalog_contents_cmd;
       IFEND;

     PROCEND output_damage_summary;
?? OLDTITLE ??
?? NEWTITLE := 'output_exception_summary', EJECT ??

     PROCEDURE output_exception_summary
       (    statistics: chacc_exception_statistics;
            message_template: ^ost$message_template);

       VAR
         i: exception_conditions,
         values: array [exception_conditions] of string (8);

       initialize_message_parameters;

       clp$convert_integer_to_rjstring (count_exceptions (statistics), {radix} 10,
             {include_radix_specifier} FALSE, ' ', total_string, status);
       IF status.normal THEN
         control_info.message_parameters [1] := ^total_string (most_significant_digit, number_of_digits);
         format_and_output_lines (only_template_lines, message_template, control_info);
         FOR i := LOWERBOUND (values) TO UPPERBOUND (values) DO
           CASE i OF
           = media_missing =
             clp$convert_integer_to_rjstring (statistics.media_missing, {radix} 10,
                   {include_radix_specifier} FALSE, ' ', values [i], status);
           = undefined_data =
             clp$convert_integer_to_rjstring (statistics.undefined_data, {radix} 10,
                   {include_radix_specifier} FALSE, ' ', values [i], status);
           = volume_unavailable =
             clp$convert_integer_to_rjstring (statistics.volume_unavailable, {radix} 10,
                   {include_radix_specifier} FALSE, ' ', values [i], status);
           ELSE
           CASEND;

           IF status.normal THEN
             control_info.message_parameters [$INTEGER (i) + 1] := ^values [i] (most_significant_digit,
                   number_of_digits);
           ELSE
             EXIT pfp$change_catalog_contents_cmd;
           IFEND;
         FOREND;
         format_and_output_lines (blank_line_after, control_info.message_templates [mt#counts_by_condition],
               control_info);

       ELSE
         EXIT pfp$change_catalog_contents_cmd;
       IFEND;

     PROCEND output_exception_summary;
?? OLDTITLE ??
?? NEWTITLE := 'output_integer', EJECT ??

     PROCEDURE output_integer
       (    blank_line_option: blank_line_option;
            integer_value: ost$non_negative_integers;
            message_template: ^ost$message_template);

       VAR
         i: exception_conditions,
         values: array [exception_conditions] of string (8);

       initialize_message_parameters;

       clp$convert_integer_to_rjstring (integer_value, {radix} 10, {include_radix_specifier} FALSE, ' ',
             total_string, status);
       IF status.normal THEN
         control_info.message_parameters [1] := ^total_string (most_significant_digit, number_of_digits);
         format_and_output_lines (blank_line_option, message_template, control_info);
       ELSE
         EXIT pfp$change_catalog_contents_cmd;
       IFEND;

     PROCEND output_integer;
?? OLDTITLE ??
?? EJECT ??

     TYPE
       scanned_objects = (totals, families, master_catalogs, subcatalogs, files, cycles,
             maximum_catalog_nesting, maximum_files_per_catalog, maximum_cycles_per_file);

     VAR
       i: scanned_objects,
       test_string: ost$string,
       total_deleted: ost$non_negative_integers,
       total: ost$non_negative_integers,
       total_released: ost$non_negative_integers,
       total_string: string (8),
       values: array [scanned_objects] of string (8);

     initialize_message_parameters;

     FOR i := LOWERBOUND (values) TO UPPERBOUND (values) DO
       CASE i OF
       = totals =
         total := count_scanned (object_stats.objects_scanned);

         clp$convert_integer_to_rjstring (total, {radix} 10, {include_radix_specifier} FALSE, ' ', values [i],
               status);
         IF status.normal THEN
           clp$convert_integer_to_string (total, {radix} 10, {include_radix_specifier} FALSE, test_string,
                 status);
           IF status.normal THEN
             number_of_digits := test_string.size;
             most_significant_digit := STRLENGTH (values [i]) - number_of_digits + 1;
           IFEND;
         IFEND;
       = families =
         clp$convert_integer_to_rjstring (object_stats.objects_scanned.families, {radix} 10,
               {include_radix_specifier} FALSE, ' ', values [i], status);
       = master_catalogs =
         clp$convert_integer_to_rjstring (object_stats.objects_scanned.master_catalogs, {radix} 10,
               {include_radix_specifier} FALSE, ' ', values [i], status);
       = subcatalogs =
         clp$convert_integer_to_rjstring (object_stats.objects_scanned.subcatalogs, {radix} 10,
               {include_radix_specifier} FALSE, ' ', values [i], status);
       = files =
         clp$convert_integer_to_rjstring (object_stats.objects_scanned.files, {radix} 10,
               {include_radix_specifier} FALSE, ' ', values [i], status);
       = cycles =
         clp$convert_integer_to_rjstring (object_stats.objects_scanned.cycles, {radix} 10,
               {include_radix_specifier} FALSE, ' ', values [i], status);
       = maximum_catalog_nesting =
         clp$convert_integer_to_rjstring (object_stats.objects_scanned.maximum_catalog_nesting, {radix} 10,
               {include_radix_specifier} FALSE, ' ', values [i], status);
       = maximum_files_per_catalog =
         clp$convert_integer_to_rjstring (object_stats.objects_scanned.maximum_files_per_catalog, {radix} 10,
               {include_radix_specifier} FALSE, ' ', values [i], status);
       = maximum_cycles_per_file =
         clp$convert_integer_to_rjstring (object_stats.objects_scanned.maximum_cycles_per_file, {radix} 10,
               {include_radix_specifier} FALSE, ' ', values [i], status);
       ELSE
       CASEND;

       IF status.normal THEN
         control_info.message_parameters [$INTEGER (i) + 1] := ^values [i] (most_significant_digit,
               number_of_digits);
       ELSE
         EXIT pfp$change_catalog_contents_cmd;
       IFEND;
     FOREND;

     format_and_output_lines (blank_line_after, control_info.message_templates [mt#objects_scanned],
           control_info);

     initialize_message_parameters;

     output_damage_summary;

     output_integer (blank_line_after, object_stats.busy_damaged_cycles, control_info.
           message_templates [mt#busy_damaged_cycles]);

     total_deleted := count_exceptions (object_stats.deleted);
     total_released := count_exceptions (object_stats.released_with_emi) +
           count_exceptions (object_stats.released_with_eni);

     output_integer (only_template_lines, total_deleted + total_released, control_info.
           message_templates [mt#total_cycles_applicable]);

     output_integer (only_template_lines, total_released, control_info.
           message_templates [mt#total_cycles_released]);

     initialize_message_parameters;

     output_exception_summary (object_stats.released_with_emi, control_info.
           message_templates [mt#emi_cycles_released]);

     output_exception_summary (object_stats.released_with_eni, control_info.
           message_templates [mt#eni_cycles_released]);

     output_exception_summary (object_stats.deleted, control_info.message_templates [mt#cycles_deleted]);

     output_integer (only_template_lines, object_stats.delete_pending, control_info.
           message_templates [mt#busy_cycles_deleted]);

     output_integer (only_template_lines, object_stats.release_pending, control_info.
           message_templates [mt#busy_cycles_released]);

     add_one (control_info.summary_count);

   PROCEND output_summary;
?? OLDTITLE ??
?? NEWTITLE := 'output_undefined_object_msg', EJECT ??

   PROCEDURE output_undefined_object_msg
     (    object_kind: object_kind;
          path: fst$file_reference);

     initialize_message_parameters;

     control_info.message_parameters [1] := ^object_names [object_kind];
     control_info.message_parameters [2] := ^path (1, clp$trimmed_string_size (path));

     format_and_output_lines (blank_line_after, control_info.message_templates [mt#undefined_object],
           control_info);

   PROCEND output_undefined_object_msg;
?? OLDTITLE ??
?? NEWTITLE := 'were_changes_made', EJECT ??

   PROCEDURE were_changes_made;

     initialize_message_parameters;

     IF (count_exceptions (control_info.object_stats.deleted) +
           count_exceptions (control_info.object_stats.released_with_emi) +
           count_exceptions (control_info.object_stats.released_with_eni) +
           count_damage_conditions (control_info.object_stats.damage_cleared) = 0) THEN

       format_and_output_lines (only_template_lines, control_info.message_templates [mt#no_changes],
             control_info);
     IFEND;

   PROCEND were_changes_made;
?? OLDTITLE ??
?? EJECT ??

   status.normal := TRUE;

   initialize_control_info;
   #SPOIL (control_info);
   osp$establish_block_exit_hndlr (^chacc_cmd_block_exit_handler);

   allocate_catalog_segments;

   evaluate_parameters;

   IF (control_info.union_of_actions <> $ost$ecp_actions []) OR
         (control_info.delete_damage_conditions [1].delete_damage_condition <> $fst$cycle_damage_symptoms [])
         THEN

     IF ($ost$ecp_actions [osc$ecp_enable_matching_image, osc$ecp_enable_nonmatch_image] *
           control_info.union_of_actions) <> $ost$ecp_actions [] THEN
       initialize_retrieve_info;
     IFEND;

     change_catalog_contents;

     IF (control_info.union_of_actions <> $ost$ecp_actions []) THEN
       IF avp$system_administrator () OR avp$family_administrator () THEN
         format_and_output_lines (blank_line_before_and_after, control_info.
               message_templates [mt#administrator_notes], control_info);
         output_applicable_policies;
       ELSE
         format_and_output_lines (blank_line_before_and_after, control_info.message_templates [mt#user_notes],
               control_info);
       IFEND;
     IFEND;
   ELSE
     osp$set_status_condition (ose$no_applicable_policies, status);
   IFEND;

 PROCEND pfp$change_catalog_contents_cmd;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pfp$set_cycle_damage_cmd ', EJECT ??

 PROCEDURE [XDCL, #GATE] pfp$set_cycle_damage_cmd
   (    parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE set_cycle_damage_conditions (
{   files, file, f: list of file = $required
{   password, pw: (SECURE) name = $optional
{   damage_conditions, dc: list of key
{       (media_image_inconsistent, mii)
{       (parent_catalog_restored, pcr)
{       (respf_modification_mismatch, rmm)
{     keyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: 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 .. 6] of clt$keyword_specification,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 7, 29, 23, 11, 9, 788],
    clc$command, 8, 4, 2, 0, 0, 0, 4, ''], [
    ['DAMAGE_CONDITIONS              ',clc$nominal_entry, 3],
    ['DC                             ',clc$abbreviation_entry, 3],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$alias_entry, 1],
    ['FILES                          ',clc$nominal_entry, 1],
    ['PASSWORD                       ',clc$nominal_entry, 2],
    ['PW                             ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 245,
  clc$required_parameter, 0, 0],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$list_type], [229, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [6], [
      ['MEDIA_IMAGE_INCONSISTENT       ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['MII                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['PARENT_CATALOG_RESTORED        ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['PCR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['RESPF_MODIFICATION_MISMATCH    ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['RMM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3]]
      ]
    ],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

   CONST
     p$files = 1,
     p$password = 2,
     p$damage_conditions = 3,
     p$status = 4;

   VAR
     pvt: array [1 .. 4] of clt$parameter_value;

   VAR
     current_file: ^clt$data_value,
     damage_conditions: ^clt$data_value,
     damage_condition_set: fst$cycle_damage_symptoms,
     password: pft$password;

   clp$evaluate_parameters (parameter_list, #SEQ (pdt), {check_procedure} NIL, ^pvt, status);

   IF status.normal THEN
     damage_conditions := pvt [p$damage_conditions].value;
     damage_condition_set := $fst$cycle_damage_symptoms [];
     WHILE damage_conditions <> NIL DO
       IF damage_conditions^.element_value^.keyword_value =
             damage_symptom_names [media_image_inconsistent] THEN
         damage_condition_set := damage_condition_set + $fst$cycle_damage_symptoms
               [fsc$media_image_inconsistent];
       ELSEIF damage_conditions^.element_value^.keyword_value =
             damage_symptom_names [respf_modification_mismatch] THEN
         damage_condition_set := damage_condition_set + $fst$cycle_damage_symptoms
               [fsc$respf_modification_mismatch];
       ELSEIF damage_conditions^.element_value^.keyword_value =
             damage_symptom_names [parent_catalog_restored] THEN
         damage_condition_set := damage_condition_set + $fst$cycle_damage_symptoms
               [fsc$parent_catalog_restored];
       IFEND;
       damage_conditions := damage_conditions^.link;
     WHILEND;

     IF pvt [p$password].specified THEN
       password := pvt [p$password].value^.name_value;
     ELSE
       password := osc$null_name;
     IFEND;

     current_file := pvt [p$files].value;
     WHILE (current_file <> NIL) AND (current_file^.element_value <> NIL) DO
       fsp$change_cycle_damage (current_file^.element_value^.file_value^, password, damage_condition_set,
             status);
       IF status.normal THEN
         current_file := current_file^.link;
       ELSE
         RETURN;
       IFEND;
     WHILEND;
   IFEND;

 PROCEND pfp$set_cycle_damage_cmd;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pfp$get_file_list ', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$get_file_list
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE get_file_list, getfl (
{   file, f: file = $required
{   variable_name, vn: name = $required
{   list_size, ls: integer 1..1000 = 100
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [94, 3, 3, 21, 4, 21, 262],
    clc$command, 7, 4, 2, 0, 0, 0, 4, ''], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['LIST_SIZE                      ',clc$nominal_entry, 3],
    ['LS                             ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['VARIABLE_NAME                  ',clc$nominal_entry, 2],
    ['VN                             ',clc$abbreviation_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, 1000, 10],
    '100'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$variable_name = 2,
      p$list_size = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

{ TYPE
{   file_list: list of file
{ TYPEND

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    type_specification : [STATIC, READ, cls$declaration_section] record
      header: clt$type_specification_header,
      name: string (9),
      qualifier: clt$list_type_qualifier_v2,
      element_type_spec: record
        header: clt$type_specification_header,
      recend,
    recend := [
      [1, 9, clc$list_type], 'FILE_LIST', [3, 0, clc$max_list_size, 0, FALSE
  , FALSE],
        [[1, 0, clc$file_type]]
      ];

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      file_attachment: ^fst$attachment_options,
      file_id: amt$file_identifier,
      file_position: amt$file_position,
      first_non_blank: string(1),
      i: ost$positive_integers,
      ignore_byte_address: amt$file_byte_address,
      ignore_status: ost$status,
      j: ost$positive_integers,
      link_list_node: boolean,
      list_node: ^clt$data_value,
      path: fst$path,
      transfer_count: amt$transfer_count,
      list_variable: ^clt$data_value,
      work_area: ^^clt$work_area;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF status.normal THEN
      PUSH file_attachment: [1 .. 2];

      file_attachment^ [1].selector := fsc$access_and_share_modes;
      file_attachment^ [1].access_modes.selector := fsc$specific_access_modes;
      file_attachment^ [1].share_modes.selector := fsc$specific_share_modes;
      file_attachment^ [1].access_modes.value := $fst$file_access_options [fsc$read];
      file_attachment^ [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];

      file_attachment^ [2].selector := fsc$private_read;
      file_attachment^ [2].private_read := FALSE;

      fsp$open_file (pvt [p$file].value^.file_value^, {access_level} amc$record, file_attachment,
            {default_creation_attributes} NIL, {mandated_creation_attributes} NIL, {attribute_validation} NIL,
            {override_attributes} NIL, file_id, status);

      IF status.normal THEN
        clp$get_work_area (#RING (^work_area), work_area, status);
        IF status.normal THEN
          clp$make_list_value (work_area^, list_node);
          list_variable := list_node;
          link_list_node := FALSE;
          clp$delete_variable (pvt [p$variable_name].value^.name_value, ignore_status);

        /file_loop/
          FOR i := 1 TO pvt [p$list_size].value^.integer_value.value DO
            amp$get_next (file_id, ^path, fsc$max_path_size, transfer_count, ignore_byte_address,
                  file_position, status);

            IF status.normal AND (file_position <> amc$eoi) THEN
              first_non_blank := ' ';
              IF transfer_count > 0 THEN
              /find_first_non_blank/
                FOR j := 1 to transfer_count DO
                  IF path (j, 1) <> ' ' THEN
                    first_non_blank := path (j, 1);
                    EXIT /find_first_non_blank/;
                  IFEND;
                FOREND /find_first_non_blank/;
              IFEND;
              IF first_non_blank = ':' THEN
                IF link_list_node THEN
                  clp$make_list_value (work_area^, list_node^.link);
                  list_node := list_node^.link;
                ELSE
                  link_list_node := TRUE;
                IFEND;
                clp$make_file_value (path (1, transfer_count), work_area^, list_node^.element_value);
              IFEND;
            ELSEIF (file_position = amc$eoi) AND (i = 1) THEN
              CYCLE /file_loop/; {Return ame$input_after_eoi status after next get}
            ELSEIF NOT status.normal THEN
              RETURN;
            ELSE
              EXIT /file_loop/;
            IFEND;
          FOREND /file_loop/;
          clp$create_procedure_variable (pvt [p$variable_name].value^.name_value, clc$local_scope,
                clc$read_write, clc$immediate_evaluation, #SEQ (type_specification), list_variable, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND pfp$get_file_list;

MODEND pfm$change_catalog_contents;
*DECK DECK=PFM$COMPUTE_CHECKSUM EXPAND=TRUE
pfm$compute_checksum  ident
.
. This module computes checksums for the permanent file manager.
.
. Registers used in this module are defined as follows:
.
index    equ       8         .index into the data to checksum
                             .This is the offset from the start of the data
p_loc    equ       8         .register pointing to location of data
remaining_bytes    equ  9    .register for number of remaining_bytes of data
result   equ       10        .register for checksum result
data     equ       11        .register for data
amacscr  equ       15        .scratch register for macros
.
index    atrib     #regtyp,#xreg
p_loc    atrib     #regtyp,#areg
remaining_bytes    atrib     #regtyp,#xreg
result   atrib     #regtyp,#xreg
data     atrib     #regtyp,#xreg
amacscr  atrib     #regtyp,#areg
.
         page
. COMMON DECKS
*copy OSA$CYBIL_INTERFACE
         page
*copy OSA$BASIC_REGISTER_EQUATES
         page
.______________________________________________________________
. Name:
.        pfp$compute_checksum
.Purpose:
.        This function computes a checksum for  data.
. Input:
.        loc: Pointer to data to checksum.
.        size: Size in bytes of data to checksum.
. Output:
.        sum: Integer value of checksum for data.
._________________________________________________________
.
.
.        PROCEDURE [XREF] pfp$compute_checksum (loc: ^cell;
.                  size: integer;
.                  VAR sum: integer)
.
.
pfp$compute_checksum     procedur  gated
loc      param     val,pointer
size     param     val,integer
sum      param     ref,integer
.
.
         ploada    p_loc,loc             . get PVA of data to checksum
         ploadx    remaining_bytes,size  . get number of bytes to checksum
         entp      index,0               . index := 0
         entp      result,0              . result := 0
.
looptest brreq     remaining_bytes,x0,done  .IF remaining_bytes = 0 goto DONE
         decr      remaining_bytes,8     . remaining_bytes := remaining_bytes - 8
         brrgt     x0,remaining_bytes,lastbyte .IF remaining_bytes<0 THEN goto lastbyte
         lbyts,8   data,p_loc,index,0    . Load the current word into data
         incr      index,8               . Index := index + 8
         xorx      result,data           . result := exclusive or of result and data
         brreq     x0,x0,looptest        . goto looptest
.
lastbyte entp      x0,7                  . Handle the last bytes
         addr      x0,remaining_bytes    . remaining_bytes := 7 + remaining_bytes
         lbyt,x0   data,p_loc,index,0    . Load the remaining_bytes into data
         xorx      result,data           . result := exclusive or of result and data
done     bss        0                    . All bytes processed
.
         brrne     result,x0,zeroend     . IF result <> 0 goto zeroend
         ente      result,6753(16)       . reset result to arbitrary non-zero number
zeroend  bss        0
         pstorxp   result,sum            . Store result into sum before returning
         return
         page
         align     0,8                   . Allows code to be callable
         use       binding
         address   ce,pfp$compute_checksum
         end                             . pfm$compute_checksum
*DECK DECK=PFM$CONVERT_STRING_TO_PF_PATH EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Permanent Files : Convert String to PF Path' ??
MODULE pfm$convert_string_to_pf_path;

{ PURPOSE:
{   This module contains the routines needed to convert a string to a pft$path.
{   The caller of PFP$CONVERT_FS_PATH_TO_PF_PATH must first have called
{   PFP$CONVERT_STRING_TO_FS_PATH, since the format of the fs_path_string must be that
{   of an fst$evaluated_file_reference path_structure.

?? NEWTITLE := '  Global Declarations Referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_file_reference
*copyc fsc$max_path_size
*copyc fst$path_element_size
*copyc fst$path_index
?? POP ??
*copyc clp$convert_cyc_ref_to_cyc_sel
*copyc clp$setup_and_parse_file_ref
*copyc clp$trimmed_string_size
*copyc clv$user_identification
*copyc osp$set_status_abnormal

?? TITLE := 'pfp$convert_string_to_fs_path', EJECT ??
*copyc pfh$convert_string_to_fs_path

  PROCEDURE [XDCL, #GATE] pfp$convert_string_to_fs_path
    (    str: string ( * );
     VAR fs_path_string: string (fsc$max_path_size);
     VAR number_of_path_elements: fst$number_of_path_elements;
     VAR cycle_reference: fst$cycle_reference;
     VAR open_position: fst$open_position;
     VAR status: ost$status);

    VAR
      evaluated_file_reference: fst$evaluated_file_reference;


    status.normal := TRUE;

    clp$setup_and_parse_file_ref (str, $clt$file_ref_parsing_options [clc$command_file_ref_allowed],
          clv$user_identification, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fs_path_string := evaluated_file_reference.path_structure
          (1, evaluated_file_reference.path_structure_size);
    number_of_path_elements := evaluated_file_reference.number_of_path_elements;
    cycle_reference := evaluated_file_reference.cycle_reference;
    open_position := evaluated_file_reference.path_handle_info.path_handle.open_position;

  PROCEND pfp$convert_string_to_fs_path;
?? TITLE := 'pfp$convert_fs_path_to_pf_path', EJECT ??
*copyc pfh$convert_fs_path_to_pf_path

  PROCEDURE [XDCL, #GATE] pfp$convert_fs_path_to_pf_path
    (    fs_path_string: string (fsc$max_path_size);
     VAR pf_path: {input, output} ^pft$path;
         cycle_reference: fst$cycle_reference;
     VAR cycle_selector: clt$cycle_selector;
     VAR status: ost$status);

    VAR
      i: fst$number_of_path_elements,
      local_status: ost$status,
      path_element_size: integer,
      path_index: fst$path_index;


  /convert/
    BEGIN
      local_status.normal := TRUE;

      path_index := 1;
      FOR i := 1 TO UPPERBOUND (pf_path^) DO
        path_element_size := $INTEGER (fs_path_string (path_index));
        IF (path_element_size < 0) OR (path_element_size > fsc$max_path_element_size) THEN
          osp$set_status_abnormal ('CL', cle$improper_fs_path_structure,
                fs_path_string (1, clp$trimmed_string_size (fs_path_string)), local_status);
          EXIT /convert/;
        IFEND;
        pf_path^ [i] := fs_path_string (path_index + 1, path_element_size);
        path_index := path_index + path_element_size + 1;
      FOREND;

      clp$convert_cyc_ref_to_cyc_sel (cycle_reference, cycle_selector);
    END /convert/;

    status := local_status;

  PROCEND pfp$convert_fs_path_to_pf_path;

MODEND pfm$convert_string_to_pf_path;

*DECK DECK=PFM$DISPLAY_CATALOGS EXPAND=TRUE
MODULE pfm$display_catalogs;
MODEND pfm$display_catalogs;
*DECK DECK=PFM$EXTRACT_FILE_LIST EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'PFM$EXTRACT_FILE_LIST' ??
MODULE pfm$extract_file_list;
?? PUSH (LISTEXT := ON) ??
*copyc pfe$error_condition_codes

*copyc amp$get_next
*copyc clp$change_variable
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc clp$get_variable
*copyc clp$get_work_area
*copyc clp$make_file_value
*copyc clp$make_list_value
*copyc clp$validate_name
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$set_status_condition
?? POP ??

?? OLDTITLE ??
?? NEWTITLE := 'PFP$EXTRACT_FILE_LIST', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$extract_file_list
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE extract_file_list_pdt (
{   input, i: file = $required
{   catalogs_moved, cm: (VAR, BY_NAME) list 0 .. clc$max_list_size of file = ..
{ $optional
{   catalogs_skipped, cs: (VAR, BY_NAME) list 0 .. clc$max_list_size of file ..
{ = $optional
{   files_moved, fm: (VAR, BY_NAME) list 0 .. clc$max_list_size of file = $op..
{ tional
{   files_skipped, fs: (VAR, BY_NAME) list 0 .. clc$max_list_size of file = $..
{ optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 5, 13, 14, 4, 5, 402],
    clc$command, 11, 6, 1, 0, 0, 4, 6, ''], [
    ['CATALOGS_MOVED                 ',clc$nominal_entry, 2],
    ['CATALOGS_SKIPPED               ',clc$nominal_entry, 3],
    ['CM                             ',clc$abbreviation_entry, 2],
    ['CS                             ',clc$abbreviation_entry, 3],
    ['FILES_MOVED                    ',clc$nominal_entry, 4],
    ['FILES_SKIPPED                  ',clc$nominal_entry, 5],
    ['FM                             ',clc$abbreviation_entry, 4],
    ['FS                             ',clc$abbreviation_entry, 5],
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 19, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 19, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 19, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 19, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [3, 0, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 3
    [[1, 0, clc$list_type], [3, 0, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 4
    [[1, 0, clc$list_type], [3, 0, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 5
    [[1, 0, clc$list_type], [3, 0, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$input = 1,
      p$catalogs_moved = 2,
      p$catalogs_skipped = 3,
      p$files_moved = 4,
      p$files_skipped = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      access_mode: clt$data_access_mode,
      attachment_options_p: ^fst$attachment_options,
      byte_adr: amt$file_byte_address,
      catalog_object: boolean,
      catalogs_moved: ^clt$data_value,
      catalogs_moved_head: ^clt$data_value,
      catalogs_skipped: ^clt$data_value,
      catalogs_skipped_head: ^clt$data_value,
      class: clt$variable_class,
      cycle_released: boolean,
      evaluated_file_reference: fst$evaluated_file_reference,
      evaluation_method: clt$expression_eval_method,
      file_pos: amt$file_position,
      files_moved: ^clt$data_value,
      files_moved_head: ^clt$data_value,
      files_skipped: ^clt$data_value,
      files_skipped_head: ^clt$data_value,
      i: integer,
      input_fid: amt$file_identifier,
      input_line: fst$path,
      j: integer,
      name_valid: boolean,
      object_moved: boolean,
      output_fid: amt$file_identifier,
      output_line: fst$path,
      search_column: 0 .. fsc$max_path_size,
      tran_cnt: amt$transfer_count,
      type_spec: ^clt$type_specification,
      valid_listing: boolean,
      validated_name: ost$name,
      work_area: ^^clt$work_area;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_work_area (#RING (^work_area), work_area, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    {
    { Get pointers to and initialize specified VAR parameters.
    {
    IF pvt [p$catalogs_moved].specified THEN
      clp$get_variable (pvt [p$catalogs_moved].variable^, work_area^, class, access_mode, evaluation_method,
            type_spec, catalogs_moved, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF catalogs_moved = NIL THEN
        clp$make_list_value (work_area^, catalogs_moved);
      ELSE
        catalogs_moved^.element_value := NIL;
        catalogs_moved^.link := NIL;
      IFEND;
      catalogs_moved_head := catalogs_moved;
    IFEND;

    IF pvt [p$catalogs_skipped].specified THEN
      clp$get_variable (pvt [p$catalogs_skipped].variable^, work_area^, class, access_mode, evaluation_method,
            type_spec, catalogs_skipped, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF catalogs_skipped = NIL THEN
        clp$make_list_value (work_area^, catalogs_skipped);
      ELSE
        catalogs_skipped^.element_value := NIL;
        catalogs_skipped^.link := NIL;
      IFEND;
      catalogs_skipped_head := catalogs_skipped;
    IFEND;

    IF pvt [p$files_moved].specified THEN
      clp$get_variable (pvt [p$files_moved].variable^, work_area^, class, access_mode, evaluation_method,
            type_spec, files_moved, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF files_moved = NIL THEN
        clp$make_list_value (work_area^, files_moved);
      ELSE
        files_moved^.element_value := NIL;
        files_moved^.link := NIL;
      IFEND;
      files_moved_head := files_moved;
    IFEND;

    IF pvt [p$files_skipped].specified THEN
      clp$get_variable (pvt [p$files_skipped].variable^, work_area^, class, access_mode, evaluation_method,
            type_spec, files_skipped, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF files_skipped = NIL THEN
        clp$make_list_value (work_area^, files_skipped);
      ELSE
        files_skipped^.element_value := NIL;
        files_skipped^.link := NIL;
      IFEND;
      files_skipped_head := files_skipped;
    IFEND;

    clp$evaluate_file_reference (pvt [p$input].value^.file_value^, $clt$file_ref_parsing_options [], FALSE,
          evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH attachment_options_p: [1 .. 1];
    attachment_options_p^ [1].selector := fsc$create_file;
    attachment_options_p^ [1].create_file := FALSE;

    fsp$open_file (pvt [p$input].value^.file_value^, amc$record, attachment_options_p, NIL, NIL, NIL, NIL,
          input_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_next (input_fid, ^input_line, #SIZE (input_line), tran_cnt, byte_adr, file_pos, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    {
    { Verify input file is the correct format. Search for the string 'MOVE_CLASSES Par' as the
    {  first character on one of the first five lines in the file.  Initialize the variable
    { search_column to be the column the "M" in 'MOVE_CLASSES' is found.
    {
    i := 0;
    valid_listing := FALSE;

  /verify_listing/
    WHILE (file_pos <> amc$eoi) AND (i < 5) DO

    /locate_header/
      FOR j := 1 TO tran_cnt DO
        IF input_line (j) <> ' ' THEN
          IF input_line (j) = 'M' THEN
            IF input_line (j, 16) = 'MOVE_CLASSES Par' THEN
              valid_listing := TRUE;
              search_column := j;
              EXIT /verify_listing/;
            IFEND;
          IFEND;
          EXIT /locate_header/;
        IFEND;
      FOREND /locate_header/;
      i := i + 1;
      amp$get_next (input_fid, ^input_line, #SIZE (input_line), tran_cnt, byte_adr, file_pos, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    WHILEND /verify_listing/;

    IF NOT valid_listing THEN
      osp$set_status_condition (pfe$invalid_input_file_format, status);
      RETURN;
    IFEND;

    {
    { Read each line of the input file until eoi is encountered.
    { A path is processed when a colon (i.e. ":") is found in the search_column.
    { If two adjacent periods are detected the path is continued on the next line.
    { The path is reconstructed in the output_line variable exactly as it appears
    { in the listing without any leading blanks or continuation marks.
    {
    WHILE file_pos <> amc$eoi DO
      object_moved := FALSE;
      cycle_released := FALSE;

      IF (input_line (search_column) = ':') THEN
        output_line := ' ';
        i := search_column;
        j := 1;
        WHILE input_line (i) <> ' ' DO
          IF (input_line (i, 2) = '..') THEN
            input_line := ' ';
            amp$get_next (input_fid, ^input_line, #SIZE (input_line), tran_cnt, byte_adr, file_pos, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            i := search_column;
          ELSE
            output_line (j) := input_line (i);
            i := i + 1;
            j := j + 1;
          IFEND;
        WHILEND;
        j := j - 1;

        {
        { The line following the path will indicate whether the move was successful or not.
        { If successful the "Size:" field will be on the this line, if not, an error
        { message will be found here.  An error message will begin with '--'.
        {
        amp$get_next (input_fid, ^input_line, #SIZE (input_line), tran_cnt, byte_adr, file_pos, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF input_line (search_column, 2) = '--' THEN
          WHILE (file_pos <> amc$eoi) AND (input_line (search_column) <> ' ') DO
            input_line := ' ';
            amp$get_next (input_fid, ^input_line, #SIZE (input_line), tran_cnt, byte_adr, file_pos, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          WHILEND;
          object_moved := FALSE;
        ELSEIF input_line (search_column + 3, 5) = 'Size:' THEN
          IF input_line (search_column + 65, 7) = 'OFFLINE' THEN
            cycle_released := TRUE;
          ELSE
            object_moved := TRUE;
          IFEND;
        IFEND;

        {
        { The last element in the path will indicate the type of object involved.
        { A file object will always have a cycle number as the last element and a
        { catalog object will not.  This code will execute clp$validate_name on the
        { last element in the path to determine if it is a catalog.
        {
        catalog_object := FALSE;
        i := j;
        WHILE (i > 0) AND (output_line (i) <> ' ') AND (output_line (i) <> '.') DO
          i := i - 1;
        WHILEND;
        IF output_line (i) = '.' THEN
          clp$validate_name (output_line (i + 1, j - i), validated_name, name_valid);
          IF name_valid THEN
            catalog_object := TRUE;
          IFEND;
        ELSE
          catalog_object := TRUE;
        IFEND;

        {
        { Add the path to the approriate VAR parameter.
        {
        {
        IF catalog_object THEN
          IF pvt [p$catalogs_moved].specified AND object_moved THEN
            IF catalogs_moved^.element_value <> NIL THEN
              clp$make_list_value (work_area^, catalogs_moved^.link);
              catalogs_moved := catalogs_moved^.link;
            IFEND;
            clp$make_file_value (output_line, work_area^, catalogs_moved^.element_value);
          ELSEIF pvt [p$catalogs_skipped].specified AND (NOT object_moved) THEN
            IF catalogs_skipped^.element_value <> NIL THEN
              clp$make_list_value (work_area^, catalogs_skipped^.link);
              catalogs_skipped := catalogs_skipped^.link;
            IFEND;
            clp$make_file_value (output_line, work_area^, catalogs_skipped^.element_value);
          IFEND;
        ELSE
          IF pvt [p$files_moved].specified AND object_moved THEN
            IF files_moved^.element_value <> NIL THEN
              clp$make_list_value (work_area^, files_moved^.link);
              files_moved := files_moved^.link;
            IFEND;
            clp$make_file_value (output_line, work_area^, files_moved^.element_value);
          ELSEIF pvt [p$files_skipped].specified AND (NOT object_moved) AND (NOT cycle_released) THEN
            IF files_skipped^.element_value <> NIL THEN
              clp$make_list_value (work_area^, files_skipped^.link);
              files_skipped := files_skipped^.link;
            IFEND;
            clp$make_file_value (output_line, work_area^, files_skipped^.element_value);
          IFEND;
        IFEND;

      IFEND;

      input_line := ' ';
      amp$get_next (input_fid, ^input_line, #SIZE (input_line), tran_cnt, byte_adr, file_pos, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    WHILEND;

    {
    { Change the values of the SCL variables with the values constructed above.
    {
    IF pvt [p$catalogs_moved].specified THEN
      clp$change_variable (pvt [p$catalogs_moved].variable^, catalogs_moved_head, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$catalogs_skipped].specified THEN
      clp$change_variable (pvt [p$catalogs_skipped].variable^, catalogs_skipped_head, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$files_moved].specified THEN
      clp$change_variable (pvt [p$files_moved].variable^, files_moved_head, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$files_skipped].specified THEN
      clp$change_variable (pvt [p$files_skipped].variable^, files_skipped_head, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    fsp$close_file (input_fid, status);

  PROCEND pfp$extract_file_list;

MODEND pfm$extract_file_list;

*DECK DECK=PFM$EXTRACT_FILE_LIST_PD EXPAND=TRUE
crepd (extract_file_list extfl) sp=pfp$extract_file_list lmo=none dm=off tel=fatal
*DECK DECK=PFM$FILE_SYSTEM_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Permanent Files : File System Interface Management' ??
MODULE pfm$file_system_interfaces;

{ PURPOSE:
{   This module contains those routines that interface to memory manager,
{   device manager, and file manager.
{
{ NOTES:
{   For those routines dealing with catalogs, the catalog described by the
{   catalog locator refers to the PHYSICAL catalog.  Thus care must be taken by
{   the caller to make sure that a call to pfp$destroy_catalog, for example, is
{   not made when really only an internal catalog is to be removed.
{
{   Access to the queued catalog table, must be referenced from the task
{   private pointers.  These task private pointers allow a task to run as if it
{   was running on behalf of a different job.

?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$put_validation_errors
*copyc amt$file_byte_address
*copyc dfd$file_server_info
*copyc dfk$file_server_info_keypoints
*copyc dft$command_buffer
*copyc dme$tape_errors
*copyc dmt$error_condition_codes
*copyc dmt$stored_tape_fmd_header
*copyc dmt$stored_tape_volume_list
*copyc dmt$tape_job_lun_table
*copyc fmt$mass_storage_request_info
*copyc fmt$pf_attachment_info
*copyc fmt$removable_media_req_info
*copyc fse$attach_validation_errors
*copyc gft$file_kind
*copyc gft$system_file_identifier
*copyc jmc$system_family
*copyc osd$integer_limits
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc ost$caller_identifier
*copyc ost$processor_model_number
*copyc pfc$null_shared_queue
*copyc pfd$authority
*copyc pfd$catalog_locator
*copyc pfd$queued_catalog_table
*copyc pfd$table_info
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pfk$keypoints
*copyc pft$df_define
*copyc rme$request_command_exceptions
*copyc rme$request_mass_storage
*copyc sft$file_space_limit_kind
?? POP ??
?? EJECT ??
*copyc bap$fetch_tape_validation
*copyc clp$get_variable_value
*copyc cmp$deadstart_phase
*copyc cmp$get_ms_class_on_volume
*copyc cmp$post_deadstart
*copyc dfv$file_server_info_enabled
*copyc dmp$attach_file
*copyc dmp$close_tape_volume
*copyc dmp$create_file_entry
*copyc dmp$create_tape_file_sfid
*copyc dmp$delete_file_descriptor
*copyc dmp$destroy_file
*copyc dmp$destroy_permanent_file
*copyc dmp$detach_file
*copyc dmp$enable_damage_detection
*copyc dmp$fetch_segment_file_info
*copyc dmp$fetch_server_sft_info
*copyc dmp$get_file_info
*copyc dmp$get_reconciled_fmd
*copyc dmp$get_stored_fmd
*copyc dmp$get_stored_fmd_header_info
*copyc dmp$get_stored_fmd_size
*copyc dmp$get_stored_fmd_volume_list
*copyc dmp$reconcile_fmd
*copyc dmp$store_valid_class_in_fmd
*copyc dmv$active_volume_table
*copyc dmv$null_sfid
*copyc dmv$reconcile_locator
*copyc dsp$system_committed
*copyc fmi$get_ring_attributes
*copyc fmi$validate_ring_attributes
*copyc fmp$attach_file
*copyc fmp$lock_path_table
*copyc fmp$unlock_path_table
*copyc fmv$default_detachment_options
*copyc i#current_sequence_position
*copyc i#move
*copyc iop$tape_file_attached
*copyc iov$number_of_tape_units
*copyc jmp$system_job
*copyc mmp$close_segment
*copyc mmp$lock_catalog_segment
*copyc mmp$open_file_segment
*copyc mmp$unlock_segment
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$clear_job_signature_lock
*copyc osp$file_access_condition
*copyc osp$generate_log_message
*copyc osp$generate_unique_binary_name
*copyc osp$get_set_name
*copyc osp$initialize_signature_lock
*copyc osp$log_job_recovery_message
*copyc osp$log_job_recovery_status
*copyc osp$log_unformatted_status
*copyc osp$prevalidate_free
*copyc osp$reset_heap
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$test_signature_lock
*copyc osp$verify_heap
*copyc osv$job_pageable_heap
*copyc osv$system_family_name
*copyc pfp$attach_for_write
*copyc pfp$build_fmd_locator
*copyc pfp$build_fmd_pointer
*copyc pfp$build_mainfram_list_locator
*copyc pfp$build_mainfram_list_pointer
*copyc pfp$build_object_list_locator
*copyc pfp$build_object_list_pointer
*copyc pfp$check_catalog_alarm
*copyc pfp$check_cycle_busy
*copyc pfp$clear_catalog_alarm
*copyc pfp$compute_checksum
*copyc pfp$convert_cycle_path_to_strng
*copyc pfp$convert_density_to_dm
*copyc pfp$convert_device_class_to_rm
*copyc pfp$convert_pf_path_to_fs_path
*copyc pfp$convert_pf_to_fs_structure
*copyc pfp$get_rem_media_req_info
*copyc pfp$get_rem_media_volume_list
*copyc pfp$map_usage_selections
*copyc pfp$process_unexpected_status
*copyc pfp$report_invalid_free
*copyc pfp$report_unexpected_status
*copyc pfp$set_catalog_alarm
*copyc pfp$system_path
*copyc pfv$allow_catalog_write
*copyc pfv$debug_catalog_access
*copyc pfv$null_unique_name
*copyc pfv$flush_catalogs
*copyc pfv$locked_catalog_list
*copyc pfv$p_p_job_heap
*copyc pfv$p_p_newest_queued_catalog
*copyc pfv$p_p_queued_catalog_table
*copyc pfv$p_queued_catalog_table_lock
*copyc pfv$task_account
*copyc pfv$task_family
*copyc pfv$task_project
*copyc pfv$task_user
*copyc pfv$unattached_status
*copyc pfv$verify_catalog_heaps
*copyc pfv$write_usage
*copyc pmp$date_time_compare
*copyc pmp$get_job_names
*copyc pmp$get_pseudo_mainframe_id
*copyc pmp$get_user_identification
*copyc pmp$log_ascii
*copyc pmp$wait
*copyc rmp$build_mass_storage_info
*copyc rmp$validate_mass_storage_info
*copyc sfp$get_job_limit
*copyc sfv$dynamic_file_space_limits
*copyc stp$get_pf_root
*copyc stp$store_pf_root


?? TITLE := '  Global Declarations Declared by this module', EJECT ??

  CONST
    pfc$file_class_index = 1,
    pfc$volume_overflow_index = 7,
    pfc$owner_index = 8,
    pfc$allocation_size_index = 10,
    pfc$initial_volume_index = 11,
    pfc$transfer_size_index = 12,
    pfc$dm_file_attribute_count = 12;

  CONST
    pfc$queued_catalog_table_size = 32;

  CONST
    assign_volume = TRUE,
    assign_volume_retry_wait = 2000, {2 seconds}
    byte_address = 0,
    file_share_history = dmc$minimum_file_share_his,
    include_radix = TRUE,
    radix = 10;

  TYPE
    pft$dm_file_attributes = array [1 .. pfc$dm_file_attribute_count] of
          dmt$new_file_attribute;

  VAR
    pfv$null_tape_fmd_header_space: [XDCL, #GATE, oss$job_paged_literal, READ] array [1 .. 48] of boolean :=
          [REP 48 OF FALSE];

  VAR
    { These variables reside in task shared to allow update from task private
    { pointers.
    pfv$p_newest_queued_catalog: [XDCL, #GATE, oss$task_shared] pft$p_queued_catalog := NIL,
    pfv$p_queued_catalog_table: [XDCL, #GATE, oss$task_shared] pft$p_queued_catalog_table := NIL,
    pfv$queued_catalog_table_lock: [XDCL, #GATE, oss$task_shared] ost$signature_lock := [0];

?? FMT (FORMAT := OFF) ??
  VAR
    initial_dm_file_attributes: [oss$job_paged_literal, READ] pft$dm_file_attributes := [
          [dmc$class, rmc$unspecified_file_class],
          [dmc$class_ordinal, dmc$default_class_ordinal],
          [dmc$clear_space, FALSE],
          [dmc$file_limit, amc$file_byte_limit],
          [dmc$locked_file, [FALSE]],
          [dmc$master_volume_required, FALSE],
          [dmc$overflow, TRUE],
          [dmc$owner, sfc$no_limit],
          [dmc$preset_value, 0],
          [dmc$requested_allocation_size, dmc$unspecified_allocation_size],
          [dmc$requested_volume, [rmc$unspecified_vsn, * ]],
          [dmc$requested_transfer_size, dmc$unspecified_transfer_size]],
?? FMT (FORMAT := ON) ??
    null_catalog_header_space: [oss$job_paged_literal, READ] array [1 .. 48] of boolean := [REP 48 OF FALSE];

?? TITLE := '  [XDCL] pfp$attach_catalog', EJECT ??
{ DESIGN:
{   If the catalog is found to be queued, it will be removed from the queue.
{   This procedure opens the catalog.
{
{ NOTE:
{   This procedure should only be used by those procedures that cannot obtain
{   the information required for queuing.

  PROCEDURE [XDCL] pfp$attach_catalog
    (    p_fmd: {input^} pft$p_fmd;
         set_name: stt$set_name;
         internal_catalog_name: pft$internal_name;
         global_file_name: ost$binary_unique_name;
         access_kind: pft$access_kind;
         catalog_remote: boolean;
     VAR catalog_locator: pft$catalog_locator;
     VAR status: ost$status);

    VAR
      catalog_found_queued: boolean,
      local_status: ost$status,
      p_queued_catalog: pft$p_queued_catalog;

    status.normal := TRUE;
    osp$set_job_signature_lock (pfv$p_queued_catalog_table_lock^);

    find_queued_cat_by_internal (internal_catalog_name, p_queued_catalog);
    catalog_found_queued := (p_queued_catalog <> NIL);
    IF catalog_found_queued THEN
      build_catalog_locator (p_queued_catalog, catalog_locator, status);
      IF status.normal THEN
        free_queued_catalog (p_queued_catalog);
      IFEND;
    IFEND;

    osp$clear_job_signature_lock (pfv$p_queued_catalog_table_lock^);

    IF status.normal AND (NOT catalog_found_queued) THEN
      pfp$physically_attach_catalog (set_name, internal_catalog_name, global_file_name, p_fmd,
            catalog_remote, catalog_locator, status);
    IFEND;

    IF status.normal THEN
      pfp$open_attached_catalog (access_kind, catalog_locator, status);
    IFEND;

    IF NOT status.normal THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

  PROCEND pfp$attach_catalog;

?? TITLE := '  [XDCL] pfp$attach_last_queued_catalog', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to attempt attaching the last catalog in
{   the path of internal catalogs.
{
{ DESIGN:
{   If the last catalog is not found, then an attempt will be made to attach
{   the next to last catalog, and so on up through the master catalog level.
{   This procedure opens the found catalog.  If no catalog is found in the
{   queued catalog table, then pfe$no_queued_catalog_found is returned.  If a
{   queued catalog is found, the found_catalog_index parameter returns the
{   index into the internal_path of the catalog that was found.  If the last
{   catalog was found, the catalog will be locked for the specified access, otherwise
{   the catalog will be locked for read access.

  PROCEDURE [XDCL] pfp$attach_last_queued_catalog
    (    set_name: stt$set_name;
         internal_path: pft$internal_path;
         last_catalog_index: pft$array_index;
         access_kind: pft$access_kind;
     VAR found_catalog_index: pft$array_index;
     VAR catalog_locator: pft$catalog_locator;
     VAR status: ost$status);

    VAR
      access: pft$access_kind,
      any_queued_catalog_found: boolean,
      local_status: ost$status,
      p_queued_catalog: pft$p_queued_catalog;

    status.normal := TRUE;
    any_queued_catalog_found := FALSE;
    osp$set_job_signature_lock (pfv$p_queued_catalog_table_lock^);

  /search_queued_catalog_table/
    FOR found_catalog_index := last_catalog_index DOWNTO pfc$master_catalog_path_index DO
      find_queued_cat_by_internal (internal_path [found_catalog_index], p_queued_catalog);
      IF p_queued_catalog <> NIL THEN
        #KEYPOINT (osk$debug, osk$m * found_catalog_index, pfk$attach_last_queued_catalog);
        build_catalog_locator (p_queued_catalog, catalog_locator, status);
        IF NOT status.normal THEN
          EXIT /search_queued_catalog_table/;
        IFEND;
        any_queued_catalog_found := TRUE;
        free_queued_catalog (p_queued_catalog);
        EXIT /search_queued_catalog_table/;
      IFEND;
    FOREND /search_queued_catalog_table/;

    osp$clear_job_signature_lock (pfv$p_queued_catalog_table_lock^);

    IF NOT status.normal AND (status.condition = pfe$catalog_access_retry) THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
      RETURN;
    IFEND;

    IF any_queued_catalog_found THEN
      IF found_catalog_index = last_catalog_index THEN
        access := access_kind;
      ELSE
        access := pfc$read_access;
      IFEND;
      pfp$open_attached_catalog (access, catalog_locator, status);
      IF NOT status.normal THEN
        pfp$return_catalog (catalog_locator, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$no_queued_catalog_found, '', status);
    IFEND;

  PROCEND pfp$attach_last_queued_catalog;

?? TITLE := '  [XDCL] pfp$attach_permanent_file', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to interface with the device manager to
{   attach a permanent file, and then to interface with the local file manager
{   to associate the attached permanent file with a local file name for the job.

  PROCEDURE [XDCL] pfp$attach_permanent_file
    (    family_location: pft$family_location;
         mainframe_id: pmt$binary_mainframe_id;
         local_file_name: amt$local_file_name;
         path: pft$complete_path;
         attached_pf_table_index: pft$attached_pf_table_index;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
         application_info: pft$application_info;
         validation_ring: ost$valid_ring;
         password_protected: boolean;
         allowed_cycle_damage_symptoms: fst$cycle_damage_symptoms;
         enable_media_damage_detection: boolean;
         implicit_attach: boolean;
         update_catalog: boolean;
         authority: pft$authority;
         p_file_label: {input} ^fmt$file_label;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
         p_physical_cycle: {i^/o^} ^pft$physical_cycle;
     VAR system_file_id: gft$system_file_identifier;
     VAR file_damaged: boolean;
     VAR flush_catalog_pages: {i/o} boolean;
     VAR path_handle: {client only} fmt$path_handle;
     VAR p_file_server_buffers: {file server only: i/o^} ^pft$file_server_buffers;
     VAR status: ost$status);

    CONST
      allow_other_mainframe_writer = TRUE,
      critical_message = TRUE,
      cycle_created = TRUE,
      flush_pages = TRUE,
      message_origin = pmc$msg_origin_system;

    VAR
      apfid: pft$attached_permanent_file_id,
      bytes_allocated: amt$file_byte_address,
      cycle_path_string: ost$string,
      detachment_options: fmt$detachment_options,
      device_class: rmt$device_class,
      evaluated_file_reference: fst$evaluated_file_reference,
      exclusive_attach_client_mf: boolean,
      exclusive_attach_executing_mf: boolean,
      executing_mainframe_id: pmt$binary_mainframe_id,
      existing_sft_entry: dmt$existing_sft_entry,
      exit_on_unknown_file: boolean,
      file_info: dmt$file_information,
      file_modified: boolean,
      file_space_limit_kind: sft$file_space_limit_kind,
      fmd_modified: boolean,
      fs_path_size: fst$path_size,
      keypoint_operation: dft$keypoint_file_operation,
      keypoint_sfid: dft$keypoint_sfid,
      local_status: ost$status,
      locked_file: dmt$locked_file,
      p_fs_path: ^fst$path,
      p_mainframe_usage_list: ^pft$mainframe_usage_list,
      p_physical_fmd: ^pft$physical_fmd,
      p_volume_list: ^rmt$volume_list,
      pf_attachment_info: fmt$pf_attachment_info,
      pfs_limit: sft$limit,
      recorded_vsn: rmt$recorded_vsn,
      removable_media_req_info: fmt$removable_media_req_info,
      restricted_attach: boolean,
      server_file: boolean,
      shared_queue: mmt$shared_queue,
      stale_cycle_entry: boolean,
      tape_file_attached: boolean,
      tape_validation: boolean,
      update_fmd: boolean,
      usage_intentions: pft$permit_selections,
      volume_count: 0 .. amc$max_vol_number;

    IF p_physical_cycle^.cycle_entry.device_information.device_class_defined THEN
      pfp$convert_device_class_to_rm (p_physical_cycle^.cycle_entry.device_information.device_class,
            device_class);
    ELSE
      device_class := rmc$mass_storage_device;
    IFEND;

    IF device_class = rmc$mass_storage_device THEN
    pfp$build_fmd_pointer (p_physical_cycle^.cycle_entry.fmd_locator, p_catalog_file, p_physical_fmd);

    IF p_physical_fmd = NIL THEN
      PUSH p_fs_path;
      pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$undefined_data,
            p_fs_path^ (1, fs_path_size), status);
      osp$append_status_integer (osc$status_parameter_delimiter, p_physical_cycle^.cycle_entry.cycle_number,
            radix, NOT include_radix, status);
      RETURN;
    IFEND;

    restricted_attach := NOT update_catalog;
    locked_file.required := FALSE;
    exit_on_unknown_file := (p_physical_cycle^.cycle_entry.attach_status.attach_count > 0) AND
         ((p_physical_cycle^.cycle_entry.attach_status.usage_counts[pfc$shorten] > 0) OR
         (p_physical_cycle^.cycle_entry.attach_status.usage_counts[pfc$append] > 0) OR
         (p_physical_cycle^.cycle_entry.attach_status.usage_counts[pfc$modify] > 0));
    server_file := family_location = pfc$server_mainframe;

    IF (share_selections <> $pft$share_selections []) AND
          p_physical_cycle^.cycle_entry.shared_queue_info.defined THEN
      shared_queue := p_physical_cycle^.cycle_entry.shared_queue_info.shared_queue;
    ELSE
      shared_queue := mmc$null_shared_queue;
    IFEND;

    dmp$attach_file (p_physical_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file,
          p_physical_fmd^.fmd, usage_selections, share_selections, pfc$average_share_history,
          pfc$maximum_pf_length, restricted_attach, exit_on_unknown_file, server_file,
          shared_queue, file_damaged, system_file_id, existing_sft_entry, status);

    IF status.normal AND (existing_sft_entry <> dmc$normal_entry) THEN
      IF p_physical_cycle^.cycle_entry.attach_status.attach_count > 0 THEN
        flush_catalog_pages := pfv$flush_catalogs;
        pfp$reconcile_fmd (^path, p_physical_cycle^.cycle_entry.internal_cycle_name, existing_sft_entry,
              update_catalog, p_catalog_file, p_physical_cycle, p_physical_fmd, status);
      IFEND;

      IF status.normal AND ((existing_sft_entry = dmc$restricted_attach_entry) OR
            (exit_on_unknown_file AND (existing_sft_entry = dmc$entry_not_found))) THEN
        dmp$attach_file (p_physical_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file,
              p_physical_fmd^.fmd, usage_selections, share_selections, pfc$average_share_history,
              pfc$maximum_pf_length, restricted_attach, {exit_on_unknown_file} FALSE, server_file,
              shared_queue, file_damaged, system_file_id, existing_sft_entry, status);
        IF status.normal THEN
          pfp$update_stale_cycle_entry (system_file_id, p_physical_cycle, status);
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      IF update_catalog THEN
        pfp$map_usage_selections (usage_selections, usage_intentions);
        pfp$check_cycle_busy (path, usage_intentions, share_selections, mainframe_id, p_catalog_file,
              p_physical_cycle^.cycle_entry, status);
      IFEND;

      IF file_damaged AND NOT (fsc$media_image_inconsistent IN allowed_cycle_damage_symptoms) THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$media_image_inconsistent,
              p_fs_path^ (1, fs_path_size), status);
      IFEND;

      IF enable_media_damage_detection AND (NOT file_damaged) AND pfp$attach_for_write (usage_selections) THEN
        dmp$enable_damage_detection (system_file_id, p_physical_cycle^.cycle_entry.internal_cycle_name,
              local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;

      IF status.normal THEN
        IF family_location = pfc$server_mainframe THEN
          set_server_output (NOT cycle_created, application_info, p_physical_cycle^.cycle_entry.cycle_number,
                NOT allow_other_mainframe_writer, p_physical_cycle^.cycle_entry.internal_cycle_name,
                usage_selections, share_selections, password_protected, attached_pf_table_index,
                system_file_id, p_file_label, {p_fmd} NIL, device_class, bytes_allocated,
                p_file_server_buffers, status);
        ELSE
          apfid.family_location := pfc$local_mainframe;
          apfid.attached_pf_table_index := attached_pf_table_index;
          pfp$convert_pf_to_fs_structure (path, evaluated_file_reference);
          evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
          evaluated_file_reference.cycle_reference.cycle_number := p_physical_cycle^.cycle_entry.cycle_number;

          IF (pfc$master_catalog_owner IN authority.ownership) AND
                (usage_selections * pfv$write_usage <> $pft$usage_selections []) THEN
            file_space_limit_kind := sfc$perm_file_space_limit;
            IF sfv$dynamic_file_space_limits AND (pfc$append IN usage_selections) THEN
              sfp$get_job_limit (avc$pfs_limit_name, pfs_limit, status);
              IF status.normal THEN
                IF pfs_limit.accumulator >= pfs_limit.job_abort_limit THEN
                  osp$set_status_condition (ame$file_space_limit_exceeded, status);
                IFEND;
              ELSE
                status.normal := TRUE;
              IFEND;
            IFEND;
          ELSE
            file_space_limit_kind := sfc$no_limit;
          IFEND;

          IF status.normal THEN
            pf_attachment_info.apfid := apfid;
            pf_attachment_info.application_info := application_info;
            pf_attachment_info.implicit_attach := implicit_attach;
            pf_attachment_info.password_protected := password_protected;
            fmp$attach_file (local_file_name, p_physical_cycle^.cycle_entry.global_file_name,
                  p_physical_cycle^.cycle_entry.internal_cycle_name, system_file_id, usage_selections,
                  share_selections, validation_ring, file_space_limit_kind, p_file_label, ^pf_attachment_info,
                  rmc$mass_storage_device, {p_removable_media_req_info} NIL, {p_volume_list} NIL,
                  evaluated_file_reference, status);
            path_handle := evaluated_file_reference.path_handle_info.path_handle;
          IFEND;

          IF NOT status.normal THEN
            IF status.condition = ame$file_space_limit_exceeded THEN
              PUSH p_fs_path;
              pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
              osp$append_status_file (osc$status_parameter_delimiter, p_fs_path^ (1, fs_path_size), status);
              osp$append_status_parameter (osc$status_parameter_delimiter, 'Permanent', status);
            ELSEIF status.condition = ame$ring_validation_error THEN
              PUSH p_fs_path;
              pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_ring_access,
                    p_fs_path^ (1, fs_path_size), status);
            ELSEIF status.condition = pfe$lfn_in_use THEN
              ;
            ELSEIF (status.condition = rme$redundant_device_assignment) OR
                  (status.condition = rme$device_assignment_conflict) THEN
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$lfn_in_use, local_file_name,
                    status);
            ELSE
              pfp$report_unexpected_status (status);
              PUSH p_fs_path;
              pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
              osp$append_status_parameter (osc$status_parameter_delimiter, p_fs_path^ (1, fs_path_size),
                    status);
              osp$log_unformatted_status (^status, - $pmt$ascii_logset [], message_origin,
                    NOT critical_message);
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      IF NOT status.normal THEN
        pfp$detach_permanent_file (^path, system_file_id, $pft$usage_selections [],
              {catalog_access_allowed} TRUE, p_physical_cycle, p_catalog_file, fmd_modified, file_info,
              local_status);
        pfp$process_unexpected_status (local_status);

        IF (status.condition <> pfe$cycle_busy) AND (status.condition <> pfe$lfn_in_use) AND
              (status.condition <> pfe$invalid_ring_access) AND
              (status.condition <> ame$file_space_limit_exceeded) AND
              (status.condition <> pfe$media_image_inconsistent) AND
              (status.condition <> pfe$pf_system_error) THEN
          pfp$report_unexpected_status (status);
        IFEND;
      IFEND;
    ELSE { Dmp$attach_file or pfp$reconcile_fmd failed.
      pfp$convert_cycle_path_to_strng (path, p_physical_cycle^.cycle_entry.cycle_number,
            cycle_path_string);
      IF status.condition = dme$volume_unavailable THEN
        recorded_vsn := status.text.value (2, 6);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$volume_unavailable,
              cycle_path_string.value (1, cycle_path_string.size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, recorded_vsn, status);
      ELSEIF status.condition = dme$some_volumes_not_online THEN
        recorded_vsn := status.text.value (2, 6);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$volume_not_online,
            cycle_path_string.value (1, cycle_path_string.size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, recorded_vsn, status);
      ELSEIF status.condition = dme$allocation_mismatch THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$allocation_mismatch,
              cycle_path_string.value (1, cycle_path_string.size), status);
      ELSE
        IF status.condition <> pfe$pf_system_error THEN
          pfp$report_unexpected_status (status);
        IFEND;
        osp$append_status_parameter (osc$status_parameter_delimiter,
              cycle_path_string.value (1, cycle_path_string.size), status);
        osp$log_unformatted_status (^status, - $pmt$ascii_logset [], message_origin, NOT critical_message);
      IFEND;
    IFEND;

    IF status.normal AND update_catalog THEN
      pfp$check_for_stale_cycle_entry (p_physical_cycle^.cycle_entry, stale_cycle_entry);

      IF stale_cycle_entry THEN
        pfp$update_stale_cycle_entry (system_file_id, p_physical_cycle, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;
    IFEND;
    ELSEIF device_class = rmc$magnetic_tape_device THEN
      file_damaged := FALSE;

      pfp$build_mainfram_list_pointer (p_physical_cycle^.cycle_entry.mainframe_usage_list_locator,
            p_catalog_file, p_mainframe_usage_list);
      IF (family_location = pfc$server_mainframe) AND mainframe_attachment (mainframe_id, p_catalog_file,
            p_mainframe_usage_list, p_physical_cycle^.cycle_entry) THEN
        osp$set_status_condition (pfe$tape_attached_on_client, status);
      IFEND;

      IF status.normal THEN
        pmp$get_pseudo_mainframe_id (executing_mainframe_id);
        IF update_catalog AND mainframe_attachment (executing_mainframe_id, p_catalog_file,
              p_mainframe_usage_list, p_physical_cycle^.cycle_entry) THEN
          iop$tape_file_attached (p_physical_cycle^.cycle_entry.global_file_name, tape_file_attached,
                local_status);
          IF local_status.normal AND (NOT tape_file_attached) THEN
            pfp$clear_cycle_attachments (^path, p_catalog_file, p_physical_cycle);
          IFEND;
        IFEND;
      IFEND;

      IF status.normal AND update_catalog THEN
        pfp$map_usage_selections (usage_selections, usage_intentions);
        pfp$check_cycle_busy (path, usage_intentions, share_selections, mainframe_id, p_catalog_file,
              p_physical_cycle^.cycle_entry, status);
      IFEND;

      IF status.normal THEN
        pfp$build_fmd_pointer (p_physical_cycle^.cycle_entry.fmd_locator, p_catalog_file, p_physical_fmd);

        IF p_physical_fmd = NIL THEN
          PUSH p_fs_path;
          pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$undefined_data,
                p_fs_path^ (1, fs_path_size), status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                p_physical_cycle^.cycle_entry.cycle_number, radix, NOT include_radix, status);
        IFEND;

        IF status.normal THEN
          IF family_location = pfc$local_mainframe THEN
            apfid.family_location := pfc$local_mainframe;
            apfid.attached_pf_table_index := attached_pf_table_index;
            pfp$convert_pf_to_fs_structure (path, evaluated_file_reference);
            evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
            evaluated_file_reference.cycle_reference.cycle_number :=
                  p_physical_cycle^.cycle_entry.cycle_number;
            pfp$get_rem_media_req_info (^p_physical_fmd^.fmd, ^removable_media_req_info, volume_count,
                  status);

            IF status.normal THEN
              IF usage_selections * pfv$write_usage = $pft$usage_selections [] THEN
                removable_media_req_info.write_ring := rmc$no_write_ring;
              ELSE
                removable_media_req_info.write_ring := rmc$write_ring;
              IFEND;

              PUSH p_volume_list: [1 .. volume_count];
              pfp$get_rem_media_volume_list (^p_physical_fmd^.fmd, p_volume_list, status);

              IF status.normal THEN
                dmp$create_tape_file_sfid (^removable_media_req_info, p_volume_list, system_file_id, status);

                IF status.normal THEN
                  pf_attachment_info.apfid := apfid;
                  pf_attachment_info.application_info := application_info;
                  pf_attachment_info.implicit_attach := implicit_attach;
                  pf_attachment_info.password_protected := password_protected;
                  fmp$attach_file (local_file_name, p_physical_cycle^.cycle_entry.global_file_name,
                        p_physical_cycle^.cycle_entry.internal_cycle_name, system_file_id, usage_selections,
                        share_selections, validation_ring, sfc$no_limit, p_file_label, ^pf_attachment_info,
                        device_class, ^removable_media_req_info, p_volume_list, evaluated_file_reference,
                        status);
                  path_handle := evaluated_file_reference.path_handle_info.path_handle;

                  IF NOT status.normal THEN
                    detachment_options := fmv$default_detachment_options;
                    detachment_options.device_class := rmc$magnetic_tape_device;
                    detachment_options.physical_unload := TRUE;
                    dmp$close_tape_volume (system_file_id, detachment_options, local_status);

                    IF status.condition = ame$ring_validation_error THEN
                      PUSH p_fs_path;
                      pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
                      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_ring_access,
                            p_fs_path^ (1, fs_path_size), status);
                    ELSEIF (status.condition = pfe$lfn_in_use) OR
                          (status.condition = rme$redundant_device_assignment) OR
                          (status.condition = rme$device_assignment_conflict) THEN
                      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$lfn_in_use,
                            local_file_name, status);
                    ELSE
                      pfp$report_unexpected_status (status);
                      PUSH p_fs_path;
                      pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
                      osp$append_status_parameter (osc$status_parameter_delimiter,
                            p_fs_path^ (1, fs_path_size), status);
                      osp$log_unformatted_status (^status, - $pmt$ascii_logset [], message_origin,
                            NOT critical_message);
                    IFEND;
                  IFEND;
                ELSEIF status.condition = dme$tape_attach_limit_exceeded THEN
                  PUSH p_fs_path;
                  pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
                  osp$set_status_abnormal (pfc$permanent_file_manager_id, fse$tape_attach_limit_exceeded,
                        p_fs_path^ (1, fs_path_size), status);
                  osp$append_status_integer (osc$status_parameter_delimiter,
                        iov$number_of_tape_units + dmc$extra_lun_table_entries, radix, NOT include_radix,
                        status);
                IFEND;
              IFEND;
            IFEND;
          ELSE {server mainframe}
            set_server_output (NOT cycle_created, application_info,
                  p_physical_cycle^.cycle_entry.cycle_number, NOT allow_other_mainframe_writer,
                  p_physical_cycle^.cycle_entry.internal_cycle_name, usage_selections, share_selections,
                  password_protected, attached_pf_table_index, system_file_id, p_file_label,
                  ^p_physical_fmd^.fmd, device_class, bytes_allocated, p_file_server_buffers, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal AND dfv$file_server_info_enabled THEN
      keypoint_operation.remote := (path [pfc$family_path_index] <> osv$system_family_name);
      keypoint_operation.catalog := FALSE;
      keypoint_sfid.file_entry_index := system_file_id.file_entry_index;
      keypoint_sfid.residence := system_file_id.residence;
      #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_operation.keypoint_data, dfk$attach_info);
      #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_sfid.keypoint_data, dfk$sfid);
    IFEND;
  PROCEND pfp$attach_permanent_file;

?? TITLE := '  [XDCL] pfp$attach_root_catalog', EJECT ??
{ PURPOSE:
{   This procedure attaches and opens the root catalog.

  PROCEDURE [XDCL] pfp$attach_root_catalog
    (    set_name: stt$set_name;
         access_kind: pft$access_kind;
     VAR catalog_locator: pft$catalog_locator;
     VAR status: ost$status);

    pfp$get_root_attached (set_name, catalog_locator, status);
    IF status.normal THEN
      pfp$open_attached_catalog (access_kind, catalog_locator, status);
    IFEND;
  PROCEND pfp$attach_root_catalog;

?? TITLE := '  [XDCL] pfp$check_for_stale_cycle_entry', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to determine whether new items which were
{   added to the cycle entry in R1.4.1 are stale.  These items will be stale if
{   the cycle was created or modified by an R1.3.1 or older version of the
{   system.
{
{ NOTE:
{   This procedure should be deleted two releases after R1.4.1 when it is no
{   longer necessary to support an upgrade from an R1.3.1 or earlier system.

  PROCEDURE [XDCL] pfp$check_for_stale_cycle_entry
    (    cycle_entry: pft$cycle_entry;
     VAR stale_cycle_entry: boolean);

    VAR
      comparison_result: pmt$comparison_result,
      status: ost$status;

    IF cycle_entry.data_modification_date_time.year <= 0 THEN
      stale_cycle_entry := TRUE;
    ELSE
      stale_cycle_entry := FALSE;
    IFEND;
  PROCEND pfp$check_for_stale_cycle_entry;

?? TITLE := '  [XDCL] pfp$clear_cycle_attachments', EJECT ??

  PROCEDURE [XDCL] pfp$clear_cycle_attachments
    (    p_path: ^pft$complete_path;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
         p_cycle: {i^/o^} ^pft$physical_cycle);

    VAR
      p_mainframe_usage_list: ^pft$mainframe_usage_list,
      prevalidate_free_result: ost$prevalidate_free_result;

    p_cycle^.cycle_entry.attach_status := pfv$unattached_status;
    p_cycle^.cycle_entry.first_mainframe_usage_entry.entry_type := pfc$free_mainframe_entry;
    pfp$build_mainfram_list_pointer (p_cycle^.cycle_entry.mainframe_usage_list_locator, p_catalog_file,
          p_mainframe_usage_list);
    IF p_mainframe_usage_list <> NIL THEN
      osp$prevalidate_free ((#OFFSET(p_mainframe_usage_list) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
            ^p_catalog_file^.catalog_heap, prevalidate_free_result);
      IF prevalidate_free_result = osc$heap_free_valid THEN
        FREE p_mainframe_usage_list IN p_catalog_file^.catalog_heap;
      ELSE
        pfp$report_invalid_free (p_path, ^p_cycle^.cycle_entry.cycle_number, 'MAINFRAME_USAGE_LIST',
              'file', prevalidate_free_result, #OFFSET(p_mainframe_usage_list));
        p_mainframe_usage_list := NIL;
      IFEND;
    IFEND;
    pfp$build_mainfram_list_locator ({p_mainframe_usage_list} NIL, {p_catalog_file} NIL,
          p_cycle^.cycle_entry.mainframe_usage_list_locator);
    pfp$compute_checksum (^p_cycle^.cycle_entry, #SIZE (pft$cycle_entry), p_cycle^.checksum);

  PROCEND pfp$clear_cycle_attachments;

?? TITLE := '  [XDCL] pfp$create_catalog', EJECT ??

  PROCEDURE [XDCL] pfp$create_catalog
    (    catalog_path: pft$complete_path;
         p_mass_storage_request_info: ^fmt$mass_storage_request_info;
         authority: pft$authority;
         lock_catalog: boolean;
     VAR new_catalog_locator: pft$catalog_locator;
     VAR status: ost$status);

    CONST
      file_type = gfc$fk_catalog;

    CONST
      catalog_algorithm = 0;

    VAR
      dm_file_attributes: pft$dm_file_attributes,
      file_returned: boolean,
      file_share_selections: pft$share_selections,
      file_usage: pft$usage_selections,
      i: integer,
      local_status: ost$status,
      segment_pointer: mmt$segment_pointer;

    status.normal := TRUE;

    new_catalog_locator.set_name := catalog_path [pfc$set_path_index];
    new_catalog_locator.new_catalog := TRUE;
    new_catalog_locator.queuing_info.set_catalog_alarm := FALSE;
    {
    { New catalogs are NOT queued.
    {
    new_catalog_locator.queuing_info.attach_queued := FALSE;

    file_usage := - $pft$usage_selections [];
    file_share_selections := $pft$share_selections [];

    IF p_mass_storage_request_info <> NIL THEN
      p_mass_storage_request_info^.allocation_size := pfc$catalog_allocation_size;
    IFEND;

    generate_dm_file_attributes (catalog_path, pfc$catalog_object, {validation_ring} osc$tsrv_ring,
          {use_scl_variable_defaults} FALSE, p_mass_storage_request_info, authority, dm_file_attributes,
          status);

    IF status.normal THEN
    /assign_catalog_to_volume/
      WHILE TRUE DO
        dmp$create_file_entry (file_type, file_usage, file_share_selections, file_share_history,
               ^dm_file_attributes, byte_address, assign_volume, new_catalog_locator.global_file_name,
               new_catalog_locator.system_file_id, status);
        IF (NOT status.normal) AND (status.condition = dme$unable_to_alloc_all_space) AND
          volume_available_for_assign (catalog_path [pfc$set_path_index],
                dm_file_attributes [pfc$file_class_index].class,
                dm_file_attributes [pfc$initial_volume_index].requested_volume.recorded_vsn) THEN
            pmp$wait (assign_volume_retry_wait, assign_volume_retry_wait);
          CYCLE /assign_catalog_to_volume/;
        ELSE
          EXIT /assign_catalog_to_volume/;
        IFEND;
      WHILEND /assign_catalog_to_volume/;
      new_catalog_locator.attached := status.normal;
      new_catalog_locator.internal_catalog_name := new_catalog_locator.global_file_name;
    IFEND;

    IF status.normal THEN
      mmp$open_file_segment (new_catalog_locator.system_file_id, NIL, mmc$cell_pointer, pfc$catalog_ring,
          sfc$no_limit, segment_pointer, status);
      new_catalog_locator.open := status.normal;

      IF status.normal THEN
        IF lock_catalog THEN
          mmp$lock_catalog_segment (segment_pointer.cell_pointer, mmc$lus_lock_for_write, osc$wait, status);
          new_catalog_locator.locked := status.normal;
        ELSE
          new_catalog_locator.locked := FALSE;
        IFEND;

        IF status.normal THEN
          new_catalog_locator.access_kind := pfc$write_access;
          new_catalog_locator.p_catalog_file := segment_pointer.cell_pointer;
          osp$reset_heap (^new_catalog_locator.p_catalog_file^.catalog_heap,
                #SIZE (new_catalog_locator.p_catalog_file^.catalog_heap), FALSE, catalog_algorithm);
          pfp$build_object_list_locator ({sorted_object_count} 0, {free_sorted_object_count} 0,
                {p_object_list} NIL, {p_catalog_file} NIL, new_catalog_locator.p_catalog_file^.
                physical_catalog_header.catalog_header.object_list_locator);
          new_catalog_locator.p_catalog_file^.physical_catalog_header.catalog_header.valid := TRUE;
          new_catalog_locator.p_catalog_file^.physical_catalog_header.catalog_header.version :=
                pfc$catalog_version;
          new_catalog_locator.p_catalog_file^.physical_catalog_header.catalog_header.
                reserved_catalog_header_space := null_catalog_header_space;
          pfp$compute_checksum (#LOC (new_catalog_locator.p_catalog_file^.physical_catalog_header.
                catalog_header), #SIZE (pft$catalog_header), new_catalog_locator.p_catalog_file^.
                physical_catalog_header.checksum);
          new_catalog_locator.object_list_descriptor.p_object_list := NIL;
          new_catalog_locator.object_list_descriptor.catalog_type := pfc$external_catalog;
          new_catalog_locator.object_list_descriptor.p_physical_catalog_header :=
                ^new_catalog_locator.p_catalog_file^.physical_catalog_header;
          new_catalog_locator.flush_catalog_pages := pfv$flush_catalogs;
          new_catalog_locator.abort_catalog_operation := FALSE;

        /initialize_locked_catalog_list/
          FOR i := 1 to UPPERBOUND(pfv$locked_catalog_list) DO
            IF pfv$locked_catalog_list[i] = NIL THEN
              pfv$locked_catalog_list[i] := segment_pointer.cell_pointer;
              EXIT /initialize_locked_catalog_list/;
            IFEND;
          FOREND /initialize_locked_catalog_list/ ;
        ELSE
          {
          { The lock failed - back out.
          {
          mmp$close_segment (segment_pointer, pfc$catalog_ring, local_status);
          new_catalog_locator.open := FALSE;
          pfp$process_unexpected_status (local_status);
          dmp$destroy_file (new_catalog_locator.system_file_id, sfc$no_limit, local_status);
          pfp$process_unexpected_status (local_status);
        IFEND;
      ELSE
        {
        { The open failed - back out.
        {
        dmp$destroy_file (new_catalog_locator.system_file_id, sfc$no_limit, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;
    IFEND;
  PROCEND pfp$create_catalog;

?? TITLE := '  [XDCL] pfp$create_permanent_file', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to interface with the file system to
{   create a permanent file.

  PROCEDURE [XDCL] pfp$create_permanent_file
    (    family_location: pft$family_location;
         local_file_name: amt$local_file_name;
         path: pft$complete_path;
         cycle_number: pft$cycle_number;
         attached_pf_table_index: pft$attached_pf_table_index;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
         application_info: pft$application_info;
         validation_ring: ost$valid_ring;
         password_protected: boolean;
         enable_media_damage_detection: boolean;
         implicit_attach: boolean;
         recreate_attached_cycle_data: boolean;
         p_file_label: {input} fmt$p_file_label;
         device_class: rmt$device_class;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
         p_removable_media_req_info: {input} ^fmt$removable_media_req_info;
         p_volume_list: {input} ^rmt$volume_list;
         authority: pft$authority;
     VAR path_handle: {client only} fmt$path_handle;
     VAR system_file_id: gft$system_file_identifier;
     VAR internal_cycle_name: pft$internal_name;
     VAR bytes_allocated: amt$file_byte_address;
     VAR p_file_server_buffers: {server only: i^/o^} pft$p_file_server_buffers;
     VAR status: ost$status);

    VAR
      apfid: pft$attached_permanent_file_id,
      cycle_path_string: ost$string,
      detachment_options: fmt$detachment_options,
      dm_file_attributes: pft$dm_file_attributes,
      evaluated_file_reference: fst$evaluated_file_reference,
      file_class: string (1),
      file_info: dmt$file_information,
      file_modified: boolean,
      file_space_limit_kind: sft$file_space_limit_kind,
      fmd_modified: boolean,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      get_stored_fmd_status: ost$status,
      global_file_name: ost$binary_unique_name,
      initial_volume: ost$name,
      keypoint_operation: dft$keypoint_file_operation,
      keypoint_sfid: dft$keypoint_sfid,
      local_status: ost$status,
      p_fmd: pft$p_fmd,
      p_physical_fmd: pft$p_physical_fmd,
      path_string: ost$string,
      pf_attachment_info: fmt$pf_attachment_info,
      pfs_limit: sft$limit,
      recorded_vsn: rmt$recorded_vsn,
      stored_fmd_size: dmt$stored_fmd_size;

    IF device_class = rmc$mass_storage_device THEN
    IF sfv$dynamic_file_space_limits THEN
      sfp$get_job_limit (avc$pfs_limit_name, pfs_limit, status);
      IF status.normal THEN
        IF pfs_limit.accumulator >= pfs_limit.job_abort_limit THEN
          osp$set_status_condition (ame$file_space_limit_exceeded, status);
          pfp$convert_cycle_path_to_strng (path, cycle_number, path_string);
          osp$append_status_file (osc$status_parameter_delimiter, path_string.value (1, path_string.size),
                  status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'Permanent', status);
          RETURN;
        IFEND;
      ELSE
        status.normal := TRUE;
      IFEND;
    IFEND;

    generate_dm_file_attributes (path, pfc$file_object, validation_ring, {use_scl_variable_defaults} TRUE,
          p_mass_storage_request_info, authority, dm_file_attributes, status);

    IF status.normal THEN
    /assign_file_to_volume/
      WHILE TRUE DO
        dmp$create_file_entry ({file_type} gfc$fk_job_permanent_file, usage_selections, share_selections,
              file_share_history, ^dm_file_attributes, byte_address, assign_volume, internal_cycle_name,
              system_file_id, status);
        IF (NOT status.normal) AND (status.condition = dme$unable_to_alloc_all_space) AND
          volume_available_for_assign (path [pfc$set_path_index],
                dm_file_attributes [pfc$file_class_index].class,
                dm_file_attributes [pfc$initial_volume_index].requested_volume.recorded_vsn) THEN
            pmp$wait (assign_volume_retry_wait, assign_volume_retry_wait);
          CYCLE /assign_file_to_volume/;
        ELSE
          EXIT /assign_file_to_volume/;
        IFEND;
      WHILEND /assign_file_to_volume/;
    IFEND;

    IF status.normal THEN
      IF enable_media_damage_detection AND pfp$attach_for_write (usage_selections) THEN
        dmp$enable_damage_detection (system_file_id, internal_cycle_name, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;

      IF dm_file_attributes [pfc$file_class_index].class = rmc$unspecified_file_class THEN
        store_valid_file_class_in_fmd (path, pfc$file_object, system_file_id, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;

      IF family_location = pfc$local_mainframe THEN
        dmp$get_file_info (system_file_id, file_info, status);
        IF status.normal THEN
          bytes_allocated := file_info.total_allocated_length;
          apfid.family_location := pfc$local_mainframe;
          apfid.attached_pf_table_index := attached_pf_table_index;
          pfp$convert_pf_to_fs_structure (path, evaluated_file_reference);
          evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
          evaluated_file_reference.cycle_reference.cycle_number := cycle_number;
          IF (pfc$master_catalog_owner IN authority.ownership) AND
                ((usage_selections * pfv$write_usage) <> $pft$usage_selections []) THEN
            file_space_limit_kind := sfc$perm_file_space_limit;
          ELSE
            file_space_limit_kind := sfc$no_limit;
          IFEND;
          IF NOT recreate_attached_cycle_data THEN
            pf_attachment_info.apfid := apfid;
            pf_attachment_info.application_info := application_info;
            pf_attachment_info.implicit_attach := implicit_attach;
            pf_attachment_info.password_protected := password_protected;
            fmp$attach_file (local_file_name, internal_cycle_name, internal_cycle_name, system_file_id,
                  usage_selections, share_selections, validation_ring, file_space_limit_kind, p_file_label,
                  ^pf_attachment_info, rmc$mass_storage_device, {p_removable_media_req_info} NIL,
                  {p_volume_list} NIL, evaluated_file_reference, status);
            path_handle := evaluated_file_reference.path_handle_info.path_handle;
          IFEND;
        IFEND;
      ELSE
        set_server_output ({cycle_created} TRUE, application_info, cycle_number,
              {allow_other_mainframe_writer} FALSE, internal_cycle_name, usage_selections, share_selections,
              password_protected, attached_pf_table_index, system_file_id, p_file_label, {p_fmd} NIL,
              device_class, bytes_allocated, p_file_server_buffers, status);
      IFEND;

      IF NOT status.normal THEN
        {
        { Remove the device manager's knowledge of the file.
        {
        dmp$detach_file (system_file_id, {access_allowed} TRUE, {flush_pages} TRUE, file_modified,
              fmd_modified, file_info, local_status);
        pfp$process_unexpected_status (local_status);

        dmp$get_stored_fmd_size (system_file_id, stored_fmd_size, get_stored_fmd_status);
        IF get_stored_fmd_status.normal THEN
          PUSH p_fmd: [[REP stored_fmd_size OF cell]];
          RESET p_fmd;
          dmp$get_stored_fmd (system_file_id, p_fmd^, get_stored_fmd_status);
          pfp$process_unexpected_status (get_stored_fmd_status);
          dmp$delete_file_descriptor (system_file_id, local_status);
          pfp$process_unexpected_status (local_status);

          IF get_stored_fmd_status.normal THEN
            dmp$destroy_permanent_file (internal_cycle_name, p_fmd^, local_status);
            pfp$process_unexpected_status (local_status);
          IFEND;
        ELSE
          pfp$report_unexpected_status (get_stored_fmd_status);
        IFEND;
      IFEND;
    ELSE { Dmp$create_file_entry failed.
      {
      { Initialize initial_volume.
      {
      IF p_mass_storage_request_info <> NIL THEN
        IF p_mass_storage_request_info^.initial_volume = rmc$unspecified_vsn THEN
          initial_volume := 'Unspecified Volume.';
        ELSE
          initial_volume := p_mass_storage_request_info^.initial_volume;
        IFEND;
      ELSE
        initial_volume := 'Permanent File Device';
      IFEND;
    IFEND;

    IF status.normal THEN
      IF dfv$file_server_info_enabled THEN
        keypoint_operation.remote := (path [pfc$family_path_index] <> osv$system_family_name);
        keypoint_operation.catalog := FALSE;
        keypoint_sfid.file_entry_index := system_file_id.file_entry_index;
        keypoint_sfid.residence := system_file_id.residence;
        #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_operation.keypoint_data, dfk$create_info);
        #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_sfid.keypoint_data, dfk$sfid);
      IFEND;
    ELSEIF status.condition = ame$ring_validation_error THEN
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_ring_access,
            fs_path (1, fs_path_size), status);
    ELSEIF (status.condition = pfe$lfn_in_use) OR (status.condition = pfe$pf_system_error) OR
          (status.condition = rme$file_class_not_valid) OR (status.condition = rme$job_not_valid) OR
          (status.condition = rme$volume_overflow_required) OR (status.condition = rme$vsn_not_part_of_set) OR
          (status.condition = dme$unable_to_alloc_all_space)  THEN
      ;
    ELSEIF status.condition = rme$device_assignment_conflict THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$lfn_in_use, local_file_name,
            status);
    ELSEIF status.condition = rme$redundant_device_assignment THEN
      pfp$convert_cycle_path_to_strng (path, cycle_number, cycle_path_string);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$duplicate_purged_cycle,
            cycle_path_string.value (1, cycle_path_string.size), status);
    ELSEIF status.condition = dme$file_class_not_valid THEN
      file_class := dm_file_attributes [pfc$file_class_index].class;
      osp$set_status_abnormal (rmc$resource_management_id, rme$file_class_not_valid, initial_volume, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, file_class, status);
    ELSEIF status.condition = dme$volume_unavailable THEN
      recorded_vsn := status.text.value (2, 6);
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$volume_unavailable,
            fs_path (1, fs_path_size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, recorded_vsn, status);
    ELSEIF status.condition = dme$some_volumes_not_online THEN
      recorded_vsn := status.text.value (2, 6);
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$volume_not_online,
            fs_path (1, fs_path_size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, recorded_vsn, status);
    ELSE
      pfp$report_unexpected_status (status);
    IFEND;

    ELSEIF device_class = rmc$magnetic_tape_device THEN
      osp$generate_unique_binary_name (internal_cycle_name, status);
      IF status.normal THEN
        IF family_location = pfc$local_mainframe THEN
          dmp$create_tape_file_sfid (p_removable_media_req_info, p_volume_list, system_file_id, status);
          IF status.normal THEN
            bytes_allocated := 0;
            apfid.family_location := pfc$local_mainframe;
            apfid.attached_pf_table_index := attached_pf_table_index;
            pfp$convert_pf_to_fs_structure (path, evaluated_file_reference);
            evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
            evaluated_file_reference.cycle_reference.cycle_number := cycle_number;
            file_space_limit_kind := sfc$no_limit;
            pf_attachment_info.apfid := apfid;
            pf_attachment_info.application_info := application_info;
            pf_attachment_info.implicit_attach := implicit_attach;
            pf_attachment_info.password_protected := password_protected;
            fmp$attach_file (local_file_name, internal_cycle_name, internal_cycle_name, system_file_id,
                  usage_selections, share_selections, validation_ring, file_space_limit_kind, p_file_label,
                  ^pf_attachment_info, device_class, p_removable_media_req_info, p_volume_list,
                  evaluated_file_reference, status);
            path_handle := evaluated_file_reference.path_handle_info.path_handle;
            IF NOT status.normal THEN
              detachment_options := fmv$default_detachment_options;
              detachment_options.device_class := rmc$magnetic_tape_device;
              detachment_options.physical_unload := TRUE;
              dmp$close_tape_volume (system_file_id, detachment_options, local_status);
            IFEND;
          ELSEIF status.condition = dme$tape_attach_limit_exceeded THEN
            pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, fse$tape_attach_limit_exceeded,
                  fs_path (1, fs_path_size), status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  iov$number_of_tape_units + dmc$extra_lun_table_entries, radix, NOT include_radix, status);
          IFEND;
        ELSE {server mainframe}
          set_server_output ({cycle_created} TRUE, application_info, cycle_number,
                {allow_other_mainframe_writer} FALSE, internal_cycle_name, usage_selections, share_selections,
                password_protected, attached_pf_table_index, system_file_id, p_file_label, {p_fmd} NIL,
                device_class, bytes_allocated, p_file_server_buffers, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND pfp$create_permanent_file;

?? TITLE := '  [XDCL] pfp$destroy_catalog', EJECT ??

  PROCEDURE [XDCL] pfp$destroy_catalog
    (VAR catalog_locator: {i/o} pft$catalog_locator;
     VAR status: ost$status);

    VAR
      close_status: ost$status,
      delete_status: ost$status,
      destroy_catalog: boolean,
      destroy_status: ost$status,
      detach_status: ost$status,
      external_name: pft$name,
      file_info: dmt$file_information,
      file_modified: boolean,
      fmd_modified: boolean,
      get_stored_fmd_status: ost$status,
      keypoint_operation: dft$keypoint_file_operation,
      keypoint_sfid: dft$keypoint_sfid,
      p_fmd: pft$p_fmd,
      segment_pointer: mmt$segment_pointer,
      stored_fmd_size: dmt$stored_fmd_size;

    close_status.normal := TRUE;
    detach_status.normal := TRUE;
    get_stored_fmd_status.normal := TRUE;
    delete_status.normal := TRUE;
    destroy_status.normal := TRUE;

    IF catalog_locator.queuing_info.set_catalog_alarm THEN
      IF catalog_locator.queuing_info.attach_queued THEN
        external_name := catalog_locator.queuing_info.external_catalog_name;
      ELSE
        external_name := 'unknown';
      IFEND;
      pfp$set_catalog_alarm (catalog_locator.global_file_name, catalog_locator.internal_catalog_name,
            external_name, {destroy_on_last_detach} TRUE);
    IFEND;

    {
    { Attempt to return as many of the job and system resources as possible.
    {

    IF catalog_locator.attached THEN
      IF catalog_locator.open THEN
        segment_pointer.kind := mmc$cell_pointer;
        segment_pointer.cell_pointer := catalog_locator.p_catalog_file;
        mmp$close_segment (segment_pointer, pfc$catalog_ring, close_status);
        catalog_locator.open := FALSE;
        pfp$process_unexpected_status (close_status);
      IFEND;

      dmp$detach_file (catalog_locator.system_file_id, {access_allowed} TRUE, {flush_pages} TRUE,
            file_modified, fmd_modified, file_info, detach_status);
      catalog_locator.attached := FALSE;
      pfp$process_unexpected_status (detach_status);

      dmp$get_stored_fmd_size (catalog_locator.system_file_id, stored_fmd_size, get_stored_fmd_status);
      IF get_stored_fmd_status.normal THEN
        PUSH p_fmd: [[REP stored_fmd_size OF cell]];
        RESET p_fmd;
        dmp$get_stored_fmd (catalog_locator.system_file_id, p_fmd^, get_stored_fmd_status);
        pfp$process_unexpected_status (get_stored_fmd_status);

        IF dfv$file_server_info_enabled THEN
          keypoint_operation.remote := TRUE {unknown} ;
          keypoint_operation.catalog := TRUE;
          keypoint_sfid.file_entry_index := catalog_locator.system_file_id.file_entry_index;
          keypoint_sfid.residence := catalog_locator.system_file_id.residence;
          #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_operation.keypoint_data, dfk$delete_info);
          #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_sfid.keypoint_data, dfk$sfid);
        IFEND;

        dmp$delete_file_descriptor (catalog_locator.system_file_id, delete_status);
        destroy_catalog := delete_status.normal;
        IF NOT delete_status.normal THEN
          IF delete_status.condition = dme$file_descriptor_not_deleted THEN
            {
            { There are other users of this deleted catalog.
            {
            IF NOT catalog_locator.queuing_info.set_catalog_alarm THEN
              IF catalog_locator.queuing_info.attach_queued THEN
                external_name := catalog_locator.queuing_info.external_catalog_name;
              ELSE
                external_name := 'unknown';
              IFEND;
              pfp$set_catalog_alarm (catalog_locator.global_file_name, catalog_locator.internal_catalog_name,
                    external_name, {destroy_on_last_detach} TRUE);
            IFEND;
            delete_status.normal := TRUE;
          ELSE
            pfp$report_unexpected_status (delete_status);
          IFEND;
        ELSEIF catalog_locator.queuing_info.set_catalog_alarm THEN
          pfp$clear_catalog_alarm (catalog_locator.global_file_name);
        IFEND;

        IF catalog_locator.queuing_info.attach_queued AND catalog_locator.queuing_info.access_queued THEN
          free_internal_catalog_list (catalog_locator.queuing_info.p_internal_catalog_list);
        IFEND;

        IF get_stored_fmd_status.normal AND destroy_catalog THEN
          dmp$destroy_permanent_file (catalog_locator.global_file_name, p_fmd^, destroy_status);
          pfp$process_unexpected_status (destroy_status);
        IFEND;
      ELSE { dmp$get_stored_fmd_size failed.
        pfp$report_unexpected_status (status);
      IFEND;
    IFEND;

    IF NOT close_status.normal THEN
      status := close_status;
    ELSEIF NOT detach_status.normal THEN
      status := detach_status;
    ELSEIF NOT get_stored_fmd_status.normal THEN
      status := get_stored_fmd_status;
    ELSEIF NOT delete_status.normal THEN
      status := delete_status;
    ELSEIF NOT destroy_status.normal THEN
      status := destroy_status;
    ELSE
      status.normal := TRUE;
    IFEND;
  PROCEND pfp$destroy_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$detach_all_catalogs', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$detach_all_catalogs;

    VAR
      catalog_alarm_set: boolean,
      destroy_on_last_detach: boolean,
      ignore_catalog_deleted: boolean,
      p_queued_catalog: pft$p_queued_catalog,
      status: ost$status;

    osp$set_job_signature_lock (pfv$p_queued_catalog_table_lock^);

    find_first_queued_catalog (p_queued_catalog);
    WHILE p_queued_catalog <> NIL DO
      pfp$check_catalog_alarm (p_queued_catalog^.global_file_name, catalog_alarm_set,
            destroy_on_last_detach);
      physically_detach_catalog (p_queued_catalog^.system_file_id, p_queued_catalog^.global_file_name,
           catalog_alarm_set, destroy_on_last_detach, {flush_catalog} TRUE, ignore_catalog_deleted, status);
      pfp$process_unexpected_status (status);
      IF p_queued_catalog^.access_queued THEN
        free_internal_catalog_list (p_queued_catalog^.p_internal_catalog_list);
      IFEND;
      free_queued_catalog (p_queued_catalog);
      find_first_queued_catalog (p_queued_catalog);
    WHILEND;

    osp$clear_job_signature_lock (pfv$p_queued_catalog_table_lock^);
  PROCEND pfp$detach_all_catalogs;

?? TITLE := '  [XDCL] pfp$detach_permanent_file', EJECT ??

  PROCEDURE [XDCL] pfp$detach_permanent_file
    (    p_path: ^pft$complete_path;
         system_file_id: gft$system_file_identifier;
         usage_selections: pft$usage_selections;
         catalog_access_allowed: boolean;
         p_cycle: {i^/o^} pft$p_cycle;
         p_catalog_file: {i^/o^} pft$p_catalog_file;
     VAR fmd_modified: boolean;
     VAR file_info: dmt$file_information;
     VAR status: ost$status);

    VAR
      access_allowed: boolean,
      file_modified: boolean,
      flush_pages: boolean,
      keypoint_sfid: dft$keypoint_sfid,
      p_new_fmd: pft$p_physical_fmd,
      p_old_fmd: pft$p_physical_fmd,
      prevalidate_free_result: ost$prevalidate_free_result,
      usage_option: pft$usage_options;

    status.normal := TRUE;

    {
    { Flush pages whenever the cycle is attached with any form of write access.
    {

    access_allowed := usage_selections <> $pft$usage_selections [];
    flush_pages := ((usage_selections * $pft$usage_selections [pfc$shorten, pfc$append,
          pfc$modify]) <> $pft$usage_selections []);
    IF flush_pages THEN
    /locate_last_attach_for_write/
      FOR usage_option := pfc$shorten TO pfc$modify DO
        IF usage_option IN usage_selections THEN
          IF p_cycle^.cycle_entry.attach_status.usage_counts [usage_option] > 1 THEN
            flush_pages := FALSE;
            EXIT /locate_last_attach_for_write/;
          IFEND;
        ELSE
          IF p_cycle^.cycle_entry.attach_status.usage_counts [usage_option] > 0 THEN
            flush_pages := FALSE;
            EXIT /locate_last_attach_for_write/;
          IFEND;
        IFEND;
      FOREND /locate_last_attach_for_write/;
    IFEND;

    dmp$detach_file (system_file_id, access_allowed, flush_pages, file_modified, fmd_modified, file_info,
          status);
    IF status.normal THEN
      IF dfv$file_server_info_enabled THEN
        keypoint_sfid.file_entry_index := system_file_id.file_entry_index;
        keypoint_sfid.residence := system_file_id.residence;
        #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_sfid.keypoint_data, dfk$detach_sfid);
      IFEND;

      IF fmd_modified THEN
        IF catalog_access_allowed OR dsp$system_committed () THEN
          IF p_cycle^.cycle_entry.entry_type = pfc$normal_cycle_entry THEN
            pfp$record_dm_file_parameters (p_path, ^p_cycle^.cycle_entry.cycle_number, system_file_id,
                  rmc$mass_storage_device, {p_removable_media_req_info} NIL, {p_volume_list} NIL,
                  ^p_catalog_file^.catalog_heap,
                  p_new_fmd, status);
            IF status.normal THEN
              pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, p_catalog_file, p_old_fmd);
              pfp$build_fmd_locator (p_new_fmd, p_catalog_file, p_cycle^.cycle_entry.fmd_locator);
              pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
              IF p_old_fmd <> NIL THEN
                osp$prevalidate_free ((#OFFSET(p_old_fmd) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
                      ^p_catalog_file^.catalog_heap, prevalidate_free_result);
                IF prevalidate_free_result = osc$heap_free_valid THEN
                  FREE p_old_fmd IN p_catalog_file^.catalog_heap;
                ELSE
                  pfp$report_invalid_free (p_path, ^p_cycle^.cycle_entry.cycle_number,
                        'FILE_MEDIA_DESCRIPTOR', 'file', prevalidate_free_result, #OFFSET(p_old_fmd));
                  p_old_fmd := NIL;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      IF status.normal THEN
        dmp$delete_file_descriptor (system_file_id, status);
        IF NOT (status.normal) AND (status.condition = dme$file_descriptor_not_deleted) THEN
          status.normal := TRUE;
        IFEND;
      IFEND;
    IFEND;

  PROCEND pfp$detach_permanent_file;

?? TITLE := '  [XDCL] pfp$detach_queued_catalog', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to remove a queued catalog from the queued
{   catalog table and to detach the catalog.
{
{ NOTES:
{   The catalog detachment may be deferred; see detach_catalog for details.
{   This procedure is called by pfp$detach_unavail_queued_cat, which may need
{   to be called following an unsuccessful attempt to access a catalog due to
{   an unavailable volume.

  PROCEDURE [XDCL] pfp$detach_queued_catalog
    (    internal_catalog_name: pft$internal_catalog_name;
     VAR catalog_locator: {i/o} pft$catalog_locator);

    VAR
      local_status: ost$status,
      p_queued_catalog: ^pft$queued_catalog;

    osp$set_job_signature_lock (pfv$p_queued_catalog_table_lock^);
    find_queued_cat_by_internal (internal_catalog_name, p_queued_catalog);

    IF p_queued_catalog = NIL THEN
      osp$clear_job_signature_lock (pfv$p_queued_catalog_table_lock^);
    ELSE
      free_queued_catalog (p_queued_catalog);
      osp$clear_job_signature_lock (pfv$p_queued_catalog_table_lock^);
      catalog_locator.queuing_info.set_catalog_alarm := TRUE;
      detach_catalog (catalog_locator, local_status);
    IFEND;
  PROCEND pfp$detach_queued_catalog;

?? TITLE := '  [XDCL] pfp$dm_create_file_entry', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to interface with the file system to
{   create a permanent file without modifying and BAM or PF tables.

  PROCEDURE [XDCL] pfp$dm_create_file_entry
    (    path: pft$complete_path;
         cycle_number: pft$cycle_number;
         authority: pft$authority;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
     VAR system_file_id: gft$system_file_identifier;
     VAR global_file_name: ost$binary_unique_name;
     VAR status: ost$status);

    VAR
      cycle_path_string: ost$string,
      dm_file_attributes: pft$dm_file_attributes,
      file_class: string (1),
      fs_path_size: fst$path_size,
      initial_volume: ost$name,
      p_fs_path: ^fst$path,
      recorded_vsn: rmt$recorded_vsn;

    generate_dm_file_attributes (path, pfc$file_object, {validation_ring} osc$tsrv_ring,
          {use_scl_variable_defaults} FALSE, p_mass_storage_request_info, authority, dm_file_attributes,
          status);

    IF status.normal THEN
    /assign_file_to_volume/
      WHILE TRUE DO
        dmp$create_file_entry ({file_type} gfc$fk_job_permanent_file, usage_selections, share_selections,
              file_share_history, ^dm_file_attributes, byte_address, assign_volume, global_file_name,
              system_file_id, status);
        IF (NOT status.normal) AND (status.condition = dme$unable_to_alloc_all_space) AND
          volume_available_for_assign (path [pfc$set_path_index],
                dm_file_attributes [pfc$file_class_index].class,
                dm_file_attributes [pfc$initial_volume_index].requested_volume.recorded_vsn) THEN
            pmp$wait (assign_volume_retry_wait, assign_volume_retry_wait);
          CYCLE /assign_file_to_volume/;
        ELSE
          EXIT /assign_file_to_volume/;
        IFEND;
      WHILEND /assign_file_to_volume/;
    IFEND;

    IF NOT status.normal THEN
      {
      { Initialize initial_volume.
      {
      IF p_mass_storage_request_info <> NIL THEN
        IF p_mass_storage_request_info^.initial_volume = rmc$unspecified_vsn THEN
          initial_volume := 'Unspecified Volume.';
        ELSE
          initial_volume := p_mass_storage_request_info^.initial_volume;
        IFEND;
      ELSE
        initial_volume := 'Permanent File Device';
      IFEND;

      IF (status.condition = pfe$lfn_in_use) OR (status.condition = pfe$pf_system_error) OR
            (status.condition = rme$file_class_not_valid) OR (status.condition = rme$job_not_valid) OR
            (status.condition = rme$volume_overflow_required) OR
            (status.condition = rme$vsn_not_part_of_set) OR (status.condition =
            dme$unable_to_alloc_all_space) THEN
        ;
      ELSEIF status.condition = rme$redundant_device_assignment THEN
        pfp$convert_cycle_path_to_strng (path, cycle_number, cycle_path_string);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$duplicate_purged_cycle,
              cycle_path_string.value (1, cycle_path_string.size), status);
      ELSEIF status.condition = dme$file_class_not_valid THEN
        file_class := dm_file_attributes [pfc$file_class_index].class;
        osp$set_status_abnormal (rmc$resource_management_id, rme$file_class_not_valid, initial_volume,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, file_class, status);
      ELSEIF status.condition = dme$volume_unavailable THEN
        recorded_vsn := status.text.value (2, 6);
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$volume_unavailable,
              p_fs_path^ (1, fs_path_size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, recorded_vsn, status);
      ELSEIF status.condition = dme$some_volumes_not_online THEN
        recorded_vsn := status.text.value (2, 6);
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$volume_not_online,
              p_fs_path^ (1, fs_path_size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, recorded_vsn, status);
      ELSE
        pfp$report_unexpected_status (status);
      IFEND;
    IFEND;

  PROCEND pfp$dm_create_file_entry;

?? TITLE := '  [XDCL] pfp$get_queued_catalog', EJECT ??

  PROCEDURE [XDCL] pfp$get_queued_catalog
    (    external_catalog_name: pft$name;
         parent_internal_name: pft$internal_catalog_name;
     VAR catalog_attach_queued: boolean;
     VAR catalog_access_queued: boolean;
     VAR catalog_locator: pft$catalog_locator;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      p_queued_catalog: pft$p_queued_catalog;

    status.normal := TRUE;

    osp$set_job_signature_lock (pfv$p_queued_catalog_table_lock^);

    find_queued_cat_by_external (external_catalog_name, parent_internal_name, p_queued_catalog);
    catalog_attach_queued := (p_queued_catalog <> NIL);
    catalog_access_queued := FALSE;
    IF catalog_attach_queued THEN
      build_catalog_locator (p_queued_catalog, catalog_locator, status);
      IF status.normal THEN
        catalog_access_queued := catalog_locator.queuing_info.access_queued;
        free_queued_catalog (p_queued_catalog);
      IFEND;
    IFEND;

    osp$clear_job_signature_lock (pfv$p_queued_catalog_table_lock^);

    IF NOT status.normal THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

  PROCEND pfp$get_queued_catalog;

?? TITLE := '  [XDCL] pfp$get_root_attached', EJECT ??

  PROCEDURE [XDCL] pfp$get_root_attached
    (    set_name: stt$set_name;
     VAR catalog_locator: pft$catalog_locator;
     VAR status: ost$status);

    VAR
      p_internal_catalog_name: ^pft$internal_catalog_name,
      p_root: ^pft$root,
      p_stored_fmd: ^dmt$stored_fmd,
      p_stored_fmd_size: ^dmt$stored_fmd_size,
      root_access_queued: boolean,
      root_attach_queued: boolean,
      root_size: pft$root_size;

    pfp$get_queued_catalog (set_name, pfv$null_unique_name, root_attach_queued, root_access_queued,
          catalog_locator, status);

    IF status.normal AND (NOT root_attach_queued) THEN
      root_size := 255; {estimate}
      REPEAT
        PUSH p_root: [[REP root_size OF cell]];
        RESET p_root;
        stp$get_pf_root (set_name, root_size, p_root^, status);
      UNTIL status.normal OR (status.condition <> ste$incorrect_root_size);

      IF status.normal THEN
        RESET p_root;
        NEXT p_internal_catalog_name IN p_root;
        NEXT p_stored_fmd_size IN p_root;
        NEXT p_stored_fmd: [[REP p_stored_fmd_size^ OF cell]] IN p_root;
        pfp$physically_attach_catalog (set_name, p_internal_catalog_name^, p_internal_catalog_name^,
              p_stored_fmd, {catalog_remote} FALSE, catalog_locator, status);
        IF status.normal THEN
          catalog_locator.queuing_info.attach_queued := TRUE;
          catalog_locator.queuing_info.parent_catalog_internal_name := pfv$null_unique_name;
          catalog_locator.queuing_info.external_catalog_name := set_name;
          catalog_locator.queuing_info.charge_id.account := osc$null_name;
          catalog_locator.queuing_info.charge_id.project := osc$null_name;
          catalog_locator.queuing_info.access_queued := TRUE;
          catalog_locator.queuing_info.p_internal_catalog_list := NIL;
          catalog_locator.queuing_info.permit.entry_type := pfc$free_permit_entry;
        IFEND;
      IFEND;
    IFEND;

  PROCEND pfp$get_root_attached;

?? TITLE := '  [XDCL] pfp$open_attached_catalog', EJECT ??

  PROCEDURE [XDCL] pfp$open_attached_catalog
    (    access_kind: pft$access_kind;
     VAR catalog_locator: {i/o} pft$catalog_locator;
     VAR status: ost$status);

    VAR
      catalog_alarm_set: boolean,
      destroy_on_last_detach: boolean,
      heap_ok: boolean,
      i: integer,
      ignore_status: ost$status,
      length: integer,
      line: string (256),
      local_status: ost$status,
      segment_pointer: mmt$segment_pointer;

    catalog_locator.open := false;
    IF NOT cmp$post_deadstart() AND (access_kind = pfc$write_access) AND
            (cmp$deadstart_phase() <> osc$installation_deadstart) AND NOT pfv$allow_catalog_write THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$no_access_before_commit, '', status);
      RETURN;
    IFEND;

    mmp$open_file_segment (catalog_locator.system_file_id, NIL, mmc$cell_pointer, pfc$catalog_ring,
        sfc$no_limit, segment_pointer, status);
    catalog_locator.open := status.normal;
    IF status.normal THEN
      pfp$check_catalog_alarm (catalog_locator.global_file_name, catalog_alarm_set,
            destroy_on_last_detach);
      IF catalog_alarm_set AND destroy_on_last_detach THEN
        IF pfv$debug_catalog_access THEN
          STRINGREP (line, length, 'PFP$OPEN_ATTACHED_CATALOG',
                ' catalog alarm detected before attempting to lock catalog segment.');
          pmp$log_ascii (line (1, length), $pmt$ascii_logset [pmc$job_log, pmc$system_log],
                pmc$msg_origin_system, ignore_status);
        IFEND;
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_access_retry, '', status);
      ELSE
        IF access_kind = pfc$read_access THEN
          mmp$lock_catalog_segment (segment_pointer.cell_pointer, mmc$lus_lock_for_read, osc$nowait, status);
        ELSE
          mmp$lock_catalog_segment (segment_pointer.cell_pointer, mmc$lus_lock_for_write, osc$nowait, status);
        IFEND;
        catalog_locator.locked := status.normal;
        IF status.normal THEN
          pfp$check_catalog_alarm (catalog_locator.global_file_name, catalog_alarm_set,
                destroy_on_last_detach);
          IF catalog_alarm_set AND destroy_on_last_detach THEN
            IF pfv$debug_catalog_access THEN
              STRINGREP (line, length, 'PFP$OPEN_ATTACHED_CATALOG',
                    ' catalog alarm detected after locking catalog segment.');
              pmp$log_ascii (line (1, length), $pmt$ascii_logset [pmc$job_log, pmc$system_log],
                    pmc$msg_origin_system, ignore_status);
            IFEND;
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_access_retry, '', status);
            mmp$unlock_segment (segment_pointer.cell_pointer, mmc$lus_free, osc$nowait, local_status);
            pfp$process_unexpected_status (local_status);
          IFEND;
        ELSEIF status.condition = mme$segment_locked_another_task THEN
          IF pfv$debug_catalog_access THEN
            STRINGREP (line, length, 'PFP$OPEN_ATTACHED_CATALOG', ' unable to lock catalog segment.');
            pmp$log_ascii (line (1, length), $pmt$ascii_logset [pmc$job_log, pmc$system_log],
                  pmc$msg_origin_system, ignore_status);
          IFEND;
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_access_retry, '', status);
        IFEND;
      IFEND;

      IF status.normal THEN
        catalog_locator.access_kind := access_kind;
        catalog_locator.p_catalog_file := segment_pointer.cell_pointer;
        pfp$build_object_list_pointer (catalog_locator.p_catalog_file^.physical_catalog_header.catalog_header.
              object_list_locator, catalog_locator.p_catalog_file,
              catalog_locator.object_list_descriptor.p_object_list);
        catalog_locator.object_list_descriptor.sorted_object_count :=
              catalog_locator.p_catalog_file^.physical_catalog_header.catalog_header.object_list_locator.
              sorted_object_count;
        catalog_locator.object_list_descriptor.free_sorted_object_count :=
              catalog_locator.p_catalog_file^.physical_catalog_header.catalog_header.object_list_locator.
              free_sorted_object_count;
        catalog_locator.object_list_descriptor.catalog_type := pfc$external_catalog;
        catalog_locator.object_list_descriptor.p_physical_catalog_header :=
              ^catalog_locator.p_catalog_file^.physical_catalog_header;
        catalog_locator.flush_catalog_pages := (access_kind = pfc$write_access) AND
              pfv$flush_catalogs;
        catalog_locator.abort_catalog_operation := FALSE;

      /initialize_locked_catalog_list/
        FOR i := 1 to UPPERBOUND( pfv$locked_catalog_list) DO
          IF pfv$locked_catalog_list[i] = NIL THEN
            pfv$locked_catalog_list[i] := segment_pointer.cell_pointer;
            EXIT /initialize_locked_catalog_list/;
          IFEND;
        FOREND /initialize_locked_catalog_list/ ;

        IF pfv$verify_catalog_heaps THEN
          osp$verify_heap (^catalog_locator.p_catalog_file^.catalog_heap, heap_ok);
          IF NOT heap_ok THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$corrupted_catalog_heap,
                  'PFP$OPEN_ATTACHED_CATALOG', local_status);
            osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], local_status,
                  ignore_status);
            pfp$report_unexpected_status (local_status);
          IFEND;
        IFEND;
      ELSE
        IF osp$file_access_condition (status) THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_volume_unavailable,
                catalog_locator.recorded_vsn, status);
        ELSEIF status.condition <> pfe$catalog_access_retry THEN
          pfp$report_unexpected_status (status);
        IFEND;
        mmp$close_segment (segment_pointer, pfc$catalog_ring, local_status);
        catalog_locator.open := FALSE;
        pfp$process_unexpected_status (local_status);
      IFEND;
    ELSE
      IF osp$file_access_condition (status) THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_volume_unavailable,
              catalog_locator.recorded_vsn, status);
      ELSE
        pfp$report_unexpected_status (status);
      IFEND;
    IFEND;
  PROCEND pfp$open_attached_catalog;

?? TITLE := '  [XDCL] pfp$physically_attach_catalog', EJECT ??

  PROCEDURE [XDCL] pfp$physically_attach_catalog
    (    set_name: stt$set_name;
         internal_catalog_name: pft$internal_catalog_name;
         global_file_name: ost$binary_unique_name;
         p_fmd: {input^} pft$p_fmd;
         catalog_remote: boolean;
     VAR catalog_locator: pft$catalog_locator;
     VAR status: ost$status);

    CONST
      flush_pages = TRUE;

    VAR
      catalog_alarm_set: boolean,
      destroy_on_last_detach: boolean,
      existing_sft_entry: dmt$existing_sft_entry,
      file_damaged: boolean,
      fmd_header: pft$fmd_header,
      ignore_status: ost$status,
      keypoint_operation: dft$keypoint_file_operation,
      keypoint_sfid: dft$keypoint_sfid,
      length: integer,
      line: string (256),
      locked_file: dmt$locked_file,
      p_volume_list: ^pft$volume_list,
      recorded_vsn: rmt$recorded_vsn;

    catalog_locator.set_name := set_name;
    catalog_locator.internal_catalog_name := internal_catalog_name;
    catalog_locator.global_file_name := global_file_name;
    catalog_locator.recorded_vsn := rmc$unspecified_vsn;
    catalog_locator.new_catalog := FALSE;
    catalog_locator.queuing_info.set_catalog_alarm := FALSE;
    catalog_locator.queuing_info.attach_queued := FALSE;
    catalog_locator.attached := FALSE;

    pfp$check_catalog_alarm (global_file_name, catalog_alarm_set, destroy_on_last_detach);
    IF catalog_alarm_set AND destroy_on_last_detach THEN
      IF pfv$debug_catalog_access THEN
        STRINGREP (line, length, 'PFP$PHYSICALLY_ATTACH_CATALOG',
              ' catalog alarm detected before attempting to attach catalog.');
        pmp$log_ascii (line (1, length), $pmt$ascii_logset [pmc$job_log, pmc$system_log],
              pmc$msg_origin_system, ignore_status);
      IFEND;
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_access_retry, '', status);
      RETURN;
    IFEND;

    locked_file.required := TRUE;
    dmp$attach_file (global_file_name, gfc$fk_catalog, p_fmd^, - $pft$usage_selections [],
          - $pft$share_selections [], pfc$average_share_history, pfc$maximum_catalog_length,
          {restricted_attach} FALSE, {exit_on_unknown_file} FALSE, {server_file} FALSE,
          mmc$null_shared_queue, file_damaged, catalog_locator.system_file_id, existing_sft_entry,
          status);
    IF status.normal THEN
      catalog_locator.attached := TRUE;
      catalog_locator.open := FALSE;

      dmp$get_stored_fmd_header_info (p_fmd, fmd_header, status);
      IF status.normal AND (fmd_header.number_of_subfiles > 0) THEN
        PUSH p_volume_list: [1 .. fmd_header.number_of_subfiles];
        dmp$get_stored_fmd_volume_list (p_fmd, p_volume_list, status);
        IF status.normal THEN
          catalog_locator.recorded_vsn := p_volume_list^ [1];
        IFEND;
      IFEND;

      IF dfv$file_server_info_enabled THEN
        keypoint_operation.remote := catalog_remote;
        keypoint_operation.catalog := TRUE;
        keypoint_sfid.file_entry_index := catalog_locator.system_file_id.file_entry_index;
        keypoint_sfid.residence := catalog_locator.system_file_id.residence;
        #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_operation.keypoint_data, dfk$attach_info);
        #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_sfid.keypoint_data, dfk$sfid);
      IFEND;
    ELSE
      IF status.condition = dme$volume_unavailable THEN
        recorded_vsn := status.text.value (2, 6);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_volume_unavailable,
              recorded_vsn, status);
        catalog_locator.recorded_vsn := recorded_vsn;
      ELSEIF status.condition = dme$some_volumes_not_online THEN
        recorded_vsn := status.text.value (2, 6);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_volume_not_online,
              recorded_vsn, status);
        catalog_locator.recorded_vsn := recorded_vsn;
      ELSE
        pfp$report_unexpected_status (status);
      IFEND;
    IFEND;
  PROCEND pfp$physically_attach_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$r2_get_queued_catalog_table', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_get_queued_catalog_table
    (VAR p_info: {i^/o} pft$p_table_info;
     VAR status: ost$status);

    VAR
      p_external_name: ^pft$name,
      p_info_internal_catalog: pft$p_queued_internal_catalog,
      p_newest_catalog: pft$p_queued_catalog,
      p_next_internal_catalog: pft$p_queued_internal_catalog,
      p_record_id: ^pft$record_id,
      p_table: pft$p_queued_catalog_table,
      p_table_lock: ^ost$signature_lock,
      p_table_name: ^pft$table_name,
      p_table_size: ^integer,
      pp_newest_queued_catalog: ^pft$p_queued_catalog,
      pp_table: ^pft$p_queued_catalog_table,
      qct_entry: integer;

    status.normal := TRUE;

    NEXT p_table_name IN p_info;
    IF p_table_name = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'table name', status);
      RETURN;
    IFEND;
    p_table_name^ := 'QUEUED_CATALOG_TABLE';
    {
    { Put the table out in the queued order, i.e. from newest to oldest.
    {
    NEXT p_record_id IN p_info;
    IF p_record_id = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
      RETURN;
    IFEND;
    p_record_id^ := 'AGEINFOT';

    NEXT p_table_size IN p_info;
    IF p_table_size = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'table size', status);
      RETURN;
    IFEND;
    p_table_size^ := 0;

    find_first_queued_catalog (p_newest_catalog);
    WHILE p_newest_catalog <> NIL DO
      NEXT p_external_name IN p_info;
      IF p_external_name = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'external name', status);
        RETURN;
      IFEND;
      p_external_name^ := p_newest_catalog^.external_catalog_name;
      p_table_size^ := p_table_size^ +1;
      find_next_queued_catalog (p_newest_catalog, p_newest_catalog);
    WHILEND;

    NEXT p_record_id IN p_info;
    IF p_record_id = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
      RETURN;
    IFEND;
    p_record_id^ := 'TABLLOCK';

    NEXT p_table_lock IN p_info;
    IF p_table_lock = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'table lock', status);
      RETURN;
    IFEND;
    p_table_lock^ := pfv$p_queued_catalog_table_lock^;

    NEXT p_record_id IN p_info;
    IF p_record_id = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
      RETURN;
    IFEND;
    p_record_id^ := 'PNEWQCAT';

    NEXT pp_newest_queued_catalog IN p_info;
    IF pp_newest_queued_catalog = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'p newest queued', status);
      RETURN;
    IFEND;
    pp_newest_queued_catalog^ := pfv$p_p_newest_queued_catalog^;

    NEXT p_record_id IN p_info;
    IF p_record_id = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
      RETURN;
    IFEND;
    p_record_id^ := 'QCTSTART';

    NEXT pp_table IN p_info;
    IF pp_table = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'p qct', status);
      RETURN;
    IFEND;
    pp_table^ := pfv$p_p_queued_catalog_table^;

    NEXT p_record_id IN p_info;
    IF p_record_id = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
      RETURN;
    IFEND;
    p_record_id^ := 'TABLSIZE';

    NEXT p_table_size IN p_info;
    IF p_table_size = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'table size', status);
      RETURN;
    ELSEIF pfv$p_p_queued_catalog_table^ = NIL THEN
      p_table_size^ := 0;
    ELSE
      p_table_size^ := UPPERBOUND (pfv$p_p_queued_catalog_table^^);

      NEXT p_record_id IN p_info;
      IF p_record_id = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
        RETURN;
      IFEND;
      p_record_id^ := 'QCATABLE';

      NEXT p_table: [1 .. p_table_size^] IN p_info;
      IF p_table = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'table', status);
        RETURN;
      IFEND;
      p_table^ := pfv$p_p_queued_catalog_table^^;
      {
      { Now go through and append any internally queued catalogs.
      {
      NEXT p_record_id IN p_info;
      IF p_record_id = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'record id', status);
        RETURN;
      IFEND;
      p_record_id^ := 'NOINTCAT';

      NEXT p_table_size IN p_info;
      IF p_table_size = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'table size', status);
        RETURN;
      IFEND;
      p_table_size^ := 0;

      FOR qct_entry := 1 TO UPPERBOUND (pfv$p_p_queued_catalog_table^^) DO
        IF pfv$p_p_queued_catalog_table^^ [qct_entry].valid_catalog AND
              pfv$p_p_queued_catalog_table^^ [qct_entry].access_queued THEN
          p_next_internal_catalog := pfv$p_p_queued_catalog_table^^ [qct_entry].p_internal_catalog_list;
          WHILE p_next_internal_catalog <> NIL DO
            NEXT p_info_internal_catalog IN p_info;
            IF p_info_internal_catalog = NIL THEN
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'internal catalog',
                    status);
              RETURN;
            IFEND;
            p_table_size^ := p_table_size^ +1;
            p_info_internal_catalog^ := p_next_internal_catalog^;
            p_next_internal_catalog := p_next_internal_catalog^.p_next_internal_catalog;
          WHILEND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND pfp$r2_get_queued_catalog_table;

?? TITLE := '  [XDCL] pfp$reconcile_fmd', EJECT ??
*copy pfh$reconcile_fmd

  PROCEDURE [XDCL] pfp$reconcile_fmd
    (    p_path: ^pft$complete_path;
         internal_cycle_name: pft$internal_name;
         existing_sft_entry: dmt$existing_sft_entry;
         update_catalog: boolean;
         p_catalog_file: {i^/o^} pft$p_catalog_file;
         p_cycle: {i^/o^} pft$p_cycle;
     VAR p_physical_fmd: {i^/o^} pft$p_physical_fmd;
     VAR status: ost$status);

    VAR
      fmd_size: dmt$stored_fmd_size,
      mass_storage_class: dmt$class,
      p_mainframe_usage_list: ^pft$mainframe_usage_list,
      p_new_physical_fmd: ^pft$physical_fmd,
      prevalidate_free_result: ost$prevalidate_free_result,
      resides_on_system_device: boolean,
      share_option: pft$share_options,
      usage_option: pft$usage_options;

    status.normal := TRUE;

    IF (existing_sft_entry <> dmc$normal_entry) AND
        (p_cycle^.cycle_entry.attach_status.attach_count > 0) THEN
      IF ((p_cycle^.cycle_entry.attach_status.usage_counts[pfc$shorten] > 0) OR
            (p_cycle^.cycle_entry.attach_status.usage_counts[pfc$append] > 0) OR
            (p_cycle^.cycle_entry.attach_status.usage_counts[pfc$modify] > 0)) AND
            (existing_sft_entry <> dmc$restricted_attach_entry) THEN
        dmp$reconcile_fmd (dmv$reconcile_locator, internal_cycle_name, p_physical_fmd^.fmd,
              {purge_file} FALSE, mass_storage_class, fmd_size, resides_on_system_device, status);

        IF status.normal OR (status.condition = dme$update_fmd) THEN
          IF NOT status.normal THEN
            IF update_catalog THEN
              ALLOCATE p_new_physical_fmd: [[REP fmd_size OF cell]] IN p_catalog_file^.catalog_heap;
            ELSE
              ALLOCATE p_new_physical_fmd: [[REP fmd_size OF cell]] IN osv$job_pageable_heap^;
            IFEND;

            IF p_new_physical_fmd = NIL THEN
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full,
                    'cycle fmd', status);
            ELSE
              dmp$get_reconciled_fmd (dmv$reconcile_locator, internal_cycle_name,
                    p_physical_fmd^.fmd, p_new_physical_fmd^.fmd, status);
              IF status.normal THEN
                pfp$compute_checksum (^p_new_physical_fmd^.fmd, #SIZE (p_new_physical_fmd^.fmd),
                      p_new_physical_fmd^.checksum);

                IF update_catalog THEN
                  pfp$build_fmd_locator (p_new_physical_fmd, p_catalog_file,
                        p_cycle^.cycle_entry.fmd_locator);
                  osp$prevalidate_free ((#OFFSET(p_physical_fmd) -
                        #OFFSET(^p_catalog_file^.catalog_heap) - 16), ^p_catalog_file^.catalog_heap,
                        prevalidate_free_result);
                  IF prevalidate_free_result = osc$heap_free_valid THEN
                    FREE p_physical_fmd IN p_catalog_file^.catalog_heap;
                  ELSE
                    pfp$report_invalid_free (p_path, ^p_cycle^.cycle_entry.cycle_number,
                          'FILE_MEDIA_DESCRIPTOR', 'file', prevalidate_free_result,
                          #OFFSET(p_physical_fmd));
                    p_physical_fmd := NIL;
                  IFEND;
                IFEND;
                p_physical_fmd := p_new_physical_fmd;
              ELSE
                pfp$report_unexpected_status (status);
              IFEND;
            IFEND;
          IFEND;
        ELSEIF NOT osp$file_access_condition (status) THEN
          IF (dmv$reconcile_locator = NIL) AND NOT dsp$system_committed () THEN
            {
            { When attaching prior to building the reconcile list, overflow
            { must not be allowed.
            {
            status.normal := TRUE;
          ELSE
            pfp$report_unexpected_status (status);
          IFEND;
        IFEND;
      IFEND;
      {
      { Clear all attach, usage, prevent usage and mainframe usage counts.
      {
      IF update_catalog AND status.normal THEN
        p_cycle^.cycle_entry.attach_status := pfv$unattached_status;

        p_cycle^.cycle_entry.first_mainframe_usage_entry.entry_type := pfc$free_mainframe_entry;
        pfp$build_mainfram_list_pointer (p_cycle^.cycle_entry.mainframe_usage_list_locator, p_catalog_file,
              p_mainframe_usage_list);
        IF p_mainframe_usage_list <> NIL THEN
          osp$prevalidate_free ((#OFFSET(p_mainframe_usage_list) -
                #OFFSET(^p_catalog_file^.catalog_heap) - 16),
                ^p_catalog_file^.catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_mainframe_usage_list IN p_catalog_file^.catalog_heap;
          ELSE
            pfp$report_invalid_free (p_path, ^p_cycle^.cycle_entry.cycle_number, 'MAINFRAME_USAGE_LIST',
                  'file', prevalidate_free_result, #OFFSET(p_mainframe_usage_list));
            p_mainframe_usage_list := NIL;
          IFEND;
        IFEND;
        pfp$build_mainfram_list_locator ({p_mainframe_usage_list} NIL, {p_catalog_file} NIL,
              p_cycle^.cycle_entry.mainframe_usage_list_locator);

        pfp$compute_checksum (^p_cycle^.cycle_entry, #SIZE (pft$cycle_entry), p_cycle^.checksum);
      IFEND;
    IFEND;
  PROCEND pfp$reconcile_fmd;

?? TITLE := '  [XDCL] pfp$record_dm_file_parameters', EJECT ??

  PROCEDURE [XDCL] pfp$record_dm_file_parameters
    (    p_path: ^pft$complete_path;
         p_cycle_number: ^pft$cycle_number;
         system_file_id: gft$system_file_identifier;
         device_class: rmt$device_class;
         p_removable_media_req_info: {input^} ^fmt$removable_media_req_info;
         p_volume_list: {input^} ^rmt$volume_list;
         p_catalog_heap: {output^} pft$p_catalog_heap;
     VAR p_new_stored_fmd: {output} pft$p_physical_fmd;
     VAR status: ost$status);

    VAR
      p_fmd: ^pft$fmd,
      p_stored_tape_fmd_header: ^dmt$stored_tape_fmd_header,
      p_stored_tape_volume_list: ^dmt$stored_tape_volume_list,
      prevalidate_free_result: ost$prevalidate_free_result,
      stored_fmd_size: dmt$stored_fmd_size,
      volume_list_index: integer;

    status.normal := TRUE;

    IF device_class = rmc$mass_storage_device THEN
      REPEAT
        dmp$get_stored_fmd_size (system_file_id, stored_fmd_size, status);
        IF status.normal THEN
          ALLOCATE p_new_stored_fmd: [[REP stored_fmd_size OF cell]] IN p_catalog_heap^;
          IF p_new_stored_fmd = NIL THEN
            osp$set_status_condition (pfe$catalog_full, status);
          ELSE
            dmp$get_stored_fmd (system_file_id, p_new_stored_fmd^.fmd, status);
            IF NOT status.normal THEN
              osp$prevalidate_free ((#OFFSET(p_new_stored_fmd) - #OFFSET(p_catalog_heap) - 16),
                    p_catalog_heap, prevalidate_free_result);
              IF prevalidate_free_result = osc$heap_free_valid THEN
                FREE p_new_stored_fmd IN p_catalog_heap^;
              ELSE
                IF p_cycle_number <> NIL THEN
                  pfp$report_invalid_free (p_path, p_cycle_number, 'FILE_MEDIA_DESCRIPTOR', 'file',
                        prevalidate_free_result, #OFFSET(p_new_stored_fmd));
                ELSE
                  pfp$report_invalid_free (p_path, {p_cycle_number} NIL, 'FILE_MEDIA_DESCRIPTOR', 'catalog',
                        prevalidate_free_result, #OFFSET(p_new_stored_fmd));
                IFEND;
                p_new_stored_fmd := NIL;
              IFEND;
              IF status.condition <> dme$fmd_too_small THEN
                pfp$report_unexpected_status (status);
              IFEND;
            IFEND;
          IFEND;
        ELSE
          pfp$report_unexpected_status (status);
        IFEND;
      UNTIL status.normal OR (status.condition <> dme$fmd_too_small);

    ELSEIF device_class = rmc$magnetic_tape_device THEN
      PUSH p_stored_tape_volume_list: [1 .. UPPERBOUND (p_volume_list^)];
      stored_fmd_size := #SIZE(dmt$stored_tape_fmd_header) +
           #SIZE(p_stored_tape_volume_list^);

      ALLOCATE p_new_stored_fmd: [[REP stored_fmd_size OF cell]] IN p_catalog_heap^;
      IF p_new_stored_fmd = NIL THEN
        osp$set_status_condition (pfe$catalog_full, status);
      IFEND;

      IF status.normal THEN
        p_fmd := ^p_new_stored_fmd^.fmd;
        NEXT p_stored_tape_fmd_header IN p_fmd;
        p_stored_tape_fmd_header^.version := dmc$stored_tape_fmd_version_1;
        pfp$convert_density_to_dm (p_removable_media_req_info^.density, p_stored_tape_fmd_header^.density);
        p_stored_tape_fmd_header^.removable_media_group :=
              p_removable_media_req_info^.removable_media_group;
        p_stored_tape_fmd_header^.volume_count := UPPERBOUND (p_volume_list^);
        p_stored_tape_fmd_header^.volume_overflow_allowed :=
              p_removable_media_req_info^.volume_overflow_allowed;
        p_stored_tape_fmd_header^.reserved_tape_fmd_header_space :=
              pfv$null_tape_fmd_header_space;

        NEXT p_stored_tape_volume_list: [1 .. UPPERBOUND (p_volume_list^)] IN p_fmd;

        FOR volume_list_index := 1 TO UPPERBOUND (p_volume_list^) DO
          p_stored_tape_volume_list^ [volume_list_index].external_vsn :=
                p_volume_list^ [volume_list_index].external_vsn;
          p_stored_tape_volume_list^ [volume_list_index].recorded_vsn :=
                p_volume_list^ [volume_list_index].recorded_vsn;
        FOREND;
      IFEND;
    IFEND;

    IF status.normal THEN
      pfp$compute_checksum (#LOC (p_new_stored_fmd^.fmd), #SIZE (p_new_stored_fmd^.fmd),
            p_new_stored_fmd^.checksum);
    IFEND;
    #KEYPOINT (osk$debug, 0, pfk$record_dm_file_parameters);
  PROCEND pfp$record_dm_file_parameters;

?? TITLE := '  [XDCL] pfp$remove_queued_catalogs', EJECT ??
{ PURPOSE:
{   This procedure deletes the queued catalog table.
{
{ DESIGN:
{   The job file manager is called to remove catalog entries from the job file
{   table.
{
{ NOTES:
{   This procedure is intended to be used only by active job recovery!  This
{   procedures does NOT assume that rollback has occurred!

  PROCEDURE [XDCL] pfp$remove_queued_catalogs;

    VAR
      display_status: ost$status,
      lock_status: ost$signature_lock_status,
      p_queued_catalog: pft$p_queued_catalog,
      status: ost$status;

    osp$test_signature_lock (pfv$p_queued_catalog_table_lock^, lock_status, status);
    pfp$process_unexpected_status (status);
    IF lock_status <> osc$sls_not_locked THEN
      osp$log_job_recovery_message ('PF queued catalog table locked.', display_status);
      osp$initialize_signature_lock (pfv$p_queued_catalog_table_lock^, status);
      pfp$process_unexpected_status (status);
      pfv$p_p_queued_catalog_table^ := NIL;
      pfv$p_p_newest_queued_catalog^ := NIL;
    IFEND;

    find_first_queued_catalog (p_queued_catalog);

  /free_all_internal_catalogs/
    WHILE p_queued_catalog <> NIL DO
      IF p_queued_catalog^.access_queued THEN
        free_internal_catalog_list (p_queued_catalog^.p_internal_catalog_list);
      IFEND;
      free_queued_catalog (p_queued_catalog);
      find_first_queued_catalog (p_queued_catalog);
    WHILEND /free_all_internal_catalogs/;

    pfv$p_p_newest_queued_catalog^ := NIL;

    IF pfv$p_queued_catalog_table <> NIL THEN
      FREE pfv$p_p_queued_catalog_table^ IN pfv$p_p_job_heap^^;
    IFEND;

  PROCEND pfp$remove_queued_catalogs;

?? TITLE := '  [XDCL] pfp$return_catalog', EJECT ??

  PROCEDURE [XDCL] pfp$return_catalog
    (VAR catalog_locator: {i/o} pft$catalog_locator;
     VAR status: ost$status);

    VAR
      close_status: ost$status,
      detach_status: ost$status,
      external_name: pft$name,
      file_returned: boolean,
      heap_ok: boolean,
      i: integer,
      ignore_status: ost$status,
      local_status: ost$status,
      segment_pointer: mmt$segment_pointer,
      unlock_status: ost$status;

    unlock_status.normal := TRUE;
    close_status.normal := TRUE;
    detach_status.normal := TRUE;

    IF catalog_locator.queuing_info.set_catalog_alarm THEN
      IF catalog_locator.queuing_info.attach_queued THEN
        external_name := catalog_locator.queuing_info.external_catalog_name;
      ELSE
        external_name := 'unknown';
      IFEND;
      pfp$set_catalog_alarm (catalog_locator.global_file_name, catalog_locator.internal_catalog_name,
            external_name, {destroy_on_last_detach} FALSE);
    IFEND;

    IF catalog_locator.attached THEN
      IF catalog_locator.open THEN
        IF pfv$verify_catalog_heaps THEN
          osp$verify_heap (^catalog_locator.p_catalog_file^.catalog_heap, heap_ok);
          IF NOT heap_ok THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$corrupted_catalog_heap,
                  'PFP$RETURN_CATALOG', local_status);
            osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], local_status,
                  ignore_status);
            pfp$report_unexpected_status (local_status);
          IFEND;
        IFEND;
        IF catalog_locator.locked THEN
          IF catalog_locator.abort_catalog_operation THEN
            mmp$unlock_segment (catalog_locator.p_catalog_file, mmc$lus_free, osc$nowait, unlock_status);
          ELSEIF catalog_locator.flush_catalog_pages THEN
            mmp$unlock_segment (catalog_locator.p_catalog_file, mmc$lus_protected_write, osc$nowait,
                  unlock_status);
          ELSE
            mmp$unlock_segment (catalog_locator.p_catalog_file, mmc$lus_none, osc$nowait, unlock_status);
          IFEND;
          catalog_locator.locked := FALSE;

      /initialize_locked_catalog_list/
          FOR i := 1 TO UPPERBOUND (pfv$locked_catalog_list) DO
            IF pfv$locked_catalog_list [i] <> NIL THEN
              IF #segment(pfv$locked_catalog_list[i]) = #segment(catalog_locator.p_catalog_file) THEN
                pfv$locked_catalog_list [i] := NIL;
                EXIT /initialize_locked_catalog_list/;
              IFEND;
            IFEND;
          FOREND /initialize_locked_catalog_list/;
          pfp$process_unexpected_status (unlock_status);
        IFEND;

        segment_pointer.kind := mmc$cell_pointer;
        segment_pointer.cell_pointer := catalog_locator.p_catalog_file;
        mmp$close_segment (segment_pointer, pfc$catalog_ring, close_status);
        catalog_locator.open := FALSE;
        pfp$process_unexpected_status (close_status);
      IFEND;

      detach_catalog (catalog_locator, detach_status);
      catalog_locator.attached := FALSE;
      pfp$process_unexpected_status (detach_status);
    IFEND;

    IF NOT unlock_status.normal THEN
      status := unlock_status;
    ELSEIF NOT close_status.normal THEN
      status := close_status;
    ELSEIF NOT detach_status.normal THEN
      status := detach_status;
    ELSE
      status.normal := TRUE;
    IFEND;
  PROCEND pfp$return_catalog;

?? TITLE := '  [XDCL] pfp$update_stale_cycle_entry', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to update new items which were added to
{   the cycle entry in R1.4.1.  These items will be stale if the file cycle was
{   created or modified by an R1.3.1 or older version of the system.
{
{ DESIGN:
{   The items in the cycle entry which are updated are eoi, bytes_allocated,
{   and data_modification_date_time.
{
{ NOTE:
{   This procedure should be deleted two releases after R1.4.1, when it is no
{   longer necessary to support an upgrade from an R1.3.1 or earlier system.

  PROCEDURE [XDCL] pfp$update_stale_cycle_entry
    (    system_file_id: gft$system_file_identifier;
         p_physical_cycle: {i^/o^} ^pft$physical_cycle;
     VAR status: ost$status);

    VAR
      dm_file_information: dmt$file_information;

    IF p_physical_cycle^.cycle_entry.attach_status.attach_count = 0 THEN
      dmp$get_file_info (system_file_id, dm_file_information, status);

      IF status.normal THEN
        p_physical_cycle^.cycle_entry.data_modification_date_time :=
              p_physical_cycle^.cycle_entry.cycle_statistics.modification_date_time;
        p_physical_cycle^.cycle_entry.device_information.eoi := dm_file_information.eoi_byte_address;
        p_physical_cycle^.cycle_entry.device_information.bytes_allocated :=
              dm_file_information.total_allocated_length;
        pfp$compute_checksum (#LOC (p_physical_cycle^.cycle_entry), #SIZE (pft$cycle_entry),
              p_physical_cycle^.checksum);
      IFEND;
    IFEND;
  PROCEND pfp$update_stale_cycle_entry;

?? TITLE := '  [XDCL] pfp$validate_ring_access', EJECT ??

  PROCEDURE [XDCL] pfp$validate_ring_access
    (    path: pft$complete_path;
         p_file_label: {input} fmt$p_file_label;
         usage_selections: pft$usage_selections;
         validation_ring: ost$valid_ring;
     VAR status: ost$status);

    VAR
      cycle_formerly_opened_info: fmt$cycle_formerly_opened_info,
      fs_path_size: fst$path_size,
      p_fs_path: ^fst$path,
      valid_ring: boolean;

    fmi$get_ring_attributes (p_file_label, cycle_formerly_opened_info, status);
    IF status.normal THEN
      fmi$validate_ring_attributes (cycle_formerly_opened_info, usage_selections, validation_ring,
            valid_ring);
      IF NOT valid_ring THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_ring_access,
              p_fs_path^ (1, fs_path_size), status);
      IFEND;
    ELSE
      PUSH p_fs_path;
      pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_fs_path^ (1, fs_path_size), status);
    IFEND;
  PROCEND pfp$validate_ring_access;

?? TITLE := '  build_catalog_locator', EJECT ??

  PROCEDURE build_catalog_locator
    (    p_queued_catalog: {i^/o^} ^pft$queued_catalog;
     VAR catalog_locator: pft$catalog_locator;
     VAR status: ost$status);

    VAR
      catalog_alarm_set: boolean,
      ignore_destroy_on_last_detach: boolean;

    #KEYPOINT (osk$debug, 0, pfk$queued_catalog_found);

    status.normal := TRUE;

    catalog_locator.set_name := p_queued_catalog^.set_name;
    catalog_locator.internal_catalog_name := p_queued_catalog^.internal_catalog_name;
    catalog_locator.global_file_name := p_queued_catalog^.global_file_name;
    catalog_locator.recorded_vsn := p_queued_catalog^.recorded_vsn;
    catalog_locator.new_catalog := FALSE;
    catalog_locator.attached := TRUE;
    catalog_locator.system_file_id := p_queued_catalog^.system_file_id;
    catalog_locator.open := FALSE;

    catalog_locator.queuing_info.set_catalog_alarm := FALSE;
    catalog_locator.queuing_info.attach_queued := TRUE;
    catalog_locator.queuing_info.parent_catalog_internal_name :=
          p_queued_catalog^.parent_catalog_internal_name;
    catalog_locator.queuing_info.external_catalog_name := p_queued_catalog^.external_catalog_name;
    catalog_locator.queuing_info.charge_id := p_queued_catalog^.charge_id;
    catalog_locator.queuing_info.access_queued := p_queued_catalog^.access_queued;

    IF catalog_locator.queuing_info.access_queued THEN
      catalog_locator.queuing_info.p_internal_catalog_list := p_queued_catalog^.p_internal_catalog_list;
      catalog_locator.queuing_info.permit.entry_type := p_queued_catalog^.permit.entry_type;

      IF catalog_locator.queuing_info.permit.entry_type = pfc$normal_permit_entry THEN
        catalog_locator.queuing_info.permit.group.group_type := p_queued_catalog^.permit.group_type;
        CASE p_queued_catalog^.permit.group_type OF
        = pfc$public =
          ;
        = pfc$family =
          catalog_locator.queuing_info.permit.group.family_description.family := pfv$task_family;
        = pfc$account =
          catalog_locator.queuing_info.permit.group.account_description.family := pfv$task_family;
          catalog_locator.queuing_info.permit.group.account_description.account := pfv$task_account;
        = pfc$project =
          catalog_locator.queuing_info.permit.group.project_description.family := pfv$task_family;
          catalog_locator.queuing_info.permit.group.project_description.account := pfv$task_account;
          catalog_locator.queuing_info.permit.group.project_description.project := pfv$task_project;
        = pfc$user =
          catalog_locator.queuing_info.permit.group.user_description.family := pfv$task_family;
          catalog_locator.queuing_info.permit.group.user_description.user := pfv$task_user;
        = pfc$user_account =
          catalog_locator.queuing_info.permit.group.user_account_description.family := pfv$task_family;
          catalog_locator.queuing_info.permit.group.user_account_description.account := pfv$task_account;
          catalog_locator.queuing_info.permit.group.user_account_description.user := pfv$task_user;
        = pfc$member =
          catalog_locator.queuing_info.permit.group.member_description.family := pfv$task_family;
          catalog_locator.queuing_info.permit.group.member_description.account := pfv$task_account;
          catalog_locator.queuing_info.permit.group.member_description.project := pfv$task_project;
          catalog_locator.queuing_info.permit.group.member_description.user := pfv$task_user;
        ELSE
          ;
        CASEND;
        catalog_locator.queuing_info.permit.usage_permissions := p_queued_catalog^.permit.usage_permissions;
        catalog_locator.queuing_info.permit.share_requirements := p_queued_catalog^.permit.share_requirements;
        catalog_locator.queuing_info.permit.application_info := p_queued_catalog^.permit.application_info;
      IFEND;
    IFEND;

    pfp$check_catalog_alarm (p_queued_catalog^.global_file_name, catalog_alarm_set,
          ignore_destroy_on_last_detach);
    IF catalog_alarm_set THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_access_retry, '', status);
    IFEND;

  PROCEND build_catalog_locator;

?? TITLE := '  [INLINE] create_queued_catalog_table', EJECT ??

  PROCEDURE [INLINE] create_queued_catalog_table;

    VAR
      index: integer,
      p_current: pft$p_queued_catalog;


    IF (pfv$p_p_queued_catalog_table^ = NIL) AND (pfc$queued_catalog_table_size > 0) THEN
      ALLOCATE pfv$p_p_queued_catalog_table^: [1 .. pfc$queued_catalog_table_size] IN pfv$p_p_job_heap^^;
    IFEND;

    IF pfv$p_p_queued_catalog_table^ <> NIL THEN
      pfv$p_p_newest_queued_catalog^ := ^pfv$p_p_queued_catalog_table^^ [1];
      FOR index := UPPERBOUND (pfv$p_p_queued_catalog_table^^) DOWNTO 1 DO
        p_current := ^pfv$p_p_queued_catalog_table^^ [index];
        p_current^.valid_catalog := FALSE;
        p_current^.p_next_newest := pfv$p_p_newest_queued_catalog^;
        pfv$p_p_newest_queued_catalog^^.p_next_oldest := p_current;
        pfv$p_p_newest_queued_catalog^ := p_current;
      FOREND;
    IFEND;
  PROCEND create_queued_catalog_table;

?? TITLE := '  detach_catalog', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to do one or more of the following:
{     o detach the catalog (the catalog will be destroyed if it has a
{       destroy_on_last_detach catalog alarm and this is the last detach)
{     o dequeue all subcatalogs internal to the catalog
{     o queue the catalog
{
{ NOTE:
{   If this procedure is changed, then pfp$detach_unavail_queued_cat may also
{   need to be changed.

  PROCEDURE detach_catalog
    (VAR catalog_locator: {i/o} pft$catalog_locator;
     VAR status: ost$status);

    VAR
      catalog_alarm_set: boolean,
      catalog_deleted: boolean,
      catalog_detached: boolean,
      destroy_on_last_detach: boolean,
      external_name: pft$name,
      old_queued_catalog: pft$queued_catalog,
      p_newest_queued_catalog: ^pft$queued_catalog,
      p_queued_catalog: pft$p_queued_catalog;

    status.normal := TRUE;
    catalog_detached := FALSE;

    {
    { Determine whether the catalog should be detached now or queued for later use.
    {

    pfp$check_catalog_alarm (catalog_locator.global_file_name, catalog_alarm_set,
          destroy_on_last_detach);

    IF catalog_locator.new_catalog OR (NOT catalog_locator.queuing_info.attach_queued) OR
          catalog_alarm_set THEN
      physically_detach_catalog (catalog_locator.system_file_id, catalog_locator.global_file_name,
            catalog_alarm_set, destroy_on_last_detach, {flush_catalog} TRUE, catalog_deleted, status);
      catalog_detached := TRUE;
    IFEND;

    IF status.normal THEN
      IF catalog_detached THEN
        IF catalog_alarm_set THEN
          osp$set_job_signature_lock (pfv$p_queued_catalog_table_lock^);
          find_queued_cat_by_internal (catalog_locator.internal_catalog_name, p_queued_catalog);
          IF p_queued_catalog <> NIL THEN
            free_internal_catalog_list (catalog_locator.queuing_info.p_internal_catalog_list);
            free_queued_catalog (p_queued_catalog);
          IFEND;
          osp$clear_job_signature_lock (pfv$p_queued_catalog_table_lock^);
        IFEND;
      ELSE
        {
        { The catalog was not detached; queue the catalog for later use.
        {
        osp$set_job_signature_lock (pfv$p_queued_catalog_table_lock^);
        rotate_catalog_queue (p_newest_queued_catalog);
        IF p_newest_queued_catalog <> NIL THEN
          old_queued_catalog := p_newest_queued_catalog^;
          {
          { Build queued catalog table entry from catalog_locator.
          {
          p_newest_queued_catalog^.valid_catalog := TRUE;
          p_newest_queued_catalog^.set_name := catalog_locator.set_name;
          p_newest_queued_catalog^.parent_catalog_internal_name :=
                catalog_locator.queuing_info.parent_catalog_internal_name;
          p_newest_queued_catalog^.external_catalog_name :=
                catalog_locator.queuing_info.external_catalog_name;
          p_newest_queued_catalog^.internal_catalog_name := catalog_locator.internal_catalog_name;
          p_newest_queued_catalog^.global_file_name := catalog_locator.global_file_name;
          p_newest_queued_catalog^.recorded_vsn := catalog_locator.recorded_vsn;
          p_newest_queued_catalog^.charge_id := catalog_locator.queuing_info.charge_id;
          p_newest_queued_catalog^.system_file_id := catalog_locator.system_file_id;
          p_newest_queued_catalog^.access_queued := catalog_locator.queuing_info.access_queued;
          IF p_newest_queued_catalog^.access_queued THEN
            p_newest_queued_catalog^.p_internal_catalog_list :=
                  catalog_locator.queuing_info.p_internal_catalog_list;
            p_newest_queued_catalog^.permit.entry_type := catalog_locator.queuing_info.permit.entry_type;
            IF p_newest_queued_catalog^.permit.entry_type = pfc$normal_permit_entry THEN
              p_newest_queued_catalog^.permit.usage_permissions :=
                    catalog_locator.queuing_info.permit.usage_permissions;
              p_newest_queued_catalog^.permit.share_requirements :=
                    catalog_locator.queuing_info.permit.share_requirements;
              p_newest_queued_catalog^.permit.application_info :=
                    catalog_locator.queuing_info.permit.application_info;
              p_newest_queued_catalog^.permit.group_type :=
                    catalog_locator.queuing_info.permit.group.group_type;
            IFEND;
          IFEND;
        IFEND;
        osp$clear_job_signature_lock (pfv$p_queued_catalog_table_lock^);
        IF p_newest_queued_catalog = NIL THEN
          {
          { Unable to get queue entry or queueing not selected.
          {
          physically_detach_catalog (catalog_locator.system_file_id, catalog_locator.global_file_name,
                catalog_alarm_set, destroy_on_last_detach, {flush_catalog} TRUE, catalog_deleted, status);
          IF catalog_locator.queuing_info.access_queued THEN
            free_internal_catalog_list (catalog_locator.queuing_info.p_internal_catalog_list);
          IFEND;
        ELSEIF old_queued_catalog.valid_catalog THEN { Old catalog aged out.
          pfp$check_catalog_alarm (old_queued_catalog.global_file_name, catalog_alarm_set,
                destroy_on_last_detach);
          physically_detach_catalog (old_queued_catalog.system_file_id, old_queued_catalog.global_file_name,
                catalog_alarm_set, destroy_on_last_detach, {flush_catalog} TRUE, catalog_deleted, status);
          IF old_queued_catalog.access_queued THEN
            free_internal_catalog_list (old_queued_catalog.p_internal_catalog_list);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND detach_catalog;

?? TITLE := '  [INLINE] fetch_file_usage', EJECT ??

  PROCEDURE [INLINE] fetch_file_usage
    (    system_file_id: gft$system_file_identifier;
     VAR file_usage: dmt$usage_count);

    VAR
      file_info: dmt$segment_file_info,
      status: ost$status;

    dmp$fetch_segment_file_info (system_file_id, 0, file_info, status);
    IF status.normal THEN
      file_usage := file_info.usage_count;
    ELSE
      file_usage := 0;
      pfp$report_unexpected_status (status);
    IFEND;
  PROCEND fetch_file_usage;

?? TITLE := '  [INLINE] find_first_queued_catalog', EJECT ??

  PROCEDURE [INLINE] find_first_queued_catalog
    (VAR p_first_queued_catalog: {output} pft$p_queued_catalog);

    IF (pfv$p_p_newest_queued_catalog^ <> NIL) AND NOT pfv$p_p_newest_queued_catalog^^.valid_catalog THEN
      p_first_queued_catalog := NIL;
    ELSE
      p_first_queued_catalog := pfv$p_p_newest_queued_catalog^;
    IFEND;
  PROCEND find_first_queued_catalog;

?? TITLE := '  [INLINE] find_next_queued_catalog', EJECT ??

  PROCEDURE [INLINE] find_next_queued_catalog
    (    p_queued_catalog: {input^} pft$p_queued_catalog;
     VAR p_next_queued_catalog: {output} pft$p_queued_catalog);

    p_next_queued_catalog := p_queued_catalog^.p_next_newest;
    IF NOT p_next_queued_catalog^.valid_catalog OR (p_next_queued_catalog = pfv$p_p_newest_queued_catalog^)
          THEN
      p_next_queued_catalog := NIL;
    IFEND;
  PROCEND find_next_queued_catalog;

?? TITLE := '  [INLINE] find_queued_cat_by_external', EJECT ??

  PROCEDURE [INLINE] find_queued_cat_by_external
    (    external_catalog_name: pft$name;
         parent_catalog_internal_name: pft$internal_catalog_name;
     VAR p_queued_catalog: {output} pft$p_queued_catalog);

    find_first_queued_catalog (p_queued_catalog);
    WHILE (p_queued_catalog <> NIL) AND NOT ((p_queued_catalog^.external_catalog_name =
          external_catalog_name) AND (p_queued_catalog^.parent_catalog_internal_name =
          parent_catalog_internal_name)) DO
      find_next_queued_catalog (p_queued_catalog, p_queued_catalog);
    WHILEND;
  PROCEND find_queued_cat_by_external;

?? TITLE := '  [INLINE] find_queued_cat_by_internal', EJECT ??

  PROCEDURE [INLINE] find_queued_cat_by_internal
    (    internal_catalog_name: pft$internal_catalog_name;
     VAR p_queued_catalog: {output} pft$p_queued_catalog);

    find_first_queued_catalog (p_queued_catalog);
    WHILE (p_queued_catalog <> NIL) AND (p_queued_catalog^.internal_catalog_name <> internal_catalog_name) DO
      find_next_queued_catalog (p_queued_catalog, p_queued_catalog);
    WHILEND;
  PROCEND find_queued_cat_by_internal;

?? TITLE := '  [INLINE] free_internal_catalog_list', EJECT ??

  PROCEDURE [INLINE] free_internal_catalog_list
    (VAR p_internal_catalog: {i/o} pft$p_queued_internal_catalog);

    { p_internal_catalog is the start of a linked list of internal catalogs.

    VAR
      next_internal_catalog: pft$p_queued_internal_catalog;

    WHILE p_internal_catalog <> NIL DO
      next_internal_catalog := p_internal_catalog^.p_next_internal_catalog;
      FREE p_internal_catalog IN pfv$p_p_job_heap^^;
      p_internal_catalog := next_internal_catalog;
    WHILEND;
  PROCEND free_internal_catalog_list;

?? TITLE := '  [INLINE] free_queued_catalog', EJECT ??

  PROCEDURE [INLINE] free_queued_catalog
    (    p_queued_catalog: {i/o^} pft$p_queued_catalog);

    VAR
      p_next_newest: pft$p_queued_catalog,
      p_next_oldest: pft$p_queued_catalog;

    p_queued_catalog^.valid_catalog := FALSE;
    IF p_queued_catalog = pfv$p_p_newest_queued_catalog^ THEN
      pfv$p_p_newest_queued_catalog^ := p_queued_catalog^.p_next_newest;
    ELSE
      p_next_oldest := p_queued_catalog^.p_next_oldest;
      p_next_newest := p_queued_catalog^.p_next_newest;
      p_next_oldest^.p_next_newest := p_next_newest;
      p_next_newest^.p_next_oldest := p_next_oldest;
      p_next_newest := pfv$p_p_newest_queued_catalog^;
      p_next_oldest := p_next_newest^.p_next_oldest;
      p_queued_catalog^.p_next_oldest := p_next_oldest;
      p_queued_catalog^.p_next_newest := p_next_newest;
      p_next_oldest^.p_next_newest := p_queued_catalog;
      p_next_newest^.p_next_oldest := p_queued_catalog;
    IFEND;
  PROCEND free_queued_catalog;

?? TITLE := '  generate_dm_file_attributes', EJECT ??

  PROCEDURE generate_dm_file_attributes
    (    path: pft$complete_path;
         object_type: pft$object_types;
         validation_ring: ost$valid_ring;
         use_scl_variable_defaults: boolean;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
         authority: pft$authority;
     VAR dm_file_attributes: pft$dm_file_attributes;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      local_status: ost$status,
      ms_class_info: cmt$ms_class_info,
      p_data_value: ^clt$data_value,
      p_local_ms_request_info: ^fmt$mass_storage_request_info,
      scl_variable_default_used: boolean,
      system_file: boolean,
      user_id: ost$user_identification,
      volume_found: boolean;

    status.normal := TRUE;

    {
    { Validate mass storage request info.
    {

    p_local_ms_request_info := NIL;
    system_file := pfp$system_path (path);

    IF p_mass_storage_request_info <> NIL THEN
      PUSH p_local_ms_request_info;
      p_local_ms_request_info^ := p_mass_storage_request_info^;
      scl_variable_default_used := FALSE;
      IF use_scl_variable_defaults THEN
        IF p_local_ms_request_info^.mass_storage_class = rmc$unspecified_file_class THEN
          clp$get_variable_value ('RMV$MASS_STORAGE_CLASS', p_data_value, local_status);
          IF local_status.normal AND (p_data_value <> NIL) THEN
            IF p_data_value^.kind = clc$name THEN
              IF p_data_value^.name_value (2) = ' ' THEN
                CASE p_data_value^.name_value (1) OF
                = 'A' .. 'Z' =
                  p_local_ms_request_info^.mass_storage_class := p_data_value^.name_value (1);
                  scl_variable_default_used := TRUE;
                ELSE
                  pmp$log_ascii ('Invalid value for variable RMV$MASS_STORAGE_CLASS ignored.',
                        $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, ignore_status);
                CASEND;
              ELSE
                pmp$log_ascii ('Invalid value for variable RMV$MASS_STORAGE_CLASS ignored.',
                      $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, ignore_status);
              IFEND;
            ELSE
              pmp$log_ascii ('Invalid type for variable RMV$MASS_STORAGE_CLASS ignored.',
                    $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, ignore_status);
            IFEND;
          IFEND;
        IFEND;
        IF p_local_ms_request_info^.initial_volume = rmc$unspecified_vsn THEN
          clp$get_variable_value ('RMV$INITIAL_VOLUME', p_data_value, local_status);
          IF local_status.normal AND (p_data_value <> NIL) THEN
            IF p_data_value^.kind = clc$name THEN
              p_local_ms_request_info^.initial_volume := p_data_value^.name_value;
              scl_variable_default_used := TRUE;
              IF p_local_ms_request_info^.mass_storage_class = rmc$unspecified_file_class THEN
                IF system_file THEN
                  p_local_ms_request_info^.mass_storage_class := rmc$msc_system_permanent_files;
                ELSE
                  p_local_ms_request_info^.mass_storage_class  := rmc$msc_user_permanent_files;
                IFEND;
              IFEND;
            ELSE
              pmp$log_ascii ('Invalid type for variable RMV$INITIAL_VOLUME ignored.',
                    $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, ignore_status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
      rmp$validate_mass_storage_info (path [pfc$set_path_index], {object_permanent} TRUE, object_type,
            p_local_ms_request_info, status);
      IF NOT status.normal THEN
        IF scl_variable_default_used THEN
          p_local_ms_request_info^ := p_mass_storage_request_info^;
          rmp$validate_mass_storage_info (path [pfc$set_path_index], {object_permanent} TRUE, object_type,
                p_local_ms_request_info, local_status);
          IF local_status.normal THEN
            pmp$log_ascii ('The following error caused by an invalid value for variable ' CAT
                  'RMV$INITIAL_VOLUME or RMV$MASS_STORAGE_CLASS was ignored.',
                  $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, ignore_status);
            osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
            status.normal := TRUE;
          ELSE
            status := local_status;
            RETURN;
          IFEND;
        ELSE
          RETURN;
        IFEND;
      IFEND;
    ELSEIF use_scl_variable_defaults THEN
      clp$get_variable_value ('RMV$MASS_STORAGE_CLASS', p_data_value, local_status);
      IF local_status.normal AND (p_data_value <> NIL) THEN
        IF p_data_value^.kind = clc$name THEN
          IF p_data_value^.name_value (2) = ' ' THEN
            IF p_local_ms_request_info = NIL THEN
              PUSH p_local_ms_request_info;
              rmp$build_mass_storage_info ({allocation_size} rmc$unspecified_allocation_size,
                    {estimated_file_size} rmc$unspecified_file_size, {initial_volume} rmc$unspecified_vsn,
                    {mass_storage_class} rmc$unspecified_file_class, {shared_queue} pfc$null_shared_queue,
                    {transfer_size} rmc$unspecified_transfer_size, {volume_overflow_allowed} TRUE,
                    validation_ring, p_local_ms_request_info, local_status);
              IF NOT local_status.normal THEN
                p_local_ms_request_info := NIL;
              IFEND;
            IFEND;
            IF p_local_ms_request_info <> NIL THEN
              CASE p_data_value^.name_value (1) OF
              = 'A' .. 'Z' =
                p_local_ms_request_info^.mass_storage_class := p_data_value^.name_value (1);
                scl_variable_default_used := TRUE;
              ELSE
                pmp$log_ascii ('Invalid value for variable RMV$MASS_STORAGE_CLASS ignored.',
                      $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, ignore_status);
              CASEND;
            IFEND;
          ELSE
            pmp$log_ascii ('Invalid value for variable RMV$MASS_STORAGE_CLASS ignored.',
                  $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, ignore_status);
          IFEND;
        ELSE
          pmp$log_ascii ('Invalid type for variable RMV$MASS_STORAGE_CLASS ignored.',
                $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, ignore_status);
        IFEND;
      IFEND;
      clp$get_variable_value ('RMV$INITIAL_VOLUME', p_data_value, local_status);
      IF local_status.normal AND (p_data_value <> NIL) THEN
        IF p_data_value^.kind = clc$name THEN
          IF p_local_ms_request_info = NIL THEN
            PUSH p_local_ms_request_info;
            rmp$build_mass_storage_info ({allocation_size} rmc$unspecified_allocation_size,
                  {estimated_file_size} rmc$unspecified_file_size, {initial_volume} rmc$unspecified_vsn,
                  {mass_storage_class} rmc$unspecified_file_class, {shared_queue} pfc$null_shared_queue,
                  {transfer_size} rmc$unspecified_transfer_size, {volume_overflow_allowed} TRUE,
                  validation_ring, p_local_ms_request_info, local_status);
            IF local_status.normal THEN
              p_local_ms_request_info^.initial_volume := p_data_value^.name_value;
              IF system_file THEN
                p_local_ms_request_info^.mass_storage_class := rmc$msc_system_permanent_files;
              ELSE
                p_local_ms_request_info^.mass_storage_class  := rmc$msc_user_permanent_files;
              IFEND;
            ELSE
              p_local_ms_request_info := NIL;
            IFEND;
          ELSE
            p_local_ms_request_info^.initial_volume := p_data_value^.name_value;
          IFEND;
        ELSE
          pmp$log_ascii ('Invalid type for variable RMV$INITIAL_VOLUME ignored.',
                $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, ignore_status);
        IFEND;
      IFEND;
      IF p_local_ms_request_info <> NIL THEN
        rmp$validate_mass_storage_info (path [pfc$set_path_index], {object_permanent} TRUE, object_type,
              p_local_ms_request_info, local_status);
        IF NOT local_status.normal THEN
          pmp$log_ascii ('The following error caused by an invalid value for variable ' CAT
                'RMV$INITIAL_VOLUME or RMV$MASS_STORAGE_CLASS was ignored.',
                $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, ignore_status);
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
          p_local_ms_request_info := NIL;
        IFEND;
      IFEND;
    IFEND;

    dm_file_attributes := initial_dm_file_attributes;
    dm_file_attributes [pfc$initial_volume_index].requested_volume.setname := path [pfc$set_path_index];

    CASE object_type OF
    = pfc$file_object =
      IF system_file THEN
        dm_file_attributes [pfc$file_class_index].class := rmc$msc_system_permanent_files;
      ELSE
        dm_file_attributes [pfc$file_class_index].class := rmc$msc_user_permanent_files;
        IF pfc$master_catalog_owner IN authority.ownership THEN
          dm_file_attributes [pfc$owner_index].file_space_limit := sfc$perm_file_space_limit;
        IFEND;
      IFEND;

    = pfc$catalog_object =
      IF system_file THEN
        dm_file_attributes [pfc$file_class_index].class := rmc$msc_system_catalogs;
      ELSE
        dm_file_attributes [pfc$file_class_index].class := rmc$msc_user_catalogs;
      IFEND;
      dm_file_attributes [pfc$volume_overflow_index].overflow_allowed := FALSE;
      dm_file_attributes [pfc$allocation_size_index].requested_allocation_size := pfc$catalog_allocation_size;

    ELSE
      ;
    CASEND;

    {
    { Assign attributes from a request_mass_storage command.
    {
    IF p_local_ms_request_info <> NIL THEN
      IF p_local_ms_request_info^.mass_storage_class <> rmc$unspecified_file_class THEN
        dm_file_attributes [pfc$file_class_index].class :=
              p_local_ms_request_info^.mass_storage_class;
      ELSEIF p_local_ms_request_info^.initial_volume <> rmc$unspecified_vsn THEN
        pmp$get_user_identification (user_id, status);
        IF status.normal AND (jmp$system_job () OR (user_id.user = jmc$system_user)) THEN
          cmp$get_ms_class_on_volume (p_local_ms_request_info^.initial_volume, volume_found,
                ms_class_info);
          IF volume_found AND NOT ms_class_info[dm_file_attributes [pfc$file_class_index].class] THEN
            dm_file_attributes [pfc$file_class_index].class := rmc$unspecified_file_class;
          IFEND;
        IFEND;
      IFEND;

      dm_file_attributes [pfc$volume_overflow_index].overflow_allowed :=
            p_local_ms_request_info^.volume_overflow_allowed;
      dm_file_attributes [pfc$allocation_size_index].requested_allocation_size :=
            p_local_ms_request_info^.allocation_size;
      dm_file_attributes [pfc$initial_volume_index].requested_volume.recorded_vsn :=
            p_local_ms_request_info^.initial_volume;
      dm_file_attributes [pfc$transfer_size_index].requested_transfer_size :=
            p_local_ms_request_info^.transfer_size;
    IFEND;
  PROCEND generate_dm_file_attributes;

?? TITLE := '  [INLINE] mainframe_attachment', EJECT ??

  FUNCTION [INLINE] mainframe_attachment
    (    mainframe_id: pmt$binary_mainframe_id;
         p_catalog_file: {input^} ^pft$catalog_file;
         p_mainframe_usage_list: {input^} ^pft$mainframe_usage_list;
         cycle_entry: pft$cycle_entry) : boolean;

    VAR
      mainframe: pft$mainframe_count;

    mainframe_attachment := FALSE;

    IF (cycle_entry.first_mainframe_usage_entry.entry_type = pfc$normal_mainframe_entry) AND
          (cycle_entry.first_mainframe_usage_entry.mainframe_id = mainframe_id) AND
          (cycle_entry.first_mainframe_usage_entry.attach_count > 0) THEN
      mainframe_attachment := TRUE;
    ELSE
      IF p_mainframe_usage_list <> NIL THEN
        FOR mainframe := 1 TO UPPERBOUND (p_mainframe_usage_list^) DO
          IF (p_mainframe_usage_list^ [mainframe].mainframe_usage.entry_type = pfc$normal_mainframe_entry) AND
                (mainframe_id = p_mainframe_usage_list^ [mainframe].mainframe_usage.mainframe_id) AND
                (p_mainframe_usage_list^ [mainframe].mainframe_usage.attach_count > 0) THEN
            mainframe_attachment := TRUE;
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    IFEND;

  FUNCEND mainframe_attachment;

?? TITLE := '  physically_detach_catalog', EJECT ??

  PROCEDURE physically_detach_catalog
    (    system_file_id: gft$system_file_identifier;
         global_file_name: ost$binary_unique_name;
         catalog_alarm_set: boolean;
         destroy_on_last_detach: boolean;
         flush_catalog: boolean;
     VAR catalog_deleted: boolean;
     VAR status: ost$status);

    VAR
      catalog_usage: dmt$usage_count,
      file_info: dmt$file_information,
      file_modified: boolean,
      fmd_modified: boolean,
      keypoint_sfid: dft$keypoint_sfid,
      p_fmd: pft$p_fmd,
      stored_fmd_size: dmt$stored_fmd_size;

    {
    { Flush catalog pages only when detaching the last instance of attach.
    {
    fetch_file_usage (system_file_id, catalog_usage);
    dmp$detach_file (system_file_id, {access_allowed} TRUE, ((catalog_usage = 1) AND
          flush_catalog), file_modified, fmd_modified, file_info, status);
    IF status.normal THEN
      IF dfv$file_server_info_enabled THEN
        keypoint_sfid.file_entry_index := system_file_id.file_entry_index;
        keypoint_sfid.residence := system_file_id.residence;
        #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_sfid.keypoint_data, dfk$detach_sfid);
      IFEND;

      dmp$delete_file_descriptor (system_file_id, status);
      IF status.normal THEN
        catalog_deleted := TRUE;
      ELSE
        catalog_deleted := FALSE;
        IF status.condition = dme$file_descriptor_not_deleted THEN
          status.normal := TRUE;
        ELSE
          pfp$report_unexpected_status (status);
        IFEND;
      IFEND;
    ELSE
      catalog_deleted := FALSE;
      pfp$report_unexpected_status (status);
    IFEND;

    IF catalog_alarm_set AND catalog_deleted AND (catalog_usage = 1) THEN
      pfp$clear_catalog_alarm (global_file_name);
      IF destroy_on_last_detach THEN
        dmp$get_stored_fmd_size (system_file_id, stored_fmd_size, status);
        IF status.normal THEN
          PUSH p_fmd: [[REP stored_fmd_size OF cell]];
          RESET p_fmd;
          dmp$get_stored_fmd (system_file_id, p_fmd^, status);
          IF status.normal THEN
            dmp$destroy_permanent_file (global_file_name, p_fmd^, status);
          IFEND;
        IFEND;
        pfp$process_unexpected_status (status);
      IFEND;
    IFEND;

  PROCEND physically_detach_catalog;

?? TITLE := '  store_valid_file_class_in_fmd', EJECT ??

  PROCEDURE store_valid_file_class_in_fmd
    (    path: pft$complete_path;
         object_type: pft$object_types;
         system_file_id: gft$system_file_identifier;
     VAR status: ost$status);

    VAR
      system_file: boolean,
      valid_file_class: dmt$class_member;

    status.normal := TRUE;

    system_file := pfp$system_path (path);

    CASE object_type OF
    = pfc$file_object =
      IF system_file THEN
        valid_file_class := rmc$msc_system_permanent_files;
      ELSE
        valid_file_class := rmc$msc_user_permanent_files;
      IFEND;

    = pfc$catalog_object =
      IF system_file THEN
        valid_file_class := rmc$msc_system_catalogs;
      ELSE
        valid_file_class := rmc$msc_user_catalogs;
      IFEND;
    ELSE
      ;
    CASEND;

    dmp$store_valid_class_in_fmd (system_file_id, valid_file_class, status);

  PROCEND store_valid_file_class_in_fmd;

?? TITLE := '  [INLINE] rotate_catalog_queue', EJECT ??

  PROCEDURE [INLINE] rotate_catalog_queue
    (VAR p_newest_queued_catalog: {output} pft$p_queued_catalog);

    IF pfv$p_p_newest_queued_catalog^ = NIL THEN
      create_queued_catalog_table;
    ELSE
      pfv$p_p_newest_queued_catalog^ := pfv$p_p_newest_queued_catalog^^.p_next_oldest;
    IFEND;

    p_newest_queued_catalog := pfv$p_p_newest_queued_catalog^;
  PROCEND rotate_catalog_queue;

?? TITLE := '  set_server_output', EJECT ??

  PROCEDURE set_server_output
    (    cycle_created: boolean;
         application_info: pft$application_info;
         cycle_number: pft$cycle_number;
         allow_other_mainframe_writer: boolean;
         internal_cycle_name: pft$internal_name;
         usage_intentions: pft$usage_selections;
         share_selections: pft$share_selections;
         password_protected: boolean;
         attached_pf_table_index: pft$attached_pf_table_index;
         system_file_id: gft$system_file_identifier;
         p_file_label: {input} fmt$p_file_label;
         p_fmd: {input} pft$p_fmd,
         device_class: rmt$device_class;
     VAR bytes_allocated: amt$file_byte_address;
     VAR p_file_server_buffers: {i^/o^} pft$p_file_server_buffers;
     VAR status: ost$status);

    VAR
      p_server_file_output: ^pft$server_file_output,
      p_nexted_fmd: pft$p_fmd,
      p_nexted_label: fmt$p_file_label;

    NEXT p_server_file_output IN p_file_server_buffers^.p_send_parameters;
    p_server_file_output^.allow_other_mainframe_writer := allow_other_mainframe_writer;
    p_server_file_output^.application_info := application_info;
    p_server_file_output^.attached_pf_table_index := attached_pf_table_index;
    p_server_file_output^.cycle_created := cycle_created;
    p_server_file_output^.cycle_number := cycle_number;
    p_server_file_output^.global_file_name := internal_cycle_name;
    p_server_file_output^.password_protected := password_protected;
    p_server_file_output^.share_selections := share_selections;
    p_server_file_output^.usage_selections := usage_intentions;

    bytes_allocated := 0;
    IF device_class = rmc$mass_storage_device THEN
      dmp$fetch_server_sft_info (system_file_id, p_server_file_output^.dm_parameters,
            p_file_server_buffers, status);
      IF status.normal THEN
        bytes_allocated := p_server_file_output^.dm_parameters.total_allocated_length;
      ELSE
        status.normal := TRUE;
      IFEND;
    IFEND;

    IF p_file_label = NIL THEN
      p_server_file_output^.label_length := 0;
    ELSE
      p_server_file_output^.label_length := #SIZE (p_file_label^);
      IF p_fmd = NIL THEN
        NEXT p_nexted_label: [[REP p_server_file_output^.label_length OF cell]] IN
              p_file_server_buffers^.p_send_parameters;
        IF p_nexted_label = NIL THEN
          NEXT p_nexted_label: [[REP p_server_file_output^.label_length OF cell]] IN
                p_file_server_buffers^.p_send_data;
        IFEND;
      ELSE
        NEXT p_nexted_label: [[REP p_server_file_output^.label_length OF cell]] IN
              p_file_server_buffers^.p_send_data;
      IFEND;
      IF p_nexted_label = NIL THEN
        osp$system_error (' File server data area overflow in SET_SERVER_OUTPUT.', NIL);
      IFEND;
      p_nexted_label^ := p_file_label^;
    IFEND;

    IF p_fmd = NIL THEN
      p_server_file_output^.rem_media_fmd_length := 0;
    ELSE
      p_server_file_output^.rem_media_fmd_length := #SIZE (p_fmd^);
      NEXT p_nexted_fmd: [[REP p_server_file_output^.rem_media_fmd_length OF cell]] IN
            p_file_server_buffers^.p_send_data;
      IF p_nexted_fmd = NIL THEN
        osp$system_error (' File server data area overflow in SET_SERVER_OUTPUT.', NIL);
      IFEND;
      p_nexted_fmd^ := p_fmd^;
    IFEND;

  PROCEND set_server_output;

?? TITLE := '  volume_available_for_assign', EJECT ??
{ PURPOSE:
{   The purpose of this function is to determine whether or not there is
{   a volume to which a file or catalog can be assigned.  It is called
{   only when a DME$UNABLE_TO_ALLOC_ALL_SPACE condition is returned
{   by DMP$CREATE_FILE_ENTRY since in some situations, a
{   DME$UNABLE_TO_ALLOC_ALL_SPACE is returned when a volume can be
{   assigned to the file or catalog.

  FUNCTION volume_available_for_assign
    (    set_name: stt$set_name;
         mass_storage_class: dmt$class_member;
         initial_volume: rmt$recorded_vsn): boolean;

    VAR
      avt_index: ost$positive_integers;                                      ;

    volume_available_for_assign := FALSE;

  /search_avt_for_volume/
    FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^) TO
          UPPERBOUND (dmv$p_active_volume_table^) DO
      IF (NOT dmv$p_active_volume_table^ [avt_index].entry_available) AND
            (set_name = dmv$p_active_volume_table^ [avt_index].mass_storage.set_name) AND
            (mass_storage_class IN dmv$p_active_volume_table^ [avt_index].mass_storage.class) AND
            (NOT dmv$p_active_volume_table^ [avt_index].mass_storage.volume_unavailable) AND
            (NOT dmv$p_active_volume_table^ [avt_index].mass_storage.space_gone) AND
            ((initial_volume = rmc$unspecified_vsn) OR
            ((initial_volume <> rmc$unspecified_vsn) AND
            (initial_volume = dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn))) THEN
        volume_available_for_assign := TRUE;
        RETURN;
      IFEND;
    FOREND /search_avt_for_volume/;

  FUNCEND volume_available_for_assign;


?? SKIP := 2 ??
MODEND pfm$file_system_interfaces;
*DECK DECK=PFM$FIND_INFORMATION EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Permanent Files : Find Information', EJECT ??
MODULE pfm$find_information;

{ PURPOSE:
{   This module contains the procedures to parse the information returned by
{   the permanent file 'get info' routines.
{
{ NOTE:
{   Because these requests run in the user's ring, the pointer provided is not
{   validated.  If the pointer is bad, a condition will occur in the user's
{   ring.

?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pfk$keypoints
*copyc pft$catalog_media_description
*copyc pft$file_media_description
?? POP ??
?? EJECT ??
*copyc clp$validate_name
*copyc i#current_sequence_position
*copyc osp$append_status_integer
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$verify_system_privilege
*copyc pfp$convert_archive_ident

?? TITLE := '  [XDCL, #GATE] pfp$find_archive_info', EJECT ??
*copy pfh$find_archive_info

  PROCEDURE [XDCL, #GATE] pfp$find_archive_info (
        p_cycle_info_record: pft$p_info_record;
    VAR p_archive_info_record: pft$p_info_record;
    VAR status: ost$status);

    VAR
      local_status: ost$status;

    #KEYPOINT (osk$entry, 0, pfk$find_archive_info);

    status.normal := TRUE;

    find_record (p_cycle_info_record, pfc$archive_info_record, p_archive_info_record, local_status);
    IF (NOT local_status.normal) AND (local_status.condition = pfe$unknown_info_record) THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_archive_info, '', local_status);
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, pfk$find_archive_info);

  PROCEND pfp$find_archive_info;

?? TITLE := '  [XDCL, #GATE] pfp$find_catalog_description', EJECT ??
*copy pfh$find_catalog_description

  PROCEDURE [XDCL, #GATE] pfp$find_catalog_description
    (    p_catalog_group_record: pft$p_info_record;
     VAR p_catalog_description: pft$p_catalog_description;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      p_catalog_desc_record_body: pft$p_info;

    #KEYPOINT (osk$entry, 0, pfk$find_catalog_description);
    local_status.normal := TRUE;

    find_record_body (p_catalog_group_record, pfc$catalog_description_record, p_catalog_desc_record_body,
          local_status);
    IF local_status.normal THEN
      NEXT p_catalog_description IN p_catalog_desc_record_body;
      IF p_catalog_description = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_info_record_format, '', local_status);
      IFEND;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
      #KEYPOINT (osk$exit, 0, pfk$find_catalog_description);
    ELSE
      status := local_status;
      #KEYPOINT (osk$exit, 0, pfk$find_catalog_description);
    IFEND;
  PROCEND pfp$find_catalog_description;

?? TITLE := '  [XDCL, #GATE] pfp$find_catalog_media', EJECT ??
*copy pfh$find_catalog_media

  PROCEDURE [XDCL, #GATE] pfp$find_catalog_media
    (    p_catalog_group_info_record: pft$p_info_record;
     VAR p_catalog_media_description: pft$p_catalog_media_description;
     VAR p_catalog_fmd: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      fmd_size: pft$info_record_body_size,
      local_status: ost$status,
      p_catalog_media_record_body: pft$p_info;

    #KEYPOINT (osk$entry, 0, pfk$find_media);
    local_status.normal := TRUE;

    find_record_body (p_catalog_group_info_record, pfc$catalog_media_record, p_catalog_media_record_body,
          local_status);
    IF local_status.normal THEN
      NEXT p_catalog_media_description IN p_catalog_media_record_body;
      IF (p_catalog_media_description = NIL) THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_info_record_format,
              'Catalog media description', local_status);
      ELSEIF p_catalog_media_description^.catalog_type = pfc$external_catalog THEN
        fmd_size := #SIZE (p_catalog_media_record_body^) - i#current_sequence_position (
              p_catalog_media_record_body);
        NEXT p_catalog_fmd: [[REP fmd_size OF cell]] IN p_catalog_media_record_body;
        IF p_catalog_fmd = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_info_record_format,
                'Catalog media ', local_status);
        IFEND;

      ELSE { internal catalog
        p_catalog_fmd := NIL;
      IFEND;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_catalog_media, '', local_status);
    IFEND;

    #KEYPOINT (osk$exit, 0, pfk$find_media);
    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
  PROCEND pfp$find_catalog_media;

?? TITLE := '  [XDCL, #GATE] pfp$find_cycle_array', EJECT ??
*copy pfh$find_cycle_array

  PROCEDURE [XDCL, #GATE] pfp$find_cycle_array
    (    p_file_group_info_record: pft$p_info_record;
     VAR p_cycle_array: pft$p_cycle_array;
     VAR status: ost$status);

    VAR
      body_size: pft$info_record_body_size,
      entry_size: pft$info_record_body_size,
      local_status: ost$status,
      p_cycle_array_record_body: pft$p_info;

    #KEYPOINT (osk$entry, 0, pfk$find_cycle_array);
    local_status.normal := TRUE;

    find_record_body (p_file_group_info_record, pfc$cycle_array_record, p_cycle_array_record_body,
          local_status);
    IF local_status.normal THEN
      body_size := #SIZE (p_cycle_array_record_body^);
      entry_size := #SIZE (pft$cycle_array_entry);
      IF body_size > 1 THEN
        IF body_size MOD entry_size = 0 THEN
          NEXT p_cycle_array: [1 .. (body_size DIV entry_size)] IN p_cycle_array_record_body;
        ELSE
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_info_record_format, '',
                local_status);
        IFEND;
      ELSE
        p_cycle_array := NIL;
      IFEND;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
      #KEYPOINT (osk$exit, 0, pfk$find_cycle_array);
    ELSE
      status := local_status;
      #KEYPOINT (osk$exit, 0, pfk$find_cycle_array);
    IFEND;
  PROCEND pfp$find_cycle_array;

?? TITLE := '  [XDCL, #GATE] pfp$find_cycle_array_extended', EJECT ??
*copy pfh$find_cycle_array_extended

  PROCEDURE [XDCL, #GATE] pfp$find_cycle_array_extended
    (    p_file_group_info_record: pft$p_info_record;
     VAR p_cycle_array_extended_record: pft$p_info_record;
     VAR status: ost$status);

    VAR
      local_status: ost$status;

    #KEYPOINT (osk$entry, 0, pfk$find_cycle_array);
    local_status.normal := TRUE;

    find_record (p_file_group_info_record, pfc$cycle_array_extended_record, p_cycle_array_extended_record,
          local_status);
    IF NOT local_status.normal THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_cycle_array, '', local_status);
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
      #KEYPOINT (osk$exit, 0, pfk$find_cycle_array);
    ELSE
      status := local_status;
      #KEYPOINT (osk$exit, 0, pfk$find_cycle_array);
    IFEND;
  PROCEND pfp$find_cycle_array_extended;

?? TITLE := '  [XDCL, #GATE] pfp$find_cycle_array_version_2', EJECT ??
*copy pfh$find_cycle_array_version_2

  PROCEDURE [XDCL, #GATE] pfp$find_cycle_array_version_2
    (    p_file_group_info_record: pft$p_info_record;
     VAR p_cycle_array: ^pft$cycle_array_version_2;
     VAR status: ost$status);

    VAR
      body_size: pft$info_record_body_size,
      entry_size: pft$info_record_body_size,
      local_status: ost$status,
      p_cycle_array_record_body: pft$p_info;

    #KEYPOINT (osk$entry, 0, pfk$find_cycle_array_version_2);
    status.normal := TRUE;

    find_record_body (p_file_group_info_record, pfc$cycle_array_version_2_rec, p_cycle_array_record_body,
          local_status);
    IF local_status.normal THEN
      body_size := #SIZE (p_cycle_array_record_body^);
      entry_size := #SIZE (pft$cycle_array_entry_version_2);
      IF body_size > 1 THEN
        IF body_size MOD entry_size = 0 THEN
          NEXT p_cycle_array: [1 .. (body_size DIV entry_size)] IN p_cycle_array_record_body;
        ELSE
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_info_record_format, '',
                local_status);
        IFEND;
      ELSE
        p_cycle_array := NIL;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$find_cycle_array_version_2);

  PROCEND pfp$find_cycle_array_version_2;

?? TITLE := '  [XDCL, #GATE] pfp$find_cycle_directory', EJECT ??
*copy pfh$find_cycle_directory

  PROCEDURE [XDCL, #GATE] pfp$find_cycle_directory
    (    p_cycle_array_extended_record: pft$p_info_record;
     VAR p_cycle_directory_array: pft$p_cycle_directory_array;
     VAR status: ost$status);

    VAR
      body_size: pft$info_record_body_size,
      entry_size: pft$info_record_body_size,
      local_status: ost$status,
      p_cycle_directory_record_body: pft$p_info;

    #KEYPOINT (osk$entry, 0, pfk$find_directory_array);
    local_status.normal := TRUE;

    find_record_body (p_cycle_array_extended_record, pfc$cycle_directory_record,
          p_cycle_directory_record_body, local_status);
    IF local_status.normal THEN
      body_size := #SIZE (p_cycle_directory_record_body^);
      entry_size := #SIZE (pft$cycle_directory_array_entry);
      IF body_size > 1 THEN
        IF body_size MOD entry_size = 0 THEN
          NEXT p_cycle_directory_array: [1 .. (body_size DIV entry_size)] IN p_cycle_directory_record_body;
        ELSE
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_info_record_format, '',
                local_status);
        IFEND;
      ELSE
        p_cycle_directory_array := NIL;
      IFEND;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
      #KEYPOINT (osk$exit, 0, pfk$find_directory_array);
    ELSE
      status := local_status;
      #KEYPOINT (osk$exit, 0, pfk$find_directory_array);
    IFEND;
  PROCEND pfp$find_cycle_directory;

?? TITLE := '  [XDCL, #GATE] pfp$find_cycle_entry', EJECT ??
*copy pfh$find_cycle_entry

  PROCEDURE [XDCL, #GATE] pfp$find_cycle_entry
    (    p_cycle_array: pft$p_cycle_array;
         cycle_selector: pft$cycle_selector;
     VAR cycle_index: pft$array_index;
     VAR status: ost$status);

    VAR
      local_status: ost$status;

    #KEYPOINT (osk$entry, 0, pfk$find_cycle_entry);
    local_status.normal := TRUE;

    check_cycle_selector (cycle_selector, local_status);
    IF local_status.normal THEN
      CASE cycle_selector.cycle_option OF
      = pfc$lowest_cycle =
        find_lowest_cycle (p_cycle_array, cycle_index);
      = pfc$highest_cycle =
        find_highest_cycle (p_cycle_array, cycle_index);
      = pfc$specific_cycle =
        find_specific_cycle (p_cycle_array, cycle_selector.cycle_number, cycle_index, local_status);
      ELSE
      CASEND;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
      #KEYPOINT (osk$exit, 0, pfk$find_cycle_entry);
    ELSE
      status := local_status;
      #KEYPOINT (osk$exit, 0, pfk$find_cycle_entry);
    IFEND;
  PROCEND pfp$find_cycle_entry;

?? TITLE := '  [XDCL, #GATE] pfp$find_cycle_entry_version_2', EJECT ??
*copy pfh$find_cycle_entry_version_2

  PROCEDURE [XDCL, #GATE] pfp$find_cycle_entry_version_2
    (    p_cycle_array: ^pft$cycle_array_version_2;
         cycle_selector: pft$cycle_selector;
     VAR cycle_index: pft$array_index;
     VAR status: ost$status);

    VAR
      local_status: ost$status;

    #KEYPOINT (osk$entry, 0, pfk$find_cycle_entry_version_2);
    status.normal := TRUE;

    check_cycle_selector (cycle_selector, local_status);
    IF local_status.normal THEN
      CASE cycle_selector.cycle_option OF
      = pfc$lowest_cycle =
        find_lowest_cycle_version_2 (p_cycle_array, cycle_index);
      = pfc$highest_cycle =
        find_highest_cycle_version_2 (p_cycle_array, cycle_index);
      = pfc$specific_cycle =
        find_specific_cycle_version_2 (p_cycle_array, cycle_selector.cycle_number, cycle_index, local_status);
      ELSE
      CASEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$find_cycle_entry_version_2);

  PROCEND pfp$find_cycle_entry_version_2;

?? TITLE := '  [XDCL, #GATE] pfp$find_cycle_label', EJECT ??
*copy pfh$find_cycle_label

  PROCEDURE [XDCL, #GATE] pfp$find_cycle_label
    (    p_cycle_info_record: pft$p_info_record;
     VAR p_cycle_label: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      local_status: ost$status;

    #KEYPOINT (osk$entry, 0, pfk$find_cycle_label);
    local_status.normal := TRUE;

    find_record_body (p_cycle_info_record, pfc$cycle_label_record, p_cycle_label, local_status);
    IF NOT local_status.normal THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_cycle_label, '', local_status);
    IFEND;

    #KEYPOINT (osk$exit, 0, pfk$find_cycle_label);
    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
  PROCEND pfp$find_cycle_label;

?? TITLE := '  [XDCL, #GATE] pfp$find_cycle_media', EJECT ??
*copy pfh$find_cycle_media

  PROCEDURE [XDCL, #GATE] pfp$find_cycle_media
    (    p_cycle_info_record: pft$p_info_record;
     VAR p_cycle_media_description: pft$p_file_media_description;
     VAR status: ost$status);

    VAR
      fmd_size: pft$info_record_body_size,
      local_status: ost$status,
      p_cycle_media_record_body: pft$p_info;

    #KEYPOINT (osk$entry, 0, pfk$find_media);
    local_status.normal := TRUE;

    find_record_body (p_cycle_info_record, pfc$cycle_media_record, p_cycle_media_record_body, local_status);
    IF local_status.normal THEN
      NEXT p_cycle_media_description: [[REP 1 OF cell]] IN p_cycle_media_record_body;
      IF (p_cycle_media_description = NIL) THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_info_record_format,
              'Cycle media description', local_status);
      ELSE
        fmd_size := #SIZE (p_cycle_media_record_body^) - i#current_sequence_position (
              p_cycle_media_record_body) + 1;
        RESET p_cycle_media_record_body;
        NEXT p_cycle_media_description: [[REP fmd_size OF cell]] IN p_cycle_media_record_body;
        IF p_cycle_media_description = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_info_record_format, 'Cycle media ',
                local_status);
        IFEND;
      IFEND;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_cycle_media, '', local_status);
    IFEND;

    #KEYPOINT (osk$exit, 0, pfk$find_media);
    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
  PROCEND pfp$find_cycle_media;

?? TITLE := '  [XDCL, #GATE, INLINE] pfp$find_direct_info_record', EJECT ??
*copy pfh$find_direct_info_record

  PROCEDURE [XDCL, #GATE, INLINE] pfp$find_direct_info_record
    (    p_info: pft$p_info;
         info_offset: pft$info_offset;
     VAR p_info_record: pft$p_info_record;
     VAR status: ost$status);

    VAR
      info_size: pft$info_record_body_size,
      local_p_info: pft$p_info,
      local_status: ost$status,
      p_skipped_info: pft$p_info;

    #KEYPOINT (osk$entry, 0, pfk$find_direct_info_record);
    local_status.normal := TRUE;

    local_p_info := p_info;
    RESET local_p_info;
    info_size := #SIZE (local_p_info^);
    IF (info_offset < 0) OR (info_offset > info_size) THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_offset_range_error, '', local_status);
      osp$append_status_integer (osc$status_parameter_delimiter, info_offset, 10, FALSE, local_status);
      osp$append_status_integer (osc$status_parameter_delimiter, 0, 10, FALSE, local_status);
      osp$append_status_integer (osc$status_parameter_delimiter, info_size, 10, FALSE, local_status);
    ELSE
      IF info_offset <> 0 THEN
        NEXT p_skipped_info: [[REP info_offset OF cell]] IN local_p_info;
      IFEND;
      pfp$find_next_info_record (local_p_info, p_info_record, local_status);
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
      #KEYPOINT (osk$exit, 0, pfk$find_direct_info_record);
    ELSE
      status := local_status;
      #KEYPOINT (osk$exit, 0, pfk$find_direct_info_record);
    IFEND;
  PROCEND pfp$find_direct_info_record;

?? TITLE := '  [XDCL, #GATE] pfp$find_directory_array', EJECT ??
*copy pfh$find_directory_array

  PROCEDURE [XDCL, #GATE] pfp$find_directory_array
    (    p_info_record: pft$p_info_record;
     VAR p_directory_array: pft$p_directory_array;
     VAR status: ost$status);

    VAR
      body_size: pft$info_record_body_size,
      entry_size: pft$info_record_body_size,
      local_status: ost$status,
      p_directory_record_body: pft$p_info;

    #KEYPOINT (osk$entry, 0, pfk$find_directory_array);
    local_status.normal := TRUE;

    find_record_body (p_info_record, pfc$directory_array_record, p_directory_record_body, local_status);
    IF local_status.normal THEN
      body_size := #SIZE (p_directory_record_body^);
      entry_size := #SIZE (pft$directory_array_entry);
      IF body_size > 1 THEN
        IF body_size MOD entry_size = 0 THEN
          NEXT p_directory_array: [1 .. (body_size DIV entry_size)] IN p_directory_record_body;
        ELSE
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_info_record_format, '',
                local_status);
        IFEND;
      ELSE
        p_directory_array := NIL;
      IFEND;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
      #KEYPOINT (osk$exit, 0, pfk$find_directory_array);
    ELSE
      status := local_status;
      #KEYPOINT (osk$exit, 0, pfk$find_directory_array);
    IFEND;
  PROCEND pfp$find_directory_array;

?? TITLE := '  [XDCL, #GATE] pfp$find_file_description', EJECT ??
*copy pfh$find_file_description

  PROCEDURE [XDCL, #GATE] pfp$find_file_description
    (    p_file_group_info_record: pft$p_info_record;
     VAR p_file_description: pft$p_file_description;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      p_file_description_record_body: pft$p_info;

    #KEYPOINT (osk$entry, 0, pfk$find_file_description);
    local_status.normal := TRUE;

    find_record_body (p_file_group_info_record, pfc$file_description_record, p_file_description_record_body,
          local_status);
    IF local_status.normal THEN
      NEXT p_file_description IN p_file_description_record_body;
      IF (p_file_description = NIL) THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_info_record_format, '', local_status);
      IFEND;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
      #KEYPOINT (osk$exit, 0, pfk$find_file_description);
    ELSE
      status := local_status;
      #KEYPOINT (osk$exit, 0, pfk$find_file_description);
    IFEND;
  PROCEND pfp$find_file_description;

?? TITLE := '  [XDCL, #GATE] pfp$find_log_array', EJECT ??
*copy pfh$find_log_array

  PROCEDURE [XDCL, #GATE] pfp$find_log_array
    (    p_file_group_info_record: pft$p_info_record;
     VAR p_log_array: pft$p_log_array;
     VAR status: ost$status);

    VAR
      body_size: pft$info_record_body_size,
      entry_size: pft$info_record_body_size,
      local_status: ost$status,
      p_log_array_record_body: pft$p_info;

    #KEYPOINT (osk$entry, 0, pfk$find_log_array);
    local_status.normal := TRUE;

    find_record_body (p_file_group_info_record, pfc$log_array_record, p_log_array_record_body, local_status);
    IF local_status.normal THEN
      body_size := #SIZE (p_log_array_record_body^);
      entry_size := #SIZE (pft$log_array_entry);
      IF body_size > 1 THEN
        IF body_size MOD entry_size = 0 THEN
          NEXT p_log_array: [1 .. (body_size DIV entry_size)] IN p_log_array_record_body;
        ELSE
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_info_record_format, '',
                local_status);
        IFEND;
      ELSE
        p_log_array := NIL;
      IFEND;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
      #KEYPOINT (osk$exit, 0, pfk$find_log_array);
    ELSE
      status := local_status;
      #KEYPOINT (osk$exit, 0, pfk$find_log_array);
    IFEND;
  PROCEND pfp$find_log_array;

?? TITLE := '  [XDCL, #GATE] pfp$find_next_archive_entry', EJECT ??
*copy pfh$find_next_archive_entry

  PROCEDURE [XDCL, #GATE] pfp$find_next_archive_entry (
        archive_identification: pft$archive_identification;
    VAR p_info: pft$p_info;
    VAR p_info_record: pft$p_info_record;
    VAR p_archive_array_entry: pft$p_archive_array_entry;
    VAR p_amd: pft$p_amd;
    VAR status: ost$status);

    VAR
      found: boolean,
      local_status: ost$status,
      local_archive_identification: pft$archive_identification;

    #KEYPOINT (osk$exit, 0, pfk$find_next_archive_entry);

    status.normal := TRUE;
    found := false;
    local_archive_identification := archive_identification;

    pfp$convert_archive_ident (archive_identification, local_archive_identification, local_status);

    IF local_status.normal THEN

    /find_matching_archive_entry/
      REPEAT
        pfp$find_next_info_record (p_info, p_info_record, local_status);
        IF local_status.normal THEN
          find_archive_entry (p_info_record, p_archive_array_entry, p_amd, local_status);
          IF p_archive_array_entry = NIL THEN
            EXIT /find_matching_archive_entry/;
          IFEND;
          IF local_archive_identification.application_identifier = osc$null_name THEN
            found := TRUE;
            EXIT /find_matching_archive_entry/;
          IFEND;
          IF p_archive_array_entry^.archive_identification.application_identifier =
              local_archive_identification.application_identifier THEN
            IF local_archive_identification.media_identifier.media_device_class = osc$null_name THEN
              found := TRUE;
              EXIT /find_matching_archive_entry/;
            IFEND;
            IF p_archive_array_entry^.archive_identification.media_identifier.media_device_class =
                local_archive_identification.media_identifier.media_device_class THEN
              IF local_archive_identification.media_identifier.media_volume_identifier = '' THEN
                found := TRUE;
                EXIT /find_matching_archive_entry/;
              IFEND;
              IF p_archive_array_entry^.archive_identification.media_identifier.media_volume_identifier =
                  local_archive_identification.media_identifier.media_volume_identifier THEN
                found := TRUE;
                EXIT /find_matching_archive_entry/;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      UNTIL NOT local_status.normal;

      IF local_status.normal AND (NOT found) THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_archive_application,
            archive_identification.application_identifier, local_status);
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, pfk$find_next_archive_entry);

  PROCEND pfp$find_next_archive_entry;

?? TITLE := '  [XDCL, #GATE, INLINE] pfp$find_next_info_record', EJECT ??
*copy pfh$find_next_info_record

  PROCEDURE [XDCL, #GATE, INLINE] pfp$find_next_info_record
    (VAR p_info: pft$p_info;
     VAR p_info_record: pft$p_info_record;
     VAR status: ost$status);

    VAR
      local_p_info: pft$p_info,
      local_status: ost$status,
      p_cell: ^cell;

    #KEYPOINT (osk$entry, 0, pfk$find_next_info_record);
    local_status.normal := TRUE;

    local_p_info := p_info;
    NEXT p_info_record: [[REP 1 OF cell]] IN local_p_info;
    IF p_info_record <> NIL THEN
      IF (p_info_record^.record_type < LOWERVALUE (pft$info_record_type)) OR
            (p_info_record^.record_type > UPPERVALUE (pft$info_record_type)) OR
            (p_info_record^.body_size < LOWERVALUE (pft$info_record_body_size)) OR
            (p_info_record^.body_size > UPPERVALUE (pft$info_record_body_size)) THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_info_record_format, '', local_status);
      ELSE
        NEXT p_info_record: [[REP p_info_record^.body_size OF cell]] IN p_info;
        IF p_info_record = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_info_record_format, '',
                local_status);
        IFEND;
      IFEND;
    ELSE
      NEXT p_cell IN local_p_info;
      IF (p_cell = NIL) OR (#SIZE (local_p_info^) = 1) THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_info_record, '', local_status);
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_info_record_format, '', local_status);
      IFEND;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
      #KEYPOINT (osk$exit, 0, pfk$find_next_info_record);
    ELSE
      status := local_status;
      #KEYPOINT (osk$exit, 0, pfk$find_next_info_record);
    IFEND;
  PROCEND pfp$find_next_info_record;

?? TITLE := '  [XDCL, #GATE] pfp$find_permit_array', EJECT ??
*copy pfh$find_permit_array

  PROCEDURE [XDCL, #GATE] pfp$find_permit_array
    (    p_info_record: pft$p_info_record;
     VAR p_permit_array: pft$p_permit_array;
     VAR status: ost$status);

    VAR
      body_size: pft$info_record_body_size,
      entry_size: pft$info_record_body_size,
      local_status: ost$status,
      p_permit_array_record_body: pft$p_info;

    #KEYPOINT (osk$entry, 0, pfk$find_permit_array);
    local_status.normal := TRUE;

    find_record_body (p_info_record, pfc$permit_array_record, p_permit_array_record_body, local_status);
    IF local_status.normal THEN
      body_size := #SIZE (p_permit_array_record_body^);
      entry_size := #SIZE (pft$permit_array_entry);
      IF body_size > 1 THEN
        IF body_size MOD entry_size = 0 THEN
          NEXT p_permit_array: [1 .. (body_size DIV entry_size)] IN p_permit_array_record_body;
        ELSE
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_info_record_format, '',
                local_status);
        IFEND;
      ELSE
        p_permit_array := NIL;
      IFEND;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
      #KEYPOINT (osk$exit, 0, pfk$find_permit_array);
    ELSE
      status := local_status;
      #KEYPOINT (osk$exit, 0, pfk$find_permit_array);
    IFEND;
  PROCEND pfp$find_permit_array;

?? TITLE := '  [XDCL] pfp$locate_group_info_record', EJECT ??

  PROCEDURE [XDCL] pfp$locate_group_info_record
    (    p_info_record: {input^} ^pft$info_record;
     VAR p_group_info_record: ^pft$info_record;
     VAR status: ost$status);

    VAR
      group_info_record_found: boolean,
      info_record_type: pft$info_record_type,
      p_info: ^pft$info;

    osp$verify_system_privilege;
    p_group_info_record := p_info_record;

    CASE p_group_info_record^.record_type OF
    = pfc$item_info_record =
      p_info := ^p_group_info_record^.body;
      RESET p_info;
      REPEAT
        pfp$find_next_info_record (p_info, p_group_info_record, status);
        IF status.normal THEN
          info_record_type := p_group_info_record^.record_type;
          group_info_record_found := (info_record_type = pfc$file_group_record) OR
                (info_record_type = pfc$catalog_group_record);
        IFEND;
      UNTIL NOT status.normal OR group_info_record_found;

    = pfc$catalog_group_record, pfc$file_group_record =
      status.normal := TRUE;

    ELSE
      osp$set_status_condition (pfe$bad_info_record_format, status);
    CASEND;
  PROCEND pfp$locate_group_info_record;

?? TITLE := '  check_cycle_selector', EJECT ??

  PROCEDURE check_cycle_selector
    (    cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

    CASE cycle_selector.cycle_option OF
    = pfc$lowest_cycle, pfc$highest_cycle =
      status.normal := TRUE;

    = pfc$specific_cycle =
      IF (cycle_selector.cycle_number >= pfc$minimum_cycle_number) AND
            (cycle_selector.cycle_number <= pfc$maximum_cycle_number) THEN
        status.normal := TRUE;
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_cycle_number, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, cycle_selector.cycle_number, 10, FALSE,
              status);
      IFEND;

    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_cycle_option, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (cycle_selector.cycle_option), 10,
            FALSE, status);
    CASEND;
  PROCEND check_cycle_selector;

?? TITLE := '  find_archive_entry', EJECT ??

  PROCEDURE find_archive_entry (
        p_info_record: pft$p_info_record;
    VAR p_archive_array_entry: pft$p_archive_array_entry;
    VAR p_amd: pft$p_amd;
    VAR status: ost$status);

    VAR
      body_size: pft$info_record_body_size,
      entry_size: pft$info_record_body_size,
      local_status: ost$status,
      p_record_body: pft$p_info;

    status.normal := TRUE;
    p_archive_array_entry :=NIL;

    find_record_body (p_info_record, pfc$archive_array_entry_record, p_record_body, local_status);
    IF local_status.normal THEN
      body_size := #SIZE (p_record_body^);
      entry_size := #SIZE (pft$archive_array_entry);
      IF body_size > 1 THEN
        IF body_size = entry_size THEN
          NEXT p_archive_array_entry IN p_record_body;
        ELSE
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_info_record_format,
              'ARCHIVE_ENTRY', local_status);
        IFEND;
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_archive_entry, '', local_status);
      IFEND;
    IFEND;

    p_amd := NIL;

    IF local_status.normal THEN
      find_record_body (p_info_record, pfc$archive_amd_record, p_record_body, local_status);
      IF local_status.normal THEN
        body_size := #SIZE (p_record_body^);
        IF body_size > 1 THEN
          NEXT p_amd: [[REP body_size OF cell]] IN p_record_body;
          IF p_amd = NIL THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_info_record_format, '',
                local_status);
          IFEND;
        ELSE
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_archive_media_desc, '',
              local_status);
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND find_archive_entry;

?? TITLE := '  find_highest_cycle', EJECT ??

  PROCEDURE find_highest_cycle
    (    p_cycle_array: pft$p_cycle_array;
     VAR highest_cycle_index: pft$array_index);

    VAR
      cycle_index: pft$array_index,
      highest_cycle_number: pft$cycle_number;

    highest_cycle_number := pfc$minimum_cycle_number;

    FOR cycle_index := 1 TO UPPERBOUND (p_cycle_array^) DO
      IF p_cycle_array^ [cycle_index].cycle_number >= highest_cycle_number THEN
        highest_cycle_number := p_cycle_array^ [cycle_index].cycle_number;
        highest_cycle_index := cycle_index;
      IFEND;
    FOREND;
  PROCEND find_highest_cycle;

?? TITLE := '  find_highest_cycle_version_2', EJECT ??

  PROCEDURE find_highest_cycle_version_2
    (    p_cycle_array: ^pft$cycle_array_version_2;
     VAR highest_cycle_index: pft$array_index);

    VAR
      cycle_index: pft$array_index,
      highest_cycle_number: pft$cycle_number;

    highest_cycle_number := pfc$minimum_cycle_number;

    FOR cycle_index := 1 TO UPPERBOUND (p_cycle_array^) DO
      IF p_cycle_array^ [cycle_index].cycle_number >= highest_cycle_number THEN
        highest_cycle_number := p_cycle_array^ [cycle_index].cycle_number;
        highest_cycle_index := cycle_index;
      IFEND;
    FOREND;

  PROCEND find_highest_cycle_version_2;

?? TITLE := '  find_lowest_cycle', EJECT ??

  PROCEDURE find_lowest_cycle
    (    p_cycle_array: pft$p_cycle_array;
     VAR lowest_cycle_index: pft$array_index);

    VAR
      cycle_index: pft$array_index,
      lowest_cycle_number: pft$cycle_number;

    lowest_cycle_number := pfc$maximum_cycle_number;

    FOR cycle_index := 1 TO UPPERBOUND (p_cycle_array^) DO
      IF p_cycle_array^ [cycle_index].cycle_number <= lowest_cycle_number THEN
        lowest_cycle_number := p_cycle_array^ [cycle_index].cycle_number;
        lowest_cycle_index := cycle_index;
      IFEND;
    FOREND;
  PROCEND find_lowest_cycle;

?? TITLE := '  find_lowest_cycle_version_2', EJECT ??

  PROCEDURE find_lowest_cycle_version_2
    (    p_cycle_array: ^pft$cycle_array_version_2;
     VAR lowest_cycle_index: pft$array_index);

    VAR
      cycle_index: pft$array_index,
      lowest_cycle_number: pft$cycle_number;

    lowest_cycle_number := pfc$maximum_cycle_number;

    FOR cycle_index := 1 TO UPPERBOUND (p_cycle_array^) DO
      IF p_cycle_array^ [cycle_index].cycle_number <= lowest_cycle_number THEN
        lowest_cycle_number := p_cycle_array^ [cycle_index].cycle_number;
        lowest_cycle_index := cycle_index;
      IFEND;
    FOREND;

  PROCEND find_lowest_cycle_version_2;

?? TITLE := '  find_record', EJECT ??

  PROCEDURE find_record
    (    p_info_record: pft$p_info_record;
         record_type: pft$info_record_type;
     VAR p_found_record: pft$p_info_record;
     VAR status: ost$status);

    VAR
      p_info: pft$p_info,
      p_next_info_record: pft$p_info_record;

    p_info := ^p_info_record^.body;
    RESET p_info;

    REPEAT
      pfp$find_next_info_record (p_info, p_next_info_record, status);
    UNTIL NOT status.normal OR (p_next_info_record^.record_type = record_type);

    IF status.normal THEN
      p_found_record := p_next_info_record;
    IFEND;
  PROCEND find_record;

?? TITLE := '  find_record_body', EJECT ??

  PROCEDURE find_record_body (p_info_record: pft$p_info_record;
        record_type: pft$info_record_type;
    VAR p_record_body: pft$p_info;
    VAR status: ost$status);

    VAR
      p_info: pft$p_info,
      p_next_info_record: pft$p_info_record;

    p_info := ^p_info_record^.body;
    RESET p_info;

    REPEAT
      pfp$find_next_info_record (p_info, p_next_info_record, status);
    UNTIL NOT status.normal OR (p_next_info_record^.record_type = record_type);

    IF status.normal THEN
      p_record_body := ^p_next_info_record^.body;
      RESET p_record_body;
    IFEND;
  PROCEND find_record_body;

?? TITLE := '  find_specific_cycle', EJECT ??

  PROCEDURE find_specific_cycle
    (    p_cycle_array: pft$p_cycle_array;
         cycle_number: pft$cycle_number;
     VAR specific_cycle_index: pft$array_index;
     VAR status: ost$status);

    VAR
      cycle_index: pft$array_index;

    FOR cycle_index := 1 TO UPPERBOUND (p_cycle_array^) DO
      IF p_cycle_array^ [cycle_index].cycle_number = cycle_number THEN
        specific_cycle_index := cycle_index;
        status.normal := TRUE;
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_cycle, '', status);
    osp$append_status_integer (osc$status_parameter_delimiter, cycle_number, 10, FALSE, status);
  PROCEND find_specific_cycle;

?? TITLE := '  find_specific_cycle_version_2', EJECT ??

  PROCEDURE find_specific_cycle_version_2
    (    p_cycle_array: ^pft$cycle_array_version_2;
         cycle_number: pft$cycle_number;
     VAR specific_cycle_index: pft$array_index;
     VAR status: ost$status);

    VAR
      cycle_index: pft$array_index;

    FOR cycle_index := 1 TO UPPERBOUND (p_cycle_array^) DO
      IF p_cycle_array^ [cycle_index].cycle_number = cycle_number THEN
        specific_cycle_index := cycle_index;
        status.normal := TRUE;
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_cycle, '', status);
    osp$append_status_integer (osc$status_parameter_delimiter, cycle_number, 10, FALSE, status);

  PROCEND find_specific_cycle_version_2;

?? OLDTITLE, SKIP := 2 ??
MODEND pfm$find_information;
*DECK DECK=PFM$HELP_MESSAGES EXPAND=TRUE
~"CREATE_MESSAGE_MODULE PFM$CHACC_OUTPUT$US_ENGLISH
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ADMINISTRATOR_NOTES
 Notes:

 1.  These cycles were busy and were left in the PARENT_CATALOG_RESTORED
     and/or the RESPF_MODIFICATION_MISMATCH damage condition.  A file backup
     operation running concurrently with CHANGE_CATALOG_CONTENTS caused the
     "cycle busy" condition.

 2.  An applicable exception policy is one that:

       - Includes at least one of the actions:  DELETE,
         ENABLE_MATCHING_IMAGE, or ENABLE_NONMATCHING_IMAGE.

       - Does not have criteria such as JOBS, JOB_CLASSES, or JOB_MODE
         either as individual criteria or as part of the LOGIN_USERS
         criterion.

       - Includes at least one reference to a permanent catalog or file
         if the FILES criteria is specified.  Policies applying only to
         temporary files are not considered applicable.

       - Has all of its criteria satisfied by the file in question.

 3.  These files were busy.  The mass storage image is marked for release
     or deletion but remains assigned until the file is no longer busy.
     Jobs currently using the file must first detach the file or terminate.
     If you choose, you may be able to terminate these jobs by installing an
     exception policy.

     For example, assume that the mass storage image was released for the
     file :AQUA.USER.FILE which was busy.  If you install the following
     exception policy using the MANAGE_EXCEPTION_POLICIES utility, you may
     be able to cause the termination of jobs that subsequently access the
     old mass storage image of the file:

          change_exception_policies files=:aqua.user.file ..
                volume_unavailable=exit

 4.  CHANGE_CATALOG_CONTENTS makes a copy of the installed exception
     condition policies and removes any policies that it does not consider
     applicable to its mission (see note 2 above).  The following policies
     were considered applicable:
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ALL_REFERENCED
     At least one exception policy defines a requirement to scan all
     families in the system.  It is necessary to scan all families when a
     policy:

         1) Specifies FILES=ALL

         2) Specifies the MASS_STORAGE_CLASSES criterion but does not
            specify other criteria such as FAMILIES, SETS, or VOLUMES.

         3) Specifies a generic file reference, e.g. $USER.file, that
            implies a need to scan all families.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=APPLICABLE_EXCEPTION_POLICIES
  CHANGE_CATALOG_CONTENTS enforces exception condition policies as defined by
  the MANAGE_EXCEPTION_POLICIES utility.  Therefore, files in a
  MEDIA_MISSING, UNDEFINED_DATA, or VOLUME_UNAVAILABLE condition may be
  affected as follows:
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=BUSY_CYCLES_DELETED
  Total Deleted Pending Detach by another Job (3)~H59: ~P1
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=BUSY_CYCLES_RELEASED
  Total Released Pending Detach by another Job (3)~H59: ~P1
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=BUSY_DAMAGED_CYCLES
  Total Damaged Cycles Not Processed (1)~H59: ~P1
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CLEARED_CONDITION
  Cleared ~P1 Damage Condition~H59~P2~P3
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONDITIONS_CLEARED
  Total Damage Conditions Cleared                        ~H59: ~P1
    MEDIA_IMAGE_INCONSISTENT (Cycles processed)          ~H59: ~P2
    PARENT_CATALOG_RESTORED                              ~H59: ~P3
    RESPF_MODIFICATION_MISMATCH                          ~H59: ~P4
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=COUNTS_BY_CONDITION
        Cycles in a MEDIA_MISSING condition              ~H59: ~P1
        Cycles in an UNDEFINED_DATA condition            ~H59: ~P2
        Cycles in a VOLUME_UNAVAILABLE condition         ~H59: ~P3
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CYCLE_BUSY_DAMAGE
  Busy Cycle - Damage Condition(s) Remain Set (1)~H59~P2~P3
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CYCLE_BUSY_DELETE
    Busy Cycle - Delete Pending (3)~H59~P2~P3
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CYCLE_BUSY_RELEASE
    Busy Cycle - Release Pending (3)~H59~P2~P3
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CYCLES_DELETED
    Total Cycles Deleted ~H59: ~P1
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=DELETE_OPTION
     At least one exception policy authorizes the deletion of a file which
     is affected by an exception condition.  A file is a candidate for
     deletion, if the file meets the criteria of the policy that authorizes
     the deletion and the file either -

         1) has not been duplicated by ARCHIVE/VE, or

         2) has been duplicated, was later modified, and the applicable
            exception policy does not also enable the release of the file's
            mass storage image.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=DELETED_CYCLE
  Deleted Cycle with ~P1~H59~P2~P3
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=EMI_CYCLES_RELEASED
      Total Released due to ENABLE_MATCHING_IMAGE ~H59: ~P1
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ENABLED_MATCHING_IMAGE
  Retrieval Enabled - ~P1~H59~P2~P3
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ENABLED_NONMATCHING_IMAGE
  Retrieval of Older Version Enabled - ~P1~H59~P2~P3
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ENI_CYCLES_RELEASED
      Total Released due to ENABLE_NONMATCHING_IMAGE ~H59: ~P1
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=HEADER_LINE
CHANGE_CATALOG_CONTENTS ~P1 for ~P2 ~P3
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=LOGIN_USERS_APPLICABLE
     Because you are executing with the privilege of a ~P1 administrator, it
     is assumed that you are executing on behalf of all of your users.
     Therefore, the file owner's family/user name is used to satisfy the
     LOGIN_USERS criterion present in at least one installed policy.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=MODIFICATION_DATES_AND_TIMES
    Modification Date Time altered in previous cycle.     ~H59Old Modification Date Time: ~P1
                                                          ~H59New Modification Date Time: ~P2
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=NO_CHANGES
  No changes were made.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=OBJECT_ERROR
****ERROR**** The following catalog object was skipped due to an unexpected
              internal error.  Please refer to the job log for details.

    ~P1
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=OBJECT_WARNING
****WARNING**** The following catalog object was skipped due to the abnormal
                status ~P1:

    ~P2
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=OBJECTS_SCANNED
  Total Objects Scanned                                  ~H59: ~P1
    Families                                             ~H59: ~P2
    Master Catalogs                                      ~H59: ~P3
    Subcatalogs                                          ~H59: ~P4
    Files                                                ~H59: ~P5
    Cycles                                               ~H59: ~P6
    Maximum Catalog Nesting                              ~H59: ~P7
    Maximum Files per Catalog                            ~H59: ~P8
    Maximum Cycles per File                              ~H59: ~P9
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PARAMETERS
CHANGE_CATALOG_CONTENTS Parameters

  CATALOG                  : ~P1
  DELETE_DAMAGE_CONDITIONS : (~P2)
  PERFORM_CHANGES          : ~P3
  RETRIEVE_FILES           : ~P4
  RETRIEVE_FILE_LIST       : ~P5
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PATH_PART
                                                          ~H59~P2~P3
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=RELEASE_OPTION
     At least one exception policy authorizes the release of the mass
     storage image of a file that has been duplicated by ARCHIVE/VE.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=SET_DAMAGE_CONDITION
    The RESPF_MODIFICATION_MISMATCH damage condition is now set for the cycle.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TOTAL_CYCLES_APPLICABLE
  Total Cycles Affected by an Applicable Policy (2)  ~H59: ~P1
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TOTAL_CYCLES_RELEASED
    Total Cycles Released ~H59: ~P1
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TOTALS
CHANGE_CATALOG_CONTENTS Totals
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=UNDEFINED_OBJECT
****WARNING**** ~P1 ~P2 referenced in installed exception policies
                 is not defined in the active NOS/VE configuration.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=UNEXPECTED_ABNORMAL_STATUS
****ERROR**** A change was attempted for the following object but an
              unexpected abnormal status was returned. Please refer
              to the job log for details.

    ~P1
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=USER_NOTES
 Notes:

 1.  These cycles were busy and were left in the PARENT_CATALOG_RESTORED
     and/or the RESPF_MODIFICATION_MISMATCH damage condition.  A file backup
     operation running concurrently with CHANGE_CATALOG_CONTENTS caused the
     "cycle busy" condition.

 2.  An applicable exception policy is one that:

       - Includes at least one of the actions:  DELETE,
         ENABLE_MATCHING_IMAGE, or ENABLE_NONMATCHING_IMAGE.

       - Does not have criteria such as JOBS, JOB_CLASSES, or JOB_MODE.

       - Has all of its criteria satisfied by the file in question.

 3.  These files were busy.  The mass storage image is marked for release
     or deletion but remains assigned until the file is no longer busy.
     Jobs currently using the file must first detach the file or terminate.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
*DECK DECK=PFM$MOVE_OBJECT EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
MODULE pfm$move_object;

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_file_reference
*copyc cme$logical_configuration_mgr
*copyc cme$logical_configuration_utl
*copyc cme$reserve_element
*copyc dmt$subfile_index
*copyc fst$goi_object_information
*copyc fst$goi_object_list
*copyc oss$job_paged_literal
*copyc pfd$complete_path
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pft$move_object_info
*copyc pft$volume_list
*copyc rme$request_mass_storage
?? POP ??

*copyc avp$family_administrator
*copyc avp$system_administrator
*copyc clp$build_path_subtitle
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_integer_to_rjstring
*copyc clp$count_list_elements
*copyc clp$close_display
*copyc clp$convert_cyc_ref_to_cyc_sel
*copyc clp$convert_integer_to_string
*copyc clp$convert_cyc_ref_to_cyc_sel
*copyc clp$evaluate_file_reference
*copyc clp$horizontal_tab_display
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$evaluate_parameters
*copyc clv$user_identification
*copyc cmp$get_element_state_via_lun
*copyc cmp$get_ms_status_via_lun
*copyc cmp$get_ms_volumes
*copyc cmp$get_ms_volume_info
*copyc dmp$utility_flush_logs_r3
*copyc fsp$build_file_ref_from_elems
*copyc fsp$convert_fs_structure_to_pf
*copyc fsp$evaluate_file_reference
*copyc i#current_sequence_position
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc pfp$convert_pft$path_to_fs_path
*copyc pfp$get_families_in_set
*copyc pfp$get_family_set
*copyc pfp$get_volumes_in_set
*copyc pfp$get_volumes_set_name
*copyc pfp$log_ascii
*copyc pfp$no_space_movc_dest_volumes
*copyc pfp$r3_get_move_obj_device_info
*copyc pfp$r3_get_object_information
*copyc pfp$r3_physically_move_catalog
*copyc pfp$r3_physically_move_cycle
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pmp$get_compact_date_time
*copyc pmp$get_microsecond_clock
*copyc pmp$get_task_cp_time
*copyc pmp$log_ascii

?? TITLE := 'Global Declarations Declared by this Module', EJECT ??

  CONST
    class_tab = 24,
    data_residence_tab = 50,
    volume_tab = 30,
    integer_value_tab = 40,
    path_tab = 2,
    move_data_tab = 5,
    old_subfile_vsn_tab = 14,
    old_subfile_length_tab = 29,
    new_subfile_vsn_tab = 53,
    new_subfile_length_tab = 68,
    title_tab = 3,
    subheader_tab = header_tab + 2,
    header_tab = 5;

  CONST
    subfile_header = 'Original Volume     Subfile Length          New Volume     Subfile Length';

  VAR
    catalog_information_request: [STATIC, READ, oss$job_paged_literal] fst$goi_information_request :=
          [[fsc$specific_depth, 1], $fst$goi_object_info_requests
          [fsc$goi_catalog_identity, fsc$goi_catalog_device_info, fsc$goi_catalog_info, fsc$goi_catalog_size,
          fsc$goi_catalog_object_list, fsc$goi_file_object_list, fsc$goi_file_identity, fsc$goi_file_info,
          fsc$goi_cycle_object_list, fsc$goi_cycle_identity, fsc$goi_archive_info, fsc$goi_cycle_device_info,
          fsc$goi_cycle_info, fsc$goi_cycle_size]],
    prohibited_classes: [STATIC, READ, oss$job_paged_literal] dmt$class := ['A', 'C', 'N', 'Q'];


?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pfp$move_classes_command', EJECT ??
{ PURPOSE:
{   This is the command processor for the MOVE_CLASSES command.
{

  PROCEDURE [XDCL, #GATE] pfp$move_classes_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE move_classes, move_class, movc (
{   catalogs, catalog, c: (BY_NAME) list of file = $optional
{   destination_volumes, destination_volume, dv: (BY_NAME) list of name 1..6 = $optional
{   files, file, f: (BY_NAME) list of file = $optional
{   hierarchy, h: (BY_NAME) any of
{       key
{         set
{       keyend
{       file
{     anyend = set
{   mass_storage_classes, mass_storage_class, msc: (BY_NAME) any of
{       key
{         all
{       keyend
{       list of key
{         (nosve_defined, nd)
{         (site_defined, sd)
{         (system_catalogs, sc)
{         (system_objects, so)
{         (system_permanent_files, system_files, spf, sf)
{         (system_products, sp)
{         (user_catalogs, uc)
{         (user_objects, uo)
{         (user_permanent_files, upf, user_files, uf)
{       keyend
{       list 1..25 of name 1..1
{     anyend = $required
{   megabytes, mb, m: (BY_NAME) integer 1..100000 = $optional
{   output, o: (BY_NAME) file = $output
{   perform_move, pm: (BY_NAME) boolean = $confirm TRUE
{   release_mass_storage, rms: (BY_NAME) any of
{       boolean
{       key
{         (when_space_unavailable, wsu)
{       keyend
{     anyend = false
{   source_volumes, source_volume, sv: (BY_NAME) list of name 1..6 = $optional
{   volume_overflow_allowed, voa: (BY_NAME) boolean = TRUE
{   wait, w: (BY_NAME) boolean = TRUE
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 31] of clt$pdt_parameter_name,
      parameters: array [1 .. 13] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type4: 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,
        recend,
        default_value: string (3),
      recend,
      type5: 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 .. 22] of clt$keyword_specification,
          recend,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier_v2,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type7: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type8: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type9: 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,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 2] of clt$keyword_specification,
        recend,
        default_value: string (5),
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type11: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type12: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type13: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [93, 1, 13, 12, 37, 55, 126],
    clc$command, 31, 13, 1, 0, 0, 0, 13, ''], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CATALOG                        ',clc$alias_entry, 1],
    ['CATALOGS                       ',clc$nominal_entry, 1],
    ['DESTINATION_VOLUME             ',clc$alias_entry, 2],
    ['DESTINATION_VOLUMES            ',clc$nominal_entry, 2],
    ['DV                             ',clc$abbreviation_entry, 2],
    ['F                              ',clc$abbreviation_entry, 3],
    ['FILE                           ',clc$alias_entry, 3],
    ['FILES                          ',clc$nominal_entry, 3],
    ['H                              ',clc$abbreviation_entry, 4],
    ['HIERARCHY                      ',clc$nominal_entry, 4],
    ['M                              ',clc$abbreviation_entry, 6],
    ['MASS_STORAGE_CLASS             ',clc$alias_entry, 5],
    ['MASS_STORAGE_CLASSES           ',clc$nominal_entry, 5],
    ['MB                             ',clc$alias_entry, 6],
    ['MEGABYTES                      ',clc$nominal_entry, 6],
    ['MSC                            ',clc$abbreviation_entry, 5],
    ['O                              ',clc$abbreviation_entry, 7],
    ['OUTPUT                         ',clc$nominal_entry, 7],
    ['PERFORM_MOVE                   ',clc$nominal_entry, 8],
    ['PM                             ',clc$abbreviation_entry, 8],
    ['RELEASE_MASS_STORAGE           ',clc$nominal_entry, 9],
    ['RMS                            ',clc$abbreviation_entry, 9],
    ['SOURCE_VOLUME                  ',clc$alias_entry, 10],
    ['SOURCE_VOLUMES                 ',clc$nominal_entry, 10],
    ['STATUS                         ',clc$nominal_entry, 13],
    ['SV                             ',clc$abbreviation_entry, 10],
    ['VOA                            ',clc$abbreviation_entry, 11],
    ['VOLUME_OVERFLOW_ALLOWED        ',clc$nominal_entry, 11],
    ['W                              ',clc$abbreviation_entry, 12],
    ['WAIT                           ',clc$nominal_entry, 12]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 67,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 5
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 926,
  clc$required_parameter, 0, 0],
{ PARAMETER 6
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 7
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 8
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$confirm_default_parameter, 0, 4],
{ PARAMETER 9
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 104,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 10
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 11
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 12
    [31, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 13
    [26, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, 6]]
    ],
{ PARAMETER 3
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['SET                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'set'],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 3],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    837, [[1, 0, clc$list_type], [821, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [22], [
        ['ND                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['NOSVE_DEFINED                  ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['SC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['SD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['SF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['SITE_DEFINED                   ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['SO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['SP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['SPF                            ', clc$alias_entry, clc$normal_usage_entry, 5],
        ['SYSTEM_CATALOGS                ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['SYSTEM_FILES                   ', clc$alias_entry, clc$normal_usage_entry, 5],
        ['SYSTEM_OBJECTS                 ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['SYSTEM_PERMANENT_FILES         ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['SYSTEM_PRODUCTS                ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['UC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
        ['UF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
        ['UO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
        ['UPF                            ', clc$alias_entry, clc$normal_usage_entry, 9],
        ['USER_CATALOGS                  ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['USER_FILES                     ', clc$alias_entry, clc$normal_usage_entry, 9],
        ['USER_OBJECTS                   ', clc$nominal_entry, clc$normal_usage_entry, 8],
        ['USER_PERMANENT_FILES           ', clc$nominal_entry, clc$normal_usage_entry, 9]]
        ]
      ],
    21, [[1, 0, clc$list_type], [5, 1, 25, 0, FALSE, FALSE],
        [[1, 0, clc$name_type], [1, 1]]
      ]
    ],
{ PARAMETER 6
    [[1, 0, clc$integer_type], [1, 100000, 10]],
{ PARAMETER 7
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 8
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type],
    FALSE, 2],
    3, [[1, 0, clc$boolean_type]],
    81, [[1, 0, clc$keyword_type], [2], [
      ['WHEN_SPACE_UNAVAILABLE         ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['WSU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'false'],
{ PARAMETER 10
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, 6]]
    ],
{ PARAMETER 11
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 12
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 13
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$catalogs = 1,
      p$destination_volumes = 2,
      p$files = 3,
      p$hierarchy = 4,
      p$mass_storage_classes = 5,
      p$megabytes = 6,
      p$output = 7,
      p$perform_move = 8,
      p$release_mass_storage = 9,
      p$source_volumes = 10,
      p$volume_overflow_allowed = 11,
      p$wait = 12,
      p$status = 13;

    VAR
      pvt: array [1 .. 13] of clt$parameter_value;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           ignore_condition_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status;

      IF display_opened THEN
        display_summary (move_object_info_p^, display_control, local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;

        clp$close_display (display_control, local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;

        display_opened := FALSE;
        #SPOIL (display_opened);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    VAR
      ch: 'A' .. 'Z',
      current_value: ^clt$data_value,
      cl_cycle_selector: clt$cycle_selector,
      cycle_number: pft$cycle_number,
      default_movement_statistics: pft$movement_statistics,
      default_ring_attributes: amt$ring_attributes,
      dest_volume_count: integer,
      display_control: clt$display_control,
      display_opened: boolean,
      element_count: integer,
      evaluated_file_reference: fst$evaluated_file_reference,
      family_catalog_info_p: ^fst$goi_object,
      family_catalog_reference: fst$path,
      family_found: boolean,
      family_object_info_p: ^fst$goi_object_information,
      i: integer,
      ignore_status: ost$status,
      index1: integer,
      index2: integer,
      j: integer,
      local_status: ost$status,
      master_catalog_array_p: ^fst$goi_object_list,
      master_catalog_path: array [1 .. 2] of pft$name,
      move_object_info_p: ^pft$move_object_info,
      number_of_volumes_in_set: integer,
      object_index: integer,
      object_info_p: ^SEQ ( * ),
      object_segment_pointer: amt$segment_pointer,
      p_cycle_number: ^pft$cycle_number,
      p_path: ^pft$path,
      set_name: ost$name,
      set_volume_list_p: ^pft$mo_volume_list,
      source_volume_count: integer,
      sub_object_info_p: ^SEQ ( * ),
      temp_volume_count: integer,
      temp_volume_list_p: ^pft$volume_list,
      traverse_hierarchy: boolean,
      traverse_set: boolean,
      user_id: ost$user_identification,
      user_name: ost$user_name,
      volume_available: boolean,
      volume_found: boolean,
      volume_list_p: ^pft$volume_list,
      volume_list_size: ost$positive_integers;

    IF (NOT avp$family_administrator ()) AND (NOT avp$system_administrator ()) THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$not_system_administrator,
            'MOVE_CLASSES', status);
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$hierarchy].specified) AND (pvt [p$files].specified OR pvt [p$catalogs].specified) THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_parameter_conflict_2,
            'HIERARCHY', status);
      RETURN;
    IFEND;

    IF (pvt [p$megabytes].specified) AND (pvt [p$files].specified OR pvt [p$catalogs].specified) THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_parameter_conflict_2,
            'MEGABYTES', status);
      RETURN;
    IFEND;

    default_movement_statistics.abnormal_status := 0;
    default_movement_statistics.bytes_moved := 0;
    default_movement_statistics.bytes_released := 0;
    default_movement_statistics.cycle_busy := 0;
    default_movement_statistics.cycles_released := 0;
    default_movement_statistics.insufficient_space := 0;
    default_movement_statistics.no_available_space := 0;
    default_movement_statistics.objects_moved := 0;
    default_movement_statistics.objects_not_moved := 0;
    default_movement_statistics.unrecovered_read_error := 0;

    PUSH move_object_info_p;

    FOR ch := 'A' TO 'Z' DO
      move_object_info_p^.class_statistics [ch] := default_movement_statistics;
    FOREND;

    move_object_info_p^.dest_volume_list_p := NIL;
    move_object_info_p^.mass_storage_class := $dmt$class [];
    move_object_info_p^.move_bytes_threshold := 0;
    move_object_info_p^.overall_statistics := default_movement_statistics;
    move_object_info_p^.perform_move := TRUE;
    move_object_info_p^.performance_statistics.catalog_count := 0;
    move_object_info_p^.performance_statistics.cycle_count := 0;
    move_object_info_p^.performance_statistics.file_count := 0;
    move_object_info_p^.release_mass_storage := pfc$never;
    move_object_info_p^.set_name := osc$null_name;
    move_object_info_p^.set_volume_list_p := NIL;
    move_object_info_p^.source_volume_list_p := NIL;
    move_object_info_p^.update_available_space_total := 0;
    move_object_info_p^.volume_overflow_allowed := TRUE;
    move_object_info_p^.wait := TRUE;

    pmp$get_compact_date_time (move_object_info_p^.performance_statistics.initial_date_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_microsecond_clock (move_object_info_p^.performance_statistics.initial_microsecond_clock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_task_cp_time (move_object_info_p^.performance_statistics.initial_task_cp_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    volume_list_size := 2 * UPPERVALUE(dmt$subfile_index) * #SIZE(pft$subfile);
    PUSH move_object_info_p^.move_status.volume_list_storage_p: [[REP volume_list_size OF cell]];
    RESET move_object_info_p^.move_status.volume_list_storage_p;
    move_object_info_p^.move_status.move_successful := FALSE;
    move_object_info_p^.move_status.new_subfile_list_p := NIL;
    move_object_info_p^.move_status.old_subfile_list_p := NIL;
    move_object_info_p^.move_status.reason_for_move_failure := pfc$unexpected_abort;

    {
    { Get set name to validate all volumes, files and catalogs.
    {
    IF pvt [p$source_volumes].specified THEN
      pfp$get_volumes_set_name (pvt [p$source_volumes].value^.element_value^.name_value (1, 6), set_name,
            status);
    ELSEIF pvt [p$destination_volumes].specified THEN
      pfp$get_volumes_set_name (pvt [p$destination_volumes].value^.element_value^.name_value (1, 6),
            set_name, status);
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_parameter_conflict_1, ' ', status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    move_object_info_p^.set_name := set_name;

    number_of_volumes_in_set := 10;
    REPEAT
      PUSH volume_list_p: [1 .. number_of_volumes_in_set];
      pfp$get_volumes_in_set (set_name, volume_list_p^, number_of_volumes_in_set, status);
    UNTIL (NOT status.normal OR (number_of_volumes_in_set <= UPPERBOUND (volume_list_p^)));
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH move_object_info_p^.set_volume_list_p: [1 .. number_of_volumes_in_set];
    FOR i := 1 TO number_of_volumes_in_set DO
      move_object_info_p^.set_volume_list_p^ [i].recorded_vsn := volume_list_p^ [i];
    FOREND;
    set_volume_list_p := move_object_info_p^.set_volume_list_p;

    initialize_set_volume_list (move_object_info_p^.set_volume_list_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$mass_storage_classes].specified THEN
      IF pvt [p$mass_storage_classes].value^.kind = clc$keyword THEN
        IF pvt [p$mass_storage_classes].value^.keyword_value = 'ALL' THEN
          move_object_info_p^.mass_storage_class := -$dmt$class [];
          move_object_info_p^.mass_storage_class :=
                move_object_info_p^.mass_storage_class - prohibited_classes;
        IFEND;
      ELSE
        current_value := pvt [p$mass_storage_classes].value;
        WHILE (current_value <> NIL) AND (current_value^.element_value <> NIL) DO
          IF current_value^.element_value^.kind = clc$keyword THEN
            IF current_value^.element_value^.keyword_value = 'ALL' THEN
              move_object_info_p^.mass_storage_class := -$dmt$class [];
              move_object_info_p^.mass_storage_class :=
                    move_object_info_p^.mass_storage_class - prohibited_classes;
            ELSEIF current_value^.element_value^.keyword_value = 'NOSVE_DEFINED' THEN
              move_object_info_p^.mass_storage_class := move_object_info_p^.mass_storage_class +
                    $dmt$class ['J', 'K', 'L', 'M', 'P'];
            ELSEIF current_value^.element_value^.keyword_value = 'SITE_DEFINED' THEN
              move_object_info_p^.mass_storage_class := move_object_info_p^.mass_storage_class +
                    $dmt$class ['U', 'V', 'W', 'X', 'Y', 'Z'];
            ELSEIF current_value^.element_value^.keyword_value = 'SYSTEM_CATALOGS' THEN
              move_object_info_p^.mass_storage_class := move_object_info_p^.mass_storage_class +
                    $dmt$class ['J'];
            ELSEIF current_value^.element_value^.keyword_value = 'SYSTEM_PERMANENT_FILES' THEN
              move_object_info_p^.mass_storage_class := move_object_info_p^.mass_storage_class +
                    $dmt$class ['K', 'P'];
            ELSEIF current_value^.element_value^.keyword_value = 'SYSTEM_PRODUCTS' THEN
              move_object_info_p^.mass_storage_class := move_object_info_p^.mass_storage_class +
                    $dmt$class ['P'];
            ELSEIF current_value^.element_value^.keyword_value = 'USER_CATALOGS' THEN
              move_object_info_p^.mass_storage_class := move_object_info_p^.mass_storage_class +
                    $dmt$class ['L'];
            ELSEIF current_value^.element_value^.keyword_value = 'USER_PERMANENT_FILES' THEN
              move_object_info_p^.mass_storage_class := move_object_info_p^.mass_storage_class +
                    $dmt$class ['M'];
            ELSEIF current_value^.element_value^.keyword_value = 'SYSTEM_OBJECTS' THEN
              move_object_info_p^.mass_storage_class := move_object_info_p^.mass_storage_class +
                    $dmt$class ['J', 'K', 'P'];
            ELSEIF current_value^.element_value^.keyword_value = 'USER_OBJECTS' THEN
              move_object_info_p^.mass_storage_class := move_object_info_p^.mass_storage_class +
                    $dmt$class ['L', 'M'];
            ELSE
            IFEND;
          ELSE
            move_object_info_p^.mass_storage_class := move_object_info_p^.mass_storage_class +
                  $dmt$class [current_value^.element_value^.name_value (1)];
          IFEND;
          current_value := current_value^.link;
        WHILEND;
      IFEND;
    ELSE
      move_object_info_p^.mass_storage_class := -$dmt$class [];
      move_object_info_p^.mass_storage_class := move_object_info_p^.mass_storage_class - prohibited_classes;
    IFEND;

    IF pvt [p$perform_move].specified THEN
      move_object_info_p^.perform_move := pvt [p$perform_move].value^.boolean_value.value;
    ELSE
      move_object_info_p^.perform_move := TRUE;
    IFEND;

    IF pvt [p$source_volumes].specified THEN
      PUSH move_object_info_p^.source_volume_list_p:
            [1 .. clp$count_list_elements (pvt [p$source_volumes].value)];
      current_value := pvt [p$source_volumes].value;
      element_count := 0;

      WHILE (current_value <> NIL) AND (current_value^.element_value <> NIL) DO
        element_count := element_count + 1;
        volume_found := FALSE;
        volume_available := FALSE;

        FOR i := 1 TO UPPERBOUND (set_volume_list_p^) DO
          IF current_value^.element_value^.name_value (1, 6) = set_volume_list_p^ [i].recorded_vsn THEN
            volume_found := TRUE;
            volume_available := set_volume_list_p^ [i].available;
            move_object_info_p^.source_volume_list_p^ [element_count] := ^set_volume_list_p^ [i];
            set_volume_list_p^ [i].volume_type := pfc$source_volume;
          IFEND;
        FOREND;

        IF NOT volume_found THEN
          osp$set_status_abnormal (rmc$resource_management_id, rme$vsn_not_part_of_set,
                current_value^.element_value^.name_value (1, 6), status);
          osp$append_status_parameter (osc$status_parameter_delimiter, move_object_info_p^.set_name,
                status);
          RETURN;
        IFEND;

        IF NOT volume_available THEN
          osp$set_status_abnormal (rmc$resource_management_id, pfe$movc_volume_unavailable,
                'SOURCE_VOLUME', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                current_value^.element_value^.name_value (1, 6), status);
          RETURN;
        IFEND;

        current_value := current_value^.link;
      WHILEND;
    IFEND;

    IF pvt [p$destination_volumes].specified THEN
      PUSH move_object_info_p^.dest_volume_list_p:
            [1 .. clp$count_list_elements (pvt [p$destination_volumes].value)];
      current_value := pvt [p$destination_volumes].value;
      element_count := 0;

      WHILE (current_value <> NIL) AND (current_value^.element_value <> NIL) DO
        element_count := element_count + 1;
        volume_found := FALSE;
        volume_available := FALSE;

        FOR i := 1 TO UPPERBOUND (set_volume_list_p^) DO
          IF current_value^.element_value^.name_value (1, 6) = set_volume_list_p^ [i].recorded_vsn THEN
            volume_found := TRUE;
            volume_available := set_volume_list_p^ [i].available;
            move_object_info_p^.dest_volume_list_p^ [element_count] := ^set_volume_list_p^ [i];
            IF set_volume_list_p^ [i].volume_type = pfc$source_volume THEN
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$redundant_volume_spec,
                    current_value^.element_value^.name_value (1, 6), status);
              RETURN;
            IFEND;
            set_volume_list_p^ [i].volume_type := pfc$destination_volume;
            IF NOT move_object_info_p^.perform_move THEN
              set_volume_list_p^ [i].ms_class :=
                    set_volume_list_p^ [i].ms_class + move_object_info_p^.mass_storage_class;
            IFEND;
          IFEND;
        FOREND;

        IF NOT volume_found THEN
          osp$set_status_abnormal (rmc$resource_management_id, rme$vsn_not_part_of_set,
                current_value^.element_value^.name_value (1, 6), status);
          osp$append_status_parameter (osc$status_parameter_delimiter, move_object_info_p^.set_name,
                status);
          RETURN;
        IFEND;

        IF NOT volume_available THEN
          osp$set_status_abnormal (rmc$resource_management_id, pfe$movc_volume_unavailable,
                'DESTINATION_VOLUME', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                current_value^.element_value^.name_value (1, 6), status);
          RETURN;
        IFEND;

        current_value := current_value^.link;
      WHILEND;
    IFEND;

    IF (move_object_info_p^.mass_storage_class * prohibited_classes) <> $dmt$class [] THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_mass_storage_class, ' ', status);
      RETURN;
    IFEND;

    IF pvt [p$megabytes].specified THEN
      move_object_info_p^.move_bytes_threshold := pvt [p$megabytes].value^.integer_value.value * 1048576;
    ELSE
      move_object_info_p^.move_bytes_threshold := 0;
    IFEND;

    IF pvt [p$release_mass_storage].specified THEN
      IF pvt [p$release_mass_storage].value^.kind = clc$keyword THEN
        move_object_info_p^.release_mass_storage := pfc$when_insufficient_space;
      ELSE
        IF pvt [p$release_mass_storage].value^.boolean_value.value THEN
          move_object_info_p^.release_mass_storage := pfc$always;
        ELSE
          move_object_info_p^.release_mass_storage := pfc$never;
        IFEND;
      IFEND;
    ELSE
      move_object_info_p^.release_mass_storage := pfc$never;
    IFEND;

    IF pvt [p$volume_overflow_allowed].specified THEN
      move_object_info_p^.volume_overflow_allowed := pvt [p$volume_overflow_allowed].value^.boolean_value.
            value;
    ELSE
      move_object_info_p^.volume_overflow_allowed := TRUE;
    IFEND;

    IF pvt [p$wait].specified THEN
      move_object_info_p^.wait := pvt [p$wait].value^.boolean_value.value;
    ELSE
      move_object_info_p^.wait := TRUE;
    IFEND;

    IF pvt [p$source_volumes].specified AND (NOT pvt [p$destination_volumes].specified) THEN
      dest_volume_count := 0;
      FOR i := 1 TO number_of_volumes_in_set DO
        IF set_volume_list_p^ [i].available AND
              (set_volume_list_p^ [i].volume_type = pfc$unspecified_volume) AND
              ((move_object_info_p^.mass_storage_class * set_volume_list_p^ [i].ms_class)
              <> $dmt$class []) THEN
          dest_volume_count := dest_volume_count + 1;
        IFEND;
      FOREND;
      IF dest_volume_count > 0 THEN
        PUSH move_object_info_p^.dest_volume_list_p: [1 .. dest_volume_count];
        j := 1;
        FOR i := 1 TO number_of_volumes_in_set DO
          IF set_volume_list_p^ [i].available AND
                (set_volume_list_p^ [i].volume_type = pfc$unspecified_volume) AND
                ((move_object_info_p^.mass_storage_class * set_volume_list_p^ [i].ms_class)
                <> $dmt$class []) THEN
            set_volume_list_p^ [i].volume_type := pfc$destination_volume;
            move_object_info_p^.dest_volume_list_p^ [j] := ^set_volume_list_p^ [i];
            j := j + 1;
          IFEND;
        FOREND;
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_no_destination_volumes,
              move_object_info_p^.set_name, status);
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$destination_volumes].specified AND (NOT pvt [p$source_volumes].specified) THEN
      source_volume_count := 0;
      FOR i := 1 TO number_of_volumes_in_set DO
        IF set_volume_list_p^ [i].available AND
              (set_volume_list_p^ [i].volume_type = pfc$unspecified_volume) THEN
          source_volume_count := source_volume_count + 1;
        IFEND;
      FOREND;

      IF source_volume_count > 0 THEN
        PUSH move_object_info_p^.source_volume_list_p: [1 .. source_volume_count];
        j := 1;

        FOR i := 1 TO number_of_volumes_in_set DO
          IF set_volume_list_p^ [i].available AND
                (set_volume_list_p^ [i].volume_type = pfc$unspecified_volume) THEN
            set_volume_list_p^ [i].volume_type := pfc$source_volume;
            move_object_info_p^.source_volume_list_p^ [j] := ^set_volume_list_p^ [i];
            j := j + 1;
          IFEND;
        FOREND;
      IFEND;
    IFEND;

    traverse_hierarchy := NOT (pvt [p$files].specified OR pvt [p$catalogs].specified);
    traverse_set := traverse_hierarchy AND (pvt [p$hierarchy].value^.kind = clc$keyword);
    validate_mass_storage_class (move_object_info_p, traverse_set, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (move_object_info_p^.source_volume_list_p = NIL) AND
          (NOT pvt [p$files].specified) AND (NOT pvt [p$catalogs].specified) THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_no_source_volumes,
            move_object_info_p^.set_name, status);
      RETURN;
    IFEND;

    pfp$r3_get_move_obj_device_info (move_object_info_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO number_of_volumes_in_set DO
      set_volume_list_p^ [i].mass_storage_before := set_volume_list_p^ [i].mass_storage_available;
    FOREND;

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
    clp$open_display_reference (pvt [p$output].value^.file_value^, NIL, fsc$list, default_ring_attributes,
          display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_opened := TRUE;
    #SPOIL (display_opened);

    osp$establish_block_exit_hndlr (^abort_handler);

  /display_file_open/
    BEGIN
      display_parameters (pvt[p$catalogs], pvt [p$files], pvt[p$source_volumes], pvt[p$destination_volumes],
            pvt[p$hierarchy], pvt[p$megabytes], move_object_info_p^, display_control, status);
      IF NOT status.normal THEN
        EXIT /display_file_open/;
      IFEND;

      IF pvt [p$catalogs].specified THEN
        current_value := pvt [p$catalogs].value;

        WHILE (current_value <> NIL) AND (current_value^.element_value <> NIL) DO
          fsp$evaluate_file_reference (current_value^.element_value^.file_value^,
                {NOT command_file_reference_allowed} FALSE, evaluated_file_reference, local_status);
          IF NOT local_status.normal THEN
            display_abnormal_status (local_status, display_control, ignore_status);
            EXIT /display_file_open/;
          IFEND;

          PUSH p_path: [1 .. evaluated_file_reference.number_of_path_elements];
          fsp$convert_fs_structure_to_pf (evaluated_file_reference, p_path);

          pfp$r3_physically_move_catalog (p_path^, move_object_info_p, local_status);

          move_object_info_p^.performance_statistics.catalog_count :=
                move_object_info_p^.performance_statistics.catalog_count + 1;

          IF (NOT move_object_info_p^.move_status.move_successful) AND
                (move_object_info_p^.move_status.reason_for_move_failure = pfc$operator_terminate) THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_operator_termination, '',
                  local_status);
            display_catalog_move (p_path^, move_object_info_p^, display_control, local_status);
            EXIT /display_file_open/;
          ELSE
            display_catalog_move (p_path^, move_object_info_p^, display_control, local_status);
          IFEND;

          current_value := current_value^.link;
        WHILEND;
      IFEND;

      IF pvt [p$files].specified THEN
        current_value := pvt [p$files].value;

        WHILE (current_value <> NIL) AND (current_value^.element_value <> NIL) DO
          fsp$evaluate_file_reference (current_value^.element_value^.file_value^, FALSE
                {NOT command_file_reference_allowed} , evaluated_file_reference, local_status);
          IF NOT local_status.normal THEN
            display_abnormal_status (local_status, display_control, ignore_status);
            EXIT /display_file_open/;
          IFEND;

          PUSH p_path: [1 .. evaluated_file_reference.number_of_path_elements];
          fsp$convert_fs_structure_to_pf (evaluated_file_reference, p_path);
          clp$convert_cyc_ref_to_cyc_sel (evaluated_file_reference.cycle_reference, cl_cycle_selector);
          cycle_number := 1;

          pfp$r3_physically_move_cycle (p_path^, cl_cycle_selector.value, move_object_info_p, cycle_number,
                local_status);
          IF local_status.normal THEN
            p_cycle_number := ^cycle_number;
          ELSE
            IF evaluated_file_reference.cycle_reference.specification = fsc$cycle_number THEN
              cycle_number := evaluated_file_reference.cycle_reference.cycle_number;
              p_cycle_number := ^cycle_number;
            ELSE
              p_cycle_number := NIL;
            IFEND;
          IFEND;

          move_object_info_p^.performance_statistics.file_count :=
                move_object_info_p^.performance_statistics.file_count + 1;
          move_object_info_p^.performance_statistics.cycle_count :=
                move_object_info_p^.performance_statistics.cycle_count + 1;

          IF (NOT move_object_info_p^.move_status.move_successful) AND
                (move_object_info_p^.move_status.reason_for_move_failure = pfc$operator_terminate) THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_operator_termination, '',
                  local_status);
            display_cycle_move (p_path^, move_object_info_p^, p_cycle_number, display_control, local_status);
            EXIT /display_file_open/;
          ELSE
            display_cycle_move (p_path^, move_object_info_p^, p_cycle_number, display_control, local_status);
          IFEND;

          current_value := current_value^.link;
        WHILEND;
      IFEND;

      IF traverse_hierarchy THEN
        IF pvt [p$hierarchy].value^.kind = clc$keyword THEN
          move_set (move_object_info_p, display_control, status);
        ELSE
          fsp$evaluate_file_reference (pvt [p$hierarchy].value^.file_value^, FALSE
                {NOT command_file_reference_allowed} , evaluated_file_reference, local_status);
          IF NOT local_status.normal THEN
            display_abnormal_status (local_status, display_control, ignore_status);
            EXIT /display_file_open/;
          IFEND;

          IF (fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local) THEN
            osp$set_status_abnormal ('CL', cle$not_permitted_on_loc_cat, '', status);
            EXIT /display_file_open/;
          IFEND;

          PUSH p_path: [1 .. evaluated_file_reference.number_of_path_elements];
          fsp$convert_fs_structure_to_pf (evaluated_file_reference, p_path);

          move_hierarchy (p_path^, move_object_info_p, display_control, ignore_status);
          IF (NOT move_object_info_p^.move_status.move_successful) AND
                ((move_object_info_p^.move_status.reason_for_move_failure = pfc$set_threshold_exceeded) OR
                (move_object_info_p^.move_status.reason_for_move_failure = pfc$operator_terminate)) THEN
            EXIT /display_file_open/;
          IFEND;
        IFEND;
      IFEND;

    END /display_file_open/;

    display_summary (move_object_info_p^, display_control, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

    clp$close_display (display_control, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

    display_opened := FALSE;
    #SPOIL (display_opened);

    osp$disestablish_cond_handler

  PROCEND pfp$move_classes_command;

?? OLDTITLE ??
?? NEWTITLE := 'convert_date_time', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to convert the information in a variable
{   of type OST$DATE_TIME to a displayable format.
{

  PROCEDURE convert_date_time
    (    date_time: ost$date_time;
     VAR str: ost$string);

    VAR
      date: ost$date,
      time: ost$time,
      status: ost$status;

    IF (date_time.year >= UPPERVALUE (date_time.year)) AND
          (date_time.month >= UPPERVALUE (date_time.month)) AND
          (date_time.day >= UPPERVALUE (date_time.day)) AND (date_time.hour >=
          UPPERVALUE (date_time.hour)) AND (date_time.minute >= UPPERVALUE (date_time.minute)) AND
          (date_time.second >= UPPERVALUE (date_time.second)) AND
          (date_time.millisecond >= UPPERVALUE (date_time.millisecond)) THEN
      str.size := 4;
      str.value := 'NONE';
      RETURN;
    IFEND;

    pmp$format_compact_date (date_time, osc$iso_date, date, status);
    IF status.normal THEN
      str.size := STRLENGTH (date.iso);
      str.value (1, str.size) := date.iso;
    ELSE
      str.size := 10;
      str.value (1, 10) := '????-??-??';
    IFEND;

    str.value (str.size + 1) := ' ';
    pmp$format_compact_time (date_time, osc$millisecond_time, time, status);
    IF status.normal THEN
      str.value (str.size + 2, STRLENGTH (time.millisecond)) := time.millisecond;
      str.size := str.size + 1 + STRLENGTH (time.millisecond);
    ELSE
      str.value (str.size + 2, 12) := '??:??:??.???';
      str.size := str.size + 1 + 12;
    IFEND;

  PROCEND convert_date_time;

?? OLDTITLE ??
?? NEWTITLE := 'display_abnormal_status', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to display a status message to the
{   output file.
{

  PROCEDURE display_abnormal_status
    (    local_status: ost$status;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      message: ost$status_message,
      message_line_index: 1 .. osc$max_status_message_lines,
      p_message: ^ost$status_message,
      p_message_line: ^ost$status_message_line,
      p_message_line_count: ^ost$status_message_line_count,
      p_message_line_size: ^ost$status_message_line_size,
      str: ost$string;

    status.normal := TRUE;

    osp$format_message (local_status, osc$full_message_level, display_control.page_width, message, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_message := ^message;
    RESET p_message;
    NEXT p_message_line_count IN p_message;

    FOR message_line_index := 1 TO p_message_line_count^ DO
      NEXT p_message_line_size IN p_message;
      NEXT p_message_line: [p_message_line_size^] IN p_message;
      str.size := p_message_line_size^;
      str.value (1, str.size) := p_message_line^;

      clp$put_partial_display (display_control, str.value (1, str.size), clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    clp$put_partial_display (display_control, ' ', clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_abnormal_status;

?? OLDTITLE ??
?? NEWTITLE := 'display_catalog_move', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to display information associated with
{   a catalog move to the output file.  If the catalog cannot be moved, the
{   abnormal status is displayed to the output file.

  PROCEDURE display_catalog_move
    (    path: pft$path;
         move_object_info: pft$move_object_info;
     VAR display_control: clt$display_control;
     VAR status: {i/o} ost$status);

    VAR
      class_str: string (1),
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      index: integer,
      local_status: ost$status,
      str: ost$string,
      str_int: string (10);

    IF (NOT move_object_info.move_status.move_successful) AND
          (move_object_info.move_status.reason_for_move_failure = pfc$volume_threshold_exceeded) THEN
      RETURN;
    IFEND;

    pfp$convert_pft$path_to_fs_path (path, fs_path, fs_path_size);

    display_path (fs_path, fs_path_size, path_tab, display_control.page_width, display_control,
          local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    IF (NOT move_object_info.move_status.move_successful) AND (NOT status.normal) THEN
      display_abnormal_status (status, display_control, local_status);
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, move_data_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Size: ', clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (move_object_info.move_status.allocated_size, {radix} 10,
          {include_radix} FALSE, ' ', str_int, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str_int, clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, class_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Mass Storage Class: ', clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    class_str (1) := move_object_info.move_status.ms_class;
    clp$put_partial_display (display_control, class_str (1, 1), clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, move_data_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, subfile_header, clc$no_trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, old_subfile_vsn_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, move_object_info.move_status.old_subfile_list_p^ [1].
          recorded_vsn, clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, old_subfile_length_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (move_object_info.move_status.old_subfile_list_p^ [1].allocated_length,
          {radix} 10, {include_radix} FALSE, ' ', str_int, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str_int, clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, new_subfile_vsn_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, move_object_info.move_status.new_subfile_list_p^ [1].
          recorded_vsn, clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, new_subfile_length_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (move_object_info.move_status.new_subfile_list_p^ [1].allocated_length,
          {radix} 10, {include_radix} FALSE, ' ', str_int, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str_int, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, ' ', clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_catalog_move;

?? OLDTITLE ??
?? NEWTITLE := 'display_class_summary', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to display movement statistics for each
{   affected mass storage class.
{

  PROCEDURE display_class_summary
    (    move_object_info: pft$move_object_info;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      class: char,
      class_str: string (1);

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, 'Class Summary', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /display_class/
    FOR class := 'A' TO 'Z' DO
      IF (move_object_info.class_statistics [class].objects_moved = 0) AND
            (move_object_info.class_statistics [class].objects_not_moved = 0) THEN
        CYCLE /display_class/;
      IFEND;

      clp$horizontal_tab_display (display_control, title_tab, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, 'Mass Storage Class: ', clc$no_trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      class_str (1) := class;
      clp$put_partial_display (display_control, class_str (1, 1), clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_movement_statistics (move_object_info.class_statistics [class], display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND /display_class/;

  PROCEND display_class_summary;

?? OLDTITLE ??
?? NEWTITLE := 'display_cycle_move', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to display information associated with
{   the move of a file cycle to the output file.  If the file cycle could
{   not be moved, the abnormal status is displayed to the output file.
{

  PROCEDURE display_cycle_move
    (    path: pft$path;
         move_object_info: pft$move_object_info;
         p_cycle_number: ^pft$cycle_number;
     VAR display_control: clt$display_control;
     VAR status: {i/o} ost$status);

    VAR
      action: string (30),
      class_str: string (1),
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      i: integer,
      local_status: ost$status,
      max_number_of_subfiles: integer,
      recorded_vsn: rmt$recorded_vsn,
      str: ost$string,
      str_int: string (10),
      subfile_length: amt$file_byte_address;

    IF (NOT move_object_info.move_status.move_successful) AND
          (move_object_info.move_status.reason_for_move_failure = pfc$volume_threshold_exceeded) THEN
      RETURN;
    IFEND;

    pfp$convert_pft$path_to_fs_path (path, fs_path, fs_path_size);

    IF (p_cycle_number <> NIL) AND (fs_path_size < fsc$max_path_size - 4) THEN
      STRINGREP (fs_path (fs_path_size + 1, * ), i, p_cycle_number^);
      fs_path (fs_path_size + 1, 1) := '.';
      fs_path_size := fs_path_size + i;
    IFEND;

    display_path (fs_path, fs_path_size, path_tab, display_control.page_width, display_control, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    IF (NOT move_object_info.move_status.move_successful) AND (NOT status.normal) THEN
      display_abnormal_status (status, display_control, local_status);
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, move_data_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Size: ', clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (move_object_info.move_status.allocated_size, {radix} 10,
          {include_radix} FALSE, ' ', str_int, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str_int, clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, class_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Mass Storage Class: ', clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    class_str (1) := move_object_info.move_status.ms_class;
    clp$put_partial_display (display_control, class_str (1, 1), clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, data_residence_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Data Residence: ', clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE move_object_info.move_status.data_residence OF
    = pfc$unreleasable_data =
      action := ' MASS STORAGE          ';
    = pfc$releasable_data =
      action := ' DUPLICATED            ';
    = pfc$offline_data =
      action := ' OFFLINE               ';
    = pfc$release_data_requested =
      action := ' OFFLINE               ';
    ELSE
      action := ' UNKNOWN               ';
    CASEND;

    clp$put_partial_display (display_control, action, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, move_data_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Modification Date Time: ', clc$no_trim, amc$continue,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    convert_date_time (move_object_info.move_status.modification_date_time, str);

    clp$put_partial_display (display_control, str.value (1, str.size), clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, move_data_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, subfile_header, clc$no_trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF move_object_info.move_status.new_subfile_list_p = NIL THEN
      max_number_of_subfiles := UPPERBOUND (move_object_info.move_status.old_subfile_list_p^);
    ELSEIF UPPERBOUND (move_object_info.move_status.old_subfile_list_p^) >=
          UPPERBOUND (move_object_info.move_status.new_subfile_list_p^) THEN
      max_number_of_subfiles := UPPERBOUND (move_object_info.move_status.old_subfile_list_p^);
    ELSE
      max_number_of_subfiles := UPPERBOUND (move_object_info.move_status.new_subfile_list_p^);
    IFEND;

    FOR i := 1 TO max_number_of_subfiles DO
      IF i <= UPPERBOUND (move_object_info.move_status.old_subfile_list_p^) THEN
        recorded_vsn := move_object_info.move_status.old_subfile_list_p^ [i].recorded_vsn;
        subfile_length := move_object_info.move_status.old_subfile_list_p^ [i].allocated_length;
      ELSE
        recorded_vsn := rmc$unspecified_vsn;
        subfile_length := 0;
      IFEND;

      clp$horizontal_tab_display (display_control, old_subfile_vsn_tab, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, recorded_vsn, clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$horizontal_tab_display (display_control, old_subfile_length_tab, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF recorded_vsn <> rmc$unspecified_vsn THEN
        clp$convert_integer_to_rjstring (subfile_length, {radix} 10, {include_radix} FALSE, ' ', str_int,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_partial_display (display_control, str_int, clc$trim, amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF move_object_info.move_status.new_subfile_list_p <> NIL THEN
        IF i <= UPPERBOUND (move_object_info.move_status.new_subfile_list_p^) THEN
          recorded_vsn := move_object_info.move_status.new_subfile_list_p^ [i].recorded_vsn;
          subfile_length := move_object_info.move_status.new_subfile_list_p^ [i].allocated_length;
        ELSE
          recorded_vsn := rmc$unspecified_vsn;
          subfile_length := 0;
        IFEND;

        clp$horizontal_tab_display (display_control, new_subfile_vsn_tab, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_partial_display (display_control, recorded_vsn, clc$trim, amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$horizontal_tab_display (display_control, new_subfile_length_tab, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF recorded_vsn <> rmc$unspecified_vsn THEN
          clp$convert_integer_to_rjstring (subfile_length, {radix} 10, {include_radix} FALSE, ' ', str_int,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          str_int := ' ';
        IFEND;

        clp$put_partial_display (display_control, str_int, clc$trim, amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSEIF i = 1 THEN
        clp$horizontal_tab_display (display_control, new_subfile_vsn_tab, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_partial_display (display_control, '  Cycle Released', clc$trim, amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      clp$put_partial_display (display_control, ' ', clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    clp$put_partial_display (display_control, ' ', clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
  PROCEND display_cycle_move;

?? OLDTITLE ??
?? NEWTITLE := 'display_movement_statistics', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to display movement statistics to the
{   output file.
{

  PROCEDURE display_movement_statistics
    (    movement_statistics: pft$movement_statistics;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      str: string (12);

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Bytes Moved:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (movement_statistics.bytes_moved, {radix} 10, {include_radix} FALSE, ' ',
          str, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Objects Moved:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (movement_statistics.objects_moved, {radix} 10, {include_radix} FALSE,
          ' ', str, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Objects Not Moved:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (movement_statistics.objects_not_moved, {radix} 10, {include_radix} FALSE,
          ' ', str, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, subheader_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Abnormal Status:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (movement_statistics.abnormal_status, {radix} 10, {include_radix} FALSE,
          ' ', str, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, subheader_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Cycle Busy:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (movement_statistics.cycle_busy, {radix} 10, {include_radix} FALSE, ' ',
          str, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, subheader_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Insufficient Space:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (movement_statistics.insufficient_space, {radix} 10,
          {include_radix} FALSE, ' ', str, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, subheader_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'No Available Space:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (movement_statistics.no_available_space, {radix} 10,
          {include_radix} FALSE, ' ', str, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, subheader_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Unrecovered Read Error:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (movement_statistics.unrecovered_read_error, {radix} 10,
          {include_radix} FALSE, ' ', str, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Bytes Released:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (movement_statistics.bytes_released, {radix} 10, {include_radix} FALSE,
          ' ', str, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Cycles Released:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (movement_statistics.cycles_released, {radix} 10, {include_radix} FALSE,
          ' ', str, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_movement_statistics;

?? OLDTITLE ??
?? NEWTITLE := 'display_overall_summary', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to display information about the type and
{   number of objects scanned to the output file.
{

  PROCEDURE display_overall_summary
    (    move_object_info: pft$move_object_info;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, 'Overall Summary', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_movement_statistics (move_object_info.overall_statistics, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_overall_summary;

?? OLDTITLE ??
?? NEWTITLE := 'display_parameters', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to display the values specified for the
{   command parameters to the output file.
{

  PROCEDURE display_parameters
    (    catalog_parameter: clt$parameter_value;
         file_parameter: clt$parameter_value;
         source_vol_parameter: clt$parameter_value;
         dest_vol_parameter: clt$parameter_value;
         hierarchy_parameter: clt$parameter_value;
         megabytes_parameter: clt$parameter_value;
         move_object_info: pft$move_object_info;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    CONST
      catalogs_header = 'CATALOGS',
      files_header = 'FILES',
      source_volumes_header = 'SOURCE_VOLUMES',
      destination_volumes_header = 'DESTINATION_VOLUMES',
      hierarchy_header = 'HIERARCHY',
      parameter_header = 'MOVE_CLASSES Parameters ',
      mass_storage_class_header = 'MASS_STORAGE_CLASSES',
      megabytes_header = 'MEGABYTES',
      perform_move_header = 'PERFORM_MOVE',
      release_mass_storage_header = 'RELEASE_MASS_STORAGE',
      volume_overflow_allowed_header = 'VOLUME_OVERFLOW_ALLOWED',
      wait_header = 'WAIT',
      first_tab_column = 2,
      header_tab_column = 4,
      value_tab_column = 35;

    VAR
      ch: 'A' .. 'Z',
      current_value_p: ^clt$data_value,
      ec_str: ost$string,
      element_count: integer,
      evaluated_file_reference: fst$evaluated_file_reference,
      fs_path_size: fst$path_size,
      mb_str: ost$string,
      p_fs_path: ^fst$path,
      pos: 0 .. 255,
      str: string (255);

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    {
    { Display parameter header.
    {
    clp$horizontal_tab_display (display_control, first_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, parameter_header, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    {
    { Display CATALOGS parameter.
    {
    clp$horizontal_tab_display (display_control, header_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, catalogs_header, clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, value_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF catalog_parameter.specified THEN
      clp$convert_integer_to_string (clp$count_list_elements (catalog_parameter.value), {radix} 10,
            {include_radix} FALSE, ec_str, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      str (1, 8) := 'List of ';
      str (9, ec_str.size) := ec_str.value (1, ec_str.size);
      str (ec_str.size + 9, 19) := ' Catalogs Specified';
      clp$put_partial_display (display_control, str (1, ec_str.size + 27), clc$trim, amc$terminate, status);
    ELSE
      clp$put_partial_display (display_control, 'UNSPECIFIED', clc$trim, amc$terminate, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    {
    { Display FILES parameter.
    {
    clp$horizontal_tab_display (display_control, header_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, files_header, clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, value_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF file_parameter.specified THEN
      clp$convert_integer_to_string (clp$count_list_elements (file_parameter.value), {radix} 10,
            {include_radix} FALSE, ec_str, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      str (1, 8) := 'List of ';
      str (9, ec_str.size) := ec_str.value (1, ec_str.size);
      str (ec_str.size + 9, 16) := ' Files Specified';
      clp$put_partial_display (display_control, str (1, ec_str.size + 24), clc$trim, amc$terminate, status);
    ELSE
      clp$put_partial_display (display_control, 'UNSPECIFIED', clc$trim, amc$terminate, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    {
    { Display SOURCE_VOLUMES parameter.
    {
    clp$horizontal_tab_display (display_control, header_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, source_volumes_header, clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_volume_list_parameter (source_vol_parameter, value_tab_column, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    {
    { Display DESTINATION_VOLUMES parameter.
    {
    clp$horizontal_tab_display (display_control, header_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, destination_volumes_header, clc$no_trim, amc$continue,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_volume_list_parameter (dest_vol_parameter, value_tab_column, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    {
    { Display HIERARCHY parameter.
    {
    clp$horizontal_tab_display (display_control, header_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, hierarchy_header, clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, value_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF hierarchy_parameter.specified THEN
      IF hierarchy_parameter.value^.kind = clc$keyword THEN
        clp$put_partial_display (display_control, 'SET', clc$trim, amc$terminate, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        fsp$evaluate_file_reference (hierarchy_parameter.value^.file_value^, FALSE
              {NOT command_file_reference_allowed} , evaluated_file_reference, status);
        IF NOT status.normal THEN
          RETURN
        IFEND;
        PUSH p_fs_path;

        clp$convert_file_ref_to_string (evaluated_file_reference, FALSE, p_fs_path^, fs_path_size, status);
        IF NOT status.normal THEN
          RETURN
        IFEND;

        display_path (p_fs_path^, fs_path_size, value_tab_column, display_control.page_width,
              display_control, status);
      IFEND;
    ELSE
      clp$put_partial_display (display_control, 'UNSPECIFIED', clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    {
    { Display MASS_STORAGE_CLASSES parameter.
    {
    clp$horizontal_tab_display (display_control, header_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, mass_storage_class_header, clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, value_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF move_object_info.mass_storage_class <> $dmt$class [] THEN
      str := '[';
      pos := 2;
      FOR ch := 'A' TO 'Z' DO
        IF ch IN move_object_info.mass_storage_class THEN
          str (pos) := ch;
          str (pos + 1) := ',';
          pos := pos + 2;
        IFEND;
      FOREND;
      pos := pos - 1;
      str (pos) := ']';
    IFEND;

    clp$put_partial_display (display_control, str (1, pos), clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    {
    { Display MEGABYTES parameter.
    {
    clp$horizontal_tab_display (display_control, header_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, megabytes_header, clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, value_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF move_object_info.move_bytes_threshold > 0 THEN

      clp$convert_integer_to_string (megabytes_parameter.value^.integer_value.value, {radix} 10,
            {include_radix} FALSE, mb_str, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, mb_str.value (1, mb_str.size), clc$no_trim, amc$continue,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, ' (', clc$no_trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$convert_integer_to_string (move_object_info.move_bytes_threshold, {radix} 10,
            {include_radix} FALSE, mb_str, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, mb_str.value (1, mb_str.size), clc$no_trim, amc$continue,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, ' BYTES)', clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      clp$put_partial_display (display_control, 'UNSPECIFIED', clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    {
    { Display PERFORM_MOVE parameter.
    {
    clp$horizontal_tab_display (display_control, header_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, perform_move_header, clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, value_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF move_object_info.perform_move THEN
      clp$put_partial_display (display_control, 'TRUE', clc$trim, amc$terminate, status);
    ELSE
      clp$put_partial_display (display_control, 'FALSE', clc$trim, amc$terminate, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    {
    { Display RELEASE_MASS_STORAGE parameter.
    {
    clp$horizontal_tab_display (display_control, header_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, release_mass_storage_header, clc$no_trim, amc$continue,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, value_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE move_object_info.release_mass_storage OF
    = pfc$always =
      clp$put_partial_display (display_control, 'TRUE', clc$trim, amc$terminate, status);
    = pfc$never =
      clp$put_partial_display (display_control, 'FALSE', clc$trim, amc$terminate, status);
    = pfc$when_insufficient_space =
      clp$put_partial_display (display_control, 'WHEN_SPACE_UNAVAILABLE', clc$trim, amc$terminate, status);
    CASEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    {
    { Display VOLUME_OVERFLOW_ALLOWED parameter.
    {
    clp$horizontal_tab_display (display_control, header_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, volume_overflow_allowed_header, clc$no_trim, amc$continue,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, value_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF move_object_info.volume_overflow_allowed THEN
      clp$put_partial_display (display_control, 'TRUE', clc$trim, amc$terminate, status);
    ELSE
      clp$put_partial_display (display_control, 'FALSE', clc$trim, amc$terminate, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    {
    { Display WAIT parameter.
    {
    clp$horizontal_tab_display (display_control, header_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, wait_header, clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, value_tab_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF move_object_info.wait THEN
      clp$put_partial_display (display_control, 'TRUE', clc$trim, amc$terminate, status);
    ELSE
      clp$put_partial_display (display_control, 'FALSE', clc$trim, amc$terminate, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_parameters;

?? OLDTITLE ??
?? NEWTITLE := 'display_path', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to display a path to the output file.
{

  PROCEDURE display_path
    (VAR fs_path: fst$path;
         fs_path_size: fst$path_size;
         left_column: amt$page_width;
         right_column: amt$page_width;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      chunk_count: 0 .. fsc$max_path_elements,
      display_chunks: clt$path_display_chunks,
      i: 0 .. fsc$max_path_elements,
      terminate_string: string (2);

    clp$build_path_subtitle (fs_path, fs_path_size, right_column - left_column, chunk_count, display_chunks);

    terminate_string := '..';
    FOR i := 1 TO chunk_count DO
      clp$horizontal_tab_display (display_control, left_column, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, fs_path (display_chunks [i].position,
            display_chunks [i].length), clc$trim, amc$continue, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF i = chunk_count THEN
        terminate_string := '  ';
      IFEND;

      clp$put_partial_display (display_control, terminate_string, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND display_path;

?? OLDTITLE ??
?? NEWTITLE := 'display_performance_statistics', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to calculate performance statistics and
{   display them to the output file.
{

  PROCEDURE display_performance_statistics
    (    performance_statistics: pft$performance_statistics;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    CONST
      cp_time_column = integer_value_tab - 5,
      date_time_column = integer_value_tab - 13,
      seconds_str = '(seconds)',
      seconds_tab = integer_value_tab + 11;

    VAR
      elapsed_cp_time: real,
      elapsed_time: integer,
      final_date_time: ost$date_time,
      final_microsecond_clock: integer,
      final_task_cp_time: pmt$task_cp_time,
      os_str: ost$string,
      str_int: string (10),
      str_len: integer,
      str_real: string (15);

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, 'Performance Statistics', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Catalog Count: ', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (performance_statistics.catalog_count, {radix} 10, {include_radix} FALSE,
          ' ', str_int, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str_int, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'File Count: ', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (performance_statistics.file_count, {radix} 10, {include_radix} FALSE,
          ' ', str_int, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str_int, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Cycle Count: ', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (performance_statistics.cycle_count, {radix} 10, {include_radix} FALSE,
          ' ', str_int, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str_int, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_compact_date_time (final_date_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_microsecond_clock (final_microsecond_clock, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_task_cp_time (final_task_cp_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Initial Date Time: ', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, date_time_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    convert_date_time (performance_statistics.initial_date_time, os_str);

    clp$put_partial_display (display_control, os_str.value (1, os_str.size), clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Final Date Time: ', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, date_time_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    convert_date_time (final_date_time, os_str);

    clp$put_partial_display (display_control, os_str.value (1, os_str.size), clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    elapsed_time := (final_microsecond_clock -
          performance_statistics.initial_microsecond_clock) DIV 1000000;
    STRINGREP (str_int, str_len, elapsed_time:10);

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Elapsed Time: ', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str_int, clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, seconds_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, seconds_str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    elapsed_cp_time := $real(final_task_cp_time.monitor_time -
          performance_statistics.initial_task_cp_time.monitor_time) / 1000000.0;
    STRINGREP (str_real, str_len, elapsed_cp_time: 15: 6);

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Monitor CP Time: ', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, cp_time_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str_real, clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, seconds_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, seconds_str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    elapsed_cp_time := $real(final_task_cp_time.task_time -
          performance_statistics.initial_task_cp_time.task_time) / 1000000.0;
    STRINGREP (str_real, str_len, elapsed_cp_time: 15: 6);

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Job CP Time: ', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, cp_time_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str_real, clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, seconds_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, seconds_str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_performance_statistics;

?? OLDTITLE ??
?? NEWTITLE := 'display_summary', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to display summary information to the
{   output file after the move is completed.
{

  PROCEDURE display_summary
    (    move_object_info: pft$move_object_info;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      str: string (12);

    display_overall_summary (move_object_info, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_class_summary (move_object_info, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_volume_summary (move_object_info, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_performance_statistics (move_object_info.performance_statistics, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_summary;


?? OLDTITLE ??
?? NEWTITLE := 'display_volume', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to display movement statistics for each
{   affected volume to the output file.
{

  PROCEDURE display_volume
    (    move_object_info: pft$move_object_info;
         volume_index: integer;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      str: string (12),
      volume: pft$mo_volume;

    volume := move_object_info.set_volume_list_p^ [volume_index];

    IF NOT volume.available THEN
      clp$put_display (display_control, ' ', clc$trim, status);
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, title_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Volume: ', clc$no_trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, volume.recorded_vsn, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Bytes Moved To:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (volume.bytes_moved_to, {radix} 10, {include_radix} FALSE, ' ', str,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Catalogs Moved To:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (volume.catalogs_moved_to, {radix} 10, {include_radix} FALSE, ' ', str,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Cycles Moved To:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (volume.cycles_moved_to, {radix} 10, {include_radix} FALSE, ' ', str,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Bytes Moved From:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (volume.bytes_moved_from, {radix} 10, {include_radix} FALSE, ' ', str,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Catalogs Moved From:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (volume.catalogs_moved_from, {radix} 10, {include_radix} FALSE, ' ', str,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Cycles Moved From:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (volume.cycles_moved_from, {radix} 10, {include_radix} FALSE, ' ', str,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Bytes Released:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (volume.bytes_released, {radix} 10, {include_radix} FALSE, ' ', str,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Cycles Released:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (volume.cycles_released, {radix} 10, {include_radix} FALSE, ' ', str,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Mass Storage Available Before:', clc$trim, amc$continue,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (volume.mass_storage_before, {radix} 10, {include_radix} FALSE, ' ',
          str, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Mass Storage Available After:', clc$trim, amc$continue,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (volume.mass_storage_available, {radix} 10, {include_radix} FALSE, ' ',
          str, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, header_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, 'Mass Storage Capacity:', clc$trim, amc$continue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$horizontal_tab_display (display_control, integer_value_tab, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (volume.mass_storage_capacity, {radix} 10, {include_radix} FALSE,
          ' ', str, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_partial_display (display_control, str, clc$trim, amc$terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_volume;

?? OLDTITLE ??
?? NEWTITLE := 'display_volume_list_parameter', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to display the list of volumes specified
{   by the source and destination volume list parameters to the output file.
{

  PROCEDURE display_volume_list_parameter
    (    volume_list_parameter: clt$parameter_value;
         left_column: amt$page_width;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      current_value_p: ^clt$data_value,
      max_str_length: 0 .. 255,
      pos: 0 .. 255,
      str: string (255);


    clp$horizontal_tab_display (display_control, left_column, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF volume_list_parameter.specified THEN
      max_str_length := display_control.page_width - left_column;
      str := '(';
      pos := 2;
      current_value_p := volume_list_parameter.value;
      WHILE (current_value_p <> NIL) AND (current_value_p^.element_value <> NIL) DO
        IF (pos + 7) < max_str_length THEN
          str (pos, 6) := current_value_p^.element_value^.name_value (1, 6);
          str (pos + 6, 1) := ' ';
          pos := pos + 7;
        ELSE
          str (pos, 2) := '..';
          pos := pos + 1;
          clp$put_partial_display (display_control, str (1, pos), clc$trim, amc$terminate, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          clp$horizontal_tab_display (display_control, left_column, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          str (1, 6) := current_value_p^.element_value^.name_value (1, 6);
          str (7) := ' ';
          pos := 8;
        IFEND;
        current_value_p := current_value_p^.link;
      WHILEND;

      pos := pos - 1;
      str (pos, 1) := ')';
      clp$put_partial_display (display_control, str (1, pos), clc$trim, amc$terminate, status);
    ELSE
      clp$put_partial_display (display_control, 'UNSPECIFIED', clc$trim, amc$terminate, status);
    IFEND;

  PROCEND display_volume_list_parameter;

?? OLDTITLE ??
?? NEWTITLE := 'display_volume_summary', EJECT ??

  PROCEDURE display_volume_summary
    (    move_object_info: pft$move_object_info;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      class: char,
      class_str: string (1),
      unspecified_volume_count: ost$non_negative_integers,
      volume_index: ost$positive_integers;

    IF move_object_info.perform_move THEN
      dmp$utility_flush_logs_r3;
      pfp$r3_get_move_obj_device_info (^move_object_info, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, 'Source Volumes', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    unspecified_volume_count := 0;

    FOR volume_index := 1 TO UPPERBOUND (move_object_info.set_volume_list_p^) DO
      IF move_object_info.set_volume_list_p^ [volume_index].volume_type = pfc$source_volume THEN
        display_volume (move_object_info, volume_index, display_control, status);
      ELSEIF move_object_info.set_volume_list_p^ [volume_index].volume_type = pfc$unspecified_volume THEN
        unspecified_volume_count := unspecified_volume_count + 1;
      IFEND;
    FOREND;

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, 'Destination Volumes', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR volume_index := 1 TO UPPERBOUND (move_object_info.set_volume_list_p^) DO
      IF move_object_info.set_volume_list_p^ [volume_index].volume_type = pfc$destination_volume THEN
        display_volume (move_object_info, volume_index, display_control, status);
      IFEND;
    FOREND;

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF unspecified_volume_count > 0 THEN
      clp$put_display (display_control, 'Other Volumes', clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_display (display_control, ' ', clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      FOR volume_index := 1 TO UPPERBOUND (move_object_info.set_volume_list_p^) DO
        IF move_object_info.set_volume_list_p^ [volume_index].volume_type = pfc$unspecified_volume THEN
          display_volume (move_object_info, volume_index, display_control, status);
        IFEND;
      FOREND;
    IFEND;

  PROCEND display_volume_summary;

?? OLDTITLE ??
?? NEWTITLE := 'initialize_set_volume_list', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to initialize information in the
{   SET_VOLUME_LIST which is contained in the MOVE_OBJECT_INFO structure.
{

  PROCEDURE initialize_set_volume_list
    (    set_volume_list_p: ^pft$mo_volume_list;
     VAR status: ost$status);

    VAR
      element_status: iot$unit_status,
      found: boolean,
      i: integer,
      j: integer,
      ms_volume_count: integer,
      ms_volumes_p: ^array [ * ] of cmt$mass_storage_volume,
      state: cmt$element_state;

    status.normal := TRUE;

    IF set_volume_list_p = NIL THEN
      RETURN;
    IFEND;

    { Obtain the class membership of each volume in the configuration which is ON and ENABLED.

    cmp$get_ms_volumes (ms_volume_count);
    PUSH ms_volumes_p: [1 .. ms_volume_count];
    cmp$get_ms_volume_info (ms_volumes_p);

  /process_volume/
    FOR i := 1 TO UPPERBOUND (set_volume_list_p^) DO
      found := FALSE;

      set_volume_list_p^ [i].available := FALSE;
      set_volume_list_p^ [i].bytes_moved_from := 0;
      set_volume_list_p^ [i].bytes_moved_to := 0;
      set_volume_list_p^ [i].bytes_released := 0;
      set_volume_list_p^ [i].catalogs_moved_from := 0;
      set_volume_list_p^ [i].catalogs_moved_to := 0;
      set_volume_list_p^ [i].cycles_moved_from := 0;
      set_volume_list_p^ [i].cycles_moved_to := 0;
      set_volume_list_p^ [i].cycles_released := 0;
      set_volume_list_p^ [i].logical_unit_number := 0;
      set_volume_list_p^ [i].mass_storage_available := 0;
      set_volume_list_p^ [i].mass_storage_before := 0;
      set_volume_list_p^ [i].mass_storage_capacity := 0;
      set_volume_list_p^ [i].move_bytes_threshold_exceeded := FALSE;
      set_volume_list_p^ [i].ms_class := $dmt$class [ ];
      set_volume_list_p^ [i].volume_type := pfc$unspecified_volume;

    /locate_volume/
      FOR j := 1 TO ms_volume_count DO
        IF set_volume_list_p^ [i].recorded_vsn = ms_volumes_p^ [j].recorded_vsn THEN
          found := TRUE;
          EXIT /locate_volume/;
        IFEND;
      FOREND /locate_volume/;

      IF NOT found THEN
        CYCLE /process_volume/;
      IFEND;

      cmp$get_element_state_via_lun (ms_volumes_p^ [j].lun, state);
      IF state <> cmc$on THEN
        CYCLE /process_volume/;
      IFEND;

      cmp$get_ms_status_via_lun (ms_volumes_p^ [j].lun, element_status);
      IF element_status.disabled THEN
        CYCLE /process_volume/;
      IFEND;

      set_volume_list_p^ [i].available := TRUE;
      set_volume_list_p^ [i].logical_unit_number := ms_volumes_p^ [j].lun;
      set_volume_list_p^ [i].ms_class := ms_volumes_p^ [j].class;

    FOREND /process_volume/;

  PROCEND initialize_set_volume_list;

?? OLDTITLE ??
?? NEWTITLE := 'move_catalog', EJECT ??
{ PURPOSE
{   This procedure attempts to move a specified catalog and it's contents.
{   PFP$R3_GET_OBJECT_INFORMATION is called to obtain a list of all objects
{   in the catalog.  If the catalog itself is to be moved,
{   PFP$R3_PHYSICALLY_MOVE_CATALOG is called to move it.  MOVE_FILE is then
{   called to move all cycles of each file contained in the catalog that are to be
{   be moved.  After moving all cycles in the catalog, MOVE_CATALOG calls
{   itself recursively to move each subcatalog contained in the catalog.

  PROCEDURE move_catalog
    (    path: pft$path;
         object_info_p: ^SEQ ( * );
         move_object_info_p: ^pft$move_object_info;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      catalog_object_entry_p: ^fst$goi_object,
      catalog_object_info_p: ^fst$goi_object_information,
      catalog_reference: fst$path,
      current_catalog_index: pft$catalog_path_index,
      current_object_info_p: ^SEQ ( * ),
      evaluated_file_reference: fst$evaluated_file_reference,
      fs_path_size: fst$path_size,
      ignore_status: ost$status,
      length: integer,
      line: string (255),
      local_status: ost$status,
      move_object: boolean,
      object_index: integer,
      object_list_p: ^fst$goi_object_list,
      object_path: ^pft$path,
      p_fs_path: ^fst$path,
      path_index: pft$catalog_path_index,
      unused_sequence_p: ^SEQ ( * );

    current_catalog_index := UPPERBOUND (path);
    PUSH object_path: [1 .. current_catalog_index + 1];
    FOR path_index := 1 TO current_catalog_index DO
      object_path^ [path_index] := path [path_index];
    FOREND;

    fsp$build_file_ref_from_elems (^path, catalog_reference, status);
    IF NOT status.normal THEN
      display_abnormal_status (status, display_control, local_status);
      RETURN;
    IFEND;

    current_object_info_p := object_info_p;

    clp$evaluate_file_reference (catalog_reference,
          $clt$file_ref_parsing_options [clc$command_file_ref_allowed], {resolve_cycle_number} FALSE,
          evaluated_file_reference, status);
    IF NOT status.normal THEN
      display_abnormal_status (status, display_control, local_status);
      RETURN;
    IFEND;

    pfp$r3_get_object_information (evaluated_file_reference, catalog_information_request,
          {validation_criteria} NIL, current_object_info_p, status);
    IF NOT status.normal THEN
      display_abnormal_status (status, display_control, local_status);
      RETURN;
    IFEND;

    {
    { Create an adaptable sequence pointer that defines the unused portion of the sequence.
    { PFP$R3_GET_OBJECT_INFORMATION leaves the sequence pointer at the next available byte in the sequence.
    {
    NEXT unused_sequence_p: [[REP #SIZE (current_object_info_p^) -
          i#current_sequence_position (current_object_info_p) OF cell]] IN current_object_info_p;
    RESET unused_sequence_p;

    {
    { Retrieve the object and object_list for the current catalog.
    {
    RESET current_object_info_p;
    NEXT catalog_object_info_p IN current_object_info_p;

    { Verify whether the catalog_object_info_p pointer or the object pointer
    { inside is NIL and if so return with an error message.

    IF catalog_object_info_p = NIL THEN
      PUSH p_fs_path;
      clp$convert_file_ref_to_string (evaluated_file_reference, FALSE, p_fs_path^, fs_path_size,
            local_status);
      IF local_status.normal THEN
        STRINGREP (line, length, 'MOVE_CATALOG - NIL pointer returned for catalog ',
              p_fs_path^ (1, fs_path_size), '- possibly an empty and/or attached master catalog');
        pmp$log_ascii (line (1, length), $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system,
              ignore_status);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'NIL Pointer returned by MOVE_CATALOG.  See job log for details.', status);
      IFEND;
      RETURN;
    IFEND;

    IF catalog_object_info_p^.object = NIL THEN
      PUSH p_fs_path;
      clp$convert_file_ref_to_string (evaluated_file_reference, FALSE, p_fs_path^, fs_path_size,
            local_status);
      IF local_status.normal THEN
        STRINGREP (line, length, 'MOVE_CATALOG - NIL pointer returned for object in the catalog ',
              p_fs_path^ (1, fs_path_size), '- possibly an empty and/or attached master catalog');
        pmp$log_ascii (line (1, length), $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system,
              ignore_status);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'NIL Pointer returned by MOVE_CATALOG.  See job log for details.', status);
      IFEND;
      RETURN;
    IFEND;

    IF catalog_object_info_p^.object^.object_type <> fsc$goi_catalog_object THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$nth_name_not_subcatalog,
            catalog_object_info_p^.resolved_path^, status);
      display_abnormal_status (status, display_control, local_status);
      RETURN;
    IFEND;

    catalog_object_entry_p := catalog_object_info_p^.object;
    object_list_p := catalog_object_entry_p^.subcatalog_and_file_object_list;
    move_object_info_p^.performance_statistics.catalog_count :=
           move_object_info_p^.performance_statistics.catalog_count + 1;

    validate_object_move (catalog_object_entry_p, move_object_info_p, move_object);

    IF move_object THEN
      pfp$r3_physically_move_catalog (path, move_object_info_p, local_status);
      IF move_object_info_p^.move_status.move_successful THEN
        display_catalog_move (path, move_object_info_p^, display_control, local_status);
      ELSE
        IF move_object_info_p^.move_status.reason_for_move_failure = pfc$set_threshold_exceeded THEN
          RETURN;
        ELSEIF move_object_info_p^.move_status.reason_for_move_failure = pfc$operator_terminate THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_operator_termination, '',
                local_status);
          display_catalog_move (path, move_object_info_p^, display_control, local_status);
          RETURN;
        ELSEIF move_object_info_p^.move_bytes_threshold > 0 THEN
          IF (move_object_info_p^.move_status.reason_for_move_failure = pfc$no_available_space) AND
                pfp$no_space_movc_dest_volumes (move_object_info_p) THEN
            RETURN;
          IFEND;
        ELSE
          display_catalog_move (path, move_object_info_p^, display_control, local_status);
        IFEND;
      IFEND;
    IFEND;

    IF object_list_p = NIL THEN
      RETURN;
    IFEND;

    {
    { Process all files in the current catalog.
    {
    FOR object_index := LOWERBOUND (object_list_p^) TO UPPERBOUND (object_list_p^) DO
      IF object_list_p^ [object_index].object_type = fsc$goi_file_object THEN
        object_path^ [current_catalog_index + 1] := object_list_p^ [object_index].file_name;

        move_file (object_path^, ^object_list_p^ [object_index], move_object_info_p, display_control);
        IF (NOT move_object_info_p^.move_status.move_successful) AND
              ((move_object_info_p^.move_status.reason_for_move_failure = pfc$set_threshold_exceeded) OR
              (move_object_info_p^.move_status.reason_for_move_failure = pfc$operator_terminate) OR
              ((move_object_info_p^.move_bytes_threshold > 0) AND
              (move_object_info_p^.move_status.reason_for_move_failure = pfc$no_available_space) AND
              pfp$no_space_movc_dest_volumes (move_object_info_p))) THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    {
    { Process all catalogs in the current catalog.
    { A recursive call to MOVE_CATALOG is used to traverse the entire catalog structure.
    {
    FOR object_index := LOWERBOUND (object_list_p^) TO UPPERBOUND (object_list_p^) DO
      IF object_list_p^ [object_index].object_type = fsc$goi_catalog_object THEN
        object_path^ [current_catalog_index + 1] := object_list_p^ [object_index].catalog_name;
        move_catalog (object_path^, unused_sequence_p, move_object_info_p, display_control, ignore_status);
        IF (NOT move_object_info_p^.move_status.move_successful) AND
              ((move_object_info_p^.move_status.reason_for_move_failure = pfc$set_threshold_exceeded) OR
              (move_object_info_p^.move_status.reason_for_move_failure = pfc$operator_terminate) OR
              ((move_object_info_p^.move_bytes_threshold > 0) AND
              (move_object_info_p^.move_status.reason_for_move_failure = pfc$no_available_space) AND
              pfp$no_space_movc_dest_volumes (move_object_info_p))) THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND move_catalog;

?? OLDTITLE ??
?? NEWTITLE := 'move_file', EJECT ??

{ PURPOSE
{   This procedure examines each cycle of the specified file to select the
{   cycles that are candidates to be moved.  PFP$R3_PHYSICALLY_MOVE_CYCLE is
{   then called to move the selected cycles.

  PROCEDURE move_file
    (    path: pft$path;
         file_object_p: ^fst$goi_object;
         move_object_info_p: ^pft$move_object_info;
     VAR display_control: clt$display_control);

    VAR
      cycle_array_p: ^fst$goi_object_list,
      cycle_number: pft$cycle_number,
      cycle_object_p: ^fst$goi_object,
      cycle_selector: pft$cycle_selector,
      i: integer,
      local_status: ost$status,
      move_object: boolean;

    move_object_info_p^.performance_statistics.file_count :=
          move_object_info_p^.performance_statistics.file_count + 1;
    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_array_p := file_object_p^.cycle_object_list;

  /move_cycles/
    FOR i := 1 TO UPPERBOUND (cycle_array_p^) DO
      cycle_object_p := ^cycle_array_p^ [i];
      cycle_selector.cycle_number := cycle_object_p^.cycle_number;
      validate_object_move (cycle_object_p, move_object_info_p, move_object);
      move_object_info_p^.performance_statistics.cycle_count :=
            move_object_info_p^.performance_statistics.cycle_count + 1;
      IF move_object THEN
        pfp$r3_physically_move_cycle (path, cycle_selector, move_object_info_p, cycle_number, local_status);
        IF NOT move_object_info_p^.move_status.move_successful THEN
          IF move_object_info_p^.move_status.reason_for_move_failure = pfc$set_threshold_exceeded THEN
            RETURN;
          ELSEIF move_object_info_p^.move_status.reason_for_move_failure = pfc$operator_terminate THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_operator_termination, '',
                  local_status);
            display_cycle_move (path, move_object_info_p^, ^cycle_number, display_control, local_status);
            RETURN;
          ELSEIF move_object_info_p^.move_bytes_threshold > 0 THEN
            IF (move_object_info_p^.move_status.reason_for_move_failure = pfc$no_available_space) AND
                  pfp$no_space_movc_dest_volumes (move_object_info_p) THEN
              RETURN;
            ELSE
              CYCLE /move_cycles/
            IFEND;
          IFEND;
        IFEND;
        display_cycle_move (path, move_object_info_p^, ^cycle_number, display_control, local_status);
      IFEND;
    FOREND /move_cycles/;

  PROCEND move_file;

?? OLDTITLE ??
?? NEWTITLE := 'move_hierarchy', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to begin a catalog traversal at the catalog
{   specified by the HIERARCHY parameter.  An attempt is made to move all
{   objects encountered in the traversal that meet the selection criteria of the
{   MOVE_CLASSES command parameters.
{

  PROCEDURE move_hierarchy
    (    path: pft$path;
         move_object_info_p: ^pft$move_object_info;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      object_info_p: ^SEQ ( * ),
      object_segment_pointer: amt$segment_pointer;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, object_segment_pointer, status);
    IF NOT status.normal THEN
      display_abnormal_status (status, display_control, local_status);
      RETURN;
    IFEND;

    RESET object_segment_pointer.sequence_pointer;
    object_info_p := object_segment_pointer.sequence_pointer;

    move_catalog (path, object_info_p, move_object_info_p, display_control, status);

    mmp$delete_scratch_segment (object_segment_pointer, status);
    IF NOT status.normal THEN
      display_abnormal_status (status, display_control, local_status);
      RETURN;
    IFEND;

  PROCEND move_hierarchy;

?? OLDTITLE ??
?? NEWTITLE := 'move_set', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to begin a catalog traversal at the root
{   catalog.  An attempt is made to move all objects encountered in the
{   traversal that meet the selection criteria of the MOVE_CLASSES command
{   parameters.
{

  PROCEDURE move_set
    (    move_object_info_p: ^pft$move_object_info;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      family_catalog_object_p: ^fst$goi_object,
      family_catalog_path: array [1 .. 1] of pft$name,
      family_catalog_reference: fst$path,
      family_list_p: ^array [1 .. * ] of ost$name,
      family_object_info_p: ^fst$goi_object_information,
      i: 0 .. 255,
      ignore_status: ost$status,
      local_status: ost$status,
      login_family_in_set: boolean,
      master_catalog_path: array [1 .. 2] of pft$name,
      move_object: boolean,
      number_of_families: 0 .. 255,
      object_index: integer,
      object_info_p: ^SEQ ( * ),
      object_list_p: ^fst$goi_object_list,
      object_segment_pointer: amt$segment_pointer,
      unused_sequence_p: ^SEQ ( * );

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, object_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET object_segment_pointer.sequence_pointer;
    object_info_p := object_segment_pointer.sequence_pointer;

    number_of_families := 3;
    REPEAT
      PUSH family_list_p: [1 .. number_of_families];
      pfp$get_families_in_set (move_object_info_p^.set_name, family_list_p^, number_of_families, status);
    UNTIL (NOT status.normal) OR (UPPERBOUND (family_list_p^) >= number_of_families);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (avp$family_administrator ()) AND (NOT avp$system_administrator ()) THEN
      login_family_in_set := FALSE;
    /check_families/
      FOR i := 1 TO number_of_families DO
        IF family_list_p^ [i] =
              clv$user_identification.family.value (1, clv$user_identification.family.size) THEN
          login_family_in_set := TRUE;
          EXIT /check_families/;
        IFEND;
      FOREND /check_families/;
      IF NOT login_family_in_set THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_family_not_in_set,
              clv$user_identification.family.value (1, clv$user_identification.family.size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, move_object_info_p^.set_name,
              status);
        RETURN;
      IFEND;
    IFEND;

  /process_family/
    FOR i := 1 TO number_of_families DO
      family_catalog_reference := ':';
      family_catalog_reference (2, * ) := family_list_p^ [i];

      IF (avp$family_administrator ()) AND (NOT avp$system_administrator ()) THEN
        IF family_list_p^ [i] <>
              clv$user_identification.family.value (1, clv$user_identification.family.size) THEN
          CYCLE /process_family/;
        IFEND;
      IFEND;

      { Reset the object info scratch segment to the beginning when starting on a new family.

      RESET object_info_p;

      clp$evaluate_file_reference (family_catalog_reference,
            $clt$file_ref_parsing_options [clc$command_file_ref_allowed], {resolve_cycle_number} FALSE,
            evaluated_file_reference, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pfp$r3_get_object_information (evaluated_file_reference, catalog_information_request,
            {validation_criteria} NIL, object_info_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      {
      { Create an adaptable sequence pointer that defines the unused portion of the sequence.
      { PFP$R3_GET_OBJECT_INFORMATION leaves the sequence pointer at the next available byte in the sequence.
      {
      NEXT unused_sequence_p: [[REP #SIZE (object_info_p^) - i#current_sequence_position (object_info_p) OF
            cell]] IN object_info_p;
      RESET unused_sequence_p;

      { Retrieve the master catalog array from the family object info.

      RESET object_info_p;
      NEXT family_object_info_p IN object_info_p;
      family_catalog_object_p := family_object_info_p^.object;
      object_list_p := family_catalog_object_p^.subcatalog_and_file_object_list;

      move_object_info_p^.performance_statistics.catalog_count :=
             move_object_info_p^.performance_statistics.catalog_count + 1;
      validate_object_move (family_catalog_object_p, move_object_info_p, move_object);
      IF move_object THEN
        family_catalog_path [1] := family_list_p^ [i];
        pfp$r3_physically_move_catalog (family_catalog_path, move_object_info_p, local_status);
        IF move_object_info_p^.move_status.move_successful THEN
          display_catalog_move (family_catalog_path, move_object_info_p^, display_control, local_status);
        ELSE
          IF move_object_info_p^.move_status.reason_for_move_failure = pfc$set_threshold_exceeded THEN
            RETURN;
          ELSEIF move_object_info_p^.move_status.reason_for_move_failure = pfc$operator_terminate THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_operator_termination, '',
                  local_status);
            display_catalog_move (family_catalog_path, move_object_info_p^, display_control, local_status);
            RETURN;
          ELSEIF move_object_info_p^.move_bytes_threshold > 0 THEN
            IF  (move_object_info_p^.move_status.reason_for_move_failure = pfc$no_available_space) AND
                  pfp$no_space_movc_dest_volumes (move_object_info_p) THEN
              RETURN;
            IFEND;
          ELSE
            display_catalog_move (family_catalog_path, move_object_info_p^, display_control, local_status);
          IFEND;
        IFEND;
      IFEND;

      IF object_list_p = NIL THEN
        RETURN;
      IFEND;

    /process_master_catalog/
      FOR object_index := LOWERBOUND (object_list_p^) TO UPPERBOUND (object_list_p^) DO
        master_catalog_path [1] := family_list_p^ [i];
        master_catalog_path [2] := object_list_p^ [object_index].catalog_name;

        move_catalog (master_catalog_path, unused_sequence_p, move_object_info_p, display_control,
              ignore_status);
        IF (NOT move_object_info_p^.move_status.move_successful) AND
              ((move_object_info_p^.move_status.reason_for_move_failure = pfc$set_threshold_exceeded) OR
              (move_object_info_p^.move_status.reason_for_move_failure = pfc$operator_terminate) OR
              ((move_object_info_p^.move_bytes_threshold > 0) AND
              (move_object_info_p^.move_status.reason_for_move_failure = pfc$no_available_space) AND
              pfp$no_space_movc_dest_volumes (move_object_info_p))) THEN
          EXIT /process_family/;
        IFEND;
      FOREND /process_master_catalog/;
    FOREND /process_family/;

    mmp$delete_scratch_segment (object_segment_pointer, ignore_status);

  PROCEND move_set;

?? OLDTITLE ??
?? NEWTITLE := 'validate_mass_storage_class', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to validate the classes specified by the
{   MASS_STORAGE_CLASSES parameter.

  PROCEDURE validate_mass_storage_class
    (    move_object_info_p: ^pft$move_object_info;
         traverse_set: boolean;
     VAR status: ost$status);

    VAR
      ch: 'A' .. 'Z',
      ch_str: string (52),
      temp_class: dmt$class,
      ms_class_sum: dmt$class,
      pos: 0 .. 255,
      i: integer;

    status.normal := TRUE;

    IF (move_object_info_p^.source_volume_list_p <> NIL) AND
          (move_object_info_p^.move_bytes_threshold = 0) AND traverse_set AND
          (move_object_info_p^.perform_move) THEN
      ms_class_sum := $dmt$class [];
      FOR i := 1 TO UPPERBOUND (move_object_info_p^.source_volume_list_p^) DO
        ms_class_sum := ms_class_sum + move_object_info_p^.source_volume_list_p^ [i]^.ms_class;
      FOREND;

      temp_class := move_object_info_p^.mass_storage_class * ms_class_sum;
      IF temp_class <> $dmt$class [] THEN
        ch_str := '[';
        pos := 2;
        FOR ch := 'A' TO 'Z' DO
          IF ch IN temp_class THEN
            ch_str (pos) := ch;
            ch_str (pos + 1) := ',';
            pos := pos + 2;
          IFEND;
        FOREND;
        pos := pos - 1;
        ch_str (pos) := ']';
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_class_on_source_vol,
              ch_str (1, pos), status);
        RETURN;
      IFEND;
    IFEND;

    IF move_object_info_p^.dest_volume_list_p <> NIL THEN
      IF move_object_info_p^.perform_move THEN
        ms_class_sum := $dmt$class [];
        FOR i := 1 TO UPPERBOUND (move_object_info_p^.dest_volume_list_p^) DO
          ms_class_sum := ms_class_sum + move_object_info_p^.dest_volume_list_p^ [i]^.ms_class;
        FOREND;

        temp_class := move_object_info_p^.mass_storage_class - ms_class_sum;
        IF temp_class <> $dmt$class [] THEN
          ch_str := '[';
          pos := 2;
          FOR ch := 'A' TO 'Z' DO
            IF ch IN temp_class THEN
              ch_str (pos) := ch;
              ch_str (pos + 1) := ',';
              pos := pos + 2;
            IFEND;
          FOREND;
          pos := pos - 1;
          ch_str (pos) := ']';
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_class_on_dest_vol,
                ch_str (1, pos), status);
          RETURN;
        IFEND;
      ELSE
        FOR i := 1 TO UPPERBOUND (move_object_info_p^.dest_volume_list_p^) DO
          move_object_info_p^.dest_volume_list_p^ [i]^.ms_class := move_object_info_p^.mass_storage_class;
        FOREND;
      IFEND;
    IFEND;

  PROCEND validate_mass_storage_class;

?? OLDTITLE ??
?? NEWTITLE := 'validate_object_move', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to verify that the specified object is a
{   valid candidate to be moved.
{

  PROCEDURE validate_object_move
    (    object_p: ^fst$goi_object;
         move_object_info_p: ^pft$move_object_info;
     VAR move_object: boolean);

    VAR
      mass_storage_device_info: fst$mass_storage_device_info,
      object_volume_index: ost$positive_integers,
      source_volume_index: ost$positive_integers;

    move_object := FALSE;

    IF (object_p^.object_type = fsc$goi_catalog_object) AND
          (object_p^.catalog_device_information <> NIL) THEN
       mass_storage_device_info := object_p^.catalog_device_information^.mass_storage_device_info;
    ELSEIF (object_p^.object_type = fsc$goi_cycle_object) AND
           (object_p^.cycle_device_class = rmc$mass_storage_device) AND
           (object_p^.cycle_device_information <> NIL) THEN
      mass_storage_device_info := object_p^.cycle_device_information^.mass_storage_device_info;
    ELSE
      RETURN;
    IFEND;

    IF (NOT mass_storage_device_info.resides_online) OR
          (NOT (mass_storage_device_info.mass_storage_class IN move_object_info_p^.mass_storage_class)) THEN
      RETURN;
    IFEND;

    IF (move_object_info_p^.source_volume_list_p <> NIL) AND
          (mass_storage_device_info.volume_list <> NIL) THEN
    /check_object_volume_list/
      FOR object_volume_index := 1 TO UPPERBOUND (mass_storage_device_info.volume_list^) DO
        FOR source_volume_index := 1 TO UPPERBOUND (move_object_info_p^.source_volume_list_p^) DO
          IF (mass_storage_device_info.volume_list^ [object_volume_index].recorded_vsn =
                move_object_info_p^.source_volume_list_p^ [source_volume_index]^.recorded_vsn) THEN
            move_object := TRUE;
            EXIT /check_object_volume_list/;
          IFEND;
        FOREND;
      FOREND /check_object_volume_list/
    IFEND;

  PROCEND validate_object_move;

MODEND pfm$move_object;
*DECK DECK=PFM$OBJECT_LIST_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Permanent Files : Object List Management' ??
MODULE pfm$object_list_manager;

{ PURPOSE:
{   This module contains the procedures to maintain the object list in a
{   catalog.  This includes:
{       changing the name of an object
{       contracting the object list
{       deleting objects
{       expanding the object list
{       locating objects
{       sorting the object list

?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfk$keypoints
*copyc pft$delete_option
*copyc pft$object_name_list
?? POP ??
?? EJECT ??
*copyc dmp$destroy_permanent_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$file_access_condition
*copyc osp$prevalidate_free
*copyc osp$recoverable_system_error
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osv$system_family_name
*copyc pfp$access_next_catalog
*copyc pfp$build_cycle_list_pointer
*copyc pfp$build_fmd_pointer
*copyc pfp$build_log_list_pointer
*copyc pfp$build_object_list_locator
*copyc pfp$build_permit_list_pointer
*copyc pfp$compute_checksum
*copyc pfp$destroy_catalog
*copyc pfp$detach_unavail_queued_cat
*copyc pfp$log_ascii
*copyc pfp$log_path
*copyc pfp$object_contraction_count
*copyc pfp$object_expansion_size
*copyc pfp$process_unexpected_status
*copyc pfp$release_locked_apfid
*copyc pfp$report_invalid_free
*copyc pfp$report_system_error
*copyc pfp$return_catalog
*copyc pfp$set_status_abnormal
*copyc pfv$binary_catalog_search
*copyc pfv$locked_apfid
*copyc pmp$continue_to_cause
*copyc pmp$get_unique_name

?? TITLE := '  [XDCL] pfp$change_object_name', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to change the name of an object.
{ If the object list is sorted and the object resides in the sorted portion
{ of the object list, the object will be moved to the unsorted portion of the
{ object list and the original object will be converted to a free object.

  PROCEDURE [XDCL] pfp$change_object_name
    (    p_path: ^pft$complete_path;
         new_object_name: pft$name;
         p_catalog_file: {output^} ^pft$catalog_file;
     VAR p_object: {i/o} ^pft$physical_object;
     VAR object_list_descriptor: {i/o} pft$object_list_descriptor;
     VAR status: ost$status);

    VAR
      object_index: pft$object_index,
      original_object_name: pft$name,
      p_found_object: ^pft$physical_object,
      p_free_object: ^pft$physical_object,
      update_catalog: boolean;

    status.normal := TRUE;

  /change_object_name/
    BEGIN
      IF object_list_descriptor.sorted_object_count = 0 THEN
        {
        { Object list is not sorted.
        {
        p_object^.object_entry.external_object_name := new_object_name;
        pfp$compute_checksum (^p_object^.object_entry, #SIZE (pft$object_entry), p_object^.checksum);
      ELSE
        original_object_name := p_object^.object_entry.external_object_name;
        locate_sorted_object (original_object_name, $pft$object_selections
              [pfc$file_object, pfc$catalog_object], object_list_descriptor, p_found_object, object_index);
        IF (p_found_object = NIL) OR (object_index > object_list_descriptor.sorted_object_count) THEN
          {
          { Object located in unsorted portion of sorted object list.
          {
          p_object^.object_entry.external_object_name := new_object_name;
          pfp$compute_checksum (^p_object^.object_entry, #SIZE (pft$object_entry), p_object^.checksum);
        ELSE
          {
          { Object found in sorted portion of sorted object_list.
          {
          pfp$establish_free_object_entry (p_path, p_catalog_file, object_list_descriptor, p_free_object,
                status);
          IF status.normal THEN
            {
            { Must locate the object again.
            { The location of the object in the object list may have changed if the object list
            { was expanded by pfp$establish_free_object_entry.
            {
            locate_sorted_object (original_object_name, $pft$object_selections
                  [pfc$file_object, pfc$catalog_object], object_list_descriptor, p_found_object,
                  object_index);
            IF p_found_object = NIL THEN
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                   'pfp$change_object_name - Unable to locate object.', status);
              EXIT /change_object_name/;
            IFEND;
            p_free_object^ := p_found_object^;
            p_free_object^.object_entry.external_object_name := new_object_name;
            p_object := p_free_object;
            pfp$compute_checksum (^p_free_object^.object_entry, #SIZE (pft$object_entry),
                  p_free_object^.checksum);
            p_found_object^.object_entry.object_type := pfc$free_object;
            pfp$compute_checksum (^p_found_object^.object_entry, #SIZE (pft$object_entry),
                  p_found_object^.checksum);
            object_list_descriptor.free_sorted_object_count :=
                  object_list_descriptor.free_sorted_object_count + 1;
            pfp$update_object_list_locator (p_path, {p_new_object_list} NIL, p_catalog_file,
                  object_list_descriptor);
          IFEND;
        IFEND;
      IFEND;
    END /change_object_name/;
  PROCEND pfp$change_object_name;

?? TITLE := '  [XDCL] pfp$delete_catalog_object', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to delete a catalog object from the
{   specified object list.  If the catalog does not exist, an abnormal status
{   is returned.
{
{ DESIGN:
{   The object list is contracted if necessary.

  PROCEDURE [XDCL] pfp$delete_catalog_object
    (    path: pft$complete_path;
         delete_option: pft$delete_option;
     VAR p_catalog_object: {i^/o^} ^pft$physical_object;
     VAR parent_catalog_locator: {i/o} pft$catalog_locator;
     VAR status: ost$status);

    PROCEDURE delete_catalog_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        variant_path: pft$variant_path,
        status_id: ost$status_identifier,
        local_status: ost$status;

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := ^path;

      IF NOT process_non_local_exit THEN
        pfp$log_ascii ('***PF Condition Handler***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, {critical_message} FALSE, local_status);
        pfp$log_path (variant_path, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
              {critical_message} FALSE, local_status);
      IFEND;

      CASE condition.selector OF
      = pmc$system_conditions, pmc$block_exit_processing, mmc$segment_access_condition =
        IF process_non_local_exit THEN
          RETURN;
        IFEND;

        IF catalog_locator.attached THEN
          catalog_locator.abort_catalog_operation := TRUE;
          pfp$return_catalog (catalog_locator, local_status);
          IF NOT local_status.normal THEN
            pfp$report_system_error (local_status);
          IFEND;
        IFEND;

        osp$set_status_from_condition (status_id, condition, p_sfsa, local_status, handler_status);
        osp$recoverable_system_error ('UNEXPECTED STATUS', ^local_status);

        status := local_status;
        initiate_non_local_exit;


      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
         {syp$invalidate_open_sfid (catalog_locator.system_file_id, local_status);
          initiate_non_local_exit;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND delete_catalog_handler;

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$delete_catalog_object;
    PROCEND initiate_non_local_exit;

    CONST
      critical_message = TRUE;

    VAR
      all_objects_purged: boolean,
      ascii_log_text_length: integer,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      empty_object_list: boolean,
      local_status: ost$status,
      p_ascii_log_text: ^string (7 {lines} * (108 - 21) {max characters/line} ),
      p_permit_list: ^pft$permit_list,
      p_physical_fmd: ^pft$physical_fmd,
      prevalidate_free_result: ost$prevalidate_free_result,
      process_non_local_exit: boolean,
      unique_name: ost$name,
      variant_path: pft$variant_path;


    PROCEDURE [INLINE] test_object_list
      (    p_object_list: {input} ^pft$object_list;
       VAR empty_object_list: boolean;
       VAR all_objects_purged: boolean);

      VAR
        object_index: pft$object_index;

      empty_object_list := TRUE;
      all_objects_purged := TRUE;

      IF p_object_list <> NIL THEN
        FOR object_index := 1 TO UPPERBOUND (p_object_list^) DO
          CASE p_object_list^ [object_index].object_entry.object_type OF
          = pfc$free_object =
            ;

          = pfc$purged_file_object, pfc$purged_catalog_object =
            empty_object_list := FALSE;

          = pfc$file_object, pfc$catalog_object =
            empty_object_list := FALSE;
            all_objects_purged := FALSE;
            RETURN;
          CASEND;
        FOREND;
      IFEND;
    PROCEND test_object_list;

  /delete_catalog_object/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);
      status.normal := TRUE;
      {
      { The parent catalog must have been locked.
      {
      pfp$access_next_catalog (pfc$read_access, parent_catalog_locator, p_catalog_object,
            {catalog_remote} (path [pfc$family_path_index] <> osv$system_family_name),
            catalog_locator, status);
      catalog_active := status.normal;
      osp$establish_condition_handler (^delete_catalog_handler, {block_exit} TRUE);
      IF NOT status.normal THEN
        IF osp$file_access_condition (status) AND (delete_option = pfc$catalog_and_contents) THEN
          delete_inaccessible_catalog (path, catalog_locator, p_catalog_object,
                parent_catalog_locator, status);
        IFEND;
        EXIT /delete_catalog_object/;
      IFEND;

      test_object_list (catalog_locator.object_list_descriptor.p_object_list, empty_object_list,
            all_objects_purged);

      IF empty_object_list THEN
        delete_object (^path, p_catalog_object, parent_catalog_locator.p_catalog_file,
              parent_catalog_locator.object_list_descriptor);
        {
        { Free all space allocated for the catalog entry.
        {
        pfp$build_permit_list_pointer (p_catalog_object^.object_entry.permit_list_locator,
              parent_catalog_locator.p_catalog_file, p_permit_list);
        IF p_permit_list <> NIL THEN
          osp$prevalidate_free ((#OFFSET(p_permit_list) -
                #OFFSET(^parent_catalog_locator.p_catalog_file^.catalog_heap) - 16),
                ^parent_catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_permit_list IN parent_catalog_locator.p_catalog_file^.catalog_heap;
          ELSE
            pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'PERMIT_LIST', 'catalog',
                  prevalidate_free_result, #OFFSET(p_permit_list));
            p_permit_list := NIL;
          IFEND;
        IFEND;

        IF catalog_locator.object_list_descriptor.catalog_type = pfc$external_catalog THEN
          pfp$build_fmd_pointer (p_catalog_object^.object_entry.catalog_object_locator.fmd_locator,
                parent_catalog_locator.p_catalog_file, p_physical_fmd);

          pfp$destroy_catalog (catalog_locator, status);
          catalog_active := (NOT status.normal);
          pfp$process_unexpected_status (status);

          IF p_physical_fmd <> NIL THEN
            osp$prevalidate_free ((#OFFSET(p_physical_fmd) -
                  #OFFSET(^parent_catalog_locator.p_catalog_file^.catalog_heap) - 16),
                  ^parent_catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
            IF prevalidate_free_result = osc$heap_free_valid THEN
              FREE p_physical_fmd IN parent_catalog_locator.p_catalog_file^.catalog_heap;
            ELSE
              pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'FILE_MEDIA_DESCRIPTOR', 'catalog',
                    prevalidate_free_result, #OFFSET(p_physical_fmd));
              p_physical_fmd := NIL;
            IFEND;
          IFEND;
        ELSE {internal catalog}
          IF catalog_locator.object_list_descriptor.p_object_list <> NIL THEN
            osp$prevalidate_free ((#OFFSET(catalog_locator.object_list_descriptor.p_object_list) -
                  #OFFSET(^parent_catalog_locator.p_catalog_file^.catalog_heap) - 16),
                  ^parent_catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
            IF prevalidate_free_result = osc$heap_free_valid THEN
              FREE catalog_locator.object_list_descriptor.p_object_list IN
                    parent_catalog_locator.p_catalog_file^.catalog_heap;
            ELSE
              pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'OBJECT_LIST_DESCRIPTOR',
                    'the catalog containing the object', prevalidate_free_result,
                    #OFFSET(catalog_locator.object_list_descriptor.p_object_list));
              catalog_locator.object_list_descriptor.p_object_list := NIL;
            IFEND;
          IFEND;
          parent_catalog_locator.queuing_info.set_catalog_alarm := TRUE;
        IFEND;

        contract_object_list (^path, parent_catalog_locator.p_catalog_file,
              parent_catalog_locator.object_list_descriptor, status);
      ELSE {catalog not empty}
        IF all_objects_purged THEN
          IF catalog_locator.object_list_descriptor.catalog_type = pfc$external_catalog THEN
            catalog_locator.queuing_info.set_catalog_alarm := TRUE;
          ELSE
            parent_catalog_locator.queuing_info.set_catalog_alarm := TRUE;
          IFEND;

          pmp$get_unique_name (unique_name, local_status);
          pfp$change_object_name (^path, unique_name, parent_catalog_locator.p_catalog_file, p_catalog_object,
                parent_catalog_locator.object_list_descriptor, status);

          p_catalog_object^.object_entry.object_type := pfc$purged_catalog_object;
          pfp$compute_checksum (#LOC (p_catalog_object^.object_entry), #SIZE (pft$object_entry),
                p_catalog_object^.checksum);
        ELSE { Catalog contains valid files or subcatalogs.
          variant_path.complete_path := TRUE;
          variant_path.p_complete_path := ^path;
          pfp$set_status_abnormal (variant_path, pfe$catalog_not_empty, status);
        IFEND;

        IF catalog_locator.object_list_descriptor.catalog_type = pfc$external_catalog THEN
          pfp$return_catalog (catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
        IFEND;
      IFEND;
    END /delete_catalog_object/;

    osp$disestablish_cond_handler;
    IF catalog_active THEN
      IF catalog_locator.object_list_descriptor.catalog_type = pfc$external_catalog THEN
        pfp$return_catalog (catalog_locator, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;
    IFEND;
  PROCEND pfp$delete_catalog_object;

?? TITLE := '  [XDCL] pfp$delete_file_object', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to delete a specific permanent file entry
{   from an object list.
{
{ DESIGN:
{   If no cycles exist for the file, the object entry for the file is deleted
{   from the object list and the object list is contracted.  If only purged
{   cycles exist for the file, the object type is changed to a purged file
{   type.  If any normal cycles still exist for the file, no action is taken
{   and normal status is returned.

  PROCEDURE [XDCL] pfp$delete_file_object
    (    p_path: ^pft$complete_path;
         p_catalog_file: {i^/o^} pft$p_catalog_file;
     VAR p_file_object: {i/o^} pft$p_object;
     VAR object_list_descriptor: {i/o} pft$object_list_descriptor;
     VAR status: ost$status);

    VAR
      all_cycles_purged: boolean,
      cycle_index: pft$cycle_index,
      empty_cycle_list: boolean,
      local_status: ost$status,
      p_cycle_list: ^pft$cycle_list,
      p_log_list: ^pft$log_list,
      p_permit_list: ^pft$permit_list,
      prevalidate_free_result: ost$prevalidate_free_result,
      unique_name: ost$name;


    PROCEDURE [INLINE] test_cycle_list
      (    p_cycle_list: {input} ^pft$cycle_list;
       VAR empty_cycle_list: boolean;
       VAR all_cycles_purged: boolean);

      VAR
        cycle_index: pft$cycle_index;

      empty_cycle_list := TRUE;
      all_cycles_purged := TRUE;

      IF p_cycle_list <> NIL THEN
        FOR cycle_index := 1 TO UPPERBOUND (p_cycle_list^) DO
          CASE p_cycle_list^ [cycle_index].cycle_entry.entry_type OF
          = pfc$normal_cycle_entry =
            empty_cycle_list := FALSE;
            all_cycles_purged := FALSE;
            RETURN;

          = pfc$purged_cycle_entry =
            empty_cycle_list := FALSE;

          ELSE {pfc$free_cycle_entry}
            ;
          CASEND;
        FOREND;
      IFEND;
    PROCEND test_cycle_list;


    status.normal := TRUE;

    IF (p_file_object <> NIL) AND (p_file_object^.object_entry.object_type IN
          $pft$object_selections [pfc$file_object, pfc$purged_file_object]) THEN
      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator, p_catalog_file,
            p_cycle_list);
      test_cycle_list (p_cycle_list, empty_cycle_list, all_cycles_purged);
      IF empty_cycle_list THEN
        pfp$build_permit_list_pointer (p_file_object^.object_entry.permit_list_locator, p_catalog_file,
              p_permit_list);
        pfp$build_log_list_pointer (p_file_object^.object_entry.log_list_locator, p_catalog_file, p_log_list);
        delete_object (p_path, p_file_object, p_catalog_file, object_list_descriptor);
        {
        { Free all space allocated for items owned by the file object.
        {
        IF p_cycle_list <> NIL THEN
          osp$prevalidate_free ((#OFFSET(p_cycle_list) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
                ^p_catalog_file^.catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_cycle_list IN p_catalog_file^.catalog_heap;
          ELSE
            pfp$report_invalid_free (p_path, {p_cycle_number} NIL, 'CYCLE_LIST', 'file',
                  prevalidate_free_result, #OFFSET(p_cycle_list));
            p_cycle_list := NIL;
          IFEND;
        IFEND;

        IF p_log_list <> NIL THEN
          osp$prevalidate_free ((#OFFSET(p_log_list) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
                ^p_catalog_file^.catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_log_list IN p_catalog_file^.catalog_heap;
          ELSE
            pfp$report_invalid_free (p_path, {p_cycle_number} NIL, 'LOG_LIST', 'file',
                  prevalidate_free_result, #OFFSET(p_log_list));
            p_log_list := NIL;
          IFEND;
        IFEND;

        IF p_permit_list <> NIL THEN
          osp$prevalidate_free ((#OFFSET(p_permit_list) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
                ^p_catalog_file^.catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_permit_list IN p_catalog_file^.catalog_heap;
          ELSE
            pfp$report_invalid_free (p_path, {p_cycle_number} NIL, 'PERMIT_LIST', 'file',
                  prevalidate_free_result, #OFFSET(p_permit_list));
            p_permit_list := NIL;
          IFEND;
        IFEND;

        contract_object_list (p_path, p_catalog_file, object_list_descriptor, status);
      ELSEIF all_cycles_purged THEN
        pmp$get_unique_name (unique_name, local_status);
        pfp$change_object_name (p_path, unique_name, p_catalog_file, p_file_object, object_list_descriptor,
              status);
        p_file_object^.object_entry.object_type := pfc$purged_file_object;
        pfp$compute_checksum (#LOC (p_file_object^.object_entry), #SIZE (pft$object_entry),
              p_file_object^.checksum);
      IFEND;
    IFEND;
  PROCEND pfp$delete_file_object;

?? TITLE := '  [XDCL] pfp$establish_free_object_entry', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to establish a free object entry in an
{ object list.  This is accomplished by either finding an existing free entry
{ or by expanding the object list to create a free entry.  If it is necessary
{ to expand the object list, a new larger object list is created and the old
{ list is copied to the new list.
{   If expanding the object list causes the number of objects to equal or
{ exceed the value, pfc$object_sort_threshold, the entire object list will
{ be sorted prior to copying to the new object list.
{   If a sorted object list is expanded the unsorted portion of the object
{ list is sorted and merged with the sorted portion while copying to the
{ new object list. Free objects will be removed from the sorted portion of
{ the object list.

  PROCEDURE [XDCL] pfp$establish_free_object_entry
    (    p_path: ^pft$complete_path;
         p_catalog_file: {output^} ^pft$catalog_file;
     VAR object_list_descriptor: {i/o} pft$object_list_descriptor;
     VAR p_object: {output} ^pft$physical_object;
     VAR status: ost$status);

    VAR
      new_object_count: pft$object_count,
      new_sorted_object_count: pft$object_count,
      new_valid_object_count: pft$object_count,
      object_index: pft$object_index,
      p_new_object_list: ^pft$object_list,
      p_object_list: ^pft$object_list,
      p_object_name_list: ^pft$object_name_list;

    PROCEDURE [INLINE] locate_free_object_entry
      (    object_list_descriptor: pft$object_list_descriptor;
       VAR p_object: {output} ^pft$physical_object);

      VAR
        object_index: pft$object_index,
        p_object_list: ^pft$object_list;

      IF object_list_descriptor.p_object_list <> NIL THEN
        p_object_list := object_list_descriptor.p_object_list;
        FOR object_index := (object_list_descriptor.sorted_object_count + 1) TO UPPERBOUND (p_object_list^) DO
          IF p_object_list^ [object_index].object_entry.object_type = pfc$free_object THEN
            p_object := ^p_object_list^ [object_index];
            RETURN;
          IFEND;
        FOREND;
      IFEND;

      p_object := NIL;
    PROCEND locate_free_object_entry;


    status.normal := TRUE;

    locate_free_object_entry (object_list_descriptor, p_object);
    IF p_object = NIL THEN
      IF object_list_descriptor.p_object_list = NIL THEN
        new_object_count := 0;
        merge_object_list ({p_object_name_list} NIL, new_object_count, {p_object_list} NIL, p_catalog_file,
              object_list_descriptor, p_new_object_list, new_valid_object_count, status);
        IF status.normal THEN
          new_sorted_object_count := 0;
          p_object := ^p_new_object_list^ [1];
        IFEND;
      ELSE { An old object list currently exists.
        p_object_list := object_list_descriptor.p_object_list;
        new_object_count := UPPERBOUND (p_object_list^) + pfp$object_expansion_size (p_object_list);
        IF object_list_descriptor.sorted_object_count > 0 THEN
          new_object_count := new_object_count - object_list_descriptor.free_sorted_object_count;
        IFEND;

        IF new_object_count >= pfc$object_sort_threshold THEN
          IF object_list_descriptor.sorted_object_count > 0 THEN
            PUSH p_object_name_list: [1 .. UPPERBOUND (p_object_list^) -
                  object_list_descriptor.sorted_object_count];
          ELSE
            PUSH p_object_name_list: [1 .. new_object_count];
          IFEND;

          build_object_name_list (object_list_descriptor, p_object_name_list, new_object_count);
          heap_sort (new_object_count, p_object_name_list);
          merge_object_list (p_object_name_list, new_object_count, p_object_list, p_catalog_file,
                object_list_descriptor, p_new_object_list, new_valid_object_count, status);
          IF status.normal THEN
            new_sorted_object_count := new_valid_object_count;
            p_object := ^p_new_object_list^ [new_valid_object_count + 1];
          IFEND;
        ELSE
          PUSH p_object_name_list: [1 .. new_object_count];
          build_object_name_list (object_list_descriptor, p_object_name_list, new_object_count);
          merge_object_list (p_object_name_list, new_object_count, p_object_list, p_catalog_file,
                object_list_descriptor, p_new_object_list, new_valid_object_count, status);
          IF status.normal THEN
            new_sorted_object_count := 0;
            p_object := ^p_new_object_list^ [new_valid_object_count + 1];
          IFEND;
        IFEND;
      IFEND;

      IF status.normal THEN
        object_list_descriptor.free_sorted_object_count := 0;
        object_list_descriptor.sorted_object_count := new_sorted_object_count;
        pfp$update_object_list_locator (p_path, p_new_object_list, p_catalog_file, object_list_descriptor);
      IFEND;
    IFEND;
  PROCEND pfp$establish_free_object_entry;

?? TITLE := '  [XDCL] pfp$get_sorted_object_name_list', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to generate an array containing an
{ entry for each non-free object in the unsorted portion of the specified
{ object list. Each entry will contain the objects external name and its
{ index in the object list. This array will then be sorted rather than
{ sorting the object list itself. Each element of an object list is 262 bytes,
{ while each object of this list is 35 bytes.

  PROCEDURE [XDCL] pfp$get_sorted_object_name_list
    (    object_list_descriptor: pft$object_list_descriptor;
         p_object_name_list: ^pft$object_name_list;
     VAR object_name_count: pft$object_count);

    build_object_name_list (object_list_descriptor, p_object_name_list, object_name_count);
    heap_sort (object_name_count, p_object_name_list);
  PROCEND pfp$get_sorted_object_name_list;

?? TITLE := '  [XDCL] pfp$locate_object', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to search an object list for an object
{ with the specified name.  If the object cannot be found or the object type
{ is not included in the specified valid_objects, a NIL pointer is returned
{ for p_object.
{   The sorted portion of the object list is searched first using a binary
{ search and the unsorted portion of the object list is then searched using
{ a linear search.
{  The system attribute, BINARY_CATALOG_SEARCH, establishes the value of the
{ variable pfv$binary_catalog_search. If set to FALSE a linear search will be
{ performed on the entire catalog to locate the specified object.

  PROCEDURE [XDCL] pfp$locate_object
    (    object_name: pft$name;
         valid_objects: pft$object_selections;
         object_list_descriptor: pft$object_list_descriptor;
     VAR p_object: {output} ^pft$physical_object);

    VAR
      new_valid_objects: pft$object_selections,
      object_index: pft$object_index;

    #KEYPOINT (osk$entry, 0, pfk$locate_object);
    p_object := NIL;
    IF (object_list_descriptor.sorted_object_count <> 0) AND pfv$binary_catalog_search THEN
      locate_sorted_object (object_name, valid_objects, object_list_descriptor, p_object, object_index);
    IFEND;

    IF p_object = NIL THEN
      locate_unsorted_object (object_name, valid_objects, object_list_descriptor, p_object, object_index);
    IFEND;

    #KEYPOINT (osk$exit, 0, pfk$locate_object);
  PROCEND pfp$locate_object;

?? TITLE := '  [XDCL] pfp$sort_object_list', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to unconditionally sort the old object
{ list and place the results in the new object list. The old object list is
{ assumed to be unsorted. The new object list is assumed to have been allocated
{ by the caller and be large enough to hold all non-free objects in the old
{ object list.

  PROCEDURE [XDCL] pfp$sort_object_list
    (    p_object_list: {input} ^pft$object_list;
         p_new_object_list: {i/o} ^pft$object_list;
     VAR object_list_descriptor: {i/o} pft$object_list_descriptor);

    VAR
      free_object_index: pft$object_index,
      free_physical_object: pft$physical_object,
      new_object_count: pft$object_count,
      object_index: pft$object_index,
      p_object_name_list: ^pft$object_name_list;

  /sort_object_list/
    BEGIN
      IF p_object_list = NIL THEN
        EXIT /sort_object_list/;
      IFEND;

      free_physical_object.object_entry.object_type := pfc$free_object;
      free_physical_object.object_entry.external_object_name := osc$null_name;
      pfp$compute_checksum (^free_physical_object.object_entry, #SIZE (pft$object_entry),
            free_physical_object.checksum);

      object_list_descriptor.p_object_list := p_object_list;
      object_list_descriptor.sorted_object_count := 0;
      PUSH p_object_name_list: [1 .. UPPERBOUND (p_object_list^)];
      build_object_name_list (object_list_descriptor, p_object_name_list, new_object_count);
      heap_sort (new_object_count, p_object_name_list);

      IF new_object_count > 0 THEN
        FOR object_index := 1 to new_object_count DO
          p_new_object_list^[object_index] := p_object_list^[p_object_name_list^[object_index].object_index];
        FOREND;
        free_object_index := new_object_count + 1;
      ELSE
        free_object_index := 1;
      IFEND;

      FOR object_index := free_object_index TO UPPERBOUND(p_new_object_list^) DO
        p_new_object_list^[object_index] := free_physical_object;
      FOREND;

      object_list_descriptor.p_object_list := p_new_object_list;
      object_list_descriptor.sorted_object_count := new_object_count;
      IF UPPERBOUND(p_new_object_list^) < pfc$object_sort_threshold THEN
        object_list_descriptor.sorted_object_count := 0;
      IFEND;
      object_list_descriptor.free_sorted_object_count := 0;

    END /sort_object_list/;
  PROCEND pfp$sort_object_list;

?? TITLE := '  [XDCL] pfp$update_obj_list_descriptor', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to determine if the specified object is
{ located in the sorted portion of the specified object list and if so,
{ increment the free_sorted_object_count field in the object_list_descriptor.
{ This procedure is intended for use by routines that are deleting objects
{ from object lists.

  PROCEDURE [XDCL] pfp$update_obj_list_descriptor
    (    p_object: ^pft$physical_object;
     VAR object_list_descriptor: pft$object_list_descriptor);

    VAR
      object_index: pft$object_index,
      p_found_object: ^pft$physical_object;

    IF object_list_descriptor.sorted_object_count > 0 THEN
      locate_sorted_object (p_object^.object_entry.external_object_name,
            $pft$object_selections [pfc$file_object, pfc$catalog_object, pfc$purged_catalog_object,
            pfc$purged_file_object], object_list_descriptor, p_found_object, object_index);
      IF (p_found_object <> NIL) AND (object_index <= object_list_descriptor.sorted_object_count) THEN
        object_list_descriptor.free_sorted_object_count :=
              object_list_descriptor.free_sorted_object_count + 1;
      IFEND;
    IFEND;
  PROCEND pfp$update_obj_list_descriptor;

?? TITLE := '  [XDCL] pfp$update_object_list_locator', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to update the object_list_locator in
{ the specified catalog with information from the specified
{ object_list_descriptor and p_new_object_list.

  PROCEDURE [XDCL] pfp$update_object_list_locator
    (    p_path: ^pft$complete_path;
         p_new_object_list: {input} pft$p_object_list;
         p_catalog_file: {i^/o^} pft$p_catalog_file;
     VAR object_list_descriptor: {i/o} pft$object_list_descriptor);

    VAR
      object_list_locator: pft$object_list_locator,
      prevalidate_free_result: ost$prevalidate_free_result;

    IF p_new_object_list = NIL THEN
      pfp$build_object_list_locator (object_list_descriptor.sorted_object_count,
            object_list_descriptor.free_sorted_object_count, object_list_descriptor.p_object_list,
            p_catalog_file, object_list_locator);
    ELSE
      pfp$build_object_list_locator (object_list_descriptor.sorted_object_count,
            object_list_descriptor.free_sorted_object_count, p_new_object_list, p_catalog_file,
            object_list_locator);
    IFEND;

    IF object_list_descriptor.catalog_type = pfc$internal_catalog THEN
      object_list_descriptor.p_parent_catalog^.object_entry.catalog_object_locator.object_list_locator :=
            object_list_locator;
      pfp$compute_checksum (#LOC (object_list_descriptor.p_parent_catalog^.object_entry),
            #SIZE (pft$object_entry), object_list_descriptor.p_parent_catalog^.checksum);
    ELSE {external catalog}
      object_list_descriptor.p_physical_catalog_header^.catalog_header.object_list_locator :=
            object_list_locator;
      pfp$compute_checksum (#LOC (object_list_descriptor.p_physical_catalog_header^.catalog_header),
            #SIZE (pft$catalog_header), object_list_descriptor.p_physical_catalog_header^.checksum);
    IFEND;
    {
    { Free the old object_list from the catalog.
    {
    IF p_new_object_list <> NIL THEN
      IF object_list_descriptor.p_object_list <> NIL THEN
        osp$prevalidate_free ((#OFFSET(object_list_descriptor.p_object_list) -
              #OFFSET(^p_catalog_file^.catalog_heap) - 16),
              ^p_catalog_file^.catalog_heap, prevalidate_free_result);
        IF prevalidate_free_result = osc$heap_free_valid THEN
          FREE object_list_descriptor.p_object_list IN p_catalog_file^.catalog_heap;
        ELSE
          pfp$report_invalid_free (p_path, {p_cycle_number} NIL, 'OBJECT_LIST_DESCRIPTOR',
                'the catalog containing the object', prevalidate_free_result,
                #OFFSET(object_list_descriptor.p_object_list));
          object_list_descriptor.p_object_list := NIL;
        IFEND;
      IFEND;
      object_list_descriptor.p_object_list := p_new_object_list;
    IFEND;
  PROCEND pfp$update_object_list_locator;

?? TITLE := '  [INLINE] adjust', EJECT ??

  PROCEDURE [INLINE] adjust
    (    p_object_name_list: {i/o} ^pft$object_name_list;
         i: pft$object_index;
         n: pft$object_index);

    VAR
      j: pft$object_index,
      k: pft$object_index,
      r: pft$object_name,
      done: boolean;

    done := FALSE;
    r := p_object_name_list^ [i];
    j := 2 * i;

    WHILE ((j <= n) AND NOT done) DO
      IF j < n THEN
        IF p_object_name_list^ [j].object_name < p_object_name_list^ [j + 1].object_name THEN
          j := j + 1;
        IFEND;
      IFEND;
      IF r.object_name < p_object_name_list^ [j].object_name THEN
        p_object_name_list^ [j DIV 2] := p_object_name_list^ [j];
        j := 2 * j;
      ELSE
        done := TRUE;
      IFEND;
    WHILEND;
    p_object_name_list^ [j DIV 2] := r;
  PROCEND adjust;

?? TITLE := '  [INLINE] build_object_name_list', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to generate an array containing an
{ entry for each non-free object in the unsorted portion of the specified
{ object list. Each entry will contain the objects external name and its
{ index in the object list. This array will then be sorted rather than
{ sorting the object list itself. Each element of an object list is 262 bytes,
{ while each object of this list is 35 bytes.

  PROCEDURE [INLINE] build_object_name_list
    (    object_list_descriptor: pft$object_list_descriptor;
         p_object_name_list: {output} ^pft$object_name_list;
     VAR object_name_count: pft$object_count);

    VAR
      ignore_status: ost$status,
      object_index: pft$object_index,
      p_object_list: ^pft$object_list;

    p_object_list := object_list_descriptor.p_object_list;
    object_name_count := 0;
    FOR object_index := (object_list_descriptor.sorted_object_count + 1) TO UPPERBOUND (p_object_list^) DO
      IF p_object_list^ [object_index].object_entry.object_type <> pfc$free_object THEN
        object_name_count := object_name_count + 1;
        p_object_name_list^ [object_name_count].object_index := object_index;
        p_object_name_list^ [object_name_count].object_name :=
              p_object_list^ [object_index].object_entry.external_object_name;
      IFEND;
    FOREND;
  PROCEND build_object_name_list;

?? TITLE := '  contract_object_list', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to analyze an object list and contract it
{ if necessary. When an object list is contracted the following will occur:
{    o Allocate space in the catalog for the new, smaller, object list.
{    o If required, sort the unsorted portion of the old object list.
{    o Copy the old object list to the new object list removing free objects.
{    o Initialize the remaining objects in the new object list as free objects.
{    o Update the object list locator in the catalog header.
{    o Free the space in the catalog used by the old object list.
{
{ For unsorted object lists the object list will be contracted when the total
{ number of free objects equals or exceeds the value pfp$object_contraction_count.
{ For sorted object lists the object list will be contracted when the number
{ of free objects in the sorted portion of the object list equals or exceeds
{ the value pfp$object_contraction_count.

  PROCEDURE contract_object_list
    (    p_path: ^pft$complete_path;
         p_catalog_file: {output^} ^pft$catalog_file;
     VAR object_list_descriptor: {i/o} pft$object_list_descriptor;
     VAR status: ost$status);

    VAR
      high_object_index: pft$object_index,
      new_object_count: pft$object_count,
      new_object_index: pft$object_index,
      new_valid_object_count: pft$object_count,
      object_index: pft$object_index,
      p_found_object: ^pft$physical_object,
      p_new_object_list: ^pft$object_list,
      p_object_list: ^pft$object_list,
      p_object_name_list: ^pft$object_name_list,
      update_catalog: boolean;

    status.normal := TRUE;
    update_catalog := FALSE;
    p_object_list := object_list_descriptor.p_object_list;

  /contract_object_list_block/
    BEGIN
      IF p_object_list = NIL THEN
        EXIT /contract_object_list_block/;
      IFEND;

      IF object_list_descriptor.sorted_object_count > 0 THEN
        p_new_object_list := NIL;

        IF object_list_descriptor.free_sorted_object_count >=
              pfp$object_contraction_count (p_object_list) THEN
          PUSH p_object_name_list: [1 .. UPPERBOUND (p_object_list^) -
                object_list_descriptor.sorted_object_count];
          build_object_name_list (object_list_descriptor, p_object_name_list, new_object_count);
          heap_sort (new_object_count, p_object_name_list);
          merge_object_list (p_object_name_list, new_object_count, p_object_list, p_catalog_file,
                object_list_descriptor, p_new_object_list, new_valid_object_count, status);
          IF status.normal THEN
            update_catalog := TRUE;
            object_list_descriptor.sorted_object_count := new_valid_object_count;
            IF UPPERBOUND (p_new_object_list^) < pfc$object_sort_threshold THEN
              object_list_descriptor.sorted_object_count := 0;
            IFEND;
            object_list_descriptor.free_sorted_object_count := 0;
          IFEND;
        IFEND;
      ELSEIF UPPERBOUND (p_object_list^) >= pfc$object_sort_threshold THEN
        p_new_object_list := NIL;

        PUSH p_object_name_list: [1 .. UPPERBOUND (p_object_list^)];
        build_object_name_list (object_list_descriptor, p_object_name_list, new_object_count);
        heap_sort (new_object_count, p_object_name_list);
        merge_object_list (p_object_name_list, new_object_count, p_object_list, p_catalog_file,
              object_list_descriptor, p_new_object_list, new_valid_object_count, status);
        IF status.normal THEN
          update_catalog := TRUE;
          object_list_descriptor.sorted_object_count := new_valid_object_count;
          IF UPPERBOUND(p_new_object_list^) < pfc$object_sort_threshold THEN
            object_list_descriptor.sorted_object_count := 0;
          IFEND;
          object_list_descriptor.free_sorted_object_count := 0;
        IFEND;
      ELSE
        {
        { Unsorted object_list.
        {
        PUSH p_object_name_list: [1 .. UPPERBOUND (p_object_list^)];
        build_object_name_list (object_list_descriptor, p_object_name_list, new_object_count);
        IF (UPPERBOUND (p_object_list^) - new_object_count) >=
              pfp$object_contraction_count (p_object_list) THEN
          merge_object_list (p_object_name_list, new_object_count, p_object_list, p_catalog_file,
                object_list_descriptor, p_new_object_list, new_valid_object_count, status);
          IF status.normal THEN
            update_catalog := TRUE;
            object_list_descriptor.sorted_object_count := 0;
            object_list_descriptor.free_sorted_object_count := 0;
          IFEND;
        IFEND;
      IFEND;

      IF status.normal THEN
        IF update_catalog THEN
          pfp$update_object_list_locator (p_path, p_new_object_list, p_catalog_file, object_list_descriptor);
        IFEND;
      ELSEIF status.condition = pfe$catalog_full THEN
        status.normal := TRUE;
      IFEND;
    END /contract_object_list_block/;
  PROCEND contract_object_list;

?? TITLE := '  delete_inaccessible_catalog', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to delete a catalog object that resides on
{   an unavailable volume from the specified object list.
{
{ DESIGN:
{   The object list is contracted if necessary.

  PROCEDURE delete_inaccessible_catalog
    (    path: pft$complete_path;
     VAR catalog_locator: {i/o} pft$catalog_locator;
     VAR p_catalog_object: {i^/o^} ^pft$physical_object;
     VAR parent_catalog_locator: {i/o} pft$catalog_locator;
     VAR status: ost$status);

    CONST
      critical_message = TRUE;

    VAR
      all_objects_purged: boolean,
      ascii_log_text_length: integer,
      local_status: ost$status,
      p_ascii_log_text: ^string (7 {lines} * (108 - 21) {max characters/line} ),
      p_permit_list: ^pft$permit_list,
      p_physical_fmd: ^pft$physical_fmd,
      prevalidate_free_result: ost$prevalidate_free_result,
      unique_name: ost$name,
      variant_path: pft$variant_path;

    status.normal := TRUE;

    pfp$detach_unavail_queued_cat (p_catalog_object^.object_entry.internal_object_name, catalog_locator);
    delete_object (^path, p_catalog_object, parent_catalog_locator.p_catalog_file,
          parent_catalog_locator.object_list_descriptor);
    {
    { Free all space allocated for the catalog entry.
    {
    pfp$build_permit_list_pointer (p_catalog_object^.object_entry.permit_list_locator,
          parent_catalog_locator.p_catalog_file, p_permit_list);
    IF p_permit_list <> NIL THEN
      osp$prevalidate_free ((#OFFSET(p_permit_list) -
            #OFFSET(^parent_catalog_locator.p_catalog_file^.catalog_heap) - 16),
            ^parent_catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
      IF prevalidate_free_result = osc$heap_free_valid THEN
        FREE p_permit_list IN parent_catalog_locator.p_catalog_file^.catalog_heap;
      ELSE
        pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'PERMIT_LIST', 'catalog',
              prevalidate_free_result, #OFFSET(p_permit_list));
        p_permit_list := NIL;
      IFEND;
    IFEND;

    pfp$build_fmd_pointer (p_catalog_object^.object_entry.catalog_object_locator.fmd_locator,
          parent_catalog_locator.p_catalog_file, p_physical_fmd);

    dmp$destroy_permanent_file (p_catalog_object^.object_entry.catalog_object_locator.global_file_name,
          p_physical_fmd^.fmd, status);
    IF status.normal THEN
      PUSH p_ascii_log_text;
      STRINGREP (p_ascii_log_text^, ascii_log_text_length, 'A catalog was deleted which resides on a',
            ' missing or unavailable volume or which contains a subcatalog or file cycle which',
            ' resides on a missing or unavailable volume.  The disk space of the catalog''s subtree',
            ' can only be regained by deleting unreconciled files during a continuation deadstart.',
            '  Refer to the DELETE_UNRECONCILED_FILES system attribute.  The deletion of',
            ' unreconciled files should only be scheduled subsequent to the reinstatement of the',
            ' missing or unavailable volume(s).');
      pfp$log_ascii (p_ascii_log_text^ (1, ascii_log_text_length), $pmt$ascii_logset [pmc$system_log],
            pmc$msg_origin_system, NOT critical_message, local_status);
      STRINGREP (p_ascii_log_text^, ascii_log_text_length, 'You deleted a catalog which resides on a',
            ' missing or unavailable volume or which contains a subcatalog or file cycle which',
            ' resides on a missing or unavailable volume.  The disk space of the catalog''s subtree',
            ' cannot be freed until your site deletes unreconciled files.  Please contact your site',
            ' analyst to regain your space.');
      pfp$log_ascii (p_ascii_log_text^ (1, ascii_log_text_length), $pmt$ascii_logset [pmc$job_log],
            pmc$msg_origin_system, NOT critical_message, local_status);
    IFEND;

    IF p_physical_fmd <> NIL THEN
      osp$prevalidate_free ((#OFFSET(p_physical_fmd) -
            #OFFSET(^parent_catalog_locator.p_catalog_file^.catalog_heap) - 16),
            ^parent_catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
      IF prevalidate_free_result = osc$heap_free_valid THEN
        FREE p_physical_fmd IN parent_catalog_locator.p_catalog_file^.catalog_heap;
      ELSE
        pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'FILE_MEDIA_DESCRIPTOR', 'catalog',
              prevalidate_free_result, #OFFSET(p_physical_fmd));
        p_physical_fmd := NIL;
      IFEND;
    IFEND;

    contract_object_list (^path, parent_catalog_locator.p_catalog_file,
          parent_catalog_locator.object_list_descriptor, status);
  PROCEND delete_inaccessible_catalog;

?? TITLE := '  delete_object', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to delete the specified object from the
{ specified object list.  If the object is located in the sorted portion of
{ a sorted object list the free_sorted_object_count field in the
{ object_list_descriptor is incremented.

  PROCEDURE delete_object
    (    p_path: ^pft$complete_path;
         p_object: {i/o} ^pft$physical_object;
         p_catalog_file: {output} ^pft$catalog_file;
     VAR object_list_descriptor: {i/o} pft$object_list_descriptor);

    VAR
      object_index: pft$object_index,
      p_found_object: ^pft$physical_object;

    IF object_list_descriptor.sorted_object_count > 0 THEN
      locate_sorted_object (p_object^.object_entry.external_object_name,
            $pft$object_selections [pfc$file_object, pfc$purged_file_object, pfc$catalog_object,
            pfc$purged_catalog_object], object_list_descriptor, p_found_object, object_index);
      p_object^.object_entry.object_type := pfc$free_object;
      pfp$compute_checksum (^p_object^.object_entry, #SIZE (pft$object_entry), p_object^.checksum);
      IF (p_found_object <> NIL) AND (object_index <= object_list_descriptor.sorted_object_count) THEN
        object_list_descriptor.free_sorted_object_count :=
              object_list_descriptor.free_sorted_object_count + 1;
        pfp$update_object_list_locator (p_path, {p_new_object_list} NIL, p_catalog_file,
              object_list_descriptor);
      IFEND;
    ELSE { Unsorted object list
      p_object^.object_entry.object_type := pfc$free_object;
      pfp$compute_checksum (^p_object^.object_entry, #SIZE (pft$object_entry), p_object^.checksum);
    IFEND;
  PROCEND delete_object;

?? TITLE := '  heap_sort', EJECT ??
{ DESIGN:
{   The following sort algorithm is a nonrecursive heap sort.  There are two
{   phases to the algorithm.  The first phase converts the list to be sorted
{   into a binary tree representation.  The second and main sorting phase of
{   the algorithm iterates through the unsorted portion of the list.  In each
{   iteration the first element and the last element of the unsorted portion
{   are swapped, and adjust is called.  Adjust searches the right and left
{   subtrees for the highest key value, which becomes the root of the tree, and
{   is returned in the first element of the list.  Each call to adjust is
{   passed a tree containing one fewer nodes than the previous call.

  PROCEDURE heap_sort
    (    object_name_count: pft$object_count;
         p_object_name_list {i^/o^} : ^pft$object_name_list);

    VAR
      temp_record: pft$object_name,
      unsorted_object_count: pft$object_count;

    FOR unsorted_object_count := object_name_count DIV 2 DOWNTO 1 DO
      adjust (p_object_name_list, unsorted_object_count, object_name_count);
    FOREND;

    FOR unsorted_object_count := object_name_count - 1 DOWNTO 1 DO
      temp_record := p_object_name_list^ [unsorted_object_count + 1];
      p_object_name_list^ [unsorted_object_count + 1] := p_object_name_list^ [1];
      p_object_name_list^ [1] := temp_record;
      adjust (p_object_name_list, 1, unsorted_object_count);
    FOREND;
  PROCEND heap_sort;

?? TITLE := '  locate_sorted_object', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to search the sorted portion of a sorted
{ object_list for an object with the specified name.  A binary search is used.
{ If the object cannot be found or the object type is not included in the
{ specified valid objects a NIL pointer is returned for p_object.
{ If binary searching is disabled by the system attribure
{ BINARY_CATALOG_SEARCH a linear search will be used to locate the object.
{ The value returned in the OBJECT_INDEX parameter is only valid if the
{ P_OBJECT parameter is non-NIL (i.e. the object is found).

  PROCEDURE locate_sorted_object
    (    object_name: pft$name;
         valid_objects: pft$object_selections;
         object_list_descriptor: pft$object_list_descriptor;
     VAR p_object: {output} ^pft$physical_object;
     VAR object_index: pft$object_index);

    VAR
      temp: integer,
      high_index: pft$object_count,
      low_index: pft$object_index,
      mid_index: pft$object_index,
      p_object_list: ^pft$object_list;

    IF pfv$binary_catalog_search THEN
      p_object := NIL;
      p_object_list := object_list_descriptor.p_object_list;

      IF (p_object_list <> NIL) AND (object_list_descriptor.sorted_object_count <> 0) THEN
        low_index := LOWERBOUND (p_object_list^);
        high_index := object_list_descriptor.sorted_object_count;

      /binary_search/
        WHILE low_index <= high_index DO
          temp := low_index + high_index;
          mid_index := temp DIV 2;
          IF object_name > p_object_list^ [mid_index].object_entry.external_object_name THEN
            low_index := mid_index + 1;
          ELSEIF object_name < p_object_list^ [mid_index].object_entry.external_object_name THEN
            high_index := mid_index - 1;
          ELSE
            IF p_object_list^ [mid_index].object_entry.object_type IN valid_objects THEN
              p_object := ^p_object_list^ [mid_index];
              object_index := mid_index;
            IFEND;
            EXIT /binary_search/;
          IFEND;
        WHILEND /binary_search/;
      IFEND;
    ELSE {binary search disabled.
      locate_unsorted_object (object_name, valid_objects, object_list_descriptor, p_object, object_index);
    IFEND;
  PROCEND locate_sorted_object;

?? TITLE := '  [INLINE] locate_unsorted_object', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to search the unsorted portion of an
{ object_list for an object with the specified name.  A linear search is used.
{ If the object cannot be found or the object type is not included in the
{ specified valid objects a NIL pointer is returned for p_object.
{ If the object list in not sorted or binary searching is disabled the
{ entire object list is searched for the object. If the object list is sorted
{ and binary searching is enabled only the unsorted portion of the object
{ list is searched.
{ The value returned in the OBJECT_INDEX parameter is only valid if the
{ P_OBJECT parameter is non-NIL (i.e. the object is found).

  PROCEDURE [INLINE] locate_unsorted_object
    (    object_name: pft$name;
         valid_objects: pft$object_selections;
         object_list_descriptor: pft$object_list_descriptor;
     VAR p_object: {output} ^pft$physical_object;
     VAR object_index: pft$object_index);

    VAR
      p_object_list: ^pft$object_list,
      start_object_index: pft$object_index;


    p_object := NIL;
    p_object_list := object_list_descriptor.p_object_list;

    IF p_object_list <> NIL THEN
      IF pfv$binary_catalog_search THEN
        start_object_index  := object_list_descriptor.sorted_object_count + 1;
      ELSE
        start_object_index := LOWERBOUND (p_object_list^);
      IFEND;

    /locate_object/
      FOR object_index := start_object_index TO UPPERBOUND (p_object_list^) DO
        IF (p_object_list^ [object_index].object_entry.external_object_name = object_name) AND
              (p_object_list^ [object_index].object_entry.object_type IN valid_objects) THEN
          p_object := ^p_object_list^ [object_index];
          EXIT /locate_object/;
        IFEND;
      FOREND /locate_object/;
    IFEND;
  PROCEND locate_unsorted_object;

?? TITLE := '  merge_object_list', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to allocate and initialize an object list
{ given an object_name_list and an existing object_list. The object_name_list
{ will contain the object_name and index into the object_list for each object
{ in the unsorted portion of the object_list. The new object list will contain
{ all the non-free objects of the old object list and pfp$object_expansion_size
{ free objects at the end of the object_list.
{ The new object list will be constructed as follows:
{   If (p_object_name_list = NIL) AND (p_object_list = NIL)
{     An object list is allocated with all free objects.
{   If (p_object_name_list <> NIL) AND (p_object_list^ is unsorted)
{      The elements are moved from the old object list to the new object list
{     using the object_name_list to determine their order. The object_name_list
{     will be in sorted order if the new object list is larger than the value
{     pfc$object_sort_threshold. Otherwise it will be in unsorted order.
{   IF (p_object_name_list <> NIL) AND (p_object_list^ is sorted)
{     The elements from the sorted and unsorted portion of the object list
{     are merged into the new object list to create a new sorted object list.

  PROCEDURE merge_object_list
    (    p_object_name_list: ^pft$object_name_list;
         object_name_count: pft$object_count;
         p_object_list: ^pft$object_list;
         p_catalog_file: {output} ^pft$catalog_file;
         object_list_descriptor: pft$object_list_descriptor;
     VAR p_new_object_list: ^pft$object_list;
     VAR new_valid_object_count: pft$object_count;
     VAR status: ost$status);

    VAR
      free_physical_object: pft$physical_object,
      i: pft$object_count,
      new_object_index: pft$object_count,
      max_object_name_index: pft$object_count,
      max_object_index: pft$object_count,
      new_total: pft$object_count,
      object_name_index: pft$object_count,
      object_index: pft$object_count;

    {
    { Compute the size of the new_object_list and allocate.
    {

    new_total := object_list_descriptor.sorted_object_count + object_name_count +
          pfp$object_expansion_size (p_object_list);
    IF object_list_descriptor.sorted_object_count > 0 THEN
      new_total := new_total - object_list_descriptor.free_sorted_object_count;
    IFEND;

    ALLOCATE p_new_object_list: [1 .. new_total] IN p_catalog_file^.catalog_heap;
    IF p_new_object_list <> NIL THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_condition (pfe$catalog_full, status);
      RETURN;
    IFEND;

    IF p_object_name_list = NIL THEN
      object_name_index := 1;
      max_object_name_index := 0;
    ELSE
      object_name_index := LOWERBOUND (p_object_name_list^);
      max_object_name_index := object_name_count;
    IFEND;

    IF p_object_list = NIL THEN
      object_index := 1;
      max_object_index := 0;
    ELSE
      object_index := LOWERBOUND (p_object_list^);
      max_object_index := object_list_descriptor.sorted_object_count;
    IFEND;

    new_object_index := LOWERBOUND (p_new_object_list^);

    {
    { Merge sorted and unsorted portions of object_list into new_object_list.
    {
    WHILE ((object_name_index <= max_object_name_index) AND (object_index <= max_object_index)) DO
      IF p_object_list^ [object_index].object_entry.object_type = pfc$free_object THEN
        { Skip free objects in the sorted portion of the old object list.
        object_index := object_index + 1;
      ELSEIF p_object_name_list^ [object_name_index].object_name <= p_object_list^ [object_index].
            object_entry.external_object_name THEN
        p_new_object_list^ [new_object_index] := p_object_list^
              [p_object_name_list^ [object_name_index].object_index];
        object_name_index := object_name_index + 1;
        new_object_index := new_object_index + 1;
      ELSE
        p_new_object_list^ [new_object_index] := p_object_list^ [object_index];
        object_index := object_index + 1;
        new_object_index := new_object_index + 1;
      IFEND;
    WHILEND;

    {
    { Either the sorted or unsorted portion is exhausted.
    { Move remaining elements into new object_list.
    {
    IF object_name_index > max_object_name_index THEN
      FOR i := object_index TO max_object_index DO
        IF p_object_list^ [i].object_entry.object_type <> pfc$free_object THEN
          p_new_object_list^ [new_object_index] := p_object_list^ [i];
          new_object_index := new_object_index + 1;
        IFEND;
      FOREND;
    ELSE
      FOR i := object_name_index TO max_object_name_index DO
        p_new_object_list^ [new_object_index] := p_object_list^ [p_object_name_list^ [i].object_index];
        new_object_index := new_object_index + 1;
      FOREND;
    IFEND;

    {
    { Initialize remaining objects as free objects.
    {
    free_physical_object.object_entry.object_type := pfc$free_object;
    free_physical_object.object_entry.external_object_name := osc$null_name;
    pfp$compute_checksum (^free_physical_object.object_entry, #SIZE (pft$object_entry),
          free_physical_object.checksum);

    new_valid_object_count := new_object_index - 1;
    FOR i := new_object_index TO UPPERBOUND (p_new_object_list^) DO
      p_new_object_list^ [i] := free_physical_object;
    FOREND;
  PROCEND merge_object_list;

?? OLDTITLE, SKIP := 2 ??
MODEND pfm$object_list_manager;
*DECK DECK=PFM$PERMANENT_FILE_DEFINITIONS EXPAND=TRUE
?? RIGHT := 110 ??
*copy osd$default_pragmats
MODULE pfm$permanent_file_definitions;
?? TITLE := '*** PFD$PERMANENT_FILE_ATTRIBUTES ***', SKIP := 4 ??
*copy pfd$permanent_file_attributes
?? TITLE := '*** PFD$PERMANENT_FILE_DEFINITIONS - PROGRAM INTERFACE DEFINITIONS ***', EJECT ??
*copy pfd$permanent_file_definitions
?? TITLE := '*** PFD$USAGE_SELECTOR, PFD$SHARE_SELECTOR, PFD$SELECTIONS_STRING ***', EJECT ??
{ *** PFD$USAGE_SELECTOR
*copy pfd$usage_selector
?? SKIP := 4 ??
{ *** PFD$SHARE_SELECTOR
*copy pfd$share_selector
?? SKIP := 4 ??
{ *** PFT$SELECTIONS_STRING
*copy pft$selections_string
?? TITLE := '*** PFD$PASSWORD_SELECTOR, PFD$MANDATED_MODIFICATION_TIME ***', EJECT ??
{ *** PFD$PASSWORD_SELECTOR
*copy pfd$password_selector
?? SKIP := 4 ??
{ *** PFD$MANDATED_MODIFICATION_TIME
*copy pfd$mandated_modification_time
?? TITLE := '*** PFC$TEST_JR_CONSTANTS ***', EJECT ??
*copy pfc$test_jr_constants
?? TITLE := '*** PFT$FAMILY_LOCATION, PFT$SERVED_FAMILY_LOCATOR ***', EJECT ??
*copyc pft$family_location
?? SKIP := 4 ??
*copyc pft$served_family_locator
?? TITLE := '*** PFD$INTERNAL_NAME, PFD$CHARGE_ID, PFD$CYCLE_STATISTICS ***', EJECT ??
{ *** PFD$INTERNAL_NAME
*copy pfd$internal_name
?? SKIP := 4 ??
?? TITLE := '*** PFD$ARCHIVE_DEFINITIONS ***', EJECT ??
*copyc pfd$archive_definitions
?? SKIP := 4 ??
{ *** PFD$CHARGE_ID
*copy pfd$charge_id
?? SKIP := 4 ??
{ *** PFD$CYCLE_STATISTICS
*copy pfd$cycle_statistics
?? TITLE := '*** PFT$DATE_TIME_OPTION, PFT$DATE_TIME ***', EJECT ??
{ *** PFT$DATE_TIME_OPTION
*copy pft$date_time_option
?? SKIP := 4 ??
{ *** PFT$DATE_TIME
*copy pft$date_time
?? TITLE := '*** PFT$PASSWORD_INFO, PFT$ATTACH_OR_CREATE_ACTION ***', EJECT ??
{ *** PFT$PASSWORD_INFO
*copy pft$password_info
?? SKIP := 4 ??
{ *** PFT$ATTACH_OR_CREATE_ACTION
*copy pft$attach_or_create_action
?? TITLE := '*** PFT$CHECKSUM, PFT$CATALOG_TYPES  *** ', EJECT ??
{ PFT$CHECKSUM
*copyc pft$checksum
?? SKIP := 4 ??
{ PFT$CATALOG_TYPES
*copyc pft$catalog_types
?? SKIP := 4 ??
{ PFT$CYCLE_COUNT
*copyc PFT$CYCLE_COUNT
?? TITLE := '*** PFT$RESTORE_CATALOG_STATUS, PFT$RETAINED_RESTORE_STATUS *** ', EJECT ??
*copyc PFT$RESTORE_CATALOG_STATUS
?? SKIP := 4 ??
*copyc PFT$RETAINED_RESTORE_STATUS
?? TITLE := '*** MEDIA INFO TYPES *** ', EJECT ??
*copyc pft$file_media_type
*copyc pft$catalog_media_description
*copyc pft$file_media_description
?? TITLE := '*** PFD$CATALOG ***', EJECT ??
*copyc pfd$catalog
?? TITLE := '*** PFD$CATALOG_INFO ***', EJECT ??
*copyc pfd$catalog_info
?? TITLE := '*** PFD$INFORMATION_SELECTIONS ***', EJECT ??
*copy pfd$information_selections
?? TITLE := '*** PFD$CATALOG_ACCESS ***', EJECT ??
*copy pfd$catalog_access
?? TITLE := '*** PFD$ROOT ***', EJECT ??
*copy pfd$root
?? TITLE := '*** PFD$QUEUED_INTERNAL_CATALOG ***', EJECT ??
*copy pfd$queued_internal_catalog
?? TITLE := '*** PFD$QUEUED_CATALOG_TABLE ***', EJECT ??
*copy pfd$queued_catalog_table
?? TITLE := '*** PFD$CATALOG_LOCATOR ***', EJECT ??
*copy pfd$catalog_locator
?? TITLE := '*** PFD$COMPLETE_PATH ***', EJECT ??
*copy pfd$complete_path
?? TITLE := '*** PFD$AUTHORITY ***', EJECT ??
*copy pfd$authority
?? TITLE := '*** PFT$OVERHAUL_CHOICES ***', EJECT ??
*copy pft$overhaul_choices
?? TITLE := '*** PFD$ATTACHED_PERMANENT_FILE_ID, PFD$ATTACHED_PF_TABLE ***', EJECT ??
{ *** PFD$ATTACHED_PERMANENT_FILE_ID
*copy pfd$attached_permanent_file_id
?? SKIP := 4 ??
{ *** PFD$ATTACHED_PF_TABLE
*copy pfd$attached_pf_table
?? TITLE := '*** PFD$CATALOG_ALARM_TABLE ***', EJECT ??
*copy pfd$catalog_alarm_table
?? TITLE := '*** PFD$TABLE_INFO ***', EJECT ??
*copy pfd$table_info
?? TITLE := '*** PFK$KEYPOINTS ***', EJECT ??
*copy pfk$keypoints
?? TITLE := '*** PFE$ERROR_CONDITION_CODES - EXTERNAL CONDITION CODES ***', EJECT ??
*copy pfe$error_condition_codes
?? TITLE := '*** PFE$EXTERNAL_ARCHIVE_CONDITIONS - EXTERNAL ARCHIVE CONDITION CODES ***', EJECT ??
*copy pfe$external_archive_conditions
?? TITLE := '*** PFE$SELECTION_ERRORS - PRODUCT CONDITION CODES ***', EJECT ??
*copy pfe$selection_errors
?? TITLE := '*** PFE$INTERNAL_ERROR_CONDITIONS - INTERNAL CONDITION CODES ***', EJECT ??
*copy pfe$internal_error_conditions
?? SKIP := 4 ??
MODEND pfm$permanent_file_definitions;
*DECK DECK=PFM$PERMANENT_FILE_TESTS EXPAND=TRUE

?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Permanent Files: Test Routines', ??
MODULE pfm$permanent_file_tests;

{
{ PURPOSE:
{   This module contains the processors for permanent file tests.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fsc$local
*copyc cle$all_must_be_used_alone
*copyc cle$ecc_file_reference
*copyc cle$ecc_parsing
*copyc cle$incompatible_params_given
*copyc cle$none_must_be_used_alone
*copyc cle$redundancy_in_selections
*copyc ost$status
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc clp$evaluate_parameters
*copyc fsp$change_cycle_damage
*copyc fsp$close_file
*copyc fsp$open_file
*copyc pfp$get_object_information
*copyc osp$set_status_abnormal

  PROCEDURE [XDCL] pfp$get_object_info_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE get_object_information, getoi (
{   file, f, catalog, c: file = $required
{   information_request, ir: (BY_NAME) list of key
{       all
{     keyend = all
{   output, o: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 2, 8, 11, 16, 8, 215],
    clc$command, 9, 4, 2, 0, 0, 0, 4, ''], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CATALOG                        ',clc$alias_entry, 1],
    ['F                              ',clc$alias_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['INFORMATION_REQUEST            ',clc$nominal_entry, 2],
    ['IR                             ',clc$abbreviation_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 60,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [44, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$file_type]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$information_request = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;


    VAR
      info_request: fst$goi_information_request,
      access_mode_selections: fst$file_access_options,
      local_status: ost$status,
      out_fid: amt$file_identifier,
      p_attachment_options: ^fst$attachment_options,
      segment_pointer: amt$segment_pointer;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_attachment_options: [1 .. 1];
    p_attachment_options^[1].selector := fsc$access_and_share_modes;
    p_attachment_options^[1].access_modes.selector := fsc$specific_access_modes;
    p_attachment_options^[1].access_modes.value := -$fst$file_access_options [];
    p_attachment_options^[1].share_modes.selector := fsc$specific_share_modes;
    p_attachment_options^[1].share_modes.value := $fst$file_access_options [];


    fsp$open_file (pvt [p$output].value^.file_value^, amc$segment, NIL, NIL, NIL, NIL,
          NIL, out_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /segment_open/
    BEGIN
      amp$get_segment_pointer (out_fid, amc$sequence_pointer, segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /segment_open/;
      IFEND;

      RESET segment_pointer.sequence_pointer;

      info_request.catalog_depth.depth_specification := fsc$specific_depth;
      info_request.catalog_depth.depth := 1;
      info_request.object_information_requests := $fst$goi_object_info_requests[fsc$goi_catalog_identity,
            fsc$goi_catalog_object_list, fsc$goi_file_identity, fsc$goi_file_object_list];

      pfp$get_object_information (pvt [p$file].value^.file_value^, info_request, {p_validation_criteria} NIL,
            segment_pointer.sequence_pointer, status);
      IF NOT status.normal THEN
        EXIT /segment_open/;
      IFEND;

      amp$set_segment_eoi (out_fid, segment_pointer, status);
    END /segment_open/;

    fsp$close_file (out_fid, local_status);

  PROCEND pfp$get_object_info_cmd;

?? TITLE := 'pfp$set_cycle_damaged_cmd', EJECT ??

  PROCEDURE [XDCL] pfp$set_cycle_damaged_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);




{ PROCEDURE (osm$setcd) set_cycle_damaged, setcd (
{   file, f: file = $required
{   password, pw: (BY_NAME, SECURE) any of
{       key
{         none
{       keyend
{       name
{     anyend = none
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: 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$name_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 9, 15, 22, 38, 126],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'OSM$SETCD'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['PASSWORD                       ',clc$nominal_entry, 2],
    ['PW                             ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'none'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$password = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      password: pft$password;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$password].value^.kind = clc$name THEN
      password := pvt [p$password].value^.name_value;
    ELSE { keyword = NONE }
      password := osc$null_name;
    IFEND;

    fsp$change_cycle_damage (pvt [p$file].value^.file_value^, password,
          $fst$cycle_damage_symptoms [fsc$media_image_inconsistent], status);
  PROCEND pfp$set_cycle_damaged_cmd;

?? TITLE := 'pfp$open_file_cmd', EJECT ??

  PROCEDURE [XDCL] pfp$open_file_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (osm$opef) open_file, opef (
{   file, f: file = $required
{   access_modes, access_mode, am: (BY_NAME) list of key
{       all
{       (append, a)
{       (execute, e)
{       (modify, m)
{       (read, r)
{       (shorten, s)
{       (write, w)
{     keyend = (read, execute)
{   share_modes, share_mode, sm: (BY_NAME) list of key
{       all, none
{       (append, a)
{       (execute, e)
{       (modify, m)
{       (read, r)
{       (shorten, s)
{       (write, w)
{     keyend = $optional
{   allowed_damage_conditions, adc: (BY_NAME) list of key
{       none
{       (media_image_inconsistent, mii)
{       (parent_catalog_restored, pcr)
{       (respf_modification_mismatch, rmm)
{     keyend = $optional
{   enable_media_damage_detection, emdd: boolean = false
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 13] of clt$keyword_specification,
        recend,
        default_value: string (15),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 7] of clt$keyword_specification,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 12, 16, 8, 51, 9, 567],
    clc$command, 13, 6, 1, 0, 0, 0, 6, 'OSM$OPEF'], [
    ['ACCESS_MODE                    ',clc$alias_entry, 2],
    ['ACCESS_MODES                   ',clc$nominal_entry, 2],
    ['ADC                            ',clc$abbreviation_entry, 4],
    ['ALLOWED_DAMAGE_CONDITIONS      ',clc$nominal_entry, 4],
    ['AM                             ',clc$abbreviation_entry, 2],
    ['EMDD                           ',clc$abbreviation_entry, 5],
    ['ENABLE_MEDIA_DAMAGE_DETECTION  ',clc$nominal_entry, 5],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['SHARE_MODE                     ',clc$alias_entry, 3],
    ['SHARE_MODES                    ',clc$nominal_entry, 3],
    ['SM                             ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 504,
  clc$optional_default_parameter, 0, 15],
{ PARAMETER 3
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 541,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 282,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 6
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [488, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [13], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['APPEND                         ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['EXECUTE                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['MODIFY                         ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['READ                           ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['SHORTEN                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['WRITE                          ', clc$nominal_entry, clc$normal_usage_entry, 7]]
      ]
    ,
    '(read, execute)'],
{ PARAMETER 3
    [[1, 0, clc$list_type], [525, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [14], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['APPEND                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['EXECUTE                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['MODIFY                         ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['READ                           ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['SHORTEN                        ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
      ['WRITE                          ', clc$nominal_entry, clc$normal_usage_entry, 8]]
      ]
    ],
{ PARAMETER 4
    [[1, 0, clc$list_type], [266, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [7], [
      ['MEDIA_IMAGE_INCONSISTENT       ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['MII                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['PARENT_CATALOG_RESTORED        ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['PCR                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['RESPF_MODIFICATION_MISMATCH    ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['RMM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4]]
      ]
    ],
{ PARAMETER 5
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$access_modes = 2,
      p$share_modes = 3,
      p$allowed_damage_conditions = 4,
      p$enable_media_damage_detection = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      allowed_cycle_damage_conditions: fst$cycle_damage_symptoms,
      fid: amt$file_identifier,
      access_mode_selections: fst$file_access_options,
      usage_selections: fst$file_access_options,
      share_selections: fst$file_access_options,
      p_attachment_options: ^fst$attachment_options;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_attachment_options: [1 .. 3];
    p_attachment_options^[1].selector := fsc$access_and_share_modes;
    p_attachment_options^[2].selector := fsc$exception_detection;
    p_attachment_options^[3].selector := fsc$allowed_exceptions;

    IF pvt [p$enable_media_damage_detection].specified AND
          pvt [p$enable_media_damage_detection].value^.boolean_value.value THEN
      p_attachment_options^ [2].exception_detection := $fst$cycle_damage_symptoms
            [fsc$media_image_inconsistent];
    ELSE
      p_attachment_options^ [2].exception_detection := $fst$cycle_damage_symptoms [];
    IFEND;

    handle_allowed_damage_condition (pvt [p$allowed_damage_conditions].value,
          allowed_cycle_damage_conditions, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    p_attachment_options^ [3].allowed_exceptions.damage_symptoms := allowed_cycle_damage_conditions;
    p_attachment_options^ [3].allowed_exceptions.access_conditions := $fst$file_access_conditions [];

    access_mode_selections := $fst$file_access_options [fsc$append, fsc$shorten, fsc$modify];

    handle_access_mode_or_share (pvt [p$access_modes].value, select_usage, usage_selections, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    IF pvt [p$share_modes].specified THEN
      handle_access_mode_or_share (pvt [p$share_modes].value, select_share, share_selections, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSEIF (usage_selections * access_mode_selections) <> $fst$file_access_options [] THEN
      share_selections := $fst$file_access_options [];
    ELSE
      share_selections := $fst$file_access_options [fsc$read, fsc$execute];
    IFEND;
    p_attachment_options^[1].access_modes.selector := fsc$specific_access_modes;
    p_attachment_options^[1].access_modes.value := usage_selections;

    p_attachment_options^[1].share_modes.selector := fsc$specific_share_modes;
    p_attachment_options^[1].share_modes.value := share_selections;


    fsp$open_file (pvt [p$file].value^.file_value^, amc$record, p_attachment_options, NIL, NIL, NIL,
          NIL, fid, status);

  PROCEND pfp$open_file_cmd;

?? TITLE := 'handle_access_mode_or_share', EJECT ??

{
{ PURPOSE:
{   This procedure processes the 'ACCESS_MODE' and 'SHARE_MODE' parameters for
{   all commands that contain  one or both of them.  One of the command
{   parameters is processed on each call to this procedure.  For any given
{   call, the caller will use only one of the output parameters; however, both
{   are always built since this procedure doesn't know which one the caller
{   wants.
{
{ NOTE:
{   The procedure assumes that pft$usage_selections and pft$share_selections
{   are "really" the same type.
{

  PROCEDURE handle_access_mode_or_share
    (    usage_share_value: ^clt$data_value;
         selections_kind: (select_usage, select_share);
     VAR usage_share_selections: fst$file_access_options;
     VAR status: ost$status);

    VAR
      access_mode_value: clt$keyword,
      local_usage_share_value: ^clt$data_value;


    usage_share_selections := $fst$file_access_options [];

    local_usage_share_value := usage_share_value;
    WHILE local_usage_share_value <> NIL DO
      access_mode_value := local_usage_share_value^.element_value^.keyword_value;
      IF access_mode_value = 'ALL' THEN
        usage_share_selections := -$fst$file_access_options [];
      ELSEIF access_mode_value = 'APPEND' THEN
        usage_share_selections := usage_share_selections + $fst$file_access_options [fsc$append];
      ELSEIF access_mode_value = 'EXECUTE' THEN
        usage_share_selections := usage_share_selections + $fst$file_access_options [fsc$execute];
      ELSEIF access_mode_value = 'MODIFY' THEN
        usage_share_selections := usage_share_selections + $fst$file_access_options [fsc$modify];
      ELSEIF access_mode_value = 'NONE' THEN
        IF usage_share_value^.link <> NIL THEN
          osp$set_status_abnormal ('CL', cle$none_must_be_used_alone, access_mode_value, status);
        IFEND;
        RETURN;
      ELSEIF access_mode_value = 'READ' THEN
        usage_share_selections := usage_share_selections + $fst$file_access_options [fsc$read];
      ELSEIF access_mode_value = 'SHORTEN' THEN
        usage_share_selections := usage_share_selections + $fst$file_access_options [fsc$shorten];
      ELSEIF access_mode_value = 'WRITE' THEN
        usage_share_selections := usage_share_selections + $fst$file_access_options
              [fsc$append, fsc$modify, fsc$shorten];
      IFEND;
      local_usage_share_value := local_usage_share_value^.link;
    WHILEND;

  PROCEND handle_access_mode_or_share;

?? TITLE := 'handle_allowed_damage_condition', EJECT ??

{
{ PURPOSE:
{   This procedure processes the 'ACCESS_MODE' and 'SHARE_MODE' parameters for
{   all commands that contain  one or both of them.  One of the command
{   parameters is processed on each call to this procedure.  For any given
{   call, the caller will use only one of the output parameters; however, both
{   are always built since this procedure doesn't know which one the caller
{   wants.
{
{ NOTE:
{   The procedure assumes that pft$usage_selections and pft$share_selections
{   are "really" the same type.
{

  PROCEDURE handle_allowed_damage_condition
    (    allowed_damage_value: ^clt$data_value;
     VAR allowed_damage_conditions: fst$cycle_damage_symptoms;
     VAR status: ost$status);

    VAR
      damage_condition_value: clt$keyword,
      local_allowed_damage_value: ^clt$data_value;


    allowed_damage_conditions := $fst$cycle_damage_symptoms [];

    local_allowed_damage_value := allowed_damage_value;
    WHILE local_allowed_damage_value <> NIL DO
      damage_condition_value := local_allowed_damage_value^.element_value^.keyword_value;
      IF damage_condition_value (1) = 'M' THEN {Media_image_inconsistent}
        allowed_damage_conditions := allowed_damage_conditions +
              $fst$cycle_damage_symptoms [fsc$media_image_inconsistent];
      ELSEIF damage_condition_value (1) = 'P' THEN {parent_catalog_restored}
        allowed_damage_conditions := allowed_damage_conditions +
              $fst$cycle_damage_symptoms [fsc$parent_catalog_restored];
      ELSEIF damage_condition_value (1) = 'R' THEN {respf_modification_mismatch}
        allowed_damage_conditions := allowed_damage_conditions +
              $fst$cycle_damage_symptoms [fsc$respf_modification_mismatch];
      ELSEIF damage_condition_value = 'NONE' THEN
        IF local_allowed_damage_value^.link <> NIL THEN
          osp$set_status_abnormal ('CL', cle$none_must_be_used_alone, damage_condition_value, status);
        IFEND;
        RETURN;
      IFEND;
      local_allowed_damage_value := local_allowed_damage_value^.link;
    WHILEND;

  PROCEND handle_allowed_damage_condition;
MODEND pfm$permanent_file_tests;

*DECK DECK=PFM$POINTER_CONVERSION_ROUTINES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE pfm$pointer_conversion_routines;
?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??

?? TITLE := '*** PFP$BUILD_AMD_LOCATOR ***', EJECT ??

  PROCEDURE [XDCL] pfp$build_amd_locator (
        p_physical_amd: pft$p_physical_amd;
        p_catalog_file: pft$p_catalog_file;
    VAR amd_locator: pft$amd_locator);

    VAR
      p_cell: ^cell;

    IF p_physical_amd = NIL THEN
      amd_locator.amd_size := 0;
    ELSE
      amd_locator.amd_size := #SIZE (p_physical_amd^.amd);
      p_cell := #LOC (p_physical_amd^);
      amd_locator.relative_cell_pointer := #REL (p_cell, p_catalog_file^);
    IFEND;

  PROCEND pfp$build_amd_locator;

?? TITLE := '*** PFP$BUILD_AMD_POINTER ***', EJECT ??

  PROCEDURE [XDCL] pfp$build_amd_pointer (
        amd_locator: pft$amd_locator;
        p_catalog_file: pft$p_catalog_file;
    VAR p_physical_amd: pft$p_physical_amd);

    VAR
      p_sequence:pft$p_sequence,
      p_sequence_record: pft$p_sequence_record;

    IF amd_locator.amd_size = 0 THEN
      p_physical_amd := NIL;
    ELSE
      p_sequence_record := #PTR (amd_locator.relative_cell_pointer, p_catalog_file^);
      p_sequence := ^p_sequence_record^.sequence;
      RESET p_sequence;
      NEXT p_physical_amd: [[REP amd_locator.amd_size OF cell]] IN p_sequence;
    IFEND;

  PROCEND pfp$build_amd_pointer;

?? TITLE := '*** PFP$BUILD_ARCHIVE_LIST_LOCATOR *** ', EJECT ??

  PROCEDURE [XDCL] pfp$build_archive_list_locator (
        p_archive_list: pft$p_archive_list;
        p_catalog_file: pft$p_catalog_file;
    VAR archive_list_locator: pft$archive_list_locator);

    VAR
      p_cell: ^cell;

    IF p_archive_list = NIL THEN
      archive_list_locator.archive_count := 0;
    ELSE
      archive_list_locator.archive_count := UPPERBOUND (p_archive_list^);
      p_cell := #LOC (p_archive_list^);
      archive_list_locator.relative_cell_pointer := #REL (p_cell, p_catalog_file^);
    IFEND;

  PROCEND pfp$build_archive_list_locator;

?? TITLE := '*** PFP$BUILD_ARCHIVE_LIST_POINTER ***', EJECT ??

  PROCEDURE [XDCL] pfp$build_archive_list_pointer (
        archive_list_locator: pft$archive_list_locator;
        p_catalog_file: pft$p_catalog_file;
    VAR p_archive_list: pft$p_archive_list);

    VAR
      p_sequence:pft$p_sequence,
      p_sequence_record: pft$p_sequence_record;

    IF archive_list_locator.archive_count = 0 THEN
      p_archive_list := NIL;
    ELSE
      p_sequence_record := #PTR (archive_list_locator.relative_cell_pointer, p_catalog_file^);
      p_sequence := ^p_sequence_record^.sequence;
      RESET p_sequence;
      NEXT p_archive_list: [1 .. archive_list_locator.archive_count] IN p_sequence;
    IFEND;

  PROCEND pfp$build_archive_list_pointer;

?? TITLE := '*** PFP$BUILD_CYCLE_LIST_LOCATOR ***', EJECT ??

  PROCEDURE [XDCL] pfp$build_cycle_list_locator (p_cycle_list: pft$p_cycle_list;
        p_catalog_file: pft$p_catalog_file;
    VAR cycle_list_locator: pft$cycle_list_locator);

    VAR
      p_cell: ^cell;

    IF (p_cycle_list = NIL) THEN
      cycle_list_locator.cycle_count := 0;
    ELSE
      cycle_list_locator.cycle_count := UPPERBOUND (p_cycle_list^);
      p_cell := #LOC (p_cycle_list^);
      cycle_list_locator.relative_cell_pointer := #REL (p_cell, p_catalog_file^);
    IFEND;
  PROCEND pfp$build_cycle_list_locator;
?? TITLE := '*** PFP$BUILD_CYCLE_LIST_POINTER ***', EJECT ??

  PROCEDURE [XDCL] pfp$build_cycle_list_pointer (cycle_list_locator: pft$cycle_list_locator;
        p_catalog_file: pft$p_catalog_file;
    VAR p_cycle_list: pft$p_cycle_list);

    VAR
      p_sequence_record: pft$p_sequence_record,
      p_sequence: pft$p_sequence;

    IF (cycle_list_locator.cycle_count = 0) THEN
      p_cycle_list := NIL;
    ELSE
      p_sequence_record := #PTR (cycle_list_locator.relative_cell_pointer, p_catalog_file^);
      p_sequence := ^p_sequence_record^.sequence;
      RESET p_sequence;
      NEXT p_cycle_list: [1 .. cycle_list_locator.cycle_count] IN p_sequence;
    IFEND;
  PROCEND pfp$build_cycle_list_pointer;
?? TITLE := '*** PFP$BUILD_FILE_LABEL_LOCATOR ***', EJECT ??

  PROCEDURE [XDCL] pfp$build_file_label_locator (p_file_label: pft$p_stored_file_label;
        p_catalog_file: pft$p_catalog_file;
    VAR file_label_locator: pft$file_label_locator);

    VAR
      p_cell: ^cell;

    IF (p_file_label = NIL) THEN
      file_label_locator.file_label_size := 0;
    ELSE
      file_label_locator.file_label_size := #SIZE (p_file_label^.file_label);
      p_cell := #LOC (p_file_label^);
      file_label_locator.relative_cell_pointer := #REL (p_cell, p_catalog_file^);
    IFEND;
  PROCEND pfp$build_file_label_locator;
?? TITLE := '*** PFP$BUILD_FILE_LABEL_POINTER ***', EJECT ??

  PROCEDURE [XDCL] pfp$build_file_label_pointer (file_label_locator: pft$file_label_locator;
        p_catalog_file: pft$p_catalog_file;
    VAR p_file_label: pft$p_stored_file_label);

    VAR
      p_sequence_record: pft$p_sequence_record,
      p_sequence: pft$p_sequence;

    IF (file_label_locator.file_label_size = 0) THEN
      p_file_label := NIL;
    ELSE
      p_sequence_record := #PTR (file_label_locator.relative_cell_pointer, p_catalog_file^);
      p_sequence := ^p_sequence_record^.sequence;
      RESET p_sequence;
      NEXT p_file_label: [[REP file_label_locator.file_label_size OF cell]] IN p_sequence;
    IFEND;
  PROCEND pfp$build_file_label_pointer;
?? TITLE := '*** PFP$BUILD_FMD_LOCATOR ***', EJECT ??

  PROCEDURE [XDCL] pfp$build_fmd_locator (p_physical_fmd: pft$p_physical_fmd;
        p_catalog_file: pft$p_catalog_file;
    VAR fmd_locator: pft$fmd_locator);

    VAR
      p_cell: ^cell;

    IF p_physical_fmd = NIL THEN
      fmd_locator.fmd_size := 0;
    ELSE
      fmd_locator.fmd_size := #SIZE (p_physical_fmd^.fmd);
      p_cell := #LOC (p_physical_fmd^);
      fmd_locator.relative_cell_pointer := #REL (p_cell, p_catalog_file^);
    IFEND;
  PROCEND pfp$build_fmd_locator;
?? TITLE := '*** PFP$BUILD_FMD_POINTER ***', EJECT ??

  PROCEDURE [XDCL] pfp$build_fmd_pointer (fmd_locator: pft$fmd_locator;
        p_catalog_file: pft$p_catalog_file;
    VAR p_physical_fmd: pft$p_physical_fmd);

    VAR
      p_sequence_record: pft$p_sequence_record,
      p_sequence: pft$p_sequence;

    IF (fmd_locator.fmd_size = 0) THEN
      p_physical_fmd := NIL;
    ELSE
      p_sequence_record := #PTR (fmd_locator.relative_cell_pointer, p_catalog_file^);
      p_sequence := ^p_sequence_record^.sequence;
      RESET p_sequence;
      NEXT p_physical_fmd: [[REP fmd_locator.fmd_size OF cell]] IN p_sequence;
    IFEND;
  PROCEND pfp$build_fmd_pointer;
?? TITLE := '*** PFP$BUILD_LOG_LIST_LOCATOR ***', EJECT ??

  PROCEDURE [XDCL] pfp$build_log_list_locator (p_log_list: pft$p_log_list;
        p_catalog_file: pft$p_catalog_file;
    VAR log_list_locator: pft$log_list_locator);

    VAR
      p_cell: ^cell;

    IF (p_log_list = NIL) THEN
      log_list_locator.log_count := 0;
    ELSE
      log_list_locator.log_count := UPPERBOUND (p_log_list^);
      p_cell := #LOC (p_log_list^);
      log_list_locator.relative_cell_pointer := #REL (p_cell, p_catalog_file^);
    IFEND;
  PROCEND pfp$build_log_list_locator;
?? TITLE := '*** PFP$BUILD_LOG_LIST_POINTER ***', EJECT ??

  PROCEDURE [XDCL] pfp$build_log_list_pointer (log_list_locator: pft$log_list_locator;
        p_catalog_file: pft$p_catalog_file;
    VAR p_log_list: pft$p_log_list);

    VAR
      p_sequence_record: pft$p_sequence_record,
      p_sequence: pft$p_sequence;

    IF (log_list_locator.log_count = 0) THEN
      p_log_list := NIL;
    ELSE
      p_sequence_record := #PTR (log_list_locator.relative_cell_pointer, p_catalog_file^);
      p_sequence := ^p_sequence_record^.sequence;
      RESET p_sequence;
      NEXT p_log_list: [1 .. log_list_locator.log_count] IN p_sequence;
    IFEND;
  PROCEND pfp$build_log_list_pointer;
?? TITLE := '*** PFP$BUILD_MAINFRAM_LIST_LOCATOR ***', EJECT ??
   PROCEDURE [XDCL] pfp$build_mainfram_list_locator
    (    p_mainframe_list: {input} ^pft$mainframe_usage_list;
         p_catalog_file: {input^} pft$p_catalog_file;
     VAR mainframe_list_locator: pft$mainframe_list_locator);

    VAR
      p_cell: ^cell;

    IF (p_mainframe_list = NIL) THEN
      mainframe_list_locator.mainframe_count := 0;
    ELSE
      mainframe_list_locator.mainframe_count := UPPERBOUND (p_mainframe_list^);
      p_cell := #LOC (p_mainframe_list^);
      mainframe_list_locator.relative_cell_pointer := #REL (p_cell, p_catalog_file^);
    IFEND;
   PROCEND;
?? TITLE := '*** PFP$BUILD_MAINFRAM_LIST_POINTER ***', EJECT ??

  PROCEDURE [XDCL] pfp$build_mainfram_list_pointer
    (    mainframe_list_locator: pft$mainframe_list_locator;
         p_catalog_file: {input^} pft$p_catalog_file;
     VAR p_mainframe_list: {output} ^pft$mainframe_usage_list);

    VAR
      p_sequence_record: pft$p_sequence_record,
      p_sequence: pft$p_sequence;

    IF (mainframe_list_locator.mainframe_count = 0) THEN
      p_mainframe_list := NIL;
    ELSE
      p_sequence_record := #PTR (mainframe_list_locator.relative_cell_pointer, p_catalog_file^);
      p_sequence := ^p_sequence_record^.sequence;
      RESET p_sequence;
      NEXT p_mainframe_list: [1 .. mainframe_list_locator.mainframe_count] IN p_sequence;
    IFEND;
  PROCEND pfp$build_mainfram_list_pointer;

?? TITLE := '*** PFP$BUILD_OBJECT_LIST_LOCATOR ***', EJECT ??

  PROCEDURE [XDCL] pfp$build_object_list_locator
    (    sorted_object_count: pft$object_count;
         free_sorted_object_count: pft$object_count;
         p_object_list: {input} pft$p_object_list;
         p_catalog_file: {input} pft$p_catalog_file;
     VAR object_list_locator: pft$object_list_locator);

    VAR
      p_cell: ^cell;

    IF p_object_list = NIL THEN
      object_list_locator.object_count := 0;
      object_list_locator.sorted_object_count := 0;
      object_list_locator.free_sorted_object_count := 0;
    ELSE
      object_list_locator.object_count := UPPERBOUND (p_object_list^);
      object_list_locator.sorted_object_count := sorted_object_count;
      object_list_locator.free_sorted_object_count := free_sorted_object_count;
      p_cell := #LOC (p_object_list^);
      object_list_locator.relative_cell_pointer := #REL (p_cell, p_catalog_file^);
    IFEND;
  PROCEND pfp$build_object_list_locator;

?? TITLE := '*** PFP$BUILD_OBJECT_LIST_POINTER ***', EJECT ??

  PROCEDURE [XDCL] pfp$build_object_list_pointer (object_list_locator: pft$object_list_locator;
        p_catalog_file: pft$p_catalog_file;
    VAR p_object_list: pft$p_object_list);

    VAR
      p_sequence_record: pft$p_sequence_record,
      p_sequence: pft$p_sequence;

    IF (object_list_locator.object_count = 0) THEN
      p_object_list := NIL;
    ELSE
      p_sequence_record := #PTR (object_list_locator.relative_cell_pointer, p_catalog_file^);
      p_sequence := ^p_sequence_record^.sequence;
      RESET p_sequence;
      NEXT p_object_list: [1 .. object_list_locator.object_count] IN p_sequence;
    IFEND;
  PROCEND pfp$build_object_list_pointer;
?? TITLE := '*** PFP$BUILD_PERMIT_LIST_LOCATOR ***', EJECT ??

  PROCEDURE [XDCL] pfp$build_permit_list_locator (p_permit_list: pft$p_permit_list;
        p_catalog_file: pft$p_catalog_file;
    VAR permit_list_locator: pft$permit_list_locator);

    VAR
      p_cell: ^cell;

    IF (p_permit_list = NIL) THEN
      permit_list_locator.permit_count := 0;
    ELSE
      permit_list_locator.permit_count := UPPERBOUND (p_permit_list^);
      p_cell := #LOC (p_permit_list^);
      permit_list_locator.relative_cell_pointer := #REL (p_cell, p_catalog_file^);
    IFEND;
  PROCEND pfp$build_permit_list_locator;
?? TITLE := '*** PFP$BUILD_PERMIT_LIST_POINTER ***', EJECT ??

  PROCEDURE [XDCL] pfp$build_permit_list_pointer (permit_list_locator: pft$permit_list_locator;
        p_catalog_file: pft$p_catalog_file;
    VAR p_permit_list: pft$p_permit_list);

    VAR
      p_sequence_record: pft$p_sequence_record,
      p_sequence: pft$p_sequence;

    IF (permit_list_locator.permit_count = 0) THEN
      p_permit_list := NIL;
    ELSE
      p_sequence_record := #PTR (permit_list_locator.relative_cell_pointer, p_catalog_file^);
      p_sequence := ^p_sequence_record^.sequence;
      RESET p_sequence;
      NEXT p_permit_list: [1 .. permit_list_locator.permit_count] IN p_sequence;
    IFEND;
  PROCEND pfp$build_permit_list_pointer;
?? SKIP := 4 ??
MODEND pfm$pointer_conversion_routines;
*DECK DECK=PFM$PROCESS_STORAGE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Permanent Files: Process Storage' ??
MODULE pfm$process_storage;
?? NEWTITLE := 'Global Declarations referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avc$accounting_statistics
*copyc ave$validation_interface_errors
*copyc cle$ecc_command_processing
*copyc fst$goi_object_information
*copyc oss$job_paged_literal
*copyc pfd$complete_path
*copyc pfe$error_condition_codes
?? POP ??
*copyc avp$change_user_pf_space_limit
*copyc avp$family_administrator
*copyc avp$replace_total_limits
*copyc avp$system_administrator
*copyc avp$validation_level
*copyc clp$convert_integer_to_string
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc clp$get_processing_phase
*copyc fsp$build_file_ref_from_elems
*copyc i#current_sequence_position
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pfp$get_object_information
*copyc pmp$date_time_compare
*copyc pmp$get_family_names
*copyc pmp$get_user_identification
*copyc sfp$emit_statistic
*copyc pfv$space_character

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations declared by this module', EJECT ??

  CONST
    include_radix = TRUE,
    process_storage_command = 'PROCESS_STORAGE',
    radix = 10,
    update_perm_file_space_command = 'UPDATE_PERM_FILE_SPACE_LIMIT';

  TYPE
    project_info_type = (pit_catalog_info, pit_cycle_info);

  TYPE
    project_information = record
      info_type: project_info_type,
      account_name: avt$account_name,
      project_name: avt$project_name,
      allocated_size: integer,
      online_eoi_size: integer,
      offline_eoi_size: integer,
      offline_total_eoi_size: integer,
      count: integer, {holds number of files or catalogs depending on info type}
      next_project_info: ^project_information,
    recend;

  TYPE
    user_information = record
      cycle_allocated_size: integer,
      cycle_online_eoi_size: integer,
      cycle_offline_eoi_size: integer,
      cycle_offline_total_eoi_size: integer,
      cycle_count: integer,
      catalog_allocated_size: integer,
      catalog_online_eoi_size: integer,
      catalog_count: integer,
    recend;

  VAR
    catalog_information_request: [STATIC, READ, oss$job_paged_literal] fst$goi_information_request :=
          [[fsc$specific_depth, 1], $fst$goi_object_info_requests
          [fsc$goi_catalog_identity, fsc$goi_catalog_device_info, fsc$goi_catalog_info, fsc$goi_catalog_size,
          fsc$goi_catalog_object_list, fsc$goi_file_object_list, fsc$goi_file_identity, fsc$goi_file_info,
          fsc$goi_cycle_object_list, fsc$goi_cycle_identity, fsc$goi_archive_info, fsc$goi_cycle_device_info,
          fsc$goi_cycle_info, fsc$goi_cycle_size]];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pfp$process_storage', EJECT ??

  PROCEDURE [XDCL] pfp$process_storage
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ NOTE:
{   Procedure pfp$_update_perm_file_space_lim has essentially the same design as this procedure.
{ Any changes made here should be considered for inclusion in that procedure as well.

{ PROCEDURE (osm$pros) process_storage, pros (
{   family, families, f: any of
{       key
{         all
{       keyend
{       list of name
{     anyend = all
{   processing_option, processing_options, po: any of
{       key
{         all
{       keyend
{       list of key
{         (emit_space_statistics, ess)
{         (update_limits, ul)
{       keyend
{     anyend = all
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 4] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 3, 15, 15, 16, 689],
    clc$command, 7, 3, 0, 0, 0, 0, 3, 'OSM$PROS'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FAMILIES                       ',clc$alias_entry, 1],
    ['FAMILY                         ',clc$nominal_entry, 1],
    ['PO                             ',clc$abbreviation_entry, 2],
    ['PROCESSING_OPTION              ',clc$nominal_entry, 2],
    ['PROCESSING_OPTIONS             ',clc$alias_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 235,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[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]]
      ],
    171, [[1, 0, clc$list_type], [155, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [4], [
        ['EMIT_SPACE_STATISTICS          ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['ESS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['UL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['UPDATE_LIMITS                  ', clc$nominal_entry, clc$normal_usage_entry, 2]]
        ]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$family = 1,
      p$processing_option = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      active_family_list: ^pmt$family_name_list,
      active_family_list_count: pmt$family_name_count,
      current_processing_option: ^clt$data_value,
      emit_space_statistics: boolean,
      family_catalog_info_p: ^fst$goi_object,
      family_catalog_reference: fst$path,
      family_found: boolean,
      family_list: ^pmt$family_name_list,
      family_name: ost$family_name,
      family_object_info_p: ^fst$goi_object_information,
      first_project_info: ^project_information,
      index1: integer,
      index2: integer,
      information_request: [STATIC, READ, oss$job_paged_literal] fst$goi_information_request :=
            [[fsc$specific_depth, 1], $fst$goi_object_info_requests
            [fsc$goi_catalog_identity, fsc$goi_catalog_size, fsc$goi_catalog_object_list]],
      limit_entries_array: ^array [1 .. * ] of avt$total_limit_update_record,
      limit_info_p: ^SEQ ( * ),
      limit_segment_pointer: amt$segment_pointer,
      master_catalog_array_p: ^fst$goi_object_list,
      master_catalog_path: array [1 .. 2] of pft$name,
      number_of_errors: integer,
      number_of_limit_entries: integer,
      object_index: integer,
      object_info_p: ^SEQ ( * ),
      object_segment_pointer: amt$segment_pointer,
      project_info_p: ^SEQ ( * ),
      project_segment_pointer: amt$segment_pointer,
      specified_family_list: ^clt$data_value,
      sub_object_info_p: ^SEQ ( * ),
      update_limits: boolean,
      user_info: user_information,
      user_name: ost$user_name,
      validation_level: avt$validation_level;

?? NEWTITLE := '[INLINE] append_to_descr_data', EJECT ??

{ PURPOSE
{   This procedure is used to append information to a descriptive data string that will be placed on a file
{   space statistic.

    PROCEDURE [INLINE] append_to_descr_data
      (    separator: string ( * <= osc$max_string_size);
           string_to_append: string ( * <= osc$max_string_size);
       VAR descriptive_data: ost$string);

      VAR
        result: boolean,
        first_blank: integer;

      IF STRLENGTH (separator) <> 0 THEN
        descriptive_data.value (descriptive_data.size + 1, STRLENGTH (separator)) := separator;
        descriptive_data.size := descriptive_data.size + STRLENGTH (separator);
      IFEND;
      IF STRLENGTH (string_to_append) <> 0 THEN
        #SCAN (pfv$space_character, string_to_append, first_blank, {ignore} result);
        descriptive_data.value (descriptive_data.size + 1, first_blank - 1) :=
              string_to_append (1, first_blank - 1);
        descriptive_data.size := descriptive_data.size + first_blank - 1;
      IFEND;

    PROCEND append_to_descr_data;
?? OLDTITLE ??
*copy pfp$add_to_project_info
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that the end emit space statistics statistic
{   is emitted and the scratch segments are deleted.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      mmp$delete_scratch_segment (object_segment_pointer, ignore_status);
      mmp$delete_scratch_segment (project_segment_pointer, ignore_status);
      mmp$delete_scratch_segment (limit_segment_pointer, ignore_status);

      IF emit_space_statistics THEN
        sfp$emit_statistic (avc$end_emit_space_statistics, 'Process storage terminated abnormally.', NIL,
              ignore_status);
      IFEND;

    PROCEND condition_handler;
?? OLDTITLE ??
*copy pfp$create_scratch_segments
?? NEWTITLE := 'process_catalog', EJECT ??

{ PURPOSE
{   This procedure processes a catalog object entry that was obtained by get object information.  A statistic
{   for the catalog itself is emitted and information is added to the project totals and user totals for the
{   master catalog.

    PROCEDURE process_catalog
      (    catalog_path: ^pft$path;
           object_entry: ^fst$goi_object;
           object_info_p: ^SEQ ( * );
       VAR status: ost$status);

      VAR
        allocated_size: integer,
        catalog_object_entry_p: ^fst$goi_object,
        catalog_object_info_p: ^fst$goi_object_information,
        catalog_reference: fst$path,
        current_catalog_index: pft$catalog_path_index,
        current_object_info_p: ^SEQ ( * ),
        number_of_files: integer,
        number_of_subcatalogs: integer,
        object_index: integer,
        object_path: ^pft$path,
        object_status: ost$status,
        online_eoi_size: integer,
        path_index: pft$catalog_path_index,
        statistic_counters: sft$counters,
        statistic_descr_data: ost$string,
        sub_object_array_p: ^fst$goi_object_list,
        sub_object_info_p: ^SEQ ( * );

?? NEWTITLE := 'process_file', EJECT ??

{ PURPOSE
{   This procedure processes a file object entry that was obtained by get object information.  A statistic for
{   each cycle of the file is emitted and information is added to the project totals and user totals for the
{   master catalog.

      PROCEDURE process_file
        (    file_path: pft$path;
             file_object_entry: ^fst$goi_object;
         VAR status: ost$status);

        VAR
          allocated_size: integer,
          archive_index: integer,
          comparison_result: pmt$comparison_result,
          cycle_number_string: ost$string,
          cycle_statistic_counters: sft$counters,
          cycle_statistic_descr_data: ost$string,
          object_index: integer,
          offline_eoi_size: integer,
          offline_total_eoi_size: integer,
          online_eoi_size: integer;

?? NEWTITLE := 'record_file_error', EJECT ??

        PROCEDURE record_file_error
          (    error_path: ^pft$path;
               cycle_number: pft$cycle_number;
           VAR number_of_errors: integer;
           VAR status: ost$status);

          VAR
            ignore_status: ost$status,
            path: fst$path,
            recorded_status: ost$status;

          number_of_errors := number_of_errors + 1;
          fsp$build_file_ref_from_elems (error_path, path, ignore_status);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$skipped_file, process_storage_command,
                recorded_status);
          osp$append_status_file (osc$status_parameter_delimiter, path, recorded_status);
          osp$append_status_integer (osc$status_parameter_delimiter, cycle_number, radix, NOT include_radix,
                recorded_status);
          osp$generate_error_message (recorded_status, ignore_status);
          osp$generate_error_message (status, ignore_status);

        PROCEND record_file_error;

?? OLDTITLE, EJECT ??

        status.normal := TRUE;

{ Process each cycle of the file.

        IF file_object_entry^.cycle_object_list <> NIL THEN

        /process_cycle/
          FOR object_index := 1 TO UPPERBOUND (file_object_entry^.cycle_object_list^) DO
            CASE file_object_entry^.cycle_object_list^ [object_index].cycle_device_class OF
            = rmc$mass_storage_device =

{ Get file size information.

              allocated_size := 0;
              online_eoi_size := 0;
              offline_eoi_size := 0;
              offline_total_eoi_size := 0;
              IF file_object_entry^.cycle_object_list^ [object_index].cycle_device_information^.
                    mass_storage_device_info.resides_online THEN
                online_eoi_size := file_object_entry^.cycle_object_list^ [object_index].cycle_size^;
                allocated_size := file_object_entry^.cycle_object_list^ [object_index].
                      cycle_device_information^.mass_storage_device_info.bytes_allocated;
              IFEND;

{ Get the archived sizes from each "current" archive information list entry.

              IF file_object_entry^.cycle_object_list^ [object_index].archive_information_list <> NIL THEN
                IF file_object_entry^.cycle_object_list^ [object_index].cycle_device_information^.
                      mass_storage_device_info.resides_online THEN

{ If the file cycle resides online, check to see if it has been modified since the last archive.  If so,
{ then do not include it as part of the size of files that are duplicated.

                /check_for_archived_files/
                  FOR archive_index := 1 TO UPPERBOUND (file_object_entry^.cycle_object_list^ [object_index].
                        archive_information_list^) DO
                    pmp$date_time_compare (file_object_entry^.cycle_object_list^ [object_index].
                          cycle_information^.data_modification_date_time,
                          file_object_entry^.cycle_object_list^ [object_index].
                          archive_information_list^ [archive_index].archive_entry.archive_date_time,
                          comparison_result, status);
                    IF NOT status.normal THEN
                      record_file_error (^file_path, file_object_entry^.cycle_object_list^ [object_index].
                            cycle_number, number_of_errors, status);
                      CYCLE /process_cycle/;
                    IFEND;
                    IF comparison_result = pmc$right_is_greater THEN
                      offline_total_eoi_size := file_object_entry^.cycle_object_list^ [object_index].
                            archive_information_list^ [archive_index].archive_entry.file_size;
                      EXIT /check_for_archived_files/;
                    IFEND;
                  FOREND /check_for_archived_files/;
                ELSE

{ In this case, the file is archived and released - it should be counted in both offline counters.

                  offline_total_eoi_size := file_object_entry^.cycle_object_list^ [object_index].cycle_size^;
                  offline_eoi_size := file_object_entry^.cycle_object_list^ [object_index].cycle_size^;
                IFEND;

              IFEND;

              IF emit_space_statistics THEN
                clp$convert_integer_to_string (file_object_entry^.cycle_object_list^ [object_index].
                      cycle_number, 10, FALSE, cycle_number_string, status);
                IF NOT status.normal THEN
                  record_file_error (^file_path, file_object_entry^.cycle_object_list^ [object_index].
                        cycle_number, number_of_errors, status);
                  CYCLE /process_cycle/;
                IFEND;

{ Set up the statistic counters.

                PUSH cycle_statistic_counters: [1 .. 6];
                cycle_statistic_counters^ [1] := online_eoi_size;
                cycle_statistic_counters^ [2] := 0; {attach status}
                cycle_statistic_counters^ [3] := UPPERBOUND (file_path) - 2; {depth}
                cycle_statistic_counters^ [4] := allocated_size;
                cycle_statistic_counters^ [5] := offline_eoi_size;
                cycle_statistic_counters^ [6] := offline_total_eoi_size;

{ Set up the statistic descriptive data.

                cycle_statistic_descr_data.value := '';
                cycle_statistic_descr_data.size := 0;
                append_to_descr_data ('', family_name, cycle_statistic_descr_data);
                append_to_descr_data (', ', user_name, cycle_statistic_descr_data);
                append_to_descr_data (', ', file_object_entry^.file_information^.account,
                      cycle_statistic_descr_data);
                append_to_descr_data (', ', file_object_entry^.file_information^.project,
                      cycle_statistic_descr_data);
                append_to_descr_data (', ', '', cycle_statistic_descr_data);
                append_to_descr_data (', ', file_object_entry^.file_name, cycle_statistic_descr_data);
                append_to_descr_data ('.', cycle_number_string.value (1, cycle_number_string.size),
                      cycle_statistic_descr_data);

{ Emit a file cycle statistic.

                sfp$emit_statistic (avc$cycle, cycle_statistic_descr_data.
                      value (1, cycle_statistic_descr_data.size), cycle_statistic_counters, status);
                IF NOT status.normal THEN
                  record_file_error (^file_path, file_object_entry^.cycle_object_list^ [object_index].
                        cycle_number, number_of_errors, status);
                  CYCLE /process_cycle/;
                IFEND;
              IFEND;

{ Add the current file information to the account, project and user info.

              pfp$add_to_project_info (pit_cycle_info, file_object_entry^.file_information^.account,
                    osc$null_name, online_eoi_size, offline_eoi_size, offline_total_eoi_size, allocated_size,
                    first_project_info);
              pfp$add_to_project_info (pit_cycle_info, file_object_entry^.file_information^.account,
                    file_object_entry^.file_information^.project, online_eoi_size, offline_eoi_size,
                    offline_total_eoi_size, allocated_size, first_project_info);
              user_info.cycle_online_eoi_size := user_info.cycle_online_eoi_size + online_eoi_size;
              user_info.cycle_offline_eoi_size := user_info.cycle_offline_eoi_size + offline_eoi_size;
              user_info.cycle_offline_total_eoi_size := user_info.cycle_offline_total_eoi_size +
                    offline_total_eoi_size;
              user_info.cycle_allocated_size := user_info.cycle_allocated_size + allocated_size;
              user_info.cycle_count := user_info.cycle_count + 1;
            ELSE

{ Device type not currently reported on.

            CASEND;
          FOREND /process_cycle/;
        IFEND;

      PROCEND process_file;

?? OLDTITLE, EJECT ??

      status.normal := TRUE;

{ Allocate a path to hold the next level object.

      current_catalog_index := UPPERBOUND (catalog_path^);
      PUSH object_path: [1 .. current_catalog_index + 1];
      FOR path_index := 1 TO current_catalog_index DO
        object_path^ [path_index] := catalog_path^ [path_index];
      FOREND;

      fsp$build_file_ref_from_elems (catalog_path, catalog_reference, status);
      IF NOT status.normal THEN
        pfp$record_catalog_error (catalog_path, process_storage_command, number_of_errors, status);
        RETURN;
      IFEND;

      current_object_info_p := object_info_p;

{ Place the object information for the current catalog into the beginning of the object info sequence.

      pfp$get_object_information (catalog_reference, catalog_information_request, {validation_criteria} NIL,
            current_object_info_p, status);
      IF NOT status.normal THEN
        pfp$record_catalog_error (catalog_path, process_storage_command, number_of_errors, status);
        RETURN;
      IFEND;

{ Insert a sequence to be used for the next level of object information into the object info sequence.

      NEXT sub_object_info_p: [[REP #SIZE (current_object_info_p^) -
            i#current_sequence_position (current_object_info_p) OF cell]] IN current_object_info_p;
      RESET sub_object_info_p;

{ Retrieve the sub_object array for the current catalog.

      RESET current_object_info_p;
      NEXT catalog_object_info_p IN current_object_info_p;
      catalog_object_entry_p := catalog_object_info_p^.object;
      sub_object_array_p := catalog_object_entry_p^.subcatalog_and_file_object_list;

{ Get the catalog size information.

      allocated_size := catalog_object_entry_p^.catalog_device_information^.mass_storage_device_info.
            bytes_allocated;
      online_eoi_size := catalog_object_entry_p^.catalog_size^;

{ If catalog archiving is ever implemented code must be added here.

      IF emit_space_statistics THEN

{ Add up the number of files and/or subcatalogs in the current catalog.

        number_of_files := 0;
        number_of_subcatalogs := 0;
        IF sub_object_array_p <> NIL THEN
          FOR object_index := LOWERBOUND (sub_object_array_p^) TO UPPERBOUND (sub_object_array_p^) DO
            IF sub_object_array_p^ [object_index].object_type = fsc$goi_file_object THEN
              number_of_files := number_of_files + 1;
            ELSEIF sub_object_array_p^ [object_index].object_type = fsc$goi_catalog_object THEN
              number_of_subcatalogs := number_of_subcatalogs + 1;
            IFEND;
          FOREND;
        IFEND;

{ Set up the statistic counters.

        PUSH statistic_counters: [1 .. 7];
        statistic_counters^ [1] := online_eoi_size;
        statistic_counters^ [2] := number_of_files;
        statistic_counters^ [3] := number_of_subcatalogs;
        statistic_counters^ [4] := UPPERBOUND (catalog_path^) - 1;
        statistic_counters^ [5] := allocated_size;
        statistic_counters^ [6] := 0; {offline_eoi_size}
        statistic_counters^ [7] := 0; {offline_total_eoi_size}

{ Set up the statistic descriptive data.

        statistic_descr_data.value := '';
        statistic_descr_data.size := 0;
        append_to_descr_data ('', family_name, statistic_descr_data);
        append_to_descr_data (', ', user_name, statistic_descr_data);
        append_to_descr_data (', ', catalog_object_entry_p^.catalog_information^.account,
              statistic_descr_data);
        append_to_descr_data (', ', catalog_object_entry_p^.catalog_information^.project,
              statistic_descr_data);
        append_to_descr_data (', ', '', statistic_descr_data);
        append_to_descr_data (', ', catalog_path^ [UPPERBOUND (catalog_path^)], statistic_descr_data);

{ Emit a catalog statistic for the current catalog.

        sfp$emit_statistic (avc$catalog, statistic_descr_data.value (1, statistic_descr_data.size),
              statistic_counters, status);
        IF NOT status.normal THEN
          pfp$record_catalog_error (catalog_path, process_storage_command, number_of_errors, status);
          RETURN;
        IFEND;
      IFEND;

{ Add the current catalog information to the account, project and user info.

      pfp$add_to_project_info (pit_catalog_info, catalog_object_entry_p^.catalog_information^.account,
            osc$null_name, online_eoi_size, {offline_eoi_size} 0, {offline_total_eoi_size} 0, allocated_size,
            first_project_info);
      pfp$add_to_project_info (pit_catalog_info, catalog_object_entry_p^.catalog_information^.account,
            catalog_object_entry_p^.catalog_information^.project, online_eoi_size, {offline_eoi_size} 0,
            {offline_total_eoi_size} 0, allocated_size, first_project_info);
      user_info.catalog_online_eoi_size := user_info.catalog_online_eoi_size + online_eoi_size;
      user_info.catalog_allocated_size := user_info.catalog_allocated_size + allocated_size;
      user_info.catalog_count := user_info.catalog_count + 1;

{ Process the sub objects within the current catalog.

      IF sub_object_array_p <> NIL THEN
        FOR object_index := LOWERBOUND (sub_object_array_p^) TO UPPERBOUND (sub_object_array_p^) DO
          IF sub_object_array_p^ [object_index].object_type = fsc$goi_file_object THEN
            object_path^ [current_catalog_index + 1] := sub_object_array_p^ [object_index].file_name;
            process_file (object_path^, ^sub_object_array_p^ [object_index], object_status);
          ELSEIF sub_object_array_p^ [object_index].object_type = fsc$goi_catalog_object THEN
            object_path^ [current_catalog_index + 1] := sub_object_array_p^ [object_index].catalog_name;
            process_catalog (object_path, ^sub_object_array_p^ [object_index], sub_object_info_p,
                  object_status);
          IFEND;
        FOREND;
      IFEND;

    PROCEND process_catalog;
?? OLDTITLE ??
?? NEWTITLE := 'process_project_info', EJECT ??

{ PURPOSE
{   This procedure reads through the linked list of project information entries for a user, emits
{   account_member and project member statistics, and writes out account , account member, project and project
{   member limit updates into a sequence of limit information to be used to update the permanent file space
{   accumulator in the validation file.

    PROCEDURE process_project_info
      (    family_name: ost$family_name;
           user_name: ost$user_name;
       VAR first_project_info {I/O} : ^project_information;
       VAR status: ost$status);

      VAR
        current_project_info: ^project_information,
        project_info_counters: sft$counters,
        project_info_descr_data: ost$string;

      current_project_info := first_project_info;

      WHILE current_project_info <> NIL DO

{ Set up the statistic counters.

        PUSH project_info_counters: [1 .. 5];
        project_info_counters^ [1] := current_project_info^.online_eoi_size;
        project_info_counters^ [2] := current_project_info^.count;
        project_info_counters^ [3] := current_project_info^.allocated_size;
        project_info_counters^ [4] := current_project_info^.offline_eoi_size;
        project_info_counters^ [5] := current_project_info^.offline_total_eoi_size;

{ Set up the statistic descriptive data.

        project_info_descr_data.value := '';
        project_info_descr_data.size := 0;
        append_to_descr_data ('', family_name, project_info_descr_data);
        append_to_descr_data (', ', user_name, project_info_descr_data);
        append_to_descr_data (', ', current_project_info^.account_name, project_info_descr_data);
        append_to_descr_data (', ', current_project_info^.project_name, project_info_descr_data);
        append_to_descr_data (', ', '', project_info_descr_data);

        IF current_project_info^.project_name = osc$null_name THEN

{ If the project is null for this entry then it is account information.

          IF emit_space_statistics THEN

{ Emit an account member statistic.

            IF current_project_info^.info_type = pit_catalog_info THEN
              sfp$emit_statistic (avc$account_member_catalog, project_info_descr_data.
                    value (1, project_info_descr_data.size), project_info_counters, status);
            ELSE
              sfp$emit_statistic (avc$account_member_cycle, project_info_descr_data.
                    value (1, project_info_descr_data.size), project_info_counters, status);
            IFEND;
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
          IF (update_limits) AND (current_project_info^.info_type = pit_cycle_info) AND
                (validation_level > avc$user_level) THEN

{ Write out an account limit entry.

            pfp$write_limit_entry (family_name, current_project_info^.account_name, osc$null_name,
                  osc$null_name, current_project_info^.allocated_size, number_of_limit_entries, limit_info_p);

{ Write out an account member limit entry.

            pfp$write_limit_entry (family_name, current_project_info^.account_name, osc$null_name, user_name,
                  current_project_info^.allocated_size, number_of_limit_entries, limit_info_p);
          IFEND;
        ELSE

{ This entry is project information.

          IF emit_space_statistics THEN

{ Emit a project member statistic.

            IF current_project_info^.info_type = pit_catalog_info THEN
              sfp$emit_statistic (avc$project_member_catalog, project_info_descr_data.
                    value (1, project_info_descr_data.size), project_info_counters, status);
            ELSE
              sfp$emit_statistic (avc$project_member_cycle, project_info_descr_data.
                    value (1, project_info_descr_data.size), project_info_counters, status);
            IFEND;
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

          IF (update_limits) AND (current_project_info^.info_type = pit_cycle_info) AND
                (validation_level > avc$account_level) THEN

{ Write out a project limit entry.

            pfp$write_limit_entry (family_name, current_project_info^.account_name,
                  current_project_info^.project_name, osc$null_name, current_project_info^.allocated_size,
                  number_of_limit_entries, limit_info_p);

{ Write out a project member limit entry.

            pfp$write_limit_entry (family_name, current_project_info^.account_name,
                  current_project_info^.project_name, user_name, current_project_info^.allocated_size,
                  number_of_limit_entries, limit_info_p);
          IFEND;
        IFEND;
        current_project_info := current_project_info^.next_project_info;
      WHILEND;
      first_project_info := NIL;

    PROCEND process_project_info;
?? OLDTITLE ??
?? NEWTITLE := 'process_user_info', EJECT ??

{ PURPOSE
{   This procedure emits user cycle and catalog statistics, and writes out user limit updates into a sequence
{   of limit information to be used to update the permanent file space accumulator in the validation file.

    PROCEDURE process_user_info
      (VAR user_info: user_information;
       VAR status: ost$status);

      VAR
        user_info_counters: sft$counters,
        user_info_descr_data: ost$string;

      IF emit_space_statistics THEN

{ Set up the statistic descriptive data.

        user_info_descr_data.value := '';
        user_info_descr_data.size := 0;
        append_to_descr_data ('', family_name, user_info_descr_data);
        append_to_descr_data (', ', user_name, user_info_descr_data);
        append_to_descr_data (', ', '', user_info_descr_data);
        append_to_descr_data (', ', '', user_info_descr_data);
        append_to_descr_data (', ', '', user_info_descr_data);

{ Set up the user catalog statistic counters.

        PUSH user_info_counters: [1 .. 5];
        user_info_counters^ [1] := user_info.catalog_online_eoi_size;
        user_info_counters^ [2] := user_info.catalog_count;
        user_info_counters^ [3] := user_info.catalog_allocated_size;
        user_info_counters^ [4] := 0; {offline_eoi_size}
        user_info_counters^ [5] := 0; {offline_total_eoi_size}

{ Emit a user catalog statistic.

        sfp$emit_statistic (avc$user_catalog, user_info_descr_data.value (1, user_info_descr_data.size),
              user_info_counters, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Set up the user cycle statistic counters.

        user_info_counters^ [1] := user_info.cycle_online_eoi_size;
        user_info_counters^ [2] := user_info.cycle_count;
        user_info_counters^ [3] := user_info.cycle_allocated_size;
        user_info_counters^ [4] := user_info.cycle_offline_eoi_size;
        user_info_counters^ [5] := user_info.cycle_offline_total_eoi_size;

{ Emit a user cycle statistic.

        sfp$emit_statistic (avc$user_cycle, user_info_descr_data.value (1, user_info_descr_data.size),
              user_info_counters, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF update_limits THEN

{ Write out a user limit entry.

        pfp$write_limit_entry (family_name, avc$high_value_name, avc$high_value_name, user_name,
              user_info.cycle_allocated_size, number_of_limit_entries, limit_info_p);
      IFEND;

{ Reset the user information totals for the next user.

      user_info.catalog_allocated_size := 0;
      user_info.catalog_online_eoi_size := 0;
      user_info.catalog_count := 0;
      user_info.cycle_allocated_size := 0;
      user_info.cycle_online_eoi_size := 0;
      user_info.cycle_offline_eoi_size := 0;
      user_info.cycle_offline_total_eoi_size := 0;
      user_info.cycle_count := 0;

    PROCEND process_user_info;

?? OLDTITLE ??
*copy pfp$record_catalog_error
*copy pfp$write_limit_entry

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal ('CL', cle$command_aborted,
            'Only System Administrator may execute PROCESS_STORAGE.', status);
      RETURN;
    IFEND;

    validation_level := avp$validation_level ();
    number_of_limit_entries := 0;
    number_of_errors := 0;

{ Get the processing options.

    emit_space_statistics := FALSE;
    #SPOIL (emit_space_statistics);
    update_limits := FALSE;
    IF pvt [p$processing_option].value^.kind = clc$keyword THEN { ALL was specified }
      emit_space_statistics := TRUE;
      update_limits := TRUE;
    ELSE {clc$list_kind}
      current_processing_option := pvt [p$processing_option].value;
      WHILE current_processing_option <> NIL DO
        IF current_processing_option^.element_value^.keyword_value = 'EMIT_SPACE_STATISTICS' THEN
          emit_space_statistics := TRUE;
        ELSEIF current_processing_option^.element_value^.keyword_value = 'UPDATE_LIMITS' THEN
          update_limits := TRUE;
        IFEND;
        current_processing_option := current_processing_option^.link;
      WHILEND;
    IFEND;

{ Get the list of active families for this system.

    active_family_list_count := 100;
    REPEAT
      PUSH active_family_list: [1 .. active_family_list_count];
      pmp$get_family_names (active_family_list^, active_family_list_count, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    UNTIL active_family_list_count <= UPPERBOUND (active_family_list^);

{ Get the list of families to be processed.

    IF pvt [p$family].value^.kind = clc$keyword THEN {ALL was specified}

{ Get the family list from the active family list if all was specified.

      PUSH family_list: [1 .. active_family_list_count];
      family_list^ := active_family_list^;
    ELSE { Get the family list from the specified family list.}

      specified_family_list := pvt [p$family].value;
      PUSH family_list: [1 .. clp$count_list_elements (specified_family_list)];
      FOR index1 := 1 TO UPPERBOUND (family_list^) DO
        family_list^ [index1] := specified_family_list^.element_value^.name_value;
        family_found := FALSE;

{ Verify that each specified family is a valid active family.

      /search_loop/
        FOR index2 := 1 TO active_family_list_count DO
          IF active_family_list^ [index2] = family_list^ [index1] THEN
            family_found := TRUE;
            EXIT /search_loop/;
          IFEND;
        FOREND /search_loop/;
        IF NOT family_found THEN
          osp$set_status_abnormal ('PF', pfe$unknown_family, family_list^ [index1], status);
          RETURN;
        IFEND;
        specified_family_list := pvt [p$family].value^.link;
      FOREND;
    IFEND;

    IF emit_space_statistics THEN
      sfp$emit_statistic (avc$begin_emit_space_statistics, ' ', NIL, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    pfp$create_scratch_segments (object_segment_pointer, project_segment_pointer, limit_segment_pointer,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    #SPOIL (object_segment_pointer, project_segment_pointer, limit_segment_pointer);

{ Set up the catalog information request one time which will be used by process catalog
{ for each getoi request.

    osp$establish_block_exit_hndlr (^condition_handler);

    RESET object_segment_pointer.sequence_pointer;
    object_info_p := object_segment_pointer.sequence_pointer;
    RESET project_segment_pointer.sequence_pointer;
    project_info_p := project_segment_pointer.sequence_pointer;
    RESET limit_segment_pointer.sequence_pointer;
    limit_info_p := limit_segment_pointer.sequence_pointer;

{ Loop through the families to be processed.

    FOR index1 := 1 TO UPPERBOUND (family_list^) DO
      family_name := family_list^ [index1];
      family_catalog_reference := ':';
      family_catalog_reference (2, * ) := family_name;

{ Reset the object info scratch segment to the beginning when starting on a new family.

      RESET object_info_p;

{ Place the object information for the family into the beginning of the object info sequence.

      pfp$get_object_information (family_catalog_reference, information_request, {validation_criteria} NIL,
            object_info_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Insert a sequence to be used later for the sub_object information into the object info sequence immediately
{ after the family object information.

      NEXT sub_object_info_p: [[REP #SIZE (object_info_p^) - i#current_sequence_position (object_info_p) OF
            cell]] IN object_info_p;
      RESET sub_object_info_p;

{ Retrieve the master catalog array from the family object info.

      RESET object_info_p;
      NEXT family_object_info_p IN object_info_p;
      family_catalog_info_p := family_object_info_p^.object;
      master_catalog_array_p := family_catalog_info_p^.subcatalog_and_file_object_list;

      first_project_info := NIL;
      user_info.catalog_allocated_size := 0;
      user_info.catalog_online_eoi_size := 0;
      user_info.catalog_count := 0;
      user_info.cycle_allocated_size := 0;
      user_info.cycle_online_eoi_size := 0;
      user_info.cycle_offline_eoi_size := 0;
      user_info.cycle_offline_total_eoi_size := 0;
      user_info.cycle_count := 0;

{ Process each master catalog within the master catalog array.

    /process_master_catalog/
      FOR object_index := LOWERBOUND (master_catalog_array_p^) TO UPPERBOUND (master_catalog_array_p^) DO
        RESET project_info_p;
        user_name := master_catalog_array_p^ [object_index].catalog_name;

        master_catalog_path [1] := family_name;
        master_catalog_path [2] := user_name;

{ Process catalog will recursively loop through the catalog structure for each master catalog.

        process_catalog (^master_catalog_path, ^master_catalog_array_p^ [object_index], sub_object_info_p,
              status);

        IF NOT status.normal THEN
          CYCLE /process_master_catalog/;
        IFEND;

{ After the complete master catalog has been processed the member and user information collected for the user
{ is processed.

        process_project_info (family_name, user_name, first_project_info, status);
        IF NOT status.normal THEN
          pfp$record_catalog_error (^master_catalog_path, process_storage_command, number_of_errors, status);
          CYCLE /process_master_catalog/;
        IFEND;
        process_user_info (user_info, status);
        IF NOT status.normal THEN
          pfp$record_catalog_error (^master_catalog_path, process_storage_command, number_of_errors, status);
        IFEND;
      FOREND /process_master_catalog/;

    FOREND;

    IF update_limits THEN
      RESET limit_info_p;
      NEXT limit_entries_array: [1 .. number_of_limit_entries] IN limit_info_p;

      avp$replace_total_limits (avc$permanent_file_space_limit, limit_entries_array, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    IF emit_space_statistics THEN
      sfp$emit_statistic (avc$end_emit_space_statistics, ' ', NIL, {ignore} status);
    IFEND;
    mmp$delete_scratch_segment (object_segment_pointer, {ignore} status);
    mmp$delete_scratch_segment (project_segment_pointer, {ignore} status);
    mmp$delete_scratch_segment (limit_segment_pointer, {ignore} status);

    IF number_of_errors = 0 THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$process_storage_errors, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, number_of_errors, radix, NOT include_radix,
            status);
    IFEND;

  PROCEND pfp$process_storage;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pfp$_update_perm_file_space_lim', EJECT ??

  PROCEDURE [XDCL] pfp$_update_perm_file_space_lim
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PURPOSE:
{   This procedure is the command processor for the update_perm_file_space_limit command.
{
{ DESIGN:
{   The design of this procedure is essentially the same as that of procedure pfp$process_storage,
{ except that it works for only one user on one family, processing options cannot be specified by
{ the caller and it does not emit statistics.

{ PROCEDURE (osm$updpfsl) update_perm_file_space_limit, updpfsl (
{   user, u: name = $job(login_user)
{   family, f: name = $job(login_family)
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (16),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
        default_value: string (18),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 5, 27, 9, 2, 51, 915],
    clc$command, 5, 3, 0, 0, 0, 0, 3, 'OSM$UPDPFSL'], [
    ['F                              ',clc$abbreviation_entry, 2],
    ['FAMILY                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['U                              ',clc$abbreviation_entry, 1],
    ['USER                           ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 16],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_default_parameter, 0, 18],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    '$job(login_user)'],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size],
    '$job(login_family)'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$user = 1,
      p$family = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      active_family_list: ^pmt$family_name_list,
      active_family_list_count: pmt$family_name_count,
      family_found: boolean,
      family_name: ost$family_name,
      first_project_info: ^project_information,
      index1: integer,
      job_processing_phase: clt$processing_phase,
      limit_entries_array: ^array [1 .. * ] of avt$total_limit_update_record,
      limit_info_p: ^SEQ ( * ),
      limit_segment_pointer: amt$segment_pointer,
      master_catalog_path: array [1 .. 2] of pft$name,
      number_of_errors: integer,
      number_of_limit_entries: integer,
      object_index: integer,
      object_info_p: ^SEQ ( * ),
      object_segment_pointer: amt$segment_pointer,
      project_segment_pointer: amt$segment_pointer,
      sub_object_info_p: ^SEQ ( * ),
      user_identification: ost$user_identification,
      user_info: user_information,
      user_name: ost$user_name,
      validation_level: avt$validation_level;

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that the scratch segments are deleted.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      mmp$delete_scratch_segment (object_segment_pointer, ignore_status);
      mmp$delete_scratch_segment (project_segment_pointer, ignore_status);
      mmp$delete_scratch_segment (limit_segment_pointer, ignore_status);

    PROCEND condition_handler;
?? OLDTITLE ??
*copy pfp$create_scratch_segments
?? NEWTITLE := 'process_catalog', EJECT ??

{ PURPOSE
{   This procedure processes a catalog object entry that was obtained by get object information.
{   Information is added to the user totals for the master catalog.

    PROCEDURE process_catalog
      (    catalog_path: ^pft$path;
           object_info_p: ^SEQ ( * );
       VAR status: ost$status);

      VAR
        allocated_size: integer,
        catalog_object_entry_p: ^fst$goi_object,
        catalog_object_info_p: ^fst$goi_object_information,
        catalog_reference: fst$path,
        current_catalog_index: pft$catalog_path_index,
        current_object_info_p: ^SEQ ( * ),
        number_of_files: integer,
        number_of_subcatalogs: integer,
        object_index: integer,
        object_path: ^pft$path,
        object_status: ost$status,
        path_index: pft$catalog_path_index,
        sub_object_array_p: ^fst$goi_object_list,
        sub_object_info_p: ^SEQ ( * );

?? NEWTITLE := 'process_file', EJECT ??

{ PURPOSE
{   This procedure processes a file object entry that was obtained by get object information.
{   Information is added to the user total for the master catalog.

      PROCEDURE process_file
        (    file_path: pft$path;
             file_object_entry: ^fst$goi_object;
         VAR status: ost$status);

        VAR
          allocated_size: integer,
          archive_index: integer,
          comparison_result: pmt$comparison_result,
          cycle_number_string: ost$string,
          object_index: integer;

?? NEWTITLE := 'record_file_error', EJECT ??

        PROCEDURE record_file_error
          (    error_path: ^pft$path;
               cycle_number: pft$cycle_number;
           VAR number_of_errors: integer;
           VAR status: ost$status);

          VAR
            ignore_status: ost$status,
            path: fst$path,
            recorded_status: ost$status;

          number_of_errors := number_of_errors + 1;
          fsp$build_file_ref_from_elems (error_path, path, ignore_status);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$skipped_file,
                update_perm_file_space_command, recorded_status);
          osp$append_status_file (osc$status_parameter_delimiter, path, recorded_status);
          osp$append_status_integer (osc$status_parameter_delimiter, cycle_number, radix, NOT include_radix,
                recorded_status);
          osp$generate_error_message (recorded_status, ignore_status);
          osp$generate_error_message (status, ignore_status);

        PROCEND record_file_error;

?? OLDTITLE, EJECT ??

        status.normal := TRUE;

{ Process each cycle of the file.

        IF file_object_entry^.cycle_object_list <> NIL THEN

        /process_cycle/
          FOR object_index := 1 TO UPPERBOUND (file_object_entry^.cycle_object_list^) DO
            CASE file_object_entry^.cycle_object_list^ [object_index].cycle_device_class OF
            = rmc$mass_storage_device =

{ Get file size information.

              allocated_size := 0;
              IF file_object_entry^.cycle_object_list^ [object_index].cycle_device_information^.
                    mass_storage_device_info.resides_online THEN
                allocated_size := file_object_entry^.cycle_object_list^ [object_index].
                      cycle_device_information^.mass_storage_device_info.bytes_allocated;
              IFEND;

{ Since offline files are not counted toward the permanent file space limit, do not get that info.

              user_info.cycle_allocated_size := user_info.cycle_allocated_size + allocated_size;
            ELSE

{ Device type not currently reported on.

            CASEND;
          FOREND /process_cycle/;
        IFEND;

      PROCEND process_file;

?? OLDTITLE, EJECT ??

      status.normal := TRUE;

{ Allocate a path to hold the next level object.

      current_catalog_index := UPPERBOUND (catalog_path^);
      PUSH object_path: [1 .. current_catalog_index + 1];
      FOR path_index := 1 TO current_catalog_index DO
        object_path^ [path_index] := catalog_path^ [path_index];
      FOREND;

      fsp$build_file_ref_from_elems (catalog_path, catalog_reference, status);
      IF NOT status.normal THEN
        pfp$record_catalog_error (catalog_path, update_perm_file_space_command, number_of_errors, status);
        RETURN;
      IFEND;

      current_object_info_p := object_info_p;

{ Place the object information for the current catalog into the beginning of the object info sequence.

      pfp$get_object_information (catalog_reference, catalog_information_request, {validation_criteria} NIL,
            current_object_info_p, status);
      IF NOT status.normal THEN
        pfp$record_catalog_error (catalog_path, update_perm_file_space_command, number_of_errors, status);
        RETURN;
      IFEND;

{ Insert a sequence to be used for the next level of object information into the object info sequence.

      NEXT sub_object_info_p: [[REP #SIZE (current_object_info_p^) -
            i#current_sequence_position (current_object_info_p) OF cell]] IN current_object_info_p;
      RESET sub_object_info_p;

{ Retrieve the sub_object array for the current catalog.

      RESET current_object_info_p;
      NEXT catalog_object_info_p IN current_object_info_p;
      catalog_object_entry_p := catalog_object_info_p^.object;
      sub_object_array_p := catalog_object_entry_p^.subcatalog_and_file_object_list;

{ Get the catalog size information.

      allocated_size := catalog_object_entry_p^.catalog_device_information^.mass_storage_device_info.
            bytes_allocated;

{ If catalog archiving is ever implemented code must be added here.

{ Add the current catalog information to the account, project and user info.

      user_info.catalog_allocated_size := user_info.catalog_allocated_size + allocated_size;

{ Process the sub objects within the current catalog.

      IF sub_object_array_p <> NIL THEN
        FOR object_index := LOWERBOUND (sub_object_array_p^) TO UPPERBOUND (sub_object_array_p^) DO
          IF sub_object_array_p^ [object_index].object_type = fsc$goi_file_object THEN
            object_path^ [current_catalog_index + 1] := sub_object_array_p^ [object_index].file_name;
            process_file (object_path^, ^sub_object_array_p^ [object_index], object_status);
          ELSEIF sub_object_array_p^ [object_index].object_type = fsc$goi_catalog_object THEN
            object_path^ [current_catalog_index + 1] := sub_object_array_p^ [object_index].catalog_name;
            process_catalog (object_path, sub_object_info_p, object_status);
          IFEND;
        FOREND;
      IFEND;

    PROCEND process_catalog;
?? OLDTITLE ??
*copy pfp$record_catalog_error

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    user_name := pvt [p$user].value^.name_value;
    family_name := pvt [p$family].value^.name_value;

    IF NOT (avp$system_administrator () OR avp$family_administrator ()) THEN
      clp$get_processing_phase (job_processing_phase, status);
      IF (NOT status.normal) OR (job_processing_phase <> clc$system_epilog_phase) THEN
        pmp$get_user_identification (user_identification, status);
        IF (NOT status.normal) OR (user_identification.user <> user_name) OR (user_identification.family <>
              family_name) THEN
          osp$set_status_condition (ave$insufficient_authority, status);
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    validation_level := avp$validation_level ();
    number_of_limit_entries := 0;
    number_of_errors := 0;

{ Get the list of active families for this system.

    active_family_list_count := 100;
    REPEAT
      PUSH active_family_list: [1 .. active_family_list_count];
      pmp$get_family_names (active_family_list^, active_family_list_count, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    UNTIL active_family_list_count <= UPPERBOUND (active_family_list^);

    family_found := FALSE;

{ Verify that the specified family is a valid active family.

  /search_loop/
    FOR index1 := 1 TO active_family_list_count DO
      IF active_family_list^ [index1] = family_name THEN
        family_found := TRUE;
        EXIT /search_loop/;
      IFEND;
    FOREND /search_loop/;
    IF NOT family_found THEN
      osp$set_status_abnormal ('PF', pfe$unknown_family, family_name, status);
      RETURN;
    IFEND;

    pfp$create_scratch_segments (object_segment_pointer, project_segment_pointer, limit_segment_pointer,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    #SPOIL (object_segment_pointer, project_segment_pointer, limit_segment_pointer);

{ Set up the catalog information request one time which will be used by process catalog
{ for each getoi request.

    osp$establish_block_exit_hndlr (^condition_handler);

    RESET object_segment_pointer.sequence_pointer;
    object_info_p := object_segment_pointer.sequence_pointer;
    RESET limit_segment_pointer.sequence_pointer;
    limit_info_p := limit_segment_pointer.sequence_pointer;

    RESET object_info_p;

    user_info.catalog_allocated_size := 0;
    user_info.catalog_online_eoi_size := 0;
    user_info.catalog_count := 0;
    user_info.cycle_allocated_size := 0;
    user_info.cycle_online_eoi_size := 0;
    user_info.cycle_offline_eoi_size := 0;
    user_info.cycle_offline_total_eoi_size := 0;
    user_info.cycle_count := 0;

    master_catalog_path [1] := family_name;
    master_catalog_path [2] := user_name;

{ Process catalog will recursively loop through the catalog structure.

    process_catalog (^master_catalog_path, object_info_p, status);
    IF status.normal THEN
      avp$change_user_pf_space_limit (family_name, ^user_info.cycle_allocated_size, user_name, status);
    IFEND;

    osp$disestablish_cond_handler;

    mmp$delete_scratch_segment (object_segment_pointer, {ignore} status);
    mmp$delete_scratch_segment (project_segment_pointer, {ignore} status);
    mmp$delete_scratch_segment (limit_segment_pointer, {ignore} status);

    IF number_of_errors = 0 THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$process_storage_errors, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, number_of_errors, radix, NOT include_radix,
            status);
    IFEND;

  PROCEND pfp$_update_perm_file_space_lim;
?? OLDTITLE ??

MODEND pfm$process_storage;
*DECK DECK=PFM$PROGRAM_INTERFACE_PROCESSOR EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Permanent Files : Ring 3 Interfaces' ??
MODULE pfm$program_interface_processor;

{ PURPOSE:
{   This module contains the 23d interfaces.  Parameter validation is performed
{   in this module.

?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dmt$error_condition_codes
*copyc dmt$file_information
*copyc fmt$removable_media_req_info
*copyc fsc$local
*copyc fsc$max_path_element_size
*copyc fsc$max_path_elements
*copyc fsc$max_path_size
*copyc fse$open_validation_errors
*copyc fse$system_conditions
*copyc fse$vxve_exception_conditions
*copyc fsk$keypoints
*copyc fst$date_time
*copyc fst$device_class
*copyc fst$file_changes
*copyc fst$path_element_name
*copyc fst$retention
*copyc jmc$system_family
*copyc ofe$error_codes
*copyc osd$virtual_address
*copyc ose$heap_full_exceptions
*copyc oss$job_paged_literal
*copyc oss$task_shared
*copyc ost$caller_identifier
*copyc pfc$max_shared_queue
*copyc pfc$movc_insuf_space
*copyc pfc$movc_no_space
*copyc pfc$null_shared_queue
*copyc pfc$shared_queues
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$get_object_info_errors
*copyc pfe$internal_error_conditions
*copyc pfk$keypoints
*copyc pft$purge_cycle_options
*copyc pft$reserved_cycles
*copyc pft$retained_restore_status
*copyc pft$retrieve_option
*copyc pft$site_archive_option
*copyc pft$site_backup_option
*copyc pft$site_release_option
*copyc pft$variant_path
*copyc rme$class_validation_errors
*copyc rme$request_mass_storage
*copyc rmt$device_class
*copyc std$active_set_table
*copyc ste$error_condition_codes
?? POP ??
?? EJECT ??
*copyc avp$family_administrator
*copyc avp$get_name_value
*copyc avp$ring_min
*copyc avp$security_option_active
*copyc avp$system_administrator
*copyc bap$fetch_tape_validation
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_integer_to_rjstring
*copyc clp$date_time_compare
*copyc clp$validate_name
*copyc clp$validate_new_file_name
*copyc cmp$class_in_volume
*copyc cmp$get_ms_volume_info
*copyc cmp$get_ms_volumes
*copyc dfp$check_self_serving_job
*copyc dfp$locate_served_family
*copyc dmp$get_file_info
*copyc dmv$active_volume_table
*copyc dsp$get_data_from_rdf
*copyc dsp$store_data_in_rdf
*copyc fsp$evaluate_file_reference
*copyc gfp$get_segment_sfid
*copyc jmp$get_scheduling_admin_status
*copyc jmp$operator_job
*copyc mmp$open_file_segment
*copyc mmp$verify_access
*copyc ofp$format_operator_menu
*copyc osp$add_family
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$delete_family
*copyc osp$get_family_names_by_set
*copyc osp$get_set_name
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$verify_system_privilege
*copyc pfi$convert_cycle_reference
*copyc pfi$convert_password
*copyc pfi$get_family_from_fs_struct
*copyc pfp$convert_archive_ident
*copyc pfp$convert_fs_to_complete_path
*copyc pfp$convert_fs_to_pft$path
*copyc pfp$convert_pf_path_to_fs_path
*copyc pfp$convert_pf_to_fs_structure
*copyc pfp$convert_pft$path_to_fs_path
*copyc pfp$convert_pft$path_to_fs_str
*copyc pfp$convert_pft$path_to_string
*copyc pfp$detach_all_catalogs
*copyc pfp$find_cycle_array
*copyc pfp$find_cycle_array_version_2
*copyc pfp$find_next_info_record
*copyc pfp$find_permit_array
*copyc pfp$get_eval_file_ref_mast_cat
*copyc pfp$get_authority
*copyc pfp$get_ownership
*copyc pfp$get_permit_level
*copyc pfp$locate_group_info_record
*copyc pfp$log_error
*copyc pfp$process_unexpected_status
*copyc pfp$r1_get_catalog_alarm_table
*copyc pfp$r2_append_rem_media_vsn
*copyc pfp$r2_df_client_app_rem_me_vsn
*copyc pfp$r2_attach
*copyc pfp$r2_attach_or_create_file
*copyc pfp$r2_build_sorted_dfl
*copyc pfp$r2_change
*copyc pfp$r2_change_catalog_name
*copyc pfp$r2_change_cycle_damage
*copyc pfp$r2_change_cycle_date_time
*copyc pfp$r2_change_file
*copyc pfp$r2_change_res_to_releasable
*copyc pfp$r2_define
*copyc pfp$r2_define_catalog
*copyc pfp$r2_define_data
*copyc pfp$r2_delete_all_arch_entries
*copyc pfp$r2_delete_archive_entry
*copyc pfp$r2_delete_catalog_permit
*copyc pfp$r2_delete_permit
*copyc pfp$r2_detach_reserved_cycles
*copyc pfp$r2_df_client_change
*copyc pfp$r2_df_client_change_cy_dam
*copyc pfp$r2_df_client_change_cy_dt
*copyc pfp$r2_df_client_change_file
*copyc pfp$r2_df_client_change_res_rel
*copyc pfp$r2_df_client_define
*copyc pfp$r2_df_client_define_catalog
*copyc pfp$r2_df_client_define_data
*copyc pfp$r2_df_client_del_all_arc_en
*copyc pfp$r2_df_client_del_arch_entry
*copyc pfp$r2_df_client_delete_permit
*copyc pfp$r2_df_client_get_family_set
*copyc pfp$r2_df_client_get_famit_info
*copyc pfp$r2_df_client_get_info
*copyc pfp$r2_df_client_get_mcat_info
*copyc pfp$r2_df_client_mark_rel_cand
*copyc pfp$r2_df_client_permit
*copyc pfp$r2_df_client_purge
*copyc pfp$r2_df_client_purge_catalog
*copyc pfp$r2_df_client_put_arch_entry
*copyc pfp$r2_df_client_put_arch_info
*copyc pfp$r2_df_client_put_cycle_info
*copyc pfp$r2_df_client_put_item_info
*copyc pfp$r2_df_client_release_data
*copyc pfp$r2_df_client_rep_arch_entry
*copyc pfp$r2_df_client_rep_rem_me_fmd
*copyc pfp$r2_df_client_resolve
*copyc pfp$r2_df_client_save_rel_label
*copyc pfp$r2_dm_attach_item
*copyc pfp$r2_flush_catalog
*copyc pfp$r2_get_attached_pf_table
*copyc pfp$r2_get_catalog_segment
*copyc pfp$r2_get_family_info
*copyc pfp$r2_get_item_info
*copyc pfp$r2_get_master_catalog_info
*copyc pfp$r2_get_move_obj_device_info
*copyc pfp$r2_get_multi_item_info
*copyc pfp$r2_get_object_information
*copyc pfp$r2_get_queued_catalog_table
*copyc pfp$r2_get_stored_fmd
*copyc pfp$r2_get_stored_fmd_size
*copyc pfp$r2_mark_release_candidate
*copyc pfp$r2_overhaul_catalog
*copyc pfp$r2_overhaul_set
*copyc pfp$r2_permit
*copyc pfp$r2_permit_catalog
*copyc pfp$r2_physically_move_catalog
*copyc pfp$r2_physically_move_cycle
*copyc pfp$r2_purge
*copyc pfp$r2_purge_catalog
*copyc pfp$r2_purge_object
*copyc pfp$r2_put_archive_entry
*copyc pfp$r2_put_archive_info
*copyc pfp$r2_put_catalog_segment
*copyc pfp$r2_put_catalog_media_info
*copyc pfp$r2_put_cycle_info
*copyc pfp$r2_put_family_info
*copyc pfp$r2_put_file_media_info
*copyc pfp$r2_put_item_info
*copyc pfp$r2_put_master_catalog_info
*copyc pfp$r2_recreate_system_catalog
*copyc pfp$r2_release_data
*copyc pfp$r2_replace_archive_entry
*copyc pfp$r2_replace_rem_media_fmd
*copyc pfp$r2_resolve_path
*copyc pfp$r2_save_released_file_label
*copyc pfp$r2_validate_catalog_exists
*copyc pfp$system_privilege
*copyc pfv$debug_catalog_access
*copyc pfv$permit_level
*copyc pmp$compute_date_time
*copyc pmp$compute_date_time_increment
*copyc pmp$get_account_project
*copyc pmp$get_compact_date_time
*copyc pmp$get_job_names
*copyc pmp$get_pseudo_mainframe_id
*copyc pmp$get_unique_name
*copyc pmp$get_user_identification
*copyc pmp$log_ascii
*copyc pmp$verify_compact_date
*copyc pmp$verify_compact_time
*copyc pmp$wait
*copyc rmp$build_mass_storage_info
*copyc sfp$accumulate_file_space
*copyc sfp$auditing_operation
*copyc sfp$emit_audit_statistic
*copyc stp$get_active_set_list
*copyc stp$get_volumes_in_set
*copyc stp$get_volumes_set_name
*copyc stp$search_ast_by_set
*copyc stv$system_set_name

?? TITLE := '  Global Declarations Declared by this module', EJECT ??

  CONST
    catalog_access_retry_wait = 1000, {1 second}
    include_radix = TRUE,
    radix = 10,
    update_catalog = TRUE;

  TYPE
    audit_ownership_rec = record
      case ownership_known: boolean of
      = FALSE =
        system_privilege: boolean,
      = TRUE =
        ownership: pft$ownership,
      casend,
    recend;

  TYPE
    path_types = (catalog_path, file_path, item_path, new_catalog_path, new_file_path, new_item_path);

  TYPE
    shared_queue_conv_entry = record
      shared_queue_name: ost$name,
      shared_queue: pft$shared_queue,
    recend;

  VAR
    pfv$flush_catalogs: [XDCL, #GATE, oss$task_shared] boolean := TRUE,
    pfv$reserved_cycle_info: [XDCL, #GATE, oss$task_shared, READ] pft$reserved_cycle_info := [*, NIL, 0, NIL],
    pfv$space_character: [XDCL, #GATE, oss$job_paged_literal, READ] set of char := [' '];

  VAR
    shared_queue_conv_table: [oss$job_paged_literal, READ]
          array [1 .. pfc$max_shared_queue] of shared_queue_conv_entry := [
          ['SITE_01', pfc$sq_site_01],
          ['SITE_02', pfc$sq_site_02],
          ['SITE_03', pfc$sq_site_03],
          ['SITE_04', pfc$sq_site_04],
          ['SITE_05', pfc$sq_site_05],
          ['SITE_06', pfc$sq_site_06],
          ['SITE_07', pfc$sq_site_07],
          ['SITE_08', pfc$sq_site_08],
          ['SITE_09', pfc$sq_site_09],
          ['SITE_10', pfc$sq_site_10],
          ['SITE_11', pfc$sq_site_11],
          ['SITE_12', pfc$sq_site_12],
          ['SITE_13', pfc$sq_site_13],
          ['SITE_14', pfc$sq_site_14],
          ['SITE_15', pfc$sq_site_15],
          ['SITE_16', pfc$sq_site_16],
          ['SITE_17', pfc$sq_site_17],
          ['SITE_18', pfc$sq_site_18],
          ['SITE_19', pfc$sq_site_19],
          ['SITE_20', pfc$sq_site_20],
          ['SITE_21', pfc$sq_site_21],
          ['SITE_22', pfc$sq_site_22],
          ['SITE_23', pfc$sq_site_23],
          ['SITE_24', pfc$sq_site_24],
          ['SITE_25', pfc$sq_site_25]],
    valid_object_info_requests: [oss$job_paged_literal, READ] fst$goi_object_info_requests :=
          [fsc$goi_set_name, fsc$goi_catalog_identity, fsc$goi_applicable_cat_permit,
          fsc$goi_catalog_device_info, fsc$goi_catalog_info, fsc$goi_catalog_permits, fsc$goi_catalog_size,
          fsc$goi_catalog_object_list, fsc$goi_file_object_list, fsc$goi_file_identity,
          fsc$goi_applicable_file_permit, fsc$goi_file_info, fsc$goi_file_log, fsc$goi_file_permits,
          fsc$goi_cycle_object_list, fsc$goi_cycle_identity, fsc$goi_archive_info, fsc$goi_cycle_device_info,
          fsc$goi_cycle_info, fsc$goi_cycle_size, fsc$goi_file_label, fsc$goi_job_environment_info];

?? TITLE := '  [XDCL, #GATE] pfp$audit_save_label', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$audit_save_label
    (    variant_path: pft$variant_path;
         p_save_label_audit_info: {input^} ^pft$save_label_audit_info;
         audit_status: ost$status);

    VAR
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id;

    osp$verify_system_privilege;

    audit_information.audited_operation := sfc$ao_fs_change_attribute;
    audited_object.variant_path := variant_path;
    audited_object.object_type := sfc$afsot_cycle;
    audited_object.cycle_selector_p := ^p_save_label_audit_info^.cycle_selector;
    audited_object.device_class := p_save_label_audit_info^.device_class;
    audit_information.change_fs_object_attribute.object_id_p := ^audited_object;
    audit_information.change_fs_object_attribute.ownership := p_save_label_audit_info^.ownership;

    IF p_save_label_audit_info^.fap_audit_info.audit THEN
      audit_information.change_fs_object_attribute.attribute := sfc$afsoa_fap_name;
      audit_information.change_fs_object_attribute.fap_name :=
            p_save_label_audit_info^.fap_audit_info.fap_name;
      sfp$emit_audit_statistic (audit_information, audit_status);
    IFEND;

    IF p_save_label_audit_info^.ring_audit_info.audit THEN
      audit_information.change_fs_object_attribute.attribute := sfc$afsoa_ring_attributes;
      audit_information.change_fs_object_attribute.ring_attributes :=
            p_save_label_audit_info^.ring_audit_info.ring_attributes;
      sfp$emit_audit_statistic (audit_information, audit_status);
    IFEND;
  PROCEND pfp$audit_save_label;

?? TITLE := '  [XDCL, #GATE] pfp$build_sorted_dfl', EJECT ??
*copy pfh$build_sorted_dfl

  PROCEDURE [XDCL, #GATE] pfp$build_sorted_dfl
    (VAR status: ost$status);

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$not_system_administrator,
            'pfp$build_sorted_dfl', status);
      RETURN;
    IFEND;

    pfp$r2_build_sorted_dfl (status);
  PROCEND pfp$build_sorted_dfl;

?? TITLE := '  [XDCL, #GATE] pfp$catalog_access_retry_wait', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$catalog_access_retry_wait
    (    procedure_name: string(*));

      VAR
        ignore_status: ost$status,
        length: integer,
        line: string (256);

      IF pfv$debug_catalog_access THEN
        STRINGREP (line, length, 'Retrying call to ', procedure_name, ' on blocked access to catalog.');
        pmp$log_ascii (line (1, length), $pmt$ascii_logset [pmc$job_log, pmc$system_log],
              pmc$msg_origin_system, ignore_status);
      IFEND;

      pmp$wait (catalog_access_retry_wait, catalog_access_retry_wait);

  PROCEND pfp$catalog_access_retry_wait;

?? TITLE := '  [XDCL, #GATE] pfp$change_family_name', EJECT ??
*copy pfh$change_family_name

  PROCEDURE [XDCL, #GATE] pfp$change_family_name
    (    set_name: stt$set_name;
         family_name: pft$name;
         new_family_name: pft$name;
     VAR status: ost$status);

    VAR
      family_path: array [1 .. pfc$family_path_index] of pft$name,
      local_family_name: pft$name,
      local_new_family_name: pft$name,
      local_set_name: stt$set_name,
      local_status: ost$status;

    #KEYPOINT (osk$entry, 0, pfk$change_family_name);
    local_status.normal := TRUE;

    convert_set_name (family_name, local_set_name, local_status);

    IF local_status.normal THEN
      convert_family_name (family_name, catalog_path, local_family_name, local_status);
    IFEND;

    IF local_status.normal THEN
      convert_family_name (new_family_name, new_catalog_path, local_new_family_name, local_status);
    IFEND;

    IF local_status.normal THEN
      family_path [pfc$set_path_index] := local_set_name;
      family_path [pfc$family_path_index] := local_family_name;
    /change_catalog_name/
      WHILE TRUE DO
        pfp$r2_change_catalog_name (family_path, local_new_family_name, local_status);
        IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
          EXIT /change_catalog_name/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$R2_CHANGE_CATALOG_NAME');
        IFEND;
      WHILEND /change_catalog_name/;
    IFEND;

    IF local_status.normal THEN
      osp$delete_family (local_family_name, local_status);
      osp$add_family (local_new_family_name, local_set_name, local_status);
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$change_family_name);
  PROCEND pfp$change_family_name;

?? TITLE := '  [XDCL, #GATE] pfp$convert_fs_retention_to_int', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$convert_fs_retention_to_int
    (    fs_retention: fst$retention;
     VAR days: integer;
     VAR status: ost$status);

    CONST
      days_per_month = 30.4375, { ((3.0 * 365.0) + 366.0) / (4.0 * 12.0) }
      days_per_year = 365.25;   { ((3.0 * 365.0) + 366.0) / (4.0) }

    VAR
      int_total_days: integer,
      now: ost$date_time,
      real_total_days: real,
      time_increment: pmt$time_increment;

    status.normal := TRUE;

    CASE fs_retention.selector OF
      = fsc$retention_day_increment =
        days := fs_retention.day_increment;
      = fsc$retention_time_increment =
        time_increment := fs_retention.time_increment;
      = fsc$retention_expiration_date =
        pmp$get_compact_date_time (now, status);
        IF status.normal THEN
          pmp$compute_date_time_increment (now, fs_retention.expiration_date, time_increment, status);
        IFEND;
    CASEND;

    IF status.normal AND (fs_retention.selector <> fsc$retention_day_increment) THEN
      real_total_days :=  $REAL(time_increment.day) + ($REAL(time_increment.month) * days_per_month) +
            ($REAL(time_increment.year) * days_per_year);
      int_total_days := $INTEGER(real_total_days);
      IF real_total_days > $REAL(int_total_days) THEN
        days := int_total_days + 1;
      ELSE
        days := int_total_days;
      IFEND;
    IFEND;

  PROCEND pfp$convert_fs_retention_to_int;

?? TITLE := '  [XDCL, #GATE] pfp$convert_shared_queue_to_ord', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$convert_shared_queue_to_ord
    (    shared_queue_name: ost$name;
     VAR shared_queue: pft$shared_queue;
     VAR status: ost$status);

    VAR
      index: integer;

    status.normal := TRUE;

    IF shared_queue_name = 'SYSTEM' THEN
      shared_queue := pfc$null_shared_queue;
    ELSE
      FOR index := LOWERBOUND (shared_queue_conv_table) TO UPPERBOUND (shared_queue_conv_table) DO
        IF shared_queue_name = shared_queue_conv_table [index].shared_queue_name THEN
          shared_queue := shared_queue_conv_table [index].shared_queue;
          RETURN;
        IFEND;
      FOREND;
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_shared_queue_name,
            shared_queue_name, status);
    IFEND;

  PROCEND pfp$convert_shared_queue_to_ord;

?? TITLE := '  [XDCL, #GATE] pfp$convert_ord_to_shared_queue', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$convert_ord_to_shared_queue
    (    shared_queue: pft$shared_queue;
     VAR shared_queue_name: ost$name;
     VAR status: ost$status);

    VAR
      index: integer;

    status.normal := TRUE;

    FOR index := LOWERBOUND (shared_queue_conv_table) TO UPPERBOUND (shared_queue_conv_table) DO
      IF shared_queue = shared_queue_conv_table [index].shared_queue THEN
        shared_queue_name := shared_queue_conv_table [index].shared_queue_name;
        RETURN;
      IFEND;
    FOREND;

    osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_shared_queue_ord, '', status);
    osp$append_status_integer (osc$status_parameter_delimiter, shared_queue, {radix} 10,
           {include_radix_specifier} FALSE, status);

  PROCEND pfp$convert_ord_to_shared_queue;

?? TITLE := '  [XDCL, #GATE] pfp$define_master_catalog', EJECT ??
*copy pfh$define_master_catalog

  PROCEDURE [XDCL, #GATE] pfp$define_master_catalog
    (    set_name: stt$set_name;
         family_name: pft$name;
         master_catalog_name: pft$name;
         charge_id: pft$charge_id;
     VAR status: ost$status);

    VAR
      audit_ownership: audit_ownership_rec,
      caller_id: ost$caller_identifier,
      current_set_name: stt$set_name,
      family_path: array [1 .. pfc$family_path_index] of pft$name,
      local_charge_id: pft$charge_id,
      local_family_name: pft$name,
      local_master_catalog_name: pft$name,
      local_set_name: stt$set_name,
      local_status: ost$status,
      master_catalog_path: array [1 .. pfc$master_catalog_path_index] of pft$name,
      system_privilege: boolean,
      user_id: ost$user_identification,
      variant_path: pft$variant_path;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$define_master_catalog);
    status.normal := TRUE;

    clp$validate_name (set_name, local_set_name, local_status.normal);
    IF NOT local_status.normal THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_set_name, set_name, local_status);
    IFEND;

    IF local_status.normal THEN
      convert_family_name (family_name, catalog_path, local_family_name, local_status);
    IFEND;

    IF local_status.normal THEN
      convert_master_catalog_name (master_catalog_name, new_catalog_path, local_master_catalog_name,
            local_status);
    IFEND;

    IF local_status.normal THEN
      convert_charge_id (charge_id, local_charge_id, local_status);
    IFEND;

    IF local_status.normal THEN
      pmp$get_user_identification (user_id, local_status);
    IFEND;

    IF local_status.normal THEN
      osp$get_set_name (local_family_name, current_set_name, local_status);
      IF local_status.normal AND (current_set_name <> local_set_name) THEN
          {
          { Family already exists in a different set.
          {
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$family_already_exists,
                local_family_name, local_status);
      ELSE
        local_status.normal := TRUE;
      IFEND;
    IFEND;

    IF local_status.normal THEN
      master_catalog_path [pfc$set_path_index] := local_set_name;
      master_catalog_path [pfc$family_path_index] := local_family_name;
      master_catalog_path [pfc$master_catalog_path_index] := local_master_catalog_name;
      {
      { The determination of system_privilege should not be based upon the
      { $system master catalog, but rather on whether the user is attempting to
      { create his own master catalog.
      {
      system_privilege := pfp$system_privilege (caller_id.ring, jmc$system_user) AND
            (user_id.family = local_family_name) AND (user_id.user = local_master_catalog_name);

    /define_catalog_1/
      WHILE TRUE DO
        pfp$r2_define_catalog (master_catalog_path, local_charge_id, system_privilege,
              {catalog_type_selected} FALSE, pfc$external_catalog, {p_mass_storage_request_info} NIL,
              local_status);
        IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
          EXIT /define_catalog_1/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$R2_DEFINE_CATALOG');
        IFEND;
      WHILEND /define_catalog_1/;

      IF local_status.normal OR ((local_status.condition <> pfe$unknown_family) AND
            (local_status.condition <> pfe$duplicate_master_catalog)) THEN
        IF avp$security_option_active (avc$vso_security_audit) THEN
          variant_path.complete_path := TRUE;
          variant_path.p_complete_path := ^master_catalog_path;
          audit_ownership.ownership_known := FALSE;
          audit_ownership.system_privilege := system_privilege;
          audit_catalog_creation (variant_path, audit_ownership, local_status);
        IFEND;
      ELSEIF local_status.condition = pfe$unknown_family THEN
        family_path [pfc$set_path_index] := local_set_name;
        family_path [pfc$family_path_index] := local_family_name;
      /define_catalog_2/
        WHILE TRUE DO
          pfp$r2_define_catalog (family_path, local_charge_id, system_privilege,
               {catalog_type_selected} FALSE, pfc$external_catalog, {p_mass_storage_request_info} NIL,
               local_status);
          IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
            EXIT /define_catalog_2/;
          ELSE
            pfp$catalog_access_retry_wait ('PFP$R2_DEFINE_CATALOG');
          IFEND;
        WHILEND /define_catalog_2/;

        IF avp$security_option_active (avc$vso_security_audit) THEN
          variant_path.complete_path := TRUE;
          variant_path.p_complete_path := ^family_path;
          audit_ownership.ownership_known := FALSE;
          audit_ownership.system_privilege := system_privilege;
          audit_catalog_creation (variant_path, audit_ownership, local_status);
        IFEND;

        IF local_status.normal THEN
          osp$add_family (local_family_name, local_set_name, local_status);

          IF local_status.normal THEN
          /define_master_catalog_3/
            WHILE TRUE DO
            pfp$r2_define_catalog (master_catalog_path, local_charge_id, system_privilege,
                  {catalog_type_selected} FALSE, pfc$external_catalog, {p_mass_storage_request_info} NIL,
                  local_status);
              IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
                EXIT /define_master_catalog_3/;
              ELSE
                pfp$catalog_access_retry_wait ('PFP$R2_DEFINE_CATALOG');
              IFEND;
            WHILEND /define_master_catalog_3/;

            IF avp$security_option_active (avc$vso_security_audit) THEN
              variant_path.p_complete_path := ^master_catalog_path;
              audit_catalog_creation (variant_path, audit_ownership, local_status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      IF local_status.condition = dme$unable_to_alloc_all_space THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id,
              pfe$no_space_for_master_catalog, master_catalog_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, family_name, status);
      ELSE
        status := local_status;
      IFEND;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$define_master_catalog);
  PROCEND pfp$define_master_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$detach_jobs_catalogs', EJECT ??
*copy pfh$detach_jobs_catalogs

  PROCEDURE [XDCL, #GATE] pfp$detach_jobs_catalogs;

    pfp$detach_all_catalogs;
  PROCEND pfp$detach_jobs_catalogs;

?? TITLE := '  [XDCL, #GATE] pfp$detach_reserved_cycles', EJECT ??
*copy pfh$detach_reserved_cycles

  PROCEDURE [XDCL, #GATE] pfp$detach_reserved_cycles
    (VAR status: ost$status);

    VAR
      mainframe_id: pmt$binary_mainframe_id;

    status.normal := TRUE;

    IF pfv$reserved_cycle_info.p_catalog_path = NIL THEN
      RETURN;
    IFEND;

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$not_system_administrator,
            'pfp$detach_reserved_cycles', status);
      RETURN;
    IFEND;

    pmp$get_pseudo_mainframe_id (mainframe_id);

  /detach_reserved_cycles/
    WHILE TRUE DO
      pfp$r2_detach_reserved_cycles (mainframe_id, status);
      IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
        EXIT /detach_reserved_cycles/;
      ELSE
        pfp$catalog_access_retry_wait ('PFP$R2_DETACH_RESERVED_CYCLES');
      IFEND;
    WHILEND /detach_reserved_cycles/;

  PROCEND pfp$detach_reserved_cycles;

?? TITLE := '  [XDCL] pfp$dm_attach_item', EJECT ??

*copy pfh$dm_attach_item

  PROCEDURE [XDCL] pfp$dm_attach_item
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR sfid: dmt$system_file_id;
     VAR status: ost$status);

    VAR
      p_complete_path: pft$p_complete_path;

    PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
    convert_path (path, {minimum_path_length} 1, item_path, p_complete_path^, status);
    IF status.normal THEN
    /dm_attach_item/
      WHILE TRUE DO
        pfp$r2_dm_attach_item (p_complete_path^, cycle_selector, sfid, status);
        IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
          EXIT /dm_attach_item/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$DM_ATTACH_ITEM');
        IFEND;
      WHILEND /dm_attach_item/;
    IFEND;
  PROCEND pfp$dm_attach_item;

?? TITLE := '  [XDCL, #GATE] pfp$get_attached_pf_table', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$get_attached_pf_table
    (VAR p_info: pft$p_table_info;
     VAR status: ost$status);

    VAR
      local_status: ost$status;

    #KEYPOINT (osk$entry, 0, pfk$get_attached_pf_table);
    local_status.normal := TRUE;

    pfp$verify_pva (p_info, mmc$va_read_write, local_status);
    IF local_status.normal THEN
      pfp$r2_get_attached_pf_table (p_info, local_status);
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$get_attached_pf_table);
  PROCEND pfp$get_attached_pf_table;

?? TITLE := '  [XDCL, #GATE] pfp$get_catalog_alarm_table', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$get_catalog_alarm_table
    (VAR p_info: pft$p_table_info;
     VAR status: ost$status);

    VAR
      local_status: ost$status;

    #KEYPOINT (osk$entry, 0, pfk$get_catalog_alarm_table);
    local_status.normal := TRUE;

    pfp$verify_pva (p_info, mmc$va_read_write, local_status);
    IF local_status.normal THEN
      pfp$r1_get_catalog_alarm_table (p_info, local_status);
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$get_catalog_alarm_table);
  PROCEND pfp$get_catalog_alarm_table;

?? TITLE := '  [XDCL, #GATE] pfp$get_catalog_segment', EJECT ??
*copy pfh$get_catalog_segment

  PROCEDURE [XDCL, #GATE] pfp$get_catalog_segment
    (    path: pft$path;
     VAR p_info: pft$p_table_info;
     VAR status: ost$status);

    CONST
      minimum_path_length = 1;

    VAR
      caller_id: ost$caller_identifier,
      local_status: ost$status,
      p_complete_path: pft$p_complete_path;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$get_catalog_segment);
    local_status.normal := TRUE;

    PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
    convert_path (path, minimum_path_length, catalog_path, p_complete_path^, local_status);

    IF local_status.normal THEN
      pfp$verify_pva (p_info, mmc$va_read_write, local_status);
    IFEND;

    IF local_status.normal THEN
    /get_catalog_segment/
      WHILE TRUE DO
        pfp$r2_get_catalog_segment (p_complete_path^, p_info, local_status);
        IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
          EXIT /get_catalog_segment/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$R2_GET_CATALOG_SEGMENT');
        IFEND;
      WHILEND /get_catalog_segment/;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$get_catalog_segment);
  PROCEND pfp$get_catalog_segment;

?? TITLE := '  [XDCL, #GATE] pfp$get_families_in_set', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$get_families_in_set
    (    set_name: stt$set_name;
     VAR family_list: array [1 .. *] of ost$name;
     VAR number_of_families: 0 .. 255;
     VAR status: ost$status);

    osp$get_family_names_by_set (set_name, family_list, number_of_families, status);
  PROCEND pfp$get_families_in_set;

?? TITLE := '  [XDCL, #GATE] pfp$get_family_info', EJECT ??
*copy pfh$get_family_info

  PROCEDURE [XDCL, #GATE] pfp$get_family_info
    (    set_name: stt$set_name;
         catalog_info_selections: pft$catalog_info_selections;
     VAR p_info: pft$p_info;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      local_set_name: stt$set_name,
      local_status: ost$status;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$get_family_info);
    local_status.normal := TRUE;

    clp$validate_name (set_name, local_set_name, local_status.normal);
    IF NOT local_status.normal THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_set_name, set_name, local_status);
    IFEND;
    IF local_status.normal THEN
      pfp$verify_pva (p_info, mmc$va_read_write, local_status);
      IF local_status.normal THEN
        pfp$r2_get_family_info (local_set_name, catalog_info_selections, p_info, local_status);
      IFEND;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$get_family_info);
  PROCEND pfp$get_family_info;

?? TITLE := '  [XDCL, #GATE] pfp$get_family_item_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$get_family_item_info
    (    family_name: pft$name;
         catalog_info_selections: pft$catalog_info_selections;
     VAR set_name: stt$set_name;
     VAR p_info: {i/o} pft$p_info;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      complete_path: array [pfc$set_path_index .. pfc$family_path_index] of pft$name,
      converted_family_name: ost$family_name,
      group: pft$group,
      local_status: ost$status,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$get_item_info);
    status.normal := TRUE;

    pfp$verify_pva (p_info, mmc$va_read_write, local_status);

    IF local_status.normal THEN
      check_family_location (family_name, converted_family_name, served_family, served_family_locator,
            local_status);
    IFEND;

    IF local_status.normal THEN
      IF served_family THEN
      /df_client_get_famit_info/
        WHILE TRUE DO
          pfp$r2_df_client_get_famit_info (converted_family_name, catalog_info_selections,
                served_family_locator, set_name, p_info, local_status);
          IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
            EXIT /df_client_get_famit_info/;
          ELSE
            pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_GET_FAMIT_INFO');
          IFEND;
        WHILEND /df_client_get_famit_info/;
      ELSE
        osp$get_set_name (converted_family_name, set_name, local_status);
        IF local_status.normal THEN
          group.group_type := pfc$public;
          complete_path [pfc$set_path_index] := set_name;
          complete_path [pfc$family_path_index] := converted_family_name;
        /get_item_info/
          WHILE TRUE DO
            pfp$r2_get_item_info (complete_path, {system_privilege} FALSE, group, catalog_info_selections,
                  $pft$file_info_selections [], p_info, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /get_item_info/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_GET_ITEM_INFO');
            IFEND;
          WHILEND /get_item_info/;
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$get_item_info);
  PROCEND pfp$get_family_item_info;

?? TITLE := '  [XDCL, #GATE] pfp$get_master_catalog_info', EJECT ??
*copy pfh$get_master_catalog_info

  PROCEDURE [XDCL, #GATE] pfp$get_master_catalog_info
    (    set_name: stt$set_name,
         family_name: pft$name;
         catalog_info_selections: pft$catalog_info_selections;
     VAR p_info: pft$p_info;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      complete_path: array [1 .. pfc$family_path_index] of pft$name,
      converted_family_name: ost$family_name,
      local_status: ost$status,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$get_master_catalog_info);
    local_status.normal := TRUE;

    pfp$verify_pva (p_info, mmc$va_read_write, local_status);
    IF local_status.normal THEN
      check_family_location (family_name, converted_family_name, served_family,
          served_family_locator, local_status);
    IFEND;

    IF local_status.normal THEN
      IF served_family THEN
      /df_client_get_mcat_info/
        WHILE TRUE DO
          pfp$r2_df_client_get_mcat_info (converted_family_name, catalog_info_selections,
                served_family_locator, p_info, local_status);
          IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
            EXIT /df_client_get_mcat_info/;
          ELSE
            pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_GET_MCAT_INFO');
          IFEND;
        WHILEND /df_client_get_mcat_info/;
      ELSE
        convert_set_name (converted_family_name, complete_path [pfc$set_path_index], local_status);
        IF local_status.normal THEN
          complete_path [pfc$family_path_index] := converted_family_name;
        /get_master_catalog_info/
          WHILE TRUE DO
            pfp$r2_get_master_catalog_info (complete_path, catalog_info_selections, p_info, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /get_master_catalog_info/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_GET_MASTER_CATALOG_INFO');
            IFEND;
          WHILEND /get_master_catalog_info/;
        IFEND;
      IFEND;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$get_master_catalog_info);
  PROCEND pfp$get_master_catalog_info;

?? TITLE := '  [XDCL, #GATE] pfp$get_queued_catalog_table', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$get_queued_catalog_table
    (VAR p_info: pft$p_table_info;
     VAR status: ost$status);

    VAR
      local_status: ost$status;

    #KEYPOINT (osk$entry, 0, pfk$get_queued_catalog_table);
    local_status.normal := TRUE;

    pfp$verify_pva (p_info, mmc$va_read_write, local_status);
    IF local_status.normal THEN
      pfp$r2_get_queued_catalog_table (p_info, local_status);
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$get_queued_catalog_table);
  PROCEND pfp$get_queued_catalog_table;

?? TITLE := '  [XDCL] pfp$get_restore_status', EJECT ??
*copy pfh$get_restore_status

  PROCEDURE [XDCL] pfp$get_restore_status
    (VAR restore_missing_catalogs_done: boolean);

    VAR
      p_restore_status: ^SEQ ( * ),
      restore_status: pft$retained_restore_status;

    p_restore_status := #SEQ (restore_status);
    dsp$get_data_from_rdf (dsc$rdf_restore_status, dsc$rdf_production, p_restore_status);
    restore_missing_catalogs_done := restore_status = pfc$restore_missing_cat_done;
  PROCEND pfp$get_restore_status;

?? TITLE := '  [XDCL, #GATE] pfp$get_set_list', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$get_set_list
    (VAR set_list: stt$set_list;
     VAR number_of_sets: stt$number_of_sets;
     VAR status: ost$status);

    status.normal := TRUE;

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$not_system_administrator,
            'pfp$get_set_list', status);
      RETURN;
    IFEND;

    stp$get_active_set_list (set_list, number_of_sets);
  PROCEND pfp$get_set_list;

?? TITLE := '  [XDCL, #GATE] pfp$get_stored_fmd', EJECT ??
*copy pfh$get_stored_fmd

  PROCEDURE [XDCL, #GATE] pfp$get_stored_fmd
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR catalog: boolean;
     VAR catalog_recreated: boolean;
     VAR internal_name: ost$binary_unique_name;
     VAR stored_fmd: dmt$stored_fmd;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      local_status: ost$status,
      p_complete_path: ^pft$complete_path;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$get_stored_fmd);
    status.normal := TRUE;

    PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
    convert_path (path, {minimum_path_length} pfc$family_name_index, item_path, p_complete_path^,
          local_status);

    IF local_status.normal THEN
      check_cycle_selector (cycle_selector, local_status);
    IFEND;

    IF local_status.normal THEN
    /get_stored_fmd/
      WHILE TRUE DO
        pfp$r2_get_stored_fmd (p_complete_path^, cycle_selector, catalog, catalog_recreated, internal_name,
              stored_fmd, local_status);
        IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
          EXIT /get_stored_fmd/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$R2_GET_STORED_FMD');
        IFEND;
      WHILEND /get_stored_fmd/;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$get_stored_fmd);
  PROCEND pfp$get_stored_fmd;

?? TITLE := '  [XDCL, #GATE] pfp$get_stored_fmd_size', EJECT ??
*copy pfh$get_stored_fmd_size

  PROCEDURE [XDCL, #GATE] pfp$get_stored_fmd_size
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR device_class: rmt$device_class;
     VAR internal_name: ost$binary_unique_name;
     VAR stored_fmd_size: dmt$stored_fmd_size;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      local_status: ost$status,
      p_complete_path: ^pft$complete_path;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$get_stored_fmd_size);
    status.normal := TRUE;

    PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
    convert_path (path, {minimum_path_length} pfc$family_name_index, item_path, p_complete_path^,
          local_status);

    IF local_status.normal THEN
      check_cycle_selector (cycle_selector, local_status);
    IFEND;

    IF local_status.normal THEN
    /get_stored_fmd_size/
      WHILE TRUE DO
        pfp$r2_get_stored_fmd_size (p_complete_path^, cycle_selector, device_class, internal_name,
              stored_fmd_size, local_status);
        IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
          EXIT /get_stored_fmd_size/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$R2_GET_STORED_FMD_SIZE');
        IFEND;
      WHILEND /get_stored_fmd_size/;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$get_stored_fmd_size);
  PROCEND pfp$get_stored_fmd_size;

?? TITLE := '  [XDCL, #GATE] pfp$get_volumes_in_set', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$get_volumes_in_set
    (    set_name: stt$set_name;
     VAR volume_list: pft$volume_list;
     VAR number_of_volumes: integer;
     VAR status: ost$status);

    VAR
      master_info: stt$volume_info,
      member_index: stt$number_of_members,
      member_list_p: ^stt$volume_list,
      number_of_members: stt$number_of_members,
      volume_index: integer;

    number_of_members := 10;
    REPEAT
      PUSH member_list_p: [1 .. number_of_members];
      stp$get_volumes_in_set (set_name, master_info, member_list_p^, number_of_members, status);
    UNTIL (NOT status.normal) OR (number_of_members <= UPPERBOUND (member_list_p^));
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF UPPERBOUND (volume_list) >= 1 THEN
      volume_list [1] := master_info.recorded_vsn;
    IFEND;
    volume_index := 2;
    member_index := 1;
    WHILE member_index <= number_of_members DO
      IF UPPERBOUND (volume_list) >= volume_index THEN
        volume_list [volume_index] := member_list_p^ [member_index].recorded_vsn;
      IFEND;
      member_index := member_index + 1;
      volume_index := volume_index + 1;
    WHILEND;

    number_of_volumes := volume_index - 1;
  PROCEND pfp$get_volumes_in_set;

?? TITLE := '  [XDCL, #GATE] pfp$get_volumes_set_name', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$get_volumes_set_name
    (    volume: rmt$recorded_vsn;
     VAR set_name: stt$set_name;
     VAR status: ost$status);

     stp$get_volumes_set_name (volume, set_name, status);

  PROCEND pfp$get_volumes_set_name;

?? TITLE := '  [XDCL, #GATE] pfp$no_space_movc_dest_volumes', EJECT ??
{ PURPOSE:
{   The purpose of this function is to determine whether or not all
{   destination volumes specified on the MOVE_CLASSES command are out of
{   space.
{

  FUNCTION [XDCL, #GATE] pfp$no_space_movc_dest_volumes
    (    move_object_info_p: ^pft$move_object_info): boolean;

    VAR
      avt_index: ost$positive_integers,
      class: char,
      volume_index: ost$positive_integers;

    pfp$no_space_movc_dest_volumes := TRUE;

  /check_classes/
    FOR class := 'A' TO 'Z' DO
      IF class IN move_object_info_p^.mass_storage_class THEN
      /check_destination_volumes/
        FOR volume_index := 1 TO UPPERBOUND (move_object_info_p^.dest_volume_list_p^) DO
          IF class IN move_object_info_p^.dest_volume_list_p^ [volume_index]^.ms_class THEN
          /search_avt_for_volume/
            FOR avt_index := LOWERBOUND (dmv$p_active_volume_table^) TO
                  UPPERBOUND (dmv$p_active_volume_table^) DO
              IF (NOT dmv$p_active_volume_table^ [avt_index].entry_available) OR
                    (dmv$p_active_volume_table^ [avt_index].mass_storage.volume_unavailable) OR
                    (dmv$p_active_volume_table^ [avt_index].mass_storage.recorded_vsn <>
                    move_object_info_p^.dest_volume_list_p^ [volume_index]^.recorded_vsn) THEN
                CYCLE /search_avt_for_volume/;
              ELSEIF (NOT dmv$p_active_volume_table^ [avt_index].mass_storage.space_gone) THEN
                pfp$no_space_movc_dest_volumes := FALSE;
                RETURN;
              IFEND;
            FOREND /search_avt_for_volume/;
          IFEND;
        FOREND /check_destination_volumes/;
      IFEND;
    FOREND /check_classes/;

  FUNCEND pfp$no_space_movc_dest_volumes;

?? TITLE := '  [XDCL, #GATE] pfp$open_file_segment', EJECT ??
*copy pfh$open_file_segment

  PROCEDURE [XDCL, #GATE] pfp$open_file_segment
    (    system_file_id: dmt$system_file_id;
         validation_ring: ost$valid_ring;
     VAR segment_pointer: mmt$segment_pointer;
     VAR status: ost$status);

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$not_system_administrator,
            'pfp$open_file_segment', status);
      RETURN;
    IFEND;

    mmp$open_file_segment (system_file_id, {seg_attributes_p} NIL, mmc$cell_pointer, validation_ring,
          {file_limits_to_enforce} sfc$no_limit, segment_pointer, status);
  PROCEND pfp$open_file_segment;

?? TITLE := '  [XDCL] pfp$overhaul_catalog', EJECT ??
*copy pfh$overhaul_catalog

  PROCEDURE [XDCL] pfp$overhaul_catalog
    (    path: pft$path;
         catalog_overhaul_choices: pft$catalog_overhaul_choices;
     VAR status: ost$status);

    CONST
      minimum_path_length = 2;

    VAR
      caller_id: ost$caller_identifier,
      local_status: ost$status,
      p_complete_path: pft$p_complete_path;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$overhaul_catalog);
    local_status.normal := TRUE;

    PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
    convert_path (path, minimum_path_length, catalog_path, p_complete_path^, local_status);
    IF local_status.normal THEN
    /overhaul_catalog/
      WHILE TRUE DO
        pfp$r2_overhaul_catalog (p_complete_path^, catalog_overhaul_choices, local_status);
        IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
          EXIT /overhaul_catalog/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$R2_OVERHAUL_CATALOG');
        IFEND;
      WHILEND /overhaul_catalog/;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$overhaul_catalog);
  PROCEND pfp$overhaul_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$overhaul_set', EJECT ??
*copy pfh$overhaul_set

  PROCEDURE [XDCL, #GATE] pfp$overhaul_set
    (    set_name: stt$set_name;
         set_overhaul_choices: pft$set_overhaul_choices;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      local_set_name: stt$set_name,
      local_status: ost$status;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$overhaul_set);
    local_status.normal := TRUE;

    clp$validate_name (set_name, local_set_name, local_status.normal);
    IF NOT local_status.normal THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_set_name, set_name, local_status);
    IFEND;
    IF local_status.normal THEN
      pfp$r2_overhaul_set (local_set_name, set_overhaul_choices, local_status);
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$overhaul_set);
  PROCEND pfp$overhaul_set;

?? TITLE := '  [XDCL, #GATE] pfp$purge_master_catalog', EJECT ??
*copy pfh$purge_master_catalog

  PROCEDURE [XDCL, #GATE] pfp$purge_master_catalog
    (    set_name: stt$set_name;
         family_name: pft$name;
         master_catalog_name: pft$name;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      family_path: array [1 .. pfc$family_path_index] of pft$name,
      local_family_name: pft$name,
      local_master_catalog_name: pft$name,
      local_set_name: stt$set_name,
      local_status: ost$status,
      master_catalog_path: array [1 .. pfc$master_catalog_path_index] of pft$name,
      system_privilege: boolean,
      user_id: ost$user_identification,
      variant_path: pft$variant_path;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$purge_master_catalog);
    status.normal := TRUE;

    convert_set_name (family_name, local_set_name, local_status);

    IF local_status.normal THEN
      convert_family_name (family_name, catalog_path, local_family_name, local_status);
    IFEND;

    IF local_status.normal THEN
      convert_master_catalog_name (master_catalog_name, catalog_path, local_master_catalog_name,
            local_status);
    IFEND;

    IF local_status.normal THEN
      pmp$get_user_identification (user_id, local_status);
    IFEND;

    IF local_status.normal THEN
      master_catalog_path [pfc$set_path_index] := local_set_name;
      master_catalog_path [pfc$family_path_index] := local_family_name;
      master_catalog_path [pfc$master_catalog_path_index] := local_master_catalog_name;
      {
      { The determination of system_privilege should not be based upon the
      { $system master catalog, but rather on whether the user is attempting to
      { delete his own master catalog.
      {
      system_privilege := pfp$system_privilege (caller_id.ring, jmc$system_user) AND
            (user_id.family = local_family_name) AND (user_id.user = local_master_catalog_name);

    /purge_catalog_1/
      WHILE TRUE DO
        pfp$r2_purge_catalog (master_catalog_path, system_privilege, pfc$only_if_empty, local_status);
        IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
          EXIT /purge_catalog_1/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$R2_PURGE_CATALOG');
        IFEND;
      WHILEND /purge_catalog_1/;

      IF avp$security_option_active (avc$vso_security_audit) THEN
        variant_path.complete_path := TRUE;
        variant_path.p_complete_path := ^master_catalog_path;
        audit_catalog_deletion (variant_path, system_privilege, local_status);
      IFEND;
    IFEND;

    IF local_status.normal THEN
      family_path [pfc$set_path_index] := local_set_name;
      family_path [pfc$family_path_index] := local_family_name;

    /purge_catalog_2/
      WHILE TRUE DO
        pfp$r2_purge_catalog (family_path, system_privilege, pfc$only_if_empty, local_status);
        IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
          EXIT /purge_catalog_2/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$R2_PURGE_CATALOG');
        IFEND;
      WHILEND /purge_catalog_2/;

      IF (local_status.normal OR (local_status.condition <> pfe$catalog_not_empty)) AND
            avp$security_option_active (avc$vso_security_audit) THEN
        variant_path.p_complete_path := ^family_path;
        audit_catalog_deletion (variant_path, system_privilege, local_status);
      IFEND;

      IF local_status.normal THEN
        osp$delete_family (local_family_name, local_status);
      IFEND;

      local_status.normal := local_status.normal OR (local_status.condition = pfe$catalog_not_empty) OR
            (local_status.condition = pfe$unknown_family);
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$purge_master_catalog);
  PROCEND pfp$purge_master_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$purge_object', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$purge_object
    (    path: pft$path;
     VAR status: ost$status);

    CONST
      minimum_path_length = 1;

    VAR
      local_status: ost$status,
      p_complete_path: pft$p_complete_path;

    local_status.normal := TRUE;

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$not_system_administrator,
            'pfp$purge_object', status);
      RETURN;
    IFEND;

    PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
    convert_path (path, minimum_path_length, catalog_path, p_complete_path^, local_status);

    IF local_status.normal THEN
    /purge_object/
      WHILE TRUE DO
        pfp$r2_purge_object (p_complete_path^, local_status);
        IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
          EXIT /purge_object/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$R2_PURGE_OBJECT');
        IFEND;
      WHILEND /purge_object/;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
  PROCEND pfp$purge_object;

?? TITLE := '  [XDCL, #GATE] pfp$put_catalog_media_info', EJECT ??
*copy pfh$put_catalog_media_info

  PROCEDURE [XDCL, #GATE] pfp$put_catalog_media_info
    (    path: pft$path;
         p_catalog_group: pft$p_info_record;
         set_name: stt$set_name;
     VAR restore_catalog_status: pft$restore_catalog_status;
     VAR status: ost$status);

    VAR
      local_set_name: stt$set_name,
      local_status: ost$status,
      master_info: stt$volume_info,
      member_list: ^stt$volume_list,
      number_of_members: stt$number_of_members,
      number_of_sets: stt$number_of_sets,
      p_complete_path: pft$p_complete_path,
      set_list: ^stt$set_list;

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$not_system_administrator,
            'pfp$put_catalog_media_info', status);
      RETURN;
    IFEND;

    #KEYPOINT (osk$entry, 0, pfk$put_catalog_media_info);
    local_status.normal := TRUE;

    PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
    IF UPPERBOUND (path) = pfc$family_name_index THEN
      {Restoring a family entry
      osp$get_set_name (path [pfc$family_name_index], local_set_name, local_status);
      IF NOT local_status.normal THEN
        {Family not defined -
        {Attempt to use set name from backup tape
        PUSH member_list: [1 .. 1];
        stp$get_volumes_in_set (set_name, master_info, member_list^, number_of_members, local_status);
        IF (NOT local_status.normal) AND (local_status.condition = ste$set_not_active) THEN
          { Use system set if only 1 set active or family is $system
          PUSH set_list: [1 .. 1];
          stp$get_active_set_list (set_list^, number_of_sets);
          IF (number_of_sets > 1) AND (path [pfc$family_name_index] <> jmc$system_family) THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_family,
                path [pfc$family_name_index], local_status);
          ELSE
            {Use system set name
            {Create family entry in OS table - may already exist
            local_set_name := stv$system_set_name;
            osp$add_family (path [pfc$family_name_index], local_set_name, local_status);
            local_status.normal := TRUE;
          IFEND;
        ELSEIF local_status.normal THEN
          local_set_name := set_name;
          osp$add_family (path [pfc$family_name_index], local_set_name, local_status);
          local_status.normal := TRUE;
        IFEND;
      IFEND;
    IFEND;

    IF local_status.normal THEN
      convert_path (path, {minimum_path_length } pfc$family_name_index, catalog_path, p_complete_path^,
            local_status);
    IFEND;

    IF local_status.normal THEN
      pfp$verify_pva (p_catalog_group, mmc$va_read, local_status);
    IFEND;

    IF local_status.normal THEN
    /put_catalog_media_info/
      WHILE TRUE DO
        pfp$r2_put_catalog_media_info (p_complete_path^, p_catalog_group, restore_catalog_status,
              local_status);
        IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
          EXIT /put_catalog_media_info/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$R2_PUT_CATALOG_MEDIA_INFO');
        IFEND;
      WHILEND /put_catalog_media_info/;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$put_catalog_media_info);
  PROCEND pfp$put_catalog_media_info;

?? TITLE := '  [XDCL, #GATE] pfp$put_catalog_segment', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$put_catalog_segment
    (    path: pft$path;
         p_catalog_segment: ^SEQ(*);
     VAR status: ost$status);

    CONST
      minimum_path_length = 1;

    VAR
      local_status: ost$status,
      p_complete_path: pft$p_complete_path;

    local_status.normal := TRUE;

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$not_system_administrator,
            'pfp$put_catalog_segment', status);
      RETURN;
    IFEND;

    PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
    convert_path (path, minimum_path_length, catalog_path, p_complete_path^, local_status);

    IF local_status.normal THEN
      pfp$verify_pva (p_catalog_segment, mmc$va_read, local_status);
    IFEND;

    IF local_status.normal THEN
    /put_catalog_segment/
      WHILE TRUE DO
        pfp$r2_put_catalog_segment (p_complete_path^, p_catalog_segment, local_status);
        IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
          EXIT /put_catalog_segment/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$R2_PUT_CATALOG_SEGMENT');
        IFEND;
      WHILEND /put_catalog_segment/;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
  PROCEND pfp$put_catalog_segment;

?? TITLE := '  [XDCL, #GATE] pfp$put_family_info', EJECT ??
*copy pfh$put_family_info

  PROCEDURE [XDCL, #GATE] pfp$put_family_info
    (    set_name: stt$set_name;
         family_name: pft$name;
         p_info_record: pft$p_info_record;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      local_family_name: pft$name,
      local_set_name: stt$set_name,
      local_status: ost$status,
      master_info: stt$volume_info,
      member_list: ^stt$volume_list,
      number_of_members: stt$number_of_members,
      number_of_sets: stt$number_of_sets,
      set_list: ^stt$set_list;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$put_family_info);
    local_status.normal := TRUE;

    convert_set_name (family_name, local_set_name, local_status);
    IF NOT local_status.normal AND (local_status.condition = pfe$unknown_family) THEN
      {Family not defined -
      {Attempt to use set name from backup tape
      PUSH member_list: [1 .. 1];
      stp$get_volumes_in_set (set_name, master_info, member_list^, number_of_members, local_status);
      IF (NOT local_status.normal) AND (local_status.condition = ste$set_not_active) THEN
        { Use system set if only 1 set active or family is $system
        PUSH set_list: [1 .. 1];
        stp$get_active_set_list (set_list^, number_of_sets);
        IF (number_of_sets > 1) AND (family_name <> jmc$system_family) THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_family,
              family_name, local_status);
        ELSE
          {Use system set name
          {Create family entry in OS table - may already exist
          local_set_name := stv$system_set_name;
          osp$add_family (family_name, local_set_name, local_status);
          local_status.normal := TRUE;
        IFEND;
      ELSEIF local_status.normal THEN
        local_set_name := set_name;
        osp$add_family (family_name, local_set_name, local_status);
        local_status.normal := TRUE;
      IFEND;
    IFEND;
    IF local_status.normal THEN
      convert_family_name (family_name, new_catalog_path, local_family_name, local_status);
      IF local_status.normal THEN
        pfp$verify_pva (p_info_record, mmc$va_read, local_status);
        IF local_status.normal THEN
        /put_family_info/
          WHILE TRUE DO
            pfp$r2_put_family_info (local_set_name, local_family_name, p_info_record, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /put_family_info/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_PUT_FAMILY_INFO');
            IFEND;
          WHILEND /put_family_info/;
        IFEND;
      IFEND;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$put_family_info);
  PROCEND pfp$put_family_info;

?? TITLE := '  [XDCL, #GATE] pfp$put_file_media_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$put_file_media_info
    (    path: pft$path;
         p_file_group: pft$p_info_record;
         set_name: stt$set_name;
         backup_file_version: pft$backup_file_version;
     VAR file_entry_recreated: boolean;
     VAR cycles_restored_with_fmd: pft$cycle_count;
     VAR cycles_restored_without_fmd: pft$cycle_count;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      p_complete_path: pft$p_complete_path;

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$not_system_administrator,
            'pfp$put_file_media_info', status);
      RETURN;
    IFEND;

    #KEYPOINT (osk$entry, 0, pfk$put_file_media_info);
    local_status.normal := TRUE;

    PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
    convert_path (path, {minimum_path_length} pfc$subcatalog_name_index, file_path, p_complete_path^,
          local_status);

    IF local_status.normal THEN
      pfp$verify_pva (p_file_group, mmc$va_read, local_status);
    IFEND;

    IF local_status.normal THEN
    /put_file_media_info/
      WHILE TRUE DO
        pfp$r2_put_file_media_info (p_complete_path^, p_file_group, backup_file_version,
              file_entry_recreated, cycles_restored_with_fmd, cycles_restored_without_fmd, local_status);
        IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
          EXIT /put_file_media_info/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$R2_PUT_FILE_MEDIA_INFO');
        IFEND;
      WHILEND /put_file_media_info/;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$put_file_media_info);
  PROCEND pfp$put_file_media_info;

?? TITLE := '  [XDCL, #GATE] pfp$put_master_catalog_info', EJECT ??
*copy pfh$put_master_catalog_info

  PROCEDURE [XDCL, #GATE] pfp$put_master_catalog_info
    (    set_name: stt$set_name;
         family_name: pft$name;
         master_catalog_name: pft$name;
         p_info_record: pft$p_info_record;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      local_family_name: pft$name,
      local_master_catalog_name: pft$name,
      local_set_name: stt$set_name,
      local_status: ost$status;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$put_master_catalog_info);
    local_status.normal := TRUE;

    convert_set_name (family_name, local_set_name, local_status);
    IF local_status.normal THEN
      convert_family_name (family_name, catalog_path, local_family_name, local_status);
      IF local_status.normal THEN
        convert_master_catalog_name (master_catalog_name, new_catalog_path, local_master_catalog_name,
              local_status);
        IF local_status.normal THEN
          pfp$verify_pva (p_info_record, mmc$va_read, local_status);
          IF local_status.normal THEN
          /put_master_catalog_info/
            WHILE TRUE DO
              pfp$r2_put_master_catalog_info (local_set_name, local_family_name, local_master_catalog_name,
                    p_info_record, local_status);
              IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
                EXIT /put_master_catalog_info/;
              ELSE
                pfp$catalog_access_retry_wait ('PFP$R2_PUT_MASTER_CATALOG_INFO');
              IFEND;
            WHILEND /put_master_catalog_info/;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$put_master_catalog_info);
  PROCEND pfp$put_master_catalog_info;

?? TITLE := '  [XDCL, #GATE] pfp$r3_append_rem_media_vsn', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_append_rem_media_vsn
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         volume_descriptor: rmt$volume_descriptor;
     VAR status: ost$status);

    CONST
      minimum_path_length = 3;

    VAR
      converted_family_name: ost$family_name,
      p_complete_path: pft$p_complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

    status.normal := TRUE;
    osp$verify_system_privilege;

  /append_rem_media_vsn_block/
    BEGIN
      check_cycle_selector (cycle_selector, status);
      IF NOT status.normal THEN
        EXIT /append_rem_media_vsn_block/;
      IFEND;

      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
           served_family_locator, status);
      IF NOT status.normal THEN
        EXIT /append_rem_media_vsn_block/;
      IFEND;

      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, file_path,
             p_converted_path^, status);
        IF status.normal THEN
        /df_client_app_rem_me_vsn/
          WHILE TRUE DO
            pfp$r2_df_client_app_rem_me_vsn (served_family_locator, p_converted_path^,
                  cycle_selector, volume_descriptor, status);
            IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_app_rem_me_vsn/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_APP_REM_ME_VSN');
            IFEND;
          WHILEND /df_client_app_rem_me_vsn/;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, file_path, p_complete_path^, status);
        IF status.normal THEN
        /append_rem_media_vsn/
          WHILE TRUE DO
            pfp$r2_append_rem_media_vsn (p_complete_path^, cycle_selector, volume_descriptor, status);
            IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
              EXIT /append_rem_media_vsn/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_APPEND_REM_MEDIA_VSN');
            IFEND;
          WHILEND /append_rem_media_vsn/;
        IFEND;
      IFEND;
    END /append_rem_media_vsn_block/;
  PROCEND pfp$r3_append_rem_media_vsn;

?? TITLE := '  [XDCL, #GATE] pfp$r3_attach', EJECT ??
*copy pfh$r3_attach

  PROCEDURE [XDCL, #GATE] pfp$r3_attach
    (    lfn: amt$local_file_name;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
     VAR cycle_number: pft$cycle_number;
     VAR status: ost$status);

    CONST
      minimum_path_length = 3;

    VAR
      caller_id: ost$caller_identifier,
      converted_family_name: ost$family_name,
      cycle_damage_symptoms: fst$cycle_damage_symptoms,
      global_file_name: ost$binary_unique_name,
      local_share_selections: pft$share_selections,
      local_status: ost$status,
      local_usage_selections: pft$usage_selections,
      r2_attach_input: pft$r2_attach_in,
      served_family_locator: pft$served_family_locator,
      system_privilege: boolean;

    #CALLER_ID (caller_id);
    status.normal := TRUE;

    osp$verify_system_privilege;

    check_family_location (path [pfc$family_name_index], converted_family_name, r2_attach_input.served_family,
          served_family_locator, local_status);
    IF local_status.normal THEN
      IF r2_attach_input.served_family THEN
        r2_attach_input.served_family_locator := served_family_locator;
        PUSH r2_attach_input.p_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, file_path,
              r2_attach_input.p_path^, local_status);
      ELSE
        PUSH r2_attach_input.p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, file_path, r2_attach_input.p_complete_path^, local_status);
      IFEND;
    IFEND;

    IF local_status.normal THEN
      convert_lfn (lfn, r2_attach_input.lfn, local_status);
    IFEND;

    IF local_status.normal THEN
      check_cycle_selector (cycle_selector, local_status);
    IFEND;

    IF local_status.normal THEN
      r2_attach_input.cycle_selector := cycle_selector;
      pfi$convert_password (password, r2_attach_input.password, local_status);
    IFEND;

    IF local_status.normal THEN
      convert_usage_and_share_selects (usage_selections, share_selections, local_usage_selections,
            local_share_selections);
      IF r2_attach_input.served_family THEN
        system_privilege := pfp$system_privilege (caller_id.ring,
              r2_attach_input.p_path^ [pfc$master_catalog_name_index]);
      ELSE
        system_privilege := pfp$system_privilege (caller_id.ring,
              r2_attach_input.p_complete_path^ [pfc$master_catalog_path_index]);
      IFEND;
    /attach/
      WHILE TRUE DO
        pfp$r2_attach (r2_attach_input, update_catalog, {update_cycle_statistics} TRUE,
              local_usage_selections, local_share_selections, system_privilege,
              {validation_ring} caller_id.ring,
              {allowed_cycle_damage_symptoms} $fst$cycle_damage_symptoms [], cycle_number,
              cycle_damage_symptoms, global_file_name, local_status);
        IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
          EXIT /attach/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$R2_ATTACH');
        IFEND;
      WHILEND /attach/;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_attach;

?? TITLE := '  [XDCL] pfp$r3_attach_or_create_file', EJECT ??
*copy pfh$r3_attach_or_create_file

  PROCEDURE [XDCL] pfp$r3_attach_or_create_file
    (    validation_ring: ost$valid_ring;
         exception_selection_info: pft$exception_selection_info;
         p_attachment_options: {input} ^fst$attachment_options;
         p_file_label: {input} fmt$p_file_label;
         retention: fst$retention;
         retrieve_option: pft$retrieve_option;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR allowed_access: fst$file_access_options;
     VAR selected_access: fst$file_access_options;
     VAR required_sharing: fst$file_access_options;
     VAR selected_sharing: fst$file_access_options;
     VAR action_taken: pft$attach_or_create_action;
     VAR label_used: boolean;
     VAR device_class: rmt$device_class;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      family: pft$name,
      first_path_element: fst$path_element_name,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      global_file_name: ost$binary_unique_name,
      master_catalog_name: pft$name,
      system_privilege: boolean;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$r3_attach_or_create_file);

    osp$verify_system_privilege;

    IF (evaluated_file_reference.number_of_path_elements > 2) OR
          (fsp$path_element (^evaluated_file_reference, 1)^ = fsc$local) THEN
      status.normal := TRUE;
    ELSE
      clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} FALSE, fs_path,
            fs_path_size, status);
      IF status.normal THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$path_too_short, fs_path (1, fs_path_size),
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, 3, radix, NOT Include_radix, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'file', status);
      IFEND;
    IFEND;


    IF status.normal AND (fsp$path_element (^evaluated_file_reference, 1)^ <> fsc$local) THEN
      first_path_element := fsp$path_element (^evaluated_file_reference, 1)^;
      family := first_path_element (1, osc$max_name_size);
      pfp$validate_site_options (family, site_archive_option, site_backup_option, site_release_option,
            status);
    IFEND;

    IF status.normal THEN
      pfp$get_eval_file_ref_mast_cat (evaluated_file_reference, master_catalog_name);
      system_privilege := pfp$system_privilege (validation_ring, master_catalog_name);
    /attach_or_create_file/
      WHILE TRUE DO
        pfp$r2_attach_or_create_file (validation_ring, system_privilege, exception_selection_info,
              p_attachment_options, p_file_label, retention, retrieve_option, site_archive_option,
              site_backup_option, site_release_option,  evaluated_file_reference, allowed_access,
              selected_access, required_sharing, selected_sharing, action_taken, label_used, device_class,
              global_file_name, status);
        IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
          EXIT /attach_or_create_file/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$R2_ATTACH_OR_CREATE_FILE');
        IFEND;
      WHILEND /attach_or_create_file/;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$r3_attach_or_create_file);
  PROCEND pfp$r3_attach_or_create_file;

?? TITLE := '  [XDCL, #GATE] pfp$r3_change', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_change
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         change_list: pft$change_list;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$master_catalog_name_index + 1;

    VAR
      caller_id: ost$caller_identifier,
      change_index: ost$non_negative_integers,
      converted_family_name: ost$family_name,
      cycle_number: pft$cycle_number,
      device_class: rmt$device_class,
      local_password: pft$password,
      local_status: ost$status,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      p_local_change_list: ^pft$change_list,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      system_privilege: boolean,
      variant_path: pft$variant_path;

    osp$verify_system_privilege;
    #CALLER_ID (caller_id);
    status.normal := TRUE;

    check_cycle_selector (cycle_selector, local_status);

    IF local_status.normal THEN
      pfi$convert_password (password, local_password, local_status);
    IFEND;

    IF local_status.normal THEN
      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, local_status);
    IFEND;

    IF local_status.normal THEN
      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, file_path,
              p_converted_path^, local_status);

        IF local_status.normal THEN
          variant_path.complete_path := FALSE;
          variant_path.p_path := p_converted_path;
          PUSH p_local_change_list: [1 .. UPPERBOUND (change_list)];
          convert_change_list (variant_path, change_list, p_local_change_list^, local_status);
        IFEND;

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_converted_path^ [pfc$master_catalog_name_index]);
        /df_client_change/
          WHILE TRUE DO
            pfp$r2_df_client_change (served_family_locator, p_converted_path^, cycle_selector, local_password,
                  system_privilege, p_local_change_list^, cycle_number, device_class, change_index,
                  local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_change/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_CHANGE');
            IFEND;
          WHILEND /df_client_change/;

          IF avp$security_option_active (avc$vso_security_audit) AND (change_index > 0) THEN
            audit_changes (variant_path, cycle_number, device_class, system_privilege, p_local_change_list^,
                  change_index, local_status);
          IFEND;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, file_path, p_complete_path^, local_status);

        IF local_status.normal THEN
          variant_path.complete_path := TRUE;
          variant_path.p_complete_path := p_complete_path;
          PUSH p_local_change_list: [1 .. UPPERBOUND (change_list)];
          convert_change_list (variant_path, change_list, p_local_change_list^, local_status);
        IFEND;

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_complete_path^ [pfc$master_catalog_path_index]);
        /change/
          WHILE TRUE DO
            pfp$r2_change (pfc$local_mainframe, p_complete_path^, cycle_selector, local_password,
                  system_privilege, p_local_change_list^, cycle_number, device_class, change_index,
                  local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /change/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_CHANGE');
            IFEND;
          WHILEND /change/;

          IF avp$security_option_active (avc$vso_security_audit) AND (change_index > 0) THEN
            audit_changes (variant_path, cycle_number, device_class, system_privilege, p_local_change_list^,
                  change_index, local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_change;

?? TITLE := '  [XDCL, #GATE] pfp$r3_change_catalog_flush_opt', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_change_catalog_flush_opt
    (    flush_catalogs: boolean);

    pfv$flush_catalogs := flush_catalogs;
  PROCEND pfp$r3_change_catalog_flush_opt;

?? TITLE := '  [XDCL, #GATE] pfp$r3_change_cycle_damage', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_change_cycle_damage
    (    file: fst$file_reference;
         password: pft$password;
         new_damage_symptoms: fst$cycle_damage_symptoms;
     VAR status: ost$status);

    CONST
      command_file_reference_allowed = TRUE,
      minimum_path_length = 3;

    VAR
      converted_family_name: ost$family_name,
      converted_password: pft$password,
      cycle_selector: pft$cycle_selector,
      evaluated_file_reference: fst$evaluated_file_reference,
      family_name: ost$family_name,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      ignore_status: ost$status,
      p_complete_path: pft$p_complete_path,
      p_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

    pfi$convert_password (password, converted_password, status);

    IF status.normal THEN
      fsp$evaluate_file_reference (file, NOT command_file_reference_allowed, evaluated_file_reference,
            status);
    IFEND;

    IF status.normal THEN
      pfi$convert_cycle_reference (evaluated_file_reference.cycle_reference, cycle_selector, status);
    IFEND;

    IF status.normal THEN
      IF evaluated_file_reference.number_of_path_elements < minimum_path_length THEN
        clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} FALSE, fs_path,
              fs_path_size, ignore_status);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$path_too_short, fs_path (1, fs_path_size),
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, 3, radix, NOT include_radix, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'file', status);
      IFEND;
    IFEND;

    IF status.normal THEN
      pfi$get_family_from_fs_struct (evaluated_file_reference, family_name);
      check_family_location (family_name, converted_family_name, served_family, served_family_locator,
            status);
    IFEND;

    IF status.normal THEN
      IF served_family THEN
        PUSH p_path: [1 .. evaluated_file_reference.number_of_path_elements];
        pfp$convert_fs_to_pft$path (evaluated_file_reference, p_path^);
      /df_client_change_cy_dam/
        WHILE TRUE DO
          pfp$r2_df_client_change_cy_dam (served_family_locator, p_path^, cycle_selector, converted_password,
                new_damage_symptoms, status);
          IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
            EXIT /df_client_change_cy_dam/;
          ELSE
            pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_CHANGE_CY_DAM');
          IFEND;
        WHILEND /df_client_change_cy_dam/;
      ELSE
        PUSH p_complete_path: [1 .. evaluated_file_reference.number_of_path_elements + 1];
        pfp$convert_fs_to_complete_path (evaluated_file_reference, p_complete_path, status);
        IF status.normal THEN
        /change_cycle_damage/
          WHILE TRUE DO
            pfp$r2_change_cycle_damage (p_complete_path^, cycle_selector, converted_password,
                  new_damage_symptoms, status);
            IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
              EXIT /change_cycle_damage/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_CHANGE_CYCLE_DAMAGE');
            IFEND;
          WHILEND /change_cycle_damage/;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pfp$r3_change_cycle_damage;

?? TITLE := '  [XDCL, #GATE] pfp$r3_change_cycle_date_time', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_change_cycle_date_time
    (    file: fst$file_reference;
         password: pft$password;
         p_new_access_date_time: ^fst$date_time;
         p_new_creation_date_time: ^fst$date_time;
         p_new_modification_date_time: ^fst$date_time;
     VAR status: ost$status);

    CONST
      command_file_reference_allowed = TRUE,
      minimum_path_length = 3;

    VAR
      converted_access_date_time: pft$date_time,
      converted_creation_date_time: pft$date_time,
      converted_family_name: ost$family_name,
      converted_mod_date_time: pft$date_time,
      converted_password: pft$password,
      cycle_selector: pft$cycle_selector,
      evaluated_file_reference: fst$evaluated_file_reference,
      family_name: ost$family_name,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      ignore_status: ost$status,
      p_complete_path: pft$p_complete_path,
      p_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

    status.normal := TRUE;
    pfi$convert_password (password, converted_password, status);

    IF status.normal THEN
      convert_date_time (p_new_access_date_time, converted_access_date_time, status);
      IF NOT status.normal THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'new_access_date_time', status);
      IFEND;
    IFEND;

    IF status.normal THEN
      convert_date_time (p_new_creation_date_time, converted_creation_date_time, status);
      IF NOT status.normal THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'new_creation_date_time', status);
      IFEND;
    IFEND;

    IF status.normal THEN
      convert_date_time (p_new_modification_date_time, converted_mod_date_time, status);
      IF NOT status.normal THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'new_modification_date_time', status);
      IFEND;
    IFEND;

    IF status.normal THEN
      fsp$evaluate_file_reference (file, NOT command_file_reference_allowed, evaluated_file_reference,
            status);
    IFEND;

    IF status.normal THEN
      pfi$convert_cycle_reference (evaluated_file_reference.cycle_reference, cycle_selector, status);
    IFEND;

    IF status.normal THEN
      IF evaluated_file_reference.number_of_path_elements < minimum_path_length THEN
        clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} FALSE, fs_path,
              fs_path_size, ignore_status);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$path_too_short, fs_path (1, fs_path_size),
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, 3, radix, NOT include_radix, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'file', status);
      IFEND;
    IFEND;

    IF status.normal THEN
      pfi$get_family_from_fs_struct (evaluated_file_reference, family_name);
      check_family_location (family_name, converted_family_name, served_family, served_family_locator,
            status);
    IFEND;

    IF status.normal THEN
      IF served_family THEN
        PUSH p_path: [1 .. evaluated_file_reference.number_of_path_elements];
        pfp$convert_fs_to_pft$path (evaluated_file_reference, p_path^);
      /df_client_change_cy_dt/
        WHILE TRUE DO
          pfp$r2_df_client_change_cy_dt (served_family_locator, p_path^, cycle_selector, converted_password,
                converted_access_date_time, converted_creation_date_time, converted_mod_date_time,
                status);
          IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
            EXIT /df_client_change_cy_dt/;
          ELSE
            pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_CHANGE_CY_DT');
          IFEND;
        WHILEND /df_client_change_cy_dt/;
      ELSE
        PUSH p_complete_path: [1 .. evaluated_file_reference.number_of_path_elements + 1];
        pfp$convert_fs_to_complete_path (evaluated_file_reference, p_complete_path, status);
        IF status.normal THEN
        /change_cycle_date_time/
          WHILE TRUE DO
            pfp$r2_change_cycle_date_time (p_complete_path^, cycle_selector, converted_password,
                  converted_access_date_time, converted_creation_date_time, converted_mod_date_time,
                  status);
            IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
              EXIT /change_cycle_date_time/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_CHANGE_CYCLE_DATE_TIME');
            IFEND;
          WHILEND /change_cycle_date_time/;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pfp$r3_change_cycle_date_time;

?? TITLE := '  [XDCL, #GATE] pfp$r3_change_file', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_change_file
    (    file: fst$file_reference;
         password: pft$password;
         file_changes: ^fst$file_changes;
     VAR status: ost$status);

    CONST
      command_file_reference_allowed = TRUE,
      minimum_path_length = 3;

    VAR
      caller_id: ost$caller_identifier,
      change_index: ost$non_negative_integers,
      converted_family_name: ost$family_name,
      cycle_number: pft$cycle_number,
      cycle_selector: pft$cycle_selector,
      device_class: rmt$device_class,
      evaluated_file_reference: fst$evaluated_file_reference,
      family_name: ost$family_name,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      ignore_status: ost$status,
      local_password: pft$password,
      local_status: ost$status,
      p_complete_path: pft$p_complete_path,
      p_local_file_changes: ^fst$file_changes,
      p_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      system_privilege: boolean,
      variant_path: pft$variant_path;

    osp$verify_system_privilege;
    #CALLER_ID (caller_id);
    status.normal := TRUE;

    pfi$convert_password (password, local_password, local_status);

    IF local_status.normal THEN
      fsp$evaluate_file_reference (file, NOT command_file_reference_allowed, evaluated_file_reference,
            local_status);
    IFEND;

    IF local_status.normal THEN
      pfi$convert_cycle_reference (evaluated_file_reference.cycle_reference, cycle_selector, local_status);
    IFEND;

    IF local_status.normal THEN
      IF evaluated_file_reference.number_of_path_elements < minimum_path_length THEN
        clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} FALSE, fs_path,
              fs_path_size, ignore_status);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$path_too_short, fs_path (1, fs_path_size),
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, 3, radix, NOT include_radix, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'file', status);
      IFEND;
    IFEND;

    IF local_status.normal THEN
      pfi$get_family_from_fs_struct (evaluated_file_reference, family_name);
      check_family_location (family_name, converted_family_name, served_family, served_family_locator,
            local_status);
    IFEND;

    IF local_status.normal THEN
      PUSH p_path: [1 .. evaluated_file_reference.number_of_path_elements];
      pfp$convert_fs_to_pft$path (evaluated_file_reference, p_path^);
      system_privilege := pfp$system_privilege (caller_id.ring, p_path^ [pfc$master_catalog_name_index]);
      variant_path.complete_path := FALSE;
      variant_path.p_path := p_path;
      PUSH p_local_file_changes: [1 .. UPPERBOUND (file_changes^)];
      convert_file_changes (variant_path, file_changes, p_local_file_changes, local_status);
      IF local_status.normal THEN
        system_privilege := pfp$system_privilege (caller_id.ring, p_path^ [pfc$master_catalog_name_index]);
        IF served_family THEN

        /df_client_change_file/
          WHILE TRUE DO
            pfp$r2_df_client_change_file (served_family_locator, p_path^, cycle_selector, local_password,
                  system_privilege, p_local_file_changes, cycle_number, device_class, change_index,
                  local_status);
            IF local_status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_change_file/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_CHANGE_FILE');
            IFEND;
          WHILEND /df_client_change_file/;

          IF avp$security_option_active (avc$vso_security_audit) AND (change_index > 0) THEN
            audit_file_changes (variant_path, cycle_number, device_class, system_privilege,
                  p_local_file_changes^, change_index, local_status);
          IFEND;
        ELSE
          PUSH p_complete_path: [1 .. evaluated_file_reference.number_of_path_elements + 1];
          pfp$convert_fs_to_complete_path (evaluated_file_reference, p_complete_path, local_status);
          IF local_status.normal THEN
            system_privilege :=
                  pfp$system_privilege (caller_id.ring, p_path^ [pfc$master_catalog_name_index]);
          /change_file/
            WHILE TRUE DO
              pfp$r2_change_file (pfc$local_mainframe, p_complete_path^, cycle_selector, local_password,
                    system_privilege, p_local_file_changes, cycle_number, device_class, change_index,
                    local_status);
              IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
                EXIT /change_file/;
              ELSE
                pfp$catalog_access_retry_wait ('PFP$R2_CHANGE_FILE');
              IFEND;
            WHILEND /change_file/;
          IFEND;

          IF avp$security_option_active (avc$vso_security_audit) AND (change_index > 0) THEN
            audit_file_changes (variant_path, cycle_number, device_class, system_privilege,
                  p_local_file_changes^, change_index, local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_change_file;

?? TITLE := '  [XDCL, #GATE] pfp$r3_change_res_to_releasable', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_change_res_to_releasable
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$master_catalog_name_index + 1;

    VAR
      converted_family_name: ost$family_name,
      local_status: ost$status,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      system_privilege: boolean;

    osp$verify_system_privilege;
    status.normal := TRUE;

    check_cycle_selector (cycle_selector, local_status);

    IF local_status.normal THEN
      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, local_status);
    IFEND;

    IF local_status.normal THEN
      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, file_path,
              p_converted_path^, local_status);

        IF local_status.normal THEN
        /df_client_change_res_rel/
          WHILE TRUE DO
            pfp$r2_df_client_change_res_rel (served_family_locator, p_converted_path^, cycle_selector,
                  local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_change_res_rel/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_CHANGE_RES_REL');
            IFEND;
          WHILEND /df_client_change_res_rel/;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, file_path, p_complete_path^, local_status);

        IF local_status.normal THEN
        /change_res_to_releasable/
          WHILE TRUE DO
            pfp$r2_change_res_to_releasable (p_complete_path^, cycle_selector, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /change_res_to_releasable/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_CHANGE_RES_TO_RELEASABLE');
            IFEND;
          WHILEND /change_res_to_releasable/;
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_change_res_to_releasable;

  PROCEDURE [XDCL, #GATE] pfp$r3_define
    (    lfn: amt$local_file_name;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         retention: pft$retention;
         log: pft$log;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$master_catalog_name_index + 1;

    VAR
      actual_cycle: pft$cycle_number,
      audit_ownership: audit_ownership_rec,
      authority: pft$authority,
      bytes_allocated: amt$file_byte_address,
      caller_id: ost$caller_identifier,
      converted_family_name: ost$family_name,
      fs_retention: fst$retention,
      local_lfn: amt$local_file_name,
      local_password: pft$password,
      local_status: ost$status,
      mainframe_id: pmt$binary_mainframe_id,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      p_dummy_buffers: ^pft$file_server_buffers,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      system_privilege: boolean,
      variant_path: pft$variant_path;

    osp$verify_system_privilege;
    #CALLER_ID (caller_id);
    status.normal := TRUE;

    convert_lfn (lfn, local_lfn, local_status);

    IF local_status.normal THEN
      check_cycle_selector (cycle_selector, local_status);
    IFEND;

    IF local_status.normal THEN
      pfi$convert_password (password, local_password, local_status);
    IFEND;

    IF local_status.normal THEN
      check_retention (retention, local_status);
      IF local_status.normal THEN
        fs_retention.selector := fsc$retention_day_increment;
        fs_retention.day_increment := retention;
      IFEND;
    IFEND;

    IF local_status.normal THEN
      check_log (log, local_status);
    IFEND;

    IF local_status.normal THEN
      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, local_status);
    IFEND;

    IF local_status.normal THEN
      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, new_file_path,
              p_converted_path^, local_status);

        IF status.normal THEN
          variant_path.complete_path := FALSE;
          variant_path.p_path := p_converted_path;
          check_for_path_too_long (variant_path, status);
        IFEND;

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_converted_path^ [pfc$master_catalog_name_index]);
          /df_client_define/
            WHILE TRUE DO
              pfp$r2_df_client_define (served_family_locator, local_lfn, p_converted_path^, cycle_selector,
                    local_password, fs_retention, log, {retrieve_option} pfc$always_retrieve,
                    {site_archive_option} pfc$null_site_archive_option,
                    {site_backup_option} pfc$null_site_backup_option,
                    {site_release_option} pfc$null_site_release_option, system_privilege, caller_id.ring,
                    {device_class} rmc$mass_storage_device, {p_mass_storage_request_info} NIL,
                    {p_removable_media_req_info} NIL, {p_volume_list} NIL, actual_cycle, authority,
                    bytes_allocated, local_status);
              IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
                EXIT /df_client_define/;
              ELSE
                pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_DEFINE');
              IFEND;
            WHILEND /df_client_define/;

          IF local_status.normal AND (pfc$master_catalog_owner IN authority.ownership) THEN
            sfp$accumulate_file_space (sfc$perm_file_space_limit, bytes_allocated);
          IFEND;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            IF local_status.normal THEN
              audit_ownership.ownership_known := TRUE;
              audit_ownership.ownership := authority.ownership;
            ELSE
              audit_ownership.ownership_known := FALSE;
              audit_ownership.system_privilege := system_privilege;
            IFEND;
            audit_cycle_creation (variant_path, cycle_selector, rmc$mass_storage_device, audit_ownership,
                  local_status);
          IFEND;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, new_file_path, p_complete_path^, local_status);

        IF status.normal THEN
          variant_path.complete_path := TRUE;
          variant_path.p_complete_path := p_complete_path;
          check_for_path_too_long (variant_path, status);
        IFEND;

        IF local_status.normal THEN
          p_dummy_buffers := NIL;
          pmp$get_pseudo_mainframe_id (mainframe_id);
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_complete_path^ [pfc$master_catalog_path_index]);
        /define/
          WHILE TRUE DO
            pfp$r2_define (pfc$local_mainframe, mainframe_id, local_lfn, p_complete_path^, cycle_selector,
                  local_password, fs_retention, log, {retrieve_option} pfc$always_retrieve,
                  {site_archive_option} pfc$null_site_archive_option,
                  {site_backup_option} pfc$null_site_backup_option,
                  {site_release_option} pfc$null_site_release_option, system_privilege, caller_id.ring,
                  {device_class} rmc$mass_storage_device, {p_mass_storage_request_info} NIL,
                  {p_removable_media_req_info} NIL, {p_volume_list} NIL, actual_cycle, authority,
                  bytes_allocated, p_dummy_buffers, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /define/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DEFINE');
            IFEND;
          WHILEND /define/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            IF local_status.normal THEN
              audit_ownership.ownership_known := TRUE;
              audit_ownership.ownership := authority.ownership;
            ELSE
              audit_ownership.ownership_known := FALSE;
              audit_ownership.system_privilege := system_privilege;
            IFEND;
            audit_cycle_creation (variant_path, cycle_selector, rmc$mass_storage_device, audit_ownership,
                  local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_define;

?? TITLE := '  [XDCL, #GATE] pfp$r3_define_catalog', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_define_catalog
    (    path: pft$path;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$subcatalog_name_index;

    VAR
      audit_ownership: audit_ownership_rec,
      caller_id: ost$caller_identifier,
      charge_id: pft$charge_id,
      converted_family_name: ost$family_name,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      p_fs_path: ^fst$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      system_privilege: boolean,
      variant_path: pft$variant_path;

    osp$verify_system_privilege;
    #CALLER_ID (caller_id);
    status.normal := TRUE;

    IF UPPERBOUND (path) <= pfc$maximum_catalog_depth THEN
      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, local_status);
    ELSE
      PUSH p_fs_path;
      pfp$convert_pft$path_to_fs_path (path, p_fs_path^, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$too_many_catalogs_in_path,
            p_fs_path^ (1, fs_path_size), local_status);
      osp$append_status_integer (osc$status_parameter_delimiter, pfc$maximum_catalog_depth, radix,
            NOT include_radix, local_status);
      osp$append_status_integer (osc$status_parameter_delimiter, UPPERBOUND (path), radix, NOT include_radix,
            local_status);
    IFEND;

    IF local_status.normal THEN
      pmp$get_account_project (charge_id.account, charge_id.project, local_status);
      pfp$process_unexpected_status (local_status);

      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, new_catalog_path,
              p_converted_path^, local_status);

        IF local_status.normal THEN
          variant_path.complete_path := FALSE;
          variant_path.p_path := p_converted_path;
          check_for_path_too_long (variant_path, local_status);
        IFEND;

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_converted_path^ [pfc$master_catalog_name_index]);
        /df_client_define_catalog/
          WHILE TRUE DO
            pfp$r2_df_client_define_catalog (served_family_locator, p_converted_path^, charge_id,
                  system_privilege, {catalog_type_selected} FALSE, pfc$external_catalog,
                  {p_mass_storage_request_info} NIL, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_define_catalog/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_DEFINE_CATALOG');
            IFEND;
          WHILEND /df_client_define_catalog/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            audit_ownership.ownership_known := FALSE;
            audit_ownership.system_privilege := system_privilege;
            audit_catalog_creation (variant_path, audit_ownership, local_status);
          IFEND;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, new_catalog_path, p_complete_path^, local_status);

        IF local_status.normal THEN
          variant_path.complete_path := TRUE;
          variant_path.p_complete_path := p_complete_path;
          check_for_path_too_long (variant_path, local_status);
        IFEND;

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_complete_path^ [pfc$master_catalog_path_index]);
        /define_catalog/
          WHILE TRUE DO
            pfp$r2_define_catalog (p_complete_path^, charge_id, system_privilege,
                  {catalog_type_selected} FALSE, pfc$external_catalog, {p_mass_storage_request_info} NIL,
                  local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /define_catalog/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DEFINE_CATALOG');
            IFEND;
          WHILEND /define_catalog/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            audit_ownership.ownership_known := FALSE;
            audit_ownership.system_privilege := system_privilege;
            audit_catalog_creation (variant_path, audit_ownership, local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_define_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$r3_define_data', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_define_data
    (    lfn: amt$local_file_name;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         update_cycle_statistics: boolean;
         password_selector: pft$password_selector;
         p_mass_storage_request_info: ^fmt$mass_storage_request_info;
         p_volume_list: ^array [1 .. * ] of rmt$recorded_vsn;
         purge_cycle_options: pft$purge_cycle_options;
         replace_cycle_data: boolean;
         restore_selections: put$restore_data_selections;
     VAR mandated_modification_time: {i/o} pft$mandated_modification_time;
     VAR data_residence: pft$data_residence;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$master_catalog_name_index + 1;

    VAR
      audit_ownership: audit_ownership_rec,
      authority: pft$authority,
      bytes_allocated: amt$file_byte_address,
      caller_id: ost$caller_identifier,
      converted_family_name: ost$family_name,
      converted_file_class: rmt$mass_storage_class,
      local_lfn: amt$local_file_name,
      local_password_selector: pft$password_selector,
      mainframe_id: pmt$binary_mainframe_id,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      p_dummy_buffers: ^pft$file_server_buffers,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      variant_path: pft$variant_path;


    PROCEDURE audit_cycle_attachment
      (    variant_path: pft$variant_path;
           cycle_selector: pft$cycle_selector;
           audit_ownership: audit_ownership_rec;
           audit_status: ost$status);

      VAR
        audit_information: sft$audit_information,
        audited_object: sft$audited_fs_object_id,
        ignore_status: ost$status,
        usage_selections: pft$usage_selections;

      audit_information.audited_operation := sfc$ao_fs_attach_file;
      audited_object.variant_path := variant_path;
      audited_object.object_type := sfc$afsot_cycle;
      audited_object.cycle_selector_p := ^cycle_selector;
      audited_object.device_class := rmc$mass_storage_device;
      audit_information.attach_file.object_id_p := ^audited_object;
      IF audit_ownership.ownership_known THEN
        audit_information.attach_file.ownership := audit_ownership.ownership;
      ELSE
        pfp$get_ownership (variant_path, audit_ownership.system_privilege,
              audit_information.attach_file.ownership, ignore_status);
      IFEND;
      usage_selections := - $pft$usage_selections [];
      audit_information.attach_file.access_mode_p := ^usage_selections;
      sfp$emit_audit_statistic (audit_information, audit_status);
    PROCEND audit_cycle_attachment;


    osp$verify_system_privilege;
    #CALLER_ID (caller_id);

    convert_lfn (lfn, local_lfn, status);

    IF status.normal THEN
      check_cycle_selector (cycle_selector, status);
    IFEND;

    IF status.normal THEN
      convert_password_selector (password_selector, local_password_selector, status);
    IFEND;

    IF status.normal THEN
      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, status);
    IFEND;

    IF status.normal THEN
      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, file_path,
              p_converted_path^, status);

        IF status.normal THEN
        /df_client_define_data/
          WHILE TRUE DO
            pfp$r2_df_client_define_data (served_family_locator, local_lfn, p_converted_path^, cycle_selector,
                  update_cycle_statistics, local_password_selector, caller_id.ring,
                  p_mass_storage_request_info, p_volume_list, purge_cycle_options, replace_cycle_data,
                  restore_selections, mandated_modification_time, data_residence, authority, bytes_allocated,
                  status);
            IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_define_data/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_DEFINE_DATA');
            IFEND;
          WHILEND /df_client_define_data/;

          IF status.normal AND (pfc$master_catalog_owner IN authority.ownership) THEN
            sfp$accumulate_file_space (sfc$perm_file_space_limit, bytes_allocated);
          IFEND;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := FALSE;
            variant_path.p_path := p_converted_path;
            IF status.normal THEN
              audit_ownership.ownership_known := TRUE;
              audit_ownership.ownership := authority.ownership;
            ELSE
              audit_ownership.ownership_known := FALSE;
              audit_ownership.system_privilege := FALSE;
            IFEND;
            audit_cycle_attachment (variant_path, cycle_selector, audit_ownership, status);
          IFEND;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, file_path, p_complete_path^, status);

        IF status.normal THEN
          p_dummy_buffers := NIL;
          pmp$get_pseudo_mainframe_id (mainframe_id);

        /define_data/
          WHILE TRUE DO
            pfp$r2_define_data (pfc$local_mainframe, mainframe_id, local_lfn, p_complete_path^,
                  cycle_selector, update_cycle_statistics, local_password_selector, caller_id.ring,
                  p_mass_storage_request_info, p_volume_list, purge_cycle_options, replace_cycle_data,
                  restore_selections, mandated_modification_time, data_residence, authority, bytes_allocated,
                  p_dummy_buffers, status);
            IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
              EXIT /define_data/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DEFINE_DATA');
            IFEND;
          WHILEND /define_data/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := TRUE;
            variant_path.p_complete_path := p_complete_path;
            IF status.normal THEN
              audit_ownership.ownership_known := TRUE;
              audit_ownership.ownership := authority.ownership;
            ELSE
              audit_ownership.ownership_known := FALSE;
              audit_ownership.system_privilege := FALSE;
            IFEND;
            audit_cycle_attachment (variant_path, cycle_selector, audit_ownership, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pfp$r3_define_data;

?? TITLE := '  [XDCL] pfp$r3_define_mass_storage', EJECT ??

  PROCEDURE [XDCL] pfp$r3_define_mass_storage
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         validation_ring: ost$valid_ring;
         fs_retention: fst$retention;
         log: pft$log;
         retrieve_option: pft$retrieve_option;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$master_catalog_name_index + 1;

    VAR
      actual_cycle: pft$cycle_number,
      audit_ownership: audit_ownership_rec,
      authority: pft$authority,
      bytes_allocated: amt$file_byte_address,
      converted_family_name: ost$family_name,
      local_file_name: amt$local_file_name,
      local_password: pft$password,
      mainframe_id: pmt$binary_mainframe_id,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      p_dummy_buffers: ^pft$file_server_buffers,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      system_privilege: boolean,
      variant_path: pft$variant_path;

    osp$verify_system_privilege;
    {
    { The last path name cannot be used for the local file name due to a
    { problem with duplicate file names in the system job when copying some
    { library files during a system upgrade.
    {
    pmp$get_unique_name (local_file_name, status);

    IF status.normal THEN
      check_cycle_selector (cycle_selector, status);
    IFEND;

    IF status.normal THEN
      pfi$convert_password (password, local_password, status);
    IFEND;

    IF status.normal THEN
      IF fs_retention.selector = fsc$retention_day_increment THEN
        check_retention (fs_retention.day_increment, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      check_log (log, status);
    IFEND;

    pfp$validate_site_options (path [pfc$family_name_index], site_archive_option, site_backup_option,
          site_release_option, status);

    IF status.normal THEN
      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, status);
    IFEND;

    IF status.normal THEN
      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, new_file_path,
              p_converted_path^, status);

        IF status.normal THEN
          variant_path.complete_path := FALSE;
          variant_path.p_path := p_converted_path;
          check_for_path_too_long (variant_path, status);
        IFEND;

        IF status.normal THEN
          system_privilege := pfp$system_privilege (validation_ring,
                p_converted_path^ [pfc$master_catalog_name_index]);

        /df_client_define/
          WHILE TRUE DO
            pfp$r2_df_client_define (served_family_locator, local_file_name, p_converted_path^,
                  cycle_selector, local_password, fs_retention, log, retrieve_option, site_archive_option,
                  site_backup_option, site_release_option, system_privilege, validation_ring,
                  rmc$mass_storage_device, p_mass_storage_request_info, {p_removable_media_req_info} NIL,
                  {p_volume_list} NIL, actual_cycle, authority, bytes_allocated, status);
            IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_define/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_DEFINE');
            IFEND;
          WHILEND /df_client_define/;

          IF status.normal AND (pfc$master_catalog_owner IN authority.ownership) THEN
            sfp$accumulate_file_space (sfc$perm_file_space_limit, bytes_allocated);
          IFEND;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            IF status.normal THEN
              audit_ownership.ownership_known := TRUE;
              audit_ownership.ownership := authority.ownership;
            ELSE
              audit_ownership.ownership_known := FALSE;
              audit_ownership.system_privilege := system_privilege;
            IFEND;
            audit_cycle_creation (variant_path, cycle_selector, rmc$mass_storage_device, audit_ownership,
                  status);
          IFEND;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, new_file_path, p_complete_path^, status);

        IF status.normal THEN
          variant_path.complete_path := TRUE;
          variant_path.p_complete_path := p_complete_path;
          check_for_path_too_long (variant_path, status);
        IFEND;

        IF status.normal THEN
          p_dummy_buffers := NIL;
          system_privilege := pfp$system_privilege (validation_ring,
                p_complete_path^ [pfc$master_catalog_path_index]);
          pmp$get_pseudo_mainframe_id (mainframe_id);

        /define/
          WHILE TRUE DO
            pfp$r2_define (pfc$local_mainframe, mainframe_id, local_file_name, p_complete_path^,
                  cycle_selector, local_password, fs_retention, log, retrieve_option, site_archive_option,
                  site_backup_option, site_release_option, system_privilege, validation_ring,
                  rmc$mass_storage_device, p_mass_storage_request_info, {p_removable_media_req_info} NIL,
                  {p_volume_list} NIL, actual_cycle, authority, bytes_allocated, p_dummy_buffers, status);
            IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
              EXIT /define/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DEFINE');
            IFEND;
          WHILEND /define/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            IF status.normal THEN
              audit_ownership.ownership_known := TRUE;
              audit_ownership.ownership := authority.ownership;
            ELSE
              audit_ownership.ownership_known := FALSE;
              audit_ownership.system_privilege := system_privilege;
            IFEND;
            audit_cycle_creation (variant_path, cycle_selector, rmc$mass_storage_device, audit_ownership,
                  status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pfp$r3_define_mass_storage;

?? TITLE := '  [XDCL, #GATE] pfp$r3_define_mass_storage_cat', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_define_mass_storage_cat
    (    path: pft$path;
         catalog_type: pft$catalog_types;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
     VAR status: ost$status);

    CONST
      system_privilege = TRUE;

    VAR
      audit_ownership: audit_ownership_rec,
      charge_id: pft$charge_id,
      converted_family_name: ost$family_name,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      p_complete_path: ^pft$complete_path,
      p_fs_path: ^fst$path,
      p_mass_storage_info: ^fmt$mass_storage_request_info,
      variant_path: pft$variant_path;

    osp$verify_system_privilege;
    status.normal := TRUE;

    IF UPPERBOUND (path) <= pfc$maximum_catalog_depth THEN
      local_status.normal := TRUE;
    ELSE
      PUSH p_fs_path;
      pfp$convert_pft$path_to_fs_path (path, p_fs_path^, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$too_many_catalogs_in_path,
            p_fs_path^ (1, fs_path_size), local_status);
      osp$append_status_integer (osc$status_parameter_delimiter, pfc$maximum_catalog_depth, radix,
            NOT include_radix, local_status);
      osp$append_status_integer (osc$status_parameter_delimiter, UPPERBOUND (path), radix, NOT include_radix,
            local_status);
    IFEND;

    IF local_status.normal THEN
      pmp$get_account_project (charge_id.account, charge_id.project, local_status);
      pfp$process_unexpected_status (local_status);

      PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
      convert_path (path, {minimum_path_length} pfc$subcatalog_name_index, new_catalog_path, p_complete_path^,
            local_status);

      IF local_status.normal THEN
        variant_path.complete_path := TRUE;
        variant_path.p_complete_path := p_complete_path;
        check_for_path_too_long (variant_path, local_status);
      IFEND;

      IF local_status.normal THEN
        IF catalog_type = pfc$external_catalog THEN
          p_mass_storage_info := p_mass_storage_request_info;
        ELSE
          {
          { Internal catalogs are physically located within another catalog.
          { Therefore, mass storage information does not apply.
          {
          p_mass_storage_info := NIL;
        IFEND;
        {
        { Only an owner or an administrator may create a catalog.  Therefore,
        { system_privilege is never appropriate in this procedure.
        {
        /define_catalog/
          WHILE TRUE DO
          pfp$r2_define_catalog (p_complete_path^, charge_id, NOT system_privilege,
                {catalog_type_selected} TRUE, catalog_type, p_mass_storage_info, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /define_catalog/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DEFINE_CATALOG');
            IFEND;
          WHILEND /define_catalog/;

        IF avp$security_option_active (avc$vso_security_audit) THEN
          audit_ownership.ownership_known := FALSE;
          audit_ownership.system_privilege := NOT system_privilege;
          audit_catalog_creation (variant_path, audit_ownership, local_status);
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_define_mass_storage_cat;

?? TITLE := '  [XDCL] pfp$r3_define_removable_media', EJECT ??

  PROCEDURE [XDCL] pfp$r3_define_removable_media
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         validation_ring: ost$valid_ring;
         retention: pft$retention;
         log: pft$log;
         device_class: rmt$device_class;
         p_removable_media_req_info: {input} ^fmt$removable_media_req_info;
         p_volume_list: {input} ^rmt$volume_list;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$master_catalog_name_index + 1;

    VAR
      actual_cycle: pft$cycle_number,
      audit_ownership: audit_ownership_rec,
      authority: pft$authority,
      bytes_allocated: amt$file_byte_address,
      converted_family_name: ost$family_name,
      fs_retention: fst$retention,
      local_file_name: amt$local_file_name,
      local_password: pft$password,
      mainframe_id: pmt$binary_mainframe_id,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      p_dummy_buffers: ^pft$file_server_buffers,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      system_privilege: boolean,
      tape_validation: boolean,
      validation_state: bat$tape_validation_state,
      variant_path: pft$variant_path;

    osp$verify_system_privilege;

    local_file_name := path [UPPERBOUND(path)];
    check_cycle_selector (cycle_selector, status);

    IF status.normal THEN
      pfi$convert_password (password, local_password, status);
    IFEND;

    IF status.normal THEN
      check_retention (retention, status);
      IF status.normal THEN
        fs_retention.selector := fsc$retention_day_increment;
        fs_retention.day_increment := retention;
      IFEND;
    IFEND;

    IF status.normal THEN
      check_log (log, status);
    IFEND;

    IF status.normal THEN
      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, status);
    IFEND;

    IF status.normal THEN
      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, file_path,
              p_converted_path^, status);

        IF status.normal THEN
          system_privilege := pfp$system_privilege (validation_ring,
                p_converted_path^ [pfc$master_catalog_name_index]);

        /df_client_define/
          WHILE TRUE DO
            pfp$r2_df_client_define (served_family_locator, local_file_name, p_converted_path^,
                  cycle_selector, local_password, fs_retention, log, {retrieve_option} pfc$always_retrieve,
                  {site_archive_option} pfc$null_site_archive_option,
                  {site_backup_option} pfc$null_site_backup_option,
                  {site_release_option} pfc$null_site_release_option, system_privilege, validation_ring,
                  device_class, {p_mass_storage_request_info} NIL, p_removable_media_req_info, p_volume_list,
                  actual_cycle, authority, bytes_allocated, status);
            IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_define/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_DEFINE');
            IFEND;
          WHILEND /df_client_define/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := FALSE;
            variant_path.p_path := p_converted_path;
            IF status.normal THEN
              audit_ownership.ownership_known := TRUE;
              audit_ownership.ownership := authority.ownership;
            ELSE
              audit_ownership.ownership_known := FALSE;
              audit_ownership.system_privilege := system_privilege;
            IFEND;
            audit_cycle_creation (variant_path, cycle_selector, device_class, audit_ownership, status);
          IFEND;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, file_path, p_complete_path^, status);

        IF status.normal THEN
          p_dummy_buffers := NIL;
          system_privilege := pfp$system_privilege (validation_ring,
                p_complete_path^ [pfc$master_catalog_path_index]);
          pmp$get_pseudo_mainframe_id (mainframe_id);

        /define/
          WHILE TRUE DO
            pfp$r2_define (pfc$local_mainframe, mainframe_id, local_file_name, p_complete_path^,
                  cycle_selector, local_password, fs_retention, log, {retrieve_option} pfc$always_retrieve,
                  {site_archive_option} pfc$null_site_archive_option,
                  {site_backup_option} pfc$null_site_backup_option,
                  {site_release_option} pfc$null_site_release_option, system_privilege, validation_ring,
                  device_class, {p_mass_storage_request_info} NIL, p_removable_media_req_info, p_volume_list,
                  actual_cycle, authority, bytes_allocated, p_dummy_buffers, status);
            IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
              EXIT /define/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DEFINE');
            IFEND;
          WHILEND /define/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := TRUE;
            variant_path.p_complete_path := p_complete_path;
            IF status.normal THEN
              audit_ownership.ownership_known := TRUE;
              audit_ownership.ownership := authority.ownership;
            ELSE
              audit_ownership.ownership_known := FALSE;
              audit_ownership.system_privilege := system_privilege;
            IFEND;
            audit_cycle_creation (variant_path, cycle_selector, device_class, audit_ownership, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pfp$r3_define_removable_media;

?? TITLE := '  [XDCL, #GATE] pfp$r3_delete_all_arch_entries', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_delete_all_arch_entries
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

    CONST
      minimum_path_length = 3;

    VAR
      converted_family_name: ost$family_name,
      p_complete_path: pft$p_complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

    status.normal := TRUE;

    check_cycle_selector (cycle_selector, status);
    IF status.normal THEN
      check_family_location (path [pfc$family_name_index], converted_family_name,
           served_family, served_family_locator, status);
      IF status.normal THEN
        IF served_family THEN
          PUSH p_converted_path: [1 .. UPPERBOUND (path)];
          convert_path_without_set (path, converted_family_name, minimum_path_length,
               file_path, p_converted_path^, status);
          IF status.normal THEN
          /df_client_del_all_arc_en/
            WHILE TRUE DO
            pfp$r2_df_client_del_all_arc_en (served_family_locator, p_converted_path^,
                 cycle_selector, status);
              IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
                EXIT /df_client_del_all_arc_en/;
              ELSE
                pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_DEL_ALL_ARC_EN');
              IFEND;
            WHILEND /df_client_del_all_arc_en/;
          IFEND;
        ELSE
          PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
          convert_path (path, minimum_path_length, file_path, p_complete_path^, status);
          IF status.normal THEN
          /delete_all_arch_entries/
            WHILE TRUE DO
              pfp$r2_delete_all_arch_entries (p_complete_path^, cycle_selector, status);
              IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
                EXIT /delete_all_arch_entries/;
              ELSE
                pfp$catalog_access_retry_wait ('PFP$R2_DELETE_ALL_ARCH_ENTRIES');
              IFEND;
            WHILEND /delete_all_arch_entries/;
          IFEND;
        IFEND;

      IFEND;
    IFEND;

  PROCEND pfp$r3_delete_all_arch_entries;

?? TITLE := '  [XDCL, #GATE] pfp$r3_delete_archive_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_delete_archive_entry
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
     VAR status: ost$status);

    CONST
      minimum_path_length = 3;

    VAR
      converted_family_name: ost$family_name,
      local_archive_identification: pft$archive_identification,
      p_complete_path: pft$p_complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

    status.normal := TRUE;

    /delete_archive_entry_block/
      BEGIN
        check_cycle_selector (cycle_selector, status);
        IF NOT status.normal THEN
          EXIT /delete_archive_entry_block/;
        IFEND;

        pfp$convert_archive_ident (archive_identification, local_archive_identification, status);
        IF NOT status.normal THEN
          EXIT /delete_archive_entry_block/;
        IFEND;

        check_family_location (path [pfc$family_name_index], converted_family_name,
             served_family, served_family_locator, status);
        IF NOT status.normal THEN
          EXIT /delete_archive_entry_block/;
        IFEND;

        IF served_family THEN
          PUSH p_converted_path: [1 .. UPPERBOUND (path)];
          convert_path_without_set (path, converted_family_name, minimum_path_length,
               file_path, p_converted_path^, status);
          IF status.normal THEN
          /df_client_del_arch_entry/
            WHILE TRUE DO
              pfp$r2_df_client_del_arch_entry (served_family_locator, p_converted_path^,
                   cycle_selector, local_archive_identification, status);
              IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
                EXIT /df_client_del_arch_entry/;
              ELSE
                pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_DEL_ARCH_ENTRY');
              IFEND;
            WHILEND /df_client_del_arch_entry/;
          IFEND;
        ELSE
          PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
          convert_path (path, minimum_path_length, file_path, p_complete_path^, status);
          IF status.normal THEN
          /delete_archive_entry/
            WHILE TRUE DO
              pfp$r2_delete_archive_entry (p_complete_path^, cycle_selector, local_archive_identification,
                   status);
              IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
                EXIT /delete_archive_entry/;
              ELSE
                pfp$catalog_access_retry_wait ('PFP$R2_DELETE_ARCHIVE_ENTRY');
              IFEND;
            WHILEND /delete_archive_entry/;
          IFEND;
        IFEND;
      END /delete_archive_entry_block/;

  PROCEND pfp$r3_delete_archive_entry;

?? TITLE := '  [XDCL, #GATE] pfp$r3_delete_catalog_permit', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_delete_catalog_permit
    (    path: pft$path;
         group: pft$group;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$master_catalog_name_index;

    VAR
      caller_id: ost$caller_identifier,
      converted_family_name: ost$family_name,
      local_group: pft$group,
      local_status: ost$status,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      system_privilege: boolean,
      variant_path: pft$variant_path;

    osp$verify_system_privilege;
    #CALLER_ID (caller_id);
    status.normal := TRUE;

    convert_group (group, {creating_permit} FALSE, local_group, local_status);

    IF local_status.normal THEN
      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, local_status);
    IFEND;

    IF local_status.normal THEN
      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, catalog_path,
              p_converted_path^, local_status);
        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_converted_path^ [pfc$master_catalog_name_index]);
          /df_client_delete_permit/
            WHILE TRUE DO
              pfp$r2_df_client_delete_permit (p_converted_path^, pfc$catalog_object, system_privilege,
                    local_group, served_family_locator, local_status);
              IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
                EXIT /df_client_delete_permit/;
              ELSE
                pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_DELETE_PERMIT');
              IFEND;
            WHILEND /df_client_delete_permit/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := FALSE;
            variant_path.p_path := p_converted_path;
            audit_permit_deletion (variant_path, sfc$afsot_catalog, system_privilege, local_group,
                  local_status);
          IFEND;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, catalog_path, p_complete_path^, local_status);
        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_complete_path^ [pfc$master_catalog_path_index]);

        /delete_catalog_permit/
          WHILE TRUE DO
            pfp$r2_delete_catalog_permit (p_complete_path^, system_privilege, local_group, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /delete_catalog_permit/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DELETE_CATALOG_PERMIT');
            IFEND;
          WHILEND /delete_catalog_permit/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := TRUE;
            variant_path.p_complete_path := p_complete_path;
            audit_permit_deletion (variant_path, sfc$afsot_catalog, system_privilege, local_group,
                  local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_delete_catalog_permit;

?? TITLE := '  [XDCL, #GATE] pfp$r3_delete_permit', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_delete_permit
    (    path: pft$path;
         group: pft$group;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$master_catalog_name_index + 1;

    VAR
      caller_id: ost$caller_identifier,
      converted_family_name: ost$family_name,
      local_group: pft$group,
      local_status: ost$status,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      system_privilege: boolean,
      variant_path: pft$variant_path;

    osp$verify_system_privilege;
    #CALLER_ID (caller_id);
    status.normal := TRUE;

    convert_group (group, {creating_permit} FALSE, local_group, local_status);

    IF local_status.normal THEN
      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, local_status);
    IFEND;

    IF local_status.normal THEN
      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, file_path,
              p_converted_path^, local_status);

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_converted_path^ [pfc$master_catalog_name_index]);

          /df_client_delete_permit/
            WHILE TRUE DO
              pfp$r2_df_client_delete_permit (p_converted_path^, pfc$file_object, system_privilege,
                    local_group, served_family_locator, local_status);
              IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
                EXIT /df_client_delete_permit/;
              ELSE
                pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_DELETE_PERMIT');
              IFEND;
            WHILEND /df_client_delete_permit/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := FALSE;
            variant_path.p_path := p_converted_path;
            audit_permit_deletion (variant_path, sfc$afsot_file, system_privilege, local_group, local_status);
          IFEND;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, file_path, p_complete_path^, local_status);

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_complete_path^ [pfc$master_catalog_path_index]);

        /delete_permit/
          WHILE TRUE DO
            pfp$r2_delete_permit (p_complete_path^, system_privilege, local_group, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /delete_permit/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DELETE_PERMIT');
            IFEND;
          WHILEND /delete_permit/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := TRUE;
            variant_path.p_complete_path := p_complete_path;
            audit_permit_deletion (variant_path, sfc$afsot_file, system_privilege, local_group, local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_delete_permit;

?? TITLE := '[XDCL, #GATE] pfp$r3_flush_catalog', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_flush_catalog
    (    evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

    VAR
      converted_family_name: ost$family_name,
      family_name: ost$family_name,
      local_status: ost$status,
      p_complete_path: ^pft$complete_path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

    status.normal := TRUE;

    pfi$get_family_from_fs_struct (evaluated_file_reference, family_name);
    check_family_location (family_name, converted_family_name, served_family, served_family_locator,
          local_status);

    IF local_status.normal THEN
      IF served_family THEN
{ Not yet a served request.}
      ELSE
        PUSH p_complete_path: [1 .. evaluated_file_reference.number_of_path_elements + 1];
        pfp$convert_fs_to_complete_path (evaluated_file_reference, p_complete_path, local_status);
        IF local_status.normal THEN
        /flush_catalog/
          WHILE TRUE DO
            pfp$r2_flush_catalog (p_complete_path, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /flush_catalog/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DELETE_PERMIT');
            IFEND;
          WHILEND /flush_catalog/;
        IFEND;
      IFEND;
    IFEND;
    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND pfp$r3_flush_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$r3_get_family_set', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_get_family_set
    (    family_name: ost$name;
     VAR set_name: stt$set_name;
     VAR status: ost$status);

    VAR
      converted_family_name: ost$family_name,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

    check_family_location (family_name, converted_family_name, served_family, served_family_locator,
          status);
    IF status.normal THEN
      IF served_family THEN
        pfp$r2_df_client_get_family_set (converted_family_name, served_family_locator, set_name, status);
      ELSE
        osp$get_set_name (family_name, set_name, status);
      IFEND;
    IFEND;
  PROCEND pfp$r3_get_family_set;

?? TITLE := '  [XDCL, #GATE] pfp$r3_get_item_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_get_item_info
    (    path: pft$path;
         group: pft$group;
         catalog_info_selections: pft$catalog_info_selections;
         file_info_selections: pft$file_info_selections;
     VAR p_info: {i/o} pft$p_info;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$master_catalog_name_index;

    VAR
      caller_id: ost$caller_identifier,
      converted_family_name: ost$family_name,
      local_group: pft$group,
      local_status: ost$status,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      system_privilege: boolean;

    #CALLER_ID (caller_id);
    status.normal := TRUE;

    osp$verify_system_privilege;

    convert_group (group, {creating_permit} FALSE, local_group, local_status);

    IF local_status.normal THEN
      pfp$verify_pva (p_info, mmc$va_read_write, local_status);
    IFEND;

    IF local_status.normal THEN
      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, local_status);
    IFEND;

    IF local_status.normal THEN
      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, item_path,
              p_converted_path^, local_status);

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_converted_path^ [pfc$master_catalog_name_index]);
        /df_client_get_info/
          WHILE TRUE DO
            pfp$r2_df_client_get_info (pfc$get_item_info, p_converted_path^, system_privilege, local_group,
                  catalog_info_selections, file_info_selections, served_family_locator, p_info, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_get_info/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_GET_INFO');
            IFEND;
          WHILEND /df_client_get_info/;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, item_path, p_complete_path^, local_status);

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_complete_path^ [pfc$master_catalog_path_index]);
        /get_item_info/
          WHILE TRUE DO
            pfp$r2_get_item_info (p_complete_path^, system_privilege, local_group, catalog_info_selections,
                  file_info_selections, p_info, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /get_item_info/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_GET_ITEM_INFO');
            IFEND;
          WHILEND /get_item_info/;
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_get_item_info;

?? TITLE := '  [XDCL, #GATE] pfp$r3_get_move_obj_device_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_get_move_obj_device_info
    (    move_object_info_p: ^pft$move_object_info;
     VAR status: ost$status);

     status.normal := TRUE;

     pfp$r2_get_move_obj_device_info (move_object_info_p, status);

  PROCEND pfp$r3_get_move_obj_device_info;

?? TITLE := '  [XDCL, #GATE] pfp$r3_get_multi_item_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_get_multi_item_info
    (    path: pft$path;
         group: pft$group;
         catalog_info_selections: pft$catalog_info_selections;
         file_info_selections: pft$file_info_selections;
         p_cycle_reservation_criteria: ^pft$cycle_reservation_criteria;
     VAR p_info: {i/o} pft$p_info;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$master_catalog_name_index;

    VAR
      caller_id: ost$caller_identifier,
      converted_family_name: ost$family_name,
      local_group: pft$group,
      local_status: ost$status,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      system_privilege: boolean;

    #CALLER_ID (caller_id);
    status.normal := TRUE;

    osp$verify_system_privilege;

    convert_group (group, {creating_permit} FALSE, local_group, local_status);

    IF local_status.normal THEN
      pfp$verify_pva (p_info, mmc$va_read_write, local_status);
    IFEND;

    IF local_status.normal THEN
      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, local_status);
    IFEND;

    IF local_status.normal THEN
      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, item_path,
              p_converted_path^, local_status);

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_converted_path^ [pfc$master_catalog_name_index]);
        /df_client_get_info/
          WHILE TRUE DO
            pfp$r2_df_client_get_info (pfc$get_multi_item_info, p_converted_path^, system_privilege,
                  local_group, catalog_info_selections, file_info_selections, served_family_locator, p_info,
                  local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_get_info/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_GET_INFO');
            IFEND;
          WHILEND /df_client_get_info/;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, item_path, p_complete_path^, local_status);

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_complete_path^ [pfc$master_catalog_path_index]);
        /get_multi_item_info/
          WHILE TRUE DO
            pfp$r2_get_multi_item_info (p_complete_path^, system_privilege, local_group,
                  catalog_info_selections, file_info_selections, p_cycle_reservation_criteria,
                  p_info, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /get_multi_item_info/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_GET_INFO');
            IFEND;
          WHILEND /get_multi_item_info/;
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_get_multi_item_info;

?? TITLE := '  [XDCL, #GATE] pfp$r3_get_object_information', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_get_object_information
    (    evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
         p_validation_criteria: {i/o^} ^fst$goi_validation_criteria;
     VAR p_object_information: {i/o} ^SEQ ( * );
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      local_information_request: fst$goi_information_request,
      min_ring: ost$valid_ring,
      p_local_validation_criteria: ^fst$goi_validation_criteria,
      password_selector: pft$password_selector,
      subject_permit_count: ost$non_negative_integers,
      system_privilege: boolean,
      user_identification: ost$user_identification,
      validation_ring: ost$valid_ring;

    osp$verify_system_privilege;
    #CALLER_ID (caller_id);

    IF (evaluated_file_reference.number_of_path_elements > 1) OR
          (fsp$path_element (^evaluated_file_reference, 1)^ = fsc$local) OR avp$system_administrator () THEN
      status.normal := TRUE;
    ELSE
      pmp$get_user_identification (user_identification, status);
      IF status.normal THEN
        IF fsp$path_element (^evaluated_file_reference, 1)^ = user_identification.family THEN
          IF NOT avp$family_administrator () THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$not_family_owner,
                  fsp$path_element (^evaluated_file_reference, 1)^, status);
          IFEND;
        ELSE
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_family,
                fsp$path_element (^evaluated_file_reference, 1)^, status);
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      check_information_request (information_request, status);
    IFEND;

    IF status.normal THEN
      local_information_request := information_request;

      IF p_validation_criteria = NIL THEN
        p_local_validation_criteria := NIL;
        password_selector.password_specified := pfc$default_password_option;
        subject_permit_count := 0;
        min_ring := avp$ring_min ();
        IF caller_id.ring <= min_ring THEN
          validation_ring := caller_id.ring;
        ELSE
          validation_ring := min_ring;
        IFEND;
      ELSE
        pfp$verify_pva (p_validation_criteria, mmc$va_read, status);

        IF status.normal THEN
          PUSH p_local_validation_criteria: [1 .. UPPERBOUND (p_validation_criteria^)];
          convert_validation_criteria (caller_id, p_validation_criteria, p_local_validation_criteria,
                password_selector, subject_permit_count, validation_ring, status);
        IFEND;

        IF status.normal AND (subject_permit_count > 0) THEN
          pfp$verify_pva (p_validation_criteria, mmc$va_read_write, status);
        IFEND;
      IFEND;

      IF status.normal {AND (subject_permit_count > 0)} THEN
        local_information_request.catalog_depth.depth_specification := fsc$specific_depth;
        local_information_request.catalog_depth.depth := 1;
      IFEND;
    IFEND;

    IF status.normal THEN
      pfp$verify_pva (p_object_information, mmc$va_read_write, status);
    IFEND;

    IF status.normal THEN
      system_privilege := (evaluated_file_reference.number_of_path_elements > 1) AND
            pfp$system_privilege (caller_id.ring, fsp$path_element (^evaluated_file_reference, 2)^);
    /get_object_information/
      WHILE TRUE DO
      pfp$r2_get_object_information (evaluated_file_reference, local_information_request, system_privilege,
            password_selector, subject_permit_count, validation_ring, p_local_validation_criteria,
            p_object_information, status);
        IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
          EXIT /get_object_information/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$R2_GET_OBJECT_INFORMATION');
        IFEND;
      WHILEND /get_object_information/;
    IFEND;

    IF status.normal AND (p_local_validation_criteria <> NIL) THEN
      p_validation_criteria^ := p_local_validation_criteria^;
    IFEND;
  PROCEND pfp$r3_get_object_information;

?? TITLE := '  [XDCL, #GATE] pfp$r3_mark_release_candidate', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_mark_release_candidate
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         caller_id: ost$caller_identifier;
         archive_identification: pft$archive_identification;
     VAR status: ost$status);

    CONST
      minimum_path_length = 3;

    VAR
      converted_family_name: ost$family_name,
      local_archive_identification: pft$archive_identification,
      local_password: pft$password,
      p_complete_path: pft$p_complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

      status.normal := TRUE;

    /mark_release_candidate_block/
      BEGIN

        pfp$convert_archive_ident (archive_identification, local_archive_identification, status);
        IF NOT status.normal THEN
          EXIT /mark_release_candidate_block/;
        IFEND;

        check_cycle_selector (cycle_selector, status);
        IF NOT status.normal THEN
          EXIT /mark_release_candidate_block/;
        IFEND;

        pfi$convert_password (password, local_password, status);
        IF NOT status.normal THEN
          EXIT /mark_release_candidate_block/;
        IFEND;

        check_family_location (path [pfc$family_name_index], converted_family_name,
             served_family, served_family_locator, status);
        IF NOT status.normal THEN
          EXIT /mark_release_candidate_block/;
        IFEND;

        IF served_family THEN
          PUSH p_converted_path: [1 .. UPPERBOUND (path)];
          convert_path_without_set (path, converted_family_name, minimum_path_length,
             file_path, p_converted_path^, status);
          IF status.normal THEN
          /df_client_mark_rel_cand/
            WHILE TRUE DO
              pfp$r2_df_client_mark_rel_cand (served_family_locator, p_converted_path^,
                   cycle_selector, local_password, caller_id.ring, local_archive_identification,
                   status);
              IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
                EXIT /df_client_mark_rel_cand /;
              ELSE
                pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_MARK_REL_CAND');
              IFEND;
            WHILEND /df_client_mark_rel_cand /;
          IFEND;
        ELSE
          PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
          convert_path (path, minimum_path_length, file_path, p_complete_path^, status);
          IF status.normal THEN
          /mark_release_candidate/
            WHILE TRUE DO
              pfp$r2_mark_release_candidate (p_complete_path^, cycle_selector, local_password, caller_id.ring,
                   local_archive_identification, status);
              IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
                EXIT /mark_release_candidate/;
              ELSE
                pfp$catalog_access_retry_wait ('PFP$R2_MARK_RELEASE_CANDIDATE');
              IFEND;
            WHILEND /mark_release_candidate/;
          IFEND;
        IFEND;
      END /mark_release_candidate_block/;

  PROCEND pfp$r3_mark_release_candidate;

?? TITLE := '  [XDCL, #GATE] pfp$r3_permit', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_permit
    (    path: pft$path;
         group: pft$group;
         permit_selections: pft$permit_selections;
         share_requirements: pft$share_requirements;
         application_info: pft$application_info;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$master_catalog_name_index + 1;

    VAR
      caller_id: ost$caller_identifier,
      converted_family_name: ost$family_name,
      local_group: pft$group,
      local_status: ost$status,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      permit_level: pft$permit_level,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      system_privilege: boolean,
      variant_path: pft$variant_path;

    osp$verify_system_privilege;
    #CALLER_ID (caller_id);
    status.normal := TRUE;

    convert_group (group, {creating_permit} TRUE, local_group, local_status);

    IF local_status.normal THEN
      IF pfv$permit_level = pfc$pl_unknown THEN
        pfp$get_permit_level (permit_level, local_status);
      ELSE
        permit_level := pfv$permit_level;
      IFEND;
    IFEND;

    IF local_status.normal THEN
      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, local_status);
    IFEND;

    IF local_status.normal THEN
      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, file_path,
              p_converted_path^, local_status);

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_converted_path^ [pfc$master_catalog_name_index]);
          /df_client_permit/
            WHILE TRUE DO
              pfp$r2_df_client_permit (p_converted_path^, pfc$file_object, system_privilege, permit_level,
                    local_group, permit_selections, share_requirements, application_info,
                    served_family_locator, local_status);
              IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
                EXIT /df_client_permit/;
              ELSE
                pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_PERMIT');
              IFEND;
            WHILEND /df_client_permit/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := FALSE;
            variant_path.p_path := p_converted_path;
            audit_permit_creation (variant_path, sfc$afsot_file, system_privilege, local_group,
                  permit_selections, local_status);
          IFEND;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, file_path, p_complete_path^, local_status);
        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_complete_path^ [pfc$master_catalog_path_index]);
        /permit/
          WHILE TRUE DO
            pfp$r2_permit (p_complete_path^, system_privilege, permit_level, local_group, permit_selections,
                  share_requirements, application_info, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /permit/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_PERMIT');
            IFEND;
          WHILEND /permit/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := TRUE;
            variant_path.p_complete_path := p_complete_path;
            audit_permit_creation (variant_path, sfc$afsot_file, system_privilege, local_group,
                  permit_selections, local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_permit;

?? TITLE := '  [XDCL, #GATE] pfp$r3_permit_catalog', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_permit_catalog
    (    path: pft$path;
         group: pft$group;
         permit_selections: pft$permit_selections;
         share_requirements: pft$share_requirements;
         application_info: pft$application_info;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$master_catalog_name_index;

    VAR
      caller_id: ost$caller_identifier,
      converted_family_name: ost$family_name,
      local_group: pft$group,
      local_status: ost$status,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      permit_level: pft$permit_level,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      system_privilege: boolean,
      variant_path: pft$variant_path;

    osp$verify_system_privilege;
    #CALLER_ID (caller_id);
    status.normal := TRUE;

    convert_group (group, {creating_permit} TRUE, local_group, local_status);

    IF local_status.normal THEN
      IF pfv$permit_level = pfc$pl_unknown THEN
        pfp$get_permit_level (permit_level, local_status);
      ELSE
        permit_level := pfv$permit_level;
      IFEND;
    IFEND;

    IF local_status.normal THEN
      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, local_status);
    IFEND;

    IF local_status.normal THEN
      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, catalog_path,
              p_converted_path^, local_status);

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_converted_path^ [pfc$master_catalog_name_index]);
        /df_client_permit/
          WHILE TRUE DO
            pfp$r2_df_client_permit (p_converted_path^, pfc$catalog_object, system_privilege, permit_level,
                  local_group, permit_selections, share_requirements, application_info, served_family_locator,
                  local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_permit/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_PERMIT');
            IFEND;
          WHILEND /df_client_permit/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := FALSE;
            variant_path.p_path := p_converted_path;
            audit_permit_creation (variant_path, sfc$afsot_catalog, system_privilege, local_group,
                  permit_selections, local_status);
          IFEND;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, catalog_path, p_complete_path^, local_status);

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_complete_path^ [pfc$master_catalog_path_index]);
        /permit_catalog/
          WHILE TRUE DO
            pfp$r2_permit_catalog (p_complete_path^, system_privilege, permit_level, local_group,
                  permit_selections, share_requirements, application_info, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /permit_catalog/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_PERMIT_CATALOG');
            IFEND;
          WHILEND /permit_catalog/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := TRUE;
            variant_path.p_complete_path := p_complete_path;
            audit_permit_creation (variant_path, sfc$afsot_catalog, system_privilege, local_group,
                  permit_selections, local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_permit_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$r3_physically_move_catalog', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to call PFP$R2_PHYSICALLY_MOVE_CATALOG
{   to move a catalog to another volume for the MOVE_CLASSES command.
{

  PROCEDURE [XDCL, #GATE] pfp$r3_physically_move_catalog
    (    path: pft$path;
         move_object_info_p: ^pft$move_object_info;
     VAR status: ost$status);

    CONST
      minimum_path_length = 1;

    VAR
      converted_family_name: ost$family_name,
      ms_class: dmt$class_member,
      operator_response: pft$mo_operator_response,
      p_complete_path: pft$p_complete_path,
      retry: boolean,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

  /move_catalog/
    BEGIN
      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, status);
      IF NOT status.normal THEN
        EXIT /move_catalog/;
      IFEND;

      IF served_family THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_family,
              path [pfc$family_name_index], status);
        EXIT /move_catalog/;
      IFEND;

      PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
      convert_path (path, minimum_path_length, file_path, p_complete_path^, status);
      IF NOT status.normal THEN
        EXIT /move_catalog/;
      IFEND;

      REPEAT
        retry := FALSE;
      /physically_move_catalog/
        WHILE TRUE DO
          pfp$r2_physically_move_catalog (p_complete_path^, move_object_info_p, status);
          IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
            EXIT /physically_move_catalog/;
          ELSE
            pfp$catalog_access_retry_wait ('PFP$R2_PHYSICALLY_MOVE_CATALOG');
          IFEND;
        WHILEND /physically_move_catalog/;

        IF (move_object_info_p^.move_bytes_threshold > 0) OR (NOT move_object_info_p^.wait) OR
              (NOT move_object_info_p^.perform_move) THEN
          EXIT /move_catalog/;
        IFEND;

        IF (NOT move_object_info_p^.move_status.move_successful) AND
              ((move_object_info_p^.move_status.reason_for_move_failure = pfc$insufficient_space) OR
              (move_object_info_p^.move_status.reason_for_move_failure = pfc$no_available_space)) THEN
          emit_out_of_space_menu ('catalog', move_object_info_p^.set_name, path,
                move_object_info_p^.move_status.ms_class, move_object_info_p^.move_status.allocated_size,
                move_object_info_p^.move_status.reason_for_move_failure, operator_response);
          IF operator_response = pfc$retry_move THEN
            retry := TRUE;
            IF move_object_info_p^.overall_statistics.objects_not_moved > 0 THEN
              move_object_info_p^.overall_statistics.objects_not_moved :=
                    move_object_info_p^.overall_statistics.objects_not_moved - 1;
            IFEND;
            ms_class := move_object_info_p^.move_status.ms_class;
            IF move_object_info_p^.class_statistics [ms_class].objects_not_moved > 0 THEN
              move_object_info_p^.class_statistics [ms_class].objects_not_moved :=
                    move_object_info_p^.class_statistics [ms_class].objects_not_moved - 1;
            IFEND;
            IF move_object_info_p^.move_status.reason_for_move_failure = pfc$insufficient_space THEN
              IF move_object_info_p^.overall_statistics.insufficient_space > 0 THEN
                move_object_info_p^.overall_statistics.insufficient_space :=
                      move_object_info_p^.overall_statistics.insufficient_space - 1;
              IFEND;
              IF move_object_info_p^.class_statistics [ms_class].insufficient_space > 0 THEN
                move_object_info_p^.class_statistics [ms_class].insufficient_space :=
                      move_object_info_p^.class_statistics [ms_class].insufficient_space - 1;
              IFEND;
            IFEND;
            IF move_object_info_p^.move_status.reason_for_move_failure = pfc$no_available_space THEN
              IF move_object_info_p^.overall_statistics.no_available_space > 0 THEN
                move_object_info_p^.overall_statistics.no_available_space :=
                      move_object_info_p^.overall_statistics.no_available_space - 1;
              IFEND;
              IF move_object_info_p^.class_statistics [ms_class].no_available_space > 0 THEN
                move_object_info_p^.class_statistics [ms_class].no_available_space :=
                      move_object_info_p^.class_statistics [ms_class].no_available_space - 1;
              IFEND;
            IFEND;
            update_set_volume_list( move_object_info_p^.set_volume_list_p);
          ELSEIF operator_response = pfc$skip_object THEN
            move_object_info_p^.move_status.reason_for_move_failure := pfc$operator_skip;
          ELSEIF operator_response = pfc$terminate_command THEN
            move_object_info_p^.move_status.reason_for_move_failure := pfc$operator_terminate;
          IFEND;
        IFEND;
      UNTIL NOT retry;
    END /move_catalog/;

  PROCEND pfp$r3_physically_move_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$r3_physically_move_cycle', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to call PFP$R2_PHYSICALLY_MOVE_CYCLE
{   to move a cycle to other volumes for the MOVE_CLASSES command.
{

  PROCEDURE [XDCL, #GATE] pfp$r3_physically_move_cycle
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         move_object_info_p: ^pft$move_object_info;
     VAR cycle_number: pft$cycle_number;
     VAR status: ost$status);

    CONST
      minimum_path_length = 3;

    VAR
      converted_family_name: ost$family_name,
      local_cycle_selector: pft$cycle_selector,
      ms_class: dmt$class_member,
      operator_response: pft$mo_operator_response,
      p_complete_path: pft$p_complete_path,
      retry: boolean,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

  /move_cycle/
    BEGIN

      check_cycle_selector (cycle_selector, status);
      IF NOT status.normal THEN
        EXIT /move_cycle/;
      IFEND;
      local_cycle_selector := cycle_selector;

      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, status);
      IF NOT status.normal THEN
        EXIT /move_cycle/;
      IFEND;

      IF served_family THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_family,
              path [pfc$family_name_index], status);
        EXIT /move_cycle/;
      IFEND;

      PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
      convert_path (path, minimum_path_length, file_path, p_complete_path^, status);
      IF NOT status.normal THEN
        EXIT /move_cycle/;
      IFEND;

      REPEAT
        retry := FALSE;
      /physically_move_cycle/
        WHILE TRUE DO
          pfp$r2_physically_move_cycle (p_complete_path^, local_cycle_selector, move_object_info_p,
                cycle_number, status);
          IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
            EXIT /physically_move_cycle/;
          ELSE
            pfp$catalog_access_retry_wait ('PFP$R2_PHYSICALLY_MOVE_CYCLE');
          IFEND;
        WHILEND /physically_move_cycle/;

        IF (move_object_info_p^.move_bytes_threshold > 0) OR (NOT move_object_info_p^.wait) OR
              (NOT move_object_info_p^.perform_move) THEN
          EXIT /move_cycle/;
        IFEND;

        IF (NOT move_object_info_p^.move_status.move_successful) AND
              ((move_object_info_p^.move_status.reason_for_move_failure = pfc$insufficient_space) OR
              (move_object_info_p^.move_status.reason_for_move_failure = pfc$no_available_space)) THEN
          emit_out_of_space_menu ('file', move_object_info_p^.set_name, path,
                move_object_info_p^.move_status.ms_class, move_object_info_p^.move_status.allocated_size,
                move_object_info_p^.move_status.reason_for_move_failure, operator_response);
          IF operator_response = pfc$retry_move THEN
            retry := TRUE;
            IF move_object_info_p^.overall_statistics.objects_not_moved > 0 THEN
              move_object_info_p^.overall_statistics.objects_not_moved :=
                    move_object_info_p^.overall_statistics.objects_not_moved - 1;
            IFEND;
            ms_class := move_object_info_p^.move_status.ms_class;
            IF move_object_info_p^.class_statistics [ms_class].objects_not_moved > 0 THEN
              move_object_info_p^.class_statistics [ms_class].objects_not_moved :=
                    move_object_info_p^.class_statistics [ms_class].objects_not_moved - 1;
            IFEND;
            IF move_object_info_p^.move_status.reason_for_move_failure = pfc$insufficient_space THEN
              IF move_object_info_p^.overall_statistics.insufficient_space > 0 THEN
                move_object_info_p^.overall_statistics.insufficient_space :=
                      move_object_info_p^.overall_statistics.insufficient_space - 1;
              IFEND;
              IF move_object_info_p^.class_statistics [ms_class].insufficient_space > 0 THEN
                move_object_info_p^.class_statistics [ms_class].insufficient_space :=
                      move_object_info_p^.class_statistics [ms_class].insufficient_space - 1;
              IFEND;
            IFEND;
            IF move_object_info_p^.move_status.reason_for_move_failure = pfc$no_available_space THEN
              IF move_object_info_p^.overall_statistics.no_available_space > 0 THEN
                move_object_info_p^.overall_statistics.no_available_space :=
                      move_object_info_p^.overall_statistics.no_available_space - 1;
              IFEND;
              IF move_object_info_p^.class_statistics [ms_class].no_available_space > 0 THEN
                move_object_info_p^.class_statistics [ms_class].no_available_space :=
                      move_object_info_p^.class_statistics [ms_class].no_available_space - 1;
              IFEND;
            IFEND;
            update_set_volume_list( move_object_info_p^.set_volume_list_p);
          ELSEIF operator_response = pfc$skip_object THEN
            move_object_info_p^.move_status.reason_for_move_failure := pfc$operator_skip;
          ELSEIF operator_response = pfc$terminate_command THEN
            move_object_info_p^.move_status.reason_for_move_failure := pfc$operator_terminate;
          IFEND;
        IFEND;
      UNTIL NOT retry;
    END /move_cycle/;

  PROCEND pfp$r3_physically_move_cycle;

?? TITLE := '  [XDCL, #GATE] pfp$r3_purge', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_purge
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         purge_cycle_options: pft$purge_cycle_options;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$master_catalog_name_index + 1;

    VAR
      authority: pft$authority,
      audit_ownership: audit_ownership_rec,
      bytes_released: amt$file_byte_address,
      caller_id: ost$caller_identifier,
      converted_family_name: ost$family_name,
      device_class: rmt$device_class,
      local_password: pft$password,
      local_status: ost$status,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      system_privilege: boolean,
      variant_path: pft$variant_path;


    PROCEDURE audit_cycle_deletion
      (    variant_path: pft$variant_path;
           cycle_selector: pft$cycle_selector;
           device_class: rmt$device_class;
           audit_ownership: audit_ownership_rec;
           audit_status: ost$status);

      VAR
        audit_information: sft$audit_information,
        audited_object: sft$audited_fs_object_id,
        ignore_status: ost$status,
        usage_selections: pft$usage_selections;

      audit_information.audited_operation := sfc$ao_fs_delete_object;
      audited_object.variant_path := variant_path;
      audited_object.object_type := sfc$afsot_cycle;
      audited_object.cycle_selector_p := ^cycle_selector;
      audited_object.device_class := device_class;
      audit_information.delete_fs_object.object_id_p := ^audited_object;
      IF audit_ownership.ownership_known THEN
        audit_information.delete_fs_object.ownership := audit_ownership.ownership;
      ELSE
        pfp$get_ownership (variant_path, audit_ownership.system_privilege,
              audit_information.delete_fs_object.ownership, ignore_status);
      IFEND;
      sfp$emit_audit_statistic (audit_information, audit_status);
    PROCEND audit_cycle_deletion;


    osp$verify_system_privilege;
    #CALLER_ID (caller_id);
    status.normal := TRUE;

    check_cycle_selector (cycle_selector, local_status);

    IF local_status.normal THEN
      pfi$convert_password (password, local_password, local_status);
    IFEND;

    IF local_status.normal THEN
      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, local_status);
    IFEND;

    IF local_status.normal THEN
      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, file_path,
              p_converted_path^, local_status);

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_converted_path^ [pfc$master_catalog_name_index]);
        /df_client_purge/
          WHILE TRUE DO
            pfp$r2_df_client_purge (served_family_locator, p_converted_path^, cycle_selector, password,
                  purge_cycle_options, system_privilege, caller_id.ring, authority, device_class,
                  bytes_released, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_purge/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_PURGE');
            IFEND;
          WHILEND /df_client_purge/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := FALSE;
            variant_path.p_path := p_converted_path;
            IF local_status.normal THEN
              audit_ownership.ownership_known := TRUE;
              audit_ownership.ownership := authority.ownership;
            ELSE
              audit_ownership.ownership_known := FALSE;
              audit_ownership.system_privilege := system_privilege;
            IFEND;
            audit_cycle_deletion (variant_path, cycle_selector, device_class, audit_ownership, local_status);
          IFEND;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, file_path, p_complete_path^, local_status);

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_complete_path^ [pfc$master_catalog_path_index]);
        /purge/
          WHILE TRUE DO
            pfp$r2_purge (p_complete_path^, cycle_selector, local_password, purge_cycle_options,
                  system_privilege, caller_id.ring, authority, device_class, bytes_released, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /purge/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_PURGE');
            IFEND;
          WHILEND /purge/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := TRUE;
            variant_path.p_complete_path := p_complete_path;
            IF local_status.normal THEN
              audit_ownership.ownership_known := TRUE;
              audit_ownership.ownership := authority.ownership;
            ELSE
              audit_ownership.ownership_known := FALSE;
              audit_ownership.system_privilege := system_privilege;
            IFEND;
            audit_cycle_deletion (variant_path, cycle_selector, device_class, audit_ownership, local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF local_status.normal THEN
      IF (pfc$master_catalog_owner IN authority.ownership) AND (bytes_released > 0) THEN
        sfp$accumulate_file_space (sfc$perm_file_space_limit, - bytes_released);
      IFEND;
    ELSE
      status := local_status;
    IFEND;
  PROCEND pfp$r3_purge;

?? TITLE := '  [XDCL, #GATE] pfp$r3_purge_catalog', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_purge_catalog
    (    path: pft$path;
         delete_option: pft$delete_option;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$subcatalog_name_index;

    VAR
      caller_id: ost$caller_identifier,
      converted_family_name: ost$family_name,
      local_status: ost$status,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      system_privilege: boolean,
      variant_path: pft$variant_path;

    osp$verify_system_privilege;
    #CALLER_ID (caller_id);
    status.normal := TRUE;

    check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
          served_family_locator, local_status);

    IF local_status.normal THEN
      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, catalog_path,
              p_converted_path^, local_status);

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_converted_path^ [pfc$master_catalog_name_index]);
        /df_client_purge_catalog/
          WHILE TRUE DO
            pfp$r2_df_client_purge_catalog (served_family_locator, p_converted_path^, system_privilege,
                  delete_option, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_purge_catalog/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_PURGE_CATALOG');
            IFEND;
          WHILEND /df_client_purge_catalog/;
          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := FALSE;
            variant_path.p_path := p_converted_path;
            audit_catalog_deletion (variant_path, system_privilege, local_status);
          IFEND;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, catalog_path, p_complete_path^, local_status);

        IF local_status.normal THEN
          system_privilege := pfp$system_privilege (caller_id.ring,
                p_complete_path^ [pfc$master_catalog_path_index]);
        /purge_catalog/
          WHILE TRUE DO
            pfp$r2_purge_catalog (p_complete_path^, system_privilege, delete_option, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /purge_catalog/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_PURGE_CATALOG');
            IFEND;
          WHILEND /purge_catalog/;
          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := TRUE;
            variant_path.p_complete_path := p_complete_path;
            audit_catalog_deletion (variant_path, system_privilege, local_status);
          IFEND;
        IFEND;
      IFEND;

      IF (NOT local_status.normal) AND (local_status.condition = pfe$path_too_short) AND
            (UPPERBOUND (path) = pfc$master_catalog_name_index) THEN
        osp$set_status_condition (pfe$cannot_purge_master_catalog, local_status);
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_purge_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$r3_put_archive_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_put_archive_entry
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         p_archive_array_entry: pft$p_archive_array_entry;
         p_amd: pft$p_amd;
     VAR status: ost$status);

    CONST
      minimum_path_length = 3;

    VAR
      converted_family_name: ost$family_name,
      local_archive_identification: pft$archive_identification,
      p_complete_path: pft$p_complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

    status.normal := TRUE;

  /put_archive_entry_block/
    BEGIN

    pfp$verify_pva (p_archive_array_entry, mmc$va_read, status);
    IF NOT status.normal THEN
      EXIT /put_archive_entry_block/;
    IFEND;

    pfp$verify_pva (p_amd, mmc$va_read, status);
    IF NOT status.normal THEN
      EXIT /put_archive_entry_block/;
    IFEND;

    check_cycle_selector (cycle_selector, status);
    IF NOT status.normal THEN
      EXIT /put_archive_entry_block/;
    IFEND;

    pfp$convert_archive_ident (p_archive_array_entry^.archive_identification,
         local_archive_identification, status);
    IF NOT status.normal THEN
      EXIT /put_archive_entry_block/;
    IFEND;

    check_family_location (path [pfc$family_name_index], converted_family_name,
         served_family, served_family_locator, status);
    IF NOT status.normal THEN
      EXIT /put_archive_entry_block/;
    IFEND;

    IF served_family THEN
      PUSH p_converted_path: [1 .. UPPERBOUND (path)];
      convert_path_without_set (path, converted_family_name, minimum_path_length,
          file_path, p_converted_path^, status);
      IF status.normal THEN
      /df_client_put_arch_entry/
        WHILE TRUE DO
          pfp$r2_df_client_put_arch_entry (served_family_locator, p_converted_path^,
               cycle_selector, local_archive_identification, p_archive_array_entry, p_amd,
               status);
          IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
            EXIT /df_client_put_arch_entry/;
          ELSE
            pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_PUT_ARCH_ENTRY');
          IFEND;
        WHILEND /df_client_put_arch_entry/;
      IFEND;
    ELSE
      PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
      convert_path (path, minimum_path_length, file_path, p_complete_path^, status);
      IF status.normal THEN
      /put_archive_entry/
        WHILE TRUE DO
          pfp$r2_put_archive_entry (p_complete_path^, cycle_selector, local_archive_identification,
               p_archive_array_entry, p_amd, status);
          IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
            EXIT /put_archive_entry/;
          ELSE
            pfp$catalog_access_retry_wait ('PFP$R2_PUT_ARCHIVE_ENTRY');
          IFEND;
        WHILEND /put_archive_entry/;
      IFEND;
    IFEND;

    END /put_archive_entry_block/;

  PROCEND pfp$r3_put_archive_entry;

?? TITLE := '  [XDCL, #GATE] pfp$r3_put_archive_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_put_archive_info
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         p_cycle_info_record: pft$p_info_record;
     VAR status: ost$status);

    CONST
      minimum_path_length = 3;

    VAR
      converted_family_name: ost$family_name,
      p_complete_path: pft$p_complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

    status.normal := TRUE;

  /put_archive_info_block/
    BEGIN

    pfp$verify_pva (p_cycle_info_record, mmc$va_read, status);
    IF NOT status.normal THEN
      EXIT /put_archive_info_block/;
    IFEND;

    check_cycle_selector (cycle_selector, status);
    IF NOT status.normal THEN
      EXIT /put_archive_info_block/;
    IFEND;

    check_family_location (path [pfc$family_name_index], converted_family_name,
         served_family, served_family_locator, status);
    IF NOT status.normal THEN
      EXIT /put_archive_info_block/;
    IFEND;

    IF served_family THEN
      PUSH p_converted_path: [1 .. UPPERBOUND (path)];
      convert_path_without_set (path, converted_family_name, minimum_path_length,
          file_path, p_converted_path^, status);
      IF status.normal THEN
      /df_client_put_arch_info/
        WHILE TRUE DO
          pfp$r2_df_client_put_arch_info (served_family_locator, p_converted_path^,
                 cycle_selector, p_cycle_info_record, status);
          IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
            EXIT /df_client_put_arch_info/;
          ELSE
            pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_PUT_ARCH_INFO');
          IFEND;
        WHILEND /df_client_put_arch_info/;
      IFEND;
    ELSE
      PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
      convert_path (path, minimum_path_length, file_path, p_complete_path^, status);
      IF status.normal THEN
      /put_archive_info/
        WHILE TRUE DO
          pfp$r2_put_archive_info (p_complete_path^, cycle_selector, p_cycle_info_record, status);
          IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
            EXIT /put_archive_info/;
          ELSE
            pfp$catalog_access_retry_wait ('PFP$R2_PUT_ARCHIVE_INFO');
          IFEND;
        WHILEND /put_archive_info/;
      IFEND;
    IFEND;

    END /put_archive_info_block/;

  PROCEND pfp$r3_put_archive_info;

?? TITLE := '  [XDCL, #GATE] pfp$r3_put_cycle_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_put_cycle_info
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         cycle_array_entry: pft$cycle_array_entry_version_2;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$master_catalog_name_index + 1;

    VAR
      converted_family_name: ost$family_name,
      local_password_selector: pft$password_selector,
      local_status: ost$status,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      variant_path: pft$variant_path;


    PROCEDURE audit_cycle_restoration
      (    variant_path: pft$variant_path;
           cycle_selector: pft$cycle_selector;
           device_class: rmt$device_class;
           audit_status: ost$status);

      CONST
        system_privilege = TRUE;

      VAR
        audit_information: sft$audit_information,
        audited_object: sft$audited_fs_object_id,
        ignore_status: ost$status;

      audit_information.audited_operation := sfc$ao_fs_create_object;
      audited_object.variant_path := variant_path;
      audited_object.object_type := sfc$afsot_cycle;
      audited_object.cycle_selector_p := ^cycle_selector;
      audited_object.device_class := device_class;
      audit_information.create_fs_object.object_id_p := ^audited_object;
      pfp$get_ownership (variant_path, NOT system_privilege, audit_information.create_fs_object.ownership,
            ignore_status);
      sfp$emit_audit_statistic (audit_information, audit_status);
    PROCEND audit_cycle_restoration;


    status.normal := TRUE;

    check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
          served_family_locator, local_status);

    IF local_status.normal THEN
      check_cycle_selector (cycle_selector, local_status);
    IFEND;

    IF local_status.normal THEN
      convert_password_selector (password_selector, local_password_selector, local_status);
    IFEND;

    IF local_status.normal THEN
      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, file_path,
              p_converted_path^, local_status);

        IF local_status.normal THEN
        /df_client_put_cycle_info/
          WHILE TRUE DO
            pfp$r2_df_client_put_cycle_info (served_family_locator, p_converted_path^, cycle_selector,
                  local_password_selector, cycle_array_entry, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_put_cycle_info/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_PUT_CYCLE_INFO');
            IFEND;
          WHILEND /df_client_put_cycle_info/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := FALSE;
            variant_path.p_path := p_converted_path;
            audit_cycle_restoration (variant_path, cycle_selector, cycle_array_entry.device_class,
                  local_status);
          IFEND;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, file_path, p_complete_path^, local_status);

        IF local_status.normal THEN
        /put_cycle_info/
          WHILE TRUE DO
            pfp$r2_put_cycle_info (p_complete_path^, cycle_selector, local_password_selector,
                  cycle_array_entry, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /put_cycle_info/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_PUT_CYCLE_INFO');
            IFEND;
          WHILEND /put_cycle_info/;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            variant_path.complete_path := TRUE;
            variant_path.p_complete_path := p_complete_path;
            audit_cycle_restoration (variant_path, cycle_selector, cycle_array_entry.device_class,
                  local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_put_cycle_info;

?? TITLE := '  [XDCL, #GATE] pfp$r3_put_item_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_put_item_info
    (    path: pft$path;
         p_info_record: {input} pft$p_info_record;
         restore_archive_information: boolean;
         selection_criteria: put$selection_criteria;
         backup_file_version: pft$backup_file_version;
     VAR all_permits_restored: boolean;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$master_catalog_name_index + 1,
      system_privilege = TRUE;

    VAR
      audit_ownership: audit_ownership_rec,
      audit_restorations: boolean,
      converted_family_name: ost$family_name,
      local_status: ost$status,
      ownership: pft$ownership,
      p_auditable_cycles: ^pft$auditable_cycles,
      p_auditable_permits: ^pft$auditable_permits,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      p_cycle_array_version_1: ^pft$cycle_array,
      p_cycle_array_version_2: ^pft$cycle_array_version_2,
      p_group_info_record: ^pft$info_record,
      p_ignore_status: ^ost$status,
      p_permit_array: ^pft$permit_array,
      permit_level: pft$permit_level,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      variant_path: pft$variant_path;

    all_permits_restored := TRUE;
    status.normal := TRUE;

    pfp$verify_pva (p_info_record, mmc$va_read, local_status);

    IF local_status.normal THEN
      IF pfv$permit_level = pfc$pl_unknown THEN
        pfp$get_permit_level (permit_level, local_status);
      ELSE
        permit_level := pfv$permit_level;
      IFEND;
    IFEND;

    IF local_status.normal THEN
      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, local_status);
    IFEND;

    IF local_status.normal THEN
      audit_restorations := sfp$auditing_operation (sfc$ao_fs_create_object) OR
            sfp$auditing_operation (sfc$ao_fs_create_permit);

      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, new_item_path,
              p_converted_path^, local_status);

        IF local_status.normal THEN
          variant_path.complete_path := FALSE;
          variant_path.p_path := p_converted_path;
          check_for_path_too_long (variant_path, local_status);
        IFEND;

        IF local_status.normal THEN
          IF audit_restorations THEN
            pfp$locate_group_info_record (p_info_record, p_group_info_record, local_status);

            IF local_status.normal THEN
              pfp$find_permit_array (p_group_info_record, p_permit_array, local_status);
            IFEND;

            IF local_status.normal THEN
              IF p_permit_array = NIL THEN
                p_auditable_permits := NIL;
              ELSE
                PUSH p_auditable_permits: [1 .. UPPERBOUND (p_permit_array^)];
              IFEND;

              IF p_group_info_record^.record_type = pfc$catalog_group_record THEN
                p_auditable_cycles := NIL;
              ELSE {pfc$file_group_record}
                IF backup_file_version = pfc$backup_file_version_2 THEN
                  pfp$find_cycle_array_version_2 (p_group_info_record, p_cycle_array_version_2, local_status);

                  IF local_status.normal THEN
                    IF p_cycle_array_version_2 = NIL THEN
                      p_auditable_cycles := NIL;
                    ELSE
                      PUSH p_auditable_cycles: [1 .. UPPERBOUND (p_cycle_array_version_2^)];
                    IFEND;
                  IFEND;
                ELSE {pfc$backup_file_version_1}
                  pfp$find_cycle_array (p_group_info_record, p_cycle_array_version_1, local_status);

                  IF local_status.normal THEN
                    IF p_cycle_array_version_1 = NIL THEN
                      p_auditable_cycles := NIL;
                    ELSE
                      PUSH p_auditable_cycles: [1 .. UPPERBOUND (p_cycle_array_version_1^)];
                    IFEND;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          ELSE
            p_auditable_permits := NIL;
            p_auditable_cycles := NIL;
          IFEND;
        IFEND;

        IF local_status.normal THEN
        /df_client_put_item_info/
          WHILE TRUE DO
            pfp$r2_df_client_put_item_info (backup_file_version, p_info_record, served_family_locator,
                  p_converted_path^, permit_level, selection_criteria, restore_archive_information,
                  audit_restorations, all_permits_restored, p_auditable_permits, p_auditable_cycles,
                  local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_put_item_info/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_PUT_ITEM_INFO');
            IFEND;
          WHILEND /df_client_put_item_info/;

          IF (p_auditable_permits <> NIL) OR (p_auditable_cycles <> NIL) THEN
            PUSH p_ignore_status;
            pfp$get_ownership (variant_path, NOT system_privilege, ownership, p_ignore_status^);

            IF p_group_info_record^.record_type = pfc$catalog_group_record THEN
              IF p_auditable_permits <> NIL THEN
                audit_permit_restorations (variant_path, sfc$afsot_catalog, ownership, p_auditable_permits^);
              IFEND;

              IF audit_restorations THEN
                audit_ownership.ownership_known := TRUE;
                audit_ownership.ownership := ownership;
                audit_catalog_creation (variant_path, audit_ownership, local_status);
              IFEND;
            ELSE {pfc$file_group_record}
              IF p_auditable_permits <> NIL THEN
                audit_permit_restorations (variant_path, sfc$afsot_file, ownership, p_auditable_permits^);
              IFEND;

              IF p_auditable_cycles <> NIL THEN
                audit_cycle_restorations (variant_path, ownership, p_auditable_cycles^);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, new_item_path, p_complete_path^, local_status);

        IF local_status.normal THEN
          variant_path.complete_path := TRUE;
          variant_path.p_complete_path := p_complete_path;
          check_for_path_too_long (variant_path, local_status);
        IFEND;

        IF local_status.normal THEN
          p_auditable_permits := NIL;
          p_auditable_cycles := NIL;
        /put_item_info/
          WHILE TRUE DO
            pfp$r2_put_item_info (backup_file_version, p_info_record, pfc$local_mainframe, p_complete_path^,
                  permit_level, selection_criteria, restore_archive_information, audit_restorations,
                  all_permits_restored, p_auditable_permits, p_auditable_cycles, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /put_item_info/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_PUT_ITEM_INFO');
            IFEND;
          WHILEND /put_item_info/;
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_put_item_info;

?? TITLE := '  [XDCL, #GATE] pfp$r3_release_data', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_release_data
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         p_release_data_info: {i/o} ^pft$release_data_info;
     VAR status: ost$status);

    CONST
      minimum_path_length = 3;

    VAR
      converted_family_name: ost$family_name,
      local_password: pft$password,
      p_complete_path: pft$p_complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

    status.normal := TRUE;

  /release_data_block/
    BEGIN
      check_cycle_selector (cycle_selector, status);
      IF NOT status.normal THEN
        EXIT /release_data_block/;
      IFEND;

      pfi$convert_password (password, local_password, status);
      IF NOT status.normal THEN
        EXIT /release_data_block/;
      IFEND;

      IF p_release_data_info <> NIL THEN
        pfp$verify_pva (p_release_data_info, mmc$va_read_write, status);
        IF NOT status.normal THEN
          EXIT /release_data_block/;
        IFEND;
      IFEND;

      check_family_location (path [pfc$family_name_index], converted_family_name,
           served_family, served_family_locator, status);
      IF NOT status.normal THEN
        EXIT /release_data_block/;
      IFEND;

      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length,
            file_path, p_converted_path^, status);
        IF status.normal THEN
        /df_client_release_data/
          WHILE TRUE DO
            pfp$r2_df_client_release_data (served_family_locator, p_converted_path^,
                  cycle_selector, local_password, p_release_data_info, status);
            IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_release_data/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_RELEASE_DATA');
            IFEND;
          WHILEND /df_client_release_data/;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, file_path, p_complete_path^, status);
        IF status.normal THEN
        /release_data/
          WHILE TRUE DO
            pfp$r2_release_data (p_complete_path^, cycle_selector, local_password, p_release_data_info,
                  status);
            IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
              EXIT /release_data/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_RELEASE_DATA');
            IFEND;
          WHILEND /release_data/;
        IFEND;
      IFEND;
    END /release_data_block/;

  PROCEND pfp$r3_release_data;

?? TITLE := '  [XDCL, #GATE] pfp$r3_replace_archive_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_replace_archive_entry
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
         p_archive_array_entry: pft$p_archive_array_entry;
         p_amd: pft$p_amd;
     VAR status: ost$status);

    CONST
      minimum_path_length = 3;

    VAR
      converted_family_name: ost$family_name,
      local_archive_identification: pft$archive_identification,
      p_complete_path: pft$p_complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

    status.normal := TRUE;

  /replace_archive_entry_block/
    BEGIN

    pfp$verify_pva (p_archive_array_entry, mmc$va_read, status);
    IF NOT status.normal THEN
      EXIT /replace_archive_entry_block/;
    IFEND;

    pfp$verify_pva (p_amd, mmc$va_read, status);
    IF NOT status.normal THEN
      EXIT /replace_archive_entry_block/;
    IFEND;

    pfp$convert_archive_ident (archive_identification, local_archive_identification, status);
    IF NOT status.normal THEN
      EXIT /replace_archive_entry_block/;
    IFEND;

    check_cycle_selector (cycle_selector, status);
    IF NOT status.normal THEN
      EXIT /replace_archive_entry_block/;
    IFEND;

    check_family_location (path [pfc$family_name_index], converted_family_name,
         served_family, served_family_locator, status);
    IF NOT status.normal THEN
      EXIT /replace_archive_entry_block/;
    IFEND;

    IF served_family THEN
      PUSH p_converted_path: [1 .. UPPERBOUND (path)];
      convert_path_without_set (path, converted_family_name, minimum_path_length,
          file_path, p_converted_path^, status);
      IF status.normal THEN
      /df_client_rep_arch_entry/
        WHILE TRUE DO
          pfp$r2_df_client_rep_arch_entry (served_family_locator, p_converted_path^, cycle_selector,
               local_archive_identification, p_archive_array_entry, p_amd, status);
          IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
            EXIT /df_client_rep_arch_entry/;
          ELSE
            pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_REP_ARCH_ENTRY');
          IFEND;
        WHILEND /df_client_rep_arch_entry/;
      IFEND;
    ELSE
      PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
      convert_path (path, minimum_path_length, file_path, p_complete_path^, status);
      IF status.normal THEN
      /replace_archive_entry/
        WHILE TRUE DO
          pfp$r2_replace_archive_entry (p_complete_path^, cycle_selector, local_archive_identification,
               p_archive_array_entry, p_amd, status);
          IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
            EXIT /replace_archive_entry/;
          ELSE
            pfp$catalog_access_retry_wait ('PFP$R2_REPLACE_ARCHIVE_ENTRY');
          IFEND;
        WHILEND /replace_archive_entry/;
      IFEND;
    IFEND;

    END /replace_archive_entry_block/;

  PROCEND pfp$r3_replace_archive_entry;

?? TITLE := '  [XDCL, #GATE] pfp$r3_replace_rem_media_fmd', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_replace_rem_media_fmd
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         p_file_media_descriptor: {input} ^SEQ ( * );
     VAR status: ost$status);

    CONST
      minimum_path_length = 3;

    VAR
      converted_family_name: ost$family_name,
      converted_password_selector: pft$password_selector,
      p_complete_path: pft$p_complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

    status.normal := TRUE;

  /replace_rem_media_fmd_block/
    BEGIN
      check_cycle_selector (cycle_selector, status);
      IF NOT status.normal THEN
        EXIT /replace_rem_media_fmd_block/;
      IFEND;

      convert_password_selector (password_selector, converted_password_selector, status);
      IF NOT status.normal THEN
        EXIT /replace_rem_media_fmd_block/;
      IFEND;

      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, status);
      IF NOT status.normal THEN
        EXIT /replace_rem_media_fmd_block/;
      IFEND;

      pfp$verify_pva (p_file_media_descriptor, mmc$va_read, status);
      IF NOT status.normal THEN
        EXIT /replace_rem_media_fmd_block/;
      IFEND;

      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, file_path,
              p_converted_path^, status);
        IF status.normal THEN
        /df_client_rep_rem_me_fmd/
          WHILE TRUE DO
            pfp$r2_df_client_rep_rem_me_fmd (served_family_locator, p_converted_path^,
                  cycle_selector, converted_password_selector, p_file_media_descriptor,
                  status);
            IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_rep_rem_me_fmd/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_REP_REM_ME_FMD');
            IFEND;
          WHILEND /df_client_rep_rem_me_fmd/;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, file_path, p_complete_path^, status);
        IF status.normal THEN
        /replace_rem_media_fmd/
          WHILE TRUE DO
            pfp$r2_replace_rem_media_fmd (p_complete_path^, cycle_selector, converted_password_selector,
                  p_file_media_descriptor, status);
            IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
              EXIT /replace_rem_media_fmd/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_REPLACE_REM_MEDIA_FMD');
            IFEND;
          WHILEND /replace_rem_media_fmd/;
        IFEND;
      IFEND;
    END /replace_rem_media_fmd_block/;
  PROCEND pfp$r3_replace_rem_media_fmd;

?? TITLE := '  [XDCL, #GATE] pfp$r3_resolve_path', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_resolve_path
    (    path: pft$path;
     VAR cycle_reference: {i/o} fst$cycle_reference;
     VAR path_resolution: fst$path_resolution;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$family_name_index;

    VAR
      converted_family_name: ost$family_name,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      system_privilege: boolean;

    { This procedure is called by pup$fetch_backup_information, as well as
    { elsewhere, which executes in the user's ring.  Hence, system_privilege
    { must not be determined using the caller's ring.  This procedure must not
    { be called directly by the user, though.
    {
    osp$verify_system_privilege;

    check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
          served_family_locator, status);

    IF status.normal THEN
      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, item_path,
              p_converted_path^, status);

        IF status.normal THEN
          system_privilege := pfp$system_privilege (osc$tsrv_ring,
                p_converted_path^ [pfc$master_catalog_name_index]);
        /df_client_resolve/
          WHILE TRUE DO
            pfp$r2_df_client_resolve (path, served_family_locator, system_privilege, cycle_reference,
                  path_resolution, status);
            IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_resolve/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_REPLACE_REM_MEDIA_FMD');
            IFEND;
          WHILEND /df_client_resolve/;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, item_path, p_complete_path^, status);

        IF status.normal THEN
          system_privilege := pfp$system_privilege (osc$tsrv_ring,
                p_complete_path^ [pfc$master_catalog_path_index]);
        /resolve_path/
          WHILE TRUE DO
            pfp$r2_resolve_path (p_complete_path^, system_privilege, cycle_reference, path_resolution,
                  status);
            IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
              EXIT /resolve_path/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_RESOLVE_PATH');
            IFEND;
          WHILEND /resolve_path/;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pfp$r3_resolve_path;

?? TITLE := '  [XDCL, #GATE] pfp$r3_save_released_file_label', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_save_released_file_label
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         update_cycle_statistics: boolean;
         password_selector: pft$password_selector;
         p_file_label: {input^} fmt$p_file_label;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$master_catalog_name_index + 1;

    VAR
      converted_family_name: ost$family_name,
      converted_password_selector: pft$password_selector,
      local_status: ost$status,
      p_complete_path: ^pft$complete_path,
      p_converted_path: ^pft$path,
      p_save_label_audit_info: ^pft$save_label_audit_info,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      variant_path: pft$variant_path;

    osp$verify_system_privilege;
    status.normal := TRUE;

    check_cycle_selector (cycle_selector, local_status);

    IF local_status.normal THEN
      convert_password_selector (password_selector, converted_password_selector, local_status);
    IFEND;

    IF local_status.normal THEN
      check_family_location (path [pfc$family_name_index], converted_family_name, served_family,
            served_family_locator, local_status);
    IFEND;

    IF local_status.normal THEN
      pfp$verify_pva (p_file_label, mmc$va_read, local_status);
    IFEND;

    IF local_status.normal THEN
      IF served_family THEN
        PUSH p_converted_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, file_path,
              p_converted_path^, local_status);

        IF local_status.normal THEN
          IF sfp$auditing_operation (sfc$ao_fs_change_attribute) THEN
            PUSH p_save_label_audit_info;
          ELSE
            p_save_label_audit_info := NIL;
          IFEND;

        /df_client_save_rel_label/
          WHILE TRUE DO
            pfp$r2_df_client_save_rel_label (served_family_locator, p_converted_path^, cycle_selector,
                  converted_password_selector, p_file_label, avp$ring_min (), update_cycle_statistics,
                  p_save_label_audit_info, local_status);
            IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
              EXIT /df_client_save_rel_label/;
            ELSE
              pfp$catalog_access_retry_wait ('PFP$R2_DF_CLIENT_SAVE_REL_LABEL');
            IFEND;
          WHILEND /df_client_save_rel_label/;

          IF p_save_label_audit_info <> NIL THEN
            variant_path.complete_path := FALSE;
            variant_path.p_path := p_converted_path;
            pfp$audit_save_label (variant_path, p_save_label_audit_info, local_status);
          IFEND;
        IFEND;
      ELSE
        PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, file_path, p_complete_path^, local_status);

        IF local_status.normal THEN
          IF sfp$auditing_operation (sfc$ao_fs_change_attribute) THEN
            PUSH p_save_label_audit_info;
          ELSE
            p_save_label_audit_info := NIL;
          IFEND;

          /save_released_file_label/
            WHILE TRUE DO
              pfp$r2_save_released_file_label (p_complete_path^, cycle_selector, converted_password_selector,
                    p_file_label, avp$ring_min (), update_cycle_statistics, p_save_label_audit_info,
                    local_status);
              IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
                EXIT /save_released_file_label/;
              ELSE
                pfp$catalog_access_retry_wait ('PFP$R2_SAVE_RELEASED_FILE_LABEL');
              IFEND;
            WHILEND /save_released_file_label/;

          IF p_save_label_audit_info <> NIL THEN
            variant_path.complete_path := TRUE;
            variant_path.p_complete_path := p_complete_path;
            pfp$audit_save_label (variant_path, p_save_label_audit_info, local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_save_released_file_label;

?? TITLE := '  [XDCL, #GATE] pfp$r3_utility_attach', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r3_utility_attach
    (    lfn: amt$local_file_name;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
         allowed_cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR cycle_number: pft$cycle_number;
     VAR status: ost$status);

    CONST
      minimum_path_length = 3;

    VAR
      caller_id: ost$caller_identifier,
      converted_family_name: ost$family_name,
      global_file_name: ost$binary_unique_name,
      local_share_selections: pft$share_selections,
      local_status: ost$status,
      local_usage_selections: pft$usage_selections,
      r2_attach_input: pft$r2_attach_in,
      system_privilege: boolean;

    #CALLER_ID (caller_id);
    status.normal := TRUE;

    osp$verify_system_privilege;

    check_family_location (path [pfc$family_name_index], converted_family_name, r2_attach_input.served_family,
          r2_attach_input.served_family_locator, local_status);
    IF local_status.normal THEN
      IF r2_attach_input.served_family THEN
        PUSH r2_attach_input.p_path: [1 .. UPPERBOUND (path)];
        convert_path_without_set (path, converted_family_name, minimum_path_length, file_path,
              r2_attach_input.p_path^, local_status);
      ELSE
        PUSH r2_attach_input.p_complete_path: [1 .. UPPERBOUND (path) + 1];
        convert_path (path, minimum_path_length, file_path, r2_attach_input.p_complete_path^, local_status);
      IFEND;
    IFEND;

    IF local_status.normal THEN
      convert_lfn (lfn, r2_attach_input.lfn, local_status);
    IFEND;

    IF local_status.normal THEN
      check_cycle_selector (cycle_selector, local_status);
    IFEND;

    IF local_status.normal THEN
      r2_attach_input.cycle_selector := cycle_selector;
      pfi$convert_password (password, r2_attach_input.password, local_status);
    IFEND;

    IF local_status.normal THEN
      convert_usage_and_share_selects (usage_selections, share_selections, local_usage_selections,
            local_share_selections);
      IF r2_attach_input.served_family THEN
        system_privilege := pfp$system_privilege (caller_id.ring,
              r2_attach_input.p_path^ [pfc$master_catalog_name_index]);
      ELSE
        system_privilege := pfp$system_privilege (caller_id.ring,
              r2_attach_input.p_complete_path^ [pfc$master_catalog_path_index]);
      IFEND;

    /attach/
      WHILE TRUE DO
        pfp$r2_attach (r2_attach_input, update_catalog, {update_cycle_statistics} FALSE,
              local_usage_selections, local_share_selections, system_privilege,
              {validation_ring} caller_id.ring, allowed_cycle_damage_symptoms, cycle_number,
              cycle_damage_symptoms, global_file_name, local_status);
        IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
          EXIT /attach/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$R2_ATTACH');
        IFEND;
      WHILEND /attach/;

    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pfp$r3_utility_attach;

?? TITLE := '  [XDCL] pfp$recreate_system_catalog', EJECT ??

  PROCEDURE [XDCL] pfp$recreate_system_catalog
    (VAR status: ost$status);

    pfp$r2_recreate_system_catalog (status);
  PROCEND pfp$recreate_system_catalog;

?? TITLE := '  [XDCL] pfp$restricted_attach', EJECT ??
*copy pfh$restricted_attach

  PROCEDURE [XDCL] pfp$restricted_attach
    (    lfn: amt$local_file_name;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
     VAR cycle_number: pft$cycle_number;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      cycle_damage_symptoms: fst$cycle_damage_symptoms,
      global_file_name: ost$binary_unique_name,
      local_share_selections: pft$share_selections,
      local_status: ost$status,
      local_usage_selections: pft$usage_selections,
      r2_attach_input: pft$r2_attach_in;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$restricted_attach);
    status.normal := TRUE;

    osp$verify_system_privilege;

    r2_attach_input.served_family := FALSE;
    PUSH r2_attach_input.p_complete_path: [1 .. UPPERBOUND (path) + 1];
    convert_path (path, {minimum_path_length} 3, file_path, r2_attach_input.p_complete_path^, local_status);

    IF local_status.normal THEN
      convert_lfn (lfn, r2_attach_input.lfn, local_status);
    IFEND;

    IF local_status.normal THEN
      check_cycle_selector (cycle_selector, local_status);
    IFEND;

    IF local_status.normal THEN
      r2_attach_input.cycle_selector := cycle_selector;
      pfi$convert_password (password, r2_attach_input.password, local_status);
    IFEND;

    IF local_status.normal THEN
      convert_usage_and_share_selects (usage_selections, share_selections, local_usage_selections,
            local_share_selections);
      {
      { This procedure is only called by job recovery.  Hence, system_privilege
      { is always appropriate in this procedure.
      {
    /attach/
      WHILE TRUE DO
      pfp$r2_attach (r2_attach_input, NOT update_catalog, {update_cycle_statistics} FALSE,
            local_usage_selections, local_share_selections, {system_privilege} TRUE,
            {validation_ring} caller_id.ring, {allowed_cycle_damage_symptoms} $fst$cycle_damage_symptoms [],
            cycle_number, cycle_damage_symptoms, global_file_name, local_status);
        IF local_status.normal OR (local_status.condition <> pfe$catalog_access_retry) THEN
          EXIT /attach/;
        ELSE
          pfp$catalog_access_retry_wait ('PFP$R2_SAVE_RELEASED_FILE_LABEL');
        IFEND;
      WHILEND /attach/;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$restricted_attach);
  PROCEND pfp$restricted_attach;

?? TITLE := '  [XDCL, #GATE] pfp$set_restore_status', EJECT ??
*copy pfh$set_restore_status

  PROCEDURE [XDCL, #GATE] pfp$set_restore_status
    (    restore_missing_catalogs_done: boolean;
     VAR status: ost$status);

    VAR
      p_restore_status: ^SEQ ( * ),
      restore_status: pft$retained_restore_status;

    status.normal := TRUE;

    IF NOT (avp$system_administrator () OR avp$family_administrator () ) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active,
           'system_administration or family_administration', status);
      RETURN;
    IFEND;

    IF restore_missing_catalogs_done THEN
      restore_status := pfc$restore_missing_cat_done;
    ELSE
      restore_status := pfc$restore_missing_cat_start;
    IFEND;
    p_restore_status := #SEQ (restore_status);
    dsp$store_data_in_rdf (dsc$rdf_restore_status, dsc$rdf_production, p_restore_status);
  PROCEND pfp$set_restore_status;

?? TITLE := '  [XDCL] pfp$validate_local_family', EJECT ??
*copy pfh$validate_local_family

  PROCEDURE [XDCL] pfp$validate_local_family
    (    family_name: pft$name;
     VAR status: ost$status);

    VAR
      family_path: array [1 .. pfc$family_path_index] of pft$name;

    osp$get_set_name (family_name, family_path [pfc$set_path_index], status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    family_path [pfc$family_path_index] := family_name;

  /validate_catalog_exists/
    WHILE TRUE DO
      pfp$r2_validate_catalog_exists (family_path, status);
      IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
        EXIT /validate_catalog_exists/;
      ELSE
        pfp$catalog_access_retry_wait ('PFP$R2_VALIDATE_CATALOG_EXISTS');
      IFEND;
    WHILEND /validate_catalog_exists/;

  PROCEND pfp$validate_local_family;

?? TITLE := '  [XDCL] pfp$validate_site_options', EJECT ??
*copy pfh$validate_site_options

  PROCEDURE [XDCL, #GATE] pfp$validate_site_options
    (    family: pft$name;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
     VAR status: ost$status);

    VAR
      family_administrator: boolean,
      found: boolean,
      i: integer,
      name_list_size: avt$name_list_size,
      option_string: string (3),
      p_name_list: ^avt$name_list,
      search_name: ost$name,
      user_identification: ost$user_identification,
      validation_name: ost$name;

    status.normal := TRUE;

    IF site_archive_option <> pfc$null_site_archive_option THEN
      IF NOT avp$system_administrator () THEN
        pmp$get_user_identification (user_identification, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        family_administrator := avp$family_administrator () AND (family = user_identification.family);
        IF NOT family_administrator THEN
          validation_name := osc$null_name;
          validation_name (1, 20) := 'SITE_ARCHIVE_OPTIONS';
          PUSH p_name_list: [1 .. 10];
          avp$get_name_value (validation_name, avc$user, p_name_list^, name_list_size, status);
          IF status.normal AND (name_list_size > 10) THEN
            PUSH p_name_list: [1 .. name_list_size];
            avp$get_name_value (validation_name, avc$user, p_name_list^, name_list_size, status);
          IFEND;

          IF NOT status.normal THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$no_site_option_validation,
                  'SITE_ARCHIVE_OPTION', status);
            osp$append_status_integer (osc$status_parameter_delimiter, site_archive_option, radix,
                  NOT include_radix, status);
            RETURN;
          IFEND;

          clp$convert_integer_to_rjstring (site_archive_option, radix, NOT include_radix,
                {file_character} '0', option_string, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          search_name := osc$null_name;
          search_name (1, 5) := 'SITE_';
          search_name (6, 3) := option_string;

          found := FALSE;
        /locate_archive_name/
          FOR i := 1 TO name_list_size DO
            IF p_name_list^ [i] = 'ALL' THEN
              found := TRUE;
              EXIT /locate_archive_name/;
            ELSEIF p_name_list^ [i] = 'NONE' THEN
              EXIT /locate_archive_name/;
            ELSEIF p_name_list^ [i] = search_name THEN
              found := TRUE;
              EXIT /locate_archive_name/;
            IFEND;
          FOREND /locate_archive_name/;

          IF NOT found THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$no_site_option_validation,
                  'SITE_ARCHIVE_OPTION', status);
            osp$append_status_integer (osc$status_parameter_delimiter, site_archive_option, radix,
                  NOT include_radix, status);
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF site_backup_option <> pfc$null_site_backup_option THEN
      IF NOT avp$system_administrator () THEN
        pmp$get_user_identification (user_identification, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        family_administrator := avp$family_administrator () AND (family = user_identification.family);
        IF NOT family_administrator THEN
          validation_name := osc$null_name;
          validation_name (1, 19) := 'SITE_BACKUP_OPTIONS';
          PUSH p_name_list: [1 .. 10];
          avp$get_name_value (validation_name, avc$user, p_name_list^, name_list_size, status);
          IF status.normal AND (name_list_size > 10) THEN
            PUSH p_name_list: [1 .. name_list_size];
            avp$get_name_value (validation_name, avc$user, p_name_list^, name_list_size, status);
          IFEND;

          IF NOT status.normal THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$no_site_option_validation,
                  'SITE_BACKUP_OPTION', status);
            osp$append_status_integer (osc$status_parameter_delimiter, site_backup_option, radix,
                  NOT include_radix, status);
            RETURN;
          IFEND;

          clp$convert_integer_to_rjstring (site_backup_option, radix, NOT include_radix, {file_character} '0',
                option_string, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          search_name := osc$null_name;
          search_name (1, 5) := 'SITE_';
          search_name (6, 3) := option_string;

          found := FALSE;
        /locate_backup_name/
          FOR i := 1 TO name_list_size DO
            IF p_name_list^ [i] = 'ALL' THEN
              found := TRUE;
              EXIT /locate_backup_name/;
            ELSEIF p_name_list^ [i] = 'NONE' THEN
              EXIT /locate_backup_name/;
            ELSEIF p_name_list^ [i] = search_name THEN
              found := TRUE;
              EXIT /locate_backup_name/;
            IFEND;
          FOREND /locate_backup_name/;

          IF NOT found THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$no_site_option_validation,
                  'SITE_BACKUP_OPTION', status);
            osp$append_status_integer (osc$status_parameter_delimiter, site_backup_option, radix,
                  NOT include_radix, status);
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF site_release_option <> pfc$null_site_release_option THEN
      IF NOT avp$system_administrator () THEN
        pmp$get_user_identification (user_identification, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        family_administrator := avp$family_administrator () AND (family = user_identification.family);
        IF NOT family_administrator THEN
          validation_name := osc$null_name;
          validation_name (1, 20) := 'SITE_RELEASE_OPTIONS';
          PUSH p_name_list: [1 .. 10];
          avp$get_name_value (validation_name, avc$user, p_name_list^, name_list_size, status);
          IF status.normal AND (name_list_size > 10) THEN
            PUSH p_name_list: [1 .. name_list_size];
            avp$get_name_value (validation_name, avc$user, p_name_list^, name_list_size, status);
          IFEND;

          IF NOT status.normal THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$no_site_option_validation,
                  'SITE_RELEASE_OPTION', status);
            osp$append_status_integer (osc$status_parameter_delimiter, site_release_option, radix,
                  NOT include_radix, status);
            RETURN;
          IFEND;

          clp$convert_integer_to_rjstring (site_release_option, radix, NOT include_radix,
                {file_character} '0', option_string, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          search_name := osc$null_name;
          search_name (1, 5) := 'SITE_';
          search_name (6, 3) := option_string;

          found := FALSE;
        /locate_release_name/
          FOR i := 1 TO name_list_size DO
            IF p_name_list^ [i] = 'ALL' THEN
              found := TRUE;
              EXIT /locate_release_name/;
            ELSEIF p_name_list^ [i] = 'NONE' THEN
              EXIT /locate_release_name/;
            ELSEIF p_name_list^ [i] = search_name THEN
              found := TRUE;
              EXIT /locate_release_name/;
            IFEND;
          FOREND /locate_release_name/;

          IF NOT found THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$no_site_option_validation,
                  'SITE_RELEASE_OPTION', status);
            osp$append_status_integer (osc$status_parameter_delimiter, site_release_option, radix,
                  NOT include_radix, status);
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND pfp$validate_site_options;

?? TITLE := '  [XDCL, #GATE] pfp$verify_admin_retrieval', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$verify_admin_retrieval
    (    path: pft$path;
         cycle_number: pft$cycle_number;
     VAR status: ost$status);

    CONST
      minimum_path_length = 3,
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      fs_path_size: fst$path_size,
      p_complete_path: ^pft$complete_path,
      p_fs_path: ^fst$path;

    PUSH p_complete_path: [1 .. UPPERBOUND (path) + 1];
    convert_path (path, minimum_path_length, file_path, p_complete_path^, status);

    IF status.normal THEN
      pfp$get_authority (p_complete_path^, NOT system_privilege, authority, status);
      IF status.normal THEN
        IF NOT ((pfc$system_owner IN authority.ownership) OR (pfc$family_owner IN authority.ownership)) THEN
          PUSH p_fs_path;
          pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$retrieve_requires_privilege,
                p_fs_path^ (1, fs_path_size), status);
          osp$append_status_integer (osc$status_parameter_delimiter, cycle_number, radix, NOT include_radix,
                status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND pfp$verify_admin_retrieval;

?? TITLE := '  [XDCL, #GATE] pfp$verify_pva', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$verify_pva
    (    pva: ^cell;
         access_mode: mmt$va_access_mode;
     VAR status: ost$status);

    CONST
      include_radix = TRUE,
      radix = 16;

    VAR
      caller_id: ost$caller_identifier,
      local_status: ost$status;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$verify_pva);
    local_status.normal := TRUE;

    IF pva = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$nil_pointer, '', local_status);
    ELSEIF NOT mmp$verify_access (^pva, access_mode) THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_or_unusable_pva, '', local_status);
      osp$append_status_integer (osc$status_parameter_delimiter, #RING (pva), radix, NOT include_radix,
            local_status);
      osp$append_status_integer (osc$status_parameter_delimiter, #SEGMENT (pva), radix, NOT include_radix,
            local_status);
      osp$append_status_integer (osc$status_parameter_delimiter, #OFFSET (pva), radix, NOT include_radix,
            local_status);
    IFEND;

    IF local_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pfk$verify_pva);
  PROCEND pfp$verify_pva;
?? TITLE := '  [XDCL, #GATE] pfp$get_file_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$get_file_info
    (    segment: ^cell;
     VAR file_info: dmt$file_information;
     VAR status: ost$status);

  VAR
    local_info: dmt$file_information,
    sfid: gft$system_file_identifier;

    osp$verify_system_privilege;

    gfp$get_segment_sfid (segment, sfid, status);
    IF status.normal THEN
      dmp$get_file_info (sfid, local_info, status);
      IF status.normal THEN
        file_info := local_info;
      IFEND;
    IFEND;

  PROCEND pfp$get_file_info;
?? TITLE := '  Internal Procedures' ??
?? NEWTITLE := '    audit_changes', EJECT ??

  PROCEDURE audit_changes
    (    variant_path: pft$variant_path;
         cycle_number: pft$cycle_number;
         device_class: rmt$device_class;
         system_privilege: boolean;
         change_list: pft$change_list;
         last_change_attempted: ost$non_negative_integers;
         audit_status: ost$status);

    VAR
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id,
      change_index: pft$array_index,
      cycle_selector: pft$cycle_selector,
      local_status: ost$status,
      local_variant_path: pft$variant_path,
      ownership: pft$ownership;

    audited_object.variant_path := variant_path;
    pfp$get_ownership (variant_path, system_privilege, ownership, local_status);

    FOR change_index := 1 TO last_change_attempted DO
      CASE change_list [change_index].change_type OF
      = pfc$pf_name_change =
        audit_information.audited_operation := sfc$ao_fs_change_name;
        audited_object.object_type := sfc$afsot_file;
        audit_information.change_fs_object_name.object_id_p := ^audited_object;
        audit_information.change_fs_object_name.ownership := ownership;
        local_variant_path.complete_path := variant_path.complete_path;
        IF variant_path.complete_path THEN
          PUSH local_variant_path.p_complete_path: [1 .. UPPERBOUND (variant_path.p_complete_path^)];
          local_variant_path.p_complete_path^ := variant_path.p_complete_path^;
          local_variant_path.p_complete_path^ [UPPERBOUND (variant_path.p_complete_path^)] :=
                change_list [change_index].pfn;
        ELSE
          PUSH local_variant_path.p_path: [1 .. UPPERBOUND (variant_path.p_path^)];
          local_variant_path.p_path^ := variant_path.p_path^;
          local_variant_path.p_path^ [UPPERBOUND (variant_path.p_path^)] := change_list [change_index].pfn;
        IFEND;
        audit_information.change_fs_object_name.new_variant_path := local_variant_path;
        sfp$emit_audit_statistic (audit_information, audit_status);

      = pfc$password_change =
        audit_information.audited_operation := sfc$ao_fs_change_attribute;
        audited_object.object_type := sfc$afsot_file;
        audit_information.change_fs_object_attribute.object_id_p := ^audited_object;
        audit_information.change_fs_object_attribute.ownership := ownership;
        audit_information.change_fs_object_attribute.attribute := sfc$afsoa_password;
        sfp$emit_audit_statistic (audit_information, audit_status);

      = pfc$cycle_number_change =
        audit_information.audited_operation := sfc$ao_fs_change_attribute;
        audited_object.object_type := sfc$afsot_cycle;
        cycle_selector.cycle_option := pfc$specific_cycle;
        cycle_selector.cycle_number := cycle_number;
        audited_object.cycle_selector_p := ^cycle_selector;
        audited_object.device_class := device_class;
        audit_information.change_fs_object_attribute.object_id_p := ^audited_object;
        audit_information.change_fs_object_attribute.ownership := ownership;
        audit_information.change_fs_object_attribute.attribute := sfc$afsoa_cycle_number;
        audit_information.change_fs_object_attribute.new_cycle_number :=
              change_list [change_index].cycle_number;
        sfp$emit_audit_statistic (audit_information, audit_status);

      = pfc$log_change =
        audit_information.audited_operation := sfc$ao_fs_change_attribute;
        audited_object.object_type := sfc$afsot_file;
        audit_information.change_fs_object_attribute.object_id_p := ^audited_object;
        audit_information.change_fs_object_attribute.ownership := ownership;
        audit_information.change_fs_object_attribute.attribute := sfc$afsoa_logging;
        audit_information.change_fs_object_attribute.logging := change_list [change_index].log = pfc$log;
        sfp$emit_audit_statistic (audit_information, audit_status);

      ELSE
        ;
      CASEND;
    FOREND;
  PROCEND audit_changes;

?? NEWTITLE := '    audit_file_changes', EJECT ??

  PROCEDURE audit_file_changes
    (    variant_path: pft$variant_path;
         cycle_number: pft$cycle_number;
         device_class: rmt$device_class;
         system_privilege: boolean;
         file_changes: fst$file_changes;
         last_change_attempted: ost$non_negative_integers;
         audit_status: ost$status);

    VAR
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id,
      change_index: pft$array_index,
      cycle_selector: pft$cycle_selector,
      local_status: ost$status,
      local_variant_path: pft$variant_path,
      ownership: pft$ownership;

    audited_object.variant_path := variant_path;
    pfp$get_ownership (variant_path, system_privilege, ownership, local_status);

    FOR change_index := 1 TO last_change_attempted DO
      CASE file_changes [change_index].selector OF
      = fsc$pf_name_change =
        audit_information.audited_operation := sfc$ao_fs_change_name;
        audited_object.object_type := sfc$afsot_file;
        audit_information.change_fs_object_name.object_id_p := ^audited_object;
        audit_information.change_fs_object_name.ownership := ownership;
        local_variant_path.complete_path := variant_path.complete_path;
        IF variant_path.complete_path THEN
          PUSH local_variant_path.p_complete_path: [1 .. UPPERBOUND (variant_path.p_complete_path^)];
          local_variant_path.p_complete_path^ := variant_path.p_complete_path^;
          local_variant_path.p_complete_path^ [UPPERBOUND (variant_path.p_complete_path^)] :=
                file_changes [change_index].pfn;
        ELSE
          PUSH local_variant_path.p_path: [1 .. UPPERBOUND (variant_path.p_path^)];
          local_variant_path.p_path^ := variant_path.p_path^;
          local_variant_path.p_path^ [UPPERBOUND (variant_path.p_path^)] := file_changes [change_index].pfn;
        IFEND;
        audit_information.change_fs_object_name.new_variant_path := local_variant_path;
        sfp$emit_audit_statistic (audit_information, audit_status);

      = fsc$password_change =
        audit_information.audited_operation := sfc$ao_fs_change_attribute;
        audited_object.object_type := sfc$afsot_file;
        audit_information.change_fs_object_attribute.object_id_p := ^audited_object;
        audit_information.change_fs_object_attribute.ownership := ownership;
        audit_information.change_fs_object_attribute.attribute := sfc$afsoa_password;
        sfp$emit_audit_statistic (audit_information, audit_status);

      = fsc$cycle_number_change =
        audit_information.audited_operation := sfc$ao_fs_change_attribute;
        audited_object.object_type := sfc$afsot_cycle;
        cycle_selector.cycle_option := pfc$specific_cycle;
        cycle_selector.cycle_number := cycle_number;
        audited_object.cycle_selector_p := ^cycle_selector;
        audited_object.device_class := device_class;
        audit_information.change_fs_object_attribute.object_id_p := ^audited_object;
        audit_information.change_fs_object_attribute.ownership := ownership;
        audit_information.change_fs_object_attribute.attribute := sfc$afsoa_cycle_number;
        audit_information.change_fs_object_attribute.new_cycle_number :=
              file_changes [change_index].cycle_number;
        sfp$emit_audit_statistic (audit_information, audit_status);

      = fsc$log_change =
        audit_information.audited_operation := sfc$ao_fs_change_attribute;
        audited_object.object_type := sfc$afsot_file;
        audit_information.change_fs_object_attribute.object_id_p := ^audited_object;
        audit_information.change_fs_object_attribute.ownership := ownership;
        audit_information.change_fs_object_attribute.attribute := sfc$afsoa_logging;
        audit_information.change_fs_object_attribute.logging := file_changes [change_index].log = pfc$log;
        sfp$emit_audit_statistic (audit_information, audit_status);

      ELSE
        ;
      CASEND;
    FOREND;
  PROCEND audit_file_changes;

?? TITLE := '    audit_catalog_creation', EJECT ??

  PROCEDURE audit_catalog_creation
    (    variant_path: pft$variant_path;
         audit_ownership: audit_ownership_rec;
         audit_status: ost$status);

    VAR
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id,
      ignore_status: ost$status;

    audit_information.audited_operation := sfc$ao_fs_create_object;
    audited_object.variant_path := variant_path;
    audited_object.object_type := sfc$afsot_catalog;
    audit_information.create_fs_object.object_id_p := ^audited_object;
    IF audit_ownership.ownership_known THEN
      audit_information.create_fs_object.ownership := audit_ownership.ownership;
    ELSE
      pfp$get_ownership (variant_path, audit_ownership.system_privilege,
            audit_information.create_fs_object.ownership, ignore_status);
    IFEND;
    sfp$emit_audit_statistic (audit_information, audit_status);
  PROCEND audit_catalog_creation;

?? TITLE := '    audit_catalog_deletion', SKIP := 2 ??

  PROCEDURE audit_catalog_deletion
    (    variant_path: pft$variant_path;
         system_privilege: boolean;
         audit_status: ost$status);

    VAR
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id,
      ignore_status: ost$status;

    audit_information.audited_operation := sfc$ao_fs_delete_object;
    audited_object.variant_path := variant_path;
    audited_object.object_type := sfc$afsot_catalog;
    audit_information.delete_fs_object.object_id_p := ^audited_object;
    pfp$get_ownership (variant_path, system_privilege, audit_information.delete_fs_object.ownership,
          ignore_status);
    sfp$emit_audit_statistic (audit_information, audit_status);
  PROCEND audit_catalog_deletion;

?? TITLE := '    audit_cycle_creation', SKIP := 2 ??

  PROCEDURE audit_cycle_creation
    (    variant_path: pft$variant_path;
         cycle_selector: pft$cycle_selector;
         device_class: rmt$device_class;
         audit_ownership: audit_ownership_rec;
         audit_status: ost$status);

    VAR
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id,
      ignore_status: ost$status,
      usage_selections: pft$usage_selections;

    audit_information.audited_operation := sfc$ao_fs_create_object;
    audited_object.variant_path := variant_path;
    audited_object.object_type := sfc$afsot_cycle;
    audited_object.cycle_selector_p := ^cycle_selector;
    audited_object.device_class := device_class;
    audit_information.create_fs_object.object_id_p := ^audited_object;
    IF audit_ownership.ownership_known THEN
      audit_information.create_fs_object.ownership := audit_ownership.ownership;
    ELSE
      pfp$get_ownership (variant_path, audit_ownership.system_privilege,
            audit_information.create_fs_object.ownership, ignore_status);
    IFEND;
    sfp$emit_audit_statistic (audit_information, audit_status);
    audit_information.audited_operation := sfc$ao_fs_attach_file;
    usage_selections := - $pft$usage_selections [];
    audit_information.attach_file.access_mode_p := ^usage_selections;
    sfp$emit_audit_statistic (audit_information, audit_status);
  PROCEND audit_cycle_creation;

?? TITLE := '    audit_cycle_restorations', SKIP := 2 ??

  PROCEDURE audit_cycle_restorations
    (    variant_path: pft$variant_path;
         ownership: pft$ownership;
         auditable_cycles: pft$auditable_cycles);

    VAR
      audit_information: sft$audit_information,
      audit_status: ost$status,
      audited_object: sft$audited_fs_object_id,
      cycle_index: pft$array_index,
      cycle_selector: pft$cycle_selector;

    audit_information.audited_operation := sfc$ao_fs_create_object;
    audited_object.variant_path := variant_path;
    audited_object.object_type := sfc$afsot_cycle;
    cycle_selector.cycle_option := pfc$specific_cycle;
    audited_object.cycle_selector_p := ^cycle_selector;
    audit_information.create_fs_object.object_id_p := ^audited_object;
    audit_information.create_fs_object.ownership := ownership;

    FOR cycle_index := 1 TO UPPERBOUND (auditable_cycles) DO
      IF auditable_cycles [cycle_index].audit THEN
        cycle_selector.cycle_number := auditable_cycles [cycle_index].cycle_number;
        audited_object.device_class := auditable_cycles [cycle_index].device_class;
        audit_status.normal := auditable_cycles [cycle_index].normal_status;
        IF NOT audit_status.normal THEN
          audit_status.condition := auditable_cycles [cycle_index].condition;
        IFEND;
        sfp$emit_audit_statistic (audit_information, audit_status);
      IFEND;
    FOREND;
  PROCEND audit_cycle_restorations;

?? TITLE := '    audit_permit_creation', SKIP := 2 ??

  PROCEDURE audit_permit_creation
    (    variant_path: pft$variant_path;
         object_type: sft$audited_fs_object_type;
         system_privilege: boolean;
         group: pft$group;
         permit_selections: pft$permit_selections;
         audit_status: ost$status);

    VAR
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id,
      ignore_status: ost$status;

    audit_information.audited_operation := sfc$ao_fs_create_permit;
    audited_object.variant_path := variant_path;
    audited_object.object_type := object_type;
    audit_information.create_fs_permit.object_id_p := ^audited_object;
    pfp$get_ownership (variant_path, system_privilege, audit_information.create_fs_permit.ownership,
          ignore_status);
    audit_information.create_fs_permit.group_p := ^group;
    audit_information.create_fs_permit.permit_selections_p := ^permit_selections;
    sfp$emit_audit_statistic (audit_information, audit_status);
  PROCEND audit_permit_creation;

?? TITLE := '    audit_permit_deletion', SKIP := 2 ??

  PROCEDURE audit_permit_deletion
    (    variant_path: pft$variant_path;
         object_type: sft$audited_fs_object_type;
         system_privilege: boolean;
         group: pft$group;
         audit_status: ost$status);

    VAR
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id,
      ignore_status: ost$status;

    audit_information.audited_operation := sfc$ao_fs_delete_permit;
    audited_object.variant_path := variant_path;
    audited_object.object_type := object_type;
    audit_information.delete_fs_permit.object_id_p := ^audited_object;
    pfp$get_ownership (variant_path, system_privilege, audit_information.delete_fs_permit.ownership,
          ignore_status);
    audit_information.delete_fs_permit.group_p := ^group;
    sfp$emit_audit_statistic (audit_information, audit_status);
  PROCEND audit_permit_deletion;

?? TITLE := '    audit_permit_restorations', SKIP := 2 ??

  PROCEDURE audit_permit_restorations
    (    variant_path: pft$variant_path;
         object_type: sft$audited_fs_object_type;
         ownership: pft$ownership;
         auditable_permits: pft$auditable_permits);

    VAR
      audit_information: sft$audit_information,
      audit_status: ost$status,
      audited_object: sft$audited_fs_object_id,
      permit_index: pft$array_index;

    audit_information.audited_operation := sfc$ao_fs_create_permit;
    audited_object.variant_path := variant_path;
    audited_object.object_type := object_type;
    audit_information.create_fs_permit.object_id_p := ^audited_object;
    audit_information.create_fs_permit.ownership := ownership;

    FOR permit_index := 1 TO UPPERBOUND (auditable_permits) DO
      audit_information.create_fs_permit.group_p := ^auditable_permits [permit_index].group;
      audit_information.create_fs_permit.permit_selections_p :=
            ^auditable_permits [permit_index].permit_selections;
      audit_status.normal := auditable_permits [permit_index].normal_status;
      IF NOT audit_status.normal THEN
        audit_status.condition := auditable_permits [permit_index].condition;
      IFEND;
      sfp$emit_audit_statistic (audit_information, audit_status);
    FOREND;
  PROCEND audit_permit_restorations;

?? TITLE := '    [INLINE] check_cycle_number', SKIP := 2 ??

  PROCEDURE [INLINE] check_cycle_number
    (    cycle_number: pft$cycle_number;
     VAR status: ost$status);

    IF (pfc$minimum_cycle_number <= cycle_number) AND (cycle_number <= pfc$maximum_cycle_number) THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_cycle_number, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, cycle_number, radix, NOT include_radix,
            status);
    IFEND;
  PROCEND check_cycle_number;

?? TITLE := '    [INLINE] check_cycle_selector', SKIP := 2 ??

  PROCEDURE [INLINE] check_cycle_selector
    (    cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

    CASE cycle_selector.cycle_option OF
    = pfc$lowest_cycle, pfc$highest_cycle =
      status.normal := TRUE;
    = pfc$specific_cycle =
      check_cycle_number (cycle_selector.cycle_number, status);
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_cycle_option, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (cycle_selector.cycle_option),
            radix, NOT include_radix, status);
    CASEND;
  PROCEND check_cycle_selector;

?? TITLE := '    check_family_location', SKIP := 2 ??

  PROCEDURE check_family_location
    (    family_name: ost$family_name;
     VAR converted_family_name: ost$family_name;
     VAR served_family: boolean;
     VAR served_family_locator: pft$served_family_locator;
     VAR status: ost$status);

    VAR
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
      self_serving: boolean,
      server_state: dft$server_state;

    convert_family_name (family_name, catalog_path, converted_family_name, status);
    IF status.normal THEN
      served_family_locator.server_location.server_location_selector := dfc$served_family_table_index;
      dfp$locate_served_family (converted_family_name, served_family,
            served_family_locator.served_family_table_index,
            served_family_locator.server_mainframe_id,
            p_queue_interface_table,  queue_index, server_state);
      IF served_family THEN
        served_family_locator.server_location.served_family_table_index :=
              served_family_locator.served_family_table_index;
        dfp$check_self_serving_job (served_family_locator.server_mainframe_id, self_serving);
        served_family := NOT self_serving;
        IF served_family AND
          (p_queue_interface_table = NIL) THEN
          { Access to a recovering server is occuring prior to the definition of the server.
          { Determine the state of the server.
          IF server_state = dfc$awaiting_recovery THEN
           { Return the status of dfe$server_not_active to allow the recovery
           { to be performed as a result of waiting for unavailable server.
           osp$set_status_abnormal (dfc$file_server_id,
               dfe$server_not_active, converted_family_name, status);
          ELSE
            osp$set_status_abnormal (dfc$file_server_id,
               dfe$server_has_terminated, converted_family_name, status);
          IFEND;
        ELSE
         #KEYPOINT (osk$debug, osk$m * queue_index, pfk$file_server_request);
        IFEND;
      IFEND;
    IFEND;
  PROCEND check_family_location;

?? TITLE := '    check_for_path_too_long', SKIP := 2 ??

  PROCEDURE check_for_path_too_long
    (    variant_path: pft$variant_path;
     VAR status: ost$status);

    VAR
      found: boolean,
      fs_path_size: fst$path_size,
      p_fs_path: ^fst$path,
      question_mark: [oss$job_paged_literal, READ] set of char := ['?'],
      scan_index: 1 .. fsc$max_path_size + 1;

    IF variant_path.complete_path THEN
      IF UPPERBOUND (variant_path.p_complete_path^) - 1 > fsc$max_path_elements THEN
        osp$set_status_condition (pfe$path_too_long, status);
      ELSEIF UPPERBOUND (variant_path.p_complete_path^) - 1 >
            fsc$max_path_size DIV (fsc$max_path_element_size + 1) THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (variant_path.p_complete_path^, p_fs_path^, fs_path_size);
        #SCAN (question_mark, p_fs_path^ (1, fs_path_size), scan_index, found);
        IF found THEN
          osp$set_status_condition (pfe$path_too_long, status);
        ELSE
          status.normal := TRUE;
        IFEND;
      ELSE
        status.normal := TRUE;
      IFEND;
    ELSE
      IF UPPERBOUND (variant_path.p_path^) - 1 > fsc$max_path_elements THEN
        osp$set_status_condition (pfe$path_too_long, status);
      ELSEIF UPPERBOUND (variant_path.p_path^) - 1 >
            fsc$max_path_size DIV (fsc$max_path_element_size + 1) THEN
        PUSH p_fs_path;
        pfp$convert_pft$path_to_fs_path (variant_path.p_path^, p_fs_path^, fs_path_size);
        #SCAN (question_mark, p_fs_path^ (1, fs_path_size), scan_index, found);
        IF found THEN
          osp$set_status_condition (pfe$path_too_long, status);
        ELSE
          status.normal := TRUE;
        IFEND;
      ELSE
        status.normal := TRUE;
      IFEND;
    IFEND;
  PROCEND check_for_path_too_long;

?? TITLE := '    [INLINE] check_information_request', SKIP := 2 ??

  PROCEDURE [INLINE] check_information_request
    (    information_request: fst$goi_information_request;
     VAR status: ost$status);

    IF information_request.object_information_requests <= valid_object_info_requests THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_condition (pfe$bad_object_info_requests, status);
    IFEND;
  PROCEND check_information_request;

?? TITLE := '    [INLINE] check_log', SKIP := 2 ??

  PROCEDURE [INLINE] check_log
    (    log: pft$log;
     VAR status: ost$status);

    IF (log = pfc$log) OR (log = pfc$no_log) THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_log_option, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (log), radix, NOT include_radix,
            status);
    IFEND;
  PROCEND check_log;

?? TITLE := '    [INLINE] check_fs_retention', SKIP := 2 ??

  PROCEDURE [INLINE] check_fs_retention
    (    retention: fst$retention;
     VAR status: ost$status);

    CASE retention.selector OF
    = fsc$retention_day_increment =
      IF (pfc$minimum_retention <= retention.day_increment) AND
            (retention.day_increment <= pfc$maximum_retention) THEN
        status.normal := TRUE;
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_retention_period, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, retention.day_increment, radix,
              NOT include_radix, status);
      IFEND;
    = fsc$retention_time_increment =
      ;
    = fsc$retention_expiration_date =
      ;
    CASEND;

  PROCEND check_fs_retention;

?? TITLE := '    [INLINE] check_retention', SKIP := 2 ??

  PROCEDURE [INLINE] check_retention
    (    retention: pft$retention;
     VAR status: ost$status);

    IF (pfc$minimum_retention <= retention) AND (retention <= pfc$maximum_retention) THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_retention_period, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, retention, radix, NOT include_radix, status);
    IFEND;
  PROCEND check_retention;

?? TITLE := '    [INLINE] check_ring', SKIP := 2 ??

  PROCEDURE [INLINE] check_ring
    (    ring: ost$valid_ring;
     VAR status: ost$status);

    IF (ring < LOWERVALUE (ring)) OR (ring > UPPERVALUE (ring)) THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_ring_number, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, ring, radix, NOT include_radix, status);
    ELSE
      status.normal := TRUE;
    IFEND;
  PROCEND check_ring;

?? TITLE := '    convert_$family', SKIP := 2 ??

  PROCEDURE convert_$family
    (VAR converted_family_name: {i/o} ost$user_name;
     VAR status: ost$status);

    VAR
      user_id: ost$user_identification;

    IF converted_family_name = '$FAMILY' THEN
      pmp$get_user_identification (user_id, status);
      pfp$process_unexpected_status (status);
      converted_family_name := user_id.family;
    ELSE
      status.normal := TRUE;
    IFEND;
  PROCEND convert_$family;

?? TITLE := '    convert_account_name', SKIP := 2 ??

  PROCEDURE convert_account_name
    (    account_name: avt$account_name;
     VAR converted_account_name: avt$account_name;
     VAR status: ost$status);

    VAR
      project: avt$project_name;

    IF account_name = osc$null_name THEN
      pmp$get_account_project (converted_account_name, project, status);
      pfp$process_unexpected_status (status);
    ELSE
      clp$validate_name (account_name, converted_account_name, status.normal);
      IF NOT status.normal THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_account_name, account_name, status);
      IFEND;
    IFEND;
  PROCEND convert_account_name;

?? TITLE := '    convert_change_list', SKIP := 2 ??

  PROCEDURE convert_change_list
    (    variant_path: pft$variant_path;
         change_list: pft$change_list;
     VAR converted_change_list: pft$change_list;
     VAR status: ost$status);

    VAR
      change_index: pft$array_index,
      found: boolean,
      new_variant_path: pft$variant_path,
      space_index: 1 .. fsc$max_path_element_size + 1,
      valid_new_file_name: boolean;

    FOR change_index := 1 TO UPPERBOUND (change_list) DO
      converted_change_list [change_index] := change_list [change_index];

      CASE change_list [change_index].change_type OF
      = pfc$pf_name_change =
        clp$validate_new_file_name (change_list [change_index].pfn, converted_change_list [change_index].pfn,
              valid_new_file_name);
        IF valid_new_file_name THEN
          IF variant_path.complete_path THEN
            new_variant_path.complete_path := TRUE;
            PUSH new_variant_path.p_complete_path: [1 .. UPPERBOUND (variant_path.p_complete_path^)];
            new_variant_path.p_complete_path^ := variant_path.p_complete_path^;
            new_variant_path.p_complete_path^ [UPPERBOUND (variant_path.p_complete_path^)] :=
                  converted_change_list [change_index].pfn;
          ELSE
            new_variant_path.complete_path := FALSE;
            PUSH new_variant_path.p_path: [1 .. UPPERBOUND (variant_path.p_path^)];
            new_variant_path.p_path^ := variant_path.p_path^;
            new_variant_path.p_path^ [UPPERBOUND (variant_path.p_path^)] :=
                  converted_change_list [change_index].pfn;
          IFEND;
          check_for_path_too_long (new_variant_path, status);
        ELSE
          #SCAN (pfv$space_character, converted_change_list [change_index].pfn, space_index, found);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_permanent_file_name,
                converted_change_list [change_index].pfn (1, space_index - 1), status);
        IFEND;

      = pfc$password_change =
        pfi$convert_password (change_list [change_index].password,
              converted_change_list [change_index].password, status);

      = pfc$cycle_number_change =
        check_cycle_number (change_list [change_index].cycle_number, status);

      = pfc$retention_change =
        check_retention (change_list [change_index].retention, status);

      = pfc$log_change =
        check_log (change_list [change_index].log, status);

      = pfc$charge_change =
        status.normal := TRUE;

      = pfc$delete_damage_change =
        IF NOT (change_list [change_index].delete_damage_condition <=
              $fst$cycle_damage_symptoms [fsc$media_image_inconsistent, fsc$respf_modification_mismatch,
              fsc$parent_catalog_restored]) THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$incorrect_damage_condition,
                'damage condition is unknown or unchangeable.', status);
        IFEND;

      ELSE
        osp$set_status_condition (pfe$bad_change_type, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (change_list [change_index].change_type), radix, NOT include_radix, status);
      CASEND;

      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    status.normal := TRUE;
  PROCEND convert_change_list;

?? TITLE := '    convert_charge_id', SKIP := 2 ??

  PROCEDURE convert_charge_id
    (    charge_id: pft$charge_id;
     VAR converted_charge_id: pft$charge_id;
     VAR status: ost$status);

    convert_account_name (charge_id.account, converted_charge_id.account, status);
    IF status.normal THEN
      convert_project_name (charge_id.project, converted_charge_id.project, status);
    IFEND;
  PROCEND convert_charge_id;

?? TITLE := '    convert_date_time', SKIP := 2 ??

  PROCEDURE convert_date_time
    (    p_date_time: ^fst$date_time;
     VAR converted_date_time: pft$date_time;
     VAR status: ost$status);

    VAR
      current_date_time: ost$date_time,
      local_date_time: ost$date_time;

    IF p_date_time = NIL THEN
      converted_date_time.date_time_option := pfc$no_date_time;
      status.normal := TRUE;
    ELSE
      pfp$verify_pva (p_date_time, mmc$va_read, status);

      IF status.normal THEN
        pmp$get_compact_date_time (current_date_time, status);
      IFEND;

      IF status.normal THEN
        IF p_date_time^.value_specified THEN
          local_date_time := p_date_time^.date_time;
          pmp$verify_compact_date (local_date_time, status);

          IF status.normal THEN
            pmp$verify_compact_time (local_date_time, status);
          IFEND;

          IF status.normal THEN
            IF (local_date_time.year > current_date_time.year) OR
                  ((local_date_time.year = current_date_time.year) AND
                  ((local_date_time.month > current_date_time.month) OR
                  ((local_date_time.month = current_date_time.month) AND
                  ((local_date_time.day > current_date_time.day) OR
                  ((local_date_time.day = current_date_time.day) AND
                  ((local_date_time.hour > current_date_time.hour) OR
                  ((local_date_time.hour = current_date_time.hour) AND
                  ((local_date_time.minute > current_date_time.minute) OR
                  ((local_date_time.minute = current_date_time.minute) AND
                  ((local_date_time.second > current_date_time.second) OR
                  ((local_date_time.second = current_date_time.second) AND
                  ((local_date_time.millisecond > current_date_time.millisecond))))))))))))) THEN
              osp$set_status_abnormal (fsc$file_system_id, fse$unallowed_future_date_time, '', status);
            ELSE
              converted_date_time.date_time_option := pfc$specified_date_time;
              converted_date_time.specified_date_time := local_date_time;
              status.normal := TRUE;
            IFEND;
          IFEND;
        ELSE
          converted_date_time.date_time_option := pfc$current_date_time;
          converted_date_time.specified_date_time := current_date_time;
        IFEND;
      IFEND;
    IFEND;
  PROCEND convert_date_time;

?? TITLE := '    convert_family_name', SKIP := 2 ??

  PROCEDURE convert_family_name
    (    family_name: ost$family_name;
         path_type: path_types;
     VAR converted_family_name: ost$family_name;
     VAR status: ost$status);

    VAR
      found: boolean,
      space_index: 1 .. fsc$max_path_element_size + 1,
      user_id: ost$user_identification;

    CASE path_type OF
    = catalog_path =
      IF family_name = osc$null_name THEN
        pmp$get_user_identification (user_id, status);
        pfp$process_unexpected_status (status);
        converted_family_name := user_id.family;
      ELSE
        clp$validate_name (family_name, converted_family_name, status.normal);
        IF NOT status.normal THEN
          #SCAN (pfv$space_character, family_name, space_index, found);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_family_name,
                family_name (1, space_index - 1), status);
        IFEND;
      IFEND;

    = new_catalog_path =
      IF family_name = osc$null_name THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_family_name, family_name, status);
      ELSE
        clp$validate_new_file_name (family_name, converted_family_name, status.normal);
        IF NOT status.normal THEN
          #SCAN (pfv$space_character, family_name, space_index, found);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_family_name,
                family_name (1, space_index - 1), status);
        IFEND;
      IFEND;

    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'Bad path_type encountered.', status);
    CASEND;
  PROCEND convert_family_name;

?? TITLE := '    convert_file_changes', SKIP := 2 ??

  PROCEDURE convert_file_changes
    (    variant_path: pft$variant_path;
         file_changes: ^fst$file_changes;
     VAR converted_file_changes: ^fst$file_changes;
     VAR status: ost$status);

    VAR
      change_index: pft$array_index,
      family: pft$name,
      found: boolean,
      new_variant_path: pft$variant_path,
      site_archive_option: pft$site_archive_option,
      site_backup_option: pft$site_backup_option,
      site_release_option: pft$site_release_option,
      space_index: 1 .. fsc$max_path_element_size + 1,
      valid_new_file_name: boolean;

    status.normal := TRUE;
    site_archive_option := pfc$null_site_archive_option;
    site_backup_option := pfc$null_site_backup_option;
    site_release_option := pfc$null_site_release_option;

    FOR change_index := 1 TO UPPERBOUND (file_changes^) DO
      converted_file_changes^ [change_index] := file_changes^ [change_index];

      CASE file_changes^ [change_index].selector OF
      = fsc$charge_change =
        ;
      = fsc$cycle_number_change =
        check_cycle_number (file_changes^ [change_index].cycle_number, status);

      = fsc$delete_damage_change =
        IF NOT (file_changes^ [change_index].delete_damage_condition <=
              $fst$cycle_damage_symptoms [fsc$media_image_inconsistent, fsc$respf_modification_mismatch,
              fsc$parent_catalog_restored]) THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$incorrect_damage_condition,
                'damage condition is unknown or unchangeable.', status);
        IFEND;

      = fsc$log_change =
        check_log (file_changes^ [change_index].log, status);

      = fsc$null_file_change =
        ;

      = fsc$password_change =
        pfi$convert_password (file_changes^ [change_index].password,
              converted_file_changes^ [change_index].password, status);

      = fsc$pf_name_change =
        clp$validate_new_file_name (file_changes^ [change_index].pfn,
              converted_file_changes^ [change_index].pfn, valid_new_file_name);
        IF valid_new_file_name THEN
          IF variant_path.complete_path THEN
            new_variant_path.complete_path := TRUE;
            PUSH new_variant_path.p_complete_path: [1 .. UPPERBOUND (variant_path.p_complete_path^)];
            new_variant_path.p_complete_path^ := variant_path.p_complete_path^;
            new_variant_path.p_complete_path^ [UPPERBOUND (variant_path.p_complete_path^)] :=
                  converted_file_changes^ [change_index].pfn;
          ELSE
            new_variant_path.complete_path := FALSE;
            PUSH new_variant_path.p_path: [1 .. UPPERBOUND (variant_path.p_path^)];
            new_variant_path.p_path^ := variant_path.p_path^;
            new_variant_path.p_path^ [UPPERBOUND (variant_path.p_path^)] :=
                  converted_file_changes^ [change_index].pfn;
          IFEND;
          check_for_path_too_long (new_variant_path, status);
        ELSE
          #SCAN (pfv$space_character, converted_file_changes^ [change_index].pfn, space_index, found);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_permanent_file_name,
                converted_file_changes^ [change_index].pfn (1, space_index - 1), status);
        IFEND;

      = fsc$retention_change =
        check_fs_retention (file_changes^ [change_index].retention, status);
      = fsc$retrieve_option_change =
        ;
      = fsc$shared_queue_change =
        ;
      = fsc$site_archive_option_change =
        site_archive_option := file_changes^ [change_index].site_archive_option;
      = fsc$site_backup_option_change =
        site_backup_option := file_changes^ [change_index].site_backup_option;
      = fsc$site_release_option_change =
        site_release_option := file_changes^ [change_index].site_release_option;

      ELSE
        osp$set_status_condition (pfe$bad_change_type, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (file_changes^ [change_index].selector), radix, NOT include_radix, status);
      CASEND;

      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    IF variant_path.complete_path THEN
      family :=  variant_path.p_complete_path^ [pfc$family_path_index];
    ELSE
      family :=  variant_path.p_path^ [pfc$family_name_index];
    IFEND;
    pfp$validate_site_options (family, site_archive_option, site_backup_option, site_release_option, status);

  PROCEND convert_file_changes;

?? TITLE := '    convert_group', SKIP := 2 ??

  PROCEDURE convert_group
    (    group: pft$group;
         creating_permit: boolean;
     VAR converted_group: pft$group;
     VAR status: ost$status);

    converted_group.group_type := group.group_type;
    CASE group.group_type OF
    = pfc$public =
      status.normal := TRUE;

    = pfc$family =
      convert_family_name (group.family_description.family, catalog_path,
            converted_group.family_description.family, status);
      IF status.normal AND creating_permit THEN
        convert_$family (converted_group.family_description.family, status);
      IFEND;

    = pfc$account =
      convert_family_name (group.account_description.family, catalog_path,
            converted_group.account_description.family, status);
      IF status.normal AND creating_permit THEN
        convert_$family (converted_group.family_description.family, status);
      IFEND;
      IF status.normal THEN
        convert_account_name (group.account_description.account, converted_group.account_description.account,
              status);
      IFEND;

    = pfc$project =
      convert_family_name (group.project_description.family, catalog_path,
            converted_group.project_description.family, status);
      IF status.normal AND creating_permit THEN
        convert_$family (converted_group.family_description.family, status);
      IFEND;
      IF status.normal THEN
        convert_account_name (group.project_description.account, converted_group.project_description.account,
              status);
        IF status.normal THEN
          convert_project_name (group.project_description.project,
                converted_group.project_description.project, status);
        IFEND;
      IFEND;

    = pfc$user =
      convert_family_name (group.user_description.family, catalog_path,
            converted_group.user_description.family, status);
      IF status.normal AND creating_permit THEN
        convert_$family (converted_group.family_description.family, status);
      IFEND;
      IF status.normal THEN
        convert_user_name (group.user_description.user, creating_permit,
              converted_group.user_description.user, status);
      IFEND;

    = pfc$user_account =
      convert_family_name (group.user_account_description.family, catalog_path,
            converted_group.user_account_description.family, status);
      IF status.normal AND creating_permit THEN
        convert_$family (converted_group.family_description.family, status);
      IFEND;
      IF status.normal THEN
        convert_account_name (group.user_account_description.account,
              converted_group.user_account_description.account, status);
        IF status.normal THEN
          convert_user_name (group.user_account_description.user, creating_permit,
                converted_group.user_account_description.user, status);
        IFEND;
      IFEND;

    = pfc$member =
      convert_family_name (group.member_description.family, catalog_path,
            converted_group.member_description.family, status);
      IF status.normal AND creating_permit THEN
        convert_$family (converted_group.family_description.family, status);
      IFEND;
      IF status.normal THEN
        convert_account_name (group.member_description.account, converted_group.member_description.account,
              status);
        IF status.normal THEN
          convert_project_name (group.member_description.project, converted_group.member_description.project,
                status);
          IF status.normal THEN
            convert_user_name (group.member_description.user, creating_permit,
                  converted_group.member_description.user, status);
          IFEND;
        IFEND;
      IFEND;

    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_group_type, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (group.group_type), radix,
            NOT include_radix, status);
    CASEND;
  PROCEND convert_group;

?? TITLE := '    convert_lfn', SKIP := 2 ??

  PROCEDURE convert_lfn
    (    lfn: amt$local_file_name;
     VAR converted_lfn: amt$local_file_name;
     VAR status: ost$status);

    VAR
      found: boolean,
      space_index: 1 .. fsc$max_path_element_size + 1;

    clp$validate_new_file_name (lfn, converted_lfn, status.normal);
    IF NOT status.normal THEN
      #SCAN (pfv$space_character, lfn, space_index, found);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_local_file_name,
            lfn (1, space_index - 1), status);
    IFEND;
  PROCEND convert_lfn;

?? TITLE := '    convert_master_catalog_name', SKIP := 2 ??

  PROCEDURE convert_master_catalog_name
    (    master_catalog_name: pft$name;
         path_type: path_types;
     VAR converted_master_catalog_name: pft$name;
     VAR status: ost$status);

    CONST
      system_user_name = '$SYSTEM';

    VAR
      found: boolean,
      space_index: 1 .. fsc$max_path_element_size + 1,
      user_id: ost$user_identification;

    CASE path_type OF
    = catalog_path =
      IF master_catalog_name = osc$null_name THEN
        pmp$get_user_identification (user_id, status);
        pfp$process_unexpected_status (status);
        converted_master_catalog_name := user_id.user;
      ELSE
        clp$validate_name (master_catalog_name, converted_master_catalog_name, status.normal);
        IF NOT status.normal THEN
          #SCAN (pfv$space_character, master_catalog_name, space_index, found);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_master_catalog_name,
                master_catalog_name (1, space_index - 1), status);
        IFEND;
      IFEND;

    = new_catalog_path =
      IF master_catalog_name = osc$null_name THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_master_catalog_name,
              master_catalog_name, status);
      ELSEIF master_catalog_name = system_user_name THEN
        converted_master_catalog_name := master_catalog_name;
        status.normal := TRUE;
      ELSE
        clp$validate_new_file_name (master_catalog_name, converted_master_catalog_name, status.normal);
        IF NOT status.normal THEN
          #SCAN (pfv$space_character, master_catalog_name, space_index, found);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_master_catalog_name,
                master_catalog_name (1, space_index - 1), status);
        IFEND;
      IFEND;

    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'Bad path_type encountered.', status);
    CASEND;
  PROCEND convert_master_catalog_name;

?? TITLE := '    [INLINE] convert_password_selector', SKIP := 2 ??

  PROCEDURE [INLINE] convert_password_selector
    (    password_selector: pft$password_selector;
     VAR converted_password_selector: pft$password_selector;
     VAR status: ost$status);

    IF password_selector.password_specified = pfc$default_password_option THEN
      converted_password_selector := password_selector;
      status.normal := TRUE;
    ELSEIF password_selector.password_specified = pfc$specific_password_option THEN
      IF password_selector.password = osc$null_name THEN
        converted_password_selector := password_selector;
        status.normal := TRUE;
      ELSE
        converted_password_selector.password_specified := pfc$specific_password_option;
        clp$validate_name (password_selector.password, converted_password_selector.password, status.normal);
        IF NOT status.normal THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_password,
                password_selector.password, status);
        IFEND;
      IFEND;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_password,
            'bad password_specified option', status);
    IFEND;
  PROCEND convert_password_selector;

?? TITLE := '    convert_path', SKIP := 2 ??

  PROCEDURE convert_path
    (    path: pft$path;
         minimum_path_length: integer;
         path_type: path_types;
     VAR converted_path: pft$complete_path;
     VAR status: ost$status);

    VAR
      found: boolean,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      new_path_index: integer,
      p_new_path: pft$p_complete_path,
      path_index: integer,
      path_length: integer,
      space_index: 1 .. fsc$max_path_element_size + 1;

    path_length := UPPERBOUND (path);

    convert_family_name (path [pfc$family_name_index], catalog_path, converted_path [pfc$family_path_index],
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF path_length > pfc$family_name_index THEN
      convert_master_catalog_name (path [pfc$master_catalog_name_index],
            catalog_path, converted_path [pfc$master_catalog_path_index], status);
      IF status.normal THEN
        osp$get_set_name (converted_path [pfc$family_path_index], converted_path [pfc$set_path_index],
            status);
      ELSE
        RETURN;
      IFEND;
    ELSE
      osp$get_set_name (path [pfc$family_name_index], converted_path [pfc$set_path_index],
        status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF path_length < minimum_path_length THEN
      PUSH p_new_path: [1 .. path_length + 1];
      IF path_length > pfc$family_name_index THEN
        p_new_path^ [pfc$set_path_index] := converted_path [pfc$set_path_index];
      IFEND;
      FOR path_index := pfc$family_path_index TO path_length + 1 DO
        p_new_path^ [path_index] := converted_path [path_index];
      FOREND;
      pfp$convert_pf_path_to_fs_path (p_new_path^, fs_path, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$path_too_short, fs_path (1, fs_path_size),
            status);
      osp$append_status_integer (osc$status_parameter_delimiter, minimum_path_length, radix,
            NOT include_radix, status);
      CASE path_type OF
      = catalog_path, new_catalog_path =
        osp$append_status_parameter (osc$status_parameter_delimiter, 'catalog', status);
      = file_path, new_file_path =
        osp$append_status_parameter (osc$status_parameter_delimiter, 'file', status);
      = item_path, new_item_path =
        osp$append_status_parameter (osc$status_parameter_delimiter, 'catalog/file', status);
      CASEND;
      RETURN;
    IFEND;

    IF path_length > pfc$master_catalog_name_index THEN
      FOR path_index := pfc$subcatalog_name_index TO path_length - 1 DO
        clp$validate_name (path [path_index], converted_path [path_index + 1], status.normal);
        IF NOT status.normal THEN
          PUSH p_new_path: [1 .. path_index + 1];
          FOR new_path_index := pfc$set_path_index TO path_index DO
            p_new_path^ [new_path_index] := converted_path [new_path_index];
          FOREND;
          p_new_path^ [path_index + 1] := path [path_index];
          pfp$convert_pf_path_to_fs_path (p_new_path^, fs_path, fs_path_size);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_nth_subcatalog_name,
                fs_path (1, fs_path_size), status);
          RETURN;
        IFEND;
      FOREND;

      CASE path_type OF
      = catalog_path, item_path =
        clp$validate_name (path [path_length], converted_path [path_length + 1], status.normal);
        IF NOT status.normal THEN
          PUSH p_new_path: [1 .. path_length + 1];
          FOR path_index := pfc$set_path_index TO path_length DO
            p_new_path^ [path_index] := converted_path [path_index];
          FOREND;
          p_new_path^ [path_length + 1] := path [path_length];
          pfp$convert_pf_path_to_fs_path (p_new_path^, fs_path, fs_path_size);
          IF path_type = catalog_path THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_last_subcatalog_name,
                  fs_path (1, fs_path_size), status);
          ELSE
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_item_name,
                  fs_path (1, fs_path_size), status);
          IFEND;
        IFEND;

      = file_path =
        clp$validate_name (path [path_length], converted_path [path_length + 1], status.normal);
        IF NOT status.normal THEN
          #SCAN (pfv$space_character, path [path_length], space_index, found);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_permanent_file_name,
                path [path_length] (1, space_index - 1), status);
        IFEND;

      = new_catalog_path, new_file_path, new_item_path =
        clp$validate_new_file_name (path [path_length], converted_path [path_length + 1], status.normal);
        IF NOT status.normal THEN
          #SCAN (pfv$space_character, path [path_length], space_index, found);
          CASE path_type OF
          = new_catalog_path =
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_last_subcatalog_name,
                  path [path_length] (1, space_index - 1), status);
          = new_file_path =
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_permanent_file_name,
                  path [path_length] (1, space_index - 1), status);
          ELSE
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_item_name, path [path_length] (1,
                  space_index - 1), status);
          CASEND;
        IFEND;

      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'Bad path_type encountered.', status);
      CASEND;
    IFEND;
  PROCEND convert_path;

?? TITLE := '    convert_path_without_set', SKIP := 2 ??

  PROCEDURE convert_path_without_set
    (    path: pft$path;
         converted_family_name: pft$name;
         minimum_path_length: integer;
         path_type: path_types;
     VAR converted_path: pft$complete_path;
     VAR status: ost$status);

    VAR
      found: boolean,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      new_path_index: integer,
      path_index: integer,
      path_length: integer,
      space_index: 1 .. fsc$max_path_element_size + 1,
      user_id: ost$user_identification;

    path_length := UPPERBOUND (path);

    converted_path [pfc$family_name_index] := converted_family_name;

    IF path_length > pfc$family_name_index THEN
      convert_master_catalog_name (path [pfc$master_catalog_name_index],
            catalog_path, converted_path [pfc$master_catalog_name_index], status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF path_length < minimum_path_length THEN
      pfp$convert_pft$path_to_fs_path (path, fs_path, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$path_too_short, fs_path (1, fs_path_size),
            status);
      osp$append_status_integer (osc$status_parameter_delimiter, minimum_path_length, radix,
            NOT include_radix, status);
      CASE path_type OF
      = catalog_path, new_catalog_path =
        osp$append_status_parameter (osc$status_parameter_delimiter, 'catalog', status);
      = file_path, new_file_path =
        osp$append_status_parameter (osc$status_parameter_delimiter, 'file', status);
      = item_path, new_item_path =
        osp$append_status_parameter (osc$status_parameter_delimiter, 'catalog/file', status);
      CASEND;
      RETURN;
    IFEND;

    IF path_length > pfc$master_catalog_name_index THEN
      FOR path_index := pfc$subcatalog_name_index TO path_length - 1 DO
        clp$validate_name (path [path_index], converted_path [path_index], status.normal);
        IF NOT status.normal THEN
          pfp$convert_pft$path_to_fs_path (path, fs_path, fs_path_size);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_nth_subcatalog_name,
                fs_path (1, fs_path_size), status);
          RETURN;
        IFEND;
      FOREND;

      CASE path_type OF
      = catalog_path, item_path =
        clp$validate_name (path [path_length], converted_path [path_length], status.normal);
        IF NOT status.normal THEN
          pfp$convert_pft$path_to_fs_path (path, fs_path, fs_path_size);
          IF path_type = catalog_path THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_last_subcatalog_name,
                  fs_path (1, fs_path_size), status);
          ELSE
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_item_name,
                  fs_path (1, fs_path_size), status);
          IFEND;
        IFEND;

      = file_path =
        clp$validate_name (path [path_length], converted_path [path_length], status.normal);
        IF NOT status.normal THEN
          #SCAN (pfv$space_character, path [path_length], space_index, found);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_permanent_file_name,
                path [path_length] (1, space_index - 1), status);
        IFEND;

      = new_catalog_path, new_file_path, new_item_path =
        clp$validate_new_file_name (path [path_length], converted_path [path_length], status.normal);
        IF NOT status.normal THEN
          #SCAN (pfv$space_character, path [path_length], space_index, found);
          CASE path_type OF
          = new_catalog_path =
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_last_subcatalog_name,
                  path [path_length] (1, space_index - 1), status);
          = new_file_path =
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_permanent_file_name,
                  path [path_length] (1, space_index - 1), status);
          ELSE
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_item_name, path [path_length] (1,
                  space_index - 1), status);
          CASEND;
        IFEND;

      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'Bad path_type encountered.', status);
      CASEND;
    IFEND;
  PROCEND convert_path_without_set;

?? TITLE := '    convert_project_name', SKIP := 2 ??

  PROCEDURE convert_project_name
    (    project_name: avt$project_name;
     VAR converted_project_name: avt$project_name;
     VAR status: ost$status);

    VAR
      account: avt$account_name;

    IF project_name = osc$null_name THEN
      pmp$get_account_project (account, converted_project_name, status);
      pfp$process_unexpected_status (status);
    ELSE
      clp$validate_name (project_name, converted_project_name, status.normal);
      IF NOT status.normal THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_project_name, project_name, status);
      IFEND;
    IFEND;
  PROCEND convert_project_name;

?? TITLE := '    convert_usage_and_share_selects', SKIP := 2 ??

  PROCEDURE convert_usage_and_share_selects
    (    usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
     VAR converted_usage_selections: pft$usage_selections;
     VAR converted_share_selections: pft$share_selections);

    VAR
      share_option: pft$share_options,
      usage_option: pft$usage_options;

    converted_usage_selections := $pft$usage_selections [];
    converted_share_selections := $pft$share_selections [];

    FOR usage_option := LOWERVALUE (usage_option) TO UPPERVALUE (usage_option) DO
      IF usage_option IN usage_selections THEN
        converted_usage_selections := converted_usage_selections + $pft$usage_selections [usage_option];
      IFEND;
    FOREND;

    FOR share_option := LOWERVALUE (share_option) TO UPPERVALUE (share_option) DO
      IF share_option IN share_selections THEN
        converted_share_selections := converted_share_selections + $pft$share_selections [share_option];
      IFEND;
    FOREND;
  PROCEND convert_usage_and_share_selects;

?? TITLE := '    [INLINE] convert_set_name', SKIP := 2 ??

  PROCEDURE [INLINE] convert_set_name
    (    family_name: ost$family_name;
     VAR converted_set_name: stt$set_name;
     VAR status: ost$status);

     VAR
       converted_family_name: ost$family_name;

    clp$validate_name (family_name, converted_family_name, status.normal);
    IF NOT status.normal THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_family_name, family_name, status);
    ELSE
      osp$get_set_name (converted_family_name, converted_set_name, status);
    IFEND;
  PROCEND convert_set_name;

?? TITLE := '    convert_user_name', SKIP := 2 ??

  PROCEDURE convert_user_name
    (    user_name: ost$user_name;
         creating_permit: boolean;
     VAR converted_user_name: ost$user_name;
     VAR status: ost$status);

    VAR
      user_id: ost$user_identification;

    IF user_name = osc$null_name THEN
      pmp$get_user_identification (user_id, status);
      pfp$process_unexpected_status (status);
      converted_user_name := user_id.user;
    ELSE
      clp$validate_name (user_name, converted_user_name, status.normal);
      IF status.normal THEN
        IF (converted_user_name = '$USER') AND creating_permit THEN
          pmp$get_user_identification (user_id, status);
          pfp$process_unexpected_status (status);
          converted_user_name := user_id.user;
        IFEND;
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_user_name, user_name, status);
      IFEND;
    IFEND;
  PROCEND convert_user_name;

?? TITLE := '    convert_validation_criteria', SKIP := 2 ??

  PROCEDURE convert_validation_criteria
    (    caller_id: ost$caller_identifier;
         p_validation_criteria: {input} ^fst$goi_validation_criteria;
         p_converted_validation_criteria: {output^} ^fst$goi_validation_criteria;
     VAR password_selector: pft$password_selector;
     VAR subject_permit_count: ost$non_negative_integers;
     VAR validation_ring: ost$valid_ring;
     VAR status: ost$status);

    VAR
      criterion_index: ost$positive_integers,
      local_group: pft$group,
      min_ring: ost$valid_ring,
      password_found: boolean,
      validation_ring_found: boolean;

    password_found := FALSE;
    password_selector.password_specified := pfc$default_password_option;
    subject_permit_count := 0;
    validation_ring_found := FALSE;
    min_ring := avp$ring_min ();
    IF caller_id.ring <= min_ring THEN
      validation_ring := caller_id.ring;
    ELSE
      validation_ring := min_ring;
    IFEND;

    p_converted_validation_criteria^ := p_validation_criteria^;

    FOR criterion_index := 1 TO UPPERBOUND (p_converted_validation_criteria^) DO
      CASE p_converted_validation_criteria^ [criterion_index].validation_selection OF
      = fsc$goi_password =
        IF NOT password_found THEN
          password_found := TRUE;
          password_selector.password_specified := pfc$specific_password_option;
          pfi$convert_password (p_converted_validation_criteria^ [criterion_index].password,
                password_selector.password, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

      = fsc$goi_subject_permit =
        convert_group (p_converted_validation_criteria^ [criterion_index].subject_permit.group,
              {creating_permit} FALSE, local_group, status);
        IF status.normal THEN
          p_converted_validation_criteria^ [criterion_index].subject_permit.group := local_group;
          subject_permit_count := subject_permit_count + 1;
        ELSE
          RETURN;
        IFEND;

      = fsc$goi_validation_ring =
        IF NOT validation_ring_found THEN
          validation_ring_found := TRUE;
          IF validation_ring <= p_converted_validation_criteria^ [criterion_index].validation_ring THEN
            validation_ring := p_converted_validation_criteria^ [criterion_index].validation_ring;
          ELSEIF p_converted_validation_criteria^ [criterion_index].validation_ring < validation_ring THEN
            osp$set_status_condition (pfe$bad_ring_number, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  p_converted_validation_criteria^ [criterion_index].validation_ring, radix,
                  NOT include_radix, status);
            RETURN;
          IFEND;
        IFEND;

      ELSE
        osp$set_status_condition (pfe$bad_validation_selection, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (p_converted_validation_criteria^ [criterion_index].validation_selection), radix,
              NOT include_radix, status);
        RETURN;
      CASEND;
    FOREND;
  PROCEND convert_validation_criteria;

?? OLDTITLE ??
?? NEWTITLE := ' emit_out_of_space_menu', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to present a menu to the operator
{   when MOVE_CLASSES cannot move files or catalogs because sufficient mass
{   storage space is not available.
{

  PROCEDURE emit_out_of_space_menu
    (    object_type_string: string(*),
         set_name: ost$name;
         path: pft$path;
         mass_storage_class: string (1);
         allocated_size: integer;
         reason_for_move_failure: pft$reason_for_move_failure;
     VAR operator_response: pft$mo_operator_response);

    CONST
      number_of_choices = 3;

    VAR
      int_string: ost$string,
      local_status: ost$status,
      message_parameters: array [1 .. 6] of ^ost$message_parameter,
      p_path_string: ^ost$string,
      parameter_names: ^ost$parameter_help_names,
      response: oft$number_of_choices,
      response_string: ost$string,
      system_job_name: jmt$system_supplied_name,
      user_job_name: jmt$user_supplied_name;

    operator_response := pfc$terminate_command;

    message_parameters [1] := ^object_type_string;
    pmp$get_job_names (user_job_name, system_job_name, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    message_parameters [2] := ^system_job_name;
    message_parameters [3] := ^mass_storage_class;
    message_parameters [4] := ^set_name;

    PUSH p_path_string;
    pfp$convert_pft$path_to_string (path, p_path_string^);
    message_parameters [5] := ^p_path_string^.value (1, p_path_string^.size);

    int_string.value := ' ';
    clp$convert_integer_to_string (allocated_size, {radix} 10, {include_radix} FALSE, int_string,
          local_status);
    IF local_status.normal THEN
      message_parameters [6] := ^int_string.value;
    ELSE
      message_parameters [6] := NIL;
    IFEND;

    PUSH parameter_names: [1 .. number_of_choices];
    parameter_names^ [1] := 'RETRY_MOVE';
    parameter_names^ [2] := 'SKIP_OBJECT';
    parameter_names^ [3] := 'TERMINATE_COMMAND';

    IF reason_for_move_failure = pfc$insufficient_space THEN
      ofp$format_operator_menu (pfc$movc_insuf_space, parameter_names, ^message_parameters,
            number_of_choices, ofc$system_operator, response, response_string, local_status);
      IF NOT local_status.normal THEN
        RETURN;
      IFEND;
    ELSEIF reason_for_move_failure = pfc$no_available_space THEN
      ofp$format_operator_menu (pfc$movc_no_space, parameter_names, ^message_parameters, number_of_choices,
            ofc$system_operator, response, response_string, local_status);
      IF NOT local_status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF response = 1 THEN {retry allocation}
      operator_response := pfc$retry_move;
    ELSEIF response = 2 THEN {skip object}
      operator_response := pfc$skip_object;
    ELSEIF response = 3 THEN {terminate command}
      operator_response := pfc$terminate_command;
    IFEND;

  PROCEND emit_out_of_space_menu;

?? OLDTITLE ??
?? NEWTITLE := 'update_set_volume_list', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to update the mass storage class
{   information contained in the MOVE_CLASSES SET_VOLUME_LIST.
{

  PROCEDURE update_set_volume_list
    (    set_volume_list_p: ^pft$mo_volume_list);

    VAR
      found: boolean,
      i: integer,
      j: integer,
      ms_volume_count: integer,
      ms_volumes_p: ^array [ * ] of cmt$mass_storage_volume;

    IF set_volume_list_p = NIL THEN
      RETURN;
    IFEND;

    { Obtain the class membership of each volume in the configuration which is ON and ENABLED.

    cmp$get_ms_volumes (ms_volume_count);
    PUSH ms_volumes_p: [1 .. ms_volume_count];
    cmp$get_ms_volume_info (ms_volumes_p);

    FOR i := 1 TO UPPERBOUND (set_volume_list_p^) DO
      found := FALSE;

    /locate_volume/
      FOR j := 1 TO ms_volume_count DO
        IF set_volume_list_p^ [i].recorded_vsn = ms_volumes_p^ [j].recorded_vsn THEN
          found := TRUE;
          EXIT /locate_volume/;
        IFEND;
      FOREND /locate_volume/;

      IF found THEN
        set_volume_list_p^ [i].ms_class := ms_volumes_p^ [j].class;
      IFEND;
    FOREND;

  PROCEND update_set_volume_list;

?? OLDTITLE, OLDTITLE, SKIP := 2 ??
MODEND pfm$program_interface_processor;
*DECK DECK=PFM$R2_DF_CLIENT_REQUESTS EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE File Server : Client Requests' ??
MODULE pfm$r2_df_client_requests;

{ PURPOSE:
{   This module processes the client side of permanent file requests
{   originating from the client and destined for the server.
{
{ DESIGN:
{   The general sequence is:
{   - Call dfp$begin_remote_procedure_call to obtain a queue entry, a pointer
{     to the parameter buffer, and a pointer to the data buffer.
{  - OR -
{   - Call dfp$begin_ch_remote_proc_call to set up a condition handler for
{     remote procedure call processing, and to obtain a queue entry, a pointer
{     to the parameter buffer, and a pointer to the data buffer.
{
{   - Call a procedure to package the parameters into the parameter and data
{     buffers of the queue entry.
{   - Call dfp$send_remote_procedure_call to queue the request.  This call will
{     wait for the server to return the request.  A pointer to the parameter
{     receive buffer and a pointer to the data receive buffer are returned.
{   - Call a procedure to parse the output parameters returned by the server in
{     the parameter receive buffer and in the data receive buffer.
{   - If needed: notify the local mainframe's file manager or device manager.
{     (i.e. on attach, create, and attach_or_create call
{     create_client_file_tables.)
{   - Call dfp$end_remote_procedure_call to release the queue entry.
{  - OR -
{   - Call dfp$end_ch_remote_proc_call to release the queue entry and
{     disestablish the condition handler.
{
{  NOTE:
{  The preferred method is to use the procedures which establish/disestablish
{  condition handlers.

?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$ring_validation_errors
*copyc dfc$partially_rebuilt_fde_eoi
*copyc dfd$driver_queue_types
*copyc dfd$file_server_info
*copyc dfd$request_package
*copyc dfe$error_condition_codes
*copyc dfk$file_server_info_keypoints
*copyc dft$server_file_output
*copyc fmt$mass_storage_request_info
*copyc fmt$removable_media_req_info
*copyc fse$open_validation_errors
*copyc fst$file_changes
*copyc fst$goi_object_information
*copyc fst$goi_validation_criteria
*copyc gft$system_file_identifier
*copyc oss$job_paged_literal
*copyc pfc$test_jr_constants
*copyc pfd$catalog
*copyc pfd$catalog_info
*copyc pfd$complete_path
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*copyc pfd$share_selector
*copyc pfd$usage_selector
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pft$auditable_cycles
*copyc pft$auditable_permits
*copyc pft$df_append_rem_media_vsn
*copyc pft$df_attach_in
*copyc pft$df_attach_out
*copyc pft$df_attach_or_create_in
*copyc pft$df_attach_or_create_out
*copyc pft$df_change_cy_dam
*copyc pft$df_change_cy_dt
*copyc pft$df_change_file_in
*copyc pft$df_change_file_out
*copyc pft$df_change_in
*copyc pft$df_change_out
*copyc pft$df_change_residence_in
*copyc pft$df_clear_cy_att_in
*copyc pft$df_define
*copyc pft$df_define_catalog
*copyc pft$df_define_data
*copyc pft$df_delete_all_arch_entries
*copyc pft$df_delete_archive_entry
*copyc pft$df_delete_permit
*copyc pft$df_get_family_set
*copyc pft$df_get_info_in
*copyc pft$df_get_info_out
*copyc pft$df_get_mcat_info
*copyc pft$df_get_obj_info_in
*copyc pft$df_get_obj_info_out
*copyc pft$df_mark_release_candidate
*copyc pft$df_permit_in
*copyc pft$df_purge_catalog_in
*copyc pft$df_purge_in
*copyc pft$df_purge_out
*copyc pft$df_put_archive_entry
*copyc pft$df_put_archive_info
*copyc pft$df_put_cycle_info
*copyc pft$df_put_item_info_in
*copyc pft$df_put_item_info_out
*copyc pft$df_release_data
*copyc pft$df_replace_archive_entry
*copyc pft$df_replace_rem_media_fmd
*copyc pft$df_resolve
*copyc pft$df_return
*copyc pft$df_save_file_label_in
*copyc pft$df_save_label_out
*copyc pft$df_save_released_label_in
*copyc pft$df_validate_password
*copyc pft$exception_selection_info
*copyc pft$permit_level
*copyc pft$purge_cycle_options
*copyc pft$release_data_info
*copyc pft$relink_server_file
*copyc pft$save_label_audit_info
*copyc pft$served_family_locator
*copyc pft$unique_volume_list
*copyc pud$selection_criteria
*copyc rme$request_command_exceptions
*copyc rmt$volume_list
*copyc sft$counter
?? POP ??
?? EJECT ??
*copyc clp$convert_file_ref_to_string
*copyc dfp$complement_gfn
*copyc dfp$extract_client_job_id
*copyc dfp$fetch_served_family_entry
*copyc dfp$fetch_served_family_info
*copyc dfp$receive_server_rpc_segment
*copyc dfp$send_remote_procedure_call
*copyc dfp$set_invalid_family_index
*copyc dfp$uncomplement_gfn
*copyc dfv$file_server_debug_enabled
*copyc dfv$file_server_info_enabled
*copyc dfv$job_recovery_enabled
*copyc dfv$use_server_io
*copyc dmp$create_client_sft
*copyc dmp$create_tape_file_sfid
*copyc dmp$detach_server_file
*copyc dmp$fixup_client_file_length
*copyc dmp$replace_client_sft
*copyc dmp$set_file_state
*copyc dmv$null_sfid
*copyc fmp$attach_file
*copyc fmp$change_recorded_cycle_num
*copyc fmp$change_recorded_file_name
*copyc fmp$get_path_table_cycle_info
*copyc fmp$locate_cd_via_path_handle
*copyc fmp$lock_path_table
*copyc fmp$process_pt_request
*copyc fmp$unlock_path_table
*copyc i#current_sequence_position
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$clear_job_signature_lock
*copyc osp$file_access_condition
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc pfp$check_device_availability
*copyc pfp$convert_pft$path_to_fs_path
*copyc pfp$convert_pft$path_to_fs_str
*copyc pfp$convert_pft$path_to_string
*copyc pfp$get_rem_media_req_info
*copyc pfp$get_rem_media_volume_list
*copyc pfp$log_error
*copyc pfp$pick_modes_for_open
*copyc pfp$process_unexpected_status
*copyc pfp$report_unexpected_status
*copyc pfv$space_character
*copyc pfv$write_usage
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_job_names
*copyc pmp$get_pseudo_mainframe_id
*copyc syp$decrement_server_file_count
*copyc syp$increment_server_file_count
*copyc syv$test_jr_job

?? TITLE := '  Global Declarations Declared by this module', EJECT ??

  CONST
    allowed_when_server_deactivated = TRUE,
    inhibit_path_table_lock = TRUE;

?? FMT (FORMAT := OFF) ??
  VAR
    null_server_file_output: [oss$job_paged_literal, READ] dft$server_file_output := [
          {bytes_per_allocation}      dmc$min_bytes_per_allocation,

{ Put eoi and file_limit high enough so that fetch_page_status won't object to a reference beyond file limit.

          {eoi_byte_address}          dfc$partially_rebuilt_fde_eoi,
          {file_limit}                dfc$partially_rebuilt_fde_eoi,
          {preset_value}              0,
          {remote_sfid}               [0, gfc$tr_null_residence, gfc$null_file_hash],
          {requested_transfer_size}   dmc$default_req_transfer_size,
          {shared_queue}              mmc$null_shared_queue,
          {total_allocated_length}    dfc$partially_rebuilt_fde_eoi];
?? FMT (FORMAT := ON) ??

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_app_rem_me_vsn', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_app_rem_me_vsn
    (    served_family_locator: pft$served_family_locator;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         volume_descriptor: rmt$volume_descriptor;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_app_rem_me_vsn;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      parameter_size: dft$send_parameter_size,
      queue_entry_location: dft$rpc_queue_entry_location;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_to_server_params, p_send_data,
          status);
    IF status.normal THEN
      build_app_rem_me_vsn_buffer (path, cycle_selector, volume_descriptor,
           p_send_to_server_params, parameter_size, status);
      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_app_rem_me_vsn, parameter_size,
              {send_data_size} 0, p_receive_from_server_params, p_receive_data, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_app_rem_me_vsn;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_attach', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_attach
    (    served_family_locator: pft$served_family_locator;
         lfn: amt$local_file_name;
         path: pft$path;
         attach_input: pft$df_attach_in;
     VAR cycle_number: pft$cycle_number;
     VAR device_class: rmt$device_class;
     VAR cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR global_file_name: dmt$global_file_name;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_attach;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      authority: pft$authority,
      client_job_id: dft$client_job_id,
      evaluated_file_reference: fst$evaluated_file_reference,
      local_status: ost$status,
      p_file_label: ^fmt$file_label,
      p_fmd: pft$p_fmd,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_removable_media_req_info: ^fmt$removable_media_req_info,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      p_volume_list: ^rmt$volume_list,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_data_size: dft$send_data_size,
      send_parameters_size: dft$send_parameter_size,
      server_file_output: pft$server_file_output,
      volume_count: 0 .. amc$max_vol_number;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_parameters, p_send_data, status);

    IF status.normal THEN
      dfp$extract_client_job_id (queue_entry_location, client_job_id);
      build_attach_send_buffer (attach_input, path, p_send_parameters, p_send_data, send_parameters_size,
            send_data_size);
      dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_attach, send_parameters_size,
            send_data_size, p_receive_parameters, p_receive_data, status);

      IF status.normal THEN
        parse_attach_receive_buffers (p_receive_parameters, p_receive_data, authority, cycle_number,
              device_class, cycle_damage_symptoms, global_file_name, server_file_output, p_file_label,
              p_fmd, status);

        IF status.normal THEN
          IF (device_class = rmc$magnetic_tape_device) AND (p_fmd <> NIL) THEN
            PUSH p_removable_media_req_info;
            pfp$get_rem_media_req_info (p_fmd, p_removable_media_req_info, volume_count, status);

            IF status.normal THEN
              IF server_file_output.usage_selections * pfv$write_usage <> $pft$usage_selections [] THEN
                p_removable_media_req_info^.write_ring := rmc$write_ring;
              ELSE
                p_removable_media_req_info^.write_ring := rmc$no_write_ring;
              IFEND;

              PUSH p_volume_list: [1 .. volume_count];
              pfp$get_rem_media_volume_list (p_fmd, p_volume_list, status);
            IFEND;
          ELSE
            p_removable_media_req_info := NIL;
            p_volume_list := NIL;
          IFEND;

          pfp$convert_pft$path_to_fs_str (path, evaluated_file_reference);
          evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
          evaluated_file_reference.cycle_reference.cycle_number := server_file_output.cycle_number;
          create_client_file_tables (served_family_locator, client_job_id, lfn, evaluated_file_reference,
                attach_input.validation_ring, device_class, authority, server_file_output,
                {implicit_attach} FALSE, p_file_label, p_removable_media_req_info, p_volume_list, status);

          IF NOT status.normal THEN
            return_server_file (server_file_output.attached_pf_table_index, {file_modified} FALSE,
                  {eoi_byte_address} 0, server_file_output.dm_parameters.remote_sfid, device_class,
                  queue_entry_location, p_send_parameters, p_receive_parameters, local_status);
            pfp$process_unexpected_status (local_status);
          IFEND;
        ELSEIF status.condition = pfe$cycle_attached_on_client THEN
          check_local_attach (path, cycle_number, lfn, attach_input.validation_ring,
                attach_input.usage_selector, attach_input.share_selector, {called_by_attach} TRUE,
                {create_file} FALSE, status);
        IFEND;
      ELSE
        device_class := rmc$mass_storage_device;
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    ELSE
      device_class := rmc$mass_storage_device;
    IFEND;
  PROCEND pfp$r2_df_client_attach;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_attach_or_cref', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_attach_or_cref
    (    served_family_locator: pft$served_family_locator;
         validation_ring: ost$valid_ring;
         system_privilege: boolean;
         exception_selection_info: pft$exception_selection_info;
         p_attachment_options: {input} ^fst$attachment_options;
         p_file_label: {input} ^fmt$file_label;
         p_path_table_cycle_info: {input} ^fmt$path_table_cycle_info;
         fs_retention: {input} fst$retention;
         retrieve_option: pft$retrieve_option;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR action_attempted: pft$action_attempted;
     VAR action_taken: pft$attach_or_create_action;
     VAR authority: pft$authority;
     VAR allowed_access: fst$file_access_options;
     VAR selected_access: fst$file_access_options;
     VAR required_sharing: fst$file_access_options;
     VAR selected_sharing: fst$file_access_options;
     VAR device_class: rmt$device_class;
     VAR global_file_name: dmt$global_file_name;
     VAR label_used: boolean;
     VAR bytes_allocated: amt$file_byte_address;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_attach_or_cref;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??

    VAR
      client_job_id: dft$client_job_id,
      complemented_new_gfn: dmt$global_file_name,
      complemented_old_gfn: dmt$global_file_name,
      local_evaluated_file_reference: fst$evaluated_file_reference,
      local_p_file_label: ^fmt$file_label,
      local_p_path_table_cycle_info: ^fmt$path_table_cycle_info,
      local_reference_created: boolean,
      local_status: ost$status,
      new_client_sfid: gft$system_file_identifier,
      new_global_file_name: dmt$global_file_name,
      new_remote_sfid: gft$system_file_identifier,
      p_cycle_description: ^fmt$cycle_description,
      p_fmd: pft$p_fmd,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_removable_media_req_info: ^fmt$removable_media_req_info,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      p_server_file_output: ^pft$server_file_output,
      p_volume_list: ^rmt$volume_list,
      path_table_cycle_info: fmt$path_table_cycle_info,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_data_size: dft$send_data_size,
      send_parameters_size: dft$send_parameter_size,
      server_file_output: pft$server_file_output,
      volume_count: 0 .. amc$max_vol_number;

    local_reference_created := FALSE;
    local_p_path_table_cycle_info := p_path_table_cycle_info;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_parameters, p_send_data,
          status);

    IF status.normal THEN
      dfp$extract_client_job_id (queue_entry_location, client_job_id);

      IF (evaluated_file_reference.cycle_reference.specification = fsc$cycle_omitted) OR
            (evaluated_file_reference.cycle_reference.specification = fsc$high_cycle) OR
            (evaluated_file_reference.cycle_reference.specification = fsc$low_cycle) THEN
        local_evaluated_file_reference := evaluated_file_reference;
        local_reference_created := TRUE;
        fmp$get_path_table_cycle_info (inhibit_path_table_lock, local_evaluated_file_reference,
              path_table_cycle_info, status);
        IF status.normal AND path_table_cycle_info.path_registered THEN
          local_p_path_table_cycle_info := ^path_table_cycle_info;
        IFEND;
      IFEND;

      IF status.normal THEN
        REPEAT
          build_attach_or_cref_send_bufs (validation_ring, system_privilege, exception_selection_info,
                p_attachment_options, p_file_label, local_p_path_table_cycle_info, fs_retention,
                retrieve_option, site_archive_option, site_backup_option, site_release_option,
                evaluated_file_reference, p_send_parameters, p_send_data, send_parameters_size,
                send_data_size, status);

          IF status.normal THEN
            dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_attach_or_cref,
                  send_parameters_size, send_data_size, p_receive_parameters, p_receive_data, status);
          IFEND;

          IF status.normal THEN
            parse_attach_or_cref_receive (p_receive_parameters, p_receive_data, evaluated_file_reference,
                  action_attempted, action_taken, authority, allowed_access, selected_access,
                  required_sharing, selected_sharing, device_class, global_file_name, new_global_file_name,
                  new_remote_sfid, label_used, bytes_allocated, local_p_file_label, p_fmd, server_file_output,
                  status);

            IF status.normal THEN
              CASE action_taken OF
              = pfc$cycle_newly_attached, pfc$cycle_created =
                {
                { The file was attached or created on the server.
                {
                IF (device_class = rmc$magnetic_tape_device) AND (p_fmd <> NIL) THEN
                  PUSH p_removable_media_req_info;
                  pfp$get_rem_media_req_info (p_fmd, p_removable_media_req_info, volume_count, status);
                  IF status.normal THEN
                    IF (server_file_output.usage_selections * pfv$write_usage) <>
                          $pft$usage_selections [] THEN
                      p_removable_media_req_info^.write_ring := rmc$write_ring;
                    ELSE
                      p_removable_media_req_info^.write_ring := rmc$no_write_ring;
                    IFEND;
                    PUSH p_volume_list: [1 .. volume_count];
                    pfp$get_rem_media_volume_list (p_fmd, p_volume_list, status);
                  IFEND;
                ELSE
                  p_removable_media_req_info := NIL;
                  p_volume_list := NIL;
                IFEND;
                create_client_file_tables (served_family_locator, client_job_id,
                      {local_file_name} osc$null_name, evaluated_file_reference, validation_ring,
                      device_class, authority, server_file_output, {implicit_attach} TRUE, local_p_file_label,
                      p_removable_media_req_info, p_volume_list, status);

                IF NOT status.normal THEN
                  return_server_file (server_file_output.attached_pf_table_index, {file_modified} FALSE,
                        {eoi_byte_address} 0, server_file_output.dm_parameters.remote_sfid, device_class,
                        queue_entry_location, p_send_parameters, p_receive_parameters, local_status);
                  pfp$process_unexpected_status (local_status);
                IFEND;

              ELSE { The cycle is already attached in the job.
                IF new_remote_sfid <> dmv$null_sfid THEN
                  dfp$complement_gfn (global_file_name, complemented_old_gfn);
                  dfp$complement_gfn (new_global_file_name, complemented_new_gfn);
                  dmp$replace_client_sft (complemented_old_gfn, complemented_new_gfn, new_remote_sfid,
                        new_client_sfid, local_status);
                  IF local_status.normal THEN
                    IF local_reference_created THEN
                      fmp$locate_cd_via_path_handle (
                            local_evaluated_file_reference.path_handle_info.path_handle,
                            {lock_path_table} FALSE, p_cycle_description, local_status);
                    ELSE
                      fmp$locate_cd_via_path_handle (evaluated_file_reference.path_handle_info.path_handle,
                            {lock_path_table} FALSE, p_cycle_description, local_status);
                    IFEND;
                    IF local_status.normal THEN
                      p_cycle_description^.system_file_id := new_client_sfid;
                      global_file_name := new_global_file_name;
                    IFEND;
                  IFEND;
                IFEND;
                IF local_reference_created THEN
                  {
                  { Use the previously established file reference so that the
                  { path handle name has been established.
                  {
                  evaluated_file_reference := local_evaluated_file_reference;
                IFEND;
              CASEND;
            ELSEIF status.condition = pfe$recheck_client_mainframe THEN
              {
              { The local mainframe needs to recheck the path table with the
              { resolved cycle number from the catalog.
              {
              fmp$get_path_table_cycle_info (inhibit_path_table_lock, evaluated_file_reference,
                    path_table_cycle_info, local_status);
              IF local_status.normal THEN
                IF path_table_cycle_info.path_registered THEN
                  local_p_path_table_cycle_info := ^path_table_cycle_info;
                IFEND;
                RESET p_send_parameters;
                RESET p_send_data;
              ELSE
                status := local_status;
              IFEND;
            IFEND;
          ELSE
            device_class := rmc$mass_storage_device;
          IFEND;
        UNTIL (status.normal) OR (status.condition <> pfe$recheck_client_mainframe);
      ELSE
        device_class := rmc$mass_storage_device;
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    ELSE
      device_class := rmc$mass_storage_device;
    IFEND;
  PROCEND pfp$r2_df_client_attach_or_cref;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_change', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_change
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         system_privilege: boolean;
         change_list: pft$change_list;
     VAR cycle_number: pft$cycle_number;
     VAR device_class: rmt$device_class;
     VAR change_index: ost$non_negative_integers;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_change;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_data_size: dft$send_data_size,
      send_parameters_size: dft$send_parameter_size;

    change_index := 0;

    fmp$lock_path_table (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    validate_path_table_change (path, change_list, status);

    IF status.normal THEN
      dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
            NOT allowed_when_server_deactivated, queue_entry_location, p_send_parameters, p_send_data,
            status);

      IF status.normal THEN
        build_change_send_buffers (path, cycle_selector, password, system_privilege, change_list,
              p_send_parameters, p_send_data, send_parameters_size, send_data_size, status);

        IF status.normal THEN
          dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_change, send_parameters_size,
                send_data_size, p_receive_parameters, p_receive_data, status);
        IFEND;

        IF status.normal THEN
          parse_change_receive_buffer (p_receive_parameters, cycle_number, device_class, change_index,
                status);
        IFEND;

        dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;

      IF status.normal THEN
        change_path_table (path, cycle_number, change_list, change_index, status);
      IFEND;
    IFEND;

    fmp$unlock_path_table;
  PROCEND pfp$r2_df_client_change;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_change_cy_dam', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_change_cy_dam
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         new_damage_symptoms: fst$cycle_damage_symptoms;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_change_cy_dam;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      parameter_size: dft$send_parameter_size,
      queue_entry_location: dft$rpc_queue_entry_location;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_to_server_params, p_send_data,
          status);

    IF status.normal THEN
      build_change_cy_dam_send_buffer (path, cycle_selector, password, new_damage_symptoms,
            p_send_to_server_params, parameter_size, status);

      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_change_cy_dam,
              parameter_size, 0, p_receive_from_server_params, p_receive_data, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_change_cy_dam;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_change_cy_dt', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_change_cy_dt
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         new_access_date_time: pft$date_time;
         new_creation_date_time: pft$date_time;
         new_modification_date_time: pft$date_time;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_change_cy_dt;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      parameter_size: dft$send_parameter_size,
      queue_entry_location: dft$rpc_queue_entry_location;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_to_server_params, p_send_data,
          status);

    IF status.normal THEN
      build_change_cy_dt_send_buffer (path, cycle_selector, password, new_access_date_time,
            new_creation_date_time, new_modification_date_time, p_send_to_server_params,
            parameter_size, status);

      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_change_cy_dt,
              parameter_size, 0, p_receive_from_server_params, p_receive_data, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_change_cy_dt;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_change_file', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_change_file
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         system_privilege: boolean;
         file_changes: ^fst$file_changes;
     VAR cycle_number: pft$cycle_number;
     VAR device_class: rmt$device_class;
     VAR change_index: ost$non_negative_integers;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_change_file;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_data_size: dft$send_data_size,
      send_parameters_size: dft$send_parameter_size;

    change_index := 0;

    fmp$lock_path_table (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    validate_path_table_change_file (path, file_changes, status);

    IF status.normal THEN
      dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
            NOT allowed_when_server_deactivated, queue_entry_location, p_send_parameters, p_send_data,
            status);

      IF status.normal THEN
        build_change_file_send_buffers (path, cycle_selector, password, system_privilege, file_changes,
              p_send_parameters, p_send_data, send_parameters_size, send_data_size, status);

        IF status.normal THEN
          dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_change_file,
                send_parameters_size, send_data_size, p_receive_parameters, p_receive_data, status);
        IFEND;

        IF status.normal THEN
          parse_change_file_receive (p_receive_parameters, cycle_number, device_class, change_index,
                status);
        IFEND;

        dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;

      IF status.normal THEN
        change_file_path_table (path, cycle_number, file_changes, change_index, status);
      IFEND;
    IFEND;

    fmp$unlock_path_table;
  PROCEND pfp$r2_df_client_change_file;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_change_res_rel', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_change_res_rel
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_change_res_rel;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_parameter_size: dft$send_parameter_size;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_parameters, p_send_data,
          status);

    IF status.normal THEN
      build_change_res_rel_send_buf (path, cycle_selector, p_send_parameters, send_parameter_size,
            status);

      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_change_res_rel,
              send_parameter_size, {send_data_size} 0, p_receive_parameters, p_receive_data, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_change_res_rel;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_clear_cy_att', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_clear_cy_att
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_clear_cy_att;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      send_parameter_size: dft$send_parameter_size,
      queue_entry_location: dft$rpc_queue_entry_location;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_parameters, p_send_data,
          status);

    IF status.normal THEN
      build_clear_cy_att_send_buffer (path, cycle_selector, password, p_send_parameters, send_parameter_size,
            status);

      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_clear_cy_att,
              send_parameter_size, {send_data_size}0, p_receive_parameters, p_receive_data, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_clear_cy_att;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_define', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_define
    (    served_family_locator: pft$served_family_locator;
         lfn: amt$local_file_name;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         fs_retention: fst$retention;
         log: pft$log;
         retrieve_option: pft$retrieve_option;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
         system_privilege: boolean;
         validation_ring: ost$valid_ring;
         device_class: rmt$device_class;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
         p_removable_media_req_info: {input} ^fmt$removable_media_req_info;
         p_volume_list: {input} ^rmt$volume_list;
     VAR cycle_number: pft$cycle_number;
     VAR authority: pft$authority;
     VAR bytes_allocated: amt$file_byte_address;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_define;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      client_job_id: dft$client_job_id,
      evaluated_file_reference: fst$evaluated_file_reference,
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      purge_cycle_options: pft$purge_cycle_options,
      purge_cycle_selector: pft$cycle_selector,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_parameters_size: dft$send_parameter_size,
      server_file_output: pft$server_file_output;

    fmp$lock_path_table (status);

    IF status.normal THEN
      dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
            NOT allowed_when_server_deactivated, queue_entry_location, p_send_parameters, p_send_data,
            status);
      IF status.normal THEN
        dfp$extract_client_job_id (queue_entry_location, client_job_id);
        build_define_send_buffer (path, cycle_selector, password, fs_retention, log, retrieve_option,
              site_archive_option, site_backup_option, site_release_option, system_privilege,
              validation_ring, device_class, p_mass_storage_request_info, p_removable_media_req_info,
              p_volume_list, p_send_parameters, send_parameters_size, status);

        IF status.normal THEN
          dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_define, send_parameters_size,
                {send data size} 0, p_receive_parameters, p_receive_data, status);
        IFEND;
        IF status.normal THEN
          parse_define_receive_params (p_receive_parameters, authority, bytes_allocated, server_file_output);

          cycle_number := server_file_output.cycle_number;
          pfp$convert_pft$path_to_fs_str (path, evaluated_file_reference);
          evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
          evaluated_file_reference.cycle_reference.cycle_number := server_file_output.cycle_number;

          create_client_file_tables (served_family_locator, client_job_id, lfn, evaluated_file_reference,
                validation_ring, device_class, authority, server_file_output, {implicit_attach} FALSE,
                {p_file_label} NIL, p_removable_media_req_info, p_volume_list, status);
          IF NOT status.normal THEN
            {
            { Purge the file first, to assure we are purging the correct cycle.
            {
            purge_cycle_selector.cycle_option := pfc$specific_cycle;
            purge_cycle_selector.cycle_number := server_file_output.cycle_number;
            purge_cycle_options.preserve_cycle_entry := FALSE;
            purge_server_file (path, purge_cycle_selector, password, purge_cycle_options,
                  system_privilege, validation_ring, queue_entry_location, p_send_parameters, p_send_data,
                  p_receive_parameters, local_status);
            pfp$process_unexpected_status (local_status);

            return_server_file (server_file_output.attached_pf_table_index, {file_modified} FALSE,
                  {eoi_byte_address} 0, server_file_output.dm_parameters.remote_sfid, device_class,
                  queue_entry_location, p_send_parameters, p_receive_parameters, local_status);
            pfp$process_unexpected_status (local_status);
          IFEND;
        IFEND;

        dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;

      fmp$unlock_path_table;
    IFEND;

  PROCEND pfp$r2_df_client_define;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_define_catalog', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_define_catalog
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         charge_id: pft$charge_id;
         system_privilege: boolean;
         catalog_type_selected: boolean;
         selected_catalog_type: pft$catalog_types;
         p_mass_storage_request_info: ^fmt$mass_storage_request_info;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_define_catalog;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      parameter_size: dft$send_parameter_size,
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_to_server_params, p_send_data,
          status);
    IF status.normal THEN
      build_define_cat_send_buffer (path, charge_id, system_privilege, catalog_type_selected,
            selected_catalog_type, p_mass_storage_request_info, p_send_to_server_params,
            parameter_size, status);

      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_create_catalog, parameter_size,
              0, p_receive_from_server_params, p_receive_data, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

  PROCEND pfp$r2_df_client_define_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_define_data', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_define_data
    (    served_family_locator: pft$served_family_locator;
         lfn: amt$local_file_name;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         update_cycle_statistics: boolean;
         password_selector: pft$password_selector;
         validation_ring: ost$valid_ring;
         p_mass_storage_request_info: ^fmt$mass_storage_request_info;
         p_volume_list: ^array [1 .. * ] of rmt$recorded_vsn;
         purge_cycle_options: pft$purge_cycle_options;
         replace_cycle_data: boolean;
         restore_selections: put$restore_data_selections;
     VAR mandated_modification_time: {Input, Output} pft$mandated_modification_time;
     VAR data_residence: pft$data_residence;
     VAR authority: pft$authority;
     VAR bytes_allocated: amt$file_byte_address;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_define_data;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      client_job_id: dft$client_job_id,
      evaluated_file_reference: fst$evaluated_file_reference,
      local_status: ost$status,
      p_file_label: fmt$p_file_label,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      parameter_size: dft$send_parameter_size,
      purge_cycle_selector: pft$cycle_selector,
      queue_entry_location: dft$rpc_queue_entry_location,
      server_file_output: pft$server_file_output;

    fmp$lock_path_table (status);
    IF status.normal THEN

      dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
            NOT allowed_when_server_deactivated, queue_entry_location, p_send_to_server_params, p_send_data,
            status);
      IF status.normal THEN
        dfp$extract_client_job_id (queue_entry_location, client_job_id);
        build_define_data_send_buffer (lfn, path, cycle_selector, update_cycle_statistics, password_selector,
              validation_ring, p_mass_storage_request_info, p_volume_list, purge_cycle_options,
              replace_cycle_data, restore_selections, mandated_modification_time, p_send_to_server_params,
              parameter_size, status);

        IF status.normal THEN
          dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_define_data, parameter_size,
                0, p_receive_from_server_params, p_receive_data, status);
        IFEND;
        IF status.normal THEN
          parse_define_data_params (p_receive_from_server_params, p_receive_data, mandated_modification_time,
                data_residence, authority, bytes_allocated, server_file_output, p_file_label);

          pfp$convert_pft$path_to_fs_str (path, evaluated_file_reference);
          evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
          evaluated_file_reference.cycle_reference.cycle_number := server_file_output.cycle_number;
          create_client_file_tables (served_family_locator, client_job_id, lfn, evaluated_file_reference,
                validation_ring, {device_class} rmc$mass_storage_device, authority, server_file_output,
                {implicit_attach} FALSE, p_file_label, {p_removable_media_req_info} NIL, {p_volume_list} NIL,
                status);
          IF NOT status.normal THEN
            {
            { We have to write a routine to reset the FMD to NIL and call it here.
            {

            return_server_file (server_file_output.attached_pf_table_index, {file_modified} FALSE,
                  {eoi_byte_address} 0, server_file_output.dm_parameters.remote_sfid,
                  {device_class} rmc$mass_storage_device, queue_entry_location, p_send_to_server_params,
                  p_receive_from_server_params, local_status);
            pfp$process_unexpected_status (local_status);
          IFEND;
        IFEND;

        dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;

      fmp$unlock_path_table;
    IFEND;

  PROCEND pfp$r2_df_client_define_data;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_del_all_arc_en', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_del_all_arc_en
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_del_all_arc_en;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      parameter_size: dft$send_parameter_size,
      queue_entry_location: dft$rpc_queue_entry_location;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_to_server_params, p_send_data,
          status);
    IF status.normal THEN
      build_del_all_arch_ent_buffer (path, cycle_selector, p_send_to_server_params, parameter_size,
            status);
      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_del_all_arc_en, parameter_size,
              0, p_receive_from_server_params, p_receive_data, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

  PROCEND pfp$r2_df_client_del_all_arc_en;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_del_arch_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_del_arch_entry
    (    served_family_locator: pft$served_family_locator;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_del_arch_entry;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_send_data: dft$p_send_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_to_server_params: dft$p_send_parameters,
      parameter_size: dft$send_parameter_size,
      queue_entry_location: dft$rpc_queue_entry_location;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_to_server_params, p_send_data,
          status);
    IF status.normal THEN
      build_delete_arch_entry_buffer (path, cycle_selector, archive_identification, p_send_to_server_params,
           parameter_size, status);

      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_del_arch_entry, parameter_size,
              0, p_receive_from_server_params, p_receive_data, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

  PROCEND pfp$r2_df_client_del_arch_entry;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_delete_permit', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_delete_permit
    (    path: pft$path;
         object_type: pft$object_types,
         system_privilege: boolean;
         group: pft$group;
         served_family_locator: pft$served_family_locator;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_delete_permit;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      parameter_size: dft$send_parameter_size,
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_to_server_params, p_send_data,
          status);

    IF status.normal THEN
      build_delete_permit_send_buffer (path, object_type, system_privilege, group, p_send_to_server_params,
            parameter_size, status);

      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_delete_permit, parameter_size,
              0, p_receive_from_server_params, p_receive_data, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_delete_permit;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_get_family_set', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_get_family_set
    (    family_name: pft$name;
         served_family_locator: pft$served_family_locator;
     VAR set_name: stt$set_name;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_get_family_set;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_parameter_size: dft$send_parameter_size;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_parameters, p_send_data, status);

    IF status.normal THEN
      build_get_fam_set_send_buffer (family_name, p_send_parameters, send_parameter_size);
      dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_get_family_set,
            send_parameter_size, {send_data_size} 0, p_receive_parameters, p_receive_data, status);

      IF status.normal THEN
        parse_get_fam_set_receive_param (p_receive_parameters, set_name);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_get_family_set;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_get_famit_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_get_famit_info
    (    family_name: pft$name;
         catalog_info_selections: pft$catalog_info_selections;
         served_family_locator: pft$served_family_locator;
     VAR set_name: pft$name;
     VAR p_info: pft$p_info;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_get_famit_info;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_parameter_size: dft$send_parameter_size;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_parameters, p_send_data, status);

    IF status.normal THEN
      build_get_mcat_info_send_buffer (family_name, catalog_info_selections, p_send_parameters,
            send_parameter_size);
      dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_get_famit_info,
            send_parameter_size, {send_data_size} 0, p_receive_parameters, p_receive_data, status);

      IF status.normal THEN
        parse_get_famit_info_params (p_receive_parameters, p_receive_data, set_name, p_info, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_get_famit_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_get_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_get_info
    (    info_selection: pft$get_info_selection;
         path: pft$path;
         system_privilege: boolean;
         group: pft$group;
         catalog_info_selections: pft$catalog_info_selections;
         file_info_selections: pft$file_info_selections;
         served_family_locator: pft$served_family_locator;
     VAR p_info: pft$p_info;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_get_info;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      parameter_size: dft$send_parameter_size,
      local_status: ost$status,
      p_get_info_output: ^pft$df_get_info_out,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      p_server_info: ^pft$info,
      p_user_info: ^pft$info,
      queue_entry_location: dft$rpc_queue_entry_location;

    status.normal := TRUE;
    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_to_server_params, p_send_data,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

      build_get_info_send_buffer (info_selection, path, system_privilege, group, catalog_info_selections,
            file_info_selections, p_send_to_server_params, parameter_size, status);

    IF status.normal THEN
      dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_get_info, parameter_size, 0,
            p_receive_from_server_params, p_receive_data, status);
      IF status.normal THEN
        IF p_receive_data = NIL THEN
          NEXT p_get_info_output IN p_receive_from_server_params;
          dfp$receive_server_rpc_segment (queue_entry_location, {server_segment_offset} 0,
                p_get_info_output^.info_size, p_info, status);
          IF (NOT status.normal) AND (status.condition = dfe$info_full) THEN
            osp$set_status_condition (pfe$info_full, status);
          IFEND;
        ELSE
          NEXT p_user_info: [[REP #SIZE (p_receive_data^) OF cell]] IN p_info;
          IF p_user_info = NIL THEN
            osp$set_status_condition (pfe$info_full, status);
          ELSE
            NEXT p_server_info: [[REP #SIZE (p_receive_data^) OF cell]] IN p_receive_data;
            p_user_info^ := p_server_info^;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
  PROCEND pfp$r2_df_client_get_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_get_mcat_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_get_mcat_info
    (    family_name: pft$name;
         catalog_info_selections: pft$catalog_info_selections;
         served_family_locator: pft$served_family_locator;
     VAR p_info: pft$p_info;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_get_mcat_info;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      info_size: ost$segment_length,
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_parameter_size: dft$send_parameter_size;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_parameters, p_send_data, status);

    IF status.normal THEN
      build_get_mcat_info_send_buffer (family_name, catalog_info_selections, p_send_parameters,
            send_parameter_size);
      dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_get_mcat_info,
            send_parameter_size, {send_data_size} 0, p_receive_parameters, p_receive_data, status);

      IF status.normal THEN
        parse_get_mcat_receive_param (p_receive_parameters, info_size);
        dfp$receive_server_rpc_segment (queue_entry_location, {server_segment_offset} 0, info_size, p_info,
              status);
        IF (NOT status.normal) AND (status.condition = dfe$info_full) THEN
          osp$set_status_condition (pfe$info_full, status);
        IFEND;
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_get_mcat_info;

?? TITLE := '  [XDCL] pfp$r2_df_client_get_obj_info', EJECT ??

  PROCEDURE [XDCL] pfp$r2_df_client_get_obj_info
    (    served_family_locator: pft$served_family_locator;
         evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
         system_privilege: boolean;
         password_selector: pft$password_selector;
         subject_permit_count: ost$non_negative_integers;
         validation_ring: ost$valid_ring;
         p_validation_criteria: {i/o^} ^fst$goi_validation_criteria;
         p_object_info: {input} ^fst$goi_object_information;
     VAR object_info_offset: ost$segment_offset;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_get_obj_info;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_data_size: dft$send_data_size,
      send_parameter_size: dft$send_parameter_size;

    object_info_offset := 0;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_parameters, p_send_data, status);

    IF status.normal THEN
      build_get_obj_info_send_buffer (evaluated_file_reference, information_request, system_privilege,
            password_selector, subject_permit_count, validation_ring, p_validation_criteria,
            p_send_parameters, send_parameter_size, p_send_data, send_data_size, status);

      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_get_obj_info,
              send_parameter_size, send_data_size, p_receive_parameters, p_receive_data, status);
      IFEND;

      IF status.normal THEN
        parse_get_obj_info_receive_bufs (p_validation_criteria, p_object_info, queue_entry_location,
              p_receive_parameters, p_receive_data, object_info_offset, p_object_information,
              status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_get_obj_info;
?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_get_vol_cl', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_get_vol_cl
    (    served_family_locator: pft$served_family_locator;
         unique_volume_list: pft$unique_volume_list;
     VAR volume_condition_list: fst$volume_condition_list;
     VAR status: ost$status);

?? TITLE := '  build_get_vol_cond_send_buffer', EJECT ??

    PROCEDURE build_get_vol_cond_send_buffer
      (    unique_volume_list: pft$unique_volume_list;
       VAR p_send_to_server_params: dft$p_send_parameters;
       VAR parameter_size: dft$send_parameter_size);

      VAR
        p_number_of_volumes: ^amt$volume_number,
        p_unique_volume_list: ^pft$unique_volume_list;

      NEXT p_number_of_volumes IN p_send_to_server_params;
      p_number_of_volumes^ := UPPERBOUND (unique_volume_list) -
            LOWERBOUND (unique_volume_list) + 1;

      NEXT p_unique_volume_list: [1 .. p_number_of_volumes^] IN
            p_send_to_server_params;
      p_unique_volume_list^ := unique_volume_list;

      parameter_size := i#current_sequence_position (p_send_to_server_params);

    PROCEND build_get_vol_cond_send_buffer;
?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to
{ clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.
{ The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save,
            status, handler_status);
      EXIT pfp$r2_df_client_get_vol_cl;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
?? TITLE := '  parse_get_vol_cond_receive_param', EJECT ??

    PROCEDURE get_vol_cond_receive_param
      (VAR p_receive_from_server_params: dft$p_receive_parameters;
       VAR volume_condition_list: fst$volume_condition_list);

      VAR
        p_number_of_volumes: ^amt$volume_number,
        p_volume_condition_list: ^fst$volume_condition_list;

      NEXT p_number_of_volumes IN p_receive_from_server_params;

      NEXT p_volume_condition_list: [1 .. p_number_of_volumes^] IN
            p_receive_from_server_params;
      volume_condition_list := p_volume_condition_list^;

    PROCEND get_vol_cond_receive_param;
?? EJECT ??

    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_parameter_size: dft$send_parameter_size;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location,
          p_send_parameters, p_send_data, status);

    IF status.normal THEN
      build_get_vol_cond_send_buffer (unique_volume_list, p_send_parameters,
            send_parameter_size);
      dfp$send_remote_procedure_call (queue_entry_location,
            dfc$r2_df_server_get_vol_cond, send_parameter_size,
            {send_data_size} 0, p_receive_parameters, p_receive_data, status);

      IF status.normal THEN
        get_vol_cond_receive_param (p_receive_parameters,
              volume_condition_list);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_get_vol_cl;
?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_mark_rel_cand', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_mark_rel_cand
    (    served_family_locator: pft$served_family_locator;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         validation_ring: ost$valid_ring;
         archive_identification: pft$archive_identification;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_mark_rel_cand;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      parameter_size: dft$send_parameter_size,
      queue_entry_location: dft$rpc_queue_entry_location;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_to_server_params, p_send_data,
          status);
    IF status.normal THEN
      build_mark_rel_candidate_buffer (path, cycle_selector, password, validation_ring,
          archive_identification, p_send_to_server_params, parameter_size, status);
      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_mark_rel_cand, parameter_size,
              0, p_receive_from_server_params, p_receive_data, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

  PROCEND pfp$r2_df_client_mark_rel_cand;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_permit', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_permit
    (    path: pft$path;
         object_type: pft$object_types;
         system_privilege: boolean;
         permit_level: pft$permit_level;
         group: pft$group;
         permit_selections: pft$permit_selections;
         share_requirements: pft$share_requirements;
         application_info: pft$application_info;
         served_family_locator: pft$served_family_locator;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_permit;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_parameter_size: dft$send_parameter_size;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_parameters, p_send_data, status);

    IF status.normal THEN
      build_permit_send_buffer (path, object_type, system_privilege, permit_level, group, permit_selections,
            share_requirements, application_info, p_send_parameters, send_parameter_size, status);

      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_permit, send_parameter_size,
              {send_data_size} 0, p_receive_parameters, p_receive_data, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_permit;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_purge', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_purge
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         purge_cycle_options: pft$purge_cycle_options;
         system_privilege: boolean;
         validation_ring: ost$valid_ring;
     VAR authority: pft$authority;
     VAR device_class: rmt$device_class;
     VAR bytes_released: amt$file_byte_address;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_purge;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_parameters, p_send_data, status);

    IF status.normal THEN
      purge_server_file (path, cycle_selector, password, purge_cycle_options, system_privilege,
            validation_ring, queue_entry_location, p_send_parameters, p_send_data, p_receive_parameters,
            status);

      IF status.normal THEN
        parse_purge_receive_buffer (p_receive_parameters, authority, device_class, bytes_released, status);
      ELSE
        device_class := rmc$mass_storage_device;
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    ELSE
      device_class := rmc$mass_storage_device;
    IFEND;
  PROCEND pfp$r2_df_client_purge;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_purge_catalog', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_purge_catalog
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         system_privilege: boolean;
         delete_option: pft$delete_option;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_purge_catalog;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_data_size: dft$send_data_size,
      send_parameters_size: dft$send_parameter_size;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_parameters, p_send_data, status);

    IF status.normal THEN
      build_purge_catalog_send_buffer (path, system_privilege, delete_option, p_send_parameters, p_send_data,
            send_parameters_size, send_data_size);
      dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_delete_catalog,
            send_parameters_size, send_data_size, p_receive_parameters, p_receive_data, status);

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_purge_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_put_arch_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_put_arch_entry
    (    served_family_locator: pft$served_family_locator;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
         p_archive_array_entry: pft$p_archive_array_entry;
         p_amd: pft$p_amd;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_put_arch_entry;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      data_size: dft$send_data_size,
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      parameter_size: dft$send_parameter_size,
      queue_entry_location: dft$rpc_queue_entry_location;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_to_server_params, p_send_data,
          status);
    IF status.normal THEN
      build_put_archive_entry_buffer (path, cycle_selector, archive_identification, p_archive_array_entry,
           p_amd, p_send_to_server_params, p_send_data, parameter_size, data_size, status);
      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_put_arch_entry, parameter_size,
              data_size, p_receive_from_server_params, p_receive_data, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

  PROCEND pfp$r2_df_client_put_arch_entry;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_put_arch_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_put_arch_info
    (    served_family_locator: pft$served_family_locator;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         p_cycle_info_record: pft$p_info_record;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_put_arch_info;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      data_size: dft$send_data_size,
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      parameter_size: dft$send_parameter_size,
      queue_entry_location: dft$rpc_queue_entry_location;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_to_server_params, p_send_data,
          status);
    IF status.normal THEN
      build_put_archive_info_buffer (path, cycle_selector, p_cycle_info_record, p_send_to_server_params,
           p_send_data, parameter_size, data_size, status);
      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_put_arch_info, parameter_size,
              data_size, p_receive_from_server_params, p_receive_data, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

  PROCEND pfp$r2_df_client_put_arch_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_put_cycle_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_put_cycle_info
    (    served_family_locator: pft$served_family_locator;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         cycle_array_entry: pft$cycle_array_entry_version_2;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_put_cycle_info;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      parameter_size: dft$send_parameter_size,
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      purge_cycle_selector: pft$cycle_selector,
      queue_entry_location: dft$rpc_queue_entry_location;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_to_server_params, p_send_data,
          status);
    IF status.normal THEN
      build_put_cycle_info_buffer (path, cycle_selector, password_selector, cycle_array_entry,
            p_send_to_server_params, parameter_size, status);

      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_put_cycle_info, parameter_size,
              0, p_receive_from_server_params, p_receive_data, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

  PROCEND pfp$r2_df_client_put_cycle_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_put_item_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_put_item_info
    (    backup_file_version: pft$backup_file_version;
         p_info_record: {input} ^pft$info_record;
         served_family_locator: pft$served_family_locator;
         path: pft$path;
         permit_level: pft$permit_level;
         selection_criteria: put$selection_criteria;
         restore_archive_information: boolean;
     VAR audit_restorations: {i/o} boolean;
     VAR all_permits_restored: boolean;
     VAR p_auditable_permits: ^pft$auditable_permits;
     VAR p_auditable_cycles: ^pft$auditable_cycles;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_put_item_info;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_data_size: dft$send_data_size,
      send_parameters_size: dft$send_parameter_size;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_parameters, p_send_data, status);

    IF status.normal THEN
      build_put_item_info_send_bufs (backup_file_version, p_info_record, path, permit_level,
            selection_criteria, restore_archive_information, audit_restorations, p_auditable_permits,
            p_auditable_cycles, p_send_parameters, send_parameters_size, p_send_data, send_data_size, status);

      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_put_info, send_parameters_size,
              send_data_size, p_receive_parameters, p_receive_data, status);
      IFEND;

      IF status.normal THEN
        parse_put_item_info_receipts (p_receive_parameters, p_receive_data, audit_restorations,
              all_permits_restored, p_auditable_permits, p_auditable_cycles, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_put_item_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_release_data', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_release_data
    (    served_family_locator: pft$served_family_locator;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         p_release_data_info: {i/o} ^pft$release_data_info;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_release_data;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_rd_info: ^pft$release_data_info,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_parameter_size: dft$send_parameter_size;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_parameters, p_send_data, status);

    IF status.normal THEN
      build_release_data_buffer (path, cycle_selector, password, p_release_data_info, p_send_parameters,
            send_parameter_size, status);
      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_release_data,
              send_parameter_size, {send_data_size} 0, p_receive_parameters, p_receive_data, status);
      IFEND;

      IF status.normal AND (p_release_data_info <> NIL) THEN
        NEXT p_rd_info IN p_receive_parameters;
        p_release_data_info^ := p_rd_info^;
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_release_data;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_rep_arch_entry', EJECT ??

  PROCEDURE [XDCL, #gate] pfp$r2_df_client_rep_arch_entry
    (    served_family_locator: pft$served_family_locator;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
         p_archive_array_entry: pft$p_archive_array_entry;
         p_amd: pft$p_amd;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_rep_arch_entry;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      data_size: dft$send_data_size,
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      parameter_size: dft$send_parameter_size,
      queue_entry_location: dft$rpc_queue_entry_location;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_to_server_params, p_send_data,
          status);
    IF status.normal THEN
      build_rep_archive_entry_buffer (path, cycle_selector, archive_identification, p_archive_array_entry,
           p_amd, p_send_to_server_params, p_send_data, parameter_size, data_size, status);
      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_rep_arch_entry, parameter_size,
              data_size, p_receive_from_server_params, p_receive_data, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

  PROCEND pfp$r2_df_client_rep_arch_entry;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_rep_rem_me_fmd', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_rep_rem_me_fmd
    (    served_family_locator: pft$served_family_locator;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         p_file_media_descriptor: {input} ^SEQ ( * );
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_rep_rem_me_fmd;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      data_size: dft$send_data_size,
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      parameter_size: dft$send_parameter_size,
      queue_entry_location: dft$rpc_queue_entry_location;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_to_server_params, p_send_data,
          status);
    IF status.normal THEN
      build_rep_rem_me_fmd_buffer (path, cycle_selector, password_selector, p_file_media_descriptor,
            p_send_to_server_params, p_send_data, parameter_size, data_size, status);
      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_rep_rem_me_fmd, parameter_size,
              data_size, p_receive_from_server_params, p_receive_data, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_rep_rem_me_fmd;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_resolve', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_resolve
    (    path: pft$path;
         served_family_locator: pft$served_family_locator;
         system_privilege: boolean;
     VAR cycle_reference: {i/o} fst$cycle_reference;
     VAR path_resolution: fst$path_resolution;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_resolve;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      parameter_size: dft$send_parameter_size,
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_to_server_params, p_send_data,
          status);

    IF status.normal THEN
      build_resolve_send_buffer (path, system_privilege, cycle_reference, p_send_to_server_params,
            parameter_size, status);

      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_resolve, parameter_size, 0,
              p_receive_from_server_params, p_receive_data, status);
      IFEND;

      IF status.normal THEN
        parse_resolve_receive_params (p_receive_from_server_params, cycle_reference, path_resolution);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_resolve;

?? TITLE := '  [XDCL] pfp$r2_df_client_return', EJECT ??

  PROCEDURE [XDCL] pfp$r2_df_client_return
    (    apfid: pft$attached_permanent_file_id;
         client_sfid: gft$system_file_identifier;
         device_class: rmt$device_class;
         usage_selections: pft$usage_selections;
     VAR authority: pft$authority;
     VAR bytes_allocated_change: sft$counter;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_return;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      detach_status: ost$status,
      file_modified: boolean,
      flush_pages: boolean,
      eoi_byte_address: amt$file_byte_address,
      local_status: ost$status,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      server_location: dft$server_location,
      server_sfid: gft$system_file_identifier,
      sft_deleted: boolean,
      queue_entry_location: dft$rpc_queue_entry_location;

{ If the file has already been terminated as a result of a failed file server job recovery - detailed in the
{ procedure fmp$terminate_server_files - it has also already been detached to prevent a "dangling" FDE.
{ DO NOT DETACH IT AGAIN!  This will screw up the attach count.

    IF apfid.server_lifetime = 0 THEN
      RETURN;
    IFEND;

    IF device_class = rmc$mass_storage_device THEN
      flush_pages := (usage_selections <> $pft$usage_selections [ ]);
      pfp$check_device_availability (apfid, status);
      IF NOT status.normal THEN
        { Return on dfe$server_not_active to allow waiting at a higher ring
        IF (status.condition = dfe$server_has_terminated) OR
              (pfc$tjr_allow_return_await_rec IN syv$test_jr_job) THEN
          { Get rid of the system file table entry
            dmp$detach_server_file (client_sfid, flush_pages, {unconditional_detach=} FALSE, file_modified,
                  eoi_byte_address, server_sfid, detach_status);
        IFEND;
        IF (pfc$tjr_allow_return_await_rec IN syv$test_jr_job) THEN
          status.normal := TRUE;
        IFEND;
        RETURN;
      IFEND;
    IFEND;

    IF device_class = rmc$mass_storage_device THEN
      dmp$detach_server_file (client_sfid, flush_pages, {unconditional_detach=} FALSE,  file_modified,
            eoi_byte_address, server_sfid, detach_status);
      IF NOT detach_status.normal THEN
        IF osp$file_access_condition (detach_status) THEN
           { Allow waiting at a higher ring. System file table entry not deleted.
           RETURN;
         ELSEIF (detach_status.condition <> mme$io_write_error) THEN
          pfp$report_unexpected_status (detach_status);
        IFEND;
      IFEND;
      sft_deleted  := detach_status.normal;
    IFEND;

    server_location.server_location_selector := dfc$served_family_table_index;
    server_location.served_family_table_index := apfid.served_family_table_index;

    dfp$begin_ch_remote_proc_call (server_location, allowed_when_server_deactivated, queue_entry_location,
          p_send_to_server_params, p_send_data, status);
    IF status.normal THEN
      return_server_file (apfid.server_attached_pf_table_index, file_modified, eoi_byte_address, server_sfid,
            device_class, queue_entry_location, p_send_to_server_params, p_receive_from_server_params,
            status);
      IF status.normal THEN
        parse_return_receive_params (p_receive_from_server_params, authority, bytes_allocated_change);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    IF device_class = rmc$mass_storage_device THEN
      IF (status.normal) AND (NOT detach_status.normal) THEN
        status := detach_status;
      ELSEIF (NOT status.normal) AND NOT osp$file_access_condition (status) AND
            (status.condition <> mme$io_write_error) THEN
        pfp$report_unexpected_status (status);
      IFEND;

      IF (NOT status.normal) AND (osp$file_access_condition (status) OR
            (status.condition = dfe$server_request_terminated)) AND sft_deleted THEN
        { A timing window occurred such that the server became
        { unavailable (inactive, or awaiting recovery) after the sft entry
        { was deleted.  Tell bam everything is OK to allow the entry
        { to be removed from the cycle description.
        { Without the system file table entry there is no use in leaving
        { the file in the cycle description. In the awaiting_recovery case
        { the file will be detached on the server during server job recovery.
        status.normal := TRUE;
      IFEND;
    IFEND;

    IF status.normal THEN
      syp$decrement_server_file_count;
    IFEND;

  PROCEND pfp$r2_df_client_return;

?? TITLE := '  [XDCL] pfp$r2_df_client_save_label', EJECT ??

  PROCEDURE [XDCL] pfp$r2_df_client_save_label
    (    apfid: pft$attached_permanent_file_id;
         system_authority: pft$system_authority;
         required_permission: pft$permit_options;
         p_file_label: {input} ^fmt$file_label;
     VAR p_save_file_label_audit_seq: {i/o} ^SEQ ( * );
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_save_label;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      send_data_size: dft$send_data_size,
      send_parameters_size: dft$send_parameter_size,
      server_location: dft$server_location,
      queue_entry_location: dft$rpc_queue_entry_location;

    pfp$check_device_availability (apfid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server_location.server_location_selector := dfc$served_family_table_index;
    server_location.served_family_table_index := apfid.served_family_table_index;

    dfp$begin_ch_remote_proc_call (server_location, allowed_when_server_deactivated, queue_entry_location,
          p_send_parameters, p_send_data, status);

    IF status.normal THEN
      build_save_label_send_buffers (apfid.server_attached_pf_table_index, system_authority,
            required_permission, p_file_label, p_save_file_label_audit_seq, p_send_parameters, p_send_data,
            send_parameters_size, send_data_size, status);

      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_save_label,
              send_parameters_size, send_data_size, p_receive_parameters, p_receive_data, status);
      IFEND;

      IF status.normal THEN
        parse_save_label_receive_bufs (p_receive_parameters, p_receive_data, p_save_file_label_audit_seq,
              status);
      ELSE
        p_save_file_label_audit_seq := NIL;
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    ELSE
      p_save_file_label_audit_seq := NIL;
    IFEND;
  PROCEND pfp$r2_df_client_save_label;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_save_rel_label', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_save_rel_label
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         p_file_label: {input^} ^fmt$file_label;
         validation_ring: ost$valid_ring;
         update_cycle_statistics: boolean;
     VAR p_save_label_audit_info: {i/o} ^pft$save_label_audit_info;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_save_rel_label;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_parameters: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_parameters: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location,
      send_data_size: dft$send_data_size,
      send_parameters_size: dft$send_parameter_size;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_parameters, p_send_data, status);

    IF status.normal THEN
      build_save_rel_label_send_bufs (path, cycle_selector, password_selector, p_file_label, validation_ring,
            update_cycle_statistics, p_save_label_audit_info, p_send_parameters, p_send_data,
            send_parameters_size, send_data_size, status);

      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_save_rel_label,
              send_parameters_size, send_data_size, p_receive_parameters, p_receive_data, status);
      IFEND;

      IF status.normal THEN
        parse_save_rel_label_receipt (p_receive_parameters, p_save_label_audit_info, status);
      ELSE
        p_save_label_audit_info := NIL;
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    ELSE
      p_save_label_audit_info := NIL;
    IFEND;
  PROCEND pfp$r2_df_client_save_rel_label;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_client_validate_pw', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_client_validate_pw
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         password: pft$password;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$r2_df_client_validate_pw;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      parameter_size: dft$send_parameter_size,
      local_status: ost$status,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      queue_entry_location: dft$rpc_queue_entry_location;

    dfp$begin_ch_remote_proc_call (served_family_locator.server_location,
          NOT allowed_when_server_deactivated, queue_entry_location, p_send_to_server_params, p_send_data,
          status);

    IF status.normal THEN
      build_validate_pw_send_buffer (path, password, p_send_to_server_params, parameter_size, status);

      IF status.normal THEN
        dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_validate_pw, parameter_size, 0,
              p_receive_from_server_params, p_receive_data, status);
      IFEND;

      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$r2_df_client_validate_pw;

?? TITLE := '  [XDCL] pfp$reattach_server_file', EJECT ??

{    This procedure is executed on the client during the normal job recovery
{ process.  This is called before the server connection is active, and all that
{ is done is that a system_file_id is assigned and the system file table is
{ build, though largely unitialized.  As a result of this operation the segment
{ descriptor table extended entry should be marked to inhibit access to this
{ file.  The system file table entry will be completed as a result of the
{ pfp$relink_server_file process performed during server job recovery.
{
{    If server job recovery has been disabled or the server has been terminated
{ then access to the file will not be allowed.

  PROCEDURE [XDCL] pfp$reattach_server_file
    (    apfid: pft$attached_permanent_file_id;
         internal_cycle_name: pft$internal_name;
         client_mainframe_id: pmt$binary_mainframe_id;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
     VAR new_sfid: gft$system_file_identifier;
     VAR status: ost$status);

    VAR
     p_served_family_entry: ^dft$served_family_table_entry;

    IF NOT dfv$job_recovery_enabled THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$server_file_attached,
            'The job is using server files and recovery is disabled.', status);
      RETURN;
    IFEND;
    dfp$fetch_served_family_entry (apfid.served_family_table_index,
        p_served_family_entry, status);
    IF NOT status.normal THEN
     { invalid served family table index or nil .
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$server_file_attached,
            'The job is using server files and served family table not recovered.', status);
      RETURN;
    IFEND;
    IF (p_served_family_entry^.server_state = dfc$terminated) OR
       (p_served_family_entry^.server_state = dfc$deleted) THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$server_file_attached,
            'The job is using server files and server has been terminated.', status);
      RETURN;
    IFEND;
    dmp$create_client_sft (internal_cycle_name, usage_selections, share_selections,
          dmc$begin_job_recovery, null_server_file_output, apfid.served_family_table_index,
          p_served_family_entry^.server_mainframe_id, new_sfid, status);

  PROCEND pfp$reattach_server_file;

?? TITLE := '  [XDCL] pfp$relink_server_file', EJECT ??
*copy pfh$relink_server_file

  PROCEDURE [XDCL] pfp$relink_server_file
    (    old_apfid: pft$attached_permanent_file_id;
         internal_name: pft$internal_name;
         old_sfid: gft$system_file_identifier;
         device_class: rmt$device_class;
     VAR new_apfid: pft$attached_permanent_file_id;
     VAR new_sfid: gft$system_file_identifier;
     VAR status: ost$status);

?? NEWTITLE := 'dfp$remote_procedure_call_ch', EJECT ??

{ PURPOSE:
{   This procedure is a condition handler established to call a routine to clear the assignment of a task
{   services queue_entry if a task aborts with a queue_entry assigned to it.  The queue_entry must be clear
{   before the task can safely exit.

    PROCEDURE dfp$remote_procedure_call_ch
      (    condition: pmt$condition;
           cond_desc: ^pmt$condition_information;
           save: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      dfp$ch_cleanup;
      osp$set_status_from_condition (dfc$file_server_id, condition, save, status, handler_status);
      EXIT pfp$relink_server_file;

    PROCEND dfp$remote_procedure_call_ch;
*block
*copyc dfp$begin_ch_remote_proc_call
*copyc dfp$end_ch_remote_proc_call
*blockend
?? OLDTITLE, EJECT ??
    VAR
      local_status: ost$status,
      p_relink_file_in: ^pft$relink_server_file_inp,
      p_relink_file_out: ^pft$relink_server_file_outp,
      p_receive_data: dft$p_receive_data,
      p_receive_from_server_params: dft$p_receive_parameters,
      p_send_data: dft$p_send_data,
      p_send_to_server_params: dft$p_send_parameters,
      p_served_family_table_entry: ^dft$served_family_table_entry,
      server_location: dft$server_location,
      queue_entry_location: dft$rpc_queue_entry_location;

    status.normal := TRUE;
    { In an event of an unexpected error leave the file alone.
    new_apfid := old_apfid;
    new_sfid := old_sfid;
    dfp$fetch_served_family_entry (old_apfid.served_family_table_index, p_served_family_table_entry, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server_location.server_location_selector := dfc$served_family_table_index;
    server_location.served_family_table_index := old_apfid.served_family_table_index;
    dfp$begin_ch_remote_proc_call (server_location, allowed_when_server_deactivated, queue_entry_location,
          p_send_to_server_params, p_send_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT p_relink_file_in IN p_send_to_server_params;
    p_relink_file_in^.attached_pf_table_index := old_apfid.attached_pf_table_index;

    IF device_class = rmc$mass_storage_device THEN
      dfp$uncomplement_gfn (internal_name, p_relink_file_in^.global_file_name);
    ELSEIF device_class = rmc$magnetic_tape_device THEN
      p_relink_file_in^.global_file_name := internal_name;
    IFEND;

    dfp$send_remote_procedure_call (queue_entry_location, dfc$relink_server_file, #SIZE (p_relink_file_in^),
          0, p_receive_from_server_params, p_receive_data, status);
    IF status.normal THEN
      IF device_class = rmc$mass_storage_device THEN
        NEXT p_relink_file_out IN p_receive_from_server_params;
        dmp$create_client_sft (internal_name, p_relink_file_out^.usage_selections,
              p_relink_file_out^.share_selections, dmc$complete_job_recovery,
              p_relink_file_out^.dm_parameters, old_apfid.served_family_table_index,
              p_served_family_table_entry^.server_mainframe_id, new_sfid, status);
{       Release the queue entry prior to calling dmp$fixup_client_file_length
{       since it too makes a remote request.
        dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
        pfp$process_unexpected_status (local_status);
        IF status.normal THEN
          dmp$fixup_client_file_length (new_sfid, status);
          new_apfid.family_location := pfc$server_mainframe;
          new_apfid.server_attached_pf_table_index := old_apfid.attached_pf_table_index;
          new_apfid.served_family_table_index := old_apfid.served_family_table_index;
          new_apfid.server_lifetime := p_served_family_table_entry^.server_lifetime;
        IFEND;
      ELSEIF device_class = rmc$magnetic_tape_device THEN
        new_apfid.family_location := pfc$server_mainframe;
        new_apfid.server_attached_pf_table_index := old_apfid.attached_pf_table_index;
        new_apfid.served_family_table_index := old_apfid.served_family_table_index;
        new_apfid.server_lifetime := p_served_family_table_entry^.server_lifetime;
        dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;
    ELSE
      IF (device_class = rmc$mass_storage_device) AND ((status.condition <> dfe$server_not_active)
            AND (status.condition <> dfe$server_request_terminated)) THEN
        dmp$set_file_state (internal_name, dfc$terminated, local_status);
        { The file was not known on the server if pfe$invalid_apfid
      IFEND;
      dfp$end_ch_remote_proc_call (queue_entry_location, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND pfp$relink_server_file;

?? TITLE := '  build_attach_or_cref_send_bufs', EJECT ??

  PROCEDURE build_attach_or_cref_send_bufs
    (    validation_ring: ost$valid_ring;
         system_privilege: boolean;
         exception_selection_info: pft$exception_selection_info;
         p_attachment_options: {input} ^fst$attachment_options;
         p_file_label: {input} ^fmt$file_label;
         p_path_table_cycle_info: {input} ^fmt$path_table_cycle_info;
         fs_retention: {input} fst$retention;
         retrieve_option: pft$retrieve_option;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
         evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR p_send_parameters: {i^/o} dft$p_send_parameters;
     VAR p_send_data: {i^/o} dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_local_attachment_options: ^fst$attachment_options,
      p_local_file_label: ^fmt$file_label,
      p_local_path_table_cycle_info: ^fmt$path_table_cycle_info,
      p_attach_or_create_input: ^pft$df_attach_or_create_in;

    status.normal := TRUE;
    NEXT p_attach_or_create_input IN p_send_parameters;
    pmp$get_pseudo_mainframe_id (p_attach_or_create_input^.mainframe_id);

    p_attach_or_create_input^.validation_ring := validation_ring;
    p_attach_or_create_input^.system_privilege := system_privilege;
    p_attach_or_create_input^.exception_selection_info := exception_selection_info;
    p_attach_or_create_input^.evaluated_file_reference := evaluated_file_reference;
    p_attach_or_create_input^.fs_retention := fs_retention;
    p_attach_or_create_input^.retrieve_option := retrieve_option;
    p_attach_or_create_input^.site_archive_option := site_archive_option;
    p_attach_or_create_input^.site_backup_option := site_backup_option;
    p_attach_or_create_input^.site_release_option := site_release_option;

    IF p_attachment_options = NIL THEN
      p_attach_or_create_input^.number_of_attachment_options := 0;
    ELSE
      NEXT p_local_attachment_options: [1 .. UPPERBOUND (p_attachment_options^)] IN p_send_parameters;
      IF p_local_attachment_options = NIL THEN
        NEXT p_local_attachment_options: [1 .. UPPERBOUND (p_attachment_options^)] IN p_send_data;
        IF p_local_attachment_options = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                'NIL p_local_attachment_options in build_attach_or_cref_send_bufs', status);
          RETURN;
        IFEND;
      IFEND;

      p_local_attachment_options^ := p_attachment_options^;
      p_attach_or_create_input^.number_of_attachment_options := UPPERBOUND (p_attachment_options^);
    IFEND;

    IF p_file_label = NIL THEN
      p_attach_or_create_input^.file_label_size := 0;
    ELSE
      NEXT p_local_file_label: [[REP #SIZE (p_file_label^) OF cell]] IN p_send_parameters;
      IF p_local_file_label = NIL THEN
        NEXT p_local_file_label: [[REP #SIZE (p_file_label^) OF cell]] IN p_send_data;
        IF p_local_file_label = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                'NIL p_local_file_label in build_attach_or_cref_send_bufs', status);
          RETURN;
        IFEND;
      IFEND;

      p_local_file_label^ := p_file_label^;
      p_attach_or_create_input^.file_label_size := #SIZE (p_file_label^);
    IFEND;

    IF p_path_table_cycle_info = NIL THEN
      p_attach_or_create_input^.path_table_info_present := FALSE;
    ELSE
      NEXT p_local_path_table_cycle_info IN p_send_parameters;
      IF p_local_path_table_cycle_info = NIL THEN
        NEXT p_local_path_table_cycle_info IN p_send_data;
        IF p_local_path_table_cycle_info = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                'NIL p_local_path_table_cycle_info in build_attach_or_cref_send_bufs', status);
          RETURN;
        IFEND;
      IFEND;

      p_local_path_table_cycle_info^ := p_path_table_cycle_info^;
      p_attach_or_create_input^.path_table_info_present := TRUE;
    IFEND;

    send_parameters_size := i#current_sequence_position (p_send_parameters);
    send_data_size := i#current_sequence_position (p_send_data);
  PROCEND build_attach_or_cref_send_bufs;

?? TITLE := '  build_app_rem_me_vsn_buffer', EJECT ??

  PROCEDURE build_app_rem_me_vsn_buffer
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         volume_descriptor: rmt$volume_descriptor;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_local_file_media_descriptor: ^SEQ( * ),
      p_path: ^pft$path,
      p_send_parameters: ^pft$df_append_rem_me_vsn_inp;

    status.normal := TRUE;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.cycle_selector := cycle_selector;
    p_send_parameters^.volume_descriptor := volume_descriptor;
    p_send_parameters^.path_length := UPPERBOUND (path);

    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_app_rem_me_vsn_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_app_rem_me_vsn_buffer;

?? TITLE := '  build_attach_send_buffer', EJECT ??

  PROCEDURE build_attach_send_buffer
    (    attach_input: pft$df_attach_in;
         path: pft$path;
     VAR p_send_parameters: dft$p_send_parameters;
     VAR p_send_data: dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size);

    VAR
      p_attach_input: ^pft$df_attach_in,
      p_path: ^pft$path;

    NEXT p_attach_input IN p_send_parameters;
    p_attach_input^ := attach_input;

    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_parameters;
    IF p_path = NIL THEN
      NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_data;
    IFEND;
    p_path^ := path;

    send_parameters_size := i#current_sequence_position (p_send_parameters);
    send_data_size := i#current_sequence_position (p_send_data);
  PROCEND build_attach_send_buffer;

?? TITLE := '  build_change_cy_dam_send_buffer', EJECT ??

  PROCEDURE build_change_cy_dam_send_buffer
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: ost$name;
         new_damage_symptoms: fst$cycle_damage_symptoms;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_path: ^pft$path,
      p_send_parameters: ^pft$df_change_cy_dam_inp;

    status.normal := TRUE;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.cycle_selector := cycle_selector;
    p_send_parameters^.password := password;
    p_send_parameters^.new_damage_symptoms := new_damage_symptoms;
    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_change_cy_dam_send_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_change_cy_dam_send_buffer;

?? TITLE := '  build_change_cy_dt_send_buffer', EJECT ??

  PROCEDURE build_change_cy_dt_send_buffer
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: ost$name;
         new_access_date_time: pft$date_time;
         new_creation_date_time: pft$date_time;
         new_modification_date_time: pft$date_time;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_path: ^pft$path,
      p_send_parameters: ^pft$df_change_cy_dt_inp;

    status.normal := TRUE;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.cycle_selector := cycle_selector;
    p_send_parameters^.password := password;
    p_send_parameters^.new_access_date_time := new_access_date_time;
    p_send_parameters^.new_creation_date_time := new_creation_date_time;
    p_send_parameters^.new_modification_date_time := new_modification_date_time;
    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_change_cy_dt_send_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_change_cy_dt_send_buffer;

?? TITLE := '  build_change_res_rel_send_buf', EJECT ??

  PROCEDURE build_change_res_rel_send_buf
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR p_send_parameters: dft$p_send_parameters;
     VAR send_parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_path: ^pft$path,
      p_change_residence_input: ^pft$df_change_residence_in;

    status.normal := TRUE;
    NEXT p_change_residence_input IN p_send_parameters;
    p_change_residence_input^.cycle_selector := cycle_selector;
    p_change_residence_input^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_parameters;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_change_res_rel_send_buf', status);
      RETURN;
    IFEND;
    p_path^ := path;

    send_parameter_size := i#current_sequence_position (p_send_parameters);
  PROCEND build_change_res_rel_send_buf;

?? TITLE := '  build_change_send_buffers', EJECT ??

  PROCEDURE build_change_send_buffers
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: ost$name,
         system_privilege: boolean;
         change_list: pft$change_list;
     VAR p_send_parameters: {i^/o} dft$p_send_parameters;
     VAR p_send_data: {i^/o} dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_change_input: ^pft$df_change_in,
      p_change_list: ^pft$change_list,
      p_path: ^pft$path;

    status.normal := TRUE;
    NEXT p_change_input IN p_send_parameters;
    p_change_input^.cycle_selector := cycle_selector;
    p_change_input^.password := password;
    p_change_input^.system_privilege := system_privilege;

    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_parameters;
    IF p_path = NIL THEN
      NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_data;
    IFEND;
    p_path^ := path;
    p_change_input^.path_length := UPPERBOUND (path);

    NEXT p_change_list: [1 .. UPPERBOUND (change_list)] IN p_send_parameters;
    IF p_change_list = NIL THEN
      NEXT p_change_list: [1 .. UPPERBOUND (change_list)] IN p_send_data;
      IF p_change_list = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'NIL p_change_list in build_change_send_buffers', status);
        RETURN;
      IFEND;
    IFEND;
    p_change_list^ := change_list;
    p_change_input^.change_count := UPPERBOUND (change_list);

    send_parameters_size := i#current_sequence_position (p_send_parameters);
    send_data_size := i#current_sequence_position (p_send_data);
  PROCEND build_change_send_buffers;

?? TITLE := '  build_change_file_send_buffers', EJECT ??

  PROCEDURE build_change_file_send_buffers
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: ost$name,
         system_privilege: boolean;
         file_changes: ^fst$file_changes;
     VAR p_send_parameters: {i^/o} dft$p_send_parameters;
     VAR p_send_data: {i^/o} dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_change_file_input: ^pft$df_change_file_in,
      p_file_changes: ^fst$file_changes,
      p_path: ^pft$path;

    status.normal := TRUE;
    NEXT p_change_file_input IN p_send_parameters;
    p_change_file_input^.cycle_selector := cycle_selector;
    p_change_file_input^.password := password;
    p_change_file_input^.system_privilege := system_privilege;

    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_parameters;
    IF p_path = NIL THEN
      NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_data;
    IFEND;
    p_path^ := path;
    p_change_file_input^.path_length := UPPERBOUND (path);

    NEXT p_file_changes: [1 .. UPPERBOUND (file_changes^)] IN p_send_parameters;
    IF p_file_changes = NIL THEN
      NEXT p_file_changes: [1 .. UPPERBOUND (file_changes^)] IN p_send_data;
      IF p_file_changes = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'NIL p_file_changes in build_change_file_send_buffers', status);
        RETURN;
      IFEND;
    IFEND;
    p_file_changes^ := file_changes^;
    p_change_file_input^.change_file_count := UPPERBOUND (file_changes^);

    send_parameters_size := i#current_sequence_position (p_send_parameters);
    send_data_size := i#current_sequence_position (p_send_data);
  PROCEND build_change_file_send_buffers;

?? TITLE := '  build_clear_cy_att_send_buffer', EJECT ??

  PROCEDURE build_clear_cy_att_send_buffer
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: ost$name;
     VAR p_send_parameters: {i^/o} dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_path: ^pft$path,
      p_clear_cycle_attach_input: ^pft$df_clear_cy_att_in;

    status.normal := TRUE;
    NEXT p_clear_cycle_attach_input IN p_send_parameters;
    p_clear_cycle_attach_input^.cycle_selector := cycle_selector;
    p_clear_cycle_attach_input^.password := password;
    p_clear_cycle_attach_input^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_parameters;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_clear_cy_att_send_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    parameter_size := i#current_sequence_position (p_send_parameters);
  PROCEND build_clear_cy_att_send_buffer;

?? TITLE := '  build_define_send_buffer', EJECT ??

  PROCEDURE build_define_send_buffer
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         fs_retention: fst$retention;
         log: pft$log;
         retrieve_option: pft$retrieve_option;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
         system_privilege: boolean;
         validation_ring: ost$valid_ring;
         device_class: rmt$device_class;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
         p_removable_media_req_info: {input} ^fmt$removable_media_req_info;
         p_volume_list: {input} ^rmt$volume_list;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_ms_request: ^fmt$mass_storage_request_info,
      p_path: ^pft$path,
      p_rem_media_request: ^fmt$removable_media_req_info,
      p_send_parameters: ^pft$df_define_inp,
      p_volume_list_request: ^rmt$volume_list;

    status.normal := TRUE;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.cycle_selector := cycle_selector;
    p_send_parameters^.password := password;
    p_send_parameters^.fs_retention := fs_retention;
    p_send_parameters^.log := log;
    p_send_parameters^.retrieve_option := retrieve_option;
    p_send_parameters^.site_archive_option := site_archive_option;
    p_send_parameters^.site_backup_option := site_backup_option;
    p_send_parameters^.site_release_option := site_release_option;
    p_send_parameters^.device_class := device_class;
    pmp$get_pseudo_mainframe_id (p_send_parameters^.mainframe_id);

    p_send_parameters^.system_privilege := system_privilege;
    p_send_parameters^.validation_ring := validation_ring;
    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_define_send_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    p_send_parameters^.mass_storage_request_included := p_mass_storage_request_info <> NIL;
    IF p_mass_storage_request_info <> NIL THEN
      NEXT p_ms_request IN p_send_to_server_params;
      p_ms_request^ := p_mass_storage_request_info^;
    IFEND;

    p_send_parameters^.rem_media_request_included := p_removable_media_req_info <> NIL;
    IF p_removable_media_req_info <> NIL THEN
      NEXT p_rem_media_request IN p_send_to_server_params;
      p_rem_media_request^ := p_removable_media_req_info^;
    IFEND;

    p_send_parameters^.volume_list_included := p_volume_list <> NIL;
    IF p_volume_list <> NIL THEN
      NEXT p_volume_list_request: [1 .. UPPERBOUND (p_volume_list^)]  IN p_send_to_server_params;
      p_volume_list_request^ := p_volume_list^;
      p_send_parameters^.number_of_volumes := UPPERBOUND (p_volume_list^);
    ELSE
      p_send_parameters^.number_of_volumes := 0;
    IFEND;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_define_send_buffer;

?? TITLE := '  build_define_catalog_send_buffer', EJECT ??

  PROCEDURE build_define_cat_send_buffer
    (    path: pft$complete_path;
         charge_id: pft$charge_id;
         system_privilege: boolean;
         catalog_type_selected: boolean;
         selected_catalog_type: pft$catalog_types;
         p_mass_storage_request_info: ^fmt$mass_storage_request_info;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_catalog_type: ^pft$catalog_types,
      p_ms_request: ^fmt$mass_storage_request_info,
      p_path: ^pft$path,
      p_send_parameters: ^pft$df_define_catalog_inp;

    status.normal := TRUE;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.charge_id := charge_id;
    p_send_parameters^.system_privilege := system_privilege;
    p_send_parameters^.catalog_type_selected := catalog_type_selected;
    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_define_cat_send_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    IF catalog_type_selected THEN
      NEXT p_catalog_type IN p_send_to_server_params;
      p_catalog_type^ := selected_catalog_type;
    IFEND;

    p_send_parameters^.mass_storage_request_included := p_mass_storage_request_info <> NIL;
    IF p_mass_storage_request_info <> NIL THEN
      NEXT p_ms_request IN p_send_to_server_params;
      p_ms_request^ := p_mass_storage_request_info^;
    IFEND;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_define_cat_send_buffer;

?? TITLE := '  build_define_data_send_buffer', EJECT ??

  PROCEDURE build_define_data_send_buffer
    (    lfn: amt$local_file_name;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         update_cycle_statistics: boolean;
         password_selector: pft$password_selector;
         validation_ring: ost$valid_ring;
         p_mass_storage_request_info: ^fmt$mass_storage_request_info;
         p_volume_list: ^array [1 .. * ] of rmt$recorded_vsn;
         purge_cycle_options: pft$purge_cycle_options;
         replace_cycle_data: boolean;
         restore_selections: put$restore_data_selections;
         mandated_modification_time: pft$mandated_modification_time;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_ms_request: ^fmt$mass_storage_request_info,
      p_path: ^pft$path,
      p_send_parameters: ^pft$df_define_data_inp,
      p_local_volume_list: ^array [1 .. * ] of rmt$recorded_vsn;

    status.normal := TRUE;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.lfn := lfn;
    pmp$get_pseudo_mainframe_id (p_send_parameters^.mainframe_id);

    p_send_parameters^.cycle_selector := cycle_selector;
    p_send_parameters^.update_cycle_statistics := update_cycle_statistics;
    p_send_parameters^.password_selector := password_selector;
    p_send_parameters^.purge_cycle_options := purge_cycle_options;
    p_send_parameters^.replace_cycle_data := replace_cycle_data;
    p_send_parameters^.restore_selections := restore_selections;
    p_send_parameters^.mandated_modification_time := mandated_modification_time;
    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_define_data_send_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    p_send_parameters^.mass_storage_request_included := p_mass_storage_request_info <> NIL;
    IF p_mass_storage_request_info <> NIL THEN
      NEXT p_ms_request IN p_send_to_server_params;
      p_ms_request^ := p_mass_storage_request_info^;
    IFEND;

    p_send_parameters^.volume_list_length := 0;
    IF p_volume_list <> NIL THEN
      p_send_parameters^.volume_list_length := UPPERBOUND (p_volume_list^);
      NEXT p_local_volume_list: [1 .. UPPERBOUND (p_volume_list^)] IN p_send_to_server_params;
      p_local_volume_list^ := p_volume_list^;
    IFEND;

    p_send_parameters^.validation_ring := validation_ring;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_define_data_send_buffer;

?? TITLE := '  build_del_all_arch_ent_buffer', EJECT ??

  PROCEDURE build_del_all_arch_ent_buffer
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_path: ^pft$path,
      p_send_parameters: ^pft$df_delete_all_arch_ent_inp;

    status.normal := TRUE;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.cycle_selector := cycle_selector;
    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_del_all_arch_ent_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_del_all_arch_ent_buffer;

?? TITLE := '  build_delete_arch_entry_buffer', EJECT ??

  PROCEDURE build_delete_arch_entry_buffer
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_path: ^pft$path,
      p_send_parameters: ^pft$df_delete_archive_entry_inp;

    status.normal := TRUE;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.cycle_selector := cycle_selector;
    p_send_parameters^.archive_identification := archive_identification;
    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_delete_arch_entry_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_delete_arch_entry_buffer;

?? TITLE := '  build_delete_permit_send_buffer', EJECT ??

  PROCEDURE build_delete_permit_send_buffer
    (    path: pft$path;
         object_type: pft$object_types;
         system_privilege: boolean;
         group: pft$group;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_path: ^pft$path,
      p_send_parameters: ^pft$df_delete_permit_inp;

    status.normal := TRUE;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.object_type := object_type;
    p_send_parameters^.system_privilege := system_privilege;
    p_send_parameters^.group := group;
    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_delete_permit_send_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_delete_permit_send_buffer;

?? TITLE := '  build_get_fam_set_send_buffer', EJECT ??

  PROCEDURE build_get_fam_set_send_buffer
    (    family_name: pft$name;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size);

    VAR
      p_send_parameters: ^pft$df_get_family_set_inp;

    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.family_name := family_name;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_get_fam_set_send_buffer;

?? TITLE := '  build_get_info_send_buffer', EJECT ??

  PROCEDURE build_get_info_send_buffer
    (    info_selection: pft$get_info_selection;
         path: pft$path;
         system_privilege: boolean;
         group: pft$group;
         catalog_info_selections: pft$catalog_info_selections;
         file_info_selections: pft$file_info_selections;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_path: ^pft$path,
      p_send_parameters: ^pft$df_get_info_in;

    status.normal := TRUE;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.info_selection := info_selection;
    p_send_parameters^.system_privilege := system_privilege;
    p_send_parameters^.group := group;
    p_send_parameters^.catalog_info_selections := catalog_info_selections;
    p_send_parameters^.file_info_selections := file_info_selections;
    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_get_info_send_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_get_info_send_buffer;

?? TITLE := '  build_get_mcat_info_send_buffer', EJECT ??

  PROCEDURE build_get_mcat_info_send_buffer
    (    family_name: pft$name;
         catalog_info_selections: pft$catalog_info_selections;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size);

    VAR
      p_send_parameters: ^pft$df_get_mcat_info_inp;

    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.family_name := family_name;
    p_send_parameters^.catalog_info_selections := catalog_info_selections;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_get_mcat_info_send_buffer;

?? TITLE := '  build_get_obj_info_send_buffer', EJECT ??

  PROCEDURE build_get_obj_info_send_buffer
    (    evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
         system_privilege: boolean;
         password_selector: pft$password_selector;
         subject_permit_count: ost$non_negative_integers;
         validation_ring: ost$valid_ring;
         p_validation_criteria: {input} ^fst$goi_validation_criteria;
     VAR p_send_parameters: dft$p_send_parameters;
     VAR send_parameter_size: dft$send_parameter_size;
     VAR p_send_data: dft$p_send_data;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_get_object_info_input: ^pft$df_get_obj_info_in,
      p_local_validation_criteria: ^fst$goi_validation_criteria;

    status.normal := TRUE;
    NEXT p_get_object_info_input IN p_send_parameters;
    IF p_get_object_info_input = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_get_object_info_input', status);
    ELSE
      pmp$get_pseudo_mainframe_id (p_get_object_info_input^.binary_mainframe_id);
        p_get_object_info_input^.evaluated_file_reference := evaluated_file_reference;
        p_get_object_info_input^.information_request := information_request;
        p_get_object_info_input^.system_privilege := system_privilege;
        p_get_object_info_input^.password_selector := password_selector;
        p_get_object_info_input^.subject_permit_count := subject_permit_count;
        p_get_object_info_input^.validation_ring := validation_ring;

        IF p_validation_criteria = NIL THEN
          p_get_object_info_input^.validation_criterion_count := 0;
          send_data_size := 0;
        ELSE
          p_get_object_info_input^.validation_criterion_count := UPPERBOUND (p_validation_criteria^);
          NEXT p_local_validation_criteria: [1 .. UPPERBOUND (p_validation_criteria^)] IN p_send_data;
          IF p_local_validation_criteria = NIL THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                  'NIL p_local_validation_criteria in build_get_obj_info_send_buffer', status);
          ELSE
            p_local_validation_criteria^ := p_validation_criteria^;
            send_data_size := i#current_sequence_position (p_send_data);
          IFEND;
        IFEND;

        send_parameter_size := i#current_sequence_position (p_send_parameters);
    IFEND;
  PROCEND build_get_obj_info_send_buffer;

?? TITLE := '  build_mark_rel_candidate_buffer', EJECT ??

  PROCEDURE build_mark_rel_candidate_buffer
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         validation_ring: ost$valid_ring;
         archive_identification: pft$archive_identification;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_path: ^pft$path,
      p_send_parameters: ^pft$df_mark_rel_candidate_inp;

    status.normal := TRUE;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.cycle_selector := cycle_selector;
    p_send_parameters^.password := password;
    p_send_parameters^.validation_ring := validation_ring;
    p_send_parameters^.archive_identification := archive_identification;
    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_mark_rel_candidate_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_mark_rel_candidate_buffer;

?? TITLE := '  build_permit_send_buffer', EJECT ??

  PROCEDURE build_permit_send_buffer
    (    path: pft$path;
         object_type: pft$object_types;
         system_privilege: boolean;
         permit_level: pft$permit_level;
         group: pft$group;
         permit_selections: pft$permit_selections;
         share_requirements: pft$share_requirements;
         application_info: pft$application_info;
     VAR p_send_parameters: dft$p_send_parameters;
     VAR send_parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_path: ^pft$path,
      p_permit_input: ^pft$df_permit_in;

    status.normal := TRUE;
    NEXT p_permit_input IN p_send_parameters;
    IF p_permit_input = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_permit_input in build_permit_send_buffer', status);
      RETURN;
    ELSE
      p_permit_input^.path_length := UPPERBOUND (path);
      p_permit_input^.object_type := object_type;
      p_permit_input^.system_privilege := system_privilege;
      p_permit_input^.permit_level := permit_level;
      p_permit_input^.group := group;
      p_permit_input^.permit_selections := permit_selections;
      p_permit_input^.share_requirements := share_requirements;
      p_permit_input^.application_info := application_info;
    IFEND;

    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_parameters;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
           'NIL p_path in build_permit_send_buffer', status);
      RETURN;
    ELSE
      p_path^ := path;
    IFEND;

    send_parameter_size := i#current_sequence_position (p_send_parameters);
    status.normal := TRUE;
  PROCEND build_permit_send_buffer;

?? TITLE := '  build_purge_catalog_send_buffer', EJECT ??

  PROCEDURE build_purge_catalog_send_buffer
    (    path: pft$path;
         system_privilege: boolean;
         delete_option: pft$delete_option;
     VAR p_send_parameters: {i^/o} dft$p_send_parameters;
     VAR p_send_data: {i^/o} dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size);

    VAR
      p_path: ^pft$path,
      p_purge_catalog_input: ^pft$df_purge_catalog_in;

    NEXT p_purge_catalog_input IN p_send_parameters;
    p_purge_catalog_input^.system_privilege := system_privilege;
    p_purge_catalog_input^.delete_option := delete_option;

    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_parameters;
    IF p_path = NIL THEN
      NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_data;
      send_data_size := i#current_sequence_position (p_send_data);
    ELSE
      send_data_size := 0;
    IFEND;
    p_path^ := path;
    p_purge_catalog_input^.path_length := UPPERBOUND (path);

    send_parameters_size := i#current_sequence_position (p_send_parameters);
  PROCEND build_purge_catalog_send_buffer;

?? TITLE := '  build_purge_send_buffers', EJECT ??

  PROCEDURE build_purge_send_buffers
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         purge_cycle_options: pft$purge_cycle_options;
         system_privilege: boolean;
         validation_ring: ost$valid_ring;
     VAR p_send_parameters: dft$p_send_parameters;
     VAR p_send_data: dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size);

    VAR
      p_path: ^pft$path,
      p_purge_input: ^pft$df_purge_in;

    RESET p_send_parameters;
    NEXT p_purge_input IN p_send_parameters;
    p_purge_input^.cycle_selector := cycle_selector;
    p_purge_input^.password := password;
    p_purge_input^.purge_cycle_options := purge_cycle_options;
    p_purge_input^.system_privilege := system_privilege;
    p_purge_input^.validation_ring := validation_ring;
    p_purge_input^.path_length := UPPERBOUND (path);

    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_parameters;
    IF p_path = NIL THEN
      RESET p_send_data;
      NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_data;
      send_data_size := i#current_sequence_position (p_send_data);
    ELSE
      send_data_size := 0;
    IFEND;
    p_path^ := path;

    send_parameters_size := i#current_sequence_position (p_send_parameters);
  PROCEND build_purge_send_buffers;

?? TITLE := '  build_put_archive_entry_buffer', EJECT ??

  PROCEDURE build_put_archive_entry_buffer
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
         p_archive_array_entry: pft$p_archive_array_entry;
         p_amd: pft$p_amd;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR p_send_to_server_data: dft$p_send_data;
     VAR parameter_size: dft$send_parameter_size;
     VAR data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_local_amd: pft$p_amd,
      p_path: ^pft$path,
      p_send_parameters: ^pft$df_put_archive_entry_inp;

    status.normal := TRUE;
    data_size := 0;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.cycle_selector := cycle_selector;
    p_send_parameters^.archive_identification := archive_identification;
    p_send_parameters^.archive_array_entry := p_archive_array_entry^;
    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_put_archive_entry_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    IF p_amd = NIL THEN
      p_send_parameters^.amd_size := 0;
    ELSE
      p_send_parameters^.amd_size := #SIZE (p_amd^);
      NEXT p_local_amd: [[REP #SIZE (p_amd^) of cell]] IN p_send_to_server_params;
      IF p_local_amd = NIL THEN
        NEXT p_local_amd: [[REP #SIZE (p_amd^) of cell]] IN p_send_to_server_data;
        IF p_local_amd = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                'NIL p_local_amd in build_put_archive_entry_buffer', status);
          RETURN;
        ELSE
          p_local_amd^ := p_amd^;
          data_size := i#current_sequence_position (p_send_to_server_data);
        IFEND;
      ELSE
        p_local_amd^ := p_amd^;
      IFEND;
    IFEND;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_put_archive_entry_buffer;

?? TITLE := '  build_put_archive_info_buffer', EJECT ??

  PROCEDURE build_put_archive_info_buffer
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         p_cycle_info_record: pft$p_info_record;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR p_send_to_server_data: dft$p_send_data;
     VAR parameter_size: dft$send_parameter_size;
     VAR data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_local_info_record: pft$p_info_record,
      p_path: ^pft$path,
      p_send_parameters: ^pft$df_put_archive_info_inp;

    status.normal := TRUE;
    data_size := 0;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.cycle_selector := cycle_selector;
    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_put_archive_info_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    IF p_cycle_info_record = NIL THEN
      p_send_parameters^.info_size := 0;
    ELSE
      p_send_parameters^.info_size := p_cycle_info_record^.body_size;
      NEXT p_local_info_record: [[REP p_cycle_info_record^.body_size OF cell]] IN p_send_to_server_params;
      IF p_local_info_record = NIL THEN
        NEXT p_local_info_record: [[REP p_cycle_info_record^.body_size OF cell]] IN p_send_to_server_data;
        IF p_local_info_record = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                'NIL p_local_info_record in build_put_archive_info_buffer', status);
          RETURN;
        ELSE
          p_local_info_record^ := p_cycle_info_record^;
          data_size := i#current_sequence_position (p_send_to_server_data);
        IFEND;
      ELSE
        p_local_info_record^ := p_cycle_info_record^;
      IFEND;
    IFEND;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_put_archive_info_buffer;

?? TITLE := '  build_put_cycle_info_buffer', EJECT ??

  PROCEDURE build_put_cycle_info_buffer
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         cycle_array_entry: pft$cycle_array_entry_version_2;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_path: ^pft$path,
      p_send_parameters: ^pft$df_put_cycle_info_inp;

    status.normal := TRUE;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.cycle_selector := cycle_selector;
    p_send_parameters^.password_selector := password_selector;
    p_send_parameters^.cycle_array_entry := cycle_array_entry;
    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_put_cycle_info_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_put_cycle_info_buffer;

?? TITLE := '  build_put_item_info_send_bufs', EJECT ??

  PROCEDURE build_put_item_info_send_bufs
    (    backup_file_version: pft$backup_file_version;
         p_info_record: {input} pft$p_info_record;
         path: pft$complete_path;
         permit_level: pft$permit_level;
         selection_criteria: put$selection_criteria;
         restore_archive_information: boolean;
         audit_restorations: boolean;
         p_auditable_permits: {input} ^pft$auditable_permits;
         p_auditable_cycles: {input} ^pft$auditable_cycles;
     VAR p_send_parameters: dft$p_send_parameters;
     VAR send_parameter_size: dft$send_parameter_size;
     VAR p_send_data: dft$p_send_data;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_local_info_record: ^pft$info_record,
      p_path: ^pft$path,
      p_put_item_info_input: ^pft$df_put_item_info_in;

    status.normal := TRUE;
    NEXT p_put_item_info_input IN p_send_parameters;

    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_parameters;
    IF p_path = NIL THEN
      NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_data;
    IFEND;
    p_path^ := path;
    p_put_item_info_input^.path_length := UPPERBOUND (path);

    IF p_info_record = NIL THEN
      p_put_item_info_input^.info_size := 0;
    ELSE
      p_put_item_info_input^.backup_file_version := backup_file_version;
      p_put_item_info_input^.info_size := p_info_record^.body_size;
      p_put_item_info_input^.permit_level := permit_level;
      p_put_item_info_input^.selection_criteria := selection_criteria;
      p_put_item_info_input^.restore_archive_information := restore_archive_information;
      p_put_item_info_input^.audit_restorations := audit_restorations;

      NEXT p_local_info_record: [[REP p_info_record^.body_size OF cell]] IN p_send_parameters;
      IF p_local_info_record = NIL THEN
        NEXT p_local_info_record: [[REP p_info_record^.body_size OF cell]] IN p_send_data;
        IF p_local_info_record = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                'NIL p_local_info_record in build_put_item_info_send_bufs', status);
          RETURN;
        IFEND;
      IFEND;
      p_local_info_record^ := p_info_record^;
    IFEND;

    IF p_auditable_permits = NIL THEN
      p_put_item_info_input^.permit_count := 0;
    ELSE
      p_put_item_info_input^.permit_count := UPPERBOUND (p_auditable_permits^);
    IFEND;

    IF p_auditable_cycles = NIL THEN
      p_put_item_info_input^.cycle_count := 0;
    ELSE
      p_put_item_info_input^.cycle_count := UPPERBOUND (p_auditable_cycles^);
    IFEND;

    send_parameter_size := i#current_sequence_position (p_send_parameters);
    send_data_size := i#current_sequence_position (p_send_data);
  PROCEND build_put_item_info_send_bufs;

?? TITLE := '  build_release_data_buffer', EJECT ??

  PROCEDURE build_release_data_buffer
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         p_release_data_info: {input} ^pft$release_data_info;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_path: ^pft$path,
      p_rd_info: ^pft$release_data_info,
      p_send_parameters: ^pft$df_release_data_inp;

    status.normal := TRUE;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.cycle_selector := cycle_selector;
    p_send_parameters^.password := password;

    p_send_parameters^.release_data_info_included := p_release_data_info <> NIL;
    IF p_release_data_info <> NIL THEN
      NEXT p_rd_info IN p_send_to_server_params;
      p_rd_info^ := p_release_data_info^;
    IFEND;

    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_release_data_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_release_data_buffer;

?? TITLE := '  build_rep_archive_entry_buffer', EJECT ??

  PROCEDURE build_rep_archive_entry_buffer
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
         p_archive_array_entry: pft$p_archive_array_entry;
         p_amd: pft$p_amd;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR p_send_to_server_data: dft$p_send_data;
     VAR parameter_size: dft$send_parameter_size;
     VAR data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_local_amd: pft$p_amd,
      p_path: ^pft$path,
      p_send_parameters: ^pft$df_replace_arch_entry_inp;

    status.normal := TRUE;
    data_size := 0;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.cycle_selector := cycle_selector;
    p_send_parameters^.archive_identification := archive_identification;
    p_send_parameters^.archive_array_entry := p_archive_array_entry^;
    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_rep_archive_entry_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    IF p_amd = NIL THEN
      p_send_parameters^.amd_size := 0;
    ELSE
      p_send_parameters^.amd_size := #SIZE (p_amd^);
      NEXT p_local_amd: [[REP #SIZE (p_amd^) of cell]] IN p_send_to_server_params;
      IF p_local_amd = NIL THEN
        NEXT p_local_amd: [[REP #SIZE (p_amd^) of cell]] IN p_send_to_server_data;
        IF p_local_amd = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                'NIL p_local_amd in build_rep_archive_entry_buffer', status);
          RETURN;
        ELSE
          p_local_amd^ := p_amd^;
          data_size := i#current_sequence_position (p_send_to_server_data);
        IFEND;
      ELSE
        p_local_amd^ := p_amd^;
      IFEND;
    IFEND;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_rep_archive_entry_buffer;

?? TITLE := '  build_rep_rem_me_fmd_buffer', EJECT ??

  PROCEDURE build_rep_rem_me_fmd_buffer
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         p_file_media_descriptor: ^SEQ ( * );
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR p_send_to_server_data: dft$p_send_data;
     VAR parameter_size: dft$send_parameter_size;
     VAR data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_local_file_media_descriptor: ^SEQ( * ),
      p_path: ^pft$path,
      p_send_parameters: ^pft$df_replace_rem_me_fmd_inp;

    status.normal := TRUE;
    data_size := 0;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.cycle_selector := cycle_selector;
    p_send_parameters^.password_selector := password_selector;
    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_rep_rem_me_fmd_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    IF p_file_media_descriptor = NIL THEN
      p_send_parameters^.file_media_descriptor_size := 0;
    ELSE
      p_send_parameters^.file_media_descriptor_size := #SIZE (p_file_media_descriptor^);
      NEXT p_local_file_media_descriptor: [[REP #SIZE (p_file_media_descriptor^) of cell]]
            IN p_send_to_server_params;
      IF p_local_file_media_descriptor = NIL THEN
        NEXT p_local_file_media_descriptor: [[REP #SIZE (p_file_media_descriptor^) of cell]]
              IN p_send_to_server_data;
        IF p_local_file_media_descriptor = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                'NIL p_local_file_media_descriptor in build_rep_rem_me_fmd_buffer', status);
          RETURN;
        ELSE
          p_local_file_media_descriptor^ := p_file_media_descriptor^;
          data_size := i#current_sequence_position (p_send_to_server_data);
        IFEND;
      ELSE
        p_local_file_media_descriptor^ := p_file_media_descriptor^;
      IFEND;
    IFEND;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_rep_rem_me_fmd_buffer;

?? TITLE := '  build_resolve_send_buffer', EJECT ??

  PROCEDURE build_resolve_send_buffer
    (    path: pft$path;
         system_privilege: boolean;
         cycle_reference: fst$cycle_reference;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_path: ^pft$path,
      p_send_parameters: ^pft$df_resolve_inp;

    status.normal := TRUE;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.system_privilege := system_privilege;
    p_send_parameters^.cycle_reference := cycle_reference;
    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_resolve_send_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_resolve_send_buffer;

?? TITLE := '  build_return_send_buffer', EJECT ??

  PROCEDURE build_return_send_buffer
    (    attached_pf_table_index: pft$attached_pf_table_index;
         file_modified: boolean;
         eoi_byte_address: amt$file_byte_address;
         server_sfid: gft$system_file_identifier;
         device_class: rmt$device_class;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size);

    VAR
      p_send_parameters: ^pft$df_return_inp;

    RESET p_send_to_server_params;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.attached_pf_table_index := attached_pf_table_index;
    pmp$get_pseudo_mainframe_id (p_send_parameters^.mainframe_id);
    p_send_parameters^.attached_for_write := file_modified;
    p_send_parameters^.eoi_byte_address :=  eoi_byte_address;
    p_send_parameters^.server_sfid := server_sfid;
    p_send_parameters^.device_class := device_class;
    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_return_send_buffer;

?? TITLE := '  build_save_label_send_buffers', EJECT ??

  PROCEDURE build_save_label_send_buffers
    (    attached_pf_table_index: pft$attached_pf_table_index;
         system_authority: pft$system_authority;
         required_permission: pft$permit_options;
         p_file_label: {input} ^fmt$file_label;
         p_save_file_label_audit_seq: {input} ^SEQ ( * );
     VAR p_send_parameters: {i^/o} dft$p_send_parameters;
     VAR p_send_data: {i^/o} dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_local_file_label: ^fmt$file_label,
      p_save_file_label_input: ^pft$df_save_file_label_in;

    status.normal := TRUE;
    NEXT p_save_file_label_input IN p_send_parameters;
    p_save_file_label_input^.attached_pf_table_index := attached_pf_table_index;
    p_save_file_label_input^.system_authority := system_authority;
    p_save_file_label_input^.required_permission := required_permission;
    p_save_file_label_input^.audit := p_save_file_label_audit_seq <> NIL;

    IF p_file_label = NIL THEN
      p_save_file_label_input^.file_label_size := 0;
    ELSE
      NEXT p_local_file_label: [[REP #SIZE (p_file_label^) OF cell]] IN p_send_parameters;
      IF p_local_file_label = NIL THEN
        NEXT p_local_file_label: [[REP #SIZE (p_file_label^) OF cell]] IN p_send_data;
        IF p_local_file_label = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                'NIL p_local_file_label in build_save_label_send_buffers', status);
          RETURN;
        IFEND;
      IFEND;

      p_local_file_label^ := p_file_label^;
      p_save_file_label_input^.file_label_size := #SIZE (p_file_label^);
    IFEND;

    send_parameters_size := i#current_sequence_position (p_send_parameters);
    send_data_size := i#current_sequence_position (p_send_data);
  PROCEND build_save_label_send_buffers;

?? TITLE := '  build_save_rel_label_send_bufs', EJECT ??

  PROCEDURE build_save_rel_label_send_bufs
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         p_file_label: {input^} ^fmt$file_label;
         validation_ring: ost$valid_ring;
         update_cycle_statistics: boolean;
         p_save_label_audit_info: {input} ^pft$save_label_audit_info;
     VAR p_send_parameters: {i^/o} dft$p_send_parameters;
     VAR p_send_data: {i^/o} dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_local_file_label: ^fmt$file_label,
      p_path: ^pft$path,
      p_save_released_label_input: ^pft$df_save_released_label_in;

    status.normal := TRUE;
    NEXT p_save_released_label_input IN p_send_parameters;
    p_save_released_label_input^.cycle_selector := cycle_selector;
    p_save_released_label_input^.password_selector := password_selector;
    p_save_released_label_input^.validation_ring := validation_ring;
    p_save_released_label_input^.update_cycle_statistics := update_cycle_statistics;
    p_save_released_label_input^.audit := p_save_label_audit_info <> NIL;

    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_parameters;
    IF p_path = NIL THEN
      NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_data;
    IFEND;
    p_path^ := path;
    p_save_released_label_input^.path_length := UPPERBOUND (path);

    NEXT p_local_file_label: [[REP #SIZE (p_file_label^) OF cell]] IN p_send_parameters;
    IF p_local_file_label = NIL THEN
      NEXT p_local_file_label: [[REP #SIZE (p_file_label^) OF cell]] IN p_send_data;
      IF p_local_file_label = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'NIL p_local_file_label in build_save_rel_label_send_bufs', status);
        RETURN;
      IFEND;
    IFEND;
    p_local_file_label^ := p_file_label^;
    p_save_released_label_input^.file_label_size := #SIZE (p_file_label^);

    send_parameters_size := i#current_sequence_position (p_send_parameters);
    send_data_size := i#current_sequence_position (p_send_data);
  PROCEND build_save_rel_label_send_bufs;

?? TITLE := '  build_validate_pw_send_buffer', EJECT ??

  PROCEDURE build_validate_pw_send_buffer
    (    path: pft$path;
         password: pft$password;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR parameter_size: dft$send_parameter_size;
     VAR status: ost$status);

    VAR
      p_path: ^pft$path,
      p_send_parameters: ^pft$df_validate_password_inp;

    status.normal := TRUE;
    NEXT p_send_parameters IN p_send_to_server_params;
    p_send_parameters^.password := password;
    p_send_parameters^.path_length := UPPERBOUND (path);
    NEXT p_path: [1 .. UPPERBOUND (path)] IN p_send_to_server_params;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_path in build_validate_pw_send_buffer', status);
      RETURN;
    IFEND;
    p_path^ := path;

    parameter_size := i#current_sequence_position (p_send_to_server_params);
  PROCEND build_validate_pw_send_buffer;

?? TITLE := '  change_file_path_table', EJECT ??
{ PURPOSE:
{   This procedure changes the file name or cycle number, associated with a
{   fsp$change_file request, in file management's path table.  This procedure is modeled
{   after process_change_file_list in pfm$r2_request_processor.

  PROCEDURE change_file_path_table
    (    path: pft$path;
         old_cycle_number: pft$cycle_number;
         file_changes: ^fst$file_changes;
         last_change_file_attempted: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      change_file_index: pft$array_index,
      cycle_reference: fst$cycle_reference,
      evaluated_file_reference: fst$evaluated_file_reference,
      found: boolean,
      new_cycle_entry: boolean,
      new_object_entry: boolean,
      new_name: fst$path_element,
      path_index: fst$path_index,
      space_index: 1 .. fsc$max_path_element_size + 1;

    status.normal := TRUE;
    new_object_entry := FALSE;
    new_cycle_entry := FALSE;

  /make_changes/
    FOR change_file_index := 1 TO last_change_file_attempted DO
      CASE file_changes^ [change_file_index].selector OF
      = fsc$pf_name_change =
        IF NOT new_cycle_entry THEN
          pfp$convert_pft$path_to_fs_str (path, evaluated_file_reference);
        IFEND;
        new_name.value := file_changes^ [change_file_index].pfn;
        #SCAN (pfv$space_character, file_changes^ [change_file_index].pfn, space_index, found);
        new_name.size := space_index - 1;
        fmp$change_recorded_file_name (evaluated_file_reference, new_name, status);
        IF status.normal THEN
          #SCAN (pfv$space_character, path [UPPERBOUND (path)], space_index, found);
          path_index := evaluated_file_reference.path_structure_size - space_index + 1;
          evaluated_file_reference.path_structure (path_index) := $CHAR (new_name.size);
          evaluated_file_reference.path_structure (path_index + 1, new_name.size) := new_name.value;
          evaluated_file_reference.path_structure_size := path_index + new_name.size;
        ELSE
          IF status.condition <> pfe$name_already_used THEN
            pfp$report_unexpected_status (status);
          IFEND;
          EXIT /make_changes/;
        IFEND;
        new_object_entry := TRUE;

      = fsc$cycle_number_change =
        IF NOT new_object_entry THEN
          pfp$convert_pft$path_to_fs_str (path, evaluated_file_reference);
        IFEND;
        evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
        evaluated_file_reference.cycle_reference.cycle_number := old_cycle_number;
        fmp$change_recorded_cycle_num (evaluated_file_reference,
              file_changes^ [change_file_index].cycle_number, status);
        IF status.normal THEN
          evaluated_file_reference.cycle_reference.cycle_number :=
                file_changes^ [change_file_index].cycle_number;
        ELSE
          IF status.condition <> pfe$duplicate_cycle THEN
            pfp$report_unexpected_status (status);
          IFEND;
          EXIT /make_changes/;
        IFEND;
        new_cycle_entry := TRUE;

      ELSE
        ;
      CASEND;
    FOREND /make_changes/;
  PROCEND change_file_path_table;

?? TITLE := '  change_path_table', EJECT ??
{ PURPOSE:
{   This procedure changes the file name or cycle number, associated with a
{   change request, in file management's path table.  This procedure is modeled
{   after process_change_list in pfm$r2_request_processor.

  PROCEDURE change_path_table
    (    path: pft$path;
         old_cycle_number: pft$cycle_number;
         change_list: pft$change_list;
         last_change_attempted: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      change_index: pft$array_index,
      cycle_reference: fst$cycle_reference,
      evaluated_file_reference: fst$evaluated_file_reference,
      found: boolean,
      new_cycle_entry: boolean,
      new_object_entry: boolean,
      new_name: fst$path_element,
      path_index: fst$path_index,
      space_index: 1 .. fsc$max_path_element_size + 1;

    status.normal := TRUE;
    new_object_entry := FALSE;
    new_cycle_entry := FALSE;

  /make_changes/
    FOR change_index := 1 TO last_change_attempted DO
      CASE change_list [change_index].change_type OF
      = pfc$pf_name_change =
        IF NOT new_cycle_entry THEN
          pfp$convert_pft$path_to_fs_str (path, evaluated_file_reference);
        IFEND;
        new_name.value := change_list [change_index].pfn;
        #SCAN (pfv$space_character, change_list [change_index].pfn, space_index, found);
        new_name.size := space_index - 1;
        fmp$change_recorded_file_name (evaluated_file_reference, new_name, status);
        IF status.normal THEN
          #SCAN (pfv$space_character, path [UPPERBOUND (path)], space_index, found);
          path_index := evaluated_file_reference.path_structure_size - space_index + 1;
          evaluated_file_reference.path_structure (path_index) := $CHAR (new_name.size);
          evaluated_file_reference.path_structure (path_index + 1, new_name.size) := new_name.value;
          evaluated_file_reference.path_structure_size := path_index + new_name.size;
        ELSE
          IF status.condition <> pfe$name_already_used THEN
            pfp$report_unexpected_status (status);
          IFEND;
          EXIT /make_changes/;
        IFEND;
        new_object_entry := TRUE;

      = pfc$cycle_number_change =
        IF NOT new_object_entry THEN
          pfp$convert_pft$path_to_fs_str (path, evaluated_file_reference);
        IFEND;
        evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
        evaluated_file_reference.cycle_reference.cycle_number := old_cycle_number;
        fmp$change_recorded_cycle_num (evaluated_file_reference, change_list [change_index].cycle_number,
              status);
        IF status.normal THEN
          evaluated_file_reference.cycle_reference.cycle_number := change_list [change_index].cycle_number;
        ELSE
          IF status.condition <> pfe$duplicate_cycle THEN
            pfp$report_unexpected_status (status);
          IFEND;
          EXIT /make_changes/;
        IFEND;
        new_cycle_entry := TRUE;

      ELSE
        ;
      CASEND;
    FOREND /make_changes/;
  PROCEND change_path_table;

?? TITLE := '  check_local_attach', EJECT ??

  PROCEDURE check_local_attach
    (    path: pft$path;
         cycle_number: pft$cycle_number;
         lfn: amt$local_file_name;
         validation_ring: ost$valid_ring;
         usage_selector: pft$usage_selector;
         share_selector: pft$share_selector;
         called_by_attach: boolean;
         create_file: boolean;
     VAR status: ost$status);

    VAR
      attachment_options: array [1 .. 1] of fst$attachment_option,
      cycle_formerly_opened_info: fmt$cycle_formerly_opened_info,
      device_class: rmt$device_class,
      evaluated_file_reference: fst$evaluated_file_reference,
      p_cycle_description: ^fmt$cycle_description,
      path_handle: fmt$path_handle,
      path_table_cycle_info: fmt$path_table_cycle_info,
      process_pt_results: bat$process_pt_results,
      process_pt_work_list: bat$process_pt_work_list,
      selected_access: fst$file_access_options,
      selected_sharing: fst$file_access_options;

    pfp$convert_pft$path_to_fs_str (path, evaluated_file_reference);
    evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
    evaluated_file_reference.cycle_reference.cycle_number := cycle_number;
    fmp$get_path_table_cycle_info ({inhibit_path_table_lock =} TRUE, evaluated_file_reference,
          path_table_cycle_info, status);

    IF status.normal THEN
      IF path_table_cycle_info.path_registered AND path_table_cycle_info.cycle_attachment_info.
            cycle_attached THEN

        attachment_options [1].selector := fsc$access_and_share_modes;
        IF usage_selector.option = pfc$default_usage_option THEN
          attachment_options [1].access_modes.selector := fsc$permitted_access_modes;
        ELSE
          attachment_options [1].access_modes.selector := fsc$specific_access_modes;
          #UNCHECKED_CONVERSION (usage_selector.usage_selections, attachment_options [1].access_modes.value);
        IFEND;

        IF share_selector.option = pfc$default_share_option THEN
          attachment_options [1].share_modes.selector := fsc$determine_from_access_modes;
        ELSE
          attachment_options [1].share_modes.selector := fsc$specific_share_modes;
          #UNCHECKED_CONVERSION (share_selector.share_selections, attachment_options [1].share_modes.value);
        IFEND;

        IF path_table_cycle_info.cycle_device_info.device_assigned THEN
          device_class := path_table_cycle_info.cycle_device_info.device_class;
          cycle_formerly_opened_info := path_table_cycle_info.cycle_device_info.cycle_formerly_opened_info;
        ELSE
          device_class := rmc$mass_storage_device;
          cycle_formerly_opened_info.cycle_previously_opened := FALSE;
        IFEND;

        IF status.normal THEN
          pfp$pick_modes_for_open (evaluated_file_reference, ^attachment_options,
                path_table_cycle_info.cycle_attachment_info.allowed_access,
                path_table_cycle_info.cycle_attachment_info.required_sharing,
                path_table_cycle_info.setfa_access_modes, device_class, cycle_formerly_opened_info,
                called_by_attach, create_file, validation_ring, selected_access, selected_sharing, status);
        IFEND;

        IF status.normal THEN
          process_pt_work_list := $bat$process_pt_work_list [bac$record_path, bac$resolve_path,
                bac$inhibit_locking_pt];
          fmp$process_pt_request (process_pt_work_list, lfn, evaluated_file_reference, p_cycle_description,
                process_pt_results, status);

        IFEND;
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              ' PF says it is attached, but not BAM', status);
      IFEND;
    IFEND;
  PROCEND check_local_attach;

?? TITLE := '  create_client_file_tables', EJECT ??

{   The purpose of this procedure is to interface with the device manager to
{ create a system file table entry, and then to interface with the local file
{ manager to associate the attached permanent file with a local file name
{ for the job, on the local mainframe.

  PROCEDURE create_client_file_tables
    (    family_locator: pft$served_family_locator;
         client_job_id: dft$client_job_id;
         lfn: amt$local_file_name;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
         validation_ring: ost$valid_ring;
         device_class: rmt$device_class;
         authority: pft$authority;
         server_file_output: pft$server_file_output;
         implicit_attach: boolean;
         p_file_label: fmt$p_file_label;
         p_removable_media_req_info: ^fmt$removable_media_req_info;
         p_volume_list: ^rmt$volume_list;
     VAR status: ost$status);

    CONST
      critical_message = TRUE,
      message_origin = pmc$msg_origin_system;

    VAR
      attached_pf_id: pft$attached_permanent_file_id,
      attached_for_write: boolean,
      bams_sfid: gft$system_file_identifier,
      client_sfid: gft$system_file_identifier,
      complemented_gfn: dmt$global_file_name,
      file_modified: boolean,
      file_space_limit_kind: sft$file_space_limit_kind,
      flush_pages: boolean,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      eoi: amt$file_byte_address,
      keypoint_operation: dft$keypoint_file_operation,
      keypoint_sfid: dft$keypoint_sfid,
      local_status: ost$status,
      pf_attachment_info: fmt$pf_attachment_info,
      server_sfid: gft$system_file_identifier;

    IF device_class = rmc$mass_storage_device THEN
    dfp$complement_gfn (server_file_output.global_file_name, complemented_gfn);
    dmp$create_client_sft (complemented_gfn, server_file_output.usage_selections,
          server_file_output.share_selections, dmc$attach_or_create, server_file_output.dm_parameters,
          family_locator.served_family_table_index, family_locator.server_mainframe_id, client_sfid, status);
    IF status.normal THEN
      {
      { Build attached pf id.
      {
      attached_pf_id.family_location := pfc$server_mainframe;
      attached_pf_id.server_attached_pf_table_index := server_file_output.attached_pf_table_index;
      attached_pf_id.served_family_table_index := family_locator.served_family_table_index;
      attached_pf_id.server_lifetime := dfv$served_family_table_root.p_family_list_pointer_array^
            [family_locator.served_family_table_index.pointers_index].p_served_family_list^
            [family_locator.served_family_table_index.family_list_index].server_lifetime;
      IF dfv$use_server_io THEN
        bams_sfid := client_sfid;
      ELSE
        {
        { Lie to bam to use the 'remote' sfid, so that io will be performed
        { directly to the 'remote' file.  This only works in a single
        { mainframe test scenario.
        {
        bams_sfid := server_file_output.dm_parameters.remote_sfid;
      IFEND;
      IF (pfc$master_catalog_owner IN authority.ownership) AND
            ((server_file_output.usage_selections * pfv$write_usage) <> $pft$usage_selections []) THEN
        file_space_limit_kind := sfc$perm_file_space_limit;
      ELSE
        file_space_limit_kind := sfc$no_limit;
      IFEND;
      pf_attachment_info.apfid := attached_pf_id;
      pf_attachment_info.application_info := server_file_output.application_info;
      pf_attachment_info.implicit_attach := implicit_attach;
      pf_attachment_info.password_protected := server_file_output.password_protected;
      fmp$attach_file (lfn, complemented_gfn, complemented_gfn, bams_sfid,
            server_file_output.usage_selections, server_file_output.share_selections, validation_ring,
            file_space_limit_kind, p_file_label, ^pf_attachment_info, device_class,
            {p_removable_media_req_info} NIL, {p_volume_list} NIL, evaluated_file_reference, status);
      IF status.normal THEN
        syp$increment_server_file_count;
        IF dfv$file_server_info_enabled THEN
          keypoint_operation.remote := TRUE;
          keypoint_operation.catalog := FALSE;
          keypoint_sfid.file_entry_index := client_sfid.file_entry_index;
          keypoint_sfid.residence := client_sfid.residence;
          #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_operation.keypoint_data, dfk$attach_info);
          #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_sfid.keypoint_data, dfk$sfid);
        IFEND;
      ELSE
        flush_pages := (server_file_output.usage_selections <> $pft$usage_selections [ ]);
        dmp$detach_server_file (client_sfid, flush_pages, {unconditional_detach=} FALSE, attached_for_write,
              eoi, server_sfid, local_status);
        pfp$process_unexpected_status (local_status);
        IF status.condition = ame$ring_validation_error THEN
          clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position =} FALSE, fs_path,
                fs_path_size, local_status);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_ring_access,
                fs_path (1, fs_path_size), status);
        ELSEIF (status.condition = pfe$lfn_in_use) THEN
        ELSEIF (status.condition = rme$redundant_device_assignment) OR
              (status.condition = rme$device_assignment_conflict) THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$lfn_in_use, lfn, status);
        ELSE
          clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} FALSE, fs_path,
                fs_path_size, local_status);
          pfp$report_unexpected_status (status);
          osp$append_status_parameter (osc$status_parameter_delimiter, fs_path (1, fs_path_size), status);
          pfp$log_error (status, -$pmt$ascii_logset [], message_origin, critical_message);
        IFEND;
      IFEND;
    ELSE
      clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position =} FALSE, fs_path,
            fs_path_size, local_status);
      pfp$report_unexpected_status (status);
      osp$append_status_parameter (osc$status_parameter_delimiter, fs_path (1, fs_path_size), status);
      pfp$log_error (status, -$pmt$ascii_logset [], message_origin, critical_message);
    IFEND;

    ELSEIF device_class = rmc$magnetic_tape_device THEN
      dmp$create_tape_file_sfid (p_removable_media_req_info, p_volume_list, client_sfid, status);
      IF status.normal THEN
          attached_pf_id.family_location := pfc$server_mainframe;
          attached_pf_id.server_attached_pf_table_index := server_file_output.attached_pf_table_index;
          attached_pf_id.served_family_table_index := family_locator.served_family_table_index;
          attached_pf_id.server_lifetime := dfv$served_family_table_root.p_family_list_pointer_array^
                [family_locator.served_family_table_index.pointers_index].p_served_family_list^
                [family_locator.served_family_table_index.family_list_index].server_lifetime;
          file_space_limit_kind := sfc$no_limit;
          pf_attachment_info.apfid := attached_pf_id;
          pf_attachment_info.application_info := server_file_output.application_info;
          pf_attachment_info.implicit_attach := implicit_attach;
          pf_attachment_info.password_protected := server_file_output.password_protected;
          fmp$attach_file (lfn, server_file_output.global_file_name, server_file_output.global_file_name,
                client_sfid, server_file_output.usage_selections, server_file_output.share_selections,
                validation_ring, file_space_limit_kind, p_file_label, ^pf_attachment_info, device_class,
                p_removable_media_req_info, p_volume_list, evaluated_file_reference, status);
          IF status.normal THEN
            syp$increment_server_file_count;
            IF dfv$file_server_info_enabled THEN
              keypoint_operation.remote := TRUE;
              keypoint_operation.catalog := FALSE;
              keypoint_sfid.file_entry_index := client_sfid.file_entry_index;
              keypoint_sfid.residence := client_sfid.residence;
              #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_operation.keypoint_data,
                    dfk$attach_info);
              #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_sfid.keypoint_data, dfk$sfid);
            IFEND;
          IFEND;
      IFEND;
    IFEND;
  PROCEND create_client_file_tables;

?? TITLE := '  parse_attach_or_cref_receive', EJECT ??

  PROCEDURE [XDCL] parse_attach_or_cref_receive
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR p_receive_data: {i/o} dft$p_receive_data;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR action_attempted: pft$action_attempted;
     VAR action_taken: pft$attach_or_create_action;
     VAR authority: pft$authority;
     VAR allowed_access: fst$file_access_options;
     VAR selected_access: fst$file_access_options;
     VAR required_sharing: fst$file_access_options;
     VAR selected_sharing: fst$file_access_options;
     VAR device_class: rmt$device_class;
     VAR global_file_name: dmt$global_file_name;
     VAR new_global_file_name: dmt$global_file_name;
     VAR new_remote_sfid: gft$system_file_identifier;
     VAR label_used: boolean;
     VAR bytes_allocated: amt$file_byte_address;
     VAR p_file_label: ^fmt$file_label;
     VAR p_fmd: pft$p_fmd;
     VAR server_file_output: pft$server_file_output;
     VAR status: ost$status);

    VAR
      p_attach_or_create_output: ^pft$df_attach_or_create_out,
      p_server_file_output: ^pft$server_file_output,
      p_status: ^ost$status;

    NEXT p_attach_or_create_output IN p_receive_parameters;
    action_attempted := p_attach_or_create_output^.action_attempted;
    action_taken := p_attach_or_create_output^.action_taken;
    selected_access := p_attach_or_create_output^.selected_access;
    device_class := p_attach_or_create_output^.device_class;

    IF p_attach_or_create_output^.status_included THEN
      NEXT p_status IN p_receive_parameters;
      status := p_status^;

      IF (status.condition = pfe$recheck_client_mainframe) OR
            (status.condition = pfe$cycle_data_resides_offline) OR
            (status.condition = fse$device_class_conflict) THEN
        evaluated_file_reference := p_attach_or_create_output^.evaluated_file_reference;
      ELSEIF status.condition = pfe$tape_attached_on_client THEN
        evaluated_file_reference := p_attach_or_create_output^.evaluated_file_reference;
        device_class := p_attach_or_create_output^.device_class;
        global_file_name := p_attach_or_create_output^.global_file_name;
      IFEND;
    ELSE
      evaluated_file_reference := p_attach_or_create_output^.evaluated_file_reference;
      authority := p_attach_or_create_output^.authority;
      allowed_access := p_attach_or_create_output^.allowed_access;
      required_sharing := p_attach_or_create_output^.required_sharing;
      label_used := p_attach_or_create_output^.label_used;
      bytes_allocated := p_attach_or_create_output^.bytes_allocated;
      device_class := p_attach_or_create_output^.device_class;
      global_file_name := p_attach_or_create_output^.global_file_name;
      new_global_file_name := p_attach_or_create_output^.new_global_file_name;
      new_remote_sfid := p_attach_or_create_output^.new_remote_sfid;
      status.normal := TRUE;

      IF (action_taken = pfc$cycle_created) OR (action_taken = pfc$cycle_newly_attached) THEN
        NEXT p_server_file_output IN p_receive_parameters;
        server_file_output := p_server_file_output^;

        IF server_file_output.label_length = 0 THEN
          p_file_label := NIL;
        ELSEIF p_receive_data = NIL THEN
          NEXT p_file_label: [[REP server_file_output.label_length OF cell]] IN p_receive_parameters;
        ELSE
          NEXT p_file_label: [[REP server_file_output.label_length OF cell]] IN p_receive_data;
        IFEND;

        IF p_server_file_output^.rem_media_fmd_length = 0 THEN
          p_fmd := NIL;
        ELSE
          NEXT p_fmd: [[REP p_server_file_output^.rem_media_fmd_length OF cell]] IN p_receive_data;
        IFEND;
      IFEND;
    IFEND;
  PROCEND parse_attach_or_cref_receive;

?? TITLE := '  parse_attach_receive_buffers', EJECT ??

  PROCEDURE parse_attach_receive_buffers
    (VAR p_receive_parameters: dft$p_receive_parameters;
     VAR p_receive_data: dft$p_receive_data;
     VAR authority: pft$authority;
     VAR cycle_number: pft$cycle_number;
     VAR device_class: rmt$device_class;
     VAR cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR global_file_name: dmt$global_file_name;
     VAR server_file_output: pft$server_file_output;
     VAR p_file_label: fmt$p_file_label;
     VAR p_fmd: pft$p_fmd;
     VAR status: ost$status);

    VAR
      p_attach_output: ^pft$df_attach_out,
      p_cycle_number: ^pft$cycle_number,
      p_server_file_output: ^pft$server_file_output,
      p_status: ^ost$status;

    NEXT p_attach_output IN p_receive_parameters;
    device_class := p_attach_output^.device_class;

    IF p_attach_output^.status_included THEN
      NEXT p_status IN p_receive_parameters;
      status := p_status^;

      NEXT p_cycle_number IN p_receive_parameters;
      cycle_number := p_cycle_number^;
      IF status.condition = pfe$tape_attached_on_client THEN
        device_class := p_attach_output^.device_class;
        global_file_name := p_attach_output^.global_file_name;
      IFEND;
    ELSE
      status.normal := TRUE;
      authority := p_attach_output^.authority;
      cycle_damage_symptoms := p_attach_output^.cycle_damage_symptoms;
      global_file_name := p_attach_output^.global_file_name;

      NEXT p_server_file_output IN p_receive_parameters;
      server_file_output := p_server_file_output^;
      cycle_number := p_server_file_output^.cycle_number;

      IF p_server_file_output^.label_length = 0 THEN
        p_file_label := NIL;
      ELSE
        IF (p_receive_data <> NIL) AND (#SIZE (p_receive_data^) > 0) THEN
          NEXT p_file_label: [[REP p_server_file_output^.label_length OF cell]] IN p_receive_data;
        ELSE
          NEXT p_file_label: [[REP p_server_file_output^.label_length OF cell]] IN p_receive_parameters;
        IFEND;
      IFEND;

      IF p_server_file_output^.rem_media_fmd_length = 0 THEN
        p_fmd := NIL;
      ELSE
        NEXT p_fmd: [[REP p_server_file_output^.rem_media_fmd_length OF cell]] IN p_receive_data;
      IFEND;
    IFEND;
  PROCEND parse_attach_receive_buffers;

?? TITLE := '  parse_change_receive_buffer', EJECT ??

  PROCEDURE parse_change_receive_buffer
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR cycle_number: pft$cycle_number;
     VAR device_class: rmt$device_class;
     VAR change_index: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      p_change_output: ^pft$df_change_out,
      p_status: ^ost$status;

    NEXT p_change_output IN p_receive_parameters;
    cycle_number := p_change_output^.cycle_number;
    device_class := p_change_output^.device_class;
    change_index := p_change_output^.change_index;

    IF p_change_output^.status_included THEN
      NEXT p_status IN p_receive_parameters;
      status := p_status^;
    ELSE
      status.normal := TRUE;
    IFEND;
  PROCEND parse_change_receive_buffer;

?? TITLE := '  parse_change_file_receive_buffer', EJECT ??

  PROCEDURE parse_change_file_receive
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR cycle_number: pft$cycle_number;
     VAR device_class: rmt$device_class;
     VAR change_file_index: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      p_change_file_output: ^pft$df_change_file_out,
      p_status: ^ost$status;

    NEXT p_change_file_output IN p_receive_parameters;
    cycle_number := p_change_file_output^.cycle_number;
    device_class := p_change_file_output^.device_class;
    change_file_index := p_change_file_output^.change_file_index;

    IF p_change_file_output^.status_included THEN
      NEXT p_status IN p_receive_parameters;
      status := p_status^;
    ELSE
      status.normal := TRUE;
    IFEND;
  PROCEND parse_change_file_receive;

?? TITLE := '  parse_define_data_params', EJECT ??

  PROCEDURE parse_define_data_params
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR p_receive_data: {i/o} dft$p_receive_data;
     VAR mandated_modification_time: pft$mandated_modification_time;
     VAR data_residence: pft$data_residence;
     VAR authority: pft$authority;
     VAR bytes_allocated: amt$file_byte_address;
     VAR server_file_output: pft$server_file_output;
     VAR p_file_label: fmt$p_file_label);

    VAR
      p_define_data_output: ^pft$df_define_data_outp,
      p_server_file_output: ^pft$server_file_output;

    NEXT p_define_data_output IN p_receive_parameters;
    mandated_modification_time := p_define_data_output^.mandated_modification_time;
    data_residence := p_define_data_output^.data_residence;
    authority := p_define_data_output^.authority;
    bytes_allocated := p_define_data_output^.bytes_allocated;
    NEXT p_server_file_output IN p_receive_parameters;
    server_file_output := p_server_file_output^;

    IF p_server_file_output^.label_length = 0 THEN
      p_file_label := NIL;
    ELSE
      IF (p_receive_data <> NIL) AND (#SIZE (p_receive_data^) > 0) THEN
        NEXT p_file_label: [[REP p_server_file_output^.label_length OF cell]] IN p_receive_data;
      ELSE
        NEXT p_file_label: [[REP p_server_file_output^.label_length OF cell]] IN p_receive_parameters;
      IFEND;
    IFEND;
  PROCEND parse_define_data_params;

?? TITLE := '  parse_define_receive_params', EJECT ??

  PROCEDURE parse_define_receive_params
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR authority: pft$authority;
     VAR bytes_allocated: amt$file_byte_address;
     VAR server_file_output: pft$server_file_output);

    VAR
      p_define_output: ^pft$df_define_outp,
      p_server_file_output: ^pft$server_file_output;

    NEXT p_define_output IN p_receive_parameters;
    authority := p_define_output^.authority;
    bytes_allocated := p_define_output^.bytes_allocated;
    NEXT p_server_file_output IN p_receive_parameters;
    server_file_output := p_server_file_output^;
  PROCEND parse_define_receive_params;

?? TITLE := '  parse_get_fam_set_receive_param', EJECT ??

  PROCEDURE parse_get_fam_set_receive_param
    (VAR p_receive_from_server_params: dft$p_receive_parameters;
     VAR set_name: stt$set_name);

    VAR
      p_receive_parameters: ^pft$df_get_family_set_outp;

    NEXT p_receive_parameters IN p_receive_from_server_params;
    set_name := p_receive_parameters^.set_name;
  PROCEND parse_get_fam_set_receive_param;

?? TITLE := '  parse_get_famit_info_params', EJECT ??

  PROCEDURE parse_get_famit_info_params
    (VAR p_receive_from_server_params: dft$p_receive_parameters;
     VAR p_receive_data: dft$p_receive_data;
     VAR set_name: pft$name;
     VAR p_info: pft$p_info;
     VAR status: ost$status);

    VAR
      p_user_info: pft$p_info,
      p_server_info: pft$p_info,
      p_set_name: ^pft$name;

    status.normal := TRUE;
    NEXT p_set_name IN p_receive_from_server_params;
    set_name := p_set_name^;
    NEXT p_user_info: [[REP #SIZE (p_receive_data^) OF cell]] IN p_info;
    IF p_user_info = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, '', status);
      RETURN;
    IFEND;
    NEXT p_server_info: [[REP #SIZE (p_receive_data^) OF cell]] IN p_receive_data;
    p_user_info^ := p_server_info^;
  PROCEND parse_get_famit_info_params;

?? TITLE := '  parse_get_mcat_receive_param', EJECT ??

  PROCEDURE parse_get_mcat_receive_param
    (VAR p_receive_from_server_params: dft$p_receive_parameters;
     VAR info_size: ost$segment_length);

    VAR
      p_receive_parameters: ^pft$df_get_mcat_info_outp;

    NEXT p_receive_parameters IN p_receive_from_server_params;
    info_size := p_receive_parameters^.info_size;
  PROCEND parse_get_mcat_receive_param;

?? TITLE := '  parse_get_obj_info_receive_bufs', EJECT ??

  PROCEDURE parse_get_obj_info_receive_bufs
    (    p_validation_criteria: {i/o^} ^fst$goi_validation_criteria;
         p_object_info: {input} ^fst$goi_object_information;
         queue_entry_location: dft$rpc_queue_entry_location;
     VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR p_receive_data: {i^/o} dft$p_receive_data;
     VAR object_info_offset: ost$segment_offset;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      p_client_object_info: ^SEQ ( * ),
      p_get_object_info_output: ^pft$df_get_obj_info_out,
      p_local_validation_criteria: ^fst$goi_validation_criteria,
      p_server_object_info: ^SEQ ( * ),
      p_status: ^ost$status;

    NEXT p_get_object_info_output IN p_receive_parameters;
    IF p_get_object_info_output = NIL THEN
      osp$set_status_abnormal (dfc$file_server_id, pfe$pf_system_error,
            'NIL p_get_object_info_output in parse_get_obj_info_receive_bufs', status);
      RETURN;
    IFEND;

    object_info_offset := p_get_object_info_output^.object_info_offset;

    IF p_validation_criteria <> NIL THEN
      NEXT p_local_validation_criteria: [1 .. UPPERBOUND (p_validation_criteria^)] IN p_receive_data;
      IF p_local_validation_criteria = NIL THEN
        osp$set_status_abnormal (dfc$file_server_id, pfe$pf_system_error,
             'NIL p_validation_criteria in parse_get_obj_info_receive_bufs', status);
        RETURN;
      IFEND;

      p_validation_criteria^ := p_local_validation_criteria^;
    IFEND;

    IF p_get_object_info_output^.status_included THEN
      NEXT p_status IN p_receive_parameters;
      IF p_status = NIL THEN
        osp$set_status_abnormal (dfc$file_server_id, pfe$pf_system_error,
              'NIL p_status in parse_get_obj_info_receive_bufs', status);
        RETURN;
      IFEND;

      IF p_status^.normal THEN
        status.normal := TRUE;
      ELSE
        status := p_status^;
      IFEND;
    ELSE
      status.normal := TRUE;
    IFEND;

    IF p_get_object_info_output^.rpc_segment_used THEN
      RESET p_object_information TO p_object_info;
      dfp$receive_server_rpc_segment (queue_entry_location, {server_segment_offset} 0,
            p_get_object_info_output^.info_size, p_object_information, status);
      IF (NOT status.normal) AND (status.condition = dfe$info_full) THEN
        osp$set_status_condition (pfe$info_full, status);
      IFEND;
    ELSE { The information is in the receive_data.
      IF p_validation_criteria = NIL THEN
        NEXT p_server_object_info: [[REP #SIZE (p_receive_data^) OF cell]] IN p_receive_data;
      ELSE
        NEXT p_server_object_info: [[REP (#SIZE (p_receive_data^) - #SIZE (p_validation_criteria^)) OF cell]]
               IN p_receive_data;
      IFEND;
      IF p_server_object_info = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'NIL p_server_object_info in parse_get_obj_info_receive_bufs', status);
        RETURN;
      IFEND;

      RESET p_object_information TO p_object_info;
      NEXT p_client_object_info: [[REP #SIZE (p_server_object_info^) OF cell]] IN p_object_information;
      IF p_client_object_info = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
      ELSE
        p_client_object_info^ := p_server_object_info^;
      IFEND;
    IFEND;
  PROCEND parse_get_obj_info_receive_bufs;

?? TITLE := '  parse_purge_receive_buffer', EJECT ??

  PROCEDURE parse_purge_receive_buffer
    (VAR p_receive_parameters: dft$p_receive_parameters;
     VAR authority: pft$authority;
     VAR device_class: rmt$device_class;
     VAR bytes_released: amt$file_byte_address;
     VAR status: ost$status);

    VAR
      p_purge_output: ^pft$df_purge_out,
      p_status: ^ost$status;

    NEXT p_purge_output IN p_receive_parameters;
    authority := p_purge_output^.authority;
    device_class := p_purge_output^.device_class;

    IF p_purge_output^.status_included THEN
      NEXT p_status IN p_receive_parameters;
      status := p_status^;
    ELSE
      bytes_released := p_purge_output^.bytes_released;
      status.normal := TRUE;
    IFEND;
  PROCEND parse_purge_receive_buffer;

?? TITLE := '  parse_put_item_info_receipts', EJECT ??

  PROCEDURE parse_put_item_info_receipts
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR p_receive_data: {i^/o} dft$p_receive_data;
     VAR audit_restorations: boolean;
     VAR all_permits_restored: boolean;
     VAR p_auditable_permits: ^pft$auditable_permits;
     VAR p_auditable_cycles: ^pft$auditable_cycles;
     VAR status: ost$status);

    VAR
      p_local_auditable_cycles: ^pft$auditable_cycles,
      p_local_auditable_permits: ^pft$auditable_permits,
      p_put_item_info_output: ^pft$df_put_item_info_out,
      p_status: ^ost$status;

    NEXT p_put_item_info_output IN p_receive_parameters;
    audit_restorations := p_put_item_info_output^.audit_restorations;
    all_permits_restored := p_put_item_info_output^.all_permits_restored;

    IF p_put_item_info_output^.status_included THEN
      NEXT p_status IN p_receive_parameters;
      status := p_status^;
    ELSE
      status.normal := TRUE;
    IFEND;

    IF p_put_item_info_output^.auditable_permits THEN
      NEXT p_local_auditable_permits: [1 .. UPPERBOUND (p_auditable_permits^)] IN p_receive_data;
      IF p_local_auditable_permits = NIL THEN
        p_auditable_permits := NIL;
      ELSE
        p_auditable_permits^ := p_local_auditable_permits^;
      IFEND;
    ELSE
      p_auditable_permits := NIL;
    IFEND;

    IF p_put_item_info_output^.auditable_cycles THEN
      NEXT p_local_auditable_cycles: [1 .. UPPERBOUND (p_auditable_cycles^)] IN p_receive_data;
      IF p_local_auditable_cycles = NIL THEN
        p_auditable_cycles := NIL;
      ELSE
        p_auditable_cycles^ := p_local_auditable_cycles^;
      IFEND;
    ELSE
      p_auditable_cycles := NIL;
    IFEND;
  PROCEND parse_put_item_info_receipts;

?? TITLE := '  parse_resolve_receive_params', EJECT ??

  PROCEDURE parse_resolve_receive_params
    (VAR p_receive_from_server_params: dft$p_receive_parameters;
     VAR cycle_reference: fst$cycle_reference;
     VAR path_resolution: fst$path_resolution);

    VAR
      p_receive_parameters: ^pft$df_resolve_outp;

    NEXT p_receive_parameters IN p_receive_from_server_params;
    cycle_reference := p_receive_parameters^.cycle_reference;
    path_resolution := p_receive_parameters^.path_resolution;
  PROCEND parse_resolve_receive_params;

?? TITLE := '  parse_return_receive_params', EJECT ??

  PROCEDURE parse_return_receive_params
    (VAR p_receive_from_server_params: dft$p_receive_parameters;
     VAR authority: pft$authority;
     VAR bytes_allocated_change: sft$counter);

    VAR
      p_parameters: ^pft$df_return_outp;

    NEXT p_parameters IN p_receive_from_server_params;
    authority := p_parameters^.authority;
    bytes_allocated_change := p_parameters^.bytes_allocated_change;

  PROCEND parse_return_receive_params;

?? TITLE := '  parse_save_label_receive_bufs', EJECT ??

  PROCEDURE parse_save_label_receive_bufs
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR p_receive_data: {i^/o} dft$p_receive_data;
     VAR p_save_file_label_audit_seq: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      p_client_complete_path: ^pft$complete_path,
      p_client_save_label_audit_info: ^pft$save_label_audit_info,
      p_save_label_output: ^pft$df_save_label_out,
      p_server_complete_path: ^pft$complete_path,
      p_server_save_label_audit_info: ^pft$save_label_audit_info,
      p_status: ^ost$status;

    NEXT p_save_label_output IN p_receive_parameters;

    IF p_save_label_output^.audit THEN
      NEXT p_server_save_label_audit_info IN p_receive_parameters;
      NEXT p_server_complete_path: [1 .. p_server_save_label_audit_info^.file_path_count]
            IN p_receive_parameters;
      IF p_server_complete_path = NIL THEN
        NEXT p_server_complete_path: [1 .. p_server_save_label_audit_info^.file_path_count] IN p_receive_data;
      IFEND;

      RESET p_save_file_label_audit_seq;
      NEXT p_client_save_label_audit_info IN p_save_file_label_audit_seq;
      IF p_client_save_label_audit_info = NIL THEN
        p_save_file_label_audit_seq := NIL;
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'NIL p_client_save_label_audit_info in parse_save_label_receive_bufs', status);
        RETURN;
      IFEND;

      NEXT p_client_complete_path: [1 .. p_server_save_label_audit_info^.file_path_count]
            IN p_save_file_label_audit_seq;
      IF p_client_complete_path = NIL THEN
        p_save_file_label_audit_seq := NIL;
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'NIL p_client_complete_path in parse_save_label_receive_bufs', status);
        RETURN;
      IFEND;

      p_client_complete_path^ := p_server_complete_path^;
      p_client_save_label_audit_info^ := p_server_save_label_audit_info^;
    ELSE
      p_save_file_label_audit_seq := NIL;
    IFEND;

    IF p_save_label_output^.status_included THEN
      NEXT p_status IN p_receive_parameters;
      IF p_status = NIL THEN
        NEXT p_status IN p_receive_data;
      IFEND;
      status := p_status^;
    ELSE
      status.normal := TRUE;
    IFEND;
  PROCEND parse_save_label_receive_bufs;

?? TITLE := '  parse_save_rel_label_receipt', EJECT ??

  PROCEDURE parse_save_rel_label_receipt
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR p_save_label_audit_info: ^pft$save_label_audit_info;
     VAR status: ost$status);

    VAR
      p_save_label_output: ^pft$df_save_label_out,
      p_server_save_label_audit_info: ^pft$save_label_audit_info,
      p_status: ^ost$status;

    NEXT p_save_label_output IN p_receive_parameters;
    IF p_save_label_output^.audit THEN
      NEXT p_server_save_label_audit_info IN p_receive_parameters;
      p_save_label_audit_info^ := p_server_save_label_audit_info^;
    ELSE
      p_save_label_audit_info := NIL;
    IFEND;

    IF p_save_label_output^.status_included THEN
      NEXT p_status IN p_receive_parameters;
      status := p_status^;
    ELSE
      status.normal := TRUE;
    IFEND;
  PROCEND parse_save_rel_label_receipt;

?? TITLE := '  purge_server_file', EJECT ??

  PROCEDURE purge_server_file
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         purge_cycle_options: pft$purge_cycle_options;
         system_privilege: boolean;
         validation_ring: ost$valid_ring;
         queue_entry_location: dft$rpc_queue_entry_location;
     VAR p_send_parameters: dft$p_send_parameters;
     VAR p_send_data: dft$p_send_data;
     VAR p_receive_parameters: dft$p_receive_parameters;
     VAR status: ost$status);

{ How about sending gfn over as a verification?

    VAR
      p_receive_data: dft$p_receive_data,
      send_data_size: dft$send_data_size,
      send_parameters_size: dft$send_parameter_size;

    build_purge_send_buffers (path, cycle_selector, password, purge_cycle_options, system_privilege,
          validation_ring, p_send_parameters, p_send_data, send_parameters_size, send_data_size);

    dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_purge, send_parameters_size,
          send_data_size, p_receive_parameters, p_receive_data, status);
  PROCEND purge_server_file;

?? TITLE := '  return_server_file', EJECT ??

  PROCEDURE return_server_file
    (    attached_pf_table_index: pft$attached_pf_table_index;
         file_modified: boolean;
         eoi_byte_address: amt$file_byte_address;
         server_sfid: gft$system_file_identifier;
         device_class: rmt$device_class;
         queue_entry_location: dft$rpc_queue_entry_location;
     VAR p_send_to_server_params: dft$p_send_parameters;
     VAR p_receive_from_server_params: dft$p_receive_parameters;
     VAR status: ost$status);

{ How about sending gfn over as a verification?

    VAR
      parameter_size: dft$send_parameter_size,
      p_receive_data: dft$p_receive_data;

    build_return_send_buffer (attached_pf_table_index, file_modified, eoi_byte_address,
         server_sfid, device_class, p_send_to_server_params, parameter_size);

    dfp$send_remote_procedure_call (queue_entry_location, dfc$r2_df_server_return, parameter_size, 0,
          p_receive_from_server_params, p_receive_data, status);
  PROCEND return_server_file;

?? TITLE := '  validate_path_table_change', EJECT ??

{  This procedure verifies the file name, or cycle number associated with a
{  change request may be changed in the path table.
{  This is done prior to going to the server, so that upon return from
{  the server, the actual change to the path table should work.

  PROCEDURE validate_path_table_change
    (    path: pft$path;
         change_list: pft$change_list;
     VAR status: ost$status);

    VAR
      change_index: integer,
      evaluated_file_reference: fst$evaluated_file_reference,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      new: pft$change_descriptor,
      new_file_object: boolean,
      p_new_path: ^pft$path,
      path_table_cycle_info: fmt$path_table_cycle_info;

    status.normal := TRUE;
    new_file_object := FALSE;

  /validate_changes/
    FOR change_index := 1 TO UPPERBOUND (change_list) DO
      new := change_list [change_index];

      CASE new.change_type OF
      = pfc$pf_name_change =
        PUSH p_new_path: [1 .. UPPERBOUND (path)];
        p_new_path^ := path;
        p_new_path^ [UPPERBOUND (path)] := new.pfn;
        pfp$convert_pft$path_to_fs_str (p_new_path^, evaluated_file_reference);
        evaluated_file_reference.cycle_reference.specification := fsc$low_cycle;
        fmp$get_path_table_cycle_info ({inhibit_path_table_lock =} TRUE, evaluated_file_reference,
              path_table_cycle_info, status);
        IF status.normal THEN
          IF path_table_cycle_info.path_registered THEN
            pfp$convert_pft$path_to_fs_path (p_new_path^, fs_path, fs_path_size);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$name_already_used,
                  fs_path (1, fs_path_size), status);
            EXIT /validate_changes/;
          IFEND;
        ELSE
          pfp$report_unexpected_status (status);
          EXIT /validate_changes/;
        IFEND;
        new_file_object := TRUE;

      = pfc$cycle_number_change =
        IF new_file_object THEN
          {
          { The new file name validated; the new cycle cannot be registered.
          {
        ELSE
          pfp$convert_pft$path_to_fs_str (path, evaluated_file_reference);
          evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
          evaluated_file_reference.cycle_reference.cycle_number := new.cycle_number;
          fmp$get_path_table_cycle_info ({inhibit_path_table_lock =} TRUE, evaluated_file_reference,
                path_table_cycle_info, status);
          IF status.normal THEN
            IF path_table_cycle_info.path_registered THEN
              pfp$convert_pft$path_to_fs_path (path, fs_path, fs_path_size);
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$duplicate_cycle,
                    fs_path (1, fs_path_size), status);
              osp$append_status_integer (osc$status_parameter_delimiter, new.cycle_number, 10, FALSE, status);
              EXIT /validate_changes/;
            IFEND;
          ELSE
            EXIT /validate_changes/;
          IFEND;
        IFEND;

      ELSE
        ;
      CASEND;
    FOREND /validate_changes/;
  PROCEND validate_path_table_change;

?? TITLE := '  validate_path_table_change_file', EJECT ??

{  This procedure verifies the file name, or cycle number associated with a
{  change request may be changed in the path table.
{  This is done prior to going to the server, so that upon return from
{  the server, the actual change to the path table should work.

  PROCEDURE validate_path_table_change_file
    (    path: pft$path;
         file_changes: ^fst$file_changes;
     VAR status: ost$status);

    VAR
      change_index: integer,
      evaluated_file_reference: fst$evaluated_file_reference,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      new: fst$file_change,
      new_file_object: boolean,
      p_new_path: ^pft$path,
      path_table_cycle_info: fmt$path_table_cycle_info;

    status.normal := TRUE;
    new_file_object := FALSE;

  /validate_changes/
    FOR change_index := 1 TO UPPERBOUND (file_changes^) DO
      new := file_changes^ [change_index];

      CASE new.selector OF
      = fsc$pf_name_change =
        PUSH p_new_path: [1 .. UPPERBOUND (path)];
        p_new_path^ := path;
        p_new_path^ [UPPERBOUND (path)] := new.pfn;
        pfp$convert_pft$path_to_fs_str (p_new_path^, evaluated_file_reference);
        evaluated_file_reference.cycle_reference.specification := fsc$low_cycle;
        fmp$get_path_table_cycle_info ({inhibit_path_table_lock =} TRUE, evaluated_file_reference,
              path_table_cycle_info, status);
        IF status.normal THEN
          IF path_table_cycle_info.path_registered THEN
            pfp$convert_pft$path_to_fs_path (p_new_path^, fs_path, fs_path_size);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$name_already_used,
                  fs_path (1, fs_path_size), status);
            EXIT /validate_changes/;
          IFEND;
        ELSE
          pfp$report_unexpected_status (status);
          EXIT /validate_changes/;
        IFEND;
        new_file_object := TRUE;

      = fsc$cycle_number_change =
        IF new_file_object THEN
          {
          { The new file name validated; the new cycle cannot be registered.
          {
        ELSE
          pfp$convert_pft$path_to_fs_str (path, evaluated_file_reference);
          evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
          evaluated_file_reference.cycle_reference.cycle_number := new.cycle_number;
          fmp$get_path_table_cycle_info ({inhibit_path_table_lock =} TRUE, evaluated_file_reference,
                path_table_cycle_info, status);
          IF status.normal THEN
            IF path_table_cycle_info.path_registered THEN
              pfp$convert_pft$path_to_fs_path (path, fs_path, fs_path_size);
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$duplicate_cycle,
                    fs_path (1, fs_path_size), status);
              osp$append_status_integer (osc$status_parameter_delimiter, new.cycle_number, 10, FALSE, status);
              EXIT /validate_changes/;
            IFEND;
          ELSE
            EXIT /validate_changes/;
          IFEND;
        IFEND;

      ELSE
        ;
      CASEND;
    FOREND /validate_changes/;
  PROCEND validate_path_table_change_file;

?? OLDTITLE, SKIP := 2 ??
MODEND pfm$r2_df_client_requests;
*DECK DECK=PFM$R2_DF_SERVER_REQUESTS EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE File Server : Server Requests' ??
MODULE pfm$r2_df_server_requests;

{ PURPOSE:
{   This module processes the server side of permanent file requests
{   originating from the client and destined for the server.
{
{ DESIGN:
{   The general sequence is:
{   - Parse the receive buffer and get the pointer to the path.
{   - Get the name of the set containing the catalog and build a complete path.
{   - Pass the required parameters to the standard processor contained in
{     module pfm$r2_request_processor.
{   - Build the parameter and data buffers to return to the client.  On
{     requests returning only the normal VAR parameters, this is done
{     completely within this module.  On those interfaces (e.g. attach, define,
{     attach_or_create) requiring additional information from the catalog or
{     device manager, part of the buffer will be built within
{     pfm$r2_request_processor.
{
{ NOTE:
{   Requests within this module assume that the request was initiated on the
{   client by calling dfp$begin_remote_procedure_call and
{   dfp$send_remote_procedure_call.

?? NEWTITLE := '  Global Declarations Referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dfd$request_package
*copyc dft$rpc_parameters
*copyc fse$open_validation_errors
*copyc fst$device_classes
*copyc fst$file_changes
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pft$df_append_rem_media_vsn
*copyc pft$df_attach_in
*copyc pft$df_attach_out
*copyc pft$df_attach_or_create_in
*copyc pft$df_attach_or_create_out
*copyc pft$df_change_file_in
*copyc pft$df_change_file_out
*copyc pft$df_change_in
*copyc pft$df_change_out
*copyc pft$df_change_cy_dam
*copyc pft$df_change_cy_dt
*copyc pft$df_change_residence_in
*copyc pft$df_clear_cy_att_in
*copyc pft$df_define
*copyc pft$df_define_catalog
*copyc pft$df_define_data
*copyc pft$df_delete_all_arch_entries
*copyc pft$df_delete_archive_entry
*copyc pft$df_delete_permit
*copyc pft$df_get_family_set
*copyc pft$df_get_info_in
*copyc pft$df_get_info_out
*copyc pft$df_get_mcat_info
*copyc pft$df_get_obj_info_in
*copyc pft$df_get_obj_info_out
*copyc pft$df_mark_release_candidate
*copyc pft$df_permit_in
*copyc pft$df_purge_catalog_in
*copyc pft$df_purge_in
*copyc pft$df_purge_out
*copyc pft$df_put_archive_entry
*copyc pft$df_put_archive_info
*copyc pft$df_put_cycle_info
*copyc pft$df_put_item_info_in
*copyc pft$df_put_item_info_out
*copyc pft$df_replace_rem_media_fmd
*copyc pft$df_release_data
*copyc pft$df_replace_archive_entry
*copyc pft$df_resolve
*copyc pft$df_return
*copyc pft$df_save_file_label_in
*copyc pft$df_save_label_out
*copyc pft$df_save_released_label_in
*copyc pft$unique_volume_list
*copyc pft$df_validate_password
*copyc pft$purge_cycle_options
*copyc pft$release_data_info
*copyc pft$relink_server_file
?? POP ??
?? EJECT ??
*copyc dfp$reserve_server_rpc_segment
*copyc dmp$fetch_eoi
*copyc dmp$fetch_server_sft_info
*copyc dmp$set_eoi
*copyc i#current_sequence_position
*copyc osp$append_status_parameter
*copyc osp$log_job_recovery_message
*copyc osp$log_job_recovery_status
*copyc osp$get_set_name
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$system_error
*copyc pfp$r2_change_res_to_releasable
*copyc pfp$r2_get_vol_condition_list
*copyc pfp$convert_cycle_path_to_strng
*copyc pfp$initialize_object_info
*copyc pfp$internal_return_file
*copyc pfp$internal_save_file_label
*copyc pfp$lock_apfid
*copyc pfp$process_unexpected_status
*copyc pfp$r2_append_rem_media_vsn
*copyc pfp$r2_attach_file
*copyc pfp$r2_attach_or_create
*copyc pfp$r2_change
*copyc pfp$r2_change_cycle_damage
*copyc pfp$r2_change_cycle_date_time
*copyc pfp$r2_change_file
*copyc pfp$r2_clear_cycle_attachments
*copyc pfp$r2_define
*copyc pfp$r2_define_catalog
*copyc pfp$r2_define_data
*copyc pfp$r2_delete_all_arch_entries
*copyc pfp$r2_delete_archive_entry
*copyc pfp$r2_delete_catalog_permit
*copyc pfp$r2_delete_permit
*copyc pfp$r2_get_item_info
*copyc pfp$r2_get_master_catalog_info
*copyc pfp$r2_get_multi_item_info
*copyc pfp$r2_get_object_info
*copyc pfp$r2_mark_release_candidate
*copyc pfp$r2_permit
*copyc pfp$r2_permit_catalog
*copyc pfp$r2_purge
*copyc pfp$r2_purge_catalog
*copyc pfp$r2_put_archive_entry
*copyc pfp$r2_put_archive_info
*copyc pfp$r2_put_cycle_info
*copyc pfp$r2_put_item_info
*copyc pfp$r2_release_data
*copyc pfp$r2_replace_archive_entry
*copyc pfp$r2_replace_rem_media_fmd
*copyc pfp$r2_resolve_path
*copyc pfp$r2_save_released_file_label
*copyc pfp$r2_validate_password
*copyc pfp$unlock_apfid
*copyc pmp$convert_binary_unique_name

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_app_rem_me_vsn', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_app_rem_me_vsn
    (VAR p_param_received_from_client: {i^/o} dft$p_receive_parameters;
     VAR p_data_from_client: {i^/o} dft$p_receive_data;
     VAR p_send_to_client_params: dft$p_send_parameters;
     VAR p_send_to_client_data: dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_complete_path: ^pft$complete_path,
      p_file_media_descriptor: ^SEQ ( * ),
      p_input_parameters: ^pft$df_append_rem_me_vsn_inp,
      p_path: ^pft$path;

    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;
    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);

    IF status.normal THEN
      pfp$r2_append_rem_media_vsn (p_complete_path^, p_input_parameters^.cycle_selector,
            p_input_parameters^.volume_descriptor, status);
    IFEND;
  PROCEND pfp$r2_df_server_app_rem_me_vsn;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_attach', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_attach
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR p_receive_data: {i^/o} dft$p_receive_data;
     VAR p_send_parameters: dft$p_send_parameters;
     VAR p_send_data: dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      allowed_usage_selections: pft$usage_selections,
      cycle_number: pft$cycle_number,
      file_server_buffers: pft$file_server_buffers,
      p_attach_input: ^pft$df_attach_in,
      p_attach_output: ^pft$df_attach_out,
      p_complete_path: ^pft$complete_path,
      p_cycle_number: ^pft$cycle_number,
      p_file_server_buffers: pft$p_file_server_buffers,
      p_path: ^pft$path,
      p_status: ^ost$status,
      required_share_selections: pft$share_selections;

    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_attach_input IN p_receive_parameters;
    NEXT p_path: [1 .. p_attach_input^.path_length] IN p_receive_parameters;
    IF p_path = NIL THEN
      NEXT p_path: [1 .. p_attach_input^.path_length] IN p_receive_data;
    IFEND;

    PUSH p_complete_path: [1 .. (p_attach_input^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_server_buffers.p_send_parameters := p_send_parameters;
    file_server_buffers.p_send_data := p_send_data;
    p_file_server_buffers := ^file_server_buffers;
    NEXT p_attach_output IN file_server_buffers.p_send_parameters;

    pfp$r2_attach_file (pfc$server_mainframe, p_attach_input^.mainframe_id, {lfn} osc$null_name,
          p_complete_path^, p_attach_input^.cycle_selector, p_attach_input^.password,
          p_attach_input^.update_catalog, p_attach_input^.update_cycle_statistics,
          p_attach_input^.usage_selector, p_attach_input^.share_selector, p_attach_input^.system_privilege,
          p_attach_input^.validation_ring, {allowed_device_classes} - $fst$device_classes [],
          p_attach_input^.allowed_cycle_damage_symptoms, p_attach_output^.device_class, cycle_number,
          allowed_usage_selections, required_share_selections, p_attach_output^.cycle_damage_symptoms,
          p_attach_output^.authority, p_attach_output^.global_file_name, p_file_server_buffers, status);

    IF status.normal THEN
      p_attach_output^.status_included := FALSE;
      send_parameters_size := i#current_sequence_position (file_server_buffers.p_send_parameters);
      send_data_size := i#current_sequence_position (file_server_buffers.p_send_data);
    ELSE
      NEXT p_status IN file_server_buffers.p_send_parameters;
      p_status^ := status;
      p_attach_output^.status_included := TRUE;

      NEXT p_cycle_number IN file_server_buffers.p_send_parameters;
      p_cycle_number^ := cycle_number;

      send_parameters_size := i#current_sequence_position (file_server_buffers.p_send_parameters);
      status.normal := TRUE;
    IFEND;
  PROCEND pfp$r2_df_server_attach;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_attach_or_cref', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_attach_or_cref
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR p_receive_data: {i^/o} dft$p_receive_data;
     VAR p_send_parameters: {i^/o} dft$p_send_parameters;
     VAR p_send_data: {i^/o} dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      authority: pft$authority,
      catalog: boolean,
      catalog_recreated: boolean,
      evaluated_file_reference: fst$evaluated_file_reference,
      file_server_buffers: pft$file_server_buffers,
      p_attach_or_create_input: ^pft$df_attach_or_create_in,
      p_attach_or_create_output: ^pft$df_attach_or_create_out,
      p_attachment_options: ^fst$attachment_options,
      p_file_label: ^fmt$file_label,
      p_file_server_buffers: ^pft$file_server_buffers,
      p_path_table_cycle_info: ^fmt$path_table_cycle_info,
      p_status: ^ost$status;

    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_attach_or_create_input IN p_receive_parameters;

    IF p_attach_or_create_input^.number_of_attachment_options = 0 THEN
      p_attachment_options := NIL;
    ELSE
      NEXT p_attachment_options: [1 .. p_attach_or_create_input^.number_of_attachment_options]
            IN p_receive_parameters;
      IF p_attachment_options = NIL THEN
        NEXT p_attachment_options: [1 .. p_attach_or_create_input^.number_of_attachment_options]
              IN p_receive_data;
      IFEND;
    IFEND;

    IF p_attach_or_create_input^.file_label_size = 0 THEN
      p_file_label := NIL;
    ELSE
      NEXT p_file_label: [[REP p_attach_or_create_input^.file_label_size OF cell]] IN p_receive_parameters;
      IF p_file_label = NIL THEN
        NEXT p_file_label: [[REP p_attach_or_create_input^.file_label_size OF cell]] IN p_receive_data;
      IFEND;
    IFEND;

    IF p_attach_or_create_input^.path_table_info_present THEN
      NEXT p_path_table_cycle_info IN p_receive_parameters;
      IF p_path_table_cycle_info = NIL THEN
        NEXT p_path_table_cycle_info IN p_receive_data;
      IFEND;
    ELSE
      p_path_table_cycle_info := NIL;
    IFEND;

    evaluated_file_reference := p_attach_or_create_input^.evaluated_file_reference;
    file_server_buffers.p_send_parameters := p_send_parameters;
    file_server_buffers.p_send_data := p_send_data;
    p_file_server_buffers := ^file_server_buffers;

    NEXT p_attach_or_create_output IN file_server_buffers.p_send_parameters;

    pfp$r2_attach_or_create (pfc$server_mainframe, p_attach_or_create_input^.mainframe_id,
          p_attach_or_create_input^.validation_ring, p_attach_or_create_input^.system_privilege,
          p_attach_or_create_input^.exception_selection_info, p_attachment_options, p_file_label,
          p_path_table_cycle_info, p_attach_or_create_input^.fs_retention,
          p_attach_or_create_input^.retrieve_option, p_attach_or_create_input^.site_archive_option,
          p_attach_or_create_input^.site_backup_option, p_attach_or_create_input^.site_release_option,
          evaluated_file_reference, p_attach_or_create_output^.action_attempted,
          p_attach_or_create_output^.action_taken, p_attach_or_create_output^.authority,
          p_attach_or_create_output^.allowed_access, p_attach_or_create_output^.selected_access,
          p_attach_or_create_output^.required_sharing, p_attach_or_create_output^.selected_sharing,
          p_attach_or_create_output^.device_class, p_attach_or_create_output^.global_file_name,
          p_attach_or_create_output^.new_global_file_name, p_attach_or_create_output^.new_remote_sfid,
          p_attach_or_create_output^.label_used, p_attach_or_create_output^.bytes_allocated,
          p_file_server_buffers, status);

    IF status.normal THEN
      p_attach_or_create_output^.evaluated_file_reference := evaluated_file_reference;
      p_attach_or_create_output^.status_included := FALSE;
      send_data_size := i#current_sequence_position (file_server_buffers.p_send_data);
    ELSE
      IF (status.condition = pfe$recheck_client_mainframe) OR
           (status.condition = pfe$cycle_data_resides_offline) OR
           (status.condition = fse$device_class_conflict) THEN
        p_attach_or_create_output^.evaluated_file_reference := evaluated_file_reference;
      IFEND;

      NEXT p_status IN file_server_buffers.p_send_parameters;
      p_status^ := status;
      p_attach_or_create_output^.status_included := TRUE;
      status.normal := TRUE;
    IFEND;

    send_parameters_size := i#current_sequence_position (file_server_buffers.p_send_parameters);
  PROCEND pfp$r2_df_server_attach_or_cref;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_change', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_change
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR p_receive_data: {i^/o} dft$p_receive_data;
     VAR p_send_parameters: {i^/o} dft$p_send_parameters;
     VAR p_send_data: {i^/o} dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_change_input: ^pft$df_change_in,
      p_change_list: ^pft$change_list,
      p_change_output: ^pft$df_change_out,
      p_complete_path: ^pft$complete_path,
      p_path: ^pft$path,
      p_status: ^ost$status;

    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_change_input IN p_receive_parameters;

    NEXT p_path: [1 .. p_change_input^.path_length] IN p_receive_parameters;
    IF p_path = NIL THEN
      NEXT p_path: [1 .. p_change_input^.path_length] IN p_receive_data;
    IFEND;

    PUSH p_complete_path: [1 .. p_change_input^.path_length + 1];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT p_change_list: [1 .. p_change_input^.change_count] IN p_receive_parameters;
    IF p_change_list = NIL THEN
      NEXT p_change_list: [1 .. p_change_input^.change_count] IN p_receive_data;
    IFEND;

    NEXT p_change_output IN p_send_parameters;

    pfp$r2_change (pfc$server_mainframe, p_complete_path^, p_change_input^.cycle_selector,
          p_change_input^.password, p_change_input^.system_privilege, p_change_list^,
          p_change_output^.cycle_number, p_change_output^.device_class, p_change_output^.change_index,
          status);

    IF status.normal THEN
      p_change_output^.status_included := FALSE;
    ELSE
      NEXT p_status IN p_send_parameters;
      p_status^ := status;
      p_change_output^.status_included := TRUE;
      status.normal := TRUE;
    IFEND;

    send_parameters_size := i#current_sequence_position (p_send_parameters);
    send_data_size := i#current_sequence_position (p_send_data);
  PROCEND pfp$r2_df_server_change;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_change_cy_dam', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_change_cy_dam
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_complete_path: ^pft$complete_path,
      p_input_parameters: ^pft$df_change_cy_dam_inp,
      p_path: ^pft$path;

    status.normal := TRUE;
    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;
    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);
    IF status.normal THEN
      pfp$r2_change_cycle_damage (p_complete_path^, p_input_parameters^.cycle_selector,
            p_input_parameters^.password, p_input_parameters^.new_damage_symptoms, status);
    IFEND;

  PROCEND pfp$r2_df_server_change_cy_dam;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_change_cy_dt', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_change_cy_dt
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_complete_path: ^pft$complete_path,
      p_input_parameters: ^pft$df_change_cy_dt_inp,
      p_path: ^pft$path;

    status.normal := TRUE;
    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;
    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);
    IF status.normal THEN
      pfp$r2_change_cycle_date_time (p_complete_path^, p_input_parameters^.cycle_selector,
            p_input_parameters^.password, p_input_parameters^.new_access_date_time,
            p_input_parameters^.new_creation_date_time, p_input_parameters^.new_modification_date_time,
            status);
    IFEND;

  PROCEND pfp$r2_df_server_change_cy_dt;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_change_file', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_change_file
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR p_receive_data: {i^/o} dft$p_receive_data;
     VAR p_send_parameters: {i^/o} dft$p_send_parameters;
     VAR p_send_data: {i^/o} dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      file_changes: ^fst$file_changes,
      p_change_file_input: ^pft$df_change_file_in,
      p_change_file_output: ^pft$df_change_file_out,
      p_complete_path: ^pft$complete_path,
      p_path: ^pft$path,
      p_status: ^ost$status;

    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_change_file_input IN p_receive_parameters;

    NEXT p_path: [1 .. p_change_file_input^.path_length] IN p_receive_parameters;
    IF p_path = NIL THEN
      NEXT p_path: [1 .. p_change_file_input^.path_length] IN p_receive_data;
    IFEND;

    PUSH p_complete_path: [1 .. p_change_file_input^.path_length + 1];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT file_changes: [1 .. p_change_file_input^.change_file_count] IN p_receive_parameters;
    IF file_changes = NIL THEN
      NEXT file_changes: [1 .. p_change_file_input^.change_file_count] IN p_receive_data;
    IFEND;

    NEXT p_change_file_output IN p_send_parameters;

    pfp$r2_change_file (pfc$server_mainframe, p_complete_path^, p_change_file_input^.cycle_selector,
          p_change_file_input^.password, p_change_file_input^.system_privilege, file_changes,
          p_change_file_output^.cycle_number, p_change_file_output^.device_class,
          p_change_file_output^.change_file_index, status);

    IF status.normal THEN
      p_change_file_output^.status_included := FALSE;
    ELSE
      NEXT p_status IN p_send_parameters;
      p_status^ := status;
      p_change_file_output^.status_included := TRUE;
      status.normal := TRUE;
    IFEND;

    send_parameters_size := i#current_sequence_position (p_send_parameters);
    send_data_size := i#current_sequence_position (p_send_data);
  PROCEND pfp$r2_df_server_change_file;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_change_res_rel', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_change_res_rel
    (VAR p_receive_parameters {i^/o} : dft$p_receive_parameters;
     VAR p_receive_data {i^/o} : dft$p_receive_data;
     VAR p_send_parameters {i^/o} : dft$p_send_parameters;
     VAR p_send_data {i^/o} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_change_residence_input: ^pft$df_change_residence_in,
      p_complete_path: ^pft$complete_path,
      p_path: ^pft$path;

    status.normal := TRUE;
    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_change_residence_input IN p_receive_parameters;
    NEXT p_path: [1 .. p_change_residence_input^.path_length] IN p_receive_parameters;
    PUSH p_complete_path: [1 .. (p_change_residence_input^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);
    IF status.normal THEN
      pfp$r2_change_res_to_releasable (p_complete_path^, p_change_residence_input^.cycle_selector, status);
    IFEND;

  PROCEND pfp$r2_df_server_change_res_rel;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_clear_cy_att', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_clear_cy_att
    (VAR p_receive_parameters {i^/o} : dft$p_receive_parameters;
     VAR p_receive_data {i^/o} : dft$p_receive_data;
     VAR p_send_parameters {i^/o} : dft$p_send_parameters;
     VAR p_send_data {i^/o} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_clear_cycle_attach_input: ^pft$df_clear_cy_att_in,
      p_complete_path: ^pft$complete_path,
      p_path: ^pft$path;

    send_parameters_size := 0;
    send_data_size := 0;
    status.normal := TRUE;

    NEXT p_clear_cycle_attach_input IN p_receive_parameters;
    NEXT p_path: [1 .. p_clear_cycle_attach_input^.path_length] IN p_receive_parameters;
    PUSH p_complete_path: [1 .. p_clear_cycle_attach_input^.path_length + 1];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);
    IF status.normal THEN
      pfp$r2_clear_cycle_attachments (p_complete_path^, p_clear_cycle_attach_input^.cycle_selector,
            p_clear_cycle_attach_input^.password, status);
    IFEND;

  PROCEND pfp$r2_df_server_clear_cy_att;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_define', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_define
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      cycle_number: pft$cycle_number,
      file_server_buffers: pft$file_server_buffers,
      p_complete_path: ^pft$complete_path,
      p_file_server_buffers: pft$p_file_server_buffers,
      p_input_parameters: ^pft$df_define_inp,
      p_ms_request: ^fmt$mass_storage_request_info,
      p_output_parameters: ^pft$df_define_outp,
      p_path: ^pft$path,
      p_rem_media_request: ^fmt$removable_media_req_info,
      p_volume_list: ^rmt$volume_list;

    status.normal := TRUE;
    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;

    IF p_input_parameters^.mass_storage_request_included THEN
      NEXT p_ms_request IN p_param_received_from_client;
    ELSE
      p_ms_request := NIL;
    IFEND;

    IF p_input_parameters^.rem_media_request_included THEN
      NEXT p_rem_media_request IN p_param_received_from_client;
    ELSE
      p_rem_media_request := NIL;
    IFEND;

    IF p_input_parameters^.volume_list_included THEN
      NEXT p_volume_list: [1 .. p_input_parameters^.number_of_volumes] IN p_param_received_from_client;
    ELSE
      p_volume_list := NIL;
    IFEND;

    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);

    IF status.normal THEN
      file_server_buffers.p_send_parameters := p_send_to_client_params;
      file_server_buffers.p_send_data := p_send_to_client_data;
      p_file_server_buffers := ^file_server_buffers;
      NEXT p_output_parameters IN file_server_buffers.p_send_parameters;
      pfp$r2_define ({family_location} pfc$server_mainframe, p_input_parameters^.mainframe_id,
            {lfn} osc$null_name, p_complete_path^, p_input_parameters^.cycle_selector,
            p_input_parameters^.password, p_input_parameters^.fs_retention, p_input_parameters^.log,
            p_input_parameters^.retrieve_option, p_input_parameters^.site_archive_option,
            p_input_parameters^.site_backup_option, p_input_parameters^.site_release_option,
            p_input_parameters^.system_privilege, p_input_parameters^.validation_ring,
            p_input_parameters^.device_class, p_ms_request, p_rem_media_request, p_volume_list, cycle_number,
            p_output_parameters^.authority, p_output_parameters^.bytes_allocated, p_file_server_buffers,
            status);
    IFEND;

    IF status.normal THEN
      send_parameters_size := i#current_sequence_position (file_server_buffers.p_send_parameters);
    IFEND;

  PROCEND pfp$r2_df_server_define;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_define_catalog', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_define_catalog
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_catalog_type: ^pft$catalog_types,
      p_complete_path: ^pft$complete_path,
      p_input_parameters: ^pft$df_define_catalog_inp,
      p_ms_request: ^fmt$mass_storage_request_info,
      p_path: ^pft$path,
      selected_catalog_type: pft$catalog_types;

    status.normal := TRUE;
    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;

    IF p_input_parameters^.catalog_type_selected THEN
      NEXT p_catalog_type IN p_param_received_from_client;
      selected_catalog_type := p_catalog_type^;
    ELSE
      selected_catalog_type := pfc$external_catalog;
    IFEND;

    IF p_input_parameters^.mass_storage_request_included THEN
      NEXT p_ms_request IN p_param_received_from_client;
    ELSE
      p_ms_request := NIL;
    IFEND;

    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);

    IF status.normal THEN
      pfp$r2_define_catalog (p_complete_path^, p_input_parameters^.charge_id,
            p_input_parameters^.system_privilege, p_input_parameters^.catalog_type_selected,
            selected_catalog_type, p_ms_request, status);
    IFEND;

  PROCEND pfp$r2_df_server_define_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_define_data', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_define_data
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      file_server_buffers: pft$file_server_buffers,
      mandated_modification_time: pft$mandated_modification_time,
      p_complete_path: ^pft$complete_path,
      p_file_server_buffers: pft$p_file_server_buffers,
      p_input_parameters: ^pft$df_define_data_inp,
      p_ms_request: ^fmt$mass_storage_request_info,
      p_output_parameters: ^pft$df_define_data_outp,
      p_path: ^pft$path,
      p_volume_list: ^array [1 .. * ] of rmt$recorded_vsn;

    status.normal := TRUE;
    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;

    IF p_input_parameters^.mass_storage_request_included THEN
      NEXT p_ms_request IN p_param_received_from_client;
    ELSE
      p_ms_request := NIL;
    IFEND;

    IF p_input_parameters^.volume_list_length <> 0 THEN
      NEXT p_volume_list: [1 .. p_input_parameters^.volume_list_length] IN p_param_received_from_client;
    ELSE
      p_volume_list := NIL;
    IFEND;

    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);

    IF status.normal THEN
      file_server_buffers.p_send_parameters := p_send_to_client_params;
      file_server_buffers.p_send_data := p_send_to_client_data;
      p_file_server_buffers := ^file_server_buffers;
      mandated_modification_time := p_input_parameters^.mandated_modification_time;
      NEXT p_output_parameters IN file_server_buffers.p_send_parameters;
      pfp$r2_define_data ({family_location =} pfc$server_mainframe, p_input_parameters^.mainframe_id,
            {lfn =} osc$null_name, p_complete_path^, p_input_parameters^.cycle_selector,
            p_input_parameters^.update_cycle_statistics, p_input_parameters^.password_selector,
            p_input_parameters^.validation_ring, p_ms_request, p_volume_list,
            p_input_parameters^.purge_cycle_options, p_input_parameters^.replace_cycle_data,
            p_input_parameters^.restore_selections, mandated_modification_time,
            p_output_parameters^.data_residence, p_output_parameters^.authority,
            p_output_parameters^.bytes_allocated, p_file_server_buffers, status);
    IFEND;

    IF status.normal THEN
      p_output_parameters^.mandated_modification_time := mandated_modification_time;
      send_parameters_size := i#current_sequence_position (file_server_buffers.p_send_parameters);
    IFEND;

  PROCEND pfp$r2_df_server_define_data;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_del_all_arc_en', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_del_all_arc_en
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_complete_path: ^pft$complete_path,
      p_input_parameters: ^pft$df_delete_all_arch_ent_inp,
      p_path: ^pft$path;

    send_parameters_length := 0;
    data_size_to_send_to_client := 0;
    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;
    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);
    IF status.normal THEN
      pfp$r2_delete_all_arch_entries (p_complete_path^, p_input_parameters^.cycle_selector, status);
    IFEND;

  PROCEND pfp$r2_df_server_del_all_arc_en;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_del_arch_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_del_arch_entry
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_complete_path: ^pft$complete_path,
      p_input_parameters: ^pft$df_delete_archive_entry_inp,
      p_path: ^pft$path;

    send_parameters_length := 0;
    data_size_to_send_to_client := 0;
    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;
    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);
    IF status.normal THEN
      pfp$r2_delete_archive_entry (p_complete_path^, p_input_parameters^.cycle_selector,
           p_input_parameters^.archive_identification, status);
    IFEND;

  PROCEND pfp$r2_df_server_del_arch_entry;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_delete_permit', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_delete_permit
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_complete_path: ^pft$complete_path,
      p_input_parameters: ^pft$df_delete_permit_inp,
      p_path: ^pft$path;

    send_parameters_length := 0;
    data_size_to_send_to_client := 0;
    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;
    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);
    IF status.normal THEN
      IF p_input_parameters^.object_type = pfc$file_object THEN
        pfp$r2_delete_permit (p_complete_path^, p_input_parameters^.system_privilege,
              p_input_parameters^.group, status);
      ELSEIF p_input_parameters^.object_type = pfc$catalog_object THEN
        pfp$r2_delete_catalog_permit (p_complete_path^, p_input_parameters^.system_privilege,
              p_input_parameters^.group, status);
      ELSE
      IFEND;
    IFEND;
  PROCEND pfp$r2_df_server_delete_permit;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_get_family_set', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_get_family_set
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_input_parameters: ^pft$df_get_family_set_inp,
      p_output_parameters: ^pft$df_get_family_set_outp,
      set_name: stt$set_name;

    status.normal := TRUE;
    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_input_parameters IN p_param_received_from_client;
    osp$get_set_name (p_input_parameters^.family_name, set_name, status);

    IF status.normal THEN
      NEXT p_output_parameters IN p_send_to_client_params;
      p_output_parameters^.set_name := set_name;
      send_parameters_size := i#current_sequence_position (p_send_to_client_params);
    IFEND;

  PROCEND pfp$r2_df_server_get_family_set;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_get_famit_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_get_famit_info
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      complete_path: array [pfc$set_path_index .. pfc$family_path_index] of pft$name,
      group: pft$group,
      p_info: pft$p_info,
      p_input_parameters: ^pft$df_get_mcat_info_inp,
      p_set_name: ^pft$name,
      path: array [pfc$family_name_index .. pfc$family_name_index] of pft$name;

    status.normal := TRUE;
    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_input_parameters IN p_param_received_from_client;
    path [pfc$family_name_index] := p_input_parameters^.family_name;
    convert_path_to_complete_path (path, complete_path, status);
    IF status.normal THEN
      NEXT p_set_name IN p_send_to_client_params;
      p_set_name^ := complete_path [pfc$set_path_index];
      send_parameters_size := #SIZE (p_set_name^);
      NEXT p_info: [[REP dfc$maximum_user_data_area OF cell]] IN p_send_to_client_data;
      group.group_type := pfc$public;
      pfp$r2_get_item_info (complete_path, {system_privilege= } FALSE, group,
            p_input_parameters^.catalog_info_selections, $pft$file_info_selections [], p_info, status);
    IFEND;

    IF status.normal THEN
      send_data_size := i#current_sequence_position (p_info);
    IFEND;
  PROCEND pfp$r2_df_server_get_famit_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_get_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_get_info
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      done: boolean,
      p_complete_path: ^pft$complete_path,
      p_info: pft$p_info,
      p_input_parameters: ^pft$df_get_info_in,
      p_output_parameters: ^pft$df_get_info_out,
      p_path: ^pft$path,
      rpc_segment_reserved: boolean;

    send_parameters_size := 0;
    send_data_size := 0;
    rpc_segment_reserved := FALSE;

    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;
    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);
    IF status.normal THEN
      NEXT p_info: [[REP dfc$maximum_user_data_area OF cell]] IN p_send_to_client_data;

      REPEAT
      done := TRUE;
      IF p_input_parameters^.info_selection = pfc$get_item_info THEN
        pfp$r2_get_item_info (p_complete_path^, p_input_parameters^.system_privilege,
              p_input_parameters^.group, p_input_parameters^.catalog_info_selections,
              p_input_parameters^.file_info_selections, p_info, status);
      ELSE
        pfp$r2_get_multi_item_info (p_complete_path^, p_input_parameters^.system_privilege,
              p_input_parameters^.group, p_input_parameters^.catalog_info_selections,
              p_input_parameters^.file_info_selections, {p_cycle_reservation_criteria} NIL, p_info, status);
      IFEND;

        IF status.normal THEN
          IF NOT rpc_segment_reserved THEN
            send_data_size := i#current_sequence_position (p_info);
          IFEND;
        ELSEIF status.condition = pfe$info_full THEN
          dfp$reserve_server_rpc_segment (p_info, status);
          done := NOT status.normal;
          rpc_segment_reserved := TRUE;
        IFEND;
      UNTIL done;
    IFEND;

    IF status.normal THEN
      NEXT p_output_parameters IN p_send_to_client_params;
      p_output_parameters^.info_size := i#current_sequence_position (p_info);
      send_parameters_size := #SIZE (p_output_parameters^);
    IFEND;
  PROCEND pfp$r2_df_server_get_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_get_mcat_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_get_mcat_info
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      complete_path: array [pfc$set_path_index .. pfc$family_path_index] of pft$name,
      p_info: pft$p_info,
      p_input_parameters: ^pft$df_get_mcat_info_inp,
      p_output_parameters: ^pft$df_get_mcat_info_outp,
      path: array [pfc$family_name_index .. pfc$family_name_index] of pft$name;

    status.normal := TRUE;
    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_input_parameters IN p_param_received_from_client;
    path [pfc$family_name_index] := p_input_parameters^.family_name;
    convert_path_to_complete_path (path, complete_path, status);
    IF status.normal THEN
      dfp$reserve_server_rpc_segment (p_info, status);
      IF status.normal THEN
        pfp$r2_get_master_catalog_info (complete_path, p_input_parameters^.catalog_info_selections, p_info,
              status);
        IF status.normal THEN
          NEXT p_output_parameters IN p_send_to_client_params;
          p_output_parameters^.info_size := i#current_sequence_position (p_info);
          send_parameters_size := #SIZE (p_output_parameters^);
        IFEND;
      IFEND;
    IFEND;
  PROCEND pfp$r2_df_server_get_mcat_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_get_obj_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_get_obj_info
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR p_receive_data: {i^/o} dft$p_receive_data;
     VAR p_send_parameters: dft$p_send_parameters;
     VAR p_send_data: dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      done: boolean,
      p_get_object_info_input: ^pft$df_get_obj_info_in,
      p_get_object_info_output: ^pft$df_get_obj_info_out,
      p_object_info: ^fst$goi_object_information,
      p_object_information: ^SEQ ( * ),
      p_status: ^ost$status,
      p_validation_criteria_input: ^fst$goi_validation_criteria,
      p_validation_criteria_output: ^fst$goi_validation_criteria;

    NEXT p_get_object_info_input IN p_receive_parameters;
    IF p_get_object_info_input = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_get_object_info_input', status);
      RETURN;
    IFEND;

    NEXT p_get_object_info_output IN p_send_parameters;
    IF p_get_object_info_output = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_get_object_info_output', status);
      RETURN;
    IFEND;

    IF p_get_object_info_input^.validation_criterion_count = 0 THEN
      p_validation_criteria_output := NIL;
      NEXT p_object_information: [[REP dfc$maximum_user_data_area OF cell]] IN p_send_data;
    ELSE
      NEXT p_validation_criteria_input: [1 .. p_get_object_info_input^.validation_criterion_count] IN
            p_receive_data;
      IF p_validation_criteria_input = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'NIL p_validation_criteria_input', status);
        RETURN;
      IFEND;

      NEXT p_validation_criteria_output: [1 .. p_get_object_info_input^.validation_criterion_count] IN
            p_send_data;
      IF p_validation_criteria_output = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'NIL p_validation_criteria_output', status);
        RETURN;
      IFEND;

      p_validation_criteria_output^ := p_validation_criteria_input^;
      NEXT p_object_information:
            [[REP (dfc$maximum_user_data_area - #SIZE (p_validation_criteria_output^)) OF cell]] IN
            p_send_data;
    IFEND;

    IF p_object_information = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error, 'NIL p_object_information',
            status);
      RETURN;
    IFEND;

    p_get_object_info_output^.rpc_segment_used := FALSE;

    REPEAT
      done := TRUE;
      RESET p_object_information;
      NEXT p_object_info IN p_object_information;
      IF p_object_info = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error, 'NIL p_object_info',
              status);
        RETURN;
      ELSE
        pfp$initialize_object_info (p_object_info);
      IFEND;

      pfp$r2_get_object_info (pfc$server_mainframe, p_get_object_info_input^.binary_mainframe_id,
            p_get_object_info_input^.evaluated_file_reference, p_get_object_info_input^.information_request,
            p_get_object_info_input^.system_privilege, p_get_object_info_input^.password_selector,
            p_get_object_info_input^.subject_permit_count, p_get_object_info_input^.validation_ring,
            p_validation_criteria_output, p_object_info, p_object_information, status);
      IF NOT status.normal AND (status.condition = pfe$info_full) THEN
        dfp$reserve_server_rpc_segment (p_object_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        done := FALSE;
        p_get_object_info_output^.rpc_segment_used := TRUE;
      IFEND;
    UNTIL done;

    IF status.normal OR (status.condition <> pfe$pf_system_error) THEN
      p_get_object_info_output^.object_info_offset := #OFFSET (p_object_info);
      p_get_object_info_output^.info_size := i#current_sequence_position (p_object_information);

      IF status.normal THEN
        p_get_object_info_output^.status_included := FALSE;
      ELSE
        NEXT p_status IN p_send_parameters;
        IF p_status = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error, 'NIL p_status',
                status);
          RETURN;
        IFEND;

        p_get_object_info_output^.status_included := TRUE;
        p_status^ := status;
        status.normal := TRUE;
      IFEND;

      IF p_get_object_info_output^.rpc_segment_used THEN
        IF p_validation_criteria_output = NIL THEN
          send_data_size := 0;
        ELSE
          send_data_size := #SIZE (p_validation_criteria_output^);
        IFEND;
      ELSE
        IF p_validation_criteria_output = NIL THEN
          send_data_size := i#current_sequence_position (p_object_information);
        ELSE
          send_data_size := #SIZE (p_validation_criteria_output^) +
                i#current_sequence_position (p_object_information);
        IFEND;
      IFEND;

      send_parameters_size := i#current_sequence_position (p_send_parameters);
    IFEND;
  PROCEND pfp$r2_df_server_get_obj_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_get_vol_cl', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_get_vol_cl
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_number_of_volumes: ^amt$volume_number,
      p_output_volume_count: ^amt$volume_number,
      p_unique_volume_list: ^pft$unique_volume_list,
      p_volume_condition_list: ^fst$volume_condition_list;

    status.normal := TRUE;
    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_number_of_volumes IN p_param_received_from_client;

    NEXT p_unique_volume_list: [1 .. p_number_of_volumes^] IN
          p_param_received_from_client;

    NEXT p_output_volume_count IN p_send_to_client_params;
    p_output_volume_count^ := p_number_of_volumes^;

    NEXT p_volume_condition_list: [1 .. p_number_of_volumes^] IN
          p_send_to_client_params;

    pfp$r2_get_vol_condition_list (p_unique_volume_list^, p_volume_condition_list^);

    send_parameters_size := i#current_sequence_position
          (p_send_to_client_params);

  PROCEND pfp$r2_df_server_get_vol_cl;
?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_mark_rel_cand', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_mark_rel_cand
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_complete_path: ^pft$complete_path,
      p_input_parameters: ^pft$df_mark_rel_candidate_inp,
      p_path: ^pft$path;

    send_parameters_length := 0;
    data_size_to_send_to_client := 0;
    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;
    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);
    IF status.normal THEN
      pfp$r2_mark_release_candidate (p_complete_path^, p_input_parameters^.cycle_selector,
           p_input_parameters^.password, p_input_parameters^. validation_ring,
           p_input_parameters^.archive_identification, status);
    IFEND;

  PROCEND pfp$r2_df_server_mark_rel_cand;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_permit', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_permit
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR p_receive_data: {i^/o} dft$p_receive_data;
     VAR p_send_parameters: dft$p_send_parameters;
     VAR p_send_data: dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_complete_path: ^pft$complete_path,
      p_path: ^pft$path,
      p_permit_input: ^pft$df_permit_in;

    NEXT p_permit_input IN p_receive_parameters;
    IF p_permit_input = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error, 'NIL p_permit_input',
            status);
      RETURN;
    IFEND;

    NEXT p_path: [1 .. p_permit_input^.path_length] IN p_receive_parameters;
    IF p_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error, 'NIL p_path in permit',
            status);
      RETURN;
    ELSE
      PUSH p_complete_path: [1 .. (p_permit_input^.path_length + 1)];
      convert_path_to_complete_path (p_path^, p_complete_path^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF p_permit_input^.object_type = pfc$file_object THEN
      pfp$r2_permit (p_complete_path^, p_permit_input^.system_privilege, p_permit_input^.permit_level,
            p_permit_input^.group, p_permit_input^.permit_selections, p_permit_input^.share_requirements,
            p_permit_input^.application_info, status);
    ELSEIF p_permit_input^.object_type = pfc$catalog_object THEN
      pfp$r2_permit_catalog (p_complete_path^, p_permit_input^.system_privilege, p_permit_input^.permit_level,
            p_permit_input^.group, p_permit_input^.permit_selections, p_permit_input^.share_requirements,
            p_permit_input^.application_info, status);
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'invalid object_type in permit', status);
      RETURN;
    IFEND;

    send_parameters_size := 0;
    send_data_size := 0;
  PROCEND pfp$r2_df_server_permit;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_purge', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_purge
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR p_receive_data: {i^/o} dft$p_receive_data;
     VAR p_send_parameters: {i^/o} dft$p_send_parameters;
     VAR p_send_data: {i^/o} dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      authority: pft$authority,
      bytes_released: amt$file_byte_address,
      file_server_buffers: pft$file_server_buffers,
      p_complete_path: ^pft$complete_path,
      p_file_server_buffers: ^pft$file_server_buffers,
      p_path: ^pft$path,
      p_purge_input: ^pft$df_purge_in,
      p_purge_output: ^pft$df_purge_out,
      p_status: ^ost$status;

    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_purge_input IN p_receive_parameters;
    NEXT p_path: [1 .. p_purge_input^.path_length] IN p_receive_parameters;
    IF p_path = NIL THEN
      NEXT p_path: [1 .. p_purge_input^.path_length] IN p_receive_data;
    IFEND;
    PUSH p_complete_path: [1 .. p_purge_input^.path_length + 1];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);

    IF status.normal THEN
      file_server_buffers.p_send_parameters := p_send_parameters;
      file_server_buffers.p_send_data := p_send_data;
      p_file_server_buffers := ^file_server_buffers;
      NEXT p_purge_output IN file_server_buffers.p_send_parameters;
      pfp$r2_purge (p_complete_path^, p_purge_input^.cycle_selector, p_purge_input^.password,
            p_purge_input^.purge_cycle_options, p_purge_input^.system_privilege,
            p_purge_input^.validation_ring, p_purge_output^.authority, p_purge_output^.device_class,
            p_purge_output^.bytes_released, status);

      IF status.normal THEN
        p_purge_output^.status_included := FALSE;
      ELSE
        NEXT p_status IN file_server_buffers.p_send_parameters;
        p_status^ := status;
        p_purge_output^.status_included := TRUE;
      IFEND;

      send_parameters_size := i#current_sequence_position (file_server_buffers.p_send_parameters);
    IFEND;
  PROCEND pfp$r2_df_server_purge;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_purge_catalog', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_purge_catalog
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR p_receive_data: {i^/o} dft$p_receive_data;
     VAR p_send_parameters: dft$p_send_parameters;
     VAR p_send_data: dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_complete_path: ^pft$complete_path,
      p_path: ^pft$path,
      p_purge_catalog_input: ^pft$df_purge_catalog_in;

    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_purge_catalog_input IN p_receive_parameters;

    NEXT p_path: [1 .. p_purge_catalog_input^.path_length] IN p_receive_parameters;
    IF p_path = NIL THEN
      NEXT p_path: [1 .. p_purge_catalog_input^.path_length] IN p_receive_data;
    IFEND;
    PUSH p_complete_path: [1 .. p_purge_catalog_input^.path_length + 1];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);

    IF status.normal THEN
      pfp$r2_purge_catalog (p_complete_path^, p_purge_catalog_input^.system_privilege,
            p_purge_catalog_input^.delete_option, status);
    IFEND;
  PROCEND pfp$r2_df_server_purge_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_put_arch_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_put_arch_entry
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_amd: pft$p_amd,
      p_archive_array_entry: pft$p_archive_array_entry,
      p_complete_path: ^pft$complete_path,
      p_info_record: pft$p_info_record,
      p_input_parameters: ^pft$df_put_archive_entry_inp,
      p_path: ^pft$path;

    status.normal := TRUE;
    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;
    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);

    IF status.normal THEN
      NEXT p_amd: [[REP p_input_parameters^.amd_size OF cell]] IN p_param_received_from_client;
      IF p_amd = NIL THEN
        NEXT p_amd: [[REP p_input_parameters^.amd_size OF cell]] IN p_data_from_client;
        IF p_amd = NIL THEN
          osp$system_error (' Amd not found in pfp$r2_df_server_put_arch_entry', NIL);
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      p_archive_array_entry := ^p_input_parameters^.archive_array_entry;
      pfp$r2_put_archive_entry (p_complete_path^, p_input_parameters^.cycle_selector,
          p_input_parameters^.archive_identification, p_archive_array_entry, p_amd, status);
    IFEND;

  PROCEND pfp$r2_df_server_put_arch_entry;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_put_arch_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_put_arch_info
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_cycle_info_record: pft$p_info_record,
      p_complete_path: ^pft$complete_path,
      p_input_parameters: ^pft$df_put_archive_info_inp,
      p_path: ^pft$path;

    status.normal := TRUE;
    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;
    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);

    IF status.normal THEN
      NEXT p_cycle_info_record: [[REP p_input_parameters^.info_size OF cell]] IN p_param_received_from_client;
      IF p_cycle_info_record = NIL THEN
        NEXT p_cycle_info_record: [[REP p_input_parameters^.info_size OF cell]] IN p_data_from_client;
        IF p_cycle_info_record = NIL THEN
          osp$system_error (' Archive_Info not found in pfp$r2_df_server_put_archive_info', NIL);
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      pfp$r2_put_archive_info (p_complete_path^, p_input_parameters^.cycle_selector,
           p_cycle_info_record, status);
    IFEND;

  PROCEND pfp$r2_df_server_put_arch_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_put_cycle_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_put_cycle_info
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_complete_path: ^pft$complete_path,
      p_input_parameters: ^pft$df_put_cycle_info_inp,
      p_path: ^pft$path;

    status.normal := TRUE;
    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;

    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);

    IF status.normal THEN
      pfp$r2_put_cycle_info (p_complete_path^, p_input_parameters^.cycle_selector,
            p_input_parameters^.password_selector, p_input_parameters^.cycle_array_entry, status);
    IFEND;

  PROCEND pfp$r2_df_server_put_cycle_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_put_item_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_put_item_info
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR p_receive_data: {i^/o} dft$p_receive_data;
     VAR p_send_parameters: {i^/o} dft$p_send_parameters;
     VAR p_send_data: {i^/o} dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_auditable_cycles: ^pft$auditable_cycles,
      p_auditable_permits: ^pft$auditable_permits,
      p_complete_path: ^pft$complete_path,
      p_info_record: ^pft$info_record,
      p_path: ^pft$path,
      p_put_item_info_input: ^pft$df_put_item_info_in,
      p_put_item_info_output: ^pft$df_put_item_info_out,
      p_status: ^ost$status;

    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_put_item_info_input IN p_receive_parameters;

    NEXT p_path: [1 .. p_put_item_info_input^.path_length] IN p_receive_parameters;
    IF p_path = NIL THEN
      NEXT p_path: [1 .. p_put_item_info_input^.path_length] IN p_receive_data;
    IFEND;

    PUSH p_complete_path: [1 .. p_put_item_info_input^.path_length + 1];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT p_info_record: [[REP p_put_item_info_input^.info_size OF cell]] IN p_receive_parameters;
    IF p_info_record = NIL THEN
      NEXT p_info_record: [[REP p_put_item_info_input^.info_size OF cell]] IN p_receive_data;
    IFEND;

    NEXT p_put_item_info_output IN p_send_parameters;
    p_put_item_info_output^.audit_restorations := p_put_item_info_input^.audit_restorations;
    p_put_item_info_output^.all_permits_restored := TRUE;

    IF p_put_item_info_input^.permit_count = 0 THEN
      p_auditable_permits := NIL;
    ELSE
      NEXT p_auditable_permits: [1 .. p_put_item_info_input^.permit_count] IN p_send_data;
      IF p_auditable_permits = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'NIL p_auditable_permits in pfp$r2_df_server_put_item_info', status);
        RETURN;
      IFEND;
    IFEND;

    IF p_put_item_info_input^.cycle_count = 0 THEN
      p_auditable_cycles := NIL;
    ELSE
      NEXT p_auditable_cycles: [1 .. p_put_item_info_input^.cycle_count] IN p_send_data;
      IF p_auditable_cycles = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'NIL p_auditable_cycles in pfp$r2_df_server_put_item_info', status);
        RETURN;
      IFEND;
    IFEND;

    pfp$r2_put_item_info (p_put_item_info_input^.backup_file_version, p_info_record, pfc$server_mainframe,
          p_complete_path^, p_put_item_info_input^.permit_level, p_put_item_info_input^.selection_criteria,
          p_put_item_info_input^.restore_archive_information, p_put_item_info_output^.audit_restorations,
          p_put_item_info_output^.all_permits_restored, p_auditable_permits, p_auditable_cycles, status);

    IF status.normal THEN
      p_put_item_info_output^.status_included := FALSE;
    ELSE
      NEXT p_status IN p_send_parameters;
      p_status^ := status;
      p_put_item_info_output^.status_included := TRUE;
      status.normal := TRUE;
    IFEND;

    p_put_item_info_output^.auditable_permits := p_auditable_permits <> NIL;
    p_put_item_info_output^.auditable_cycles := p_auditable_cycles <> NIL;

    send_parameters_size := i#current_sequence_position (p_send_parameters);
    send_data_size := i#current_sequence_position (p_send_data);
  PROCEND pfp$r2_df_server_put_item_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_release_data', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_release_data
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_complete_path: ^pft$complete_path,
      p_input_parameters: ^pft$df_release_data_inp,
      p_path: ^pft$path,
      p_rd_info: ^pft$release_data_info,
      p_rd_info_out: ^pft$release_data_info;

    send_parameters_length := 0;
    data_size_to_send_to_client := 0;
    NEXT p_input_parameters IN p_param_received_from_client;

    IF p_input_parameters^.release_data_info_included THEN
      NEXT p_rd_info IN p_param_received_from_client;
    ELSE
      p_rd_info := NIL;
    IFEND;

    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;
    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);
    IF status.normal THEN
      pfp$r2_release_data (p_complete_path^, p_input_parameters^.cycle_selector,
            p_input_parameters^.password, p_rd_info, status);
    IFEND;

    IF status.normal AND (p_rd_info <> NIL) THEN
      NEXT p_rd_info_out IN p_send_to_client_params;
      p_rd_info_out^ := p_rd_info^;
      send_parameters_length := i#current_sequence_position (p_send_to_client_params);
    IFEND;

  PROCEND pfp$r2_df_server_release_data;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_rep_arch_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_rep_arch_entry
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_amd: pft$p_amd,
      p_archive_array_entry: pft$p_archive_array_entry,
      p_complete_path: ^pft$complete_path,
      p_info_record: pft$p_info_record,
      p_input_parameters: ^pft$df_replace_arch_entry_inp,
      p_path: ^pft$path;

    status.normal := TRUE;
    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;
    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);

    IF status.normal THEN
      NEXT p_amd: [[REP p_input_parameters^.amd_size OF cell]] IN p_param_received_from_client;
      IF p_amd = NIL THEN
        NEXT p_amd: [[REP p_input_parameters^.amd_size OF cell]] IN p_data_from_client;
        IF p_amd = NIL THEN
          osp$system_error (' Amd not found in pfp$r2_df_server_rep_arch_entry', NIL);
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      p_archive_array_entry := ^p_input_parameters^.archive_array_entry;
      pfp$r2_replace_archive_entry (p_complete_path^, p_input_parameters^.cycle_selector,
          p_input_parameters^.archive_identification, p_archive_array_entry, p_amd, status);
    IFEND;

  PROCEND pfp$r2_df_server_rep_arch_entry;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_rep_rem_me_fmd', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_rep_rem_me_fmd
    (VAR p_param_received_from_client: {i^/o} dft$p_receive_parameters;
     VAR p_data_from_client: {i^/o} dft$p_receive_data;
     VAR p_send_to_client_params: dft$p_send_parameters;
     VAR p_send_to_client_data: dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      error_message: string (80),
      error_message_length: integer,
      p_complete_path: ^pft$complete_path,
      p_file_media_descriptor: ^SEQ ( * ),
      p_input_parameters: ^pft$df_replace_rem_me_fmd_inp,
      p_path: ^pft$path;

    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;
    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);

    IF status.normal THEN
      NEXT p_file_media_descriptor: [[REP p_input_parameters^.file_media_descriptor_size OF cell]]
            IN p_param_received_from_client;
      IF p_file_media_descriptor = NIL THEN
        NEXT p_file_media_descriptor: [[REP p_input_parameters^.file_media_descriptor_size OF cell]]
              IN p_data_from_client;
        IF p_file_media_descriptor = NIL THEN
          STRINGREP (error_message, error_message_length, ' File_media_descriptor_size',
             p_input_parameters^.file_media_descriptor_size, ' too large pfp$r2_df_server_rep_rem_me_fmd');
          osp$system_error (error_message (1, error_message_length), NIL);
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      pfp$r2_replace_rem_media_fmd (p_complete_path^, p_input_parameters^.cycle_selector,
            p_input_parameters^.password_selector, p_file_media_descriptor, status);
    IFEND;
  PROCEND pfp$r2_df_server_rep_rem_me_fmd;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_resolve', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_resolve
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      cycle_reference: fst$cycle_reference,
      path_resolution: fst$path_resolution,
      p_complete_path: ^pft$complete_path,
      p_input_parameters: ^pft$df_resolve_inp,
      p_output_parameters: ^pft$df_resolve_outp,
      p_path: ^pft$path;

    status.normal := TRUE;
    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;
    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);
    IF status.normal THEN
      cycle_reference := p_input_parameters^.cycle_reference;
      pfp$r2_resolve_path (p_complete_path^, p_input_parameters^.system_privilege, cycle_reference,
            path_resolution, status);
    IFEND;

    IF status.normal THEN
      NEXT p_output_parameters IN p_send_to_client_params;
      p_output_parameters^.cycle_reference := cycle_reference;
      p_output_parameters^.path_resolution := path_resolution;
      send_parameters_size := i#current_sequence_position (p_send_to_client_params);
    IFEND;

  PROCEND pfp$r2_df_server_resolve;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_return', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_return
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_send_to_client_data {^Output} : dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      file_server_buffers: pft$file_server_buffers,
      p_file_server_buffers: pft$p_file_server_buffers,
      p_input_parameters: ^pft$df_return_inp,
      p_output_parameters: ^pft$df_return_outp,
      server_eoi: amt$file_byte_address;

    status.normal := TRUE;
    send_parameters_size := 0;
    send_data_size := 0;

    NEXT p_input_parameters IN p_param_received_from_client;
    file_server_buffers.p_send_parameters := p_send_to_client_params;
    file_server_buffers.p_send_data := p_send_to_client_data;
    p_file_server_buffers := ^file_server_buffers;
    NEXT p_output_parameters IN file_server_buffers.p_send_parameters;
    IF (p_input_parameters^.device_class = rmc$mass_storage_device) AND
          p_input_parameters^.attached_for_write THEN
      dmp$fetch_eoi (p_input_parameters^.server_sfid, server_eoi, status);
      IF status.normal AND (server_eoi <> p_input_parameters^.eoi_byte_address) THEN
        dmp$set_eoi (p_input_parameters^.server_sfid, p_input_parameters^.eoi_byte_address,
             status);
      IFEND;
    IFEND;

    pfp$internal_return_file (p_input_parameters^.attached_pf_table_index,
          p_input_parameters^.mainframe_id, p_output_parameters^.authority,
          p_output_parameters^.bytes_allocated_change, status);

    IF status.normal THEN
      send_parameters_size := i#current_sequence_position (file_server_buffers.p_send_parameters);
    IFEND;

  PROCEND pfp$r2_df_server_return;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_save_label', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_save_label
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR p_receive_data: {i/o} dft$p_receive_data;
     VAR p_send_parameters: {i^/o} dft$p_send_parameters;
     VAR p_send_data: {i^/o} dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      apfid: pft$attached_permanent_file_id,
      p_client_complete_path: ^pft$complete_path,
      p_client_save_label_audit_info: ^pft$save_label_audit_info,
      p_file_label: ^fmt$file_label,
      p_save_file_label_audit_seq: ^SEQ ( * ),
      p_save_file_label_input: ^pft$df_save_file_label_in,
      p_save_label_output: ^pft$df_save_label_out,
      p_server_complete_path: ^pft$complete_path,
      p_server_save_label_audit_info: ^pft$save_label_audit_info,
      p_status: ^ost$status;

    NEXT p_save_file_label_input IN p_receive_parameters;
    apfid.family_location := pfc$local_mainframe;
    apfid.attached_pf_table_index := p_save_file_label_input^.attached_pf_table_index;

    IF p_save_file_label_input^.file_label_size = 0 THEN
      p_file_label := NIL;
    ELSEIF p_receive_data = NIL THEN
      NEXT p_file_label: [[REP p_save_file_label_input^.file_label_size OF cell]] IN p_receive_parameters;
    ELSE
      NEXT p_file_label: [[REP p_save_file_label_input^.file_label_size OF cell]] IN p_receive_data;
    IFEND;

    IF p_save_file_label_input^.audit THEN
      PUSH p_save_file_label_audit_seq: [[pft$save_label_audit_info,
            REP UPPERVALUE (pft$file_path_count) OF pft$name]];
    ELSE
      p_save_file_label_audit_seq := NIL;
    IFEND;

    pfp$internal_save_file_label (apfid, p_save_file_label_input^.system_authority,
          p_save_file_label_input^.required_permission, p_file_label, p_save_file_label_audit_seq, status);

    NEXT p_save_label_output IN p_send_parameters;

    IF p_save_file_label_audit_seq = NIL THEN
      p_save_label_output^.audit := FALSE;
    ELSE
      RESET p_save_file_label_audit_seq;
      NEXT p_server_save_label_audit_info IN p_save_file_label_audit_seq;
      NEXT p_server_complete_path: [1 .. p_server_save_label_audit_info^.file_path_count]
            IN p_save_file_label_audit_seq;

      NEXT p_client_save_label_audit_info IN p_send_parameters;
      NEXT p_client_complete_path: [1 .. p_server_save_label_audit_info^.file_path_count]
            IN p_send_parameters;
      IF p_client_complete_path = NIL THEN
        NEXT p_client_complete_path: [1 .. p_server_save_label_audit_info^.file_path_count] IN p_send_data;
      IFEND;

      p_client_complete_path^ := p_server_complete_path^;
      p_client_save_label_audit_info^ := p_server_save_label_audit_info^;
      p_save_label_output^.audit := TRUE;
    IFEND;

    IF status.normal THEN
      p_save_label_output^.status_included := FALSE;
    ELSE
      NEXT p_status IN p_send_parameters;
      IF p_status = NIL THEN
        NEXT p_status IN p_send_data;
      IFEND;
      p_status^ := status;
      p_save_label_output^.status_included := TRUE;
      status.normal := TRUE;
    IFEND;

    send_parameters_size := i#current_sequence_position (p_send_parameters);
    send_data_size := i#current_sequence_position (p_send_data);
  PROCEND pfp$r2_df_server_save_label;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_save_rel_label', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_save_rel_label
    (VAR p_receive_parameters: {i^/o} dft$p_receive_parameters;
     VAR p_receive_data: {i^/o} dft$p_receive_data;
     VAR p_send_parameters: {i^/o} dft$p_send_parameters;
     VAR p_send_data: {i^/o} dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_complete_path: ^pft$complete_path,
      p_file_label: ^fmt$file_label,
      p_path: ^pft$path,
      p_save_label_audit_info: ^pft$save_label_audit_info,
      p_save_released_label_input: ^pft$df_save_released_label_in,
      p_save_label_output: ^pft$df_save_label_out,
      p_status: ^ost$status;

    NEXT p_save_released_label_input IN p_receive_parameters;

    NEXT p_path: [1 .. p_save_released_label_input^.path_length] IN p_receive_parameters;
    IF p_path = NIL THEN
      NEXT p_path: [1 .. p_save_released_label_input^.path_length] IN p_receive_data;
    IFEND;

    PUSH p_complete_path: [1 .. p_save_released_label_input^.path_length + 1];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);
    IF NOT status.normal THEN
      send_parameters_size := 0;
      send_data_size := 0;
      RETURN;
    IFEND;

    NEXT p_file_label: [[REP p_save_released_label_input^.file_label_size OF cell]] IN p_receive_parameters;
    IF p_file_label = NIL THEN
      NEXT p_file_label: [[REP p_save_released_label_input^.file_label_size OF cell]] IN p_receive_data;
    IFEND;

    NEXT p_save_label_output IN p_send_parameters;
    IF p_save_released_label_input^.audit THEN
      NEXT p_save_label_audit_info IN p_send_parameters;
    ELSE
      p_save_label_audit_info := NIL;
    IFEND;

    pfp$r2_save_released_file_label (p_complete_path^, p_save_released_label_input^.cycle_selector,
          p_save_released_label_input^.password_selector, p_file_label,
          p_save_released_label_input^.validation_ring,
          p_save_released_label_input^.update_cycle_statistics, p_save_label_audit_info, status);

    IF p_save_label_audit_info = NIL THEN
      RESET p_send_parameters;
      NEXT p_save_label_output IN p_send_parameters;
      p_save_label_output^.audit := FALSE;
    ELSE
      p_save_label_output^.audit := TRUE;
    IFEND;

    IF status.normal THEN
      p_save_label_output^.status_included := FALSE;
    ELSE
      NEXT p_status IN p_send_parameters;
      p_status^ := status;
      p_save_label_output^.status_included := TRUE;
      status.normal := TRUE;
    IFEND;

    send_parameters_size := i#current_sequence_position (p_send_parameters);
    send_data_size := 0;
  PROCEND pfp$r2_df_server_save_rel_label;

?? TITLE := '  [XDCL, #GATE] pfp$r2_df_server_validate_pw', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_df_server_validate_pw
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      p_complete_path: ^pft$complete_path,
      p_input_parameters: ^pft$df_validate_password_inp,
      p_path: ^pft$path;

    send_parameters_length := 0;
    data_size_to_send_to_client := 0;
    NEXT p_input_parameters IN p_param_received_from_client;
    NEXT p_path: [1 .. p_input_parameters^.path_length] IN p_param_received_from_client;
    PUSH p_complete_path: [1 .. (p_input_parameters^.path_length + 1)];
    convert_path_to_complete_path (p_path^, p_complete_path^, status);
    IF status.normal THEN
      pfp$r2_validate_password (p_complete_path^, p_input_parameters^.password, status);
    IFEND;
  PROCEND pfp$r2_df_server_validate_pw;

?? TITLE := '  [XDCL, #GATE] pfp$relink_file_to_client', EJECT ??

{    This is the server companion procedure to the client procedure
{ pfp$relink_server_file.  This procedure performs the server side processing
{ during server job recovery, when the file is relinked to the client.  This
{ merely involves verifying that the file is still attached on the server, and
{ returning the required device manager information so that the client may be
{ updated.  The state of the file in the attached permanent file table is
{ updated to indicate 'normal'.
{
  PROCEDURE [XDCL, #GATE] pfp$relink_file_to_client
    (VAR p_param_received_from_client {Input} : dft$p_receive_parameters;
     VAR p_data_from_client {Input} : dft$p_receive_data;
     VAR p_send_to_client_params {^Output} : dft$p_send_parameters;
     VAR p_data_to_client {^Output} : dft$p_send_data;
     VAR send_parameters_length: dft$send_parameter_size;
     VAR data_size_to_send_to_client: dft$send_data_size;
     VAR status: ost$status);

    VAR
      error_string: string (100),
      error_string_length: integer,
      file_server_buffers: pft$file_server_buffers,
      gfn_name: ost$name,
      local_status: ost$status,
      p_attached_pf_entry: pft$p_attached_pf_entry,
      p_catalog_path: ^pft$path,
      p_file_server_buffers: ^pft$file_server_buffers,
      p_input_parameters: ^pft$relink_server_file_inp,
      p_output_parameters: ^pft$relink_server_file_outp,
      path_string: ost$string;

    status.normal := TRUE;
    send_parameters_length := 0;
    data_size_to_send_to_client := 0;

    NEXT p_input_parameters IN p_param_received_from_client;
    pfp$lock_apfid (p_input_parameters^.attached_pf_table_index, p_attached_pf_entry, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    IF status.normal AND (p_input_parameters^.global_file_name <>
          p_attached_pf_entry^.internal_cycle_path.cycle_name) THEN
      { What does this mean?  Cant happen?
      pmp$convert_binary_unique_name (p_input_parameters^.global_file_name,
          gfn_name, status);
      STRINGREP (error_string, error_string_length, 'Mismatch in gfn - Client:',
          gfn_name, ' Server:');
      pmp$convert_binary_unique_name (p_attached_pf_entry^.internal_cycle_path.cycle_name,
          gfn_name, status);
      error_string (error_string_length + 1, *) := gfn_name;
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_apfid, error_string, status);
    IFEND;

    IF status.normal AND (p_attached_pf_entry^.sfid_status.recovery_state <> pfc$attached_pf_awaiting_client)
          THEN
      { What does this mean?  Cant happen?
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            ' Unexpected recovery state in relink', status);
    IFEND;

    IF status.normal THEN
      file_server_buffers.p_send_parameters := p_send_to_client_params;
      file_server_buffers.p_send_data := p_data_to_client;
      p_file_server_buffers := ^file_server_buffers;
      NEXT p_output_parameters IN file_server_buffers.p_send_parameters;
      IF p_attached_pf_entry^.device_class = rmc$mass_storage_device THEN
        dmp$fetch_server_sft_info (p_attached_pf_entry^.sfid_status.sfid, p_output_parameters^.dm_parameters,
              p_file_server_buffers, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      { Advance the state of the attached permanent file table.
      p_attached_pf_entry^.sfid_status.recovery_state := pfc$attached_pf_normal;
      p_output_parameters^.usage_selections := p_attached_pf_entry^.usage_selections;
      p_output_parameters^.share_selections := p_attached_pf_entry^.share_selections;
      send_parameters_length := i#current_sequence_position (file_server_buffers.p_send_parameters);
      data_size_to_send_to_client := i#current_sequence_position (file_server_buffers.p_send_data);
    ELSE { Unexpected abnormal status - log the fact for debugging
      { The attached permanent file table entry will be released at the end of job recovery.
      p_catalog_path := p_attached_pf_entry^.p_external_path;
      pfp$convert_cycle_path_to_strng (p_catalog_path^, p_attached_pf_entry^.cycle_number, path_string);
      osp$log_job_recovery_message (path_string.value (1, path_string.size), local_status);
      osp$log_job_recovery_status (status, local_status);
    IFEND;
    pfp$unlock_apfid (p_input_parameters^.attached_pf_table_index, p_attached_pf_entry, local_status);
    pfp$process_unexpected_status (local_status);

  PROCEND pfp$relink_file_to_client;

?? TITLE := '  convert_path_to_complete_path', EJECT ??

{ This routine converts a path to a complete path.  The
{ path is assumed to be capitalized already, and name
{ defaulting completed already.  The complete path is
{ assumed to be of length UPPERBOUND(path) + 1.

  PROCEDURE convert_path_to_complete_path
    (    path: pft$path;
     VAR complete_path: pft$complete_path;
     VAR status: ost$status);

    VAR
      path_index: pft$array_index;

    osp$get_set_name (path [pfc$family_name_index], complete_path [pfc$set_path_index], status);

    IF status.normal THEN
      FOR path_index := 1 TO UPPERBOUND (path) DO
        complete_path [path_index + 1] := path [path_index];
      FOREND;
    IFEND;
  PROCEND convert_path_to_complete_path;

?? OLDTITLE, SKIP := 2 ??
MODEND pfm$r2_df_server_requests;
*DECK DECK=PFM$R2_GET_INFO EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Permanent Files : Information Retrieval' ??
MODULE pfm$r2_get_info;

{ PURPOSE:
{   This module contains the procedures to get information about catalogs,
{   files, and cycles, and about their permits and log entries.

?? NEWTITLE := '  Global Declarations Referenced by this module.' ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$ring_validation_errors
*copyc dmt$error_condition_codes
*copyc dmt$stored_fmd_size
*copyc osd$cybil_structure_definitions
*copyc oss$job_paged_literal
*copyc pfd$catalog
*copyc pfd$catalog_info
*copyc pfd$table_info
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pft$catalog_media_description
*copyc pft$cycle_reservation_criteria
*copyc pft$file_media_description
*copyc pft$reserved_cycles
*copyc pud$selection_criteria
*copyc put$include_volumes_option
?? POP ??
?? EJECT ??
*copyc avp$security_option_active
*copyc dmp$attach_file
*copyc dmp$delete_file_descriptor
*copyc dmp$detach_file
*copyc dmp$get_stored_fmd_header_info
*copyc dmp$get_stored_fmd_volume_list
*copyc fmi$validate_ring_attributes
*copyc fsp$expand_file_label
*copyc i#current_sequence_position
*copyc i#move
*copyc mmp$get_segment_length
*copyc mmp$lock_catalog_segment
*copyc mmp$unlock_segment
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$file_access_condition
*copyc osp$recoverable_system_error
*copyc osp$set_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osv$catalog_name_security
*copyc osv$task_shared_heap
*copyc pfp$access_object
*copyc pfp$build_amd_pointer
*copyc pfp$build_archive_list_pointer
*copyc pfp$build_cycle_list_pointer
*copyc pfp$build_file_label_pointer
*copyc pfp$build_fmd_pointer
*copyc pfp$build_log_list_pointer
*copyc pfp$build_permit_list_pointer
*copyc pfp$check_cycle_busy
*copyc pfp$compute_checksum
*copyc pfp$convert_device_class_to_rm
*copyc pfp$convert_pf_path_to_fs_path
*copyc pfp$cycle_attached_for_write
*copyc pfp$detach_permanent_file
*copyc pfp$detach_reserved_cycles
*copyc pfp$extract_permit_entry
*copyc pfp$increment_usage_counts
*copyc pfp$get_authority
*copyc pfp$get_catalog
*copyc pfp$get_sorted_object_name_list
*copyc pfp$locate_cycle
*copyc pfp$locate_log_entry
*copyc pfp$log_ascii
*copyc pfp$log_path
*copyc pfp$process_unexpected_status
*copyc pfp$reconcile_fmd
*copyc pfp$reduce_permits
*copyc pfp$release_locked_apfid
*copyc pfp$report_system_error
*copyc pfp$return_catalog
*copyc pfp$set_status_abnormal
*copyc pfp$shared_queue
*copyc pfp$validate_ownership
*copyc pfv$binary_catalog_search
*copyc pfv$locked_apfid
*copyc pfv$reserved_cycle_info
*copyc pfv$unlock_catalog_threshold
*copyc pmp$continue_to_cause
*copyc pmp$date_time_compare
*copyc pmp$get_pseudo_mainframe_id
*copyc sfp$emit_audit_statistic
*copyc stp$get_pf_root
*copyc syp$pop_inhibit_job_recovery
*copyc syp$push_inhibit_job_recovery

?? TITLE := '  Global Declarations Declared by this module', EJECT ??

  CONST
    include_radix = TRUE,
    radix = 10;

  VAR
    read_share_selections: [oss$job_paged_literal, READ] pft$share_selections := [pfc$read],
    read_usage_selections: [oss$job_paged_literal, READ] pft$usage_selections := [pfc$read],
    reserved_cycle_array_entry_sp: [oss$job_paged_literal, READ] array [1 .. 46] of boolean :=
          [REP 46 OF FALSE],
    stale_data_mod_date_time: [oss$job_paged_literal, READ] ost$date_time := [0, 1, 1, 0, 0, 0, 0];

?? TITLE := '  [XDCL, #GATE] pfp$r2_get_catalog_segment', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_get_catalog_segment
    (    path: pft$complete_path;
     VAR p_info: pft$p_table_info;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_get_catalog_segment;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE,
      validation_ring_number = 2;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      catalog_segment_length: ost$segment_length,
      charge_id: pft$charge_id,
      local_status: ost$status,
      p_cell_array: ^array [1 .. * ] of cell,
      p_internal_path: ^pft$internal_path,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    VAR
      condition: pmt$condition,
      psa: ^ost$stack_frame_save_area;


    syp$push_inhibit_job_recovery;

  /get_catalog_segment/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL(process_non_local_exit);

      pfp$get_authority (path, NOT system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /get_catalog_segment/;
      IFEND;

      pfp$validate_ownership (authority, path, status);
      IF NOT status.normal THEN
        EXIT /get_catalog_segment/;
      IFEND;

      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$get_catalog (path, pfc$read_access, authority, p_internal_path^, charge_id, permit_entry,
            catalog_locator, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /get_catalog_segment/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      mmp$get_segment_length (catalog_locator.p_catalog_file, validation_ring_number,
            catalog_segment_length, status);
      IF status.normal THEN
        NEXT p_cell_array: [1 .. catalog_segment_length] IN p_info;
        IF p_cell_array = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, '', status);
        ELSE
          i#move (catalog_locator.p_catalog_file, p_cell_array, catalog_segment_length);
        IFEND;
      ELSE
        pfp$report_unexpected_status (status);
      IFEND;
    END /get_catalog_segment/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_get_catalog_segment;

?? TITLE := '  [XDCL, #GATE] pfp$r2_get_family_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_get_family_info
    (    set_name: stt$set_name;
         catalog_info_selections: pft$catalog_info_selections;
     VAR p_info: {i/o} pft$p_info;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_get_family_info;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      charge_id: pft$charge_id,
      internal_path: array [1 .. pfc$set_path_index] of pft$internal_name,
      local_status: ost$status,
      p_record_body: ^pft$info,
      path: array [1 .. pfc$set_path_index] of pft$name,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;

  /get_family_info/
    BEGIN
      catalog_active := FALSE;
      path [pfc$set_path_index] := set_name;
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);

      pfp$get_authority (path, NOT system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /get_family_info/;
      IFEND;

      pfp$get_catalog (path, pfc$read_access, authority, internal_path, charge_id, permit_entry,
            catalog_locator, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /get_family_info/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      locate_info_record_body (p_info, p_record_body, status);
      IF NOT status.normal THEN
        EXIT /get_family_info/;
      IFEND;


      get_multi_object_info (^path, authority, permit_entry, catalog_locator.object_list_descriptor,
            catalog_info_selections, $pft$file_info_selections [], {p_cycle_reservation_criteria} NIL,
            catalog_locator.p_catalog_file, catalog_locator, p_record_body, status);
      IF NOT status.normal THEN
        EXIT /get_family_info/;
      IFEND;


      build_info_record (pfc$family_info_record, i#current_sequence_position (p_record_body), p_info,
            status);
      IF NOT status.normal THEN
        EXIT /get_family_info/;
      IFEND;
    END /get_family_info/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_get_family_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_get_item_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_get_item_info
    (    path: pft$complete_path;
         system_privilege: boolean;
         group: pft$group;
         catalog_info_selections: pft$catalog_info_selections;
         file_info_selections: pft$file_info_selections;
     VAR p_info: {i/o} pft$p_info;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_get_item_info;
    PROCEND initiate_non_local_exit;

    VAR
      access_kind: pft$access_kind,
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      charge_id: pft$charge_id,
      local_status: ost$status,
      object_count: pft$object_count,
      p_internal_path: ^pft$internal_path,
      p_physical_object: ^pft$physical_object,
      p_qualified_object_list: ^pft$object_list,
      p_record_body: ^pft$info,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean,
      valid_objects: pft$object_selections,
      variant_path: pft$variant_path;

    syp$push_inhibit_job_recovery;

  /get_item_info/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);

      pfp$get_authority (path, system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /get_item_info/;
      IFEND;

      IF catalog_info_selections <> $pft$catalog_info_selections [] THEN
        valid_objects := $pft$object_selections [pfc$catalog_object];
      ELSE
        valid_objects := $pft$object_selections [];
      IFEND;

      IF file_info_selections <> $pft$file_info_selections [] THEN
        valid_objects := valid_objects + $pft$object_selections [pfc$file_object];

        IF pfc$cycle_media_descriptor IN file_info_selections THEN
          access_kind := pfc$write_access;
        ELSE
          access_kind := pfc$read_access;
        IFEND;
      IFEND;

      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, access_kind, authority, valid_objects, charge_id,
            catalog_locator, p_physical_object, p_internal_path^, permit_entry, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /get_item_info/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      IF (pfc$catalog_object IN valid_objects) AND osv$catalog_name_security AND
            (authority.ownership = $pft$ownership []) AND ((permit_entry.entry_type =
            pfc$free_permit_entry) OR (permit_entry.usage_permissions = $pft$permit_selections [])) AND
            (p_physical_object^.object_entry.object_type = pfc$catalog_object) THEN
        pfp$return_catalog (catalog_locator, local_status);
        pfp$process_unexpected_status (local_status);

        pfp$get_catalog (path, pfc$read_access, authority, p_internal_path^, charge_id, permit_entry,
              catalog_locator, status);
        IF status.normal THEN
          IF catalog_locator.object_list_descriptor.p_object_list <> NIL THEN
            PUSH p_qualified_object_list: [1 .. UPPERBOUND (catalog_locator.object_list_descriptor.
                  p_object_list^)];
          IFEND;
          build_qualified_object_list (catalog_locator.object_list_descriptor,
                $pft$object_selections [pfc$catalog_object, pfc$file_object],
                catalog_locator.p_catalog_file, authority, permit_entry, object_count,
                p_qualified_object_list);

          IF object_count = 0 THEN
            variant_path.complete_path := TRUE;
            variant_path.p_complete_path := ^path;
            CASE UPPERBOUND (path) OF
            = pfc$family_path_index =
              pfp$set_status_abnormal (variant_path, pfe$unknown_family, status);
            = pfc$master_catalog_path_index =
              pfp$set_status_abnormal (variant_path, pfe$unknown_master_catalog, status);
            ELSE
              pfp$set_status_abnormal (variant_path, pfe$unknown_last_subcatalog, status);
            CASEND;
          IFEND;

          pfp$return_catalog (catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
        IFEND;

        IF status.normal THEN
          pfp$access_object (path, access_kind, authority, valid_objects, charge_id,
                catalog_locator, p_physical_object, p_internal_path^, permit_entry, status);
        IFEND;
      IFEND;
      IF NOT status.normal THEN
        EXIT /get_item_info/;
      IFEND;

      locate_info_record_body (p_info, p_record_body, status);
      IF NOT status.normal THEN
        EXIT /get_item_info/;
      IFEND;

      get_object_info (path, authority, p_physical_object^.object_entry, catalog_info_selections,
            file_info_selections, catalog_locator.p_catalog_file, p_record_body, status);
      IF NOT status.normal THEN
        EXIT /get_item_info/;
      IFEND;

      build_info_record (pfc$item_info_record, i#current_sequence_position (p_record_body), p_info, status);
    END /get_item_info/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_get_item_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_get_master_catalog_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_get_master_catalog_info
    (    path: pft$complete_path;
         catalog_info_selections: pft$catalog_info_selections;
     VAR p_info: {i/o} pft$p_info;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_get_master_catalog_info;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      charge_id: pft$charge_id,
      local_status: ost$status,
      catalog_locator: pft$catalog_locator,
      p_internal_path: ^pft$internal_path,
      p_record_body: ^pft$info,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;

  /get_master_catalog_info/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);

      pfp$get_authority (path, NOT system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /get_master_catalog_info/;
      IFEND;

      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$get_catalog (path, pfc$read_access, authority, p_internal_path^, charge_id, permit_entry,
            catalog_locator, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /get_master_catalog_info/;
      IFEND;


      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      locate_info_record_body (p_info, p_record_body, status);
      IF NOT status.normal THEN
        EXIT /get_master_catalog_info/;
      IFEND;

      get_multi_object_info (^path, authority, permit_entry, catalog_locator.object_list_descriptor,
            catalog_info_selections, $pft$file_info_selections [], {p_cycle_reservation_criteria} NIL,
            catalog_locator.p_catalog_file, catalog_locator, p_record_body, status);
      IF NOT status.normal THEN
        EXIT /get_master_catalog_info/;
      IFEND;

      build_info_record (pfc$master_catalog_info_record, i#current_sequence_position (p_record_body),
            p_info, status);
      IF NOT status.normal THEN
        EXIT /get_master_catalog_info/;
      IFEND;
    END /get_master_catalog_info/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_get_master_catalog_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_get_multi_item_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_get_multi_item_info
    (    path: pft$complete_path;
         system_privilege: boolean;
         group: pft$group;
         catalog_info_selections: pft$catalog_info_selections;
         file_info_selections: pft$file_info_selections;
         p_cycle_reservation_criteria: {input} ^pft$cycle_reservation_criteria;
     VAR p_info: {i/o} pft$p_info;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_get_multi_item_info;
    PROCEND initiate_non_local_exit;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      charge_id: pft$charge_id,
      local_status: ost$status,
      p_internal_path: ^pft$internal_path,
      p_record_body: ^pft$info,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;

  /get_multi_item_info/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);

      pfp$get_authority (path, system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /get_multi_item_info/;
      IFEND;

      IF (p_cycle_reservation_criteria <> NIL) AND (pfv$reserved_cycle_info.p_catalog_path <> NIL) THEN
        {
        { This should never happen but just in case!
        {
        pfp$detach_reserved_cycles (status);
        IF NOT status.normal THEN
          EXIT /get_multi_item_info/;
        IFEND;
      IFEND;

      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      IF (pfc$cycle_media_descriptor IN file_info_selections) OR (p_cycle_reservation_criteria <> NIL) THEN
        pfp$get_catalog (path, pfc$write_access, authority, p_internal_path^, charge_id, permit_entry,
              catalog_locator, status);
      ELSE
        pfp$get_catalog (path, pfc$read_access, authority, p_internal_path^, charge_id, permit_entry,
              catalog_locator, status);
      IFEND;
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /get_multi_item_info/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      locate_info_record_body (p_info, p_record_body, status);
      IF NOT status.normal THEN
        EXIT /get_multi_item_info/;
      IFEND;

      IF p_cycle_reservation_criteria <> NIL THEN
        create_reserved_cycle_info (path, status);
        IF NOT status.normal THEN
          EXIT /get_multi_item_info/;
        IFEND;
      IFEND;

      get_multi_object_info (^path, authority, permit_entry, catalog_locator.object_list_descriptor,
            catalog_info_selections, file_info_selections, p_cycle_reservation_criteria,
            catalog_locator.p_catalog_file, catalog_locator, p_record_body, status);
      IF NOT status.normal THEN
        EXIT /get_multi_item_info/;
      IFEND;

      build_info_record (pfc$multi_item_info_record, i#current_sequence_position (p_record_body), p_info,
            status);
    END /get_multi_item_info/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_get_multi_item_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_get_stored_fmd', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_get_stored_fmd
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
     VAR catalog: boolean;
     VAR catalog_recreated: boolean;
     VAR global_file_name: ost$binary_unique_name;
     VAR stored_fmd: dmt$stored_fmd;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_get_stored_fmd;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      fmd_locator: pft$fmd_locator,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      p_cycle_list: ^pft$cycle_list,
      p_fs_path: ^fst$path,
      p_internal_cycle_path: ^pft$internal_cycle_path,
      p_internal_path: ^pft$internal_path,
      p_physical_cycle: ^pft$physical_cycle,
      p_physical_fmd: ^pft$physical_fmd,
      p_physical_object: ^pft$physical_object,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean,
      variant_path: pft$variant_path;

    syp$push_inhibit_job_recovery;

  /get_stored_fmd/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);

      pfp$get_authority (path, NOT system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /get_stored_fmd/;
      IFEND;

      pfp$validate_ownership (authority, path, status);
      IF NOT status.normal THEN
        EXIT /get_stored_fmd/;
      IFEND;

      IF UPPERBOUND (path) = pfc$family_path_index THEN
        get_root_stored_fmd (path, catalog, catalog_recreated, global_file_name, stored_fmd, status);
        EXIT /get_stored_fmd/;
      IFEND;

      PUSH p_internal_cycle_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$read_access, authority, $pft$object_selections
            [pfc$catalog_object, pfc$file_object], parent_charge_id, catalog_locator, p_physical_object,
            p_internal_cycle_path^.path, permit_entry, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /get_stored_fmd/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      IF p_physical_object^.object_entry.object_type = pfc$file_object THEN
        catalog := FALSE;
        pfp$build_cycle_list_pointer (p_physical_object^.object_entry.cycle_list_locator,
              catalog_locator.p_catalog_file, p_cycle_list);
        pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_physical_cycle, status);
        IF NOT status.normal THEN
          EXIT /get_stored_fmd/;
        IFEND;
        fmd_locator := p_physical_cycle^.cycle_entry.fmd_locator;
      ELSEIF p_physical_object^.object_entry.catalog_object_locator.catalog_type = pfc$external_catalog THEN
        catalog := TRUE;
        catalog_recreated := p_physical_object^.object_entry.catalog_recreated_by_restore;
        fmd_locator := p_physical_object^.object_entry.catalog_object_locator.fmd_locator;
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'Internal_catalogs do not have an FMD.', status);
        EXIT /get_stored_fmd/;
      IFEND;

      pfp$build_fmd_pointer (fmd_locator, catalog_locator.p_catalog_file, p_physical_fmd);
      IF p_physical_fmd = NIL THEN
        variant_path.complete_path := TRUE;
        variant_path.p_complete_path := ^path;
        pfp$set_status_abnormal (variant_path, pfe$undefined_data, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              p_physical_cycle^.cycle_entry.cycle_number, radix, NOT include_radix, status);
      ELSEIF #SIZE (stored_fmd) <> #SIZE (p_physical_fmd^.fmd) THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error, 'FMD size mismatch.',
              status);
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_fs_path^ (1, fs_path_size), status);
      ELSE
        stored_fmd := p_physical_fmd^.fmd;
        IF p_physical_object^.object_entry.object_type = pfc$file_object THEN
          global_file_name := p_physical_cycle^.cycle_entry.internal_cycle_name;
        ELSE
          global_file_name := p_physical_object^.object_entry.catalog_object_locator.global_file_name;
        IFEND;
      IFEND;
    END /get_stored_fmd/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_get_stored_fmd;

?? TITLE := '  [XDCL, #GATE] pfp$r2_get_stored_fmd_size', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_get_stored_fmd_size
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
     VAR device_class: rmt$device_class;
     VAR global_file_name: ost$binary_unique_name;
     VAR fmd_size: dmt$stored_fmd_size;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_get_stored_fmd_size;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      fmd_locator: pft$fmd_locator,
      local_status: ost$status,
      p_cycle_list: ^pft$cycle_list,
      p_internal_cycle_path: ^pft$internal_cycle_path,
      p_internal_path: ^pft$internal_path,
      p_physical_cycle: ^pft$physical_cycle,
      p_physical_fmd: ^pft$physical_fmd,
      p_physical_object: ^pft$physical_object,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean,
      variant_path: pft$variant_path;

    syp$push_inhibit_job_recovery;

  /get_stored_fmd_size/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);

      pfp$get_authority (path, NOT system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /get_stored_fmd_size/;
      IFEND;

      pfp$validate_ownership (authority, path, status);
      IF NOT status.normal THEN
        EXIT /get_stored_fmd_size/;
      IFEND;

      IF UPPERBOUND (path) = pfc$family_path_index THEN
        get_root_stored_fmd_size (path, device_class, global_file_name, fmd_size, status);
        EXIT /get_stored_fmd_size/;
      IFEND;

      PUSH p_internal_cycle_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$read_access, authority, $pft$object_selections
            [pfc$catalog_object, pfc$file_object], parent_charge_id, catalog_locator, p_physical_object,
            p_internal_cycle_path^.path, permit_entry, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /get_stored_fmd_size/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      IF p_physical_object^.object_entry.object_type = pfc$file_object THEN
        pfp$build_cycle_list_pointer (p_physical_object^.object_entry.cycle_list_locator,
              catalog_locator.p_catalog_file, p_cycle_list);
        pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_physical_cycle, status);
        IF NOT status.normal THEN
          EXIT /get_stored_fmd_size/;
        IFEND;
        fmd_locator := p_physical_cycle^.cycle_entry.fmd_locator;
      ELSEIF p_physical_object^.object_entry.catalog_object_locator.catalog_type = pfc$external_catalog THEN
        fmd_locator := p_physical_object^.object_entry.catalog_object_locator.fmd_locator;
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'Internal_catalogs do not have an FMD.', status);
        EXIT /get_stored_fmd_size/;
      IFEND;

      pfp$build_fmd_pointer (fmd_locator, catalog_locator.p_catalog_file, p_physical_fmd);
      IF p_physical_fmd = NIL THEN
        variant_path.complete_path := TRUE;
        variant_path.p_complete_path := ^path;
        pfp$set_status_abnormal (variant_path, pfe$undefined_data, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              p_physical_cycle^.cycle_entry.cycle_number, radix, NOT include_radix, status);
      ELSE
        IF p_physical_object^.object_entry.object_type = pfc$file_object THEN
          IF p_physical_cycle^.cycle_entry.device_information.device_class_defined THEN
            pfp$convert_device_class_to_rm (p_physical_cycle^.cycle_entry.device_information.device_class,
                  device_class);
          ELSE
            device_class := rmc$mass_storage_device;
          IFEND;
          global_file_name := p_physical_cycle^.cycle_entry.internal_cycle_name;
        ELSE
          device_class := rmc$mass_storage_device;
          global_file_name := p_physical_object^.object_entry.catalog_object_locator.global_file_name;
        IFEND;
        fmd_size := #SIZE (p_physical_fmd^.fmd);
      IFEND;
    END /get_stored_fmd_size/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_get_stored_fmd_size;

?? TITLE := '  pfp$unlock_catalog_pages', EJECT ??
{
{  PURPOSE:
{    This interface is intended for use when a catalog is to remain open for
{    an extended period of time and many pages of the catalog are modified.
{    This interface will unlock and relock the catalog.  The effect of this
{    will be to allow all modified pages of the catalog to be written to disk.
{    When a catalog is very large and many of the pages are modified it is
{    possible to exhaust all memory resources with modified catalog pages
{    and cause the system to hang.  Reserve_cycles and detach_reserve_cycles
{    are two good examples of this condition.
{
  PROCEDURE [XDCL] pfp$unlock_catalog_pages
    (VAR catalog_locator: {i/o} pft$catalog_locator;
     VAR status: ost$status);

    IF catalog_locator.attached AND catalog_locator.open AND catalog_locator.locked THEN
      IF catalog_locator.flush_catalog_pages THEN
        mmp$unlock_segment (catalog_locator.p_catalog_file, mmc$lus_protected_write, osc$nowait, status);
      ELSE
        mmp$unlock_segment (catalog_locator.p_catalog_file, mmc$lus_none, osc$nowait, status);
      IFEND;
      catalog_locator.locked := FALSE;
      pfp$process_unexpected_status (status);
    ELSE
      RETURN;
    IFEND;

    IF status.normal THEN
      IF catalog_locator.access_kind = pfc$read_access THEN
        mmp$lock_catalog_segment (catalog_locator.p_catalog_file, mmc$lus_lock_for_read, osc$wait, status);
      ELSE
        mmp$lock_catalog_segment (catalog_locator.p_catalog_file, mmc$lus_lock_for_write, osc$wait, status);
      IFEND;

      catalog_locator.locked := status.normal;
      IF NOT status.normal THEN
        IF osp$file_access_condition (status) THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_volume_unavailable, '', status);
        ELSE
          pfp$report_unexpected_status (status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND pfp$unlock_catalog_pages;

?? TITLE := '  [INLINE] allocate_cycle_directory', EJECT ??

  PROCEDURE [INLINE] allocate_cycle_directory
    (    number_of_cycles: pft$cycle_count;
     VAR p_cycle_array_extended: {Input, Output} pft$p_info;
     VAR p_cycle_directory_array: pft$p_cycle_directory_array;
     VAR status: ost$status);

    VAR
      p_cycle_directory_body: pft$p_info;

    locate_info_record_body (p_cycle_array_extended, p_cycle_directory_body, status);
    IF status.normal THEN
      IF number_of_cycles > 0 THEN
        NEXT p_cycle_directory_array: [1 .. number_of_cycles] IN p_cycle_directory_body;
        IF p_cycle_directory_array = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, ' cycle directory ', status);
        IFEND;
      ELSE
        p_cycle_directory_array := NIL;
      IFEND;

      IF status.normal THEN
        build_info_record (pfc$cycle_directory_record, i#current_sequence_position (p_cycle_directory_body),
              p_cycle_array_extended, status);
      IFEND;
    IFEND;
  PROCEND allocate_cycle_directory;

?? TITLE := '  allocate_directory_array', EJECT ??

  PROCEDURE allocate_directory_array (VAR p_info: pft$p_info;
        directory_size: integer;
    VAR p_directory_array: pft$p_directory_array;
    VAR status: ost$status);

    VAR
      p_record_body: pft$p_info;

    locate_info_record_body (p_info, p_record_body, status);
    IF status.normal THEN
      IF directory_size > 0 THEN
        NEXT p_directory_array: [1 .. directory_size] IN p_record_body;
        IF p_directory_array = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, '', status);
        IFEND;
      ELSE
        p_directory_array := NIL;
      IFEND;

      IF status.normal THEN
        build_info_record (pfc$directory_array_record, i#current_sequence_position (p_record_body), p_info,
              status);
      IFEND;
    IFEND;
  PROCEND allocate_directory_array;

?? TITLE := '  append_log_entry', EJECT ??

  PROCEDURE append_log_entry (log_entry: pft$log_entry;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

    VAR
      log_info: pft$log_array_entry,
      p_log_info: pft$p_log_array_entry;

    status.normal := TRUE;

    IF log_entry.entry_type = pfc$normal_log_entry THEN
      NEXT p_log_info IN p_info;
      IF p_log_info <> NIL THEN
        log_info.user_id := log_entry.user_id;
        log_info.access_date_time := log_entry.access_date_time;
        log_info.access_count := log_entry.access_count;
        log_info.last_cycle := log_entry.last_cycle;
        p_log_info^ := log_info;
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, '', status);
      IFEND;
    IFEND;
  PROCEND append_log_entry;

?? TITLE := '  append_permit_entry', EJECT ??

  PROCEDURE append_permit_entry (permit_entry: pft$permit_entry;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

    VAR
      p_permit_info: pft$p_permit_array_entry,
      permit_info: pft$permit_array_entry;

    status.normal := TRUE;

    IF permit_entry.entry_type = pfc$normal_permit_entry THEN
      NEXT p_permit_info IN p_info;
      IF p_permit_info <> NIL THEN
        permit_info.permit_type := pfc$direct_permit;
        permit_info.group := permit_entry.group;
        permit_info.usage_permissions := permit_entry.usage_permissions;
        permit_info.share_requirements := permit_entry.share_requirements;
        permit_info.application_info := permit_entry.application_info;
        p_permit_info^ := permit_info;
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, '', status);
      IFEND;
    IFEND;
  PROCEND append_permit_entry;

?? TITLE := '  audit_cycle_attachment', EJECT ??

  PROCEDURE audit_cycle_attachment
    (    p_complete_path: {input} ^pft$complete_path;
         cycle_number: pft$cycle_number;
         ownership: pft$ownership;
         audit_status: ost$status);

    VAR
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id,
      cycle_selector: pft$cycle_selector,
      usage_selections: pft$usage_selections;

    audit_information.audited_operation := sfc$ao_fs_attach_file;
    audited_object.variant_path.complete_path := TRUE;
    audited_object.variant_path.p_complete_path := p_complete_path;
    audited_object.object_type := sfc$afsot_cycle;
    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := cycle_number;
    audited_object.cycle_selector_p := ^cycle_selector;
    audited_object.device_class := rmc$mass_storage_device;
    audit_information.attach_file.object_id_p := ^audited_object;
    audit_information.attach_file.ownership := ownership;
    usage_selections := $pft$usage_selections [pfc$read];
    audit_information.attach_file.access_mode_p := ^usage_selections;
    sfp$emit_audit_statistic (audit_information, audit_status);
  PROCEND audit_cycle_attachment;

?? TITLE := '  build_info_record', EJECT ??

  PROCEDURE build_info_record (record_type: pft$info_record_type;
        body_size: pft$info_record_body_size;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

    VAR
      local_body_size: pft$info_record_body_size,
      p_info_record: pft$p_info_record;

    IF p_info <> NIL THEN
      IF body_size = 0 THEN
        local_body_size := 1;
      ELSE
        local_body_size := body_size;
      IFEND;

      NEXT p_info_record: [[REP local_body_size OF cell]] IN p_info;
      IF p_info_record <> NIL THEN
        p_info_record^.record_type := record_type;
        p_info_record^.body_size := local_body_size;
        status.normal := TRUE;
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, '', status);
      IFEND;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, '', status);
    IFEND;
  PROCEND build_info_record;

?? TITLE := '  build_qualified_object_list', EJECT ??

  PROCEDURE build_qualified_object_list
    (    object_list_descriptor: pft$object_list_descriptor;
         selected_objects: pft$object_selections;
         p_catalog_file: pft$p_catalog_file;
         authority: pft$authority;
         permit_entry: pft$permit_entry;
     VAR object_count: pft$object_count;
     VAR p_qualified_object_list: pft$p_object_list);

    VAR
      max_object_name_index: pft$object_count,
      max_sorted_object_index: pft$object_count,
      object_index: pft$object_index,
      object_name_index: pft$object_index,
      object_qualified: boolean,
      p_object_list: ^pft$object_list,
      p_object_name_list: ^pft$object_name_list,
      sorted_object_index: pft$object_index;

    object_count := 0;
    p_object_list := object_list_descriptor.p_object_list;
    IF p_object_list = NIL THEN
      RETURN;
    IFEND;

    IF pfv$binary_catalog_search THEN
      max_sorted_object_index := object_list_descriptor.sorted_object_count;
      sorted_object_index := 1;
      object_name_index := 1;

      IF object_list_descriptor.sorted_object_count = 0 THEN
        PUSH p_object_name_list: [1 .. UPPERBOUND (p_object_list^)];
      ELSE
        PUSH p_object_name_list: [1 .. UPPERBOUND (p_object_list^) -
              object_list_descriptor.sorted_object_count];
      IFEND;

      pfp$get_sorted_object_name_list (object_list_descriptor, p_object_name_list, max_object_name_index);

      WHILE (sorted_object_index <= max_sorted_object_index) OR
            (object_name_index <= max_object_name_index) DO
        IF object_name_index > max_object_name_index THEN
          object_index := sorted_object_index;
          sorted_object_index := sorted_object_index + 1;
        ELSEIF sorted_object_index > max_sorted_object_index THEN
          object_index := p_object_name_list^ [object_name_index].object_index;
          object_name_index := object_name_index + 1;
        ELSEIF p_object_list^ [sorted_object_index].object_entry.external_object_name >
              p_object_name_list^ [object_name_index].object_name THEN
          object_index := p_object_name_list^ [object_name_index].object_index;
          object_name_index := object_name_index + 1;
        ELSE
          object_index := sorted_object_index;
          sorted_object_index := sorted_object_index + 1;
        IFEND;

        test_object_qualifications (p_object_list^ [object_index].object_entry, selected_objects,
              p_catalog_file, authority, permit_entry, object_qualified);
        IF object_qualified THEN
          object_count := object_count + 1;
          p_qualified_object_list^ [object_count] := p_object_list^ [object_index];
        IFEND;
      WHILEND;
    ELSE
      FOR object_index := 1 TO UPPERBOUND (p_object_list^) DO
        test_object_qualifications (p_object_list^ [object_index].object_entry, selected_objects,
              p_catalog_file, authority, permit_entry, object_qualified);
        IF object_qualified THEN
          object_count := object_count + 1;
          p_qualified_object_list^ [object_count] := p_object_list^ [object_index];
        IFEND;
      FOREND;
    IFEND;
  PROCEND build_qualified_object_list;

?? TITLE := '  check_file_attributes', EJECT ??

  PROCEDURE check_file_attributes
    (    usage_mode: pft$usage_selections;
         validation_ring: ost$valid_ring;
         p_cycle: {input} ^pft$physical_cycle;
         p_catalog_file: {input} ^pft$catalog_file;
     VAR cycle_included: boolean;
     VAR status: ost$status);

    TYPE
      file_organization_set = set of amt$file_organization;

    VAR
      cycle_formerly_opened_info: fmt$cycle_formerly_opened_info,
      expanded_label: bat$static_label_attributes,
      p_physical_label: ^pft$physical_file_label;

    cycle_included := FALSE;
    status.normal := TRUE;

    pfp$build_file_label_pointer (p_cycle^.cycle_entry.file_label_locator, p_catalog_file, p_physical_label);
    IF p_physical_label <> NIL THEN
      fsp$expand_file_label (^p_physical_label^.file_label, expanded_label,
            cycle_formerly_opened_info.cycle_previously_opened, status);
      IF NOT status.normal OR NOT cycle_formerly_opened_info.cycle_previously_opened THEN
        RETURN;
      IFEND;

      cycle_formerly_opened_info.ring_attributes := expanded_label.ring_attributes;
      cycle_formerly_opened_info.ring_attributes_source := expanded_label.ring_attributes_source;

      fmi$validate_ring_attributes (cycle_formerly_opened_info, usage_mode, validation_ring,
            cycle_included);
      IF NOT cycle_included THEN
        osp$set_status_abnormal (amc$access_method_id, ame$ring_validation_error, '', status);
        RETURN;
      IFEND;
      {
      { Determine if AAM file has selected a logging option of ENABLE_MEDIA_RECOVERY.
      {
      cycle_included := NOT (((expanded_label.file_organization_source <> amc$undefined_attribute) AND
            (expanded_label.file_organization IN $file_organization_set
            [amc$indexed_sequential, amc$direct_access, amc$system_key])) AND
            ((expanded_label.logging_options_source <> amc$undefined_attribute) AND
            (amc$enable_media_recovery IN expanded_label.logging_options)));
    IFEND;
  PROCEND check_file_attributes;

?? TITLE := '  check_if_access_included', EJECT ??

  PROCEDURE check_if_access_included
    (    selection_criteria: put$selection_criteria;
         cycle_array_entry: pft$cycle_array_entry_version_2;
     VAR cycle_included: boolean);

    VAR
      before_time_after_cycle_time: boolean,
      comparison_result: pmt$comparison_result,
      cycle_date_time: ost$date_time,
      cycle_time_after_after_time: boolean,
      ignore_status: ost$status;

    IF (NOT selection_criteria.after_date_time_selected) AND
          (NOT selection_criteria.before_date_time_selected) THEN
      cycle_included := TRUE;
    ELSE
      select_cycle_date_time (cycle_array_entry, selection_criteria.mode, cycle_date_time);
      IF selection_criteria.after_date_time_selected THEN
        pmp$date_time_compare (cycle_date_time, selection_criteria.after_date_time, comparison_result,
              ignore_status);
        cycle_time_after_after_time := (comparison_result = pmc$left_is_greater);
      IFEND;
      IF selection_criteria.before_date_time_selected THEN
        pmp$date_time_compare (selection_criteria.before_date_time, cycle_date_time, comparison_result,
              ignore_status);
        before_time_after_cycle_time := (comparison_result = pmc$left_is_greater);
      IFEND;
      IF selection_criteria.after_date_time_selected AND selection_criteria.before_date_time_selected THEN
        IF selection_criteria.after_time_after_before_time THEN
          cycle_included := cycle_time_after_after_time OR before_time_after_cycle_time;
        ELSE
          cycle_included := cycle_time_after_after_time AND before_time_after_cycle_time;
        IFEND;
      ELSEIF selection_criteria.after_date_time_selected THEN
        cycle_included := cycle_time_after_after_time;
      ELSE
        cycle_included := before_time_after_cycle_time;
      IFEND;
    IFEND;

    IF cycle_array_entry.sparse_allocation OR (cycle_array_entry.device_class <> rmc$mass_storage_device)
          THEN
      cycle_included := FALSE;
    IFEND;

  PROCEND check_if_access_included;

?? TITLE := '  [INLINE] check_if_high_cycle_included', EJECT ??

  PROCEDURE [INLINE] check_if_high_cycle_included
    (    cycle_number: pft$cycle_index;
         p_cycle_list: {input} ^pft$cycle_list;
         p_cycle_reservation_criteria: {input} ^pft$cycle_reservation_criteria;
     VAR cycle_included: boolean);

    VAR
      cycle_index: pft$cycle_count,
      higher_cycles: pft$cycle_count;


    cycle_included := TRUE;
    IF p_cycle_reservation_criteria <> NIL THEN
      IF p_cycle_reservation_criteria^.exclude_highest_cycles = 0 THEN
        cycle_included := TRUE;
      ELSEIF p_cycle_reservation_criteria^.exclude_highest_cycles = pfc$maximum_cycle_number THEN
        cycle_included := FALSE;
      ELSE
        higher_cycles := 0;
        FOR cycle_index := 1 TO UPPERBOUND (p_cycle_list^) DO
          IF (p_cycle_list^ [cycle_index].cycle_entry.entry_type = pfc$normal_cycle_entry) AND
                (p_cycle_list^ [cycle_index].cycle_entry.cycle_number > cycle_number) THEN
            higher_cycles := higher_cycles + 1;
          IFEND;
        FOREND;
        cycle_included := (higher_cycles >= p_cycle_reservation_criteria^.exclude_highest_cycles);
      IFEND;
    IFEND;
  PROCEND check_if_high_cycle_included;

?? TITLE := '  check_if_size_included ', EJECT ??

  PROCEDURE check_if_size_included
    (    large_cycles_lower_bound: amt$file_length;
         small_cycles_upper_bound: amt$file_length;
         cycle_size: amt$file_length;
         p_cycle: {input} ^pft$physical_cycle;
     VAR cycle_included: boolean);

    VAR
      local_status: ost$status,
      comparison_result: pmt$comparison_result;

    cycle_included := FALSE;
    IF p_cycle^.cycle_entry.data_modification_date_time.year <= 0 THEN
      RETURN;
    ELSE
      pmp$date_time_compare (p_cycle^.cycle_entry.data_modification_date_time,
            p_cycle^.cycle_entry.cycle_statistics.modification_date_time, comparison_result, local_status);
      IF comparison_result = pmc$right_is_greater THEN
        RETURN;
      IFEND;
    IFEND;

    cycle_included := (cycle_size >= large_cycles_lower_bound) AND (cycle_size <= small_cycles_upper_bound);

  PROCEND check_if_size_included;

?? TITLE := '  check_if_usage_included ', EJECT ??

  PROCEDURE check_if_usage_included
    (    usage_intentions: pft$permit_selections;
         share_intentions: pft$share_selections;
         mainframe_id: pmt$binary_mainframe_id;
         p_cycle: {input} ^pft$physical_cycle;
         p_catalog: {input} ^pft$catalog_file;
     VAR cycle_included: boolean);

   VAR
     dummy_path: [STATIC] array [1 .. 1] of pft$name := ['DUMMY'],
     local_status: ost$status;

     IF p_cycle^.cycle_entry.attach_status.attach_count = 0 THEN
       cycle_included := TRUE;
     ELSE
       pfp$check_cycle_busy (dummy_path, usage_intentions, share_intentions, mainframe_id, p_catalog,
             p_cycle^.cycle_entry, local_status);
       cycle_included := local_status.normal;
     IFEND;
  PROCEND check_if_usage_included;

?? TITLE := '  check_if_volume_included ', EJECT ??

  PROCEDURE check_if_volume_included
    (    include_volumes_option: put$include_volumes_option;
         p_stored_fmd: ^dmt$stored_fmd;
         p_included_volume_list: ^pft$volume_list;
     VAR volume_included: boolean;
     VAR status: ost$status);

    VAR
      file_volume: integer,
      fmd_header: pft$fmd_header,
      included_volume: integer,
      p_actual_volume_list: ^pft$volume_list;

    status.normal := TRUE;

    IF p_included_volume_list = NIL THEN
      volume_included := TRUE;
    ELSE
      volume_included := FALSE;
      dmp$get_stored_fmd_header_info (p_stored_fmd, fmd_header, status);
      IF NOT status.normal OR (fmd_header.number_of_subfiles <= 0) THEN
        RETURN;
      IFEND;

      PUSH p_actual_volume_list: [1 .. fmd_header.number_of_subfiles];
      dmp$get_stored_fmd_volume_list (p_stored_fmd, p_actual_volume_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF include_volumes_option = puc$initial_volume THEN

      /search_for_volume_one/
        FOR included_volume := 1 TO UPPERBOUND (p_included_volume_list^) DO
          IF p_actual_volume_list^ [1] = p_included_volume_list^ [included_volume] THEN
            volume_included := TRUE;
            EXIT /search_for_volume_one/;
          IFEND;
        FOREND /search_for_volume_one/;

      ELSE { multiple volumes

      /search_included_volumes/
        FOR included_volume := 1 TO UPPERBOUND (p_included_volume_list^) DO
          FOR file_volume := 1 TO UPPERBOUND (p_actual_volume_list^) DO
            IF p_actual_volume_list^ [file_volume] = p_included_volume_list^ [included_volume] THEN
              volume_included := TRUE;
              EXIT /search_included_volumes/;
            IFEND;
          FOREND;
        FOREND /search_included_volumes/;
      IFEND;
    IFEND;
  PROCEND check_if_volume_included;

?? TITLE := '  create_reserved_cycle_info', EJECT ??

  PROCEDURE create_reserved_cycle_info
    (    path: pft$complete_path;
     VAR status: ost$status);


    osp$set_signature_lock (pfv$reserved_cycle_info.signature_lock, osc$nowait, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$reserved_cycle_table_locked, '', status);
      RETURN;
    IFEND;

    ALLOCATE pfv$reserved_cycle_info.p_catalog_path: [1 .. UPPERBOUND (path)] IN osv$task_shared_heap^;
    IF pfv$reserved_cycle_info.p_catalog_path = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
             'Unable to allocate space in Task Shared heap.', status);
      RETURN;
    IFEND;

    pfv$reserved_cycle_info.p_catalog_path^ := path;

  PROCEND create_reserved_cycle_info;

?? TITLE := '  get_amd', EJECT ??

  PROCEDURE { [INLINE] } get_amd (
        p_physical_amd: pft$p_physical_amd;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

    VAR
      p_amd: pft$p_amd,
      p_record_body: pft$p_info,
      size: pft$amd_size;

    locate_info_record_body (p_info, p_record_body, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_physical_amd = NIL THEN
      RETURN;
    IFEND;

    size := #SIZE (p_physical_amd^.amd);
    NEXT p_amd: [[REP size OF cell]] IN p_record_body;
    IF p_amd = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, '', status);
      RETURN;
    IFEND;
    p_amd^ := p_physical_amd^.amd;

    build_info_record (pfc$archive_amd_record, i#current_sequence_position (p_record_body), p_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND get_amd;

?? TITLE := '  get_archive_entry', EJECT ??

  PROCEDURE { [INLINE] } get_archive_entry (
        p_archive: pft$p_archive;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

    VAR
      p_archive_array_entry: pft$p_archive_array_entry,
      p_record_body: pft$p_info;

    locate_info_record_body (p_info, p_record_body, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT p_archive_array_entry IN p_record_body;
    IF p_archive_array_entry = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, '', status);
    ELSE

       p_archive_array_entry^.version := p_archive^.archive_entry.version;

       p_archive_array_entry^.archive_date_time := p_archive^.archive_entry.archive_date_time;

       p_archive_array_entry^.archive_identification := p_archive^.archive_entry.archive_identification;

       p_archive_array_entry^.file_size := p_archive^.archive_entry.file_size;

       p_archive_array_entry^.last_release_date_time := p_archive^.archive_entry.last_release_date_time;

       p_archive_array_entry^.last_retrieval_status := p_archive^.archive_entry.last_retrieval_status;

       p_archive_array_entry^.modification_date_time := p_archive^.archive_entry.modification_date_time;

       p_archive_array_entry^.release_candidate := p_archive^.archive_entry.release_candidate;

       p_archive_array_entry^.reserved_archive_array_entry_sp :=

        p_archive^.archive_entry.reserved_archive_entry_space;
       build_info_record (pfc$archive_array_entry_record, i#current_sequence_position

          (p_record_body), p_info, status);
     IFEND;


  PROCEND get_archive_entry;

?? TITLE := '  get_archive_list', EJECT ??

  PROCEDURE { [INLINE] } get_archive_list (
        p_archive_list: pft$p_archive_list;
        p_catalog_file: pft$p_catalog_file;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

    VAR
      archive_index: pft$archive_index,
      p_archive: pft$p_archive,
      p_physical_amd: pft$p_physical_amd,
      p_record_body: pft$p_info;

    status.normal := TRUE;

    /get_all_list_entries/
    FOR archive_index := 1 TO UPPERBOUND (p_archive_list^) DO
      p_archive := ^p_archive_list^[archive_index];
      locate_info_record_body (p_info, p_record_body, status);
      IF NOT status.normal THEN
        EXIT /get_all_list_entries/;
      IFEND;
      get_archive_entry (p_archive, p_record_body, status);
      IF NOT status.normal THEN
        EXIT /get_all_list_entries/;
      IFEND;
      pfp$build_amd_pointer (p_archive^.archive_entry.amd_locator, p_catalog_file, p_physical_amd);
      get_amd (p_physical_amd, p_record_body, status);
      IF NOT status.normal THEN
        EXIT /get_all_list_entries/;
      IFEND;
      build_info_record (pfc$archive_entry_record, i#current_sequence_position (p_record_body), p_info,
          status);
      IF NOT status.normal THEN
        EXIT /get_all_list_entries/;
      IFEND;
    FOREND;

  PROCEND get_archive_list;

?? TITLE := '  [INLINE] get_catalog_description_info', EJECT ??

  PROCEDURE [INLINE] get_catalog_description_info (catalog_object: pft$object_entry;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

    VAR
      p_catalog_description: pft$p_catalog_description,
      p_record_body: pft$p_info;

    locate_info_record_body (p_info, p_record_body, status);
    IF status.normal THEN
      NEXT p_catalog_description IN p_record_body;
      IF p_catalog_description <> NIL THEN
        p_catalog_description^.name := catalog_object.external_object_name;
        p_catalog_description^.charge_id := catalog_object.charge_id;
        build_info_record (pfc$catalog_description_record, i#current_sequence_position (p_record_body),
              p_info, status);
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, '', status);
      IFEND;
    IFEND;
  PROCEND get_catalog_description_info;

?? TITLE := '  get_catalog_info', EJECT ??

  PROCEDURE get_catalog_info (catalog_object: pft$object_entry;
        catalog_info_selections: pft$catalog_info_selections;
        p_catalog_file: pft$p_catalog_file;
        authority: pft$authority;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

    VAR
      p_permit_list: pft$p_permit_list,
      p_record_body: pft$p_info;

    locate_info_record_body (p_info, p_record_body, status);
    IF status.normal THEN
      IF pfc$catalog_description IN catalog_info_selections THEN
        get_catalog_description_info (catalog_object, p_record_body, status);
      IFEND;

      IF status.normal AND (pfc$catalog_permits IN catalog_info_selections) THEN
        pfp$build_permit_list_pointer (catalog_object.permit_list_locator, p_catalog_file, p_permit_list);
        get_permit_info (p_permit_list, authority, p_record_body, status);
      IFEND;

      IF status.normal AND (pfc$catalog_media_descriptor IN catalog_info_selections) THEN
        get_catalog_media_info (catalog_object.internal_object_name, catalog_object.catalog_object_locator,
              p_catalog_file, p_record_body, status);
      IFEND;

      IF status.normal THEN
        build_info_record (pfc$catalog_group_record, i#current_sequence_position (p_record_body), p_info,
              status);
      IFEND;
    IFEND;
  PROCEND get_catalog_info;

?? TITLE := '  [INLINE] get_catalog_media_info', EJECT ??

  PROCEDURE [INLINE] get_catalog_media_info
    (    internal_name: pft$internal_name;
         catalog_object_locator: pft$catalog_object_locator;
         p_catalog_file: pft$p_catalog_file;
     VAR p_catalog_group: {Input, Output} pft$p_info;
     VAR status: ost$status);

    VAR
      p_catalog_media_description: pft$p_catalog_media_description,
      p_catalog_media_record_body: pft$p_info,
      p_fmd_info: ^SEQ ( * ),
      p_physical_fmd: pft$p_physical_fmd;

    locate_info_record_body (p_catalog_group, p_catalog_media_record_body, status);
    IF status.normal THEN
      NEXT p_catalog_media_description IN p_catalog_media_record_body;
      IF p_catalog_media_description = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'Catalog media ', status);
      ELSE
        p_catalog_media_description^.internal_name := internal_name;
        p_catalog_media_description^.catalog_type := catalog_object_locator.catalog_type;

        IF catalog_object_locator.catalog_type = pfc$external_catalog THEN
          pfp$build_fmd_pointer (catalog_object_locator.fmd_locator, p_catalog_file, p_physical_fmd);
          IF p_physical_fmd <> NIL THEN
            p_catalog_media_description^.global_file_name := catalog_object_locator.global_file_name;
            p_catalog_media_description^.file_media_type.media_version := pfc$file_media_disk_version_1;
            p_catalog_media_description^.file_media_type.device_class := rmc$mass_storage_device;
            p_catalog_media_description^.checksum := p_physical_fmd^.checksum;
            NEXT p_fmd_info: [[REP #SIZE (p_physical_fmd^.fmd) OF cell]] IN p_catalog_media_record_body;
            IF p_fmd_info = NIL THEN
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, 'Catalog fmd ', status);
              RETURN;
            ELSE
              p_fmd_info^ := p_physical_fmd^.fmd;
            IFEND;
          IFEND
        IFEND;

        build_info_record (pfc$catalog_media_record, i#current_sequence_position
              (p_catalog_media_record_body), p_catalog_group, status);
      IFEND;
    IFEND;
  PROCEND get_catalog_media_info;

?? TITLE := '  get_cycle_archive_info', EJECT ??

  PROCEDURE get_cycle_archive_info (
        p_archive_list: pft$p_archive_list;
        p_catalog_file: pft$p_catalog_file;
    VAR p_info: {i/o} pft$p_info;
    VAR status: ost$status);

    VAR
      p_record_body: pft$p_info;

    locate_info_record_body (p_info, p_record_body, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_archive_list (p_archive_list, p_catalog_file, p_record_body, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    build_info_record (pfc$archive_info_record, i#current_sequence_position (p_record_body), p_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND get_cycle_archive_info;

?? TITLE := '  [INLINE] get_cycle_array', EJECT ??

  PROCEDURE [INLINE] get_cycle_array (p_cycle_list: pft$p_cycle_list;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

    VAR
      comparison_result: pmt$comparison_result,
      cycle_entry: pft$cycle_entry,
      cycle_index: pft$cycle_index,
      cycle_info: pft$cycle_array_entry,
      p_cycle_info: pft$p_cycle_array_entry,
      p_record_body: pft$p_info;

    locate_info_record_body (p_info, p_record_body, status);
    IF status.normal THEN
      IF p_cycle_list <> NIL THEN

      /get_cycle_info_loop/
        FOR cycle_index := 1 TO UPPERBOUND (p_cycle_list^) DO
          cycle_entry := p_cycle_list^ [cycle_index].cycle_entry;
          IF cycle_entry.entry_type = pfc$normal_cycle_entry THEN
            NEXT p_cycle_info IN p_record_body;
            IF p_cycle_info <> NIL THEN
              cycle_info.cycle_number := cycle_entry.cycle_number;
              cycle_info.cycle_statistics := cycle_entry.cycle_statistics;
              cycle_info.expiration_date_time := cycle_entry.expiration_date_time;
              IF (cycle_entry.data_modification_date_time.year > 0) AND
                    (cycle_entry.data_residence <> pfc$unreleasable_data) THEN
                pmp$date_time_compare (cycle_entry.cycle_statistics.modification_date_time,
                    cycle_entry.data_modification_date_time, comparison_result, status);
                IF comparison_result = pmc$left_is_greater THEN
                  cycle_info.cycle_statistics.modification_date_time :=
                        cycle_entry.data_modification_date_time;
                IFEND;
              IFEND;
              p_cycle_info^ := cycle_info;
            ELSE
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, '', status);
              EXIT /get_cycle_info_loop/;
            IFEND;
          IFEND;
        FOREND /get_cycle_info_loop/;
      IFEND;

      IF status.normal THEN
        build_info_record (pfc$cycle_array_record, i#current_sequence_position (p_record_body), p_info,
              status);
      IFEND;
    IFEND;
  PROCEND get_cycle_array;

?? TITLE := '  get_cycle_array_extended', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to obtain the information required when
{   restoring a catalog.
{
{ DESIGN:
{   The information has the following format:
{     pfc$cycle_array_extended_record
{       pfc$cycle_array_directory
{       pfc$cycle_info_record (one for each cycle)
{         pfc$cycle_media_record
{         pfc$cycle_label_record
{         pfc$archive_info_record

  PROCEDURE get_cycle_array_extended
    (    p_complete_path: {input} ^pft$complete_path;
         ownership: pft$ownership;
         file_info_selections: pft$file_info_selections;
         p_cycle_list: {i/o^} ^pft$cycle_list;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
     VAR p_file_info: {i/o} ^pft$info;
     VAR status: ost$status);

    VAR
      cycle_index: pft$cycle_count,
      directory_index: pft$cycle_count,
      normal_cycle_count: pft$cycle_count,
      p_cycle_array_extended_body: ^pft$info,
      p_cycle_directory: ^pft$cycle_directory_array;

    locate_info_record_body (p_file_info, p_cycle_array_extended_body, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    normal_cycle_count := 0;
    IF p_cycle_list <> NIL THEN
      FOR cycle_index := 1 TO UPPERBOUND (p_cycle_list^) DO
        IF p_cycle_list^ [cycle_index].cycle_entry.entry_type = pfc$normal_cycle_entry THEN
          normal_cycle_count := normal_cycle_count + 1;
        IFEND;
      FOREND;
    IFEND;

    IF normal_cycle_count > 0 THEN
      allocate_cycle_directory (normal_cycle_count, p_cycle_array_extended_body, p_cycle_directory, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    directory_index := 0;
    IF (p_cycle_list <> NIL) AND (normal_cycle_count > 0) THEN
      FOR cycle_index := 1 TO UPPERBOUND (p_cycle_list^) DO
        IF p_cycle_list^ [cycle_index].cycle_entry.entry_type = pfc$normal_cycle_entry THEN
          directory_index := directory_index + 1;
          p_cycle_directory^ [directory_index].internal_name :=
                p_cycle_list^ [cycle_index].cycle_entry.internal_cycle_name;
          p_cycle_directory^ [directory_index].cycle_number :=
                p_cycle_list^ [cycle_index].cycle_entry.cycle_number;
          p_cycle_directory^ [directory_index].info_offset :=
                i#current_sequence_position (p_cycle_array_extended_body);

          get_cycle_info (p_complete_path, ownership, file_info_selections, p_catalog_file,
                ^p_cycle_list^ [cycle_index], p_cycle_array_extended_body, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;

    build_info_record (pfc$cycle_array_extended_record,
          i#current_sequence_position (p_cycle_array_extended_body), p_file_info, status);
  PROCEND get_cycle_array_extended;

?? TITLE := '  get_cycle_array_version_2', EJECT ??

  PROCEDURE get_cycle_array_version_2
    (    p_complete_path: {input} ^pft$complete_path;
         ownership: pft$ownership;
         file_info_selections: pft$file_info_selections;
         p_cycle_reservation_criteria: {input} ^pft$cycle_reservation_criteria;
         p_file_object: {input^} ^pft$object_entry;
         p_cycle_list: {i^/o^} ^pft$cycle_list;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
     VAR p_info: {i/o} ^pft$info;
     VAR status: ost$status);

    VAR
      cycle_included: boolean,
      cycle_index: pft$cycle_index,
      cycle_info: pft$cycle_array_entry_version_2,
      p_cycle_entry: ^pft$cycle_entry,
      p_cycle_info: ^pft$cycle_array_entry_version_2,
      p_physical_fmd: ^pft$physical_fmd,
      p_record_body: ^pft$info;

    locate_info_record_body (p_info, p_record_body, status);
    IF status.normal THEN
      IF p_cycle_list <> NIL THEN

      /get_cycle_info_loop/
        FOR cycle_index := 1 TO UPPERBOUND (p_cycle_list^) DO
          IF p_cycle_list^ [cycle_index].cycle_entry.entry_type = pfc$normal_cycle_entry THEN
            p_cycle_entry := ^p_cycle_list^ [cycle_index].cycle_entry;

            NEXT p_cycle_info IN p_record_body;
            IF p_cycle_info <> NIL THEN
              cycle_info.cycle_damage_symptoms := p_cycle_entry^.cycle_damage_symptoms;
              cycle_info.cycle_number := p_cycle_entry^.cycle_number;
              cycle_info.cycle_statistics := p_cycle_entry^.cycle_statistics;
              cycle_info.data_modification_date_time := p_cycle_entry^.data_modification_date_time;
              cycle_info.data_residence := p_cycle_entry^.data_residence;

              IF p_cycle_entry^.device_information.device_class_defined THEN
                pfp$convert_device_class_to_rm (p_cycle_entry^.device_information.device_class,
                      cycle_info.device_class);
              ELSE
                cycle_info.device_class := rmc$mass_storage_device;
              IFEND;

              pfp$build_fmd_pointer (p_cycle_entry^.fmd_locator, p_catalog_file, p_physical_fmd);
              IF (cycle_info.device_class = rmc$mass_storage_device) AND (p_physical_fmd <> NIL) THEN
                reconcile_fmd (p_complete_path, ownership, p_catalog_file, ^p_cycle_list^ [cycle_index],
                      p_physical_fmd, status);
              IFEND;

              IF (cycle_info.device_class = rmc$mass_storage_device) AND
                    (p_cycle_entry^.data_modification_date_time.year > 0) THEN
                IF pfp$cycle_attached_for_write (^p_cycle_list^ [cycle_index]) THEN
                  cycle_info.data_modification_date_time := stale_data_mod_date_time;
                  cycle_info.bytes_allocated := 0;
                  cycle_info.eoi := 0;
                ELSE
                  cycle_info.bytes_allocated := p_cycle_entry^.device_information.bytes_allocated;
                  cycle_info.eoi := p_cycle_entry^.device_information.eoi;
                IFEND;
              ELSE
                cycle_info.bytes_allocated := 0;
                cycle_info.eoi := 0;
              IFEND;

              cycle_info.expiration_date_time := p_cycle_entry^.expiration_date_time;
              cycle_info.original_unique_name := p_cycle_entry^.global_file_name;
              cycle_info.shared_queue_info := p_cycle_entry^.shared_queue_info;
              cycle_info.retrieve_option := p_cycle_entry^.retrieve_option;
              cycle_info.site_backup_option := p_cycle_entry^.site_backup_option;
              cycle_info.site_archive_option := p_cycle_entry^.site_archive_option;
              cycle_info.site_release_option := p_cycle_entry^.site_release_option;
              cycle_info.sparse_allocation := FALSE;
              cycle_info.reserved_cycle_array_entry_sp := reserved_cycle_array_entry_sp;
              IF status.normal AND (p_physical_fmd <> NIL) THEN
                reserve_cycle (p_complete_path, ownership, p_file_object, cycle_index,
                      p_cycle_reservation_criteria, p_physical_fmd, p_catalog_file, p_cycle_list,
                      ^cycle_info);
              ELSE
                cycle_info.cycle_reservation.cycle_reserved := FALSE;
                pfp$process_unexpected_status (status);
                status.normal := TRUE;
              IFEND;

              p_cycle_info^ := cycle_info;
            ELSE
              osp$set_status_condition (pfe$info_full, status);
              EXIT /get_cycle_info_loop/;
            IFEND;
          IFEND;
        FOREND /get_cycle_info_loop/;
      IFEND;

      IF status.normal THEN
        build_info_record (pfc$cycle_array_version_2_rec, i#current_sequence_position (p_record_body), p_info,
              status);
      IFEND;
    IFEND;
  PROCEND get_cycle_array_version_2;

?? TITLE := '  get_cycle_info', EJECT ??

  PROCEDURE get_cycle_info
    (    p_complete_path: {input} ^pft$complete_path;
         ownership: pft$ownership;
         file_info_selections: pft$file_info_selections;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
         p_cycle: {i^/o^} ^pft$physical_cycle;
     VAR p_cycle_array_extended_body: {i/o} ^pft$info;
     VAR status: ost$status);

    VAR
      device_class: rmt$device_class,
      existing_sft_entry: dmt$existing_sft_entry,
      exit_on_unknown_file: boolean,
      file_damaged: boolean,
      file_info: dmt$file_information,
      file_modified: boolean,
      fmd_modified: boolean,
      local_status: ost$status,
      p_archive_list: ^pft$archive_list,
      p_cycle_info: ^pft$info,
      p_physical_fmd: ^pft$physical_fmd,
      p_physical_label: ^pft$physical_file_label,
      system_file_id: dmt$system_file_id;

    locate_info_record_body (p_cycle_array_extended_body, p_cycle_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pfc$cycle_media_descriptor IN file_info_selections THEN
      IF p_cycle^.cycle_entry.device_information.device_class_defined THEN
        pfp$convert_device_class_to_rm (p_cycle^.cycle_entry.device_information.device_class,
              device_class);
      ELSE
        device_class := rmc$mass_storage_device;
      IFEND;

      pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, p_catalog_file, p_physical_fmd);
      IF p_physical_fmd <> NIL THEN
        IF device_class = rmc$mass_storage_device THEN
          reconcile_fmd (p_complete_path, ownership, p_catalog_file, p_cycle, p_physical_fmd, status);
          IF NOT status.normal THEN
            {
            { Don't terminate the get_info because an fmd could not be
            { reconciled. If the get_info is being called on behalf of bacpf,
            { this error will be displayed when the file is backed up.
            {
            pfp$report_unexpected_status (status);
            status.normal := TRUE;
          IFEND;
        IFEND;

        get_cycle_media_info (device_class, p_cycle^.cycle_entry.internal_cycle_name, p_physical_fmd,
              p_cycle_info, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    IF pfc$cycle_label_descriptor IN file_info_selections THEN
      pfp$build_file_label_pointer (p_cycle^.cycle_entry.file_label_locator, p_catalog_file,
            p_physical_label);
      IF p_physical_label <> NIL THEN
        get_cycle_label_info (p_physical_label, p_cycle_info, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    IF pfc$archive_descriptors IN file_info_selections THEN
      pfp$build_archive_list_pointer (p_cycle^.cycle_entry.archive_list_locator, p_catalog_file,
            p_archive_list);
      IF p_archive_list <> NIL THEN
        get_cycle_archive_info (p_archive_list, p_catalog_file, p_cycle_info, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    build_info_record (pfc$cycle_info_record, i#current_sequence_position (p_cycle_info),
          p_cycle_array_extended_body, status);
  PROCEND get_cycle_info;

?? TITLE := '  get_cycle_label_info', EJECT ??

  PROCEDURE get_cycle_label_info
    (    p_physical_label: pft$p_stored_file_label;
     VAR p_cycle_info: {Input, Output} pft$p_info;
     VAR status: ost$status);

    VAR
      p_file_label_info: pft$p_stored_file_label,
      p_file_label_record_body: pft$p_info;

    locate_info_record_body (p_cycle_info, p_file_label_record_body, status);
    IF status.normal THEN
      NEXT p_file_label_info: [[REP #SIZE (p_physical_label^.file_label) OF cell]] IN
            p_file_label_record_body;
      IF p_file_label_info = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, ' Cycles label', status);
      ELSE
        p_file_label_info^ := p_physical_label^;
        build_info_record (pfc$cycle_label_record, i#current_sequence_position (p_file_label_record_body),
              p_cycle_info, status);
      IFEND;
    IFEND;
  PROCEND get_cycle_label_info;

?? TITLE := '  get_cycle_media_info', EJECT ??

  PROCEDURE get_cycle_media_info
    (    device_class: rmt$device_class;
         internal_cycle_name: pft$internal_name;
         p_physical_fmd: pft$p_physical_fmd;
     VAR p_cycle_info: {Input, Output} pft$p_info;
     VAR status: ost$status);

    VAR
      p_file_media_description: pft$p_file_media_description,
      p_file_media_record_body: pft$p_info;

    locate_info_record_body (p_cycle_info, p_file_media_record_body, status);
    IF status.normal THEN
      NEXT p_file_media_description: [[REP #SIZE (p_physical_fmd^.fmd) OF cell]] IN p_file_media_record_body;
      IF p_file_media_description = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, ' Cycles fmd', status);
      ELSE
        p_file_media_description^.global_file_name := internal_cycle_name;
        p_file_media_description^.file_media_type.media_version := pfc$file_media_disk_version_1;
        p_file_media_description^.file_media_type.device_class := device_class;
        p_file_media_description^.checksum := p_physical_fmd^.checksum;
        p_file_media_description^.file_media_descriptor := p_physical_fmd^.fmd;
        build_info_record (pfc$cycle_media_record, i#current_sequence_position (p_file_media_record_body),
              p_cycle_info, status);
      IFEND;
    IFEND;
  PROCEND get_cycle_media_info;

?? TITLE := '  [INLINE] get_file_description_info', EJECT ??

  PROCEDURE [INLINE] get_file_description_info
   (    file_object: pft$object_entry;
        authority: pft$authority;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

    VAR
      file_description: pft$file_description,
      p_file_description: pft$p_file_description,
      p_record_body: pft$p_info;

    locate_info_record_body (p_info, p_record_body, status);
    IF status.normal THEN
      NEXT p_file_description IN p_record_body;
      IF p_file_description <> NIL THEN
        file_description.name := file_object.external_object_name;
        IF authority.ownership = $pft$ownership [] THEN
          file_description.password := osc$null_name;
        ELSE
          file_description.password := file_object.password;
        IFEND;
        file_description.charge_id := file_object.charge_id;
        file_description.logging_selection := file_object.logging_selection;
        p_file_description^ := file_description;
        build_info_record (pfc$file_description_record, i#current_sequence_position (p_record_body), p_info,
              status);
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, '', status);
      IFEND;
    IFEND;
  PROCEND get_file_description_info;

?? TITLE := '  get_file_info', EJECT ??

  PROCEDURE get_file_info
    (   p_complete_path: {input} ^pft$complete_path;
        authority: pft$authority;
        file_object: pft$object_entry;
        file_info_selections: pft$file_info_selections;
        p_cycle_reservation_criteria: {input} ^pft$cycle_reservation_criteria;
        p_catalog_file: {i^/o^} ^pft$catalog_file;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

    VAR
      p_cycle_list: ^pft$cycle_list,
      p_log_list: ^pft$log_list,
      p_permit_list: ^pft$permit_list,
      p_record_body: ^pft$info;

    locate_info_record_body (p_info, p_record_body, status);
    IF status.normal THEN
      IF pfc$file_description IN file_info_selections THEN
        get_file_description_info (file_object, authority, p_record_body, status);
      IFEND;

      IF status.normal AND (pfc$file_permits IN file_info_selections) THEN
        pfp$build_permit_list_pointer (file_object.permit_list_locator, p_catalog_file, p_permit_list);
        get_permit_info (p_permit_list, authority, p_record_body, status);
      IFEND;

      IF status.normal THEN
        pfp$build_cycle_list_pointer (file_object.cycle_list_locator, p_catalog_file, p_cycle_list);

        IF pfc$file_cycles IN file_info_selections  THEN
          get_cycle_array (p_cycle_list, p_record_body, status);
        ELSEIF pfc$file_cycles_version_2 IN file_info_selections THEN
          get_cycle_array_version_2 (p_complete_path, authority.ownership, file_info_selections,
                p_cycle_reservation_criteria, ^file_object, p_cycle_list, p_catalog_file, p_record_body,
                status);
        IFEND;
      IFEND;

      IF status.normal AND (pfc$file_log IN file_info_selections) THEN
        pfp$build_log_list_pointer (file_object.log_list_locator, p_catalog_file, p_log_list);
        get_log_info (p_log_list, authority, p_record_body, status);
      IFEND;

      IF (pfc$cycle_media_descriptor IN file_info_selections) OR
            (pfc$cycle_label_descriptor IN file_info_selections) OR
            (pfc$archive_descriptors IN file_info_selections) THEN
        IF (NOT (pfc$file_cycles IN file_info_selections)) AND
              NOT (pfc$file_cycles_version_2 IN file_info_selections) THEN
          pfp$build_cycle_list_pointer (file_object.cycle_list_locator, p_catalog_file, p_cycle_list);
        IFEND;

        get_cycle_array_extended (p_complete_path, authority.ownership, file_info_selections, p_cycle_list,
              p_catalog_file, p_record_body, status);
      IFEND;

      IF status.normal THEN
        build_info_record (pfc$file_group_record, i#current_sequence_position (p_record_body), p_info,
              status);
      IFEND;
    IFEND;
  PROCEND get_file_info;

?? TITLE := '  [INLINE] get_log_info', EJECT ??

  PROCEDURE [INLINE] get_log_info
   (    p_log_list: pft$p_log_list;
        authority: pft$authority;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

    VAR
      log_index: pft$log_index,
      p_log_entry: pft$p_log,
      p_record_body: pft$p_info,
      user_id: ost$user_identification;

    locate_info_record_body (p_info, p_record_body, status);
    IF status.normal AND (p_log_list <> NIL) THEN
      IF authority.ownership = $pft$ownership [] THEN
        user_id.family := authority.family;
        user_id.user := authority.user;
        pfp$locate_log_entry (p_log_list, user_id, p_log_entry);
        IF p_log_entry <> NIL THEN
          append_log_entry (p_log_entry^.log_entry, p_record_body, status);
        IFEND;
      ELSE

      /get_log_info_loop/
        FOR log_index := 1 TO UPPERBOUND (p_log_list^) DO
          append_log_entry (p_log_list^ [log_index].log_entry, p_record_body, status);
          IF NOT status.normal THEN
            EXIT /get_log_info_loop/;
          IFEND;
        FOREND /get_log_info_loop/;
      IFEND;
    IFEND;

    IF status.normal THEN
      build_info_record (pfc$log_array_record, i#current_sequence_position (p_record_body), p_info, status);
    IFEND;
  PROCEND get_log_info;

?? TITLE := '  get_multi_object_info', EJECT ??

  PROCEDURE get_multi_object_info
   (    p_complete_path: {input} ^pft$complete_path;
        authority: pft$authority;
        permit_entry: pft$permit_entry;
        object_list_descriptor: pft$object_list_descriptor;
        catalog_info_selections: pft$catalog_info_selections;
        file_info_selections: pft$file_info_selections;
        p_cycle_reservation_criteria: {input} ^pft$cycle_reservation_criteria;
        p_catalog_file: {i^/o^} ^pft$catalog_file;
    VAR catalog_locator: {i/o} pft$catalog_locator;
    VAR p_record_body: {i/o} ^pft$info;
    VAR status: ost$status);

    VAR
      directory_entry: pft$directory_array_entry,
      fs_path_size: fst$path_size,
      object_count: pft$object_count,
      object_entry: pft$object_entry,
      object_index: pft$object_index,
      p_directory_array: ^pft$directory_array,
      p_file_path: ^pft$complete_path,
      p_fs_path: ^fst$path,
      p_qualified_object_list: ^pft$object_list,
      selected_objects: pft$object_selections;

    IF catalog_info_selections <> $pft$catalog_info_selections [] THEN
      selected_objects := $pft$object_selections [pfc$catalog_object];
    ELSE
      selected_objects := $pft$object_selections [];
    IFEND;
    IF file_info_selections <> $pft$file_info_selections [] THEN
      selected_objects := selected_objects + $pft$object_selections [pfc$file_object];
    IFEND;

    IF object_list_descriptor.p_object_list <> NIL THEN
      PUSH p_qualified_object_list: [1 .. UPPERBOUND (object_list_descriptor.p_object_list^)];
    IFEND;

    build_qualified_object_list (object_list_descriptor, selected_objects, p_catalog_file, authority,
          permit_entry, object_count, p_qualified_object_list);
    allocate_directory_array (p_record_body, object_count, p_directory_array, status);

    IF status.normal THEN
      IF object_count > 0 THEN
        IF pfc$file_object IN selected_objects THEN
          PUSH p_file_path: [1 .. UPPERBOUND (p_complete_path^) + 1];
          p_file_path^ := p_complete_path^;
        IFEND;

      /get_info_loop/
        FOR object_index := 1 TO object_count DO
          object_entry := p_qualified_object_list^ [object_index].object_entry;
          directory_entry.name := object_entry.external_object_name;
          directory_entry.info_offset := i#current_sequence_position (p_record_body);

          IF object_entry.object_type = pfc$catalog_object THEN
            directory_entry.name_type := pfc$catalog_name;
            get_catalog_info (object_entry, catalog_info_selections, p_catalog_file, authority, p_record_body,
                  status);
          ELSE
            directory_entry.name_type := pfc$file_name;
            p_file_path^ [UPPERBOUND (p_file_path^)] := object_entry.external_object_name;
            get_file_info (p_file_path, authority, object_entry, file_info_selections,
                  p_cycle_reservation_criteria, p_catalog_file, p_record_body, status);
          IFEND;

          IF status.normal THEN
            p_directory_array^ [object_index] := directory_entry;
          ELSE
            EXIT /get_info_loop/;
          IFEND;

          IF (object_index MOD pfv$unlock_catalog_threshold) = 0  THEN
            pfp$unlock_catalog_pages(catalog_locator, status);
            IF NOT status.normal THEN
              EXIT /get_info_loop/;
            IFEND;
          IFEND;
        FOREND /get_info_loop/;

      ELSEIF osv$catalog_name_security AND (authority.ownership = $pft$ownership []) AND
            ((permit_entry.entry_type = pfc$free_permit_entry) OR
            (permit_entry.usage_permissions = $pft$permit_selections [])) THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (p_complete_path^, p_fs_path^, fs_path_size);
        CASE UPPERBOUND (p_complete_path^) OF
        = pfc$family_path_index =
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_family,
                p_fs_path^ (1, fs_path_size), status);
        = pfc$master_catalog_path_index =
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_master_catalog,
                p_fs_path^ (1, fs_path_size), status);
        ELSE
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_last_subcatalog,
                p_fs_path^ (1, fs_path_size), status);
        CASEND;
      IFEND;
    IFEND;
  PROCEND get_multi_object_info;

?? TITLE := '  get_object_info', EJECT ??

  PROCEDURE get_object_info
    (    path: pft$complete_path;
         authority: pft$authority;
         object_entry: pft$object_entry;
         catalog_info_selections: pft$catalog_info_selections;
         file_info_selections: pft$file_info_selections;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
     VAR p_record_body: {i/o} ^pft$info;
     VAR status: ost$status);

    VAR
      directory_entry: pft$directory_array_entry,
      p_directory_array: ^pft$directory_array;

    allocate_directory_array (p_record_body, {directory_size} 1, p_directory_array, status);
    IF status.normal THEN
      directory_entry.name := object_entry.external_object_name;
      directory_entry.info_offset := i#current_sequence_position (p_record_body);

      IF object_entry.object_type = pfc$catalog_object THEN
        directory_entry.name_type := pfc$catalog_name;
        get_catalog_info (object_entry, catalog_info_selections, p_catalog_file, authority, p_record_body,
              status);
      ELSE
        directory_entry.name_type := pfc$file_name;
        get_file_info (^path, authority, object_entry, file_info_selections,
              {p_cycle_reservation_criteria} NIL, p_catalog_file, p_record_body, status);
      IFEND;

      p_directory_array^ [1] := directory_entry;
    IFEND;
  PROCEND get_object_info;

?? TITLE := '  get_permit_info', EJECT ??

  PROCEDURE get_permit_info
   (    p_permit_list: pft$p_permit_list;
        authority: pft$authority;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

    VAR
      p_record_body: pft$p_info,
      permit_entry: pft$permit_entry,
      permit_index: pft$permit_index;

    locate_info_record_body (p_info, p_record_body, status);
    IF status.normal AND (p_permit_list <> NIL) THEN
      IF authority.ownership = $pft$ownership [] THEN
        pfp$extract_permit_entry (p_permit_list, authority, permit_entry);
        append_permit_entry (permit_entry, p_record_body, status);
      ELSE

      /get_permit_info_loop/
        FOR permit_index := 1 TO UPPERBOUND (p_permit_list^) DO
          append_permit_entry (p_permit_list^ [permit_index].permit_entry, p_record_body, status);
          IF NOT status.normal THEN
            EXIT /get_permit_info_loop/;
          IFEND;
        FOREND /get_permit_info_loop/;
      IFEND;
    IFEND;

    IF status.normal THEN
      build_info_record (pfc$permit_array_record, i#current_sequence_position (p_record_body), p_info,
            status);
    IFEND;
  PROCEND get_permit_info;

?? OLDTITLE ??
?? NEWTITLE := ' get_root_stored_fmd', EJECT ??

  PROCEDURE get_root_stored_fmd
    (    path: pft$complete_path;
     VAR catalog: boolean;
     VAR catalog_recreated: boolean;
     VAR global_file_name: ost$binary_unique_name;
     VAR stored_fmd: dmt$stored_fmd;
     VAR status: ost$status);

    VAR
      p_internal_catalog_name: ^pft$internal_catalog_name,
      p_root: ^pft$root,
      p_stored_fmd: ^dmt$stored_fmd,
      p_stored_fmd_size: ^dmt$stored_fmd_size,
      root_size: pft$root_size;

    root_size := 255; {estimate}
    REPEAT
      PUSH p_root: [[REP root_size OF cell]];
      RESET p_root;
      stp$get_pf_root (path [pfc$set_path_index], root_size, p_root^, status);
    UNTIL status.normal OR (status.condition <> ste$incorrect_root_size);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET p_root;
    NEXT p_internal_catalog_name IN p_root;
    NEXT p_stored_fmd_size IN p_root;
    NEXT p_stored_fmd: [[REP p_stored_fmd_size^ OF cell]] IN p_root;

    catalog := TRUE;
    catalog_recreated := FALSE;
    global_file_name := p_internal_catalog_name^;
    stored_fmd := p_stored_fmd^;

  PROCEND get_root_stored_fmd;

?? OLDTITLE ??
?? NEWTITLE := ' get_root_stored_fmd_size', EJECT ??

  PROCEDURE get_root_stored_fmd_size
    (    path: pft$complete_path;
     VAR device_class: rmt$device_class;
     VAR global_file_name: ost$binary_unique_name;
     VAR fmd_size: dmt$stored_fmd_size;
     VAR status: ost$status);

    VAR
      p_internal_catalog_name: ^pft$internal_catalog_name,
      p_root: ^pft$root,
      p_stored_fmd: ^dmt$stored_fmd,
      p_stored_fmd_size: ^dmt$stored_fmd_size,
      root_size: pft$root_size;


    root_size := 255; {estimate}
    REPEAT
      PUSH p_root: [[REP root_size OF cell]];
      RESET p_root;
      stp$get_pf_root (path [pfc$set_path_index], root_size, p_root^, status);
    UNTIL status.normal OR (status.condition <> ste$incorrect_root_size);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET p_root;
    NEXT p_internal_catalog_name IN p_root;
    NEXT p_stored_fmd_size IN p_root;
    NEXT p_stored_fmd: [[REP p_stored_fmd_size^ OF cell]] IN p_root;

    device_class := rmc$mass_storage_device;
    global_file_name := p_internal_catalog_name^;
    fmd_size := p_stored_fmd_size^;

  PROCEND get_root_stored_fmd_size;

?? TITLE := '  locate_info_record_body', EJECT ??

  PROCEDURE locate_info_record_body (p_info: pft$p_info;
    VAR p_record_body: pft$p_info;
    VAR status: ost$status);

    VAR
      body_size: integer,
      header_size: integer,
      local_p_info: pft$p_info,
      p_info_record: pft$p_info_record;

    IF p_info <> NIL THEN
      PUSH p_info_record: [[REP 1 OF cell]];
      header_size := #SIZE (p_info_record^) - 1;
      body_size := #SIZE (p_info^) - i#current_sequence_position (p_info) - header_size;
      IF body_size > 0 THEN
        local_p_info := p_info;
        NEXT p_record_body: [[REP header_size OF cell]] IN local_p_info;
        NEXT p_record_body: [[REP body_size OF cell]] IN local_p_info;
        RESET p_record_body;
        status.normal := TRUE;
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, '', status);
      IFEND;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, '', status);
    IFEND;
  PROCEND locate_info_record_body;

?? TITLE := '  reconcile_fmd', EJECT ??

  PROCEDURE reconcile_fmd
    (    p_complete_path: {input} ^pft$complete_path;
         ownership: pft$ownership;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
         p_cycle: {i^/o^} ^pft$physical_cycle;
     VAR p_physical_fmd: {i^/o} ^pft$physical_fmd;
     VAR status: ost$status);

    VAR
      existing_sft_entry: dmt$existing_sft_entry,
      exit_on_unknown_file: boolean,
      file_damaged: boolean,
      file_info: dmt$file_information,
      file_modified: boolean,
      fmd_modified: boolean,
      local_status: ost$status,
      system_file_id: dmt$system_file_id;

    status.normal := TRUE;
    exit_on_unknown_file := pfp$cycle_attached_for_write (p_cycle);

    IF exit_on_unknown_file THEN

      dmp$attach_file (p_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file,
            p_physical_fmd^.fmd, $pft$usage_selections [pfc$read], $pft$share_selections [],
            pfc$average_share_history, pfc$maximum_pf_length, {restricted attach} FALSE,
            exit_on_unknown_file, {server_file} FALSE,
            pfp$shared_queue (p_cycle^.cycle_entry.shared_queue_info, $pft$share_selections []),
            file_damaged, system_file_id, existing_sft_entry, status);
      IF status.normal THEN
        IF existing_sft_entry = dmc$normal_entry THEN
          pfp$detach_permanent_file (p_complete_path, system_file_id, $pft$usage_selections [],
                {catalog_access_allowed} TRUE, p_cycle, p_catalog_file, fmd_modified, file_info,
                local_status);
          pfp$process_unexpected_status (local_status);

          IF fmd_modified THEN
            pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, p_catalog_file, p_physical_fmd);
          IFEND;
        ELSE
          pfp$reconcile_fmd (p_complete_path, p_cycle^.cycle_entry.internal_cycle_name, existing_sft_entry,
                {update_catalog} TRUE, p_catalog_file, p_cycle, p_physical_fmd, status);

          IF status.normal THEN
            dmp$attach_file (p_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file,
                  p_physical_fmd^.fmd, $pft$usage_selections [pfc$read], $pft$share_selections [],
                  pfc$average_share_history, pfc$maximum_pf_length, {restricted attach} FALSE,
                  {exit_on_unknown_file} FALSE, {server_file} FALSE,
                  pfp$shared_queue (p_cycle^.cycle_entry.shared_queue_info, $pft$share_selections []),
                  file_damaged, system_file_id, existing_sft_entry, status);

            IF status.normal THEN
              pfp$detach_permanent_file (p_complete_path, system_file_id, $pft$usage_selections [],
                    {catalog_access_allowed} TRUE, p_cycle, p_catalog_file, fmd_modified, file_info,
                    local_status);
              pfp$process_unexpected_status (local_status);

              IF fmd_modified THEN
                pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, p_catalog_file, p_physical_fmd);
              IFEND;

              p_cycle^.cycle_entry.device_information.eoi := file_info.eoi_byte_address;
              p_cycle^.cycle_entry.device_information.bytes_allocated := file_info.total_allocated_length;
              pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND reconcile_fmd;

?? TITLE := '  reserve_cycle', EJECT ??

  PROCEDURE reserve_cycle
    (    p_complete_path: {input} ^pft$complete_path;
         ownership: pft$ownership;
         p_file_object: {input^} ^pft$object_entry;
         cycle_index: pft$cycle_index;
         p_cycle_reservation_criteria: {input} ^pft$cycle_reservation_criteria;
         p_physical_fmd: {input^} ^pft$physical_fmd;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
         p_cycle_list: {i^/o^} ^pft$cycle_list;
         p_cycle_info: {i^/o^} ^pft$cycle_array_entry_version_2);

    VAR
      cycle_included: boolean,
      existing_sft_entry: dmt$existing_sft_entry,
      file_damaged: boolean,
      file_info: dmt$file_information,
      flush_catalog_pages: boolean,
      fmd_modified: boolean,
      local_status: ost$status,
      mainframe_id: pmt$binary_mainframe_id,
      p_cycle: ^pft$physical_cycle,
      reserved_cycle_index: ost$non_negative_integers,
      system_file_id: dmt$system_file_id;

    p_cycle_info^.cycle_reservation.cycle_reserved := FALSE;

    IF p_cycle_reservation_criteria = NIL THEN
      RETURN;
    IFEND;

    p_cycle := ^p_cycle_list^ [cycle_index];
    IF (p_cycle^.cycle_entry.entry_type <> pfc$normal_cycle_entry) OR
          (p_cycle^.cycle_entry.cycle_damage_symptoms <> $fst$cycle_damage_symptoms []) OR
          (p_cycle^.cycle_entry.data_residence = pfc$offline_data) OR
          (p_cycle^.cycle_entry.device_information.device_class_defined AND
          (p_cycle^.cycle_entry.device_information.device_class <> pfc$mass_storage_device)) THEN
      RETURN;
    IFEND;

    check_if_access_included (p_cycle_reservation_criteria^.date_selection_criteria, p_cycle_info^,
          cycle_included);
    IF NOT cycle_included THEN
      RETURN;
    IFEND;

    check_if_size_included (p_cycle_reservation_criteria^.minimum_cycle_size,
          p_cycle_reservation_criteria^.maximum_cycle_size, p_cycle^.cycle_entry.device_information.eoi,
          p_cycle, cycle_included);
    IF NOT cycle_included THEN
      RETURN;
    IFEND;

    check_if_high_cycle_included (p_cycle^.cycle_entry.cycle_number, p_cycle_list,
          p_cycle_reservation_criteria, cycle_included);
    IF NOT cycle_included THEN
      RETURN;
    IFEND;

    pmp$get_pseudo_mainframe_id (mainframe_id);
    check_if_usage_included ($pft$permit_selections [pfc$read], $pft$share_selections [pfc$read, pfc$execute],
          mainframe_id, p_cycle, p_catalog_file, cycle_included);
    IF NOT cycle_included THEN
      RETURN;
    IFEND;

    check_if_volume_included (p_cycle_reservation_criteria^.include_volumes_option, ^p_physical_fmd^.fmd,
          p_cycle_reservation_criteria^.p_volume_list, cycle_included, local_status);
    IF (NOT local_status.normal) OR NOT cycle_included THEN
      RETURN;
    IFEND;

    check_file_attributes ($pft$usage_selections [pfc$read], p_cycle_reservation_criteria^.validation_ring,
          p_cycle, p_catalog_file, cycle_included, local_status);
    IF (NOT local_status.normal) OR NOT cycle_included THEN
      RETURN;
    IFEND;

    dmp$attach_file (p_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file,
          p_physical_fmd^.fmd, $pft$usage_selections [pfc$read],
          $pft$share_selections [pfc$read, pfc$execute], pfc$average_share_history, pfc$maximum_pf_length,
          {restricted attach} FALSE, {exit_on_unknown_file} FALSE, {server_file} FALSE,
          pfp$shared_queue (p_cycle^.cycle_entry.shared_queue_info,
          $pft$share_selections [pfc$read, pfc$execute]), file_damaged, system_file_id,
          existing_sft_entry, local_status);

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_cycle_attachment (p_complete_path, p_cycle^.cycle_entry.cycle_number, ownership, local_status);
    IFEND;

    IF NOT local_status.normal THEN
      RETURN;
    IFEND;


    IF NOT file_damaged THEN
      update_reserved_cycle_list (p_file_object^.external_object_name, p_file_object^.internal_object_name,
            p_cycle^.cycle_entry.cycle_number, p_cycle^.cycle_entry.internal_cycle_name, system_file_id,
            reserved_cycle_index, local_status);

      IF local_status.normal THEN
        pfp$increment_usage_counts (p_complete_path^, $pft$usage_selections [pfc$read],
              $pft$share_selections [pfc$read, pfc$execute], mainframe_id, p_catalog_file,
              flush_catalog_pages, p_cycle^.cycle_entry, local_status);

        IF local_status.normal THEN
          p_cycle_info^.cycle_reservation.cycle_reserved := TRUE;
          p_cycle_info^.cycle_reservation.reserved_cycle_index := reserved_cycle_index;
        IFEND;

        pfp$compute_checksum (^p_cycle^.cycle_entry, #SIZE (p_cycle^.cycle_entry), p_cycle^.checksum);
      IFEND;
    IFEND;

    IF (NOT local_status.normal) OR file_damaged THEN
      pfp$detach_permanent_file (p_complete_path, system_file_id, $pft$usage_selections [pfc$read],
            {catalog_access_allowed} TRUE, p_cycle, p_catalog_file, fmd_modified, file_info, local_status);
    IFEND;
  PROCEND reserve_cycle;

?? TITLE := '  [INLINE] select_cycle_date_time', EJECT ??

  PROCEDURE [INLINE] select_cycle_date_time
   (    cycle_array_entry: pft$cycle_array_entry_version_2;
        selection_criteria_mode: put$selection_criteria_mode;
    VAR cycle_date_time: ost$date_time);

    CASE selection_criteria_mode OF
    = puc$created =
      cycle_date_time := cycle_array_entry.cycle_statistics.creation_date_time;
    = puc$accessed =
      cycle_date_time := cycle_array_entry.cycle_statistics.access_date_time;
    = puc$modified =
      cycle_date_time := cycle_array_entry.cycle_statistics.modification_date_time;
    = puc$expired =
      cycle_date_time := cycle_array_entry.expiration_date_time;
    CASEND;
  PROCEND select_cycle_date_time;

?? TITLE := '  [INLINE] test_object_qualifications', EJECT ??

  PROCEDURE [INLINE] test_object_qualifications
   (    object_entry: pft$object_entry;
        selected_objects: pft$object_selections;
        p_catalog_file: pft$p_catalog_file;
        authority: pft$authority;
        permit_entry: pft$permit_entry;
    VAR object_qualified: boolean);

    VAR
      new_permit_entry: pft$permit_entry,
      p_permit_list: pft$p_permit_list;

    object_qualified := (object_entry.object_type IN selected_objects);
    IF object_qualified AND (authority.ownership = $pft$ownership []) THEN
      IF osv$catalog_name_security THEN
        IF (object_entry.object_type = pfc$catalog_object) OR
              (object_entry.object_type = pfc$file_object) THEN
          pfp$build_permit_list_pointer (object_entry.permit_list_locator, p_catalog_file, p_permit_list);
          pfp$extract_permit_entry (p_permit_list, authority, new_permit_entry);
          pfp$reduce_permits (permit_entry, new_permit_entry, new_permit_entry);
          object_qualified := ((new_permit_entry.entry_type = pfc$normal_permit_entry) AND
                (new_permit_entry.usage_permissions <> $pft$permit_selections []));
        IFEND;
      ELSE
        IF object_entry.object_type = pfc$file_object THEN
          pfp$build_permit_list_pointer (object_entry.permit_list_locator, p_catalog_file, p_permit_list);
          pfp$extract_permit_entry (p_permit_list, authority, new_permit_entry);
          pfp$reduce_permits (permit_entry, new_permit_entry, new_permit_entry);
          object_qualified := ((new_permit_entry.entry_type = pfc$normal_permit_entry) AND
                (new_permit_entry.usage_permissions <> $pft$permit_selections []));
        IFEND;
      IFEND;
    IFEND;
  PROCEND test_object_qualifications;

?? TITLE := '  [INLINE] update_reserved_cycle_list', EJECT ??

  PROCEDURE [INLINE] update_reserved_cycle_list
    (    external_object_name: pft$name;
         internal_object_name: pft$internal_name;
         cycle_number: pft$cycle_number;
         internal_cycle_name: pft$internal_name;
         system_file_id: dmt$system_file_id;
     VAR reserved_cycle_index: ost$non_negative_integers;
     VAR status: ost$status);

    CONST
      reserved_cycle_expansion_size = 50;

    VAR
      p_reserved_cycles: ^pft$reserved_cycles;

    IF pfv$reserved_cycle_info.p_reserved_cycles = NIL THEN
      ALLOCATE pfv$reserved_cycle_info.p_reserved_cycles: [1 .. reserved_cycle_expansion_size] IN
            osv$task_shared_heap^;
      IF pfv$reserved_cycle_info.p_reserved_cycles = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
               'Unable to allocate space in Task Shared heap.', status);
        RETURN;
      IFEND;
      pfv$reserved_cycle_info.number_of_cycles_reserved := 0;
    ELSEIF pfv$reserved_cycle_info.number_of_cycles_reserved >=
          UPPERBOUND (pfv$reserved_cycle_info.p_reserved_cycles^) THEN
      p_reserved_cycles := pfv$reserved_cycle_info.p_reserved_cycles;
      ALLOCATE pfv$reserved_cycle_info.p_reserved_cycles:
            [1 .. (UPPERBOUND (p_reserved_cycles^) + reserved_cycle_expansion_size)] IN
            osv$task_shared_heap^;
      IF pfv$reserved_cycle_info.p_reserved_cycles = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
               'Unable to allocate space in Task Shared heap.', status);
        RETURN;
      IFEND;
      i#move (p_reserved_cycles, pfv$reserved_cycle_info.p_reserved_cycles, #SIZE (p_reserved_cycles^));
      FREE p_reserved_cycles IN osv$task_shared_heap^;
    IFEND;

    pfv$reserved_cycle_info.number_of_cycles_reserved := pfv$reserved_cycle_info.number_of_cycles_reserved +
          1;
    pfv$reserved_cycle_info.p_reserved_cycles^ [pfv$reserved_cycle_info.number_of_cycles_reserved].
          external_object_name := external_object_name;
    pfv$reserved_cycle_info.p_reserved_cycles^ [pfv$reserved_cycle_info.number_of_cycles_reserved].
          internal_object_name := internal_object_name;
    pfv$reserved_cycle_info.p_reserved_cycles^ [pfv$reserved_cycle_info.number_of_cycles_reserved].
          cycle_number := cycle_number;
    pfv$reserved_cycle_info.p_reserved_cycles^ [pfv$reserved_cycle_info.number_of_cycles_reserved].
          internal_cycle_name := internal_cycle_name;
    pfv$reserved_cycle_info.p_reserved_cycles^ [pfv$reserved_cycle_info.number_of_cycles_reserved].
          system_file_id := system_file_id;
    reserved_cycle_index := pfv$reserved_cycle_info.number_of_cycles_reserved;
  PROCEND update_reserved_cycle_list;

?? OLDTITLE, SKIP := 2 ??
MODEND pfm$r2_get_info;
*DECK DECK=PFM$R2_GET_OBJECT_INFORMATION EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Permanent Files : Get Object Information' ??
MODULE pfm$r2_get_object_information;

{ PURPOSE:
{   This module contains the procedures to get information about a catalog,
{   file, or cycle.

?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$lfn_program_actions
*copyc dmt$error_condition_codes
*copyc dmt$stored_ms_fmd_header
*copyc fsc$local
*copyc fst$file_access_conditions
*copyc fst$goi_object_information
*copyc fst$goi_validation_criteria
*copyc fst$path_element_name
*copyc gft$system_file_identifier
*copyc osd$integer_limits
*copyc oss$job_paged_literal
*copyc pfc$system_shared_queue_name
*copyc pfd$catalog_info
*copyc pfe$error_condition_codes
*copyc pfe$get_object_info_errors
*copyc pfe$internal_error_conditions
*copyc pfk$keypoints
*copyc pft$unique_volume_list
?? POP ??
?? EJECT ??
*copyc bap$set_evaluated_file_abnormal
*copyc clp$convert_file_ref_to_string
*copyc dfp$check_self_serving_job
*copyc dfp$locate_served_family
*copyc dmp$attach_file
*copyc dmp$fetch_eoi
*copyc dmp$get_file_info
*copyc dmp$get_server_fmd
*copyc dmp$get_stored_fmd
*copyc dmp$get_stored_fmd_header_info
*copyc dmp$get_stored_fmd_size
*copyc dmp$get_stored_fmd_volume_list
*copyc dmp$get_tape_volume_information
*copyc dmp$get_tape_volume_list
*copyc dmp$get_unique_fmd_volume_list
*copyc fmp$complete_pf_object_info
*copyc fmp$get_attached_tape_info
*copyc fmp$get_$local_object_info
*copyc fmp$get_label_header_info
*copyc fmp$get_path_table_cycle_info
*copyc fmp$get_setfa_values_for_object
*copyc fmp$lock_path_table
*copyc fmp$merge_setfa_entries
*copyc fmp$process_pt_request
*copyc fmp$setup_job_environment_info
*copyc fmp$unlock_path_table
*copyc fmv$static_label_header
*copyc fsp$path_element
*copyc i#move
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc mmp$fetch_segment_attributes
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$file_access_condition
*copyc osp$get_set_name
*copyc osp$recoverable_system_error
*copyc osp$set_status_from_condition
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osv$catalog_name_security
*copyc osv$system_family_name
*copyc pfi$convert_cycle_reference
*copyc pfp$access_next_catalog
*copyc pfp$access_object
*copyc pfp$build_archive_list_pointer
*copyc pfp$build_cycle_list_pointer
*copyc pfp$build_amd_pointer
*copyc pfp$build_file_label_pointer
*copyc pfp$build_fmd_pointer
*copyc pfp$build_log_list_pointer
*copyc pfp$build_mainfram_list_pointer
*copyc pfp$build_permit_list_pointer
*copyc pfp$check_archive_entries
*copyc pfp$check_for_stale_cycle_entry
*copyc pfp$compute_checksum
*copyc pfp$convert_device_class_to_rm
*copyc pfp$convert_fs_to_complete_path
*copyc pfp$convert_fs_to_pft$path
*copyc pfp$convert_ord_to_shared_queue
*copyc pfp$cycle_attached_for_write
*copyc pfp$detach_permanent_file
*copyc pfp$extract_permit_entry
*copyc pfp$form_administrator_permit
*copyc pfp$get_authority
*copyc pfp$get_rem_media_req_info
*copyc pfp$get_rem_media_volume_list
*copyc pfp$get_sorted_object_name_list
*copyc pfp$initialize_object_info
*copyc pfp$locate_cycle
*copyc pfp$locate_log_entry
*copyc pfp$log_ascii
*copyc pfp$log_path
*copyc pfp$process_unexpected_status
*copyc pfp$r2_df_client_get_family_set
*copyc pfp$r2_df_client_get_obj_info
*copyc pfp$r2_df_client_get_vol_cl
*copyc pfp$r2_df_client_validate_pw
*copyc pfp$r2_get_stored_fmd
*copyc pfp$r2_get_stored_fmd_size
*copyc pfp$r2_get_vol_condition_list
*copyc pfp$r2_validate_password
*copyc pfp$reconcile_fmd
*copyc pfp$reduce_permits
*copyc pfp$release_locked_apfid
*copyc pfp$report_unexpected_status
*copyc pfp$return_catalog
*copyc pfp$set_status_abnormal
*copyc pfp$shared_queue
*copyc pfp$update_stale_cycle_entry
*copyc pfp$validate_password
*copyc pfp$validate_ring_access
*copyc pfv$locked_apfid
*copyc pfv$null_unique_name
*copyc pfv$unattached_status
*copyc pmp$compute_local_date_time
*copyc pmp$continue_to_cause
*copyc pmp$get_pseudo_mainframe_id
*copyc pmp$get_time_zone
*copyc pmp$get_user_identification
*copyc syp$pop_inhibit_job_recovery
*copyc syp$push_inhibit_job_recovery

?? TITLE := '  Global Declarations Declared by this module', EJECT ??

  TYPE
    adaptable_array_ptr_converter = record
      case adaptable_array_ptr_kind of
      = adaptable_array_ptr_data_rep =
        pva: ost$pva,
        array_size: 0 .. 0ffffffff(16),
        lower_bound: 0 .. 0ffffffff(16),
        element_size: 0 .. 0ffffffff(16),
      = archive_information_list_ptr =
        p_archive_information_list: ^fst$archive_information_list,
      = log_array_ptr =
        p_log_array: ^pft$log_array,
      = object_list_ptr =
        p_object_list: ^fst$goi_object_list,
      = permit_array_ptr =
        p_permit_array: ^pft$permit_array,
      = volume_condition_list_ptr =
        p_volume_condition_list: ^fst$volume_condition_list,
      = volume_list_ptr =
        p_volume_list: ^rmt$volume_list,
      casend,
    recend,

    adaptable_array_ptr_kind = (adaptable_array_ptr_data_rep, archive_information_list_ptr, log_array_ptr,
          object_list_ptr, permit_array_ptr, volume_condition_list_ptr, volume_list_ptr),

    adaptable_string_ptr_converter = record
      case adaptable_string_ptr_kind of
      = adaptable_string_ptr_data_rep =
        pva: ost$pva,
        length: 0 .. 0ffff(16),
      = file_reference_ptr =
        p_file_reference: ^fst$file_reference,
      casend,
    recend,

    adaptable_string_ptr_kind = (adaptable_string_ptr_data_rep, file_reference_ptr),

    sequence_ptr_converter = record
      case sequence_ptr_kind of
      = sequence_ptr =
        p_sequence: ^SEQ ( * ),
      = sequence_ptr_data_rep =
        pva: ost$pva,
        length: 0 .. 07fffffff(16),
        nextt: 0 .. 07fffffff(16),
      casend,
    recend,

    sequence_ptr_kind = (sequence_ptr, sequence_ptr_data_rep),

    subject_permit_id_list = array [1 .. * ] of subject_permit_identifier,

    subject_permit_identifier = record
      authority: pft$authority,
      permit_type: pft$permit_type,
      group_type: pft$group_types,
    recend;

  VAR
    pfv$catalog_info_requests: [XDCL, oss$job_paged_literal, READ] fst$goi_object_info_requests :=
          [fsc$goi_catalog_identity, fsc$goi_applicable_cat_permit, fsc$goi_catalog_device_info,
          fsc$goi_catalog_info, fsc$goi_catalog_permits, fsc$goi_catalog_size, fsc$goi_catalog_object_list,
          fsc$goi_file_object_list],
    pfv$cycle_info_requests: [XDCL, oss$job_paged_literal, READ] fst$goi_object_info_requests :=
          [fsc$goi_cycle_identity, fsc$goi_archive_info, fsc$goi_cycle_device_info, fsc$goi_cycle_info,
          fsc$goi_cycle_size, fsc$goi_file_label, fsc$goi_job_environment_info],
    pfv$file_info_requests: [XDCL, oss$job_paged_literal, READ] fst$goi_object_info_requests :=
          [fsc$goi_file_identity, fsc$goi_applicable_file_permit, fsc$goi_file_info, fsc$goi_file_log,
          fsc$goi_file_permits, fsc$goi_cycle_object_list];

  VAR
    object_list_requests: [oss$job_paged_literal, READ] fst$goi_object_info_requests :=
          [fsc$goi_catalog_object_list, fsc$goi_cycle_object_list, fsc$goi_file_object_list],
    protected_info_requests: [oss$job_paged_literal, READ] fst$goi_object_info_requests :=
          [fsc$goi_file_label, fsc$goi_job_environment_info],
    valid_objects: [oss$job_paged_literal, READ] pft$object_selections :=
          [pfc$file_object, pfc$catalog_object];

?? TITLE := '  [XDCL] pfp$get_attached_device_info', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to get the device information about a
{   cycle which is attached within the job.

  PROCEDURE [XDCL] pfp$get_attached_device_info
    (    temporary_file: boolean;
         served_family: boolean;
         served_family_locator: {input^} ^pft$served_family_locator,
         p_cycle_description: {input^} ^fmt$cycle_description;
         p_object: {output^} ^fst$goi_object;
     VAR p_object_information: ^SEQ ( * );
     VAR eoi: amt$file_byte_address;
     VAR status: ost$status);

    VAR
      device_information_initialized: boolean,
      dm_file_information: dmt$file_information,
      fmd_size: dmt$stored_fmd_size,
      p_device_information: ^fst$device_information,
      p_fmd: ^dmt$stored_fmd,
      removable_media_group: ost$name,
      shared_queue: pft$shared_queue,
      shared_queue_name: ost$name,
      volume_number: amt$volume_number;

    NEXT p_device_information IN p_object_information;
    IF p_device_information = NIL THEN
      osp$set_status_condition (pfe$info_full, status);
      RETURN;
    IFEND;

    IF temporary_file AND (p_cycle_description^.device_class = rmc$magnetic_tape_device) THEN
      fmp$get_attached_tape_info (p_cycle_description^.system_file_id, p_device_information^.
            magnetic_tape_device_info.volume_list, volume_number, p_device_information^.
            magnetic_tape_device_info.volume_overflow_allowed, p_device_information^.
            magnetic_tape_device_info.density, removable_media_group, p_object_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      p_object^.cycle_device_information := p_device_information;
    ELSEIF p_cycle_description^.device_class = rmc$mass_storage_device THEN
      fmd_size := #SIZE (dmt$stored_ms_fmd_header) + (4 * #SIZE (dmt$stored_ms_fmd_subfile));
      IF served_family THEN
        REPEAT
          PUSH p_fmd: [[REP fmd_size OF cell]];
          dmp$get_server_fmd (p_cycle_description^.system_file_id, p_fmd^, fmd_size, status);
        UNTIL status.normal OR (status.condition <> dme$fmd_too_small);
      ELSE
        PUSH p_fmd: [[REP fmd_size OF cell]];
        dmp$get_stored_fmd (p_cycle_description^.system_file_id, p_fmd^, status);

        IF (NOT status.normal) AND (status.condition = dme$fmd_too_small) THEN
          dmp$get_stored_fmd_size (p_cycle_description^.system_file_id, fmd_size, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          PUSH p_fmd: [[REP fmd_size OF cell]];
          dmp$get_stored_fmd (p_cycle_description^.system_file_id, p_fmd^, status);
        IFEND;
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      dmp$get_file_info (p_cycle_description^.system_file_id, dm_file_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      p_device_information^.mass_storage_device_info.bytes_allocated :=
            dm_file_information.total_allocated_length;

      IF temporary_file THEN
        p_device_information^.mass_storage_device_info.shared_queue := osc$null_name;
      ELSE
        pfp$convert_ord_to_shared_queue (dm_file_information.shared_queue, shared_queue_name, status);
        IF status.normal THEN
          p_device_information^.mass_storage_device_info.shared_queue := shared_queue_name;
        ELSE
          p_device_information^.mass_storage_device_info.shared_queue := pfc$system_shared_queue_name;
          status.normal := TRUE;
        IFEND;
      IFEND;

      get_disk_device_info_from_fmd (p_fmd, p_device_information, device_information_initialized,
            p_object_information, status);
      IF device_information_initialized THEN
        IF status.normal THEN
          get_object_condition ({catalog_object} FALSE, served_family, served_family_locator, p_fmd,
                p_device_information^.mass_storage_device_info,  p_object_information, status);
        IFEND;
        IF status.normal THEN
          p_object^.cycle_device_information := p_device_information;
        IFEND;
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      eoi := dm_file_information.eoi_byte_address;
    IFEND;
  PROCEND pfp$get_attached_device_info;

?? TITLE := '  [XDCL] pfp$r2_get_object_info', EJECT ??

{ PURPOSE:
{   This purpose of this procedure is to get subject permit information, the
{   set name, and the resolved path for the specified object.

  PROCEDURE [XDCL] pfp$r2_get_object_info
    (    family_location: pft$family_location;
         binary_mainframe_id: pmt$binary_mainframe_id;
         evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
         system_privilege: boolean;
         password_selector: pft$password_selector;
         subject_permit_count: ost$non_negative_integers;
         validation_ring: ost$valid_ring;
         p_validation_criteria: {i^/o^} ^fst$goi_validation_criteria;
         p_object_info: {output^} ^fst$goi_object_information;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    PROCEDURE get_object_info_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status,
        status_id: ost$status_identifier,
        variant_path: pft$variant_path;

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := p_path;

      IF NOT process_non_local_exit THEN
        pfp$log_ascii ('***PF Condition Handler***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, {critical_message} FALSE, local_status);
        pfp$log_path (variant_path, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
              {critical_message} FALSE, local_status);
      IFEND;

      CASE condition.selector OF
      = pmc$system_conditions, pmc$block_exit_processing, mmc$segment_access_condition =
        IF process_non_local_exit THEN
          RETURN;
        IFEND;

        IF catalog_locator.attached THEN
          catalog_locator.abort_catalog_operation := TRUE;
          pfp$return_catalog (catalog_locator, local_status);
          IF NOT local_status.normal THEN
            pfp$report_system_error (local_status);
          IFEND;
        IFEND;

        osp$set_status_from_condition (status_id, condition, p_sfsa, local_status, handler_status);
        osp$recoverable_system_error ('UNEXPECTED STATUS', ^local_status);

        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'PFP$R2_GET_OBJECT_INFO failure - see job log for details.', status);
        process_non_local_exit := TRUE;
        #SPOIL(process_non_local_exit);
        EXIT pfp$r2_get_object_info;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          process_non_local_exit := TRUE;
          #SPOIL(process_non_local_exit);
          EXIT pfp$r2_get_object_info;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND get_object_info_handler;

    VAR
      authority: pft$authority,
      catalog_locator: pft$catalog_locator,
      cycle_selector: pft$cycle_selector,
      local_authority: pft$authority,
      local_evaluated_file_reference: fst$evaluated_file_reference,
      local_status: ost$status,
      object_information_requests: fst$goi_object_info_requests,
      p_complete_path: ^pft$complete_path,
      p_cycle_list: ^pft$cycle_list,
      p_internal_path: ^pft$internal_path,
      p_path: ^pft$path,
      p_physical_cycle: ^pft$physical_cycle,
      p_physical_object: ^pft$physical_object,
      p_subject_permit_id_list: ^subject_permit_id_list,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      permitted_to_object: boolean,
      process_non_local_exit: boolean,
      unknown_cycle: boolean,
      variant_path: pft$variant_path;

    process_non_local_exit := FALSE;
    #SPOIL(process_non_local_exit);

    PUSH p_complete_path: [1 .. evaluated_file_reference.number_of_path_elements + 1];
    pfp$convert_fs_to_complete_path (evaluated_file_reference, p_complete_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$get_authority (p_complete_path^, system_privilege, authority, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF subject_permit_count = 0 THEN
      p_subject_permit_id_list := NIL;
    ELSE
      IF authority.ownership = $pft$ownership [] THEN
        osp$set_status_condition (pfe$neither_owner_nor_admin, status);
        RETURN;
      IFEND;

      PUSH p_subject_permit_id_list: [1 .. subject_permit_count];
      resolve_subject_permits (p_complete_path^, authority, p_validation_criteria, p_subject_permit_id_list,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    local_authority := authority;
    local_authority.ownership := $pft$ownership [pfc$system_owner];

    object_information_requests := information_request.object_information_requests;

    PUSH p_internal_path: [1 .. evaluated_file_reference.number_of_path_elements + 1];
    IF object_information_requests *
          $fst$goi_object_info_requests [fsc$goi_cycle_device_info, fsc$goi_cycle_size] <>
          $fst$goi_object_info_requests [] THEN
      {
      { A cycle's fmd may need to be reconciled, so the catalog must be
      { attached for write.
      {
      pfp$access_object (p_complete_path^, pfc$write_access, local_authority, valid_objects, parent_charge_id,
            catalog_locator, p_physical_object, p_internal_path^, permit_entry, status);
    ELSE
      pfp$access_object (p_complete_path^, pfc$read_access, local_authority, valid_objects, parent_charge_id,
            catalog_locator, p_physical_object, p_internal_path^, permit_entry, status);
    IFEND;

    IF NOT status.normal THEN
      IF (status.condition = pfe$unknown_item) AND (authority.ownership = $pft$ownership []) AND
            ((permit_entry.entry_type = pfc$free_permit_entry) OR
            NOT (pfc$cycle IN permit_entry.usage_permissions)) THEN
        variant_path.complete_path := TRUE;
        variant_path.p_complete_path := p_complete_path;
        pfp$set_status_abnormal (variant_path, pfe$unknown_permanent_file, status);
      IFEND;
      RETURN;
    IFEND;

    PUSH p_path: [1 .. evaluated_file_reference.number_of_path_elements];
    pfp$convert_fs_to_pft$path (evaluated_file_reference, p_path^);
    osp$establish_condition_handler (^get_object_info_handler, {block_exit} TRUE);

  /catalog_attached/
    BEGIN
      pfp$form_administrator_permit (authority, permit_entry);
      permitted_to_object := (authority.ownership <> $pft$ownership []) OR
            ((permit_entry.entry_type = pfc$normal_permit_entry) AND
            (permit_entry.usage_permissions <> $pft$permit_selections []));

      IF fsc$goi_set_name IN object_information_requests THEN
        p_object_info^.set_name := p_complete_path^ [pfc$set_path_index];
      IFEND;

    /resolve_path/
      BEGIN
        local_evaluated_file_reference := evaluated_file_reference;
        IF (p_physical_object^.object_entry.object_type = pfc$catalog_object) OR
              (fsc$goi_cycle_object_list IN object_information_requests) OR
              (object_information_requests * pfv$cycle_info_requests = $fst$goi_object_info_requests []) THEN
          local_evaluated_file_reference.cycle_reference.specification := fsc$cycle_omitted;
          unknown_cycle := FALSE; { The cycle is omitted, not unknown.
          p_physical_cycle := NIL;
        ELSEIF evaluated_file_reference.cycle_reference.specification = fsc$next_cycle THEN
          unknown_cycle := TRUE;
          p_physical_cycle := NIL;
          variant_path.complete_path := TRUE;
          variant_path.p_complete_path := p_complete_path;
          pfp$set_status_abnormal (variant_path, pfe$unknown_cycle, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, '$NEXT', status);
          EXIT /resolve_path/;
        ELSE
          pfp$build_cycle_list_pointer (p_physical_object^.object_entry.cycle_list_locator,
                catalog_locator.p_catalog_file, p_cycle_list);
          pfi$convert_cycle_reference (evaluated_file_reference.cycle_reference, cycle_selector, status);
          IF NOT status.normal THEN
            unknown_cycle := TRUE;
            p_physical_cycle := NIL;
            EXIT /resolve_path/;
          IFEND;

          pfp$locate_cycle (p_complete_path^, p_cycle_list, cycle_selector, p_physical_cycle, status);
          IF NOT status.normal THEN
            unknown_cycle := TRUE;
            EXIT /resolve_path/;
          IFEND;

          local_evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
          local_evaluated_file_reference.cycle_reference.cycle_number :=
                p_physical_cycle^.cycle_entry.cycle_number;
          unknown_cycle := FALSE;
        IFEND;

        store_resolved_path (local_evaluated_file_reference, p_object_info, p_object_information, status);
        IF (NOT status.normal) AND (status.condition = pfe$info_full) THEN
          EXIT /catalog_attached/;
        IFEND;
      END /resolve_path/;

      IF ((p_physical_object^.object_entry.object_type = pfc$file_object) AND
            (object_information_requests - pfv$catalog_info_requests <> $fst$goi_object_info_requests [])) OR
            ((p_physical_object^.object_entry.object_type = pfc$catalog_object) AND
            ((object_information_requests * pfv$catalog_info_requests <> $fst$goi_object_info_requests []) OR
            NOT permitted_to_object)) THEN
        get_object_information (family_location, binary_mainframe_id, p_complete_path^, information_request,
              authority, permit_entry, p_physical_object, unknown_cycle, password_selector, validation_ring,
              p_subject_permit_id_list, p_physical_cycle, p_object_info, catalog_locator, permitted_to_object,
              p_object_information, local_status);

        IF (NOT local_status.normal) AND (status.normal OR (local_status.condition = pfe$info_full)) THEN
          status := local_status;
        ELSEIF NOT permitted_to_object THEN
          variant_path.complete_path := TRUE;
          variant_path.p_complete_path := p_complete_path;
          pfp$set_status_abnormal (variant_path, pfe$unknown_item, status);
        IFEND;
      IFEND;
    END /catalog_attached/;

    osp$disestablish_cond_handler;
    pfp$return_catalog (catalog_locator, local_status);
    pfp$process_unexpected_status (local_status);
  PROCEND pfp$r2_get_object_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_get_object_information', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to get the requested information about the
{   specified catalog, file, or cycle.

  PROCEDURE [XDCL, #GATE] pfp$r2_get_object_information
    (    evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
         system_privilege: boolean;
         password_selector: pft$password_selector;
         subject_permit_count: ost$non_negative_integers;
         validation_ring: ost$valid_ring;
         p_validation_criteria: {i^/o^} ^fst$goi_validation_criteria;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      all_protected_info_returned: boolean,
      binary_mainframe_id: pmt$binary_mainframe_id,
      check_path_table_for_setfa: boolean,
      first_path_element_name: fst$path_element_name,
      local_evaluated_file_reference: fst$evaluated_file_reference,
      local_status: ost$status,
      object_info_offset: ost$segment_offset,
      p_cycle_description: ^fmt$cycle_description,
      p_local_object_information: ^SEQ ( * ),
      p_object_info: ^fst$goi_object_information,
      process_pt_results: bat$process_pt_results,
      scratch_segment_created: boolean,
      scratch_segment_pointer: amt$segment_pointer,
      segment_attributes: array [1 .. 1] of mmt$attribute_descriptor,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      setfa_found: boolean,
      using_local_object_info_seq: boolean;

    first_path_element_name := fsp$path_element (^evaluated_file_reference, 1)^;

    IF #SIZE (p_object_information^) <= 2000000 THEN
      PUSH p_local_object_information: [[REP #SIZE (p_object_information^) OF cell,
            REP #SIZE (p_object_information^) DIV #SIZE (fst$goi_object) OF pft$password]];
      RESET p_local_object_information;
      using_local_object_info_seq := TRUE;
      scratch_segment_created := FALSE;
    ELSE
      IF first_path_element_name = fsc$local THEN
        served_family := FALSE;
      ELSE
        find_family_location (first_path_element_name, served_family, served_family_locator);
      IFEND;

      IF NOT served_family THEN
        segment_attributes [1].keyword := mmc$kw_ring_numbers;
        mmp$fetch_segment_attributes (p_object_information, segment_attributes, status);
      IFEND;

      IF status.normal AND (NOT served_family) AND (segment_attributes [1].r2 <= osc$tsrv_ring) THEN
        p_local_object_information := p_object_information;
        using_local_object_info_seq := FALSE;
      ELSE
        mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, scratch_segment_pointer, status);
        IF status.normal THEN
          using_local_object_info_seq := TRUE;
          scratch_segment_created := TRUE;
          p_local_object_information := scratch_segment_pointer.sequence_pointer;
          RESET p_local_object_information;
        ELSE
          RETURN;
        IFEND;
      IFEND;
    IFEND;

  /get_information/
    BEGIN;
      NEXT p_object_info IN p_local_object_information;
      IF p_object_info = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        EXIT /get_information/;
      ELSE
        pfp$initialize_object_info (p_object_info);
      IFEND;

      IF first_path_element_name = fsc$local THEN
        IF subject_permit_count > 0 THEN
          check_subject_permits (evaluated_file_reference, p_validation_criteria, status);
          IF NOT status.normal THEN
            EXIT /get_information/;
          IFEND;
        IFEND;

        fmp$get_$local_object_info (evaluated_file_reference, information_request, password_selector,
              validation_ring, p_object_info, p_local_object_information, status);
        EXIT /get_information/;
      ELSEIF (evaluated_file_reference.cycle_reference.specification = fsc$cycle_number) AND
            (information_request.object_information_requests <= $fst$goi_object_info_requests
            [fsc$goi_set_name, fsc$goi_cycle_identity, fsc$goi_cycle_device_info, fsc$goi_cycle_size,
            fsc$goi_file_label, fsc$goi_job_environment_info]) AND (subject_permit_count = 0) THEN
        local_evaluated_file_reference := evaluated_file_reference;

        fmp$lock_path_table (status);
        IF NOT status.normal THEN
          EXIT /get_information/;
        IFEND;
        fmp$process_pt_request
              ($bat$process_pt_work_list [bac$inhibit_locking_pt, bac$return_cycle_description],
              {local_file_name} osc$null_name, local_evaluated_file_reference, p_cycle_description,
              process_pt_results, status);

        IF status.normal THEN
          IF p_cycle_description = NIL THEN
            check_path_table_for_setfa := FALSE;
          ELSEIF p_cycle_description^.attached_file AND (p_cycle_description^.device_class =
                rmc$mass_storage_device) THEN
            get_attached_cycle_information (evaluated_file_reference, information_request,
                  p_cycle_description, password_selector, validation_ring, p_object_info,
                  p_local_object_information, status);
            fmp$unlock_path_table;
            EXIT /get_information/;
          ELSE
            check_path_table_for_setfa := TRUE;
          IFEND;
        ELSE
          check_path_table_for_setfa := TRUE;
        IFEND;

        fmp$unlock_path_table;
      ELSE
        check_path_table_for_setfa := TRUE;
      IFEND;

      syp$push_inhibit_job_recovery;

      IF using_local_object_info_seq AND NOT scratch_segment_created THEN
        find_family_location (first_path_element_name, served_family, served_family_locator);
      IFEND;

      IF served_family THEN
        pfp$r2_df_client_get_obj_info (served_family_locator, evaluated_file_reference, information_request,
              system_privilege, password_selector, subject_permit_count, validation_ring,
              p_validation_criteria, p_object_info, object_info_offset, p_local_object_information, status);
        {
        { Convert all server pvas to client pvas.
        {
        IF status.normal OR
              ((status.condition <> pfe$pf_system_error) AND (status.condition <> pfe$catalog_access_retry))
              AND (object_info_offset > 0) THEN
          convert_object_info_pointers (object_info_offset, p_object_info, p_local_object_information,
                local_status);
          IF NOT local_status.normal THEN
            status := local_status;
          IFEND;
        IFEND;
      ELSE
        pmp$get_pseudo_mainframe_id (binary_mainframe_id);
        pfp$r2_get_object_info (pfc$local_mainframe, binary_mainframe_id, evaluated_file_reference,
              information_request, system_privilege, password_selector, subject_permit_count,
              validation_ring, p_validation_criteria, p_object_info, p_local_object_information, status);
      IFEND;

      syp$pop_inhibit_job_recovery;

      IF information_request.object_information_requests * $fst$goi_object_info_requests [fsc$goi_cycle_size,
            fsc$goi_file_label, fsc$goi_job_environment_info] <> $fst$goi_object_info_requests [] THEN
        IF NOT status.normal THEN
          IF ((status.condition = pfe$unknown_item) OR (status.condition = pfe$unknown_cycle)) AND
                check_path_table_for_setfa THEN
            {
            { The path table must be checked for setfa values.
            {
            NEXT p_object_info^.object IN p_local_object_information;
            IF p_object_info^.object = NIL THEN
              osp$set_status_condition (pfe$info_full, status);
              EXIT /get_information/;
            IFEND;

            fmp$get_setfa_values_for_object (evaluated_file_reference, information_request, validation_ring,
                  p_object_info^.object, p_local_object_information, setfa_found, local_status);
            IF setfa_found THEN
              store_resolved_path (evaluated_file_reference, p_object_info, p_local_object_information,
                    status);
            ELSE
              p_object_info^.object := NIL;
              IF NOT local_status.normal THEN
                status := local_status;
              IFEND;
            IFEND;

            EXIT /get_information/;
          ELSEIF (status.condition = pfe$info_full) OR (status.condition = pfe$pf_system_error) OR
                (status.condition = pfe$catalog_access_retry) THEN
            EXIT /get_information/;
          IFEND;
        IFEND;

        fmp$complete_pf_object_info (evaluated_file_reference, information_request, password_selector,
              validation_ring, p_object_info^.object, p_local_object_information, all_protected_info_returned,
              local_status);
        status.normal := status.normal OR
              ((status.condition = pfe$incorrect_password) AND all_protected_info_returned);
        IF (NOT local_status.normal) AND (status.normal OR (local_status.condition = pfe$info_full)) THEN
          status := local_status;
        IFEND;
      IFEND;
    END /get_information/;

    IF using_local_object_info_seq THEN
      IF status.normal OR
            ((status.condition <> pfe$pf_system_error) AND (status.condition <> pfe$catalog_access_retry)
            AND (p_object_info <> NIL)) THEN
        move_object_information (p_object_info, p_object_information, local_status);
        IF NOT local_status.normal THEN
          status := local_status;
        IFEND;
      IFEND;

      IF scratch_segment_created THEN
        mmp$delete_scratch_segment (scratch_segment_pointer, local_status);
      IFEND;
    ELSE
      p_object_information := p_local_object_information;
    IFEND;
  PROCEND pfp$r2_get_object_information;

?? TITLE := '  attach_next_catalog', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to retrieve the next catalog in the path
{   from device management.

  PROCEDURE attach_next_catalog
    (    path: pft$complete_path;
         object_information_requests: fst$goi_object_info_requests;
         p_physical_object: {input^} ^pft$physical_object;
     VAR catalog_locator: {i/o} pft$catalog_locator;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      new_catalog_locator: pft$catalog_locator;

    IF (fsc$goi_cycle_object_list IN object_information_requests) AND
          ($fst$goi_object_info_requests [fsc$goi_cycle_device_info, fsc$goi_cycle_size] *
          object_information_requests <> $fst$goi_object_info_requests []) THEN
      {
      { A cycle's fmd may need to be reconciled, so the catalog must be
      { attached for write.
      {
      pfp$access_next_catalog (pfc$write_access, catalog_locator, p_physical_object,
            ({catalog_remote} path [pfc$family_path_index] <> osv$system_family_name), new_catalog_locator,
            status);
    ELSE
      pfp$access_next_catalog (pfc$read_access, catalog_locator, p_physical_object,
            ({catalog_remote} path [pfc$family_path_index] <> osv$system_family_name), new_catalog_locator,
            status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF new_catalog_locator.internal_catalog_name <> catalog_locator.internal_catalog_name THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
    catalog_locator := new_catalog_locator;
  PROCEND attach_next_catalog;

?? TITLE := '  check_subject_permits', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to determine if any subject permits
{   identify someone other than the caller; if so, then an abnormal status is
{   returned.
{
{ NOTE:
{   This procedure should only be used when the caller is neither the owner nor
{   an administrator of the object and the object is a $local catalog, file, or
{   cycle.

  PROCEDURE check_subject_permits
    (    evaluated_file_reference: fst$evaluated_file_reference;
         p_validation_criteria: {i^/o^} ^fst$goi_validation_criteria;
     VAR status: ost$status);

    VAR
      criterion_index: ost$positive_integers,
      p_subject_permit: ^pft$permit_array_entry,
      user_id: ost$user_identification;

    pmp$get_user_identification (user_id, status);

    IF status.normal THEN
      FOR criterion_index := 1 TO UPPERBOUND (p_validation_criteria^) DO
        IF p_validation_criteria^ [criterion_index].validation_selection = fsc$goi_subject_permit THEN
          p_subject_permit := ^p_validation_criteria^ [criterion_index].subject_permit;

          IF ((p_subject_permit^.group.group_type = pfc$family) AND
                (p_subject_permit^.group.user_description.family = user_id.family)) OR
                ((p_subject_permit^.group.group_type = pfc$account) AND
                (p_subject_permit^.group.user_description.family = user_id.family)) OR
                ((p_subject_permit^.group.group_type = pfc$project) AND
                (p_subject_permit^.group.user_description.family = user_id.family)) OR
                ((p_subject_permit^.group.group_type = pfc$user) AND
                (p_subject_permit^.group.user_description.family = user_id.family) AND
                (p_subject_permit^.group.user_description.user = user_id.user)) OR
                ((p_subject_permit^.group.group_type = pfc$user_account) AND
                (p_subject_permit^.group.user_account_description.family = user_id.family) AND
                (p_subject_permit^.group.user_account_description.user = user_id.user)) OR
                ((p_subject_permit^.group.group_type = pfc$member) AND
                (p_subject_permit^.group.member_description.family = user_id.family) AND
                (p_subject_permit^.group.member_description.user = user_id.user)) THEN
            p_subject_permit^.usage_permissions := -$pft$permit_selections [];
            p_subject_permit^.share_requirements := $pft$share_requirements [];
            p_subject_permit^.application_info := osc$null_name;
          ELSE
            p_subject_permit^.usage_permissions := $pft$permit_selections [];
            p_subject_permit^.share_requirements := -$pft$share_selections [];
            p_subject_permit^.application_info := osc$null_name;
            bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$file_not_known,
                  'pfp$get_object_information', '', status);
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND check_subject_permits;

?? TITLE := '  convert_catalog_object_pointers', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to convert pvas, within a catalog object
{   of the object information sequence, which are valid on the server to pvas
{   which are valid on the client.

  PROCEDURE convert_catalog_object_pointers
    (    object_info_offset_difference: ost$segment_offset;
         p_object: {i^/o^} ^fst$goi_object;
     VAR p_object_information: {i/o} ^SEQ ( * );
     VAR status: ost$status);

    VAR
      adaptable_array_ptr_convtr: adaptable_array_ptr_converter,
      object_index: ost$positive_integers,
      p_device_information: ^fst$device_information,
      p_object_list: ^fst$goi_object_list,
      ring: ost$valid_ring,
      segment: ost$segment;

    ring := #RING (p_object_information);
    segment := #SEGMENT (p_object_information);

    IF p_object^.applicable_catalog_permit <> NIL THEN
      p_object^.applicable_catalog_permit := #ADDRESS (ring, segment,
            #OFFSET (p_object^.applicable_catalog_permit) - object_info_offset_difference);
    IFEND;

    IF p_object^.catalog_device_information <> NIL THEN
      p_object^.catalog_device_information := #ADDRESS (ring, segment,
            #OFFSET (p_object^.catalog_device_information) - object_info_offset_difference);

      RESET p_object_information TO p_object^.catalog_device_information;
      NEXT p_device_information IN p_object_information;
      IF p_device_information = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'p_device_information = NIL  convert_catalog_object_pointers', status);
        RETURN;
      IFEND;

      IF p_device_information^.mass_storage_device_info.volume_list <> NIL THEN
        adaptable_array_ptr_convtr.p_volume_list :=
              p_device_information^.mass_storage_device_info.volume_list;
        adaptable_array_ptr_convtr.pva.ring := ring;
        adaptable_array_ptr_convtr.pva.seg := segment;
        adaptable_array_ptr_convtr.pva.offset :=
              #OFFSET (p_device_information^.mass_storage_device_info.volume_list) -
              object_info_offset_difference;
        p_device_information^.mass_storage_device_info.volume_list :=
              adaptable_array_ptr_convtr.p_volume_list;
      IFEND;

      IF p_device_information^.mass_storage_device_info.volume_condition_list <> NIL THEN
        adaptable_array_ptr_convtr.p_volume_condition_list :=
              p_device_information^.mass_storage_device_info.volume_condition_list;
        adaptable_array_ptr_convtr.pva.ring := ring;
        adaptable_array_ptr_convtr.pva.seg := segment;
        adaptable_array_ptr_convtr.pva.offset :=
              #OFFSET (p_device_information^.mass_storage_device_info.volume_condition_list) -
              object_info_offset_difference;
        p_device_information^.mass_storage_device_info.volume_condition_list :=
              adaptable_array_ptr_convtr.p_volume_condition_list;
      IFEND;
    IFEND;

    IF p_object^.catalog_information <> NIL THEN
      p_object^.catalog_information := #ADDRESS (ring, segment,
            #OFFSET (p_object^.catalog_information) - object_info_offset_difference);
    IFEND;

    IF p_object^.catalog_permits <> NIL THEN
      adaptable_array_ptr_convtr.p_permit_array := p_object^.catalog_permits;
      adaptable_array_ptr_convtr.pva.ring := ring;
      adaptable_array_ptr_convtr.pva.seg := segment;
      adaptable_array_ptr_convtr.pva.offset :=
            #OFFSET (p_object^.catalog_permits) - object_info_offset_difference;
      p_object^.catalog_permits := adaptable_array_ptr_convtr.p_permit_array;
    IFEND;

    IF p_object^.catalog_size <> NIL THEN
      p_object^.catalog_size := #ADDRESS (ring, segment,
            #OFFSET (p_object^.catalog_size) - object_info_offset_difference);
    IFEND;

    IF p_object^.subcatalog_and_file_object_list <> NIL THEN
      adaptable_array_ptr_convtr.p_object_list := p_object^.subcatalog_and_file_object_list;
      adaptable_array_ptr_convtr.pva.ring := ring;
      adaptable_array_ptr_convtr.pva.seg := segment;
      adaptable_array_ptr_convtr.pva.offset :=
            #OFFSET (p_object^.subcatalog_and_file_object_list) - object_info_offset_difference;
      p_object^.subcatalog_and_file_object_list := adaptable_array_ptr_convtr.p_object_list;

      RESET p_object_information TO p_object^.subcatalog_and_file_object_list;
      NEXT p_object_list: [1 .. UPPERBOUND (p_object^.subcatalog_and_file_object_list^)]
            IN p_object_information;
      IF p_object_list = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'p_object_list = NIL  convert_catalog_object_pointers', status);
        RETURN;
      IFEND;

      FOR object_index := 1 TO UPPERBOUND (p_object_list^) DO
        CASE p_object_list^ [object_index].object_type OF
        = fsc$goi_catalog_object =
          convert_catalog_object_pointers (object_info_offset_difference, ^p_object_list^ [object_index],
                p_object_information, status);
        = fsc$goi_file_object =
          convert_file_object_pointers (object_info_offset_difference, ^p_object_list^ [object_index],
                p_object_information, status);
        ELSE
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                'Invalid object_type in subcatalog_and_file_object_list.  convert_catalog_object_pointers',
                status);
        CASEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    status.normal := TRUE;
  PROCEND convert_catalog_object_pointers;

?? TITLE := '  convert_cycle_object_pointers', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to convert pvas, within a cycle object of
{   the object information sequence, which are valid on the server to pvas
{   which are valid on the client.

  PROCEDURE convert_cycle_object_pointers
    (    object_info_offset_difference: ost$segment_offset;
         p_object: {i^/o^} ^fst$goi_object;
     VAR p_object_information: {i/o} ^SEQ ( * );
     VAR status: ost$status);

    VAR
      adaptable_array_ptr_convtr: adaptable_array_ptr_converter,
      archive_index: ost$positive_integers,
      object_index: ost$positive_integers,
      p_archive_information_list: ^fst$archive_information_list,
      p_device_information: ^fst$device_information,
      ring: ost$valid_ring,
      segment: ost$segment,
      sequence_ptr_convtr: sequence_ptr_converter;

    ring := #RING (p_object_information);
    segment := #SEGMENT (p_object_information);

    IF p_object^.archive_information_list <> NIL THEN
      adaptable_array_ptr_convtr.p_archive_information_list := p_object^.archive_information_list;
      adaptable_array_ptr_convtr.pva.ring := ring;
      adaptable_array_ptr_convtr.pva.seg := segment;
      adaptable_array_ptr_convtr.pva.offset :=
            #OFFSET (p_object^.archive_information_list) - object_info_offset_difference;
      p_object^.archive_information_list := adaptable_array_ptr_convtr.p_archive_information_list;

      RESET p_object_information TO p_object^.archive_information_list;
      NEXT p_archive_information_list: [1 .. UPPERBOUND (p_object^.archive_information_list^)]
            IN p_object_information;
      IF p_archive_information_list = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'p_archive_information_list = NIL  convert_cycle_object_pointers', status);
        RETURN;
      IFEND;

      FOR archive_index := 1 TO UPPERBOUND (p_object^.archive_information_list^) DO
        IF p_archive_information_list^ [archive_index].amd <> NIL THEN
          sequence_ptr_convtr.p_sequence := p_archive_information_list^ [archive_index].amd;
          sequence_ptr_convtr.pva.ring := ring;
          sequence_ptr_convtr.pva.seg := segment;
          sequence_ptr_convtr.pva.offset :=
                #OFFSET (p_archive_information_list^ [archive_index].amd) - object_info_offset_difference;
          p_archive_information_list^ [archive_index].amd := sequence_ptr_convtr.p_sequence;
        IFEND;
      FOREND;
    IFEND;

    IF p_object^.cycle_device_information <> NIL THEN
      p_object^.cycle_device_information := #ADDRESS (ring, segment,
            #OFFSET (p_object^.cycle_device_information) - object_info_offset_difference);

      RESET p_object_information TO p_object^.cycle_device_information;
      NEXT p_device_information IN p_object_information;
      IF p_device_information = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'p_device_information = NIL  convert_cycle_object_pointers', status);
        RETURN;
      IFEND;

      IF (p_object^.cycle_device_class = rmc$mass_storage_device) AND p_device_information^.
            mass_storage_device_info.resides_online THEN
        IF p_device_information^.mass_storage_device_info.volume_list <> NIL THEN
          adaptable_array_ptr_convtr.p_volume_list :=
                p_device_information^.mass_storage_device_info.volume_list;
          adaptable_array_ptr_convtr.pva.ring := ring;
          adaptable_array_ptr_convtr.pva.seg := segment;
          adaptable_array_ptr_convtr.pva.offset :=
                #OFFSET (p_device_information^.mass_storage_device_info.volume_list) -
                object_info_offset_difference;
          p_device_information^.mass_storage_device_info.volume_list :=
                adaptable_array_ptr_convtr.p_volume_list;
        IFEND;
        IF p_device_information^.mass_storage_device_info.volume_condition_list <> NIL THEN
          adaptable_array_ptr_convtr.p_volume_condition_list :=
                p_device_information^.mass_storage_device_info.volume_condition_list;
          adaptable_array_ptr_convtr.pva.ring := ring;
          adaptable_array_ptr_convtr.pva.seg := segment;
          adaptable_array_ptr_convtr.pva.offset :=
                #OFFSET (p_device_information^.mass_storage_device_info.volume_condition_list) -
                object_info_offset_difference;
          p_device_information^.mass_storage_device_info.volume_condition_list :=
                adaptable_array_ptr_convtr.p_volume_condition_list;
        IFEND;
      ELSEIF p_object^.cycle_device_class = rmc$magnetic_tape_device THEN
        IF p_device_information^.magnetic_tape_device_info.volume_list <> NIL THEN
          adaptable_array_ptr_convtr.p_volume_list :=
                p_device_information^.magnetic_tape_device_info.volume_list;
          adaptable_array_ptr_convtr.pva.ring := ring;
          adaptable_array_ptr_convtr.pva.seg := segment;
          adaptable_array_ptr_convtr.pva.offset :=
                #OFFSET (p_device_information^.magnetic_tape_device_info.volume_list) -
                object_info_offset_difference;
          p_device_information^.magnetic_tape_device_info.volume_list :=
                adaptable_array_ptr_convtr.p_volume_list;
        IFEND;
      IFEND;
    IFEND;

    IF p_object^.cycle_information <> NIL THEN
      p_object^.cycle_information := #ADDRESS (ring, segment,
            #OFFSET (p_object^.cycle_information) - object_info_offset_difference);
    IFEND;

    IF p_object^.cycle_size <> NIL THEN
      p_object^.cycle_size := #ADDRESS (ring, segment,
            #OFFSET (p_object^.cycle_size) - object_info_offset_difference);
    IFEND;

    IF p_object^.file_label <> NIL THEN
      sequence_ptr_convtr.p_sequence := p_object^.file_label;
      sequence_ptr_convtr.pva.ring := ring;
      sequence_ptr_convtr.pva.seg := segment;
      sequence_ptr_convtr.pva.offset := #OFFSET (p_object^.file_label) - object_info_offset_difference;
      p_object^.file_label := sequence_ptr_convtr.p_sequence;
    IFEND;

    status.normal := TRUE;
  PROCEND convert_cycle_object_pointers;

?? TITLE := '  convert_file_object_pointers', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to convert pvas, within a file object of
{   the object information sequence, which are valid on the server to pvas
{   which are valid on the client.

  PROCEDURE convert_file_object_pointers
    (    object_info_offset_difference: ost$segment_offset;
         p_object: {i^/o^} ^fst$goi_object;
     VAR p_object_information: {i/o} ^SEQ ( * );
     VAR status: ost$status);

    VAR
      adaptable_array_ptr_convtr: adaptable_array_ptr_converter,
      object_index: ost$positive_integers,
      p_file_information: ^fst$goi_file_information,
      p_object_list: ^fst$goi_object_list,
      ring: ost$valid_ring,
      segment: ost$segment;

    ring := #RING (p_object_information);
    segment := #SEGMENT (p_object_information);

    IF p_object^.applicable_file_permit <> NIL THEN
      p_object^.applicable_file_permit := #ADDRESS (ring, segment,
            #OFFSET (p_object^.applicable_file_permit) - object_info_offset_difference);
    IFEND;

    IF p_object^.file_information <> NIL THEN
      p_object^.file_information := #ADDRESS (ring, segment,
            #OFFSET (p_object^.file_information) - object_info_offset_difference);

      RESET p_object_information TO p_object^.file_information;
      NEXT p_file_information IN p_object_information;
      IF p_file_information = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'p_file_information = NIL  convert_file_object_pointers', status);
        RETURN;
      IFEND;

      p_file_information^.logging_selection := #ADDRESS (ring, segment,
            #OFFSET (p_file_information^.logging_selection) - object_info_offset_difference);
    IFEND;

    IF p_object^.file_log <> NIL THEN
      adaptable_array_ptr_convtr.p_log_array := p_object^.file_log;
      adaptable_array_ptr_convtr.pva.ring := ring;
      adaptable_array_ptr_convtr.pva.seg := segment;
      adaptable_array_ptr_convtr.pva.offset := #OFFSET (p_object^.file_log) - object_info_offset_difference;
      p_object^.file_log := adaptable_array_ptr_convtr.p_log_array;
    IFEND;

    IF p_object^.file_permits <> NIL THEN
      adaptable_array_ptr_convtr.p_permit_array := p_object^.file_permits;
      adaptable_array_ptr_convtr.pva.ring := ring;
      adaptable_array_ptr_convtr.pva.seg := segment;
      adaptable_array_ptr_convtr.pva.offset :=
            #OFFSET (p_object^.file_permits) - object_info_offset_difference;
      p_object^.file_permits := adaptable_array_ptr_convtr.p_permit_array;
    IFEND;

    IF p_object^.cycle_object_list <> NIL THEN
      adaptable_array_ptr_convtr.p_object_list := p_object^.cycle_object_list;
      adaptable_array_ptr_convtr.pva.ring := ring;
      adaptable_array_ptr_convtr.pva.seg := segment;
      adaptable_array_ptr_convtr.pva.offset :=
            #OFFSET (p_object^.cycle_object_list) - object_info_offset_difference;
      p_object^.cycle_object_list := adaptable_array_ptr_convtr.p_object_list;

      RESET p_object_information TO p_object^.cycle_object_list;
      NEXT p_object_list: [1 .. UPPERBOUND (p_object^.cycle_object_list^)] IN p_object_information;
      IF p_object_list = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'p_object_list = NIL  convert_file_object_pointers', status);
        RETURN;
      IFEND;

      FOR object_index := 1 TO UPPERBOUND (p_object_list^) DO
        IF p_object_list^ [object_index].object_type = fsc$goi_cycle_object THEN
          convert_cycle_object_pointers (object_info_offset_difference, ^p_object_list^ [object_index],
                p_object_information, status);
        ELSE
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                'Invalid object_type in cycle_object_list.  convert_file_object_pointers', status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    status.normal := TRUE;
  PROCEND convert_file_object_pointers;

?? TITLE := '  [INLINE] convert_group_to_authority', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to convert type pft$group to type
{   pft$authority.

  PROCEDURE [INLINE] convert_group_to_authority
    (    group: pft$group;
     VAR authority: pft$authority);

    authority.ownership := $pft$ownership [];
    authority.family := osc$null_name;
    authority.user := osc$null_name;
    authority.account := osc$null_name;
    authority.project := osc$null_name;

    CASE group.group_type OF
    = pfc$public =
      ;
    = pfc$family =
      authority.family := group.family_description.family;
    = pfc$account =
      authority.family := group.account_description.family;
      authority.account := group.account_description.account;
    = pfc$project =
      authority.family := group.project_description.family;
      authority.account := group.project_description.account;
      authority.project := group.project_description.project;
    = pfc$user =
      authority.family := group.user_description.family;
      authority.user := group.user_description.user;
    = pfc$user_account =
      authority.family := group.user_account_description.family;
      authority.account := group.user_account_description.account;
      authority.user := group.user_account_description.user;
    = pfc$member =
      authority.family := group.member_description.family;
      authority.account := group.member_description.account;
      authority.project := group.member_description.project;
      authority.user := group.member_description.user;
    ELSE
      ;
    CASEND;
  PROCEND convert_group_to_authority;

?? TITLE := '  convert_object_info_pointers', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to convert pvas, within the object
{   information sequence, which are valid on the server to pvas which are valid
{   on the client.
{
{ NOTE:
{   The offsets must be converted, as well as the segment numbers, because the
{   server may not start the information at the same offset in the segment as
{   would the client for two reasons.  First, the server uses the upper most
{   512K bytes of the segment, thus starting the information in the middle of
{   the segment.  Second, the caller may have pushed the sequence onto a stack,
{   allocated it into the middle of a segment, or reset the sequence pointer to
{   other than the first byte of the sequence; and the server does not use the
{   same physical memory for output as was provided by the caller.

  PROCEDURE convert_object_info_pointers
    (    server_object_info_offset: ost$segment_offset;
         p_object_info: {i/o^} ^fst$goi_object_information;
         p_object_information: {i/o^} ^SEQ ( * );
     VAR status: ost$status);

    VAR
      adaptable_string_ptr_convtr: adaptable_string_ptr_converter,
      object_info_offset_difference: ost$segment_offset,
      p_local_object_information: ^SEQ ( * ),
      p_object: ^fst$goi_object;

    p_local_object_information := p_object_information;
    object_info_offset_difference := server_object_info_offset - #OFFSET (p_object_info);

    IF p_object_info^.resolved_path <> NIL THEN
      adaptable_string_ptr_convtr.p_file_reference := p_object_info^.resolved_path;
      adaptable_string_ptr_convtr.pva.ring := #RING (p_local_object_information);
      adaptable_string_ptr_convtr.pva.seg := #SEGMENT (p_local_object_information);
      adaptable_string_ptr_convtr.pva.offset :=
            #OFFSET (p_object_info^.resolved_path) - object_info_offset_difference;
      p_object_info^.resolved_path := adaptable_string_ptr_convtr.p_file_reference;
    IFEND;

    IF p_object_info^.object <> NIL THEN
      p_object_info^.object := #ADDRESS (#RING (p_local_object_information),
            #SEGMENT (p_local_object_information),
            #OFFSET (p_object_info^.object) - object_info_offset_difference);

      RESET p_local_object_information TO p_object_info^.object;
      NEXT p_object IN p_local_object_information;
      IF p_object = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'p_object = NIL in convert_object_info_pointers', status);
        RETURN;
      IFEND;

      CASE p_object^.object_type OF
      = fsc$goi_catalog_object =
        convert_catalog_object_pointers (object_info_offset_difference, p_object, p_local_object_information,
              status);
      = fsc$goi_file_object =
        convert_file_object_pointers (object_info_offset_difference, p_object, p_local_object_information,
              status);
      = fsc$goi_cycle_object =
        convert_cycle_object_pointers (object_info_offset_difference, p_object, p_local_object_information,
              status);
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'Invalid object_type in convert_object_info_pointers.', status);
      CASEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    status.normal := TRUE;
  PROCEND convert_object_info_pointers;

?? TITLE := '  cycle_condition', EJECT ??

  FUNCTION [INLINE, UNSAFE] cycle_condition
    (    p_catalog_file: {input^} pft$p_catalog_file;
         p_physical_cycle: ^pft$physical_cycle): fst$file_access_condition;

    VAR
      file_duplicated: boolean,
      local_status: ost$status;

    cycle_condition := fsc$null_file_access_condition;
    IF (p_physical_cycle <> NIL) THEN
      IF p_physical_cycle^.cycle_entry.data_residence = pfc$offline_data THEN
        pfp$check_archive_entries (p_catalog_file, p_physical_cycle, file_duplicated, local_status);
        IF local_status.normal AND file_duplicated THEN
          cycle_condition := fsc$data_retrieval_required;
        ELSE
          cycle_condition := fsc$data_restoration_required;
        IFEND;
      ELSE
        cycle_condition := fsc$data_restoration_required;
      IFEND;
    IFEND;

  FUNCEND cycle_condition;
?? TITLE := '  [INLINE] determine_access_modes', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to determine the total modes of access for
{   which the cycle is attached throughout the system and the total modes of
{   access for which the cycle cannot be attached within the system.

  PROCEDURE [INLINE] determine_access_modes
    (    attach_status: pft$attach_status;
     VAR outstanding_access_modes: pft$usage_selections;
     VAR prevented_access_modes: pft$usage_selections);

    VAR
      usage_option: pft$usage_options;

    outstanding_access_modes := $pft$usage_selections [];
    prevented_access_modes := $pft$usage_selections [];

    IF attach_status.attach_count > 0 THEN
      FOR usage_option := LOWERVALUE (usage_option) TO UPPERVALUE (usage_option) DO
        IF attach_status.usage_counts [usage_option] > 0 THEN
          outstanding_access_modes := outstanding_access_modes + $pft$usage_selections [usage_option];
        IFEND;

        IF attach_status.prevent_usage_counts [usage_option] > 0 THEN
          prevented_access_modes := prevented_access_modes + $pft$usage_selections [usage_option];
        IFEND;
      FOREND;
    IFEND;
  PROCEND determine_access_modes;

?? TITLE := '  determine_mainframe_concurrency', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to determine if a cycle is attached on
{   this mainframe and/or on another mainframe, or on no mainframe; and whether
{   it isn't attached for write, or whether it may be shared for write on this
{   mainframe, or whether it may be shared for write between mainframes.
{
{ NOTE:
{   Until mainframe write concurrency is actually implemented,
{   fsc$shared_mass_storage really means "the cycle is attached for write on
{   another mainframe and mainframe write concurrency is not allowed."

  PROCEDURE determine_mainframe_concurrency
    (    binary_mainframe_id: pmt$binary_mainframe_id;
         cycle_entry: pft$cycle_entry;
         prevented_access_modes: pft$usage_selections;
         p_catalog_file: {input^} ^pft$catalog_file;
     VAR mainframe_usage_concurrency: fst$mainframe_usage_concurrency;
     VAR mainframe_write_concurrency: fst$mainframe_write_concurrency);

    VAR
      mainframe_usage_index: pft$mainframe_usage_index,
      p_mainframe_usage_list: ^pft$mainframe_usage_list;

    IF cycle_entry.attach_status.attach_count = 0 THEN
      mainframe_usage_concurrency := $fst$mainframe_usage_concurrency [];
      mainframe_write_concurrency := fsc$not_attached_for_write;
      RETURN;
    IFEND;

    IF cycle_entry.first_mainframe_usage_entry.entry_type = pfc$free_mainframe_entry THEN
      mainframe_usage_concurrency := $fst$mainframe_usage_concurrency [];
      IF $pft$usage_selections [pfc$append, pfc$modify, pfc$shorten] <= prevented_access_modes THEN
        {
        { unwilling to share for any form of write
        {
        mainframe_write_concurrency := fsc$not_attached_for_write;
      ELSE
        mainframe_write_concurrency := fsc$shared_memory;
      IFEND;
    ELSE
      IF cycle_entry.first_mainframe_usage_entry.attach_count = 0 THEN
        mainframe_usage_concurrency := $fst$mainframe_usage_concurrency [];
      ELSEIF cycle_entry.first_mainframe_usage_entry.mainframe_id = binary_mainframe_id THEN
        mainframe_usage_concurrency := $fst$mainframe_usage_concurrency [fsc$attached_on_this_mainframe];
      ELSE
        mainframe_usage_concurrency := $fst$mainframe_usage_concurrency [fsc$attached_on_other_mainframe];
      IFEND;

      IF cycle_entry.first_mainframe_usage_entry.write_count = 0 THEN
        IF $pft$usage_selections [pfc$append, pfc$modify, pfc$shorten] <= prevented_access_modes THEN
          {
          { unwilling to share for any form of write
          {
          mainframe_write_concurrency := fsc$not_attached_for_write;
        ELSE
          mainframe_write_concurrency := fsc$shared_memory;
        IFEND;
      ELSEIF cycle_entry.first_mainframe_usage_entry.mainframe_id = binary_mainframe_id THEN
        mainframe_write_concurrency := fsc$shared_memory;
      ELSE
        mainframe_write_concurrency := fsc$shared_mass_storage;
      IFEND;
    IFEND;

    pfp$build_mainfram_list_pointer (cycle_entry.mainframe_usage_list_locator, p_catalog_file,
          p_mainframe_usage_list);
    IF p_mainframe_usage_list <> NIL THEN
      FOR mainframe_usage_index := 1 TO UPPERBOUND (p_mainframe_usage_list^) DO
        IF p_mainframe_usage_list^ [mainframe_usage_index].mainframe_usage.entry_type =
              pfc$normal_mainframe_entry THEN
          IF p_mainframe_usage_list^ [mainframe_usage_index].mainframe_usage.attach_count > 0 THEN
            IF p_mainframe_usage_list^ [mainframe_usage_index].mainframe_usage.mainframe_id =
                  binary_mainframe_id THEN
              mainframe_usage_concurrency := mainframe_usage_concurrency +
                    $fst$mainframe_usage_concurrency [fsc$attached_on_this_mainframe];
            ELSE
              mainframe_usage_concurrency := mainframe_usage_concurrency +
                    $fst$mainframe_usage_concurrency [fsc$attached_on_other_mainframe];
            IFEND;
          IFEND;

          IF (p_mainframe_usage_list^ [mainframe_usage_index].mainframe_usage.write_count > 0) AND
                (mainframe_write_concurrency <> fsc$shared_mass_storage) THEN
            IF p_mainframe_usage_list^ [mainframe_usage_index].mainframe_usage.mainframe_id =
                  binary_mainframe_id THEN
              mainframe_write_concurrency := fsc$shared_memory;
            ELSE
              mainframe_write_concurrency := fsc$shared_mass_storage;
            IFEND;
          IFEND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND determine_mainframe_concurrency;

?? TITLE := '  find_family_location', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to determine on which mainframe the
{   specified family resides.

  PROCEDURE find_family_location
    (    family_name: ost$family_name;
     VAR served_family: boolean;
     VAR served_family_locator: pft$served_family_locator);

    VAR
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
      self_serving: boolean,
      server_state: dft$server_state;

    served_family_locator.server_location.server_location_selector := dfc$served_family_table_index;
    dfp$locate_served_family (family_name, served_family, served_family_locator.served_family_table_index,
          served_family_locator.server_mainframe_id,
          p_queue_interface_table,
          queue_index, server_state);
    IF served_family THEN
      served_family_locator.server_location.served_family_table_index :=
            served_family_locator.served_family_table_index;
      dfp$check_self_serving_job (served_family_locator.server_mainframe_id, self_serving);
      served_family := NOT self_serving;
      #KEYPOINT (osk$debug, osk$m * queue_index,
            pfk$file_server_request);
    IFEND;
  PROCEND find_family_location;

?? TITLE := '  get_attached_cycle_information', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to get the requested information about a
{   cycle which is attached within the job.

  PROCEDURE get_attached_cycle_information
    (    evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
         p_cycle_description: {input^} ^fmt$cycle_description;
         password_selector: pft$password_selector;
         validation_ring: ost$valid_ring;
         p_object_info: {output^} ^fst$goi_object_information;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      eoi: amt$file_byte_address,
      family_name: ost$family_name,
      file_previously_opened: boolean,
      local_status: ost$status,
      object_information_requests: fst$goi_object_info_requests,
      p_size: ^amt$file_byte_address,
      served_family: boolean,
      served_family_locator: pft$served_family_locator;

    object_information_requests := information_request.object_information_requests;

    IF object_information_requests * $fst$goi_object_info_requests [fsc$goi_set_name,
          fsc$goi_cycle_device_info, fsc$goi_job_environment_info, fsc$goi_file_label] <>
          $fst$goi_object_info_requests [] THEN
      family_name := fsp$path_element (^evaluated_file_reference, 1)^;
      find_family_location (family_name, served_family, served_family_locator);

      IF fsc$goi_set_name IN object_information_requests THEN
        IF served_family THEN
          pfp$r2_df_client_get_family_set (family_name, served_family_locator, p_object_info^.set_name,
                status);
        ELSE
          osp$get_set_name (family_name, p_object_info^.set_name, status);
        IFEND;
      IFEND;
    IFEND;

    store_resolved_path (evaluated_file_reference, p_object_info, p_object_information, local_status);
    IF NOT local_status.normal THEN
      IF local_status.condition = pfe$info_full THEN
        status := local_status;
        RETURN;
      ELSEIF status.normal THEN
        status := local_status;
      IFEND;
    IFEND;

    IF ((object_information_requests - pfv$catalog_info_requests = $fst$goi_object_info_requests []) AND
          (evaluated_file_reference.number_of_path_elements > 1)) OR
          (object_information_requests = $fst$goi_object_info_requests []) THEN
      RETURN;
    IFEND;

    NEXT p_object_info^.object IN p_object_information;
    IF p_object_info^.object = NIL THEN
      osp$set_status_condition (pfe$info_full, status);
      RETURN;
    IFEND;

    initialize_cycle_object (evaluated_file_reference.cycle_reference.cycle_number,
          p_cycle_description^.system_file_label.descriptive_label.global_file_name,
          p_cycle_description^.device_class, {validation_error} FALSE, p_object_info^.object);

    IF fsc$goi_cycle_device_info IN object_information_requests THEN
      pfp$get_attached_device_info ({temporary_file} FALSE, served_family, ^served_family_locator,
            p_cycle_description, p_object_info^.object, p_object_information, eoi, local_status);
      IF NOT local_status.normal THEN
        IF local_status.condition = pfe$info_full THEN
          status := local_status;
          RETURN;
        ELSEIF status.normal THEN
          status := local_status;
        IFEND;
      IFEND;
    IFEND;

  /get_cycle_size/
    BEGIN
      IF (fsc$goi_cycle_size IN object_information_requests) AND (p_cycle_description^.device_class =
            rmc$mass_storage_device) THEN
        NEXT p_size IN p_object_information;
        IF p_size = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          RETURN;
        IFEND;

        IF p_cycle_description^.global_file_information^.eoi_set AND
              (p_cycle_description^.attached_share_modes <= $fst$file_access_options [fsc$execute, fsc$read])
              THEN
          p_size^ := p_cycle_description^.global_file_information^.eoi_byte_address;
        ELSEIF fsc$goi_cycle_device_info IN object_information_requests THEN
          p_size^ := eoi;
        ELSE
          dmp$fetch_eoi (p_cycle_description^.system_file_id, p_size^, local_status);
          IF NOT local_status.normal THEN
            IF status.normal THEN
              status := local_status;
            IFEND;
            EXIT /get_cycle_size/;
          IFEND;
        IFEND;

        p_object_info^.object^.cycle_size := p_size;
      IFEND;
    END /get_cycle_size/;

    IF (fsc$goi_job_environment_info IN object_information_requests) OR
          (fsc$goi_file_label IN object_information_requests) THEN
      get_protected_info_from_cd (served_family, served_family_locator, evaluated_file_reference,
            object_information_requests, p_cycle_description, password_selector, validation_ring,
            p_object_info^.object, p_object_information, status);
      IF (NOT local_status.normal) AND (status.normal OR (local_status.condition = pfe$info_full)) THEN
        status := local_status;
      IFEND;
    IFEND;
  PROCEND get_attached_cycle_information;

?? TITLE := '  get_catalog_object_information', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to get the requested information about the
{   specified catalog.

  PROCEDURE get_catalog_object_information
    (    family_location: pft$family_location;
         binary_mainframe_id: pmt$binary_mainframe_id;
         path: pft$complete_path;
         information_request: fst$goi_information_request;
         current_depth: fst$path_element_index;
         authority: pft$authority;
         permit_entry: pft$permit_entry;
         p_physical_object: {input^} ^pft$physical_object;
         password_selector: pft$password_selector;
         validation_ring: ost$valid_ring;
         p_subject_permit_id_list: {i/o^} ^subject_permit_id_list;
         p_object: {output^} ^fst$goi_object;
     VAR catalog_locator: {i/o} pft$catalog_locator;
     VAR permitted_to_catalog: {i/o} boolean;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      device_information_initialized: boolean,
      dm_file_information: dmt$file_information,
      global_file_name: ost$binary_unique_name,
      local_date_time: ost$date_time,
      local_status: ost$status,
      local_time_zone: ost$time_zone,
      object_information_requests: fst$goi_object_info_requests,
      p_device_information: ^fst$device_information,
      p_physical_fmd: ^pft$physical_fmd,
      p_size: ^amt$file_byte_address;

     VAR
      catalog: boolean,
      catalog_recreated: boolean,
      cycle_selector: pft$cycle_selector,
      device_class: rmt$device_class,
      file_gfn: ost$binary_unique_name,
      fmd_size: dmt$stored_fmd_size,
      p_stored_fmd: ^dmt$stored_fmd;

    object_information_requests := information_request.object_information_requests;

    IF fsc$goi_applicable_cat_permit IN object_information_requests THEN
      NEXT p_object^.applicable_catalog_permit IN p_object_information;
      IF p_object^.applicable_catalog_permit = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      p_object^.applicable_catalog_permit^.permit_type := pfc$indirect_permit;
      p_object^.applicable_catalog_permit^.group := permit_entry.group;
      p_object^.applicable_catalog_permit^.usage_permissions := permit_entry.usage_permissions;
      p_object^.applicable_catalog_permit^.share_requirements := permit_entry.share_requirements;
      p_object^.applicable_catalog_permit^.application_info := permit_entry.application_info;
    IFEND;

    IF (fsc$goi_catalog_device_info IN object_information_requests) THEN
      IF p_physical_object^.object_entry.catalog_object_locator.catalog_type = pfc$external_catalog THEN
        pfp$build_fmd_pointer (p_physical_object^.object_entry.catalog_object_locator.fmd_locator,
              catalog_locator.p_catalog_file, p_physical_fmd);

        IF p_physical_fmd = NIL THEN
          p_device_information := NIL;
          status.normal := TRUE;
        ELSE
          NEXT p_device_information IN p_object_information;
          IF p_device_information = NIL THEN
            osp$set_status_condition (pfe$info_full, status);
            RETURN;
          IFEND;

          get_disk_device_info_from_fmd (^p_physical_fmd^.fmd, p_device_information,
                device_information_initialized, p_object_information, status);
          IF (NOT status.normal) AND (status.condition = pfe$info_full) THEN
            RETURN;
          ELSEIF NOT device_information_initialized THEN
            p_device_information := NIL;
          IFEND;
          {
          { Bytes_allocated cannot be retrieved without attaching the catalog.
          { The catalog must not be attached yet, but will be attached below.
          {
        IFEND;
      ELSE
        cycle_selector.cycle_option := pfc$highest_cycle;
        pfp$r2_get_stored_fmd_size (path, cycle_selector, device_class, file_gfn, fmd_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        PUSH p_stored_fmd: [[REP fmd_size OF cell]];
        IF p_stored_fmd = NIL THEN
          p_device_information := NIL;
          status.normal := TRUE;
        ELSE
          pfp$r2_get_stored_fmd (path, cycle_selector, catalog, catalog_recreated, file_gfn,
              p_stored_fmd^, status);
          IF status.normal THEN
            NEXT p_device_information IN p_object_information;
            IF p_device_information = NIL THEN
              osp$set_status_condition (pfe$info_full, status);
              RETURN;
            IFEND;

            get_disk_device_info_from_fmd (p_stored_fmd, p_device_information,
                  device_information_initialized, p_object_information, status);
            IF (NOT status.normal) AND (status.condition = pfe$info_full) THEN
              RETURN;
            ELSEIF NOT device_information_initialized THEN
              p_device_information := NIL;
            IFEND;
            {
            { Bytes_allocated cannot be retrieved without attaching the catalog.
            { The catalog must not be attached yet, but will be attached below.
            {
          ELSEIF status.condition = pfe$catalog_access_retry THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    ELSE
      p_device_information := NIL;
      status.normal := TRUE;
    IFEND;

    IF fsc$goi_catalog_info IN object_information_requests THEN
      NEXT p_object^.catalog_information IN p_object_information;
      IF p_object^.catalog_information = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      p_object^.catalog_information^.account := p_physical_object^.object_entry.charge_id.account;
      global_file_name := p_physical_object^.object_entry.internal_object_name;
      p_object^.catalog_information^.creation_date_time.year := global_file_name.year - 1900;
      p_object^.catalog_information^.creation_date_time.month := global_file_name.month;
      p_object^.catalog_information^.creation_date_time.day := global_file_name.day;
      p_object^.catalog_information^.creation_date_time.hour := global_file_name.hour;
      p_object^.catalog_information^.creation_date_time.minute := global_file_name.minute;
      p_object^.catalog_information^.creation_date_time.second := global_file_name.second;
      p_object^.catalog_information^.creation_date_time.millisecond := 000;
      p_object^.catalog_information^.project := p_physical_object^.object_entry.charge_id.project;
      {
      { Here the creation_date_time is converted to local_date_time
      {
      pmp$get_time_zone (local_time_zone, local_status);
      pmp$compute_local_date_time (p_object^.catalog_information^.creation_date_time, local_time_zone,
            local_date_time, local_status);
      p_object^.catalog_information^.creation_date_time := local_date_time;
    IFEND;

    IF fsc$goi_catalog_permits IN object_information_requests THEN
      get_permits (authority, p_physical_object^.object_entry.permit_list_locator,
            catalog_locator.p_catalog_file, p_object, p_object_information, local_status);
      IF NOT local_status.normal THEN
        status := local_status;
        RETURN;
      IFEND;
    IFEND;

    IF fsc$goi_catalog_size IN object_information_requests THEN
      NEXT p_size IN p_object_information;
      IF p_size = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;
      {
      { Catalog_size cannot be retrieved without attaching the catalog. The
      { catalog will be attached below.
      {
    IFEND;

    IF p_device_information <> NIL THEN
      IF p_physical_object^.object_entry.catalog_object_locator.catalog_type = pfc$external_catalog THEN
        get_object_condition ({catalog_object} TRUE, {served_family} FALSE,
             {p_served_family_locator} NIL, ^p_physical_fmd^.fmd,
             p_device_information^.mass_storage_device_info, p_object_information, status);
      ELSE
        get_object_condition ({catalog_object} TRUE, {served_family} FALSE,
             {p_served_family_locator} NIL, p_stored_fmd,
             p_device_information^.mass_storage_device_info, p_object_information, status);
      IFEND;
    IFEND;

    IF (p_device_information <> NIL) OR (fsc$goi_catalog_size IN object_information_requests) OR
          (object_information_requests * object_list_requests <> $fst$goi_object_info_requests []) OR
          (information_request.catalog_depth.depth_specification = fsc$entire_subtree) OR
          (current_depth < information_request.catalog_depth.depth) OR NOT permitted_to_catalog THEN
      attach_next_catalog (path, object_information_requests, p_physical_object, catalog_locator,
            local_status);
      IF NOT local_status.normal THEN
        IF osp$file_access_condition (local_status) THEN
          IF p_device_information <> NIL THEN
            p_device_information^.mass_storage_device_info.bytes_allocated := 16384;
            p_device_information^.mass_storage_device_info.shared_queue := osc$null_name;
            p_object^.catalog_device_information := p_device_information;
          IFEND;
        ELSEIF status.normal THEN
          status := local_status;
        IFEND;
        RETURN;
      IFEND;

    /get_bytes_allocated_and_eoi/
      BEGIN
        IF (p_device_information <> NIL) OR (fsc$goi_catalog_size IN object_information_requests) THEN
          dmp$get_file_info (catalog_locator.system_file_id, dm_file_information, local_status);
          IF NOT local_status.normal THEN
            IF status.normal THEN
              status := local_status;
            IFEND;
            EXIT /get_bytes_allocated_and_eoi/;
          IFEND;

          IF p_device_information <> NIL THEN
            p_device_information^.mass_storage_device_info.bytes_allocated :=
                  dm_file_information.total_allocated_length;
            p_device_information^.mass_storage_device_info.shared_queue := osc$null_name;
            IF status.normal THEN
              p_object^.catalog_device_information := p_device_information;
            IFEND;
          IFEND;

          IF fsc$goi_catalog_size IN object_information_requests THEN
            p_size^ := dm_file_information.eoi_byte_address;
            p_object^.catalog_size := p_size;
          IFEND;
        IFEND;
      END /get_bytes_allocated_and_eoi/;

      IF (catalog_locator.object_list_descriptor.p_object_list <> NIL) AND
            ((object_information_requests * object_list_requests <> $fst$goi_object_info_requests []) OR
            (information_request.catalog_depth.depth_specification = fsc$entire_subtree) OR
            (current_depth < information_request.catalog_depth.depth) OR NOT permitted_to_catalog) THEN
        get_object_list_information (family_location, binary_mainframe_id, path, information_request,
              current_depth, authority, permit_entry, password_selector, validation_ring,
              p_subject_permit_id_list, p_object, catalog_locator, permitted_to_catalog, p_object_information,
              local_status);
        IF (NOT local_status.normal) AND (status.normal OR (local_status.condition = pfe$info_full)) THEN
          status := local_status;
        IFEND;
      IFEND;
    IFEND;
  PROCEND get_catalog_object_information;

?? TITLE := '  get_cycle_list_information', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to get the requested information about the
{   specified cycle(s).

  PROCEDURE get_cycle_list_information
    (    family_location: pft$family_location;
         binary_mainframe_id: pmt$binary_mainframe_id;
         path: pft$complete_path;
         object_information_requests: fst$goi_object_info_requests;
         authority: pft$authority;
         p_physical_object: {input^} ^pft$physical_object;
         p_catalog_file: {input^} ^pft$catalog_file;
         password_selector: pft$password_selector;
         validation_ring: ost$valid_ring;
         p_physical_cycle: {i/o^} ^pft$physical_cycle;
         p_object: {output^} ^fst$goi_object;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      cycle_count: pft$cycle_count,
      cycle_index: pft$cycle_index,
      cycle_info_requested: fst$goi_object_info_requests,
      cycle_selector: pft$cycle_selector,
      device_class: rmt$device_class,
      local_status: ost$status,
      p_cycle_list: ^pft$cycle_list,
      p_local_physical_cycle: ^pft$physical_cycle,
      password_status: ost$status;

    cycle_info_requested := object_information_requests * pfv$cycle_info_requests;

    IF cycle_info_requested * protected_info_requests = $fst$goi_object_info_requests [] THEN
      password_status.normal := TRUE;
    ELSEIF password_selector.password_specified = pfc$default_password_option THEN
      pfp$validate_password (path, authority, osc$null_name, p_physical_object, password_status);
    ELSE
      pfp$validate_password (path, authority, password_selector.password, p_physical_object, password_status);
    IFEND;

    IF fsc$goi_cycle_object_list IN object_information_requests THEN
      pfp$build_cycle_list_pointer (p_physical_object^.object_entry.cycle_list_locator, p_catalog_file,
            p_cycle_list);
      IF p_cycle_list = NIL THEN
        IF NOT password_status.normal THEN
          status := password_status;
        ELSE
          status.normal := TRUE;
        IFEND;
        RETURN;
      IFEND;

      cycle_count := 0;
      FOR cycle_index := 1 TO UPPERBOUND (p_cycle_list^) DO
        IF p_cycle_list^ [cycle_index].cycle_entry.entry_type = pfc$normal_cycle_entry THEN
          cycle_count := cycle_count + 1;
        IFEND;
      FOREND;

      NEXT p_object^.cycle_object_list: [1 .. cycle_count] IN p_object_information;
      IF p_object^.cycle_object_list = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      cycle_count := 0;
      cycle_info_requested := cycle_info_requested -
            $fst$goi_object_info_requests [fsc$goi_cycle_identity, fsc$goi_job_environment_info];
      status.normal := TRUE;

      FOR cycle_index := 1 TO UPPERBOUND (p_cycle_list^) DO
        IF p_cycle_list^ [cycle_index].cycle_entry.entry_type = pfc$normal_cycle_entry THEN
          p_local_physical_cycle := ^p_cycle_list^ [cycle_index];
          cycle_count := cycle_count + 1;

          IF p_local_physical_cycle^.cycle_entry.device_information.device_class_defined THEN
            pfp$convert_device_class_to_rm (
                  p_local_physical_cycle^.cycle_entry.device_information.device_class, device_class);
          ELSE
            device_class := rmc$mass_storage_device;
          IFEND;

          initialize_cycle_object (p_local_physical_cycle^.cycle_entry.cycle_number,
                p_local_physical_cycle^.cycle_entry.global_file_name, device_class,
                {validation_error} NOT password_status.normal, ^p_object^.cycle_object_list^ [cycle_count]);

          IF (status.normal OR (status.condition <> pfe$info_full)) AND
                (cycle_info_requested <> $fst$goi_object_info_requests []) THEN
            get_cycle_object_information (family_location, binary_mainframe_id, path, cycle_info_requested,
                  authority, p_physical_object, validation_ring, p_local_physical_cycle, p_catalog_file,
                  ^p_object^.cycle_object_list^ [cycle_count], p_object_information, local_status);
            IF (NOT local_status.normal) AND (status.normal OR (local_status.condition = pfe$info_full)) THEN
              status := local_status;
            IFEND;
          IFEND;
        IFEND;
      FOREND;

    ELSE {cycle_info_requested <> $fst$goi_object_info_requests []}
      IF p_physical_cycle = NIL THEN
        pfp$build_cycle_list_pointer (p_physical_object^.object_entry.cycle_list_locator, p_catalog_file,
              p_cycle_list);
        cycle_selector.cycle_option := pfc$highest_cycle;
        pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_local_physical_cycle, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        p_local_physical_cycle := p_physical_cycle;
      IFEND;

      IF p_local_physical_cycle^.cycle_entry.device_information.device_class_defined THEN
        pfp$convert_device_class_to_rm (
              p_local_physical_cycle^.cycle_entry.device_information.device_class, device_class);
      ELSE
        device_class := rmc$mass_storage_device;
      IFEND;

      NEXT p_object^.cycle_object_list: [1 .. 1] IN p_object_information;
      IF p_object^.cycle_object_list = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      initialize_cycle_object (p_local_physical_cycle^.cycle_entry.cycle_number,
            p_local_physical_cycle^.cycle_entry.global_file_name, device_class,
            {validation_error} NOT password_status.normal, ^p_object^.cycle_object_list^ [1]);

      IF cycle_info_requested -
            $fst$goi_object_info_requests [fsc$goi_cycle_identity, fsc$goi_job_environment_info] <>
            $fst$goi_object_info_requests [] THEN
        get_cycle_object_information (family_location, binary_mainframe_id, path, cycle_info_requested,
              authority, p_physical_object, validation_ring, p_local_physical_cycle, p_catalog_file,
              ^p_object^.cycle_object_list^ [1], p_object_information, status);
      ELSE
        status.normal := TRUE;
      IFEND;

      IF p_physical_cycle <> NIL THEN
        p_physical_cycle^ := p_local_physical_cycle^;
      IFEND;
    IFEND;

    IF (NOT password_status.normal) AND (status.normal OR (status.condition = pfe$invalid_ring_access) OR
          (status.condition = ame$damaged_file_attributes)) THEN
      status := password_status;
    IFEND;
  PROCEND get_cycle_list_information;

?? TITLE := '  get_cycle_object_information', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to get the requested information about the
{   specified cycle.

  PROCEDURE get_cycle_object_information
    (    family_location: pft$family_location;
         binary_mainframe_id: pmt$binary_mainframe_id;
         path: pft$complete_path;
         object_information_requests: fst$goi_object_info_requests;
         authority: pft$authority;
         p_physical_object: {input^} ^pft$physical_object;
         validation_ring: ost$valid_ring;
         p_physical_cycle: {i^/o^} ^pft$physical_cycle;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
         p_object: {output^} ^fst$goi_object;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      archive_entry: pft$archive_entry,
      archive_index: pft$archive_index,
      attached_for_write: boolean,
      cycle_entry: pft$cycle_entry,
      device_class: rmt$device_class,
      device_information_initialized: boolean,
      dm_file_information: dmt$file_information,
      dm_file_information_valid: boolean,
      local_status: ost$status,
      p_archive_list: ^pft$archive_list,
      p_device_information: ^fst$device_information,
      p_file_label: ^fmt$file_label,
      p_physical_amd: ^pft$physical_amd,
      p_physical_file_label: ^pft$physical_file_label,
      p_physical_fmd: ^pft$physical_fmd,
      p_size: ^amt$file_byte_address,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      shared_queue_name: ost$name,
      stale_cycle_entry: boolean;

    IF fsc$goi_archive_info IN object_information_requests THEN
      pfp$build_archive_list_pointer (p_physical_cycle^.cycle_entry.archive_list_locator, p_catalog_file,
            p_archive_list);

      IF p_archive_list <> NIL THEN
        NEXT p_object^.archive_information_list: [1 .. UPPERBOUND (p_archive_list^)] IN p_object_information;
        IF p_object^.archive_information_list = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          RETURN;
        IFEND;

        FOR archive_index := 1 TO UPPERBOUND (p_archive_list^) DO
          archive_entry := p_archive_list^ [archive_index].archive_entry;
          p_object^.archive_information_list^ [archive_index].archive_entry.version := archive_entry.version;
          p_object^.archive_information_list^ [archive_index].archive_entry.archive_date_time :=
                archive_entry.archive_date_time;
          p_object^.archive_information_list^ [archive_index].archive_entry.archive_identification :=
                archive_entry.archive_identification;
          p_object^.archive_information_list^ [archive_index].archive_entry.file_size :=
                archive_entry.file_size;
          p_object^.archive_information_list^ [archive_index].archive_entry.last_release_date_time :=
                archive_entry.last_release_date_time;
          p_object^.archive_information_list^ [archive_index].archive_entry.last_retrieval_status :=
                archive_entry.last_retrieval_status;
          p_object^.archive_information_list^ [archive_index].archive_entry.modification_date_time :=
                archive_entry.modification_date_time;
          p_object^.archive_information_list^ [archive_index].archive_entry.release_candidate :=
                archive_entry.release_candidate;
          pfp$build_amd_pointer (archive_entry.amd_locator, p_catalog_file, p_physical_amd);
          IF p_physical_amd <> NIL THEN
            NEXT p_object^.archive_information_list^ [archive_index].amd:
                [[REP #SIZE (p_physical_amd^.amd) OF cell]] IN p_object_information;
            p_object^.archive_information_list^ [archive_index].amd^ := p_physical_amd^.amd;
          ELSE
            p_object^.archive_information_list^ [archive_index].amd := NIL;
          IFEND;
        FOREND;
      IFEND;
    IFEND;

    IF p_physical_cycle^.cycle_entry.device_information.device_class_defined THEN
      pfp$convert_device_class_to_rm (p_physical_cycle^.cycle_entry.device_information.device_class,
            device_class);
    ELSE
      device_class := rmc$mass_storage_device;
    IFEND;

  /get_cycle_device_info/
    BEGIN
      IF fsc$goi_cycle_device_info IN object_information_requests THEN
        NEXT p_device_information IN p_object_information;
        IF p_device_information = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          RETURN;
        IFEND;

        update_fmd (^path, family_location, p_physical_cycle, p_catalog_file, device_class, p_physical_fmd,
              attached_for_write, dm_file_information_valid, dm_file_information, status);
        IF NOT status.normal THEN
          EXIT /get_cycle_device_info/;
        IFEND;

        IF device_class = rmc$mass_storage_device THEN
          IF p_physical_cycle^.cycle_entry.shared_queue_info.defined THEN
            IF  dm_file_information_valid THEN
              pfp$convert_ord_to_shared_queue (dm_file_information.shared_queue, shared_queue_name,
                     status);
            ELSE
              pfp$convert_ord_to_shared_queue (p_physical_cycle^.cycle_entry.shared_queue_info.shared_queue,
                    shared_queue_name, status);
            IFEND;
            IF status.normal THEN
              p_device_information^.mass_storage_device_info.shared_queue := shared_queue_name;
            ELSE
              p_device_information^.mass_storage_device_info.shared_queue := pfc$system_shared_queue_name;
              status.normal := TRUE;
            IFEND;
          ELSE
            p_device_information^.mass_storage_device_info.shared_queue := pfc$system_shared_queue_name;
          IFEND;

          IF p_physical_fmd = NIL THEN
            p_device_information^.mass_storage_device_info.bytes_allocated :=
                  p_physical_cycle^.cycle_entry.device_information.bytes_allocated;
            p_device_information^.mass_storage_device_info.resides_online := FALSE;
            p_device_information^.mass_storage_device_info.object_condition := cycle_condition
                  (p_catalog_file, p_physical_cycle);
            p_object^.cycle_device_information := p_device_information;
          ELSE
            IF attached_for_write THEN
              IF dm_file_information_valid THEN
                p_device_information^.mass_storage_device_info.bytes_allocated :=
                      dm_file_information.total_allocated_length;
              ELSE
                p_device_information^.mass_storage_device_info.bytes_allocated :=
                      p_physical_cycle^.cycle_entry.device_information.bytes_allocated;
              IFEND;
            ELSE
              pfp$check_for_stale_cycle_entry (p_physical_cycle^.cycle_entry, stale_cycle_entry);

              IF stale_cycle_entry THEN
                update_stale_cycle_entry (family_location, ^path, p_physical_fmd^.fmd, p_physical_cycle,
                      p_catalog_file);
              IFEND;

              p_device_information^.mass_storage_device_info.bytes_allocated :=
                    p_physical_cycle^.cycle_entry.device_information.bytes_allocated;
            IFEND;

            get_disk_device_info_from_fmd (^p_physical_fmd^.fmd, p_device_information,
                  device_information_initialized, p_object_information, status);
            IF device_information_initialized THEN
              IF status.normal THEN
                find_family_location (path [pfc$family_path_index], served_family, served_family_locator);
                get_object_condition ({catalog_object} FALSE, served_family, ^served_family_locator,
                      ^p_physical_fmd^.fmd, p_device_information^.mass_storage_device_info,
                      p_object_information, status);
              IFEND;
              p_object^.cycle_device_information := p_device_information;
            IFEND;
          IFEND;
        ELSEIF (device_class = rmc$magnetic_tape_device) AND (p_physical_fmd <> NIL) THEN
          get_tape_device_info_from_fmd (^p_physical_fmd^.fmd, p_device_information, p_object_information,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          p_object^.cycle_device_information := p_device_information;
        IFEND;
      ELSE
        status.normal := TRUE;
      IFEND;
    END /get_cycle_device_info/;

    IF fsc$goi_cycle_info IN object_information_requests THEN
      NEXT p_object^.cycle_information IN p_object_information;
      IF p_object^.cycle_information = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      cycle_entry := p_physical_cycle^.cycle_entry;
      p_object^.cycle_information^.creation_date_time := cycle_entry.cycle_statistics.creation_date_time;
      p_object^.cycle_information^.damage_symptoms := cycle_entry.cycle_damage_symptoms;
      p_object^.cycle_information^.data_modification_date_time := cycle_entry.data_modification_date_time;
      p_object^.cycle_information^.expiration_date_time := cycle_entry.expiration_date_time;
      p_object^.cycle_information^.last_access_date_time := cycle_entry.cycle_statistics.access_date_time;
      p_object^.cycle_information^.last_modification_date_time :=
            cycle_entry.cycle_statistics.modification_date_time;
      p_object^.cycle_information^.lifetime_attachment_count := cycle_entry.cycle_statistics.access_count;
      determine_access_modes (cycle_entry.attach_status,
            p_object^.cycle_information^.outstanding_access_modes,
            p_object^.cycle_information^.prevented_access_modes);
      determine_mainframe_concurrency (binary_mainframe_id, cycle_entry,
            p_object^.cycle_information^.prevented_access_modes, p_catalog_file,
            p_object^.cycle_information^.mainframe_usage_concurrency,
            p_object^.cycle_information^.mainframe_write_concurrency);
      p_object^.cycle_information^.retrieve_option := cycle_entry.retrieve_option;
      p_object^.cycle_information^.site_backup_option := cycle_entry.site_backup_option;
      p_object^.cycle_information^.site_archive_option := cycle_entry.site_archive_option;
      p_object^.cycle_information^.site_release_option := cycle_entry.site_release_option;
    IFEND;

  /get_cycle_size/
    BEGIN
      IF (fsc$goi_cycle_size IN object_information_requests) AND (device_class = rmc$mass_storage_device) THEN
        NEXT p_size IN p_object_information;
        IF p_size = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          RETURN;
        IFEND;

        IF fsc$goi_cycle_device_info IN object_information_requests THEN
          IF dm_file_information_valid THEN
            p_size^ := dm_file_information.eoi_byte_address;
          ELSE
            p_size^ := p_physical_cycle^.cycle_entry.device_information.eoi;
          IFEND;
        ELSE
          update_fmd (^path, family_location, p_physical_cycle, p_catalog_file, device_class, p_physical_fmd,
                attached_for_write, dm_file_information_valid, dm_file_information, status);
          IF NOT status.normal THEN
            EXIT /get_cycle_size/;
          IFEND;

          IF attached_for_write THEN
            IF dm_file_information_valid THEN
              p_size^ := dm_file_information.eoi_byte_address;
            ELSE
              p_size^ := p_physical_cycle^.cycle_entry.device_information.eoi;
            IFEND;
          ELSE
            IF p_physical_fmd <> NIL THEN
              pfp$check_for_stale_cycle_entry (p_physical_cycle^.cycle_entry, stale_cycle_entry);

              IF stale_cycle_entry THEN
                update_stale_cycle_entry (family_location, ^path, p_physical_fmd^.fmd, p_physical_cycle,
                      p_catalog_file);
              IFEND;
            IFEND;

            p_size^ := p_physical_cycle^.cycle_entry.device_information.eoi;
          IFEND;
        IFEND;

        p_object^.cycle_size := p_size;
      IFEND;
    END /get_cycle_size/;

    IF (fsc$goi_file_label IN object_information_requests) AND NOT p_object^.validation_error THEN
      pfp$build_file_label_pointer (p_physical_cycle^.cycle_entry.file_label_locator, p_catalog_file,
            p_physical_file_label);
      IF p_physical_file_label <> NIL THEN
        pfp$validate_ring_access (path, ^p_physical_file_label^.file_label,
              $pft$usage_selections [pfc$execute], validation_ring, local_status);
        IF NOT local_status.normal THEN
          p_object^.validation_error := TRUE;
          IF status.normal THEN
            status := local_status;
          IFEND;
          RETURN;
        IFEND;

        NEXT p_file_label: [[REP p_physical_cycle^.cycle_entry.file_label_locator.file_label_size OF cell]]
              IN p_object_information;
        IF p_file_label = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          RETURN;
        IFEND;

        p_file_label^ := p_physical_file_label^.file_label;
        p_object^.file_label := p_file_label;
      IFEND;
    IFEND;
  PROCEND get_cycle_object_information;

?? TITLE := '  get_disk_device_info_from_fmd', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to get disk device information from an
{   fmd.

  PROCEDURE get_disk_device_info_from_fmd
    (    p_fmd: {input^} ^pft$fmd;
         p_device_information: {output^} ^fst$device_information;
     VAR device_information_initialized: boolean;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      fmd_header: pft$fmd_header,
      p_volume_list: ^pft$volume_list,
      volume_index: dmt$subfile_index;

    dmp$get_stored_fmd_header_info (p_fmd, fmd_header, status);
    IF NOT status.normal THEN
      device_information_initialized := FALSE;
      RETURN;
    IFEND;

    p_device_information^.mass_storage_device_info.resides_online := TRUE;
    p_device_information^.mass_storage_device_info.allocation_unit_size :=
          fmd_header.requested_allocation_size;
    p_device_information^.mass_storage_device_info.initial_volume := fmd_header.requested_volume.recorded_vsn;
    p_device_information^.mass_storage_device_info.mass_storage_class := fmd_header.requested_class;
    p_device_information^.mass_storage_device_info.transfer_size := fmd_header.requested_transfer_size;
    p_device_information^.mass_storage_device_info.volume_overflow_allowed := fmd_header.overflow_allowed;
    p_device_information^.mass_storage_device_info.volume_condition_list := NIL;
    p_device_information^.mass_storage_device_info.volume_list := NIL;
    device_information_initialized := TRUE;

    PUSH p_volume_list: [1 .. fmd_header.number_of_subfiles];
    dmp$get_stored_fmd_volume_list (p_fmd, p_volume_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT p_device_information^.mass_storage_device_info.volume_list: [1 .. fmd_header.number_of_subfiles]
          IN p_object_information;
    IF p_device_information^.mass_storage_device_info.volume_list = NIL THEN
      osp$set_status_condition (pfe$info_full, status);
      RETURN;
    IFEND;

    FOR volume_index := 1 TO fmd_header.number_of_subfiles DO
      p_device_information^.mass_storage_device_info.volume_list^ [volume_index].recorded_vsn :=
            p_volume_list^ [volume_index];
      p_device_information^.mass_storage_device_info.volume_list^ [volume_index].external_vsn :=
            p_volume_list^ [volume_index];
    FOREND;
  PROCEND get_disk_device_info_from_fmd;
?? TITLE := '  get_file_object_information', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to get the requested information about the
{   specified file.

  PROCEDURE get_file_object_information
    (    family_location: pft$family_location;
         binary_mainframe_id: pmt$binary_mainframe_id;
         path: pft$complete_path;
         object_information_requests: fst$goi_object_info_requests;
         authority: pft$authority;
         permit_entry: pft$permit_entry;
         p_physical_object: {input^} ^pft$physical_object;
         p_catalog_file: {input^} ^pft$catalog_file;
         unknown_cycle: boolean;
         password_selector: pft$password_selector;
         validation_ring: ost$valid_ring;
         p_physical_cycle: {i/o^} ^pft$physical_cycle;
         p_object: {output^} ^fst$goi_object;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      log_count: pft$log_count,
      log_index: pft$log_index,
      p_file_information: ^fst$goi_file_information,
      p_log_entry: ^pft$log_entry,
      p_log_list: ^pft$log_list,
      p_logging_selection: ^pft$log,
      user_id: ost$user_identification;

    IF fsc$goi_applicable_file_permit IN object_information_requests THEN
      NEXT p_object^.applicable_file_permit IN p_object_information;
      IF p_object^.applicable_file_permit = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      p_object^.applicable_file_permit^.permit_type := pfc$indirect_permit;
      p_object^.applicable_file_permit^.group := permit_entry.group;
      p_object^.applicable_file_permit^.usage_permissions := permit_entry.usage_permissions;
      p_object^.applicable_file_permit^.share_requirements := permit_entry.share_requirements;
      p_object^.applicable_file_permit^.application_info := permit_entry.application_info;
    IFEND;

    IF fsc$goi_file_info IN object_information_requests THEN
      NEXT p_file_information IN p_object_information;
      IF p_file_information = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      p_file_information^.account := p_physical_object^.object_entry.charge_id.account;

      IF authority.ownership = $pft$ownership [] THEN
        p_file_information^.logging_selection := NIL;
      ELSE
        NEXT p_logging_selection IN p_object_information;
        IF p_logging_selection = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          RETURN;
        IFEND;

        p_logging_selection^ := p_physical_object^.object_entry.logging_selection;
        p_file_information^.logging_selection := p_logging_selection;
      IFEND;

      p_file_information^.project := p_physical_object^.object_entry.charge_id.project;
      p_object^.file_information := p_file_information;
    IFEND;

    IF (fsc$goi_file_log IN object_information_requests) AND (authority.ownership <> $pft$ownership []) THEN
      pfp$build_log_list_pointer (p_physical_object^.object_entry.log_list_locator, p_catalog_file,
            p_log_list);

      IF p_log_list <> NIL THEN
        log_count := 0;
        FOR log_index := 1 TO UPPERBOUND (p_log_list^) DO
          IF p_log_list^ [log_index].log_entry.entry_type = pfc$normal_log_entry THEN
            log_count := log_count + 1;
          IFEND;
        FOREND;

        NEXT p_object^.file_log: [1 .. log_count] IN p_object_information;
        IF p_object^.file_log = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          RETURN;
        IFEND;

        log_count := 0;
        FOR log_index := 1 TO UPPERBOUND (p_log_list^) DO
          IF p_log_list^ [log_index].log_entry.entry_type = pfc$normal_log_entry THEN
            p_log_entry := ^p_log_list^ [log_index].log_entry;
            log_count := log_count + 1;
            p_object^.file_log^ [log_count].user_id := p_log_entry^.user_id;
            p_object^.file_log^ [log_count].access_date_time := p_log_entry^.access_date_time;
            p_object^.file_log^ [log_count].access_count := p_log_entry^.access_count;
            p_object^.file_log^ [log_count].last_cycle := p_log_entry^.last_cycle;
          IFEND;
        FOREND;
      IFEND;
    IFEND;

    IF fsc$goi_file_permits IN object_information_requests THEN
      get_permits (authority, p_physical_object^.object_entry.permit_list_locator, p_catalog_file, p_object,
            p_object_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF authority.ownership <> $pft$ownership [] THEN
       p_object^.password := p_physical_object^.object_entry.password;
    ELSE
       p_object^.password := osc$null_name;
    IFEND;

    IF (NOT unknown_cycle) AND ((fsc$goi_cycle_object_list IN object_information_requests) OR
          (object_information_requests * pfv$cycle_info_requests <> $fst$goi_object_info_requests [])) THEN
      get_cycle_list_information (family_location, binary_mainframe_id, path, object_information_requests,
            authority, p_physical_object, p_catalog_file, password_selector, validation_ring,
            p_physical_cycle, p_object, p_object_information, status);
    ELSE
      status.normal := TRUE;
    IFEND;
  PROCEND get_file_object_information;

?? TITLE := '  get_object_condition', EJECT ??

  PROCEDURE get_object_condition
    (    catalog_object: boolean;
         served_family: boolean;
         p_served_family_locator: ^pft$served_family_locator;
         p_fmd: ^dmt$stored_fmd;
     VAR device_info: fst$mass_storage_device_info;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      p_unique_volume_list: ^pft$unique_volume_list;

    status.normal := TRUE;

    device_info.object_condition := fsc$null_file_access_condition;
    IF device_info.volume_list <> NIL THEN
      NEXT device_info.volume_condition_list: [LOWERBOUND (device_info.volume_list^) ..
            UPPERBOUND (device_info.volume_list^)] IN p_object_information;
      IF device_info.volume_condition_list <> NIL THEN
        IF p_fmd <> NIL THEN
          PUSH p_unique_volume_list: [1 .. UPPERBOUND (device_info.volume_list^)];
          dmp$get_unique_fmd_volume_list (p_fmd, p_unique_volume_list, status);
          IF status.normal THEN
            IF served_family THEN
              pfp$r2_df_client_get_vol_cl (p_served_family_locator^, p_unique_volume_list^,
                    device_info.volume_condition_list^, status);
            ELSE
              pfp$r2_get_vol_condition_list (p_unique_volume_list^, device_info.volume_condition_list^);
            IFEND;
            IF status.normal THEN
              device_info.object_condition := volume_list_condition
                    (catalog_object, device_info.volume_condition_list^);
            IFEND;
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;
    ELSE
      device_info.volume_condition_list := NIL;
    IFEND;
  PROCEND get_object_condition;

?? TITLE := '  get_object_information', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to get the requested information about the
{   specified catalog, file, or cycle object.

  PROCEDURE get_object_information
    (    family_location: pft$family_location;
         binary_mainframe_id: pmt$binary_mainframe_id;
         path: pft$complete_path;
         information_request: fst$goi_information_request;
         authority: pft$authority;
         permit_entry: pft$permit_entry;
         p_physical_object: {input^} ^pft$physical_object;
         unknown_cycle: boolean;
         password_selector: pft$password_selector;
         validation_ring: ost$valid_ring;
         p_subject_permit_id_list: {i/o^} ^subject_permit_id_list;
         p_physical_cycle: {i/o^} ^pft$physical_cycle,
         p_object_info: {output^} ^fst$goi_object_information;
     VAR catalog_locator: {i/o} pft$catalog_locator;
     VAR permitted_to_object: {i/o} boolean;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      device_class: rmt$device_class,
      p_object: ^fst$goi_object,
      password_status: ost$status;

    NEXT p_object IN p_object_information;
    IF p_object = NIL THEN
      osp$set_status_condition (pfe$info_full, status);
      RETURN;
    IFEND;

    IF p_physical_object^.object_entry.object_type = pfc$catalog_object THEN
      initialize_catalog_object (p_physical_object^.object_entry, p_object);

      IF (password_selector.password_specified = pfc$specific_password_option) AND
            (password_selector.password <> osc$null_name) THEN
        osp$set_status_condition (pfe$catalogs_have_no_password, status);
        RETURN;
      IFEND;

      get_catalog_object_information (family_location, binary_mainframe_id, path, information_request,
            {current_depth} 1, authority, permit_entry, p_physical_object, password_selector, validation_ring,
            p_subject_permit_id_list, p_object, catalog_locator, permitted_to_object, p_object_information,
            status);
    ELSEIF information_request.object_information_requests * pfv$file_info_requests <>
          $fst$goi_object_info_requests [] THEN
      initialize_file_object (p_physical_object^.object_entry.external_object_name, p_object);
      get_file_object_information (family_location, binary_mainframe_id, path,
            information_request.object_information_requests, authority, permit_entry, p_physical_object,
            catalog_locator.p_catalog_file, unknown_cycle, password_selector, validation_ring,
            p_physical_cycle, p_object, p_object_information, status);
    ELSEIF p_physical_cycle = NIL THEN
      status.normal := TRUE;
      RETURN;
    ELSE
      IF information_request.object_information_requests * protected_info_requests =
            $fst$goi_object_info_requests [] THEN
        password_status.normal := TRUE;
      ELSEIF password_selector.password_specified = pfc$default_password_option THEN
        pfp$validate_password (path, authority, osc$null_name, p_physical_object, password_status);
      ELSE
        pfp$validate_password (path, authority, password_selector.password, p_physical_object,
              password_status);
      IFEND;

      IF p_physical_cycle^.cycle_entry.device_information.device_class_defined THEN
        pfp$convert_device_class_to_rm (p_physical_cycle^.cycle_entry.device_information.device_class,
              device_class);
      ELSE
        device_class := rmc$mass_storage_device;
      IFEND;

      initialize_cycle_object (p_physical_cycle^.cycle_entry.cycle_number,
            p_physical_cycle^.cycle_entry.global_file_name, device_class,
            {validation_error} NOT password_status.normal, p_object);

      IF information_request.object_information_requests * pfv$cycle_info_requests -
            $fst$goi_object_info_requests [fsc$goi_cycle_identity] = $fst$goi_object_info_requests [] THEN
        status.normal := TRUE;
      ELSE
        get_cycle_object_information (family_location, binary_mainframe_id, path,
              information_request.object_information_requests, authority, p_physical_object, validation_ring,
              p_physical_cycle, catalog_locator.p_catalog_file, p_object, p_object_information, status);
        IF (NOT password_status.normal) AND (status.normal OR (status.condition = pfe$invalid_ring_access) OR
              (status.condition = ame$damaged_file_attributes)) THEN
          status := password_status;
        IFEND;
      IFEND;
    IFEND;

    IF permitted_to_object THEN
      p_object_info^.object := p_object;
    IFEND;
  PROCEND get_object_information;

?? TITLE := '  get_object_list_information', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to access the specified catalog and to get
{   the requested information about the files and/or subcatalogs within the
{   specified catalog.

  PROCEDURE get_object_list_information
    (    family_location: pft$family_location;
         binary_mainframe_id: pmt$binary_mainframe_id;
         path: pft$complete_path;
         information_request: fst$goi_information_request;
         current_depth: fst$path_element_index;
         authority: pft$authority;
         permit_entry: pft$permit_entry;
         password_selector: pft$password_selector;
         validation_ring: ost$valid_ring;
         p_subject_permit_id_list: {i/o^} ^subject_permit_id_list;
         p_object: {output^} ^fst$goi_object;
     VAR catalog_locator: {i/o} pft$catalog_locator;
     VAR permitted_to_catalog: {i/o} boolean;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      all_subjects_are_permitted: boolean,
      extracted_permit_entry: pft$permit_entry,
      internal_name: pft$internal_name,
      local_status: ost$status,
      max_object_name_index: pft$object_count,
      max_sorted_object_index: pft$object_count,
      new_catalog_locator: pft$catalog_locator,
      new_permit_entry: pft$permit_entry,
      object_accessed: boolean,
      object_count: pft$object_count,
      object_index: pft$object_index,
      object_information_requests: fst$goi_object_info_requests,
      object_name_index: pft$object_index,
      p_internal_path: ^pft$internal_path,
      p_local_object_list: ^pft$object_list,
      p_new_path: ^pft$complete_path,
      p_object_list: ^pft$object_list,
      p_object_name_list: ^pft$object_name_list,
      p_objects: ^fst$goi_object_list,
      p_permit_list: ^pft$permit_list,
      p_subject_permit_id_lists: ^array [1 .. * ] of ^subject_permit_id_list,
      parent_charge_id: pft$charge_id,
      path_index: pft$file_path_index,
      sorted_object_index: pft$object_index;

    object_information_requests := information_request.object_information_requests;

    p_object_list := catalog_locator.object_list_descriptor.p_object_list;
    object_count := 0;
    PUSH p_local_object_list: [1 .. UPPERBOUND (p_object_list^)];
    PUSH p_subject_permit_id_lists: [1 .. UPPERBOUND (p_object_list^)];

    IF catalog_locator.object_list_descriptor.sorted_object_count = 0 THEN
      PUSH p_object_name_list: [1 .. UPPERBOUND (p_object_list^)];
    ELSE
      PUSH p_object_name_list: [1 .. UPPERBOUND (p_object_list^) -
            catalog_locator.object_list_descriptor.sorted_object_count];
    IFEND;

    pfp$get_sorted_object_name_list (catalog_locator.object_list_descriptor, p_object_name_list,
          max_object_name_index);
    max_sorted_object_index := catalog_locator.object_list_descriptor.sorted_object_count;
    sorted_object_index := 1;
    object_name_index := 1;

    WHILE (sorted_object_index <= max_sorted_object_index) OR (object_name_index <= max_object_name_index) DO
      IF object_name_index > max_object_name_index THEN
        object_index := sorted_object_index;
        sorted_object_index := sorted_object_index + 1;
      ELSEIF sorted_object_index > max_sorted_object_index THEN
        object_index := p_object_name_list^[object_name_index].object_index;
        object_name_index := object_name_index + 1;
      ELSEIF p_object_list^[sorted_object_index].object_entry.external_object_name >
            p_object_name_list^[object_name_index].object_name THEN
        object_index := p_object_name_list^[object_name_index].object_index;
        object_name_index := object_name_index + 1;
      ELSE
        object_index := sorted_object_index;
        sorted_object_index := sorted_object_index + 1;
      IFEND;

      IF ((p_object_list^ [object_index].object_entry.object_type = pfc$file_object) AND
            ((fsc$goi_file_object_list IN object_information_requests) OR
            (((information_request.catalog_depth.depth_specification = fsc$entire_subtree) OR
            (current_depth <= information_request.catalog_depth.depth)) AND
            (object_information_requests - pfv$catalog_info_requests <> $fst$goi_object_info_requests []))))
            OR ((p_object_list^ [object_index].object_entry.object_type = pfc$catalog_object) AND
            ((fsc$goi_catalog_object_list IN object_information_requests) OR
            (((information_request.catalog_depth.depth_specification = fsc$entire_subtree) OR
            (current_depth < information_request.catalog_depth.depth)) AND
            (object_information_requests * pfv$catalog_info_requests <> $fst$goi_object_info_requests [])) OR
            NOT permitted_to_catalog)) THEN
        pfp$build_permit_list_pointer (p_object_list^ [object_index].object_entry.permit_list_locator,
              catalog_locator.p_catalog_file, p_permit_list);
        pfp$extract_permit_entry (p_permit_list, authority, extracted_permit_entry);
        pfp$reduce_permits (permit_entry, extracted_permit_entry, new_permit_entry);
        pfp$form_administrator_permit (authority, new_permit_entry);

        IF p_subject_permit_id_list <> NIL THEN
          PUSH p_subject_permit_id_lists^ [object_count + 1]: [1 .. UPPERBOUND (p_subject_permit_id_list^)];
          validate_subject_permits (p_permit_list, p_subject_permit_id_list,
                p_subject_permit_id_lists^ [object_count + 1], all_subjects_are_permitted);
        IFEND;

        IF ((authority.ownership <> $pft$ownership []) OR
              ((new_permit_entry.entry_type = pfc$normal_permit_entry) AND
              (new_permit_entry.usage_permissions <> $pft$permit_selections [])) OR
              ((p_object_list^ [object_index].object_entry.object_type = pfc$catalog_object) AND
              NOT osv$catalog_name_security)) AND
              ((p_subject_permit_id_list = NIL) OR all_subjects_are_permitted) THEN
          object_count := object_count + 1;
          p_local_object_list^ [object_count] := p_object_list^ [object_index];
        IFEND;
      IFEND;
    WHILEND;

    IF object_count = 0 THEN
      status.normal := TRUE;
      RETURN;
    ELSEIF NOT permitted_to_catalog THEN
      permitted_to_catalog := TRUE;
      IF NOT (fsc$goi_catalog_object_list IN object_information_requests) AND
            (((information_request.catalog_depth.depth_specification = fsc$specific_depth) AND
            (information_request.catalog_depth.depth <= current_depth)) OR
            (object_information_requests * pfv$catalog_info_requests = $fst$goi_object_info_requests [])) THEN
        status.normal := TRUE;
        RETURN;
      IFEND;
    IFEND;

    NEXT p_objects: [1 .. object_count] IN p_object_information;
    IF p_objects = NIL THEN
      osp$set_status_condition (pfe$info_full, status);
      RETURN;
    IFEND;

    status.normal := TRUE;

    PUSH p_new_path: [1 .. UPPERBOUND (path) + 1];
    FOR path_index := 1 TO UPPERBOUND (path) DO
      p_new_path^ [path_index] := path [path_index];
    FOREND;

    FOR object_index := 1 TO object_count DO
      IF p_local_object_list^ [object_index].object_entry.object_type = pfc$file_object THEN
        initialize_file_object (p_local_object_list^ [object_index].object_entry.external_object_name,
              ^p_objects^ [object_index]);

        IF (status.normal OR (status.condition <> pfe$info_full)) AND
              ((information_request.catalog_depth.depth_specification = fsc$entire_subtree) OR
              (current_depth <= information_request.catalog_depth.depth)) AND
              (object_information_requests - pfv$catalog_info_requests <> $fst$goi_object_info_requests [])
              THEN
          p_new_path^ [path_index + 1] :=
                p_local_object_list^ [object_index].object_entry.external_object_name;
          get_file_object_information (family_location, binary_mainframe_id, p_new_path^,
                object_information_requests, authority, new_permit_entry,
                ^p_local_object_list^ [object_index], catalog_locator.p_catalog_file, {unknown_cycle} FALSE,
                password_selector, validation_ring, {p_physical_cycle} NIL, ^p_objects^ [object_index],
                p_object_information, local_status);
          IF (NOT local_status.normal) AND (status.normal OR (local_status.condition = pfe$info_full)) THEN
            status := local_status;
          IFEND;
        IFEND;
      ELSE
        initialize_catalog_object (p_local_object_list^ [object_index].object_entry,
              ^p_objects^ [object_index]);
      IFEND;
    FOREND;

{   IF (status.normal OR (status.condition <> pfe$info_full)) AND
{         ((information_request.catalog_depth.depth_specification = fsc$entire_subtree) OR
{         (current_depth < information_request.catalog_depth.depth)) AND
{         (object_information_requests * pfv$catalog_info_requests <> $fst$goi_object_info_requests []) THEN
{     new_catalog_locator := catalog_locator;
{     object_accessed := TRUE;
{
{   /get_catalog_object_info/
{     FOR object_index := 1 TO object_count DO
{       IF p_local_object_list^ [object_index].object_entry.object_type = pfc$catalog_object THEN
{         p_new_path^ [path_index + 1] :=
{               p_local_object_list^ [object_index].object_entry.external_object_name;
{
{         IF new_catalog_locator <> catalog_locator THEN
{           {
{           { Because each subcatalog is attached when it is processed, the
{           { parent catalog needs to be reattached to process all but the
{           { first subcatalog in the list.
{           {
{           IF object_accessed THEN
{             pfp$return_catalog (new_catalog_locator, local_status);
{             IF NOT local_status.normal THEN
{               IF status.normal THEN
{                 status := local_status;
{               IFEND;
{               RETURN;
{             IFEND;
{           IFEND;
{
{           PUSH p_internal_path: [1 .. UPPERBOUND (p_new_path)];
{           pfp$access_object (p_new_path^, pfc$read_access, authority, valid_objects, parent_charge_id,
{                 new_catalog_locator, p_local_object_list^ [object_index], p_internal_path, new_permit_entry,
{                 local_status);
{           object_accessed := local_status.normal;
{           IF NOT local_status.normal THEN
{             IF status.normal THEN
{               status := local_status;
{             IFEND;
{             CYCLE /get_catalog_object_info/;
{           IFEND;
{
{           catalog_locator := new_catalog_locator;
{           pfp$form_administrator_permit (authority, new_permit_entry);
{         IFEND;
{
{         get_catalog_object_information (family_location, binary_mainframe_id, p_new_path^,
{               information_request, (current_depth + 1), authority, new_permit_entry,
{               ^p_local_object_list^ [object_index], password_selector, validation_ring,
{               p_subject_permit_id_lists^ [object_index], ^p_objects^ [object_index], new_catalog_locator,
{               permitted_to_catalog, p_object_information, local_status);
{         IF NOT local_status.normal THEN
{           IF local_status.condition = pfe$info_full THEN
{             status := local_status;
{             EXIT /get_catalog_object_info/;
{           ELSEIF status.normal THEN
{             status := local_status;
{           IFEND;
{         IFEND;
{       IFEND;
{     FOREND /get_catalog_object_info/;
{   IFEND;

    p_object^.subcatalog_and_file_object_list := p_objects;
  PROCEND get_object_list_information;

?? TITLE := '  get_permits', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to get permits for a catalog or file.

  PROCEDURE get_permits
    (    authority: pft$authority;
         permit_list_locator: pft$permit_list_locator;
         p_catalog_file: {input^} ^pft$catalog_file;
         p_object: {i^/o^} ^fst$goi_object;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      p_permit_entry: ^pft$permit_entry,
      p_permit_list: ^pft$permit_list,
      p_permits: ^pft$permit_array,
      permit_count: pft$permit_count,
      permit_entry: pft$permit_entry,
      permit_index: pft$permit_index;

    pfp$build_permit_list_pointer (permit_list_locator, p_catalog_file, p_permit_list);

    IF p_permit_list <> NIL THEN
      IF authority.ownership = $pft$ownership [] THEN
        p_permits := NIL;
      ELSE
        permit_count := 0;
        FOR permit_index := 1 TO UPPERBOUND (p_permit_list^) DO
          IF p_permit_list^ [permit_index].permit_entry.entry_type = pfc$normal_permit_entry THEN
            permit_count := permit_count + 1;
          IFEND;
        FOREND;

        IF permit_count > 0 THEN
          NEXT p_permits: [1 .. permit_count] IN p_object_information;
          IF p_permits = NIL THEN
            osp$set_status_condition (pfe$info_full, status);
            RETURN;
          IFEND;

          permit_count := 0;
          FOR permit_index := 1 TO UPPERBOUND (p_permit_list^) DO
            IF p_permit_list^ [permit_index].permit_entry.entry_type = pfc$normal_permit_entry THEN
              permit_count := permit_count + 1;
              p_permit_entry := ^p_permit_list^ [permit_index].permit_entry;
              p_permits^ [permit_count].permit_type := pfc$direct_permit;
              p_permits^ [permit_count].group := p_permit_entry^.group;
              p_permits^ [permit_count].usage_permissions := p_permit_entry^.usage_permissions;
              p_permits^ [permit_count].share_requirements := p_permit_entry^.share_requirements;
              p_permits^ [permit_count].application_info := p_permit_entry^.application_info;
            IFEND;
          FOREND;
        ELSE
          p_permits := NIL;
        IFEND;
      IFEND;

      IF p_object^.object_type = fsc$goi_catalog_object THEN
        p_object^.catalog_permits := p_permits;
      ELSEIF p_object^.object_type = fsc$goi_file_object THEN
        p_object^.file_permits := p_permits;
      IFEND;
    IFEND;

    status.normal := TRUE;
  PROCEND get_permits;

?? TITLE := '  get_protected_info_from_cd', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to get the requested, password protected
{   information about a cycle which is attached within the job.

  PROCEDURE get_protected_info_from_cd
    (    served_family: boolean;
         served_family_locator: pft$served_family_locator;
         evaluated_file_reference: fst$evaluated_file_reference;
         object_information_requests: fst$goi_object_info_requests;
         p_cycle_description: {input^} ^fmt$cycle_description;
         password_selector: pft$password_selector;
         validation_ring: ost$valid_ring;
         p_object: {output^} ^fst$goi_object;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      fs_path_size: fst$path_size,
      label_size: ost$non_negative_integers,
      p_complete_path: ^pft$complete_path,
      p_fs_path: ^fst$path,
      p_path: ^pft$path,
      p_static_label_header: ^fmt$static_label_header,
      ring_attributes: amt$ring_attributes;

    IF (password_selector.password_specified = pfc$specific_password_option) AND
          (p_cycle_description^.password_protected OR (password_selector.password <> osc$null_name)) THEN
      IF served_family THEN
        PUSH p_path: [1 .. evaluated_file_reference.number_of_path_elements];
        pfp$convert_fs_to_pft$path (evaluated_file_reference, p_path^);
        pfp$r2_df_client_validate_pw (served_family_locator, p_path^, password_selector.password, status);
        p_object^.validation_error := NOT status.normal;
      ELSE
        PUSH p_complete_path: [1 .. evaluated_file_reference.number_of_path_elements + 1];
        pfp$convert_fs_to_complete_path (evaluated_file_reference, p_complete_path, status);
        IF status.normal THEN
          pfp$r2_validate_password (p_complete_path^, password_selector.password, status);
          p_object^.validation_error := NOT status.normal;
        IFEND;
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF object_information_requests * protected_info_requests <> $fst$goi_object_info_requests [] THEN
      IF p_cycle_description^.system_file_label.file_previously_opened THEN
        fmp$get_label_header_info (^p_cycle_description^.system_file_label, ring_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF validation_ring > ring_attributes.r3 THEN
          p_object^.validation_error := TRUE;
          PUSH p_fs_path;
          clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} FALSE, p_fs_path^,
                fs_path_size, status);
          IF status.normal THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_ring_access,
                  p_fs_path^ (1, fs_path_size), status);
          ELSE
            osp$set_status_condition (pfe$invalid_ring_access, status);
          IFEND;
          RETURN;
        IFEND;
      IFEND;

      IF fsc$goi_job_environment_info IN object_information_requests THEN
        NEXT p_object^.job_environment_information IN p_object_information;
        IF p_object^.job_environment_information = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          RETURN;
        IFEND;

        fmp$setup_job_environment_info (p_cycle_description, {path_handle_p} NIL,
              p_object^.job_environment_information, p_object_information);
      IFEND;

      IF fsc$goi_file_label IN object_information_requests THEN
        IF NOT p_cycle_description^.system_file_label.file_previously_opened AND
              (p_cycle_description^.static_setfa_entries <> NIL) THEN
          p_object^.file_label := p_cycle_description^.system_file_label.static_label;
          fmp$merge_setfa_entries (p_cycle_description^.static_setfa_entries, p_object, p_object_information,
                status);
          IF NOT status.normal THEN
            p_object^.file_label := NIL;
          IFEND;
        ELSEIF p_cycle_description^.system_file_label.static_label <> NIL THEN
          label_size := #SIZE (p_cycle_description^.system_file_label.static_label^);
          NEXT p_object^.file_label: [[REP label_size OF cell]] IN p_object_information;
          IF p_object^.file_label = NIL THEN
            osp$set_status_condition (pfe$info_full, status);
            RETURN;
          IFEND;

          i#move (p_cycle_description^.system_file_label.static_label, p_object^.file_label, label_size);
          status.normal := TRUE;
        ELSE
          label_size := #SIZE (fmt$static_label_header);
          NEXT p_object^.file_label: [[REP label_size OF cell]] IN p_object_information;
          IF p_object^.file_label = NIL THEN
            osp$set_status_condition (pfe$info_full, status);
            RETURN;
          IFEND;

          i#move (^fmv$static_label_header, p_object^.file_label, label_size);
          IF NOT p_cycle_description^.system_file_label.file_previously_opened THEN
            RESET p_object^.file_label;
            NEXT p_static_label_header IN p_object^.file_label;
            IF p_static_label_header <> NIL THEN
              p_static_label_header^.file_previously_opened := FALSE;
            IFEND;
          IFEND;
          status.normal := TRUE;
        IFEND;
      ELSE
        status.normal := TRUE;
      IFEND;
    ELSE
      status.normal := TRUE;
    IFEND;
  PROCEND get_protected_info_from_cd;

?? TITLE := '  get_tape_device_info_from_fmd', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to get tape device information from an
{   fmd.

  PROCEDURE get_tape_device_info_from_fmd
    (    p_fmd: {input^} pft$p_fmd;
         p_device_information: {output^} ^fst$device_information;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      number_of_volumes: 0 .. amc$max_vol_number,
      p_pf_volume_list: ^pft$volume_list,
      p_rm_volume_list: ^rmt$volume_list,
      p_volume_list: ^rmt$volume_list,
      removable_media_req_info: fmt$removable_media_req_info;

    pfp$get_rem_media_req_info (p_fmd, ^removable_media_req_info, number_of_volumes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_device_information^.magnetic_tape_device_info.density := removable_media_req_info.density;
    p_device_information^.magnetic_tape_device_info.removable_media_group :=
          removable_media_req_info.removable_media_group;
    p_device_information^.magnetic_tape_device_info.volume_overflow_allowed :=
          removable_media_req_info.volume_overflow_allowed;

    IF number_of_volumes > 0 THEN
      NEXT p_volume_list: [1 .. number_of_volumes] IN p_object_information;
      IF p_volume_list <> NIL THEN
        pfp$get_rem_media_volume_list (p_fmd, p_volume_list, status);
      ELSE
        p_volume_list := NIL;
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      p_volume_list := NIL;
    IFEND;

    p_device_information^.magnetic_tape_device_info.volume_list := p_volume_list;

  PROCEND get_tape_device_info_from_fmd;

?? TITLE := '  [INLINE] initialize_catalog_object', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to initialize catalog object information.

  PROCEDURE [INLINE] initialize_catalog_object
    (    object_entry: pft$object_entry;
         p_object: {output^} ^fst$goi_object);

    p_object^.object_type := fsc$goi_catalog_object;
    p_object^.catalog_name := object_entry.external_object_name;
    IF object_entry.catalog_object_locator.catalog_type = pfc$external_catalog THEN
      p_object^.catalog_global_file_name := object_entry.catalog_object_locator.global_file_name;
    ELSE
      p_object^.catalog_global_file_name := pfv$null_unique_name;
    IFEND;
    p_object^.applicable_catalog_permit := NIL;
    p_object^.catalog_device_information := NIL;
    p_object^.catalog_information := NIL;
    p_object^.catalog_permits := NIL;
    p_object^.catalog_size := NIL;
    p_object^.subcatalog_and_file_object_list := NIL;
  PROCEND initialize_catalog_object;

?? TITLE := '  [INLINE] initialize_cycle_object', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to initialize cycle object information.

  PROCEDURE [INLINE] initialize_cycle_object
    (    cycle_number: pft$cycle_number;
         global_file_name: ost$binary_unique_name;
         device_class: rmt$device_class;
         validation_error: boolean;
         p_object: {output^} ^fst$goi_object);

    p_object^.object_type := fsc$goi_cycle_object;
    p_object^.cycle_number := cycle_number;
    p_object^.cycle_global_file_name := global_file_name;
    p_object^.cycle_device_class := device_class;
    p_object^.archive_information_list := NIL;
    p_object^.cycle_device_information := NIL;
    p_object^.cycle_information := NIL;
    p_object^.cycle_size := NIL;
    p_object^.validation_error := validation_error;
    p_object^.file_label := NIL;
    p_object^.job_environment_information := NIL;
  PROCEND initialize_cycle_object;

?? TITLE := '  [INLINE] initialize_file_object', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to initialize file object information.

  PROCEDURE [INLINE] initialize_file_object
    (    file_name: pft$name;
         p_object: {output^} ^fst$goi_object);

    p_object^.object_type := fsc$goi_file_object;
    p_object^.file_name := file_name;
    p_object^.applicable_file_permit := NIL;
    p_object^.file_information := NIL;
    p_object^.file_log := NIL;
    p_object^.file_permits := NIL;
    p_object^.password := osc$null_name;
    p_object^.cycle_object_list := NIL;
  PROCEND initialize_file_object;

?? TITLE := '  move_catalog_object_information', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to move catalog information from the local
{   sequence to the caller supplied sequence.

  PROCEDURE move_catalog_object_information
    (    local_catalog_object: fst$goi_object;
     VAR catalog_object: fst$goi_object;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      object_index: ost$positive_integers;

    catalog_object.catalog_name := local_catalog_object.catalog_name;
    catalog_object.catalog_global_file_name := local_catalog_object.catalog_global_file_name;

    IF local_catalog_object.applicable_catalog_permit = NIL THEN
      catalog_object.applicable_catalog_permit := NIL;
    ELSE
      NEXT catalog_object.applicable_catalog_permit IN p_object_information;
      IF catalog_object.applicable_catalog_permit = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      catalog_object.applicable_catalog_permit^ := local_catalog_object.applicable_catalog_permit^;
    IFEND;

    IF local_catalog_object.catalog_device_information = NIL THEN
      catalog_object.catalog_device_information := NIL;
    ELSE
      NEXT catalog_object.catalog_device_information IN p_object_information;
      IF catalog_object.catalog_device_information = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      catalog_object.catalog_device_information^.mass_storage_device_info.bytes_allocated :=
            local_catalog_object.catalog_device_information^.mass_storage_device_info.bytes_allocated;
      catalog_object.catalog_device_information^.mass_storage_device_info.object_condition :=
            local_catalog_object.catalog_device_information^.mass_storage_device_info.object_condition;
      catalog_object.catalog_device_information^.mass_storage_device_info.shared_queue :=
            local_catalog_object.catalog_device_information^.mass_storage_device_info.shared_queue;
      catalog_object.catalog_device_information^.mass_storage_device_info.resides_online :=
            local_catalog_object.catalog_device_information^.mass_storage_device_info.resides_online;

      IF catalog_object.catalog_device_information^.mass_storage_device_info.resides_online THEN
        catalog_object.catalog_device_information^.mass_storage_device_info.allocation_unit_size :=
              local_catalog_object.catalog_device_information^.mass_storage_device_info.allocation_unit_size;
        catalog_object.catalog_device_information^.mass_storage_device_info.initial_volume :=
              local_catalog_object.catalog_device_information^.mass_storage_device_info.initial_volume;
        catalog_object.catalog_device_information^.mass_storage_device_info.mass_storage_class :=
              local_catalog_object.catalog_device_information^.mass_storage_device_info.mass_storage_class;
        catalog_object.catalog_device_information^.mass_storage_device_info.transfer_size :=
              local_catalog_object.catalog_device_information^.mass_storage_device_info.transfer_size;

        IF local_catalog_object.catalog_device_information^.mass_storage_device_info.volume_list = NIL THEN
          catalog_object.catalog_device_information^.mass_storage_device_info.volume_list := NIL;
        ELSE
          NEXT catalog_object.catalog_device_information^.mass_storage_device_info.volume_list:
                [1 .. UPPERBOUND (local_catalog_object.catalog_device_information^.mass_storage_device_info.
                volume_list^)] IN p_object_information;
          IF catalog_object.catalog_device_information^.mass_storage_device_info.volume_list = NIL THEN
            osp$set_status_condition (pfe$info_full, status);
            RETURN;
          IFEND;

          catalog_object.catalog_device_information^.mass_storage_device_info.volume_list^ :=
                local_catalog_object.catalog_device_information^.mass_storage_device_info.volume_list^;
        IFEND;

        IF local_catalog_object.catalog_device_information^.mass_storage_device_info.volume_condition_list =
              NIL THEN
          catalog_object.catalog_device_information^.mass_storage_device_info.volume_condition_list := NIL;
        ELSE
          NEXT catalog_object.catalog_device_information^.mass_storage_device_info.volume_condition_list:
                [1 .. UPPERBOUND (local_catalog_object.catalog_device_information^.mass_storage_device_info.
                volume_condition_list^)] IN p_object_information;
          IF catalog_object.catalog_device_information^.mass_storage_device_info.volume_condition_list = NIL
              THEN
            osp$set_status_condition (pfe$info_full, status);
            RETURN;
          IFEND;

          catalog_object.catalog_device_information^.mass_storage_device_info.volume_condition_list^ :=
                local_catalog_object.catalog_device_information^.mass_storage_device_info.
                volume_condition_list^;
        IFEND;

        catalog_object.catalog_device_information^.mass_storage_device_info.volume_overflow_allowed :=
              local_catalog_object.catalog_device_information^.mass_storage_device_info.
              volume_overflow_allowed;
      IFEND;
    IFEND;

    IF local_catalog_object.catalog_information = NIL THEN
      catalog_object.catalog_information := NIL;
    ELSE
      NEXT catalog_object.catalog_information IN p_object_information;
      IF catalog_object.catalog_information = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      catalog_object.catalog_information^ := local_catalog_object.catalog_information^;
    IFEND;

    IF local_catalog_object.catalog_permits = NIL THEN
      catalog_object.catalog_permits := NIL;
    ELSE
      NEXT catalog_object.catalog_permits: [1 .. UPPERBOUND (local_catalog_object.catalog_permits^)]
            IN p_object_information;
      IF catalog_object.catalog_permits = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      catalog_object.catalog_permits^ := local_catalog_object.catalog_permits^;
    IFEND;

    IF local_catalog_object.catalog_size = NIL THEN
      catalog_object.catalog_size := NIL;
    ELSE
      NEXT catalog_object.catalog_size IN p_object_information;
      IF catalog_object.catalog_size = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      catalog_object.catalog_size^ := local_catalog_object.catalog_size^;
    IFEND;

    IF local_catalog_object.subcatalog_and_file_object_list = NIL THEN
      catalog_object.subcatalog_and_file_object_list := NIL;
    ELSE
      NEXT catalog_object.subcatalog_and_file_object_list:
            [1 .. UPPERBOUND (local_catalog_object.subcatalog_and_file_object_list^)] IN p_object_information;
      IF catalog_object.subcatalog_and_file_object_list = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      FOR object_index := 1 TO UPPERBOUND (catalog_object.subcatalog_and_file_object_list^) DO
        catalog_object.subcatalog_and_file_object_list^ [object_index].object_type :=
              local_catalog_object.subcatalog_and_file_object_list^ [object_index].object_type;

        CASE catalog_object.subcatalog_and_file_object_list^ [object_index].object_type OF
        = fsc$goi_catalog_object =
          move_catalog_object_information
                (local_catalog_object.subcatalog_and_file_object_list^ [object_index],
                catalog_object.subcatalog_and_file_object_list^ [object_index], p_object_information, status);
        = fsc$goi_file_object =
          move_file_object_information (local_catalog_object.subcatalog_and_file_object_list^ [object_index],
                catalog_object.subcatalog_and_file_object_list^ [object_index], p_object_information, status);
        = fsc$goi_cycle_object =
          move_cycle_object_information (local_catalog_object.subcatalog_and_file_object_list^ [object_index],
                catalog_object.subcatalog_and_file_object_list^ [object_index], p_object_information, status);
        ELSE
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                'Invalid object_type in move_catalog_object_information.', status);
        CASEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    status.normal := TRUE;
  PROCEND move_catalog_object_information;

?? TITLE := '  move_cycle_device_information', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to move cycle device information from the
{   local sequence to the caller supplied sequence.

  PROCEDURE move_cycle_device_information
    (    cycle_device_class: rmt$device_class;
         local_cycle_device_information: fst$device_information;
     VAR cycle_device_information: fst$device_information;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    IF cycle_device_class = rmc$mass_storage_device THEN
      cycle_device_information.mass_storage_device_info.bytes_allocated :=
            local_cycle_device_information.mass_storage_device_info.bytes_allocated;
      cycle_device_information.mass_storage_device_info.object_condition :=
            local_cycle_device_information.mass_storage_device_info.object_condition;
      cycle_device_information.mass_storage_device_info.shared_queue :=
            local_cycle_device_information.mass_storage_device_info.shared_queue;
      cycle_device_information.mass_storage_device_info.resides_online :=
            local_cycle_device_information.mass_storage_device_info.resides_online;

      IF cycle_device_information.mass_storage_device_info.resides_online THEN
        cycle_device_information.mass_storage_device_info.allocation_unit_size :=
              local_cycle_device_information.mass_storage_device_info.allocation_unit_size;
        cycle_device_information.mass_storage_device_info.initial_volume :=
              local_cycle_device_information.mass_storage_device_info.initial_volume;
        cycle_device_information.mass_storage_device_info.mass_storage_class :=
              local_cycle_device_information.mass_storage_device_info.mass_storage_class;
        cycle_device_information.mass_storage_device_info.transfer_size :=
              local_cycle_device_information.mass_storage_device_info.transfer_size;

        IF local_cycle_device_information.mass_storage_device_info.volume_list = NIL THEN
          cycle_device_information.mass_storage_device_info.volume_list := NIL;
        ELSE
          NEXT cycle_device_information.mass_storage_device_info.volume_list:
                [1 .. UPPERBOUND (local_cycle_device_information.mass_storage_device_info.volume_list^)]
                IN p_object_information;
          IF cycle_device_information.mass_storage_device_info.volume_list = NIL THEN
            osp$set_status_condition (pfe$info_full, status);
            RETURN;
          IFEND;

          cycle_device_information.mass_storage_device_info.volume_list^ :=
                local_cycle_device_information.mass_storage_device_info.volume_list^;
        IFEND;

        IF local_cycle_device_information.mass_storage_device_info.volume_condition_list = NIL THEN
          cycle_device_information.mass_storage_device_info.volume_condition_list := NIL;
        ELSE
          NEXT cycle_device_information.mass_storage_device_info.volume_condition_list:
                [1 .. UPPERBOUND (local_cycle_device_information.mass_storage_device_info.
                volume_condition_list^)] IN p_object_information;
          IF cycle_device_information.mass_storage_device_info.volume_condition_list = NIL THEN
            osp$set_status_condition (pfe$info_full, status);
            RETURN;
          IFEND;

          cycle_device_information.mass_storage_device_info.volume_condition_list^ :=
                local_cycle_device_information.mass_storage_device_info.volume_condition_list^;
        IFEND;

        cycle_device_information.mass_storage_device_info.volume_overflow_allowed :=
              local_cycle_device_information.mass_storage_device_info.volume_overflow_allowed;
      IFEND;
    ELSEIF cycle_device_class = rmc$magnetic_tape_device THEN
      cycle_device_information.magnetic_tape_device_info.density :=
            local_cycle_device_information.magnetic_tape_device_info.density;
      cycle_device_information.magnetic_tape_device_info.removable_media_group :=
            local_cycle_device_information.magnetic_tape_device_info.removable_media_group;
      cycle_device_information.magnetic_tape_device_info.volume_overflow_allowed :=
            local_cycle_device_information.magnetic_tape_device_info.volume_overflow_allowed;

      IF local_cycle_device_information.magnetic_tape_device_info.volume_list = NIL THEN
        cycle_device_information.magnetic_tape_device_info.volume_list := NIL;
      ELSE
        NEXT cycle_device_information.magnetic_tape_device_info.volume_list:
              [LOWERBOUND (local_cycle_device_information.magnetic_tape_device_info.volume_list^) ..
              UPPERBOUND (local_cycle_device_information.magnetic_tape_device_info.volume_list^)]
              IN p_object_information;
        IF cycle_device_information.magnetic_tape_device_info.volume_list = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          RETURN;
        IFEND;
        cycle_device_information.magnetic_tape_device_info.volume_list^ :=
              local_cycle_device_information.magnetic_tape_device_info.volume_list^;
      IFEND;
    IFEND;

    status.normal := TRUE;
  PROCEND move_cycle_device_information;

?? TITLE := '  move_cycle_object_information', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to move cycle information from the local
{   sequence to the caller supplied sequence.

  PROCEDURE move_cycle_object_information
    (    local_cycle_object: fst$goi_object;
     VAR cycle_object: fst$goi_object;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      archive_index: ost$positive_integers;

    cycle_object.cycle_number := local_cycle_object.cycle_number;
    cycle_object.cycle_global_file_name := local_cycle_object.cycle_global_file_name;
    cycle_object.cycle_device_class := local_cycle_object.cycle_device_class;

    IF local_cycle_object.archive_information_list = NIL THEN
      cycle_object.archive_information_list := NIL;
    ELSE
      NEXT cycle_object.archive_information_list:
            [1 .. UPPERBOUND (local_cycle_object.archive_information_list^)] IN p_object_information;
      IF cycle_object.archive_information_list = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      FOR archive_index := 1 TO UPPERBOUND (cycle_object.archive_information_list^) DO
        cycle_object.archive_information_list^ [archive_index].archive_entry :=
              local_cycle_object.archive_information_list^ [archive_index].archive_entry;

        IF local_cycle_object.archive_information_list^ [archive_index].amd = NIL THEN
          cycle_object.archive_information_list^ [archive_index].amd := NIL;
        ELSE
          NEXT cycle_object.archive_information_list^ [archive_index].amd:
                [[REP #SIZE (local_cycle_object.archive_information_list^ [archive_index].amd^) OF cell]]
                IN p_object_information;
          IF cycle_object.archive_information_list^ [archive_index].amd = NIL THEN
            osp$set_status_condition (pfe$info_full, status);
            RETURN;
          IFEND;

          cycle_object.archive_information_list^ [archive_index].amd^ :=
                local_cycle_object.archive_information_list^ [archive_index].amd^;
        IFEND;
      FOREND;
    IFEND;

    IF local_cycle_object.cycle_device_information = NIL THEN
      cycle_object.cycle_device_information := NIL;
    ELSE
      NEXT cycle_object.cycle_device_information IN p_object_information;
      IF cycle_object.cycle_device_information = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      move_cycle_device_information (cycle_object.cycle_device_class,
            local_cycle_object.cycle_device_information^, cycle_object.cycle_device_information^,
            p_object_information, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF local_cycle_object.cycle_information = NIL THEN
      cycle_object.cycle_information := NIL;
    ELSE
      NEXT cycle_object.cycle_information IN p_object_information;
      IF cycle_object.cycle_information = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      cycle_object.cycle_information^ := local_cycle_object.cycle_information^;
    IFEND;

    IF local_cycle_object.cycle_size = NIL THEN
      cycle_object.cycle_size := NIL;
    ELSE
      NEXT cycle_object.cycle_size IN p_object_information;
      IF cycle_object.cycle_size = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      cycle_object.cycle_size^ := local_cycle_object.cycle_size^;
    IFEND;

    cycle_object.validation_error := local_cycle_object.validation_error;

    IF local_cycle_object.file_label = NIL THEN
      cycle_object.file_label := NIL;
    ELSE
      NEXT cycle_object.file_label: [[REP #SIZE (local_cycle_object.file_label^) OF cell]]
            IN p_object_information;
      IF cycle_object.file_label = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      cycle_object.file_label^ := local_cycle_object.file_label^;
    IFEND;

    IF local_cycle_object.job_environment_information = NIL THEN
      cycle_object.job_environment_information := NIL;
    ELSE
      NEXT cycle_object.job_environment_information IN p_object_information;
      IF cycle_object.job_environment_information = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      cycle_object.job_environment_information^ := local_cycle_object.job_environment_information^;

      IF cycle_object.job_environment_information^.volume_list <> NIL THEN
        NEXT cycle_object.job_environment_information^.volume_list:
              [1 .. UPPERBOUND (local_cycle_object.job_environment_information^.volume_list^)] IN
              p_object_information;
        IF cycle_object.job_environment_information^.volume_list = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          RETURN;
        IFEND;
        cycle_object.job_environment_information^.volume_list^ := local_cycle_object.
              job_environment_information^.volume_list^;
      IFEND;

      IF cycle_object.job_environment_information^.connected_files <> NIL THEN
        NEXT cycle_object.job_environment_information^.connected_files:
              [1 .. UPPERBOUND (local_cycle_object.job_environment_information^.connected_files^)] IN
              p_object_information;
        IF cycle_object.job_environment_information^.connected_files = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          RETURN;
        IFEND;
        cycle_object.job_environment_information^.connected_files^ := local_cycle_object.
              job_environment_information^.connected_files^;
      IFEND;
    IFEND;

    status.normal := TRUE;
  PROCEND move_cycle_object_information;

?? TITLE := '  move_file_object_information', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to move file information from the local
{   sequence to the caller supplied sequence.

  PROCEDURE move_file_object_information
    (    local_file_object: fst$goi_object;
     VAR file_object: fst$goi_object;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      cycle_index: ost$positive_integers;

    file_object.file_name := local_file_object.file_name;

    IF local_file_object.applicable_file_permit = NIL THEN
      file_object.applicable_file_permit := NIL;
    ELSE
      NEXT file_object.applicable_file_permit IN p_object_information;
      IF file_object.applicable_file_permit = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      file_object.applicable_file_permit^ := local_file_object.applicable_file_permit^;
    IFEND;

    IF local_file_object.file_information = NIL THEN
      file_object.file_information := NIL;
    ELSE
      NEXT file_object.file_information IN p_object_information;
      IF file_object.file_information = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      file_object.file_information^.account := local_file_object.file_information^.account;

      IF local_file_object.file_information^.logging_selection = NIL THEN
        file_object.file_information^.logging_selection := NIL;
      ELSE
        NEXT file_object.file_information^.logging_selection IN p_object_information;
        IF file_object.file_information^.logging_selection = NIL THEN
          osp$set_status_condition (pfe$info_full, status);
          RETURN;
        IFEND;

        file_object.file_information^.logging_selection^ :=
              local_file_object.file_information^.logging_selection^;
      IFEND;

      file_object.file_information^.project := local_file_object.file_information^.project;
    IFEND;

    IF local_file_object.file_log = NIL THEN
      file_object.file_log := NIL;
    ELSE
      NEXT file_object.file_log: [1 .. UPPERBOUND (local_file_object.file_log^)] IN p_object_information;
      IF file_object.file_log = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      file_object.file_log^ := local_file_object.file_log^;
    IFEND;

    IF local_file_object.file_permits = NIL THEN
      file_object.file_permits := NIL;
    ELSE
      NEXT file_object.file_permits: [1 .. UPPERBOUND (local_file_object.file_permits^)]
            IN p_object_information;
      IF file_object.file_permits = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      file_object.file_permits^ := local_file_object.file_permits^;
    IFEND;

    file_object.password := local_file_object.password;

    IF local_file_object.cycle_object_list = NIL THEN
      file_object.cycle_object_list := NIL;
    ELSE
      NEXT file_object.cycle_object_list: [1 .. UPPERBOUND (local_file_object.cycle_object_list^)]
            IN p_object_information;
      IF file_object.cycle_object_list = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      FOR cycle_index := 1 TO UPPERBOUND (file_object.cycle_object_list^) DO
        file_object.cycle_object_list^ [cycle_index].object_type := fsc$goi_cycle_object;
        move_cycle_object_information (local_file_object.cycle_object_list^ [cycle_index],
              file_object.cycle_object_list^ [cycle_index], p_object_information, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    status.normal := TRUE;
  PROCEND move_file_object_information;

?? TITLE := '  move_object_information', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to move the information from the local
{   sequence to the caller supplied sequence.

  PROCEDURE move_object_information
    (    p_local_object_info: {i^/o^} ^fst$goi_object_information;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      p_object_info: ^fst$goi_object_information;

    NEXT p_object_info IN p_object_information;
    IF p_object_info = NIL THEN
      osp$set_status_condition (pfe$info_full, status);
      RETURN;
    IFEND;

    p_object_info^.set_name := p_local_object_info^.set_name;

    IF p_local_object_info^.resolved_path = NIL THEN
      p_object_info^.resolved_path := NIL;
    ELSE
      NEXT p_object_info^.resolved_path: [#SIZE (p_local_object_info^.resolved_path^)]
            IN p_object_information;
      IF p_object_info^.resolved_path = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      p_object_info^.resolved_path^ := p_local_object_info^.resolved_path^;
    IFEND;

    IF p_local_object_info^.object = NIL THEN
      p_object_info^.object := NIL;
    ELSE
      NEXT p_object_info^.object IN p_object_information;
      IF p_object_info^.object = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
        RETURN;
      IFEND;

      p_object_info^.object^.object_type := p_local_object_info^.object^.object_type;

      CASE p_object_info^.object^.object_type OF
      = fsc$goi_catalog_object =
        move_catalog_object_information (p_local_object_info^.object^, p_object_info^.object^,
              p_object_information, status);
      = fsc$goi_file_object =
        move_file_object_information (p_local_object_info^.object^, p_object_info^.object^,
              p_object_information, status);
      = fsc$goi_cycle_object =
        move_cycle_object_information (p_local_object_info^.object^, p_object_info^.object^,
              p_object_information, status);
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'Invalid object_type in move_object_information.', status);
      CASEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    status.normal := TRUE;
  PROCEND move_object_information;

?? TITLE := '  [INLINE] reduce_subject_permit', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to reduce a subject permit and a permit
{   entry into a single subject permit by picking the one with the more
{   selective group.  In the case of equally selective groups, the child permit
{   entry will become the reduced subject permit.

  PROCEDURE [INLINE] reduce_subject_permit
    (    parental_subject_permit: pft$permit_array_entry;
         child_permit_entry: pft$permit_entry;
     VAR group_type: pft$group_types;
     VAR reduced_subject_permit: pft$permit_array_entry);

    IF child_permit_entry.entry_type = pfc$normal_permit_entry THEN
      IF child_permit_entry.group.group_type < parental_subject_permit.group.group_type THEN
        group_type := parental_subject_permit.group.group_type;
        reduced_subject_permit := parental_subject_permit;
      ELSE
        group_type := child_permit_entry.group.group_type;
        reduced_subject_permit.permit_type := parental_subject_permit.permit_type;
        reduced_subject_permit.group := child_permit_entry.group;
        reduced_subject_permit.usage_permissions := child_permit_entry.usage_permissions;
        reduced_subject_permit.share_requirements := child_permit_entry.share_requirements;
        reduced_subject_permit.application_info := child_permit_entry.application_info;
      IFEND;
    ELSE
      group_type := parental_subject_permit.group.group_type;
      reduced_subject_permit := parental_subject_permit;
    IFEND;
  PROCEND reduce_subject_permit;

?? TITLE := '  resolve_subject_permits', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to resolve the subject permit entries
{   supplied in the validation_criteria parameter of
{   pfp$get_object_information.

  PROCEDURE resolve_subject_permits
    (    path: pft$complete_path;
         authority: pft$authority;
         p_validation_criteria: {i^/o^} ^fst$goi_validation_criteria;
         p_subject_permit_id_list: {output^} ^subject_permit_id_list;
     VAR status: ost$status);

    PROCEDURE resolve_subject_permits_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status,
        status_id: ost$status_identifier,
        variant_path: pft$variant_path;

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := ^path;

      IF NOT process_non_local_exit THEN
        pfp$log_ascii ('***PF Condition Handler***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, {critical_message} FALSE, local_status);
        pfp$log_path (variant_path, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
              {critical_message} FALSE, local_status);
      IFEND;

      CASE condition.selector OF
      = pmc$system_conditions, pmc$block_exit_processing, mmc$segment_access_condition =
        IF process_non_local_exit THEN
          RETURN;
        IFEND;

        IF catalog_locator.attached THEN
          catalog_locator.abort_catalog_operation := TRUE;
          pfp$return_catalog (catalog_locator, local_status);
          IF NOT local_status.normal THEN
            pfp$report_system_error (local_status);
          IFEND;
        IFEND;

        osp$set_status_from_condition (status_id, condition, p_sfsa, local_status, handler_status);
        osp$recoverable_system_error ('UNEXPECTED STATUS', ^local_status);

        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'PFP$R2_GET_OBJECT_INFO failure - see job log for details.', status);
        process_non_local_exit := TRUE;
        #SPOIL(process_non_local_exit);
        EXIT resolve_subject_permits;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          process_non_local_exit := TRUE;
          #SPOIL(process_non_local_exit);
          EXIT resolve_subject_permits;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND resolve_subject_permits_handler;

    VAR
      catalog_locator: pft$catalog_locator,
      local_path_index: pft$file_path_index,
      local_status: ost$status,
      p_internal_path: ^pft$internal_path,
      p_local_path: ^pft$complete_path,
      p_permit_list: ^pft$permit_list,
      p_physical_object: ^pft$physical_object,
      parent_charge_id: pft$charge_id,
      path_index: pft$file_path_index,
      permit_entry: pft$permit_entry,
      process_direct_permit: boolean,
      process_indirect_permit: boolean,
      process_non_local_exit: boolean,
      spil_index: ost$non_negative_integers,
      variant_path: pft$variant_path,
      vc_index: ost$non_negative_integers;

    process_non_local_exit := FALSE;
    #SPOIL(process_non_local_exit);

    process_direct_permit := FALSE;
    process_indirect_permit := FALSE;

    spil_index := 0;
    FOR vc_index := 1 TO UPPERBOUND (p_validation_criteria^) DO
      IF p_validation_criteria^ [vc_index].validation_selection = fsc$goi_subject_permit THEN
        process_direct_permit := process_direct_permit OR
              (p_validation_criteria^ [vc_index].subject_permit.permit_type = pfc$direct_permit);
        process_indirect_permit := process_indirect_permit OR
              (p_validation_criteria^ [vc_index].subject_permit.permit_type = pfc$indirect_permit);
        spil_index := spil_index + 1;
        convert_group_to_authority (p_validation_criteria^ [vc_index].subject_permit.group,
              p_subject_permit_id_list^ [spil_index].authority);
        p_subject_permit_id_list^ [spil_index].permit_type :=
              p_validation_criteria^ [vc_index].subject_permit.permit_type;
        p_validation_criteria^ [vc_index].subject_permit.group.group_type := pfc$public;
        p_validation_criteria^ [vc_index].subject_permit.usage_permissions := $pft$permit_selections [];
        p_validation_criteria^ [vc_index].subject_permit.share_requirements := - $pft$share_requirements [];
        p_validation_criteria^ [vc_index].subject_permit.application_info := osc$null_name;
      IFEND;
    FOREND;

    IF (NOT process_direct_permit) AND (NOT process_indirect_permit) THEN
      status.normal := TRUE;
      RETURN;
    IFEND;

    IF process_indirect_permit THEN

    /resolve_permit_for_each_element/
      FOR path_index := pfc$master_catalog_path_index TO UPPERBOUND (path) DO
        PUSH p_local_path: [1 .. path_index];
        FOR local_path_index := 1 TO path_index DO
          p_local_path^ [local_path_index] := path [local_path_index];
        FOREND;

        PUSH p_internal_path: [1 .. path_index];
        pfp$access_object (p_local_path^, pfc$read_access, authority, valid_objects, parent_charge_id,
              catalog_locator, p_physical_object, p_internal_path^, permit_entry, status);
        IF status.normal THEN
          osp$establish_condition_handler (^resolve_subject_permits_handler, {block_exit} TRUE);
          pfp$build_permit_list_pointer (p_physical_object^.object_entry.permit_list_locator,
                catalog_locator.p_catalog_file, p_permit_list);
          IF p_permit_list <> NIL THEN
            spil_index := 0;

            FOR vc_index := 1 TO UPPERBOUND (p_validation_criteria^) DO
              IF p_validation_criteria^ [vc_index].validation_selection = fsc$goi_subject_permit THEN
                spil_index := spil_index + 1;
                IF (p_subject_permit_id_list^ [spil_index].permit_type = pfc$indirect_permit) OR
                      (path_index = UPPERBOUND (path)) THEN
                  pfp$extract_permit_entry (p_permit_list, p_subject_permit_id_list^ [spil_index].authority,
                        permit_entry);
                  reduce_subject_permit (p_validation_criteria^ [vc_index].subject_permit, permit_entry,
                        p_subject_permit_id_list^ [spil_index].group_type,
                        p_validation_criteria^ [vc_index].subject_permit);
                IFEND;
              IFEND;
            FOREND;
          IFEND;

          osp$disestablish_cond_handler;
          pfp$return_catalog (catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
        IFEND;

        IF NOT status.normal THEN
          EXIT /resolve_permit_for_each_element/;
        IFEND;
      FOREND /resolve_permit_for_each_element/;

    ELSE
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$read_access, authority, valid_objects, parent_charge_id, catalog_locator,
            p_physical_object, p_internal_path^, permit_entry, status);
      IF status.normal THEN
        osp$establish_condition_handler (^resolve_subject_permits_handler, {block_exit} TRUE);
        pfp$build_permit_list_pointer (p_physical_object^.object_entry.permit_list_locator,
              catalog_locator.p_catalog_file, p_permit_list);
        IF p_permit_list <> NIL THEN
          spil_index := 0;

          FOR vc_index := 1 TO UPPERBOUND (p_validation_criteria^) DO
            IF p_validation_criteria^ [vc_index].validation_selection = fsc$goi_subject_permit THEN
              spil_index := spil_index + 1;
              pfp$extract_permit_entry (p_permit_list, p_subject_permit_id_list^ [spil_index].authority,
                    permit_entry);
              reduce_subject_permit (p_validation_criteria^ [vc_index].subject_permit, permit_entry,
                    p_subject_permit_id_list^ [spil_index].group_type,
                    p_validation_criteria^ [vc_index].subject_permit);
            IFEND;
          FOREND;
        IFEND;

        osp$disestablish_cond_handler;
        pfp$return_catalog (catalog_locator, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;
    IFEND;

    { If any of the subjects is not permitted access to the object, then return
    { an abnormal status.

    IF status.normal THEN
      FOR vc_index := 1 TO UPPERBOUND (p_validation_criteria^) DO
        IF (p_validation_criteria^ [vc_index].validation_selection = fsc$goi_subject_permit) AND
              (p_validation_criteria^ [vc_index].subject_permit.usage_permissions = $pft$permit_selections [])
              THEN
          variant_path.complete_path := TRUE;
          variant_path.p_complete_path := ^path;
          pfp$set_status_abnormal (variant_path, pfe$unknown_item, status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;
  PROCEND resolve_subject_permits;

?? TITLE := '  store_resolved_path', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to convert an evaluated file reference,
{   which has already been resolved, to a string and to store the string in an
{   object information sequence.

  PROCEDURE store_resolved_path
    (    evaluated_file_reference: fst$evaluated_file_reference;
         p_object_info: {output^} ^fst$goi_object_information;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      fs_path: fst$path,
      fs_path_size: fst$path_size;

    clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} TRUE, fs_path,
          fs_path_size, status);

    IF status.normal THEN
      NEXT p_object_info^.resolved_path: [fs_path_size] IN p_object_information;
      IF p_object_info^.resolved_path = NIL THEN
        osp$set_status_condition (pfe$info_full, status);
      ELSE
        p_object_info^.resolved_path^ := fs_path (1, fs_path_size);
      IFEND;
    IFEND;
  PROCEND store_resolved_path;

?? TITLE := '  update_fmd', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to update a cycle's file media descriptor
{   if necessary.
{
{ NOTE:
{   The dm_file_information is only valid if dm_file_information_valid is TRUE.

  PROCEDURE update_fmd
    (    p_path: ^pft$complete_path;
         family_location: pft$family_location;
         p_physical_cycle: {i^/o^} ^pft$physical_cycle;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
         device_class: rmt$device_class;
     VAR p_physical_fmd: ^pft$physical_fmd;
     VAR attached_for_write: boolean;
     VAR dm_file_information_valid: boolean;
     VAR dm_file_information: dmt$file_information;
     VAR status: ost$status);

    VAR
      existing_sft_entry: dmt$existing_sft_entry,
      file_damaged: boolean,
      file_modified: boolean,
      fmd_modified: boolean,
      local_status: ost$status,
      shared_queue: mmt$shared_queue,
      system_file_id: gft$system_file_identifier;

    pfp$build_fmd_pointer (p_physical_cycle^.cycle_entry.fmd_locator, p_catalog_file, p_physical_fmd);

    status.normal := TRUE;
    attached_for_write := FALSE;
    dm_file_information_valid := FALSE;

    IF (device_class = rmc$magnetic_tape_device) OR (p_physical_fmd = NIL) THEN
      RETURN;
    ELSE
      attached_for_write := pfp$cycle_attached_for_write (p_physical_cycle);
      shared_queue := pfp$shared_queue (p_physical_cycle^.cycle_entry.shared_queue_info,
            -$pft$share_selections []);
      IF attached_for_write OR (p_physical_cycle^.cycle_entry.shared_queue_info.defined AND
           (p_physical_cycle^.cycle_entry.attach_status.attach_count > 1)) THEN
        dmp$attach_file (p_physical_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file,
              p_physical_fmd^.fmd, $pft$usage_selections [], -$pft$share_selections [],
              pfc$average_share_history, pfc$maximum_pf_length, {restricted_attach} FALSE,
              {exit_on_unknown_file} TRUE, (family_location = pfc$server_mainframe),
              shared_queue, file_damaged, system_file_id, existing_sft_entry, status);
        IF NOT status.normal THEN
          status.normal := TRUE;
          RETURN;
        IFEND;

        IF existing_sft_entry = dmc$normal_entry THEN
          pfp$detach_permanent_file (p_path, system_file_id, $pft$usage_selections [],
                {catalog_access_allowed} TRUE, p_physical_cycle, p_catalog_file, fmd_modified,
                dm_file_information, local_status);
          pfp$process_unexpected_status (local_status);
          dm_file_information_valid := local_status.normal;

          IF fmd_modified THEN
            pfp$build_fmd_pointer (p_physical_cycle^.cycle_entry.fmd_locator, p_catalog_file, p_physical_fmd);
          IFEND;
        ELSE
          attached_for_write := FALSE;
          pfp$reconcile_fmd (p_path, p_physical_cycle^.cycle_entry.internal_cycle_name, existing_sft_entry,
                {update_catalog} TRUE, p_catalog_file, p_physical_cycle, p_physical_fmd, status);
          IF NOT status.normal THEN
            status.normal := TRUE;
            RETURN;
          IFEND;

          {
          { Attach and detach the file to get the dm_file_information and update the eoi in the catalog.
          {

          dmp$attach_file (p_physical_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file,
                p_physical_fmd^.fmd, $pft$usage_selections [], -$pft$share_selections [],
                pfc$average_share_history, pfc$maximum_pf_length, {restricted_attach} FALSE,
                {exit_on_unknown_file} FALSE, (family_location = pfc$server_mainframe),
                pfp$shared_queue (p_physical_cycle^.cycle_entry.shared_queue_info, -$pft$share_selections []),
                file_damaged, system_file_id, existing_sft_entry, status);
          IF NOT status.normal THEN
            status.normal := TRUE;
            RETURN;
          IFEND;

          pfp$detach_permanent_file (p_path, system_file_id, $pft$usage_selections [],
                {catalog_access_allowed} TRUE, p_physical_cycle, p_catalog_file, fmd_modified,
                dm_file_information, local_status);
          pfp$process_unexpected_status (local_status);
          dm_file_information_valid := local_status.normal;

          p_physical_cycle^.cycle_entry.device_information.eoi := dm_file_information.eoi_byte_address;
          p_physical_cycle^.cycle_entry.device_information.bytes_allocated :=
                dm_file_information.total_allocated_length;

          p_physical_cycle^.cycle_entry.attach_status := pfv$unattached_status;
          pfp$compute_checksum (#LOC (p_physical_cycle^.cycle_entry), #SIZE (pft$cycle_entry),
                p_physical_cycle^.checksum);
        IFEND;
      IFEND;
    IFEND;
  PROCEND update_fmd;

?? TITLE := '  update_stale_cycle_entry', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to update new items which were added to
{   the cycle entry in R1.4.1.  These items will be stale if the cycle was
{   created or modified by an R1.3.1 or older version of the system.
{
{ NOTE:
{   This procedure should be deleted two releases after R1.4.1 when it is no
{   longer necessary to support an upgrade from an R1.3.1 or earlier system.

  PROCEDURE update_stale_cycle_entry
    (    family_location: pft$family_location;
         p_path: ^pft$complete_path;
         stored_fmd: dmt$stored_fmd;
         p_physical_cycle: {i^/o^} ^pft$physical_cycle;
         p_catalog_file: {i^/o^} ^pft$catalog_file);

    VAR
      dm_file_information: dmt$file_information,
      existing_sft_entry: dmt$existing_sft_entry,
      file_damaged: boolean,
      file_modified: boolean,
      fmd_modified: boolean,
      local_status: ost$status,
      system_file_id: gft$system_file_identifier;

    dmp$attach_file (p_physical_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file, stored_fmd,
          $pft$usage_selections [], -$pft$share_selections [], pfc$average_share_history,
          pfc$maximum_pf_length, {restricted_attach} FALSE, {exit_on_unknown_file} TRUE,
          (family_location = pfc$server_mainframe),
          pfp$shared_queue (p_physical_cycle^.cycle_entry.shared_queue_info, -$pft$share_selections []),
          file_damaged, system_file_id, existing_sft_entry, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    IF existing_sft_entry = dmc$normal_entry THEN
      pfp$update_stale_cycle_entry (system_file_id, p_physical_cycle, local_status);

      pfp$detach_permanent_file (p_path, system_file_id, $pft$usage_selections [],
            {catalog_access_allowed} TRUE, p_physical_cycle, p_catalog_file, fmd_modified,
            dm_file_information, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND update_stale_cycle_entry;

?? TITLE := '  [INLINE] validate_subject_permits', EJECT ??

  PROCEDURE [INLINE] validate_subject_permits
    (    p_permit_list: {input} ^pft$permit_list;
         p_old_subject_permit_id_list: {input^} ^subject_permit_id_list;
         p_new_subject_permit_id_list: {output^} ^subject_permit_id_list;
     VAR all_subjects_are_permitted: boolean);

    VAR
      permit_entry: pft$permit_entry,
      subject_permit_index: ost$positive_integers;

    FOR subject_permit_index := 1 TO UPPERBOUND (p_old_subject_permit_id_list^) DO
      pfp$extract_permit_entry (p_permit_list, p_old_subject_permit_id_list^ [subject_permit_index].authority,
            permit_entry);
      IF (permit_entry.entry_type = pfc$free_permit_entry) OR (permit_entry.group.group_type <
            p_old_subject_permit_id_list^ [subject_permit_index].group_type) THEN
        p_new_subject_permit_id_list^ [subject_permit_index] :=
              p_old_subject_permit_id_list^ [subject_permit_index];
      ELSEIF permit_entry.usage_permissions <> $pft$permit_selections [] THEN
        p_new_subject_permit_id_list^ [subject_permit_index] :=
              p_old_subject_permit_id_list^ [subject_permit_index];
        p_new_subject_permit_id_list^ [subject_permit_index].group_type := permit_entry.group.group_type;
      ELSE
        all_subjects_are_permitted := FALSE;
        RETURN;
      IFEND;
    FOREND;

    all_subjects_are_permitted := TRUE;
  PROCEND validate_subject_permits;
?? TITLE := '  volume_list_condition', EJECT ??

  FUNCTION [INLINE] volume_list_condition
    (    catalog_object: boolean;
         volume_condition_list: fst$volume_condition_list): fst$file_access_condition;

    VAR
      i: ost$non_negative_integers,
      conditions: fst$file_access_conditions;

    conditions := $fst$file_access_conditions [];

    FOR i := LOWERBOUND (volume_condition_list) TO UPPERBOUND (volume_condition_list) DO
      conditions := conditions + $fst$file_access_conditions [volume_condition_list [i]];
    FOREND;

    IF fsc$media_missing IN conditions THEN
      IF catalog_object THEN
        volume_list_condition := fsc$catalog_media_missing;
      ELSE
        volume_list_condition := fsc$media_missing;
      IFEND;
    ELSEIF fsc$volume_unavailable IN conditions THEN
      IF catalog_object THEN
        volume_list_condition := fsc$catalog_volume_unavailable;
      ELSE
        volume_list_condition := fsc$volume_unavailable;
      IFEND;
    ELSEIF fsc$space_unavailable IN conditions THEN
      volume_list_condition := fsc$space_unavailable;
    ELSE
      volume_list_condition := fsc$null_file_access_condition;
    IFEND;
  FUNCEND volume_list_condition;

?? OLDTITLE, SKIP := 2 ??
MODEND pfm$r2_get_object_information;
*DECK DECK=PFM$R2_MOVE_OBJECT EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
MODULE pfm$r2_move_object;

?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
*copyc pfd$catalog
*copyc pfd$complete_path
*copyc pfe$external_archive_conditions
*copyc pft$move_object_info
*copyc pft$variant_path
?? POP ??

*copyc amv$device_class_names
*copyc cmp$get_element_entry_via_lun
*copyc dmp$attach_file
*copyc dmp$calculate_device_capacity
*copyc dmp$calculate_remaining_space
*copyc dmp$change_file_damaged
*copyc dmp$delete_file_descriptor
*copyc dmp$destroy_permanent_file
*copyc dmp$detach_file
*copyc dmp$get_file_info
*copyc dmp$get_stored_fmd
*copyc dmp$get_stored_fmd_header_info
*copyc dmp$get_stored_fmd_size
*copyc dmp$get_stored_fmd_subfile_list
*copyc dmp$put_stored_fmd_header_info
*copyc dmv$active_volume_table
*copyc i#move
*copyc mmp$advise_out
*copyc mmp$close_segment
*copyc mmp$open_file_segment
*copyc mmp$os_preallocate_file_space
*copyc mmp$preset_page_streaming
*copyc mmp$set_segment_length
*copyc mmp$verify_no_space_available
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$get_parameter_prompt
*copyc osp$prevalidate_free
*copyc osp$recoverable_system_error
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc pfp$access_object
*copyc pfp$attach_catalog
*copyc pfp$attach_root_catalog
*copyc pfp$build_archive_list_pointer
*copyc pfp$build_cycle_list_pointer
*copyc pfp$build_fmd_locator
*copyc pfp$build_fmd_pointer
*copyc pfp$compute_checksum
*copyc pfp$convert_cycle_path_to_strng
*copyc pfp$convert_pf_path_to_fs_path
*copyc pfp$convert_device_class_to_rm
*copyc pfp$create_catalog
*copyc pfp$dm_create_file_entry
*copyc pfp$destroy_catalog
*copyc pfp$detach_permanent_file
*copyc pfp$get_authority
*copyc pfp$locate_cycle
*copyc pfp$log_ascii
*copyc pfp$log_path
*copyc pfp$process_unexpected_status
*copyc pfp$reconcile_fmd
*copyc pfp$report_invalid_free
*copyc pfp$return_catalog
*copyc pfp$set_status_abnormal
*copyc pfp$shared_queue
*copyc pmp$continue_to_cause
*copyc pfp$shared_queue
*copyc pmp$date_time_compare
*copyc pmp$delay
*copyc pmp$get_compact_date_time
*copyc stp$get_pf_root
*copyc stp$store_pf_root
*copyc stv$system_set_name
*copyc syp$pop_inhibit_job_recovery
*copyc syp$push_inhibit_job_recovery

?? TITLE := 'Global Declarations Declared by this Module', EJECT ??

  CONST
    pfc$update_device_info_limit = 10485760,
    pfc$move_while_locked_limit = 1048576;

?? OLDTITLE ??
?? NEWTITLE := ' pfp$r2_get_move_obj_device_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_get_move_obj_device_info
    (    move_object_info_p: ^pft$move_object_info;
     VAR status: ost$status);

    VAR
      entry_p: ^cmt$peripheral_element_entry,
      i: integer,
      mass_storage_available: integer,
      mass_storage_capacity: integer,
      set_volume_list_p: ^pft$mo_volume_list;

    IF move_object_info_p = NIL THEN
      RETURN;
    IFEND;

    IF move_object_info_p^.set_volume_list_p <> NIL THEN
      set_volume_list_p := move_object_info_p^.set_volume_list_p;

      FOR i := 1 TO UPPERBOUND (set_volume_list_p^) DO
        cmp$get_element_entry_via_lun (set_volume_list_p^ [i].logical_unit_number, entry_p);
        IF entry_p <> NIL THEN
          dmp$calculate_device_capacity (entry_p^.product_id, mass_storage_capacity, status);
          IF status.normal THEN
            set_volume_list_p^ [i].mass_storage_capacity := mass_storage_capacity;
            dmp$calculate_remaining_space (set_volume_list_p^ [i].logical_unit_number, mass_storage_available,
                  status);
            IF status.normal THEN
              set_volume_list_p^ [i].mass_storage_available := mass_storage_available;
            IFEND;
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;

  PROCEND pfp$r2_get_move_obj_device_info;

?? OLDTITLE ??
?? NEWTITLE := ' pfp$r2_physically_move_catalog', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_physically_move_catalog
    (    path: pft$complete_path;
         move_object_info_p: ^pft$move_object_info;
     VAR status: ost$status);

    PROCEDURE physically_move_catalog_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        local_status: ost$status,
        status_id: ost$status_identifier,
        variant_path: pft$variant_path;

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := ^path;

      IF NOT process_non_local_exit THEN
        pfp$log_ascii ('***PF Condition Handler***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, {critical_message} FALSE, local_status);
        pfp$log_path (variant_path, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
              {critical_message} FALSE, local_status);
      IFEND;

      CASE condition.selector OF
      = pmc$system_conditions, pmc$block_exit_processing, mmc$segment_access_condition =
        IF process_non_local_exit THEN
          RETURN;
        IFEND;

        IF new_catalog_active THEN
          pfp$return_catalog (new_catalog_locator, local_status);
          new_catalog_active := NOT local_status.normal;
          #SPOIL (new_catalog_active);
          pfp$process_unexpected_status (local_status);
        IFEND;

        IF catalog_active THEN
          catalog_locator.abort_catalog_operation := TRUE;
          pfp$return_catalog (catalog_locator, local_status);
          catalog_active := NOT local_status.normal;
          #SPOIL (catalog_active);
          pfp$process_unexpected_status (local_status);
        IFEND;

        IF parent_catalog_active THEN
          parent_catalog_locator.abort_catalog_operation := TRUE;
          pfp$return_catalog (parent_catalog_locator, local_status);
          parent_catalog_active := NOT local_status.normal;
          #SPOIL (parent_catalog_active);
          pfp$process_unexpected_status (local_status);
        IFEND;

        IF job_recovery_inhibited THEN
          syp$pop_inhibit_job_recovery;
          job_recovery_inhibited := FALSE;
          #SPOIL (job_recovery_inhibited);
        IFEND;

        osp$set_status_from_condition (status_id, condition, p_sfsa, local_status, handler_status);
        osp$recoverable_system_error ('UNEXPECTED STATUS', ^local_status);

        status := local_status;
        initiate_non_local_exit;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          {syp$invalidate_open_sfid (catalog_locator.system_file_id, local_status);
          initiate_non_local_exit;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND physically_move_catalog_handler;

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_physically_move_catalog;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      class_string : string (1),
      destination_file_info: dmt$file_information,
      file_info: dmt$file_information,
      fmd_header: pft$fmd_header,
      fs_path_size: fst$path_size,
      gfn_dest: dmt$global_file_name,
      gfn_source: dmt$global_file_name,
      job_recovery_inhibited: boolean,
      local_status: ost$status,
      new_catalog_active: boolean,
      new_catalog_locator: pft$catalog_locator,
      p_catalog_object: ^pft$physical_object,
      p_fs_path: ^fst$path,
      p_internal_cycle_path: ^pft$internal_cycle_path,
      p_mass_storage_request_info: ^fmt$mass_storage_request_info,
      p_new_physical_fmd: ^pft$physical_fmd,
      p_physical_fmd: ^pft$physical_fmd,
      parent_catalog_active: boolean,
      parent_catalog_locator: pft$catalog_locator,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      prevalidate_free_result: ost$prevalidate_free_result,
      process_non_local_exit: boolean,
      resides_on_destination_volumes: boolean,
      selected_volume: rmt$recorded_vsn,
      sfid_dest: gft$system_file_identifier,
      sfid_src: gft$system_file_identifier,
      stored_fmd_size: dmt$stored_fmd_size,
      temp_subfile_list_p: ^pft$subfile_list,
      verify_status: ost$status,
      volume_index: ost$positive_integers;

    IF UPPERBOUND (path) <= 2 THEN
      IF move_object_info_p^.set_name = stv$system_set_name THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_sys_set_root_not_moved,
              move_object_info_p^.set_name, status);
      ELSE
        move_root_catalog (path, move_object_info_p, status);
      IFEND;
      RETURN;
    IFEND;

    syp$push_inhibit_job_recovery;
    job_recovery_inhibited := TRUE;
    #SPOIL (job_recovery_inhibited);

  /move_object/
    BEGIN
      catalog_active := FALSE;
      #SPOIL (catalog_active);
      new_catalog_active := FALSE;
      #SPOIL (new_catalog_active);
      parent_catalog_active := FALSE;
      #SPOIL (parent_catalog_active);
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);
      fmd_header.requested_class := rmc$unspecified_file_class;
      p_new_physical_fmd := NIL;
      status.normal := TRUE;

      move_object_info_p^.move_status.move_successful := FALSE;
      move_object_info_p^.move_status.old_subfile_list_p := NIL;
      move_object_info_p^.move_status.new_subfile_list_p := NIL;
      move_object_info_p^.move_status.reason_for_move_failure := pfc$unexpected_abort;

      pfp$get_authority (path, system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      PUSH p_internal_cycle_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$catalog_object],
            parent_charge_id, parent_catalog_locator, p_catalog_object, p_internal_cycle_path^.path,
            permit_entry, status);
      parent_catalog_active := status.normal;
      #SPOIL (parent_catalog_active);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      osp$establish_condition_handler (^physically_move_catalog_handler, {block_exit} TRUE);

      pfp$build_fmd_pointer (p_catalog_object^.object_entry.catalog_object_locator.fmd_locator,
            parent_catalog_locator.p_catalog_file, p_physical_fmd);

      gfn_source := p_catalog_object^.object_entry.catalog_object_locator.global_file_name;
      pfp$attach_catalog (^p_physical_fmd^.fmd, parent_catalog_locator.set_name,
            p_catalog_object^.object_entry.internal_object_name, gfn_source,
            pfc$write_access, {catalog_remote} FALSE, catalog_locator, status);
      catalog_active := status.normal;
      #SPOIL (catalog_active);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;
      sfid_src := catalog_locator.system_file_id;

      dmp$get_file_info (sfid_src, file_info, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      dmp$get_stored_fmd_header_info (^p_physical_fmd^.fmd, fmd_header, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      move_object_info_p^.move_status.allocated_size := file_info.total_allocated_length;
      move_object_info_p^.move_status.ms_class := fmd_header.requested_class;

      RESET move_object_info_p^.move_status.volume_list_storage_p;
      NEXT temp_subfile_list_p: [1 .. fmd_header.number_of_subfiles] IN
            move_object_info_p^.move_status.volume_list_storage_p;
      IF temp_subfile_list_p = NIL THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_subfile_list_seq_size, 'catalog',
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_fs_path^ (1, fs_path_size), status);
        EXIT /move_object/;
      ELSE
        move_object_info_p^.move_status.old_subfile_list_p := temp_subfile_list_p;
      IFEND;

      dmp$get_stored_fmd_subfile_list (^p_physical_fmd^.fmd, file_info.total_allocated_length,
            move_object_info_p^.move_status.old_subfile_list_p, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      validate_volume_threshold (move_object_info_p);
      IF NOT move_object_info_p^.move_status.move_successful AND
            ((move_object_info_p^.move_status.reason_for_move_failure = pfc$volume_threshold_exceeded) OR
            (move_object_info_p^.move_status.reason_for_move_failure = pfc$set_threshold_exceeded)) THEN
        EXIT /move_object/;
      IFEND;

      PUSH p_mass_storage_request_info;
      select_volume (path, {p_cycle_number} NIL, fmd_header,
            move_object_info_p^.move_status.old_subfile_list_p^, file_info, move_object_info_p,
            p_mass_storage_request_info^, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      IF NOT move_object_info_p^.perform_move THEN
        destination_file_info := file_info;
        simulate_move_object (path, {p_cycle_number} NIL, fmd_header,
              move_object_info_p^.move_status.old_subfile_list_p^, file_info, move_object_info_p, status);
        EXIT /move_object/;
      IFEND;

      selected_volume := p_mass_storage_request_info^.initial_volume;

      pfp$create_catalog (path, p_mass_storage_request_info, authority, {lock_catalog} FALSE,
            new_catalog_locator, status);
      new_catalog_active := status.normal;
      #SPOIL (new_catalog_active);
      IF status.normal THEN
        verify_volume_residence (new_catalog_locator.system_file_id, move_object_info_p^.dest_volume_list_p,
              resides_on_destination_volumes, verify_status);
        IF NOT verify_status.normal THEN
          status := verify_status;
          EXIT /move_object/;
        IFEND;
        IF (NOT resides_on_destination_volumes) AND
              ((UPPERBOUND(move_object_info_p^.dest_volume_list_p^) -
              LOWERBOUND(move_object_info_p^.dest_volume_list_p^)) > 0) THEN
          pfp$destroy_catalog (new_catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
          IF NOT local_status.normal THEN
            status := local_status;
            EXIT /move_object/;
          IFEND;

          pfp$return_catalog (new_catalog_locator, local_status);
          new_catalog_active := NOT local_status.normal;
          #SPOIL (new_catalog_active);
          pfp$process_unexpected_status (local_status);
          IF NOT local_status.normal THEN
            status := local_status;
            EXIT /move_object/;
          IFEND;

        /try_other_volumes/
          FOR volume_index := 1 TO UPPERBOUND (move_object_info_p^.dest_volume_list_p^) DO
            IF (NOT (fmd_header.requested_class IN
                  move_object_info_p^.dest_volume_list_p^ [volume_index]^.ms_class)) OR
                  (move_object_info_p^.dest_volume_list_p^ [volume_index]^.recorded_vsn =
                  selected_volume) THEN
              CYCLE /try_other_volumes/;
            IFEND;
            p_mass_storage_request_info^.initial_volume :=
                  move_object_info_p^.dest_volume_list_p^ [volume_index]^.recorded_vsn;
            pfp$create_catalog (path, p_mass_storage_request_info, authority, {lock_catalog} FALSE,
                  new_catalog_locator, status);
            new_catalog_active := status.normal;
            #SPOIL (new_catalog_active);
            IF status.normal THEN
              verify_volume_residence (new_catalog_locator.system_file_id,
                    move_object_info_p^.dest_volume_list_p, resides_on_destination_volumes, verify_status);
              IF NOT verify_status.normal THEN
                status := verify_status;
                EXIT /move_object/;
              IFEND;
              IF NOT resides_on_destination_volumes THEN
                pfp$destroy_catalog (new_catalog_locator, local_status);
                pfp$process_unexpected_status (local_status);
                IF NOT local_status.normal THEN
                  status := local_status;
                  EXIT /move_object/;
                IFEND;

                pfp$return_catalog (new_catalog_locator, local_status);
                new_catalog_active := NOT local_status.normal;
                #SPOIL (new_catalog_active);
                pfp$process_unexpected_status (local_status);
                IF NOT local_status.normal THEN
                  status := local_status;
                  EXIT /move_object/;
                IFEND;
                CYCLE /try_other_volumes/;
              IFEND;
            ELSE
              EXIT /try_other_volumes/;
            IFEND;
          FOREND /try_other_volumes/;
        IFEND;
      IFEND;

      IF ((NOT status.normal) AND (status.condition = dme$unable_to_alloc_all_space)) OR
            (NOT resides_on_destination_volumes) THEN
        class_string (1) := fmd_header.requested_class;
        move_object_info_p^.move_status.move_successful := FALSE;
        move_object_info_p^.move_status.reason_for_move_failure := pfc$no_available_space;
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_no_available_space, class_string,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, move_object_info_p^.set_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'catalog', status);
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_fs_path^ (1, fs_path_size),
              status);
      IFEND;

      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      sfid_dest := new_catalog_locator.system_file_id;
      gfn_dest := new_catalog_locator.internal_catalog_name;

      allocate_space_and_move_data (path, catalog_locator.p_catalog_file, new_catalog_locator.p_catalog_file,
            file_info.eoi_byte_address, {p_cycle_number} NIL, move_object_info_p, fmd_header.requested_class,
            status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      mmp$set_segment_length (new_catalog_locator.p_catalog_file, pfc$catalog_ring,
            file_info.eoi_byte_address, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      dmp$get_stored_fmd_size (sfid_dest, stored_fmd_size, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      ALLOCATE p_new_physical_fmd: [[REP stored_fmd_size OF cell]] IN
            parent_catalog_locator.p_catalog_file^.catalog_heap;
      IF p_new_physical_fmd = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, 'catalog fmd', status);
        EXIT /move_object/;
      IFEND;

      dmp$get_stored_fmd (sfid_dest, p_new_physical_fmd^.fmd, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      dmp$get_file_info (sfid_dest, destination_file_info, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      dmp$put_stored_fmd_header_info (fmd_header, ^p_new_physical_fmd^.fmd, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      pfp$compute_checksum (^p_new_physical_fmd^.fmd, #SIZE (p_new_physical_fmd^.fmd),
            p_new_physical_fmd^.checksum);

      dmp$get_stored_fmd_header_info (^p_new_physical_fmd^.fmd, fmd_header, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      NEXT temp_subfile_list_p: [1 .. fmd_header.number_of_subfiles] IN
            move_object_info_p^.move_status.volume_list_storage_p;
      IF temp_subfile_list_p = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_subfile_list_seq_size, 'catalog',
              status);
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_fs_path^ (1, fs_path_size), status);
        EXIT /move_object/;
      ELSE
        move_object_info_p^.move_status.new_subfile_list_p := temp_subfile_list_p;
      IFEND;

      dmp$get_stored_fmd_subfile_list (^p_new_physical_fmd^.fmd, destination_file_info.total_allocated_length,
            move_object_info_p^.move_status.new_subfile_list_p, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      pfp$build_fmd_locator (p_new_physical_fmd, parent_catalog_locator.p_catalog_file,
            p_catalog_object^.object_entry.catalog_object_locator.fmd_locator);

      p_catalog_object^.object_entry.catalog_object_locator.global_file_name := gfn_dest;
      pfp$compute_checksum (^p_catalog_object^.object_entry, #SIZE (pft$object_entry),
            p_catalog_object^.checksum);

      catalog_locator.queuing_info.set_catalog_alarm := TRUE;
      move_object_info_p^.move_status.move_successful := TRUE;
      move_object_info_p^.move_status.allocated_size := destination_file_info.total_allocated_length;
      move_object_info_p^.move_status.data_residence := pfc$unreleasable_data;
      move_object_info_p^.move_status.ms_class := fmd_header.requested_class;

    END /move_object/;

    IF new_catalog_active THEN
      IF NOT move_object_info_p^.move_status.move_successful THEN
        pfp$destroy_catalog (new_catalog_locator, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;

      pfp$return_catalog (new_catalog_locator, local_status);
      new_catalog_active := NOT local_status.normal;
      #SPOIL (new_catalog_active);
      pfp$process_unexpected_status (local_status);

      IF (NOT move_object_info_p^.move_status.move_successful) AND (p_new_physical_fmd <> NIL) THEN
        osp$prevalidate_free ((#OFFSET(p_new_physical_fmd) -
              #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
              ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
        IF prevalidate_free_result = osc$heap_free_valid THEN
          FREE p_new_physical_fmd IN catalog_locator.p_catalog_file^.catalog_heap;
        ELSE
          pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'FILE_MEDIA_DESCRIPTOR', 'catalog',
                prevalidate_free_result, #OFFSET(p_new_physical_fmd));
          p_new_physical_fmd := NIL;
        IFEND;
      IFEND;
    IFEND;

    IF catalog_active THEN
      IF move_object_info_p^.perform_move AND move_object_info_p^.move_status.move_successful THEN
        pfp$destroy_catalog (catalog_locator, local_status);
        pfp$process_unexpected_status (local_status);
        osp$prevalidate_free ((#OFFSET(p_physical_fmd) -
              #OFFSET(^parent_catalog_locator.p_catalog_file^.catalog_heap) - 16),
              ^parent_catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
        IF prevalidate_free_result = osc$heap_free_valid THEN
          FREE p_physical_fmd IN parent_catalog_locator.p_catalog_file^.catalog_heap;
        ELSE
          pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'FILE_MEDIA_DESCRIPTOR', 'catalog',
                prevalidate_free_result, #OFFSET(p_physical_fmd));
          p_physical_fmd := NIL;
        IFEND;
      ELSE
        pfp$return_catalog (catalog_locator, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;
      catalog_active := NOT local_status.normal;
      #SPOIL (catalog_active);
    IFEND;

    update_move_object_info (move_object_info_p, pfc$catalog_object, fmd_header,
          move_object_info_p^.move_status.old_subfile_list_p,
          move_object_info_p^.move_status.new_subfile_list_p, file_info, destination_file_info, local_status);
    pfp$process_unexpected_status (local_status);

    osp$disestablish_cond_handler;

    IF parent_catalog_active THEN
      pfp$return_catalog (parent_catalog_locator, local_status);
      parent_catalog_active := NOT local_status.normal;
      #SPOIL (parent_catalog_active);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
    job_recovery_inhibited := FALSE;
    #SPOIL (job_recovery_inhibited);

  PROCEND pfp$r2_physically_move_catalog;

?? OLDTITLE ??
?? NEWTITLE := ' pfp$r2_physically_move_cycle', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_physically_move_cycle
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         move_object_info_p: ^pft$move_object_info;
     VAR cycle_number: pft$cycle_number;
     VAR status: ost$status);

    PROCEDURE physically_move_cycle_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        variant_path: pft$variant_path,
        status_id: ost$status_identifier,
        local_status: ost$status;

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := ^path;

      IF NOT process_non_local_exit THEN
        pfp$log_ascii ('***PF Condition Handler***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, {critical_message} FALSE, local_status);
        pfp$log_path (variant_path, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
              {critical_message} FALSE, local_status);
      IFEND;

      CASE condition.selector OF
      = pmc$system_conditions, pmc$block_exit_processing, mmc$segment_access_condition =
        IF process_non_local_exit THEN
          RETURN;
        IFEND;

        IF source_file_open AND catalog_active THEN
          mmp$close_segment (seg_pointer_src, pfc$catalog_ring, local_status);
          source_file_open := NOT local_status.normal;
          #SPOIL (source_file_open);
          pfp$process_unexpected_status (local_status);
        IFEND;

        IF source_file_attached AND catalog_active THEN
          usage_selections := -$pft$usage_selections [];
          pfp$detach_permanent_file (^path, sfid_src, usage_selections, {catalog_access_allowed} TRUE,
                p_cycle, catalog_locator.p_catalog_file, fmd_modified, file_info, local_status);
          source_file_attached := NOT local_status.normal;
          #SPOIL (source_file_attached);
          pfp$process_unexpected_status (local_status);
        IFEND;

        IF destination_file_open THEN
          mmp$close_segment (seg_pointer_dest, pfc$catalog_ring, status);
          destination_file_open := NOT local_status.normal;
          #SPOIL (destination_file_open);
          pfp$process_unexpected_status (local_status);
        IFEND;

        IF destination_file_attached THEN
          dm_detach_file (sfid_dest, local_status);
          destination_file_attached := NOT local_status.normal;
          #SPOIL (destination_file_attached);
          pfp$process_unexpected_status (local_status);
        IFEND;

        IF catalog_active THEN
          catalog_locator.abort_catalog_operation := TRUE;
          pfp$return_catalog (catalog_locator, local_status);
          catalog_active := NOT local_status.normal;
          #SPOIL (catalog_active);
          pfp$process_unexpected_status (local_status);
        IFEND;

        IF job_recovery_inhibited THEN
          syp$pop_inhibit_job_recovery;
          job_recovery_inhibited := FALSE;
          #SPOIL (job_recovery_inhibited);
        IFEND;

        osp$set_status_from_condition (status_id, condition, p_sfsa, local_status, handler_status);
        osp$recoverable_system_error ('UNEXPECTED STATUS', ^local_status);

        status := local_status;
        initiate_non_local_exit;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          {syp$invalidate_open_sfid (catalog_locator.system_file_id, local_status);
          initiate_non_local_exit;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND physically_move_cycle_handler;

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_physically_move_cycle;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      allocate_space_status: ost$status,
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      class_string: string(1),
      destination_file_attached: boolean,
      destination_file_info: dmt$file_information,
      destination_file_open: boolean,
      device_class: rmt$device_class,
      file_allocated_length: integer,
      file_damaged: boolean,
      file_info: dmt$file_information,
      file_move_successful: boolean,
      fs_path_size: fst$path_size,
      fmd_header: pft$fmd_header,
      fmd_modified: boolean,
      gfn_dest: dmt$global_file_name,
      gfn_source: dmt$global_file_name,
      ignore_status: ost$status,
      job_recovery_inhibited: boolean,
      local_status: ost$status,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_fs_path: ^fst$path,
      p_internal_cycle_path: ^pft$internal_cycle_path,
      p_mass_storage_request_info: ^fmt$mass_storage_request_info,
      p_new_physical_fmd: ^pft$physical_fmd,
      p_new_subfile_list: ^pft$subfile_list,
      p_path_string: ^ost$string,
      p_physical_fmd: ^pft$physical_fmd,
      p_temp_physical_fmd: ^pft$physical_fmd,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      prevalidate_free_result: ost$prevalidate_free_result,
      process_non_local_exit: boolean,
      resides_on_destination_volumes: boolean,
      save_modification_date_time: ost$date_time,
      seg_pointer_dest: mmt$segment_pointer,
      seg_pointer_src: mmt$segment_pointer,
      selected_volume: rmt$recorded_vsn,
      sfid_dest: gft$system_file_identifier,
      sfid_src: gft$system_file_identifier,
      share_selections: pft$share_selections,
      source_file_attached: boolean,
      source_file_open: boolean,
      source_volume_list_p: ^pft$mo_volume_list_p,
      stored_fmd_size: dmt$stored_fmd_size,
      subfile_index: ost$positive_integers,
      temp_fmd_header: pft$fmd_header,
      temp_subfile_list_p: ^pft$subfile_list,
      usage_selections: pft$usage_selections,
      verify_status: ost$status,
      volume_index: ost$positive_integers;

    VAR
      segment_attributes: array [1 .. 1] of mmt$attribute_descriptor;

    syp$push_inhibit_job_recovery;
    job_recovery_inhibited := TRUE;
    #SPOIL (job_recovery_inhibited);

  /move_object/
    BEGIN
      catalog_active := FALSE;
      #SPOIL (catalog_active);
      destination_file_attached := FALSE;
      #SPOIL (destination_file_attached);
      destination_file_open := FALSE;
      #SPOIL (destination_file_open);
      file_move_successful := FALSE;
      #SPOIL (file_move_successful);
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);
      source_file_attached := FALSE;
      #SPOIL (source_file_attached);
      source_file_open := FALSE;
      #SPOIL (source_file_open);
      p_new_physical_fmd := NIL;
      status.normal := TRUE;

      segment_attributes [1].keyword := mmc$kw_software_attributes;
      segment_attributes [1].software_attri_set := $mmt$software_attribute_set
            [mmc$sa_read_transfer_unit, mmc$sa_free_behind];

      move_object_info_p^.move_status.move_successful := FALSE;
      move_object_info_p^.move_status.old_subfile_list_p := NIL;
      move_object_info_p^.move_status.new_subfile_list_p := NIL;
      move_object_info_p^.move_status.reason_for_move_failure := pfc$unexpected_abort;

      pfp$get_authority (path, system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      PUSH p_internal_cycle_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$file_object],
            parent_charge_id, catalog_locator, p_file_object, p_internal_cycle_path^.path, permit_entry,
            status);
      catalog_active := status.normal;
      #SPOIL (catalog_active);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      osp$establish_condition_handler (^physically_move_cycle_handler, {block_exit} TRUE);

      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      cycle_number := p_cycle^.cycle_entry.cycle_number;
      save_modification_date_time := p_cycle^.cycle_entry.cycle_statistics.modification_date_time;

      IF p_cycle^.cycle_entry.data_residence = pfc$offline_data THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^ , fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_data_resides_offline,
              p_fs_path^ (1, fs_path_size), status);
        osp$append_status_integer (osc$status_parameter_delimiter, p_cycle^.cycle_entry.cycle_number,
               {radix} 10, {include_radix_specifier} FALSE, status);
        EXIT /move_object/;
      IFEND;

      IF p_cycle^.cycle_entry.device_information.device_class_defined THEN
        pfp$convert_device_class_to_rm (p_cycle^.cycle_entry.device_information.device_class, device_class);
      ELSE
        device_class := rmc$mass_storage_device;
      IFEND;

      IF device_class <> rmc$mass_storage_device THEN
        PUSH p_path_string;
        pfp$convert_cycle_path_to_strng (path, p_cycle^.cycle_entry.cycle_number, p_path_string^);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_invalid_device_class,
              p_path_string^.value (1, p_path_string^.size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              amv$device_class_names [device_class].name, status);
        EXIT /move_object/;
      IFEND;

      pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, catalog_locator.p_catalog_file,
            p_physical_fmd);

      IF p_physical_fmd = NIL THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^ , fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$undefined_data,
              p_fs_path^ (1, fs_path_size), status);
        osp$append_status_integer (osc$status_parameter_delimiter, p_cycle^.cycle_entry.cycle_number,
              {radix} 10, {include_radix_specifier} FALSE, status);
        EXIT /move_object/;
      IFEND;

      dmp$get_stored_fmd_header_info (^p_physical_fmd^.fmd, fmd_header, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      IF p_cycle^.cycle_entry.attach_status.attach_count > 0 THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^ , fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_busy,
              p_fs_path^ (1, fs_path_size), status);
        osp$append_status_integer (osc$status_parameter_delimiter, p_cycle^.cycle_entry.cycle_number,
               {radix} 10, {include_radix_specifier} FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, pfc$multiple_job_usage_conflict, status);
        move_object_info_p^.move_status.move_successful := FALSE;
        move_object_info_p^.move_status.reason_for_move_failure := pfc$cycle_busy;
        EXIT /move_object/;
      IFEND;

      gfn_source := p_cycle^.cycle_entry.internal_cycle_name;
      usage_selections := -$pft$usage_selections [];
      share_selections := -$pft$share_selections [];
      dm_attach_file (path, catalog_locator.p_catalog_file, usage_selections, share_selections, p_cycle,
            sfid_src, file_damaged, status);
      source_file_attached := status.normal;
      #SPOIL (source_file_attached);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      dmp$get_file_info (sfid_src, file_info, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;
      file_allocated_length := file_info.total_allocated_length;

      move_object_info_p^.move_status.allocated_size := file_info.total_allocated_length;
      move_object_info_p^.move_status.ms_class := fmd_header.requested_class;

      RESET move_object_info_p^.move_status.volume_list_storage_p;
      NEXT temp_subfile_list_p: [1 .. fmd_header.number_of_subfiles] IN
            move_object_info_p^.move_status.volume_list_storage_p;
      IF temp_subfile_list_p = NIL THEN
        PUSH p_path_string;
        pfp$convert_cycle_path_to_strng (path, p_cycle^.cycle_entry.cycle_number, p_path_string^);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_subfile_list_seq_size, 'file',
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              p_path_string^.value (1, p_path_string^.size), status);
        EXIT /move_object/;
      ELSE
        move_object_info_p^.move_status.old_subfile_list_p := temp_subfile_list_p;
      IFEND;

      dmp$get_stored_fmd_subfile_list (^p_physical_fmd^.fmd, file_info.total_allocated_length,
            move_object_info_p^.move_status.old_subfile_list_p, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      validate_volume_threshold (move_object_info_p);
      IF NOT move_object_info_p^.move_status.move_successful AND
            ((move_object_info_p^.move_status.reason_for_move_failure = pfc$volume_threshold_exceeded) OR
            (move_object_info_p^.move_status.reason_for_move_failure = pfc$set_threshold_exceeded)) THEN
        EXIT /move_object/;
      IFEND;

      IF (p_cycle^.cycle_entry.data_residence = pfc$releasable_data) AND
            (move_object_info_p^.release_mass_storage = pfc$always) THEN
        release_cycle_data (path, move_object_info_p^.perform_move, p_cycle, catalog_locator.p_catalog_file,
              status);
        IF status.normal THEN
          move_object_info_p^.move_status.move_successful := TRUE;
          move_object_info_p^.move_status.allocated_size := file_info.total_allocated_length;
          move_object_info_p^.move_status.data_residence := pfc$offline_data;
          move_object_info_p^.move_status.modification_date_time :=
                p_cycle^.cycle_entry.data_modification_date_time;
          move_object_info_p^.move_status.ms_class := fmd_header.requested_class;
          EXIT /move_object/;
        ELSEIF (status.condition = pfe$empty_archive_list) OR
              (status.condition = pfe$data_not_releasable) THEN
          status.normal := TRUE;
        ELSE
          EXIT /move_object/;
        IFEND;
      IFEND;

      PUSH p_mass_storage_request_info;
      select_volume (path, ^p_cycle^.cycle_entry.cycle_number, fmd_header,
            move_object_info_p^.move_status.old_subfile_list_p^, file_info, move_object_info_p,
            p_mass_storage_request_info^, status);

      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      IF NOT move_object_info_p^.perform_move THEN
        destination_file_info := file_info;
        simulate_move_object (path, ^p_cycle^.cycle_entry.cycle_number, fmd_header,
              move_object_info_p^.move_status.old_subfile_list_p^, file_info, move_object_info_p, status);
        IF status.normal THEN
          move_object_info_p^.move_status.data_residence := p_cycle^.cycle_entry.data_residence;
          move_object_info_p^.move_status.modification_date_time :=
                p_cycle^.cycle_entry.cycle_statistics.modification_date_time;
        ELSEIF ((status.condition = pfe$movc_insufficient_space) OR
              (status.condition = pfe$movc_no_available_space)) AND
              (p_cycle^.cycle_entry.data_residence = pfc$releasable_data) AND
              (move_object_info_p^.release_mass_storage = pfc$when_insufficient_space) THEN
          release_cycle_data (path, move_object_info_p^.perform_move, p_cycle,
                catalog_locator.p_catalog_file, local_status);
          IF local_status.normal THEN
            status.normal := TRUE;
            move_object_info_p^.move_status.move_successful := TRUE;
            move_object_info_p^.move_status.allocated_size := file_info.total_allocated_length;
            move_object_info_p^.move_status.data_residence := pfc$offline_data;
            move_object_info_p^.move_status.modification_date_time :=
                  p_cycle^.cycle_entry.data_modification_date_time;
            move_object_info_p^.move_status.ms_class := fmd_header.requested_class;
          IFEND;
        IFEND;
        EXIT /move_object/;
      IFEND;

      selected_volume := p_mass_storage_request_info^.initial_volume;

      mmp$open_file_segment (sfid_src, ^segment_attributes, mmc$cell_pointer, pfc$catalog_ring,
            sfc$no_limit, seg_pointer_src, status);
      source_file_open := status.normal;
      #SPOIL (source_file_open);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      resides_on_destination_volumes := TRUE;
      usage_selections := -$pft$usage_selections [];
      share_selections := $pft$share_selections [];
      pfp$dm_create_file_entry (path, p_cycle^.cycle_entry.cycle_number, authority, usage_selections,
            share_selections, p_mass_storage_request_info, sfid_dest, gfn_dest, status);
      destination_file_attached := status.normal;
      #SPOIL (destination_file_attached);
      IF status.normal THEN
        verify_volume_residence (sfid_dest, move_object_info_p^.dest_volume_list_p,
              resides_on_destination_volumes, verify_status);
        IF NOT verify_status.normal THEN
          status := verify_status;
          EXIT /move_object/;
        IFEND;
        IF (NOT resides_on_destination_volumes) AND
              ((UPPERBOUND(move_object_info_p^.dest_volume_list_p^) -
              LOWERBOUND(move_object_info_p^.dest_volume_list_p^)) > 0) THEN

          dmp$get_stored_fmd_size (sfid_dest, stored_fmd_size, local_status);
          IF NOT local_status.normal THEN
            status := local_status;
            EXIT /move_object/;
          IFEND;

          PUSH p_temp_physical_fmd: [[REP stored_fmd_size OF cell]];
          dmp$get_stored_fmd (sfid_dest, p_temp_physical_fmd^.fmd, local_status);
          IF NOT local_status.normal THEN
            status := local_status;
            EXIT /move_object/;
          IFEND;

          dm_detach_file (sfid_dest, local_status);
          destination_file_attached := NOT local_status.normal;
          #SPOIL (destination_file_attached);
          IF NOT local_status.normal THEN
            status := local_status;
            EXIT /move_object/;
          IFEND;

          dmp$destroy_permanent_file (gfn_dest, p_temp_physical_fmd^.fmd, local_status);
          IF NOT local_status.normal THEN
            status := local_status;
            EXIT /move_object/;
          IFEND;

        /try_other_volumes/
          FOR volume_index := 1 TO UPPERBOUND (move_object_info_p^.dest_volume_list_p^) DO
            IF (NOT (fmd_header.requested_class IN
                  move_object_info_p^.dest_volume_list_p^ [volume_index]^.ms_class)) OR
                  (move_object_info_p^.dest_volume_list_p^ [volume_index]^.recorded_vsn =
                  selected_volume) THEN
              CYCLE /try_other_volumes/;
            IFEND;
            p_mass_storage_request_info^.initial_volume :=
                  move_object_info_p^.dest_volume_list_p^ [volume_index]^.recorded_vsn;
            pfp$dm_create_file_entry (path, p_cycle^.cycle_entry.cycle_number, authority, usage_selections,
                  share_selections, p_mass_storage_request_info, sfid_dest, gfn_dest, status);
            destination_file_attached := status.normal;
            #SPOIL (destination_file_attached);
            IF status.normal THEN
              verify_volume_residence (sfid_dest, move_object_info_p^.dest_volume_list_p,
                    resides_on_destination_volumes, verify_status);
              IF NOT verify_status.normal THEN
                status := verify_status;
                EXIT /move_object/;
              IFEND;

              IF NOT resides_on_destination_volumes THEN
                dmp$get_stored_fmd_size (sfid_dest, stored_fmd_size, local_status);
                IF NOT local_status.normal THEN
                  status := local_status;
                  EXIT /move_object/;
                IFEND;

                PUSH p_temp_physical_fmd: [[REP stored_fmd_size OF cell]];
                dmp$get_stored_fmd (sfid_dest, p_temp_physical_fmd^.fmd, local_status);
                IF NOT local_status.normal THEN
                  status := local_status;
                  EXIT /move_object/;
                IFEND;

                dm_detach_file (sfid_dest, local_status);
                destination_file_attached := NOT local_status.normal;
                #SPOIL (destination_file_attached);
                IF NOT local_status.normal THEN
                  status := local_status;
                  EXIT /move_object/;
                IFEND;

                dmp$destroy_permanent_file (gfn_dest, p_temp_physical_fmd^.fmd, local_status);
                IF NOT local_status.normal THEN
                  status := local_status;
                  EXIT /move_object/;
                IFEND;
                CYCLE /try_other_volumes/;
              IFEND;
            IFEND;
          FOREND /try_other_volumes/;
        IFEND;
      IFEND;

      IF ((NOT status.normal) AND (status.condition = dme$unable_to_alloc_all_space)) OR
            (NOT resides_on_destination_volumes) THEN
        class_string (1) := fmd_header.requested_class;
        move_object_info_p^.move_status.move_successful := FALSE;
        move_object_info_p^.move_status.reason_for_move_failure := pfc$no_available_space;
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_no_available_space, class_string,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, move_object_info_p^.set_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'file', status);
        PUSH p_path_string;
        pfp$convert_cycle_path_to_strng (path, p_cycle^.cycle_entry.cycle_number, p_path_string^);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              p_path_string^.value (1, p_path_string^.size), status);
      IFEND;

      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      mmp$open_file_segment (sfid_dest, ^segment_attributes, mmc$cell_pointer, pfc$catalog_ring,
            sfc$no_limit, seg_pointer_dest, status);
      destination_file_open := status.normal;
      #SPOIL (destination_file_open);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      IF file_info.eoi_byte_address <= pfc$move_while_locked_limit THEN
        allocate_space_and_move_data (path, seg_pointer_src.seq_pointer, seg_pointer_dest.seq_pointer,
              file_info.eoi_byte_address, ^cycle_number, move_object_info_p, fmd_header.requested_class,
              status);
        IF NOT status.normal THEN
          EXIT /move_object/;
        IFEND;
      ELSE
        pfp$return_catalog (catalog_locator, status);
        catalog_active := NOT status.normal;
        #SPOIL (catalog_active);
        IF NOT status.normal THEN
          EXIT /move_object/;
        IFEND;

        syp$pop_inhibit_job_recovery;
        job_recovery_inhibited := FALSE;
        #SPOIL (job_recovery_inhibited);

        allocate_space_and_move_data (path, seg_pointer_src.seq_pointer, seg_pointer_dest.seq_pointer,
              file_info.eoi_byte_address, ^cycle_number, move_object_info_p, fmd_header.requested_class,
              allocate_space_status);

        syp$push_inhibit_job_recovery;
        job_recovery_inhibited := TRUE;
        #SPOIL (job_recovery_inhibited);

        pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$file_object],
              parent_charge_id, catalog_locator, p_file_object, p_internal_cycle_path^.path, permit_entry,
              status);
        catalog_active := status.normal;
        #SPOIL (catalog_active);
        IF NOT status.normal THEN
          EXIT /move_object/;
        IFEND;

        pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
              catalog_locator.p_catalog_file, p_cycle_list);

        pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
        IF NOT status.normal THEN
          EXIT /move_object/;
        IFEND;

        IF NOT allocate_space_status.normal THEN
          status := allocate_space_status;
          EXIT /move_object/;
        IFEND;
      IFEND;

      mmp$set_segment_length (seg_pointer_dest.seq_pointer, pfc$catalog_ring, file_info.eoi_byte_address,
            status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      IF (p_cycle^.cycle_entry.attach_status.attach_count > 0) OR
            (save_modification_date_time <> p_cycle^.cycle_entry.cycle_statistics.modification_date_time) OR
            (p_cycle^.cycle_entry.internal_cycle_name <> gfn_source) THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^ , fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_busy,
              p_fs_path^ (1, fs_path_size), status);
        osp$append_status_integer (osc$status_parameter_delimiter, p_cycle^.cycle_entry.cycle_number,
               {radix} 10, {include_radix_specifier} FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, pfc$multiple_job_usage_conflict, status);
        move_object_info_p^.move_status.move_successful := FALSE;
        move_object_info_p^.move_status.reason_for_move_failure := pfc$cycle_busy;
        EXIT /move_object/;
      IFEND;

      verify_volume_residence (sfid_dest, move_object_info_p^.dest_volume_list_p,
            resides_on_destination_volumes, verify_status);
      IF NOT verify_status.normal THEN
        status := verify_status;
        EXIT /move_object/;
      IFEND;

      IF NOT resides_on_destination_volumes THEN
        class_string (1) := fmd_header.requested_class;
        move_object_info_p^.move_status.move_successful := FALSE;
        move_object_info_p^.move_status.reason_for_move_failure := pfc$insufficient_space;
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_insufficient_space, class_string,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, move_object_info_p^.set_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'file', status);
        PUSH p_path_string;
        pfp$convert_cycle_path_to_strng (path, p_cycle^.cycle_entry.cycle_number, p_path_string^);
        osp$append_status_parameter (osc$status_parameter_delimiter,
             p_path_string^.value (1, p_path_string^.size), status);
        EXIT /move_object/;
      IFEND;

      dmp$get_stored_fmd_size (sfid_dest, stored_fmd_size, local_status);
      IF NOT local_status.normal THEN
        status := local_status;
        EXIT /move_object/;
      IFEND;

      ALLOCATE p_new_physical_fmd: [[REP stored_fmd_size OF cell]] IN
            catalog_locator.p_catalog_file^.catalog_heap;
      IF p_new_physical_fmd = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, 'cycle fmd', status);
        EXIT /move_object/;
      IFEND;

      dmp$get_stored_fmd (sfid_dest, p_new_physical_fmd^.fmd, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      dmp$get_file_info (sfid_dest, destination_file_info, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      dmp$put_stored_fmd_header_info (fmd_header, ^p_new_physical_fmd^.fmd, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      dmp$get_stored_fmd_header_info (^p_new_physical_fmd^.fmd, fmd_header, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      NEXT temp_subfile_list_p: [1 .. fmd_header.number_of_subfiles] IN
            move_object_info_p^.move_status.volume_list_storage_p;
      IF temp_subfile_list_p = NIL THEN
        PUSH p_path_string;
        pfp$convert_cycle_path_to_strng (path, p_cycle^.cycle_entry.cycle_number, p_path_string^);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_subfile_list_seq_size, 'file',
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              p_path_string^.value (1, p_path_string^.size), status);
        EXIT /move_object/;
      ELSE
        move_object_info_p^.move_status.new_subfile_list_p := temp_subfile_list_p;
      IFEND;

      dmp$get_stored_fmd_subfile_list (^p_new_physical_fmd^.fmd, destination_file_info.total_allocated_length,
            move_object_info_p^.move_status.new_subfile_list_p, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      IF file_damaged THEN
        dmp$change_file_damaged (sfid_dest, {file_damaged} TRUE, gfn_dest, status);
        IF NOT status.normal THEN
          EXIT /move_object/;
        IFEND;
      IFEND;

      pfp$compute_checksum (^p_new_physical_fmd^.fmd, #SIZE (p_new_physical_fmd^.fmd),
            p_new_physical_fmd^.checksum);

      pfp$build_fmd_locator (p_new_physical_fmd, catalog_locator.p_catalog_file,
            p_cycle^.cycle_entry.fmd_locator);

      move_object_info_p^.move_status.move_successful := TRUE;
      file_move_successful := TRUE;
      #SPOIL (file_move_successful);

      p_cycle^.cycle_entry.internal_cycle_name := gfn_dest;

      pfp$compute_checksum (^p_cycle^.cycle_entry, #SIZE (pft$cycle_entry), p_cycle^.checksum);

      move_object_info_p^.move_status.allocated_size := destination_file_info.total_allocated_length;
      move_object_info_p^.move_status.data_residence := p_cycle^.cycle_entry.data_residence;
      move_object_info_p^.move_status.modification_date_time :=
            p_cycle^.cycle_entry.cycle_statistics.modification_date_time;
      move_object_info_p^.move_status.ms_class := fmd_header.requested_class;

    END /move_object/;

    IF catalog_active AND (NOT status.normal) AND ((status.condition = pfe$movc_insufficient_space) OR
          (status.condition = pfe$movc_no_available_space)) AND
          (p_cycle^.cycle_entry.data_residence = pfc$releasable_data) AND
          (move_object_info_p^.release_mass_storage = pfc$when_insufficient_space) THEN
      release_cycle_data (path, move_object_info_p^.perform_move, p_cycle,
            catalog_locator.p_catalog_file, local_status);
      IF local_status.normal THEN
        status.normal := TRUE;
        move_object_info_p^.move_status.move_successful := TRUE;
        move_object_info_p^.move_status.allocated_size := file_info.total_allocated_length;
        move_object_info_p^.move_status.data_residence := pfc$offline_data;
        move_object_info_p^.move_status.modification_date_time :=
              p_cycle^.cycle_entry.data_modification_date_time;
        move_object_info_p^.move_status.ms_class := fmd_header.requested_class;
      IFEND;
    IFEND;

    IF source_file_open AND catalog_active THEN
      mmp$close_segment (seg_pointer_src, pfc$catalog_ring, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    IF destination_file_open THEN
      mmp$close_segment (seg_pointer_dest, pfc$catalog_ring, local_status);
      destination_file_open := NOT local_status.normal;
      #SPOIL (destination_file_open);
      pfp$process_unexpected_status (local_status);
    IFEND;

    IF destination_file_attached THEN
      dmp$get_stored_fmd_size (sfid_dest, stored_fmd_size, local_status);
      IF local_status.normal THEN
        PUSH p_temp_physical_fmd: [[REP stored_fmd_size OF cell]];
        dmp$get_stored_fmd (sfid_dest, p_temp_physical_fmd^.fmd, local_status);
        IF local_status.normal THEN
          dm_detach_file (sfid_dest, local_status);
          destination_file_attached := NOT local_status.normal;
          #SPOIL (destination_file_attached);
          IF local_status.normal AND (NOT file_move_successful) THEN
            dmp$destroy_permanent_file (gfn_dest, p_temp_physical_fmd^.fmd, local_status);
          IFEND;
        IFEND;
      IFEND;
      IF (NOT file_move_successful) AND (p_new_physical_fmd <> NIL) THEN
        osp$prevalidate_free ((#OFFSET(p_new_physical_fmd) -
              #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
              ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
        IF prevalidate_free_result = osc$heap_free_valid THEN
          FREE p_new_physical_fmd IN catalog_locator.p_catalog_file^.catalog_heap;
        ELSE
          pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'FILE_MEDIA_DESCRIPTOR', 'file',
                prevalidate_free_result, #OFFSET(p_new_physical_fmd));
          p_new_physical_fmd := NIL;
        IFEND;
      IFEND;
    IFEND;

    IF source_file_attached AND catalog_active THEN
      usage_selections := -$pft$usage_selections [];
      pfp$detach_permanent_file (^path, sfid_src, usage_selections, {catalog_access_allowed} TRUE, p_cycle,
            catalog_locator.p_catalog_file, fmd_modified, file_info, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    IF file_move_successful AND catalog_active THEN
      dmp$destroy_permanent_file (gfn_source, p_physical_fmd^.fmd, local_status);
      osp$prevalidate_free ((#OFFSET(p_physical_fmd) -
            #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
            ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
      IF prevalidate_free_result = osc$heap_free_valid THEN
        FREE p_physical_fmd IN catalog_locator.p_catalog_file^.catalog_heap;
      ELSE
        pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'FILE_MEDIA_DESCRIPTOR', 'file',
              prevalidate_free_result, #OFFSET(p_physical_fmd));
        p_physical_fmd := NIL;
      IFEND;
      IF (NOT local_status.normal) AND (local_status.condition <> dme$file_descriptor_not_deleted) THEN
        pfp$process_unexpected_status (local_status);
      IFEND;
    IFEND;

    update_move_object_info (move_object_info_p, pfc$file_object, fmd_header,
          move_object_info_p^.move_status.old_subfile_list_p,
          move_object_info_p^.move_status.new_subfile_list_p, file_info, destination_file_info, local_status);
    pfp$process_unexpected_status (local_status);

    osp$disestablish_cond_handler;

    IF catalog_active THEN
      pfp$return_catalog (catalog_locator, local_status);
      catalog_active := NOT local_status.normal;
      #SPOIL (catalog_active);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
    job_recovery_inhibited := FALSE;
    #SPOIL (job_recovery_inhibited);

  PROCEND pfp$r2_physically_move_cycle;

?? OLDTITLE ??
?? NEWTITLE := ' allocate_space_and_move_data', EJECT ??

  PROCEDURE allocate_space_and_move_data
    (    path: pft$complete_path;
         source_pva: ^cell;
         destination_pva: ^cell;
         length: integer;
         p_cycle_number: ^pft$cycle_number;
         move_object_info_p: ^pft$move_object_info;
         mass_storage_class: dmt$class_member;
     VAR status: ost$status);

    CONST
      destination_transfer_size =  4000(16), {16,384 bytes}
      maximum_byte_move = 80000(16), {512K = 524,288}
      minimum_preset = 4096,
      unable_to_alloc_all_space_delay = 5 * 1000, {wait 5 seconds if out of MAT space}
      source_transfer_size =  10000(16); {65,536 bytes}

    VAR
      advise_pointer: ^cell,
      advise_size: integer,
      bytes_to_move: amt$file_byte_address,
      class_string: string(1),
      current_byte_address: amt$file_byte_address,
      from_pointer: ^cell,
      fs_path_size: fst$path_size,
      ignore_free_behind: boolean,
      ignore_transfer_size: 0..15,
      local_status: ost$status,
      no_space_available: boolean,
      p_fs_path: ^fst$path,
      p_path_string: ^ost$string,
      to_pointer: ^cell;

  /preallocate_file_space/
    REPEAT
      mmp$os_preallocate_file_space (destination_pva, length, {maximum_wait_seconds} 1, status);
      IF NOT status.normal THEN
        IF status.condition = dme$unable_to_alloc_all_space THEN
          mmp$verify_no_space_available (destination_pva, no_space_available, local_status);
          IF NOT local_status.normal THEN
            status := local_status;
            RETURN;
          ELSE
            IF no_space_available THEN
              move_object_info_p^.move_status.move_successful := FALSE;
              move_object_info_p^.move_status.reason_for_move_failure := pfc$insufficient_space;
              class_string (1) := mass_storage_class;
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_insufficient_space,
                    class_string, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, move_object_info_p^.set_name,
                    status);
              IF p_cycle_number = NIL THEN
                osp$append_status_parameter (osc$status_parameter_delimiter, 'catalog', status);
                PUSH p_fs_path;
                pfp$convert_pf_path_to_fs_path (path, p_fs_path^ , fs_path_size);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      p_fs_path^ (1, fs_path_size), status);
              ELSE
                osp$append_status_parameter (osc$status_parameter_delimiter, 'file', status);
                PUSH p_path_string;
                pfp$convert_cycle_path_to_strng (path, p_cycle_number^, p_path_string^);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      p_path_string^.value (1, p_path_string^.size), status);
              IFEND;
              RETURN;
            ELSE
              pmp$delay (unable_to_alloc_all_space_delay, local_status);
              CYCLE /preallocate_file_space/
            IFEND;
          IFEND;
        ELSE
          RETURN;
        IFEND;
      IFEND;
    UNTIL status.normal;

  /move_data/
    BEGIN
      current_byte_address := 0;

      WHILE current_byte_address < length DO
        bytes_to_move := maximum_byte_move;
        IF (current_byte_address + bytes_to_move) >= length THEN
          bytes_to_move := length - current_byte_address;
        IFEND;

        from_pointer := #ADDRESS ( #RING (source_pva), #SEGMENT (source_pva), current_byte_address);
        to_pointer := #address ( #RING (destination_pva), #SEGMENT (destination_pva), current_byte_address);

        IF (current_byte_address = 0) AND (bytes_to_move > minimum_preset) THEN

{ If the file is small (length is <= MINIMUM_PRESET (4096)), use I#MOVE without
{ presetting streaming mode.
{ If the file is large (length is > MINIMUM_PRESET (4096)), data is moved in
{ blocks of MAXIMUM_BYTE_MOVE (512K) bytes and MMP$PRESET_PAGE_STREAMING is
{ called prior to the first move to set streaming mode on both the source and
{ destination files before calling I#MOVE.  The reason for setting streaming
{ mode on the destination file is to enable FREE_BEHIND.

          mmp$preset_page_streaming ({preset_and_save_ts_fb} TRUE, from_pointer, source_transfer_size,
                ignore_transfer_size, ignore_free_behind, status);
          IF NOT status.normal THEN
            EXIT /move_data/;
          IFEND;

{ Use a transfer size of 16K on the destination file so free behind will release
{ pages faster than it would with a 64K transfer size.  If the disk allocation
{ unit is greater than 16K, memory management uses the AU size for the free
{ behind size.

          mmp$preset_page_streaming ({preset_and_save_ts_fb} TRUE, to_pointer, destination_transfer_size,
                ignore_transfer_size, ignore_free_behind, status);
          IF NOT status.normal THEN
            EXIT /move_data/;
          IFEND;
        IFEND;

        i#move (from_pointer, to_pointer, bytes_to_move);
        current_byte_address := current_byte_address + bytes_to_move;

{ Even though FREE_BEHIND is set for the source file, the last 2 or 3 transfer
{ units plus a partial transfer unit are still in the working set.  For the
{ destination file, the last transfer unit plus a partial transfer unit are
{ still in the working set.  An advise out on the entire file is done to remove
{ these pages from memory.

        advise_size:= #OFFSET (from_pointer) + bytes_to_move;
        advise_pointer := #ADDRESS (#RING (from_pointer), #SEGMENT (from_pointer), 0);
        mmp$advise_out (advise_pointer, advise_size, status);
        IF NOT status.normal THEN
          EXIT /move_data/;
        IFEND;

        advise_size:= #OFFSET (to_pointer) + bytes_to_move;
        advise_pointer := #ADDRESS (#RING (to_pointer), #SEGMENT (to_pointer), 0);
        mmp$advise_out (advise_pointer, advise_size, status);
        IF NOT status.normal THEN
          EXIT /move_data/;
        IFEND;

      WHILEND;

    END /move_data/;

  PROCEND allocate_space_and_move_data;

?? OLDTITLE ??
?? NEWTITLE := ' dm_attach_file', EJECT ??

  PROCEDURE dm_attach_file
    (    path: pft$complete_path;
         p_catalog_file: {input^} pft$p_catalog_file;
         usage_intentions: pft$usage_selections;
         share_selections: pft$share_selections;
         p_cycle: {i^/o^} pft$p_cycle;
     VAR system_file_id: gft$system_file_identifier;
     VAR file_damaged: boolean;
     VAR status: ost$status);

    CONST
      update_catalog = TRUE;

    VAR
      existing_sft_entry: dmt$existing_sft_entry,
      exit_on_unknown_file: boolean,
      fs_path_size: fst$path_size,
      p_fs_path: ^fst$path,
      p_path_string: ^ost$string,
      p_physical_fmd: pft$p_physical_fmd,
      recorded_vsn: rmt$recorded_vsn;

    pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, p_catalog_file, p_physical_fmd);

    {exit_on_unknown_file := cycle attached for write access
    exit_on_unknown_file := (p_cycle^.cycle_entry.attach_status.attach_count > 0) AND
          ((p_cycle^.cycle_entry.attach_status.usage_counts [pfc$shorten] > 0) OR
          (p_cycle^.cycle_entry.attach_status.usage_counts [pfc$append] > 0) OR
          (p_cycle^.cycle_entry.attach_status.usage_counts [pfc$modify] > 0));

    dmp$attach_file (p_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file,
          p_physical_fmd^.fmd, usage_intentions, share_selections, pfc$average_share_history,
          pfc$maximum_pf_length, {restricted_attach} FALSE, exit_on_unknown_file, {server_file} FALSE,
          pfp$shared_queue (p_cycle^.cycle_entry.shared_queue_info, share_selections), file_damaged,
          system_file_id, existing_sft_entry, status);
    IF status.normal THEN
      pfp$reconcile_fmd (^path, p_cycle^.cycle_entry.internal_cycle_name, existing_sft_entry, update_catalog,
            p_catalog_file, p_cycle, p_physical_fmd, status);
      IF status.normal AND ((existing_sft_entry = dmc$restricted_attach_entry) OR
            (exit_on_unknown_file AND (existing_sft_entry = dmc$entry_not_found))) THEN
        dmp$attach_file (p_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file,
              p_physical_fmd^.fmd, usage_intentions, share_selections, pfc$average_share_history,
              pfc$maximum_pf_length, {restricted_attach} FALSE, {exit_on_unknown_file} FALSE,
              {server_file} FALSE,
              pfp$shared_queue (p_cycle^.cycle_entry.shared_queue_info, share_selections), file_damaged,
              system_file_id, existing_sft_entry, status);
      IFEND;
    IFEND;

    IF NOT status.normal THEN
      PUSH p_path_string;
      pfp$convert_cycle_path_to_strng (path, p_cycle^.cycle_entry.cycle_number, p_path_string^);
      IF status.condition = dme$volume_unavailable THEN
        recorded_vsn := status.text.value (2, 6);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$volume_unavailable,
              p_path_string^.value (1, p_path_string^.size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, recorded_vsn, status);
      ELSEIF status.condition = dme$some_volumes_not_online THEN
        recorded_vsn := status.text.value (2, 6);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$volume_not_online,
              p_path_string^.value (1, p_path_string^.size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, recorded_vsn, status);
      ELSE
        pfp$report_unexpected_status (status);
        pfp$process_unexpected_status (status);
      IFEND;
    IFEND;

  PROCEND dm_attach_file;


?? OLDTITLE ??
?? NEWTITLE := ' dm_detach_file', EJECT ??

  PROCEDURE dm_detach_file
    (    system_file_id: gft$system_file_identifier;
     VAR status: ost$status);

    VAR
      file_modified: boolean,
      file_info: dmt$file_information,
      fmd_modified: boolean;

    status.normal := TRUE;


    dmp$detach_file (system_file_id, {access_allowed} TRUE, {flush_pages} TRUE, file_modified, fmd_modified,
          file_info, status);
    IF status.normal THEN
      dmp$delete_file_descriptor (system_file_id, status);
      IF NOT (status.normal) AND (status.condition = dme$file_descriptor_not_deleted) THEN
        status.normal := TRUE;
      IFEND;
    IFEND;

  PROCEND dm_detach_file;

?? OLDTITLE ??
?? NEWTITLE := ' move_root_catalog', EJECT ??

  PROCEDURE move_root_catalog
    (    path: pft$complete_path;
         move_object_info_p: ^pft$move_object_info;
     VAR status: ost$status);

    PROCEDURE move_root_catalog_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        fs_path_size: fst$path_size,
        local_status: ost$status,
        p_fs_path: ^fst$path,
        status_id: ost$status_identifier,
        variant_path: pft$variant_path;

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := ^path;

      IF NOT process_non_local_exit THEN
        pfp$log_ascii ('***PF Condition Handler***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, {critical_message} FALSE, local_status);
        pfp$log_path (variant_path, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
              {critical_message} FALSE, local_status);
      IFEND;

      CASE condition.selector OF
      = pmc$system_conditions, pmc$block_exit_processing, mmc$segment_access_condition =
        IF process_non_local_exit THEN
          RETURN;
        IFEND;

        IF new_catalog_active THEN
          pfp$return_catalog (new_catalog_locator, local_status);
          new_catalog_active := NOT local_status.normal;
          #SPOIL (new_catalog_active);
          pfp$process_unexpected_status (local_status);
        IFEND;

        IF catalog_active THEN
          catalog_locator.abort_catalog_operation := TRUE;
          pfp$return_catalog (catalog_locator, local_status);
          catalog_active := NOT local_status.normal;
          #SPOIL (catalog_active);
          pfp$process_unexpected_status (local_status);
        IFEND;

        IF job_recovery_inhibited THEN
          syp$pop_inhibit_job_recovery;
          job_recovery_inhibited := FALSE;
          #SPOIL (job_recovery_inhibited);
        IFEND;

        osp$set_status_from_condition (status_id, condition, p_sfsa, local_status, handler_status);
        osp$recoverable_system_error ('UNEXPECTED STATUS', ^local_status);

        status := local_status;
        initiate_non_local_exit;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          {syp$invalidate_open_sfid (catalog_locator.system_file_id, local_status);
          initiate_non_local_exit;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND move_root_catalog_handler;

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT move_root_catalog;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      class_string: string(1),
      destination_file_info: dmt$file_information,
      file_info: dmt$file_information,
      fmd_header: pft$fmd_header,
      fs_path_size: fst$path_size,
      job_recovery_inhibited: boolean,
      local_status: ost$status,
      new_catalog_active: boolean,
      new_catalog_locator: pft$catalog_locator,
      p_fs_path: ^fst$path,
      p_internal_catalog_name: ^pft$internal_catalog_name,
      p_mass_storage_request_info: ^fmt$mass_storage_request_info,
      p_path_string: ^ost$string,
      p_root: ^pft$root,
      p_stored_fmd: ^dmt$stored_fmd,
      p_stored_fmd_size: ^dmt$stored_fmd_size,
      process_non_local_exit: boolean,
      resides_on_destination_volumes: boolean,
      root_size: pft$root_size,
      selected_volume: rmt$recorded_vsn,
      set_path: array [1 .. 1] of ost$name,
      stored_fmd_size: dmt$stored_fmd_size,
      temp_subfile_list_p: ^pft$subfile_list,
      verify_status: ost$status,
      volume_index: ost$positive_integers;

    syp$push_inhibit_job_recovery;
    job_recovery_inhibited := TRUE;
    #SPOIL (job_recovery_inhibited);

  /move_object/
    BEGIN
      catalog_active := FALSE;
      #SPOIL (catalog_active);
      new_catalog_active := FALSE;
      #SPOIL (new_catalog_active);
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);
      fmd_header.requested_class := rmc$unspecified_file_class;
      status.normal := TRUE;

      move_object_info_p^.move_status.move_successful := FALSE;
      move_object_info_p^.move_status.old_subfile_list_p := NIL;
      move_object_info_p^.move_status.new_subfile_list_p := NIL;
      move_object_info_p^.move_status.reason_for_move_failure := pfc$unexpected_abort;

      root_size := 255; {estimate}
      REPEAT
        PUSH p_root: [[REP root_size OF cell]];
        RESET p_root;
        stp$get_pf_root (move_object_info_p^.set_name, root_size, p_root^, status);
      UNTIL status.normal OR (status.condition <> ste$incorrect_root_size);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      RESET p_root;
      NEXT p_internal_catalog_name IN p_root;
      NEXT p_stored_fmd_size IN p_root;
      NEXT p_stored_fmd: [[REP p_stored_fmd_size^ OF cell]] IN p_root;

      pfp$attach_root_catalog (move_object_info_p^.set_name, pfc$write_access, catalog_locator, status);
      catalog_active := status.normal;
      #SPOIL (catalog_active);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      osp$establish_condition_handler (^move_root_catalog_handler, {block_exit} TRUE);

      dmp$get_file_info (catalog_locator.system_file_id, file_info, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      dmp$get_stored_fmd_header_info (p_stored_fmd, fmd_header, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      move_object_info_p^.move_status.allocated_size := file_info.total_allocated_length;
      move_object_info_p^.move_status.ms_class := fmd_header.requested_class;

      RESET move_object_info_p^.move_status.volume_list_storage_p;
      NEXT temp_subfile_list_p: [1 .. fmd_header.number_of_subfiles] IN
            move_object_info_p^.move_status.volume_list_storage_p;
      IF temp_subfile_list_p = NIL THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^ , fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_subfile_list_seq_size, 'catalog',
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_fs_path^ (1, fs_path_size), status);
        EXIT /move_object/;
      ELSE
        move_object_info_p^.move_status.old_subfile_list_p := temp_subfile_list_p;
      IFEND;

      dmp$get_stored_fmd_subfile_list (p_stored_fmd, file_info.total_allocated_length,
            move_object_info_p^.move_status.old_subfile_list_p, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      PUSH p_mass_storage_request_info;
      select_volume (path, {p_cycle_number} NIL, fmd_header,
            move_object_info_p^.move_status.old_subfile_list_p^, file_info, move_object_info_p,
            p_mass_storage_request_info^, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      IF NOT move_object_info_p^.perform_move THEN
        destination_file_info := file_info;
        simulate_move_object (path, {p_cycle_number} NIL, fmd_header,
              move_object_info_p^.move_status.old_subfile_list_p^, file_info, move_object_info_p, status);
        EXIT /move_object/;
      IFEND;

      selected_volume := p_mass_storage_request_info^.initial_volume;

      pfp$get_authority (path, system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      set_path [1] := move_object_info_p^.set_name;
      pfp$create_catalog (path, p_mass_storage_request_info, authority, {lock_catalog} FALSE,
            new_catalog_locator, status);
      new_catalog_active := status.normal;
      #SPOIL (new_catalog_active);
      IF status.normal THEN
        verify_volume_residence (new_catalog_locator.system_file_id, move_object_info_p^.dest_volume_list_p,
              resides_on_destination_volumes, verify_status);
        IF NOT verify_status.normal THEN
          status := verify_status;
          EXIT /move_object/;
        IFEND;
        IF (NOT resides_on_destination_volumes) AND
              ((UPPERBOUND(move_object_info_p^.dest_volume_list_p^) -
              LOWERBOUND(move_object_info_p^.dest_volume_list_p^)) > 0) THEN
          pfp$destroy_catalog (new_catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
          IF NOT local_status.normal THEN
            status := local_status;
            EXIT /move_object/;
          IFEND;

          pfp$return_catalog (new_catalog_locator, local_status);
          new_catalog_active := NOT local_status.normal;
          #SPOIL (new_catalog_active);
          pfp$process_unexpected_status (local_status);
          IF NOT local_status.normal THEN
            status := local_status;
            EXIT /move_object/;
          IFEND;

        /try_other_volumes/
          FOR volume_index := 1 TO UPPERBOUND (move_object_info_p^.dest_volume_list_p^) DO
            IF (NOT (fmd_header.requested_class IN
                  move_object_info_p^.dest_volume_list_p^ [volume_index]^.ms_class)) OR
                  (move_object_info_p^.dest_volume_list_p^ [volume_index]^.recorded_vsn =
                  selected_volume) THEN
              CYCLE /try_other_volumes/;
            IFEND;
            p_mass_storage_request_info^.initial_volume :=
                  move_object_info_p^.dest_volume_list_p^ [volume_index]^.recorded_vsn;
            pfp$create_catalog (path, p_mass_storage_request_info, authority, {lock_catalog} FALSE,
                  new_catalog_locator, status);
            new_catalog_active := status.normal;
            #SPOIL (new_catalog_active);
            IF status.normal THEN
              verify_volume_residence (new_catalog_locator.system_file_id,
                    move_object_info_p^.dest_volume_list_p, resides_on_destination_volumes, verify_status);
              IF NOT verify_status.normal THEN
                status := verify_status;
                EXIT /move_object/;
              IFEND;
              IF NOT resides_on_destination_volumes THEN
                pfp$destroy_catalog (new_catalog_locator, local_status);
                pfp$process_unexpected_status (local_status);
                IF NOT local_status.normal THEN
                  status := local_status;
                  EXIT /move_object/;
                IFEND;

                pfp$return_catalog (new_catalog_locator, local_status);
                new_catalog_active := NOT local_status.normal;
                #SPOIL (new_catalog_active);
                pfp$process_unexpected_status (local_status);
                IF NOT local_status.normal THEN
                  status := local_status;
                  EXIT /move_object/;
                IFEND;
                CYCLE /try_other_volumes/;
              IFEND;
            ELSE
              EXIT /try_other_volumes/;
            IFEND;
          FOREND /try_other_volumes/;
        IFEND;
      IFEND;

      IF ((NOT status.normal) AND (status.condition = dme$unable_to_alloc_all_space)) OR
            (NOT resides_on_destination_volumes) THEN
        class_string (1) := fmd_header.requested_class;
        move_object_info_p^.move_status.move_successful := FALSE;
        move_object_info_p^.move_status.reason_for_move_failure := pfc$no_available_space;
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_no_available_space, class_string,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, move_object_info_p^.set_name,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'catalog', status);
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^ , fs_path_size);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              p_fs_path^ (1, fs_path_size), status);
      IFEND;

      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      allocate_space_and_move_data (path, catalog_locator.p_catalog_file, new_catalog_locator.p_catalog_file,
            file_info.eoi_byte_address, {p_cycle_number} NIL, move_object_info_p, fmd_header.requested_class,
            status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      mmp$set_segment_length (new_catalog_locator.p_catalog_file, pfc$catalog_ring,
            file_info.eoi_byte_address, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      dmp$get_stored_fmd_size (new_catalog_locator.system_file_id, stored_fmd_size, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      PUSH p_root: [[REP 1 OF pft$internal_catalog_name, REP 1 OF dmt$stored_fmd_size,
            REP stored_fmd_size OF cell]];

      RESET p_root;
      NEXT p_internal_catalog_name IN p_root;
      p_internal_catalog_name^ := new_catalog_locator.internal_catalog_name;

      NEXT p_stored_fmd_size IN p_root;
      p_stored_fmd_size^ := stored_fmd_size;

      NEXT p_stored_fmd: [[REP stored_fmd_size OF cell]] IN p_root;
      dmp$get_stored_fmd (new_catalog_locator.system_file_id, p_stored_fmd^, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      dmp$get_file_info (new_catalog_locator.system_file_id, destination_file_info, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      dmp$put_stored_fmd_header_info (fmd_header, p_stored_fmd, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      dmp$get_stored_fmd_header_info (p_stored_fmd, fmd_header, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      NEXT temp_subfile_list_p: [1 .. fmd_header.number_of_subfiles] IN
            move_object_info_p^.move_status.volume_list_storage_p;
      IF temp_subfile_list_p = NIL THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_subfile_list_seq_size, 'catalog',
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_fs_path^ (1, fs_path_size), status);
        EXIT /move_object/;
      ELSE
        move_object_info_p^.move_status.new_subfile_list_p := temp_subfile_list_p;
      IFEND;

      dmp$get_stored_fmd_subfile_list (p_stored_fmd, destination_file_info.total_allocated_length,
            move_object_info_p^.move_status.new_subfile_list_p, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      stp$store_pf_root (move_object_info_p^.set_name, p_root^, status);
      IF NOT status.normal THEN
        EXIT /move_object/;
      IFEND;

      catalog_locator.queuing_info.set_catalog_alarm := TRUE;
      move_object_info_p^.move_status.move_successful := TRUE;
      move_object_info_p^.move_status.allocated_size := destination_file_info.total_allocated_length;
      move_object_info_p^.move_status.data_residence := pfc$unreleasable_data;
      move_object_info_p^.move_status.ms_class := fmd_header.requested_class;

    END /move_object/;

    IF new_catalog_active THEN
      IF NOT move_object_info_p^.move_status.move_successful THEN
        pfp$destroy_catalog (new_catalog_locator, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;

      pfp$return_catalog (new_catalog_locator, local_status);
      new_catalog_active := NOT local_status.normal;
      #SPOIL (new_catalog_active);
      pfp$process_unexpected_status (local_status);
    IFEND;

    update_move_object_info (move_object_info_p, pfc$catalog_object, fmd_header,
          move_object_info_p^.move_status.old_subfile_list_p,
          move_object_info_p^.move_status.new_subfile_list_p, file_info, destination_file_info, local_status);
    pfp$process_unexpected_status (local_status);

    osp$disestablish_cond_handler;

    IF catalog_active THEN
      IF move_object_info_p^.perform_move AND move_object_info_p^.move_status.move_successful THEN
        pfp$destroy_catalog (catalog_locator, local_status);
        catalog_active := NOT local_status.normal;
        #SPOIL (catalog_active);
        pfp$process_unexpected_status (local_status);
      ELSE
        pfp$return_catalog (catalog_locator, local_status);
        catalog_active := NOT local_status.normal;
        #SPOIL (catalog_active);
        pfp$process_unexpected_status (local_status);
      IFEND;
    IFEND;

    syp$pop_inhibit_job_recovery;
    job_recovery_inhibited := FALSE;
    #SPOIL (job_recovery_inhibited);

  PROCEND move_root_catalog;

?? OLDTITLE ??
?? NEWTITLE := ' release_cycle_data', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to release mass storage data for a
{   specified file cycle.
{
{ NOTES:
{   If the cycle data has been modified since the most recent archive entry was
{   created, mass storage data is not released.
{

  PROCEDURE release_cycle_data
    (    path: pft$complete_path;
         perform_changes: boolean;
         p_physical_cycle: {i^/o^} ^pft$physical_cycle;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
     VAR status: ost$status);

    VAR
      archive_date_time: ost$date_time,
      archive_index: pft$archive_index,
      comparison_result: pmt$comparison_result,
      data_modification_date_time: ost$date_time,
      p_archive_entry: ^pft$archive_entry,
      p_archive_list: ^pft$archive_list,
      p_physical_fmd: ^pft$physical_fmd,
      prevalidate_free_result: ost$prevalidate_free_result,
      release_date_time: ost$date_time,
      valid_archive_entry_found: boolean,
      variant_path: pft$variant_path;

    status.normal := TRUE;

    pfp$build_archive_list_pointer (p_physical_cycle^.cycle_entry.archive_list_locator, p_catalog_file,
          p_archive_list);
    IF p_archive_list = NIL THEN
      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := ^path;
      pfp$set_status_abnormal (variant_path, pfe$empty_archive_list, status);
      RETURN;
    IFEND;
    {
    { Locate most recently created archive entry.
    {
    p_archive_entry := ^p_archive_list^ [1].archive_entry;
    archive_date_time := p_archive_entry^.archive_date_time;

  /search_archive_list/
    FOR archive_index := 2 TO UPPERBOUND (p_archive_list^) DO
      pmp$date_time_compare (p_archive_list^ [archive_index].archive_entry.archive_date_time,
            archive_date_time, comparison_result, status);
      IF NOT status.normal THEN
        CYCLE /search_archive_list/;
      IFEND;
      IF comparison_result = pmc$left_is_greater THEN
        archive_date_time := p_archive_list^ [archive_index].archive_entry.archive_date_time;
        p_archive_entry := ^p_archive_list^ [archive_index].archive_entry;
      IFEND;
    FOREND /search_archive_list/;
    {
    { The archive entry will be considered a valid archive entry if it was created after
    { the cycle was last modified.
    {
    data_modification_date_time := p_physical_cycle^.cycle_entry.data_modification_date_time;
    pmp$date_time_compare (archive_date_time, data_modification_date_time, comparison_result, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    valid_archive_entry_found := (comparison_result = pmc$left_is_greater);
    {
    { If a valid archive entry does not exist, the release request will be rejected.
    {
    IF NOT valid_archive_entry_found THEN
      p_physical_cycle^.cycle_entry.data_residence := pfc$unreleasable_data;
      pfp$compute_checksum (^p_physical_cycle^.cycle_entry, #SIZE (pft$cycle_entry),
            p_physical_cycle^.checksum);

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := ^path;
      pfp$set_status_abnormal (variant_path, pfe$data_not_releasable, status);
      osp$append_status_integer (osc$status_parameter_delimiter, p_physical_cycle^.cycle_entry.cycle_number,
            {radix} 10, {include_radix_specifier} FALSE, status);
      RETURN;
    IFEND;

    IF NOT perform_changes THEN
      RETURN;
    IFEND;

    pfp$build_fmd_pointer (p_physical_cycle^.cycle_entry.fmd_locator, p_catalog_file, p_physical_fmd);
    IF p_physical_fmd <> NIL THEN
      dmp$destroy_permanent_file (p_physical_cycle^.cycle_entry.internal_cycle_name, p_physical_fmd^.fmd,
            status);
      pfp$process_unexpected_status (status);
      status.normal := TRUE;
      {
      { Release the file_media_descriptor even if there is a failure in
      { releasing the mass storage for the file cycle.  This makes the
      { system more fault tolerant and allows the user to continue.
      { Recovery of the set will make the files known to both device
      { management and permanent file management.
      {
      osp$prevalidate_free ((#OFFSET(p_physical_fmd) -
            #OFFSET(^p_catalog_file^.catalog_heap) - 16), ^p_catalog_file^.catalog_heap,
            prevalidate_free_result);
      IF prevalidate_free_result = osc$heap_free_valid THEN
        FREE p_physical_fmd IN p_catalog_file^.catalog_heap;
      ELSE
        pfp$report_invalid_free (^path, ^p_physical_cycle^.cycle_entry.cycle_number, 'FILE_MEDIA_DESCRIPTOR',
              'file', prevalidate_free_result, #OFFSET(p_physical_fmd));
        p_physical_fmd := NIL;
      IFEND;
      pfp$build_fmd_locator ({p_physical_fmd} NIL, {p_catalog_file} NIL,
            p_physical_cycle^.cycle_entry.fmd_locator);
    IFEND;
    p_physical_cycle^.cycle_entry.data_residence := pfc$offline_data;
    p_physical_cycle^.cycle_entry.data_modification_date_time := p_archive_entry^.modification_date_time;
    p_physical_cycle^.cycle_entry.cycle_statistics.modification_date_time :=
          p_archive_entry^.modification_date_time;

    pmp$get_compact_date_time (release_date_time, status);

  /set_release_date_time/
    FOR archive_index := 1 TO UPPERBOUND (p_archive_list^) DO
      pmp$date_time_compare (p_archive_list^ [archive_index].archive_entry.modification_date_time,
            p_physical_cycle^.cycle_entry.data_modification_date_time, comparison_result, status);
      IF NOT status.normal THEN
        EXIT /set_release_date_time/;
      IFEND;

      IF comparison_result = pmc$equal THEN
        p_archive_list^ [archive_index].archive_entry.last_release_date_time := release_date_time;
        pfp$compute_checksum (^p_archive_list^ [archive_index].archive_entry, #SIZE (pft$archive_entry),
              p_archive_list^ [archive_index].checksum);
      IFEND;
    FOREND /set_release_date_time/;

    pfp$compute_checksum (^p_physical_cycle^.cycle_entry, #SIZE (pft$cycle_entry),
          p_physical_cycle^.checksum);

  PROCEND release_cycle_data;

?? OLDTITLE ??
?? NEWTITLE := ' select_volume', EJECT ??

  PROCEDURE select_volume
    (    path: pft$complete_path;
         p_cycle_number: ^pft$cycle_number,
         fmd_header: pft$fmd_header;
         subfile_list: pft$subfile_list;
         file_info: dmt$file_information;
         move_object_info_p: ^pft$move_object_info;
     VAR mass_storage_request_info: fmt$mass_storage_request_info;
     VAR status: ost$status);

    VAR
      best_volume: ost$non_negative_integers,
      class_string: string(1),
      dest_volume_list_p: ^pft$mo_volume_list_p,
      fs_path_size: fst$path_size,
      most_space_available: ost$non_negative_integers,
      p_fs_path: ^fst$path,
      p_path_string: ^ost$string,
      remaining_space_to_allocate: ost$non_negative_integers,
      resides_on_destination_volumes: boolean,
      resides_on_source_volumes: boolean,
      source_volume_list_p: ^pft$mo_volume_list_p,
      subfile_index: ost$positive_integers,
      volume_index: ost$positive_integers;

    status.normal := TRUE;
    class_string := fmd_header.requested_class;

    IF NOT (fmd_header.requested_class IN move_object_info_p^.mass_storage_class) THEN
      IF p_cycle_number = NIL THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_ms_class_conflict, 'catalog',
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_fs_path^ (1, fs_path_size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, class_string, status);
        RETURN;
      ELSE
        PUSH p_path_string;
        pfp$convert_cycle_path_to_strng (path, p_cycle_number^, p_path_string^);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_ms_class_conflict, 'file', status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              p_path_string^.value (1, p_path_string^.size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, class_string, status);
        RETURN;
      IFEND;
    IFEND;

    dest_volume_list_p := move_object_info_p^.dest_volume_list_p;
    IF dest_volume_list_p = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_no_destination_volumes,
            move_object_info_p^.set_name, status);
      RETURN;
    IFEND;

  /check_subfiles_destination/
    FOR subfile_index := 1 TO UPPERBOUND (subfile_list) DO
      resides_on_destination_volumes := FALSE;
    /check_destination_volumes/
      FOR volume_index := 1 TO UPPERBOUND (dest_volume_list_p^) DO
        IF (subfile_list [subfile_index].recorded_vsn = dest_volume_list_p^ [volume_index]^.recorded_vsn) THEN
          resides_on_destination_volumes := TRUE;
          EXIT /check_destination_volumes/
        IFEND
      FOREND /check_destination_volumes/;
      IF NOT resides_on_destination_volumes THEN
        EXIT /check_subfiles_destination/
      IFEND;
    FOREND /check_subfiles_destination/;

    IF resides_on_destination_volumes THEN
      IF p_cycle_number = NIL THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$resides_on_dest_volumes, 'Catalog',
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_fs_path^ (1, fs_path_size), status);
      ELSE
        PUSH p_path_string;
        pfp$convert_cycle_path_to_strng (path, p_cycle_number^, p_path_string^);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$resides_on_dest_volumes, 'File', status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              p_path_string^.value (1, p_path_string^.size), status);
      IFEND;
      RETURN;
    IFEND;

    source_volume_list_p := move_object_info_p^.source_volume_list_p;

    resides_on_source_volumes := FALSE;
  /check_subfiles_source/
    FOR subfile_index := 1 TO UPPERBOUND (subfile_list) DO
      FOR volume_index := 1 TO UPPERBOUND (source_volume_list_p^) DO
        IF subfile_list [subfile_index].recorded_vsn = source_volume_list_p^ [volume_index]^.recorded_vsn THEN
          resides_on_source_volumes := TRUE;
          EXIT /check_subfiles_source/;
        IFEND;
      FOREND;
    FOREND /check_subfiles_source/;

    IF NOT resides_on_source_volumes THEN
      IF p_cycle_number = NIL THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_not_on_source_volumes, 'catalog',
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              p_fs_path^ (1, fs_path_size), status);
      ELSE
        PUSH p_path_string;
        pfp$convert_cycle_path_to_strng (path, p_cycle_number^, p_path_string^);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_not_on_source_volumes, 'file',
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              p_path_string^.value (1, p_path_string^.size), status);
      IFEND;
      RETURN;
    IFEND;

    best_volume := 0;
    most_space_available := 0;
    remaining_space_to_allocate := file_info.total_allocated_length;

  /check_requested_volume/
    FOR volume_index := 1 TO UPPERBOUND (dest_volume_list_p^) DO
      IF NOT (fmd_header.requested_class IN dest_volume_list_p^ [volume_index]^.ms_class) THEN
        CYCLE /check_requested_volume/;
      IFEND;

      IF (fmd_header.requested_volume.recorded_vsn = dest_volume_list_p^ [volume_index]^.recorded_vsn) AND
            (dest_volume_list_p^ [volume_index]^.mass_storage_available >= remaining_space_to_allocate) THEN
        remaining_space_to_allocate := 0;
        most_space_available := dest_volume_list_p^ [volume_index]^.mass_storage_available;
        best_volume := volume_index;
        EXIT /check_requested_volume/;
      IFEND;
    FOREND /check_requested_volume/;

    IF best_volume = 0 THEN
    /select_best_volume/
      FOR volume_index := 1 TO UPPERBOUND (dest_volume_list_p^) DO
        IF NOT (fmd_header.requested_class IN dest_volume_list_p^ [volume_index]^.ms_class) THEN
          CYCLE /select_best_volume/;
        IFEND;

        IF remaining_space_to_allocate > dest_volume_list_p^ [volume_index]^.mass_storage_available THEN
          remaining_space_to_allocate := remaining_space_to_allocate -
                dest_volume_list_p^ [volume_index]^.mass_storage_available;
        ELSE
          remaining_space_to_allocate := 0;
        IFEND;

        IF dest_volume_list_p^ [volume_index]^.mass_storage_available >= most_space_available THEN
          most_space_available := dest_volume_list_p^ [volume_index]^.mass_storage_available;
          best_volume := volume_index;
        IFEND;
      FOREND /select_best_volume/;
    IFEND;

    IF (remaining_space_to_allocate > 0) OR ((NOT move_object_info_p^.volume_overflow_allowed) AND
          (file_info.total_allocated_length > most_space_available)) THEN
      move_object_info_p^.move_status.move_successful := FALSE;
      move_object_info_p^.move_status.reason_for_move_failure := pfc$insufficient_space;
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_insufficient_space, class_string,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, move_object_info_p^.set_name, status);
      IF p_cycle_number = NIL THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'catalog', status);
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_fs_path^ (1, fs_path_size), status);
      ELSE
        osp$append_status_parameter (osc$status_parameter_delimiter, 'file', status);
        PUSH p_path_string;
        pfp$convert_cycle_path_to_strng (path, p_cycle_number^, p_path_string^);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              p_path_string^.value (1, p_path_string^.size), status);
      IFEND;
      RETURN;
    IFEND;

    mass_storage_request_info.allocation_size := fmd_header.requested_allocation_size;
    mass_storage_request_info.estimated_file_size := rmc$unspecified_file_size;
    mass_storage_request_info.mass_storage_class := fmd_header.requested_class;
    mass_storage_request_info.initial_volume := dest_volume_list_p^ [best_volume]^.recorded_vsn;
    mass_storage_request_info.transfer_size := fmd_header.requested_transfer_size;
    mass_storage_request_info.volume_overflow_allowed := fmd_header.overflow_allowed;
    IF NOT move_object_info_p^.volume_overflow_allowed THEN
      mass_storage_request_info.volume_overflow_allowed := FALSE;
    IFEND;
    mass_storage_request_info.user_privilege := rmc$system_user;
    mass_storage_request_info.maintenance_job := FALSE;

  PROCEND select_volume;

?? OLDTITLE ??
?? NEWTITLE := ' simulate_move_object', EJECT ??

  PROCEDURE simulate_move_object
    (    path: pft$complete_path;
         p_cycle_number: ^pft$cycle_number,
         fmd_header: pft$fmd_header;
         old_subfile_list: pft$subfile_list;
         file_info: dmt$file_information;
         move_object_info_p: ^pft$move_object_info;
     VAR status: ost$status);

    VAR
      best_volume: ost$non_negative_integers,
      class_string: string(1),
      current_byte_address: amt$file_byte_address,
      dest_volume_list_p: ^pft$mo_volume_list_p,
      fs_path_size: fst$path_size,
      most_space_available: ost$non_negative_integers,
      new_subfile_count: ost$non_negative_integers,
      new_subfile_list_p: ^pft$subfile_list,
      p_fs_path: ^fst$path,
      p_path_string: ^ost$string,
      remaining_space_to_allocate: ost$non_negative_integers,
      subfile_index: ost$positive_integers,
      temp_subfile_list_p: ^pft$subfile_list,
      volume_index: ost$positive_integers;

    status.normal := TRUE;
    move_object_info_p^.move_status.move_successful := FALSE;
    class_string := fmd_header.requested_class;
    current_byte_address := 0;
    new_subfile_count := 0;
    remaining_space_to_allocate := file_info.total_allocated_length;
    dest_volume_list_p := move_object_info_p^.dest_volume_list_p;
    PUSH new_subfile_list_p: [1 .. UPPERBOUND (dest_volume_list_p^)];

  /simulate_allocation/
    BEGIN

    /allocate_space/
      WHILE remaining_space_to_allocate > 0 DO

        best_volume := 0;
        most_space_available := 0;
      /select_best_volume/
        FOR volume_index := 1 TO UPPERBOUND (dest_volume_list_p^) DO
          IF NOT (fmd_header.requested_class IN dest_volume_list_p^ [volume_index]^.ms_class) THEN
            CYCLE /select_best_volume/;
          IFEND;
          IF dest_volume_list_p^ [volume_index]^.mass_storage_available > most_space_available THEN
            most_space_available := dest_volume_list_p^ [volume_index]^.mass_storage_available;
            best_volume := volume_index;
          IFEND;
        FOREND /select_best_volume/;

        IF (most_space_available = 0) OR
              ((p_cycle_number = NIL) AND (remaining_space_to_allocate > most_space_available)) OR
              ((NOT move_object_info_p^.volume_overflow_allowed) AND (new_subfile_count = 0) AND
              (remaining_space_to_allocate > most_space_available)) THEN
          move_object_info_p^.move_status.reason_for_move_failure := pfc$insufficient_space;
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_insufficient_space, class_string,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, move_object_info_p^.set_name, status);
          IF p_cycle_number = NIL THEN
            osp$append_status_parameter (osc$status_parameter_delimiter, 'catalog', status);
            PUSH p_fs_path;
            pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  p_fs_path^ (1, fs_path_size), status);
          ELSE
            osp$append_status_parameter (osc$status_parameter_delimiter, 'file', status);
            PUSH p_path_string;
            pfp$convert_cycle_path_to_strng (path, p_cycle_number^, p_path_string^);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  p_path_string^.value (1, p_path_string^.size), status);
          IFEND;
          EXIT /simulate_allocation/;
        IFEND;

        IF best_volume > 0 THEN
          new_subfile_count := new_subfile_count + 1;
          new_subfile_list_p^ [new_subfile_count].recorded_vsn :=
                dest_volume_list_p^ [best_volume]^.recorded_vsn;
          new_subfile_list_p^ [new_subfile_count].byte_address := current_byte_address;

          IF remaining_space_to_allocate > most_space_available THEN
            new_subfile_list_p^ [new_subfile_count].allocated_length := most_space_available;
            current_byte_address := current_byte_address + most_space_available;
            remaining_space_to_allocate := remaining_space_to_allocate - most_space_available;
            dest_volume_list_p^ [best_volume]^.mass_storage_available :=
                  dest_volume_list_p^ [best_volume]^.mass_storage_available - most_space_available;
          ELSE
            new_subfile_list_p^ [new_subfile_count].allocated_length :=
                  file_info.total_allocated_length - current_byte_address;
            dest_volume_list_p^ [best_volume]^.mass_storage_available :=
                  dest_volume_list_p^ [best_volume]^.mass_storage_available -
                  new_subfile_list_p^ [new_subfile_count].allocated_length;
            remaining_space_to_allocate := 0;
          IFEND;
        IFEND;

      WHILEND /allocate_space/;

    /return_old_subfiles/
      FOR subfile_index := 1 TO UPPERBOUND(old_subfile_list) DO
        FOR volume_index := 1 TO UPPERBOUND (move_object_info_p^.set_volume_list_p^) DO
          IF move_object_info_p^.set_volume_list_p^ [volume_index].recorded_vsn =
                old_subfile_list [subfile_index].recorded_vsn THEN
            move_object_info_p^.set_volume_list_p^ [volume_index].mass_storage_available :=
                  move_object_info_p^.set_volume_list_p^ [volume_index].mass_storage_available +
                  old_subfile_list [subfile_index].allocated_length;
            CYCLE /return_old_subfiles/;
          IFEND;
        FOREND;
      FOREND /return_old_subfiles/;

      NEXT temp_subfile_list_p: [1 .. new_subfile_count] IN
            move_object_info_p^.move_status.volume_list_storage_p;
      IF temp_subfile_list_p = NIL THEN
        IF p_cycle_number = NIL THEN
          PUSH p_fs_path;
          pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_subfile_list_seq_size, 'catalog',
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_fs_path^ (1, fs_path_size), status);
        ELSE
          PUSH p_path_string;
          pfp$convert_cycle_path_to_strng (path, p_cycle_number^, p_path_string^);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$movc_subfile_list_seq_size, 'file',
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                p_path_string^.value (1, p_path_string^.size), status);
        IFEND;
        EXIT /simulate_allocation/;
      ELSE
        move_object_info_p^.move_status.new_subfile_list_p := temp_subfile_list_p;
      IFEND;

      FOR subfile_index := 1 TO new_subfile_count DO
        move_object_info_p^.move_status.new_subfile_list_p^ [subfile_index] :=
              new_subfile_list_p^ [subfile_index];
      FOREND;

      move_object_info_p^.move_status.move_successful := TRUE;
      move_object_info_p^.move_status.allocated_size := file_info.total_allocated_length;
      move_object_info_p^.move_status.data_residence := pfc$unreleasable_data;
      move_object_info_p^.move_status.ms_class := fmd_header.requested_class;

    END /simulate_allocation/;

    IF NOT status.normal AND (new_subfile_count > 0) THEN
    /return_allocated_space/
      FOR subfile_index := 1 TO new_subfile_count DO
        FOR volume_index := 1 TO UPPERBOUND (dest_volume_list_p^) DO
          IF dest_volume_list_p^ [volume_index]^.recorded_vsn =
                new_subfile_list_p^ [subfile_index].recorded_vsn THEN
            dest_volume_list_p^ [volume_index]^.mass_storage_available :=
                  dest_volume_list_p^ [volume_index]^.mass_storage_available +
                  new_subfile_list_p^ [subfile_index].allocated_length;
            CYCLE /return_allocated_space/;
          IFEND;
        FOREND;
      FOREND /return_allocated_space/;
    IFEND;

  PROCEND simulate_move_object;

?? OLDTITLE ??
?? NEWTITLE := ' update_available_space_info', EJECT ??

  PROCEDURE update_available_space_info
    (    move_object_info_p: ^pft$move_object_info;
     VAR status: ost$status);

    VAR
      i: integer,
      mass_storage_available: integer;

    IF move_object_info_p = NIL THEN
      RETURN;
    IFEND;

    IF move_object_info_p^.set_volume_list_p = NIL THEN
      RETURN;
    IFEND;

    IF move_object_info_p^.perform_move THEN
      FOR i := 1 TO UPPERBOUND (move_object_info_p^.set_volume_list_p^) DO
        IF move_object_info_p^.set_volume_list_p^[i].available THEN
          dmp$calculate_remaining_space (move_object_info_p^.set_volume_list_p^ [i].logical_unit_number,
                mass_storage_available, status);
          IF status.normal THEN
            move_object_info_p^.set_volume_list_p^ [i].mass_storage_available := mass_storage_available;
          ELSE
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;

    move_object_info_p^.update_available_space_total := 0;

  PROCEND update_available_space_info;

?? OLDTITLE ??
?? NEWTITLE := ' update_move_object_info', EJECT ??

  PROCEDURE update_move_object_info
    (    move_object_info_p: ^pft$move_object_info;
         object_type: pft$object_types;
         fmd_header: pft$fmd_header;
         p_old_subfile_list: ^pft$subfile_list;
         p_new_subfile_list: ^pft$subfile_list;
         file_info: dmt$file_information;
         destination_file_info: dmt$file_information;
     VAR status: ost$status);

    CONST
      allocation_unit = 16384,
      fudge_factor = 4 * allocation_unit;

    VAR
      subfile_index: ost$positive_integers,
      volume_index: ost$positive_integers;

    status.normal := TRUE;

    IF move_object_info_p = NIL THEN
      RETURN;
    IFEND;

  /update_info/
    BEGIN
      IF move_object_info_p^.move_status.move_successful AND
            (move_object_info_p^.move_status.data_residence = pfc$offline_data) THEN
        move_object_info_p^.overall_statistics.cycles_released :=
              move_object_info_p^.overall_statistics.cycles_released + 1;
        move_object_info_p^.overall_statistics.bytes_released :=
              move_object_info_p^.overall_statistics.bytes_released + file_info.total_allocated_length;

        FOR subfile_index := 1 TO UPPERBOUND (p_old_subfile_list^) DO

        /update_released_info/
          FOR volume_index := 1 TO UPPERBOUND (move_object_info_p^.set_volume_list_p^) DO
            IF move_object_info_p^.set_volume_list_p^ [volume_index].recorded_vsn =
                  p_old_subfile_list^ [subfile_index].recorded_vsn THEN
              move_object_info_p^.set_volume_list_p^ [volume_index].bytes_released :=
                    move_object_info_p^.set_volume_list_p^ [volume_index].bytes_released +
                    p_old_subfile_list^ [subfile_index].allocated_length;

              IF subfile_index = 1 THEN
                move_object_info_p^.set_volume_list_p^ [volume_index].cycles_released :=
                      move_object_info_p^.set_volume_list_p^ [volume_index].cycles_released + 1;
              IFEND;
              EXIT /update_released_info/;
            IFEND;
          FOREND /update_released_info/;
        FOREND;
        IF fmd_header.requested_class <> rmc$unspecified_file_class THEN
          move_object_info_p^.class_statistics [fmd_header.requested_class].cycles_released :=
                move_object_info_p^.class_statistics [fmd_header.requested_class].cycles_released + 1;
          move_object_info_p^.class_statistics [fmd_header.requested_class].bytes_released :=
                move_object_info_p^.class_statistics [fmd_header.requested_class].bytes_released +
                file_info.total_allocated_length;
        IFEND;

        EXIT /update_info/;
      IFEND;

      IF move_object_info_p^.move_status.move_successful THEN
        move_object_info_p^.overall_statistics.objects_moved :=
              move_object_info_p^.overall_statistics.objects_moved + 1;

        move_object_info_p^.overall_statistics.bytes_moved :=
              move_object_info_p^.overall_statistics.bytes_moved +
              destination_file_info.total_allocated_length;

        move_object_info_p^.update_available_space_total :=
              move_object_info_p^.update_available_space_total + destination_file_info.total_allocated_length;

        FOR subfile_index := 1 TO UPPERBOUND (p_old_subfile_list^) DO

        /update_old_subfile_info/
          FOR volume_index := 1 TO UPPERBOUND (move_object_info_p^.set_volume_list_p^) DO
            IF move_object_info_p^.set_volume_list_p^ [volume_index].recorded_vsn =
                  p_old_subfile_list^ [subfile_index].recorded_vsn THEN
              move_object_info_p^.set_volume_list_p^ [volume_index].bytes_moved_from :=
                    move_object_info_p^.set_volume_list_p^ [volume_index].bytes_moved_from +
                    p_old_subfile_list^ [subfile_index].allocated_length;

              IF move_object_info_p^.move_bytes_threshold > 0 THEN
                IF move_object_info_p^.set_volume_list_p^ [volume_index].bytes_moved_from >=
                      (move_object_info_p^.move_bytes_threshold - fudge_factor) THEN
                  move_object_info_p^.set_volume_list_p^ [volume_index].move_bytes_threshold_exceeded := TRUE;
                IFEND;
              IFEND;

              IF subfile_index = 1 THEN
                IF object_type = pfc$catalog_object THEN
                  move_object_info_p^.set_volume_list_p^ [volume_index].catalogs_moved_from :=
                        move_object_info_p^.set_volume_list_p^ [volume_index].catalogs_moved_from + 1;
                ELSE
                  move_object_info_p^.set_volume_list_p^ [volume_index].cycles_moved_from :=
                        move_object_info_p^.set_volume_list_p^ [volume_index].cycles_moved_from + 1;
                IFEND;
              IFEND;
              EXIT /update_old_subfile_info/;
            IFEND;
          FOREND /update_old_subfile_info/;
        FOREND;

        FOR subfile_index := 1 TO UPPERBOUND (p_new_subfile_list^) DO

        /update_new_subfile_info/
          FOR volume_index := 1 TO UPPERBOUND (move_object_info_p^.set_volume_list_p^) DO
            IF move_object_info_p^.set_volume_list_p^ [volume_index].recorded_vsn =
                  p_new_subfile_list^ [subfile_index].recorded_vsn THEN
              move_object_info_p^.set_volume_list_p^ [volume_index].bytes_moved_to :=
                    move_object_info_p^.set_volume_list_p^ [volume_index].bytes_moved_to +
                    p_new_subfile_list^ [subfile_index].allocated_length;

              IF subfile_index = 1 THEN
                IF object_type = pfc$catalog_object THEN
                  move_object_info_p^.set_volume_list_p^ [volume_index].catalogs_moved_to :=
                        move_object_info_p^.set_volume_list_p^ [volume_index].catalogs_moved_to + 1;
                ELSE
                  move_object_info_p^.set_volume_list_p^ [volume_index].cycles_moved_to :=
                        move_object_info_p^.set_volume_list_p^ [volume_index].cycles_moved_to + 1;
                IFEND;
              IFEND;
              EXIT /update_new_subfile_info/;
            IFEND;
          FOREND /update_new_subfile_info/;
        FOREND;

        move_object_info_p^.class_statistics [fmd_header.requested_class].objects_moved :=
              move_object_info_p^.class_statistics [fmd_header.requested_class].objects_moved + 1;
        move_object_info_p^.class_statistics [fmd_header.requested_class].bytes_moved :=
              move_object_info_p^.class_statistics [fmd_header.requested_class].bytes_moved +
              file_info.total_allocated_length;

      ELSE

        CASE move_object_info_p^.move_status.reason_for_move_failure OF
        = pfc$cycle_busy =
          move_object_info_p^.overall_statistics.objects_not_moved :=
                move_object_info_p^.overall_statistics.objects_not_moved + 1;
          move_object_info_p^.overall_statistics.cycle_busy :=
                move_object_info_p^.overall_statistics.cycle_busy + 1;
        = pfc$insufficient_space =
          move_object_info_p^.overall_statistics.objects_not_moved :=
                move_object_info_p^.overall_statistics.objects_not_moved + 1;
          move_object_info_p^.overall_statistics.insufficient_space :=
                move_object_info_p^.overall_statistics.insufficient_space + 1;
        = pfc$no_available_space =
          move_object_info_p^.overall_statistics.objects_not_moved :=
                move_object_info_p^.overall_statistics.objects_not_moved + 1;
          move_object_info_p^.overall_statistics.no_available_space :=
                move_object_info_p^.overall_statistics.no_available_space + 1;
        = pfc$io_error =
          move_object_info_p^.overall_statistics.objects_not_moved :=
                move_object_info_p^.overall_statistics.objects_not_moved + 1;
          move_object_info_p^.overall_statistics.unrecovered_read_error :=
                move_object_info_p^.overall_statistics.unrecovered_read_error + 1;
        = pfc$data_released =
          move_object_info_p^.overall_statistics.cycles_released :=
                move_object_info_p^.overall_statistics.cycles_released + 1;
        = pfc$unexpected_abort =
          move_object_info_p^.overall_statistics.objects_not_moved :=
                move_object_info_p^.overall_statistics.objects_not_moved + 1;
          move_object_info_p^.overall_statistics.abnormal_status :=
                move_object_info_p^.overall_statistics.abnormal_status + 1;
        ELSE
        CASEND;

        IF fmd_header.requested_class <> rmc$unspecified_file_class THEN

          CASE move_object_info_p^.move_status.reason_for_move_failure OF
          = pfc$cycle_busy =
            move_object_info_p^.class_statistics [fmd_header.requested_class].objects_not_moved :=
                  move_object_info_p^.class_statistics [fmd_header.requested_class].objects_not_moved + 1;
            move_object_info_p^.class_statistics [fmd_header.requested_class].cycle_busy :=
                  move_object_info_p^.class_statistics [fmd_header.requested_class].cycle_busy + 1;
          = pfc$insufficient_space =
            move_object_info_p^.class_statistics [fmd_header.requested_class].objects_not_moved :=
                  move_object_info_p^.class_statistics [fmd_header.requested_class].objects_not_moved + 1;
            move_object_info_p^.class_statistics [fmd_header.requested_class].insufficient_space :=
                  move_object_info_p^.class_statistics [fmd_header.requested_class].insufficient_space + 1;
          = pfc$no_available_space =
            move_object_info_p^.class_statistics [fmd_header.requested_class].objects_not_moved :=
                  move_object_info_p^.class_statistics [fmd_header.requested_class].objects_not_moved + 1;
            move_object_info_p^.class_statistics [fmd_header.requested_class].no_available_space :=
                  move_object_info_p^.class_statistics [fmd_header.requested_class].no_available_space + 1;
          = pfc$io_error =
            move_object_info_p^.class_statistics [fmd_header.requested_class].objects_not_moved :=
                  move_object_info_p^.class_statistics [fmd_header.requested_class].objects_not_moved + 1;
            move_object_info_p^.class_statistics [fmd_header.requested_class].unrecovered_read_error :=
                  move_object_info_p^.class_statistics [fmd_header.requested_class].unrecovered_read_error +
                  1;
          = pfc$data_released =
            move_object_info_p^.class_statistics [fmd_header.requested_class].cycles_released :=
                  move_object_info_p^.class_statistics [fmd_header.requested_class].cycles_released + 1;
          = pfc$unexpected_abort =
            move_object_info_p^.class_statistics [fmd_header.requested_class].objects_not_moved :=
                  move_object_info_p^.class_statistics [fmd_header.requested_class].objects_not_moved + 1;
            move_object_info_p^.class_statistics [fmd_header.requested_class].abnormal_status :=
                  move_object_info_p^.class_statistics [fmd_header.requested_class].abnormal_status + 1;
          ELSE
          CASEND;
        IFEND;
      IFEND;
    END /update_info/;

    IF move_object_info_p^.update_available_space_total > pfc$update_device_info_limit THEN
      update_available_space_info (move_object_info_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND update_move_object_info;

?? OLDTITLE ??
?? NEWTITLE := ' validate_volume_threshold', EJECT ??

  PROCEDURE validate_volume_threshold
    (    move_object_info_p: ^pft$move_object_info);

    CONST
      allocation_unit = 16384,
      fudge_factor = 4 * allocation_unit;

    VAR
      set_threshold_exceeded: boolean,
      source_volume_p: ^pft$mo_volume,
      subfile_index: ost$positive_integers,
      volume_index: ost$positive_integers;

    IF move_object_info_p^.move_bytes_threshold = 0 THEN
      RETURN;
    IFEND;

    IF move_object_info_p^.move_status.old_subfile_list_p = NIL THEN
      RETURN;
    IFEND;

    IF move_object_info_p^.source_volume_list_p = NIL THEN
      RETURN;
    IFEND;

  /validate_threshold/
    FOR subfile_index := 1 TO UPPERBOUND (move_object_info_p^.move_status.old_subfile_list_p^) DO
      source_volume_p := NIL;

    /locate_source_volume/
      FOR volume_index := 1 TO UPPERBOUND (move_object_info_p^.source_volume_list_p^) DO
        IF move_object_info_p^.source_volume_list_p^ [volume_index]^.recorded_vsn =
              move_object_info_p^.move_status.old_subfile_list_p^ [subfile_index].recorded_vsn THEN
          source_volume_p := move_object_info_p^.source_volume_list_p^ [volume_index];
          EXIT /locate_source_volume/;
        IFEND;
      FOREND /locate_source_volume/;

      IF source_volume_p <> NIL THEN
        IF source_volume_p^.bytes_moved_from > move_object_info_p^.move_bytes_threshold THEN
          move_object_info_p^.move_status.move_successful := FALSE;
          move_object_info_p^.move_status.reason_for_move_failure := pfc$volume_threshold_exceeded;
          EXIT /validate_threshold/;
        IFEND;

        IF (move_object_info_p^.move_status.old_subfile_list_p^ [subfile_index].allocated_length +
              source_volume_p^.bytes_moved_from) > (move_object_info_p^.move_bytes_threshold + fudge_factor)
              THEN
          move_object_info_p^.move_status.move_successful := FALSE;
          move_object_info_p^.move_status.reason_for_move_failure := pfc$volume_threshold_exceeded;
          EXIT /validate_threshold/;
        IFEND;
      IFEND;
    FOREND /validate_threshold/;

    IF move_object_info_p^.move_status.reason_for_move_failure = pfc$volume_threshold_exceeded THEN
      set_threshold_exceeded := TRUE;

    /locate_threshold/
      FOR volume_index := 1 TO UPPERBOUND (move_object_info_p^.source_volume_list_p^) DO
        IF NOT move_object_info_p^.source_volume_list_p^ [volume_index]^.move_bytes_threshold_exceeded THEN
          set_threshold_exceeded := FALSE;
          EXIT /locate_threshold/;
        IFEND;
      FOREND /locate_threshold/;

      IF set_threshold_exceeded THEN
        move_object_info_p^.move_status.move_successful := FALSE;
        move_object_info_p^.move_status.reason_for_move_failure := pfc$set_threshold_exceeded;
      IFEND;
    IFEND;

  PROCEND validate_volume_threshold;

?? OLDTITLE ??
?? NEWTITLE := ' verify_volume_residence', EJECT ??

  PROCEDURE verify_volume_residence
    (    sfid: gft$system_file_identifier;
         volume_list_p: ^pft$mo_volume_list_p;
     VAR resides_on_volumes: boolean;
     VAR status: ost$status);


    VAR
      file_info: dmt$file_information,
      fmd_header: pft$fmd_header,
      p_physical_fmd: ^pft$physical_fmd,
      p_subfile_list: ^pft$subfile_list,
      stored_fmd_size: dmt$stored_fmd_size,
      subfile_index: ost$positive_integers,
      volume_index: ost$positive_integers;

    dmp$get_stored_fmd_size (sfid, stored_fmd_size, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$get_file_info (sfid, file_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_physical_fmd: [[REP stored_fmd_size OF cell]];
    dmp$get_stored_fmd (sfid, p_physical_fmd^.fmd, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    dmp$get_stored_fmd_header_info (^p_physical_fmd^.fmd, fmd_header, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_subfile_list: [1 .. fmd_header.number_of_subfiles];
    dmp$get_stored_fmd_subfile_list (^p_physical_fmd^.fmd, file_info.total_allocated_length,
          p_subfile_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    resides_on_volumes := TRUE;
  /check_subfiles/
    FOR subfile_index := 1 TO UPPERBOUND (p_subfile_list^) DO
      FOR volume_index := 1 TO UPPERBOUND (volume_list_p^) DO
        IF p_subfile_list^ [subfile_index].recorded_vsn =
              volume_list_p^ [volume_index]^.recorded_vsn THEN
          CYCLE /check_subfiles/;
        IFEND;
      FOREND;
      resides_on_volumes := FALSE;
      EXIT /check_subfiles/;
    FOREND /check_subfiles/;

  PROCEND verify_volume_residence;

MODEND pfm$r2_move_object;
*DECK DECK=PFM$R2_PUT_INFO EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Permanent Files : Put Info' ??
MODULE pfm$r2_put_info;

{ PURPOSE:
{   This module contains the procedures used to put backup information when
{   restoring from a backup file.  The information is of the format returned by
{   the permanent file 'get info' routines.

?? NEWTITLE := '  Global Declarations Referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$put_validation_errors
*copyc oss$job_paged_literal
*copyc pfd$catalog_access
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pft$auditable_cycles
*copyc pft$auditable_permits
*copyc pft$chosen_cycles
*copyc pft$family_location
*copyc pft$permit_level
*copyc pft$restore_catalog_status
*copyc pud$selection_criteria
*copyc std$set_name
*copyc ste$error_condition_codes
?? POP ??
?? EJECT ??
*copyc avp$security_option_active
*copyc dmp$attach_file
*copyc dmp$build_sorted_dfl
*copyc dmp$get_reconciled_fmd
*copyc dmp$reconcile_fmd
*copyc dmv$reconcile_locator
*copyc i#move
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$generate_unique_binary_name
*copyc osp$prevalidate_free
*copyc osp$recoverable_system_error
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc pfi$store_file_media_descriptor
*copyc pfp$access_last_object
*copyc pfp$access_next_catalog
*copyc pfp$access_object
*copyc pfp$allocate_archive_list
*copyc pfp$allocate_cycle_list
*copyc pfp$allocate_log_list
*copyc pfp$allocate_permit_list
*copyc pfp$attach_root_catalog
*copyc pfp$build_archive_entry
*copyc pfp$build_archive_list_locator
*copyc pfp$build_archive_list_pointer
*copyc pfp$build_cycle_list_locator
*copyc pfp$build_cycle_list_pointer
*copyc pfp$build_file_label_locator
*copyc pfp$build_fmd_locator
*copyc pfp$build_fmd_pointer
*copyc pfp$build_log_list_locator
*copyc pfp$build_log_list_pointer
*copyc pfp$build_mainfram_list_locator
*copyc pfp$build_object_list_locator
*copyc pfp$build_permit_list_locator
*copyc pfp$build_permit_list_pointer
*copyc pfp$check_archive_entries
*copyc pfp$check_group_by_permit_level
*copyc pfp$compute_checksum
*copyc pfp$convert_archive_ident
*copyc pfp$convert_device_class_to_pf
*copyc pfp$convert_device_class_to_rm
*copyc pfp$convert_pf_path_to_fs_path
*copyc pfp$create_catalog
*copyc pfp$create_catalog_object
*copyc pfp$create_file_object
*copyc pfp$destroy_catalog
*copyc pfp$detach_permanent_file
*copyc pfp$determine_new_cycle_number
*copyc pfp$establish_free_cycle_entry
*copyc pfp$find_archive_info
*copyc pfp$find_catalog_description
*copyc pfp$find_catalog_media
*copyc pfp$find_cycle_array
*copyc pfp$find_cycle_array_extended
*copyc pfp$find_cycle_array_version_2
*copyc pfp$find_cycle_directory
*copyc pfp$find_cycle_label
*copyc pfp$find_cycle_media
*copyc pfp$find_direct_info_record
*copyc pfp$find_file_description
*copyc pfp$find_log_array
*copyc pfp$find_next_archive_entry
*copyc pfp$find_next_info_record
*copyc pfp$find_permit_array
*copyc pfp$get_authority
*copyc pfp$get_catalog
*copyc pfp$locate_cycle
*copyc pfp$locate_group_info_record
*copyc pfp$locate_object
*copyc pfp$locate_specific_cycle
*copyc pfp$log_ascii
*copyc pfp$log_path
*copyc pfp$process_unexpected_status
*copyc pfp$record_dm_file_parameters
*copyc pfp$release_locked_apfid
*copyc pfp$report_invalid_free
*copyc pfp$report_system_error
*copyc pfp$return_catalog
*copyc pfp$set_status_abnormal
*copyc pfp$shared_queue
*copyc pfp$validate_default_password
*copyc pfp$validate_family_ownership
*copyc pfp$validate_file_permission
*copyc pfp$validate_ownership
*copyc pfv$family_administrator
*copyc pfv$locked_apfid
*copyc pfv$null_catalog_entry_space
*copyc pfv$null_cycle_entry_space
*copyc pfv$null_date_time
*copyc pfv$null_file_entry_space
*copyc pfv$null_object_entry_space
*copyc pfv$system_administrator
*copyc pfv$task_family
*copyc pfv$task_user
*copyc pfv$unattached_status
*copyc pmp$continue_to_cause
*copyc pmp$date_time_compare
*copyc sfp$emit_audit_statistic
*copyc sfp$get_job_limit
*copyc sfv$dynamic_file_space_limits
*copyc stp$get_root_recreated
*copyc stv$system_set_name
*copyc syp$pop_inhibit_job_recovery
*copyc syp$push_inhibit_job_recovery

?? TITLE := '  Global Declarations Declared by this module', EJECT ??

  CONST
    include_radix = TRUE,
    radix = 10;

  VAR
    pfv$null_unique_name: [XDCL, oss$job_paged_literal, READ] ost$binary_unique_name :=
         [0, 0, 1980, 1, 1, 0, 0, 0, 0, 0];

  VAR
    cycle_array_entry_version_2: [oss$job_paged_literal, READ] pft$cycle_array_entry_version_2 :=
          [0, $fst$cycle_damage_symptoms [], *, *, *, pfc$unreleasable_data, rmc$mass_storage_device, 0, *,
          *, FALSE, [FALSE], [FALSE], pfc$always_retrieve, pfc$null_site_backup_option,
          pfc$null_site_archive_option, pfc$null_site_release_option, [REP 46 OF FALSE]];

?? TITLE := '  [XDCL, #GATE] pfp$r2_build_archive_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_build_archive_entry (
        archive_identification: pft$archive_identification;
        p_archive_array_entry: pft$p_archive_array_entry;
        p_amd: pft$p_amd;
        p_catalog_file: pft$p_catalog_file;
        p_archive: pft$p_archive;
    VAR status: ost$status);

    VAR
      p_physical_amd: pft$p_physical_amd;

    ALLOCATE p_physical_amd: [[REP #SIZE(p_amd^) of cell]] IN p_catalog_file^.catalog_heap;
    IF p_physical_amd = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, '', status);
      RETURN;
    IFEND;

    p_physical_amd^.amd := p_amd^;

    pfp$build_archive_entry (archive_identification, p_archive_array_entry, p_physical_amd,
        p_catalog_file, p_archive, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND pfp$r2_build_archive_entry;

?? TITLE := '  [XDCL, #GATE] pfp$r2_build_sorted_dfl', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_build_sorted_dfl
    (VAR status: ost$status);

    dmp$build_sorted_dfl (stv$system_set_name, dmv$reconcile_locator, status);

  PROCEND pfp$r2_build_sorted_dfl;

?? TITLE := '  [XDCL, #GATE] pfp$r2_put_archive_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_put_archive_entry (
        path: pft$complete_path;
        cycle_selector: pft$cycle_selector;
        archive_identification: pft$archive_identification;
        p_archive_array_entry: pft$p_archive_array_entry;
        p_amd: pft$p_amd;
    VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_put_archive_entry;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      archive_index: pft$archive_index,
      archive_list_locator: pft$archive_list_locator,
      authority: pft$authority,
      catalog_locator: pft$catalog_locator,
      local_status: ost$status,
      p_cycle_list: ^pft$cycle_list,
      p_internal_path: ^pft$internal_path,
      p_new_archive_list: ^pft$archive_list,
      p_old_archive_list: ^pft$archive_list,
      p_physical_cycle: ^pft$physical_cycle,
      p_physical_file_object: ^pft$physical_object,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      prevalidate_free_result: ost$prevalidate_free_result,
      process_non_local_exit: boolean,
      valid_archive_entry_exists: boolean;

    syp$push_inhibit_job_recovery;
    process_non_local_exit := FALSE;
    #SPOIL (process_non_local_exit);

    pfp$get_authority (path, NOT system_privilege, authority, status);
    IF status.normal THEN
      pfp$validate_ownership (authority, path, status);
    IFEND;

    IF status.normal THEN
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$file_object],
            parent_charge_id, catalog_locator, p_physical_file_object, p_internal_path^, permit_entry,
            status);
    IFEND;

    IF status.normal THEN
      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);
      pfp$build_cycle_list_pointer (p_physical_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_physical_cycle, status);

      IF status.normal THEN
        archive_list_locator := p_physical_cycle^.cycle_entry.archive_list_locator;
        pfp$build_archive_list_pointer (archive_list_locator, catalog_locator.p_catalog_file,
              p_old_archive_list);
        pfp$allocate_archive_list (archive_list_locator.archive_count + 1,
              ^catalog_locator.p_catalog_file^.catalog_heap, p_new_archive_list, status);
      IFEND;

      IF status.normal THEN
        pfp$r2_build_archive_entry (archive_identification, p_archive_array_entry, p_amd,
              catalog_locator.p_catalog_file, ^p_new_archive_list^ [1], status);

        IF status.normal THEN
          IF archive_list_locator.archive_count <> 0 THEN
            FOR archive_index := 1 TO archive_list_locator.archive_count DO
               p_new_archive_list^ [archive_index +1] := p_old_archive_list^ [archive_index];
            FOREND;
            osp$prevalidate_free ((#OFFSET(p_old_archive_list) -
                  #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
                  ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
            IF prevalidate_free_result = osc$heap_free_valid THEN
              FREE p_old_archive_list IN catalog_locator.p_catalog_file^.catalog_heap;
            ELSE
              pfp$report_invalid_free (^path, ^p_physical_cycle^.cycle_entry.cycle_number, 'ARCHIVE_LIST',
                    'file', prevalidate_free_result, #OFFSET(p_old_archive_list));
              p_old_archive_list := NIL;
            IFEND;
          IFEND;

          pfp$build_archive_list_locator (p_new_archive_list, catalog_locator.p_catalog_file,
                archive_list_locator);
          p_physical_cycle^.cycle_entry.archive_list_locator := archive_list_locator;
          pfp$check_archive_entries (catalog_locator.p_catalog_file, p_physical_cycle,
                valid_archive_entry_exists, status);

          IF status.normal AND valid_archive_entry_exists AND
                (p_physical_cycle^.cycle_entry.fmd_locator.fmd_size <> 0) THEN
            p_physical_cycle^.cycle_entry.data_residence := pfc$releasable_data;
          IFEND;

          pfp$compute_checksum (#LOC (p_physical_cycle^.cycle_entry), #SIZE (pft$cycle_entry),
                p_physical_cycle^.checksum);
        ELSE
          osp$prevalidate_free ((#OFFSET(p_new_archive_list) -
                #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
                ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_new_archive_list IN catalog_locator.p_catalog_file^.catalog_heap;
          ELSE
            pfp$report_invalid_free (^path, ^p_physical_cycle^.cycle_entry.cycle_number, 'ARCHIVE_LIST',
                  'file', prevalidate_free_result, #OFFSET(p_new_archive_list));
            p_new_archive_list := NIL;
          IFEND;
        IFEND;
      IFEND;

      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_put_archive_entry;

?? TITLE := '  [XDCL, #GATE] pfp$r2_put_archive_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_put_archive_info (
        path: pft$complete_path;
        cycle_selector: pft$cycle_selector;
        p_cycle_info_record: pft$p_info_record;
    VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_put_archive_info;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_locator: pft$catalog_locator,
      local_status: ost$status,
      p_cycle_list: ^pft$cycle_list,
      p_internal_path: ^pft$internal_path,
      p_physical_file_object: ^pft$physical_object,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;
    process_non_local_exit := FALSE;
    #SPOIL (process_non_local_exit);

    pfp$get_authority (path, NOT system_privilege, authority, status);
    IF status.normal THEN
      pfp$validate_ownership (authority, path, status);
    IFEND;

    IF status.normal THEN
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$file_object],
            parent_charge_id, catalog_locator, p_physical_file_object, p_internal_path^, permit_entry,
            status);
    IFEND;

    IF status.normal THEN
      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);
      pfp$build_cycle_list_pointer (p_physical_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      put_cycle_archive_info (catalog_locator.p_catalog_file, p_cycle_list, cycle_selector, path,
            p_cycle_info_record, status);

      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_put_archive_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_put_catalog_media_info', EJECT ??
{ DESIGN:
{   This procedure restores the catalog information under the following rules:
{
{   CONDITIONS:
{     catalog registered               T   T   F   F
{     registered catalog on-line       T   F
{     parent re-created                        T   T
{     backup catalog on-line                   T   F
{   ACTIONS:
{     re-create catalog media              X       X
{     no change                        X
{     store backup fmd                         X
{     put catalog info (permits etc)           X   X

  PROCEDURE [XDCL, #GATE] pfp$r2_put_catalog_media_info
    (    path: pft$complete_path;
         p_catalog_group: {input} pft$p_info_record;
     VAR restore_catalog_status: pft$restore_catalog_status;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_put_catalog_media_info;
    PROCEND initiate_non_local_exit;

    CONST
      family_location = pfc$local_mainframe,
      permit_level = pfc$pl_public;

    VAR
      all_permits_restored: boolean,
      audit_restorations: boolean,
      authority: pft$authority,
      catalog_locator: pft$catalog_locator,
      device_class: dmt$class,
      fmd_size: dmt$stored_fmd_size,
      local_status: ost$status,
      p_auditable_permits: ^pft$auditable_permits,
      p_backup_catalog_fmd: ^SEQ ( * ),
      p_backup_catalog_media_desc: ^pft$catalog_media_description,
      p_catalog_object: ^pft$physical_object,
      p_physical_fmd: ^pft$physical_fmd,
      parent_catalog_recreated: boolean,
      prevalidate_free_result: ost$prevalidate_free_result,
      process_non_local_exit: boolean,
      resides_on_system_device: boolean;

    process_non_local_exit := FALSE;
    #SPOIL (process_non_local_exit);

    IF dmv$reconcile_locator = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error, 'NIL reconcile locator',
            status);
      RETURN;
    IFEND;

    syp$push_inhibit_job_recovery;

    access_parent_and_object (path, $pft$object_selections [pfc$catalog_object, pfc$free_object], authority,
          parent_catalog_recreated, catalog_locator, p_catalog_object, status);
    IF status.normal THEN
      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);
      IF p_catalog_object^.object_entry.object_type = pfc$catalog_object THEN
        {
        { Catalog exists in parent.
        {
        IF p_catalog_object^.object_entry.catalog_object_locator.catalog_type = pfc$internal_catalog THEN
          restore_catalog_status := pfc$catalog_already_exists;
        ELSE
          pfp$build_fmd_pointer (p_catalog_object^.object_entry.catalog_object_locator.fmd_locator,
                catalog_locator.p_catalog_file, p_physical_fmd);
          dmp$reconcile_fmd (dmv$reconcile_locator,
                p_catalog_object^.object_entry.catalog_object_locator.global_file_name, p_physical_fmd^.fmd,
                {purge_file} FALSE, device_class, fmd_size, resides_on_system_device, status);
          IF status.normal THEN
            restore_catalog_status := pfc$catalog_already_exists;
          ELSE
            {
            { The catalog does not reconcile; re-create the catalog.
            {
            osp$prevalidate_free ((#OFFSET(p_physical_fmd) -
                  #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
                  ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
            IF prevalidate_free_result = osc$heap_free_valid THEN
              FREE p_physical_fmd IN catalog_locator.p_catalog_file^.catalog_heap;
            ELSE
              pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'FILE_MEDIA_DESCRIPTOR', 'catalog',
                    prevalidate_free_result, #OFFSET(p_physical_fmd));
              p_physical_fmd := NIL;
            IFEND;
            recreate_catalog_media (path, authority, catalog_locator.p_catalog_file, p_catalog_object,
                  status);
            restore_catalog_status := pfc$catalog_recreated;
          IFEND;
        IFEND;
      ELSE {free object}
        {
        { Catalog not found in parent and the parent was re-created.
        { Reconstruct the parent catalog's contents from the backup file.
        {
        pfp$find_catalog_media (p_catalog_group, p_backup_catalog_media_desc, p_backup_catalog_fmd, status);
        IF status.normal THEN
          IF p_backup_catalog_media_desc^.catalog_type = pfc$internal_catalog THEN
            audit_restorations := avp$security_option_active (avc$vso_security_audit);
            p_auditable_permits := NIL;
            put_catalog_info (p_catalog_group, family_location, path, authority, permit_level,
                  pfc$internal_catalog, {catalog_recreated} TRUE, catalog_locator.p_catalog_file,
                  p_catalog_object, audit_restorations, all_permits_restored, p_auditable_permits, status);
            restore_catalog_status := pfc$catalog_recreated;
          ELSE
            dmp$reconcile_fmd (dmv$reconcile_locator, p_backup_catalog_media_desc^.global_file_name,
                  p_backup_catalog_fmd^, {purge_file} FALSE, device_class, fmd_size, resides_on_system_device,
                  status);
            IF status.normal THEN
              {
              { Re-create the catalog entry and store the backed up fmd.
              {
              recreate_catalog_entry (p_catalog_group, path, authority.ownership, p_backup_catalog_media_desc,
                    p_backup_catalog_fmd, catalog_locator.p_catalog_file, p_catalog_object, status);
              restore_catalog_status := pfc$catalog_recovered;
            ELSE
              {
              { The catalog fmd from the backup file does not reconcile.
              { Re-create the catalog entry and the catalog itself.
              {
              { Note: This will restore deleted catalogs as the catalogs may
              { have moved since the backup.  This is unavoidable.
              {
              audit_restorations := avp$security_option_active (avc$vso_security_audit);
              p_auditable_permits := NIL;
              put_catalog_info (p_catalog_group, family_location, path, authority, permit_level,
                    pfc$external_catalog, {catalog_recreated} TRUE, catalog_locator.p_catalog_file,
                    p_catalog_object, audit_restorations, all_permits_restored, p_auditable_permits, status);
              restore_catalog_status := pfc$catalog_recreated;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_put_catalog_media_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_put_catalog_segment', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_put_catalog_segment
    (    path: pft$path;
         p_catalog_segment: ^SEQ ( * );
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_put_catalog_segment;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE,
      validation_ring_number = 2;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      catalog_segment_length: ost$segment_length,
      charge_id: pft$charge_id,
      local_status: ost$status,
      p_catalog_seq: ^SEQ ( * ),
      p_cell_array: ^array [1 .. * ] of cell,
      p_internal_path: ^pft$internal_path,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;

  /put_catalog_segment/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL(process_non_local_exit);

      pfp$get_authority (path, NOT system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /put_catalog_segment/;
      IFEND;

      pfp$validate_ownership (authority, path, status);
      IF NOT status.normal THEN
        EXIT /put_catalog_segment/;
      IFEND;

      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$get_catalog (path, pfc$write_access, authority, p_internal_path^, charge_id, permit_entry,
            catalog_locator, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /put_catalog_segment/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      catalog_segment_length := #SIZE (p_catalog_segment^);
      p_catalog_seq := #SEQ (catalog_locator.p_catalog_file^);
      NEXT p_cell_array: [1 .. catalog_segment_length] IN p_catalog_seq;
      IF p_cell_array = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$info_full, '', status);
      ELSE
        i#move (p_catalog_segment, p_cell_array, catalog_segment_length);
      IFEND;
    END /put_catalog_segment/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_put_catalog_segment;

?? TITLE := '  [XDCL, #GATE] pfp$r2_put_cycle_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_put_cycle_info
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         cycle_array_entry: pft$cycle_array_entry_version_2;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_put_cycle_info;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_locator: pft$catalog_locator,
      comparison_result: pmt$comparison_result,
      cycle_entry: pft$cycle_entry,
      cycle_list_locator: pft$cycle_list_locator,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      new_file_created: boolean,
      new_physical_file_object: pft$physical_object,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_fs_path: ^fst$path,
      p_internal_path: ^pft$internal_path,
      p_physical_file_object: ^pft$physical_object,
      parent_charge_id: pft$charge_id,
      password: pft$password,
      permit_entry: pft$permit_entry,
      pf_device_class: pft$device_class,
      pfs_limit: sft$limit,
      process_non_local_exit: boolean,
      task_charge_id: pft$charge_id,
      variant_path: pft$variant_path;

    syp$push_inhibit_job_recovery;
    process_non_local_exit := FALSE;
    #SPOIL (process_non_local_exit);

    pfp$get_authority (path, NOT system_privilege, authority, status);
    IF status.normal THEN
      IF (cycle_array_entry.device_class = rmc$magnetic_tape_device) AND
            (authority.ownership = $pft$ownership []) THEN
        variant_path.complete_path := TRUE;
        variant_path.p_complete_path := ^path;
        pfp$set_status_abnormal (variant_path, pfe$usage_not_permitted, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              '[READ] or [EXECUTE] or [SHORTEN] or [MODIFY] or [APPEND]', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, '[CYCLE] or [CONTROL]', status);
      IFEND;
    IFEND;

    IF status.normal THEN
      IF sfv$dynamic_file_space_limits AND (pfc$master_catalog_owner IN authority.ownership) THEN
        sfp$get_job_limit (avc$pfs_limit_name, pfs_limit, status);
        IF status.normal THEN
          IF pfs_limit.accumulator >= pfs_limit.job_abort_limit THEN
            osp$set_status_condition (ame$file_space_limit_exceeded, status);
            PUSH p_fs_path;
            pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
            osp$append_status_file (osc$status_parameter_delimiter, p_fs_path^ (1, fs_path_size), status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'Permanent', status);
          IFEND;
        ELSE
          status.normal := TRUE;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority,
            $pft$object_selections [pfc$free_object, pfc$file_object], parent_charge_id, catalog_locator,
            p_physical_file_object, p_internal_path^, permit_entry, status);
    IFEND;

    IF status.normal THEN
      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      {
      { Cycle permit is only verified for non owners.
      {

      IF authority.ownership = $pft$ownership [] THEN
        pfp$validate_file_permission (path, authority, permit_entry, $pft$permit_selections [pfc$cycle],
              - $pft$share_selections [], status);
      IFEND;

      IF status.normal THEN
        IF p_physical_file_object^.object_entry.object_type = pfc$file_object THEN
          new_file_created := FALSE;
          pfp$validate_default_password (path, authority, password_selector, p_physical_file_object, status);
        ELSE {pfc$free_object}
          {
          { Do not use the real file object, in case an error occurs in
          { create_cycle_entry.
          {
          task_charge_id.account := authority.account;
          task_charge_id.project := authority.project;
          IF password_selector.password_specified = pfc$default_password_option THEN
            password := osc$null_name;
          ELSE
            password := password_selector.password;
          IFEND;
          pfp$create_file_object (path [UPPERBOUND (path)], authority, task_charge_id, password, pfc$no_log,
                new_physical_file_object.object_entry);
          p_internal_path^ [UPPERBOUND (path)] := new_physical_file_object.object_entry.internal_object_name;
          {
          { The file object checksum will be computed in add_cycle_entry.
          {
          new_file_created := TRUE;
        IFEND;
      IFEND;

      IF status.normal THEN
        IF new_file_created THEN
          cycle_list_locator := new_physical_file_object.object_entry.cycle_list_locator;
        ELSE
          cycle_list_locator := p_physical_file_object^.object_entry.cycle_list_locator;
        IFEND;
        pfp$convert_device_class_to_pf (cycle_array_entry.device_class, pf_device_class);
        create_cycle_entry (path, cycle_list_locator, catalog_locator.p_catalog_file, cycle_selector,
              pf_device_class, cycle_array_entry.cycle_statistics,
              cycle_array_entry.data_modification_date_time, cycle_array_entry.expiration_date_time,
              cycle_array_entry.cycle_damage_symptoms, cycle_array_entry.shared_queue_info,
              cycle_array_entry.retrieve_option, cycle_array_entry.site_archive_option,
              cycle_array_entry.site_backup_option, cycle_array_entry.site_release_option,
              cycle_entry, status);
      IFEND;

      IF status.normal THEN
        IF new_file_created THEN
          p_physical_file_object^ := new_physical_file_object;
        IFEND;
        add_cycle_entry (^path, cycle_entry, p_physical_file_object, catalog_locator.p_catalog_file, status);
      ELSEIF status.condition = pfe$duplicate_cycle THEN
        pfp$build_cycle_list_pointer (p_physical_file_object^.object_entry.cycle_list_locator,
              catalog_locator.p_catalog_file, p_cycle_list);
        pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, local_status);
        IF local_status.normal THEN
          pmp$date_time_compare (p_cycle^.cycle_entry.cycle_statistics.modification_date_time,
                cycle_array_entry.cycle_statistics.modification_date_time, comparison_result, local_status);
          IF local_status.normal AND (comparison_result = pmc$equal) THEN
            p_cycle^.cycle_entry.retrieve_option := cycle_array_entry.retrieve_option;
            p_cycle^.cycle_entry.site_archive_option := cycle_array_entry.site_archive_option;
            p_cycle^.cycle_entry.site_backup_option := cycle_array_entry.site_backup_option;
            p_cycle^.cycle_entry.site_release_option := cycle_array_entry.site_release_option;
          IFEND;
          pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (p_cycle^.cycle_entry), p_cycle^.checksum);
          IF (p_cycle^.cycle_entry.data_residence = pfc$offline_data) AND
                (NOT ((pfc$system_owner IN authority.ownership) OR (pfc$family_owner IN authority.ownership)))
                THEN
            PUSH p_fs_path;
            pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$duplicate_offline_cycle,
                  p_fs_path^ (1, fs_path_size), status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  p_cycle^.cycle_entry.cycle_number, radix, NOT include_radix, status);
          IFEND;
        IFEND;
      IFEND;

      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_put_cycle_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_put_family_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_put_family_info
    (    set_name: stt$set_name;
         family_name: pft$name;
         p_info_record: {input} pft$p_info_record;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_put_family_info;
    PROCEND initiate_non_local_exit;

    CONST
      permit_level = pfc$pl_public;

    VAR
      all_permits_restored: boolean,
      audit_restorations: boolean,
      authority: pft$authority,
      catalog_locator: pft$catalog_locator,
      internal_path: array [1 .. pfc$family_path_index] of pft$internal_name,
      local_status: ost$status,
      p_auditable_permits: ^pft$auditable_permits,
      p_physical_object: ^pft$physical_object,
      parent_charge_id: pft$charge_id,
      path: array [1 .. pfc$family_path_index] of pft$name,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;

    path [pfc$set_path_index] := set_name;
    path [pfc$family_path_index] := family_name;
    process_non_local_exit := FALSE;
    #SPOIL (process_non_local_exit);

    pfp$get_authority (path, {system_privilege} FALSE, authority, status);
    IF status.normal THEN
      pfp$validate_family_ownership (family_name, authority, status);
    IFEND;

    IF status.normal THEN
      pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$free_object],
            parent_charge_id, catalog_locator, p_physical_object, internal_path, permit_entry, status);
    IFEND;

    IF status.normal THEN
      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);
      audit_restorations := avp$security_option_active (avc$vso_security_audit);
      p_auditable_permits := NIL;
      put_catalog_info (p_info_record, pfc$local_mainframe, path, authority, permit_level,
            pfc$internal_catalog, {catalog_recreated} FALSE, catalog_locator.p_catalog_file,
            p_physical_object, audit_restorations, all_permits_restored, p_auditable_permits, status);

      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_put_family_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_put_file_media_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_put_file_media_info
    (    path: pft$complete_path;
         p_file_group: {input} pft$p_info_record;
         backup_file_version: pft$backup_file_version;
     VAR file_entry_recreated: boolean;
     VAR cycles_restored_with_fmd: pft$cycle_count;
     VAR cycles_restored_without_fmd: pft$cycle_count;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_put_file_media_info;
    PROCEND initiate_non_local_exit;

    CONST
      permit_level = pfc$pl_public,
      restore_archive_information = TRUE;

    VAR
      all_permits_restored: boolean,
      audit_restorations: boolean,
      authority: pft$authority,
      catalog_locator: pft$catalog_locator,
      catalog_recreated: boolean,
      local_status: ost$status,
      p_auditable_cycles: ^pft$auditable_cycles,
      p_auditable_permits: ^pft$auditable_permits,
      p_file_object: ^pft$physical_object,
      process_non_local_exit: boolean,
      selection_criteria: put$selection_criteria;

    file_entry_recreated := FALSE;
    cycles_restored_with_fmd := 0;
    cycles_restored_without_fmd := 0;
    process_non_local_exit := FALSE;
    #SPOIL (process_non_local_exit);

    IF dmv$reconcile_locator = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error, 'NIL reconcile locator',
            status);
      RETURN;
    IFEND;

    syp$push_inhibit_job_recovery;

    access_parent_and_object (path, $pft$object_selections [pfc$file_object], authority, catalog_recreated,
          catalog_locator, p_file_object, status);
    IF status.normal THEN
      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);
      IF catalog_recreated THEN
        IF p_file_object^.object_entry.object_type = pfc$file_object THEN
          {
          { The file occurs redundantly on the backup file so re-create
          { nonredundant cycles.
          {
          put_new_cycles_media (backup_file_version, p_file_group, path, authority.ownership,
                catalog_locator.p_catalog_file, p_file_object, cycles_restored_without_fmd,
                cycles_restored_with_fmd, status);
        ELSE {free object}
          {
          { Reconstruct the parent catalog's contents from the backup file.
          {
          file_entry_recreated := TRUE;
          selection_criteria.after_date_time_selected := FALSE;
          selection_criteria.before_date_time_selected := FALSE;
          audit_restorations := avp$security_option_active (avc$vso_security_audit);
          p_auditable_permits := NIL;
          p_auditable_cycles := NIL;
          put_file_info (backup_file_version, p_file_group, pfc$local_mainframe, path, authority.ownership,
                permit_level, selection_criteria,
                $fst$cycle_damage_symptoms [fsc$respf_modification_mismatch, fsc$parent_catalog_restored],
                restore_archive_information, {restore_media} TRUE, catalog_locator.p_catalog_file,
                p_file_object, audit_restorations, all_permits_restored, p_auditable_permits,
                cycles_restored_without_fmd, cycles_restored_with_fmd, p_auditable_cycles, status);
        IFEND;
      IFEND;

      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_put_file_media_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_put_item_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_put_item_info
    (    backup_file_version: pft$backup_file_version;
         p_info_record: {input} ^pft$info_record;
         family_location: pft$family_location;
         path: pft$complete_path;
         permit_level: pft$permit_level;
         selection_criteria: put$selection_criteria;
         restore_archive_information: boolean;
     VAR audit_restorations: {i/o} boolean;
     VAR all_permits_restored: {i/o} boolean;
     VAR p_auditable_permits: {server only} ^pft$auditable_permits;
     VAR p_auditable_cycles: {server only} ^pft$auditable_cycles;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_put_item_info;
    PROCEND initiate_non_local_exit;

    VAR
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id,
      authority: pft$authority,
      catalog_locator: pft$catalog_locator,
      cycles_media_restored: pft$cycle_count,
      cycles_recreated: pft$cycle_count,
      fs_path_size: fst$path_size,
      local_permit_level: pft$permit_level,
      local_status: ost$status,
      p_fs_path: ^fst$path,
      p_group_record: ^pft$info_record,
      p_internal_path: ^pft$internal_path,
      p_physical_object: ^pft$physical_object,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      pfs_limit: sft$limit,
      process_non_local_exit: boolean,
      variant_path: pft$variant_path;

    syp$push_inhibit_job_recovery;

    process_non_local_exit := FALSE;
    #SPOIL (process_non_local_exit);

    pfp$get_authority (path, {system_privilege} FALSE, authority, status);
    IF status.normal THEN
      IF authority.ownership <= $pft$ownership [pfc$master_catalog_owner] THEN
        local_permit_level := permit_level;
      ELSE
        local_permit_level := pfc$pl_public;
      IFEND;

      pfp$locate_group_info_record (p_info_record, p_group_record, status);
    IFEND;

    IF status.normal AND sfv$dynamic_file_space_limits AND
          (pfc$master_catalog_owner IN authority.ownership) THEN
      sfp$get_job_limit (avc$pfs_limit_name, pfs_limit, status);
      IF status.normal THEN
        IF pfs_limit.accumulator >= pfs_limit.job_abort_limit THEN
          osp$set_status_condition (ame$file_space_limit_exceeded, status);
          PUSH p_fs_path;
          pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
          osp$append_status_file (osc$status_parameter_delimiter, p_fs_path^ (1, fs_path_size), status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'Permanent', status);
        IFEND;
      ELSE
        status.normal := TRUE;
      IFEND;
    IFEND;

    IF status.normal THEN
      IF (p_group_record^.record_type = pfc$catalog_group_record) AND
            (UPPERBOUND (path) - 1 > pfc$maximum_catalog_depth) THEN
        variant_path.complete_path := TRUE;
        variant_path.p_complete_path := ^path;
        pfp$set_status_abnormal (variant_path, pfe$too_many_catalogs_in_path, status);
        osp$append_status_integer (osc$status_parameter_delimiter, pfc$maximum_catalog_depth, radix,
              NOT include_radix, status);
        osp$append_status_integer (osc$status_parameter_delimiter, UPPERBOUND (path) - 1, radix,
              NOT include_radix, status);
      ELSE
        PUSH p_internal_path: [1 .. UPPERBOUND (path)];
        pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$free_object],
              parent_charge_id, catalog_locator, p_physical_object, p_internal_path^, permit_entry, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);
      CASE p_group_record^.record_type OF
      = pfc$catalog_group_record =
        pfp$validate_ownership (authority, path, status);
        IF status.normal THEN
          put_catalog_info (p_group_record, family_location, path, authority, local_permit_level,
                pfc$external_catalog, {catalog_recreated} FALSE, catalog_locator.p_catalog_file,
                p_physical_object, audit_restorations, all_permits_restored, p_auditable_permits, status);
        ELSEIF audit_restorations THEN
          p_auditable_permits := NIL;
          IF family_location = pfc$local_mainframe THEN
            audit_information.audited_operation := sfc$ao_fs_create_object;
            audited_object.variant_path.complete_path := TRUE;
            audited_object.variant_path.p_complete_path := ^path;
            audited_object.object_type := sfc$afsot_catalog;
            audit_information.create_fs_object.object_id_p := ^audited_object;
            audit_information.create_fs_object.ownership := authority.ownership;
            sfp$emit_audit_statistic (audit_information, status);
          IFEND;
        IFEND;
        p_auditable_cycles := NIL;

      = pfc$file_group_record =
        pfp$validate_file_permission (path, authority, permit_entry, $pft$permit_selections [pfc$cycle],
              - $pft$share_selections [], status);
        IF status.normal THEN
          put_file_info (backup_file_version, p_group_record, family_location, path, authority.ownership,
                local_permit_level, selection_criteria, $fst$cycle_damage_symptoms [],
                restore_archive_information, {restore_media} FALSE, catalog_locator.p_catalog_file,
                p_physical_object, audit_restorations, all_permits_restored, p_auditable_permits,
                cycles_recreated, cycles_media_restored, p_auditable_cycles, status);
        ELSEIF audit_restorations THEN
          p_auditable_permits := NIL;
          variant_path.complete_path := TRUE;
          variant_path.p_complete_path := ^path;
          audit_cycle_restorations (backup_file_version, p_group_record, family_location, variant_path,
                authority.ownership, selection_criteria, restore_archive_information, status,
                p_auditable_cycles);
          audit_restorations := p_auditable_cycles <> NIL;
        IFEND;

      ELSE
        audit_restorations := FALSE;
        p_auditable_permits := NIL;
        p_auditable_cycles := NIL;
        osp$set_status_condition (pfe$bad_info_record_format, status);
      CASEND;

      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    ELSE
      audit_restorations := FALSE;
      p_auditable_permits := NIL;
      p_auditable_cycles := NIL;
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_put_item_info;

?? TITLE := '  [XDCL, #GATE] pfp$r2_put_master_catalog_info', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_put_master_catalog_info
    (    set_name: stt$set_name;
         family_name: pft$name;
         master_catalog_name: pft$name;
         p_info_record: {input} pft$p_info_record;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_put_master_catalog_info;
    PROCEND initiate_non_local_exit;

    CONST
      permit_level = pfc$pl_public;

    VAR
      all_permits_restored: boolean,
      audit_restorations: boolean,
      authority: pft$authority,
      catalog_locator: pft$catalog_locator,
      internal_path: array [1 .. pfc$master_catalog_path_index] of pft$internal_name,
      local_status: ost$status,
      p_auditable_permits: ^pft$auditable_permits,
      p_physical_object: ^pft$physical_object,
      parent_charge_id: pft$charge_id,
      path: array [1 .. pfc$master_catalog_path_index] of pft$name,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;

    path [pfc$set_path_index] := set_name;
    path [pfc$family_path_index] := family_name;
    path [pfc$master_catalog_path_index] := master_catalog_name;
    process_non_local_exit := FALSE;
    #SPOIL (process_non_local_exit);

    pfp$get_authority (path, {system_privilege} FALSE, authority, status);
    IF status.normal THEN
      pfp$validate_family_ownership (family_name, authority, status);
    IFEND;

    IF status.normal THEN
      pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$free_object],
            parent_charge_id, catalog_locator, p_physical_object, internal_path, permit_entry, status);
    IFEND;

    IF status.normal THEN
      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);
      audit_restorations := avp$security_option_active (avc$vso_security_audit);
      p_auditable_permits := NIL;
      put_catalog_info (p_info_record, pfc$local_mainframe, path, authority, permit_level,
            pfc$external_catalog, {catalog_recreated} FALSE, catalog_locator.p_catalog_file,
            p_physical_object, audit_restorations, all_permits_restored, p_auditable_permits, status);

      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_put_master_catalog_info;

?? TITLE := '  access_parent_and_object', EJECT ??

  PROCEDURE access_parent_and_object
    (    path: pft$complete_path;
         object_selections: pft$object_selections;
     VAR authority: pft$authority;
     VAR parent_recreated: boolean;
     VAR parent_catalog_locator: pft$catalog_locator;
     VAR p_physical_object: ^pft$physical_object;
     VAR status: ost$status);

    PROCEDURE access_parent_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        variant_path: pft$variant_path,
        status_id: ost$status_identifier,
        local_status: ost$status;

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := ^path;

      IF NOT process_non_local_exit THEN
        pfp$log_ascii ('***PF Condition Handler***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, {critical_message} FALSE, local_status);
        pfp$log_path (variant_path, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
              {critical_message} FALSE, local_status);
      IFEND;

      CASE condition.selector OF
      = pmc$system_conditions, pmc$block_exit_processing, mmc$segment_access_condition =
        IF process_non_local_exit THEN
          RETURN;
        IFEND;

        IF parent_catalog_locator.attached THEN
          parent_catalog_locator.abort_catalog_operation := TRUE;
          pfp$return_catalog (parent_catalog_locator, local_status);
          IF NOT local_status.normal THEN
            pfp$report_system_error (local_status);
          IFEND;
        IFEND;

        IF grandparent_catalog_locator.attached THEN
          grandparent_catalog_locator.abort_catalog_operation := TRUE;
          pfp$return_catalog (grandparent_catalog_locator, local_status);
          IF NOT local_status.normal THEN
            pfp$report_system_error (local_status);
          IFEND;
        IFEND;

        osp$set_status_from_condition (status_id, condition, p_sfsa, local_status, handler_status);
        osp$recoverable_system_error ('UNEXPECTED STATUS', ^local_status);

        status := local_status;
        initiate_non_local_exit;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
        { syp$invalidate_open_sfid (catalog_locator.system_file_id, local_status);
          initiate_non_local_exit;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND access_parent_handler;

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT access_parent_and_object;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      catalog: pft$array_index,
      grandparent_catalog_locator: pft$catalog_locator,
      internal_name: pft$internal_name,
      local_object_selections: pft$object_selections,
      local_status: ost$status,
      p_parent_catalog_internal_path: ^pft$internal_path,
      p_parent_catalog_path: ^pft$complete_path,
      p_physical_parent_catalog_obj: ^pft$physical_object,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    pfp$get_authority (path, NOT system_privilege, authority, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /access_parent/
    BEGIN
      grandparent_catalog_locator.attached := FALSE;
      parent_catalog_locator.attached := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL(process_non_local_exit);

      osp$establish_condition_handler (^access_parent_handler, {block_exit} TRUE);

      IF UPPERBOUND (path) = pfc$family_path_index THEN
        stp$get_root_recreated (path [pfc$set_path_index], parent_recreated, status);
        IF status.normal THEN
          pfp$attach_root_catalog (path [pfc$set_path_index], pfc$write_access, parent_catalog_locator,
                status);
          permit_entry.entry_type := pfc$free_permit_entry;
        IFEND;
        EXIT /access_parent/;
      IFEND;
      {
      { Access the parent object entry to determine if it was re-created.
      {
      PUSH p_parent_catalog_path: [1 .. (UPPERBOUND (path) - 1)];
      FOR catalog := 1 TO (UPPERBOUND (path) - 1) DO
        p_parent_catalog_path^ [catalog] := path [catalog];
      FOREND;
      PUSH p_parent_catalog_internal_path: [1 .. (UPPERBOUND (path) - 1)];
      pfp$access_object (p_parent_catalog_path^, pfc$read_access, authority,
            $pft$object_selections [pfc$catalog_object], parent_charge_id, grandparent_catalog_locator,
            p_physical_parent_catalog_obj, p_parent_catalog_internal_path^, permit_entry, status);

      IF status.normal THEN
        parent_recreated := p_physical_parent_catalog_obj^.object_entry.catalog_recreated_by_restore;
        {
        { Access the parent catalog to look for this file or catalog.
        {
        pfp$access_next_catalog (pfc$write_access, grandparent_catalog_locator,
              p_physical_parent_catalog_obj, {catalog_remote} FALSE, parent_catalog_locator, status);
        IF (NOT status.normal) OR (p_physical_parent_catalog_obj^.object_entry.catalog_object_locator.
              catalog_type = pfc$external_catalog) THEN
          pfp$return_catalog (grandparent_catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
        IFEND;
      IFEND;
    END /access_parent/;

  /access_object/
    BEGIN
      IF NOT status.normal THEN
        EXIT /access_object/;
      IFEND;

      IF parent_recreated THEN
        {
        { The parent catalog was re-created and the object does not exist, so
        { create the object.
        {
        local_object_selections := object_selections + $pft$object_selections [pfc$free_object];
      ELSE
        {
        { The parent catalog was not re-created, so do not re-create any
        { deleted files or catalogs.
        {
        local_object_selections := object_selections;
      IFEND;

      pfp$access_last_object (path, authority, local_object_selections, parent_catalog_locator,
            permit_entry, p_physical_object, internal_name, status);
      IF NOT status.normal THEN
        pfp$return_catalog (parent_catalog_locator, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;
    END /access_object/;

    osp$disestablish_cond_handler;
  PROCEND access_parent_and_object;

?? TITLE := '  add_cycle_entry', EJECT ??

  PROCEDURE add_cycle_entry
    (    p_path: ^pft$complete_path;
         cycle_entry: pft$cycle_entry;
         p_file_object: pft$p_object;
         p_catalog_file: pft$p_catalog_file;
     VAR status: ost$status);

    VAR
      cycle_list_locator: pft$cycle_list_locator,
      new_cycle_list: boolean,
      new_cycle_list_locator: pft$cycle_list_locator,
      p_cycle: pft$p_cycle,
      p_cycle_list: pft$p_cycle_list,
      p_new_cycle_list: pft$p_cycle_list;

    cycle_list_locator := p_file_object^.object_entry.cycle_list_locator;

    pfp$build_cycle_list_pointer (cycle_list_locator, p_catalog_file, p_cycle_list);
    pfp$establish_free_cycle_entry (^p_catalog_file^.catalog_heap, p_cycle_list, p_new_cycle_list,
          new_cycle_list, p_cycle, status);
    IF status.normal THEN
      p_cycle^.cycle_entry := cycle_entry;
      pfp$compute_checksum (#LOC (cycle_entry), #SIZE (cycle_entry), p_cycle^.checksum);

      IF new_cycle_list THEN
        pfp$build_cycle_list_locator (p_new_cycle_list, p_catalog_file, new_cycle_list_locator);
        p_file_object^.object_entry.cycle_list_locator := new_cycle_list_locator;
        pfp$compute_checksum (#LOC (p_file_object^.object_entry), #SIZE (p_file_object^.object_entry),
              p_file_object^.checksum);
        free_cycle_list (p_path, cycle_list_locator, p_catalog_file);
      IFEND;
    IFEND;
  PROCEND add_cycle_entry;

?? TITLE := '  audit_cycle_deletions', EJECT ??

  PROCEDURE audit_cycle_deletions
    (    path: pft$complete_path;
         ownership: pft$ownership;
         p_catalog_file: {input^} ^pft$catalog_file;
         cycle_list_locator: pft$cycle_list_locator);

    VAR
      audit_information: sft$audit_information,
      audit_status: ost$status,
      audited_object: sft$audited_fs_object_id,
      cycle_index: pft$cycle_index,
      cycle_selector: pft$cycle_selector,
      p_cycle_list: ^pft$cycle_list;

    pfp$build_cycle_list_pointer (cycle_list_locator, p_catalog_file, p_cycle_list);
    IF p_cycle_list <> NIL THEN
      audit_information.audited_operation := sfc$ao_fs_delete_object;
      audited_object.variant_path.complete_path := TRUE;
      audited_object.variant_path.p_complete_path := ^path;
      audited_object.object_type := sfc$afsot_cycle;
      cycle_selector.cycle_option := pfc$specific_cycle;
      audited_object.cycle_selector_p := ^cycle_selector;
      audit_information.delete_fs_object.object_id_p := ^audited_object;
      audit_information.delete_fs_object.ownership := ownership;
      audit_status.normal := TRUE;

      FOR cycle_index := 1 TO UPPERBOUND (p_cycle_list^) DO
        IF p_cycle_list^ [cycle_index].cycle_entry.entry_type <> pfc$free_cycle_entry THEN
          cycle_selector.cycle_number := p_cycle_list^ [cycle_index].cycle_entry.cycle_number;
          IF p_cycle_list^ [cycle_index].cycle_entry.device_information.device_class_defined THEN
            pfp$convert_device_class_to_rm
                  (p_cycle_list^ [cycle_index].cycle_entry.device_information.device_class,
                  audited_object.device_class);
          ELSE
            audited_object.device_class := rmc$mass_storage_device;
          IFEND;
          sfp$emit_audit_statistic (audit_information, audit_status);
        IFEND;
      FOREND;
    IFEND;
  PROCEND audit_cycle_deletions;

?? TITLE := '  audit_cycle_restorations', EJECT ??

  PROCEDURE audit_cycle_restorations
    (    backup_file_version: pft$backup_file_version;
         p_file_group_record: ^pft$info_record;
         family_location: pft$family_location;
         variant_path: pft$variant_path;
         ownership: pft$ownership;
         selection_criteria: put$selection_criteria;
         restore_archive_information: boolean;
         audit_status: ost$status;
     VAR p_auditable_cycles: ^pft$auditable_cycles);

    VAR
      all_cycles_chosen: boolean,
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id,
      cycle_count: pft$cycle_count,
      cycle_index: pft$array_index,
      cycle_selector: pft$cycle_selector,
      local_status: ost$status,
      p_chosen_cycles: ^pft$chosen_cycles,
      p_cycle_array_version_1: ^pft$cycle_array,
      p_cycle_array_version_2: ^pft$cycle_array_version_2,
      p_file_description: ^pft$file_description;

    pfp$find_file_description (p_file_group_record, p_file_description, local_status);
    IF local_status.normal THEN
      IF backup_file_version = pfc$backup_file_version_2 THEN
        pfp$find_cycle_array_version_2 (p_file_group_record, p_cycle_array_version_2, local_status);
        IF local_status.normal AND (p_cycle_array_version_2 = NIL) THEN
          p_auditable_cycles := NIL;
          RETURN;
        IFEND;
      ELSE { backup_file_version = pfc$backup_file_version_1 }
        pfp$find_cycle_array (p_file_group_record, p_cycle_array_version_1, local_status);
        IF local_status.normal AND (p_cycle_array_version_1 = NIL) THEN
          p_auditable_cycles := NIL;
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    IF local_status.normal THEN
      IF backup_file_version = pfc$backup_file_version_1 THEN
        PUSH p_cycle_array_version_2: [1 .. UPPERBOUND (p_cycle_array_version_1^)];
        map_cycle_array_to_version_2 (p_cycle_array_version_1, p_cycle_array_version_2);
      IFEND;

      all_cycles_chosen := restore_archive_information AND (NOT selection_criteria.after_date_time_selected)
            AND NOT selection_criteria.before_date_time_selected;
      IF all_cycles_chosen THEN
        cycle_count := UPPERBOUND (p_cycle_array_version_2^);
      ELSE
        PUSH p_chosen_cycles: [1 .. UPPERBOUND (p_cycle_array_version_2^)];
        choose_relevant_cycles (p_file_group_record, ownership, p_cycle_array_version_2, selection_criteria,
              restore_archive_information, p_chosen_cycles, cycle_count, local_status);
      IFEND;
    IFEND;

    IF local_status.normal THEN
      IF cycle_count = 0 THEN
        p_auditable_cycles := NIL;
      ELSE
        IF family_location = pfc$local_mainframe THEN
          audit_information.audited_operation := sfc$ao_fs_create_object;
          audited_object.variant_path := variant_path;
          audited_object.object_type := sfc$afsot_cycle;
          cycle_selector.cycle_option := pfc$specific_cycle;
          audited_object.cycle_selector_p := ^cycle_selector;
          audit_information.create_fs_object.object_id_p := ^audited_object;
          audit_information.create_fs_object.ownership := ownership;
        IFEND;

        FOR cycle_index := 1 TO UPPERBOUND (p_cycle_array_version_2^) DO
          IF all_cycles_chosen OR p_chosen_cycles^ [cycle_index] THEN
            IF family_location = pfc$local_mainframe THEN
              cycle_selector.cycle_number := p_cycle_array_version_2^ [cycle_index].cycle_number;
              audited_object.device_class := p_cycle_array_version_2^ [cycle_index].device_class;
              sfp$emit_audit_statistic (audit_information, audit_status);
            ELSE
              p_auditable_cycles^ [cycle_index].audit := TRUE;
              p_auditable_cycles^ [cycle_index].cycle_number :=
                    p_cycle_array_version_2^ [cycle_index].cycle_number;
              p_auditable_cycles^ [cycle_index].device_class :=
                    p_cycle_array_version_2^ [cycle_index].device_class;
              p_auditable_cycles^ [cycle_index].normal_status := FALSE;
              p_auditable_cycles^ [cycle_index].condition := audit_status.condition;
            IFEND;
          ELSEIF family_location = pfc$server_mainframe THEN
            p_auditable_cycles^ [cycle_index].audit := FALSE;
          IFEND;
        FOREND;
      IFEND;
    ELSE
      p_auditable_cycles := NIL;
    IFEND;
  PROCEND audit_cycle_restorations;

?? TITLE := '  audit_permit_deletions', EJECT ??

  PROCEDURE audit_permit_deletions
    (    path: pft$complete_path;
         object_type: sft$audited_fs_object_type;
         ownership: pft$ownership;
         p_catalog_file: {input^} ^pft$catalog_file;
         permit_list_locator: pft$permit_list_locator);

    VAR
      audit_information: sft$audit_information,
      audit_status: ost$status,
      audited_object: sft$audited_fs_object_id,
      p_permit_list: ^pft$permit_list,
      permit_index: pft$permit_index;

    pfp$build_permit_list_pointer (permit_list_locator, p_catalog_file, p_permit_list);
    IF p_permit_list <> NIL THEN
      audit_information.audited_operation := sfc$ao_fs_delete_permit;
      audited_object.variant_path.complete_path := TRUE;
      audited_object.variant_path.p_complete_path := ^path;
      audited_object.object_type := object_type;
      audit_information.delete_fs_permit.object_id_p := ^audited_object;
      audit_information.delete_fs_permit.ownership := ownership;
      audit_status.normal := TRUE;

      FOR permit_index := 1 TO UPPERBOUND (p_permit_list^) DO
        IF p_permit_list^ [permit_index].permit_entry.entry_type = pfc$normal_permit_entry THEN
          audit_information.delete_fs_permit.group_p := ^p_permit_list^ [permit_index].permit_entry.group;
          sfp$emit_audit_statistic (audit_information, audit_status);
        IFEND;
      FOREND;
    IFEND;
  PROCEND audit_permit_deletions;

?? TITLE := '  choose_relevant_cycles', EJECT ??
*copy pfh$choose_relevant_cycles

  PROCEDURE choose_relevant_cycles
    (    p_file_info_record: {input} ^pft$info_record;
         ownership: pft$ownership;
         p_cycle_array: {input} ^pft$cycle_array_version_2;
         selection_criteria: put$selection_criteria;
         restore_archive_information: boolean;
         p_chosen_cycles: {output^} ^pft$chosen_cycles;
     VAR chosen_cycles_count: pft$cycle_count;
     VAR status: ost$status);

    VAR
      comparison_result: pmt$comparison_result,
      cycle_array_extended_missing: boolean,
      cycle_date_time: ost$date_time,
      cycle_included: boolean,
      cycle_index: pft$cycle_count,
      cycle_time_after_after_time: boolean,
      cycle_time_before_before_time: boolean,
      local_status: ost$status,
      p_archive_list: ^pft$info_record,
      p_cycle_array_extended_record: ^pft$info_record,
      p_cycle_directory_array: ^pft$cycle_directory_array,
      p_cycle_info_record: ^pft$info_record,
      p_cycle_media_description: ^pft$file_media_description;

    chosen_cycles_count := 0;

    cycle_array_extended_missing := FALSE;
    IF restore_archive_information THEN
      status.normal := TRUE;
    ELSE
      pfp$find_cycle_array_extended (p_file_info_record, p_cycle_array_extended_record, status);
      IF status.normal THEN
        pfp$find_cycle_directory (p_cycle_array_extended_record, p_cycle_directory_array, status);
      ELSEIF status.condition = pfe$unknown_cycle_array THEN
        cycle_array_extended_missing := TRUE;
        status.normal := TRUE;
      IFEND;
    IFEND;

    IF status.normal THEN
      FOR cycle_index := 1 TO UPPERBOUND (p_cycle_array^) DO
        IF (NOT selection_criteria.after_date_time_selected) AND
              NOT selection_criteria.before_date_time_selected THEN
          cycle_included := TRUE;
        ELSE
          CASE selection_criteria.mode OF
          = puc$created =
            cycle_date_time := p_cycle_array^ [cycle_index].cycle_statistics.creation_date_time;
          = puc$accessed =
            cycle_date_time := p_cycle_array^ [cycle_index].cycle_statistics.access_date_time;
          = puc$modified =
            cycle_date_time := p_cycle_array^ [cycle_index].cycle_statistics.modification_date_time;
          = puc$expired =
            cycle_date_time := p_cycle_array^ [cycle_index].expiration_date_time;
          ELSE
            ;
          CASEND;

          IF selection_criteria.after_date_time_selected THEN
            pmp$date_time_compare (selection_criteria.after_date_time, cycle_date_time, comparison_result,
                  local_status);
            cycle_time_after_after_time := (NOT local_status.normal) OR
                  (comparison_result = pmc$right_is_greater);
          IFEND;

          IF selection_criteria.before_date_time_selected THEN
            pmp$date_time_compare (cycle_date_time, selection_criteria.before_date_time, comparison_result,
                  local_status);
            cycle_time_before_before_time := (NOT local_status.normal) OR
                  (comparison_result = pmc$right_is_greater);
          IFEND;

          IF selection_criteria.after_date_time_selected THEN
            IF selection_criteria.before_date_time_selected THEN
              IF selection_criteria.after_time_after_before_time THEN
                cycle_included := cycle_time_before_before_time OR cycle_time_after_after_time;
              ELSE
                cycle_included := cycle_time_after_after_time AND cycle_time_before_before_time;
              IFEND;
            ELSE { after_date_time_selected by itself }
              cycle_included := cycle_time_after_after_time;
            IFEND;
          ELSE { before_date_time_selected by itself }
            cycle_included := cycle_time_before_before_time;
          IFEND;
        IFEND;

        IF cycle_included THEN
          IF restore_archive_information OR cycle_array_extended_missing THEN
            chosen_cycles_count := chosen_cycles_count + 1;
          ELSE
            {
            { Ignore the cycle if it had been archived and released.
            {
            pfp$find_direct_info_record (^p_cycle_array_extended_record^.body,
                  p_cycle_directory_array^ [cycle_index].info_offset, p_cycle_info_record, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            pfp$find_archive_info (p_cycle_info_record, p_archive_list, status);
            IF status.normal THEN
              pfp$find_cycle_media (p_cycle_info_record, p_cycle_media_description, status);
              IF status.normal THEN
                chosen_cycles_count := chosen_cycles_count + 1;
              ELSEIF status.condition = pfe$unknown_cycle_media THEN
                cycle_included := FALSE;
                status.normal := TRUE;
              ELSE
                RETURN;
              IFEND;
            ELSEIF status.condition = pfe$unknown_archive_info THEN
              chosen_cycles_count := chosen_cycles_count + 1;
              status.normal := TRUE;
            ELSE
              RETURN;
            IFEND;
          IFEND;
        IFEND;

        p_chosen_cycles^ [cycle_index] := cycle_included AND
              (((p_cycle_array^ [cycle_index].device_class = rmc$mass_storage_device) AND
              NOT p_cycle_array^ [cycle_index].sparse_allocation) OR
              ((ownership <> $pft$ownership []) AND
              (p_cycle_array^ [cycle_index].device_class = rmc$magnetic_tape_device)));
      FOREND;
    IFEND;
  PROCEND choose_relevant_cycles;

?? TITLE := '  create_cycle_entry', EJECT ??

  PROCEDURE create_cycle_entry
    (    path: pft$complete_path;
         cycle_list_locator: pft$cycle_list_locator;
         p_catalog_file: pft$p_catalog_file;
         cycle_selector: pft$cycle_selector;
         pf_device_class: pft$device_class;
         cycle_statistics: pft$cycle_statistics;
         data_modification_date_time: ost$date_time;
         expiration_date_time: ost$date_time;
         cycle_damage_symptoms: fst$cycle_damage_symptoms;
         shared_queue_info: pft$shared_queue_info;
         retrieve_option: pft$retrieve_option;
         site_backup_option: pft$site_backup_option;
         site_archive_option: pft$site_archive_option;
         site_release_option: pft$site_release_option;
     VAR cycle_entry: pft$cycle_entry;
     VAR status: ost$status);

    VAR
      cycle_number: pft$cycle_number,
      p_cycle_list: pft$p_cycle_list;

    pfp$build_cycle_list_pointer (cycle_list_locator, p_catalog_file, p_cycle_list);
    pfp$determine_new_cycle_number (path, p_cycle_list, cycle_selector, cycle_number, status);
    IF status.normal THEN
      initialize_cycle_entry (cycle_number, pf_device_class, cycle_statistics, data_modification_date_time,
            expiration_date_time, cycle_damage_symptoms, shared_queue_info, retrieve_option,
            site_backup_option, site_archive_option, site_release_option, cycle_entry);
    IFEND;
  PROCEND create_cycle_entry;

?? TITLE := '  free_cycle_list', EJECT ??

  PROCEDURE free_cycle_list
    (    p_path: ^pft$complete_path;
         cycle_list_locator: pft$cycle_list_locator;
         p_catalog_file: pft$p_catalog_file);

    VAR
      p_cycle_list: pft$p_cycle_list,
      prevalidate_free_result: ost$prevalidate_free_result;

    pfp$build_cycle_list_pointer (cycle_list_locator, p_catalog_file, p_cycle_list);
    IF p_cycle_list <> NIL THEN
      osp$prevalidate_free ((#OFFSET(p_cycle_list) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
             ^p_catalog_file^.catalog_heap, prevalidate_free_result);
      IF prevalidate_free_result = osc$heap_free_valid THEN
        FREE p_cycle_list IN p_catalog_file^.catalog_heap;
      ELSE
        pfp$report_invalid_free (p_path, {p_cycle_number} NIL, 'CYCLE_LIST', 'file', prevalidate_free_result,
              #OFFSET(p_cycle_list));
        p_cycle_list := NIL;
      IFEND;
    IFEND;
  PROCEND free_cycle_list;

?? TITLE := '  free_log_list', EJECT ??

  PROCEDURE free_log_list
    (    p_path: ^pft$complete_path;
         log_list_locator: pft$log_list_locator;
         p_catalog_file: pft$p_catalog_file);

    VAR
      p_log_list: pft$p_log_list,
      prevalidate_free_result: ost$prevalidate_free_result;

    pfp$build_log_list_pointer (log_list_locator, p_catalog_file, p_log_list);
    IF p_log_list <> NIL THEN
      osp$prevalidate_free ((#OFFSET(p_log_list) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
            ^p_catalog_file^.catalog_heap, prevalidate_free_result);
      IF prevalidate_free_result = osc$heap_free_valid THEN
        FREE p_log_list IN p_catalog_file^.catalog_heap;
      ELSE
        pfp$report_invalid_free (p_path, {p_cycle_number} NIL, 'LOG_LIST', 'file', prevalidate_free_result,
              #OFFSET(p_log_list));
        p_log_list := NIL;
      IFEND;
    IFEND;
  PROCEND free_log_list;

?? TITLE := '  free_permit_list', EJECT ??

  PROCEDURE free_permit_list
    (    p_path: ^pft$complete_path;
         p_physical_catalog_object: ^pft$physical_object;
         permit_list_locator: pft$permit_list_locator;
         p_catalog_file: pft$p_catalog_file);

    VAR
      p_permit_list: pft$p_permit_list,
      prevalidate_free_result: ost$prevalidate_free_result;

    pfp$build_permit_list_pointer (permit_list_locator, p_catalog_file, p_permit_list);
    IF p_permit_list <> NIL THEN
      osp$prevalidate_free ((#OFFSET(p_permit_list) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
            ^p_catalog_file^.catalog_heap, prevalidate_free_result);
      IF prevalidate_free_result = osc$heap_free_valid THEN
        FREE p_permit_list IN p_catalog_file^.catalog_heap;
      ELSE
        IF p_physical_catalog_object^.object_entry.object_type = pfc$file_object THEN
          pfp$report_invalid_free (p_path, {p_cycle_number} NIL, 'PERMIT_LIST', 'file',
                prevalidate_free_result, #OFFSET(p_permit_list));
        ELSE
          pfp$report_invalid_free (p_path, {p_cycle_number} NIL, 'PERMIT_LIST', 'catalog',
                prevalidate_free_result, #OFFSET(p_permit_list));
        IFEND;
        p_permit_list := NIL;
      IFEND;
    IFEND;
  PROCEND free_permit_list;

?? TITLE := '  initialize_cycle_entry', EJECT ??

  PROCEDURE initialize_cycle_entry
    (    cycle_number: pft$cycle_number;
         pf_device_class: pft$device_class;
         cycle_statistics: pft$cycle_statistics;
         data_modification_date_time: ost$date_time;
         expiration_date_time: ost$date_time;
         cycle_damage_symptoms: fst$cycle_damage_symptoms;
         shared_queue_info: pft$shared_queue_info;
         retrieve_option: pft$retrieve_option;
         site_backup_option: pft$site_backup_option;
         site_archive_option: pft$site_archive_option;
         site_release_option: pft$site_release_option;
     VAR cycle_entry: pft$cycle_entry);

    VAR
      status: ost$status;

    osp$generate_unique_binary_name (cycle_entry.internal_cycle_name, status);
    pfp$process_unexpected_status (status);
    cycle_entry.entry_type := pfc$normal_cycle_entry;
    cycle_entry.cycle_number := cycle_number;
    cycle_entry.cycle_statistics := cycle_statistics;
    cycle_entry.expiration_date_time := expiration_date_time;
    cycle_entry.attach_status := pfv$unattached_status;
    cycle_entry.cycle_damage_symptoms := cycle_damage_symptoms;
    cycle_entry.data_modification_date_time := data_modification_date_time;
    cycle_entry.device_information.device_class_defined := TRUE;
    cycle_entry.device_information.device_class := pf_device_class;
    cycle_entry.device_information.eoi := 0;
    cycle_entry.device_information.bytes_allocated := 0;
    pfp$build_fmd_locator (NIL, NIL, cycle_entry.fmd_locator);
    pfp$build_file_label_locator (NIL, NIL, cycle_entry.file_label_locator);
    pfp$build_archive_list_locator (NIL, NIL,
      cycle_entry.archive_list_locator);
    cycle_entry.first_mainframe_usage_entry.entry_type := pfc$free_mainframe_entry;
    pfp$build_mainfram_list_locator (NIL, NIL, cycle_entry.mainframe_usage_list_locator);
    cycle_entry.global_file_name := cycle_entry.internal_cycle_name;
    cycle_entry.data_residence := pfc$unreleasable_data;
    cycle_entry.shared_queue_info := shared_queue_info;
    cycle_entry.retrieve_option := retrieve_option;
    cycle_entry.site_backup_option := site_backup_option;
    cycle_entry.site_archive_option := site_archive_option;
    cycle_entry.site_release_option := site_release_option;
    cycle_entry.reserved_cycle_entry_space := pfv$null_cycle_entry_space;
  PROCEND initialize_cycle_entry;

?? TITLE := '  initialize_file_object', EJECT ??

  PROCEDURE initialize_file_object
    (    file_name: pft$name;
     VAR file_object: pft$object_entry);

    VAR
      status: ost$status;

    file_object.external_object_name := file_name;
    osp$generate_unique_binary_name (file_object.internal_object_name, status);
    pfp$process_unexpected_status (status);
    pfp$build_permit_list_locator (NIL, NIL, file_object.permit_list_locator);
    file_object.object_type := pfc$file_object;
    file_object.password := osc$null_name;
    file_object.charge_id.account := osc$null_name;
    file_object.charge_id.project := osc$null_name;
    file_object.logging_selection := pfc$no_log;
    pfp$build_log_list_locator (NIL, NIL, file_object.log_list_locator);
    pfp$build_cycle_list_locator (NIL, NIL, file_object.cycle_list_locator);
    file_object.reserved_object_entry_space := pfv$null_object_entry_space;
    file_object.reserved_file_entry_space := pfv$null_file_entry_space;
  PROCEND initialize_file_object;

?? TITLE := '  map_cycle_array_to_version_2', EJECT ??

  PROCEDURE map_cycle_array_to_version_2
    (    p_cycle_array: {input^} ^pft$cycle_array;
         p_cycle_array_version_2: {output^} ^pft$cycle_array_version_2);

    VAR
      cycle_array_index: pft$cycle_array_index;

    FOR cycle_array_index := 1 TO UPPERBOUND (p_cycle_array^) DO
      p_cycle_array_version_2^ [cycle_array_index] := cycle_array_entry_version_2;
      p_cycle_array_version_2^ [cycle_array_index].cycle_number :=
            p_cycle_array^ [cycle_array_index].cycle_number;
      p_cycle_array_version_2^ [cycle_array_index].cycle_statistics :=
            p_cycle_array^ [cycle_array_index].cycle_statistics;
      p_cycle_array_version_2^ [cycle_array_index].data_modification_date_time :=
            p_cycle_array^ [cycle_array_index].cycle_statistics.modification_date_time;
      p_cycle_array_version_2^ [cycle_array_index].device_class := rmc$mass_storage_device;
      p_cycle_array_version_2^ [cycle_array_index].expiration_date_time :=
            p_cycle_array^ [cycle_array_index].expiration_date_time;
      p_cycle_array_version_2^ [cycle_array_index].original_unique_name := pfv$null_unique_name;
      p_cycle_array_version_2^ [cycle_array_index].shared_queue_info.defined := FALSE;
      p_cycle_array_version_2^ [cycle_array_index].retrieve_option := pfc$always_retrieve;
      p_cycle_array_version_2^ [cycle_array_index].site_backup_option := pfc$null_site_backup_option;
      p_cycle_array_version_2^ [cycle_array_index].site_archive_option := pfc$null_site_archive_option;
      p_cycle_array_version_2^ [cycle_array_index].site_release_option := pfc$null_site_release_option;
    FOREND;
  PROCEND map_cycle_array_to_version_2;

?? TITLE := '  put_archive_info', EJECT ??

  PROCEDURE put_archive_info
    (    p_path: ^pft$complete_path;
         p_cycle_number: ^pft$cycle_number;
         p_catalog_file: pft$p_catalog_file;
         data_modification_date_time: ost$date_time;
     VAR file_size: amt$file_length;
     VAR p_archive_info: pft$p_info;
     VAR archive_list_locator: pft$archive_list_locator;
     VAR status: ost$status);

    VAR
      archive_count: pft$archive_count,
      archive_identification: pft$archive_identification,
      archive_index: pft$archive_index,
      local_archive_identification: pft$archive_identification,
      p_amd: pft$p_amd,
      p_archive: pft$p_archive,
      p_archive_array_entry: pft$p_archive_array_entry,
      p_archive_record: pft$p_info_record,
      p_new_archive_list: pft$p_archive_list,
      prevalidate_free_result: ost$prevalidate_free_result;

    status.normal := TRUE;
    archive_count := 0;
    archive_identification.application_identifier := osc$null_name;
    archive_identification.media_identifier.media_device_class := osc$null_name;
    archive_identification.media_identifier.media_volume_identifier := '';
    p_new_archive_list := NIL;
    RESET p_archive_info;

  /build_archive_list/
    BEGIN

      REPEAT
        pfp$find_next_archive_entry (archive_identification, p_archive_info, p_archive_record,
            p_archive_array_entry, p_amd, status);

        IF status.normal THEN
          pfp$convert_archive_ident (p_archive_array_entry^.archive_identification,
             local_archive_identification, status);
          IF NOT status.normal THEN
            EXIT /build_archive_list/;
          IFEND;
          archive_count := archive_count + 1;
          IF (data_modification_date_time = pfv$null_date_time) OR
                (p_archive_array_entry^.modification_date_time = data_modification_date_time) THEN
            file_size := p_archive_array_entry^.file_size;
          IFEND;
        IFEND;
      UNTIL NOT status.normal;
      IF status.condition = pfe$unknown_info_record THEN
        status.normal := TRUE; { all archive array entries found }
      IFEND;

      archive_list_locator.archive_count := 0;

      IF archive_count = 0 THEN
        EXIT /build_archive_list/;
      IFEND;

      pfp$allocate_archive_list (archive_count, ^p_catalog_file^.catalog_heap, p_new_archive_list, status);
      IF NOT status.normal THEN
        EXIT /build_archive_list/;
      IFEND;

      RESET p_archive_info;

    /build_new_archive_list/
      FOR archive_index := 1 TO archive_count DO
        pfp$find_next_archive_entry (archive_identification, p_archive_info, p_archive_record,
            p_archive_array_entry, p_amd, status);
        IF NOT status.normal THEN
          EXIT /build_archive_list/;
        IFEND;
        p_archive := ^p_new_archive_list^[archive_index];
        pfp$convert_archive_ident (p_archive_array_entry^.archive_identification,
          local_archive_identification, status);
        IF NOT status.normal THEN
          EXIT /build_archive_list/;
        IFEND;
        pfp$r2_build_archive_entry (local_archive_identification, p_archive_array_entry, p_amd,
            p_catalog_file, p_archive, status);
        IF NOT status.normal THEN
          EXIT /build_archive_list/;
        IFEND;
      FOREND;

    END /build_archive_list/;

    IF NOT status.normal THEN
      IF p_new_archive_list <> NIL THEN
        osp$prevalidate_free ((#OFFSET(p_new_archive_list) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
              ^p_catalog_file^.catalog_heap, prevalidate_free_result);
        IF prevalidate_free_result = osc$heap_free_valid THEN
          FREE p_new_archive_list IN p_catalog_file^.catalog_heap;
        ELSE
          pfp$report_invalid_free (p_path, p_cycle_number, 'ARCHIVE_LIST', 'file', prevalidate_free_result,
                #OFFSET(p_new_archive_list));
          p_new_archive_list := NIL;
        IFEND;
      IFEND;
    IFEND;

    pfp$build_archive_list_locator (p_new_archive_list, p_catalog_file, archive_list_locator);

  PROCEND put_archive_info;

?? TITLE := '  put_catalog_info', EJECT ??

  PROCEDURE put_catalog_info
    (    p_catalog_group_record: {input} ^pft$info_record;
         family_location: pft$family_location;
         path: pft$complete_path;
         authority: pft$authority;
         permit_level: pft$permit_level;
         catalog_type: pft$catalog_types;
         catalog_recreated: boolean;
         p_parent_catalog_file: {i^/o^} ^pft$catalog_file;
         p_physical_catalog_object: {output^} ^pft$physical_object;
     VAR audit_restorations: {i/o} boolean;
     VAR all_permits_restored: boolean;
     VAR p_auditable_permits: ^pft$auditable_permits;
     VAR status: ost$status);

    CONST
      system_privilege = TRUE;

    VAR
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id,
      p_catalog_description: ^pft$catalog_description,
      permit_list_locator: pft$permit_list_locator,
      permit_restorations_audited: boolean;

    pfp$find_catalog_description (p_catalog_group_record, p_catalog_description, status);

    IF status.normal THEN
      put_permit_array (p_catalog_group_record, family_location, path, sfc$afsot_catalog, authority.ownership,
            permit_level, audit_restorations, p_parent_catalog_file, permit_list_locator,
            all_permits_restored, permit_restorations_audited, p_auditable_permits, status);

      IF status.normal THEN
        pfp$create_catalog_object (path, authority, catalog_type, p_catalog_description^.charge_id,
              p_catalog_description^.charge_id, {p_mass_storage_request_info} NIL, p_parent_catalog_file,
              p_physical_catalog_object, status);

        IF audit_restorations AND (family_location = pfc$local_mainframe) THEN
          audit_information.audited_operation := sfc$ao_fs_create_object;
          audited_object.variant_path.complete_path := TRUE;
          audited_object.variant_path.p_complete_path := ^path;
          audited_object.object_type := sfc$afsot_catalog;
          audit_information.create_fs_object.object_id_p := ^audited_object;
          audit_information.create_fs_object.ownership := authority.ownership;
          sfp$emit_audit_statistic (audit_information, status);
        IFEND;

        IF status.normal THEN
          p_physical_catalog_object^.object_entry.catalog_recreated_by_restore := catalog_recreated;
          p_physical_catalog_object^.object_entry.permit_list_locator := permit_list_locator;
          pfp$compute_checksum (#LOC (p_physical_catalog_object^.object_entry), #SIZE (pft$object_entry),
                p_physical_catalog_object^.checksum);
        ELSE
          IF permit_restorations_audited THEN
            audit_permit_deletions (path, sfc$afsot_catalog, authority.ownership, p_parent_catalog_file,
                  permit_list_locator);
          IFEND;
          p_auditable_permits := NIL;
          free_permit_list (^path, p_physical_catalog_object, permit_list_locator, p_parent_catalog_file);
        IFEND;
      ELSE
        audit_restorations := FALSE;
      IFEND;
    ELSE
      audit_restorations := FALSE;
      p_auditable_permits := NIL;
    IFEND;
  PROCEND put_catalog_info;

?? TITLE := '  put_cycle_archive_info', EJECT ??

  PROCEDURE put_cycle_archive_info (
        p_catalog_file: pft$p_catalog_file;
        p_cycle_list: pft$p_cycle_list;
        cycle_selector: pft$cycle_selector;
        path: pft$complete_path;
        p_cycle_info_record: pft$p_info_record;
    VAR status: ost$status);

    VAR
      archive_list_locator: pft$archive_list_locator,
      data_modification_date_time: ost$date_time,
      file_size: amt$file_length,
      p_archive_info: ^pft$info,
      p_archive_info_record: ^pft$info_record,
      p_archive_list: pft$p_archive_list,
      p_cycle: pft$p_cycle,
      p_cycle_label: ^fmt$file_label,
      p_cycle_label_checksum: ^pft$checksum,
      p_cycle_label_info: ^SEQ ( * ),
      p_fmd_description: ^pft$file_media_description,
      p_new_stored_file_label: ^pft$physical_file_label,
      valid_archive_entry_exists: boolean;

    pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);

    IF status.normal THEN
      pfp$find_archive_info (p_cycle_info_record, p_archive_info_record, status);
      IF NOT status.normal THEN

{ Someday, restructure all these checks for normal status.  This change is
{ going in after the very last chance for 1.5.2, so it will not restructure.

        status.normal := TRUE;
        RETURN;
      IFEND;
    IFEND;

    IF status.normal THEN
      IF p_cycle^.cycle_entry.archive_list_locator.archive_count = 0 THEN
        IF p_cycle^.cycle_entry.file_label_locator.file_label_size = 0 THEN
          pfp$find_cycle_label (p_cycle_info_record, p_cycle_label_info, status);
          IF status.normal THEN
            RESET p_cycle_label_info;
            NEXT p_cycle_label_checksum IN p_cycle_label_info;
            NEXT p_cycle_label: [[REP (#SIZE (p_cycle_label_info^) - #SIZE (pft$checksum)) OF cell]] IN
                  p_cycle_label_info;

            ALLOCATE p_new_stored_file_label: [[REP (#SIZE (p_cycle_label^)) OF cell]] IN
                  p_catalog_file^.catalog_heap;
            IF p_new_stored_file_label = NIL THEN
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, 'cycle label',
                    status);
            ELSE
              p_new_stored_file_label^.file_label := p_cycle_label^;
              pfp$compute_checksum (#LOC (p_cycle_label^), #SIZE (p_cycle_label^),
                    p_new_stored_file_label^.checksum);
              pfp$build_file_label_locator (p_new_stored_file_label, p_catalog_file,
                    p_cycle^.cycle_entry.file_label_locator);
            IFEND;
          ELSEIF status.condition = pfe$unknown_cycle_label THEN
            status.normal := TRUE;
          IFEND;
        IFEND;
        IF p_cycle^.cycle_entry.data_modification_date_time.year > 0 THEN
          data_modification_date_time := p_cycle^.cycle_entry.data_modification_date_time;
        ELSE
          data_modification_date_time := p_cycle^.cycle_entry.cycle_statistics.modification_date_time;
        IFEND;
        p_archive_info := ^p_archive_info_record^.body;
        put_archive_info (^path, ^p_cycle^.cycle_entry.cycle_number, p_catalog_file,
              data_modification_date_time, file_size, p_archive_info, archive_list_locator, status);
        IF status.normal AND (archive_list_locator.archive_count <> 0) THEN
          p_cycle^.cycle_entry.archive_list_locator := archive_list_locator;
          pfp$check_archive_entries (p_catalog_file, p_cycle, valid_archive_entry_exists, status);
          IF status.normal AND valid_archive_entry_exists AND
                (p_cycle^.cycle_entry.fmd_locator.fmd_size = 0) THEN
            p_cycle^.cycle_entry.data_residence := pfc$offline_data;
            p_cycle^.cycle_entry.device_information.device_class_defined := TRUE;
            p_cycle^.cycle_entry.device_information.device_class := pfc$mass_storage_device;
            p_cycle^.cycle_entry.device_information.bytes_allocated := 0;
            p_cycle^.cycle_entry.device_information.eoi := file_size;
            p_cycle^.cycle_entry.data_modification_date_time := data_modification_date_time;
          IFEND;
          pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
        IFEND;
      IFEND;
    IFEND;

  PROCEND put_cycle_archive_info;

?? TITLE := '  put_cycle_array', EJECT ??

  PROCEDURE put_cycle_array
    (    p_file_group_record: {input} ^pft$info_record;
         p_cycle_array_version_2: ^pft$cycle_array_version_2;
         family_location: pft$family_location;
         path: pft$complete_path;
         ownership: pft$ownership;
         selection_criteria: put$selection_criteria;
         cycle_damage_symptoms: fst$cycle_damage_symptoms;
         restore_archive_information: boolean;
         audit_cycle_restorations: boolean;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
     VAR cycle_list_locator: pft$cycle_list_locator;
     VAR cycle_count: pft$cycle_count;
     VAR cycle_restorations_audited: boolean;
     VAR p_auditable_cycles: ^pft$auditable_cycles;
     VAR status: ost$status);

    VAR
      all_cycles_chosen: boolean,
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id,
      chosen_cycles_index: pft$array_index,
      cycle_index: pft$array_index,
      cycle_selector: pft$cycle_selector,
      free_physical_cycle: pft$physical_cycle,
      p_chosen_cycles: ^pft$chosen_cycles,
      p_cycle_list: ^pft$cycle_list,
      pf_device_class: pft$device_class;

    all_cycles_chosen := restore_archive_information AND (NOT selection_criteria.after_date_time_selected)
          AND NOT selection_criteria.before_date_time_selected;
    IF all_cycles_chosen THEN
      cycle_count := UPPERBOUND (p_cycle_array_version_2^);
    ELSE
      PUSH p_chosen_cycles: [1 .. UPPERBOUND (p_cycle_array_version_2^)];
      choose_relevant_cycles (p_file_group_record, ownership, p_cycle_array_version_2, selection_criteria,
            restore_archive_information, p_chosen_cycles, cycle_count, status);
      IF NOT status.normal THEN
        cycle_count := 0;
      IFEND;
    IFEND;

    IF cycle_count > 0 THEN
      pfp$allocate_cycle_list (cycle_count, ^p_catalog_file^.catalog_heap, p_cycle_list, status);

      IF status.normal THEN
        IF audit_cycle_restorations AND (family_location = pfc$local_mainframe) THEN
          audit_information.audited_operation := sfc$ao_fs_create_object;
          audited_object.variant_path.complete_path := TRUE;
          audited_object.variant_path.p_complete_path := ^path;
          audited_object.object_type := sfc$afsot_cycle;
          cycle_selector.cycle_option := pfc$specific_cycle;
          audited_object.cycle_selector_p := ^cycle_selector;
          audit_information.create_fs_object.object_id_p := ^audited_object;
          audit_information.create_fs_object.ownership := ownership;
          cycle_restorations_audited := TRUE;
        ELSE
          cycle_restorations_audited := FALSE;
        IFEND;

        chosen_cycles_index := 1;
        FOR cycle_index := 1 TO UPPERBOUND (p_cycle_array_version_2^) DO
          IF all_cycles_chosen OR p_chosen_cycles^ [cycle_index] THEN
            pfp$convert_device_class_to_pf (p_cycle_array_version_2^ [cycle_index].device_class,
                  pf_device_class);
            initialize_cycle_entry (p_cycle_array_version_2^ [cycle_index].cycle_number, pf_device_class,
                  p_cycle_array_version_2^ [cycle_index].cycle_statistics,
                  p_cycle_array_version_2^ [cycle_index].data_modification_date_time,
                  p_cycle_array_version_2^ [cycle_index].expiration_date_time,
                  (p_cycle_array_version_2^ [cycle_index].cycle_damage_symptoms + cycle_damage_symptoms),
                  p_cycle_array_version_2^ [cycle_index].shared_queue_info,
                  pfc$always_retrieve, pfc$null_site_backup_option, pfc$null_site_archive_option,
                  pfc$null_site_release_option, p_cycle_list^ [chosen_cycles_index].cycle_entry);
            pfp$compute_checksum (#LOC (p_cycle_list^ [chosen_cycles_index].cycle_entry),
                  #SIZE (pft$cycle_entry), p_cycle_list^ [chosen_cycles_index].checksum);
            chosen_cycles_index := chosen_cycles_index + 1;

            IF audit_cycle_restorations THEN
              IF family_location = pfc$local_mainframe THEN
                cycle_selector.cycle_number := p_cycle_array_version_2^ [cycle_index].cycle_number;
                audited_object.device_class := p_cycle_array_version_2^ [cycle_index].device_class;
                sfp$emit_audit_statistic (audit_information, status);
              ELSE
                p_auditable_cycles^ [cycle_index].audit := TRUE;
                p_auditable_cycles^ [cycle_index].cycle_number :=
                      p_cycle_array_version_2^ [cycle_index].cycle_number;
                p_auditable_cycles^ [cycle_index].device_class :=
                      p_cycle_array_version_2^ [cycle_index].device_class;
                p_auditable_cycles^ [cycle_index].normal_status := TRUE;
              IFEND;
            IFEND;
          ELSEIF audit_cycle_restorations AND (family_location = pfc$server_mainframe) THEN
            p_auditable_cycles^ [cycle_index].audit := FALSE;
          IFEND;
        FOREND;

        free_physical_cycle.cycle_entry.entry_type := pfc$free_cycle_entry;
        pfp$compute_checksum (#LOC (free_physical_cycle.cycle_entry), #SIZE (pft$cycle_entry),
              free_physical_cycle.checksum);

        FOR cycle_index := cycle_count + 1 TO UPPERBOUND (p_cycle_list^) DO
          p_cycle_list^ [cycle_index] := free_physical_cycle;
        FOREND;

        pfp$build_cycle_list_locator (p_cycle_list, p_catalog_file, cycle_list_locator);
      ELSE
        cycle_restorations_audited := FALSE;
        p_auditable_cycles := NIL;
      IFEND;
    ELSE
      cycle_restorations_audited := FALSE;
      p_auditable_cycles := NIL;
    IFEND;
  PROCEND put_cycle_array;

?? TITLE := '  put_cycle_info', EJECT ??

  PROCEDURE put_cycle_info
    (     p_file_group: {input} ^pft$info_record;
          p_cycle_array_version_2: {input^} ^pft$cycle_array_version_2;
          path: pft$complete_path;
          cycle_list_locator: pft$cycle_list_locator;
          restore_archive_information: boolean;
          restore_media: boolean;
          p_catalog_file: {i^/o^} ^pft$catalog_file;
      VAR cycles_media_restored: pft$cycle_count;
      VAR status: ost$status);

    VAR
      cycle_index: pft$array_index,
      cycle_list_index: pft$array_index,
      cycle_selector: pft$cycle_selector,
      media_restored: boolean,
      p_cycle_array_extended_record: ^pft$info_record,
      p_cycle_directory_array: ^pft$cycle_directory_array,
      p_cycle_info_record: ^pft$info_record,
      p_cycle_list: ^pft$cycle_list,
      p_fmd: ^pft$file_media_description;

    cycles_media_restored := 0;

    pfp$find_cycle_array_extended (p_file_group, p_cycle_array_extended_record, status);

    IF status.normal THEN
      pfp$find_cycle_directory (p_cycle_array_extended_record, p_cycle_directory_array, status);

      IF status.normal AND (p_cycle_directory_array <> NIL) THEN
        pfp$build_cycle_list_pointer (cycle_list_locator, p_catalog_file, p_cycle_list);
        cycle_list_index := 1;

        FOR cycle_index := 1 TO UPPERBOUND (p_cycle_directory_array^) DO
          IF p_cycle_directory_array^ [cycle_index].cycle_number =
                p_cycle_list^ [cycle_list_index].cycle_entry.cycle_number THEN
            pfp$find_direct_info_record (^p_cycle_array_extended_record^.body,
                  p_cycle_directory_array^ [cycle_index].info_offset, p_cycle_info_record, status);

            IF status.normal THEN
              {
              { This code takes advantage of the fact that the cycle list in
              { the catalog and both the cycle array and the cycle array
              { extended info on the backup file are in the same order.
              {
              put_cycle_media_info (^path, p_cycle_array_version_2^ [cycle_index],
                    p_cycle_directory_array^ [cycle_index], p_cycle_info_record, restore_media,
                    p_catalog_file, p_cycle_list^ [cycle_list_index], media_restored, status);
              IF NOT status.normal THEN
                RETURN;
              ELSEIF media_restored THEN
                cycles_media_restored := cycles_media_restored + 1;
              IFEND;

              IF restore_archive_information THEN
                cycle_selector.cycle_option := pfc$specific_cycle;
                cycle_selector.cycle_number := p_cycle_directory_array^ [cycle_index].cycle_number;
                put_cycle_archive_info (p_catalog_file, p_cycle_list, cycle_selector, path,
                      p_cycle_info_record, status);
                IF status.condition = pfe$unknown_archive_info THEN
                  status.normal := TRUE;  { cycle not archived }
                IFEND;
              IFEND;
            IFEND;

            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF cycle_list_index = UPPERBOUND (p_cycle_list^) THEN
              RETURN;
            IFEND;

            cycle_list_index := cycle_list_index + 1;
          IFEND;
        FOREND;
      IFEND;
    IFEND;
  PROCEND put_cycle_info;

?? TITLE := '  put_cycle_media_info', EJECT ??

  PROCEDURE put_cycle_media_info
    (    p_path: ^pft$complete_path;
         cycle_array_entry_version_2: pft$cycle_array_entry_version_2;
         cycle_directory_array_entry: pft$cycle_directory_array_entry;
         p_cycle_info_record: {input} ^pft$info_record;
         restore_media: boolean;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
     VAR physical_cycle: {i/o} pft$physical_cycle;
     VAR media_restored: boolean;
     VAR status: ost$status);

    VAR
      cycle_available: boolean,
      comparison_result: pmt$comparison_result,
      existing_sft_entry: dmt$existing_sft_entry,
      file_damaged: boolean,
      file_information: dmt$file_information,
      fmd_modified: boolean,
      fmd_size: dmt$stored_fmd_size,
      ignore_class: dmt$class,
      local_status: ost$status,
      p_cycle_label: ^fmt$file_label,
      p_cycle_label_checksum: ^pft$checksum,
      p_cycle_label_info: ^SEQ ( * ),
      p_fmd: ^pft$file_media_description,
      p_new_physical_fmd: ^pft$physical_fmd,
      p_new_stored_file_label: ^pft$physical_file_label,
      resides_on_system_device: boolean,
      system_file_id: gft$system_file_identifier;

    status.normal := TRUE;
    media_restored := FALSE;

    IF restore_media AND (cycle_array_entry_version_2.device_class = rmc$mass_storage_device) THEN
      pfp$find_cycle_media (p_cycle_info_record, p_fmd, status);
      IF status.normal THEN
        dmp$reconcile_fmd (dmv$reconcile_locator, p_fmd^.global_file_name,
              p_fmd^.file_media_descriptor, {purge_file} FALSE, ignore_class, fmd_size,
              resides_on_system_device, status);

        IF status.normal OR (status.condition = dme$some_volumes_not_online) OR
              (status.condition = dme$update_fmd) OR (status.condition = dme$volume_unavailable) OR
              (status.condition = ste$master_not_active) OR (status.condition = ste$vol_not_found) THEN
          cycle_available := status.normal OR (status.condition = dme$update_fmd);
          {
          { Dme$some_volumes_not_online, dme$volume_unavailable,
          { ste$master_not_active, and ste$vol_not_found will be detected by
          { attach.
          {
          IF status.normal OR (status.condition <> dme$update_fmd) THEN
            ALLOCATE p_new_physical_fmd: [[REP #SIZE (p_fmd^.file_media_descriptor) OF cell]] IN
                  p_catalog_file^.catalog_heap;
            IF p_new_physical_fmd = NIL THEN
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, 'cycle fmd',
                    status);
            ELSE
              status.normal := TRUE;
              p_new_physical_fmd^.fmd := p_fmd^.file_media_descriptor;
            IFEND;
          ELSE
            ALLOCATE p_new_physical_fmd: [[REP fmd_size OF cell]] IN p_catalog_file^.catalog_heap;
            IF p_new_physical_fmd = NIL THEN
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, 'cycle fmd',
                    status);
            ELSE
              dmp$get_reconciled_fmd (dmv$reconcile_locator, p_fmd^.global_file_name,
                    p_fmd^.file_media_descriptor, p_new_physical_fmd^.fmd, status);
            IFEND;
          IFEND;

          IF status.normal THEN
            pfp$compute_checksum (#LOC (p_new_physical_fmd^.fmd), #SIZE (p_new_physical_fmd^.fmd),
                  p_new_physical_fmd^.checksum);
            pfp$build_fmd_locator (p_new_physical_fmd, p_catalog_file,
                  physical_cycle.cycle_entry.fmd_locator);
            physical_cycle.cycle_entry.internal_cycle_name := cycle_directory_array_entry.internal_name;
            physical_cycle.cycle_entry.global_file_name := p_fmd^.global_file_name;

            IF cycle_available THEN
              dmp$attach_file (physical_cycle.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file,
                    p_new_physical_fmd^.fmd, $pft$usage_selections [], -$pft$share_selections [],
                    pfc$average_share_history, pfc$maximum_pf_length, {restricted_attach} FALSE,
                    {exit_on_unknown_file} FALSE, {server_file} FALSE,
                    pfp$shared_queue (physical_cycle.cycle_entry.shared_queue_info,
                    -$pft$share_selections []), file_damaged, system_file_id, existing_sft_entry, status);

              IF status.normal THEN
                pfp$detach_permanent_file (p_path, system_file_id, $pft$usage_selections [],
                      {catalog_access_allowed} TRUE, ^physical_cycle, p_catalog_file, fmd_modified,
                      file_information, status);
              IFEND;

              IF status.normal THEN
                physical_cycle.cycle_entry.device_information.eoi := file_information.eoi_byte_address;
                physical_cycle.cycle_entry.device_information.bytes_allocated :=
                      file_information.total_allocated_length;
              ELSE
                pfp$report_unexpected_status (status);
                status.normal := TRUE;
                physical_cycle.cycle_entry.attach_status.attach_count := 1;
                physical_cycle.cycle_entry.attach_status.usage_counts [pfc$modify] := 1;
                physical_cycle.cycle_entry.device_information.eoi := cycle_array_entry_version_2.eoi;
                physical_cycle.cycle_entry.device_information.bytes_allocated :=
                      cycle_array_entry_version_2.bytes_allocated;
              IFEND;
            IFEND;

            media_restored := TRUE;
          IFEND;

          IF status.normal THEN
            pfp$compute_checksum (#LOC (physical_cycle.cycle_entry), #SIZE (physical_cycle.cycle_entry),
                  physical_cycle.checksum);
          IFEND;
        ELSE { Does not reconcile
          {
          { The cycle described in the catalog no longer exists.  Leave the cycle
          { in an 'undefined data' state (NIL FMD) to allow restore_excluded_file_cycles
          { to restore it.
          {
          { This restores deleted cycles, but allows for the case of a file whose
          { only available cycle is on the backup file.
          {
          media_restored := FALSE;
          status.normal := TRUE;
        IFEND;
      ELSEIF status.condition = pfe$unknown_cycle_media THEN
        media_restored := FALSE;
        status.normal := TRUE;
      IFEND;
    ELSEIF cycle_array_entry_version_2.device_class = rmc$magnetic_tape_device THEN
      pfp$find_cycle_media (p_cycle_info_record, p_fmd, status);
      IF status.normal THEN
        pfi$store_file_media_descriptor (^p_fmd^.file_media_descriptor, p_catalog_file,
              ^physical_cycle, status);
        media_restored := status.normal;
      ELSEIF status.condition = pfe$unknown_cycle_media THEN
        media_restored := FALSE;
        status.normal := TRUE;
      IFEND;
    IFEND;

    IF status.normal THEN
      pfp$find_cycle_label (p_cycle_info_record, p_cycle_label_info, status);
      IF status.normal THEN
        RESET p_cycle_label_info;
        NEXT p_cycle_label_checksum IN p_cycle_label_info;
        NEXT p_cycle_label: [[REP (#SIZE (p_cycle_label_info^) - #SIZE (pft$checksum)) OF cell]] IN
              p_cycle_label_info;

        ALLOCATE p_new_stored_file_label: [[REP (#SIZE (p_cycle_label^)) OF cell]] IN
              p_catalog_file^.catalog_heap;
        IF p_new_stored_file_label = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, 'cycle label',
                status);
        ELSE
          p_new_stored_file_label^.file_label := p_cycle_label^;
          pfp$compute_checksum (#LOC (p_cycle_label^), #SIZE (p_cycle_label^),
                p_new_stored_file_label^.checksum);
          pfp$build_file_label_locator (p_new_stored_file_label, p_catalog_file,
                physical_cycle.cycle_entry.file_label_locator);
        IFEND;
      ELSEIF status.condition = pfe$unknown_cycle_label THEN
        status.normal := TRUE;
      IFEND;
    IFEND;

    IF status.normal THEN
      pmp$date_time_compare (physical_cycle.cycle_entry.cycle_statistics.modification_date_time,
            cycle_array_entry_version_2.cycle_statistics.modification_date_time, comparison_result,
            local_status);
      IF local_status.normal AND (comparison_result = pmc$equal) THEN
        physical_cycle.cycle_entry.retrieve_option := cycle_array_entry_version_2.retrieve_option;
        physical_cycle.cycle_entry.site_backup_option := cycle_array_entry_version_2.site_backup_option;
        physical_cycle.cycle_entry.site_archive_option := cycle_array_entry_version_2.site_archive_option;
        physical_cycle.cycle_entry.site_release_option := cycle_array_entry_version_2.site_release_option;
      IFEND;
      pfp$compute_checksum (#LOC (physical_cycle.cycle_entry), #SIZE (physical_cycle.cycle_entry),
            physical_cycle.checksum);
    IFEND;

  PROCEND put_cycle_media_info;

?? TITLE := '  put_file_info', EJECT ??

  PROCEDURE put_file_info
    (    backup_file_version: pft$backup_file_version;
         p_file_group_record: {input} ^pft$info_record;
         family_location: pft$family_location;
         path: pft$complete_path;
         ownership: pft$ownership;
         permit_level: pft$permit_level;
         selection_criteria: put$selection_criteria;
         cycle_damage_symptoms: fst$cycle_damage_symptoms;
         restore_archive_information: boolean;
         restore_media: boolean;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
         p_file_object: {output^} ^pft$physical_object;
     VAR audit_restorations: {i/o} boolean;
     VAR all_permits_restored: boolean;
     VAR p_auditable_permits: ^pft$auditable_permits;
     VAR cycle_count: pft$cycle_count;
     VAR cycles_media_restored: pft$cycle_count;
     VAR p_auditable_cycles: ^pft$auditable_cycles;
     VAR status: ost$status);

    VAR
      cycle_index: pft$cycle_index,
      cycle_list_locator: pft$cycle_list_locator,
      cycle_restorations_audited: boolean,
      file_entry: pft$object_entry,
      log_list_locator: pft$log_list_locator,
      p_cycle_array_version_1: ^pft$cycle_array,
      p_cycle_array_version_2: ^pft$cycle_array_version_2,
      p_file_description: ^pft$file_description,
      permit_list_locator: pft$permit_list_locator,
      permit_restorations_audited: boolean;

    initialize_file_object (path [UPPERBOUND (path)], file_entry);

    pfp$find_file_description (p_file_group_record, p_file_description, status);
    IF status.normal THEN
      file_entry.charge_id := p_file_description^.charge_id;
      file_entry.password := p_file_description^.password;
      file_entry.logging_selection := p_file_description^.logging_selection;

      put_permit_array (p_file_group_record, family_location, path, sfc$afsot_file, ownership, permit_level,
            audit_restorations, p_catalog_file, permit_list_locator, all_permits_restored,
            permit_restorations_audited, p_auditable_permits, status);
      IF status.normal THEN
        file_entry.permit_list_locator := permit_list_locator;

        put_log_array (p_file_group_record, p_catalog_file, log_list_locator, status);
        IF status.normal THEN
          file_entry.log_list_locator := log_list_locator;

          IF backup_file_version = pfc$backup_file_version_2 THEN
            pfp$find_cycle_array_version_2 (p_file_group_record, p_cycle_array_version_2, status);
            IF status.normal AND (p_cycle_array_version_2 = NIL) THEN
              osp$set_status_condition (pfe$unknown_cycle_array, status);
            IFEND;
          ELSE { backup_file_version = pfc$backup_file_version_1 }
            pfp$find_cycle_array (p_file_group_record, p_cycle_array_version_1, status);
            IF status.normal THEN
              IF p_cycle_array_version_1 = NIL THEN
                osp$set_status_condition (pfe$unknown_cycle_array, status);
              ELSE
                PUSH p_cycle_array_version_2: [1 .. UPPERBOUND (p_cycle_array_version_1^)];
                map_cycle_array_to_version_2 (p_cycle_array_version_1, p_cycle_array_version_2);
              IFEND;
            IFEND;
          IFEND;

          IF status.normal THEN
            put_cycle_array (p_file_group_record, p_cycle_array_version_2, family_location, path, ownership,
                  selection_criteria, cycle_damage_symptoms, restore_archive_information, audit_restorations,
                  p_catalog_file, cycle_list_locator, cycle_count, cycle_restorations_audited,
                  p_auditable_cycles, status);
          ELSE
            cycle_restorations_audited := FALSE;
          IFEND;
        ELSE
          cycle_restorations_audited := FALSE;
        IFEND;
      ELSE
        cycle_restorations_audited := FALSE;
      IFEND;
    ELSE
      permit_restorations_audited := FALSE;
      cycle_restorations_audited := FALSE;
    IFEND;

    IF status.normal AND (cycle_count <> 0) THEN
      file_entry.cycle_list_locator := cycle_list_locator;
      p_file_object^.object_entry := file_entry;
      pfp$compute_checksum (#LOC (file_entry), #SIZE (file_entry), p_file_object^.checksum);

      FOR cycle_index := 1 TO UPPERBOUND (p_cycle_array_version_2^) DO
        p_cycle_array_version_2^[cycle_index].retrieve_option := pfc$always_retrieve;
        p_cycle_array_version_2^[cycle_index].site_backup_option := pfc$null_site_backup_option;
        p_cycle_array_version_2^[cycle_index].site_archive_option := pfc$null_site_archive_option;
        p_cycle_array_version_2^[cycle_index].site_release_option := pfc$null_site_release_option;
      FOREND;
      put_cycle_info (p_file_group_record, p_cycle_array_version_2, path, cycle_list_locator,
            restore_archive_information, restore_media, p_catalog_file, cycles_media_restored, status);
    ELSE
      audit_restorations := FALSE;

      IF cycle_restorations_audited THEN
        audit_cycle_deletions (path, ownership, p_catalog_file, cycle_list_locator);
      IFEND;
      p_auditable_cycles := NIL;

      IF permit_restorations_audited THEN
        audit_permit_deletions (path, sfc$afsot_file, ownership, p_catalog_file, permit_list_locator);
      IFEND;
      p_auditable_permits := NIL;

      free_cycle_list (^path, file_entry.cycle_list_locator, p_catalog_file);
      free_log_list (^path, file_entry.log_list_locator, p_catalog_file);
      free_permit_list (^path, p_file_object, file_entry.permit_list_locator, p_catalog_file);
    IFEND;
  PROCEND put_file_info;

?? TITLE := '  put_log_array', EJECT ??

  PROCEDURE put_log_array
    (    p_file_group_record: pft$p_info_record;
         p_catalog_file: pft$p_catalog_file;
     VAR log_list_locator: pft$log_list_locator;
     VAR status: ost$status);

    VAR
      free_physical_log: pft$physical_log,
      log_array_entry: pft$log_array_entry,
      log_count: integer,
      log_entry: pft$log_entry,
      log_index: pft$array_index,
      p_catalog_heap: pft$p_catalog_heap,
      p_log_array: pft$p_log_array,
      p_log_list: pft$p_log_list;

    pfp$find_log_array (p_file_group_record, p_log_array, status);
    IF status.normal THEN
      IF p_log_array = NIL THEN
        pfp$build_log_list_locator (NIL, NIL, log_list_locator);
      ELSE
        log_count := UPPERBOUND (p_log_array^);
        p_catalog_heap := ^p_catalog_file^.catalog_heap;
        pfp$allocate_log_list (log_count, p_catalog_heap, p_log_list, status);
        IF status.normal THEN
          FOR log_index := 1 TO log_count DO
            log_array_entry := p_log_array^ [log_index];
            log_entry.entry_type := pfc$normal_log_entry;
            log_entry.user_id := log_array_entry.user_id;
            log_entry.access_date_time := log_array_entry.access_date_time;
            log_entry.access_count := log_array_entry.access_count;
            log_entry.last_cycle := log_array_entry.last_cycle;
            p_log_list^ [log_index].log_entry := log_entry;
            pfp$compute_checksum (#LOC (log_entry), #SIZE (log_entry), p_log_list^ [log_index].checksum);
          FOREND;

          free_physical_log.log_entry.entry_type := pfc$free_log_entry;
          pfp$compute_checksum (#LOC (free_physical_log.log_entry), #SIZE (pft$log_entry),
                free_physical_log.checksum);

          FOR log_index := log_count + 1 TO UPPERBOUND (p_log_list^) DO
            p_log_list^ [log_index] := free_physical_log;
          FOREND;

          pfp$build_log_list_locator (p_log_list, p_catalog_file, log_list_locator);
        IFEND;
      IFEND;
    ELSE
      IF status.condition = pfe$nil_pointer THEN
        status.normal := TRUE;
        pfp$build_log_list_locator (NIL, NIL, log_list_locator);
      IFEND;
    IFEND;
  PROCEND put_log_array;

?? TITLE := '  put_new_cycles_media', EJECT ??

  PROCEDURE put_new_cycles_media
    (    backup_file_version: pft$backup_file_version;
         p_file_group: {input} ^pft$info_record;
         path: pft$complete_path;
         ownership: pft$ownership;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
         p_file_object: {i^/o^} ^pft$physical_object;
     VAR cycles_created: pft$cycle_count;
     VAR cycles_media_restored: pft$cycle_count;
     VAR status: ost$status);

    VAR
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id,
      cycle_entry: pft$cycle_entry,
      cycle_index: pft$array_index,
      cycle_selector: pft$cycle_selector,
      media_restored: boolean,
      p_archive_info: ^pft$info,
      p_archive_info_record: ^pft$info_record,
      p_cycle: ^pft$physical_cycle,
      p_cycle_array_extended_record: ^pft$info_record,
      p_cycle_array_version_1: ^pft$cycle_array,
      p_cycle_array_version_2: ^pft$cycle_array_version_2,
      p_cycle_directory_array: ^pft$cycle_directory_array,
      p_cycle_info_extended_body: ^pft$info,
      p_cycle_info_record: ^pft$info_record,
      p_cycle_list: ^pft$cycle_list,
      pf_device_class: pft$device_class;

    cycles_created := 0;
    cycles_media_restored := 0;

    IF backup_file_version = pfc$backup_file_version_2 THEN
      pfp$find_cycle_array_version_2 (p_file_group, p_cycle_array_version_2, status);
      IF status.normal AND (p_cycle_array_version_2 = NIL) THEN
        osp$set_status_condition (pfe$unknown_cycle_array, status);
      IFEND;
    ELSE { backup_file_version = pfc$backup_file_version_1 }
      pfp$find_cycle_array (p_file_group, p_cycle_array_version_1, status);
      IF status.normal AND (p_cycle_array_version_1 = NIL) THEN
        osp$set_status_condition (pfe$unknown_cycle_array, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      pfp$find_cycle_array_extended (p_file_group, p_cycle_array_extended_record, status);
    IFEND;

    IF status.normal THEN
      pfp$find_cycle_directory (p_cycle_array_extended_record, p_cycle_directory_array, status);

      IF status.normal AND (p_cycle_directory_array <> NIL) THEN
        IF backup_file_version = pfc$backup_file_version_1 THEN
          PUSH p_cycle_array_version_2: [1 .. UPPERBOUND (p_cycle_array_version_1^)];
          map_cycle_array_to_version_2 (p_cycle_array_version_1, p_cycle_array_version_2);
        IFEND;

        pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator, p_catalog_file,
              p_cycle_list);
        cycle_selector.cycle_option := pfc$specific_cycle;

        FOR cycle_index := 1 TO UPPERBOUND (p_cycle_array_version_2^) DO
          pfp$locate_specific_cycle (p_cycle_list, p_cycle_array_version_2^ [cycle_index].cycle_number,
                p_cycle);

          IF p_cycle = NIL THEN
            cycle_selector.cycle_number := p_cycle_array_version_2^ [cycle_index].cycle_number;
            pfp$convert_device_class_to_pf (p_cycle_array_version_2^ [cycle_index].device_class,
                  pf_device_class);
            initialize_cycle_entry (cycle_selector.cycle_number, pf_device_class,
                  p_cycle_array_version_2^ [cycle_index].cycle_statistics,
                  p_cycle_array_version_2^ [cycle_index].data_modification_date_time,
                  p_cycle_array_version_2^ [cycle_index].expiration_date_time,
                  $fst$cycle_damage_symptoms [fsc$respf_modification_mismatch, fsc$parent_catalog_restored],
                  p_cycle_array_version_2^ [cycle_index].shared_queue_info,
                  pfc$always_retrieve, pfc$null_site_backup_option, pfc$null_site_archive_option,
                  pfc$null_site_release_option, cycle_entry);
            add_cycle_entry (^path, cycle_entry, p_file_object, p_catalog_file, status);

            IF NOT status.normal THEN
              IF avp$security_option_active (avc$vso_security_audit) THEN
                audit_information.audited_operation := sfc$ao_fs_create_object;
                audited_object.variant_path.complete_path := TRUE;
                audited_object.variant_path.p_complete_path := ^path;
                audited_object.object_type := sfc$afsot_cycle;
                audited_object.cycle_selector_p := ^cycle_selector;
                audited_object.device_class := p_cycle_array_version_2^ [cycle_index].device_class;
                audit_information.create_fs_object.object_id_p := ^audited_object;
                audit_information.create_fs_object.ownership := ownership;
                sfp$emit_audit_statistic (audit_information, status);
              IFEND;
              RETURN;
            IFEND;

            cycles_created := cycles_created + 1;
            pfp$find_direct_info_record (^p_cycle_array_extended_record^.body,
                  p_cycle_directory_array^ [cycle_index].info_offset, p_cycle_info_record, status);
            IF status.normal THEN
              {
              { This code takes advantage of the fact that the cycle list in
              { the catalog and both the cycle array and the cycle array
              { extended info on the backup file are in the same order.
              {
              put_cycle_media_info (^path, p_cycle_array_version_2^ [cycle_index],
                    p_cycle_directory_array^ [cycle_index], p_cycle_info_record, {restore_media} TRUE,
                    p_catalog_file, p_cycle_list^ [cycle_index], media_restored, status);
            IFEND;

            IF avp$security_option_active (avc$vso_security_audit) THEN
              audit_information.audited_operation := sfc$ao_fs_create_object;
              audited_object.variant_path.complete_path := TRUE;
              audited_object.variant_path.p_complete_path := ^path;
              audited_object.object_type := sfc$afsot_cycle;
              audited_object.cycle_selector_p := ^cycle_selector;
              audited_object.device_class := p_cycle_array_version_2^ [cycle_index].device_class;
              audit_information.create_fs_object.object_id_p := ^audited_object;
              audit_information.create_fs_object.ownership := ownership;
              sfp$emit_audit_statistic (audit_information, status);
            IFEND;

            IF status.normal THEN
              IF media_restored THEN
                cycles_media_restored := cycles_media_restored + 1;
              IFEND;

              put_cycle_archive_info (p_catalog_file, p_cycle_list, cycle_selector, path, p_cycle_info_record,
                    status);
            IFEND;

            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        FOREND;
      IFEND;
    IFEND;
  PROCEND put_new_cycles_media;

?? TITLE := '  put_permit_array', EJECT ??

  PROCEDURE put_permit_array
    (    p_file_group_record: {input} ^pft$info_record;
         family_location: pft$family_location;
         path: pft$complete_path;
         object_type: sft$audited_fs_object_type;
         ownership: pft$ownership;
         permit_level: pft$permit_level;
         audit_permit_restorations: boolean;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
     VAR permit_list_locator: pft$permit_list_locator;
     VAR all_permits_restored: boolean;
     VAR permit_restorations_audited: boolean;
     VAR p_auditable_permits: ^pft$auditable_permits;
     VAR status: ost$status);

    VAR
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id,
      free_physical_permit: pft$physical_permit,
      p_catalog_heap: ^pft$catalog_heap,
      p_permit_array: ^pft$permit_array,
      p_permit_list: ^pft$permit_list,
      permit_count: pft$permit_count,
      permit_entry: pft$permit_entry,
      permit_index: pft$array_index;

    all_permits_restored := TRUE;

    pfp$find_permit_array (p_file_group_record, p_permit_array, status);
    IF status.normal THEN
      IF p_permit_array = NIL THEN
        permit_restorations_audited := FALSE;
        p_auditable_permits := NIL;
        pfp$build_permit_list_locator ({p_permit_list} NIL, p_catalog_file, permit_list_locator);
      ELSE
        permit_count := UPPERBOUND (p_permit_array^);
        p_catalog_heap := ^p_catalog_file^.catalog_heap;
        pfp$allocate_permit_list (permit_count, p_catalog_heap, p_permit_list, status);

        IF status.normal THEN
          free_physical_permit.permit_entry.entry_type := pfc$free_permit_entry;
          pfp$compute_checksum (#LOC (free_physical_permit.permit_entry), #SIZE (pft$permit_entry),
                free_physical_permit.checksum);

          IF audit_permit_restorations AND (family_location = pfc$local_mainframe) THEN
            audit_information.audited_operation := sfc$ao_fs_create_permit;
            audited_object.variant_path.complete_path := TRUE;
            audited_object.variant_path.p_complete_path := ^path;
            audited_object.object_type := object_type;
            audit_information.create_fs_permit.object_id_p := ^audited_object;
            audit_information.create_fs_permit.ownership := ownership;
            permit_restorations_audited := TRUE;
          ELSE
            permit_restorations_audited := FALSE;
          IFEND;

          FOR permit_index := 1 TO permit_count DO
            IF pfv$system_administrator OR pfv$family_administrator THEN
              status.normal := TRUE;
            ELSE
              pfp$check_group_by_permit_level (permit_level, p_permit_array^ [permit_index].group, status);
            IFEND;

            IF status.normal THEN
              permit_entry.entry_type := pfc$normal_permit_entry;
              permit_entry.group := p_permit_array^ [permit_index].group;
              permit_entry.usage_permissions := p_permit_array^ [permit_index].usage_permissions;
              permit_entry.share_requirements := p_permit_array^ [permit_index].share_requirements;
              permit_entry.application_info := p_permit_array^ [permit_index].application_info;
              p_permit_list^ [permit_index].permit_entry := permit_entry;
              pfp$compute_checksum (#LOC (permit_entry), #SIZE (permit_entry),
                    p_permit_list^ [permit_index].checksum);
            ELSE
              p_permit_list^ [permit_index] := free_physical_permit;
              all_permits_restored := FALSE;
            IFEND;

            IF audit_permit_restorations THEN
              IF family_location = pfc$local_mainframe THEN
                audit_information.create_fs_permit.group_p := ^p_permit_array^ [permit_index].group;
                audit_information.create_fs_permit.permit_selections_p :=
                      ^p_permit_array^ [permit_index].usage_permissions;
                sfp$emit_audit_statistic (audit_information, status);
              ELSE
                p_auditable_permits^ [permit_count].group := p_permit_array^ [permit_index].group;
                p_auditable_permits^ [permit_count].permit_selections :=
                      p_permit_array^ [permit_index].usage_permissions;
                IF status.normal THEN
                  p_auditable_permits^ [permit_count].normal_status := TRUE;
                ELSE
                  p_auditable_permits^ [permit_count].normal_status := FALSE;
                  p_auditable_permits^ [permit_count].condition := status.condition;
                IFEND;
              IFEND;
            IFEND;
          FOREND;

          FOR permit_index := permit_count + 1 TO UPPERBOUND (p_permit_list^) DO
            p_permit_list^ [permit_index] := free_physical_permit;
          FOREND;

          pfp$build_permit_list_locator (p_permit_list, p_catalog_file, permit_list_locator);
          status.normal := TRUE;
        ELSE
          permit_restorations_audited := FALSE;
          p_auditable_permits := NIL;
        IFEND;
      IFEND;
    ELSE
      permit_restorations_audited := FALSE;
      p_auditable_permits := NIL;
      IF status.condition = pfe$nil_pointer THEN
        pfp$build_permit_list_locator ({p_permit_list} NIL, p_catalog_file, permit_list_locator);
        status.normal := TRUE;
      IFEND;
    IFEND;
  PROCEND put_permit_array;

?? TITLE := '  recreate_catalog_entry', EJECT ??
{ PURPOSE:
{   This procedure recreates the catalog entry and stores the file media
{   descriptor from the backup.  The files in the catalog need not be marked as
{   damaged, as this catalog is the current one on the disk.

  PROCEDURE recreate_catalog_entry
    (    p_catalog_group: {input} ^pft$info_record;
         path: pft$complete_path;
         ownership: pft$ownership;
         p_catalog_media_description: {input^} ^pft$catalog_media_description;
         p_backup_catalog_fmd: {input^} ^SEQ ( * );
         p_parent_catalog_file: {i^/o^} ^pft$catalog_file;
         p_catalog_object: {output^} ^pft$physical_object;
     VAR status: ost$status);

    VAR
      all_permits_restored: boolean,
      audit_permit_restorations: boolean,
      p_auditable_permits: ^pft$auditable_permits,
      p_catalog_description: pft$p_catalog_description,
      p_catalog_fmd: pft$p_physical_fmd,
      permit_list_locator: pft$permit_list_locator,
      permit_restorations_audited: boolean;

    pfp$find_catalog_description (p_catalog_group, p_catalog_description, status);

    IF status.normal THEN
      audit_permit_restorations := avp$security_option_active (avc$vso_security_audit);
      p_auditable_permits := NIL;
      put_permit_array (p_catalog_group, pfc$local_mainframe, path, sfc$afsot_catalog, ownership,
            pfc$pl_public, audit_permit_restorations, p_parent_catalog_file, permit_list_locator,
            all_permits_restored, permit_restorations_audited, p_auditable_permits, status);
    IFEND;

    IF status.normal THEN
      ALLOCATE p_catalog_fmd: [[REP #SIZE (p_backup_catalog_fmd^) OF cell]] IN
            p_parent_catalog_file^.catalog_heap;
      IF p_catalog_fmd = NIL THEN
        IF permit_restorations_audited THEN
          audit_permit_deletions (path, sfc$afsot_catalog, ownership, p_parent_catalog_file,
                permit_list_locator);
        IFEND;
        free_permit_list (^path, p_catalog_object, permit_list_locator, p_parent_catalog_file);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, 'catalog fmd', status);
      IFEND;
    IFEND;

    IF status.normal THEN
      p_catalog_object^.object_entry.external_object_name := path [UPPERBOUND (path)];
      p_catalog_object^.object_entry.internal_object_name := p_catalog_media_description^.internal_name;
      p_catalog_object^.object_entry.permit_list_locator := permit_list_locator;
      p_catalog_object^.object_entry.charge_id := p_catalog_description^.charge_id;
      p_catalog_object^.object_entry.reserved_object_entry_space := pfv$null_object_entry_space;
      p_catalog_object^.object_entry.object_type := pfc$catalog_object;
      p_catalog_object^.object_entry.catalog_object_locator.catalog_type := pfc$external_catalog;

      p_catalog_fmd^.fmd := p_backup_catalog_fmd^;
      pfp$compute_checksum (#LOC (p_catalog_fmd^.fmd), #SIZE (p_catalog_fmd^.fmd), p_catalog_fmd^.checksum);
      pfp$build_fmd_locator (p_catalog_fmd, p_parent_catalog_file,
            p_catalog_object^.object_entry.catalog_object_locator.fmd_locator);

      p_catalog_object^.object_entry.catalog_object_locator.global_file_name :=
            p_catalog_media_description^.global_file_name;
      p_catalog_object^.object_entry.catalog_recreated_by_restore := FALSE;
      p_catalog_object^.object_entry.reserved_catalog_entry_space := pfv$null_catalog_entry_space;

      pfp$compute_checksum (#LOC (p_catalog_object^.object_entry), #SIZE (p_catalog_object^.object_entry),
            p_catalog_object^.checksum);
    IFEND;
  PROCEND recreate_catalog_entry;

?? TITLE := '  recreate_catalog_media', EJECT ??
{ PURPOSE:
{   This procedure recreates the catalog, but leaves the catalog entry
{   (permits and charge) as is.
{
{ DESIGN:
{   The catalog contents will be reconstructed from files and subcatalogs yet
{   to be found on the backup file.  The file media descriptor of this catalog
{   from the backup file is not used, because it is not valid.  If the catalog
{   has not moved via pf recovery, then the fmd on the backup file describes a
{   catalog on an inactive device.  If the catalog has moved via pf recovery,
{   then the fmd on the backup file describes a catalog deleted via pf
{   recovery.  An attempt could be made to reconcile the fmd from the backup
{   file and, if it reconciles, to destroy it.

  PROCEDURE recreate_catalog_media
    (    path: pft$complete_path;
         authority: pft$authority;
         p_parent_catalog_file: {i^/o^} ^pft$catalog_file;
         p_catalog_object: {i^/o^} ^pft$physical_object;
     VAR status: ost$status);

    CONST
      system_privilege = TRUE;

    VAR
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id,
      local_status: ost$status,
      new_catalog_locator: pft$catalog_locator,
      p_new_physical_fmd: pft$p_physical_fmd;

    pfp$create_catalog (path, {mass storage request} NIL, authority, {lock_catalog} TRUE,
          new_catalog_locator, status);
    IF status.normal THEN
      pfp$record_dm_file_parameters (^path, {p_cycle_number} NIL, new_catalog_locator.system_file_id,
            rmc$mass_storage_device, {p_removable_media_req_info} NIL, {p_volume_list} NIL,
            ^p_parent_catalog_file^.catalog_heap, p_new_physical_fmd, status);
      IF status.normal THEN
        pfp$build_fmd_locator (p_new_physical_fmd, p_parent_catalog_file,
              p_catalog_object^.object_entry.catalog_object_locator.fmd_locator);
        p_catalog_object^.object_entry.catalog_object_locator.global_file_name :=
              new_catalog_locator.global_file_name;
        p_catalog_object^.object_entry.internal_object_name := new_catalog_locator.internal_catalog_name;
        p_catalog_object^.object_entry.catalog_recreated_by_restore := TRUE;
        pfp$compute_checksum (#LOC (p_catalog_object^.object_entry), #SIZE (p_catalog_object^.object_entry),
              p_catalog_object^.checksum);
      ELSE
        pfp$destroy_catalog (new_catalog_locator, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;
    IFEND;

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_information.audited_operation := sfc$ao_fs_create_object;
      audited_object.variant_path.complete_path := TRUE;
      audited_object.variant_path.p_complete_path := ^path;
      audited_object.object_type := sfc$afsot_catalog;
      audit_information.create_fs_object.object_id_p := ^audited_object;
      audit_information.create_fs_object.ownership := authority.ownership;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;

    IF status.normal THEN
      pfp$return_catalog (new_catalog_locator, status);
    IFEND;
  PROCEND recreate_catalog_media;

?? OLDTITLE, SKIP := 2 ??
MODEND pfm$r2_put_info;
*DECK DECK=PFM$R2_REQUEST_PROCESSOR EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Permanent Files : Ring 2 Interfaces' ??
MODULE pfm$r2_request_processor;
?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$open_validation_errors
*copyc dfd$file_server_info
*copyc dfe$error_condition_codes
*copyc dfk$file_server_info_keypoints
*copyc dmd$null_global_file_name
*copyc dmt$error_condition_codes
*copyc dmt$stored_fmd_size
*copyc fmc$unique_label_id
*copyc fmt$static_label_header
*copyc fst$volume_condition_list
*copyc dmt$stored_tape_fmd_header
*copyc dmt$stored_tape_volume_list
*copyc fsc$local
*copyc fse$open_validation_errors
*copyc fse$path_exception_conditions
*copyc fse$system_conditions
*copyc fsk$keypoints
*copyc fst$file_changes
*copyc fst$path_resolution
*copyc gft$system_file_identifier
*copyc osd$integer_limits
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc pfc$null_shared_queue
*copyc pfc$test_jr_constants
*copyc pfd$catalog_info
*copyc pfd$mandated_modification_time
*copyc pfd$share_selector
*copyc pfd$usage_selector
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pfk$keypoints
*copyc pft$data_residence
*copyc pft$date_time
*copyc pft$exception_selection_info
*copyc pft$permit_level
*copyc pft$purge_cycle_options
*copyc pft$r2_attach_in
*copyc pft$release_data_info
*copyc pft$save_label_audit_info
*copyc pft$unique_volume_list
*copyc put$restore_data_selections
*copyc rme$request_mass_storage
*copyc rmt$device_class
?? POP ??
?? EJECT ??
*copyc avp$security_option_active
*copyc clp$convert_file_ref_to_string
*copyc clp$get_variable_value
*copyc clp$validate_new_file_name
*copyc clp$verify_time_increment
*copyc dfp$check_self_serving_job
*copyc dfp$fetch_served_family_entry
*copyc dfp$get_job_server_state
*copyc dfp$locate_served_family
*copyc dfv$file_server_info_enabled
*copyc dmp$attach_file
*copyc dmp$change_file_damaged
*copyc dmp$change_sft_damage_detection
*copyc dmp$change_sft_file_damaged
*copyc dmp$delete_file_descriptor
*copyc dmp$destroy_file
*copyc dmp$destroy_permanent_file
*copyc dmp$detach_file
*copyc dmp$enable_damage_detection
*copyc dmp$get_stored_fmd_header_info
*copyc dmp$get_stored_fmd_volume_list
*copyc dmp$get_unique_fmd_volume_list
*copyc dmp$locate_existing_sft_entry
*copyc dmv$null_sfid
*copyc dmv$active_volume_table
*copyc fmi$get_ring_attributes
*copyc fmi$validate_ring_attributes
*copyc fmp$change_recorded_cycle_num
*copyc fmp$change_recorded_file_name
*copyc fmp$delete_path_description
*copyc fmp$extract_dynamic_setfa_attrs
*copyc fmp$get_path_table_cycle_info
*copyc fmp$locate_cd_via_path_handle
*copyc fmp$lock_path_table
*copyc fmp$process_pt_request
*copyc fmp$unlock_path_table
*copyc fmp$validate_system_label
*copyc fmv$default_file_attributes
*copyc fsp$convert_device_class_to_fs
*copyc fsp$expand_file_label
*copyc fsp$path_element
*copyc i#move
*copyc iop$tape_file_attached
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$clear_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$file_access_condition
*copyc osp$generate_log_message
*copyc osp$generate_unique_binary_name
*copyc osp$get_set_name
*copyc osp$get_volume_condition
*copyc osp$log_job_recovery_message
*copyc osp$log_job_recovery_status
*copyc osp$prevalidate_free
*copyc osp$recoverable_system_error
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$test_signature_lock
*copyc osv$recover_system_set_phase
*copyc osv$system_family_name
*copyc osv$task_shared_heap
*copyc pfi$convert_cycle_reference
*copyc pfi$get_create_file_option
*copyc pfi$get_password
*copyc pfi$store_file_media_descriptor
*copyc pfp$access_last_object
*copyc pfp$access_next_catalog
*copyc pfp$access_object
*copyc pfp$allocate_archive_list
*copyc pfp$allocate_cycle_list
*copyc pfp$allocate_log_list
*copyc pfp$allocate_permit_list
*copyc pfp$assign_locked_apfid
*copyc pfp$attach_catalog
*copyc pfp$attach_permanent_file
*copyc pfp$audit_save_label
*copyc pfp$build_amd_locator
*copyc pfp$build_amd_pointer
*copyc pfp$build_archive_list_locator
*copyc pfp$build_archive_list_pointer
*copyc pfp$build_cycle_list_locator
*copyc pfp$build_cycle_list_pointer
*copyc pfp$build_file_label_locator
*copyc pfp$build_file_label_pointer
*copyc pfp$build_fmd_locator
*copyc pfp$build_fmd_pointer
*copyc pfp$build_log_list_locator
*copyc pfp$build_log_list_pointer
*copyc pfp$build_mainfram_list_locator
*copyc pfp$build_mainfram_list_pointer
*copyc pfp$build_object_list_locator
*copyc pfp$build_permit_list_locator
*copyc pfp$build_permit_list_pointer
*copyc pfp$build_permit_selections_str
*copyc pfp$catalog_access_retry_wait
*copyc pfp$change_object_name
*copyc pfp$check_catalog_alarm
*copyc pfp$clear_cycle_attachments
*copyc pfp$compute_checksum
*copyc pfp$convert_cycle_path_to_strng
*copyc pfp$convert_density_to_dm
*copyc pfp$convert_device_class_to_pf
*copyc pfp$convert_device_class_to_rm
*copyc pfp$convert_fs_to_complete_path
*copyc pfp$convert_fs_to_pft$path
*copyc pfp$convert_pf_path_to_fs_path
*copyc pfp$convert_pf_to_fs_structure
*copyc pfp$convert_pft$path_to_fs_str
*copyc pfp$convert_shared_queue_to_ord
*copyc pfp$create_catalog
*copyc pfp$create_permanent_file
*copyc pfp$cycle_attached_for_write
*copyc pfp$destroy_catalog
*copyc pfp$delete_catalog_object
*copyc pfp$delete_file_object
*copyc pfp$detach_all_catalogs
*copyc pfp$detach_all_files
*copyc pfp$detach_permanent_file
*copyc pfp$detach_unavail_queued_cat
*copyc pfp$determine_new_cycle_number
*copyc pfp$establish_free_cycle_entry
*copyc pfp$extract_permit_entry
*copyc pfp$form_administrator_permit
*copyc pfp$get_allowed_device_classes
*copyc pfp$get_authority
*copyc pfp$get_catalog
*copyc pfp$get_cycle_damage_options
*copyc pfp$get_ownership
*copyc pfp$get_rem_media_req_info
*copyc pfp$get_rem_media_volume_list
*copyc pfp$internal_access_object
*copyc pfp$internal_locate_object
*copyc pfp$locate_attached_file
*copyc pfp$locate_cycle
*copyc pfp$locate_log_entry
*copyc pfp$locate_object
*copyc pfp$lock_apfid
*copyc pfp$log_ascii
*copyc pfp$log_error
*copyc pfp$log_path
*copyc pfp$map_usage_selections
*copyc pfp$process_unexpected_status
*copyc pfp$r2_build_archive_entry
*copyc pfp$r2_df_client_attach
*copyc pfp$r2_df_client_attach_or_cref
*copyc pfp$r2_df_client_clear_cy_att
*copyc pfp$r2_df_client_return
*copyc pfp$r2_df_client_save_label
*copyc pfp$r2_df_client_validate_pw
*copyc pfp$reattach_server_file
*copyc pfp$reconcile_fmd
*copyc pfp$record_dm_file_parameters
*copyc pfp$reduce_permits
*copyc pfp$release_locked_apfid
*copyc pfp$remove_queued_catalogs
*copyc pfp$report_unexpected_status
*copyc pfp$report_system_error
*copyc pfp$return_catalog
*copyc pfp$set_status_abnormal
*copyc pfp$setup_attached_pf_recovery
*copyc pfp$share_for_write
*copyc pfp$shared_queue
*copyc pfp$system_privilege_authority
*copyc pfp$unlock_apfid
*copyc pfp$unlock_catalog_pages
*copyc pfp$update_object_list_locator
*copyc pfp$validate_default_password
*copyc pfp$validate_family_ownership
*copyc pfp$validate_file_permission
*copyc pfp$validate_ored_permission
*copyc pfp$validate_ownership
*copyc pfp$validate_password
*copyc pfp$validate_ring_access
*copyc pfv$flush_catalogs
*copyc pfv$locked_apfid
*copyc pfv$null_tape_fmd_header_space
*copyc pfv$null_unique_name
*copyc pfv$p_locked_catalog
*copyc pfv$p_p_job_heap
*copyc pfv$reserved_cycle_info
*copyc pfv$restrict_catalog_flushing
*copyc pfv$space_character
*copyc pfv$system_authority
*copyc pfv$task_family
*copyc pfv$task_user
*copyc pmp$compute_date_time
*copyc pmp$continue_to_cause
*copyc pmp$date_time_compare
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pmp$get_compact_date_time
*copyc pmp$get_pseudo_mainframe_id
*copyc pmp$log_ascii
*copyc rmp$build_mass_storage_info
*copyc sfp$accumulate_file_space
*copyc sfp$auditing_operation
*copyc sfp$emit_audit_statistic
*copyc stp$get_pf_root
*copyc stv$system_set_name
*copyc syp$hang_if_job_jrt_set
*copyc syp$invalidate_open_sfid
*copyc syp$pop_inhibit_job_recovery
*copyc syp$push_inhibit_job_recovery
*copyc syp$replace_sfid

?? TITLE := '  Global Declarations Declared by this module', EJECT ??

  CONST
    include_radix = TRUE,
    inhibit_path_table_lock = TRUE,
    maximum_group_type_string_size = 12,
    max_free_result_string = 26,
    radix = 10;

  VAR
    pfv$allow_catalog_write: [XDCL, #GATE, oss$task_private] boolean := FALSE,
    pfv$null_catalog_entry_space: [XDCL, oss$job_paged_literal, READ] array [1 .. 47] of boolean :=
          [REP 47 OF FALSE],
    pfv$null_cycle_entry_space: [XDCL, oss$job_paged_literal, READ] array [1 .. 34] of boolean :=
          [REP 34 OF FALSE],
    pfv$null_date_time: [XDCL, oss$job_paged_literal, READ] ost$date_time :=
          [{year} 1, {month} 1, {day} 1, {hour} 0, {minute} 0, {second} 0, {millisecond} 0],
    pfv$null_file_entry_space: [XDCL, oss$job_paged_literal, READ] array [1 .. 48] of boolean :=
          [REP 48 OF FALSE],
    pfv$null_object_entry_space: [XDCL, oss$job_paged_literal, READ] array [1 .. 6] of integer :=
          [REP 6 OF 0],
    pfv$unattached_status: [XDCL, oss$job_paged_literal, READ] pft$attach_status :=
          [0, [REP 5 OF 0], [REP 5 OF 0]],
    pfv$unlock_catalog_threshold: [XDCL, #GATE] integer := 500,
    pfv$write_usage: [XDCL, #GATE, oss$job_paged_literal, READ] pft$usage_selections :=
          [pfc$shorten, pfc$append, pfc$modify];

  VAR
    null_archive_entry_space: [oss$job_paged_literal, READ] array [1 .. 48] of boolean := [REP 48 OF FALSE],
    prevalidate_free_result_strings: [oss$job_paged_literal, READ]
          array [ost$prevalidate_free_result] of record
          size: 1 .. max_free_result_string,
          value: string (max_free_result_string), recend :=
          [[26, 'HEAP_ALLOCATION_ID_INVALID'], [15, 'HEAP_FREE_VALID'], [20, 'HEAP_LINKAGE_INVALID'],
          [20, 'HEAP_POINTER_INVALID'], [25, 'HEAP_VERIFICATION_FAILURE']],
    process_pt_work_list: [oss$job_paged_literal, READ] bat$process_pt_work_list :=
          [bac$inhibit_locking_pt, bac$record_path, bac$resolve_path];


?? TITLE := '  [XDCL] pfp$build_archive_entry', EJECT ??

  PROCEDURE [XDCL] pfp$build_archive_entry (
        archive_identification: pft$archive_identification;
        p_archive_array_entry: pft$p_archive_array_entry;
        p_physical_amd: pft$p_physical_amd,
        p_catalog_file: pft$p_catalog_file;
        p_archive: pft$p_archive;
    VAR status: ost$status);

    status.normal := TRUE;

    p_archive^.archive_entry.version := pfc$archive_entry_version_1;
    p_archive^.archive_entry.archive_date_time := p_archive_array_entry^.archive_date_time;
    p_archive^.archive_entry.archive_identification := archive_identification;
    p_archive^.archive_entry.file_size := p_archive_array_entry^.file_size;
    p_archive^.archive_entry.last_release_date_time := p_archive_array_entry^.last_release_date_time;
    p_archive^.archive_entry.last_retrieval_status := p_archive_array_entry^.last_retrieval_status;
    p_archive^.archive_entry.modification_date_time := p_archive_array_entry^.modification_date_time;
    p_archive^.archive_entry.release_candidate := p_archive_array_entry^.release_candidate;
    p_archive^.archive_entry.reserved_archive_entry_space := null_archive_entry_space;

    pfp$build_amd_locator (p_physical_amd, p_catalog_file,  p_archive^.archive_entry.amd_locator);

    pfp$compute_checksum (#LOC (p_physical_amd^.amd), #SIZE (p_physical_amd^.amd),
        p_physical_amd^.checksum);

    pfp$compute_checksum (#LOC (p_archive^.archive_entry), #SIZE (p_archive^.archive_entry),
        p_archive^.checksum);

  PROCEND pfp$build_archive_entry;

?? TITLE := '  [XDCL] pfp$check_archive_entries', EJECT ??

  PROCEDURE [XDCL] pfp$check_archive_entries
    (    p_catalog_file: {input^} pft$p_catalog_file;
         p_cycle: {input^} pft$p_cycle;
     VAR valid_archive_entry_exists: boolean;
     VAR status: ost$status);

    VAR
      archive_date_time: ost$date_time,
      archive_index: pft$archive_index,
      comparison_result: pmt$comparison_result,
      data_modification_date_time: ost$date_time,
      p_archive_list: pft$p_archive_list;

    pfp$build_archive_list_pointer (p_cycle^.cycle_entry.archive_list_locator, p_catalog_file,
          p_archive_list);
    IF p_archive_list = NIL THEN
      status.normal := TRUE;
      valid_archive_entry_exists := FALSE;
    ELSE
      archive_date_time := p_archive_list^ [1].archive_entry.archive_date_time;
    /search_archive_list/
      FOR archive_index := 1 TO UPPERBOUND (p_archive_list^) DO
        pmp$date_time_compare (p_archive_list^ [archive_index].archive_entry.archive_date_time,
              archive_date_time, comparison_result, status);
        IF NOT status.normal THEN
          CYCLE /search_archive_list/;
        IFEND;
        IF comparison_result = pmc$left_is_greater THEN
          archive_date_time := p_archive_list^ [archive_index].archive_entry.archive_date_time;
        IFEND;
      FOREND /search_archive_list/;

      IF p_cycle^.cycle_entry.data_modification_date_time.year > 0 THEN
        data_modification_date_time := p_cycle^.cycle_entry.data_modification_date_time;
      ELSE
        data_modification_date_time := p_cycle^.cycle_entry.cycle_statistics.modification_date_time;
      IFEND;
      pmp$date_time_compare (archive_date_time, data_modification_date_time, comparison_result,
            status);
      valid_archive_entry_exists := status.normal AND (comparison_result = pmc$left_is_greater);
    IFEND;

  PROCEND pfp$check_archive_entries;

?? TITLE := '  [XDCL] pfp$check_cycle_busy', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to determine if the current
{   file activity specified by the attach_status would allow the proposed
{   activity specified by the usage_intentions and share_intentions.
{   This procedure also determines if the requested usage conflicts with
{   usage by another mainframe.

  PROCEDURE [XDCL] pfp$check_cycle_busy
    (    path: pft$complete_path;
         usage_intentions: pft$permit_selections;
         share_intentions: pft$share_selections;
         mainframe_id: pmt$binary_mainframe_id;
         p_catalog_file: {input^} ^pft$catalog_file;
         cycle_entry: pft$cycle_entry;
     VAR status: ost$status);

    VAR
      fs_path_size: fst$path_size,
      p_fs_path: ^fst$path;

    status.normal := TRUE;

    IF cycle_entry.attach_status.attach_count > 0 THEN
      IF cycle_busy_due_to_usage (cycle_entry.attach_status, usage_intentions) THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_busy, p_fs_path^ (1, fs_path_size),
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, cycle_entry.cycle_number, 10, FALSE,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, pfc$multiple_job_usage_conflict, status);
        RETURN;
      IFEND;

      IF cycle_busy_due_to_sharing (cycle_entry.attach_status, share_intentions) THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_busy, p_fs_path^ (1, fs_path_size),
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, cycle_entry.cycle_number, 10, FALSE,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, pfc$multiple_job_share_conflict,
              status);
        RETURN;
      IFEND;

      check_mainframe_usage (path, mainframe_id, usage_intentions, p_catalog_file, cycle_entry, status);
    IFEND;
  PROCEND pfp$check_cycle_busy;

?? TITLE := '  [XDCL] pfp$check_device_availability', EJECT ??
{
{    This procedure determines if access to the attached file should proceed,
{ for example as a result of an open file.
{ For a file attached on the local mainframe this is currently unimplemented
{   and always returns that the device is available.
{ For a file attached on the server mainframe this routine determines if the
{    the server is available, and if the server is active determines if
{    the job is at the same lifetime as the server mainframe.
{     If the server is active the following table holds:
{     --------------------------------------------------
{ CASE
{     server lifetime    =   =   =
{     job    lifetime    =   =   <
{     file   lifetime    =   <       0
{ CONDITION
{              Active    X
{  Job needs recovery            X
{     File terminated        X       X

  PROCEDURE [XDCL] pfp$check_device_availability
    (    apfid: pft$attached_permanent_file_id;
     VAR status: ost$status);

    VAR
      job_lifetime: dft$server_lifetime,
      p_served_family_entry: ^dft$served_family_table_entry,
      server_found: boolean;

    IF apfid.family_location = pfc$local_mainframe THEN
      status.normal := TRUE;
    ELSE {pfc$server_mainframe}
      dfp$fetch_served_family_entry (apfid.served_family_table_index,
            p_served_family_entry, status);
      IF status.normal THEN
        IF apfid.server_lifetime = 0 THEN
          { File has been terminated.
          osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated,
                p_served_family_entry^.family_name, status);
          RETURN;
        IFEND;

        CASE p_served_family_entry^.server_state OF
        = dfc$awaiting_recovery, dfc$inactive, dfc$deactivated =
          dfp$get_job_server_state (p_served_family_entry^.server_mainframe_id,
                server_found, job_lifetime);
          IF apfid.server_lifetime < job_lifetime THEN
            { Even though the state of the server is inactive, this is an old
            { file.
            osp$set_status_abnormal (dfc$file_server_id,
                  dfe$server_has_terminated, p_served_family_entry^.
                  family_name, status);
          ELSE
            { Return the status of dfe$server_not_active to allow waiting
            { to be performed as a result of waiting for unavailable server.
            osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_active,
                  p_served_family_entry^.family_name, status);
          IFEND;
        = dfc$recovering =
          { Wait for the server to become active to sort out the lifetime.
          osp$set_status_abnormal (dfc$file_server_id, dfe$server_not_active,
                p_served_family_entry^.family_name, status);
        = dfc$terminated, dfc$deleted =
          osp$set_status_abnormal (dfc$file_server_id,
                dfe$server_has_terminated, p_served_family_entry^.family_name,
                status);
        ELSE { Active
          IF p_served_family_entry^.server_lifetime =
                apfid.server_lifetime THEN
            { The file and the server are at the same lifetime - all is active.
            { The job must be at the same lifetime, because the file could
            { not be at the same lifetime without the job being at the same
            { lifetime.
          ELSE { The file is at a different lifetime than the server.
            dfp$get_job_server_state (p_served_family_entry^.
                  server_mainframe_id, server_found, job_lifetime);
            IF job_lifetime = p_served_family_entry^.server_lifetime THEN
              { The job and the server are at the same lifetime, but the
              { file is at a different lifetime, the apfid must be old,
              { so the file did not recover.
              osp$set_status_abnormal (dfc$file_server_id,
                    dfe$server_has_terminated, p_served_family_entry^.
                    family_name, status);
            ELSE
              { The job is at a previous lifetime than the server so the
              { job has not gone through job recovery yet.
              osp$set_status_abnormal (dfc$file_server_id,
                    dfe$server_not_active, p_served_family_entry^.family_name,
                    status);
            IFEND;
          IFEND;
        CASEND;
      ELSE { The server must have terminated
        osp$set_status_abnormal (dfc$file_server_id, dfe$server_has_terminated,
              '', status);
      IFEND;
    IFEND;
  PROCEND pfp$check_device_availability;

?? TITLE := '  [XDCL] pfp$check_group_by_permit_level', EJECT ??

  PROCEDURE [XDCL] pfp$check_group_by_permit_level
    (    permit_level: pft$permit_level;
         group: pft$group;
     VAR status: ost$status);

    TYPE
      group_type_set = set of pft$group_types;

    VAR
      group_type_string: string (maximum_group_type_string_size),
      group_type_string_size: 1 .. maximum_group_type_string_size;

    status.normal := TRUE;

    CASE permit_level OF
    = pfc$pl_public =
      ;

    = pfc$pl_family =
      IF group.group_type = pfc$public THEN
        convert_group_type_to_string (group.group_type, group_type_string, group_type_string_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_group_type,
              group_type_string (1, group_type_string_size), status);
      IFEND;

    = pfc$pl_account =
      IF group.group_type IN $group_type_set [pfc$public, pfc$family] THEN
        convert_group_type_to_string (group.group_type, group_type_string, group_type_string_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_group_type,
              group_type_string (1, group_type_string_size), status);
      IFEND;

    = pfc$pl_project =
      IF group.group_type IN $group_type_set [pfc$public, pfc$family, pfc$account] THEN
        convert_group_type_to_string (group.group_type, group_type_string, group_type_string_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_group_type,
              group_type_string (1, group_type_string_size), status);
      IFEND;

    = pfc$pl_user =
      IF group.group_type IN $group_type_set [pfc$public, pfc$family, pfc$account, pfc$project] THEN
        convert_group_type_to_string (group.group_type, group_type_string, group_type_string_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_group_type,
              group_type_string (1, group_type_string_size), status);
      IFEND;

    = pfc$pl_owner =
      IF group.group_type IN $group_type_set [pfc$public, pfc$family, pfc$account, pfc$project] THEN
        convert_group_type_to_string (group.group_type, group_type_string, group_type_string_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_group_type,
              group_type_string (1, group_type_string_size), status);
      ELSE
        {
        { The family_name and user name must be that of the requestor, but any
        { account and project is valid.
        {
        IF ((group.group_type = pfc$user) AND (group.user_description.family <> pfv$task_family)) OR
              ((group.group_type = pfc$user_account) AND
              (group.user_account_description.family <> pfv$task_family)) OR
              ((group.group_type = pfc$member) AND (group.member_description.family <> pfv$task_family)) THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_group, 'family name', status);
        ELSEIF ((group.group_type = pfc$user) AND (group.user_description.user <> pfv$task_user)) OR
              ((group.group_type = pfc$user_account) AND
              (group.user_account_description.user <> pfv$task_user)) OR
              ((group.group_type = pfc$member) AND (group.member_description.user <> pfv$task_user)) THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_group, 'user name', status);
        IFEND;
      IFEND;

    ELSE
      {
      { Should never occur; but if it does, treat as pfc$pl_public.
      {
    CASEND;
  PROCEND pfp$check_group_by_permit_level;

?? TITLE := '  [XDCL] pfp$create_catalog_object', EJECT ??

  PROCEDURE [XDCL] pfp$create_catalog_object
    (    path: pft$complete_path;
         authority: pft$authority;
         catalog_type: pft$catalog_types;
         parent_charge_id: pft$charge_id;
         charge_id: pft$charge_id;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
         p_parent_catalog_file: {i^/o^} ^pft$catalog_file;
         p_catalog_object: {output^} ^pft$physical_object;
     VAR status: ost$status);

    VAR
      keypoint_operation: dft$keypoint_file_operation,
      keypoint_sfid: dft$keypoint_sfid,
      local_catalog_object_locator: pft$catalog_object_locator,
      local_status: ost$status,
      new_catalog_locator: pft$catalog_locator,
      new_internal_catalog_name: pft$internal_name,
      p_physical_fmd: ^pft$physical_fmd;

    local_catalog_object_locator.catalog_type := catalog_type;
    {
    { For external catalogs, the catalog is created when the object is created,
    { because the process to update the object would be difficult when
    { allocating the first object in the catalog. For internal catalogs, the
    { object list is created when the first object must be created in the
    { object list.
    {
    IF catalog_type = pfc$external_catalog THEN
      pfp$create_catalog (path, p_mass_storage_request_info, authority, {lock_catalog} TRUE,
            new_catalog_locator, status);
      IF status.normal THEN
        IF dfv$file_server_info_enabled THEN
          keypoint_operation.remote := path [pfc$family_path_index] <> osv$system_family_name;
          keypoint_operation.catalog := TRUE;
          keypoint_sfid.file_entry_index := new_catalog_locator.system_file_id.file_entry_index;
          keypoint_sfid.residence := new_catalog_locator.system_file_id.residence;
          #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_operation.keypoint_data, dfk$create_info);
          #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_sfid.keypoint_data, dfk$sfid);
        IFEND;
        pfp$record_dm_file_parameters (^path, {p_cycle_number} NIL, new_catalog_locator.system_file_id,
              rmc$mass_storage_device, {p_removable_media_req_info} NIL, {p_volume_list} NIL,
              ^p_parent_catalog_file^.catalog_heap, p_physical_fmd, status);
        IF status.normal THEN
          pfp$build_fmd_locator (p_physical_fmd, p_parent_catalog_file,
                local_catalog_object_locator.fmd_locator);
          local_catalog_object_locator.global_file_name := new_catalog_locator.global_file_name;
          new_internal_catalog_name := new_catalog_locator.internal_catalog_name;
          pfp$return_catalog (new_catalog_locator, status);
        ELSE
          pfp$destroy_catalog (new_catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
        IFEND;

      ELSEIF (status.condition = rme$file_class_not_valid) OR
             (status.condition = rme$job_not_valid) OR
             (status.condition = rme$volume_overflow_required) OR
             (status.condition = rme$vsn_not_part_of_set) OR
             (status.condition = dme$unable_to_alloc_all_space) THEN
        {
        { Allow abnormal status to filter up to user ring.
        {
      ELSE
        pfp$report_unexpected_status (status);
      IFEND;
    ELSE {internal catalog}
      osp$generate_unique_binary_name (new_internal_catalog_name, status);
      pfp$process_unexpected_status (status);
      pfp$build_object_list_locator ({sorted_object_count} 0, {free_sorted_object_count} 0,
           {p_object_list} NIL, p_parent_catalog_file, local_catalog_object_locator.object_list_locator);
    IFEND;

    IF status.normal THEN
      p_catalog_object^.object_entry.object_type := pfc$catalog_object;
      p_catalog_object^.object_entry.external_object_name := path [UPPERBOUND (path)];
      p_catalog_object^.object_entry.internal_object_name := new_internal_catalog_name;
      pfp$build_permit_list_locator ({p_permit_list} NIL, p_parent_catalog_file,
            p_catalog_object^.object_entry.permit_list_locator);
      IF (pfc$system_owner IN authority.ownership) AND
            (pfc$master_catalog_path_index < UPPERBOUND (path)) THEN
        p_catalog_object^.object_entry.charge_id := parent_charge_id;
      ELSE
        p_catalog_object^.object_entry.charge_id := charge_id;
      IFEND;
      p_catalog_object^.object_entry.reserved_object_entry_space := pfv$null_object_entry_space;
      p_catalog_object^.object_entry.catalog_recreated_by_restore := osv$recover_system_set_phase =
            osc$reinitialize_system_device;
      p_catalog_object^.object_entry.catalog_object_locator := local_catalog_object_locator;
      p_catalog_object^.object_entry.reserved_catalog_entry_space := pfv$null_catalog_entry_space;
      pfp$compute_checksum (#LOC (p_catalog_object^.object_entry), #SIZE (pft$object_entry),
            p_catalog_object^.checksum);
    IFEND;
  PROCEND pfp$create_catalog_object;

?? TITLE := '  [XDCL] pfp$create_file_object', EJECT ??

  PROCEDURE [XDCL] pfp$create_file_object
    (    file_name: pft$name;
         authority: pft$authority;
         parent_charge_id: pft$charge_id;
         password: pft$password;
         log: pft$log;
     VAR object_entry: pft$object_entry);

    VAR
      status: ost$status;

    object_entry.external_object_name := file_name;
    osp$generate_unique_binary_name (object_entry.internal_object_name, status);
    pfp$process_unexpected_status (status);
    pfp$build_permit_list_locator ({p_permit_list} NIL, {p_catalog_file} NIL,
          object_entry.permit_list_locator);
    IF pfc$system_owner IN authority.ownership THEN
      object_entry.charge_id := parent_charge_id;
    ELSE
      object_entry.charge_id.account := authority.account;
      object_entry.charge_id.project := authority.project;
    IFEND;
    object_entry.object_type := pfc$file_object;
    object_entry.password := password;
    object_entry.logging_selection := log;
    pfp$build_log_list_locator ({p_log_list} NIL, {p_catalog_file} NIL, object_entry.log_list_locator);
    pfp$build_cycle_list_locator ({p_cycle_list} NIL, {p_catalog_file} NIL, object_entry.cycle_list_locator);
    object_entry.reserved_object_entry_space := pfv$null_object_entry_space;
    object_entry.reserved_file_entry_space := pfv$null_file_entry_space;
  PROCEND pfp$create_file_object;

?? TITLE := '  [XDCL, #GATE] pfp$dm_return_item', EJECT ??
*copy pfh$dm_return_item

  PROCEDURE [XDCL, #GATE] pfp$dm_return_item
    (    sfid: gft$system_file_identifier;
     VAR status: ost$status);

    VAR
      file_info: dmt$file_information,
      file_modified: boolean,
      fmd_modified: boolean;

    dmp$detach_file (sfid, {access_allowed} TRUE, {flush_pages} TRUE, file_modified, fmd_modified, file_info,
          status);
    IF status.normal THEN
      dmp$delete_file_descriptor (sfid, status);
      status.normal := status.normal OR (status.condition = dme$file_descriptor_not_deleted);
    IFEND;
  PROCEND pfp$dm_return_item;
?? TITLE := '  pfp$r2_get_vol_condition_list', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_get_vol_condition_list
    (    unique_volume_list: pft$unique_volume_list;
     VAR volume_condition_list: fst$volume_condition_list);

    VAR
      conditions: fst$file_access_conditions,
      volume_index: ost$non_negative_integers;

    FOR volume_index := LOWERBOUND (unique_volume_list) TO UPPERBOUND (unique_volume_list) DO
      volume_condition_list [volume_index] := osp$get_volume_condition (unique_volume_list [volume_index]);
    FOREND;

  PROCEND pfp$r2_get_vol_condition_list;

?? TITLE := '  [XDCL] pfp$increment_usage_counts', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to increment the attach status and the
{   mainframe usage to reflect the additional activity indicated by the usage_selections
{   and share_selections parameters.

  PROCEDURE [XDCL] pfp$increment_usage_counts
    (    path: pft$complete_path;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
         mainframe_id: pmt$binary_mainframe_id;
         p_catalog_file: {input, output} ^pft$catalog_file;
     VAR flush_catalog_pages: boolean;
     VAR cycle_entry {input, output} : pft$cycle_entry;
     VAR status: ost$status);

    update_mainframe_usage (path, mainframe_id, usage_selections, p_catalog_file, flush_catalog_pages,
          cycle_entry, status);
    IF status.normal THEN
      increment_attach_status (cycle_entry.attach_status, usage_selections, share_selections,
            cycle_entry.attach_status);
    IFEND;
  PROCEND pfp$increment_usage_counts;

?? TITLE := '  [XDCL] pfp$initialize_job_recovery', EJECT ??
{       PFP$INITIALIZE_JOB_RECOVERY
{
{   This procedure initializes the permanent file part of file recovery with
{ active job recovery. This involves deleting queued catalogs and marking all
{ attached files as being in recovery.

  PROCEDURE [XDCL] pfp$initialize_job_recovery
    (    file_recovery_state: pft$attached_pf_recovery_state;
     VAR status: ost$status);

    pfp$remove_queued_catalogs;
    pfp$setup_attached_pf_recovery (file_recovery_state, status);
  PROCEND pfp$initialize_job_recovery;

?? TITLE := '  [XDCL] pfp$internal_return_file', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to return an attached permanent file.
{   This routine always runs on the mainframe where the catalogs reside.
{   The caller is required to pass in the attached permanent file table index
{   and the mainframe_id of the mainframe that has the file attached.

  PROCEDURE [XDCL] pfp$internal_return_file
    (    attached_pf_table_index: pft$attached_pf_table_index;
         mainframe_id: pmt$binary_mainframe_id;
     VAR authority: pft$authority;
     VAR bytes_allocated_change: sft$counter;
     VAR status: ost$status);

    PROCEDURE internal_return_file_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        variant_path: pft$variant_path,
        status_id: ost$status_identifier,
        local_status: ost$status;

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := p_attached_pf_entry^.p_external_path;

      IF NOT process_non_local_exit THEN
        pfp$log_ascii ('***PF Condition Handler***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, {critical_message} FALSE, local_status);
        pfp$log_path (variant_path, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
              {critical_message} FALSE, local_status);
      IFEND;

      CASE condition.selector OF
      = pmc$system_conditions, pmc$block_exit_processing, mmc$segment_access_condition =
        IF process_non_local_exit THEN
          RETURN;
        IFEND;

        IF catalog_locator.attached THEN
          catalog_locator.abort_catalog_operation := TRUE;
          pfp$return_catalog (catalog_locator, local_status);
          IF NOT local_status.normal THEN
            pfp$report_system_error (local_status);
          IFEND;
        IFEND;

        syp$pop_inhibit_job_recovery;

        pfp$unlock_apfid (attached_pf_table_index, p_attached_pf_entry, local_status);
        IF pfv$locked_apfid <> 0 THEN
          pfp$release_locked_apfid (pfv$locked_apfid, local_status);
          pfv$locked_apfid := 0;
        IFEND;

        osp$set_status_from_condition (status_id, condition, p_sfsa, local_status, handler_status);
        osp$recoverable_system_error ('UNEXPECTED STATUS', ^local_status);

        status := local_status;
        initiate_non_local_exit;


      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
         {syp$invalidate_open_sfid (catalog_locator.system_file_id, local_status);
          initiate_non_local_exit;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND internal_return_file_handler;

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$internal_return_file;
    PROCEND initiate_non_local_exit;

    CONST
      extract_permits = TRUE,
      system_privilege = TRUE;

    VAR
      access_kind: pft$access_kind,
      bytes_released: amt$file_byte_address,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      date_time: ost$date_time,
      device_class: rmt$device_class,
      disk_image_deleted: boolean,
      file_info: dmt$file_information,
      fmd_modified: boolean,
      internal_cycle_name: pft$internal_name,
      local_status: ost$status,
      p_attached_pf_entry: pft$p_attached_pf_entry,
      p_cycle: pft$p_cycle,
      p_cycle_list: pft$p_cycle_list,
      p_file_object: pft$p_object,
      p_internal_path: pft$p_internal_path,
      p_path_string: ^ost$string,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean,
      purge_cycle_options: pft$purge_cycle_options,
      set_name: stt$set_name,
      sfid: gft$system_file_identifier,
      share_selections: pft$share_selections,
      update_catalog: boolean,
      usage_selections: pft$usage_selections;

    syp$push_inhibit_job_recovery;
    bytes_allocated_change := 0;
    status.normal := TRUE;
    pfp$lock_apfid (attached_pf_table_index, p_attached_pf_entry, status);
    IF NOT status.normal THEN
      pfp$report_unexpected_status (status);
      RETURN;
    ELSEIF p_attached_pf_entry = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'NIL p_attached_pf_entry AND valid apfid.', status);
      RETURN;
    IFEND;

  /internal_return_file/
    BEGIN
      catalog_active := FALSE;
      disk_image_deleted := FALSE;
      #SPOIL (disk_image_deleted);
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);

      set_name := p_attached_pf_entry^.p_external_path^ [pfc$set_path_index];
      p_internal_path := ^p_attached_pf_entry^.internal_cycle_path.path;
      internal_cycle_name := p_attached_pf_entry^.internal_cycle_path.cycle_name;
      update_catalog := p_attached_pf_entry^.update_catalog;
      IF update_catalog THEN
        access_kind := pfc$write_access;
      ELSE
        access_kind := pfc$read_access;
      IFEND;
      usage_selections := p_attached_pf_entry^.usage_selections;
      share_selections := p_attached_pf_entry^.share_selections;
      IF (p_attached_pf_entry^.sfid_status.recovery_state = pfc$attached_pf_normal) OR
            (p_attached_pf_entry^.sfid_status.recovery_state = pfc$attached_pf_awaiting_client) THEN
        sfid := p_attached_pf_entry^.sfid_status.sfid;
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'Return called with non-normal sfid.', status);
        EXIT /internal_return_file/;
      IFEND;

      pfp$get_authority (p_attached_pf_entry^.p_external_path^, NOT system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /internal_return_file/;
      IFEND;

    /internal_access_object/
      WHILE TRUE DO
        pfp$internal_access_object (set_name, p_internal_path^, access_kind, authority, NOT extract_permits,
              (p_attached_pf_entry^.p_external_path^ [pfc$family_path_index] <> osv$system_family_name),
              p_file_object, catalog_locator, permit_entry, status);
        IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
          EXIT /internal_access_object/;
        ELSE
          syp$pop_inhibit_job_recovery;
          pfp$catalog_access_retry_wait ('PFP$INTERNAL_ACCESS_OBJECT');
          syp$push_inhibit_job_recovery;
        IFEND;
      WHILEND /internal_access_object/;

      catalog_active := status.normal;
      IF NOT status.normal THEN
        IF (NOT update_catalog) AND (status.condition = pfe$unknown_permanent_file) THEN
          {
          { This error will occur if a job terminates, and its swap file is
          { deleted, before job recovery completes and it attempts to detach
          { the swap file.
          {
          status.normal := TRUE;
        IFEND;
        EXIT /internal_return_file/;
      IFEND;

      osp$establish_condition_handler (^internal_return_file_handler, {block_exit} TRUE);

      IF pfv$restrict_catalog_flushing THEN
        catalog_locator.flush_catalog_pages := FALSE;
      IFEND;

      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      internal_locate_cycle (p_cycle_list, internal_cycle_name, p_cycle, status);
      IF NOT status.normal THEN
        EXIT /internal_return_file/;
      IFEND;

      IF p_cycle^.cycle_entry.device_information.device_class_defined THEN
        pfp$convert_device_class_to_rm (p_cycle^.cycle_entry.device_information.device_class, device_class);
      ELSE
        device_class := rmc$mass_storage_device;
      IFEND;

      IF device_class = rmc$mass_storage_device THEN
        pfp$detach_permanent_file (^p_attached_pf_entry^.p_external_path^, sfid, usage_selections,
              update_catalog, p_cycle, catalog_locator.p_catalog_file, fmd_modified, file_info, status);
      ELSEIF device_class = rmc$magnetic_tape_device THEN
        file_info.trimmed_length := 0;
        file_info.eoi_byte_address := 0;
        file_info.total_allocated_length := 0;
      IFEND;

      IF NOT update_catalog THEN
        EXIT /internal_return_file/;
      IFEND;

      IF status.normal OR NOT osp$file_access_condition (status) THEN
        decrement_usage_counts (usage_selections, share_selections, mainframe_id,
              catalog_locator.p_catalog_file, p_cycle^.cycle_entry);
        bytes_allocated_change := -file_info.trimmed_length;
        p_cycle^.cycle_entry.device_information.eoi := file_info.eoi_byte_address;
        p_cycle^.cycle_entry.device_information.bytes_allocated := file_info.total_allocated_length;

        IF p_attached_pf_entry^.update_cycle_statistics THEN
          pmp$get_compact_date_time (date_time, local_status);
          pfp$process_unexpected_status (local_status);
          update_cycle_statistics (p_cycle^.cycle_entry.cycle_statistics, date_time, usage_selections,
                share_selections, p_cycle^.cycle_entry.cycle_statistics,
                p_cycle^.cycle_entry.data_modification_date_time);
        IFEND;

        IF fmd_modified THEN
          catalog_locator.flush_catalog_pages := pfv$flush_catalogs;
        IFEND;

        CASE p_cycle^.cycle_entry.data_residence OF
        = pfc$release_data_requested =
          release_cycle_data (p_attached_pf_entry^.p_external_path^, p_cycle,
                catalog_locator.p_catalog_file, {p_release_data_info} NIL, local_status);
        = pfc$offline_data =
          p_cycle^.cycle_entry.entry_type := pfc$normal_cycle_entry;
        ELSE
          ;
        CASEND;

        pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
      ELSEIF status.condition = pfe$pf_system_error THEN
        PUSH p_path_string;
        pfp$convert_cycle_path_to_strng (p_attached_pf_entry^.p_external_path^,
              p_attached_pf_entry^.cycle_number, p_path_string^);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_path_string^.
              value (1, p_path_string^.size), status);
      IFEND;

      IF (status.normal OR NOT osp$file_access_condition (status)) AND
            (p_cycle^.cycle_entry.entry_type = pfc$purged_cycle_entry) THEN
        purge_cycle_options.preserve_cycle_entry := FALSE;
        purge_cycle (p_attached_pf_entry^.p_external_path^, device_class, purge_cycle_options,
              {p_data_modification_date_time} NIL, p_cycle, catalog_locator.p_catalog_file, p_file_object,
              catalog_locator.object_list_descriptor, disk_image_deleted, bytes_released, local_status);
        IF status.normal THEN
          IF local_status.normal THEN
            bytes_allocated_change := -bytes_released;
          ELSE
            status := local_status;
          IFEND;
        IFEND;
        pfp$process_unexpected_status (local_status);
      IFEND;

      syp$hang_if_job_jrt_set (pfc$tjr_return);
    END /internal_return_file/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    IF status.normal OR NOT osp$file_access_condition (status) THEN
      IF p_attached_pf_entry^.p_external_path <> NIL THEN
        FREE p_attached_pf_entry^.p_external_path IN pfv$p_p_job_heap^^;
      IFEND;
      FREE p_attached_pf_entry IN pfv$p_p_job_heap^^;
      pfp$release_locked_apfid (attached_pf_table_index, local_status);
      pfp$process_unexpected_status (local_status);
    ELSE
      pfp$unlock_apfid (attached_pf_table_index, p_attached_pf_entry, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$internal_return_file;

?? TITLE := '  [XDCL] pfp$internal_save_file_label', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to save a file label for an attached
{   permanent file cycle.  The file label specified by the caller replaces any
{   file label previously saved for the cycle.
{
{ DESIGN:
{   If the cycle does not yet have a file label stored in the catalog, then
{   whatever permission was necessary to get to this point is sufficient to
{   save the file label provided.  If the cycle already has a file label
{   stored in the catalog and the cycle has not been previously opened, then
{   either append permission is necessary to save the new file label.  If the
{   cycle already has a file label stored in the catalog and the cycle has been
{   previously opened, then control permission is necessary to save the new
{   file label.

  PROCEDURE [XDCL] pfp$internal_save_file_label
    (    apfid: pft$attached_permanent_file_id;
         system_authority: pft$system_authority;
         required_permission: pft$permit_options;
         p_file_label: {input} ^fmt$file_label;
     VAR p_save_file_label_audit_seq: {i/o} ^SEQ ( * );
     VAR status: ost$status);

    PROCEDURE save_file_label_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        variant_path: pft$variant_path,
        status_id: ost$status_identifier,
        local_status: ost$status;

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := p_attached_pf_entry^.p_external_path;

      IF NOT process_non_local_exit THEN
        pfp$log_ascii ('***PF Condition Handler***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, {critical_message} FALSE, local_status);
        pfp$log_path (variant_path, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
              {critical_message} FALSE, local_status);
      IFEND;

      CASE condition.selector OF
      = pmc$system_conditions, pmc$block_exit_processing, mmc$segment_access_condition =
        IF process_non_local_exit THEN
          RETURN;
        IFEND;

        IF catalog_locator.attached THEN
          catalog_locator.abort_catalog_operation := TRUE;
          pfp$return_catalog (catalog_locator, local_status);
          IF NOT local_status.normal THEN
            pfp$report_system_error (local_status);
          IFEND;
        IFEND;

        syp$pop_inhibit_job_recovery;

        IF apfid_locked THEN
          pfp$unlock_apfid (apfid.attached_pf_table_index, p_attached_pf_entry, local_status);
        IFEND;

        osp$set_status_from_condition (status_id, condition, p_sfsa, local_status, handler_status);
        osp$recoverable_system_error ('UNEXPECTED STATUS', ^local_status);

        status := local_status;
        initiate_non_local_exit;


      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
         {syp$invalidate_open_sfid (catalog_locator.system_file_id, local_status);
          initiate_non_local_exit;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND save_file_label_handler;

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$internal_save_file_label;
    PROCEND initiate_non_local_exit;

    VAR
      apfid_locked: boolean,
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      cycle_formerly_opened_info: fmt$cycle_formerly_opened_info,
      date_time: ost$date_time,
      file_previously_opened: boolean,
      internal_cycle_name: pft$internal_name,
      local_status: ost$status,
      p_attached_pf_entry: ^pft$attached_pf_entry,
      p_complete_path: ^pft$complete_path,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_local_file_label: ^fmt$file_label,
      p_path_string: ^ost$string,
      p_save_label_audit_info: ^pft$save_label_audit_info,
      p_static_label_header: ^fmt$static_label_header,
      p_stored_file_label: ^pft$physical_file_label,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean,
      static_label_attributes: bat$static_label_attributes,
      system_privilege: boolean;

    syp$push_inhibit_job_recovery;

  /internal_save_file_label/
    BEGIN
      apfid_locked := FALSE;
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL(process_non_local_exit);
      status.normal := TRUE;

      IF p_file_label = NIL THEN
        osp$set_status_condition (pfe$nil_pointer, status);
        EXIT /internal_save_file_label/;
      IFEND;

      pfp$lock_apfid (apfid.attached_pf_table_index, p_attached_pf_entry, status);
      apfid_locked := status.normal;
      IF (NOT status.normal) OR (p_attached_pf_entry = NIL) THEN
        p_save_file_label_audit_seq := NIL;
        EXIT /internal_save_file_label/;
      IFEND;

      IF p_attached_pf_entry^.update_catalog THEN
        {
        { This procedure is only callable from ring 3 or below.  Therefore, the
        { caller's ring need not be used in determining system_privilege.
        {
        system_privilege := pfp$system_privilege_authority
              (system_authority, osc$tsrv_ring, p_attached_pf_entry^.
              p_external_path^ [pfc$master_catalog_path_index]);
        pfp$get_authority (p_attached_pf_entry^.p_external_path^, system_privilege, authority, status);
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'Save file label issued but catalog update not allowed.', status);
        EXIT /internal_save_file_label/;
      IFEND;

    /internal_access_object/
      WHILE TRUE DO
        pfp$internal_access_object (p_attached_pf_entry^.p_external_path^ [pfc$set_path_index],
              p_attached_pf_entry^.internal_cycle_path.path, pfc$write_access, authority,
              {extract_permits} TRUE, (p_attached_pf_entry^.p_external_path^ [pfc$family_path_index] <>
              osv$system_family_name), p_file_object, catalog_locator, permit_entry, status);
        IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
          EXIT /internal_access_object/;
        ELSE
          syp$pop_inhibit_job_recovery;
          pfp$catalog_access_retry_wait ('PFP$INTERNAL_ACCESS_OBJECT');
          syp$push_inhibit_job_recovery;
        IFEND;
      WHILEND /internal_access_object/;

      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /internal_save_file_label/;
      IFEND;

      osp$establish_condition_handler (^save_file_label_handler, {block_exit} TRUE);

      internal_cycle_name := p_attached_pf_entry^.internal_cycle_path.cycle_name;
      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      internal_locate_cycle (p_cycle_list, internal_cycle_name, p_cycle, status);
      IF NOT status.normal THEN
        EXIT /internal_save_file_label/;
      IFEND;

      IF p_save_file_label_audit_seq <> NIL THEN
        RESET p_save_file_label_audit_seq;
        NEXT p_save_label_audit_info IN p_save_file_label_audit_seq;

        NEXT p_complete_path: [1 .. UPPERBOUND (p_attached_pf_entry^.p_external_path^)] IN
              p_save_file_label_audit_seq;
        IF p_complete_path = NIL THEN
          p_save_file_label_audit_seq := NIL;
        ELSE
          p_complete_path^ := p_attached_pf_entry^.p_external_path^;
          p_save_label_audit_info^.file_path_count := UPPERBOUND (p_attached_pf_entry^.p_external_path^);
          p_save_label_audit_info^.cycle_selector.cycle_option := pfc$specific_cycle;
          p_save_label_audit_info^.cycle_selector.cycle_number := p_cycle^.cycle_entry.cycle_number;

          IF p_cycle^.cycle_entry.device_information.device_class_defined THEN
            pfp$convert_device_class_to_rm (p_cycle^.cycle_entry.device_information.device_class,
                  p_save_label_audit_info^.device_class);
          ELSE
            p_save_label_audit_info^.device_class := rmc$mass_storage_device;
          IFEND;

          p_save_label_audit_info^.ownership := authority.ownership;

          IF (p_file_label = NIL) OR (#SIZE (p_file_label^) < #SIZE (fmt$static_label_header)) THEN
            p_save_label_audit_info^.fap_audit_info.audit := FALSE;
            p_save_label_audit_info^.ring_audit_info.audit := FALSE;
          ELSE
            p_local_file_label := p_file_label;
            RESET p_local_file_label;
            NEXT p_static_label_header IN p_local_file_label;

            IF (p_static_label_header = NIL) OR (p_static_label_header^.unique_character <>
                  fmc$unique_label_id) THEN
              p_save_label_audit_info^.fap_audit_info.audit := FALSE;
              p_save_label_audit_info^.ring_audit_info.audit := FALSE;
            ELSE
              IF (fmc$file_access_procedure <= p_static_label_header^.highest_attribute_present) AND
                    p_static_label_header^.attribute_present [fmc$file_access_procedure] THEN
                fsp$expand_file_label (p_local_file_label, static_label_attributes, file_previously_opened,
                      local_status);
                IF local_status.normal THEN
                  p_save_label_audit_info^.fap_audit_info.audit := TRUE;
                  p_save_label_audit_info^.fap_audit_info.fap_name :=
                        static_label_attributes.file_access_procedure;
                ELSE
                  p_save_label_audit_info^.fap_audit_info.audit := FALSE;
                IFEND;
              ELSE
                p_save_label_audit_info^.fap_audit_info.audit := FALSE;
              IFEND;

              IF p_static_label_header^.file_previously_opened THEN
                p_save_label_audit_info^.ring_audit_info.audit := TRUE;
                p_save_label_audit_info^.ring_audit_info.ring_attributes :=
                      p_static_label_header^.ring_attributes;
              ELSE
                p_save_label_audit_info^.ring_audit_info.audit := FALSE;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      pfp$build_file_label_pointer (p_cycle^.cycle_entry.file_label_locator, catalog_locator.p_catalog_file,
            p_stored_file_label);
      IF p_stored_file_label = NIL THEN
        IF (p_save_file_label_audit_seq <> NIL) AND (NOT p_save_label_audit_info^.fap_audit_info.audit) AND
              NOT p_save_label_audit_info^.ring_audit_info.audit THEN
          p_save_file_label_audit_seq := NIL;
        IFEND;
      ELSE
        IF p_save_file_label_audit_seq <> NIL THEN
          IF #SIZE (fmt$static_label_header) <= #SIZE (p_stored_file_label^.file_label) THEN
            p_local_file_label := ^p_stored_file_label^.file_label;
            RESET p_local_file_label;
            NEXT p_static_label_header IN p_local_file_label;

            IF (p_static_label_header <> NIL) AND (p_static_label_header^.unique_character =
                  fmc$unique_label_id) THEN
              IF (fmc$file_access_procedure <= p_static_label_header^.highest_attribute_present) AND
                    p_static_label_header^.attribute_present [fmc$file_access_procedure] THEN
                fsp$expand_file_label (p_local_file_label, static_label_attributes, file_previously_opened,
                      local_status);
                IF local_status.normal THEN
                  IF p_save_label_audit_info^.fap_audit_info.audit THEN
                    p_save_label_audit_info^.fap_audit_info.audit :=
                          p_save_label_audit_info^.fap_audit_info.fap_name <>
                          static_label_attributes.file_access_procedure;
                  ELSE
                    p_save_label_audit_info^.fap_audit_info.audit := TRUE;
                    p_save_label_audit_info^.fap_audit_info.fap_name := osc$null_name;
                  IFEND;
                ELSEIF NOT p_save_label_audit_info^.fap_audit_info.audit THEN
                  p_save_label_audit_info^.fap_audit_info.audit := TRUE;
                  p_save_label_audit_info^.fap_audit_info.fap_name := osc$null_name;
                IFEND;
              IFEND;

              IF p_static_label_header^.file_previously_opened THEN
                p_save_label_audit_info^.ring_audit_info.audit :=
                      p_save_label_audit_info^.ring_audit_info.ring_attributes <>
                      p_static_label_header^.ring_attributes;
              IFEND;
            IFEND;
          IFEND;

          IF (NOT p_save_label_audit_info^.fap_audit_info.audit) AND
                NOT p_save_label_audit_info^.ring_audit_info.audit THEN
            p_save_file_label_audit_seq := NIL;
          IFEND;
        IFEND;

        IF required_permission = pfc$control THEN
          pfp$validate_file_permission (p_attached_pf_entry^.p_external_path^, authority, permit_entry,
                $pft$permit_selections [pfc$control], -$pft$share_selections [], status);
          IF NOT status.normal THEN
            EXIT /internal_save_file_label/;
          IFEND;
        IFEND;
      IFEND;

      store_file_label (p_attached_pf_entry^.p_external_path^, p_file_label, catalog_locator.p_catalog_file,
            p_cycle, p_stored_file_label, status);
      IF NOT status.normal THEN
        EXIT /internal_save_file_label/;
      IFEND;

      IF p_attached_pf_entry^.update_cycle_statistics THEN
        pmp$get_compact_date_time (date_time, local_status);
        pfp$process_unexpected_status (local_status);
        p_cycle^.cycle_entry.cycle_statistics.modification_date_time := date_time;
        p_cycle^.cycle_entry.data_modification_date_time := date_time;
        pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
      IFEND;
    END /internal_save_file_label/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    IF apfid_locked THEN
      pfp$unlock_apfid (apfid.attached_pf_table_index, p_attached_pf_entry, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$internal_save_file_label;

?? TITLE := '  [XDCL] pfp$pick_modes_for_open', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to pick the first set of access and share
{   modes specified which is compatible with how the cycle is already attached
{   within the job.

  PROCEDURE [XDCL] pfp$pick_modes_for_open
    (    evaluated_file_reference: fst$evaluated_file_reference;
         p_attachment_options: {input} ^fst$attachment_options;
         allowed_access: fst$file_access_options;
         required_sharing: fst$file_access_options;
         setfa_access_modes: fst$access_modes;
         device_class: rmt$device_class;
         cycle_formerly_opened_info: fmt$cycle_formerly_opened_info;
         called_by_attach: boolean;
         create_file: boolean;
         validation_ring: ost$valid_ring;
     VAR selected_access: fst$file_access_options;
     VAR selected_sharing: fst$file_access_options;
     VAR status: ost$status);

    VAR
      access_modes: fst$access_modes,
      access_selections: fst$file_access_options,
      fs_path_size: fst$path_size,
      ignore_status: ost$status,
      last_access_and_share_mode_ind: ost$non_negative_integers,
      local_status: ost$status,
      option_index: ost$non_negative_integers,
      p_fs_path: ^fst$path,
      permitted_access_modes_failure: boolean,
      share_modes: fst$share_modes,
      share_selections: fst$file_access_options,
      usage_selections: pft$usage_selections,
      valid_ring: boolean;

    IF p_attachment_options = NIL THEN
      last_access_and_share_mode_ind := 0;
    ELSE
      last_access_and_share_mode_ind := 0;

    /find_last_access_and_share_mode/
      FOR option_index := UPPERBOUND (p_attachment_options^) DOWNTO 1 DO
        IF p_attachment_options^ [option_index].selector = fsc$access_and_share_modes THEN
          last_access_and_share_mode_ind := option_index;
          EXIT /find_last_access_and_share_mode/;
        IFEND;
      FOREND /find_last_access_and_share_mode/;
    IFEND;

    option_index := 0;
    REPEAT
      IF option_index < last_access_and_share_mode_ind THEN
        REPEAT
          option_index := option_index + 1;
        UNTIL p_attachment_options^ [option_index].selector = fsc$access_and_share_modes;
      IFEND;

      IF option_index > 0 THEN
        access_modes := p_attachment_options^ [option_index].access_modes;
        IF device_class = rmc$mass_storage_device THEN
          share_modes := p_attachment_options^ [option_index].share_modes;
        ELSEIF device_class = rmc$magnetic_tape_device THEN
          share_modes.selector := fsc$specific_share_modes;
          share_modes.value := $fst$file_access_options [];
        IFEND;
        status.normal := TRUE;
      ELSE
        {
        { Use setfa access modes and default share modes. (If access
        { modes were not specified via a setfa, they will default to
        { fsc$permitted_access_modes.)
        {
        access_modes := setfa_access_modes;
        IF device_class = rmc$mass_storage_device THEN
          share_modes.selector := fsc$determine_from_access_modes;
        ELSEIF device_class = rmc$magnetic_tape_device THEN
          share_modes.selector := fsc$specific_share_modes;
          share_modes.value := $fst$file_access_options [];
        IFEND;
        status.normal := TRUE;
      IFEND;

      IF status.normal THEN
        validate_access_and_share_modes (evaluated_file_reference,
              {last_access_and_share_modes} (option_index = last_access_and_share_mode_ind), access_modes,
              share_modes, allowed_access, required_sharing, {initial_open}
              ((NOT cycle_formerly_opened_info.cycle_previously_opened) AND NOT called_by_attach),
              create_file, device_class, access_selections, share_selections, permitted_access_modes_failure,
              status);
      IFEND;

      IF status.normal THEN
        IF cycle_formerly_opened_info.cycle_previously_opened THEN
          #UNCHECKED_CONVERSION (access_selections, usage_selections);
          ring_vote_selected_access (access_modes.selector, cycle_formerly_opened_info, validation_ring,
                usage_selections, valid_ring);
          IF (NOT valid_ring) AND (usage_selections <> $pft$usage_selections []) THEN
            permitted_access_modes_failure := (access_modes.selector = fsc$permitted_access_modes);
            IF (option_index = last_access_and_share_mode_ind) OR permitted_access_modes_failure THEN
              PUSH p_fs_path;
              clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} FALSE,
                    p_fs_path^, fs_path_size, ignore_status);
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_ring_access,
                    p_fs_path^ (1, fs_path_size), status);
            ELSE
              osp$set_status_condition (pfe$invalid_ring_access, status);
            IFEND;
          ELSE
            #UNCHECKED_CONVERSION (usage_selections, selected_access);
            selected_sharing := share_selections;
          IFEND;
        ELSE
          selected_access := access_selections;
          selected_sharing := share_selections;
        IFEND;
      IFEND;
    UNTIL status.normal OR (option_index = last_access_and_share_mode_ind) OR (option_index = 0) OR
          permitted_access_modes_failure OR ((status.condition <> pfe$cycle_busy) AND
          (status.condition <> ame$new_file_requires_append) AND
          (status.condition <> pfe$invalid_ring_access) AND
          (status.condition <> pfe$null_access_not_allowed));
  PROCEND pfp$pick_modes_for_open;

?? TITLE := '  [XDCL, #GATE] pfp$process_job_end', EJECT ??
*copy pfh$process_job_end

  PROCEDURE [XDCL, #GATE] pfp$process_job_end
    (files_binary_mainframe_id: pmt$binary_mainframe_id;
     VAR return_files_option: pft$return_files_option);

    syp$push_inhibit_job_recovery;
    IF return_files_option.return_files THEN
      pfp$detach_all_files (files_binary_mainframe_id, return_files_option);
    IFEND;
    pfp$detach_all_catalogs;
    syp$pop_inhibit_job_recovery;
  PROCEND pfp$process_job_end;

?? TITLE := '  [XDCL, #GATE] pfp$r2_append_rem_media_vsn', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_append_rem_media_vsn
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         volume_descriptor: rmt$volume_descriptor;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_append_rem_media_vsn;
    PROCEND initiate_non_local_exit;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      local_status: ost$status,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      p_stored_fmd: ^pft$physical_fmd,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;
    process_non_local_exit := FALSE;
    status.normal := TRUE;

    pfp$get_authority (path, {system_privilege} FALSE, authority, status);
    IF status.normal THEN
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$file_object],
            parent_charge_id, catalog_locator, p_file_object, p_internal_path^, permit_entry, status);
    IFEND;
    catalog_active := status.normal;
    osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

    IF status.normal THEN
      pfp$validate_file_permission (path, authority, permit_entry, $pft$permit_selections [pfc$control],
          - $pft$share_selections [], status);
    IFEND;

    IF status.normal THEN
      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
    IFEND;
    IF status.normal THEN
      pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, catalog_locator.p_catalog_file, p_stored_fmd);
      IF p_stored_fmd <> NIL THEN
        append_rem_media_vsn (path, volume_descriptor, catalog_locator.p_catalog_file, p_cycle, status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;
    IF catalog_active THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_append_rem_media_vsn;

?? TITLE := '  [XDCL, #GATE] pfp$r2_attach', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to check whether the cycle is already
{   attached within the job, and to optionally call pfp$r2_df_attach or
{   pfp$r2_attach_file.
{
{ NOTE:
{   The path table must be locked throughout.

  PROCEDURE [XDCL, #GATE] pfp$r2_attach
    (    r2_attach_input: pft$r2_attach_in;
         update_catalog: boolean;
         update_cycle_statistics: boolean;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
         system_privilege: boolean;
         validation_ring: ost$valid_ring;
         allowed_cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR cycle_number: pft$cycle_number;
     VAR cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR global_file_name: dmt$global_file_name;
     VAR status: ost$status);

    VAR
      allowed_usage_selections: pft$usage_selections,
      attachment_options: array [1 .. 1] of fst$attachment_option,
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id,
      authority: pft$authority,
      authority_known: boolean,
      cycle_attached: boolean,
      cycle_formerly_opened_info: fmt$cycle_formerly_opened_info,
      cycle_selector: pft$cycle_selector,
      device_class: rmt$device_class,
      df_attach_input: pft$df_attach_in,
      evaluated_file_reference: fst$evaluated_file_reference,
      fs_path_size: fst$path_size,
      mainframe_id: pmt$binary_mainframe_id,
      p_cycle_description: ^fmt$cycle_description,
      p_file_server_buffers: ^pft$file_server_buffers,
      p_fs_path: ^fst$path,
      p_ignore_status: ^ost$status,
      p_local_status: ^ost$status,
      path_table_cycle_info: fmt$path_table_cycle_info,
      process_pt_results: bat$process_pt_results,
      required_share_selections: pft$share_selections,
      selected_access: fst$file_access_options,
      selected_sharing: fst$file_access_options,
      share_selector: pft$share_selector,
      tape_file_attached: boolean,
      usage_selector: pft$usage_selector;

    fmp$lock_path_table (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF r2_attach_input.cycle_selector.cycle_option = pfc$specific_cycle THEN
      IF r2_attach_input.served_family THEN
        pfp$convert_pft$path_to_fs_str (r2_attach_input.p_path^, evaluated_file_reference);
      ELSE
        pfp$convert_pf_to_fs_structure (r2_attach_input.p_complete_path^, evaluated_file_reference);
      IFEND;
      evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
      evaluated_file_reference.cycle_reference.cycle_number := r2_attach_input.cycle_selector.cycle_number;
      fmp$get_path_table_cycle_info (inhibit_path_table_lock, evaluated_file_reference,
            path_table_cycle_info, status);

      cycle_attached := status.normal AND path_table_cycle_info.path_registered AND
            path_table_cycle_info.cycle_attachment_info.cycle_attached;

      IF cycle_attached THEN
        IF path_table_cycle_info.cycle_attachment_info.password_protected OR
              (r2_attach_input.password <> osc$null_name) THEN
          IF r2_attach_input.served_family THEN
            pfp$r2_df_client_validate_pw (r2_attach_input.served_family_locator, r2_attach_input.p_path^,
                  r2_attach_input.password, status);
          ELSE
            pfp$r2_validate_password (r2_attach_input.p_complete_path^, r2_attach_input.password, status);
          IFEND;
        IFEND;

        IF status.normal THEN
          IF path_table_cycle_info.cycle_device_info.device_assigned THEN
            device_class := path_table_cycle_info.cycle_device_info.device_class;
            cycle_formerly_opened_info := path_table_cycle_info.cycle_device_info.cycle_formerly_opened_info;
          ELSE
            device_class := rmc$mass_storage_device;
            cycle_formerly_opened_info.cycle_previously_opened := FALSE;
          IFEND;

          attachment_options [1].selector := fsc$access_and_share_modes;
          attachment_options [1].access_modes.selector := fsc$specific_access_modes;
          #UNCHECKED_CONVERSION (usage_selections, attachment_options [1].access_modes.value);
          attachment_options [1].share_modes.selector := fsc$specific_share_modes;
          #UNCHECKED_CONVERSION (share_selections, attachment_options [1].share_modes.value);

          pfp$pick_modes_for_open (evaluated_file_reference, ^attachment_options,
                path_table_cycle_info.cycle_attachment_info.allowed_access,
                path_table_cycle_info.cycle_attachment_info.required_sharing,
                path_table_cycle_info.setfa_access_modes, device_class, cycle_formerly_opened_info,
                {called_by_attach} TRUE, {create_file} FALSE, validation_ring, selected_access,
                selected_sharing, status);
        ELSE
          device_class := rmc$mass_storage_device;
        IFEND;

        IF status.normal THEN
          fmp$process_pt_request (process_pt_work_list, r2_attach_input.lfn, evaluated_file_reference,
                p_cycle_description, process_pt_results, status);

          IF status.normal THEN
            cycle_number := r2_attach_input.cycle_selector.cycle_number;
          IFEND;
        IFEND;
      ELSE
        device_class := rmc$mass_storage_device;
      IFEND;
    ELSE
      status.normal := TRUE;
      cycle_attached := FALSE;
    IFEND;

    IF status.normal AND NOT cycle_attached THEN
      pmp$get_pseudo_mainframe_id (mainframe_id);
      usage_selector.option := pfc$specific_usage_option;
      usage_selector.usage_selections := usage_selections;
      share_selector.option := pfc$specific_share_option;
      share_selector.share_selections := share_selections;

      IF r2_attach_input.served_family THEN
        df_attach_input.mainframe_id := mainframe_id;
        df_attach_input.cycle_selector := r2_attach_input.cycle_selector;
        df_attach_input.password := r2_attach_input.password;
        df_attach_input.usage_selector := usage_selector;
        df_attach_input.share_selector := share_selector;
        df_attach_input.allowed_device_classes := - $fst$device_classes [];
        df_attach_input.allowed_cycle_damage_symptoms := allowed_cycle_damage_symptoms;
        df_attach_input.system_privilege := system_privilege;
        df_attach_input.validation_ring := validation_ring;
        df_attach_input.update_catalog := update_catalog;
        df_attach_input.update_cycle_statistics := update_cycle_statistics;
        df_attach_input.path_length := UPPERBOUND (r2_attach_input.p_path^);
        pfp$r2_df_client_attach (r2_attach_input.served_family_locator, r2_attach_input.lfn,
              r2_attach_input.p_path^, df_attach_input, cycle_number, device_class, cycle_damage_symptoms,
              global_file_name, status);
          IF (NOT status.normal) AND (status.condition = pfe$tape_attached_on_client) THEN
            PUSH p_local_status;
            iop$tape_file_attached (global_file_name, tape_file_attached, p_local_status^);
            IF p_local_status^.normal THEN
              IF tape_file_attached THEN
                PUSH p_fs_path;
                pfp$convert_pf_path_to_fs_path (r2_attach_input.p_path^, p_fs_path^, fs_path_size);
                osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_busy,
                      p_fs_path^ (1, fs_path_size), status);
                osp$append_status_integer (osc$status_parameter_delimiter, cycle_number, radix,
                      NOT include_radix, status);
                osp$append_status_parameter (osc$status_parameter_delimiter, pfc$multiple_job_usage_conflict,
                      status);
              ELSE
                pfp$r2_df_client_clear_cy_att (r2_attach_input.served_family_locator, r2_attach_input.p_path^,
                      r2_attach_input.cycle_selector, r2_attach_input.password, p_local_status^);
                IF NOT p_local_status^.normal THEN
                  status := p_local_status^;
                IFEND;
              IFEND;
            ELSE
              status := p_local_status^;
            IFEND;
          IFEND;
        authority_known := FALSE;
      ELSE
        p_file_server_buffers := NIL;
        pfp$r2_attach_file (pfc$local_mainframe, mainframe_id, r2_attach_input.lfn,
              r2_attach_input.p_complete_path^, r2_attach_input.cycle_selector, r2_attach_input.password,
              update_catalog, update_cycle_statistics, usage_selector, share_selector, system_privilege,
              validation_ring, {allowed_device_classes} - $fst$device_classes [],
              allowed_cycle_damage_symptoms, device_class, cycle_number, allowed_usage_selections,
              required_share_selections, cycle_damage_symptoms, authority, global_file_name,
              p_file_server_buffers, status);
        authority_known := status.normal;
      IFEND;
    ELSE
      authority_known := FALSE;
    IFEND;

    fmp$unlock_path_table;

    IF avp$security_option_active (avc$vso_security_audit) THEN
      audit_information.audited_operation := sfc$ao_fs_attach_file;
      IF r2_attach_input.served_family THEN
        audited_object.variant_path.complete_path := FALSE;
        audited_object.variant_path.p_path := r2_attach_input.p_path;
      ELSE
        audited_object.variant_path.complete_path := TRUE;
        audited_object.variant_path.p_complete_path := r2_attach_input.p_complete_path;
      IFEND;
      audited_object.object_type := sfc$afsot_cycle;
      IF (r2_attach_input.cycle_selector.cycle_option = pfc$specific_cycle) OR NOT status.normal THEN
        audited_object.cycle_selector_p := ^r2_attach_input.cycle_selector;
      ELSE
        cycle_selector.cycle_option := pfc$specific_cycle;
        cycle_selector.cycle_number := cycle_number;
        audited_object.cycle_selector_p := ^cycle_selector;
      IFEND;
      audited_object.device_class := device_class;
      audit_information.attach_file.object_id_p := ^audited_object;
      IF authority_known THEN
        audit_information.attach_file.ownership := authority.ownership;
      ELSE
        PUSH p_ignore_status;
        pfp$get_ownership (audited_object.variant_path, system_privilege,
              audit_information.attach_file.ownership, p_ignore_status^);
      IFEND;
      audit_information.attach_file.access_mode_p := ^usage_selections;
      sfp$emit_audit_statistic (audit_information, status);
    IFEND;
  PROCEND pfp$r2_attach;

?? TITLE := '  [XDCL] pfp$r2_attach_file', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to access the cycle and to process the
{   "attachment" or to start processing the attachment, depending on whether or
{   not the cycle is already attached within the job.

  PROCEDURE [XDCL] pfp$r2_attach_file
    (    family_location: pft$family_location;
         mainframe_id: pmt$binary_mainframe_id;
         lfn: amt$local_file_name;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         update_catalog: boolean;
         update_cycle_statistics: boolean;
         requested_usage_selector: pft$usage_selector;
         requested_share_selector: pft$share_selector;
         system_privilege: boolean;
         validation_ring: ost$valid_ring;
         allowed_device_classes: fst$device_classes,
         allowed_cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR device_class: rmt$device_class;
     VAR cycle_number: pft$cycle_number;
     VAR allowed_usage_selections: pft$usage_selections;
     VAR required_share_selections: pft$share_selections;
     VAR cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR authority: pft$authority;
     VAR global_file_name: ost$binary_unique_name;
     VAR p_file_server_buffers: {server only: i^/o^} pft$p_file_server_buffers;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      fmp$process_pt_request (process_pt_work_list, lfn, evaluated_file_reference, p_cycle_description,
            process_pt_results, local_status);
      fmp$delete_path_description (evaluated_file_reference, {implicit_detach} FALSE,
            {return_permanent_file} TRUE, {detachment_options} NIL, local_status);
      EXIT pfp$r2_attach_file;
    PROCEND initiate_non_local_exit;

    CONST
      implicit_attach = TRUE;

    VAR
      apft_index: pft$attached_pf_table_index,
      attachment_options: array [1 .. 1] of fst$attachment_option,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      cycle_attached: boolean,
      cycle_attachment_info: fmt$cycle_attachment_info,
      cycle_formerly_opened_info: fmt$cycle_formerly_opened_info,
      damage_symptoms_string: pft$selections_string,
      date_time: ost$date_time,
      dm_file_information: dmt$file_information,
      evaluated_file_reference: fst$evaluated_file_reference,
      existing_sft_entry: dmt$existing_sft_entry,
      file_damaged: boolean,
      fmd_modified: boolean,
      fs_device_class: fst$device_class,
      fs_path_size: fst$path_size,
      ignore_status: ost$status,
      local_status: ost$status,
      p_attached_pf_entry: ^pft$attached_pf_entry,
      p_cycle: ^pft$physical_cycle,
      p_cycle_description: ^fmt$cycle_description,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_fs_path: ^fst$path,
      p_internal_cycle_path: ^pft$internal_cycle_path,
      p_label: ^fmt$file_label,
      p_mainframe_usage_list: ^pft$mainframe_usage_list,
      p_path_string: ^ost$string,
      p_physical_fmd: ^pft$physical_fmd,
      p_stored_file_label: ^pft$physical_file_label,
      parent_charge_id: pft$charge_id,
      path_handle: fmt$path_handle,
      path_registered: boolean,
      path_table_cycle_info: fmt$path_table_cycle_info,
      permit_entry: pft$permit_entry,
      prevalidate_free_result: ost$prevalidate_free_result,
      process_non_local_exit: boolean,
      process_pt_results: bat$process_pt_results,
      selected_access: fst$file_access_options,
      selected_sharing: fst$file_access_options,
      sfid: gft$system_file_identifier,
      shared_queue: pft$shared_queue,
      share_selections: pft$share_selections,
      share_selector: pft$share_selector,
      usage_intentions: pft$permit_selections,
      usage_selections: pft$usage_selections,
      valid_archive_entry_exists: boolean;

    syp$push_inhibit_job_recovery;
    process_non_local_exit := FALSE;
    #SPOIL(process_non_local_exit);
    status.normal := TRUE;

    pmp$get_compact_date_time (date_time, local_status);
    pfp$process_unexpected_status (local_status);

    pfp$get_authority (path, system_privilege, authority, status);
    IF status.normal THEN
      PUSH p_internal_cycle_path: [1 .. UPPERBOUND (path)];
      IF update_catalog THEN
        pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$file_object],
              parent_charge_id, catalog_locator, p_file_object, p_internal_cycle_path^.path, permit_entry,
              status);
      ELSE
        pfp$access_object (path, pfc$read_access, authority, $pft$object_selections [pfc$file_object],
              parent_charge_id, catalog_locator, p_file_object, p_internal_cycle_path^.path, permit_entry,
              status);
      IFEND;
    IFEND;
    catalog_active := status.normal;

    osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

    IF status.normal THEN
      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
    IFEND;

    IF status.normal THEN
      cycle_number := p_cycle^.cycle_entry.cycle_number;

      IF cycle_selector.cycle_option = pfc$specific_cycle THEN
        evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
        evaluated_file_reference.cycle_reference.cycle_number := cycle_selector.cycle_number;
        path_registered := FALSE;
      ELSEIF family_location = pfc$local_mainframe THEN
        pfp$convert_pf_to_fs_structure (path, evaluated_file_reference);
        evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
        evaluated_file_reference.cycle_reference.cycle_number := p_cycle^.cycle_entry.cycle_number;
        fmp$get_path_table_cycle_info (inhibit_path_table_lock, evaluated_file_reference,
              path_table_cycle_info, status);
        IF status.normal THEN
          path_registered := path_table_cycle_info.path_registered;
        IFEND;
      ELSE {server mainframe and nonspecific cycle}
        path_registered := FALSE;
        pfp$locate_attached_file (p_cycle^.cycle_entry.internal_cycle_name, apft_index, p_attached_pf_entry,
              cycle_attached);
        IF cycle_attached THEN
          pfp$validate_password (path, authority, password, p_file_object, status);
          IF status.normal THEN
            osp$set_status_condition (pfe$cycle_attached_on_client, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal AND update_catalog AND (p_cycle^.cycle_entry.attach_status.attach_count > 0) AND
          (p_cycle^.cycle_entry.data_residence = pfc$release_data_requested) THEN
      pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, catalog_locator.p_catalog_file,
            p_physical_fmd);

      IF p_physical_fmd <> NIL THEN
        shared_queue := pfp$shared_queue (p_cycle^.cycle_entry.shared_queue_info, -$pft$share_selections []);
        dmp$attach_file (p_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file,
              p_physical_fmd^.fmd, $pft$usage_selections [], -$pft$share_selections [],
              pfc$average_share_history, pfc$maximum_pf_length, {restricted_attach} FALSE,
              {exit_on_unknown_file} TRUE, (family_location = pfc$server_mainframe), shared_queue,
              file_damaged, sfid, existing_sft_entry, local_status);

        IF local_status.normal THEN
          IF existing_sft_entry = dmc$normal_entry THEN
            pfp$detach_permanent_file (^path, sfid, $pft$usage_selections [], {catalog_access_allowed} TRUE,
                  p_cycle, catalog_locator.p_catalog_file, fmd_modified, dm_file_information, ignore_status);
          ELSEIF existing_sft_entry = dmc$entry_not_found THEN
            dmp$destroy_permanent_file (p_cycle^.cycle_entry.internal_cycle_name, p_physical_fmd^.fmd,
                  ignore_status);
            osp$prevalidate_free ((#OFFSET(p_physical_fmd) -
                  #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
                  ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
            IF prevalidate_free_result = osc$heap_free_valid THEN
              FREE p_physical_fmd IN catalog_locator.p_catalog_file^.catalog_heap;
            ELSE
              pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'FILE_MEDIA_DESCRIPTOR',
                    'file', prevalidate_free_result, #OFFSET(p_physical_fmd));
            IFEND;
            pfp$build_fmd_locator ({p_physical_fmd} NIL, {p_catalog_file} NIL,
                  p_cycle^.cycle_entry.fmd_locator);
            pfp$build_mainfram_list_pointer (p_cycle^.cycle_entry.mainframe_usage_list_locator,
                  catalog_locator.p_catalog_file, p_mainframe_usage_list);
            IF p_mainframe_usage_list <> NIL THEN
              osp$prevalidate_free ((#OFFSET(p_mainframe_usage_list) -
                    #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
                    ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
              IF prevalidate_free_result = osc$heap_free_valid THEN
                FREE p_mainframe_usage_list IN catalog_locator.p_catalog_file^.catalog_heap;
              ELSE
                pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'MAINFRAME_USAGE_LIST',
                      'file', prevalidate_free_result, #OFFSET(p_mainframe_usage_list));
                p_mainframe_usage_list := NIL;
              IFEND;
            IFEND;
            pfp$build_mainfram_list_locator ({p_mainframe_list} NIL, {p_catalog_file} NIL,
                  p_cycle^.cycle_entry.mainframe_usage_list_locator);
            p_cycle^.cycle_entry.data_residence := pfc$offline_data;
            p_cycle^.cycle_entry.attach_status := pfv$unattached_status;
            p_cycle^.cycle_entry.first_mainframe_usage_entry.entry_type := pfc$free_mainframe_entry;
            pfp$compute_checksum (^p_cycle^.cycle_entry, #SIZE (pft$cycle_entry), p_cycle^.checksum);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal AND (p_cycle^.cycle_entry.data_residence = pfc$offline_data) THEN
      pfp$check_archive_entries (catalog_locator.p_catalog_file, p_cycle, valid_archive_entry_exists,
            status);
      IF status.normal THEN
        PUSH p_fs_path;
        IF valid_archive_entry_exists THEN
          IF p_cycle^.cycle_entry.retrieve_option = pfc$explicit_retrieve_only THEN
            pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$explicit_retrieve_required,
                  p_fs_path^ (1, fs_path_size), status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  p_cycle^.cycle_entry.cycle_number, radix, NOT include_radix, status);
          ELSE
            pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_data_resides_offline,
                  p_fs_path^ (1, fs_path_size), status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  p_cycle^.cycle_entry.cycle_number, radix, NOT include_radix, status);
          IFEND;
        ELSE
          pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$undefined_data,
                p_fs_path^ (1, fs_path_size), status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                p_cycle^.cycle_entry.cycle_number, radix, NOT include_radix, status);
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      IF p_cycle^.cycle_entry.device_information.device_class_defined THEN
        pfp$convert_device_class_to_rm (p_cycle^.cycle_entry.device_information.device_class, device_class);
      ELSE
        device_class := rmc$mass_storage_device;
      IFEND;
      fsp$convert_device_class_to_fs (device_class, fs_device_class);

      IF device_class = rmc$mass_storage_device THEN
        share_selector := requested_share_selector;
      ELSEIF device_class = rmc$magnetic_tape_device THEN
        share_selector.option := pfc$specific_share_option;
        share_selector.share_selections  := $pft$share_selections [];
      IFEND;

      IF path_registered AND path_table_cycle_info.cycle_attachment_info.cycle_attached THEN
        pfp$validate_password (path, authority, password, p_file_object, status);

        IF status.normal THEN
          pfp$locate_attached_file (p_cycle^.cycle_entry.internal_cycle_name, apft_index, p_attached_pf_entry,
                cycle_attached);
          IF cycle_attached THEN
            IF NOT (fs_device_class IN allowed_device_classes) THEN
              PUSH p_fs_path;
              pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
              osp$set_status_abnormal (pfc$permanent_file_manager_id, fse$device_class_conflict,
                    p_fs_path^ (1, fs_path_size), status);
            ELSEIF allowed_cycle_damage_symptoms <> p_attached_pf_entry^.allowed_exception_conditions THEN
              PUSH p_fs_path;
              pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
              build_damage_symptoms_string (p_attached_pf_entry^.allowed_exception_conditions,
                    damage_symptoms_string);
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$allowed_damage_mismatch,
                    p_fs_path^ (1, fs_path_size), status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    damage_symptoms_string.value (1, damage_symptoms_string.size), status);
            IFEND;
          ELSE
            PUSH p_path_string;
            pfp$convert_cycle_path_to_strng (path, cycle_number, p_path_string^);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$duplicate_purged_cycle,
                  p_path_string^.value (1, p_path_string^.size), status);
          IFEND;
        IFEND;

        IF status.normal THEN
          attachment_options [1].selector := fsc$access_and_share_modes;

          IF requested_usage_selector.option = pfc$default_usage_option THEN
            attachment_options [1].access_modes.selector := fsc$permitted_access_modes;
          ELSE
            attachment_options [1].access_modes.selector := fsc$specific_access_modes;
            #UNCHECKED_CONVERSION (requested_usage_selector.usage_selections, attachment_options [1].
                  access_modes.value);
          IFEND;

          IF share_selector.option = pfc$default_share_option THEN
            attachment_options [1].share_modes.selector := fsc$determine_from_access_modes;
          ELSE
            attachment_options [1].share_modes.selector := fsc$specific_share_modes;
            #UNCHECKED_CONVERSION (share_selector.share_selections, attachment_options [1].share_modes.value);
          IFEND;

          cycle_attachment_info := path_table_cycle_info.cycle_attachment_info;

          IF path_table_cycle_info.cycle_device_info.device_assigned THEN
            cycle_formerly_opened_info := path_table_cycle_info.cycle_device_info.cycle_formerly_opened_info;
          ELSE
            cycle_formerly_opened_info.cycle_previously_opened := FALSE;
          IFEND;

          pfp$pick_modes_for_open (evaluated_file_reference, ^attachment_options,
                cycle_attachment_info.allowed_access, cycle_attachment_info.required_sharing,
                path_table_cycle_info.setfa_access_modes, device_class, cycle_formerly_opened_info,
                {called_by_attach} TRUE, {create_file} FALSE, validation_ring, selected_access,
                selected_sharing, status);
        IFEND;

        IF status.normal THEN
          fmp$process_pt_request (process_pt_work_list, lfn, evaluated_file_reference, p_cycle_description,
                process_pt_results, status);
        IFEND;

        IF status.normal THEN
          cycle_number := evaluated_file_reference.cycle_reference.cycle_number;
          #UNCHECKED_CONVERSION (cycle_attachment_info.allowed_access, allowed_usage_selections);
          #UNCHECKED_CONVERSION (cycle_attachment_info.required_sharing, required_share_selections);
          cycle_damage_symptoms := $fst$cycle_damage_symptoms [];
        IFEND;
      ELSE
        {
        { Attach the file.
        {
        pfp$validate_password (path, authority, password, p_file_object, status);

        IF status.normal THEN
          pfp$form_administrator_permit (authority, permit_entry);
          determine_usage_permitted (requested_usage_selector, permit_entry, usage_selections,
                allowed_usage_selections);
          pfp$map_usage_selections (usage_selections, usage_intentions);
          determine_share_with_pf_option (share_selector, permit_entry, usage_selections, share_selections,
                required_share_selections);
          pfp$validate_file_permission (path, authority, permit_entry, usage_intentions, share_selections,
                status);
        IFEND;

        IF status.normal AND NOT (fs_device_class IN allowed_device_classes) THEN
          PUSH p_fs_path;
          pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, fse$device_class_conflict,
                p_fs_path^ (1, fs_path_size), status);
        IFEND;

        IF status.normal THEN
          pfp$build_file_label_pointer (p_cycle^.cycle_entry.file_label_locator,
                catalog_locator.p_catalog_file, p_stored_file_label);
          IF p_stored_file_label = NIL THEN
            p_label := NIL;
          ELSE
            p_label := ^p_stored_file_label^.file_label;
          IFEND;
          global_file_name := p_cycle^.cycle_entry.global_file_name;
          attach_cycle (family_location, mainframe_id, path, lfn, device_class, date_time, authority,
                update_catalog, update_cycle_statistics, usage_selections, share_selections,
                permit_entry.application_info, validation_ring, allowed_cycle_damage_symptoms,
                {enable_media_damage_detection} FALSE, NOT implicit_attach, p_label,
                catalog_locator.p_catalog_file, p_file_object, p_internal_cycle_path, p_cycle,
                catalog_locator.flush_catalog_pages, path_handle, cycle_damage_symptoms,
                p_file_server_buffers, status);
        IFEND;
      IFEND;
    ELSE
      device_class := rmc$mass_storage_device;
    IFEND;

    osp$disestablish_cond_handler;
    IF catalog_active THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
    pfv$locked_apfid := 0;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_attach_file;

?? TITLE := '  [XDCL] pfp$r2_attach_or_create', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to access the cycle and to process the
{   "attachment" or to start processing the creation or attachment, depending
{   on whether or not the cycle is already attached within the job.

  PROCEDURE [XDCL] pfp$r2_attach_or_create
    (    family_location: pft$family_location;
         mainframe_id: pmt$binary_mainframe_id;
         validation_ring: ost$valid_ring;
         system_privilege: boolean;
         exception_selection_info: pft$exception_selection_info;
         p_attachment_options: {input} ^fst$attachment_options;
         p_file_label: {input} ^fmt$file_label;
         p_path_table_cycle_info: {input} ^fmt$path_table_cycle_info;
         fs_retention: fst$retention;
         retrieve_option: pft$retrieve_option;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR action_attempted: pft$action_attempted;
     VAR action_taken: pft$attach_or_create_action;
     VAR authority: pft$authority;
     VAR allowed_access: fst$file_access_options;
     VAR selected_access: fst$file_access_options;
     VAR required_sharing: fst$file_access_options;
     VAR selected_sharing: fst$file_access_options;
     VAR device_class: rmt$device_class;
     VAR global_file_name: ost$binary_unique_name;
     VAR new_global_file_name: ost$binary_unique_name;
     VAR new_remote_sfid: gft$system_file_identifier;
     VAR label_used: boolean;
     VAR bytes_allocated: amt$file_byte_address;
     VAR p_file_server_buffers: {server only: i^/o^} ^pft$file_server_buffers;
     VAR status: ost$status);

?? NEWTITLE := '         attach_or_create_handler', EJECT ??

    PROCEDURE attach_or_create_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        variant_path: pft$variant_path,
        status_id: ost$status_identifier,
        local_status: ost$status;

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := p_complete_path;

      IF NOT process_non_local_exit THEN
        pfp$log_ascii ('***PF Condition Handler***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, {critical_message} FALSE, local_status);
        pfp$log_path (variant_path, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
              {critical_message} FALSE, local_status);
      IFEND;

      CASE condition.selector OF
      = pmc$system_conditions, pmc$block_exit_processing, mmc$segment_access_condition =
        IF process_non_local_exit THEN
          RETURN;
        IFEND;

        IF catalog_locator.attached THEN
          catalog_locator.abort_catalog_operation := TRUE;
          pfp$return_catalog (catalog_locator, local_status);
          IF NOT local_status.normal THEN
            pfp$report_system_error (local_status);
          IFEND;
        IFEND;

        syp$pop_inhibit_job_recovery;

        IF pfv$locked_apfid <> 0 THEN
          pfp$release_locked_apfid (pfv$locked_apfid, local_status);
          pfv$locked_apfid := 0;
        IFEND;

        fmp$delete_path_description (evaluated_file_reference, {implicit_detach} TRUE,
              {return_permanent_file} TRUE, {detachment_options} NIL, local_status);

        osp$set_status_from_condition (status_id, condition, p_sfsa, local_status, handler_status);
        osp$recoverable_system_error ('UNEXPECTED STATUS', ^local_status);

        status := local_status;
        initiate_non_local_exit;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pfp$log_ascii ('***Recover Files***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
                pmc$msg_origin_system, {critical_message} FALSE, local_status);
         { syp$invalidate_open_sfid (catalog_locator.system_file_id, local_status);
          initiate_non_local_exit;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND attach_or_create_handler;

?? OLDTITLE ??
?? NEWTITLE := '         check_all_volumes_available', EJECT ??

    PROCEDURE check_all_volumes_available
      (    p_stored_fmd: {input} ^dmt$stored_fmd;
       VAR all_volumes_available: boolean;
       VAR status: ost$status);

      VAR
        fmd_header: pft$fmd_header,
        p_unique_volume_list: ^pft$unique_volume_list,
        volume_index: integer;

      all_volumes_available := TRUE;

      dmp$get_stored_fmd_header_info (p_stored_fmd, fmd_header, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      PUSH p_unique_volume_list: [1 .. fmd_header.number_of_subfiles];
      dmp$get_unique_fmd_volume_list (p_stored_fmd, p_unique_volume_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    /search_volume_list/
      FOR volume_index := LOWERBOUND (p_unique_volume_list^) TO UPPERBOUND (p_unique_volume_list^) DO
        IF osp$get_volume_condition (p_unique_volume_list^ [volume_index]) IN
              $fst$file_access_conditions [fsc$media_missing, fsc$volume_unavailable] THEN
          all_volumes_available := FALSE;
          EXIT /search_volume_list/;
        IFEND;
      FOREND /search_volume_list/;

    PROCEND check_all_volumes_available;

?? OLDTITLE ??
?? NEWTITLE := '         check_delete_data_allowed', EJECT ??

    PROCEDURE check_delete_data_allowed
      (     evaluated_file_reference: fst$evaluated_file_reference;
            exception_selection_info: pft$exception_selection_info;
            intended_access: fst$file_access_options;
            intended_sharing: fst$file_access_options;
            eoi: amt$file_byte_address;
            p_file_label: ^fmt$file_label;
            cycle_attachment_status: ost$status;
        VAR delete_data_allowed: boolean);

      VAR
        delete_data_specified: boolean,
        dynamic_label: bat$dynamic_label_attributes,
        file_organization: amt$file_organization,
        file_previously_opened: boolean,
        local_status: ost$status,
        never_opened: boolean,
        offline_data: boolean,
        open_position: amt$open_position,
        p_cycle_description: ^fmt$cycle_description,
        p_local_file_label: ^fmt$file_label,
        p_static_label_header: ^fmt$static_label_header,
        previously_opened: boolean,
        sequential_record_access: boolean,
        setfa_open_position: amt$open_position,
        setfa_open_position_source: amt$attribute_source,
        static_label_attributes: bat$static_label_attributes,
        undefined_data: boolean;

      setfa_open_position_source := amc$access_method_default;

      fmp$locate_cd_via_path_handle (evaluated_file_reference.path_handle_info.path_handle,
            {lock_path_table} FALSE, p_cycle_description, local_status);
      IF local_status.normal AND (p_cycle_description^.dynamic_setfa_entries <> NIL) THEN
        fmp$extract_dynamic_setfa_attrs (p_cycle_description^.dynamic_setfa_entries, dynamic_label);
        IF dynamic_label.open_position_source <> amc$access_method_default THEN
          setfa_open_position := dynamic_label.open_position;
          setfa_open_position_source := dynamic_label.open_position_source;
        IFEND;
      IFEND;
      IF (exception_selection_info.open_position_source = amc$access_method_default) AND
            (setfa_open_position_source <> amc$access_method_default) THEN
        open_position := setfa_open_position;
      ELSE
        open_position := exception_selection_info.open_position;
      IFEND;

      file_organization := amc$sequential;
      previously_opened := FALSE;

      IF p_file_label <> NIL THEN
        p_local_file_label := p_file_label;
        NEXT p_static_label_header IN p_local_file_label;
        IF (p_static_label_header <> NIL) AND
              (p_static_label_header^.unique_character = fmc$unique_label_id) THEN
          fsp$expand_file_label (p_file_label, static_label_attributes, file_previously_opened, local_status);
          IF local_status.normal THEN
            previously_opened := file_previously_opened;
            file_organization := static_label_attributes.file_organization;
          IFEND;
        IFEND;
      IFEND;

      { The data for the cycle resides offline.
      offline_data := ((NOT cycle_attachment_status.normal) AND
            (cycle_attachment_status.condition = pfe$cycle_data_resides_offline)) AND
            (intended_access * $fst$file_access_options [fsc$read, fsc$execute] =
            $fst$file_access_options []);

      { The cycle entry was restored but the cycle data was not.
      undefined_data := ((NOT cycle_attachment_status.normal) AND
            (cycle_attachment_status.condition = pfe$undefined_data)) AND
            (intended_access * $fst$file_access_options [fsc$read, fsc$execute] =
            $fst$file_access_options []);

      { The cycle has never been opened.
      never_opened := (cycle_attachment_status.normal OR
            ((NOT cycle_attachment_status.normal) AND
            (cycle_attachment_status.condition <> pfe$undefined_data))) AND
            (NOT previously_opened) AND (eoi = 0);

      { The delete_data attachment option was specified.
      delete_data_specified := exception_selection_info.delete_data;

      { The file organization is sequential and the file is being opened for record access.
      sequential_record_access :=
            ((file_organization = amc$sequential) AND (exception_selection_info.access_level = amc$record) AND
            (intended_access * $fst$file_access_options [fsc$read, fsc$execute] =
            $fst$file_access_options []));

      delete_data_allowed :=
            ((open_position = amc$open_at_boi) AND (fsc$shorten IN intended_access) AND
            (intended_sharing = $fst$file_access_options [])) AND
            (offline_data OR undefined_data OR never_opened OR delete_data_specified OR
            sequential_record_access);

    PROCEND check_delete_data_allowed;

?? EJECT ??
?? OLDTITLE ??

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_attach_or_create;
    PROCEND initiate_non_local_exit;

    CONST
      implicit_attach = TRUE;

    VAR
      allowed_cycle_damage_symptoms: fst$cycle_damage_symptoms,
      allowed_device_classes: fst$device_classes,
      all_volumes_available: boolean,
      apft_index: pft$attached_pf_table_index,
      archive_status: ost$status,
      catalog_attached: boolean,
      catalog_locator: pft$catalog_locator,
      create_file: boolean,
      cycle_attached: boolean,
      cycle_attachment_info: fmt$cycle_attachment_info,
      cycle_formerly_opened_info: fmt$cycle_formerly_opened_info,
      cycle_number: pft$cycle_number,
      cycle_reference: fst$cycle_reference,
      cycle_selector: pft$cycle_selector,
      cycle_damage_symptoms: fst$cycle_damage_symptoms,
      damage_symptoms_string: pft$selections_string,
      date_time: ost$date_time,
      delete_data_allowed: boolean,
      device_assigned: boolean,
      dm_file_information: dmt$file_information,
      enable_media_damage_detection: boolean,
      existing_sft_entry: dmt$existing_sft_entry,
      fetch_new_cycle_info: boolean,
      file_damaged: boolean,
      file_index: 1 .. fsc$max_path_elements + 1,
      file_info: dmt$file_information,
      fmd_header_info: pft$fmd_header,
      fmd_modified: boolean,
      fmd_reconciliation_required: boolean,
      fs_device_class: fst$device_class,
      fs_path_size: fst$path_size,
      ignore_apft_index: pft$attached_pf_table_index,
      ignore_status: ost$status,
      intended_access: fst$file_access_options,
      intended_sharing: fst$file_access_options,
      internal_cycle_name: pft$internal_name,
      local_password: pft$password,
      local_status: ost$status,
      p_attached_pf_entry: ^pft$attached_pf_entry,
      p_complete_path: ^pft$complete_path,
      p_cycle: ^pft$physical_cycle,
      p_cycle_description: ^fmt$cycle_description,
      p_cycle_list: ^pft$cycle_list,
      p_evaluated_file_reference: ^fst$evaluated_file_reference,
      p_file_object: ^pft$physical_object,
      p_fs_path: ^fst$path,
      p_internal_cycle_path: ^pft$internal_cycle_path,
      p_label: ^fmt$file_label,
      p_mainframe_usage_list: ^pft$mainframe_usage_list,
      p_path_element: ^fst$path_element_string,
      p_path_string: ^ost$string,
      p_physical_fmd: ^pft$physical_fmd,
      p_stored_file_label: ^pft$physical_file_label,
      parent_charge_id: pft$charge_id,
      password_specified: boolean,
      path_description_created: boolean,
      path_table_cycle_info: fmt$path_table_cycle_info,
      permit_entry: pft$permit_entry,
      physical_object: pft$physical_object,
      prevalidate_free_result: ost$prevalidate_free_result,
      process_non_local_exit: boolean,
      save_file_label: boolean,
      saved_attach_status: pft$attach_status,
      setfa_access_modes: fst$access_modes,
      sfid: gft$system_file_identifier,
      share_modes: fst$share_modes,
      share_option: pft$share_options,
      share_selections: pft$share_selections,
      shared_queue: pft$shared_queue,
      sharing_required: pft$share_selections,
      usage_allowed: pft$usage_selections,
      usage_option: pft$usage_options,
      usage_selections: pft$usage_selections,
      valid_file_name: boolean,
      valid_archive_entry_exists: boolean,
      valid_objects: pft$object_selections,
      variant_path: pft$variant_path;

    syp$push_inhibit_job_recovery;

    action_attempted := pfc$no_action_attempted;
    bytes_allocated := 0;
    device_class := rmc$mass_storage_device;
    new_global_file_name := dmv$null_global_file_name;
    new_remote_sfid := dmv$null_sfid;
    label_used := FALSE;
    path_description_created := FALSE;
    process_non_local_exit := FALSE;
    #SPOIL(process_non_local_exit);
    selected_access := $fst$file_access_options [];
    status.normal := TRUE;
    archive_status.normal := TRUE;

    pmp$get_compact_date_time (date_time, local_status);
    pfp$process_unexpected_status (local_status);
    pfi$get_password (p_attachment_options, password_specified, local_password);
    pfp$get_allowed_device_classes (p_attachment_options, allowed_device_classes);
    pfp$get_cycle_damage_options (p_attachment_options, enable_media_damage_detection,
          allowed_cycle_damage_symptoms);

    file_index := evaluated_file_reference.number_of_path_elements + 1;
    PUSH p_complete_path: [1 .. file_index];
    pfp$convert_fs_to_complete_path (evaluated_file_reference, p_complete_path, status);

    IF status.normal THEN
      cycle_reference := evaluated_file_reference.cycle_reference;
      pfi$convert_cycle_reference (cycle_reference, cycle_selector, status);
    IFEND;

    IF status.normal THEN
      pfp$get_authority (p_complete_path^, system_privilege, authority, status);
    IFEND;

    IF status.normal THEN
      pfi$get_create_file_option (p_attachment_options, cycle_reference, create_file);
      IF create_file THEN
        valid_objects := $pft$object_selections [pfc$free_object, pfc$file_object];
      ELSE
        valid_objects := $pft$object_selections [pfc$file_object];
      IFEND;
      PUSH p_internal_cycle_path: [1 .. file_index];
      pfp$access_object (p_complete_path^, pfc$write_access, authority, valid_objects, parent_charge_id,
            catalog_locator, p_file_object, p_internal_cycle_path^.path, permit_entry, status);
      IF NOT status.normal THEN
        action_attempted := pfc$dm_attachment_attempted;
      IFEND;
    IFEND;
    catalog_attached := status.normal;
    osp$establish_condition_handler (^attach_or_create_handler, {block_exit} TRUE);

    IF status.normal AND (p_file_object^.object_entry.object_type = pfc$file_object) THEN
      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
    IFEND;

    IF status.normal AND (p_file_object^.object_entry.object_type = pfc$file_object) AND
          (cycle_reference.specification <> fsc$next_cycle) THEN
      pfp$locate_cycle (p_complete_path^, p_cycle_list, cycle_selector, p_cycle, status);

      IF status.normal THEN
        global_file_name := p_cycle^.cycle_entry.global_file_name;
        IF p_cycle^.cycle_entry.device_information.device_class_defined THEN
          pfp$convert_device_class_to_rm (p_cycle^.cycle_entry.device_information.device_class, device_class);
        IFEND;
        fsp$convert_device_class_to_fs (device_class, fs_device_class);

        IF cycle_reference.specification <> fsc$cycle_number THEN
          cycle_reference.specification := fsc$cycle_number;
          cycle_reference.cycle_number := p_cycle^.cycle_entry.cycle_number;
          evaluated_file_reference.cycle_reference := cycle_reference;

          IF family_location = pfc$local_mainframe THEN
            fmp$get_path_table_cycle_info (inhibit_path_table_lock, evaluated_file_reference,
                  path_table_cycle_info, status);
          ELSE {server mainframe and nonspecific cycle}
            IF p_path_table_cycle_info = NIL THEN
              path_table_cycle_info.path_registered := FALSE;
            ELSEIF p_cycle^.cycle_entry.cycle_number = p_path_table_cycle_info^.cycle_number THEN
              path_table_cycle_info := p_path_table_cycle_info^;
            ELSE
              check_path_table_cycle_number (p_cycle^.cycle_entry.cycle_number, cycle_selector,
                    p_path_table_cycle_info^.cycle_number, fetch_new_cycle_info);
              IF fetch_new_cycle_info THEN
                osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recheck_client_mainframe,
                      'attach_or_create', status);
              ELSE
                path_table_cycle_info.path_registered := FALSE;
              IFEND;
            IFEND;
          IFEND;
        ELSEIF p_path_table_cycle_info = NIL THEN
          path_table_cycle_info.path_registered := FALSE;
        ELSE
          path_table_cycle_info := p_path_table_cycle_info^;
        IFEND;
      IFEND;

      IF status.normal AND (p_cycle^.cycle_entry.attach_status.attach_count > 0) AND
            (p_cycle^.cycle_entry.data_residence = pfc$release_data_requested) THEN
        pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, catalog_locator.p_catalog_file,
              p_physical_fmd);

        IF p_physical_fmd <> NIL THEN
          shared_queue := pfp$shared_queue (p_cycle^.cycle_entry.shared_queue_info,
                -$pft$share_selections []);
          dmp$attach_file (p_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file,
                p_physical_fmd^.fmd, $pft$usage_selections [], -$pft$share_selections [],
                pfc$average_share_history, pfc$maximum_pf_length, {restricted_attach} FALSE,
                {exit_on_unknown_file} TRUE, (family_location = pfc$server_mainframe), shared_queue,
                file_damaged, sfid, existing_sft_entry, local_status);

          IF local_status.normal THEN
            IF existing_sft_entry = dmc$normal_entry THEN
              pfp$detach_permanent_file (p_complete_path, sfid, $pft$usage_selections [],
                    {catalog_access_allowed} TRUE, p_cycle, catalog_locator.p_catalog_file, fmd_modified,
                    dm_file_information, ignore_status);
            ELSEIF existing_sft_entry = dmc$entry_not_found THEN
              dmp$destroy_permanent_file (p_cycle^.cycle_entry.internal_cycle_name, p_physical_fmd^.fmd,
                    ignore_status);
              osp$prevalidate_free ((#OFFSET(p_physical_fmd) -
                    #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
                    ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
              IF prevalidate_free_result = osc$heap_free_valid THEN
                FREE p_physical_fmd IN catalog_locator.p_catalog_file^.catalog_heap;
              ELSE
                pfp$report_invalid_free (p_complete_path, ^p_cycle^.cycle_entry.cycle_number,
                      'FILE_MEDIA_DESCRIPTOR', 'file', prevalidate_free_result, #OFFSET(p_physical_fmd));
              IFEND;
              pfp$build_fmd_locator ({p_physical_fmd} NIL, {p_catalog_file} NIL,
                    p_cycle^.cycle_entry.fmd_locator);
              pfp$build_mainfram_list_pointer (p_cycle^.cycle_entry.mainframe_usage_list_locator,
                    catalog_locator.p_catalog_file, p_mainframe_usage_list);
              IF p_mainframe_usage_list <> NIL THEN
                osp$prevalidate_free ((#OFFSET(p_mainframe_usage_list) -
                      #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
                      ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
                IF prevalidate_free_result = osc$heap_free_valid THEN
                  FREE p_mainframe_usage_list IN catalog_locator.p_catalog_file^.catalog_heap;
                ELSE
                  pfp$report_invalid_free (p_complete_path, ^p_cycle^.cycle_entry.cycle_number,
                        'MAINFRAME_USAGE_LIST', 'file', prevalidate_free_result,
                        #OFFSET(p_mainframe_usage_list));
                IFEND;
              IFEND;
              pfp$build_mainfram_list_locator ({p_mainframe_list} NIL, {p_catalog_file} NIL,
                  p_cycle^.cycle_entry.mainframe_usage_list_locator);
              p_cycle^.cycle_entry.data_residence := pfc$offline_data;
              p_cycle^.cycle_entry.attach_status := pfv$unattached_status;
              p_cycle^.cycle_entry.first_mainframe_usage_entry.entry_type := pfc$free_mainframe_entry;
              pfp$compute_checksum (^p_cycle^.cycle_entry, #SIZE (pft$cycle_entry), p_cycle^.checksum);
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      IF status.normal AND (p_cycle^.cycle_entry.data_residence = pfc$offline_data) THEN
        pfp$check_archive_entries (catalog_locator.p_catalog_file, p_cycle, valid_archive_entry_exists,
              archive_status);
        IF archive_status.normal THEN
          PUSH p_fs_path;
          IF valid_archive_entry_exists THEN
            IF p_cycle^.cycle_entry.retrieve_option = pfc$explicit_retrieve_only THEN
              pfp$convert_pf_path_to_fs_path (p_complete_path^, p_fs_path^, fs_path_size);
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$explicit_retrieve_required,
                    p_fs_path^ (1, fs_path_size), archive_status);
              osp$append_status_integer (osc$status_parameter_delimiter,
                    p_cycle^.cycle_entry.cycle_number, radix, NOT include_radix, archive_status);
            ELSE
              pfp$convert_pf_path_to_fs_path (p_complete_path^, p_fs_path^, fs_path_size);
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_data_resides_offline,
                    p_fs_path^ (1, fs_path_size), archive_status);
              osp$append_status_integer (osc$status_parameter_delimiter,
                    p_cycle^.cycle_entry.cycle_number, radix, NOT include_radix, archive_status);
            IFEND;
          ELSE
            pfp$convert_pf_path_to_fs_path (p_complete_path^, p_fs_path^, fs_path_size);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$undefined_data,
                  p_fs_path^ (1, fs_path_size), archive_status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  p_cycle^.cycle_entry.cycle_number, radix, NOT include_radix, archive_status);
          IFEND;
        IFEND;
      IFEND;

      IF status.normal THEN
        p_attached_pf_entry := NIL;
        IF path_table_cycle_info.path_registered AND
              path_table_cycle_info.cycle_attachment_info.cycle_attached THEN
          {
          { The cycle is already attached within the job.
          {
          action_attempted := pfc$fm_attachment_attempted;

          IF password_specified THEN
            pfp$validate_password (p_complete_path^, authority, local_password, p_file_object, status);
          IFEND;

          IF status.normal THEN
            pfp$locate_attached_file (p_cycle^.cycle_entry.internal_cycle_name, apft_index,
                  p_attached_pf_entry, cycle_attached);
            IF cycle_attached THEN
              IF NOT (fs_device_class IN allowed_device_classes) THEN
                variant_path.complete_path := TRUE;
                variant_path.p_complete_path := p_complete_path;
                pfp$set_status_abnormal (variant_path, fse$device_class_conflict, status);
              ELSEIF allowed_cycle_damage_symptoms <> p_attached_pf_entry^.allowed_exception_conditions THEN
                variant_path.complete_path := TRUE;
                variant_path.p_complete_path := p_complete_path;
                pfp$set_status_abnormal (variant_path, pfe$allowed_damage_mismatch, status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      damage_symptoms_string.value (1, damage_symptoms_string.size), status);
              IFEND;
            ELSE
              PUSH p_path_string;
              pfp$convert_cycle_path_to_strng (p_complete_path^, p_cycle^.cycle_entry.cycle_number,
                    p_path_string^);
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$duplicate_purged_cycle,
                    p_path_string^.value (1, p_path_string^.size), status);
            IFEND;
          IFEND;

          IF status.normal THEN
            cycle_attachment_info := path_table_cycle_info.cycle_attachment_info;

            IF path_table_cycle_info.cycle_device_info.device_assigned THEN
              cycle_formerly_opened_info :=
                    path_table_cycle_info.cycle_device_info.cycle_formerly_opened_info;
            ELSE
              cycle_formerly_opened_info.cycle_previously_opened := FALSE;
            IFEND;

            pfp$pick_modes_for_open (evaluated_file_reference, p_attachment_options,
                  cycle_attachment_info.allowed_access, cycle_attachment_info.required_sharing,
                  path_table_cycle_info.setfa_access_modes, device_class, cycle_formerly_opened_info,
                  {called_by_attach} FALSE, create_file, validation_ring, selected_access, selected_sharing,
                  status);
          IFEND;
          IF status.normal THEN
            evaluated_file_reference.cycle_reference := cycle_reference;
            evaluated_file_reference.path_resolution := fsc$cycle_path;
            action_taken := pfc$cycle_already_attached;
            allowed_access := cycle_attachment_info.allowed_access;
            required_sharing := cycle_attachment_info.required_sharing;

            IF (device_class = rmc$mass_storage_device) AND (cycle_attachment_info.open_count = 0) THEN
              pfp$build_file_label_pointer (p_cycle^.cycle_entry.file_label_locator,
                    catalog_locator.p_catalog_file, p_stored_file_label);
              IF p_stored_file_label = NIL THEN
                p_label := NIL;
              ELSE
                p_label := ^p_stored_file_label^.file_label;
              IFEND;

              check_delete_data_allowed (evaluated_file_reference, exception_selection_info,
                    selected_access, selected_sharing, p_cycle^.cycle_entry.device_information.eoi, p_label,
                    status, delete_data_allowed);
              IF delete_data_allowed AND (p_cycle^.cycle_entry.attach_status.attach_count <= 1) THEN
                pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, catalog_locator.p_catalog_file,
                      p_physical_fmd);
                IF p_physical_fmd <> NIL THEN
                  check_all_volumes_available (^p_physical_fmd^.fmd, all_volumes_available, local_status);
                  IF NOT local_status.normal THEN
                    all_volumes_available := TRUE;
                  IFEND;
                ELSE
                  all_volumes_available := FALSE;
                IFEND;

                IF NOT all_volumes_available THEN
                  IF family_location = pfc$local_mainframe THEN
                    fmp$locate_cd_via_path_handle (evaluated_file_reference.path_handle_info.path_handle,
                          {lock_path_table} FALSE, p_cycle_description, local_status);
                  ELSE
                    p_cycle_description := NIL;
                    local_status.normal := TRUE;
                  IFEND;
                  IF local_status.normal THEN
                    #UNCHECKED_CONVERSION (selected_access, usage_selections);
                    #UNCHECKED_CONVERSION (selected_sharing, share_selections);
                    recreate_cycle_data (family_location, mainframe_id, p_complete_path^, authority,
                          usage_selections, share_selections, permit_entry.application_info, validation_ring,
                          {password_protected} (p_file_object^.object_entry.password <> osc$null_name),
                          enable_media_damage_detection, apft_index, p_label, p_cycle_description,
                          catalog_locator, p_cycle, p_internal_cycle_path, p_attached_pf_entry,
                          evaluated_file_reference, new_global_file_name, new_remote_sfid, bytes_allocated,
                          p_file_server_buffers, status);
                    IF status.normal THEN
                      action_taken := pfc$cycle_already_attached;
                    IFEND;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          ELSEIF status.condition = pfe$cycle_busy THEN
            action_taken := pfc$cycle_already_attached;
          IFEND;
        ELSE
          {
          { The cycle exists but is not attached within the job.
          {
          action_attempted := pfc$dm_attachment_attempted;

          pfp$validate_password (p_complete_path^, authority, local_password, p_file_object, status);

          IF status.normal AND NOT (fs_device_class IN allowed_device_classes) THEN
            variant_path.complete_path := TRUE;
            variant_path.p_complete_path := p_complete_path;
            pfp$set_status_abnormal (variant_path, fse$device_class_conflict, status);
          IFEND;

          IF status.normal THEN
            fmd_reconciliation_required := FALSE;

            IF p_cycle^.cycle_entry.attach_status.attach_count > 0 THEN
              IF device_class = rmc$mass_storage_device THEN
                dmp$locate_existing_sft_entry (p_cycle^.cycle_entry.internal_cycle_name,
                      gfc$fk_job_permanent_file, existing_sft_entry, file_info, status);
                IF status.normal THEN
                  IF existing_sft_entry = dmc$entry_not_found THEN
                    fmd_reconciliation_required := TRUE;
                    saved_attach_status := p_cycle^.cycle_entry.attach_status;
                    p_cycle^.cycle_entry.attach_status := pfv$unattached_status;
                    p_cycle^.cycle_entry.first_mainframe_usage_entry.entry_type := pfc$free_mainframe_entry;
                    pfp$build_mainfram_list_pointer (p_cycle^.cycle_entry.mainframe_usage_list_locator,
                          catalog_locator.p_catalog_file, p_mainframe_usage_list);
                    IF p_mainframe_usage_list <> NIL THEN
                      osp$prevalidate_free ((#OFFSET(p_mainframe_usage_list) -
                            #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
                            ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
                      IF prevalidate_free_result = osc$heap_free_valid THEN
                        FREE p_mainframe_usage_list IN catalog_locator.p_catalog_file^.catalog_heap;
                      ELSE
                        pfp$report_invalid_free (p_complete_path, ^p_cycle^.cycle_entry.cycle_number,
                              'MAINFRAME_USAGE_LIST', 'file', prevalidate_free_result,
                              #OFFSET(p_mainframe_usage_list));
                        p_mainframe_usage_list := NIL;
                      IFEND;
                    IFEND;
                    pfp$build_mainfram_list_locator ({p_mainframe_list} NIL, {p_catalog_file} NIL,
                          p_cycle^.cycle_entry.mainframe_usage_list_locator);
                    pfp$compute_checksum (^p_cycle^.cycle_entry, #SIZE (pft$cycle_entry), p_cycle^.checksum);
                  IFEND;
                ELSE
                  pfp$report_unexpected_status (status);
                IFEND;
              IFEND;
            IFEND;

            IF path_table_cycle_info.path_registered THEN
              setfa_access_modes := path_table_cycle_info.setfa_access_modes;
            ELSE
              setfa_access_modes.selector := fsc$permitted_access_modes;
            IFEND;

            pfp$form_administrator_permit (authority, permit_entry);
            pfp$build_file_label_pointer (p_cycle^.cycle_entry.file_label_locator,
                  catalog_locator.p_catalog_file, p_stored_file_label);

            IF p_stored_file_label = NIL THEN
              pick_modes_for_attach (p_complete_path^, cycle_reference, mainframe_id, authority,
                    p_attachment_options, setfa_access_modes, device_class, permit_entry,
                    p_cycle^.cycle_entry, {p_old_file_label} NIL, p_file_label, validation_ring,
                    catalog_locator.p_catalog_file, usage_allowed, usage_selections,
                    sharing_required, share_selections, save_file_label, status);
            ELSE
              pick_modes_for_attach (p_complete_path^, cycle_reference, mainframe_id, authority,
                    p_attachment_options, setfa_access_modes, device_class, permit_entry,
                    p_cycle^.cycle_entry, ^p_stored_file_label^.file_label, p_file_label,
                    validation_ring, catalog_locator.p_catalog_file, usage_allowed,
                    usage_selections, sharing_required, share_selections, save_file_label, status);
            IFEND;
            #UNCHECKED_CONVERSION (usage_selections, selected_access);

            IF fmd_reconciliation_required THEN
              p_cycle^.cycle_entry.attach_status := saved_attach_status;
              pfp$compute_checksum (^p_cycle^.cycle_entry, #SIZE (pft$cycle_entry), p_cycle^.checksum);
            IFEND;
          IFEND;

          p_label := NIL;

          IF status.normal THEN
            status := archive_status;
            IF save_file_label AND (p_file_label <> NIL) THEN
              p_label := p_file_label;
            ELSEIF p_stored_file_label <> NIL THEN
              p_label := ^p_stored_file_label^.file_label;
            IFEND;
          ELSEIF (status.condition = pfe$cycle_busy) OR (status.condition = pfe$sharing_not_permitted) THEN
            IF NOT archive_status.normal THEN
              status := archive_status;
            IFEND;
          IFEND;

          IF status.normal THEN
            attach_cycle (family_location, mainframe_id, p_complete_path^, {lfn} osc$null_name, device_class,
                  date_time, authority, {update_catalog} TRUE, {update_cycle_statistics} TRUE,
                  usage_selections, share_selections, permit_entry.application_info, validation_ring,
                  allowed_cycle_damage_symptoms, enable_media_damage_detection, implicit_attach,
                  p_label, catalog_locator.p_catalog_file, p_file_object, p_internal_cycle_path,
                  p_cycle, catalog_locator.flush_catalog_pages,
                  evaluated_file_reference.path_handle_info.path_handle, cycle_damage_symptoms,
                  p_file_server_buffers, status);
          IFEND;

          IF status.normal THEN
            IF family_location = pfc$local_mainframe THEN
              evaluated_file_reference.path_handle_info.path_handle_present := TRUE;
            IFEND;
            evaluated_file_reference.cycle_reference := cycle_reference;
            evaluated_file_reference.path_resolution := fsc$cycle_path;
            action_taken := pfc$cycle_newly_attached;
            #UNCHECKED_CONVERSION (usage_allowed, allowed_access);
            #UNCHECKED_CONVERSION (sharing_required, required_sharing);
            #UNCHECKED_CONVERSION (share_selections, selected_sharing);
            IF save_file_label AND (p_file_label <> NIL) THEN
              store_file_label (p_complete_path^, p_file_label, catalog_locator.p_catalog_file, p_cycle,
                    p_stored_file_label, status);
              label_used := status.normal;
            IFEND;
          ELSEIF status.condition = pfe$cycle_busy THEN
            action_taken := pfc$cycle_busy_elsewhere;
          ELSEIF (device_class = rmc$mass_storage_device) AND osp$file_access_condition (status) THEN
            #UNCHECKED_CONVERSION (usage_selections, intended_access);
            #UNCHECKED_CONVERSION (share_selections, intended_sharing);
            check_delete_data_allowed (evaluated_file_reference,
                  exception_selection_info, intended_access, intended_sharing,
                  p_cycle^.cycle_entry.device_information.eoi, p_label, status, delete_data_allowed);
            IF delete_data_allowed AND
                  (fmd_reconciliation_required OR (p_cycle^.cycle_entry.attach_status.attach_count = 0)) THEN
              recreate_cycle_data (family_location, mainframe_id, p_complete_path^, authority,
                    usage_selections, share_selections, permit_entry.application_info, validation_ring,
                    {password_protected} (p_file_object^.object_entry.password <> osc$null_name),
                    enable_media_damage_detection, ignore_apft_index, p_label, {p_cycle_description} NIL,
                    catalog_locator, p_cycle, p_internal_cycle_path, {p_attached_pf_entry} NIL,
                    evaluated_file_reference, new_global_file_name, new_remote_sfid, bytes_allocated,
                    p_file_server_buffers, status);
              IF status.normal THEN
                action_taken := pfc$cycle_newly_attached;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF (status.normal AND ((cycle_reference.specification = fsc$next_cycle) OR
          (p_file_object^.object_entry.object_type <> pfc$file_object))) OR
          ((NOT status.normal) AND (status.condition = pfe$unknown_cycle)) THEN
      {
      { Create cycle and possibly file.
      {
      action_attempted := pfc$creation_attempted;
      fs_device_class := fsc$mass_storage_device;

      IF create_file THEN
        status.normal := TRUE;
      ELSEIF cycle_reference.specification = fsc$next_cycle THEN
        variant_path.complete_path := TRUE;
        variant_path.p_complete_path := p_complete_path;
        pfp$set_status_abnormal (variant_path, pfe$unknown_cycle, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, '$NEXT', status);
      IFEND;

      IF status.normal AND NOT (fs_device_class IN allowed_device_classes) THEN
        variant_path.complete_path := TRUE;
        variant_path.p_complete_path := p_complete_path;
        pfp$set_status_abnormal (variant_path, fse$device_class_conflict, status);
      IFEND;

      IF status.normal THEN
        IF p_file_object^.object_entry.object_type = pfc$free_object THEN
          local_status.normal := TRUE;
          clp$validate_new_file_name (p_complete_path^ [file_index], p_complete_path^ [file_index],
                valid_file_name);
          IF valid_file_name THEN
            IF cycle_reference.specification = fsc$cycle_number THEN
              cycle_number := cycle_reference.cycle_number;
            ELSE
              cycle_number := 1;
            IFEND;
          ELSE
            file_index := file_index - 1;
            p_path_element := fsp$path_element (^evaluated_file_reference, file_index);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_permanent_file_name,
                  p_path_element^, status);
          IFEND;
        ELSE
          pfp$validate_password (p_complete_path^, authority, local_password, p_file_object, status);
          pfp$determine_new_cycle_number (p_complete_path^, p_cycle_list, cycle_selector, cycle_number,
                local_status);
        IFEND;

        IF status.normal THEN
          pfp$validate_file_permission (p_complete_path^, authority, permit_entry,
                $pft$permit_selections [pfc$cycle], - $pft$share_selections [], status);
        IFEND;

        IF status.normal AND local_status.normal THEN
          IF cycle_reference.specification <> fsc$cycle_number THEN
            IF family_location = pfc$local_mainframe THEN
              evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
              evaluated_file_reference.cycle_reference.cycle_number := cycle_number;
              fmp$get_path_table_cycle_info (inhibit_path_table_lock, evaluated_file_reference,
                    path_table_cycle_info, status);
            ELSEIF p_path_table_cycle_info = NIL THEN
              path_table_cycle_info.path_registered := FALSE;
            ELSEIF cycle_number = p_path_table_cycle_info^.cycle_number THEN
              path_table_cycle_info := p_path_table_cycle_info^;
            ELSE
              check_path_table_cycle_number (cycle_number, cycle_selector,
                    p_path_table_cycle_info^.cycle_number, fetch_new_cycle_info);
              IF fetch_new_cycle_info THEN
                osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$recheck_client_mainframe,
                      'attach_or_create', status);
              ELSE
                path_table_cycle_info.path_registered := FALSE;
              IFEND;
            IFEND;
          ELSEIF p_path_table_cycle_info = NIL THEN
            path_table_cycle_info.path_registered := FALSE;
          ELSE
            path_table_cycle_info := p_path_table_cycle_info^;
          IFEND;
        IFEND;

        IF status.normal AND local_status.normal THEN
          IF path_table_cycle_info.path_registered THEN
            setfa_access_modes := path_table_cycle_info.setfa_access_modes;
          ELSE
            setfa_access_modes.selector := fsc$permitted_access_modes;
          IFEND;
        IFEND;

        IF status.normal THEN
          pick_modes_for_create (p_complete_path^, p_attachment_options, setfa_access_modes,
                authority.ownership, permit_entry, usage_allowed, usage_selections, sharing_required,
                share_selections, status);
        IFEND;

        IF status.normal THEN
          pfp$validate_ring_access (p_complete_path^, p_file_label, - $pft$usage_selections [],
                validation_ring, status);
        IFEND;

        IF status.normal AND NOT local_status.normal THEN
          status := local_status;
        IFEND;

        IF status.normal THEN
          IF p_file_object^.object_entry.object_type = pfc$free_object THEN
            pfp$create_file_object (p_complete_path^ [file_index], authority, parent_charge_id,
                  local_password, pfc$no_log, p_file_object^.object_entry);
            pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
                  catalog_locator.p_catalog_file, p_cycle_list);
            p_internal_cycle_path^.path [file_index] := p_file_object^.object_entry.internal_object_name;
            evaluated_file_reference.path_resolution := fsc$new_file_path;
          ELSE
            evaluated_file_reference.path_resolution := fsc$new_cycle_path;
          IFEND;
        IFEND;

        IF status.normal THEN
          physical_object := p_file_object^;
          create_cycle (family_location, mainframe_id, p_complete_path^, cycle_number, {lfn} osc$null_name,
                date_time, authority, usage_selections, share_selections, permit_entry.application_info,
                validation_ring, enable_media_damage_detection, implicit_attach, fs_retention,
                retrieve_option, site_archive_option, site_backup_option, site_release_option, p_file_label,
                device_class, {p_mass_storage_request_info} NIL, {p_removable_media_req_info} NIL,
                {p_volume_list} NIL, catalog_locator.p_catalog_file, p_file_object, p_internal_cycle_path,
                physical_object, p_cycle_list, p_cycle, sfid,
                evaluated_file_reference.path_handle_info.path_handle, bytes_allocated, p_file_server_buffers,
                status);
          path_description_created := status.normal;
          IF NOT status.normal THEN
            pfp$delete_file_object (p_complete_path, catalog_locator.p_catalog_file, p_file_object,
                  catalog_locator.object_list_descriptor, local_status);
          IFEND;
        IFEND;

        #UNCHECKED_CONVERSION (usage_selections, selected_access);
        IF status.normal THEN
          IF family_location = pfc$local_mainframe THEN
            evaluated_file_reference.path_handle_info.path_handle_present := TRUE;
          IFEND;
          evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
          evaluated_file_reference.cycle_reference.cycle_number := cycle_number;
          action_taken := pfc$cycle_created;
          #UNCHECKED_CONVERSION (usage_allowed, allowed_access);
          #UNCHECKED_CONVERSION (sharing_required, required_sharing);
          #UNCHECKED_CONVERSION (share_selections, selected_sharing);
          IF p_file_label <> NIL THEN
            p_stored_file_label := NIL;
            store_file_label (p_complete_path^, p_file_label, catalog_locator.p_catalog_file, p_cycle,
                  p_stored_file_label, status);
            label_used := status.normal;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF NOT status.normal AND path_description_created THEN
      dmp$destroy_file (sfid, sfc$no_limit, local_status);

      fmp$delete_path_description (evaluated_file_reference, {implicit_detach} FALSE,
            {return_permanent_file} FALSE, {detachment_options} NIL, local_status);

      pfp$locate_attached_file (p_cycle^.cycle_entry.internal_cycle_name, apft_index,
            p_attached_pf_entry, cycle_attached);
      IF cycle_attached THEN
        IF p_attached_pf_entry <> NIL THEN
          IF p_attached_pf_entry^.p_external_path <> NIL THEN
            FREE p_attached_pf_entry^.p_external_path IN pfv$p_p_job_heap^^;
          IFEND;
          FREE p_attached_pf_entry IN pfv$p_p_job_heap^^;
          pfp$release_locked_apfid (apft_index, local_status);
          pfp$process_unexpected_status (local_status);
        IFEND;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;
    IF catalog_attached THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
    pfv$locked_apfid := 0;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_attach_or_create;

?? TITLE := '  [XDCL, #GATE] pfp$r2_attach_or_create_file', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to check whether the cycle is already
{   attached within the job, and to optionally call pfp$r2_df_attach_or_cref or
{   pfp$r2_attach_or_create.
{
{ NOTE:
{   The path table must be locked throughout.

  PROCEDURE [XDCL, #GATE] pfp$r2_attach_or_create_file
    (    validation_ring: ost$valid_ring;
         system_privilege: boolean;
         exception_selection_info: pft$exception_selection_info;
         p_attachment_options: {input} ^fst$attachment_options;
         p_file_label: {input} fmt$p_file_label;
         fs_retention: fst$retention;
         retrieve_option: pft$retrieve_option;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR allowed_access: fst$file_access_options;
     VAR selected_access: fst$file_access_options;
     VAR required_sharing: fst$file_access_options;
     VAR selected_sharing: fst$file_access_options;
     VAR action_taken: pft$attach_or_create_action;
     VAR label_used: boolean;
     VAR device_class: rmt$device_class;
     VAR global_file_name: ost$binary_unique_name;
     VAR status: ost$status);

    CONST
      include_open_position = TRUE;

    VAR
      access_selected: fst$file_access_options,
      action_attempted: pft$action_attempted,
      audit_information: sft$audit_information,
      audited_object: sft$audited_fs_object_id,
      authority: pft$authority,
      bytes_allocated: amt$file_byte_address,
      create_file: boolean,
      cycle_attached: boolean,
      cycle_attachment_info: fmt$cycle_attachment_info,
      cycle_formerly_opened_info: fmt$cycle_formerly_opened_info,
      cycle_selector: pft$cycle_selector,
      first_path_element_name: fst$path_element_name,
      fs_path_size: fst$path_size,
      ignore_new_remote_sfid: gft$system_file_identifier,
      ignore_old_global_file_name: ost$binary_unique_name,
      ignore_status: ost$status,
      local_file: boolean,
      local_status: ost$status,
      mainframe_id: pmt$binary_mainframe_id,
      p_complete_path: ^pft$complete_path,
      p_file_server_buffers: ^pft$file_server_buffers,
      p_fs_path: ^fst$path,
      p_local_status: ^ost$status,
      p_path: ^pft$path,
      p_path_table_cycle_info: ^fmt$path_table_cycle_info,
      p_security_status: ^ost$status,
      password: pft$password,
      password_specified: boolean,
      password_status: ost$status,
      path_table_cycle_info: fmt$path_table_cycle_info,
      served_family: boolean,
      served_family_locator: pft$served_family_locator,
      sharing_required: fst$file_access_options,
      tape_file_attached: boolean,
      usage_selections: pft$usage_selections;

    first_path_element_name := fsp$path_element (^evaluated_file_reference, 1)^;
    find_family_location (first_path_element_name, served_family, served_family_locator);
    local_file := first_path_element_name = fsc$local;
    fmp$lock_path_table (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (evaluated_file_reference.cycle_reference.specification = fsc$cycle_number) OR local_file THEN
      fmp$get_path_table_cycle_info (inhibit_path_table_lock, evaluated_file_reference, path_table_cycle_info,
            status);

      IF status.normal AND path_table_cycle_info.path_registered THEN
        p_path_table_cycle_info := ^path_table_cycle_info;
        cycle_attached := path_table_cycle_info.cycle_attachment_info.cycle_attached;

        IF cycle_attached THEN
          pfi$get_password (p_attachment_options, password_specified, password);

          IF password_specified AND (path_table_cycle_info.cycle_attachment_info.password_protected OR
                (password <> osc$null_name)) THEN
            IF served_family THEN
              PUSH p_path: [1 .. evaluated_file_reference.number_of_path_elements];
              pfp$convert_fs_to_pft$path (evaluated_file_reference, p_path^);
              IF NOT system_privilege THEN
                pfp$r2_df_client_validate_pw (served_family_locator, p_path^, password, status);
              IFEND;
            ELSE
              PUSH p_complete_path: [1 .. evaluated_file_reference.number_of_path_elements + 1];
              pfp$convert_fs_to_complete_path (evaluated_file_reference, p_complete_path, status);
              IF status.normal AND NOT system_privilege THEN
                pfp$r2_validate_password (p_complete_path^, password, status);
              IFEND;
            IFEND;
          IFEND;

          IF status.normal THEN
            cycle_attachment_info := path_table_cycle_info.cycle_attachment_info;

            IF path_table_cycle_info.cycle_device_info.device_assigned THEN
              device_class := path_table_cycle_info.cycle_device_info.device_class;
              cycle_formerly_opened_info :=
                    path_table_cycle_info.cycle_device_info.cycle_formerly_opened_info;
            ELSE
              device_class := rmc$mass_storage_device;
              cycle_formerly_opened_info.cycle_previously_opened := FALSE;
            IFEND;

            pfi$get_create_file_option (p_attachment_options, evaluated_file_reference.cycle_reference,
                  create_file);
            pfp$pick_modes_for_open (evaluated_file_reference, p_attachment_options,
                  cycle_attachment_info.allowed_access, cycle_attachment_info.required_sharing,
                  path_table_cycle_info.setfa_access_modes, device_class, cycle_formerly_opened_info,
                  {called_by_attach} FALSE, create_file, validation_ring, selected_access, selected_sharing,
                  status);
          IFEND;

          IF status.normal THEN
            allowed_access := cycle_attachment_info.allowed_access;
            required_sharing := cycle_attachment_info.required_sharing;
            action_taken := pfc$cycle_already_attached;
            label_used := FALSE;
          ELSEIF status.condition = pfe$cycle_busy THEN
            action_taken := pfc$cycle_already_attached;
          IFEND;
        IFEND;
      ELSE
        p_path_table_cycle_info := NIL;
        cycle_attached := FALSE;
      IFEND;
    ELSE
      p_path_table_cycle_info := NIL;
      status.normal := TRUE;
      cycle_attached := FALSE;
    IFEND;

    IF status.normal AND (NOT local_file) AND (NOT cycle_attached) THEN
      IF served_family THEN
        pfp$r2_df_client_attach_or_cref (served_family_locator, validation_ring, system_privilege,
              exception_selection_info, p_attachment_options, p_file_label, p_path_table_cycle_info,
              fs_retention, retrieve_option, site_archive_option, site_backup_option, site_release_option,
              evaluated_file_reference, action_attempted, action_taken, authority, allowed_access,
              selected_access, required_sharing, selected_sharing, device_class, global_file_name,
              label_used, bytes_allocated, status);
        IF status.normal THEN
          IF pfc$master_catalog_owner IN authority.ownership THEN
            sfp$accumulate_file_space (sfc$perm_file_space_limit, bytes_allocated);
          IFEND;
        ELSEIF status.condition = pfe$tape_attached_on_client THEN
          PUSH p_local_status;
          iop$tape_file_attached (global_file_name, tape_file_attached, p_local_status^);
          IF p_local_status^.normal THEN
            IF tape_file_attached THEN
              PUSH p_fs_path;
              clp$convert_file_ref_to_string (evaluated_file_reference, NOT include_open_position,
                    p_fs_path^, fs_path_size, ignore_status);
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_busy,
                    p_fs_path^ (1, fs_path_size), status);
              osp$append_status_integer (osc$status_parameter_delimiter,
                    evaluated_file_reference.cycle_reference.cycle_number, radix, NOT include_radix, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, pfc$multiple_job_usage_conflict,
                    status);
            ELSE
              cycle_selector.cycle_option := pfc$specific_cycle;
              cycle_selector.cycle_number := evaluated_file_reference.cycle_reference.cycle_number;
              PUSH p_path: [1 .. evaluated_file_reference.number_of_path_elements];
              pfp$convert_fs_to_pft$path (evaluated_file_reference, p_path^);
              pfp$convert_pf_path_to_fs_path (p_path^, p_fs_path^, fs_path_size);
              pfp$r2_df_client_clear_cy_att (served_family_locator, p_path^, cycle_selector, password,
                    p_local_status^);
              IF NOT p_local_status^.normal THEN
                status := p_local_status^;
              IFEND;
            IFEND;
          ELSE
            status := p_local_status^;
          IFEND;
        IFEND;
      ELSE
        pmp$get_pseudo_mainframe_id (mainframe_id);
        p_file_server_buffers := NIL;
        pfp$r2_attach_or_create (pfc$local_mainframe, mainframe_id, validation_ring, system_privilege,
              exception_selection_info, p_attachment_options, p_file_label, p_path_table_cycle_info,
              fs_retention, retrieve_option, site_archive_option, site_backup_option, site_release_option,
              evaluated_file_reference, action_attempted, action_taken, authority, allowed_access,
              selected_access, required_sharing, selected_sharing, device_class, global_file_name,
              ignore_old_global_file_name, ignore_new_remote_sfid, label_used, bytes_allocated,
              p_file_server_buffers, status);
      IFEND;
      IF avp$security_option_active (avc$vso_security_audit) THEN
        IF action_attempted = pfc$dm_attachment_attempted THEN
          audit_information.audited_operation := sfc$ao_fs_attach_file;
          audited_object.variant_path.complete_path := FALSE;
          PUSH audited_object.variant_path.p_path: [1 .. evaluated_file_reference.number_of_path_elements];
          pfp$convert_fs_to_pft$path (evaluated_file_reference, audited_object.variant_path.p_path^);
          audited_object.object_type := sfc$afsot_cycle;
          PUSH p_security_status;
          pfi$convert_cycle_reference (evaluated_file_reference.cycle_reference, cycle_selector,
                p_security_status^);
          IF p_security_status^.normal THEN
            audited_object.cycle_selector_p := ^cycle_selector;
          ELSE
            audited_object.cycle_selector_p := NIL;
          IFEND;
          audited_object.device_class := device_class;
          audit_information.attach_file.object_id_p := ^audited_object;
          IF status.normal THEN
            audit_information.attach_file.ownership := authority.ownership;
            #UNCHECKED_CONVERSION (selected_access, usage_selections);
            audit_information.attach_file.access_mode_p := ^usage_selections;
          ELSE
            pfp$get_ownership (audited_object.variant_path, system_privilege,
                  audit_information.attach_file.ownership, p_security_status^);
            audit_information.attach_file.access_mode_p := NIL;
          IFEND;
          sfp$emit_audit_statistic (audit_information, status);
        ELSEIF action_attempted = pfc$creation_attempted THEN
          audit_information.audited_operation := sfc$ao_fs_create_object;
          audited_object.variant_path.complete_path := FALSE;
          PUSH audited_object.variant_path.p_path: [1 .. evaluated_file_reference.number_of_path_elements];
          pfp$convert_fs_to_pft$path (evaluated_file_reference, audited_object.variant_path.p_path^);
          audited_object.object_type := sfc$afsot_cycle;
          PUSH p_security_status;
          pfi$convert_cycle_reference (evaluated_file_reference.cycle_reference, cycle_selector,
                p_security_status^);
          IF p_security_status^.normal THEN
            audited_object.cycle_selector_p := ^cycle_selector;
          ELSE
            audited_object.cycle_selector_p := NIL;
          IFEND;
          audited_object.device_class := device_class;
          audit_information.create_fs_object.object_id_p := ^audited_object;
          IF status.normal THEN
            audit_information.create_fs_object.ownership := authority.ownership;
          ELSE
            pfp$get_ownership (audited_object.variant_path, system_privilege,
                  audit_information.create_fs_object.ownership, p_security_status^);
          IFEND;
          sfp$emit_audit_statistic (audit_information, status);
          audit_information.audited_operation := sfc$ao_fs_attach_file;
          IF status.normal THEN
            #UNCHECKED_CONVERSION (selected_access, usage_selections);
            audit_information.attach_file.access_mode_p := ^usage_selections;
          ELSE
            audit_information.attach_file.access_mode_p := NIL;
          IFEND;
          sfp$emit_audit_statistic (audit_information, status);
        ELSE {pfc$no_action_attempted or pfc$fm_attachment_attempted}
          ;
        IFEND;
      IFEND;
    IFEND;

    IF NOT status.normal THEN
      fmp$unlock_path_table;
    IFEND;

  PROCEND pfp$r2_attach_or_create_file;

?? TITLE := '  [XDCL, #GATE] pfp$r2_change', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_change
    (    family_location: pft$family_location;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         system_privilege: boolean;
         change_list: pft$change_list;
     VAR cycle_number: pft$cycle_number;
     VAR device_class: rmt$device_class;
     VAR change_index: ost$non_negative_integers;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);

      IF path_table_lock_set THEN
        fmp$unlock_path_table;
        path_table_lock_set := FALSE;
        #SPOIL(path_table_lock_set);
      IFEND;

      EXIT pfp$r2_change;
    PROCEND initiate_non_local_exit;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      catalog_permit_entry: pft$permit_entry,
      charge_id: pft$charge_id,
      date_time: ost$date_time,
      file_permit_entry: pft$permit_entry,
      local_status: ost$status,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      p_parent_path: ^pft$complete_path,
      path_index: pft$file_path_index,
      path_table_lock_set: boolean,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;
    path_table_lock_set := FALSE;
    #SPOIL(path_table_lock_set);
    process_non_local_exit := FALSE;
    #SPOIL(process_non_local_exit);
    status.normal := TRUE;

    pmp$get_compact_date_time (date_time, local_status);
    pfp$process_unexpected_status (local_status);

    pfp$get_authority (path, system_privilege, authority, status);
    IF status.normal THEN
      IF family_location = pfc$local_mainframe THEN
        fmp$lock_path_table (status);
        IF NOT status.normal THEN
          syp$pop_inhibit_job_recovery;
          RETURN;
        IFEND;
        path_table_lock_set := TRUE;
      IFEND;

      PUSH p_parent_path: [1 .. UPPERBOUND (path) - 1];
      FOR path_index := 1 TO UPPERBOUND (path) - 1 DO
        p_parent_path^ [path_index] := path [path_index];
      FOREND;
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$get_catalog (p_parent_path^, pfc$write_access, authority, p_internal_path^, charge_id,
            catalog_permit_entry, catalog_locator, status);
    IFEND;
    catalog_active := status.normal;

    osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

    IF status.normal THEN
      file_permit_entry := catalog_permit_entry;
      pfp$access_last_object (path, authority, $pft$object_selections [pfc$file_object], catalog_locator,
            file_permit_entry, p_file_object, p_internal_path^ [UPPERBOUND (path)], status);
    IFEND;

    IF status.normal THEN
      pfp$validate_password (path, authority, password, p_file_object, status);
    IFEND;

    IF status.normal THEN
      pfp$validate_file_permission (path, authority, file_permit_entry, $pft$permit_selections [pfc$control],
            - $pft$share_selections [], status);
    IFEND;

    IF status.normal THEN
      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
    IFEND;

    IF status.normal THEN
      cycle_number := p_cycle^.cycle_entry.cycle_number;
      IF p_cycle^.cycle_entry.device_information.device_class_defined THEN
        pfp$convert_device_class_to_rm (p_cycle^.cycle_entry.device_information.device_class, device_class);
      ELSE
        device_class := rmc$mass_storage_device;
      IFEND;
      process_change_list (family_location, path, device_class, change_list, date_time,
            catalog_locator.p_catalog_file, authority, catalog_permit_entry, p_cycle, p_file_object,
            catalog_locator.object_list_descriptor, change_index, status);
    ELSE
      change_index := 0;
    IFEND;

    osp$disestablish_cond_handler;
    IF catalog_active THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    IF path_table_lock_set THEN
      fmp$unlock_path_table;
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_change;

?? TITLE := '  [XDCL, #GATE] pfp$r2_change_catalog_name', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to change the name of a catalog.
{
{ NOTE:
{   This routine should be used with care!  It is not normally advisable to
{   change the name of a catalog because:
{   1) The old external catalog name is currently used in job recovery to
{      re-attach the permanent file.
{   2) The current scheme of partial backups would not backup the unchanged
{      files in this catalog.  If we needed to restore from both the partials
{      and the full, the restore from the full would not find the cycles
{      because they were backed up under the old catalog name.

  PROCEDURE [XDCL, #GATE] pfp$r2_change_catalog_name
    (    path: pft$complete_path;
         new_catalog_name: pft$name;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_change_catalog_name;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_alarm_set: boolean,
      catalog_locator: pft$catalog_locator,
      changed_catalog_locator: pft$catalog_locator,
      charge_id: pft$charge_id,
      global_file_name: ost$binary_unique_name,
      ignore_destroy_on_last_detach: boolean,
      index: pft$catalog_path_index,
      last_index: pft$catalog_path_index,
      local_status: ost$status,
      p_catalog_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      p_parent_path: ^pft$complete_path,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;
    process_non_local_exit := FALSE;
    #SPOIL(process_non_local_exit);
    status.normal := TRUE;

    pfp$get_authority (path, NOT system_privilege, authority, status);
    IF status.normal THEN
      IF UPPERBOUND (path) <= pfc$master_catalog_path_index THEN
        pfp$validate_family_ownership (path [pfc$family_path_index], authority, status);
      ELSE
        pfp$validate_ownership (authority, path, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      last_index := UPPERBOUND (path);
      PUSH p_parent_path: [1 .. last_index - 1];
      FOR index := 1 TO last_index - 1 DO
        p_parent_path^ [index] := path [index];
      FOREND;
      PUSH p_internal_path: [1 .. last_index];
      pfp$get_catalog (p_parent_path^, pfc$write_access, authority, p_internal_path^, charge_id, permit_entry,
            catalog_locator, status);
    IFEND;
    catalog_active := status.normal;
    osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

    IF status.normal THEN
      pfp$access_last_object (path, authority, $pft$object_selections [pfc$catalog_object], catalog_locator,
            permit_entry, p_catalog_object, p_internal_path^ [last_index], status);
    IFEND;

    IF status.normal THEN
      validate_object_name_change (path, new_catalog_name, catalog_locator.object_list_descriptor,
            catalog_locator.p_catalog_file, authority, permit_entry, status);
    IFEND;

    IF status.normal THEN
      p_catalog_object^.object_entry.external_object_name := new_catalog_name;
      pfp$compute_checksum (#LOC (p_catalog_object^.object_entry), #SIZE (pft$object_entry),
            p_catalog_object^.checksum);
    IFEND;

    IF status.normal THEN
      IF p_catalog_object^.object_entry.catalog_object_locator.catalog_type = pfc$external_catalog THEN
        global_file_name := p_catalog_object^.object_entry.catalog_object_locator.global_file_name;
      ELSE
        global_file_name := catalog_locator.global_file_name;
      IFEND;
      pfp$check_catalog_alarm (global_file_name, catalog_alarm_set, ignore_destroy_on_last_detach);
      IF NOT catalog_alarm_set THEN
        {
        { Access the changed catalog so that an alarm may be set on it.
        {
        pfp$access_next_catalog (pfc$read_access, catalog_locator, p_catalog_object,
              (path [pfc$family_path_index] <> osv$system_family_name), changed_catalog_locator, status);
        IF status.normal THEN
          IF changed_catalog_locator.object_list_descriptor.catalog_type = pfc$internal_catalog THEN
            {
            { Set alarm on the parent.
            {
            catalog_locator.queuing_info.set_catalog_alarm := TRUE;
          ELSE { external catalog
            changed_catalog_locator.queuing_info.set_catalog_alarm := TRUE;
            pfp$return_catalog (changed_catalog_locator, status);
            pfp$process_unexpected_status (status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;
    IF catalog_active THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_change_catalog_name;

?? TITLE := '  [XDCL, #GATE] pfp$r2_change_cycle_damage', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_change_cycle_damage
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         new_damage_symptoms: fst$cycle_damage_symptoms;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_change_cycle_damage;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      catalog_permit_entry: pft$permit_entry,
      charge_id: pft$charge_id,
      device_class: rmt$device_class,
      dm_file_info: dmt$file_information,
      file_damaged: boolean,
      file_index: pft$file_path_index,
      fmd_modified: boolean,
      file_permit_entry: pft$permit_entry,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_fs_path: ^fst$path,
      p_internal_path: ^pft$internal_path,
      p_parent_path: ^pft$complete_path,
      path_index: pft$catalog_path_index,
      process_non_local_exit: boolean,
      sfid: gft$system_file_identifier;

    syp$push_inhibit_job_recovery;
    process_non_local_exit := FALSE;
    #SPOIL(process_non_local_exit);
    status.normal := TRUE;

    pfp$get_authority (path, NOT system_privilege, authority, status);
    IF status.normal THEN
      file_index := UPPERBOUND (path);
      PUSH p_parent_path: [1 .. file_index - 1];
      FOR path_index := 1 TO file_index - 1 DO
        p_parent_path^ [path_index] := path [path_index];
      FOREND;
      PUSH p_internal_path: [1 .. file_index];
      pfp$get_catalog (p_parent_path^, pfc$write_access, authority, p_internal_path^, charge_id,
            catalog_permit_entry, catalog_locator, status);
    IFEND;
    catalog_active := status.normal;
    osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

    IF status.normal THEN
      file_permit_entry := catalog_permit_entry;
      pfp$access_last_object (path, authority, $pft$object_selections [pfc$file_object], catalog_locator,
            file_permit_entry, p_file_object, p_internal_path^ [file_index], status);
    IFEND;

    IF status.normal THEN
      pfp$validate_password (path, authority, password, p_file_object, status);
    IFEND;

    IF status.normal THEN
      pfp$validate_file_permission (path, authority, file_permit_entry, $pft$permit_selections [pfc$control],
            - $pft$share_selections [], status);
    IFEND;

    IF status.normal THEN
      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
    IFEND;

    IF status.normal THEN
      IF fsc$media_image_inconsistent IN new_damage_symptoms THEN
        IF p_cycle^.cycle_entry.attach_status.attach_count = 0 THEN
          IF p_cycle^.cycle_entry.device_information.device_class_defined THEN
            pfp$convert_device_class_to_rm (p_cycle^.cycle_entry.device_information.device_class,
                  device_class);
          ELSE
            device_class := rmc$mass_storage_device;
          IFEND;
          IF (device_class = rmc$mass_storage_device) AND
                (p_cycle^.cycle_entry.data_residence <> pfc$offline_data) THEN
            dm_attach_file (path, catalog_locator.p_catalog_file, $pft$usage_selections [pfc$read],
                  - $pft$share_selections [], p_cycle, sfid, file_damaged, status);
            IF status.normal THEN
              dmp$change_file_damaged (sfid, {file_damaged} TRUE, p_cycle^.cycle_entry.internal_cycle_name,
                    status);
              IF status.normal THEN
                pfp$detach_permanent_file (^path, sfid, $pft$usage_selections [pfc$read],
                      {catalog_update_allowed} TRUE, p_cycle, catalog_locator.p_catalog_file, fmd_modified,
                      dm_file_info, status);
              IFEND;
            ELSEIF status.condition = pfe$undefined_data THEN
              status.normal := TRUE;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      p_cycle^.cycle_entry.cycle_damage_symptoms := new_damage_symptoms -
            $fst$cycle_damage_symptoms[fsc$media_image_inconsistent];
      pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
    IFEND;

    osp$disestablish_cond_handler;
    IF catalog_active THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_change_cycle_damage;

?? TITLE := '  [XDCL, #GATE] pfp$r2_change_cycle_date_time', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_change_cycle_date_time
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         new_access_date_time: pft$date_time;
         new_creation_date_time: pft$date_time;
         new_modification_date_time: pft$date_time;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_change_cycle_date_time;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      catalog_permit_entry: pft$permit_entry,
      charge_id: pft$charge_id,
      file_index: pft$file_path_index,
      file_permit_entry: pft$permit_entry,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_fs_path: ^fst$path,
      p_internal_path: ^pft$internal_path,
      p_parent_path: ^pft$complete_path,
      path_index: pft$catalog_path_index,
      process_non_local_exit: boolean,
      saved_access_date_time: ost$date_time,
      selections_string: pft$selections_string,
      update_checksum: boolean;

    syp$push_inhibit_job_recovery;
    process_non_local_exit := FALSE;
    #SPOIL(process_non_local_exit);
    status.normal := TRUE;

    pfp$get_authority (path, NOT system_privilege, authority, status);
    IF status.normal THEN
      file_index := UPPERBOUND (path);
      PUSH p_parent_path: [1 .. file_index - 1];
      FOR path_index := 1 TO file_index - 1 DO
        p_parent_path^ [path_index] := path [path_index];
      FOREND;
      PUSH p_internal_path: [1 .. file_index];
      pfp$get_catalog (p_parent_path^, pfc$write_access, authority, p_internal_path^, charge_id,
            catalog_permit_entry, catalog_locator, status);
    IFEND;
    catalog_active := status.normal;
    osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

    IF status.normal THEN
      file_permit_entry := catalog_permit_entry;
      pfp$access_last_object (path, authority, $pft$object_selections [pfc$file_object], catalog_locator,
            file_permit_entry, p_file_object, p_internal_path^ [file_index], status);
    IFEND;

    IF status.normal AND ((new_modification_date_time.date_time_option = pfc$current_date_time) OR
          (new_modification_date_time.date_time_option = pfc$specified_date_time)) AND
          NOT (pfc$family_owner IN authority.ownership) AND NOT (pfc$system_owner IN authority.ownership) THEN
      IF (file_permit_entry.entry_type = pfc$free_permit_entry) OR
            (file_permit_entry.usage_permissions = $pft$permit_selections []) THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_permanent_file,
              p_fs_path^ (1, fs_path_size), status);
      ELSEIF file_permit_entry.usage_permissions - $pft$permit_selections [pfc$read, pfc$execute] =
            $pft$permit_selections [] THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$usage_not_permitted,
              p_fs_path^ (1, fs_path_size), status);
        pfp$build_permit_selections_str (file_permit_entry.usage_permissions, selections_string);
        osp$append_status_parameter (osc$status_parameter_delimiter, selections_string.
              value (1, selections_string.size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              '[CONTROL, or CYCLE, or SHORTEN, or MODIFY, or APPEND]', status);
      IFEND;
    IFEND;

    IF status.normal THEN
      pfp$validate_password (path, authority, password, p_file_object, status);
    IFEND;

    IF status.normal THEN
      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
    IFEND;

    update_checksum := FALSE;
    IF status.normal THEN
      CASE new_access_date_time.date_time_option OF
      = pfc$no_date_time =
        ;

      = pfc$current_date_time =
        saved_access_date_time := p_cycle^.cycle_entry.cycle_statistics.access_date_time;
        p_cycle^.cycle_entry.cycle_statistics.access_date_time := new_access_date_time.current_date_time;
        update_checksum := TRUE;

      = pfc$specified_date_time =
        saved_access_date_time := p_cycle^.cycle_entry.cycle_statistics.access_date_time;
        p_cycle^.cycle_entry.cycle_statistics.access_date_time := new_access_date_time.specified_date_time;
        update_checksum := TRUE;

      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'Invalid date_time_option:', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (new_access_date_time.date_time_option), radix, NOT include_radix, status);
      CASEND;
    IFEND;

    IF status.normal THEN
      CASE new_creation_date_time.date_time_option OF
      = pfc$no_date_time =
        ;

      = pfc$current_date_time =
        p_cycle^.cycle_entry.cycle_statistics.creation_date_time := new_creation_date_time.current_date_time;
        update_checksum := TRUE;

      = pfc$specified_date_time =
        p_cycle^.cycle_entry.cycle_statistics.creation_date_time :=
              new_creation_date_time.specified_date_time;
        update_checksum := TRUE;

      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'Invalid date_time_option:', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (new_creation_date_time.date_time_option), radix, NOT include_radix, status);
      CASEND;
    IFEND;

    IF status.normal THEN
      CASE new_modification_date_time.date_time_option OF
      = pfc$no_date_time =
        ;

      = pfc$current_date_time =
        p_cycle^.cycle_entry.cycle_statistics.modification_date_time :=
              new_modification_date_time.current_date_time;
        p_cycle^.cycle_entry.data_modification_date_time := new_modification_date_time.current_date_time;
        update_checksum := TRUE;

      = pfc$specified_date_time =
        p_cycle^.cycle_entry.cycle_statistics.modification_date_time :=
              new_modification_date_time.specified_date_time;
        p_cycle^.cycle_entry.data_modification_date_time := new_modification_date_time.specified_date_time;
        update_checksum := TRUE;

      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'Invalid date_time_option:', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER (new_modification_date_time.date_time_option), radix, NOT include_radix, status);
      CASEND;
    IFEND;

    IF update_checksum THEN
      IF status.normal THEN
        pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
      ELSE
        p_cycle^.cycle_entry.cycle_statistics.access_date_time := saved_access_date_time;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;
    IF catalog_active THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_change_cycle_date_time;

?? TITLE := '  [XDCL, #GATE] pfp$r2_change_file', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_change_file
    (    family_location: pft$family_location;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         system_privilege: boolean;
         file_changes: ^fst$file_changes;
     VAR cycle_number: pft$cycle_number;
     VAR device_class: rmt$device_class;
     VAR change_index: ost$non_negative_integers;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);

      IF path_table_lock_set THEN
        fmp$unlock_path_table;
        path_table_lock_set := FALSE;
        #SPOIL(path_table_lock_set);
      IFEND;

      EXIT pfp$r2_change_file;
    PROCEND initiate_non_local_exit;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      catalog_permit_entry: pft$permit_entry,
      charge_id: pft$charge_id,
      date_time: ost$date_time,
      file_permit_entry: pft$permit_entry,
      local_status: ost$status,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      p_parent_path: ^pft$complete_path,
      path_index: pft$file_path_index,
      path_table_lock_set: boolean,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;
    path_table_lock_set := FALSE;
    #SPOIL(path_table_lock_set);
    process_non_local_exit := FALSE;
    #SPOIL(process_non_local_exit);
    status.normal := TRUE;

    pmp$get_compact_date_time (date_time, local_status);
    pfp$process_unexpected_status (local_status);

    pfp$get_authority (path, system_privilege, authority, status);
    IF status.normal THEN
      IF family_location = pfc$local_mainframe THEN
        fmp$lock_path_table (status);
        IF NOT status.normal THEN
          syp$pop_inhibit_job_recovery;
          RETURN;
        IFEND;
        path_table_lock_set := TRUE;
      IFEND;

      PUSH p_parent_path: [1 .. UPPERBOUND (path) - 1];
      FOR path_index := 1 TO UPPERBOUND (path) - 1 DO
        p_parent_path^ [path_index] := path [path_index];
      FOREND;
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$get_catalog (p_parent_path^, pfc$write_access, authority, p_internal_path^, charge_id,
            catalog_permit_entry, catalog_locator, status);
    IFEND;
    catalog_active := status.normal;

    osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

    IF status.normal THEN
      file_permit_entry := catalog_permit_entry;
      pfp$access_last_object (path, authority, $pft$object_selections [pfc$file_object], catalog_locator,
            file_permit_entry, p_file_object, p_internal_path^ [UPPERBOUND (path)], status);
    IFEND;

    IF status.normal THEN
      pfp$validate_password (path, authority, password, p_file_object, status);
    IFEND;

    IF status.normal THEN
      pfp$validate_file_permission (path, authority, file_permit_entry, $pft$permit_selections [pfc$control],
            - $pft$share_selections [], status);
    IFEND;

    IF status.normal THEN
      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
    IFEND;

    IF status.normal THEN
      cycle_number := p_cycle^.cycle_entry.cycle_number;
      IF p_cycle^.cycle_entry.device_information.device_class_defined THEN
        pfp$convert_device_class_to_rm (p_cycle^.cycle_entry.device_information.device_class, device_class);
      ELSE
        device_class := rmc$mass_storage_device;
      IFEND;
      process_file_changes (family_location, path, device_class, file_changes, date_time,
            catalog_locator.p_catalog_file, authority, catalog_permit_entry, p_cycle, p_file_object,
            catalog_locator.object_list_descriptor, change_index, status);
    ELSE
      change_index := 0;
    IFEND;

    osp$disestablish_cond_handler;
    IF catalog_active THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    IF path_table_lock_set THEN
      fmp$unlock_path_table;
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_change_file;

?? TITLE := '  [XDCL, #GATE] pfp$r2_change_res_to_releasable', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_change_res_to_releasable
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_change_res_to_releasable;
    PROCEND initiate_non_local_exit;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      charge_id: pft$charge_id,
      local_status: ost$status,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      p_parent_path: ^pft$complete_path,
      path_index: pft$catalog_path_index,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;

    process_non_local_exit := FALSE;
    #SPOIL(process_non_local_exit);

    pfp$get_authority (path, {system_privilege} FALSE, authority, status);
    IF status.normal THEN
      PUSH p_parent_path: [1 .. UPPERBOUND (path) - 1];
      FOR path_index := 1 TO UPPERBOUND (path) - 1 DO
        p_parent_path^ [path_index] := path [path_index];
      FOREND;
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$get_catalog (p_parent_path^, pfc$write_access, authority, p_internal_path^, charge_id,
            permit_entry, catalog_locator, status);
    IFEND;
    catalog_active := status.normal;
    osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

    IF status.normal THEN
      pfp$access_last_object (path, authority, $pft$object_selections [pfc$file_object], catalog_locator,
            permit_entry, p_file_object, p_internal_path^ [UPPERBOUND (path)], status);
    IFEND;

    IF status.normal THEN
      pfp$validate_file_permission (path, authority, permit_entry, $pft$permit_selections [pfc$control],
            - $pft$share_selections [], status);
    IFEND;

    IF status.normal THEN
      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
    IFEND;

    IF status.normal AND (p_cycle^.cycle_entry.data_residence = pfc$offline_data) THEN
      p_cycle^.cycle_entry.data_residence := pfc$releasable_data;
      pfp$compute_checksum (^p_cycle^.cycle_entry, #SIZE (p_cycle^.cycle_entry), p_cycle^.checksum);
    IFEND;

    osp$disestablish_cond_handler;
    IF catalog_active THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_change_res_to_releasable;

?? TITLE := '  [XDCL, #GATE] pfp$r2_clear_cycle_attachments', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_clear_cycle_attachments
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_clear_cycle_attachments;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      local_status: ost$status,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;

    process_non_local_exit := FALSE;
    #SPOIL(process_non_local_exit);

    pfp$get_authority (path, NOT system_privilege, authority, status);
    IF status.normal THEN
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$file_object],
            parent_charge_id, catalog_locator, p_file_object, p_internal_path^, permit_entry, status);
    IFEND;
    catalog_active := status.normal;
    osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

    IF status.normal THEN
      pfp$validate_password (path, authority, password, p_file_object, status);
    IFEND;

    IF status.normal THEN
      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
    IFEND;

    IF status.normal THEN
      pfp$clear_cycle_attachments (^path, catalog_locator.p_catalog_file, p_cycle);
      pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
    IFEND;

    osp$disestablish_cond_handler;
    IF catalog_active THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_clear_cycle_attachments;

?? TITLE := '  [XDCL, #GATE] pfp$r2_define', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_define
    (    family_location: pft$family_location;
         mainframe_id: pmt$binary_mainframe_id;
         lfn: amt$local_file_name;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         fs_retention: fst$retention;
         log: pft$log;
         retrieve_option: pft$retrieve_option;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
         system_privilege: boolean;
         validation_ring: ost$valid_ring;
         device_class: rmt$device_class;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
         p_removable_media_req_info: {input^} ^fmt$removable_media_req_info;
         p_volume_list: {input^} ^rmt$volume_list;
     VAR cycle_number: pft$cycle_number;
     VAR authority: pft$authority;
     VAR bytes_allocated: amt$file_byte_address;
     VAR p_file_server_buffers: {server only: i^/o^} pft$p_file_server_buffers;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
    VAR
      p_cycle_description: ^fmt$cycle_description,
      p_evaluated_file_reference: ^fst$evaluated_file_reference,
      process_pt_results: bat$process_pt_results;

      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);

      IF path_table_lock_set THEN
        fmp$unlock_path_table;
        path_table_lock_set := FALSE;
        #SPOIL(path_table_lock_set);
      IFEND;
      {
      { Attempt to clean up BAM tables.
      { Set the cycle_number_valid flag to FALSE after initializing the
      { evaluated_file_reference to prevent an infinite loop if either fmp$
      { interface causes a condition that invokes the handler.
      {
      IF cycle_number_valid THEN
        PUSH p_evaluated_file_reference;
        pfp$convert_pf_to_fs_structure (path, p_evaluated_file_reference^);
        p_evaluated_file_reference^.cycle_reference.specification := fsc$cycle_number;
        p_evaluated_file_reference^.cycle_reference.cycle_number := cycle_number;
        cycle_number_valid := FALSE;
        #SPOIL(cycle_number_valid);
        fmp$process_pt_request (process_pt_work_list, lfn, p_evaluated_file_reference^, p_cycle_description,
              process_pt_results, local_status);
        fmp$delete_path_description (p_evaluated_file_reference^, {implicit_detach} FALSE,
              {return_permanent_file} TRUE, {detachment_options} NIL, local_status);
      IFEND;

      EXIT pfp$r2_define;
    PROCEND initiate_non_local_exit;

    VAR
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      cycle_number_valid: boolean,
      date_time: ost$date_time,
      ignore_path_handle: fmt$path_handle,
      ignore_sfid: gft$system_file_identifier,
      local_status: ost$status,
      new_file_index: integer,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_internal_cycle_path: ^pft$internal_cycle_path,
      parent_charge_id: pft$charge_id,
      path_table_lock_set: boolean,
      permit_entry: pft$permit_entry,
      physical_object: pft$physical_object,
      process_non_local_exit: boolean,
      usage_selections: pft$usage_selections,
      valid_objects: pft$object_selections;

    syp$push_inhibit_job_recovery;

    cycle_number_valid := FALSE;
    #SPOIL(cycle_number_valid);
    path_table_lock_set := FALSE;
    #SPOIL(path_table_lock_set);
    process_non_local_exit := FALSE;
    #SPOIL(process_non_local_exit);

    pmp$get_compact_date_time (date_time, local_status);
    pfp$process_unexpected_status (local_status);
    pfp$get_authority (path, system_privilege, authority, status);
    IF status.normal THEN
      IF family_location = pfc$local_mainframe THEN
        fmp$lock_path_table (status);
        IF NOT status.normal THEN
          syp$pop_inhibit_job_recovery;
          RETURN;
        IFEND;
        path_table_lock_set := TRUE;
      IFEND;

      valid_objects := $pft$object_selections [pfc$free_object, pfc$file_object];
      new_file_index := UPPERBOUND (path);
      PUSH p_internal_cycle_path: [1 .. new_file_index];
      pfp$access_object (path, pfc$write_access, authority, valid_objects, parent_charge_id, catalog_locator,
            p_file_object, p_internal_cycle_path^.path, permit_entry, status);
    IFEND;
    catalog_active := status.normal;
    osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

    IF status.normal THEN
      IF p_file_object^.object_entry.object_type = pfc$file_object THEN
        {
        { Care must be exercised in adding new cycles. The old information for
        { a file must be left intact, if a cycle cannot be added. If a new
        { cycle causes the creation of a file object, then all items belonging
        { to the file object should be created before the file object is placed
        { in the catalog.
        {
        physical_object := p_file_object^;
        pfp$validate_password (path, authority, password, p_file_object, status);

        IF status.normal THEN
          pfp$validate_file_permission (path, authority, permit_entry, $pft$permit_selections [pfc$cycle],
                - $pft$share_selections [], status);
        IFEND;
      ELSE
        pfp$validate_file_permission (path, authority, permit_entry, $pft$permit_selections [pfc$cycle],
              - $pft$share_selections [], status);

        IF status.normal THEN
          pfp$create_file_object (path [new_file_index], authority, parent_charge_id, password, log,
                physical_object.object_entry);
          p_internal_cycle_path^.path [new_file_index] := physical_object.object_entry.internal_object_name;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      pfp$build_cycle_list_pointer (physical_object.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      pfp$determine_new_cycle_number (path, p_cycle_list, cycle_selector, cycle_number, status);
      cycle_number_valid := status.normal;
      #SPOIL(cycle_number_valid);
    IFEND;

    IF status.normal THEN
      IF (device_class = rmc$magnetic_tape_device) AND
            (p_removable_media_req_info^.write_ring = rmc$no_write_ring) THEN
        usage_selections := $pft$usage_selections [pfc$read, pfc$execute];
      ELSE
        usage_selections := - $pft$usage_selections [];
      IFEND;

      create_cycle (family_location, mainframe_id, path, cycle_number, lfn, date_time, authority,
            usage_selections, $pft$share_selections [], permit_entry.application_info, validation_ring,
            {enable_media_damage_detection} FALSE, {implicit_attach} FALSE, fs_retention, retrieve_option,
            site_archive_option, site_backup_option, site_release_option, {p_file_label} NIL,
            device_class, p_mass_storage_request_info, p_removable_media_req_info, p_volume_list,
            catalog_locator.p_catalog_file, p_file_object, p_internal_cycle_path, physical_object,
            p_cycle_list, p_cycle, ignore_sfid, ignore_path_handle, bytes_allocated, p_file_server_buffers,
            status);
      IF NOT status.normal THEN
        pfp$delete_file_object (^path, catalog_locator.p_catalog_file, p_file_object,
              catalog_locator.object_list_descriptor, local_status);
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;
    IF catalog_active THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    IF path_table_lock_set THEN
      fmp$unlock_path_table;
    IFEND;
    pfv$locked_apfid := 0;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_define;

?? TITLE := '  [XDCL, #GATE] pfp$r2_define_catalog', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_define_catalog
    (    path: pft$complete_path;
         charge_id: pft$charge_id;
         system_privilege: boolean;
         catalog_type_selected: boolean;
         selected_catalog_type: pft$catalog_types;
         p_mass_storage_request_info: ^fmt$mass_storage_request_info;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_define_catalog;
    PROCEND initiate_non_local_exit;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      catalog_type: pft$catalog_types,
      family_catalog: boolean,
      group: pft$group,
      local_status: ost$status,
      master_catalog: boolean,
      new_catalog_index: integer,
      p_catalog_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;

  /define_catalog/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);

      pfp$get_authority (path, system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /define_catalog/;
      IFEND;

      new_catalog_index := UPPERBOUND (path);
      family_catalog := new_catalog_index = pfc$family_path_index;
      master_catalog := new_catalog_index = pfc$master_catalog_path_index;

      IF family_catalog OR master_catalog THEN
        pfp$validate_family_ownership (path [pfc$family_path_index], authority, status);
      ELSE
        pfp$validate_ownership (authority, path, status);
      IFEND;
      IF NOT status.normal THEN
        EXIT /define_catalog/;
      IFEND;

      PUSH p_internal_path: [1 .. new_catalog_index];
      pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$free_object],
            parent_charge_id, catalog_locator, p_catalog_object, p_internal_path^, permit_entry, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /define_catalog/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      IF catalog_type_selected THEN
        catalog_type := selected_catalog_type;
      ELSEIF family_catalog THEN
        catalog_type := pfc$internal_catalog;
      ELSE
        catalog_type := pfc$external_catalog;
      IFEND;

      pfp$create_catalog_object (path, authority, catalog_type, parent_charge_id, charge_id,
            p_mass_storage_request_info, catalog_locator.p_catalog_file, p_catalog_object, status);
      IF status.normal AND master_catalog THEN
        group.group_type := pfc$user;
        group.user_description.family := path [pfc$family_path_index];
        group.user_description.user := path [pfc$master_catalog_path_index];
        replace_permit_description (path, group, -$pft$permit_selections [], $pft$share_requirements [],
              {application_info} osc$null_name, p_catalog_object, catalog_locator.p_catalog_file, status);
      IFEND;
    END /define_catalog/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_define_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$r2_define_data', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_define_data
    (    family_location: pft$family_location;
         mainframe_id: pmt$binary_mainframe_id;
         lfn: amt$local_file_name;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         update_cycle_statistics: boolean;
         password_selector: pft$password_selector;
         validation_ring: ost$valid_ring;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
         p_volume_list: {input} ^array [1 .. * ] of rmt$recorded_vsn;
         purge_cycle_options: pft$purge_cycle_options;
         replace_cycle_data: boolean;
         restore_selections: put$restore_data_selections;
     VAR mandated_modification_time: {i/o} pft$mandated_modification_time;
     VAR data_residence: pft$data_residence;
     VAR authority: pft$authority;
     VAR bytes_allocated: amt$file_byte_address;
     VAR p_file_server_buffers: {i^/o^} pft$p_file_server_buffers;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
    VAR
      p_cycle_description: ^fmt$cycle_description,
      p_evaluated_file_reference: ^fst$evaluated_file_reference,
      process_pt_results: bat$process_pt_results;

      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);

      IF path_table_lock_set THEN
        fmp$unlock_path_table;
        path_table_lock_set := FALSE;
        #SPOIL(path_table_lock_set);
      IFEND;
      {
      { Attempt to clean up BAM tables.
      { Set the cycle_number_valid flag to FALSE after initializing the
      { evaluated_file_reference to prevent an infinite loop if either fmp$
      { interface causes a condition that invokes the handler.
      {
      IF cycle_number_valid THEN
        PUSH p_evaluated_file_reference;
        pfp$convert_pf_to_fs_structure (path, p_evaluated_file_reference^);
        p_evaluated_file_reference^.cycle_reference.specification := fsc$cycle_number;
        p_evaluated_file_reference^.cycle_reference.cycle_number := cycle_number;
        cycle_number_valid := FALSE;
        #SPOIL(cycle_number_valid);
        fmp$process_pt_request (process_pt_work_list, lfn, p_evaluated_file_reference^, p_cycle_description,
              process_pt_results, local_status);
        fmp$delete_path_description (p_evaluated_file_reference^, {implicit_detach} FALSE,
              {return_permanent_file} TRUE, {detachment_options} NIL, local_status);
      IFEND;

      EXIT pfp$r2_define_data;
    PROCEND initiate_non_local_exit;

    CONST
      enable_media_damage_detection = TRUE,
      implicit_attach = TRUE;

    VAR
      apfid_assigned: boolean,
      apfid_in_use: boolean,
      apft_index: pft$attached_pf_table_index,
      bytes_released: amt$file_byte_address,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      cycle_number: pft$cycle_number,
      cycle_number_valid: boolean,
      cycle_on_missing_volume: boolean,
      cycle_on_selected_volume: boolean,
      cycle_on_unavailable_volume: boolean,
      define_cycle: boolean,
      device_class: rmt$device_class,
      disk_image_deleted: boolean,
      flush_catalog_pages: boolean,
      fs_path_size: fst$path_size,
      ignore_path_handle: fmt$path_handle,
      internal_cycle_name: pft$internal_name,
      local_status: ost$status,
      modification_times_match: boolean,
      new_cycle_list: boolean,
      p_attached_pf_entry: ^pft$attached_pf_entry,
      p_cycle: ^pft$physical_cycle,
      p_cycle_description: ^fmt$cycle_description,
      p_cycle_list: ^pft$cycle_list,
      p_data_modification_date_time: ^ost$date_time,
      p_evaluated_file_reference: ^fst$evaluated_file_reference,
      p_file_object: ^pft$physical_object,
      p_free_cycle: ^pft$physical_cycle,
      p_fs_path: ^fst$path,
      p_internal_cycle_path: ^pft$internal_cycle_path,
      p_new_cycle_list: ^pft$cycle_list,
      p_physical_fmd: ^pft$physical_fmd,
      parent_charge_id: pft$charge_id,
      path_description_created: boolean,
      path_handle_name: amt$local_file_name,
      path_name: ost$string,
      path_table_lock_set: boolean,
      permit_entry: pft$permit_entry,
      pf_system_file_id: gft$system_file_identifier,
      prevalidate_free_result: ost$prevalidate_free_result,
      process_non_local_exit: boolean,
      process_pt_results: bat$process_pt_results,
      valid_objects: pft$object_selections;

    cycle_number_valid := FALSE;
    #SPOIL(cycle_number_valid);
    define_cycle := FALSE;
    path_table_lock_set := FALSE;
    #SPOIL(path_table_lock_set);
    process_non_local_exit := FALSE;
    #SPOIL(process_non_local_exit);
    p_attached_pf_entry := NIL;
    path_description_created := FALSE;

    syp$push_inhibit_job_recovery;

    pfp$get_authority (path, {system_privilege} FALSE, authority, status);
    IF status.normal THEN
      IF family_location = pfc$local_mainframe THEN
        fmp$lock_path_table (status);
        IF NOT status.normal THEN
          syp$pop_inhibit_job_recovery;
          RETURN;
        IFEND;
        path_table_lock_set := TRUE;
      IFEND;

      valid_objects := $pft$object_selections [pfc$file_object];
      PUSH p_internal_cycle_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, valid_objects, parent_charge_id, catalog_locator,
            p_file_object, p_internal_cycle_path^.path, permit_entry, status);
    IFEND;
    catalog_active := status.normal;
    osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

    IF status.normal THEN
      pfp$validate_default_password (path, authority, password_selector, p_file_object, status);
    IFEND;

    IF status.normal THEN
      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
      IF status.normal THEN
        cycle_number := p_cycle^.cycle_entry.cycle_number;
        cycle_number_valid := TRUE;
        #SPOIL(cycle_number_valid);
      IFEND;
    IFEND;

    IF status.normal THEN
      data_residence := p_cycle^.cycle_entry.data_residence;
      IF data_residence = pfc$offline_data THEN
        pfp$validate_file_permission (path, authority, permit_entry,
            $pft$permit_selections  [pfc$read, pfc$shorten, pfc$append, pfc$modify, pfc$execute],
            - $pft$share_selections [], status);
      ELSE

        {
        { Cycle permit is only verified for non owners.
        {

        IF authority.ownership = $pft$ownership [] THEN
          pfp$validate_file_permission (path, authority, permit_entry, $pft$permit_selections [pfc$cycle],
              - $pft$share_selections [], status);
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      IF replace_cycle_data THEN
        pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, catalog_locator.p_catalog_file,
              p_physical_fmd);
        IF p_physical_fmd <> NIL THEN
          locate_cycle_on_selected_volume (^p_physical_fmd^.fmd, p_volume_list, cycle_on_selected_volume,
                status);
          IF status.normal AND (NOT cycle_on_selected_volume) THEN
            PUSH p_fs_path;
            pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$restore_not_selected,
                  p_fs_path^ (1, fs_path_size), status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  'REPLACE_CYCLE_DATA=TRUE and not on selected volume(s)', status);
          IFEND;
        IFEND;
      ELSE
        pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, catalog_locator.p_catalog_file,
              p_physical_fmd);
        IF (p_physical_fmd <> NIL) AND
              ((puc$media_missing IN restore_selections) OR (puc$volume_unavailable IN restore_selections))
                   THEN
          locate_cycle_on_selected_volume (^p_physical_fmd^.fmd, p_volume_list, cycle_on_selected_volume,
                status);
          IF status.normal THEN
            IF cycle_on_selected_volume THEN
              locate_cycle_on_active_device (^path, p_cycle, p_physical_fmd^.fmd,
                    catalog_locator.p_catalog_file, cycle_on_missing_volume, cycle_on_unavailable_volume,
                    status);

              IF status.normal THEN
                define_cycle := (cycle_on_missing_volume  AND (puc$media_missing IN restore_selections)) OR
                      (cycle_on_unavailable_volume AND (puc$volume_unavailable IN restore_selections));

                IF NOT define_cycle THEN
                  PUSH p_fs_path;
                  pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
                  osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$data_already_defined,
                        p_fs_path^ (1, fs_path_size), status);
                  osp$append_status_integer (osc$status_parameter_delimiter,
                       p_cycle^.cycle_entry.cycle_number, radix, NOT include_radix, status);
                IFEND;
              IFEND;
            ELSE
              PUSH p_fs_path;
              pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$restore_not_selected,
                    p_fs_path^ (1, fs_path_size), status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    'RESTORE_EXCLUDED_FILE_CYCLES and not on selected volume(s)', status);
            IFEND;
          IFEND;
        ELSEIF p_physical_fmd <> NIL THEN
          PUSH p_fs_path;
          pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$data_already_defined,
                p_fs_path^ (1, fs_path_size), status);
          osp$append_status_integer (osc$status_parameter_delimiter, p_cycle^.cycle_entry.cycle_number,
                radix, NOT include_radix, status);
        ELSE
          IF NOT (puc$no_data_defined IN restore_selections) THEN
            PUSH p_fs_path;
            pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$restore_not_selected,
                  p_fs_path^ (1, fs_path_size), status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  'RESTORE_EXCLUDED_FILE_CYCLES and NO_DATA_DEFINED not in RESTORE_OPTIONS', status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal AND ((mandated_modification_time.verify_option = pfc$verify_modification_time) OR
          (mandated_modification_time.verify_option = pfc$replace_modification_time)) THEN
      modification_times_match := ((mandated_modification_time.specified_modification_time =
            p_cycle^.cycle_entry.cycle_statistics.modification_date_time) OR
            (mandated_modification_time.specified_modification_time =
            p_cycle^.cycle_entry.data_modification_date_time));
      IF (mandated_modification_time.verify_option = pfc$verify_modification_time) AND
            NOT modification_times_match THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$modification_time_mismatch,
              p_fs_path^ (1, fs_path_size), status);
        osp$append_status_integer (osc$status_parameter_delimiter, p_cycle^.cycle_entry.cycle_number, radix,
              NOT include_radix, status);
      IFEND;
    IFEND;

    IF status.normal AND replace_cycle_data THEN
      IF p_cycle^.cycle_entry.device_information.device_class_defined THEN
        pfp$convert_device_class_to_rm (p_cycle^.cycle_entry.device_information.device_class,
              device_class);
      ELSE
        device_class := rmc$mass_storage_device;
      IFEND;

      IF (mandated_modification_time.verify_option = pfc$replace_modification_time) OR
         (mandated_modification_time.verify_option = pfc$verify_modification_time) THEN
        p_data_modification_date_time := ^mandated_modification_time.specified_modification_time;
      ELSE
        p_data_modification_date_time := NIL;
      IFEND;
      purge_cycle (path, device_class, purge_cycle_options,
            p_data_modification_date_time, p_cycle, catalog_locator.p_catalog_file, p_file_object,
            catalog_locator.object_list_descriptor, disk_image_deleted, bytes_released, local_status);
      IF local_status.normal THEN
        IF (pfc$master_catalog_owner IN authority.ownership) AND (bytes_released > 0) THEN
          sfp$accumulate_file_space (sfc$perm_file_space_limit, -bytes_released);
        IFEND;
      ELSE
        status := local_status;
      IFEND;
    IFEND;

    IF status.normal THEN
      pfp$assign_locked_apfid (apft_index, status);
    IFEND;
    apfid_assigned := status.normal;
    pfv$locked_apfid := apft_index;

    IF status.normal THEN
      pfp$create_permanent_file (family_location, lfn, path, p_cycle^.cycle_entry.cycle_number, apft_index,
            - $pft$usage_selections [], $pft$share_selections [], permit_entry.application_info,
            validation_ring, {password_protected} (p_file_object^.object_entry.password <> osc$null_name),
            NOT enable_media_damage_detection, NOT implicit_attach, {recreate_attached_cycle_data} FALSE,
            {p_file_label} NIL, rmc$mass_storage_device, p_mass_storage_request_info,
            {p_removable_media_req_info} NIL, {p_volume_list} NIL, authority, ignore_path_handle,
            pf_system_file_id, internal_cycle_name, bytes_allocated, p_file_server_buffers, status);
    IFEND;
    path_description_created := status.normal;

    IF status.normal AND define_cycle THEN
      {
      { The file is on a selected downed device or a medium is missing.
      {
      IF p_cycle^.cycle_entry.attach_status.attach_count > 0 THEN
        {
        { Logically purge the old cycle and create a new cycle to replace it.
        {
        p_cycle^.cycle_entry.entry_type := pfc$purged_cycle_entry;
        pfp$compute_checksum (^p_cycle^.cycle_entry, #SIZE (p_cycle^.cycle_entry), p_cycle^.checksum);

        pfp$establish_free_cycle_entry (^catalog_locator.p_catalog_file^.catalog_heap, p_cycle_list,
              p_new_cycle_list, new_cycle_list, p_free_cycle, status);
        IF status.normal THEN
          IF new_cycle_list THEN
            pfp$build_cycle_list_locator (p_new_cycle_list, catalog_locator.p_catalog_file,
                  p_file_object^.object_entry.cycle_list_locator);
            pfp$compute_checksum (^p_file_object^.object_entry, #SIZE (pft$object_entry),
                  p_file_object^.checksum);
            p_free_cycle^ := p_cycle^;
            osp$prevalidate_free ((#OFFSET(p_cycle_list) -
                  #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
                   ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
            IF prevalidate_free_result = osc$heap_free_valid THEN
              FREE p_cycle_list IN catalog_locator.p_catalog_file^.catalog_heap;
            ELSE
              pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'CYCLE_LIST', 'file',
                    prevalidate_free_result, #OFFSET(p_cycle_list));
              p_cycle_list := NIL;
            IFEND;
            p_cycle_list := p_new_cycle_list;
          ELSE
            p_free_cycle^ := p_cycle^;
          IFEND;
          p_cycle := p_free_cycle;
          p_cycle^.cycle_entry.entry_type := pfc$normal_cycle_entry;
          p_cycle^.cycle_entry.attach_status := pfv$unattached_status;
          p_cycle^.cycle_entry.cycle_damage_symptoms := $fst$cycle_damage_symptoms [];
          pfp$build_fmd_locator ({p_physical_fmd} NIL, {p_catalog_file} NIL,
                p_cycle^.cycle_entry.fmd_locator);
          pfp$build_file_label_locator ({p_file_label} NIL, catalog_locator.p_catalog_file,
                p_cycle^.cycle_entry.file_label_locator);
          pfp$compute_checksum (^p_cycle^.cycle_entry, #SIZE (p_cycle^.cycle_entry), p_cycle^.checksum);
        IFEND;
      ELSE
        {
        { Delete all subfiles before re-creating the cycle.
        {
        dmp$destroy_permanent_file (p_cycle^.cycle_entry.internal_cycle_name, p_physical_fmd^.fmd,
              local_status);
        osp$prevalidate_free ((#OFFSET(p_physical_fmd) -
              #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
              ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
        IF prevalidate_free_result = osc$heap_free_valid THEN
          FREE p_physical_fmd IN catalog_locator.p_catalog_file^.catalog_heap;
        ELSE
          pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'FILE_MEDIA_DESCRIPTOR', 'file',
                prevalidate_free_result, #OFFSET(p_physical_fmd));
          p_physical_fmd := NIL;
        IFEND;
        pfp$build_fmd_locator ({p_physical_fmd} NIL, {p_catalog_file} NIL, p_cycle^.cycle_entry.fmd_locator);
        pfp$compute_checksum (^p_cycle^.cycle_entry, #SIZE (p_cycle^.cycle_entry), p_cycle^.checksum);
      IFEND;
    IFEND;

    IF status.normal THEN
      pfp$record_dm_file_parameters (^path, ^p_cycle^.cycle_entry.cycle_number, pf_system_file_id,
            rmc$mass_storage_device, {p_removable_media_req_info} NIL, {p_volume_list} NIL,
            ^catalog_locator.p_catalog_file^.catalog_heap, p_physical_fmd, status);
    IFEND;

    IF status.normal THEN
      p_internal_cycle_path^.cycle_name := internal_cycle_name;
      build_attached_pf_entry (pf_system_file_id, path, p_cycle^.cycle_entry.cycle_number,
            rmc$mass_storage_device, {update_catalog} TRUE, update_cycle_statistics,
            - $pft$usage_selections [], $pft$share_selections [], {media_image_inconsistent} FALSE,
            {media_damage_detection_enabled} FALSE, $fst$cycle_damage_symptoms [], p_internal_cycle_path^,
            p_attached_pf_entry, status);
    IFEND;
    apfid_in_use := status.normal;

    IF status.normal THEN
      mandated_modification_time.existing_modification_time :=
            p_cycle^.cycle_entry.cycle_statistics.modification_date_time;
      IF (mandated_modification_time.verify_option = pfc$replace_modification_time) AND
            NOT modification_times_match AND NOT replace_cycle_data THEN
        p_cycle^.cycle_entry.cycle_damage_symptoms :=
              $fst$cycle_damage_symptoms [fsc$respf_modification_mismatch];
        p_cycle^.cycle_entry.cycle_statistics.modification_date_time :=
              mandated_modification_time.specified_modification_time;
        p_cycle^.cycle_entry.data_modification_date_time :=
              mandated_modification_time.specified_modification_time;
      IFEND;
      p_cycle^.cycle_entry.internal_cycle_name := internal_cycle_name;
      p_cycle^.cycle_entry.device_information.device_class_defined := TRUE;
      p_cycle^.cycle_entry.device_information.device_class := pfc$mass_storage_device;
      IF data_residence <> pfc$offline_data THEN
        p_cycle^.cycle_entry.device_information.eoi := 0;
        p_cycle^.cycle_entry.device_information.bytes_allocated := bytes_allocated;
      IFEND;
      IF replace_cycle_data THEN
         p_cycle^.cycle_entry.global_file_name := internal_cycle_name;
      IFEND;
      pfp$increment_usage_counts (path, -$pft$usage_selections [], $pft$share_selections [], mainframe_id,
            catalog_locator.p_catalog_file, flush_catalog_pages, p_cycle^.cycle_entry, status);
      pfp$build_fmd_locator (p_physical_fmd, catalog_locator.p_catalog_file,
            p_cycle^.cycle_entry.fmd_locator);
      pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (p_cycle^.cycle_entry), p_cycle^.checksum);
    IFEND;

    IF NOT status.normal AND path_description_created THEN
      dmp$destroy_file (pf_system_file_id, sfc$no_limit, local_status);

      PUSH p_evaluated_file_reference;
      pfp$convert_pf_to_fs_structure (path, p_evaluated_file_reference^);
      p_evaluated_file_reference^.cycle_reference.specification := fsc$cycle_number;
      p_evaluated_file_reference^.cycle_reference.cycle_number := cycle_number;
      fmp$process_pt_request (process_pt_work_list, lfn, p_evaluated_file_reference^, p_cycle_description,
            process_pt_results, local_status);
      fmp$delete_path_description (p_evaluated_file_reference^, {implicit_detach} FALSE,
            {return_permanent_file} FALSE, {detachment_options} NIL, local_status);

      IF p_attached_pf_entry <> NIL THEN
        IF p_attached_pf_entry^.p_external_path <> NIL THEN
          FREE p_attached_pf_entry^.p_external_path IN pfv$p_p_job_heap^^;
        IFEND;
        FREE p_attached_pf_entry IN pfv$p_p_job_heap^^;
        pfp$release_locked_apfid (apft_index, local_status);
        pfp$process_unexpected_status (local_status);
        apfid_assigned := FALSE;
      IFEND;
    IFEND;

    IF apfid_assigned THEN
      IF apfid_in_use THEN
        pfp$unlock_apfid (apft_index, p_attached_pf_entry, local_status);
      ELSE
        pfp$release_locked_apfid (apft_index, local_status);
      IFEND;
      pfv$locked_apfid := 0;
      pfp$process_unexpected_status (local_status);
    IFEND;

    osp$disestablish_cond_handler;
    IF catalog_active THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    IF path_table_lock_set THEN
      fmp$unlock_path_table;
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_define_data;

?? TITLE := '  [XDCL, #GATE] pfp$r2_delete_all_arch_entries', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_delete_all_arch_entries (
        path: pft$complete_path;
        cycle_selector: pft$cycle_selector;
    VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_delete_all_arch_entries;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      archive_index: pft$archive_index,
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      p_archive_entry: ^pft$archive_entry,
      p_archive_list: ^pft$archive_list,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_fs_path: ^fst$path,
      p_internal_path: ^pft$internal_path,
      p_physical_amd: ^pft$physical_amd,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      prevalidate_free_result: ost$prevalidate_free_result,
      process_non_local_exit: boolean,
      update_checksum: boolean;

    syp$push_inhibit_job_recovery;

    /delete_archive_list/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL(process_non_local_exit);
      update_checksum := FALSE;

      pfp$get_authority (path, NOT system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /delete_archive_list/;
      IFEND;

      pfp$validate_ownership (authority, path, status);
      IF NOT status.normal THEN
        EXIT /delete_archive_list/;
      IFEND;

      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$file_object],
            parent_charge_id, catalog_locator, p_file_object, p_internal_path^, permit_entry, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /delete_archive_list/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
          catalog_locator.p_catalog_file, p_cycle_list);

      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
      IF NOT status.normal THEN
        EXIT /delete_archive_list/;
      IFEND;

      IF p_cycle^.cycle_entry.archive_list_locator.archive_count = 0 THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$empty_archive_list,
            p_fs_path^ (1, fs_path_size), status);
        EXIT /delete_archive_list/;
      IFEND;

      update_checksum := TRUE;

      pfp$build_archive_list_pointer (p_cycle^.cycle_entry.archive_list_locator,
          catalog_locator.p_catalog_file, p_archive_list);

      FOR archive_index := 1 TO UPPERBOUND(p_archive_list^) DO
        p_archive_entry := ^p_archive_list^[archive_index].archive_entry;
        pfp$build_amd_pointer (p_archive_entry^.amd_locator, catalog_locator.p_catalog_file, p_physical_amd);
        IF p_physical_amd <> NIL THEN
          osp$prevalidate_free ((#OFFSET(p_physical_amd) -
                #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
                ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_physical_amd IN catalog_locator.p_catalog_file^.catalog_heap;
          ELSE
            pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'ARCHIVE_MEDIA_DESCRIPTOR',
                  'file', prevalidate_free_result, #OFFSET(p_physical_amd));
            p_physical_amd := NIL;
          IFEND;
        IFEND;
      FOREND;

      osp$prevalidate_free ((#OFFSET(p_archive_list) -
            #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
            ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
      IF prevalidate_free_result = osc$heap_free_valid THEN
        FREE p_archive_list IN catalog_locator.p_catalog_file^.catalog_heap;
      ELSE
        pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'ARCHIVE_LIST', 'file',
              prevalidate_free_result, #OFFSET(p_archive_list));
        p_archive_list := NIL;
      IFEND;
      pfp$build_archive_list_locator ({p_archive_list} NIL, catalog_locator.p_catalog_file,
          p_cycle^.cycle_entry.archive_list_locator);

    END /delete_archive_list/;

    IF update_checksum THEN
      pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
    IFEND;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;

  PROCEND pfp$r2_delete_all_arch_entries;

?? TITLE := '  [XDCL, #GATE] pfp$r2_delete_archive_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_delete_archive_entry (
        path: pft$complete_path;
        cycle_selector: pft$cycle_selector;
        archive_identification: pft$archive_identification;
    VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_delete_archive_entry;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      delete_count: pft$archive_count,
      found: boolean,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      new_archive_count: pft$archive_count,
      new_archive_index: pft$archive_index,
      old_archive_index: pft$archive_index,
      p_archive_entry: ^pft$archive_entry,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_fs_path: ^fst$path,
      p_internal_path: ^pft$internal_path,
      p_new_archive_list: ^pft$archive_list,
      p_old_archive_list: ^pft$archive_list,
      p_physical_amd: ^pft$physical_amd,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      prevalidate_free_result: ost$prevalidate_free_result,
      process_non_local_exit: boolean,
      update_checksum: boolean;

    syp$push_inhibit_job_recovery;

    /delete_archive_entry/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL(process_non_local_exit);
      update_checksum := FALSE;

      pfp$get_authority (path, NOT system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /delete_archive_entry/;
      IFEND;

      pfp$validate_ownership (authority, path, status);
      IF NOT status.normal THEN
        EXIT /delete_archive_entry/;
      IFEND;

      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$file_object],
            parent_charge_id, catalog_locator, p_file_object, p_internal_path^, permit_entry, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /delete_archive_entry/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
          catalog_locator.p_catalog_file, p_cycle_list);

      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
      IF NOT status.normal THEN
        EXIT /delete_archive_entry/;
      IFEND;

      IF p_cycle^.cycle_entry.archive_list_locator.archive_count = 0 THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$empty_archive_list,
            p_fs_path^ (1, fs_path_size), status);
        EXIT /delete_archive_entry/;
      IFEND;

      pfp$build_archive_list_pointer (p_cycle^.cycle_entry.archive_list_locator,
          catalog_locator.p_catalog_file, p_old_archive_list);
      found := FALSE;

      FOR old_archive_index := 1 TO p_cycle^.cycle_entry.archive_list_locator.archive_count DO
        p_archive_entry := ^p_old_archive_list^[old_archive_index].archive_entry;
        IF (p_archive_entry^.archive_identification.application_identifier =
            archive_identification.application_identifier) THEN
          IF (p_archive_entry^.archive_identification.media_identifier.media_device_class =
                archive_identification.media_identifier.media_device_class) THEN
            IF (p_archive_entry^.archive_identification.media_identifier.media_volume_identifier =
                  archive_identification.media_identifier.media_volume_identifier) THEN
              found := TRUE;
            IFEND;
          IFEND;
        IFEND;
      FOREND;

      IF NOT found THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_archive_ident,
            archive_identification.application_identifier, status);
        EXIT /delete_archive_entry/;
      ELSE
        update_checksum := TRUE;
      IFEND;

      new_archive_count := p_cycle^.cycle_entry.archive_list_locator.archive_count - 1;
      new_archive_index := 1;
      IF new_archive_count = 0 THEN
        p_new_archive_list := NIL;
        p_archive_entry := ^p_old_archive_list^ [1].archive_entry;
        pfp$build_amd_pointer (p_archive_entry^.amd_locator, catalog_locator.p_catalog_file,
            p_physical_amd);
        IF p_physical_amd <> NIL THEN
          osp$prevalidate_free ((#OFFSET(p_physical_amd) -
                #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
                ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_physical_amd IN catalog_locator.p_catalog_file^.catalog_heap;
          ELSE
            pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'ARCHIVE_MEDIA_DESCRIPTOR',
                  'file', prevalidate_free_result, #OFFSET(p_physical_amd));
            p_physical_amd := NIL;
          IFEND;
        IFEND;
      ELSE
        pfp$allocate_archive_list (new_archive_count, ^catalog_locator.p_catalog_file^.catalog_heap,
            p_new_archive_list, status);
        IF NOT status.normal THEN
          EXIT /delete_archive_entry/;
        IFEND;

        found := FALSE;
      /build_new_archive_list/
        FOR old_archive_index := 1 TO UPPERBOUND(p_old_archive_list^) DO
          p_archive_entry := ^p_old_archive_list^ [old_archive_index].archive_entry;
          IF NOT found THEN
            IF (p_archive_entry^.archive_identification.application_identifier =
                archive_identification.application_identifier) THEN
              IF (p_archive_entry^.archive_identification.media_identifier.media_device_class =
                    archive_identification.media_identifier.media_device_class) THEN
                IF (p_archive_entry^.archive_identification.media_identifier.media_volume_identifier =
                      archive_identification.media_identifier.media_volume_identifier) THEN
                  found := TRUE;
                  pfp$build_amd_pointer (p_archive_entry^.amd_locator, catalog_locator.p_catalog_file,
                      p_physical_amd);
                  IF p_physical_amd <> NIL THEN
                    osp$prevalidate_free ((#OFFSET(p_physical_amd) -
                          #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
                          ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
                    IF prevalidate_free_result = osc$heap_free_valid THEN
                      FREE p_physical_amd IN catalog_locator.p_catalog_file^.catalog_heap;
                    ELSE
                      pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number,
                            'ARCHIVE_MEDIA_DESCRIPTOR', 'file', prevalidate_free_result,
                            #OFFSET(p_physical_amd));
                      p_physical_amd := NIL;
                    IFEND;
                  IFEND;
                  CYCLE /build_new_archive_list/;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
          p_new_archive_list^ [new_archive_index] := p_old_archive_list^ [old_archive_index];
          new_archive_index := new_archive_index + 1;
        FOREND;
      IFEND;

      pfp$build_archive_list_locator (p_new_archive_list, catalog_locator.p_catalog_file,
          p_cycle^.cycle_entry.archive_list_locator);

      osp$prevalidate_free ((#OFFSET(p_old_archive_list) -
            #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
            ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
      IF prevalidate_free_result = osc$heap_free_valid THEN
        FREE p_old_archive_list IN catalog_locator.p_catalog_file^.catalog_heap;
      ELSE
        pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'ARCHIVE_LIST', 'file',
              prevalidate_free_result, #OFFSET(p_old_archive_list));
        p_old_archive_list := NIL;
      IFEND;
    END /delete_archive_entry/;

    IF update_checksum THEN
      pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
    IFEND;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;

  PROCEND pfp$r2_delete_archive_entry;

?? TITLE := '  [XDCL, #GATE] pfp$r2_delete_catalog_permit', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_delete_catalog_permit
    (    path: pft$complete_path;
         system_privilege: boolean;
         group: pft$group;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_delete_catalog_permit;
    PROCEND initiate_non_local_exit;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_alarm_set: boolean,
      catalog_locator: pft$catalog_locator,
      changed_catalog_locator: pft$catalog_locator,
      global_file_name: ost$binary_unique_name,
      ignore_destroy_on_last_detach: boolean,
      local_status: ost$status,
      p_catalog_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean,
      valid_objects: pft$object_selections;

    syp$push_inhibit_job_recovery;

  /delete_catalog_permit/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);

      pfp$get_authority (path, system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /delete_catalog_permit/;
      IFEND;

      pfp$validate_ownership (authority, path, status);
      IF NOT status.normal THEN
        EXIT /delete_catalog_permit/;
      IFEND;

      valid_objects := $pft$object_selections [pfc$catalog_object];
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, valid_objects, parent_charge_id,
            catalog_locator, p_catalog_object, p_internal_path^, permit_entry, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /delete_catalog_permit/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      delete_permit_description (path, group, p_catalog_object, catalog_locator.p_catalog_file, status);
      IF NOT status.normal THEN
        EXIT /delete_catalog_permit/;
      IFEND;

      IF p_catalog_object^.object_entry.catalog_object_locator.catalog_type = pfc$external_catalog THEN
        global_file_name := p_catalog_object^.object_entry.catalog_object_locator.global_file_name;
      ELSE
        global_file_name := catalog_locator.global_file_name;
      IFEND;
      pfp$check_catalog_alarm (global_file_name, catalog_alarm_set, ignore_destroy_on_last_detach);
      IF NOT catalog_alarm_set THEN
        {
        { Access the changed catalog so that an alarm may be set on it.
        {
        pfp$access_next_catalog (pfc$read_access, catalog_locator, p_catalog_object,
              (path [pfc$family_path_index] <> osv$system_family_name), changed_catalog_locator, status);
        IF status.normal THEN
          IF changed_catalog_locator.object_list_descriptor.catalog_type = pfc$internal_catalog THEN
            {
            { Set alarm on the parent.
            {
            catalog_locator.queuing_info.set_catalog_alarm := TRUE;
          ELSE
            changed_catalog_locator.queuing_info.set_catalog_alarm := TRUE;
            pfp$return_catalog (changed_catalog_locator, status);
            pfp$process_unexpected_status (status);
          IFEND;
      ELSEIF osp$file_access_condition (status) THEN
          pfp$detach_unavail_queued_cat (p_catalog_object^.object_entry.internal_object_name,
                changed_catalog_locator);
          status.normal := TRUE;
        ELSEIF status.condition <> pfe$catalog_access_retry THEN
          pfp$report_unexpected_status (status);
        IFEND;
      IFEND;
    END /delete_catalog_permit/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_delete_catalog_permit;

?? TITLE := '  [XDCL, #GATE] pfp$r2_delete_permit', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_delete_permit
    (    path: pft$complete_path;
         system_privilege: boolean;
         group: pft$group;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_delete_permit;
    PROCEND initiate_non_local_exit;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      local_status: ost$status,
      p_file_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean,
      valid_objects: pft$object_selections;

    syp$push_inhibit_job_recovery;

  /delete_permit/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);

      pfp$get_authority (path, system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /delete_permit/;
      IFEND;

      pfp$validate_ownership (authority, path, status);
      IF NOT status.normal THEN
        EXIT /delete_permit/;
      IFEND;

      valid_objects := $pft$object_selections [pfc$file_object];
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, valid_objects, parent_charge_id,
            catalog_locator, p_file_object, p_internal_path^, permit_entry, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /delete_permit/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      delete_permit_description (path, group, p_file_object, catalog_locator.p_catalog_file, status);
      syp$hang_if_job_jrt_set (pfc$tjr_delete_permit);
    END /delete_permit/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_delete_permit;

?? TITLE := '  [XDCL, #GATE] pfp$r2_detach_reserved_cycles', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_detach_reserved_cycles
    (    mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

    PROCEDURE detach_reserved_cycles_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        variant_path: pft$variant_path,
        status_id: ost$status_identifier,
        local_status: ost$status;

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := pfv$reserved_cycle_info.p_catalog_path;

      IF NOT process_non_local_exit THEN
        pfp$log_ascii ('***PF Condition Handler***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, {critical_message} FALSE, local_status);
        pfp$log_path (variant_path, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
              {critical_message} FALSE, local_status);
      IFEND;

      CASE condition.selector OF
      = pmc$system_conditions, pmc$block_exit_processing, mmc$segment_access_condition =
        IF process_non_local_exit THEN
          RETURN;
        IFEND;

        IF catalog_locator.attached THEN
          catalog_locator.abort_catalog_operation := FALSE;
          pfp$return_catalog (catalog_locator, local_status);
          IF NOT local_status.normal THEN
            pfp$report_system_error (local_status);
          IFEND;
        IFEND;

        syp$pop_inhibit_job_recovery;

        osp$set_status_from_condition (status_id, condition, p_sfsa, local_status, handler_status);
        osp$recoverable_system_error ('UNEXPECTED STATUS', ^local_status);

        status := local_status;
        initiate_non_local_exit;


      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
         {syp$invalidate_open_sfid (catalog_locator.system_file_id, local_status);
          initiate_non_local_exit;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND detach_reserved_cycles_handler;

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);

      IF all_cycles_detached THEN
        FREE pfv$reserved_cycle_info.p_catalog_path IN osv$task_shared_heap^;
        IF pfv$reserved_cycle_info.p_reserved_cycles <> NIL THEN
          FREE pfv$reserved_cycle_info.p_reserved_cycles IN osv$task_shared_heap^;
        IFEND;
        pfv$reserved_cycle_info.number_of_cycles_reserved := 0;
        osp$clear_signature_lock (pfv$reserved_cycle_info.signature_lock, status);
      IFEND;

      EXIT pfp$r2_detach_reserved_cycles;
    PROCEND initiate_non_local_exit;

    VAR
      all_cycles_detached: boolean,
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      catalog_permit_entry: pft$permit_entry,
      charge_id: pft$charge_id,
      cycle_index: pft$object_index,
      file_info: dmt$file_information,
      fmd_modified: boolean,
      local_status: ost$status,
      lock_status: ost$signature_lock_status,
      object_index: pft$object_index,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      process_non_local_exit: boolean;

    IF pfv$reserved_cycle_info.p_catalog_path = NIL THEN
      RETURN;
    IFEND;

    osp$test_signature_lock (pfv$reserved_cycle_info.signature_lock, lock_status, local_status);
    IF lock_status <> osc$sls_locked_by_current_task THEN
      RETURN;
    IFEND;

    syp$push_inhibit_job_recovery;

  /detach_reserved_cycles/
    BEGIN

      catalog_active := FALSE;
      all_cycles_detached := FALSE;
      #SPOIL (all_cycles_detached);
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);

      pfp$get_authority (pfv$reserved_cycle_info.p_catalog_path^, {system_privilege} TRUE, authority,
            status);
      IF NOT status.normal THEN
        EXIT /detach_reserved_cycles/;
      IFEND;

      PUSH p_internal_path: [1 .. UPPERBOUND (pfv$reserved_cycle_info.p_catalog_path^)];
      pfp$get_catalog (pfv$reserved_cycle_info.p_catalog_path^, pfc$write_access, authority,
            p_internal_path^, charge_id, catalog_permit_entry, catalog_locator, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /detach_reserved_cycles/;
      IFEND;

      osp$establish_condition_handler (^detach_reserved_cycles_handler, {block_exit} TRUE);

    /process_cycles/
      FOR object_index := 1 TO pfv$reserved_cycle_info.number_of_cycles_reserved DO
        pfp$locate_object (pfv$reserved_cycle_info.p_reserved_cycles^ [object_index].external_object_name,
              $pft$object_selections [pfc$file_object, pfc$purged_file_object],
              catalog_locator.object_list_descriptor, p_file_object);
        IF (p_file_object = NIL) OR (pfv$reserved_cycle_info.p_reserved_cycles^ [object_index].
              internal_object_name <> p_file_object^.object_entry.internal_object_name) THEN
          pfp$internal_locate_object (catalog_locator.object_list_descriptor.p_object_list,
                pfv$reserved_cycle_info.p_reserved_cycles^ [object_index].internal_object_name,
                p_file_object);
          IF p_file_object = NIL THEN
            CYCLE /process_cycles/;
          IFEND;
        IFEND;

        pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
              catalog_locator.p_catalog_file, p_cycle_list);

        p_cycle := NIL;

      /locate_reserved_cycle/
        FOR cycle_index := 1 TO UPPERBOUND (p_cycle_list^) DO
          IF (p_cycle_list^ [cycle_index].cycle_entry.entry_type = pfc$normal_cycle_entry) AND
                (p_cycle_list^ [cycle_index].cycle_entry.internal_cycle_name =
                pfv$reserved_cycle_info.p_reserved_cycles^ [object_index].internal_cycle_name) THEN
            p_cycle := ^p_cycle_list^ [cycle_index];
            EXIT /locate_reserved_cycle/;
          IFEND;
        FOREND /locate_reserved_cycle/;

        IF p_cycle <> NIL THEN
          pfp$detach_permanent_file ({p_path} NIL, pfv$reserved_cycle_info.p_reserved_cycles^ [object_index].
                system_file_id, $pft$usage_selections [pfc$read], {catalog_update_allowed} TRUE, p_cycle,
                catalog_locator.p_catalog_file, fmd_modified, file_info, local_status);
          IF local_status.normal THEN
            pfv$reserved_cycle_info.p_reserved_cycles^ [object_index].internal_cycle_name :=
                  pfv$null_unique_name;
            decrement_usage_counts ($pft$usage_selections [pfc$read], $pft$share_selections
                  [pfc$read, pfc$execute], mainframe_id, catalog_locator.p_catalog_file,
                  p_cycle^.cycle_entry);
            pfp$compute_checksum (^p_cycle^.cycle_entry, #SIZE (p_cycle^.cycle_entry), p_cycle^.checksum);
          IFEND;
        IFEND;

        IF (object_index MOD pfv$unlock_catalog_threshold) = 0 THEN
          pfp$unlock_catalog_pages (catalog_locator, status);
          IF NOT status.normal THEN
            EXIT /process_cycles/;
          IFEND;
        IFEND;

      FOREND /process_cycles/;
      all_cycles_detached := TRUE;
      #SPOIL (all_cycles_detached);
    END /detach_reserved_cycles/;

    IF all_cycles_detached THEN
      FREE pfv$reserved_cycle_info.p_catalog_path IN osv$task_shared_heap^;
      IF pfv$reserved_cycle_info.p_reserved_cycles <> NIL THEN
        FREE pfv$reserved_cycle_info.p_reserved_cycles IN osv$task_shared_heap^;
      IFEND;
      pfv$reserved_cycle_info.number_of_cycles_reserved := 0;
      osp$clear_signature_lock (pfv$reserved_cycle_info.signature_lock, local_status);
    IFEND;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_detach_reserved_cycles;

?? TITLE := '  [XDCL, #GATE] pfp$r2_dm_attach_item', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_dm_attach_item
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
     VAR sfid: gft$system_file_identifier;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_dm_attach_item;
    PROCEND initiate_non_local_exit;

    CONST
      root_size_guess = 0ff(16),
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      device_class: rmt$device_class,
      existing_sft_entry: dmt$existing_sft_entry,
      file_damaged: boolean,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_fmd: ^pft$fmd,
      p_fs_path: ^fst$path,
      p_internal_catalog_name: ^pft$internal_catalog_name,
      p_internal_path: ^pft$internal_path,
      p_object: ^pft$physical_object,
      p_physical_fmd: ^pft$physical_fmd,
      p_root_container: ^pft$root,
      p_stored_fmd_size: ^dmt$stored_fmd_size,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean,
      root_size: pft$root_size,
      valid_objects: pft$object_selections;

    syp$push_inhibit_job_recovery;

  /dm_attach_item/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);

      pfp$get_authority (path, NOT system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /dm_attach_item/;
      IFEND;

      IF NOT (pfc$system_owner IN authority.ownership) THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error, ' NOT SYSTEM OWNER',
              status);
        EXIT /dm_attach_item/;
      IFEND;

      IF UPPERBOUND (path) <= pfc$family_path_index THEN
        root_size := root_size_guess;
        PUSH p_root_container: [[REP root_size OF cell]];
        RESET p_root_container;
        stp$get_pf_root (path [pfc$set_path_index], root_size, p_root_container^, status);

        IF status.normal THEN
          RESET p_root_container;
          NEXT p_internal_catalog_name IN p_root_container;
          NEXT p_stored_fmd_size IN p_root_container;
          NEXT p_fmd: [[REP p_stored_fmd_size^ OF cell]] IN p_root_container;
          dmp$attach_file (p_internal_catalog_name^, gfc$fk_catalog, p_fmd^, -pfv$write_usage,
                -$pft$share_selections [], pfc$average_share_history, pfc$maximum_pf_length,
                {restricted_attach} FALSE, {exit_on_unknown_file} FALSE, {server_file} FALSE,
                mmc$null_shared_queue, file_damaged, sfid, existing_sft_entry, status);
        IFEND;
        EXIT /dm_attach_item/;
      IFEND;
      {
      { Process all items other than root catalog.
      {
      valid_objects := $pft$object_selections [pfc$file_object, pfc$catalog_object];
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$read_access, authority, valid_objects, parent_charge_id, catalog_locator,
            p_object, p_internal_path^, permit_entry, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /dm_attach_item/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      IF p_object^.object_entry.object_type = pfc$catalog_object THEN
        IF p_object^.object_entry.catalog_object_locator.catalog_type = pfc$external_catalog THEN
          pfp$build_fmd_pointer (p_object^.object_entry.catalog_object_locator.fmd_locator,
                catalog_locator.p_catalog_file, p_physical_fmd);
          IF p_physical_fmd = NIL THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error, ' NIL CATALOG FMD',
                  status);
          ELSE
            dmp$attach_file (p_object^.object_entry.internal_object_name, gfc$fk_catalog,
                  p_physical_fmd^.fmd, -pfv$write_usage, -$pft$share_selections [],
                  pfc$average_share_history, pfc$maximum_pf_length, {restricted_attach} FALSE,
                  {exit_on_unknown_file} FALSE, {server_file} FALSE, mmc$null_shared_queue, file_damaged,
                  sfid, existing_sft_entry, status);
          IFEND;
        ELSE
          {
          { Currently the only internal catalog is the family catalog,
          { which is handled above.
          {
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error, ' INTERNAL CATALOG',
                status);
        IFEND;
      ELSE {file object}
        pfp$build_cycle_list_pointer (p_object^.object_entry.cycle_list_locator,
              catalog_locator.p_catalog_file, p_cycle_list);
        pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);

        IF p_cycle^.cycle_entry.device_information.device_class_defined THEN
          pfp$convert_device_class_to_rm (p_cycle^.cycle_entry.device_information.device_class, device_class);
        ELSE
          device_class := rmc$mass_storage_device;
        IFEND;

        IF status.normal AND (device_class = rmc$mass_storage_device) THEN
          pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, catalog_locator.p_catalog_file,
                p_physical_fmd);
          IF p_physical_fmd = NIL THEN
            PUSH p_fs_path;
            pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$undefined_data,
                  p_fs_path^ (1, fs_path_size), status);
            osp$append_status_integer (osc$status_parameter_delimiter, p_cycle^.cycle_entry.cycle_number,
                  radix, NOT include_radix, status);
          ELSE
            dmp$attach_file (p_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file,
                  p_physical_fmd^.fmd, -pfv$write_usage, -$pft$share_selections [],
                  pfc$average_share_history, pfc$maximum_pf_length, {restricted_attach} FALSE,
                  {exit_on_unknown_file} FALSE, {server_file} FALSE,
                  pfp$shared_queue (p_cycle^.cycle_entry.shared_queue_info, -$pft$share_selections []),
                  file_damaged, sfid, existing_sft_entry, status);
          IFEND;
        IFEND;
      IFEND;
    END /dm_attach_item/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;
    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_dm_attach_item;

?? TITLE := '  [XDCL, #GATE] pfp$r2_flush_catalog', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_flush_catalog
    (    p_complete_path: ^pft$complete_path;
     VAR status: ost$status);

    VAR
      authority: pft$authority,
      catalog_locator: pft$catalog_locator,
      charge_id:pft$charge_id,
      index: pft$array_index,
      last_catalog_index: pft$array_index,
      local_status: ost$status,
      p_file_object: ^pft$physical_object,
      p_internal_cycle_path: ^pft$internal_cycle_path,
      p_parent_path: ^pft$complete_path,
      permit_entry: pft$permit_entry;

    syp$push_inhibit_job_recovery;
    pfp$get_authority (p_complete_path^, {system_privilege} FALSE, authority, status);

    IF status.normal THEN
      PUSH p_internal_cycle_path: [1 .. UPPERBOUND (p_complete_path^)];
      pfp$access_object (p_complete_path^, pfc$write_access, authority,
            - $pft$object_selections [pfc$free_object], charge_id, catalog_locator, p_file_object,
            p_internal_cycle_path^.path, permit_entry, status);

      IF status.normal THEN
        pfp$validate_ored_permission (p_complete_path^, authority, permit_entry,
              - $pft$permit_selections [pfc$read, pfc$execute], - $pft$share_selections [], status);
        IF status.normal THEN
          catalog_locator.flush_catalog_pages := TRUE;
          pfp$return_catalog (catalog_locator, status);
          pfp$process_unexpected_status (status);
        ELSE
          catalog_locator.flush_catalog_pages := FALSE;
          pfp$return_catalog (catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
        IFEND;
      ELSEIF status.condition = pfe$unknown_item THEN
{ The object may have been purged}
        authority.ownership := $pft$ownership [pfc$master_catalog_owner];
        last_catalog_index := UPPERBOUND (p_complete_path^) - 1;
        PUSH p_parent_path: [1 .. last_catalog_index];
        FOR index := 1 to last_catalog_index DO
          p_parent_path^ [index] := p_complete_path^ [index];
        FOREND;
        pfp$get_catalog (p_parent_path^, pfc$write_access, authority, p_internal_cycle_path^.path,
              charge_id, permit_entry, catalog_locator, status);
        IF status.normal THEN
          catalog_locator.flush_catalog_pages := TRUE;
          pfp$return_catalog (catalog_locator, status);
          pfp$process_unexpected_status (status);
        IFEND;
      IFEND;
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_flush_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$r2_mark_release_candidate', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_mark_release_candidate (
        path: pft$complete_path;
        cycle_selector: pft$cycle_selector;
        password: pft$password;
        validation_ring: ost$valid_ring;
        archive_identification: pft$archive_identification;
    VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_mark_release_candidate;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      archive_index: pft$archive_index,
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      found: boolean,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      mark_date_time: ost$date_time,
      p_archive: ^pft$physical_archive,
      p_archive_list: ^pft$archive_list,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_fs_path: ^fst$path,
      p_internal_path: ^pft$internal_path,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;

    /mark_release_candidate/
      BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL(process_non_local_exit);

      pfp$get_authority (path, NOT system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /mark_release_candidate/;
      IFEND;

      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$file_object],
            parent_charge_id, catalog_locator, p_file_object, p_internal_path^, permit_entry, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /mark_release_candidate/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      pfp$validate_file_permission (path, authority, permit_entry, $pft$permit_selections [pfc$control],
            - $pft$share_selections [], status);
      IF NOT status.normal THEN
        EXIT /mark_release_candidate/;
      IFEND;

      pfp$validate_password (path, authority, password, p_file_object, status);
      IF NOT status.normal THEN
         EXIT /mark_release_candidate/;
      IFEND;

      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
          catalog_locator.p_catalog_file, p_cycle_list);

      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
      IF NOT status.normal THEN
        EXIT /mark_release_candidate/;
      IFEND;

      IF p_cycle^.cycle_entry.archive_list_locator.archive_count = 0 THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$empty_archive_list,
            p_fs_path^ (1, fs_path_size), status);
        EXIT /mark_release_candidate/;
      IFEND;

      pfp$build_archive_list_pointer (p_cycle^.cycle_entry.archive_list_locator,
          catalog_locator.p_catalog_file, p_archive_list);

      found := FALSE;

      FOR archive_index := 1 TO p_cycle^.cycle_entry.archive_list_locator.archive_count DO
        p_archive := ^p_archive_list^[archive_index];
        IF (p_archive^.archive_entry.archive_identification.application_identifier =
            archive_identification.application_identifier) THEN
          IF (p_archive^.archive_entry.archive_identification.media_identifier.media_device_class =
                archive_identification.media_identifier.media_device_class) THEN
            IF (p_archive^.archive_entry.archive_identification.media_identifier.media_volume_identifier =
                  archive_identification.media_identifier.media_volume_identifier) THEN
              found := TRUE;
              pmp$get_compact_date_time (mark_date_time, local_status);
              p_archive^.archive_entry.release_candidate.releasable := TRUE;
              p_archive^.archive_entry.release_candidate.mark_date_time := mark_date_time;
              pfp$compute_checksum (#LOC (p_archive^.archive_entry), #SIZE (p_archive^.archive_entry),
                  p_archive^.checksum);
            IFEND;
          IFEND;
        IFEND;
      FOREND;

      IF NOT found THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_archive_ident,
            archive_identification.application_identifier, status);
        EXIT /mark_release_candidate/;
      IFEND;

    END /mark_release_candidate/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_mark_release_candidate;

?? TITLE := '  [XDCL, #GATE] pfp$r2_permit', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_permit
    (    path: pft$complete_path;
         system_privilege: boolean;
         permit_level: pft$permit_level;
         group: pft$group;
         permit_selections: pft$permit_selections;
         share_requirements: pft$share_requirements;
         application_info: pft$application_info;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_permit;
    PROCEND initiate_non_local_exit;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      local_status: ost$status,
      p_file_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean,
      valid_objects: pft$object_selections;

    syp$push_inhibit_job_recovery;

  /permit/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL(process_non_local_exit);

      pfp$get_authority (path, system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /permit/;
      IFEND;

      pfp$validate_ownership (authority, path, status);
      IF NOT status.normal THEN
        EXIT /permit/;
      IFEND;

      IF authority.ownership <= $pft$ownership [pfc$master_catalog_owner] THEN
        pfp$check_group_by_permit_level (permit_level, group, status);
        IF NOT status.normal THEN
          EXIT /permit/;
        IFEND;
      IFEND;

      valid_objects := $pft$object_selections [pfc$file_object];
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, valid_objects, parent_charge_id,
            catalog_locator, p_file_object, p_internal_path^, permit_entry, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /permit/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      replace_permit_description (path, group, permit_selections, share_requirements, application_info,
            p_file_object, catalog_locator.p_catalog_file, status);
      syp$hang_if_job_jrt_set (pfc$tjr_permit);
    END /permit/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_permit;

?? TITLE := '  [XDCL, #GATE] pfp$r2_permit_catalog', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_permit_catalog
    (    path: pft$complete_path;
         system_privilege: boolean;
         permit_level: pft$permit_level;
         group: pft$group;
         permit_selections: pft$permit_selections;
         share_requirements: pft$share_requirements;
         application_info: pft$application_info;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_permit_catalog;
    PROCEND initiate_non_local_exit;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_alarm_set: boolean,
      catalog_locator: pft$catalog_locator,
      changed_catalog_locator: pft$catalog_locator,
      global_file_name: ost$binary_unique_name,
      ignore_destroy_on_last_detach: boolean,
      local_status: ost$status,
      p_catalog_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean,
      valid_objects: pft$object_selections;

    syp$push_inhibit_job_recovery;

  /permit_catalog/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);

      pfp$get_authority (path, system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /permit_catalog/;
      IFEND;

      pfp$validate_ownership (authority, path, status);
      IF NOT status.normal THEN
        EXIT /permit_catalog/;
      IFEND;

      IF authority.ownership <= $pft$ownership [pfc$master_catalog_owner] THEN
        pfp$check_group_by_permit_level (permit_level, group, status);
        IF NOT status.normal THEN
          EXIT /permit_catalog/;
        IFEND;
      IFEND;

      valid_objects := $pft$object_selections [pfc$catalog_object];
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, valid_objects, parent_charge_id,
            catalog_locator, p_catalog_object, p_internal_path^, permit_entry, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /permit_catalog/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      replace_permit_description (path, group, permit_selections, share_requirements, application_info,
            p_catalog_object, catalog_locator.p_catalog_file, status);
      IF NOT status.normal THEN
        EXIT /permit_catalog/;
      IFEND;

      IF p_catalog_object^.object_entry.catalog_object_locator.catalog_type = pfc$external_catalog THEN
        global_file_name := p_catalog_object^.object_entry.catalog_object_locator.global_file_name;
      ELSE
        global_file_name := catalog_locator.global_file_name;
      IFEND;
      pfp$check_catalog_alarm (global_file_name, catalog_alarm_set, ignore_destroy_on_last_detach);
      IF NOT catalog_alarm_set THEN
        {
        { Access the changed catalog so that an alarm may be set on it.
        {
        pfp$access_next_catalog (pfc$read_access, catalog_locator, p_catalog_object,
              (path [pfc$family_path_index] <> osv$system_family_name), changed_catalog_locator, status);
        IF status.normal THEN
          IF changed_catalog_locator.object_list_descriptor.catalog_type = pfc$internal_catalog THEN
            {
            { Set alarm on the parent.
            {
            catalog_locator.queuing_info.set_catalog_alarm := TRUE;
          ELSE
            changed_catalog_locator.queuing_info.set_catalog_alarm := TRUE;
            pfp$return_catalog (changed_catalog_locator, status);
            pfp$process_unexpected_status (status);
          IFEND;
        ELSEIF osp$file_access_condition (status) THEN
          pfp$detach_unavail_queued_cat (p_catalog_object^.object_entry.internal_object_name,
                changed_catalog_locator);
          status.normal := TRUE;
        IFEND;
      IFEND;
    END /permit_catalog/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_permit_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$r2_purge', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_purge
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         purge_cycle_options: pft$purge_cycle_options;
         system_privilege: boolean;
         validation_ring: ost$valid_ring;
     VAR authority: pft$authority;
     VAR device_class: rmt$device_class;
     VAR bytes_released: amt$file_byte_address;
     VAR status: ost$status);


    PROCEDURE purge_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        variant_path: pft$variant_path,
        status_id: ost$status_identifier,
        local_status: ost$status;

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := ^path;

      IF NOT process_non_local_exit THEN
        pfp$log_ascii ('***PF Condition Handler***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, {critical_message} FALSE, local_status);
        pfp$log_path (variant_path, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
              {critical_message} FALSE, local_status);
      IFEND;

      CASE condition.selector OF
      = pmc$system_conditions, pmc$block_exit_processing, mmc$segment_access_condition =
        IF process_non_local_exit THEN
          RETURN;
        IFEND;

        IF catalog_locator.attached THEN
          IF disk_image_deleted THEN
            p_cycle^.cycle_entry.entry_type := pfc$free_cycle_entry;
            catalog_locator.abort_catalog_operation := FALSE;
          ELSE
            catalog_locator.abort_catalog_operation := TRUE;
         IFEND;

          pfp$return_catalog (catalog_locator, local_status);
          IF NOT local_status.normal THEN
            pfp$report_system_error (local_status);
          IFEND;
        IFEND;


        osp$set_status_from_condition (status_id, condition, p_sfsa, local_status, handler_status);
        osp$recoverable_system_error ('UNEXPECTED STATUS', ^local_status);

        status := local_status;
        initiate_non_local_exit;


      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pfp$log_ascii ('***Recover Files***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
                pmc$msg_origin_system, {critical_message} FALSE, local_status);
         {syp$invalidate_open_sfid (catalog_locator.system_file_id, local_status);
          initiate_non_local_exit;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND purge_handler;

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_purge;
    PROCEND initiate_non_local_exit;

    VAR
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      disk_image_deleted: boolean,
      file_path_index: integer,
      local_status: ost$status,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_label: ^fmt$file_label,
      p_file_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      p_stored_file_label: ^pft$physical_file_label,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean,
      valid_objects: pft$object_selections;

    syp$push_inhibit_job_recovery;

    disk_image_deleted := FALSE;
    #SPOIL(disk_image_deleted);
    process_non_local_exit := FALSE;
    #SPOIL(process_non_local_exit);

    pfp$get_authority (path, system_privilege, authority, status);
    IF status.normal THEN
      valid_objects := $pft$object_selections [pfc$file_object];
      file_path_index := UPPERBOUND (path);
      PUSH p_internal_path: [1 .. file_path_index];
      pfp$access_object (path, pfc$write_access, authority, valid_objects, parent_charge_id, catalog_locator,
            p_file_object, p_internal_path^, permit_entry, status);
    IFEND;
    catalog_active := status.normal;

    osp$establish_condition_handler (^purge_handler, {block_exit} TRUE);

    IF status.normal AND purge_cycle_options.enforce_password_validation THEN
      pfp$validate_password (path, authority, password, p_file_object, status);
    IFEND;

    IF status.normal THEN
      pfp$validate_file_permission (path, authority, permit_entry, $pft$permit_selections [pfc$control],
            - $pft$share_selections [], status);
    IFEND;

    IF status.normal THEN
      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
    IFEND;

    IF status.normal THEN
      IF p_cycle^.cycle_entry.device_information.device_class_defined THEN
        pfp$convert_device_class_to_rm (p_cycle^.cycle_entry.device_information.device_class, device_class);
      ELSE
        device_class := rmc$mass_storage_device;
      IFEND;

      pfp$build_file_label_pointer (p_cycle^.cycle_entry.file_label_locator, catalog_locator.p_catalog_file,
            p_stored_file_label);
      IF p_stored_file_label = NIL THEN
        p_file_label := NIL;
      ELSE
        p_file_label := ^p_stored_file_label^.file_label;
      IFEND;

      IF purge_cycle_options.enforce_ring_validation THEN
        pfp$validate_ring_access (path, p_file_label, pfv$write_usage, validation_ring, status);
        {
        { Allow an administrator to purge a cycle which has a bad label.
        {
        status.normal := status.normal OR ((status.condition = ame$damaged_file_attributes) AND
              (authority.ownership - $pft$ownership [pfc$master_catalog_owner] <> $pft$ownership []));
      IFEND;
    ELSE
      device_class := rmc$mass_storage_device;
    IFEND;

    IF status.normal THEN
      purge_cycle (path, device_class, purge_cycle_options, {p_data_modification_date_time} NIL, p_cycle,
            catalog_locator.p_catalog_file, p_file_object, catalog_locator.object_list_descriptor,
            disk_image_deleted, bytes_released, status);
    IFEND;

    syp$hang_if_job_jrt_set (pfc$tjr_purge);

    osp$disestablish_cond_handler;
    IF catalog_active THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_purge;

?? TITLE := '  [XDCL, #GATE] pfp$r2_purge_catalog', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_purge_catalog
    (    path: pft$complete_path;
         system_privilege: boolean;
         delete_option: pft$delete_option;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_purge_catalog;
    PROCEND initiate_non_local_exit;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      local_status: ost$status,
      p_catalog_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean,
      valid_objects: pft$object_selections;

    syp$push_inhibit_job_recovery;

  /purge_catalog/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);

      pfp$get_authority (path, system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /purge_catalog/;
      IFEND;

      IF UPPERBOUND (path) <= pfc$master_catalog_path_index THEN
        pfp$validate_family_ownership (path [pfc$family_path_index], authority, status);
      ELSE
        pfp$validate_ownership (authority, path, status);
      IFEND;
      IF NOT status.normal THEN
        EXIT /purge_catalog/;
      IFEND;

      valid_objects := $pft$object_selections [pfc$catalog_object];
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, valid_objects, parent_charge_id,
            catalog_locator, p_catalog_object, p_internal_path^, permit_entry, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /purge_catalog/;
      IFEND;

      pfp$delete_catalog_object (path, delete_option, p_catalog_object, catalog_locator, status);
    END /purge_catalog/;

    IF catalog_active THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_purge_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$r2_purge_object', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_purge_object
    (    path: pft$complete_path;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_purge_object;
    PROCEND initiate_non_local_exit;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      charge_id: pft$charge_id,
      i: integer,
      local_status: ost$status,
      p_catalog_object: ^pft$physical_object,
      p_catalog_path: ^pft$complete_path,
      p_internal_path: ^pft$internal_path,
      p_physical_object: ^pft$physical_object,
      parent_catalog_index: integer,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean,
      system_privilege: boolean;

    syp$push_inhibit_job_recovery;

  /purge_object/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL(process_non_local_exit);
      system_privilege := TRUE;

      pfp$get_authority (path, system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /purge_object/;
      IFEND;

      parent_catalog_index := UPPERBOUND (path) - 1;
      PUSH p_catalog_path: [1 .. parent_catalog_index];
      FOR i := 1 TO parent_catalog_index DO
        p_catalog_path^ [i] := path [i];
      FOREND;

      PUSH p_internal_path: [1 .. parent_catalog_index];
      pfp$get_catalog (p_catalog_path^, pfc$write_access, authority, p_internal_path^, charge_id,
            permit_entry, catalog_locator, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /purge_object/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      pfp$locate_object (path [UPPERBOUND (path)], $pft$object_selections
            [pfc$file_object, pfc$catalog_object], catalog_locator.object_list_descriptor,
            p_physical_object);
      IF p_physical_object <> NIL THEN
        p_physical_object^.object_entry.object_type := pfc$free_object;
        pfp$compute_checksum (^p_physical_object^.object_entry, #SIZE (pft$object_entry),
              p_physical_object^.checksum);
      IFEND;
    END /purge_object/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_purge_object;

?? TITLE := '  [XDCL, #GATE] pfp$r2_recreate_system_catalog', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to re-create the $system master catalog if
{   necessary.
{
{ DESIGN:
{   This procedure will attempt to attach the $system master catalog.  If
{   successful the catalog will be returned and no other action will be taken.
{   If the catalog is found to reside on a volume no longer in the
{   configuration, a new $system master catalog will be created and the
{   catalog_recreated_by_restore field in both the $system family catalog and
{   the $system master catalog will be set to TRUE.

  PROCEDURE [XDCL, #GATE] pfp$r2_recreate_system_catalog
    (VAR status: ost$status);

    CONST
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_object_locator: pft$catalog_object_locator,
      family_catalog_active: boolean,
      family_catalog_locator: pft$catalog_locator,
      local_status: ost$status,
      master_catalog_active: boolean,
      master_catalog_locator: pft$catalog_locator,
      new_catalog_locator: pft$catalog_locator,
      p_family_object: ^pft$physical_object,
      p_family_path: ^pft$complete_path,
      p_internal_path: ^pft$internal_path,
      p_master_catalog_object: ^pft$physical_object,
      p_master_catalog_path: ^pft$complete_path,
      p_new_physical_fmd: ^pft$physical_fmd,
      p_physical_fmd: ^pft$physical_fmd,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      prevalidate_free_result: ost$prevalidate_free_result,
      valid_objects: pft$object_selections;

    syp$push_inhibit_job_recovery;
    family_catalog_active := FALSE;
    master_catalog_active := FALSE;
    pfv$allow_catalog_write := TRUE;
    catalog_object_locator.catalog_type := pfc$external_catalog;
    PUSH p_master_catalog_path: [1 .. pfc$master_catalog_path_index];
    p_master_catalog_path^ [pfc$set_path_index] := stv$system_set_name;
    p_master_catalog_path^ [pfc$family_path_index] := jmc$system_family;
    p_master_catalog_path^ [pfc$master_catalog_path_index] := jmc$system_user;

    pfp$get_authority (p_master_catalog_path^, system_privilege, authority, status);

    IF status.normal THEN
      pfp$validate_family_ownership (p_master_catalog_path^[pfc$family_path_index], authority, status);
    IFEND;

    IF status.normal THEN
      valid_objects := $pft$object_selections [pfc$catalog_object];
      PUSH p_internal_path: [1 .. pfc$master_catalog_path_index];
      pfp$access_object (p_master_catalog_path^, pfc$write_access, authority, valid_objects, parent_charge_id,
            family_catalog_locator, p_master_catalog_object, p_internal_path^, permit_entry, status);
    IFEND;
    family_catalog_active := status.normal;

    IF status.normal THEN
      pfp$build_fmd_pointer (p_master_catalog_object^.object_entry.catalog_object_locator.fmd_locator,
            family_catalog_locator.p_catalog_file, p_physical_fmd);

      pfp$attach_catalog (^p_physical_fmd^.fmd, stv$system_set_name,
            p_master_catalog_object^.object_entry.internal_object_name,
            p_master_catalog_object^.object_entry.catalog_object_locator.global_file_name,
            pfc$write_access, {Catalog_remote =} TRUE, master_catalog_locator, status);
    IFEND;
    master_catalog_active := status.normal;


    IF NOT status.normal AND (status.condition = pfe$catalog_volume_not_online) THEN
      {
      { When the $system master catalog cannot be accessed a new catalog will be created
      { and the new fmd will be placed in the master catalogs entry in the family catalog.
      {
      pfp$create_catalog (p_master_catalog_path^, {p_ms_request_info} NIL, authority,
            {lock_catalog} TRUE,new_catalog_locator, status);
      IF status.normal THEN
        pfp$record_dm_file_parameters (p_master_catalog_path, {p_cycle_number} NIL,
              new_catalog_locator.system_file_id, rmc$mass_storage_device, {p_removable_media_req_info} NIL,
              {p_volume_list} NIL, ^family_catalog_locator.p_catalog_file^.catalog_heap, p_new_physical_fmd,
              status);
        IF status.normal THEN
          pfp$build_fmd_locator (p_new_physical_fmd, family_catalog_locator.p_catalog_file,
                catalog_object_locator.fmd_locator);
          catalog_object_locator.global_file_name := new_catalog_locator.global_file_name;
          pfp$return_catalog (new_catalog_locator, status);
        ELSE
          pfp$destroy_catalog (new_catalog_locator, local_status);
          pfp$process_unexpected_status (local_status);
        IFEND;
      ELSE
        pfp$report_unexpected_status (status);
      IFEND;

      IF status.normal THEN
        osp$prevalidate_free ((#OFFSET(p_physical_fmd) -
              #OFFSET(^family_catalog_locator.p_catalog_file^.catalog_heap) - 16),
              ^family_catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
        IF prevalidate_free_result = osc$heap_free_valid THEN
          FREE p_physical_fmd IN family_catalog_locator.p_catalog_file^.catalog_heap;
        ELSE
          pfp$report_invalid_free (p_master_catalog_path, {p_cycle_number} NIL, 'FILE_MEDIA_DESCRIPTOR',
                'catalog', prevalidate_free_result, #OFFSET(p_physical_fmd));
          p_physical_fmd := NIL;
        IFEND;
        p_master_catalog_object^.object_entry.catalog_recreated_by_restore := TRUE;
        p_master_catalog_object^.object_entry.catalog_object_locator := catalog_object_locator;
        p_master_catalog_object^.object_entry.internal_object_name := catalog_object_locator.global_file_name;
        pfp$compute_checksum (^p_master_catalog_object^.object_entry, #SIZE (pft$object_entry),
              p_master_catalog_object^.checksum);
      IFEND;

      pfp$return_catalog (family_catalog_locator, local_status);
      family_catalog_active := NOT local_status.normal;
      pfp$process_unexpected_status (local_status);
      {
      { Obtain a pointer to the $system family catalog and set the
      { catalog_recreated_by_restore field to TRUE.
      {
      PUSH p_family_path: [1 .. pfc$family_path_index];
      p_family_path^ [pfc$set_path_index] := stv$system_set_name;
      p_family_path^ [pfc$family_path_index] := jmc$system_family;

      IF status.normal THEN
        valid_objects := $pft$object_selections [pfc$catalog_object];
        PUSH p_internal_path: [1 .. pfc$family_path_index];
        pfp$access_object (p_family_path^, pfc$write_access, authority, valid_objects, parent_charge_id,
              family_catalog_locator, p_family_object, p_internal_path^, permit_entry, status);
      IFEND;
      family_catalog_active := status.normal;

      IF status.normal THEN
        p_family_object^.object_entry.catalog_recreated_by_restore := TRUE;
        pfp$compute_checksum (^p_family_object^.object_entry, #SIZE (pft$object_entry),
              p_family_object^.checksum);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$system_catalog_recreated, '', status);
      IFEND;
    IFEND;

    IF master_catalog_active THEN
      pfp$return_catalog (master_catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    IF family_catalog_active THEN
      pfp$return_catalog (family_catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    pfv$allow_catalog_write := FALSE;
    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_recreate_system_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$r2_release_data', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_release_data
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         p_release_data_info: {i/o} ^pft$release_data_info;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_release_data;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      local_status: ost$status,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;

    /release_data/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL(process_non_local_exit);

      pfp$get_authority (path, NOT system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /release_data/;
      IFEND;

      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$file_object],
            parent_charge_id, catalog_locator, p_file_object, p_internal_path^, permit_entry, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /release_data/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      pfp$validate_file_permission (path, authority, permit_entry, $pft$permit_selections [pfc$control],
          - $pft$share_selections [], status);
      IF NOT status.normal THEN
        EXIT /release_data/;
      IFEND;

      pfp$validate_password (path, authority, password, p_file_object, status);
      IF NOT status.normal THEN
         EXIT /release_data/;
      IFEND;

      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
          catalog_locator.p_catalog_file, p_cycle_list);

      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
      IF NOT status.normal THEN
        EXIT /release_data/;
      IFEND;

      release_cycle_data (path, p_cycle, catalog_locator.p_catalog_file, p_release_data_info, status);
      IF NOT status.normal THEN
        EXIT /release_data/;
      IFEND;

    END /release_data/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;

  PROCEND pfp$r2_release_data;

?? TITLE := '  [XDCL, #GATE] pfp$r2_replace_archive_entry', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_replace_archive_entry (
        path: pft$complete_path;
        cycle_selector: pft$cycle_selector;
        archive_identification: pft$archive_identification;
        p_archive_array_entry: pft$p_archive_array_entry;
        p_amd: pft$p_amd;
    VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_replace_archive_entry;
    PROCEND initiate_non_local_exit;

    CONST
      system_privilege = TRUE;

    VAR
      archive_index: pft$archive_index,
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      file_path_index: integer,
      found: boolean,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      p_archive: ^pft$physical_archive,
      p_archive_entry: ^pft$archive_entry,
      p_archive_list: ^pft$archive_list,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_fs_path: ^fst$path,
      p_internal_path: ^pft$internal_path,
      p_old_physical_amd: ^pft$physical_amd,
      parent_charge_id: pft$charge_id,
      path_name: ost$string,
      permit_entry: pft$permit_entry,
      prevalidate_free_result: ost$prevalidate_free_result,
      process_non_local_exit: boolean,
      update_checksum: boolean,
      valid: boolean,
      validated_name: ost$name;

    syp$push_inhibit_job_recovery;

    /replace_archive_entry/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL(process_non_local_exit);
      update_checksum := FALSE;

      pfp$get_authority (path, NOT system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /replace_archive_entry/;
      IFEND;

      pfp$validate_ownership (authority, path, status);
      IF NOT status.normal THEN
        EXIT /replace_archive_entry/;
      IFEND;

      file_path_index := UPPERBOUND (path);
      PUSH p_internal_path: [1 .. file_path_index];
      pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$file_object],
            parent_charge_id, catalog_locator, p_file_object, p_internal_path^, permit_entry, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        EXIT /replace_archive_entry/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
          catalog_locator.p_catalog_file, p_cycle_list);

      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
      IF NOT status.normal THEN
        EXIT /replace_archive_entry/;
      IFEND;

      IF p_cycle^.cycle_entry.archive_list_locator.archive_count = 0 THEN
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$empty_archive_list,
            p_fs_path^ (1, fs_path_size), status);
        EXIT /replace_archive_entry/;
      IFEND;

      pfp$build_archive_list_pointer (p_cycle^.cycle_entry.archive_list_locator,
          catalog_locator.p_catalog_file, p_archive_list);
      found := FALSE;

    /search_archive_list/
      FOR archive_index := 1 TO p_cycle^.cycle_entry.archive_list_locator.archive_count DO
        p_archive_entry := ^p_archive_list^[archive_index].archive_entry;
        IF (p_archive_entry^.archive_identification.application_identifier =
            archive_identification.application_identifier) THEN
          IF (p_archive_entry^.archive_identification.media_identifier.media_device_class =
                archive_identification.media_identifier.media_device_class) THEN
            IF (p_archive_entry^.archive_identification.media_identifier.media_volume_identifier =
                  archive_identification.media_identifier.media_volume_identifier) THEN
              found := TRUE;
              pfp$build_amd_pointer (p_archive_entry^.amd_locator, catalog_locator.p_catalog_file,
                  p_old_physical_amd);
              p_archive := ^p_archive_list^[archive_index];
              pfp$r2_build_archive_entry (p_archive_array_entry^.archive_identification,
                  p_archive_array_entry, p_amd, catalog_locator.p_catalog_file, p_archive, status);
              IF NOT status.normal THEN
                EXIT /replace_archive_entry/;
              ELSE
                update_checksum := TRUE;
              IFEND;

              IF p_old_physical_amd <> NIL THEN
                osp$prevalidate_free ((#OFFSET(p_old_physical_amd) -
                      #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
                      ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
                IF prevalidate_free_result = osc$heap_free_valid THEN
                  FREE p_old_physical_amd IN catalog_locator.p_catalog_file^.catalog_heap;
                ELSE
                  pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number,
                        'ARCHIVE_MEDIA_DESCRIPTOR', 'file', prevalidate_free_result,
                        #OFFSET(p_old_physical_amd));
                  p_old_physical_amd := NIL;
                IFEND;
              IFEND;
              EXIT /search_archive_list/;
            IFEND;
          IFEND;
        IFEND;
      FOREND;

      IF NOT found THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_archive_ident,
            archive_identification.application_identifier, status);
        EXIT /replace_archive_entry/;
      IFEND;

    END /replace_archive_entry/;

    IF update_checksum THEN
      pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
    IFEND;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;

  PROCEND pfp$r2_replace_archive_entry;

?? TITLE := '  [XDCL, #GATE] pfp$r2_replace_rem_media_fmd', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_replace_rem_media_fmd
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         p_file_media_descriptor: ^SEQ ( * );
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_replace_rem_media_fmd;
    PROCEND initiate_non_local_exit;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      date_time: ost$date_time,
      local_status: ost$status,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;
    process_non_local_exit := FALSE;
    #SPOIL(process_non_local_exit);

    pfp$get_authority (path, {system_privilege} FALSE, authority, status);
    IF status.normal THEN
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$file_object],
            parent_charge_id, catalog_locator, p_file_object, p_internal_path^, permit_entry, status);
    IFEND;
    catalog_active := status.normal;
    osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

    IF status.normal THEN
      pfp$validate_default_password (path, authority, password_selector, p_file_object, status);
    IFEND;

    IF status.normal THEN
      pfp$validate_file_permission (path, authority, permit_entry, $pft$permit_selections [pfc$control],
            - $pft$share_selections [], status);
    IFEND;

    IF status.normal THEN
      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
    IFEND;

    IF status.normal THEN
      pfi$store_file_media_descriptor (p_file_media_descriptor, catalog_locator.p_catalog_file, p_cycle,
            status);
    IFEND;

    osp$disestablish_cond_handler;
    IF catalog_active THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_replace_rem_media_fmd;

?? TITLE := '  [XDCL, #GATE] pfp$r2_resolve_path', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_resolve_path
    (    path: pft$complete_path;
         system_privilege: boolean;
     VAR cycle_reference: {i/o} fst$cycle_reference;
     VAR path_resolution: fst$path_resolution;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;

      process_non_local_exit := TRUE;
      #SPOIL (process_non_local_exit);
      EXIT pfp$r2_resolve_path;
    PROCEND initiate_non_local_exit;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      cycle_number: pft$cycle_number,
      cycle_selector: pft$cycle_selector,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_fs_path: ^fst$path,
      p_internal_path: ^pft$internal_path,
      p_object: ^pft$physical_object,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    syp$push_inhibit_job_recovery;

  /resolve_path/
    BEGIN
      catalog_active := FALSE;
      process_non_local_exit := FALSE;
      #SPOIL (process_non_local_exit);

      pfp$get_authority (path, system_privilege, authority, status);
      IF NOT status.normal THEN
        EXIT /resolve_path/;
      IFEND;

      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$read_access, authority, $pft$object_selections
            [pfc$file_object, pfc$catalog_object], parent_charge_id, catalog_locator, p_object,
            p_internal_path^, permit_entry, status);
      catalog_active := status.normal;
      IF NOT status.normal THEN
        CASE status.condition OF
        = pfe$unknown_item =
          CASE cycle_reference.specification OF
          = fsc$cycle_omitted =
            cycle_reference.specification := fsc$cycle_number;
            cycle_reference.cycle_number := 1;
            path_resolution := fsc$path_does_not_exist;
            status.normal := TRUE;

          = fsc$high_cycle, fsc$low_cycle =
            PUSH p_fs_path;
            pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_permanent_file,
                  p_fs_path^ (1, fs_path_size), status);

          = fsc$next_cycle =
            cycle_reference.specification := fsc$cycle_number;
            cycle_reference.cycle_number := 1;
            path_resolution := fsc$new_file_path;
            status.normal := TRUE;

          = fsc$cycle_number =
            {
            { The following IF condition and entire ELSE clause should be removed
            { once pf supports fst$cycle_number.
            {
            IF cycle_reference.cycle_number <= pfc$maximum_cycle_number THEN
              path_resolution := fsc$new_file_path;
              status.normal := TRUE;
            ELSE
              osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_cycle_number, '', status);
              osp$append_status_integer (osc$status_parameter_delimiter, cycle_reference.cycle_number, 10,
                    FALSE, status);
            IFEND;

          ELSE
            osp$set_status_abnormal (pfc$permanent_file_manager_id, fse$system_error,
                  'Invalid cycle specification.', status);
            #KEYPOINT (osk$unusual, 0, fsk$invalid_cycle_specification);
          CASEND;

        ELSE
          ;
        CASEND;
        EXIT /resolve_path/;
      IFEND;

      osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

      CASE p_object^.object_entry.object_type OF
      = pfc$file_object =
        pfp$build_cycle_list_pointer (p_object^.object_entry.cycle_list_locator,
              catalog_locator.p_catalog_file, p_cycle_list);
        CASE cycle_reference.specification OF
        = fsc$cycle_omitted, fsc$high_cycle =
          cycle_selector.cycle_option := pfc$highest_cycle;
          pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
          IF status.normal THEN
            cycle_reference.specification := fsc$cycle_number;
            cycle_reference.cycle_number := p_cycle^.cycle_entry.cycle_number;
            path_resolution := fsc$cycle_path;
          IFEND;

        = fsc$low_cycle =
          cycle_selector.cycle_option := pfc$lowest_cycle;
          pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
          IF status.normal THEN
            cycle_reference.specification := fsc$cycle_number;
            cycle_reference.cycle_number := p_cycle^.cycle_entry.cycle_number;
            path_resolution := fsc$cycle_path;
          IFEND;

        = fsc$next_cycle =
          cycle_selector.cycle_option := pfc$highest_cycle;
          pfp$determine_new_cycle_number (path, p_cycle_list, cycle_selector, cycle_number, status);
          IF status.normal THEN
            cycle_reference.specification := fsc$cycle_number;
            cycle_reference.cycle_number := cycle_number;
            path_resolution := fsc$new_cycle_path;
          IFEND;

        = fsc$cycle_number =
          {
          { The following IF condition and entire ELSE clause should be removed
          { once pf supports fst$cycle_number.
          {
          IF cycle_reference.cycle_number <= pfc$maximum_cycle_number THEN
            cycle_selector.cycle_option := pfc$specific_cycle;
            cycle_selector.cycle_number := cycle_reference.cycle_number;
            pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
            IF status.normal THEN
              path_resolution := fsc$cycle_path;
            ELSEIF status.condition = pfe$unknown_cycle THEN
              path_resolution := fsc$new_cycle_path;
              status.normal := TRUE;
            IFEND;
          ELSE
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_cycle_number, '', status);
            osp$append_status_integer (osc$status_parameter_delimiter, cycle_reference.cycle_number, 10,
                  FALSE, status);
          IFEND;
        ELSE
          osp$set_status_abnormal (pfc$permanent_file_manager_id, fse$system_error,
                'Invalid cycle specification.', status);
          #KEYPOINT (osk$unusual, 0, fsk$invalid_cycle_specification);
        CASEND;

      = pfc$catalog_object =
        IF cycle_reference.specification = fsc$cycle_omitted THEN
          path_resolution := fsc$catalog_path;
        ELSE
          PUSH p_fs_path;
          pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, fse$catalogs_do_not_have_cycles,
                p_fs_path^ (1, fs_path_size), status);
        IFEND;

      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'Unexpected object type.', status);
        #KEYPOINT (osk$unusual, 0, pfk$invalid_object_entry);
      CASEND;
    END /resolve_path/;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_resolve_path;

?? TITLE := '  [XDCL, #GATE] pfp$r2_save_released_file_label', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_save_released_file_label
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         p_file_label: {input^} ^fmt$file_label;
         validation_ring: ost$valid_ring;
         update_cycle_statistics: boolean;
     VAR p_save_label_audit_info: {i/o} ^pft$save_label_audit_info;
     VAR status: ost$status);

*copy pfp$r2_condition_handler

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$r2_save_released_file_label;
    PROCEND initiate_non_local_exit;

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      cycle_formerly_opened_info: fmt$cycle_formerly_opened_info,
      date_time: ost$date_time,
      file_previously_opened: boolean,
      local_status: ost$status,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      p_static_label_header: ^fmt$static_label_header,
      p_local_file_label: ^fmt$file_label,
      p_physical_file_label: ^pft$physical_file_label,
      p_stored_file_label: ^pft$physical_file_label,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean,
      static_label_attributes: bat$static_label_attributes,
      valid_checksum: boolean;

    syp$push_inhibit_job_recovery;

    process_non_local_exit := FALSE;
    #SPOIL(process_non_local_exit);

    pfp$get_authority (path, {system_privilege} FALSE, authority, status);
    IF status.normal THEN
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$write_access, authority, $pft$object_selections [pfc$file_object],
            parent_charge_id, catalog_locator, p_file_object, p_internal_path^, permit_entry, status);
    IFEND;
    catalog_active := status.normal;

    osp$establish_condition_handler (^pfp$r2_condition_handler, {block_exit} TRUE);

    IF status.normal THEN
      pfp$validate_default_password (path, authority, password_selector, p_file_object, status);
    IFEND;

    IF status.normal THEN
      pfp$validate_file_permission (path, authority, permit_entry, $pft$permit_selections [pfc$control],
            - $pft$share_selections [], status);
    IFEND;

    IF status.normal THEN
      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
    IFEND;

    IF status.normal THEN
      p_local_file_label := p_file_label;
      RESET p_local_file_label;
      fmp$validate_system_label (p_local_file_label^, validation_ring, valid_checksum, status);

      IF status.normal THEN
        RESET p_local_file_label;
        NEXT p_physical_file_label: [[REP #SIZE (p_local_file_label^) - #SIZE (pft$checksum) OF cell]]
              IN p_local_file_label;

        IF p_save_label_audit_info <> NIL THEN
          IF #SIZE (fmt$static_label_header) <= #SIZE (p_physical_file_label^.file_label) THEN
            p_local_file_label := ^p_physical_file_label^.file_label;
            RESET p_local_file_label;
            NEXT p_static_label_header IN p_local_file_label;

            IF (p_static_label_header = NIL) OR
                  (p_static_label_header^.unique_character <> fmc$unique_label_id) THEN
              p_save_label_audit_info := NIL;
            ELSE
              p_save_label_audit_info^.file_path_count := 0; { The path is available in ring 3.
              p_save_label_audit_info^.cycle_selector.cycle_option := pfc$specific_cycle;
              p_save_label_audit_info^.cycle_selector.cycle_number := p_cycle^.cycle_entry.cycle_number;

              IF p_cycle^.cycle_entry.device_information.device_class_defined THEN
                pfp$convert_device_class_to_rm (p_cycle^.cycle_entry.device_information.device_class,
                      p_save_label_audit_info^.device_class);
              ELSE
                p_save_label_audit_info^.device_class := rmc$mass_storage_device;
              IFEND;

              p_save_label_audit_info^.ownership := authority.ownership;

              IF (fmc$file_access_procedure <= p_static_label_header^.highest_attribute_present) AND
                    p_static_label_header^.attribute_present [fmc$file_access_procedure] THEN
                fsp$expand_file_label (p_local_file_label, static_label_attributes, file_previously_opened,
                      local_status);
                IF local_status.normal THEN
                  p_save_label_audit_info^.fap_audit_info.audit := TRUE;
                  p_save_label_audit_info^.fap_audit_info.fap_name :=
                        static_label_attributes.file_access_procedure;
                ELSE
                  p_save_label_audit_info^.fap_audit_info.audit := FALSE;
                IFEND;
              ELSE
                p_save_label_audit_info^.fap_audit_info.audit := FALSE;
              IFEND;

              IF p_static_label_header^.file_previously_opened THEN
                p_save_label_audit_info^.ring_audit_info.audit := TRUE;
                p_save_label_audit_info^.ring_audit_info.ring_attributes :=
                      p_static_label_header^.ring_attributes;
              ELSE
                p_save_label_audit_info^.ring_audit_info.audit := FALSE;
              IFEND;

              IF (NOT p_save_label_audit_info^.fap_audit_info.audit) AND
                    NOT p_save_label_audit_info^.ring_audit_info.audit THEN
                p_save_label_audit_info := NIL;
              IFEND;
            IFEND;
          ELSE
            p_save_label_audit_info := NIL;
          IFEND;
        IFEND;

        IF valid_checksum THEN
          p_stored_file_label := NIL;
          store_file_label (path, ^p_physical_file_label^.file_label, catalog_locator.p_catalog_file, p_cycle,
                p_stored_file_label, status);
        ELSE
          osp$set_status_condition (ame$damaged_file_attributes, status);
        IFEND;
      ELSE
        p_save_label_audit_info := NIL;
      IFEND;
    ELSE
      p_save_label_audit_info := NIL;
    IFEND;

    IF status.normal AND update_cycle_statistics THEN
      pmp$get_compact_date_time (date_time, local_status);
      pfp$process_unexpected_status (local_status);
      p_cycle^.cycle_entry.cycle_statistics.modification_date_time := date_time;

      pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
    IFEND;

    osp$disestablish_cond_handler;
    IF catalog_active THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_save_released_file_label;

?? TITLE := '  [XDCL, #GATE] pfp$r2_validate_catalog_exists', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_validate_catalog_exists
    (    catalog_path: pft$complete_path;
     VAR status: ost$status);

    CONST
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_locator: pft$catalog_locator,
      p_internal_path: ^pft$internal_path,
      p_object: ^pft$physical_object,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry;

    syp$push_inhibit_job_recovery;
    pfp$get_authority (catalog_path, NOT system_privilege, authority, status);

    IF status.normal THEN
      PUSH p_internal_path: [1 .. UPPERBOUND (catalog_path)];
      pfp$access_object (catalog_path, pfc$read_access, authority,
            $pft$object_selections [pfc$catalog_object], parent_charge_id, catalog_locator, p_object,
            p_internal_path^, permit_entry, status);
    IFEND;

    IF status.normal THEN
      pfp$return_catalog (catalog_locator, status);
    IFEND;
    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_validate_catalog_exists;

?? TITLE := '  [XDCL, #GATE] pfp$r2_validate_password', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$r2_validate_password
    (    path: pft$complete_path;
         password: pft$password;
     VAR status: ost$status);

    CONST
      system_privilege = TRUE;

    VAR
      authority: pft$authority,
      catalog_locator: pft$catalog_locator,
      local_status: ost$status,
      p_file_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path,
      parent_charge_id: pft$charge_id,
      permit_entry: pft$permit_entry;

    syp$push_inhibit_job_recovery;
    pfp$get_authority (path, NOT system_privilege, authority, status);

    IF status.normal AND NOT (pfc$system_owner IN authority.ownership) AND
          NOT (pfc$family_owner IN authority.ownership) THEN
      PUSH p_internal_path: [1 .. UPPERBOUND (path)];
      pfp$access_object (path, pfc$read_access, authority,
            $pft$object_selections [pfc$file_object, pfc$purged_file_object], parent_charge_id,
            catalog_locator, p_file_object, p_internal_path^, permit_entry, status);
      IF status.normal THEN
        pfp$validate_password (path, authority, password, p_file_object, status);
        pfp$return_catalog (catalog_locator, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$r2_validate_password;

?? TITLE := '  [XDCL] pfp$reattach_permanent_file', EJECT ??
*copy pfh$reattach_permanent_file

  PROCEDURE [XDCL] pfp$reattach_permanent_file
    (    apfid: pft$attached_permanent_file_id;
         device_class: rmt$device_class;
         internal_cycle_name: pft$internal_name;
         mainframe_id: pmt$binary_mainframe_id;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
     VAR new_sfid: gft$system_file_identifier;
     VAR status: ost$status);

    PROCEDURE reattach_perm_file_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           p_sfsa: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        variant_path: pft$variant_path,
        status_id: ost$status_identifier,
        local_status: ost$status;

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := p_attached_pf_entry^.p_external_path;

      IF NOT process_non_local_exit THEN
        pfp$log_ascii ('***PF Condition Handler***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, {critical_message} FALSE, local_status);
        pfp$log_path (variant_path, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
              {critical_message} FALSE, local_status);
      IFEND;

      CASE condition.selector OF
      = pmc$system_conditions, pmc$block_exit_processing, mmc$segment_access_condition =
        IF process_non_local_exit THEN
          RETURN;
        IFEND;

        IF catalog_locator.attached THEN
          catalog_locator.abort_catalog_operation := TRUE;
          pfp$return_catalog (catalog_locator, local_status);
          IF NOT local_status.normal THEN
            pfp$report_system_error (local_status);
          IFEND;
        IFEND;

        syp$pop_inhibit_job_recovery;

        IF apfid_locked THEN
          pfp$release_locked_apfid (apfid.attached_pf_table_index, local_status);
        IFEND;

        osp$set_status_from_condition (status_id, condition, p_sfsa, local_status, handler_status);
        osp$recoverable_system_error ('UNEXPECTED STATUS', ^local_status);

        status := local_status;
        initiate_non_local_exit;


      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pfp$log_ascii ('***Recover Files***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
                pmc$msg_origin_system, {critical_message} FALSE, local_status);
         {syp$invalidate_open_sfid (catalog_locator.system_file_id, local_status);
          initiate_non_local_exit;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;

    PROCEND reattach_perm_file_handler;

    PROCEDURE initiate_non_local_exit;
      process_non_local_exit := TRUE;
      #SPOIL(process_non_local_exit);
      EXIT pfp$reattach_permanent_file;
    PROCEND initiate_non_local_exit;


    CONST
      system_privilege = TRUE;

    VAR
      apfid_locked: boolean,
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      charge_id: pft$charge_id,
      cycle_damage_symptoms: fst$cycle_damage_symptoms,
      display_status: ost$status,
      file_damaged: boolean,
      file_info: dmt$file_information,
      flush_catalog_pages: boolean,
      fmd_modified: boolean,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      p_attached_pf_entry: ^pft$attached_pf_entry,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_fs_path: ^fst$path,
      path_string: ost$string,
      permit_entry: pft$permit_entry,
      process_non_local_exit: boolean;

    #KEYPOINT (osk$entry, 0, pfk$reattach_permanent_file);
    syp$push_inhibit_job_recovery;
    apfid_locked := FALSE;
    #SPOIL(apfid_locked);
    catalog_active := FALSE;
    process_non_local_exit := FALSE;
    #SPOIL(process_non_local_exit);
    status.normal := TRUE;

    IF apfid.family_location = pfc$server_mainframe THEN
      IF device_class = rmc$mass_storage_device THEN
        pfp$reattach_server_file (apfid, internal_cycle_name, mainframe_id,
              usage_selections, share_selections, new_sfid, status);
      IFEND;
      syp$pop_inhibit_job_recovery;
      #KEYPOINT (osk$exit, 0, pfk$reattach_permanent_file);
      RETURN;
    IFEND;

    IF status.normal THEN
      pfp$lock_apfid (apfid.attached_pf_table_index, p_attached_pf_entry, status);
      apfid_locked := status.normal;
      #SPOIL(apfid_locked);
    IFEND;

    IF status.normal AND (internal_cycle_name <> p_attached_pf_entry^.internal_cycle_path.cycle_name) THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'The global file name (gfn) from FM does not match the gfn in pfp$reattach_permanent_file.',
            status);
    IFEND;

    IF status.normal THEN
      pfp$get_authority (p_attached_pf_entry^.p_external_path^, NOT system_privilege, authority, status);
    IFEND;

    IF status.normal THEN
    /reattach_permanent_file/
      WHILE TRUE DO
        pfp$internal_access_object (p_attached_pf_entry^.p_external_path^ [pfc$set_path_index],
              p_attached_pf_entry^.internal_cycle_path.path, pfc$write_access, authority,
              {extract_permits} TRUE,
              (p_attached_pf_entry^.p_external_path^ [pfc$family_path_index] <> osv$system_family_name),
              p_file_object, catalog_locator, permit_entry, status);
        IF status.normal OR (status.condition <> pfe$catalog_access_retry) THEN
          EXIT /reattach_permanent_file/;
        ELSE
          syp$pop_inhibit_job_recovery;
          pfp$catalog_access_retry_wait ('PFP$REATTACH_PERMANENT_FILE');
          syp$push_inhibit_job_recovery;
        IFEND;
      WHILEND /reattach_permanent_file/;
    IFEND;
    catalog_active := status.normal;

    IF catalog_active THEN
      osp$establish_condition_handler (^reattach_perm_file_handler, {block_exit} TRUE);
    IFEND;

    IF p_file_object = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'Unable to locate file in pfp$reattach_permanent_file.', status);
    IFEND;

    IF status.normal THEN
      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);
      internal_locate_cycle (p_cycle_list, internal_cycle_name, p_cycle, status);
    IFEND;

    IF status.normal THEN
      check_cycle_damage (p_attached_pf_entry^.p_external_path^, p_cycle^.cycle_entry,
            p_attached_pf_entry^.allowed_exception_conditions, cycle_damage_symptoms, status);
    IFEND;

    IF status.normal AND (device_class = rmc$mass_storage_device) THEN
      dm_attach_file (p_attached_pf_entry^.p_external_path^,
            catalog_locator.p_catalog_file, p_attached_pf_entry^.usage_selections,
            p_attached_pf_entry^.share_selections, p_cycle, new_sfid, file_damaged, status);

      IF status.normal THEN
        IF pfp$share_for_write (p_attached_pf_entry^.share_selections) THEN
          IF file_damaged = p_attached_pf_entry^.media_image_inconsistent THEN
            IF p_attached_pf_entry^.media_damage_detection_enabled THEN
              dmp$enable_damage_detection (new_sfid, internal_cycle_name, status);
            IFEND;
          ELSE
            PUSH p_fs_path;
            pfp$convert_pf_path_to_fs_path (p_attached_pf_entry^.p_external_path^, p_fs_path^, fs_path_size);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$media_image_inconsistent,
                  p_fs_path^ (1, fs_path_size), status);
          IFEND;
        ELSE { Attached for exclusive write access.
          IF (NOT file_damaged) OR (fsc$media_image_inconsistent IN
                p_attached_pf_entry^.allowed_exception_conditions) THEN
            dmp$change_sft_damage_detection (new_sfid, p_attached_pf_entry^.media_damage_detection_enabled,
                  internal_cycle_name, status);
            IF status.normal THEN
              IF p_attached_pf_entry^.media_damage_detection_enabled AND
                    NOT p_attached_pf_entry^.media_image_inconsistent THEN
                IF file_damaged THEN
                  dmp$change_sft_file_damaged (new_sfid, {file_damaged} FALSE, internal_cycle_name, status);
                ELSE
                  dmp$enable_damage_detection (new_sfid, internal_cycle_name, status);
                IFEND;
              IFEND;
            IFEND;
          ELSEIF p_attached_pf_entry^.media_damage_detection_enabled AND
                NOT p_attached_pf_entry^.media_image_inconsistent THEN
            dmp$change_sft_file_damaged (new_sfid, {file_damaged} FALSE, internal_cycle_name, status);
            IF status.normal THEN
              dmp$change_sft_damage_detection (new_sfid, p_attached_pf_entry^.
                    media_damage_detection_enabled, internal_cycle_name, status);
            IFEND;
          IFEND;
        IFEND;

        IF NOT status.normal THEN
          pfp$detach_permanent_file (^p_attached_pf_entry^.p_external_path^, new_sfid,
                p_attached_pf_entry^.usage_selections, {catalog_update_allowed} TRUE, p_cycle,
                catalog_locator.p_catalog_file, fmd_modified, file_info, local_status);
          pfp$process_unexpected_status (local_status);
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      p_attached_pf_entry^.sfid_status.recovery_state := pfc$attached_pf_normal;
      p_attached_pf_entry^.sfid_status.sfid := new_sfid;
      IF p_attached_pf_entry^.update_catalog THEN
        pfp$increment_usage_counts (p_attached_pf_entry^.p_external_path^,
              p_attached_pf_entry^.usage_selections, p_attached_pf_entry^.share_selections, mainframe_id,
              catalog_locator.p_catalog_file, flush_catalog_pages, p_cycle^.cycle_entry, status);
        pfp$process_unexpected_status (status);
        pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
      IFEND;

      pfp$unlock_apfid (apfid.attached_pf_table_index, p_attached_pf_entry, status);
      pfp$process_unexpected_status (status);
    ELSEIF apfid_locked THEN
      IF status.condition = pfe$catalog_access_retry THEN
        pfp$unlock_apfid (apfid.attached_pf_table_index, p_attached_pf_entry, local_status);
        pfp$process_unexpected_status (local_status);
      ELSE
        pfp$convert_cycle_path_to_strng (p_attached_pf_entry^.p_external_path^,
              p_attached_pf_entry^.cycle_number, path_string);
        IF status.condition = pfe$pf_system_error THEN
          osp$append_status_parameter (osc$status_parameter_delimiter,
                path_string.value (1, path_string.size), status);
        ELSE
          osp$log_job_recovery_message (path_string.value (1, path_string.size), display_status);
        IFEND;
        osp$log_job_recovery_status (status, display_status);
        FREE p_attached_pf_entry^.p_external_path IN pfv$p_p_job_heap^^;
        FREE p_attached_pf_entry IN pfv$p_p_job_heap^^;
        pfp$release_locked_apfid (apfid.attached_pf_table_index, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;
    IFEND;

    IF catalog_active THEN
      osp$disestablish_cond_handler;
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    syp$pop_inhibit_job_recovery;
    #KEYPOINT (osk$exit, 0, pfk$reattach_permanent_file);
  PROCEND pfp$reattach_permanent_file;

?? TITLE := '  [XDCL] pfp$reattach_reserved_cycles', EJECT ??

  PROCEDURE [XDCL] pfp$reattach_reserved_cycles
    (    mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

    VAR
      authority: pft$authority,
      catalog_active: boolean,
      catalog_locator: pft$catalog_locator,
      catalog_permit_entry: pft$permit_entry,
      charge_id: pft$charge_id,
      cycle_index: pft$object_index,
      file_damaged: boolean,
      file_info: dmt$file_information,
      fmd_modified: boolean,
      i: pft$catalog_path_index,
      local_status: ost$status,
      new_sfid: gft$system_file_identifier,
      object_index: pft$object_index,
      old_sfid: gft$system_file_identifier,
      p_complete_path: ^pft$complete_path,
      p_cycle: ^pft$physical_cycle,
      p_cycle_list: ^pft$cycle_list,
      p_file_object: ^pft$physical_object,
      p_internal_path: ^pft$internal_path;

    IF pfv$reserved_cycle_info.p_catalog_path = NIL THEN
      RETURN;
    IFEND;

    syp$push_inhibit_job_recovery;
    pfp$get_authority (pfv$reserved_cycle_info.p_catalog_path^, {system_privilege} TRUE, authority, status);
    IF status.normal THEN
      PUSH p_internal_path: [1 .. UPPERBOUND (pfv$reserved_cycle_info.p_catalog_path^)];
      pfp$get_catalog (pfv$reserved_cycle_info.p_catalog_path^, pfc$write_access, authority, p_internal_path^,
            charge_id, catalog_permit_entry, catalog_locator, status);
      catalog_active := status.normal;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_complete_path: [1 .. UPPERBOUND (pfv$reserved_cycle_info.p_catalog_path^) + 1];
    FOR i := 1 TO UPPERBOUND (pfv$reserved_cycle_info.p_catalog_path^) DO
      p_complete_path^ [i] := pfv$reserved_cycle_info.p_catalog_path^ [i];
    FOREND;

  /reattach_reserved_cycles/
    FOR object_index := 1 TO pfv$reserved_cycle_info.number_of_cycles_reserved DO
      pfp$locate_object (pfv$reserved_cycle_info.p_reserved_cycles^ [object_index].external_object_name,
            $pft$object_selections [pfc$file_object, pfc$purged_file_object],
            catalog_locator.object_list_descriptor, p_file_object);
      IF (p_file_object = NIL) OR (pfv$reserved_cycle_info.p_reserved_cycles^ [object_index].
            internal_object_name <> p_file_object^.object_entry.internal_object_name) THEN
        pfp$internal_locate_object (catalog_locator.object_list_descriptor.p_object_list,
              pfv$reserved_cycle_info.p_reserved_cycles^ [object_index].internal_object_name, p_file_object);
        IF p_file_object = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
                'Unable to locate reserved cycle.', local_status);
          EXIT /reattach_reserved_cycles/;
        IFEND;
      IFEND;

      pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator,
            catalog_locator.p_catalog_file, p_cycle_list);

      p_cycle := NIL;

    /locate_reserved_cycle/
      FOR cycle_index := 1 TO UPPERBOUND (p_cycle_list^) DO
        IF (p_cycle_list^ [cycle_index].cycle_entry.entry_type = pfc$normal_cycle_entry) AND
              (p_cycle_list^ [cycle_index].cycle_entry.internal_cycle_name =
              pfv$reserved_cycle_info.p_reserved_cycles^ [object_index].internal_cycle_name) THEN
          p_cycle := ^p_cycle_list^ [cycle_index];
          EXIT /locate_reserved_cycle/;
        IFEND;
      FOREND /locate_reserved_cycle/;

      IF p_cycle = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'Unable to locate reserved cycle.', local_status);
        EXIT /reattach_reserved_cycles/;
      ELSE
        p_complete_path^ [UPPERBOUND (p_complete_path^)] := p_file_object^.object_entry.external_object_name;
        dm_attach_file (p_complete_path^, catalog_locator.p_catalog_file, $pft$usage_selections [pfc$read],
              $pft$share_selections [pfc$read, pfc$execute], p_cycle, new_sfid, file_damaged, status);
        IF status.normal THEN
          old_sfid := pfv$reserved_cycle_info.p_reserved_cycles^ [object_index].system_file_id;
          syp$replace_sfid (old_sfid, new_sfid, mmc$sas_allow_access, status);
          IF status.normal THEN
            pfv$reserved_cycle_info.p_reserved_cycles^ [object_index].system_file_id := new_sfid;
            pfp$increment_usage_counts (p_complete_path^, $pft$usage_selections [pfc$read],
                  $pft$share_selections [pfc$read, pfc$execute], mainframe_id, catalog_locator.p_catalog_file,
                  catalog_locator.flush_catalog_pages, p_cycle^.cycle_entry, status);
            pfp$compute_checksum (^p_cycle^.cycle_entry, #SIZE (p_cycle^.cycle_entry), p_cycle^.checksum);
          ELSE
            syp$invalidate_open_sfid (old_sfid, local_status);
          IFEND;

          IF NOT status.normal THEN
            {
            {Detach file from device manager.
            {
            pfp$detach_permanent_file ({p_path} NIL, new_sfid, $pft$usage_selections [pfc$read],
                  {catalog_update_allowed} TRUE, p_cycle, catalog_locator.p_catalog_file, fmd_modified,
                  file_info, local_status);
          IFEND;
        IFEND;
      IFEND;
    FOREND /reattach_reserved_cycles/;

    IF catalog_active THEN
      pfp$return_catalog (catalog_locator, local_status);
      pfp$process_unexpected_status (local_status);
    IFEND;

    IF NOT status.normal THEN
      {
      {Upon task termination pfp$detach_reserved_cycles should detach only those
      {cycles that were reattached successfully.
      {
      pfv$reserved_cycle_info.number_of_cycles_reserved := object_index - 1;
      pfp$report_unexpected_status (status);
    IFEND;

    syp$pop_inhibit_job_recovery;
  PROCEND pfp$reattach_reserved_cycles;

?? TITLE := '  [XDCL] pfp$report_invalid_free', EJECT ??

  PROCEDURE [XDCL] pfp$report_invalid_free
    (    p_path: ^pft$complete_path;
         p_cycle_number: ^pft$cycle_number;
         free_object: string ( * <= osc$max_string_size);
         file_or_catalog: string ( * <= osc$max_string_size);
         prevalidate_free_result: ost$prevalidate_free_result;
         catalog_offset: ost$halfword);

    VAR
      free_result_string: ost$string,
      free_status: ost$status,
      fs_path_size: fst$path_size,
      ignore_status: ost$status,
      p_fs_path: ^fst$path,
      p_path_string: ^ost$string;

      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_free, free_object,
            free_status);
      osp$append_status_parameter (osc$status_parameter_delimiter, file_or_catalog, free_status);

      IF p_cycle_number <> NIL THEN
        IF p_path <> NIL THEN
          PUSH p_path_string;
          pfp$convert_cycle_path_to_strng (p_path^, p_cycle_number^, p_path_string^);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_path_string^.
                value (1, p_path_string^.size), free_status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter, 'of unknown path', free_status);
        IFEND;
      ELSE
        IF p_path <> NIL THEN
          PUSH p_fs_path;
          pfp$convert_pf_path_to_fs_path (p_path^, p_fs_path^, fs_path_size);
          osp$append_status_parameter (osc$status_parameter_delimiter, p_fs_path^ (1, fs_path_size),
                free_status);
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter, 'of unknown path', free_status);
        IFEND;
      IFEND;

      free_result_string.value := prevalidate_free_result_strings [prevalidate_free_result].value;
      free_result_string.size := prevalidate_free_result_strings [prevalidate_free_result].size;
      osp$append_status_parameter (osc$status_parameter_delimiter,
            free_result_string.value (1, free_result_string.size), free_status);
      osp$append_status_integer (osc$status_parameter_delimiter, catalog_offset, {radix} 16,
            include_radix, free_status);
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], free_status,
            ignore_status);
      pfp$report_unexpected_status (free_status);

  PROCEND pfp$report_invalid_free;


?? TITLE := '  [XDCL] pfp$return_permanent_file', EJECT ??
*copy pfh$return_permanent_file

  PROCEDURE [XDCL] pfp$return_permanent_file
    (    apfid: pft$attached_permanent_file_id;
         system_file_id: gft$system_file_identifier;
         device_class: rmt$device_class;
         usage_selections: pft$usage_selections;
     VAR status: ost$status);

    VAR
      authority: pft$authority,
      bytes_allocated_change: sft$counter,
      mainframe_id: pmt$binary_mainframe_id;

    #KEYPOINT (osk$entry, 0, pfk$return_permanent_file);
    status.normal := TRUE;

    IF apfid.family_location = pfc$server_mainframe THEN
      pfp$r2_df_client_return (apfid, system_file_id, device_class, usage_selections, authority,
            bytes_allocated_change, status);
    ELSE { local mainframe
      pmp$get_pseudo_mainframe_id (mainframe_id);
      pfp$internal_return_file (apfid.attached_pf_table_index, mainframe_id, authority,
            bytes_allocated_change, status);
    IFEND;

    IF status.normal AND (pfc$master_catalog_owner IN authority.ownership) AND
          (bytes_allocated_change < 0) THEN
      sfp$accumulate_file_space (sfc$perm_file_space_limit, bytes_allocated_change);
    IFEND;

    #KEYPOINT (osk$exit, 0, pfk$return_permanent_file);
  PROCEND pfp$return_permanent_file;

?? TITLE := '  [XDCL] pfp$save_file_label', EJECT ??
*copy pfh$save_file_label

  PROCEDURE [XDCL] pfp$save_file_label
    (    apfid: pft$attached_permanent_file_id;
         p_file_label: {input} fmt$p_file_label;
         required_permission: pft$permit_options;
     VAR status: ost$status);

    VAR
      p_complete_path: ^pft$complete_path,
      p_save_label_audit_info: ^pft$save_label_audit_info,
      p_save_file_label_audit_seq: ^SEQ ( * ),
      variant_path: pft$variant_path;

    #KEYPOINT (osk$entry, 0, pfk$save_file_label);
    syp$push_inhibit_job_recovery;

    IF sfp$auditing_operation (sfc$ao_fs_change_attribute) THEN
      PUSH p_save_file_label_audit_seq: [[pft$save_label_audit_info,
            REP UPPERVALUE (pft$file_path_count) OF pft$name]];
    ELSE
      p_save_file_label_audit_seq := NIL;
    IFEND;

    IF apfid.family_location = pfc$server_mainframe THEN
      pfp$r2_df_client_save_label (apfid, pfv$system_authority, required_permission, p_file_label,
            p_save_file_label_audit_seq, status);
    ELSE
      pfp$internal_save_file_label (apfid, pfv$system_authority, required_permission, p_file_label,
            p_save_file_label_audit_seq, status);
    IFEND;

    IF p_save_file_label_audit_seq <> NIL THEN
      RESET p_save_file_label_audit_seq;
      NEXT p_save_label_audit_info IN p_save_file_label_audit_seq;

      NEXT p_complete_path: [1 .. p_save_label_audit_info^.file_path_count] IN p_save_file_label_audit_seq;

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := p_complete_path;
      pfp$audit_save_label (variant_path, p_save_label_audit_info, status);
    IFEND;

    syp$pop_inhibit_job_recovery;
    #KEYPOINT (osk$exit, 0, pfk$save_file_label);
  PROCEND pfp$save_file_label;

?? TITLE := '  append_rem_media_vsn', EJECT ??

  PROCEDURE append_rem_media_vsn
    (    path: pft$complete_path;
         volume_descriptor: rmt$volume_descriptor;
         p_catalog_file: {i^/o^} pft$p_catalog_file;
         p_cycle: {i^/o^} pft$p_cycle;
     VAR status: ost$status);

    VAR
      additional_volumes: 0 .. amc$max_vol_number,
      new_stored_fmd_size: dmt$stored_fmd_size,
      number_of_volumes: 0 .. amc$max_vol_number,
      p_fmd: ^pft$fmd,
      p_new_stored_fmd: pft$p_physical_fmd,
      p_old_stored_fmd: pft$p_physical_fmd,
      p_stored_tape_fmd_header: ^dmt$stored_tape_fmd_header,
      p_stored_tape_volume_list: ^dmt$stored_tape_volume_list,
      p_volume_list: ^rmt$volume_list,
      prevalidate_free_result: ost$prevalidate_free_result,
      removable_media_req_info: fmt$removable_media_req_info,
      volume_list_index: integer;

    pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, p_catalog_file, p_old_stored_fmd);

    pfp$get_rem_media_req_info (^p_old_stored_fmd^.fmd, ^removable_media_req_info, number_of_volumes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF number_of_volumes > 0 THEN
      PUSH p_volume_list: [1 .. number_of_volumes];
      pfp$get_rem_media_volume_list (^p_old_stored_fmd^.fmd, p_volume_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF (number_of_volumes = 1) AND (p_volume_list^ [1].external_vsn = rmc$unspecified_vsn) AND
          (p_volume_list^ [1].recorded_vsn = rmc$unspecified_vsn) THEN
      additional_volumes := 0;
    ELSE
      additional_volumes := 1;
    IFEND;

    new_stored_fmd_size := #SIZE (p_old_stored_fmd^) + (additional_volumes * #SIZE (rmt$volume_descriptor));

    ALLOCATE p_new_stored_fmd: [[REP new_stored_fmd_size OF cell]] IN p_catalog_file^.catalog_heap;
    IF p_new_stored_fmd = NIL THEN
      osp$set_status_condition (pfe$catalog_full, status);
      RETURN;
    IFEND;

    p_fmd := ^p_new_stored_fmd^.fmd;
    NEXT p_stored_tape_fmd_header IN p_fmd;
    p_stored_tape_fmd_header^.version := dmc$stored_tape_fmd_version_1;
    pfp$convert_density_to_dm (removable_media_req_info.density, p_stored_tape_fmd_header^.density);
    p_stored_tape_fmd_header^.removable_media_group := removable_media_req_info.removable_media_group;
    p_stored_tape_fmd_header^.volume_count := number_of_volumes + additional_volumes;
    p_stored_tape_fmd_header^.volume_overflow_allowed := removable_media_req_info.volume_overflow_allowed;
    p_stored_tape_fmd_header^.reserved_tape_fmd_header_space := pfv$null_tape_fmd_header_space;

    NEXT p_stored_tape_volume_list: [1 .. (number_of_volumes + additional_volumes)] IN p_fmd;

    IF number_of_volumes > 0 THEN
      FOR volume_list_index := 1 TO UPPERBOUND (p_volume_list^) DO
        p_stored_tape_volume_list^ [volume_list_index].external_vsn :=
              p_volume_list^ [volume_list_index].external_vsn;
        p_stored_tape_volume_list^ [volume_list_index].recorded_vsn :=
              p_volume_list^ [volume_list_index].recorded_vsn;
      FOREND;
    IFEND;

    p_stored_tape_volume_list^ [(number_of_volumes + additional_volumes)].external_vsn :=
          volume_descriptor.external_vsn;
    p_stored_tape_volume_list^ [(number_of_volumes + additional_volumes)].recorded_vsn :=
          volume_descriptor.recorded_vsn;

    pfp$compute_checksum (#LOC (p_new_stored_fmd^.fmd), #SIZE (p_new_stored_fmd^.fmd),
          p_new_stored_fmd^.checksum);

    pfp$build_fmd_locator (p_new_stored_fmd, p_catalog_file, p_cycle^.cycle_entry.fmd_locator);
    pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
    IF p_old_stored_fmd <> NIL THEN
      osp$prevalidate_free ((#OFFSET(p_old_stored_fmd) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
            ^p_catalog_file^.catalog_heap, prevalidate_free_result);
      IF prevalidate_free_result = osc$heap_free_valid THEN
        FREE p_old_stored_fmd IN p_catalog_file^.catalog_heap;
      ELSE
        pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'FILE_MEDIA_DESCRIPTOR', 'file',
              prevalidate_free_result, #OFFSET(p_old_stored_fmd));
        p_old_stored_fmd := NIL;
      IFEND;
    IFEND;

  PROCEND append_rem_media_vsn;

?? TITLE := '  attach_cycle', EJECT ??

  PROCEDURE attach_cycle
    (    family_location: pft$family_location;
         mainframe_id: pmt$binary_mainframe_id;
         path: pft$complete_path;
         lfn: amt$local_file_name;
         device_class: rmt$device_class;
         date_time: ost$date_time;
         authority: pft$authority;
         update_catalog: boolean;
         update_cycle_statistics: boolean;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
         application_info: pft$application_info;
         validation_ring: ost$valid_ring;
         allowed_cycle_damage_symptoms: fst$cycle_damage_symptoms;
         enable_media_damage_detection: boolean;
         implicit_attach: boolean;
         p_file_label: {input} ^fmt$file_label;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
         p_file_object: {i^/o^} ^pft$physical_object;
         p_internal_cycle_path: {i^/o^} ^pft$internal_cycle_path;
         p_physical_cycle: {i^/o^} ^pft$physical_cycle;
     VAR flush_catalog_pages: {i/o} boolean;
     VAR path_handle: {client only} fmt$path_handle;
     VAR cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR p_file_server_buffers: {server only: i^/o^} ^pft$file_server_buffers;
     VAR status: ost$status);

    VAR
      apft_entry_assigned: boolean,
      apft_entry_in_use: boolean,
      archive_date_time: ost$date_time,
      archive_index: pft$archive_index,
      attached_pf_table_index: pft$attached_pf_table_index,
      comparison_result: pmt$comparison_result,
      data_modification_date_time: ost$date_time,
      file_damaged: boolean,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      new_log_list: boolean,
      p_archive_list: ^pft$archive_list,
      p_attached_pf_entry: ^pft$attached_pf_entry,
      p_fs_path: ^fst$path,
      p_log_list: ^pft$log_list,
      p_new_log_list: ^pft$log_list,
      prevalidate_free_result: ost$prevalidate_free_result,
      sfid: gft$system_file_identifier,
      valid_archive_entry_exists: boolean;

    set_flush_catalog_pages (usage_selections, p_physical_cycle, flush_catalog_pages);
    pfp$assign_locked_apfid (attached_pf_table_index, status);
    apft_entry_assigned := status.normal;
    pfv$locked_apfid := attached_pf_table_index;

    IF status.normal THEN
      check_cycle_damage (path, p_physical_cycle^.cycle_entry, allowed_cycle_damage_symptoms,
            cycle_damage_symptoms, status);
    IFEND;

    IF status.normal THEN
      pfp$attach_permanent_file (family_location, mainframe_id, lfn, path, attached_pf_table_index,
            usage_selections, share_selections, application_info, validation_ring,
            (p_file_object^.object_entry.password <> osc$null_name), allowed_cycle_damage_symptoms,
            enable_media_damage_detection, implicit_attach, update_catalog, authority, p_file_label,
            p_catalog_file, p_physical_cycle, sfid, file_damaged, flush_catalog_pages, path_handle,
            p_file_server_buffers, status);
    IFEND;
    apft_entry_in_use := status.normal;

    IF status.normal THEN
      p_internal_cycle_path^.cycle_name := p_physical_cycle^.cycle_entry.internal_cycle_name;
      build_attached_pf_entry (sfid, path, p_physical_cycle^.cycle_entry.cycle_number, device_class,
            update_catalog, update_cycle_statistics, usage_selections, share_selections, file_damaged,
            enable_media_damage_detection, allowed_cycle_damage_symptoms, p_internal_cycle_path^,
            p_attached_pf_entry, status);
    IFEND;

    IF status.normal AND update_catalog AND (p_file_object^.object_entry.logging_selection = pfc$log) THEN
      flush_catalog_pages := pfv$flush_catalogs;
      pfp$build_log_list_pointer (p_file_object^.object_entry.log_list_locator, p_catalog_file, p_log_list);
      update_access_log (date_time, authority, p_physical_cycle^.cycle_entry.cycle_number,
            ^p_catalog_file^.catalog_heap, p_log_list, p_new_log_list, new_log_list, status);

      IF status.normal AND new_log_list THEN
        pfp$build_log_list_locator (p_new_log_list, p_catalog_file,
              p_file_object^.object_entry.log_list_locator);
        pfp$compute_checksum (#LOC (p_file_object^.object_entry), #SIZE (pft$object_entry),
              p_file_object^.checksum);
        IF p_log_list <> NIL THEN
          osp$prevalidate_free ((#OFFSET(p_log_list) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
                ^p_catalog_file^.catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_log_list IN p_catalog_file^.catalog_heap;
          ELSE
            pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'LOG_LIST', 'file', prevalidate_free_result,
                  #OFFSET(p_log_list));
            p_log_list := NIL;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal AND update_catalog THEN
      pfp$increment_usage_counts (path, usage_selections, share_selections, mainframe_id, p_catalog_file,
            flush_catalog_pages, p_physical_cycle^.cycle_entry, status);

      IF status.normal THEN
        IF update_cycle_statistics THEN
          update_access_date (p_physical_cycle^.cycle_entry.cycle_statistics, date_time, usage_selections,
                share_selections, p_physical_cycle^.cycle_entry.cycle_statistics);
          IF usage_selections * pfv$write_usage <> $pft$usage_selections [] THEN
            p_physical_cycle^.cycle_entry.data_modification_date_time := date_time;
          IFEND;
        ELSE {utility attach}
          { Set a job recovery test.
          syp$hang_if_job_jrt_set (pfc$tjr_utility_attach);
        IFEND;

        pfp$compute_checksum (#LOC (p_physical_cycle^.cycle_entry), #SIZE (pft$cycle_entry),
              p_physical_cycle^.checksum);
      IFEND;
    IFEND;

    IF apft_entry_assigned THEN
      IF apft_entry_in_use THEN
        pfp$unlock_apfid (attached_pf_table_index, p_attached_pf_entry, local_status);
      ELSE
        pfp$release_locked_apfid (attached_pf_table_index, local_status);
      IFEND;
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND attach_cycle;

?? TITLE := '  build_attached_pf_entry', EJECT ??

  PROCEDURE build_attached_pf_entry
    (    system_file_id: gft$system_file_identifier;
         external_path: pft$complete_path;
         cycle_number: pft$cycle_number;
         device_class: rmt$device_class;
         update_catalog: boolean;
         update_cycle_statistics: boolean;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
         media_image_inconsistent: boolean;
         media_damage_detection_enabled: boolean;
         allowed_cycle_damage_symptoms: fst$cycle_damage_symptoms;
         internal_cycle_path: pft$internal_cycle_path;
     VAR p_attached_pf_entry: pft$p_attached_pf_entry;
     VAR status: ost$status);

    ALLOCATE p_attached_pf_entry: [1 .. UPPERBOUND (internal_cycle_path.path)] IN pfv$p_p_job_heap^^;
    IF p_attached_pf_entry = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'Too many attached files - p_attached_pf_entry', status);
      #KEYPOINT (osk$unusual, 0, pfk$job_pageable_full);
    ELSE
      ALLOCATE p_attached_pf_entry^.p_external_path: [1 .. UPPERBOUND (external_path)] IN pfv$p_p_job_heap^^;
      IF p_attached_pf_entry^.p_external_path = NIL THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'Too many attached files - p_external_path', status);
        #KEYPOINT (osk$unusual, 0, pfk$job_pageable_full);
      ELSE
        status.normal := TRUE;
        p_attached_pf_entry^.sfid_status.recovery_state := pfc$attached_pf_normal;
        p_attached_pf_entry^.sfid_status.sfid := system_file_id;
        p_attached_pf_entry^.update_catalog := update_catalog;
        p_attached_pf_entry^.update_cycle_statistics := update_cycle_statistics;
        p_attached_pf_entry^.usage_selections := usage_selections;
        p_attached_pf_entry^.share_selections := share_selections;
        p_attached_pf_entry^.media_image_inconsistent := media_image_inconsistent;
        p_attached_pf_entry^.media_damage_detection_enabled := media_damage_detection_enabled;
        IF update_cycle_statistics THEN
          p_attached_pf_entry^.allowed_exception_conditions := allowed_cycle_damage_symptoms;
        ELSE
          p_attached_pf_entry^.allowed_exception_conditions := $fst$cycle_damage_symptoms[];
        IFEND;
        p_attached_pf_entry^.p_external_path^ := external_path;
        p_attached_pf_entry^.cycle_number := cycle_number;
        p_attached_pf_entry^.device_class := device_class;
        p_attached_pf_entry^.internal_cycle_path := internal_cycle_path;
      IFEND;
    IFEND;
  PROCEND build_attached_pf_entry;

?? TITLE := '  build_damage_symptoms_string', EJECT ??

  PROCEDURE build_damage_symptoms_string
    (    cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR cycle_damage_symptoms_string: pft$selections_string);

    VAR
      cycle_damage_symptom: fst$cycle_damage_symptom,
      first_match: boolean;

    IF cycle_damage_symptoms = $fst$cycle_damage_symptoms [] THEN
      cycle_damage_symptoms_string.value := 'null set';
      cycle_damage_symptoms_string.size := 8;
    ELSE
      first_match := TRUE;

      FOR cycle_damage_symptom := fsc$media_image_inconsistent TO fsc$parent_catalog_restored DO
        IF cycle_damage_symptom IN cycle_damage_symptoms THEN
          CASE cycle_damage_symptom OF
          = fsc$media_image_inconsistent =
            cycle_damage_symptoms_string.value (1, 29) := '[fsc$media_image_inconsistent';
            cycle_damage_symptoms_string.size := 29;
            first_match := FALSE;

          = fsc$respf_modification_mismatch =
            IF first_match THEN
              cycle_damage_symptoms_string.value (1, 32) := '[fsc$respf_modification_mismatch';
              cycle_damage_symptoms_string.size := 32;
              first_match := FALSE;
            ELSE
              STRINGREP (cycle_damage_symptoms_string.value, cycle_damage_symptoms_string.size,
                    cycle_damage_symptoms_string.value (1, cycle_damage_symptoms_string.size),
                    ', fsc$respf_modification_mismatch');
            IFEND;

          = fsc$parent_catalog_restored =
            IF first_match THEN
              cycle_damage_symptoms_string.value (1, 27) := '[fsc$parent_catalog_restored';
              cycle_damage_symptoms_string.size := 27;
              first_match := FALSE;
            ELSE
              STRINGREP (cycle_damage_symptoms_string.value, cycle_damage_symptoms_string.size,
                    cycle_damage_symptoms_string.value (1, cycle_damage_symptoms_string.size),
                    ', fsc$parent_catalog_restored');
            IFEND;

          ELSE
            ;
          CASEND;
        IFEND;
      FOREND;

      STRINGREP (cycle_damage_symptoms_string.value, cycle_damage_symptoms_string.size,
            cycle_damage_symptoms_string.value (1, cycle_damage_symptoms_string.size), ']');
    IFEND;
  PROCEND build_damage_symptoms_string;

?? TITLE := '  check_cycle_damage', EJECT ??

  PROCEDURE check_cycle_damage
    (    path: pft$complete_path;
         cycle_entry: pft$cycle_entry;
         allowed_cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR status: ost$status);

    VAR
      date_string: ost$date,
      local_status: ost$status,
      path_string: ost$string,
      time_string: ost$time;

    cycle_damage_symptoms := cycle_entry.cycle_damage_symptoms;
    IF cycle_entry.cycle_damage_symptoms <= allowed_cycle_damage_symptoms THEN
      status.normal := TRUE;
    ELSE { Cycle contains damage symptoms NOT allowed.
      IF fsc$respf_modification_mismatch IN cycle_entry.cycle_damage_symptoms THEN
        pfp$convert_cycle_path_to_strng (path, cycle_entry.cycle_number, path_string);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$respf_modification_mismatch,
              path_string.value (1, path_string.size), status);
        pmp$format_compact_date (cycle_entry.cycle_statistics.modification_date_time, osc$mdy_date,
              date_string, local_status);
        pfp$process_unexpected_status (local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, date_string.mdy, status);
        pmp$format_compact_time (cycle_entry.cycle_statistics.modification_date_time, osc$millisecond_time,
              time_string, local_status);
        pfp$process_unexpected_status (local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, time_string.millisecond, status);
      ELSEIF fsc$parent_catalog_restored IN cycle_entry.cycle_damage_symptoms THEN
        pfp$convert_cycle_path_to_strng (path, cycle_entry.cycle_number, path_string);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$parent_catalog_restored,
              path_string.value (1, path_string.size), status);
      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
              'Unexpected damage condition.', status);
      IFEND;
    IFEND;
  PROCEND check_cycle_damage;

?? TITLE := '  check_mainframe_usage', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is  determine is a cycle is to be considered
{   busy, due to usage by another mainframe.  If another mainframe is writing the cycle,
{   or if this mainframe desires to write the cycle, but another mainframe is
{   using the cycle, then the cycle is considered busy.

  PROCEDURE check_mainframe_usage
    (    path: pft$complete_path;
         mainframe_id: pmt$binary_mainframe_id;
         usage_intentions: pft$permit_selections;
         p_catalog_file: {input^} ^pft$catalog_file;
         cycle_entry: pft$cycle_entry;
     VAR status: ost$status);

    VAR
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      mainframe: pft$mainframe_count,
      p_mainframe_usage_list: ^pft$mainframe_usage_list;

    status.normal := TRUE;
    pfp$build_mainfram_list_pointer (cycle_entry.mainframe_usage_list_locator, p_catalog_file,
          p_mainframe_usage_list);

    {
    { Check for another mainframe writing the file.
    {
    IF other_mainframe_writer (mainframe_id, cycle_entry, p_mainframe_usage_list) THEN
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_busy, fs_path (1, fs_path_size),
            status);
      osp$append_status_integer (osc$status_parameter_delimiter, cycle_entry.cycle_number, 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, pfc$another_mainframe_writer,  status);
      RETURN;
    IFEND;

    IF (usage_intentions * $pft$permit_selections [pfc$shorten, pfc$append, pfc$modify]) <>
          $pft$permit_selections [] THEN
      {
      { Check if another mainframe is using the file.
      {
      IF other_mainframe_using (mainframe_id, cycle_entry, p_mainframe_usage_list) THEN
        pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_busy, fs_path (1, fs_path_size),
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, cycle_entry.cycle_number, 10, FALSE,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, pfc$another_mainframe_user, status);
        RETURN;
      IFEND;
    IFEND;
  PROCEND check_mainframe_usage;

?? TITLE := '  check_path_table_cycle_number', EJECT ??

  PROCEDURE check_path_table_cycle_number
    (    catalog_cycle_number: pft$cycle_number;
         cycle_selector: pft$cycle_selector;
         path_table_cycle_number: pft$cycle_number;
     VAR fetch_new_cycle_info: boolean);


    CASE cycle_selector.cycle_option OF
    = pfc$specific_cycle =
      fetch_new_cycle_info := FALSE;

    = pfc$highest_cycle =
      IF path_table_cycle_number = catalog_cycle_number THEN
        fetch_new_cycle_info := FALSE;
      ELSEIF path_table_cycle_number > catalog_cycle_number THEN
        {
        { The highest cycle attached within the job has been deleted from
        { the catalog. The path table must be searched for a cycle entry
        { corresponding to the highest cycle in the catalog.
        {
        fetch_new_cycle_info := TRUE;
      ELSE { path_table_cycle_number < catalog_cycle_number
        {
        { The highest cycle attached within the job is lower than the highest
        { cycle in the catalog. The path table need not be searched.
        {
        fetch_new_cycle_info := FALSE;
      IFEND;

    = pfc$lowest_cycle =
      IF path_table_cycle_number = catalog_cycle_number THEN
        fetch_new_cycle_info := FALSE;
      ELSEIF path_table_cycle_number > catalog_cycle_number THEN
        {
        { The lowest cycle attached within the job is higher than the lowest
        { cycle in the catalog. The path table need not be searched.
        {
        fetch_new_cycle_info := FALSE;
      ELSE { path_table_cycle_number < catalog_cycle_number
        {
        { The lowest cycle attached within the job has been deleted from the
        { catalog.  The path table must be searched for a cycle entry
        { corresponding to the lowest cycle in the catalog.
        {
        fetch_new_cycle_info := TRUE;
      IFEND;
    ELSE
      ;
    CASEND;
  PROCEND check_path_table_cycle_number;

?? TITLE := '  contract_cycle_list', EJECT ??
{       CONTRACT_CYCLE_LIST
{
{   The purpose of this procedure is to analyze a cycle list and conditionally
{ contract it based on some algorithm.  If it is necessary to contract the cycle
{ list, a new, smaller cycle list is created and the old list is copied to the
{ new list.  The algorithm can be chosen to determine the performance of the
{ permanent file system relative to a changing number of cycles.  The current
{ algorithm is a very simple one that contracts the cycle list if the free cycle
{ count equals or exceeds a threshold.

  PROCEDURE contract_cycle_list
    (    path: pft$complete_path;
         p_file_object: {output^} pft$p_object;
         p_catalog_file: {output^} pft$p_catalog_file;
     VAR status: ost$status);

    VAR
      cycle_index: pft$cycle_index,
      free_physical_cycle: pft$physical_cycle,
      high_cycle_index: pft$cycle_index,
      new_cycle_count: pft$cycle_count,
      new_cycle_index: pft$cycle_index,
      p_cycle_list: pft$p_cycle_list,
      p_new_cycle_list: pft$p_cycle_list,
      prevalidate_free_result: ost$prevalidate_free_result;

    status.normal := TRUE;

    pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator, p_catalog_file,
          p_cycle_list);
    IF p_cycle_list <> NIL THEN
      high_cycle_index := UPPERBOUND (p_cycle_list^);

      IF pfc$cycle_contraction_count <= high_cycle_index THEN
        new_cycle_count := 0;

        FOR cycle_index := 1 TO high_cycle_index DO
          IF p_cycle_list^ [cycle_index].cycle_entry.entry_type <> pfc$free_cycle_entry THEN
            new_cycle_count := new_cycle_count + 1;
          IFEND;
        FOREND;

        IF pfc$cycle_contraction_count <= high_cycle_index - new_cycle_count THEN
          pfp$allocate_cycle_list (new_cycle_count, ^p_catalog_file^.catalog_heap, p_new_cycle_list, status);
          IF status.normal THEN
            new_cycle_index := 1;

            FOR cycle_index := 1 TO high_cycle_index DO
              IF p_cycle_list^ [cycle_index].cycle_entry.entry_type <> pfc$free_cycle_entry THEN
                p_new_cycle_list^ [new_cycle_index] := p_cycle_list^ [cycle_index];
                new_cycle_index := new_cycle_index + 1;
              IFEND;
            FOREND;

            free_physical_cycle.cycle_entry.entry_type := pfc$free_cycle_entry;
            pfp$compute_checksum (#LOC (free_physical_cycle.cycle_entry), #SIZE (pft$cycle_entry),
                  free_physical_cycle.checksum);

            FOR new_cycle_index := new_cycle_index TO UPPERBOUND (p_new_cycle_list^) DO
              p_new_cycle_list^ [new_cycle_index] := free_physical_cycle;
            FOREND;
            {
            { To make the catalog crash resistant, the new cycle list should be
            { written to permanent storage, the file object owning the new
            { cycle list written to permanent storage, and the old cycle list
            { released.
            {
            pfp$build_cycle_list_locator (p_new_cycle_list, p_catalog_file,
                  p_file_object^.object_entry.cycle_list_locator);
            pfp$compute_checksum (#LOC (p_file_object^.object_entry), #SIZE (pft$object_entry),
                  p_file_object^.checksum);
            osp$prevalidate_free ((#OFFSET(p_cycle_list) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
                  ^p_catalog_file^.catalog_heap, prevalidate_free_result);
            IF prevalidate_free_result = osc$heap_free_valid THEN
              FREE p_cycle_list IN p_catalog_file^.catalog_heap;
            ELSE
              pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'CYCLE_LIST', 'file',
                    prevalidate_free_result, #OFFSET(p_cycle_list));
              p_cycle_list := NIL;
            IFEND;
          ELSEIF status.condition = pfe$catalog_full THEN
            status.normal := TRUE;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND contract_cycle_list;

?? TITLE := '  contract_permit_list', EJECT ??

  PROCEDURE contract_permit_list
    (    path: pft$complete_path;
         p_object: {output^} pft$p_object;
         p_catalog_file: {output^} pft$p_catalog_file;
     VAR status: ost$status);

    VAR
      free_physical_permit: pft$physical_permit,
      high_permit_index: pft$permit_index,
      new_permit_count: pft$permit_count,
      new_permit_index: pft$permit_index,
      p_new_permit_list: pft$p_permit_list,
      p_permit_list: pft$p_permit_list,
      permit_index: pft$permit_index,
      prevalidate_free_result: ost$prevalidate_free_result;

    status.normal := TRUE;

    pfp$build_permit_list_pointer (p_object^.object_entry.permit_list_locator, p_catalog_file, p_permit_list);
    IF p_permit_list <> NIL THEN
      high_permit_index := UPPERBOUND (p_permit_list^);

      IF pfc$permit_contraction_count <= high_permit_index THEN
        new_permit_count := 0;

        FOR permit_index := 1 TO high_permit_index DO
          IF p_permit_list^ [permit_index].permit_entry.entry_type <> pfc$free_permit_entry THEN
            new_permit_count := new_permit_count + 1;
          IFEND;
        FOREND;

        IF pfc$permit_contraction_count <= high_permit_index - new_permit_count THEN
          pfp$allocate_permit_list (new_permit_count, ^p_catalog_file^.catalog_heap, p_new_permit_list,
                status);
          IF status.normal THEN
            new_permit_index := 1;

            FOR permit_index := 1 TO high_permit_index DO
              IF p_permit_list^ [permit_index].permit_entry.entry_type <> pfc$free_permit_entry THEN
                p_new_permit_list^ [new_permit_index] := p_permit_list^ [permit_index];
                new_permit_index := new_permit_index + 1;
              IFEND;
            FOREND;

            free_physical_permit.permit_entry.entry_type := pfc$free_permit_entry;
            pfp$compute_checksum (#LOC (free_physical_permit.permit_entry), #SIZE (pft$permit_entry),
                  free_physical_permit.checksum);

            FOR new_permit_index := new_permit_index TO UPPERBOUND (p_new_permit_list^) DO
              p_new_permit_list^ [new_permit_index] := free_physical_permit;
            FOREND;
            {
            { To make the catalog crash resistant, write the new permit list to
            { permanent storage, update the pointer to the new permit list, and
            { free the old permit list.
            {
            pfp$build_permit_list_locator (p_new_permit_list, p_catalog_file,
                  p_object^.object_entry.permit_list_locator);
            pfp$compute_checksum (#LOC (p_object^.object_entry), #SIZE (pft$object_entry),
                  p_object^.checksum);
            osp$prevalidate_free ((#OFFSET(p_permit_list) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
                  ^p_catalog_file^.catalog_heap, prevalidate_free_result);
            IF prevalidate_free_result = osc$heap_free_valid THEN
              FREE p_permit_list IN p_catalog_file^.catalog_heap;
            ELSE
              IF p_object^.object_entry.object_type = pfc$file_object THEN
                pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'PERMIT_LIST', 'file',
                      prevalidate_free_result, #OFFSET(p_permit_list));
              ELSE
                pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'PERMIT_LIST', 'catalog',
                      prevalidate_free_result, #OFFSET(p_permit_list));
              IFEND;
              p_permit_list := NIL;
            IFEND;
          ELSEIF status.condition = pfe$catalog_full THEN
            status.normal := TRUE;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND contract_permit_list;

?? TITLE := '  [INLINE] convert_group_type_to_string', EJECT ??

  PROCEDURE [INLINE] convert_group_type_to_string
    (    group_type: pft$group_types;
     VAR group_type_string: string (maximum_group_type_string_size);
     VAR group_type_string_size: 1 .. maximum_group_type_string_size);

    CASE group_type OF
    = pfc$public =
      group_type_string := 'public';
      group_type_string_size := 6;
    = pfc$family =
      group_type_string := 'family';
      group_type_string_size := 6;
    = pfc$account =
      group_type_string := 'account';
      group_type_string_size := 7;
    = pfc$project =
      group_type_string := 'project';
      group_type_string_size := 7;
    = pfc$user =
      group_type_string := 'user';
      group_type_string_size := 4;
    = pfc$user_account =
      group_type_string := 'user_account';
      group_type_string_size := 12;
    = pfc$member =
      group_type_string := 'member';
      group_type_string_size := 6;
    ELSE
      group_type_string := '?';
      group_type_string_size := 1;
    CASEND;
  PROCEND convert_group_type_to_string;

?? TITLE := '  create_cycle', EJECT ??

  PROCEDURE create_cycle
    (    family_location: pft$family_location;
         mainframe_id: pmt$binary_mainframe_id;
         path: pft$complete_path;
         cycle_number: pft$cycle_number;
         lfn: amt$local_file_name;
         date_time: ost$date_time;
         authority: pft$authority;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
         application_info: pft$application_info;
         validation_ring: ost$valid_ring;
         enable_media_damage_detection: boolean;
         implicit_attach: boolean;
         fs_retention: fst$retention;
         retrieve_option: pft$retrieve_option;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
         p_file_label: {input} fmt$p_file_label;
         device_class: rmt$device_class,
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
         p_removable_media_req_info: {input} ^fmt$removable_media_req_info;
         p_volume_list: {input} ^rmt$volume_list;
         p_catalog_file: {i^/o^} pft$p_catalog_file;
         p_file_object: {i^/o^} pft$p_object;
         p_internal_cycle_path: {i^/o^} pft$p_internal_cycle_path;
     VAR physical_file_object: {i/o} pft$physical_object;
     VAR p_cycle_list: {i/o} pft$p_cycle_list;
     VAR p_cycle: {output} pft$p_cycle;
     VAR sfid: gft$system_file_identifier;
     VAR path_handle: {client only} fmt$path_handle;
     VAR bytes_allocated: amt$file_byte_address;
     VAR p_file_server_buffers: {server only: i^/o^} pft$p_file_server_buffers;
     VAR status: ost$status);

    VAR
      apft_index: pft$attached_pf_table_index,
      apfid_assigned: boolean,
      apfid_in_use: boolean,
      flush_catalog_pages: boolean,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      ignore_status: ost$status,
      internal_cycle_name: pft$internal_name,
      local_status: ost$status,
      new_cycle_list: boolean,
      new_log_list: boolean,
      p_attached_pf_entry: pft$p_attached_pf_entry,
      p_catalog_heap: pft$p_catalog_heap,
      p_data_value: ^clt$data_value,
      p_evaluated_file_reference: ^fst$evaluated_file_reference,
      p_log_list: pft$p_log_list,
      p_new_cycle_list: pft$p_cycle_list,
      p_new_log_list: pft$p_log_list,
      p_new_stored_fmd: pft$p_physical_fmd,
      p_parent_path: ^pft$complete_path,
      path_description_created: boolean,
      path_index: pft$catalog_path_index,
      pf_device_class: pft$device_class,
      physical_cycle: pft$physical_cycle,
      prevalidate_free_result: ost$prevalidate_free_result,
      shared_queue: pft$shared_queue;

    pfp$assign_locked_apfid (apft_index, status);
    apfid_assigned := status.normal;
    apfid_in_use := FALSE;
    path_description_created := FALSE;
    pfv$locked_apfid := apft_index;

    IF status.normal THEN
      IF (device_class = rmc$magnetic_tape_device) AND (authority.ownership = $pft$ownership []) THEN
        PUSH p_parent_path: [1 .. (UPPERBOUND (path) - 1)];
        FOR path_index := 1 TO UPPERBOUND (path) - 1 DO
          p_parent_path^ [path_index] := path [path_index];
        FOREND;
        pfp$convert_pf_path_to_fs_path (p_parent_path^, fs_path, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$non_owner_tape_file_create,
              fs_path (1, fs_path_size), status);
      IFEND;
    IFEND;

    IF status.normal THEN
      pfp$create_permanent_file (family_location, lfn, path, cycle_number, apft_index, usage_selections,
            share_selections, application_info, validation_ring,
            {password_protected} (physical_file_object.object_entry.password <> osc$null_name),
            enable_media_damage_detection, implicit_attach, {recreate_attached_cycle_data} FALSE,
            p_file_label, device_class, p_mass_storage_request_info, p_removable_media_req_info,
            p_volume_list, authority, path_handle, sfid, internal_cycle_name, bytes_allocated,
            p_file_server_buffers, status);
    IFEND;
    apfid_in_use := status.normal;
    path_description_created := status.normal;

    IF status.normal THEN
      p_catalog_heap := ^p_catalog_file^.catalog_heap;
      pfp$record_dm_file_parameters (^path, ^cycle_number, sfid, device_class, p_removable_media_req_info,
            p_volume_list, p_catalog_heap, p_new_stored_fmd, status);
    IFEND;

    p_attached_pf_entry := NIL;
    IF status.normal THEN
      create_cycle_entry (cycle_number, fs_retention, retrieve_option, site_archive_option,
            site_backup_option, site_release_option, date_time, bytes_allocated, device_class,
            physical_cycle.cycle_entry);
      physical_cycle.cycle_entry.internal_cycle_name := internal_cycle_name;
      physical_cycle.cycle_entry.device_information.device_class_defined := TRUE;
      pfp$convert_device_class_to_pf (device_class, pf_device_class);
      physical_cycle.cycle_entry.device_information.device_class := pf_device_class;
      IF (p_mass_storage_request_info <> NIL) AND
            (p_mass_storage_request_info^.shared_queue <> pfc$null_shared_queue) THEN
        physical_cycle.cycle_entry.shared_queue_info.defined := TRUE;
        physical_cycle.cycle_entry.shared_queue_info.shared_queue :=
              p_mass_storage_request_info^.shared_queue;
      ELSE
        clp$get_variable_value ('RMV$SHARED_QUEUE', p_data_value, local_status);
        IF local_status.normal AND (p_data_value <> NIL) THEN
          IF p_data_value^.kind = clc$name THEN
            pfp$convert_shared_queue_to_ord (p_data_value^.name_value, shared_queue, local_status);
            IF local_status.normal THEN
              physical_cycle.cycle_entry.shared_queue_info.defined := TRUE;
              physical_cycle.cycle_entry.shared_queue_info.shared_queue := shared_queue;
            ELSE
              pmp$log_ascii ('Invalid value for variable RMV$SHARED_QUEUE ignored.',
                    $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, ignore_status);
            IFEND;
          ELSE
            pmp$log_ascii ('Invalid type for variable RMV$SHARED_QUEUE ignored.',
                  $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_system, ignore_status);
          IFEND;
        IFEND;
      IFEND;
      physical_cycle.cycle_entry.device_information.eoi := 0;
      physical_cycle.cycle_entry.device_information.bytes_allocated := bytes_allocated;
      physical_cycle.cycle_entry.global_file_name := internal_cycle_name;
      pfp$build_fmd_locator (p_new_stored_fmd, p_catalog_file, physical_cycle.cycle_entry.fmd_locator);
      pfp$increment_usage_counts (path, usage_selections, share_selections, mainframe_id,
            p_catalog_file, flush_catalog_pages, physical_cycle.cycle_entry, status);
      pfp$compute_checksum (#LOC (physical_cycle.cycle_entry), #SIZE (physical_cycle.cycle_entry),
            physical_cycle.checksum);
      syp$hang_if_job_jrt_set (pfc$tjr_define);
      p_internal_cycle_path^.cycle_name := internal_cycle_name;
      build_attached_pf_entry (sfid, path, cycle_number, device_class, {update_catalog} TRUE,
            {update_cycle_statistics} TRUE, usage_selections, share_selections,
            {media_image_inconsistent} FALSE, enable_media_damage_detection, $fst$cycle_damage_symptoms [],
            p_internal_cycle_path^, p_attached_pf_entry, status);
    IFEND;

    IF status.normal THEN
      new_log_list := FALSE;
      IF physical_file_object.object_entry.logging_selection = pfc$log THEN
        pfp$build_log_list_pointer (physical_file_object.object_entry.log_list_locator, p_catalog_file,
              p_log_list);
        update_access_log (date_time, authority, cycle_number, p_catalog_heap, p_log_list, p_new_log_list,
              new_log_list, status);
      IFEND;

      IF status.normal THEN
        pfp$establish_free_cycle_entry (p_catalog_heap, p_cycle_list, p_new_cycle_list, new_cycle_list,
              p_cycle, status);

        IF status.normal THEN
          p_cycle^ := physical_cycle;

          IF new_cycle_list THEN
            pfp$build_cycle_list_locator (p_new_cycle_list, p_catalog_file,
                  physical_file_object.object_entry.cycle_list_locator);
          IFEND;

          IF new_log_list THEN
            pfp$build_log_list_locator (p_new_log_list, p_catalog_file,
                  physical_file_object.object_entry.log_list_locator);
          IFEND;

          IF new_cycle_list OR new_log_list THEN
            pfp$compute_checksum (#LOC (physical_file_object.object_entry), #SIZE (pft$object_entry),
                  physical_file_object.checksum);
            p_file_object^ := physical_file_object;
          IFEND;

          IF new_cycle_list AND (p_cycle_list <> NIL) THEN
            osp$prevalidate_free ((#OFFSET(p_cycle_list) - #OFFSET(p_catalog_heap) - 16),
                  p_catalog_heap, prevalidate_free_result);
            IF prevalidate_free_result = osc$heap_free_valid THEN
              FREE p_cycle_list IN p_catalog_heap^;
            ELSE
              pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'CYCLE_LIST', 'file',
                    prevalidate_free_result, #OFFSET(p_cycle_list));
              p_cycle_list := NIL;
            IFEND;
          IFEND;

          IF new_log_list AND (p_log_list <> NIL) THEN
            osp$prevalidate_free ((#OFFSET(p_log_list) - #OFFSET(p_catalog_heap) - 16),
                  p_catalog_heap, prevalidate_free_result);
            IF prevalidate_free_result = osc$heap_free_valid THEN
              FREE p_log_list IN p_catalog_heap^;
            ELSE
              pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'LOG_LIST', 'file',
                    prevalidate_free_result, #OFFSET(p_log_list));
              p_log_list := NIL;
            IFEND;
          IFEND;
        ELSE
          IF new_log_list THEN
            osp$prevalidate_free ((#OFFSET(p_new_log_list) - #OFFSET(p_catalog_heap) - 16),
                  p_catalog_heap, prevalidate_free_result);
            IF prevalidate_free_result = osc$heap_free_valid THEN
              FREE p_new_log_list IN p_catalog_heap^;
            ELSE
              pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'LOG_LIST', 'file',
                    prevalidate_free_result, #OFFSET(p_new_log_list));
              p_new_log_list := NIL;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF NOT status.normal AND path_description_created THEN
      dmp$destroy_file (sfid, sfc$no_limit, local_status);

      PUSH p_evaluated_file_reference;
      pfp$convert_pf_to_fs_structure(path, p_evaluated_file_reference^);
      p_evaluated_file_reference^.path_handle_info.path_handle_present := TRUE;
      p_evaluated_file_reference^.path_handle_info.path_handle := path_handle;
      fmp$delete_path_description (p_evaluated_file_reference^, {implicit_detach} FALSE,
            {return_permanent_file} FALSE, {detachment_options} NIL, local_status);

      IF p_attached_pf_entry <> NIL THEN
        IF p_attached_pf_entry^.p_external_path <> NIL THEN
          FREE p_attached_pf_entry^.p_external_path IN pfv$p_p_job_heap^^;
        IFEND;
        FREE p_attached_pf_entry IN pfv$p_p_job_heap^^;
        pfp$release_locked_apfid (apft_index, local_status);
        pfp$process_unexpected_status (local_status);
        apfid_assigned := FALSE;
      IFEND;
    IFEND;

    IF apfid_assigned THEN
      IF apfid_in_use THEN
        pfp$unlock_apfid (apft_index, p_attached_pf_entry, local_status);
      ELSE
        pfp$release_locked_apfid (apft_index, local_status);
      IFEND;
      pfp$process_unexpected_status (local_status);
    IFEND;
  PROCEND create_cycle;

?? TITLE := '  [INLINE] create_cycle_entry', EJECT ??

  PROCEDURE [INLINE] create_cycle_entry
    (    cycle_number: pft$cycle_number;
         fs_retention: fst$retention;
         retrieve_option: pft$retrieve_option;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
         date_time: ost$date_time;
         bytes_allocated: amt$file_byte_address;
         device_class: rmt$device_class;
     VAR cycle_entry: pft$cycle_entry);

    VAR
      pf_device_class: pft$device_class;

    cycle_entry.entry_type := pfc$normal_cycle_entry;
    cycle_entry.cycle_number := cycle_number;
    cycle_entry.cycle_statistics.creation_date_time := date_time;
    cycle_entry.cycle_statistics.modification_date_time := date_time;
    cycle_entry.cycle_statistics.access_date_time := date_time;
    cycle_entry.data_modification_date_time := date_time;
    cycle_entry.cycle_statistics.access_count := 0;
    form_expiration_date_time (date_time, fs_retention, cycle_entry.expiration_date_time);
    cycle_entry.attach_status := pfv$unattached_status;
    cycle_entry.cycle_damage_symptoms := $fst$cycle_damage_symptoms [];
    cycle_entry.device_information.device_class_defined := TRUE;
    pfp$convert_device_class_to_pf (device_class, pf_device_class);
    cycle_entry.device_information.device_class := pf_device_class;
    cycle_entry.shared_queue_info.defined := FALSE;
    cycle_entry.shared_queue_info.shared_queue := pfc$null_shared_queue;
    cycle_entry.retrieve_option := retrieve_option;
    cycle_entry.site_backup_option := site_backup_option;
    cycle_entry.site_archive_option := site_archive_option;
    cycle_entry.site_release_option := site_release_option;
    cycle_entry.device_information.eoi := 0;
    cycle_entry.device_information.bytes_allocated := bytes_allocated;
    pfp$build_fmd_locator (NIL, NIL, cycle_entry.fmd_locator);
    pfp$build_file_label_locator (NIL, NIL, cycle_entry.file_label_locator);
    pfp$build_archive_list_locator (NIL, NIL, cycle_entry.archive_list_locator);
    cycle_entry.data_residence := pfc$unreleasable_data;
    cycle_entry.first_mainframe_usage_entry.entry_type := pfc$free_mainframe_entry;
    pfp$build_mainfram_list_locator (NIL, NIL, cycle_entry.mainframe_usage_list_locator);
    cycle_entry.reserved_cycle_entry_space := pfv$null_cycle_entry_space;
  PROCEND create_cycle_entry;

?? TITLE := '  [INLINE] cycle_busy_due_to_sharing', EJECT ??

  FUNCTION [INLINE] cycle_busy_due_to_sharing
    (    attach_status: pft$attach_status;
         share_intentions: pft$share_selections): boolean;

    VAR
      busy: boolean,
      share_option: pft$share_options;

    busy := FALSE;

    FOR share_option := LOWERVALUE (share_option) TO UPPERVALUE (share_option) DO
      busy := (busy OR (NOT (share_option IN share_intentions) AND
            (attach_status.usage_counts [share_option] > 0)));
    FOREND;

    cycle_busy_due_to_sharing := busy;
  FUNCEND cycle_busy_due_to_sharing;

?? TITLE := '  [INLINE] cycle_busy_due_to_usage', EJECT ??

  FUNCTION [INLINE] cycle_busy_due_to_usage
    (    attach_status: pft$attach_status;
         usage_intentions: pft$permit_selections): boolean;

    VAR
      busy: boolean,
      usage_option: pft$usage_options;

    busy := FALSE;

    FOR usage_option := LOWERVALUE (usage_option) TO UPPERVALUE (usage_option) DO
      busy := (busy OR ((usage_option IN usage_intentions) AND
            (attach_status.prevent_usage_counts [usage_option] > 0)));
    FOREND;

    cycle_busy_due_to_usage := busy;
  FUNCEND cycle_busy_due_to_usage;

?? TITLE := '  [INLINE] decrement_attach_status', EJECT ??
{       DECREMENT_ATTACH_STATUS
{
{   The purpose of this procedure is to decrement the attach status to reflect
{ that the activity, as indicated by the usage_selections and share_selections
{ parameters, has stopped.

  PROCEDURE [INLINE] decrement_attach_status
    (    old_attach_status: pft$attach_status;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
     VAR new_attach_status: pft$attach_status);

    VAR
      share_option: pft$share_options,
      usage_option: pft$usage_options;

    new_attach_status := old_attach_status;
    new_attach_status.attach_count := new_attach_status.attach_count - 1;

    FOR usage_option := LOWERVALUE (usage_option) TO UPPERVALUE (usage_option) DO
      IF usage_option IN usage_selections THEN
        new_attach_status.usage_counts [usage_option] := new_attach_status.usage_counts [usage_option] - 1;
      IFEND;
    FOREND;

    FOR share_option := LOWERVALUE (share_option) TO UPPERVALUE (share_option) DO
      IF NOT (share_option IN share_selections) THEN
        new_attach_status.prevent_usage_counts [share_option] :=
              new_attach_status.prevent_usage_counts [share_option] - 1;
      IFEND;
    FOREND;
  PROCEND decrement_attach_status;

?? TITLE := '  [INLINE]  decrement_mainframe_usage', EJECT ??

{ PURPOSE:
{   This procedure updates the mainframe usage to reflect that the specified
{   usage is no longer in effect.

  PROCEDURE [INLINE] decrement_mainframe_usage
    (    usage_selections: pft$usage_selections;
     VAR mainframe_usage {input, output} : pft$mainframe_usage_entry);

    mainframe_usage.attach_count := mainframe_usage.attach_count - 1;
    IF (usage_selections * pfv$write_usage) <> $pft$usage_selections [] THEN
      mainframe_usage.write_count := mainframe_usage.write_count - 1;
    IFEND;
  PROCEND decrement_mainframe_usage;

?? TITLE := '  decrement_usage_counts', EJECT ??

{ PURPOSE:
{   This procedure decrements the attach status and the mainframe usage
{   to reflect that the cycle is no longer used for the specified access and
{   share.

  PROCEDURE decrement_usage_counts
    (    usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
         mainframe_id: pmt$binary_mainframe_id;
         p_catalog_file: {input^} ^pft$catalog_file;
     VAR cycle_entry: {input, output} pft$cycle_entry);

    VAR
      first_mainframe: boolean,
      mainframe_found: boolean,
      p_physical_mainframe_usage: ^pft$physical_mainframe_usage;

    decrement_attach_status (cycle_entry.attach_status, usage_selections, share_selections,
          cycle_entry.attach_status);

    locate_mainframe_usage (mainframe_id, cycle_entry, p_catalog_file, mainframe_found, first_mainframe,
          p_physical_mainframe_usage);
    IF mainframe_found THEN
      IF first_mainframe THEN
        decrement_mainframe_usage (usage_selections, cycle_entry.first_mainframe_usage_entry);
      ELSE
        decrement_mainframe_usage (usage_selections, p_physical_mainframe_usage^.mainframe_usage);
        pfp$compute_checksum (#LOC (p_physical_mainframe_usage^.mainframe_usage),
              #SIZE (p_physical_mainframe_usage^.mainframe_usage), p_physical_mainframe_usage^.checksum);
      IFEND;
    IFEND;
  PROCEND decrement_usage_counts;

?? TITLE := '  delete_permit_description', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to delete the permit description for a
{   specified group from a permit list.
{
{ DESIGN:
{   If no permit description is found, a warning level abnormal status is
{   returned.  If the permit list is contracted as a result of deleting the
{   permit description, a new, smaller permit list is created and the old
{   permit list is copied to the new list.

  PROCEDURE delete_permit_description
    (    path: pft$complete_path;
         group: pft$group;
         p_object: {i^/o^} pft$p_object;
         p_catalog_file: {i^/o^} pft$p_catalog_file;
     VAR status: ost$status);

    VAR
      p_permit: pft$p_permit;

    locate_group (p_object^.object_entry.permit_list_locator, p_catalog_file, group, p_permit);
    IF p_permit = NIL THEN
      osp$set_status_condition (pfe$no_permit_deleted, status);
    ELSE
      p_permit^.permit_entry.entry_type := pfc$free_permit_entry;
      pfp$compute_checksum (#LOC (p_permit^.permit_entry), #SIZE (pft$permit_entry), p_permit^.checksum);
      contract_permit_list (path, p_object, p_catalog_file, status);
    IFEND;
  PROCEND delete_permit_description;

?? TITLE := '  [INLINE] determine_share_with_fs_select', EJECT ??

{ PURPOSE:
{   This procedure determines the user's share requirements based on
{   the user's permit and also defaults the share selections if either
{   fsc$determine_from_access_modes or fsc$required_share_modes was
{   specified.  This procedure takes into account usage by other jobs when
{   determining fsc$required_share_modes.

  PROCEDURE [INLINE] determine_share_with_fs_select
    (    usage_selections: pft$usage_selections;
         share_modes: fst$share_modes;
         authority: pft$authority;
         permit_entry: pft$permit_entry;
         cycle_entry: pft$cycle_entry;
         device_class: rmt$device_class;
     VAR sharing_required: pft$share_selections;
     VAR share_selections: pft$share_selections);

    VAR
      share_option: pft$share_options;

    IF device_class = rmc$mass_storage_device THEN
      IF (pfc$system_owner IN authority.ownership) OR (pfc$family_owner IN authority.ownership) THEN
        sharing_required := $pft$share_selections [];
      ELSE
        sharing_required := permit_entry.share_requirements;
      IFEND;

      CASE share_modes.selector OF
      = fsc$determine_from_access_modes =
        IF (usage_selections * pfv$write_usage) = $pft$usage_selections [] THEN
          share_selections := $pft$share_selections [pfc$execute, pfc$read];
        ELSE
          share_selections := $pft$share_selections [];
        IFEND;

      = fsc$required_share_modes =
        share_selections := sharing_required;

      /determine_share_selections/
        FOR share_option := LOWERVALUE (share_option) TO UPPERVALUE (share_option) DO
          IF cycle_entry.attach_status.usage_counts [share_option] > 0 THEN
            share_selections := share_selections + $pft$share_selections [share_option];
          IFEND;
        FOREND /determine_share_selections/;

      = fsc$specific_share_modes =
        #UNCHECKED_CONVERSION (share_modes.value, share_selections);
      CASEND;

    ELSEIF device_class = rmc$mass_storage_device THEN
      sharing_required := $pft$share_selections [];
      share_selections := $pft$share_selections [];
    IFEND;

  PROCEND determine_share_with_fs_select;

?? TITLE := '  [INLINE] determine_share_with_pf_option', EJECT ??

{ PURPOSE:
{   This procedure determines the user's share requirements based on
{   the user's permit and also determines the share selections based upon
{   the share option selected, either pfc$specific_share_option, or
{   pfc$default_share_option.

  PROCEDURE [INLINE] determine_share_with_pf_option
    (    share_selector: pft$share_selector;
         permit_entry: pft$permit_entry;
         usage_selections: pft$usage_selections;
     VAR share_selections: pft$share_selections;
     VAR required_share_selections: pft$share_selections);

    IF permit_entry.entry_type = pfc$normal_permit_entry THEN
      required_share_selections := permit_entry.share_requirements;
    ELSE
      required_share_selections := - $pft$share_selections [];
    IFEND;

    IF share_selector.option = pfc$specific_share_option THEN
      share_selections := share_selector.share_selections;
    ELSE {pfc$default_share_option
      IF (usage_selections * pfv$write_usage) = $pft$usage_selections [] THEN
        share_selections := $pft$share_selections [pfc$read, pfc$execute];
      ELSE
        share_selections := $pft$share_selections [];
      IFEND;
    IFEND;
  PROCEND determine_share_with_pf_option;

?? TITLE := '  determine_usage_allowed', EJECT ??

{ PURPOSE:
{   This procedure determines the user's allowed usage.
{
{ DESIGN:
{   If fsc$permitted_access_modes was specified, the usage is determined based
{   upon the user's permit, upon sharing allowed in other jobs, and upon usage
{   on other mainframes.

  PROCEDURE determine_usage_allowed
    (    path: pft$complete_path;
         cycle_reference: fst$cycle_reference;
         mainframe_id: pmt$binary_mainframe_id;
         access_modes: fst$access_modes;
         authority: pft$authority;
         permit_entry: pft$permit_entry;
         cycle_entry: pft$cycle_entry;
         p_catalog_file: {input^} ^pft$catalog_file;
     VAR usage_allowed: pft$usage_selections;
     VAR usage_selections: pft$usage_selections;
     VAR multiple_job_usage_selections: pft$usage_selections;
     VAR status: ost$status);

    VAR
      fs_path_size: fst$path_size,
      p_fs_path: ^fst$path,
      p_mainframe_usage_list: ^pft$mainframe_usage_list,
      selections_string: pft$selections_string,
      usage_option: pft$usage_options;

    status.normal := TRUE;
    IF access_modes.selector = fsc$permitted_access_modes THEN
      IF (pfc$system_owner IN authority.ownership) OR (pfc$family_owner IN authority.ownership) THEN
        usage_allowed := - $pft$usage_selections [];
        usage_selections := $pft$usage_selections [];

      /determine_usage_selections/
        FOR usage_option := LOWERVALUE (usage_option) TO UPPERVALUE (usage_option) DO
          IF cycle_entry.attach_status.prevent_usage_counts [usage_option] = 0 THEN
            usage_selections := usage_selections + $pft$usage_selections [usage_option];
          IFEND;
        FOREND /determine_usage_selections/;
      ELSEIF permit_entry.usage_permissions <= $pft$permit_selections [pfc$cycle, pfc$control] THEN
        usage_selections := $pft$usage_selections [];
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$usage_not_permitted,
              p_fs_path^ (1, fs_path_size), status);
        pfp$build_permit_selections_str (permit_entry.usage_permissions, selections_string);
        osp$append_status_parameter (osc$status_parameter_delimiter, selections_string.
              value (1, selections_string.size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'null set', status);
        IF permit_entry.usage_permissions = $pft$permit_selections [] THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, pfc$usage_self_denied, status);
        IFEND;
        RETURN;
      ELSE
        usage_allowed := $pft$usage_selections [];
        usage_selections := $pft$usage_selections [];

      /determine_permitted_and_usage/
        FOR usage_option := LOWERVALUE (usage_option) TO UPPERVALUE (usage_option) DO
          IF usage_option IN permit_entry.usage_permissions THEN
            usage_allowed := usage_allowed + $pft$usage_selections [usage_option];
            IF cycle_entry.attach_status.prevent_usage_counts [usage_option] = 0 THEN
              usage_selections := usage_selections + $pft$usage_selections [usage_option];
            IFEND;
          IFEND;
        FOREND /determine_permitted_and_usage/;
      IFEND;

      multiple_job_usage_selections := usage_selections;
      {
      { If another mainframe is using the cycle remove write usage.
      {
      IF (usage_selections * pfv$write_usage <> $pft$usage_selections []) AND
            (cycle_entry.attach_status.attach_count > 0) THEN
        pfp$build_mainfram_list_pointer (cycle_entry.mainframe_usage_list_locator,
               p_catalog_file, p_mainframe_usage_list);
        IF other_mainframe_using (mainframe_id, cycle_entry, p_mainframe_usage_list) THEN
          usage_selections := usage_selections - pfv$write_usage;
        IFEND;
      IFEND;
    ELSE {fsc$specific_access_modes}
      #UNCHECKED_CONVERSION (access_modes.value, usage_selections);
      multiple_job_usage_selections := usage_selections;
      IF (pfc$system_owner IN authority.ownership) OR (pfc$family_owner IN authority.ownership) THEN
        usage_allowed := - $pft$usage_selections [];
      ELSE
        usage_allowed := $pft$usage_selections [];

      /determine_permitted_usage/
        FOR usage_option := LOWERVALUE (usage_option) TO UPPERVALUE (usage_option) DO
          IF usage_option IN permit_entry.usage_permissions THEN
            usage_allowed := usage_allowed + $pft$usage_selections [usage_option];
          IFEND;
        FOREND /determine_permitted_usage/;
      IFEND;
    IFEND;
  PROCEND determine_usage_allowed;

?? TITLE := '  [INLINE] determine_usage_permitted', EJECT ??

{ PURPOSE:
{   This procedure determines the users selected usage based either on
{   specifically requested usage, or based on the usage permitted.  This
{   procedure also determines the users permitted usage.

  PROCEDURE [INLINE] determine_usage_permitted
    (    usage_selector: pft$usage_selector;
         permit_entry: pft$permit_entry;
     VAR usage_selections: pft$usage_selections;
     VAR permitted_usage_selections: pft$usage_selections);

    VAR
      usage_option: pft$usage_options;

    permitted_usage_selections := $pft$usage_selections [];

    IF permit_entry.entry_type = pfc$normal_permit_entry THEN
      FOR usage_option := LOWERVALUE (usage_option) TO UPPERVALUE (usage_option) DO
        IF usage_option IN permit_entry.usage_permissions THEN
          permitted_usage_selections := permitted_usage_selections + $pft$usage_selections [usage_option];
        IFEND;
      FOREND;
    IFEND;

    IF usage_selector.option = pfc$specific_usage_option THEN
      usage_selections := usage_selector.usage_selections;
    ELSE {pfc$allowed_usage_option
      usage_selections := permitted_usage_selections;
    IFEND;
  PROCEND determine_usage_permitted;

?? TITLE := '  dm_attach_file', EJECT ??
{ This routine will call device manager to attach a permanent_file.
{ If the fmd requires reconciliation it will performed.
{ When dmp$attach encounters a file that was attached by pfp$restricted_attach
{ it does not attach the file and returns the value dmc$restricted_attach_entry
{ in the EXISTING_SFT_ENTRY parameter. If this value is returned the FMD
{ will be reconciled and dmp$attach_file will be called again.
{ Since this routine is used to attach all files during job recovery
{ this is the only attach that should encounter a file previously
{ attached by restricted attach.

  PROCEDURE dm_attach_file
    (    path: pft$complete_path;
         p_catalog_file: {input^} pft$p_catalog_file;
         usage_intentions: pft$usage_selections;
         share_selections: pft$share_selections;
         p_cycle: {i^/o^} pft$p_cycle;
     VAR system_file_id: gft$system_file_identifier;
     VAR file_damaged: boolean;
     VAR status: ost$status);

    CONST
      update_catalog = TRUE;

    VAR
      existing_sft_entry: dmt$existing_sft_entry,
      exit_on_unknown_file: boolean,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      p_physical_fmd: pft$p_physical_fmd,
      recorded_vsn: rmt$recorded_vsn;

    pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, p_catalog_file, p_physical_fmd);
    IF p_physical_fmd = NIL THEN
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$undefined_data, fs_path (1, fs_path_size),
            status);
      osp$append_status_integer (osc$status_parameter_delimiter, p_cycle^.cycle_entry.cycle_number,
            10, FALSE, status);
    ELSE
      {exit_on_unknown_file := cycle attached for write access
      exit_on_unknown_file := (p_cycle^.cycle_entry.attach_status.attach_count > 0) AND
           ((p_cycle^.cycle_entry.attach_status.usage_counts[pfc$shorten] > 0) OR
           (p_cycle^.cycle_entry.attach_status.usage_counts[pfc$append] > 0) OR
           (p_cycle^.cycle_entry.attach_status.usage_counts[pfc$modify] > 0));

      dmp$attach_file (p_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file,
            p_physical_fmd^.fmd, usage_intentions, share_selections, pfc$average_share_history,
            pfc$maximum_pf_length, {restricted_attach} FALSE, exit_on_unknown_file, {server_file} FALSE,
            pfp$shared_queue (p_cycle^.cycle_entry.shared_queue_info, share_selections), file_damaged,
            system_file_id, existing_sft_entry, status);
      IF status.normal THEN
        pfp$reconcile_fmd (^path, p_cycle^.cycle_entry.internal_cycle_name, existing_sft_entry,
              update_catalog, p_catalog_file, p_cycle, p_physical_fmd, status);
        IF status.normal AND ((existing_sft_entry = dmc$restricted_attach_entry) OR
              (exit_on_unknown_file AND (existing_sft_entry = dmc$entry_not_found))) THEN
          dmp$attach_file (p_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file,
                p_physical_fmd^.fmd, usage_intentions, share_selections, pfc$average_share_history,
                pfc$maximum_pf_length, {restricted_attach} FALSE, {exit_on_unknown_file} FALSE,
                {server_file} FALSE,
                pfp$shared_queue (p_cycle^.cycle_entry.shared_queue_info, share_selections), file_damaged,
                system_file_id, existing_sft_entry, status);
        IFEND;
      IFEND;

      IF NOT status.normal THEN
        pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
        IF status.condition = dme$volume_unavailable THEN
          recorded_vsn := status.text.value (2, 6);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$volume_unavailable,
                fs_path (1, fs_path_size), status);
          osp$append_status_parameter (osc$status_parameter_delimiter, recorded_vsn, status);
        ELSEIF status.condition = dme$some_volumes_not_online THEN
          recorded_vsn := status.text.value (2, 6);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$volume_not_online,
                fs_path (1, fs_path_size), status);
          osp$append_status_parameter (osc$status_parameter_delimiter, recorded_vsn, status);
        ELSE
          pfp$report_unexpected_status (status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND dm_attach_file;

?? TITLE := '  establish_free_log_entry', EJECT ??
{       ESTABLISH_FREE_LOG_ENTRY
{
{   The purpose of this procedure is to establish a free log entry in a log
{ list.  This is accomplished by either finding an existing free entry or by
{ expanding the log list to create a free entry.  If it is necessary to expand
{ the log list, a new, larger log list is created and the old list is copied to
{ the new list.  NOTE: It is the responsibility of the caller to FREE the old
{ log list if a new log list has been created.

  PROCEDURE establish_free_log_entry
    (    p_catalog_heap: {output^} pft$p_catalog_heap;
     VAR p_log_list: {i/o} pft$p_log_list;
     VAR p_new_log_list: {output} pft$p_log_list;
     VAR new_log_list: boolean;
     VAR p_log: {output} pft$p_log;
     VAR status: ost$status);

    VAR
      free_physical_log: pft$physical_log,
      log_index: pft$log_index;


    PROCEDURE [INLINE] locate_free_log_entry
      (    p_log_list: {input} pft$p_log_list;
       VAR p_log: {output} pft$p_log);

      VAR
        log_index: pft$log_index;

      IF p_log_list <> NIL THEN
        FOR log_index := 1 TO UPPERBOUND (p_log_list^) DO
          IF p_log_list^ [log_index].log_entry.entry_type = pfc$free_log_entry THEN
            p_log := ^p_log_list^ [log_index];
            RETURN;
          IFEND;
        FOREND;
      IFEND;

      p_log := NIL;
    PROCEND locate_free_log_entry;


    status.normal := TRUE;
    new_log_list := FALSE;

    locate_free_log_entry (p_log_list, p_log);
    IF p_log = NIL THEN
      IF p_log_list = NIL THEN
        pfp$allocate_log_list (0, p_catalog_heap, p_new_log_list, status);
        IF status.normal THEN
          free_physical_log.log_entry.entry_type := pfc$free_log_entry;
          pfp$compute_checksum (#LOC (free_physical_log.log_entry), #SIZE (pft$log_entry),
                free_physical_log.checksum);

          FOR log_index := 1 TO UPPERBOUND (p_new_log_list^) DO
            p_new_log_list^ [log_index] := free_physical_log;
          FOREND;

          p_log := ^p_new_log_list^ [1];
          new_log_list := TRUE;
        IFEND;
      ELSE { A log list already exists.
        pfp$allocate_log_list (UPPERBOUND (p_log_list^), p_catalog_heap, p_new_log_list, status);
        IF status.normal THEN
          i#move (#LOC (p_log_list^), #LOC (p_new_log_list^), #SIZE (p_log_list^));

          free_physical_log.log_entry.entry_type := pfc$free_log_entry;
          pfp$compute_checksum (#LOC (free_physical_log.log_entry), #SIZE (pft$log_entry),
                free_physical_log.checksum);

          FOR log_index := UPPERBOUND (p_log_list^) + 1 TO UPPERBOUND (p_new_log_list^) DO
            p_new_log_list^ [log_index] := free_physical_log;
          FOREND;

          p_log := ^p_new_log_list^ [UPPERBOUND (p_log_list^) + 1];
          new_log_list := TRUE;
        IFEND;
      IFEND;
    IFEND;
  PROCEND establish_free_log_entry;

?? TITLE := '  establish_free_mainframe_entry', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to establish a free mainframe entry.
{   If this is the first mainframe using the cycle, then the mainframe entry
{   in the cycle entry will be used, and first_mainframe will be returned as
{   TRUE, and the p_physical_mainframe_entry parameter is not initialized.
{   If the mainframe entry in the cycle entry is not free, then the
{   mainframe usage list is searched for a free entry, and optionally a new
{   list is allocated. In this case a pointer to the mainframe entry is
{   returned.
{   This procedure assumes that the cycle entry checksum will be recomputed
{   subsequent to this call.

  PROCEDURE establish_free_mainframe_entry
    (    path: pft$complete_path;
         p_catalog_file: {input^, output^} ^pft$catalog_file;
     VAR cycle_entry: {input, output} pft$cycle_entry;
     VAR first_mainframe: boolean;
     VAR p_physical_mainframe_entry: ^pft$physical_mainframe_usage;
     VAR status: ost$status);

    VAR
      p_mainframe_usage_list: ^pft$mainframe_usage_list,
      p_new_mainframe_usage_list: ^pft$mainframe_usage_list,
      prevalidate_free_result: ost$prevalidate_free_result;

    status.normal := TRUE;

    IF cycle_entry.first_mainframe_usage_entry.entry_type = pfc$free_mainframe_entry THEN
      first_mainframe := TRUE;
    ELSE
      first_mainframe := FALSE;
      pfp$build_mainfram_list_pointer (cycle_entry.mainframe_usage_list_locator, p_catalog_file,
            p_mainframe_usage_list);
      IF p_mainframe_usage_list = NIL THEN
        ALLOCATE p_mainframe_usage_list: [1 .. 1] IN p_catalog_file^.catalog_heap;
        IF p_mainframe_usage_list = NIL THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, 'mainframe list', status);
        ELSE
          p_physical_mainframe_entry := ^p_mainframe_usage_list^ [1];
          pfp$build_mainfram_list_locator (p_mainframe_usage_list, p_catalog_file,
                cycle_entry.mainframe_usage_list_locator);
        IFEND;
      ELSE { A mainframe list already exists
        locate_free_mainframe_entry (p_mainframe_usage_list, p_physical_mainframe_entry);
        IF p_physical_mainframe_entry = NIL THEN
          ALLOCATE p_new_mainframe_usage_list: [1 .. (UPPERBOUND (p_mainframe_usage_list^) + 1)] IN
                p_catalog_file^.catalog_heap;
          IF p_new_mainframe_usage_list = NIL THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, 'New mainframe list',
                  status);
          ELSE
            i#move (#LOC (p_mainframe_usage_list^), #LOC (p_new_mainframe_usage_list^),
                  #SIZE (p_mainframe_usage_list^));
            p_physical_mainframe_entry := ^p_new_mainframe_usage_list^
                  [UPPERBOUND (p_new_mainframe_usage_list^)];
            pfp$build_mainfram_list_locator (p_new_mainframe_usage_list, p_catalog_file,
                  cycle_entry.mainframe_usage_list_locator);
            osp$prevalidate_free ((#OFFSET(p_mainframe_usage_list) -
                  #OFFSET(^p_catalog_file^.catalog_heap) - 16),
                  ^p_catalog_file^.catalog_heap, prevalidate_free_result);
            IF prevalidate_free_result = osc$heap_free_valid THEN
              FREE p_mainframe_usage_list IN p_catalog_file^.catalog_heap;
            ELSE
              pfp$report_invalid_free (^path, ^cycle_entry.cycle_number, 'MAINFRAME_USAGE_LIST', 'file',
                    prevalidate_free_result, #OFFSET(p_mainframe_usage_list));
              p_mainframe_usage_list := NIL;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND establish_free_mainframe_entry;

?? TITLE := '  establish_free_permit_entry', EJECT ??

  PROCEDURE establish_free_permit_entry
    (    path: pft$complete_path;
         p_object: {i^/o^} pft$p_object;
         p_catalog_file: {i^/o^} pft$p_catalog_file;
     VAR p_permit: {output} pft$p_permit;
     VAR status: ost$status);

    VAR
      free_physical_permit: pft$physical_permit,
      p_new_permit_list: pft$p_permit_list,
      p_permit_list: pft$p_permit_list,
      permit_index: pft$permit_index,
      prevalidate_free_result: ost$prevalidate_free_result;


    PROCEDURE [INLINE] locate_free_permit_entry
      (    p_permit_list: {input} pft$p_permit_list;
       VAR p_permit: {output} pft$p_permit);

      VAR
        permit_index: pft$permit_index;

      IF p_permit_list <> NIL THEN
        FOR permit_index := 1 TO UPPERBOUND (p_permit_list^) DO
          IF p_permit_list^ [permit_index].permit_entry.entry_type = pfc$free_permit_entry THEN
            p_permit := ^p_permit_list^ [permit_index];
            RETURN;
          IFEND;
        FOREND;
      IFEND;

      p_permit := NIL;
    PROCEND locate_free_permit_entry;


    status.normal := TRUE;

    pfp$build_permit_list_pointer (p_object^.object_entry.permit_list_locator, p_catalog_file, p_permit_list);
    locate_free_permit_entry (p_permit_list, p_permit);
    IF p_permit = NIL THEN
      IF p_permit_list = NIL THEN
        pfp$allocate_permit_list (0, ^p_catalog_file^.catalog_heap, p_new_permit_list, status);
        IF status.normal THEN
          free_physical_permit.permit_entry.entry_type := pfc$free_permit_entry;
          pfp$compute_checksum (#LOC (free_physical_permit.permit_entry), #SIZE (pft$permit_entry),
                free_physical_permit.checksum);

          FOR permit_index := 1 TO UPPERBOUND (p_new_permit_list^) DO
            p_new_permit_list^ [permit_index] := free_physical_permit;
          FOREND;

          p_permit := ^p_new_permit_list^ [1];
          {
          { To make the catalog crash resistant, write the new permit list to
          { permanent storage and then update the object that owns the new
          { permit list.
          {
          pfp$build_permit_list_locator (p_new_permit_list, p_catalog_file,
                p_object^.object_entry.permit_list_locator);
          pfp$compute_checksum (#LOC (p_object^.object_entry), #SIZE (pft$object_entry), p_object^.checksum);
        IFEND;
      ELSE { A permit list already exists.
        pfp$allocate_permit_list (UPPERBOUND (p_permit_list^), ^p_catalog_file^.catalog_heap,
              p_new_permit_list, status);
        IF status.normal THEN
          i#move (#LOC (p_permit_list^), #LOC (p_new_permit_list^), #SIZE (p_permit_list^));

          free_physical_permit.permit_entry.entry_type := pfc$free_permit_entry;
          pfp$compute_checksum (#LOC (free_physical_permit.permit_entry), #SIZE (pft$permit_entry),
                free_physical_permit.checksum);

          FOR permit_index := UPPERBOUND (p_permit_list^) + 1 TO UPPERBOUND (p_new_permit_list^) DO
            p_new_permit_list^ [permit_index] := free_physical_permit;
          FOREND;

          p_permit := ^p_new_permit_list^ [UPPERBOUND (p_permit_list^) + 1];
          {
          { To make the catalog crash resistant, write the new permit list to
          { permanent storage, update the object that owns the new permit
          { list, and then free the old permit list.
          {
          pfp$build_permit_list_locator (p_new_permit_list, p_catalog_file,
                p_object^.object_entry.permit_list_locator);
          pfp$compute_checksum (#LOC (p_object^.object_entry), #SIZE (pft$object_entry), p_object^.checksum);
          osp$prevalidate_free ((#OFFSET(p_permit_list) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
                ^p_catalog_file^.catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_permit_list IN p_catalog_file^.catalog_heap;
          ELSE
            IF p_object^.object_entry.object_type = pfc$file_object THEN
              pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'PERMIT_LIST', 'file',
                    prevalidate_free_result, #OFFSET(p_permit_list));
            ELSE
              pfp$report_invalid_free (^path, {p_cycle_number} NIL, 'PERMIT_LIST', 'catalog',
                    prevalidate_free_result, #OFFSET(p_permit_list));
            IFEND;
            p_permit_list := NIL;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND establish_free_permit_entry;

?? TITLE := '  find_family_location', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to determine on which mainframe the
{   specified family resides.

  PROCEDURE find_family_location
    (    family_name: ost$family_name;
     VAR served_family: boolean;
     VAR served_family_locator: pft$served_family_locator);

    VAR
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index,
      self_serving: boolean,
      server_state: dft$server_state;

    served_family_locator.server_location.server_location_selector := dfc$served_family_table_index;
    dfp$locate_served_family (family_name, served_family, served_family_locator.served_family_table_index,
          served_family_locator.server_mainframe_id,
          p_queue_interface_table,
          queue_index, server_state);
    IF served_family THEN
      served_family_locator.server_location.served_family_table_index :=
            served_family_locator.served_family_table_index;
      dfp$check_self_serving_job (served_family_locator.server_mainframe_id, self_serving);
      served_family := NOT self_serving;
      #KEYPOINT (osk$debug, osk$m * queue_index,
            pfk$file_server_request);
    IFEND;
  PROCEND find_family_location;

?? TITLE := '  form_expiration_date_time', EJECT ??
{
{   The purpose of this procedure is to form the expiration date and time from
{ the current date and time and the retention period.

  PROCEDURE form_expiration_date_time
    (    current_date: ost$date_time;
         fs_retention: fst$retention;
     VAR expiration_date: ost$date_time);

    VAR
      local_expiration_date: ost$date_time,
      local_status: ost$status,
      time_increment: pmt$time_increment;

    local_expiration_date := current_date;

    CASE fs_retention.selector OF
    = fsc$retention_day_increment =
      local_expiration_date.hour := 23;
      local_expiration_date.minute := 59;
      local_expiration_date.second := 59;
      local_expiration_date.millisecond := 999;
      IF fs_retention.day_increment = UPPERVALUE (pft$retention) THEN
        local_expiration_date.year := UPPERVALUE (local_expiration_date.year);
        local_expiration_date.month := 12;
        local_expiration_date.day := 31;
      ELSE
        time_increment.year := 0;
        time_increment.month := 0;
        time_increment.day := fs_retention.day_increment;
        time_increment.hour := 0;
        time_increment.minute := 0;
        time_increment.second := 0;
        time_increment.millisecond := 0;
        pmp$compute_date_time (current_date, time_increment, local_expiration_date, local_status);
        pfp$process_unexpected_status (local_status);
      IFEND;

    = fsc$retention_time_increment =
      time_increment := fs_retention.time_increment;
      pmp$compute_date_time (current_date, time_increment, local_expiration_date, local_status);
      pfp$process_unexpected_status (local_status);

    = fsc$retention_expiration_date =
      local_expiration_date := fs_retention.expiration_date;
    CASEND;

    expiration_date := local_expiration_date;

  PROCEND form_expiration_date_time;

?? TITLE := '  [INLINE] increment_attach_status', EJECT ??

{       INCREMENT_ATTACH_STATUS
{
{   The purpose of this procedure is to increment attach status to reflect the
{ additional activity indicated by the usage_selections and share_selections
{ parameters.

  PROCEDURE [INLINE] increment_attach_status
    (    old_attach_status: pft$attach_status;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
     VAR new_attach_status: pft$attach_status);

    VAR
      share_option: pft$share_options,
      usage_option: pft$usage_options;

    new_attach_status := old_attach_status;
    new_attach_status.attach_count := new_attach_status.attach_count + 1;

    FOR usage_option := LOWERVALUE (usage_option) TO UPPERVALUE (usage_option) DO
      IF usage_option IN usage_selections THEN
        new_attach_status.usage_counts [usage_option] := new_attach_status.usage_counts [usage_option] + 1;
      IFEND;
    FOREND;

    FOR share_option := LOWERVALUE (share_option) TO UPPERVALUE (share_option) DO
      IF NOT (share_option IN share_selections) THEN
        new_attach_status.prevent_usage_counts [share_option] :=
              new_attach_status.prevent_usage_counts [share_option] + 1;
      IFEND;
    FOREND;
  PROCEND increment_attach_status;

?? TITLE := '  [INLINE] increment_mainframe_usage', EJECT ??

{ PURPOSE:
{   This procedure updates the mainframe usage to reflect the additional usage.

  PROCEDURE [INLINE] increment_mainframe_usage
    (    usage_selections: pft$usage_selections;
     VAR mainframe_usage {input, output} : pft$mainframe_usage_entry);

    mainframe_usage.attach_count := mainframe_usage.attach_count + 1;
    IF (usage_selections * pfv$write_usage) <> $pft$usage_selections [] THEN
      mainframe_usage.write_count := mainframe_usage.write_count + 1;
    IFEND;
  PROCEND increment_mainframe_usage;

?? TITLE := '  internal_locate_cycle', EJECT ??
{       INTERNAL_LOCATE_CYCLE
{
{   The purpose of this routine is to locate the specified cycle for the
{ specified file object.  If the selected cycle cannot be found, an error
{ status is returned.

  PROCEDURE internal_locate_cycle
    (    p_cycle_list: {input} pft$p_cycle_list;
         internal_cycle_name: pft$internal_name;
     VAR p_cycle: {output} pft$p_cycle;
     VAR status: ost$status);

    VAR
      cycle_index: pft$cycle_index;

    status.normal := TRUE;
    p_cycle := NIL;

    IF p_cycle_list <> NIL THEN
      FOR cycle_index := 1 TO UPPERBOUND (p_cycle_list^) DO
        IF (p_cycle_list^ [cycle_index].cycle_entry.entry_type <> pfc$free_cycle_entry) AND
              (p_cycle_list^ [cycle_index].cycle_entry.internal_cycle_name = internal_cycle_name) THEN
          p_cycle := ^p_cycle_list^ [cycle_index];
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    IF p_cycle = NIL THEN
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error, '', status);
      #KEYPOINT (osk$unusual, 0, pfk$unknown_internal_cycle);
    IFEND;
  PROCEND internal_locate_cycle;

?? TITLE := '  locate_cycle_on_active_device', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to determine whether or not a cycle exists
{   on an active volume.
{
{ DESIGN:
{   An attempt to attach the cycle is made using dmp$attach_file.  If abnormal
{   status is returned, the status condition will be examined to determine the
{   current status of the volumes on which the cycle resides.

  PROCEDURE locate_cycle_on_active_device
    (    p_path: ^pft$complete_path;
         p_cycle: {i^/o^} pft$p_cycle;
         fmd: pft$fmd;
         p_catalog_file: {i^/o^} pft$p_catalog_file;
     VAR cycle_on_missing_volume: boolean;
     VAR cycle_on_unavailable_volume: boolean;
     VAR status: ost$status);

    VAR
      existing_sft_entry: dmt$existing_sft_entry,
      file_damaged: boolean,
      file_info: dmt$file_information,
      file_modified: boolean,
      fmd_modified: boolean,
      local_status: ost$status,
      sfid: gft$system_file_identifier;

    cycle_on_missing_volume := FALSE;
    cycle_on_unavailable_volume := FALSE;

    dmp$attach_file (p_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file, fmd,
          $pft$usage_selections [pfc$read], -$pft$share_selections [], pfc$average_share_history,
          pfc$maximum_pf_length, {restricted_attach} FALSE, {exit_on_unknown_file} FALSE,
          {server_file} FALSE,
          pfp$shared_queue (p_cycle^.cycle_entry.shared_queue_info, -$pft$share_selections []), file_damaged,
          sfid, existing_sft_entry, status);
    IF status.normal THEN
      pfp$detach_permanent_file (p_path, sfid, $pft$usage_selections [], {catalog_access_allowed} TRUE,
            p_cycle, p_catalog_file, fmd_modified, file_info, local_status);
      pfp$process_unexpected_status (local_status);
    ELSEIF status.condition = dme$some_volumes_not_online THEN
      cycle_on_missing_volume := TRUE;
      status.normal := TRUE;
    ELSEIF status.condition = dme$volume_unavailable THEN
      cycle_on_unavailable_volume := TRUE;
      status.normal := TRUE;
    ELSE
      pfp$report_unexpected_status (status);
    IFEND;
  PROCEND locate_cycle_on_active_device;

?? TITLE := '  locate_cycle_on_selected_volume', EJECT ??
{         LOCATE_CYCLE_ON_SELECTED_VOLUME
{
{ The purpose of this procedure is to determine if any portion of a
{ specific cycle exists on the volumes specfied by a previous
{ INCLUDE_VOLUMES subcommand.

  PROCEDURE locate_cycle_on_selected_volume
    (    p_fmd: {input} pft$p_fmd;
         p_included_volume_list: {input} ^pft$volume_list;
     VAR cycle_on_selected_volume: boolean;
     VAR status: ost$status);

    VAR
      fmd_header: pft$fmd_header,
      fmd_volume_index: dmt$subfile_index,
      included_volume_index: dmt$subfile_index,
      p_fmd_volume_list: ^pft$volume_list,
      p_stored_fmd: ^dmt$stored_fmd;

    cycle_on_selected_volume := FALSE;
    status.normal := TRUE;

    IF p_included_volume_list = NIL THEN
      cycle_on_selected_volume := TRUE;
    ELSE
      p_stored_fmd := p_fmd;
      RESET p_stored_fmd;

      dmp$get_stored_fmd_header_info (p_stored_fmd, fmd_header, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF fmd_header.number_of_subfiles > 0 THEN
        PUSH p_fmd_volume_list: [1 .. fmd_header.number_of_subfiles];
        dmp$get_stored_fmd_volume_list (p_stored_fmd, p_fmd_volume_list, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      FOR fmd_volume_index := 1 TO fmd_header.number_of_subfiles DO
        FOR included_volume_index := 1 TO UPPERBOUND (p_included_volume_list^) DO
          IF p_fmd_volume_list^ [fmd_volume_index] = p_included_volume_list^ [included_volume_index] THEN
            cycle_on_selected_volume := TRUE;
            RETURN;
          IFEND;
        FOREND;
      FOREND;
    IFEND;
  PROCEND locate_cycle_on_selected_volume;

?? TITLE := '  [INLINE] locate_free_mainframe_entry', EJECT ??

{ PURPOSE:
{   This procedure searches a mainframe usage list looking for a free mainframe
{   usage list entry.  If no free entry is found p_physical_mainframe_usage is
{   returned as NIL.

  PROCEDURE [INLINE] locate_free_mainframe_entry
    (    p_mainframe_usage_list: {input^} ^pft$mainframe_usage_list;
     VAR p_physical_mainframe_usage: ^pft$physical_mainframe_usage);

    VAR
      mainframe: pft$mainframe_count;

  /search_mainframe_list/
    FOR mainframe := 1 TO UPPERBOUND (p_mainframe_usage_list^) DO
      IF p_mainframe_usage_list^ [mainframe].mainframe_usage.entry_type = pfc$free_mainframe_entry THEN
        p_physical_mainframe_usage := ^p_mainframe_usage_list^ [mainframe];
        RETURN;
      IFEND;
    FOREND /search_mainframe_list/;
    p_physical_mainframe_usage := NIL;
  PROCEND locate_free_mainframe_entry;

?? TITLE := '  locate_group', EJECT ??
{       LOCATE_GROUP
{
{   The purpose of this procedure is to search a permit list and return a
{ pointer to the permit entry that applies to the specified group.  If no
{ permit entry that applies to the group is found, a NIL pointer is returned.

  PROCEDURE locate_group
    (    permit_list_locator: pft$permit_list_locator;
         p_catalog_file: {input^} pft$p_catalog_file;
         group: pft$group;
     VAR p_permit: pft$p_permit);

    VAR
      group_found: boolean,
      p_permit_list: pft$p_permit_list,
      permit_group: pft$group,
      permit_index: pft$permit_index;

    pfp$build_permit_list_pointer (permit_list_locator, p_catalog_file, p_permit_list);
    IF p_permit_list = NIL THEN
      p_permit := NIL;
    ELSE
      FOR permit_index := 1 TO UPPERBOUND (p_permit_list^) DO
        p_permit := ^p_permit_list^ [permit_index];
        IF (p_permit^.permit_entry.entry_type = pfc$normal_permit_entry) AND
              (p_permit^.permit_entry.group.group_type = group.group_type) THEN
          permit_group := p_permit^.permit_entry.group;
          CASE permit_group.group_type OF
          = pfc$public =
            group_found := TRUE;
          = pfc$family =
            group_found := (permit_group.family_description = group.family_description);
          = pfc$account =
            group_found := (permit_group.account_description = group.account_description);
          = pfc$project =
            group_found := (permit_group.project_description = group.project_description);
          = pfc$user =
            group_found := (permit_group.user_description = group.user_description);
          = pfc$user_account =
            group_found := (permit_group.user_account_description = group.user_account_description);
          = pfc$member =
            group_found := (permit_group.member_description = group.member_description);
          ELSE
            group_found := FALSE;
          CASEND;

          IF group_found THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND;

      p_permit := NIL;
    IFEND;
  PROCEND locate_group;

?? TITLE := '  locate_mainframe_usage', EJECT ??

{ PURPOSE:
{   This procedure locates a mainframe in the list of mainframes using the cycle.
{   IF the mainframe is found AND it's the first mainframe, THEN the p_physical_mainframe_usage
{   is not set, and the mainframe was found in the cycle entry. IF the mainframe is found
{   AND it's NOT the first mainframe, then the p_physical_mainframe_usage
{   points to the particular entry in the mainframe usage list.

  PROCEDURE locate_mainframe_usage
    (    mainframe_id: pmt$binary_mainframe_id;
         cycle_entry: pft$cycle_entry;
         p_catalog_file: {input} pft$p_catalog_file;
     VAR mainframe_found: boolean;
     VAR first_mainframe: boolean;
     VAR p_physical_mainframe_usage: ^pft$physical_mainframe_usage);

    VAR
      mainframe_index: pft$mainframe_count,
      p_mainframe_usage_list: ^pft$mainframe_usage_list;

    IF (cycle_entry.first_mainframe_usage_entry.entry_type = pfc$normal_mainframe_entry) AND
          (cycle_entry.first_mainframe_usage_entry.mainframe_id = mainframe_id) THEN
      mainframe_found := TRUE;
      first_mainframe := TRUE;
      RETURN;
    IFEND;

    pfp$build_mainfram_list_pointer (cycle_entry.mainframe_usage_list_locator, p_catalog_file,
          p_mainframe_usage_list);

    IF p_mainframe_usage_list <> NIL THEN

    /search_mainframes/
      FOR mainframe_index := 1 TO UPPERBOUND (p_mainframe_usage_list^) DO
        IF (p_mainframe_usage_list^ [mainframe_index].mainframe_usage.entry_type =
              pfc$normal_mainframe_entry) AND (p_mainframe_usage_list^ [mainframe_index].mainframe_usage.
              mainframe_id = mainframe_id) THEN
          mainframe_found := TRUE;
          first_mainframe := FALSE;
          p_physical_mainframe_usage := ^p_mainframe_usage_list^ [mainframe_index];
          RETURN;
        IFEND;
      FOREND /search_mainframes/;
    IFEND;

    mainframe_found := FALSE;
  PROCEND locate_mainframe_usage;

?? TITLE := '  [INLINE] other_mainframe_using', EJECT ??

{ PURPOSE:
{   The purpose of this function is to determine is a mainframe other
{   than the specified mainframe has the cycle attached.

  FUNCTION [INLINE] other_mainframe_using
    (    mainframe_id: pmt$binary_mainframe_id;
         cycle_entry: pft$cycle_entry;
         p_mainframe_usage_list: {input^} ^pft$mainframe_usage_list) : boolean;

    VAR
      mainframe: pft$mainframe_count;

    IF (cycle_entry.first_mainframe_usage_entry.entry_type = pfc$normal_mainframe_entry) AND
          (cycle_entry.first_mainframe_usage_entry.mainframe_id <> mainframe_id) AND
          (cycle_entry.first_mainframe_usage_entry.attach_count > 0) THEN
      other_mainframe_using := TRUE;
    ELSE
      IF p_mainframe_usage_list <> NIL THEN

      /locate_other_mainframe_using/
        FOR mainframe := 1 TO UPPERBOUND (p_mainframe_usage_list^) DO
          IF (p_mainframe_usage_list^ [mainframe].mainframe_usage.entry_type = pfc$normal_mainframe_entry) AND
                (mainframe_id <> p_mainframe_usage_list^ [mainframe].mainframe_usage.mainframe_id) AND
                (p_mainframe_usage_list^ [mainframe].mainframe_usage.attach_count > 0) THEN
            other_mainframe_using := TRUE;
            RETURN;
          IFEND;
        FOREND /locate_other_mainframe_using/;
      IFEND;
      other_mainframe_using := FALSE;
    IFEND;
  FUNCEND other_mainframe_using;

?? TITLE := '  [INLINE] other_mainframe_writer', EJECT ??

{ PURPOSE:
{   The purpose of this function is to determine if a mainframe other than the
{   specified mainframe has the file attached for write usage.

  FUNCTION [INLINE] other_mainframe_writer
    (    mainframe_id: pmt$binary_mainframe_id;
         cycle_entry: pft$cycle_entry;
         p_mainframe_usage_list: ^pft$mainframe_usage_list) : boolean;

    VAR
      mainframe: pft$mainframe_count;

    IF (cycle_entry.first_mainframe_usage_entry.entry_type = pfc$normal_mainframe_entry) AND
          (cycle_entry.first_mainframe_usage_entry.mainframe_id <> mainframe_id) AND
          (cycle_entry.first_mainframe_usage_entry.write_count > 0) THEN
      other_mainframe_writer := TRUE;
    ELSE
      IF p_mainframe_usage_list <> NIL THEN

      /locate_other_mainframe_writer/
        FOR mainframe := 1 TO UPPERBOUND (p_mainframe_usage_list^) DO
          IF (p_mainframe_usage_list^ [mainframe].mainframe_usage.entry_type = pfc$normal_mainframe_entry) AND
                (mainframe_id <> p_mainframe_usage_list^ [mainframe].mainframe_usage.mainframe_id) AND
                (p_mainframe_usage_list^ [mainframe].mainframe_usage.write_count > 0) THEN
            other_mainframe_writer := TRUE;
            RETURN;
          IFEND;
        FOREND /locate_other_mainframe_writer/;
      IFEND;
      other_mainframe_writer := FALSE;
    IFEND;
  FUNCEND other_mainframe_writer;

?? TITLE := '  pick_modes_for_attach', EJECT ??

  PROCEDURE pick_modes_for_attach
    (    path: pft$complete_path;
         cycle_reference: fst$cycle_reference;
         mainframe_id: pmt$binary_mainframe_id;
         authority: pft$authority;
         p_attachment_options: {input} ^fst$attachment_options;
         setfa_access_modes: fst$access_modes;
         device_class: rmt$device_class;
         permit_entry: pft$permit_entry;
         cycle_entry: pft$cycle_entry;
         p_old_file_label: {input} fmt$p_file_label;
         p_new_file_label: {input} fmt$p_file_label;
         validation_ring: ost$valid_ring;
         p_catalog_file: {input^} ^pft$catalog_file;
     VAR usage_allowed: pft$usage_selections; {phase 1}
     VAR usage_selections: pft$usage_selections;
     VAR sharing_required: pft$share_selections; {phase 1}
     VAR share_selections: pft$share_selections;
     VAR save_file_label: boolean;
     VAR status: ost$status);

    VAR
      access_and_share_modes_found: boolean,
      access_modes: fst$access_modes,
      cycle_formerly_opened_info: fmt$cycle_formerly_opened_info,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      label_status: ost$status,
      options_index: ost$non_negative_integers,
      options_specified: ost$non_negative_integers,
      permitted_access_modes_failure: boolean,
      ring_attributes: amt$ring_attributes,
      ring_attributes_source: amt$attribute_source,
      share_modes: fst$share_modes,
      usage_intentions: pft$permit_selections,
      valid_ring: boolean;

    options_index := 0;
    IF p_attachment_options = NIL THEN
      options_specified := 0;
    ELSE
      options_specified := UPPERBOUND (p_attachment_options^);
    IFEND;
    access_and_share_modes_found := FALSE;
    save_file_label := FALSE;

    IF (p_old_file_label = NIL) AND (pfc$control IN permit_entry.usage_permissions) THEN
      fmi$get_ring_attributes (p_new_file_label, cycle_formerly_opened_info, label_status);
      save_file_label := (label_status.normal AND (p_new_file_label <> NIL));
    ELSE
      fmi$get_ring_attributes (p_old_file_label, cycle_formerly_opened_info, label_status);
      save_file_label := FALSE;
    IFEND;

    REPEAT
      IF p_attachment_options <> NIL THEN
        REPEAT
          options_index := options_index + 1;
        UNTIL (p_attachment_options^ [options_index].selector = fsc$access_and_share_modes) OR
              (options_index = options_specified);
      IFEND;

      IF (p_attachment_options <> NIL) AND (p_attachment_options^ [options_index].selector =
            fsc$access_and_share_modes) THEN
        access_and_share_modes_found := TRUE;
        access_modes := p_attachment_options^ [options_index].access_modes;
        IF device_class = rmc$mass_storage_device THEN
          share_modes := p_attachment_options^ [options_index].share_modes;
        ELSEIF device_class = rmc$magnetic_tape_device THEN
          share_modes.selector := fsc$specific_share_modes;
          share_modes.value := $fst$file_access_options [];
        IFEND;
        status.normal := TRUE;
      ELSEIF NOT access_and_share_modes_found THEN
        {
        { Use setfa access modes and default share modes. (If access
        { modes were not specified via a setfa, they will default to
        { fsc$permitted_access_modes.)
        {
        access_modes := setfa_access_modes;
        IF device_class = rmc$mass_storage_device THEN
          share_modes.selector := fsc$determine_from_access_modes;
        ELSEIF device_class = rmc$magnetic_tape_device THEN
          share_modes.selector := fsc$specific_share_modes;
          share_modes.value := $fst$file_access_options [];
        IFEND;
        status.normal := TRUE;
      IFEND;

      IF status.normal THEN
        validate_permission_and_sharing (path, cycle_reference, mainframe_id, access_modes, share_modes,
              authority, permit_entry, cycle_entry, device_class,
              cycle_formerly_opened_info.cycle_previously_opened, p_catalog_file, usage_allowed { phase 1},
              usage_selections, sharing_required {phase 1}, share_selections, status);
      IFEND;
      permitted_access_modes_failure := (access_modes.selector = fsc$permitted_access_modes) AND
            (usage_selections = $pft$usage_selections []);

      IF status.normal THEN
        IF label_status.normal THEN
          ring_vote_selected_access (access_modes.selector, cycle_formerly_opened_info, validation_ring,
                usage_selections, valid_ring);
          IF (NOT valid_ring) AND (usage_selections <> $pft$usage_selections []) THEN
            pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$invalid_ring_access,
                  fs_path (1, fs_path_size), status);
            save_file_label := FALSE;
            permitted_access_modes_failure := (access_modes.selector = fsc$permitted_access_modes);
          IFEND;
        ELSE
          status := label_status;
        IFEND;
      IFEND;
    UNTIL status.normal OR (options_index = options_specified) OR permitted_access_modes_failure OR
          ((status.condition <> pfe$cycle_busy) AND (status.condition <> pfe$usage_not_permitted) AND
          (status.condition <> pfe$unknown_cycle) AND (status.condition <> ame$new_file_requires_append) AND
          (status.condition <> pfe$sharing_not_permitted) AND (status.condition <> pfe$invalid_ring_access));
  PROCEND pick_modes_for_attach;

?? TITLE := '  pick_modes_for_create', EJECT ??

  PROCEDURE pick_modes_for_create
    (    path: pft$complete_path;
         p_attachment_options: {input} ^fst$attachment_options;
         setfa_access_modes: fst$access_modes;
         ownership: pft$ownership;
         permit_entry: pft$permit_entry;
     VAR usage_allowed: pft$usage_selections;
     VAR usage_selections: pft$usage_selections;
     VAR sharing_required: pft$share_selections;
     VAR share_selections: pft$share_selections;
     VAR status: ost$status);

    VAR
      access_and_share_modes_found: boolean,
      access_modes: fst$access_modes,
      fs_path_size: fst$path_size,
      options_index: ost$non_negative_integers,
      options_specified: ost$non_negative_integers,
      p_fs_path: ^fst$path,
      share_modes: fst$share_modes,
      usage_option: pft$usage_options;

    options_index := 0;
    IF p_attachment_options = NIL THEN
      options_specified := 0;
    ELSE
      options_specified := UPPERBOUND (p_attachment_options^);
    IFEND;
    access_and_share_modes_found := FALSE;

    REPEAT
      IF p_attachment_options <> NIL THEN
        REPEAT
          options_index := options_index + 1;
        UNTIL (p_attachment_options^ [options_index].selector = fsc$access_and_share_modes) OR
              (options_index = options_specified);
      IFEND;

      IF (p_attachment_options <> NIL) AND (p_attachment_options^ [options_index].selector =
            fsc$access_and_share_modes) THEN
        access_and_share_modes_found := TRUE;
        access_modes := p_attachment_options^ [options_index].access_modes;
        share_modes := p_attachment_options^ [options_index].share_modes;
        status.normal := TRUE;
      ELSEIF NOT access_and_share_modes_found THEN
        {
        { Use setfa access modes and default share modes. (If access
        { modes were not specified via a setfa, they will default to
        { fsc$permitted_access_modes.)
        {
        access_modes := setfa_access_modes;
        share_modes.selector := fsc$determine_from_access_modes;
        status.normal := TRUE;
      IFEND;

      IF status.normal THEN
        IF access_modes.selector = fsc$permitted_access_modes THEN
          usage_selections := - $pft$usage_selections [];
        ELSE
          #UNCHECKED_CONVERSION (access_modes.value, usage_selections);
          IF NOT (fsc$append IN access_modes.value) THEN
            PUSH p_fs_path;
            pfp$convert_pf_path_to_fs_path (path, p_fs_path^, fs_path_size);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, ame$new_file_requires_append,
                  p_fs_path^ (1, fs_path_size), status);
          IFEND;
        IFEND;
      IFEND;

      IF status.normal THEN
        CASE share_modes.selector OF
        = fsc$determine_from_access_modes, fsc$required_share_modes =
          share_selections := $pft$share_selections [];
        = fsc$specific_share_modes =
          #UNCHECKED_CONVERSION (share_modes.value, share_selections);
        ELSE
          osp$set_status_condition (fse$system_error, status);
          #KEYPOINT (osk$unusual, 0, fsk$invalid_share_mode_selector);
        CASEND;
      IFEND;
    UNTIL status.normal OR (options_index = options_specified);

    IF status.normal THEN
      IF (pfc$system_owner IN ownership) OR (pfc$family_owner IN ownership) THEN
        usage_allowed := - $pft$usage_selections [];
        sharing_required := $pft$share_selections [];
      ELSEIF (permit_entry.entry_type = pfc$normal_permit_entry) AND
            NOT (permit_entry.usage_permissions <= $pft$permit_selections [pfc$cycle, pfc$control]) THEN
        usage_allowed := $pft$usage_selections [];
        FOR usage_option := LOWERVALUE (usage_option) TO UPPERVALUE (usage_option) DO
          IF usage_option IN permit_entry.usage_permissions THEN
            usage_allowed := usage_allowed + $pft$usage_selections [usage_option];
          IFEND;
        FOREND;
        sharing_required := permit_entry.share_requirements;
      ELSE {unpermitted}
        usage_allowed := $pft$usage_selections [];
        sharing_required := - $pft$share_selections [];
      IFEND;
    IFEND;
  PROCEND pick_modes_for_create;

?? TITLE := '  process_change_list', EJECT ??
{ NOTE:
{   Modifiers of this procedure may also need to modify procedures
{   change_path_table and validate_path_table_change in module
{   pfm$r2_df_client_requests.

  PROCEDURE process_change_list
    (    family_location: pft$family_location;
         path: pft$complete_path;
         device_class: rmt$device_class;
         change_list: pft$change_list;
         date_time: ost$date_time;
         p_catalog_file: {input^} ^pft$catalog_file;
         authority: pft$authority;
         permit_entry: pft$permit_entry;
         p_cycle: {i^/o^} ^pft$physical_cycle;
     VAR p_file_object: {i^/o} ^pft$physical_object;
     VAR object_list_descriptor: {i/o} pft$object_list_descriptor;
     VAR change_index: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      cycle_reference: fst$cycle_reference,
      detach_status: ost$status,
      dm_file_info: dmt$file_information,
      evaluated_file_reference: fst$evaluated_file_reference,
      fs_retention: fst$retention,
      file_damaged: boolean,
      fmd_modified: boolean,
      found: boolean,
      new_cycle_entry: boolean,
      new_name: fst$path_element,
      new_object_entry: boolean,
      p_cycle_list: ^pft$cycle_list,
      p_path_string: ^ost$string,
      path_index: fst$path_index,
      sfid: gft$system_file_identifier,
      space_index: 1 .. fsc$max_path_element_size + 1;

    status.normal := TRUE;

    FOR change_index := 1 TO UPPERBOUND (change_list) DO
      CASE change_list [change_index].change_type OF
      = pfc$pf_name_change =
        validate_object_name_change (path, change_list [change_index].pfn, object_list_descriptor,
              p_catalog_file, authority, permit_entry, status);
        IF status.normal THEN
          pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator, p_catalog_file,
                p_cycle_list);
        IFEND;

      = pfc$cycle_number_change =
        pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator, p_catalog_file,
              p_cycle_list);
        validate_cycle_number_change (path, p_cycle^.cycle_entry.cycle_number,
              change_list [change_index].cycle_number, p_cycle_list, status);

      ELSE
        ;
      CASEND;

      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    new_object_entry := FALSE;
    new_cycle_entry := FALSE;

  /make_changes/
    FOR change_index := 1 TO UPPERBOUND (change_list) DO
      CASE change_list [change_index].change_type OF
      = pfc$pf_name_change =
        IF family_location = pfc$local_mainframe THEN
          IF NOT new_cycle_entry THEN
            pfp$convert_pf_to_fs_structure (path, evaluated_file_reference);
          IFEND;
          new_name.value := change_list [change_index].pfn;
          #SCAN (pfv$space_character, change_list [change_index].pfn, space_index, found);
          new_name.size := space_index - 1;
          fmp$change_recorded_file_name (evaluated_file_reference, new_name, status);
          IF status.normal THEN
            #SCAN (pfv$space_character, path [UPPERBOUND (path)], space_index, found);
            path_index := evaluated_file_reference.path_structure_size - space_index + 1;
            evaluated_file_reference.path_structure (path_index) := $CHAR (new_name.size);
            evaluated_file_reference.path_structure (path_index + 1, new_name.size) := new_name.value;
            evaluated_file_reference.path_structure_size := path_index + new_name.size;
          ELSE
            IF status.condition <> pfe$name_already_used THEN
              pfp$report_unexpected_status (status);
            IFEND;
            EXIT /make_changes/;
          IFEND;
        IFEND;
        pfp$change_object_name (^path, change_list [change_index].pfn, p_catalog_file, p_file_object,
              object_list_descriptor, status);
        IF NOT status.normal THEN
          EXIT /make_changes/;
        IFEND;
        {
        { Update the modification date and time of all cycles so they will appear
        { to have been modified and, thus, will be backed-up on a partial backup.
        {
        update_all_cycles_modif_date (date_time, p_cycle_list);
        new_object_entry := TRUE;

      = pfc$password_change =
        p_file_object^.object_entry.password := change_list [change_index].password;
        new_object_entry := TRUE;

      = pfc$cycle_number_change =
        IF family_location = pfc$local_mainframe THEN
          IF NOT new_object_entry THEN
            pfp$convert_pf_to_fs_structure (path, evaluated_file_reference);
          IFEND;
          evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
          evaluated_file_reference.cycle_reference.cycle_number := p_cycle^.cycle_entry.cycle_number;
          fmp$change_recorded_cycle_num (evaluated_file_reference, change_list [change_index].cycle_number,
                status);
          IF status.normal THEN
            evaluated_file_reference.cycle_reference.cycle_number := change_list [change_index].cycle_number;
          ELSE
            IF status.condition <> pfe$duplicate_cycle THEN
              pfp$report_unexpected_status (status);
            IFEND;
            EXIT /make_changes/;
          IFEND;
        IFEND;
        p_cycle^.cycle_entry.cycle_number := change_list [change_index].cycle_number;
        {
        { Update the modification date and time of the cycle so it will appear
        { to have been modified and, thus, will be backed-up on a partial backup.
        { The data_modification_date_time is not updated as that would make the
        { the off-line data for the cycle obsolete.
        {
        p_cycle^.cycle_entry.cycle_statistics.modification_date_time := date_time;
        new_cycle_entry := TRUE;

      = pfc$retention_change =
        fs_retention.selector := fsc$retention_day_increment;
        fs_retention.day_increment := change_list [change_index].retention;
        form_expiration_date_time (date_time, fs_retention, p_cycle^.cycle_entry.expiration_date_time);
        new_cycle_entry := TRUE;

      = pfc$log_change =
        p_file_object^.object_entry.logging_selection := change_list [change_index].log;
        new_object_entry := TRUE;

      = pfc$charge_change =
        p_file_object^.object_entry.charge_id.account := authority.account;
        p_file_object^.object_entry.charge_id.project := authority.project;
        new_object_entry := TRUE;

      = pfc$delete_damage_change =
        p_cycle^.cycle_entry.cycle_damage_symptoms := p_cycle^.cycle_entry.cycle_damage_symptoms -
              change_list [change_index].delete_damage_condition;
        new_cycle_entry := TRUE;
        IF fsc$media_image_inconsistent IN change_list [change_index].delete_damage_condition THEN
          file_damaged := FALSE;
          IF p_cycle^.cycle_entry.attach_status.attach_count = 0 THEN
            IF (device_class = rmc$mass_storage_device) AND
                  (p_cycle^.cycle_entry.data_residence <> pfc$offline_data) THEN
              dm_attach_file (path, p_catalog_file, $pft$usage_selections [pfc$read],
                    - $pft$share_selections [], p_cycle, sfid, file_damaged, status);
              IF status.normal THEN
                IF file_damaged THEN
                  dmp$change_file_damaged (sfid, {file_damaged} FALSE,
                        p_cycle^.cycle_entry.internal_cycle_name, status);
                IFEND;
                pfp$detach_permanent_file (^path, sfid, $pft$usage_selections [pfc$read],
                      {catalog_update_allowed} TRUE, p_cycle, p_catalog_file, fmd_modified, dm_file_info,
                      detach_status);
                IF NOT detach_status.normal THEN
                  pfp$report_unexpected_status (detach_status);
                IFEND;
              ELSEIF status.condition = pfe$undefined_data THEN
                status.normal := TRUE;
              IFEND;
            IFEND;
          IFEND;
          IF status.normal AND (NOT file_damaged) THEN
            PUSH p_path_string;
            pfp$convert_cycle_path_to_strng (path, p_cycle^.cycle_entry.cycle_number, p_path_string^);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$no_media_image_inconsistent,
                  p_path_string^.value (1, p_path_string^.size), status);
            EXIT /make_changes/;
          IFEND;
        IFEND;
        IF NOT status.normal THEN
          IF (status.condition <> pfe$no_media_image_inconsistent) THEN
            pfp$report_unexpected_status (status);
          IFEND;
          EXIT /make_changes/;
        IFEND;
      ELSE
        ;
      CASEND;
    FOREND /make_changes/;

    IF change_index > UPPERBOUND (change_list) THEN
      change_index := UPPERBOUND (change_list);
    IFEND;

    IF new_cycle_entry THEN
      pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
    IFEND;

    IF new_object_entry THEN
      pfp$compute_checksum (#LOC (p_file_object^.object_entry), #SIZE (pft$object_entry),
            p_file_object^.checksum);
    IFEND;
  PROCEND process_change_list;

?? TITLE := '  process_file_changes', EJECT ??
{ NOTE:
{   Modifiers of this procedure may also need to modify procedures
{   change_path_table and validate_path_table_change in module
{   pfm$r2_df_client_requests.

  PROCEDURE process_file_changes
    (    family_location: pft$family_location;
         path: pft$complete_path;
         device_class: rmt$device_class;
         file_changes: ^fst$file_changes;
         date_time: ost$date_time;
         p_catalog_file: {input^} ^pft$catalog_file;
         authority: pft$authority;
         permit_entry: pft$permit_entry;
         p_cycle: {i^/o^} ^pft$physical_cycle;
     VAR p_file_object: {i^/o} ^pft$physical_object;
     VAR object_list_descriptor: {i/o} pft$object_list_descriptor;
     VAR change_index: ost$non_negative_integers;
     VAR status: ost$status);

    VAR
      cycle_reference: fst$cycle_reference,
      detach_status: ost$status,
      dm_file_info: dmt$file_information,
      evaluated_file_reference: fst$evaluated_file_reference,
      file_damaged: boolean,
      fmd_modified: boolean,
      found: boolean,
      local_expiration_date: ost$date_time,
      new_cycle_entry: boolean,
      new_name: fst$path_element,
      new_object_entry: boolean,
      p_cycle_list: ^pft$cycle_list,
      p_path_string: ^ost$string,
      path_index: fst$path_index,
      sfid: gft$system_file_identifier,
      shared_queue: pft$shared_queue,
      space_index: 1 .. fsc$max_path_element_size + 1,
      time_increment: pmt$time_increment;

    status.normal := TRUE;

    FOR change_index := 1 TO UPPERBOUND (file_changes^) DO
      CASE file_changes^ [change_index].selector OF
      = fsc$cycle_number_change =
        pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator, p_catalog_file,
              p_cycle_list);
        validate_cycle_number_change (path, p_cycle^.cycle_entry.cycle_number,
              file_changes^ [change_index].cycle_number, p_cycle_list, status);

      = fsc$pf_name_change =
        validate_object_name_change (path, file_changes^ [change_index].pfn, object_list_descriptor,
              p_catalog_file, authority, permit_entry, status);
        IF status.normal THEN
          pfp$build_cycle_list_pointer (p_file_object^.object_entry.cycle_list_locator, p_catalog_file,
                p_cycle_list);
        IFEND;

      = fsc$retention_change =
        CASE file_changes^ [change_index].retention.selector OF
        = fsc$retention_day_increment =
          time_increment.year := 0;
          time_increment.month := 0;
          time_increment.day := file_changes^ [change_index].retention.day_increment;
          time_increment.hour := 0;
          time_increment.minute := 0;
          time_increment.second := 0;
          time_increment.millisecond := 0;
          clp$verify_time_increment(time_increment, status);
          IF status.normal THEN
            pmp$compute_date_time (date_time, time_increment, local_expiration_date, status);
          IFEND;

        = fsc$retention_time_increment =
          time_increment := file_changes^ [change_index].retention.time_increment;
          clp$verify_time_increment(time_increment, status);
          IF status.normal THEN
            pmp$compute_date_time (date_time, time_increment, local_expiration_date, status);
          IFEND;
          pmp$compute_date_time (date_time, time_increment, local_expiration_date, status);

        = fsc$retention_expiration_date =
          time_increment.year := 0;
          time_increment.month := 0;
          time_increment.day := 0;
          time_increment.hour := 0;
          time_increment.minute := 0;
          time_increment.second := 0;
          time_increment.millisecond := 0;
          pmp$compute_date_time (file_changes^ [change_index].retention.expiration_date, time_increment,
                local_expiration_date, status);
        CASEND;

      = fsc$retrieve_option_change =
        IF ((p_cycle^.cycle_entry.retrieve_option = pfc$admin_retrieve_only) AND
              (file_changes^ [change_index].retrieve_option <> pfc$admin_retrieve_only) AND
              (NOT ((pfc$system_owner IN authority.ownership) OR
              (pfc$family_owner IN authority.ownership)))) THEN
          IF file_changes^ [change_index].retrieve_option = pfc$always_retrieve THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$change_requires_privilege,
                  'ALWAYS_RETRIEVE', status);
          ELSEIF file_changes^ [change_index].retrieve_option = pfc$explicit_retrieve_only THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$change_requires_privilege,
                  'EXPLICIT_RETRIEVE_ONLY', status);
          IFEND;
        IFEND;

      = fsc$shared_queue_change =
        pfp$convert_shared_queue_to_ord (file_changes^ [change_index].shared_queue, shared_queue, status);

      ELSE
        ;
      CASEND;

      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    new_object_entry := FALSE;
    new_cycle_entry := FALSE;

  /make_changes/
    FOR change_index := 1 TO UPPERBOUND (file_changes^) DO
      CASE file_changes^ [change_index].selector OF
      = fsc$charge_change =
        p_file_object^.object_entry.charge_id.account := authority.account;
        p_file_object^.object_entry.charge_id.project := authority.project;
        new_object_entry := TRUE;

      = fsc$cycle_number_change =
        IF family_location = pfc$local_mainframe THEN
          IF NOT new_object_entry THEN
            pfp$convert_pf_to_fs_structure (path, evaluated_file_reference);
          IFEND;
          evaluated_file_reference.cycle_reference.specification := fsc$cycle_number;
          evaluated_file_reference.cycle_reference.cycle_number := p_cycle^.cycle_entry.cycle_number;
          fmp$change_recorded_cycle_num (evaluated_file_reference, file_changes^ [change_index].cycle_number,
                status);
          IF status.normal THEN
            evaluated_file_reference.cycle_reference.cycle_number :=
                  file_changes^ [change_index].cycle_number;
          ELSE
            IF status.condition <> pfe$duplicate_cycle THEN
              pfp$report_unexpected_status (status);
            IFEND;
            EXIT /make_changes/;
          IFEND;
        IFEND;
        p_cycle^.cycle_entry.cycle_number := file_changes^ [change_index].cycle_number;
        {
        { Update the modification date and time of the cycle so it will appear
        { to have been modified and, thus, will be backed-up on a partial backup.
        { The data_modification_date_time is not updated as that would make the
        { the off-line data for the cycle obsolete.
        {
        p_cycle^.cycle_entry.cycle_statistics.modification_date_time := date_time;
        new_cycle_entry := TRUE;

      = fsc$delete_damage_change =
        p_cycle^.cycle_entry.cycle_damage_symptoms := p_cycle^.cycle_entry.cycle_damage_symptoms -
              file_changes^ [change_index].delete_damage_condition;
        new_cycle_entry := TRUE;
        IF fsc$media_image_inconsistent IN file_changes^ [change_index].delete_damage_condition THEN
          file_damaged := FALSE;
          IF p_cycle^.cycle_entry.attach_status.attach_count = 0 THEN
            IF (device_class = rmc$mass_storage_device) AND
                  (p_cycle^.cycle_entry.data_residence <> pfc$offline_data) THEN
              dm_attach_file (path, p_catalog_file, $pft$usage_selections [pfc$read],
                    - $pft$share_selections [], p_cycle, sfid, file_damaged, status);
              IF status.normal THEN
                IF file_damaged THEN
                  dmp$change_file_damaged (sfid, {file_damaged} FALSE,
                        p_cycle^.cycle_entry.internal_cycle_name, status);
                IFEND;
                pfp$detach_permanent_file (^path, sfid, $pft$usage_selections [pfc$read],
                      {catalog_update_allowed} TRUE, p_cycle, p_catalog_file, fmd_modified, dm_file_info,
                      detach_status);
                IF NOT detach_status.normal THEN
                  pfp$report_unexpected_status (detach_status);
                IFEND;
              ELSEIF status.condition = pfe$undefined_data THEN
                status.normal := TRUE;
              IFEND;
            IFEND;
          IFEND;
          IF status.normal AND (NOT file_damaged) THEN
            PUSH p_path_string;
            pfp$convert_cycle_path_to_strng (path, p_cycle^.cycle_entry.cycle_number, p_path_string^);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$no_media_image_inconsistent,
                  p_path_string^.value (1, p_path_string^.size), status);
            EXIT /make_changes/;
          IFEND;
        IFEND;
        IF NOT status.normal THEN
          IF (status.condition <> pfe$no_media_image_inconsistent) THEN
            pfp$report_unexpected_status (status);
          IFEND;
          EXIT /make_changes/;
        IFEND;

      = fsc$log_change =
        p_file_object^.object_entry.logging_selection := file_changes^ [change_index].log;
        new_object_entry := TRUE;

      = fsc$null_file_change =
        ;

      = fsc$password_change =
        p_file_object^.object_entry.password := file_changes^ [change_index].password;
        new_object_entry := TRUE;

      = fsc$pf_name_change =
        IF family_location = pfc$local_mainframe THEN
          IF NOT new_cycle_entry THEN
            pfp$convert_pf_to_fs_structure (path, evaluated_file_reference);
          IFEND;
          new_name.value := file_changes^ [change_index].pfn;
          #SCAN (pfv$space_character, file_changes^ [change_index].pfn, space_index, found);
          new_name.size := space_index - 1;
          fmp$change_recorded_file_name (evaluated_file_reference, new_name, status);
          IF status.normal THEN
            #SCAN (pfv$space_character, path [UPPERBOUND (path)], space_index, found);
            path_index := evaluated_file_reference.path_structure_size - space_index + 1;
            evaluated_file_reference.path_structure (path_index) := $CHAR (new_name.size);
            evaluated_file_reference.path_structure (path_index + 1, new_name.size) := new_name.value;
            evaluated_file_reference.path_structure_size := path_index + new_name.size;
          ELSE
            IF status.condition <> pfe$name_already_used THEN
              pfp$report_unexpected_status (status);
            IFEND;
            EXIT /make_changes/;
          IFEND;
        IFEND;
        pfp$change_object_name (^path, file_changes^ [change_index].pfn, p_catalog_file, p_file_object,
              object_list_descriptor, status);
        IF NOT status.normal THEN
          EXIT /make_changes/;
        IFEND;
        {
        { Update the modification date and time of all cycles so they will appear
        { to have been modified and, thus, will be backed-up on a partial backup.
        {
        update_all_cycles_modif_date (date_time, p_cycle_list);
        new_object_entry := TRUE;

      = fsc$retention_change =
        form_expiration_date_time (date_time, file_changes^ [change_index].retention,
              p_cycle^.cycle_entry.expiration_date_time);
        new_cycle_entry := TRUE;

      = fsc$retrieve_option_change =
        p_cycle^.cycle_entry.retrieve_option := file_changes^ [change_index].retrieve_option;
        p_cycle^.cycle_entry.cycle_statistics.modification_date_time := date_time;
        new_cycle_entry := TRUE;

      = fsc$shared_queue_change =
        IF shared_queue = pfc$null_shared_queue THEN
          p_cycle^.cycle_entry.shared_queue_info.defined := FALSE;
        ELSE
          p_cycle^.cycle_entry.shared_queue_info.defined := TRUE;
          p_cycle^.cycle_entry.shared_queue_info.shared_queue := shared_queue;
        IFEND;
        p_cycle^.cycle_entry.cycle_statistics.modification_date_time := date_time;
        new_cycle_entry := TRUE;

      = fsc$site_archive_option_change =
        p_cycle^.cycle_entry.site_archive_option := file_changes^ [change_index].site_archive_option;
        p_cycle^.cycle_entry.cycle_statistics.modification_date_time := date_time;
        new_cycle_entry := TRUE;

      = fsc$site_backup_option_change =
        p_cycle^.cycle_entry.site_backup_option := file_changes^ [change_index].site_backup_option;
        p_cycle^.cycle_entry.cycle_statistics.modification_date_time := date_time;
        new_cycle_entry := TRUE;

      = fsc$site_release_option_change =
        p_cycle^.cycle_entry.site_release_option := file_changes^ [change_index].site_release_option;
        p_cycle^.cycle_entry.cycle_statistics.modification_date_time := date_time;
        new_cycle_entry := TRUE;

      ELSE
        ;
      CASEND;
    FOREND /make_changes/;

    IF change_index > UPPERBOUND (file_changes^) THEN
      change_index := UPPERBOUND (file_changes^);
    IFEND;

    IF new_cycle_entry THEN
      pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
    IFEND;

    IF new_object_entry THEN
      pfp$compute_checksum (#LOC (p_file_object^.object_entry), #SIZE (pft$object_entry),
            p_file_object^.checksum);
    IFEND;
  PROCEND process_file_changes;

?? TITLE := '  purge_cycle', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to purge the specified cycle entry for a
{   file object.  This includes deleting the file described by the cycle entry.
{   If the file is busy, it is flagged so that it will be deleted when it is
{   detached.  If the specified cycle is not found, an error status is
{   returned.  If the cycle list is contracted as a result of deleting the
{   cycle entry, a new, smaller cycle list is created and the old list is
{   copied to the new list.

  PROCEDURE purge_cycle
    (    path: pft$complete_path;
         device_class: rmt$device_class;
         purge_cycle_options: pft$purge_cycle_options;
         p_data_modification_date_time: ^ost$date_time;
         p_cycle: {i^/o^} pft$p_cycle;
         p_catalog_file: {i^/o^} pft$p_catalog_file;
     VAR p_file_object: {i^/o^} pft$p_object;
     VAR object_list_descriptor: {i/o} pft$object_list_descriptor;
     VAR disk_image_deleted: boolean;
     VAR bytes_released: amt$file_byte_address;
     VAR status: ost$status);

    CONST
      update_catalog = TRUE;

    VAR
      archive_index: pft$archive_index,
      authority: pft$authority,
      delete_cycle: boolean,
      existing_sft_entry: dmt$existing_sft_entry,
      file_info: dmt$file_information,
      keypoint_operation: dft$keypoint_file_operation,
      local_status: ost$status,
      matching_archive_entry: boolean,
      p_archive_list: ^pft$archive_list,
      p_mainframe_usage_list: ^pft$mainframe_usage_list,
      p_physical_fmd: ^pft$physical_fmd,
      p_physical_media: ^pft$physical_amd,
      p_stored_file_label: ^pft$physical_file_label,
      path_name: ost$string,
      prevalidate_free_result: ost$prevalidate_free_result,
      sfid: gft$system_file_identifier;

    bytes_released := 0;
    delete_cycle := TRUE;
    status.normal := TRUE;

    IF purge_cycle_options.preserve_cycle_entry AND
          (p_cycle^.cycle_entry.attach_status.attach_count > 0) THEN
      pfp$convert_cycle_path_to_strng (path, p_cycle^.cycle_entry.cycle_number,
            path_name);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$replace_cycle_data_busy,
            path_name.value (1, path_name.size), status);
      RETURN;
    IFEND;

    pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, p_catalog_file, p_physical_fmd);

    IF (p_cycle^.cycle_entry.attach_status.attach_count <> 0) AND (p_physical_fmd <> NIL) THEN
      IF device_class = rmc$mass_storage_device THEN
        dmp$locate_existing_sft_entry (p_cycle^.cycle_entry.internal_cycle_name, gfc$fk_job_permanent_file,
              existing_sft_entry, file_info, status);

        IF status.normal THEN
          IF (existing_sft_entry = dmc$normal_entry) OR (existing_sft_entry = dmc$restricted_attach_entry)
                THEN
            delete_cycle := FALSE;
            p_cycle^.cycle_entry.entry_type := pfc$purged_cycle_entry;
            pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
          ELSEIF pfp$cycle_attached_for_write (p_cycle) THEN
            pfp$reconcile_fmd (^path, p_cycle^.cycle_entry.internal_cycle_name, existing_sft_entry,
                  update_catalog, p_catalog_file, p_cycle, p_physical_fmd, status);
            pfp$process_unexpected_status (status);
          IFEND;
        ELSE
          pfp$report_unexpected_status (status);
        IFEND;
      ELSEIF device_class = rmc$magnetic_tape_device THEN
        delete_cycle := FALSE;
        p_cycle^.cycle_entry.entry_type := pfc$purged_cycle_entry;
        pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
      IFEND;
    IFEND;

    IF delete_cycle THEN
      IF p_physical_fmd <> NIL THEN
        IF device_class = rmc$mass_storage_device THEN
          dmp$destroy_permanent_file (p_cycle^.cycle_entry.internal_cycle_name, p_physical_fmd^.fmd,
                local_status);
          disk_image_deleted := local_status.normal;
          #SPOIL(disk_image_deleted);
          IF dfv$file_server_info_enabled THEN
            keypoint_operation.remote := path [pfc$family_path_index] <> osv$system_family_name;
            keypoint_operation.catalog := FALSE;
            #KEYPOINT (dfk$file_server_info_class, osk$m * keypoint_operation.keypoint_data, dfk$delete_info);
          IFEND;
          pfp$process_unexpected_status (local_status);

          bytes_released := p_cycle^.cycle_entry.device_information.bytes_allocated;
          {
          { Despite a dmp$destroy_permanent_file failure, remove the file from
          { the permanent file base. This makes the permanent file manager
          { somewhat fault tolerant and allows the user to continue. Recovery
          { of the set will make the files known to device management and to
          { permanent file management consistent.
          {
          osp$prevalidate_free ((#OFFSET(p_physical_fmd) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
                ^p_catalog_file^.catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_physical_fmd IN p_catalog_file^.catalog_heap;
          ELSE
            pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'FILE_MEDIA_DESCRIPTOR',
                  'file', prevalidate_free_result, #OFFSET(p_physical_fmd));
            p_physical_fmd := NIL;
          IFEND;
          pfp$build_fmd_locator ({p_physical_fmd} NIL, {p_catalog_file} NIL,
                p_cycle^.cycle_entry.fmd_locator);
        ELSEIF device_class = rmc$magnetic_tape_device THEN
          disk_image_deleted := TRUE;
          #SPOIL(disk_image_deleted);
          osp$prevalidate_free ((#OFFSET(p_physical_fmd) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
                ^p_catalog_file^.catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_physical_fmd IN p_catalog_file^.catalog_heap;
          ELSE
            pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'FILE_MEDIA_DESCRIPTOR',
                  'file', prevalidate_free_result, #OFFSET(p_physical_fmd));
            p_physical_fmd := NIL;
          IFEND;
          pfp$build_fmd_locator ({p_physical_fmd} NIL, {p_catalog_file} NIL,
                p_cycle^.cycle_entry.fmd_locator);
        IFEND;
      IFEND;

      IF (NOT purge_cycle_options.preserve_cycle_entry) OR ((purge_cycle_options.preserve_cycle_entry) AND
            (NOT purge_cycle_options.preserve_file_label)) THEN
        pfp$build_file_label_pointer (p_cycle^.cycle_entry.file_label_locator, p_catalog_file,
              p_stored_file_label);
        IF p_stored_file_label <> NIL THEN
          osp$prevalidate_free ((#OFFSET(p_stored_file_label) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
                ^p_catalog_file^.catalog_heap, prevalidate_free_result);
          IF prevalidate_free_result = osc$heap_free_valid THEN
            FREE p_stored_file_label IN p_catalog_file^.catalog_heap;
          ELSE
            pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'FILE_LABEL', 'file',
                  prevalidate_free_result, #OFFSET(p_stored_file_label));
            p_stored_file_label := NIL;
          IFEND;
          pfp$build_file_label_locator ({p_file_label} NIL, {p_catalog_file} NIL,
                p_cycle^.cycle_entry.file_label_locator);
        IFEND;
      IFEND;

      IF (purge_cycle_options.preserve_cycle_entry) AND
            (NOT purge_cycle_options.preserve_modification_date_time) THEN
        p_cycle^.cycle_entry.data_modification_date_time := pfv$null_date_time;
        p_cycle^.cycle_entry.cycle_statistics.modification_date_time := pfv$null_date_time;
      IFEND;

      IF p_cycle^.cycle_entry.archive_list_locator.archive_count > 0 THEN
        pfp$build_archive_list_pointer (p_cycle^.cycle_entry.archive_list_locator, p_catalog_file,
              p_archive_list);
        IF p_archive_list <> NIL THEN
          matching_archive_entry := FALSE;
          IF p_data_modification_date_time <> NIL THEN
            FOR archive_index := 1 TO UPPERBOUND (p_archive_list^) DO
              matching_archive_entry := matching_archive_entry OR
                    (p_archive_list^ [archive_index].archive_entry.modification_date_time =
                    p_data_modification_date_time^);
            FOREND;
          IFEND;
          IF (NOT purge_cycle_options.preserve_cycle_entry) OR
                (purge_cycle_options.preserve_cycle_entry AND
                (NOT purge_cycle_options.preserve_archive_info)) OR
                (purge_cycle_options.preserve_cycle_entry AND
                purge_cycle_options.preserve_archive_info AND (p_data_modification_date_time <> NIL) AND
                (NOT matching_archive_entry)) THEN
            FOR archive_index := 1 TO UPPERBOUND (p_archive_list^) DO
              pfp$build_amd_pointer (p_archive_list^ [archive_index].archive_entry.amd_locator,
                    p_catalog_file, p_physical_media);
              IF p_physical_media <> NIL THEN
                osp$prevalidate_free (
                      (#OFFSET(p_physical_media) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
                      ^p_catalog_file^.catalog_heap, prevalidate_free_result);
                IF prevalidate_free_result = osc$heap_free_valid THEN
                  FREE p_physical_media IN p_catalog_file^.catalog_heap;
                ELSE
                  pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number,
                        'ARCHIVE_MEDIA_DESCRIPTOR', 'file', prevalidate_free_result,
                        #OFFSET(p_physical_media));
                  p_physical_media := NIL;
                IFEND;
              IFEND;
            FOREND;

            osp$prevalidate_free ((#OFFSET(p_archive_list) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
                  ^p_catalog_file^.catalog_heap, prevalidate_free_result);
            IF prevalidate_free_result = osc$heap_free_valid THEN
              FREE p_archive_list IN p_catalog_file^.catalog_heap;
            ELSE
              pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'ARCHIVE_LIST', 'file',
                    prevalidate_free_result, #OFFSET(p_archive_list));
              p_archive_list := NIL;
            IFEND;
            pfp$build_archive_list_locator ({p_archive_list} NIL, {p_catalog_file} NIL,
                  p_cycle^.cycle_entry.archive_list_locator);
          IFEND;
        IFEND;
      IFEND;

      pfp$build_mainfram_list_pointer (p_cycle^.cycle_entry.mainframe_usage_list_locator, p_catalog_file,
            p_mainframe_usage_list);
      IF p_mainframe_usage_list <> NIL THEN
        osp$prevalidate_free ((#OFFSET(p_mainframe_usage_list) -
              #OFFSET(^p_catalog_file^.catalog_heap) - 16), ^p_catalog_file^.catalog_heap,
              prevalidate_free_result);
        IF prevalidate_free_result = osc$heap_free_valid THEN
          FREE p_mainframe_usage_list IN p_catalog_file^.catalog_heap;
        ELSE
          pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'MAINFRAME_USAGE_LIST',
                'file', prevalidate_free_result, #OFFSET(p_mainframe_usage_list));
          p_mainframe_usage_list := NIL;
        IFEND;
      IFEND;
      p_cycle^.cycle_entry.first_mainframe_usage_entry.entry_type := pfc$free_mainframe_entry;
      pfp$build_mainfram_list_locator ({p_mainframe_list} NIL, {p_catalog_file} NIL,
            p_cycle^.cycle_entry.mainframe_usage_list_locator);
      pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);

      IF NOT purge_cycle_options.preserve_cycle_entry THEN
        p_cycle^.cycle_entry.entry_type := pfc$free_cycle_entry;
        pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
        pfp$delete_file_object (^path, p_catalog_file, p_file_object, object_list_descriptor, status);
        IF status.normal AND (p_file_object^.object_entry.object_type <> pfc$free_object) THEN
          contract_cycle_list (path, p_file_object, p_catalog_file, status);
        IFEND;
      IFEND;
    ELSE
      IF NOT purge_cycle_options.preserve_cycle_entry THEN
        pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);
        pfp$delete_file_object (^path, p_catalog_file, p_file_object, object_list_descriptor, status);
      IFEND;
    IFEND;
  PROCEND purge_cycle;

?? TITLE := '  recreate_cycle_data', EJECT ??

  PROCEDURE recreate_cycle_data
    (    family_location: pft$family_location;
         mainframe_id: pmt$binary_mainframe_id;
         path: pft$complete_path;
         authority: pft$authority;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
         application_info: pft$application_info;
         validation_ring: ost$valid_ring;
         password_protected: boolean;
         enable_media_damage_detection: boolean;
         apft_index: pft$attached_pf_table_index;
         p_file_label: {input} fmt$p_file_label;
         p_cycle_description: {i^/o^} ^fmt$cycle_description;
         catalog_locator: {i^/o^} pft$catalog_locator;
         p_cycle: {i^/o^} ^pft$physical_cycle;
         p_internal_cycle_path: {i^/o^} ^pft$internal_cycle_path;
         p_attached_pf_entry: {i^/o^} ^pft$attached_pf_entry;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR new_global_file_name: ost$binary_unique_name;
     VAR new_remote_sfid: gft$system_file_identifier;
     VAR bytes_allocated: amt$file_byte_address;
     VAR p_file_server_buffers: {server only: i^/o^} pft$p_file_server_buffers;
     VAR status: ost$status);

    VAR
      fmd_header_info: pft$fmd_header,
      ignore_flush_catalog_pages: boolean,
      ignore_status: ost$status,
      internal_cycle_name: pft$internal_name,
      local_apft_index: pft$attached_pf_table_index,
      local_status: ost$status,
      mass_storage_request_info: fmt$mass_storage_request_info,
      new_apfid_assigned: boolean,
      new_apfid_in_use: boolean,
      p_catalog_heap: pft$p_catalog_heap,
      p_local_attached_pf_entry: ^pft$attached_pf_entry,
      p_mass_storage_request_info: ^fmt$mass_storage_request_info,
      p_new_stored_fmd: ^pft$physical_fmd,
      p_physical_fmd: ^pft$physical_fmd,
      prevalidate_free_result: ost$prevalidate_free_result,
      sfid: gft$system_file_identifier,
      shared_queue: pft$shared_queue;

    status.normal := TRUE;
    new_apfid_assigned := FALSE;
    new_global_file_name := dmv$null_global_file_name;
    new_remote_sfid := dmv$null_sfid;

    IF p_attached_pf_entry <> NIL THEN
      local_apft_index := apft_index;
      IF p_cycle_description <> NIL THEN
        evaluated_file_reference.path_handle_info.path_handle := p_cycle_description^.path_handle;
      IFEND;
    ELSE
      pfp$assign_locked_apfid (local_apft_index, status);
      IF status.normal THEN
        new_apfid_assigned := TRUE;
        pfv$locked_apfid := local_apft_index;
      IFEND;
    IFEND;

    IF status.normal THEN
      pfp$build_fmd_pointer (p_cycle^.cycle_entry.fmd_locator, catalog_locator.p_catalog_file,
            p_physical_fmd);
      p_mass_storage_request_info := NIL;
      IF p_physical_fmd <> NIL THEN
        dmp$get_stored_fmd_header_info (^p_physical_fmd^.fmd, fmd_header_info, status);
        IF status.normal THEN
          IF p_cycle^.cycle_entry.shared_queue_info.defined THEN
            shared_queue := p_cycle^.cycle_entry.shared_queue_info.shared_queue;
          ELSE
            shared_queue := pfc$null_shared_queue;
          IFEND;

          rmp$build_mass_storage_info (fmd_header_info.requested_allocation_size, rmc$unspecified_file_size,
                fmd_header_info.requested_volume.recorded_vsn, fmd_header_info.requested_class, shared_queue,
                fmd_header_info.requested_transfer_size, fmd_header_info.overflow_allowed,
                {ring_of_caller} osc$tmtr_ring, ^mass_storage_request_info, status);
          IF status.normal THEN
            p_mass_storage_request_info := ^mass_storage_request_info;
          IFEND;
        IFEND;
      IFEND;

      pfp$create_permanent_file (family_location, {lfn} osc$null_name, path,
            p_cycle^.cycle_entry.cycle_number, local_apft_index, usage_selections, share_selections,
            application_info, validation_ring, password_protected, enable_media_damage_detection,
            {implicit_attach} (p_attached_pf_entry = NIL),
            {recreate_attached_cycle_data} (p_attached_pf_entry <> NIL), p_file_label,
            {device_class} rmc$mass_storage_device, p_mass_storage_request_info,
            {p_removable_media_req_info} NIL, {p_volume_list} NIL, authority,
            evaluated_file_reference.path_handle_info.path_handle, sfid, internal_cycle_name,
            bytes_allocated, p_file_server_buffers, status);
    IFEND;
    new_apfid_in_use := (p_attached_pf_entry = NIL) AND status.normal;

    IF status.normal THEN
      IF p_physical_fmd <> NIL THEN
        dmp$destroy_permanent_file (p_cycle^.cycle_entry.internal_cycle_name, p_physical_fmd^.fmd,
              local_status);
        pfp$process_unexpected_status (local_status);
        osp$prevalidate_free ((#OFFSET(p_physical_fmd) -
              #OFFSET(^catalog_locator.p_catalog_file^.catalog_heap) - 16),
              ^catalog_locator.p_catalog_file^.catalog_heap, prevalidate_free_result);
        IF prevalidate_free_result = osc$heap_free_valid THEN
          FREE p_physical_fmd IN catalog_locator.p_catalog_file^.catalog_heap;
        ELSE
          pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'FILE_MEDIA_DESCRIPTOR', 'file',
                prevalidate_free_result, #OFFSET(p_physical_fmd));
          p_physical_fmd := NIL;
        IFEND;
      IFEND;

      p_catalog_heap := ^catalog_locator.p_catalog_file^.catalog_heap;
      pfp$record_dm_file_parameters (^path, ^p_cycle^.cycle_entry.cycle_number, sfid,
            {device_class} rmc$mass_storage_device, {p_removable_media_req_info} NIL, {p_volume_list} NIL,
            p_catalog_heap, p_new_stored_fmd, status);
      IF NOT status.normal THEN
        fmp$delete_path_description (evaluated_file_reference, {implicit_detach} FALSE,
              {return_permanent_file} FALSE, {detachment_options} NIL, ignore_status);
        dmp$destroy_file (sfid, sfc$no_limit, ignore_status);
        new_apfid_in_use := FALSE;
      IFEND;
    IFEND;

    IF status.normal THEN
      p_cycle^.cycle_entry.internal_cycle_name := internal_cycle_name;
      p_cycle^.cycle_entry.global_file_name := internal_cycle_name;
      p_cycle^.cycle_entry.device_information.eoi := 0;
      p_cycle^.cycle_entry.device_information.bytes_allocated := bytes_allocated;
      p_cycle^.cycle_entry.data_residence := pfc$unreleasable_data;
      pfp$build_fmd_locator (p_new_stored_fmd, catalog_locator.p_catalog_file,
            p_cycle^.cycle_entry.fmd_locator);
      IF p_attached_pf_entry = NIL THEN
        p_cycle^.cycle_entry.attach_status := pfv$unattached_status;
        pfp$increment_usage_counts (path, usage_selections, share_selections, mainframe_id,
              catalog_locator.p_catalog_file, ignore_flush_catalog_pages, p_cycle^.cycle_entry, status);
      IFEND;
      pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (p_cycle^.cycle_entry),
            p_cycle^.checksum);
      syp$hang_if_job_jrt_set (pfc$tjr_define);
      p_internal_cycle_path^.cycle_name := internal_cycle_name;
      IF p_attached_pf_entry <> NIL THEN
        IF p_cycle_description <> NIL THEN
          p_cycle_description^.system_file_id := sfid;
        ELSE
          new_global_file_name := p_cycle^.cycle_entry.global_file_name;
          new_remote_sfid := sfid;
        IFEND;
        p_attached_pf_entry^.internal_cycle_path.cycle_name := internal_cycle_name;
        p_attached_pf_entry^.sfid_status.sfid := sfid;
      ELSE
        build_attached_pf_entry (sfid, path, p_cycle^.cycle_entry.cycle_number,
              {device_class} rmc$mass_storage_device, {update_catalog} TRUE, {update_cycle_statistics} TRUE,
              usage_selections, share_selections, {media_image_inconsistent} FALSE,
              enable_media_damage_detection, $fst$cycle_damage_symptoms [], p_internal_cycle_path^,
              p_local_attached_pf_entry, status);
      IFEND;
    IFEND;

    IF (p_attached_pf_entry = NIL) AND new_apfid_assigned THEN
      IF new_apfid_in_use THEN
        pfp$unlock_apfid (local_apft_index, p_local_attached_pf_entry, status);
      ELSE
        pfp$release_locked_apfid (local_apft_index, status);
      IFEND;
      pfp$process_unexpected_status (status);
    IFEND;

  PROCEND recreate_cycle_data;

?? TITLE := '  release_cycle_data', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to release mass storage data for a
{   specified file cycle.
{
{ NOTES:
{   Releasing mass storage data does not cause the file label to be released.
{   If the file cycle is busy, mass storage will be released when the file
{   cycle is detached.  If the mass storage data has been modified since the
{   most recent archive entry was created, the mass storage data will not be
{   released.

  PROCEDURE release_cycle_data
    (    path: pft$complete_path;
         p_physical_cycle: {i^/o^} ^pft$physical_cycle;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
         p_release_data_info: {i/o} ^pft$release_data_info;
     VAR status: ost$status);

    VAR
      archive_date_time: ost$date_time,
      archive_index: pft$archive_index,
      comparison_result: pmt$comparison_result,
      data_modification_date_time: ost$date_time,
      local_status: ost$status,
      p_archive_entry: ^pft$archive_entry,
      p_archive_list: ^pft$archive_list,
      p_physical_fmd: ^pft$physical_fmd,
      p_mainframe_usage_list: ^pft$mainframe_usage_list,
      prevalidate_free_result: ost$prevalidate_free_result,
      release_data_info: pft$release_data_info,
      release_date_time: ost$date_time,
      variant_path: pft$variant_path;

    status.normal := TRUE;

    IF p_release_data_info = NIL THEN
      release_data_info.perform_changes := TRUE;
      release_data_info.release_attached_cycle_data := TRUE;
      release_data_info.update_last_release_date_time := TRUE;
      release_data_info.valid_archive_entry_required := TRUE;
    ELSE
      release_data_info := p_release_data_info^;
    IFEND;
    release_data_info.cycle_attached := FALSE;

    pfp$build_archive_list_pointer (p_physical_cycle^.cycle_entry.archive_list_locator, p_catalog_file,
          p_archive_list);
    IF p_archive_list = NIL THEN
      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := ^path;
      pfp$set_status_abnormal (variant_path, pfe$empty_archive_list, status);
      RETURN;
    IFEND;
    {
    { Locate most recently created archive entry.
    {
    p_archive_entry := ^p_archive_list^ [1].archive_entry;
    archive_date_time := p_archive_entry^.archive_date_time;
  /search_archive_list/
    FOR archive_index := 2 TO UPPERBOUND (p_archive_list^) DO
      pmp$date_time_compare (p_archive_list^ [archive_index].archive_entry.archive_date_time,
            archive_date_time, comparison_result, status);
      IF NOT status.normal THEN
        CYCLE /search_archive_list/;
      IFEND;
      IF comparison_result = pmc$left_is_greater THEN
        archive_date_time := p_archive_list^ [archive_index].archive_entry.archive_date_time;
        p_archive_entry := ^p_archive_list^ [archive_index].archive_entry;
      IFEND;
    FOREND /search_archive_list/;
    {
    { The archive entry will be considered a valid archive entry if it was created after
    { the cycle was last modified.
    {
    data_modification_date_time := p_physical_cycle^.cycle_entry.data_modification_date_time;
    pmp$date_time_compare (archive_date_time, data_modification_date_time, comparison_result, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    release_data_info.valid_archive_entry_found := (comparison_result = pmc$left_is_greater);
    {
    { If the release_data_info specified that a valid archive entry must exist and a valid archive
    { entry does not exist, the release request will be rejected.
    {
    IF release_data_info.valid_archive_entry_required AND NOT release_data_info.valid_archive_entry_found THEN
      p_physical_cycle^.cycle_entry.data_residence := pfc$unreleasable_data;
      pfp$compute_checksum (^p_physical_cycle^.cycle_entry, #SIZE (pft$cycle_entry),
            p_physical_cycle^.checksum);

      variant_path.complete_path := TRUE;
      variant_path.p_complete_path := ^path;
      pfp$set_status_abnormal (variant_path, pfe$data_not_releasable, status);
      osp$append_status_integer (osc$status_parameter_delimiter, p_physical_cycle^.cycle_entry.cycle_number,
            radix, NOT include_radix, status);
      RETURN;
    IFEND;

    IF NOT release_data_info.valid_archive_entry_found THEN
      release_data_info.old_data_modification_date_time := data_modification_date_time;
      release_data_info.new_data_modification_date_time := p_archive_entry^.modification_date_time;
    IFEND;
    {
    { Exit here with the output parameter containing the correct data but before the catalog
    { is modified, if indicated in the release_data_info.
    {
    IF NOT release_data_info.perform_changes THEN
      IF p_physical_cycle^.cycle_entry.attach_status.attach_count > 0 THEN
        release_data_info.cycle_attached := TRUE;
      IFEND;
      IF p_release_data_info <> NIL THEN
        p_release_data_info^ := release_data_info;
      IFEND;
      RETURN;
    IFEND;
    {
    { For cycles currently attached to this or other jobs the data residence will be
    { set to indicate that the cycle should be released when the attach count goes to
    { zero.  The new data residence will also specify what type of release to execute.
    {
    IF p_physical_cycle^.cycle_entry.attach_status.attach_count > 0 THEN
      release_data_info.cycle_attached := TRUE;
      IF release_data_info.release_attached_cycle_data THEN
        p_physical_cycle^.cycle_entry.data_residence := pfc$release_data_requested;
        IF (NOT release_data_info.valid_archive_entry_found) AND
              (data_modification_date_time <> p_archive_entry^.modification_date_time) THEN
          p_physical_cycle^.cycle_entry.cycle_statistics.modification_date_time :=
                p_archive_entry^.modification_date_time;
          p_physical_cycle^.cycle_entry.data_modification_date_time :=
                p_archive_entry^.modification_date_time;
          p_physical_cycle^.cycle_entry.cycle_damage_symptoms :=
                p_physical_cycle^.cycle_entry.cycle_damage_symptoms +
                $fst$cycle_damage_symptoms [fsc$respf_modification_mismatch];
        IFEND;

        IF release_data_info.update_last_release_date_time THEN
          pmp$get_compact_date_time (release_date_time, local_status);
        /set_attached_release_date_time/
          FOR archive_index := 1 TO UPPERBOUND (p_archive_list^) DO
            pmp$date_time_compare (p_archive_list^ [archive_index].archive_entry.modification_date_time,
                  p_physical_cycle^.cycle_entry.data_modification_date_time, comparison_result, local_status);
            IF NOT local_status.normal THEN
              CYCLE /set_attached_release_date_time/;
            IFEND;
            IF comparison_result = pmc$equal THEN
              p_archive_list^[archive_index].archive_entry.last_release_date_time := release_date_time;
              pfp$compute_checksum (^p_archive_list^[archive_index].archive_entry,
                    #SIZE (pft$archive_entry), p_archive_list^[archive_index].checksum);
            IFEND;
          FOREND /set_attached_release_date_time/;
        IFEND;

        pfp$compute_checksum (^p_physical_cycle^.cycle_entry, #SIZE (pft$cycle_entry),
              p_physical_cycle^.checksum);
      IFEND;
      IF p_release_data_info <> NIL THEN
        p_release_data_info^ := release_data_info;
      IFEND;
      RETURN;
    IFEND;

    pfp$build_fmd_pointer (p_physical_cycle^.cycle_entry.fmd_locator, p_catalog_file, p_physical_fmd);
    IF p_physical_fmd <> NIL THEN
      dmp$destroy_permanent_file (p_physical_cycle^.cycle_entry.internal_cycle_name,
            p_physical_fmd^.fmd, status);
      IF NOT status.normal THEN
        pfp$report_unexpected_status (status);
        status.normal := TRUE;
      IFEND;
      {
      { Release the file_media_descriptor even if there is a failure in
      { releasing the mass storage for the file cycle.  This makes the
      { system more fault tolerant and allows the user to continue.
      { Recovery of the set will make the files known to both device
      { management and permanent file management.
      {
      osp$prevalidate_free ((#OFFSET(p_physical_fmd) - #OFFSET(^p_catalog_file^.catalog_heap) - 16),
            ^p_catalog_file^.catalog_heap, prevalidate_free_result);
      IF prevalidate_free_result = osc$heap_free_valid THEN
        FREE p_physical_fmd IN p_catalog_file^.catalog_heap;
      ELSE
        pfp$report_invalid_free (^path, ^p_physical_cycle^.cycle_entry.cycle_number, 'FILE_MEDIA_DESCRIPTOR',
              'file', prevalidate_free_result, #OFFSET(p_physical_fmd));
        p_physical_fmd := NIL;
      IFEND;
      pfp$build_fmd_locator ({p_physical_fmd} NIL, {p_catalog_file} NIL,
            p_physical_cycle^.cycle_entry.fmd_locator);
    IFEND;

    pfp$build_mainfram_list_pointer (p_physical_cycle^.cycle_entry.mainframe_usage_list_locator,
          p_catalog_file, p_mainframe_usage_list);
    IF p_mainframe_usage_list <> NIL THEN
      osp$prevalidate_free ((#OFFSET(p_mainframe_usage_list) -
            #OFFSET(^p_catalog_file^.catalog_heap) - 16), ^p_catalog_file^.catalog_heap,
            prevalidate_free_result);
      IF prevalidate_free_result = osc$heap_free_valid THEN
        FREE p_mainframe_usage_list IN p_catalog_file^.catalog_heap;
      ELSE
        pfp$report_invalid_free (^path, ^p_physical_cycle^.cycle_entry.cycle_number, 'MAINFRAME_USAGE_LIST',
              'file', prevalidate_free_result, #OFFSET(p_mainframe_usage_list));
        p_mainframe_usage_list := NIL;
      IFEND;
    IFEND;
    pfp$build_mainfram_list_locator ({p_mainframe_list} NIL, {p_catalog_file} NIL,
          p_physical_cycle^.cycle_entry.mainframe_usage_list_locator);

    p_physical_cycle^.cycle_entry.attach_status := pfv$unattached_status;
    p_physical_cycle^.cycle_entry.first_mainframe_usage_entry.entry_type := pfc$free_mainframe_entry;
    p_physical_cycle^.cycle_entry.data_residence := pfc$offline_data;

    IF (NOT release_data_info.valid_archive_entry_found) AND
          (data_modification_date_time <> p_archive_entry^.modification_date_time) THEN
      p_physical_cycle^.cycle_entry.cycle_statistics.modification_date_time :=
            p_archive_entry^.modification_date_time;
      p_physical_cycle^.cycle_entry.data_modification_date_time := p_archive_entry^.modification_date_time;
      p_physical_cycle^.cycle_entry.cycle_damage_symptoms :=
            p_physical_cycle^.cycle_entry.cycle_damage_symptoms +
            $fst$cycle_damage_symptoms [fsc$respf_modification_mismatch];
    IFEND;

    IF release_data_info.update_last_release_date_time THEN
      pmp$get_compact_date_time (release_date_time, local_status);
    /set_release_date_time/
      FOR archive_index := 1 TO UPPERBOUND (p_archive_list^) DO
        pmp$date_time_compare (p_archive_list^ [archive_index].archive_entry.modification_date_time,
              p_physical_cycle^.cycle_entry.data_modification_date_time, comparison_result, local_status);
        IF NOT local_status.normal THEN
          CYCLE /set_release_date_time/;
        IFEND;
        IF comparison_result = pmc$equal THEN
          p_archive_list^[archive_index].archive_entry.last_release_date_time := release_date_time;
          pfp$compute_checksum (^p_archive_list^[archive_index].archive_entry,
                #SIZE (pft$archive_entry), p_archive_list^[archive_index].checksum);
        IFEND;
      FOREND /set_release_date_time/;
    IFEND;

    pfp$compute_checksum (^p_physical_cycle^.cycle_entry, #SIZE (pft$cycle_entry),
          p_physical_cycle^.checksum);

    IF p_release_data_info <> NIL THEN
      p_release_data_info^ := release_data_info;
    IFEND;
  PROCEND release_cycle_data;

?? TITLE := '  replace_permit_description', EJECT ??
{       REPLACE_PERMIT_DESCRIPTION
{
{   The purpose of this procedure is to replace the permit description for a
{ specified group that may exist in a permit list.  If no permit description
{ currently exists for the group, a new one is created.  If the permit list is
{ expanded as a result of adding a new permit description, a new, larger permit
{ list is created and the old list is copied to the new list.

  PROCEDURE replace_permit_description
    (    path: pft$complete_path;
         group: pft$group;
         permit_selections: pft$permit_selections;
         share_requirements: pft$share_requirements;
         application_info: pft$application_info;
         p_object: {i^/o^} pft$p_object;
         p_catalog_file: {i^/o^} pft$p_catalog_file;
     VAR status: ost$status);

    VAR
      p_permit: pft$p_permit;

    status.normal := TRUE;

    locate_group (p_object^.object_entry.permit_list_locator, p_catalog_file, group, p_permit);
    IF p_permit = NIL THEN
      establish_free_permit_entry (path, p_object, p_catalog_file, p_permit, status);
      IF status.normal THEN
        p_permit^.permit_entry.entry_type := pfc$normal_permit_entry;
        p_permit^.permit_entry.group := group;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    p_permit^.permit_entry.usage_permissions := permit_selections;
    p_permit^.permit_entry.share_requirements := share_requirements;
    p_permit^.permit_entry.application_info := application_info;
    pfp$compute_checksum (#LOC (p_permit^.permit_entry), #SIZE (pft$permit_entry), p_permit^.checksum);
  PROCEND replace_permit_description;

?? TITLE := '  ring_vote_selected_access', EJECT ??

  PROCEDURE ring_vote_selected_access
    (    access_mode_choice: fst$access_mode_choices;
         cycle_formerly_opened_info: fmt$cycle_formerly_opened_info;
         validation_ring: ost$valid_ring;
     VAR usage_selections: {i/o} pft$usage_selections;
     VAR valid_ring: boolean);

    fmi$validate_ring_attributes (cycle_formerly_opened_info, usage_selections, validation_ring, valid_ring);

    WHILE NOT valid_ring AND (access_mode_choice = fsc$permitted_access_modes) AND
          (usage_selections <> $pft$usage_selections []) DO
      IF (usage_selections * pfv$write_usage) <> $pft$usage_selections [] THEN
        usage_selections := usage_selections - pfv$write_usage;
      ELSEIF pfc$read IN usage_selections THEN
        usage_selections := usage_selections - $pft$usage_selections [pfc$read];
      ELSE
        usage_selections := $pft$usage_selections [];
      IFEND;

      IF usage_selections <> $pft$usage_selections [] THEN
        fmi$validate_ring_attributes (cycle_formerly_opened_info, usage_selections, validation_ring,
              valid_ring);
      IFEND;
    WHILEND;
  PROCEND ring_vote_selected_access;

?? TITLE := '  set_flush_catalog_pages', EJECT ??

    { DESIGN:
    {   This procedure will inhibit catalog flushing under certain conditions.
    {   The flush_catalog_pages field of the catalog_locator is set to TRUE when the catalog
    {   is opened and should not be modified prior to passing the value to this procedure.
    {   The following rules for flushing catalog pages are used:
    {      Flush catalog pages on the first attach for write access.
    {      Flush catalog pages when cycle_entry spans an allocation unit boundary.
    {      Do not flush catalog pages when the file is being attached for read access.
    {
    {   IF cycle_not_currently_attached_for_write AND this_attach_is_for_write THEN
    {     flush_catalog_pages := TRUE
    {   ELSE
    {     flush_catalog_pages := FALSE;
    {   IFEND;
    {

  PROCEDURE [INLINE] set_flush_catalog_pages
    (    usage_selections: pft$usage_selections;
         p_cycle: {input} pft$p_cycle;
     VAR flush_catalog_pages: boolean);

    IF pfv$restrict_catalog_flushing THEN
      flush_catalog_pages := (NOT pfp$cycle_attached_for_write (p_cycle)) AND
              ((usage_selections * $pft$usage_selections [pfc$shorten, pfc$append, pfc$modify])
              <> $pft$usage_selections []) AND pfv$flush_catalogs;

      {
      { Force flushing of catalog pages if the cycle_entry crosses an allocation unit boundary
      { and flushing was set to FALSE.
      {
      IF NOT flush_catalog_pages THEN
        flush_catalog_pages := (((#OFFSET (p_cycle) MOD pfc$catalog_allocation_size) +
              #SIZE (pft$physical_cycle)) > pfc$catalog_allocation_size) AND
              pfv$flush_catalogs;
      IFEND;
    IFEND;
  PROCEND set_flush_catalog_pages;

?? TITLE := '  store_file_label', EJECT ??

  PROCEDURE store_file_label
    (    path: pft$complete_path;
         p_file_label: {input} fmt$p_file_label;
         p_catalog_file: {i^/o^} pft$p_catalog_file;
         p_cycle: {i^/o^} pft$p_cycle;
     VAR p_old_stored_file_label: {i/o} pft$p_stored_file_label;
     VAR status: ost$status);

    VAR
      label_replaced: boolean,
      p_new_stored_file_label: pft$p_stored_file_label,
      prevalidate_free_result: ost$prevalidate_free_result;

    update_file_label (p_file_label, p_old_stored_file_label, ^p_catalog_file^.catalog_heap,
          p_new_stored_file_label, label_replaced, status);

    IF status.normal AND label_replaced THEN
      pfp$build_file_label_locator (p_new_stored_file_label, p_catalog_file,
            p_cycle^.cycle_entry.file_label_locator);
      pfp$compute_checksum (#LOC (p_cycle^.cycle_entry), #SIZE (pft$cycle_entry), p_cycle^.checksum);

      IF p_old_stored_file_label <> NIL THEN
        osp$prevalidate_free ((#OFFSET(p_old_stored_file_label) -
              #OFFSET(^p_catalog_file^.catalog_heap) - 16),
              ^p_catalog_file^.catalog_heap, prevalidate_free_result);
        IF prevalidate_free_result = osc$heap_free_valid THEN
          FREE p_old_stored_file_label IN p_catalog_file^.catalog_heap;
        ELSE
          pfp$report_invalid_free (^path, ^p_cycle^.cycle_entry.cycle_number, 'FILE_LABEL', 'file',
                prevalidate_free_result, #OFFSET(p_old_stored_file_label));
          p_old_stored_file_label := NIL;
        IFEND;
      IFEND;
    IFEND;
  PROCEND store_file_label;

?? TITLE := '  [INLINE] update_access_date', EJECT ??
{       UPDATE_ACCESS_DATE
{
{   The purpose of this procedure is to update the cycle statistics to reflect
{ the file access indicated by the usage_intentions and share_intentions
{ parameters.  This does NOT update usage count.

  PROCEDURE [INLINE] update_access_date
    (    old_cycle_statistics: pft$cycle_statistics;
         date_time: ost$date_time;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
     VAR new_cycle_statistics: pft$cycle_statistics);

    new_cycle_statistics := old_cycle_statistics;
    new_cycle_statistics.access_date_time := date_time;
    IF (usage_selections * pfv$write_usage) <> $pft$usage_selections [] THEN
      new_cycle_statistics.modification_date_time := date_time;
    IFEND;
  PROCEND update_access_date;

?? TITLE := '  update_access_log', EJECT ??
{       UPDATE_ACCESS_LOG
{
{   The purpose of this procedure is to locate the log entry for the specified
{ user in the log list and update it.  If no log entry is found for the user, a
{ new one is created.  If the log list is expanded as a result of adding a new
{ log entry, a new, larger log list is created and the old list is copied to
{ the new list.

  PROCEDURE update_access_log
    (    date_time: ost$date_time;
         authority: pft$authority;
         cycle_number: pft$cycle_number;
         p_catalog_heap: {output^} pft$p_catalog_heap;
     VAR p_log_list: {i/o} pft$p_log_list;
     VAR p_new_log_list: {output} pft$p_log_list;
     VAR new_log_list: boolean;
     VAR status: ost$status);

    VAR
      p_log: pft$p_log,
      physical_log: pft$physical_log,
      user_id: ost$user_identification;

    status.normal := TRUE;
    new_log_list := FALSE;
    user_id.family := authority.family;
    user_id.user := authority.user;

    pfp$locate_log_entry (p_log_list, user_id, p_log);
    IF p_log = NIL THEN
      establish_free_log_entry (p_catalog_heap, p_log_list, p_new_log_list, new_log_list, p_log, status);
      IF status.normal THEN
        physical_log.log_entry.entry_type := pfc$normal_log_entry;
        physical_log.log_entry.user_id := user_id;
        physical_log.log_entry.access_count := 0;
      ELSE
        RETURN;
      IFEND;
    ELSE
      physical_log := p_log^;
    IFEND;

    physical_log.log_entry.access_date_time := date_time;
    physical_log.log_entry.access_count := physical_log.log_entry.access_count + 1;
    physical_log.log_entry.last_cycle := cycle_number;
    pfp$compute_checksum (#LOC (physical_log.log_entry), #SIZE (pft$log_entry), physical_log.checksum);
    p_log^ := physical_log;
  PROCEND update_access_log;

?? TITLE := '  update_all_cycles_modif_date', EJECT ??
{       UPDATE_ALL_CYCLES_MODIF_DATE
{
{   The purpose of this procedure is to update the cycle modification date of all
{ cycles of a file to indicate that the cycles are modified.  It is neccessary
{ for all cycles to appear modified after a pf name change, so that the cycles
{ will be backed-up on a partial backup.  New checksums are computed for each
{ cycle.

  PROCEDURE update_all_cycles_modif_date
    (    date_time: ost$date_time;
         p_cycle_list: {i/o^} pft$p_cycle_list);

    VAR
      cycle_index: pft$cycle_index;

    IF p_cycle_list <> NIL THEN
      FOR cycle_index := 1 TO UPPERBOUND (p_cycle_list^) DO
        IF p_cycle_list^ [cycle_index].cycle_entry.entry_type = pfc$normal_cycle_entry THEN
          p_cycle_list^[cycle_index].cycle_entry.cycle_statistics.modification_date_time := date_time;
          pfp$compute_checksum (#LOC (p_cycle_list^ [cycle_index].cycle_entry), #SIZE (pft$cycle_entry),
                p_cycle_list^ [cycle_index].checksum);
        IFEND;
      FOREND;
    IFEND;
  PROCEND update_all_cycles_modif_date;

?? TITLE := '  [INLINE] update_cycle_statistics', EJECT ??
{       UPDATE_CYCLE_STATISTICS
{
{   The purpose of this procedure is to update the cycle statistics to reflect
{ the file access indicated by the usage_intentions and share_intentions
{ parameters.

  PROCEDURE [INLINE] update_cycle_statistics
    (    old_cycle_statistics: pft$cycle_statistics;
         date_time: ost$date_time;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
     VAR new_cycle_statistics: pft$cycle_statistics;
     VAR new_data_modification_date_time: ost$date_time);

    update_access_date (old_cycle_statistics, date_time, usage_selections, share_selections,
          new_cycle_statistics);
    IF (usage_selections * pfv$write_usage) <> $pft$usage_selections [] THEN
      new_data_modification_date_time := date_time;
    IFEND;
    new_cycle_statistics.access_count := old_cycle_statistics.access_count + 1;

  PROCEND update_cycle_statistics;

?? TITLE := '  update_file_label', EJECT ??

  PROCEDURE update_file_label
    (    p_file_label: {input} fmt$p_file_label;
         p_old_stored_file_label: {i/o^} pft$p_stored_file_label;
         p_catalog_heap: {output^} pft$p_catalog_heap;
     VAR p_new_stored_file_label: {output} pft$p_stored_file_label;
     VAR new_stored_file_label: boolean;
     VAR status: ost$status);

    IF (p_old_stored_file_label = NIL) OR (#SIZE (p_file_label^) <>
          #SIZE (p_old_stored_file_label^.file_label)) THEN
      ALLOCATE p_new_stored_file_label: [[REP (#SIZE (p_file_label^)) OF cell]] IN p_catalog_heap^;
      IF p_new_stored_file_label = NIL THEN
        new_stored_file_label := FALSE;
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, '', status);
      ELSE
        p_new_stored_file_label^.file_label := p_file_label^;
        pfp$compute_checksum (#LOC (p_file_label^), #SIZE (p_file_label^), p_new_stored_file_label^.checksum);
        new_stored_file_label := TRUE;
        status.normal := TRUE;
      IFEND;
    ELSE
      p_old_stored_file_label^.file_label := p_file_label^;
      pfp$compute_checksum (#LOC (p_file_label^), #SIZE (p_file_label^), p_old_stored_file_label^.checksum);
      new_stored_file_label := FALSE;
      status.normal := TRUE;
    IFEND;
  PROCEND update_file_label;

?? TITLE := '  update_mainframe_usage', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is update the mainframe usage to reflect
{   the addition of this usage.  If required, a new mainframe entry will be added
{   to the cycle entry.  If the mainframe already is recorded in the cycle entry,
{   the entry for the mainframe is incremented to indicate this additional attach.

  PROCEDURE update_mainframe_usage
    (    path: pft$complete_path;
         mainframe_id: pmt$binary_mainframe_id;
         usage_selections: pft$usage_selections;
         p_catalog_file: pft$p_catalog_file;
     VAR flush_catalog_pages: boolean;
     VAR cycle_entry: {input, output} pft$cycle_entry;
     VAR status: ost$status);

    VAR
      first_mainframe: boolean,
      mainframe_found: boolean,
      p_physical_mainframe_usage: ^pft$physical_mainframe_usage;


    locate_mainframe_usage (mainframe_id, cycle_entry, p_catalog_file, mainframe_found, first_mainframe,
          p_physical_mainframe_usage);
    IF mainframe_found THEN
      status.normal := TRUE;
      IF first_mainframe THEN
        increment_mainframe_usage (usage_selections, cycle_entry.first_mainframe_usage_entry);
      ELSE
        increment_mainframe_usage (usage_selections, p_physical_mainframe_usage^.mainframe_usage);
        pfp$compute_checksum (^p_physical_mainframe_usage^.mainframe_usage,
              #SIZE (p_physical_mainframe_usage^.mainframe_usage), p_physical_mainframe_usage^.checksum);
      IFEND;
    ELSE
      establish_free_mainframe_entry (path, p_catalog_file, cycle_entry, first_mainframe,
            p_physical_mainframe_usage, status);
      IF status.normal THEN
        flush_catalog_pages := pfv$flush_catalogs;
        IF first_mainframe THEN
          cycle_entry.first_mainframe_usage_entry.entry_type := pfc$normal_mainframe_entry;
          cycle_entry.first_mainframe_usage_entry.mainframe_id := mainframe_id;
          cycle_entry.first_mainframe_usage_entry.attach_count := 0;
          cycle_entry.first_mainframe_usage_entry.write_count := 0;
          increment_mainframe_usage (usage_selections, cycle_entry.first_mainframe_usage_entry);
        ELSE
          p_physical_mainframe_usage^.mainframe_usage.entry_type := pfc$normal_mainframe_entry;
          p_physical_mainframe_usage^.mainframe_usage.mainframe_id := mainframe_id;
          p_physical_mainframe_usage^.mainframe_usage.attach_count := 0;
          p_physical_mainframe_usage^.mainframe_usage.write_count := 0;
          increment_mainframe_usage (usage_selections, p_physical_mainframe_usage^.mainframe_usage);
          pfp$compute_checksum (^p_physical_mainframe_usage^.mainframe_usage,
                #SIZE (p_physical_mainframe_usage^.mainframe_usage), p_physical_mainframe_usage^.checksum);
        IFEND;
      IFEND;
    IFEND;
  PROCEND update_mainframe_usage;

?? TITLE := '  validate_access_and_share_modes', EJECT ??

  PROCEDURE validate_access_and_share_modes
    (    evaluated_file_reference: fst$evaluated_file_reference;
         last_access_and_share_modes: boolean;
         access_modes: fst$access_modes;
         share_modes: fst$share_modes;
         allowed_access: fst$file_access_options;
         required_sharing: fst$file_access_options;
         initial_open: boolean;
         create_file: boolean;
         device_class: rmt$device_class;
     VAR access_selections: fst$file_access_options;
     VAR share_selections: fst$file_access_options;
     VAR permitted_access_modes_failure: boolean;
     VAR status: ost$status);

    CONST
      include_open_position = TRUE;

    VAR
      p_fs_path: ^fst$path,
      fs_path_size: fst$path_size,
      local_status: ost$status;

    IF access_modes.selector = fsc$permitted_access_modes THEN
      IF allowed_access = $fst$file_access_options [] THEN
        permitted_access_modes_failure := TRUE;
        PUSH p_fs_path;
        clp$convert_file_ref_to_string (evaluated_file_reference, NOT include_open_position, p_fs_path^,
              fs_path_size, local_status);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_busy, p_fs_path^ (1, fs_path_size),
              status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              evaluated_file_reference.cycle_reference.cycle_number, radix, NOT include_radix, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, pfc$current_job_usage_conflict,
              status);
      ELSE
        access_selections := allowed_access;
        permitted_access_modes_failure := FALSE;
        status.normal := TRUE;
      IFEND;
{   ELSEIF access_modes.value = $fst$file_access_options [] THEN
{     permitted_access_modes_failure := FALSE;
{     PUSH p_fs_path;
{     clp$convert_file_ref_to_string (evaluated_file_reference, NOT include_open_position, p_fs_path^,
{           fs_path_size, status);
{     osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$null_access_not_allowed,
{           p_fs_path^ (1, fs_path_size), status);
    ELSEIF access_modes.value <= allowed_access THEN
      access_selections := access_modes.value;
      permitted_access_modes_failure := FALSE;
      status.normal := TRUE;
    ELSE
      permitted_access_modes_failure := FALSE;
      IF last_access_and_share_modes THEN
        PUSH p_fs_path;
        clp$convert_file_ref_to_string (evaluated_file_reference, NOT include_open_position, p_fs_path^,
              fs_path_size, local_status);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_busy, p_fs_path^ (1, fs_path_size),
              status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              evaluated_file_reference.cycle_reference.cycle_number, radix, NOT include_radix, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, pfc$current_job_usage_conflict,
              status);
      ELSE
        osp$set_status_condition (pfe$cycle_busy, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      CASE share_modes.selector OF
      = fsc$determine_from_access_modes =
        IF (access_selections * $fst$file_access_options [fsc$shorten, fsc$append,
              fsc$modify]) = $fst$file_access_options [] THEN
          share_selections := $fst$file_access_options [fsc$execute, fsc$read];
        ELSE
          share_selections := $fst$file_access_options [];
        IFEND;
        IF NOT (required_sharing <= share_selections) THEN
          IF last_access_and_share_modes THEN
            PUSH p_fs_path;
            clp$convert_file_ref_to_string (evaluated_file_reference, NOT include_open_position, p_fs_path^,
                  fs_path_size, local_status);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_busy,
                  p_fs_path^ (1, fs_path_size), status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  evaluated_file_reference.cycle_reference.cycle_number, radix, NOT include_radix, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, pfc$current_job_share_conflict,
                  status);
          ELSE
            osp$set_status_condition (pfe$cycle_busy, status);
          IFEND;
        IFEND;

      = fsc$required_share_modes =
        share_selections := required_sharing;

      = fsc$specific_share_modes =
        IF required_sharing <= share_modes.value THEN
          share_selections := share_modes.value;
        ELSEIF last_access_and_share_modes THEN
          PUSH p_fs_path;
          clp$convert_file_ref_to_string (evaluated_file_reference, NOT include_open_position, p_fs_path^,
                fs_path_size, local_status);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_busy,
                p_fs_path^ (1, fs_path_size), status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                evaluated_file_reference.cycle_reference.cycle_number, radix, NOT include_radix, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, pfc$current_job_share_conflict,
                status);
        ELSE
          osp$set_status_condition (pfe$cycle_busy, status);
        IFEND;

      ELSE
        osp$set_status_abnormal (pfc$permanent_file_manager_id, fse$system_error, '', status);
        #KEYPOINT (osk$unusual, 0, fsk$invalid_share_mode_selector);
      CASEND;
    IFEND;

    IF status.normal AND initial_open AND
          (((NOT (fsc$append IN access_selections)) AND (device_class = rmc$mass_storage_device)) OR
          (access_selections = $fst$file_access_options [])) THEN

      IF last_access_and_share_modes THEN
        PUSH p_fs_path;
        clp$convert_file_ref_to_string (evaluated_file_reference, NOT include_open_position, p_fs_path^,
              fs_path_size, local_status);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, ame$new_file_requires_append,
              p_fs_path^ (1, fs_path_size), status);
      ELSE
        osp$set_status_condition (ame$new_file_requires_append, status);
      IFEND;
    IFEND;
  PROCEND validate_access_and_share_modes;

?? TITLE := '  [INLINE] validate_cycle_number_change', EJECT ??

  PROCEDURE [INLINE] validate_cycle_number_change
    (    path: pft$complete_path;
         old_cycle_number: pft$cycle_number;
         new_cycle_number: pft$cycle_number;
         p_cycle_list: {input} pft$p_cycle_list;
     VAR status: ost$status);

    VAR
      cycle_selector: pft$cycle_selector,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      p_cycle: pft$p_cycle;

    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := new_cycle_number;
    pfp$locate_cycle (path, p_cycle_list, cycle_selector, p_cycle, status);
    IF status.normal THEN
      IF new_cycle_number <> old_cycle_number THEN
        pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$duplicate_cycle,
              fs_path (1, fs_path_size), status);
        osp$append_status_integer (osc$status_parameter_delimiter, new_cycle_number, 10, FALSE, status);
      IFEND;
    ELSE { New cycle number does not already exist.
      status.normal := TRUE;
    IFEND;
  PROCEND validate_cycle_number_change;

?? TITLE := '  validate_object_name_change', EJECT ??

  PROCEDURE validate_object_name_change
    (    path: pft$complete_path;
         new_object_name: pft$name;
         object_list_descriptor: pft$object_list_descriptor;
         p_catalog_file: {input^} pft$p_catalog_file;
         authority: pft$authority;
         permit_entry: pft$permit_entry;
     VAR status: ost$status);

    VAR
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      last_name_index: integer,
      new_permit_entry: pft$permit_entry,
      p_new_path: pft$p_complete_path,
      p_object: pft$p_object,
      p_permit_list: pft$p_permit_list,
      path_index: integer;

    status.normal := TRUE;

    IF path [UPPERBOUND (path)] <> new_object_name THEN
      pfp$locate_object (new_object_name, $pft$object_selections
            [pfc$file_object, pfc$catalog_object], object_list_descriptor, p_object);
      IF p_object <> NIL THEN
        IF authority.ownership = $pft$ownership [] THEN
          pfp$build_permit_list_pointer (p_object^.object_entry.permit_list_locator, p_catalog_file,
                p_permit_list);
          pfp$extract_permit_entry (p_permit_list, authority, new_permit_entry);
          pfp$reduce_permits (permit_entry, new_permit_entry, new_permit_entry);

          IF (new_permit_entry.entry_type = pfc$free_permit_entry) OR
                (new_permit_entry.usage_permissions = $pft$permit_selections []) THEN
            last_name_index := UPPERBOUND (path);
            PUSH p_new_path: [1 .. last_name_index];
            FOR path_index := 1 TO last_name_index - 1 DO
              p_new_path^ [path_index] := path [path_index];
            FOREND;
            p_new_path^ [last_name_index] := new_object_name;
            pfp$convert_pf_path_to_fs_path (p_new_path^, fs_path, fs_path_size);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$name_already_used,
                  fs_path (1, fs_path_size), status);
          IFEND;
        IFEND;

        IF status.normal THEN
          last_name_index := UPPERBOUND (path);
          PUSH p_new_path: [1 .. last_name_index];
          FOR path_index := 1 TO last_name_index - 1 DO
            p_new_path^ [path_index] := path [path_index];
          FOREND;
          p_new_path^ [last_name_index] := new_object_name;
          pfp$convert_pf_path_to_fs_path (p_new_path^, fs_path, fs_path_size);
          IF p_object^.object_entry.object_type = pfc$file_object THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$name_already_permanent_file,
                  fs_path (1, fs_path_size), status);
          ELSEIF (last_name_index = pfc$family_path_index) THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$duplicate_family_catalog,
                  fs_path (1, fs_path_size), status);
          ELSEIF (last_name_index = pfc$master_catalog_path_index) THEN
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$duplicate_master_catalog,
                  fs_path (1, fs_path_size), status);
          ELSE
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$name_already_subcatalog,
                  fs_path (1, fs_path_size), status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND validate_object_name_change;

?? TITLE := '  validate_permission_and_sharing', EJECT ??

  PROCEDURE validate_permission_and_sharing
    (    path: pft$complete_path;
         cycle_reference: fst$cycle_reference;
         mainframe_id: pmt$binary_mainframe_id;
         access_modes: fst$access_modes;
         share_modes: fst$share_modes;
         authority: pft$authority;
         permit_entry: pft$permit_entry;
         cycle_entry: pft$cycle_entry;
         device_class: rmt$device_class;
         cycle_previously_opened: boolean;
         p_catalog_file: {input^} ^pft$catalog_file;
     VAR usage_allowed: pft$usage_selections;
     VAR usage_selections: pft$usage_selections;
     VAR sharing_required: pft$share_selections;
     VAR share_selections: pft$share_selections;
     VAR status: ost$status);

    VAR
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      multiple_job_usage_selections: pft$usage_selections,
      p_mainframe_usage_list: ^pft$mainframe_usage_list,
      usage_intentions: pft$permit_selections;

    determine_usage_allowed (path, cycle_reference, mainframe_id, access_modes, authority, permit_entry,
          cycle_entry, p_catalog_file, usage_allowed, usage_selections, multiple_job_usage_selections,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    determine_share_with_fs_select (usage_selections, share_modes, authority, permit_entry, cycle_entry,
          device_class, sharing_required, share_selections);

    IF (access_modes.selector <> fsc$permitted_access_modes) OR
          (share_modes.selector <> fsc$required_share_modes) THEN
      pfp$map_usage_selections (usage_selections, usage_intentions);
      pfp$validate_file_permission (path, authority, permit_entry, usage_intentions, share_selections,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    { Determine if the cycle is busy, and if so why.

    { Check for conflicts between jobs.
    {
    IF access_modes.selector = fsc$permitted_access_modes THEN
      IF multiple_job_usage_selections = $pft$usage_selections [] THEN
        {
        { If there is no usage because of multimainframes, catch it later.
        {
        pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_busy, fs_path (1, fs_path_size),
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, cycle_entry.cycle_number, radix,
              NOT include_radix, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, pfc$multiple_job_usage_conflict, status);
      IFEND;
    ELSE {fsc$specific_access_modes}
      IF (cycle_entry.attach_status.attach_count > 0) AND
            cycle_busy_due_to_usage (cycle_entry.attach_status, usage_intentions) THEN
        pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_busy, fs_path (1, fs_path_size),
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, cycle_entry.cycle_number, radix,
              NOT include_radix, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, pfc$multiple_job_usage_conflict, status);
      IFEND;
    IFEND;

    IF (share_modes.selector <> fsc$required_share_modes) AND (cycle_entry.attach_status.attach_count > 0) AND
          cycle_busy_due_to_sharing (cycle_entry.attach_status, share_selections) THEN
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_busy, fs_path (1, fs_path_size),
            status);
      osp$append_status_integer (osc$status_parameter_delimiter, cycle_entry.cycle_number, radix,
            NOT include_radix, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, pfc$multiple_job_share_conflict, status);
    IFEND;

    { Check for multimainframe conflicts.
    {
    IF status.normal THEN
      IF access_modes.selector = fsc$permitted_access_modes THEN
        IF usage_selections = $pft$usage_selections [] THEN
          pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_busy, fs_path (1, fs_path_size),
                status);
          osp$append_status_integer (osc$status_parameter_delimiter, cycle_entry.cycle_number, radix,
                NOT include_radix, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, pfc$another_mainframe_user, status);
        ELSEIF cycle_entry.attach_status.attach_count > 0 THEN
          pfp$build_mainfram_list_pointer (cycle_entry.mainframe_usage_list_locator, p_catalog_file,
                p_mainframe_usage_list);
          IF other_mainframe_writer (mainframe_id, cycle_entry, p_mainframe_usage_list) THEN
            pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
            osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$cycle_busy, fs_path (1, fs_path_size),
                  status);
            osp$append_status_integer (osc$status_parameter_delimiter, cycle_entry.cycle_number, radix,
                  NOT include_radix, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, pfc$another_mainframe_writer,
                  status);
          IFEND;
        IFEND;
      ELSEIF cycle_entry.attach_status.attach_count > 0 THEN
        check_mainframe_usage (path, mainframe_id, usage_intentions, p_catalog_file, cycle_entry, status);
      IFEND;
    IFEND;

    { Append access is required if the file has never been opened and has a disk image.
    IF status.normal AND (NOT cycle_previously_opened) AND (usage_selections <> $pft$usage_selections []) AND
          (NOT (pfc$append IN usage_selections)) AND (device_class = rmc$mass_storage_device) AND
          (((cycle_entry.data_residence = pfc$releasable_data) OR
          (cycle_entry.data_residence = pfc$unreleasable_data)) AND
          (cycle_entry.fmd_locator.fmd_size > 0)) THEN
      pfp$convert_pf_path_to_fs_path (path, fs_path, fs_path_size);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, ame$new_file_requires_append,
            fs_path (1, fs_path_size), status);
    IFEND;
  PROCEND validate_permission_and_sharing;

?? OLDTITLE, SKIP := 2 ??
MODEND pfm$r2_request_processor;
*DECK DECK=PFM$RECOVER_SYSTEM_SET_HELP EXPAND=TRUE
~"  CREATE_MESSAGE_MODULE RECOVER_SYSTEM_SET$US_ENGLISH
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=INITIALIZE_SYSTEM_DEVICE

  You selected the RECOVER_SYSTEM_SET parameter of INITIALIZE_SYSTEM_DEVICE
  system core command.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=INITIALIZE_SYSTEM_CATALOG

  The $SYSTEM master catalog has been re-created.  Either you have changed
  the state of a disk unit whose volume contains $SYSTEM catalogs (class J)
  or such a volume has been made inaccessible via reconfiguration.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=RSS_CONSEQUENCES

  You will lose the following as a consequence of this process:

    - Queued input files destined for execution on this mainframe
    - Queued input files destined for execution on another mainframe
    - Executing jobs
    - Global system logs
    - Any files that may have resided on the lost $SYSTEM catalog volume
    - $SYSTEM files and catalogs created since the last catalog backup

  The process of recovering the system set includes restoring catalogs,
  optionally restoring unreconciled (missing) files, and performing a
  continuation deadstart.  First, you must restore catalogs:
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ACTIVE_VOLUME_SUMMARY

  There are ~P active volumes.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CATALOG_RESTORATION

  Locate the most recent catalog backup.  If you include catalogs in your
  partial backup and you also backup catalogs separately, choose the most
  recent of the two for catalog restoration.

  If the tape volumes are unlabelled or you have to take manual action at the
  System Console to complete the restoration, you must use the STOP function
  key before you can enter a command.  Enter RESUME_COMMAND (RESC) to continue
  this command.

  YOU CANNOT SUBMIT BATCH JOBS OR ACCESS PERMANENT FILES AT THIS TIME.

  In a moment you will be asked to supply values for the parameters of the
  RESTORE_UNRECONCILED_CATALOGS command which restores catalogs from a backup
  recorded on magnetic tape.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PARAMETER_PROMPTING

  If you need help determining how to answer the prompt for a parameter value,
  enter a question mark (?).  To terminate prompting of optional parameters,
  enter a semi-colon (;).
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ABNORMAL_STATUS

  The RESTORE_UNRECONCILED_CATALOGS command returned the following abnormal
  status.  Please repeat the catalog restoration until successful.  If the
  most recent catalog backup cannot be read, then use a less recent catalog
  backup.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=DELETING_$SYSTEM_DAMAGE

  Deleting the damage conditions from the ~P $SYSTEM files.
  This may take awhile.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=DETERMINE_UNRECONCILED_FILES

  Determining the extent of unreconciled files and catalogs.
  This may take a long time.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=UNRECONCILED_FILES

  There are ~P1 files and ~P2 catalogs that are unreconciled.

  This may be an indication that you forgot to configure a volume that once
  was a member of the system set.  If this is the case, choose the option
  in the main menu to display the active volumes to see if a volume is
  missing.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ALL_IS_WELL

  There are no unreconciled files or catalogs.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=FILE_RESTORATION

  YOU CANNOT SUBMIT BATCH JOBS OR ACCESS PERMANENT FILES AT THIS TIME.

  In a moment you will be asked to supply values for the parameters of the
  RESTORE_UNRECONCILED_FILES command that restores files from a file backup
  recorded on magnetic tape.  Some of the parameter values will be
  automatically selected.  The remaining parameters consist of both required
  and optional parameters that control the source and destination of the
  file restoration.

  If the tape volumes are unlabelled or you have to take manual action at the
  System Console to complete the restoration, you must use the STOP function
  key before you can enter a command.  Enter RESUME_COMMAND (RESC) to continue
  this command.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=RESULTS_ON_FILE

  File: ~P
  has been created and has been entered in the output queue.  This file
  contains a history of what has happened during the recovery process.
  Delete the file only after it has been successfully printed; the printing
  should occur after the next deadstart.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=SYSTEM_TERMINATION

  In a moment the NOS/VE system will terminate.  You must then perform a
  continuation deadstart.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TERMINATION_WITH_FILES_MISSING

  It is recommended that you specify pause for operator intervention and
  execute the following System Core command:

    set_system_attribute delete_unreconciled_files 0

  This command ensures that you do not lose files or catalogs during the
  continuation deadstart.  When you are satisfied that your physical
  configuration has been correctly specified, you may delete unreconciled
  files or catalogs at a future continuation deadstart to regain mass
  storage space.

  Do not be alarmed if the SYSTEM_TERMINATION_PROLOG terminates abnormally;
  commands in the prolog may attempt to reference the unreconciled files or
  catalogs.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=NOT_SYSTEM_ORIGIN

  This command may only be executed by the NOS/VE system itself.
~"**
~"END_MESSAGE_MODULE CREATE_MODULE=YES
~"  CREATE_MESSAGE_MODULE DISPLAY_MISSING_MENU$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE


  NOS/VE SYSTEM SET RECOVERY MENU - UNRECONCILED FILE DISPLAY -

  Choose one of the following selections:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=DISPLAY_MISSING_SYSTEM_SET
    1 - Display the names of unreconciled files in the system set.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_WITH_RESTORATION
    2 - Return to the preceding menu.
~"**
~"CREATE_FULL_HELP_MESSAGE

  You may display the names of all of the files that are missing and the
  recorded_vsn of any missing catalog volume.  If you choose not to display
  this information, you return to the preceding menu.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=DISPLAY_MISSING_SYSTEM_SET

  Choose this selection to determine which files may need to be restored.

  You may also use this display to determine whether or not you may have
  made a mistake in specifying your configuration at this deadstart.  The
  display identifies any missing catalog volumes in the system set.

  This selection edits a listing produced by doing a backup of the system set
  to the file $NULL.  A single line is written to the output window at the
  System Console for each unreconciled file or catalog detected in the backup.
  If the file name is quite long, BACPF writes the exception message and the
  file name on separate lines.  This menu selection only displays the line
  containing the exception message.  This is done for expediency because
  finding the long file names takes 100 times longer to produce the display.
  It is suggested that you use the DISPLAY_UNRECONCILED_FILES command in
  $SYSTEM.OSF$SOU_LIBRARY after the next deadstart, if you need to see
  the long file names and you still have missing files at the end of the
  system set recovery process.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CONTINUE_WITH_RESTORATION

  Choose this selection to return to the preceding menu.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROMPT
  Enter selection or ? for HELP.
~"**
~"END_MESSAGE_MODULE CREATE_MODULE=YES
~"  CREATE_MESSAGE_MODULE RSS_RESUC_MENU$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE


  NOS/VE SYSTEM SET RECOVERY MENU - $SYSTEM CATALOG RESTORATION -

  Choose one of the following selections:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=DISPLAY_ACTIVE_VOLUMES
    1 - Display the active volumes for all sets in the system.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=DISPLAY_COMMAND_INFORMATION
    2 - Display command information for RESTORE_UNRECONCILED_CATALOGS.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=RESTORE_ONLY_CATALOGS
    3 - Restore catalogs without restoring files using the
        RESTORE_UNRECONCILED_CATALOGS command.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=RESTORE_CATALOGS_AND_FILES
    4 - Restore catalogs and any files also contained on the volume set
        using the RESTORE_UNRECONCILED_CATALOGS command.  Read the help
        information for this selection before choosing this selection;
        enter 4?.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=QUIT
    5 - QUIT  This item should be selected only if you are confident that
        even though an error has occured you do not wish to continue
        restoring catalogs.  You will be given a chance to restore files.

~"**
~"CREATE_FULL_HELP_MESSAGE

  Because you have initialized the system device or the volume containing the
  $SYSTEM master catalog was not accessible at deadstart, it was necessary to
  temporarily re-create the $SYSTEM master catalog to deadstart the system.

  This process assumes that $SYSTEM catalogs and files may exist on volumes
  other than the system device.  Therefore, the newly re-created $SYSTEM
  master catalog and the files created by this deadstart have been deleted.
  This allows the most recent catalog backup to be restored for the purpose
  of recovering the catalogs and files belonging to $SYSTEM that reside on
  the surviving members of the system set.  If the system device has been
  initialized during this deadstart, the catalogs and files belonging to
  families other than $SYSTEM will also be recovered, if they did not reside
  on the system device.

  Catalogs must be successfully restored using either selection 3 or 4
  before the process of recovering the system set will proceed.  If the
  catalog restoration fails, you will be shown the abnormal status and will
  have an opportunity to repeat the catalog restoration.

  To get help for a particular selection, enter the number of the selection,
  followed by a question mark.  For example, to get the help for selection 1,
  you would enter: 1?
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=RESTORE_ONLY_CATALOGS

  Choose this selection to restore catalogs without restoring any files.

  This selection is the best choice if a $SYSTEM catalog volume was lost
  and the volume did not contain permanent files, i.e. the volume was not
  a member of class K or M.

  This selection is also the best choice if you perform catalog-only
  backups (using CREATE_CATALOG_BACKUP) and you exclude catalogs from
  your partial or full backups.

  If your most recent catalog backup was taken during a full backup or a
  partial backup that consists of many magnetic tape volumes, selection 4
  may be the fastest choice; however, refer to the help information for
  selection 4 before actually selecting this choice.

  If you choose selection 3, you will be given an opportunity to restore
  $SYSTEM files after the catalogs have been restored, when it can more
  reliably be determined which files are missing.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=RESTORE_CATALOGS_AND_FILES

  Choose this selection to restore catalogs and files.

  The only advantage of this choice is speed.  If your most recent catalog
  backup includes $SYSTEM files, then you can restore catalogs and any
  missing $SYSTEM files in one pass through a multi-volume set of magnetic
  tapes.  If you choose selection 3 instead, you will have to mount the
  same set of tapes twice.  However, there is some risk in choosing this
  selection (4):

  If you initialized the system device during this deadstart, you had to
  install the physical configuration either manually or from a deadstart
  tape that may not reflect the most recent mass storage configuration.
  Restoring only catalogs may be the safest choice unless you are absolutely
  certain that all of your mass storage volumes are configured.  If you have
  omitted a volume from the configuration, restoring files at this time might
  cause the loss of files residing on the omitted volume. If you have time,
  choose selection 3, instead.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=DISPLAY_ACTIVE_VOLUMES

  Choose this selection to determine whether your mass storage configuration
  is correct.  If it is not, it is recommended that you deadstart NOS/VE and
  reconfigure rather than proceeding to restore catalogs.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROMPT
  Enter selection or ? for HELP.
~"**
~"END_MESSAGE_MODULE CREATE_MODULE=YES
~"  CREATE_MESSAGE_MODULE RSS_RESUF_MENU$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE


  NOS/VE SYSTEM SET RECOVERY MENU - $SYSTEM FILE RESTORATION -

  Choose one of the following selections:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=DISPLAY_UNRECONCILED_FILES
    1 - Display the number of unreconciled files and catalogs in the
        system set.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=RESTORE_UNRECONCILED_FILES
    2 - Restore files using the RESTORE_UNRECONCILED_FILES command.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=DISPLAY_ACTIVE_VOLUMES
    3 - Display the active volumes for all sets in the system.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=DISPLAY_COMMAND_INFORMATION
    4 - Display command information for RESTORE_UNRECONCILED_FILES.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=QUIT
    5 - QUIT (The system will terminate.)

~"**
~"CREATE_FULL_HELP_MESSAGE

  Because you have initialized the system device or the volume containing the
  $SYSTEM master catalog was not accessible at deadstart, it was necessary to
  restore catalogs to recover the system set.  Now you have the opportunity
  to restore files.

  Unless you choose selection 5 (quit), this menu will be presented after each
  selection you make.  Thus you may iteratively determine how many files
  remain to be restored (selection 1) and then restore a set of backup tapes
  (selection 2) until there are no more unreconciled files.

  It is recommended that you start by restoring files modified since the last
  full backup.  If you use the CREATE_PARTIAL_BACKUP command, there is only
  one partial backup volume set; otherwise, there may be several partial
  backup sets to be restored.  After restoring the partial backup, use
  selection 1 to determine whether or not there are additional files to be
  restored.  If there are, restore files from your last full backup set next.
  If only $SYSTEM files are missing and you have a backup of the $SYSTEM
  family, you may restore it instead of the full backup.

  To get help for a particular selection, enter the number of the selection,
  followed by a question mark.  For example, to get the help for selection 1,
  you would enter: 1?
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=DISPLAY_UNRECONCILED_FILES

  Choose this selection to determine which files or catalogs do not reside on
  mass storage.  The DISPLAY_UNRECONCILED_FILES command displays the name of
  each file or catalog that does not reside on an accessible mass storage
  volume.  A summary is also provided at the end of the display.

  Each time you choose this selection, the display is updated to reflect the
  presence of any file you restored.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=RESTORE_UNRECONCILED_FILES

  Choose this selection to restore files that are no longer on mass storage
  but are still described by a catalog; these are referred to as
  unreconciled files.  The files may be unreconciled because they were
  assigned to the system device that you initialized or the $SYSTEM catalog
  volume that failed.

  However, it is also possible that the files are unreconciled because you
  may have forgotten to configure a mass storage device (or its state is not
  ON).  If you did make a mistake configuring the system, choose selection 5
  (quit), perform a continuation deadstart, reconfigure during the deadstart
  and then restore unreconciled files, if necessary. Otherwise, if you have
  a missing volume and you choose to restore unreconciled files, you may
  lose any changes to those files that had been made since the most recent
  file backup was taken.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=DISPLAY_ACTIVE_VOLUMES

  Choose this selection to determine whether your mass storage configuration
  is correct.  If it is not, it is recommended that you deadstart NOS/VE and
  reconfigure rather than proceeding to restore files.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=QUIT

  Choose this selection to terminate the system.  You will need to perform a
  continuation deadstart to continue production.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROMPT
  Enter selection or ? for HELP.
~"**
~"END_MESSAGE_MODULE CREATE_MODULE=YES
*DECK DECK=PFM$REPORT_UNEXPECTED_STATUS EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Permanent Files : Status Handling' ??
MODULE pfm$report_unexpected_status;
?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$page_width
*copyc dfe$error_condition_codes
*copyc dmt$error_condition_codes
*copyc fsc$max_path_elements
*copyc fsc$max_path_size
*copyc fst$path
*copyc fst$path_element_size
*copyc fst$path_index
*copyc fst$path_size
*copyc mme$condition_codes
*copyc osd$integer_limits
*copyc oss$job_paged_literal
*copyc ost$string
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pft$variant_path
*copyc pmd$system_log_interface
?? POP ??
?? EJECT ??
*copyc clp$convert_integer_to_rjstring
*copyc dpp$put_critical_message
*copyc fsp$path_element
*copyc fsv$evaluated_file_reference
*copyc i#build_adaptable_seq_pointer
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$format_message
*copyc osp$generate_log_message
*copyc osp$get_set_name
*copyc osp$recoverable_system_error
*copyc osp$set_status_abnormal
*copyc osp$unpack_status_condition
*copyc pfv$space_character
*copyc pmp$log_ascii


VAR

   control_codes_translation: [oss$job_paged_literal, READ] string (256) := '            '
     CAT '                     !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijkl'
     CAT 'mnopqrstuvwxyz{|}~                                                                                '
     CAT '                                                 ';

?? TITLE := '  [XDCL, #GATE] pfp$convert_cycle_path_to_strng', EJECT ??
{ PURPOSE:
{   This procedure converts a complete path and cycle number to a string.  The
{   string is a path name suitable for printing and follows the standard form,
{   i.e. it begins with :family_name, contains no blanks, and separates each
{   name with a period.
{
{ NOTE:
{   A set name is expected to be the first name in the path, but is not
{   included in the path name.

  PROCEDURE [XDCL, #GATE] pfp$convert_cycle_path_to_strng
    (    path: pft$complete_path;
         cycle_number: pft$cycle_number;
     VAR path_name: ost$string);

    VAR
      cycle_string: string (6),
      cycle_string_length: integer,
      found: boolean,
      last_name_length: ost$name_size,
      path_index: pft$array_index,
      path_name_length: integer,
      space_index: 1 .. osc$max_name_size + 1;

    path_name_length := 0;

    #SCAN (pfv$space_character, path [UPPERBOUND (path)], space_index, found);
    IF space_index = 1 THEN
      last_name_length := 2;
    ELSE
      last_name_length := space_index - 1;
    IFEND;

    STRINGREP (cycle_string, cycle_string_length, cycle_number);
    cycle_string (1) := '.';

    FOR path_index := pfc$family_path_index TO UPPERBOUND (path) DO
      IF (path [path_index] = osc$null_name) OR (path [path_index] = '') THEN
        path_name.value (path_name_length + 1, 2) := '.?';
        path_name_length := path_name_length + 2;
      ELSEIF path_index = UPPERBOUND (path) THEN
        STRINGREP (path_name.value, path_name_length, path_name.value (1, path_name_length), '.',
              path [UPPERBOUND (path)] (1, last_name_length), cycle_string (1, cycle_string_length));
      ELSE
        #SCAN (pfv$space_character, path [path_index], space_index, found);
        IF path_name_length + space_index + (2 * ((UPPERBOUND (path) - 1) - path_index)) +
              (last_name_length + 1) + cycle_string_length <= osc$max_string_size THEN
          STRINGREP (path_name.value, path_name_length, path_name.value (1, path_name_length), '.',
                path [path_index] (1, space_index - 1));
        ELSE
          {
          { The path name would be too long, so a '?' is substituted for this
          { name in the path.
          {
          path_name.value (path_name_length + 1, 2) := '.?';
          path_name_length := path_name_length + 2;
        IFEND;
      IFEND;
    FOREND;

    path_name.value (1) := ':';
    path_name.size := path_name_length;
  PROCEND pfp$convert_cycle_path_to_strng;

?? TITLE := '  [XDCL, #GATE] pfp$convert_fs_to_complete_path', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$convert_fs_to_complete_path
    (    evaluated_file_reference: fst$evaluated_file_reference;
     VAR p_complete_path: {output^} pft$p_complete_path;
     VAR status: ost$status);

    VAR
      element_index: fst$number_of_path_elements,
      family: ost$name,
      path_element_size: fst$path_element_size,
      path_index: fst$path_index;

    family := fsp$path_element (^evaluated_file_reference, pfc$family_name_index)^;
    osp$get_set_name (family, p_complete_path^ [pfc$set_path_index], status);

    IF status.normal THEN
      path_index := 1;

      FOR element_index := 1 TO evaluated_file_reference.number_of_path_elements DO
        path_element_size := $INTEGER (evaluated_file_reference.path_structure (path_index));
        p_complete_path^ [element_index + pfc$set_path_index] :=
              evaluated_file_reference.path_structure (path_index + 1, path_element_size);
        path_index := path_index + path_element_size + 1;
      FOREND;
    IFEND;
  PROCEND pfp$convert_fs_to_complete_path;

?? TITLE := '  [XDCL, #GATE] pfp$convert_fs_to_pft$path', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$convert_fs_to_pft$path
    (    evaluated_file_reference: fst$evaluated_file_reference;
     VAR path: pft$path);

    VAR
      element_index: fst$number_of_path_elements,
      path_element_size: fst$path_element_size,
      path_index: fst$path_index;

    path_index := 1;

    FOR element_index := 1 TO evaluated_file_reference.number_of_path_elements DO
      path_element_size := $INTEGER (evaluated_file_reference.path_structure (path_index));
      path [element_index] := evaluated_file_reference.path_structure (path_index + 1, path_element_size);
      path_index := path_index + path_element_size + 1;
    FOREND;
  PROCEND pfp$convert_fs_to_pft$path;

?? TITLE := '  [XDCL, #GATE] pfp$convert_pf_to_fs_structure', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$convert_pf_to_fs_structure
    (    complete_path: pft$complete_path;
     VAR evaluated_file_reference: fst$evaluated_file_reference);

    VAR
      element_index: fst$number_of_path_elements,
      found: boolean,
      path_index: fst$path_index,
      space_index: 1 .. osc$max_name_size + 1;

    evaluated_file_reference := fsv$evaluated_file_reference;
    IF UPPERBOUND (complete_path) - pfc$set_path_index <= fsc$max_path_elements THEN
      evaluated_file_reference.number_of_path_elements := UPPERBOUND (complete_path) - pfc$set_path_index;
    ELSE
      evaluated_file_reference.number_of_path_elements := fsc$max_path_elements;
    IFEND;

    path_index := 1;

    FOR element_index := 1 TO evaluated_file_reference.number_of_path_elements DO
      #SCAN (pfv$space_character, complete_path [element_index + pfc$set_path_index], space_index, found);
      evaluated_file_reference.path_structure (path_index) := $CHAR (space_index - 1);
      evaluated_file_reference.path_structure (path_index + 1, space_index - 1) :=
            complete_path [element_index + pfc$set_path_index] (1, space_index - 1);
      path_index := path_index + space_index;
    FOREND;

    evaluated_file_reference.path_structure_size := path_index - 1;
  PROCEND pfp$convert_pf_to_fs_structure;

?? TITLE := '  [XDCL, #GATE] pfp$convert_pf_cy_path_to_strng', EJECT ??
{ PURPOSE:
{   This procedure converts a path and cycle number to a string.  The string is
{   a path name suitable for printing and follows the standard form, i.e. it
{   begins with :family_name, contains no blanks, and separates each name with
{   a period.

  PROCEDURE [XDCL, #GATE] pfp$convert_pf_cy_path_to_strng
    (    path: pft$path;
         cycle_number: pft$cycle_number;
     VAR path_name: ost$string);

    VAR
      cycle_string: string (6),
      cycle_string_length: integer,
      found: boolean,
      last_name_length: ost$name_size,
      path_index: pft$array_index,
      path_name_length: integer,
      space_index: 1 .. osc$max_name_size + 1;

    path_name_length := 0;

    #SCAN (pfv$space_character, path [UPPERBOUND (path)], space_index, found);
    IF space_index = 1 THEN
      last_name_length := 2;
    ELSE
      last_name_length := space_index - 1;
    IFEND;

    STRINGREP (cycle_string, cycle_string_length, cycle_number);
    cycle_string (1) := '.';

    FOR path_index := pfc$family_name_index TO UPPERBOUND (path) DO
      IF (path [path_index] = osc$null_name) OR (path [path_index] = '') THEN
        path_name.value (path_name_length + 1, 2) := '.?';
        path_name_length := path_name_length + 2;
      ELSEIF path_index = UPPERBOUND (path) THEN
        STRINGREP (path_name.value, path_name_length, path_name.value (1, path_name_length), '.',
              path [UPPERBOUND (path)] (1, last_name_length), cycle_string (1, cycle_string_length));
      ELSE
        #SCAN (pfv$space_character, path [path_index], space_index, found);
        IF path_name_length + space_index + (2 * ((UPPERBOUND (path) - 1) - path_index)) +
              (last_name_length + 1) + cycle_string_length <= osc$max_string_size THEN
          STRINGREP (path_name.value, path_name_length, path_name.value (1, path_name_length), '.',
                path [path_index] (1, space_index - 1));
        ELSE
          {
          { The path name would be too long, so a '?' is substituted for this
          { name in the path.
          {
          path_name.value (path_name_length + 1, 2) := '.?';
          path_name_length := path_name_length + 2;
        IFEND;
      IFEND;
    FOREND;

    path_name.value (1) := ':';
    path_name.size := path_name_length;
  PROCEND pfp$convert_pf_cy_path_to_strng;

?? TITLE := '  [XDCL, #GATE] pfp$convert_pf_path_to_fs_path', EJECT ??
{ PURPOSE:
{   This procedure converts a complete path to an fs path.  The fs path is
{   suitable for printing and follows the standard form, i.e. it begins with
{   :family_name, contains no blanks, and separates each name with a period.
{
{ NOTE:
{   A set name is expected to be the first name in the complete path, but is
{   not included in the fs path.

  PROCEDURE [XDCL, #GATE] pfp$convert_pf_path_to_fs_path
    (    pf_path: pft$complete_path;
     VAR fs_path: fst$path;
     VAR fs_path_size: fst$path_size);

    VAR
      found: boolean,
      fs_path_length: integer,
      last_name_length: ost$name_size,
      pf_path_index: pft$array_index,
      space_index: 1 .. osc$max_name_size + 1;

    fs_path_length := 0;

    #SCAN (pfv$space_character, pf_path [UPPERBOUND (pf_path)], space_index, found);
    IF space_index = 1 THEN
      last_name_length := 2;
    ELSE
      last_name_length := space_index - 1;
    IFEND;

    FOR pf_path_index := pfc$family_path_index TO UPPERBOUND (pf_path) DO
      IF (pf_path [pf_path_index] = osc$null_name) OR (pf_path [pf_path_index] = '') THEN
        fs_path (fs_path_length + 1, 2) := '.?';
        fs_path_length := fs_path_length + 2;
      ELSEIF pf_path_index = UPPERBOUND (pf_path) THEN
        STRINGREP (fs_path, fs_path_length, fs_path (1, fs_path_length), '.',
              pf_path [UPPERBOUND (pf_path)] (1, last_name_length));
      ELSE
        #SCAN (pfv$space_character, pf_path [pf_path_index], space_index, found);
        IF fs_path_length + space_index + (2 * ((UPPERBOUND (pf_path) - 1) - pf_path_index)) +
              (last_name_length + 1) <= fsc$max_path_size THEN
          STRINGREP (fs_path, fs_path_length, fs_path (1, fs_path_length), '.',
                pf_path [pf_path_index] (1, space_index - 1));
        ELSE
          {
          { The fs path would be too long, so a '?' is substituted for this
          { name in the path.
          {
          fs_path (fs_path_length + 1, 2) := '.?';
          fs_path_length := fs_path_length + 2;
        IFEND;
      IFEND;
    FOREND;

    fs_path (1) := ':';
    fs_path_size := fs_path_length;
  PROCEND pfp$convert_pf_path_to_fs_path;

?? TITLE := '  [XDCL, #GATE] pfp$convert_pft$path_to_fs_path', EJECT ??
{ PURPOSE:
{   This procedure converts a pf path to an fs path.  The fs path is suitable
{   for printing and follows the standard form, i.e. it begins with
{   :family_name, contains no blanks, and separates each name with a period.

  PROCEDURE [XDCL, #GATE] pfp$convert_pft$path_to_fs_path
    (    pf_path: pft$path;
     VAR fs_path: fst$path;
     VAR fs_path_size: fst$path_size);

    VAR
      found: boolean,
      fs_path_length: integer,
      last_name_length: ost$name_size,
      pf_path_index: pft$array_index,
      space_index: 1 .. osc$max_name_size + 1;

    fs_path_length := 0;

    #SCAN (pfv$space_character, pf_path [UPPERBOUND (pf_path)], space_index, found);
    IF space_index = 1 THEN
      last_name_length := 2;
    ELSE
      last_name_length := space_index - 1;
    IFEND;

    FOR pf_path_index := pfc$family_name_index TO UPPERBOUND (pf_path) DO
      IF (pf_path [pf_path_index] = osc$null_name) OR (pf_path [pf_path_index] = '') THEN
        fs_path (fs_path_length + 1, 2) := '.?';
        fs_path_length := fs_path_length + 2;
      ELSEIF pf_path_index = UPPERBOUND (pf_path) THEN
        STRINGREP (fs_path, fs_path_length, fs_path (1, fs_path_length), '.',
              pf_path [UPPERBOUND (pf_path)] (1, last_name_length));
      ELSE
        #SCAN (pfv$space_character, pf_path [pf_path_index], space_index, found);
        IF fs_path_length + space_index + (2 * ((UPPERBOUND (pf_path) - 1) - pf_path_index)) +
              (last_name_length + 1) <= fsc$max_path_size THEN
          STRINGREP (fs_path, fs_path_length, fs_path (1, fs_path_length), '.',
                pf_path [pf_path_index] (1, space_index - 1));
        ELSE
          {
          { The fs path would be too long, so a '?' is substituted for this
          { name in the path.
          {
          fs_path (fs_path_length + 1, 2) := '.?';
          fs_path_length := fs_path_length + 2;
        IFEND;
      IFEND;
    FOREND;

    fs_path (1) := ':';
    fs_path_size := fs_path_length;
  PROCEND pfp$convert_pft$path_to_fs_path;

?? TITLE := '  [XDCL, #GATE] pfp$convert_pft$path_to_fs_str', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$convert_pft$path_to_fs_str
    (    path: pft$path;
     VAR evaluated_file_reference: fst$evaluated_file_reference);

    VAR
      element_index: fst$number_of_path_elements,
      found: boolean,
      path_index: fst$path_index,
      space_index: 1 .. osc$max_name_size + 1;

    evaluated_file_reference := fsv$evaluated_file_reference;
    IF UPPERBOUND (path) <= fsc$max_path_elements THEN
      evaluated_file_reference.number_of_path_elements := UPPERBOUND (path);
    ELSE
      evaluated_file_reference.number_of_path_elements := fsc$max_path_elements;
    IFEND;

    path_index := 1;

    FOR element_index := 1 TO evaluated_file_reference.number_of_path_elements DO
      #SCAN (pfv$space_character, path [element_index], space_index, found);
      evaluated_file_reference.path_structure (path_index) := $CHAR (space_index - 1);
      evaluated_file_reference.path_structure (path_index + 1, space_index - 1) :=
            path [element_index] (1, space_index - 1);
      path_index := path_index + space_index;
    FOREND;

    evaluated_file_reference.path_structure_size := path_index - 1;
  PROCEND pfp$convert_pft$path_to_fs_str;

?? TITLE := '  [XDCL, #GATE] pfp$convert_pft$path_to_string', EJECT ??
{ PURPOSE:
{   This procedure converts a path to a string.  The string is a path name
{   suitable for printing and follows the standard form, i.e. it begins with
{   :family_name, contains no blanks, and separates each name with a period.

  PROCEDURE [XDCL, #GATE] pfp$convert_pft$path_to_string
    (    path: pft$path;
     VAR path_name: ost$string);

    VAR
      found: boolean,
      last_name_length: ost$name_size,
      path_index: pft$array_index,
      path_name_length: integer,
      space_index: 1 .. osc$max_name_size + 1;

    path_name_length := 0;

    #SCAN (pfv$space_character, path [UPPERBOUND (path)], space_index, found);
    IF space_index = 1 THEN
      last_name_length := 2;
    ELSE
      last_name_length := space_index - 1;
    IFEND;

    FOR path_index := pfc$family_name_index TO UPPERBOUND (path) DO
      IF (path [path_index] = osc$null_name) OR (path [path_index] = '') THEN
        path_name.value (path_name_length + 1, 2) := '.?';
        path_name_length := path_name_length + 2;
      ELSEIF path_index = UPPERBOUND (path) THEN
        STRINGREP (path_name.value, path_name_length, path_name.value (1, path_name_length), '.',
              path [UPPERBOUND (path)] (1, last_name_length));
      ELSE
        #SCAN (pfv$space_character, path [path_index], space_index, found);
        IF path_name_length + space_index + (2 * ((UPPERBOUND (path) - 1) - path_index)) +
              (last_name_length + 1) <= osc$max_string_size THEN
          STRINGREP (path_name.value, path_name_length, path_name.value (1, path_name_length), '.',
                path [path_index] (1, space_index - 1));
        ELSE
          {
          { The path name would be too long, so a '?' is substituted for this
          { name in the path.
          {
          path_name.value (path_name_length + 1, 2) := '.?';
          path_name_length := path_name_length + 2;
        IFEND;
      IFEND;
    FOREND;

    path_name.value (1) := ':';
    path_name.size := path_name_length;
  PROCEND pfp$convert_pft$path_to_string;

?? TITLE := '  [XDCL, #GATE] pfp$display_memory_to_log', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$display_memory_to_log
    (    address: ^cell;
         bytes: ost$segment_length);

    CONST
      bytes_in_item = 8,
      fixed = size_of_address_parameter + spaces_before_memory_contents,
      page_width = 74,
      size_of_address_parameter = 8,
      spaces_before_memory_contents = 3,
      space_for_numeric_byte = 2,
      space_for_numeric_item = bytes_in_item * space_for_numeric_byte + 6,
      space_for_ascii_item = bytes_in_item;


    PROCEDURE [INLINE] convert_byte_to_hex_string
      (    byte: 0 .. 0ff(16);
       VAR str: string (2));

      VAR
        ptr: ^packed record
          left: 0 .. 0f(16),
          right: 0 .. 0f(16)
        recend;

      ptr := #LOC (byte);
      str (1) := hex_chars [ptr^.left];
      str (2) := hex_chars [ptr^.right];

    PROCEND convert_byte_to_hex_string;

    VAR
      ascii_tab_column: 1 .. 256,
      byte: ^0 .. 0ff(16),
      byte_count: 1 .. 2,
      bytes_displayed: integer,
      bytes_this_line: 0 .. 132,
      char_index: 0 .. 255,
      current_item: 1 .. 63,
      display_address: ost$segment_length,
      first_item: ^cell,
      first_line: boolean,
      half_words: 1 .. 2,
      half_half_words: 1 .. 2,
      hex_chars: [oss$job_paged_literal, READ] array [0 .. 0f(16)] of char := ['0', '1', '2', '3', '4', '5',
            '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'],
      item_ascii: ^string ( * ),
      items_per_line: 0 .. 100,
      line_buffer: ^string ( * ),
      line_index: 1 .. 256,
      log_string_length : integer,
      local_status: ost$status,
      p_memory: ^SEQ ( * ),
      log_string: string (osc$max_string_size);

    IF bytes = 0 THEN
      RETURN;
    IFEND;

    items_per_line := (page_width - fixed) DIV (space_for_ascii_item + space_for_numeric_item);
    ascii_tab_column := fixed + (items_per_line * space_for_numeric_item) + 1;

    PUSH line_buffer: [page_width];

    STRINGREP (log_string, log_string_length, ' *  segment = ', #segment(address): #(16), '(16)',
          ' length = ', bytes: #(16), '(16)');
    pfp$log_ascii (log_string (1, log_string_length), $pmt$ascii_logset [pmc$system_log, pmc$job_log],
          pmc$msg_origin_system, {critical_message} FALSE, local_status);

      i#build_adaptable_seq_pointer (#ring(address), #segment(address), #offset(address),
            bytes, 0, p_memory);

      display_address := #offset(address);
      bytes_displayed := 0;
      bytes_this_line := items_per_line * space_for_ascii_item;
      first_line := TRUE;

   REPEAT
    /display_items/
      WHILE TRUE DO
        line_buffer^ := ' *  ';
        line_index := 5;
        clp$convert_integer_to_rjstring (display_address, 16, FALSE, '0',
              line_buffer^ (line_index, size_of_address_parameter), local_status);
        IF NOT local_status.normal THEN
          EXIT /display_items/;
        IFEND;
        line_index := line_index + size_of_address_parameter + spaces_before_memory_contents;
        NEXT byte IN p_memory;
        first_item := byte;
        RESET p_memory TO first_item;
        bytes_this_line := 0;

      /format_numeric/
        FOR current_item := 1 TO items_per_line DO
          FOR half_words := 1 TO 2 DO
            FOR half_half_words := 1 TO 2 DO
              FOR byte_count := 1 TO 2 DO
                NEXT byte IN p_memory;
                convert_byte_to_hex_string (byte^, line_buffer^ (line_index, 2));
                line_index := line_index + 2;
                bytes_this_line := bytes_this_line + 1;
                bytes_displayed := bytes_displayed + 1;
                IF bytes_displayed >= bytes THEN
                  IF first_line THEN
                    line_index := line_index + 3;
                  ELSE
                    line_index := ascii_tab_column;
                  IFEND;
                  EXIT /format_numeric/;
                IFEND;
              FOREND;
              line_index := line_index + 1;
            FOREND;
          FOREND;
          line_index := line_index + 2;
        FOREND /format_numeric/;
        RESET p_memory TO first_item;
        NEXT item_ascii: [bytes_this_line] IN p_memory;
        #TRANSLATE (control_codes_translation, item_ascii^, line_buffer^ (line_index, bytes_this_line));
        pfp$log_ascii (line_buffer^ (1, * ), $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, {critical_message} FALSE, local_status);
        display_address := display_address + bytes_this_line;
        IF bytes_displayed >= bytes THEN
          EXIT /display_items/;
        IFEND;
        first_line := FALSE;
      WHILEND /display_items/;
     {display_count := display_count - bytes_returned;
     {offset := offset + bytes_returned;
    UNTIL bytes_displayed >= bytes;
  PROCEND pfp$display_memory_to_log;

?? TITLE := '  [XDCL, #GATE] pfp$log_ascii', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$log_ascii
    (    text: string ( * );
         ascii_logset: pmt$ascii_logset;
         message_origin: pmt$log_msg_origin;
         critical_message: boolean;
     VAR status: ost$status);

    CONST
      critical_window_width = 71,
      log_width = 116;

    VAR
      print_line_index: ost$positive_integers,
      print_line_length: amt$page_width,
      remaining_text_index: ost$positive_integers,
      remaining_text_length: ost$non_negative_integers,
      trimmed_text_index: ost$positive_integers,
      trimmed_text_length: ost$non_negative_integers;

    trimmed_text_length := STRLENGTH (text);

    IF trimmed_text_length <> 0 THEN
      trimmed_text_index := 1;
      trim_beginning_blanks (^text, trimmed_text_index, trimmed_text_length);
    IFEND;

    IF trimmed_text_length = 0 THEN
      pmp$log_ascii (' ', ascii_logset, message_origin, status);
      IF critical_message THEN
        dpp$put_critical_message (' ', status);
      IFEND;
    ELSE
      remaining_text_index := trimmed_text_index;
      remaining_text_length := trimmed_text_length;

      REPEAT
        format_text (^text, log_width, remaining_text_index, remaining_text_length, print_line_index,
              print_line_length);
        pmp$log_ascii (text (print_line_index, print_line_length), ascii_logset, message_origin, status);
      UNTIL remaining_text_length = 0;

      IF critical_message THEN
        remaining_text_index := trimmed_text_index;
        remaining_text_length := trimmed_text_length;

        REPEAT
          format_text (^text, critical_window_width, remaining_text_index, remaining_text_length,
                print_line_index, print_line_length);
          dpp$put_critical_message (text (print_line_index, print_line_length), status);
        UNTIL remaining_text_length = 0;
      IFEND;
    IFEND;
  PROCEND pfp$log_ascii;

?? TITLE := '  [XDCL, #GATE] pfp$log_status', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$log_status
    (    ascii_logset: pmt$ascii_logset;
         log_status: ost$status);

    VAR
      ignore_status: ost$status;

    osp$generate_log_message (ascii_logset, log_status, ignore_status);

  PROCEND pfp$log_status;

?? TITLE := '  [XDCL, #GATE] pfp$log_error', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$log_error
    (    status: ost$status;
         ascii_logset: pmt$ascii_logset;
         message_origin: pmt$log_msg_origin;
         critical_message: boolean);

    VAR
      local_status: ost$status,
      message: ost$status_message,
      message_line_index: 1 .. osc$max_status_message_lines,
      p_message: ^ost$status_message,
      p_message_line: ^ost$status_message_line,
      p_message_line_count: ^ost$status_message_line_count,
      p_message_line_size: ^ost$status_message_line_size;

    osp$format_message (status, osc$full_message_level, osc$max_status_message_line, message, local_status);
    IF local_status.normal THEN
      p_message := ^message;
      RESET p_message;
      NEXT p_message_line_count IN p_message;

      FOR message_line_index := 1 TO p_message_line_count^ DO
        NEXT p_message_line_size IN p_message;
        NEXT p_message_line: [p_message_line_size^] IN p_message;
        pfp$log_ascii (p_message_line^, ascii_logset, message_origin, critical_message, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;
  PROCEND pfp$log_error;

?? TITLE := '  [XDCL, #GATE] pfp$log_path', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$log_path
    (    variant_path: pft$variant_path;
         ascii_logset: pmt$ascii_logset;
         message_origin: pmt$log_msg_origin;
         critical_message: boolean;
     VAR status: ost$status);

    VAR
      fs_path_size: fst$path_size,
      p_fs_path: ^fst$path;

    PUSH p_fs_path;

    IF variant_path.complete_path THEN
      pfp$convert_pf_path_to_fs_path (variant_path.p_complete_path^, p_fs_path^, fs_path_size);
    ELSE
      pfp$convert_pft$path_to_fs_path (variant_path.p_path^, p_fs_path^, fs_path_size);
    IFEND;

    pfp$log_ascii (p_fs_path^ (1, fs_path_size), ascii_logset, message_origin, critical_message, status);

  PROCEND pfp$log_path;

?? TITLE := '  [XDCL, #GATE] pfp$report_system_error', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to report a system error and to map the
{   status to pfe$pf_system_error.

  PROCEDURE [XDCL, #GATE] pfp$report_system_error
    (VAR status: ost$status);

    VAR
      condition_code: ost$status_condition_number,
      condition_identifier: ost$status_identifier,
      local_status: ost$status;

    osp$recoverable_system_error ('UNEXPECTED STATUS', ^status);
    local_status := status;
    osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error, 'Unexpected status.',
          status);
    osp$unpack_status_condition (local_status.condition, condition_identifier, condition_code);
    osp$append_status_parameter (osc$status_parameter_delimiter, condition_identifier, status);
    osp$append_status_integer (osc$status_parameter_delimiter, condition_code, {radix} 10,
          {include_radix} FALSE, status);
    osp$append_status_parameter (osc$status_parameter_delimiter,
          local_status.text.value (1, local_status.text.size), status);
  PROCEND pfp$report_system_error;

?? TITLE := '  [XDCL, #GATE] pfp$report_unexpected_status', EJECT ??
{ NOTE:
{   An INLINE procedure has been added which replaces this procedure, but this
{   procedure must remain until all products which use it, or which use
{   pfp$process_unexpected_status, have been recompiled, post build_19226, to
{   allow the loader to satisfy the references.  This procedure and the *copyc
{   for dfe$error_condition_codes, for dmt$error_condition_codes, and for
{   mme$condition_codes should be deleted once all of the recompilations have
{   occurred.

  PROCEDURE [XDCL, #GATE] pfp$report_unexpected_status
    (VAR status: ost$status);

    VAR
      condition_code: ost$status_condition_number,
      condition_identifier: ost$status_identifier,
      local_status: ost$status;

    IF (status.condition <> dme$unable_to_alloc_all_space) AND
          (status.condition <> dfe$server_not_active) AND (status.condition <> dfe$server_has_terminated) AND
          (status.condition <> dfe$server_request_terminated) AND
          (status.condition <> dme$volume_unavailable) AND (status.condition <> mme$segment_table_is_full) AND
          (status.condition <> mme$volume_unavailable) THEN
      osp$recoverable_system_error ('UNEXPECTED STATUS', ^status);
      local_status := status;
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error, 'Unexpected status.',
            status);
      osp$unpack_status_condition (local_status.condition, condition_identifier, condition_code);
      osp$append_status_parameter (osc$status_parameter_delimiter, condition_identifier, status);
      osp$append_status_integer (osc$status_parameter_delimiter, condition_code, 10, FALSE, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            local_status.text.value (1, local_status.text.size), status);
    IFEND;
  PROCEND pfp$report_unexpected_status;

?? TITLE := '  pfp$set_status_abnormal', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to construct a string representation of
{   a path and call osp$set_status_abnormal with the specified condition and
{   the path as the text field.

  PROCEDURE [XDCL, #GATE] pfp$set_status_abnormal
    (    variant_path: pft$variant_path;
         condition: ost$status_condition_code;
     VAR status: ost$status);

    VAR
      fs_path_size: fst$path_size,
      p_fs_path: ^fst$path;

    PUSH p_fs_path;

    IF variant_path.complete_path THEN
      pfp$convert_pf_path_to_fs_path (variant_path.p_complete_path^, p_fs_path^, fs_path_size);
    ELSE
      pfp$convert_pft$path_to_fs_path (variant_path.p_path^, p_fs_path^, fs_path_size);
    IFEND;

    osp$set_status_abnormal (pfc$permanent_file_manager_id, condition, p_fs_path^ (1, fs_path_size), status);
  PROCEND pfp$set_status_abnormal;

?? TITLE := '  [INLINE] format_text', EJECT ??

  PROCEDURE [INLINE] format_text
    (    p_text: ^string ( * );
         page_width: amt$page_width;
     VAR remaining_text_index: {i/o} ost$positive_integers;
     VAR remaining_text_length: {i/o} ost$non_negative_integers;
     VAR print_line_index: ost$positive_integers;
     VAR print_line_length: amt$page_width);

    VAR
      line_length: 0 .. amc$max_page_width;

    print_line_index := remaining_text_index;

    IF remaining_text_length <= page_width THEN
      print_line_length := remaining_text_length;
      remaining_text_length := 0;
    ELSE
      line_length := page_width;
      WHILE (line_length > 0) AND (p_text^ (remaining_text_index + line_length) <> ' ') DO
        line_length := line_length - 1;
      WHILEND;

      IF line_length = 0 THEN
        print_line_length := page_width;
        remaining_text_index := remaining_text_index + page_width;
        remaining_text_length := remaining_text_length - page_width;
      ELSE
        print_line_length := line_length;
        remaining_text_index := remaining_text_index + line_length;
        remaining_text_length := remaining_text_length - line_length;
        trim_beginning_blanks (p_text, remaining_text_index, remaining_text_length);
      IFEND;
    IFEND;
  PROCEND format_text;

?? TITLE := '  [INLINE] trim_beginning_blanks', EJECT ??

  PROCEDURE [INLINE] trim_beginning_blanks
    (    p_text: ^string ( * );
     VAR text_index: {i/o} ost$positive_integers;
     VAR text_length: {i/o} ost$non_negative_integers);

    VAR
      index: ost$positive_integers;

    index := text_index;

    WHILE (index < text_index + text_length) AND (p_text^ (index) = ' ') DO
      index := index + 1;
    WHILEND;

    text_length := text_length - index + text_index;
    text_index := index;
  PROCEND trim_beginning_blanks;

?? OLDTITLE, SKIP := 2 ??
MODEND pfm$report_unexpected_status;
*DECK DECK=PFM$TASK_PRIVATE_DATA EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Permanent Files : Task Private Data Management' ??
MODULE pfm$task_private_data;

{ PURPOSE:
{   This module contains those permanent file manager routines that manage data
{   that is specific to a task.  All STATIC data contained in this module is
{   task specific.
{
{ DESIGN:
{   This module resides in the 23d library.
{
{   Task private data is used to:
{   1. improve performance;
{      Data that might be expensive to acquire and cannot change within the
{      execution of a task may be maintained.
{   2. provide a means for a task to run as if it were running on behalf of
{      another job.
{      The file server uses pfp$set_task_environment to set values within the
{      task.
{
{   There is no need to lock the data maintained in this module as it is task
{   specific; no other process may be accessing it.

?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc ave$family_errors
*copyc avv$production_environ_begun
*copyc dft$client_job_list
*copyc jmv$executing_within_system_job
*copyc oss$task_private
*copyc pfd$authority
*copyc pfd$catalog_locator
*copyc pfd$complete_path
*copyc pft$locked_catalog_list
*copyc pft$permit_level
*copyc pft$system_authority
*copyc pft$variant_path
*copyc ste$error_condition_codes
?? POP ??
?? EJECT ??
*copyc avp$family_administrator
*copyc avp$get_name_value
*copyc avp$system_administrator
*copyc osv$task_shared_heap
*copyc pfp$report_unexpected_status
*copyc pfv$p_attached_pf_table
*copyc pfv$p_newest_queued_catalog
*copyc pfv$p_queued_catalog_table
*copyc pfv$queued_catalog_table_lock
*copyc pmp$get_account_project
*copyc pmp$get_user_identification
*copyc stp$get_set_owner

?? TITLE := '  Global Declarations Declared by this module', EJECT ??

  VAR
    { osc$null_name inidcates an unknown value.
    pfv$family_administrator: [XDCL, STATIC, oss$task_private] boolean := FALSE,
    pfv$permit_level: [XDCL, oss$task_private, STATIC] pft$permit_level := pfc$pl_unknown,
    pfv$system_administrator: [XDCL, STATIC, oss$task_private] boolean := FALSE,
    pfv$system_authority: [XDCL, STATIC, oss$task_private] pft$system_authority := 0,
    pfv$task_account: [XDCL, STATIC, oss$task_private] avt$account_name := osc$null_name,
    pfv$task_family: [XDCL, STATIC, oss$task_private] ost$family_name := osc$null_name,
    pfv$task_project: [XDCL, STATIC, oss$task_private] avt$project_name := osc$null_name,
    pfv$task_user: [XDCL, STATIC, oss$task_private] ost$user_name := osc$null_name;

  VAR
    pfv$p_queued_catalog_table_lock: [XDCL, STATIC, oss$task_private] ^ost$signature_lock :=
          ^pfv$queued_catalog_table_lock,
    pfv$p_p_queued_catalog_table: [XDCL, STATIC, oss$task_private] ^pft$p_queued_catalog_table :=
          ^pfv$p_queued_catalog_table,
    pfv$p_p_newest_queued_catalog: [XDCL, STATIC, oss$task_private] ^pft$p_queued_catalog :=
          ^pfv$p_newest_queued_catalog,

    pfv$p_p_attached_pf_table: [XDCL, STATIC, oss$task_private] ^pft$p_attached_pf_table :=
          ^pfv$p_attached_pf_table,

    pfv$p_p_job_heap: [XDCL, STATIC, oss$task_private] ^^ost$heap := ^osv$task_shared_heap;

  VAR
    pfv$locked_apfid: [XDCL, STATIC, oss$task_private] 0 .. 0ffff(16) := 0;

  VAR
    pfv$locked_catalog_list: [XDCL, STATIC, oss$task_private] pft$locked_catalog_list :=
          [REP pfc$max_locked_catalogs of NIL];

  VAR
    administrator_status_known: [STATIC, oss$task_private] boolean := FALSE,
    set_name: [STATIC, oss$task_private] stt$set_name := '',
    set_owner: [STATIC, oss$task_private] ost$user_identification,
    set_owner_known: [STATIC, oss$task_private] boolean := FALSE;

?? TITLE := '  [XDCL, #GATE] pfp$get_authority', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$get_authority
    (    path: pft$complete_path;
         system_privilege: boolean;
     VAR authority: pft$authority;
     VAR status: ost$status);

{   The use of the static data assumes that the name of the family administrator
{ set owner, user id, or user's account_project will not change during execution
{ of the calling task.

    VAR
      same_family: boolean,
      same_master_catalog: boolean,
      user_id: ost$user_identification;

    authority.ownership := $pft$ownership [];
    IF (pfv$task_family = osc$null_name) OR (pfv$task_user = osc$null_name) THEN
      pmp$get_user_identification (user_id, status);
      IF status.normal THEN
        pfv$task_family := user_id.family;
        pfv$task_user := user_id.user;
      IFEND;
    ELSE
      status.normal := TRUE;
      user_id.family := pfv$task_family;
      user_id.user := pfv$task_user;
    IFEND;
    IF status.normal THEN
      authority.family := user_id.family;
      authority.user := user_id.user;
      same_family := (pfc$family_path_index <= UPPERBOUND (path)) AND
            (user_id.family = path [pfc$family_path_index]);
      same_master_catalog := (pfc$master_catalog_path_index <= UPPERBOUND (path)) AND
            (user_id.user = path [pfc$master_catalog_path_index]);
      IF same_family AND same_master_catalog THEN
        authority.ownership := authority.ownership + $pft$ownership [pfc$master_catalog_owner];
      IFEND;
      IF (pfv$task_account = osc$null_name) OR (pfv$task_project = osc$null_name) THEN
        pmp$get_account_project (authority.account, authority.project, status);
        IF status.normal THEN
          pfv$task_account := authority.account;
          pfv$task_project := authority.project;
        IFEND;
      ELSE
        authority.account := pfv$task_account;
        authority.project := pfv$task_project;
      IFEND;
    IFEND;

    IF status.normal THEN
      IF (NOT set_owner_known) OR (set_name <> path [pfc$set_path_index]) THEN
        stp$get_set_owner (path [pfc$set_path_index], set_owner, status);
        set_owner_known := status.normal;
        set_name := path [pfc$set_path_index];
      IFEND;
    IFEND;

    IF status.normal THEN
      IF set_owner = user_id THEN
        authority.ownership := authority.ownership + $pft$ownership [pfc$set_owner];
      IFEND;
      IF NOT administrator_status_known THEN
        IF jmv$executing_within_system_job AND NOT avv$production_environ_begun THEN
          { In system job, grant administrator status until production environment has been
          { established.
          pfv$system_administrator := TRUE;
          pfv$family_administrator := TRUE;
        ELSE
          pfv$system_administrator := avp$system_administrator ();
          pfv$family_administrator := avp$family_administrator ();
          administrator_status_known := TRUE;
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      IF pfv$system_administrator THEN
        authority.ownership := authority.ownership + $pft$ownership [pfc$system_owner];
      ELSE
        IF pfv$family_administrator AND same_family THEN
          authority.ownership := authority.ownership + $pft$ownership [pfc$family_owner];
        IFEND;
        IF system_privilege THEN
          authority.ownership := authority.ownership + $pft$ownership [pfc$system_owner];
        IFEND;
      IFEND;
    ELSEIF (status.condition <> ste$set_not_active) AND (status.condition <> ste$not_allowing_access) THEN
      pfp$report_unexpected_status (status);
    IFEND;
  PROCEND pfp$get_authority;

?? TITLE := '  [XDCL, #GATE] pfp$get_ownership', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to determine the ownership of the task.
{
{ DESIGN:
{   An attempt will be made to determine set ownership only if a complete path
{   is provided.  If the family is served and this procedure is called from the
{   client mainframe, the ownership will not include set ownership.
{
{ Note:
{   The use of the static data assumes that the names of the system and family
{   administrators, the name of the set owner, and the user's identification
{   will not change during execution of the calling task.

  PROCEDURE [XDCL ,#GATE] pfp$get_ownership
    (    variant_path: pft$variant_path;
         system_privilege: boolean;
     VAR ownership: pft$ownership;
     VAR status: ost$status);

    VAR
      same_family: boolean,
      same_master_catalog: boolean,
      user_id: ost$user_identification;

    IF NOT administrator_status_known THEN
      IF jmv$executing_within_system_job AND NOT avv$production_environ_begun THEN
        {
        { Grant administrator status until production environment has been
        { established.
        {
        pfv$system_administrator := TRUE;
        pfv$family_administrator := TRUE;
      ELSE
        pfv$system_administrator := avp$system_administrator ();
        pfv$family_administrator := avp$family_administrator ();
        administrator_status_known := TRUE;
      IFEND;
    IFEND;

    IF pfv$system_administrator OR system_privilege THEN
      ownership := $pft$ownership [pfc$system_owner];
    ELSE
      ownership := $pft$ownership [];
    IFEND;

    IF (pfv$task_family = osc$null_name) OR (pfv$task_user = osc$null_name) THEN
      pmp$get_user_identification (user_id, status);
      IF status.normal THEN
        pfv$task_family := user_id.family;
        pfv$task_user := user_id.user;
      IFEND;
    IFEND;

    IF variant_path.complete_path THEN
      IF (NOT set_owner_known) AND (set_name <> variant_path.p_complete_path^ [pfc$set_path_index]) THEN
        stp$get_set_owner (variant_path.p_complete_path^ [pfc$set_path_index], set_owner, status);
        set_owner_known := status.normal;
        set_name := variant_path.p_complete_path^ [pfc$set_path_index];
      IFEND;

      IF set_owner = user_id THEN
        ownership := ownership + $pft$ownership [pfc$set_owner];
      IFEND;

      same_family := (pfc$family_path_index <= UPPERBOUND (variant_path.p_complete_path^)) AND
            (pfv$task_family = variant_path.p_complete_path^ [pfc$family_path_index]);
      same_master_catalog := (pfc$master_catalog_path_index <= UPPERBOUND (variant_path.p_complete_path^))
            AND (pfv$task_user = variant_path.p_complete_path^ [pfc$master_catalog_path_index]);
    ELSE
      same_family := (pfc$family_path_index <= UPPERBOUND (variant_path.p_path^)) AND
            (pfv$task_family = variant_path.p_path^ [pfc$family_name_index]);
      same_master_catalog := (pfc$master_catalog_path_index <= UPPERBOUND (variant_path.p_path^)) AND
            (pfv$task_user = variant_path.p_path^ [pfc$master_catalog_name_index]);
    IFEND;

    IF pfv$family_administrator AND same_family THEN
      ownership := ownership + $pft$ownership [pfc$family_owner];
    IFEND;

    IF same_family AND same_master_catalog THEN
      ownership := ownership + $pft$ownership [pfc$master_catalog_owner];
    IFEND;
  PROCEND pfp$get_ownership;

?? TITLE := '  [XDCL] pfp$get_permit_level', EJECT ??

  PROCEDURE [XDCL] pfp$get_permit_level
    (VAR permit_level: pft$permit_level;
     VAR status: ost$status);

    VAR
      number_of_names: avt$name_list_size,
      p_permit_level: ^avt$name_list;

    PUSH p_permit_level: [1 .. 1];
    avp$get_name_value (avc$permit_level, avc$user, p_permit_level^, number_of_names, status);
    IF status.normal THEN
      IF p_permit_level^ [1] = 'PUBLIC' THEN
        permit_level := pfc$pl_public;
        pfv$permit_level := pfc$pl_public;
        RETURN;
      ELSEIF p_permit_level^ [1] = 'FAMILY' THEN
        permit_level := pfc$pl_family;
        pfv$permit_level := pfc$pl_family;
      ELSEIF p_permit_level^ [1] = 'ACCOUNT' THEN
        permit_level := pfc$pl_account;
        pfv$permit_level := pfc$pl_account;
      ELSEIF p_permit_level^ [1] = 'PROJECT' THEN
        permit_level := pfc$pl_project;
        pfv$permit_level := pfc$pl_project;
      ELSEIF p_permit_level^ [1] = 'USER' THEN
        permit_level := pfc$pl_user;
        pfv$permit_level := pfc$pl_user;
      ELSEIF p_permit_level^ [1] = 'OWNER' THEN
        permit_level := pfc$pl_owner;
        pfv$permit_level := pfc$pl_owner;
      ELSE
        {
        { Treat as 'PUBLIC'.
        {
        permit_level := pfc$pl_public;
        pfv$permit_level := pfc$pl_public;
      IFEND;
    ELSE
      IF (status.condition = ave$unknown_field) OR
            (status.condition = ave$field_was_deleted) THEN
        {
        { Treat as 'PUBLIC'.
        {
        permit_level := pfc$pl_public;
        pfv$permit_level := pfc$pl_public;
        status.normal := TRUE;
      ELSEIF status.condition = ave$user_info_not_found THEN
        {
        { Temporarily treat as 'PUBLIC'.
        {
        permit_level := pfc$pl_public;
        status.normal := TRUE;
      ELSE
        pfp$report_unexpected_status (status);
      IFEND;
    IFEND;
  PROCEND pfp$get_permit_level;

?? TITLE := '  [XDCL] pfp$reset_administrator_status', EJECT ??

  PROCEDURE [XDCL] pfp$reset_administrator_status;

    pfv$system_administrator := avp$system_administrator ();
    pfv$family_administrator := avp$family_administrator ();
    administrator_status_known := TRUE;

  PROCEND pfp$reset_administrator_status;

?? TITLE := '  [XDCL] pfp$reset_task_environment', EJECT ??
{
{   This request resets a task's permanent file environment to its 'native'
{ environment.  The task will now run on behalf of the job of which it is a task
{ of, and the user that owns the job.  Any previously established environment
{ will be lost, and must have been cleaned up by the caller.
{

  PROCEDURE [XDCL] pfp$reset_task_environment;

    pfv$task_family := osc$null_name;
    pfv$task_user := osc$null_name;
    pfv$task_account := osc$null_name;
    pfv$task_project := osc$null_name;
    administrator_status_known := FALSE;
    set_owner_known := FALSE;
    set_name := osc$null_name;

    pfv$p_queued_catalog_table_lock := ^pfv$queued_catalog_table_lock;
    pfv$p_p_queued_catalog_table := ^pfv$p_queued_catalog_table;
    pfv$p_p_newest_queued_catalog := ^pfv$p_newest_queued_catalog;

    pfv$p_p_attached_pf_table := ^pfv$p_attached_pf_table;

    pfv$p_p_job_heap := ^osv$task_shared_heap;

  PROCEND pfp$reset_task_environment;

?? TITLE := '  [XDCL] pfp$set_family_administrator', EJECT ??

  PROCEDURE [XDCL] pfp$set_family_administrator
    (     family_administrator: boolean);

    IF family_administrator THEN
      pfv$family_administrator := TRUE;
        IF NOT administrator_status_known THEN
          pfv$system_administrator := avp$system_administrator ();
          administrator_status_known := TRUE;
        IFEND;
    ELSE
      administrator_status_known := FALSE;
    IFEND;

  PROCEND pfp$set_family_administrator;

?? TITLE := '  [XDCL] pfp$set_task_environment', EJECT ??
*copy pfh$set_task_environment

  PROCEDURE [XDCL] pfp$set_task_environment
    (    p_client_job_space: ^dft$client_job_space;
         system_administrator: boolean;
         family_administrator: boolean);

    pfv$task_family := p_client_job_space^.family;
    pfv$task_user := p_client_job_space^.user;
    pfv$task_account := p_client_job_space^.account;
    pfv$task_project := p_client_job_space^.project;
    administrator_status_known := TRUE;
    pfv$system_administrator := system_administrator;
    pfv$family_administrator := family_administrator;

    pfv$p_queued_catalog_table_lock := ^p_client_job_space^.queued_catalog_table_lock;
    pfv$p_p_queued_catalog_table := ^p_client_job_space^.p_queued_catalog_table;
    pfv$p_p_newest_queued_catalog := ^p_client_job_space^.p_newest_queued_catalog;

    pfv$p_p_attached_pf_table := ^p_client_job_space^.p_attached_pf_table;

    pfv$p_p_job_heap := ^p_client_job_space^.p_job_heap;
  PROCEND pfp$set_task_environment;

?? OLDTITLE, SKIP := 2 ??
MODEND pfm$task_private_data;
*DECK DECK=PFM$TASK_TERMINATION EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
MODULE pfm$task_termination;
?? PUSH (LISTEXT := ON) ??
?? POP ??

*copyc fmp$unlock_path_table
*copyc mmp$close_segment
*copyc mmp$unlock_segment
*copyc mmp$verify_access
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$test_signature_lock
*copyc pfp$release_locked_apfid
*copyc pfp$return_catalog
*copyc pmp$continue_to_cause

*copyc pfv$locked_apfid
*copyc pfv$locked_catalog_list

?? TITLE := 'Global Declarations Declared by this Module', EJECT ??


{   Purpose:
?? OLDTITLE ??
?? NEWTITLE := 'PROCEDURE [XDCL] pfp$task_termination_cleanup', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$task_termination_cleanup;

    VAR
      i: integer,
      ignore_status: ost$status,
      lock_status: ost$signature_lock_status,
      pva: ^cell,
      segment_pointer: mmt$segment_pointer,
      p_catalog_locator: ^pft$catalog_locator;

?? NEWTITLE := 'task_cleanup_handler', EJECT ??

    PROCEDURE task_cleanup_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      status.normal := TRUE;

      CASE condition.selector OF
      = pmc$block_exit_processing, pmc$system_conditions, mmc$segment_access_condition =
        EXIT pfp$task_termination_cleanup;

      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, status);
      CASEND;

    PROCEND task_cleanup_handler;

?? OLDTITLE, EJECT ??

    osp$establish_condition_handler (^task_cleanup_handler, TRUE);

    FOR i := 1 TO UPPERBOUND (pfv$locked_catalog_list) DO
      IF pfv$locked_catalog_list [i] <> NIL THEN
        pva := #ADDRESS (2, #SEGMENT (pfv$locked_catalog_list [i]), #OFFSET (pfv$locked_catalog_list [i]));
        IF mmp$verify_access (^pva, mmc$va_read_write) THEN
          mmp$unlock_segment (pva, mmc$lus_free, osc$nowait, ignore_status);
          segment_pointer.kind := mmc$cell_pointer;
          segment_pointer.cell_pointer := pva;
          mmp$close_segment (segment_pointer, pfc$catalog_ring, ignore_status);
          pfv$locked_catalog_list [i] := NIL;
        IFEND;
      IFEND;
    FOREND;

    osp$test_signature_lock (fmv$path_table_lock, lock_status, ignore_status);
    IF lock_status = osc$sls_locked_by_current_task THEN
      fmp$unlock_path_table;
    IFEND;

    IF pfv$locked_apfid <> 0 THEN
      pfp$release_locked_apfid(pfv$locked_apfid, ignore_status);
      pfv$locked_apfid := 0;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND pfp$task_termination_cleanup;
MODEND pfm$task_termination;
*DECK DECK=PFM$TEST_ALL_REQUESTS EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, KEYW := UPPER, IDENT := LOWER) ??
?? SET (LISTCTS := OFF) ??
MODULE pfm$test_all_requests ALIAS 'pfmtall';
?? PUSH (LISTEXT := ON) ??
*copyc OSP$UNPACK_STATUS_CONDITION
*copyc PFP$ATTACH
*copyc PFP$CHANGE
*copyc PFP$DEFINE
*copyc PFP$DEFINE_CATALOG
*copyc PFP$DELETE_CATALOG_PERMIT
*copyc PFP$DELETE_PERMIT
*copyc PFP$PERMIT
*copyc PFP$PERMIT_CATALOG
*copyc PFP$PURGE
*copyc PFP$PURGE_CATALOG
*copyc AMP$OPEN
*copyc AMP$CLOSE
*copyc AMP$PUT_NEXT
*copyc AMP$RETURN
*copyc PFE$ERROR_CONDITION_CODES
*copyc PFE$INTERNAL_ERROR_CONDITIONS
?? POP ??
?? TITLE := '*** GLOBAL DEFINITIONS ***', EJECT ??

  CONST
    null = osc$null_name;

?? SKIP := 4 ??

  VAR
    end_of_line: string (1) := CHR (255),
    cycle_selector: pft$cycle_selector := [pfc$highest_cycle],
    password: pft$password := ' ',
    new_password: pft$password := 'new_password',
    usage: pft$usage_selections := [],
    sharing: pft$share_selections := [pfc$read, pfc$shorten, pfc$append, pfc$modify, pfc$execute],
    nowait: pft$wait := pfc$no_wait,
    application_info: pft$application_info := ' ',

    c: array [1 .. 2] of pft$name := [null, null],
    c1: array [1 .. 3] of pft$name := [null, null, 'catalog_1'],
    c2: array [1 .. 3] of pft$name := [null, null, 'catalog_2'],
    c3: array [1 .. 3] of pft$name := [null, null, 'catalog_3'],
    c11: array [1 .. 4] of pft$name := [null, null, 'catalog_1', 'catalog_1'],
    c12: array [1 .. 4] of pft$name := [null, null, 'catalog_1', 'catalog_2'],
    c13: array [1 .. 4] of pft$name := [null, null, 'catalog_1', 'catalog_3'],
    c121: array [1 .. 5] of pft$name := [null, null, 'catalog_1', 'catalog_2', 'catalog_1'],
    c122: array [1 .. 5] of pft$name := [null, null, 'catalog_1', 'catalog_2', 'catalog_2'],
    c123: array [1 .. 5] of pft$name := [null, null, 'catalog_1', 'catalog_2', 'catalog_3'],

    f1: array [1 .. 3] of pft$name := [null, null, 'file_1'],
    f2: array [1 .. 3] of pft$name := [null, null, 'file_2'],
    f3: array [1 .. 3] of pft$name := [null, null, 'file_3'],
    f11: array [1 .. 4] of pft$name := [null, null, 'catalog_1', 'file_1'],
    f13: array [1 .. 4] of pft$name := [null, null, 'catalog_1', 'file_3'],
    f14: array [1 .. 4] of pft$name := [null, null, 'catalog_1', 'file_4'],
    f125: array [1 .. 5] of pft$name := [null, null, 'catalog_1', 'catalog_2', 'file_5'],
    f126: array [1 .. 5] of pft$name := [null, null, 'catalog_1', 'catalog_2', 'file_6'],
    f127: array [1 .. 5] of pft$name := [null, null, 'catalog_1', 'catalog_2', 'file_7'],

    unknown_catalog: array [1 .. 3] of pft$name := [null, null, 'unknown_catalog'],
    unknown_catalog_known_catalog: array [1 .. 4] of pft$name := [null, null, 'unknown_catalog', 'catalog_1'],
    unknown_catalog_unknown_file: array [1 .. 4] of pft$name := [null, null, 'unknown_catalog',
      'unknown_file'],
    unknown_catalog_known_file: array [1 .. 4] of pft$name := [null, null, 'unknown_catalog', 'file_1'],
    known_catalog_unknown_file: array [1 .. 3] of pft$name := [null, null, 'unknown_file'],

    l1: amt$local_file_name := 'lfn_1',
    l2: amt$local_file_name := 'lfn_2',
    l3: amt$local_file_name := 'lfn_3',
    l4: amt$local_file_name := 'lfn_4',
    l5: amt$local_file_name := 'lfn_5',
    l6: amt$local_file_name := 'lfn_6',
    l7: amt$local_file_name := 'lfn_7',
    l8: amt$local_file_name := 'lfn_8',
    l9: amt$local_file_name := 'lfn_9',
    l10: amt$local_file_name := 'lfn_10',
    l11: amt$local_file_name := 'lfn_11',
    l12: amt$local_file_name := 'lfn_12',

    public: pft$group := [pfc$public],
    family_1: pft$group := [pfc$family, ['family_1']],
    family_2: pft$group := [pfc$family, ['family_2']],
    account_1: pft$group := [pfc$account, ['family_1', 'account_1']],
    account_2: pft$group := [pfc$account, ['family_1', 'account_2']],
    project_1: pft$group := [pfc$project, ['family_1', 'account_1', 'project_1']],
    project_2: pft$group := [pfc$project, ['family_1', 'account_1', 'project_2']],
    user_1: pft$group := [pfc$user, ['family_1', 'user_1']],
    user_2: pft$group := [pfc$user, ['family_1', 'user_2']],
    user_account_1: pft$group := [pfc$user_account, ['family_1', 'account_1', 'user_1']],
    user_account_2: pft$group := [pfc$user_account, ['family_1', 'account_2', 'user_1']],
    member_1: pft$group := [pfc$member, ['family_1', 'account_1', 'project_1', 'user_1']],
    member_2: pft$group := [pfc$member, ['family_1', 'account_1', 'project_2', 'user_1']],

    read_access: pft$permit_selections := [pfc$read],
    shorten_access: pft$permit_selections := [pfc$shorten],
    append_access: pft$permit_selections := [pfc$append],
    modify_access: pft$permit_selections := [pfc$modify],
    execute_access: pft$permit_selections := [pfc$execute],
    cycle_access: pft$permit_selections := [pfc$cycle],
    control_access: pft$permit_selections := [pfc$control],
    write_access: pft$permit_selections := [pfc$shorten, pfc$append, pfc$modify],
    all_access: pft$permit_selections := [pfc$read, pfc$shorten, pfc$append, pfc$modify, pfc$execute,
      pfc$cycle, pfc$control],
    no_access: pft$permit_selections := [],

    read_sharing: pft$share_selections := [pfc$read],
    shorten_sharing: pft$share_selections := [pfc$shorten],
    append_sharing: pft$share_selections := [pfc$append],
    modify_sharing: pft$share_selections := [pfc$modify],
    execute_sharing: pft$share_selections := [pfc$execute],
    write_sharing: pft$share_selections := [pfc$shorten, pfc$append, pfc$modify],
    all_sharing: pft$share_selections := [pfc$read, pfc$shorten, pfc$append, pfc$modify, pfc$execute],
    no_sharing: pft$share_selections := [],

    read_usage: pft$usage_selections := [pfc$read],

    change_list: array [1 .. 1] of pft$change_descriptor,
    change_list_5: array [1 .. 5] of pft$change_descriptor := [[pfc$pf_name_change, 'file_1'],
      [pfc$log_change, pfc$no_log], [pfc$retention_change, 321], [pfc$cycle_number_change, 555],
      [pfc$password_change, 'new_password']],

    file_id: amt$file_identifier,
    status: ost$status;

?? TITLE := '*** PFP$TEST_ALL_REQUESTS ***', EJECT ??
{       PFP$TEST_ALL_REQUESTS -
{

  PROCEDURE [XDCL, #GATE] pfp$test_all_requests;

    PROCEDURE [XREF] pfp$display_master_catalog;

    display_line (' Start of pfp$test_all_requests.');




    define (l1, f1, cycle_selector, password, 1, pfc$log, status);

    define_catalog (c1, status);

    define (l2, f2, cycle_selector, password, 999, pfc$no_log, status);

    define_catalog (c12, status);
    define_catalog (c123, status);

    define (l3, f13, cycle_selector, password, 500, pfc$log, status);

    define_catalog (c2, status);
    define_catalog (c3, status);
    define_catalog (c11, status);
    define_catalog (c13, status);

    define (l4, f14, cycle_selector, password, 30, pfc$no_log, status);

    define_catalog (c121, status);
    define_catalog (c122, status);

    define (l5, f125, cycle_selector, password, 1, pfc$log, status);

    define (l6, f126, cycle_selector, password, 1, pfc$log, status);

    define (l7, f127, cycle_selector, password, 1, pfc$log, status);

    define (l8, f1, cycle_selector, password, 999, pfc$no_log, status);

    cycle_selector.cycle_option := pfc$lowest_cycle;
    define (l9, f1, cycle_selector, password, 999, pfc$no_log, status);

    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := 1;
    define (l10, f1, cycle_selector, password, 999, pfc$no_log, status);

    cycle_selector.cycle_number := 999;
    define (l11, f1, cycle_selector, password, 999, pfc$no_log, status);

    cycle_selector.cycle_option := pfc$highest_cycle;
    define (l12, f1, cycle_selector, password, 999, pfc$no_log, status);




    amp$return (l1, status);
    amp$return (l2, status);
    amp$return (l3, status);
    amp$return (l4, status);
    amp$return (l5, status);
    amp$return (l6, status);
    amp$return (l7, status);
    amp$return (l8, status);
    amp$return (l9, status);
    amp$return (l10, status);
    amp$return (l11, status);
    amp$return (l12, status);




    permit_catalog (c, user_2, read_access, read_sharing, application_info, status);
    permit_catalog (c1, public, read_access, read_sharing, application_info, status);
    permit_catalog (c12, family_1, read_access + write_access, read_sharing, application_info, status);
    permit (f125, user_1, read_access + write_access + cycle_access, read_sharing, application_info, status);

    permit (f1, public, read_access, read_sharing, application_info, status);
    permit (f1, family_1, shorten_access, shorten_sharing, application_info, status);
    permit (f1, family_2, append_access, append_sharing, application_info, status);
    permit (f1, account_1, modify_access, modify_sharing, application_info, status);
    permit (f1, account_2, execute_access, execute_sharing, application_info, status);
    permit (f1, project_1, cycle_access, no_sharing, application_info, status);
    permit (f1, project_2, control_access, no_sharing, application_info, status);
    permit (f1, user_1, read_access + write_access, read_sharing + write_sharing, application_info, status);
    permit (f1, user_2, read_access + execute_access, read_sharing + execute_sharing, application_info,
      status);
    permit (f1, user_account_1, all_access, no_sharing, application_info, status);
    permit (f1, user_account_2, no_access, all_sharing, application_info, status);
    permit (f1, member_1, read_access + write_access, read_sharing, application_info, status);
    permit (f1, member_2, read_access + write_access, read_sharing + write_sharing, application_info, status);

    permit (f1, user_1, no_access, all_sharing, application_info, status);




    cycle_selector.cycle_option := pfc$highest_cycle;
    attach (l1, f1, cycle_selector, password, usage, sharing, nowait, status);

    attach (l2, f2, cycle_selector, password, usage, sharing, nowait, status);

    attach (l3, f13, cycle_selector, password, usage, sharing, nowait, status);

    attach (l4, f14, cycle_selector, password, usage, sharing, nowait, status);

    attach (l5, f125, cycle_selector, password, usage, sharing, nowait, status);

    attach (l6, f126, cycle_selector, password, usage, sharing, nowait, status);

    attach (l7, f127, cycle_selector, password, usage, sharing, nowait, status);

    attach (l8, f1, cycle_selector, password, usage, sharing, nowait, status);

    cycle_selector.cycle_option := pfc$lowest_cycle;
    attach (l9, f1, cycle_selector, password, usage, sharing, nowait, status);

    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := 1;
    attach (l10, f1, cycle_selector, password, usage, sharing, nowait, status);

    cycle_selector.cycle_number := 999;
    attach (l11, f1, cycle_selector, password, usage, sharing, nowait, status);

    cycle_selector.cycle_option := pfc$highest_cycle;
    attach (l12, f1, cycle_selector, password, usage, sharing, nowait, status);




    amp$return (l1, status);
    amp$return (l2, status);
    amp$return (l3, status);
    amp$return (l4, status);
    amp$return (l5, status);
    amp$return (l6, status);
    amp$return (l7, status);
    amp$return (l8, status);
    amp$return (l9, status);
    amp$return (l10, status);
    amp$return (l11, status);
    amp$return (l12, status);


    pfp$display_master_catalog;


    delete_permit (f1, user_2, status);
    delete_permit (f1, public, status);
    delete_permit (f1, family_1, status);
    delete_permit (f1, family_2, status);
    delete_permit (f1, family_2, status);
    delete_permit (f1, account_1, status);
    delete_permit (f1, account_2, status);
    delete_permit (f1, project_1, status);
    delete_permit (f1, project_2, status);
    delete_permit (f1, user_1, status);
    delete_permit (f1, user_2, status);
    delete_permit (f1, user_account_1, status);
    delete_permit (f1, user_account_2, status);
    delete_permit (f1, member_1, status);
    delete_permit (f1, member_2, status);

    permit_catalog (c, public, all_access, all_sharing, application_info, status);
    delete_catalog_permit (c, public, status);

    permit_catalog (c1, user_2, write_access, no_sharing, application_info, status);
    delete_catalog_permit (c1, user_2, status);

    permit (known_catalog_unknown_file, public, read_access, read_sharing, application_info, status);
    delete_permit (known_catalog_unknown_file, public, status);

    permit (unknown_catalog_known_file, public, read_access, read_sharing, application_info, status);
    delete_permit (unknown_catalog_known_file, public, status);

    permit_catalog (unknown_catalog, public, read_access, read_sharing, application_info, status);
    delete_catalog_permit (unknown_catalog, public, status);




    change_list [1].change_type := pfc$pf_name_change;
    change_list [1].pfn := f2 [UPPERBOUND (f2)];
    change (f1, cycle_selector, password, change_list, status);

    change_list [1].pfn := f3 [UPPERBOUND (f3)];
    change (f1, cycle_selector, password, change_list, status);

    change_list [1].change_type := pfc$password_change;
    change_list [1].password := new_password;
    change (f3, cycle_selector, password, change_list, status);

    change_list [1].change_type := pfc$cycle_number_change;
    change_list [1].cycle_number := 2;
    change (f3, cycle_selector, new_password, change_list, status);

    change_list [1].cycle_number := 3;
    change (f3, cycle_selector, new_password, change_list, status);

    change_list [1].change_type := pfc$retention_change;
    change_list [1].retention := 123;
    change (f3, cycle_selector, new_password, change_list, status);

    change_list [1].change_type := pfc$log_change;
    change_list [1].log := pfc$no_log;
    change (f3, cycle_selector, new_password, change_list, status);

    change_list [1].change_type := pfc$charge_change;
    change (f3, cycle_selector, new_password, change_list, status);

    change_list [1].change_type := pfc$pf_name_change;
    change_list [1].pfn := f1 [UPPERBOUND (f1)];
    change (f3, cycle_selector, new_password, change_list, status);

    change (f13, cycle_selector, password, change_list_5, status);

    change_list [1].change_type := pfc$pf_name_change;
    change_list [1].pfn := f13 [UPPERBOUND (f13)];
    change (f11, cycle_selector, new_password, change_list, status);




    purge_catalog (c1, status);

    cycle_selector.cycle_option := pfc$highest_cycle;
    purge (f127, cycle_selector, password, status);

    purge (f126, cycle_selector, password, status);

    purge (f125, cycle_selector, password, status);

    purge_catalog (c121, status);

    purge_catalog (c122, status);

    purge_catalog (c123, status);

    purge_catalog (c11, status);

    purge_catalog (c12, status);

    purge_catalog (c13, status);

    purge (f14, cycle_selector, password, status);

    purge (f13, cycle_selector, new_password, status);

    purge (f2, cycle_selector, password, status);

    purge (f1, cycle_selector, new_password, status);
    purge (f1, cycle_selector, new_password, status);
    purge (f1, cycle_selector, new_password, status);

    purge_catalog (c1, status);

    purge_catalog (c2, status);

    purge_catalog (c3, status);

    purge (known_catalog_unknown_file, cycle_selector, password, status);
    purge (unknown_catalog_unknown_file, cycle_selector, password, status);

    purge_catalog (unknown_catalog_known_catalog, status);


    {additional pf tests
    {BEGIN - these test are dependent on each other.
    cycle_selector.cycle_option := pfc$highest_cycle;
    define (l1, f1, cycle_selector, password, 1, pfc$log, status);

    {test of cycle busy }
    attach (l2, f1, cycle_selector, password, read_usage, read_sharing, nowait, status);

    {test of return
    amp$return (l1, status);
    attach (l1, f1, cycle_selector, password, read_usage, read_sharing, nowait, status);

    {test of sharing
    attach (l2, f1, cycle_selector, password, read_usage, read_sharing, nowait, status);

    {test of define of catalog of same name as file }
    define_catalog (f1, status);

    {test of duplicate lfn's
    attach (l2, f1, cycle_selector, password, read_usage, read_sharing, nowait, status);
    define (l2, f3, cycle_selector, password, 1, pfc$log, status);

    {test of defining and attaching an existing local file name}
    amp$open (l3, amc$record, NIL, file_id, status);
    define (l3, f3, cycle_selector, password, 1, pfc$log, status);
    attach (l3, f1, cycle_selector, password, read_usage, read_sharing, nowait, status);

    {purging an attached file
    purge (f1, cycle_selector, password, status);

    {test of attaching a purged (but active) file.
    attach (l4, f1, cycle_selector, password, read_usage, read_sharing, nowait, status);

    {clean up
    amp$return (l1, status);
    amp$return (l2, status);
    amp$return (l3, status);
    amp$return (l4, status);
    {END - the above tests were dependent on each other - all cleanup has been done


    {test of define of file as same name as catalog
    define_catalog (f1, status);
    define (l1, f1, cycle_selector, password, 1, pfc$log, status);
    purge_catalog (f1, status);




    display_line (' End of pfp$test_all_requests.');

  PROCEND pfp$test_all_requests;
?? TITLE := '*** ATTACH ***', EJECT ??
{       ATTACH -
{

  PROCEDURE attach (lfn: amt$local_file_name;
    path: pft$path;
    cycle_selector: pft$cycle_selector;
    password: pft$password;
    usage_selections: pft$usage_selections;
    share_selections: pft$share_selections;
    wait: pft$wait;
    VAR status: ost$status);

    VAR
      attach_count: [STATIC] integer := 0;

    attach_count := attach_count + 1;
    pfp$attach (lfn, path, cycle_selector, password, usage_selections, share_selections, wait, status);
    display_error ('ATTACH', attach_count, status);
  PROCEND attach;
?? TITLE := '*** CHANGE ***', EJECT ??
{       CHANGE -
{

  PROCEDURE change (path: pft$path;
    cycle_selector: pft$cycle_selector;
    password: pft$password;
    change_list: pft$change_list;
    VAR status: ost$status);

    VAR
      change_count: [STATIC] integer := 0;

    change_count := change_count + 1;
    pfp$change (path, cycle_selector, password, change_list, status);
    display_error ('CHANGE', change_count, status);
  PROCEND change;
?? TITLE := '*** DEFINE ***', EJECT ??
{       DEFINE -
{

  PROCEDURE define (lfn: amt$local_file_name;
    path: pft$path;
    cycle_selector: pft$cycle_selector;
    password: pft$password;
    retention: pft$retention;
    log: pft$log;
    VAR status: ost$status);

    VAR
      define_count: [STATIC] integer := 0;

    define_count := define_count + 1;
    pfp$define (lfn, path, cycle_selector, password, retention, log, status);
    display_error ('DEFINE', define_count, status);
  PROCEND define;
?? TITLE := '*** DEFINE_CATALOG ***', EJECT ??
{       DEFINE_CATALOG -
{

  PROCEDURE define_catalog (path: pft$path;
    VAR status: ost$status);

    VAR
      define_catalog_count: [STATIC] integer := 0;

    define_catalog_count := define_catalog_count + 1;
    pfp$define_catalog (path, status);
    display_error ('DEFINE_CATALOG', define_catalog_count, status);
  PROCEND define_catalog;
?? TITLE := '*** DELETE_CATALOG_PERMIT ***', EJECT ??
{       DELETE_CATALOG_PERMIT -
{

  PROCEDURE delete_catalog_permit (path: pft$path;
    group: pft$group;
    VAR status: ost$status);

    VAR
      delete_catalog_permit_count: [STATIC] integer := 0;

    delete_catalog_permit_count := delete_catalog_permit_count + 1;
    pfp$delete_catalog_permit (path, group, status);
    display_error ('DELETE_CATALOG_PERMIT', delete_catalog_permit_count, status);
  PROCEND delete_catalog_permit;
?? TITLE := '*** DELETE_PERMIT ***', EJECT ??
{       DELETE_PERMIT -
{

  PROCEDURE delete_permit (path: pft$path;
    group: pft$group;
    VAR status: ost$status);

    VAR
      delete_permit_count: [STATIC] integer := 0;

    delete_permit_count := delete_permit_count + 1;
    pfp$delete_permit (path, group, status);
    display_error ('DELETE_PERMIT', delete_permit_count, status);
  PROCEND delete_permit;
?? TITLE := '*** DISPLAY ***', EJECT ??
{       DISPLAY -
{

  PROCEDURE display (strng: string ( * ));

    VAR
      index: [STATIC] integer := 1,
      line: [STATIC] string (255),
      space: integer,
      size: integer,
      file_open: [STATIC] boolean := FALSE,
      file_name: [STATIC] amt$local_file_name := '$OUTPUT',
      file_id: [STATIC] amt$file_identifier,
      file_byte_address: amt$file_byte_address,
      status: ost$status;

    size := STRLENGTH (strng);
    IF (size > 0) THEN
      IF (strng = end_of_line) THEN
        IF NOT file_open THEN
          file_open := TRUE;
          amp$open (file_name, amc$record, NIL, file_id, status);
        IFEND;
        amp$put_next (file_id, ^line, index - 1, file_byte_address, status);
        index := 1;
      ELSE
        space := STRLENGTH (line) - index + 1;
        IF (size > space) THEN
          size := space;
        IFEND;
        line (index, size) := strng (1, size);
        index := index + size;
      IFEND;
    IFEND;
  PROCEND display;
?? TITLE := '*** DISPLAY_ERROR ***', EJECT ??
{       DISPLAY_ERROR -
{

  PROCEDURE display_error (name: string ( * );
    number: integer;
    status: ost$status);

    VAR
      identifier: ost$status_identifier,
      condition_number: ost$status_condition_number;

    IF NOT status.normal THEN
      display (' ');
      display (name);
      display (' #');
      display_integer (number);
      display (' = ');
      IF ((pfc$lowest_error <= status.condition) AND (status.condition <= pfc$highest_error)) THEN
        osp$unpack_status_condition (status.condition, identifier, condition_number);
        display (identifier);
        display (': ');
        display_pf_condition (condition_number);
        display (': ');
        display (status.text.value (1, status.text.size));
      ELSE
        display_integer (status.condition);
      IFEND;
      display_line ('');
    IFEND;
  PROCEND display_error;
?? TITLE := '*** DISPLAY_INTEGER ***', EJECT ??
{       DISPLAY_INTEGER -
{

  PROCEDURE display_integer (intgr: integer);

    VAR
      strng: string (30),
      length: integer;

    STRINGREP (strng, length, intgr);
    display (strng (1, length));
  PROCEND display_integer;
?? TITLE := '*** DISPLAY_LINE ***', EJECT ??
{       DISPLAY_LINE -
{

  PROCEDURE display_line (strng: string ( * ));

    display (strng);
    display (end_of_line);
  PROCEND display_line;
?? TITLE := '*** DISPLAY_PF_CONDITION ***', EJECT ??
{       DISPLAY_PF_CONDITION -
{

  PROCEDURE display_pf_condition (condition: integer);

    display_integer (condition);
  PROCEND display_pf_condition;
?? TITLE := '*** PERMIT ***', EJECT ??
{       PERMIT -
{

  PROCEDURE permit (path: pft$path;
    group: pft$group;
    permit_selections: pft$permit_selections;
    share_requirements: pft$share_requirements;
    application_info: pft$application_info;
    VAR status: ost$status);

    VAR
      permit_count: [STATIC] integer := 0;

    permit_count := permit_count + 1;
    pfp$permit (path, group, permit_selections, share_requirements, application_info, status);
    display_error ('PERMIT', permit_count, status);
  PROCEND permit;
?? TITLE := '*** PERMIT_CATALOG ***', EJECT ??
{       PERMIT_CATALOG -
{

  PROCEDURE permit_catalog (path: pft$path;
    group: pft$group;
    permit_selections: pft$permit_selections;
    share_requirements: pft$share_requirements;
    application_info: pft$application_info;
    VAR status: ost$status);

    VAR
      permit_catalog_count: [STATIC] integer := 0;

    permit_catalog_count := permit_catalog_count + 1;
    pfp$permit_catalog (path, group, permit_selections, share_requirements, application_info, status);
    display_error ('PERMIT_CATALOG', permit_catalog_count, status);
  PROCEND permit_catalog;
?? TITLE := '*** PURGE ***', EJECT ??
{       PURGE -
{

  PROCEDURE purge (path: pft$path;
    cycle_selector: pft$cycle_selector;
    password: pft$password;
    VAR status: ost$status);

    VAR
      purge_count: [STATIC] integer := 0;

    purge_count := purge_count + 1;
    pfp$purge (path, cycle_selector, password, status);
    display_error ('PURGE', purge_count, status);
  PROCEND purge;
?? TITLE := '*** PURGE_CATALOG ***', EJECT ??
{       PURGE_CATALOG -
{

  PROCEDURE purge_catalog (path: pft$path;
    VAR status: ost$status);

    VAR
      purge_catalog_count: [STATIC] integer := 0;

    purge_catalog_count := purge_catalog_count + 1;
    pfp$purge_catalog (path, status);
    display_error ('PURGE_CATALOG', purge_catalog_count, status);
  PROCEND purge_catalog;
?? SKIP := 4 ??
MODEND pfm$test_all_requests;
*DECK DECK=PFM$USER_RING_REQUEST_PROCESSOR EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Permanent Files : User Interfaces' ??
MODULE pfm$user_ring_request_processor;

{ PURPOSE:
{   This module contains the 2dd user interfaces.  If waiting is necessary, it
{   will occur here.

?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc dme$tape_errors
*copyc fsc$local
*copyc fsk$keypoints
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc pfd$catalog
*copyc pfk$keypoints
*copyc pft$purge_cycle_options
?? POP ??
?? EJECT ??
*copyc avp$system_administrator
*copyc bap$process_pt_request
*copyc clp$convert_file_ref_to_string
*copyc clp$evaluate_file_reference
*copyc fsp$path_element
*copyc jmp$system_job
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc ofp$display_status_message
*copyc ofp$get_display_status_message
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$clear_wait_message
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$get_current_display_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osv$initial_exception_context
*copyc pfp$detach_reserved_cycles
*copyc pfp$find_cycle_array_version_2
*copyc pfp$find_direct_info_record
*copyc pfp$find_directory_array
*copyc pfp$find_file_description
*copyc pfp$find_next_info_record
*copyc pfp$process_unexpected_status
*copyc pfp$r3_attach
*copyc pfp$r3_change
*copyc pfp$r3_change_catalog_flush_opt
*copyc pfp$r3_change_cycle_damage
*copyc pfp$r3_change_cycle_date_time
*copyc pfp$r3_change_file
*copyc pfp$r3_change_res_to_releasable
*copyc pfp$r3_define
*copyc pfp$r3_define_catalog
*copyc pfp$r3_define_data
*copyc pfp$r3_define_mass_storage_cat
*copyc pfp$r3_delete_all_arch_entries
*copyc pfp$r3_delete_archive_entry
*copyc pfp$r3_delete_catalog_permit
*copyc pfp$r3_delete_permit
*copyc pfp$r3_flush_catalog
*copyc pfp$r3_get_family_set
*copyc pfp$r3_get_item_info
*copyc pfp$r3_get_multi_item_info
*copyc pfp$r3_get_object_information
*copyc pfp$r3_mark_release_candidate
*copyc pfp$r3_permit
*copyc pfp$r3_permit_catalog
*copyc pfp$r3_purge
*copyc pfp$r3_purge_catalog
*copyc pfp$r3_put_archive_entry
*copyc pfp$r3_put_archive_info
*copyc pfp$r3_release_data
*copyc pfp$r3_replace_archive_entry
*copyc pfp$r3_replace_rem_media_fmd
*copyc pfp$r3_save_released_file_label
*copyc pfp$r3_put_cycle_info
*copyc pfp$r3_put_item_info
*copyc pfp$r3_resolve_path
*copyc pfp$r3_utility_attach
*copyc pfp$retrieve_archived_file
*copyc pfv$flush_catalogs
*copyc pfv$space_character
*copyc pmp$cause_condition
*copyc pmp$get_job_names
*copyc pmp$long_term_wait
*copyc pmp$wait

?? TITLE := '  Global Declarations Declared by this module', EJECT ??

  CONST
    include_radix = TRUE,
    one_second = 1000 {milliseconds},
    radix = 10,
    ten_seconds = 10 * one_second;

?? TITLE := '  [XDCL, #GATE] fsp$change_catalog_flush_option', EJECT ??
*copy fsh$change_catalog_flush_option

  PROCEDURE [XDCL, #GATE] fsp$change_catalog_flush_option
    (    flush_catalogs: boolean;
     VAR status: ost$status);

    pfp$r3_change_catalog_flush_opt (flush_catalogs);
    status.normal := TRUE;
  PROCEND fsp$change_catalog_flush_option;

?? TITLE := '  [XDCL, #GATE] fsp$change_cycle_damage', EJECT ??
*copy fsh$change_cycle_damage

  PROCEDURE [XDCL, #GATE] fsp$change_cycle_damage
    (    file: fst$file_reference;
         password: pft$password;
         new_damage_symptoms: fst$cycle_damage_symptoms;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context;

    #KEYPOINT (osk$entry, 0, fsk$change_cycle_damage);

    context := NIL;

    REPEAT
      pfp$r3_change_cycle_damage (file, password, new_damage_symptoms, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_file_reference;
          context^.file.file_reference := ^file;
          context^.password := password;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, fsk$change_cycle_damage);

  PROCEND fsp$change_cycle_damage;

?? TITLE := '  [XDCL, #GATE] fsp$change_cycle_date_time', EJECT ??
*copy fsh$change_cycle_date_time

  PROCEDURE [XDCL, #GATE] fsp$change_cycle_date_time
    (    file: fst$file_reference;
         password: pft$password;
         p_new_access_date_time: ^fst$date_time;
         p_new_modification_date_time: ^fst$date_time;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, fsk$change_cycle_date_time);

    context := NIL;

    REPEAT
      pfp$r3_change_cycle_date_time (file, password, p_new_access_date_time, {p_new_creation_date_time} NIL,
            p_new_modification_date_time, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_file_reference;
          context^.file.file_reference := ^file;
          context^.password := password;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
    #KEYPOINT (osk$exit, 0, fsk$change_cycle_date_time);

  PROCEND fsp$change_cycle_date_time;

?? TITLE := '  [XDCL, #GATE] fsp$change_file', EJECT ??
*copy fsh$change_file

  PROCEDURE [XDCL, #GATE] fsp$change_file
    (    file: fst$file_reference;
         password: pft$password;
         file_changes: ^fst$file_changes;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context;

    context := NIL;

    REPEAT
      pfp$r3_change_file (file, password, file_changes, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_file_reference;
          context^.file.file_reference := ^file;
          context^.password := password;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

  PROCEND fsp$change_file;

?? TITLE := '  [XDCL, #GATE] fsp$flush_catalog', EJECT ??
*copy fsh$flush_catalog

  PROCEDURE [XDCL, #GATE] fsp$flush_catalog
    (    catalog_object: fst$file_reference;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context,
      evaluated_file_reference: fst$evaluated_file_reference,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      p_fs_path: ^fst$path;

    context := NIL;

    clp$evaluate_file_reference (catalog_object, $clt$file_ref_parsing_options [],
          {resolve_cycle_number} FALSE, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF evaluated_file_reference.number_of_path_elements < pfc$subcatalog_name_index THEN
      PUSH p_fs_path;
      clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} FALSE, p_fs_path^,
            fs_path_size, local_status);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$path_too_short,
            p_fs_path^ (1, fs_path_size), status);
      osp$append_status_integer (osc$status_parameter_delimiter, pfc$subcatalog_name_index, radix,
            include_radix, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'catalog', status);
      RETURN;
    IFEND;

    REPEAT
      pfp$r3_flush_catalog (evaluated_file_reference, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_evaluated_file_ref;
          context^.file.evaluated_file_reference := evaluated_file_reference;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

  PROCEND fsp$flush_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$attach', EJECT ??
*copy pfh$attach

  PROCEDURE [XDCL, #GATE] pfp$attach
    (    lfn: amt$local_file_name;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
         wait: pft$wait;
     VAR status: ost$status);

    CONST
      five_minutes = 5*60*one_second; {milliseconds}

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context,
      cycle_number: pft$cycle_number,
      local_status: ost$status,
      time_since_last_retrieval: 0 .. fsc$longest_wait_time;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$attach);

    context := NIL;

    check_wait (wait, status);
    IF status.normal THEN

    /attach_file/
      REPEAT
        pfp$r3_attach (lfn, path, cycle_selector, password, usage_selections, share_selections,
              cycle_number, status);
        IF NOT status.normal THEN
          CASE status.condition OF

          = dme$unable_to_lock_tape_table =
            {
            { An extra wait is done to allow for the server case, where a
            { previous ready task has inhibited the subsequent wait.
            {
            pmp$wait (1, 1);
            pmp$long_term_wait (one_second, one_second);
            CYCLE /attach_file/;

          = pfe$tape_attached_on_client =
            CYCLE /attach_file/;

          ELSE
            ;
          CASEND;
          IF osp$file_access_condition (status) THEN
            IF context = NIL THEN
              PUSH context;
              context^ := osv$initial_exception_context;
              context^.caller_will_retrieve_file := TRUE;
              context^.file.selector := osc$ecp_pf_path;
              context^.file.pf_path := ^path;
              context^.file.cycle_selector := cycle_selector;
              context^.password := password;
              time_since_last_retrieval := 0;
            IFEND;

            IF (status.condition = pfe$cycle_data_resides_offline) THEN
              context^.wait := TRUE;
              IF NOT (fsc$data_retrieval_required IN context^.raised_conditions) THEN
                pmp$cause_condition (osc$data_retrieval_req_cond, ^context {input, output}, local_status);
                IF local_status.normal THEN
                  context^.raised_conditions := context^.raised_conditions + $fst$file_access_conditions
                        [fsc$data_retrieval_required]
                IFEND;
              IFEND;

              IF ((time_since_last_retrieval = 0) OR (time_since_last_retrieval >= five_minutes)) THEN
                pfp$retrieve_archived_file (path, cycle_number, password, osc$nowait, local_status);
                IF local_status.normal THEN
                  time_since_last_retrieval := 0;
                ELSE
                  context^.wait := FALSE;
                  status := local_status;
                  EXIT /attach_file/;
                IFEND;
              IFEND;
            ELSEIF status.condition = pfe$cycle_busy THEN
              context^.wait := (wait=pfc$wait);
            ELSE
              context^.wait := TRUE;
            IFEND;
            IF context^.wait THEN
              context^.condition_status := status;
              osp$enforce_exception_policies (context^);
              time_since_last_retrieval := time_since_last_retrieval + context^.elapsed_wait_time;
              status := context^.condition_status;
            IFEND;
          IFEND;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    IFEND;

    #KEYPOINT (osk$exit, 0, pfk$attach);

  PROCEND pfp$attach;

?? TITLE := '  [XDCL, #GATE] pfp$change', EJECT ??
*copy pfh$change

  PROCEDURE [XDCL, #GATE] pfp$change
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         change_list: pft$change_list;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$change);

    context := NIL;

    REPEAT
      pfp$r3_change (path, cycle_selector, password, change_list, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
          context^.file.cycle_selector := cycle_selector;
          context^.password := password;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
    #KEYPOINT (osk$exit, 0, pfk$change);

  PROCEND pfp$change;

?? TITLE := '  [XDCL, #GATE] pfp$change_res_to_releasable', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$change_res_to_releasable
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context;

    context := NIL;

    REPEAT
      pfp$r3_change_res_to_releasable (path, cycle_selector, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
          context^.file.cycle_selector := cycle_selector;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

  PROCEND pfp$change_res_to_releasable;

?? TITLE := '  [XDCL, #GATE] pfp$define', EJECT ??
*copy pfh$define

  PROCEDURE [XDCL, #GATE] pfp$define
    (    lfn: amt$local_file_name;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         retention: pft$retention;
         log: pft$log;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$define);

    context := NIL;

    REPEAT
      pfp$r3_define (lfn, path, cycle_selector, password, retention, log, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
          context^.file.cycle_selector := cycle_selector;
          context^.password := password;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
    #KEYPOINT (osk$exit, 0, pfk$define);

  PROCEND pfp$define;

?? TITLE := '  [XDCL, #GATE] pfp$define_catalog', EJECT ??
*copy pfh$define_catalog

  PROCEDURE [XDCL, #GATE] pfp$define_catalog
    (    path: pft$path;
     VAR status: ost$status);

    CONST
      minimum_path_length = 3;

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$define_catalog);

    context := NIL;

    REPEAT
      pfp$r3_define_catalog (path, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
          context^.catalog_object := TRUE;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$define_catalog);

  PROCEND pfp$define_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$define_data', EJECT ??
*copy pfh$define_data

  PROCEDURE [XDCL, #GATE] pfp$define_data
    (    lfn: amt$local_file_name;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         update_cycle_statistics: boolean;
         password_selector: pft$password_selector;
         p_mass_storage_request_info: ^fmt$mass_storage_request_info;
         p_volume_list: ^array [1 .. *] of rmt$recorded_vsn;
         purge_cycle_options: pft$purge_cycle_options;
         replace_cycle_data: boolean;
         restore_selections: put$restore_data_selections;
         wait_on_volume: boolean;
     VAR mandated_modification_time: {i/o} pft$mandated_modification_time;
     VAR data_residence: pft$data_residence;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$define_data);

    context := NIL;

    REPEAT
      pfp$r3_define_data (lfn, path, cycle_selector, update_cycle_statistics, password_selector,
            p_mass_storage_request_info, p_volume_list, purge_cycle_options, replace_cycle_data,
            restore_selections, mandated_modification_time, data_residence, status);
      IF wait_on_volume THEN
        IF NOT status.normal THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_pf_path;
            context^.file.pf_path := ^path;
            context^.file.cycle_selector := cycle_selector;
          IFEND;
          IF password_selector.password_specified = pfc$specific_password_option THEN
            context^.password := password_selector.password;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      IFEND;
    UNTIL status.normal OR (NOT wait_on_volume) OR (NOT osp$file_access_condition (status)) OR
          (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$define_data);

  PROCEND pfp$define_data;

?? TITLE := '  [XDCL, #GATE] pfp$define_mass_storage_catalog', EJECT ??
*copy pfh$define_mass_storage_catalog

  PROCEDURE [XDCL, #GATE] pfp$define_mass_storage_catalog
    (    catalog: pft$path;
         catalog_type: pft$catalog_types;
         p_mass_storage_request_info: ^fmt$mass_storage_request_info;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$define_mass_storage_catalog);

    context := NIL;

    REPEAT
      pfp$r3_define_mass_storage_cat (catalog, catalog_type, p_mass_storage_request_info, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^catalog;
          context^.catalog_object := TRUE;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$define_mass_storage_catalog);

  PROCEND pfp$define_mass_storage_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$delete_all_archive_entries', EJECT ??
*copy pfh$delete_all_archive_entries

  PROCEDURE [XDCL, #GATE] pfp$delete_all_archive_entries
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$delete_all_archive_entries);

    context := NIL;

    REPEAT
      pfp$r3_delete_all_arch_entries (path, cycle_selector, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
          context^.file.cycle_selector := cycle_selector;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$delete_all_archive_entries);

  PROCEND pfp$delete_all_archive_entries;

?? TITLE := '  [XDCL, #GATE] pfp$delete_archive_entry', EJECT ??
*copy pfh$delete_archive_entry

  PROCEDURE [XDCL, #GATE] pfp$delete_archive_entry
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$delete_archive_entry);

    context := NIL;

    REPEAT
      pfp$r3_delete_archive_entry (path, cycle_selector, archive_identification, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
          context^.file.cycle_selector := cycle_selector;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$delete_archive_entry);

  PROCEND pfp$delete_archive_entry;

?? TITLE := '  [XDCL, #GATE] pfp$delete_catalog_permit', EJECT ??
*copy pfh$delete_catalog_permit

  PROCEDURE [XDCL, #GATE] pfp$delete_catalog_permit
    (    path: pft$path;
         group: pft$group;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$delete_catalog_permit);

    context := NIL;

    REPEAT
      pfp$r3_delete_catalog_permit (path, group, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$delete_catalog_permit);

  PROCEND pfp$delete_catalog_permit;

?? TITLE := '  [XDCL, #GATE] pfp$delete_cycle_data', EJECT ??
*copy pfh$delete_cycle_data

  PROCEDURE [XDCL, #GATE] pfp$delete_cycle_data
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         purge_cycle_options: pft$purge_cycle_options;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context;

    context := NIL;

    REPEAT
      pfp$r3_purge (path, cycle_selector, password, purge_cycle_options, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
          context^.file.cycle_selector := cycle_selector;
          context^.password := password;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

  PROCEND pfp$delete_cycle_data;

?? TITLE := '  [XDCL, #GATE] pfp$delete_permit', EJECT ??
*copy pfh$delete_permit

  PROCEDURE [XDCL, #GATE] pfp$delete_permit
    (    path: pft$path;
         group: pft$group;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$delete_permit);

    context := NIL;

    REPEAT
      pfp$r3_delete_permit (path, group, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$delete_permit);

  PROCEND pfp$delete_permit;

?? TITLE := '  [XDCL, #GATE] pfp$get_family_set', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$get_family_set
    (    family_name: ost$name;
     VAR set_name: stt$set_name;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$get_family_set);

    context := NIL;

    REPEAT
      pfp$r3_get_family_set (family_name, set_name, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_file_reference;
          context^.file.file_reference := ^family_name;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
    #KEYPOINT (osk$exit, 0, pfk$get_family_set);

  PROCEND pfp$get_family_set;

?? TITLE := '  [XDCL, #GATE] pfp$get_item_info', EJECT ??
*copy pfh$get_item_info

  PROCEDURE [XDCL, #GATE] pfp$get_item_info
    (    path: pft$path;
         group: pft$group;
         catalog_info_selections: pft$catalog_info_selections;
         file_info_selections: pft$file_info_selections;
     VAR p_info: pft$p_info;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$get_item_info);

    context := NIL;

    REPEAT
      pfp$r3_get_item_info (path, group, catalog_info_selections, file_info_selections, p_info, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$get_item_info);

  PROCEND pfp$get_item_info;

?? TITLE := '  [XDCL, #GATE] pfp$get_multi_item_info', EJECT ??
*copy pfh$get_multi_item_info

  PROCEDURE [XDCL, #GATE] pfp$get_multi_item_info
    (    path: pft$path;
         group: pft$group;
         catalog_info_selections: pft$catalog_info_selections;
         file_info_selections: pft$file_info_selections;
     VAR p_info: pft$p_info;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$get_multi_item_info);

    context := NIL;

    REPEAT
      pfp$r3_get_multi_item_info (path, group, catalog_info_selections, file_info_selections,
            {p_cycle_reservation_criteria} NIL, p_info, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$get_multi_item_info);

  PROCEND pfp$get_multi_item_info;

?? TITLE := '  [XDCL, #GATE] pfp$get_object_information', EJECT ??
*copy pfh$get_object_information

  PROCEDURE [XDCL, #GATE] pfp$get_object_information
    (    file_reference: fst$file_reference;
         information_request: fst$goi_information_request;
         p_validation_criteria: {i/o^} ^fst$goi_validation_criteria;
     VAR p_object_information: {i/o} ^SEQ ( * );
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      evaluated_file_reference: fst$evaluated_file_reference;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$get_object_information);

    evaluate_file_reference (file_reference, {command_file_reference_allowed} TRUE, evaluated_file_reference,
          status);
    IF status.normal THEN
      pfp$r3_get_object_information (evaluated_file_reference, information_request, p_validation_criteria,
            p_object_information, status);
    IFEND;

    #KEYPOINT (osk$exit, 0, pfk$get_object_information);

  PROCEND pfp$get_object_information;

?? TITLE := '  [XDCL, #GATE] pfp$get_reserved_item_info', EJECT ??
*copy pfh$get_reserved_item_info

  PROCEDURE [XDCL, #GATE] pfp$get_reserved_item_info
    (    path: pft$path;
         group: pft$group;
         catalog_info_selections: pft$catalog_info_selections;
         file_info_selections: pft$file_info_selections;
         p_cycle_reservation_criteria: ^pft$cycle_reservation_criteria;
     VAR p_info: pft$p_info;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context,
      local_status: ost$status,
      message_displayed: boolean,
      original_display_message: oft$display_message;

    message_displayed := FALSE;

    context := NIL;

    REPEAT
      pfp$r3_get_multi_item_info (path, group, catalog_info_selections, file_info_selections,
            p_cycle_reservation_criteria, p_info, status);
      IF NOT status.normal THEN
        IF status.condition = pfe$reserved_cycle_table_locked THEN
          IF NOT message_displayed THEN
            message_displayed := TRUE;
            osp$get_current_display_message (original_display_message);
          IFEND;
          ofp$display_status_message (' Waiting for Reserved Cycle Table.', local_status);
          pmp$long_term_wait (ten_seconds, ten_seconds);
        ELSE
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_pf_path;
            context^.file.pf_path := ^path;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    IF NOT status.normal THEN
      REPEAT
        pfp$detach_reserved_cycles (local_status);
        IF NOT local_status.normal THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_pf_path;
            context^.file.pf_path := ^path;
          IFEND;
          context^.condition_status := local_status;
          osp$enforce_exception_policies (context^);
          local_status := context^.condition_status;
        IFEND;
      UNTIL local_status.normal OR (NOT osp$file_access_condition (local_status)) OR (NOT context^.wait);
    IFEND;

    IF message_displayed THEN
      osp$clear_wait_message (original_display_message, message_displayed);
    IFEND;

  PROCEND pfp$get_reserved_item_info;

?? TITLE := '  [XDCL, #GATE] pfp$mark_release_candidate', EJECT ??
*copy pfh$mark_release_candidate

  PROCEDURE [XDCL, #GATE] pfp$mark_release_candidate
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         archive_identification: pft$archive_identification;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$mark_release_candidate);

    context := NIL;

    REPEAT
      pfp$r3_mark_release_candidate (path, cycle_selector, password, caller_id, archive_identification,
            status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
          context^.file.cycle_selector := cycle_selector;
          context^.password := password;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$mark_release_candidate);

  PROCEND pfp$mark_release_candidate;

?? TITLE := '  [XDCL, #GATE] pfp$permit', EJECT ??
*copy pfh$permit

  PROCEDURE [XDCL, #GATE] pfp$permit
    (    path: pft$path;
         group: pft$group;
         permit_selections: pft$permit_selections;
         share_requirements: pft$share_requirements;
         application_info: pft$application_info;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$permit);

    context := NIL;

    REPEAT
      pfp$r3_permit (path, group, permit_selections, share_requirements, application_info, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$permit);

  PROCEND pfp$permit;

?? TITLE := '  [XDCL, #GATE] pfp$permit_catalog', EJECT ??
*copy pfh$permit_catalog

  PROCEDURE [XDCL, #GATE] pfp$permit_catalog
    (    path: pft$path;
         group: pft$group;
         permit_selections: pft$permit_selections;
         share_requirements: pft$share_requirements;
         application_info: pft$application_info;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$permit_catalog);

    context := NIL;

    REPEAT
      pfp$r3_permit_catalog (path, group, permit_selections, share_requirements, application_info, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$permit_catalog);

  PROCEND pfp$permit_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$purge', EJECT ??
*copy pfh$purge

  PROCEDURE [XDCL, #GATE] pfp$purge
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context,
      purge_cycle_options: pft$purge_cycle_options;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$purge);

    context := NIL;
    purge_cycle_options.enforce_password_validation := TRUE;
    purge_cycle_options.enforce_ring_validation := TRUE;
    purge_cycle_options.preserve_cycle_entry := FALSE;

    REPEAT
      pfp$r3_purge (path, cycle_selector, password, purge_cycle_options, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
          context^.file.cycle_selector := cycle_selector;
          context^.password := password;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$purge);

  PROCEND pfp$purge;

?? TITLE := '  [XDCL, #GATE] pfp$purge_catalog', EJECT ??
*copy pfh$purge_catalog

  PROCEDURE [XDCL, #GATE] pfp$purge_catalog
    (    path: pft$path;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$purge_catalog);

    context := NIL;

    REPEAT
      pfp$r3_purge_catalog (path, pfc$only_if_empty, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$purge_catalog);

  PROCEND pfp$purge_catalog;

?? TITLE := '  [XDCL, #GATE] pfp$purge_catalog_contents', EJECT ??
*copy pfh$purge_catalog_contents

  PROCEDURE [XDCL, #GATE] pfp$purge_catalog_contents
    (    catalog_path: pft$path;
         purge_catalog: boolean;
     VAR status: ost$status);

    CONST
      minimum_path_length = pfc$master_catalog_name_index;

    VAR
      context: ^ost$ecp_exception_context,
      found: boolean,
      group: pft$group,
      last_catalog_index: pft$catalog_path_index,
      local_status: ost$status,
      object_index: pft$object_index,
      p_catalog_directory_array: pft$p_directory_array,
      p_catalog_info: pft$p_info,
      p_catalog_info_record: pft$p_info_record,
      p_new_path: ^pft$path,
      path_index: pft$file_path_index,
      segment_pointer: amt$segment_pointer,
      space_index: 1 .. osc$max_name_size + 1;

?? NEWTITLE := '    delete_file_contents', EJECT ??

    PROCEDURE delete_file_contents
      (    file_path: pft$path;
           directory_entry: pft$directory_array_entry;
           p_catalog_info_record: {input^} pft$p_info_record;
           purge_catalog: boolean;
       VAR status: ost$status);

      VAR
        cycle_index: pft$cycle_index,
        cycle_selector: pft$cycle_selector,
        p_cycle_array: ^pft$cycle_array_version_2,
        p_file_description: pft$p_file_description,
        p_file_info_record: pft$p_info_record,
        purge_cycle_options: pft$purge_cycle_options;

      pfp$find_direct_info_record (^p_catalog_info_record^.body, directory_entry.info_offset,
            p_file_info_record, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pfp$find_cycle_array_version_2 (p_file_info_record, p_cycle_array, status);
      IF (NOT status.normal) OR (p_cycle_array = NIL) THEN
        RETURN;
      IFEND;

      pfp$find_file_description (p_file_info_record, p_file_description, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      cycle_selector.cycle_option := pfc$specific_cycle;
      purge_cycle_options.enforce_password_validation := TRUE;
      purge_cycle_options.enforce_ring_validation := TRUE;
      purge_cycle_options.preserve_cycle_entry := FALSE;

      FOR cycle_index := 1 TO UPPERBOUND (p_cycle_array^) DO
        cycle_selector.cycle_number := p_cycle_array^ [cycle_index].cycle_number;
        IF purge_catalog THEN
          pfp$r3_purge (file_path, cycle_selector, p_file_description^.password, purge_cycle_options,
                status);
          status.normal := status.normal OR osp$file_access_condition (status);
        ELSE
          pfp$purge (file_path, cycle_selector, p_file_description^.password, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND;

    PROCEND delete_file_contents;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    context := NIL;

    last_catalog_index := UPPERBOUND (catalog_path);
    IF last_catalog_index < minimum_path_length THEN
      #SCAN (pfv$space_character, catalog_path [pfc$family_name_index], space_index, found);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$path_too_short,
            catalog_path [pfc$family_name_index] (1, space_index - 1), status);
      osp$append_status_integer (osc$status_parameter_delimiter, minimum_path_length, radix, include_radix,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'catalog', status);
      RETURN;
    ELSEIF (last_catalog_index = minimum_path_length) AND purge_catalog THEN
      osp$set_status_condition (pfe$cannot_purge_master_catalog, status);
      RETURN;
    IFEND;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /segment_created/
    BEGIN
      p_catalog_info := segment_pointer.sequence_pointer;
      RESET p_catalog_info;

      PUSH p_new_path: [1 .. last_catalog_index + 1];
      FOR path_index := 1 TO last_catalog_index DO
        p_new_path^ [path_index] := catalog_path [path_index];
      FOREND;

      group.group_type := pfc$public;
      IF purge_catalog THEN
        pfp$r3_get_multi_item_info (catalog_path, group, $pft$catalog_info_selections [pfc$catalog_directory,
              pfc$catalog_description], $pft$file_info_selections [pfc$file_directory, pfc$file_description,
              pfc$file_cycles_version_2], {p_cycle_reservation_criteria} NIL, p_catalog_info, status);
        IF NOT status.normal THEN
          status.normal := osp$file_access_condition (status);
          EXIT /segment_created/;
        IFEND;
      ELSE
        REPEAT
          pfp$get_multi_item_info (catalog_path, group, $pft$catalog_info_selections [pfc$catalog_directory,
                pfc$catalog_description], $pft$file_info_selections [pfc$file_directory, pfc$file_description,
                pfc$file_cycles_version_2], p_catalog_info, status);
          IF NOT status.normal THEN
            IF context = NIL THEN
              PUSH context;
              context^ := osv$initial_exception_context;
              context^.file.selector := osc$ecp_pf_path;
              context^.file.pf_path := ^catalog_path;
            IFEND;
            context^.condition_status := status;
            osp$enforce_exception_policies (context^);
            status := context^.condition_status;
          IFEND;
        UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

        IF NOT status.normal THEN
          EXIT /segment_created/;
        IFEND;
      IFEND;

      RESET p_catalog_info;
      pfp$find_next_info_record (p_catalog_info, p_catalog_info_record, status);
      IF NOT status.normal THEN
        EXIT /segment_created/;
      IFEND;

      pfp$find_directory_array (p_catalog_info_record, p_catalog_directory_array, status);
      IF NOT status.normal THEN
        EXIT /segment_created/;
      IFEND;

      IF p_catalog_directory_array <> NIL THEN
        FOR object_index := LOWERBOUND (p_catalog_directory_array^)
              TO UPPERBOUND (p_catalog_directory_array^) DO
          p_new_path^ [last_catalog_index + 1] := p_catalog_directory_array^ [object_index].name;
          IF p_catalog_directory_array^ [object_index].name_type = pfc$file_name THEN
            delete_file_contents (p_new_path^, p_catalog_directory_array^ [object_index],
                  p_catalog_info_record, purge_catalog, status);
            IF NOT status.normal THEN
              EXIT /segment_created/;
            IFEND;
          ELSEIF p_catalog_directory_array^ [object_index].name_type = pfc$catalog_name THEN
            pfp$purge_catalog_contents (p_new_path^, {purge_catalog} TRUE, status);
            IF NOT status.normal THEN
              EXIT /segment_created/;
            IFEND;
          IFEND;
        FOREND;
      IFEND;
    END /segment_created/;

    IF status.normal THEN
      mmp$delete_scratch_segment (segment_pointer, local_status);
      pfp$process_unexpected_status (local_status);
    ELSE
      mmp$delete_scratch_segment (segment_pointer, local_status);
      RETURN;
    IFEND;

    IF purge_catalog THEN
      pfp$r3_purge_catalog (catalog_path, pfc$catalog_and_contents, status);
    IFEND;

  PROCEND pfp$purge_catalog_contents;

?? TITLE := '  [XDCL, #GATE] pfp$put_archive_entry', EJECT ??
*copy pfh$put_archive_entry

  PROCEDURE [XDCL, #GATE] pfp$put_archive_entry
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         p_archive_array_entry: pft$p_archive_array_entry;
         p_amd: pft$p_amd;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$put_archive_entry);

    context := NIL;

    REPEAT
      pfp$r3_put_archive_entry (path, cycle_selector, p_archive_array_entry, p_amd, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
          context^.file.cycle_selector := cycle_selector;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$put_archive_entry);

  PROCEND pfp$put_archive_entry;

?? TITLE := '  [XDCL, #GATE] pfp$put_archive_info', EJECT ??
*copy pfh$put_archive_info

  PROCEDURE [XDCL, #GATE] pfp$put_archive_info
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         p_cycle_info_record: pft$p_info_record;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$put_archive_info);

    context := NIL;

    REPEAT
      pfp$r3_put_archive_info (path, cycle_selector, p_cycle_info_record, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
          context^.file.cycle_selector := cycle_selector;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$put_archive_info);

  PROCEND pfp$put_archive_info;

?? TITLE := '  [XDCL, #GATE] pfp$put_cycle_info', EJECT ??
*copy pfh$put_cycle_info

  PROCEDURE [XDCL, #GATE] pfp$put_cycle_info
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         cycle_array_entry: pft$cycle_array_entry_version_2;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$put_cycle_info);

    context := NIL;

    REPEAT
      pfp$r3_put_cycle_info (path, cycle_selector, password_selector, cycle_array_entry, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
          context^.file.cycle_selector := cycle_selector;
        IFEND;
        IF password_selector.password_specified = pfc$specific_password_option THEN
          context^.password := password_selector.password;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);
    #KEYPOINT (osk$exit, 0, pfk$put_cycle_info);

  PROCEND pfp$put_cycle_info;

?? TITLE := '  [XDCL, #GATE] pfp$put_item_info', EJECT ??
*copy pfh$put_item_info

  PROCEDURE [XDCL, #GATE] pfp$put_item_info
    (    path: pft$path;
         p_info_record: pft$p_info_record;
         restore_archive_information: boolean;
         cycle_selection_criteria: put$selection_criteria;
         backup_file_version: pft$backup_file_version;
     VAR all_permits_restored: boolean;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$put_item_info);

    context := NIL;

    REPEAT
      pfp$r3_put_item_info (path, p_info_record, restore_archive_information, cycle_selection_criteria,
            backup_file_version, all_permits_restored, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
          context^.catalog_object := TRUE;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$put_item_info);

  PROCEND pfp$put_item_info;

?? TITLE := '  [XDCL, #GATE] pfp$release_data', EJECT ??
*copy pfh$release_data

  PROCEDURE [XDCL, #GATE] pfp$release_data
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$release_data);

    context := NIL;

    REPEAT
      pfp$r3_release_data (path, cycle_selector, password, {p_release_data_info} NIL, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
          context^.file.cycle_selector := cycle_selector;
          context^.password := password;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$release_data);

  PROCEND pfp$release_data;

?? TITLE := '  [XDCL, #GATE] pfp$replace_archive_entry', EJECT ??
*copy pfh$replace_archive_entry

  PROCEDURE [XDCL, #GATE] pfp$replace_archive_entry
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
         p_archive_array_entry: pft$p_archive_array_entry;
         p_amd: pft$p_amd;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$replace_archive_entry);

    context := NIL;

    REPEAT
      pfp$r3_replace_archive_entry (path, cycle_selector, archive_identification, p_archive_array_entry,
            p_amd, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
          context^.file.cycle_selector := cycle_selector;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$replace_archive_entry);

  PROCEND pfp$replace_archive_entry;

?? TITLE := '  [XDCL, #GATE] pfp$replace_rem_media_fmd', EJECT ??
*copy pfh$replace_rem_media_fmd

  PROCEDURE [XDCL, #GATE] pfp$replace_rem_media_fmd
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         p_file_media_descriptor: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context;

    context := NIL;

    REPEAT
      pfp$r3_replace_rem_media_fmd (path, cycle_selector, password_selector, p_file_media_descriptor,
           status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
          context^.file.cycle_selector := cycle_selector;
        IFEND;
        IF password_selector.password_specified = pfc$specific_password_option THEN
          context^.password := password_selector.password;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

  PROCEND pfp$replace_rem_media_fmd;

?? TITLE := '  [XDCL, #GATE] pfp$resolve_path', EJECT ??

  PROCEDURE [XDCL, #GATE] pfp$resolve_path
    (    path: pft$path;
     VAR cycle_reference: {i/o} fst$cycle_reference;
     VAR path_resolution: fst$path_resolution;
     VAR status: ost$status);

    pfp$r3_resolve_path (path, cycle_reference, path_resolution, status);

  PROCEND pfp$resolve_path;

?? TITLE := '  [XDCL, #GATE] pfp$save_released_file_label', EJECT ??
*copy pfh$save_released_file_label

  PROCEDURE [XDCL, #GATE] pfp$save_released_file_label
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         update_cycle_statistics: boolean;
         password_selector: pft$password_selector;
         p_file_label_container: fmt$p_file_label;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context;

    #CALLER_ID (caller_id);
    #KEYPOINT (osk$entry, osk$m * caller_id.ring, pfk$save_released_file_label);

    context := NIL;

    REPEAT
      pfp$r3_save_released_file_label (path, cycle_selector, update_cycle_statistics, password_selector,
            p_file_label_container, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_pf_path;
          context^.file.pf_path := ^path;
          context^.file.cycle_selector := cycle_selector;
        IFEND;
        IF password_selector.password_specified = pfc$specific_password_option THEN
          context^.password := password_selector.password;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    #KEYPOINT (osk$exit, 0, pfk$save_released_file_label);

  PROCEND pfp$save_released_file_label;

?? TITLE := '  [XDCL, #GATE] pfp$utility_attach', EJECT ??
*copy pfh$utility_attach

  PROCEDURE [XDCL, #GATE] pfp$utility_attach
    (    lfn: amt$local_file_name;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
         wait: pft$wait;
         allowed_cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR cycle_number: pft$cycle_number;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context;

    #KEYPOINT (osk$entry, 0, pfk$utility_attach);

    context := NIL;

    check_wait (wait, status);
    IF status.normal THEN

      REPEAT
        pfp$r3_utility_attach (lfn, path, cycle_selector, password, usage_selections, share_selections,
              allowed_cycle_damage_symptoms, cycle_damage_symptoms, cycle_number, status);
        IF NOT status.normal THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.allowed_access_conditions := $fst$file_access_conditions [fsc$catalog_media_missing,
                  fsc$catalog_volume_unavailable, fsc$file_server_inactive];
            IF  wait = pfc$wait THEN
              context^.allowed_access_conditions := context^.allowed_access_conditions +
                    $fst$file_access_conditions [fsc$cycle_busy];
            IFEND;
            context^.file.selector := osc$ecp_pf_path;
            context^.file.pf_path := ^path;
            context^.file.cycle_selector := cycle_selector;
            context^.password := password;
            IF status.condition = pfe$cycle_busy THEN
              context^.wait := (wait = pfc$wait);
            IFEND;
          IFEND;
          context^.condition_status := status;
          osp$enforce_exception_policies (context^);
          status := context^.condition_status;
        IFEND;
      UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

    IFEND;

    #KEYPOINT (osk$exit, 0, pfk$utility_attach);

  PROCEND pfp$utility_attach;

?? TITLE := '  [INLINE] check_wait', EJECT ??

  PROCEDURE [INLINE] check_wait
    (    wait: pft$wait;
     VAR status: ost$status);

    IF (wait = pfc$wait) OR (wait = pfc$no_wait) THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_condition (pfe$bad_wait_option, status);
      osp$append_status_integer (osc$status_parameter_delimiter, $INTEGER (wait), radix, NOT include_radix,
            status);
    IFEND;

  PROCEND check_wait;

?? TITLE := '  evaluate_file_reference', EJECT ??

  PROCEDURE evaluate_file_reference
    (    file_reference: fst$file_reference;
         command_file_reference_allowed: boolean;
     VAR evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

    VAR
      process_pt_results: bat$process_pt_results;

    clp$evaluate_file_reference (file_reference, $clt$file_ref_parsing_options [clc$command_file_ref_allowed],
          {resolve_cycle_number} FALSE, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Return permanent file path if alias & resolve temporary files.

    IF (fsp$path_element (^evaluated_file_reference, 1)^ = fsc$local) THEN
      bap$process_pt_request ($bat$process_pt_work_list [], {local_file_name} osc$null_name,
            evaluated_file_reference, process_pt_results, status);
    IFEND;

  PROCEND evaluate_file_reference;

MODEND pfm$user_ring_request_processor;
*DECK DECK=PFP$ACCESS_LAST_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] pfp$access_last_object (
        path: pft$complete_path;
        authority: pft$authority;
        valid_objects: pft$object_selections;
    VAR catalog_locator: {i/o} pft$catalog_locator;
    VAR permit_entry: {i/o} pft$permit_entry;
    VAR p_object: {output} pft$p_object;
    VAR internal_name: pft$internal_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$authority
*copyc pfd$catalog
*copyc pfd$catalog_locator
*copyc pfd$complete_path
*copyc pfd$internal_name
?? POP ??
*DECK DECK=PFP$ACCESS_NEXT_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$access_next_catalog (
        access_kind: pft$access_kind;
        last_catalog_locator: pft$catalog_locator;
        p_catalog_object: pft$p_object;
        catalog_remote: boolean;
    VAR next_catalog_logcator: pft$catalog_locator;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG
*copyc PFD$CATALOG_LOCATOR
?? POP ??
*DECK DECK=PFP$ACCESS_NEXT_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] pfp$access_next_object (
        p_object_list: pft$p_object_list;
        next_object_name: pft$name;
        permit_entry: pft$permit_entry;
        authority: pft$authority;
        p_catalog_file: pft$p_catalog_file;
    VAR p_next_object: pft$p_object;
    VAR new_permit_entry: pft$permit_entry);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$AUTHORITY
*copyc PFD$CATALOG
*copyc PFD$PERMANENT_FILE_DEFINITIONS
?? POP ??
*DECK DECK=PFP$ACCESS_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] pfp$access_object (
        path: pft$complete_path;
        access_kind: pft$access_kind;
        authority: pft$authority;
        valid_objects: pft$object_selections;
    VAR parent_charge_id: pft$charge_id;
    VAR catalog_locator: pft$catalog_locator;
    VAR p_physical_object: ^pft$physical_object;
    VAR internal_path: pft$internal_path;
    VAR permit_entry: pft$permit_entry;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$authority
*copyc pfd$catalog
*copyc pfd$catalog_locator
*copyc pfd$charge_id
*copyc pfd$complete_path
?? POP ??
*DECK DECK=PFP$ADD_TO_PROJECT_INFO EXPAND=TRUE
?? NEWTITLE := 'pfp$add_to_project_info', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avt$account_name
*copyc avt$project_name
?? POP ??

{ PURPOSE
{   This procedure is used to add account/project information for a user to a linked list of information
{   records.  This list is processed and cleared out each time a new master catalog (user) is processed.  The
{   information in this list is used for emitting membership statistics and for writing account, project and
{   membership limit information into the limit information sequence.

    PROCEDURE pfp$add_to_project_info
      (    info_type: project_info_type;
           account_name: avt$account_name;
           project_name: avt$project_name;
           online_eoi_size: integer;
           offline_eoi_size: integer;
           offline_total_eoi_size: integer;
           allocated_size: integer;
       VAR first_project_info {input, output} : ^project_information);

      VAR
        current_project_info: ^project_information,
        next_project_info: ^project_information,
        previous_project_info: ^project_information;

      next_project_info := NIL;
      previous_project_info := NIL;
      current_project_info := first_project_info;

    /project_search/
      WHILE current_project_info <> NIL DO
        IF (current_project_info^.info_type = info_type) AND
              (current_project_info^.account_name = account_name) AND
              (current_project_info^.project_name = project_name) THEN
          EXIT /project_search/;
        ELSEIF (current_project_info^.info_type = info_type) AND
              ((current_project_info^.account_name > account_name) OR
              ((current_project_info^.account_name = account_name) AND
              (current_project_info^.project_name > project_name))) THEN
          IF current_project_info = first_project_info THEN
            first_project_info := NIL;
          IFEND;
          next_project_info := current_project_info;
          current_project_info := NIL;
          EXIT /project_search/;
        ELSE
          previous_project_info := current_project_info;
          current_project_info := current_project_info^.next_project_info;
        IFEND;
      WHILEND /project_search/;

      IF current_project_info = NIL THEN
        NEXT current_project_info IN project_info_p;
        IF first_project_info = NIL THEN
          first_project_info := current_project_info;
        IFEND;
        IF previous_project_info <> NIL THEN
          previous_project_info^.next_project_info := current_project_info;
        IFEND;
        current_project_info^.next_project_info := next_project_info;
        current_project_info^.info_type := info_type;
        current_project_info^.account_name := account_name;
        current_project_info^.project_name := project_name;
        current_project_info^.allocated_size := 0;
        current_project_info^.online_eoi_size := 0;
        current_project_info^.offline_eoi_size := 0;
        current_project_info^.offline_total_eoi_size := 0;
        current_project_info^.count := 0;
      IFEND;

      current_project_info^.allocated_size := current_project_info^.allocated_size + allocated_size;
      current_project_info^.online_eoi_size := current_project_info^.online_eoi_size + online_eoi_size;
      current_project_info^.offline_eoi_size := current_project_info^.offline_eoi_size + offline_eoi_size;
      current_project_info^.offline_total_eoi_size := current_project_info^.offline_total_eoi_size +
            offline_total_eoi_size;
      current_project_info^.count := current_project_info^.count + 1;

    PROCEND pfp$add_to_project_info;
?? OLDTITLE ??
*DECK DECK=PFP$ALLOCATE_ARCHIVE_LIST EXPAND=FALSE

  PROCEDURE [INLINE] pfp$allocate_archive_list
    (    archive_count: pft$archive_count;
         p_catalog_heap: pft$p_catalog_heap;
     VAR p_archive_list: pft$p_archive_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    ALLOCATE p_archive_list: [1 .. archive_count] IN p_catalog_heap^;
    IF p_archive_list <> NIL THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, '', status);
    IFEND;
  PROCEND pfp$allocate_archive_list;

*copyc pfd$catalog
*copyc pfe$error_condition_codes
*copyc osp$set_status_abnormal
?? POP ??
*DECK DECK=PFP$ALLOCATE_CYCLE_LIST EXPAND=FALSE

  PROCEDURE [INLINE] pfp$allocate_cycle_list (
        cycle_count: pft$cycle_count;
        p_catalog_heap: pft$p_catalog_heap;
    VAR p_cycle_list: pft$p_cycle_list;
    VAR status: ost$status);

    ALLOCATE p_cycle_list: [1 .. cycle_count + pfc$cycle_expansion_count] IN p_catalog_heap^;
    IF p_cycle_list <> NIL THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, '', status);
    IFEND;
  PROCEND pfp$allocate_cycle_list;

?? PUSH (LISTEXT := ON) ??
*copyc PFD$CATALOG
*copyc OSP$SET_STATUS_ABNORMAL
?? POP ??
*DECK DECK=PFP$ALLOCATE_LOG_LIST EXPAND=FALSE

  PROCEDURE [INLINE] pfp$allocate_log_list (
        log_count: pft$log_count;
        p_catalog_heap: pft$p_catalog_heap;
    VAR p_log_list: pft$p_log_list;
    VAR status: ost$status);

    ALLOCATE p_log_list: [1 .. log_count + pfc$log_expansion_count] IN p_catalog_heap^;
    IF p_log_list <> NIL THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, '', status);
    IFEND;
  PROCEND pfp$allocate_log_list;

?? PUSH (LISTEXT := ON) ??
*copyc PFD$CATALOG
*copyc OSP$SET_STATUS_ABNORMAL
?? POP ??
*DECK DECK=PFP$ALLOCATE_OBJECT_LIST EXPAND=FALSE

  PROCEDURE [INLINE] pfp$allocate_object_list (
        object_count: pft$object_count;
        p_catalog_heap: pft$p_catalog_heap;
    VAR p_object_list: pft$p_object_list;
    VAR status: ost$status);

    ALLOCATE p_object_list: [1 .. object_count + pfc$object_expansion_count] IN p_catalog_heap^;
    IF p_object_list <> NIL THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, '', status);
    IFEND;
  PROCEND pfp$allocate_object_list;

?? PUSH (LISTEXT := ON) ??
*copyc PFD$CATALOG
*copyc OSP$SET_STATUS_ABNORMAL
?? POP ??
*DECK DECK=PFP$ALLOCATE_PERMIT_LIST EXPAND=FALSE

  PROCEDURE [INLINE] pfp$allocate_permit_list (
        permit_count: pft$permit_count;
        p_catalog_heap: pft$p_catalog_heap;
    VAR p_permit_list: pft$p_permit_list;
    VAR status: ost$status);

    ALLOCATE p_permit_list: [1 .. permit_count + pfc$permit_expansion_count] IN p_catalog_heap^;
    IF p_permit_list <> NIL THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_full, '', status);
    IFEND;
  PROCEND pfp$allocate_permit_list;

?? PUSH (LISTEXT := ON) ??
*copyc PFD$CATALOG
*copyc OSP$SET_STATUS_ABNORMAL
?? POP ??
*DECK DECK=PFP$ASSIGN_LOCKED_APFID EXPAND=FALSE

  PROCEDURE [XREF] pfp$assign_locked_apfid (VAR apfid:
    pft$attached_pf_table_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pft$attached_pf_table_index
*copyc OST$STATUS
?? POP ??
*DECK DECK=PFP$ATTACH EXPAND=FALSE

  PROCEDURE [XREF] pfp$attach ALIAS 'pfxatt' (lfn: amt$local_file_name;
    path: pft$path;
    cycle_selector: pft$cycle_selector;
    password: pft$password;
    usage_selections: pft$usage_selections;
    share_selections: pft$share_selections;
    wait: pft$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc PFE$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=PFP$ATTACH_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$attach_catalog
   (    p_fmd: pft$p_fmd;
        set_name: stt$set_name;
        internal_catalog_name: pft$internal_name;
        global_file_name: ost$binary_unique_name;
        access_kind: pft$access_kind;
        catalog_remote: boolean;
    VAR catalog_locator: pft$catalog_locator;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$catalog_locator
*copyc pfd$internal_name
*copyc std$set_name
?? POP ??
*DECK DECK=PFP$ATTACH_FOR_WRITE EXPAND=FALSE

  FUNCTION [INLINE] pfp$attach_for_write
    (    usage_selections: pft$usage_selections): boolean;

?? PUSH (LISTEXT := ON) ??
    pfp$attach_for_write := usage_selections *
          $pft$usage_selections [pfc$shorten, pfc$append,
          pfc$modify] <> $pft$usage_selections [];

  FUNCEND pfp$attach_for_write;

*copyc pfd$permanent_file_attributes
?? POP ??
*DECK DECK=PFP$ATTACH_LAST_QUEUED_CATALOG EXPAND=FALSE
 PROCEDURE [XREF] pfp$attach_last_queued_catalog (set_name: stt$set_name;
        internal_path: pft$internal_path;
        last_catalog_index: pft$array_index;
        access_kind: pft$access_kind;
    VAR found_catalog_index: pft$array_index;
    VAR catalog_locator: pft$catalog_locator;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc std$set_name
*copyc pfd$complete_path
*copyc pfd$catalog_locator
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$ATTACH_PERMANENT_FILE EXPAND=FALSE

  PROCEDURE [XREF] pfp$attach_permanent_file (
        family_location: pft$family_location;
        mainframe_id: pmt$binary_mainframe_id;
        lfn: amt$local_file_name;
        path: pft$complete_path;
        attached_pf_table_index: pft$attached_pf_table_index;
        usage_selections: pft$usage_selections;
        share_selections: pft$share_selections;
        application_info: pft$application_info;
        validation_ring: ost$valid_ring;
        password_protected: boolean;
        allowed_cycle_damage_symptoms: fst$cycle_damage_symptoms;
        enable_media_damage_detection: boolean;
        implicit_attach: boolean;
        update_catalog: boolean;
        authority: pft$authority;
        p_file_label: {input} ^fmt$file_label;
        p_catalog_file: {i^/o^} ^pft$catalog_file;
        p_physical_cycle: {i^/o^} ^pft$physical_cycle;
    VAR system_file_id: dmt$system_file_id;
    VAR file_damaged: boolean;
    VAR flush_catalog_pages: boolean;
    VAR path_handle: fmt$path_handle;
    VAR p_file_server_buffers: ^pft$file_server_buffers;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dft$command_buffer
*copyc dmt$system_file_id
*copyc fmt$file_label
*copyc fmt$path_handle
*copyc fst$cycle_damage_symptoms
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$attached_permanent_file_id
*copyc pfd$authority
*copyc pfd$catalog
*copyc pfd$complete_path
*copyc pfd$permanent_file_attributes
*copyc pft$family_location
*copyc pft$server_file_output
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=PFP$ATTACH_ROOT_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$attach_root_catalog (
        set_name: stt$set_name;
        access_kind: pft$access_kind;
    VAR catalog_locator: pft$catalog_locator;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_LOCATOR
*copyc STD$SET_NAME
?? POP ??
*DECK DECK=PFP$AUDIT_SAVE_LABEL EXPAND=FALSE

  PROCEDURE [XREF] pfp$audit_save_label
    (    variant_path: pft$variant_path;
         p_save_label_audit_info: {input^} ^pft$save_label_audit_info;
         audit_status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pft$save_label_audit_info
*copyc pft$variant_path
?? POP ??
*DECK DECK=PFP$BEGIN_SYSTEM_AUTHORITY EXPAND=FALSE

  PROCEDURE [INLINE] pfp$begin_system_authority;

?? PUSH (LISTEXT := ON) ??

    pfv$system_authority := pfv$system_authority + 1;
  PROCEND pfp$begin_system_authority;

*copyc pfv$system_authority
?? POP ??
*DECK DECK=PFP$BUILD_AMD_LOCATOR EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_amd_locator
    (    p_physical_amd: pft$p_physical_amd;
         p_catalog_file: pft$p_catalog_file;
     VAR amd_locator: pft$amd_locator);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$BUILD_AMD_POINTER EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_amd_pointer
    (    amd_locator: pft$amd_locator;
         p_catalog_file: pft$p_catalog_file;
     VAR p_physical_amd: pft$p_physical_amd);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$BUILD_ARCHIVE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_archive_entry
    (    archive_identification: pft$archive_identification;
         p_archive_array_entry: pft$p_archive_array_entry;
         p_physical_amd: pft$p_physical_amd,
         p_catalog_file: pft$p_catalog_file;
         p_archive: pft$p_archive;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$catalog_info
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
?? POP ??
*DECK DECK=PFP$BUILD_ARCHIVE_LIST_LOCATOR EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_archive_list_locator
    (    p_archive_list: pft$p_archive_list;
         p_catalog_file: pft$p_catalog_file;
     VAR archive_list_locator: pft$archive_list_locator);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$CATALOG
?? POP ??
*DECK DECK=PFP$BUILD_ARCHIVE_LIST_POINTER EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_archive_list_pointer
    (    archive_list_locator: pft$archive_list_locator;
         p_catalog_file: pft$p_catalog_file;
     VAR p_archive_list: pft$p_archive_list);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$BUILD_CYCLE_LIST_LOCATOR EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_cycle_list_locator
    (    p_cycle_list: {input} pft$p_cycle_list;
         p_catalog_file: {input^} pft$p_catalog_file;
     VAR cycle_list_locator: pft$cycle_list_locator);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$BUILD_CYCLE_LIST_POINTER EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_cycle_list_pointer
    (    cycle_list_locator: pft$cycle_list_locator;
         p_catalog_file: {input^} pft$p_catalog_file;
     VAR p_cycle_list: {output} pft$p_cycle_list);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$BUILD_FILE_LABEL_LOCATOR EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_file_label_locator
    (    p_file_label: {input} pft$p_stored_file_label;
         p_catalog_file: {input^} pft$p_catalog_file;
     VAR file_label_locator: pft$file_label_locator);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$BUILD_FILE_LABEL_POINTER EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_file_label_pointer
    (    file_label_locator: pft$file_label_locator;
         p_catalog_file: {input^} pft$p_catalog_file;
     VAR p_file_label: {output} pft$p_stored_file_label);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$BUILD_FMD_LOCATOR EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_fmd_locator
    (    p_physical_fmd: {input} pft$p_physical_fmd;
         p_catalog_file: {input^} pft$p_catalog_file;
     VAR fmd_locator: pft$fmd_locator);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$BUILD_FMD_POINTER EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_fmd_pointer
    (    fmd_locator: pft$fmd_locator;
         p_catalog_file: {input^} pft$p_catalog_file;
     VAR p_physical_fmd: {output} pft$p_physical_fmd);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$BUILD_LOG_LIST_LOCATOR EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_log_list_locator
    (    p_log_list: {input} pft$p_log_list;
         p_catalog_file: {input^} pft$p_catalog_file;
     VAR log_list_locator: pft$log_list_locator);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$BUILD_LOG_LIST_POINTER EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_log_list_pointer
    (    log_list_locator: pft$log_list_locator;
         p_catalog_file: {input^} pft$p_catalog_file;
     VAR p_log_list: {output} pft$p_log_list);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$BUILD_MAINFRAM_LIST_LOCATOR EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_mainfram_list_locator
    (    p_mainframe_list: {input} ^pft$mainframe_usage_list;
         p_catalog_file: {input^} pft$p_catalog_file;
     VAR mainframe_list_locator: pft$mainframe_list_locator);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$BUILD_MAINFRAM_LIST_POINTER EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_mainfram_list_pointer
    (    mainframe_list_locator: pft$mainframe_list_locator;
         p_catalog_file: {input^} pft$p_catalog_file;
     VAR p_mainframe_list: {output} ^pft$mainframe_usage_list);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$BUILD_OBJECT_LIST_LOCATOR EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_object_list_locator
    (    sorted_object_count: pft$object_count;
         free_sorted_object_count: pft$object_count;
         p_object_list: {input} pft$p_object_list;
         p_catalog_file: {input} pft$p_catalog_file;
     VAR object_list_locator: pft$object_list_locator);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$BUILD_OBJECT_LIST_POINTER EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_object_list_pointer
    (    object_list_locator: pft$object_list_locator;
         p_catalog_file: {input^} pft$p_catalog_file;
     VAR p_object_list: {output} pft$p_object_list);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$BUILD_PERMIT_LIST_LOCATOR EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_permit_list_locator
    (    p_permit_list: {input} pft$p_permit_list;
         p_catalog_file: {input^} pft$p_catalog_file;
     VAR permit_list_locator: pft$permit_list_locator);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$BUILD_PERMIT_LIST_POINTER EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_permit_list_pointer
    (    permit_list_locator: pft$permit_list_locator;
         p_catalog_file: {input^} pft$p_catalog_file;
     VAR p_permit_list: {output} pft$p_permit_list);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$BUILD_PERMIT_SELECTIONS_STR EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_permit_selections_str (
        permit_selections: pft$permit_selections;
    VAR permit_string: pft$selections_string);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
*copyc pft$selections_string
?? POP ??
*DECK DECK=PFP$BUILD_SHARE_SELECTIONS_STR EXPAND=FALSE

  PROCEDURE [XREF] pfp$build_share_selections_str (
        share_selections: pft$share_selections;
    VAR share_string: pft$selections_string);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_attributes
*copyc pft$selections_string
?? POP ??
*DECK DECK=PFP$BUILD_SORTED_DFL EXPAND=FALSE
   PROCEDURE [XREF] pfp$build_sorted_dfl
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PFP$CATALOG_ACCESS_RETRY_WAIT EXPAND=FALSE

  PROCEDURE [XREF] pfp$catalog_access_retry_wait
    (    procedure_name: string(*));

*DECK DECK=PFP$CHANGE EXPAND=FALSE

  PROCEDURE [XREF] pfp$change ALIAS 'pfxcha' (path: pft$path;
    cycle_selector: pft$cycle_selector;
    password: pft$password;
    change_list: pft$change_list;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc OST$STATUS
*copyc PFE$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=PFP$CHANGE_FAMILY_NAME EXPAND=FALSE
PROCEDURE [XREF] pfp$change_family_name (set_name: stt$set_name;
        family_name: pft$name;
        new_family_name: pft$name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc std$set_name
?? POP ??
*DECK DECK=PFP$CHANGE_OBJECT_NAME EXPAND=FALSE

  PROCEDURE [XREF] pfp$change_object_name
    (    p_path: ^pft$complete_path;
         new_object_name: pft$name;
         p_catalog_file: {output} ^pft$catalog_file;
     VAR p_object: {i/o} ^pft$physical_object;
     VAR object_list_descriptor: {i/o} pft$object_list_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$catalog_locator
*copyc pfd$complete_path
?? POP ??
*DECK DECK=PFP$CHANGE_RES_TO_RELEASABLE EXPAND=FALSE

  PROCEDURE [XREF] pfp$change_res_to_releasable
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$CHECK_APFID_LOCATION EXPAND=FALSE
{   This procedure determines if the attached permanent file is on the
{ requested mainframe.

  PROCEDURE [INLINE] pfp$check_apfid_location
    (    requested_mainframe_id: pmt$binary_mainframe_id;
         apfid: pft$attached_permanent_file_id;
     VAR correct_mainframe: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      apfid_mainframe_id: pmt$binary_mainframe_id,
      family: ost$family_name,
      index_valid: boolean,
      p_queue_interface_table: dft$p_queue_interface_table,
      queue_index: dft$queue_index;

    IF apfid.family_location = pfc$local_mainframe THEN
      pmp$get_pseudo_mainframe_id (apfid_mainframe_id);
      correct_mainframe := (apfid_mainframe_id = requested_mainframe_id);
    ELSE { Server file
      dfp$fetch_served_family_info (apfid.served_family_table_index, family,
            apfid_mainframe_id, p_queue_interface_table, queue_index,
            index_valid);
      correct_mainframe := index_valid AND
            (apfid_mainframe_id = requested_mainframe_id);

    IFEND;
  PROCEND pfp$check_apfid_location;
*copyc pfd$attached_permanent_file_id
*copyc pmt$binary_mainframe_id
*copyc dfp$fetch_served_family_info
*copyc pmp$get_pseudo_mainframe_id
?? POP ??
*DECK DECK=PFP$CHECK_ARCHIVE_ENTRIES EXPAND=FALSE

  PROCEDURE [XREF] pfp$check_archive_entries
    (    p_catalog_file: {input^} pft$p_catalog_file;
         p_cycle: {input^} pft$p_cycle;
     VAR valid_archive_entry_exists: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$CHECK_CATALOG_ALARM EXPAND=FALSE

  PROCEDURE [XREF] pfp$check_catalog_alarm
    (    global_file_name: ost$binary_unique_name;
     VAR catalog_alarm_set: boolean;
     VAR delete_on_last_detach: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
?? POP ??

*DECK DECK=PFP$CHECK_CYCLE_BUSY EXPAND=FALSE
  PROCEDURE [XREF] pfp$check_cycle_busy
    (    path: pft$complete_path;
         usage_intentions: pft$permit_selections;
         share_intentions: pft$share_selections;
         mainframe_id: pmt$binary_mainframe_id;
         p_catalog_file: {input^} ^pft$catalog_file;
         cycle_entry: pft$cycle_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$complete_path
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc pfd$share_selector
*copyc pfd$usage_selector
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=PFP$CHECK_DEVICE_AVAILABILITY EXPAND=FALSE
  PROCEDURE [XREF] pfp$check_device_availability
    (    apfid: pft$attached_permanent_file_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dfe$error_condition_codes
*copyc ost$status
*copyc pfd$attached_permanent_file_id
?? POP ??
*DECK DECK=PFP$CHECK_FOR_STALE_CYCLE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$check_for_stale_cycle_entry
    (    cycle_entry: pft$cycle_entry;
     VAR stale_cycle_entry: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$CHECK_GROUP_BY_PERMIT_LEVEL EXPAND=FALSE

  PROCEDURE [XREF] pfp$check_group_by_permit_level
    (    permit_level: pft$permit_level;
         group: pft$group;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pft$permit_level
?? POP ??
*DECK DECK=PFP$CLEAR_CATALOG_ALARM EXPAND=FALSE
  PROCEDURE [XREF] pfp$clear_catalog_alarm
    (    global_file_name: ost$binary_unique_name);

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
?? POP ??
*DECK DECK=PFP$CLEAR_CYCLE_ATTACHMENTS EXPAND=FALSE

  PROCEDURE [XREF] pfp$clear_cycle_attachments
    (    p_path: ^pft$complete_path;
         p_catalog_file: {i^/o^} ^pft$catalog_file;
         p_physical_cycle: {i^/o^} ^pft$physical_cycle);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
*copyc pfd$complete_path
?? POP ??
*DECK DECK=PFP$CLEAR_SYSTEM_AUTHORITY EXPAND=FALSE

  PROCEDURE [INLINE] pfp$clear_system_authority;

?? PUSH (LISTEXT := ON) ??

    pfv$system_authority := 0;
  PROCEND pfp$clear_system_authority;

*copyc pfv$system_authority
?? POP ??
*DECK DECK=PFP$COLLECT_FILE_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] pfp$collect_file_information (
        path: pft$path;
        file_selections: pft$file_selections;
    VAR selection_id: pft$selection_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfd$information_selections
*copyc pfe$error_condition_codes
*copyc pfe$selection_errors
?? POP ??
*DECK DECK=PFP$COMPLETE_JOB_RECOVERY EXPAND=FALSE

  PROCEDURE [XREF] pfp$complete_job_recovery
    (    mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
*copyc ost$status
?? POP ??

*DECK DECK=PFP$COMPUTE_CHECKSUM EXPAND=FALSE

  PROCEDURE [XREF] pfp$compute_checksum
    (    checksum_location: pft$checksum_location;
         checksum_size: pft$checksum_size;
     VAR checksum: pft$checksum);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$CONSTRUCT_VOLUME_LIST EXPAND=TRUE
*DECK DECK=PFP$CONTRACT_OBJECT_LIST EXPAND=FALSE
*DECK DECK=PFP$CONVERT_ARCHIVE_IDENT EXPAND=FALSE

  PROCEDURE [INLINE] pfp$convert_archive_ident
    (    archive_identification: pft$archive_identification;
     VAR converted_archive_ident: pft$archive_identification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    status.normal := TRUE;
    converted_archive_ident := archive_identification;

    IF archive_identification.application_identifier <> osc$null_name THEN
      clp$validate_name (archive_identification.application_identifier,
            converted_archive_ident.application_identifier, status.normal);
      IF NOT status.normal THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_archive_identification,
              archive_identification.application_identifier, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      IF archive_identification.media_identifier.media_device_class <> osc$null_name THEN
        clp$validate_name (archive_identification.media_identifier.media_device_class,
              converted_archive_ident.media_identifier.media_device_class, status.normal);
        IF NOT status.normal THEN
          osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$bad_archive_identification,
                archive_identification.media_identifier.media_device_class, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND pfp$convert_archive_ident;

*copyc clp$validate_name
*copyc pfd$catalog
*copyc pfe$error_condition_codes
*copyc osp$set_status_abnormal
?? POP ??

*DECK DECK=PFP$CONVERT_CYCLE_PATH_TO_STRNG EXPAND=FALSE
 PROCEDURE [XREF] pfp$convert_cycle_path_to_strng (path: pft$complete_path;
        cycle_number: pft$cycle_number;
    VAR path_string: ost$string);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
*copyc ost$string
?? POP ??
*DECK DECK=PFP$CONVERT_DENSITY_TO_DM EXPAND=FALSE

  PROCEDURE [INLINE] pfp$convert_density_to_dm
    (    rm_density: rmt$density;
     VAR dm_density: dmt$stored_tape_density);

?? PUSH (LISTEXT := ON) ??

    CASE rm_density OF
    = rmc$800 =
      dm_density := dmc$stored_density_800;
    = rmc$1600 =
      dm_density := dmc$stored_density_1600;
    = rmc$6250 =
      dm_density := dmc$stored_density_6250;
    = rmc$38000 =
      dm_density := dmc$stored_density_38000;
    ELSE
      dm_density := dmc$stored_density_6250;
    CASEND;

  PROCEND pfp$convert_density_to_dm;

*copyc dmt$stored_tape_density
*copyc rmt$density
?? POP ??
*DECK DECK=PFP$CONVERT_DENSITY_TO_RM EXPAND=FALSE

  PROCEDURE [INLINE] pfp$convert_density_to_rm
    (    dm_density: dmt$stored_tape_density;
     VAR rm_density: rmt$density);

?? PUSH (LISTEXT := ON) ??

    CASE dm_density OF
    = dmc$stored_density_800 =
      rm_density := rmc$800;
    = dmc$stored_density_1600 =
      rm_density := rmc$1600;
    = dmc$stored_density_6250 =
      rm_density := rmc$6250;
    = dmc$stored_density_38000 =
      rm_density := rmc$38000;
    ELSE
      rm_density := rmc$6250;
    CASEND;

  PROCEND pfp$convert_density_to_rm;

*copyc dmt$stored_tape_density
*copyc rmt$density
?? POP ??
*DECK DECK=PFP$CONVERT_DEVICE_CLASS_TO_PF EXPAND=FALSE
                                                                                                              
  PROCEDURE [INLINE] pfp$convert_device_class_to_pf                                                           
    (    rm_device_class: rmt$device_class;                                                                   
     VAR pf_device_class: pft$device_class);                                                                  
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
                                                                                                              
    CASE rm_device_class OF                                                                                   
    = rmc$connected_file_device =                                                                             
      pf_device_class := pfc$connected_file_device;                                                           
    = rmc$interstate_link_device =                                                                            
      pf_device_class := pfc$interstate_link_device;                                                          
    = rmc$local_queue_device =                                                                                
      pf_device_class := pfc$local_queue_device;                                                              
    = rmc$log_device =                                                                                        
      pf_device_class := pfc$log_device;                                                                      
    = rmc$magnetic_tape_device =                                                                              
      pf_device_class := pfc$magnetic_tape_device;                                                            
    = rmc$mass_storage_device =                                                                               
      pf_device_class := pfc$mass_storage_device;                                                             
    = rmc$memory_resident_device =                                                                            
      pf_device_class := pfc$memory_resident_device;                                                          
    = rmc$network_device =                                                                                    
      pf_device_class := pfc$network_device;                                                                  
    = rmc$null_device =                                                                                       
      pf_device_class := pfc$null_device;                                                                     
    = rmc$pipeline_device =                                                                                   
      pf_device_class := pfc$pipeline_device;                                                                 
    = rmc$rhfam_device =                                                                                      
      pf_device_class := pfc$rhfam_device;                                                                    
    = rmc$terminal_device =                                                                                   
      pf_device_class := pfc$terminal_device;                                                                 
    ELSE                                                                                                      
      pf_device_class := pfc$mass_storage_device;                                                             
    CASEND;                                                                                                   
                                                                                                              
  PROCEND pfp$convert_device_class_to_pf;                                                                     
                                                                                                              
*copyc pft$device_class                                                                                       
*copyc rmt$device_class                                                                                       
?? POP ??                                                                                                     
*DECK DECK=PFP$CONVERT_DEVICE_CLASS_TO_RM EXPAND=FALSE
                                                                                                              
  PROCEDURE [INLINE] pfp$convert_device_class_to_rm                                                           
    (    pf_device_class: pft$device_class;                                                                   
     VAR rm_device_class: rmt$device_class);                                                                  
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
                                                                                                              
    CASE pf_device_class OF                                                                                   
    = pfc$connected_file_device =                                                                             
      rm_device_class := rmc$connected_file_device;                                                           
    = pfc$interstate_link_device =                                                                            
      rm_device_class := rmc$interstate_link_device;                                                          
    = pfc$local_queue_device =                                                                                
      rm_device_class := rmc$local_queue_device;                                                              
    = pfc$log_device =                                                                                        
      rm_device_class := rmc$log_device;                                                                      
    = pfc$magnetic_tape_device =                                                                              
      rm_device_class := rmc$magnetic_tape_device;                                                            
    = pfc$mass_storage_device =                                                                               
      rm_device_class := rmc$mass_storage_device;                                                             
    = pfc$memory_resident_device =                                                                            
      rm_device_class := rmc$memory_resident_device;                                                          
    = pfc$network_device =                                                                                    
      rm_device_class := rmc$network_device;                                                                  
    = pfc$null_device =                                                                                       
      rm_device_class := rmc$null_device;                                                                     
    = pfc$pipeline_device =                                                                                   
      rm_device_class := rmc$pipeline_device;                                                                 
    = pfc$rhfam_device =                                                                                      
      rm_device_class := rmc$rhfam_device;                                                                    
    = pfc$terminal_device =                                                                                   
      rm_device_class := rmc$terminal_device;                                                                 
    ELSE                                                                                                      
      rm_device_class := rmc$mass_storage_device;                                                             
    CASEND;                                                                                                   
                                                                                                              
  PROCEND pfp$convert_device_class_to_rm;                                                                     
                                                                                                              
*copyc pft$device_class                                                                                       
*copyc rmt$device_class                                                                                       
?? POP ??                                                                                                     
*DECK DECK=PFP$CONVERT_FS_PATH_TO_PF_PATH EXPAND=FALSE

  PROCEDURE [XREF] pfp$convert_fs_path_to_pf_path
    (    fs_path_string: string (fsc$max_path_size);
     VAR pf_path: {input, output} ^pft$path;
         cycle_reference: fst$cycle_reference;
     VAR cycle_selector: clt$cycle_selector;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$cycle_selector
*copyc fsc$max_path_size
*copyc fst$cycle_reference
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$CONVERT_FS_RETENTION_TO_INT EXPAND=FALSE

  PROCEDURE [XREF] pfp$convert_fs_retention_to_int
    (    fs_retention: fst$retention;
     VAR days: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$retention
*copyc ost$status
?? POP ??

*DECK DECK=PFP$CONVERT_FS_TO_COMPLETE_PATH EXPAND=FALSE

  PROCEDURE [XREF] pfp$convert_fs_to_complete_path (
        evaluated_file_reference: fst$evaluated_file_reference;
    VAR p_complete_path: {output^} pft$p_complete_path;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc ost$status
*copyc pfd$complete_path
?? POP ??
*DECK DECK=PFP$CONVERT_FS_TO_PFT$PATH EXPAND=FALSE
  PROCEDURE [XREF] pfp$convert_fs_to_pft$path (
        evaluated_file_reference: fst$evaluated_file_reference;
    VAR path: pft$path);
*copyc fst$evaluated_file_reference
*copyc pfd$permanent_file_definitions
*DECK DECK=PFP$CONVERT_ORD_TO_SHARED_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] pfp$convert_ord_to_shared_queue
    (    shared_queue: pft$shared_queue;
     VAR shared_queue_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc pfe$error_condition_codes
*copyc pft$shared_queue
?? POP ??
*DECK DECK=PFP$CONVERT_PFT$PATH_TO_FS_PATH EXPAND=FALSE

  PROCEDURE [XREF] pfp$convert_pft$path_to_fs_path (pf_path: pft$path;
    VAR fs_path: fst$path;
    VAR fs_path_size: fst$path_size);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
*copyc fst$path
*copyc fst$path_size
?? POP ??
*DECK DECK=PFP$CONVERT_PFT$PATH_TO_FS_STR EXPAND=FALSE
 PROCEDURE [XREF] pfp$convert_pft$path_to_fs_str (path: pft$path;
    VAR evaluated_file_reference: fst$evaluated_file_reference);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
*copyc fst$evaluated_file_reference
?? POP ??
*DECK DECK=PFP$CONVERT_PFT$PATH_TO_STRING EXPAND=FALSE
  PROCEDURE [XREF] pfp$convert_pft$path_to_string (
        path: pft$path;
    VAR path_name: ost$string);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STRING
*copyc PFD$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$CONVERT_PF_CY_PATH_TO_STRNG EXPAND=FALSE

  PROCEDURE [XREF] pfp$convert_pf_cy_path_to_strng
    (    path: pft$path;
         cycle_number: pft$cycle_number;
     VAR path_name: ost$string);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
*copyc ost$string
?? POP ??
*DECK DECK=PFP$CONVERT_PF_PATH_TO_FS_PATH EXPAND=FALSE

  PROCEDURE [XREF] pfp$convert_pf_path_to_fs_path (
        pf_path: pft$complete_path;
    VAR fs_path: fst$path;
    VAR fs_path_size: fst$path_size);

?? PUSH (LISTEXT := ON) ??
*copyc fst$path
*copyc fst$path_size
*copyc pfd$complete_path
?? POP ??
*DECK DECK=PFP$CONVERT_PF_TO_FS_STRUCTURE EXPAND=FALSE

  PROCEDURE [XREF] pfp$convert_pf_to_fs_structure (
        complete_path: pft$complete_path;
    VAR evaluated_file_reference: fst$evaluated_file_reference);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc pfd$complete_path
?? POP ??
*DECK DECK=PFP$CONVERT_SHARED_QUEUE_TO_ORD EXPAND=FALSE

  PROCEDURE [XREF] pfp$convert_shared_queue_to_ord
    (    shared_queue_name: ost$name;
     VAR shared_queue: pft$shared_queue;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc pfe$error_condition_codes
*copyc pft$shared_queue
?? POP ??
*DECK DECK=PFP$CONVERT_STRING_TO_FS_PATH EXPAND=FALSE

  PROCEDURE [XREF] pfp$convert_string_to_fs_path
    (    str: string ( * );
     VAR fs_path_string: string (fsc$max_path_size);
     VAR number_of_path_elements: fst$number_of_path_elements;
     VAR cycle_reference: fst$cycle_reference;
     VAR open_position: fst$open_position;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_file_reference
*copyc cle$ecc_lexical
*copyc fsc$max_path_size
*copyc fst$cycle_reference
*copyc fst$number_of_path_elements
*copyc fst$open_position
*copyc ost$status
?? POP ??
*DECK DECK=PFP$COUNT_UNRECONCILED_FILES EXPAND=TRUE
PROCEDURE (hidden) pfp$count_unreconciled_files (
  backup_listing, bl: file = $required
  missing_catalogs, mc: (VAR) integer = $optional
  missing_files, mf: (VAR) integer = $optional
  unavailable_catalogs, uc: (VAR) integer = $optional
  unavailable_files, uf: (VAR) integer = $optional
  status)

"$FORMAT=OFF
  VAR
    mc_text: string = $status_code_string(pfe$catalog_volume_not_online)//'--'
    mf_text: string = $status_code_string(pfe$volume_not_online)//'--'
    uc_text: string = $status_code_string(pfe$catalog_volume_unavailable)//'--'
    uf_text: string = $status_code_string(pfe$volume_unavailable)//'--'
    lines: list 0..$max_list of string 20
  VAREND

"$FORMAT=ON"

  IF $specified(mc) OR $specified(mf) OR $specified(uc) OR $specified(uf) THEN


    get_line variable=lines input=backup_listing

    lines=$select(lines x(3, 7)='--ERROR')

    IF $specified(missing_catalogs) THEN
      missing_catalogs=$size($select(lines x(11, 8)=mc_text))
    IFEND

    IF $specified(missing_files) THEN
      missing_files=$size($select(lines x(11, 9)=mf_text))
    IFEND

    IF $specified(unavailable_catalogs) THEN
      unavailable_catalogs=$size($select(lines x(11, 8)=uc_text))
    IFEND

    IF $specified(unavailable_files) THEN
      unavailable_files=$size($select(lines x(11, 9)=uf_text))
    IFEND
  ELSE
    EXIT_PROC WITH $status(false, 'US', 3330, ..
          'At least one VAR parameter must be specified')
  IFEND
PROCEND pfp$count_unreconciled_files


*DECK DECK=PFP$CREATE_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$create_catalog
    (    catalog_path: pft$complete_path;
         p_mass_storage_request_info: ^fmt$mass_storage_request_info;
         authority: pft$authority;
         lock_catalog: boolean;
     VAR new_catalog_locator: pft$catalog_locator;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$mass_storage_request_info
*copyc ost$status
*copyc pfd$authority
*copyc pfd$catalog_locator
*copyc pfd$complete_path
?? POP ??
*DECK DECK=PFP$CREATE_CATALOG_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] pfp$create_catalog_object
    (    path: pft$complete_path;
         authority: pft$authority;
         catalog_type: pft$catalog_types;
         parent_charge_id: pft$charge_id;
         charge_id: pft$charge_id;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
         p_parent_catalog_file: {i^/o^} ^pft$catalog_file;
         p_catalog_object: {output^} ^pft$physical_object;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$mass_storage_request_info
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$charge_id
*copyc pfd$complete_path
?? POP ??
*DECK DECK=PFP$CREATE_FILE_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] pfp$create_file_object (
        file_name: pft$name;
        authority: pft$authority;
        parent_charge_id: pft$charge_id;
        password: pft$password;
        log: pft$log;
    VAR object_entry: pft$object_entry);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$authority
*copyc pfd$catalog
*copyc pfd$charge_id
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$CREATE_PERMANENT_FILE EXPAND=FALSE

  PROCEDURE [XREF] pfp$create_permanent_file
    (    family_location: pft$family_location;
         lfn: amt$local_file_name;
         path: pft$complete_path;
         cycle_number: pft$cycle_number;
         apft_index: pft$attached_pf_table_index;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
         application_info: pft$application_info;
         validation_ring: ost$valid_ring;
         password_protected: boolean;
         enable_media_damage_detection: boolean;
         implicit_attach: boolean;
         recreate_attached_cycle_data: boolean;
         p_file_label: {input} fmt$p_file_label;
         device_class: rmt$device_class;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
         p_removable_media_req_info: {input} ^fmt$removable_media_req_info;
         p_volume_list: {input} ^rmt$volume_list;
         authority: pft$authority;
     VAR path_handle: fmt$path_handle;
     VAR system_file_id: gft$system_file_identifier;
     VAR internal_cycle_name: pft$internal_name;
     VAR bytes_allocated: amt$file_byte_address;
     VAR p_file_server_buffers: {server only: i^/o^} pft$p_file_server_buffers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dft$command_buffer
*copyc fmt$file_label
*copyc fmt$mass_storage_request_info
*copyc fmt$removable_media_req_info
*copyc fmt$path_handle
*copyc gft$system_file_identifier
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$attached_permanent_file_id
*copyc pfd$authority
*copyc pfd$complete_path
*copyc pfd$internal_name
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pft$server_file_output
*copyc rme$request_mass_storage
*copyc rmt$device_class
*copyc rmt$volume_list
?? POP ??
*DECK DECK=PFP$CREATE_ROOT_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$create_root_catalog {PFXCRC} (set_name: stt$set_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STD$SET_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=PFP$CREATE_SCRATCH_SEGMENTS EXPAND=TRUE
?? PUSH (LISTEXT := ON) ??
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
?? POP ??

?? NEWTITLE := 'pfp$create_scratch_segments', EJECT ??

{ PURPOSE
{   This procedure creates the scratch segments used for holding object information, project information, and
{   limit information.

    PROCEDURE pfp$create_scratch_segments
      (VAR object_segment_pointer: amt$segment_pointer;
       VAR project_segment_pointer: amt$segment_pointer;
       VAR limit_segment_pointer: amt$segment_pointer;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, object_segment_pointer, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, project_segment_pointer, status);
      IF NOT status.normal THEN
        mmp$delete_scratch_segment (object_segment_pointer, ignore_status);
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, limit_segment_pointer, status);
      IF NOT status.normal THEN
        mmp$delete_scratch_segment (object_segment_pointer, ignore_status);
        mmp$delete_scratch_segment (project_segment_pointer, ignore_status);
      IFEND;

    PROCEND pfp$create_scratch_segments;
?? OLDTITLE ??
*DECK DECK=PFP$CYCLE_ATTACHED_FOR_WRITE EXPAND=FALSE

  FUNCTION [INLINE] pfp$cycle_attached_for_write
    (    p_cycle: ^pft$physical_cycle): boolean;

?? PUSH (LISTEXT := ON) ??

    pfp$cycle_attached_for_write := (p_cycle^.cycle_entry.attach_status.attach_count > 0) AND
          ((p_cycle^.cycle_entry.attach_status.usage_counts [pfc$shorten] > 0) OR
          (p_cycle^.cycle_entry.attach_status.usage_counts [pfc$append] > 0) OR
          (p_cycle^.cycle_entry.attach_status.usage_counts [pfc$modify] > 0));

  FUNCEND pfp$cycle_attached_for_write;

*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$DEFINE EXPAND=FALSE

  PROCEDURE [XREF] pfp$define ALIAS 'pfxdef' (lfn: amt$local_file_name;
    path: pft$path;
    cycle_selector: pft$cycle_selector;
    password: pft$password;
    retention: pft$retention;
    log: pft$log;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc PFE$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=PFP$DEFINE_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$define_catalog
    (    path: pft$path;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
*copyc ost$status
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$DEFINE_DATA EXPAND=FALSE

  PROCEDURE [XREF] pfp$define_data
    (    lfn: amt$local_file_name;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         update_cycle_statistics: boolean;
         password_selector: pft$password_selector;
         p_mass_storage_request_info: ^fmt$mass_storage_request_info;
         p_volume_list: ^array [1 .. * ] of rmt$recorded_vsn;
         purge_cycle_options: pft$purge_cycle_options;
         replace_cycle_data: boolean;
         restore_selections: put$restore_data_selections;
         wait_on_volume: boolean;
     VAR mandated_modification_time: {i/o} pft$mandated_modification_time;
     VAR data_residence: pft$data_residence;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc fmt$mass_storage_request_info
*copyc ost$status
*copyc pfd$mandated_modification_time
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pft$data_residence
*copyc pft$purge_cycle_options
*copyc put$restore_data_selections
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=PFP$DEFINE_MASS_STORAGE_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$define_mass_storage_catalog
    (    catalog: pft$path;
         catalog_type: pft$catalog_types;
         p_mass_storage_request_info: {i} ^fmt$mass_storage_request_info;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc fmt$mass_storage_request_info
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pft$catalog_types
*copyc rmc$condition_code_limits
*copyc rme$request_mass_storage
?? POP ??
*DECK DECK=PFP$DEFINE_MASTER_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$define_master_catalog (
        set_name: stt$set_name;
        family_name: pft$name;
        master_catalog_name: pft$name;
        charge_id: pft$charge_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CHARGE_ID
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PFE$ERROR_CONDITION_CODES
*copyc PFE$INTERNAL_ERROR_CONDITIONS
*copyc STD$SET_NAME
?? POP ??
*DECK DECK=PFP$DELETE_ALL_ARCHIVE_ENTRIES EXPAND=FALSE

  PROCEDURE [XREF] pfp$delete_all_archive_entries
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
?? POP ??
*DECK DECK=PFP$DELETE_ARCHIVE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$delete_archive_entry
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$archive_definitions
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
?? POP ??
*DECK DECK=PFP$DELETE_CATALOG_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] pfp$delete_catalog_object
    (    path: pft$complete_path;
         delete_option: pft$delete_option;
     VAR p_catalog_object: {i^/o^} ^pft$physical_object;
     VAR parent_catalog_locator: {i/o} pft$catalog_locator;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$catalog_locator
*copyc pfd$complete_path
*copyc pft$delete_option
?? POP ??
*DECK DECK=PFP$DELETE_CATALOG_PERMIT EXPAND=FALSE

  PROCEDURE [XREF] pfp$delete_catalog_permit ALIAS 'pfxdcp' (path: pft$path;
    group: pft$group;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc OST$STATUS
*copyc PFE$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=PFP$DELETE_CYCLE_DATA EXPAND=TRUE

  PROCEDURE [XREF] pfp$delete_cycle_data
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         purge_cycle_options: pft$purge_cycle_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pft$purge_cycle_options
?? POP ??
*DECK DECK=PFP$DELETE_FILE_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] pfp$delete_file_object
    (    p_path: ^pft$complete_path;
         p_catalog_file: {i^/o^} pft$p_catalog_file;
     VAR p_file_object: {i^/o^} pft$p_object;
     VAR object_list_descriptor: {i/o} pft$object_list_descriptor;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$catalog_locator
*copyc pfd$complete_path
?? POP ??
*DECK DECK=PFP$DELETE_PERMIT EXPAND=FALSE

  PROCEDURE [XREF] pfp$delete_permit ALIAS 'pfxdp' (
        path: pft$path;
        group: pft$group;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PFE$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=PFP$DESTROY_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$destroy_catalog (
    VAR catalog_locator: pft$catalog_locator;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_LOCATOR
?? POP ??
*DECK DECK=PFP$DETACH_ALL_CATALOGS EXPAND=FALSE

  PROCEDURE [XREF] pfp$detach_all_catalogs;

*DECK DECK=PFP$DETACH_ALL_FILES EXPAND=TRUE

  PROCEDURE [XREF] pfp$detach_all_files
    (    files_binary_mainframe_id: pmt$binary_mainframe_id;
     VAR return_files_option: pft$return_files_option);

?? PUSH (LISTEXT := ON) ??
*copyc pft$return_files_option
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=PFP$DETACH_JOBS_CATALOGS EXPAND=FALSE
 PROCEDURE [XREF] pfp$detach_jobs_catalogs;
*DECK DECK=PFP$DETACH_PERMANENT_FILE EXPAND=FALSE

  PROCEDURE [XREF] pfp$detach_permanent_file
    (    p_path: ^pft$complete_path;
         system_file_id: gft$system_file_identifier;
         usage_selections: pft$usage_selections;
         catalog_update_allowed: boolean;
         p_cycle: pft$p_cycle;
         p_catalog_file: pft$p_catalog_file;
     VAR fmd_modified: boolean;
     VAR file_info: dmt$file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$file_information
*copyc gft$system_file_identifier
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$complete_path
*copyc pfd$permanent_file_attributes
?? POP ??
*DECK DECK=PFP$DETACH_QUEUED_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$detach_queued_catalog
    (    internal_catalog_name: pft$internal_catalog_name;
     VAR catalog_locator: {i/o} pft$catalog_locator);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_locator
*copyc pfd$internal_name
?? POP ??
*DECK DECK=PFP$DETACH_RESERVED_CYCLES EXPAND=FALSE

  PROCEDURE [XREF] pfp$detach_reserved_cycles
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PFP$DETACH_UNAVAIL_QUEUED_CAT EXPAND=FALSE

  PROCEDURE [INLINE] pfp$detach_unavail_queued_cat
    (    internal_catalog_name: pft$internal_catalog_name;
     VAR catalog_locator: {i/o} pft$catalog_locator);

?? PUSH (LISTEXT := ON) ??

    { This procedure is based on detach_catalog (pfm$file_system_interfaces).

    IF (NOT catalog_locator.new_catalog) AND
          catalog_locator.queuing_info.attach_queued AND
          (NOT catalog_locator.queuing_info.set_catalog_alarm) AND
          (pfv$p_p_newest_queued_catalog^ <> NIL) THEN
      pfp$detach_queued_catalog (internal_catalog_name, catalog_locator);
    IFEND;
  PROCEND pfp$detach_unavail_queued_cat;

*copyc pfp$detach_queued_catalog
*copyc pfv$p_p_newest_queued_catalog
?? POP ??
*DECK DECK=PFP$DETERMINE_NEW_CYCLE_NUMBER EXPAND=FALSE

  PROCEDURE [XREF] pfp$determine_new_cycle_number (
        path: pft$complete_path;
        p_cycle_list: pft$p_cycle_list;
        cycle_selector: pft$cycle_selector;
    VAR new_cycle_number: pft$cycle_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG
*copyc PFD$COMPLETE_PATH
*copyc PFD$PERMANENT_FILE_DEFINITIONS
?? POP ??
*DECK DECK=PFP$DISPLAY_ALL_CATALOGS EXPAND=FALSE
 PROCEDURE [XREF] pfp$display_all_catalogs;
*DECK DECK=PFP$DISPLAY_MASTER_CATALOG EXPAND=FALSE
 PROCEDURE [XREF] pfp$display_master_catalog;
*DECK DECK=PFP$DISPLAY_MEMORY_TO_LOG EXPAND=FALSE

PROCEDURE [XREF] pfp$display_memory_to_log
  (    address: ^cell;
       bytes: ost$segment_length);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
?? POP ??
*DECK DECK=PFP$DISPLAY_UNRECONCILED_FILES EXPAND=TRUE
PROCEDURE (hidden) pfp$display_unreconciled_files (
  backup_listing, bl: file = $required
  output, o: file = $output
  status)

"$FORMAT=OFF
  VAR
    mc_text: string = $status_code_string(pfe$catalog_volume_not_online)//'--'
    mf_text: string = $status_code_string(pfe$volume_not_online)//'--'
    lines: list 0..$max_list of string
  VAREND

"$FORMAT=ON"

  get_line variable=lines input=backup_listing

  lines=$select($select(lines $size(x)>16) x(3, 7)='--ERROR')

  put_lines $select(lines x(11, 8)=mc_text) o=output
  put_lines $select(lines x(11, 9)=mf_text) o=output.$eoi

PROCEND pfp$display_unreconciled_files


*DECK DECK=PFP$DM_ATTACH_ITEM EXPAND=TRUE

  PROCEDURE [XREF] pfp$dm_attach_item
    (   path: pft$path;
        cycle_selector: pft$cycle_selector;
    VAR sfid: dmt$system_file_id;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
*copyc dmt$system_file_id
*copyc ost$status
?? POP ??
*DECK DECK=PFP$DM_CREATE_FILE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$dm_create_file_entry
    (    path: pft$complete_path;
         cycle_number: pft$cycle_number;
         authority: pft$authority;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
     VAR system_file_id: gft$system_file_identifier;
     VAR global_file_name: ost$binary_unique_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$mass_storage_request_info
*copyc gft$system_file_identifier
*copyc ost$status
*copyc pfd$authority
*copyc pfd$complete_path
*copyc pfd$internal_name
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc rme$request_mass_storage
?? POP ??
*DECK DECK=PFP$DM_RETURN_ITEM EXPAND=TRUE
  PROCEDURE [XREF] pfp$dm_return_item
    (    sfid: gft$system_file_identifier;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=PFP$END_SYSTEM_AUTHORITY EXPAND=FALSE

  PROCEDURE [INLINE] pfp$end_system_authority;

?? PUSH (LISTEXT := ON) ??

    pfv$system_authority := pfv$system_authority - 1;
  PROCEND pfp$end_system_authority;

*copyc pfv$system_authority
?? POP ??
*DECK DECK=PFP$ESTABLISH_FREE_CYCLE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$establish_free_cycle_entry (
        p_catalog_heap: pft$p_catalog_heap;
    VAR p_cycle_list: pft$p_cycle_list;
    VAR p_new_cycle_list: pft$p_cycle_list;
    VAR new_cycle_list: boolean;
    VAR p_cycle: pft$p_cycle;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG
?? POP ??
*DECK DECK=PFP$ESTABLISH_FREE_OBJECT_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$establish_free_object_entry
    (    p_path: ^pft$complete_path;
         p_catalog_file: {output} ^pft$catalog_file;
     VAR object_list_descriptor: {i/o} pft$object_list_descriptor;
     VAR p_object: {output} ^pft$physical_object;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$catalog_locator
*copyc pfd$complete_path
?? POP ??
*DECK DECK=PFP$EXTRACT_PERMIT_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$extract_permit_entry (
        p_permit_list: pft$p_permit_list;
        authority: pft$authority;
    VAR permit_entry: pft$permit_entry);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$AUTHORITY
*copyc PFD$CATALOG
?? POP ??
*DECK DECK=PFP$FIND_ARCHIVE_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$find_archive_info
    (    p_info_record: pft$p_info_record;
     VAR p_archive_info: pft$p_info_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
?? POP ??
*DECK DECK=PFP$FIND_CATALOG_DESCRIPTION EXPAND=FALSE

  PROCEDURE [XREF] pfp$find_catalog_description (
        p_info_record: pft$p_info_record;
    VAR p_catalog_description: pft$p_catalog_description;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_INFO
*copyc PFE$ERROR_CONDITION_CODES
*copyc PFE$INTERNAL_ERROR_CONDITIONS
?? POP ??
*DECK DECK=PFP$FIND_CATALOG_MEDIA EXPAND=FALSE
  PROCEDURE [XREF] pfp$find_catalog_media
    (    p_info_record: pft$p_info_record;
     VAR p_catalog_media_description: pft$p_catalog_media_description;
     VAR p_catalog_fmd: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_info
*copyc pft$catalog_media_description
*copyc ost$status
?? POP ??
*DECK DECK=PFP$FIND_CYCLE_ARRAY EXPAND=FALSE

  PROCEDURE [XREF] pfp$find_cycle_array
    (    p_info_record: pft$p_info_record;
     VAR p_cycle_array: pft$p_cycle_array;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
?? POP ??
*DECK DECK=PFP$FIND_CYCLE_ARRAY_EXTENDED EXPAND=FALSE

  PROCEDURE [XREF] pfp$find_cycle_array_extended
    (    p_file_group_info_record: pft$p_info_record;
     VAR p_cycle_array_extended_record: pft$p_info_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_info
*copyc ost$status
?? POP ??
*DECK DECK=PFP$FIND_CYCLE_ARRAY_VERSION_2 EXPAND=FALSE
                                                                                                              
  PROCEDURE [XREF] pfp$find_cycle_array_version_2                                                             
    (    p_info_record: pft$p_info_record;                                                                    
     VAR p_cycle_array: ^pft$cycle_array_version_2;                                                           
     VAR status: ost$status);                                                                                 
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc ost$status                                                                                             
*copyc pfd$catalog_info                                                                                       
*copyc pfe$error_condition_codes                                                                              
*copyc pfe$external_archive_conditions                                                                        
?? POP ??                                                                                                     
*DECK DECK=PFP$FIND_CYCLE_DIRECTORY EXPAND=FALSE
  PROCEDURE [XREF] pfp$find_cycle_directory
    (    p_cycle_array_extended_record: pft$p_info_record;
     VAR p_cycle_directory_array: pft$p_cycle_directory_array;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_info
*copyc ost$status
?? POP ??
*DECK DECK=PFP$FIND_CYCLE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$find_cycle_entry (
        p_cycle_array: pft$p_cycle_array;
        cycle_selector: pft$cycle_selector;
    VAR cycle_index: pft$array_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_INFO
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PFE$ERROR_CONDITION_CODES
*copyc PFE$INTERNAL_ERROR_CONDITIONS
?? POP ??
*DECK DECK=PFP$FIND_CYCLE_ENTRY_VERSION_2 EXPAND=FALSE
                                                                                                              
  PROCEDURE [XREF] pfp$find_cycle_entry_version_2                                                             
    (    p_cycle_array: ^pft$cycle_array_version_2;                                                           
         cycle_selector: pft$cycle_selector;                                                                  
     VAR cycle_index: pft$array_index;                                                                        
     VAR status: ost$status);                                                                                 
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc ost$status                                                                                             
*copyc pfd$catalog_info                                                                                       
*copyc pfd$permanent_file_definitions                                                                         
*copyc pfe$error_condition_codes                                                                              
*copyc pfe$external_archive_conditions                                                                        
*copyc pfe$internal_error_conditions                                                                          
?? POP ??                                                                                                     
*DECK DECK=PFP$FIND_CYCLE_LABEL EXPAND=FALSE
  PROCEDURE [XREF] pfp$find_cycle_label
    (    p_cycle_info_record: pft$p_info_record;
     VAR p_cycle_label: ^ SEQ (*);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_info
*copyc ost$status
?? POP ??
*DECK DECK=PFP$FIND_CYCLE_MEDIA EXPAND=FALSE
  PROCEDURE [XREF] pfp$find_cycle_media
    (    p_cycle_info_record: pft$p_info_record;
     VAR p_cycle_media_description: pft$p_file_media_description;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_info
*copyc pft$file_media_description
*copyc ost$status
?? POP ??
*DECK DECK=PFP$FIND_DIRECTORY_ARRAY EXPAND=FALSE

  PROCEDURE [XREF] pfp$find_directory_array (
        p_info_record: pft$p_info_record;
    VAR p_directory_array: pft$p_directory_array;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_INFO
*copyc PFE$ERROR_CONDITION_CODES
*copyc PFE$INTERNAL_ERROR_CONDITIONS
?? POP ??
*DECK DECK=PFP$FIND_DIRECT_INFO_RECORD EXPAND=FALSE

  PROCEDURE [XREF] pfp$find_direct_info_record (
        p_info: pft$p_info;
        info_offset: pft$info_offset;
    VAR p_info_record: pft$p_info_record;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_INFO
*copyc PFE$ERROR_CONDITION_CODES
*copyc PFE$INTERNAL_ERROR_CONDITIONS
?? POP ??
*DECK DECK=PFP$FIND_FILE_DESCRIPTION EXPAND=FALSE

  PROCEDURE [XREF] pfp$find_file_description (
        p_info_record: pft$p_info_record;
    VAR p_file_description: pft$p_file_description;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_INFO
*copyc PFE$ERROR_CONDITION_CODES
*copyc PFE$INTERNAL_ERROR_CONDITIONS
?? POP ??
*DECK DECK=PFP$FIND_LOG_ARRAY EXPAND=FALSE

  PROCEDURE [XREF] pfp$find_log_array (
        p_info_record: pft$p_info_record;
    VAR p_log_array: pft$p_log_array;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_INFO
*copyc PFE$ERROR_CONDITION_CODES
*copyc PFE$INTERNAL_ERROR_CONDITIONS
?? POP ??
*DECK DECK=PFP$FIND_NEXT_ARCHIVE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$find_next_archive_entry
    (    archive_identification: pft$archive_identification;
     VAR p_info: pft$p_info;
     VAR p_info_record: pft$p_info_record;
     VAR p_archive_array_entry: pft$p_archive_array_entry;
     VAR p_amd: pft$p_amd;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
?? POP ??
*DECK DECK=PFP$FIND_NEXT_INFO_RECORD EXPAND=FALSE

  PROCEDURE [XREF] pfp$find_next_info_record
    (VAR p_info: pft$p_info;
     VAR p_info_record: pft$p_info_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
?? POP ??
*DECK DECK=PFP$FIND_PERMIT_ARRAY EXPAND=FALSE

  PROCEDURE [XREF] pfp$find_permit_array (
        p_info_record: pft$p_info_record;
    VAR p_permit_array: pft$p_permit_array;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_INFO
*copyc PFE$ERROR_CONDITION_CODES
*copyc PFE$INTERNAL_ERROR_CONDITIONS
?? POP ??
*DECK DECK=PFP$FORM_ADMINISTRATOR_PERMIT EXPAND=TRUE

  PROCEDURE [INLINE] pfp$form_administrator_permit
    (    authority: pft$authority;
     VAR permit_entry: pft$permit_entry);

?? PUSH (LISTEXT := ON) ??

    IF authority.ownership *
          $pft$ownership [pfc$system_owner, pfc$set_owner, pfc$family_owner] <>
          $pft$ownership [] THEN
      IF permit_entry.entry_type = pfc$free_permit_entry THEN
        permit_entry.entry_type := pfc$normal_permit_entry;
        permit_entry.group.group_type := pfc$user;
        permit_entry.group.user_description.family := authority.family;
        permit_entry.group.user_description.user := authority.user;
        permit_entry.usage_permissions := - $pft$permit_selections [];
        permit_entry.share_requirements := $pft$share_selections [];
        permit_entry.application_info := osc$null_name;
      ELSE
        permit_entry.group.group_type := pfc$user;
        permit_entry.group.user_description.family := authority.family;
        permit_entry.group.user_description.user := authority.user;
        permit_entry.usage_permissions := - $pft$permit_selections [];
        permit_entry.share_requirements := $pft$share_selections [];
      IFEND;
    IFEND;
  PROCEND pfp$form_administrator_permit;

*copyc pfd$authority
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$GET_ALLOWED_DEVICE_CLASSES EXPAND=FALSE

  PROCEDURE [INLINE] pfp$get_allowed_device_classes
    (    p_attachment_options: {input} ^fst$attachment_options;
     VAR allowed_device_classes: fst$device_classes);

?? PUSH (LISTEXT := ON) ??

    VAR
      options_index: ost$positive_integers;

    allowed_device_classes :=  - $fst$device_classes [];

    IF p_attachment_options <> NIL THEN
      FOR options_index := 1 TO UPPERBOUND (p_attachment_options^) DO
        IF p_attachment_options^ [options_index].selector = fsc$allowed_device_classes THEN
          allowed_device_classes := p_attachment_options^ [options_index].allowed_device_classes;
        IFEND;
      FOREND;
    IFEND;

  PROCEND pfp$get_allowed_device_classes;

*copyc fst$attachment_options
*copyc fst$device_classes
*copyc osd$integer_limits
?? POP ??
*DECK DECK=PFP$GET_ATTACHED_DEVICE_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$get_attached_device_info
    (    temporary_file: boolean;
         served_family: boolean;
         served_family_locator: ^pft$served_family_locator,
         p_cycle_description: {input^} ^fmt$cycle_description;
         p_object: {output^} ^fst$goi_object;
     VAR p_object_information: ^SEQ ( * );
     VAR eoi: amt$file_byte_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc fmt$cycle_description
*copyc fst$goi_object
*copyc ost$status
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$GET_ATTACHED_PF_TABLE EXPAND=FALSE
  PROCEDURE [XREF] pfp$get_attached_pf_table (VAR p_table_info: pft$p_table_info;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$table_info
*copyc ost$status
?? POP ??
*DECK DECK=PFP$GET_AUTHORITY EXPAND=FALSE

  PROCEDURE [XREF] pfp$get_authority (
        path: pft$complete_path;
        system_privilege: boolean;
    VAR authority: pft$authority;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$AUTHORITY
*copyc PFD$COMPLETE_PATH
?? POP ??
*DECK DECK=PFP$GET_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$get_catalog (
        path: pft$complete_path;
        access_kind: pft$access_kind;
        authority: pft$authority;
    VAR internal_path: pft$internal_path;
    VAR charge_id: pft$charge_id;
    VAR permit_entry: pft$permit_entry;
    VAR catalog_locator: pft$catalog_locator;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$authority
*copyc pfd$catalog
*copyc pfd$catalog_locator
*copyc pfd$charge_id
*copyc pfd$complete_path
?? POP ??
*DECK DECK=PFP$GET_CATALOG_ALARM_TABLE EXPAND=FALSE
  PROCEDURE [XREF] pfp$get_catalog_alarm_table (VAR p_table_info: pft$p_table_info;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$table_info
*copyc ost$status
?? POP ??
*DECK DECK=PFP$GET_CATALOG_SEGMENT EXPAND=FALSE
procedure [xref] pfp$get_catalog_segment (path: pft$path;
 var p_info: pft$p_table_info;
 var status: ost$status);
?? PUSH (LISTEXT := on) ??
*copyc pfd$permanent_file_definitions
*copyc pfd$table_info
*copyc ost$status
?? pop ??
*DECK DECK=PFP$GET_CYCLE_DAMAGE_OPTIONS EXPAND=FALSE

  PROCEDURE [INLINE] pfp$get_cycle_damage_options
    (    p_attachment_options: {input} ^fst$attachment_options;
     VAR media_damage_detection_enabled: boolean;
     VAR allowed_cycle_damage_symptoms: fst$cycle_damage_symptoms);

?? PUSH (LISTEXT := ON) ??
    VAR
      options_index: ost$positive_integers;

    media_damage_detection_enabled := FALSE;
    allowed_cycle_damage_symptoms := $fst$cycle_damage_symptoms [];

    IF p_attachment_options <> NIL THEN
      FOR options_index := 1 TO UPPERBOUND (p_attachment_options^) DO
        IF p_attachment_options^ [options_index].selector = fsc$exception_detection THEN
          media_damage_detection_enabled := (fsc$media_image_inconsistent IN
                p_attachment_options^ [options_index].exception_detection);
        IFEND;

        IF p_attachment_options^ [options_index].selector = fsc$allowed_exceptions THEN
          allowed_cycle_damage_symptoms := p_attachment_options^ [options_index].allowed_exceptions.
                damage_symptoms;
        IFEND;
      FOREND;
    IFEND;

  PROCEND pfp$get_cycle_damage_options;

*copyc fst$attachment_options
*copyc fst$cycle_damage_symptoms
*copyc osd$integer_limits
?? POP ??
*DECK DECK=PFP$GET_EVAL_FILE_REF_MAST_CAT EXPAND=FALSE

  PROCEDURE [INLINE] pfp$get_eval_file_ref_mast_cat
    (    evaluated_file_reference: fst$evaluated_file_reference;
     VAR master_catalog_name: pft$name);

?? PUSH (LISTEXT := ON) ??

    VAR
      family_name_size: fst$path_element_size;

    family_name_size := $INTEGER (evaluated_file_reference.path_structure (1));

    master_catalog_name :=
          evaluated_file_reference.path_structure (family_name_size + 3,
          $INTEGER (evaluated_file_reference.path_structure (family_name_size +
          2)));
  PROCEND pfp$get_eval_file_ref_mast_cat;

*copyc fst$evaluated_file_reference
*copyc fst$path_element_size
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$GET_FAMILIES_IN_SET EXPAND=FALSE
  PROCEDURE [XREF] pfp$get_families_in_set
    (    set_name: ost$name;
     VAR family_list: array [1 .. * ] of ost$name;
     VAR number_of_families: 0 .. 255;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=PFP$GET_FAMILY_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$get_family_info (
        set_name: stt$set_name;
        catalog_info_selections: pft$catalog_info_selections;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_INFO
*copyc PFE$ERROR_CONDITION_CODES
*copyc PFE$INTERNAL_ERROR_CONDITIONS
*copyc STD$SET_NAME
?? POP ??
*DECK DECK=PFP$GET_FAMILY_ITEM_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$get_family_item_info (
        family_name: pft$name;
        catalog_info_selections: pft$catalog_info_selections;
    VAR set_name: stt$set_name;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_INFO
*copyc PFE$ERROR_CONDITION_CODES
*copyc PFE$INTERNAL_ERROR_CONDITIONS
*copyc STD$SET_NAME
?? POP ??



*DECK DECK=PFP$GET_FAMILY_SET EXPAND=FALSE
PROCEDURE [XREF] pfp$get_family_set (family_name: ost$name;
    VAR set_name: stt$set_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc std$set_name
*copyc ost$status
?? POP ??
*DECK DECK=PFP$GET_FILE_INFO EXPAND=FALSE
  PROCEDURE [XREF] pfp$get_file_info
    (    segment: ^cell;
     VAR file_info: dmt$file_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$file_information
*copyc ost$status
?? POP ??
*DECK DECK=PFP$GET_ITEM_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$get_item_info (
        path: pft$path;
        group: pft$group;
        catalog_info_selections: pft$catalog_info_selections;
        file_info_selections: pft$file_info_selections;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
?? POP ??
*DECK DECK=PFP$GET_MASTER_CATALOG_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$get_master_catalog_info (
        set_name: stt$set_name;
        family_name: pft$name;
        catalog_info_selections: pft$catalog_info_selections;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_INFO
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PFE$ERROR_CONDITION_CODES
*copyc PFE$INTERNAL_ERROR_CONDITIONS
*copyc STD$SET_NAME
?? POP ??
*DECK DECK=PFP$GET_MULTI_ITEM_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$get_multi_item_info (
        path: pft$path;
        group: pft$group;
        catalog_info_selections: pft$catalog_info_selections;
        file_info_selections: pft$file_info_selections;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_INFO
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PFE$ERROR_CONDITION_CODES
*copyc PFE$INTERNAL_ERROR_CONDITIONS
?? POP ??
*DECK DECK=PFP$GET_NEXT_FILE_SELECTION EXPAND=FALSE

  PROCEDURE [XREF] pfp$get_next_file_selection (
        selection_id: pft$selection_identifier;
    VAR selection_record: pft$selection_record;
    VAR selection_position: pft$selection_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$information_selections
*copyc pfe$error_condition_codes
*copyc pfe$selection_errors
?? POP ??
*DECK DECK=PFP$GET_OBJECT_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] pfp$get_object_information
    (    file_reference: fst$file_reference;
         information_request: fst$goi_information_request;
         p_validation_criteria: {i/o^} ^fst$goi_validation_criteria;
     VAR p_object_information: {i/o} ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc ame$lfn_program_actions
*copyc ame$ring_validation_errors
*copyc fst$file_reference
*copyc fst$goi_information_request
*copyc fst$goi_object_information
*copyc fst$goi_validation_criteria
*copyc ost$status
*copyc pfe$error_condition_codes
*copyc pfe$get_object_info_errors
*copyc pfe$internal_error_conditions
?? POP ??
*DECK DECK=PFP$GET_OWNERSHIP EXPAND=FALSE

  PROCEDURE [XREF] pfp$get_ownership
    (    variant_path: pft$variant_path;
         system_privilege: boolean;
     VAR ownership: pft$ownership;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$authority
*copyc pft$variant_path
*copyc ste$error_condition_codes
?? POP ??
*DECK DECK=PFP$GET_PERMIT_LEVEL EXPAND=FALSE

  PROCEDURE [XREF] pfp$get_permit_level
    (VAR permit_level: pft$permit_level;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pft$permit_level
?? POP ??
*DECK DECK=PFP$GET_QUEUED_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$get_queued_catalog
    (    external_catalog_name: pft$name;
         parent_internal_name: pft$internal_catalog_name;
     VAR catalog_attach_queued: boolean;
     VAR catalog_access_queued: boolean;
     VAR catalog_locator: pft$catalog_locator;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_locator
*copyc pfd$internal_name
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$GET_QUEUED_CATALOG_TABLE EXPAND=FALSE
  PROCEDURE [XREF] pfp$get_queued_catalog_table (VAR p_table_info: pft$p_table_info;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$table_info
*copyc ost$status
?? POP ??
*DECK DECK=PFP$GET_REM_MEDIA_REQ_INFO EXPAND=FALSE
  PROCEDURE [INLINE] pfp$get_rem_media_req_info
    (    p_fmd: {input^} ^pft$fmd;
         p_removable_media_req_info: {output^} ^fmt$removable_media_req_info;
     VAR number_of_volumes: 0 .. amc$max_vol_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      p_stored_tape_fmd: ^dmt$stored_tape_fmd,
      p_stored_tape_fmd_header: ^dmt$stored_tape_fmd_header;

      status.normal := TRUE;

      p_stored_tape_fmd := p_fmd;
      RESET p_stored_tape_fmd;
      NEXT p_stored_tape_fmd_header IN p_stored_tape_fmd;
      IF (p_stored_tape_fmd_header <> NIL) AND
            (p_stored_tape_fmd_header^.version = dmc$stored_tape_fmd_version_1) THEN
        pfp$convert_density_to_rm (p_stored_tape_fmd_header^.density, p_removable_media_req_info^.density);
        p_removable_media_req_info^.removable_media_group := p_stored_tape_fmd_header^.removable_media_group;
        p_removable_media_req_info^.volume_overflow_allowed :=
              p_stored_tape_fmd_header^.volume_overflow_allowed;
        number_of_volumes := p_stored_tape_fmd_header^.volume_count;
      ELSE
        p_removable_media_req_info^.density := rmc$6250;
        p_removable_media_req_info^.removable_media_group := osc$null_name;
        p_removable_media_req_info^.volume_overflow_allowed := TRUE;
        number_of_volumes := 0;
      IFEND;

  PROCEND pfp$get_rem_media_req_info;

*copyc dmt$stored_tape_fmd
*copyc dmt$stored_tape_fmd_header
*copyc dmt$stored_tape_volume_list
*copyc fmt$removable_media_req_info
*copyc pfd$catalog
*copyc pfp$convert_density_to_rm
*copyc rmt$volume_list
*copyc ost$status
?? POP ??
*DECK DECK=PFP$GET_REM_MEDIA_VOLUME_LIST EXPAND=FALSE

  PROCEDURE [INLINE] pfp$get_rem_media_volume_list
    (    p_fmd: {^input} ^pft$fmd;
         p_volume_list: {output^} ^rmt$volume_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      volume_list_index: integer,
      p_stored_tape_fmd: ^dmt$stored_tape_fmd,
      p_stored_tape_fmd_header: ^dmt$stored_tape_fmd_header,
      p_stored_tape_volume_list: ^rmt$volume_list;

    status.normal := TRUE;

    IF (p_volume_list <> NIL) THEN
      p_stored_tape_fmd := p_fmd;
      RESET p_stored_tape_fmd;

      NEXT p_stored_tape_fmd_header IN p_stored_tape_fmd;
      IF (p_stored_tape_fmd_header <> NIL) AND
            (p_stored_tape_fmd_header^.version = dmc$stored_tape_fmd_version_1)
            THEN
        NEXT p_stored_tape_volume_list: [1 .. UPPERBOUND (p_volume_list^)] IN
              p_stored_tape_fmd;
        IF p_stored_tape_volume_list <> NIL THEN
          FOR volume_list_index := 1 TO UPPERBOUND (p_volume_list^) DO
            p_volume_list^ [volume_list_index].external_vsn :=
                  p_stored_tape_volume_list^ [volume_list_index].external_vsn;
            p_volume_list^ [volume_list_index].recorded_vsn :=
                  p_stored_tape_volume_list^ [volume_list_index].recorded_vsn;
          FOREND;
        ELSE
          FOR volume_list_index := 1 TO UPPERBOUND (p_volume_list^) DO
            p_volume_list^ [volume_list_index].external_vsn :=
                  rmc$unspecified_vsn;
            p_volume_list^ [volume_list_index].recorded_vsn :=
                  rmc$unspecified_vsn;
          FOREND;
        IFEND;
      ELSE
        FOR volume_list_index := 1 TO UPPERBOUND (p_volume_list^) DO
          p_volume_list^ [volume_list_index].external_vsn :=
                rmc$unspecified_vsn;
          p_volume_list^ [volume_list_index].recorded_vsn :=
                rmc$unspecified_vsn;
        FOREND;
      IFEND;
    IFEND;

  PROCEND pfp$get_rem_media_volume_list;

*copyc dmt$stored_tape_fmd
*copyc dmt$stored_tape_fmd_header
*copyc dmt$stored_tape_volume_list
*copyc pfd$catalog
*copyc rmt$volume_list
*copyc ost$status
?? POP ??
*DECK DECK=PFP$GET_RESERVED_ITEM_INFO EXPAND=FALSE
  PROCEDURE [XREF] pfp$get_reserved_item_info
    (    path: pft$path;
         group: pft$group;
         catalog_info_selections: pft$catalog_info_selections;
         file_info_selections: pft$file_info_selections;
         p_cycle_reservation_criteria: {input} ^pft$cycle_reservation_criteria;
     VAR p_info: {i/o} pft$p_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pft$cycle_reservation_criteria
?? POP ??
*DECK DECK=PFP$GET_RESTORE_STATUS EXPAND=FALSE
 PROCEDURE [XREF] pfp$get_restore_status
    (VAR restore_missing_catalogs_done: boolean);
*DECK DECK=PFP$GET_ROOT_ATTACHED EXPAND=FALSE
  PROCEDURE [XREF] pfp$get_root_attached (set_name: stt$set_name;
    VAR catalog_locator: pft$catalog_locator;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc std$set_name
*copyc pfd$catalog_locator
*copyc ost$status
?? POP ??
*DECK DECK=PFP$GET_SET_LIST EXPAND=FALSE
  PROCEDURE [XREF] pfp$get_set_list
    (VAR set_list: stt$set_list;
     VAR number_of_sets: stt$number_of_sets;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc STT$SET_LIST
*copyc STD$MISCELLANEOUS
*copyc ost$status
?? POP ??

*DECK DECK=PFP$GET_SORTED_OBJECT_NAME_LIST EXPAND=FALSE
  PROCEDURE [XREF] pfp$get_sorted_object_name_list
    (    object_list_descriptor: pft$object_list_descriptor;
         p_object_name_list: ^pft$object_name_list;
     VAR object_name_count: pft$object_count);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
*copyc pfd$catalog_locator
*copyc pft$object_name_list
?? POP ??
*DECK DECK=PFP$GET_STORED_FMD EXPAND=FALSE

  PROCEDURE [XREF] pfp$get_stored_fmd (
        path: pft$path;
        cycle_selector: pft$cycle_selector;
    VAR catalog: boolean;
    VAR catalog_recreated_by_restore: boolean;
    VAR internal_name: ost$binary_unique_name;
    VAR stored_fmd: dmt$stored_fmd;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$stored_fmd
*copyc osd$unique_name
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$GET_STORED_FMD_SIZE EXPAND=FALSE

  PROCEDURE [XREF] pfp$get_stored_fmd_size
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR device_class: rmt$device_class;
     VAR internal_name: ost$binary_unique_name;
     VAR stored_fmd_size: dmt$stored_fmd_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$stored_fmd_size
*copyc osd$unique_name
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$GET_VOLUMES_IN_SET EXPAND=FALSE
  PROCEDURE [XREF] pfp$get_volumes_in_set
    (    set_name: stt$set_name;
     VAR volume_list: pft$volume_list;
     VAR number_of_volumes: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pft$volume_list
*copyc std$set_name
?? POP ??
*DECK DECK=PFP$GET_VOLUMES_SET_NAME EXPAND=FALSE
  PROCEDURE [XREF] pfp$get_volumes_set_name
    (    volume: rmt$recorded_vsn;
     VAR set_name: stt$set_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$recorded_vsn
*copyc std$set_name
?? POP ??
*DECK DECK=PFP$INCREMENT_USAGE_COUNTS EXPAND=FALSE

  PROCEDURE [XREF] pfp$increment_usage_counts
    (    path: pft$complete_path;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
         mainframe_id: pmt$binary_mainframe_id;
         p_catalog_file: {input, output} ^pft$catalog_file;
     VAR flush_catalog_pages: boolean;
     VAR cycle_entry {input, output} : pft$cycle_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$complete_path
*copyc pfd$permanent_file_attributes
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=PFP$INITIALIZE_JOB_RECOVERY EXPAND=FALSE

  PROCEDURE [XREF] pfp$initialize_job_recovery
    (    file_recovery_state: pft$attached_pf_recovery_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pft$attached_pf_recovery_state
?? POP ??
*DECK DECK=PFP$INITIALIZE_OBJECT_INFO EXPAND=FALSE

  PROCEDURE pfp$initialize_object_info
    (    p_object_info: {output^} ^fst$goi_object_information);

?? PUSH (LISTEXT := ON) ??

    p_object_info^.set_name := osc$null_name;
    p_object_info^.resolved_path := NIL;
    p_object_info^.object := NIL;
  PROCEND pfp$initialize_object_info;

*copyc fst$goi_object_information
*copyc ost$name
?? POP ??
*DECK DECK=PFP$INTERNAL_ACCESS_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] pfp$internal_access_object (
        set_name: stt$set_name;
        internal_path: pft$internal_path;
        access_kind: pft$access_kind;
        authority: pft$authority;
        extract_permits: boolean;
        catalog_remote: boolean;
    VAR p_object: pft$p_object;
    VAR catalog_locator: pft$catalog_locator;
    VAR permit_entry: pft$permit_entry;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$AUTHORITY
*copyc PFD$CATALOG
*copyc PFD$CATALOG_LOCATOR
*copyc PFD$COMPLETE_PATH
*copyc STD$SET_NAME
?? POP ??
*DECK DECK=PFP$INTERNAL_LOCATE_OBJECT EXPAND=FALSE
  PROCEDURE [XREF] pfp$internal_locate_object (p_object_list: pft$p_object_list;
        internal_object_name: pft$internal_name;
    VAR p_object: pft$p_object);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
*copyc pfd$internal_name
?? POP ??
*DECK DECK=PFP$INTERNAL_RETURN_FILE EXPAND=FALSE

  PROCEDURE [XREF] pfp$internal_return_file
    (    attached_pf_table_index: pft$attached_pf_table_index;
         mainframe_id: pmt$binary_mainframe_id;
     VAR authority: pft$authority;
     VAR bytes_allocated_change: sft$counter;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$attached_permanent_file_id
*copyc pfd$authority
*copyc pmt$binary_mainframe_id
*copyc sft$counter
?? POP ??
*DECK DECK=PFP$INTERNAL_SAVE_FILE_LABEL EXPAND=FALSE

  PROCEDURE [XREF] pfp$internal_save_file_label
    (    apfid: pft$attached_permanent_file_id;
         system_authority: pft$system_authority;
         required_permission: pft$permit_options;
         p_file_label: {input} ^fmt$file_label;
     VAR p_save_file_label_audit_seq: {i/o} ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$file_label
*copyc ost$status
*copyc pfd$attached_permanent_file_id
*copyc pfd$permanent_file_attributes
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pft$system_authority
?? POP ??
*DECK DECK=PFP$LOCATE_ATTACHED_FILE EXPAND=FALSE
  PROCEDURE [XREF] pfp$locate_attached_file
    (    internal_cycle_name: pft$internal_name;
     VAR apfid: pft$attached_pf_table_index;
     VAR p_attached_pf_entry: pft$p_attached_pf_entry;
     VAR cycle_found: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc pft$attached_pf_table_index
*copyc pfd$attached_pf_table
*copyc pfd$internal_name
?? POP ??
*DECK DECK=PFP$LOCATE_CYCLE EXPAND=FALSE

  PROCEDURE [XREF] pfp$locate_cycle (
        path: pft$complete_path;
        p_cycle_list: pft$p_cycle_list;
        cycle_selector: pft$cycle_selector;
    VAR p_cycle: pft$p_cycle;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG
*copyc PFD$COMPLETE_PATH
*copyc PFD$PERMANENT_FILE_DEFINITIONS
?? POP ??
*DECK DECK=PFP$LOCATE_GROUP_INFO_RECORD EXPAND=FALSE

  PROCEDURE [XREF] pfp$locate_group_info_record
    (    p_info_record: {input^} ^pft$info_record;
     VAR p_group_info_record: ^pft$info_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfe$internal_error_conditions
?? POP ??
*DECK DECK=PFP$LOCATE_LOG_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$locate_log_entry {PFXLLE} (p_log_list: pft$p_log_list;
        user_id: ost$user_identification;
    VAR p_log_entry: pft$p_log);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$CATALOG
*copyc OST$USER_IDENTIFICATION
?? POP ??
*DECK DECK=PFP$LOCATE_OBJECT EXPAND=FALSE

  PROCEDURE [XREF] pfp$locate_object
    (    object_name: pft$name;
         valid_objects: pft$object_selections;
         object_list_descriptor: pft$object_list_descriptor;
     VAR p_object: {output} ^pft$physical_object);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
*copyc pfd$catalog_locator
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$LOCATE_SPECIFIC_CYCLE EXPAND=FALSE

  PROCEDURE [INLINE] pfp$locate_specific_cycle
    (    p_cycle_list: {input} ^pft$cycle_list;
         cycle_number: pft$cycle_number;
     VAR p_physical_cycle: {output} ^pft$physical_cycle);

?? PUSH (LISTEXT := ON) ??

    VAR
      cycle_index: pft$cycle_index;

    IF p_cycle_list <> NIL THEN
      FOR cycle_index := 1 TO UPPERBOUND (p_cycle_list^) DO
        IF (p_cycle_list^ [cycle_index].cycle_entry.entry_type =
              pfc$normal_cycle_entry) AND
              (p_cycle_list^ [cycle_index].cycle_entry.cycle_number =
              cycle_number) THEN
          p_physical_cycle := ^p_cycle_list^ [cycle_index];
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    p_physical_cycle := NIL;
  PROCEND pfp$locate_specific_cycle;

*copyc pfd$catalog
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$LOCK_APFID EXPAND=FALSE

  PROCEDURE [XREF] pfp$lock_apfid (apfid: pft$attached_pf_table_index;
    VAR p_attached_pf_entry: pft$p_attached_pf_entry;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pft$attached_pf_table_index
*copyc PFD$ATTACHED_PF_TABLE
*copyc OST$STATUS
?? POP ??

*DECK DECK=PFP$LOG_ASCII EXPAND=FALSE

  PROCEDURE [XREF] pfp$log_ascii (
        text: string ( * );
        ascii_logset: pmt$ascii_logset;
        origin: pmt$log_msg_origin;
        critical_message: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmd$system_log_interface
?? POP ??
*DECK DECK=PFP$LOG_ERROR EXPAND=FALSE

  PROCEDURE [XREF] pfp$log_error (
        status: ost$status;
        ascii_logset: pmt$ascii_logset;
        message_origin: pmt$log_msg_origin;
        critical_message: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmd$system_log_interface
?? POP ??
*DECK DECK=PFP$LOG_PATH EXPAND=FALSE

  PROCEDURE [XREF] pfp$log_path
    (    variant_path: pft$variant_path;
         ascii_logset: pmt$ascii_logset;
         origin: pmt$log_msg_origin;
         critical_message: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pft$variant_path
*copyc pmd$system_log_interface
?? POP ??
*DECK DECK=PFP$LOG_STATUS EXPAND=FALSE

  PROCEDURE [XREF] pfp$log_status
    (    ascii_logset: pmt$ascii_logset;
         log_status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$ascii_logset
?? POP ??
*DECK DECK=PFP$MAP_USAGE_SELECTIONS EXPAND=FALSE

  PROCEDURE [INLINE] pfp$map_usage_selections
    (    usage_selections: pft$usage_selections;
     VAR usage_intentions: pft$permit_selections);

?? PUSH (LISTEXT := ON) ??

    VAR
      usage_option: pft$usage_options;

    usage_intentions := $pft$permit_selections [];

    FOR usage_option := LOWERVALUE (usage_option) TO UPPERVALUE (usage_option)
          DO
      IF usage_option IN usage_selections THEN
        usage_intentions := usage_intentions +
              $pft$permit_selections [usage_option];
      IFEND;
    FOREND;
  PROCEND pfp$map_usage_selections;

*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$MARK_RELEASE_CANDIDATE EXPAND=FALSE

  PROCEDURE [XREF] pfp$mark_release_candidate
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         archive_identification: pft$archive_identification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$archive_definitions
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
?? POP ??
*DECK DECK=PFP$NO_SPACE_MOVC_DEST_VOLUMES EXPAND=FALSE

  FUNCTION [XREF] pfp$no_space_movc_dest_volumes
    (    move_object_info_p: ^pft$move_object_info): boolean;

?? PUSH (LISTEXT := ON) ??
*copyc pft$move_object_info
?? POP ??
*DECK DECK=PFP$OBJECT_CONTRACTION_COUNT EXPAND=FALSE
  FUNCTION [INLINE] pfp$object_contraction_count
    (    p_object_list: ^pft$object_list): pft$object_count;

?? PUSH (LISTEXT := ON) ??
    IF p_object_list = NIL THEN
      pfp$object_contraction_count := 8;
    ELSEIF UPPERBOUND (p_object_list^) < 32 THEN
      pfp$object_contraction_count := 8;
    ELSEIF UPPERBOUND (p_object_list^) < 256 THEN
      pfp$object_contraction_count := 16;
    ELSEIF UPPERBOUND (p_object_list^) < 512 THEN
      pfp$object_contraction_count := 32;
    ELSE
      pfp$object_contraction_count := 64;
    IFEND;

  FUNCEND pfp$object_contraction_count;

*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$OBJECT_EXPANSION_SIZE EXPAND=FALSE
  FUNCTION [INLINE] pfp$object_expansion_size
    (    p_object_list: ^pft$object_list): pft$object_count;

?? PUSH (LISTEXT := ON) ??
    IF p_object_list = NIL THEN
      pfp$object_expansion_size := 16;
    ELSEIF UPPERBOUND (p_object_list^) < 256 THEN
      pfp$object_expansion_size := 16;
    ELSEIF UPPERBOUND (p_object_list^) < 512 THEN
      pfp$object_expansion_size := 32;
    ELSE
      pfp$object_expansion_size := 64;
    IFEND;

  FUNCEND pfp$object_expansion_size;

*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$OPEN_ATTACHED_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$open_attached_catalog (
        access_kind: pft$access_kind;
    VAR catalog_locator: {i/o} pft$catalog_locator;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_locator
?? POP ??
*DECK DECK=PFP$OPEN_FILE_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] pfp$open_file_segment
    (    system_file_id: dmt$system_file_id;
         validation_ring: ost$valid_ring;
     VAR segment_pointer: mmt$segment_pointer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc mmt$attribute_keyword
*copyc osd$virtual_address
*copyc ost$status
?? POP ??

*DECK DECK=PFP$OVERHAUL_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$overhaul_catalog (
        path: pft$path;
        catalog_overhaul_choices: pft$catalog_overhaul_choices;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PFE$ERROR_CONDITION_CODES
*copyc PFT$OVERHAUL_CHOICES
?? POP ??
*DECK DECK=PFP$OVERHAUL_SET EXPAND=FALSE

  PROCEDURE [XREF] pfp$overhaul_set (
        set_name: stt$set_name;
        set_overhaul_choices: pft$set_overhaul_choices;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFE$ERROR_CONDITION_CODES
*copyc PFE$INTERNAL_ERROR_CONDITIONS
*copyc PFT$OVERHAUL_CHOICES
*copyc STD$SET_NAME
?? POP ??
*DECK DECK=PFP$PERMIT EXPAND=FALSE

  PROCEDURE [XREF] pfp$permit ALIAS 'pfxper' (path: pft$path;
    group: pft$group;
    permit_selections: pft$permit_selections;
    share_requirements: pft$share_requirements;
    application_info: pft$application_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
*copyc OST$STATUS
*copyc PFE$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=PFP$PERMIT_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$permit_catalog ALIAS 'pfxperc' (
        path: pft$path;
        group: pft$group;
        permit_selections: pft$permit_selections;
        share_requirements: pft$share_requirements;
        application_info: pft$application_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PFE$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=PFP$PHYSICALLY_ATTACH_CATALOG EXPAND=FALSE
  PROCEDURE [XREF] pfp$physically_attach_catalog
    (    set_name: stt$set_name;
         internal_catalog_name: pft$internal_catalog_name;
         global_file_name: ost$binary_unique_name;
         p_fmd: pft$p_fmd;
         catalog_remote: boolean;
     VAR catalog_locator: pft$catalog_locator;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$catalog_locator
*copyc pfd$internal_name
*copyc std$set_name
?? POP ??
*DECK DECK=PFP$PICK_MODES_FOR_OPEN EXPAND=FALSE

  PROCEDURE [XREF] pfp$pick_modes_for_open (
        evaluated_file_reference: fst$evaluated_file_reference;
        p_attachment_options: {input} ^fst$attachment_options;
        allowed_access: fst$file_access_options;
        required_sharing: fst$file_access_options;
        setfa_access_modes: fst$access_modes;
        device_class: rmt$device_class;
        cycle_formerly_opened_info: fmt$cycle_formerly_opened_info;
        called_by_attach: boolean;
        create_file: boolean;
        validation_ring: ost$valid_ring;
    VAR selected_access: fst$file_access_options;
    VAR selected_sharing: fst$file_access_options;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$cycle_formerly_opened_info
*copyc fst$access_modes
*copyc fst$attachment_options
*copyc fst$evaluated_file_reference
*copyc fst$file_access_options
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$authority
*copyc pfd$catalog
*copyc pft$password_info
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$PROCESS_JOB_END EXPAND=FALSE

  PROCEDURE [XREF] pfp$process_job_end
    (    files_binary_mainframe_id: pmt$binary_mainframe_id;
     VAR return_files_option {Input, Output} : pft$return_files_option);

?? PUSH (LISTEXT := ON) ??
*copyc pft$return_files_option
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=PFP$PROCESS_UNEXPECTED_STATUS EXPAND=FALSE

  PROCEDURE [INLINE] pfp$process_unexpected_status (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    IF NOT status.normal THEN
      pfp$report_unexpected_status (status);
    IFEND;
  PROCEND pfp$process_unexpected_status;

*copyc ost$status
*copyc pfp$report_unexpected_status
?? POP ??
*DECK DECK=PFP$PURGE EXPAND=FALSE

  PROCEDURE [XREF] pfp$purge
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$PURGE_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$purge_catalog ALIAS 'pfxpurc' (path: pft$path;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc OST$STATUS
*copyc PFE$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=PFP$PURGE_CATALOG_CONTENTS EXPAND=FALSE

  PROCEDURE [XREF] pfp$purge_catalog_contents
    (    catalog_path: pft$path;
         purge_catalog: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$PURGE_MASTER_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$purge_master_catalog (
        set_name: stt$set_name;
        family_name: pft$name;
        master_catalog_name: pft$name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PFE$ERROR_CONDITION_CODES
*copyc PFE$INTERNAL_ERROR_CONDITIONS
*copyc STD$SET_NAME
?? POP ??
*DECK DECK=PFP$PURGE_OBJECT EXPAND=FALSE
  PROCEDURE [XREF] pfp$purge_object
    (    path: pft$path;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$PUT_ARCHIVE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$put_archive_entry (
        path: pft$path;
        cycle_selector: pft$cycle_selector;
        p_archive_array_entry: pft$p_archive_array_entry;
        p_amd: pft$p_amd;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
?? POP ??
*DECK DECK=PFP$PUT_ARCHIVE_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$put_archive_info
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         p_info_record: pft$p_info_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
?? POP ??
*DECK DECK=PFP$PUT_CATALOG_MEDIA_INFO EXPAND=FALSE
  PROCEDURE [XREF] pfp$put_catalog_media_info
    (    catalog_path: pft$path;
         p_catalog_gorup: pft$p_info_record;
         set_name: stt$set_name;
     VAR restore_catalog_status: pft$restore_catalog_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pft$restore_catalog_status
*copyc std$set_name
?? POP ??

*DECK DECK=PFP$PUT_CATALOG_SEGMENT EXPAND=FALSE
  PROCEDURE [XREF] pfp$put_catalog_segment
    (    path: pft$path;
         p_catalog_segment: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$PUT_CYCLE_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$put_cycle_info
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         cycle_array_entry: pft$cycle_array_entry_version_2;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$PUT_FAMILY_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$put_family_info (
        set_name: stt$set_name;
        family_name: pft$name;
        p_info_record: pft$p_info_record;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_INFO
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PFE$ERROR_CONDITION_CODES
*copyc STD$SET_NAME
?? POP ??
*DECK DECK=PFP$PUT_FILE_MEDIA_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$put_file_media_info (
         file_path: pft$path;
         p_file_info_record: pft$p_info_record;
         set_name: stt$set_name;
         backup_file_version: pft$backup_file_version;
     VAR file_entry_recreated: boolean;
     VAR cycles_restored_with_fmd: pft$cycle_count;
     VAR cycles_restored_without_fmd: pft$cycle_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pft$cycle_count
*copyc std$set_name
?? POP ??
*DECK DECK=PFP$PUT_ITEM_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$put_item_info
    (    path: pft$path;
         p_info_record: pft$p_info_record;
         restore_archive_information: boolean;
         cycle_selection_criteria: put$selection_criteria;
         backup_file_version: pft$backup_file_version;
     VAR all_permits_restored: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pud$selection_criteria
?? POP ??
*DECK DECK=PFP$PUT_MASTER_CATALOG_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$put_master_catalog_info (
        set_name: stt$set_name;
        family_name: pft$name;
        master_catalog_name: pft$name;
        p_info_record: pft$p_info_record;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_INFO
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PFE$ERROR_CONDITION_CODES
*copyc STD$SET_NAME
?? POP ??
*DECK DECK=PFP$R1_CLEAR_MOVE_CLASSES_LOCK EXPAND=FALSE
*DECK DECK=PFP$R1_GET_CATALOG_ALARM_TABLE EXPAND=FALSE
  PROCEDURE [XREF] pfp$r1_get_catalog_alarm_table (VAR p_table_info: pft$p_table_info;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$table_info
*copyc ost$status
?? POP ??

*DECK DECK=PFP$R1_SET_MOVE_CLASSES_LOCK EXPAND=FALSE
*DECK DECK=PFP$R2_APPEND_REM_MEDIA_VSN EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_append_rem_media_vsn
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         volume_descriptor: rmt$volume_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc rmt$volume_descriptor
?? POP ??
*DECK DECK=PFP$R2_ATTACH EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_attach (
        r2_attach_input: pft$r2_attach_in;
        update_catalog: boolean;
        update_cycle_statistics: boolean;
        usage_selections: pft$usage_selections;
        share_selections: pft$share_selections;
        system_privilege: boolean;
        validation_ring: ost$valid_ring;
        allowed_cycle_damage_symptoms: fst$cycle_damage_symptoms;
    VAR cycle_number: pft$cycle_number;
    VAR cycle_damage_symptoms: fst$cycle_damage_symptoms;
    VAR global_file_name: ost$binary_unique_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$cycle_damage_symptoms
*copyc osd$virtual_address
*copyc ost$binary_unique_name
*copyc ost$status
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc pft$r2_attach_in
?? POP ??
*DECK DECK=PFP$R2_ATTACH_FILE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_attach_file
    (    family_location: pft$family_location;
         mainframe_id: pmt$binary_mainframe_id;
         lfn: amt$local_file_name;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         update_catalog: boolean;
         update_cycle_statistics: boolean;
         usage_selector: pft$usage_selector;
         share_selector: pft$share_selector;
         system_privilege: boolean;
         validation_ring: ost$valid_ring;
         allowed_device_classes: fst$device_classes;
         allowed_cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR device_class: rmt$device_class;
     VAR cycle_number: pft$cycle_number;
     VAR allowed_usage_selections: pft$usage_selections;
     VAR required_share_selections: pft$share_selections;
     VAR cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR authority: pft$authority;
     VAR global_file_name: ost$binary_unique_name;
     VAR p_file_server_buffers: {server only: i^/o^} pft$p_file_server_buffers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc fst$cycle_damage_symptoms
*copyc fst$device_classes
*copyc osd$virtual_address
*copyc ost$binary_unique_name
*copyc ost$status
*copyc pfd$authority
*copyc pfd$complete_path
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc pfd$share_selector
*copyc pfd$usage_selector
*copyc pft$family_location
*copyc pft$server_file_output
*copyc pmt$binary_mainframe_id
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$R2_ATTACH_OR_CREATE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_attach_or_create
    (    family_location: pft$family_location;
         mainframe_id: pmt$binary_mainframe_id;
         validation_ring: ost$valid_ring;
         system_privilege: boolean;
         exception_selection_info: pft$exception_selection_info;
         p_attachment_options: {input} ^fst$attachment_options;
         p_file_label: {input} ^fmt$file_label;
         p_path_table_cycle_info: {input} ^fmt$path_table_cycle_info;
         fs_retention: fst$retention;
         retrieve_option: pft$retrieve_option;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR action_attempted: pft$action_attempted;
     VAR action_taken: pft$attach_or_create_action;
     VAR authority: pft$authority;
     VAR allowed_access: fst$file_access_options;
     VAR selected_access: fst$file_access_options;
     VAR required_sharing: fst$file_access_options;
     VAR selected_sharing: fst$file_access_options;
     VAR device_class: rmt$device_class;
     VAR global_file_name: ost$binary_unique_name;
     VAR new_global_file_name: ost$binary_unique_name;
     VAR new_remote_sfid: gft$system_file_identifier;
     VAR label_used: boolean;
     VAR bytes_allocated: amt$file_byte_address;
     VAR p_file_server_buffers: {server only: i^/o^} ^pft$file_server_buffers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc fmt$file_label
*copyc fmt$path_table_cycle_info
*copyc fst$attachment_options
*copyc fst$evaluated_file_reference
*copyc fst$retention
*copyc fst$file_access_options
*copyc gft$system_file_identifier
*copyc osd$virtual_address
*copyc ost$binary_unique_name
*copyc ost$status
*copyc pfd$authority
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pft$action_attempted
*copyc pft$attach_or_create_action
*copyc pft$exception_selection_info
*copyc pft$family_location
*copyc pft$server_file_output
*copyc pmt$binary_mainframe_id
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$R2_ATTACH_OR_CREATE_FILE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_attach_or_create_file
    (    validation_ring: ost$valid_ring;
         system_privilege: boolean;
         exception_selection_info: pft$exception_selection_info;
         p_attachment_options: {input} ^fst$attachment_options;
         p_file_label: {input} fmt$p_file_label;
         fs_retention: fst$retention;
         retrieve_option: pft$retrieve_option;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR allowed_access: fst$file_access_options;
     VAR selected_access: fst$file_access_options;
     VAR required_sharing: fst$file_access_options;
     VAR selected_sharing: fst$file_access_options;
     VAR action_taken: pft$attach_or_create_action;
     VAR label_replaced: boolean;
     VAR device_class: rmt$device_class;
     VAR global_file_name: ost$binary_unique_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$file_label
*copyc fst$attachment_options
*copyc fst$evaluated_file_reference
*copyc fst$file_access_options
*copyc fst$retention
*copyc osd$virtual_address
*copyc ost$binary_unique_name
*copyc ost$status
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pft$attach_or_create_action
*copyc pft$exception_selection_info
*copyc pft$retrieve_option
*copyc pft$site_archive_option
*copyc pft$site_backup_option
*copyc pft$site_release_option
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$R2_BUILD_ARCHIVE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_build_archive_entry
    (    archive_identification: pft$archive_identification;
         p_archive_array_entry: pft$p_archive_array_entry;
         p_amd: pft$p_amd;
         p_catalog_file: pft$p_catalog_file;
         p_archive: pft$p_archive;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$catalog_info
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
?? POP ??
*DECK DECK=PFP$R2_BUILD_SORTED_DFL EXPAND=FALSE
  PROCEDURE [XREF] pfp$r2_build_sorted_dfl
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PFP$R2_CHANGE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_change (
        family_location: pft$family_location;
        path: pft$complete_path;
        cycle_selector: pft$cycle_selector;
        password: pft$password;
        system_privilege: boolean;
        change_list: pft$change_list;
    VAR cycle_number: pft$cycle_number;
    VAR device_class: rmt$device_class;
    VAR change_index: ost$non_negative_integers;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
*copyc ost$status
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pft$family_location
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$R2_CHANGE_CATALOG_NAME EXPAND=FALSE
  PROCEDURE [XREF] pfp$r2_change_catalog_name (path: pft$complete_path;
        new_catalog_name: pft$name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc ost$status
?? POP ??
*DECK DECK=PFP$R2_CHANGE_CYCLE_DAMAGE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_change_cycle_damage
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         new_damage_symptoms: fst$cycle_damage_symptoms;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$cycle_damage_symptoms
*copyc ost$status
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$R2_CHANGE_CYCLE_DATE_TIME EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_change_cycle_date_time
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         new_access_date_time: pft$date_time;
         new_creation_date_time: pft$date_time;
         new_modification_date_time: pft$date_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pft$date_time
?? POP ??
*DECK DECK=PFP$R2_CHANGE_FILE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_change_file (
        family_location: pft$family_location;
        path: pft$complete_path;
        cycle_selector: pft$cycle_selector;
        password: pft$password;
        system_privilege: boolean;
        file_changes: ^fst$file_changes;
    VAR cycle_number: pft$cycle_number;
    VAR device_class: rmt$device_class;
    VAR change_index: ost$non_negative_integers;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_changes
*copyc osd$integer_limits
*copyc ost$status
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pft$family_location
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$R2_CHANGE_RES_TO_RELEASABLE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_change_res_to_releasable
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$R2_CLEAR_CYCLE_ATTACHMENTS EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_clear_cycle_attachments
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$R2_CONDITION_HANDLER EXPAND=FALSE

  PROCEDURE pfp$r2_condition_handler
    (    condition: pmt$condition;
         p_condition_info: ^pmt$condition_information;
         p_sfsa: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    VAR
      variant_path: pft$variant_path,
      status_id: ost$status_identifier,
      local_status: ost$status;

    variant_path.complete_path := TRUE;
    variant_path.p_complete_path := ^path;

    IF NOT process_non_local_exit THEN
      pfp$log_ascii ('***PF Condition Handler***', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
            pmc$msg_origin_system, {critical_message} FALSE, local_status);
      pfp$log_path (variant_path, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
            {critical_message} FALSE, local_status);
    IFEND;

    CASE condition.selector OF
    = pmc$system_conditions, pmc$block_exit_processing, mmc$segment_access_condition =
      IF process_non_local_exit THEN
        RETURN;
      IFEND;

      IF catalog_locator.attached THEN
        catalog_locator.abort_catalog_operation := TRUE;
        pfp$return_catalog (catalog_locator, local_status);
        IF NOT local_status.normal THEN
          pfp$report_system_error (local_status);
        IFEND;
      IFEND;

      syp$pop_inhibit_job_recovery;

      IF pfv$locked_apfid <> 0 THEN
        pfp$release_locked_apfid (pfv$locked_apfid, local_status);
        pfv$locked_apfid := 0;
      IFEND;

      osp$set_status_from_condition (status_id, condition, p_sfsa, local_status, handler_status);
      osp$recoverable_system_error ('UNEXPECTED STATUS', ^local_status);

      status := local_status;
      initiate_non_local_exit;


    = pmc$user_defined_condition =
      IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
       {syp$invalidate_open_sfid (catalog_locator.system_file_id, local_status);
        initiate_non_local_exit;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;
    ELSE
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    CASEND;

  PROCEND pfp$r2_condition_handler;

*DECK DECK=PFP$R2_DEFINE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_define
    (    family_location: pft$family_location;
         mainframe_id: pmt$binary_mainframe_id;
         lfn: amt$local_file_name;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         fs_retention: fst$retention;
         log: pft$log;
         retrieve_option: pft$retrieve_option;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
         system_privilege: boolean;
         validation_ring: ost$valid_ring;
         device_class: rmt$device_class;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
         p_removable_media_req_info: {input} ^fmt$removable_media_req_info;
         p_volume_list: {input} ^rmt$volume_list;
     VAR cycle_number: pft$cycle_number;
     VAR authority: pft$authority;
     VAR bytes_allocated: amt$file_byte_address;
     VAR p_file_server_buffers: {server only: i^/o^} pft$p_file_server_buffers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc amt$local_file_name
*copyc dfd$request_package
*copyc fmt$mass_storage_request_info
*copyc fmt$removable_media_req_info
*copyc fst$retention
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$authority
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pft$df_define
*copyc pft$family_location
*copyc pft$retrieve_option
*copyc pft$site_archive_option
*copyc pft$site_backup_option
*copyc pft$site_release_option
*copyc pft$server_file_output
*copyc pmt$binary_mainframe_id
*copyc rmd$volume_declarations
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$R2_DEFINE_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_define_catalog (
        path: pft$complete_path;
        charge_id: pft$charge_id;
        system_privilege: boolean;
         catalog_type_selected: boolean;
         selected_catalog_type: pft$catalog_types;
         p_mass_storage_request_info: ^fmt$mass_storage_request_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$mass_storage_request_info
*copyc ost$status
*copyc pfd$charge_id
*copyc pfd$complete_path
*copyc pft$catalog_types
?? POP ??
*DECK DECK=PFP$R2_DEFINE_DATA EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_define_data (
        family_location: pft$family_location;
        mainframe_id: pmt$binary_mainframe_id;
        lfn: amt$local_file_name;
        path: pft$complete_path;
        cycle_selector: pft$cycle_selector;
        update_cycle_statistics: boolean;
        password_selector: pft$password_selector;
        validation_ring: ost$valid_ring;
        p_mass_storage_request_info: ^fmt$mass_storage_request_info;
        p_volume_list: ^array [1 .. *] of rmt$recorded_vsn;
        purge_cycle_options: pft$purge_cycle_options;
        replace_cycle_data: boolean;
        restore_selections: put$restore_data_selections;
    VAR mandated_modification_time: {i/o} pft$mandated_modification_time;
    VAR data_residence: pft$data_residence;
    VAR authority: pft$authority;
    VAR bytes_allocated: amt$file_byte_address;
    VAR p_file_server_buffers: pft$p_file_server_buffers;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc amt$local_file_name
*copyc fmt$mass_storage_request_info
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$authority
*copyc pfd$complete_path
*copyc pfd$mandated_modification_time
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pft$data_residence
*copyc pft$family_location
*copyc pmt$binary_mainframe_id
*copyc put$restore_data_selections
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=PFP$R2_DELETE_ALL_ARCH_ENTRIES EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_delete_all_arch_entries
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
?? POP ??
*DECK DECK=PFP$R2_DELETE_ARCHIVE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_delete_archive_entry
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
?? POP ??
*DECK DECK=PFP$R2_DELETE_CATALOG_PERMIT EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_delete_catalog_permit (
        path: pft$complete_path;
        system_privilege: boolean;
        group: pft$group;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$COMPLETE_PATH
*copyc PFD$PERMANENT_FILE_DEFINITIONS
?? POP ??
*DECK DECK=PFP$R2_DELETE_PERMIT EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_delete_permit (
        path: pft$complete_path;
        system_privilege: boolean;
        group: pft$group;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$COMPLETE_PATH
*copyc PFD$PERMANENT_FILE_DEFINITIONS
?? POP ??
*DECK DECK=PFP$R2_DETACH_RESERVED_CYCLES EXPAND=FALSE

 PROCEDURE [XREF] pfp$r2_detach_reserved_cycles
   (    mainframe_id: pmt$binary_mainframe_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
*copyc ost$status
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_APP_REM_ME_VSN EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_app_rem_me_vsn
    (    served_family_locator: pft$served_family_locator;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         volume_descriptor: rmt$volume_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pft$served_family_locator
*copyc rmt$volume_descriptor
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_ATTACH EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_attach
    (    served_family_locator: pft$served_family_locator;
         lfn: amt$local_file_name;
         path: pft$path;
         attach_input: pft$df_attach_in;
     VAR cycle_number: pft$cycle_number;
     VAR device_class: rmt$device_class;
     VAR cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR global_file_name: dmt$global_file_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc dmt$global_file_name
*copyc fst$cycle_damage_symptoms
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pft$df_attach_in
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_ATTACH_OR_CREF EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_attach_or_cref
    (    served_family_locator: pft$served_family_locator;
         validation_ring: ost$valid_ring;
         system_privilege: boolean;
         exception_selection_info: pft$exception_selection_info;
         p_attachment_options: {input} ^fst$attachment_options;
         p_file_label: {input} ^fmt$file_label;
         p_path_table_cycle_info: {input} ^fmt$path_table_cycle_info;
         fs_retention: {input} fst$retention;
         retrieve_option: pft$retrieve_option;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR action_attempted: pft$action_attempted;
     VAR action_taken: pft$attach_or_create_action;
     VAR authority: pft$authority;
     VAR allowed_access: fst$file_access_options;
     VAR selected_access: fst$file_access_options;
     VAR required_sharing: fst$file_access_options;
     VAR selected_sharing: fst$file_access_options;
     VAR device_class: rmt$device_class;
     VAR global_file_name: dmt$global_file_name;
     VAR label_used: boolean;
     VAR bytes_allocated: amt$file_byte_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmt$global_file_name
*copyc fmt$file_label
*copyc fmt$path_table_cycle_info
*copyc fmt$removable_media_req_info
*copyc fst$attachment_options
*copyc fst$evaluated_file_reference
*copyc fst$file_access_options
*copyc fst$retention
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$authority
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pft$action_attempted
*copyc pft$attach_or_create_action
*copyc pft$exception_selection_info
*copyc pft$retrieve_option
*copyc pft$served_family_locator
*copyc pft$site_archive_option
*copyc pft$site_backup_option
*copyc pft$site_release_option
*copyc rmd$volume_declarations
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_CHANGE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_change (
        served_family_location: pft$served_family_locator;
        path: pft$path;
        cycle_selector: pft$cycle_selector;
        password: pft$password;
        system_privilege: boolean;
        change_list: pft$change_list;
    VAR cycle_number: pft$cycle_number;
    VAR device_class: rmt$device_class;
    VAR change_index: ost$non_negative_integers;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pft$served_family_locator
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_CHANGE_CY_DAM EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_change_cy_dam
    (    served_family_location: pft$served_family_locator;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         new_damage_symptoms: fst$cycle_damage_symptoms;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$cycle_damage_symptoms
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pft$family_location
*copyc pft$served_family_locator
?? POP ??


*DECK DECK=PFP$R2_DF_CLIENT_CHANGE_CY_DT EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_change_cy_dt
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         new_access_date_time: pft$date_time;
         new_creation_date_time: pft$date_time;
         new_modification_date_time: pft$date_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pft$date_time
*copyc pft$family_location
*copyc pft$served_family_locator
?? POP ??

*DECK DECK=PFP$R2_DF_CLIENT_CHANGE_FILE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_change_file (
        served_family_location: pft$served_family_locator;
        path: pft$path;
        cycle_selector: pft$cycle_selector;
        password: pft$password;
        system_privilege: boolean;
        file_changes: ^fst$file_changes;
    VAR cycle_number: pft$cycle_number;
    VAR device_class: rmt$device_class;
    VAR change_index: ost$non_negative_integers;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_changes
*copyc osd$integer_limits
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pft$served_family_locator
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_CHANGE_RES_REL EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_change_res_rel
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_CLEAR_CY_ATT EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_clear_cy_att (
         served_family_locator: pft$served_family_locator;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pft$df_clear_cy_att_in
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_DEFINE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_define
    (    served_family_location: pft$served_family_locator;
         lfn: amt$local_file_name;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         fs_retention: fst$retention;
         log: pft$log;
         retrieve_option: pft$retrieve_option;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
         system_privilege: boolean;
         validation_ring: ost$valid_ring;
         device_class: rmt$device_class;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
         p_removable_media_req_info: {input} ^fmt$removable_media_req_info;
         p_volume_list: {input} ^rmt$volume_list;
     VAR cycle_number: pft$cycle_number;
     VAR authority: pft$authority;
     VAR bytes_allocated: amt$file_byte_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc amt$file_byte_address
*copyc fmt$mass_storage_request_info
*copyc fmt$removable_media_req_info
*copyc fst$retention
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$authority
*copyc pfd$permanent_file_definitions
*copyc pft$served_family_locator
*copyc pft$retrieve_option
*copyc pft$site_archive_option
*copyc pft$site_backup_option
*copyc pft$site_release_option
*copyc rmd$volume_declarations
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_DEFINE_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_define_catalog
    (   served_family_location: pft$served_family_locator;
        path: pft$path;
        charge_id: pft$charge_id;
        system_privilege: boolean;
        catalog_type_selected: boolean;
        selected_catalog_type: pft$catalog_types;
        p_mass_storage_request_info: ^fmt$mass_storage_request_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$mass_storage_request_info
*copyc ost$status
*copyc pfd$charge_id
*copyc pfd$permanent_file_definitions
*copyc pft$catalog_types
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_DEFINE_DATA EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_define_data (
         served_family_locator: pft$served_family_locator;
         lfn: amt$local_file_name;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         update_cycle_statistics: boolean;
         password_selector: pft$password_selector;
         validation_ring: ost$valid_ring;
         p_mass_storage_request_info: ^fmt$mass_storage_request_info;
         p_volume_list: ^array [1 .. *] of rmt$recorded_vsn;
         purge_cycle_options: pft$purge_cycle_options;
         replace_cycle_data: boolean;
         restore_selections: put$restore_data_selections;
     VAR mandated_modification_time: {i/o} pft$mandated_modification_time;
     VAR data_residence: pft$data_residence;
     VAR authority: pft$authority;
     VAR bytes_allocated: amt$file_byte_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc amt$local_file_name
*copyc fmt$mass_storage_request_info
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$authority
*copyc pfd$complete_path
*copyc pfd$mandated_modification_time
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*copyc pft$data_residence
*copyc pft$family_location
*copyc pft$served_family_locator
*copyc put$restore_data_selections
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_DELETE_PERMIT EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_delete_permit
    (    path: pft$path;
         object_type: pft$object_types;
         system_privilege: boolean;
         group: pft$group;
         served_family_location: pft$served_family_locator;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$permanent_file_definitions
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_DEL_ALL_ARC_EN EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_del_all_arc_en
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
*copyc pft$served_family_locator
*copyc ost$status
?? POP ??

*DECK DECK=PFP$R2_DF_CLIENT_DEL_ARCH_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_del_arch_entry
    (    served_family_locator: pft$served_family_locator;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$archive_definitions
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_GET_FAMILY_SET EXPAND=FALSE
  PROCEDURE [XREF] pfp$r2_df_client_get_family_set
    (    family_name: pft$name;
         served_family_locator: pft$served_family_locator;
     VAR set_name: stt$set_name;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pft$served_family_locator
*copyc std$set_name
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_GET_FAMIT_INFO EXPAND=FALSE
  PROCEDURE [XREF] pfp$r2_df_client_get_famit_info
    (    family_name: pft$name;
         catalog_info_selections: pft$catalog_info_selections;
         served_family_locator: pft$served_family_locator;
     VAR set_name: pft$name;
     VAR p_info: pft$p_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
?? POP ??

*DECK DECK=PFP$R2_DF_CLIENT_GET_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_get_info (
        info_selection: pft$get_info_selection;
        path: pft$path;
        system_privilege: boolean;
        group: pft$group;
        catalog_info_selections: pft$catalog_info_selections;
        file_info_selections: pft$file_info_selections;
        served_family_locator: pft$served_family_locator;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$internal_error_conditions
*copyc pft$get_info_selection
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_GET_MCAT_INFO EXPAND=FALSE
  PROCEDURE [XREF] pfp$r2_df_client_get_mcat_info
    (    family_name: pft$name;
         catalog_info_selections: pft$catalog_info_selections;
         served_family_locator: pft$served_family_locator;
     VAR p_info: pft$p_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
?? POP ??

*DECK DECK=PFP$R2_DF_CLIENT_GET_OBJ_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_get_obj_info
    (    served_family_locator: pft$served_family_locator;
         evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
         system_privilege: boolean;
         password_selector: pft$password_selector;
         subject_permit_count: ost$non_negative_integers;
         validation_ring: ost$valid_ring;
         p_validation_criteria: {i/o^} ^fst$goi_validation_criteria;
         p_object_info: {input} ^fst$goi_object_information;
     VAR offset: ost$segment_offset;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc fst$evaluated_file_reference
*copyc fst$goi_information_request
*copyc fst$goi_object_information
*copyc fst$goi_validation_criteria
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$password_selector
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_GET_VOL_CL EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_get_vol_cl
    (    served_family_locator: pft$served_family_locator;
         unique_volume_list: pft$unique_volume_list;
     VAR volume_condition_list: fst$volume_condition_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$volume_condition_list
*copyc ost$status
*copyc pft$served_family_locator
*copyc pft$unique_volume_list
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_MARK_REL_CAND EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_mark_rel_cand
    (    served_family_locator: pft$served_family_locator;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         validation_ring: ost$valid_ring;
         archive_identification: pft$archive_identification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$archive_definitions
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_PERMIT EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_permit
    (    path: pft$path;
         object_type: pft$object_types;
         system_privilege: boolean;
         permit_level: pft$permit_level;
         group: pft$group;
         permit_selections: pft$permit_selections;
         share_requirements: pft$share_requirements;
         application_info: pft$application_info;
         served_family_location: pft$served_family_locator;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pft$served_family_locator
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc pft$permit_level
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_PURGE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_purge
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         purge_cycle_options: pft$purge_cycle_options;
         system_privilege: boolean;
         validation_ring: ost$valid_ring;
     VAR authority: pft$authority;
     VAR device_class: rmt$device_class;
     VAR bytes_released: amt$file_byte_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc amt$file_byte_address
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$authority
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pft$purge_cycle_options
*copyc pft$served_family_locator
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_PURGE_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_purge_catalog
    (   served_family_location: pft$served_family_locator;
        path: pft$path;
        system_privilege: boolean;
        delete_option: pft$delete_option;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pft$delete_option
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_PUT_ARCH_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_put_arch_entry
    (    served_family_locator: pft$served_family_locator;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
         p_archive_array_entry: pft$p_archive_array_entry;
         p_amd: pft$p_amd;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$archive_definitions
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_PUT_ARCH_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_put_arch_info
    (    served_family_locator: pft$served_family_locator;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         p_info_record: pft$p_info_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_PUT_CYCLE_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_put_cycle_info
    (    served_family_locator: pft$served_family_locator;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         cycle_array_entry: pft$cycle_array_entry_version_2;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$complete_path
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_PUT_ITEM_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_put_item_info
    (    backup_file_version: pft$backup_file_version;
         p_info_record: {input} ^pft$info_record;
         served_family_locator: pft$served_family_locator;
         path: pft$path;
         permit_level: pft$permit_level;
         selection_criteria: put$selection_criteria;
         restore_archive_information: boolean;
     VAR audit_restorations: {i/o} boolean;
     VAR all_permits_restored: boolean;
     VAR p_auditable_permits: ^pft$auditable_permits;
     VAR p_auditable_cycles: ^pft$auditable_cycles;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pft$auditable_cycles
*copyc pft$auditable_permits
*copyc pft$permit_level
*copyc pft$served_family_locator
*copyc pud$selection_criteria
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_RELEASE_DATA EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_release_data
    (   served_family_locator: pft$served_family_locator;
        path: pft$complete_path;
        cycle_selector: pft$cycle_selector;
        password: pft$password;
        p_release_data_info: {i/o} ^pft$release_data_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pft$release_data_info
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_REP_ARCH_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_rep_arch_entry
    (    served_family_locator: pft$served_family_locator;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
         p_archive_array_entry: pft$p_archive_array_entry;
         p_amd: pft$p_amd;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$archive_definitions
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_REP_REM_ME_FMD EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_rep_rem_me_fmd
    (    served_family_locator: pft$served_family_locator;
         path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         p_file_media_descriptor: {input} ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$complete_path
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_RESOLVE EXPAND=FALSE

   PROCEDURE [XREF] pfp$r2_df_client_resolve (pf_path: pft$path;
        served_family_location: pft$served_family_locator;
        system_privilege: boolean;
    VAR cycle_reference: {i/o} fst$cycle_reference;
    VAR path_resolution: fst$path_resolution;
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc fst$cycle_reference
*copyc fst$path_resolution
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_RETURN EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_return
    (    apfid: pft$attached_permanent_file_id;
         client_sfid: gft$system_file_identifier;
         device_class: rmt$device_class;
         usage_selections: pft$usage_selections;
     VAR authority: pft$authority;
     VAR bytes_allocated_change: sft$counter;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc ost$status
*copyc pfd$attached_permanent_file_id
*copyc pfd$authority
*copyc pfd$permanent_file_attributes
*copyc rmt$device_class
*copyc sft$counter
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_SAVE_LABEL EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_save_label
    (    apfid: pft$attached_permanent_file_id;
         system_authority: pft$system_authority;
         required_permission: pft$permit_options;
         p_file_label: {input} ^fmt$file_label;
     VAR p_save_file_label_audit_seq: {i/o} ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$file_label
*copyc ost$status
*copyc pfd$attached_permanent_file_id
*copyc pfd$permanent_file_attributes
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pft$system_authority
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_SAVE_REL_LABEL EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_save_rel_label
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         p_file_label: {input^} ^fmt$file_label;
         validation_ring: ost$valid_ring;
         update_cycle_statistics: boolean;
     VAR p_save_label_audit_info: {i/o} ^pft$save_label_audit_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$file_label
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pft$save_label_audit_info
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R2_DF_CLIENT_VALIDATE_PW EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_client_validate_pw
    (    served_family_locator: pft$served_family_locator;
         path: pft$path;
         password: pft$password;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R2_DF_SERVER_GET_OBJ_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_df_server_get_obj_info
    (VAR p_param_received_from_client: {i/o} dft$p_receive_parameters;
     VAR p_data_from_client: {i/o} dft$p_receive_data;
     VAR p_send_to_client_params: dft$p_send_parameters;
     VAR p_send_to_client_data: dft$p_send_data;
     VAR send_parameters_size: dft$send_parameter_size;
     VAR send_data_size: dft$send_data_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_parameters
*copyc ost$status
?? POP ??
*DECK DECK=PFP$R2_DM_ATTACH_ITEM EXPAND=TRUE
  PROCEDURE [XREF] pfp$r2_dm_attach_item
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
     VAR sfid: gft$system_file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc ost$status
?? POP ??
*DECK DECK=PFP$R2_FLUSH_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_flush_catalog
    (    p_complete_path: ^pft$complete_path;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$complete_path
?? POP ??
*DECK DECK=PFP$R2_GET_ATTACHED_PF_TABLE EXPAND=FALSE
  PROCEDURE [XREF] pfp$r2_get_attached_pf_table (VAR p_table_info: pft$p_table_info;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$table_info
*copyc ost$status
?? POP ??
*DECK DECK=PFP$R2_GET_CATALOG_SEGMENT EXPAND=FALSE
procedure [xref] pfp$r2_get_catalog_segment (path: pft$complete_path;
 var p_info: pft$p_table_info;
var status: ost$status);
?? push (listext := on) ??
*copyc pfd$complete_path
*copyc pfd$table_info
*copyc ost$status
?? pop ??
*DECK DECK=PFP$R2_GET_FAMILY_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_get_family_info {PFX2FI} (set_name: stt$set_name;
    catalog_info_selections: pft$catalog_info_selections;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STD$SET_NAME
*copyc PFD$CATALOG_INFO
*copyc OST$STATUS
?? POP ??
*DECK DECK=PFP$R2_GET_ITEM_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_get_item_info (
        path: pft$complete_path;
        system_privilege: boolean;
        group: pft$group;
        catalog_info_selections: pft$catalog_info_selections;
        file_info_selections: pft$file_info_selections;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_INFO
*copyc PFD$COMPLETE_PATH
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc pfe$internal_error_conditions
?? POP ??
*DECK DECK=PFP$R2_GET_MASTER_CATALOG_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_get_master_catalog_info (
        path: pft$complete_path;
        catalog_info_selections: pft$catalog_info_selections;
    VAR p_info: pft$p_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_INFO
*copyc PFD$COMPLETE_PATH
?? POP ??
*DECK DECK=PFP$R2_GET_MOVE_OBJ_DEVICE_INFO EXPAND=FALSE
  PROCEDURE [XREF] pfp$r2_get_move_obj_device_info
    (    move_object_info_p: ^pft$move_object_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pft$move_object_info
?? POP ??
*DECK DECK=PFP$R2_GET_MULTI_ITEM_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_get_multi_item_info (
        path: pft$complete_path;
        system_privilege: boolean;
        group: pft$group;
        catalog_info_selections: pft$catalog_info_selections;
        file_info_selections: pft$file_info_selections;
        p_cycle_reservation_criteria: {input} ^pft$cycle_reservation_criteria;
    VAR p_info: {i/o} pft$p_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pfe$internal_error_conditions
*copyc pft$cycle_reservation_criteria
?? POP ??
*DECK DECK=PFP$R2_GET_OBJECT_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_get_object_info
    (    family_location: pft$family_location;
         binary_mainframe_id: pmt$binary_mainframe_id;
         evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
         system_privilege: boolean;
         password_selector: pft$password_selector;
         subject_permit_count: ost$non_negative_integers;
         validation_ring: ost$valid_ring;
         p_validation_criteria: {i^/o^} ^fst$goi_validation_criteria;
         p_object_info: {output^} ^fst$goi_object_information;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc fst$goi_information_request
*copyc fst$goi_object_information
*copyc fst$goi_validation_criteria
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$password_selector
*copyc pfe$error_condition_codes
*copyc pft$family_location
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=PFP$R2_GET_OBJECT_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_get_object_information
    (    evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
         system_privilege: boolean;
         password_selector: pft$password_selector;
         subject_permit_count: ost$non_negative_integers;
         validation_ring: ost$valid_ring;
         p_validation_criteria: {i^/o^} ^fst$goi_validation_criteria;
     VAR p_object_information: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc ame$lfn_program_actions
*copyc fst$evaluated_file_reference
*copyc fst$goi_information_request
*copyc fst$goi_validation_criteria
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$password_selector
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$R2_GET_QUEUED_CATALOG_TABLE EXPAND=FALSE
  PROCEDURE [XREF] pfp$r2_get_queued_catalog_table (VAR p_table_info: pft$p_table_info;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$table_info
*copyc ost$status
?? POP ??
*DECK DECK=PFP$R2_GET_STORED_FMD EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_get_stored_fmd (
        path: pft$complete_path;
        cycle_selector: pft$cycle_selector;
    VAR catalog: boolean;
    VAR catalog_recreated_by_restore: boolean;
    VAR global_file_name: ost$binary_unique_name;
    VAR stored_fmd: dmt$stored_fmd;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$stored_fmd
*copyc osd$unique_name
*copyc ost$status
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$R2_GET_STORED_FMD_SIZE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_get_stored_fmd_size (
        path: pft$complete_path;
        cycle_selector: pft$cycle_selector;
    VAR device_class: rmt$device_class;
    VAR global_file_name: ost$binary_unique_name;
    VAR fmd_size: dmt$stored_fmd_size;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$stored_fmd_size
*copyc osd$unique_name
*copyc ost$status
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$R2_GET_VOL_CONDITION_LIST EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_get_vol_condition_list
    (    unique_volume_list: pft$unique_volume_list;
     VAR volume_condition_list: fst$volume_condition_list);

?? PUSH (LISTEXT := ON) ??
*copyc fst$volume_condition_list
*copyc pft$unique_volume_list
?? POP ??
*DECK DECK=PFP$R2_MARK_RELEASE_CANDIDATE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_mark_release_candidate
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         validation_ring: ost$valid_ring;
         archive_identification: pft$archive_identification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$archive_definitions
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
?? POP ??
*DECK DECK=PFP$R2_OVERHAUL_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_overhaul_catalog (
        path: pft$complete_path;
        catalog_overhaul_choices: pft$catalog_overhaul_choices;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$COMPLETE_PATH
*copyc PFT$OVERHAUL_CHOICES
?? POP ??
*DECK DECK=PFP$R2_OVERHAUL_SET EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_overhaul_set (
        set_name: stt$set_name;
        set_overhaul_choices: pft$set_overhaul_choices;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFT$OVERHAUL_CHOICES
*copyc STD$SET_NAME
?? POP ??
*DECK DECK=PFP$R2_PERMIT EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_permit (
        path: pft$complete_path;
        system_privilege: boolean;
        permit_level: pft$permit_level;
        group: pft$group;
        permit_selections: pft$permit_selections;
        share_requirements: pft$share_requirements;
        application_info: pft$application_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$complete_path
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc pft$permit_level
?? POP ??
*DECK DECK=PFP$R2_PERMIT_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_permit_catalog (
        path: pft$complete_path;
        system_privilege: boolean;
        permit_level: pft$permit_level;
        group: pft$group;
        permit_selections: pft$permit_selections;
        share_requirements: pft$share_requirements;
        application_info: pft$application_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$complete_path
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc pft$permit_level
?? POP ??
*DECK DECK=PFP$R2_PHYSICALLY_MOVE_CATALOG EXPAND=FALSE
  PROCEDURE [XREF] pfp$r2_physically_move_catalog
    (    path: pft$complete_path;
         move_object_info_p: ^pft$move_object_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$complete_path
*copyc pft$move_object_info
?? POP ??
*DECK DECK=PFP$R2_PHYSICALLY_MOVE_CYCLE EXPAND=FALSE
  PROCEDURE [XREF] pfp$r2_physically_move_cycle
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         move_object_info_p: ^pft$move_object_info;
     VAR cycle_number: pft$cycle_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$complete_path
*copyc pft$move_object_info
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$R2_PURGE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_purge (
        path: pft$complete_path;
        cycle_selector: pft$cycle_selector;
        password: pft$password;
        purge_cycle_options: pft$purge_cycle_options;
        system_privilege: boolean;
        validation_ring: ost$valid_ring;
    VAR authority: pft$authority;
    VAR device_class: rmt$device_class;
    VAR bytes_released: amt$file_byte_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc amt$file_byte_address
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$authority
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pft$purge_cycle_options
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$R2_PURGE_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_purge_catalog (
        path: pft$complete_path;
        system_privilege: boolean;
        delete_option: pft$delete_option;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$complete_path
*copyc pfe$error_condition_codes
*copyc pft$delete_option
?? POP ??
*DECK DECK=PFP$R2_PURGE_OBJECT EXPAND=FALSE
  PROCEDURE [XREF] pfp$r2_purge_object
    (    path: pft$complete_path;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$complete_path
?? POP ??
*DECK DECK=PFP$R2_PUT_ARCHIVE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_put_archive_entry
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
         p_archive_array_entry: pft$p_archive_array_entry;
         p_amd: pft$p_amd;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$archive_definitions
*copyc pfd$catalog_info
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
?? POP ??
*DECK DECK=PFP$R2_PUT_ARCHIVE_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_put_archive_info
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         p_info_record: pft$p_info_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
?? POP ??
*DECK DECK=PFP$R2_PUT_CATALOG_MEDIA_INFO EXPAND=FALSE
  PROCEDURE [XREF] pfp$r2_put_catalog_media_info
    (    catalog_path: pft$complete_path;
         p_catalog_group: pft$p_info_record;
     VAR restore_catalog_status: pft$restore_catalog_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$complete_path
*copyc pft$restore_catalog_status
?? POP ??
*DECK DECK=PFP$R2_PUT_CATALOG_SEGMENT EXPAND=FALSE
  PROCEDURE [XREF] pfp$r2_put_catalog_segment
    (    path: pft$path;
         p_catalog_segment: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$R2_PUT_CYCLE_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_put_cycle_info
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         cycle_array_entry: pft$cycle_array_entry_version_2;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$complete_path
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$R2_PUT_FAMILY_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_put_family_info (
        set_name: stt$set_name;
        family_name: pft$name;
        p_info_record: pft$p_info_record;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_INFO
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc STD$SET_NAME
?? POP ??
*DECK DECK=PFP$R2_PUT_FILE_MEDIA_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_put_file_media_info (
         file_path: pft$complete_path;
         p_file_info_record: pft$p_info_record;
         backup_file_version: pft$backup_file_version;
     VAR file_entry_recreated: boolean;
     VAR cycles_restored_with_fmd: pft$cycle_count;
     VAR cycles_restored_without_fmd: pft$cycle_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pft$cycle_count
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
?? POP ??
*DECK DECK=PFP$R2_PUT_ITEM_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_put_item_info
    (    backup_file_version: pft$backup_file_version;
         p_info_record: {input^} ^pft$info_record;
         family_location: pft$family_location;
         path: pft$complete_path;
         permit_level: pft$permit_level;
         selection_criteria: put$selection_criteria;
         restore_archive_information: boolean;
     VAR audit_restorations: {i/o} boolean;
     VAR all_permits_restored: {i/o} boolean;
     VAR p_auditable_permits: {server only} ^pft$auditable_permits;
     VAR p_auditable_cycles: {server only} ^pft$auditable_cycles;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$complete_path
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pft$auditable_cycles
*copyc pft$auditable_permits
*copyc pft$family_location
*copyc pft$permit_level
*copyc pud$selection_criteria
?? POP ??
*DECK DECK=PFP$R2_PUT_MASTER_CATALOG_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_put_master_catalog_info (
        set_name: stt$set_name;
        family_name: pft$name;
        master_catalog_name: pft$name;
        p_info_record: pft$p_info_record;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_INFO
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc STD$SET_NAME
?? POP ??
*DECK DECK=PFP$R2_RECREATE_SYSTEM_CATALOG EXPAND=FALSE
  PROCEDURE [XREF] pfp$r2_recreate_system_catalog
    (VAR status: ost$status);

*DECK DECK=PFP$R2_RELEASE_DATA EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_release_data
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         p_release_data_info: {i/o} ^pft$release_data_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pft$release_data_info
?? POP ??
*DECK DECK=PFP$R2_REPLACE_ARCHIVE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_replace_archive_entry
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
         p_archive_array_entry: pft$p_archive_array_entry;
         p_amd: pft$p_amd;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$archive_definitions
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
?? POP ??
*DECK DECK=PFP$R2_REPLACE_REM_MEDIA_FMD EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_replace_rem_media_fmd
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         p_file_media_descriptor: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$complete_path
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$R2_RESOLVE_PATH EXPAND=FALSE
  PROCEDURE [XREF] pfp$r2_resolve_path
    (    path: pft$complete_path;
         system_privilege: boolean;
     VAR cycle_reference: {i/o} fst$cycle_reference;
     VAR path_resolution: fst$path_resolution;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fse$system_conditions
*copyc fst$cycle_reference
*copyc fst$path_resolution
*copyc ost$status
*copyc pfd$complete_path
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$R2_SAVE_RELEASED_FILE_LABEL EXPAND=FALSE

  PROCEDURE [XREF] pfp$r2_save_released_file_label
    (    path: pft$complete_path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         p_file_label: {input^} ^fmt$file_label;
         validation_ring: ost$valid_ring;
         update_cycle_statistics: boolean;
     VAR p_save_label_audit_info: {i/o} ^pft$save_label_audit_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$file_label
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$complete_path
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pft$save_label_audit_info
?? POP ??
*DECK DECK=PFP$R2_VALIDATE_CATALOG_EXISTS EXPAND=TRUE
  PROCEDURE [XREF] pfp$r2_validate_catalog_exists
    (    family_path: pft$complete_path;
     VAR status: ost$status);

*copyc ost$status
*copyc pfd$complete_path
*DECK DECK=PFP$R2_VALIDATE_PASSWORD EXPAND=FALSE
  PROCEDURE [XREF] pfp$r2_validate_password (
    path: pft$complete_path;
    password: pft$password;
    VAR status: ost$status);
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc ost$status
*DECK DECK=PFP$R3_APPEND_REM_MEDIA_VSN EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_append_rem_media_vsn
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         volume_descriptor: rmt$volume_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc rmt$volume_descriptor
?? POP ??
*DECK DECK=PFP$R3_ATTACH EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_attach {PFX3ATT} (lfn: amt$local_file_name;
        path: pft$path;
        cycle_selector: pft$cycle_selector;
        password: pft$password;
        usage_selections: pft$usage_selections;
        share_selections: pft$share_selections;
    VAR cycle_number: pft$cycle_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc PFE$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=PFP$R3_ATTACH_OR_CREATE_FILE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_attach_or_create_file (
        validation_ring: ost$valid_ring;
        exception_selection_info: pft$exception_selection_info;
        p_attachment_options: {input} ^fst$attachment_options;
        p_file_label: {input} fmt$p_file_label;
        retention: fst$retention;
        retrieve_option: pft$retrieve_option;
        site_archive_option: pft$site_archive_option;
        site_backup_option: pft$site_backup_option;
        site_release_option: pft$site_release_option;
    VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
    VAR allowed_access: fst$file_access_options; {phase 1}
    VAR selected_access: fst$file_access_options;
    VAR required_sharing: fst$file_access_options; {phase 1}
    VAR selected_sharing: fst$file_access_options;
    VAR action_taken: pft$attach_or_create_action;
    VAR label_used: boolean;
    VAR device_class: rmt$device_class;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc fmt$file_label
*copyc fst$attachment_options
*copyc fst$evaluated_file_reference
*copyc fst$file_access_options
*copyc fst$retention
*copyc osd$virtual_address
*copyc ost$status
*copyc pfe$error_condition_codes
*copyc pft$attach_or_create_action
*copyc pft$exception_selection_info
*copyc pft$retrieve_option
*copyc pft$site_archive_option
*copyc pft$site_backup_option
*copyc pft$site_release_option
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$R3_CHANGE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_change
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         change_list: pft$change_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$R3_CHANGE_CATALOG_FLUSH_OPT EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_change_catalog_flush_opt
    (    flush_catalogs: boolean);

*DECK DECK=PFP$R3_CHANGE_CYCLE_DAMAGE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_change_cycle_damage
    (    file: fst$file_reference;
         password: pft$password;
         new_damage_symptoms: fst$cycle_damage_symptoms;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$cycle_damage_symptoms
*copyc fst$file_reference
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??

*DECK DECK=PFP$R3_CHANGE_CYCLE_DAMAGED EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_change_cycle_damaged
    (    file: fst$file_reference;
         password: pft$password;
         new_damage_symptoms: fst$cycle_damage_symptoms;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$cycle_damage_symptoms
*copyc fst$file_reference
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??

*DECK DECK=PFP$R3_CHANGE_CYCLE_DATE_TIME EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_change_cycle_date_time
    (    file: fst$file_reference;
         password: pft$password;
         p_new_access_date_time: ^fst$date_time;
         p_new_creation_date_time: ^fst$date_time;
         p_new_modification_date_time: ^fst$date_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fse$vxve_exception_conditions
*copyc fst$date_time
*copyc fst$file_reference
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$R3_CHANGE_FILE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_change_file
    (    file: fst$file_reference;
         password: pft$password;
         file_changes: ^fst$file_changes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_changes
*copyc fst$file_reference
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$R3_CHANGE_RES_TO_RELEASABLE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_change_res_to_releasable
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$R3_CLEAR_MOVE_CLASSES_LOCK EXPAND=FALSE
*DECK DECK=PFP$R3_DEFINE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_define
    (    lfn: amt$local_file_name;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         retention: pft$retention;
         log: pft$log;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc ost$status
?? POP ??
*DECK DECK=PFP$R3_DEFINE_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_define_catalog
    (    path: pft$path;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
*copyc ost$status
*copyc pfe$error_condition_codes
?? POP ??

*DECK DECK=PFP$R3_DEFINE_DATA EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_define_data (
         lfn: amt$local_file_name;
         path: pft$path;
         cycle_selector: pft$cycle_selector;
         update_cycle_statistics: boolean;
         password_selector: pft$password_selector;
         p_mass_storage_request_info: ^fmt$mass_storage_request_info;
         p_volume_list: ^array [1 .. *] of rmt$recorded_vsn;
         purge_cycle_options: pft$purge_cycle_options;
         replace_cycle_data: boolean;
         restore_selections: put$restore_data_selections;
     VAR mandated_modification_time: {i/o} pft$mandated_modification_time;
     VAR data_residence: pft$data_residence;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc fmt$mass_storage_request_info
*copyc ost$status
*copyc pfd$mandated_modification_time
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pft$data_residence
*copyc put$restore_data_selections
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=PFP$R3_DEFINE_MASS_STORAGE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_define_mass_storage
     (   path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         validation_ring: ost$valid_ring;
         fs_retention: fst$retention;
         log: pft$log;
         retrieve_option: pft$retrieve_option;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc fmt$mass_storage_request_info
*copyc fst$retention
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pft$retrieve_option
*copyc pft$site_archive_option
*copyc pft$site_backup_option
*copyc pft$site_release_option
*copyc rme$request_mass_storage
?? POP ??
*DECK DECK=PFP$R3_DEFINE_MASS_STORAGE_CAT EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_define_mass_storage_cat
    (    catalog: pft$path;
         catalog_type: pft$catalog_types;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$mass_storage_request_info
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pft$catalog_types
*copyc rmc$condition_code_limits
*copyc rme$request_mass_storage
?? POP ??
*DECK DECK=PFP$R3_DEFINE_REMOVABLE_MEDIA EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_define_removable_media
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         validation_ring: ost$valid_ring;
         retention: pft$retention;
         log: pft$log;
         device_class: rmt$device_class;
         p_removable_media_req_info: {input} ^fmt$removable_media_req_info;
         p_volume_list: {input} ^rmt$volume_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$removable_media_req_info
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc rmd$volume_declarations
*copyc rme$request_tape
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$R3_DELETE_ALL_ARCH_ENTRIES EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_delete_all_arch_entries
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$R3_DELETE_ARCHIVE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_delete_archive_entry
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$archive_definitions
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$R3_DELETE_CATALOG_PERMIT EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_delete_catalog_permit
    (    path: pft$path;
         group: pft$group;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$R3_DELETE_PERMIT EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_delete_permit
    (    path: pft$path;
         group: pft$group;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$R3_FLUSH_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_flush_catalog
    (    evaluated_file_reference: fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=PFP$R3_GET_FAMILY_SET EXPAND=FALSE
  PROCEDURE [XREF] pfp$r3_get_family_set
    (    family_name: ost$name;
     VAR set_name: stt$set_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc std$set_name
?? POP ??
*DECK DECK=PFP$R3_GET_ITEM_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_get_item_info
    (    path: pft$path;
         group: pft$group;
         catalog_info_selections: pft$catalog_info_selections;
         file_info_selections: pft$file_info_selections;
     VAR p_info: pft$p_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
?? POP ??
*DECK DECK=PFP$R3_GET_MOVE_OBJ_DEVICE_INFO EXPAND=FALSE
  PROCEDURE [XREF] pfp$r3_get_move_obj_device_info
    (    move_object_info_p: ^pft$move_object_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pft$move_object_info
?? POP ??
*DECK DECK=PFP$R3_GET_MULTI_ITEM_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_get_multi_item_info
    (    path: pft$path;
         group: pft$group;
         catalog_info_selections: pft$catalog_info_selections;
         file_info_selections: pft$file_info_selections;
         p_cycle_reservation_criteria: {input} ^pft$cycle_reservation_criteria;
     VAR p_info: pft$p_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pft$cycle_reservation_criteria
?? POP ??
*DECK DECK=PFP$R3_GET_OBJECT_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_get_object_information
    (    evaluated_file_reference: fst$evaluated_file_reference;
         information_request: fst$goi_information_request;
         p_validation_criteria: {i/o^} ^fst$goi_validation_criteria;
     VAR p_object_information: {i/o} ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc ame$lfn_program_actions
*copyc fst$evaluated_file_reference
*copyc fst$goi_information_request
*copyc fst$goi_object_information
*copyc fst$goi_validation_criteria
*copyc ost$status
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$R3_MARK_RELEASE_CANDIDATE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_mark_release_candidate
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         caller_id: ost$caller_identifier;
         archive_identification: pft$archive_identification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$caller_identifier
*copyc ost$status
*copyc pfd$archive_definitions
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$R3_PERMIT EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_permit
    (    path: pft$path;
         group: pft$group;
         permit_selections: pft$permit_selections;
         share_requirements: pft$share_requirements;
         application_info: pft$application_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfd$permanent_file_attributes
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$R3_PERMIT_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_permit_catalog
    (    path: pft$path;
         group: pft$group;
         permit_selections: pft$permit_selections;
         share_requirements: pft$share_requirements;
         application_info: pft$application_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$R3_PHYSICALLY_MOVE_CATALOG EXPAND=FALSE
  PROCEDURE [XREF] pfp$r3_physically_move_catalog
    (    path: pft$path;
         move_object_info_p: ^pft$move_object_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pft$move_object_info
?? POP ??
*DECK DECK=PFP$R3_PHYSICALLY_MOVE_CYCLE EXPAND=FALSE
  PROCEDURE [XREF] pfp$r3_physically_move_cycle
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         move_object_info_p: ^pft$move_object_info;
     VAR cycle_number: pft$cycle_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$complete_path
*copyc pft$move_object_info
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$R3_PURGE EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_purge
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         purge_cycle_options: pft$purge_cycle_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pft$purge_cycle_options
?? POP ??
*DECK DECK=PFP$R3_PURGE_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_purge_catalog
    (    path: pft$path;
         delete_option: pft$delete_option;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pft$delete_option
?? POP ??
*DECK DECK=PFP$R3_PUT_ARCHIVE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_put_archive_entry
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         p_archive_array_entry: pft$p_archive_array_entry;
         p_amd: pft$p_amd;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$archive_definitions
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
?? POP ??


*DECK DECK=PFP$R3_PUT_ARCHIVE_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_put_archive_info
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         p_archive_info: pft$p_info_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$archive_definitions
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$R3_PUT_CYCLE_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_put_cycle_info
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         cycle_array_entry: pft$cycle_array_entry_version_2;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$R3_PUT_ITEM_INFO EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_put_item_info
    (    path: pft$path;
         p_info_record: pft$p_info_record;
         restore_archive_information: boolean;
         cycle_selection_criteria: put$selection_criteria;
         backup_file_version: pft$backup_file_version;
     VAR all_permits_restored: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pud$selection_criteria
?? POP ??
*DECK DECK=PFP$R3_RELEASE_DATA EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_release_data
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         p_release_data_info: {i/o} ^pft$release_data_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pft$release_data_info
?? POP ??
*DECK DECK=PFP$R3_REPLACE_ARCHIVE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_replace_archive_entry
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
         p_archive_array_entry: pft$p_archive_array_entry;
         p_amd: pft$p_amd;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$archive_definitions
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$R3_REPLACE_REM_MEDIA_FMD EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_replace_rem_media_fmd
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         p_file_media_descriptor: {iinput} ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$R3_RESOLVE_PATH EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_resolve_path
    (    path: pft$path;
     VAR cycle_reference: {i/o} fst$cycle_reference;
     VAR path_resolution: fst$path_resolution;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fse$path_exception_conditions
*copyc fst$cycle_reference
*copyc fst$path_resolution
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$R3_SAVE_RELEASED_FILE_LABEL EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_save_released_file_label
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         update_cycle_statistics: boolean;
         password_selector: pft$password_selector;
         p_file_label_container: { input } fmt$p_file_label;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$file_label
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pft$served_family_locator
?? POP ??
*DECK DECK=PFP$R3_SET_MOVE_CLASSES_LOCK EXPAND=FALSE
*DECK DECK=PFP$R3_UTILITY_ATTACH EXPAND=FALSE

  PROCEDURE [XREF] pfp$r3_utility_attach (lfn: amt$local_file_name;
        path: pft$path;
        cycle_selector: pft$cycle_selector;
        password: pft$password;
        usage_selections: pft$usage_selections;
        share_selections: pft$share_selections;
        allowed_cycle_damage_symptoms: fst$cycle_damage_symptoms;
    VAR cycle_damage_symptoms: fst$cycle_damage_symptoms;
    VAR cycle_number: pft$cycle_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc fst$cycle_damage_symptoms
*copyc OST$STATUS
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
*copyc PFE$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=PFP$REATTACH_FILES_FOR_CLIENT EXPAND=FALSE

  PROCEDURE [XREF] pfp$reattach_files_for_client
    (    client_mainframe_id: pmt$binary_mainframe_id;
         p_old_attached_pf_table: ^pft$attached_pf_table;
     VAR files_reattached : ost$non_negative_integers;
     VAR files_not_reattached : ost$non_negative_integers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
*copyc ost$status
*copyc pfd$attached_pf_table
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=PFP$REATTACH_PERMANENT_FILE EXPAND=FALSE

  PROCEDURE [XREF] pfp$reattach_permanent_file
    (    apfid: pft$attached_permanent_file_id;
         device_class: rmt$device_class;
         internal_name: pft$internal_name;
         mainframe_id: pmt$binary_mainframe_id;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
     VAR new_sfid: gft$system_file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc ost$status
*copyc pfd$attached_permanent_file_id
*copyc pfd$internal_name
*copyc pfd$permanent_file_attributes
*copyc pmt$binary_mainframe_id
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$REATTACH_RESERVED_CYCLES EXPAND=FALSE

   PROCEDURE [XREF] pfp$reattach_reserved_cycles
      (    mainframe_id: pmt$binary_mainframe_id;
       VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$binary_mainframe_id
?? POP ??

*DECK DECK=PFP$REATTACH_SERVER_FILE EXPAND=FALSE
  PROCEDURE [XREF] pfp$reattach_server_file
    (    apfid: pft$attached_permanent_file_id;
         internal_cycle_name: pft$internal_name;
         client_mainframe_id: pmt$binary_mainframe_id;
         usage_selections: pft$usage_selections;
         share_selections: pft$share_selections;
     VAR new_sfid: gft$system_file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc ost$status
*copyc pfd$attached_permanent_file_id
*copyc pfd$complete_path
*copyc pfd$permanent_file_attributes
*copyc pmt$binary_mainframe_id
?? POP ??

*DECK DECK=PFP$RECONCILE_FMD EXPAND=FALSE

  PROCEDURE [XREF] pfp$reconcile_fmd
    (    p_path: ^pft$complete_path;
         internal_cycle_name: pft$internal_name;
         existing_sft_entry: dmt$existing_sft_entry,
         update_catalog: boolean;
         p_catalog_file: {i^/o^} pft$p_catalog_file;
         p_cycle: {i^/o^} pft$p_cycle;
     VAR p_physical_fmd: {i^/o^} pft$p_physical_fmd;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$existing_sft_entry
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$complete_path
?? POP ??
*DECK DECK=PFP$RECORD_CATALOG_ERROR EXPAND=TRUE
?? NEWTITLE := 'pfp$record_catalog_error', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fst$path
*copyc pfe$error_condition_codes
*copyc fsp$build_file_ref_from_elems
*copyc osp$append_status_file
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
?? POP ??

    PROCEDURE pfp$record_catalog_error
      (    catalog_path: ^pft$path;
           command_name: string ( * <= osc$max_string_size );
       VAR number_of_errors: integer;
       VAR status: ost$status);

      VAR
        catalog_reference: fst$path,
        ignore_status: ost$status,
        recorded_status: ost$status;

      number_of_errors := number_of_errors + 1;
      fsp$build_file_ref_from_elems (catalog_path, catalog_reference, ignore_status);
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$skipped_catalog, command_name,
            recorded_status);
      osp$append_status_file (osc$status_parameter_delimiter, catalog_reference, recorded_status);
      osp$generate_error_message (recorded_status, ignore_status);
      osp$generate_error_message (status, ignore_status);

    PROCEND pfp$record_catalog_error;

?? OLDTITLE ??
*DECK DECK=PFP$RECORD_DM_FILE_PARAMETERS EXPAND=FALSE

  PROCEDURE [XREF] pfp$record_dm_file_parameters
    (    p_path: ^pft$complete_path;
         p_cycle_number: ^pft$cycle_number;
         system_file_id: gft$system_file_identifier;
         device_class: rmt$device_class;
         p_removable_media_req_info: {input^} ^fmt$removable_media_req_info;
         p_volume_list: {input^} ^rmt$volume_list;
         p_catalog_heap: {output^} pft$p_catalog_heap;
     VAR p_physical_fmd: {output} pft$p_physical_fmd;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc fmt$removable_media_req_info
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$complete_path
*copyc rmt$device_class
*copyc rmt$volume_list
?? POP ??
*DECK DECK=PFP$RECOVER_SYSTEM_CATALOGS EXPAND=TRUE
PROCEDURE (HIDDEN) pfp$recover_system_catalogs (
  restore_excluded_file_cycles, refc: list of key
      none
      (no_data_defined, ndd)
      (volume_unavailable, vu)
      (media_missing, mm)
    keyend = (no_data_defined,media_missing)
  vsn_prefix, vsnp: any of
      name 1..5
      string 1..5
      integer 0..99999
    anyend = $optional
  vsn_count, vsnc: integer 1..11881376 = 9
  vsn_suffix, vsns: any of
      name 1..5
      string 1..5
      integer 0..99998
    anyend = $optional
  increment_scheme, is: key
      (alphabetic, a)
      (decimal, d)
    keyend = decimal
  vsn_list, vsnl: list of any of
      string 1..6
      name 1..6
    anyend = $optional
  file_label_type, flt: key
      (labeled, labelled, l)
      (unlabeled, unlabelled, u)
    keyend = labeled
  type, t: key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = mt9$6250
  output, o: file = $null
  status)

  "$FORMAT=OFF
  VAR
    backup_file: file=$fname('$local.'//$unique())
    restore_status: status
    volume_list: list 1 .. $max_list of string 6
  VAREND

  "$FORMAT=ON"

  IF $specified(vsn_list) THEN
    delete_variable volume_list
    volume_list = vsn_list
  ELSE
    pup$construct_volume_list vsn_count=vsn_count vsn_prefix=vsn_prefix increment_scheme=increment_scheme ..
          vsn_suffix=vsn_suffix volume_list=volume_list
  IFEND

  IF NOT $variable(cmv$deadstart_simulation, defined) THEN
    RESTORE_PERMANENT_FILES
      set_restore_missing_catalogs operation=start
    QUIT
  IFEND

  request_magnetic_tape file=backup_file type=type ring=no ..
        recorded_vsn=volume_list
  set_file_attributes backup_file file_label_type=file_label_type
  IF NOT $variable(cmv$deadstart_simulation, defined) THEN
    vedisplay display_option=tape_mount
  IFEND

  TASK ring=3
    RESTORE_PERMANENT_FILES list=output
      set_restore_options require_matching_modification=false update_cycle_statistics=false..
            restore_archive_information=TRUE
      IF NOT $variable(cmv$deadstart_simulation, defined) THEN
        restore_missing_catalogs backup_file=backup_file ..
              restore_excluded_file_cycles=restore_excluded_file_cycles status=restore_status
      IFEND
    QUIT
    change_file_attributes file=output ring_attributes=(11 11 11)
  TASKEND

  IF NOT $variable(cmv$deadstart_simulation, defined) THEN
    vedisplay display_option=null
  IFEND

  delete_file backup_file

  EXIT_PROC WITH restore_status

PROCEND pfp$recover_system_catalogs

*DECK DECK=PFP$RECOVER_SYSTEM_SET EXPAND=TRUE
PROCEDURE (HIDDEN) pfp$recover_system_set (
  set_name, sn: name = $required
  status)

" PURPOSE: To automate the recovery of existing system set members when the
"          $SYSTEM master catalog has been lost.
"
" CONSTRAINTS: This procedure cannot submit batch jobs or print files to
"              accomplish the recovery of the system set due to the fact
"              the subcatalogs for queued files are lost.
"
" This procedure is automatically executed by the NOS/VE deadstart process
" as a result of:
"
"   1) INITIALIZE_SYSTEM_DEVICE ,,RECOVER_SYSTEM_SET
"      In this case the $SYSTEM master catalog may be on a surviving class J
"      catalog volume.  Deadstart re-creates the $SYSTEM root catalog, family
"      catalog and master catalog.  All are marked as PARENT_RECREATED to
"      authorize the restoration of unreconciled catalogs; this recovers all
"      of the $SYSTEM files and catalogs not actually contained on the system
"      device.  To recover the original $SYSTEM master catalog that is
"      presumed to exist on the class J volume, it is necessary to delete the
"      master catalog $SYSTEM and all of its contents.  This also has the
"      effect of deleting the $SYSTEM family catalog.  Recovering the $SYSTEM
"      master catalog allows us to recover all files and catalogs created in
"      that catalog since the last catalog backup was taken.
"
"   2) A continuation deadstart that is missing the $SYSTEM master catalog.
"      This case differs from the preceding one in that the class J volume
"      containing the $SYSTEM master catalog has been DOWNed at a continuation
"      deadstart.  Deadstart will detect that the $SYSTEM master catalog is
"      missing and re-create it.  It will also set the PARENT_RECREATED
"      boolean in the $SYSTEM catalog to authorize the restoration of its
"      contents.  Unlike (1) above, there is no advantage to deleting the
"      $SYSTEM catalog because it exists on no other volume that is
"      accessible.
"
"      Further, we cannot deadstart without the $SYSTEM master catalog; thus
"      we are unable to wait for the class J volume to be reinstated.
"
" This procedure should not be manually executed because the two circumstances
" identified above have caused the family and master catalog $SYSTEM to be
" marked as re-created for the purposes of recovering catalogs and files on
" volumes other than the system device.  Executing this procedure at other
" times would cause the contents of the master catalog $SYSTEM to be deleted
" without hope of recovering its contents on other volumes.

  "$FORMAT=OFF
  VAR
      catalog_info: file = $fname($unique())
      echo_file: file = $fname($unique())
      extended_access_privilege: integer 0 .. 15
      ignore_status: status
      lost_cycles: file = $fname($unique())
      missing_catalogs:integer
      menu_items: list 1..5 of name
      missing_files: integer
      missing_count: integer = 9999 "Assume missing files"
      osv$deadstart_phase: (XREF) string 0 .. $max_name
      osv$reinitialize_system_device: (XREF) boolean
      restore_listing: file = $fname($unique())
      rss_report_file:file
      rss_status: status
      system_job: boolean
      system_master_catalog: file
  VAREND
  "$FORMAT=ON"

" Save current command and object lists in case this proc abends"
" Reduce the command and object lists to allow the corresponding permanent
" files to be deleted.

  PUSH command_list
  PUSH file_connections
  PUSH program_attributes
  PUSH working_catalog

  IF $variable(cmv$deadstart_simulation, defined) THEN
    extended_access_privilege=11
    system_master_catalog=cmv$rss_working_catalog
    system_job=true
  ELSE
    extended_access_privilege=3
    system_master_catalog=:$system.$system
    system_job=$job(system)
  IFEND

  set_program_attributes delete_library=all

  " The display of unreconciled files requires the use of BACPF which is
  " packaged on $system.osf$builtin_library.  A copy of this library to a
  " temporary file is required to allow access to BACPF while allowing the
  " $SYSTEM master catalog to be deleted.
  copy_file $system.osf$builtin_library $local.$builtin_library
  change_file_attributes $local.$builtin_library ring_attributes=(..
        extended_access_privilege, 13, 13)

  "The procedures that get involved in the reinitialization of the system device
  "use commands that are packaged in the SOU library.  So a copy of this library
  "to a temporary file is required before the $system master catalog is deleted.
  copy_file $system.osf$sou_library $local.$sou_library
  change_file_attributes $local.$sou_library ring_attributes=(..
        extended_access_privilege, 13, 13)

  delete_command_list_entry entry=all "allow all of $SYSTEM to be deleted"

  $system.create_command_list_entry entry=($local.osf$ds_library ..
        $local.$builtin_library $local.$sou_library $system)

  set_working_catalog system_master_catalog status=ignore_status

  rss_report_file=$fname('recover_system_set_report_'//$date('y2j3'))

  IF system_job AND ($ring = extended_access_privilege) THEN

" Task to ring 11 to allow pause-break (STOP) from System Console.  This proc
" starts running in ring 3 and execution in this ring does not permit
" interactive interruption.  This command cannot be executed until the command
" list has been adjusted to allow deletion of permanent files that may have
" been in the command list.

    TASK ring=11

      create_file_connection $errors $job_log status=ignore_status
      create_file_connection $output $job_log status=ignore_status
      create_file_connection $response $job_log status=ignore_status
      create_file_connection $echo echo_file status=ignore_status

      IF osv$deadstart_phase = 'INSTALL' AND osv$reinitialize_system_device ..
            THEN
        rap$display_message message_module=recover_system_set ..
              message_name=initialize_system_device to=$output
      ELSE
        rap$display_message message_module=recover_system_set ..
              message_name=initialize_system_catalog to=$output
      IFEND

      rap$display_message message_module=recover_system_set ..
            message_name=rss_consequences to=$output
      rap$press_next "wait for operator to read text and respond"

" Delete the contents of the master catalog $SYSTEM to allow files created in
" the $SYSTEM catalog since the catalog backup to be recovered by the catalog
" restoration process. Optionally delete the master catalog itself.

      TASK ring=extended_access_privilege
        BACKUP_PERMANENT_FILES backup_file=$null
          include_empty_catalogs delete_catalog=true
          IF osv$reinitialize_system_device THEN
            IF NOT $variable(cmv$deadstart_simulation, defined) THEN
              include_master_catalogs delete_master_catalogs=true
            IFEND
          IFEND
          IF NOT $variable(cmv$deadstart_simulation, defined) THEN
            delete_catalog_contents catalog=$working_catalog ..
                  status=ignore_status
          IFEND

        QUIT
      TASKEND

    menu_items=$list_of(display_active_volumes, ..
          display_command_information restore_only_catalogs, ..
          restore_catalogs_and_files)

    " Turn off the flushing of catalogs to improve the performance of catalog restoration"
    " This is safe because modified pages are flushed by the TERMINATE_SYSTEM at the end"
    change_catalog_access flush_catalogs=off
    resmc_loop: ..
      LOOP
        choice=''
        rap$prompt_via_menu menu_module=rss_resuc_menu ..
              menu_selections=menu_items selection_chosen=choice
        cmp$display_menu_selection menu_selection=choice ..
              menu_items=menu_items output=$job_log

        IF choice = 'RESTORE_ONLY_CATALOGS' THEN
          refc='none'
          chacc_text='recovered'
        ELSEIF choice = 'RESTORE_CATALOGS_AND_FILES' THEN
          refc='(media_missing no_data_defined)'
          chacc_text='recovered and restored'
        ELSEIF choice = 'DISPLAY_ACTIVE_VOLUMES' THEN
          display_active_volumes output=$output ..
                relevant_classes=system_defined_classes sets=all
          number_of_active_volumes=0
          LOGICAL_CONFIGURATION_UTILITY
            FOR each set in $active_sets() DO
              number_of_active_volumes=number_of_active_volumes + ..
                   $size($active_set_members(set))
            FOREND
          QUIT
          rap$display_message message_module=recover_system_set ..
                message_name=active_volume_summary ..
                message_parameters=$string(number_of_active_volumes) ..
                to=$output
          rap$press_next "wait for operator to read text and respond"
          CYCLE resmc_loop
        ELSEIF choice = 'DISPLAY_COMMAND_INFORMATION' THEN
          display_command_information command=pfp$recover_system_catalogs ..
                output=$output
          rap$press_next "wait for operator to read text and respond"
          CYCLE resmc_loop
        ELSEIF choice = 'QUIT' THEN
          EXIT resmc_loop
        ELSE
          CYCLE resmc_loop
        IFEND

        rap$display_message message_module=recover_system_set ..
              message_name=catalog_restoration to=$output

        rap$display_message message_module=recover_system_set ..
              message_name=parameter_prompting to=$output

        rap$press_next "wait for operator to read text and respond"
        include_line statement_list= ..
'?pfp$recover_system_catalogs restore_excluded_file_cycles='//refc//..
' output=restore_listing.$eoi' status=rss_status

        EXIT resmc_loop WHEN rss_status.normal

        rap$display_message message_module=recover_system_set ..
              message_name=abnormal_status to=$output
        display_value value=rss_status output=$output
        rap$press_next "wait for operator to read text and respond"

" Add quit to the menu items to allow the process to continue without
" restoring more catalogs.

        menu_items=$list_of(display_active_volumes, ..
              display_command_information restore_only_catalogs, ..
              restore_catalogs_and_files, quit)
      LOOPEND resmc_loop

" Terminate the window for restoration of missing catalogs"

      IF NOT $variable(cmv$deadstart_simulation, defined) THEN
        IF $job(system) THEN
          RESTORE_PERMANENT_FILES
            set_restore_missing_catalogs operation=end status=ignore_status
          QUIT
        IFEND
      IFEND

" Delete the damage conditions that were set for the recovered/restored files
" in the $SYSTEM master catalog to allow the products and files to be
" attachable - in particular EDIT_FILE which is used in the next step.

      rap$display_message message_module=recover_system_set ..
            message_name=deleting_$system_damage ..
            message_parameters=chacc_text to=$output

      TASK ring=extended_access_privilege
        change_catalog_contents catalog=$working_catalog ..
              delete_damage_conditions=(parent_catalog_restored ..
              respf_modification_mismatch) output=catalog_info.$eoi status=ignore_status
        change_file_attributes catalog_info ring_attributes=(11, 11, 11) status=ignore_status
      TASKEND

" Optionally restore missing files, if there are any"

    file_restore_loop: ..
      LOOP
        IF rss_status.normal AND (missing_count = 0) THEN
          rap$display_message message_module=recover_system_set ..
                message_name=all_is_well to=$output
          EXIT file_restore_loop
        ELSE
          choice=''
          menu_items=$list_of(display_unreconciled_files, ..
                restore_unreconciled_files, display_active_volumes, ..
                display_command_information, quit)
          rap$prompt_via_menu menu_module=rss_resuf_menu ..
                menu_selections=menu_items selection_chosen=choice
          cmp$display_menu_selection menu_selection=choice ..
                menu_items=menu_items output=$job_log

          IF choice = 'DISPLAY_UNRECONCILED_FILES' THEN
            IF NOT $file(lost_cycles, opened) THEN
              rap$display_message message_module=recover_system_set ..
                    message_name=determine_unreconciled_files to=$output
              pup$generate_backup_listing set_name=set_name ..
                    backup_listing= lost_cycles status=rss_status
            IFEND
            IF NOT rss_status.normal THEN
              display_value value=rss_status output=$output
              rap$press_next "wait for operator to read text and respond"
              CYCLE file_restore_loop
            IFEND
            pfp$count_unreconciled_files backup_listing=lost_cycles ..
                  missing_catalogs=missing_catalogs ..
                  missing_files=missing_files status=rss_status
            IF NOT rss_status.normal THEN
              display_value value=rss_status output=$output
              rap$press_next "wait for operator to read text and respond"
              CYCLE file_restore_loop
            IFEND
            missing_count=missing_catalogs + missing_files
            IF missing_count > 0 THEN
              rap$display_message message_module=recover_system_set ..
                    message_name=unreconciled_files, message_parameters= (''..
//missing_files, ''//missing_catalogs) to=$output
              rap$press_next "wait for operator to read text and respond"

              choice=''
              menu_items=$list_of(display_missing_system_set, ..
                    continue_with_restoration)
              rap$prompt_via_menu menu_module=display_missing_menu ..
                    menu_selections=menu_items selection_chosen=choice
              cmp$display_menu_selection menu_selection=choice ..
                    menu_items=menu_items output=$job_log
              IF choice='DISPLAY_MISSING_SYSTEM_SET' THEN
                pfp$display_unreconciled_files backup_listing=lost_cycles ..
                      output=$output status=rss_status
                IF rss_status.normal THEN
                  rap$press_next "wait for operator to read text and respond"
                ELSE
                  display_value value=rss_status output=$output
                  rap$press_next "wait for operator to read text and respond"
                IFEND
              IFEND
            IFEND
          ELSEIF choice = 'RESTORE_UNRECONCILED_FILES' THEN
            rap$display_message message_module=recover_system_set ..
                  message_name=file_restoration to=$output
            rap$display_message message_module=recover_system_set ..
                  message_name=parameter_prompting to=$output
            rap$press_next "wait for operator to read text and respond"
            include_line statement_list= ..
'?pfp$restore_system_device restore_options=(no_data_defi..
ned media_missing) output=restore_listing.$eoi' status=rss_status

            IF rss_status.normal THEN
              " Force regeneration of the unreconciled file/catalog report"

              delete_file file=lost_cycles status=ignore_status

              " Delete the damage conditions that were set for the restored
              " files in the $SYSTEM master catalog to allow the products and
              " files to be attachable.

              rap$display_message message_module=recover_system_set ..
                    message_name=deleting_$system_damage ..
                    message_parameters='restored' to=$output

              TASK ring=extended_access_privilege
                change_catalog_contents catalog=$working_catalog ..
                      delete_damage_conditions=(parent_catalog_restored ..
                      respf_modification_mismatch) output=catalog_info.$eoi status=ignore_status
                change_file_attributes catalog_info ring_attributes=(11, 11, 11) status=ignore_status
              TASKEND
            ELSE
              display_value value=rss_status output=$output
              rap$press_next "wait for operator to read text and respond"
            IFEND
          ELSEIF choice = 'DISPLAY_ACTIVE_VOLUMES' THEN
            display_active_volumes output=$output ..
                  relevant_classes=system_defined_classes sets=all
            number_of_active_volumes=0
            LOGICAL_CONFIGURATION_UTILITY
              FOR each set in $active_sets() DO
                number_of_active_volumes=number_of_active_volumes + ..
                     $size($active_set_members(set))
              FOREND
            QUIT
            rap$display_message message_module=recover_system_set ..
                  message_name=active_volume_summary ..
                  message_parameters=$string(number_of_active_volumes) ..
                  to=$output
            rap$press_next "wait for operator to read text and respond"

          ELSEIF choice = 'DISPLAY_COMMAND_INFORMATION' THEN
            display_command_information command=pfp$restore_system_device ..
                  output=$output
            rap$press_next "wait for operator to read text and respond"
          ELSEIF choice = 'QUIT' THEN
            EXIT file_restore_loop
          IFEND
        IFEND
      LOOPEND file_restore_loop

" Delete the $job_input_queue, $sf_job_input_queue, and $job_swap_files
" subcatalogs of $SYSTEM just in case they were restored during this process.

      TASK ring=extended_access_privilege
        delete_catalog catalog=$job_input_queue do=contents_only ..
              status=ignore_status
        delete_catalog catalog=$job_swap_files do=contents_only ..
              status=ignore_status
        delete_catalog catalog=$sf_job_input_queue do=contents_only ..
              status=ignore_status
      TASKEND
" Delete damage conditions from all known validation files
      LOGICAL_CONFIGURATION_UTILITY
        FOR EACH set IN $active_sets DO
          FOR EACH family IN $active_set_families(set) DO
            validation_file = $fname(':'//family//'.$system.$validations')
            display_value ' Clearing damage conditions from '//validation_file output=$output
            change_catalog_entry validation_file delete_damage_condition=(respf_modification_mismatch, ..
                  parent_catalog_restored) status=ignore_status
          FOREND
        FOREND
      QUIT

      display_catalog catalog=$working_catalog display_options=contents ..
            depth=all include_exception_conditions=all ..
            output=catalog_info.$eoi status=ignore_status

      POP file_connections

      display_log o=rss_report_file.$next status=ignore_status
      copy_file lost_cycles rss_report_file.$eoi status=ignore_status
      copy_file restore_listing rss_report_file.$eoi status=ignore_status
      copy_file catalog_info rss_report_file.$eoi status=ignore_status
      copy_file echo_file rss_report_file.$eoi status=ignore_status

      IF NOT $variable(cmv$deadstart_simulation, defined) THEN
        print_file rss_report_file status=ignore_status
      IFEND

      rap$display_message message_module=recover_system_set ..
            message_name=results_on_file message_parameters= ..
'$system.$system.recover_system_set_report_'//$date('y2j3') to=$output
      rap$press_next "wait for operator to read text and respond"

      rap$display_message message_module=recover_system_set ..
            message_name=system_termination to=$output

      IF (missing_count > 0) THEN
        rap$display_message message_module=recover_system_set ..
              message_name=termination_with_files_missing to=$output
        rap$press_next "wait for operator to read text and respond"
      IFEND

" A TERMINATE_SYSTEM is mandated to address the following deficiencies:
"
"  1. Job management cannot recover the queued output catalog except at
"     deadstart.
"  2. Job management depends upon an image file for information about which
"     jobs have started execution.  The image file is lost when the system
"     device is reinitialized.  Therefore, this proc has deleted the job
"     input queue to prevent any job from being rerun (since we cannot
"     determine which jobs had started and we have an obligation to prevent
"     jobs from being rerun that requested not to be rerun).
"  3. It is necessary to delete the PARENT_RECREATED condition in each catalog
"     that was re-created automatically by NOS/VE or by catalog restoration.
"     This prevents a deleted catalog from being restored by subsequent
"     RESPF operations.

      IF NOT $variable(cmv$deadstart_simulation, defined) THEN
        terminate_system
      IFEND

    TASKEND
  ELSE
    rap$display_message message_module=recover_system_set ..
          message_name=not_system_origin to=$output
  IFEND

PROCEND pfp$recover_system_set
*DECK DECK=PFP$RECREATE_SYSTEM_CATALOG EXPAND=FALSE
  PROCEDURE [XREF] pfp$recreate_system_catalog
    (VAR status: ost$status);

*DECK DECK=PFP$REDUCE_PERMITS EXPAND=FALSE

  PROCEDURE [XREF] pfp$reduce_permits (
        high_level_permit_entry: pft$permit_entry;
        low_level_permit_entry: pft$permit_entry;
    VAR reduced_permit_entry: pft$permit_entry);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$RELEASE_DATA EXPAND=FALSE

  PROCEDURE [XREF] pfp$release_data
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$RELEASE_LOCKED_APFID EXPAND=FALSE

  PROCEDURE [XREF] pfp$release_locked_apfid (apfid:
    pft$attached_pf_table_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pft$attached_pf_table_index
*copyc OST$STATUS
?? POP ??
*DECK DECK=PFP$RELINK_SERVER_FILE EXPAND=FALSE

  PROCEDURE [XREF] pfp$relink_server_file
    (    old_apfid: pft$attached_permanent_file_id;
         internal_name: pft$internal_name;
         old_sfid: gft$system_file_identifier;
         device_class: rmt$device_class;
     VAR new_apfid: pft$attached_permanent_file_id;
     VAR new_sfid: gft$system_file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc ost$status
*copyc pfd$attached_permanent_file_id
*copyc pfd$complete_path
*copyc pfd$internal_name
*copyc rmt$device_class
?? POP ??

*DECK DECK=PFP$REMOVE_QUEUED_CATALOGS EXPAND=FALSE
  PROCEDURE [XREF] pfp$remove_queued_catalogs;
*DECK DECK=PFP$REPLACE_ARCHIVE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$replace_archive_entry
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         archive_identification: pft$archive_identification;
         p_archive_array_entry: pft$p_archive_array_entry;
         p_amd: pft$p_amd;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
?? POP ??

*DECK DECK=PFP$REPLACE_REM_MEDIA_FMD EXPAND=FALSE

  PROCEDURE [XREF] pfp$replace_rem_media_fmd
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         p_file_media_descriptor: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$REPORT_INVALID_FREE EXPAND=FALSE

  PROCEDURE [XREF] pfp$report_invalid_free
    (    p_path: ^pft$complete_path;
         p_cycle_number: ^pft$cycle_number;
         free_object: string ( * <= osc$max_string_size);
         file_or_catalog: string ( * <= osc$max_string_size);
         prevalidate_free_result: ost$prevalidate_free_result;
         catalog_offset: ost$halfword);

?? PUSH (LISTEXT := ON) ??
*copyc ost$halfword
*copyc ost$prevalidate_free_result
*copyc ost$string
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$REPORT_SYSTEM_ERROR EXPAND=FALSE

  PROCEDURE [XREF] pfp$report_system_error
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PFP$REPORT_UNEXPECTED_STATUS EXPAND=FALSE

  PROCEDURE [INLINE] pfp$report_unexpected_status
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    IF (NOT osp$file_access_condition (status)) AND
          (status.condition <> dfe$server_has_terminated) AND
          (status.condition <> dfe$server_request_terminated) AND
          (status.condition <> mme$segment_table_is_full) THEN
      pfp$report_system_error (status);
    IFEND;
  PROCEND pfp$report_unexpected_status;

*copyc dfe$error_condition_codes
*copyc osp$file_access_condition
*copyc mme$condition_codes
*copyc pfp$report_system_error
?? POP ??
*DECK DECK=PFP$RESET_ADMINISTRATOR_STATUS EXPAND=TRUE

  PROCEDURE [XREF] pfp$reset_administrator_status;

*DECK DECK=PFP$RESET_TASK_ENVIRONMENT EXPAND=FALSE

  PROCEDURE [XREF] pfp$reset_task_environment;

*DECK DECK=PFP$RESOLVE_PATH EXPAND=FALSE

  PROCEDURE [XREF] pfp$resolve_path (
        path: pft$path;
    VAR cycle_reference: {i/o} fst$cycle_reference;
    VAR path_resolution: fst$path_resolution;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fse$path_exception_conditions
*copyc fst$cycle_reference
*copyc fst$path_resolution
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$RESTORE_SYSTEM_DEVICE EXPAND=TRUE
PROCEDURE (HIDDEN) pfp$restore_system_device (
  vsn_prefix, vsnp: any of
      name 1..5
      string 1..5
      integer 0..99999
    anyend = $optional
  vsn_count, vsnc: integer 1..99999 = 9
  vsn_suffix, vsns: any of
      name 1..5
      string 1..5
      integer 0..99998
    anyend = $optional
  increment_scheme, is: key
      (alphabetic, a)
      (decimal, d)
    keyend = decimal
  vsn_list, vsnl: list of any of
      string 1..6
      name 1..6
    anyend = $optional
  file_label_type, flt: key
      (labeled, labelled, l)
      (unlabeled, unlabelled, u)
    keyend = labeled
  type, t: key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = mt9$6250
  recorded_vsns, recorded_vsn, rvsn: any of
      key
        all
      keyend
      list of name 6..6
    anyend = all
  restore_options, ro: list of key
      (media_missing, mm)
      (no_data_defined, ndd)
      (volume_unavailable, vu)
    keyend = (media_missing no_data_defined)
  output, o: file = $null
  status)

  "$FORMAT=OFF
  VAR
    backup_file: file=$fname('$local.'//$unique())
    restore_status: status
    volume_list: list 1..$max_list of string 6
  VAREND

  "$FORMAT=ON"

  IF $specified(vsn_list) THEN
    delete_variable volume_list
    volume_list = $apply(vsn_list, $string(x))
  ELSE
    pup$construct_volume_list vsn_count=vsn_count vsn_prefix=vsn_prefix increment_scheme=increment_scheme ..
          vsn_suffix=vsn_suffix volume_list=volume_list
  IFEND

  request_magnetic_tape file=backup_file type=type ring=no ..
        recorded_vsn=volume_list
  set_file_attributes backup_file file_label_type=file_label_type

  IF NOT $variable(cmv$deadstart_simulation, defined) THEN
    vedisplay display_option=tape_mount
  IFEND

  TASK ring=3
    RESTORE_PERMANENT_FILES list=output
      include_volumes recorded_vsn=recorded_vsn
      set_restore_options require_matching_modification=false update_cycle_statistics=false..
            restore_archive_information=TRUE
      IF NOT $variable(cmv$deadstart_simulation, defined) THEN
        restore_excluded_file_cycles backup_file=backup_file ..
              restore_options= restore_options status=restore_status
      IFEND
    QUIT
    change_file_attributes file=output ring_attributes=(11 11 11)
  TASKEND

  IF NOT $variable(cmv$deadstart_simulation, defined) THEN
    vedisplay display_option=null
  IFEND

  delete_file backup_file

  EXIT_PROC WITH restore_status

PROCEND pfp$restore_system_device
*DECK DECK=PFP$RESTRICTED_ATTACH EXPAND=FALSE
  PROCEDURE [XREF] pfp$restricted_attach (
        lfn: amt$local_file_name;
        path: pft$path;
        cycle_selector: pft$cycle_selector;
        password: pft$password;
        usage_selections: pft$usage_selections;
        share_selections: pft$share_selections;
    VAR cycle_number: pft$cycle_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
*copyc PFD$PERMANENT_FILE_DEFINITIONS
?? POP ??
*DECK DECK=PFP$RETRIEVE_ARCHIVED_FILE EXPAND=FALSE

  PROCEDURE [XREF] pfp$retrieve_archived_file
    (    path: pft$path;
         cycle_number: pft$cycle_number;
         password: pft$password;
         wait: ost$wait;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$wait
*copyc pfd$complete_path
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
?? POP ??
*DECK DECK=PFP$RETURN_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pfp$return_catalog (
    VAR catalog_locator: pft$catalog_locator;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$CATALOG_LOCATOR
?? POP ??
*DECK DECK=PFP$RETURN_FILE_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] pfp$return_file_information (
        selection_id: pft$selection_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$information_selections
*copyc pfe$error_condition_codes
*copyc pfe$selection_errors
?? POP ??
*DECK DECK=PFP$RETURN_PERMANENT_FILE EXPAND=FALSE

  PROCEDURE [XREF] pfp$return_permanent_file
    (    apfid: pft$attached_permanent_file_id;
         system_file_id: gft$system_file_identifier;
         device_class: rmt$device_class;
         usage_selections: pft$usage_selections;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc ost$status
*copyc pfd$attached_permanent_file_id
*copyc pfd$permanent_file_attributes
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFP$RING_VOTE_SELECTED_ACCESS EXPAND=FALSE

*DECK DECK=PFP$SAVE_FILE_LABEL EXPAND=FALSE

  PROCEDURE [XREF] pfp$save_file_label (
        apfid: pft$attached_permanent_file_id;
        p_file_label: fmt$p_file_label;
        required_permission: pft$permit_options;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$file_label
*copyc ost$status
*copyc pfd$attached_permanent_file_id
*copyc pfd$permanent_file_attributes
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
?? POP ??
*DECK DECK=PFP$SAVE_RELEASED_FILE_LABEL EXPAND=FALSE

  PROCEDURE [XREF] pfp$save_released_file_label
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         update_cycle_statistics: boolean;
         password_selector: pft$password_selector;
         p_file_label_container: fmt$p_file_label;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$file_label
*copyc ost$status
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFP$SETUP_ATTACHED_PF_RECOVERY EXPAND=FALSE

  PROCEDURE [XREF] pfp$setup_attached_pf_recovery
    (    file_recovery_state: pft$attached_pf_recovery_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pft$attached_pf_recovery_state
?? POP ??
*DECK DECK=PFP$SET_CATALOG_ALARM EXPAND=FALSE

  PROCEDURE [XREF] pfp$set_catalog_alarm
    (    global_file_name: ost$binary_unique_name;
         internal_catalog_name: pft$internal_catalog_name;
         external_catalog_name: ost$name;
         destroy_on_last_detach: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
*copyc ost$name
*copyc pfd$internal_name
?? POP ??
*DECK DECK=PFP$SET_FAMILY_ADMINISTRATOR EXPAND=FALSE
  PROCEDURE [XREF] pfp$set_family_administrator
    (    family_administrator: boolean);
*DECK DECK=PFP$SET_RESTORE_STATUS EXPAND=FALSE
  PROCEDURE [XREF] pfp$set_restore_status
    (    restore_missing_catalogs_done: boolean;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PFP$SET_STATUS_ABNORMAL EXPAND=FALSE

  PROCEDURE [XREF] pfp$set_status_abnormal
    (    variant_path: pft$variant_path;
         condition: ost$status_condition_code;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfe$error_condition_codes
*copyc pft$variant_path
?? POP ??
*DECK DECK=PFP$SET_TASK_ENVIRONMENT EXPAND=FALSE

  PROCEDURE [XREF] pfp$set_task_environment
    (    p_client_job_space: ^dft$client_job_space;
         system_administrator: boolean;
         family_administrator: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc dft$client_job_list
?? POP ??
*DECK DECK=PFP$SHARED_QUEUE EXPAND=FALSE

  FUNCTION [INLINE] pfp$shared_queue
    (    shared_queue_info: pft$shared_queue_info;
         share_selections: pft$share_selections): mmt$shared_queue;

?? PUSH (LISTEXT := ON) ??

    IF shared_queue_info.defined AND (share_selections <>
          $pft$share_selections []) THEN
      IF (shared_queue_info.shared_queue >= LOWERVALUE (mmt$shared_queue)) AND
            (shared_queue_info.shared_queue <= UPPERVALUE (mmt$shared_queue))
            THEN
        pfp$shared_queue := shared_queue_info.shared_queue;
      ELSE
        pfp$shared_queue := mmc$null_shared_queue;
      IFEND;
    ELSE
      pfp$shared_queue := mmc$null_shared_queue;
    IFEND;

  FUNCEND pfp$shared_queue;

*copyc mmt$shared_queue
*copyc pfd$permanent_file_attributes
*copyc pft$shared_queue_info
?? POP ??
*DECK DECK=PFP$SHARE_FOR_WRITE EXPAND=FALSE

  FUNCTION [INLINE] pfp$share_for_write
    (    share_selections: pft$share_selections): boolean;

?? PUSH (LISTEXT := ON) ??
    pfp$share_for_write := share_selections *
          $pft$share_selections [pfc$shorten, pfc$append,
          pfc$modify] <> $pft$share_selections [];

  FUNCEND pfp$share_for_write;

*copyc pfd$attached_permanent_file_id
?? POP ??
*DECK DECK=PFP$SORT_OBJECT_LIST EXPAND=FALSE
  PROCEDURE [XREF] pfp$sort_object_list
    (    p_object_list: {input} ^pft$object_list;
         p_new_object_list: {i/o} ^pft$object_list;
     VAR object_list_descriptor: {i/o} pft$object_list_descriptor);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
*copyc pfd$catalog_locator
?? POP ??
*DECK DECK=PFP$SYSTEM_PATH EXPAND=FALSE

  FUNCTION [INLINE] pfp$system_path (path: pft$complete_path): boolean;

?? PUSH (LISTEXT := ON) ??

    pfp$system_path := (UPPERBOUND (path) < pfc$family_path_index) OR
          (path [pfc$family_path_index] = jmc$system_family) OR
          ((UPPERBOUND (path) > pfc$family_path_index) AND
          (path [pfc$master_catalog_path_index] = jmc$system_user));
  FUNCEND pfp$system_path;

*copyc jmc$system_family
*copyc pfd$complete_path
?? POP ??
*DECK DECK=PFP$SYSTEM_PRIVILEGE EXPAND=FALSE

  FUNCTION [INLINE] pfp$system_privilege
    (    caller_ring: ost$ring;
         master_catalog_name: pft$name): boolean;

?? PUSH (LISTEXT := ON) ??
{  This procedure uses the current executing tasks system authority to
{  determine if the caller has system privilege.
{  This procedure must only be called on the client mainframe.

    pfp$system_privilege := pfp$system_privilege_authority
          (pfv$system_authority, caller_ring, master_catalog_name);
  FUNCEND pfp$system_privilege;

*copyc osd$virtual_address
*copyc pfd$permanent_file_definitions
*copyc pfp$system_privilege_authority
*copyc pfv$system_authority
?? POP ??

*DECK DECK=PFP$SYSTEM_PRIVILEGED_CATALOG EXPAND=FALSE

  FUNCTION [INLINE] pfp$system_privileged_catalog (catalog: pft$name): boolean;

{   This function determines whether or not files may be created in and
{ deleted from the specified catalog by the system on behalf of the user,
{ regardless of any permits which may or may not exist.

    pfp$system_privileged_catalog := ((catalog = jmc$job_input_catalog) OR
          (catalog = jmc$job_output_catalog) OR
          (catalog = jmc$job_swap_catalog) OR
          (catalog = jmc$sf_job_input_catalog) OR
          (catalog = jmc$sf_job_output_catalog));
  FUNCEND pfp$system_privileged_catalog;

*copyc jmc$system_family
*copyc pfd$permanent_file_definitions
*DECK DECK=PFP$SYSTEM_PRIVILEGE_AUTHORITY EXPAND=FALSE

  FUNCTION [INLINE] pfp$system_privilege_authority
    (    system_authority: pft$system_authority;
         caller_ring: ost$ring;
         master_catalog_name: pft$name): boolean;

?? PUSH (LISTEXT := ON) ??

    pfp$system_privilege_authority := (system_authority > 0) AND
          (caller_ring <= osc$tsrv_ring) AND
          (master_catalog_name = jmc$system_user);
  FUNCEND pfp$system_privilege_authority;

*copyc jmc$system_family
*copyc osd$virtual_address
*copyc pfd$permanent_file_definitions
*copyc pft$system_authority
?? POP ??
*DECK DECK=PFP$TASK_TERMINATION_CLEANUP EXPAND=FALSE

  PROCEDURE [XREF] pfp$task_termination_cleanup;
*DECK DECK=PFP$TERMINATE_SERVER_APFID EXPAND=FALSE
  PROCEDURE [INLINE] pfp$terminate_server_apfid
    (VAR apfid: pft$attached_permanent_file_id);

    apfid.server_lifetime := 0;
  PROCEND pfp$terminate_server_apfid;

?? PUSH (LISTEXT := ON) ??
*copyc pfd$attached_permanent_file_id
?? POP ??

*DECK DECK=PFP$TEST_CONDITION_HANDLER EXPAND=FALSE
  PROCEDURE pfp$test_condition_handler
    (    debug_value: integer);

    VAR
      condition: pmt$condition,
      local_status: ost$status,
      p_obj1: ^pft$physical_object,
      p_obj2: ^pft$physical_object,
      psa: ^ost$stack_frame_save_area;

    IF debug_value = 0 THEN
      RETURN;
    IFEND;

    CASE debug_value OF
    = 0 =
      ;
    = 1 =
      osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$pf_system_error,
            'OSP$SYSTEM_ERROR test.', local_status);
      osp$system_error ('osp$system_error test.', ^local_status);
    = 2 =
      condition.selector := pmc$system_conditions;
      condition.system_conditions := $pmt$system_conditions [pmc$access_violation];
      psa := #PREVIOUS_SAVE_AREA ();
      pmp$test_condition_handler (condition, psa, local_status);
    = 3 =
      condition.selector := pmc$system_conditions;
      condition.system_conditions := $pmt$system_conditions [pmc$instruction_specification];
      psa := #PREVIOUS_SAVE_AREA ();
      pmp$test_condition_handler (condition, psa, local_status);
    = 4 =
      condition.selector := pmc$system_conditions;
      condition.system_conditions := $pmt$system_conditions [pmc$address_specification];
      psa := #PREVIOUS_SAVE_AREA ();
      pmp$test_condition_handler (condition, psa, local_status);
    = 5 =
      condition.selector := pmc$system_conditions;
      condition.system_conditions := $pmt$system_conditions [pmc$invalid_segment_ring_0];
      psa := #PREVIOUS_SAVE_AREA ();
      pmp$test_condition_handler (condition, psa, local_status);
    = 6 =
      condition.selector := pmc$system_conditions;
      condition.system_conditions := $pmt$system_conditions [pmc$divide_fault];
      psa := #PREVIOUS_SAVE_AREA ();
      pmp$test_condition_handler (condition, psa, local_status);
    = 7 =
      condition.selector := pmc$block_exit_processing;
      condition.reason := $pmt$block_exit_reason [pmc$block_exit];
      psa := #PREVIOUS_SAVE_AREA ();
      pmp$test_condition_handler (condition, psa, local_status);
    = 8 =
      condition.selector := pmc$block_exit_processing;
      condition.reason := $pmt$block_exit_reason [pmc$program_termination];
      psa := #PREVIOUS_SAVE_AREA ();
      pmp$test_condition_handler (condition, psa, local_status);
    = 9 =
      condition.selector := pmc$block_exit_processing;
      condition.reason := $pmt$block_exit_reason [pmc$program_abort];
      psa := #PREVIOUS_SAVE_AREA ();
      pmp$test_condition_handler (condition, psa, local_status);
    = 10 =
      condition.selector := mmc$segment_access_condition;
      condition.segment_access_condition.identifier := mmc$sac_read_beyond_eoi;
      psa := #PREVIOUS_SAVE_AREA ();
      pmp$test_condition_handler (condition, psa, local_status);
    = 11 =
      condition.selector := mmc$segment_access_condition;
      condition.segment_access_condition.identifier := mmc$sac_segment_access_error;
      psa := #PREVIOUS_SAVE_AREA ();
      pmp$test_condition_handler (condition, psa, local_status);
    = 12 =
      condition.selector := mmc$segment_access_condition;
      condition.segment_access_condition.identifier := mmc$sac_ring_violation;
      psa := #PREVIOUS_SAVE_AREA ();
      pmp$test_condition_handler (condition, psa, local_status);
    = 13 =
      RETURN;
    = 14 =
      p_obj1 := p_obj2;
    = 15 =
      ;
    ELSE
    CASEND;

  PROCEND pfp$test_condition_handler;

*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc pfd$catalog
*copyc pfe$error_condition_codes
*copyc pmp$test_condition_handler

  VAR
    osv$debug: [XREF] array [0..15] of integer;
*DECK DECK=PFP$UNLOCK_APFID EXPAND=FALSE

  PROCEDURE [XREF] pfp$unlock_apfid (apfid: pft$attached_pf_table_index;
    p_attached_pf_entry: pft$p_attached_pf_entry;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pft$attached_pf_table_index
*copyc OST$STATUS
*copyc PFD$ATTACHED_PF_TABLE
?? POP ??
*DECK DECK=PFP$UNLOCK_CATALOG_PAGES EXPAND=FALSE
  PROCEDURE [XREF] pfp$unlock_catalog_pages
    (VAR catalog_locator: {i/o} pft$catalog_locator;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_locator
*copyc ost$status
?? POP ??
*DECK DECK=PFP$UPDATE_OBJECT_LIST_LOCATOR EXPAND=FALSE

  PROCEDURE [XREF] pfp$update_object_list_locator
    (    p_path: ^pft$complete_path;
         p_new_object_list: pft$p_object_list;
         p_catalog_file: pft$p_catalog_file;
     VAR object_list_descriptor: pft$object_list_descriptor);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
*copyc pfd$catalog_locator
*copyc pfd$complete_path
?? POP ??
*DECK DECK=PFP$UPDATE_OBJ_LIST_DESCRIPTOR EXPAND=FALSE
  PROCEDURE [XREF] pfp$update_obj_list_descriptor
    (    p_object: ^pft$physical_object;
     VAR object_list_descriptor: pft$object_list_descriptor);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
*copyc pfd$catalog_locator
?? POP ??
*DECK DECK=PFP$UPDATE_STALE_CYCLE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pfp$update_stale_cycle_entry
    (    system_file_id: gft$system_file_identifier;
         p_physical_cycle: {i^/o^} ^pft$physical_cycle;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc ost$status
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFP$UTILITY_ATTACH EXPAND=FALSE

  PROCEDURE [XREF] pfp$utility_attach (lfn:
    amt$local_file_name;
        path: pft$path;
        cycle_selector: pft$cycle_selector;
        password: pft$password;
        usage_selections: pft$usage_selections;
        share_selections: pft$share_selections;
        wait: pft$wait;
        allowed_cycle_damage_symptoms: fst$cycle_damage_symptoms;
    VAR cycle_damage_symptoms: fst$cycle_damage_symptoms;
    VAR cycle_number: pft$cycle_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
*copyc fst$cycle_damage_symptoms
*copyc PFE$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=PFP$VALIDATE_DEFAULT_PASSWORD EXPAND=FALSE

  PROCEDURE [XREF] pfp$validate_default_password (
        path: pft$complete_path;
        authority: pft$authority;
        access_password: pft$password_selector;
        p_file_object: pft$p_object;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$AUTHORITY
*copyc PFD$CATALOG
*copyc PFD$COMPLETE_PATH
*copyc PFD$PASSWORD_SELECTOR
*copyc PFD$PERMANENT_FILE_DEFINITIONS
?? POP ??
*DECK DECK=PFP$VALIDATE_FAMILY_OWNERSHIP EXPAND=FALSE

  PROCEDURE [XREF] pfp$validate_family_ownership (
        family_name: ost$family_name;
        authority: pft$authority;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc OST$USER_IDENTIFICATION
*copyc PFD$AUTHORITY
?? POP ??
*DECK DECK=PFP$VALIDATE_FILE_PERMISSION EXPAND=FALSE

  PROCEDURE [XREF] pfp$validate_file_permission (
        path: pft$complete_path;
        authority: pft$authority;
        permit_entry: pft$permit_entry;
        usage_intentions: pft$permit_selections;
        share_intentions: pft$share_selections;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$AUTHORITY
*copyc PFD$CATALOG
*copyc PFD$COMPLETE_PATH
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
?? POP ??
*DECK DECK=PFP$VALIDATE_LOCAL_FAMILY EXPAND=TRUE
  PROCEDURE [XREF] pfp$validate_local_family
    (    family_name: pft$name;
     VAR status: ost$status);

*copyc pfe$error_condition_codes
*copyc pfd$permanent_file_definitions
*copyc ost$status

*DECK DECK=PFP$VALIDATE_ORED_PERMISSION EXPAND=FALSE

  PROCEDURE [XREF] pfp$validate_ored_permission
    (    path: pft$complete_path;
         authority: pft$authority;
         permit_entry: pft$permit_entry;
         usage_intentions: pft$permit_selections;
         share_intentions: pft$share_selections;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$authority
*copyc pfd$catalog
*copyc pfd$complete_path
*copyc pfd$permanent_file_attributes
?? POP ??
*DECK DECK=PFP$VALIDATE_OWNERSHIP EXPAND=FALSE

  PROCEDURE [XREF] pfp$validate_ownership (
        authority: pft$authority;
        path: pft$complete_path;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$AUTHORITY
*copyc PFD$COMPLETE_PATH
?? POP ??
*DECK DECK=PFP$VALIDATE_PASSWORD EXPAND=FALSE

  PROCEDURE [XREF] pfp$validate_password (
        path: pft$complete_path;
        authority: pft$authority;
        access_password: pft$password;
        p_file_object: pft$p_object;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$AUTHORITY
*copyc PFD$CATALOG
*copyc PFD$COMPLETE_PATH
*copyc PFD$PERMANENT_FILE_DEFINITIONS
?? POP ??
*DECK DECK=PFP$VALIDATE_RING_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] pfp$validate_ring_access (
        path: pft$complete_path;
        p_file_label: fmt$p_file_label;
        usage_selections: pft$usage_selections;
        validation_ring: ost$valid_ring;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc FMT$FILE_LABEL
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
*copyc PFD$COMPLETE_PATH
*copyc PFD$PERMANENT_FILE_ATTRIBUTES
?? POP ??
*DECK DECK=PFP$VALIDATE_SET_OWNER EXPAND=FALSE

  PROCEDURE [XREF] pfp$validate_set_owner (
        set_name: stt$set_name;
        authority: pft$authority;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$AUTHORITY
*copyc STD$SET_NAME
?? POP ??
*DECK DECK=PFP$VALIDATE_SITE_OPTIONS EXPAND=FALSE

  PROCEDURE [XREF] pfp$validate_site_options
    (    family: pft$name;
         site_archive_option: pft$site_archive_option;
         site_backup_option: pft$site_backup_option;
         site_release_option: pft$site_release_option;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
*copyc pft$site_archive_option
*copyc pft$site_backup_option
*copyc pft$site_release_option
?? POP ??
*DECK DECK=PFP$VERIFY_ADMIN_RETRIEVAL EXPAND=FALSE

  PROCEDURE [XREF] pfp$verify_admin_retrieval (
        path: pft$path;
        cycle_number: pft$cycle_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pfe$error_condition_codes
?? POP ??
*DECK DECK=PFP$VERIFY_PVA EXPAND=FALSE

  PROCEDURE [XREF] pfp$verify_pva (
        pva: ^cell;
        access_mode: mmt$va_access_mode;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$va_access_mode
*copyc ost$status
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
?? POP ??
*DECK DECK=PFP$WRITE_LIMIT_ENTRY EXPAND=TRUE
?? NEWTITLE := 'pfp$write_limit_entry', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avt$total_limit_update_record
?? POP ??

{ PURPOSE
{   This procedure writes information about totals for accounts, projects, and users into a sequence of limit
{   information to be used to update the permanent file space accumulator in the validation file.  This
{   information is input to avp$replace_total_limits.

    PROCEDURE pfp$write_limit_entry
      (    family_name: ost$family_name;
           account_name: avt$account_name;
           project_name: avt$project_name;
           user_name: ost$user_name;
           allocated_size: integer;
       VAR number_of_limit_entries: integer;
       VAR limit_entries: ^SEQ ( * ));

      VAR
        limit_entry: ^avt$total_limit_update_record;

{ Account and project NONE are special keywords to signify no account or project.
{ No account or project can possibly be defined for them  so do not write out a limit entry.

      IF ((account_name <> 'NONE') AND (project_name <> 'NONE')) THEN
        NEXT limit_entry IN limit_entries;
        limit_entry^.family_name := family_name;
        limit_entry^.validation_key.account_name := account_name;
        limit_entry^.validation_key.project_name := project_name;
        limit_entry^.validation_key.user_name := user_name;
        limit_entry^.size := allocated_size;
        number_of_limit_entries := number_of_limit_entries + 1;
      IFEND;

    PROCEND pfp$write_limit_entry;

?? OLDTITLE, EJECT ??
*DECK DECK=PFT$ACTION_ATTEMPTED EXPAND=FALSE

  TYPE
    pft$action_attempted = (pfc$no_action_attempted, pfc$creation_attempted,
          pfc$dm_attachment_attempted, pfc$fm_attachment_attempted);

*DECK DECK=PFT$ATTACHED_PF_RECOVERY_STATE EXPAND=FALSE
{ - pfc$attached_pf_normal - The file is attached.
{ -  pfc$attached_pf_awaiting_client  -The file is attached
{ in the catalog, and in the attached_permanent_file_table, but
{ has not been updated in the file manager table.  The file is
{ awaiting the client job to re-obtain the information for the file.
{ -  pfc$attached_pf_in_job_recovery =
{    A new sfid has not yet been assigned after a system failure.

  TYPE
    pft$attached_pf_recovery_state = (pfc$attached_pf_normal,
      pfc$attached_pf_awaiting_client, pfc$attached_pf_in_job_recovery);

*DECK DECK=PFT$ATTACHED_PF_TABLE_INDEX EXPAND=FALSE
  TYPE
    pft$attached_pf_table_index = 1 .. 0ffff(16);


*DECK DECK=PFT$ATTACH_OR_CREATE_ACTION EXPAND=FALSE

  TYPE
    pft$attach_or_create_action = (pfc$cycle_created,
      pfc$cycle_already_attached, pfc$cycle_busy_elsewhere,
      pfc$cycle_newly_attached);

*DECK DECK=PFT$AUDITABLE_CYCLE EXPAND=FALSE

  TYPE
    pft$auditable_cycle = record
      case audit: boolean of
      = FALSE =
        ,
      = TRUE =
        cycle_number: pft$cycle_number,
        device_class: rmt$device_class,
        case normal_status: boolean of
        = FALSE =
          condition: ost$status_condition_code,
        = TRUE =
          ,
        casend,
      casend,
    recend;

*copyc ost$status_condition_code
*copyc pfd$permanent_file_definitions
*copyc rmt$device_class
*DECK DECK=PFT$AUDITABLE_CYCLES EXPAND=FALSE

  TYPE
    pft$auditable_cycles = array [1 .. * ] of pft$auditable_cycle;

*copyc pft$auditable_cycle
*DECK DECK=PFT$AUDITABLE_PERMIT EXPAND=FALSE

  TYPE
    pft$auditable_permit = record
      group: pft$group,
      permit_selections: pft$permit_selections,
      case normal_status: boolean of
      = FALSE =
        condition: ost$status_condition_code,
      = TRUE =
        ,
      casend,
    recend;

*copyc ost$status_condition_code
*copyc pfd$permanent_file_definitions
*DECK DECK=PFT$AUDITABLE_PERMITS EXPAND=FALSE

  TYPE
    pft$auditable_permits = array [1 .. * ] of pft$auditable_permit;

*copyc pft$auditable_permit
*DECK DECK=PFT$CATALOG_MEDIA_DESCRIPTION EXPAND=FALSE

 {CATALOG MEDIA Definitions}

  TYPE
    pft$p_catalog_media_description = ^pft$catalog_media_description,
    pft$catalog_media_description = record
      internal_name: ost$binary_unique_name,
      case catalog_type: pft$catalog_types of
      = pfc$external_catalog =
        global_file_name: ost$binary_unique_name,
        checksum: pft$checksum,
        file_media_type: pft$file_media_type,
      = pfc$internal_catalog =
        ,
      casend,
    recend;



*copyc ost$binary_unique_name
*copyc pft$catalog_types
*copyc pft$checksum
*copyc pft$file_media_type
*DECK DECK=PFT$CATALOG_TYPES EXPAND=FALSE
  TYPE
    pft$catalog_types = (pfc$internal_catalog, pfc$external_catalog);

*DECK DECK=PFT$CHECKSUM EXPAND=FALSE
  {Checksum Definitions}

  TYPE
    pft$checksum = integer,
    pft$checksum_location = ^cell,
    pft$checksum_size = integer,
    pft$p_checksum = ^pft$checksum;

*DECK DECK=PFT$CHOSEN_CYCLES EXPAND=FALSE

  TYPE
    pft$chosen_cycles = array [1 .. * ] of boolean;

*DECK DECK=PFT$CYCLE_COUNT EXPAND=FALSE

  CONST
    pfc$maximum_cycle_count = 0ffffffff(16);

  TYPE
    pft$cycle_count = 0 .. pfc$maximum_cycle_count;



*DECK DECK=PFT$CYCLE_INFO_DESC_VERSION_1 EXPAND=FALSE
                                                                                                              
  TYPE                                                                                                        
    pft$cycle_info_desc_version_1 = record                                                                    
      cycle_number: pft$cycle_number,                                                                         
      cycle_statistics: pft$cycle_statistics,                                                                 
      expiration_date_time: ost$date_time,                                                                    
    recend;                                                                                                   
                                                                                                              
*copyc ost$date_time                                                                                          
*copyc pfd$cycle_statistics                                                                                   
*copyc pfd$permanent_file_definitions                                                                         
*DECK DECK=PFT$CYCLE_INFO_DESC_VERSION_2 EXPAND=FALSE
                                                                                                              
  TYPE                                                                                                        
    pft$cycle_info_desc_version_2 = record                                                                    
      cycle_damage_symptoms: fst$cycle_damage_symptoms,                                                       
      cycle_number: pft$cycle_number,                                                                         
      cycle_statistics: pft$cycle_statistics,                                                                 
      data_modification_date_time: ost$date_time,                                                             
      device_class: pft$device_class,                                                                         
      expiration_date_time: ost$date_time,                                                                    
      original_unique_name: ost$binary_unique_name,                                                           
      sparse_backup_file_format: boolean,                                                                     
      shared_queue_info: pft$shared_queue_info,                                                               
      retrieve_option: pft$retrieve_option,                                                                   
      site_backup_option: pft$site_backup_option,                                                             
      site_archive_option: pft$site_archive_option,                                                           
      site_release_option: pft$site_release_option,                                                           
      reserved_cycle_info_space: array [1 .. 55] of boolean,                                                  
      fmd_checksum: pft$checksum,                                                                             
      file_media_descriptor: SEQ ( * ),                                                                       
    recend;                                                                                                   
                                                                                                              
*copyc fst$cycle_damage_symptoms                                                                              
*copyc ost$binary_unique_name                                                                                 
*copyc ost$date_time                                                                                          
*copyc pfd$cycle_statistics                                                                                   
*copyc pfd$permanent_file_definitions                                                                         
*copyc pft$checksum                                                                                           
*copyc pft$device_class                                                                                       
*copyc pft$shared_queue_info                                                                                  
*copyc pft$site_backup_option                                                                                 
*copyc pft$site_archive_option                                                                                
*copyc pft$site_release_option                                                                                
*copyc pft$retrieve_option                                                                                    
*DECK DECK=PFT$CYCLE_RESERVATION_CRITERIA EXPAND=FALSE

  TYPE
    pft$cycle_reservation_criteria = record
      date_selection_criteria: put$selection_criteria,
      minimum_cycle_size: amt$file_byte_address,
      maximum_cycle_size: amt$file_byte_address,
      p_volume_list: ^pft$volume_list,
      include_volumes_option: put$include_volumes_option,
      exclude_highest_cycles: pft$cycle_count,
      validation_ring: ost$ring,
    recend;

*copyc amt$file_byte_address
*copyc osd$virtual_address
*copyc pft$cycle_count
*copyc pft$volume_list
*copyc pud$selection_criteria
*copyc put$include_volumes_option
*DECK DECK=PFT$DATA_RESIDENCE EXPAND=FALSE
{                                                                                                             
{ pft$data_residence describes the data residence of a file cycle as follows:                                 
{                                                                                                             
{     pfc$unreleasable_data - data resides on mass storage with no current copy                               
{           on an alternate storage device.                                                                   
{                                                                                                             
{     pfc$releasable_data - data resides on mass storage and a current copy                                   
{     also                                                                                                    
{           resides on an alternate storage device.                                                           
{                                                                                                             
{     pfc$release_data_requested - release of mass storage data has been                                      
{           requested for a cycle of a file which has a current copy of the                                   
{           data cycle on an alternate storage device.                                                        
{                                                                                                             
{     pfc$offline_data - data resides only on an alternate storage device                                     
{           (i.e. data on mass storage has been released).                                                    
{                                                                                                             
                                                                                                              
  TYPE                                                                                                        
    pft$data_residence = (pfc$unreleasable_data, pfc$releasable_data,                                         
          pfc$release_data_requested, pfc$offline_data, pfc$data_residence_4,                                 
          pfc$data_residence_5, pfc$data_residence_6, pfc$data_residence_7);                                  
                                                                                                              
*DECK DECK=PFT$DATE_TIME EXPAND=FALSE

  TYPE
    pft$date_time = record
      case date_time_option: pft$date_time_option of
      = pfc$no_date_time =
        ,
      = pfc$current_date_time =
        current_date_time: ost$date_time,
      = pfc$specified_date_time =
        specified_date_time: ost$date_time,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc pft$date_time_option
?? POP ??
*DECK DECK=PFT$DATE_TIME_OPTION EXPAND=FALSE

  TYPE
    pft$date_time_option = (pfc$no_date_time, pfc$current_date_time,
          pfc$specified_date_time);
*DECK DECK=PFT$DELETE_OPTION EXPAND=FALSE

  TYPE
    pft$delete_option = (pfc$catalog_and_contents, pfc$contents_only,
          pfc$only_if_empty);

*DECK DECK=PFT$DEVICE_CLASS EXPAND=FALSE
                                                                                                              
  TYPE                                                                                                        
    pft$device_class = 0 .. 127;                                                                              
                                                                                                              
*copyc pfc$device_class                                                                                       
*DECK DECK=PFT$DF_APPEND_REM_MEDIA_VSN EXPAND=FALSE

{ Parameters sent from CLIENT to SERVER:

  TYPE
    pft$df_append_rem_me_vsn_inp = record
      cycle_selector: pft$cycle_selector,
      path_length: pft$array_index,
      volume_descriptor: rmt$volume_descriptor,
    recend;

{ PATH follows in the buffer.

?? SKIP := 2 ??

{ Parameters received by CLIENT from SERVER:
{   status

*copyc pfd$permanent_file_definitions
*copyc rmt$volume_descriptor
*DECK DECK=PFT$DF_ATTACH_IN EXPAND=FALSE

{ parameters sent from client to server

  TYPE
    pft$df_attach_in = record
      { parameters supplied by caller:
      cycle_selector: pft$cycle_selector,
      password: pft$password,
      usage_selector: pft$usage_selector,
      share_selector: pft$share_selector,

      { parameter on pfp$utility_attach only:
      allowed_cycle_damage_symptoms: fst$cycle_damage_symptoms,
      allowed_device_classes: fst$device_classes,

      { parameters supplied by ring 3 caller:
      mainframe_id: pmt$binary_mainframe_id,
      path_length: pft$file_path_index,
      system_privilege: boolean,
      validation_ring: ost$valid_ring,
      update_catalog: boolean,
      update_cycle_statistics: boolean,
    recend;

*copyc fst$cycle_damage_symptoms
*copyc fst$device_classes
*copyc osd$virtual_address
*copyc pfd$permanent_file_definitions
*copyc pfd$share_selector
*copyc pfd$usage_selector
*copyc pmt$binary_mainframe_id
*DECK DECK=PFT$DF_ATTACH_OR_CREATE_IN EXPAND=FALSE

{ parameters sent from client to server

  TYPE
    pft$df_attach_or_create_in = record
      evaluated_file_reference: fst$evaluated_file_reference,
      exception_selection_info: pft$exception_selection_info,
      file_label_size: pft$file_label_size,
      mainframe_id: pmt$binary_mainframe_id,
      number_of_attachment_options: ost$non_negative_integers,
      path_table_info_present: boolean,
      fs_retention: fst$retention,
      retrieve_option: pft$retrieve_option,
      site_archive_option: pft$site_archive_option,
      site_backup_option: pft$site_backup_option,
      site_release_option: pft$site_release_option,
      system_privilege: boolean,
      validation_ring: ost$valid_ring,
    recend;

    { If there are any attachment_options, the array is in the data buffer.
    { If there is a file_label; it follows in this buffer if it's small enough,
    { otherwise it is in the data buffer.
    { If there is path_table_info, it follows in this buffer.

*copyc fst$evaluated_file_reference
*copyc fst$retention
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc pfd$catalog
*copyc pfd$permanent_file_definitions
*copyc pft$exception_selection_info
*copyc pmt$binary_mainframe_id
*DECK DECK=PFT$DF_ATTACH_OR_CREATE_OUT EXPAND=FALSE

{ parameters received by client from server

  TYPE
    pft$df_attach_or_create_out = record
      action_attempted: pft$action_attempted,
      action_taken: pft$attach_or_create_action,
      allowed_access: fst$file_access_options,
      authority: pft$authority,
      bytes_allocated: amt$file_byte_address,
      device_class: rmt$device_class,
      evaluated_file_reference: fst$evaluated_file_reference,
      global_file_name: ost$binary_unique_name,
      label_size: pft$file_label_size,
      label_used: boolean,
      new_remote_sfid: gft$system_file_identifier,
      new_global_file_name: ost$binary_unique_name,
      required_sharing: fst$file_access_options,
      selected_access: fst$file_access_options,
      selected_sharing: fst$file_access_options,
      status_included: boolean,
    recend;

    { The status follows in this buffer, if included;
    { otherwise the server_file_output follows in this buffer.

*copyc amt$file_byte_address
*copyc fst$evaluated_file_reference
*copyc fst$file_access_options
*copyc gft$system_file_identifier
*copyc ost$binary_unique_name
*copyc pfd$authority
*copyc pfd$catalog
*copyc pft$action_attempted
*copyc pft$attach_or_create_action
*copyc rmt$device_class
*DECK DECK=PFT$DF_ATTACH_OUT EXPAND=FALSE

{ parameters received by client from server

  TYPE
    pft$df_attach_out = record
      authority: pft$authority,
      cycle_damage_symptoms: fst$cycle_damage_symptoms,
      device_class: rmt$device_class,
      global_file_name: ost$binary_unique_name,
      file_label_size: pft$file_label_size,
      status_included: boolean,
    recend;

    { status from server pfp$r2_attach
    { IF status.normal
    {   pft$df_attach_outp
    {   server_file_output
    {   subfile array
    {   file label
    { ELSEIF status.condition = pfe$cycle_busy
    {   cycle number

    { server_file_output follows in buffer.
    { subfile array follows in buffer.
    { file label follows in buffer if space permits,
    {   otherwise file label in data area.
    { fmd for removable media device in data area.

*copyc fst$cycle_damage_symptoms
*copyc ost$binary_unique_name
*copyc pfd$authority
*copyc pfd$catalog
*copyc rmt$device_class
*DECK DECK=PFT$DF_CHANGE_CY_DAM EXPAND=FALSE

{ Parameters sent from CLIENT >---> SERVER
{ pft$df_change_cy_dam_inp
{ path

  TYPE
    pft$df_change_cy_dam_inp = record
      cycle_selector: pft$cycle_selector,
      password: ost$name,
      new_damage_symptoms: fst$cycle_damage_symptoms,
      path_length: pft$array_index,
    recend;
    { Path follows in buffer.

*copyc fst$cycle_damage_symptoms
*copyc ost$status
*copyc pfd$permanent_file_definitions

*DECK DECK=PFT$DF_CHANGE_CY_DT EXPAND=FALSE

{ Parameters sent from CLIENT >---> SERVER
{ pft$df_change_cy_dt_inp
{ path

  TYPE
    pft$df_change_cy_dt_inp = record
      cycle_selector: pft$cycle_selector,
      password: ost$name,
      new_access_date_time: pft$date_time,
      new_creation_date_time: pft$date_time,
      new_modification_date_time: pft$date_time,
      path_length: pft$array_index,
    recend;
    { Path follows in buffer.

*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pft$date_time

*DECK DECK=PFT$DF_CHANGE_FILE_IN EXPAND=FALSE

{ parameters sent from client to server

  TYPE
    pft$df_change_file_in = record
      path_length: pft$file_path_index,
      cycle_selector: pft$cycle_selector,
      password: pft$name,
      system_privilege: boolean,
      change_file_count: pft$array_index,
    recend;

    { The path and change_list follow in this buffer.

*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*DECK DECK=PFT$DF_CHANGE_FILE_OUT EXPAND=FALSE

{ parameters received by client from server

  TYPE
    pft$df_change_file_out = record
      cycle_number: pft$cycle_number,
      device_class: rmt$device_class,
      change_file_index: ost$non_negative_integers,
      status_included: boolean,
    recend;

    { The status follows in this buffer, if included.

*copyc osd$integer_limits
*copyc pfd$permanent_file_definitions
*copyc rmt$device_class
*DECK DECK=PFT$DF_CHANGE_IN EXPAND=FALSE

{ parameters sent from client to server

  TYPE
    pft$df_change_in = record
      path_length: pft$file_path_index,
      cycle_selector: pft$cycle_selector,
      password: pft$name,
      system_privilege: boolean,
      change_count: pft$array_index,
    recend;

    { The path and change_list follow in this buffer.

*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*DECK DECK=PFT$DF_CHANGE_OUT EXPAND=FALSE

{ parameters received by client from server

  TYPE
    pft$df_change_out = record
      cycle_number: pft$cycle_number,
      device_class: rmt$device_class,
      change_index: ost$non_negative_integers,
      status_included: boolean,
    recend;

    { The status follows in this buffer, if included.

*copyc osd$integer_limits
*copyc pfd$permanent_file_definitions
*copyc rmt$device_class
*DECK DECK=PFT$DF_CHANGE_RESIDENCE_IN EXPAND=FALSE

{ Parameters sent from client to server.

  TYPE
    pft$df_change_residence_in = record
      cycle_selector: pft$cycle_selector,
      path_length: pft$file_path_index,
    recend;

    { Path follows in buffer.

*copyc ost$status
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*DECK DECK=PFT$DF_CLEAR_CY_ATT_IN EXPAND=FALSE

{ Parameters sent from client to server.

  TYPE
    pft$df_clear_cy_att_in = record
      cycle_selector: pft$cycle_selector,
      password: ost$name,
      path_length: pft$file_path_index,
    recend;

    { Path follows in buffer.

*copyc ost$status
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*DECK DECK=PFT$DF_DEFINE EXPAND=FALSE

{ Parameters sent from CLIENT to SERVER.

  TYPE
    pft$df_define_inp = record
      { Parameters supplied by caller.
      cycle_selector: pft$cycle_selector,
      password: pft$password,
      fs_retention: fst$retention,
      log: pft$log,
      retrieve_option: pft$retrieve_option,
      site_archive_option: pft$site_archive_option,
      site_backup_option: pft$site_backup_option,
      site_release_option: pft$site_release_option,
      device_class: rmt$device_class,
      mass_storage_request_included: boolean,
      rem_media_request_included: boolean,
      volume_list_included: boolean,
      number_of_volumes: 0 .. osc$max_integer,
      { Parameters supplied by ring 3 caller.
      mainframe_id: pmt$binary_mainframe_id,
      system_privilege: boolean,
      validation_ring: ost$valid_ring,
      path_length: pft$array_index,
    recend;

?? SKIP := 2 ??

{ Parameters received by CLIENT from SERVER.
{   buffer format
{   pft$df_define_outp
{   subfile array

  TYPE
    pft$df_define_outp = record
      authority: pft$authority,
      bytes_allocated: amt$file_byte_address,
      server_file_output : pft$server_file_output,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc fst$retention
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc pfd$authority
*copyc pfd$permanent_file_definitions
*copyc pft$server_file_output
*copyc pmt$binary_mainframe_id
*copyc rmt$device_class
?? POP ??
*DECK DECK=PFT$DF_DEFINE_CATALOG EXPAND=FALSE
{ Parameters sent from CLIENT to SERVER.

  TYPE
    pft$df_define_catalog_inp = record
      { Parameters supplied by caller.
      charge_id: pft$charge_id,
      system_privilege: boolean,
      catalog_type_selected: boolean,
      selected_catalog_type: pft$catalog_types,
      mass_storage_request_included: boolean,
      path_length: pft$array_index,
    recend;

?? SKIP := 2 ??

{ Parameters received by CLIENT from SERVER.
{   status

?? PUSH (LISTEXT := ON) ??
*copyc pfd$charge_id
*copyc pfd$permanent_file_definitions
*copyc pft$catalog_types
?? POP ??
*DECK DECK=PFT$DF_DEFINE_DATA EXPAND=FALSE

{ Parameters sent from CLIENT to SERVER.

  TYPE
    pft$df_define_data_inp = record
      { Parameters supplied by caller.
      lfn: amt$local_file_name,
      mainframe_id: pmt$binary_mainframe_id,
      cycle_selector: pft$cycle_selector,
      update_cycle_statistics: boolean,
      password_selector: pft$password_selector,
      purge_cycle_options: pft$purge_cycle_options,
      replace_cycle_data: boolean,
      restore_selections: put$restore_data_selections,
      mandated_modification_time: pft$mandated_modification_time,
      path_length: pft$array_index,
      mass_storage_request_included: boolean,
      volume_list_length: integer,
      { Parameters supplied by ring 3 caller.
      validation_ring: ost$valid_ring,
    recend;

?? SKIP := 2 ??

{ Parameters received by CLIENT from SERVER.
{   buffer format
{   pft$df_define_data_outp
{   subfile array

  TYPE
    pft$df_define_data_outp = record
      mandated_modification_time: pft$mandated_modification_time,
      data_residence: pft$data_residence,
      authority: pft$authority,
      bytes_allocated: amt$file_byte_address,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc amt$local_file_name
*copyc osd$virtual_address
*copyc pfd$authority
*copyc pfd$mandated_modification_time
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*copyc pft$data_residence
*copyc pft$purge_cycle_options
*copyc pmt$binary_mainframe_id
*copyc put$restore_data_selections
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=PFT$DF_DELETE_ALL_ARCH_ENTRIES EXPAND=FALSE

{ Parameters sent from CLIENT to SERVER:

  TYPE
    pft$df_delete_all_arch_ent_inp = record
      cycle_selector: pft$cycle_selector,
      path_length: pft$array_index,
    recend;
{ PATH follows the buffer.
?? SKIP := 2 ??

{ Parameters received by CLIENT from SERVER:
{   status

*copyc pfd$permanent_file_definitions
*DECK DECK=PFT$DF_DELETE_ARCHIVE_ENTRY EXPAND=FALSE

{ Parameters sent from CLIENT to SERVER:

  TYPE
    pft$df_delete_archive_entry_inp = record
      cycle_selector: pft$cycle_selector,
      archive_identification: pft$archive_identification,
      path_length: pft$array_index,
    recend;
{ PATH follows the buffer.
?? SKIP := 2 ??

{ Parameters received by CLIENT from SERVER:
{   status

*copyc pfd$archive_definitions
*copyc pfd$permanent_file_definitions
*DECK DECK=PFT$DF_DELETE_PERMIT EXPAND=FALSE
{Deck: PFT$DELETE_PERMIT
{ Parameters sent from CLIENT >--> SERVER

  TYPE
    pft$df_delete_permit_inp = record
      object_type: pft$object_types,
      system_privilege: boolean,
      group: pft$group,
      path_length: pft$array_index,
    recend;
    { Path follows in the buffer.

?? SKIP := 5 ??
  { Parameters received from CLIENT <--< SERVER
  {   ost$status

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFT$DF_GET_FAMILY_SET EXPAND=FALSE
{ Parameters sent from CLIENT >---> SERVER

  TYPE
    pft$df_get_family_set_inp = record
      family_name: pft$name,
    recend;

?? SKIP := 5 ??
  { Parameters received from CLIENT <---< SERVER
  { pft$df_get_family_set_outp

  TYPE
    pft$df_get_family_set_outp = record
      set_name: stt$set_name,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
*copyc std$set_name
?? POP ??
*DECK DECK=PFT$DF_GET_INFO EXPAND=FALSE

*DECK DECK=PFT$DF_GET_INFO_IN EXPAND=FALSE

{ Parameters sent from CLIENT >---> SERVER

  TYPE
    pft$df_get_info_in = record
      info_selection: pft$get_info_selection,
      system_privilege: boolean,
      group: pft$group,
      catalog_info_selections: pft$catalog_info_selections,
      file_info_selections: pft$file_info_selections,
      path_length: pft$array_index,
    recend;

  { Path follows in buffer.

*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pft$get_info_selection
*DECK DECK=PFT$DF_GET_INFO_OUT EXPAND=FALSE
{ Parameters received from CLIENT <---< SERVER
{ ost$status

  TYPE
    pft$df_get_info_out = record
      info_size: ost$segment_length,
    recend;

*copyc osd$virtual_address

*DECK DECK=PFT$DF_GET_MCAT_INFO EXPAND=FALSE

{ Parameters sent from CLIENT to SERVER

  TYPE
    pft$df_get_mcat_info_inp = record
      family_name: pft$name,
      catalog_info_selections: pft$catalog_info_selections,
    recend;


  { Parameters received by CLIENT from SERVER
  { ost$status

  TYPE
    pft$df_get_mcat_info_outp = record
      info_size: ost$segment_length,
    recend;

*copyc osd$virtual_address
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*DECK DECK=PFT$DF_GET_OBJ_INFO_IN EXPAND=FALSE

{ Parameters sent from client to server.

  TYPE
    pft$df_get_obj_info_in = record
      binary_mainframe_id: pmt$binary_mainframe_id,
      evaluated_file_reference: fst$evaluated_file_reference,
      information_request: fst$goi_information_request,
      system_privilege: boolean,
      password_selector: pft$password_selector,
      subject_permit_count: ost$non_negative_integers,
      validation_ring: ost$valid_ring,
      validation_criterion_count: ost$non_negative_integers,
    recend;

    { If there are any validation_criteria, the array is in the data buffer.

*copyc fst$evaluated_file_reference
*copyc fst$goi_information_request
*copyc fst$goi_validation_criteria
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc pfd$password_selector
*copyc pmt$binary_mainframe_id
*DECK DECK=PFT$DF_GET_OBJ_INFO_OUT EXPAND=FALSE

{ Parameters received by client from server.

  TYPE
    pft$df_get_obj_info_out = record
      rpc_segment_used: boolean,
      object_info_offset: ost$segment_offset,
      info_size: ost$segment_length,
      status_included: boolean,
    recend;

    { Status follows in buffer, if included.
    { If there are any validation_criteria, the array is in the data buffer.

*copyc fst$goi_validation_criteria
*copyc osd$virtual_address
*copyc ost$status
*copyc pft$server_file_output
*DECK DECK=PFT$DF_MARK_RELEASE_CANDIDATE EXPAND=FALSE

{ Parameters sent from CLIENT to SERVER:

  TYPE
    pft$df_mark_rel_candidate_inp = record
      cycle_selector: pft$cycle_selector,
      password: pft$password,
      validation_ring: ost$valid_ring,
      archive_identification: pft$archive_identification,
      path_length: pft$array_index,
    recend;
{ PATH follows the buffer.
?? SKIP := 2 ??

{ Parameters received by CLIENT from SERVER:
{   status

*copyc osd$virtual_address
*copyc pfd$archive_definitions
*copyc pfd$permanent_file_definitions
*DECK DECK=PFT$DF_PERMIT_IN EXPAND=FALSE

  { Parameters sent by client to server.

  TYPE
    pft$df_permit_in = record
      path_length: pft$array_index,
      object_type: pft$object_types,
      system_privilege: boolean,
      permit_level: pft$permit_level,
      group: pft$group,
      permit_selections: pft$permit_selections,
      share_requirements: pft$share_requirements,
      application_info: pft$application_info,
    recend;

    { Path follows in buffer.

*copyc pfd$catalog
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc pft$permit_level
*DECK DECK=PFT$DF_PURGE_CATALOG_IN EXPAND=FALSE

{ Parameters sent from client to server.

  TYPE
    pft$df_purge_catalog_in = record
      path_length: pft$file_path_index,
      system_privilege: boolean,
      delete_option: pft$delete_option,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc pfd$complete_path
*copyc pft$delete_option
?? POP ??
*DECK DECK=PFT$DF_PURGE_IN EXPAND=FALSE

{ parameters sent from client to server

  TYPE
    pft$df_purge_in = record
      path_length: pft$file_path_index,
      cycle_selector: pft$cycle_selector,
      password: pft$password,
      purge_cycle_options: pft$purge_cycle_options,
      system_privilege: boolean,
      validation_ring: ost$valid_ring,
    recend;

    { Path follows in the buffer.

*copyc osd$virtual_address
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pft$purge_cycle_options
*DECK DECK=PFT$DF_PURGE_OUT EXPAND=FALSE

{ parameters received by client from server

  TYPE
    pft$df_purge_out = record
      authority: pft$authority,
      device_class: rmt$device_class,
      bytes_released: amt$file_byte_address,
      status_included: boolean,
    recend;

    { The status follows in this buffer, if included.

*copyc amt$file_byte_address
*copyc pfd$authority
*copyc rmt$device_class
*DECK DECK=PFT$DF_PUT_ARCHIVE_ENTRY EXPAND=FALSE

{ Parameters sent from CLIENT to SERVER:

  TYPE
    pft$df_put_archive_entry_inp = record
      cycle_selector: pft$cycle_selector,
      archive_identification: pft$archive_identification,
      archive_array_entry: pft$archive_array_entry,
      path_length: pft$array_index,
      amd_size: integer,
    recend;
{ PATH follows in the buffer.
{ ARCHIVE_MEDIA_DESCRIPTOR record follows in the buffer if small enough,
{ otherwise ARCHIVE_MEDIA_DESCRIPTOR will be found in the data buffer.

?? SKIP := 2 ??

{ Parameters received by CLIENT from SERVER:
{   status

*copyc pfd$archive_definitions
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*DECK DECK=PFT$DF_PUT_ARCHIVE_INFO EXPAND=FALSE

{ Parameters sent from CLIENT to SERVER:

  TYPE
    pft$df_put_archive_info_inp = record
      cycle_selector: pft$cycle_selector,
      path_length: pft$array_index,
      info_size: integer,
    recend;
{ PATH follows in the buffer.
{ INFO_RECORD follows in the buffer if it is small enough,
{ otherwise INFO_RECORD will be found in the data buffer.
?? SKIP := 2 ??

{ Parameters received by CLIENT from SERVER:
{   status

*copyc pfd$archive_definitions
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*DECK DECK=PFT$DF_PUT_CYCLE_INFO EXPAND=FALSE

{ Parameters sent from CLIENT to SERVER.

  TYPE
    pft$df_put_cycle_info_inp = record
      { Parameters supplied by caller.
      cycle_selector: pft$cycle_selector,
      password_selector: pft$password_selector,
      cycle_array_entry: pft$cycle_array_entry_version_2,
      path_length: pft$array_index,
    recend;

?? SKIP := 2 ??

{ Parameters received by CLIENT from SERVER.
{   ost$status

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_info
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFT$DF_PUT_ITEM_INFO_IN EXPAND=FALSE

  { parameters sent from client to server

  TYPE
    pft$df_put_item_info_in = record
      backup_file_version: pft$backup_file_version,
      info_size: integer,
      path_length: pft$file_path_index,
      permit_level: pft$permit_level,
      selection_criteria: put$selection_criteria,
      restore_archive_information: boolean,
      audit_restorations: boolean,
      permit_count: pft$permit_count,
      cycle_count: pft$cycle_count,
    recend;

    { The path and info_record follow in this buffer, if they're small enough;
    { otherwise they're in the data buffer.

*copyc pfd$catalog
*copyc pfd$catalog_info
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pft$permit_level
*copyc pud$selection_criteria
*DECK DECK=PFT$DF_PUT_ITEM_INFO_OUT EXPAND=FALSE

  { parameters received by client from server

  TYPE
    pft$df_put_item_info_out = record
      audit_restorations: boolean,
      all_permits_restored: boolean,
      auditable_permits: boolean,
      auditable_cycles: boolean,
      status_included: boolean,
    recend;

    { The status follows in this buffer, if included.
    { If there are auditable_permits and/or auditable_cycles; the array(s) are
    { in the data buffer.

*DECK DECK=PFT$DF_RELEASE_DATA EXPAND=FALSE

{ Parameters sent from CLIENT to SERVER:

  TYPE
    pft$df_release_data_inp = record
      cycle_selector: pft$cycle_selector,
      password: pft$password,
      release_data_info_included: boolean,
      path_length: pft$array_index,
    recend;
{ PATH follows in the buffer.

{ Parameters received by CLIENT from SERVER:
{   status

*copyc pfd$permanent_file_definitions
*DECK DECK=PFT$DF_REPLACE_ARCHIVE_ENTRY EXPAND=FALSE

{ Parameters sent from CLIENT to SERVER:

  TYPE
    pft$df_replace_arch_entry_inp = record
      cycle_selector: pft$cycle_selector,
      archive_identification: pft$archive_identification,
      archive_array_entry: pft$archive_array_entry,
      path_length: pft$array_index,
      amd_size: integer,
    recend;
{ PATH follows in the buffer.
{ ARCHIVE_MEDIA_DESCRIPTOR record follows in the buffer if small enough,
{ otherwise ARCHIVE_MEDIA_DESCRIPTOR will be found in the data buffer.

?? SKIP := 2 ??

{ Parameters received by CLIENT from SERVER:
{   status

*copyc pfd$archive_definitions
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*DECK DECK=PFT$DF_REPLACE_REM_MEDIA_FMD EXPAND=FALSE

{ Parameters sent from Client to Server:

  TYPE
    pft$df_replace_rem_me_fmd_inp = record
      cycle_selector: pft$cycle_selector,
      password_selector: pft$password_selector,
      path_length: pft$array_index,
      file_media_descriptor_size: integer,
      p_file_media_descriptor: ^SEQ ( * ),
    recend;

{ Path follows in the buffer.
{ File Media Descriptor record follows in the buffer if small enough,
{ otherwise it will be found in the data buffer.

*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*DECK DECK=PFT$DF_RESOLVE EXPAND=FALSE
{ Parameters sent from CLIENT >---> SERVER

  TYPE
    pft$df_resolve_inp = record
      system_privilege: boolean,
      cycle_reference: fst$cycle_reference,
      path_length: pft$array_index,
    recend;
    {Path follows in buffer.

?? SKIP := 5 ??
  { Parameters received from CLIENT <---< SERVER
  { pft$df_resolve_outp

  TYPE
    pft$df_resolve_outp = record
      cycle_reference: fst$cycle_reference,
      path_resolution: fst$path_resolution,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc fst$cycle_reference
*copyc fst$path_resolution
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFT$DF_RETURN EXPAND=FALSE

{ Parameters sent from CLIENT >--> SERVER

  TYPE
    pft$df_return_inp = record
      attached_pf_table_index: pft$attached_pf_table_index,
      mainframe_id: pmt$binary_mainframe_id,
      server_sfid: dmt$system_file_id,
      device_class: rmt$device_class,
      case attached_for_write: boolean of
      = TRUE =
        eoi_byte_address: amt$file_byte_address,
      = FALSE =
        ,
      casend,
    recend;


?? SKIP := 2 ??

{ Parameters sent from SERVER to CLIENT

  TYPE
    pft$df_return_outp = record
      authority: pft$authority,
      bytes_allocated_change: sft$counter,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc dmt$system_file_id
*copyc pfd$authority
*copyc pft$attached_pf_table_index
*copyc pmt$binary_mainframe_id
*copyc rmt$device_class
*copyc sft$counter
?? POP ??
*DECK DECK=PFT$DF_SAVE_FILE_LABEL_IN EXPAND=FALSE

{ parameters sent from client to server

  TYPE
    pft$df_save_file_label_in = record
      attached_pf_table_index: pft$attached_pf_table_index,
      system_authority: pft$system_authority,
      required_permission: pft$permit_options,
      file_label_size: pft$file_label_size,
      audit: {i/o} boolean,
    recend;

    { If there is a file_label; it follows in this buffer if it's small enough,
    { otherwise it's in the data buffer.

*copyc pfd$attached_permanent_file_id
*copyc pfd$catalog
*copyc pfd$permanent_file_attributes
*copyc pft$system_authority
*DECK DECK=PFT$DF_SAVE_LABEL_OUT EXPAND=FALSE

  { parameters received by client from server

  TYPE
    pft$df_save_label_out = record
      audit: boolean,
      status_included: boolean,
    recend;

    { The save_label_audit_info follows in this buffer, if included.
    { The path is included if auditing and if pfp$save_file_label was called.
    { If included; the path and status follow in this buffer if they're small
    { enough, otherwise they're in the data buffer.

*DECK DECK=PFT$DF_SAVE_RELEASED_LABEL_IN EXPAND=FALSE

{ parameters sent from client to server

  TYPE
    pft$df_save_released_label_in = record
      path_length: pft$file_path_index,
      cycle_selector: pft$cycle_selector,
      password_selector: pft$password_selector,
      file_label_size: pft$file_label_size,
      validation_ring: ost$valid_ring,
      update_cycle_statistics: boolean,
      audit: boolean,
    recend;

    { The path and file label follow in this buffer, if they're small enough;
    { otherwise they're in the data buffer.

*copyc osd$virtual_address
*copyc pfd$catalog
*copyc pfd$complete_path
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*DECK DECK=PFT$DF_VALIDATE_PASSWORD EXPAND=FALSE
{ DECK: pft$df_validate_password
{ Parameters sent from CLIENT to SERVER.

  TYPE
    pft$df_validate_password_inp = record
      password: pft$password,
      path_length: pft$array_index,
    recend;
    { Path follows in the buffer.

?? SKIP := 2 ??

{ Parameters sent from SERVER to CLIENT
{   ost$status

?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFT$EXCEPTION_SELECTION_INFO EXPAND=FALSE

  TYPE
    pft$exception_selection_info = record
      access_level: amt$access_level,
      delete_data: boolean,
      open_position: amt$open_position,
      open_position_source: amt$attribute_source,
    recend;

*copyc amt$access_level
*copyc amt$attribute_source
*copyc amt$open_position
*DECK DECK=PFT$FAMILY_LOCATION EXPAND=FALSE
  TYPE
     pft$family_location =
      (pfc$local_mainframe, pfc$server_mainframe);
*DECK DECK=PFT$FAP_AUDIT_INFO EXPAND=FALSE

  TYPE
    pft$fap_audit_info = record
      case audit: boolean of
      = FALSE =
        ,
      = TRUE =
        fap_name: ost$name,
      casend,
    recend;

*copyc ost$name
*DECK DECK=PFT$FILE_MEDIA_DESCRIPTION EXPAND=FALSE

  TYPE
    pft$p_file_media_description = ^pft$file_media_description,

    pft$file_media_description = record
      global_file_name: ost$binary_unique_name,
      file_media_type: pft$file_media_type,
      checksum: pft$checksum,
      file_media_descriptor: SEQ ( * ),
    recend;

*copyc ost$binary_unique_name
*copyc pft$checksum
*copyc pft$file_media_type
*DECK DECK=PFT$FILE_MEDIA_TYPE EXPAND=FALSE

  TYPE
    pft$file_media_type = record
      device_class: rmt$device_class,
      media_version: pft$file_media_version,
    recend,

    pft$file_media_version = (pfc$file_media_disk_version_1,
          pfc$file_media_disk_version_2, pfc$file_media_disk_version_3,
          pfc$file_media_disk_version_4, pfc$file_media_disk_version_5,
          pfc$file_media_disk_version_6, pfc$file_media_disk_version_7,
          pfc$file_media_disk_version_8, pfc$file_media_disk_version_9,
          pfc$file_media_disk_version_10, pfc$file_media_disk_version_11);

*copyc rmt$device_class
*DECK DECK=PFT$FILE_PATH_COUNT EXPAND=FALSE

  TYPE
    pft$file_path_count = 0 .. pfc$maximum_catalog_depth + 1;

*copyc pfd$complete_path
*DECK DECK=PFT$FMD_HEADER EXPAND=FALSE

  TYPE
    pft$fmd_header = record
      clear_space: ost$clear_file_space,
      file_limit: amt$file_limit,
      number_of_subfiles: dmt$subfile_index,
      overflow_allowed: boolean,
      preset_value: amt$preset_value,
      requested_allocation_size: dmt$allocation_size,
      requested_class: dmt$class_member,
      requested_class_ordinal: dmt$class_ordinal,
      requested_transfer_size: dmt$transfer_size,
      requested_volume: dmt$requested_volume,
    recend;

*copyc amt$file_limit
*copyc amt$preset_value
*copyc dmt$allocation_size
*copyc dmt$class
*copyc dmt$requested_volume_attributes
*copyc dmt$subfile_index
*copyc dmt$transfer_size
*copyc ost$clear_file_space

*DECK DECK=PFT$GET_INFO_SELECTION EXPAND=FALSE
   TYPE
     PFT$GET_Info_SELECTION= (pfc$get_item_info, pfc$get_multi_item_info);

*DECK DECK=PFT$LOCKED_CATALOG_LIST EXPAND=FALSE
  TYPE
    pft$locked_catalog_list = array [1 .. pfc$max_locked_catalogs] of ^cell;

?? PUSH (LISTEXT := ON) ??
*copyc pfc$max_locked_catalogs
?? POP ??
*DECK DECK=PFT$MOVE_OBJECT_INFO EXPAND=FALSE
  TYPE
    pft$move_object_info = record
      class_statistics: pft$class_movement_statistics,
      dest_volume_list_p: ^array [1 .. * ] of ^pft$mo_volume,
      mass_storage_class: dmt$class,
      move_bytes_threshold: ost$non_negative_integers,
      move_status: pft$move_status,
      overall_statistics: pft$movement_statistics,
      perform_move: boolean,
      performance_statistics: pft$performance_statistics,
      release_mass_storage: pft$mo_release_mass_storage,
      set_name: ost$name,
      set_volume_list_p: ^pft$mo_volume_list,
      source_volume_list_p: ^array [1 .. * ] of ^pft$mo_volume,
      update_available_space_total: ost$non_negative_integers,
      volume_overflow_allowed: boolean,
      wait: boolean,
    recend;

  TYPE
    pft$mo_volume = record
      available: boolean,
      bytes_moved_from: ost$non_negative_integers,
      bytes_moved_to: ost$non_negative_integers,
      bytes_released: ost$non_negative_integers,
      catalogs_moved_from: ost$non_negative_integers,
      catalogs_moved_to: ost$non_negative_integers,
      cycles_moved_from: ost$non_negative_integers,
      cycles_moved_to: ost$non_negative_integers,
      cycles_released: ost$non_negative_integers,
      logical_unit_number: iot$logical_unit,
      mass_storage_available: ost$non_negative_integers,
      mass_storage_before: ost$non_negative_integers,
      mass_storage_capacity: ost$non_negative_integers,
      move_bytes_threshold_exceeded: boolean,
      ms_class: dmt$class,
      recorded_vsn: rmt$recorded_vsn,
      volume_type: pft$mo_volume_type,
    recend;

  TYPE
    pft$mo_volume_list = array [1 .. * ] of pft$mo_volume,
    pft$mo_volume_list_p = array [1 .. * ] of ^pft$mo_volume;

  TYPE
    pft$mo_release_mass_storage = (pfc$always, pfc$never, pfc$when_insufficient_space);

  TYPE
    pft$mo_volume_type = (pfc$source_volume, pfc$destination_volume, pfc$unspecified_volume);

  TYPE
    pft$movement_statistics = record
      abnormal_status: ost$non_negative_integers,
      bytes_moved: ost$non_negative_integers,
      bytes_released: ost$non_negative_integers,
      cycle_busy: ost$non_negative_integers,
      cycles_released: ost$non_negative_integers,
      insufficient_space: ost$non_negative_integers,
      no_available_space: ost$non_negative_integers,
      objects_moved: ost$non_negative_integers,
      objects_not_moved: ost$non_negative_integers,
      unrecovered_read_error: ost$non_negative_integers,
    recend;

  TYPE
    pft$class_movement_statistics = array ['A' .. 'Z'] of pft$movement_statistics;

  TYPE
    pft$reason_for_move_failure = (pfc$cycle_busy, pfc$data_released, pfc$device_class_not_ms,
          pfc$insufficient_space, pfc$io_error, pfc$no_available_space, pfc$operator_skip,
          pfc$operator_terminate, pfc$set_threshold_exceeded, pfc$unexpected_abort,
          pfc$volume_threshold_exceeded);

  TYPE
    pft$mo_operator_response = (pfc$retry_move, pfc$skip_object, pfc$terminate_command);

  TYPE
    pft$move_status = record
      allocated_size: ost$non_negative_integers,
      ms_class: dmt$class_member,
      new_subfile_list_p: ^pft$subfile_list,
      old_subfile_list_p: ^pft$subfile_list,
      volume_list_storage_p: ^SEQ (*),
      case move_successful: boolean of
      = TRUE =
        data_residence: pft$data_residence,
        modification_date_time: ost$date_time,
      = FALSE =
        reason_for_move_failure: pft$reason_for_move_failure,
      casend,
    recend;

  TYPE
    pft$performance_statistics = record
      catalog_count: ost$non_negative_integers,
      cycle_count: ost$non_negative_integers,
      file_count: ost$non_negative_integers,
      initial_date_time: ost$date_time,
      initial_microsecond_clock: integer,
      initial_task_cp_time: pmt$task_cp_time,
    recend;

*copyc dmt$class
*copyc iot$logical_unit
*copyc osd$integer_limits
*copyc ost$date_time
*copyc ost$name
*copyc pft$data_residence
*copyc pft$subfile_list
*copyc pmt$task_cp_time
*copyc rmt$recorded_vsn
*DECK DECK=PFT$OBJECT_NAME_LIST EXPAND=FALSE

  TYPE
    pft$object_name = record
      object_name: pft$name,
      object_index: pft$object_index,
    recend,
    pft$object_name_list = array [1 .. * ] of pft$object_name;

*copyc pfd$catalog
*copyc pfd$permanent_file_definitions
*DECK DECK=PFT$OVERHAUL_CHOICES EXPAND=FALSE

  TYPE
    { pfc$all_catalogs:  subcatalogs and their subtrees will be processed,
    {                    as well as the specified catalog;
    { pfc$recover_purged_files:  purged files will be recovered, when possible;
    { pfc$validate_files:  checksums will be validated;
    { pfc$reorganize_catalogs:  catalogs will be reorganized to improve
    {                           locality of reference;
    { pfc$reconcile_fmds:  catalog FMDs and file cycle FMDs will be reconciled
    {                      with device management;
    { pfc$delete_unreconciled_objects:  irreconcilable file cycles and catalogs
    {                                   will be deleted.

    { If either pfc$reorganize_catalogs or pfc$delete_unreconciled_objects is
    { selected, then pfc$reconcile_fmds must also be selected.

    pft$set_overhaul_options = (pfc$all_catalogs, pfc$recover_purged_files,
      pfc$validate_files, pfc$reorganize_catalogs, pfc$reconcile_fmds,
      pfc$delete_unreconciled_objects),
    pft$set_overhaul_choices = set of pft$set_overhaul_options,

    pft$catalog_overhaul_options = pfc$all_catalogs .. pfc$validate_files,
    pft$catalog_overhaul_choices = set of pft$catalog_overhaul_options;

*DECK DECK=PFT$PASSWORD_INFO EXPAND=FALSE

  TYPE
    pft$password_info = record
      case validate_password: boolean of
      = FALSE =
        ,
      = TRUE =
        password: pft$password,
        password_protected: boolean,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PFT$PERMIT_LEVEL EXPAND=FALSE

  TYPE
    pft$permit_level = (pfc$pl_unknown, pfc$pl_public, pfc$pl_family,
          pfc$pl_account, pfc$pl_project, pfc$pl_user, pfc$pl_owner);

*DECK DECK=PFT$PURGE_CYCLE_OPTIONS EXPAND=TRUE

  TYPE
    pft$purge_cycle_options = record
      enforce_password_validation: boolean,
      enforce_ring_validation: boolean,
      case preserve_cycle_entry: boolean of
      = TRUE =
        preserve_archive_info: boolean,
        preserve_file_label: boolean,
        preserve_modification_date_time: boolean,
      = FALSE =
        ,
      casend,
    recend;
*DECK DECK=PFT$R2_ATTACH_IN EXPAND=FALSE

  TYPE
    pft$r2_attach_in = record
      lfn: amt$local_file_name,
      cycle_selector: pft$cycle_selector,
      password: pft$password,
      case served_family: boolean of
      = FALSE =
        p_complete_path: ^pft$complete_path,
      = TRUE =
        served_family_locator: pft$served_family_locator,
        p_path: ^pft$path,
      casend,
    recend;

*copyc amt$local_file_name
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*copyc pft$served_family_locator
*DECK DECK=PFT$RELEASE_DATA_INFO EXPAND=FALSE
                                                                               
  TYPE                                                                         
    pft$release_data_info = record                                             
      perform_changes: {input} boolean,                                        
      release_attached_cycle_data: {input} boolean,                            
      update_last_release_date_time: {input} boolean,                          
      valid_archive_entry_required: {input} boolean,                           
      cycle_attached: {output} boolean,                                        
      case valid_archive_entry_found: {output} boolean of                      
      = TRUE =                                                                 
        ,                                                                      
      = FALSE =                                                                
        old_data_modification_date_time: ost$date_time,                        
        new_data_modification_date_time: ost$date_time,                        
      casend,                                                                  
  recend;                                                                      
                                                                               
*copyc ost$date_time                                                           
*DECK DECK=PFT$RELINK_SERVER_FILE EXPAND=FALSE
{Deck:  PFT$RELINK_SERVER_FILE
  TYPE
    pft$relink_server_file_inp  = record
      global_file_name: dmt$global_file_name,
      attached_pf_table_index: pft$attached_pf_table_index,
    recend,

    pft$relink_server_file_outp  = record
      usage_selections: pft$usage_selections,
      share_selections: pft$share_selections,
      dm_parameters: dmt$server_file_output,
    recend;

*copyc dmt$global_file_name
*copyc dmt$server_file_output
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc pft$attached_pf_table_index

*DECK DECK=PFT$RESERVED_CYCLES EXPAND=FALSE

  TYPE
    pft$reserved_cycle_info = record
      signature_lock: ost$signature_lock,
      p_catalog_path: ^pft$complete_path,
      number_of_cycles_reserved: pft$cycle_count,
      p_reserved_cycles: ^pft$reserved_cycles,
    recend,

    pft$reserved_cycles = array [1 .. *] of pft$reserved_cycle,

    pft$reserved_cycle = record
      external_object_name: pft$name,
      internal_object_name: pft$internal_name,
      cycle_number: pft$cycle_number,
      internal_cycle_name: pft$internal_name,
      system_file_id: dmt$system_file_id,
    recend;

*copyc dmt$system_file_id
*copyc ost$signature_lock
*copyc pfd$catalog
*copyc pfd$complete_path
*copyc pfd$internal_name
*copyc pfd$permanent_file_definitions
*copyc pft$cycle_count

*DECK DECK=PFT$RESTORE_CATALOG_STATUS EXPAND=FALSE
  TYPE
    pft$restore_catalog_status = (pfc$catalog_already_exists,
          pfc$catalog_recreated, pfc$catalog_recovered);


*DECK DECK=PFT$RETAINED_RESTORE_STATUS EXPAND=FALSE

  { This deck contains the types and string constants that describe the
  { status of a RESTORE_MISSING_CATALOGS.  These values are maintained
  { across deadstarts.

  TYPE
    pft$retained_restore_status = string (8);

  CONST
    pfc$restore_missing_cat_done = 'RESCDONE',
    pfc$restore_missing_cat_start = 'RESCSTRT';


*DECK DECK=PFT$RETRIEVE_OPTION EXPAND=FALSE

  TYPE
    pft$retrieve_option = (pfc$always_retrieve, pfc$explicit_retrieve_only,
          pfc$admin_retrieve_only);
*DECK DECK=PFT$RETURN_FILES_OPTION EXPAND=FALSE
  TYPE
    pft$return_files_option = record
      case return_files: boolean of
      = FALSE =
        ,
      = TRUE =
        files_returned {Output} : ost$non_negative_integers,
        log_returned_files: boolean,
        case wait_for_down_volume: boolean of
        = TRUE =
          ,
        = FALSE =
          files_on_down_device {Output} : ost$non_negative_integers,
        casend,
      casend,
    recend;


*copyc osd$integer_limits
*DECK DECK=PFT$RING_AUDIT_INFO EXPAND=FALSE

  TYPE
    pft$ring_audit_info = record
      case audit: boolean of
      = FALSE =
        ,
      = TRUE =
        ring_attributes: amt$ring_attributes,
      casend,
    recend;

*copyc amt$ring_attributes
*DECK DECK=PFT$SAVE_LABEL_AUDIT_INFO EXPAND=FALSE

  TYPE
    pft$save_label_audit_info = record
      file_path_count: pft$file_path_count,
      cycle_selector: pft$cycle_selector,
      device_class: rmt$device_class,
      ownership: pft$ownership,
      fap_audit_info: pft$fap_audit_info,
      ring_audit_info: pft$ring_audit_info,
    recend;

*copyc pfd$authority
*copyc pfd$permanent_file_definitions
*copyc pft$fap_audit_info
*copyc pft$file_path_count
*copyc pft$ring_audit_info
*copyc rmt$device_class
*DECK DECK=PFT$SELECTIONS_STRING EXPAND=FALSE

  TYPE
    pft$selections_string = record
      size: integer,
      value: string (127),
    recend;

*DECK DECK=PFT$SERVED_FAMILY_LOCATOR EXPAND=FALSE

  TYPE
    pft$served_family_locator = record
     server_mainframe_id: pmt$binary_mainframe_id,
     served_family_table_index: dft$served_family_table_index,
     server_location: dft$server_location,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
*copyc dft$served_family_table_index
*copyc dft$server_location
?? POP ??
*DECK DECK=PFT$SERVER_ATTACH_OUTPUT EXPAND=FALSE
  TYPE
    pft$server_attach_output = record
      { parameters returned on normal attach
      cycle_damage_symptoms: fst$cycle_damage_symptoms,
      cycle_number: pft$cycle_number,
      allowed_usage_selections: pft$usage_selections,
      required_share_selections: pft$share_selections,

      { Parameters returned only on server attach
      usage_selections: pft$usage_selections,
      share_selections: pft$share_selections,
      cycle_created: boolean,
      application_info: pft$application_info,
      allow_other_mainframe_writer: boolean,
      global_file_name: dmt$global_file_name,
      attached_pf_table_index: pft$attached_pf_table_index,
      label_replaced: boolean,
      label_length: pft$file_label_size,
      label_included: boolean,
      password_protected: boolean,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$global_file_name
*copyc fst$cycle_damage_symptoms
*copyc pfd$catalog
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc pft$attached_pf_table_index
?? POP ??
*DECK DECK=PFT$SERVER_FILE_OUTPUT EXPAND=FALSE

  TYPE
    pft$server_file_output = record
      allow_other_mainframe_writer: boolean,
      application_info: pft$application_info,
      attached_pf_table_index: pft$attached_pf_table_index,
      cycle_created: boolean,
      cycle_number: pft$cycle_number,
      dm_parameters: dmt$server_file_output,
      global_file_name: dmt$global_file_name,
      label_length: pft$file_label_size,
      password_protected: boolean,
      rem_media_fmd_length: pft$fmd_size,
      share_selections: pft$share_selections,
      usage_selections: pft$usage_selections,
    recend,

    pft$file_server_buffers = record
      p_send_parameters: dft$p_send_parameters,
      p_send_data: dft$p_send_data,
    recend,

    pft$p_file_server_buffers = ^pft$file_server_buffers;

?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_parameters
*copyc dmt$global_file_name
*copyc pfd$catalog
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc pft$attached_pf_table_index
*copyc dmt$server_file_output
?? POP ??
*DECK DECK=PFT$SERVER_QUEUE_LOCATOR EXPAND=FALSE

  TYPE
    pft$server_queue_locator = record
     p_queue_interface_table: dft$p_queue_interface_table,
     queue_index: dft$queue_index,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc dfd$driver_queue_types
*copyc dft$queue_index
?? POP ??
*DECK DECK=PFT$SHARED_QUEUE EXPAND=FALSE

  TYPE
    pft$shared_queue = 0 .. 127;
*DECK DECK=PFT$SHARED_QUEUE_INFO EXPAND=FALSE

  TYPE
    pft$shared_queue_info = packed record
      case defined: boolean of
      = FALSE =
        ,
      = TRUE =
        shared_queue: pft$shared_queue,
      casend,
    recend;

*copyc pft$shared_queue
*DECK DECK=PFT$SITE_ARCHIVE_OPTION EXPAND=FALSE

  TYPE
    pft$site_archive_option = 0 .. 255;

*copyc pfc$null_site_archive_option
*DECK DECK=PFT$SITE_BACKUP_OPTION EXPAND=FALSE

  TYPE
    pft$site_backup_option = 0 .. 255;

*copyc pfc$null_site_backup_option
*DECK DECK=PFT$SITE_RELEASE_OPTION EXPAND=FALSE

  TYPE
    pft$site_release_option = 0 .. 255;

*copyc pfc$null_site_release_option
*DECK DECK=PFT$SUBFILE EXPAND=FALSE
  TYPE
    pft$subfile = record
      recorded_vsn: rmt$recorded_vsn,
      byte_address: amt$file_byte_address,
      allocated_length: amt$file_byte_address,
    recend;

*copyc amt$file_byte_address
*copyc rmt$recorded_vsn
*DECK DECK=PFT$SUBFILE_LIST EXPAND=FALSE
  TYPE
    pft$subfile_list = array [1 .. * ] of pft$subfile;

*copyc pft$subfile
*DECK DECK=PFT$SYSTEM_AUTHORITY EXPAND=FALSE

  TYPE
    pft$system_authority = 0 .. 0ffff(16);

*DECK DECK=PFT$UNIQUE_VOLUME_DESC EXPAND=FALSE

  TYPE
    pft$unique_volume_desc = record
      internal_vsn: dmt$internal_vsn,
      recorded_vsn: rmt$recorded_vsn,
    recend;

*copyc dmt$internal_vsn
*copyc rmt$recorded_vsn

*DECK DECK=PFT$UNIQUE_VOLUME_LIST EXPAND=FALSE

  TYPE
    pft$unique_volume_list = array [1 .. *] of pft$unique_volume_desc;

*copyc pft$unique_volume_desc

*DECK DECK=PFT$VARIANT_PATH EXPAND=FALSE

  TYPE
    pft$variant_path = record
      case complete_path: boolean of
      = FALSE =
        p_path: ^pft$path,
      = TRUE =
        p_complete_path: ^pft$complete_path,
      casend,
    recend;

*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
*DECK DECK=PFT$VOLUME_LIST EXPAND=FALSE

  TYPE
    pft$volume_list = array [1 .. *] of rmt$recorded_vsn;

*copyc rmt$recorded_vsn
*DECK DECK=PFV$ALLOW_CATALOG_WRITE EXPAND=FALSE

      VAR
    pfv$allow_catalog_write: [XREF] boolean;

*DECK DECK=PFV$ATTACHED_PF_TABLE_LOCK EXPAND=FALSE
  var
    PFV$ATTACHED_PF_TABLE_LOCK: [XREF] ost$signature_lock;
?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??
*DECK DECK=PFV$BINARY_CATALOG_SEARCH EXPAND=FALSE
  VAR
    pfv$binary_catalog_search: [XREF] boolean;
*DECK DECK=PFV$CATALOG_INFO_REQUESTS EXPAND=FALSE

  VAR
    pfv$catalog_info_requests: [XREF] fst$goi_object_info_requests;

?? PUSH (LISTEXT := ON) ??
*copyc fst$goi_object_info_requests
?? POP ??
*DECK DECK=PFV$CYCLE_INFO_REQUESTS EXPAND=FALSE

  VAR
    pfv$cycle_info_requests: [XREF] fst$goi_object_info_requests;

?? PUSH (LISTEXT := ON) ??
*copyc fst$goi_object_info_requests
?? POP ??
*DECK DECK=PFV$DEBUG_CATALOG_ACCESS EXPAND=FALSE

  VAR
    pfv$debug_catalog_access: [XREF] boolean;

*DECK DECK=PFV$FAMILY_ADMINISTRATOR EXPAND=FALSE

  VAR
    pfv$family_administrator: [XREF] boolean;
*DECK DECK=PFV$FILE_INFO_REQUESTS EXPAND=FALSE

  VAR
    pfv$file_info_requests: [XREF] fst$goi_object_info_requests;

?? PUSH (LISTEXT := ON) ??
*copyc fst$goi_object_info_requests
?? POP ??
*DECK DECK=PFV$FLUSH_CATALOGS EXPAND=FALSE

  VAR
    pfv$flush_catalogs: [XREF] boolean;

*DECK DECK=PFV$LOCKED_APFID EXPAND=FALSE
  VAR
    pfv$locked_apfid: [XREF] 0 .. 0ffff(16);

*DECK DECK=PFV$LOCKED_CATALOG_LIST EXPAND=FALSE

  VAR
    pfv$locked_catalog_list: [XREF] pft$locked_catalog_list;

?? PUSH (LISTEXT := ON) ??
*copyc pft$locked_catalog_list
?? POP ??
*DECK DECK=PFV$NULL_CATALOG_ENTRY_SPACE EXPAND=FALSE

  VAR
    pfv$null_catalog_entry_space: [XREF] array [1 .. 47] of boolean;

*DECK DECK=PFV$NULL_CYCLE_ENTRY_SPACE EXPAND=FALSE

  VAR
    pfv$null_cycle_entry_space: [XREF] array [1 .. 34] of boolean;
*DECK DECK=PFV$NULL_DATE_TIME EXPAND=TRUE

  VAR
    pfv$null_date_time: [XREF] ost$date_time;

*copyc ost$date_time
*DECK DECK=PFV$NULL_FILE_ENTRY_SPACE EXPAND=FALSE

  VAR
    pfv$null_file_entry_space: [XREF] array [1 .. 48] of boolean;

*DECK DECK=PFV$NULL_OBJECT_ENTRY_SPACE EXPAND=FALSE

  VAR
    pfv$null_object_entry_space: [XREF] array [1 .. 6] of integer;

*DECK DECK=PFV$NULL_TAPE_FMD_HEADER_SPACE EXPAND=FALSE

  VAR
    pfv$null_tape_fmd_header_space: [XREF] array [1 .. 48] of boolean;
*DECK DECK=PFV$NULL_UNIQUE_NAME EXPAND=FALSE

  VAR
    pfv$null_unique_name: [XREF] ost$binary_unique_name;

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
?? POP ??
*DECK DECK=PFV$PERMIT_LEVEL EXPAND=FALSE

  VAR
    pfv$permit_level: [XREF] pft$permit_level;

?? PUSH (LISTEXT := ON) ??
*copyc pft$permit_level
?? POP ??
*DECK DECK=PFV$P_ATTACHED_PF_TABLE EXPAND=FALSE

  VAR

PFV$P_ATTACHED_PF_TABLE: [XREF]
                            pft$p_attached_pf_table ;

?? PUSH (LISTEXT := ON) ??
*copyc pfd$attached_pf_table
?? POP ??
*DECK DECK=PFV$P_ATTACHED_PF_TABLE_LOCK EXPAND=FALSE

var
    pfv$p_attached_pf_table_lock: [XREF] ^ost$signature_lock;
?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??
*DECK DECK=PFV$P_LOCKED_CATALOG EXPAND=FALSE
  VAR
    pfv$p_locked_catalog: [XREF] ^pft$catalog_locator;

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_locator
?? POP ??
*DECK DECK=PFV$P_NEWEST_QUEUED_CATALOG EXPAND=FALSE
    VAR
PFV$P_NEWEST_QUEUED_CATALOG : [XREF]
                                    pft$p_queued_catalog;
?? PUSH (LISTEXT := ON) ??
*copyc pfd$queued_catalog_table
?? POP ??
*DECK DECK=PFV$P_P_ATTACHED_PF_TABLE EXPAND=FALSE
  var
    pfv$p_p_attached_pf_table : [XREF] ^pft$p_attached_pf_table;
?? PUSH (LISTEXT := ON) ??
*copyc pfd$attached_pf_table
?? POP ??
*DECK DECK=PFV$P_P_JOB_HEAP EXPAND=FALSE
           var
   pfv$p_p_job_heap: [XREF] ^^ost$heap;
?? PUSH (LISTEXT := ON) ??
*copyc ost$heap
?? POP ??
*DECK DECK=PFV$P_P_NEWEST_QUEUED_CATALOG EXPAND=FALSE
  VAR
    pfv$p_p_newest_queued_catalog: [XREF] ^pft$p_queued_catalog;

?? PUSH (LISTEXT := ON) ??
*copyc pfd$queued_catalog_table
?? POP ??
*DECK DECK=PFV$P_P_QUEUED_CATALOG_TABLE EXPAND=FALSE
   var
    pfv$p_p_queued_catalog_table: [XREF] ^pft$p_queued_catalog_table;
?? PUSH (LISTEXT := ON) ??
*copyc pfd$queued_catalog_table
?? POP ??
*DECK DECK=PFV$P_QUEUED_CATALOG_TABLE EXPAND=FALSE

    var
      PFV$P_QUEUED_CATALOG_TABLE: [XREF] pft$p_queued_catalog_table;
?? PUSH (LISTEXT := ON) ??
*copyc pfd$queued_catalog_table
?? POP ??
*DECK DECK=PFV$P_QUEUED_CATALOG_TABLE_LOCK EXPAND=FALSE
  VAR
    pfv$p_queued_catalog_table_lock: [XREF] ^ost$signature_lock;

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??
*DECK DECK=PFV$QUEUED_CATALOG_TABLE_LOCK EXPAND=FALSE

 VAR
   PFV$QUEUED_CATALOG_TABLE_LOCK: [XREF]  ost$signature_lock;
?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??
*DECK DECK=PFV$RESERVED_CYCLE_INFO EXPAND=FALSE

  VAR
    pfv$reserved_cycle_info: [XREF] pft$reserved_cycle_info;

*copyc pft$reserved_cycles
*DECK DECK=PFV$RESTRICT_CATALOG_FLUSHING EXPAND=FALSE

  VAR
    pfv$restrict_catalog_flushing: [XREF] boolean;

*DECK DECK=PFV$SORT_CATALOG_OBJECT_LIST EXPAND=FALSE
  VAR
    pfv$sort_catalog_object_list: [XREF] boolean;
*DECK DECK=PFV$SPACE_CHARACTER EXPAND=FALSE

  VAR
    pfv$space_character: [XREF] set of char;

*DECK DECK=PFV$SYSTEM_ADMINISTRATOR EXPAND=FALSE

  VAR
    pfv$system_administrator: [XREF] boolean;

*DECK DECK=PFV$SYSTEM_AUTHORITY EXPAND=FALSE

  VAR
    pfv$system_authority: [XREF] pft$system_authority;

?? PUSH (LISTEXT := ON) ??
*copyc pft$system_authority
?? POP ??
*DECK DECK=PFV$TASK_ACCOUNT EXPAND=FALSE
    VAR
   pfv$task_account:  [XREF] avt$account_name;
?? PUSH (LISTEXT := ON) ??
*copyc avt$account_name
?? POP ??
*DECK DECK=PFV$TASK_FAMILY EXPAND=FALSE
        VAR
    pfv$task_family:  [XREF] ost$family_name;
?? PUSH (LISTEXT := ON) ??
*copyc ost$user_identification
?? POP ??
*DECK DECK=PFV$TASK_PROJECT EXPAND=TRUE

    VAR
   pfv$task_project:  [XREF] avt$project_name;
?? PUSH (LISTEXT := ON) ??
*copyc avt$project_name
?? POP ??
*DECK DECK=PFV$TASK_USER EXPAND=FALSE
                    VAR
    pfv$task_user:  [XREF] ost$user_name;
?? PUSH (LISTEXT := ON) ??
*copyc ost$user_identification
?? POP ??
*DECK DECK=PFV$UNATTACHED_STATUS EXPAND=FALSE

  VAR
    pfv$unattached_status: [XREF] pft$attach_status;

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog
?? POP ??
*DECK DECK=PFV$UNLOCK_CATALOG_THRESHOLD EXPAND=FALSE
  VAR
    pfv$unlock_catalog_threshold: [XREF] integer;

*DECK DECK=PFV$VERIFY_CATALOG_HEAPS EXPAND=FALSE

  VAR
    pfv$verify_catalog_heaps: [XREF] boolean;

*DECK DECK=PFV$WRITE_USAGE EXPAND=FALSE

  VAR
    pfv$write_usage: [XREF] pft$usage_selections;

?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_attributes
?? POP ??
*DECK DECK=PMC$CONDITION_LIMITS EXPAND=FALSE
*copyc pmc$min_ecc

  CONST
    pmc$min_scc = pmc$min_ecc,
    pmc$max_scc = pmc$min_scc + 9999;

*DECK DECK=PMC$DEFAULT_USER_STACK_SIZE EXPAND=FALSE

  CONST
    pmc$default_user_stack_size = 2000000,
    pmc$maximum_user_stack_size = 78000000(16);
*DECK DECK=PMC$INTERNAL_BASE_EXCEPTION EXPAND=FALSE

*copyc PMC$PC_BASE_EXCEPTION
*copyc PMC$PROGRAM_MANAGEMENT_ID

  CONST
    pmc$internal_base_exception = pmc$pc_base_exception + 4900;

*DECK DECK=PMC$MIN_ECC EXPAND=FALSE

  CONST
*IF $true(osv$unix)
    pmc$min_ecc = (($INTEGER ('P') * 100(16)) + $INTEGER ('M')) * 10000(16);
*ELSE
    pmc$min_ecc = (($INTEGER ('P') * 100(16)) + $INTEGER ('M')) * 1000000(16);
*IFEND
*DECK DECK=PMC$MIN_SCC_PROGRAM_EXECUTION EXPAND=FALSE
*copyc PMC$CONDITION_LIMITS
?? NEWTITLE := 'PMDSPE : Program Execution Statistics : ''PM'' 0 .. 4999' ??

  CONST
    pmc$min_scc_program_execution   = pmc$min_scc,

    pml$task_begin                  = pmc$min_scc_program_execution +    0,
    pml$task_name                   = pmc$min_scc_program_execution +    1,
    pml$starting_procedure_name     = pmc$min_scc_program_execution +    2,
    pml$task_end                    = pmc$min_scc_program_execution +    3,

    pml$call_loader                 = pmc$min_scc_program_execution +    4,
    pml$return_from_loader          = pmc$min_scc_program_execution +    5,
    pml$task_end_exception          = pmc$min_scc_program_execution +    6;

?? OLDTITLE ??
*DECK DECK=PMC$PC_BASE_EXCEPTION EXPAND=FALSE

  CONST
    pmc$pc_base_exception = pmc$min_ecc + 5000;

*copyc pmc$min_ecc
*copyc PMC$PROGRAM_MANAGEMENT_ID
*DECK DECK=PMC$PROGRAM_MANAGEMENT_ID EXPAND=FALSE

  {Product Identifier for Program Management}
  CONST
    pmc$program_management_id = 'PM';
*DECK DECK=PMC$SF_TERMINATE_TASK EXPAND=FALSE
*DECK DECK=PMD$DEBUG EXPAND=FALSE

  TYPE
    pmt$debug_identifier = 0 .. 31,

    pmt$debug_codes = set of osc$data_read .. osc$call_instruction,

    pmt$debug_low_address = ^cell,
    pmt$debug_high_address = ^cell;

*copyc OST$DEBUG_CODE
*DECK DECK=PMD$LOCAL_QUEUES EXPAND=FALSE

  TYPE
    pmt$queue_connection = 1 .. pmc$max_queues_per_job,

    pmt$queue_name = ost$name,

    pmt$message = record
      sender_id: pmt$task_id, { set by pmp$send_to_queue }
      sender_ring: ost$ring, { set by pmp$send_to_queue }
      case contents: pmt$message_kind of
      = pmc$message_value =
        value: pmt$message_value,
      = pmc$passed_segments, pmc$shared_segments = {* not supported in R1}
        number_of_segments: pmt$segments_per_message,
        segments: array [pmt$segments_per_message] of pmt$queued_segment,
      casend,
    recend,

    pmt$queued_segment = record {* not supported in R1}
      case kind: pmt$queued_segment_kind of
      = pmc$message_pointer =
        pointer: ^cell,
      = pmc$message_heap_pointer =
        heap_pointer: ^HEAP ( * ),
      = pmc$message_sequence_pointer =
        sequence_pointer: ^SEQ ( * ),
      casend,
    recend,

    pmt$segments_per_message = 1 .. pmc$max_segs_per_message,

    pmt$message_kind = (pmc$message_value, pmc$no_message, pmc$passed_segments,
      pmc$shared_segments),

    pmt$message_value = SEQ (REP 1 of pmt$segments_per_message, REP
      pmc$max_segs_per_message of pmt$queued_segment),

    pmt$queued_segment_kind = (pmc$message_pointer, pmc$message_heap_pointer,
      pmc$message_sequence_pointer);

  CONST
    pmc$max_queues_per_job = 255,
    pmc$max_segs_per_message = 12;

  TYPE
    pmt$queues_per_job = 0 .. pmc$max_queues_per_job,

    pmt$connected_tasks_per_queue = 0 .. pmc$max_connected_per_queue,

    pmt$messages_per_queue = 0 .. pmc$max_messages_per_queue;

  CONST
    pmc$max_connected_per_queue = 255,
    pmc$max_messages_per_queue = 100;

*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$NAME
*copyc PMT$TASK_ID
*DECK DECK=PMD$LOG_ENTRIES EXPAND=FALSE

{ Log entry definitions. }

*copyc pmt$system_log_entry
*copyc pmt$job_log_entry
*DECK DECK=PMD$MEMORY_IMAGE_HEADER EXPAND=FALSE

  TYPE
    pmt$memory_image_header = record
      version: pmt$memory_image_version,
      length: ost$segment_length,
      offset: ost$segment_length,
      processor_registers: pmt$processor_registers,
      initialization_values: pmt$initialization_values,
    recend;

  TYPE
    pmt$memory_image_version = string (8);

  TYPE
    pmt$processor_registers = record
      jps: ost$word,
      mps: ost$word,
      pta: ost$word,
      ptl: ost$word,
      psm: ost$word,
      eid: ost$word,
      sit: ost$word,
      pid: ost$word,
      ptm: ost$word,
      pfs: ost$word,
      dec: ost$word,
      vmcl: ost$word,
      ss: ost$word,
      oi: ost$word,
    recend;

  TYPE
    pmt$initialization_values = record
      pp_address_array_segment: ost$halfword,
      pp_address_array_offset: ost$halfword,
      pages_loaded_segment: ost$halfword,
      pages_loaded_offset: ost$halfword,
      page_size_segment: ost$halfword,
      page_size_offset: ost$halfword,
    recend;

  CONST
    pmc$real_memory_image_version = 'RMI_V1.0';


?? PUSH (LISTEXT := ON) ??
*copyc OST$HARDWARE_SUBRANGES
?? POP ??
*DECK DECK=PMD$PPU_CHARACTERISTICS EXPAND=FALSE


{  CYBER 80 PPU characteristic definition. }

CONST
  llc$max_ppu_number = 20 - 1, {maximum number of PPUs in a configuration.}
  llc$max_ppu_size = 0fff(16); {maximum number of words in a PPU.}

TYPE
  llt$ppu_address = 0 .. llc$max_ppu_size;
*DECK DECK=PMD$PROGRAM_MGMT_EXCEPTIONS EXPAND=FALSE
?? NEWTITLE := 'PMDECC  : Program Management Exceptions : ''PM'' 0 .. 9999' ??
*copyc pme$execution_exceptions                   " 0000 - 4900
*copyc pme$target_ring_error                      " 4901
*copyc pme$new_password_does_not_match            " 4902
*copyc pmc$pc_base_exception                      " 5000
*copyc pme$condition_exceptions                   " 5000 .. 5049
*copyc pme$local_queue_exceptions                 " 5050 .. 5099
*copyc pme$system_exceptions                      " 5100 .. 5149
*copyc pme$program_services_exceptions            " 5150 .. 5199
*copyc pme$debug_exceptions                       " 5200 .. 5249
*copyc pme$logging_exceptions                     " 5250 .. 5299
*copyc pme$analyze_program_dynamics               " 5300 .. 5349
*copyc pme$program_state_exceptions               " 5350 .. 5399
?? TITLE := 'PMDECC  : Program Mgmt Internal Exceptions : ''PM'' 9900 - 9999'
      ??
*copyc pmc$internal_base_exception                " 4900
*copyc pme$invalid_task_origin_flag               " 9900
*copyc pme$invalid_task_origin_signal             " 9901
*copyc pme$define_handler_exceptions              " 9902 .. 9905
*copyc pme$exec_call_bracket_error                " 9906
*copyc pme$unknown_recipient_task                 " 9907
*copyc pme$hung_recipient_task                    " 9908
*copyc pme$insufficient_privilege                 " 9908
*copyc pme$broken_task_exceptions                 " 9909 .. 9916
*copyc pme$broken_condition_processor             " 9920 .. 9929
*copyc pme$system_time_exceptions                 " 9930 .. 9939
*copyc pme$push_inhibit_too_deep                  " 9940
*copyc pme$push_inhibit_but_no_pop                " 9941
*copyc pme$task_term_while_inhibited              " 9942
*copyc pme$pop_inhibit_caused_term                " 9943
?? OLDTITLE ??
*DECK DECK=PMD$PROGRAM_MGMT_KEYPOINTS EXPAND=FALSE

*copyc PMK$KEYPOINTS
*DECK DECK=PMD$PROGRAM_MGMT_STATISTICS EXPAND=FALSE
?? NEWTITLE := 'PMDSCC : Program Management : 280000 .. 239999' ??
*copy PMC$CONDITION_LIMITS
*copy PMC$MIN_SCC_PROGRAM_EXECUTION
?? OLDTITLE ??
*DECK DECK=PMD$PROGRAM_STATE EXPAND=FALSE
{
{ PMD$PROGRAM_STATE:
{
{   This deck contains type definitions for use in saving the state of
{ a program.
{

  TYPE
    pmt$program_state = record
      p_save_area: ^cell,
      segment_count: pmt$segment_count,
    recend,

    pmt$segment_count = 0 .. osc$maximum_segment + 1,

    pmt$segment_directory = array [1 .. * ] of pmt$segment_directory_entry,

    pmt$segment_directory_entry = record
      segment_allocation: lot$segment_allocation,
      saved_length: ost$segment_length,
      segment_offset: ost$segment_length,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc lot$loader_type_definitions
*copyc osd$virtual_address
?? POP ??
*DECK DECK=PMD$SYSTEM_LOG_INTERFACE EXPAND=FALSE

{ System logging interface type declarations.

*copyc pmt$log_msg_text
*copyc pmt$log_msg_origin
*copyc pmt$logs
*copyc pmt$ascii_logs
*copyc pmt$binary_logs
*copyc pmt$global_logs
*copyc pmt$global_binary_logs
*copyc pmt$local_binary_logs
*copyc pmt$logset
*copyc pmt$ascii_logset
*copyc pmt$binary_logset
*copyc pmt$global_logset
*copyc pmt$global_binary_logset
*copyc pmt$local_binary_logset
*DECK DECK=PME$ANALYZE_PROGRAM_DYNAMICS EXPAND=FALSE

?? FMT (FORMAT := OFF) ??

?? NEWTITLE := '  PMDAPER : Analyze Program Dynamics : ''PM'' 5300 .. 5349' ??
?? OLDTITLE ??

*copyc PMC$PC_BASE_EXCEPTION

  CONST
    pmc$apd_external_base_exception = pmc$pc_base_exception + 300,

    pme$e_internal_mpe_seg_overflow = pmc$apd_external_base_exception + 0,
    {E Internal MPE segment overflow.}

    pme$e_premature_eof_on_file     = pmc$apd_external_base_exception + 1,
    {E Premature end of file encountered on file: +F.}

    pme$e_internal_apd_read_error   = pmc$apd_external_base_exception + 2,
    {E Error encountered while reading APD_SEQ file: +F.}

    pme$e_fatal_intercept_error     = pmc$apd_external_base_exception + 3,
    {E Error encountered while intercepting calls - MPE unable to continue.}

    pme$e_target_text_not_file      = pmc$apd_external_base_exception + 4,
    {E Target text file name must be included in object file list.}

    pme$e_file_not_created_by_mpe   = pmc$apd_external_base_exception + 5,
    {E File being read was not created by APD: +F.}

    pme$e_no_program_description    = pmc$apd_external_base_exception + 6,
    {E A program description has not yet been defined.}

    pme$path_name_too_long_for_mpe  = pmc$apd_external_base_exception + 7,
    {E Path name of local files too long for restructure procedure.}

    pme$e_mpe_loader_abort          = pmc$apd_external_base_exception + 8,
    {E Unable to complete Measure Program Execution.}

    pme$w_mpe_environment_restored  = pmc$apd_external_base_exception + 9,
    {W Measure Program Execution environment has been reinitialized.}

    pme$e_missing_or_empty_file     = pmc$apd_external_base_exception + 10,
    {E Missing or empty file on file: +F.}

    pme$e_no_connectivity_matrix    = pmc$apd_external_base_exception + 11,
    {E A connectivity matrix does not exist.}

    pme$e_no_execution_time_totals  = pmc$apd_external_base_exception + 12,
    {E Execution time totals do not exist.}

    pme$e_no_block_name_map         = pmc$apd_external_base_exception + 13,
    {E The block name map has not yet been defined.}

    pme$e_no_local_program_units    = pmc$apd_external_base_exception + 14,
    {E There are no local program units to print.}

    pme$e_no_remote_program_units   = pmc$apd_external_base_exception + 15,
    {E There are no remote program units to print.}

    pmc$max_apd_ext_base_exception  = pmc$apd_external_base_exception + 49;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=PME$BROKEN_CONDITION_PROCESSOR EXPAND=FALSE
*copyc PMC$INTERNAL_BASE_EXCEPTION

  {PMDBROK : Broken Condition Processor : 'PM' 9920 .. 9929}
  CONST
    pme$broken_condition_processor = pmc$internal_base_exception + 20,
    {F broken condition processor - +P}

    pme$invalid_debug_trap = pmc$internal_base_exception + 21;
    {F debug trap with no debugger loaded}
*DECK DECK=PME$BROKEN_TASK_EXCEPTIONS EXPAND=FALSE
?? NEWTITLE := 'PME$BROKEN_TASK_EXCEPTIONS : ''PM'' 9909 .. 9916', EJECT ??
*copyc PMC$INTERNAL_BASE_EXCEPTION
?? FMT (FORMAT := OFF) ??

  CONST
    pme$monitor_fault_buffer_full = pmc$internal_base_exception + 9,
    {F system error - monitor fault=+P, buffer full at P=+P, MCR=+P, UCR=+P.}

    pme$fault_with_traps_disabled = pmc$internal_base_exception + 10,
    {F system error - monitor fault=+P with traps disabled at P=+P, DSP=+P,
    { MCR=+P.}

    pme$invalid_dynamic_space_ptr = pmc$internal_base_exception + 11,
    {F system error - invalid DSP=+P at P=+P, MCR=+P, UCR=+P.}

    pme$invalid_p_register = pmc$internal_base_exception + 12,
    {F system error - invalid P=+P, DSP=+P, MCR=+P, UCR=+P.}

    pme$mcr_with_traps_disabled = pmc$internal_base_exception + 13,
    {F system error - MCR=+P with traps disabled at P=+P.}

    pme$ucr_with_traps_disabled = pmc$internal_base_exception + 14,
    {F system error - unstackable UCR=+P with traps disabled at P=+P.}

    pme$system_error = pmc$internal_base_exception + 15,
    {C system error - please submit job log with PSR.}

    pme$undefined_broken_task = pmc$internal_base_exception + 16;
    {C system error - received an undefined broken task fault at P=+P.}

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=PME$CONDITION_EXCEPTIONS EXPAND=FALSE

*copyc PMC$PC_BASE_EXCEPTION
?? NEWTITLE := 'Condition Processing Exceptions: ''PM'' 5000 .. 5049' ??
?? EJECT ??

  CONST
    pme$incorrect_condition_name = pmc$pc_base_exception + 2,
    {E Condition name, +P, is improper.}

    pme$descriptor_address_error = pmc$pc_base_exception + 3,
    {E Establish descriptor is not an automatic variable of the requestor.}

    pme$no_established_handler = pmc$pc_base_exception + 4,
    {E No handler is in effect within the scope of the condition.}

    pme$inconsistent_stack = pmc$pc_base_exception + 5,
    {E A stack segment contains invalid frames or a stack overflow..}
    { has occurred. Please see job log for details.}

    pme$handler_stack_error = pmc$pc_base_exception + 6,
    {E A stack of established condition handlers is erroneous.}

    pme$invalid_condition_handler = pmc$pc_base_exception + 7,
    {F The condition handler in effect for +P is not callable.}

    pme$condition_in_handler = pmc$pc_base_exception + 8,
    {F A condition handler caused the same condition the handler was..}
    { processing.}

    pme$no_condition_to_continue = pmc$pc_base_exception + 9,
    {E PMP$CONTINUE_TO_CAUSE requested from outside the realm of a condition..}
    { handler.}

    pme$invalid_condition_selector = pmc$pc_base_exception + 10,
    {E Invalid condition selector - establish or disestablish.}

    pme$unselectable_condition = pmc$pc_base_exception + 11,
    {E A specified system condition is improper for the request.}

    pme$recursive_continue = pmc$pc_base_exception + 12,
    {E Attempted to continue a condition to a handler active processing that..}
    { condition.}

    pme$invalid_standard_selection = pmc$pc_base_exception + 13,
    {E Standard procedure selection is improper.}

    pme$stack_overwritten = pmc$pc_base_exception + 14,
    {E Ring=+P stack segment overwritten.}

    pme$unsupported_by_test_cond = pmc$pc_base_exception + 15,
    {E PMP$TEST_CONDITION_HANDLER does not support the specified condition.}

    pme$pit_value_out_of_range = pmc$pc_base_exception + 20,
    {E PMP$SET_PROCESS_INTERVAL_TIMER microsecond parameter is out of range.}

    pme$handler_queue_error = pmc$pc_base_exception + 21,
    {E Unable to queue task end handler.}

    pme$handler_nested_proc = pmc$pc_base_exception + 22,
    {E Task end handler procedure is a nested procedure.}

    pme$handler_more_privileged = pmc$pc_base_exception + 23;
    {E Ring of task end handler is more privileged.}

?? OLDTITLE ??
*DECK DECK=PME$DEBUG_EXCEPTIONS EXPAND=TRUE

?? FMT (FORMAT := OFF) ??

?? NEWTITLE := 'Debug Management Exceptions : ''PM'' 5200 .. 5249' ??
?? EJECT ??
*copyc PMC$PC_BASE_EXCEPTION

  CONST
    pmc$min_debug_mgmt_exception    = pmc$pc_base_exception + 200,

    pme$missing_module_definition   = pmc$min_debug_mgmt_exception +   0,
        {E Missing module definition.}

    pme$missing_module_termination  = pmc$min_debug_mgmt_exception +   1,
        {E Module not terminated: +P.}

    pme$module_segment_overflow     = pmc$min_debug_mgmt_exception +   2,
        {E Internal module segment overflow: +P.}

    pme$entry_pt_segment_overflow   = pmc$min_debug_mgmt_exception +   3,
        {E Internal entry point segment overflow: +P.}

    pme$bad_symbol_table_fragment   = pmc$min_debug_mgmt_exception +   4,
        {E Bad symbol table fragment encountered on module: +P.}

    pme$undefined_debug_id          = pmc$min_debug_mgmt_exception +   5,
        {E Undefined debug id.}

    pme$too_many_debug_list_entries = pmc$min_debug_mgmt_exception +   6,
        {E Debug entry list overflow - entry ignored.}

    pme$empty_debug_code            = pmc$min_debug_mgmt_exception +   7,
        {E No debug codes specified.}

    pme$address_segments_not_equal  = pmc$min_debug_mgmt_exception +   8,
        {E Segments unequal in debug addresses.}

    pme$low_addr_greater_than_high  = pmc$min_debug_mgmt_exception +   9,
        {E Low debug address is greater than high debug address.}

    pme$invalid_access              = pmc$min_debug_mgmt_exception +  10,
        {E Address specified can not be accessed.}

    pme$undefined_debug_index       = pmc$min_debug_mgmt_exception +  11,
        {E Undefined debug index.}

    pme$stack_frame_not_found       = pmc$min_debug_mgmt_exception +  12,
        {E Stack frame not found.}

    pme$too_many_entry_points       = pmc$min_debug_mgmt_exception +  13,
        {E Too many entry points. }

    pme$invalid_section_ordinal     = pmc$min_debug_mgmt_exception +  14,
        {E Invalid section ordinal: +P.}

    pme$invalid_ring_number         = pmc$min_debug_mgmt_exception +  15,
        {E Invalid ring number: +P.}

    pme$set_to_more_privileged_ring = pmc$min_debug_mgmt_exception +  16,
        {E User not validated to run at ring +P.}

    pme$invalid_line_address_table  = pmc$min_debug_mgmt_exception +  17,
        {E Invalid line address table encountered. }

    pme$unable_to_load_debug        = pmc$min_debug_mgmt_exception + 18,
        {W Unable to load interactive debugger entry point +P.}

    pme$bad_debug_symbol_table         = pmc$min_debug_mgmt_exception + 19,
       {E Bad debug symbol table encountered on module: +P.}

    pmc$max_debug_mgmt_exception    = pmc$min_debug_mgmt_exception +  49;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=PME$DEFINE_HANDLER_EXCEPTIONS EXPAND=FALSE

*copyc PMC$INTERNAL_BASE_EXCEPTION
  {PMDDFER : Define Handler Exceptions : 'PM' 9902 .. 9905}
  CONST
    pme$nil_handler = pmc$internal_base_exception + 2,
    {E NIL handler on a define handler request}

    pme$handler_already_defined = pmc$internal_base_exception + 3,
    {E an attempt to replace a handler}

    pme$invalid_identifier = pmc$internal_base_exception + 4,
    {E monitor fault, system flag or signal identifier is in error}

    pme$define_privilege_error = pmc$internal_base_exception + 5;
    {E requestor does not have adequate privilege to define the handler}

*DECK DECK=PME$EXECUTION_EXCEPTIONS EXPAND=FALSE
?? NEWTITLE := 'PME$EXECUTION_EXCEPTIONS : ''PM'' 0 .. 4900', EJECT ??
*copyc pmc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    pmc$program_execution           = pmc$min_ecc,

    pme$invalid_file_name           = pmc$program_execution + 0,
    {W String +P1 is not a valid +P2 file name.}

    pme$invalid_term_error_level    = pmc$program_execution + 1,
    {E Specified value for TERMINATION_ERROR_LEVEL is unknown.}

    pme$invalid_preset_option       = pmc$program_execution + 2,
    {E Specified value for PRESET is unknown.}

    pme$invalid_stack_size_option   = pmc$program_execution + 3,
    {E Specified MAXIMUM_STACK_SIZE exceeds maximum segment length.}

    pme$map_option_conflict         = pmc$program_execution + 4,
    {E Specified LOAD_MAP_OPTIONS contains NONE and another option.}

    pme$invalid_wait_parameter      = pmc$program_execution + 5,
    {E Specified WAIT parameter is not OSC$WAIT or OSC$NO_WAIT.}

    pme$invalid_library_change_kind = pmc$program_execution + 10,
    {E Library list change kind unknown.}

    pme$no_libraries_in_change      = pmc$program_execution + 11,
    {E No libraries specified in ADD or DELETE request.}

    pme$empty_library_list          = pmc$program_execution + 12,
    {E Library list currently empty.}

    pme$unknown_delete_library      = pmc$program_execution + 13,
    {W Library +F not present in library list.}

    pme$duplicate_add_library       = pmc$program_execution + 14,
    {W Library +F already present in library list.}

    pme$library_count_mismatch      = pmc$program_execution + 15,
    {E Output list has different dimension than current library list.}

    pme$file_not_existing_library   = pmc$program_execution + 16,
    {W +F is not an existing library.}

    pme$reserved_library_name       = pmc$program_execution + 17,
    {W +F cannot be an existing file.}

    pme$some_libraries_not          = pmc$program_execution + 18,
    {E Some libraries were not +P.}

    pme$prog_description_too_small  = pmc$program_execution + 20,
    {E Program description is too small to contain +P.}

    pme$invalid_list_length         = pmc$program_execution + 21,
    {E Specified number of +P1 is 0 or exceeds +P2.}

    pme$transfer_address_ring_error = pmc$program_execution + 22,
    {E Initial program transfer may not be to ring 1 or 2.}

    pme$invalid_task_id             = pmc$program_execution + 23,
    {E Task id not within valid range.}

    pme$task_not_current_child      = pmc$program_execution + 24,
    {E Specified task is not a child of executing task.}

    pme$terminated_by_parent        = pmc$program_execution + 25,
    {E Task termination requested by parent task.}

    pme$prog_description_size_error = pmc$program_execution + 26,
    {E Size of parameter not equal to size of current program description.}

    pme$illegal_ada_control_task    = pmc$program_execution + 27,
    {E The asynchronous procedure attempted to call a program interface..}
    { reserved for control task use.}

    pme$no_available_stacks         = pmc$program_execution + 28,
    {E The asynchronous procedure cannot be initiated because there..}
    { are no shared stacks available for assignment.}

    pme$ada_critical_frame_error    = pmc$program_execution + 29,
    {E The critical frame count for a stack frame is non-zero but there are..}
    { no asynchronous procedure child tasks dependent on the stack frame.}

    pme$invalid_critical_frame      = pmc$program_execution + 30,
    {E The critical frame given in the pmp$execute_procedure call is not..}
    { a stack frame save area for the calling task.}

    pme$critical_frame_count_limit  = pmc$program_execution + 31,
    {E An attempt was made to execute an asynchronous procedure that would..}
    { cause the critical frame count to be exceeded.}

    pme$invalid_inheritance_option  = pmc$program_execution + 32,
    {E Only pmc$inherit_code_and_data is valid as an inheritance option.}

    pme$invalid_loaded_ring         = pmc$program_execution + 33,
    {E The caller of an asynchronous procedure may not be a multi-ring task.}

    pme$kill_task_requested         = pmc$program_execution + 34,
    {F The task has been terminated with a kill task request.}

    pme$stack_frame_popper_aborted  = pmc$program_execution + 40,
    {E Stack destroyed - some block exit handlers may not have been activated.}

    pme$termination_not_revocable   = pmc$program_execution + 50,
    {E Program termination is beyond the point of revocation.}

    pme$maximum_term_revocations    = pmc$program_execution + 51,
    {E Maximum program termination revocations exceeded.}

    pme$common_not_unallocated      = pmc$program_execution + 60,
    {E Common block +P not unallocated common.}

    pme$common_file_open            = pmc$program_execution + 61,
    {E File to be opened for common block +P is already open.}

    pme$common_file_not_open        = pmc$program_execution + 62,
    {E The file for common block +P is not open.}

    pme$task_status_inaccessible    = pmc$program_execution + 63,
    {E Unable to write childs termination status in task status variable.}

    pme$2nd_call_to_execute_within  = pmc$program_execution + 70,
    {E PMP$EXECUTE_WITHIN_TASK can only be called once per task.}

    pme$incorrect_applic_address = pmc$program_execution + 71,
    {E Incorrect application address (PVA = +P).}

    pme$xcb_offset_exceeds_maximum  = pmc$program_execution + 72,
    {E The XCB offset exceeds the maximum allowed.}

    pme$unknown_task_id             = pmc$program_execution + 4900,
    {E Task_id not currently assigned to any active task.}

    pmc$max_program_execution       = pmc$program_execution + 4900;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=PME$EXEC_CALL_BRACKET_ERROR EXPAND=FALSE

*copyc PMC$INTERNAL_BASE_EXCEPTION
  {PMDMFER : Define Fault Handler Exception : 'PM' 9906}
  CONST
    pme$exec_call_bracket_error = pmc$internal_base_exception + 6;
    {E new handler does not have adequate privilege}

*DECK DECK=PME$HUNG_RECIPIENT_TASK EXPAND=FALSE


*copyc PMC$INTERNAL_BASE_EXCEPTION
  {PME$HUNG_RECIPIENT_TASK : 'PM' 9917}
  CONST
    pme$hung_recipient_task = pmc$internal_base_exception + 17;
    {E requestor specified a task recognized as hung by monitor}

*DECK DECK=PME$INSUFFICIENT_PRIVILEGE EXPAND=FALSE
?? NEWTITLE := 'PME$INSUFFICIENT_PRIVILEGE ----- ''PM'' 9908', EJECT ??
*copyc pmc$internal_base_exception
?? FMT (FORMAT := OFF) ??

  CONST
    pme$insufficient_privilege = pmc$internal_base_exception + 8;
    {E insufficient privilege for request}

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=PME$INVALID_TASK_ORIGIN_FLAG EXPAND=FALSE

*copyc PMC$INTERNAL_BASE_EXCEPTION
  {PMDIFLG : Set System Flag Exceptions : 'PM' 9900}
  CONST
    pme$invalid_task_origin_flag = pmc$internal_base_exception;
    {E Requestor cannot originate the specified system flag.}

*DECK DECK=PME$INVALID_TASK_ORIGIN_SIGNAL EXPAND=FALSE

*copyc PMC$INTERNAL_BASE_EXCEPTION
  {PMDISGL : Send Signal Exceptions : 'PM' 9901}
  CONST
    pme$invalid_task_origin_signal = pmc$internal_base_exception + 1;
    {E Requestor cannot originate the specified signal.}

*DECK DECK=PME$LOCAL_QUEUE_EXCEPTIONS EXPAND=FALSE

*copyc PMC$PC_BASE_EXCEPTION
?? NEWTITLE := 'Local Queue Exceptions : ''PM'' 5050 .. 5099', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    pme$maximum_queues_defined = pmc$pc_base_exception + 50,
    {E Maximum number of queues are already defined in the job.}

    pme$queue_already_defined = pmc$pc_base_exception + 51,
    {E The queue, +P, is already defined.}

    pme$removal_bracket_error = pmc$pc_base_exception + 52,
    {E Attempted to remove +P from a ring greater than the removal bracket.}

    pme$usage_lt_removal_bracket = pmc$pc_base_exception + 53,
    {E Usage bracket more privileged than removal bracket for +P.}

    pme$unknown_queue_name = pmc$pc_base_exception + 54,
    {E Queue, +P, is undefined.}

    pme$tasks_connected_to_queue = pmc$pc_base_exception + 55,
    {E The queue, +P, has tasks connected.}

    pme$nonempty_queue = pmc$pc_base_exception + 56,
    {E The queue, +P, contains messages.}

    pme$maximum_tasks_connected = pmc$pc_base_exception + 57,
    {E Maximum number of tasks are already connected to +P.}

    pme$task_already_connected = pmc$pc_base_exception + 58,
    {E Task is already connected to +P.}

    pme$usage_bracket_error = pmc$pc_base_exception + 59,
    {E Requestor has insufficient privilege for +P.}

    pme$unknown_queue_identifier = pmc$pc_base_exception + 60,
    {E Task is not connected to +P.}

    pme$maximum_queued_messages = pmc$pc_base_exception + 61,
    {E Maximum number of messages are already on +P.}

    pme$incorrect_segment_message = pmc$pc_base_exception + 62,
    {E Passing or sharing executable, binding or stack segment is not allowed.}

    pme$incorrect_message_type = pmc$pc_base_exception + 63,
    {E Incorrect queue message type.}

    pme$incorrect_queued_seg_type = pmc$pc_base_exception + 64,
    {E Incorrect queued segment type.}

    pme$error_pointer_privilege = pmc$pc_base_exception + 65,
    {E Requestor has insufficient privilege to access the pointer object.}

    pme$error_segment_privilege = pmc$pc_base_exception + 66,
    {E Requestor has insufficient privilege to access a passed/shared segment.}

    pme$error_number_of_segments = pmc$pc_base_exception + 67,
    {E Number_of_segments to be passed/shared is not in the valid range.}

    pme$maximum_waiting_tasks = pmc$pc_base_exception + 68,
    {E The maximum number of tasks are already waiting for a message on +P.}

    pme$incorrect_queue_name = pmc$pc_base_exception + 69,
    {E Queue name, +P, is improper.}

    pme$request_gt_removal_bracket = pmc$pc_base_exception + 70,
    {E Requestor is less privileged than the removal bracket for +P.}

    pme$pass_share_prohibited = pmc$pc_base_exception + 71,
    {E Segment passing/sharing is not currently supported.}

    pme$caller_gt_removal_bracket = pmc$pc_base_exception + 72;
    {E Caller is outside the removal bracket for +P.}

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=PME$LOGGING_EXCEPTIONS EXPAND=FALSE
?? NEWTITLE := 'PME$LOGGING_EXCEPTIONS : ''PM'' 5250 .. 5299', EJECT ??
*copyc pmc$pc_base_exception
?? FMT (FORMAT := OFF) ??

  CONST
    pmc$external_log_management_id = 'PM',
    pmc$external_log_base_exception = pmc$pc_base_exception + 250;

  CONST
    pme$logging_not_yet_active = pmc$external_log_base_exception + 0,
    {E Logging has not been initialized.

    pme$job_log_no_longer_active = pmc$external_log_base_exception + 1,
    {E Caller attempted to add to the JOB_LOG after the JOB_LOG had
    { appended to the output file.

    pme$cannot_write_in_system_log = pmc$external_log_base_exception + 2,
    {I Caller does not have sufficient privilege to write in the SYSTEM_LOG.

    pme$log_cycles_do_not_match = pmc$external_log_base_exception + 3,
    {E The log cycle provided by the caller does not match the current
    { cycle for log +P.

    pme$file_id_is_not_log_file = pmc$external_log_base_exception + 4,
    {E The file identifier passed does not represent a log file.

    pme$requested_op_not_allowed = pmc$external_log_base_exception + 5,
    {E Caller does not have the necessary privilege on log +P to +P.

    pme$not_enough_space_in_wsa = pmc$external_log_base_exception + 6,
    {E Not enough space in wsa ( +P) for log entry of length ( +P).

    pme$name_is_not_name_of_log = pmc$external_log_base_exception + 7,
    {E The local file name ( +P ) passed in the OPEN request does not match a
    { log name.

    pme$requested_op_not_defined = pmc$external_log_base_exception + 8,
    {E The requested operation is not defined for an active log.


    pme$new_boi_addr_out_of_range = pmc$external_log_base_exception + 9,
    {E Specified new boi address is beyond the current EOI.

    pme$access_fault_with_log = pmc$external_log_base_exception + 10,
    {E Attempt to read or write log +P caused a segment access fault ..
    {(detected by +P).

    pme$backup_limit_exceeded = pmc$external_log_base_exception + 11,
    {E Specified backup count was +P (limit is +P).

    pme$content_param_not_integer = pmc$external_log_base_exception + 12,
    {E If the FROM parameter is LAST, then the CONTENT parameter must be
    { an integer.

    pme$content_param_not_string = pmc$external_log_base_exception + 13,
    {E If the FROM parameter is TIME or MESSAGE, then the CONTENT parameter
    { must be a string.

    pme$search_did_not_find_match = pmc$external_log_base_exception + 14,
    {E The string ( +P ) could not be found.

    pme$record_too_short = pmc$external_log_base_exception + 15,
    {E The record just read in is not long enough to be an ascii
    { log entry. It consists of ... +P.

    pme$variable_ref_must_be_string = pmc$external_log_base_exception + 16,
    {E The variable supplied by the user in the PFN parameter of the
    { TERMINATE_LOG command was not STRING KIND.

    pme$push_fail = pmc$external_log_base_exception + 17,
    {E Not enough local space to log entry.

    pme$log_is_full = pmc$external_log_base_exception + 18,
    {E Log is full. See site analyst.

    pme$end_of_log = pmc$external_log_base_exception + 19,
    {E EOF reached while reading log +P. }

    pme$not_local_log = pmc$external_log_base_exception + 20,
    {E Local log parameter specified is not a local log.

    pme$not_system_administrator = pmc$external_log_base_exception + 21,
    {E User must be system administrator to terminate log.


    pme$cannot_write_to_log = pmc$external_log_base_exception + 22,
    {I Caller does not have sufficient privilege to write in the +P.

    pme$undefined_metric            = pmc$external_log_base_exception + 23,
    {E Metric +P1 is specified for display +P2, but is not defined.}

    pme$undefined_group             = pmc$external_log_base_exception + 24,
    {E Group +P1 is specified for metric +P2, but is not defined.}

    pme$undefined_group_for_dump    = pmc$external_log_base_exception + 25,
    {E Group +P1 is specified for a group dump, but is not defined.}

    pme$redefined_group             = pmc$external_log_base_exception + 26,
    {W Group +P1 was already defined.  The new definition is ignored.}

    pme$redefined_metric            = pmc$external_log_base_exception + 27,
    {W Metric +P1 was already defined.  The new definition is ignored.}

    pme$bad_statistic               = pmc$external_log_base_exception + 28,
    {E +P1 is not a valid statistic name.}

    pme$no_metric_type              = pmc$external_log_base_exception + 29,
    {E Some metric type must be specified.}

    pme$too_many_metric_types       = pmc$external_log_base_exception + 30,
    {E Conflicting metric types specified for metric +P1.}

    pme$null_desc_data              = pmc$external_log_base_exception + 31,
    {E A null string may not be specified for descriptive dat3233,

    pme$bad_expression               = pmc$external_log_base_exception + 32,
    {E +P1 is not a valid expression.}

    pme$bad_time                    = pmc$external_log_base_exception + 33,
    {E +P1 is not a legal time  }

    pme$bad_high_low_limit          = pmc$external_log_base_exception + 34,
    {E +P1 low_limit > high_limit in disd subcommand }

    pme$output_permanent            = pmc$external_log_base_exception + 35,
    {E +P1 $OUTPUT file should not be permanent in gengf subcommand }

    pme$local_name_conflict         = pmc$external_log_base_exception + 36,
    {E +P1 local file name redefined by gengf p=TRUE }

    pme$bad_date                     = pmc$external_log_base_exception + 37,
    {E +P1 is not a legal date  }

    pme$automatic_log_termination    = pmc$external_log_base_exception + 38,
    {I +F was automatically terminated to file +F.}

    pme$incorrect_log_ordinal        = pmc$external_log_base_exception + 39,
    {E An incorrect log ordinal was specified on the call to +P.}

    pmc$max_external_logging_error = pmc$external_log_base_exception + 49;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=PME$NEW_PASSWORD_DOES_NOT_MATCH EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc PME$EXECUTION_EXCEPTIONS
?? POP ??

  CONST
    pme$new_password_does_not_match = pmc$program_execution + 4902;
{E +P and +P must be the same.
*DECK DECK=PME$POP_INHIBIT_CAUSED_TERM EXPAND=FALSE
?? NEWTITLE := 'PME$POP_INHIBIT_CAUSED_TERM: ''PM'' 9943', EJECT ??
*copyc pmc$internal_base_exception
?? FMT (FORMAT := OFF) ??

  CONST
    pme$pop_inhibit_caused_term = pmc$internal_base_exception + 43;
    {E Clearing task inhibit with pending task termination.

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??

*DECK DECK=PME$PROGRAM_SERVICES_EXCEPTIONS EXPAND=FALSE

?? FMT (FORMAT := OFF) ??
*copyc PMC$PC_BASE_EXCEPTION

  {PMDPSER : Program Services Exceptions : 'PM' 5150 .. 5199}

  CONST
    pmc$prog_service_base_exception = pmc$pc_base_exception + 150,

    pme$invalid_date_format = pmc$prog_service_base_exception + 0,
    {E incorrect date format}

    pme$invalid_time_format = pmc$prog_service_base_exception + 1,
    {E incorrect time format}

    pme$invalid_spy_identifier = pmc$prog_service_base_exception + 2,
    {E invalid spy identifier}

    pme$common_block_not_defined = pmc$prog_service_base_exception + 3,
    {E common block +P not defined}

    pme$library_header_missing = pmc$prog_service_base_exception + 4,
    {E library header missing}

    pme$wrong_library_version = pmc$prog_service_base_exception + 5,
    {E invalid library version +P}

    pme$bad_entry_dictionary_ptr = pmc$prog_service_base_exception + 6,
    {E bad entry point dictionary pointer encountered}

    pme$result_array_too_small = pmc$prog_service_base_exception + 7,
    {E The result array +P is not large enough to contain the..}
    { requested information. }

    pme$unknown_entry_point = pmc$prog_service_base_exception + 8,
    {E unknown entry point +P}

    pme$invalid_unique_name = pmc$prog_service_base_exception + 9,
    {E +P is an invalid unique name. }

    pme$task_id_not_found = pmc$prog_service_base_exception + 10,
    {E Task +P does not exist.}

    pme$task_has_no_parent = pmc$prog_service_base_exception + 11,
    {E Task +P has no parent.}

    pme$invalid_sequence_pointer = pmc$prog_service_base_exception + 12,
    {E An invalid sequence pointer was passed in parameter LIBRARY_FILE.}

    pme$invalid_mainframe_id = pmc$prog_service_base_exception + 13,
    {E The mainframe identifier (+P) is not valid.}

    pme$invalid_relative_priority = pmc$prog_service_base_exception + 14,
    {E The relative task priority is out of the valid range of priorities.}

    pme$not_transient_segment = pmc$prog_service_base_exception + 15,
    {E The segment whose attributes are to be changed is not a transient..}
    { segment. }

    pme$segment_ring_error = pmc$prog_service_base_exception + 16,
    {E The caller ring is different from the ring attributes of the segment. }

    pme$code_base_pointer_error = pmc$prog_service_base_exception + 17,
    {E The r3 value in a code base pointer in the segment is different from..}
    { the caller ring. }

    pme$invalid_attribute_key = pmc$prog_service_base_exception + 18,
    {E +P was called with an invalid key.}

    pmc$high_prog_service_exception = pmc$prog_service_base_exception + 49;

?? FMT (FORMAT := ON) ??
*DECK DECK=PME$PROGRAM_STATE_EXCEPTIONS EXPAND=FALSE
?? NEWTITLE := 'PME$PROGRAM_STATE_EXCEPTIONS: ''PM'' 5350 .. 5399', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc pmc$pc_base_exception
?? POP ??

  CONST
    pmc$min_program_state_exception = pmc$pc_base_exception + 350,

    pme$state_container_full = pmc$min_program_state_exception + 0,
    {E There is insufficient room in the state container provided to hold
    { the program state.

    pme$program_mismatch = pmc$min_program_state_exception + 1,
    {E The program requesting a state restoration is not the same as
    { the program who's state was saved.

    pme$invalid_program_state = pmc$min_program_state_exception + 2,
    {E The data contained in the program state container did not
    { represent a valid program state.

    pme$unreadable_program_state = pmc$min_program_state_exception + 3,
    {E The caller has a ring number too high to allow read access to one or
    { more segments of the program state.

    pme$unwritable_program_state = pmc$min_program_state_exception + 4,
    {E The caller has a ring number too high to allow write access to one or
    { more segments of the program state.

    pmc$max_program_state_exception = pmc$min_program_state_exception + 49;

?? OLDTITLE ??
*DECK DECK=PME$PUSH_INHIBIT_BUT_NO_POP EXPAND=FALSE
?? NEWTITLE := 'PME$PUSH_INHIBIT_BUT_NO_POP: ''PM'' 9941', EJECT ??
*copyc pmc$internal_base_exception
?? FMT (FORMAT := OFF) ??

  CONST
    pme$push_inhibit_but_no_pop = pmc$internal_base_exception + 41;
    {E The program inhibited task termination but exited without popping
    { the inhibit.

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??

*DECK DECK=PME$PUSH_INHIBIT_TOO_DEEP EXPAND=FALSE
?? NEWTITLE := 'PME$PUSH_INHIBIT_TOO_DEEP: ''PM'' 9940', EJECT ??
*copyc pmc$internal_base_exception
?? FMT (FORMAT := OFF) ??

  CONST
    pme$push_inhibit_too_deep = pmc$internal_base_exception + 40;
    {E Too many nested calls to inhibit task termination have been made.

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??

*DECK DECK=PME$SYSTEM_EXCEPTIONS EXPAND=FALSE

*copyc PMC$PC_BASE_EXCEPTION

  {PMDPERR : System Exceptions : 'PM' 5100 .. 5149}
  CONST
    pme$system_condition = pmc$pc_base_exception + 100,
    {F +P at P=+P.}

    pme$unknown_system_request = pmc$pc_base_exception + 101,
    {F Unknown system request at P=+P.}

    pme$task_begin_information = pmc$pc_base_exception + 102,
    {I Task Name: +P1.  Global Task ID: +P2.}

    pme$task_end_information = pmc$pc_base_exception + 103,
    {I Task Name: +P1.  Global Task ID: +P2.  Completion Status: +P3.}

    pme$unknown_monitor_fault = pmc$pc_base_exception + 104;
    {F Unknown monitor fault at P=+P.}
*DECK DECK=PME$SYSTEM_TIME_EXCEPTIONS EXPAND=FALSE
*copyc PMC$INTERNAL_BASE_EXCEPTION

  {PMDTRER : System Time Requests : 'PM' 9930 .. 9939 }
  CONST
    pme$invalid_millisecond         = pmc$internal_base_exception + 30,
                                     {E Incorrect millisecond specified: +P.}

    pme$invalid_second              = pmc$internal_base_exception + 31,
                                     {E Incorrect second specified: +P.}

    pme$invalid_minute              = pmc$internal_base_exception + 32,
                                     {E Incorrect minute specified: +P.}

    pme$invalid_hour                = pmc$internal_base_exception + 33,
                                     {E Incorrect hour specified: +P.}

    pme$invalid_month               = pmc$internal_base_exception + 34,
                                     {E Incorrect month specified: +P.}

    pme$invalid_day                 = pmc$internal_base_exception + 35,
                                     {E Incorrect day specified: +P.}

    pme$invalid_year                = pmc$internal_base_exception + 36,
                                     {E Incorrect year specified: +P.}

    pme$computed_year_out_of_range  = pmc$internal_base_exception + 37,
                                     {E Computed value for the year is out of range.}

    pme$compute_overflow            = pmc$internal_base_exception + 38,
                                     {E Arithmetic overflow occurred during computation.}

    pme$invalid_time_zone           = pmc$internal_base_exception + 39;
                                     {E Incorrect time zone specified.}


*DECK DECK=PME$TARGET_RING_ERROR EXPAND=FALSE

?? PUSH (LISTEXT := ON) ??
*copyc PME$EXECUTION_EXCEPTIONS
?? POP ??

  {PMDTERR : Internal Execute Exceptions : 'PM' 4901}

  CONST
    pme$target_ring_error = pmc$program_execution + 4901;
    {E Target ring is less than requestor's ring.}
*DECK DECK=PME$TASK_TERM_WHILE_INHIBITED EXPAND=FALSE
?? NEWTITLE := 'PME$TASK_TERM_WHILE_INHIBITED: ''PM'' 9942', EJECT ??
*copyc pmc$internal_base_exception
?? FMT (FORMAT := OFF) ??

  CONST
    pme$task_term_while_inhibited = pmc$internal_base_exception + 42;
    {E Task termination requested while terminate inhibit is in effect.

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??

*DECK DECK=PME$UNKNOWN_RECIPIENT_TASK EXPAND=FALSE
?? NEWTITLE := 'PME$UNKNOWN_RECIPIENT_TASK ------ ''PM'' 9907', EJECT ??
*copyc pmc$internal_base_exception
?? FMT (FORMAT := OFF) ??

  CONST
    pme$unknown_recipient_task = pmc$internal_base_exception + 7;
    {E requestor specified an nonexistent task}

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=PMH$ABORT EXPAND=FALSE

{
{    The purpose of this request is to terminate execution of the requesting
{  task, due to an internal failure, causing processing of the abort file.
{
{        PMP$ABORT (STATUS)
{
{  STATUS: (input) This parameter specifies the status to be returned to the
{        caller of the requesting task.
{
*DECK DECK=PMH$ACTIVATE_RING_ALARM EXPAND=FALSE
{
{    The purpose of this request is to determine if a ring alarm should be
{ activated.
{
{       PMP$ACTIVATE_RING_ALARM (ACTIVATE_RING_ALARM, STATUS)
{
{ ACTIVATE_RING_ALARM: (output)  This parameter specifies whether a ring alarm
{       should be activated.
{
{ STATUS: (output) This parameter specifies the request outcome.
{
*DECK DECK=PMH$AWAIT_ADA_TASK EXPAND=FALSE


{
{    The purpose of this procedure is to wait for the termination of all of the
{  asynchronous procedure child tasks that have a particular stack frame in this
{  parent task that is a critical frame.
{
{        PMP$AWAIT_ADA_TASK (CRITICAL_FRAME)
{
{  CRITICAL_FRAME: (input) This parameter specifies the PVA of the most recent
{        entry on this task's stack that is also required to be present in its
{        child.  This procedure will not be return until all child tasks using
{        this stack frame have terminated.
{
{
*DECK DECK=PMH$AWAIT_NONEMPTY_QUEUE EXPAND=FALSE

{
{   The purpose of this request is to condition the task to wait for a non-empty
{ queue.
{
{        PMP$AWAIT_NONEMPTY_QUEUE (QID, REQUESTOR_RING, NONEMPTY_QUEUE,
{          STATUS)
{
{ QID: (input) This parameter specifies the system supplied identifier of the
{       queue for which the task is to wait.
{
{ REQUESTOR_RING: (input) This parameter specifies the requestor's ring on
{       whose behalf the request is being issued.
{
{ NONEMPTY_QUEUE: (output) This specifies if the queue is non-empty at the
{       time of request.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$unknown_queue_identifier, pme$usage_bracket_error.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$AWAIT_TASK EXPAND=FALSE

{
{    The purpose of this request is to suspend execution of the requesting
{  task until another task has terminated.  The requesting task can only
{  wait for termination of tasks that it has executed.
{
{        PMP$AWAIT_TASK (TASK_ID, WAIT_COMPLETE, STATUS)
{
{  TASK_ID: (input) This parameter specifies the system supplied identifier
{        of the task the termination of which is to be awaited.  This
{        identifier is returned by the PMP$EXECUTE request.
{
{  WAIT_COMPLETE: (output) This parameter specifies whether the specified task
{        child of the requestor - if so the request must reissued.
{
{  STATUS: (output) This parameter specifies request status.
{

*DECK DECK=PMH$AWAIT_TASK_TERMINATION EXPAND=FALSE

{
{    The purpose of this request is to suspend execution of the requesting
{  task until another task has terminated.  The requesting task can only
{  wait for termination of tasks that it has executed.
{
{        PMP$AWAIT_TASK_TERMINATION (TASK_ID, STATUS)
{
{  TASK_ID: (input) This parameter specifies the system supplied identifier
{        of the task the termination of which is to be awaited.  This
{        identifier is returned by the PMP$EXECUTE request.
{
{  STATUS: (output) This parameter specifies request status.
{       CONDITIONS: pme$invalid_task_id
{       IDENTIFIER: 'PM'
{
*DECK DECK=PMH$BEGIN_SUBSYSTEM_ACTIVITY EXPAND=FALSE
{
{      *** WARNING This interface is intended to be used carefully ***
{      ***     by subsystem writers ONLY. Misuse of this interface ***
{      ***     may cause a degradation in system performance or    ***
{      ***     (in worse case) a system failure.                   ***
{
{ This request is used to inform the operating system that the task has
{ entered a critical region where global resources may be interlocked.
{ This request will cause the system to give special dispatching/swapping
{ priority to the job and task while the task is in the critical region.
{
{ Critical regions may be nested. There is a counter for each task that is
{ incremented each time the task enters a critical region and decremented
{ each time the task exits the critical region. If the count is non-zero
{ the task is considered to be in a critical region. If the count exceeds
{ 255 the task is terminated.
{
{ Correct use of this request requires the following:
{    o the size of the critical region should be as small as possible.
{      Try to minimize the CP time spent in the critical region. Values
{      up to a couple of hundred of milliseconds are reasonable.
{    o Try to prevent  page faults while in the critical
{      region, especially to pages that may be on disk. If possible,
{      data structures that will be referenced from within the critical
{      region should be referenced prior to entering the critical region.
{    o Avoid calls to other parts of the operating system while in the
{      critical region.
{
{ NOS/VE handles critical regions as follows:
{    o A task is guaranteed at least 1 full time slice after entering a
{      critical region before a task switch will occur because of end of
{      timeslice. (of course pmp$wait, page fault for page on disk, etc.
{      will cause a task switch sooner)
{    o A task in a critical region will execute for 5 time slices with
{      a high priority. After 5 time slices have elapsed, the task reverts
{      to its nominal priority. No further special dispatching
{      consideration is given to the task.
{    o If a PMP$READY_TASK or PMP$READY_TASK_AND_WAIT request is sent to
{      a task in a critical region, the priority of the task in the
{      critical region is set to the larger of its current priority or
{      the nominal priority of the task that issued the ready request.
{      The task will continue to execute with this priority until it
{      exits the critical region. At this time the priority reverts to
{      its original priority.
{
{
{        PMP$BEGIN_SUBSYSTEM_ACTIVITY (STATUS);
{
{  STATUS: (output) This parameter is the request status.
{        CONDITIONS:
{              none

*DECK DECK=PMH$BROADCAST_UNSEEN_MAIL EXPAND=FALSE
{
{   This request notifies all jobs executing on behalf of the specified
{ recipient that mail has been sent to the recipient.
{
{       PMP$BROADCAST_UNSEEN_MAIL (RECIPIENT_USER, STATUS)
{
{ RECIPIENT_USER: (input) This parameter specifies the recipient's user
{        identification.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             none
{
*DECK DECK=PMH$BUILD_ADA_TASK_TABLE EXPAND=FALSE


{
{    The purpose of this procedure is to initialize the asynchronous task table
{  in the task control block of the calling task.
{
{        PMP$BUILD_ADA_TASK_TABLE (NUMBER_OF_TASKS, STATUS)
{
{  NUMBER_OF_TASKS: (input) This parameter specifies the number of task table
{        entries to be ALLOCATED.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: pme$illegal_ada_control_task
{
{       IDENTIFIER: 'PM'
{
*DECK DECK=PMH$BUILD_RING_CROSSING_FRAME EXPAND=FALSE

{  PURPOSE:
{    This procedure builds a stack frame save area at the beginning of a stack in front of
{    the ring crossing frame.
{
{  NOTE:
{    The design of this procedure is to make it look like pmp$call_ring_crossing_proc called
{    the owner of the ring crossing frame.  When the owner of the ring_crossing frame returns
{    pmp$call_ring_crossing_proc will execute and call pmp$ring_crossing_procedure.
{
{              PMP$BUILD_RING_CROSSING_FRAME (RING_CROSSING_SFSA)
{
{    RING_CROSSING_SFSA: (input) This parameter specifies the address (pva) of the stack frame
{              save area in the stack segment whose previous save area pointer points to a
{              stack frame save area in a stack segment for a higher ring.
{
*DECK DECK=PMH$CAUSE_CONDITION EXPAND=FALSE

{
{    The purpose of this request is to cause the named user defined
{  condition. Attempts to cause conditions for which there is no
{  condition handler established will result in abnormal status.
{
{        PMP$CAUSE_CONDITION (CONDITION_NAME, CONDITION_DESCRIPTOR,
{            STATUS)
{
{  CONDITION_NAME: (input) This parameter specifies the condition to be
{       caused.
{
{  CONDITION_DESCRIPTOR: (input) This parameter specifies the parameters
{        to be passed to the condition handler.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$incorrect_condition_name, pme$no_established_handler,
{                  pme$handler_stack_error, pme$inconsistent_stack,
{                  pme$invalid_condition_handler, pme$stack_overwritten.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$CAUSE_CONDITION_IN_TASKS EXPAND=FALSE

{    The purpose of this request is to cause a user defined condition in all
{ tasks of the requesting job.  If a task cannot receive signals it will not
{ have the condition raised in it.
{
{       PMP$CAUSE_CONDITION_IN_TASKS (CONDITION_NAME);
{
{ CONDITION_NAME: (input)  This is the name of the user defined condition to
{       cause.
*DECK DECK=PMH$CAUSE_INTER_JOB_CONDITION EXPAND=FALSE
{
{    The purpose of this request is to cause a user defined condition to be
{ raised within a different task.  The destination task may be in any job, and
{ is specified via a global task id.
{
{       PMP$CAUSE_INTER_JOB_CONDITION (CONDITION, TASK_ID, STATUS);
{
{  CONDITION: (input)  The name of the condition to be caused.
{
{  TASK_ID: (input)  The global task id of the task where the condition is to
{        be raised.
{
{  STATUS: (output) The status of the request.
{       CONDITIONS:
{             pme$incorrect_condition_name
{
*DECK DECK=PMH$CAUSE_INTRA_JOB_CONDITION EXPAND=FALSE
{
{    The purpose of this request is to cause a user defined condition to be
{ raised within a different task.  The destination task must be in the
{ requesting job, and is specified via a local task id.
{
{       PMP$CAUSE_INTRA_JOB_CONDITION (CONDITION, TASK_ID, STATUS);
{
{  CONDITION: (input)  The name of the condition to be caused.
{
{  TASK_ID: (input)  The local task id of the task where the condition is to be
{        raised.
{
{  STATUS: (output) The status of the request.
{       CONDITIONS:
{             pme$incorrect_condition_name
{             pme$unknown_recipient_task
{
*DECK DECK=PMH$CHANGE_BINARY_TO_ALPHA_DATE EXPAND=FALSE

{
{    The purpose of this request is to change a binary date to its alpha
{  equivalent.
{
{        PMP$CHANGE_BINARY_TO_ALPHA_DATE (BINARY_TIME, FORMAT, DATE, STATUS)
{
{  BINARY_TIME: (input) The binary date and time from which the date is
{        obtained and changed to its alpha equivalent.
{
{  FORMAT: (input) This parameter specifies the format in which the date
{        will be returned.  Valid specifications are:
{          osc$month_date : month DD, YYYY
{            example: November 13, 1978
{          osc$mdy_date : MM/DD/YY
{            example: 11/13/78
{          osc$iso_date : YYYY-MM-DD
{            example: 1978-13-11
{          osc$ordinal_date : YYYYDDD
{            example: 1978317
{          osc$default_date : an installation specified format from the above.
{
{  DATE: (output) This parameter specifies the current date.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$invalid_date_format.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$CHANGE_BINARY_TO_ALPHA_TIME EXPAND=FALSE

{
{    The purpose of this request is to change a binary time to its alpha
{  equivalent.
{
{        PMP$CHANGE_BINARY_TO_ALPHA_TIME (BINARY_TIME, FORMAT, TIME, STATUS)
{
{  BINARY_TIME: (input) The binary date and time from which the time is
{        obtained and changed to its alpha equivalent.
{
{  FORMAT: (input) This parameter specifies the format in which the time
{        will be returned.  Valid specifications are:
{          osc$ampm_time :  HH:MM AM or PM
{            example:  1:15 PM
{          osc$hms_time : HH:MM:SS
{            example: 13:15:21
{          osc$millisecond_time : HH:MM:SS:MMM
{            example: 13:15:21:453
{          osc$default_time : an installation specified format from the above.
{
{  TIME: (output) This parameter specifies the current time.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$invalid_time_format.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$CHANGE_BINDING_TO_WRITE EXPAND=FALSE
{
{    The purpose of this request is to change the segment attributes of a
{ binding segment in the calling task's address space so that the write
{ attribute is included and the binding attribute is excluded.
{
{       PMP$CHANGE_BINDING_TO_WRITE (SEGMENT, STATUS)
{
{  SEGMENT: (input)  This parameter specifies the segment whose attributes are
{        to be changed.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$not_transient_segment
{             pme$segment_ring_error
{
{
*DECK DECK=PMH$CHANGE_DEBUG_LIBRARY_LIST EXPAND=FALSE
{
{    The purpose of this request is to change the contents of the debug library
{ list.
{
{       PMP$CHANGE_DEBUG_LIBRARY_LIST (DELETE_LIBRARIES, ADD_LIBRARIES,
{             STATUS);
{
{  DELETE_LIBRARIES: (input)  This parameter specifies an array containing
{        library names to be deleted from the debug library list.
{
{  ADD_LIBRARIES: (input)  This parameter specifies an array containing library
{        names to be added to the debug library list.
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=PMH$CHANGE_DEFAULT_PROG_OPTIONS EXPAND=FALSE

{    The purpose of this request is to change the contents of the default
{  program options record.
{
{        PMP$CHANGE_DEFAULT_PROG_OPTIONS (CHANGE, STATUS)
{
{  CHANGE: (input) This parameter specifies which fields of the default
{        program options record are to be changed and the new values they are
{        to assume.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              pme$map_option_conflict
{              pme$invalid_file_name
{              pme$invalid_preset_option
{              pme$invalid_stack_size_option
{              pme$invalid_term_error_level

*DECK DECK=PMH$CHANGE_INHERITABLE_SEGMENTS EXPAND=FALSE
{
{
{
{    The purpose of this request is to change the segment inheritance
{ attributes of all segments opened or created when the requesting task was
{ loaded.  Setting segment inheritance causes these segments to be marked as
{ inherited; any child tasks created after this request is issued will inherit
{ these segments in the same process segment numbers in which they were opened
{ or created.
{
{    This request also causes the stack segment associated with rings from
{ which the request was issued to also be inherited.
{
{       PMP$CHANGE_INHERITABLE_SEGMENTS (OPTION, STATUS)
{
{  OPTION: (input)  This parameter specifies the inheritance option to use.
{        Permissible values are:
{          pmc$inherit_code_and_data:  modifiable static segments,
{            passed stack segments and nonmodifiable segments are shared.
{          pmc$clear_inherited_segments:  no segments are inherited except for
{            stacks if they are passed.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$illegal_ada_control_task
{             pme$invalid_inheritance_option
{             pme$invalid_loaded_ring
*DECK DECK=PMH$CHANGE_JOB_LIBRARY_LIST EXPAND=FALSE
{
{    The purpose of this request is to change the contents of the job library
{ list.
{
{       PMP$CHANGE_JOB_LIBRARY_LIST (DELETE_LIBRARIES, ADD_LIBRARIES, STATUS);
{
{  DELETE_LIBRARIES: (input)  This parameter specifies an array containing
{        library names to be deleted from the library list.
{
{  ADD_LIBRARIES: (input)  This parameter specifies an array containing library
{        names to be added to the library list.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              pme$duplicate_add_library
{              pme$empty_library_list
{              pme$file_not_existing_library
{              pme$invalid_file_name
{              pme$reserved_library_name
{              pme$unknown_delete_library
*DECK DECK=PMH$CHANGE_LEGIBLE_DATE_FORMAT EXPAND=FALSE
{
{    The purpose of this request is to convert a date from one legible date
{ format to another.
{
{
{       PMP$CHANGE_LEGIBLE_DATE_FORMAT (DATE, NEW_FORMAT, STATUS)
{
{ NEW_FORMAT: (input)  This parameter specifies the format in which the date
{        will be returned.  Valid specifications are:
{
{        osc$month_date :  month DD, YYYY   example:  November 13, 1978
{        osc$mdy_date :  MM/DD/YY           example:  11/13/78
{        osc$iso_date :  YYYY-MM-DD         example:  1978-11-13
{        osc$ordinal_date :  YYYYDDD        example:  1978317
{        osc$dmy_date :  DD.MM.YY           example:  13.11.78
{        osc$default_date :  an installation specified format from the above.
{
{ DATE: (input, output)  This parameter specifies the date to be converted.
{        It can be specified in any of the formats above except
{        osc$default_date.  The specified date will be returned in the format
{        indicated by the NEW_FORMAT parameter.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             pme$invalid_date_format.
{             pme$invalid_day.
{             pme$invalid_month.
{             pme$invalid_year.
*DECK DECK=PMH$CHANGE_TERM_ERROR_LEVEL EXPAND=FALSE
{
{   The purpose of this request is to change the "termination error level"
{ being used by the loader in the current task.
{
{   The motivation for this capability is to allow a caller to attempt a
{ dynamic load without having the "side effect" of any resulting loader errors
{ being written anywhere.  This could be accomplished by:
{
{       1.  calling this request with a "new" level of osc$fatal_status,
{
{       2.  calling the appropriate dynamic load request,
{
{       3.  calling this request again with a "new" level equal to the "old"
{           level returned by step 1.
{
{   The caller of this request is responsible for ensuring that the original
{ termination error level is restored.  This may require the use of a "block
{ exit" condition handler.
{
{       PMP$CHANGE_TERM_ERROR_LEVEL (NEW_TERMINATION_ERROR_LEVEL,
{         OLD_TERMINATION_ERROR_LEVEL, STATUS)
{
{ NEW_TERMINATION_ERROR_LEVEL: (input)  This parameter specifies the new value
{       for the loader's termination error level.
{
{ OLD_TERMINATION_ERROR_LEVEL: (output)  This parameter specifies the
{       termination error level being used by the loader at the time this
{       request is made.
{
{ STATUS: (output)  This parameter specifies the request status.
{
*DECK DECK=PMH$CHANGE_TRANSIENT_TO_BINDING EXPAND=FALSE
{
{    The purpose of this request is to change the segment attributes of a
{ segment in the calling task's address space so that the binding attribute is
{ included and the write attribute is excluded.
{
{  NOTES:  This procedure insures that only pointers to the caller's ring are
{        present in the segment to insure no unauthorized references.
{
{       PMP$CHANGE_TRANSIENT_TO_BINDING (SEGMENT, STATUS)
{
{  SEGMENT: (input)  This parameter specifies the segment whose attributes are
{        to be changed.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$code_base_pointer_error
{             pme$not_transient_segment
{             pme$segment_ring_error
{
{
*DECK DECK=PMH$CHANGE_TRANSIENT_TO_EXECUTE EXPAND=FALSE
{
{    The purpose of this request is to change the segment attributes of a
{ segment in the calling task's address space so that the execute attribute is
{ included and the write attribute is excluded.
{
{       PMP$CHANGE_TRANSIENT_TO_EXECUTE (SEGMENT, STATUS)
{
{  SEGMENT: (input)  This parameter specifies the segment whose attributes are
{        to be changed.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$not_transient_segment
{             pme$segment_ring_error
{
{
*DECK DECK=PMH$CHANGE_TRANSIENT_TO_WRITE EXPAND=FALSE
{
{    The purpose of this request is to change the segment attributes of a
{ segment in the calling task's address space so that the write attribute is
{ included and the execute attribute is excluded.
{
{       PMP$CHANGE_TRANSIENT_TO_WRITE (SEGMENT, STATUS)
{
{  SEGMENT: (input)  This parameter specifies the segment whose attributes are
{        to be changed.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$not_transient_segment
{             pme$segment_ring_error
{
{
*DECK DECK=PMH$CLEAR_WAIT_INHIBITED EXPAND=FALSE
{
{  The purpose of this request is to clear the wait inhibited flag of
{ a task that has been made ready by PMP$READY_TASK.  The wait
{ inhibited flag will prevent a task from going into wait.
{
{       PMP$CLEAR_WAIT_INHIBITED (WAS_WAIT_INHIBITED, STATUS)
{
{ WAS_WAIT_INHIBITED: (output) This parameter specifies whether the wait
{       inhibited flag was set.
{
{ STATUS: (output) This parameter specifies the request status.
{    CONDITIONS:
{          none
*DECK DECK=PMH$CLOSE_COMMON_BLOCK_FILE EXPAND=FALSE
{
{    The purpose of this request is to close a file open for segment access and
{ remove its association with a common block.  A subsequent
{ PMP$OPEN_COMMON_BLOCK_FILE request can be issued to reassociate the common
{ block with a file.
{
{       PMP$CLOSE_COMMON_BLOCK_FILE (COMMON_BLOCK,STATUS)
{
{  COMMON_BLOCK: (input)  This parameter specifies the common block for which
{        the association with a file is to be removed.  The file with which it
{        is associated will be closed.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$common_not_unallocated
{             pme$common_file_not_open
{
*DECK DECK=PMH$CLOSE_OBJECT_LIBRARY EXPAND=FALSE
{
{    The purpose of this request is to close an object library.
{
{       PMP$CLOSE_OBJECT_LIBRARY (FILE_IDENTIFIER, STATUS)
{
{   FILE_IDENTIFIER: (input)  This parameter specifies the file identifier of
{         the object library.
{
{   STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{              none
{
*DECK DECK=PMH$COMPUTE_DATE_TIME EXPAND=FALSE
{
{    The purpose of this request is to compute a new date and time from a base
{  date and time, and an increment.
{
{        PMP$COMPUTE_DATE_TIME (BASE, INCREMENT, RESULT, STATUS)
{
{ BASE: (input) This parameter specifies the date and time to increment.
{
{ INCREMENT: (input) This parameter specifies the amount to increment the base
{        date and time by, either positive or negative.
{
{ RESULT: (output) This parameter specifies the resulting date and time.
{
{ STATUS: (output) This parameter specifies the request status.
{    CONDITION: pme$compute_overflow, pme$invalid_year.
{    IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$COMPUTE_DATE_TIME_INCREMENT EXPAND=TRUE
{
{   The purpose of this request is to compute the time increment between an old
{ date and time and a new date and time.
{
{       PMP$COMPUTE_DATE_TIME_INCREMENT (OLD, NEW, INCREMENT, STATUS)
{
{ OLD: (input)  This parameter specifies the first date and time.
{
{ NEW: (input)  This parameter specifies the second date and time.  If OLD is
{       earlier in time than NEW, then INCREMENT will be positive.
{
{ INCREMENT: (output)  This parameter specifies the resulting date and time
{       increment, either positive or negative.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: pme$compute_overflow
{                   pme$invalid_year
{
*DECK DECK=PMH$COMPUTE_DAY_OF_WEEK EXPAND=FALSE
{
{   The purpose of this request is to determine the day of the week
{ corresponding to a date.
{
{       PMP$COMPUTE_DAY_OF_WEEK (DATE, DAY_OF_WEEK, STATUS)
{
{ DATE: (input)  This parameter specifies the date for which the day of the
{       week is desired.
{
{ DAY_OF_WEEK: (output)  This parameter specifies the day of the week.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: pme$invalid_year
{
*DECK DECK=PMH$COMPUTE_LOCAL_DATE_TIME EXPAND=FALSE
{
{   The purpose of this request is to compute the "local" date and time
{ equivalent to a date and time expressed relative to the "universal" time
{ zone.  The "universal" time zone is that of Greenwich, England, often called
{ Greenwich Mean Time.
{
{       PMP$COMPUTE_LOCAL_DATE_TIME (UNIVERSAL_DATE_TIME, TIME_ZONE,
{         LOCAL_DATE_TIME, STATUS)
{
{ UNIVERSAL_DATE_TIME: (input)  This parameter specifies the universal date
{       and time.
{
{ TIME_ZONE: (input)  This parameter specifies the time zone that the date and
{       time are to be made relative to.
{
{ LOCAL_DATE_TIME: (output)  This parameter specifies the resulting local date
{       and time.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: pme$compute_overflow
{                   pme$invalid_year
{                   pme$invalid_time_zone
{
*DECK DECK=PMH$COMPUTE_TIME_DIF_IN_SECONDS EXPAND=FALSE
{
{    The purpose of this request is to compute the number of seconds that have
{ elapsed between the two dates given.  If the "old" date is greater than the
{ "new" date, the number of seconds returned is a negative value.
{
{       PMP$COMPUTE_TIME_DIF_IN_SECONDS (OLD, NEW, SECONDS, STATUS)
{
{ OLD: (input)  This parameter specifies the old date to be used in the
{       computation.
{
{ NEW: (input)  This parameter specifies the new date to be used in the
{       computation.
{
{ SECONDS: (output)  This parameter specifies the number of seconds between the
{       old and new dates.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$invalid_day
{             pme$invalid_hour
{             pme$invalid_millisecond
{             pme$invalid_minute
{             pme$invalid_month
{             pme$invalid_second
{             pme$invalid_year
*DECK DECK=PMH$COMPUTE_UNIVERSAL_DATE_TIME EXPAND=FALSE
{
{   The purpose of this request is to compute the "universal" date and time
{ equivalent to a date and time expressed relative to a "local" time zone.
{ The "universal" time zone is that of Greenwich, England, often called
{ Greenwich Mean Time.
{
{       PMP$COMPUTE_UNIVERSAL_DATE_TIME (LOCAL_DATE_TIME, TIME_ZONE,
{         UNIVERSAL_DATE_TIME, STATUS)
{
{ LOCAL_DATE_TIME: (input)  This parameter specifies the local date and time.
{
{ TIME_ZONE: (input)  This parameter specifies the time zone that the local
{       date and time is relative to.
{
{ UNIVERSAL_DATE_TIME: (output)  This parameter specifies the resulting
{       universal date and time.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: pme$compute_overflow
{                   pme$invalid_year
{                   pme$invalid_time_zone
{
*DECK DECK=PMH$CONDITION_TASK_TERMINATION EXPAND=FALSE
{
{    The purpose of this request is to pre-condition the termination of a task
{ so that it can terminate correctly.  The requirements for routines called by
{ this procedure are as follows:
{
{    1.  They must be 100% recallable at anytime during task termination.
{
{    2.  They cannot go into a wait of any kind.
{
{    3.  They must not require a large amount of space on the stack such that
{        if a task is aborting due to a stack overflow, we can still orderly
{        abort the task.
{
{        PMP$CONDITION_TASK_TERMINATION;
*DECK DECK=PMH$CONNECT_QUEUE EXPAND=FALSE
{
{    The purpose of this request is to connect a task to a previously defined
{ queue for subsequent sending and receiving.
{
{       PMP$CONNECT_QUEUE (NAME, QID, STATUS)
{
{  NAME: (input)  This parameter specifies the queue to which connection is to
{        be made.
{
{  QID: (output)  This parameter specifies the system supplied queue identifier
{        to be used on subsequent PMP$SEND_TO_QUEUE and PMP$RECEIVE_FROM_QUEUE
{        requests.
{
{  STATUS: (output) This parameter specifies request status.
{       CONDITIONS:
{             pme$incorrect_queue_name.
{             pme$maximum_tasks_connected
{             pme$task_already_connected
{             pme$unknown_queue_name
{             pme$usage_bracket_error,
{
{  NOTES:
{    The correct QID will be returned if the error pme$task_already_connected
{    occurs.
{
*DECK DECK=PMH$CONTINUE_TO_CAUSE EXPAND=FALSE

{
{    The purpose of this request is to allow a user condition handler
{  to continue to cause the condition being processed (i.e., pass the
{  condition to the next most recently established handler in effect for
{  the condition.  Attempts to use this request from other than a condition
{  handler are in error.
{    Selection of pmc$execute_standard_procedure will cause execution of
{  the respective standard operating system procedure if there is no other
{  condition handler in effect for the condition.
{    Selection of pmc$inhibit_standard_procedure will inhibit the execution
{  of standard operating system procedures if no other handler is in effect.
{  Attempts to continue a condition with the inhibit selection for which there
{  is no other condition handler in effect will result in abnormal status.
{
{        PMP$CONTINUE_TO_CAUSE ( STANDARD, STATUS )
{
{ STANDARD: (input) This parameter specifies whether the standard operating
{       system procedure should execute in absence of another condition
{       handler.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$no_condition_to_continue, pme$no_established_handler,
{                  pme$handler_stack_error, pme$inconsistent_stack,
{                  pme$invalid_condition_handler, pme$recursive_continue,
{                  pme$invalid_standard_selection, pme$stack_overwritten.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$CONVERT_BINARY_MAINFRAME_ID EXPAND=FALSE
{
{    The purpose of this request is to convert a binary mainframe identifier to
{ its legible mainframe identifier equivalent.
{
{       PMP$CONVERT_BINARY_MAINFRAME_ID (BINARY_MAINFRAME_ID, MAINFRAME_ID,
{             STATUS);
{
{ BINARY_MAINFRAME_ID: (input)  This is the binary mainframe identifier to be
{       converted.
{
{ MAINFRAME_ID: (output)  This is the legible counterpart to the specified
{       binary mainframe identifier.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{         none
*DECK DECK=PMH$CONVERT_BINARY_UNIQUE_NAME EXPAND=FALSE
{
{    The purpose of this request is to convert a binary unique name to a
{ similar SCL name equivalent.
{
{       PMP$CONVERT_BINARY_UNIQUE_NAME (BINARY_NAME, NAME, STATUS);
{
{ BINARY_NAME: (input)  This is the binary unique name to be converted.
{
{ NAME: (output)  This name is the result of the conversion.
{
{ STATUS: (output) This is the status of the request.
{    CONDITIONS:
{        none.
{
*DECK DECK=PMH$CONVERT_CPU_BINARY_TO_ASCII EXPAND=FALSE
*DECK DECK=PMH$CONVERT_MAINFRAME_TO_BINARY EXPAND=FALSE
{
{    The purpose of this request is to convert a mainframe identifier into its
{ counterpart binary mainframe identifier.
{
{       PMP$CONVERT_MAINFRAME_TO_BINARY (MAINFRAME_ID, BINARY_MAINFRAME_ID,
{             STATUS);
{
{ MAINFRAME_ID: (input)  This is the mainframe identifier to be converted.
{
{ BINARY_MAINFRAME_ID: (output)  This is the binary mainframe identifier that
{       is the counterpart to the mainframe identifier specified.  The model
{       number field returned will be osc$cyber_180_model_unknown if the
{       mainframe identifier is not recognized.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             pme$invalid_mainframe_id
*DECK DECK=PMH$CONVERT_UNIQUE_TO_BINARY EXPAND=FALSE
{
{    The purpose of this request is to convert a unique name into its binary
{ unique name equivalent.
{
{       PMP$CONVERT_UNIQUE_TO_BINARY (NAME, BINARY_NAME, STATUS);
{
{ NAME: (input)  This is the unique name to be converted.
{
{ BINARY_NAME: (output)  This is the result of the conversion.
{
{ STATUS: (output) This is the status of the request.
{    CONDITIONS:
{        pme$invalid_unique_name
{
*DECK DECK=PMH$CREATE_ADA_HEAP EXPAND=FALSE
{
{    The purpose of this request is to create a segment for the ADA control
{  task that can be used as a n ADA shared heap.  The segment created will be
{  entered into the loader's allocated segment table so that it will be in-
{  herited by any asynchronous procedure that is subsequently called.
{
{        PMP$CREATE_ADA_HEAP(HEAP_SEGMENT_POINTER, STATUS)
{
{  HEAP_SEGMENT_POINTER: (output) This parameter specifies a pointer to the
{        heap segments that was created.  This segment will be
{        inherited by all subsequent tasks created in the same "family" of
{        tasks.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: pme$illegal_ada_control_task
{
*DECK DECK=PMH$CREATE_SHARED_STACK EXPAND=FALSE


{
{    The purpose of this procedure is to call the segment manager to acquire a
{  shared stack segment for use by the task being initiated.
{    This procedure runs in ring 2 so that it can lock the parent-child task
{  control block chain before calling the segment manager.  This is necessary
{  to ensure that the array of task_id's sent to the segment manager contain
{  only valid entries.
{
{        PMP$CREATE_SHARED_STACK (SEGMENT_ATTRIBUTES, STATUS)
{
{  SEGMENT_ATTRIBUTES: (input) This parameter specifies the attributes the stack segment
{        is to be assigned.
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=PMH$CYCLE EXPAND=FALSE
{
{   The purpose of this request is to relinquish control of the system.
{
{       PMP$CYCLE (STATUS)
{
{ STATUS: (output) This parameter specifies the request status.
{     CONDITIONS:
{           none
*DECK DECK=PMH$DATE_TIME_COMPARE EXPAND=FALSE
{
{    The purpose of this request is to provide a comparison of two dates.
{
{       PMP$DATE_TIME_COMPARE (LEFT_OPERAND, RIGHT_OPERAND, COMPARISON_RESULT,
{             STATUS)
{
{ LEFT_OPERAND: (input)  This parameter specifies the left operand date_time.
{
{ RIGHT_OPERAND: (input)  This parameter specifies the right operand date_time.
{
{ COMPARISON_RESULT: (output)  This parameter specifies the result of the
{       date_time comparison as follows:
{
{       PMC$LEFT_IS_GREATER if the left operand value is greater.  PMC$EQUAL if
{       the left and right operand values are equal.  PMC$RIGHT_IS_GREATER if
{       the right operand value is greater.
{
{ STATUS: (output) This parameter specifies the request status.
{    CONDITIONS:
{          pme$invalid_day
{          pme$invalid_month
{          pme$invalid_year
{          pme$invalid_millisecond
{          pme$invalid_second
{          pme$invalid_minute
{          pme$invalid_hour
{
*DECK DECK=PMH$DEBUG_CRITICAL_FRAME EXPAND=FALSE
{
{   The purpose of this request is to determine whether a stack frame
{ has been previously established as a debug critical stack frame.
{
{       PMP$DEBUG_CRITICAL_FRAME (STACK_FRAME, CRITICAL_STACK_FRAME)
{
{ STACK_FRAME: (input) This parameter specifies the stack frame which
{       is in question.
{
{ CRITICAL_STACK_FRAME: (output) This parameter returns TRUE if the stack
{       frame in question has been previously established has a debug critical
{       stack frame.
{
*DECK DECK=PMH$DEBUG_LOGGING_ENABLED EXPAND=FALSE

{   The purpose of this request is to return a boolean value that indicates if the
{ system attribute ENABLE_PM_DEBUG_LOGGING is true or false.
{
{       PMP$DEBUG_LOGGING_ENABLED (): BOOLEAN;
*DECK DECK=PMH$DEFINE_DEBUG_ENTRY EXPAND=FALSE
{
{
{    The purpose of this request is to define a debug list entry.
{
{       PMP$DEFINE_DEBUG_ENTRY (DEBUG_CODE, LOW_ADDRESS, HIGH_ADDRESS,
{             DEBUG_ID, STATUS)
{
{ DEBUG_CODE: (input)  This parameter specifies the debug codes (data read,
{       data write, instruction fetch, branching instruction, call instruction)
{       for which the entry is being defined.
{
{ LOW_ADDRESS: (input)  This parameter specifies the LOW address for which the
{       entry is being defined.
{
{ HIGH_ADDRESS: (input)  This parameter specifies the HIGH address for which
{       the entry is being defined.
{
{ DEBUG_ID: (output)  This parameter specifies the system assigned debug
{       identifier to be passed to a debug condition handler when a a debug
{       condition associated with this debug entry arises.  The debug
{       identifier is also used on subsequent requests (remove, get, and
{       modify) related to the defined entry.
{
{ STATUS: (output) This parameter specifies the request status.
{      CONDITIONS:
{            pme$address_segments_not_equal
{            pme$empty_debug_code
{            pme$invalid_access
{            pme$low_addr_greater_than_high
{            pme$too_many_debug_list_entries
{
{
*DECK DECK=PMH$DEFINE_MONITOR_FAULT EXPAND=FALSE

{
{   The purpose of this request is to define a monitor fault handler within a
{ job for a specified monitor fault.  The request effects all existing and
{ future tasks within the job.
{
{   Attempts to define an already defined handler are in error.
{
{  WARNING: this request is intended for testing purposes only -
{           "released" systems must have fault identifiers and
{           corresponding fault handlers known at compile-time.
{
{       PMP$DEFINE_MONITOR_FAULT (FAULT_ID, FAULT_HANDLER, STATUS)
{
{ FAULT_ID: (input) This parameter specifies the monitor fault identifier
{       the fault handler is to process.
{
{ FAULT_HANDLER: (input) This parameter specifies the handler for the
{       specified fault.  The low ring of execution of the handler must
{       be osc$tmtr_ring, otherwise the request is in error.  The high
{       ring must be osc$user_ring_2 or at least osc$tsrv_ring with a
{       call bracket of osc$user_ring_2, otherwise the request is in
{       error.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$nil_handler, pme$handler_already_defined,
{                  pme$invalid_identifier, pme$exec_call_bracket_error.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$DEFINE_QUEUE EXPAND=FALSE

{
{    The purpose of this request is to define a job local queue.
{
{        PMP$DEFINE_QUEUE (NAME, REMOVAL_BRACKET, USAGE_BRACKET, STATUS)
{
{  NAME: (input) This parameter specifies the name of the queue.
{
{  REMOVAL_BRACKET: (input) This parameter specifies the highest ring
{        from which this queue definition may be removed.  The ring from
{        which the request is made must be less than or equal to the
{        removal bracket.
{
{  USAGE_BRACKET: (input) This parameter specifies the highest ring from
{        which this queue may be sent to or received from.  The usage
{        bracket must be greater than or equal to the removal bracket.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$maximum_queues_defined, pme$queue_already_defined,
{                  pme$request_gt_removal_bracket, pme$usage_lt_removal_bracket,
{                  pme$incorrect_queue_name.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$DELAY EXPAND=FALSE
{
{
{    The purpose of this request is to relinquish control of the system for at
{ least the specified number of milliseconds.
{
{       PMP$DELAY (MILLISECONDS, STATUS)
{
{ MILLISECONDS: (input)  This parameter specifies the delay time.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             none
*DECK DECK=PMH$DELETE_ENVIRONMENT EXPAND=FALSE
{
{    The purpose of this request is to delete the condition environment
{ associated with the critical frame being circumvented by a condition
{ handler's non local exit.
{
{       PMP$DELETE_ENVIRONMENT (CRITICAL_FRAME, STATUS)
{
{ CRITICAL_FRAME: (input)  This parameter specifies the critical frame being
{       circumvented by a non local exit.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             pme$stack_overwritten.
{
*DECK DECK=PMH$DESELECT_PROCESSOR EXPAND=FALSE
{
{  The purpose of this procedure is to allow a task to deselect the particular
{ processor which was selected using a previous call PMP$SELECT_PROCESSOR.
{
{   PMP$SELECT_PROCESSOR (status)
{
{ STATUS: (OUTPUT) This parameter specifies the request status.
{
*DECK DECK=PMH$DISCONNECT_QUEUE EXPAND=FALSE

{
{    The purpose of this request is to disconnect a task from a previously
{  connected queue.
{
{        PMP$DISCONNECT_QUEUE (QID, STATUS)
{
{  QID: (input) This parameter specifies the queue from which the requesting
{        task is to be disconnected.
{
{  STATUS: (output) This parameter specifies request status.
{       CONDITION: pme$unknown_queue_identifier, pme$usage_bracket_error.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$DISCONNECT_TASK_FROM_QUEUES EXPAND=FALSE

{ }
{   The purpose of this request is to disconnect the terminating task   }
{ from all local queues - to be utlilized only during task termination. }
{ }
{       PMP$DISCONNECT_TASK_FROM_QUEUES                                 }
{ }
*DECK DECK=PMH$DISESTABLISH_COND_HANDLER EXPAND=FALSE

{
{   The purpose of this request is to disestablish the condition handler
{ currently in effect for the specified condition(s).
{
{        PMP$DISESTABLISH_COND_HANDLER (CONDITIONS, STATUS)
{
{  CONDITIONS: (input) This parameter specifies the conditions previously
{        established for the handler which is to be disestablished.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$incorrect_condition_name, pme$no_established_handler,
{                  pme$handler_stack_error, pme$inconsistent_stack.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$DISESTABLISH_END_HANDLER EXPAND=FALSE
{
{
{   The purpose of this request is to disestablish a previously
{ established task end handler.
{
{       PMP$DISESTABLISH_END_HANDLER (END_HANDLER, STATUS)
{
{ END_HANDLER: (input) This parameter specifies the
{       previously established task end handler which is
{       to be disestablished.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$handler_more_privileged
{             pme$no_established_handler
*DECK DECK=PMH$DISESTABLISH_SEGMENT_ACCESS EXPAND=FALSE

{
{   The purpose of this request is to delete the association of a segment
{ access file to a previously defined unallocated common block.
{
{   The following assumptions prevail when using this interface:
{
{    1.  The file has already been opened for segment access by the program
{        and the association of it with the unallocated common block has
{        been made thru a call to pmp$establish_segment_access.  The
{        file_identifier from that open has been stored in the proper
{        entry in the loader's internal common block tables.
{
{    2.  The program is responsible for establishing the size of the file
{        prior to closing it.  The amp$set_segment_eoi interface may be used
{        for this purpose.
{
{
{       PMP$DISESTABLISH_SEGMENT_ACCESS (COMMON_BLOCK, STATUS)
{
{  COMMON_BLOCK: (input)  This parameter specifies the name of a previously
{        defined unallocated common block.  This common block cannot be
{        associated with a file at the time this request is issued.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{                    pme$common_not_unallocated
{                    pme$common_file_open
{
*DECK DECK=PMH$DISESTAB_END_HNDLR_IN_RING EXPAND=FALSE
{
{
{   The purpose of this request is to disestablish a previously
{ established task end handler in a specific ring.  This
{ procedure may only be used to disestablish task end handlers
{ in the same or less privileged rings from which it is called.
{
{       PMP$DISESTAB_END_HNDLR_IN_RING (END_HANDLER,
{            RING, STATUS)
{
{ END_HANDLER: (input) This parameter specifies the
{       previously established task end handler which is to
{       be disestablished.
{
{ RING: (input) This parameter specifies the ring in which the
{       task end handler is to be disestablished.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$no_established_handler
{             pme$more_privileged_ring
{
*DECK DECK=PMH$DISPLAY_ACTIVE_TASKS EXPAND=FALSE
{
{    The purpose of this request is to display the tasks which are executing
{ within the current job.
{
{       PMP$DISPLAY_ACTIVE_TASKS (OUTPUT, STATUS)
{
{ OUTPUT: (input)  This parameter specifies the file to which the output is
{       displayed.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=PMH$DISPOSE_INTERACTIVE_COND EXPAND=FALSE

{
{   The purpose of this request is to dispose of (cause) an interactive
{ condition.  The request is to be used only by the interactive facility and
{ the condition processing portions of program management.
{
{       PMP$DISPOSE_INTERACTIVE_COND (INTERACTIVE_CONDITION)
{
{ INTERACTIVE_CONDITION: (input) This parameter specifies the interactive condition.
{
{
*DECK DECK=PMH$DISPOSE_JOB_RESOURCE_COND EXPAND=FALSE

{
{   The purpose of this request is to dispose of (cause) a job resource
{ condition.  The request is to be used only by accounting/valiadation.
{
{       PMP$DISPOSE_JOB_RESOURCE_COND (JOB_RESOURCE_CONDITION)
{
{ JOB_RESOURCE_CONDITION: (input) This parameter specifies the job resource
{       condition.
{
*DECK DECK=PMH$DISPOSE_MCR_CONDITIONS EXPAND=FALSE
{ }
{   The purpose of this procedure is to dispose of monitor condition    }
{ register faults - NOS/VE monitor fault identifier tmc$mcr_fault.      }
{ }
{       PMP$DISPOSE_MCR_CONDITIONS (FAULT, SFSA)                        }
{ }
{ FAULT: (input) This parameter specifies the received MCR fault.       }
{ }
{ SFSA: (input) This parameter specifies the Stack Frame Save Area      }
{       which caused the MCR fault.                                     }
{ }

*DECK DECK=PMH$DISPOSE_OF_DELAYED_COND EXPAND=FALSE
{ }
{   The purpose of this request is to dispoe of delayed conditions.     }
{ }
{       PMP$DISPOSE_OF_DELAYED_COND (SFSA)                              }
{ }
{ SFSA: (input) This parameter specifies the Stack Frame Save Area      }
{       which caused the request to be issued.                          }
{ }
*DECK DECK=PMH$DISPOSE_OF_TRAPS EXPAND=FALSE
{
{   The purpose of this request is dispose of traps.
{
{   pmp$dispose_of_traps is to be called only by the assembly language
{   trap processor.
{
{    PMP$DISPOSE_OF_TRAPS (SFSA)
{
{ SFSA: (input) This parameter specifies the trapped Stack Frame Save
{       Area.
*DECK DECK=PMH$DISPOSE_SEGMENT_ACCESS_COND EXPAND=FALSE

{
{   The purpose of this request is to dispose of (cause) a segment access
{ condition.  The request is to be used only by segment management.
{
{       PMP$DISPOSE_SEGMENT_ACCESS_COND (CONDITION, SFSA)
{
{ CONDITION: (input) This parameter specifies the segment access condition.
{
{ SFSA: (input) This parameter specifies the stack frame save area which
{       caused the segment access condition.
{
*DECK DECK=PMH$DISPOSE_UCR_CONDITIONS EXPAND=FALSE
{ }
{   The purpose of this procedure is to dispose of ucr conditions.  UCR }
{ conditions are those conditions detected by hardware and reported in  }
{ the ucr register. In general ucr condition will prohibit task execu-  }
{ tion in absence of corrective action.                                 }
{ }
{       PMP$DISPOSE_UCR_CONDITIONS (OUTSTANDING_UCR,                    }
{         CONDITION_SAVE_AREA, DEBUG_INDEX)                             }
{ }
{ OUTSTANDING_UCR: (input, output) This parameter specifies the ucr     }
{       conditions to be processed.                                     }
{ }
{ CONDITION_SAVE_AREA: (input) This parameter specifies the stack frame }
{       save area which caused the condition.                           }
{ }
{ DEBUG_INDEX: (input) This parameter specifies the debug index at the  }
{       time the condition was caused.                                  }
{ }
*DECK DECK=PMH$EMIT_JOB_END_STATISTICS EXPAND=FALSE
{    The purpose of this request is to emit the job end statistics for a NOS/VE
{ job.  This request also emits the task end statistics for the job's job
{ monitor task.
{
{       PMP$EMIT_JOB_END_STATISTICS (STATUS);
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{          none
*DECK DECK=PMH$ENABLE_SYSTEM_CONDITIONS EXPAND=FALSE

{   The purpose of this request is to allow any of the following system
{ conditions to arise in the requesting block and its subordinates:
{      pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
{      pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
{      pmc$arithmetic_significance, pmc$invalid_bdp_data.
{ For each system condition being enabled, if the condition is pending
{ as the result of a previous inhibit, that condition is cleared prior to
{ enabling the condition.
{
{   NOTE: All system conditions, except pmc$fp_significance_loss, are enabled
{         before the starting procedure executes.
{
{       PMP$ENABLE_SYSTEM_CONDITIONS (CONDITIONS, STATUS)
{
{ CONDITIONS: (input) This parameter specifies the conditions to be enabled.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$unselectable_condition.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$ENABLE_TS_IO_IN_JOB EXPAND=FALSE
{    The purpose of this request is to re-enable timesharing (interactive) IO
{ in all tasks of a job.  This procedure non-discriminately ignores the fact
{ that an interactive condition may have caused a task to be unable to perform
{ terminal IO.
{
{    PMP$ENABLE_TS_IO_IN_JOB;
*DECK DECK=PMH$END_SUBSYSTEM_ACTIVITY EXPAND=FALSE
{
{
{ This request is used by a subsystem to inform the OS that the task
{ has left a block of code that set interlocks (or equivalent)
{ on shared system-global resources. If the operating system has deferred
{ swapping the task because of a non-zero subsystem_activity count and the
{ count is now zero, this request will cause the swap to proceed.
{
{
{        PMP$END_SUBSYSTEM_ACTIVITY (STATUS);
{
{  STATUS: (output) This parameter is the request status.
{       CONDITIONS:
{             none
*DECK DECK=PMH$ESTABLISH_CH_IN_BLOCK EXPAND=FALSE
{
{    The purpose of this request is to establish a procedure that will process
{ the specified condition(s) in the specified block.  Condition handlers are
{ stacked in the order they are established.  When a condition arises, the most
{ recently established handler for that condition is given control.
{
{    On block exit all condition handlers established in that block are
{ automatically disestablished.
{
{       PMP$ESTABLISH_CH_IN_BLOCK (CONDITIONS, CONDITION_HANDLER, BLOCK,
{             ESTABLISH_DESCRIPTOR, STATUS)
{
{  CONDITIONS: (input)  This parameter specifies the conditions for which the
{        handler is being established.
{
{  CONDITION_HANDLER: (input)  This parameter specifies the user's condition
{        handler.
{
{  BLOCK: (input)  This parameter specifies the block in which the handler is
{        to be established.
{
{  ESTABLISH_DESCRIPTOR: (input, output)  This parameter specifies the variable
{        that describes the established condition handler.  This variable must
{        in the stack segment specified by block at an address greater than
{        that of block.  The values of this variable are initialized by the
{        request processor and need not be initialized by the requestor.
{        WARNING:  re-use of an establish_descriptor (e.g., two establish
{        requests for the same block which utilize the same descriptor) will
{        cause undefined results.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$invalid_condition_selector
{             pme$incorrect_condition_name
{             pme$descriptor_address_error
{             pme$unselectable_condition
{             pme$handler_stack_error
{             pme$inconsistent_stack
{
*DECK DECK=PMH$ESTABLISH_CH_OUTSIDE_BLOCK EXPAND=FALSE
{
{    The purpose of this request is to establish a procedure that will
{  process the specified condition(s).  Condition handlers are stacked
{  in the order they are established.  When a condition arises, the
{  condition handler currently in effect for that condition is given control.
{  This request is different from PMP$ESTABLISH_CONDITION_HANDLER in that
{  the establish descriptor need not reside in the calling procedures block.
{
{  On block exit all condition handlers established in that block
{  are automatically disestablished.
{
{        PMP$ESTABLISH_CH_OUTSIDE_BLOCK (CONDITIONS, CONDITION_HANDLER,
{            BLOCK, ESTABLISH_DESCRIPTOR, STATUS)
{
{  CONDITIONS: (input) This parameter specifies the conditions for which
{        the handler is being established.
{
{  CONDITION_HANDLER: (input) This parameter specifies the user's
{        condition handler.
{
{  BLOCK: (input)  This parameter specifies the block in which the handler is
{        to be established.
{
{  ESTABLISH_DESCRIPTOR: (input, output) This parameter specifies the variable
{        that describes the established condition handler. The values
{        of this variable are initialized by the request processor and
{        need not be initialized by the requestor.
{        WARNING: re-use of an establish_descriptor (e.g., two establish
{        requests in the same procedure which utilize the same descriptor)
{        will cause undefined results.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$invalid_condition_selector,
{                  pme$incorrect_condition_name,
{                  pme$descriptor_address_error,
{                  pme$unselectable_condition
{                  pme$handler_stack_error,
{                  pme$inconsistent_stack,
{                  pme$stack_overwritten.
{
*DECK DECK=PMH$ESTABLISH_CONDITION_HANDLER EXPAND=FALSE

{
{    The purpose of this request is to establish a procedure that will
{  process the specified condition(s).  Condition handlers are stacked
{  in the order they are established.  When a condition arises, the
{  condition handler currently in effect for that condition is given control.
{
{  On block exit all condition handlers established in that block
{  are automatically disestablished.
{
{        PMP$ESTABLISH_CONDITION_HANDLER (CONDITIONS, CONDITION_HANDLER,
{            ESTABLISH_DESCRIPTOR, STATUS)
{
{  CONDITIONS: (input) This parameter specifies the conditions for which
{        the handler is being established.
{
{  CONDITION_HANDLER: (input) This parameter specifies the user's
{        condition handler.
{
{  ESTABLISH_DESCRIPTOR: (input, output) This parameter specifies the variable
{        that describes the established condition handler. This must
{        reside in the current stack frame of the requestor. The values
{        of this variable are initialized by the request processor and
{        need not be initialized by the requestor.
{        WARNING: re-use of an establish_descriptor (e.g., two establish
{        requests in the same procedure which utilize the same descriptor)
{        will cause undefined results.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$invalid_condition_selector, pme$incorrect_condition_name,
{                  pme$descriptor_address_error, pme$unselectable_condition,
{                  pme$handler_stack_error, pme$inconsistent_stack,
{                  pme$stack_overwritten.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$ESTABLISH_DEBUG_CFF EXPAND=FALSE
{
{   The purpose of this request is to establish a debug critical frame
{ in an interrupted user program.  An established debug critical frame
{ will give a debugger control on return from or pop of a user's procedure
{ for which a debug critical frame is established.
{
{   Attempts to establish a debug critical frame for an invalid stack
{ frame save area are in error.
{
{       PMP$ESTABLISH_DEBUG_CFF (CRITICAL_FRAME, STATUS)
{
{ CRITICAL_FRAME: (input) This parameter specifies the critical stack
{       frame save area for establishment of the debug critical frame.
{
{ STATUS: (output) This parameter specifies the request status.
{      CONDITIONS:
{            pme$inconsistent_stack
{            pme$stack_frame_not_found
{
*DECK DECK=PMH$ESTABLISH_END_HANDLER EXPAND=FALSE
{
{   The purpose of this request is to establish a procedure that
{ will receive control after a task has called PMP$EXIT or
{ PMP$ABORT but before it is actually terminated by the system.
{ The procedure that has been established will typically
{ perform any cleanup activities that are required before the
{ task actually terminates.
{
{ This task end handler remains in effect until the task
{ terminates or until it is explicitly disestablished.  The
{ lifetime of the end handler is not associated with the lifetime
{ of its caller as in the case of PMP$ESTABLISH_CONDITION_HANDLER.
{
{ An end handler established with this request will only be called
{ after the program executed by the task has completed; it is not
{ involved in the normal condition processing algorithm.  The end
{ handler executes in the ring of the caller that established it.
{
{ When the end handler is called, it may finish by returning or by
{ calling PMP$EXIT or PMP$ABORT; in all cases task termination
{ proceeds.  The task termination status is passed as a parameter
{ to the end handler so that it can determine the condition that
{ caused the task to terminate.
{
{ End handlers established by this procedure are queued according
{ to the execution ring of the caller along with other end
{ handlers established for the same ring.  Within a ring they
{ will be called in the order in which they were established; that
{ is, the end handler that was established first is called first.
{ If end handlers are established in multiple rings, the end
{ handlers in the least privileged rings will be called first.
{ These end handlers are always called if still established at task
{ termination whether the task terminated normally or abnormally.
{
{ Block-exit condition handlers that are still established at
{ task termination time are called before any end handlers are
{ called.
{
{ Files with user FAP's established in the end handler's ring that
{ are left open at task termination will still be open when
{ the end handler is called but will be closed by the system
{ before end handlers for more privileged rings are called.
{
{       PMP$ESTABLISH_END_HANDLER (END_HANDLER, STATUS)
{
{ END_HANDLER: (input) This parameter specifies the
{       task end handler.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$handler_more_privileged
{             pme$handler_nested_proc
{             pme$handler_queue_error
{
*DECK DECK=PMH$ESTABLISH_END_HNDLR_IN_RING EXPAND=FALSE
{
{   The purpose of this request is to establish a procedure that
{ will receive control after a task has called PMP$EXIT or
{ PMP$ABORT but before it is actually terminated by the system.
{ The procedure that has been established will typically
{ perform any cleanup activities that are required before the
{ task actually terminates.
{
{ This task end handler remains in effect until the task
{ terminates or until it is explicitly disestablished.  The
{ lifetime of the end handler is not associated with the lifetime
{ of its caller as in the case of PMP$ESTABLISH_CONDITION_HANDLER.
{
{ An end handler established with this request will only be called
{ after the program executed by the task has completed; it is not
{ involved in the normal condition processing algorithm.  The end
{ handler executes in the ring specified by the ring parameter with
{ which it was established.  The specified ring cannot be more
{ privileged than the ring of the caller.
{
{ When the end handler is called, it may finish by returning or by
{ calling PMP$EXIT or PMP$ABORT; in all cases task termination
{ proceeds.  The task termination status is passed as a parameter to
{ the end handler so that it can determine the condition that
{ caused the task to terminate.
{
{ End handlers established by this procedure are queued according
{ to the ring specified by the caller along with other end
{ handlers established for the same ring.  Within a ring they
{ will be called in the order in which they were established;
{ that is, the end handler that was established first is called
{ first.  If end handlers are established in multiple rings, the
{ end handlers in the least privileged rings will be called first.
{ These end handlers are always called if still established at task
{ termination whether the task terminated normally or abnormally.
{
{ This request differs from PMP$ESTABLISH_END_HANDLER only in that
{ it allows a ring different than the caller's ring to be specified
{ as the ring in which the end handler will execute.
{
{ Block-exit condition handlers that are still established at
{ task termination time are called before any end handlers are
{ called.
{
{ Files with user FAP's established in the end handler's ring that
{ are left open at task termination will still be open when
{ the end handler is called but will be closed by the system
{ before end handlers for more privileged rings are called.
{
{       PMP$ESTABLISH_END_HNDLR_IN_RING (END_HANDLER, RING,
{           STATUS)
{
{ END_HANDLER: (input) This parameter specifies the user's
{       task end handler.
{
{ RING: (input) This parameter specifies the ring in which the
{       task end handler is to be established.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$handler_more_privileged
{             pme$handler_nested_proc
{             pme$handler_queue_error
{
*DECK DECK=PMH$ESTABLISH_SEGMENT_ACCESS EXPAND=FALSE

{
{   The purpose of this request is to associate a file opened for segment
{ access with a previously defined unallocated common block.
{
{   The following assumptions prevail when using this interface:
{
{    1.  The program is responsible for describing the file and its attributes
{        such that the file may be used by other NOS/VE commands.
{
{    2.  The file has already been opened for segment access by the program
{        and the file_identifier from that open has been passed to this
{        request.
{
{    3.  The modes of access specified when opening the file are consistent
{        with the manner in which the common block will be referenced.
{
{    4.  If the file is shared by two or more asynchronous jobs or tasks, it
{        is the responsibility of the program to serialize file access.
{
{    5.  The program is responsible for establishing the size of the file
{        prior to closing it.  The amp$set_segment_eoi interface may be used
{        for this purpose.
{
{
{       PMP$ESTABLISH_SEGMENT_ACCESS (FILE_IDENTIFIER, COMMON_BLOCK,
{         SEGMENT_POINTER, STATUS)
{
{  FILE_IDENTIFIER: (input)  This parameter specifies the file access
{        identifier established when the file to be associated with the common
{        block was opened.
{
{  COMMON_BLOCK: (input)  This parameter specifies the name of a previously
{        defined unallocated common block.  This common block cannot be
{        associated with a file at the time this request is issued.
{
{  SEGMENT_POINTER: (output)  This parameter specifies a segment pointer to
{        the common block/file.  This value is of type ^seq(*).
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              pme$common_file_open
{              pme$common_not_unallocated
{
*DECK DECK=PMH$EXECUTE EXPAND=FALSE

{
{    The purpose of this request is to initiate execution of the
{  specified program as a task.
{
{        PMP$EXECUTE (PROGRAM_DESCRIPTION, PARAMETERS, WAIT, TASK_ID,
{          TASK_STATUS, STATUS)
{
{  PROGRAM_DESCRIPTION: (input) This parameter specifies the description
{        of the program to be executed.
{
{  PARAMETERS: (input) This parameter specifies the parameters to be passed
{        to the task.
{
{  WAIT: (input) This parameter specifies whether the requesting task
{        is to await completion of the executed task or is to execute
{        asynchronously with the executed task.
{
{  TASK_ID: (output) This parameter specifies the system supplied
{        identification of the executed task.  This identification can be
{        used in subsequent requests.
{
{  TASK_STATUS: (output) This parameter specifies the status of the
{        executed task.  For synchronously executed tasks, it is returned
{        after the request has been processed.  For asynchronously
{        executed tasks, it is set to incomplete after the request has been
{        processed and set to complete when the asynchronously executed task
{        terminates.  This implies that the lifetime of the task status
{        variable must be the duration of the asynchronously executed
{        task.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: pme$prog_description_too_small, pme$invalid_list_length,
{                   pme$invalid_file_name, pme$invalid_term_error_level,
{                   pme$invalid_preset_option, pme$invalid_stack_size_option,
{                   pme$map_option_conflict, pme$invalid_wait_parameter
{       IDENTIFIER: 'PM'
{
*DECK DECK=PMH$EXECUTE_JOB_EPILOGS EXPAND=FALSE
{ PURPOSE:
{    The purpose of this request is to direct the execution of the job epilogs
{    during the termination of the Job Monitor task.
{ DESIGN:
{    This procedure is called during Job Monitor task termination after all
{    stack frames have been popped but before calling the procedure
{    PMP$CLEANUP_LOADED_RINGS.  This procedure supervises job epilog processing
{    by setting the variable CLV$PROCESSING_PHASE to specify the next valid
{    epilog to process and making an outward call to the procedure
{    PMP$EXECUTE_EPILOG to execute that epilog.  Before the
{    execution of the job class epilog the following operations will be performed
{    to insure the integrity of the accounting and validation processing:
{
{       Make an outward call to the procedure PMP$MONITOR_LOADED_RING_CLEANUP for
{       each loaded ring
{
{       Call to the procedure BAP$MONITOR_LOADED_RING_CLEANUP for ring 3
{
{       Call to the procedure BAP$MONITOR_TASK_TERM_CLEANUP
{
{       Call the procedure LOP$DELETE_LOADER_LIBRARY_LIST to delete all currently
{       defined libraries
{
{       Call the procedure LOP$DELETE_LINKAGE_TREE to delete all currently defined
{       entry points
{
{       Reset PMV$PROG_OPTIONS_AND_LIBRARIES to specify the default set of program
{       options
{
{       Call procedure BAP$DETACH_ALL_TAPE_FILES
{
{       Call procedure CLP$DELETE_VARIABLES
{
{    This procedure then executes the job_class and system epilogs as necessary,
{    sets the variable CLV$PROCESSING_PHASE to CLC$JOB_END_PHASE, and returns.
*DECK DECK=PMH$EXECUTE_PROCEDURE EXPAND=FALSE
{
{    The purpose of this request is to initiate execution of the specified
{ procedure as a task.
{
{       PMP$EXECUTE_PROCEDURE (STARTING_PROCEDURE, PARAMETERS, CRITICAL_FRAME,
{             TASK_ID, TASK_STATUS, STATUS)
{
{  STARTING_PROCEDURE: (input)  This parameter specifies the procedure at which
{        execution is to begin.
{
{  PARAMETERS: (input)  This parameter specifies the parameters to be passed to
{        the task.
{
{  CRITICAL_FRAME: (input)  This parameter specifies the PVA of the most recent
{        entry on the caller's stack that is also required to be present in the
{        callee.  This stack frame will not be removed from the stack until the
{        callee has terminated.
{
{  TASK_ID: (output)  This parameter specifies the system supplied
{        identification of the executed task.  This identification can be used
{        in subsequent requests.
{
{  TASK_STATUS: (output)  This parameter specifies the status of the executed
{        task.  It is set to incomplete after the request has been processed
{        and set to complete when the asynchronously executed task terminates.
{        This implies that the lifetime of the task status variable must be the
{        duration of the asynchronously executed procedure.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$critical_frame_count_limit
{             pme$invalid_critical_frame
{             pme$invalid_spy_identifier
{             pme$no_available_stacks
{             pme$target_ring_error
{
*DECK DECK=PMH$EXECUTE_PROCEDURE_AS_TASK EXPAND=FALSE

{
{    The purpose of this procedure is to initiate the execution of the
{  specified procedure as a task.
{
{        PMP$EXECUTE_PROCEDURE_AS_TASK (INITIAL_RING, PROCEDURE, PARAMETERS,
{          CRITICAL_FRAME, TASK_ID, TASK_STATUS, STATUS)
{
{  INITIAL_RING: (input) This parameter specifies the initial ring of execution
{        for the procedure.
{
{  PROCEDURE: (input) This parameter specifies the procedure at which execution
{        is to begin.
{
{  PARAMETERS: (input) This parameter specifies the parameters to be passed
{        to the task.
{
{  CRITICAL_FRAME: (input) This parameter specifies the PVA of the most recent
{        entry on the caller's stack that is also required to be present in
{        the callee.  This stack frame will not be removed from the stack
{        until the callee has terminated.
{
{  TASK_ID: (output) This parameter specifies the system supplied
{        identification of the executed task.  This identification can be
{        used in subsequent requests.
{
{  TASK_STATUS: (output) This parameter specifies the status of the
{        asynchronously executed procedure.  It is set to incomplete after
{        the request has been processed and set to complete when the asynchronously
{        executed procedure terminates.  This implies that the lifetime of the task
{        status variable must be the duration of the asynchronously executed
{        procedure.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: pme$no_available_stacks
{
{       IDENTIFIER: 'PM'
{
*DECK DECK=PMH$EXECUTE_TASK EXPAND=FALSE

{
{    The purpose of this request is to initiate execution of the
{  specified program as a task.
{
{        PMP$EXECUTE_TASK (TARGET_RING, PROGRAM_DESCRIPTION, PARAMETERS,
{          COMMAND_FILE, WAIT, CL_TASK, TASK_ID, TASK_STATUS, STATUS)
{
{  TARGET_RING: (input) This parameter is the ring in which the task will
{        execute (target_ring must be >= requestor's ring).
{
{  PROGRAM_DESCRIPTION: (input) This parameter specifies the description
{        of the program to be executed.
{
{  PARAMETERS: (input) This parameter specifies the parameters to be passed
{        to the task.
{
{ COMMAND_FILE:  (input) This parameter specifies a file which becomes the
{       current comand file (i.e.  $COMMAND) within the new task.  This
{       parameter is only meaningful if the task is being executed
{       asynchronously.
{
{  WAIT: (input) This parameter specifies whether the requesting task
{        is to await completion of the executed task or is to execute
{        asynchronously with the executed task.
{
{  CL_TASK: (input) This parameter specifies whether this task is the result
{        of the execution of a Command Language $TASK command.
{
{  TASK_ID: (output) This parameter specifies the system supplied
{        identification of the executed task.  This identification can be
{        used in subsequent requests.
{
{  TASK_STATUS: (output) This parameter specifies the status of the
{        executed task.  For synchronously executed tasks, it is returned
{        after the request has been processed.  For asynchronously
{        executed tasks, it is set to incomplete after the request has been
{        processed and set to complete when the asynchronously executed task
{        terminates.  This implies that the lifetime of the task status
{        variable must be the duration of the asynchronously executed
{        task.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: pme$prog_description_too_small, pme$invalid_list_length,
{                   pme$invalid_file_name, pme$invalid_term_error_level,
{                   pme$invalid_preset_option, pme$invalid_stack_size_option,
{                   pme$map_option_conflict, pme$target_ring_error.
{       IDENTIFIER: 'PM'
{
*DECK DECK=PMH$EXECUTE_WITH_COMMAND_FILE EXPAND=FALSE
{
{    The purpose of this request is to allow execution of the specified
{  program as a task with less privilege (target ring) than the requestor.
{  This request differs from PMP$EXECUTE in that the target ring influences
{  the task's execution ring(s) rather than the requestor's ring, and the
{  task's current command file (i.e. $COMMAND) can be specified.
{
{        PMP$EXECUTE_WITH_COMMAND_FILE (TARGET_RING, PROGRAM_DESCRIPTION,
{          PARAMETERS, COMMAND_FILE, WAIT, TASK_ID, TASK_STATUS, STATUS)
{
{  TARGET_RING: (input) This parameter influences the ring(s) in which the
{        task will execute (target_ring must be >= requestor's ring).
{
{  PROGRAM_DESCRIPTION: (input) This parameter specifies the description
{        of the program to be executed.
{
{  PARAMETERS: (input) This parameter specifies the parameters to be passed
{        to the task.
{
{ COMMAND_FILE: (input)  This parameter specifies a file which becomes the
{       current command file (i.e.  $COMMAND) within the new task.  This
{       parameter is only meaningful if the command being executed is a
{       command utility, or for some other reason references the current
{       command file.  A null or blank string can be used to specify the
{       absence of a command file.
{
{  WAIT: (input) This parameter specifies whether the requesting task
{        is to await completion of the executed task or is to execute
{        asynchronously with the executed task.
{
{  CL_TASK: (input) This parameter specifies whether the task is the
{        result of the execution of a Command Language TASK/TASKEND command.
{
{  TASK_ID: (output) This parameter specifies the system supplied
{        identification of the executed task.  This identification can be
{        used in subsequent requests.
{
{  TASK_STATUS: (output) This parameter specifies the status of the
{        executed task.  For synchronously executed tasks, it is returned
{        after the request has been processed.  For asynchronously
{        executed tasks, it is set to incomplete after the request has been
{        processed and set to complete when the asynchronously executed task
{        terminates.  This implies that the lifetime of the task status
{        variable must be the duration of the asynchronously executed
{        task.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: pme$prog_description_too_small, pme$invalid_list_length,
{                   pme$invalid_file_name, pme$invalid_term_error_level,
{                   pme$invalid_preset_option, pme$invalid_stack_size_option,
{                   pme$map_option_conflict, pme$target_ring_error.
{       IDENTIFIER: 'PM'
{
*DECK DECK=PMH$EXECUTE_WITH_LESS_PRIVILEGE EXPAND=FALSE

{
{    The purpose of this request is to allow execution of the specified
{  program as a task with less privilege (target ring) than the requestor.
{  This request differs from PMP$EXECUTE in that the target ring influences
{  the task's execution ring(s) rather than the requestor's ring.
{
{        PMP$EXECUTE_WITH_LESS_PRIVILEGE (TARGET_RING, PROGRAM_DESCRIPTION,
{          PROGRAM_PARAMETERS, WAIT, CL_TASK, TASK_ID, TASK_STATUS, STATUS)
{
{  TARGET_RING: (input) This parameter influences the ring(s) in which the
{        task will execute (target_ring must be >= requestor's ring).
{
{  PROGRAM_DESCRIPTION: (input) This parameter specifies the description
{        of the program to be executed.
{
{  PROGRAM_PARAMETERS: (input) This parameter specifies the parameters to be
{  passed
{        to the task.
{
{  WAIT: (input) This parameter specifies whether the requesting task
{        is to await completion of the executed task or is to execute
{        asynchronously with the executed task.
{
{  CL_TASK: (input) This parameter specifies whether the task is the
{        result of the execution of a Command Language TASK/TASKEND command.
{
{  TASK_ID: (output) This parameter specifies the system supplied
{        identification of the executed task.  This identification can be
{        used in subsequent requests.
{
{  TASK_STATUS: (output) This parameter specifies the status of the
{        executed task.  For synchronously executed tasks, it is returned
{        after the request has been processed.  For asynchronously
{        executed tasks, it is set to incomplete after the request has been
{        processed and set to complete when the asynchronously executed task
{        terminates.  This implies that the lifetime of the task status
{        variable must be the duration of the asynchronously executed
{        task.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$invalid_file_name
{             pme$invalid_list_length
{             pme$invalid_preset_option
{             pme$invalid_spy_identifier
{             pme$invalid_stack_size_option
{             pme$invalid_term_error_level
{             pme$invalid_wait_parameter
{             pme$map_option_conflict
{             pme$prog_description_too_small
{             pme$target_ring_error
{
*DECK DECK=PMH$EXIT EXPAND=FALSE

{
{    The purpose of this request is to terminate execution of the requesting
{  task either normally or abnormally.  Abnormal termination in this
{  context implies that the requesting task was unable to perform its
{  requested function due to some flaw in the job environment or in the
{  task's input.  This is contrasted with abnormal termination due to an
{  abort, which is attributable to an internal failure of the task.
{    Returning from the starting procedure of the task is equivalent
{  to issuing a PMP$EXIT request passing the status parameter that was
{  provided to the starting procedure.
{
{        PMP$EXIT (STATUS)
{
{  STATUS: (input) This parameter specifies the status to be returned to the
{        caller of the requesting task.
{
*DECK DECK=PMH$EXIT_UNIX_TASK EXPAND=FALSE
{    This request is used by the UNIX kernel to notify NOS/VE that the UNIX
{ environment of the task has been dismantled and that NOS/VE can complete
{ termination of the task.
{
{        PMP$EXIT_UNIX_TASK;
*DECK DECK=PMH$EXPAND_SEGMENT EXPAND=FALSE
{     This request dynamically expands a segment containing a FORTRAN common
{ block, returns a pointer to the expanded area, and sets the end of
{ information
{ to include the expanded area.  The segment is also given the attribute
{ "extensible" so that any subsequent loads of programs will not use the
{ segment.
{
{      PMP$EXPAND_SEGMENT (PVA, LENGTH, STARTING_PVA, STATUS)
{
{    PVA: (input) This parameter specifies an address residing in the segment.
{
{    LENGTH: (input) This parameter specifies the number of bytes to expand
{       the segment.
{
{    STARTING_PVA: (output) This parameter specifies the starting address of
{       the expanded area.
{
{    STATUS: (output) This parameter specifies the request status.
{         CONDITIONS:
{               lle$program_segment_overflow
{               pme$common_block_not_defined
*DECK DECK=PMH$FIND_DEBUG EXPAND=FALSE

{    The purpose of this request is to return a pointer to the debug
{  procedure DBP$DEBUG.  A NIL pointer will be returned if the requestor
{  is executing outside of the call bracket of the procedure.
{
{        PMP$FIND_DEBUG (DEBUG)
{
{  DEBUG: (output) This parameter specifies a procedure pointer to the
{        debug procedure DBP$DEBUG.
{
*DECK DECK=PMH$FIND_ENTRY_POINT_ADDRESS EXPAND=FALSE

{
{   The purpose of this request is to search the program library list for
{ an entry point name and return the kind and address of the entity in
{ which the name is defined.
{
{       PMP$FIND_ENTRY_POINT_ADDRESS (ENTRY_POINT_NAME, ADDRESS, STATUS)
{
{ ENTRY_POINT_NAME: (input) This parameter specifies the name of the entry
{       point name to be found.
{
{ ADDRESS: (output) This parameter specifies the kind and address of the
{       entity in which the entry point is defined.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION: lle$entry_point_not_found, lle$bad_library_member_header,
{                  lle$bad_program_header_ptr, lle$bad_scl_header_ptr,
{                  lle$bad_entry_dictionary_ptr.
{       IDENTIFIER: 'PM'
{
*DECK DECK=PMH$FIND_ENTRY_POINT_IN_LIBRARY EXPAND=FALSE

{
{   The purpose of this request is to search the entry point dictionary of
{ an object library for a specified entry point name, and return the entry
{ point kind and the location of the module that contains it, if it is
{ present in the object library.
{
{       PMP$FIND_ENTRY_POINT_IN_LIBRARY (OBJECT_LIBRARY,
{           ENTRY_POINT_NAME, ADDRESS, STATUS)
{
{ OBJECT_LIBRARY: (input) This parameter specifies the address of the object
{       library to be searched.
{
{ ENTRY_POINT_NAME: (input) This parameter specifies the name of the entry
{       point to be found.
{
{ ADDRESS: (output) This parameter specifies the kind and address of the
{       module, procedure or program description in which the entry point
{       is defined.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION: lle$entry_point_not_found, lle$wrong_library_version,
{                  lle$empty_module_dictionary, lle$bad_module_dictionary_ptr,
{                  lle$empty_entry_dictionary, lle$library_header_missing,
{                  lle$bad_entry_dictionary_ptr, lle$bad_library_member_header,
{                  lle$bad_program_header_ptr, lle$bad_scl_header_ptr.
{       IDENTIFIER: 'PM'
{

*DECK DECK=PMH$FIND_EXECUTING_TASK_XCB EXPAND=FALSE

{    The purpose of this request is to locate the execution_control_block
{  of the executing task.
{
{        PMP$FIND_EXECUTING_TASK_XCB (XCB)
{
{  XCB: (output) This parameter specifies the location of the executing
{        task's execution_control_block.
{
*DECK DECK=PMH$FIND_MODULE_IN_LIBRARY EXPAND=FALSE
{
{   The purpose of this request is to search the module dictionary of
{  an object library for a specified module, and return the
{  address and the location of the module, if it is present
{  in the object library.
{
{     PMP$FIND_MODULE_IN_LIBRARY (NAME, OBJECT_LIBRARY,
{         ADDRESS, STATUS)
{
{  NAME: (input) This parameter specifies the name of the module
{     to be found.
{
{  OBJECT_LIBRARY: (input) This parameter specifies the address of
{              the object library to be searched.
{
{  ADDRESS: (output) This parameter specifies the kind and address
{       of the module.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             lle$bad_library_member_header
{             lle$bad_load_header_ptr
{             lle$bad_module
{             lle$bad_module_dictionary_ptr
{             lle$bad_ppu_header_ptr
{             lle$bad_program_header_ptr
{             lle$bad_scl_header_ptr
{             lle$empty_module_dictionary
{             lle$library_header_missing
{             lle$module_not_found
{             lle$wrong_library_version
{
{

*DECK DECK=PMH$FIND_TASK_TCB EXPAND=FALSE

{    The purpose of this request is to locate the task_control_block
{  of a specified task in the active job.
{
{        PMP$FIND_TASK_TCB (TASK_ID, TCB)
{
{  TASK_ID: (input) This parameter specifies the identity of the task whose
{        task_control_block is to be located.
{
{  TCB: (output) This parameter specifies the location of the identified
{        task's task_control_block.
{
*DECK DECK=PMH$FIND_TASK_XCB EXPAND=FALSE

{    The purpose of this request is to locate the execution_control_block
{  of a specified task in the active job.
{
{        PMP$FIND_TASK_XCB (TASK_ID, XCB)
{
{  TASK_ID: (input) This parameter specifies the identity of the task whose
{        execution_control_block is to be located.
{
{  XCB: (output) This parameter specifies the location of the identified
{        task's execution_control_block.
{
{       WARNING:  This procedure uses a ring 1 interlock. It must not
{         be called by signal handlers (or their subordinates) which
{         may interrupt ring 1 processes.
{
*DECK DECK=PMH$FLAG_ALL_CHILD_TASKS EXPAND=FALSE

{    The purpose of this request is to set a system flag in each child task
{  of the executing task.
{
{        PMP$FLAG_ALL_CHILD_TASKS (FLAG, STATUS)
{
{  FLAG: (input) This parameter specifies the system flag to be set in each
{        child task.
{
{  STATUS: (output) This parameter specifies the request status.
{
{       WARNING:  This procedure uses a ring 1 interlock.  It must not
{         be called by signal handlers (or their subordinates) which
{         may interrupt ring 1 processes.
{
*DECK DECK=PMH$FORK_TASK EXPAND=FALSE
{    The purpose of this request is to create an exact duplicate of the current
{ task.  Both the requesting task and and forked task are identical and resume
{ execution at the same point.  This request is intended for use by the UNIX
{ kernel.
{
{       PMP$FORK_TASK (U_AREA_SOURCE_SEGMENT, U_AREA_DESTINATION_SEGMENT,
{             CHILD_TASK, STATUS);
{
{ U_AREA_SOURCE_SEGMENT: (input)  This is the segment number (in the parent
{       task) of the u-area the parent has created for the child task.
{
{ U_AREA_DESTINATION_SEGMENT: (input)  This is the desired segment number to
{       which the u-area created by the parent task is placed in the child
{       task.
{
{ CHILD_TASK: (output)  This is false if the task is the caller of
{       pmp$fork_task.  This is true if the task is the result of a fork.
{
{ STATUS: (output)  This is the resulting status of the request.  A zero (0)
{       result indicates that the fork attempt was successful.  A non-zero
{       result indicates that the request failed.
*DECK DECK=PMH$FORK_TASK_BOOT EXPAND=FALSE
{    This request is called during task begin for a task that has started due
{ to a pmp$fork_task request.  This request causes the caller and its callers
{ to be delinked from the stack and a linkage made to the stack frame save area
{ for the pmp$fork_task request.
{
{        PMP$FORK_TASK_BOOT;
*DECK DECK=PMH$FORMAT_COMPACT_DATE EXPAND=FALSE

{
{    The purpose of this request is to format a compact date into a user
{  specified format.
{
{        PMP$FORMAT_COMPACT_DATE (DATE_TIME, FORMAT, DATE, STATUS)
{
{  DATE_TIME: (input) The compact date and time from which the date is
{         extracted and formatted.
{
{  FORMAT: (input) This parameter specifies the format in which the date
{        will be returned.  Valid specifications are:
{          osc$month_date : month DD, YYYY
{            example: November 13, 1978
{          osc$mdy_date : MM/DD/YY
{            example: 11/13/78
{          osc$iso_date : YYYY-MM-DD
{            example: 1978-13-11
{          osc$ordinal_date : YYYYDDD
{            example: 1978317
{          osc$dmy_date: DD/MM/YY
{            example: 13/11/78
{          osc$default_date : an installation specified format from the above.
{
{  DATE: (output) This parameter specifies the formatted date.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$invalid_date_format, pme$invalid_day,
{                  pme$invalid_month, pme$invalid_year.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$FORMAT_COMPACT_TIME EXPAND=FALSE

{
{    The purpose of this request is to format a compact time into a user
{  specified format.
{
{        PMP$FORMAT_COMPACT_TIME (DATE_TIME, FORMAT, TIME, STATUS)
{
{  DATE_TIME: (input) The compact date and time from which the time is
{        extracted and formatted.
{
{  FORMAT: (input) This parameter specifies the format in which the time
{        will be returned.  Valid specifications are:
{          osc$ampm_time :  HH:MM AM or PM
{            example:  1:15 PM
{          osc$hms_time : HH:MM:SS
{            example: 13:15:21
{          osc$millisecond_time : HH:MM:SS:MMM
{            example: 13:15:21:453
{          osc$default_time : an installation specified format from the above.

{  TIME: (output) This parameter specifies the formatted time.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$invalid_time_format, pme$invalid_millisecond,
{                  pme$invalid_second, pme$invalid_minute, pme$invalid_hour.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$GENERATE_UNIQUE_NAME EXPAND=FALSE
{
{   The purpose  of  this  request  is  to generate a name that is unique with
{ respect to all CYBER 180 mainframes.  A  name  generated  via  this  request
{ could  be  used  for such things as a local file name, a global file name, a
{ queue name, a volume serial number, or a permanent file set name.
{
{       PMP$GENERATE_UNIQUE_NAME (NAME, STATUS)
{
{ NAME: (output) This parameter specifies the generated unique name.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=PMH$GET_170_OS_TYPE EXPAND=FALSE
{
{    The purpose of this request is to obtain the type of the CYBER 170
{  operating system running concurrently with NOS/VE in dual state.
{
{        PMP$GET_170_OS_TYPE (OS_TYPE, STATUS)
{
{  OS_TYPE: (output) This parameter specifies the type of the CYBER 170
{        operating system.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             none
*DECK DECK=PMH$GET_ACCOUNT_PROJECT EXPAND=FALSE

{ }
{    The purpose of this request is to obtain the account name and project
{ name of the job of which the requesting task is a part.
{ }
{        PMP$GET_ACCOUNT_PROJECT (ACCOUNT, PROJECT, STATUS)
{ }
{  ACCOUNT: (output) This parameter specifies the current account name.
{ }
{  PROJECT: (output) This parameter specifies the current project name.
{ }
{  STATUS: (output) This parameter specifies request status.
{ }
*DECK DECK=PMH$GET_APD_TASK_JOBMODE_STATS EXPAND=FALSE
{
{    The purpose of this request is to obtain the jobmode statistics for the
{ current task.  The jobmode statistics contain the paging statistics used by
{ ANALYZE_PROGRAM_DYNAMICS and the cptime spent in jobmode.
{
{       PMP$GET_APD_TASK_JOBMODE_STATISTICS (JOBMODE_STATISTICS)
{
{ JOBMODE_STATISTICS: (output)  This parameter specifies the jobmode statistics
{       for the current task.
{
{ STATUS: (OUTPUT) This parameter specifies the request status.
{
*DECK DECK=PMH$GET_APPLICATION_INFORMATION EXPAND=FALSE
{}
{   The purpose of this request is to find the module name and application
{ identifier when given a PVA in an executing module.  The module address
{ table is searched for a module whose sections contain the PVA.
{}
{      PMP$GET_APPLICATION_INFORMATION (PVA, APPLICATION_MODULE_NAME,
{        APPLICATION_IDENTIFIER, LIBRARY_PRIVILEGE, STATUS);
{}
{ PVA: (input) This parameter specifies a PVA in an executing
{       module.
{}
{ APPLICATION_MODULE_NAME: (output) This parameter specifies the
{       name of the module that contains the executing code that
{       the PVA points to.
{}
{ APPLICATION_IDENTIFIER: (output) This parameter specifies a
{       name that identifies the module as an application.
{}
{ LIBRARY_PRIVILEGE: (output) This parameter specifies the
{       library_privilege file registration attribute for the module.
{}
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:  PME$PVA_NOT_IN_ANY_MODULE.
{}
*DECK DECK=PMH$GET_BINARY_CPU_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to retrieve various binary data about all
{  of the central processing units in the system.
{
{        PMP$GET_BINARY_CPU_ATTRIBUTES (CPU_ATTRIBUTES, STATUS);
{
{ CPU_ATTRIBUTES: (output) This contains the binary data on the cpus.
{
{ STATUS: (output) This contains the status of the request.
{        CONDITIONS: none.
{
*DECK DECK=PMH$GET_BINARY_DATE_AND_TIME EXPAND=FALSE
{
{    The purpose of this request is to obtain the current date and
{  time in a compact, binary form.
{
{        PMP$GET_BINARY_DATE_AND_TIME (DATE_AND_TIME, STATUS)
{
{  DATE_AND_TIME: (output) This parameter specifies the current date
{        and time.
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=PMH$GET_BINARY_MAINFRAME_ID EXPAND=FALSE
{
{    The purpose of this request is to retrieve the binary representation of
{  the value that uniquely identifies the mainframe.
{
{        PMP$GET_BINARY_MAINFRAME_ID (MAINFRAME_ID, STATUS);
{
{ MAINFRAME_ID: (output) This is the value of the mainframe identifier.
{
{ STATUS: (output) This is the status of the request.
{        CONDITIONS: none.
{
*DECK DECK=PMH$GET_BINARY_PROCESSOR_ID EXPAND=FALSE
{
{    The purpose of this request is to retrieve various binary form data about
{  the central processing unit currently being executed on.
{
{        PMP$GET_BINARY_PROCESSOR_ID (PROCESSOR_ELEMENT_ID, STATUS);
{
{ PROCESSOR_ELEMENT_ID: (output) This contains the binary data about the cpu.
{
{ STATUS: (output) This contains the status of the request.
{        CONDITIONS: none.
{
*DECK DECK=PMH$GET_COMPACT_DATE_TIME EXPAND=FALSE
{
{    The purpose of this request is to obtain the current date and
{  time in a compact form.
{
{        PMP$GET_COMPACT_DATE_TIME (DATE_TIME, STATUS)
{
{  DATE_TIME: (output) This parameter specifies the current date
{        and time.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$computed_year_out_of_range.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$GET_CPU_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to retrieve various human readable data
{  for all the central processing units in the system.
{
{        PMP$GET_CPU_ATTRIBUTES (CPU_ATTRIBUTES, STATUS);
{
{ CPU_ATTRIBUTES: (output) This contains the data on the cpus.
{
{ STATUS: (output) This contains the status of the request.
{        CONDITIONS: none
{
*DECK DECK=PMH$GET_CURRENT_ENVIRONMENT EXPAND=FALSE
{
{    The purpose of this request is to retreive the most recent condition
{ environemnt for the requesting ring.
{
{       PMP$GET_CURRENT_ENVIRONMENT (ENVIRONMENT, ENVIRONMENT_PRESENT, STATUS)
{
{ ENVIRONMENT: (output)  This parameter specifies the current condition
{       environment for the requestor's ring.
{
{ ENVIRONMENT_PRESENT: (output)  This parameter specifies if a condition
{       environment is active for the requestor's ring.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             pme$stack_overwritten.
{
*DECK DECK=PMH$GET_DATE EXPAND=FALSE

{
{    The purpose of this request is to obtain the current date in}
{  a user selected format.}
{
{        PMP$GET_DATE (FORMAT, DATE, STATUS)
{
{  FORMAT: (input) This parameter specifies the format in which the date
{        will be returned.  Valid specifications are:
{          osc$month_date : month DD, YYYY
{            example: November 13, 1978
{          osc$mdy_date : MM/DD/YY
{            example: 11/13/78
{          osc$iso_date : YYYY-MM-DD
{            example: 1978-13-11
{          osc$ordinal_date : YYYYDDD
{            example: 1978317
{          osc$dmy_date : DD/MM/YY
{            example: 13/11/78
{          osc$default_date : an installation specified format from the above.
{
{  DATE: (output) This parameter specifies the current date.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$invalid_date_format.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$GET_DATE_TIME_AT_TIMESTAMP EXPAND=FALSE
{
{    This procedure uses a timestamp obtained during system execution and
{ returns a record containing the compact date and time corresponding to that
{ timestamp.
{
{       PMP$GET_DATE_TIME_AT_TIMESTAMP (TIMESTAMP, DATE_TIME, STATUS)
{
{  TIMESTAMP: (input)  This parameter specifies the timestamp to be converted.
{
{  DATE_TIME: (output)  This parameter specifies the date and time which
{        corresponds with the given timestamp.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$computed_year_out_of_range
{
*DECK DECK=PMH$GET_DAY_OF_WEEK EXPAND=FALSE
{
{   The purpose of this request is to return the current day of the week.
{
{       PMP$GET_DAY_OF_WEEK (DAY_OF_WEEK, STATUS)
{
{ DAY_OF_WEEK: (output)  This parameter specifies the day of the week.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: none
{
*DECK DECK=PMH$GET_DEBUG_ABORT_FILE EXPAND=FALSE
{   The purpose of this request is to determine whether an abort file is
{ specified for the requesting task and to retrieve the abort file name if
{ specified.
{
{       PMP$GET_DEBUG_ABORT_FILE (ABORT_FILE_SPECIFIED, ABORT_FILE)
{
{ ABORT_FILE_SPECIFIED: (output) This parameter specifies whether there is an
{       abort file for the task.
{
{ ABORT_FILE: (output) This parameter specifies the abort file name.
{

*DECK DECK=PMH$GET_DEBUG_ENTRY EXPAND=FALSE
{
{   The purpose of this request is to obtain the values of a previously
{ defined debug entry.
{
{       PMP$GET_DEBUG_ENTRY (DEBUG_ID, DEBUG_CODE, LOW_ADDRESS,
{         HIGH_ADDRESS, STATUS)
{
{ DEBUG_ID: (input) This parameter specifies the debug identifier of a
{       previously defined debug entry from which the values are to be
{       obtained.
{
{ DEBUG_CODE: (output) This parameter specifies the debug code of the
{       debug entry.
{
{ LOW_ADDRESS: (output) This parameter specifies the LOW address value
{       of the debug entry.
{
{ HIGH_ADDRESS: (output) This parameter specifies the HIGH address value
{       of the debug entry.
{
{ STATUS: (output) This parameter specifies the request status.
{      CONDITIONS:
{            pme$undefined_debug_id
{

*DECK DECK=PMH$GET_DEBUG_ENVIRONMENT EXPAND=FALSE
{
{   The purpose of this request is to retrieve and pop the last debug
{ environment stacked.
{
{       PMP$GET_DEBUG_ENVIRONMENT (DEBUG_ENVIRONMENT)
{
{ DEBUG_ENVIRONMENT: (output) This parameter specifies the last debug
{       environment stacked.
{
*DECK DECK=PMH$GET_DEBUG_ID EXPAND=FALSE
{
{   The purpose of this request is to return the debug identifier associated
{ with a debug index.
{
{       PMP$GET_DEBUG_ID (DEBUG_INDEX, DEBUG_ID, STATUS)
{
{ DEBUG_INDEX: (input) This parameter specifies the debug index of a
{       previously defined debug entry.
{
{ DEBUG_ID: (output) This prameter returns the debug identifier associated
{       with the debug index.
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$undefined_debug_index
{

*DECK DECK=PMH$GET_DEBUG_INPUT_FILE EXPAND=FALSE
{    The purpose of this request is to determine whether an debug input file is
{ specified for the requesting task and to retrieve the debug input file name
{ if specified.
{
{       PMP$GET_DEBUG_INPUT_FILE (INPUT_FILE_SPECIFIED, INPUT_FILE)
{
{ INPUT_FILE_SPECIFIED: (output)  This parameter specifies whether there is an
{       debug input file for the task.
{
{ INPUT_FILE: (output)  This parameter specifies the debug input file name.
{
{
*DECK DECK=PMH$GET_DEBUG_OUTPUT_FILE EXPAND=FALSE

{   The purpose of this request is to determine whether an debug output file is
{ specified for the requesting task and to retrieve the debug output file name
{ if specified.
{
{       PMP$GET_DEBUG_OUTPUT_FILE (OUTPUT_FILE_SPECIFIED, OUTPUT_FILE)
{
{ OUTPUT_FILE_SPECIFIED: (output) This parameter specifies whether there is an
{       debug output file for the task.
{
{ OUTPUT_FILE: (output) This parameter specifies the debug output file name.
{

*DECK DECK=PMH$GET_DEFAULT_DATE_TIME_FORM EXPAND=FALSE
{
{    The purpose of this request is to return the system date and time formats
{ as defined by operator command CHANGE_DEFAULT_DATE_FORMAT and
{ CHANGE_DEFAULT_TIME_FORMAT.
{
{       PMP$GET_DEFAULT_DATE_TIME_FORM (DATE_DEFAULT, TIME_DEFAULT);
{
{ DATE_DEFAULT: (output)  This parameter specifies the default date format.
{
{ TIME_DEFAULT: (output)  This parameter specifies the default time format.
{
*DECK DECK=PMH$GET_DELAYED_CONDITION EXPAND=FALSE
{
{    The purpose of this request is retrieve a previously posted delayed
{ condition if one exists.
{
{       PMP$GET_DELAYED_CONDITION (DELAYED_CONDITION, PRESENT_CONDITION,
{             ANOTHER_CONDITION_PRESENT)
{
{ DELAYED_CONDITION: (output)  This parameter specifies the retrieved
{       condition.
{
{ CONDITION_PRESENT: (output)  This parameter specifies if there was a
{       previously posted condition.
{
{ ANOTHER_CONDITION_PRESENT: (output)  This parameter specifies if there is
{       another condition to be retrieved.
{
*DECK DECK=PMH$GET_ENTRY_POINT_DICTIONARY EXPAND=FALSE
{
{   The purpose of this request is to return a pointer to the entry point
{ dictionary on a object library.
{
{       PMP$GET_ENTRY_POINT_DICTIONARY (LIBRARY, ENTRY_POINT_DICTIONARY,
{         STATUS)
{
{ LIBRARY: (input) This parameter specifies the library from which the entry
{       dictionary is to be obtained.
{
{ ENTRY_POINT_DICTIONARY: (output) This parameter specifies the pointer to the
{      entry point dictionary.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$library_heaer_missing
{                  pme$wrong_library_version
{                  pme$bad_entry_dictionary_ptr
{       IDENTIFIER: pmc$program_management_id
{
*DECK DECK=PMH$GET_EXECUTING_TASK_GTID EXPAND=FALSE

{    The purpose of this request is to return the global_task_id of the
{  executing task.
{
{        PMP$GET_EXECUTING_TASK_GTID (GLOBAL_TASK_ID)
{
{  GLOBAL_TASK_ID: (output) This parameter specifies the global_task_id of
{        the executing task.
{
*DECK DECK=PMH$GET_EXECUTING_TASK_GTID_R6 EXPAND=FALSE
{    The purpose of this request is to return the global_task_id of the
{ executing task.  This request is callable out to ring 6.
{
{       PMP$GET_EXECUTING_TASK_GTID_R6 (GLOBAL_TASK_ID)
{
{  GLOBAL_TASK_ID: (output)  This parameter specifies the global_task_id of the
{        executing task.
{
*DECK DECK=PMH$GET_FAMILY_NAMES EXPAND=FALSE
{
{    The purpose of this request is to retrieve a list of all family names that
{  exist on a local mainframe.
{
{        PMP$GET_FAMILY_NAMES (FAMILY_NAMES, NAME_COUNT, STATUS);
{
{ FAMILY_NAME: (output) This is the array of family names.
{
{ NAME_COUNT: (output) This is the number of families that exist on the system.
{
{ STATUS: (output) This is the status of the request.
{      CONDITION: pme$result_array_too_small
{

*DECK DECK=PMH$GET_GLOBAL_TASK_ID EXPAND=FALSE

{    The purpose of this request is to return the global_task_id of an
{  identified task in the active job.
{
{        PMP$GET_GLOBAL_TASK_ID (TASK_ID, GLOBAL_TASK_ID, STATUS)
{
{  TASK_ID: (input) This parameter identifies a task in the active job.
{
{  GLOBAL_TASK_ID: (output) This parameter specifies the global_task_id of
{        the identified task.
{
{  STATUS: (output) This parameter specifies the request status.
{
{       WARNING:  This procedure uses a ring 1 interlock.  It must not
{         be called by signal handlers (or their subordinates) which
{         may interrupt ring 1 processes.
{
*DECK DECK=PMH$GET_JOB_MODE EXPAND=FALSE

{ }
{    The purpose of this request is to obtain the mode of the job.  It
{  allows a task to determine whether it is executing as part of an
{  interactive or batch job.
{ }
{        PMP$GET_JOB_MODE (MODE, STATUS)
{ }
{  MODE: (output) This parameter specifies the mode of the job.
{ }
{  STATUS: (output) This parameter specifies the request status.
{ }
*DECK DECK=PMH$GET_JOB_MONITOR_GTID EXPAND=FALSE
{
{    The purpose of this request is to retrieve the global task id of a job's
{  job monitor task.
{
{        PMP$GET_JOB_MONITOR_GTID (GLOBAL_TASK_ID, STATUS);
{
{ GLOBAL_TASK_ID: (output) This is the global task id of the job monitor task.
{
{ STATUS: (output) This is the status of the request.
{        CONDITIONS: none.
{
*DECK DECK=PMH$GET_JOB_NAMES EXPAND=FALSE

{ }
{    The purpose of this request is to obtain the user and system
{  supplied names of the job of which the currently executing task
{  is a part.
{ }
{        PMP$GET_JOB_NAMES (USER_NAME, NAME, STATUS)
{ }
{  USER_NAME: (output) This parameter specifies the user supplied job
{  name.
{ }
{  NAME: (output) This parameter specifies the system supplied job
{  name.
{ }
{  STATUS: (output) This parameter specifies the request status.
{ }
*DECK DECK=PMH$GET_JOB_TASK_STATISTICS EXPAND=FALSE
{
{    This procedure returns one or more statistics for the current job or task.
{  Statistics which may be requested are the job mode, monitor mode, and total
{  CPU time for the current job and for the current task; and the paging
{  statistics, ready task count, and working set size for the current job.
{
{       PMP$GET_JOB_TASK_STATISTICS (STATISTIC_DATA_P, STATUS)
{
{ STATISTIC_DATA_P: (input, output) This parameter specifies the pointer to the
{       array containing requests for one or more statistics.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=PMH$GET_LEGIBLE_DATE_TIME EXPAND=FALSE
{
{    The purpose of this request is to obtain the current date and
{  time in a legible form.
{
{        PMP$GET_LEGIBLE_DATE_TIME (DATE_FORMAT, DATE, TIME_FORMAT, TIME,
{        STATUS)
{
{  DATE_FORMAT: (input) This parameter specifies the format in which the date
{        will be returned.  Valid specifications are:
{          osc$month_date : month DD, YYYY
{            example: November 13, 1978
{          osc$mdy_date : MM/DD/YY
{            example: 11/13/78
{          osc$iso_date : YYYY-MM-DD
{            example: 1978-13-11
{          osc$ordinal_date : YYYYDDD
{            example: 1978317
{          osc$dmy_date: DD/MM/YY
{            example: 13/11/78
{          osc$default_date : an installation specified format from the above.
{
{  DATE: (output) This parameter specifies the legible date.
{
{  TIME_FORMAT: (input) This parameter specifies the format in which the time
{        will be returned.  Valid specifications are:
{          osc$ampm_time :  HH:MM AM or PM
{            example:  1:15 PM
{          osc$hms_time : HH:MM:SS
{            example: 13:15:21
{          osc$millisecond_time : HH:MM:SS:MMM
{            example: 13:15:21:453
{          osc$default_time : an installation specified format from the above.
{
{  TIME: (output) This parameter specifies the legible time.
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=PMH$GET_LIBRARY_DICTIONARIES EXPAND=FALSE
{
{   The purpose of this request is obtain the library version and pointers to
{ each of the dictionaries on the library.
{
{       PMP$GET_LIBRARY_DICTIONARIES (LIBRARY, DICTIONARIES, STATUS)
{
{ LIBRARY: (input) This parameter specifies the sequence pointer for the
{       library file.
{
{ DICTIONARIES: (output) This parameter specifies the library version and
{       pointers to each of the dictionaries on the library.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             lle$bad_entry_dictionary_ptr
{             lle$bad_module_dictionary_ptr
{             lle$empty_module_dictionary
{             lle$library_header_missing
{             lle$wrong_library_version
{             pme$invalid_sequence_pointer
*DECK DECK=PMH$GET_MAINFRAME_ATTRIBUTES EXPAND=FALSE
{    This request returns information about various mainframe attributes.
{
{       PMH$GET_MAINFRAME_ATTRIBUTES (MAINFRAME_ATTRIBUTES, STATUS)
{
{ MAINFRAME_ATTRIBUTES: (input, output)  This parameter specifies the mainframe
{       attributes to get via setting the key field of the array elements to
{       designate the desired attribute.  The attribute values are returned in
{       the corresponding array elements.
{
{ STATUS: (OUTPUT)  This parameter specifies the standard status parameter.
{      CONDITION:
{          pme$invalid_attribute_key.
*DECK DECK=PMH$GET_MAINFRAME_ID EXPAND=FALSE
{
{    The purpose of this request is to retrieve the value that uniquely
{  identifies the mainframe.
{
{        PMP$GET_MAINFRAME_ID (MAINFRAME_ID, STATUS);
{
{ MAINFRAME_ID: (output) This is the unique identifier of the mainframe.
{
{ STATUS: (output) This is the status of the request.
{        CONDITIONS: none.
{
*DECK DECK=PMH$GET_MICROSECOND_CLOCK EXPAND=FALSE

{
{    The purpose of this request is to obtain the current value of the
{  microsecond clock.  Successive requests are guaranteed to return
{  different values.
{
{        PMP$GET_MICROSECOND_CLOCK (MICROSECOND_CLOCK, STATUS)
{
{  MICROSECOND_CLOCK: (output) This parameter specifies the current value
{        of the microsecond clock.
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=PMH$GET_OS_BUILD_LEVEL EXPAND=FALSE
{
{    The purpose of this request is to get the build level (in character
{ format) of the operating system currently installed.
{
{       PMP$GET_OS_BUILD_LEVEL (BUILD_LEVEL, STATUS)
{
{  BUILD_LEVEL: (output)  This parameter specifies the current build level.
{
{  STATUS: (output)  This parameter specifies the request status.
{     CONDITIONS:
{        NONE
*DECK DECK=PMH$GET_OS_VERSION EXPAND=FALSE

{ }
{    The purpose of this request is to obtain the name and version
{  number of the operating system currently controlling the execution
{  in character format.
{ }
{        PMP$GET_OS_VERSION (VERSION, STATUS)
{ }
{  VERSION: (output) This parameter specifies the operating system name
{        and version.
{ }
{  STATUS: (output) This parameter specifies the request status.
{ }
*DECK DECK=PMH$GET_PAGE_SIZE EXPAND=FALSE
{
{    The purpose of this request is to retrieve the page size being used on
{  the mainframe.
{
{        PMP$GET_PAGE_SIZE (PAGE_SIZE, STATUS);
{
{ PAGE_SIZE: (output) This is the page size used on the mainframe.
{
{ STATUS: (output) This is the status of the request.
{        CONDITIONS: none.
{
*DECK DECK=PMH$GET_PARENT_CALLING_RING EXPAND=FALSE


{
{    The purpose of this request is to allow the calling task to determine
{  the execution ring of its parent task.
{
{       PMP$GET_PARENT_CALLING_RING (RING, STATUS)
{
{  RING: (output)  This parameter specifies the execution ring of the caller's
{        parent task.
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=PMH$GET_PARENT_TASK_ID EXPAND=FALSE
{
{   The purpose of this request is to return the task id of the parent of
{ the specified task.  An exception is returned if the specified task does
{ not exist or the specified task has no parent (i.e. the job monitor task).
{
{       PMP$GET_PARENT_TASK_ID (CHILD_TASK_ID, PARENT_TASK_ID, STATUS)
{
{ CHILD_TASK_ID: (input) This parameter specifies the task id of the child
{       whose parent's task id is to be returned.
{
{ PARENT_TASK_ID: (output) This parameter specifies the task id of the
{       child's parent.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$task_id_not_found
{             pme$task_has_no_parent
{
*DECK DECK=PMH$GET_PROCESSOR_ATTRIBUTES EXPAND=FALSE

{}
{    The purpose of this request is to obtain the attributes of the}
{  the central processor.}
{ }
{        PMP$GET_PROCESSOR_ATTRIBUTES (ATTRIBUTES, STATUS)}
{ }
{  ATTRIBUTES: (output) This parameter specifies the attributes of}
{        the processor on which the request was made.}
{ }
{  STATUS: (output) This parameter specifies the request status.}
{}
*DECK DECK=PMH$GET_PROCESSOR_ID EXPAND=FALSE
{
{    The purpose of this request is to retrieve various human readable data
{  about the central processing unit being executed on.
{
{        PMP$GET_PROCESSOR_ID (MODEL_TYPE, MODEL_NUMBER, SERIAL_NUMBER, STATUS);
{
{ MODEL_TYPE: (output) This contains the model type of the cpu.
{
{ MODEL_NUMBER: (output) This contains the model number of the cpu.
{
{ SERIAL_NUMBER: (output) This contains the serial number of the cpu.
{
{ STATUS: (output) This contains the status of the request.
{        CONDITIONS: none.
{
*DECK DECK=PMH$GET_PROGRAM_DESCRIPTION EXPAND=FALSE

{
{    The purpose of this request is to obtain the program description
{  used to execute the requesting task.  This request allows a task to
{  execute subsequent tasks using a similar program description.
{
{        PMP$GET_PROGRAM_DESCRIPTION (PROGRAM_DESCRIPTION, STATUS)
{
{  PROGRAM_DESCRIPTION: (output) This parameter specifies the program
{        description used to execute the requesting task.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: PME$PROG_DESCRIPTION_SIZE_ERROR
{
*DECK DECK=PMH$GET_PROGRAM_SIZE EXPAND=FALSE

{
{   The purpose of this request is to return the sizes of the object file
{ list, module list and library list of the program description of the
{ requesting task.  This allows the allocation of a program description
{ variable of the appropriate size for subsequent PMP$GET_PROGRAM_DESCRIPTION
{ requests.
{
{       PMP$GET_PROGRAM_SIZE (NUMBER_OF_OBJECT_FILES, NUMBER_OF_MODULES,
{         NUMBER_OF_LIBRARIES, STATUS)
{
{ NUMBER_OF_OBJECT_FILES: (output) This parameter specifies the number of
{       object files in the program description.
{
{ NUMBER_OF_MODULES: (output) This parameter specifies the number of
{       modules in the program description.
{
{ NUMBER_OF_LIBRARIES: (output) This parameter specifies the number of
{       libraries in the program description.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: NONE
{
*DECK DECK=PMH$GET_PROGRAM_SIZE_IN_BYTES EXPAND=FALSE
{
{   The purpose of this request is to return the size of the
{ program description for the requesting task.  This allows the
{ allocation of a program description variable of the appropriate
{ size for subsequent PMP$GET_PROGRAM_DESCRIPTION requests.
{
{       PMP$GET_PROGRAM_SIZE_IN_BYTES (PROGRAM_SIZE, STATUS)
{
{ PROGRAM_SIZE: (output) This parameter specifies the size of the
{       program description in bytes.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: NONE
{
*DECK DECK=PMH$GET_QUEUE_LIMITS EXPAND=FALSE

{ }
{    The purpose of this request is to determine the job local queue
{  limits for this job.
{ }
{        PMP$GET_QUEUE_LIMITS (QUEUE_LIMITS, STATUS)
{ }
{  QUEUE_LIMITS: (output) This parameter specifies limits record.
{ }
{  STATUS: (output) This parameter specifies the request status.
{ }
*DECK DECK=PMH$GET_SRUS EXPAND=FALSE

{ }
{    The purpose of this request is to obtain the current number of
{  system resource units presently accrued by the job of which the
{  requesting task is a part.
{ }
{        PMP$GET_SRUS (SRUS, STATUS)
{ }
{  SRUS: (output) This parameter specifies the current SRU usage.
{ }
{  STATUS: (output) This parameter specifies the request status.
{ }
*DECK DECK=PMH$GET_SYSTEM_TIME EXPAND=FALSE
{
{    The purpose of this request is to obtain the numerical values for the
{ current time, date, and free running clock.
{
{       PMP$GET_SYSTEM_TIME (TIME, STATUS)
{
{ TIME: (output)  This parameter specifies the current system time.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=PMH$GET_TASK_CP_TIME EXPAND=FALSE

{
{   The purpose of this request is to obtain the amount of central
{ processor (CP) task and monitor time that the requesting task has used
{ since it started executing.  Successive requests are guaranteed to return
{ different values.
{
{       PMP$GET_TASK_CP_TIME (CP_TIME, STATUS)
{
{ CP_TIME: (output) This parameter specifies the amount of CP time
{       in microseconds spent in job mode and monitor mode.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=PMH$GET_TASK_ID EXPAND=FALSE

{ }
{   The purpose of this request is to obtain the system assigned task
{ identifier of the requesting task.
{ }
{       PMP$GET_TASK_ID (TASK_ID, STATUS)
{ }
{ TASK_ID: (output) This parameter specifies the task identifier.
{ }
{ STATUS: (output) This parameter specifies the request status.
*DECK DECK=PMH$GET_TASK_JOBMODE_STATISTICS EXPAND=FALSE
{
{    The purpose of this request is to obtain the jobmode statistics for the
{ current task.  The jobmode statistics contain the paging statistics and the
{ cptime spent in jobmode.
{
{       PMP$GET_TASK_JOBMODE_STATISTICS (JOBMODE_STATISTICS, STATUS)
{
{ JOBMODE_STATISTICS: (output)  This parameter specifies the jobmode statistics
{       for the current task.
{
{ STATUS: (OUTPUT) This parameter specifies the request status.
{
*DECK DECK=PMH$GET_TERMINATION_STATUS EXPAND=FALSE

{
{   The purpose of this request is to obtain the status of a terminating
{ task.
{
{       PMP$GET_TERMINATION_STATUS (TERMINATION_STATUS)
{
{ TERMINATION_STATUS: (output) this parameter specifies the terminating task's
{       status.
{

*DECK DECK=PMH$GET_TIME EXPAND=FALSE

{
{    The purpose of this request is to obtain the current time of day
{  in a user selected format.
{
{        PMP$GET_TIME (FORMAT, TIME, STATUS)
{
{  FORMAT: (input) This parameter specifies the format in which the time
{        will be returned.  Valid specifications are:
{          osc$ampm_time :  HH:MM AM or PM
{            example:  1:15 PM
{          osc$hms_time : HH:MM:SS
{            example: 13:15:21
{          osc$millisecond_time : HH:MM:SS:MMM
{            example: 13:15:21:453
{          osc$default_time : an installation specified format from the above.
{
{  TIME: (output) This parameter specifies the current time.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$invalid_time_format.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$GET_TIME_ZONE EXPAND=FALSE
{
{   The purpose of this request is to return the time zone currently defined
{ for the job.  Requests that return dates and times do so relative to this
{ time zone.
{
{       PMP$GET_TIME_ZONE (TIME_ZONE, STATUS)
{
{ TIME_ZONE: (output)  This parameter specifies the time zone.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: none
{
*DECK DECK=PMH$GET_UNIQUE_NAME EXPAND=FALSE
{
{    The purpose of this request is to return a unique name that is unique
{  within the scope of all NOS/VE mainframes and systems.
{
{        PMP$GET_UNIQUE_NAME (NAME, STATUS);
{
{ NAME: (output) This is the unique name generated.
{
{ STATUS: (output) This is the status of the request.
{    CONDITIONS:
{        none.
{
*DECK DECK=PMH$GET_UNIVERSAL_DATE_TIME EXPAND=FALSE
{
{   The purpose of this request is to get the current "universal" date and
{ time.  The "universal" time zone is that of Greenwich, England, often called
{ Greenwich Mean Time.
{
{       PMP$GET_UNIVERSAL_DATE_TIME (UNIVERSAL_DATE_TIME, STATUS)
{
{ UNIVERSAL_DATE_TIME: (output)  This parameter specifies the universal
{       date and time.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS: pme$compute_year_out_of_range
{
*DECK DECK=PMH$GET_USER_IDENTIFICATION EXPAND=FALSE

{ }
{    The purpose of this request is to obtain the identification of the
{  user on whose behalf the requesting task is executing.
{ }
{        PMP$GET_USER_IDENTIFICATION (IDENTIFICATION, STATUS)
{ }
{  IDENTIFICATION: (output) This parameter specifies the family name
{        and user name.
{ }
{  STATUS: (output) This parameter specifies the request status.
{ }
*DECK DECK=PMH$INHIBIT_SYSTEM_CONDITIONS EXPAND=FALSE

{   The purpose of this request is to inhibit any of the following system
{ conditions from arising in the requesting block and its subordinates:
{      pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
{      pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
{      pmc$arithmetic_significance, pmc$invalid_bdp_data.
{
{   NOTE: superfluous conditions may arise in the requestor's immediate superior
{         if the inhibited conditions are not re-enabled prior to exiting the
{         requestor.  All system conditions, except pmc$fp_significance_loss,
{         are enabled before the starting procedure executes.
{
{       PMP$INHIBIT_SYSTEM_CONDITIONS (CONDITIONS, STATUS)
{
{ CONDITIONS: (input) This parameter specifies the conditions to be inhibited.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$unselectable_condition.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$INITIALIZE_CPU_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to determine the cpu attributes of the
{  system.  This request is called during system deadstart.
{
{        PMP$INITIALIZE_CPU_ATTRIBUTES (STATUS);
{
{ STATUS: (output) This contains the status of the request.
{
*DECK DECK=PMH$INITIAL_DEBUG_MODE_ON EXPAND=FALSE
{   The purpose of this procedure is to return the initial setting of the task
{ debug mode for the requesting task.
{
{       PMP$INITIAL_DEBUG_MODE_ON (INITIAL_DEBUG_MODE_ON, STATUS)
{
{ INITIAL_DEBUG_MODE_ON: (output) This parameter specifies the initial setting
{       of the task debug mode.
{
{ STATUS: (output) This parameter specifies the request status.
{      CONDITIONS:
{            none
*DECK DECK=PMH$JOB_DEBUG_RING EXPAND=FALSE

{
{   The purpose of this request is to return the current value of the
{ job debug ring.
{
{       PMP$JOB_DEBUG_RING : DEBUG_RING
{
{ DEBUG_RING: (output) This function evaluates to the current job debug ring.
{
*DECK DECK=PMH$KILL_TASK_FLAG_HANDLER EXPAND=FALSE
{    The purpose of this request is to "kill" a task.  The act of killing a
{ task may damage the task's environment such that block exit handlers are not
{ activated, FAP's are not called, and task end handlers are not activated.
{ This can result in cleanup not being performed by the task which may have
{ many ramifications.  If a task has child tasks its children are killed first.
{
{    This request is incremental.  It causes the task to take another step
{ towards termination.
{
{       PMP$KILL_TASK_FLAG_HANDLER (FLAG_ID);
{
{ FLAG_ID: (input)  This is the flag identifier of the flag sent to the
{       handler.
*DECK DECK=PMH$LOAD EXPAND=FALSE

{
{    The purpose of this request is to return the address of a specified
{  XDCLed name in the requesting task.
{
{  IF the XDCLed name is defined, its address will be simply returned.
{
{  If the XDCLed name is not yet defined in the requesting task, it will
{  be loaded dynamically from the the program library list and the address
{  assigned to it returned.
{
{  IF the XDCLed name cannot be located in any of the libraries currently
{  present in the task's program library list, any libraries added to the
{  job library list in the program attributes of the job since the last
{  loader request will be added to the task's library list.  These libraries
{  will then be searched for the XDCLed name.  IF the XDCLed name is found,
{  it will be loaded into the requesting task and its address will be
{  returned.
{
{        PMP$LOAD (NAME, KIND, ADDRESS, STATUS)
{
{  NAME: (input) This parameter specifies the XDCLed name whose address is to be
{        returned.
{
{  KIND: (input) This parameter specifies the kind of address to be returned.
{
{  ADDRESS: (output) This parameter specifies the kind of address being
{        returned and the address assigned to the NAME parameter.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: lle$entry_point_not_found, lle$term_error_level_exceeded,
{                   lle$insufficient_memory_to_load,
{                   lle$premature_load_termination, lle$loader_malfunctioned.
{       IDENTIFIER: 'LL'
{
*DECK DECK=PMH$LOAD_DEBUG_PROCEDURES EXPAND=FALSE

{    The purpose of this request is to initiate loading of the procedures
{  which constitute the interface to a debug facility.
{
{        PMP$LOAD_DEBUG_PROCEDURES (STATUS)
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=PMH$LOAD_ENTRY_POINT EXPAND=FALSE
{
{    The purpose of this request is to dynamically satisfy a reference
{  to an entry point from a specified protection environment.  The reference
{  will be satisfied by a previously_loaded entry point if possible;
{  otherwise the library list will be searched for an appropriate
{  module to load.
{
{        PMP$LOAD_ENTRY_POINT (NAME, REFERENCE_RING, REFERENCE_GLOBAL_KEY,
{          KIND, ADDRESS, STATUS)
{
{  NAME: (input) This parameter specifies the name of entry point being
{       referenced.
{
{  REFERENCE_RING: (input) This parameter specifies the ring of the
{       protection environment from which the entry point is being referenced.
{
{  REFERENCE_GLOBAL_KEY: (input) This parameter specifies the global_key
{       of the protection environment from which the entry point is being
{       referenced.
{
{  KIND: (input) This parameter specifies the kind of address to be
{        returned.
{
{  ADDRESS: (output) This parameter specifies the kind of address
{        being returned and the address assigned to 'NAME'.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             lle$entry_point_not_found
{             lle$entry_point_unaligned
{             lle$loader_stopped
*DECK DECK=PMH$LOAD_FROM_LIBRARY EXPAND=FALSE

{
{    The purpose of this request is to return the address of the specified
{  XDCLed name in the requesting task.  If the XDCLed name is not yet
{  defined in the requesting task, it will be loaded dynamically from the
{  library specified on the request and the address assigned to it returned.
{  If the XDCLed name is defined, the address will simply be returned.
{    Any unsatisfied externals created as the result of loading caused by
{  this request will be satisfied by searching the program library list.
{  The library specified on the request is not included in the program
{  library list and therefore will not be searched when satisfying externals.
{    The program attributes in effect at task initiation time remain in
{  in effect during any dynamic loading performed by this request.
{
{        PMP$LOAD_FROM_LIBRARY (NAME, RING, GLOBAL_KEY, KIND, LIBRARY,
{                LIBRARY_NAME, ADDRESS, STATUS)
{
{  NAME: (input) This parameter specifies the XDCLed name whose address is to
{        be returned.
{
{  RING: (input) This parameter specifies the ring in which the module
{        containing the XDCLed  name is to be loaded.
{
{  GLOBAL_KEY: (input) This parameter specifies the global key in which
{        the module containing the XDCLed name is to be loaded.
{
{  KIND: (input) This parameter specifies the kind of address to be returned.
{
{  LIBRARY: (input) This parameter specifies the library from which the
{        module containing the XDCLed name is to be loaded, if not already
{        defined in the requesting task.
{
{  LIBRARY_NAME: (input) This parameter specifies the name of the library to
{        be searched.  It is used solely for error diagnostic purposes.
{        No attempt is made to verify that the LIBRARY parameter refers to
{        a file of this name.
{
{  ADDRESS: (output) This parameter specifies the kind of address being
{        returned and the address assigned to the NAME parameter.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS: lle$entry_point_not_found, lle$term_error_level_exceeded,
{                    lle$insufficient_memory_to_load,
{                    lle$premature_load_termination, lle$loader_malfunctioned
{
*DECK DECK=PMH$LOAD_MODULE_FROM_LIBRARY EXPAND=FALSE


{
{    The purpose of this request is to return the address of the specified
{  XDCLed name in the requesting task.  If the XDCLed name is not yet
{  defined in the requesting task, the library specified in the request will
{  be entered at the head of the task's library list and then the library
{  list will be searched  for the XDCLed name.  The first module found in this
{  search that contains the XDCLed name will be loaded and the address returned.
{
{  If the XDCLed name is defined, the address will simply be returned.
{
{        PMP$LOAD_MODULE_FROM_LIBRARY (NAME, REFERENCE_RING, KIND, LIBRARY, LOADED_RING,
{                CALL_BRACKET_RING, ADDRESS, STATUS)
{
{  NAME: (input) This parameter specifies the XDCLed name whose address is to
{        be returned.
{
{  REFERENCE_RING: (input) This parameter specifies the ring from which the XDCLed name
{        will be referenced.
{
{  KIND: (input) This parameter specifies the kind of address to be returned.
{
{  LIBRARY: (input) This parameter specifies the path name of the library to
{        be searched.
{
{  LOADED_RING: (output) This parameter specifies the ring in which the module
{        containing the XDCLed name was loaded.
{
{  CALL_BRACKET_RING: (output) This parameter specifies the call bracket for the
{        XDCLed name.
{
{  ADDRESS: (output) This parameter specifies the kind of address being
{        returned and the address assigned to the NAME parameter.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS: lle$entry_point_not_found, lle$term_error_level_exceeded,
{                    lle$insufficient_memory_to_load,
{                    lle$premature_load_termination, lle$loader_malfunctioned
{
*DECK DECK=PMH$LOG EXPAND=FALSE
{
{   The purpose of this request is to put a message into the current
{ JOB log.
{
{       PMP$LOG ( TEXT, STATUS )
{
{ TEXT: (input) This parameter specifies the text of the message.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$logging_not_yet_active.
{                  pme$job_log_no_longer_active.
{
{       IDENTIFIER: pmc$external_log_management_id.
{
*DECK DECK=PMH$LOG_ASCII EXPAND=FALSE
{
{   The purpose of this request is to place a message into an ASCII
{ log(s) (to be used by System programs not the normal user).
{
{       PMP$LOG_ASCII ( TEXT, LOG, ORIGIN, STATUS )
{
{ TEXT: (input) This parameter specifies the text of the message.
{
{ LOG: (input) This parameter specifies which log(s) is to receive
{       the message.
{
{ ORIGIN: (input) This parameter specifies the type of
{       originator of the message.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:  pme$logging_not_yet_active,
{                   pme$cannot_write_in_system_log.
{
{       IDENTIFIER: pmc$external_log_management_id.
{
*DECK DECK=PMH$LONG_TERM_WAIT EXPAND=FALSE

{
{   The purpose of this request is to relinquish control of the system
{ waiting for an event which may require an exceedingly long period
{ of time to occur.  An event occurs when a signal or system flag is
{ received, the task is made ready via pmp$ready_task, or the time
{ (requested_ms) expires.
{
{   If the task is waiting for a specific signal or system flag, the
{ pmp$long_term_wait must be issued from a ring >= the bottom of the
{ execution bracket of the handler of the signal or flag.  Further the
{ signal or flag must be able to preempt pmp$long_term_wait - currently
{ all signals and flags preempt a long term wait.
{
{       PMP$LONG_TERM_WAIT (REQUESTED_MS, EXPECTED_MS)
{
{ REQUESTED_MS: (input) This parameter specifies the maximum time
{       (in milliseconds) before the task will become a candidate
{       for execution.
{ EXPECTED_MS: (input) This parameter specifies the amount of time
{       (in milliseconds) that the caller expects to wait before
{       an event occurs to make the task ready.
{
*DECK DECK=PMH$MANAGE_SENSE_SWITCHES EXPAND=FALSE

{ }
{    The purpose of this request is to allow the software maintained
{  job local 'sense switches' to be set, changed or interrogated.
{ }
{        PMP$MANAGE_SENSE_SWITCHES (ON, OFF, CURRENT, STATUS)
{ }
{  ON: (input) This parameter specifies the 'sense switches' to be
{        set.  The results of setting and clearing the same switch
{        on a single command are undefined.
{ }
{  OFF: (input) This parameter specifies the 'sense switches' to be
{        cleared.  The results of setting and clearing the same switch
{        on a single command are undefined.
{ }
{  CURRENT: (output) This parameter specifies the switch settings
{        resulting from the processing of this request.  By specifying
{        empty sets for the ON and OFF parameters, this request can be
{        used to interrogate the current 'sense switch' settings.
{ }
{  STATUS: (output) This parameter specifies the request status.
{ }
*DECK DECK=PMH$MODIFY_DEBUG_ENTRY EXPAND=FALSE
{
{   The purpose of this request is to modify the contents of a
{ previously defined debug entry.  Each value in the debug entry is
{ changed.
{
{       PMP$MODIFY_DEBUG_ENTRY (DEBUG_ID, DEBUG_CODE, LOW_ADDRESS,
{         HIGH_ADDRESS, STATUS)
{
{ DEBUG_ID: (input) This parameter specifies the debug identifier of
{       the debug entry to be modified.
{
{ DEBUG_CODE: (input) This parameter specifies the new debug codes of
{       the debug entry.
{
{ LOW_ADDRESS: (input) This parameter specifies the new LOW address of
{      the debug entry.
{
{ HIGH_ADDRESS: (input) This parameter specifies the new HIGH address of
{      the debug entry.
{
{ STATUS: (output) This parameter specifies the request status.
{      CONDITIONS:
{            pme$address_segments_not_equal
{            pme$empty_debug_code
{            pme$invalid_access
{            pme$low_addr_greater_than_high
{            pme$undefined_debug_id
{
*DECK DECK=PMH$OPEN_COMMON_BLOCK_FILE EXPAND=FALSE
{
{    The purpose of this request is to open a file for segment access and
{  associate it with a previously defined unallocated common block.
{
{        PMP$OPEN_COMMON_BLOCK_FILE (FILE, COMMON_BLOCK, SEGMENT_POINTER,
{          STATUS)
{
{  FILE: (input) This paramener specifies the path name of the file to be
{        opened.  The value specified will be evaluated by this request as
{        an SCL <file expression>.
{
{  COMMON_BLOCK: (input) This parameter specifies the name of a previously
{        defined unallocated common block.  This common block cannot be
{        associated with a file at the time this request is issued.
{
{  SEGMENT_POINTER: (output) This parameter specifies a segment pointer to
{        the common block/file.
{
{  STATUS: (output) This parameter specifies the request status.
{        CONDITIONS:
{              pme$common_file_open
{              pme$common_not_unallocated
{
*DECK DECK=PMH$OPEN_OBJECT_LIBRARY EXPAND=FALSE
{
{    The purpose of this request is to open an object library and verify the
{ header contents and return the address and the file identifier of the object
{ library.
{
{       PMP$OPEN_OBJECT_LIBRARY (FILE_NAME, FILE_IDENTIFIER, OBJECT_LIBRARY,
{             STATUS)
{
{  FILE_NAME: (input)  This parameter specifies the file name of the object
{        library.
{
{  FILE_IDENTIFIER: (output)  This parameter specifies the file identifer of
{        the object library.
{
{  OBJECT_LIBRARY: (output)  This parameter specifies the address of the object
{        library.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             lle$empty_load_file
{             lle$file_not_load_file
{
{
*DECK DECK=PMH$POP_INHIBIT_TERMINATION EXPAND=FALSE
{
{    This request decrements a count of the number of times task termination
{ has been inhibited.  If this count is decremented to zero and the task
{ has been requested to terminate, then pmp$abort will be called.  If the
{ count was zero, the request will be ignored.  This request can only be
{ called from ring 4.
{
{       PMP$POP_INHIBIT_TERMINATION ();
*DECK DECK=PMH$POP_TASK_DEBUG_MODE EXPAND=FALSE
{
{    The purpose of this request is to remove the most recently stacked setting
{ of task debug mode established via a pmp$push_task_debug_mode request.
{
{       PMP$POP_TASK_DEBUG_MODE (STATUS)
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{            none
{
*DECK DECK=PMH$POSITION_OBJECT_LIBRARY EXPAND=FALSE
{
{   The purpose of this request is to position an object library to a
{ relative offset within the object library.
{
{       PMP$POSITION_OBJECT_LIBRARY (OBJECT_LIBRARY, OFFSET, VALID_POSITION)
{
{ OBJECT_LIBRARY: (input, output) This parameter specifies the object library
{       to be positioned.
{
{ OFFSET: (input) This parameter specifies the relative offset to which the
{      object library is to be positioned.
{
{ VALID_POSITION: (output) This parameter specifies the request status.
*DECK DECK=PMH$POST_DEBUG_ENVIRONMENT EXPAND=FALSE
{
{   The purpose of this request is to stack the current debug environment.
{
{       PMP$POST_DEBUG_ENVIRONMENT (DEBUG_ENVIRONMENT)
{
{ DEBUG_ENVIRONMENT: (input) This parameter specifies the debug environment
{       to be stacked.
{
*DECK DECK=PMH$POST_DELAYED_CONDITION EXPAND=FALSE
{
{    The purpose of this request is to post a delayed condition for later
{ retrieval.
{
{       PMP$POST_DELAYED_CONDITION (DELAYED_CONDITION, STATUS)
{
{ DELAYED_CONDITION: (input)  This parameter specifies the condition to post.
{
{ STATUS: (output) This parameter specifies the request outcome.
{
*DECK DECK=PMH$PURGE_INSTRUCTION_STACK EXPAND=FALSE
{
{    The purpose of this request is to ensure that a CALLSEG instruction is
{ executed after code modification, in order to guarantee that code
{ modification works.
{
{    PMP$PURGE_INSTRUCTION_STACK
{
*DECK DECK=PMH$PUSH_INHIBIT_TERMINATION EXPAND=FALSE
{
{    The purpose of this request is to prevent the task from being terminated
{ when it is executing in a critical section.  The request is only available
{ to routines in ring 4.  The request increments a count of the number of
{ times task termination has been inhibited.  As long as this count is non
{ zero, the task cannot be terminated.  The matching request pmp$pop_inhibit_
{ termination decrements this count and when it returns to zero, any pending
{ task termination requests will be honored.
{
{    If this is the first inhibit request and the stack frame is exited without
{ making the call to pmp$pop_inhibit_termination to reset the count to zero,
{ then the task will be aborted with pmp$abort.
{
{       PMP$PUSH_INHIBIT_TERMINATION ();
*DECK DECK=PMH$PUSH_TASK_DEBUG_MODE EXPAND=FALSE
{
{  The purpose of this request is to put a task into or take it out of
{ debug mode and stack this setting on a last in, first out basis.
{
{       PMP$PUSH_TASK_DEBUG_MODE (DEBUG_MODE, STATUS)
{
{ DEBUG_MODE: (input) This parameter specifies the debug mode in which
{       the task is to be placed.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             lle$entry_point_not_found
{             lle$entry_point_unaligned
{             lle$loader_stopped
*DECK DECK=PMH$READY_TASK EXPAND=FALSE

{
{   The purpose of this request is to make another task a candidate for
{ execution.  The other task must be known, otherwise, the request
{ returns abnormal status.
{
{       PMP$READY_TASK (TASK, STATUS)
{
{ TASK: (input) This parameter specifies the task to be made ready.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$unknown_recipient_task
{
*DECK DECK=PMH$READY_TASK_AND_WAIT EXPAND=FALSE
{
{    The purpose of this request is to make a selected task ready, and to give
{ up control of the CPU by the currently executing task.  The calling task is
{ put into WAIT, waiting for an event to occur.
{
{    PMP$READY_TASK_AND WAIT (GLOBAL_TASKID, REQUESTED_MS, EXPECTED_MS, STATUS)
{
{    GLOBAL_TASKID:  (INPUT) This parameter specifies the task which is to be
{          made ready.
{
{    REQUESTED_MS:  (INPUT) This parameter specifies the maximum amount of time
{          (in milliseconds) before the task will become a candidate for
{          execution.
{
{    EXPECTED_MS:  (INPUT) This parameter specifies the amount of time (in
{          milliseconds) that the caller expects to wait before an event occurs
{          to make the task ready.
{
{    STATUS: (OUTPUT) This parameter specifies the request status.
{       CONDITIONS:
{             pme$insufficient_privilege
{             pme$unknown_recipient_task
*DECK DECK=PMH$RECEIVE_FROM_QUEUE EXPAND=FALSE

{
{    The purpose of this request is to receive an item from a queue.
{
{        PMP$RECEIVE_FROM_QUEUE (QID, WAIT, MESSAGE, STATUS)
{
{  QID: (input) This parameter specifies the system supplied identifier
{        of the queue from which an item is to be taken.  This identifier
{        is returned by the PMP$CONNECT_QUEUE request.
{
{  WAIT: (input) This parameter specifies the action to be taken if a
{        receive of an empty queue is attempted.  The valid parameters
{        are:
{        osc$wait: dont return control until a message is transferred.
{        osc$nowait: return control whether or not a message has been
{            dequeued.
{            Message contents of PMC$NO_MESSAGE will be set if
{            no dequeueing took place.
{
{  MESSAGE: (output) This parameter specifies the dequeued item.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$unknown_queue_identifier, pme$usage_bracker_error,
{                  pme$error_segment_privilege.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$RECEIVE_QUEUE_MESSAGE EXPAND=FALSE
{
{    The purpose of this request is to receive an item from a queue.
{
{       PMP$RECEIVE_QUEUE_MESSAGE (QID, WAIT, MESSAGE, COMPLETE, STATUS)
{
{  QID: (input)  This parameter specifies the system supplied identifier of the
{        queue from which an item is to be taken.  This identifier is returned
{        by the PMP$CONNECT_QUEUE request.
{
{  WAIT: (input)  This parameter specifies the action to be taken if a receive
{        of an empty queue is attempted.  The valid parameters are:
{        osc$wait:  dont return control until a message is transferred.
{        osc$nowait:  return control whether or not a message has been
{              dequeued.  Message contents of PMC$NO_MESSAGE will be set if no
{              dequeueing took place.
{
{  MESSAGE: (output)  This parameter specifies the dequeued item.
{
{  COMPLETE: (output)  this parameter specifies whether the request was
{        completed (i.e., an item was dequeued) or that the request must be
{        reissued.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{             pme$unknown_queue_identifier
{             pme$usage_bracket_error,
{             pme$error_segment_privilege.
{
*DECK DECK=PMH$REINITIALIZE_MODULE EXPAND=FALSE
{
{   The purpose of this request is to reinitialize the static data
{ of a single, previously loaded module.  All variables and addresses
{ that are local to the module will be reinitialized to the state they
{ were in when the module was loaded the first time.  No other modules
{ are affected.  This request is intended to be used by the COBOL Run
{ Time system in order to support the COBOL verbs CALL and CANCEL.
{
{      PMP$REINITIALIZE_MODULE (MODULE_NAME, STATUS)
{
{ MODULE_NAME: (input) This parameter specifies the name of the
{       module to be loaded. If more than one module with this
{       name has been loaded, the one that gets reinitialized
{       is undefined.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             lle$module_not_previous_loaded
{             lle$no_reinit_info_for_module
{             lle$premature_eof_on_module
{             lle$unknown_record_kind
*DECK DECK=PMH$REMOVE_AWAIT_NONEMPTY_QUEUE EXPAND=FALSE

{   The purpose of this request is to remove the task from the condition of
{ waiting for a non-empty queue.
{
{       PMP$REMOVE_AWAIT_NONEMPTY_QUEUE (QID)
{
{ QID: (input) This parameter specifies the system supplied identifier of the
{       queue the task is no longer waiting to go non-empty.
{
*DECK DECK=PMH$REMOVE_DEBUG_ENTRY EXPAND=FALSE
{
{   The purpose of this request is to remove the effect of a previously
{ defined debug entry.
{
{       PMP$REMOVE_DEBUG_ENTRY (DEBUG_ID, STATUS)
{
{ DEBUG_ID: (input) This parameter specifies the debug identifier of the
{       entry to be removed.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$undefined_debug_id
{

*DECK DECK=PMH$REMOVE_ENTRY_POINT EXPAND=FALSE

{
{    The purpose of this request is to delete an entry point definition from
{  the table of currently defined entry points associated with the requesting
{  task.  It has no other effect; in particular, the loaded module associated
{  with the removed entry point and all data associated with it, including
{  common blocks, are still loaded in the requesting task.
{    A subsequent PMP$LOAD_FROM_LIBRARY request may be used to load a new
{  module containing the same entry point name as the one that was removed.
{  For some applications, this may provide the ability to "reload" a corrected
{  version of a procedure, but care must be exercisedsince the old version
{  remains in the task's address space.
{
{        PMP$REMOVE_ENTRY_POINT (NAME, STATUS)
{
{   NAME:  This parameter specifies the name of the entry point to be removed
{         from the table of currently defined entry points associated with
{         the calling task.
{
{   STATUS:  This parameter specifies the request status.
{        pme$unknown_entry_point
{

*DECK DECK=PMH$REMOVE_QUEUE EXPAND=FALSE

{
{    The purpose of this request is to remove a definition of a job local
{  queue.
{
{        PMP$REMOVE_QUEUE (NAME, STATUS)
{
{  NAME: (input) This parameter specifies the queue to be removed.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$unknown_queue_name, pme$nonempty_queue,
{                  pme$task_connected_to_queue, pme$removal_bracket_error.
{                  pme$incorrect_queue_name.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$RESERVE_STACK_SEGMENTS EXPAND=FALSE
{
{    The purpose of this request is to reserve a set of stack segments for
{  subsequent use with PMP$EXECUTE_PROCEDURE.  The reserved segments will be
{  inheritied, that is shared at exactly the same process segment number in
{  all tasks created by the issuer of the request.  This applies to any tasks
{  created by tasks created by the issuing task and on down the task hierarchy.
{
{        PMP$RESERVE_STACK_SEGMENTS (NUMBER_OF_TASKS, STATUS)
{
{  NUMBER_OF_TASKS: (input) This parameter specifies the number of tasks for
{        which stack segments are to be reserved.  These segments are
{        inherited by all subsequent tasks created in the same "family" of
{        tasks.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$illegal_ada_control_task
{
{
*DECK DECK=PMH$RESET_DEBUG_SCAN EXPAND=FALSE
{    The purpose of this request is to reset the debug scan if the p-register
{ is modified in the stack frame save area of the trapped procedure and the
{ trap is "debug".
{
{       PMP$RESET_DEBUG_SCAN (STATUS)
{
{ STATUS: (input) This parameter specifies the request status.
{       CONDITIONS:
{             none
{
*DECK DECK=PMH$RESTORE_PROGRAM_STATE EXPAND=FALSE
{
{    The purpose of this request is to restore the state of a program to what
{ was saved using the pmp$save_program_state request.  The state of a program
{ consists of the writable working storage and the stack.  The program state is
{ restored from the container provided by the caller.
{
{    If an error condition is detected in processing this request, the request
{ will return with an abnormal status.  If no error is detected, however, the
{ state of the program will be restored to what it was at the time the
{ pmp$save_program_state request was made.  This means that the program will
{ look like it just returned from making the pmp$save_program_state request.
{ The value of the original_program parameter will be false, however, to
{ indicate that the program is executing at a point following a state
{ restoration.
{
{    The p_parameter_block and parameter_block_length parameters can be used to
{ pass a parameter block to the restored program.  The parameter block must be
{ in working storage rather than the stack since the stack following the
{ restoration bears no relationship to the stack before the restoration.  The
{ parameter block amounts to a part of working storage that is not restored to
{ what it was at the time the pmp$save_program_state request was made.
{
{
{       PMP$RESTORE_PROGRAM_STATE (P_STATE_CONTAINER, P_PARAMETER,
{             PARAMETER_LENGTH, STATUS)
{
{ P_STATE_CONTAINER: (input)  This parameter specifies a container from which
{       the program state is to be restored.  The container is an adaptable
{       sequence.  The program state is taken from the sequence at the current
{       position.
{
{ P_PARAMETER: (input)  This parameter specifies a parameter block in working
{       storage that is to be passed to the program in its restored state.  The
{       parameter block amounts to a part of working storage that is not
{       restored to what it was at the time the program state was saved.  If no
{       parameter block is desired, a NIL pointer may be used.
{
{ PARAMETER_LENGTH: (input)  This parameter specifies the length of the
{       parameter block.  If no parameter block is desired, a length of zero
{       may be used.
{
{ STATUS: (output) This parameter returns the request status.
{       CONDITIONS:
{             pme$invalid_program_state
{             pme$program_mismatch
{             pme$unwritable_program_state
{
{
*DECK DECK=PMH$REVOKE_PROGRAM_TERMINATION EXPAND=FALSE

{    The purpose of this request is to revoke a previously recorded program
{  termination.  Issuing this request is necessary if some process executing
{  after a program has called PMP$EXIT or PMP$ABORT desires to resume the
{  program.  The number of revocations is limited to 1000.
{
{ NOTE: This interface was specifically designed to be used only by the
{       interactive debugger.  There is code in PMP$EXIT and PMP$ABORT
{       to revoke program termination only if debug mode is on and dbp$end_debug
{       is callable.
{
{        PMP$REVOKE_PROGRAM_TERMINATION (STATUS)
{
{ STATUS: (output) This parameter sepcifies the request status.
{       CONDITIONS:
{             pme$maximum_term_revocations
{             pme$termination_not_revocable
{
*DECK DECK=PMH$RING_CROSSING_PROCEDURE EXPAND=FALSE


{  PURPOSE:
{    This procedure is called to check for ring alarms and initiate the processing of
{    premptive communications before returning to a procedure running in a higher ring.
{
{  NOTE:
{    The design of this procedure allows it to be called by both pmp$call_ring_crossing_proc
{    during normal task operation and by pmp$intra_ring_popper during task termination.  The
{    procedure is entered with traps enabled, but returns to its caller with traps disabled.
{    If abnormal status is returned by pmp$activate_ring_alarm, traps are enabled and the
{    procedure is exited through pmp$exit.
{
{              PMP$RING_CROSSING_PROCEDURE
{
*DECK DECK=PMH$SAVE_PROGRAM_STATE EXPAND=FALSE
{
{   The purpose of this request is to save the state of a program so that it
{ may later be restored.  The state of a program consists of the writable
{ working storage and the stack.  The state of the program is saved in the
{ container provided by the caller.  The state can be restored from the
{ container by using the pmp$restore_program_state request.
{
{   The primary purpose of this request is to provide a building block that
{ can be used by a task to clone itself.  The clone task would be executing
{ the same program at the same place and would have nearly the same working
{ storage and stack as the original task.  The minor differences between the
{ working storage and/or stack of the two tasks are the result of parameters
{ on the save/restore program state interfaces that make it possible for the
{ original and clone task to take different paths following the clone.
{
{   In order for a task to clone itself, the program being executed must
{ have two different paths and a means of determining which path is to be
{ followed. The path selection could be as simple as choosing the path based
{ on a parameter passed to the program when it is started.  One of the paths
{ of the program can be considered the normal path and it implements the
{ primary function of the program.  The other path is used only to complete
{ a cloning process.  The following algorithm demonstrates how a clone can
{ be achieved.
{
{   Original Task
{
{   1. The program looks at its parameters and determines that it should
{      perform its primary function.
{
{   2. As part of performing its primary function, it determines that it
{      must create a clone task.
{
{   3. It creates a segment access file and uses the pmp$save_program_state
{      request to save its current state in the segment.
{
{   4. It determines that it is the original program from the
{      original_program parameter returned by pmp$save_program_state and
{      therefore continues with the original program part of the algorithm
{      as follows.
{
{   5. It uses pmp$execute to start the clone task.  It does the execute
{      with its own program description but passes parameters which select
{      the "complete cloning" path and identify the file containing the
{      saved state.
{
{   6. It continues any other processing required by the original task.
{
{
{   Clone Task
{
{   1. The program looks at its parameters and determines that it should
{      perform the "complete cloning" function.
{
{   2. It opens the program state file (program parameter) for segment
{      access.
{
{   3. If desired, it sets up a parameter block in working storage that is
{      to be passed to the clone.
{
{   4. It uses the pmp$restore_program_state request to restore the program
{      state to that saved in the program state file.
{
{   5. It resumes execution following the pmp$save_program_state request
{      made by the original task but determines that it is not the original
{      program based on the original_program parameter returning false.
{
{   6. It continues any other processing required by the clone task.  Its
{      working storage and stack are the same as the original task, except
{      for the parameter block passed on the pmp$restore_program_state
{      request.  The parameter block can be used to cause the clone to
{      perform differently than the original task.
{
{
{       PMP$SAVE_PROGRAM_STATE (P_STATE_CONTAINER, ORIGINAL_PROGRAM, STATUS)
{
{ P_STATE_CONTAINER: (input, output) This parameter specifies a container in
{       which the program state is to be placed.  The container is an
{       adaptable sequence.  The program state is placed in the sequence at
{       the current position.  The current position is updated to reflect
{       the amount of space occupied by the program state.
{
{ ORIGINAL_PROGRAM: (output) This parameter returns the value TRUE to the
{       program that makes the pmp$save_program_state request.  It returns
{       the value FALSE to any program that "returns" from
{       pmp$save_program_state by using the pmp$restore_program_state
{       request.
{
{ STATUS: (output) This parameter returns the request status.
{        CONDITIONS:
{              pme$state_container_full
{              pme$unreadable_program_state
{
{
*DECK DECK=PMH$SELECT_PROCESSOR EXPAND=FALSE
{
{  The purpose of this procedure is to allow a task to select a particular
{ processor on which to execute.
{
{   PMP$SELECT_PROCESSOR (id, status)
{
{ ID: (INPUT) This parameter specifies the logical processor ID of the
{     processor on which the task will execute.
{
{ STATUS: (OUTPUT) This parameter specifies the request status.
{
*DECK DECK=PMH$SEND_SIGNAL EXPAND=FALSE

{
{   The purpose of this request is to send a task orginated signal to
{ another task.  The other task must be known, otherwise the request
{ is in error. If the recipient task is in another job, the request
{ must be issued from ring 1, otherwise the request is in error.
{
{   The signal handler, corresponding to signal_id, is guaranteed to
{ preempt any non-NOS/VE code in the recipent task.
{
{   **** This request DOES NOT issue a PMP$WAIT request. ****
{
{       PMP$SEND_SIGNAL (RECIPIENT, SIGNAL, STATUS)
{
{ RECIPIENT: (input) This parameter specifies the task to be signaled.
{
{ SIGNAL: (input) This parameter specifies the signal to be sent to the
{       recipient task.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$invalid_task_origin_signal,
{                  pme$invalid_identifier,
{                  pme$unknown_recipient_task,
{                  pme$insufficient_privilege.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$SEND_TO_QUEUE EXPAND=FALSE

{
{    The purpose of this request is to send an item to a queue.
{
{        PMP$SEND_TO_QUEUE (QID, MESSAGE, STATUS)
{
{  QID: (input) This parameter specifies the system supplied identifier
{        of the queue to which an item is to be sent.  This identifier
{        is returned by the PMP$CONNECT_QUEUE request.
{
{  MESSAGE: (input) This parameter specifies the item to be sent to the
{        queue.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$unknown_queue_identifier, pme$usage_bracker_error,
{                  pme$maximum_queued_messages, pme$error_pointer_privilege,
{                  pme$incorrect_message_type, pme$pass_share_prohibited,
{                  pme$incorrect_segment_message, pme$error_segment_privilege,
{                  pme$error_segment_message, pme$error_number_of_segments,
{                  pme$maximum_queued_segments.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$SET_JOB_DEBUG_RING EXPAND=FALSE

{
{   The purpose of this request is to specify the ring of execution for
{ the interactive debugger.  The job debug ring cannot be set to a more
{ privileged ring than the most privileged ring in which the user is validated
{ to run.  The initial setting of debug ring is the initial user ring of
{ execution established at validation.  This request will only affect tasks
{ which are executed subsequent to the request.
{
{       PMP$SET_JOB_DEBUG_RING ( DEBUG_RING, STATUS )
{
{ DEBUG_RING: (input) This parameter specifies the job debug ring number.
{
{ STATUS: (output) This parameter specifies the request status.
{      CONDITION: pme$invalid_ring_number,
{                 pme$set_to_more_privelaged_ring.
{      IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$SET_POPPER_HANDLER_ACTIVITY EXPAND=FALSE
{
{    The purpose of this request is to set a boolean that indicates whether or
{ not an essence of the trap handler has noted that it needs to protect popper
{ from being popped off the stack for task termination.
{
{       PMP$SET_POPPER_HANDLER_ACTIVITY (ACTIVE);
{
{ ACTIVE: (input)  This indicates whether popper is protected or not.
{
*DECK DECK=PMH$SET_PROCESS_INTERVAL_TIMER EXPAND=FALSE

{   The purpose of this request is to set the process interval timer.
{ This request is to be used in conjunction with the establishment of a
{ pmc$pit_condition handler.  A pmc$pit_condition will arise only if a
{ handler is in effect and the process interval timer has been set via
{ the PMP$SET_PROCESS_INTERVAL_TIMER request.
{
{       PMP$SET_PROCESS_INTERVAL_TIMER (MICROSECONDS, STATUS)
{
{ MICROSECONDS: (input) This parameter specifies the value to be placed in
{       process interval timer.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$pit_value_out_of_range.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$SET_RELATIVE_PRIORITY EXPAND=FALSE
{
{    The purpose of this request is to assign a relative priority to a task.
{ The relative priority of a task is used in the task dispatching algorithms to
{ determine the order of execution of ready tasks.
{
{    The default relative priority of a task is 128.  The user should be aware
{ of the impact of the default.  Any tasks which have not set their relative
{ priority will run at a higher priority than tasks which have lowered their
{ priority below the default.  Also, any tasks which have set their priority
{ above the default will block other tasks from setting their relative priority
{ (assuming the task which has raised its priority above the default is CP
{ bound).
{
{       PMP$SET_RELATIVE_PRIORITY (relative_priority, status)
{
{ RELATIVE_PRIORITY: (input)  This parameter is the relative priority to be
{       assigned to the task.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             pme$invalid_relative_priority
*DECK DECK=PMH$SET_SYSTEM_FLAG EXPAND=FALSE

{
{  The purpose of this request is to set a task originated system flag
{ in another task.  The other task must be known, otherwise the request
{ is in error.  If the recipient task is in another job, the request
{ must be issued from ring 1, otherwise the request is in error.
{
{   The system flag handler, corresponding to the flag_id, in the other
{ task is guaranteed to preempt any non-NOS/VE execution.
{
{   **** This request DOES NOT issue a PMP$WAIT request. ****
{
{       PMP$SET_SYSTEM_FLAG (FLAG_ID, RECIPIENT, STATUS)
{
{ FLAG_ID: (input) This parameter specifies the system flag to be set.
{
{ RECIPIENT: (input) This parameter specifies the task in which the
{       system flag is to be set.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$invalid_task_origin_flag,
{                  pme$invalid_identifier,
{                  pme$unknown_recipient_task,
{                  pme$insufficient_privilege.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$SET_TASK_DEBUG_MODE EXPAND=FALSE
{
{   The purpose of this request is to set a task into or take it out of
{ debug mode.  It operates on the most recently stacked setting of task
{ debug mode.  Other settings of the task debug mode are not affected.
{
{       PMP$SET_TASK_DEBUG_MODE (DEBUG_MODE, STATUS)
{
{ DEBUG_MODE: (input) This parameter specifies the debug mode in which the
{       the task is to be placed.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             lle$entry_point_not_found
{             lle$entry_point_unaligned
{             lle$loader_stopped
*DECK DECK=PMH$SET_TASK_DEBUG_RING EXPAND=FALSE

{
{   The purpose of this request is to set the execution ring of the
{ interactive debugger in the requesting task to job debug ring.  This
{ request is honored once in a task.
{
{       PMP$SET_TASK_DEBUG_RING
{
*DECK DECK=PMH$SET_TASK_EXECUTION_PHASE EXPAND=FALSE
{
{    The purpose of this request is to set the execution phase of a task.
{
{       PMP$SET_TASK_EXECUTION_PHASE (EXECUTION_PHASE);
{
{ EXECUTION_PHASE: (input)  This is the execution phase that task is in.
{
*DECK DECK=PMH$SIGNAL_ALL_CHILD_TASKS EXPAND=FALSE

{    The purpose of this request is to send a signal to each child task of
{  the executing task.
{
{        PMP$SIGNAL_ALL_CHILD_TASKS (SIGNAL, STATUS)
{
{  SIGNAL: (input) This parameter specifies the signal to be sent to each
{        child task.
{
{  STATUS: (output) This parameter specifies the request status.
{
{       WARNING:  This procedure uses a ring 1 interlock.  It must not
{         be called by signal handlers (or their subordinates) which
{         may interrupt ring 1 processes.
{
*DECK DECK=PMH$STATUS_QUEUE EXPAND=FALSE

{
{    The purpose of this request is to determine the number of tasks
{  connected to a queue, the number of queued messages, and the number
{  of waiting tasks.
{
{        PMP$STATUS_QUEUE (QID, COUNTS, STATUS)
{
{  QID: (input) This parameter specifies the system supplied identifier
{        of the queue of which is to be interrogated.
{        This identifier is returned by the PMP$CONNECT_QUEUE request.
{
{  COUNTS: (output) This parameter specifies the number of tasks
{        connected to the queue, the number of queued messages, and the
{        number of waiting tasks.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$unknown_queue_identifier, pme$usage_bracket_error.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$STATUS_QUEUES_DEFINED EXPAND=FALSE

{ }
{    The purpose of this request is to determine the number of currently
{  defined queues.
{ }
{        PMP$STATUS_QUEUES_DEFINED (COUNT, STATUS)
{ }
{  COUNT: (output) This parameter specifies the number of queues
{        currently defined.
{ }
{  STATUS: (output) This parameter specifies the request status.
{ }
*DECK DECK=PMH$TASK_DEBUG_MODE_ON EXPAND=FALSE

{
{   The purpose of this request is to return the current debug mode of
{ the task.
{
{       PMP$TASK_DEBUG_MODE_ON : DEBUG_MODE
{
{ DEBUG_MODE: (output) This function evaluates to the current debug mode.
{
*DECK DECK=PMH$TASK_DEBUG_RING EXPAND=FALSE

{
{   The purpose of this request is to return the current value of the
{ task debug ring.
{
{       PMP$TASK_DEBUG_RING : DEBUG_RING
{
{ DEBUG_RING: (output) This function evaluates to the current task debug ring.
{
*DECK DECK=PMH$TASK_STATE EXPAND=FALSE

{    The purpose of this request is to return the current state of the
{  executing task.  The task state is returned as a function value.
{
{        PMP$TASK_STATE
{
*DECK DECK=PMH$TERMINATE EXPAND=FALSE

{
{    The purpose of this request is to terminate the execution of a
{  previously executed task.  The task being terminated must have been
{  executed by the task issuing the request.  All tasks executed by the
{  task being terminated will be terminated as well.  Control is returned
{  to the requestor when the task has terminated.
{
{        PMP$TERMINATE (TASK_ID, STATUS)
{
{  TASK_ID: (input) This parameter specifies the system supplied identifier
{        of the task to be terminated.  This identifier is returned by
{        the PMP$EXECUTE request.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITIONS: pme$task_not_current_child, pme$invalid_task_id
{       IDENTIFIER: 'PM'
{
*DECK DECK=PMH$TERMINATED_WHILE_INHIBITED EXPAND=FALSE
{
{    The purpose of this request is to allow a routine to test if a request
{ has been made to terminate the task while task termination is inhibited.
{
{    This request can only be made from ring 4.
{
{       PMP$TERMINATED_WHILE_INHIBITED (): BOOLEAN;
*DECK DECK=PMH$TERMINATE_POPPER EXPAND=FALSE
{
{    The purpose of this request is to terminate the stack frame popper.  The
{ status message supplied on this request is logged and the stack is truncated.
{
{       PMP$TERMINATE_POPPER (MESSAGE_STATUS);
{
{ MESSAGE_STATUS: (input)  This is the status message to log.  If the status is
{       normal the task is terminated with normal status otherwise the task is
{       terminated with the error PME$STACK_FRAME_POPPER_ABORTED.
*DECK DECK=PMH$TEST_CONDITION_HANDLER EXPAND=FALSE

{
{    The purpose of this request is to assist in testing established
{  condition handlers. This request programmatically forces the
{  appearance of conditions normally detected by the hardware or
{  NOS/VE.
{
{        PMP$TEST_CONDITION_HANDLER (CONDITIONS, SAVE_AREA, STATUS)
{
{  CONDITIONS: (input) This parameter specifies the forced conditions
{        to be passed to the condition handler.
{
{  SAVE_AREA: (input) This parameter specifies the image of the save
{        area to be passed to the condition handler.
{
{  STATUS: (output) This parameter specifies the request status.
{       CONDITION: pme$unsupported_by_test_cond, pme$no_established_handler,
{                  pme$handler_stack_error, pme$inconsistent_stack,
{                  pme$invalid_condition_handler.
{       IDENTIFIER: pmc$program_management_id.
{
*DECK DECK=PMH$TMM$MANAGE_SIGNALS_AND_FLAG EXPAND=FALSE

{   PURPOSE:
{     The task control block is the job template description of a task and
{     its relationship with its superior and subordinates within a job.
{
{     The task control block services two major purposes: 1) communication
{     between a parent task and its children; and 2) as a convenient container
{     for structures related to preemptive communication (system flags and
{     signals).
{
{   DESIGN:
{     The task control block is internal to PROGRAM MANAGEMENT (tasking
{     and preemptive communication); its contents are the sole responsibility
{     of PROGRAM MANAGEMENT; and its domain of reference is to be limited to
{     PROGRAM MANAGEMENT.
{
{     Task control blocks are always created and released in a parent task.
{
{     1)  Parent / Child Communication
{         task_id: task id of owner of the task control block -
{                initialized in parent when creating a child task;
{                used to discover task control blocks and XCBs of tasks other
{                than the requestor.
{         parent: pointer to parent's task control block -
{                initialized in parent when creating a child task;
{                used to determine if a task is a job monitor (in ring 2
{                and above); used in a parent to establish the relationship
{                among siblings.
{         first_child, next_sibling: this 'list' establishs the relationship
{                between the parent and its children -
{                managed in parent when creating and releasing a child task;
{                the 'list' is used to reference all child tasks as group -
{                signal all children, flag all children, and wait for all
{                children;
{                the 'list' is also used to verify that a specified task is
{                a child of the requestor - terminate or wait for a specific
{                child.
{         program_description, program_parameters, target_ring, debug_input,
{           debug_output, abort_file, and initial_debug_ring: these fields are
{                the vehicle by which the associated data is passed from the
{                parent to the child task -
{                initialized in parent when creating the child task;
{                used within the child task in creating its local environment.
{         termination_status, parent_task_status_variable: these fields are
{                the vehicle by which the task status variable is returned to
{                the returned to the requestor of PMP$EXECUTE -
{                initialized in parent when creating the child task;
{                termiantion_status is updated in child as part of exit
{                processing;
{                parent_task_status_variable is used within the parent to
{                locate the destination of task status.
{
{         flag_execution_ring, signal_execution_ring: these arrays contain
{                the ring in which an outstanding flag or signal should be
{                processed -
{                initalized in parent when creating the child task;
{                managed within the child by preemptive communication
{                processing (i.e., tmm$allocate_execution_rings,
{                tmm$manage_signals_and_flags).
{         task_local_signal_list: this 'list' augments the XCB's signal
{                buffer -
{                initialized in parent when creating the child task;
{                managed within the child by preemptive communication
{                processing (i.e., tmm$allocate_execution_rings,
{                tmm$manage_signals_and_flags).
{
*DECK DECK=PMH$UPDATE_PROGRAM_DESCRIPTION EXPAND=FALSE
{    The purpose of this request is to replace the current task's program
{ description with the program description supplied on the request.  This
{ request is only called by pmp$execute_within_task.
{
{       PMP$UPDATE_PROGRAM_DESCRIPTION (NEW_PROGRAM_DESCRIPTION);
{
{ NEW_PROGRAM_DESCRIPTION: (input)  This is the program description to replace
{       the current task's program description.
*DECK DECK=PMH$VALIDATE_PREVIOUS_SAVE_AREA EXPAND=FALSE
{
{    The purpose of this request is to ensure that the previous save area is
{ valid according to hardware specification.  A previous save area (a2) of NIL
{ in the current save area is valid by software convention.
{
{       PMP$VALIDATE_PREVIOUS_SAVE_AREA (CURRENT_SAVE_AREA, STATUS)
{
{ CURRENT_SAVE_AREA: (input)  This parameter specifies the save area whose
{       predecessor is to be validated.
{
{ STATUS: (output) This parameter specifies the outcome of the request -
{       abnormal status indicates an invalid previous save area.
{       CONDITIONS:
{             pme$inconsistent_stack
{
*DECK DECK=PMH$VERIFY_CHILD_TASK EXPAND=FALSE

{    The purpose of this request is to verify that an identified task is
{  currently a child of the executing task.
{
{        PMP$VERIFY_CHILD_TASK (TASK_ID, CURRENT_CHILD)
{
{  TASK_ID: (input) This parameter specifies the identity of the task which
{        is to be verified as a current child.
{
{  CURRENT_CHILD: (output) This parameter specifies whether the identified
{        task is currently a child of the executing task.
{
*DECK DECK=PMH$VERIFY_LIBRARY EXPAND=FALSE

{
{   The purpose of this request is to verify that a file is a legitimate
{ object library.
{
{       PMP$VERIFY_LIBRARY (LIBRARY_FILE, VERSION, STATUS)
{
{ LIBRARY_FILE: (input) This parameter specifies the sequence pointer for the
{       library file.
{
{ VERSION: (output) This parameter specifies the library version.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION: lle$library_header_missing, lle$wrong_library_version,
{                  lle$empty_module_dictionary, lle$bad_module_dictionary_ptr,
{                  lle$bad_entry_dictionary_ptr.
{       IDENTIFIER: 'PM'
{
*DECK DECK=PMH$WAIT EXPAND=FALSE

{
{   The purpose of this request is to relinquish control of the system
{ waiting for an event which will always nominally occur in a short
{ period of time.  An event occurs when a signal or system flag is
{ received, the task is made ready via pmp$ready_task, or the time
{ (requested_ms) expires.
{
{   If the task is waiting for a specific signal or system flag, the
{ pmp$wait must be issued from a ring >= the bottom of the execution
{ bracket of the handler of the signal or flag.  Further the signal
{ or flag must be able to preempt pmp$wait - currently all signals and
{ flags preempt a pmp$wait.
{
{       PMP$WAIT (REQUESTED_MS, EXPECTED_MS)
{
{ REQUESTED_MS: (input) This parameter specifies the maximum time
{       (in milliseconds) before the task will become a candidate
{       for execution.
{ EXPECTED_MS: (input) This parameter specifies the amount of time
{       (in milliseconds) that the caller expects to wait before
{       an event occurs to make the task ready.
{
*DECK DECK=PMH$ZERO_OUT_TABLE EXPAND=FALSE
{
{    The purpose of this request is to initialize a section of memory to zeros.
{
{       PMP$ZERO_OUT_TABLE (P, LEN)
{
{ P: (input)  This parameter specifies a pointer to the area to be initialized.
{
{ LEN: (input)  This parameter specifies the length of the area to be
{       initialized.
{
{
*DECK DECK=PMK$KEYPOINTS EXPAND=FALSE

  {Program Management Keypoint Procedure Identifiers}

  { NOTE:
  { The value for pmk$purge_instruction_stack is used in the ASSEMBLE deck PMM$JOB_TEMPLATE_TRAP_HANDLER

  CONST
    pmk$task_begin_end = pmk$base + 0,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'PM_process_task' }
    {X 'PM_process_task' }
*ELSE
    {E 'pmp$task_begin_end' }
    {X 'pmp$task_begin_end' }
*IFEND

    pmk$task_begin = pmk$base + 1,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'PM_initiate_task' }
    {X 'PM_initiate_task' }
*ELSE
    {E 'pmp$task_begin' }
    {X 'pmp$task_begin' }
*IFEND

    pmk$pop_all_stack_frames = pmk$base + 2,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'PM_pop_all_stack_frames' }
    {X 'PM_pop_all_stack_frames' }
*ELSE
    {E 'pmp$pop_all_stack_frames' }
    {X 'pmp$terminate_popper' }
*IFEND

    pmk$ring_crossing_popper = pmk$base + 3,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'PM_ring_crossing_popper' }
    {X 'PM_ring_crossing_popper' }
*ELSE
    {E 'pmp$ring_crossing_popper' }
    {X 'pmp$ring_crossing_popper' }
*IFEND

    pmk$execute = pmk$base + 4,
    {E 'pmp$execute' }
    {X 'pmp$execute' 'status ' I20 }

    pmk$execute_with_less_privilege = pmk$base + 5,
    {E 'pmp$execute_with_less_privilege' }
    {X 'pmp$execute_with_less_privilege' 'status ' I20 }

    pmk$exit = pmk$base + 6,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'PM_exit_task' }
*ELSE
    {E 'pmp$exit' }
*IFEND

    pmk$abort = pmk$base + 7,
*IF $variable(osc$select_path_keypoints, defined) AND osc$select_path_keypoints
    {E 'PM_abort_task' }
*ELSE
    {E 'pmp$abort' }
*IFEND

    pmk$terminate = pmk$base + 8,
    {E 'pmp$terminate' 'child_id' H20 }
    {X 'pmp$terminate' 'status ' I20 }

    pmk$await_task_termination = pmk$base + 9,
    {E 'pmp$await_task_termination' 'child_id' H20 }
    {X 'pmp$await_task_termination' 'status ' I20 }

    pmk$get_entry_point_address = pmk$base + 10,
    {E 'pmp$get_entry_point_address' }
    {X 'pmp$get_entry_point_address' }

    pmk$get_program_description = pmk$base + 11,
    {E 'pmp$get_program_description' }
    {X 'pmp$get_program_description' 'status ' I20 }

    pmk$get_program_size = pmk$base + 12,
    {E 'pmp$get_program_size' }
    {X 'pmp$get_program_size' 'status ' I20 }

    pmk$define_queue = pmk$base + 13,
    {E 'pmp$define_queue' }
    {X 'pmp$define_queue' }

    pmk$remove_queue = pmk$base + 14,
    {E 'pmp$remove_queue' }
    {X 'pmp$remove_queue' }

    pmk$connect_queue = pmk$base + 15,
    {E 'pmp$connect_queue' }
    {X 'pmp$connect_queue' }

    pmk$disconnect_queue = pmk$base + 16,
    {E 'pmp$disconnect_queue' }
    {X 'pmp$disconnect_queue' }

    pmk$send_to_queue = pmk$base + 17,
    {E 'pmp$send_to_queue' }
    {X 'pmp$send_to_queue' }

    pmk$receive_from_queue = pmk$base + 18,
    {E 'pmp$receive_from_queue' }
    {X 'pmp$receive_from_queue' }

    pmk$status_queue = pmk$base + 19,
    {E 'pmp$status_queue' }
    {X 'pmp$status_queue' }

    pmk$status_queues_defined = pmk$base + 20,
    {E 'pmp$status_queues_defined' }
    {X 'pmp$status_queues_defined' }

    pmk$get_queue_limits = pmk$base + 21,
    {E 'pmp$status_queues_defined_queue' }
    {X 'pmp$status_queues_defined_queue' }

    pmk$establish_condition_handler = pmk$base + 22,
    {E 'pmp$establish_condition_handler' }
    {X 'pmp$establish_condition_handler' 'status ' I20 }

    pmk$disestablish_cond_handler = pmk$base + 23,
    {E 'pmp$disestablish_cond_handler' }
    {X 'pmp$disestablish_cond_handler' 'status ' I20 }

    pmk$cause_condition = pmk$base + 24,
    {E 'pmp$cause_condition' }
    {X 'pmp$cause_condition' 'status ' I20 }

    pmk$continue_to_cause_condition = pmk$base + 25,
    {E 'pmp$continue_to_cause_condition' }
    {X 'pmp$continue_to_cause_condition' }

    pmk$test_condition_handler = pmk$base + 26,
    {E 'pmp$test_condition_handler' }
    {X 'pmp$test_condition_handler' }

    pmk$get_time = pmk$base + 27,
    {E 'pmp$get_time' }
    {X 'pmp$get_time' 'status ' I20 }

    pmk$get_microsecond_clock = pmk$base + 28,
    {E 'pmp$get_microsecond_clock' }
    {X 'pmp$get_microsecond_clock' }

    pmk$get_task_cp_time = pmk$base + 29,
    {E 'pmp$get_task_cp_time' }
    {X 'pmp$get_task_cp_time' }

    pmk$get_date = pmk$base + 30,
    {E 'pmp$get_date' }
    {X 'pmp$get_date' 'status ' I20 }

    pmk$get_srus = pmk$base + 31,
    {E 'pmp$get_srus' }
    {X 'pmp$get_srus' }

    pmk$get_user_identification = pmk$base + 32,
    {E 'pmp$get_user_identification' }
    {X 'pmp$get_user_identification' }

    pmk$get_account_project = pmk$base + 33,
    {E 'pmp$get_account_project' }
    {X 'pmp$get_account_project' }

    pmk$get_job_names = pmk$base + 34,
    {E 'pmp$get_job_names' }
    {X 'pmp$get_job_names' }

    pmk$get_job_mode = pmk$base + 35,
    {E 'pmp$get_job_name' }
    {X 'pmp$get_job_name' }

    pmk$get_task_id = pmk$base + 36,
    {E 'pmp$get_task_id' }
    {X 'pmp$get_task_id' 'status ' I20 }

    pmk$manage_sense_switches = pmk$base + 37,
    {E 'pmp$manage_sense_switches' }
    {X 'pmp$manage_sense_switches' }

    pmk$generate_unique_name = pmk$base + 38,
    {E 'pmp$generate_unique_name' }
    {X 'pmp$generate_unique_name' 'status ' I20 }

    pmk$get_os_version = pmk$base + 39,
    {E 'pmp$get_os_version' }
    {X 'pmp$get_os_version' }

    pmk$get_processor_attributes = pmk$base + 40,
    {E 'pmp$get_processor_attributes' }
    {X 'pmp$get_processor_attributes' }

    pmk$log_message = pmk$base + 41,
    {E 'pmp$log_message' }
    {X 'pmp$log_message' }

    pmk$log_ascii = pmk$base + 42,
    {E 'pmp$log_ascii' }
    {X 'pmp$log_ascii' }

    pmk$get_legible_date_time = pmk$base + 43,
    {E 'pmp$get_legible_date_time' }
    {X 'pmp$get_legible_date_time' }

    pmk$get_compact_date_time = pmk$base + 44,
    {E 'pmp$get_compact_date_time' }
    {X 'pmp$get_compact_date_time' }

    pmk$format_compact_time = pmk$base + 45,
    {E 'pmp$format_compact_time' }
    {X 'pmp$format_compact_time' }

    pmk$format_compact_date = pmk$base + 46,
    {E 'pmp$format_compact_date' }
    {X 'pmp$format_compact_date' }

    pmk$job_debug_ring = pmk$base + 47,
    {E 'pmp$job_debug_ring' }
    {X 'pmp$job_debug_ring' 'dbg_ring' I8 }

    pmk$reset_debug_scan = pmk$base + 48,
    {E 'pmp$reset_debug_scan' }
    {X 'pmp$reset_debug_scan' }

    pmk$compute_date_time = pmk$base + 49,
    {E 'pmp$compute_date_time' }
    {X 'pmp$compute_date_time' }

    pmk$get_common_block_info = pmk$base + 50,
    {E 'pmp$get_common_block_info' }
    {X 'pmp$get_common_block_info' 'status ' I20 }

    pmk$log = pmk$base + 51,
    {E 'pmp$log' }
    {X 'pmp$log' 'status ' I20 }

    pmk$load = pmk$base + 52,
    {E 'pmp$load' }
    {X 'pmp$load' 'status ' I20 }

    pmk$find_entry_point_address = pmk$base + 53,
    {E 'pmp$find_entry_point_address' }
    {X 'pmp$find_entry_point_address' 'status ' I20 }

    pmk$get_170_os_type = pmk$base + 54,
    {E 'pmp$get_170_os_type' }
    {X 'pmp$get_170_os_type' }

    pmk$wait = pmk$base + 55,
    {E 'pmp$wait' }
    {X 'pmp$wait' }

    pmk$long_term_wait = pmk$base + 56,
    {E 'pmp$long_term_wait' }
    {X 'pmp$long_term_wait' }

    pmk$get_executing_task_gtid_r6 = pmk$base + 57,
    {E 'pmp$get_executing_task_gtid_r6' }
    {X 'pmp$get_executing_task_gtid_r6' 'task_id' H20}

    pmk$ready_task = pmk$base + 58,
    {E 'pmp$ready_task' 'task_id' H20}
    {X 'pmp$ready_task' }

    pmk$get_program_size_in_bytes = pmk$base + 59,
    {E 'pmp$get_program_size_in_bytes' }
    {X 'pmp$get_program_size_in_bytes' 'status ' I20 }

    pmk$get_job_task_statistics = pmk$base + 60,
    {E 'pmp$get_job_task_statistics' }
    {X 'pmp$get_job_task_statistics' 'status ' I20 }

    pmk$change_inheritable_segments = pmk$base + 61,
    {E 'pmp$change_inheritable_segments' }
    {X 'pmp$change_inheritable_segments' }

    pmk$clear_wait_inhibited = pmk$base + 62,
    {E 'pmp$clear_wait_inhibited' }
    {X 'pmp$clear_wait_inhibited' }

    pmk$get_parent_calling_ring = pmk$base + 63,
    {E 'pmp$get_parent_calling_ring' }
    {X 'pmp$get_parent_calling_ring' }

    pmk$get_parent_task_id = pmk$base + 64,
    {E 'pmp$get_parent_task_id' }
    {X 'pmp$get_parent_task_id' }

    pmk$reserve_stack_segments = pmk$base + 65,
    {E 'pmp$reserve_stack_segments' }
    {X 'pmp$reserve_stack_segments' }

    pmk$compute_date_time_increment = pmk$base + 66,
    {E 'pmp$compute_date_time_increment' }
    {X 'pmp$compute_date_time_increment' }

    pmk$compute_day_of_week = pmk$base + 67,
    {E 'pmp$compute_day_of_week' }
    {X 'pmp$compute_day_of_week' }

    pmk$compute_local_date_time = pmk$base + 68,
    {E 'pmp$compute_local_date_time' }
    {X 'pmp$compute_local_date_time' }

    pmk$compute_universal_date_time = pmk$base + 69,
    {E 'pmp$compute_universal_date_time' }
    {X 'pmp$compute_universal_date_time' }

    pmk$delay = pmk$base + 70,
    {E 'pmp$delay' }
    {X 'pmp$delay' }

    pmk$cycle = pmk$base + 71,
    {E 'pmp$cycle' }
    {X 'pmp$cycle' }

    pmk$disestablish_end_handler = pmk$base + 72,
    {E 'pmp$disestablish_end_handler' }
    {X 'pmp$disestablish_end_handler' }

    pmk$disestab_end_hndlr_in_ring = pmk$base + 73,
    {E 'pmp$disestab_end_hndlr_in_ring' }
    {X 'pmp$disestab_end_hndlr_in_ring' }

    pmk$establish_end_handler = pmk$base + 74,
    {E 'pmp$establish_end_handler' }
    {X 'pmp$establish_end_handler' }

    pmk$establish_end_hndlr_in_ring = pmk$base + 75,
    {E 'pmp$establish_end_hndlr_in_ring' }
    {X 'pmp$establish_end_hndlr_in_ring' }

    pmk$enable_system_conditions = pmk$base + 76,
    {E 'pmp$enable_system_conditions' }
    {X 'pmp$enable_system_conditions' }

    pmk$establish_ch_in_block = pmk$base + 77,
    {E 'pmp$establish_ch_in_block' }
    {X 'pmp$establish_ch_in_block' }

    pmk$inhibit_system_conditions = pmk$base + 78,
    {E 'pmp$inhibit_system_conditions' }
    {X 'pmp$inhibit_system_conditions' }

    pmk$get_time_zone = pmk$base + 79,
    {E 'pmp$get_time_zone' }
    {X 'pmp$get_time_zone' }

    pmk$get_universal_date_time = pmk$base + 80,
    {E 'pmp$get_universal_date_time' }
    {X 'pmp$get_universal_date_time' }

    pmk$get_binary_cpu_attributes = pmk$base + 81,
    {E 'pmp$get_binary_cpu_attributes' }
    {X 'pmp$get_binary_cpu_attributes' }

    pmk$get_binary_mainframe_id = pmk$base + 82,
    {E 'pmp$get_binary_mainframe_id' }
    {X 'pmp$get_binary_mainframe_id' }

    pmk$get_binary_processor_id = pmk$base + 83,
    {E 'pmp$get_binary_processor_id' }
    {X 'pmp$get_binary_processor_id' }

    pmk$get_cpu_attributes = pmk$base + 84,
    {E 'pmp$get_cpu_attributes' }
    {X 'pmp$get_cpu_attributes' }

    pmk$get_day_of_week = pmk$base + 85,
    {E 'pmp$get_day_of_week' }
    {X 'pmp$get_day_of_week' }

    pmk$get_mainframe_id = pmk$base + 86,
    {E 'pmp$get_mainframe_id' }
    {X 'pmp$get_mainframe_id' }

    pmk$get_page_size = pmk$base + 87,
    {E 'pmp$get_page_size' }
    {X 'pmp$get_page_size' }

    pmk$get_processor_id = pmk$base + 88,
    {E 'pmp$get_processor_id' }
    {X 'pmp$get_processor_id' }

    pmk$load_from_library = pmk$base + 89,
    {E 'pmp$load_from_library' }
    {X 'pmp$load_from_library' }

    pmk$get_unique_name = pmk$base + 90,
    {E 'pmp$get_unique_name' }
    {X 'pmp$get_unique_name' }

{ NOTE:
{ This value is used in the ASSEMBLE deck PMM$JOB_TEMPLATE_TRAP_HANDLER
    pmk$purge_instruction_stack = pmk$base + 91,
    {E 'pmp$purge_instruction_stack' }
    {X 'pmp$purge_instruction_stack' }

    pmk$remove_entry_point = pmk$base + 92,
    {E 'pmp$remove_entry_point' }
    {X 'pmp$remove_entry_point' }

    pmk$ready_task_and_wait = pmk$base + 93,
    {E 'pmp$ready_task_and_wait' }
    {X 'pmp$ready_task_and_wait' }

    pmk$set_process_interval_timer = pmk$base + 94,
    {E 'pmp$set_process_interval_timer' }
    {X 'pmp$set_process_interval_timer' }

    pmk$execute_procedure = pmk$base + 95,
    {E 'pmp$execute_procedure' }
    {X 'pmp$execute_procedure' 'status ' I20 }

    pmk$establish_segment_access = pmk$base + 96,
    {E 'pmp$establish_segment_access' }
    {X 'pmp$establish_segment_access' }

    pmk$disestablish_segment_access = pmk$base + 97,
    {E 'pmp$disestablish_segment_access' }
    {X 'pmp$disestablish_segment_access' }

    pmk$close_common_block_file = pmk$base + 98,
    {E 'pmp$close_common_block_file' }
    {X 'pmp$close_common_block_file' }

    pmk$load_entry_point = pmk$base + 99,
    {E 'pmp$load_entry_point' }
    {X 'pmp$load_entry_point' }

    pmk$reinitialize_module = pmk$base + 100,
    {E 'pmp$reinitialize_module' }
    {X 'pmp$reinitialize_module' }

    pmk$select_processor = pmk$base + 101,
    {E 'pmp$select_processor' }
    {X 'pmp$select_processor' }

    pmk$deselect_processor = pmk$base + 102,
    {E 'pmp$deselect_processor' }
    {X 'pmp$deselect_processor' }

    pmk$validate_previous_save_area = pmk$base + 103,
    {E 'pmp$validate_previous_save_area' }
    {X 'pmp$validate_previous_save_area' }

    pmk$initial_debug_mode_on = pmk$base + 104,
    {E 'pmp$initial_debug_mode_on' }
    {X 'pmp$initial_debug_mode_on' }

    pmk$get_debug_abort_file = pmk$base + 105,
    {E 'pmp$get_debug_abort_file' }
    {X 'pmp$get_debug_abort_file' }

    pmk$get_debug_input_file = pmk$base + 106,
    {E 'pmp$get_debug_input_file' }
    {X 'pmp$get_debug_input_file' }

    pmk$get_debug_output_file = pmk$base + 107,
    {E 'pmp$get_debug_output_file' }
    {X 'pmp$get_debug_output_file' }

    pmk$push_task_debug_mode = pmk$base + 108,
    {E 'pmp$push_task_debug_mode' }
    {X 'pmp$push_task_debug_mode' }

    pmk$pop_task_debug_mode = pmk$base + 109,
    {E 'pmp$pop_task_debug_mode' }
    {X 'pmp$pop_task_debug_mode' }

    pmk$set_task_debug_mode = pmk$base + 110,
    {E 'pmp$set_task_debug_mode' }
    {X 'pmp$set_task_debug_mode' }

    pmk$task_debug_mode_on = pmk$base + 111,
    {E 'pmp$task_debug_mode_on' }
    {X 'pmp$task_debug_mode_on' }

    pmk$establish_debug_cff = pmk$base + 112,
    {E 'pmp$establish_debug_cff' }
    {X 'pmp$establish_debug_cff' }

    pmk$define_debug_entry = pmk$base + 113,
    {E 'pmp$define_debug_entry' }
    {X 'pmp$define_debug_entry' }

    pmk$get_debug_entry = pmk$base + 114,
    {E 'pmp$get_debug_entry' }
    {X 'pmp$get_debug_entry' }

    pmk$modify_debug_entry = pmk$base + 115,
    {E 'pmp$modify_debug_entry' }
    {X 'pmp$modify_debug_entry' }

    pmk$remove_debug_entry = pmk$base + 116,
    {E 'pmp$remove_debug_entry' }
    {X 'pmp$remove_debug_entry' }

    pmk$get_debug_id = pmk$base + 117,
    {E 'pmp$get_debug_id' }
    {X 'pmp$get_debug_id' }

    pmk$task_debug_ring = pmk$base + 118,
    {E 'pmp$task_debug_ring' }
    {X 'pmp$task_debug_ring' }

    pmk$change_default_prog_options = pmk$base + 119,
    {E 'pmp$change_default_prog_options' }
    {X 'pmp$change_default_prog_options' }

    pmk$change_job_library_list = pmk$base + 120,
    {E 'pmp$change_job_library_list' }
    {X 'pmp$change_job_library_list' }

    pmk$pop_inhibit_termination = pmk$base + 121,
    {E 'pmp$pop_inhibit_termination' }
    {X 'pmp$pop_inhibit_termination' }

    pmk$push_inhibit_termination = pmk$base + 122,
    {E 'pmp$push_inhibit_termination' }
    {X 'pmp$push_inhibit_termination' }

    pmk$terminated_while_inhibited = pmk$base + 123,
    {E 'pmp$terminated_while_inhibited' }
    {X 'pmp$terminated_while_inhibited' }

    pmk$cause_inter_job_condition = pmk$base + 124,
    {E 'pmp$cause_inter_job_condition' }
    {X 'pmp$cause_inter_job_condition' }

    pmk$get_library_dictionaries = pmk$base + 125,
    {E 'pmp$get_library_dictionaries' }
    {X 'pmp$get_library_dictionaries' }

    pmk$find_module_in_library = pmk$base + 126,
    {E 'pmp$find_module_in_library' }
    {X 'pmp$find_module_in_library' }

    pmk$open_object_library = pmk$base + 127,
    {E 'pmp$open_object_library' }
    {X 'pmp$open_object_library' }

    pmk$close_object_library = pmk$base + 128,
    {E 'pmp$close_object_library' }
    {X 'pmp$close_object_library' }

    pmk$get_os_build_level = pmk$base + 129,
    {E 'pmp$get_os_build_level' }
    {X 'pmp$get_os_build_level' }

    pmk$restore_program_state = pmk$base + 130,
    {E 'pmp$restore_program_state' }
    {X 'pmp$restore_program_state' }

    pmk$save_program_state = pmk$base + 131,
    {E 'pmp$save_program_state' }
    {X 'pmp$save_program_state' }

    pmk$compute_time_dif_in_seconds = pmk$base + 132,
    {E 'pmp$compute_time_dif_in_seconds' }
    {X 'pmp$compute_time_dif_in_seconds' }

    pmk$open_common_block_file = pmk$base + 133,
    {E 'pmp$open_common_block_file' }
    {X 'pmp$open_common_block_file' }

    pmk$create_ada_heap = pmk$base + 134,
    {E 'pmp$create_ada_heap' }
    {X 'pmp$create_ada_heap' }

    pmk$set_relative_priority = pmk$base + 135,
    {E 'pmp$set_relative_priority' }
    {X 'pmp$set_relative_priority' }

    pmk$cause_intra_job_condition = pmk$base + 136,
    {E 'pmp$cause_intra_job_condition' }
    {X 'pmp$cause_intra_job_condition' }

    pmk$change_transient_to_write = pmk$base + 137,
    {E 'pmp$change_transient_to_write' }
    {X 'pmp$change_transient_to_write' }

    pmk$change_transient_to_execute = pmk$base + 138,
    {E 'pmp$change_transient_to_execute' }
    {X 'pmp$change_transient_to_execute' }

    pmk$change_transient_to_binding = pmk$base + 139,
    {E 'pmp$change_transient_to_binding' }
    {X 'pmp$change_transient_to_binding' }

    pmk$change_binding_to_write = pmk$base + 140,
    {E 'pmp$change_binding_to_write' }
    {X 'pmp$change_binding_to_write' }

    pmk$expand_segment = pmk$base + 141,
    {E 'pmp$expand_segment' }
    {X 'pmp$expand_segment' }

    pmk$begin_subsystem_activity = pmk$base + 142,
    {E 'pmp$begin_subsystem_activity' }
    {X 'pmp$begin_subsystem_activity' }

    pmk$revoke_program_termination = pmk$base + 143,
    {E 'pmp$revoke_program_termination' }
    {X 'pmp$revoke_program_termination' }

    pmk$zero_out_table = pmk$base + 144,
    {E 'pmp$zero_out_table' }
    {X 'pmp$zero_out_table' }

    pmk$establish_ch_outside_block = pmk$base + 145,
    {E 'pmp$establish_ch_outside_block' }
    {X 'pmp$establish_ch_outside_block' }

    pmk$limit = pmk$base + 149;

*copyc OSK$KEYPOINTS
*DECK DECK=PMM$ANALYZE_PROGRAM_DYNAMICS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : APD : Analyze program dynamics' ??
MODULE pmm$analyze_program_dynamics;
?? NEWTITLE := '  Global declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_expression_result
*copyc llt$program_description
*copyc osd$integer_limits
*copyc ost$date
*copyc pme$analyze_program_dynamics
*copyc pmt$loader_seq_descriptor
*copyc pmt$program_parameters
*copyc pmt$task_id
*copyc pmt$task_status
?? POP ??
*copyc amp$fetch_access_information
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc amp$return
*copyc amp$set_segment_eoi
*copyc clp$close_display
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_file
*copyc clp$get_fs_path_elements
*copyc clp$get_path_description
*copyc clp$new_display_line
*copyc clp$new_display_page
*copyc clp$open_display
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc clp$scan_command_line
*copyc clp$scan_parameter_list
*copyc clp$trimmed_string_size
*copyc clp$validate_local_file_name
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$execute_with_apd
*copyc pmp$get_date
*copyc pmp$get_last_path_name
*copyc pmp$get_legible_date_time
*copyc pmp$get_os_version
*copyc pmp$get_apd_task_jobmode_stats
*copyc pmp$log
*copyc pmp$simulate_call_overhead
*copyc pmp$simulate_return_overhead
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  SECTION
    file_attributes: READ;

  VAR
    measures_file_attributes: [STATIC, READ, file_attributes] array [1 .. 3] of fst$file_cycle_attribute :=
          [[fsc$file_contents_and_processor, fsc$unknown_contents, fsc$unknown_processor],
          [fsc$file_organization, amc$sequential], [fsc$record_type, amc$undefined]];

  VAR
    pmv$loader_description: [XREF] pmt$loader_description,
    pmv$loader_seq_descriptor: [XREF] ^pmt$loader_seq_descriptor,
    pmv$interblock_references_hdr: [XREF] ^pmt$interblock_references_hdr,
    pmv$mpe_seq_descriptor: [XREF] pmt$mpe_seq_descriptor,
    pmv$program_description: [XREF] ^pmt$program_description;

?? NEWTITLE := '[XDCL] pmp$restore_program_measures', EJECT ??

  PROCEDURE [XDCL] pmp$restore_program_measures
    (    measures_file: amt$local_file_name;
     VAR status: ost$status);



    VAR
      connectivity_matrix: ^array [0 .. * ] of 0 .. 0ffffff(16),
      contains_data: boolean,

      dummy: [STATIC] array [1 .. 1] of amt$get_item := [[ * , amc$access_mode, * ]],

      existing_file: boolean,
      file: clt$file,
      i: pmt$number_of_object_files,
      local_block_name_map: ^array [0 .. * ] of pmt$block_name_map_entry,
      local_execution_time_totals: ^array [0 .. * ] of pmt$execution_time_totals,
      local_file: boolean,
      measures_file_identifier: amt$file_identifier,
      module_list: ^pmt$module_list,
      number_of_libraries: pmt$number_of_libraries,
      number_of_local_blocks: pmt$block_id,
      number_of_modules: pmt$number_of_modules,
      number_of_object_files: pmt$number_of_object_files,
      number_of_remote_blocks: pmt$block_id,
      object_file_list: ^pmt$object_file_list,
      object_library_list: ^pmt$object_library_list,
      program_attributes: ^pmt$program_attributes,

      read_attachment: [STATIC, READ] array [1 .. 2] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$read]],
            [fsc$determine_from_access_modes]], [fsc$create_file, FALSE]],

      remote_block_name_map: ^array [0 .. * ] of pmt$block_name_map_entry,
      remote_execution_time_totals: ^array [0 .. * ] of pmt$execution_time_totals,
      saved_environment_ptr: ^pmt$mpe_environment_descriptor,
      saved_module_list: ^pmt$module_list,
      saved_object_file_list: ^llt$object_file_list,
      saved_object_library_list: ^llt$object_library_list,
      saved_program_attributes: ^llt$program_attributes,
      segment_pointer: amt$segment_pointer;



    amp$get_file_attributes (measures_file, dummy, local_file, existing_file, contains_data, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal ('PM', pme$e_missing_or_empty_file, measures_file, status);
      RETURN;
    IFEND;

    IF NOT contains_data THEN
      osp$set_status_abnormal ('PM', pme$e_missing_or_empty_file, measures_file, status);
      RETURN;
    IFEND;

    fsp$open_file (measures_file, amc$segment, ^read_attachment, NIL, NIL, ^measures_file_attributes, NIL,
          measures_file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (measures_file_identifier, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET segment_pointer.sequence_pointer;
    RESET pmv$loader_seq_descriptor^.seq_ptr;
    RESET pmv$mpe_seq_descriptor.seq_ptr;

    NEXT pmv$loader_seq_descriptor IN pmv$loader_seq_descriptor^.seq_ptr;
    IF pmv$loader_seq_descriptor = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
      RETURN;
    IFEND;

    NEXT saved_environment_ptr IN segment_pointer.sequence_pointer;
    IF saved_environment_ptr = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
      RETURN;
    IFEND;

    IF saved_environment_ptr^.verification_header <> mpe_verification_header THEN
      osp$set_status_abnormal ('PM', pme$e_file_not_created_by_mpe, measures_file, status);
      RETURN;
    IFEND;

    number_of_local_blocks := saved_environment_ptr^.number_of_local_blocks;
    number_of_remote_blocks := saved_environment_ptr^.number_of_remote_blocks;

    pmv$loader_seq_descriptor^.local_block_id := number_of_local_blocks;
    pmv$loader_seq_descriptor^.remote_block_id := number_of_remote_blocks;

    NEXT remote_block_name_map: [0 .. number_of_remote_blocks] IN segment_pointer.sequence_pointer;
    IF remote_block_name_map = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
      RETURN;
    IFEND;

    NEXT pmv$loader_seq_descriptor^.remote_block_name_map: [0 .. number_of_remote_blocks] IN
          pmv$loader_seq_descriptor^.seq_ptr;
    IF pmv$loader_seq_descriptor^.remote_block_name_map = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
      RETURN;
    IFEND;

    pmv$loader_seq_descriptor^.remote_block_name_map^ := remote_block_name_map^;

    NEXT local_block_name_map: [0 .. number_of_local_blocks] IN segment_pointer.sequence_pointer;
    IF local_block_name_map = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
      RETURN;
    IFEND;

    NEXT pmv$loader_seq_descriptor^.local_block_name_map: [0 .. number_of_local_blocks] IN
          pmv$loader_seq_descriptor^.seq_ptr;
    IF pmv$loader_seq_descriptor^.local_block_name_map = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
      RETURN;
    IFEND;

    pmv$loader_seq_descriptor^.local_block_name_map^ := local_block_name_map^;

    pmv$loader_seq_descriptor^.block_name_map_exists := TRUE;

    IF pmc$connectivity_matrix IN saved_environment_ptr^.saved_environment THEN
      NEXT connectivity_matrix: [0 .. number_of_local_blocks * number_of_local_blocks] IN
            segment_pointer.sequence_pointer;
      IF connectivity_matrix = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
        RETURN;
      IFEND;

      NEXT pmv$mpe_seq_descriptor.connectivity_matrix: [0 .. number_of_local_blocks *
            number_of_local_blocks] IN pmv$mpe_seq_descriptor.seq_ptr;
      IF pmv$mpe_seq_descriptor.connectivity_matrix = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;

      pmv$mpe_seq_descriptor.connectivity_matrix^ := connectivity_matrix^;
    ELSE
      pmv$mpe_seq_descriptor.connectivity_matrix := NIL;
    IFEND;

    IF pmc$execution_time_totals IN saved_environment_ptr^.saved_environment THEN
      NEXT remote_execution_time_totals: [0 .. number_of_remote_blocks] IN segment_pointer.sequence_pointer;
      IF remote_execution_time_totals = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
        RETURN;
      IFEND;

      NEXT pmv$mpe_seq_descriptor.remote_execution_time_totals: [0 .. number_of_remote_blocks] IN
            pmv$mpe_seq_descriptor.seq_ptr;
      IF pmv$mpe_seq_descriptor.remote_execution_time_totals = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;

      pmv$mpe_seq_descriptor.remote_execution_time_totals^ := remote_execution_time_totals^;

      NEXT local_execution_time_totals: [0 .. number_of_local_blocks] IN segment_pointer.sequence_pointer;
      IF local_execution_time_totals = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
        RETURN;
      IFEND;

      NEXT pmv$mpe_seq_descriptor.local_execution_time_totals: [0 .. number_of_local_blocks] IN
            pmv$mpe_seq_descriptor.seq_ptr;
      IF pmv$mpe_seq_descriptor.local_execution_time_totals = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;

      pmv$mpe_seq_descriptor.local_execution_time_totals^ := local_execution_time_totals^;

      pmv$mpe_seq_descriptor.creation_date := saved_environment_ptr^.creation_date;
      pmv$mpe_seq_descriptor.number_of_runs := saved_environment_ptr^.number_of_runs;
    ELSE
      pmv$mpe_seq_descriptor.local_execution_time_totals := NIL;
      pmv$mpe_seq_descriptor.remote_execution_time_totals := NIL;
    IFEND;

    IF pmv$program_description <> NIL THEN
      FREE pmv$program_description;
    IFEND;

    ALLOCATE pmv$program_description: [[REP saved_environment_ptr^.program_description_size OF cell]];
    IF pmv$program_description = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
      RETURN;
    IFEND;

    RESET pmv$program_description;

    NEXT saved_program_attributes IN segment_pointer.sequence_pointer;
    IF saved_program_attributes = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
      RETURN;
    IFEND;

    NEXT program_attributes IN pmv$program_description;
    IF program_attributes = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
      RETURN;
    IFEND;

    program_attributes^.contents := saved_program_attributes^.contents;
    program_attributes^.maximum_stack_size := saved_program_attributes^.maximum_stack_size;

    IF pmc$starting_proc_specified IN saved_program_attributes^.contents THEN
      program_attributes^.starting_procedure := saved_program_attributes^.starting_procedure;
    IFEND;

    IF pmc$object_file_list_specified IN saved_program_attributes^.contents THEN
      number_of_object_files := saved_program_attributes^.number_of_object_files;
      program_attributes^.number_of_object_files := number_of_object_files;

      NEXT saved_object_file_list: [1 .. number_of_object_files] IN segment_pointer.sequence_pointer;
      IF saved_object_file_list = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
        RETURN;
      IFEND;

      NEXT object_file_list: [1 .. number_of_object_files] IN pmv$program_description;
      IF object_file_list = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;

      FOR i := 1 TO number_of_object_files DO
        clp$convert_string_to_file (saved_object_file_list^ [i], file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        object_file_list^ [i] := file.local_file_name;
      FOREND;
    IFEND;

    IF pmc$module_list_specified IN saved_program_attributes^.contents THEN
      number_of_modules := saved_program_attributes^.number_of_modules;
      program_attributes^.number_of_modules := number_of_modules;

      NEXT saved_module_list: [1 .. number_of_modules] IN segment_pointer.sequence_pointer;
      IF saved_module_list = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
        RETURN;
      IFEND;

      NEXT module_list: [1 .. number_of_modules] IN pmv$program_description;
      IF module_list = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;

      FOR i := 1 TO number_of_modules DO
        module_list^ [i] := saved_module_list^ [i];
      FOREND;
    IFEND;

    IF pmc$library_list_specified IN saved_program_attributes^.contents THEN
      number_of_libraries := saved_program_attributes^.number_of_libraries;
      program_attributes^.number_of_libraries := number_of_libraries;

      NEXT saved_object_library_list: [1 .. number_of_libraries] IN segment_pointer.sequence_pointer;
      IF saved_object_library_list = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
        RETURN;
      IFEND;

      NEXT object_library_list: [1 .. number_of_libraries] IN pmv$program_description;
      IF object_library_list = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;

      FOR i := 1 TO number_of_libraries DO
        clp$convert_string_to_file (saved_object_library_list^ [i], file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        object_library_list^ [i] := file.local_file_name;
      FOREND;
    IFEND;

    clp$convert_string_to_file (saved_environment_ptr^.target_text_path_name,
          pmv$loader_description.target_text, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$close_file (measures_file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND pmp$restore_program_measures;
?? EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '  pmp$save_program_measures' ??

  PROCEDURE [XDCL] pmp$save_program_measures
    (    measures_file: amt$local_file_name;
         amount: pmt$environment_contents;
     VAR status: ost$status);



    VAR
      connectivity_matrix: ^array [0 .. * ] of 0 .. 0ffffff(16),
      cycle_selector: clt$cycle_selector,
      file: clt$file,
      file_reference: clt$file_reference,
      i: pmt$number_of_object_files,
      local_block_name_map: ^array [0 .. * ] of pmt$block_name_map_entry,
      local_execution_time_totals: ^array [0 .. * ] of pmt$execution_time_totals,
      measures_file_identifier: amt$file_identifier,
      module_list: ^pmt$module_list,
      number_of_libraries: pmt$number_of_libraries,
      number_of_local_blocks: pmt$block_id,
      number_of_modules: pmt$number_of_modules,
      number_of_object_files: pmt$number_of_object_files,
      number_of_remote_blocks: pmt$block_id,
      object_file_list: ^pmt$object_file_list,
      object_library_list: ^pmt$object_library_list,
      open_position: clt$open_position,
      path: ^pft$path,
      path_container: clt$path_container,
      program_attributes: ^pmt$program_attributes,
      remote_block_name_map: ^array [0 .. * ] of pmt$block_name_map_entry,
      remote_execution_time_totals: ^array [0 .. * ] of pmt$execution_time_totals,
      saved_environment_ptr: ^pmt$mpe_environment_descriptor,
      saved_module_list: ^pmt$module_list,
      saved_object_file_list: ^llt$object_file_list,
      saved_object_library_list: ^llt$object_library_list,
      saved_program_attributes: ^llt$program_attributes,
      segment_pointer: amt$segment_pointer,
      write_attachment: [STATIC, READ] array [1 .. 2] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$read, fsc$append, fsc$modify,
            fsc$shorten]], [fsc$specific_share_modes, []]], [fsc$create_file, TRUE]];

    fsp$open_file (measures_file, amc$segment, ^write_attachment, NIL, ^measures_file_attributes,
          ^measures_file_attributes, NIL, measures_file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (measures_file_identifier, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET segment_pointer.sequence_pointer;

    NEXT saved_environment_ptr IN segment_pointer.sequence_pointer;
    IF NOT status.normal THEN
      osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
      RETURN;
    IFEND;

    number_of_local_blocks := pmv$loader_seq_descriptor^.local_block_id;
    number_of_remote_blocks := pmv$loader_seq_descriptor^.remote_block_id;

    saved_environment_ptr^.verification_header := mpe_verification_header;
    saved_environment_ptr^.creation_date := pmv$mpe_seq_descriptor.creation_date;
    saved_environment_ptr^.number_of_runs := pmv$mpe_seq_descriptor.number_of_runs;
    saved_environment_ptr^.number_of_local_blocks := number_of_local_blocks;
    saved_environment_ptr^.number_of_remote_blocks := number_of_remote_blocks;
    saved_environment_ptr^.saved_environment := amount;

    clp$get_path_description (pmv$loader_description.target_text, file_reference, path_container, path,
          cycle_selector, open_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    saved_environment_ptr^.target_text_path_name := file_reference.path_name;

    NEXT remote_block_name_map: [0 .. number_of_remote_blocks] IN segment_pointer.sequence_pointer;
    IF remote_block_name_map = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
      RETURN;
    IFEND;

    remote_block_name_map^ := pmv$loader_seq_descriptor^.remote_block_name_map^;

    NEXT local_block_name_map: [0 .. number_of_local_blocks] IN segment_pointer.sequence_pointer;
    IF local_block_name_map = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
      RETURN;
    IFEND;

    local_block_name_map^ := pmv$loader_seq_descriptor^.local_block_name_map^;

    IF pmc$connectivity_matrix IN amount THEN
      NEXT connectivity_matrix: [0 .. number_of_local_blocks * number_of_local_blocks] IN
            segment_pointer.sequence_pointer;
      IF connectivity_matrix = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
        RETURN;
      IFEND;

      connectivity_matrix^ := pmv$mpe_seq_descriptor.connectivity_matrix^;
    IFEND;

    IF pmc$execution_time_totals IN amount THEN
      NEXT remote_execution_time_totals: [0 .. number_of_remote_blocks] IN segment_pointer.sequence_pointer;
      IF remote_execution_time_totals = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
        RETURN;
      IFEND;

      remote_execution_time_totals^ := pmv$mpe_seq_descriptor.remote_execution_time_totals^;

      NEXT local_execution_time_totals: [0 .. number_of_local_blocks] IN segment_pointer.sequence_pointer;
      IF local_execution_time_totals = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
        RETURN;
      IFEND;

      local_execution_time_totals^ := pmv$mpe_seq_descriptor.local_execution_time_totals^;
    IFEND;

    RESET pmv$program_description;

    NEXT program_attributes IN pmv$program_description;
    IF program_attributes = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
      RETURN;
    IFEND;

    NEXT saved_program_attributes IN segment_pointer.sequence_pointer;
    IF saved_program_attributes = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
      RETURN;
    IFEND;

    saved_program_attributes^.contents := program_attributes^.contents;
    saved_program_attributes^.maximum_stack_size := program_attributes^.maximum_stack_size;

    IF pmc$starting_proc_specified IN program_attributes^.contents THEN
      saved_program_attributes^.starting_procedure := program_attributes^.starting_procedure;
    IFEND;

    IF pmc$object_file_list_specified IN program_attributes^.contents THEN
      number_of_object_files := program_attributes^.number_of_object_files;
      saved_program_attributes^.number_of_object_files := number_of_object_files;

      NEXT object_file_list: [1 .. number_of_object_files] IN pmv$program_description;
      IF object_file_list = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;

      NEXT saved_object_file_list: [1 .. number_of_object_files] IN segment_pointer.sequence_pointer;
      IF saved_object_file_list = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
        RETURN;
      IFEND;

      FOR i := 1 TO number_of_object_files DO
        file.local_file_name := object_file_list^ [i];

        clp$get_path_description (file, file_reference, path_container, path, cycle_selector, open_position,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        saved_object_file_list^ [i] := file_reference.path_name;
      FOREND;
    IFEND;

    IF pmc$module_list_specified IN program_attributes^.contents THEN
      number_of_modules := program_attributes^.number_of_modules;
      saved_program_attributes^.number_of_modules := number_of_modules;

      NEXT module_list: [1 .. number_of_modules] IN pmv$program_description;
      IF module_list = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;

      NEXT saved_module_list: [1 .. number_of_modules] IN segment_pointer.sequence_pointer;
      IF saved_module_list = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
        RETURN;
      IFEND;

      FOR i := 1 TO number_of_modules DO
        saved_module_list^ [i] := module_list^ [i];
      FOREND;
    IFEND;

    IF pmc$library_list_specified IN program_attributes^.contents THEN
      number_of_libraries := program_attributes^.number_of_libraries;
      saved_program_attributes^.number_of_libraries := number_of_libraries;

      NEXT object_library_list: [1 .. number_of_libraries] IN pmv$program_description;
      IF object_library_list = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;

      NEXT saved_object_library_list: [1 .. number_of_libraries] IN segment_pointer.sequence_pointer;
      IF saved_object_library_list = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_premature_eof_on_file, measures_file, status);
        RETURN;
      IFEND;

      FOR i := 1 TO number_of_libraries DO
        file.local_file_name := object_library_list^ [i];

        clp$get_path_description (file, file_reference, path_container, path, cycle_selector, open_position,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        saved_object_library_list^ [i] := file_reference.path_name;
      FOREND;
    IFEND;

    saved_environment_ptr^.program_description_size := #SIZE (pmv$program_description^);

    amp$set_segment_eoi (measures_file_identifier, segment_pointer, status);

    fsp$close_file (measures_file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND pmp$save_program_measures;
?? OLDTITLE ??
?? NEWTITLE := '  pmp$create_restructure_commands' ??
?? EJECT ??

  PROCEDURE [XDCL] pmp$create_restructure_commands
    (    commands: amt$local_file_name;
         library_file_reference: clt$file_reference;
         gen_module_name: pmt$program_name;
     VAR status: ost$status);

?? NEWTITLE := '    create_intercolumn_bond_matrix' ??
?? EJECT ??

    PROCEDURE create_intercolumn_bond_matrix
      (    connectivity_matrix: ^array [0 .. * ] of 0 .. 0ffffff(16);
       VAR intercolumn_bond_matrix: ^array [1 .. * ] of 0 .. 0ffffffff(16);
       VAR status: ost$status);


      VAR
        i: integer,
        j: integer,
        k: integer,
        number_of_local_blocks: pmt$block_id,
        temp_icbm_element: 0 .. 0ffffffff(16),
        temp_i_index: integer,
        temp_j_index: integer,
        first: integer,
        last: integer,
        column_of_zeros: ^array [1 .. * ] of boolean;


      status.normal := TRUE;

      number_of_local_blocks := pmv$loader_seq_descriptor^.local_block_id;

      PUSH column_of_zeros: [1 .. number_of_local_blocks];
      IF column_of_zeros = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;

    /loop/
      FOR i := 1 TO number_of_local_blocks DO
        first := (number_of_local_blocks * (i - 1)) + 1;
        last := first + number_of_local_blocks - 1;

        FOR j := first TO last DO
          IF connectivity_matrix^ [j] <> 0 THEN
            column_of_zeros^ [i] := FALSE;
            CYCLE /loop/;
          IFEND;
        FOREND;

        column_of_zeros^ [i] := TRUE;
      FOREND /loop/;


      NEXT intercolumn_bond_matrix: [1 .. (number_of_local_blocks * number_of_local_blocks)] IN
            pmv$loader_seq_descriptor^.seq_ptr;
      IF intercolumn_bond_matrix = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;
?? EJECT ??

      FOR i := 1 TO number_of_local_blocks DO
        temp_i_index := number_of_local_blocks * (i - 1);

        FOR j := i TO number_of_local_blocks DO
          temp_j_index := number_of_local_blocks * (j - 1);
          temp_icbm_element := 0;

          IF NOT (column_of_zeros^ [i] OR column_of_zeros^ [j]) THEN

            FOR k := 1 TO number_of_local_blocks DO
              temp_icbm_element := temp_icbm_element + (connectivity_matrix^ [temp_i_index + k] *
                    connectivity_matrix^ [temp_j_index + k]);
            FOREND;
          IFEND;

          intercolumn_bond_matrix^ [temp_i_index + j] := temp_icbm_element;
          intercolumn_bond_matrix^ [temp_j_index + i] := temp_icbm_element;
        FOREND;
      FOREND;

    PROCEND create_intercolumn_bond_matrix;
?? EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '    initialize_working_lists' ??

    PROCEDURE initialize_working_lists
      (    number_of_local_blocks: pmt$block_id;
           intercolumn_bond_matrix: ^array [1 .. * ] of 0 .. 0ffffffff(16);
       VAR candidate_list: pmt$candidate_list;
       VAR cluster_list: ^pmt$candidate_list;
       VAR not_called_list: ^pmt$candidate_list;
       VAR status: ost$status);



      VAR
        candidates: ^array [1 .. * ] of pmt$candidate_list,
        current_candidate: ^pmt$candidate_list,
        greatest_value_on_diagonal: integer,
        i: pmt$block_id,
        temporary_candidate: ^pmt$candidate_list;


      status.normal := TRUE;

      candidate_list.link := NIL;
      cluster_list := NIL;
      not_called_list := NIL;

      NEXT candidates: [1 .. number_of_local_blocks] IN pmv$mpe_seq_descriptor.seq_ptr;
      IF candidates = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;

      greatest_value_on_diagonal := 0;
      temporary_candidate := NIL;

      FOR i := 1 TO number_of_local_blocks DO
        current_candidate := ^candidates^ [i];
        current_candidate^.local_block_id := i;
        current_candidate^.cluster_merit := 0;
        current_candidate^.best_position := NIL;

        IF (pmv$mpe_seq_descriptor.local_execution_time_totals <> NIL) AND
              (pmv$mpe_seq_descriptor.local_execution_time_totals^ [i].number_of_calls = 0) THEN
          current_candidate^.link := not_called_list;
          not_called_list := current_candidate;
        ELSE
          IF intercolumn_bond_matrix^ [number_of_local_blocks * (i - 1) + i] > greatest_value_on_diagonal THEN
            current_candidate := temporary_candidate;
            temporary_candidate := ^candidates^ [i];
            greatest_value_on_diagonal := intercolumn_bond_matrix^ [number_of_local_blocks * (i - 1) + i];
          IFEND;

          IF current_candidate <> NIL THEN
            current_candidate^.link := candidate_list.link;
            candidate_list.link := current_candidate;
          IFEND;
        IFEND;
      FOREND;
?? EJECT ??

      IF temporary_candidate <> NIL THEN
        cluster_list := temporary_candidate;
        cluster_list^.link := NIL;
      IFEND;


    PROCEND initialize_working_lists;
?? OLDTITLE ??
?? NEWTITLE := '    evaluate_candidates' ??
?? EJECT ??

    PROCEDURE evaluate_candidates
      (    number_of_local_blocks: pmt$block_id;
           intercolumn_bond_matrix: ^array [1 .. * ] of 0 .. 0ffffffff(16);
       VAR candidate_list: pmt$candidate_list;
       VAR cluster_list: ^pmt$candidate_list);



      VAR
        current_candidate: ^pmt$candidate_list,
        current_element: ^pmt$candidate_list,
        local_block_id: pmt$block_id,
        test_value: integer;



      current_candidate := candidate_list.link;

      WHILE current_candidate <> NIL DO
        local_block_id := current_candidate^.local_block_id;
        current_candidate^.cluster_merit := intercolumn_bond_matrix^
              [number_of_local_blocks * (cluster_list^.local_block_id - 1) + local_block_id];
        current_candidate^.best_position := cluster_list;
        current_element := cluster_list;

        WHILE current_element <> NIL DO
          IF current_element^.link = NIL THEN
            test_value := intercolumn_bond_matrix^ [number_of_local_blocks *
                  (local_block_id - 1) + current_element^.local_block_id];
          ELSE
            test_value := intercolumn_bond_matrix^ [number_of_local_blocks *
                  (local_block_id - 1) + cluster_list^.local_block_id] +
                  intercolumn_bond_matrix^ [number_of_local_blocks *
                  (cluster_list^.link^.local_block_id - 1) + local_block_id] -
                  intercolumn_bond_matrix^ [number_of_local_blocks *
                  (cluster_list^.link^.local_block_id - 1) + cluster_list^.local_block_id];
          IFEND;

          IF test_value >= current_candidate^.cluster_merit THEN
            current_candidate^.cluster_merit := test_value;
            current_candidate^.best_position := current_element;
          IFEND;

          current_element := current_element^.link;
        WHILEND;

        current_candidate := current_candidate^.link;
      WHILEND;

    PROCEND evaluate_candidates;
?? OLDTITLE ??
?? NEWTITLE := '    select_best_candidate' ??
?? EJECT ??

    PROCEDURE select_best_candidate
      (VAR candidate_list: pmt$candidate_list;
       VAR cluster_list: ^pmt$candidate_list);



      VAR
        best_candidate: ^pmt$candidate_list,
        best_position_in_list: ^pmt$candidate_list,
        current_candidate: ^pmt$candidate_list,
        current_element: ^pmt$candidate_list;



      current_candidate := candidate_list.link;
      best_candidate := ^candidate_list;

      WHILE current_candidate^.link <> NIL DO
        IF current_candidate^.link^.cluster_merit > best_candidate^.link^.cluster_merit THEN
          best_candidate := current_candidate;
        IFEND;
        current_candidate := current_candidate^.link;
      WHILEND;

      best_position_in_list := best_candidate^.link^.best_position;
      current_element := best_position_in_list^.link;
      best_position_in_list^.link := best_candidate^.link;
      best_candidate^.link := best_candidate^.link^.link;
      best_position_in_list^.link^.link := current_element;

    PROCEND select_best_candidate;
?? OLDTITLE ??
?? NEWTITLE := '    generate_optimal_ordering' ??
?? EJECT ??

    PROCEDURE generate_optimal_ordering
      (    intercolumn_bond_matrix: ^array [1 .. * ] of 0 .. 0ffffffff(16);
       VAR cluster_list: ^pmt$candidate_list;
       VAR status: ost$status);



      VAR
        candidate_list: pmt$candidate_list,
        element: ^pmt$candidate_list,
        not_called_list: ^pmt$candidate_list,
        number_of_local_blocks: pmt$block_id;



      status.normal := TRUE;

      number_of_local_blocks := pmv$loader_seq_descriptor^.local_block_id;

      initialize_working_lists (number_of_local_blocks, intercolumn_bond_matrix, candidate_list, cluster_list,
            not_called_list, status);

      IF NOT status.normal THEN
        RETURN;
      IFEND;

      WHILE candidate_list.link <> NIL DO
        evaluate_candidates (number_of_local_blocks, intercolumn_bond_matrix, candidate_list, cluster_list);

        select_best_candidate (candidate_list, cluster_list);
      WHILEND;


      IF cluster_list = NIL THEN
        cluster_list := not_called_list;

      ELSE
        element := cluster_list;

        WHILE element^.link <> NIL DO
          element := element^.link;
        WHILEND;

        element^.link := not_called_list;
      IFEND;


    PROCEND generate_optimal_ordering;
?? OLDTITLE ??
?? NEWTITLE := 'format_restructure_directives', EJECT ??

{ PURPOSE:
{   Build an SCL procedure to restructure the module.

    PROCEDURE format_restructure_directives
      (    command_file: amt$local_file_name;
           object_text_file: clt$file;
           library_file_reference: clt$file_reference;
           gen_module_name: pmt$program_name;
           cluster_list: ^pmt$candidate_list;
           local_block_name_map: ^array [0 .. * ] of pmt$block_name_map_entry;
       VAR status: ost$status);

      VAR
        command_file_attributes: [STATIC, READ] array [1 .. 1] of fst$file_cycle_attribute :=
              [[fsc$file_contents_and_processor, fsc$legible_data, fsc$unknown_processor]],
        command_file_identifier: amt$file_identifier,
        current_module: ^pmt$candidate_list,
        cycle_selector: clt$cycle_selector,
        file: clt$file,
        file_reference: clt$file_reference,
        ignore_byte_address: amt$file_byte_address,
        local_block_id: pmt$block_id,
        open_position: clt$open_position,
        path: ^pft$path,
        path_container: clt$path_container,
        proc_string: string (256),
        section_number: string (7),
        string_index: 0 .. osc$max_string_size,
        write_attachment: [STATIC, READ] array [1 .. 2] of fst$attachment_option :=
              [[fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$append, fsc$modify,
              fsc$shorten]], [fsc$determine_from_access_modes]], [fsc$create_file, TRUE]];

?? NEWTITLE := 'put_string', EJECT ??

{  PURPOSE:
{    Build a text line and write it to the procedure file when complete.

      PROCEDURE put_string
        (    text: string ( * );
             action: (trim, add, eol));

        proc_string (string_index, STRLENGTH (text)) := text;
        string_index := string_index + STRLENGTH (text);

        IF action = eol THEN
          amp$put_next (command_file_identifier, ^proc_string, string_index - 1, ignore_byte_address, status);
          IF NOT status.normal THEN
            EXIT format_restructure_directives;
          IFEND;
          string_index := 1;
        ELSEIF action = trim THEN
          WHILE proc_string (string_index - 1) = ' ' DO
            string_index := string_index - 1;
          WHILEND;
        IFEND;

      PROCEND put_string;
?? OLDTITLE, EJECT ??
      fsp$open_file (command_file, amc$record, ^write_attachment, NIL, ^command_file_attributes,
            ^command_file_attributes, NIL, command_file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      string_index := 1;

      put_string ('PROCEDURE ', add);
      file.local_file_name := command_file;
      clp$get_path_description (file, file_reference, path_container, path, cycle_selector, open_position,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      put_string (path^ [UPPERBOUND (path^)], add);
      put_string (' (', eol);

      clp$get_path_description (object_text_file, file_reference, path_container, path, cycle_selector,
            open_position, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      put_string ('  target_text, tt: file = ', add);
      IF file_reference.path_name_size - string_index > osc$max_string_size THEN
        osp$set_status_abnormal ('PM', pme$path_name_too_long_for_mpe, '', status);
        RETURN;
      IFEND;
      put_string (file_reference.path_name (1, file_reference.path_name_size), eol);

      put_string ('  restructured_module, rm: file = ', add);
      IF library_file_reference.path_name_size + string_index > osc$max_string_size THEN
        osp$set_status_abnormal ('PM', pme$path_name_too_long_for_mpe, '', status);
        RETURN;
      IFEND;
      put_string (library_file_reference.path_name (1, library_file_reference.path_name_size), eol);

      put_string ('  restructured_module_name, rmn: program_name = ''', add);
      put_string (gen_module_name, trim);
      put_string ('''', eol);

      put_string ('  status)', eol);

      put_string ('  create_object_library', eol);
      put_string ('    bind_module name=$string(restructured_module_name) file=target_text', add);

      current_module := cluster_list;

      WHILE current_module <> NIL DO
        local_block_id := current_module^.local_block_id;
        put_string (' mode=continue', eol);

        put_string ('    bind_module "', add);
        put_string (local_block_name_map^ [local_block_id].procedure_name, add);
        put_string ('" section_order=((''', add);
        put_string (local_block_name_map^ [local_block_id].module_name, trim);
        clp$convert_integer_to_rjstring (local_block_name_map^ [local_block_id].section_ordinal, 10, FALSE,
              ' ', section_number, status);
        section_number (1) := '''';
        put_string (section_number, add);
        put_string ('))', add);

        current_module := current_module^.link;
      WHILEND;
      put_string (' mode=quit', eol);

      put_string ('    generate_library library=restructured_module', eol);
      put_string ('    quit', eol);
      put_string ('procend', eol);

      fsp$close_file (command_file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND format_restructure_directives;
?? OLDTITLE ??
?? EJECT ??

    VAR
      cluster_list: ^pmt$candidate_list;


    status.normal := TRUE;

    IF pmv$mpe_seq_descriptor.connectivity_matrix = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_no_connectivity_matrix, '', status);
      RETURN;
    IFEND;

    create_intercolumn_bond_matrix (pmv$mpe_seq_descriptor.connectivity_matrix,
          pmv$mpe_seq_descriptor.intercolumn_bond_matrix, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    generate_optimal_ordering (pmv$mpe_seq_descriptor.intercolumn_bond_matrix, cluster_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    format_restructure_directives (commands, pmv$loader_description.target_text, library_file_reference,
          gen_module_name, cluster_list, pmv$loader_seq_descriptor^.local_block_name_map, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND pmp$create_restructure_commands;
?? OLDTITLE ??
?? NEWTITLE := '  pmp$create_restructured_module' ??
?? EJECT ??

  PROCEDURE [XDCL] pmp$create_restructured_module
    (    library_file_reference: clt$file_reference;
         module_name: pmt$program_name;
         commands: amt$local_file_name;
     VAR status: ost$status);


    VAR
      command_line: string (256),
      ignore_status: ost$status,
      path: fst$path,
      path_size: fst$path_size,
      evaluated_file_reference: fst$evaluated_file_reference,
      ignore_path_handle: fmt$path_handle,
      local_file_name: amt$local_file_name,
      name_is_path_handle: boolean,
      name_is_valid: boolean;


    status.normal := TRUE;

    IF pmv$program_description = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_no_program_description, '', status);
      RETURN;
    IFEND;

    pmp$create_restructure_commands (commands, library_file_reference, module_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$validate_local_file_name (commands, local_file_name, ignore_path_handle, name_is_path_handle,
          name_is_valid);
    IF name_is_path_handle THEN
      clp$get_fs_path_elements (local_file_name, evaluated_file_reference, status);
      IF NOT status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
        status.normal := TRUE;
        command_line := '$LOCAL.';
        command_line (8, * ) := commands;
      ELSE
        clp$convert_file_ref_to_string (evaluated_file_reference, FALSE, path, path_size, status);
        IF NOT status.normal THEN
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
          status.normal := TRUE;
          command_line := '$LOCAL.';
          command_line (8, * ) := commands;
        ELSE
          command_line := path (1, path_size);
        IFEND;
      IFEND;
    ELSE
      command_line := '$LOCAL.';
      command_line (8, * ) := commands;
    IFEND;

    clp$scan_command_line (command_line, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND pmp$create_restructured_module;
?? OLDTITLE ??
?? NEWTITLE := '  pmp$execute_instrumented_task' ??
?? NEWTITLE := '    initialize_sequences' ??
?? EJECT ??

  PROCEDURE [XDCL] pmp$execute_instrumented_task
    (    parameter_list: ^clt$parameter_list;
         connectivity_matrix: boolean;
         cws_interval_size: 0 .. 0ffffffff(16);
     VAR status: ost$status);

?? EJECT ??

    PROCEDURE initialize_sequences
      (    mpe_loader_seq: amt$local_file_name;
       VAR pmv$loader_seq_descriptor: ^pmt$loader_seq_descriptor;
       VAR status: ost$status);


      VAR
        file_attachment: ^fst$attachment_options,
        attribute_validation: ^fst$file_cycle_attributes;

      VAR
        seq_identifier: amt$file_identifier,
        connectivity_matrix_exists: boolean,
        date: ost$date,
        execution_time_totals_exists: boolean,
        i: integer,
        ignore_status: ost$status,
        number_of_local_blocks: pmt$block_id,
        number_of_remote_blocks: pmt$block_id,
        segment_pointer: amt$segment_pointer;


      status.normal := TRUE;

      PUSH file_attachment: [1 .. 1];
      file_attachment^ [1].selector := fsc$access_and_share_modes;
      file_attachment^ [1].access_modes.selector := fsc$specific_access_modes;
      file_attachment^ [1].access_modes.value := $fst$file_access_options
            [fsc$read, fsc$modify, fsc$append, fsc$shorten];
      file_attachment^ [1].share_modes.selector := fsc$determine_from_access_modes;

      PUSH attribute_validation: [1 .. 3];
      attribute_validation^ [1].selector := fsc$file_contents_and_processor;
      attribute_validation^ [1].file_contents := fsc$data;
      attribute_validation^ [1].file_processor := fsc$unknown_processor;
      attribute_validation^ [2].selector := fsc$file_organization;
      attribute_validation^ [2].file_organization := amc$sequential;
      attribute_validation^ [3].selector := fsc$record_type;
      attribute_validation^ [3].record_type := amc$undefined;

      fsp$open_file (mpe_loader_seq, amc$segment, file_attachment, NIL, NIL, attribute_validation, NIL,
            seq_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$get_segment_pointer (seq_identifier, amc$sequence_pointer, segment_pointer, status);
      IF NOT status.normal THEN
        fsp$close_file (seq_identifier, ignore_status);
        RETURN;
      IFEND;

      RESET segment_pointer.sequence_pointer;

      NEXT pmv$loader_seq_descriptor IN segment_pointer.sequence_pointer;
      IF pmv$loader_seq_descriptor = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_apd_read_error, '', status);
        fsp$close_file (seq_identifier, ignore_status);
        RETURN;
      IFEND;

      pmv$loader_seq_descriptor^.seq_ptr := segment_pointer.sequence_pointer;
      pmv$loader_seq_descriptor^.file_id := seq_identifier;

      IF pmv$loader_seq_descriptor^.mpe_aborted THEN
        osp$set_status_abnormal ('PM', pme$e_fatal_intercept_error, '', status);
        RETURN;
      IFEND;

      connectivity_matrix_exists := FALSE;
      execution_time_totals_exists := FALSE;


      number_of_local_blocks := pmv$loader_seq_descriptor^.local_block_id;
      number_of_remote_blocks := pmv$loader_seq_descriptor^.remote_block_id;

      NEXT pmv$loader_seq_descriptor^.remote_block_name_map: [0 .. number_of_remote_blocks] IN
            pmv$loader_seq_descriptor^.seq_ptr;
      IF pmv$loader_seq_descriptor^.remote_block_name_map = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_apd_read_error, '', status);
        RETURN;
      IFEND;

      NEXT pmv$loader_seq_descriptor^.local_block_name_map: [0 .. number_of_local_blocks] IN
            pmv$loader_seq_descriptor^.seq_ptr;
      IF pmv$loader_seq_descriptor^.local_block_name_map = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_apd_read_error, '', status);
        RETURN;
      IFEND;
      pmv$loader_seq_descriptor^.block_name_map_exists := TRUE;

      RESET pmv$mpe_seq_descriptor.seq_ptr;

      IF pmv$mpe_seq_descriptor.connectivity_matrix <> NIL THEN
        connectivity_matrix_exists := TRUE;
        NEXT pmv$mpe_seq_descriptor.connectivity_matrix: [0 .. (number_of_local_blocks *
              number_of_local_blocks)] IN pmv$mpe_seq_descriptor.seq_ptr;
        IF pmv$mpe_seq_descriptor.connectivity_matrix = NIL THEN
          osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
          RETURN;
        IFEND;
      IFEND;

      IF pmv$mpe_seq_descriptor.local_execution_time_totals <> NIL THEN
        execution_time_totals_exists := TRUE;
        NEXT pmv$mpe_seq_descriptor.remote_execution_time_totals: [0 .. number_of_remote_blocks] IN
              pmv$mpe_seq_descriptor.seq_ptr;
        IF pmv$mpe_seq_descriptor.remote_execution_time_totals = NIL THEN
          osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
          RETURN;
        IFEND;

        NEXT pmv$mpe_seq_descriptor.local_execution_time_totals: [0 .. number_of_local_blocks] IN
              pmv$mpe_seq_descriptor.seq_ptr;
        IF pmv$mpe_seq_descriptor.local_execution_time_totals = NIL THEN
          osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
          RETURN;
        IFEND;
      IFEND;

      fsp$open_file (pmv$loader_seq_descriptor^.first_interblock_segment_name, amc$segment, file_attachment,
            NIL, NIL, attribute_validation, NIL, seq_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$get_segment_pointer (seq_identifier, amc$sequence_pointer, segment_pointer, status);
      IF NOT status.normal THEN
        fsp$close_file (seq_identifier, ignore_status);
        RETURN;
      IFEND;

      pmv$loader_seq_descriptor^.last_interblock_segment := segment_pointer.sequence_pointer;

      RESET pmv$loader_seq_descriptor^.last_interblock_segment;
      NEXT pmv$interblock_references_hdr IN pmv$loader_seq_descriptor^.last_interblock_segment;
      IF pmv$interblock_references_hdr = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_apd_read_error, '', status);
        fsp$close_file (seq_identifier, ignore_status);
        RETURN;
      IFEND;

      pmv$interblock_references_hdr^.file_id := seq_identifier;

      IF pmv$interblock_references_hdr^.number_of_interblock_references = 0 THEN
        osp$set_status_abnormal ('PM', pme$e_mpe_loader_abort, '', status);
        RETURN;
      IFEND;

      IF NOT connectivity_matrix THEN
        IF NOT connectivity_matrix_exists THEN
          NEXT pmv$mpe_seq_descriptor.connectivity_matrix: [0 .. (number_of_local_blocks *
                number_of_local_blocks)] IN pmv$mpe_seq_descriptor.seq_ptr;
          IF pmv$mpe_seq_descriptor.connectivity_matrix = NIL THEN
            osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
            RETURN;
          IFEND;

          FOR i := 1 TO (number_of_local_blocks * number_of_local_blocks) DO
            pmv$mpe_seq_descriptor.connectivity_matrix^ [i] := 0;
          FOREND;
        IFEND;
      IFEND;

      IF NOT execution_time_totals_exists THEN
        NEXT pmv$mpe_seq_descriptor.remote_execution_time_totals: [0 .. number_of_remote_blocks] IN
              pmv$mpe_seq_descriptor.seq_ptr;
        IF pmv$mpe_seq_descriptor.remote_execution_time_totals = NIL THEN
          osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
          RETURN;
        IFEND;

        FOR i := 1 TO number_of_remote_blocks DO
          pmv$mpe_seq_descriptor.remote_execution_time_totals^ [i].block_total := 0;
          pmv$mpe_seq_descriptor.remote_execution_time_totals^ [i].number_of_calls := 0;
          pmv$mpe_seq_descriptor.remote_execution_time_totals^ [i].block_paging_total.page_in_count := 0;
          pmv$mpe_seq_descriptor.remote_execution_time_totals^ [i].block_paging_total.
                pages_reclaimed_from_queue := 0;
          pmv$mpe_seq_descriptor.remote_execution_time_totals^ [i].block_paging_total.new_pages_assigned := 0;
          pmv$mpe_seq_descriptor.remote_execution_time_totals^ [i].block_paging_total.page_fault_count := 0;
        FOREND;

        NEXT pmv$mpe_seq_descriptor.local_execution_time_totals: [0 .. number_of_local_blocks] IN
              pmv$mpe_seq_descriptor.seq_ptr;
        IF pmv$mpe_seq_descriptor.local_execution_time_totals = NIL THEN
          osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
          RETURN;
        IFEND;

        FOR i := 1 TO number_of_local_blocks DO
          pmv$mpe_seq_descriptor.local_execution_time_totals^ [i].block_total := 0;
          pmv$mpe_seq_descriptor.local_execution_time_totals^ [i].remote_total := 0;
          pmv$mpe_seq_descriptor.local_execution_time_totals^ [i].number_of_calls := 0;
          pmv$mpe_seq_descriptor.local_execution_time_totals^ [i].block_paging_total.page_in_count := 0;
          pmv$mpe_seq_descriptor.local_execution_time_totals^ [i].block_paging_total.
                pages_reclaimed_from_queue := 0;
          pmv$mpe_seq_descriptor.local_execution_time_totals^ [i].block_paging_total.new_pages_assigned := 0;
          pmv$mpe_seq_descriptor.local_execution_time_totals^ [i].block_paging_total.page_fault_count := 0;
          pmv$mpe_seq_descriptor.local_execution_time_totals^ [i].remote_paging_total.page_in_count := 0;
          pmv$mpe_seq_descriptor.local_execution_time_totals^ [i].remote_paging_total.
                pages_reclaimed_from_queue := 0;
          pmv$mpe_seq_descriptor.local_execution_time_totals^ [i].remote_paging_total.new_pages_assigned := 0;
          pmv$mpe_seq_descriptor.local_execution_time_totals^ [i].remote_paging_total.page_fault_count := 0;
        FOREND;

        pmp$get_date (osc$mdy_date, date, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        pmv$mpe_seq_descriptor.creation_date := date.mdy;
        pmv$mpe_seq_descriptor.number_of_runs := 0;
      IFEND;

      pmv$mpe_seq_descriptor.intercolumn_bond_matrix := NIL;

    PROCEND initialize_sequences;
?? OLDTITLE ??
?? NEWTITLE := '    initialize_cumulative_stats' ??
?? EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '    get_next_free_block_statistic' ??

    PROCEDURE get_next_free_block_statistic
      (VAR stack_ptr: ^pmt$block_statistic;
       VAR status: ost$status);


      CONST
        block_statistic_allocation_unit = 100;


      VAR
        free_list: ^array [1 .. * ] of pmt$block_statistic,
        i: 1 .. block_statistic_allocation_unit;


      status.normal := TRUE;

      IF free_block_statistic_list = NIL THEN
        NEXT free_list: [1 .. block_statistic_allocation_unit] IN pmv$mpe_seq_descriptor.seq_ptr;

        IF free_list = NIL THEN
          osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
          RETURN;
        IFEND;

        FOR i := 1 TO block_statistic_allocation_unit - 1 DO
          free_list^ [i].link := ^free_list^ [i + 1];
        FOREND;
        free_list^ [block_statistic_allocation_unit].link := NIL;

        free_block_statistic_list := ^free_list^ [1];
      IFEND;

      stack_ptr := free_block_statistic_list;
      free_block_statistic_list := free_block_statistic_list^.link;
      stack_ptr^.link := NIL;

    PROCEND get_next_free_block_statistic;
?? OLDTITLE ??
?? NEWTITLE := '    free_block_statistic' ??
?? EJECT ??

    PROCEDURE free_block_statistic
      (VAR stack: ^pmt$block_statistic);



      VAR
        stack_ptr: ^pmt$block_statistic;



      stack_ptr := stack;
      stack := stack^.link;
      stack_ptr^.link := free_block_statistic_list;
      free_block_statistic_list := stack_ptr;


    PROCEND free_block_statistic;
?? OLDTITLE ??
?? NEWTITLE := '    get_next_free_bws_in_list' ??
?? EJECT ??
?? RIGHT := 110 ??

    PROCEDURE get_next_free_bws_in_list
      (VAR block_working_set_pointer: ^pmt$working_set_block_reference;
       VAR status: ost$status);

{    Purpose:
{      To maintain a link list of up to 100 free block_working_set record spaces.  A calling procedure can
{      have the first free record space linked to the end of a given list by providing this procedure with
{      a pointer to the current end of the given list.


      CONST
        blk_working_set_allocation_unit = 100;


      VAR
        i: 1 .. blk_working_set_allocation_unit,
        free_bws_list: ^array [1 .. * ] of pmt$working_set_block_reference;


      status.normal := TRUE;

      IF free_block_working_set_list = NIL THEN
        NEXT free_bws_list: [1 .. blk_working_set_allocation_unit] IN pmv$mpe_seq_descriptor.seq_ptr;
        IF free_bws_list = NIL THEN
          osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
          RETURN;
        IFEND;

        FOR i := 1 TO blk_working_set_allocation_unit - 1 DO
          free_bws_list^ [i].link := ^free_bws_list^ [i + 1];
        FOREND;

        free_bws_list^ [blk_working_set_allocation_unit].link := NIL;
        free_block_working_set_list := ^free_bws_list^ [1];
      IFEND;

      block_working_set_pointer^.link := free_block_working_set_list;
      free_block_working_set_list := free_block_working_set_list^.link;
      block_working_set_pointer := block_working_set_pointer^.link;
      block_working_set_pointer^.link := NIL;

    PROCEND get_next_free_bws_in_list;

?? OLDTITLE ??
?? NEWTITLE := '   free_block_working_set_entry' ??
?? EJECT ??

    PROCEDURE free_block_working_set_entry
      (VAR free_bws_entry: ^pmt$working_set_block_reference);

      VAR
        block_working_set_pointer: ^pmt$working_set_block_reference;

      block_working_set_pointer := free_bws_entry;
      free_bws_entry := free_bws_entry^.link;
      block_working_set_pointer^.link := free_block_working_set_list;
      free_block_working_set_list := block_working_set_pointer;

    PROCEND free_block_working_set_entry;

?? OLDTITLE ??
?? NEWTITLE := '    update_block_working_set' ??
?? EJECT ??

    PROCEDURE update_block_working_set
      (    block_number: pmt$block_id;
           reference_time: pmt$reference_time;
       VAR status: ost$status);



{   Purpose:
{     To update the apd sequence by deleting all sequence entries whose
{     reference_time is less than the reference_time passed to the procedure
{     minus the cws_interval_size.  After these entries have been deleted a
{     pmt$working_set_block_reference entry is added to the end of the list
{     with a nil pointer and the passed values for the reference_time and block
{     number.  The procedure assumes a nil pointer as the signal for the end of the list.

{   Loop to delete sequence entries whose reference_time does not satisfy condition stated above.

      status.normal := TRUE;

      WHILE (block_working_set.link <> NIL) AND (block_working_set.link^.reference_time <
            (reference_time - cws_interval_size)) DO
        free_block_working_set_entry (block_working_set.link);
      WHILEND;

{   Add the new block_working_set entry to the end of the list.

      get_next_free_bws_in_list (last_block_entry_in_set, status);

      last_block_entry_in_set^.reference_time := reference_time;
      last_block_entry_in_set^.block_number := block_number;

    PROCEND update_block_working_set;

?? OLDTITLE ??
?? NEWTITLE := '    detect_critical_reference' ??
?? EJECT ??

    PROCEDURE detect_critical_reference
      (    local_block_id: pmt$block_id;
           reference_time: pmt$reference_time;
       VAR status: ost$status);



      VAR
        found_in_block_working_set: boolean,
        i: pmt$block_id,
        number_of_local_blocks: pmt$block_id,
        working_set_ptr: ^pmt$working_set_block_reference;


      status.normal := TRUE;

      found_in_block_working_set := FALSE;
      number_of_local_blocks := pmv$loader_seq_descriptor^.local_block_id;

      critical_reference_count := critical_reference_count + 1;
      working_set_ptr := block_working_set.link;

    /search_block_working_set/
      WHILE working_set_ptr <> NIL DO
        IF local_block_id = working_set_ptr^.block_number THEN
          found_in_block_working_set := TRUE;
          EXIT /search_block_working_set/;
        IFEND;

        working_set_ptr := working_set_ptr^.link;
      WHILEND /search_block_working_set/;
?? EJECT ??


      IF NOT found_in_block_working_set THEN
        working_set_ptr := block_working_set.link;

      /update_connectivity_strengths/
        WHILE working_set_ptr <> NIL DO

          IF updated_for_critical_reference^ [working_set_ptr^.block_number] <> critical_reference_count THEN
            i := number_of_local_blocks * (working_set_ptr^.block_number - 1) + local_block_id;
            pmv$mpe_seq_descriptor.connectivity_matrix^ [i] :=
                  pmv$mpe_seq_descriptor.connectivity_matrix^ [i] + 1;
            i := number_of_local_blocks * (local_block_id - 1) + working_set_ptr^.block_number;
            pmv$mpe_seq_descriptor.connectivity_matrix^ [i] :=
                  pmv$mpe_seq_descriptor.connectivity_matrix^ [i] + 1;
            updated_for_critical_reference^ [working_set_ptr^.block_number] := critical_reference_count;

          IFEND;

          working_set_ptr := working_set_ptr^.link;
        WHILEND /update_connectivity_strengths/;

        i := number_of_local_blocks * (local_block_id - 1) + local_block_id;
        pmv$mpe_seq_descriptor.connectivity_matrix^ [i] := pmv$mpe_seq_descriptor.connectivity_matrix^ [i] +
              1;
      IFEND;

      update_block_working_set (local_block_id, reference_time, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND detect_critical_reference;
?? OLDTITLE ??
?? NEWTITLE := '    push_block_statistic' ??
?? EJECT ??

    PROCEDURE push_block_statistic
      (    reference_time: pmt$reference_time;
           block_id: pmt$block_identifier;
           paging_info: pmt$paging_statistics;
       VAR status: ost$status);



      VAR
        block_statistic_ptr: ^pmt$block_statistic;


      status.normal := TRUE;

      get_next_free_block_statistic (block_statistic_ptr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      block_statistic_ptr^.link := active_block_stack_ptr;
      active_block_stack_ptr := block_statistic_ptr;

      active_block_stack_ptr^.block_id := block_id;
      active_block_stack_ptr^.call_time := reference_time;
      active_block_stack_ptr^.paging_stats := paging_info;
      active_block_stack_ptr^.subordinate_time := 0;
      active_block_stack_ptr^.subordinate_paging_stats.page_in_count := 0;
      active_block_stack_ptr^.subordinate_paging_stats.pages_reclaimed_from_queue := 0;
      active_block_stack_ptr^.subordinate_paging_stats.new_pages_assigned := 0;
      active_block_stack_ptr^.subordinate_paging_stats.page_fault_count := 0;
      active_block_stack_ptr^.pop_count := 0;

      IF block_id.local THEN
        pmv$mpe_seq_descriptor.local_execution_time_totals^ [block_id.block_number].number_of_calls :=
              pmv$mpe_seq_descriptor.local_execution_time_totals^ [block_id.block_number].number_of_calls + 1;
        IF NOT connectivity_matrix THEN
          detect_critical_reference (block_id.block_number, reference_time, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      ELSE
        pmv$mpe_seq_descriptor.remote_execution_time_totals^ [block_id.block_number].number_of_calls :=
              pmv$mpe_seq_descriptor.remote_execution_time_totals^ [block_id.block_number].number_of_calls +
              1;
      IFEND;

    PROCEND push_block_statistic;
?? OLDTITLE ??
?? NEWTITLE := '    pop_block_statistic' ??
?? EJECT ??

    PROCEDURE pop_block_statistic
      (    reference_time: pmt$reference_time;
           paging_info: pmt$paging_statistics;
       VAR status: ost$status);



      VAR
        block_time_in_remote: pmt$reference_time,
        current_block_no: pmt$block_id,
        intger: integer,
        new_pages_assigned: 0 .. 0ffffffff(16),
        page_fault_count: 0 .. 0ffffffffff(16),
        pages_in: 0 .. 0ffffffff(16),
        pages_reclaimed: 0 .. 0ffffffff(16),
        pop_count: integer,
        stack_ptr: ^pmt$block_statistic;


      status.normal := TRUE;

      pop_count := active_block_stack_ptr^.pop_count + 1;

      WHILE (pop_count > 0) AND (active_block_stack_ptr <> NIL) DO
        current_block_no := active_block_stack_ptr^.block_id.block_number;
        IF active_block_stack_ptr^.block_id.local THEN
          intger := pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].
                block_total + (reference_time - active_block_stack_ptr^.call_time -
                active_block_stack_ptr^.subordinate_time);

          IF intger <= 0 THEN
            pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].block_total := 0;
          ELSE
            pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].block_total := intger;
          IFEND;

          intger := pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].block_paging_total.
                page_in_count + (paging_info.page_in_count - active_block_stack_ptr^.paging_stats.
                page_in_count - active_block_stack_ptr^.subordinate_paging_stats.page_in_count);

          IF intger <= 0 THEN
            pages_in := 0;
          ELSE
            pages_in := intger;
          IFEND;

          pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].block_paging_total.
                page_in_count := pages_in;

          intger := pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].block_paging_total.
                pages_reclaimed_from_queue + (paging_info.pages_reclaimed_from_queue -
                active_block_stack_ptr^.paging_stats.pages_reclaimed_from_queue -
                active_block_stack_ptr^.subordinate_paging_stats.pages_reclaimed_from_queue);

          IF intger <= 0 THEN
            pages_reclaimed := 0;
          ELSE
            pages_reclaimed := intger;
          IFEND;

          pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].block_paging_total.
                pages_reclaimed_from_queue := pages_reclaimed;

          intger := pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].block_paging_total.
                new_pages_assigned + (paging_info.new_pages_assigned -
                active_block_stack_ptr^.paging_stats.new_pages_assigned -
                active_block_stack_ptr^.subordinate_paging_stats.new_pages_assigned);

          IF intger <= 0 THEN
            new_pages_assigned := 0;
          ELSE
            new_pages_assigned := intger;
          IFEND;

          pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].block_paging_total.
                new_pages_assigned := new_pages_assigned;

          intger := pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].block_paging_total.
                page_fault_count + (paging_info.page_fault_count -
                active_block_stack_ptr^.paging_stats.page_fault_count -
                active_block_stack_ptr^.subordinate_paging_stats.page_fault_count);

          IF intger <= 0 THEN
            page_fault_count := 0;
          ELSE
            page_fault_count := intger;
          IFEND;

          pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].block_paging_total.
                page_fault_count := page_fault_count;

        ELSE
          intger := reference_time - active_block_stack_ptr^.call_time -
                active_block_stack_ptr^.subordinate_time;

          IF intger <= 0 THEN
            block_time_in_remote := 0;
          ELSE
            block_time_in_remote := intger;
          IFEND;

          pmv$mpe_seq_descriptor.remote_execution_time_totals^ [current_block_no].block_total :=
                pmv$mpe_seq_descriptor.remote_execution_time_totals^ [current_block_no].block_total +
                block_time_in_remote;

          intger := paging_info.page_in_count - active_block_stack_ptr^.paging_stats.page_in_count -
                active_block_stack_ptr^.subordinate_paging_stats.page_in_count;

          IF intger <= 0 THEN
            pages_in := 0;
          ELSE
            pages_in := intger;
            pmv$mpe_seq_descriptor.remote_execution_time_totals^ [current_block_no].block_paging_total.
                  page_in_count := pmv$mpe_seq_descriptor.remote_execution_time_totals^ [current_block_no].
                  block_paging_total.page_in_count + pages_in;
          IFEND;

          intger := paging_info.pages_reclaimed_from_queue -
                active_block_stack_ptr^.paging_stats.pages_reclaimed_from_queue -
                active_block_stack_ptr^.subordinate_paging_stats.pages_reclaimed_from_queue;

          IF intger <= 0 THEN
            pages_reclaimed := 0;
          ELSE
            pages_reclaimed := intger;
            pmv$mpe_seq_descriptor.remote_execution_time_totals^ [current_block_no].block_paging_total.
                  pages_reclaimed_from_queue := pmv$mpe_seq_descriptor.
                  remote_execution_time_totals^ [current_block_no].block_paging_total.
                  pages_reclaimed_from_queue + pages_reclaimed;
          IFEND;

          intger := paging_info.new_pages_assigned - active_block_stack_ptr^.paging_stats.new_pages_assigned -
                active_block_stack_ptr^.subordinate_paging_stats.new_pages_assigned;

          IF intger <= 0 THEN
            new_pages_assigned := 0;
          ELSE
            new_pages_assigned := intger;
            pmv$mpe_seq_descriptor.remote_execution_time_totals^ [current_block_no].block_paging_total.
                  new_pages_assigned := pmv$mpe_seq_descriptor.remote_execution_time_totals^
                  [current_block_no].block_paging_total.new_pages_assigned + new_pages_assigned;
          IFEND;

          intger := paging_info.page_fault_count - active_block_stack_ptr^.paging_stats.page_fault_count -
                active_block_stack_ptr^.subordinate_paging_stats.page_fault_count;

          IF intger <= 0 THEN
            page_fault_count := 0;
          ELSE
            page_fault_count := intger;
            pmv$mpe_seq_descriptor.remote_execution_time_totals^ [current_block_no].block_paging_total.
                  page_fault_count := pmv$mpe_seq_descriptor.remote_execution_time_totals^ [current_block_no].
                  block_paging_total.page_fault_count + page_fault_count;
          IFEND;

        IFEND;

        IF active_block_stack_ptr^.link <> NIL THEN
          IF reference_time > active_block_stack_ptr^.call_time THEN
            intger := reference_time - active_block_stack_ptr^.call_time;
          ELSE
            intger := 0;
          IFEND;

          active_block_stack_ptr^.link^.subordinate_time := active_block_stack_ptr^.link^.subordinate_time +
                intger;

          active_block_stack_ptr^.link^.subordinate_paging_stats.page_in_count :=
                active_block_stack_ptr^.link^.subordinate_paging_stats.page_in_count +
                (paging_info.page_in_count - active_block_stack_ptr^.paging_stats.page_in_count);

          active_block_stack_ptr^.link^.subordinate_paging_stats.pages_reclaimed_from_queue :=
                active_block_stack_ptr^.link^.subordinate_paging_stats.pages_reclaimed_from_queue +
                (paging_info.pages_reclaimed_from_queue - active_block_stack_ptr^.paging_stats.
                pages_reclaimed_from_queue);

          active_block_stack_ptr^.link^.subordinate_paging_stats.new_pages_assigned :=
                active_block_stack_ptr^.link^.subordinate_paging_stats.new_pages_assigned +
                (paging_info.new_pages_assigned - active_block_stack_ptr^.paging_stats.new_pages_assigned);

          active_block_stack_ptr^.link^.subordinate_paging_stats.page_fault_count :=
                active_block_stack_ptr^.link^.subordinate_paging_stats.page_fault_count +
                (paging_info.page_fault_count - active_block_stack_ptr^.paging_stats.page_fault_count);

          IF NOT active_block_stack_ptr^.block_id.local THEN
            current_block_no := active_block_stack_ptr^.link^.block_id.block_number;

            IF active_block_stack_ptr^.link^.block_id.local THEN
              intger := pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].
                    remote_total + (intger - active_block_stack_ptr^.subordinate_time);

              IF intger <= 0 THEN
                pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].remote_total := 0;
              ELSE
                pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].remote_total := intger;
              IFEND;

{ Calculate pages_in.

              intger := pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].
                    remote_paging_total.page_in_count + (paging_info.page_in_count -
                    active_block_stack_ptr^.paging_stats.page_in_count -
                    active_block_stack_ptr^.subordinate_paging_stats.page_in_count);

              IF intger <= 0 THEN
                pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].remote_paging_total.
                      page_in_count := 0;
              ELSE
                pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].remote_paging_total.
                      page_in_count := intger;
              IFEND;

{ Calculate pages_reclaimed.

              intger := pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].
                    remote_paging_total.pages_reclaimed_from_queue +
                    (paging_info.pages_reclaimed_from_queue - active_block_stack_ptr^.paging_stats.
                    pages_reclaimed_from_queue - active_block_stack_ptr^.subordinate_paging_stats.
                    pages_reclaimed_from_queue);

              IF intger <= 0 THEN
                pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].remote_paging_total.
                      pages_reclaimed_from_queue := 0;
              ELSE
                pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].remote_paging_total.
                      pages_reclaimed_from_queue := intger;
              IFEND;

{ Calculate new_pages_assigned.

              intger := pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].
                    remote_paging_total.new_pages_assigned + (paging_info.new_pages_assigned -
                    active_block_stack_ptr^.paging_stats.new_pages_assigned -
                    active_block_stack_ptr^.subordinate_paging_stats.new_pages_assigned);

              IF intger <= 0 THEN
                pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].remote_paging_total.
                      new_pages_assigned := 0;
              ELSE
                pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].remote_paging_total.
                      new_pages_assigned := intger;
              IFEND;

{ Calculate page_fault_count.

              intger := pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].
                    remote_paging_total.page_fault_count + (paging_info.page_fault_count -
                    active_block_stack_ptr^.paging_stats.page_fault_count -
                    active_block_stack_ptr^.subordinate_paging_stats.page_fault_count);

              IF intger <= 0 THEN
                pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].remote_paging_total.
                      page_fault_count := 0;
              ELSE
                pmv$mpe_seq_descriptor.local_execution_time_totals^ [current_block_no].remote_paging_total.
                      page_fault_count := intger;
              IFEND;

            ELSE

              pmv$mpe_seq_descriptor.remote_execution_time_totals^ [current_block_no].block_total :=
                    pmv$mpe_seq_descriptor.remote_execution_time_totals^ [current_block_no].block_total +
                    block_time_in_remote;
              pmv$mpe_seq_descriptor.remote_execution_time_totals^ [current_block_no].block_paging_total.
                    page_in_count := pmv$mpe_seq_descriptor.remote_execution_time_totals^ [current_block_no].
                    block_paging_total.page_in_count + pages_in;
              pmv$mpe_seq_descriptor.remote_execution_time_totals^ [current_block_no].block_paging_total.
                    pages_reclaimed_from_queue := pmv$mpe_seq_descriptor.
                    remote_execution_time_totals^ [current_block_no].block_paging_total.
                    pages_reclaimed_from_queue + pages_reclaimed;
              pmv$mpe_seq_descriptor.remote_execution_time_totals^ [current_block_no].block_paging_total.
                    new_pages_assigned := pmv$mpe_seq_descriptor.remote_execution_time_totals^ [
                    current_block_no].block_paging_total.new_pages_assigned + new_pages_assigned;
              pmv$mpe_seq_descriptor.remote_execution_time_totals^ [current_block_no].block_paging_total.
                    page_fault_count := pmv$mpe_seq_descriptor.remote_execution_time_totals^
                    [current_block_no].block_paging_total.page_fault_count + page_fault_count;

              active_block_stack_ptr^.link^.subordinate_time :=
                    active_block_stack_ptr^.link^.subordinate_time + active_block_stack_ptr^.subordinate_time;
              active_block_stack_ptr^.link^.subordinate_paging_stats.page_in_count :=
                    active_block_stack_ptr^.link^.subordinate_paging_stats.page_in_count +
                    active_block_stack_ptr^.subordinate_paging_stats.page_in_count;
              active_block_stack_ptr^.link^.subordinate_paging_stats.pages_reclaimed_from_queue :=
                    active_block_stack_ptr^.link^.subordinate_paging_stats.pages_reclaimed_from_queue +
                    active_block_stack_ptr^.subordinate_paging_stats.pages_reclaimed_from_queue;
              active_block_stack_ptr^.link^.subordinate_paging_stats.new_pages_assigned :=
                    active_block_stack_ptr^.link^.subordinate_paging_stats.new_pages_assigned +
                    active_block_stack_ptr^.subordinate_paging_stats.new_pages_assigned;
              active_block_stack_ptr^.link^.subordinate_paging_stats.page_fault_count :=
                    active_block_stack_ptr^.link^.subordinate_paging_stats.page_fault_count +
                    active_block_stack_ptr^.subordinate_paging_stats.page_fault_count;

              pmv$mpe_seq_descriptor.remote_execution_time_totals^
                    [active_block_stack_ptr^.block_id.block_number].number_of_calls :=
                    pmv$mpe_seq_descriptor.remote_execution_time_totals^
                    [active_block_stack_ptr^.block_id.block_number].number_of_calls - 1;
              pmv$mpe_seq_descriptor.remote_execution_time_totals^
                    [active_block_stack_ptr^.block_id.block_number].block_total :=
                    pmv$mpe_seq_descriptor.remote_execution_time_totals^
                    [active_block_stack_ptr^.block_id.block_number].block_total - block_time_in_remote;
              pmv$mpe_seq_descriptor.remote_execution_time_totals^
                    [active_block_stack_ptr^.block_id.block_number].block_paging_total.page_in_count :=
                    pmv$mpe_seq_descriptor.remote_execution_time_totals^
                    [active_block_stack_ptr^.block_id.block_number].block_paging_total.page_in_count -
                    pages_in;
              pmv$mpe_seq_descriptor.remote_execution_time_totals^
                    [active_block_stack_ptr^.block_id.block_number].block_paging_total.
                    pages_reclaimed_from_queue := pmv$mpe_seq_descriptor.
                    remote_execution_time_totals^ [active_block_stack_ptr^.block_id.block_number].
                    block_paging_total.pages_reclaimed_from_queue - pages_reclaimed;
              pmv$mpe_seq_descriptor.remote_execution_time_totals^
                    [active_block_stack_ptr^.block_id.block_number].block_paging_total.new_pages_assigned :=
                    pmv$mpe_seq_descriptor.remote_execution_time_totals^
                    [active_block_stack_ptr^.block_id.block_number].block_paging_total.new_pages_assigned -
                    new_pages_assigned;
              pmv$mpe_seq_descriptor.remote_execution_time_totals^
                    [active_block_stack_ptr^.block_id.block_number].block_paging_total.page_fault_count :=
                    pmv$mpe_seq_descriptor.remote_execution_time_totals^
                    [active_block_stack_ptr^.block_id.block_number].block_paging_total.page_fault_count -
                    page_fault_count;
            IFEND;
          IFEND;
        IFEND;

        pop_count := pop_count - 1;

        free_block_statistic (active_block_stack_ptr);
      WHILEND;


      IF NOT connectivity_matrix THEN
        IF active_block_stack_ptr <> NIL THEN
          IF active_block_stack_ptr^.block_id.local THEN
            detect_critical_reference (active_block_stack_ptr^.block_id.block_number, reference_time, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

    PROCEND pop_block_statistic;
?? OLDTITLE ??
?? NEWTITLE := '    determine_reference_type' ??
?? EJECT ??

    PROCEDURE determine_reference_type
      (VAR status: ost$status);


      VAR
        attribute_validation: ^fst$file_cycle_attributes,
        current_interblock_reference: pmt$interblock_reference,
        file_attachment: ^fst$attachment_options,
        file_id: amt$file_identifier,
        i: integer,
        ignore_status: ost$status,
        interblock_reference_string: ^array [1 .. * ] of pmt$interblock_reference,
        next_file_name: amt$local_file_name,
        number_of_segments: ost$positive_integers,
        previous_file_name: amt$local_file_name,
        segment: ost$positive_integers,
        segment_pointer: amt$segment_pointer;

      status.normal := TRUE;

      active_block_stack_ptr := NIL;
      block_working_set.link := NIL;
      free_block_statistic_list := NIL;
      free_block_working_set_list := NIL;
      last_block_entry_in_set := ^block_working_set;
      critical_reference_count := 0;

      PUSH file_attachment: [1 .. 1];
      file_attachment^ [1].selector := fsc$access_and_share_modes;
      file_attachment^ [1].access_modes.selector := fsc$specific_access_modes;
      file_attachment^ [1].access_modes.value := $fst$file_access_options [fsc$read, fsc$modify];
      file_attachment^ [1].share_modes.selector := fsc$determine_from_access_modes;

      PUSH attribute_validation: [1 .. 3];
      attribute_validation^ [1].selector := fsc$file_contents_and_processor;
      attribute_validation^ [1].file_contents := fsc$data;
      attribute_validation^ [1].file_processor := fsc$unknown_processor;
      attribute_validation^ [2].selector := fsc$file_organization;
      attribute_validation^ [2].file_organization := amc$sequential;
      attribute_validation^ [3].selector := fsc$record_type;
      attribute_validation^ [3].record_type := amc$undefined;

      PUSH updated_for_critical_reference: [0 .. pmv$loader_seq_descriptor^.local_block_id];
      IF updated_for_critical_reference = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;

      FOR i := 1 TO pmv$loader_seq_descriptor^.local_block_id DO
        updated_for_critical_reference^ [i] := 0;
      FOREND;

      number_of_segments := pmv$loader_seq_descriptor^.number_of_interblock_segments;
      pmv$loader_seq_descriptor^.number_of_interblock_segments := 1;
      FOR segment := 1 TO number_of_segments DO
        NEXT interblock_reference_string: [1 .. pmv$interblock_references_hdr^.
              number_of_interblock_references] IN pmv$loader_seq_descriptor^.last_interblock_segment;
        IF interblock_reference_string = NIL THEN
          osp$set_status_abnormal ('PM', pme$e_internal_apd_read_error, '', status);
          RETURN;
        IFEND;
        FOR i := 1 TO pmv$interblock_references_hdr^.number_of_interblock_references DO
          current_interblock_reference := interblock_reference_string^ [i];

          CASE current_interblock_reference.reference_type OF
          = pmc$call =
            push_block_statistic (current_interblock_reference.reference_time,
                  current_interblock_reference.block_id, current_interblock_reference.page_fault_stats,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

          = pmc$return =
            pop_block_statistic (current_interblock_reference.reference_time,
                  current_interblock_reference.page_fault_stats, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

          = pmc$final_return =
            IF active_block_stack_ptr <> NIL THEN
              pop_block_statistic (current_interblock_reference.reference_time,
                    current_interblock_reference.page_fault_stats, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;

          = pmc$pop =
            active_block_stack_ptr^.pop_count := active_block_stack_ptr^.pop_count + 1;

          ELSE
            osp$set_status_abnormal ('PM', pme$e_internal_apd_read_error, '', status);
            RETURN;

          CASEND;
        FOREND;

{ Open the next interblock reference file.  Return all files except the first
{ one as they are processed.

        next_file_name := pmv$interblock_references_hdr^.next_segment_file_name;
        IF next_file_name <> osc$null_name THEN
          IF segment = 1 THEN
            pmv$interblock_references_hdr^.next_segment_file_name := osc$null_name;
            fsp$close_file (pmv$interblock_references_hdr^.file_id, ignore_status);
            pmv$interblock_references_hdr := NIL;
          ELSE
            fsp$close_file (pmv$interblock_references_hdr^.file_id, ignore_status);
            pmv$interblock_references_hdr := NIL;
            amp$return (previous_file_name, ignore_status);
          IFEND;
          previous_file_name := next_file_name;

          fsp$open_file (next_file_name, amc$segment, file_attachment, NIL, NIL, attribute_validation,
                NIL, file_id, status);
          IF NOT status.normal THEN
            amp$return (next_file_name, ignore_status);
            RETURN;
          IFEND;

          amp$get_segment_pointer (file_id, amc$sequence_pointer, segment_pointer, status);
          IF NOT status.normal THEN
            fsp$close_file (file_id, ignore_status);
            amp$return (next_file_name, ignore_status);
            RETURN;
          IFEND;


          pmv$loader_seq_descriptor^.last_interblock_segment := segment_pointer.sequence_pointer;
          RESET pmv$loader_seq_descriptor^.last_interblock_segment;
          NEXT pmv$interblock_references_hdr IN pmv$loader_seq_descriptor^.last_interblock_segment;
          IF pmv$interblock_references_hdr = NIL THEN
            osp$set_status_abnormal ('PM', pme$e_internal_apd_read_error, '', status);
            fsp$close_file (file_id, ignore_status);
            amp$return (next_file_name, ignore_status);
            RETURN;
          IFEND;

          pmv$interblock_references_hdr^.file_id := file_id;
        ELSE
          IF segment <> 1 THEN
            fsp$close_file (pmv$interblock_references_hdr^.file_id, ignore_status);
            pmv$interblock_references_hdr := NIL;
            amp$return (previous_file_name, ignore_status);

            fsp$open_file (pmv$loader_seq_descriptor^.first_interblock_segment_name, amc$segment,
                  file_attachment, NIL, NIL, attribute_validation, NIL, file_id, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            amp$get_segment_pointer (file_id, amc$sequence_pointer, segment_pointer, status);
            IF NOT status.normal THEN
              fsp$close_file (file_id, ignore_status);
              RETURN;
            IFEND;

            pmv$loader_seq_descriptor^.last_interblock_segment := segment_pointer.sequence_pointer;
            RESET pmv$loader_seq_descriptor^.last_interblock_segment;
            NEXT pmv$interblock_references_hdr IN pmv$loader_seq_descriptor^.last_interblock_segment;
            IF pmv$interblock_references_hdr = NIL THEN
              osp$set_status_abnormal ('PM', pme$e_internal_apd_read_error, '', status);
              fsp$close_file (file_id, ignore_status);
              RETURN;
            IFEND;

            pmv$interblock_references_hdr^.file_id := file_id;
          IFEND;
        IFEND;
      FOREND;

    PROCEND determine_reference_type;
?? OLDTITLE ??
?? NEWTITLE := '    initialize_intercept_variables', EJECT ??

{ PURPOSE:
{   The purpose of this request is to initialize the variables in the
{   loader_seq_descriptor file that are used to manage the overhead time
{   generated while intercepting the program calls and returns of an
{   instrumented task.
{ DESIGN:
{   This procedure calculates the average values for some of the overhead
{   time generated in the APD intercept procedures which cannot be timed
{   during the intercept process.
{ NOTES:
{   This procedure is executed prior to executing an instrumented task.

    PROCEDURE initialize_intercept_variables
      (VAR loader_seq_descriptor_p: ^pmt$loader_seq_descriptor);

      VAR
        assemble_call_overhead: pmt$reference_time,
        assemble_return_overhead: pmt$reference_time,
        count: 1 .. 40,
        cp_time: array [1 .. 11] of pmt$apd_task_jobmode_statistics,
        i: 1 .. 40,
        intercept_overhead: pmt$reference_time,
        temp_time: pmt$reference_time;

      loader_seq_descriptor_p^.accumulated_intercept_time := 0;
      loader_seq_descriptor_p^.number_of_intercepted_calls := 0;
      loader_seq_descriptor_p^.number_of_intercepted_returns := 0;
      loader_seq_descriptor_p^.accum_intercept_call_time := 0;
      loader_seq_descriptor_p^.accum_intercept_return_time := 0;
      loader_seq_descriptor_p^.average_intercept_call_time := 0;
      loader_seq_descriptor_p^.average_intercept_return_time := 0;
      loader_seq_descriptor_p^.average_stats_request_time := 0;
      loader_seq_descriptor_p^.timed_call_overhead := 0;
      loader_seq_descriptor_p^.timed_return_overhead := 0;
      loader_seq_descriptor_p^.untimed_call_overhead := 0;
      loader_seq_descriptor_p^.untimed_return_overhead := 0;
      loader_seq_descriptor_p^.average_null_procedure_time := 0;

      count := 40;

{ Calculate the average time to execute a call to pmp$get_apd_task_jobmode_stats.

      temp_time := 0;

      FOR i := 1 TO 5 DO
        pmp$get_apd_task_jobmode_stats (cp_time [1]);
        pmp$get_apd_task_jobmode_stats (cp_time [2]);
        pmp$get_apd_task_jobmode_stats (cp_time [3]);
        pmp$get_apd_task_jobmode_stats (cp_time [4]);
        pmp$get_apd_task_jobmode_stats (cp_time [5]);
        pmp$get_apd_task_jobmode_stats (cp_time [6]);
        pmp$get_apd_task_jobmode_stats (cp_time [7]);
        pmp$get_apd_task_jobmode_stats (cp_time [8]);
        pmp$get_apd_task_jobmode_stats (cp_time [9]);
        pmp$get_apd_task_jobmode_stats (cp_time [10]);
        pmp$get_apd_task_jobmode_stats (cp_time [11]);
        temp_time := temp_time + ((cp_time [11].jobmode_cptime - cp_time [1].jobmode_cptime) DIV 10);
      FOREND;
      loader_seq_descriptor_p^.average_stats_request_time := temp_time DIV 5;

{ Calculate the average time to call a null procedure.

      pmp$get_apd_task_jobmode_stats (cp_time [1]);
      FOR i := 1 TO count DO
        execute_null_procedure;
      FOREND;
      pmp$get_apd_task_jobmode_stats (cp_time [2]);
      loader_seq_descriptor_p^.average_null_procedure_time := (cp_time [2].jobmode_cptime -
            cp_time [1].jobmode_cptime - loader_seq_descriptor_p^.average_stats_request_time)
            DIV count;

{ Calculate the average ASSEMBLE overhead time to intercept a call or return
{ that cannot be calculated in CYBIL.

      pmp$get_apd_task_jobmode_stats (cp_time [1]);
      FOR i := 1 TO count DO
        pmp$simulate_call_overhead;
      FOREND;
      pmp$get_apd_task_jobmode_stats (cp_time [2]);
      assemble_call_overhead := ((cp_time [2].jobmode_cptime - cp_time [1].jobmode_cptime -
            loader_seq_descriptor_p^.average_stats_request_time) DIV count) -
            loader_seq_descriptor_p^.average_null_procedure_time;

      pmp$get_apd_task_jobmode_stats (cp_time [1]);
      FOR i := 1 TO count DO
        pmp$simulate_return_overhead;
      FOREND;
      pmp$get_apd_task_jobmode_stats (cp_time [2]);
      assemble_return_overhead := ((cp_time [2].jobmode_cptime - cp_time [1].jobmode_cptime -
            loader_seq_descriptor_p^.average_stats_request_time) DIV count) -
            loader_seq_descriptor_p^.average_null_procedure_time;

{ Calculate the average overhead time to intercept a call or return that is
{ being timed by the intercept procedures.

      pmp$get_apd_task_jobmode_stats (cp_time [1]);
      FOR i := 1 TO count DO
        simulate_timed_request (loader_seq_descriptor_p);
      FOREND;
      pmp$get_apd_task_jobmode_stats (cp_time [2]);
      intercept_overhead := ((cp_time [2].jobmode_cptime - cp_time [1].jobmode_cptime -
            loader_seq_descriptor_p^.average_stats_request_time) DIV count) -
            loader_seq_descriptor_p^.average_null_procedure_time;

      loader_seq_descriptor_p^.timed_call_overhead := intercept_overhead + assemble_call_overhead;
      loader_seq_descriptor_p^.timed_return_overhead := intercept_overhead + assemble_return_overhead;

{ Calculate the average overhead time to intercept a call or return that is
{ not being timed by the intercept procedures.

      pmp$get_apd_task_jobmode_stats (cp_time [1]);
      FOR i := 1 TO count DO
        simulate_untimed_request (loader_seq_descriptor_p);
      FOREND;
      pmp$get_apd_task_jobmode_stats (cp_time [2]);
      intercept_overhead := ((cp_time [2].jobmode_cptime - cp_time [1].jobmode_cptime -
            loader_seq_descriptor_p^.average_stats_request_time) DIV count) -
            loader_seq_descriptor_p^.average_null_procedure_time;

      loader_seq_descriptor_p^.untimed_call_overhead := intercept_overhead + assemble_call_overhead;
      loader_seq_descriptor_p^.untimed_return_overhead := intercept_overhead + assemble_return_overhead;

      loader_seq_descriptor_p^.accumulated_intercept_time := 0;
      loader_seq_descriptor_p^.accum_intercept_call_time := 0;

    PROCEND initialize_intercept_variables;
?? OLDTITLE ??
?? NEWTITLE := '    simulate_timed_request', EJECT ??

{ PURPOSE:
{   The purpose of this request is to simulate overhead code in the APD
{   intercept procedures that is executed when the intercept procedures are
{   timing a call or return explicitly.
{ NOTES:
{   Modifications to the intercept procedures for calls and returns may
{   require similar modifications in this procedure.

    PROCEDURE simulate_timed_request
      (VAR loader_seq_descriptor_p: ^pmt$loader_seq_descriptor);

      VAR
        initial_cptime: [STATIC] pmt$reference_time := 171,
        statistics: pmt$apd_task_jobmode_statistics;

      pmp$get_apd_task_jobmode_stats (statistics);
      loader_seq_descriptor_p^.accumulated_intercept_time := loader_seq_descriptor_p^.
            accumulated_intercept_time + loader_seq_descriptor_p^.timed_call_overhead +
            (statistics.jobmode_cptime - initial_cptime);
      loader_seq_descriptor_p^.accum_intercept_call_time := loader_seq_descriptor_p^.
            accum_intercept_call_time + loader_seq_descriptor_p^.untimed_call_overhead +
            (statistics.jobmode_cptime - initial_cptime);

    PROCEND simulate_timed_request;
?? OLDTITLE ??
?? NEWTITLE := '    simulate_untimed_request', EJECT ??

{ PURPOSE:
{   The purpose of this request is to simulate overhead code in the APD
{   intercept procedures that is executed when the intercept procedures are
{   using an average value to time a call or return.
{ NOTES:
{   Modifications to the intercept procedures for calls and returns may
{   require similar modifications in this procedure.

    PROCEDURE simulate_untimed_request
      (VAR loader_seq_descriptor_p: ^pmt$loader_seq_descriptor);

      VAR
        statistics: pmt$apd_task_jobmode_statistics;

      pmp$get_apd_task_jobmode_stats (statistics);
      loader_seq_descriptor_p^.accumulated_intercept_time := loader_seq_descriptor_p^.
            accumulated_intercept_time + loader_seq_descriptor_p^.average_intercept_call_time;

    PROCEND simulate_untimed_request;
?? OLDTITLE ??
?? NEWTITLE := '    execute_null_procedure', EJECT ??

{ PURPOSE:
{   The purpose of this request is to execute a procedure consisting only of
{   PROCEDURE and PROCEND statements.

    PROCEDURE execute_null_procedure;
    PROCEND execute_null_procedure;
?? OLDTITLE ??
?? EJECT ??

    VAR
      date: ost$date,
      active_block_stack_ptr: ^pmt$block_statistic,
      block_working_set: pmt$working_set_block_reference,
      critical_reference_count: 0 .. 0ffffff(16),
      fetch_attr: array [1 .. 1] of amt$access_info,
      free_block_statistic_list: ^pmt$block_statistic,
      free_block_working_set_list: ^pmt$working_set_block_reference,
      i: 1 .. 10,
      ignore_status: ost$status,
      last_block_entry_in_set: ^pmt$working_set_block_reference,
      secondary_status: ost$status,
      task_id: pmt$task_id,
      task_status: pmt$task_status,
      updated_for_critical_reference: ^array [0 .. * ] of 0 .. 0ffffff(16);



    IF pmv$program_description = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_no_program_description, '', status);
      RETURN;
    IFEND;

    IF pmv$interblock_references_hdr <> NIL THEN
      fsp$close_file (pmv$interblock_references_hdr^.file_id, status);
      pmv$interblock_references_hdr := NIL;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF pmv$loader_seq_descriptor <> NIL THEN
      initialize_intercept_variables (pmv$loader_seq_descriptor);
      fsp$close_file (pmv$loader_seq_descriptor^.file_id, status);
      pmv$loader_seq_descriptor := NIL;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    pmp$execute_with_apd (pmv$program_description^, pmv$loader_description, parameter_list^, osc$wait,
          task_id, task_status, status);

    initialize_sequences (pmv$loader_description.mpe_loader_seq, pmv$loader_seq_descriptor, secondary_status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fetch_attr [1].key := amc$eoi_byte_address;
    amp$fetch_access_information (pmv$interblock_references_hdr^.file_id, fetch_attr, ignore_status);
    IF fetch_attr [1].eoi_byte_address > 1999999000 THEN
      pmp$log(' WARNING - statistics collected by EXEIT were truncated to 2 GB of data.', ignore_status);
    IFEND;

    IF NOT task_status.status.normal THEN
      status := task_status.status;
      RETURN;
    IFEND;

    IF NOT secondary_status.normal THEN
      status := secondary_status;
      RETURN;
    IFEND;

    pmv$mpe_seq_descriptor.number_of_runs := pmv$mpe_seq_descriptor.number_of_runs + 1;

    determine_reference_type (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


  PROCEND pmp$execute_instrumented_task;
?? EJECT ??
?? OLDTITLE ??
?? NEWTITLE := '  pmp$display_program_profile' ??

  PROCEDURE [XDCL] pmp$display_program_profile
    (    profile_order: pmt$profile_order;
         procedures: pmt$procedures;
         number: 0 .. 0ffffffff(16);
         output: clt$file;
     VAR status: ost$status);

{   purpose:
{     to produce and print a program profile report containing execution-
{     time and other pertinent program execution statistics on local blocks of a program as well
{     as the remote blocks that the program calls.

?? NEWTITLE := '    new_page_proc', EJECT ??

    PROCEDURE new_page_proc
      (VAR display_control: clt$display_control;
           new_page_number: integer;
       VAR status: ost$status);

      VAR
        l: integer;

      clp$reset_for_next_display_page (display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      STRINGREP (page_header (117, * ), l, display_control.page_number);
      clp$put_display (display_control, page_header, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$new_display_line (display_control, 2, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT first_entry THEN
        FOR i := 1 TO 3 DO
          clp$put_display (display_control, table_header [i], clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
        FOR i := 1 TO 3 DO
          clp$put_display (display_control, table_header2 [i], clc$trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
        clp$put_display (display_control, underline, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        first_entry := FALSE;
      IFEND;

    PROCEND new_page_proc;
?? OLDTITLE ??
?? NEWTITLE := '    sort_by_module_procedure', EJECT ??

    PROCEDURE sort_by_module_procedure
      (    block_name_array: ^array [0 .. * ] of pmt$block_name_map_entry;
       VAR index_array: ^array [0 .. * ] of pmt$block_id);



      VAR
        i: pmt$block_id,
        number_of_changes: -1 .. 7fffffff(16),
        temporary_index_array_entry: pmt$block_id,
        number_of_sort_passes: pmt$block_id;




      number_of_changes := UPPERBOUND (block_name_array^) - 1;

      REPEAT
        number_of_sort_passes := number_of_changes;
        number_of_changes := 0;

        FOR i := 1 TO number_of_sort_passes DO
          IF block_name_array^ [index_array^ [i]].module_name >
                block_name_array^ [index_array^ [i + 1]].module_name THEN
            number_of_changes := i - 1;
            temporary_index_array_entry := index_array^ [i];
            index_array^ [i] := index_array^ [i + 1];
            index_array^ [i + 1] := temporary_index_array_entry;
          IFEND;
        FOREND;
      UNTIL number_of_changes <= 0;

    PROCEND sort_by_module_procedure;
?? OLDTITLE ??
?? NEWTITLE := '    sort_by_procedure', EJECT ??

    PROCEDURE sort_by_procedure
      (    block_name_array: ^array [0 .. * ] of pmt$block_name_map_entry;
       VAR index_array: ^array [0 .. * ] of pmt$block_id);



      VAR
        i: pmt$block_id,
        number_of_changes: -1 .. 7fffffff(16),
        temporary_index_array_entry: pmt$block_id,
        number_of_sort_passes: pmt$block_id;




      number_of_changes := UPPERBOUND (block_name_array^) - 1;

      REPEAT
        number_of_sort_passes := number_of_changes;
        number_of_changes := 0;

        FOR i := 1 TO number_of_sort_passes DO
          IF block_name_array^ [index_array^ [i]].procedure_name >
                block_name_array^ [index_array^ [i + 1]].procedure_name THEN
            number_of_changes := i - 1;
            temporary_index_array_entry := index_array^ [i];
            index_array^ [i] := index_array^ [i + 1];
            index_array^ [i + 1] := temporary_index_array_entry;
          IFEND;
        FOREND;
      UNTIL number_of_changes <= 0;

    PROCEND sort_by_procedure;
?? OLDTITLE ??
?? NEWTITLE := '    sort_by_time', EJECT ??

    PROCEDURE sort_by_time
      (    execution_time_totals_array: ^array [0 .. * ] of pmt$execution_time_totals;
       VAR index_array: ^array [0 .. * ] of pmt$block_id);



      VAR
        i: pmt$block_id,
        number_of_changes: -1 .. 7ffffffff(16),
        temporary_index_array_entry: pmt$block_id,
        number_of_sort_passes: pmt$block_id;



      number_of_changes := UPPERBOUND (execution_time_totals_array^) - 1;

      REPEAT
        number_of_sort_passes := number_of_changes;
        number_of_changes := 0;


        FOR i := 1 TO number_of_sort_passes DO
          IF execution_time_totals_array^ [index_array^ [i]].
                block_total < execution_time_totals_array^ [index_array^ [i + 1]].block_total THEN
            number_of_changes := i - 1;
            temporary_index_array_entry := index_array^ [i];
            index_array^ [i] := index_array^ [i + 1];
            index_array^ [i + 1] := temporary_index_array_entry;
          IFEND;
        FOREND;
      UNTIL number_of_changes <= 0;

    PROCEND sort_by_time;
?? OLDTITLE ??
?? NEWTITLE := '    display_profile' ??
?? EJECT ??

    PROCEDURE display_profile
      (    index_array: ^array [0 .. * ] of pmt$block_id;
           number_to_print: integer;
           block_name_array: ^array [0 .. * ] of pmt$block_name_map_entry;
           execution_time_totals: ^array [0 .. * ] of pmt$execution_time_totals;
       VAR status: ost$status);

      VAR
        i,
        block_percentage,
        block_percentage_fraction,
        block_chargeback_percentage,
        blk_chargeback_percent_fraction,
        pages_in_chargeback,
        pages_in_chargeback_fraction,
        pages_reclaimed_chargeback,
        pages_reclaimed_fraction,
        new_pages_chargeback,
        new_pages_chargeback_fraction,
        total_pages_in,
        total_pages_reclaimed,
        total_new_pages,
        block_execution_time_in_seconds,
        current_index_array,
        how_many_to_print,
        block_execution_time_fraction: integer,
        block_chargeback_overflow: boolean,
        block_percentage_overflow: boolean,
        index: string (3),
        profile_template: [STATIC] string (120) := '                                                         '
              CAT '                  .             .               .             ',
        page_info_template: [STATIC] string (120) := ' ';

      status.normal := TRUE;

      how_many_to_print := number_to_print;

    /find_display_code_76/
      FOR i := 1 TO number_to_print DO
        IF block_name_array^ [index_array^ [i]].procedure_name = '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' THEN
          IF number_to_print < UPPERBOUND (block_name_array^) THEN
            how_many_to_print := number_to_print + 1;
          IFEND;
          EXIT /find_display_code_76/;
        IFEND;
      FOREND /find_display_code_76/;

      i := 1;

      WHILE i <= how_many_to_print DO

        block_percentage_overflow := FALSE;
        block_chargeback_overflow := FALSE;
        current_index_array := index_array^ [i];

{     a check is made here to get rid of block_name_array elements which contain a string of display-code-76
{     characters, indicating that this element is not to be printed.  this has been intended to inhibit the
{     printing of the zero-th element of both the local_ and remote_block_name_map

        IF block_name_array^ [current_index_array].procedure_name <> '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' THEN
          IF block_name_array^ [current_index_array].module_name = '{** REMOTE_MODULE **}' THEN
            profile_template (40, 31) := '   {** REMOTE_MODULE **}       ';
          ELSE
            profile_template (40, 31) := block_name_array^ [current_index_array].module_name;
          IFEND;
          profile_template (5, 31) := block_name_array^ [current_index_array].procedure_name;
          block_percentage := ((execution_time_totals^ [current_index_array].block_total * 10000) DIV
                program_microsec_execution_time) DIV 100;
          IF (execution_time_totals^ [current_index_array].block_total < 100000000000000) THEN
            block_percentage_fraction := ((execution_time_totals^ [current_index_array].block_total *
                  100000) DIV program_microsec_execution_time) MOD 1000;
          ELSE
            block_percentage_overflow := TRUE;
          IFEND;

          IF block_percentage < 0 THEN
            profile_template (87, 3) := '000';
          ELSE
            clp$convert_integer_to_rjstring (block_percentage, 10, FALSE, ' ', profile_template (87, 3),
                  status);
            IF NOT status.normal THEN
              profile_template (87, 3) := '000';
            IFEND;
          IFEND;

          IF block_percentage_overflow THEN
            profile_template (91, 3) := '***';
          ELSEIF block_percentage_fraction < 0 THEN
            profile_template (91, 3) := '000';
          ELSE
            clp$convert_integer_to_rjstring (block_percentage_fraction, 10, FALSE, '0',
                  profile_template (91, 3), status);
            IF NOT status.normal THEN
              profile_template (91, 3) := '000';
            IFEND;
          IFEND;

          block_execution_time_in_seconds := (execution_time_totals^ [current_index_array].block_total DIV
                1000) DIV 1000;
          block_execution_time_fraction := (execution_time_totals^ [current_index_array].block_total MOD
                1000000);

          IF block_execution_time_in_seconds < 0 THEN
            profile_template (71, 5) := '00000';
          ELSE
            clp$convert_integer_to_rjstring (block_execution_time_in_seconds, 10, FALSE, ' ',
                  profile_template (71, 5), status);
            IF NOT status.normal THEN
              profile_template (71, 5) := '*****';
            IFEND;
          IFEND;

          IF block_execution_time_fraction < 0 THEN
            profile_template (77, 6) := '000000';
          ELSE
            clp$convert_integer_to_rjstring (block_execution_time_fraction, 10, FALSE, '0',
                  profile_template (77, 6), status);
            IF NOT status.normal THEN
              profile_template (77, 6) := '000000';
            IFEND;
          IFEND;

          clp$convert_integer_to_rjstring (execution_time_totals^ [current_index_array].number_of_calls, 10,
                FALSE, ' ', profile_template (112, 8), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF block_name_array^ [current_index_array].module_name <> '{** REMOTE_MODULE **}' THEN
            profile_template (104, 1) := '.';
            block_chargeback_percentage := (((execution_time_totals^ [current_index_array].block_total +
                  execution_time_totals^ [current_index_array].remote_total) * 10000) DIV
                  program_microsec_execution_time) DIV 100;
            IF (execution_time_totals^ [current_index_array].remote_total < 100000000000000) AND
               (execution_time_totals^ [current_index_array].block_total < 100000000000000) AND
               ((execution_time_totals^ [current_index_array].block_total +
               execution_time_totals^ [current_index_array].remote_total) < 100000000000000) THEN
              blk_chargeback_percent_fraction := (((execution_time_totals^ [current_index_array].block_total +
                    execution_time_totals^ [current_index_array].remote_total) * 100000) DIV
                    program_microsec_execution_time) MOD 1000;
            ELSE
              block_chargeback_overflow := TRUE;
            IFEND;

            IF block_chargeback_percentage < 0 THEN
              profile_template (101, 3) := '000';
            ELSE
              clp$convert_integer_to_rjstring (block_chargeback_percentage, 10, FALSE, ' ',
                    profile_template (101, 3), status);
              IF NOT status.normal THEN
                profile_template (101, 3) := '000';
              IFEND;
            IFEND;

            IF block_chargeback_overflow THEN
              profile_template (105, 3) := '***';
            ELSEIF blk_chargeback_percent_fraction < 0 THEN
              profile_template (105, 3) := '000';
            ELSE
              clp$convert_integer_to_rjstring (blk_chargeback_percent_fraction, 10, FALSE, '0',
                    profile_template (105, 3), status);
              IF NOT status.normal THEN
                profile_template (105, 3) := '000';
              IFEND;
            IFEND;
          ELSE
            profile_template (101, 10) := '          ';
          IFEND;


          clp$put_display (display_control, profile_template, clc$no_trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$convert_integer_to_rjstring (execution_time_totals^ [current_index_array].block_paging_total.
                page_in_count, 10, FALSE, ' ', page_info_template (45, 8), status);
          IF NOT status.normal THEN
            page_info_template (48, 8) := '000';
          IFEND;

          clp$convert_integer_to_rjstring (execution_time_totals^ [current_index_array].block_paging_total.
                pages_reclaimed_from_queue, 10, FALSE, ' ', page_info_template (75, 8), status);
          IF NOT status.normal THEN
            page_info_template (76, 8) := '000';
          IFEND;

          clp$convert_integer_to_rjstring (execution_time_totals^ [current_index_array].block_paging_total.
                new_pages_assigned, 10, FALSE, ' ', page_info_template (100, 8), status);
          IF NOT status.normal THEN
            page_info_template (103, 8) := '000';
          IFEND;

          IF block_name_array^ [current_index_array].module_name <> '{** REMOTE_MODULE **}' THEN
            page_info_template (64, 1) := '.';
            page_info_template (90, 1) := '.';
            page_info_template (116, 1) := '.';

            total_pages_in := total_local_pages_in + total_remote_pages_in;
            IF total_pages_in <= 0 THEN
              page_info_template (61, 3) := '000';
            ELSE
              pages_in_chargeback := (((execution_time_totals^ [current_index_array].block_paging_total.
                    page_in_count + execution_time_totals^ [current_index_array].remote_paging_total.
                    page_in_count) * 10000) DIV total_pages_in) DIV 100;

              pages_in_chargeback_fraction := (((execution_time_totals^ [current_index_array].
                    block_paging_total.page_in_count + execution_time_totals^ [current_index_array].
                    remote_paging_total.page_in_count) * 100000) DIV total_pages_in) MOD 1000;

              IF pages_in_chargeback < 0 THEN
                page_info_template (61, 3) := '000';
              ELSE
                clp$convert_integer_to_rjstring (pages_in_chargeback, 10, FALSE, ' ',
                      page_info_template (61, 3), status);
                IF NOT status.normal THEN
                  page_info_template (61, 3) := '000';
                IFEND;
              IFEND;

              IF pages_in_chargeback_fraction < 0 THEN
                page_info_template (65, 3) := '000';
              ELSE
                clp$convert_integer_to_rjstring (pages_in_chargeback_fraction, 10, FALSE, '0',
                      page_info_template (65, 3), status);
                IF NOT status.normal THEN
                  page_info_template (65, 3) := '000';
                IFEND;
              IFEND;
            IFEND;

            total_pages_reclaimed := total_local_pages_reclaimed + total_remote_pages_reclaimed;
            IF total_pages_reclaimed <= 0 THEN
              page_info_template (87, 3) := '000';
            ELSE
              pages_reclaimed_chargeback := (((execution_time_totals^ [current_index_array].
                    block_paging_total.pages_reclaimed_from_queue +
                    execution_time_totals^ [current_index_array].remote_paging_total.
                    pages_reclaimed_from_queue) * 10000) DIV total_pages_reclaimed) DIV 100;

              pages_reclaimed_fraction := (((execution_time_totals^ [current_index_array].block_paging_total.
                    pages_reclaimed_from_queue + execution_time_totals^ [current_index_array].
                    remote_paging_total.pages_reclaimed_from_queue) * 100000) DIV total_pages_reclaimed) MOD
                    1000;

              IF pages_reclaimed_chargeback < 0 THEN
                page_info_template (87, 3) := '000';
              ELSE
                clp$convert_integer_to_rjstring (pages_reclaimed_chargeback, 10, FALSE, ' ',
                      page_info_template (87, 3), status);
                IF NOT status.normal THEN
                  page_info_template (87, 3) := '000';
                IFEND;
              IFEND;

              IF pages_reclaimed_fraction < 0 THEN
                page_info_template (91, 3) := '000';
              ELSE
                clp$convert_integer_to_rjstring (pages_reclaimed_fraction, 10, FALSE, '0',
                      page_info_template (91, 3), status);
                IF NOT status.normal THEN
                  page_info_template (91, 3) := '000';
                IFEND;
              IFEND;
            IFEND;

            total_new_pages := total_local_new_pages + total_remote_new_pages;
            IF total_new_pages <= 0 THEN
              page_info_template (113, 3) := '000';
            ELSE
              new_pages_chargeback := (((execution_time_totals^ [current_index_array].block_paging_total.
                    new_pages_assigned + execution_time_totals^ [current_index_array].remote_paging_total.
                    new_pages_assigned) * 10000) DIV total_new_pages) DIV 100;

              new_pages_chargeback_fraction := (((execution_time_totals^ [current_index_array].
                    block_paging_total.new_pages_assigned + execution_time_totals^ [current_index_array].
                    remote_paging_total.new_pages_assigned) * 100000) DIV total_new_pages) MOD 1000;

              IF new_pages_chargeback < 0 THEN
                page_info_template (113, 3) := '000';
              ELSE
                clp$convert_integer_to_rjstring (new_pages_chargeback, 10, FALSE, ' ',
                      page_info_template (113, 3), status);
                IF NOT status.normal THEN
                  page_info_template (113, 3) := '000';
                IFEND;
              IFEND;

              IF new_pages_chargeback_fraction < 0 THEN
                page_info_template (117, 3) := '000';
              ELSE
                clp$convert_integer_to_rjstring (new_pages_chargeback_fraction, 10, FALSE, '0',
                      page_info_template (117, 3), status);
                IF NOT status.normal THEN
                  page_info_template (117, 3) := '000';
                IFEND;
              IFEND;
            IFEND;
          ELSE
            page_info_template (60, 8) := '        ';
            page_info_template (86, 8) := '        ';
            page_info_template (112, 8) := '        ';
          IFEND;

          clp$put_display (display_control, page_info_template, clc$no_trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          clp$new_display_line (display_control, 1, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        IFEND;
        i := i + 1;
      WHILEND;

    PROCEND display_profile;
?? OLDTITLE ??
?? EJECT ??

    VAR
      time: ost$time,
      date: ost$date,
      i,
      j,
      program_total_execution_time,
      remote_block_total_percentage,
      remote_blk_tot_percent_fraction,
      total_page_faults,
      total_local_pages_in,
      total_local_pages_reclaimed,
      total_local_new_pages,
      total_local_page_faults,
      total_remote_pages_in,
      total_remote_pages_reclaimed,
      total_remote_new_pages,
      total_remote_page_faults,
      number_of_calls,
      program_tot_execution_fraction: integer,
      listable_name: amt$local_file_name,
      number_to_print: pmt$block_id,
      temp_string: ost$string,
      first_entry: boolean,
      number_of_local_program_units: [STATIC] string (41) := '   * NUMBER OF LOCAL PROGRAM UNITS = ',
      number_of_remote_program_units: [STATIC] string (42) := '   * NUMBER OF REMOTE PROGRAM UNITS = ',
      amount_to_print: [STATIC] string (28) := '   * NUMBER TO PRINT =      ',
      total_number_of_calls: [STATIC] string (45) := '   * TOTAL NUMBER OF CALLS = ',
      table_header: [STATIC] array [1 .. 3] of string (120) :=
            ['                                              ' CAT
            '                                                       BLOCK       NUMBER',
            '                                                                        EXECUTION    ' CAT
            '  BLOCK       CHARGEBACK      OF', '           PROGRAM_UNIT NAME                      MODULE' CAT
            ' NAME             TIME       PERCENTAGE    PERCENTAGE    CALLS'],
      table_header2: [STATIC] array [1 .. 3] of string (120) :=
            ['                                        ' CAT
            '                    BLOCK                      BLOCK                     BLOCK  ',
            '                                        ' CAT
            '      PAGES       CHARGEBACK      PAGES      CHARGEBACK       NEW     CHARGEBACK',
            '                                        ' CAT
            '        IN        PERCENTAGE    RECLAIMED    PERCENTAGE      PAGES    PERCENTAGE'],
      block_execution_time_in_seconds: [STATIC] integer := 0,
      last_module_name: [STATIC] pmt$program_name := osc$null_name,
      program_microsec_execution_time: integer,
      local_total: integer,
      remote_total: integer,
      underline: [STATIC] string (120) :=
            '____________________________________________________________________' CAT
            '____________________________________________________',
      number_of_collection_runs: [STATIC] string (45) := '   * NUMBER OF COLLECTION RUNS TO DATE =     ',
      initial_creation_date: [STATIC] string (37) := '   * INITIAL CREATION DATE =         ',
      total_program_execution_time: [STATIC] string (56) :=
            '   * TOTAL PROGRAM EXECUTION TIME =      .       SECONDS',
      remote_blk_total_percentage: [STATIC] string (45) := '   * REMOTE BLOCK TOTAL PERCENTAGE =    .   %',
      total_page_fault_line: [STATIC] string (35) := '   * TOTAL PAGE FAULTS =           ',
      total_local_page_in_count: [STATIC] string (42) := '   * TOTAL LOCAL PAGE IN COUNT =          ',
      total_local_page_reclaimed: [STATIC] string (55) := '   * TOTAL LOCAL PAGES RECLAIMED FROM QUEUE =' CAT
            '          ',
      total_local_new_page: [STATIC] string (47) := '   * TOTAL LOCAL NEW PAGES ASSIGNED =          ',
      total_remote_page_in_count: [STATIC] string (43) := '   * TOTAL REMOTE PAGE IN COUNT =          ',
      total_remote_page_reclaimed: [STATIC] string (56) :=
            '   * TOTAL REMOTE PAGES RECLAIMED FROM QUEUE =          ',
      total_remote_new_page: [STATIC] string (48) := '   * TOTAL REMOTE NEW PAGES ASSIGNED =          ',
      page_header: [STATIC] string (120) :=
            'MEASURE PROGRAM EXECUTION                                         ' CAT
            '                                             PAGE             ',
      profile_sorted_by: [STATIC] string (45) := '   * PROFILE SORTED BY                      ',
      target_text: [STATIC] string (51) := '   * TARGET TEXT =                                ',
      list_template: [STATIC] string (38) := '                                      ',
      starting_procedure: [STATIC] string (59) :=
            '   * STARTING PROCEDURE =                                  ',
      small_underline: [STATIC] string (18) := '     ------------',
      object_files: [STATIC] string (18) := '   * OBJECT FILES',
      modules: [STATIC] string (13) := '   * MODULES',
      libraries: [STATIC] string (15) := '   * LIBRARIES',
      stack_size: [STATIC] string (29) := '   * STACK SIZE =            ',
      object_file_list: ^pmt$object_file_list,
      module_list: ^pmt$module_list,
      object_library_list: ^pmt$object_library_list,
      program_attributes: ^pmt$program_attributes,
      pmv$loader_description: [XREF] pmt$loader_description,
      block_name_array: ^array [0 .. * ] of pmt$block_name_map_entry,
      execution_time_totals_array: ^array [0 .. * ] of pmt$execution_time_totals,
      index_array: ^array [0 .. * ] of pmt$block_id,
      display_control: clt$display_control;


    first_entry := TRUE;

    IF pmv$mpe_seq_descriptor.local_execution_time_totals = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_no_execution_time_totals, '', status);
      RETURN;
    IFEND;

    remote_total := 0;
    local_total := 0;

    FOR i := 1 TO pmv$loader_seq_descriptor^.local_block_id DO
      local_total := local_total + pmv$mpe_seq_descriptor.local_execution_time_totals^ [i].block_total;
    FOREND;

    FOR i := 1 TO pmv$loader_seq_descriptor^.remote_block_id DO
      remote_total := remote_total + pmv$mpe_seq_descriptor.remote_execution_time_totals^ [i].block_total;
    FOREND;

    IF ((remote_total + local_total) = 0) THEN
      osp$set_status_abnormal ('PM', pme$e_no_execution_time_totals, '', status);
      RETURN;
    IFEND;

{   construct page header.

    pmp$get_legible_date_time (osc$mdy_date, date, osc$ampm_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    page_header (75, 8) := date.mdy;
    page_header (60, 8) := time.hms;

    pmp$get_os_version (page_header (30, 22), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   print page header

    clp$open_display (output, ^new_page_proc, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   print number of collection runs to date.

    clp$convert_integer_to_string (pmv$mpe_seq_descriptor.number_of_runs, 10, FALSE, temp_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    number_of_collection_runs (42, 3) := temp_string.value (1, temp_string.size);
    clp$put_display (display_control, number_of_collection_runs, clc$no_trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   print initial creation date.

    initial_creation_date (30, 8) := pmv$mpe_seq_descriptor.creation_date;
    clp$put_display (display_control, initial_creation_date, clc$no_trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   compute and print total program execution time.

    program_microsec_execution_time := remote_total + local_total;

{   convert time in microseconds to seconds for display.

    program_total_execution_time := (program_microsec_execution_time DIV 1000) DIV 1000;
    program_tot_execution_fraction := program_microsec_execution_time MOD 1000000;
    clp$convert_integer_to_rjstring (program_total_execution_time, 10, FALSE, ' ',
          total_program_execution_time (37, 5), status);
    IF NOT status.normal THEN
      total_program_execution_time (37, 5) := '*****';
    IFEND;
    clp$convert_integer_to_rjstring (program_tot_execution_fraction, 10, FALSE, '0',
          total_program_execution_time (43, 6), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$put_display (display_control, total_program_execution_time, clc$no_trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   compute and print remote block total percentage.

    remote_block_total_percentage := ((10000 * remote_total) DIV program_microsec_execution_time) DIV 100;
    remote_blk_tot_percent_fraction := ((100000 * remote_total) DIV program_microsec_execution_time) MOD 1000;


    clp$convert_integer_to_rjstring (remote_block_total_percentage, 10, FALSE, ' ',
          remote_blk_total_percentage (38, 3), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$convert_integer_to_rjstring (remote_blk_tot_percent_fraction, 10, FALSE, '0',
          remote_blk_total_percentage (42, 3), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$put_display (display_control, remote_blk_total_percentage, clc$no_trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   compute and print total paging statistics

    total_local_pages_in := 0;
    total_local_pages_reclaimed := 0;
    total_local_new_pages := 0;
    total_local_page_faults := 0;

    total_remote_pages_in := 0;
    total_remote_pages_reclaimed := 0;
    total_remote_new_pages := 0;
    total_remote_page_faults := 0;

    FOR i := 1 TO pmv$loader_seq_descriptor^.local_block_id DO
      total_local_pages_in := total_local_pages_in + pmv$mpe_seq_descriptor.local_execution_time_totals^ [i].
            block_paging_total.page_in_count;
      total_local_pages_reclaimed := total_local_pages_reclaimed +
            pmv$mpe_seq_descriptor.local_execution_time_totals^ [i].block_paging_total.
            pages_reclaimed_from_queue;
      total_local_new_pages := total_local_new_pages + pmv$mpe_seq_descriptor.
            local_execution_time_totals^ [i].block_paging_total.new_pages_assigned;
      total_local_page_faults := total_local_page_faults +
            pmv$mpe_seq_descriptor.local_execution_time_totals^ [i].block_paging_total.page_fault_count;
    FOREND;

    FOR i := 1 TO pmv$loader_seq_descriptor^.remote_block_id DO
      total_remote_pages_in := total_remote_pages_in + pmv$mpe_seq_descriptor.
            remote_execution_time_totals^ [i].block_paging_total.page_in_count;
      total_remote_pages_reclaimed := total_remote_pages_reclaimed +
            pmv$mpe_seq_descriptor.remote_execution_time_totals^ [i].block_paging_total.
            pages_reclaimed_from_queue;
      total_remote_new_pages := total_remote_new_pages + pmv$mpe_seq_descriptor.
            remote_execution_time_totals^ [i].block_paging_total.new_pages_assigned;
      total_remote_page_faults := total_remote_page_faults +
            pmv$mpe_seq_descriptor.remote_execution_time_totals^ [i].block_paging_total.page_fault_count;
    FOREND;

    total_page_faults := total_local_page_faults + total_remote_page_faults;

    clp$convert_integer_to_rjstring (total_page_faults, 10, FALSE, ' ', total_page_fault_line (26, 8),
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$put_display (display_control, total_page_fault_line, clc$no_trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (total_local_pages_in, 10, FALSE, ' ', total_local_page_in_count (33, 7),
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$put_display (display_control, total_local_page_in_count, clc$no_trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (total_local_pages_reclaimed, 10, FALSE, ' ',
          total_local_page_reclaimed (46, 7), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$put_display (display_control, total_local_page_reclaimed, clc$no_trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (total_local_new_pages, 10, FALSE, ' ', total_local_new_page (38, 7),
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$put_display (display_control, total_local_new_page, clc$no_trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (total_remote_pages_in, 10, FALSE, ' ',
          total_remote_page_in_count (34, 7), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$put_display (display_control, total_remote_page_in_count, clc$no_trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (total_remote_pages_reclaimed, 10, FALSE, ' ',
          total_remote_page_reclaimed (48, 8), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$put_display (display_control, total_remote_page_reclaimed, clc$no_trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_rjstring (total_remote_new_pages, 10, FALSE, ' ', total_remote_new_page (39, 7),
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$put_display (display_control, total_remote_new_page, clc$no_trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   print program description variables

    RESET pmv$program_description;
    NEXT program_attributes IN pmv$program_description;
    IF program_attributes = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
      RETURN;
    IFEND;

    IF pmc$starting_proc_specified IN program_attributes^.contents THEN
      starting_procedure (27, 31) := program_attributes^.starting_procedure;
      clp$put_display (display_control, starting_procedure, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF pmc$max_stack_size_specified IN program_attributes^.contents THEN
      clp$convert_integer_to_string (program_attributes^.maximum_stack_size, 10, FALSE, temp_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      stack_size (19, 10) := temp_string.value (1, temp_string.size);
      clp$put_display (display_control, stack_size, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    pmp$get_last_path_name (pmv$loader_description.target_text.local_file_name, listable_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    target_text (20, 31) := listable_name;
    clp$put_display (display_control, target_text, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pmc$object_file_list_specified IN program_attributes^.contents THEN
      NEXT object_file_list: [1 .. program_attributes^.number_of_object_files] IN pmv$program_description;
      clp$put_display (display_control, object_files, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_display (display_control, small_underline, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      FOR i := 1 TO program_attributes^.number_of_object_files DO
        pmp$get_last_path_name (object_file_list^ [i], listable_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        list_template (8, 31) := listable_name;
        clp$put_display (display_control, list_template, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF pmc$module_list_specified IN program_attributes^.contents THEN
      NEXT module_list: [1 .. program_attributes^.number_of_modules] IN pmv$program_description;
      clp$put_display (display_control, modules, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_display (display_control, small_underline, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      FOR i := 1 TO program_attributes^.number_of_modules DO
        list_template (8, 31) := module_list^ [i];
        clp$put_display (display_control, list_template, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF pmc$library_list_specified IN program_attributes^.contents THEN
      NEXT object_library_list: [1 .. program_attributes^.number_of_libraries] IN pmv$program_description;
      clp$put_display (display_control, libraries, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$put_display (display_control, small_underline, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      FOR i := 1 TO program_attributes^.number_of_libraries DO
        pmp$get_last_path_name (object_library_list^ [i], listable_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        list_template (8, 31) := listable_name;
        clp$put_display (display_control, list_template, clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;


    CASE procedures OF

    = pmc$all =

{     the zero-th element of the local_block_name_map array and the local_execution_time_totals
{     array will be set to a string of display-code-76 characters (~) to facilitate checking
{     for these elements in the display_profile proc so that they will not be printed.

      pmv$loader_seq_descriptor^.local_block_name_map^ [0].procedure_name :=
            '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~';
      RESET pmv$loader_seq_descriptor^.seq_ptr TO pmv$loader_seq_descriptor^.remote_block_name_map;
      NEXT block_name_array: [0 .. (pmv$loader_seq_descriptor^.local_block_id +
            pmv$loader_seq_descriptor^.remote_block_id + 1)] IN pmv$loader_seq_descriptor^.seq_ptr;

      pmv$mpe_seq_descriptor.local_execution_time_totals^ [0].block_total := 0;
      RESET pmv$mpe_seq_descriptor.seq_ptr TO pmv$mpe_seq_descriptor.remote_execution_time_totals;
      NEXT execution_time_totals_array: [0 .. (pmv$loader_seq_descriptor^.local_block_id +
            pmv$loader_seq_descriptor^.remote_block_id + 1)] IN pmv$mpe_seq_descriptor.seq_ptr;

    = pmc$local =

      block_name_array := pmv$loader_seq_descriptor^.local_block_name_map;
      execution_time_totals_array := pmv$mpe_seq_descriptor.local_execution_time_totals;

    = pmc$remote =

      block_name_array := pmv$loader_seq_descriptor^.remote_block_name_map;
      execution_time_totals_array := pmv$mpe_seq_descriptor.remote_execution_time_totals;

    CASEND;

    PUSH index_array: [0 .. UPPERBOUND (block_name_array^)];
    FOR i := 1 TO UPPERBOUND (block_name_array^) DO
      index_array^ [i] := i;
    FOREND;

{   print the number of local program units and the number of remote program units.

    clp$convert_integer_to_string (pmv$loader_seq_descriptor^.local_block_id, 10, FALSE, temp_string, status);
    IF NOT status.normal THEN
      number_of_local_program_units (38, 4) := '****';
    ELSE
      number_of_local_program_units (38, 4) := temp_string.value (1, temp_string.size);
    IFEND;
    clp$put_display (display_control, number_of_local_program_units, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (pmv$loader_seq_descriptor^.remote_block_id, 10, FALSE, temp_string,
          status);
    IF NOT status.normal THEN
      number_of_remote_program_units (39, 4) := '****';
    ELSE
      number_of_remote_program_units (39, 4) := temp_string.value (1, temp_string.size);
    IFEND;
    clp$put_display (display_control, number_of_remote_program_units, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   print the total number of procedure calls for the measured program.

    number_of_calls := 0;

    FOR i := 1 TO pmv$loader_seq_descriptor^.remote_block_id DO
      number_of_calls := number_of_calls + pmv$mpe_seq_descriptor.remote_execution_time_totals^ [i].
            number_of_calls;
    FOREND;
    FOR i := 1 TO pmv$loader_seq_descriptor^.local_block_id DO
      number_of_calls := number_of_calls + pmv$mpe_seq_descriptor.local_execution_time_totals^ [i].
            number_of_calls;
    FOREND;

    clp$convert_integer_to_string (number_of_calls, 10, FALSE, temp_string, status);
    IF NOT status.normal THEN
      total_number_of_calls (30, 16) := '****************';
    ELSE
      total_number_of_calls (30, 16) := temp_string.value (1, temp_string.size);
    IFEND;
    clp$put_display (display_control, total_number_of_calls, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE profile_order OF

    = pmc$module_procedure =
      sort_by_module_procedure (block_name_array, index_array);
      profile_sorted_by (24, 21) := 'MODULE-PROGRAM_UNIT  ';

    = pmc$procedure =
      sort_by_procedure (block_name_array, index_array);
      profile_sorted_by (24, 21) := 'PROGRAM_UNIT         ';

    = pmc$time =
      sort_by_time (execution_time_totals_array, index_array);
      profile_sorted_by (24, 21) := 'TIME                 ';

    CASEND;

    clp$put_display (display_control, profile_sorted_by, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 1, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    number_to_print := number;
    IF (number_to_print > UPPERBOUND (block_name_array^)) AND (procedures = pmc$all) THEN
      number_to_print := UPPERBOUND (block_name_array^) - 1;
    ELSEIF number_to_print > UPPERBOUND (block_name_array^) THEN
      number_to_print := UPPERBOUND (block_name_array^);
    IFEND;

    clp$convert_integer_to_string (number_to_print, 10, FALSE, temp_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amount_to_print (24, 4) := temp_string.value (1, temp_string.size);
    clp$put_display (display_control, amount_to_print, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF number_to_print <> 0 THEN

      clp$new_display_line (display_control, 2, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF ((display_control.line_number + 11) > display_control.page_length) AND
            (display_control.page_format <> amc$continuous_form) THEN
        clp$new_display_page (display_control, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        FOR i := 1 TO 3 DO
          clp$put_display (display_control, table_header [i], clc$no_trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
        FOR i := 1 TO 3 DO
          clp$put_display (display_control, table_header2 [i], clc$no_trim, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
        clp$put_display (display_control, underline, clc$no_trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$new_display_line (display_control, 1, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      display_profile (index_array, number_to_print, block_name_array, execution_time_totals_array, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;


    IFEND;

    clp$close_display (display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND pmp$display_program_profile;

MODEND pmm$analyze_program_dynamics;
*DECK DECK=PMM$BROADCAST_UNSEEN_MAIL EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Program Control: Broadcast UNSEEN_MAIL Condition' ??
MODULE pmm$broadcast_unseen_mail;

{
{ PURPOSE:
{   This module contains the subsystem program interface to broadcast unseen_mail.
{

?? NEWTITLE := 'Global Declarations Referenced in this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*copyc jmp$send_job_message
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$broadcast_unseen_mail', EJECT ??
*copyc pmh$broadcast_unseen_mail

{ NOTE:
{   This request always returns normal status.

  PROCEDURE [XDCL, #GATE] pmp$broadcast_unseen_mail
    (    recipient_user: ost$user_identification;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      job_message: jmt$job_message;

      status.normal := TRUE;

      job_message.message_kind := jmc$jmk_unseen_mail_message;
      job_message.unseen_mail_message.user_id := recipient_user;
      jmp$send_job_message (pmc$null_mainframe_id, job_message, ignore_status);

  PROCEND pmp$broadcast_unseen_mail;
?? OLDTITLE ??
MODEND pmm$broadcast_unseen_mail;

*DECK DECK=PMM$CHANGE_OPERATION_PASSWRD_PD EXPAND=TRUE
create_program_description name=(change_operation_password, chaop) ..
      starting_procedure=pmp$_change_operation_password log_option=manual ..
      library=osf$current_library termination_error_level=warning ..
      load_map_options=none load_map=$null debug_mode=off
*DECK DECK=PMM$CHILD_TASK_MANAGEMENT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Tasking : Child task management' ??
MODULE pmm$child_task_management;

{  PURPOSE:
{    This module contains procedure which allow an executing task to
{    control the execution of its child tasks.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$processing_phase
*copyc mme$condition_codes
*copyc osd$virtual_address
*copyc osk$keypoints
*copyc oss$job_pageable
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc ost$status
*copyc ost$system_flag
*copyc pme$execution_exceptions
*copyc pme$insufficient_privilege
*copyc pme$task_term_while_inhibited
*copyc pmk$keypoints
*copyc pmt$task_id
*copyc tmc$wait_times
?? POP ??
*copyc clp$get_processing_phase
*copyc osp$establish_condition_handler
*copyc osp$generate_log_message
*copyc osp$system_error
*copyc osp$set_status_condition
*copyc pmp$exit
*copyc pmp$find_executing_task_tcb
*copyc pmp$find_executing_task_xcb
*copyc pmp$continue_to_cause
*copyc pmp$flag_all_child_tasks
*copyc pmp$long_term_wait
*copyc pmp$set_system_flag
*copyc pmp$verify_current_child
*copyc pmp$get_global_task_id
*copyc pmp$await_task_termination
*copyc pmv$debug_logging_enabled
*copyc pmv$task_execution_phase
*copyc pmv$task_term_inhibit_count
*copyc pmv$task_termination_attempted
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', ??

  VAR
    pmv$job_maximum_limit_exceeded: [XDCL, oss$job_pageable] boolean := FALSE;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$await_task', EJECT ??
*copyc pmh$await_task

{  PURPOSE:
{    This procedure waits until a specified child task of the executing
{    task terminates.

  PROCEDURE [XDCL, #GATE] pmp$await_task
    (    task_id: pmt$task_id;
     VAR wait_complete: boolean;
     VAR status: ost$status);

    VAR
      current_child: boolean;

?? NEWTITLE := 'condition_handler', EJECT ??

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      CASE condition.selector OF

      = ifc$interactive_condition, jmc$job_resource_condition =
        pmp$verify_current_child (task_id, current_child);
        wait_complete := NOT current_child;
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        EXIT pmp$await_task;

      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      CASEND;
    PROCEND condition_handler;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    IF (task_id < LOWERVALUE (pmt$task_id)) OR (task_id > UPPERVALUE (pmt$task_id)) THEN
      osp$set_status_condition (pme$invalid_task_id, status);
    ELSE
      current_child := TRUE;
      osp$establish_condition_handler (^condition_handler, {block_exit} FALSE);
      REPEAT
        pmp$verify_current_child (task_id, current_child);
        wait_complete := NOT current_child;
        IF current_child THEN
          pmp$long_term_wait (tmc$infinite_wait, tmc$infinite_wait);
        IFEND;
      UNTIL NOT current_child;
    IFEND;
  PROCEND pmp$await_task;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$terminate', EJECT ??
*copy pmh$terminate

{ PURPOSE:
{   This procedure terminates a specified child task of the executing task.
{   The executing task is suspended until the specified child task
{   terminates.
{
{ WARNING! This procedure follows the same protocol as pmp$terminate_task_without_wait (below).
{          Any change in this procedure also must be made to pmp$terminate_task_without_wait
{          to keep the procedures in sync.

  PROCEDURE [XDCL, #GATE] pmp$terminate
    (    task_id: pmt$task_id;
     VAR status: ost$status);

    VAR
      current_child: boolean,
      child_gtid: ost$global_task_id,
      local_status: ost$status;

    #KEYPOINT (osk$entry, task_id MOD 100000(16) * osk$m, pmk$terminate);
    IF (task_id < LOWERVALUE (pmt$task_id)) OR (task_id > UPPERVALUE (pmt$task_id)) THEN
      osp$set_status_condition (pme$invalid_task_id, status);
    ELSE
      status.normal := TRUE;
      pmp$verify_current_child (task_id, current_child);
      IF NOT current_child THEN
        osp$set_status_condition (pme$task_not_current_child, status);
      ELSE
        pmp$get_global_task_id (task_id, child_gtid, local_status);
        IF NOT local_status.normal THEN
          osp$system_error ('child XCB lost', NIL);
        ELSE
          pmp$set_system_flag (pmc$sf_terminate_task, child_gtid, local_status);
          IF NOT local_status.normal THEN
            IF local_status.condition = pme$unknown_recipient_task THEN

{ If we get to this point, the following has happened.  The child task is gone.
{ The parent has not recognized that fact yet.  The following request will
{ force the parent to recognize that fact when the task goes into wait.

              pmp$await_task_termination (task_id, status);
            ELSE
              osp$system_error ('unexpected abnormal status', ^local_status);
            IFEND;
          ELSE
            pmp$await_task_termination (task_id, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    #KEYPOINT (osk$exit, (1 - $INTEGER (status.normal)) * 0, pmk$terminate);
  PROCEND pmp$terminate;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$terminate_task_without_wait', EJECT ??

{ PURPOSE:
{   This procedure terminates a specified child task of the executing task.  The
{   executing task does NOT wait for termination of the child.  It is up to the
{   user of this procedure to check for termination of the child task.
{
{ WARNING! This procedure follows the same protocol as pmp$terminate (above).
{          Any change in this procedure also must be made to pmp$terminate
{          to keep the procedures in sync.

  PROCEDURE [XDCL, #GATE] pmp$terminate_task_without_wait
    (    task_id: pmt$task_id;
     VAR status: ost$status);

    VAR
      current_child: boolean,
      child_gtid: ost$global_task_id,
      local_status: ost$status;

    IF (task_id < LOWERVALUE (pmt$task_id)) OR (task_id > UPPERVALUE (pmt$task_id)) THEN
      osp$set_status_condition (pme$invalid_task_id, status);
    ELSE
      status.normal := TRUE;
      pmp$verify_current_child (task_id, current_child);
      IF NOT current_child THEN
        osp$set_status_condition (pme$task_not_current_child, status);
      ELSE
        pmp$get_global_task_id (task_id, child_gtid, local_status);
        IF NOT local_status.normal THEN
          osp$system_error ('child XCB lost', NIL);
        ELSE
          pmp$set_system_flag (pmc$sf_terminate_task, child_gtid, local_status);
          IF NOT local_status.normal THEN
            IF local_status.condition = pme$unknown_recipient_task THEN
              osp$set_status_condition (pme$task_not_current_child, status);
            ELSE
              osp$system_error ('unexpected abnormal status', ^local_status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pmp$terminate_task_without_wait;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$terminate_flag_handler', EJECT ??

{  PURPOSE:
{    This procedure is the handler for the system flag pmc$sf_terminate_task.
{    This system flag has a recognition ring of 4.
{
{  NOTE:
{    This procedure is triggered as a consequence of a PMP$TERMINATE request being issued in
{    the parent task of the executing task.

  PROCEDURE [XDCL] pmp$terminate_flag_handler
    (    flag_id: ost$system_flag);

    VAR
      xcb_p: ^ost$execution_control_block,
      local_status: ost$status,
      log_status: ^ost$status,
      processing_phase: clt$processing_phase,
      tcb_p: ^pmt$task_control_block;

{ If the task was terminated because the job file tables are full, abort
{ the task-specifying the reason for the task termination.

    IF flag_id = pmc$sf_terminate_task THEN
      pmp$find_executing_task_xcb (xcb_p);
      IF xcb_p^.ring1_termination_reason = osc$rtr_sft_full THEN
        osp$set_status_condition (mme$job_file_tables_full, local_status);
        pmp$exit (local_status);
      IFEND;
    IFEND;

{ This inhibits termination of child tasks in system epilog processing, and in system prolog
{ processing unless a job maximum limit has been reached.

    clp$get_processing_phase (processing_phase, local_status);
    IF ((processing_phase = clc$system_prolog_phase) AND (NOT pmv$job_maximum_limit_exceeded)) OR
          (processing_phase = clc$system_epilog_phase) THEN
      RETURN;
    IFEND;

    IF flag_id <> pmc$sf_terminate_task THEN
      osp$system_error ('misrouted flag', NIL);
    ELSE

{ If the task is executing and termination inhibit is not selected, the task will be
{ aborted.  If inhibit is selected, the termination attempt is postponed until the
{ inhibit is cleared.  If the task is terminating, the request is ignored.

      IF pmv$task_execution_phase = pmc$task_executing THEN
        IF pmv$task_term_inhibit_count > 0 THEN
          IF pmv$debug_logging_enabled THEN
            osp$set_status_condition (pme$task_term_while_inhibited, local_status);
            PUSH log_status;
            osp$generate_log_message ($pmt$ascii_logset [pmc$system_log, pmc$job_log], local_status,
                  log_status^);
          IFEND;
          pmv$task_termination_attempted := TRUE;
          RETURN;
        IFEND;
        osp$set_status_condition (pme$terminated_by_parent, local_status);
        pmp$exit (local_status);
      ELSE

{ The task is in the process of termination.  If it is a "normal" termination
{ set the termination status to indicate that the task was terminated by its parent.
{ This has the impact of delaying the popping of frames and loaded ring cleanup from being
{ exited due to a terminate task flag.  If a task is going through normal termination,
{ we need to set its termination status abnormal so it understands that its parent expects
{ it to terminate its children and complete termination.  After loaded ring cleanup is
{ complete, the task checks its termination status - if it is abnormal it flags its child
{ tasks - the task then waits for all of its children to termination.

        pmp$find_executing_task_tcb (tcb_p);
        IF (tcb_p^.task_kind = osc$tk_nosve_task) AND tcb_p^.nosve.termination_status^.normal THEN
          osp$set_status_condition (pme$terminated_by_parent, tcb_p^.nosve.termination_status^);
        IFEND;

{ The child tasks will be flagged if the parent is beyond executing any user code, ie. the
{ task execution phase is >= to pmc$task_termination_cleanup.  To execute this code
{ the parent had to be terminated abnormally.  Because of this, it is appropriate to
{ terminate the child tasks.

        IF pmv$task_execution_phase >= pmc$task_termination_cleanup THEN
          pmp$flag_all_child_tasks (pmc$sf_terminate_task, local_status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND pmp$terminate_flag_handler;
?? OLDTITLE ??

MODEND pmm$child_task_management;
*DECK DECK=PMM$CONDITION_STACK_PROCESSOR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Control - Program Conditions' ??
MODULE pmm$condition_stack_processor;


{   PURPOSE:
{     The purpose of this module is to isolate the knowledge of stacks
{     with respect to conditions, system flags, and signals.

{   DESIGN:
{     The procedures contained in this module are designed to execute
{     with traps enabled.  The module has an execute bracket of 2, 13.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_map_offsets
*copyc osd$code_base_pointer
*copyc osd$conditions
*copyc osd$registers
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc ost$name
*copyc ost$stack_frame_save_area
*copyc ost$virtual_machine_identifier
*copyc pme$condition_exceptions
*copyc pmk$keypoints
*copyc pmt$condition
*copyc pmt$condition_handler
*copyc pmt$condition_information
*copyc pmt$established_handler
*copyc pmt$established_handler_internl
*copyc pmt$minimum_save_area
?? POP ??
*copyc clp$validate_name
*copyc i#disable_traps
*copyc i#enable_traps
*copyc i#restore_traps
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc pmp$call_ring_crossing_proc
*copyc pmp$apd_call_to_users_procedure
*copyc pmp$continue_to_cause
*copyc pmp$purge_instruction_stack
*copyc pmp$ring_crossing_proc_return
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    maximum_descriptors = 100;

*copyc pmt$internal_condition

  TYPE
    comparable_pointer = 0 .. 0ffffffffffff(16);

?? EJECT ??

  TYPE
    p_address = packed record
      filler: 0 .. 0fffff(16),
      seg_offset: 0 .. 0fffffffffff(16),
    recend,

    pva = packed record
      ring: 0 .. 0f(16),
      seg: 0 .. 0fff(16),
      offset_sign: 0 .. 1,
      offset: 0 .. 7fffffff(16),
    recend,

    pointer_to_procedure = record
      case dummy: 0 .. 1 of
      = 0 =
        procedure_pointer: ^procedure,
      = 1 =
        cbp: ^p_address,
      casend,
    recend;


  VAR
    apd_call_to_users_procedure: [STATIC, READ, oss$job_paged_literal] pointer_to_procedure :=
          [0, ^pmp$apd_call_to_users_procedure];

?? OLDTITLE ??
?? NEWTITLE := 'condition selectors', EJECT ??

  VAR

{The following condition selectors are named for the detection of software errors which are
{reflected as hardware conditions. However, included in the selectors,
{implicitly via combination, is the hardware detected uncorrected error which is dealt with
{distinctly by the respective condition handler.

    handler_stack_error: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
          [pmc$condition_combination, $pmt$condition_combination
          [pmc$system_conditions, mmc$segment_access_condition]],
    stack_error: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
          [pmc$condition_combination, $pmt$condition_combination
          [pmc$system_conditions, mmc$segment_access_condition]];

  VAR
    unselectable_system_conditions: [STATIC, READ, oss$job_paged_literal] pmt$system_conditions :=
          $pmt$system_conditions [pmc$ua_unselectable, pmc$sw_unselectable, pmc$xr_unselectable,
          pmc$xi_unselectable, pmc$pf_unselectable, pmc$sc_unselectable, pmc$sit_unselectable,
          pmc$sel_unselectable, pmc$tx_unselectable, pmc$ff_unselectable, pmc$pit_unselectable,
          pmc$cff_unselectable, pmc$kypt_unselectable, pmc$debug_unselectable];

  VAR
    handler_inactive: [STATIC, READ, oss$job_paged_literal] pmt$condition_handler_active :=
          [$pmt$system_conditions [], [0, NIL]];

  VAR
    initialize_os_stack_frame_word: [STATIC, READ, oss$job_paged_literal] pmt$os_stack_frame_word :=
          [NIL, FALSE, FALSE, FALSE, FALSE, 0];

  VAR
    maskable_system_conditions: [STATIC, READ, oss$job_paged_literal] pmt$system_conditions :=
          $pmt$system_conditions [pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
          pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite, pmc$arithmetic_significance,
          pmc$invalid_bdp_data];


?? OLDTITLE ??
?? NEWTITLE := 'find_handler_in_stack_frame', EJECT ??


  PROCEDURE find_handler_in_stack_frame
    (    condition: pmt$internal_condition;
         current_sa: ^pmt$minimum_save_area;
         handler_stack: ^pmt$established_handler;
     VAR established_handler: ^pmt$established_handler;
     VAR status: ost$status);

    VAR
      number_descriptors_scanned: integer,
      established_handler_stack: ^pmt$established_handler,
      condition_segment: ost$segment,
      established_segment: ost$segment;

    established_handler := NIL;
    IF (handler_stack <> NIL) AND current_sa^.frame_descriptor.on_condition_flag THEN
      established_handler_stack := handler_stack;
      number_descriptors_scanned := 1;
      WHILE (established_handler = NIL) AND (established_handler_stack <> NIL) AND status.normal DO
        validate_descriptor_address (current_sa, established_handler_stack, status);
        IF established_handler_stack^.established AND status.normal THEN
          IF (established_handler_stack^.established_conditions.selector = pmc$all_conditions) THEN
            established_handler := established_handler_stack;
          ELSEIF (established_handler_stack^.established_conditions.selector = pmc$condition_combination) THEN
            IF (condition.class IN established_handler_stack^.established_conditions.combination) THEN
              established_handler := established_handler_stack;
            IFEND;
          ELSEIF (established_handler_stack^.established_conditions.selector = condition.class) THEN
            CASE condition.class OF
            = pmc$system_conditions =
              IF (condition.system IN established_handler_stack^.established_conditions.system_conditions)
                    THEN
                established_handler := established_handler_stack;
              IFEND;
            = pmc$block_exit_processing =
              IF ((established_handler_stack^.established_conditions.reason * condition.reason) <>
                    $pmt$block_exit_reason []) THEN
                established_handler := established_handler_stack;
              IFEND;
            = jmc$job_resource_condition =
              IF (condition.job_resource = established_handler_stack^.established_conditions.
                    job_resource_condition) THEN
                established_handler := established_handler_stack;
              IFEND;
            = mmc$segment_access_condition =
              condition_segment := #SEGMENT (condition.segment_access.segment);
              established_segment := #SEGMENT (established_handler_stack^.established_conditions.
                    segment_access_condition.segment);
              IF (condition_segment = established_segment) AND
                    (condition.segment_access.identifier = established_handler_stack^.established_conditions.
                    segment_access_condition.identifier) THEN
                established_handler := established_handler_stack;
              IFEND;
            = ifc$interactive_condition =
              IF (condition.interactive = established_handler_stack^.established_conditions.
                    interactive_condition) THEN
                established_handler := established_handler_stack;
              IFEND;
            = pmc$pit_condition =
              established_handler := established_handler_stack;
            = pmc$user_defined_condition =
              IF (condition.user_defined = established_handler_stack^.established_conditions.
                    user_condition_name) THEN
                established_handler := established_handler_stack;
              IFEND;
            ELSE
              osp$set_status_condition (pme$invalid_condition_selector, status);
            CASEND;
          IFEND;
        IFEND;
        IF (established_handler = NIL) AND status.normal THEN
          IF (established_handler_stack^.est_handler_stack <> NIL) THEN
            number_descriptors_scanned := number_descriptors_scanned + 1;
            IF number_descriptors_scanned > maximum_descriptors THEN
              osp$set_status_condition (pme$handler_stack_error, status);
            IFEND;
          IFEND;
          established_handler_stack := established_handler_stack^.est_handler_stack;
        IFEND;
      WHILEND;
    IFEND;
  PROCEND find_handler_in_stack_frame;
?? OLDTITLE ??
?? NEWTITLE := 'handler_stack', EJECT ??

  FUNCTION handler_stack
    (    save_area: ^pmt$minimum_save_area): ^pmt$established_handler;


    IF (save_area <> NIL) THEN
      IF save_area^.frame_descriptor.on_condition_flag THEN
        handler_stack := save_area^.a1_current_stack_frame^.established_handler;
      ELSE
        handler_stack := NIL;
      IFEND;
    ELSE
      handler_stack := NIL;
    IFEND;


  FUNCEND handler_stack;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$build_ring_crossing_frame', EJECT ??
*copyc pmh$build_ring_crossing_frame

  PROCEDURE [XDCL] pmp$build_ring_crossing_frame
    (    ring_crossing_sfsa: ^ost$stack_frame_save_area);

    VAR
      converter: record
        case 0 .. 1 of
        = 0 =
          procedure_pointer: ^procedure,
        = 1 =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend;

    VAR
      traps: 0 .. 3,
      new_stack_frame_address: ^cell,
      ring_crossing_procedure_pva: ^cell,
      ring_crossing_return_pva: ^cell,
      new_stack_frame_save_area: ^ost$stack_frame_save_area,
      previous_save_area: ^ost$stack_frame_save_area;


    converter.procedure_pointer := ^pmp$call_ring_crossing_proc;
    ring_crossing_procedure_pva := converter.code_base_pointer^.code_pva;

    converter.procedure_pointer := ^pmp$ring_crossing_proc_return;
    ring_crossing_return_pva := converter.code_base_pointer^.code_pva;

{  If a ring crossing procedure frame has already been inserted for this stack then do nothing.

    i#disable_traps (traps);
    IF (#SEGMENT (ring_crossing_sfsa^.minimum_save_area.a2_previous_save_area) =
          #SEGMENT (ring_crossing_sfsa^.minimum_save_area.a1_current_stack_frame)) THEN

{  A trap has occurred after tmp$find_ring_crossing_frame found the crossing frame but before it was returned
{  and so there is already a ring crossing frame in the stack

      i#restore_traps (traps);
      RETURN;

    ELSEIF (ring_crossing_sfsa^.minimum_save_area.p_register.pva.seg =
          #SEGMENT (ring_crossing_procedure_pva)) AND ((ring_crossing_sfsa^.minimum_save_area.p_register.pva.
          offset >= #OFFSET (ring_crossing_procedure_pva)) AND
          (ring_crossing_sfsa^.minimum_save_area.p_register.pva.offset <= #OFFSET (ring_crossing_return_pva)))
          THEN
      i#restore_traps (traps);
      RETURN;
    IFEND;

{  Put the new stack frame in the area reserved for it at the beginning of the stack.

    new_stack_frame_address := #ADDRESS (#RING (ring_crossing_sfsa^.minimum_save_area.a1_current_stack_frame),
          #SEGMENT (ring_crossing_sfsa^.minimum_save_area.a1_current_stack_frame),
          (#OFFSET (ring_crossing_sfsa^.minimum_save_area.a1_current_stack_frame) -
          mmc$ring_crossing_offset));
    new_stack_frame_save_area := new_stack_frame_address;
    new_stack_frame_save_area^.minimum_save_area.p_register.undefined1 := 0;
    previous_save_area := #PREVIOUS_SAVE_AREA ();
    new_stack_frame_save_area^.minimum_save_area.p_register.global_key :=
          previous_save_area^.minimum_save_area.p_register.global_key;
    new_stack_frame_save_area^.minimum_save_area.p_register.undefined2 := 0;
    new_stack_frame_save_area^.minimum_save_area.p_register.local_key :=
          previous_save_area^.minimum_save_area.p_register.local_key;
    new_stack_frame_save_area^.minimum_save_area.p_register.pva.ring := #RING (ring_crossing_sfsa);
    new_stack_frame_save_area^.minimum_save_area.p_register.pva.seg := #SEGMENT (ring_crossing_procedure_pva);
    new_stack_frame_save_area^.minimum_save_area.p_register.pva.offset :=
          #OFFSET (ring_crossing_procedure_pva);
    new_stack_frame_save_area^.minimum_save_area.vmid := converter.code_base_pointer^.vmid;
    new_stack_frame_save_area^.minimum_save_area.undefined := 0;
    new_stack_frame_save_area^.minimum_save_area.a0_dynamic_space_pointer := new_stack_frame_save_area;
    new_stack_frame_save_area^.minimum_save_area.frame_descriptor.critical_frame_flag := FALSE;
    new_stack_frame_save_area^.minimum_save_area.frame_descriptor.on_condition_flag := FALSE;
    new_stack_frame_save_area^.minimum_save_area.frame_descriptor.undefined := 0;
    new_stack_frame_save_area^.minimum_save_area.frame_descriptor.x_starting := 1;
    new_stack_frame_save_area^.minimum_save_area.frame_descriptor.a_terminating := 3;
    new_stack_frame_save_area^.minimum_save_area.frame_descriptor.x_terminating := 0;
    new_stack_frame_save_area^.minimum_save_area.a1_current_stack_frame := new_stack_frame_save_area;
    new_stack_frame_save_area^.minimum_save_area.user_mask := previous_save_area^.minimum_save_area.user_mask;
    new_stack_frame_save_area^.minimum_save_area.a2_previous_save_area :=
          ring_crossing_sfsa^.minimum_save_area.a2_previous_save_area;
    new_stack_frame_save_area^.a3 := converter.code_base_pointer^.binding_pva;

{ Put the address of the new stack frame save area into the previous save area field in the ring crossing
{ frame.  When the owner of the ring crossing frame returns, pmp$call_ring_crossing_proc will execute.

    ring_crossing_sfsa^.minimum_save_area.a2_previous_save_area := new_stack_frame_save_area;
    pmp$purge_instruction_stack;
    i#restore_traps (traps);

  PROCEND pmp$build_ring_crossing_frame;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$disestablish_cond_handler', EJECT ??
*copyc pmh$disestablish_cond_handler

  PROCEDURE [XDCL, #GATE] pmp$disestablish_cond_handler
    (    conditions: pmt$condition;
     VAR status: ost$status);


    VAR
      traps: 0 .. 3;

?? NEWTITLE := 'dispose_of_handler_stack_error', EJECT ??

    PROCEDURE dispose_of_handler_stack_error
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR c_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF (condition.selector <> pmc$system_conditions) OR ((condition.selector = pmc$system_conditions) AND
            NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
        osp$set_status_condition (pme$handler_stack_error, status);
        #KEYPOINT (osk$exit, 0, pmk$disestablish_cond_handler);
        i#restore_traps (traps);
        EXIT pmp$disestablish_cond_handler;
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, c_status,
              ignore_status);
      IFEND;
    PROCEND dispose_of_handler_stack_error;
?? OLDTITLE ??
?? NEWTITLE := 'disestablish_handler_in_frame', EJECT ??

    PROCEDURE disestablish_handler_in_frame
      (    conditions: pmt$condition;
           current_save_area: ^pmt$minimum_save_area;
       VAR disestablished: boolean;
       VAR local_status: ost$status);

      VAR
        number_descriptors_scanned: integer,
        handler_stack: ^pmt$established_handler;

?? NEWTITLE := 'should_cff_be_cleared', EJECT ??

      PROCEDURE should_cff_be_cleared
        (VAR critical_frame: boolean;
         VAR block_exit_frame: boolean);

        VAR
          executing_ring: ost$ring,
          descriptors_scanned: integer,
          handler: ^pmt$established_handler,
          status: ost$status;

        descriptors_scanned := number_descriptors_scanned;
        handler := handler_stack^.est_handler_stack;

        block_exit_frame := FALSE;

        WHILE ((handler <> NIL) AND status.normal) DO
          validate_descriptor_address (current_save_area, handler, status);
          IF status.normal THEN

{ The critical frame flag should remain set if there is a condition handler in the handler stack
{ whose condition selector includes pmc$block_exit_processing.

            IF handler^.established AND ((handler^.established_conditions.selector =
                  pmc$block_exit_processing) OR (handler^.established_conditions.selector =
                  pmc$all_conditions) OR ((handler^.established_conditions.selector =
                  pmc$condition_combination) AND (pmc$block_exit_processing IN
                  handler^.established_conditions.combination))) THEN
              critical_frame := TRUE;
              block_exit_frame := TRUE;
              RETURN;
            ELSE
              IF (handler^.est_handler_stack <> NIL) THEN
                IF descriptors_scanned >= maximum_descriptors THEN
                  critical_frame := TRUE;
                  RETURN;
                ELSE
                  descriptors_scanned := descriptors_scanned + 1;
                IFEND;
              IFEND;
              handler := handler^.est_handler_stack;
            IFEND;
          ELSE
            critical_frame := TRUE;
            RETURN;
          IFEND;
        WHILEND;

{ If this frame is a terminate inhibit, DEBUG or ADA critical frame then the
{ critical frame flag should not be cleared.

        critical_frame := current_save_area^.a1_current_stack_frame^.debug_cff_frame OR
              current_save_area^.a1_current_stack_frame^.terminate_inhibit_frame OR
              (current_save_area^.a1_current_stack_frame^.ada_critical_frame AND
              (current_save_area^.a1_current_stack_frame^.ada_critical_frame_count <> 0));

      PROCEND should_cff_be_cleared;
?? OLDTITLE, EJECT ??

      VAR
        block_exit_frame: boolean,
        critical_frame: boolean,
        handler_stack_pva: ^pva;

{DISESTABLISHED = FALSE and LOCAL_STATUS.NORMAL = TRUE on entry

      handler_stack_pva := #LOC (current_save_area^.a1_current_stack_frame^);

{ It is assumed that the handler stack pointer must be NIL or be a valid pointer in the
{ stack if the on condition flag (OCF) is set.

      IF ((handler_stack_pva^.ring = 0f(16)) AND ((handler_stack_pva^.seg = 0fff(16)) AND
            ((handler_stack_pva^.offset_sign = 1) AND (handler_stack_pva^.offset = 0)))) OR
            NOT current_save_area^.frame_descriptor.on_condition_flag THEN
        RETURN;
      IFEND;

      handler_stack := current_save_area^.a1_current_stack_frame^.established_handler;
      number_descriptors_scanned := 1;
      block_exit_frame := FALSE;
      REPEAT
        validate_descriptor_address (current_save_area, handler_stack, local_status);
        IF NOT local_status.normal THEN
          RETURN;
        IFEND;
        IF handler_stack^.established AND (conditions.selector =
              handler_stack^.established_conditions.selector) THEN
          CASE conditions.selector OF
          = pmc$all_conditions =
            disestablished := TRUE;
            block_exit_frame := TRUE;
          = pmc$system_conditions =
            disestablished := (conditions.system_conditions =
                  handler_stack^.established_conditions.system_conditions);
          = pmc$block_exit_processing =
            IF (conditions.reason = handler_stack^.established_conditions.reason) THEN
              disestablished := TRUE;
              block_exit_frame := TRUE;
            IFEND;
          = jmc$job_resource_condition =
            disestablished := (conditions.job_resource_condition =
                  handler_stack^.established_conditions.job_resource_condition);
          = mmc$segment_access_condition =
            disestablished := (conditions.segment_access_condition =
                  handler_stack^.established_conditions.segment_access_condition);
          = ifc$interactive_condition =
            disestablished := (conditions.interactive_condition =
                  handler_stack^.established_conditions.interactive_condition);
          = pmc$pit_condition =
            disestablished := TRUE;
          = pmc$user_defined_condition =
            disestablished := (conditions.user_condition_name =
                  handler_stack^.established_conditions.user_condition_name);
          = pmc$condition_combination =
            IF (conditions.combination = handler_stack^.established_conditions.combination) THEN
              disestablished := TRUE;
              block_exit_frame := pmc$block_exit_processing IN
                    handler_stack^.established_conditions.combination;
            IFEND;
          CASEND;

          IF disestablished THEN
            handler_stack^.established := FALSE;
            IF block_exit_frame THEN
              should_cff_be_cleared (critical_frame, block_exit_frame);
              current_save_area^.frame_descriptor.critical_frame_flag := critical_frame;
              current_save_area^.a1_current_stack_frame^.block_exit_frame := block_exit_frame;
            IFEND;
            RETURN;
          IFEND;

        IFEND;

        IF number_descriptors_scanned >= maximum_descriptors THEN
          osp$set_status_condition (pme$handler_stack_error, local_status);
          RETURN;
        IFEND;
        number_descriptors_scanned := number_descriptors_scanned + 1;
        handler_stack := handler_stack^.est_handler_stack;
      UNTIL handler_stack = NIL;

    PROCEND disestablish_handler_in_frame;
?? OLDTITLE, EJECT ??

    VAR
      condition_name: ost$name,
      current_save_area: ^pmt$minimum_save_area,
      descriptor: pmt$established_handler,
      disestablish_condition: pmt$condition,
      disestablish_status: ost$status,
      disestablished: boolean,
      disestablishing_save_area: ^pmt$minimum_save_area,
      p: ^p_address,
      sfsa: ^ost$stack_frame_save_area,
      stack_segment_ring: ost$ring,
      valid_name: boolean;

    i#enable_traps (traps);
    #KEYPOINT (osk$entry, 0, pmk$disestablish_cond_handler);

  /disestablish_a_handler/
    BEGIN
      IF ((conditions.selector < LOWERVALUE (pmt$condition_selector)) OR
            (conditions.selector > UPPERVALUE (pmt$condition_selector))) THEN
        osp$set_status_condition (pme$invalid_condition_selector, status);
        EXIT /disestablish_a_handler/;
      IFEND;

      disestablish_status.normal := TRUE;
      pmp$establish_condition_handler (handler_stack_error, ^dispose_of_handler_stack_error, ^descriptor,
            disestablish_status);
      disestablishing_save_area := #PREVIOUS_SAVE_AREA ();
      disestablished := FALSE;

      IF (conditions.selector = pmc$all_conditions) OR (conditions.selector = pmc$block_exit_processing) OR
            ((conditions.selector = pmc$condition_combination) AND
            (pmc$block_exit_processing IN conditions.combination)) THEN
        p := #LOC (disestablishing_save_area^);
        IF (p^.seg_offset = apd_call_to_users_procedure.cbp^.seg_offset) THEN
          pmp$validate_previous_save_area (#LOC (disestablishing_save_area^), disestablish_status);
          IF disestablish_status.normal THEN
            disestablishing_save_area := disestablishing_save_area^.a2_previous_save_area;
          ELSE
            status := disestablish_status;
            EXIT /disestablish_a_handler/;
          IFEND;
        IFEND;
        disestablish_handler_in_frame (conditions, disestablishing_save_area, disestablished,
              disestablish_status);

      ELSE
        disestablish_condition := conditions;
        IF (conditions.selector = pmc$user_defined_condition) THEN
          clp$validate_name (conditions.user_condition_name, condition_name, valid_name);
          IF valid_name THEN
            disestablish_condition.user_condition_name := condition_name;
          ELSE
            osp$set_status_condition (pme$incorrect_condition_name, status);
            EXIT /disestablish_a_handler/;
          IFEND;
        IFEND;
        stack_segment_ring := disestablishing_save_area^.p_register.pva.ring;
        current_save_area := disestablishing_save_area;
        REPEAT
          disestablish_handler_in_frame (disestablish_condition, current_save_area, disestablished,
                disestablish_status);
          IF NOT disestablished AND disestablish_status.normal THEN
            sfsa := #LOC (current_save_area^);
            pmp$validate_previous_save_area (sfsa, disestablish_status);
            current_save_area := current_save_area^.a2_previous_save_area;
          IFEND;
        UNTIL (NOT disestablish_status.normal OR disestablished OR (current_save_area = NIL) OR
              (current_save_area^.p_register.pva.ring <> stack_segment_ring));

      IFEND;

      IF disestablished THEN
        status.normal := TRUE;
      ELSEIF disestablish_status.normal THEN
        osp$set_status_condition (pme$no_established_handler, status);
      ELSE
        status := disestablish_status;
      IFEND;
    END /disestablish_a_handler/;

    #KEYPOINT (osk$exit, ((1 - $INTEGER (status.normal)) * 0), pmk$disestablish_cond_handler);
    i#restore_traps (traps);
  PROCEND pmp$disestablish_cond_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$enable_system_conditions', EJECT ??
*copy pmh$enable_system_conditions

  PROCEDURE [XDCL, #GATE] pmp$enable_system_conditions
    (    conditions: pmt$system_conditions;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmp$push_task_debug_mode
*copyc pmp$pop_task_debug_mode
?? POP ??

?? NEWTITLE := 'handle_pending_conditions', EJECT ??

{ The purpose of the following two procedures is to clear any pending system
{ conditions which are being enabled.

    PROCEDURE handle_pending_conditions
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      status.normal := TRUE;

    PROCEND handle_pending_conditions;
?? OLDTITLE ??
?? NEWTITLE := 'cause_pending_conditions', EJECT ??

    PROCEDURE cause_pending_conditions
      (    enable: ost$user_conditions);

      VAR
        sfsa: ^ost$stack_frame_save_area;

      sfsa := #PREVIOUS_SAVE_AREA ();

{ Setting the user mask in the caller's sfsa will cause any pending system conditions to arise when the
{ user mask is loaded from the sfsa on the return from this procedure.

      sfsa^.minimum_save_area.user_mask := (sfsa^.minimum_save_area.user_mask + enable);

    PROCEND cause_pending_conditions;
?? OLDTITLE, EJECT ??

    VAR
      enable: ost$user_conditions,
      enable_bit: ost$user_condition,
      requestor_sfsa: ^ost$stack_frame_save_area,
      system_condition: pmt$system_condition,
      user_enable: pmt$system_conditions,
      conditions_to_clear: pmt$condition,
      clear_descriptor: pmt$established_handler,
      ignore_status: ost$status;


    #KEYPOINT (osk$entry, 0, pmk$enable_system_conditions);

    status.normal := TRUE;

    IF (conditions <> $pmt$system_conditions []) THEN
      IF ((conditions - maskable_system_conditions) = $pmt$system_conditions []) THEN
        enable := $ost$user_conditions [];
        enable_bit := osc$divide_fault;
        system_condition := pmc$divide_fault;
        user_enable := conditions;

        WHILE (user_enable <> $pmt$system_conditions []) DO
          IF (system_condition IN user_enable) THEN
            enable := enable + $ost$user_conditions [enable_bit];
            user_enable := (user_enable - $pmt$system_conditions [system_condition]);
          IFEND;

          IF (system_condition < pmc$invalid_bdp_data) THEN
            system_condition := SUCC (system_condition);
            enable_bit := SUCC (enable_bit);
          IFEND;
        WHILEND;

        requestor_sfsa := #PREVIOUS_SAVE_AREA ();
        requestor_sfsa^.minimum_save_area.user_mask := (requestor_sfsa^.minimum_save_area.user_mask + enable);
        conditions_to_clear.selector := pmc$system_conditions;
        conditions_to_clear.system_conditions := conditions;

        pmp$establish_condition_handler (conditions_to_clear, ^handle_pending_conditions, ^clear_descriptor,
              ignore_status);

        pmp$push_task_debug_mode (pmc$debug_mode_off, ignore_status);
        cause_pending_conditions (enable);
        pmp$pop_task_debug_mode (ignore_status);
      ELSE
        osp$set_status_condition (pme$unselectable_condition, status);
      IFEND;
    IFEND;

    #KEYPOINT (osk$exit, 0, pmk$enable_system_conditions);

  PROCEND pmp$enable_system_conditions;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$establish_condition_handler', EJECT ??
*copy pmh$establish_condition_handler

{   WARNING: if this procedure must be modified the equivalent modifications must be made to
{            PMP$ESTABLISH_CH_IN_BLOCK.

  PROCEDURE [XDCL, #GATE] pmp$establish_condition_handler
    (    conditions: pmt$condition;
         condition_handler: pmt$condition_handler;
         establish_descriptor {input, output} : ^pmt$established_handler;
     VAR status: ost$status);

    VAR
      apd_stack_frame: boolean,
      condition_name: ost$name,
      csf: ^ost$pva,
      current_stack_frame: ^comparable_pointer,
      descriptor_address: ^comparable_pointer,
      dynamic_space_pointer: ^comparable_pointer,
      establish_status: ^ost$status,
      establishing_save_area: ^pmt$minimum_save_area,
      executing_stack: ^cell,
      handler_stack: ^pva,
      p: ^p_address,
      valid_name: boolean;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, pmk$establish_condition_handler);

    IF ((conditions.selector < LOWERVALUE (pmt$condition_selector)) OR
          (conditions.selector > UPPERVALUE (pmt$condition_selector))) THEN
      osp$set_status_condition (pme$invalid_condition_selector, status);
      #KEYPOINT (osk$exit, 0, pmk$establish_condition_handler);
      RETURN;
    IFEND;

    establishing_save_area := #PREVIOUS_SAVE_AREA ();

    REPEAT

{ validate current stack frame (a1) pointer

      csf := #LOC (establishing_save_area^.a1_current_stack_frame);

      IF ((csf^.ring <> #RING (^executing_stack)) OR (csf^.seg <> #SEGMENT (^executing_stack)) OR
            (establishing_save_area^.a0_dynamic_space_pointer.offset < (csf^.offset + 8))) THEN
        osp$set_status_condition (pme$inconsistent_stack, status);
        #KEYPOINT (osk$exit, 0, pmk$establish_condition_handler);
        RETURN;
      IFEND;

{ validate descriptor address

      descriptor_address := #LOC (establish_descriptor);
      current_stack_frame := #LOC (establishing_save_area^.a1_current_stack_frame);
      dynamic_space_pointer := #LOC (establishing_save_area^.a0_dynamic_space_pointer);

      IF (descriptor_address^ < (current_stack_frame^ +8)) OR
            ((descriptor_address^ + #SIZE (pmt$established_handler)) >= dynamic_space_pointer^) THEN

        p := #LOC (establishing_save_area^);
        IF (p^.seg_offset <> apd_call_to_users_procedure.cbp^.seg_offset) THEN
          osp$set_status_condition (pme$descriptor_address_error, status);
          #KEYPOINT (osk$exit, 0, pmk$establish_condition_handler);
          RETURN;
        IFEND;

        PUSH establish_status;
        pmp$validate_previous_save_area (#LOC (establishing_save_area^), establish_status^);
        IF NOT establish_status^.normal THEN
          status := establish_status^;
          #KEYPOINT (osk$exit, 0, pmk$establish_condition_handler);
          RETURN;
        IFEND;

        apd_stack_frame := TRUE;
        establishing_save_area := establishing_save_area^.a2_previous_save_area;
      ELSE
        apd_stack_frame := FALSE;
      IFEND;
    UNTIL NOT apd_stack_frame;

    establish_descriptor^.established_conditions := conditions;

    IF (conditions.selector = pmc$system_conditions) AND ((conditions.system_conditions *
          unselectable_system_conditions) <> $pmt$system_conditions []) THEN
      osp$set_status_condition (pme$unselectable_condition, status);
      #KEYPOINT (osk$exit, 0, pmk$establish_condition_handler);
      RETURN;
    IFEND;


    IF (conditions.selector = pmc$user_defined_condition) THEN
      clp$validate_name (conditions.user_condition_name, condition_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_condition (pme$incorrect_condition_name, status);
        #KEYPOINT (osk$exit, 0, pmk$establish_condition_handler);
        RETURN;
      IFEND;

      establish_descriptor^.established_conditions.user_condition_name := condition_name;
    IFEND;


    establish_descriptor^.handler_active := handler_inactive;
    establish_descriptor^.handler := condition_handler;
    establish_descriptor^.established := TRUE;


    IF NOT (establishing_save_area^.frame_descriptor.on_condition_flag) THEN
      establish_descriptor^.est_handler_stack := NIL;

{ Initialize the OS stack frame word.

      establishing_save_area^.a1_current_stack_frame^ := initialize_os_stack_frame_word;

    ELSE

{ validate current top of handler stack

      handler_stack := #LOC (establishing_save_area^.a1_current_stack_frame^);

{ It is assumed that the handler stack pointer must be NIL or be a valid pointer in the
{ stack if the on condition flag (OCF) is set.

      IF NOT ((handler_stack^.ring = 0f(16)) AND ((handler_stack^.seg = 0fff(16)) AND
            ((handler_stack^.offset_sign = 1) AND (handler_stack^.offset = 0)))) THEN
        IF (handler_stack^.ring <> #RING (^executing_stack)) OR
              ((handler_stack^.seg = #SEGMENT (^executing_stack)) AND
              (establishing_save_area^.a0_dynamic_space_pointer.offset <
              (handler_stack^.offset + #SIZE (pmt$established_handler)))) THEN
          osp$set_status_condition (pme$handler_stack_error, status);
          #KEYPOINT (osk$exit, 0, pmk$establish_condition_handler);
          RETURN;
        IFEND;
      IFEND;

      establish_descriptor^.est_handler_stack := establishing_save_area^.a1_current_stack_frame^.
            established_handler;
    IFEND;

    establishing_save_area^.a1_current_stack_frame^.established_handler := establish_descriptor;

    IF (conditions.selector = pmc$block_exit_processing) OR
          (conditions.selector = pmc$all_conditions) OR ((conditions.selector = pmc$condition_combination) AND
          (pmc$block_exit_processing IN conditions.combination)) THEN
      establishing_save_area^.frame_descriptor.critical_frame_flag := TRUE;
      establishing_save_area^.a1_current_stack_frame^.block_exit_frame := TRUE;
    IFEND;

    establishing_save_area^.frame_descriptor.on_condition_flag := TRUE;


    #KEYPOINT (osk$exit, 0, pmk$establish_condition_handler);


  PROCEND pmp$establish_condition_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$establish_ch_in_block', EJECT ??
*copy pmh$establish_ch_in_block

{   WARNING: if this procedure must be modified the equivalent modifications must be made to
{            PMP$ESTABLISH_CONDITION_HANDLER

  PROCEDURE [XDCL, #GATE] pmp$establish_ch_in_block
    (    conditions: pmt$condition;
         condition_handler: pmt$condition_handler;
         block: ^ost$stack_frame_save_area;
         establish_descriptor {input, output} : ^pmt$established_handler;
     VAR status: ost$status);

    VAR
      apd_stack_frame: boolean,
      condition_name: ost$name,
      csf: ^ost$pva,
      current_stack_frame: ^comparable_pointer,
      descriptor_address: ^comparable_pointer,
      establish_status: ^ost$status,
      establishing_save_area: ^pmt$minimum_save_area,
      handler_stack: ^pva,
      p: ^p_address,
      valid_name: boolean;

    #KEYPOINT (osk$entry, 0, pmk$establish_ch_in_block);

    status.normal := TRUE;

    IF ((conditions.selector < LOWERVALUE (pmt$condition_selector)) OR
          (conditions.selector > UPPERVALUE (pmt$condition_selector))) THEN
      osp$set_status_condition (pme$invalid_condition_selector, status);
      #KEYPOINT (osk$exit, 0, pmk$establish_ch_in_block);
      RETURN;
    IFEND;

    establishing_save_area := #LOC (block^);

    REPEAT

{ validate block's stack frame (a1) pointer

      csf := #LOC (establishing_save_area^.a1_current_stack_frame);

      IF ((csf^.ring <> #RING (block)) OR (csf^.seg <> #SEGMENT (block)) OR
            (establishing_save_area^.a0_dynamic_space_pointer.offset < (csf^.offset + 8))) THEN
        osp$set_status_condition (pme$inconsistent_stack, status);
        #KEYPOINT (osk$exit, 0, pmk$establish_ch_in_block);
        RETURN;
      IFEND;

{ validate descriptor address

      descriptor_address := #LOC (establish_descriptor);
      current_stack_frame := #LOC (establishing_save_area^.a1_current_stack_frame);

      IF (descriptor_address^ < (current_stack_frame^ +8)) THEN

        p := #LOC (establishing_save_area^);
        IF (p^.seg_offset <> apd_call_to_users_procedure.cbp^.seg_offset) THEN
          osp$set_status_condition (pme$descriptor_address_error, status);
          #KEYPOINT (osk$exit, 0, pmk$establish_ch_in_block);
          RETURN;
        IFEND;

        PUSH establish_status;
        pmp$validate_previous_save_area (#LOC (establishing_save_area^), establish_status^);
        IF NOT establish_status^.normal THEN
          status := establish_status^;
          #KEYPOINT (osk$exit, 0, pmk$establish_ch_in_block);
          RETURN;
        IFEND;

        apd_stack_frame := TRUE;
        establishing_save_area := establishing_save_area^.a2_previous_save_area;
      ELSE
        apd_stack_frame := FALSE;
      IFEND;
    UNTIL NOT apd_stack_frame;

    establish_descriptor^.established_conditions := conditions;

    IF (conditions.selector = pmc$system_conditions) AND ((conditions.system_conditions *
          unselectable_system_conditions) <> $pmt$system_conditions []) THEN
      osp$set_status_condition (pme$unselectable_condition, status);
      #KEYPOINT (osk$exit, 0, pmk$establish_ch_in_block);
      RETURN;
    IFEND;


    IF (conditions.selector = pmc$user_defined_condition) THEN
      clp$validate_name (conditions.user_condition_name, condition_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_condition (pme$incorrect_condition_name, status);
        #KEYPOINT (osk$exit, 0, pmk$establish_ch_in_block);
        RETURN;
      IFEND;

      establish_descriptor^.established_conditions.user_condition_name := condition_name;
    IFEND;


    establish_descriptor^.handler_active := handler_inactive;
    establish_descriptor^.handler := condition_handler;
    establish_descriptor^.established := TRUE;

    IF NOT (establishing_save_area^.frame_descriptor.on_condition_flag) THEN
      establish_descriptor^.est_handler_stack := NIL;

{ Initialize the OS stack frame word.

      establishing_save_area^.a1_current_stack_frame^ := initialize_os_stack_frame_word;

    ELSE

      handler_stack := #LOC (establishing_save_area^.a1_current_stack_frame^);

{ It is assumed that the handler stack pointer must be NIL or be a valid pointer in the
{ stack if the on condition flag (OCF) is set.

      IF NOT ((handler_stack^.ring = 0f(16)) AND ((handler_stack^.seg = 0fff(16)) AND
            ((handler_stack^.offset_sign = 1) AND (handler_stack^.offset = 0)))) THEN
        IF (handler_stack^.ring <> #RING (block)) OR ((handler_stack^.seg = #SEGMENT (block)) AND
              (establishing_save_area^.a0_dynamic_space_pointer.offset <
              (handler_stack^.offset + #SIZE (pmt$established_handler)))) THEN
          osp$set_status_condition (pme$handler_stack_error, status);
          #KEYPOINT (osk$exit, 0, pmk$establish_ch_in_block);
          RETURN;
        IFEND;
      IFEND;

      establish_descriptor^.est_handler_stack := establishing_save_area^.a1_current_stack_frame^.
            established_handler;
    IFEND;

    establishing_save_area^.a1_current_stack_frame^.established_handler := establish_descriptor;

    IF (conditions.selector = pmc$block_exit_processing) OR
          (conditions.selector = pmc$all_conditions) OR ((conditions.selector = pmc$condition_combination) AND
          (pmc$block_exit_processing IN conditions.combination)) THEN
      establishing_save_area^.frame_descriptor.critical_frame_flag := TRUE;
      establishing_save_area^.a1_current_stack_frame^.block_exit_frame := TRUE;
    IFEND;

    establishing_save_area^.frame_descriptor.on_condition_flag := TRUE;

    #KEYPOINT (osk$exit, 0, pmk$establish_ch_in_block);

  PROCEND pmp$establish_ch_in_block;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$establish_ch_outside_block', EJECT ??
*copy pmh$establish_ch_outside_block

{   WARNING: if this procedure must be modified the equivalent modifications must be made to
{            PMP$ESTABLISH_CH_IN_BLOCK.

  PROCEDURE [XDCL, #GATE] pmp$establish_ch_outside_block
    (    conditions: pmt$condition;
         condition_handler: pmt$condition_handler;
         block: ^ost$stack_frame_save_area;
         establish_descriptor {input, output} : ^pmt$established_handler;
     VAR status: ost$status);

    VAR
      condition_name: ost$name,
      csf: ^ost$pva,
      current_stack_frame: ^comparable_pointer,
      descriptor_address: ^comparable_pointer,
      dynamic_space_pointer: ^comparable_pointer,
      descriptor_internal_p: ^pmt$established_handler_internl,
      establish_status: ^ost$status,
      establishing_save_area: ^pmt$minimum_save_area,
      executing_stack: ^cell,
      handler_stack: ^pva,
      p: ^p_address,
      valid_name: boolean;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, pmk$establish_ch_outside_block);

    IF ((conditions.selector < LOWERVALUE (pmt$condition_selector)) OR
          (conditions.selector > UPPERVALUE (pmt$condition_selector))) THEN
      osp$set_status_condition (pme$invalid_condition_selector, status);
      #KEYPOINT (osk$exit, 0, pmk$establish_ch_outside_block);
      RETURN;
    IFEND;

{ Skip the apd stack frame if present.

    establishing_save_area := #LOC (block^);

    p := #LOC (establishing_save_area^);
    IF (p^.seg_offset = apd_call_to_users_procedure.cbp^.seg_offset) THEN

      PUSH establish_status;
      pmp$validate_previous_save_area (#LOC (establishing_save_area^), establish_status^);
      IF NOT establish_status^.normal THEN
        status := establish_status^;
        #KEYPOINT (osk$exit, 0, pmk$establish_condition_handler);
        RETURN;
      IFEND;

      establishing_save_area := establishing_save_area^.a2_previous_save_area;
    IFEND;

{ Validate that the descriptor is either not in the stack or in the stack before
{ the current stack frame.

    IF #SEGMENT (^executing_stack) = #SEGMENT (establish_descriptor) THEN

{ Validate current stack frame (a1) pointer.

      csf := #LOC (establishing_save_area^.a1_current_stack_frame);
      IF ((csf^.ring <> #RING (^executing_stack)) OR (csf^.seg <> #SEGMENT (^executing_stack)) OR
            (establishing_save_area^.a0_dynamic_space_pointer.offset < (csf^.offset + 8))) THEN
        osp$set_status_condition (pme$inconsistent_stack, status);
        #KEYPOINT (osk$exit, 0, pmk$establish_ch_outside_block);
        RETURN;
      IFEND;

{ validate descriptor address

      descriptor_address := #LOC (establish_descriptor);
      dynamic_space_pointer := #LOC (establishing_save_area^.a0_dynamic_space_pointer);

      IF (descriptor_address^ + #SIZE (pmt$established_handler)) >= dynamic_space_pointer^ THEN
        osp$set_status_condition (pme$descriptor_address_error, status);
        #KEYPOINT (osk$exit, 0, pmk$establish_ch_outside_block);
        RETURN;
      IFEND;
    IFEND;

    establish_descriptor^.established_conditions := conditions;

{ Verify the selected system conditions.

    IF (conditions.selector = pmc$system_conditions) AND ((conditions.system_conditions *
          unselectable_system_conditions) <> $pmt$system_conditions []) THEN
      osp$set_status_condition (pme$unselectable_condition, status);
      #KEYPOINT (osk$exit, 0, pmk$establish_ch_outside_block);
      RETURN;
    IFEND;

{ Verify the user condition name.

    IF (conditions.selector = pmc$user_defined_condition) THEN
      clp$validate_name (conditions.user_condition_name, condition_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_condition (pme$incorrect_condition_name, status);
        #KEYPOINT (osk$exit, 0, pmk$establish_ch_outside_block);
        RETURN;
      IFEND;

      establish_descriptor^.established_conditions.user_condition_name := condition_name;
    IFEND;

{ Add the descriptor to the callers condition stack.

    establish_descriptor^.handler_active := handler_inactive;
    establish_descriptor^.handler := condition_handler;
    establish_descriptor^.established := TRUE;
    descriptor_internal_p := #LOC (establish_descriptor^);
    descriptor_internal_p^.established_outside_block :=
           #SEGMENT (^executing_stack) <> #SEGMENT (establish_descriptor);

    IF NOT (establishing_save_area^.frame_descriptor.on_condition_flag) THEN
      establish_descriptor^.est_handler_stack := NIL;

{ Initialize the OS stack frame word.

      establishing_save_area^.a1_current_stack_frame^ := initialize_os_stack_frame_word;

    ELSE

{ validate current top of handler stack

      handler_stack := #LOC (establishing_save_area^.a1_current_stack_frame^);

{ It is assumed that the handler stack pointer must be NIL or be a valid pointer in the
{ stack if the on condition flag (OCF) is set.

      IF NOT ((handler_stack^.ring = 0f(16)) AND ((handler_stack^.seg = 0fff(16)) AND
            ((handler_stack^.offset_sign = 1) AND (handler_stack^.offset = 0)))) THEN
        IF (handler_stack^.ring <> #RING (^executing_stack)) OR
              ((handler_stack^.seg = #SEGMENT (^executing_stack)) AND
              (establishing_save_area^.a0_dynamic_space_pointer.offset <
              (handler_stack^.offset + #SIZE (pmt$established_handler)))) THEN
          osp$set_status_condition (pme$handler_stack_error, status);
          #KEYPOINT (osk$exit, 0, pmk$establish_ch_outside_block);
          RETURN;
        IFEND;
      IFEND;

      establish_descriptor^.est_handler_stack := establishing_save_area^.a1_current_stack_frame^.
            established_handler;
    IFEND;

    establishing_save_area^.a1_current_stack_frame^.established_handler := establish_descriptor;

    IF (conditions.selector = pmc$block_exit_processing) OR
          (conditions.selector = pmc$all_conditions) OR ((conditions.selector = pmc$condition_combination) AND
          (pmc$block_exit_processing IN conditions.combination)) THEN
      establishing_save_area^.frame_descriptor.critical_frame_flag := TRUE;
      establishing_save_area^.a1_current_stack_frame^.block_exit_frame := TRUE;
    IFEND;

    establishing_save_area^.frame_descriptor.on_condition_flag := TRUE;

    #KEYPOINT (osk$exit, 0, pmk$establish_ch_outside_block);

  PROCEND pmp$establish_ch_outside_block;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$find_handler_in_stack', EJECT ??

{   PURPOSE:
{     This procedure finds the most recently established handler for the
{     condition in the stack segment defined by save_area.

  PROCEDURE [XDCL] pmp$find_handler_in_stack
    (    condition: pmt$internal_condition;
         save_area: ^ost$stack_frame_save_area;
     VAR established_handler: ^pmt$established_handler;
     VAR handler_save_area: ^ost$stack_frame_save_area;
     VAR find_status: ost$status);

?? NEWTITLE := 'dispose_of_handler_stack_error', EJECT ??

    PROCEDURE dispose_of_handler_stack_error
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status;

      IF (condition.selector <> pmc$system_conditions) OR ((condition.selector = pmc$system_conditions) AND
            NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
        osp$set_status_condition (pme$handler_stack_error, find_status);
        EXIT pmp$find_handler_in_stack;
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, status,
              ignore_status);
      IFEND;
    PROCEND dispose_of_handler_stack_error;
?? OLDTITLE, EJECT ??


    VAR
      descriptor: pmt$established_handler,
      sfsa: ^ost$stack_frame_save_area,
      established_handler_stack: ^pmt$established_handler,
      current_sa: ^pmt$minimum_save_area,
      stack_segment_ring: ost$ring;


    find_status.normal := TRUE;

    pmp$establish_condition_handler (handler_stack_error, ^dispose_of_handler_stack_error, ^descriptor,
          find_status);

    current_sa := #LOC (save_area^);
    established_handler_stack := handler_stack (current_sa);
    stack_segment_ring := #RING (current_sa);
    established_handler := NIL;

    WHILE (established_handler = NIL) AND (current_sa <> NIL) AND (#RING (current_sa) =
          stack_segment_ring) AND find_status.normal DO

      find_handler_in_stack_frame (condition, current_sa, established_handler_stack, established_handler,
            find_status);
      IF find_status.normal THEN
        IF (established_handler = NIL) THEN
          sfsa := #LOC (current_sa^);

          pmp$validate_previous_save_area (sfsa, find_status);
          IF find_status.normal THEN
            current_sa := current_sa^.a2_previous_save_area;
            established_handler_stack := handler_stack (current_sa);
          IFEND;
        ELSE
          handler_save_area := #LOC (current_sa^);
        IFEND;
      IFEND;
    WHILEND;


  PROCEND pmp$find_handler_in_stack;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$find_next_handler_in_stack', EJECT ??

{   PURPOSE:
{     This procedure finds the next most recently established handler for the
{     condition in the stack segment defined by save_area.

  PROCEDURE [XDCL] pmp$find_next_handler_in_stack
    (    condition: pmt$internal_condition;
         save_area: ^ost$stack_frame_save_area;
         current_handler: ^pmt$established_handler;
     VAR established_handler: ^pmt$established_handler;
     VAR handler_save_area: ^ost$stack_frame_save_area;
     VAR find_status: ost$status);

    VAR
      starting_sa: ^ost$stack_frame_save_area,
      stack_segment_ring: ost$ring;

    find_status.normal := TRUE;
    IF (current_handler <> NIL) THEN
      handler_save_area := save_area;
      pmp$find_next_handler_in_frame (condition, save_area, current_handler, established_handler,
            find_status);
      IF find_status.normal THEN
        IF (established_handler = NIL) THEN
          pmp$validate_previous_save_area (save_area, find_status);
          IF find_status.normal THEN
            stack_segment_ring := #RING (save_area);
            IF (save_area^.minimum_save_area.a2_previous_save_area <> NIL) AND
                  (#RING (save_area^.minimum_save_area.a2_previous_save_area) = stack_segment_ring) THEN
              starting_sa := save_area^.minimum_save_area.a2_previous_save_area;
              pmp$find_handler_in_stack (condition, starting_sa, established_handler, handler_save_area,
                    find_status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    ELSE
      pmp$find_handler_in_stack (condition, save_area, established_handler, handler_save_area, find_status);
    IFEND;


  PROCEND pmp$find_next_handler_in_stack;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$find_handler_in_stack_frame', EJECT ??

{   PURPOSE:
{     This procedure finds the most recently established handler for the
{     condition in the stack frame defined by save_area.

  PROCEDURE [XDCL] pmp$find_handler_in_stack_frame
    (    condition: pmt$internal_condition;
         save_area: ^ost$stack_frame_save_area;
     VAR established_handler: ^pmt$established_handler;
     VAR handler_save_area: ^ost$stack_frame_save_area;
     VAR find_status: ost$status);

?? NEWTITLE := 'dispose_of_handler_stack_error', EJECT ??

    PROCEDURE dispose_of_handler_stack_error
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status;

      IF (condition.selector <> pmc$system_conditions) OR ((condition.selector = pmc$system_conditions) AND
            NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
        osp$set_status_condition (pme$handler_stack_error, find_status);
        EXIT pmp$find_handler_in_stack_frame;
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, status,
              ignore_status);
      IFEND;
    PROCEND dispose_of_handler_stack_error;
?? OLDTITLE, EJECT ??

    VAR
      descriptor: pmt$established_handler,
      current_sa: ^pmt$minimum_save_area,
      established_handler_stack: ^pmt$established_handler,
      ignore_status: ost$status;

    find_status.normal := TRUE;

    pmp$establish_condition_handler (handler_stack_error, ^dispose_of_handler_stack_error, ^descriptor,
          ignore_status);

    handler_save_area := save_area;
    current_sa := #LOC (save_area^);
    established_handler_stack := handler_stack (current_sa);

    find_handler_in_stack_frame (condition, current_sa, established_handler_stack, established_handler,
          find_status);


  PROCEND pmp$find_handler_in_stack_frame;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$find_next_handler_in_frame', EJECT ??

{   PURPOSE:
{     This procedure finds the next most recently established handler for the
{     condition in the stack frame defined by save_area.

  PROCEDURE [XDCL] pmp$find_next_handler_in_frame
    (    condition: pmt$internal_condition;
         save_area: ^ost$stack_frame_save_area;
         current_handler: ^pmt$established_handler;
     VAR established_handler: ^pmt$established_handler;
     VAR find_status: ost$status);

?? NEWTITLE := 'dispose_of_handler_stack_error', EJECT ??

    PROCEDURE dispose_of_handler_stack_error
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status;

      IF (condition.selector <> pmc$system_conditions) OR ((condition.selector = pmc$system_conditions) AND
            NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
        osp$set_status_condition (pme$handler_stack_error, find_status);
        EXIT pmp$find_next_handler_in_frame;
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, status,
              ignore_status);
      IFEND;
    PROCEND dispose_of_handler_stack_error;
?? OLDTITLE, EJECT ??

    VAR
      descriptor: pmt$established_handler,
      current_sa: ^pmt$minimum_save_area,
      established_handler_stack: ^pmt$established_handler,
      ignore_status: ost$status;


    find_status.normal := TRUE;

    pmp$establish_condition_handler (handler_stack_error, ^dispose_of_handler_stack_error, ^descriptor,
          ignore_status);
    current_sa := #LOC (save_area^);
    established_handler_stack := current_handler^.est_handler_stack;

    find_handler_in_stack_frame (condition, current_sa, established_handler_stack, established_handler,
          find_status);


  PROCEND pmp$find_next_handler_in_frame;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$inhibit_system_conditions', EJECT ??
*copy pmh$inhibit_system_conditions

  PROCEDURE [XDCL, #GATE] pmp$inhibit_system_conditions
    (    conditions: pmt$system_conditions;
     VAR status: ost$status);


    VAR
      inhibit: ost$user_conditions,
      inhibit_bit: ost$user_condition,
      requestor_sfsa: ^ost$stack_frame_save_area,
      system_condition: pmt$system_condition,
      user_inhibit: pmt$system_conditions;


    #KEYPOINT (osk$entry, 0, pmk$inhibit_system_conditions);

    status.normal := TRUE;

    IF (conditions <> $pmt$system_conditions []) THEN
      IF ((conditions - maskable_system_conditions) = $pmt$system_conditions []) THEN
        inhibit := $ost$user_conditions [];
        inhibit_bit := osc$divide_fault;
        system_condition := pmc$divide_fault;
        user_inhibit := conditions;

        WHILE (user_inhibit <> $pmt$system_conditions []) DO
          IF (system_condition IN user_inhibit) THEN
            inhibit := inhibit + $ost$user_conditions [inhibit_bit];
            user_inhibit := (user_inhibit - $pmt$system_conditions [system_condition]);
          IFEND;

          IF (system_condition < pmc$invalid_bdp_data) THEN
            system_condition := SUCC (system_condition);
            inhibit_bit := SUCC (inhibit_bit);
          IFEND;
        WHILEND;

        requestor_sfsa := #PREVIOUS_SAVE_AREA ();
        requestor_sfsa^.minimum_save_area.user_mask := (requestor_sfsa^.minimum_save_area.user_mask -
              inhibit);
      ELSE
        osp$set_status_condition (pme$unselectable_condition, status);
      IFEND;
    IFEND;

    #KEYPOINT (osk$exit, 0, pmk$inhibit_system_conditions);

  PROCEND pmp$inhibit_system_conditions;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$is_there_a_handler_in_stack', EJECT ??

{   PURPOSE:
{     This procedure returns if an established handler has been found
{     on the stack segment defined by save_area.  If not the last frame
{     on the stack is returned.

  PROCEDURE [XDCL] pmp$is_there_a_handler_in_stack
    (    condition: pmt$internal_condition;
         save_area: ^ost$stack_frame_save_area;
     VAR established_handler: ^pmt$established_handler;
     VAR handler_save_area: ^ost$stack_frame_save_area;
     VAR find_status: ost$status);

?? NEWTITLE := 'dispose_of_handler_stack_error', EJECT ??

    PROCEDURE dispose_of_handler_stack_error
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status;

      IF (condition.selector <> pmc$system_conditions) OR ((condition.selector = pmc$system_conditions) AND
            NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
        osp$set_status_condition (pme$handler_stack_error, find_status);
        EXIT pmp$is_there_a_handler_in_stack;
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, status,
              ignore_status);
      IFEND;
    PROCEND dispose_of_handler_stack_error;
?? OLDTITLE, EJECT ??


    VAR
      descriptor: pmt$established_handler,
      sfsa: ^ost$stack_frame_save_area,
      established_handler_stack: ^pmt$established_handler,
      current_sa: ^pmt$minimum_save_area,
      stack_segment_ring: ost$ring;


    find_status.normal := TRUE;

    pmp$establish_condition_handler (handler_stack_error, ^dispose_of_handler_stack_error, ^descriptor,
          find_status);

    current_sa := #LOC (save_area^);
    established_handler_stack := handler_stack (current_sa);
    stack_segment_ring := #RING (current_sa);
    established_handler := NIL;

    WHILE (established_handler = NIL) AND (#RING (current_sa) = stack_segment_ring) AND find_status.normal DO

      find_handler_in_stack_frame (condition, current_sa, established_handler_stack, established_handler,
            find_status);
      IF find_status.normal THEN
        IF (established_handler = NIL) THEN
          IF (current_sa^.a2_previous_save_area <> NIL) AND (#RING (current_sa^.a2_previous_save_area) =
                stack_segment_ring) THEN

            sfsa := #LOC (current_sa^);
            pmp$validate_previous_save_area (sfsa, find_status);
            IF find_status.normal THEN
              current_sa := current_sa^.a2_previous_save_area;
              established_handler_stack := handler_stack (current_sa);
            IFEND;
          ELSE
            handler_save_area := #LOC (current_sa^);
            RETURN;
          IFEND;
        ELSE
          handler_save_area := #LOC (current_sa^);
        IFEND;
      IFEND;
    WHILEND;


  PROCEND pmp$is_there_a_handler_in_stack;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$validate_previous_save_area', EJECT ??
*copy pmh$validate_previous_save_area

  PROCEDURE [XDCL, #GATE] pmp$validate_previous_save_area
    (    current_save_area: ^ost$stack_frame_save_area;
     VAR status: ost$status);

    VAR
      traps: 0 .. 3;

?? NEWTITLE := 'dispose_of_stack_error', EJECT ??

    PROCEDURE dispose_of_stack_error
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF (condition.selector <> pmc$system_conditions) OR ((condition.selector = pmc$system_conditions) AND
            NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
        osp$set_status_condition (pme$inconsistent_stack, status);
        i#restore_traps (traps);
        #KEYPOINT (osk$exit, 0, pmk$validate_previous_save_area);
        EXIT pmp$validate_previous_save_area;
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, condition_status,
              ignore_status);
      IFEND;

    PROCEND dispose_of_stack_error;
?? OLDTITLE, EJECT ??


    VAR
      psa: ^ost$stack_frame_save_area, {previous_save_area}
      current_psa: ^cell,
      descriptor: pmt$established_handler,
      ignore_status: ost$status;


    #KEYPOINT (osk$entry, 0, pmk$validate_previous_save_area);
    i#enable_traps (traps);
    status.normal := TRUE;

    pmp$establish_condition_handler (stack_error, ^dispose_of_stack_error, ^descriptor, ignore_status);

    IF (current_save_area^.minimum_save_area.a2_previous_save_area <> NIL) THEN
      psa := current_save_area^.minimum_save_area.a2_previous_save_area;
      current_psa := current_save_area^.minimum_save_area.a2_previous_save_area;
      IF (((psa^.minimum_save_area.a2_previous_save_area = NIL) OR
            ((#OFFSET (psa^.minimum_save_area.a2_previous_save_area) >= 0) AND
            ((#OFFSET (psa^.minimum_save_area.a2_previous_save_area) MOD 8) = 0))) AND
            (current_psa = psa^.minimum_save_area.a0_dynamic_space_pointer) AND
            (psa^.minimum_save_area.frame_descriptor.a_terminating > 1)) THEN
        status.normal := TRUE;
      ELSE
        osp$set_status_condition (pme$inconsistent_stack, status);
      IFEND;
    IFEND;

    i#restore_traps (traps);
    #KEYPOINT (osk$exit, 0, pmk$validate_previous_save_area);

  PROCEND pmp$validate_previous_save_area;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] tmp$find_ring_crossing_frame', EJECT ??
*copy tmh$find_ring_crossing_frame

  PROCEDURE [XDCL] tmp$find_ring_crossing_frame
    (    starting_frame: ^ost$stack_frame_save_area;
     VAR frame: ^ost$stack_frame_save_area;
     VAR status: ost$status);

?? NEWTITLE := 'dispose_of_stack_error', EJECT ??

    PROCEDURE dispose_of_stack_error
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      CASE condition.selector OF
      = pmc$system_conditions =
        IF NOT (pmc$detected_uncorrected_err IN condition.system_conditions) THEN
          osp$set_status_condition (pme$inconsistent_stack, status);
          EXIT tmp$find_ring_crossing_frame;
        ELSE
          osp$set_status_from_condition (pmc$program_management_id, condition, save_area, condition_status,
                ignore_status);
        IFEND;
      = mmc$segment_access_condition =
        osp$set_status_condition (pme$inconsistent_stack, status);
        EXIT tmp$find_ring_crossing_frame;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, ignore_status);
        condition_status.normal := TRUE;
      CASEND;
    PROCEND dispose_of_stack_error;
?? OLDTITLE, EJECT ??

    VAR
      stack_segment_ring: ost$ring,
      psa: ^ost$stack_frame_save_area, {previous_save_area}
      current_psa: ^cell;

    status.normal := TRUE;
    osp$establish_condition_handler (^dispose_of_stack_error, FALSE);


    IF (starting_frame = NIL) THEN
      frame := #PREVIOUS_SAVE_AREA ();
    ELSE
      frame := starting_frame;
    IFEND;

    stack_segment_ring := #RING (frame);
    WHILE (frame^.minimum_save_area.a2_previous_save_area <> NIL) AND
          (#RING (frame^.minimum_save_area.a2_previous_save_area) = stack_segment_ring) AND status.normal DO
      psa := frame^.minimum_save_area.a2_previous_save_area;
      current_psa := frame^.minimum_save_area.a2_previous_save_area;
      IF (((psa^.minimum_save_area.a2_previous_save_area = NIL) OR
            ((#OFFSET (psa^.minimum_save_area.a2_previous_save_area) >= 0) AND
            ((#OFFSET (psa^.minimum_save_area.a2_previous_save_area) MOD 8) = 0))) AND
            (current_psa = psa^.minimum_save_area.a0_dynamic_space_pointer) AND
            (psa^.minimum_save_area.frame_descriptor.a_terminating > 1)) THEN
        frame := frame^.minimum_save_area.a2_previous_save_area;
      ELSE
        osp$set_status_condition (pme$inconsistent_stack, status);
      IFEND;
    WHILEND;

  PROCEND tmp$find_ring_crossing_frame;
?? OLDTITLE ??
?? NEWTITLE := 'validate_descriptor_address', EJECT ??

  PROCEDURE validate_descriptor_address
    (    save_area: ^pmt$minimum_save_area;
         descriptor: ^pmt$established_handler;
     VAR status: ost$status);


    VAR
      current_stack_frame: ^comparable_pointer,
      descriptor_address: ^comparable_pointer,
      descriptor_internal_p: ^pmt$established_handler_internl,
      dynamic_space_pointer: ^comparable_pointer;


    descriptor_address := #LOC (descriptor);
    descriptor_internal_p := #LOC (descriptor^);
    current_stack_frame := #LOC (save_area^.a1_current_stack_frame);
    dynamic_space_pointer := #LOC (save_area^.a0_dynamic_space_pointer);

    IF (descriptor_address^ >= (current_stack_frame^ +8)) AND
          ((descriptor_address^ + #SIZE (pmt$established_handler)) < dynamic_space_pointer^) THEN
      status.normal := TRUE;
    ELSEIF NOT descriptor_internal_p^.established_outside_block THEN
      osp$set_status_condition (pme$descriptor_address_error, status);
    IFEND;


  PROCEND validate_descriptor_address;
?? OLDTITLE ??
MODEND pmm$condition_stack_processor;
*DECK DECK=PMM$DEBUG_INTERFACE_MGMT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Tasking : Debug Interface Management' ??
MODULE pmm$debug_interface_mgmt;

{  PURPOSE:
{    This module contains procedures which load the interfaces to the debug facility and
{    control access to these interfaces.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dbt$begin_debug
*copyc dbt$debug
*copyc dbt$end_debug
*copyc osd$code_base_pointer
*copyc oss$task_private
*copyc ost$caller_identifier
*copyc ost$status
*copyc pmk$keypoints
?? POP ??
*copyc lop$add_debug_libraries
*copyc lop$load_entry_point
*copyc osp$system_error
*copyc pmp$find_executing_task_tcb
*copyc pmp$find_prog_options_and_libs
*copyc pmp$get_loaded_rings
*copyc pmp$set_task_state
*copyc pmp$task_debug_ring
*copyc pmp$task_state
*copyc clv$standard_files
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    pmt$debug_procedures = record
      begin_debug: dbt$begin_debug,
      debug: dbt$debug,
      end_debug: dbt$end_debug,
    recend;

  TYPE
    debug_converter = record
      case 0 .. 4 of
      = 0 =
        pointer_to_procedure: ^procedure,
      = 1 =
        code_base_pointer: ^ost$external_code_base_pointer,
      = 2 =
        begin_debug: dbt$begin_debug,
      = 3 =
        debug: dbt$debug,
      = 4 =
        end_debug: dbt$end_debug,
      casend,
    recend;

  VAR
    debug_procedures: [STATIC, oss$task_private] pmt$debug_procedures := [NIL, NIL, NIL];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$find_begin_debug', EJECT ??

{  PURPOSE:
{    This procedure returns a pointer to the BEGIN_DEBUG procedure, provided that the caller
{    is within the call bracket of BEGIN_DEBUG.

  PROCEDURE [XDCL, #GATE] pmp$find_begin_debug
    (VAR begin_debug: dbt$begin_debug);

    VAR
      caller_id: ost$caller_identifier,
      converter: debug_converter;

    #CALLER_ID (caller_id);
    converter.begin_debug := debug_procedures.begin_debug;
    IF (pmp$task_debug_ring () <= caller_id.ring) AND (caller_id.ring <= converter.code_base_pointer^.r3) THEN
      begin_debug := debug_procedures.begin_debug;
    ELSE
      begin_debug := NIL;
    IFEND;
  PROCEND pmp$find_begin_debug;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$find_debug', EJECT ??
*copy pmh$find_debug

  PROCEDURE [XDCL, #GATE] pmp$find_debug
    (VAR debug: dbt$debug);

    VAR
      caller_id: ost$caller_identifier,
      converter: debug_converter;

    #CALLER_ID (caller_id);
    converter.debug := debug_procedures.debug;
    IF (pmp$task_debug_ring () <= caller_id.ring) AND (caller_id.ring <= converter.code_base_pointer^.r3) THEN
      debug := debug_procedures.debug;
    ELSE
      debug := NIL;
    IFEND;
  PROCEND pmp$find_debug;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$find_end_debug', EJECT ??

{  PURPOSE:
{    This procedure returns a pointer to the END_DEBUG procedure, provided that the caller
{    is within the call bracket of END_DEBUG.

  PROCEDURE [XDCL, #GATE] pmp$find_end_debug
    (VAR end_debug: dbt$end_debug);

    VAR
      caller_id: ost$caller_identifier,
      converter: debug_converter;

    #CALLER_ID (caller_id);
    converter.end_debug := debug_procedures.end_debug;
    IF (pmp$task_debug_ring () <= caller_id.ring) AND (caller_id.ring <= converter.code_base_pointer^.r3) THEN
      end_debug := debug_procedures.end_debug;
    ELSE
      end_debug := NIL;
    IFEND;
  PROCEND pmp$find_end_debug;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$load_debug_procedures', EJECT ??
*copy pmh$load_debug_procedures

  PROCEDURE [XDCL, #GATE] pmp$load_debug_procedures
    (VAR status {control} : ost$status);

    VAR
      converter: debug_converter,
      debug_global_key: ost$key_lock_value,
      debug_procedures_loaded: [STATIC, oss$task_private] boolean := FALSE,
      debug_ring: ost$valid_ring,
      highest_loaded_ring: pmt$loadable_ring,
      loaded_address: pmt$loaded_address,
      loaded_rings: pmt$loadable_rings,
      name: pmt$program_name,
      prog_options_and_libraries: ^pmt$prog_options_and_libraries;

    status.normal := TRUE;
    pmp$get_loaded_rings (loaded_rings);

  /find_highest_loaded_ring/
    FOR highest_loaded_ring := UPPERVALUE (pmt$loadable_ring) DOWNTO LOWERVALUE (pmt$loadable_ring) DO
      IF highest_loaded_ring IN loaded_rings THEN
        EXIT /find_highest_loaded_ring/
      IFEND;
    FOREND /find_highest_loaded_ring/;

    debug_ring := pmp$task_debug_ring ();

    IF NOT debug_procedures_loaded AND (debug_ring <= highest_loaded_ring) THEN

      pmp$find_prog_options_and_libs (prog_options_and_libraries);
      IF prog_options_and_libraries^.debug_library_list <> NIL THEN
        lop$add_debug_libraries (prog_options_and_libraries^.debug_library_list^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      debug_procedures_loaded := TRUE;
      debug_global_key := 0;

      name := 'DBP$BEGIN_DEBUG';
      lop$load_entry_point (name, debug_ring, debug_global_key, pmc$procedure_address, loaded_address,
            status);
      IF NOT status.normal THEN
        debug_procedures.begin_debug := NIL;
        RETURN
      ELSE
        converter.pointer_to_procedure := loaded_address.pointer_to_procedure;
        debug_procedures.begin_debug := converter.begin_debug;
      IFEND;

      name := 'DBP$DEBUG';
      lop$load_entry_point (name, debug_ring, debug_global_key, pmc$procedure_address, loaded_address,
            status);
      IF NOT status.normal THEN
        debug_procedures.begin_debug := NIL;
        debug_procedures.debug := NIL;
        RETURN
      ELSE
        converter.pointer_to_procedure := loaded_address.pointer_to_procedure;
        debug_procedures.debug := converter.debug;
      IFEND;

      name := 'DBP$END_DEBUG';
      lop$load_entry_point (name, debug_ring, debug_global_key, pmc$procedure_address, loaded_address,
            status);
      IF NOT status.normal THEN
        debug_procedures.begin_debug := NIL;
        debug_procedures.debug := NIL;
        debug_procedures.end_debug := NIL;
        RETURN
      ELSE
        converter.pointer_to_procedure := loaded_address.pointer_to_procedure;
        debug_procedures.end_debug := converter.end_debug;
      IFEND;
    IFEND;
  PROCEND pmp$load_debug_procedures;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$debug_abort_file_specified', EJECT ??

{  PURPOSE:
{    This procedure returns the determination whether an abort file is specified
{    for the executing task.

  PROCEDURE [XDCL, #GATE] pmp$debug_abort_file_specified
    (VAR debug_abort_file_specified: boolean);

    VAR
      tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb_p);
    debug_abort_file_specified := (tcb_p^.nosve.abort_file <> clv$standard_files [clc$sf_null_file].
          path_handle_name);
  PROCEND pmp$debug_abort_file_specified;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$initial_debug_mode_on', EJECT ??
*copy pmh$initial_debug_mode_on

  PROCEDURE [XDCL, #GATE] pmp$initial_debug_mode_on
    (VAR initial_debug_mode_on: boolean;
     VAR status: ost$status);

    VAR
      tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb_p);
    initial_debug_mode_on := tcb_p^.nosve.initial_debug_mode;
  PROCEND pmp$initial_debug_mode_on;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_debug_abort_file', EJECT ??
*copy pmh$get_debug_abort_file

  PROCEDURE [XDCL, #GATE] pmp$get_debug_abort_file
    (VAR abort_file_specified: boolean;
     VAR abort_file: amt$local_file_name);

    VAR
      tcb_p: ^pmt$task_control_block;

    #KEYPOINT (osk$entry, 0, pmk$get_debug_abort_file);
    pmp$find_executing_task_tcb (tcb_p);
    abort_file_specified := (tcb_p^.nosve.abort_file <>
          clv$standard_files [clc$sf_null_file].path_handle_name);
    abort_file := tcb_p^.nosve.abort_file;
    #KEYPOINT (osk$exit, 0, pmk$get_debug_abort_file);
  PROCEND pmp$get_debug_abort_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_debug_input_file', EJECT ??
*copy pmh$get_debug_input_file

  PROCEDURE [XDCL, #GATE] pmp$get_debug_input_file
    (VAR input_file_specified: boolean;
     VAR input_file: amt$local_file_name);

    VAR
      tcb_p: ^pmt$task_control_block;

    #KEYPOINT (osk$entry, 0, pmk$get_debug_input_file);
    pmp$find_executing_task_tcb (tcb_p);
    input_file_specified := (tcb_p^.nosve.debug_input <>
          clv$standard_files [clc$sf_null_file].path_handle_name);
    input_file := tcb_p^.nosve.debug_input;
    #KEYPOINT (osk$exit, 0, pmk$get_debug_input_file);
  PROCEND pmp$get_debug_input_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_debug_output_file', EJECT ??
*copy pmh$get_debug_output_file

  PROCEDURE [XDCL, #GATE] pmp$get_debug_output_file
    (VAR output_file_specified: boolean;
     VAR output_file: amt$local_file_name);

    VAR
      tcb_p: ^pmt$task_control_block;

    #KEYPOINT (osk$entry, 0, pmk$get_debug_output_file);
    pmp$find_executing_task_tcb (tcb_p);
    output_file_specified := (tcb_p^.nosve.debug_output <>
          clv$standard_files [clc$sf_null_file].path_handle_name);
    output_file := tcb_p^.nosve.debug_output;
    #KEYPOINT (osk$exit, 0, pmk$get_debug_output_file);
  PROCEND pmp$get_debug_output_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$set_debug_ending', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$set_debug_ending;

    IF (pmp$task_state () < pmc$debug_ending) THEN
      pmp$set_task_state (pmc$debug_ending);
    IFEND;
  PROCEND pmp$set_debug_ending;
?? OLDTITLE ??
MODEND pmm$debug_interface_mgmt;
*DECK DECK=PMM$DEBUG_STACK_MANAGERS_13F EXPAND=TRUE
?? RIGHT := 110 ??
*copy OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE: Program Management - Debug Stack Managers 13F' ??
?? NEWTITLE := '  Global Declarations' ??
?? EJECT ??
MODULE pmm$debug_stack_managers_13f;




{   PURPOSE:
{     This module handles the access requests to the task debug stacks.
{   These requests include setting, popping, pushing, and obtaining
{   of the current top of the task debug stack.
{

?? PUSH (LISTEXT := ON) ??
*copyc OST$CALLER_IDENTIFIER
*copyc pmd$program_mgmt_keypoints
*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSP$APPEND_STATUS_PARAMETER
*copyc CLP$CONVERT_INTEGER_TO_STRING
*copyc PME$DEBUG_EXCEPTIONS
*copyc PMP$EXIT
*copyc CLP$PUT_JOB_OUTPUT
*copyc OSE$HEAP_FULL_EXCEPTIONS

*copyc PMP$LOAD_DEBUG_PROCEDURES
*copyc PMP$VALIDATE_PREVIOUS_SAVE_AREA
*copyc pmk$keypoints
?? POP ??


*copyc PMT$OS_STACK_FRAME_WORD
*copyc PMT$TASK_DEBUG_MODE_STACK


*copyc OSS$JOB_PAGED_LITERAL
*copyc OSS$TASK_PRIVATE
*copyc OSS$TASK_SHARED
*copyc OSV$TASK_PRIVATE_HEAP


  VAR
    initialize_os_stack_frame_word: [STATIC, READ, oss$job_paged_literal] pmt$os_stack_frame_word :=
      [NIL, FALSE, FALSE, FALSE, FALSE, 0];

  VAR
    pmv$task_debug_mode: [STATIC, oss$task_private] pmt$task_debug_mode_stack := [ * , NIL];

?? OLDTITLE ??
?? EJECT ??
?? NEWTITLE := '  [XDCL]  PMP$PUSH_TASK_DEBUG_MODE' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$push_task_debug_mode (debug_mode: pmt$debug_mode;
    VAR status: ost$status);
*copy PMH$PUSH_TASK_DEBUG_MODE


    VAR
      new_stack: ^pmt$debug_mode_stack,
      local_status: ost$status;


    #keypoint (osk$entry, 0, pmk$push_task_debug_mode);
    status.normal := TRUE;
    local_status.normal := TRUE;

    IF debug_mode = pmc$debug_mode_on THEN
      pmp$load_debug_procedures (local_status);
      IF NOT local_status.normal THEN
        status := local_status;
        #keypoint (osk$exit, 0, pmk$push_task_debug_mode);
        RETURN;
      IFEND;
    IFEND;

    IF (pmv$task_debug_mode.stack <> NIL) OR (debug_mode = pmc$debug_mode_on) THEN
      IF (pmv$task_debug_mode.stack = NIL) OR (pmv$task_debug_mode.top_of_stack =
            pmc$max_elements_in_debug_stack) THEN
        ALLOCATE new_stack IN osv$task_private_heap^;
        new_stack^.previous_stack := pmv$task_debug_mode.stack;
        pmv$task_debug_mode.stack := new_stack;
        pmv$task_debug_mode.top_of_stack := pmc$min_elements_in_debug_stack;
        pmv$task_debug_mode.stack^.element [pmv$task_debug_mode.top_of_stack] := debug_mode;

      ELSE
        pmv$task_debug_mode.top_of_stack := pmv$task_debug_mode.top_of_stack + 1;
        pmv$task_debug_mode.stack^.element [pmv$task_debug_mode.top_of_stack] := debug_mode;
      IFEND;
    IFEND;

    #keypoint (osk$exit, 0, pmk$push_task_debug_mode);

  PROCEND pmp$push_task_debug_mode;
?? TITLE := '  [XDCL]  PMP$POP_TASK_DEBUG_MODE' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$pop_task_debug_mode (VAR status: ost$status);
*copy PMH$POP_TASK_DEBUG_MODE


    VAR
      previous_stack: ^pmt$debug_mode_stack;


    #keypoint (osk$entry, 0, pmk$pop_task_debug_mode);
    status.normal := TRUE;

    IF pmv$task_debug_mode.stack <> NIL THEN
      IF pmv$task_debug_mode.top_of_stack = pmc$min_elements_in_debug_stack THEN
        previous_stack := pmv$task_debug_mode.stack^.previous_stack;
        FREE pmv$task_debug_mode.stack IN osv$task_private_heap^;
        pmv$task_debug_mode.stack := previous_stack;
        pmv$task_debug_mode.top_of_stack := pmc$max_elements_in_debug_stack;

        IF pmv$task_debug_mode.stack = NIL THEN
          clr_debug_in_callers_user_masks;
        IFEND;
      ELSE
        pmv$task_debug_mode.top_of_stack := pmv$task_debug_mode.top_of_stack - 1;
      IFEND;
    IFEND;

    #keypoint (osk$exit, 0, pmk$pop_task_debug_mode);

  PROCEND pmp$pop_task_debug_mode;
?? TITLE := '  [XDCL]  PMP$SET_TASK_DEBUG_MODE' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$set_task_debug_mode (debug_mode: pmt$debug_mode;
    VAR status: ost$status);
*copy PMH$SET_TASK_DEBUG_MODE


    VAR
      local_status: ost$status;


    #keypoint (osk$entry, 0, pmk$set_task_debug_mode);
    status.normal := TRUE;
    local_status.normal := TRUE;

    IF pmv$task_debug_mode.stack = NIL THEN
      pmp$push_task_debug_mode (debug_mode, status);
    ELSE
      IF (debug_mode = pmc$debug_mode_off) AND (pmv$task_debug_mode.top_of_stack =
            pmc$min_elements_in_debug_stack) AND (pmv$task_debug_mode.stack^.previous_stack = NIL) THEN
        pmp$pop_task_debug_mode (status);
      ELSE
        IF debug_mode = pmc$debug_mode_on THEN
          pmp$load_debug_procedures (local_status);
          IF NOT local_status.normal THEN
            status := local_status;
            #keypoint (osk$exit, 0, pmk$set_task_debug_mode);
            RETURN;
          IFEND;
        IFEND;

        pmv$task_debug_mode.stack^.element [pmv$task_debug_mode.top_of_stack] := debug_mode;
      IFEND;
    IFEND;

    #keypoint (osk$exit, 0, pmk$set_task_debug_mode);

  PROCEND pmp$set_task_debug_mode;
?? TITLE := '  [XDCL]  PMP$TASK_DEBUG_MODE_ON' ??
?? EJECT ??

  FUNCTION [XDCL, #GATE] pmp$task_debug_mode_on: pmt$debug_mode;
*copy PMH$TASK_DEBUG_MODE_ON


    #keypoint (osk$entry, 0, pmk$task_debug_mode_on);

    IF pmv$task_debug_mode.stack = NIL THEN
      pmp$task_debug_mode_on := pmc$debug_mode_off;

    ELSE
      pmp$task_debug_mode_on := pmv$task_debug_mode.stack^.element [pmv$task_debug_mode.top_of_stack];

    IFEND;

    #keypoint (osk$exit, 0, pmk$task_debug_mode_on);

  FUNCEND pmp$task_debug_mode_on;
?? TITLE := '    SET_DEBUG_IN_CALLERS_USER_MASKS' ??
?? EJECT ??

  PROCEDURE set_debug_in_callers_user_masks;

    VAR
      psa: ^ost$stack_frame_save_area,
      save_area: ost$status;


    psa := #previous_save_area ();
    psa := psa^.minimum_save_area.a2_previous_save_area; {skip debug handler}
    REPEAT
      psa^.minimum_save_area.user_mask := psa^.minimum_save_area.user_mask + $ost$user_conditions [osc$debug];
      pmp$validate_previous_save_area (psa, save_area);
      psa := psa^.minimum_save_area.a2_previous_save_area;
    UNTIL (psa = NIL) OR (NOT save_area.normal);


  PROCEND set_debug_in_callers_user_masks;
?? TITLE := '    CLR_DEBUG_IN_CALLERS_USER_MASKS' ??
?? EJECT ??

  PROCEDURE clr_debug_in_callers_user_masks;

    VAR
      psa: ^ost$stack_frame_save_area,
      save_area: ost$status;

    psa := #previous_save_area ();
    psa := psa^.minimum_save_area.a2_previous_save_area; {skip debug handler}
    REPEAT
      psa^.minimum_save_area.user_mask := psa^.minimum_save_area.user_mask - $ost$user_conditions [osc$debug];
      pmp$validate_previous_save_area (psa, save_area);
      psa := psa^.minimum_save_area.a2_previous_save_area;
    UNTIL (psa = NIL) OR (NOT save_area.normal);

  PROCEND clr_debug_in_callers_user_masks;
?? OLDTITLE ??
?? TITLE := '    [XDCL]  PMP$ESTABLISH_DEBUG_OFF' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$establish_debug_cff (critical_frame: ^ost$stack_frame_save_area;
    VAR status: ost$status);

*copy PMH$ESTABLISH_DEBUG_CFF

    VAR
      os_stack_frame_word: ^pmt$os_stack_frame_word,
      psa: ^ost$stack_frame_save_area,
      save_area: ost$status;


    #keypoint (osk$entry, 0, pmk$establish_debug_cff);
    status.normal := TRUE;

    os_stack_frame_word := critical_frame^.minimum_save_area.a1_current_stack_frame;
    psa := #previous_save_area ();
    save_area.normal := TRUE;

    WHILE (psa <> NIL) AND (psa^.minimum_save_area.a1_current_stack_frame <> critical_frame^.
          minimum_save_area.a1_current_stack_frame) DO
      pmp$validate_previous_save_area (psa, save_area);
      IF NOT save_area.normal THEN
        osp$set_status_abnormal ('PM', pme$inconsistent_stack, '', status);
        #keypoint (osk$exit, 0, pmk$establish_debug_cff);
        RETURN;
      IFEND;
      psa := psa^.minimum_save_area.a2_previous_save_area;
    WHILEND;

    IF psa <> NIL THEN
      IF NOT critical_frame^.minimum_save_area.frame_descriptor.on_condition_flag THEN
        critical_frame^.minimum_save_area.frame_descriptor.on_condition_flag := TRUE;
        os_stack_frame_word^ := initialize_os_stack_frame_word;
      IFEND;
      os_stack_frame_word^.debug_cff_frame := TRUE;
      critical_frame^.minimum_save_area.frame_descriptor.critical_frame_flag := TRUE;
    ELSE
      osp$set_status_abnormal ('PM', pme$stack_frame_not_found, '', status);
    IFEND;

    #keypoint (osk$exit, 0, pmk$establish_debug_cff);

  PROCEND pmp$establish_debug_cff;
?? TITLE := '    [XDCL]  PMP$DEBUG_CRITICAL_FRAME' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$debug_critical_frame (stack_frame: ^ost$stack_frame_save_area;
    VAR critical_stack_frame: boolean);

*copy PMH$DEBUG_CRITICAL_FRAME

    VAR
      os_stack_frame_word: ^pmt$os_stack_frame_word;

    os_stack_frame_word := stack_frame^.minimum_save_area.a1_current_stack_frame;
    critical_stack_frame := (stack_frame^.minimum_save_area.frame_descriptor.on_condition_flag
                                                       AND os_stack_frame_word^.debug_cff_frame);
    os_stack_frame_word^.debug_cff_frame := FALSE;


  PROCEND pmp$debug_critical_frame;
?? OLDTITLE ??
?? TITLE := '  Debug Hardware Interfaces' ??
?? NEWTITLE := '    Global Declarations' ??
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc OSC$PROCESSOR_DEFINED_REGISTERS
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc PMP$VALIDATE_PREVIOUS_SAVE_AREA
*copyc MMP$VERIFY_ACCESS
?? POP ??

*copyc PMD$DEBUG
*copyc OST$DEBUG_LIST
*copyc PMT$DEBUG_ENVIRONMENT


  CONST
    pmc$minimum_debug_list_entry = 0,
    pmc$maximum_debug_list_entry = 31;


  TYPE
    pmt$range_of_next_free_index = pmc$minimum_debug_list_entry .. pmc$maximum_debug_list_entry + 1,

    pmt$debug_environment_stack = record
      environment: pmt$debug_environment,
      link: ^pmt$debug_environment_stack,
    recend,

    pmt$user_mask = set of 0 .. 63,

    pmt$debug_mask = packed record
      filler: packed array [0 .. 56] of boolean,
      mask: ost$debug_mask,
    recend,

    pmt$corresponding_index = record
      defined: boolean,
      index: pmt$debug_identifier,
      link: pmt$debug_identifier,
    recend;


  CONST
    debug_bit = 56;


  VAR
    converter: record
      case 0 .. 2 of
      = 0 =
        register: integer,
      = 1 =
        user_mask: pmt$user_mask,
      = 2 =
        debug_mask: pmt$debug_mask,
      casend,
    recend;


  VAR
    pmv$debug_list: [STATIC] ^ost$debug_list := NIL,
    pmv$debug_environment_stack: [STATIC] ^pmt$debug_environment_stack := NIL,
    pmv$debug_mask_codes: [STATIC] packed array [osc$data_read .. osc$call_instruction] of boolean := [FALSE,
      FALSE, FALSE, FALSE, FALSE],

    next_free_index: [STATIC] pmt$range_of_next_free_index := 0,
    next_free_identifier: [STATIC] pmt$debug_identifier,
    last_identifier_used: [STATIC] pmt$debug_identifier,

    corresponding_id: [STATIC] ^array [pmt$debug_identifier] of pmt$debug_identifier,
    corresponding_index: [STATIC] ^array [pmt$debug_identifier] of pmt$corresponding_index,

    number_of_debug_codes_set: [STATIC] array [osc$data_read .. osc$call_instruction] of 0 ..
      (pmc$maximum_debug_list_entry - pmc$minimum_debug_list_entry + 1) := [0, 0, 0, 0, 0];

?? TITLE := '    VERIFY_DEBUG_ADDRESSES' ??
?? EJECT ??

  PROCEDURE verify_debug_addresses (debug_code: pmt$debug_codes;
        low_address: ^cell;
        high_address: ^cell;
    VAR status: ost$status);



    status.normal := TRUE;

    IF #segment (low_address) <> #segment (high_address) THEN
      osp$set_status_abnormal ('PM', pme$address_segments_not_equal, '', status);

    ELSEIF #offset (low_address) > #offset (high_address) THEN
      osp$set_status_abnormal ('PM', pme$low_addr_greater_than_high, '', status);

    ELSEIF debug_code = $pmt$debug_codes [] THEN
      osp$set_status_abnormal ('PM', pme$empty_debug_code, '', status);

    ELSE
      IF osc$data_read IN debug_code THEN
        IF NOT mmp$verify_access (^low_address, mmc$va_read) THEN
          osp$set_status_abnormal ('PM', pme$invalid_access, '', status);
          RETURN;
        IFEND;
      IFEND;

      IF osc$data_write IN debug_code THEN
        IF NOT mmp$verify_access (^low_address, mmc$va_write) THEN
          osp$set_status_abnormal ('PM', pme$invalid_access, '', status);
          RETURN;
        IFEND;
      IFEND;

      IF ($pmt$debug_codes [osc$instruction_fetch, osc$branching_instruction, osc$call_instruction] *
            debug_code) <> $pmt$debug_codes [] THEN
        IF NOT mmp$verify_access (^low_address, mmc$va_execute) THEN
          osp$set_status_abnormal ('PM', pme$invalid_access, '', status);
          RETURN;
        IFEND;
      IFEND;
    IFEND;


  PROCEND verify_debug_addresses;
?? TITLE := '    INITIALIZE_DEBUG_LIST' ??
?? EJECT ??

  PROCEDURE initialize_debug_list;


    VAR
      converter: record
        case 0 .. 1 of
        = 0 =
          debug_list: ^ost$debug_list,
        = 1 =
          debug_list_register: 0 .. 0ffffffffffff(16),
        casend,
      recend,

      local_status: ost$status,
      i: pmt$debug_identifier,
      code: ost$debug_code;


    ALLOCATE corresponding_id IN osv$task_private_heap^;
    ALLOCATE corresponding_index IN osv$task_private_heap^;
    ALLOCATE pmv$debug_list IN osv$task_private_heap^;

    converter.debug_list := pmv$debug_list;
    #write_register (osc$pr_debug_list_pointer, converter.debug_list_register);

    next_free_index := pmc$minimum_debug_list_entry;
    next_free_identifier := LOWERVALUE (pmt$debug_identifier);
    last_identifier_used := LOWERVALUE (pmt$debug_identifier); { could be anything}

    FOR i := LOWERVALUE (pmt$debug_identifier) TO UPPERVALUE (pmt$debug_identifier) DO
      FOR code := LOWERVALUE (ost$debug_code) TO UPPERVALUE (ost$debug_code) DO
        pmv$debug_list^ [i].debug_code [code] := FALSE;
      FOREND;
?? EJECT ??
      pmv$debug_list^ [i].debug_code [osc$end_of_list] := TRUE;
    FOREND;

    FOR i := LOWERVALUE (pmt$debug_identifier) TO UPPERVALUE (pmt$debug_identifier) - 1 DO
      corresponding_index^ [i].defined := FALSE;
      corresponding_index^ [i].link := i + 1;
    FOREND;
    corresponding_index^ [UPPERVALUE (pmt$debug_identifier)].defined := FALSE;
    corresponding_index^ [UPPERVALUE (pmt$debug_identifier)].link := LOWERVALUE (pmt$debug_identifier);


  PROCEND initialize_debug_list;
?? TITLE := '    [XDCL]  PMP$DEFINE_DEBUG_ENTRY' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$define_debug_entry (debug_code: pmt$debug_codes;
        low_address: pmt$debug_low_address;
        high_address: pmt$debug_high_address;
    VAR debug_id: pmt$debug_identifier;
    VAR status: ost$status);

*copy PMH$DEFINE_DEBUG_ENTRY

    VAR
      local_status: ost$status,

      dc: osc$data_read .. osc$call_instruction,

      index: pmt$debug_identifier,
      temp: pmt$debug_identifier,

      stack_entry: ^pmt$debug_environment_stack;

?? EJECT ??


    { initialization }


    #keypoint (osk$entry, 0, pmk$define_debug_entry);
    status.normal := TRUE;
    local_status.normal := TRUE;

    converter.register := #read_register (osc$pr_user_mask_reg);
    converter.user_mask := converter.user_mask - $pmt$user_mask [debug_bit];
    #write_register (osc$pr_user_mask_reg, converter.register);

    verify_debug_addresses (debug_code, low_address, high_address, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      #keypoint (osk$exit, 0, pmk$define_debug_entry);
      RETURN;
    IFEND;

    IF pmv$debug_list = NIL THEN
      initialize_debug_list;

    ELSEIF next_free_index > pmc$maximum_debug_list_entry THEN
      osp$set_status_abnormal ('PM', pme$too_many_debug_list_entries, '', status);
      #keypoint (osk$exit, 0, pmk$define_debug_entry);
      RETURN;
    IFEND;
?? EJECT ??
    { modify debug list }

    index := next_free_index;
    pmv$debug_list^ [index].seg := #segment (low_address);
    pmv$debug_list^ [index].low_bn := #offset (low_address);
    pmv$debug_list^ [index].high_bn := #offset (high_address);

    FOR dc := osc$data_read TO osc$call_instruction DO
      IF dc IN debug_code THEN
        pmv$debug_list^ [index].debug_code [dc] := TRUE;
        number_of_debug_codes_set [dc] := number_of_debug_codes_set [dc] + 1;
        pmv$debug_mask_codes [dc] := TRUE;
      ELSE
        pmv$debug_list^ [index].debug_code [dc] := FALSE;
      IFEND;
    FOREND;

    pmv$debug_list^ [index].debug_code [osc$end_of_list] := TRUE;
    IF index > pmc$minimum_debug_list_entry THEN
      pmv$debug_list^ [index - 1].debug_code [osc$end_of_list] := FALSE;
    IFEND;


    { modify corresponding index and identifier lists }

    debug_id := next_free_identifier;
    corresponding_id^ [index] := next_free_identifier;

    temp := corresponding_index^ [next_free_identifier].link;
    corresponding_index^ [next_free_identifier].defined := TRUE;
    corresponding_index^ [next_free_identifier].index := index;
    corresponding_index^ [next_free_identifier].link := last_identifier_used;
    last_identifier_used := next_free_identifier;

    next_free_identifier := temp;
    next_free_index := next_free_index + 1;
?? EJECT ??
    { modify debug environment stack }

    converter.register := #read_register (osc$pr_debug_mask_reg);
    converter.debug_mask.mask.codes := pmv$debug_mask_codes;
    #write_register (osc$pr_debug_mask_reg, converter.register);

    IF pmv$debug_environment_stack <> NIL THEN
      stack_entry := pmv$debug_environment_stack;
      REPEAT
        IF stack_entry^.environment.debug_mask.end_of_list_seen_flag THEN
          stack_entry^.environment.debug_mask.end_of_list_seen_flag := FALSE;
          stack_entry^.environment.debug_mask.scan_in_progress := TRUE;
        IFEND;
        stack_entry := stack_entry^.link;
      UNTIL stack_entry = NIL;
    IFEND;


    set_debug_in_callers_user_masks;

    #keypoint (osk$exit, 0, pmk$define_debug_entry);

  PROCEND pmp$define_debug_entry;
?? TITLE := '    [XDCL]  PMP$GET_DEBUG_ENTRY' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_debug_entry (debug_id: pmt$debug_identifier;
    VAR debug_code: pmt$debug_codes;
    VAR low_address: pmt$debug_low_address;
    VAR high_address: pmt$debug_high_address;
    VAR status: ost$status);

*copy PMH$GET_DEBUG_ENTRY

    VAR
      index: pmt$debug_identifier,
      dc: ost$debug_code,
      caller_id: ost$caller_identifier;

?? EJECT ??


    #keypoint (osk$entry, 0, pmk$get_debug_entry);
    #caller_id (caller_id);

    status.normal := TRUE;

    IF ((((pmv$debug_list <> NIL) AND (debug_id >= LOWERVALUE (pmt$debug_identifier))) AND (debug_id <=
          UPPERVALUE (pmt$debug_identifier))) AND (corresponding_index^ [debug_id].defined)) THEN

      index := corresponding_index^ [debug_id].index;

      debug_code := $pmt$debug_codes [];
      FOR dc := osc$data_read TO osc$call_instruction DO
        IF pmv$debug_list^ [index].debug_code [dc] THEN
          debug_code := debug_code + $pmt$debug_codes [dc];
        IFEND;
      FOREND;

      low_address := #address (caller_id.ring, pmv$debug_list^ [index].seg, pmv$debug_list^ [index].low_bn);
      high_address := #address (caller_id.ring, pmv$debug_list^ [index].seg, pmv$debug_list^ [index].high_bn);

    ELSE

      osp$set_status_abnormal ('PM', pme$undefined_debug_id, '', status);

    IFEND;

    #keypoint (osk$exit, 0, pmk$get_debug_entry);

  PROCEND pmp$get_debug_entry;
?? TITLE := '    [XDCL]  PMP$MODIFY_DEBUG_ENTRY' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$modify_debug_entry (debug_id: pmt$debug_identifier;
        debug_code: pmt$debug_codes;
        low_address: pmt$debug_low_address;
        high_address: pmt$debug_high_address;
    VAR status: ost$status);

*copy PMH$MODIFY_DEBUG_ENTRY

    VAR
      local_status: ost$status,

      index: pmt$debug_identifier,
      dc: ost$debug_code,

      stack_entry: ^pmt$debug_environment_stack;

?? EJECT ??

    #keypoint (osk$entry, 0, pmk$modify_debug_entry);
    status.normal := TRUE;
    local_status.normal := TRUE;

    IF ((((pmv$debug_list <> NIL) AND (debug_id >= LOWERVALUE (pmt$debug_identifier))) AND (debug_id <=
          UPPERVALUE (pmt$debug_identifier))) AND (corresponding_index^ [debug_id].defined)) THEN

      verify_debug_addresses (debug_code, low_address, high_address, local_status);

      IF local_status.normal THEN
        index := corresponding_index^ [debug_id].index;

        pmv$debug_list^ [index].seg := #segment (low_address);
        pmv$debug_list^ [index].low_bn := #offset (low_address);
        pmv$debug_list^ [index].high_bn := #offset (high_address);

        FOR dc := osc$data_read TO osc$call_instruction DO
          IF dc IN debug_code THEN
            IF NOT pmv$debug_list^ [index].debug_code [dc] THEN
              pmv$debug_list^ [index].debug_code [dc] := TRUE;
              number_of_debug_codes_set [dc] := number_of_debug_codes_set [dc] + 1;
              pmv$debug_mask_codes [dc] := TRUE;
            IFEND;
          ELSE
            IF pmv$debug_list^ [index].debug_code [dc] THEN
              pmv$debug_list^ [index].debug_code [dc] := FALSE;
              number_of_debug_codes_set [dc] := number_of_debug_codes_set [dc] - 1;
              IF number_of_debug_codes_set [dc] = 0 THEN
                pmv$debug_mask_codes [dc] := FALSE;
              IFEND;
            IFEND;
          IFEND;
        FOREND;

        converter.register := #read_register (osc$pr_debug_mask_reg);
        converter.debug_mask.mask.codes := pmv$debug_mask_codes;
        #write_register (osc$pr_debug_mask_reg, converter.register);

      ELSE
        status := local_status;
      IFEND;
    ELSE
      osp$set_status_abnormal ('PM', pme$undefined_debug_id, '', status);
    IFEND;

    #keypoint (osk$exit, 0, pmk$modify_debug_entry);

  PROCEND pmp$modify_debug_entry;
?? TITLE := '    [XDCL]  PMP$REMOVE_DEBUG_ENTRY' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$remove_debug_entry (debug_id: pmt$debug_identifier;
    VAR status: ost$status);

*copy PMH$REMOVE_DEBUG_ENTRY

    VAR
      index: pmt$debug_identifier,
      id: pmt$debug_identifier,
      last_id: pmt$debug_identifier,
      di: pmt$debug_identifier,
      dc: ost$debug_code,

      stack_entry: ^pmt$debug_environment_stack,
      debug_index: 0 .. 63;

?? EJECT ??


    #keypoint (osk$entry, 0, pmk$remove_debug_entry);
    status.normal := TRUE;

    converter.register := #read_register (osc$pr_user_mask_reg);
    converter.user_mask := converter.user_mask - $pmt$user_mask [debug_bit];
    #write_register (osc$pr_user_mask_reg, converter.register);

    IF ((((pmv$debug_list <> NIL) AND (debug_id >= LOWERVALUE (pmt$debug_identifier))) AND (debug_id <=
          UPPERVALUE (pmt$debug_identifier))) AND (corresponding_index^ [debug_id].defined)) THEN

      index := corresponding_index^ [debug_id].index;

      FOR dc := osc$data_read TO osc$call_instruction DO
        IF pmv$debug_list^ [index].debug_code [dc] THEN
          number_of_debug_codes_set [dc] := number_of_debug_codes_set [dc] - 1;
          IF number_of_debug_codes_set [dc] = 0 THEN
            pmv$debug_mask_codes [dc] := FALSE;
          IFEND;
        IFEND;
      FOREND;

      next_free_index := next_free_index - 1;

      id := last_identifier_used;
      FOR di := index TO (next_free_index - 1) DO
        pmv$debug_list^ [di] := pmv$debug_list^ [di + 1];
        corresponding_id^ [di] := corresponding_id^ [di + 1];

        corresponding_index^ [id].index := corresponding_index^ [id].index - 1;
        last_id := id;
        id := corresponding_index^ [id].link;
      FOREND;

      FOR dc := osc$data_read TO osc$call_instruction DO
        pmv$debug_list^ [next_free_index].debug_code [dc] := FALSE;
      FOREND;

      IF next_free_index = LOWERVALUE (pmt$debug_identifier) THEN
        clr_debug_in_callers_user_masks;
      ELSE
        pmv$debug_list^ [next_free_index - 1].debug_code [osc$end_of_list] := TRUE;
      IFEND;
?? EJECT ??

      IF debug_id = last_identifier_used THEN
        last_identifier_used := corresponding_index^ [debug_id].link;
      ELSE
        corresponding_index^ [last_id].link := corresponding_index^ [debug_id].link;
      IFEND;
      corresponding_index^ [debug_id].link := next_free_identifier;
      next_free_identifier := debug_id;
      corresponding_index^ [next_free_identifier].defined := FALSE;

      converter.register := #read_register (osc$pr_debug_mask_reg);
      converter.debug_mask.mask.codes := pmv$debug_mask_codes;
      #write_register (osc$pr_debug_mask_reg, converter.register);

      IF pmv$debug_environment_stack <> NIL THEN
        stack_entry := pmv$debug_environment_stack;
        debug_index := (2 * index) + 1;
        REPEAT
          IF stack_entry^.environment.debug_index >= debug_index THEN
            IF stack_entry^.environment.debug_index > 1 THEN
              stack_entry^.environment.debug_index := stack_entry^.environment.debug_index - 2;
            ELSE
              stack_entry^.environment.debug_index := 0;
              stack_entry^.environment.debug_mask.scan_in_progress := FALSE;
              stack_entry^.environment.debug_mask.end_of_list_seen_flag := FALSE;
            IFEND;
          IFEND;
          stack_entry := stack_entry^.link;
        UNTIL stack_entry = NIL;
      IFEND;
    ELSE
      osp$set_status_abnormal ('PM', pme$undefined_debug_id, '', status);
    IFEND;

    #keypoint (osk$exit, 0, pmk$remove_debug_entry);

  PROCEND pmp$remove_debug_entry;
?? TITLE := '    [XDCL]  PMP$GET_DEBUG_ID' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_debug_id (debug_index: 0 .. 63;
    VAR debug_id: pmt$debug_identifier;
    VAR status: ost$status);

*copy PMH$GET_DEBUG_ID

    #keypoint (osk$entry, 0, pmk$get_debug_id);
    status.normal := TRUE;

    IF debug_index <= ((2 * (next_free_index - 1)) + 1) THEN
      debug_id := corresponding_id^ [debug_index DIV 2];
    ELSE
      osp$set_status_abnormal ('PM', pme$undefined_debug_index, '', status);
    IFEND;

    #keypoint (osk$exit, 0, pmk$get_debug_id);

  PROCEND pmp$get_debug_id;
?? TITLE := '    PMP$POST_DEBUG_ENVIRONMENT' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$post_debug_environment (debug_environment: pmt$debug_environment);

*copy PMH$POST_DEBUG_ENVIRONMENT

    VAR
      status: ost$status,
      stack_entry: ^pmt$debug_environment_stack;


    ALLOCATE stack_entry IN osv$task_private_heap^;

    stack_entry^.environment := debug_environment;
    stack_entry^.link := pmv$debug_environment_stack;
    pmv$debug_environment_stack := stack_entry;


  PROCEND pmp$post_debug_environment;
?? TITLE := '    PMP$GET_DEBUG_ENVIRONMENT' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_debug_environment (VAR debug_environment: pmt$debug_environment);

*copy PMH$GET_DEBUG_ENVIRONMENT

    VAR
      stack_entry: ^pmt$debug_environment_stack;


    debug_environment := pmv$debug_environment_stack^.environment;
    debug_environment.debug_mask.codes := pmv$debug_mask_codes;

    stack_entry := pmv$debug_environment_stack;
    pmv$debug_environment_stack := pmv$debug_environment_stack^.link;
    FREE stack_entry IN osv$task_private_heap^;


  PROCEND pmp$get_debug_environment;
?? TITLE := '    [XDCL]  PMP$RESET_DEBUG_SCAN' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$reset_debug_scan (VAR status: ost$status);


*copy PMH$RESET_DEBUG_SCAN



    #keypoint (osk$entry, 0, pmk$reset_debug_scan);
    status.normal := TRUE;

    IF pmv$debug_environment_stack <> NIL THEN
      pmv$debug_environment_stack^.environment.debug_index := 0;
      pmv$debug_environment_stack^.environment.debug_mask.scan_in_progress := FALSE;
      pmv$debug_environment_stack^.environment.debug_mask.end_of_list_seen_flag := FALSE;
    IFEND;

    #keypoint (osk$exit, 0, pmk$reset_debug_scan);

  PROCEND pmp$reset_debug_scan;
?? TITLE := '  Debug Ring Handlers' ??
?? NEWTITLE := '    Global Declarations' ??
?? EJECT ??

*copyc OSD$VIRTUAL_ADDRESS

*copyc AVP$RING_MIN
*copyc PMP$JOB_DEBUG_RING


  VAR
    pmv$task_debug_ring: [STATIC, oss$task_private] ost$ring := 0;

*copyc PMV$JOB_DEBUG_RING

?? TITLE := '    [XDCL]  PMP$SET_TASK_DEBUG_RING' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$set_task_debug_ring;


*copy PMH$SET_TASK_DEBUG_RING


    IF pmv$task_debug_ring = 0 THEN
      pmv$task_debug_ring := pmp$job_debug_ring ();
    IFEND;


  PROCEND pmp$set_task_debug_ring;
?? TITLE := '    [XDCL]  PMP$TASK_DEBUG_RING' ??
?? EJECT ??

  FUNCTION [XDCL, #GATE] pmp$task_debug_ring: ost$ring;


*copy PMH$TASK_DEBUG_RING


    #keypoint (osk$entry, 0, pmk$task_debug_ring);
    pmp$task_debug_ring := pmv$task_debug_ring;
    #keypoint (osk$exit, 0, pmk$task_debug_ring);

  FUNCEND pmp$task_debug_ring;
?? TITLE := '    [XDCL]  PMP$SET_JOB_DEBUG_RING' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$set_job_debug_ring (debug_ring: ost$ring;
    VAR status: ost$status);


*copy PMH$SET_JOB_DEBUG_RING


    VAR
      dummy_status: ost$status,
      ring: ost$string;



    status.normal := TRUE;

    IF debug_ring >= avp$ring_min () THEN
      IF debug_ring <= osc$max_ring THEN
        pmv$job_debug_ring := debug_ring;
      ELSE
        clp$convert_integer_to_string (debug_ring, 10, FALSE, ring, dummy_status);
        osp$set_status_abnormal ('PM', pme$invalid_ring_number, ring.value (1, ring.size), status);
      IFEND;
    ELSE
      clp$convert_integer_to_string (debug_ring, 10, FALSE, ring, dummy_status);
      osp$set_status_abnormal ('PM', pme$set_to_more_privileged_ring, ring.value (1, ring.size), status);
    IFEND;



  PROCEND pmp$set_job_debug_ring;




MODEND pmm$debug_stack_managers_13f;
*DECK DECK=PMM$DEBUG_STACK_MANAGERS_1FF EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Management : Debug Stack Managers 1FF' ??
MODULE pmm$debug_stack_managers_1ff;

{ PURPOSE:
{   This module is responsible for the declaring and obtaining the the job debug ring (task shared).

?? NEWTITLE := 'Global Declarations Referenced by This Module' ??
?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc oss$task_shared
*copyc pmk$keypoints
?? POP ??
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module' ??

  VAR
    pmv$job_debug_ring: [XDCL, oss$task_shared] ost$ring := 11;

?? OLDTITLE ??
?? NEWTITLE := 'pmp$job_debug_ring', EJECT ??

*copy pmh$job_debug_ring

  FUNCTION [XDCL, #GATE] pmp$job_debug_ring: ost$ring;

    #KEYPOINT (osk$entry, 0, pmk$job_debug_ring);

    pmp$job_debug_ring := pmv$job_debug_ring;

    #KEYPOINT (osk$exit, osk$m * pmv$job_debug_ring, pmk$job_debug_ring);


  FUNCEND pmp$job_debug_ring;

?? OLDTITLE ??
?? NEWTITLE := 'pmp$purge_instruction_stack', EJECT ??

{ NOTE:
{ The following procedure has been translated into ASSEMBLE code and is now located in the module
{ PMM$JOB_TEMPLATE_TRAP_HANDLER.  The need for the translation arose with the advent of the CYBER 2000
{ processor which needed an instruction stack purge instruction placed in this procedure.  The presence of
{ the instruction will not affect any non-CYBER_2000 processor.
{
{ PROCEDURE [XDCL, #GATE] pmp$purge_instruction_stack;
{
{ This is a routine to be used to insure that a CALLSEG instruction is
{ executed after code modification. (Current use is by the Interactive Debugger).
{
{   #KEYPOINT (osk$entry, 0, pmk$purge_instruction_stack);
{   #KEYPOINT (osk$exit, 0, pmk$purge_instruction_stack);
{
{ PROCEND pmp$purge_instruction_stack;

MODEND pmm$debug_stack_managers_1ff;
*DECK DECK=PMM$DEBUG_TABLE_BUILDER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Program Management - Debug Table Builder' ??
MODULE pmm$debug_table_builder;

{  PURPOSE:
{
{    This module is responsible for accumulating the debug table
{    information output by the loader and making it available to
{    the debugger.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cyd$debug_symbols
*copyc dbt$entry_point_table
*copyc dbt$module_address_table_item
*copyc llt$line_address_table
*copyc llt$load_module
*copyc llt$supplemental_debug_tables
*copyc oce$library_generator_errors
*copyc osd$code_base_pointer
*copyc ose$heap_full_exceptions
*copyc oss$task_private
*copyc pme$debug_exceptions
*copyc pmt$debug_table_info
?? POP ??
*copyc clp$convert_integer_to_string
*copyc i#build_adaptable_array_ptr
*copyc i#build_adaptable_seq_pointer
*copyc mmp$create_segment
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc pmp$exit
*copyc pmp$find_executing_task_tcb
*copyc osv$task_private_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declaration Declared by This Module', EJECT ??

  VAR
    current_debug_symbol_table: [STATIC, oss$task_private] ^pmt$debug_symbol_table_list,
    current_line_address_table: [STATIC, oss$task_private] ^pmt$line_address_table_list,
    current_supplemental_dtable: [STATIC, oss$task_private] ^pmt$supplemental_dtable_list,
    first_debug_symbol_table: [STATIC, oss$task_private] pmt$debug_symbol_table_list,
    first_line_address_table: [STATIC, oss$task_private] pmt$line_address_table_list,
    first_supplemental_dtable: [STATIC, oss$task_private] pmt$supplemental_dtable_list,
    number_of_debug_symbol_tables: [STATIC, oss$task_private] 0 .. llc$max_components,
    number_of_line_address_tables: [STATIC, oss$task_private] llt$line_address_table_size,
    number_of_supplemental_dtables: [STATIC, oss$task_private] 0 .. llc$max_components;

?? OLDTITLE ??
?? NEWTITLE := 'set_up_debug_table_processing', EJECT ??

  PROCEDURE set_up_debug_table_processing;

    number_of_line_address_tables := 0;
    current_line_address_table := ^first_line_address_table;
    current_line_address_table^.link := NIL;

    number_of_debug_symbol_tables := 0;
    current_debug_symbol_table := ^first_debug_symbol_table;
    current_debug_symbol_table^.link := NIL;

    number_of_supplemental_dtables := 0;
    current_supplemental_dtable := ^first_supplemental_dtable;
    current_supplemental_dtable^.link := NIL;
  PROCEND set_up_debug_table_processing;
?? OLDTITLE ??
?? NEWTITLE := 'finish_line_table_processing', EJECT ??

  PROCEDURE finish_line_table_processing
    (VAR status: ost$status);

    VAR
      i: llt$line_address_table_size,
      tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb_p);
    IF number_of_line_address_tables <> 0 THEN
      NEXT tcb_p^.nosve.debug_table^.current_module_item^.line_address_tables:
            [0 .. number_of_line_address_tables - 1] IN tcb_p^.nosve.debug_table^.module_segment.seq_pointer;
      IF tcb_p^.nosve.debug_table^.current_module_item^.line_address_tables = NIL THEN
        osp$set_status_abnormal ('PM', pme$module_segment_overflow, '', status);
        RETURN;
      IFEND;

      current_line_address_table := ^first_line_address_table;
      FOR i := 0 TO (number_of_line_address_tables - 1) DO
        current_line_address_table := current_line_address_table^.link;
        tcb_p^.nosve.debug_table^.current_module_item^.line_address_tables^ [i] :=
              current_line_address_table^.pointer;
      FOREND;
    IFEND;
  PROCEND finish_line_table_processing;
?? OLDTITLE ??
?? NEWTITLE := 'finish_debug_table_processing', EJECT ??

  PROCEDURE finish_debug_table_processing
    (VAR status: ost$status);

    VAR
      i: 0 .. llc$max_components,
      tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb_p);
    IF number_of_debug_symbol_tables > 0 THEN
      NEXT tcb_p^.nosve.debug_table^.current_module_item^.debug_symbol_tables:
            [0 .. number_of_debug_symbol_tables - 1] IN tcb_p^.nosve.debug_table^.module_segment.seq_pointer;
      IF tcb_p^.nosve.debug_table^.current_module_item^.debug_symbol_tables = NIL THEN
        osp$set_status_abnormal ('PM', pme$module_segment_overflow, '', status);
        FOR i := 0 TO (number_of_debug_symbol_tables - 1) DO
          current_debug_symbol_table := first_debug_symbol_table.link;
          first_debug_symbol_table.link := current_debug_symbol_table^.link;
          FREE current_debug_symbol_table IN osv$task_private_heap^;
        FOREND;
      ELSE

        current_debug_symbol_table := ^first_debug_symbol_table;

        FOR i := 0 TO (number_of_debug_symbol_tables - 1) DO
          current_debug_symbol_table := current_debug_symbol_table^.link;
          tcb_p^.nosve.debug_table^.current_module_item^.debug_symbol_tables^ [i] :=
                current_debug_symbol_table^.pointer;
        FOREND;
      IFEND;
    IFEND;
  PROCEND finish_debug_table_processing;
?? OLDTITLE ??
?? NEWTITLE := 'finish_sd_table_processing', EJECT ??

  PROCEDURE finish_sd_table_processing
    (VAR status: ost$status);

    VAR
      i: 0 .. llc$max_components,
      tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb_p);
    IF number_of_supplemental_dtables > 0 THEN
      NEXT tcb_p^.nosve.debug_table^.current_module_item^.supplemental_debug_tables:
            [0 .. number_of_supplemental_dtables - 1] IN tcb_p^.nosve.debug_table^.module_segment.seq_pointer;
      IF tcb_p^.nosve.debug_table^.current_module_item^.supplemental_debug_tables = NIL THEN
        osp$set_status_abnormal ('PM', pme$module_segment_overflow, '', status);
        FOR i := 0 TO (number_of_supplemental_dtables - 1) DO
          current_supplemental_dtable := first_supplemental_dtable.link;
          first_supplemental_dtable.link := current_supplemental_dtable^.link;
          FREE current_supplemental_dtable IN osv$task_private_heap^;
        FOREND;
      ELSE

        current_supplemental_dtable := ^first_supplemental_dtable;

        FOR i := 0 TO (number_of_supplemental_dtables - 1) DO
          current_supplemental_dtable := current_supplemental_dtable^.link;
          tcb_p^.nosve.debug_table^.current_module_item^.supplemental_debug_tables^ [i] :=
                current_supplemental_dtable^.pointer;
        FOREND;
      IFEND;
    IFEND;
  PROCEND finish_sd_table_processing;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] dbp$define_module', EJECT ??
*copy dbh$define_module

  PROCEDURE [XDCL] dbp$define_module
    (    identification: ^llt$identification;
         language: llt$module_generator;
     VAR status: ost$status);

    VAR
      modules_ptr: ^llt$identification,
      ring_attributes: array [1 .. 1] of mmt$attribute_descriptor,
      tcb_p: ^pmt$task_control_block;

    status.normal := TRUE;
    PUSH modules_ptr;

    pmp$find_executing_task_tcb (tcb_p);
    IF tcb_p^.nosve.debug_table^.module_segment.seq_pointer = NIL THEN
      ring_attributes [1].keyword := mmc$kw_ring_numbers;
      ring_attributes [1].r1 := osc$tsrv_ring;
      ring_attributes [1].r2 := 0f(16);
      mmp$create_segment (^ring_attributes, mmc$sequence_pointer, 1, tcb_p^.nosve.debug_table^.module_segment,
            status);
      IF status.normal THEN
        RESET tcb_p^.nosve.debug_table^.module_segment.seq_pointer;
        tcb_p^.nosve.debug_table^.last_module_item := ^tcb_p^.nosve.debug_table^.
              first_module_address_table_item;
      ELSE
        RETURN;
      IFEND;
    ELSE
      IF tcb_p^.nosve.debug_table^.current_module_item <> NIL THEN
        osp$set_status_abnormal ('PM', pme$missing_module_termination,
              tcb_p^.nosve.debug_table^.current_module_item^.name, status);
        dbp$terminate_module (status);
      IFEND;
    IFEND;

    modules_ptr^ := identification^;
    modules_ptr^.generator_id := language;
    NEXT tcb_p^.nosve.debug_table^.current_module_item: [0 .. modules_ptr^.greatest_section_ordinal] IN
          tcb_p^.nosve.debug_table^.module_segment.seq_pointer;
    IF tcb_p^.nosve.debug_table^.current_module_item <> NIL THEN
      tcb_p^.nosve.debug_table^.current_module_item^.name := modules_ptr^.name;
      tcb_p^.nosve.debug_table^.current_module_item^.language := modules_ptr^.generator_id;
      tcb_p^.nosve.debug_table^.current_module_item^.greatest_section_ordinal :=
            modules_ptr^.greatest_section_ordinal;
      tcb_p^.nosve.debug_table^.current_module_item^.application_identifier := NIL;
      tcb_p^.nosve.debug_table^.current_module_item^.reinitialization_information := identification;
      tcb_p^.nosve.debug_table^.current_module_item^.next_module := NIL;
      tcb_p^.nosve.debug_table^.current_module_item^.line_address_tables := NIL;
      tcb_p^.nosve.debug_table^.current_module_item^.debug_symbol_tables := NIL;
      tcb_p^.nosve.debug_table^.current_module_item^.supplemental_debug_tables := NIL;

      set_up_debug_table_processing;
    ELSE
      osp$set_status_abnormal ('PM', pme$module_segment_overflow, '', status);
    IFEND;
  PROCEND dbp$define_module;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] dbp$define_section', EJECT ??
*copy dbh$define_section

  PROCEDURE [XDCL] dbp$define_section
    (    section_item: dbt$section_item;
     VAR status: ost$status);

    VAR
      dummy: ost$status,
      str: ost$string,
      tcb_p: ^pmt$task_control_block;

    status.normal := TRUE;

    pmp$find_executing_task_tcb (tcb_p);
    IF (tcb_p^.nosve.debug_table^.module_segment.seq_pointer <> NIL) AND
          (tcb_p^.nosve.debug_table^.current_module_item <> NIL) THEN
      IF section_item.section_ordinal <= UPPERBOUND (tcb_p^.nosve.debug_table^.current_module_item^.
            section_item) THEN
        tcb_p^.nosve.debug_table^.current_module_item^.section_item [section_item.section_ordinal] :=
              section_item;
      ELSE
        osp$set_status_abnormal ('PM', pme$invalid_section_ordinal,
              tcb_p^.nosve.debug_table^.current_module_item^.name, status);
        clp$convert_integer_to_string (section_item.section_ordinal, 10, FALSE, str, dummy);
        osp$append_status_parameter (osc$status_parameter_delimiter, str.value (1, str.size), status);
      IFEND;
    ELSE
      osp$set_status_abnormal ('PM', pme$missing_module_definition, '', status);
    IFEND;

  PROCEND dbp$define_section;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] dbp$define_applic_identifier', EJECT ??
*copy dbh$define_applic_identifier

  PROCEDURE [XDCL] dbp$define_applic_identifier
    (    application_identifier: ^llt$application_identifier;
     VAR status: ost$status);

    VAR
      dummy: ost$status,
      str: ost$string,
      tcb_p: ^pmt$task_control_block;

    status.normal := TRUE;

    pmp$find_executing_task_tcb (tcb_p);
    IF (tcb_p^.nosve.debug_table^.module_segment.seq_pointer <> NIL) AND
          (tcb_p^.nosve.debug_table^.current_module_item <> NIL) THEN
      NEXT tcb_p^.nosve.debug_table^.current_module_item^.application_identifier IN
            tcb_p^.nosve.debug_table^.module_segment.seq_pointer;
      IF tcb_p^.nosve.debug_table^.current_module_item^.application_identifier <> NIL THEN
        tcb_p^.nosve.debug_table^.current_module_item^.application_identifier^.name :=
              application_identifier^.name;
      ELSE
        osp$set_status_abnormal ('PM', pme$module_segment_overflow, '', status);
      IFEND;
    ELSE
      osp$set_status_abnormal ('PM', pme$missing_module_definition, '', status);
    IFEND;

  PROCEND dbp$define_applic_identifier;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] dbp$define_line_address_table', EJECT ??

  PROCEDURE [XDCL] dbp$define_line_address_table
    (    line_address_table: ^llt$line_address_table;
         loaded_ring: ost$ring;
     VAR status: ost$status);

    VAR
      tcb_p: ^pmt$task_control_block;

    status.normal := TRUE;

    pmp$find_executing_task_tcb (tcb_p);
    IF (tcb_p^.nosve.debug_table^.module_segment.seq_pointer = NIL) OR
          (tcb_p^.nosve.debug_table^.current_module_item = NIL) THEN
      osp$set_status_abnormal ('PM', pme$missing_module_definition, '', status);
      RETURN;
    IFEND;

    ALLOCATE current_line_address_table^.link IN osv$task_private_heap^;

    current_line_address_table := current_line_address_table^.link;
    current_line_address_table^.link := NIL;

    i#build_adaptable_array_ptr (loaded_ring, #SEGMENT (line_address_table), #OFFSET (line_address_table),
          #SIZE (line_address_table^.item), LOWERBOUND (line_address_table^.item),
          #SIZE (llt$line_address_item), #LOC (current_line_address_table^.pointer));

    number_of_line_address_tables := number_of_line_address_tables + 1;
  PROCEND dbp$define_line_address_table;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] dbp$define_debug_symbol_tables', EJECT ??

  PROCEDURE [XDCL] dbp$define_debug_symbol_tables
    (    debug_symbol_table: ^llt$symbol_table;
         loaded_ring: ost$ring;
     VAR status: ost$status);

    VAR
      symbol_table: ^SEQ ( * ),
      debug_table: ^llt$debug_symbol_table,
      tcb_p: ^pmt$task_control_block;

    status.normal := TRUE;

    pmp$find_executing_task_tcb (tcb_p);
    IF (tcb_p^.nosve.debug_table^.module_segment.seq_pointer = NIL) OR
          (tcb_p^.nosve.debug_table^.current_module_item = NIL) THEN
      osp$set_status_abnormal ('PM', pme$missing_module_definition, '', status);
      RETURN;
    IFEND;

    IF debug_symbol_table = NIL THEN
      osp$set_status_abnormal ('PM', pme$bad_debug_symbol_table,
            tcb_p^.nosve.debug_table^.current_module_item^.name, status);
      RETURN;
    IFEND;

    ALLOCATE current_debug_symbol_table^.link IN osv$task_private_heap^;

    current_debug_symbol_table := current_debug_symbol_table^.link;
    current_debug_symbol_table^.link := NIL;

    symbol_table := ^debug_symbol_table^.text;
    RESET symbol_table;

    NEXT debug_table: [1 .. 1] IN symbol_table;
    IF debug_table = NIL THEN
      osp$set_status_abnormal ('PM', pme$bad_debug_symbol_table,
            tcb_p^.nosve.debug_table^.current_module_item^.name, status);
      RETURN;
    IFEND;

    RESET symbol_table;
    NEXT debug_table: [1 .. debug_table^.number_of_items] IN symbol_table;
    IF debug_table = NIL THEN
      osp$set_status_abnormal ('PM', pme$bad_debug_symbol_table,
            tcb_p^.nosve.debug_table^.current_module_item^.name, status);
      RETURN;
    IFEND;

    i#build_adaptable_array_ptr (loaded_ring, #SEGMENT (debug_table), #OFFSET (debug_table),
          #SIZE (debug_table^.item), LOWERBOUND (debug_table^.item), #SIZE (llt$symbol_table_item),
          #LOC (current_debug_symbol_table^.pointer));

    number_of_debug_symbol_tables := number_of_debug_symbol_tables + 1;
  PROCEND dbp$define_debug_symbol_tables;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] dbp$define_supplemental_dtables', EJECT ??
*copy dbh$define_supplemental_dtables

  PROCEDURE [XDCL] dbp$define_supplemental_dtables
    (    supplemental_debug_tables: ^llt$supplemental_debug_tables,
         loaded_ring: ost$ring;
     VAR status: ost$status);

    TYPE
      convert_pointer = record
        case boolean of
        = TRUE =
          value: ^llt$supplemental_debug_tables,
        = FALSE =
          sequence: ^SEQ ( * ),
        casend,
      recend;

    VAR
      convert_sequence_pointer: convert_pointer,
      tcb_p: ^pmt$task_control_block;

    status.normal := TRUE;

    pmp$find_executing_task_tcb (tcb_p);
    IF (tcb_p^.nosve.debug_table^.module_segment.seq_pointer = NIL) OR
          (tcb_p^.nosve.debug_table^.current_module_item = NIL) THEN
      osp$set_status_abnormal ('PM', pme$missing_module_definition, '', status);
      RETURN;
    IFEND;

    ALLOCATE current_supplemental_dtable^.link IN osv$task_private_heap^;

    current_supplemental_dtable := current_supplemental_dtable^.link;
    current_supplemental_dtable^.link := NIL;

    i#build_adaptable_seq_pointer (loaded_ring, #SEGMENT (supplemental_debug_tables),
          #OFFSET (supplemental_debug_tables), #SIZE (supplemental_debug_tables^.sd_table), 0,
          convert_sequence_pointer.sequence);

    current_supplemental_dtable^.pointer := convert_sequence_pointer.value;

    number_of_supplemental_dtables := number_of_supplemental_dtables + 1;
  PROCEND dbp$define_supplemental_dtables;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] dbp$define_entry_point_address', EJECT ??
*copy dbh$define_entry_point_address

  PROCEDURE [XDCL] dbp$define_entry_point_address
    (    entry_point_table_item: dbt$entry_point_table_item;
     VAR status: ost$status);

    VAR
      ring_attributes: array [1 .. 1] of mmt$attribute_descriptor,
      tcb_p: ^pmt$task_control_block;

    status.normal := TRUE;

    pmp$find_executing_task_tcb (tcb_p);
    IF tcb_p^.nosve.debug_table^.entry_point_segment.seq_pointer = NIL THEN
      ring_attributes [1].keyword := mmc$kw_ring_numbers;
      ring_attributes [1].r1 := osc$tsrv_ring;
      ring_attributes [1].r2 := 0f(16);
      mmp$create_segment (^ring_attributes, mmc$sequence_pointer, 1,
            tcb_p^.nosve.debug_table^.entry_point_segment, status);
      tcb_p^.nosve.debug_table^.number_of_entry_point_items := 1;
    ELSE
      IF tcb_p^.nosve.debug_table^.number_of_entry_point_items < dbc$max_entry_point_items THEN
        tcb_p^.nosve.debug_table^.number_of_entry_point_items :=
              tcb_p^.nosve.debug_table^.number_of_entry_point_items + 1;
      ELSE
        osp$set_status_abnormal ('PM', pme$too_many_entry_points, '', status);
      IFEND;
    IFEND;

    IF status.normal THEN
      RESET tcb_p^.nosve.debug_table^.entry_point_segment.seq_pointer;
      NEXT tcb_p^.nosve.debug_table^.entry_point_table: [1 .. tcb_p^.nosve.debug_table^.
            number_of_entry_point_items] IN tcb_p^.nosve.debug_table^.entry_point_segment.seq_pointer;
      IF tcb_p^.nosve.debug_table^.entry_point_table <> NIL THEN
        tcb_p^.nosve.debug_table^.entry_point_table^.address :=
              ^tcb_p^.nosve.debug_table^.entry_point_table^.item;
        tcb_p^.nosve.debug_table^.entry_point_table^.item [tcb_p^.nosve.debug_table^.
              number_of_entry_point_items] := entry_point_table_item;
      ELSE
        osp$set_status_abnormal ('PM', pme$entry_pt_segment_overflow, '', status);
      IFEND;
    IFEND;
  PROCEND dbp$define_entry_point_address;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] dbp$terminate_module', EJECT ??
*copy dbh$terminate_module

  PROCEDURE [XDCL] dbp$terminate_module
    (VAR status: ost$status);

    VAR
      tcb_p: ^pmt$task_control_block;

    status.normal := TRUE;

    pmp$find_executing_task_tcb (tcb_p);
    IF (tcb_p^.nosve.debug_table^.module_segment.seq_pointer <> NIL) AND
          (tcb_p^.nosve.debug_table^.current_module_item <> NIL) THEN
      finish_line_table_processing (status);
      finish_debug_table_processing (status);
      finish_sd_table_processing (status);

      tcb_p^.nosve.debug_table^.last_module_item^ := tcb_p^.nosve.debug_table^.current_module_item;
      tcb_p^.nosve.debug_table^.last_module_item := ^tcb_p^.nosve.debug_table^.last_module_item^^.next_module;
      tcb_p^.nosve.debug_table^.current_module_item := NIL;
    ELSE
      osp$set_status_abnormal ('PM', pme$missing_module_definition, '', status);
    IFEND;
  PROCEND dbp$terminate_module;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] dbp$module_table_address', EJECT ??
*copy dbh$module_table_address

  FUNCTION [XDCL, #GATE] dbp$module_table_address: ^dbt$module_address_table_item;

    VAR
      tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb_p);
    dbp$module_table_address := tcb_p^.nosve.debug_table^.first_module_address_table_item;
  FUNCEND dbp$module_table_address;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] dbp$entry_point_table_address', EJECT ??
*copy dbh$entry_point_table_address

  FUNCTION [XDCL, #GATE] dbp$entry_point_table_address: ^dbt$entry_point_table;

    VAR
      tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb_p);
    dbp$entry_point_table_address := tcb_p^.nosve.debug_table^.entry_point_table;
  FUNCEND dbp$entry_point_table_address;
?? OLDTITLE ??
MODEND pmm$debug_table_builder;
*DECK DECK=PMM$DEFAULT_LOADER_PARAM_MGMT EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE : Default loader parameter management' ??
MODULE pmm$default_loader_param_mgmt;

{  PURPOSE:
{    This module contains procedures to define and fetch defaults for loader parameters which
{    apply to all program loads occurring within a job, unless explicitly overridden.

?? NEWTITLE := '  Global declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc clt$environment_object_contents
*copyc clt$environment_object_size
*copyc clt$env_object_pop_reason
*copyc clt$env_object_push_reason
*copyc fsc$compiling_for_test_harness
*copyc LOC$TASK_SERVICES_LIBRARY_NAME
*copyc LOT$LOADER_TYPE_DEFINITIONS
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
*copyc PMC$DEFAULT_USER_STACK_SIZE
*copyc PME$EXECUTION_EXCEPTIONS
*copyc PMT$PROG_OPTIONS_AND_LIBRARIES
*copyc PMT$DEFAULT_PROG_OPTIONS_CHANGE
*copyc PMT$PROGRAM_DESCRIPTION
*copyc PMT$PROGRAM_OPTIONS
*copyc pmk$keypoints
?? POP ??
*copyc amp$get_file_attributes
*copyc clp$convert_str_to_path_handle
*copyc clp$convert_string_to_file
*copyc clp$validate_name
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
*copyc osv$page_size
*copyc osv$task_shared_heap
*copyc pmp$find_prog_options_and_libs
?? EJECT ??

{!  The following variable should be defined in this module (and XDCLed) once the CYBIL
{!  can initialize 64 bit integers.  This data should reside in a read_only section readable
{!  from all rings.
*copyc PMV$PRESET_CONVERSION_TABLE
?? TITLE := '  [XDCL] pmp$init_default_prog_options', EJECT ??

  PROCEDURE [XDCL] pmp$init_default_prog_options
    (VAR default_program_options: ^pmt$program_options;
     VAR status: ost$status);

{
{    The purpose of this procedure is to allocate and initialize the default program options
{ which apply to all program loads within the job.
{
{       PMP$INIT_DEFAULT_PROG_OPTIONS (DEFAULT_PROGRAM_OPTIONS, STATUS)
{
{ DEFAULT_PROGRAM_OPTIONS: (output) This parameter specifies a pointer to the default
{       program options record.
{
{ STATUS: (output) This parameter specifies the request status.
{

    VAR
      program_options: ^pmt$program_options,
      load_map: clt$file;


    status.normal := TRUE;
    default_program_options := NIL;

    ALLOCATE program_options IN osv$task_shared_heap^;

    clp$convert_string_to_file ('$LOCAL.LOADMAP', load_map, status);
    IF NOT status.normal THEN
      FREE program_options IN osv$task_shared_heap^;
      RETURN;
    IFEND;

    program_options^.map_file := load_map.local_file_name;
    program_options^.map_options := $pmt$load_map_options [];
    program_options^.termination_error_level := pmc$error_load_errors;
    program_options^.preset := 0;
    pmp$change_maximum_stack_size (pmc$default_user_stack_size, program_options^.maximum_stack_size);

{ debug_input, debug_output, and the abort_file are assigned in clp$store_std_path_handle_names

    program_options^.debug_input := osc$null_name;
    program_options^.debug_output := osc$null_name;
    program_options^.abort_file := osc$null_name;

    program_options^.debug_mode := FALSE;
    program_options^.conditions_enabled := $pmt$system_conditions
          [pmc$arithmetic_overflow, pmc$arithmetic_significance, pmc$divide_fault, pmc$exponent_overflow,
          pmc$exponent_underflow, pmc$fp_indefinite, pmc$invalid_bdp_data];
    program_options^.conditions_inhibited := $pmt$system_conditions [pmc$fp_significance_loss];

    default_program_options := program_options;

  PROCEND pmp$init_default_prog_options;
?? TITLE := '  [INLINE] pmp$change_maximum_stack_size', EJECT ??

  PROCEDURE [INLINE] pmp$change_maximum_stack_size
    (    maximum_stack_size: ost$segment_length;
     VAR actual_maximum_stack_size: ost$segment_length);

{
{ PURPOSE:
{   This procedure changes the maximum stack size in the default program
{   options which apply to all program loads within the job.
{

    IF (maximum_stack_size > pmc$maximum_user_stack_size) OR fsc$compiling_for_test_harness THEN
      actual_maximum_stack_size := pmc$maximum_user_stack_size;
    ELSE
      actual_maximum_stack_size := ((maximum_stack_size + osv$page_size - 1) DIV osv$page_size) *
            osv$page_size;
    IFEND;

  PROCEND pmp$change_maximum_stack_size;
?? TITLE := '  [XDCL, #GATE] pmp$change_default_prog_options', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$change_default_prog_options
    (    change: pmt$default_prog_options_change;
     VAR status {control} : ost$status);

*copyc PMH$CHANGE_DEFAULT_PROG_OPTIONS

    TYPE
      valid_termination_error_level = set of pmt$termination_error_level,
      valid_preset_options = set of pmt$initialization_value;

    VAR
      valid_name: boolean,
      name: ost$name,
      debug_input_name: ost$name,
      debug_output_name: ost$name,
      abort_file_name: ost$name,
      prog_options_and_libraries: ^pmt$prog_options_and_libraries,
      default_program_options: ^pmt$program_options;


    #keypoint (osk$entry, 0, pmk$change_default_prog_options);
    status.normal := TRUE;

{ Validate change.

    IF pmc$load_map_file_specified IN change.contents THEN
      clp$validate_name (change.map_file, name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal ('PM', pme$invalid_file_name, change.map_file, status);
        osp$append_status_parameter (' ', 'load map', status);
        #keypoint (osk$exit, 0, pmk$change_default_prog_options);
        RETURN;
      IFEND;
    IFEND;
    IF pmc$term_error_level_specified IN change.contents THEN
      IF NOT (change.termination_error_level IN -$valid_termination_error_level []) THEN
        osp$set_status_abnormal ('PM', pme$invalid_term_error_level, '', status);
        #keypoint (osk$exit, 0, pmk$change_default_prog_options);
        RETURN;
      IFEND;
    IFEND;
    IF pmc$preset_specified IN change.contents THEN
      IF NOT (change.preset IN -$valid_preset_options []) THEN
        osp$set_status_abnormal ('PM', pme$invalid_preset_option, '', status);
        #keypoint (osk$exit, 0, pmk$change_default_prog_options);
        RETURN;
      IFEND;
    IFEND;
    IF pmc$max_stack_size_specified IN change.contents THEN
      IF (change.maximum_stack_size > UPPERVALUE (ost$segment_length)) OR (change.maximum_stack_size = 0) THEN
        osp$set_status_abnormal ('PM', pme$invalid_stack_size_option, '', status);
        #keypoint (osk$exit, 0, pmk$change_default_prog_options);
        RETURN;
      IFEND;
    IFEND;
    IF pmc$debug_input_specified IN change.contents THEN
      clp$validate_name (change.debug_input, debug_input_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal ('PM', pme$invalid_file_name, change.debug_input, status);
        osp$append_status_parameter (' ', 'debug input', status);
        #keypoint (osk$exit, 0, pmk$change_default_prog_options);
        RETURN;
      IFEND;
    IFEND;
    IF pmc$debug_output_specified IN change.contents THEN
      clp$validate_name (change.debug_output, debug_output_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal ('PM', pme$invalid_file_name, change.debug_output, status);
        osp$append_status_parameter (' ', 'debug output', status);
        #keypoint (osk$exit, 0, pmk$change_default_prog_options);
        RETURN;
      IFEND;
    IFEND;
    IF pmc$abort_file_specified IN change.contents THEN
      clp$validate_name (change.abort_file, abort_file_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal ('PM', pme$invalid_file_name, change.abort_file, status);
        osp$append_status_parameter (' ', 'abort file', status);
        #keypoint (osk$exit, 0, pmk$change_default_prog_options);
        RETURN;
      IFEND;
    IFEND;

{ Record validated change.

    pmp$find_prog_options_and_libs (prog_options_and_libraries);
    default_program_options := prog_options_and_libraries^.default_options;

    IF pmc$load_map_file_specified IN change.contents THEN
      default_program_options^.map_file := name;
    IFEND;
    IF pmc$load_map_options_specified IN change.contents THEN
      IF pmc$no_load_map IN change.map_options THEN
        default_program_options^.map_options := $pmt$load_map_options [];
        IF (change.map_options - $pmt$load_map_options [pmc$no_load_map]) <> $pmt$load_map_options [] THEN
          osp$set_status_abnormal ('PM', pme$map_option_conflict, '', status);
        IFEND;
      ELSE
        default_program_options^.map_options := change.map_options;
      IFEND;
    IFEND;

    IF pmc$term_error_level_specified IN change.contents THEN
      default_program_options^.termination_error_level := change.termination_error_level;
    IFEND;

    IF pmc$preset_specified IN change.contents THEN
      default_program_options^.preset := pmv$preset_conversion_table [change.preset];
    IFEND;

    IF pmc$max_stack_size_specified IN change.contents THEN
      pmp$change_maximum_stack_size (change.maximum_stack_size, default_program_options^.maximum_stack_size);
    IFEND;

    IF pmc$debug_input_specified IN change.contents THEN
      default_program_options^.debug_input := debug_input_name;
    IFEND;
    IF pmc$debug_output_specified IN change.contents THEN
      default_program_options^.debug_output := debug_output_name;
    IFEND;
    IF pmc$abort_file_specified IN change.contents THEN
      default_program_options^.abort_file := abort_file_name;
    IFEND;
    IF pmc$debug_mode_specified IN change.contents THEN
      default_program_options^.debug_mode := change.debug_mode;
    IFEND;

    IF pmc$condition_specified IN change.contents THEN
      default_program_options^.conditions_enabled := default_program_options^.conditions_enabled +
            change.conditions_enabled - change.conditions_inhibited;
      default_program_options^.conditions_inhibited := default_program_options^.conditions_inhibited +
            change.conditions_inhibited - change.conditions_enabled;
    IFEND;

    #keypoint (osk$exit, 0, pmk$change_default_prog_options);

  PROCEND pmp$change_default_prog_options;
?? TITLE := '  [XDCL, #GATE] pmp$change_job_library_list', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$change_job_library_list
    (    delete_libraries: ^pmt$object_library_list;
         add_libraries: ^pmt$object_library_list;
     VAR status: ost$status);

*copyc PMH$CHANGE_JOB_LIBRARY_LIST

    VAR
      prog_options_and_libraries: ^pmt$prog_options_and_libraries;


    #keypoint (osk$entry, 0, pmk$change_job_library_list);

    pmp$find_prog_options_and_libs (prog_options_and_libraries);
    change_library_list (delete_libraries, add_libraries, prog_options_and_libraries^.job_library_list,
          status);

    #keypoint (osk$exit, 0, pmk$change_job_library_list);

  PROCEND pmp$change_job_library_list;
?? TITLE := '  [XDCL, #GATE] pmp$change_debug_library_list', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$change_debug_library_list
    (    delete_libraries: ^pmt$object_library_list;
         add_libraries: ^pmt$object_library_list;
     VAR status: ost$status);

*copyc PMH$CHANGE_DEBUG_LIBRARY_LIST

    VAR
      prog_options_and_libraries: ^pmt$prog_options_and_libraries;


    pmp$find_prog_options_and_libs (prog_options_and_libraries);
    change_library_list (delete_libraries, add_libraries, prog_options_and_libraries^.debug_library_list,
          status);

  PROCEND pmp$change_debug_library_list;
?? TITLE := '  change_library_list', EJECT ??

  PROCEDURE change_library_list
    (    delete_libraries: ^pmt$object_library_list;
         add_libraries: ^pmt$object_library_list;
     VAR library_list: ^pmt$object_library_list;
     VAR status: ost$status);

{
{ PURPOSE:
{   The purpose of this procedure is to add or delete libraries from the
{   given library list.
{

    VAR
      contains_data: boolean,
      current_attributes: array [1 .. 2] of amt$get_item,
      current_list_length: pmt$number_of_libraries,
      evaluated_file_reference: fst$evaluated_file_reference,
      existing_file: boolean,
      free_list: ^pmt$object_library_list,
      i: pmt$number_of_libraries,
      j: pmt$number_of_libraries,
      library_index: pmt$number_of_libraries,
      local_file: boolean,
      name: ost$name,
      new_library_list: ^pmt$object_library_list,
      path_handle_name: fst$path_handle_name,
      valid_name: boolean;


    status.normal := TRUE;

    IF delete_libraries <> NIL THEN
      IF (UPPERBOUND (delete_libraries^) = 1) AND (delete_libraries^ [1] = 'ALL') THEN
        free_list := library_list;
        library_list := NIL;
        IF free_list <> NIL THEN
          FREE free_list IN osv$task_shared_heap^;
        IFEND;
      ELSE
        IF library_list = NIL THEN
          osp$set_status_abnormal ('PM', pme$empty_library_list, '', status);
          RETURN;
        IFEND;

        FOR i := 1 TO UPPERBOUND (delete_libraries^) DO
          IF library_list <> NIL THEN
            clp$validate_name (delete_libraries^ [i], name, valid_name);
            IF NOT valid_name THEN
              osp$set_status_abnormal ('PM', pme$invalid_file_name, delete_libraries^ [i], status);
              osp$append_status_parameter (' ', 'library', status);
              RETURN;
            IFEND;

            IF name <> loc$task_services_library_name THEN
              clp$convert_str_to_path_handle (name, FALSE, TRUE, FALSE, path_handle_name,
                    evaluated_file_reference, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              name := path_handle_name;
            IFEND;

            IF (UPPERBOUND (library_list^) = 1) THEN
              IF (library_list^ [1] = name) THEN
                free_list := library_list;
                library_list := NIL;
                IF free_list <> NIL THEN
                  FREE free_list IN osv$task_shared_heap^;
                IFEND;
              ELSE
                osp$set_status_abnormal ('PM', pme$unknown_delete_library, delete_libraries^ [i], status);
                RETURN;
              IFEND;
            ELSE
              ALLOCATE new_library_list: [1 .. (UPPERBOUND (library_list^) - 1)] IN osv$task_shared_heap^;
              library_index := 0;

              FOR j := 1 TO UPPERBOUND (library_list^) DO
                IF library_list^ [j] <> name THEN
                  IF library_index < UPPERBOUND (new_library_list^) THEN
                    library_index := library_index + 1;
                    new_library_list^ [library_index] := library_list^ [j];
                  ELSE
                    osp$set_status_abnormal ('PM', pme$unknown_delete_library, delete_libraries^ [i], status);
                    FREE new_library_list IN osv$task_shared_heap^;
                    RETURN;
                  IFEND;
                IFEND;
              FOREND;

              free_list := library_list;
              library_list := new_library_list;
              IF free_list <> NIL THEN
                FREE free_list IN osv$task_shared_heap^;
              IFEND;
            IFEND;
          ELSE
            osp$set_status_abnormal ('PM', pme$unknown_delete_library, delete_libraries^ [i], status);
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    IFEND;


    IF add_libraries <> NIL THEN
      current_attributes [1].key := amc$file_contents;
      current_attributes [2].key := amc$file_structure;

      FOR i := UPPERBOUND (add_libraries^) DOWNTO 1 DO
        clp$validate_name (add_libraries^ [i], name, valid_name);
        IF NOT valid_name THEN
          osp$set_status_abnormal ('PM', pme$invalid_file_name, add_libraries^ [i], status);
          osp$append_status_parameter (' ', 'library', status);
          RETURN;
        IFEND;

        IF name <> loc$task_services_library_name THEN
          clp$convert_str_to_path_handle (name, FALSE, TRUE, FALSE, path_handle_name,
                evaluated_file_reference, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          name := path_handle_name;
        IFEND;

        amp$get_file_attributes (name, current_attributes, local_file, existing_file, contains_data, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF (name <> loc$task_services_library_name) THEN
          IF NOT existing_file OR NOT contains_data OR (current_attributes [1].file_contents <> amc$object) OR
                (current_attributes [2].file_structure <> amc$library) THEN
            osp$set_status_abnormal ('PM', pme$file_not_existing_library, add_libraries^ [i], status);
            RETURN;
          IFEND;

        ELSEIF existing_file THEN
          osp$set_status_abnormal ('PM', pme$reserved_library_name, add_libraries^ [i], status);
          RETURN;
        IFEND;

        IF library_list = NIL THEN
          current_list_length := 0;
        ELSE
          current_list_length := UPPERBOUND (library_list^);
        IFEND;

        FOR j := 1 TO current_list_length DO
          IF name = library_list^ [j] THEN
            osp$set_status_abnormal ('PM', pme$duplicate_add_library, add_libraries^ [i], status);
            RETURN;
          IFEND;
        FOREND;

        ALLOCATE new_library_list: [1 .. (current_list_length + 1)] IN osv$task_shared_heap^;
        new_library_list^ [1] := name;
        FOR j := 2 TO UPPERBOUND (new_library_list^) DO
          new_library_list^ [j] := library_list^ [j - 1];
        FOREND;

        free_list := library_list;
        library_list := new_library_list;
        IF free_list <> NIL THEN
          FREE free_list IN osv$task_shared_heap^;
        IFEND;
      FOREND;
    IFEND;

  PROCEND change_library_list;
?? TITLE := '  [XDCL] pmp$eo_size_program_attributes', EJECT ??

  FUNCTION [XDCL] pmp$eo_size_program_attributes: clt$environment_object_size;

{
{ PURPOSE:
{   This function is called during job initialization to provide the
{   environment object manager with the size of the PROGRAM_ATTRIBUTES
{   environment object.
{
{ NOTE:
{   For a complete description of the interface to this procedure see module
{   CLM$ENVIRONMENT_OBJECT_DATA.
{


    pmp$eo_size_program_attributes := #SIZE (pmt$prog_options_and_libraries);

  FUNCEND pmp$eo_size_program_attributes;
?? TITLE := '  [XDCL] pmp$eo_init_program_attributes', EJECT ??

  PROCEDURE [XDCL] pmp$eo_init_program_attributes
    (    object: ^clt$environment_object_contents);

{
{ PURPOSE:
{   This procedure is called during job initialization to provide an initial
{   value for the PROGRAM_ATTRIBUTES environment object.
{
{ NOTE:
{   For a complete description of the interface to this procedure see module
{   CLM$ENVIRONMENT_OBJECT_DATA.
{

    VAR
      prog_options_and_libraries: ^pmt$prog_options_and_libraries;


    prog_options_and_libraries := object;

    prog_options_and_libraries^.default_options := NIL;
    prog_options_and_libraries^.job_library_list := NIL;
    prog_options_and_libraries^.debug_library_list := NIL;

  PROCEND pmp$eo_init_program_attributes;
?? TITLE := '  [XDCL] pmp$eo_push_program_attributes', EJECT ??

  PROCEDURE [XDCL] pmp$eo_push_program_attributes
    (    push_reason: clt$env_object_push_reason;
         new_object: ^clt$environment_object_contents;
         new_object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

{
{ PURPOSE:
{   This procedure is called when the PROGRAM_ATTRIBUTES environment object is
{   being pushed.  It makes copies of the program options, job library list and
{   debug library list.
{
{ NOTE:
{   For a complete description of the interface to this procedure see module
{   CLM$ENVIRONMENT_OBJECT_DATA.
{

    VAR
      new_debug_library_list: ^pmt$object_library_list,
      new_default_program_options: ^pmt$program_options,
      new_job_library_list: ^pmt$object_library_list,
      new_prog_options_and_libraries: ^pmt$prog_options_and_libraries,
      old_prog_options_and_libraries: ^pmt$prog_options_and_libraries;


    status.normal := TRUE;

    new_prog_options_and_libraries := new_object;
    old_prog_options_and_libraries := pushed_object;

    IF old_prog_options_and_libraries^.default_options <> NIL THEN
      ALLOCATE new_default_program_options IN osv$task_shared_heap^;
      new_default_program_options^ := old_prog_options_and_libraries^.default_options^;
    ELSE
      new_default_program_options := NIL;
    IFEND;

    IF old_prog_options_and_libraries^.job_library_list <> NIL THEN
      ALLOCATE new_job_library_list: [1 .. UPPERBOUND (old_prog_options_and_libraries^.job_library_list^)] IN
            osv$task_shared_heap^;
      new_job_library_list^ := old_prog_options_and_libraries^.job_library_list^;
    ELSE
      new_job_library_list := NIL;
    IFEND;

    IF old_prog_options_and_libraries^.debug_library_list <> NIL THEN
      ALLOCATE new_debug_library_list: [1 .. UPPERBOUND (old_prog_options_and_libraries^.
            debug_library_list^)] IN osv$task_shared_heap^;
      new_debug_library_list^ := old_prog_options_and_libraries^.debug_library_list^;
    ELSE
      new_debug_library_list := NIL;
    IFEND;

    new_prog_options_and_libraries^.default_options := new_default_program_options;
    new_prog_options_and_libraries^.job_library_list := new_job_library_list;
    new_prog_options_and_libraries^.debug_library_list := new_debug_library_list;

  PROCEND pmp$eo_push_program_attributes;
?? TITLE := '  [XDCL] pmp$eo_pop_program_attributes', EJECT ??

  PROCEDURE [XDCL] pmp$eo_pop_program_attributes
    (    pop_reason: clt$env_object_pop_reason;
         object: ^clt$environment_object_contents;
         object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

{
{ PURPOSE:
{   This procedure is called when the PROGRAM_ATTRIBUTES environment object is
{   being popped.  It releases the space for the program options, job library
{   list and debug library list.
{
{ NOTE:
{   For a complete description of the interface to this procedure see module
{   CLM$ENVIRONMENT_OBJECT_DATA.
{

    VAR
      prog_options_and_libraries: ^pmt$prog_options_and_libraries;


    status.normal := TRUE;

    prog_options_and_libraries := object;

    IF prog_options_and_libraries^.default_options <> NIL THEN
      FREE prog_options_and_libraries^.default_options IN osv$task_shared_heap^;
    IFEND;
    IF prog_options_and_libraries^.job_library_list <> NIL THEN
      FREE prog_options_and_libraries^.job_library_list IN osv$task_shared_heap^;
    IFEND;
    IF prog_options_and_libraries^.debug_library_list <> NIL THEN
      FREE prog_options_and_libraries^.debug_library_list IN osv$task_shared_heap^;
    IFEND;

  PROCEND pmp$eo_pop_program_attributes;

MODEND pmm$default_loader_param_mgmt;
*DECK DECK=PMM$DISABLE_MAIN_OPERATOR_WI_PD EXPAND=TRUE
create_program_description name=(disable_main_operator_window, dismow) ..
      starting_procedure=pmp$_disable_main_operator_wind log_option=manual ..
      library=osf$current_library termination_error_level=warning ..
      load_map_options=none load_map=$null debug_mode=off
*DECK DECK=PMM$DISPLAY_ACTIVE_TASKS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Program Management : Display Active Tasks Command' ??
MODULE pmm$display_active_tasks;

{
{ PURPOSE:
{   This module contains the display task status command.
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc ost$status
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$convert_integer_to_string
*copyc clp$convert_integer_to_rjstring
*copyc clp$open_display_reference
*copyc clp$close_display
*copyc clp$put_partial_display
*copyc clv$nil_display_control
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc pmp$acquire_raw_task_statistics

?? TITLE := 'pmp$_display_active_tasks', EJECT ??

  PROCEDURE [XDCL] pmp$_display_active_tasks
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$disat) display_active_tasks, disat (
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 12, 12, 14, 17, 44, 227],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$DISAT'], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    pmp$display_active_tasks (pvt [p$output].value^.file_value^, status);

  PROCEND pmp$_display_active_tasks;
?? TITLE := 'pmp$display_active_tasks', EJECT ??
*copyc pmh$display_active_tasks

  PROCEDURE [XDCL] pmp$display_active_tasks
    (    output: fst$file_reference;
     VAR status: ost$status);

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;
?? TITLE := 'put_partial_display', EJECT ??

    PROCEDURE [INLINE] put_partial_display
      (    str: string ( * );
           trim_option: clt$trim_display_text_option;
           term_option: amt$term_option);

      clp$put_partial_display (display_control, str, trim_option, term_option, status);
      IF NOT status.normal THEN
        EXIT pmp$display_active_tasks;
      IFEND;

    PROCEND put_partial_display;
?? OLDTITLE, EJECT ??

    VAR
      active_task_count: 0 .. pmc$max_task_id,
      active_task_statistics: array [1 .. 100] of pmt$raw_task_statistics,
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      ignore_status: ost$status,
      local_status: ost$status,
      milliseconds: integer,
      statistics: string (103),
      strng: ost$string,
      task: 1 .. pmc$max_task_id,
      task_name: ost$name,
      task_count: ost$string;


    status.normal := TRUE;
    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    osp$establish_block_exit_hndlr (^abort_handler);

  /display_active_tasks/
    BEGIN

      default_ring_attributes.r1 := #RING (^default_ring_attributes);
      default_ring_attributes.r2 := #RING (^default_ring_attributes);
      default_ring_attributes.r3 := #RING (^default_ring_attributes);

      clp$open_display_reference (output, NIL, fsc$list, default_ring_attributes, display_control, status);
      IF NOT status.normal THEN
        EXIT /display_active_tasks/;
      IFEND;

      pmp$acquire_raw_task_statistics (active_task_count, active_task_statistics);

      put_partial_display ('ACTIVE TASKS = ', clc$no_trim, amc$start);
      clp$convert_integer_to_string (active_task_count, 10, FALSE, task_count, ignore_status);
      put_partial_display (task_count.value (1, task_count.size), clc$trim, amc$terminate);

      IF (active_task_count > UPPERBOUND (active_task_statistics)) THEN
        active_task_count := UPPERBOUND (active_task_statistics);
      IFEND;

      FOR task := 1 TO active_task_count DO
        statistics (1, 31) := active_task_statistics [task].task_name;

        statistics (32, * ) := ' job time =      0.000  monitor time =      0.000  page faults = ******';
        milliseconds := active_task_statistics [task].cp_time.task_time DIV 1000;
        clp$convert_integer_to_rjstring (milliseconds DIV 1000, 10, FALSE, ' ', statistics (43, 7),
              ignore_status);
        clp$convert_integer_to_rjstring (milliseconds MOD 1000, 10, FALSE, '0', statistics (51, 3),
              ignore_status);
        milliseconds := active_task_statistics [task].cp_time.monitor_time DIV 1000;
        clp$convert_integer_to_rjstring (milliseconds DIV 1000, 10, FALSE, ' ', statistics (70, 7),
              ignore_status);
        clp$convert_integer_to_rjstring (milliseconds MOD 1000, 10, FALSE, '0', statistics (78, 3),
              ignore_status);
        clp$convert_integer_to_string (active_task_statistics [task].page_fault_count, 10, FALSE, strng,
              ignore_status);
        IF ignore_status.normal THEN
          statistics (97, 6) := strng.value (1, strng.size);
        IFEND;

        put_partial_display (statistics, clc$no_trim, amc$terminate);
      FOREND;
    END /display_active_tasks/;

    clp$close_display (display_control, local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND pmp$display_active_tasks;

MODEND pmm$display_active_tasks;
*DECK DECK=PMM$DISPOSE_OF_CONDITIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Control - Program Conditions' ??
MODULE pmm$dispose_of_conditions;

{   PURPOSE:
{     This module restricts the knowledge of disposing of conditions.
{     The module contains the procedures to dispose of all conditions.

{   DESIGN:
{     The procedures in this module are designed to have an execute
{     bracket of 2, 13 and a call bracket of 13.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc osc$space_unavailable_condition
*copyc osc$unseen_mail_condition
*copyc osc$volume_unavailable_cond
*copyc dbt$debug
*copyc osc$unseen_mail_condition
*copyc mmd$segment_access_condition
*copyc mme$condition_codes
*copyc osc$processor_defined_registers
*copyc osd$conditions
*copyc osd$registers
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc ost$name
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc ost$virtual_machine_identifier
*copyc pme$broken_condition_processor
*copyc pme$condition_exceptions
*copyc pmk$keypoints
*copyc pmt$condition
*copyc pmt$condition_environment
*copyc pmt$condition_identifier
*copyc pmt$delayed_condition
*copyc pmt$established_handler_internl
*copyc pmt$ext_default_cond_handler
*copyc pmt$internal_condition
*copyc pmt$standard_selection
*copyc pmt$sys_default_cond_handler
?? POP ??
*copyc bap$find_open_file_via_segment
*copyc clp$default_unseen_mail_handler
*copyc clp$determine_when_condition
*copyc clp$get_fs_path_string
*copyc clp$process_when_cond_in_task
*copyc clp$validate_name
*copyc i#disable_traps
*copyc i#enable_traps
*copyc i#restore_traps
*copyc ifp$default_interactive_handler
*copyc ifp$fetch_context
*copyc jmp$begin_timesharing_handler
*copyc jmp$default_job_resource_hndlr
*copyc jmp$end_timesharing_handler
*copyc ofp$display_status_message
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$clear_wait_message
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$establish_condition_handler
*copyc osp$executing_in_job_monitor
*copyc osp$format_segment_condition
*copyc osp$format_system_condition
*copyc osp$generate_log_message
*copyc osp$generate_message
*copyc osp$get_current_display_message
*copyc osp$log_io_read_error
*copyc osp$recover_job
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$system_error
*copyc pfp$get_file_info
*copyc pmp$abort
*copyc pmp$build_ring_crossing_frame
*copyc pmp$change_term_error_level
*copyc pmp$clear_pit_has_been_set
*copyc pmp$clear_pit_was_set_in_ch
*copyc pmp$debug_critical_frame
*copyc pmp$delete_current_environment
*copyc pmp$delete_environment
*copyc pmp$establish_condition_handler
*copyc pmp$exit
*copyc pmp$find_debug
*copyc pmp$find_handler_in_stack
*copyc pmp$find_handler_in_stack_frame
*copyc pmp$get_current_environment
*copyc pmp$get_delayed_condition
*copyc pmp$get_job_mode
*copyc pmp$get_mainframe_attributes
*copyc pmp$is_there_a_handler_in_stack
*copyc pmp$load
*copyc pmp$log
*copyc pmp$long_term_wait
*copyc pmp$pit_was_set
*copyc pmp$pit_was_set_in_ch
*copyc pmp$post_current_environment
*copyc pmp$post_delayed_condition
*copyc pmp$push_task_debug_mode
*copyc pmp$set_where_pit_can_be_cleard
*copyc pmp$task_debug_mode_on
*copyc pmp$task_debug_ring
*copyc pmp$task_state
*copyc pmp$terminate_popper
*copyc pmp$validate_previous_save_area
*copyc tmp$find_ring_crossing_frame

*copyc bav$task_file_table
*copyc bav$last_tft_entry
*copyc bav$tft_entry_assignment
*copyc pmv$task_execution_phase

{ The following two entry points bracket the vector simulator routine.

  VAR
    pma$vector_simulator: [XREF] cell,
    pma$vector_simulator_end: [XREF] cell;

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
?? NEWTITLE := 'condition selectors', EJECT ??


  VAR
    block_exit: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
          [pmc$condition_combination, $pmt$condition_combination [pmc$block_exit_processing]],

{The following condition selector is named for the detection of software errors which are
{reflected as hardware conditions. However, included in the selector,
{implicitly via combination, is the hardware detected uncorrected error which is dealt with
{distinctly by the respective condition handler.

    condition_handler_faults: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
          [pmc$condition_combination, $pmt$condition_combination
          [pmc$system_conditions, mmc$segment_access_condition]],

    environment_overwrite: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
          [pmc$system_conditions, $pmt$system_conditions [pmc$access_violation, pmc$invalid_segment_ring_0,
          pmc$address_specification], * ],
    stack_read_error: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
          [pmc$condition_combination, $pmt$condition_combination [mmc$segment_access_condition]];

?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'default_system_cond_handler', EJECT ??

{ PURPOSE:
{

  PROCEDURE default_system_cond_handler
    (    current_environment: ^pmt$condition_environment;
         inconsistent_stack: boolean);

    VAR
      executing_ring: ost$ring,
      status: ost$status;

    IF inconsistent_stack AND (pmv$task_execution_phase = pmc$task_popping_stack_frames) THEN
      osp$set_status_condition (pme$inconsistent_stack, status);
      pmp$terminate_popper (status); { Does not return
    IFEND;
    osp$format_system_condition (current_environment^.condition.system,
          current_environment^.condition.untranslatable_pointer, current_environment^.condition_save_area,
          status);

    CASE #RING (^executing_ring) OF
    = osc$tmtr_ring =
      IF (current_environment^.condition.system = pmc$detected_uncorrected_err) THEN
        pmp$exit (status);
      ELSE
        osp$system_error ('R2 system condition', ^status);
      IFEND;
    = osc$tsrv_ring .. osc$user_ring_4 =
      IF (current_environment^.condition.system = pmc$detected_uncorrected_err) THEN
        pmp$exit (status);
      ELSE
        pmp$abort (status);
      IFEND;
    CASEND;
  PROCEND default_system_cond_handler;
?? OLDTITLE ??
?? NEWTITLE := 'default_seg_access_cond_handler', EJECT ??

{ PURPOSE:
{

  PROCEDURE default_seg_access_cond_handler
    (    current_environment: ^pmt$condition_environment);

    TYPE
      segment_access_condition_set = set of pmt$condition_identifier;

    VAR
      executing_ring: ost$ring,
      fatal_segment_condition: boolean,
      job_monitor_task: boolean,
      status: ost$status,
      condition_status: ost$status;

    osp$format_segment_condition ('MM', current_environment^.condition.segment_access,
          current_environment^.condition_save_area, condition_status, status);
    IF NOT status.normal THEN
      osp$system_error ('undefined segment condition', ^status);
    IFEND;

    fatal_segment_condition := current_environment^.condition.segment_access.identifier IN
          -$segment_access_condition_set [mmc$sac_pf_space_limit_exceeded, mmc$sac_tf_space_limit_exceeded];
    job_monitor_task := osp$executing_in_job_monitor ();

    CASE #RING (^executing_ring) OF
    = osc$tmtr_ring =
      IF fatal_segment_condition THEN
        osp$system_error ('R2 segment access condition', ^condition_status);
      IFEND;
    = osc$tsrv_ring .. osc$user_ring_4 =
      IF fatal_segment_condition OR (NOT job_monitor_task) THEN
        IF job_monitor_task THEN
          pmp$exit (condition_status);
        ELSE
          pmp$abort (condition_status);
        IFEND;
      IFEND;
    ELSE
    CASEND;
  PROCEND default_seg_access_cond_handler;
?? OLDTITLE ??
?? NEWTITLE := 'post_ring_crossing_condition', EJECT ??

{ PURPOSE:
{

  PROCEDURE post_ring_crossing_condition
    (    trapped_sfsa: ^ost$stack_frame_save_area;
         condition_environment: ^pmt$condition_environment;
         below_ring: ost$valid_ring;
     VAR post_status: ost$status;
     VAR default_status: ost$status);

    VAR
      condition_processed: boolean,
      default_condition: pmt$condition,
      system_default_handler: ^pmt$sys_default_cond_handler,
      osv$job_recovery_required: [XREF] boolean,
      x_frame: ^ost$stack_frame_save_area,
      starting_frame: ^ost$stack_frame_save_area,
      ignore_status: ost$status,
      delay: pmt$delayed_condition;

?? NEWTITLE := 'perform_default_processing', EJECT ??

    PROCEDURE perform_default_processing
      (VAR default_status: ost$status);

      CONST
        screen_default_handler_name = 'CSP$DEFAULT_CONDITION_HANDLER  ';

      VAR
        callers_save_area: ^ost$stack_frame_save_area,
        external_default_handler: ^pmt$ext_default_cond_handler,
        ignore_term_error_level: ost$status_severity,
        interactive_context: array [1 .. 1] of ift$fetch_context_attribute,
        job_mode: jmt$job_mode,
        loaded_address: pmt$loaded_address,
        original_term_error_level: ost$status_severity;

?? NEWTITLE := 'abort_handler', EJECT ??

      PROCEDURE abort_handler
        (    condition: pmt$condition;
             ignore_info: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);


        IF condition.selector = pmc$block_exit_processing THEN
          pmp$change_term_error_level (original_term_error_level, ignore_term_error_level, ignore_status);
          RETURN;
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      PROCEND abort_handler;
?? TITLE := 'invoke_condition_handler', EJECT ??

      PROCEDURE invoke_condition_handler
        (    condition: pmt$condition;
             condition_info: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);

        CONST
          aborted_with = '* * *   CSP$DEFAULT_CONDITION_HANDLER aborted with...';

        VAR
          condition_status: ost$status;


        CASE condition.selector OF

        = pmc$system_conditions =
          IF (($pmt$system_conditions [pmc$instruction_specification, pmc$address_specification,
                pmc$access_violation, pmc$environment_specification, pmc$invalid_segment_ring_0,
                pmc$out_call_in_return] * condition.system_conditions) <> $pmt$system_conditions []) AND
                (save_area^.minimum_save_area.a2_previous_save_area = callers_save_area) THEN
          ELSE
            pmp$log (aborted_with, ignore_status);
            osp$set_status_from_condition (pmc$program_management_id, condition, save_area,
                  condition_status, ignore_status);
            osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], condition_status, ignore_status);
          IFEND;
          system_default_handler^ (default_condition, default_status);
          EXIT perform_default_processing;

        = mmc$segment_access_condition =
          pmp$log (aborted_with, ignore_status);
          osp$set_status_from_condition (pmc$program_management_id, condition, save_area,
                condition_status, ignore_status);
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], condition_status, ignore_status);
          system_default_handler^ (default_condition, default_status);
          EXIT perform_default_processing;

        = pmc$block_exit_processing =
          RETURN;

        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        CASEND;

      PROCEND invoke_condition_handler;
?? OLDTITLE, EJECT ??

      default_status.normal := TRUE;

      job_mode := jmc$batch;
      pmp$get_job_mode (job_mode, ignore_status);
      IF job_mode = jmc$batch THEN

{ perform system default action if in a batch job

        system_default_handler^ (default_condition, default_status);
        RETURN;
      IFEND;

      interactive_context [1].key := ifc$previous_mode;
      interactive_context [1].previous_mode := ifc$line;
      ifp$fetch_context (interactive_context, ignore_status);
      IF interactive_context [1].previous_mode = ifc$line THEN

{ perform the system default action if currently in "line mode"

        system_default_handler^ (default_condition, default_status);
        RETURN;
      IFEND;

{ try to load the default handler for "screen mode"

      loaded_address.kind := pmc$procedure_address;
      loaded_address.pointer_to_procedure := NIL;
      original_term_error_level := osc$fatal_status;
      #SPOIL (original_term_error_level);
      osp$establish_block_exit_hndlr (^abort_handler);
      pmp$change_term_error_level (osc$fatal_status, original_term_error_level, default_status);
      IF default_status.normal THEN
        pmp$load (screen_default_handler_name, pmc$procedure_address, loaded_address, default_status);
        IF NOT default_status.normal THEN
          loaded_address.pointer_to_procedure := NIL;
        IFEND;
        pmp$change_term_error_level (original_term_error_level, ignore_term_error_level, default_status);
        osp$disestablish_cond_handler;
      IFEND;

      IF (NOT default_status.normal) OR (loaded_address.pointer_to_procedure = NIL) THEN

{ couldn't load the "screen mode" default handler so perform the system action

        default_status.normal := TRUE;
        system_default_handler^ (default_condition, default_status);
        RETURN;
      IFEND;

      #CONVERT_POINTER_TO_PROCEDURE (loaded_address.pointer_to_procedure, external_default_handler);

      callers_save_area := #PREVIOUS_SAVE_AREA ();
      #SPOIL (callers_save_area);
      osp$establish_condition_handler (^invoke_condition_handler, FALSE);

{ call (or at least try to call) the "screen mode" default handler

      external_default_handler^ (default_condition, system_default_handler, default_status);

      osp$disestablish_cond_handler;

    PROCEND perform_default_processing;
?? OLDTITLE ??
?? NEWTITLE := 'process_scl_condition', EJECT ??

    PROCEDURE process_scl_condition
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_processed: boolean;
       VAR default_status: ost$status);

      VAR
        when_condition_definition: clt$when_condition_definition;


      clp$determine_when_condition (condition, condition_information, save_area, when_condition_definition,
            default_status);

      IF NOT default_status.normal THEN
        default_status.normal := TRUE;
        condition_processed := FALSE;
        RETURN;
      IFEND;

      clp$process_when_cond_in_task (when_condition_definition, ^perform_default_processing,
            condition_processed, default_status);

      default_status.normal := TRUE;

    PROCEND process_scl_condition;
?? OLDTITLE, EJECT ??

    post_status.normal := TRUE;
    default_status.normal := TRUE;
    x_frame := trapped_sfsa;
    starting_frame := trapped_sfsa;
    WHILE ((starting_frame <> NIL) AND (starting_frame^.minimum_save_area.a2_previous_save_area <> NIL) AND
          (#RING (starting_frame^.minimum_save_area.a2_previous_save_area) < below_ring) AND
          post_status.normal) DO
      tmp$find_ring_crossing_frame (starting_frame, x_frame, post_status);
      starting_frame := x_frame^.minimum_save_area.a2_previous_save_area;
    WHILEND;

    IF post_status.normal THEN
      IF (x_frame^.minimum_save_area.a2_previous_save_area <> NIL) THEN
        CASE condition_environment^.condition.class OF
        = pmc$system_conditions =
          delay.delayed_condition := debug;
          delay.condition := condition_environment^.condition;
          delay.condition_save_area := condition_environment^.condition_save_area^;
          delay.debug_index := condition_environment^.debug_index;

        = jmc$job_resource_condition =
          delay.delayed_condition := job_resource;
          delay.job_resource_condition := condition_environment^.condition.job_resource;

        = ifc$interactive_condition =
          jmp$begin_timesharing_handler (condition_environment^.condition.interactive);

{ is balanced by an end handler request in pmp$dispose_of_delayed_cond

          delay.delayed_condition := interactive;
          delay.interactive_condition := condition_environment^.condition.interactive;
        = pmc$pit_condition =
          delay.delayed_condition := process_interval_timer;
          pmp$set_where_pit_can_be_cleard;
        = pmc$user_defined_condition =
          delay.delayed_condition := user_condition;
          delay.user_defined := condition_environment^.condition.user_defined;
          delay.propagate_info := condition_environment^.condition.propagate_info;
          delay.condition_descriptor := condition_environment^.condition_descriptor;
          IF condition_environment^.condition.user_defined = 'OSC$JOB_RECOVERY' THEN
            IF osv$job_recovery_required THEN
              osp$recover_job;
            IFEND;
          IFEND;
        ELSE
          osp$set_status_abnormal (pmc$program_management_id, pme$broken_condition_processor,
                'invalid delayed system condition - PMM$DISPOSE_OF_CONDITIONS', post_status);
          osp$system_error ('invalid delayed system condition', ^post_status);
        CASEND;

        pmp$build_ring_crossing_frame (x_frame);
        pmp$post_delayed_condition (^delay, post_status);

      ELSE
        CASE condition_environment^.condition.class OF
        = jmc$job_resource_condition =
          default_condition.selector := jmc$job_resource_condition;
          default_condition.job_resource_condition := condition_environment^.condition.job_resource;
          system_default_handler := ^jmp$default_job_resource_hndlr;
          process_scl_condition (default_condition, condition_environment^.condition_descriptor,
                condition_environment^.condition_save_area, condition_processed, default_status);
          IF NOT (default_status.normal AND condition_processed) THEN
            default_status.normal := TRUE;
            perform_default_processing (default_status);
          IFEND;
        = ifc$interactive_condition =
          default_condition.selector := ifc$interactive_condition;
          default_condition.interactive_condition := condition_environment^.condition.interactive;
          system_default_handler := ^ifp$default_interactive_handler;
          process_scl_condition (default_condition, condition_environment^.condition_descriptor,
                condition_environment^.condition_save_area, condition_processed, default_status);
          IF NOT (default_status.normal AND condition_processed) THEN
            default_status.normal := TRUE;
            perform_default_processing (default_status);
          IFEND;
        = pmc$system_conditions =
          CASE condition_environment^.condition.system OF
          = pmc$debug_unselectable =
            osp$set_status_abnormal (pmc$program_management_id, pme$invalid_debug_trap,
                  'debug trap with no debugger loaded', default_status);
            pmp$exit (default_status);
          ELSE
            osp$set_status_abnormal (pmc$program_management_id, pme$broken_condition_processor,
                  'invalid delayed system condition - PMM$DISPOSE_OF_CONDITIONS', default_status);
            osp$system_error ('invalid delayed system condition', ^default_status);
          CASEND;
        = pmc$pit_condition =
          {there is no standard system procedure for a process interval timer condition} ;
          pmp$clear_pit_has_been_set;
        = pmc$user_defined_condition =
          IF condition_environment^.condition.user_defined = 'OSC$JOB_RECOVERY' THEN
            IF osv$job_recovery_required THEN
              osp$recover_job;
            IFEND;
          IFEND;
          default_condition.selector := pmc$user_defined_condition;
          default_condition.user_condition_name := condition_environment^.condition.user_defined;
          IF default_condition.user_condition_name = osc$unseen_mail_condition THEN
            system_default_handler := ^clp$default_unseen_mail_handler;
          ELSEIF condition_environment^.condition.propagate_info.call_default_handler THEN
            system_default_handler := ^default_user_defined_handler;
          ELSE
            system_default_handler := ^ignore_user_defined_condition;
          IFEND;
          IF NOT condition_environment^.condition.propagate_info.notify_scl THEN
            condition_processed := FALSE;
            default_status.normal := TRUE;
          ELSE
            process_scl_condition (default_condition, condition_environment^.condition_descriptor,
                  condition_environment^.condition_save_area, condition_processed, default_status);
          IFEND;
          IF NOT (default_status.normal AND condition_processed) THEN
            default_status.normal := TRUE;
            perform_default_processing (default_status);
          IFEND;
          default_status.normal := TRUE;
        ELSE
          osp$set_status_abnormal (pmc$program_management_id, pme$broken_condition_processor,
                'invalid delayed condition - PMM$DISPOSE_OF_CONDITIONS', default_status);
          osp$system_error ('invalid delayed condition', ^default_status);
        CASEND;
      IFEND;
    IFEND;
  PROCEND post_ring_crossing_condition;
?? OLDTITLE ??
?? NEWTITLE := 'set_debug_in_user_mask', EJECT ??

{ PURPOSE:
{

  PROCEDURE set_debug_in_user_mask;

    VAR
      sfsa: ^ost$stack_frame_save_area;

    IF pmp$task_debug_mode_on () THEN
      sfsa := #PREVIOUS_SAVE_AREA ();
      sfsa^.minimum_save_area.user_mask := sfsa^.minimum_save_area.user_mask + $ost$user_conditions
            [osc$debug];
    IFEND;
  PROCEND set_debug_in_user_mask;
?? OLDTITLE ??
?? NEWTITLE := 'clear_debug_in_user_mask', EJECT ??

{ PURPOSE:
{

  PROCEDURE clear_debug_in_user_mask;

    VAR
      sfsa: ^ost$stack_frame_save_area;

    sfsa := #PREVIOUS_SAVE_AREA ();
    sfsa^.minimum_save_area.user_mask := sfsa^.minimum_save_area.user_mask - $ost$user_conditions [osc$debug];
  PROCEND clear_debug_in_user_mask;
?? TITLE := '  determine_call_debug' ??
?? EJECT ??

  PROCEDURE determine_call_debug
    (VAR call_debug: boolean);

    VAR
      executing_ring: ost$ring,
      debug: dbt$debug;

    pmp$find_debug (debug);
    call_debug := (pmp$task_debug_mode_on () AND (#RING (^executing_ring) >= pmp$task_debug_ring ()) AND
          (debug <> NIL));
  PROCEND determine_call_debug;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'dispose_condition_with_debugger', EJECT ??

{ PURPOSE:
{

  PROCEDURE dispose_condition_with_debugger
    (    current_environment: ^pmt$condition_environment;
         trapped_sfsa: ^ost$stack_frame_save_area;
         multiple_conditions: boolean);

    VAR
      debug: dbt$debug,
      debug_condition: pmt$condition,
      debug_status: ost$status,
      delete: ost$status,
      environment: pmt$condition_environment,
      ignore_status: ost$status,
      nonlocal_exit: pmt$established_handler,
      trap_enables: 0 .. 3;

?? NEWTITLE := 'dispose_of_nonlocal_exit', EJECT ??

{ PURPOSE:
{ This procedure (condition handler) ensures that the environment saved
{ before the debugger was called is deleted before a debugger's nonlocal
{ exit is permitted to complete.

    PROCEDURE dispose_of_nonlocal_exit
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      pmp$delete_environment (save_area, status);
      IF NOT status.normal THEN
        dispose_of_environment_overwrit (status);
      IFEND;
    PROCEND dispose_of_nonlocal_exit;
?? OLDTITLE, EJECT ??

    current_environment^.established_descriptor := NIL;
    current_environment^.handler_save_area := trapped_sfsa;
    environment := current_environment^;
    i#disable_traps (trap_enables);
    pmp$post_current_environment (^environment);
    pmp$establish_condition_handler (block_exit, ^dispose_of_nonlocal_exit, ^nonlocal_exit, ignore_status);
    i#enable_traps (trap_enables);
    debug_condition.selector := environment.condition.class;
    CASE environment.condition.class OF
    = pmc$system_conditions =
      debug_condition.system_conditions := $pmt$system_conditions [environment.condition.system];
      debug_condition.untranslatable_pointer := environment.condition.untranslatable_pointer;
    = pmc$block_exit_processing =
      debug_condition.reason := environment.condition.reason;
    = mmc$segment_access_condition =
      debug_condition.segment_access_condition := environment.condition.segment_access;
    = ifc$interactive_condition =
      debug_condition.interactive_condition := environment.condition.interactive;
    = jmc$job_resource_condition =
      debug_condition.job_resource_condition := environment.condition.job_resource;
    = pmc$pit_condition =
      ;
    = pmc$user_defined_condition =
      debug_condition.user_condition_name := environment.condition.user_defined;
    ELSE
    CASEND;

    debug_status.normal := TRUE;
    pmp$find_debug (debug);
    debug^ (debug_condition, environment.condition_descriptor, environment.condition_save_area, trapped_sfsa,
          environment.debug_index, multiple_conditions, debug_status);
    pmp$delete_current_environment (delete);
    #WRITE_REGISTER (osc$pr_clear_critical_frame, 0);
    IF NOT delete.normal THEN
      dispose_of_environment_overwrit (delete);
    IFEND;
    IF NOT debug_status.normal THEN
      pmp$push_task_debug_mode (pmc$debug_mode_off, ignore_status);
      pmp$exit (debug_status);
    IFEND;
  PROCEND dispose_condition_with_debugger;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_of_environment_overwrit', EJECT ??

{ PURPOSE:
{

  PROCEDURE dispose_of_environment_overwrit
    (VAR status {input, output} : ost$status);

    VAR
      executing_ring: ost$ring;

    CASE #RING (^executing_ring) OF
    = osc$os_ring_1 =
      osp$system_error ('R1 stack overwritten', ^status);
    = osc$tmtr_ring =
      osp$system_error ('R2 stack overwritten', ^status);
    = osc$tsrv_ring .. osc$user_ring_4 =
      osp$append_status_integer (osc$status_parameter_delimiter, #RING (^executing_ring), 10, FALSE, status);
      pmp$abort (status);
    CASEND;
  PROCEND dispose_of_environment_overwrit;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_of_descriptor_overwrit', EJECT ??

{ PURPOSE:
{

  PROCEDURE dispose_of_descriptor_overwrit
    (    condition: pmt$condition;
         condition_descriptor: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR status: ost$status);

    osp$set_status_abnormal (pmc$program_management_id, pme$stack_overwritten, '', status);
    dispose_of_environment_overwrit (status);
  PROCEND dispose_of_descriptor_overwrit;
?? OLDTITLE ??
?? NEWTITLE := 'find_users_handler', EJECT ??

{ PURPOSE:
{

  PROCEDURE find_users_handler
    (    environment {input, output} : ^pmt$condition_environment;
     VAR handler_found: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'dispose_of_stack_read_error', EJECT ??

{ PURPOSE:
{ This procedure (condition handler) ensures that segment access
{ conditions which may arise when scanning stack frames are reported.

    PROCEDURE dispose_of_stack_read_error
      (    segment_access_condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR ignore_status: ost$status);

      osp$set_status_from_condition (pmc$program_management_id, segment_access_condition, save_area, status,
            status);
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
      osp$set_status_abnormal (pmc$program_management_id, pme$inconsistent_stack, '', status);

      EXIT find_users_handler;

    PROCEND dispose_of_stack_read_error;
?? OLDTITLE, EJECT ??

    VAR
      read_error_descriptor: pmt$established_handler,
      ignore_status: ost$status;

    pmp$establish_condition_handler (stack_read_error, ^dispose_of_stack_read_error, ^read_error_descriptor,
          ignore_status);
    IF (environment^.condition.class = pmc$block_exit_processing) THEN
      pmp$find_handler_in_stack_frame (environment^.condition, environment^.condition_save_area,
            environment^.established_descriptor, environment^.handler_save_area, status);
    ELSE
      pmp$find_handler_in_stack (environment^.condition, environment^.condition_save_area,
            environment^.established_descriptor, environment^.handler_save_area, status);
    IFEND;

    IF status.normal THEN
      handler_found := (environment^.established_descriptor <> NIL);
    ELSE
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
    IFEND;
  PROCEND find_users_handler;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_pit_with_handler', EJECT ??

{ PURPOSE:
{

  PROCEDURE dispose_pit_with_handler
    (    current_environment {input, output} : ^pmt$condition_environment;
     VAR status: ost$status);


    VAR
      environment: pmt$condition_environment,
      handler_condition: pmt$condition,
      dispose_pit_psa: ^ost$stack_frame_save_area;

?? NEWTITLE := 'dispose_of_handler_faults', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that faults
{   occuring during the call to a user's condition handler
{   are reported.
{

    PROCEDURE dispose_of_handler_faults
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR fault_status: ost$status);


      VAR
        ignore_status: ost$status;

{ determine if call to the handler faulted or the handler itself faulted

      IF (save_area^.minimum_save_area.a2_previous_save_area <> dispose_pit_psa) THEN

{ call a user's handler if one is in effect

        pmp$continue_to_cause (pmc$execute_standard_procedure, fault_status);
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, status, status);
        IF (condition.selector <> pmc$system_conditions) OR
              ((condition.selector = pmc$system_conditions) AND
              NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
          osp$set_status_from_condition (pmc$program_management_id, handler_condition,
                environment.condition_save_area, status, status);
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
          osp$set_status_abnormal (pmc$program_management_id, pme$invalid_condition_handler, 'pit conditions',
                status);
        IFEND;
        EXIT dispose_pit_with_handler;
      IFEND;
    PROCEND dispose_of_handler_faults;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_of_nonlocal_exit', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that the previous
{   pit condition environment is deleted before a user's
{   nonlocal exit completes.

    PROCEDURE dispose_of_nonlocal_exit
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);


      pmp$clear_pit_has_been_set;
      pmp$delete_environment (save_area, status);
      IF NOT status.normal THEN
        dispose_of_environment_overwrit (status);
      IFEND;
    PROCEND dispose_of_nonlocal_exit;
?? OLDTITLE, EJECT ??

    VAR
      fault_descriptor: pmt$established_handler,
      nonlocal_exit: pmt$established_handler,
      trap_enables: 0 .. 3,
      ignore_status: ost$status,
      delete: ost$status;

    dispose_pit_psa := #PREVIOUS_SAVE_AREA ();
    environment := current_environment^;
    handler_condition.selector := pmc$pit_condition;
    pmp$establish_condition_handler (condition_handler_faults, ^dispose_of_handler_faults, ^fault_descriptor,
          ignore_status);
    i#disable_traps (trap_enables);
    pmp$post_current_environment (^environment);
    pmp$establish_condition_handler (block_exit, ^dispose_of_nonlocal_exit, ^nonlocal_exit, ignore_status);
    i#enable_traps (trap_enables);

{call the user's condition handler

    set_debug_in_user_mask;
    environment.established_descriptor^.handler^ (handler_condition, NIL, environment.condition_save_area,
          status);
    clear_debug_in_user_mask;
    pmp$delete_current_environment (delete);
    #WRITE_REGISTER (osc$pr_clear_critical_frame, 0);
    IF NOT delete.normal THEN
      dispose_of_environment_overwrit (delete);
    IFEND;
  PROCEND dispose_pit_with_handler;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_pit_condition', EJECT ??

{ PURPOSE:
{

  PROCEDURE dispose_pit_condition
    (    sfsa: ^ost$stack_frame_save_area;
         multiple_conditions: boolean);


    VAR
      call_debug: boolean,
      executing_ring: ost$ring,
      status: ost$status,
      post_status: ost$status,
      users_handler_found: boolean,
      current_environment: pmt$condition_environment;

    status.normal := TRUE;
    IF pmp$pit_was_set () THEN
      current_environment.condition_save_area := sfsa;
      current_environment.condition.class := pmc$pit_condition;
      current_environment.condition_descriptor := NIL;
      current_environment.debug_index := 0;

      determine_call_debug (call_debug);
      IF NOT call_debug THEN
        find_users_handler (^current_environment, users_handler_found, status);
        IF status.normal THEN
          IF users_handler_found THEN
            pmp$clear_pit_was_set_in_ch;
            dispose_pit_with_handler (^current_environment, status);
            IF NOT pmp$pit_was_set_in_ch () THEN
              pmp$clear_pit_has_been_set;
            IFEND;
          ELSE
            post_ring_crossing_condition (sfsa, ^current_environment, (#RING (^executing_ring) + 1) MOD 16,
                  post_status, status);
            IF NOT post_status.normal THEN

{  Posting the process interval timer condition found an inconsistent stack segment - the pit
{  condition will be ignored and continued execution of the task will detect the inconsistent
{  stack again, at which time the task will be aborted.

              status.normal := TRUE;
              pmp$clear_pit_has_been_set;
            IFEND;
          IFEND;
        ELSE

{finding user's handler found an inconsistent stack segment or handler stack - the pit condition
{will be ignored and continued execution of the task will detect the inconsistent stack again, at
{which time the task will be aborted.

          status.normal := TRUE;
          pmp$clear_pit_has_been_set;
        IFEND;
      ELSE
        pmp$clear_pit_was_set_in_ch;
        dispose_condition_with_debugger (^current_environment, sfsa, multiple_conditions);
        IF NOT pmp$pit_was_set_in_ch () THEN
          pmp$clear_pit_has_been_set;
        IFEND;
      IFEND;
      IF NOT status.normal THEN
        pmp$exit (status);
      IFEND;
    IFEND;
  PROCEND dispose_pit_condition;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_block_exit_with_handler', EJECT ??

{ PURPOSE:
{

  PROCEDURE dispose_block_exit_with_handler
    (    current_environment {input,output} : ^pmt$condition_environment;
     VAR status: ost$status);


    VAR
      environment: pmt$condition_environment,
      handler_condition: pmt$condition,
      dispose_block_exit_psa: ^ost$stack_frame_save_area;

?? NEWTITLE := 'dispose_of_handler_faults', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that faults
{   occuring during the call to a user's condition handler
{   are reported.

    PROCEDURE dispose_of_handler_faults
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR fault_status: ost$status);

      VAR
        ignore_status: ost$status;

{determine if call to the handler faulted or the handler itself faulted

      IF (save_area^.minimum_save_area.a2_previous_save_area <> dispose_block_exit_psa) THEN

{call a user's handler if one is in effect

        pmp$continue_to_cause (pmc$execute_standard_procedure, fault_status);
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, status, status);
        IF (condition.selector <> pmc$system_conditions) OR
              ((condition.selector = pmc$system_conditions) AND
              NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
          osp$set_status_from_condition (pmc$program_management_id, handler_condition,
                environment.condition_save_area, status, status);
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
          osp$set_status_abnormal (pmc$program_management_id, pme$invalid_condition_handler, 'block exits',
                status);
        IFEND;
        EXIT dispose_block_exit_with_handler;
      IFEND;
    PROCEND dispose_of_handler_faults;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_of_nonlocal_exit', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that the previous
{   block exit condition environment is deleted before a nonlocal
{   exit completes.

    PROCEDURE dispose_of_nonlocal_exit
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);


      pmp$delete_environment (save_area, status);
      IF NOT status.normal THEN
        dispose_of_environment_overwrit (status);
      IFEND;
    PROCEND dispose_of_nonlocal_exit;
?? OLDTITLE, EJECT ??

    VAR
      fault_descriptor: pmt$established_handler,
      nonlocal_exit: pmt$established_handler,
      trap_enables: 0 .. 3,
      ignore_status: ost$status,
      delete: ost$status;

    dispose_block_exit_psa := #PREVIOUS_SAVE_AREA ();
    environment := current_environment^;
    handler_condition.selector := pmc$block_exit_processing;
    handler_condition.reason := environment.condition.reason;
    pmp$establish_condition_handler (condition_handler_faults, ^dispose_of_handler_faults, ^fault_descriptor,
          ignore_status);
    i#disable_traps (trap_enables);
    pmp$post_current_environment (^environment);
    pmp$establish_condition_handler (block_exit, ^dispose_of_nonlocal_exit, ^nonlocal_exit, ignore_status);
    i#enable_traps (trap_enables);

{call the user's condition handler

    set_debug_in_user_mask;
    environment.established_descriptor^.handler^ (handler_condition, environment.condition_descriptor,
          environment.condition_save_area, status);
    clear_debug_in_user_mask;
    pmp$delete_current_environment (delete);
    #WRITE_REGISTER (osc$pr_clear_critical_frame, 0);
    IF NOT delete.normal THEN
      dispose_of_environment_overwrit (delete);
    IFEND;
  PROCEND dispose_block_exit_with_handler;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_of_block_exit_cond', EJECT ??

{ PURPOSE:
{

  PROCEDURE dispose_of_block_exit_cond
    (    condition_save_area: ^ost$stack_frame_save_area);


    VAR
      status: ost$status,
      task_state: pmt$task_state,
      debug_critical_frame: boolean,
      call_debug: boolean,
      users_handler_found: boolean,
      current_environment: pmt$condition_environment;

    status.normal := TRUE;
    current_environment.condition.class := pmc$block_exit_processing;
    current_environment.condition_save_area := condition_save_area;
    current_environment.condition_descriptor := NIL;
    current_environment.debug_index := 0;
    task_state := pmp$task_state ();
    CASE task_state OF
    = pmc$task_active =
      current_environment.condition.reason := $pmt$block_exit_reason [pmc$block_exit];
    = pmc$program_exiting, pmc$debug_ending, pmc$task_terminating =
      current_environment.condition.reason := $pmt$block_exit_reason [pmc$program_termination];
    = pmc$program_aborting =
      current_environment.condition.reason := $pmt$block_exit_reason [pmc$program_abort];
    CASEND;
    determine_call_debug (call_debug);
    IF call_debug THEN
      pmp$debug_critical_frame (condition_save_area, debug_critical_frame);
    IFEND;
    IF NOT (call_debug AND debug_critical_frame) THEN
      find_users_handler (^current_environment, users_handler_found, status);
      IF status.normal AND users_handler_found THEN
        dispose_block_exit_with_handler (^current_environment, status);
      ELSEIF NOT status.normal THEN
        pmp$abort (status);
      IFEND;
    ELSE
      dispose_condition_with_debugger (^current_environment, condition_save_area, FALSE);
      find_users_handler (^current_environment, users_handler_found, status);
      IF status.normal AND users_handler_found THEN
        dispose_block_exit_with_handler (^current_environment, status);
      ELSEIF NOT status.normal THEN
        pmp$abort (status);
      IFEND;
    IFEND;
    IF NOT status.normal THEN
      pmp$exit (status);
    IFEND;
  PROCEND dispose_of_block_exit_cond;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_system_with_handler', EJECT ??

{ PURPOSE:
{

  PROCEDURE dispose_system_with_handler
    (    current_environment {input,output} : ^pmt$condition_environment;
     VAR status: ost$status);


    VAR
      environment: pmt$condition_environment,
      handler_condition: pmt$condition,
      dispose_system_psa: ^ost$stack_frame_save_area;


?? NEWTITLE := 'dispose_of_handler_faults', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that faults
{   occuring during the call to a user's condition handler
{   are reported.

    PROCEDURE dispose_of_handler_faults
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR fault_status: ost$status);


      VAR
        ignore_status: ost$status;

{determine if call to the handler faulted or the handler itself faulted

      IF (save_area^.minimum_save_area.a2_previous_save_area <> dispose_system_psa) THEN

{call a user's handler if one is in effect

        pmp$continue_to_cause (pmc$execute_standard_procedure, fault_status);
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, status, status);
        IF (condition.selector <> pmc$system_conditions) OR
              ((condition.selector = pmc$system_conditions) AND
              NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
          osp$set_status_from_condition (pmc$program_management_id, handler_condition,
                environment.condition_save_area, status, status);
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
          osp$set_status_abnormal (pmc$program_management_id, pme$invalid_condition_handler,
                'system conditions', status);
        IFEND;
        EXIT dispose_system_with_handler;
      IFEND;
    PROCEND dispose_of_handler_faults;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_of_nonlocal_exit', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that the system
{   condition environment associated with the save_area is
{   deleted and the user's condition handler is set inactive for
{   the condition before a user's nonlocal exit completes.
{ NOTE:
{   The environment may not have been overwritten to the extent that
{   pmp$delete_environment detected an error, but portions (i.e.,
{   established_descriptor^) may have been overwritten causing a
{   fault when setting the handler inactive.  An occuring fault will
{   be routed to dispose_of_descriptor_overwrit which will abort
{   task or call system error.

    PROCEDURE dispose_of_nonlocal_exit
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        executing_stack_segment: ost$segment,
        ignore_status: ost$status,
        internal_descriptor_p: ^pmt$established_handler_internl,
        overwrite_descriptor: pmt$established_handler;

      pmp$delete_environment (save_area, status);
      IF status.normal THEN
        pmp$establish_condition_handler (environment_overwrite, ^dispose_of_descriptor_overwrit,
              ^overwrite_descriptor, ignore_status);
        internal_descriptor_p := #LOC (environment.established_descriptor^);
        IF (#SEGMENT (environment.established_descriptor) = #SEGMENT (^executing_stack_segment)) OR
              internal_descriptor_p^.established_outside_block THEN

{clear handler active for the condition

          environment.established_descriptor^.handler_active.system :=
                (environment.established_descriptor^.handler_active.system XOR
                $pmt$system_conditions [environment.condition.system]);
        ELSE
          osp$set_status_abnormal (pmc$program_management_id, pme$stack_overwritten, '', status);
          dispose_of_environment_overwrit (status);
        IFEND;
      ELSE
        dispose_of_environment_overwrit (status);
      IFEND;
    PROCEND dispose_of_nonlocal_exit;
?? OLDTITLE, EJECT ??

    VAR
      delete: ost$status,
      executing_stack_segment: ost$segment,
      fault_descriptor: pmt$established_handler,
      ignore_status: ost$status,
      internal_descriptor_p: ^pmt$established_handler_internl,
      nonlocal_exit: pmt$established_handler,
      overwrite_descriptor: pmt$established_handler,
      trap_enables: 0 .. 3;

    dispose_system_psa := #PREVIOUS_SAVE_AREA ();
    environment := current_environment^;
    IF NOT (environment.condition.system IN environment.established_descriptor^.handler_active.system) THEN
      handler_condition.selector := pmc$system_conditions;
      handler_condition.system_conditions := $pmt$system_conditions [environment.condition.system];
      handler_condition.untranslatable_pointer := environment.condition.untranslatable_pointer;

{set handler active for the condition

      environment.established_descriptor^.handler_active.system :=
            (environment.established_descriptor^.handler_active.system XOR $pmt$system_conditions
            [environment.condition.system]);
      pmp$establish_condition_handler (condition_handler_faults, ^dispose_of_handler_faults,
            ^fault_descriptor, ignore_status);
      i#disable_traps (trap_enables);
      pmp$post_current_environment (^environment);
      pmp$establish_condition_handler (block_exit, ^dispose_of_nonlocal_exit, ^nonlocal_exit, ignore_status);
      i#enable_traps (trap_enables);

{call the user's condition handler

      set_debug_in_user_mask;
      environment.established_descriptor^.handler^ (handler_condition, environment.condition_descriptor,
            environment.condition_save_area, status);
      clear_debug_in_user_mask;
      pmp$delete_current_environment (delete);
      #WRITE_REGISTER (osc$pr_clear_critical_frame, 0);
      IF delete.normal THEN

{        NOTE:
{          The environment may not have been overwritten to the extent that
{          pmp$delete_current_environment detected an error, but portions
{          (i.e., established_descriptor^) may have been overwritten causing a
{          fault when setting the handler inactive.  An occuring fault will
{          be routed to dispose_of_descriptor_overwrit which will abort
{          task or call system error.

        pmp$establish_condition_handler (environment_overwrite, ^dispose_of_descriptor_overwrit,
              ^overwrite_descriptor, ignore_status);
        internal_descriptor_p := #LOC (environment.established_descriptor^);
        IF (#SEGMENT (environment.established_descriptor) = #SEGMENT (^executing_stack_segment)) OR
              internal_descriptor_p^.established_outside_block THEN

{clear handler active for the condition

          environment.established_descriptor^.handler_active.system :=
                (environment.established_descriptor^.handler_active.system XOR
                $pmt$system_conditions [environment.condition.system]);
        ELSE
          osp$set_status_abnormal (pmc$program_management_id, pme$stack_overwritten, '', delete);
          dispose_of_environment_overwrit (delete);
        IFEND;
      ELSE
        dispose_of_environment_overwrit (delete);
      IFEND;
    ELSE
      osp$set_status_abnormal (pmc$program_management_id, pme$condition_in_handler, 'system condition',
            status);
    IFEND;
  PROCEND dispose_system_with_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$dispose_ucr_conditions', EJECT ??
*copyc pmh$dispose_ucr_conditions

  PROCEDURE [XDCL] pmp$dispose_ucr_conditions
    (VAR outstanding_ucr {input, output} : ost$user_conditions;
         condition_save_area: ^ost$stack_frame_save_area;
         debug_index: 0 .. 31);

    CONST
      five_minutes = 300000;

    TYPE
      op_code = 0 .. 0ff(16);

    VAR
      call_debug: boolean,
      current_environment: pmt$condition_environment,
      op_code_pointer: ^op_code,
      original_display_message: oft$display_message,
      p_address: ^cell,
      status: ost$status,
      system_condition: pmt$system_condition,
      ucr_condition: ost$user_condition,
      users_handler_found: boolean,
      vector_attribute: array [1 .. 1] of pmt$mainframe_attribute,
      wait_message_displayed: boolean;

    VAR
      maskable_system_conditions: [STATIC, READ, oss$job_paged_literal] pmt$system_conditions :=
            $pmt$system_conditions [pmc$divide_fault, pmc$arithmetic_overflow, pmc$exponent_overflow,
            pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite, pmc$arithmetic_significance,
            pmc$invalid_bdp_data];

    status.normal := TRUE;
    current_environment.condition.class := pmc$system_conditions;
    current_environment.condition_save_area := condition_save_area;
    current_environment.debug_index := debug_index;
    current_environment.condition_descriptor := NIL;

{If debug is set, clear all other UCR exceptions except debug and critical frame. If anyother exceptions
{were present, the eliminated exception(s) will arise at the attempt to re-execute the instruction.

    IF (osc$debug IN outstanding_ucr) THEN
      outstanding_ucr := (outstanding_ucr * $ost$user_conditions [osc$critical_frame_flag, osc$debug]);

{The following prioritizes invalid bdp data and the other arithmetic UCR exceptions, eliminating
{potentially invalid exceptions. If any valid exceptions were present, the eliminated exception(s) will
{arise at the attempt to re-execute the instruction.

    ELSEIF (osc$invalid_bdp_data IN outstanding_ucr) THEN
      outstanding_ucr := (outstanding_ucr * $ost$user_conditions
            [osc$critical_frame_flag, osc$invalid_bdp_data]);
    IFEND;
    ucr_condition := osc$privileged_instruction;
    system_condition := pmc$privileged_instruction;
    REPEAT
      IF (ucr_condition IN outstanding_ucr) THEN
        outstanding_ucr := (outstanding_ucr XOR $ost$user_conditions [ucr_condition]);
        current_environment.condition.system := system_condition;
        IF (system_condition = pmc$unimplemented_instruction) THEN

          p_address := #ADDRESS (condition_save_area^.minimum_save_area.p_register.pva.ring,
                condition_save_area^.minimum_save_area.p_register.pva.seg,
                condition_save_area^.minimum_save_area.p_register.pva.offset);
          op_code_pointer := p_address;
          IF (op_code_pointer^ >= 40(16)) AND (op_code_pointer^ <= 5E(16)) THEN
            vector_attribute [1].key := pmc$mak_vector_simulation;
            pmp$get_mainframe_attributes (vector_attribute, {ignore} status);
            WHILE vector_attribute [1].vector_simulation = pmc$vectors_suspended DO
              osp$get_current_display_message (original_display_message);
              ofp$display_status_message (' Waiting for vector processing.', status);
              wait_message_displayed := TRUE;
              pmp$long_term_wait (five_minutes, five_minutes);
              osp$clear_wait_message (original_display_message, wait_message_displayed);
              pmp$get_mainframe_attributes (vector_attribute, {ignore} status);
            WHILEND;
            IF vector_attribute [1].vector_simulation = pmc$vectors_simulated THEN
              RETURN;
            IFEND;
          IFEND;
        IFEND;
        IF (system_condition = pmc$cff_unselectable) THEN
          dispose_of_block_exit_cond (condition_save_area);
        ELSEIF (system_condition = pmc$pit_unselectable) THEN
          dispose_pit_condition (condition_save_area, FALSE);
        ELSE
          determine_call_debug (call_debug);
          IF NOT call_debug THEN
            IF (system_condition <> pmc$debug_unselectable) THEN
              find_users_handler (^current_environment, users_handler_found, status);
              IF status.normal AND users_handler_found THEN
                dispose_system_with_handler (^current_environment, status);
              ELSE

{The program being executed may have inhibited any of the maskable system conditions, caused
{one of the inhibited conditions, and returned to the original caller. Because in general all
{maskable system conditions are enabled in the original caller, the condition will arise when
{the original caller is returned to. Therefore, if the condition is a maskable system
{condition and the stack frame belongs to the original caller (i.e., the frame's previous save
{area pointer = NIL), the condition is ignored.

                IF NOT ((current_environment.condition.system IN maskable_system_conditions) AND
                      (current_environment.condition_save_area^.minimum_save_area.a2_previous_save_area =
                      NIL)) THEN
                  default_system_cond_handler (^current_environment, { inconsistand_stack } FALSE);
                IFEND;
              IFEND;
            ELSEIF pmp$task_debug_mode_on () THEN
              post_ring_crossing_condition (condition_save_area, ^current_environment, pmp$task_debug_ring (),
                    status, status);
              IF NOT status.normal THEN

{posting the debug condition found an inconsistent stack segment - the debug condition will be
{ignored and continued execution of the task will detect the inconsistent stack again, at
{which time the task will be aborted.

                status.normal := TRUE;
              IFEND;
            IFEND;
          ELSE
            dispose_condition_with_debugger (^current_environment, condition_save_area, FALSE);
          IFEND;
        IFEND;
      IFEND;
      IF (ucr_condition < osc$invalid_bdp_data) THEN
        ucr_condition := SUCC (ucr_condition);
        system_condition := SUCC (system_condition);
      IFEND;
    UNTIL (outstanding_ucr = $ost$user_conditions []) OR NOT status.normal;
    IF NOT status.normal THEN
      pmp$exit (status);
    IFEND;
  PROCEND pmp$dispose_ucr_conditions;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$dispose_mcr_conditions', EJECT ??
*copyc pmh$dispose_mcr_conditions

*copyc ost$monitor_fault

  PROCEDURE [XDCL] pmp$dispose_mcr_conditions
    (    fault: ost$monitor_fault;
         sfsa: ^ost$stack_frame_save_area);

?? NEWTITLE := 'dispose_of_mcr_conditions', EJECT ??

{ PURPOSE:
{

    PROCEDURE dispose_of_mcr_conditions
      (    sfsa: ^ost$stack_frame_save_area;
           untranslatable_pointer: ost$pva;
           mcr_conditions: pmt$system_conditions;
       VAR status: ost$status);

      VAR
        call_debug: boolean,
        users_handler_found: boolean,
        current_environment: pmt$condition_environment,
        mcr_condition: pmt$system_condition;

      status.normal := TRUE;
      current_environment.condition.class := pmc$system_conditions;
      current_environment.condition.untranslatable_pointer := untranslatable_pointer;
      current_environment.condition_save_area := sfsa;
      current_environment.condition_descriptor := NIL;
      current_environment.debug_index := 0;

{The following conditional statement prioritizes multiple MCR interrupts.

      IF (pmc$detected_uncorrected_err IN mcr_conditions) THEN
        mcr_condition := pmc$detected_uncorrected_err;

{The following conditional statement prioritizes multiple MCR group 3 interrupts eliminating
{potentially invalid exceptions. If the exception is corrected and anyother exception which may have
{present was valid, the exception will arise at the attempt to re-execute the instruction.

      ELSEIF (pmc$instruction_specification IN mcr_conditions) THEN
        mcr_condition := pmc$instruction_specification;

{The following conditional statments (invalid_segment .. address_spec) prioritizes the exceptions
{which require the UTP to be updated, eliminating all other exceptions. If the exception is corrected
{and anyother exception which may have present was valid, the exception will arise at the attempt to
{re-execute the instruction.

      ELSEIF (pmc$invalid_segment_ring_0 IN mcr_conditions) THEN
        mcr_condition := pmc$invalid_segment_ring_0;
      ELSEIF (pmc$access_violation IN mcr_conditions) THEN
        mcr_condition := pmc$access_violation;
      ELSEIF (pmc$address_specification IN mcr_conditions) THEN
        mcr_condition := pmc$address_specification;
      ELSE
        mcr_condition := pmc$ua_unselectable;
        WHILE NOT (mcr_condition IN mcr_conditions) DO
          IF (mcr_condition < pmc$out_call_in_return) THEN
            mcr_condition := SUCC (mcr_condition);
          IFEND;
        WHILEND;
      IFEND;

{ If the fault occurred within the vector simulation code then make it look
{ like it occurred on the vector instruction itself.

      current_environment.condition.system := mcr_condition;
      IF (sfsa^.minimum_save_area.p_register.pva.seg = #SEGMENT (^pma$vector_simulator)) AND
            (sfsa^.minimum_save_area.p_register.pva.offset >= #OFFSET (^pma$vector_simulator)) AND
            (sfsa^.minimum_save_area.p_register.pva.offset <= #OFFSET (^pma$vector_simulator_end)) THEN
        current_environment.condition_save_area := sfsa^.minimum_save_area.a2_previous_save_area;
      IFEND;

      determine_call_debug (call_debug);
      IF NOT call_debug THEN
        find_users_handler (^current_environment, users_handler_found, status);
        IF status.normal AND users_handler_found THEN
          dispose_system_with_handler (^current_environment, status);
        ELSE
          default_system_cond_handler (^current_environment, { inconsistent_stack } status.condition =
                pme$inconsistent_stack);
        IFEND;
      ELSE
        dispose_condition_with_debugger (^current_environment, sfsa, FALSE);
      IFEND;
    PROCEND dispose_of_mcr_conditions;
?? OLDTITLE, EJECT ??

*copyc tmt$mcr_faults

    VAR
      mcr_faults: ^tmt$mcr_faults,
      monitor_condition: ost$monitor_condition,
      monitor_conditions: ost$monitor_conditions,
      system_condition: pmt$system_condition,
      selectable_mcr_conditions: ost$monitor_conditions,
      untranslatable_pointer: ost$pva,
      mcr_conditions: pmt$system_conditions,
      status: ost$status;

    status.normal := TRUE;
    mcr_faults := #LOC (fault.contents);
    selectable_mcr_conditions := $ost$monitor_conditions [osc$detected_uncorrected_err, osc$instruction_spec,
          osc$address_specification, osc$access_violation, osc$invalid_segment_ring_0, osc$out_call_in_return,
          osc$environment_spec];
    monitor_conditions := (mcr_faults^.faults * selectable_mcr_conditions);
    IF (monitor_conditions <> $ost$monitor_conditions []) THEN
      untranslatable_pointer := mcr_faults^.untranslatable_pointer;
      system_condition := pmc$detected_uncorrected_err;
      mcr_conditions := $pmt$system_conditions [];
      FOR monitor_condition := osc$detected_uncorrected_err TO osc$trap_exception DO
        IF (monitor_condition IN monitor_conditions) THEN
          mcr_conditions := (mcr_conditions + $pmt$system_conditions [system_condition]);
        IFEND;
        IF (monitor_condition < osc$trap_exception) THEN
          system_condition := SUCC (system_condition);
        IFEND;
      FOREND;
      dispose_of_mcr_conditions (sfsa, untranslatable_pointer, mcr_conditions, status);
      IF NOT status.normal THEN
        pmp$exit (status);
      IFEND;
    IFEND;
  PROCEND pmp$dispose_mcr_conditions;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_seg_access_with_handler', EJECT ??

{ PURPOSE:
{

  PROCEDURE dispose_seg_access_with_handler
    (    current_environment {input, output} : ^pmt$condition_environment;
     VAR status: ost$status);


    VAR
      environment: pmt$condition_environment,
      handler_condition: pmt$condition,
      dispose_segment_psa: ^ost$stack_frame_save_area;

?? OLDTITLE ??
?? NEWTITLE := 'dispose_of_handler_faults', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that faults
{   occuring during the call to a user's condition handler are
{   reported.

    PROCEDURE dispose_of_handler_faults
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR fault_status: ost$status);


      VAR
        ignore_status: ost$status;

{determine if call to the handler faulted or the handler itself faulted

      IF (save_area^.minimum_save_area.a2_previous_save_area <> dispose_segment_psa) THEN

{call a user's handler if one is in effect

        pmp$continue_to_cause (pmc$execute_standard_procedure, fault_status);
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, status, status);
        IF (condition.selector <> pmc$system_conditions) OR
              ((condition.selector = pmc$system_conditions) AND
              NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
          osp$set_status_from_condition (pmc$program_management_id, handler_condition,
                environment.condition_save_area, status, status);
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
          osp$set_status_abnormal (pmc$program_management_id, pme$invalid_condition_handler,
                'segment access conditions', status);
        IFEND;
        EXIT dispose_seg_access_with_handler;
      IFEND;
    PROCEND dispose_of_handler_faults;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_of_nonlocal_exit', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that the system
{   condition environment associated with the save_area is
{   deleted and the user's condition handler is set inactive for
{   the condition before a user's nonlocal exit completes.
{ NOTE:
{   The environment may not have been overwritten to the extent that
{   pmp$delete_environment detected an error, but portions (i.e.,
{   established_descriptor^) may have been overwritten causing a
{   fault when setting the handler inactive.  An occuring fault will
{   be routed to dispose_of_descriptor_overwrit which will abort
{   task or call system error.
{

    PROCEDURE dispose_of_nonlocal_exit
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);


      VAR
        executing_stack_segment: ost$segment,
        ignore_status: ost$status,
        internal_descriptor_p: ^pmt$established_handler_internl,
        overwrite_descriptor: pmt$established_handler;

      pmp$delete_environment (save_area, status);
      IF status.normal THEN
        pmp$establish_condition_handler (environment_overwrite, ^dispose_of_descriptor_overwrit,
              ^overwrite_descriptor, ignore_status);
        internal_descriptor_p := #LOC (environment.established_descriptor^);
        IF (#SEGMENT (environment.established_descriptor) = #SEGMENT (^executing_stack_segment)) OR
              internal_descriptor_p^.established_outside_block THEN

{clear handler active for the condition

          environment.established_descriptor^.handler_active.segment_access.identifier := 0;
          environment.established_descriptor^.handler_active.segment_access.segment := NIL;
        ELSE
          osp$set_status_abnormal (pmc$program_management_id, pme$stack_overwritten, '', status);
          dispose_of_environment_overwrit (status);
        IFEND;
      ELSE
        dispose_of_environment_overwrit (status);
      IFEND;
    PROCEND dispose_of_nonlocal_exit;
?? OLDTITLE, EJECT ??

    VAR
      active_segment: ost$segment,
      condition_segment: ost$segment,
      delete: ost$status,
      executing_stack_segment: ost$segment,
      fault_descriptor: pmt$established_handler,
      ignore_status: ost$status,
      internal_descriptor_p: ^pmt$established_handler_internl,
      nonlocal_exit: pmt$established_handler,
      overwrite_descriptor: pmt$established_handler,
      trap_enables: 0 .. 3;

    dispose_segment_psa := #PREVIOUS_SAVE_AREA ();
    environment := current_environment^;
    active_segment := #SEGMENT (environment.established_descriptor^.handler_active.segment_access.segment);
    condition_segment := #SEGMENT (environment.condition.segment_access.segment);
    IF (environment.condition.segment_access.identifier <>
          environment.established_descriptor^.handler_active.segment_access.identifier) AND
          ((environment.established_descriptor^.handler_active.segment_access.segment = NIL) OR
          (condition_segment <> active_segment)) THEN
      handler_condition.selector := mmc$segment_access_condition;
      handler_condition.segment_access_condition := environment.condition.segment_access;

{set handler active for condition

      environment.established_descriptor^.handler_active.segment_access :=
            environment.condition.segment_access;
      pmp$establish_condition_handler (condition_handler_faults, ^dispose_of_handler_faults,
            ^fault_descriptor, ignore_status);
      i#disable_traps (trap_enables);
      pmp$establish_condition_handler (block_exit, ^dispose_of_nonlocal_exit, ^nonlocal_exit, ignore_status);
      pmp$post_current_environment (^environment);
      i#enable_traps (trap_enables);

{call the user' condition handler

      set_debug_in_user_mask;
      environment.established_descriptor^.handler^ (handler_condition, environment.condition_descriptor,
            environment.condition_save_area, status);
      clear_debug_in_user_mask;
      pmp$delete_current_environment (delete);
      #WRITE_REGISTER (osc$pr_clear_critical_frame, 0);
      IF delete.normal THEN

{        NOTE:
{          The environment may not have been overwritten to the extent that
{          pmp$delete_current_environment detected an error, but portions
{          (i.e., established_descriptor^) may have been overwritten causing a
{          fault when setting the handler inactive.  An occuring fault will
{          be routed to dispose_of_descriptor_overwrit which will abort
{          task or call system error.

        pmp$establish_condition_handler (environment_overwrite, ^dispose_of_descriptor_overwrit,
              ^overwrite_descriptor, ignore_status);
        internal_descriptor_p := #LOC (environment.established_descriptor^);
        IF (#SEGMENT (environment.established_descriptor) = #SEGMENT (^executing_stack_segment)) OR
              internal_descriptor_p^.established_outside_block THEN

{clear handler active for the condition

          environment.established_descriptor^.handler_active.segment_access.identifier := 0;
          environment.established_descriptor^.handler_active.segment_access.segment := NIL;
        ELSE
          osp$set_status_abnormal (pmc$program_management_id, pme$stack_overwritten, '', delete);
          dispose_of_environment_overwrit (delete);
        IFEND;
      ELSE
        dispose_of_environment_overwrit (delete);
      IFEND;
    ELSE
      osp$set_status_abnormal (pmc$program_management_id, pme$condition_in_handler,
            'segment access condition', status);
    IFEND;

  PROCEND dispose_seg_access_with_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$dispose_segment_access_cond', EJECT ??
*copyc pmh$dispose_segment_access_cond

  PROCEDURE [XDCL] pmp$dispose_segment_access_cond
    (    condition: mmt$segment_access_condition;
         sfsa: ^ost$stack_frame_save_area);


?? NEWTITLE := '  log_io_read_error', EJECT ??

    PROCEDURE log_io_read_error
      (    condition: mmt$segment_access_condition);

{   Purpose:
{ The purpose of this procedure is to emit a message to the job log
{ for an open permanent file, temporary file or transient segment.
{   Design:
{ Open catalogs are processed by PF condition handlers.  BACPF and
{ MOVE_CLASSES do not call FSP$OPEN_FILE for the PF that is being backed up
{ or moved; therefore, no Task File Table entry exists.  Therefore, at the
{ time the I/O read error is detected, a log message with ' Path Not Found '
{ is logged.  Subsequently, BACPF's or MOVE_CLASSES' condition handler logs
{ another message that provides the path.  The PVA is provided in all log
{ messages to correlate these redundant messages for the same error.

      CONST
        unknown_pf = '** Permanent FIle Path Not Found **',
        unknown_temp = '** Temporary FIle Path Not Found **';

      VAR
        entry_found: boolean,
        file_info: dmt$file_information,
        ignore_file_instance: ^bat$task_file_entry,
        ignore_path_handle: fmt$path_handle,
        index: integer,
        path: fst$path,
        path_size: fst$path_size,
        sfid: gft$system_file_identifier,
        status: ost$status;

      IF condition.identifier = mmc$sac_io_read_error THEN
        pfp$get_file_info (condition.segment, file_info, status);
        IF status.normal THEN
          CASE file_info.file_kind OF
          = gfc$fk_job_permanent_file, gfc$fk_job_local_file =
            bap$find_open_file_via_segment (#SEGMENT (condition.segment), ignore_file_instance, path,
                  path_size, entry_found);
            IF entry_found THEN
              osp$log_io_read_error (path (1, path_size), file_info.file_kind, condition.segment);
            ELSEIF file_info.file_kind = gfc$fk_job_permanent_file THEN
              osp$log_io_read_error (unknown_pf, file_info.file_kind, condition.segment);
            ELSE
              osp$log_io_read_error (unknown_temp, file_info.file_kind, condition.segment);
            IFEND;
          = gfc$fk_catalog =
            RETURN; {PF condition handler will log condition}
          = gfc$fk_device_file, gfc$fk_unnamed_file, gfc$fk_global_unnamed =
            osp$log_io_read_error ('', file_info.file_kind, condition.segment);
          ELSE
          CASEND;
        ELSE
          { Put out "transient segment" message even though the file is not attached}
          osp$log_io_read_error ('', gfc$fk_unnamed_file, condition.segment);
        IFEND;
      IFEND;

    PROCEND log_io_read_error;
?? OLDTITLE ??
    VAR
      call_debug: boolean,
      current_environment: pmt$condition_environment,
      status: ost$status,
      users_handler_found: boolean;

    status.normal := TRUE;
    current_environment.condition_save_area := sfsa;
    current_environment.condition.class := mmc$segment_access_condition;
    current_environment.condition.segment_access := condition;
    current_environment.condition_descriptor := NIL;
    current_environment.debug_index := 0;

    IF (sfsa^.minimum_save_area.p_register.pva.seg = #SEGMENT (^pma$vector_simulator)) AND
          (sfsa^.minimum_save_area.p_register.pva.offset >= #OFFSET (^pma$vector_simulator)) AND
          (sfsa^.minimum_save_area.p_register.pva.offset <= #OFFSET (^pma$vector_simulator_end)) THEN
      current_environment.condition_save_area := sfsa^.minimum_save_area.a2_previous_save_area;
    IFEND;

    log_io_read_error (condition);
    determine_call_debug (call_debug);
    IF NOT call_debug THEN
      find_users_handler (^current_environment, users_handler_found, status);
      IF status.normal AND users_handler_found THEN
        dispose_seg_access_with_handler (^current_environment, status);
      ELSE
        default_seg_access_cond_handler (^current_environment);
      IFEND;
    ELSE
      dispose_condition_with_debugger (^current_environment, sfsa, FALSE);
    IFEND;

    IF NOT status.normal THEN
      pmp$exit (status);
    IFEND;
  PROCEND pmp$dispose_segment_access_cond;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_job_resrce_with_handler', EJECT ??

{ PURPOSE:
{

  PROCEDURE dispose_job_resrce_with_handler
    (    current_environment {input, output} : ^pmt$condition_environment;
     VAR status: ost$status);


    VAR
      environment: pmt$condition_environment,
      handler_condition: pmt$condition,
      dispose_job_psa: ^ost$stack_frame_save_area;

?? NEWTITLE := 'dispose_of_handler_faults', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that faults
{   occuring during the call to a user's condition handler
{   are reported.

    PROCEDURE dispose_of_handler_faults
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR fault_status: ost$status);


      VAR
        ignore_status: ost$status;

{determine if call to the handler faulted or the handler itself faulted

      IF (save_area^.minimum_save_area.a2_previous_save_area <> dispose_job_psa) THEN

{call a user's handler if one is in effect

        pmp$continue_to_cause (pmc$execute_standard_procedure, fault_status);
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, status, status);
        IF (condition.selector <> pmc$system_conditions) OR
              ((condition.selector = pmc$system_conditions) AND
              NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
          osp$set_status_from_condition (pmc$program_management_id, handler_condition,
                environment.condition_save_area, status, status);
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
          osp$set_status_abnormal (pmc$program_management_id, pme$invalid_condition_handler,
                'job resource conditions', status);
        IFEND;
        EXIT dispose_job_resrce_with_handler;
      IFEND;
    PROCEND dispose_of_handler_faults;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_of_nonlocal_exit', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that the previous
{   job resource condition environment is deleted before a user's
{   nonlocal exit completes.

    PROCEDURE dispose_of_nonlocal_exit
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);


      pmp$delete_environment (save_area, status);
      IF NOT status.normal THEN
        dispose_of_environment_overwrit (status);
      IFEND;
    PROCEND dispose_of_nonlocal_exit;
?? OLDTITLE, EJECT ??

    VAR
      fault_descriptor: pmt$established_handler,
      nonlocal_exit: pmt$established_handler,
      trap_enables: 0 .. 3,
      ignore_status: ost$status,
      delete: ost$status;

    dispose_job_psa := #PREVIOUS_SAVE_AREA ();
    environment := current_environment^;
    handler_condition.selector := jmc$job_resource_condition;
    handler_condition.job_resource_condition := environment.condition.job_resource;
    pmp$establish_condition_handler (condition_handler_faults, ^dispose_of_handler_faults, ^fault_descriptor,
          ignore_status);
    i#disable_traps (trap_enables);
    pmp$post_current_environment (^environment);
    pmp$establish_condition_handler (block_exit, ^dispose_of_nonlocal_exit, ^nonlocal_exit, ignore_status);
    i#enable_traps (trap_enables);

{call the user's condition handler

    set_debug_in_user_mask;
    environment.established_descriptor^.handler^ (handler_condition, environment.condition_descriptor, NIL,
          status);
    clear_debug_in_user_mask;
    pmp$delete_current_environment (delete);
    #WRITE_REGISTER (osc$pr_clear_critical_frame, 0);
    IF NOT delete.normal THEN
      dispose_of_environment_overwrit (delete);
    IFEND;
  PROCEND dispose_job_resrce_with_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$dispose_job_resource_cond', EJECT ??
*copyc pmh$dispose_job_resource_cond

  PROCEDURE [XDCL] pmp$dispose_job_resource_cond
    (    job_resource_condition: jmt$job_resource_condition);


    VAR
      previous_save_area: ^ost$stack_frame_save_area;


    previous_save_area := #PREVIOUS_SAVE_AREA ();

    dispose_job_resource_condition (job_resource_condition, previous_save_area);
  PROCEND pmp$dispose_job_resource_cond;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_job_resource_condition', EJECT ??

{ PURPOSE:
{

  PROCEDURE dispose_job_resource_condition
    (    job_resource_condition: jmt$job_resource_condition;
         sfsa: ^ost$stack_frame_save_area);

    VAR
      call_debug: boolean,
      current_environment: pmt$condition_environment,
      executing_ring: ost$ring,
      post_status: ost$status,
      status: ost$status,
      users_handler_found: boolean;

    status.normal := TRUE;
    current_environment.condition_save_area := sfsa;
    current_environment.condition.class := jmc$job_resource_condition;
    current_environment.condition.job_resource := job_resource_condition;
    current_environment.condition_descriptor := NIL;
    current_environment.debug_index := 0;

    determine_call_debug (call_debug);
    IF NOT call_debug THEN
      find_users_handler (^current_environment, users_handler_found, status);
      IF status.normal THEN
        IF users_handler_found THEN
          dispose_job_resrce_with_handler (^current_environment, status);
        ELSE
          post_ring_crossing_condition (sfsa, ^current_environment, (#RING (^executing_ring) + 1),
                post_status, status);
          IF NOT post_status.normal THEN

{ posting the job resource condition found an inconsistent stack segment - the resource condition
{ will be ignored and continued execution of the task will detect the inconsistent stack again, at
{ which time the task will be aborted.

            status.normal := TRUE;
          IFEND;
        IFEND;
      ELSE

{ finding user's handler found an inconsistent stack segment or handler stack - the resource condition
{ will be ignored and continued execution of the task will detect the inconsistent stack again, at
{ which time the task will be aborted.

        status.normal := TRUE;
      IFEND;
    ELSE { call_debug = TRUE
      dispose_condition_with_debugger (^current_environment, sfsa, {multiple_conditions} FALSE);
    IFEND;
    IF NOT status.normal THEN
      pmp$exit (status);
    IFEND;
  PROCEND dispose_job_resource_condition;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_interactiv_with_handler', EJECT ??

{ PURPOSE:
{

  CONST
    continue_interactive_output = FALSE,
    terminate_interactive_output = TRUE;

  PROCEDURE dispose_interactiv_with_handler
    (    current_environment {input, output} : ^pmt$condition_environment;
     VAR status: ost$status);


    VAR
      environment: pmt$condition_environment,
      handler_condition: pmt$condition,
      dispose_interactive_psa: ^ost$stack_frame_save_area;

?? NEWTITLE := 'dispose_of_handler_faults', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that faults
{   occuring during the call to a user's condition handler
{   are reported.

    PROCEDURE dispose_of_handler_faults
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR fault_status: ost$status);

      VAR
        ignore_status: ost$status;

{determine if call to the handler faulted or the handler itself faulted

      IF (save_area^.minimum_save_area.a2_previous_save_area <> dispose_interactive_psa) THEN

{call a user's handler if one is in effect

        pmp$continue_to_cause (pmc$execute_standard_procedure, fault_status);
      ELSE
        osp$set_status_from_condition (pmc$program_management_id, condition, save_area, status, status);
        IF (condition.selector <> pmc$system_conditions) OR
              ((condition.selector = pmc$system_conditions) AND
              NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
          osp$set_status_from_condition (pmc$program_management_id, handler_condition,
                environment.condition_save_area, status, status);
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
          osp$set_status_abnormal (pmc$program_management_id, pme$invalid_condition_handler,
                'interactive conditions', status);
        IFEND;
        EXIT dispose_interactiv_with_handler;
      IFEND;
    PROCEND dispose_of_handler_faults;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_of_nonlocal_exit', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that the previous
{   interactive condition environment is deleted before a user's
{   nonlocal exit completes.

    PROCEDURE dispose_of_nonlocal_exit
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);



      pmp$delete_environment (save_area, status);
      IF NOT status.normal THEN
        dispose_of_environment_overwrit (status);
      IFEND;
    PROCEND dispose_of_nonlocal_exit;
?? OLDTITLE, EJECT ??

    VAR
      fault_descriptor: pmt$established_handler,
      nonlocal_exit: pmt$established_handler,
      trap_enables: 0 .. 3,
      ignore_status: ost$status,
      delete: ost$status;

    dispose_interactive_psa := #PREVIOUS_SAVE_AREA ();
    environment := current_environment^;
    handler_condition.selector := ifc$interactive_condition;
    handler_condition.interactive_condition := environment.condition.interactive;
    pmp$establish_condition_handler (condition_handler_faults, ^dispose_of_handler_faults, ^fault_descriptor,
          ignore_status);
    i#disable_traps (trap_enables);
    pmp$post_current_environment (^environment);
    pmp$establish_condition_handler (block_exit, ^dispose_of_nonlocal_exit, ^nonlocal_exit, ignore_status);
    i#enable_traps (trap_enables);

{call the user's condition handler

    set_debug_in_user_mask;
    environment.established_descriptor^.handler^ (handler_condition, environment.condition_descriptor, NIL,
          status);
    clear_debug_in_user_mask;
    pmp$delete_current_environment (delete);
    #WRITE_REGISTER (osc$pr_clear_critical_frame, 0);
    IF NOT delete.normal THEN
      dispose_of_environment_overwrit (delete);
    IFEND;
  PROCEND dispose_interactiv_with_handler;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_interactive_condition', EJECT ??

{ PURPOSE:
{

  PROCEDURE dispose_interactive_condition
    (    interactive_condition: ift$interactive_condition;
         sfsa: ^ost$stack_frame_save_area;
         multiple_conditions: boolean);

?? NEWTITLE := 'dispose_of_nonlocal_exit', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that the end handler
{   request is issued before a user's nonlocal exit completes.

    PROCEDURE dispose_of_nonlocal_exit
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      jmp$end_timesharing_handler (interactive_condition);
    PROCEND dispose_of_nonlocal_exit;
?? OLDTITLE, EJECT ??

    VAR
      call_debug: boolean,
      executing_ring: ost$ring,
      status: ost$status,
      post_status: ost$status,
      ignore_status: ost$status,
      nonlocal_exit: pmt$established_handler,
      users_handler_found: boolean,
      current_environment: pmt$condition_environment;

    status.normal := TRUE;
    current_environment.condition_save_area := sfsa;
    current_environment.condition.class := ifc$interactive_condition;
    current_environment.condition.interactive := interactive_condition;
    current_environment.condition_descriptor := NIL;
    current_environment.debug_index := 0;
    pmp$establish_condition_handler (block_exit, ^dispose_of_nonlocal_exit, ^nonlocal_exit, ignore_status);

    jmp$begin_timesharing_handler (interactive_condition);
    determine_call_debug (call_debug);
    IF NOT call_debug THEN
      find_users_handler (^current_environment, users_handler_found, status);
      IF status.normal THEN
        IF users_handler_found THEN
          dispose_interactiv_with_handler (^current_environment, status);
        ELSE
          post_ring_crossing_condition (sfsa, ^current_environment, (#RING (^executing_ring) + 1) MOD 16,
                post_status, status);
          IF NOT post_status.normal THEN

{posting the interactive condition found an inconsistent stack segment - the interactive condition
{will be ignored and continued execution of the task will detect the inconsistent stack again, at
{which time the task will be aborted.

            status.normal := TRUE;
          IFEND;
        IFEND;
      ELSE

{finding user's handler found an inconsistent stack segment or handler stack - the interactive
{condition will be ignored and continued execution of the task will detect the inconsistent stack
{again, at which time the task will be aborted.

        status.normal := TRUE;
      IFEND;
    ELSE
      dispose_condition_with_debugger (^current_environment, sfsa, multiple_conditions);
    IFEND;
    jmp$end_timesharing_handler (interactive_condition);
    #WRITE_REGISTER (osc$pr_clear_critical_frame, 0);
    IF NOT status.normal THEN
      pmp$exit (status);
    IFEND;
  PROCEND dispose_interactive_condition;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$dispose_interactive_cond', EJECT ??
*copyc pmh$dispose_interactive_cond

  PROCEDURE [XDCL] pmp$dispose_interactive_cond
    (    interactive_condition: ift$interactive_condition);


    VAR
      previous_save_area: ^ost$stack_frame_save_area;


    previous_save_area := #PREVIOUS_SAVE_AREA ();

    dispose_interactive_condition (interactive_condition, previous_save_area, FALSE);
  PROCEND pmp$dispose_interactive_cond;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$dispose_of_delayed_cond', EJECT ??
*copyc pmh$dispose_of_delayed_cond

  PROCEDURE [XDCL] pmp$dispose_of_delayed_cond
    (    sfsa: ^ost$stack_frame_save_area);

    VAR
      delayed: pmt$delayed_condition;

?? NEWTITLE := 'dispose_of_nonlocal_exit', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that the end handler
{   request is issued before a user's nonlocal exit completes.

    PROCEDURE dispose_of_nonlocal_exit
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      jmp$end_timesharing_handler (delayed.interactive_condition);
    PROCEND dispose_of_nonlocal_exit;
?? OLDTITLE, EJECT ??

    VAR
      call_debug: boolean,
      condition_present: boolean,
      another_condition_present: boolean,
      environment: pmt$condition_environment,
      nonlocal_exit: pmt$established_handler,
      ignore_status: ost$status;

    another_condition_present := TRUE;
    WHILE another_condition_present DO
      pmp$get_delayed_condition (delayed, condition_present, another_condition_present);
      IF condition_present THEN
        CASE delayed.delayed_condition OF
        = debug =
          determine_call_debug (call_debug);
          IF call_debug THEN
            environment.condition := delayed.condition;
            environment.condition_save_area := ^delayed.condition_save_area;
            environment.condition_descriptor := NIL;
            environment.debug_index := delayed.debug_index;
            dispose_condition_with_debugger (^environment, sfsa, another_condition_present);
          ELSE

{DEBUGGER no longer active - ignore the condition

          IFEND;

        = job_resource =
          dispose_job_resource_condition (delayed.job_resource_condition, sfsa);

        = interactive =
          pmp$establish_condition_handler (block_exit, ^dispose_of_nonlocal_exit, ^nonlocal_exit,
                ignore_status);
          dispose_interactive_condition (delayed.interactive_condition, sfsa, another_condition_present);
          jmp$end_timesharing_handler (delayed.interactive_condition);

{ The end handler request balances
{ the begin handler request in post_ring_crossing_condition.

          #WRITE_REGISTER (osc$pr_clear_critical_frame, 0);

        = process_interval_timer =
          dispose_pit_condition (sfsa, another_condition_present);

        = user_condition =
          pmp$cause_task_condition (delayed.user_defined, delayed.condition_descriptor,
                delayed.propagate_info.notify_scl, delayed.propagate_info.notify_debug,
                delayed.propagate_info.propagate_to_parent, delayed.propagate_info.call_default_handler,
                ignore_status);
        CASEND;
      IFEND;
    WHILEND;
  PROCEND pmp$dispose_of_delayed_cond;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_of_user_condition', EJECT ??

{ PURPOSE:
{

  PROCEDURE dispose_of_user_condition
    (    current_environment {input, output} : ^pmt$condition_environment;
     VAR status: ost$status);


    VAR
      environment: pmt$condition_environment,
      handler_condition: pmt$condition,
      dispose_user_psa: ^ost$stack_frame_save_area;

?? NEWTITLE := 'dispose_of_handler_faults', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that faults
{   occuring during the call to a user's condition handler
{   are reported.

    PROCEDURE dispose_of_handler_faults
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR fault_status: ost$status);


      VAR
        ignore_status: ost$status;

{ If the condition is a recursive user defined condition and it is the same
{ condition that was passed to the user's condition handler, the condition
{ recurred within the handler (or another handler on the stack).  In this case
{ eat the condition.  This will end the condition and in the case of the volume
{ or space unavailable conditions, the task will go into wait.

      IF condition.selector = pmc$user_defined_condition THEN
        IF (condition.user_condition_name = active_user_condition_name) AND
              ((condition.user_condition_name = osc$volume_unavailable_cond) OR
              (condition.user_condition_name = osc$space_unavailable_condition) OR
              (condition.user_condition_name = osc$unseen_mail_condition)) THEN
          RETURN; { eat the condition

        ELSE { Its a different condition or was not a recursive condition.
          pmp$continue_to_cause (pmc$execute_standard_procedure, fault_status);
        IFEND;
      ELSE

{determine if call to the handler faulted or the handler itself faulted

        IF (save_area^.minimum_save_area.a2_previous_save_area <> dispose_user_psa) THEN

{call a user's handler if one is in effect

          pmp$continue_to_cause (pmc$execute_standard_procedure, fault_status);
        ELSE
          osp$set_status_from_condition (pmc$program_management_id, condition, save_area, status, status);
          IF (condition.selector <> pmc$system_conditions) OR
                ((condition.selector = pmc$system_conditions) AND
                NOT (pmc$detected_uncorrected_err IN condition.system_conditions)) THEN
            osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
            osp$set_status_from_condition (pmc$program_management_id, handler_condition,
                  environment.condition_save_area, status, status);
            osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
            osp$set_status_abnormal (pmc$program_management_id, pme$invalid_condition_handler,
                  'user defined conditions', status);
          IFEND;
          EXIT dispose_of_user_condition;
        IFEND;
      IFEND;
    PROCEND dispose_of_handler_faults;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_of_nonlocal_exit', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that the previous
{   user defined condition environment is deleted
{   before a user's nonlocal exit completes.

    PROCEDURE dispose_of_nonlocal_exit
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      pmp$delete_environment (save_area, status);
      IF NOT status.normal THEN
        dispose_of_environment_overwrit (status);
      IFEND;
    PROCEND dispose_of_nonlocal_exit;
?? OLDTITLE, EJECT ??

    VAR
      user_condition_handler_faults: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
            [pmc$condition_combination, $pmt$condition_combination
            [pmc$system_conditions, mmc$segment_access_condition, pmc$user_defined_condition]],
      active_user_condition_name: pmt$condition_name,
      fault_descriptor: pmt$established_handler,
      nonlocal_exit: pmt$established_handler,
      trap_enables: 0 .. 3,
      ignore_status: ost$status,
      delete: ost$status;

    dispose_user_psa := #PREVIOUS_SAVE_AREA ();
    environment := current_environment^;
    environment.debug_index := 0;
    handler_condition.selector := pmc$user_defined_condition;
    handler_condition.user_condition_name := environment.condition.user_defined;
    active_user_condition_name := environment.condition.user_defined;
    #SPOIL (active_user_condition_name);
    pmp$establish_condition_handler (user_condition_handler_faults, ^dispose_of_handler_faults,
          ^fault_descriptor, ignore_status);
    i#disable_traps (trap_enables);
    pmp$post_current_environment (^environment);
    pmp$establish_condition_handler (block_exit, ^dispose_of_nonlocal_exit, ^nonlocal_exit, ignore_status);
    i#enable_traps (trap_enables);
    set_debug_in_user_mask;

{call the user's condition handler

    environment.established_descriptor^.handler^ (handler_condition, environment.condition_descriptor, NIL,
          status);
    clear_debug_in_user_mask;
    pmp$delete_current_environment (delete);
    #WRITE_REGISTER (osc$pr_clear_critical_frame, 0);
    IF NOT delete.normal THEN
      dispose_of_environment_overwrit (delete);
    IFEND;
  PROCEND dispose_of_user_condition;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE {retained}] pmp$cause_condition', EJECT ??
*copyc pmh$cause_condition

  PROCEDURE [XDCL, #GATE {retained} ] pmp$cause_condition
    (    condition_name: pmt$condition_name;
         condition_descriptor: ^pmt$condition_information;
     VAR status: ost$status);

    VAR
      call_debug: boolean,
      name: ost$name,
      cause_status: ost$status,
      users_handler_found: boolean,
      current_environment: pmt$condition_environment,
      valid_name: boolean;

    #INLINE ('keypoint', osk$entry, 0, pmk$cause_condition);
    clp$validate_name (condition_name, name, valid_name);
    IF valid_name THEN
      cause_status.normal := TRUE;
      current_environment.condition_save_area := #PREVIOUS_SAVE_AREA ();
      current_environment.condition.class := pmc$user_defined_condition;
      current_environment.condition.user_defined := name;
      current_environment.condition_descriptor := condition_descriptor;
      current_environment.debug_index := 0;
      current_environment.condition.propagate_info.scope := pmc$current_ring;

      determine_call_debug (call_debug);
      IF NOT call_debug THEN
        find_users_handler (^current_environment, users_handler_found, cause_status);
        IF cause_status.normal THEN
          IF users_handler_found THEN
            dispose_of_user_condition (^current_environment, cause_status);
            IF NOT cause_status.normal THEN
              #INLINE ('keypoint', osk$exit, (0), pmk$cause_condition);
              pmp$exit (cause_status);
            IFEND;
          ELSE
            osp$set_status_abnormal (pmc$program_management_id, pme$no_established_handler, '', cause_status);
          IFEND;
        IFEND;
      ELSE
        dispose_condition_with_debugger (^current_environment, current_environment.condition_save_area,
              FALSE);
      IFEND;
    ELSE
      osp$set_status_abnormal ('CL', cle$improper_name, condition_name, cause_status);
    IFEND;

    IF cause_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := cause_status;
    IFEND;

    #INLINE ('keypoint', osk$exit, ((1 - $INTEGER (status.normal)) * 0), pmk$cause_condition);


  PROCEND pmp$cause_condition;
?? OLDTITLE ??
?? NEWTITLE := 'find_handler_in_stacks', EJECT ??

{ PURPOSE:
{

  PROCEDURE find_handler_in_stacks
    (    condition: pmt$internal_condition;
         last_save_area: ^ost$stack_frame_save_area;
     VAR handler_found: boolean;
     VAR continue_status: ost$status);

?? NEWTITLE := 'dispose_of_stack_read_error', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that segment access
{   conditions which may arise when scanning stack frames are reported.

    PROCEDURE dispose_of_stack_read_error
      (    segment_access_condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR ignore_status: ost$status);

      osp$set_status_from_condition (pmc$program_management_id, segment_access_condition, save_area,
            continue_status, continue_status);
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], continue_status, ignore_status);
      osp$set_status_abnormal (pmc$program_management_id, pme$inconsistent_stack, '', continue_status);

      EXIT find_handler_in_stacks;

    PROCEND dispose_of_stack_read_error;
?? OLDTITLE, EJECT ??

    VAR
      established_descriptor: ^pmt$established_handler,
      next_save_area: ^ost$stack_frame_save_area,
      read_error_descriptor: pmt$established_handler,
      ignore_status: ost$status;

    pmp$establish_condition_handler (stack_read_error, ^dispose_of_stack_read_error, ^read_error_descriptor,
          ignore_status);
    next_save_area := last_save_area^.minimum_save_area.a2_previous_save_area;
    handler_found := FALSE;
    continue_status.normal := TRUE;
    WHILE NOT handler_found AND (next_save_area <> NIL) AND (#RING (next_save_area) <= osc$user_ring_2) AND
          continue_status.normal DO
      pmp$is_there_a_handler_in_stack (condition, next_save_area, established_descriptor, next_save_area,
            continue_status);
      IF continue_status.normal THEN
        IF (established_descriptor <> NIL) THEN
          handler_found := TRUE;
        ELSE
          next_save_area := next_save_area^.minimum_save_area.a2_previous_save_area;
        IFEND;
      IFEND;
    WHILEND;
  PROCEND find_handler_in_stacks;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE {retained}] pmp$continue_to_cause', EJECT ??
*copyc pmh$continue_to_cause

  PROCEDURE [XDCL, {user} #GATE] pmp$continue_to_cause
    (    standard: pmt$standard_selection;
     VAR status: ost$status);

?? NEWTITLE := 'find_next_users_handler', EJECT ??

{ PURPOSE:
{

    PROCEDURE find_next_users_handler
      (    environment {input, output} : ^pmt$condition_environment;
       VAR handler_found: boolean;
       VAR status: ost$status);

?? NEWTITLE := 'dispose_of_environment_overwrit', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that if an environment
{   has been overwritten that the environment is deleted and the user
{   of pmp$continue_to_cause is informed that a continue cannot be
{   preformed.

      PROCEDURE dispose_of_environment_overwrit
        (    condition: pmt$condition;
             condition_descriptor: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR overwrite_status: ost$status);

        osp$set_status_abnormal (pmc$program_management_id, pme$stack_overwritten, '', status);
        pmp$delete_current_environment (overwrite_status);
        EXIT find_next_users_handler;
      PROCEND dispose_of_environment_overwrit;
?? OLDTITLE ??
?? NEWTITLE := 'dispose_of_stack_read_error', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that segment access
{   conditions which may arise when scanning stack frames are reported.

      PROCEDURE dispose_of_stack_read_error
        (    segment_access_condition: pmt$condition;
             condition_descriptor: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR ignore_status: ost$status);

        osp$set_status_from_condition (pmc$program_management_id, segment_access_condition, save_area, status,
              status);
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
        osp$set_status_abnormal (pmc$program_management_id, pme$inconsistent_stack, '', status);

        EXIT find_next_users_handler;

      PROCEND dispose_of_stack_read_error;
?? OLDTITLE, EJECT ??

      VAR
        read_error_descriptor: pmt$established_handler,
        descriptor: pmt$established_handler,
        ignore_status: ost$status,
        current_handler: ^pmt$established_handler;

*copyc pmp$find_next_handler_in_stack
*copyc pmp$find_next_handler_in_frame

      pmp$establish_condition_handler (stack_read_error, ^dispose_of_stack_read_error, ^read_error_descriptor,
            ignore_status);
      pmp$establish_condition_handler (environment_overwrite, ^dispose_of_environment_overwrit, ^descriptor,
            ignore_status);
      current_handler := environment^.established_descriptor;
      IF (environment^.condition.class = pmc$block_exit_processing) THEN
        pmp$find_next_handler_in_frame (environment^.condition, environment^.handler_save_area,
              environment^.established_descriptor, environment^.established_descriptor, status);
      ELSE
        pmp$find_next_handler_in_stack (environment^.condition, environment^.handler_save_area,
              environment^.established_descriptor, environment^.established_descriptor,
              environment^.handler_save_area, status);
      IFEND;

      IF status.normal THEN
        IF (current_handler <> environment^.established_descriptor) THEN
          handler_found := (environment^.established_descriptor <> NIL);
        ELSE
          osp$set_status_abnormal (pmc$program_management_id, pme$handler_stack_error, '  ', status);
        IFEND;
      IFEND;

    PROCEND find_next_users_handler;
?? OLDTITLE, EJECT ??

    VAR
      current_environment: pmt$condition_environment,
      condition_handler_active: boolean,
      users_handler_found: boolean,
      active_segment: ost$segment,
      condition_segment: ost$segment,
      executing_ring: ost$ring,
      continue_status: ost$status,
      ignore_status: ost$status;

    #INLINE ('keypoint', osk$entry, 0, pmk$continue_to_cause_condition);
    status.normal := TRUE;
    pmp$get_current_environment (current_environment, condition_handler_active, continue_status);
    IF continue_status.normal THEN
      IF condition_handler_active THEN
        CASE current_environment.condition.class OF


        = pmc$system_conditions =
          IF (current_environment.condition.system <> pmc$debug_unselectable) THEN
            find_next_users_handler (^current_environment, users_handler_found, continue_status);
            IF continue_status.normal THEN
              IF users_handler_found THEN
                IF NOT (current_environment.condition.system IN
                      current_environment.established_descriptor^.handler_active.system) THEN
                  dispose_system_with_handler (^current_environment, continue_status);
                  IF NOT continue_status.normal THEN
                    IF continue_status.condition <> pme$invalid_condition_handler THEN
                      pmp$exit (continue_status);
                    IFEND;
                  IFEND;
                ELSE
                  osp$set_status_abnormal (pmc$program_management_id, pme$recursive_continue,
                        'system condition', continue_status);
                IFEND;
              ELSE
                CASE standard OF
                = pmc$execute_standard_procedure =
                  default_system_cond_handler (^current_environment, { inconsistent_stack } FALSE);
                = pmc$inhibit_standard_procedure =
                  osp$set_status_abnormal (pmc$program_management_id, pme$no_established_handler, '',
                        continue_status);
                ELSE
                  osp$set_status_abnormal (pmc$program_management_id, pme$invalid_standard_selection, '',
                        continue_status);
                CASEND;
              IFEND;
            IFEND;

          ELSE
            osp$set_status_abnormal (pmc$program_management_id, pme$no_condition_to_continue, '',
                  continue_status);
          IFEND;

        = pmc$block_exit_processing =
          find_next_users_handler (^current_environment, users_handler_found, continue_status);
          IF continue_status.normal THEN
            IF users_handler_found THEN
              dispose_block_exit_with_handler (^current_environment, continue_status);
              IF NOT continue_status.normal THEN
                IF (continue_status.condition <> pme$invalid_condition_handler) THEN
                  pmp$exit (continue_status);
                IFEND;
              IFEND;
            ELSE
              CASE standard OF
              = pmc$execute_standard_procedure =
                ;
              = pmc$inhibit_standard_procedure =
                osp$set_status_abnormal (pmc$program_management_id, pme$no_established_handler, '',
                      continue_status);
              ELSE
                osp$set_status_abnormal (pmc$program_management_id, pme$invalid_standard_selection, '',
                      continue_status);
              CASEND;
            IFEND;
          IFEND;


        = jmc$job_resource_condition =
          find_next_users_handler (^current_environment, users_handler_found, continue_status);
          IF continue_status.normal THEN
            IF users_handler_found THEN
              dispose_job_resrce_with_handler (^current_environment, continue_status);
              IF NOT continue_status.normal THEN
                IF (continue_status.condition <> pme$invalid_condition_handler) THEN
                  pmp$exit (continue_status);
                IFEND;
              IFEND;
            ELSE
              find_handler_in_stacks (current_environment.condition, current_environment.handler_save_area,
                    users_handler_found, continue_status);
              IF continue_status.normal THEN
                IF users_handler_found THEN
                  post_ring_crossing_condition (current_environment.handler_save_area, ^current_environment,
                        #RING (^executing_ring) + 1, continue_status, continue_status);

{#ring (^executing_ring) + 1 is the current ring of execution + 1

                ELSE
                  CASE standard OF
                  = pmc$execute_standard_procedure =
                    post_ring_crossing_condition (current_environment.handler_save_area, ^current_environment,
                          #RING (^executing_ring) + 1, continue_status, continue_status);

{#ring (^executing_ring) + 1 is the current ring of execution + 1

                  = pmc$inhibit_standard_procedure =
                    osp$set_status_abnormal (pmc$program_management_id, pme$no_established_handler, '',
                          continue_status);
                  ELSE
                    osp$set_status_abnormal (pmc$program_management_id, pme$invalid_standard_selection, '',
                          continue_status);
                  CASEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;


        = mmc$segment_access_condition =
          find_next_users_handler (^current_environment, users_handler_found, continue_status);
          IF continue_status.normal THEN
            IF users_handler_found THEN
              active_segment := #SEGMENT (current_environment.established_descriptor^.handler_active.
                    segment_access.segment);
              condition_segment := #SEGMENT (current_environment.condition.segment_access.segment);
              IF (current_environment.condition.segment_access.identifier <>
                    current_environment.established_descriptor^.handler_active.segment_access.identifier) AND
                    ((current_environment.established_descriptor^.handler_active.segment_access.segment =
                    NIL) OR (condition_segment <> active_segment)) THEN
                dispose_seg_access_with_handler (^current_environment, continue_status);
                IF NOT continue_status.normal THEN
                  IF (continue_status.condition <> pme$invalid_condition_handler) THEN
                    pmp$exit (continue_status);
                  IFEND;
                IFEND;
              ELSE
                osp$set_status_abnormal (pmc$program_management_id, pme$recursive_continue,
                      'segment access condition', continue_status);
              IFEND;
            ELSE
              CASE standard OF
              = pmc$execute_standard_procedure =
                default_seg_access_cond_handler (^current_environment);
              = pmc$inhibit_standard_procedure =
                osp$set_status_abnormal (pmc$program_management_id, pme$no_established_handler, '',
                      continue_status);
              ELSE
                osp$set_status_abnormal (pmc$program_management_id, pme$invalid_standard_selection, '',
                      continue_status);
              CASEND;
            IFEND;
          IFEND;


        = ifc$interactive_condition =
          find_next_users_handler (^current_environment, users_handler_found, continue_status);
          IF continue_status.normal THEN
            IF users_handler_found THEN
              dispose_interactiv_with_handler (^current_environment, continue_status);
              IF NOT continue_status.normal THEN
                IF (continue_status.condition <> pme$invalid_condition_handler) THEN
                  pmp$exit (continue_status);
                IFEND;
              IFEND;
            ELSE
              find_handler_in_stacks (current_environment.condition, current_environment.handler_save_area,
                    users_handler_found, continue_status);
              IF continue_status.normal THEN
                IF users_handler_found THEN
                  post_ring_crossing_condition (current_environment.handler_save_area, ^current_environment,
                        #RING (^executing_ring) + 1, continue_status, continue_status);

{#ring (^executing_ring) + 1 is the current ring of execution + 1

                ELSE
                  CASE standard OF
                  = pmc$execute_standard_procedure =
                    post_ring_crossing_condition (current_environment.handler_save_area, ^current_environment,
                          #RING (^executing_ring) + 1, continue_status, continue_status);

{#ring (^executing_ring) + 1 is the current ring of execution + 1

                  = pmc$inhibit_standard_procedure =
                    osp$set_status_abnormal (pmc$program_management_id, pme$no_established_handler, '',
                          continue_status);
                  ELSE
                    osp$set_status_abnormal (pmc$program_management_id, pme$invalid_standard_selection, '',
                          continue_status);
                  CASEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;


        = pmc$pit_condition =
          find_next_users_handler (^current_environment, users_handler_found, continue_status);
          IF continue_status.normal THEN
            IF users_handler_found THEN
              dispose_pit_with_handler (^current_environment, continue_status);
              IF NOT continue_status.normal THEN
                IF (continue_status.condition <> pme$invalid_condition_handler) THEN
                  pmp$exit (continue_status);
                IFEND;
              IFEND;
            ELSE
              find_handler_in_stacks (current_environment.condition, current_environment.handler_save_area,
                    users_handler_found, continue_status);
              IF continue_status.normal THEN
                IF users_handler_found THEN
                  post_ring_crossing_condition (current_environment.handler_save_area, ^current_environment,
                        #RING (^executing_ring) + 1, continue_status, continue_status);

{#ring (^executing_ring) + 1 is the current ring of execution + 1

                ELSE
                  CASE standard OF
                  = pmc$execute_standard_procedure =
                    ;
                  = pmc$inhibit_standard_procedure =
                    osp$set_status_abnormal (pmc$program_management_id, pme$no_established_handler, '',
                          continue_status);
                  ELSE
                    osp$set_status_abnormal (pmc$program_management_id, pme$invalid_standard_selection, '',
                          continue_status);
                  CASEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;


        = pmc$user_defined_condition =
          find_next_users_handler (^current_environment, users_handler_found, continue_status);
          IF continue_status.normal THEN
            IF users_handler_found THEN
              dispose_of_user_condition (^current_environment, continue_status);
              IF NOT continue_status.normal THEN
                IF (continue_status.condition <> pme$invalid_condition_handler) THEN
                  pmp$exit (continue_status);
                IFEND;
              IFEND;
            ELSE
              IF current_environment.condition.propagate_info.scope = pmc$current_ring THEN
                CASE standard OF
                = pmc$execute_standard_procedure =
                  ;
                = pmc$inhibit_standard_procedure =
                  osp$set_status_abnormal (pmc$program_management_id, pme$no_established_handler, '',
                        continue_status);
                ELSE
                  osp$set_status_abnormal (pmc$program_management_id, pme$invalid_standard_selection, '',
                        continue_status);
                CASEND;
              ELSE

{ propagate user condition across rings

                find_handler_in_stacks (current_environment.condition, current_environment.handler_save_area,
                      users_handler_found, continue_status);
                IF continue_status.normal THEN
                  IF users_handler_found THEN
                    post_ring_crossing_condition (current_environment.handler_save_area, ^current_environment,
                          #RING (^executing_ring) + 1, continue_status, continue_status);

{#ring (^executing_ring) + 1 is the current ring of execution + 1

                  ELSE
                    CASE standard OF
                    = pmc$execute_standard_procedure =
                      post_ring_crossing_condition (current_environment.handler_save_area,
                            ^current_environment, #RING (^executing_ring) + 1, continue_status,
                            continue_status);

{#ring (^executing_ring) + 1 is the current ring of execution + 1

                    = pmc$inhibit_standard_procedure =
                      osp$set_status_abnormal (pmc$program_management_id, pme$no_established_handler, '',
                            continue_status);
                    ELSE
                      osp$set_status_abnormal (pmc$program_management_id, pme$invalid_standard_selection, '',
                            continue_status);
                    CASEND;
                  IFEND;
                IFEND;
              IFEND; {propagate across rings}
            IFEND;
          IFEND;
        ELSE

{the environment has been overwritten delete the environment

          pmp$delete_current_environment (ignore_status);
          osp$set_status_abnormal (pmc$program_management_id, pme$stack_overwritten, '', continue_status);
          osp$append_status_integer (osc$status_parameter_delimiter, #RING (^executing_ring), 16, FALSE,
                continue_status);
        CASEND;
      ELSE
        osp$set_status_abnormal (pmc$program_management_id, pme$no_condition_to_continue, '',
              continue_status);
      IFEND;
    ELSE
      osp$append_status_integer (osc$status_parameter_delimiter, #RING (^executing_ring), 16, FALSE,
            continue_status);
    IFEND;

    IF continue_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := continue_status;
    IFEND;
    #INLINE ('keypoint', osk$exit, 0, pmk$continue_to_cause_condition);
  PROCEND pmp$continue_to_cause;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE {RETAINED}] pmp$test_condition_handler', EJECT ??
*copyc pmh$test_condition_handler

  PROCEDURE [XDCL, #GATE {retained} ] pmp$test_condition_handler
    (    conditions: pmt$condition;
         save_area: ^ost$stack_frame_save_area;
     VAR status: ost$status);

?? NEWTITLE := 'find_handler', EJECT ??

{ PURPOSE:
{

    PROCEDURE find_handler
      (    condition: pmt$internal_condition;
           save_area: ^ost$stack_frame_save_area;
           environment {input, output} : ^pmt$condition_environment;
       VAR handler_found: boolean;
       VAR status: ost$status);

?? NEWTITLE := 'dispose_of_stack_read_error', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that segment access
{   conditions which may arise when scanning stack frames are reported.

      PROCEDURE dispose_of_stack_read_error
        (    segment_access_condition: pmt$condition;
             condition_descriptor: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR ignore_status: ost$status);

        osp$set_status_from_condition (pmc$program_management_id, segment_access_condition, save_area, status,
              status);
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
        osp$set_status_abnormal (pmc$program_management_id, pme$inconsistent_stack, '', status);

        EXIT find_handler;

      PROCEND dispose_of_stack_read_error;
?? OLDTITLE, EJECT ??

      VAR
        read_error_descriptor: pmt$established_handler,
        ignore_status: ost$status;

      pmp$establish_condition_handler (stack_read_error, ^dispose_of_stack_read_error, ^read_error_descriptor,
            ignore_status);
      pmp$find_handler_in_stack (condition, save_area, environment^.established_descriptor,
            environment^.handler_save_area, status);

      IF status.normal THEN
        handler_found := (environment^.established_descriptor <> NIL);
      ELSE
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
      IFEND;
    PROCEND find_handler;
?? OLDTITLE, EJECT ??

    VAR
      traps: 0 .. 3,
      call_debug: boolean,
      executing_ring: ost$ring,
      outstanding_system: pmt$system_conditions,
      callers_save_area: ^ost$stack_frame_save_area,
      current_environment: pmt$condition_environment,
      handler_found: boolean,
      test_status: ost$status;

    i#enable_traps (traps);
    #INLINE ('keypoint', osk$entry, 0, pmk$test_condition_handler);
    callers_save_area := #PREVIOUS_SAVE_AREA ();
    test_status.normal := TRUE;
    current_environment.debug_index := 0;

    CASE conditions.selector OF
    = pmc$system_conditions =
      current_environment.condition.class := pmc$system_conditions;
      current_environment.condition.system := pmc$detected_uncorrected_err;
      current_environment.condition.untranslatable_pointer := conditions.untranslatable_pointer;
      current_environment.condition_descriptor := NIL;
      current_environment.condition_save_area := save_area;
      outstanding_system := conditions.system_conditions;

      WHILE (current_environment.condition.system <= pmc$invalid_bdp_data) AND
            (outstanding_system <> $pmt$system_conditions []) AND test_status.normal DO
        IF (current_environment.condition.system IN conditions.system_conditions) THEN

          determine_call_debug (call_debug);
          IF NOT call_debug THEN
            find_handler (current_environment.condition, callers_save_area, ^current_environment,
                  handler_found, test_status);
            IF test_status.normal THEN
              IF handler_found THEN
                dispose_system_with_handler (^current_environment, test_status);
                IF NOT test_status.normal THEN
                  IF (test_status.condition <> pme$invalid_condition_handler) THEN
                    pmp$exit (test_status);
                  IFEND;
                IFEND;
              ELSE
                osp$set_status_abnormal (pmc$program_management_id, pme$no_established_handler, '',
                      test_status);
              IFEND;
            IFEND;
          ELSE
            dispose_condition_with_debugger (^current_environment, callers_save_area, FALSE);
          IFEND;
          outstanding_system := (outstanding_system - $pmt$system_conditions
                [current_environment.condition.system]);
        IFEND;
        IF current_environment.condition.system < pmc$invalid_bdp_data THEN
          current_environment.condition.system := SUCC (current_environment.condition.system);
        IFEND;
      WHILEND;

    = pmc$block_exit_processing =
      osp$set_status_abnormal (pmc$program_management_id, pme$unsupported_by_test_cond, '', test_status);

    = mmc$segment_access_condition =
      current_environment.condition.class := mmc$segment_access_condition;
      current_environment.condition_save_area := save_area;
      current_environment.condition.segment_access := conditions.segment_access_condition;
      current_environment.condition_descriptor := NIL;
      current_environment.debug_index := 0;

      determine_call_debug (call_debug);
      IF NOT call_debug THEN
        find_handler (current_environment.condition, callers_save_area, ^current_environment, handler_found,
              test_status);
        IF test_status.normal THEN
          IF handler_found THEN
            dispose_seg_access_with_handler (^current_environment, test_status);
            IF NOT test_status.normal THEN
              IF (test_status.condition <> pme$invalid_condition_handler) THEN
                pmp$exit (test_status);
              IFEND;
            IFEND;
          ELSE
            osp$set_status_abnormal (pmc$program_management_id, pme$no_established_handler, '', test_status);
          IFEND;
        IFEND;
      ELSE
        dispose_condition_with_debugger (^current_environment, callers_save_area, FALSE);
      IFEND;

    = jmc$job_resource_condition =
      current_environment.condition.class := jmc$job_resource_condition;
      current_environment.condition.job_resource := conditions.job_resource_condition;
      current_environment.condition_descriptor := NIL;
      current_environment.condition_save_area := callers_save_area;
      current_environment.debug_index := 0;

      find_handler (current_environment.condition, callers_save_area, ^current_environment, handler_found,
            test_status);
      IF test_status.normal THEN
        IF handler_found THEN
          dispose_job_resrce_with_handler (^current_environment, test_status);
          IF NOT test_status.normal THEN
            IF (test_status.condition <> pme$invalid_condition_handler) THEN
              pmp$exit (test_status);
            IFEND;
          IFEND;
        ELSE
          find_handler_in_stacks (current_environment.condition, callers_save_area, handler_found,
                test_status);
          IF test_status.normal THEN
            IF handler_found THEN
              post_ring_crossing_condition (current_environment.handler_save_area, ^current_environment,
                    #RING (^executing_ring) + 1, test_status, test_status);

{#ring (^executing_ring) + 1 is the current ring of execution + 1

            ELSE
              osp$set_status_abnormal (pmc$program_management_id, pme$no_established_handler, '',
                    test_status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;

    = ifc$interactive_condition =
      current_environment.condition.class := ifc$interactive_condition;
      current_environment.condition.interactive := conditions.interactive_condition;
      current_environment.condition_descriptor := NIL;
      current_environment.condition_save_area := callers_save_area;
      current_environment.debug_index := 0;

      determine_call_debug (call_debug);
      IF NOT call_debug THEN
        find_handler (current_environment.condition, callers_save_area, ^current_environment, handler_found,
              test_status);
        IF test_status.normal THEN
          IF handler_found THEN
            dispose_interactiv_with_handler (^current_environment, test_status);
            IF NOT test_status.normal THEN
              IF (test_status.condition <> pme$invalid_condition_handler) THEN
                pmp$exit (test_status);
              IFEND;
            IFEND;
          ELSE
            find_handler_in_stacks (current_environment.condition, callers_save_area, handler_found,
                  test_status);
            IF test_status.normal THEN
              IF handler_found THEN
                post_ring_crossing_condition (current_environment.handler_save_area, ^current_environment,
                      #RING (^executing_ring) + 1, test_status, test_status);

{#ring (^executing_ring) + 1 is the current ring of execution + 1

              ELSE
                osp$set_status_abnormal (pmc$program_management_id, pme$no_established_handler, '',
                      test_status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      ELSE
        dispose_condition_with_debugger (^current_environment, callers_save_area, FALSE);
      IFEND;

    = pmc$pit_condition =
      current_environment.condition.class := pmc$pit_condition;
      current_environment.condition_descriptor := NIL;
      current_environment.condition_save_area := callers_save_area;
      current_environment.debug_index := 0;

      determine_call_debug (call_debug);
      IF NOT call_debug THEN
        find_handler (current_environment.condition, callers_save_area, ^current_environment, handler_found,
              test_status);
        IF test_status.normal THEN
          IF handler_found THEN
            dispose_pit_with_handler (^current_environment, test_status);
            IF NOT test_status.normal THEN
              IF (test_status.condition <> pme$invalid_condition_handler) THEN
                pmp$exit (test_status);
              IFEND;
            IFEND;
          ELSE
            find_handler_in_stacks (current_environment.condition, callers_save_area, handler_found,
                  test_status);
            IF test_status.normal THEN
              IF handler_found THEN
                post_ring_crossing_condition (current_environment.handler_save_area, ^current_environment,
                      #RING (^executing_ring) + 1, test_status, test_status);

{#ring (^executing_ring) + 1 is the current ring of execution + 1

              ELSE
                osp$set_status_abnormal (pmc$program_management_id, pme$no_established_handler, '',
                      test_status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      ELSE
        dispose_condition_with_debugger (^current_environment, callers_save_area, FALSE);
      IFEND;

    ELSE
      osp$set_status_abnormal (pmc$program_management_id, pme$unsupported_by_test_cond, '', test_status);
    CASEND;

    IF test_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := test_status;
    IFEND;

    #INLINE ('keypoint', osk$exit, 0, pmk$test_condition_handler);
    i#restore_traps (traps);
  PROCEND pmp$test_condition_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE {retained}] pmp$cause_task_condition', EJECT ??

  PROCEDURE [XDCL, #GATE {retained} ] pmp$cause_task_condition
    (    condition_name: pmt$condition_name;
         condition_descriptor: ^pmt$condition_information;
         notify_scl: boolean;
         notify_debug: boolean;
         propagate_to_parent: boolean;
         call_default_handler: boolean;
     VAR status: ost$status);


    VAR
      call_debug: boolean,
      name: ost$name,
      executing_ring: ost$ring,
      sfsa: ^ost$stack_frame_save_area,
      post_status,
      cause_status: ost$status,
      users_handler_found: boolean,
      ignore_status: ost$status,
      current_environment: pmt$condition_environment,
      valid_name: boolean;

    #INLINE ('keypoint', osk$entry, 0, pmk$cause_condition);

    clp$validate_name (condition_name, name, valid_name);
    IF valid_name THEN
      cause_status.normal := TRUE;
      sfsa := #PREVIOUS_SAVE_AREA ();
      current_environment.condition_save_area := #PREVIOUS_SAVE_AREA ();
      current_environment.condition.class := pmc$user_defined_condition;
      current_environment.condition.user_defined := name;
      current_environment.condition_descriptor := condition_descriptor;
      current_environment.condition.propagate_info.scope := pmc$current_task;
      current_environment.condition.propagate_info.notify_scl := notify_scl;
      current_environment.condition.propagate_info.notify_debug := notify_debug;
      current_environment.condition.propagate_info.propagate_to_parent := propagate_to_parent;
      current_environment.condition.propagate_info.call_default_handler := call_default_handler;
      current_environment.debug_index := 0;

      determine_call_debug (call_debug);
      IF (NOT call_debug) OR (NOT notify_debug) THEN
        find_users_handler (^current_environment, users_handler_found, cause_status);
        IF cause_status.normal THEN
          IF users_handler_found THEN
            dispose_of_user_condition (^current_environment, cause_status);
            IF NOT cause_status.normal THEN
              #INLINE ('keypoint', osk$exit, (0), pmk$cause_condition);
              pmp$exit (cause_status);
            IFEND;
          ELSE
            post_ring_crossing_condition (sfsa, ^current_environment, (#RING (^executing_ring) + 1) MOD 16,
                  post_status, status);
            IF NOT post_status.normal THEN

{posting the condition found an inconsistent stack segment - the condition
{will be ignored and continued execution of the task will detect the
{inconsistent stack again, at which time the task will be aborted.

              status.normal := TRUE;
            IFEND;
          IFEND;
        IFEND;
      ELSE
        dispose_condition_with_debugger (^current_environment, current_environment.condition_save_area,
              FALSE);
      IFEND;
    ELSE
      osp$set_status_abnormal ('CL', cle$improper_name, condition_name, cause_status);
    IFEND;

    IF cause_status.normal THEN
      status.normal := TRUE;
    ELSE
      status := cause_status;
    IFEND;

    #INLINE ('keypoint', osk$exit, ((1 - ORD (status.normal)) * 0),
          pmk$cause_condition);


  PROCEND pmp$cause_task_condition;
?? OLDTITLE ??
?? NEWTITLE := 'default_user_defined_handler', EJECT ??

  PROCEDURE default_user_defined_handler
    (    condition: pmt$condition;
     VAR status: ost$status);

    VAR
      str: string (80),
      strl: integer;


    STRINGREP (str, strl, 'USER DEFINED CONDITION ', condition.user_condition_name, ' IGNORED');
    pmp$log (str (1, strl), status);

  PROCEND default_user_defined_handler;
?? OLDTITLE ??
?? NEWTITLE := 'ignore_user_defined_condition', EJECT ??

  PROCEDURE ignore_user_defined_condition
    (    condition: pmt$condition;
     VAR status: ost$status);

{ Do nothing.

  PROCEND ignore_user_defined_condition;
?? OLDTITLE ??

MODEND pmm$dispose_of_conditions;
*DECK DECK=PMM$DISPOSE_OF_TRAPS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Management - Program Conditions' ??
MODULE pmm$dispose_of_traps;




{   PURPOSE:
{     The purpose of this module is to confine the knowledge of disposing
{     of traps - it is the first CYBIL module to execute in the trap
{     processor.

{   DESIGN:
{     The procedures contained in this module have an execution bracket
{     of 2, 13.

{     One of the purposes of the trap handler is to protect task termination's
{     stack frame popper.  When any trap occurs, a test is made to see if the
{     trap handler needs protect popper.  If it does, it protects popper by
{     a local variable "protect_popper".  If this is true, and the trap handler's
{     block_exit handler gets control, the interface pmp$pop_all_stack_frames is
{     called.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osc$processor_defined_registers
*copyc osd$registers
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc ost$name
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc pme$push_inhibit_but_no_pop
*copyc pmt$condition
*copyc pmt$debug_environment
*copyc pmt$os_stack_frame_word
?? POP ??
*copyc i#disable_traps
*copyc i#enable_traps
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_condition
*copyc pmp$abort
*copyc pmp$activate_ring_alarm
*copyc pmp$await_ada_task
*copyc pmp$continue_to_cause
*copyc pmp$dispose_of_delayed_cond
*copyc pmp$dispose_ucr_conditions
*copyc pmp$exit
*copyc pmp$get_debug_environment
*copyc pmp$pop_all_stack_frames
*copyc pmp$post_debug_environment
*copyc pmp$set_popper_handler_activity
*copyc tmp$dispose_of_monitor_faults
*copyc tmp$dispose_preemptive_commo
*copyc tmp$post_monitor_fault_sfsa
*copyc pmv$popper_handler_established
*copyc pmv$task_execution_phase
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$dispose_of_traps', EJECT ??
*copy pmh$dispose_of_traps

  PROCEDURE [XDCL] pmp$dispose_of_traps
    (    sfsa: ^ost$stack_frame_save_area);

    VAR
      critical_frame: boolean,
      debug_environment: pmt$debug_environment,
      debug_index: 0 .. 31,
      debug_trap: boolean,
      local_status: ost$status,
      monitor_fault_present: boolean,
      need_to_protect_popper: boolean,
      on_condition: boolean,
      os_stack_frame_word: ^pmt$os_stack_frame_word,
      p_ring: ost$ring,
      psa_ring: ost$ring,
      ring_status: ost$status,
      system_core_debugger_inactive: boolean,
      trap_enables: 0 .. 3,
      ucr: ost$user_conditions,
      x_frame: ^ost$stack_frame_save_area;

?? NEWTITLE := 'dispose_of_nonlocal_exit - dispose of traps', EJECT ??

{ PURPOSE:
{   This procedure (condition handler) ensures that:
{   1.  the system uses of free flag (ring alarm and preemptive communication)
{       are not circumvented by a non local exit;
{   2.  no outstanding condition is circumvented by a non local exit;
{   3.  the debug environment is popped if the trap was debug -
{       pmp$get_debug_environment.
{
{ NOTES:
{   If we happen to trap before the block exit handler gets established it is
{   possible that this block exit handler will not get the opportunity to
{   really execute.

    PROCEDURE dispose_of_nonlocal_exit
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        trap_enables: 0 .. 3;

      i#disable_traps (trap_enables);
      osp$establish_block_exit_hndlr (^dispose_of_nonlocal_exit);
      i#enable_traps (trap_enables);

      IF (osc$free_flag IN ucr) THEN
        IF monitor_fault_present THEN
          tmp$dispose_of_monitor_faults (sfsa);
        IFEND;

        tmp$dispose_preemptive_commo (tmc$free_flag);

        IF (sfsa^.minimum_save_area.p_register.pva.ring > osc$tmtr_ring) THEN
          pmp$dispose_of_delayed_cond (sfsa);
        IFEND;

        ucr := (ucr - $ost$user_conditions [osc$free_flag]);
      IFEND;

      IF critical_frame THEN
        IF NOT (on_condition AND (os_stack_frame_word^.block_exit_frame OR
              os_stack_frame_word^.debug_cff_frame)) THEN
          ucr := (ucr - $ost$user_conditions [osc$critical_frame_flag]);
        IFEND;
      IFEND;

      IF (osc$keypoint IN ucr) THEN
        ucr := (ucr - $ost$user_conditions [osc$keypoint]);
      IFEND;

      IF (ucr <> $ost$user_conditions []) THEN
        pmp$dispose_ucr_conditions (ucr, sfsa, debug_index);
      IFEND;

{ After all other ucr conditions have been processed, process the task
{ termination inhibit and ADA critical frame flags.

      IF on_condition AND critical_frame THEN
        #SPOIL (os_stack_frame_word^);
        IF os_stack_frame_word^.terminate_inhibit_frame THEN
          os_stack_frame_word^.terminate_inhibit_frame := FALSE;
          #SPOIL (os_stack_frame_word^);
          osp$set_status_condition (pme$push_inhibit_but_no_pop, local_status);
          pmp$abort (local_status);
        IFEND;

{ Do not allow the task to continue if this stack frame is an ADA critical
{ frame with a non-zero frame count.  The task must wait until all tasks with
{ this critical frame have terminated.

        IF (os_stack_frame_word^.ada_critical_frame AND (os_stack_frame_word^.ada_critical_frame_count <> 0))
              THEN
          pmp$await_ada_task (os_stack_frame_word);
        IFEND;
      IFEND;

      IF debug_trap AND system_core_debugger_inactive THEN
        pmp$get_debug_environment (debug_environment);

{it is not necessary to update the debug environment registers on a non-local exit

      IFEND;

      IF critical_frame THEN
        sfsa^.minimum_save_area.frame_descriptor.on_condition_flag := FALSE;
        sfsa^.minimum_save_area.frame_descriptor.critical_frame_flag := FALSE;
      IFEND;

      i#disable_traps (trap_enables);
      osp$disestablish_cond_handler;

      IF need_to_protect_popper THEN
        pmp$set_popper_handler_activity (FALSE);
        IF pmv$task_execution_phase = pmc$task_popping_stack_frames THEN
          i#enable_traps (trap_enables);
          pmp$pop_all_stack_frames;
        ELSE
          need_to_protect_popper := FALSE;
        IFEND;
      IFEND;
      i#enable_traps (trap_enables);
    PROCEND dispose_of_nonlocal_exit;
?? OLDTITLE ??
?? EJECT ??

    TYPE
      debug_mask_type = packed record
        filler: array [1 .. 7] of cell,
        unused: boolean,
        mask: ost$debug_mask,
      recend,
      user_mask_type = set of 0 .. 63;

    CONST
      debug_mask_bit = 56;

    VAR
      converter: record
        case 0 .. 2 of
        = 0 =
          register: integer,
        = 1 =
          debug_mask: debug_mask_type,
        = 2 =
          user_mask: user_mask_type,
        casend,
      recend,

      debug_mask: debug_mask_type;

    p_ring := sfsa^.minimum_save_area.p_register.pva.ring;
    psa_ring := #RING (sfsa^.minimum_save_area.a2_previous_save_area);
    ucr := (sfsa^.user_condition_register * sfsa^.minimum_save_area.user_mask);
    debug_index := (#READ_REGISTER (osc$pr_debug_index) DIV 2);
    system_core_debugger_inactive := (#READ_REGISTER (osc$pr_debug_list_pointer) DIV 100000000000(16)) <> 1;
    debug_trap := (osc$debug IN ucr);
    critical_frame := (osc$critical_frame_flag IN ucr);
    on_condition := sfsa^.minimum_save_area.frame_descriptor.on_condition_flag;
    os_stack_frame_word := sfsa^.minimum_save_area.a1_current_stack_frame;

    IF system_core_debugger_inactive THEN
      IF debug_trap THEN
        debug_environment.debug_index := #READ_REGISTER (osc$pr_debug_index);
        converter.register := #READ_REGISTER (osc$pr_debug_mask_reg);
        debug_mask := converter.debug_mask;
        debug_environment.debug_mask := debug_mask.mask;
        pmp$post_debug_environment (debug_environment);
      IFEND;

{clear the debug bit in the user mask register

      converter.register := #READ_REGISTER (osc$pr_user_mask_reg);
      converter.user_mask := converter.user_mask - $user_mask_type [debug_mask_bit];
      #WRITE_REGISTER (osc$pr_user_mask_reg, converter.register);
    IFEND;
?? EJECT ??
    IF osc$free_flag IN ucr THEN
      tmp$post_monitor_fault_sfsa (sfsa, monitor_fault_present);
    ELSE
      monitor_fault_present := FALSE;
    IFEND;

    osp$establish_block_exit_hndlr (^dispose_of_nonlocal_exit);

    need_to_protect_popper := NOT pmv$popper_handler_established;
    IF need_to_protect_popper THEN
      pmp$set_popper_handler_activity (need_to_protect_popper);
    IFEND;
    i#enable_traps (trap_enables);

    IF (osc$free_flag IN ucr) THEN
      IF monitor_fault_present THEN
        tmp$dispose_of_monitor_faults (sfsa);
      IFEND;
      tmp$dispose_preemptive_commo (tmc$free_flag);
      sfsa^.user_condition_register := ucr;

      IF sfsa^.minimum_save_area.p_register.pva.ring > osc$tmtr_ring THEN
        pmp$dispose_of_delayed_cond (sfsa);
      IFEND;
      ucr := ucr - $ost$user_conditions [osc$free_flag];
    IFEND;

    IF critical_frame AND NOT (on_condition AND (os_stack_frame_word^.block_exit_frame OR
          os_stack_frame_word^.debug_cff_frame)) THEN
      ucr := (ucr - $ost$user_conditions [osc$critical_frame_flag]);
    IFEND;

    IF (osc$keypoint IN ucr) THEN
      ucr := (ucr - $ost$user_conditions [osc$keypoint]);
    IFEND;

    IF (ucr <> $ost$user_conditions []) THEN
      pmp$dispose_ucr_conditions (ucr, sfsa, debug_index);
    IFEND;

{ After all other ucr conditions have been processed, process the task
{ termination inhibit and ADA critical frame flags.

    IF on_condition AND critical_frame THEN
      #SPOIL (os_stack_frame_word^);
      IF os_stack_frame_word^.terminate_inhibit_frame THEN
        os_stack_frame_word^.terminate_inhibit_frame := FALSE;
        #SPOIL (os_stack_frame_word^);
        osp$set_status_condition (pme$push_inhibit_but_no_pop, local_status);
        pmp$abort (local_status);
      IFEND;

{ Do not allow the task to continue if this stack frame is an ADA critical
{ frame with a non-zero frame count.  The task must wait until all tasks with
{ this critical frame have terminated.

      IF (os_stack_frame_word^.ada_critical_frame AND (os_stack_frame_word^.ada_critical_frame_count <> 0))
            THEN
        pmp$await_ada_task (os_stack_frame_word);
      IFEND;
    IFEND;

    IF critical_frame THEN
      sfsa^.minimum_save_area.frame_descriptor.on_condition_flag := FALSE;
      sfsa^.minimum_save_area.frame_descriptor.critical_frame_flag := FALSE;
    IFEND;

    i#disable_traps (trap_enables);

    IF debug_trap AND system_core_debugger_inactive THEN
      pmp$get_debug_environment (debug_environment);
      #WRITE_REGISTER (osc$pr_debug_index, debug_environment.debug_index);
      debug_mask.mask := debug_environment.debug_mask;
      converter.debug_mask := debug_mask;
      #WRITE_REGISTER (osc$pr_debug_mask_reg, converter.register);
    IFEND;

    osp$disestablish_cond_handler;

    IF need_to_protect_popper THEN
      pmp$set_popper_handler_activity (FALSE);
    IFEND;

  PROCEND pmp$dispose_of_traps;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$ring_crossing_procedure', EJECT ??
*copyc pmh$ring_crossing_procedure

  PROCEDURE [XDCL] pmp$ring_crossing_procedure;

    VAR
      activate_alarm: boolean,
      of_execution: ^cell,
      trap_enables: 0 .. 3,
      p_ring: ost$ring,
      activate_status: ost$status;

?? NEWTITLE := 'dispose_of_nonlocal_exit - ring_crossing_procedure', EJECT ??

{ PURPOSE:
{   This procedure is the block exit processor for PMP$RING_CROSSING_PROCEDURE.

    PROCEDURE dispose_of_nonlocal_exit
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        trap_enables: 0 .. 3;


      i#disable_traps (trap_enables);
      osp$establish_block_exit_hndlr (^dispose_of_nonlocal_exit);
      i#enable_traps (trap_enables);

      tmp$dispose_preemptive_commo (tmc$recognition_ring_delay);
      osp$disestablish_cond_handler;

    PROCEND dispose_of_nonlocal_exit;

?? OLDTITLE, EJECT ??

    osp$establish_block_exit_hndlr (^dispose_of_nonlocal_exit);
    of_execution := ^p_ring;
    p_ring := #RING (of_execution);
    i#enable_traps (trap_enables);

    activate_alarm := FALSE;
    activate_status.normal := TRUE;

{Check for delayed preemption and potential activation of ring alarm.

    IF p_ring <= osc$tsrv_ring THEN
      tmp$dispose_preemptive_commo (tmc$recognition_ring_delay);
    IFEND;

    i#disable_traps (trap_enables);
    pmp$activate_ring_alarm (activate_alarm, activate_status);
    osp$disestablish_cond_handler;

    IF NOT activate_status.normal THEN
      i#enable_traps (trap_enables);
      pmp$exit (activate_status);
    IFEND;

  PROCEND pmp$ring_crossing_procedure;
?? OLDTITLE ??

MODEND pmm$dispose_of_traps;

*DECK DECK=PMM$ENABLE_MAIN_OPERATOR_WIN_PD EXPAND=TRUE
create_program_description name=(enable_main_operator_window, enamow) ..
      starting_procedure=pmp$_enable_main_operator_windo log_option=manual ..
      library=osf$current_library termination_error_level=warning ..
      load_map_options=none load_map=$null debug_mode=off
*DECK DECK=PMM$END_HANDLER_PROCESSING EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE: Program Management - Task End Handler Interfaces', EJECT ??
MODULE pmm$end_handler_processing;

{  PURPOSE:
{    This module contains program services for establishing and
{  disestablishing handlers that execute at task termination for
{  the purpose of task cleanup.
{
{  DESIGN:
{    Task end handlers are queued in task private lists for each ring
{  and are called during task termination cleanup.
{
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cyd$cybil_structure_definitions
*copyc osd$virtual_address
*copyc ost$caller_identifier
*copyc ost$status
*copyc oss$task_private
*copyc osv$task_private_heap
*copyc osk$keypoints
*copyc pme$condition_exceptions
*copyc pmk$keypoints

?? POP ??
*copyc pmp$task_state
*copyc pmt$end_handler_desc
*copyc osp$set_status_abnormal

  VAR
    pmv$end_handler_list: [XDCL, STATIC, oss$task_private] ^pmt$end_handler_ring_list := NIL;


?? TITLE := '  [XDCL, #GATE] pmp$establish_end_handler', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$establish_end_handler (end_handler: pmt$end_handler;
    VAR status: ost$status);

    VAR
      caller: ost$caller_identifier;

    #KEYPOINT (osk$entry, 0, pmk$establish_end_handler);

    #caller_id (caller);

    pmp$establish_end_hndlr_in_ring (end_handler, caller.ring, status);

    #KEYPOINT (osk$exit, 0, pmk$establish_end_handler);

  PROCEND pmp$establish_end_handler;

?? TITLE := '  [XDCL, #GATE] pmp$establish_end_hndlr_in_ring', EJECT ??


  PROCEDURE [XDCL, #GATE] pmp$establish_end_hndlr_in_ring (end_handler: pmt$end_handler;
        ring: ost$ring;
    VAR status: ost$status);

    VAR
      converter: record
        case 0 .. 1 of
        = 0 =
          end_handler: pmt$end_handler,
        = 1 =
          pointer_to_procedure: cyt$pointer_to_procedure,
        casend,
      recend;

    VAR
      caller: ost$caller_identifier,
      ring_index: ost$ring,
      handler_list: ^pmt$end_handler_ring_list,
      desc_ptr: ^pmt$end_handler_desc,
      cur_ptr: ^pmt$end_handler_desc;

    #KEYPOINT (osk$entry, 0, pmk$establish_end_hndlr_in_ring);

    #caller_id (caller);

    status.normal := TRUE;

    IF pmp$task_state () <> pmc$task_active THEN
      osp$set_status_abnormal (pmc$program_management_id, pme$handler_queue_error, '', status);
      #KEYPOINT (osk$exit, 0, pmk$establish_end_hndlr_in_ring);
      RETURN;
    IFEND;

    IF (caller.ring > ring) THEN
      osp$set_status_abnormal (pmc$program_management_id, pme$handler_more_privileged, '', status);
      #KEYPOINT (osk$exit, 0, pmk$establish_end_hndlr_in_ring);
      RETURN;
    IFEND;

    IF pmv$end_handler_list = NIL THEN
      ALLOCATE handler_list IN osv$task_private_heap^;
      FOR ring_index := LOWERBOUND (pmt$end_handler_ring_list) TO UPPERBOUND (pmt$end_handler_ring_list) DO
        handler_list^ [ring_index] := NIL;
      FOREND;
      pmv$end_handler_list := handler_list;
    IFEND;

    converter.end_handler := end_handler;
    IF converter.pointer_to_procedure.static_link <> NIL THEN
      osp$set_status_abnormal (pmc$program_management_id, pme$handler_nested_proc, '', status);
      #KEYPOINT (osk$exit, 0, pmk$establish_end_hndlr_in_ring);
      RETURN;
    IFEND;

    ALLOCATE desc_ptr IN osv$task_private_heap^;

    desc_ptr^.end_handler := end_handler;
    desc_ptr^.disestablished := FALSE;
    desc_ptr^.called := FALSE;
    desc_ptr^.link := NIL;

    IF pmv$end_handler_list^ [ring] = NIL THEN
      pmv$end_handler_list^ [ring] := desc_ptr;
    ELSE
      cur_ptr := pmv$end_handler_list^ [ring];
      WHILE cur_ptr^.link <> NIL DO
        cur_ptr := cur_ptr^.link;
      WHILEND;
      cur_ptr^.link := desc_ptr;
    IFEND;

    #KEYPOINT (osk$exit, 0, pmk$establish_end_hndlr_in_ring);

  PROCEND pmp$establish_end_hndlr_in_ring;

?? TITLE := '  [XDCL, #GATE] pmp$disestablish_end_handler', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$disestablish_end_handler (end_handler: pmt$end_handler;
    VAR status: ost$status);

    VAR
      caller: ost$caller_identifier;

    #KEYPOINT (osk$entry, 0, pmk$disestablish_end_handler);

    #caller_id (caller);

    pmp$disestab_end_hndlr_in_ring (end_handler, caller.ring, status);

    #KEYPOINT (osk$exit, 0, pmk$disestablish_end_handler);

  PROCEND pmp$disestablish_end_handler;


?? TITLE := '  [XDCL, #GATE] pmp$disestab_end_hndlr_in_ring', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$disestab_end_hndlr_in_ring (end_handler: pmt$end_handler;
        ring: ost$ring;
    VAR status: ost$status);

    VAR
      cur_ptr: ^pmt$end_handler_desc,
      dis_ptr: ^pmt$end_handler_desc,
      caller: ost$caller_identifier;

    #KEYPOINT (osk$entry, 0, pmk$disestab_end_hndlr_in_ring);

    #caller_id (caller);

    status.normal := TRUE;

    IF (caller.ring > ring) THEN
      osp$set_status_abnormal (pmc$program_management_id, pme$handler_more_privileged, '', status);
      #KEYPOINT (osk$exit, 0, pmk$disestab_end_hndlr_in_ring);
      RETURN;
    IFEND;


    IF pmv$end_handler_list = NIL THEN
      osp$set_status_abnormal (pmc$program_management_id, pme$no_established_handler, '', status);
      #KEYPOINT (osk$exit, 0, pmk$disestab_end_hndlr_in_ring);
      RETURN;
    IFEND;


    cur_ptr := pmv$end_handler_list^ [ring];
    dis_ptr := NIL;

    WHILE cur_ptr <> NIL DO
      IF (cur_ptr^.end_handler = end_handler) AND (NOT cur_ptr^.disestablished) AND (NOT cur_ptr^.called) THEN
        dis_ptr := cur_ptr;
      IFEND;
      cur_ptr := cur_ptr^.link;
    WHILEND;

    IF dis_ptr = NIL THEN
      osp$set_status_abnormal (pmc$program_management_id, pme$no_established_handler, '', status);
    ELSE
      dis_ptr^.disestablished := TRUE;
    IFEND;

    #KEYPOINT (osk$exit, 0, pmk$disestab_end_hndlr_in_ring);

  PROCEND pmp$disestab_end_hndlr_in_ring;

MODEND pmm$end_handler_processing;
*DECK DECK=PMM$GET_JOB_TASK_STATISTICS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Program Management : Job/Task Statistics Services' ??
MODULE pmm$get_job_task_statistics;

{ PURPOSE:
{   This module contains procedures which return job or task performance statistics
{   to the user.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc clt$parameter_list
*copyc clt$work_area
*copyc osk$keypoint_class_codes
*copyc oss$job_paged_literal
*copyc ost$data_id
*copyc ost$status
*copyc pmk$keypoints
*copyc pmt$job_task_statistics
*copyc pmt$task_cp_time
*copyc pmt$task_jobmode_statistics
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$make_integer_value
*copyc osp$copy_local_status_to_status
*copyc osp$get_job_stats
*copyc osp$set_status_abnormal
*copyc pmp$get_task_cp_time
*copyc pmp$get_task_jobmode_statistics

?? TITLE := '[XDCL] pmp$$cpu_time', EJECT ??

{ PURPOSE:
{   This procedure provides the SCL $CPU_TIME function processor.

  PROCEDURE [XDCL] pmp$$cpu_time
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION (osm$$cpu_time) $cpu_time (
{   accumulator: key
{       (job, j)
{       (job_monitor_mode, jmm)
{       (job_job_mode, jjm)
{       (task, t)
{       (task_monitor_mode, tmm)
{       (task_job_mode, tjm)
{     keyend = job
{   )

?? 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$keyword_type_qualifier,
        keyword_specs: array [1 .. 12] of clt$keyword_specification,
        default_value: string (3),
      recend,
    recend := [
    [1,
    [88, 12, 12, 14, 16, 43, 175],
    clc$function, 1, 1, 0, 0, 0, 0, 0, 'OSM$$CPU_TIME'], [
    ['ACCUMULATOR                    ',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, 451,
  clc$optional_default_parameter, 0, 3]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [12], [
    ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['JJM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['JMM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['JOB_JOB_MODE                   ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['JOB_MONITOR_MODE               ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['TASK                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['TASK_JOB_MODE                  ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['TASK_MONITOR_MODE              ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['TJM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['TMM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5]]
    ,
    'job']];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$accumulator = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    CONST
      keywords_supported = 6;

    VAR
      accumulator_list: [STATIC, READ, oss$job_paged_literal] array [1 .. keywords_supported] of record
        accumulator_name: ost$name,
        statistic_key: pmt$job_task_statistics_key,
      recend := [['JOB                            ', pmc$jts_job_cpu],
            ['JOB_JOB_MODE                   ', pmc$jts_job_job_cpu],
            ['JOB_MONITOR_MODE               ', pmc$jts_job_monitor_cpu],
            ['TASK                           ', pmc$jts_task_cpu],
            ['TASK_JOB_MODE                  ', pmc$jts_task_job_cpu],
            ['TASK_MONITOR_MODE              ', pmc$jts_task_monitor_cpu]],
      get_statistic_p: ^array [1 .. * ] of pmt$job_task_statistics,
      i: 1 .. keywords_supported;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH get_statistic_p: [1 .. 1];
    IF pvt [p$accumulator].specified THEN

    /find_key/
      FOR i := 1 TO keywords_supported DO
        IF pvt [p$accumulator].value^.keyword_value = accumulator_list [i].accumulator_name THEN
          get_statistic_p^ [1].key := accumulator_list [i].statistic_key;
          EXIT /find_key/;
        IFEND;
      FOREND /find_key/;
    ELSE
      get_statistic_p^ [1].key := pmc$jts_job_cpu;
    IFEND;

    pmp$get_job_task_statistics (get_statistic_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE get_statistic_p^ [1].key OF
    = pmc$jts_job_cpu =
      clp$make_integer_value (get_statistic_p^ [1].job_cpu_time, 10, FALSE, work_area, result);
    = pmc$jts_job_job_cpu =
      clp$make_integer_value (get_statistic_p^ [1].job_job_cpu_time, 10, FALSE, work_area, result);
    = pmc$jts_job_monitor_cpu =
      clp$make_integer_value (get_statistic_p^ [1].job_monitor_cpu_time, 10, FALSE, work_area, result);
    = pmc$jts_task_cpu =
      clp$make_integer_value (get_statistic_p^ [1].task_cpu_time, 10, FALSE, work_area, result);
    = pmc$jts_task_job_cpu =
      clp$make_integer_value (get_statistic_p^ [1].task_job_cpu_time, 10, FALSE, work_area, result);
    = pmc$jts_task_monitor_cpu =
      clp$make_integer_value (get_statistic_p^ [1].task_monitor_cpu_time, 10, FALSE, work_area, result);
    ELSE;
    CASEND;
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
    IFEND;
  PROCEND pmp$$cpu_time;

?? TITLE := '[XDCL, #GATE] pmp$get_job_task_statistics', EJECT ??
*copy pmh$get_job_task_statistics

  PROCEDURE [XDCL, #GATE] pmp$get_job_task_statistics
    (    statistic_data_p: ^array [1 .. * ] of pmt$job_task_statistics;
     VAR status: ost$status);

    VAR
      i: integer,
      job_stats: boolean,
      local_status: ost$status,
      task_cpu: boolean,
      task_cp_time: pmt$task_cp_time,
      task_job_cpu: boolean,
      task_jobmode_stats: pmt$task_jobmode_statistics,
      user_job_stats: ost$job_stats;

    #KEYPOINT (osk$entry, 0, pmk$get_job_task_statistics);

    IF statistic_data_p <> NIL THEN
      local_status.normal := TRUE;

    /local_status_control/
      BEGIN
        job_stats := FALSE;
        task_cpu := FALSE;
        task_job_cpu := FALSE;

{ Determine statistic functions to call.

        FOR i := 1 TO UPPERBOUND (statistic_data_p^) DO
          CASE statistic_data_p^ [i].key OF
          = pmc$jts_task_job_cpu =
            task_job_cpu := TRUE;
          = pmc$jts_task_cpu, pmc$jts_task_monitor_cpu =
            task_cpu := TRUE;
          = pmc$jts_job_cpu, pmc$jts_job_job_cpu, pmc$jts_job_monitor_cpu, pmc$jts_paging_statistics,
                pmc$jts_ready_task_count, pmc$jts_working_set_size =
            job_stats := TRUE;
          = pmc$jts_null_statistic =
            ;
          ELSE;
          CASEND;
        FOREND;

{ Call required statistic functions.

        IF task_cpu THEN
          pmp$get_task_cp_time (task_cp_time, local_status);
        ELSEIF task_job_cpu THEN
          pmp$get_task_jobmode_statistics (task_jobmode_stats, local_status);
        IFEND;
        IF job_stats THEN
          osp$get_job_stats (FALSE, user_job_stats, local_status);
          IF NOT local_status.normal THEN
            EXIT /local_status_control/;
          IFEND;
        IFEND;

{ Store requested statistics in the callers array.

        FOR i := 1 TO UPPERBOUND (statistic_data_p^) DO
          CASE statistic_data_p^ [i].key OF
          = pmc$jts_job_cpu =
            statistic_data_p^ [i].job_cpu_time := user_job_stats.job_data.cp_time.time_spent_in_job_mode +
                  user_job_stats.job_data.cp_time.time_spent_in_mtr_mode;
          = pmc$jts_job_job_cpu =
            statistic_data_p^ [i].job_job_cpu_time := user_job_stats.job_data.cp_time.time_spent_in_job_mode;
          = pmc$jts_job_monitor_cpu =
            statistic_data_p^ [i].job_monitor_cpu_time := user_job_stats.job_data.cp_time.
                  time_spent_in_mtr_mode;
          = pmc$jts_null_statistic =
            ;
          = pmc$jts_paging_statistics =
            statistic_data_p^ [i].paging_statistics.page_in_count :=
                  user_job_stats.job_data.paging_statistics.page_in_count;
            statistic_data_p^ [i].paging_statistics.pages_reclaimed_from_queue :=
                  user_job_stats.job_data.paging_statistics.pages_reclaimed_from_queue;
            statistic_data_p^ [i].paging_statistics.new_pages_assigned :=
                  user_job_stats.job_data.paging_statistics.new_pages_assigned;
            statistic_data_p^ [i].paging_statistics.pages_from_server :=
                  user_job_stats.job_data.paging_statistics.pages_from_server;
            statistic_data_p^ [i].paging_statistics.page_fault_count :=
                  user_job_stats.job_data.paging_statistics.page_fault_count;
            statistic_data_p^ [i].paging_statistics.working_set_max_used :=
                  user_job_stats.job_data.paging_statistics.working_set_max_used;
          = pmc$jts_ready_task_count =
            statistic_data_p^ [i].ready_task_count := user_job_stats.job_data.ready_task_count;
          = pmc$jts_task_cpu =
            statistic_data_p^ [i].task_cpu_time := task_cp_time.task_time + task_cp_time.monitor_time;
          = pmc$jts_task_job_cpu =
            IF task_cpu THEN
              statistic_data_p^ [i].task_job_cpu_time := task_cp_time.task_time;
            ELSE
              statistic_data_p^ [i].task_job_cpu_time := task_jobmode_stats.jobmode_cptime;
            IFEND;
          = pmc$jts_task_monitor_cpu =
            statistic_data_p^ [i].task_monitor_cpu_time := task_cp_time.monitor_time;
          = pmc$jts_working_set_size =
            statistic_data_p^ [i].working_set_size := user_job_stats.job_data.working_set_size;
          ELSE;
          CASEND;
        FOREND;
      END /local_status_control/;
      osp$copy_local_status_to_status (local_status, status);
    IFEND;

    #KEYPOINT (osk$exit, 0, pmk$get_job_task_statistics);
  PROCEND pmp$get_job_task_statistics;

MODEND pmm$get_job_task_statistics;

*DECK DECK=PMM$GET_UNIQUE_NAME EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Program Services : Unique Name Management' ??
MODULE pmm$get_unique_name;

{ Purpose:  This module contains the procedures to generate and manipulate
{           Unique SCL compatible names.

{ Design:   For generation of names, first generate a binary unique name and
{           then convert it to an SCL compatible form.


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_paged_literal
*copyc ost$binary_unique_name
*copyc ost$name
*copyc ost$status
*copyc ost$string
*copyc pmc$program_management_id
*copyc pme$program_services_exceptions
*copyc pmk$keypoints
*copyc pmt$processor_serial_number
?? POP ??
*copyc osp$generate_unique_binary_name
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    pmt_unique_name = record
      case boolean of
      = TRUE =
        value: ost$name,
      = FALSE =
        dollar_sign: string (1),
        sequence_number: string (7),
        processor_model_number: string (2),
        s: string (1),
        processor_serial_number: string (pmc$processor_serial_num_size),
        d: string (1),
        year: string (4),
        month: string (2),
        day: string (2),
        t: string (1),
        hour: string (2),
        minute: string (2),
        second: string (2),
      casend,
    recend,

    pmt_conversion_mask = record
      case boolean of
      = TRUE =
        integer_value: ost$processor_serial_number,
      = FALSE =
        bcd_value: packed array [1 .. pmc$processor_serial_num_size] of 0 .. 0f(16),
      casend,
    recend;

  VAR
    digits: [STATIC, READ, oss$mainframe_paged_literal] array [0 .. 15] of char := ['0', '1', '2', '3', '4',
          '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'];

  { Unique names are translated using the following string in order to simplify
  { validation and conversion.  The plus character is used for all non-printable
  { characters to make specification of the string easier. Any character that
  { does not appear in valid unique names could be used.  Decimal digits and
  { both upper and lower case hex digits are mapped to their integer value.  All
  { other lower case alphabetic characters are mapped to their upper case
  { equivalent.
  {
  { Validation is performed by comparing each character of the translated
  { version of the unique name string with the corresponding character of the
  { following pattern string.  For pattern characters with integer values of
  { 128 - 255, the unique name character must be less than or equal to the
  { pattern character - 128.  For all other pattern character values, the
  { unique name character must equal the pattern character.

  CONST
    dec = $CHAR (9 + 128),
    hex = $CHAR (15 + 128);

?? FMT (FORMAT := OFF) ??
  VAR
    name_translator: [STATIC, READ, oss$mainframe_paged_literal] string (256) :=
          '++++++++++++++++++++++++++++++++' CAT
          ' !"#$%&''()*+,-./' CAT
          $CHAR (00) CAT $CHAR (01) CAT $CHAR (02) CAT $CHAR (03) CAT $CHAR (04) CAT
          $CHAR (05) CAT $CHAR (06) CAT $CHAR (07) CAT $CHAR (08) CAT $CHAR (09) CAT
          ':;<=>?@' CAT
          $CHAR (10) CAT $CHAR (11) CAT $CHAR (12) CAT $CHAR (13) CAT $CHAR (14) CAT
          $CHAR (15) CAT 'GHIJKLMNOPQRSTUVWXYZ' CAT
          '[\]^_`' CAT
          $CHAR (10) CAT $CHAR (11) CAT $CHAR (12) CAT $CHAR (13) CAT $CHAR (14) CAT
          $CHAR (15) CAT 'GHIJKLMNOPQRSTUVWXYZ' CAT
          '{|}~+' CAT
          '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++' CAT
          '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++',

    name_pattern: [STATIC, READ, oss$mainframe_paged_literal] ost$name :=
      { $               }  '$' CAT
      { sequence number }  dec CAT dec CAT dec CAT dec CAT dec CAT dec CAT dec CAT
      { model number    }  hex CAT hex CAT
      { S               }  'S' CAT
      { serial number   }  dec CAT dec CAT dec CAT dec CAT
      { D (hex digit)   }  $CHAR (0d(16)) CAT
      { date            }  dec CAT dec CAT dec CAT dec CAT dec CAT dec CAT dec CAT dec CAT
      { T               }  'T' CAT
      { time            }  dec CAT dec CAT dec CAT dec CAT dec CAT dec;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
?? NEWTITLE := '[INLINE, XDCL, #GATE] pmp$convert_binary_unique_name', EJECT ??
*copyc pmh$convert_binary_unique_name

  PROCEDURE [INLINE, XDCL, #GATE] pmp$convert_binary_unique_name
    (    binary_name: ost$binary_unique_name;
     VAR name: ost$name;
     VAR status: ost$status);


    VAR
      number: integer,
      index: ost$string_index,
      converter: pmt_conversion_mask,
      generated_name: pmt_unique_name;

    status.normal := TRUE;

    generated_name.dollar_sign := '$';

    number := binary_name.sequence_number;
    FOR index := STRLENGTH (generated_name.sequence_number) DOWNTO 1 DO
      generated_name.sequence_number (index) := digits [number MOD 10];
      number := number DIV 10;
    FOREND;

    generated_name.processor_model_number (1) := digits [binary_name.model_number DIV 16];
    generated_name.processor_model_number (2) := digits [binary_name.model_number MOD 16];

    generated_name.s := 'S';

    converter.integer_value := binary_name.serial_number;
    FOR index := 1 TO pmc$processor_serial_num_size DO
      generated_name.processor_serial_number (index) := digits [converter.bcd_value [index]];
    FOREND;

    generated_name.d := 'D';

    number := binary_name.year;
    FOR index := STRLENGTH (generated_name.year) DOWNTO 1 DO
      generated_name.year (index) := digits [number MOD 10];
      number := number DIV 10;
    FOREND;

    generated_name.month (1) := digits [binary_name.month DIV 10];
    generated_name.month (2) := digits [binary_name.month MOD 10];

    generated_name.day (1) := digits [binary_name.day DIV 10];
    generated_name.day (2) := digits [binary_name.day MOD 10];

    generated_name.t := 'T';

    generated_name.hour (1) := digits [binary_name.hour DIV 10];
    generated_name.hour (2) := digits [binary_name.hour MOD 10];

    generated_name.minute (1) := digits [binary_name.minute DIV 10];
    generated_name.minute (2) := digits [binary_name.minute MOD 10];

    generated_name.second (1) := digits [binary_name.second DIV 10];
    generated_name.second (2) := digits [binary_name.second MOD 10];

    name := generated_name.value;
  PROCEND pmp$convert_binary_unique_name;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$convert_unique_to_binary', EJECT ??
*copyc pmh$convert_unique_to_binary

  PROCEDURE [XDCL, #GATE] pmp$convert_unique_to_binary
    (    name: ost$name;
     VAR binary_unique_name: ost$binary_unique_name;
     VAR status: ost$status);

    VAR
      converter: pmt_conversion_mask,
      index: ost$string_index,
      number: integer,
      pattern: char,
      unique: char,
      unique_name: pmt_unique_name;

    status.normal := TRUE;

    #TRANSLATE (name_translator, name, unique_name.value);

    FOR index := 1 TO STRLENGTH (unique_name.value) DO
      unique := unique_name.value (index);
      pattern := name_pattern (index);
      IF (unique <> pattern) AND ((pattern < $CHAR (128)) OR (unique > $CHAR ($INTEGER (pattern) - 128))) THEN
        osp$set_status_abnormal (pmc$program_management_id, pme$invalid_unique_name, name, status);
        RETURN;
      IFEND;
    FOREND;

    binary_unique_name.sequence_number := 0;
    FOR index := 1 TO STRLENGTH (unique_name.sequence_number) DO
      binary_unique_name.sequence_number := 10 * binary_unique_name.sequence_number +
            $INTEGER (unique_name.sequence_number (index));
    FOREND;

    binary_unique_name.model_number := 16 * $INTEGER (unique_name.processor_model_number (1)) +
          $INTEGER (unique_name.processor_model_number (2));

    FOR index := 1 TO pmc$processor_serial_num_size DO
      converter.bcd_value [index] := $INTEGER (unique_name.processor_serial_number (index));
    FOREND;
    binary_unique_name.serial_number := converter.integer_value;

    number := 0;
    FOR index := 1 TO STRLENGTH (unique_name.year) DO
      number := 10 * number + $INTEGER (unique_name.year (index));
    FOREND;
    binary_unique_name.year := number;

    binary_unique_name.month := 10 * $INTEGER (unique_name.month (1)) + $INTEGER (unique_name.month (2));

    binary_unique_name.day := 10 * $INTEGER (unique_name.day (1)) + $INTEGER (unique_name.day (2));

    binary_unique_name.hour := 10 * $INTEGER (unique_name.hour (1)) + $INTEGER (unique_name.hour (2));

    binary_unique_name.minute := 10 * $INTEGER (unique_name.minute (1)) + $INTEGER (unique_name.minute (2));

    binary_unique_name.second := 10 * $INTEGER (unique_name.second (1)) + $INTEGER (unique_name.second (2));

    binary_unique_name.fill := 0;

  PROCEND pmp$convert_unique_to_binary;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$generate_unique_name', EJECT ??
*copyc pmh$generate_unique_name

  PROCEDURE [XDCL, #GATE] pmp$generate_unique_name
    (VAR name: ost$unique_name;
     VAR status: ost$status);

    VAR
      binary_name: ost$binary_unique_name,
      local_status: ost$status;

    status.normal := TRUE;

    #KEYPOINT (osk$entry, 0, pmk$generate_unique_name);

{ pmp$get_unique_name is inline so a call is not performed

    pmp$get_unique_name (name.value, status);

    #KEYPOINT (osk$exit, 0, pmk$generate_unique_name);
  PROCEND pmp$generate_unique_name;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE, XDCL, #GATE] pmp$get_unique_name', EJECT ??
*copyc pmh$get_unique_name

  PROCEDURE [INLINE, XDCL, #GATE] pmp$get_unique_name
    (VAR name: ost$name;
     VAR status: ost$status);

    VAR
      binary_name: ost$binary_unique_name,
      local_status: ost$status;

    #KEYPOINT (osk$entry, 0, pmk$get_unique_name);

    status.normal := TRUE;

    osp$generate_unique_binary_name (binary_name, local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      #KEYPOINT (osk$exit, 0, pmk$get_unique_name);
      RETURN;
    IFEND;

    pmp$convert_binary_unique_name (binary_name, name, status);

    #KEYPOINT (osk$exit, 0, pmk$get_unique_name);

  PROCEND pmp$get_unique_name;
?? OLDTITLE ??
MODEND pmm$get_unique_name;
*DECK DECK=PMM$INHIBIT_TASK_TERMINATION EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Program Management : Inhibit Task Termination' ??
MODULE pmm$inhibit_task_termination;

{ PURPOSE:
{   This module contains routines callable only from ring 4.  These routines
{   are used to prevent the task from unexpectedly terminating when in a
{   critical section.  The routines are specifically made for use by AAM which
{   has its critical section in ring 4.
{
{ DESIGN:
{   pmp$push_inhibit_termination causes a counter to be incremented.  When this
{   counter is greater then zero, task termination will be "stacked" until the
{   counter returns to zero.  pmp$pop_inhibit_termination causes the counter to
{   be decremented.  If it causes the counter to return to zero, the task will
{   be terminated at this point if a terminate request had been stacked.
{   pmp$terminated_while_inhibited is a function which returns true if a
{   terminate request has been stacked.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc ost$caller_identifier
*copyc ost$stack_frame_save_area
*copyc pme$condition_exceptions
*copyc pme$execution_exceptions
*copyc pme$insufficient_privilege
*copyc pme$pop_inhibit_caused_term
*copyc pme$push_inhibit_too_deep
*copyc pmt$minimum_save_area
*copyc pmt$task_term_inhibit_count
*copyc pmk$keypoints
?? POP ??
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$executing_in_job_monitor
*copyc osp$generate_log_message
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc pmp$abort
*copyc pmp$apd_call_to_users_procedure
*copyc pmp$continue_to_cause
*copyc pmp$validate_previous_save_area
*copyc pmv$debug_logging_enabled
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    pmv$task_term_inhibit_count: [XDCL, oss$task_private]
          pmt$task_term_inhibit_count := 0,
    pmv$task_termination_attempted: [XDCL, oss$task_private] boolean := FALSE;

  TYPE
    p_address = packed record
      filler: 0 .. 0fffff(16),
      seg_offset: 0 .. 0fffffffffff(16),
    recend,

    pointer_to_procedure = record
      case dummy: 0 .. 1 of
      = 0 =
        procedure_pointer: ^procedure,
      = 1 =
        cbp: ^p_address,
      casend,
    recend;

  VAR
    apd_call_to_users_procedure: [STATIC, READ, oss$job_paged_literal]
          pointer_to_procedure := [0, ^pmp$apd_call_to_users_procedure];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE]  pmp$pop_inhibit_termination', EJECT ??
*copy pmh$pop_inhibit_termination

  PROCEDURE [XDCL, #GATE] pmp$pop_inhibit_termination;


    VAR
      current_a2: ^cell,
      frame: ^ost$stack_frame_save_area,
      local_status: ost$status,
      log_status: ^ost$status,
      stack_frame_word_p: ^pmt$os_stack_frame_word,
      psa: ^ost$stack_frame_save_area; {previous_save_area}

    #keypoint (osk$entry, 0, pmk$pop_inhibit_termination);
    IF pmv$task_term_inhibit_count > 0 THEN
      pmv$task_term_inhibit_count := pmv$task_term_inhibit_count - 1;
      IF pmv$task_term_inhibit_count = 0 THEN
        frame := #PREVIOUS_SAVE_AREA ();

        stack_frame_word_p := frame^.minimum_save_area.a1_current_stack_frame;

      /find_establishing_frame/
        WHILE NOT ((#RING (frame) = osc$sj_ring_1) AND
              frame^.minimum_save_area.frame_descriptor.on_condition_flag AND
              frame^.minimum_save_area.frame_descriptor.critical_frame_flag AND
              stack_frame_word_p^.terminate_inhibit_frame) DO
          psa := frame^.minimum_save_area.a2_previous_save_area;
          current_a2 := frame^.minimum_save_area.a2_previous_save_area;
          IF (psa = NIL) OR (#RING (psa) > osc$sj_ring_1) THEN
            frame := NIL;
            EXIT /find_establishing_frame/;
          ELSEIF (((psa^.minimum_save_area.a2_previous_save_area = NIL) OR
                ((#OFFSET (psa^.minimum_save_area.a2_previous_save_area) >=
                0) AND ((#OFFSET (psa^.minimum_save_area.
                a2_previous_save_area) MOD 8) = 0))) AND
                (current_a2 = psa^.minimum_save_area.
                a0_dynamic_space_pointer) AND (psa^.minimum_save_area.
                frame_descriptor.a_terminating > 1)) THEN
            frame := psa;
          ELSE
            osp$set_status_condition (pme$inconsistent_stack, local_status);
            #keypoint (osk$exit, 0, pmk$pop_inhibit_termination);
            pmp$abort (local_status);
          IFEND;
          stack_frame_word_p := frame^.minimum_save_area.
                a1_current_stack_frame;
        WHILEND /find_establishing_frame/;

        IF frame <> NIL THEN
          stack_frame_word_p^.terminate_inhibit_frame := FALSE;
          frame^.minimum_save_area.frame_descriptor.critical_frame_flag :=
                stack_frame_word_p^.block_exit_frame OR
                stack_frame_word_p^.debug_cff_frame OR
                (stack_frame_word_p^.ada_critical_frame AND
                (stack_frame_word_p^.ada_critical_frame_count <> 0));
        IFEND;

        IF pmv$task_termination_attempted THEN
          IF pmv$debug_logging_enabled THEN
            osp$set_status_condition (pme$pop_inhibit_caused_term,
                  local_status);
            PUSH log_status;
            osp$generate_log_message ($pmt$ascii_logset
                  [pmc$system_log, pmc$job_log], local_status, log_status^);
          IFEND;
          pmv$task_termination_attempted := FALSE;
          osp$set_status_condition (pme$terminated_by_parent, local_status);
          #keypoint (osk$exit, 0, pmk$pop_inhibit_termination);
          pmp$abort (local_status);
        IFEND;
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, pmk$pop_inhibit_termination);
  PROCEND pmp$pop_inhibit_termination;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE]  pmp$push_inhibit_termination', EJECT ??
*copy pmh$push_inhibit_termination

  PROCEDURE [XDCL, #GATE] pmp$push_inhibit_termination;

    VAR
      caller_id: ost$caller_identifier,
      current_a2: ^cell,
      frame: ^ost$stack_frame_save_area,
      local_status: ost$status,
      stack_frame_word_p: ^pmt$os_stack_frame_word,
      p: ^p_address,
      psa: ^ost$stack_frame_save_area; {previous_save_area}

    #keypoint (osk$entry, 0, pmk$push_inhibit_termination);
    IF osp$executing_in_job_monitor () THEN
      #keypoint (osk$exit, 0, pmk$push_inhibit_termination);
      RETURN;
    IFEND;
    #CALLER_ID (caller_id);
    IF caller_id.ring <> osc$sj_ring_1 THEN
      osp$set_status_condition (pme$insufficient_privilege, local_status);
      #keypoint (osk$exit, 0, pmk$push_inhibit_termination);
      pmp$abort (local_status);
    IFEND;
    IF pmv$task_term_inhibit_count = pmc$max_task_term_inhibits THEN
      osp$set_status_condition (pme$push_inhibit_too_deep, local_status);
      #keypoint (osk$exit, 0, pmk$push_inhibit_termination);
      pmp$abort (local_status);
    ELSEIF pmv$task_term_inhibit_count = 0 THEN

      frame := #PREVIOUS_SAVE_AREA ();

      p := #LOC (frame);
      WHILE (#RING (frame) < osc$sj_ring_1) OR
            (p^.seg_offset = apd_call_to_users_procedure.cbp^.seg_offset) DO
        psa := frame^.minimum_save_area.a2_previous_save_area;
        current_a2 := frame^.minimum_save_area.a2_previous_save_area;
        IF NOT (((psa^.minimum_save_area.a2_previous_save_area = NIL) OR
              ((#OFFSET (psa^.minimum_save_area.a2_previous_save_area) >=
              0) AND ((#OFFSET (psa^.minimum_save_area.
              a2_previous_save_area) MOD 8) = 0))) AND
              (current_a2 = psa^.minimum_save_area.
              a0_dynamic_space_pointer) AND (psa^.minimum_save_area.
              frame_descriptor.a_terminating > 1)) THEN
          osp$set_status_condition (pme$inconsistent_stack, local_status);
          #keypoint (osk$exit, 0, pmk$push_inhibit_termination);
          pmp$abort (local_status);
        IFEND;
        frame := psa;
        p := #LOC (frame);
      WHILEND;

      stack_frame_word_p := frame^.minimum_save_area.a1_current_stack_frame;
      IF NOT frame^.minimum_save_area.frame_descriptor.on_condition_flag THEN
        stack_frame_word_p^.block_exit_frame := FALSE;
        stack_frame_word_p^.debug_cff_frame := FALSE;
        stack_frame_word_p^.ada_critical_frame := FALSE;
        stack_frame_word_p^.ada_critical_frame_count := 0;
        stack_frame_word_p^.established_handler := NIL;
      IFEND;

      frame^.minimum_save_area.frame_descriptor.critical_frame_flag := TRUE;
      stack_frame_word_p^.terminate_inhibit_frame := TRUE;
      frame^.minimum_save_area.frame_descriptor.on_condition_flag := TRUE;
    IFEND;
    pmv$task_term_inhibit_count := pmv$task_term_inhibit_count + 1;
    #keypoint (osk$exit, 0, pmk$push_inhibit_termination);
  PROCEND pmp$push_inhibit_termination;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE]  pmp$terminated_while_inhibited', EJECT ??
*copy pmh$terminated_while_inhibited

  FUNCTION [XDCL, #GATE] pmp$terminated_while_inhibited: boolean;

    VAR
      caller_id: ost$caller_identifier,
      local_status: ost$status;

    #keypoint (osk$entry, 0, pmk$terminated_while_inhibited);
    #CALLER_ID (caller_id);
    IF caller_id.ring <> osc$sj_ring_1 THEN
      osp$set_status_condition (pme$insufficient_privilege, local_status);
      #keypoint (osk$exit, 0, pmk$terminated_while_inhibited);
      pmp$abort (local_status);
    IFEND;

    pmp$terminated_while_inhibited := pmv$task_termination_attempted;
    #keypoint (osk$exit, 0, pmk$terminated_while_inhibited);
  FUNCEND pmp$terminated_while_inhibited;
?? OLDTITLE ??

MODEND pmm$inhibit_task_termination;
*DECK DECK=PMM$INTERCEPT_PROCEDURES EXPAND=TRUE

.
.     APD assembly modules which intercept procedures between caller
.     and callee.
.
.
PMM$INTERCEPT_PROCEDURES      IDENT
.
               def            pmp$initial_intercept_procedure
               def            pmp$intercept_call_procedure
               def            record_trapped_block_exit
               def            clean_up_condition_handler
               def            pmp$apd_call_to_users_procedure
               defg           pmp$simulate_call_overhead
               defg           pmp$simulate_return_overhead
.
.
.     external cybil procedure references
.
               ref            osv$default_block_exit_desc
               ref            pmp$open_new_interblock_segment
               ref            pmp$get_apd_task_jobmode_stats
               ref            process_block_exits
               ref            process_exit_from_apd
.
.
.     set up binding section for external procedures
.
.
                    use               binding
.
ptr_block_exit_desc address           p,osv$default_block_exit_desc
ptr_open_new_seg    address           ce,pmp$open_new_interblock_segment
ptr_get_job_stats   address           ce,pmp$get_apd_task_jobmode_stats
ptr_cleanup_handler address           ce,clean_up_condition_handler
ptr_cond_handler    address           ce,record_trapped_block_exit
ptr_proc_block_exit address           ce,process_block_exits
ptr_proc_exit_apd   address           ce,process_exit_from_apd
.
.
                    use               #lastsec
.
.
word_size                       equ       8
est_handler_size                equ      62     . size of pmt$established_handler
interblock_reference_size       set      30     . size of pmt$interblock_reference
.
.     constants for offsets into pmt$loader_seq_descriptor
.
last_interblock_seg_offset      set      95     . .last_interblock_segment offset
accum_intercept_time_offset     set     111     . .accumulated_intercept_time offset
no_of_calls_offset              set     121     . .number_of_intercepted_calls offset
no_of_returns_offset            set     125     . .number_of_intercepted_returns offset
accum_call_time_offset          set     129     . .accum_intercept_call_time offset
accum_return_time_offset        set     135     . .accum_intercept_return_time offset
avg_call_time_offset            set     141     . .average_intercept_call_time offset
avg_return_time_offset          set     147     . .average_intercept_return_time offset
avg_stats_request_time_offset   set     153     . .average_stats_request_time offset
timed_call_overhead_offset      set     159     . .timed_call_intercept_overhead offset
timed_return_overhead_offset    set     165     . .timed_return_intercept_overhead offset
untimed_call_overhead_offset    set     171     . .untimed_call_intercept_overhead offset
untimed_return_overhead_offset  set     177     . .untimed_return_intercept_overhead offset
.
.
.     constants for offsets into pmt$interblock_references_hdr
.
.
no_of_interblock_ref_offset     set       4
.
.
.     constants for offsets into pmt$interblock_reference
.
.
reference_time_offset           set       1
block_id_offset                 set       7
paging_statistics_offset        set      12
.
.
paging_statistics_size          equ      18    . size of pmt$paging_statistics
jobmode_stats_paging_stats      set       8    . offset into pmt$apd_task_jobmode_
.                                                statistics
.
.     constant for maximum number of intercepted calls and returns to be timed
.
maximum_timed_intercepts        vfd,64  5000(10)
.
.     constants for offsets of areas used in the workspace.  Additions may have
.     been made to insure word boundaries.
.
stack_workspace                 set     360
.
ws_callers_x0                   set       8     . size = 8
ws_callers_regs                 set      16     . size = 224
ws_parameter_list               set     240     . size = 8
ws_est_handler                  set     248     . size = 64
ws_jobmode_stats                set     312     . size = 32
ws_save_a3a4                    set     344     . size = 16
.
               title          c'pmp$initial_intercept_procedure'
               align          0,8
.
PMP$INITIAL_INTERCEPT_PROCEDURE   addaq       a0,a0,stack_workspace . save workspace
.
.     save original caller's environment at the top of stack
.
               sx             x0,a1,ws_callers_x0         . save actual callers X0
.
               enta           x0,31ff(16)                 . save registers from actual
.                                                           caller which are used by
.                                                           this intercept procedure;
.                                                           registers A3 - AF
.                                                           registers X1 - XF
               smult          x0,a1,ws_callers_regs
.
.     change A3 to point to the intercept procedures binding section
.
               addaq          a3,a3,2*word_size
               la             a5,a3,2                     . A5 = Binding section ptr
.
.     establish block exit condition handler
.
               addaq          a6,a1,ws_est_handler        . get ptr to established_handler
               la             a8,a5,ptr_block_exit_desc   . get ptr to osv$default_
.                                                           block_exit_desc
               movb,a8,x0 a6,x1 0,9,est_handler_size,0 0,9,est_handler_size,0
.
.     pmt$established_handler.handler
.
               addaq          a8,a5,ptr_cleanup_handler
               sa             a8,a6,7
.
.     Store pointer to loader_seq_descriptor in static link of pointer to procedure
.
               addaq          a8,a3,word_size*2+2
               la             a7,a8,0                     . A7 = pointer to loader
.                                                           _seq_descriptor
               sa             a7,a6,13
.
.     store stack frame word (pmt$os_stack_frame_word) at A1
.
               sa             a6,a1,0                     . pointer to
.                                                           pmt$established_handler
               ente           x2,4000(16)                 . block_exit_frame = TRUE
               sbyts,2        x2,a1,x0,6                  . debug_cff_frame = FALSE
.                                                           ada_critical_frame = FALSE
.                                                           ada_critical_frame_count=0
.
.     set critical_frame_flag
.
               ente           x2,0e1(16)
               cpyxs          x2,x2
.
.     set on_condition_flag
.
               ente           x2,0e3(16)
               cpyxs          x2,x2
.
.     restore original callers environment except registers A0, A1, and A2
.
               enta           x0,31ff(16)
               lmult          x0,a1,ws_callers_regs
.
               lx             x0,a1,ws_callers_x0         . restore original X0
.
               callseg        0,a3,a4
               return
.
               title          c'pmp$intercept_call_procedure'
.
. PURPOSE:
.   The purpose of this request is to intercept a program call from an
.   instrumented task and record the reference times and page statistics for
.   the callee in the interblock_reference file.  This information is recorded
.   at the points of call and return for the callee.
. DESIGN:
.   The accumulated time spent processing all call and return intercepts is
.   subtracted from the reference times for the callee before they are recorded
.   in the file.  This sequence of times approximates the actual reference
.   times for standalone execution of the instrumented task.  The time spent
.   processing call and return intercepts is monitored for a count of
.   maximum_timed_intercepts and the average values are used for subsequent
.   calls and returns.  There is no adjustment to the page statistics for
.   page faults due to accessing the interblock_reference file.
. NOTES:
.   Instructions that cannot be timed in this procedure are estimated prior to
.   execution of an instrumented task and stored in the loader_seq_descriptor
.   file for access by this procedure.  Any modifications to the procedure calls
.   that obtain the task jobmode statistics or code outside the pairs of these
.   calls may require similar modifications to the procedure that initializes
.   the intercept variables in pmm$analyze_program_dynamics.
.   The tag, pmp$apd_call_to_users_procedure, in this procedure functions as an
.   entry point and must always be aligned on a word boundary.  Check this on an
.   assembly listing after making any changes to the code preceding this tag
.   and adjust the padding instructions preceding the tag if necessary.
.
.
               align          0,8
.
. NOTE: start of code simulated in pmp$simulate_return_overhead procedure
.
PMP$INTERCEPT_CALL_PROCEDURE   addaq        a0,a0,stack_workspace . save workspace
.
.     save original caller's environment at the top of stack
.
               sx             x0,a1,ws_callers_x0         . save actual callers X0
               enta           x0,31ff(16)                 . save registers from actual
.                                                           caller which are used by
.                                                           this intercept procedure;
.                                                           registers A3 - AF
.                                                           registers X1 - XF
               smult          x0,a1,ws_callers_regs       . store A and X registers
.                                                           in stack
.
.     change A3 to point to the intercept procedures binding section
.
               addaq          a3,a3,2*word_size
               la             a5,a3,2                     . A5 = Binding section ptr
               addaq          a4,a1,ws_parameter_list     . get ptr to parameter
.                                                           list
.
. NOTE: end of code simulated in pmp$simulate_return_overhead procedure
.
.
.     set up parameter list for call to pmp$get_apd_task_jobmode_stats
.
.     pmt$apd_task_jobmode_statistics
.
               addaq          a6,a1,ws_jobmode_stats      . get ptr to jobmode_stats
               sa             a6,a4,0                     . in parameter list
               enta           x0,050(16)                  . save registers A0 - A5
.                                                           on call to pmp$get_apd_
.                                                           task_jobmode_statistics
               callseg        ptr_get_job_stats,a5,a4
.
.     establish block exit condition handler
.
               addaq          a6,a1,ws_est_handler        . get ptr to pmt$established_handler
               la             a8,a5,ptr_block_exit_desc   . get ptr to osv$default_
.                                                           block_exit_desc
               movb,a8,x0 a6,x1 0,9,est_handler_size,0 0,9,est_handler_size,0
.
.     pmt$established_handler.handler
.
               addaq          a8,a5,ptr_cond_handler
               sa             a8,a6,7
.
.     Store pointer to loader_seq_descriptor in static link of pointer to procedure
.
               addaq          a8,a3,word_size*2+2
               la             a7,a8,0                     . A7 = pointer to loader
.                                                           _seq_descriptor
               sa             a7,a6,13
.
.     store stack frame word (pmt$os_stack_frame_word) at A1
.
               sa             a6,a1,0                     . pointer to
.                                                           pmt$established_handler
               ente           x2,4000(16)                 . block_exit_frame = TRUE
               sbyts,2        x2,a1,x0,6                  . debug_cff_frame = FALSE
.                                                           ada_critical_frame = FALSE
.                                                           ada_critical_frame_count=0
.
.     set critical_frame_flag
.
               ente           x2,0e1(16)
               cpyxs          x2,x2
.
.     set on_condition_flag
.
               ente           x2,0e3(16)
               cpyxs          x2,x2
.
.     Allocate an interblock_reference (pmt$interblock_reference) and
.     record_intercepted_call
.
.     'NEXT' an interblock_reference into the loader_seq_descriptor
.
               la             a6,a7,last_interblock_seg_offset . A6 = ptr to current
.                                                           interblock_references_hdr
               lbyts,8        x2,a7,x0,6+last_interblock_seg_offset . get upper_limit
.                                                           and offset of interblock
.                                                           _references
               addxq          x3,x2,interblock_reference_size . increment offset by
.                                                           size of pmt$interblock_
.                                                           reference
               shfx           x4,x2,x0,-32                . get max segment length
               brrge          x4,x3,update_seq_ptr        . check for size greater
.                                                           than max segment length
.
.     Segment would overflow if interblock_reference is added to it.
.     Instead, open a new segment for more interblock references.
.
.     Set up call to PMP$OPEN_NEW_INTERBLOCK_SEGMENT
.
               sa             a7,a4,0                     . Store ptr to loader_seq_
.                                                           descriptor in parameter_
.                                                           list
               enta           x0,070(16)                  . Save registers A0 - A7
               callseg        ptr_open_new_seg,a5,a4      . on call to pmp$open_new
.                                                           _interblock_segment
.
               la             a6,a7,last_interblock_seg_offset . A6 = ptr to current
.                                                           interblock_references_hdr
               lbyts,4        x2,a7,x0,10+last_interblock_seg_offset . get offset of
.                                                           interblock_references
               addxq          x3,x2,interblock_reference_size . increment offset by
.                                                           size of pmt$interblock_
.                                                           reference
.
update_seq_ptr sbyts,4        x3,a7,x0,10+last_interblock_seg_offset . update offset
.                                                           in adaptable sequence
.                                                           pointer
               cpyaa          a8,a6                       . A8= ptr to pmt$interblock
               addax          a8,x2                       . _reference
.
.     update loader_seq_descriptor.number_of_interblock_references
.
               lbyts,4        x2,a6,x0,no_of_interblock_ref_offset . A7 points to
.                                                           interblock_references_hdr
               incx           x2,1
               sbyts,4        x2,a6,x0,no_of_interblock_ref_offset
.
.     fill in fields of interblock_reference
.
.     pmt$reference_type
.
               entp           x2,0                        . reference_type = pmc$call
               sbyts,1        x2,a8,x0,0                  . A8 - points to interblock
.                                                           _reference
.     pmt$block_identifier
.
               addaq          a9,a3,word_size             . get block_id from binding
.                                                           section entry
               lbyts,5        x2,a9,x0,3
               sbyts,5        x2,a8,x0,block_id_offset    . put in interblock_reference
.
.     fill in interblock_reference.reference_time
.
               lbyts,6        x2,a7,x0,accum_intercept_time_offset
               addaq          a9,a1,ws_jobmode_stats      . access job statistics
               lbyts,8        x3,a9,x0,0                  . pick up current_cptime
               subx           x3,x2                       . X2 has accumulate_
.                                                           intercept_time (current_
.                                                           cptime - accumulated_
.                                                           intercept_time)
               sbyts,6        x3,a8,x0,reference_time_offset   . store reference_time
.                                                           in interblock_reference
.
.     Move paging statistics from jobmode_stats to the interblock reference.
.
               addaq          aa,a9,jobmode_stats_paging_stats
               addaq          ab,a8,paging_statistics_offset
               movb,aa,x0 ab,x1 0,9,paging_statistics_size,0 0,9,paging_statistics_size,0
.
.     check if this intercepted call is to be timed
.
               lbyts,4        x3,a7,x0,no_of_calls_offset . current number of calls
               lbytp,8        x2,maximum_timed_intercepts . threshhold for timed calls
               brxge          x3,x2,add_avg_call          . if call is not to be timed
               incx           x3,1                        . increment number of calls
               sbyts,4        x3,a7,x0,no_of_calls_offset
               subx           x2,x3                       . (threshhold - current)
.
.     save initial intercept cptime value in X3
.
               lbyts,8        x3,a9,x0,0                  . X3 = initial jobmode_cptime
.
.     set up parameter list for call to pmp$get_apd_task_jobmode_stats
.
.     pmt$apd_task_jobmode_statistics
.
               sa             a9,a4,0                     . store jobmode statistics
.                                                           in parameter list
               ente           x0,093(16)                  . save A0 - A9, X0 - X3
               callseg        ptr_get_job_stats,a5,a4
.
.     calculate and update loader_seq_descriptor.accumulated_intercept_time for
.     a timed call
.
.     accumulated_intercept_time = accumulated_intercept_time +
.           timed_call_overhead + (current cptime - initial cptime)
.
.     get current cptime value
.
               lbyts,8        x4,a9,x0,0                  . get current jobmode_cptime
               subx           x4,x3                       . (current cptime - initial
.                                                           cptime)
.     get timed_call_overhead for a timed call
.
               lbyts,6        x3,a7,x0,timed_call_overhead_offset
               addx           x3,x4
.
.     get accumulated_intercept_time value
.
               lbyts,6        x5,a7,x0,accum_intercept_time_offset
               addx           x3,x5                       . calculate new accumulated_
.                                                           intercept_time
               sbyts,6        x3,a7,x0,accum_intercept_time_offset
.
.     calculate and update loader_seq_descriptor.accum_intercept_call_time for
.     intercepted calls
.
.     accum_intercept_call_time = accum_intercept_call_time +
.           untimed_call_overhead + (current cptime - initial cptime)
.
.     get untimed_call_overhead for an intercepted call
.
               lbyts,6        x3,a7,x0,untimed_call_overhead_offset
               addx           x4,x3
.
.     update the accum_intercept_call_time
.
               lbyts,6        x5,a7,x0,accum_call_time_offset
               addx           x4,x5
               sbyts,6        x4,a7,x0,accum_call_time_offset
               brxne          x0,x2,save_registers        . if not last call to time
.
.     calculate the average_intercept_call_time required to process an intercepted call
.     which will be used as the estimate for all subsequent untimed calls
.
.     average_intercept_call_time = ((accum_intercept_call_time +
.           .5 * maximum_timed_intercepts ) / maximum_timed_intercepts ) -
.           average_stats_request_time
.
               lbytp,8        x3,maximum_timed_intercepts . maximum_timed_intercepts
               shfx           x5,x3,x0,-1                 . .5 * maximum_timed_intercepts
               addx           x4,x5
               divx           x4,x3
               lbyts,6        x2,a7,x0,avg_stats_request_time_offset
               subx           x4,x2
.
               sbyts,6        x4,a7,x0,avg_call_time_offset
               brxeq          x0,x0,save_registers        . continue processing
.
.     update the loader_seq_descriptor.accumulated_intercept_time for an untimed call
.     using the average_intercept_call_time value
.
.     accumulated_intercept_time = accumulated_intercept_time +
.           average_intercept_call_time
.
add_avg_call   lbyts,6        x2,a7,x0,avg_call_time_offset
               lbyts,6        x3,a7,x0,accum_intercept_time_offset
               addx           x2,x3
               sbyts,6        x2,a7,x0,accum_intercept_time_offset
.
. NOTE: start of code simulated in pmp$simulate_call_overhead procedure
.
.     save intercept_call_procedures's A3 and A4 registers
.
save_registers enta           x0,3040(16)
               smult          x0,a1,ws_save_a3a4
.
.     restore original callers environment except registers A0, A1, and A2
.
               enta           x0,31ff(16)
               lmult          x0,a1,ws_callers_regs
.
. ******************************************************************************
. *   insert a no-op to align PMP$APD_CALL_TO_USERS_PROGRAM on a word boundary *
. *   These may have to changed (commented or uncommented) every time this     *
. *   procedure is changed.  Note that instructions must be used for padding   *
. *   instead of the "align" statement because whatever is in the pad will be  *
. *   executed!                                                                *
               addaq          a0,a0,0                     . 4 byte no-op       *
.              cpyxx          x1,x1                       . 2 byte no-op       *
. ******************************************************************************
.
.     call the original callee
.
               lx             x0,a1,ws_callers_x0         . restore orginal X0
               callseg        0,a3,a4
.
. ***************************************************************************
. *   insert a dummy entry point for the condition handling mechanism       *
. *   NOTE: this entry point MUST be word aligned                           *
. *         comment or un-comment the addaq and cpyxx instructions above to *
. *         provide the required padding                                    *
. ***************************************************************************
.
.     save registers again before call to record_intercepted_return
.
pmp$apd_call_to_users_procedure     sx             x0,a1,ws_callers_x0 . save X0
.
               enta           x0,31ff(16)
               smult          x0,a1,ws_callers_regs
.
.     restore intercept_call_procedure's A3 and A4 registers
.
               enta           x0,3040(16)
               lmult          x0,a1,ws_save_a3a4
.
. NOTE: end of code simulated in pmp$simulate_call_overhead procedure
.
.     Allocate an interblock reference (pmt$interblock_reference) and
.     record_intercepted_return
.
.     set up parameter for pmp$get_apd_task_jobmode_stats
.
.     pmt$apd_task_jobmode_statistics
.
               addaq          a8,a1,ws_jobmode_stats      . set A8 pointing to current_
.                                                           jobmode_statistics
               sa             a8,a4,0
               la             a5,a3,2
               ente           x0,050(16)                  . save registers A3 - A5
               callseg        ptr_get_job_stats,a5,a4
.
.     'NEXT' an interblock_reference into the loader_seq_descriptor
.
               addaq          a6,a3,2*word_size+2         . pick up pointer to loader_
.                                                           seq_descriptor
               la             a7,a6,0                     . A7 - address of loader_seq_
.                                                           descriptor
               la             a6,a7,last_interblock_seg_offset . A6 - ptr to current
.                                                           interblock_references_hdr
               lbyts,8        x2,a7,x0,6+last_interblock_seg_offset . pick up upper_
.                                                           limit and offset of
.                                                           interblock_references_hdr
               addxq          x3,x2,interblock_reference_size . increase offset
.                                                           by size of
.                                                           pmt$interblock_reference
               shfx           x4,x2,x0,-32                . get max segment length
               brrge          x4,x3,update_offset         . check for size greater
.                                                           than max segment length
.
.     Segment would overflow if interblock_reference is added to it.
.     Instead, open a new segment for more interblock references.
.
.     Set up call to PMP$OPEN_NEW_INTERBLOCK_SEGMENT
.
               sa             a7,a4,0                     . Store ptr to loader_seq_
.                                                           descriptor in parameter_
.                                                           list
               enta           x0,070(16)                  . Save registers A0 - A7
               callseg        ptr_open_new_seg,a5,a4      . on call to pmp$open_new
.                                                           _interblock_segment
.
               la             a6,a7,last_interblock_seg_offset . A6 = ptr to current
.                                                           interblock_references_hdr
               lbyts,4        x2,a7,x0,10+last_interblock_seg_offset . pick up offset
.                                                           interblock_references seg
               addxq          x3,x2,interblock_reference_size . increment offset by
.                                                           size of pmt$interblock_
.                                                           reference
.
update_offset  sbyts,4        x3,a7,x0,10+last_interblock_seg_offset . update offset
.                                                           in adaptable sequence
.                                                           pointer
.                                                           (.interblock_references)
               cpyaa          a8,a6                       . A8 = address of interblock
               addax          a8,x2                       . reference
.
.     update loader_seq_descriptor.number_of_interblock_references
.
               lbyts,4        x2,a6,x0,no_of_interblock_ref_offset . A7 - address of
.                                                           loader_seq_descriptor
               incx           x2,1
               sbyts,4        x2,a6,x0,no_of_interblock_ref_offset
.
.     fill in fields of interblock_reference
.
.     pmt$reference_type
.
               entp           x2,1                        . reference_type = pmc$return
               sbyts,1        x2,a8,x0,0
.
.     pmt$reference_time
.
.     get current jobmode_cptime
.
               addaq          a9,a1,ws_jobmode_stats
               lbyts,8        x3,a9,x0,0                  . pick up jobmode_cptime
.
.     get loader_seq_descriptor.accumulated_intercept_time
.
               lbyts,6        x2,a7,x0,accum_intercept_time_offset
               subx           x3,x2                       . current.jobmode_cptime -
.                                                           accumulated_intercept_time
               sbyts,6        x3,a8,x0,reference_time_offset
.
.     Move paging statistics from jobmode_stats to the interblock reference.
.
               addaq          aa,a9,jobmode_stats_paging_stats
               addaq          ab,a8,paging_statistics_offset
               movb,aa,x0 ab,x1 0,9,paging_statistics_size,0 0,9,paging_statistics_size,0
.
.     check if this intercepted return is to be timed
.
               lbyts,4        x3,a7,x0,no_of_returns_offset . current number of returns
               lbytp,8        x2,maximum_timed_intercepts . threshhold for timed returns
               brxge          x3,x2,add_avg_return        . if return is not to be timed
               incx           x3,1                        . increment number of returns
               sbyts,4        x3,a7,x0,no_of_returns_offset
               subx           x2,x3                       . (threshhold - current)
.
.     save the initial intercept cptime value
.
               lbyts,8        x3,a9,x0,0                  . initial jobmode_cptime
.
.     set up parameter list for call to pmp$get_apd_task_jobmode_stats
.
.     pmt$apd_task_jobmode_statistics
.
               sa             a9,a4,0
               ente           x0,093(16)                  . save A0 - A9, X0 - X3
               callseg        ptr_get_job_stats,a5,a4
.
.     calculate and update loader_seq_descriptor.accumulated_intercept_time
.     for a timed return
.
.     accumulated_intercept_time = accumulated_intercept_time +
.           timed_return_overhead + (current cptime - initial cptime)
.
.     get current cptime value
.
               lbyts,8        x4,a9,x0,0                  . .jobmode_cptime
               subx           x4,x3                       . (current cptime - initial
.                                                           cptime)
.
.     get timed_return_overhead for a timed return
.
               lbyts,6        x3,a7,x0,timed_return_overhead_offset
               addx           x3,x4
.
.     get accumulated_intercept_time value
.
               lbyts,6        x5,a7,x0,accum_intercept_time_offset
               addx           x3,x5                       . calculate new accumulated_
.                                                           intercept_time
               sbyts,6        x3,a7,x0,accum_intercept_time_offset
.
.     calculate and update loader_seq_descriptor.accum_intercept_return_time for
.     intercepted returns
.
.     accum_intercept_return_time = accum_intercept_return_time +
.           untimed_return_overhead + (current cptime - initial cptime)
.
.     get untimed_return_overhead for an intercepted return
.
               lbyts,6        x3,a7,x0,untimed_return_overhead_offset
               addx           x4,x3
.
.     update the accum_intercept_return_time
.
               lbyts,6        x5,a7,x0,accum_return_time_offset
               addx           x4,x5
               sbyts,6        x4,a7,x0,accum_return_time_offset
               brxne          x0,x2,process_exit          . if not last return to time
.
.     calculate the average_intercept_return_time required to process an intercepted
.     return which will be used as the estimate for all subsequent untimed returns
.
.     average_intercept_return_time = ((accum_intercept_return_time +
.           .5 * maximum_timed_intercepts ) / maximum_timed_intercepts ) -
.           average_stats_request_time
.
               lbytp,8        x3,maximum_timed_intercepts . maximum_timed_intercepts
               shfx           x5,x2,x0,-1                 . .5 * maximum_timed_intercepts
               addx           x4,x5
               divx           x4,x3
               lbyts,6        x2,a7,x0,avg_stats_request_time_offset
               subx           x4,x2
.
               sbyts,6        x4,a7,x0,avg_return_time_offset
               brxeq          x0,x0,process_exit          . continue processing
.
.     update the loader_seq_descriptor.accumulated_intercept_time for an untimed return
.     using the average_intercept_return_time value
.
.     accumulated_intercept_time = accumulated_intercept_time +
.           average_intercept_return_time
.
add_avg_return lbyts,6        x2,a7,x0,avg_return_time_offset
               lbyts,6        x3,a7,x0,accum_intercept_time_offset
               addx           x2,x3
               sbyts,6        x2,a7,x0,accum_intercept_time_offset
.
. NOTE: start of code simulated in pmp$simulate_return_overhead procedure
.
.     disestablish block exit condition handler
.
process_exit   la             a5,a1,0
               ente           x2,0                        . set established to FALSE
               sbyts,1        x2,a5,x0,0
.
               ente           x2,0e0(16)                  . clear critical_frame_flag
               cpyxs          x2,x2
.
.     restore all registers
.
               enta           x0,31ff(16)
               lmult          x0,a1,ws_callers_regs
               lx             x0,a1,ws_callers_x0
.
. NOTE: end of code simulated in pmp$simulate_return_overhead procedure
.
               return
.
               title          c'record_trapped_block_exit'
               align          0,8
.
RECORD_TRAPPED_BLOCK_EXIT     addaq          a0,a0,word_size . 8 bytes reserved for
.                                                           condition handler
               addaq          a6,a4,word_size+2           . get address to
.                                                           pmt$condition_information
               sa             a5,a6,0                     . store pointer to
.                                                           apd_seq_descriptor in
.                                                           pmt$condition_information;
.                                                           seq_ptr in static link
               enta           x0,0ff(16)                  . save all registers for call
.
.    call process_block_exit
.
               callseg        ptr_proc_block_exit,a3,a4
.
               return
.
               title          c'clean_up_condition_handler'
               align          0,8
.
CLEAN_UP_CONDITION_HANDLER      addaq          a0,a0,word_size  . 8 bytes reserved for
.                                                                 condition handler
               addaq          a6,a4,word_size+2           . get address to
.                                                           pmt$condition_information
               sa             a5,a6,0                     . store pointer to
.                                                           apd_seq_descriptor in
.                                                           pmt$condition_information
               enta           x0,0ff(16)                  . save all registers for call
.
.    call process_exit_from_apd
.
               callseg        ptr_proc_exit_apd,a3,a4
.
               return
.
               title          c'pmp$simulate_call_overhead'
.
. PURPOSE:
.   The purpose of this request is to simulate the instructions that save and
.   restore registers after processing a call intercept and before processing
.   a return intercept in pmp$intercept_call_procedure.
. NOTES:
.   Modifications to the above sequence of instructions in
.   pmp$intercept_call_procedure may require modifications to this procedure.
.   The instructions in this procedure are for timing purposes only and do
.   not necessarily produce the same result as the instructions they simulate.
.
               align          0,8
.
PMP$SIMULATE_CALL_OVERHEAD    enta      x0,3040(16)       . simulate save of registers
               smult          x0,a1,ws_save_a3a4
.
               enta           x0,31ff(16)
               smult          x0,a1,ws_callers_regs
.
.     simulate restore of registers
.
               enta           x0,31ff(16)
               lmult          x0,a1,ws_callers_regs
.
               enta           x0,3040(16)
               lmult          x0,a1,ws_save_a3a4
.
               addaq          a0,a0,0                     . alignment no-op
.              cpyxx          x1,x1                       . alignment no-op

               lx             x0,a1,ws_callers_x0         . restore orginal X0
.
               return
.
.
               title          c'pmp$simulate_return_overhead'
.
. PURPOSE:
.   The purpose of this request is to simulate the instructions that save and
.   restore registers before processing a call intercept and after processing
.   a return intercept in pmp$intercept_call_procedure.
. NOTES:
.   Modifications to the above sequence of instructions in
.   pmp$intercept_call_procedure may require modifications to this procedure.
.   The instructions in this procedure are for timing purposes only and do
.   not necessarily produce the same result as the instructions they simulate.
.
               align          0,8
.
PMP$SIMULATE_RETURN_OVERHEAD  addaq       a0,a0,stack_workspace . reserve bytes
.
.    simulate save of registers and other initialization before processing call
.
               sx             x0,a1,ws_callers_x0         . save X0 register
               enta           x0,31ff(16)
               smult          x0,a1,ws_callers_regs
.
               addaq          a6,a3,0
               la             a5,a3,2
               addaq          a5,a5,word_size
.
.    simulate setting of flags and restore of registers after processing a return
.
               la             a5,a3,2
               ente           x2,0
               sbyts,1        x2,a1,x0,0
.
               ente           x2,0e0(16)                  . clear critical_frame_flag
               cpyxx          x3,x2                       . dummy store
.
               enta           x0,31ff(16)
               lmult          x0,a1,ws_callers_regs
               lx             x0,a1,ws_callers_x0         . restore original X0
.
               return
               end
*DECK DECK=PMM$INTERFACE_TO_LOGGING EXPAND=TRUE
?? RIGHT := 110 ??
*copy osd$default_pragmats
?? NEWTITLE := 'NOS/VE Logging' ??
?? NEWTITLE := '  TYPE Declarations' ??
MODULE pmm$interface_to_logging;

{   PURPOSE:
{     This module contains RING 3 procedures and data structures
{     necessary to support Logging.
{
{   DESIGN:
{     This module contains those procedures that are documented
{     in the PROGRAM ERS.

?? PUSH (LISTEXT := ON) ??
*copyc pmd$system_log_interface
*copyc pmd$log_entries
*copyc lgt$log_read_activity
*copyc lgt$entry_info
*copyc pme$logging_exceptions
*copyc pmk$keypoints
*copyc lgk$log_ascii
*copyc pmt$program_parameters
*copyc ost$caller_identifier
?? POP ??

?? TITLE := '  XREF procedures', EJECT ??
{*copy clp$fetch_display_log_indices
{*copy clp$store_display_log_indices
*copy lgp$add_entry_to_ascii_log
*copy osp$set_status_abnormal
?? TITLE := '  pmp$log', EJECT ??
*copy pmh$log

  PROCEDURE [XDCL, #GATE] pmp$log (text: pmt$log_msg_text;
    VAR status: ost$status);

    #keypoint (osk$entry, 0, pmk$log);

    pmp$log_ascii (text, $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_program, status);

    #keypoint (osk$exit, 0, pmk$log);

  PROCEND pmp$log;

?? TITLE := '  PMP$LOG_ASCII', EJECT ??
*copy pmh$log_ascii

  PROCEDURE [INLINE, XDCL, #GATE] pmp$log_ascii (text: pmt$log_msg_text;
        log: pmt$ascii_logset;
        origin: pmt$log_msg_origin;
    VAR status: ost$status);

    VAR
      local_status: ost$status,
      local_text: ^pmt$log_msg_text,
      caller_id: ost$caller_identifier,
      local_log: pmt$ascii_logset;

    #keypoint (osk$entry, osk$m * ORD (origin), lgk$log_ascii);

    status.normal := TRUE;
    local_status.normal := TRUE;
    #caller_id (caller_id);
    PUSH local_text: [STRLENGTH(text)];
    local_text^ := text;

  /log_ascii/
    BEGIN

      local_log := log;

      lgp$add_entry_to_ascii_log (local_log, origin, local_text^, local_status);
      IF NOT local_status.normal THEN
        EXIT /log_ascii/;
      IFEND;

{
{ The following "commented out" code used to be used to assist the
{ DISPLAY_LOG and DISPLAY_SYSTEM_LOG commands to keep track of the
{ last entry placed in the corresponding log.  This function has
{ been moved to the appropriate modules.
{
{     clp$fetch_display_log_indices (indices);
{
{     IF pmc$system_log IN local_log THEN
{       indices [clc$display_system_log].last_log_entry := logset_entry_info [pmc$system_log].entry_offset;
{       IF logset_entry_info [pmc$system_log].log_cycle <> indices [clc$display_system_log].last_log_cycle
{             THEN
{         indices [clc$display_system_log].last_display_log_entry := 0;
{       IFEND;
{       indices [clc$display_system_log].last_log_cycle := logset_entry_info [pmc$system_log].log_cycle;
{     IFEND;
{
{     IF pmc$job_log IN local_log THEN
{       indices [clc$display_job_log].last_log_entry := logset_entry_info [pmc$job_log].entry_offset;
{       IF logset_entry_info [pmc$job_log].log_cycle <> indices [clc$display_job_log].last_log_cycle THEN
{         indices [clc$display_job_log].last_display_log_entry := 0;
{       IFEND;
{       indices [clc$display_job_log].last_log_cycle := logset_entry_info [pmc$job_log].log_cycle;
{     IFEND;
{
{     clp$store_display_log_indices (indices);
{

    END /log_ascii/;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #keypoint (osk$exit, 0, lgk$log_ascii);

  PROCEND pmp$log_ascii;

MODEND pmm$interface_to_logging;
*DECK DECK=PMM$JOB_TEMPLATE_TRAP_HANDLER EXPAND=TRUE
PMM$JOB_TEMPLATE_TRAP_HANDLER   IDENT
.

*copy sya$constants
*copy osa$basic_register_equates
*copyc OSA$KEYPOINT_CLASSES
*copyc SYA$ISSUE_KEYPOINTS_IN_HANDLERS
*copyc sya$xp_and_sf_constants
.
.
.  Local definitions
.      NOTE
.         XA thru XC are always scratch registers).
.         XE contains the vector simulation flag (on entry)
.              bits 56-63 - Non-zero if all divide nets are degraded
.              bits 40-47 - VECTOR_SIMULATION system attribute (0=simulate)
.
.      NOTE registers used by the VECTOR SIMULATOR are not included here
.
xenviro   equ       0233(16)       .For call to CYBIL trap handler.
xenvsel   equ       024e(16)       .For call to osp$select_proc_w_divide.
.
x_ucr     xreg      2
x_p       xreg      3
.
.      (the following are not saved on call to CYBIL trap handler)
.
x_opcode  xreg      5            .Must be X5 to int'f to Vector Simulator
a_p       areg      4            .Must be A4 for int'f to Vector Simulator.
          page
.
.   Trap Handling Routine for traps occur in Job Mode
.
          USE      code
          def      traprtn
TRAPRTN   ALIAS    PMP$TRAP_HANDLER
traprtn   bss       0
.
          lbyts,2  x_ucr,a_psa,x0,sfsa_ucr .Get the UCR.
          lx       x_p,a_psa,0       .Save the initial P register.
.
.
dispose   bss      0
          brxeq    x_ucr,x0,trapex   .Jump if there are no UCR bits to process
.
. Check if trap was caused by a vector instruction that should be simulated by
. the VECTOR SIMULATOR. Simulation is attempted ONLY if UNIMP is the only bit
. in the UCR
.
          shfx     xa,x_ucr,x0,49    .Shift UNIMP bit to bit 0.
          brxge    xa,x0,disp5       .Jump if UNIMP not in UCR that caused trap.
          cpyxa    a_p,x_p           .Fetch OP code.
          lbyts,1  x_opcode,a_p,x0,0
          ente     xc,5f(16)         .Max vector OP code.
          brxgt    x_opcode,xc,disp5 .Jump if cant be vector opcode.
          lbytp,8  xb,vecmsk#        .Get mask of vector instructions.
          shfx     xb,xb,x_opcode,-63 .Test for vector instruction.
          brxge    xb,x0,disp5       .Jump if not vector instruction.
          ente     xa,4000(16)       .Enter UCR value for UNIMP.
          brxeq    xa,x_ucr,disp2    .Jump if UNIMP is the ONLY bit set.
          inhx     x_ucr,xa          .Clear UNIMP in UCR and process rest of
          sbyts,2  x_ucr,a_psa,x0,sfsa_ucr . conditions. UNIMP will occur again.
          brxeq    x0,x0,disp5       .Go process rest of conditions.
.
disp2     lbytp,8  xb,divmsk#        .Get mask of vector divide instructions.
          shfx     xb,xb,x_opcode,-63 .Test for divide instruction.
          brxge    xb,x0,disp3       .Jump if not a divide instruction.
          shfx     xa,xe,x0,56       .Jump if all divide nets degraded.
          brxne    xa,x0,disp3       .  (boolean in bits 56-63)
          ente     x0,xenvsel        .Change processor selections to run only
          callseg  bs_seldiv,a_bindin,ae .  on processor with good divide units.
          brxne    xf,x0,trapex      .Exit if processor switch was sucessful.
.
disp3     shfx     xa,xe,x0,-16      .Isolate simulation flag.
          brxeq    xa,x0,vtrap#      .Jump if vector simulation enabled.
.                                       (returns directly to user)
.
.  Call pmp$dispose_of_traps (sfsa)
.
disp5     addaq    a_tos,a_tos,8     .Set up call to pmp$dispose_of_traps
          sa       a_psa,a_csf,2     .SFSA - input

          ente     x0,xenviro
          cpyaa    ae,a_csf
          callseg  bs_disp,a_bindin,ae
.
          shfx     x6,x_ucr,x0,17    .Position UCR49 to bit 32.
          brrge    x6,x0,trap1       .If unimplemented instruction not present.
          entl     x0,r_di
          entp     xe,0              .Clear debug index.
          cpyxs    xe,x0
          brxeq    x0,x0,trap2
.
trap1     lx       xe,a_psa,0        .Reset DEBUG control info if P has been changed.
          brxeq    xe,x_p,trapex
trap2     entl     x0,r_dmr
          cpysx    xe,x0
          ente     xf,9f(16)         .Clear end-list-seen & scan-in-progress.
          andx     xe,xf
          cpyxs    xe,x0
.
. The following field definition is used to support the PSFSA instruction which is
. required for CYBER-2000 but is not available in the ASSEMBLER language yet.
. When it is available, replace the VFD line with the following line:
.         psfsa                      .Purge the SFSA pushdown (CYBER-2000 only)
.
          vfd,16   0701(16)          .Purge SFSA pushdouwn (CYBER-2000 only)
.
trapex    bss      0
          keypt    oscexit,osktrpj,x0,x_ucr,x3
          entl     x0,r_ted         .set trap enable delay.
          cpyxs    x0,x0
          return
.
.
          align  0,8
          page
.
.   Define Binding Section
.
          USE      BINDING
          ref      disposet,seldiv
bindsec   bss      0
bs_disp   address  c,disposet
disposet  alias    PMP$DISPOSE_OF_TRAPS
bs_seldiv address  c,seldiv
seldiv    alias    OSP$SELECT_PROCESSORS_W_DIVIDE
         PAGE
.* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
.
. PROCEDURE [XDCL, #GATE] pmp$purge_instruction_stack;
.
. This is a routine to be used to insure that a CALLSEG instruction is
. executed after code modification. (Current use is by the Interactive Debugger).
.
. CYBIL Pseudocode:
.
.   #KEYPOINT (osk$entry, 0, pmk$purge_instruction_stack);
.   {purge_instruction_stack instruction}
.   #KEYPOINT (osk$exit, 0, pmk$purge_instruction_stack);
.
.* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
          use      code
          defg     prg_istk
prg_istk  alias    pmp$purge_instruction_stack
prg_istk  bss      0
          addaq    a0,a1,24
          keypoint oscent,x0,1691      .Entry keypoint, pmk$purge_instuction_stack
          purge    x0,4                .Purge the instruction stack (CYBER-2000 only)
.
. The following field definition is used to support the PSFSA instruction which is
. required for CYBER-2000 but is not available in the ASSEMBLER language yet.
. When it is available, replace the VFD line with the following line:
.         psfsa                        .Purge the SFSA pushdown (CYBER-2000 only)
.
          vfd,16   0701(16)            .Purge the SFSA pushdown (CYBER-2000 only)
          keypoint oscexit,x0,1691     .Exit keypoint, pmk$purge_instuction_stack
          return
          page
.* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
.
.
.        V E C T O R   I N S T R U C T I O N   S I M U L A T O R
.
. THIS PROC IS ENTERED VIA AN ILLEGAL INSTRUCTION TRAP, AND SIMULATES
. THE THETA-E (CYBER 2000) VECTOR INSTRUCTIONS.
.
.        ON ENTRY A2 POINTS TO THE PREVIOUS STACK FRAME SAVE AREA
.                 X5 (x_opcode) CONTAINS TRAPPED OPCODE
.                 A4 (a_p) CONTAINS TRAPPED 'P' REGISTER.
.
.* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
.
         USE       CODE
         ALIGN     0,8
VECMSK#  VFD,64    7E7E7FFF00000000(16) .BIT # + 3F(16) = VALID VEC OP CODE
DIVMSK#  VFD,64    0800000000000000(16) .BIT # + 3F(16) = DIVIDE INS
.                                           (IE, BIT 4 = OPCODE 43(16))
BRTB#    ALIGN     0,8
         BRXNE     X1,X0,ADDFV
         BRXNE     X1,X0,ADDFVR
         BRXNE     X1,X0,SUBFV
         BRXNE     X1,X0,SUBFVR
         BRXNE     X1,X0,MULFV
         BRXNE     X1,X0,MULFVR
         BRXNE     X1,X0,DIVFV
         BRXNE     X1,X0,DIVFVR
         BRXNE     X1,X0,ADDXV
         BRXNE     X1,X0,ADDXVR
         BRXNE     X1,X0,SUBXV
         BRXNE     X1,X0,SUBXVR
         BRXEQ     X0,X0,VTEXIT#       .PUNT
         BRXEQ     X0,X0,VTEXIT#       .PUNT
         BRXEQ     X0,X0,VTEXIT#       .PUNT
         BRXEQ     X0,X0,VTEXIT#       .PUNT
         BRXNE     X1,X0,IORV
         BRXNE     X1,X0,IORVR
         BRXNE     X1,X0,XORV
         BRXNE     X1,X0,XORVR
         BRXNE     X1,X0,ANDV
         BRXNE     X1,X0,ANDVR
         BRXNE     X1,X0,CNIFV
         BRXNE     X1,X0,CNIFVR
         BRXNE     X1,X0,CNFIV
         BRXNE     X1,X0,CNFIVR
         BRXNE     X1,X0,SHFCV
         BRXNE     X1,X0,SHFCVR
         BRXEQ     X0,X0,VTEXIT#       .PUNT
         BRXEQ     X0,X0,VTEXIT#       .PUNT
         BRXEQ     X0,X0,VTEXIT#       .PUNT
         BRXEQ     X0,X0,VTEXIT#       .PUNT
         BRXNE     X1,X0,CMPEQV
         BRXNE     X1,X0,CMPEQVR
         BRXNE     X1,X0,CMPLTV
         BRXNE     X1,X0,CMPLTVR
         BRXNE     X1,X0,CMPGEV
         BRXNE     X1,X0,CMPGEVR
         BRXNE     X1,X0,CMPNEV
         BRXNE     X1,X0,CMPNEVR
         BRXNE     X1,X0,MRGV
         BRXNE     X1,X0,MRGVR
         BRXNE     X1,X0,GTHV
         BRXNE     X1,X0,GTHVR
         BRXNE     X1,X0,SCTV
         BRXNE     X1,X0,SCTVR
         BRXNE     X1,X0,SUMFV
         BRXNE     X1,X0,SUMFV
         BRXNE     X1,X0,TPSFV
         BRXNE     X1,X0,TPSFVR
         BRXNE     X1,X0,TPDFV
         BRXNE     X1,X0,TPDFVR
         BRXNE     X1,X0,TSPFV
         BRXNE     X1,X0,TSPFVR
         BRXNE     X1,X0,TDPFV
         BRXNE     X1,X0,TDPFVR
         BRXNE     X1,X0,SUMPFV
         BRXNE     X1,X0,SUMPFVR
         BRXNE     X1,X0,GTHIV
         BRXNE     X1,X0,GTHIVR
         BRXNE     X1,X0,SCTIV
         BRXNE     X1,X0,SCTIVR
         BRXEQ     X0,X0,VTEXIT#       .PUNT
.
.                  INSTRUCTION DECODE
.
.        THIS SEGMENT DECODES THE INSTRUCTION FOUND AT P AND LEAVES -
.
.        XB - AI         X6 - XI        X1 - L
.        X9 - AJ         X7 - XJ        X2 - I(L/2)
.        XA - AK         X8 - K-FIELD   X3 - ODD/EVEN (L) FLAG
.        X0 - X0
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        ENTRY POINT FROM TRAP
.
         DEF       VTRAP#,VTRAPE#
VTRAP#   ALIAS     PMA$VECTOR_SIMULATOR
VTRAP#   ALIGN     0,8
.
         ENTE      XE,R_UM             .DISABLE ALL ARITHMETIC TRAPS BY
         ENTP      XF,0                . CLEARING THE UM SELECTIONS.
         CPYXS     XF,XE
         ENTE      XF,R_TE             .ENABLE TRAPS.
         CPYXS     XF,XF

         LX        X1,A2,18*8          .LOAD X1 FROM SFSA
         ENTE      X6,512              .FOR MAX L COMPARE
         ENTS      X1                  .LENGTH IN X1R
         ENTE      X2,03FF(16)         .MASK FOR L EXTRACTION
         ENTP      X3,1                .FOR ODD/EVEN FLAG
         LBYTS,3   XF,A4,X0,1          .JKID
         ANDX      X2,XF               .LENGTH FROM INSTRUCTION
          ISOB      X8,XF,X0,6400(8)    .BROADCAST BIT (B)
         BRXEQ     X2,X0,DCD1#         .BRANCH IF L  IN X1
         CPYXX     X1,X2               .PLACE L IN X1
         BRXGE     X6,X2,DCD3#         .BRANCH IF L IN RANGE
         BRXEQ     X0,X0,VTISE#        .***** ISE
.
DCD1#    BSS       0
         BRXEQ     X1,X0,VTEXIT#       .EXIT IF L=0
         BRXGT     X1,X0,DCD2#         .BRANCH IF L +VE
         BRXEQ     X0,X0,VTISE#        .***** ISE
.
DCD2#    BSS       0
         BRXGE     X6,X1,DCD3#         .BRANCH IF L IN RANGE
         CPYXX     X1,X6               .DEFAULT L = 512
.
DCD3#    BSS       0
         LX        X0,A2,17*8          .X0
         SHFX      X2,X1,X0,-1         .I(L/2)
          ADDX      X5,X5               .2*OP
           ISOB      X9,XF,X0,5003(8)    .J-FIELD
         ANDX      X3,X1               .ODD/EVEN FLAG
           ISOB      XB,XF,X0,6003(8)    .I-FIELD
          IORX      X5,X8               .2*OP + B
           ISOB      X8,XF,X0,5403(8)    .K-FIELD
          ADDXQ     X5,X5,-080(16)      .NORMALIZE
           LXI       X7,A2,X9,17*8       .XJ
           LXI       X6,A2,XB,17*8       .XI
           LXI       X9,A2,X9,1*8        .AJ
           LXI       XB,A2,XB,1*8        .AI
           LXI       XA,A2,X8,1*8        .AK
          ADDX      X5,X5               .2*(2*OP + B - 80(16))
          ADDXQ     X5,X5,(BRTB#-BRINS#)/2  .BRANCH TABLE INDEX
BRINS#   BRREL     X5                  .BRANCH TO SIMULATE
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        T P S F V   -   FLOATING POINT VECTOR TRIAD, * +
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
TPSFV    BSS       0
         CPYXA     A7,X9               .AJ
         CPYXA     A8,XA               .AK
         CPYXA     A6,XB               .AI
         LX        X6,A6,0        .     1ST OPERAND
         LX        X7,A7,0        .     2ND OPERAND
         ENTP      XE,1           .     LOOP COUNTER
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,TPSF2#   .     BRANCH IF L = 1
         LX        XA,A6,8        .     3RD OPERAND
         LX        XB,A7,8        .     4TH OPERAND
         BRXEQ     X0,X0,TPSF1A#  .
TPSF1#   SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
TPSF1A#  MULF      X6,X0          .                                      VTRI           1
         MULF      XA,X0          .                                      VTRI           2
         ADDF      X6,X7          .                                      VTRI           3
         ADDF      XA,XB          .                                      VTRI           4
         LXI       X7,A7,XE,8     .
         LXI       XB,A7,XE,16    .
         BRINC     X1,XE,TPSF1#   .
         INCX      XE,1           .
         SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         BRXEQ     X3,X0,TPSF3#   .
         LXI       X6,A6,XE,0     .
         INCX      XE,1           .
TPSF2#   MULF      X6,X0          .                                      VTRI           5
         ADDF      X6,X7          .                                      VTRI           6
         SXI       X6,A8,XE,0     .
TPSF3#   BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
TPSFVR   BSS       0
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .
         ENTP      XE,1           .
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,TPSFR2#  .
         LX        XA,A6,8        .
         BRXEQ     X0,X0,TPSFR1A# .
TPSFR1#  SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
TPSFR1A# MULF      X6,X0          .                                      VTRI           7
         MULF      XA,X0          .                                      VTRI           8
         ADDF      X6,X7          .                                      VTRI           9
         ADDF      XA,X7          .                                      VTRI          10
         BRINC     X1,XE,TPSFR1#  .
         INCX      XE,1           .
         SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         BRXEQ     X3,X0,TPSFR3#  .
         LXI       X6,A6,XE,0     .
         INCX      XE,1           .
TPSFR2#  MULF      X6,X0          .                                      VTRI          11
         ADDF      X6,X7          .                                      VTRI          12
         SXI       X6,A8,XE,0     .
TPSFR3#  BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        T P D F V   -   FLOATING POINT VECTOR TRIAD, * -
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
TPDFV    BSS       0
         CPYXA     A7,X9               .AJ
         CPYXA     A8,XA               .AK
         CPYXA     A6,XB               .AI
         LX        X6,A6,0        .     1ST OPERAND
         LX        X7,A7,0        .     2ND OPERAND
         ENTP      XE,1           .     LOOP COUNTER
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,TPDF2#   .     BRANCH IF L = 1
         LX        XA,A6,8        .     3RD OPERAND
         LX        XB,A7,8        .     4TH OPERAND
         BRXEQ     X0,X0,TPDF1A#  .
TPDF1#   SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
TPDF1A#  MULF      X6,X0          .                                      VTRI          13
         MULF      XA,X0          .                                      VTRI          14
         SUBF      X6,X7          .                                      VTRI          15
         SUBF      XA,XB          .                                      VTRI          16
         LXI       X7,A7,XE,8     .
         LXI       XB,A7,XE,16    .
         BRINC     X1,XE,TPDF1#   .
         INCX      XE,1           .
         SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         BRXEQ     X3,X0,TPDF3#   .
         LXI       X6,A6,XE,0     .
         INCX      XE,1           .
TPDF2#   MULF      X6,X0          .                                      VTRI          17
         SUBF      X6,X7          .                                      VTRI          18
         SXI       X6,A8,XE,0     .
TPDF3#   BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
TPDFVR   BSS       0
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .
         ENTP      XE,1           .
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,TPDFR2#  .
         LX        XA,A6,8        .
         BRXEQ     X0,X0,TPDFR1A# .
TPDFR1#  SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
TPDFR1A# MULF      X6,X0          .                                      VTRI          19
         MULF      XA,X0          .                                      VTRI          20
         SUBF      X6,X7          .                                      VTRI          21
         SUBF      XA,X7          .                                      VTRI          22
         BRINC     X1,XE,TPDFR1#  .
         INCX      XE,1           .
         SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         BRXEQ     X3,X0,TPDFR3#  .
         LXI       X6,A6,XE,0     .
         INCX      XE,1           .
TPDFR2#  MULF      X6,X0          .                                      VTRI          23
         SUBF      X6,X7          .                                      VTRI          24
         SXI       X6,A8,XE,0     .
TPDFR3#  BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        T S P F V   -   FLOATING POINT VECTOR TRIAD, + *
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
TSPFV    BSS       0
         CPYXA     A7,X9               .AJ
         CPYXA     A8,XA               .AK
         CPYXA     A6,XB               .AI
         LX        X6,A6,0        .     1ST OPERAND
         LX        X7,A7,0        .     2ND OPERAND
         ENTP      XE,1           .     LOOP COUNTER
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,TSPF2#   .     BRANCH IF L = 1
         LX        XA,A6,8        .     3RD OPERAND
         LX        XB,A7,8        .     4TH OPERAND
         BRXEQ     X0,X0,TSPF1A#  .
TSPF1#   SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
TSPF1A#  ADDF      X6,X7          .
         ADDF      XA,XB          .
         LXI       X7,A7,XE,8     .
         LXI       XB,A7,XE,16    .
         MULF      X6,X0          .
         MULF      XA,X0          .
         BRINC     X1,XE,TSPF1#   .
         INCX      XE,1           .
         SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         BRXEQ     X3,X0,TSPF3#   .
         LXI       X6,A6,XE,0     .
         INCX      XE,1           .
TSPF2#   ADDF      X6,X7          .
         MULF      X6,X0          .
         SXI       X6,A8,XE,0     .
TSPF3#   BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
TSPFVR   BSS       0
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .
         CPYXX     X4,X7          .XJ
         CPYXX     X5,X7          .
         ENTP      XE,1           .
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,TSPFR2#  .
         LX        XA,A6,8        .
         BRXEQ     X0,X0,TSPFR1A# .
TSPFR1#  SXI       X4,AF,XE,0     .
         SXI       X5,AF,XE,8     .
         CPYXX     X4,X7          .
         CPYXX     X5,X7          .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
TSPFR1A# ADDF      X4,X6          .
         ADDF      X5,XA          .
         MULF      X4,X0          .
         MULF      X5,X0          .
         BRINC     X1,XE,TSPFR1#  .
         INCX      XE,1           .
         SXI       X4,AF,XE,0     .
         SXI       X5,AF,XE,8     .
         BRXEQ     X3,X0,TSPFR3#  .
         LXI       X6,A6,XE,0     .
         CPYXX     X4,X7          .
         INCX      XE,1           .
TSPFR2#  ADDF      X4,X6          .
         MULF      X4,X0          .
         SXI       X4,A8,XE,0     .
TSPFR3#  BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        T D P F V   -   FLOATING POINT VECTOR TRIAD, - *
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
TDPFV    BSS       0
         CPYXA     A7,X9               .AJ
         CPYXA     A8,XA               .AK
         CPYXA     A6,XB               .AI
         LX        X6,A6,0        .     1ST OPERAND
         LX        X7,A7,0        .     2ND OPERAND
         ENTP      XE,1           .     LOOP COUNTER
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,TDPF2#   .     BRANCH IF L = 1
         LX        XA,A6,8        .     3RD OPERAND
         LX        XB,A7,8        .     4TH OPERAND
         BRXEQ     X0,X0,TDPF1A#  .
TDPF1#   SXI       X7,AF,XE,0     .
         SXI       XB,AF,XE,8     .
         LXI       X7,A7,XE,0     .
         LXI       XB,A7,XE,8     .
         INCX      XE,1           .
TDPF1A#  SUBF      X7,X6          .
         SUBF      XB,XA          .
         LXI       X6,A6,XE,8     .
         LXI       XA,A6,XE,16    .
         MULF      X7,X0          .
         MULF      XB,X0          .
         BRINC     X1,XE,TDPF1#   .
         INCX      XE,1           .
         SXI       X7,AF,XE,0     .
         SXI       XB,AF,XE,8     .
         BRXEQ     X3,X0,TDPF3#   .
         LXI       X7,A7,XE,0     .
         INCX      XE,1           .
TDPF2#   SUBF      X7,X6          .
         MULF      X7,X0          .
         SXI       X7,A8,XE,0     .
TDPF3#   BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
TDPFVR   BSS       0
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         CPYXX     X4,X7          .
         CPYXX     X5,X7          .
         LX        X6,A6,0        .
         ENTP      XE,1           .
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,TDPFR2#  .
         LX        XA,A6,8        .
         BRXEQ     X0,X0,TDPFR1A# .
TDPFR1#  SXI       X4,AF,XE,0     .
         SXI       X5,AF,XE,8     .
         CPYXX     X4,X7          .
         CPYXX     X5,X7          .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
TDPFR1A# SUBF      X4,X6          .
         SUBF      X5,XA          .
         MULF      X4,X0          .
         MULF      X5,X0          .
         BRINC     X1,XE,TDPFR1#  .
         INCX      XE,1           .
         SXI       X4,AF,XE,0     .
         SXI       X5,AF,XE,8     .
         BRXEQ     X3,X0,TDPFR3#  .
         LXI       X6,A6,XE,0     .
         CPYXX     X4,X7          .
         INCX      XE,1           .
TDPFR2#  SUBF      X4,X6          .
         MULF      X4,X0          .
         SXI       X4,A8,XE,0     .
TDPFR3#  BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        S U M P F V   -   FLT POINT VECTOR SUMMATION OF PRODUCTS
.
. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
SUMPFV   BSS       0
         CPYXA     A7,XB               .SET-UP A-REG.
         CPYXA     A6,X9               .AJ
         CPYXX     X5,X8               .SAVE STORE INDEX
.
         ENTP      X6,0                .
         ENTP      X7,0                .
         ENTP      X8,0                .CLEAR SUM REGISTERS
         ENTP      X9,0                .
         ENTP      XA,0                .
         ENTP      XB,0                .
.
         ENTP      X2,1                .FOR LENGTH TEST
         LX        X6,A7,0*8           .V(0)
         LX        X0,A6,0*8
         MULF      X6,X0
         BRXEQ     X1,X2,SUMPV2#       .BRANCH IF L = 1
         ENTP      X2,2                .
         LX        X7,A7,1*8           .V(1)
         LX        X0,A6,1*8
         MULF      X7,X0
         BRXEQ     X1,X2,SUMPV2#       .BRANCH IF L = 2
         ENTP      X2,3                .
         LX        X8,A7,2*8           .V(2)
         LX        X0,A6,2*8
         MULF      X8,X0
         BRXEQ     X1,X2,SUMPV2#       .BRANCH IF L = 3
         ENTP      X2,4                .
         LX        X9,A7,3*8           .V(3)
         LX        X0,A6,3*8
         MULF      X9,X0
         BRXEQ     X1,X2,SUMPV2#       .BRANCH IF L = 4
         ENTP      X2,5                .
         LX        XA,A7,4*8           .V(4)
         LX        X0,A6,4*8
         MULF      XA,X0
         BRXEQ     X1,X2,SUMPV2#       .BRANCH IF L = 5
.
         LX        XB,A7,5*8           .V(5)
         LX        X0,A6,5*8
         LX        XC,A7,6*8           .V(6)
         LX        XD,A7,7*8           .V(7)
         LX        XE,A7,8*8           .V(8)
         LX        XF,A7,9*8           .V(9)
.
         ENTP      X3,10               .RUNNING INDEX
         ADDAQ     A6,A6,-4*8          .ADJUST FOR LOADS
SUMPV1#  BSS       0
         MULF      XB,X0
         LXI       X0,A6,X3,0
         INCX      X2,1                .
         ADDF      X6,XB               .R(0) = R(0) + V(K+0)
         LXI       XB,A7,X3,0*8        .V(K+5)
         BRXEQ     X1,X2,SUMPV2#
         MULF      XC,X0
         LXI       X0,A6,X3,+1*8
         INCX      X2,1                .
         ADDF      X7,XC               .R(1) = R(1) + V(K+1)
         LXI       XC,A7,X3,1*8        .V(K+6)
         BRXEQ     X1,X2,SUMPV2#       .
         MULF      XD,X0
         LXI       X0,A6,X3,+2*8
         INCX      X2,1                .
         ADDF      X8,XD               .R(2) = R(2) + V(K+2)
         LXI       XD,A7,X3,2*8        .V(K+7)
         BRXEQ     X1,X2,SUMPV2#       .
         MULF      XE,X0
         LXI       X0,A6,X3,+3*8
         INCX      X2,1                .
         ADDF      X9,XE               .R(3) = R(3) + V(K+3)
         LXI       XE,A7,X3,3*8        .V(K+8)
         BRXEQ     X1,X2,SUMPV2#       .
         MULF      XF,X0
         LXI       X0,A6,X3,+4*8
         INCX      X2,1                .
         ADDF      XA,XF               .R(4) = R(4) + V(K+4)
         LXI       XF,A7,X3,4*8        .V(K+9)
         BRXEQ     X1,X2,SUMPV2#       .
         INCX      X3,5                .BUMP RUNNING INDEX
         BRXEQ     X0,X0,SUMPV1#       .LOOP
.
SUMPV2#  BSS       0
         CPYXX     XF,X1               .L
         ENTP      XE,5                .
         DIVX      XF,XE               .I(L/5)
         CPYXX     XE,X1               .
         MULXQ     XF,XF,5             .I(L/5) * 5
         SUBX      XE,XF               .R(L/5)
         ENTP      X4,0                .CLEAR ACCUMULATOR
         SHFX      XE,XE,X0,1          .POSITION XE FOR BRREL
         ADDXQ     XE,XE,(SUMPV4#-SUMPV3#)/2   .BRANCH ADDRESS
SUMPV3#  BRREL     XE                  .
SUMPV4#  BSS       0
         BRXEQ     X0,X0,SUMPV5#       .ZERO
         BRXEQ     X0,X0,SUMPV6#       .ONE
         BRXEQ     X0,X0,SUMPV7#       .TWO
         BRXEQ     X0,X0,SUMPV8#       .THREE
         ADDF      X4,X8               .R + V(2)
         ADDF      X4,X9               .R + V(3)
         ADDF      X4,XA               .R + V(4)
         ADDF      X4,X6               .R + V(0)
         ADDF      X4,X7               .R + V(1)
         BRXEQ     X0,X0,SUMPV9#       .PUNT
SUMPV5#  BSS       0
         ADDF      X4,X9               .R + V(3)
         ADDF      X4,XA               .R + V(4)
         ADDF      X4,X6               .R + V(0)
         ADDF      X4,X7               .R + V(1)
         ADDF      X4,X8               .R + V(2)
         BRXEQ     X0,X0,SUMPV9#       .PUNT
SUMPV6#  BSS       0
         ADDF      X4,XA               .R + V(4)
         ADDF      X4,X6               .R + V(0)
         ADDF      X4,X7               .R + V(1)
         ADDF      X4,X8               .R + V(2)
         ADDF      X4,X9               .R + V(3)
         BRXEQ     X0,X0,SUMPV9#       .PUNT
SUMPV7#  BSS       0
         ADDF      X4,X6               .R + V(0)
         ADDF      X4,X7               .R + V(1)
         ADDF      X4,X8               .R + V(2)
         ADDF      X4,X9               .R + V(3)
         ADDF      X4,XA               .R + V(4)
         BRXEQ     X0,X0,SUMPV9#       .PUNT
SUMPV8#  BSS       0
         ADDF      X4,X7               .R + V(1)
         ADDF      X4,X8               .R + V(2)
         ADDF      X4,X9               .R + V(3)
         ADDF      X4,XA               .R + V(4)
         ADDF      X4,X6               .R + V(0)
SUMPV9#  BSS       0
         ENTE      X2,0E6(16)
         CPYSX     X2,X2               .READ USER MASK
         ENTE      X1,043(16)
         CPYSX     X1,X1               .READ UCR
         ANDX      X2,X1
         ENTE      X1,017F(16)         .CONDITIONS OF INTEREST
         ANDX      X2,X1               .SAVE
         ENTP      X1,4
         BRXEQ     X1,X2,SUMPV11#      .IF INDEFINITE ONLY
SUMPV10# BSS       0
         SXI       X4,A2,X5,17*8       .SAVE RESULT
SUMPV11# BSS       0
         BRXEQ     X0,X0,VTEXIT#       .PUNT
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
SUMPFVR  BSS       0
         CPYXA     A7,XB               .SET-UP A-REG.
         CPYXX     X0,X7               .XJ VALUE
         CPYXX     X5,X8               .SAVE STORE INDEX
.
         ENTP      X6,0                .
         ENTP      X7,0                .
         ENTP      X8,0                .CLEAR SUM REGISTERS
         ENTP      X9,0                .
         ENTP      XA,0                .
         ENTP      XB,0                .
.
         ENTP      X2,1                .FOR LENGTH TEST
         LX        X6,A7,0*8           .V(0)
         MULF      X6,X0
         BRXEQ     X1,X2,SUMPVR2#      .BRANCH IF L = 1
         ENTP      X2,2                .
         LX        X7,A7,1*8           .V(1)
         MULF      X7,X0
         BRXEQ     X1,X2,SUMPVR2#      .BRANCH IF L = 2
         ENTP      X2,3                .
         LX        X8,A7,2*8           .V(2)
         MULF      X8,X0
         BRXEQ     X1,X2,SUMPVR2#      .BRANCH IF L = 3
         ENTP      X2,4                .
         LX        X9,A7,3*8           .V(3)
         MULF      X9,X0
         BRXEQ     X1,X2,SUMPVR2#      .BRANCH IF L = 4
         ENTP      X2,5                .
         LX        XA,A7,4*8           .V(4)
         MULF      XA,X0
         BRXEQ     X1,X2,SUMPVR2#      .BRANCH IF L = 5
.
         LX        XB,A7,5*8           .V(5)
         LX        XC,A7,6*8           .V(6)
         LX        XD,A7,7*8           .V(7)
         LX        XE,A7,8*8           .V(8)
         LX        XF,A7,9*8           .V(9)
.
         ENTP      X3,10               .RUNNING INDEX
SUMPVR1# BSS       0
         MULF      XB,X0
         INCX      X2,1                .
         ADDF      X6,XB               .R(0) = R(0) + V(K+0)
         LXI       XB,A7,X3,0*8        .V(K+5)
         BRXEQ     X1,X2,SUMPVR2#
         MULF      XC,X0
         INCX      X2,1                .
         ADDF      X7,XC               .R(1) = R(1) + V(K+1)
         LXI       XC,A7,X3,1*8        .V(K+6)
         BRXEQ     X1,X2,SUMPVR2#      .
         MULF      XD,X0
         INCX      X2,1                .
         ADDF      X8,XD               .R(2) = R(2) + V(K+2)
         LXI       XD,A7,X3,2*8        .V(K+7)
         BRXEQ     X1,X2,SUMPVR2#      .
         MULF      XE,X0
         INCX      X2,1                .
         ADDF      X9,XE               .R(3) = R(3) + V(K+3)
         LXI       XE,A7,X3,3*8        .V(K+8)
         BRXEQ     X1,X2,SUMPVR2#      .
         MULF      XF,X0
         INCX      X2,1                .
         ADDF      XA,XF               .R(4) = R(4) + V(K+4)
         LXI       XF,A7,X3,4*8        .V(K+9)
         BRXEQ     X1,X2,SUMPVR2#      .
         INCX      X3,5                .BUMP RUNNING INDEX
         BRXEQ     X0,X0,SUMPVR1#      .LOOP
.
SUMPVR2# BSS       0
         CPYXX     XF,X1               .L
         ENTP      XE,5                .
         DIVX      XF,XE               .I(L/5)
         CPYXX     XE,X1               .
         MULXQ     XF,XF,5             .I(L/5) * 5
         SUBX      XE,XF               .R(L/5)
         ENTP      X4,0                .CLEAR ACCUMULATOR
         SHFX      XE,XE,X0,1          .POSITION XE FOR BRREL
         ADDXQ     XE,XE,(SUMPVR4#-SUMPVR3#)/2   .BRANCH ADDRESS
SUMPVR3# BRREL     XE                  .
SUMPVR4# BSS       0
         BRXEQ     X0,X0,SUMPVR5#       .ZERO
         BRXEQ     X0,X0,SUMPVR6#       .ONE
         BRXEQ     X0,X0,SUMPVR7#       .TWO
         BRXEQ     X0,X0,SUMPVR8#      .THREE
         ADDF      X4,X8               .R + V(2)
         ADDF      X4,X9               .R + V(3)
         ADDF      X4,XA               .R + V(4)
         ADDF      X4,X6               .R + V(0)
         ADDF      X4,X7               .R + V(1)
         BRXEQ     X0,X0,SUMPVR9#      .PUNT
SUMPVR5# BSS       0
         ADDF      X4,X9               .R + V(3)
         ADDF      X4,XA               .R + V(4)
         ADDF      X4,X6               .R + V(0)
         ADDF      X4,X7               .R + V(1)
         ADDF      X4,X8               .R + V(2)
         BRXEQ     X0,X0,SUMPVR9#      .PUNT
SUMPVR6# BSS       0
         ADDF      X4,XA               .R + V(4)
         ADDF      X4,X6               .R + V(0)
         ADDF      X4,X7               .R + V(1)
         ADDF      X4,X8               .R + V(2)
         ADDF      X4,X9               .R + V(3)
         BRXEQ     X0,X0,SUMPVR9#      .PUNT
SUMPVR7# BSS       0
         ADDF      X4,X6               .R + V(0)
         ADDF      X4,X7               .R + V(1)
         ADDF      X4,X8               .R + V(2)
         ADDF      X4,X9               .R + V(3)
         ADDF      X4,XA               .R + V(4)
         BRXEQ     X0,X0,SUMPVR9#      .PUNT
SUMPVR8# BSS       0
         ADDF      X4,X7               .R + V(1)
         ADDF      X4,X8               .R + V(2)
         ADDF      X4,X9               .R + V(3)
         ADDF      X4,XA               .R + V(4)
         ADDF      X4,X6               .R + V(0)
SUMPVR9# BSS       0
         ENTE      X2,0E6(16)
         CPYSX     X2,X2               .READ USER MASK
         ENTE      X1,043(16)
         CPYSX     X1,X1               .READ UCR
         ANDX      X2,X1
         ENTE      X1,017F(16)         .CONDITIONS OF INTEREST
         ANDX      X2,X1               .SAVE
         ENTP      X1,4
         BRXEQ     X1,X2,SUMPR11#      .IF INDEFINITE ONLY
SUMPR10# BSS       0
         SXI       X4,A2,X5,17*8       .SAVE RESULT
SUMPR11# BSS       0
         BRXEQ     X0,X0,VTEXIT#       .PUNT
.
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +  +
.
.        G T H I V  -   GATHER VECTOR, INDEX
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
GTHIV    BSS       0
         CPYXA     A7,X9               .AJ
         CPYXA     A8,XA               .AK
         CPYXA     A6,XB               .AI
         ENTP      XE,1           .
         ADDAQ     A8,A8,-8       .
         ADDAQ     A6,A6,-8       .
GTHIV1#  LXI       X6,A6,XE,0     .1ST ELEMENT V(AI)
         SHFX      X6,X6,X0,3     .
         CPYAA     AF,A7          .
         ADDAX     AF,X6          .
         LX        X7,AF,0        .
         SXI       X7,A8,XE,0     .
         BRINC     X1,XE,GTHIV1#
         BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
GTHIVR   BSS       0
         CPYXA     A8,XA               .AK
         CPYXA     A6,XB               .AI
         ENTP      XE,1           .
         ADDAQ     A8,A8,-8       .
GTHIVR1# SXI       X7,A8,XE,0     .
         BRINC     X1,XE,GTHIVR1# .
         BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        S C T I V  -   SCATTER VECTOR, INDEX
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
SCTIV    BSS       0
         CPYXA     A7,X9               .AJ
         CPYXA     A8,XA               .AK
         CPYXA     A6,XB               .AI
         ENTP      XE,1           .
         LX        X7,A7,0        .     1ST OPERAND V(AJ)
         LX        X6,A6,0        .     1ST OPERAND V(AI)
SCTIV1#  SHFX      X6,X6,X0,3     .
         CPYAA     AF,A8
         ADDAX     AF,X6
         SX        X7,AF,0        .
         LXI       X7,A7,XE,0     .
         LXI       X6,A6,XE,0     .
         BRINC     X1,XE,SCTIV1#  .
         BRXEQ     X0,X0,VTEXIT#  .
.
. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
SCTIVR   BSS       0
         CPYXA     A8,XA               .AK
         CPYXA     A6,XB               .AI
         ENTP      XE,1           .
         LX        X6,A6,0        .    1ST ELEMENT V(AI)
SCTIVR1# SHFX      X6,X6,X0,3     .
         CPYAA     AF,A8
         ADDAX     AF,X6
         SX        X7,AF,0        .
         LXI       X6,A6,XE,0     .
         BRINC     X1,XE,SCTIVR1# .
         BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        A D D F V   -   FLOATING POINT VECTOR SUM
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
ADDFV    BSS       0
         CPYXA     A7,X9               .
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .     1ST OPERAND
         LX        X7,A7,0        .     2ND OPERAND
         ENTP      XE,1           .     LOOP COUNTER
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,ADDF2#   .     BRANCH IF L = 1
         LX        XA,A6,8        .     3RD OPERAND
         LX        XB,A7,8        .     4TH OPERAND
         BRXEQ     X0,X0,ADDF1A#  .
ADDF1#   SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
ADDF1A#  ADDF      X6,X7          .
         ADDF      XA,XB          .
         LXI       X7,A7,XE,8     .
         LXI       XB,A7,XE,16    .
         BRINC     X1,XE,ADDF1#   .
         INCX      XE,1           .
         SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         BRXEQ     X3,X0,ADDF3#   .
         LXI       X6,A6,XE,0     .
         INCX      XE,1           .
ADDF2#   ADDF      X6,X7          .
         SXI       X6,A8,XE,0     .
ADDF3#   BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
ADDFVR   BSS       0
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .
         ENTP      XE,1           .
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,ADDFR2#  .
         LX        XA,A6,8        .
         BRXEQ     X0,X0,ADDFR1A# .
ADDFR1#  SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
ADDFR1A# ADDF      X6,X7          .
         ADDF      XA,X7          .
         BRINC     X1,XE,ADDFR1#  .
         INCX      XE,1           .
         SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         BRXEQ     X3,X0,ADDFR3#  .
         LXI       X6,A6,XE,0     .
         INCX      XE,1           .
ADDFR2#  ADDF      X6,X7          .
         SXI       X6,A8,XE,0     .
ADDFR3#  BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        S U B F V   -   FLOATING POINT VECTOR DIFFERENCE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
SUBFV    BSS       0
         CPYXA     A7,X9               .
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .     1ST OPERAND
         LX        X7,A7,0        .     2ND OPERAND
         ENTP      XE,1           .     LOOP COUNTER
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,SUBF2#   .     BRANCH IF L = 1
         LX        XA,A6,8        .     3RD OPERAND
         LX        XB,A7,8        .     4TH OPERAND
         BRXEQ     X0,X0,SUBF1A#  .
SUBF1#   SXI       X7,AF,XE,0     .
         SXI       XB,AF,XE,8     .
         LXI       X7,A7,XE,0     .
         LXI       XB,A7,XE,8     .
         INCX      XE,1           .
SUBF1A#  SUBF      X7,X6          .
         SUBF      XB,XA          .
         LXI       X6,A6,XE,8     .
         LXI       XA,A6,XE,16    .
         BRINC     X1,XE,SUBF1#   .
         INCX      XE,1           .
         SXI       X7,AF,XE,0     .
         SXI       XB,AF,XE,8     .
         BRXEQ     X3,X0,SUBF3#   .
         LXI       X7,A7,XE,0     .
         INCX      XE,1           .
SUBF2#   SUBF      X7,X6          .
         SXI       X7,A8,XE,0     .
SUBF3#   BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
SUBFVR   BSS       0
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .
         CPYXX     X4,X7          .
         ENTP      XE,1           .
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,SUBFR2#  .
         LX        XA,A6,8        .
         CPYXX     X5,X7          .
         BRXEQ     X0,X0,SUBFR1A# .
SUBFR1#  SXI       X4,AF,XE,0     .
         SXI       X5,AF,XE,8     .
         CPYXX     X4,X7          .
         CPYXX     X5,X7          .
         INCX      XE,1           .
SUBFR1A# SUBF      X4,X6          .
         SUBF      X5,XA          .
         LXI       X6,A6,XE,8     .
         LXI       XA,A6,XE,16    .
         BRINC     X1,XE,SUBFR1#  .
         INCX      XE,1           .
         SXI       X4,AF,XE,0     .
         SXI       X5,AF,XE,8     .
         BRXEQ     X3,X0,SUBFR3#  .
         LXI       X6,A6,XE,0     .
         CPYXX     X4,X7          .
         INCX      XE,1           .
SUBFR2#  SUBF      X4,X6          .
         SXI       X4,A8,XE,0     .
SUBFR3#  BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        M U L F V   -   FLOATING POINT VECTOR PRODUCT
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
MULFV    BSS       0
         CPYXA     A7,X9               .
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .     1ST OPERAND
         LX        X7,A7,0        .     2ND OPERAND
         ENTP      XE,1           .     LOOP COUNTER
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,MULF2#   .     BRANCH IF L = 1
         LX        XA,A6,8        .     3RD OPERAND
         LX        XB,A7,8        .     4TH OPERAND
         BRXEQ     X0,X0,MULF1A#  .
MULF1#   SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
MULF1A#  MULF      X6,X7          .
         MULF      XA,XB          .
         LXI       X7,A7,XE,8     .
         LXI       XB,A7,XE,16    .
         BRINC     X1,XE,MULF1#   .
         INCX      XE,1           .
         SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         BRXEQ     X3,X0,MULF3#   .
         LXI       X6,A6,XE,0     .
         INCX      XE,1           .
MULF2#   MULF      X6,X7          .
         SXI       X6,A8,XE,0     .
MULF3#   BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
MULFVR   BSS       0
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .
         ENTP      XE,1           .
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,MULFR2#  .
         LX        XA,A6,8        .
         BRXEQ     X0,X0,MULFR1A# .
MULFR1#  SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
MULFR1A# MULF      X6,X7          .
         MULF      XA,X7          .
         BRINC     X1,XE,MULFR1#  .
         INCX      XE,1           .
         SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         BRXEQ     X3,X0,MULFR3#  .
         LXI       X6,A6,XE,0     .
         INCX      XE,1           .
MULFR2#  MULF      X6,X7          .
         SXI       X6,A8,XE,0     .
MULFR3#  BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        D I V F V   -   FLOATING POINT VECTOR QUOTIENT
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
DIVFV    BSS       0
         ENTP      X2,0                .
         CPYXA     A7,X9               .
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0             .1ST OPERAND
         LX        X7,A7,0             .2ND OPERAND
         ENTP      XE,1                .LOOP COUNTER
         ADDAQ     A8,A8,-8            .
DIVF1#   DIVF      X7,X6               .
         BRCR      7,4,DIVF3#          .
DIVF2#   BSS       0
         LXI       X6,A6,XE,0          .
         SXI       X7,A8,XE,0          .
         LXI       X7,A7,XE,0          .
         BRINC     X1,XE,DIVF1#        .
         BRXEQ     X2,X0,VTEXIT#       .
         BRCR      0D(16),5,DIVF21#    .
DIVF21#  BSS       0
         BRCR      7,5,VTEXIT#         .
DIVF3#   BSS       0
         ENTP      X2,4                .
         ISOM      X7,X0,102(8)        .
         BRXEQ     X0,X0,DIVF2#        .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
DIVFVR   BSS       0
         ENTP      X2,0
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0             .
         CPYXX     X4,X7               .
         ENTP      XE,1                .
         ADDAQ     A8,A8,-8            .
DIVFR1#  DIVF      X4,X6               .
         BRCR      7,4,DIVFR3#         .
DIVFR2#  BSS       0
         LXI       X6,A6,XE,0          .
         SXI       X4,A8,XE,0          .
         CPYXX     X4,X7               .
         BRINC     X1,XE,DIVFR1#       .
         BRXEQ     X2,X0,VTEXIT#       .
         BRCR      0D(16),5,DIVFR21#   .
DIVFR21# BSS       0
         BRCR      7,5,VTEXIT#         .
DIVFR3#  BSS       0
         ENTP      X2,4                .
         ISOM      X4,X0,102(8)        .
         BRXEQ     X0,X0,DIVFR2#       .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        A D D X V   -   INTEGER VECTOR SUM
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
ADDXV    BSS       0
         CPYXA     A7,X9               .
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .     1ST OPERAND
         LX        X7,A7,0        .     2ND OPERAND
         ENTP      XE,1           .     LOOP COUNTER
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,ADDX2#   .     BRANCH IF L = 1
         LX        XA,A6,8        .     3RD OPERAND
         LX        XB,A7,8        .     4TH OPERAND
         BRXEQ     X0,X0,ADDX1A#  .
ADDX1#   SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
ADDX1A#  ADDX      X6,X7          .
         ADDX      XA,XB          .
         LXI       X7,A7,XE,8     .
         LXI       XB,A7,XE,16    .
         BRINC     X1,XE,ADDX1#   .
         INCX      XE,1           .
         SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         BRXEQ     X3,X0,ADDX3#   .
         LXI       X6,A6,XE,0     .
         INCX      XE,1           .
ADDX2#   ADDX      X6,X7          .
         SXI       X6,A8,XE,0     .
ADDX3#   BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
ADDXVR   BSS       0
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .
         ENTP      XE,1           .
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,ADDXR2#  .
         LX        XA,A6,8        .
         BRXEQ     X0,X0,ADDXR1A# .
ADDXR1#  SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
ADDXR1A# ADDX      X6,X7          .
         ADDX      XA,X7          .
         BRINC     X1,XE,ADDXR1#  .
         INCX      XE,1           .
         SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         BRXEQ     X3,X0,ADDXR3#  .
         LXI       X6,A6,XE,0     .
         INCX      XE,1           .
ADDXR2#  ADDX      X6,X7          .
         SXI       X6,A8,XE,0     .
ADDXR3#  BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        S U B X V   -   INTEGER VECTOR DIFFERENCE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
SUBXV    BSS       0
         CPYXA     A7,X9               .
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .     1ST OPERAND
         LX        X7,A7,0        .     2ND OPERAND
         ENTP      XE,1           .     LOOP COUNTER
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,SUBX2#   .     BRANCH IF L = 1
         LX        XA,A6,8        .     3RD OPERAND
         LX        XB,A7,8        .     4TH OPERAND
         BRXEQ     X0,X0,SUBX1A#  .
SUBX1#   SXI       X7,AF,XE,0     .
         SXI       XB,AF,XE,8     .
         LXI       X7,A7,XE,0     .
         LXI       XB,A7,XE,8     .
         INCX      XE,1           .
SUBX1A#  SUBX      X7,X6          .
         SUBX      XB,XA          .
         LXI       X6,A6,XE,8     .
         LXI       XA,A6,XE,16    .
         BRINC     X1,XE,SUBX1#   .
         INCX      XE,1           .
         SXI       X7,AF,XE,0     .
         SXI       XB,AF,XE,8     .
         BRXEQ     X3,X0,SUBX3#   .
         LXI       X7,A7,XE,0     .
         INCX      XE,1           .
SUBX2#   SUBX      X7,X6          .
         SXI       X7,A8,XE,0     .
SUBX3#   BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
SUBXVR   BSS       0
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .
         CPYXX     X4,X7          .
         ENTP      XE,1           .
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,SUBXR2#  .
         LX        XA,A6,8        .
         CPYXX     X5,X7          .
         BRXEQ     X0,X0,SUBXR1A# .
SUBXR1#  SXI       X4,AF,XE,0     .
         SXI       X5,AF,XE,8     .
         CPYXX     X4,X7          .
         CPYXX     X5,X7          .
         INCX      XE,1           .
SUBXR1A# SUBX      X4,X6          .
         SUBX      X5,XA          .
         LXI       X6,A6,XE,8     .
         LXI       XA,A6,XE,16    .
         BRINC     X1,XE,SUBXR1#  .
         INCX      XE,1           .
         SXI       X4,AF,XE,0     .
         SXI       X5,AF,XE,8     .
         BRXEQ     X3,X0,SUBXR3#  .
         CPYXX     X4,X7          .
         INCX      XE,1           .
SUBXR2#  SUBX      X4,X6          .
         SXI       X4,A8,XE,0     .
SUBXR3#  BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        I O R V   -   LOGICAL VECTOR SUM
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
IORV     BSS       0
         CPYXA     A7,X9               .
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .     1ST OPERAND
         LX        X7,A7,0        .     2ND OPERAND
         ENTP      XE,1           .     LOOP COUNTER
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,IORX2#   .     BRANCH IF L = 1
         LX        XA,A6,8        .     3RD OPERAND
         LX        XB,A7,8        .     4TH OPERAND
         BRXEQ     X0,X0,IORX1A#  .
IORX1#   SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
IORX1A#  IORX      X6,X7          .
         IORX      XA,XB          .
         LXI       X7,A7,XE,8     .
         LXI       XB,A7,XE,16    .
         BRINC     X1,XE,IORX1#   .
         INCX      XE,1           .
         SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         BRXEQ     X3,X0,IORX3#   .
         LXI       X6,A6,XE,0     .
         INCX      XE,1           .
IORX2#   IORX      X6,X7          .
         SXI       X6,A8,XE,0     .
IORX3#   BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
IORVR    BSS       0
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .
         ENTP      XE,1           .
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,IORXR2#  .
         LX        XA,A6,8        .
         BRXEQ     X0,X0,IORXR1A# .
IORXR1#  SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
IORXR1A# IORX      X6,X7          .
         IORX      XA,X7          .
         BRINC     X1,XE,IORXR1#  .
         INCX      XE,1           .
         SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         BRXEQ     X3,X0,IORXR3#  .
         LXI       X6,A6,XE,0     .
         INCX      XE,1           .
IORXR2#  IORX      X6,X7          .
         SXI       X6,A8,XE,0     .
IORXR3#  BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        X O R V   -   LOGICAL VECTOR DIFFERENCE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
XORV     BSS       0
         CPYXA     A7,X9               .
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .     1ST OPERAND
         LX        X7,A7,0        .     2ND OPERAND
         ENTP      XE,1           .     LOOP COUNTER
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,XORX2#   .     BRANCH IF L = 1
         LX        XA,A6,8        .     3RD OPERAND
         LX        XB,A7,8        .     4TH OPERAND
         BRXEQ     X0,X0,XORX1A#  .
XORX1#   SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
XORX1A#  XORX      X6,X7          .
         XORX      XA,XB          .
         LXI       X7,A7,XE,8     .
         LXI       XB,A7,XE,16    .
         BRINC     X1,XE,XORX1#   .
         INCX      XE,1           .
         SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         BRXEQ     X3,X0,XORX3#   .
         LXI       X6,A6,XE,0     .
         INCX      XE,1           .
XORX2#   XORX      X6,X7          .
         SXI       X6,A8,XE,0     .
XORX3#   BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
XORVR    BSS       0
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .
         ENTP      XE,1           .
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,XORXR2#  .
         LX        XA,A6,8        .
         BRXEQ     X0,X0,XORXR1A# .
XORXR1#  SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
XORXR1A# XORX      X6,X7          .
         XORX      XA,X7          .
         BRINC     X1,XE,XORXR1#  .
         INCX      XE,1           .
         SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         BRXEQ     X3,X0,IORXR3#  .
         LXI       X6,A6,XE,0     .
         INCX      XE,1           .
XORXR2#  XORX      X6,X7          .
         SXI       X6,A8,XE,0     .
XORXR3#  BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        A N D V   -   LOGICAL VECTOR PRODUCT
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
ANDV     BSS       0
         CPYXA     A7,X9               .
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .     1ST OPERAND
         LX        X7,A7,0        .     2ND OPERAND
         ENTP      XE,1           .     LOOP COUNTER
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,ANDX2#   .     BRANCH IF L = 1
         LX        XA,A6,8        .     3RD OPERAND
         LX        XB,A7,8        .     4TH OPERAND
         BRXEQ     X0,X0,ANDX1A#  .
ANDX1#   SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
ANDX1A#  ANDX      X6,X7          .
         ANDX      XA,XB          .
         LXI       X7,A7,XE,8     .
         LXI       XB,A7,XE,16    .
         BRINC     X1,XE,ANDX1#   .
         INCX      XE,1           .
         SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         BRXEQ     X3,X0,ANDX3#   .
         LXI       X6,A6,XE,0     .
         INCX      XE,1           .
ANDX2#   ANDX      X6,X7          .
         SXI       X6,A8,XE,0     .
ANDX3#   BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
ANDVR    BSS       0
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .
         ENTP      XE,1           .
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,ANDXR2#  .
         LX        XA,A6,8        .
         BRXEQ     X0,X0,ANDXR1A# .
ANDXR1#  SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         LXI       X6,A6,XE,0     .
         LXI       XA,A6,XE,8     .
         INCX      XE,1           .
ANDXR1A# ANDX      X6,X7          .
         ANDX      XA,X7          .
         BRINC     X1,XE,ANDXR1#  .
         INCX      XE,1           .
         SXI       X6,AF,XE,0     .
         SXI       XA,AF,XE,8     .
         BRXEQ     X3,X0,IORXR3#  .
         LXI       X6,A6,XE,0     .
         INCX      XE,1           .
ANDXR2#  ANDX      X6,X7          .
         SXI       X6,A8,XE,0     .
ANDXR3#  BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        C N F I V   -   CONVERT INTEGER VECTOR TO FLOATING
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
CNIFV    BSS       0
         CPYXA     A7,X9               .SET UP A-REGS
         CPYXA     A8,XA               .
         LX        X7,A7,0        .
         LX        XA,A7,8        .
         ENTP      XE,1           .
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,CNIF3#   .
         BRXEQ     X0,X0,CNIF2#   .
CNIF1#   SXI       X8,AF,XE,0     .
         SXI       XB,AF,XE,8     .
         INCX      XE,1           .
CNIF2#   CNIF      X8,X7          .
         CNIF      XB,XA          .
         LXI       X7,A7,XE,8     .
         LXI       XA,A7,XE,16    .
         BRINC     X1,XE,CNIF1#   .
         INCX      XE,1           .
         SXI       X8,AF,XE,0     .
         SXI       XB,AF,XE,8     .
         BRXEQ     X3,X0,CNIF4#   .
         INCX      XE,1           .
CNIF3#   CNIF      X8,X7          .
         SXI       X8,A8,XE,0      .
CNIF4#   BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
CNIFVR   BSS       0
         CPYXA     A8,XA               .SET UP A-REG
         ENTP      XE,1
         CNIF      X8,X7          .
         ADDAQ     A8,A8,-8       .
CNIFR1#  SXI       X8,A8,XE,0     .
         BRINC     X1,XE,CNIFR1#  .
         BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        C N I F V   -   CONVERT FLOATING VECTOR TO INTEGER
.
. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
CNFIV    BSS       0
         CPYXA     A7,X9               .SET UP A-REGS
         CPYXA     A8,XA               .
         LX        X7,A7,0        .
         LX        XA,A7,8        .
         ENTP      XE,1           .
         DECX      X1,1           .
         ADDAQ     AF,A8,-16      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,CNFI3#   .
         BRXEQ     X0,X0,CNFI2#   .
CNFI1#   SXI       X8,AF,XE,0   .
         SXI       XB,AF,XE,8    .
         INCX      XE,1           .
CNFI2#   CNFI      X8,X7          .
         CNFI      XB,XA          .
         LXI       X7,A7,XE,8     .
         LXI       XA,A7,XE,16    .
         BRINC     X1,XE,CNFI1#   .
         INCX      XE,1           .
         SXI       X8,AF,XE,0     .
         SXI       XB,AF,XE,8    .
         BRXEQ     X3,X0,CNFI4#   .
         INCX      XE,1           .
CNFI3#   CNFI      X8,X7          .
         SXI       X8,A8,XE,0      .
CNFI4#   BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
CNFIVR   BSS       0
         CPYXA     A8,XA               .SET UP A-REG
         ENTP      XE,1
         CNFI      X8,X7          .
         ADDAQ     A8,A8,-8       .
CNFIR1#  SXI       X8,A8,XE,0    .
         BRINC     X1,XE,CNFIR1#  .
         BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        S H F V   -   VECTOR SHIFT
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
SHFCV    BSS       0
         CPYXA     A7,X9               .
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .     1ST OPERAND
         LX        X7,A7,0        .     2ND OPERAND
         ENTP      XE,1           .     LOOP COUNTER
         DECX      X1,1           .
         ADDAQ     AF,A8,-24      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,SHFC2#   .     BRANCH IF L = 1
         LX        XA,A6,8        .     3RD OPERAND
         LX        XB,A7,8        .     4TH OPERAND
         BRXEQ     X0,X0,SHFC1A#  .
SHFC1#   SXI       X8,AF,XE,0     .
         SXI       XC,AF,XE,8     .
SHFC1A#  SHFC      X8,X6,X7,0     .
         SHFC      XC,XA,XB,0     .
         LXI       X7,A7,XE,8     .
         LXI       XB,A7,XE,16    .
         LXI       X6,A6,XE,8     .
         LXI       XA,A6,XE,16    .
         INCX      XE,1           .
         BRINC     X1,XE,SHFC1#   .
         INCX      XE,1           .
         SXI       X8,AF,XE,0     .
         SXI       XC,AF,XE,8     .
         BRXEQ     X3,X0,SHFC3#   .
SHFC2#   SHFC      X8,X6,X7,0     .
         SXI       X8,A8,XE,0     .
SHFC3#   BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
SHFCVR   BSS       0
         CPYXA     A8,XA               .SET UP A-REGS
         CPYXA     A6,XB               .
         LX        X6,A6,0        .
         ENTP      XE,1           .
         DECX      X1,1           .
         ADDAQ     AF,A8,-24      .
         ADDAQ     A8,A8,-8       .
         SUBX      X1,X3          .
         BRXEQ     X2,X0,SHFCR2#  .
         LX        XA,A6,8        .
         BRXEQ     X0,X0,SHFCR1A# .
SHFCR1#  SXI       X8,AF,XE,0     .
         SXI       XC,AF,XE,8     .
SHFCR1A# SHFC      X8,X6,X7,0     .
         SHFC      XC,XA,X7,0     .
         LXI       X6,A6,XE,8     .
         LXI       XA,A6,XE,16    .
         INCX      XE,1           .
         BRINC     X1,XE,SHFCR1#  .
         INCX      XE,1           .
         SXI       X8,AF,XE,0     .
         SXI       XC,AF,XE,8     .
         BRXEQ     X3,X0,SHFCR3#  .
SHFCR2#  SHFC      X8,X6,X7,0     .
         SXI       X8,A8,XE,0     .
SHFCR3#  BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        C M P E Q V   -   INTEGER VECTOR COMPARE FOR EQUAL
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
CMPEQV   BSS       0
         ADDXQ     X4,X1,-1            .L - 1
         CPYXA     A6,XB               .AI
         CPYXA     A8,XA               .AK
         CPYXA     A7,X9               .AJ
         LX        X6,A6,0             .FIRST OPERAND
         LX        X7,A7,0             .SECOND OPERAND
         ENTP      XE,1                .LOOP INDEX
         ADDAQ     AF,A8,-3*8          .FOR STORES
         ADDAQ     A8,A8,-2*8          .
         SUBX      X4,X3               .REMOVE ODD COUNT
         BRXEQ     X2,X0,CMPEQ2#       .BRANCH IF ONE OPERAND
         LX        XA,A6,1*8           .1ST OPERAND
         LX        XB,A7,1*8           .2ND OPERAND
         BRXEQ     X0,X0,CMPEQ1A#      .ENTER LOOP
.
CMPEQ1#  BSS       0
         SXI       XC,AF,XE,0          .
         SXI       XD,AF,XE,1*8        .
CMPEQ1A# BSS       0
         CMPX      X1,X7,X6            .
         LXI       X6,A6,XE,1*8        .
         LXI       X7,A7,XE,1*8        .
         INCX      XE,1                .
         MARK      XC,X1,08(16)        .
         CMPX      X1,XB,XA            .
         LXI       XA,A6,XE,1*8        .
         LXI       XB,A7,XE,1*8        .
         MARK      XD,X1,08(16)        .
         BRINC     X4,XE,CMPEQ1#       .
.
         INCX      XE,1                .
         SXI       XC,AF,XE,0*8        .
         SXI       XD,AF,XE,1*8        .
         BRXEQ     X3,X0,CMPEQ3#       .
.
CMPEQ2#  BSS       0
         CMPX      X1,X7,X6            .
         INCX      XE,1                .
         MARK      XC,X1,08(16)        .
         SXI       XC,A8,XE,0*8        .
CMPEQ3#  BSS       0
         BRXEQ     X0,X0,VTEXIT#
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
CMPEQVR  BSS       0
         CPYXA     A6,XB               .AI.
         CPYXA     A8,XA               .AK
         LX        X6,A6,0*8           .FIRST OPERAND
         ENTP      XE,1                .
         ADDXQ     X4,X1,-1            .LOOP MAX
         ADDAQ     AF,A8,-3*8          .FOR STORE
         ADDAQ     A8,A8,-2*8          .
         SUBX      X4,X3               .REMOVE ODD COUNT
         BRXEQ     X2,X0,CMPEQR2#      .BRANCH IF L = 1
         LX        XA,A6,1*8           .1ST OPERAND
         BRXEQ     X0,X0,CMPEQRA#      .ENTER LOOP
.
CMPEQR1# BSS       0
         SXI       XC,AF,XE,0*8        .
         SXI       XD,AF,XE,1*8        .
CMPEQRA# BSS       0
         CMPX      X1,X7,X6            .
         LXI       X6,A6,XE,1*8        .
         INCX      XE,1                .
         MARK      XC,X1,08(16)        .
         CMPX      X1,X7,XA            .
         LXI       XA,A6,XE,1*8        .
         MARK      XD,X1,08(16)        .
         BRINC     X4,XE,CMPEQR1#      .
         INCX      XE,1                .
         SXI       XC,AF,XE,0*8        .
         SXI       XD,AF,XE,1*8        .
         BRXEQ     X3,X0,CMPEQR3#      .
CMPEQR2# BSS       0
         CMPX      X1,X7,X6            .
         INCX      XE,1                .
         MARK      XC,X1,08(16)        .
         SXI       XC,A8,XE,0*8        .
CMPEQR3# BSS       0
         BRXEQ     X0,X0,VTEXIT#       .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        C M P L T V   -   INTEGER VECTOR COMPARE FOR LESS THAN
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
CMPLTV   BSS       0
         ADDXQ     X4,X1,-1            .L - 1
         CPYXA     A6,XB               .AI
         CPYXA     A8,XA               .AK
         CPYXA     A7,X9               .AJ
         LX        X6,A6,0             .FIRST OPERAND
         LX        X7,A7,0             .SECOND OPERAND
         ENTP      XE,1                .LOOP INDEX
         ADDAQ     AF,A8,-3*8          .FOR STORES
         ADDAQ     A8,A8,-2*8          .
         SUBX      X4,X3               .REMOVE ODD COUNT
         BRXEQ     X2,X0,CMPLT2#       .BRANCH IF ONE OPERAND
         LX        XA,A6,1*8           .1ST OPERAND
         LX        XB,A7,1*8           .2ND OPERAND
         BRXEQ     X0,X0,CMPLT1A#      .ENTER LOOP
.
CMPLT1#  BSS       0
         SXI       XC,AF,XE,0          .
         SXI       XD,AF,XE,1*8        .
CMPLT1A# BSS       0
         CMPX      X1,X7,X6            .
         LXI       X6,A6,XE,1*8        .
         LXI       X7,A7,XE,1*8        .
         INCX      XE,1                .
         MARK      XC,X1,01(16)        .
         CMPX      X1,XB,XA            .
         LXI       XA,A6,XE,1*8        .
         LXI       XB,A7,XE,1*8        .
         MARK      XD,X1,01(16)        .
         BRINC     X4,XE,CMPLT1#       .
.
         INCX      XE,1                .
         SXI       XC,AF,XE,0*8        .
         SXI       XD,AF,XE,1*8        .
         BRXEQ     X3,X0,CMPLT3#       .
.
CMPLT2#  BSS       0
         CMPX      X1,X7,X6            .
         INCX      XE,1                .
         MARK      XC,X1,01(16)        .
         SXI       XC,A8,XE,0*8        .
CMPLT3#  BSS       0
         BRXEQ     X0,X0,VTEXIT#
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
CMPLTVR  BSS       0
         CPYXA     A6,XB               .AI.
         CPYXA     A8,XA               .AK
         LX        X6,A6,0*8           .FIRST OPERAND
         ENTP      XE,1                .
         ADDXQ     X4,X1,-1            .LOOP MAX
         ADDAQ     AF,A8,-3*8          .FOR STORE
         ADDAQ     A8,A8,-2*8          .
         SUBX      X4,X3               .REMOVE ODD COUNT
         BRXEQ     X2,X0,CMPLTR2#      .BRANCH IF L = 1
         LX        XA,A6,1*8           .1ST OPERAND
         BRXEQ     X0,X0,CMPLTRA#      .ENTER LOOP
.
CMPLTR1# BSS       0
         SXI       XC,AF,XE,0*8        .
         SXI       XD,AF,XE,1*8        .
CMPLTRA# BSS       0
         CMPX      X1,X7,X6            .
         LXI       X6,A6,XE,1*8        .
         INCX      XE,1                .
         MARK      XC,X1,01(16)        .
         CMPX      X1,X7,XA            .
         LXI       XA,A6,XE,1*8        .
         MARK      XD,X1,01(16)        .
         BRINC     X4,XE,CMPLTR1#      .
         INCX      XE,1                .
         SXI       XC,AF,XE,0*8        .
         SXI       XD,AF,XE,1*8        .
         BRXEQ     X3,X0,CMPLTR3#      .
CMPLTR2# BSS       0
         CMPX      X1,X7,X6            .
         INCX      XE,1                .
         MARK      XC,X1,01(16)        .
         SXI       XC,A8,XE,0*8        .
CMPLTR3# BSS       0
         BRXEQ     X0,X0,VTEXIT#       .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        C M P G E V   -   INTEGER VECTOR COMPARE FOR GREATER OR EQUAL
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
CMPGEV   BSS       0
         ADDXQ     X4,X1,-1            .L - 1
         CPYXA     A6,XB               .AI
         CPYXA     A8,XA               .AK
         CPYXA     A7,X9               .AJ
         LX        X6,A6,0             .FIRST OPERAND
         LX        X7,A7,0             .SECOND OPERAND
         ENTP      XE,1                .LOOP INDEX
         ADDAQ     AF,A8,-3*8          .FOR STORES
         ADDAQ     A8,A8,-2*8          .
         SUBX      X4,X3               .REMOVE ODD COUNT
         BRXEQ     X2,X0,CMPGE2#       .BRANCH IF ONE OPERAND
         LX        XA,A6,1*8           .1ST OPERAND
         LX        XB,A7,1*8           .2ND OPERAND
         BRXEQ     X0,X0,CMPGE1A#      .ENTER LOOP
.
CMPGE1#  BSS       0
         SXI       XC,AF,XE,0          .
         SXI       XD,AF,XE,1*8        .
CMPGE1A# BSS       0
         CMPX      X1,X7,X6            .
         LXI       X6,A6,XE,1*8        .
         LXI       X7,A7,XE,1*8        .
         INCX      XE,1                .
         MARK      XC,X1,0C(16)        .
         CMPX      X1,XB,XA            .
         LXI       XA,A6,XE,1*8        .
         LXI       XB,A7,XE,1*8        .
         MARK      XD,X1,0C(16)        .
         BRINC     X4,XE,CMPGE1#       .
.
         INCX      XE,1                .
         SXI       XC,AF,XE,0*8        .
         SXI       XD,AF,XE,1*8        .
         BRXEQ     X3,X0,CMPGE3#       .
.
CMPGE2#  BSS       0
         CMPX      X1,X7,X6            .
         INCX      XE,1                .
         MARK      XC,X1,0C(16)        .
         SXI       XC,A8,XE,0*8        .
CMPGE3#  BSS       0
         BRXEQ     X0,X0,VTEXIT#
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
CMPGEVR  BSS       0
         CPYXA     A6,XB               .AI.
         CPYXA     A8,XA               .AK
         LX        X6,A6,0*8           .FIRST OPERAND
         ENTP      XE,1                .
         ADDXQ     X4,X1,-1            .LOOP MAX
         ADDAQ     AF,A8,-3*8          .FOR STORE
         ADDAQ     A8,A8,-2*8          .
         SUBX      X4,X3               .REMOVE ODD COUNT
         BRXEQ     X2,X0,CMPGER2#      .BRANCH IF L = 1
         LX        XA,A6,1*8           .1ST OPERAND
         BRXEQ     X0,X0,CMPGERA#      .ENTER LOOP
.
CMPGER1# BSS       0
         SXI       XC,AF,XE,0*8        .
         SXI       XD,AF,XE,1*8        .
CMPGERA# BSS       0
         CMPX      X1,X7,X6            .
         LXI       X6,A6,XE,1*8        .
         INCX      XE,1                .
         MARK      XC,X1,0C(16)        .
         CMPX      X1,X7,XA            .
         LXI       XA,A6,XE,1*8        .
         MARK      XD,X1,0C(16)        .
         BRINC     X4,XE,CMPGER1#      .
         INCX      XE,1                .
         SXI       XC,AF,XE,0*8        .
         SXI       XD,AF,XE,1*8        .
         BRXEQ     X3,X0,CMPGER3#      .
CMPGER2# BSS       0
         CMPX      X1,X7,X6            .
         INCX      XE,1                .
         MARK      XC,X1,0C(16)        .
         SXI       XC,A8,XE,0*8        .
CMPGER3# BSS       0
         BRXEQ     X0,X0,VTEXIT#       .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        C M P N E V   -   INTEGER VECTOR COMPARE FOR NOT EQUAL
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
CMPNEV   BSS       0
         ADDXQ     X4,X1,-1            .L - 1
         CPYXA     A6,XB               .AI
         CPYXA     A8,XA               .AK
         CPYXA     A7,X9               .AJ
         LX        X6,A6,0             .FIRST OPERAND
         LX        X7,A7,0             .SECOND OPERAND
         ENTP      XE,1                .LOOP INDEX
         ADDAQ     AF,A8,-3*8          .FOR STORES
         ADDAQ     A8,A8,-2*8          .
         SUBX      X4,X3               .REMOVE ODD COUNT
         BRXEQ     X2,X0,CMPNE2#       .BRANCH IF ONE OPERAND
         LX        XA,A6,1*8           .1ST OPERAND
         LX        XB,A7,1*8           .2ND OPERAND
         BRXEQ     X0,X0,CMPNE1A#      .ENTER LOOP
.
CMPNE1#  BSS       0
         SXI       XC,AF,XE,0          .
         SXI       XD,AF,XE,1*8        .
CMPNE1A# BSS       0
         CMPX      X1,X7,X6            .
         LXI       X6,A6,XE,1*8        .
         LXI       X7,A7,XE,1*8        .
         INCX      XE,1                .
         MARK      XC,X1,05(16)        .
         CMPX      X1,XB,XA            .
         LXI       XA,A6,XE,1*8        .
         LXI       XB,A7,XE,1*8        .
         MARK      XD,X1,05(16)        .
         BRINC     X4,XE,CMPNE1#       .
.
         INCX      XE,1                .
         SXI       XC,AF,XE,0*8        .
         SXI       XD,AF,XE,1*8        .
         BRXEQ     X3,X0,CMPNE3#       .
.
CMPNE2#  BSS       0
         CMPX      X1,X7,X6            .
         INCX      XE,1                .
         MARK      XC,X1,05(16)        .
         SXI       XC,A8,XE,0*8        .
CMPNE3#  BSS       0
         BRXEQ     X0,X0,VTEXIT#
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
CMPNEVR  BSS       0
         CPYXA     A6,XB               .AI.
         CPYXA     A8,XA               .AK
         LX        X6,A6,0*8           .FIRST OPERAND
         ENTP      XE,1                .
         ADDXQ     X4,X1,-1            .LOOP MAX
         ADDAQ     AF,A8,-3*8          .FOR STORE
         ADDAQ     A8,A8,-2*8          .
         SUBX      X4,X3               .REMOVE ODD COUNT
         BRXEQ     X2,X0,CMPNER2#      .BRANCH IF L = 1
         LX        XA,A6,1*8           .1ST OPERAND
         BRXEQ     X0,X0,CMPNERA#      .ENTER LOOP
.
CMPNER1# BSS       0
         SXI       XC,AF,XE,0*8        .
         SXI       XD,AF,XE,1*8        .
CMPNERA# BSS       0
         CMPX      X1,X7,X6            .
         LXI       X6,A6,XE,1*8        .
         INCX      XE,1                .
         MARK      XC,X1,05(16)        .
         CMPX      X1,X7,XA            .
         LXI       XA,A6,XE,1*8        .
         MARK      XD,X1,05(16)        .
         BRINC     X4,XE,CMPNER1#      .
         INCX      XE,1                .
         SXI       XC,AF,XE,0*8        .
         SXI       XD,AF,XE,1*8        .
         BRXEQ     X3,X0,CMPNER3#      .
CMPNER2# BSS       0
         CMPX      X1,X7,X6            .
         INCX      XE,1                .
         MARK      XC,X1,05(16)        .
         SXI       XC,A8,XE,0*8        .
CMPNER3# BSS       0
         BRXEQ     X0,X0,VTEXIT#       .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +  +
.
.        M R G V   -   VECTOR MERGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
MRGV     BSS       0
         CPYXA     A6,XB               .AI
         CPYXA     A7,X9               .AJ
         CPYXA     A8,XA               .AK
         LX        X4,A6,0*8           .CONTROL VECTOR
         LX        X6,A7,0*8           .1ST OPERAND
         LX        X7,A8,0*8           .2ND OPERAND
         ADDAQ     AA,A8,-2*8          .FOR STORES
         BRXNE     X2,X0,MRGV1#        .BRANCH IF L NE 1
         SHFX      X4,X4,X0,-63
         ANDX      X6,X4               .
         INHX      X7,X4               .FORM RESULT
         IORX      X6,X7               .
         SX        X6,A8,0*8           .AND STORE
         BRXEQ     X0,X0,VTEXIT#       .PUNT
.
MRGV1#   BSS       0
         LX        XC,A6,1*8           .CONTROL VECTOR
         LX        XA,A7,1*8           .1ST OPERAND
         LX        XB,A8,1*8           .2ND OPERAND
         DECX      X1,1                .LOOP MAX
         ENTP      XE,1                .LOOP INDEX
         SUBX      X1,X3               .REMOVE ODD NUMBER
         SHFX      X4,X4,X0,-63        .FORM MASK
         SHFX      XC,XC,X0,-63        .FORM MASK
.
MRGV2#   BSS       0
         INCX      XE,1                .
         ANDX      X6,X4               .
         ANDX      XA,XC               .
         INHX      X7,X4               .
         INHX      XB,XC               .
         LXI       X4,A6,XE,0*8        .
         LXI       XC,A6,XE,1*8        .
         IORX      X6,X7               .
         IORX      XA,XB               .
         LXI       X7,A8,XE,0*8        .
         LXI       XB,A8,XE,1*8        .
         SXI       X6,AA,XE,0*8        .
         SXI       XA,AA,XE,1*8        .
         LXI       X6,A7,XE,0*8        .
         LXI       XA,A7,XE,1*8        .
         SHFX      X4,X4,X0,-63        .
         SHFX      XC,XC,X0,-63        .
         BRINC     X1,XE,MRGV2#        .
.
         BRXEQ     X3,X0,VTEXIT#       .PUNT IF EVEN
         ANDX      X6,X4               .
         INHX      X7,X4               .
         IORX      X6,X7               .
         SXI       X6,AA,XE,2*8        .
         BRXEQ     X0,X0,VTEXIT#       .PUNT
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
MRGVR    BSS       0
         CPYXA     A6,XB               .AI
         CPYXA     A8,XA               .AK
         CPYXX     XF,X7               .XJ
         LX        X4,A6,0*8           .CONTROL VECTOR
         LX        X8,A8,0*8           .2ND OPERAND
         ADDAQ     AA,A8,-2*8          .FOR STORES
         BRXNE     X2,X0,MRGVR1#       .BRANCH IF L NE 1
         SHFX      X4,X4,X0,-63
         ANDX      X7,X4               .
         INHX      X8,X4               .FORM RESULT
         IORX      X7,X8               .
         SX        X7,A8,0*8           .AND STORE
         BRXEQ     X0,X0,VTEXIT#       .PUNT
.
MRGVR1#  BSS       0
         LX        XC,A6,1*8           .CONTROL VECTOR
         CPYXX     XA,XF               .1ST OPERAND
         LX        XB,A8,1*8           .2ND OPERAND
         DECX      X1,1                .LOOP MAX
         ENTP      XE,1                .LOOP INDEX
         SUBX      X1,X3               .REMOVE ODD NUMBER
         SHFX      X4,X4,X0,-63        .FORM MASK
         SHFX      XC,XC,X0,-63        .FORM MASK
.
MRGVR2#  BSS       0
         INCX      XE,1                .
         ANDX      X7,X4               .
         ANDX      XA,XC               .
         INHX      X8,X4               .
         INHX      XB,XC               .
         LXI       X4,A6,XE,0*8        .
         LXI       XC,A6,XE,1*8        .
         IORX      X7,X8               .
         IORX      XA,XB               .
         LXI       X8,A8,XE,0*8        .
         LXI       XB,A8,XE,1*8        .
         SXI       X7,AA,XE,0*8        .
         SXI       XA,AA,XE,1*8        .
         CPYXX     X7,XF               .
         CPYXX     XA,XF               .
         SHFX      X4,X4,X0,-63        .
         SHFX      XC,XC,X0,-63        .
         BRINC     X1,XE,MRGVR2#       .
.
         BRXEQ     X3,X0,VTEXIT#       .PUNT IF EVEN
         ANDX      X7,X4               .
         INHX      X8,X4               .
         IORX      X7,X8               .
         SXI       X7,AA,XE,2*8        .
         BRXEQ     X0,X0,VTEXIT#       .PUNT
.
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +  +
.
.        G T H V   -   GATHER VECTOR
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
GTHV     BSS       0
         CPYXA     A7,X9               .SET UP A-REGS
         CPYXA     A8,XA               .
         LX        X7,A7,0        .     1ST OPERAND
         SHFX      X6,X6,X0,3     .
         ENTP      XE,1           .
         ADDAQ     A8,A8,-8       .
         ADDAX     A7,X6          .
GTHV1#   SXI       X7,A8,XE,0     .
         LX        X7,A7,0        .
         ADDAX     A7,X6          .
         BRINC     X1,XE,GTHV1#
         BRXEQ     X0,X0,VTEXIT#  .
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
GTHVR    BSS       0
         CPYXA     A8,XA               .SET UP A-REG
         ENTP      XE,1           .
         ADDAQ     A8,A8,-8       .
GTHVR1#  SXI       X7,A8,XE,0     .
         BRINC     X1,XE,GTHVR1#  .
         BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        S C T V   -   SCATTER VECTOR
.
.+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
SCTV     BSS       0
         CPYXA     A7,X9               .SET UP A-REGS
         CPYXA     A8,XA               .
         LX        X7,A7,0        .     1ST OPERAND
         SHFX      X6,X6,X0,3     .
         ENTP      XE,1           .
SCTV1#   SX        X7,A8,0        .
         LXI       X7,A7,XE,0     .
         ADDAX     A8,X6          .
         BRINC     X1,XE,SCTV1#   .
         BRXEQ     X0,X0,VTEXIT#  .
.
. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
SCTVR    BSS       0
         CPYXA     A8,XA               .SET UP A-REG
         SHFX      X6,X6,X0,3     .
         ENTP      XE,1           .
SCTVR1#  SX        X7,A8,0        .
         ADDAX     A8,X6          .
         BRINC     X1,XE,SCTVR1#  .
         BRXEQ     X0,X0,VTEXIT#  .
         PAGE
.
. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
.        S U M F V   -   FLOATING POINT VECTOR SUMMATION
.
. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
SUMFV    BSS       0
         CPYXA     A7,XB               .SET-UP A-REG.
         CPYXX     X5,X8               .SAVE STORE INDEX
.
         ENTP      X6,0                .
         ENTP      X7,0                .
         ENTP      X8,0                .CLEAR SUMM REGISTERS
         ENTP      X9,0                .
         ENTP      XA,0                .
         ENTP      XB,0                .
.
         ENTP      X2,1                .FOR LENGTH TEST
         LX        X6,A7,0*8           .V(0)
         BRXEQ     X1,X2,SUMFV2#       .BRANCH IF L = 1
         ENTP      X2,2                .
         LX        X7,A7,1*8           .V(1)
         BRXEQ     X1,X2,SUMFV2#       .BRANCH IF L = 2
         ENTP      X2,3                .
         LX        X8,A7,2*8           .V(2)
         BRXEQ     X1,X2,SUMFV2#       .BRANCH IF L = 3
         ENTP      X2,4                .
         LX        X9,A7,3*8           .V(3)
         BRXEQ     X1,X2,SUMFV2#       .BRANCH IF L = 4
         ENTP      X2,5                .
         LX        XA,A7,4*8           .V(4)
         BRXEQ     X1,X2,SUMFV2#       .BRANCH IF L = 5
.
         LX        XB,A7,5*8           .V(5)
         LX        XC,A7,6*8           .V(6)
         LX        XD,A7,7*8           .V(7)
         LX        XE,A7,8*8           .V(8)
         LX        XF,A7,9*8           .V(9)
.
         ENTP      X3,10               .RUNNING INDEX
SUMFV1#  BSS       0
         INCX      X2,1                .
         ADDF      X6,XB               .R(0) = R(0) + V(K+0)
         LXI       XB,A7,X3,0*8        .V(K+5)
         BRXEQ     X1,X2,SUMFV2#
         INCX      X2,1                .
         ADDF      X7,XC               .R(1) = R(1) + V(K+1)
         LXI       XC,A7,X3,1*8        .V(K+6)
         BRXEQ     X1,X2,SUMFV2#       .
         INCX      X2,1                .
         ADDF      X8,XD               .R(2) = R(2) + V(K+2)
         LXI       XD,A7,X3,2*8        .V(K+7)
         BRXEQ     X1,X2,SUMFV2#       .
         INCX      X2,1                .
         ADDF      X9,XE               .R(3) = R(3) + V(K+3)
         LXI       XE,A7,X3,3*8        .V(K+8)
         BRXEQ     X1,X2,SUMFV2#       .
         INCX      X2,1                .
         ADDF      XA,XF               .R(4) = R(4) + V(K+4)
         LXI       XF,A7,X3,4*8        .V(K+9)
         BRXEQ     X1,X2,SUMFV2#       .
         INCX      X3,5                .BUMP RUNNING INDEX
         BRXEQ     X0,X0,SUMFV1#       .LOOP
.
SUMFV2#  BSS       0
         CPYXX     XF,X1               .L
         ENTP      XE,5                .
         DIVX      XF,XE               .I(L/5)
         CPYXX     XE,X1               .
         MULXQ     XF,XF,5             .I(L/5) * 5
         SUBX      XE,XF               .R(L/5)
         ENTP      X4,0                .CLEAR ACCUMULATOR
         SHFX      XE,XE,X0,1          .POSITION XE FOR BRREL
         ADDXQ     XE,XE,(SUMFV4#-SUMFV3#)/2   .BRANCH ADDRESS
SUMFV3#  BRREL     XE                  .
SUMFV4#  BSS       0
         BRXEQ     X0,X0,SUMFV5#       .ZERO
         BRXEQ     X0,X0,SUMFV6#       .ONE
         BRXEQ     X0,X0,SUMFV7#       .TWO
         BRXEQ     X0,X0,SUMFV8#       .THREE
         ADDF      X4,X8               .R + V(2)
         ADDF      X4,X9               .R + V(3)
         ADDF      X4,XA               .R + V(4)
         ADDF      X4,X6               .R + V(0)
         ADDF      X4,X7               .R + V(1)
         BRXEQ     X0,X0,SUMFV9#       .PUNT
SUMFV5#  BSS       0
         ADDF      X4,X9               .R + V(3)
         ADDF      X4,XA               .R + V(4)
         ADDF      X4,X6               .R + V(0)
         ADDF      X4,X7               .R + V(1)
         ADDF      X4,X8               .R + V(2)
         BRXEQ     X0,X0,SUMFV9#       .PUNT
SUMFV6#  BSS       0
         ADDF      X4,XA               .R + V(4)
         ADDF      X4,X6               .R + V(0)
         ADDF      X4,X7               .R + V(1)
         ADDF      X4,X8               .R + V(2)
         ADDF      X4,X9               .R + V(3)
         BRXEQ     X0,X0,SUMFV9#       .PUNT
SUMFV7#  BSS       0
         ADDF      X4,X6               .R + V(0)
         ADDF      X4,X7               .R + V(1)
         ADDF      X4,X8               .R + V(2)
         ADDF      X4,X9               .R + V(3)
         ADDF      X4,XA               .R + V(4)
         BRXEQ     X0,X0,SUMFV9#       .PUNT
SUMFV8#  BSS       0
         ADDF      X4,X7               .R + V(1)
         ADDF      X4,X8               .R + V(2)
         ADDF      X4,X9               .R + V(3)
         ADDF      X4,XA               .R + V(4)
         ADDF      X4,X6               .R + V(0)
SUMFV9#  BSS       0
         ENTE      X2,0E6(16)
         CPYSX     X2,X2               .READ USER MASK
         ENTE      X1,043(16)
         CPYSX     X1,X1               .READ UCR
         ANDX      X2,X1
         ENTE      X1,017F(16)         .CONDITIONS OF INTEREST
         ANDX      X2,X1               .SAVE
         ENTP      X1,4
         BRXEQ     X1,X2,SUMFV11#      .IF INDEFINITE ONLY
SUMFV10# BSS       0
         SXI       X4,A2,X5,17*8       .SAVE RESULT
SUMFV11# BSS       0
         BRXEQ     X0,X0,VTEXIT#       .PUNT
.
. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
.
VTISE#   BSS       0
         HALT                          .CAUSE INS SPEC ERROR
.
VTEXIT#  BSS       0
         ENTL      X0,043(16)          .ADD(UCR)
         CPYSX     X1,X0               .READ UCR
         ENTE      X0,0EFFF(16)        .
         ANDX      X1,X0               .IGNORE PIT
         CPYXX     X2,X1               .
         ENTL      X0,0E6(16)          .ADD(UM)
         CPYSX     X0,X0               .READ UM
         ANDX      X2,X0               .CHECK FOR POTENTIAL TRAPS
         BRXEQ     X2,X0,VTEX50#       .BRANCH IF NONE
         ENTE      X2,0038(16)         .P+ INTERRUPTS
         ANDX      X2,X1               .
         BRXeq     X2,X0,VTEX55#       .BRANCH IF not P+
VTEX50#  BSS       0
         lx        x1,a2,0             .Increment P in SFSA.
         incx      x1,4
         sx        x1,a2,0
vtex55#  bss       0
         RETURN
VTRAPE#  BSS       0
VTRAPE#  ALIAS     PMA$VECTOR_SIMULATOR_END
         END
*DECK DECK=PMM$MANAGE_CONDITION_STACKS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Control - Program Conditions' ??
MODULE pmm$manage_condition_stacks;


{   PURPOSE:
{     The purpose of this module is to confine the knowledge of the
{     condition environment stack and the delayed condition (ring alarm)
{     stacks.  All accesses to these stacks are via procedures in this module.

{   DESIGN:
{     This module is designed to execute in rings 2 - 3.  The XDCL, #GATEed
{     procedures have a call bracket of 13.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osd$conditions
*copyc osd$registers
*copyc osd$virtual_address
*copyc ose$heap_full_exceptions
*copyc oss$task_private
*copyc ost$caller_identifier
*copyc ost$name
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc ost$virtual_machine_identifier
*copyc pmc$program_management_id
*copyc pmt$condition
*copyc pmt$established_handler
?? POP ??
*copyc i#disable_traps
*copyc i#restore_traps
*copyc osp$set_status_abnormal
*copyc osp$verify_system_privilege
*copyc pmp$delete_current_environ_r2
*copyc pmp$delete_environment_r2
*copyc pmp$get_current_environ_r2
*copyc pmp$log
*copyc pmp$post_current_environ_r2
*copyc syp$enable_job_free_flag
*copyc tmp$find_ring_crossing_frame

*copyc osv$task_private_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
*copyc pmt$condition_environment
*copyc pmt$delayed_condition
?? OLDTITLE ??
?? NEWTITLE := 'Manage Condition Environment Stack', EJECT ??

{    the condition_environment_stack in the tcb exists to support the
{    PMP$CONTINUE_TO_CAUSE Program Interface.
{
{    NOTE:
{      The design relies upon the assumption that NOS/VE procedures
{      residing in rings 1 - 3 will not overwrite the contents of the
{      condition_environment_stack.  If in fact this
{      assumption is not true and the condition_environment_stack is
{      overwritten, the consequence is dependent on 1) the procedure
{      which is disrupted by the overwrite and 2) the ring of that procedure's
{      caller:
{      1. PMP$POST_CURRENT_ENVIRONMENT
{         R2. broken task --> osp$system_error
{         R3 - R15. broken task --> pmp$exit
{
{      2. PMP$DELETE_CURRENT_ENVIRONMENT
{         R2. pme$stack_overwritten --> osp$system_error
{         R3 - R15. pme$stack_overwritten --> pmp$abort
{
{      3. PMP$GET_CURRENT_ENVIRONMENT
{         R2 - R15. abnormal status (pme$no_condition_to_continue) from
{                   pmp$continue_to_cause
{
{      4. PMP$DELETE_ENVIRONMENT
{         R2. pme$stack_overwritten --> osp$system_error
{         R3 - R15. pme$stack_overwritten --> pmp$abort
{
{  - The caller's ring is always put into the condition_environment_stack.
{    This is to insure that the caller is not given more privelege than he
{    currently has.

?? NEWTITLE := '[XDCL, #GATE] pmp$get_current_environment', EJECT ??
*copy pmh$get_current_environment

  PROCEDURE [XDCL, #GATE] pmp$get_current_environment
    (VAR environment: pmt$condition_environment;
     VAR environment_present: boolean;
     VAR status: ost$status);

    VAR
      caller: ost$caller_identifier;

    #CALLER_ID (caller);
    status.normal := TRUE;

    osp$verify_system_privilege;
    pmp$get_current_environ_r2 (caller.ring, environment, environment_present, status);

  PROCEND pmp$get_current_environment;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$delete_current_environment', EJECT ??

{ PURPOSE:
{   Pop the current environment from the condition_environment_stack.

  PROCEDURE [XDCL, #GATE] pmp$delete_current_environment
    (VAR status: ost$status);

    VAR
      caller: ost$caller_identifier;

    #CALLER_ID (caller);
    status.normal := TRUE;

    osp$verify_system_privilege;
    pmp$delete_current_environ_r2 (caller.ring, status);

  PROCEND pmp$delete_current_environment;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$delete_environment', EJECT ??
*copy pmh$delete_environment

  PROCEDURE [XDCL, #GATE] pmp$delete_environment
    (    critical_frame: ^ost$stack_frame_save_area;
     VAR status: ost$status);

    VAR
      caller: ost$caller_identifier;

    #CALLER_ID (caller);
    status.normal := TRUE;

    osp$verify_system_privilege;
    pmp$delete_environment_r2 (caller.ring, critical_frame, status);

  PROCEND pmp$delete_environment;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$post_current_environment', EJECT ??

{ PURPOSE:
{   push the environment onto the condition_environment_stack contained in the
{   task_control_block

  PROCEDURE [XDCL, #GATE] pmp$post_current_environment
    (    environment {input, output} : ^pmt$condition_environment);

    VAR
      caller: ost$caller_identifier,
      environment_stack: ^pmt$condition_environment;

    #CALLER_ID (caller);

    osp$verify_system_privilege;
    environment_stack := environment;
    pmp$post_current_environment_r2 (caller.ring, environment_stack);

  PROCEND pmp$post_current_environment;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'Manage Delayed Condition Stacks', EJECT ??

  VAR
    pmv$activate_ring_alarm: [STATIC, oss$task_private {stack} ] array [osc$os_ring_1 .. osc$user_ring_1] of ^
          {BOUND} pmt$delayed_condition := [REP osc$user_ring_1 of NIL],

    pmv$ring_alarm: [STATIC, oss$task_private {stack} ] array [osc$tmtr_ring .. osc$user_ring_4] of
          ^ {BOUND} pmt$delayed_condition := [REP (osc$user_ring_4 - osc$tmtr_ring + 1) of NIL];

?? NEWTITLE := '[XDCL, #GATE] pmp$activate_ring_alarm', EJECT ??
*copy pmh$activate_ring_alarm

  PROCEDURE [XDCL, #GATE] pmp$activate_ring_alarm
    (VAR activate_ring_alarm: boolean;
     VAR status: ost$status);

    VAR
      activate_stack: ^ {BOUND} pmt$delayed_condition,
      caller_id: ost$caller_identifier,
      alarm_ring: ost$ring,
      x_frame: ^ost$stack_frame_save_area,
      callers_frame: ^ost$stack_frame_save_area,
      starting_frame: ^ost$stack_frame_save_area;

    #CALLER_ID (caller_id);
    osp$verify_system_privilege;
    callers_frame := #PREVIOUS_SAVE_AREA ();
    starting_frame := callers_frame^.minimum_save_area.a2_previous_save_area;
    tmp$find_ring_crossing_frame (starting_frame, x_frame, status);
    IF status.normal THEN
      alarm_ring := #RING (x_frame^.minimum_save_area.a2_previous_save_area);
      IF (pmv$activate_ring_alarm [caller_id.ring] <> NIL) THEN
        IF (pmv$ring_alarm [alarm_ring] = NIL) THEN
          pmv$ring_alarm [alarm_ring] := pmv$activate_ring_alarm [caller_id.ring];
        ELSE
          activate_stack := pmv$activate_ring_alarm [caller_id.ring];
          WHILE (activate_stack^.next_delayed_condition <> NIL) DO
            activate_stack := activate_stack^.next_delayed_condition;
          WHILEND;
          activate_stack^.next_delayed_condition := pmv$ring_alarm [alarm_ring];
          pmv$ring_alarm [alarm_ring] := pmv$activate_ring_alarm [caller_id.ring];
        IFEND;

        pmv$activate_ring_alarm [caller_id.ring] := NIL;
      IFEND;
      activate_ring_alarm := (pmv$ring_alarm [alarm_ring] <> NIL);
    ELSE
      activate_ring_alarm := FALSE;
    IFEND;
  PROCEND pmp$activate_ring_alarm;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$enable_job_free_flag', EJECT ??


{ PURPOSE:
{   The purpose of this request is to call syp$enable_job_free_flag.

{ NOTE:
{   This is only called from PMM$TASKING_HELPER_PROCEDURES which is assembler.

  PROCEDURE [XDCL, #GATE] pmp$enable_job_free_flag;

    osp$verify_system_privilege;
    syp$enable_job_free_flag;
  PROCEND pmp$enable_job_free_flag;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_delayed_condition', EJECT ??
*copy pmh$get_delayed_condition

  PROCEDURE [XDCL, #GATE] pmp$get_delayed_condition
    (VAR delayed_condition: pmt$delayed_condition;
     VAR condition_present: boolean;
     VAR another_condition_present: boolean);

    VAR
      traps: 0 .. 3,
      free_dc: ^ {BOUND} pmt$delayed_condition,
      caller_id: ost$caller_identifier;

    #CALLER_ID (caller_id);
    osp$verify_system_privilege;
    i#disable_traps (traps);
    IF (pmv$ring_alarm [caller_id.ring] <> NIL) THEN
      free_dc := pmv$ring_alarm [caller_id.ring];
      pmv$ring_alarm [caller_id.ring] := pmv$ring_alarm [caller_id.ring]^.next_delayed_condition;
      i#restore_traps (traps);
      delayed_condition := free_dc^;
      condition_present := TRUE;
      another_condition_present := (pmv$ring_alarm [caller_id.ring] <> NIL);
      FREE free_dc IN osv$task_private_heap^;
    ELSE
      i#restore_traps (traps);
      condition_present := FALSE;
      another_condition_present := FALSE;
    IFEND;
  PROCEND pmp$get_delayed_condition;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$post_delayed_condition', EJECT ??
*copy pmh$post_delayed_condition

  PROCEDURE [XDCL, #GATE] pmp$post_delayed_condition
    (    delayed_condition: ^pmt$delayed_condition;
     VAR status: ost$status);

    VAR
      dc: ^ {BOUND} pmt$delayed_condition,
      caller_id: ost$caller_identifier;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    osp$verify_system_privilege;
    ALLOCATE dc {: [delayed_condition^.delayed_condition]} IN osv$task_private_heap^;
    CASE delayed_condition^.delayed_condition OF
    = debug =
      dc^.delayed_condition := debug;
      dc^.condition := delayed_condition^.condition;
      dc^.condition_save_area := delayed_condition^.condition_save_area;
      dc^.debug_index := delayed_condition^.debug_index;
    = job_resource =
      dc^.delayed_condition := job_resource;
      dc^.job_resource_condition := delayed_condition^.job_resource_condition;
    = interactive =
      dc^.delayed_condition := interactive;
      dc^.interactive_condition := delayed_condition^.interactive_condition;
    = process_interval_timer =
      dc^.delayed_condition := process_interval_timer;
    = user_condition =
      dc^ := delayed_condition^;
    CASEND;
    dc^.next_delayed_condition := pmv$activate_ring_alarm [caller_id.ring];
    pmv$activate_ring_alarm [caller_id.ring] := dc;
  PROCEND pmp$post_delayed_condition;
?? OLDTITLE ??
?? OLDTITLE ??
MODEND pmm$manage_condition_stacks;
*DECK DECK=PMM$MANAGE_CONDITION_STACKS_R2 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Control - Program Conditions' ??
?? NEWTITLE := '  Global System Declarations' ??
MODULE pmm$manage_condition_stacks_r2;


{   PURPOSE:
{     The purpose of this module is to confine access to the
{     condition environment stack int the task_control_block.
{     All accesses to this stack are via procedures in this module.

{   DESIGN:
{     This module is designed to execute in ring 2. This is necessary to
{     handle ring 2 conditions (ie. interactive).
?? EJECT ??
*copyc OSP$SET_STATUS_ABNORMAL
*copyc oss$job_paged_literal
*copyc OST$CALLER_IDENTIFIER
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc OST$STATUS
*copyc PMC$PROGRAM_MANAGEMENT_ID
*copyc PMP$ESTABLISH_CONDITION_HANDLER
*copyc pmp$find_executing_task_tcb
*copyc PMT$CONDITION
*copyc PMT$CONDITION_ENVIRONMENT
*copyc PMT$ESTABLISHED_HANDLER

  TYPE
    comparable_pointer = 0 .. 0ffffffffffff(16);

  VAR
    environment_overwrite: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
          [pmc$system_conditions, $pmt$system_conditions [pmc$access_violation, pmc$invalid_segment_ring_0,
          pmc$address_specification], * ];


?? NEWTITLE := '  [XDCL, #GATE] pmp$post_current_environment_r2' ??
?? EJECT ??


  PROCEDURE [XDCL, #GATE] pmp$post_current_environment_r2
    (    condition_ring: ost$ring;
     VAR environment: ^pmt$condition_environment);

    VAR
      tcb: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb);

    {push the environment onto the condition_environment_stack}

    environment^.next_environment := tcb^.condition_environment_stack;
    tcb^.condition_environment_stack := #ADDRESS (condition_ring, #SEGMENT (environment),
          #OFFSET (environment));

  PROCEND pmp$post_current_environment_r2;
?? TITLE := '  [XDCL, #GATE] pmp$delete_current_environ_r2 ' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$delete_current_environ_r2
    (    condition_ring: ost$ring;
     VAR status: ost$status);

    {The purpose of this procedure is to pop the current environment from the
    { condition_environment_stack

    PROCEDURE dispose_of_environment_overwrit (condition: pmt$condition;
          condition_descriptor: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR ignore_status: ost$status);

{        PURPOSE:
{          This procedure ensures that if the environment in the calling
{          stack segment has been overwritten, that the condition environment
{          stack is truncated - allowing further condition processing.


      VAR
        environment_stack: ^pmt$condition_environment,
        tcb: ^pmt$task_control_block;

      pmp$find_executing_task_tcb (tcb);

      environment_stack := #address (#ring(tcb^.condition_environment_stack), #segment
            (tcb^.condition_environment_stack), #offset (tcb^.condition_environment_stack));
      {The environment at top of stack is the environment of this condition handler - next_environment is the
      {faultly environment.
      environment_stack^.next_environment := NIL;
      osp$set_status_abnormal (pmc$program_management_id, pme$stack_overwritten, '', status);
      EXIT pmp$delete_current_environ_r2;
    PROCEND dispose_of_environment_overwrit;

?? EJECT ??
    VAR
      descriptor: pmt$established_handler,
      environment_stack: ^pmt$condition_environment,
      ignore_status: ost$status,
      tcb: ^pmt$task_control_block;

    status.normal := TRUE;
    pmp$establish_condition_handler (environment_overwrite, ^dispose_of_environment_overwrit, ^descriptor,
          ignore_status);

    pmp$find_executing_task_tcb (tcb);

    environment_stack := #ADDRESS (condition_ring,
          #SEGMENT (tcb^.condition_environment_stack),
          #OFFSET (tcb^.condition_environment_stack));
    tcb^.condition_environment_stack := environment_stack^.next_environment;

  PROCEND pmp$delete_current_environ_r2;
?? TITLE := '  [XDCL, #GATE] pmp$get_current_environ_r2 ' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_current_environ_r2
    (   condition_ring: ost$ring;
     VAR environment: pmt$condition_environment;
     VAR environment_present: boolean;
     VAR status: ost$status);

    PROCEDURE dispose_of_environment_overwrit
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR ignore_status: ost$status);

{        PURPOSE:
{          This procedure ensures that if the environment in the calling
{          stack segment has been overwritten, that the condition environment
{          stack is truncated - allowing further condition processing.

      VAR
        tcb: ^pmt$task_control_block;

      pmp$find_executing_task_tcb (tcb);

      {The environment at top of stack is the environment of this condition handler - next_environment is the
      {faultly environment.
      tcb^.condition_environment_stack^.next_environment := NIL;
      osp$set_status_abnormal (pmc$program_management_id, pme$stack_overwritten, '', status);
      environment_present := FALSE;
      EXIT pmp$get_current_environ_r2;
    PROCEND dispose_of_environment_overwrit;
?? EJECT ??
    VAR
      descriptor: pmt$established_handler,
      environment_stack: ^pmt$condition_environment,
      ignore_status: ost$status,
      tcb: ^pmt$task_control_block;

    status.normal := TRUE;
    pmp$establish_condition_handler (environment_overwrite, ^dispose_of_environment_overwrit, ^descriptor,
          ignore_status);

    pmp$find_executing_task_tcb (tcb);

    IF (tcb^.condition_environment_stack <> NIL) THEN
      IF (#RING (tcb^.condition_environment_stack) = condition_ring) THEN
        IF (#SEGMENT (tcb^.condition_environment_stack) = #SEGMENT (^environment)) THEN
          environment_stack := #ADDRESS (condition_ring, #SEGMENT (tcb^.condition_environment_stack),
                #OFFSET (tcb^.condition_environment_stack));
          environment := environment_stack^;
          environment_present := TRUE;
        ELSE
          {An environment was previously overwritten - there is no condition to continue, the environment
          {stack is truncated.
          environment_present := FALSE;
          tcb^.condition_environment_stack := NIL;
        IFEND;
      ELSEIF (#RING (tcb^.condition_environment_stack) > condition_ring) THEN
        {The environment at top of stack is from a higher ring - there is no condition to continue. Either the
        {condition arose in higher ring; or the previous execution of a condition handler in a higher ring
        {performed a nonlocal exit by modifying its own A2; or an environment was previously overwritten - a
        {judgement cannot be made at this point.
        environment_present := FALSE;
      ELSE
        {An environment was previously overwritten or the previous execution of a condition handler in a lower
        {ring performed a nonlocal exit by modifying its own A2 - the environment stack is truncated; there is
        {no condition to continue.
        environment_present := FALSE;
        tcb^.condition_environment_stack := NIL;
      IFEND;
    ELSE
      environment_present := FALSE;
    IFEND;

  PROCEND pmp$get_current_environ_r2;
?? TITLE := '  [XDCL, #GATE] pmp$delete_environment_r2' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$delete_environment_r2
    (    condition_ring: ost$ring;
         critical_frame: ^ost$stack_frame_save_area;
     VAR status: ost$status);

    PROCEDURE dispose_of_environment_overwrit
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR ignore_status: ost$status);

      VAR
        tcb: ^pmt$task_control_block;

{        PURPOSE:
{          This procedure ensures that if an environment in the calling
{          stack segment has been overwritten, that the condition environment
{          stack is truncated - allowing further condition processing.

      pmp$find_executing_task_tcb (tcb);

      IF (relink = ^tcb^.condition_environment_stack) THEN
        {The environment formerly at the top of stack has been overwritten. The environment at top of stack is
        {the environment of this condition handler - next_environment is the faultly environment.
        relink^^.next_environment := NIL;
      ELSE
        {An environment at other than top of stack has been overwritten.
        relink^ := NIL;
      IFEND;
      osp$set_status_abnormal (pmc$program_management_id, pme$stack_overwritten, '', status);
      EXIT pmp$delete_environment_r2;
    PROCEND dispose_of_environment_overwrit;


    VAR
      converter: record
        case 0 .. 1 of
        = 0 =
          cell_pointer: ^cell,
        = 1 =
          comparable_pointer: comparable_pointer,
        casend,
      recend,

      descriptor: pmt$established_handler,
      deleted: boolean,
      scan_environment: ^pmt$condition_environment,
      relink: ^^pmt$condition_environment,
      environment_stack: ^pmt$condition_environment,

      end_of_frame: comparable_pointer,
      start_of_frame: comparable_pointer,
      scan: comparable_pointer,
      tcb: ^pmt$task_control_block,
      ignore_status: ost$status;

    status.normal := TRUE;

    pmp$find_executing_task_tcb (tcb);

    relink := ^tcb^.condition_environment_stack; { this assignment is needed for the condition handler }
    pmp$establish_condition_handler (environment_overwrite, ^dispose_of_environment_overwrit, ^descriptor,
          ignore_status);


    environment_stack := #ADDRESS (condition_ring, #SEGMENT (tcb^.condition_environment_stack),
          #OFFSET (tcb^.condition_environment_stack));
    converter.cell_pointer := critical_frame;
    end_of_frame := converter.comparable_pointer;
    converter.cell_pointer := critical_frame^.minimum_save_area.a1_current_stack_frame;
    start_of_frame := converter.comparable_pointer;
    scan_environment := environment_stack^.next_environment;
    relink := ^environment_stack^.next_environment;
    deleted := FALSE;
    {find the environment associated with the critical *frame}
    WHILE NOT deleted AND (scan_environment <> NIL) DO
      converter.cell_pointer := scan_environment;
      scan := converter.comparable_pointer;
      IF (scan < end_of_frame) AND (scan > start_of_frame) THEN
        {delete the condition environment from the environment stack}
        relink^ := scan_environment^.next_environment;
        deleted := TRUE;
      ELSE
        scan_environment := scan_environment^.next_environment;
        relink := ^relink^^.next_environment;
      IFEND;
    WHILEND;
  PROCEND pmp$delete_environment_r2;

MODEND pmm$manage_condition_stacks_r2;
*DECK DECK=PMM$MANAGE_LOCAL_QUEUES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Control - Job Local Queues' ??
MODULE pmm$manage_local_queues;




{   PURPOSE:
{     The purpose of this module is to provide the interfaces to NOS/VE job
{     local queues (See: NOS/VE Program Management - Program Communications).
{     With the exception of pmm/p$status_queues_defined, this module contains
{     all knowledge of job local queues.

{   DESIGN:
{     The procedures contained in this module have an execution bracket of 1, 3
{     and a call bracket of 13.  All XDCL'd procedures are gated.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ose$heap_full_exceptions
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc ost$caller_identifier
*copyc ost$heap
*copyc ost$wait
*copyc pmd$local_queues
*copyc pme$local_queue_exceptions
*copyc pmk$keypoints
*copyc pmt$queue_limits
*copyc pmt$queue_status
*copyc tmc$wait_times
?? POP ??
*copyc clp$validate_name
*copyc mmp$fetch_segment_attributes
*copyc mmp$verify_access
*copyc osp$clear_job_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$initialize_sig_lock
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$test_sig_lock
*copyc osp$verify_system_privilege
*copyc pmp$continue_to_cause
*copyc pmp$exit
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_task_id
*copyc pmp$long_term_wait
*copyc pmp$ready_task

*copyc osv$task_shared_heap
*copyc pmv$queue_definition_table
?? OLDTITLE ??
?? NEWTITLE := 'disconnect_task_from_queue', EJECT ??

{ PURPOSE:
{   Disconnect the task from the queue.
{
{ NOTE:
{   This procedure expects the connection lock to be set on entry and
{   on exit the connection lock is unlocked (cleared).

  PROCEDURE disconnect_task_from_queue
    (    queue: ^pmt$queue_specification;
     VAR status: ost$status);

?? NEWTITLE := 'delete_task_from_wait_list', EJECT ??

{ PURPOSE:
{   Delete the task from the wait list of the queue.

    PROCEDURE delete_task_from_wait_list
      (    queue: ^pmt$queue_specification);

      VAR
        next_waiting_task: ^pmt$queued_task,
        task: ost$global_task_id,
        waiting_task: ^^pmt$queued_task;

      pmp$get_executing_task_gtid (task);
      waiting_task := ^queue^.control.waiting_task_queue.dequeue;
      WHILE (waiting_task^ <> NIL) DO
        IF (waiting_task^^.task = task) THEN
          next_waiting_task := waiting_task^^.next_task;
          FREE waiting_task^ IN osv$task_shared_heap^;
          waiting_task^ := next_waiting_task;
          queue^.control.waiting_task_queue.number_waiting_tasks :=
                queue^.control.waiting_task_queue.number_waiting_tasks - 1;
          IF (waiting_task^ = NIL) THEN
            queue^.control.waiting_task_queue.enqueue := waiting_task;
          IFEND;
        ELSE
          waiting_task := ^waiting_task^^.next_task;
        IFEND;
      WHILEND;
    PROCEND delete_task_from_wait_list;
?? OLDTITLE, EJECT ??
?? EJECT ??

    VAR
      connected_task: ^^pmt$queue_connected_task,
      ignore_status: ost$status,
      local_task_id: pmt$task_id,
      next_connected_task: ^pmt$queue_connected_task;

    status.normal := TRUE;
    connected_task := ^queue^.control.connected_task_list;
    IF (connected_task^ = NIL) THEN
      osp$clear_job_signature_lock (queue^.control.connection_lock);
      osp$set_status_condition (pme$unknown_queue_identifier, status);
      RETURN;
    IFEND;

    pmp$get_task_id (local_task_id, ignore_status);
    WHILE (connected_task^ <> NIL) AND (connected_task^^.task <> local_task_id) DO
      connected_task := ^connected_task^^.next_connected_task;
    WHILEND;
    IF (connected_task^ <> NIL) THEN
      next_connected_task := connected_task^^.next_connected_task;
      FREE connected_task^ IN osv$task_shared_heap^;
      connected_task^ := next_connected_task;
      osp$set_job_signature_lock (queue^.control.waiting_task_lock);
      osp$clear_job_signature_lock (queue^.control.connection_lock);
      IF (queue^.control.waiting_task_queue.number_waiting_tasks > 0) THEN
        delete_task_from_wait_list (queue);
      IFEND;
      osp$clear_job_signature_lock (queue^.control.waiting_task_lock);
    ELSE
      osp$clear_job_signature_lock (queue^.control.connection_lock);
      osp$set_status_condition (pme$unknown_queue_identifier, status);
    IFEND;
  PROCEND disconnect_task_from_queue;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$await_nonempty_queue', EJECT ??
*copyc pmh$await_nonempty_queue

  PROCEDURE [XDCL] pmp$await_nonempty_queue
    (    qid: pmt$queue_connection;
         requestor_ring: ost$ring;
     VAR nonempty_queue: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'set_await_message', EJECT ??

{ PURPOSE:
{   Add an entry to the queue's wait list for this task.

    PROCEDURE set_await_message
      (    queue: ^pmt$queue_specification;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status,
        q_limits: pmt$queue_limits,
        waiting_task: ^pmt$queued_task,
        x_global_task_id: ost$global_task_id;

      status.normal := TRUE;
      pmp$get_executing_task_gtid (x_global_task_id);
      osp$set_job_signature_lock (queue^.control.waiting_task_lock);
      osp$clear_job_signature_lock (queue^.control.message_queue_lock);
      waiting_task := queue^.control.waiting_task_queue.dequeue;
      WHILE (waiting_task <> NIL) AND (waiting_task^.task = x_global_task_id) DO
        waiting_task := waiting_task^.next_task;
      WHILEND;
      IF (waiting_task = NIL) THEN
        pmp$get_queue_limits (q_limits, ignore_status);
        IF (queue^.control.waiting_task_queue.number_waiting_tasks < q_limits.maximum_messages) THEN
          ALLOCATE queue^.control.waiting_task_queue.enqueue^ IN osv$task_shared_heap^;
          queue^.control.waiting_task_queue.enqueue^^.next_task := NIL;
          queue^.control.waiting_task_queue.enqueue^^.task := x_global_task_id;
          queue^.control.waiting_task_queue.enqueue := ^queue^.control.waiting_task_queue.enqueue^^.next_task;
          queue^.control.waiting_task_queue.number_waiting_tasks :=
                queue^.control.waiting_task_queue.number_waiting_tasks + 1;
        ELSE
          osp$set_status_abnormal (pmc$program_management_id, pme$maximum_waiting_tasks, queue^.name, status);
        IFEND;
      IFEND;
      osp$clear_job_signature_lock (queue^.control.waiting_task_lock);
    PROCEND set_await_message;
?? OLDTITLE, EJECT ??

    VAR
      caller: ost$caller_identifier,
      connected_task: ^pmt$queue_connected_task,
      ignore_status: ost$status,
      local_task_id: pmt$task_id;

    status.normal := TRUE;
    IF (pmv$queue_definition_table.queues = NIL) OR (qid < 1) OR
          (qid > UPPERBOUND (pmv$queue_definition_table.queues^)) THEN
      osp$set_status_condition (pme$unknown_queue_identifier, status);
      RETURN;
    IFEND;

    osp$set_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
    IF (pmv$queue_definition_table.queues^ [qid].definition = NIL) THEN
      osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
      osp$set_status_condition (pme$unknown_queue_identifier, status);
      RETURN;
    IFEND;

    IF (requestor_ring > pmv$queue_definition_table.queues^ [qid].definition^.usage_bracket) THEN
      osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
      osp$set_status_abnormal (pmc$program_management_id, pme$usage_bracket_error,
            pmv$queue_definition_table.queues^ [qid].definition^.name, status);
      RETURN;
    IFEND;

    osp$set_job_signature_lock (pmv$queue_definition_table.queues^ [qid].definition^.control.connection_lock);
    osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
    connected_task := pmv$queue_definition_table.queues^ [qid].definition^.control.connected_task_list;
    pmp$get_task_id (local_task_id, ignore_status);
    WHILE (connected_task <> NIL) AND (connected_task^.task <> local_task_id) DO
      connected_task := connected_task^.next_connected_task;
    WHILEND;
    osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].definition^.control.
          connection_lock);
    IF (connected_task <> NIL) THEN
      osp$set_job_signature_lock (pmv$queue_definition_table.queues^ [qid].definition^.control.
            message_queue_lock);
      IF (pmv$queue_definition_table.queues^ [qid].definition^.control.message_queue.number_messages > 0) THEN
        nonempty_queue := TRUE;
        osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].definition^.control.
              message_queue_lock);
      ELSE
        set_await_message (pmv$queue_definition_table.queues^ [qid].definition, status);
      IFEND;
    ELSE
      osp$set_status_condition (pme$unknown_queue_identifier, status);
    IFEND;
  PROCEND pmp$await_nonempty_queue;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$connect_queue', EJECT ??
*copyc pmh$connect_queue

  PROCEDURE [XDCL, #GATE] pmp$connect_queue
    (    name: pmt$queue_name;
     VAR qid: pmt$queue_connection;
     VAR status: ost$status);

?? NEWTITLE := 'connect_task_to_queue', EJECT ??

{ PURPOSE:
{   Add task's id to the connected task list for the queue.

    PROCEDURE connect_task_to_queue
      (    queue: ^pmt$queue_specification;
       VAR connected {input, output} : boolean;
       VAR status: ost$status);

      VAR
        connected_task: ^pmt$queue_connected_task,
        ignore_status: ost$status,
        local_task_id: pmt$task_id,
        number_connected: pmt$connected_tasks_per_queue,
        queue_limits: pmt$queue_limits;

      status.normal := TRUE;
      pmp$get_task_id (local_task_id, ignore_status);
      connected_task := queue^.control.connected_task_list;
      number_connected := 1;
      WHILE connected_task <> NIL DO
        IF (connected_task^.task = local_task_id) THEN
          osp$set_status_abnormal (pmc$program_management_id, pme$task_already_connected, queue^.name,
                status);
          connected := TRUE;
          RETURN;
        IFEND;
        number_connected := number_connected + 1;
        connected_task := connected_task^.next_connected_task;
      WHILEND;

      pmp$get_queue_limits (queue_limits, ignore_status);
      IF (number_connected < queue_limits.maximum_connected) THEN
        ALLOCATE connected_task IN osv$task_shared_heap^;
        connected_task^.task := local_task_id;
        connected_task^.next_connected_task := queue^.control.connected_task_list;
        queue^.control.connected_task_list := connected_task;
        connected := TRUE;
      ELSE
        osp$set_status_abnormal (pmc$program_management_id, pme$maximum_tasks_connected, queue^.name, status);
      IFEND;
    PROCEND connect_task_to_queue;
?? OLDTITLE, EJECT ??

    VAR
      caller: ost$caller_identifier,
      connect_name: ost$name,
      connect_status: ost$status,
      connected: boolean,
      ignore_status: ost$status,
      q_index: pmt$queue_connection,
      valid_name: boolean;

    #KEYPOINT (osk$entry, 0, pmk$connect_queue);
    #CALLER_ID (caller);
    status.normal := TRUE;
    connect_status.normal := TRUE;
    connected := FALSE;
    qid := LOWERVALUE (pmt$queue_connection);

  /connect_queue/
    BEGIN
      IF (pmv$queue_definition_table.queues = NIL) THEN
        osp$set_status_abnormal (pmc$program_management_id, pme$unknown_queue_name, name, connect_status);
        EXIT /connect_queue/;
      IFEND;

      clp$validate_name (name, connect_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal (pmc$program_management_id, pme$incorrect_queue_name, name, connect_status);
        EXIT /connect_queue/;
      IFEND;

      FOR q_index := 1 TO UPPERBOUND (pmv$queue_definition_table.queues^) DO
        osp$set_job_signature_lock (pmv$queue_definition_table.queues^ [q_index].removal_lock);
        IF (pmv$queue_definition_table.queues^ [q_index].definition <> NIL) AND
              (pmv$queue_definition_table.queues^ [q_index].definition^.name = connect_name) THEN
          IF (caller.ring <= pmv$queue_definition_table.queues^ [q_index].definition^.usage_bracket) THEN
            osp$set_job_signature_lock (pmv$queue_definition_table.queues^ [q_index].definition^.control.
                  connection_lock);
            connect_task_to_queue (pmv$queue_definition_table.queues^ [q_index].definition, connected,
                  connect_status);
            osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [q_index].definition^.control.
                  connection_lock);
            IF NOT connect_status.normal THEN
              connect_status := connect_status;
            IFEND;
            IF connected THEN
              qid := q_index;
            IFEND;
          ELSE
            osp$set_status_abnormal (pmc$program_management_id, pme$usage_bracket_error, connect_name,
                  connect_status);
          IFEND;
          osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [q_index].removal_lock);
          EXIT /connect_queue/;
        IFEND;
        osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [q_index].removal_lock);
      FOREND;
      osp$set_status_abnormal (pmc$program_management_id, pme$unknown_queue_name, connect_name,
            connect_status);
    END /connect_queue/;
    IF NOT connect_status.normal THEN
      status := connect_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pmk$connect_queue);
  PROCEND pmp$connect_queue;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$define_queue', EJECT ??
*copyc pmh$define_queue

  PROCEDURE [XDCL, #GATE] pmp$define_queue
    (    name: pmt$queue_name;
         removal_bracket: ost$ring;
         usage_bracket: ost$ring;
     VAR status: ost$status);

    VAR
      define_status: ost$status;

?? NEWTITLE := 'initialize_local_queues', EJECT ??

{ PURPOSE:
{   Initialize the task's local queue table.

    PROCEDURE initialize_local_queues;

      VAR
        ignore_status: ost$status,
        q_index: pmt$queues_per_job,
        q_limits: pmt$queue_limits;

      pmp$get_queue_limits (q_limits, ignore_status);
      ALLOCATE pmv$queue_definition_table.queues: [1 .. q_limits.maximum_queues] IN osv$task_shared_heap^;
      FOR q_index := 1 TO UPPERBOUND (pmv$queue_definition_table.queues^) DO
        pmv$queue_definition_table.queues^ [q_index].definition := NIL;
        osp$initialize_sig_lock (pmv$queue_definition_table.queues^ [q_index].removal_lock);
      FOREND;
    PROCEND initialize_local_queues;
?? OLDTITLE, EJECT ??

    VAR
      caller: ost$caller_identifier,
      define_name: ost$name,
      free_entry: boolean,
      free_index: pmt$queues_per_job,
      ignore_status: ost$status,
      q_index: 0 .. (pmc$max_queues_per_job + 1),
      queue_definition: ^pmt$queue_specification,
      unlocked: ost$signature_lock,
      valid_name: boolean;

    #KEYPOINT (osk$entry, 0, pmk$define_queue);
    #CALLER_ID (caller);
    status.normal := TRUE;
    define_status.normal := TRUE;

    clp$validate_name (name, define_name, valid_name);
    IF NOT valid_name THEN
      osp$set_status_abnormal (pmc$program_management_id, pme$incorrect_queue_name, name, status);
    ELSEIF (usage_bracket < removal_bracket) THEN
      osp$set_status_abnormal (pmc$program_management_id, pme$usage_lt_removal_bracket, define_name, status);
    ELSEIF (caller.ring > removal_bracket) THEN
      osp$set_status_abnormal (pmc$program_management_id, pme$caller_gt_removal_bracket, define_name, status);
    ELSE { Parameters are valid
      ALLOCATE queue_definition IN osv$task_shared_heap^;
      osp$initialize_sig_lock (unlocked);
      queue_definition^.name := define_name;
      queue_definition^.removal_bracket := removal_bracket;
      queue_definition^.usage_bracket := usage_bracket;
      queue_definition^.control.connection_lock := unlocked;
      queue_definition^.control.connected_task_list := NIL;
      queue_definition^.control.message_queue_lock := unlocked;
      queue_definition^.control.message_queue.number_messages := 0;
      queue_definition^.control.message_queue.enqueue := ^queue_definition^.control.message_queue.dequeue;
      queue_definition^.control.message_queue.dequeue := NIL;
      queue_definition^.control.waiting_task_lock := unlocked;
      queue_definition^.control.waiting_task_queue.number_waiting_tasks := 0;
      queue_definition^.control.waiting_task_queue.enqueue :=
            ^queue_definition^.control.waiting_task_queue.dequeue;
      queue_definition^.control.waiting_task_queue.dequeue := NIL;
      osp$set_job_signature_lock (pmv$queue_definition_table.definition_lock);
      IF (pmv$queue_definition_table.queues = NIL) THEN
        initialize_local_queues;
      IFEND;
      free_entry := FALSE;

    /preset_table/
      FOR q_index := 1 TO UPPERBOUND (pmv$queue_definition_table.queues^) DO
        IF (pmv$queue_definition_table.queues^ [q_index].definition <> NIL) THEN
          IF (pmv$queue_definition_table.queues^ [q_index].definition^.name = define_name) THEN
            osp$set_status_abnormal (pmc$program_management_id, pme$queue_already_defined, define_name,
                  define_status);
            EXIT /preset_table/;
          IFEND;
        ELSEIF NOT free_entry THEN
          free_index := q_index;
          free_entry := TRUE;
        IFEND;
      FOREND /preset_table/;
      IF free_entry THEN
        osp$set_job_signature_lock (pmv$queue_definition_table.queues^ [free_index].removal_lock);
        pmv$queue_definition_table.queues^ [free_index].definition := queue_definition;
        osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [free_index].removal_lock);
      ELSE
        FREE queue_definition IN osv$task_shared_heap^;
        IF define_status.normal THEN
          osp$set_status_abnormal (pmc$program_management_id, pme$maximum_queues_defined, define_name,
                define_status);
        IFEND;
      IFEND;
      osp$clear_job_signature_lock (pmv$queue_definition_table.definition_lock);
      IF NOT define_status.normal THEN
        status := define_status;
      IFEND;
    IFEND;
    #KEYPOINT (osk$exit, 0, pmk$define_queue);
  PROCEND pmp$define_queue;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$disconnect_queue', EJECT ??
*copyc pmh$disconnect_queue

  PROCEDURE [XDCL, #GATE] pmp$disconnect_queue
    (    qid: pmt$queue_connection;
     VAR status: ost$status);

    VAR
      caller: ost$caller_identifier,
      disconnect_status: ost$status,
      ignore_status: ost$status;

    #KEYPOINT (osk$entry, 0, pmk$disconnect_queue);
    #CALLER_ID (caller);
    status.normal := TRUE;
    disconnect_status.normal := TRUE;
    IF (pmv$queue_definition_table.queues = NIL) OR (qid < 1) OR
          (qid > UPPERBOUND (pmv$queue_definition_table.queues^)) THEN
      osp$set_status_condition (pme$unknown_queue_identifier, status);
    ELSE
      osp$set_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
      IF (pmv$queue_definition_table.queues^ [qid].definition = NIL) THEN
        osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
        osp$set_status_condition (pme$unknown_queue_identifier, disconnect_status);
      ELSEIF (caller.ring > pmv$queue_definition_table.queues^ [qid].definition^.usage_bracket) THEN
        osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
        osp$set_status_condition (pme$usage_bracket_error, disconnect_status);
      ELSE { QID is valid.
        osp$set_job_signature_lock (pmv$queue_definition_table.queues^ [qid].definition^.control.
              connection_lock);
        osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
        disconnect_task_from_queue (pmv$queue_definition_table.queues^ [qid].definition, disconnect_status);
      IFEND;
      IF NOT disconnect_status.normal THEN
        status := disconnect_status;
      IFEND;
    IFEND;
    #KEYPOINT (osk$exit, 0, pmk$disconnect_queue);
  PROCEND pmp$disconnect_queue;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$disconnect_task_from_queues', EJECT ??
*copyc pmh$disconnect_task_from_queues

  PROCEDURE [XDCL] pmp$disconnect_task_from_queues;

    VAR
      qid: pmt$queue_connection,
      ignore_status: ost$status;

    IF (pmv$queue_definition_table.queues <> NIL) THEN
      FOR qid := 1 TO UPPERBOUND (pmv$queue_definition_table.queues^) DO
        osp$set_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
        IF (pmv$queue_definition_table.queues^ [qid].definition <> NIL) THEN
          osp$set_job_signature_lock (pmv$queue_definition_table.queues^ [qid].definition^.control.
                connection_lock);
          osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
          disconnect_task_from_queue (pmv$queue_definition_table.queues^ [qid].definition, ignore_status);
        ELSE
          osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
        IFEND;

      FOREND;
    IFEND;
  PROCEND pmp$disconnect_task_from_queues;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_queue_limits', EJECT ??
*copyc pmh$get_queue_limits

  PROCEDURE [XDCL, #GATE] pmp$get_queue_limits
    (VAR queue_limits: pmt$queue_limits;
     VAR status: ost$status);

{   **** the contents of this procedure are temporary until it is defined how
{   **** maximums are determined.

    #KEYPOINT (osk$entry, 0, pmk$get_queue_limits);
    status.normal := TRUE;
    queue_limits.maximum_queues := UPPERVALUE (pmt$queues_per_job);
    queue_limits.maximum_connected := UPPERVALUE (pmt$connected_tasks_per_queue);
    queue_limits.maximum_messages := UPPERVALUE (pmt$messages_per_queue);
    #KEYPOINT (osk$exit, 0, pmk$get_queue_limits);
  PROCEND pmp$get_queue_limits;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$receive_queue_message', EJECT ??
*copyc pmh$receive_queue_message

  PROCEDURE [XDCL, #GATE] pmp$receive_queue_message
    (    qid: pmt$queue_connection;
         wait: ost$wait;
     VAR message: pmt$message;
     VAR complete: boolean;
     VAR status: ost$status);

?? NEWTITLE := 'rqm_condition_handler', EJECT ??

{ PURPOSE:
{   Handle the interactive break, job resource, block exit, and job
{   recovery conditions.

    PROCEDURE rqm_condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           stack_frame_save_area_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF (condition.selector = jmc$job_resource_condition) OR
            (condition.selector = ifc$interactive_condition) OR
            ((condition.selector = pmc$user_defined_condition) AND
            (condition.user_condition_name = osc$job_recovery_condition_name)) THEN
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        EXIT pmp$receive_queue_message;
      ELSEIF (condition.selector = pmc$block_exit_processing) THEN
        pmp$remove_await_nonempty_queue (qid);
      IFEND;
    PROCEND rqm_condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'dequeue_message', EJECT ??

{ PURPOSE:
{   Remove a message from the queue.

    PROCEDURE dequeue_message
      (    queue: ^pmt$queue_specification;
           wait: ost$wait;
       VAR message: pmt$message;
       VAR dequeue_status: ost$status);

?? NEWTITLE := 'wait_for_message', EJECT ??

{ PURPOSE:
{   Wait for a message.

      PROCEDURE wait_for_message
        (    queue: ^pmt$queue_specification;
         VAR status: ost$status);

        VAR
          ignore_status: ost$status,
          interactive_descriptor: ^pmt$established_handler,
          q_limits: pmt$queue_limits,
          task_waiting: boolean,
          waiting_task: ^pmt$queued_task,
          x_global_task_id: ost$global_task_id;

        status.normal := TRUE;
        pmp$get_executing_task_gtid (x_global_task_id);
        pmp$get_queue_limits (q_limits, ignore_status);
        osp$set_job_signature_lock (queue^.control.waiting_task_lock);
        osp$clear_job_signature_lock (queue^.control.message_queue_lock);
        IF (queue^.control.waiting_task_queue.number_waiting_tasks < q_limits.maximum_messages) THEN
          ALLOCATE queue^.control.waiting_task_queue.enqueue^ IN osv$task_shared_heap^;
          queue^.control.waiting_task_queue.enqueue^^.next_task := NIL;
          queue^.control.waiting_task_queue.enqueue^^.task := x_global_task_id;
          queue^.control.waiting_task_queue.enqueue := ^queue^.control.waiting_task_queue.enqueue^^.next_task;
          queue^.control.waiting_task_queue.number_waiting_tasks :=
                queue^.control.waiting_task_queue.number_waiting_tasks + 1;
          osp$clear_job_signature_lock (queue^.control.waiting_task_lock);
          task_waiting := TRUE;
          WHILE task_waiting DO
            osp$set_job_signature_lock (queue^.control.waiting_task_lock);
            IF (queue^.control.waiting_task_queue.number_waiting_tasks > 0) THEN
              waiting_task := queue^.control.waiting_task_queue.dequeue;
              WHILE (waiting_task <> NIL) AND (waiting_task^.task <> x_global_task_id) DO
                waiting_task := waiting_task^.next_task;
              WHILEND;
              task_waiting := (waiting_task <> NIL);
            ELSE
              task_waiting := FALSE;
            IFEND;
            osp$clear_job_signature_lock (queue^.control.waiting_task_lock);
            IF task_waiting THEN
              osp$establish_condition_handler (^rqm_condition_handler, TRUE);
              pmp$long_term_wait (tmc$infinite_wait, tmc$infinite_wait);
              osp$disestablish_cond_handler;
            IFEND;
          WHILEND;
        ELSE
          osp$clear_job_signature_lock (queue^.control.waiting_task_lock);
          osp$set_status_abnormal (pmc$program_management_id, pme$maximum_waiting_tasks, queue^.name, status);
        IFEND;
      PROCEND wait_for_message;
?? OLDTITLE, EJECT ??

      VAR
        dequeued: ^pmt$queued_message,
        dequeued_message: pmt$queued_message,
        ignore_status: ost$status,
        message_dequeued: boolean,
        queued_message: ^^pmt$queued_message;


{*
{*    VAR
{*      s: 0 .. (pmc$max_segs_per_message + 1),
{*      queued_segments: ^array [*] OF mmt$queued_segment,
{*      d: pmt$segments_per_message,
{*      pva: ^cell;

      dequeue_status.normal := TRUE;
      message_dequeued := FALSE;
      WHILE NOT message_dequeued AND dequeue_status.normal DO
        osp$set_job_signature_lock (queue^.control.message_queue_lock);
        IF (queue^.control.message_queue.number_messages > 0) THEN
          queued_message := ^queue^.control.message_queue.dequeue;
          dequeued := queued_message^;
          dequeued_message := queued_message^^;
          queued_message^ := queued_message^^.dequeue_thread;
          IF (queued_message^ = NIL) THEN
            queue^.control.message_queue.enqueue := queued_message;
          IFEND;
          queue^.control.message_queue.number_messages := queue^.control.message_queue.number_messages - 1;
          osp$clear_job_signature_lock (queue^.control.message_queue_lock);
          CASE dequeued_message.message.contents OF
          = pmc$message_value =
            message := dequeued_message.message;
          = pmc$passed_segments, pmc$shared_segments =

{ **** R1 restriction - passed/shared segments are not supported by NOS/VE
{ Release 1.  The following documents the algorithm for dequeing queued
{ segments.  Note:  a field (segments) will be added to pmt$queued_message
{ which will point to an array of queued segment images that have been
{ constructed on behalf of pmp$send_to_queue by segment management (MMP$).
{ Segments contained in message_queue.segments^ are added to the requestor's
{ address space, via MMP$ADD, assuming of course that the requestor can access
{ all queued segments.
{
{ The MMP$ADD interface is not yet defined, therefore, some manipulation of
{ segment pointer types (e.g., message_heap_pointer) may be required when
{ constructing dequeued_message.segments.  The MMP$ADD request will return
{ abnormal status for a segment which unaccessible to the requestor - its
{ dequeue_message's responsibility to delete any segments already added to the
{ requestor's address space and to delete any remaining segments in
{ message_queue.segments^ when an unaccessible segment is detected.

{*          queued_segments := queue^.control.message_queue.segments;
{*          s := 1;
{*          WHILE (s <= UPPERBOUND (queued_segments^) AND dequeue_status.normal DO
{*            mmp$add_queued_segment (queued_segment^[s], dequeued_message.segments[s],
{*              dequeue_status);
{*            IF dequeue_status.normal THEN
{*              s := s + 1;
{*            ELSE
{*              {delete segments already added to requestor's address space
{*             FOR d := 1 TO (s - 1) DO
{*               CASE dequeued_message.segments[d].segment_type OF
{*                 =pmc$message_pointer=
{*                   mmp$delete_segment (dequeued_message.segments[d].segment_pointer,
{*                     ignore_status);
{*                 =pmc$message_heap_pointer=
{*                   pva := #LOC (dequeued_message.segments[d].segment_heap_pointer^);
{*                   mmp$delete_segment (pva, ignore_status);
{*                 =pmc$message_sequence_pointer=
{*                   pva := #LOC (dequeued_message.segments[d].segment_sequence_pointer^);
{*                   mmp$delete_segment (pva, ignore_status);
{*               CASEND;
{*             FOREND;
{*               {delete queued segments not yet added to requestor's address space
{*             FOR d := s to UPPERBOUND (queued_segments^) DO
{*               mmp$delete_queued_segment (queued_segment^[d], ignore_status);
{*             FOREND;
{*              osp$set_status_abnormal (pmc$program_management_id,
{*                pme$error_segment_privilege, '', dequeue_status);
{*           IFEND;
{*         WHILEND;
{*         FREE queued_segments IN osv$task_shared_heap^;

            ;
          CASEND;
          FREE dequeued IN osv$task_shared_heap^;
          message_dequeued := TRUE;
        ELSEIF (wait = osc$wait) THEN
          wait_for_message (queue, dequeue_status);
        ELSE
          osp$clear_job_signature_lock (queue^.control.message_queue_lock);
          message.contents := pmc$no_message;
          message_dequeued := TRUE;
        IFEND;
      WHILEND;
    PROCEND dequeue_message;
?? OLDTITLE, EJECT ??

    VAR
      caller: ost$caller_identifier,
      connected_task: ^pmt$queue_connected_task,
      ignore_status: ost$status,
      local_task_id: pmt$task_id,
      receive_status: ost$status;

    #CALLER_ID (caller);

    status.normal := TRUE;
    osp$verify_system_privilege;
    complete := FALSE;
    message.contents := pmc$no_message;
    receive_status.normal := TRUE;
    IF (pmv$queue_definition_table.queues = NIL) OR (qid < 1) OR
          (qid > UPPERBOUND (pmv$queue_definition_table.queues^)) THEN
      osp$set_status_condition (pme$unknown_queue_identifier, status);
      RETURN;
    IFEND;

    osp$set_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
    IF (pmv$queue_definition_table.queues^ [qid].definition = NIL) THEN
      osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
      osp$set_status_condition (pme$unknown_queue_identifier, status);
      RETURN;
    IFEND;

    IF (caller.ring > pmv$queue_definition_table.queues^ [qid].definition^.usage_bracket) THEN
      osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
      osp$set_status_abnormal (pmc$program_management_id, pme$usage_bracket_error,
            pmv$queue_definition_table.queues^ [qid].definition^.name, status);
      RETURN;
    IFEND;

    osp$set_job_signature_lock (pmv$queue_definition_table.queues^ [qid].definition^.control.connection_lock);
    osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
    connected_task := pmv$queue_definition_table.queues^ [qid].definition^.control.connected_task_list;
    pmp$get_task_id (local_task_id, ignore_status);
    WHILE (connected_task <> NIL) AND (connected_task^.task <> local_task_id) DO
      connected_task := connected_task^.next_connected_task;
    WHILEND;
    osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].definition^.control.
          connection_lock);
    IF (connected_task = NIL) THEN
      osp$set_status_condition (pme$unknown_queue_identifier, status);
    ELSE
      dequeue_message (pmv$queue_definition_table.queues^ [qid].definition, wait, message, receive_status);
      complete := TRUE;
      IF NOT receive_status.normal THEN
        status := receive_status;
      IFEND;
    IFEND;
  PROCEND pmp$receive_queue_message;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$remove_await_nonempty_queue', EJECT ??
*copyc pmh$remove_await_nonempty_queue

  PROCEDURE [XDCL] pmp$remove_await_nonempty_queue
    (    qid: pmt$queue_connection);

    VAR
      ignore_status: ost$status,
      next_waiting_task: ^pmt$queued_task,
      queue: ^pmt$queue_specification,
      task: ost$global_task_id,
      waiting_task: ^^pmt$queued_task;

    queue := pmv$queue_definition_table.queues^ [qid].definition;
    waiting_task := ^queue^.control.waiting_task_queue.dequeue;
    pmp$get_executing_task_gtid (task);
    osp$set_job_signature_lock (queue^.control.waiting_task_lock);
    WHILE (waiting_task^ <> NIL) DO
      IF (waiting_task^^.task = task) THEN
        next_waiting_task := waiting_task^^.next_task;
        FREE waiting_task^ IN osv$task_shared_heap^;
        waiting_task^ := next_waiting_task;
        queue^.control.waiting_task_queue.number_waiting_tasks :=
              queue^.control.waiting_task_queue.number_waiting_tasks - 1;
        IF (waiting_task^ = NIL) THEN
          queue^.control.waiting_task_queue.enqueue := waiting_task;
        IFEND;
      ELSE
        waiting_task := ^waiting_task^^.next_task;
      IFEND;
    WHILEND;
    osp$clear_job_signature_lock (queue^.control.waiting_task_lock);
  PROCEND pmp$remove_await_nonempty_queue;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$remove_queue', EJECT ??
*copyc pmh$remove_queue

  PROCEDURE [XDCL, #GATE] pmp$remove_queue
    (    name: pmt$queue_name;
     VAR status: ost$status);

    VAR
      caller: ost$caller_identifier,
      ignore_status: ost$status,
      lock_status: ost$signature_lock_status,
      q_index: pmt$queues_per_job,
      remove_name: ost$name,
      remove_status: ost$status,
      valid_name: boolean;

    #KEYPOINT (osk$entry, 0, pmk$remove_queue);
    #CALLER_ID (caller);
    status.normal := TRUE;
    remove_status.normal := TRUE;

  /remove_queue/
    BEGIN
      IF (pmv$queue_definition_table.queues = NIL) THEN
        osp$set_status_abnormal (pmc$program_management_id, pme$unknown_queue_name, remove_name,
              remove_status);
        EXIT /remove_queue/;
      IFEND;

      clp$validate_name (name, remove_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal (pmc$program_management_id, pme$incorrect_queue_name, name, remove_status);
        EXIT /remove_queue/;
      IFEND;

      FOR q_index := 1 TO UPPERBOUND (pmv$queue_definition_table.queues^) DO
        osp$set_job_signature_lock (pmv$queue_definition_table.queues^ [q_index].removal_lock);
        IF (pmv$queue_definition_table.queues^ [q_index].definition <> NIL) AND
              (pmv$queue_definition_table.queues^ [q_index].definition^.name = remove_name) THEN
          IF (caller.ring > pmv$queue_definition_table.queues^ [q_index].definition^.removal_bracket) THEN
            osp$set_status_abnormal (pmc$program_management_id, pme$removal_bracket_error, remove_name,
                  remove_status);
          ELSEIF (pmv$queue_definition_table.queues^ [q_index].definition^.control.connected_task_list <>
                NIL) THEN
            osp$set_status_abnormal (pmc$program_management_id, pme$tasks_connected_to_queue, remove_name,
                  remove_status);
          ELSE
            osp$test_sig_lock (pmv$queue_definition_table.queues^ [q_index].definition^.control.
                  connection_lock, lock_status);
            IF lock_status <> osc$sls_not_locked THEN
              osp$set_status_abnormal (pmc$program_management_id, pme$tasks_connected_to_queue, remove_name,
                    remove_status);
            ELSEIF (pmv$queue_definition_table.queues^ [q_index].definition^.control.message_queue.enqueue =
                  ^pmv$queue_definition_table.queues^ [q_index].definition^.control.message_queue.dequeue)
                  THEN
              FREE pmv$queue_definition_table.queues^ [q_index].definition IN osv$task_shared_heap^;
            ELSE
              osp$set_status_abnormal (pmc$program_management_id, pme$nonempty_queue, remove_name,
                    remove_status);
            IFEND;
          IFEND;
          osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [q_index].removal_lock);
          EXIT /remove_queue/;
        IFEND;
        osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [q_index].removal_lock);
      FOREND;
      osp$set_status_abnormal (pmc$program_management_id, pme$unknown_queue_name, remove_name, remove_status);
    END /remove_queue/;
    IF NOT remove_status.normal THEN
      status := remove_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pmk$remove_queue);
  PROCEND pmp$remove_queue;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$send_to_queue', EJECT ??
*copyc pmh$send_to_queue

  PROCEDURE [XDCL, #GATE] pmp$send_to_queue
    (    qid: pmt$queue_connection;
         message: pmt$message;
     VAR status: ost$status);

?? NEWTITLE := 'validate_message', EJECT ??

{ PURPOSE:
{   Ensure a legitimate message.

    PROCEDURE validate_message
      (    caller: ost$caller_identifier;
           message: pmt$message;
       VAR status: ost$status);

{ validate does not return if an error is detected - status is set to reflect
{ the detected error and a nonlocal exit performed.

      CONST
        hardware = 1,
        software = 2;

      VAR
        pva: ^cell,
        s: pmt$segments_per_message,
        segment_attributes: [STATIC, oss$task_private] array [hardware .. software] of
              mmt$attribute_descriptor := [[mmc$kw_hardware_attributes, $mmt$hardware_attribute_set []],
              [mmc$kw_software_attributes, $mmt$software_attribute_set []]],
        access: mmt$va_access_mode,
        ignore_status: ost$status;

      status.normal := TRUE;
      CASE message.contents OF
      = pmc$message_value =
        ;
      = pmc$passed_segments, pmc$shared_segments =

{ **** R1 restricition - the following code prevents a user from passing or
{ sharing segments in NOS/VE Release 1.  The statments upto the next comment
{ maybe deleted when the restriction is removed.

        osp$set_status_condition (pme$pass_share_prohibited, status);
        RETURN;

{ **** end R1 restriction.

{       IF (message.number_of_segments >= LOWERVALUE (pmt$segments_per_message)) AND
{             (message.number_of_segments <= UPPERVALUE (pmt$segments_per_message)) THEN
{         FOR s := 1 TO message.number_of_segments DO
{           CASE message.segments [s].kind OF
{           = pmc$message_pointer =
{             pva := ^message.segments [s].pointer;
{             IF (message.contents = pmc$passed_segments) THEN
{               access := mmc$va_read;
{             ELSE
{               access := mmc$va_write;
{             IFEND;
{             IF NOT mmp$verify_access (caller, pva, access) THEN
{               osp$set_status_condition (pme$incorrect_segment_message, status);
{               RETURN;
{             IFEND;
{           = pmc$message_heap_pointer =
{             pva := ^message.segments [s].heap_pointer;
{             IF (message.contents = pmc$passed_segments) THEN
{               access := mmc$va_read;
{             ELSE
{               access := mmc$va_write;
{             IFEND;
{             IF NOT mmp$verify_access (caller, pva, access) THEN
{               osp$set_status_condition (pme$error_segment_privilege, status);
{               RETURN;
{             IFEND;
{           = pmc$message_sequence_pointer =
{             pva := ^message.segments [s].sequence_pointer;
{             IF (message.contents = pmc$passed_segments) THEN
{               access := mmc$va_read;
{             ELSE
{               access := mmc$va_write;
{             IFEND;
{             IF NOT mmp$verify_access (caller, pva, access) THEN
{               osp$set_status_condition (pme$error_segment_privilege, status);
{               RETURN;
{             IFEND;
{           ELSE
{             osp$set_status_condition (pme$incorrect_queued_seg_type, status);
{             RETURN;
{           CASEND;
{           mmp$fetch_segment_attributes (pva, segment_attributes, ignore_status);
{           IF (mmc$ha_binding IN segment_attributes [hardware].hardware_attri_set) OR
{                 (mmc$ha_execute IN segment_attributes [hardware].hardware_attri_set) THEN
{             osp$set_status_condition (pme$incorrect_segment_message, status);
{             RETURN;
{           IFEND;
{           IF (mmc$sa_stack IN segment_attributes [software].software_attri_set) THEN
{             osp$set_status_condition (pme$error_segment_privilege, status);
{             RETURN;
{           IFEND;
{         FOREND;
{       ELSE
{         osp$set_status_condition (pme$error_number_of_segments, status);
{         RETURN;
{       IFEND;

      ELSE
        osp$set_status_condition (pme$incorrect_message_type, status);
        RETURN;
      CASEND;
    PROCEND validate_message;
?? OLDTITLE ??
?? NEWTITLE := 'enqueue_the_message', EJECT ??

{ PURPOSE:
{   Add the message to the queue's message list.

    PROCEDURE enqueue_the_message
      (    message: ^pmt$message;
           queue: ^pmt$queue_specification;
           caller_ring: ost$ring;
       VAR enqueue_status: ost$status);

      VAR
        enqueue_message: ^pmt$queued_message,
        ignore_status: ost$status,
        limits: pmt$queue_limits;

{*      VAR
{*        s: pmt$segments_per_message,
{*        pva: ^cell;

      enqueue_status.normal := TRUE;
      pmp$get_queue_limits (limits, ignore_status);
      osp$set_job_signature_lock (queue^.control.message_queue_lock);
      IF (queue^.control.message_queue.number_messages < limits.maximum_messages) THEN
        ALLOCATE enqueue_message IN osv$task_shared_heap^;
        enqueue_message^.dequeue_thread := NIL;
        enqueue_message^.message := message^;
        pmp$get_task_id (enqueue_message^.message.sender_id, ignore_status);
        enqueue_message^.message.sender_ring := caller_ring;
        CASE message^.contents OF
        = pmc$message_value =

{*          queue^.control.message_queue.segments := NIL;

          ;
        = pmc$passed_segments =

{ **** R1 restriction - passed/shared segments are not supported by NOS/VE
{ Release 1.  The following documents the alogorithm for enqueueing queued
{ segments.  Note:  a field (segments) will be added to pmt$queued_message
{ which will point to an array of queued segments constructed by
{ enqueue_message via segment management (MMP$).  pmp$receive_from_queue on
{ behalf of its requestor will dequeue the segments adding them to the
{ requestor's address space.
{
{ The MMP$ENQUEUE_SEGMENT interface is not yet defined, therefore, some
{ manipulation of a segment pointer (e.g., message_heap_pointer) prior to
{ calling MMP$ENQUEUE_SEGMENT may be required.

{         ALLOCATE enqueue_message^.segments: [1 .. message^.number_of_segments] IN
{            osv$task_shared_heap^;
{         FOR s := 1 TO message^.number_of_segments DO
{           mmp$enqueue_segment (message.segments[s], enqueue_message^.segments^[s],
{                 enqueue_status);
{           CASE message^.segments[s].segment_type OF
{             =pmc$message_pointer=
{               pva := #LOC (message^.segments[s].segment_pointer^);
{             =pmc$message_pointer=
{               pva := #LOC (message^.segments[s].segment_heap_pointer^);
{             =pmc$message_sequence_pointer=
{               pva := #LOC (message^.segments[s].segment_sequence_pointer^);
{           CASEND;
{           mmp$delete_segment (pva, ignore_status);
{         FOREND;

          ;
        = pmc$shared_segments =

{ SEE **** R1 restriction above.

{         ALLOCATE enqueue_message^.segments: [1 .. message^.number_of_segments] IN
{           osv$task_shared_heap^;
{         IF (enqueue_message^.segments <> NIL) THEN
{           FOR s := 1 TO message^.number_of_segments DO
{             mmp$enqueue_segment (message.segments[s], enqueue_message^.segments[s],
{               enqueue_status);
{           FOREND;
{         ELSE
{           FREE enqueue_message IN osv$task_shared_heap^;
{           osp$set_status_abnormal (pmc$program_management_id,
{             ose$task_shared_full, 'pmp$send_to_queue', enqueue_status);
{           pmp$exit (status);
{         IFEND;

          ;
        CASEND;
        IF enqueue_status.normal THEN
          queue^.control.message_queue.enqueue^ := enqueue_message;
          queue^.control.message_queue.enqueue := ^enqueue_message^.dequeue_thread;
          queue^.control.message_queue.number_messages := queue^.control.message_queue.number_messages + 1;
        IFEND;
      ELSE
        osp$set_status_abnormal (pmc$program_management_id, pme$maximum_queued_messages, queue^.name,
              enqueue_status);
      IFEND;
      osp$clear_job_signature_lock (queue^.control.message_queue_lock);
    PROCEND enqueue_the_message;
?? OLDTITLE ??
?? NEWTITLE := 'ready_waiting_tasks', EJECT ??

{ PURPOSE:
{   Ready tasks waiting for a message on this queue.

    PROCEDURE ready_waiting_tasks
      (    queue: ^pmt$queue_specification);

      VAR
        ignore_status: ost$status,
        next_waiting_task: ^pmt$queued_task,
        waiting_task: ^^pmt$queued_task;

      osp$set_job_signature_lock (queue^.control.waiting_task_lock);
      waiting_task := ^queue^.control.waiting_task_queue.dequeue;
      WHILE waiting_task^ <> NIL DO
        pmp$ready_task (waiting_task^^.task, ignore_status);
        next_waiting_task := waiting_task^^.next_task;
        FREE waiting_task^ IN osv$task_shared_heap^;
        waiting_task^ := next_waiting_task;
        IF (waiting_task^ = NIL) THEN
          queue^.control.waiting_task_queue.enqueue := waiting_task;
        IFEND;
      WHILEND;
      queue^.control.waiting_task_queue.number_waiting_tasks := 0;
      osp$clear_job_signature_lock (queue^.control.waiting_task_lock);
    PROCEND ready_waiting_tasks;
?? OLDTITLE, EJECT ??

    VAR
      local_task_id: pmt$task_id,
      connected_task: ^pmt$queue_connected_task,
      connected: boolean,
      caller: ost$caller_identifier,
      ignore_status: ost$status,
      send_status: ost$status;

    #KEYPOINT (osk$entry, 0, pmk$send_to_queue);
    #CALLER_ID (caller);
    status.normal := TRUE;
    send_status.normal := TRUE;

  /send_to_queue/
    BEGIN
      validate_message (caller, message, send_status);
      IF NOT send_status.normal THEN
        EXIT /send_to_queue/;
      IFEND;

{validate_message does not return if an error in message is detected

      IF (pmv$queue_definition_table.queues = NIL) OR (qid < 1) OR
            (qid > UPPERBOUND (pmv$queue_definition_table.queues^)) THEN
        osp$set_status_condition (pme$unknown_queue_identifier, send_status);
        EXIT /send_to_queue/;
      IFEND;

      osp$set_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
      IF (pmv$queue_definition_table.queues^ [qid].definition = NIL) THEN
        osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
        osp$set_status_condition (pme$unknown_queue_identifier, send_status);
        EXIT /send_to_queue/;
      IFEND;

      IF (caller.ring > pmv$queue_definition_table.queues^ [qid].definition^.usage_bracket) THEN
        osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
        osp$set_status_abnormal (pmc$program_management_id, pme$usage_bracket_error,
              pmv$queue_definition_table.queues^ [qid].definition^.name, send_status);
        EXIT /send_to_queue/;
      IFEND;

      osp$set_job_signature_lock (pmv$queue_definition_table.queues^ [qid].definition^.control.
            connection_lock);
      osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
      connected_task := pmv$queue_definition_table.queues^ [qid].definition^.control.connected_task_list;
      IF (connected_task = NIL) THEN
        osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].definition^.control.
              connection_lock);
        osp$set_status_condition (pme$unknown_queue_identifier, send_status);
        EXIT /send_to_queue/;
      IFEND;

      pmp$get_task_id (local_task_id, ignore_status);
      connected := FALSE;
      WHILE (connected_task <> NIL) AND (connected_task^.task <> local_task_id) DO
        connected_task := connected_task^.next_connected_task;
      WHILEND;
      osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].definition^.control.
            connection_lock);
      IF (connected_task = NIL) THEN
        osp$set_status_condition (pme$unknown_queue_identifier, send_status);
        EXIT /send_to_queue/;
      IFEND;
      connected := TRUE;
      enqueue_the_message (^message, pmv$queue_definition_table.queues^ [qid].definition, caller.ring,
            send_status);
      IF send_status.normal THEN
        ready_waiting_tasks (pmv$queue_definition_table.queues^ [qid].definition);
      IFEND;
    END /send_to_queue/;
    IF NOT send_status.normal THEN
      status := send_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pmk$send_to_queue);
  PROCEND pmp$send_to_queue;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$status_queue', EJECT ??
*copyc pmh$status_queue

  PROCEDURE [XDCL, #GATE] pmp$status_queue
    (    qid: pmt$queue_connection;
     VAR counts: pmt$queue_status;
     VAR status: ost$status);

    VAR
      caller: ost$caller_identifier,
      connected: boolean,
      connected_task: ^pmt$queue_connected_task,
      ignore_status: ost$status,
      local_task_id: pmt$task_id,
      message: ^pmt$queued_message,
      q_status: ost$status;

    #KEYPOINT (osk$entry, 0, pmk$status_queue);
    #CALLER_ID (caller);
    status.normal := TRUE;
    counts.connections := 0;
    q_status.normal := TRUE;

  /status_queue/
    BEGIN
      IF (pmv$queue_definition_table.queues = NIL) OR (qid < 1) OR
            (qid > UPPERBOUND (pmv$queue_definition_table.queues^)) THEN
        osp$set_status_condition (pme$unknown_queue_identifier, q_status);
        EXIT /status_queue/;
      IFEND;

      osp$set_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
      IF (pmv$queue_definition_table.queues^ [qid].definition = NIL) THEN
        osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
        osp$set_status_condition (pme$unknown_queue_identifier, q_status);
        EXIT /status_queue/;
      IFEND;

      IF (caller.ring > pmv$queue_definition_table.queues^ [qid].definition^.usage_bracket) THEN
        osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
        osp$set_status_abnormal (pmc$program_management_id, pme$usage_bracket_error,
              pmv$queue_definition_table.queues^ [qid].definition^.name, q_status);
        EXIT /status_queue/;
      IFEND;

      osp$set_job_signature_lock (pmv$queue_definition_table.queues^ [qid].definition^.control.
            connection_lock);
      osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].removal_lock);
      connected_task := pmv$queue_definition_table.queues^ [qid].definition^.control.connected_task_list;

      pmp$get_task_id (local_task_id, ignore_status);
      connected := FALSE;
      counts.connections := 0;
      WHILE (connected_task <> NIL) DO
        counts.connections := counts.connections + 1;
        connected := connected OR (connected_task^.task = local_task_id);
        connected_task := connected_task^.next_connected_task;
      WHILEND;
      osp$clear_job_signature_lock (pmv$queue_definition_table.queues^ [qid].definition^.control.
            connection_lock);
      IF connected THEN
        counts.messages := pmv$queue_definition_table.queues^ [qid].definition^.control.message_queue.
              number_messages;
        counts.waiting_tasks := pmv$queue_definition_table.queues^ [qid].definition^.control.
              waiting_task_queue.number_waiting_tasks;
      ELSE
        osp$set_status_condition (pme$unknown_queue_identifier, q_status);
      IFEND;
    END /status_queue/;
    IF NOT q_status.normal THEN
      status := q_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pmk$status_queue);
  PROCEND pmp$status_queue;
?? OLDTITLE ??
MODEND pmm$manage_local_queues;
*DECK DECK=PMM$MPE_COMMAND_HANDLERS EXPAND=TRUE
?? RIGHT := 110 ??
*copy OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE:  MPE : Measure Program Execution Command Handlers', EJECT ??
MODULE pmm$mpe_command_handlers;



{ PURPOSE:                                                 }
{  Command processors for Measure Program Execution. }






{ *callc clxspl  }
{ *callc clxtpar }
{ *callc clxgsc  }
{ *callc clxgvc  }
{ *callc clxgval }
{ *callc clxpuut }
{ *callc clxscmf }
{ *callc clxexcf }
{ *callc clxpout }
{ *callc clxgpd  }

{ *callc pmxgdat }
{ *callc pmxunam }

{ *callc cldsfn  }
{ *callc cldescl }
{ *callc cldeere }

{ *callc osdhrdw }
{ *callc osdpgsz }
{ *callc osdptbl }

{ *callc amxclse }
{ *callc amxgsgp }
{ *callc amxsete }
{ *callc amxfile }

{ *callc osxssa  }
{ *callc osxasp  }

{ *callc ocxcpn  }
{ *callc ocxcts  }
{ *callc ocxgmsg }

{ *callc lldprgx }
{ *callc pmdaper }
{ *callc pmdapd  }
?? SET (LIST := OFF) ??

*copyc CLP$SCAN_PARAMETER_LIST
*copyc CLP$TEST_PARAMETER
*copyc CLP$EVALUATE_PARAMETERS
*copyc CLP$GET_SET_COUNT
*copyc CLP$GET_VALUE_COUNT
*copyc CLP$GET_VALUE
*copyc CLP$PUSH_UTILITY
*copyc CLP$SCAN_COMMAND_FILE
*copyc CLP$END_SCAN_COMMAND_FILE
*copyc CLP$POP_UTILITY
*copyc CLP$GET_PATH_DESCRIPTION

*copyc PMP$GET_DATE
*copyc pmp$get_unique_name

*copyc CLC$STANDARD_FILE_NAMES
*copyc CLE$ECC_MISCELLANEOUS
*copyc CLE$ECC_EXPRESSION_RESULT
*copyc OSD$INTEGER_LIMITS
*copyc OST$HARDWARE_SUBRANGES
*copyc OST$PAGE_SIZE
*copyc OST$PAGE_TABLE

*copyc AMP$GET_SEGMENT_POINTER
*copyc AMP$SET_SEGMENT_EOI
*copyc AMP$FILE
*copyc AMP$RETURN
*copyc FSP$CLOSE_FILE
*copyc FSP$OPEN_FILE

*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSP$APPEND_STATUS_PARAMETER

*copyc OCP$CRACK_PROGRAM_NAME
*copyc OCP$CREATE_TRANSIENT_SEGMENT
*copyc OCP$GENERATE_MESSAGE
*copyc PMP$DISESTABLISH_END_HANDLER
*copyc PMP$ESTABLISH_END_HANDLER
*copyc LLT$PROGRAM_DESCRIPTION
*copyc PME$ANALYZE_PROGRAM_DYNAMICS
*copyc PMT$LOADER_SEQ_DESCRIPTOR

  PROCEDURE [XREF] pmp$restore_program_measures (measures: amt$local_file_name;
    VAR status: ost$status);

  PROCEDURE [XREF] pmp$execute_instrumented_task (execute_parameter_list: ^clt$parameter_list;
        no_connectivity_matrix: boolean;
        working_set_interval: 0 .. 0ffffffff(16);
    VAR status: ost$status);

  PROCEDURE [XREF] pmp$save_program_measures (measures: amt$local_file_name;
        environment_contents: pmt$environment_contents;
    VAR status: ost$status);

  PROCEDURE [XREF] pmp$create_restructure_commands (commands: amt$local_file_name;
        file_reference: clt$file_reference;
        module_name: pmt$program_name;
    VAR status: ost$status);

  PROCEDURE [XREF] pmp$create_restructured_module (file_reference: clt$file_reference;
        module_name: pmt$program_name;
        commands: amt$local_file_name;
    VAR status: ost$status);

  PROCEDURE [XREF] pmp$display_program_profile (profile_order: pmt$profile_order;
        procedures: pmt$procedures;
        number: 0 .. 0ffffffff(16);
        output: clt$file;
    VAR status: ost$status);
?? SET (LIST := ON) ??
?? NEWTITLE := '  Global Variables', EJECT ??

  SECTION
    file_attributes: READ;

  VAR
    pmv$program_description: [XDCL] ^pmt$program_description,
    pmv$loader_seq_descriptor: [XDCL] ^pmt$loader_seq_descriptor,
    pmv$mpe_seq_descriptor: [XDCL] pmt$mpe_seq_descriptor,
    pmv$loader_description: [XDCL] pmt$loader_description,
    pmv$interblock_references_hdr: [XDCL] ^pmt$interblock_references_hdr,
    command_file: [STATIC] amt$local_file_name := clc$current_command_input;

  VAR
    work_file_attachment: [STATIC, READ, file_attributes] array [1 .. 1] of fst$attachment_option :=
          [[fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$read, fsc$append, fsc$modify,
          fsc$shorten]], [fsc$determine_from_access_modes]]],
    work_file_attributes: [STATIC, READ, file_attributes] array [1 .. 3] of fst$file_cycle_attribute :=
          [[fsc$file_contents_and_processor, fsc$data, fsc$unknown_processor],
          [fsc$file_organization, amc$sequential], [fsc$record_type, amc$undefined]];

?? OLDTITLE ??
?? NEWTITLE := '  end_handler', EJECT ??

{ PURPOSE:
{   The purpose of this request is to perform termination processing if
{   the MEASURE_PROGRAM_EXECUTION utility aborts.

  PROCEDURE end_handler
    (    termination_status: ost$status;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status;

    status.normal := TRUE;

    release_files (ignore_status);

  PROCEND end_handler;
?? OLDTITLE ??
?? NEWTITLE := '  init_loader_seq_descriptor', EJECT ??

  PROCEDURE init_loader_seq_descriptor;

    IF pmv$loader_seq_descriptor <> NIL THEN
      pmv$loader_seq_descriptor^.block_name_map_exists := FALSE;
      pmv$loader_seq_descriptor^.local_block_id := 0;
      pmv$loader_seq_descriptor^.remote_block_id := 0;
      pmv$loader_seq_descriptor^.local_block_name_map := NIL;
      pmv$loader_seq_descriptor^.remote_block_name_map := NIL;
      pmv$loader_seq_descriptor^.number_of_interblock_segments := 1;
    IFEND;

  PROCEND init_loader_seq_descriptor;
?? OLDTITLE ??
?? NEWTITLE := '  init_interblock_references_hdr', EJECT ??

  PROCEDURE init_interblock_references_hdr;

    IF pmv$interblock_references_hdr <> NIL THEN
      pmv$interblock_references_hdr^.number_of_interblock_references := 0;
      pmv$interblock_references_hdr^.next_segment_file_name := osc$null_name;
    IFEND;

  PROCEND init_interblock_references_hdr;
?? OLDTITLE ??
?? NEWTITLE := '  init_mpe_seq_descriptor', EJECT ??

  PROCEDURE init_mpe_seq_descriptor;

    pmv$program_description := NIL;

    pmv$mpe_seq_descriptor.local_execution_time_totals := NIL;
    pmv$mpe_seq_descriptor.remote_execution_time_totals := NIL;
    pmv$mpe_seq_descriptor.connectivity_matrix := NIL;
    pmv$mpe_seq_descriptor.intercolumn_bond_matrix := NIL;

  PROCEND init_mpe_seq_descriptor;
?? OLDTITLE ??
?? NEWTITLE := '  release_files', EJECT ??

{ PURPOSE:
{   The purpose of this request is to release all temporary files used by
{   the MEASURE_PROGRAM_EXECUTION utility.

  PROCEDURE release_files
    (VAR status: ost$status);

    VAR
      ignore_status: ost$status;

    status.normal := TRUE;

    IF pmv$loader_seq_descriptor <> NIL THEN
      IF pmv$interblock_references_hdr <> NIL THEN
        fsp$close_file (pmv$interblock_references_hdr^.file_id, ignore_status);
        pmv$interblock_references_hdr := NIL;
      IFEND;
      release_interblock_segments (ignore_status);
      fsp$close_file (pmv$loader_seq_descriptor^.file_id, ignore_status);
      pmv$loader_seq_descriptor := NIL;
    IFEND;
    amp$return (pmv$loader_description.mpe_loader_seq, ignore_status);

  PROCEND release_files;
?? OLDTITLE ??
?? NEWTITLE := '  release_interblock_segments', EJECT ??

{ PURPOSE:
{   The purpose of this request is to release the temporary files used to
{   record the interblock references made by the program being analyzed.
{
{ NOTES:
{   All of the interblock reference files are assumed to be closed upon
{   entry.  The loader sequence file is assumed to be open.

  PROCEDURE release_interblock_segments
    (VAR status: ost$status);

    VAR
      file_id: amt$file_identifier,
      ignore_status: ost$status,
      next_file_name: amt$local_file_name,
      next_file_opened: boolean,
      previous_file_name: amt$local_file_name,
      previous_file_opened: boolean,
      segment: ost$positive_integers,
      segment_pointer: amt$segment_pointer;

    status.normal := TRUE;

    IF pmv$loader_seq_descriptor <> NIL THEN
      IF pmv$loader_seq_descriptor^.number_of_interblock_segments = 1 THEN
        amp$return (pmv$loader_seq_descriptor^.first_interblock_segment_name, ignore_status);
        RETURN;
      IFEND;
      next_file_name := pmv$loader_seq_descriptor^.first_interblock_segment_name;
      next_file_opened := FALSE;
      previous_file_opened := FALSE;

    /release_segments/
      FOR segment := 1 TO pmv$loader_seq_descriptor^.number_of_interblock_segments DO

        IF next_file_name <> osc$null_name THEN
          fsp$open_file (next_file_name, amc$segment, ^work_file_attachment, NIL, NIL, ^work_file_attributes,
                NIL, file_id, status);
          IF NOT status.normal THEN
            EXIT /release_segments/;
          IFEND;

          next_file_opened := TRUE;
          amp$get_segment_pointer (file_id, amc$sequence_pointer, segment_pointer, status);
          IF NOT status.normal THEN
            EXIT /release_segments/;
          IFEND;

          IF previous_file_opened THEN
            fsp$close_file (pmv$interblock_references_hdr^.file_id, ignore_status);
            amp$return (previous_file_name, ignore_status);
            previous_file_opened := FALSE;
          IFEND;

          pmv$loader_seq_descriptor^.last_interblock_segment := segment_pointer.sequence_pointer;
          RESET pmv$loader_seq_descriptor^.last_interblock_segment;
          NEXT pmv$interblock_references_hdr IN pmv$loader_seq_descriptor^.last_interblock_segment;
          IF pmv$interblock_references_hdr = NIL THEN
            osp$set_status_abnormal ('PM', pme$e_internal_apd_read_error, '', status);
            EXIT /release_segments/;
          IFEND;

          pmv$interblock_references_hdr^.file_id := file_id;
          previous_file_name := next_file_name;
          previous_file_opened := TRUE;
          next_file_name := pmv$interblock_references_hdr^.next_segment_file_name;
          next_file_opened := FALSE;
        IFEND;
      FOREND /release_segments/;

      IF previous_file_opened THEN
        fsp$close_file (pmv$interblock_references_hdr^.file_id, ignore_status);
        amp$return (previous_file_name, ignore_status);
      IFEND;
      IF next_file_name <> osc$null_name THEN
        IF next_file_opened THEN
          fsp$close_file (file_id, ignore_status);
        IFEND;
        amp$return (next_file_name, ignore_status);
      IFEND;
      pmv$interblock_references_hdr := NIL;
    IFEND;

  PROCEND release_interblock_segments;
?? OLDTITLE ??
?? NEWTITLE := '  set_program_description', EJECT ??

  PROCEDURE set_program_description (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{ pdt setpd_pdt (
{   target_text, tt: file = $required
{   file, files, f: list of file
{   library, libraries, l: list of file
{   module, modules, m: list of any
{   starting_procedure, sp: any
{   stack_size, ss: integer 1 .. osc$max_segment_length = 2000000
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      setpd_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^setpd_pdt_names,
        ^setpd_pdt_params];

    VAR
      setpd_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 16] of
        clt$parameter_name_descriptor := [['TARGET_TEXT', 1], ['TT', 1], ['FILE', 2], ['FILES', 2], ['F', 2],
        ['LIBRARY', 3], ['LIBRARIES', 3], ['L', 3], ['MODULE', 4], ['MODULES', 4], ['M', 4], [
        'STARTING_PROCEDURE', 5], ['SP', 5], ['STACK_SIZE', 6], ['SS', 6], ['STATUS', 7]];

    VAR
      setpd_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 7] of clt$parameter_descriptor := [

{ TARGET_TEXT TT }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ FILE FILES F }
      [[clc$optional], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ LIBRARY LIBRARIES L }
      [[clc$optional], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ MODULE MODULES M }
      [[clc$optional], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed, [NIL, clc$any_value]],

{ STARTING_PROCEDURE SP }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$any_value]],

{ STACK_SIZE SS }
      [[clc$optional_with_default, ^setpd_pdt_dv6], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$integer_value, 1, osc$max_segment_length]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      setpd_pdt_dv6: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '2000000';

?? POP ??


    VAR
      parameter: clt$value,
      number_of_object_files: 0 .. clc$max_value_sets,
      number_of_files: 0 .. clc$max_value_sets,
      number_of_libraries: 0 .. clc$max_value_sets,
      number_of_modules: 0 .. clc$max_value_sets,
      i: 0 .. clc$max_value_sets,
      target_text_in_file_list: boolean,
      target_text: clt$file,
      module_name: pmt$program_name,
      size: integer,
      starting_proc: pmt$program_name,
      temp_program_description: ^pmt$program_description,
      program_attributes: ^pmt$program_attributes,
      object_file_list: ^pmt$object_file_list,
      module_list: ^pmt$module_list,
      object_library_list: ^pmt$object_library_list;

?? EJECT ??

    status.normal := TRUE;
    init_loader_seq_descriptor;
    init_interblock_references_hdr;
    init_mpe_seq_descriptor;

    clp$scan_parameter_list (parameter_list, setpd_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('FILE', number_of_files, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF number_of_files = 0 THEN
      number_of_object_files := 1;
    ELSE
      number_of_object_files := number_of_files;
    IFEND;

    clp$get_set_count ('LIBRARY', number_of_libraries, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('MODULE', number_of_modules, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    size := (#SIZE (pmt$program_attributes)) + (#SIZE (amt$local_file_name) * (number_of_libraries +
          number_of_object_files)) + (#SIZE (pmt$program_name) * number_of_modules);

    PUSH temp_program_description: [[REP size OF cell]];
    IF temp_program_description = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
      RETURN;
    IFEND;

    RESET temp_program_description;

    NEXT program_attributes IN temp_program_description;
    IF program_attributes = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
      RETURN;
    IFEND;
    program_attributes^.contents := $pmt$prog_description_contents [];

    clp$get_value ('TARGET_TEXT', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    target_text := parameter.file;
    target_text_in_file_list := FALSE;
?? EJECT ??

    program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
          [pmc$object_file_list_specified];
    program_attributes^.number_of_object_files := number_of_object_files;

    IF number_of_files <> 0 THEN
      NEXT object_file_list: [1 .. number_of_files] IN temp_program_description;
      IF object_file_list = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;

      FOR i := 1 TO number_of_files DO
        clp$get_value ('FILE', i, 1, clc$low, parameter, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF target_text.local_file_name = parameter.file.local_file_name THEN
          target_text_in_file_list := TRUE;
        IFEND;

        object_file_list^ [i] := parameter.file.local_file_name;
      FOREND;

      IF NOT target_text_in_file_list THEN
        osp$set_status_abnormal ('PM', pme$e_target_text_not_file, '', status);
        RETURN;
      IFEND;
    ELSE
      NEXT object_file_list: [1 .. 1] IN temp_program_description;
      IF object_file_list = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;

      object_file_list^ [1] := target_text.local_file_name;
    IFEND;
?? EJECT ??

    IF number_of_modules <> 0 THEN
      program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
            [pmc$module_list_specified];
      program_attributes^.number_of_modules := number_of_modules;

      NEXT module_list: [1 .. number_of_modules] IN temp_program_description;
      IF module_list = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;

      FOR i := 1 TO number_of_modules DO
        clp$get_value ('MODULES', i, 1, clc$low, parameter, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        ocp$crack_program_name ('MODULES', parameter, module_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        module_list^ [i] := module_name;
      FOREND;
    IFEND;

    IF number_of_libraries <> 0 THEN
      program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
            [pmc$library_list_specified];
      program_attributes^.number_of_libraries := number_of_libraries;

      NEXT object_library_list: [1 .. number_of_libraries] IN temp_program_description;
      IF object_library_list = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;

      FOR i := 1 TO number_of_libraries DO
        clp$get_value ('LIBRARY', i, 1, clc$low, parameter, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        object_library_list^ [i] := parameter.file.local_file_name;
      FOREND;
    IFEND;
?? EJECT ??

    clp$get_value ('STARTING_PROCEDURE', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter.kind <> clc$unknown_value THEN
      program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
            [pmc$starting_proc_specified];

      ocp$crack_program_name ('STARTING_PROCEDURE', parameter, starting_proc, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      program_attributes^.starting_procedure := starting_proc;
    IFEND;

    clp$get_value ('STACK_SIZE', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    program_attributes^.contents := program_attributes^.contents + $pmt$prog_description_contents
          [pmc$max_stack_size_specified];
    program_attributes^.maximum_stack_size := parameter.int.value;

    IF pmv$program_description <> NIL THEN
      FREE pmv$program_description;
    IFEND;

    ALLOCATE pmv$program_description: [[REP (#SIZE (temp_program_description^)) OF cell]];
    IF pmv$program_description = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
      RETURN;
    IFEND;

    pmv$program_description^ := temp_program_description^;

    pmv$loader_description.target_text := target_text;

  PROCEND set_program_description;
?? OLDTITLE ??
?? NEWTITLE := '  restore_program_measures', EJECT ??

  PROCEDURE restore_program_measures (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{ pdt setpm_pdt (
{   measures, m: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      setpm_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^setpm_pdt_names,
        ^setpm_pdt_params];

    VAR
      setpm_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['MEASURES', 1], ['M', 1], ['STATUS', 2]];

    VAR
      setpm_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ MEASURES M }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??


    VAR
      parameter: clt$value;


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, setpm_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('MEASURES', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$restore_program_measures (parameter.file.local_file_name, status);
    IF NOT status.normal THEN
      init_loader_seq_descriptor;
      init_interblock_references_hdr;
      init_mpe_seq_descriptor;

      ocp$generate_message (status);

      status.normal := TRUE;

      osp$set_status_abnormal ('PM', pme$w_mpe_environment_restored, '', status);
      RETURN;
    IFEND;

  PROCEND restore_program_measures;
?? OLDTITLE ??
?? NEWTITLE := '  execute_instrumented_task', EJECT ??

  PROCEDURE execute_instrumented_task (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{ procedure exeit_pdt (
{   parameter, p: string = ' '
{   no_connectivity_matrix, ncm: boolean = false
{   working_set_interval, wsi: integer 0 .. 0ffffffff(16) = 50000
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (5),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [93, 10, 18, 0, 11, 45, 521],
    clc$command, 7, 4, 0, 0, 0, 0, 4, ''], [
    ['NCM                            ',clc$abbreviation_entry, 2],
    ['NO_CONNECTIVITY_MATRIX         ',clc$nominal_entry, 2],
    ['P                              ',clc$abbreviation_entry, 1],
    ['PARAMETER                      ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['WORKING_SET_INTERVAL           ',clc$nominal_entry, 3],
    ['WSI                            ',clc$abbreviation_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE],
    ''' '''],
{ PARAMETER 2
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10],
    '50000'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$parameter = 1,
      p$no_connectivity_matrix = 2,
      p$working_set_interval = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      execute_parameter_list: ^clt$parameter_list,
      string_index: clt$string_size,
      strng: ^char,
      strng_length: ^clt$string_size,
      string_size: clt$string_size;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    string_size := STRLENGTH (pvt [p$parameter].value^.string_value^);
    PUSH execute_parameter_list: [[ clt$string_size, REP string_size OF char ]];
    RESET execute_parameter_list;

    NEXT strng_length IN execute_parameter_list;
    IF strng_length = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
      RETURN;
    IFEND;
    strng_length^ := string_size;

    FOR string_index := 1 TO string_size DO
      NEXT strng IN execute_parameter_list;
      IF strng = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        RETURN;
      IFEND;
      strng^ := pvt [p$parameter].value^.string_value^(string_index);
    FOREND;

    pmp$execute_instrumented_task (execute_parameter_list,
         pvt [p$no_connectivity_matrix].value^.boolean_value.value,
         pvt [p$working_set_interval].value^.integer_value.value,status);
    IF NOT status.normal THEN
      init_loader_seq_descriptor;
      init_interblock_references_hdr;

      ocp$generate_message (status);
      status.normal := TRUE;

      osp$set_status_abnormal ('PM', pme$w_mpe_environment_restored, '', status);

      RETURN;
    IFEND;

  PROCEND execute_instrumented_task;
?? OLDTITLE ??
?? NEWTITLE := '  save_program_measures', EJECT ??

  PROCEDURE save_program_measures (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{ pdt coppm_pdt (
{   measures, m: file = $required
{   amount, a: list 1..2 of key all, connectivity_matrix, cm, execution_time_totals, ett = all
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      coppm_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^coppm_pdt_names,
        ^coppm_pdt_params];

    VAR
      coppm_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
        clt$parameter_name_descriptor := [['MEASURES', 1], ['M', 1], ['AMOUNT', 2], ['A', 2], ['STATUS', 3]];

    VAR
      coppm_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ MEASURES M }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ AMOUNT A }
      [[clc$optional_with_default, ^coppm_pdt_dv2], 1, 2, 1, 1, clc$value_range_not_allowed, [^coppm_pdt_kv2,
        clc$keyword_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      coppm_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of ost$name := ['ALL',
        'CONNECTIVITY_MATRIX', 'CM', 'EXECUTION_TIME_TOTALS', 'ETT'];

    VAR
      coppm_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

?? POP ??


    VAR
      number_of_sets: 0 .. clc$max_value_sets,
      i: 0 .. clc$max_value_sets,
      environment_contents: pmt$environment_contents,
      measures: amt$local_file_name,
      parameter: clt$value;


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, coppm_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('MEASURES', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    measures := parameter.file.local_file_name;

    clp$get_set_count ('AMOUNT', number_of_sets, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    environment_contents := $pmt$environment_contents [];

    IF pmv$program_description = NIL THEN
      osp$set_status_abnormal ('PM', pme$e_no_program_description, '', status);
      RETURN;
    IFEND;

    IF NOT pmv$loader_seq_descriptor^.block_name_map_exists THEN
      osp$set_status_abnormal ('PM', pme$e_no_block_name_map, '', status);
      RETURN;
    IFEND;
?? EJECT ??

    FOR i := 1 TO number_of_sets DO
      clp$get_value ('AMOUNT', i, 1, clc$low, parameter, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF parameter.name.value = 'ALL' THEN
        IF number_of_sets = 1 THEN
          IF pmv$mpe_seq_descriptor.local_execution_time_totals <> NIL THEN
            environment_contents := environment_contents + $pmt$environment_contents
                  [pmc$execution_time_totals];
          IFEND;

          IF pmv$mpe_seq_descriptor.connectivity_matrix <> NIL THEN
            environment_contents := environment_contents + $pmt$environment_contents
                  [pmc$connectivity_matrix];
          IFEND;
        ELSE
          osp$set_status_abnormal ('PM', cle$all_must_be_used_alone, 'AMOUNT', status);
          RETURN;
        IFEND;
      ELSEIF (parameter.name.value = 'CONNECTIVITY_MATRIX') OR (parameter.name.value = 'CM') THEN
        IF pmv$mpe_seq_descriptor.connectivity_matrix = NIL THEN
          osp$set_status_abnormal ('PM', pme$e_no_connectivity_matrix, '', status);
          RETURN;
        IFEND;

        environment_contents := environment_contents + $pmt$environment_contents [pmc$connectivity_matrix];
      ELSEIF (parameter.name.value = 'EXECUTION_TIME_TOTALS') OR (parameter.name.value = 'ETT') THEN
        IF pmv$mpe_seq_descriptor.local_execution_time_totals = NIL THEN
          osp$set_status_abnormal ('PM', pme$e_no_execution_time_totals, '', status);
          RETURN;
        IFEND;

        environment_contents := environment_contents + $pmt$environment_contents [pmc$execution_time_totals];
      IFEND;
    FOREND;

    pmp$save_program_measures (measures, environment_contents, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND save_program_measures;
?? OLDTITLE ??
?? NEWTITLE := '  create_restructure_commands', EJECT ??

  PROCEDURE create_restructuring_commands (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{ pdt crerc_pdt (
{   restructuring_commands, rc: file = $required
{   restructured_module, rm: file = $required
{   restructured_module_name, rmn: any
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      crerc_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^crerc_pdt_names,
        ^crerc_pdt_params];

    VAR
      crerc_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
        clt$parameter_name_descriptor := [['RESTRUCTURING_COMMANDS', 1], ['RC', 1], ['RESTRUCTURED_MODULE',
        2], ['RM', 2], ['RESTRUCTURED_MODULE_NAME', 3], ['RMN', 3], ['STATUS', 4]];

    VAR
      crerc_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor := [

{ RESTRUCTURING_COMMANDS RC }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ RESTRUCTURED_MODULE RM }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ RESTRUCTURED_MODULE_NAME RMN }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$any_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??


    VAR
      commands: amt$local_file_name,
      library: clt$file,
      file_reference: clt$file_reference,
      path_container: clt$path_container,
      path: ^pft$path,
      cycle_selector: clt$cycle_selector,
      open_position: clt$open_position,
      module_name: pmt$program_name,
      parameter: clt$value;


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, crerc_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('RESTRUCTURING_COMMANDS', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    commands := parameter.file.local_file_name;

    clp$get_value ('RESTRUCTURED_MODULE', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    library := parameter.file;

    clp$get_value ('RESTRUCTURED_MODULE_NAME', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
?? EJECT ??

    clp$get_path_description (library, file_reference, path_container, path, cycle_selector, open_position,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter.kind <> clc$unknown_value THEN
      ocp$crack_program_name ('RESTRUCTURED_MODULE_NAME', parameter, module_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      module_name := path^ [UPPERBOUND (path^)];
    IFEND;

    pmp$create_restructure_commands (commands, file_reference, module_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND create_restructuring_commands;
?? OLDTITLE ??
?? NEWTITLE := '  create_restructured_module', EJECT ??

  PROCEDURE create_restructured_module (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{ pdt crerm_pdt (
{   restructured_module, rm: file = $required
{   restructured_module_name, rmn: any
{   restructuring_commands, rc: file
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      crerm_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^crerm_pdt_names,
        ^crerm_pdt_params];

    VAR
      crerm_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
        clt$parameter_name_descriptor := [['RESTRUCTURED_MODULE', 1], ['RM', 1], ['RESTRUCTURED_MODULE_NAME',
        2], ['RMN', 2], ['RESTRUCTURING_COMMANDS', 3], ['RC', 3], ['STATUS', 4]];

    VAR
      crerm_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor := [

{ RESTRUCTURED_MODULE RM }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ RESTRUCTURED_MODULE_NAME RMN }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$any_value]],

{ RESTRUCTURING_COMMANDS RC }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??


    VAR
      return_attribute: [STATIC] array [1 .. 1] of amt$access_selection := [[amc$return_option,
        amc$return_at_task_exit]];


    VAR
      file_reference: clt$file_reference,
      path_container: clt$path_container,
      path: ^pft$path,
      cycle_selector: clt$cycle_selector,
      open_position: clt$open_position,
      library: clt$file,
      commands: amt$local_file_name,
      module_name: pmt$program_name,
      parameter: clt$value;


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, crerm_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('RESTRUCTURED_MODULE', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    library := parameter.file;

    clp$get_value ('RESTRUCTURED_MODULE_NAME', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
?? EJECT ??

    clp$get_path_description (library, file_reference, path_container, path, cycle_selector, open_position,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter.kind <> clc$unknown_value THEN
      ocp$crack_program_name ('RESTRUCTURED_MODULE_NAME', parameter, module_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      module_name := path^ [UPPERBOUND (path^)];
    IFEND;

    clp$get_value ('RESTRUCTURING_COMMANDS', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter.kind <> clc$unknown_value THEN
      commands := parameter.file.local_file_name;
    ELSE
      pmp$get_unique_name (commands, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$file (commands, return_attribute, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    pmp$create_restructured_module (file_reference, module_name, commands, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND create_restructured_module;
?? OLDTITLE ??
?? NEWTITLE := '  display_program_profile', EJECT ??

  PROCEDURE display_program_profile (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{ pdt dispp_pdt (
{   profile_order, po: key module_program_unit, mpu, program_unit, pu, time, t = time
{   program_unit_class, puc: key all, local, remote = all
{   number, n: integer 0 .. 0ffffffff(16) or key all = all
{   output, o: file = $OUTPUT
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      dispp_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^dispp_pdt_names,
        ^dispp_pdt_params];

    VAR
      dispp_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 9] of
        clt$parameter_name_descriptor := [['PROFILE_ORDER', 1], ['PO', 1], ['PROGRAM_UNIT_CLASS', 2], ['PUC',
        2], ['NUMBER', 3], ['N', 3], ['OUTPUT', 4], ['O', 4], ['STATUS', 5]];

    VAR
      dispp_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of clt$parameter_descriptor := [

{ PROFILE_ORDER PO }
      [[clc$optional_with_default, ^dispp_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [^dispp_pdt_kv1,
        clc$keyword_value]],

{ PROGRAM_UNIT_CLASS PUC }
      [[clc$optional_with_default, ^dispp_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [^dispp_pdt_kv2,
        clc$keyword_value]],

{ NUMBER N }
      [[clc$optional_with_default, ^dispp_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [^dispp_pdt_kv3,
        clc$integer_value, 0, 0ffffffff(16)]],

{ OUTPUT O }
      [[clc$optional_with_default, ^dispp_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      dispp_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of ost$name := [
        'MODULE_PROGRAM_UNIT', 'MPU', 'PROGRAM_UNIT', 'PU', 'TIME', 'T'];

    VAR
      dispp_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of ost$name := ['ALL', 'LOCAL',
        'REMOTE'];

    VAR
      dispp_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['ALL'];

    VAR
      dispp_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'time';

    VAR
      dispp_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

    VAR
      dispp_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

    VAR
      dispp_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??


    VAR
      parameter: clt$value,
      procedures: pmt$procedures,
      profile_order: pmt$profile_order,
      number: 0 .. 0ffffffff(16),
      output: clt$file;


    clp$scan_parameter_list (parameter_list, dispp_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('PROFILE_ORDER', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (parameter.name.value = 'MODULE_PROGRAM_UNIT') OR (parameter.name.value = 'MPU') THEN
      profile_order := pmc$module_procedure;
    ELSEIF (parameter.name.value = 'PROGRAM_UNIT') OR (parameter.name.value = 'PU') THEN
      profile_order := pmc$procedure;
    ELSEIF (parameter.name.value = 'TIME') OR (parameter.name.value = 'T') THEN
      profile_order := pmc$time;
    IFEND;

    clp$get_value ('PROGRAM_UNIT_CLASS', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter.name.value = 'ALL' THEN
      IF pmv$loader_seq_descriptor^.local_block_id = 0 THEN
        procedures := pmc$remote;
      ELSEIF pmv$loader_seq_descriptor^.remote_block_id = 0 THEN
        procedures := pmc$local;
      ELSE
        procedures := pmc$all;
      IFEND;
    ELSEIF parameter.name.value = 'LOCAL' THEN
      IF pmv$loader_seq_descriptor^.local_block_id = 0 THEN
        osp$set_status_abnormal ('PM', pme$e_no_local_program_units, '', status);
        RETURN;
      IFEND;
      procedures := pmc$local;
    ELSEIF parameter.name.value = 'REMOTE' THEN
      IF pmv$loader_seq_descriptor^.remote_block_id = 0 THEN
        osp$set_status_abnormal ('PM', pme$e_no_remote_program_units, '', status);
        RETURN;
      IFEND;
      procedures := pmc$remote;
    IFEND;

    clp$get_value ('NUMBER', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter.kind = clc$integer_value THEN
      number := parameter.int.value;
    ELSE
      number := pmv$loader_seq_descriptor^.local_block_id + pmv$loader_seq_descriptor^.remote_block_id;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output := parameter.file;

    pmp$display_program_profile (profile_order, procedures, number, output, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_program_profile;
?? OLDTITLE ??
?? NEWTITLE := '  quit', EJECT ??

  PROCEDURE quit (parameter_list: clt$parameter_list;
    VAR status: ost$status);





{ pdt quit_pdt ()

?? PUSH (LISTEXT := ON) ??

    VAR
      quit_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, quit_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_scan_command_file (mpe_utility_name, status);

  PROCEND quit;
?? OLDTITLE ??
?? NEWTITLE := '  pmp$measure_program_execution', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$measure_program_execution (parameter_list: clt$parameter_list;
    VAR status: ost$status);




{ pdt meape_pdt (
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      meape_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^meape_pdt_names,
        ^meape_pdt_params];

    VAR
      meape_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
        clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      meape_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

?? PUSH (LISTEXT := ON) ??

    VAR
      build_real_memory_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^build_real_memory_pdt_names, ^build_real_memory_pdt_params];

    VAR
      build_real_memory_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of
        clt$parameter_name_descriptor := [['STATUS', 1], ['ST', 1]];

    VAR
      build_real_memory_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
        clt$parameter_descriptor := [

{ STATUS ST }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??
?? EJECT ??
{ table mpe_command_list t=c s=local
{   command (set_program_description        ,setpd) set_program_description cm=local
{   command (restore_program_measures       ,respm) restore_program_measures cm=local
{   command (execute_instrumented_task      ,exeit) execute_instrumented_task cm=local
{   command (save_program_measures          ,savpm) save_program_measures cm=local
{   command (create_restructuring_commands  ,crerc) create_restructuring_commands cm=local
{   command (create_restructured_module     ,crerm) create_restructured_module cm=local
{   command (display_program_profile        ,dispp) display_program_profile cm=local
{   command (quit                           ,qui) quit cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??
VAR
  mpe_command_list: [STATIC, READ] ^clt$command_table :=
      ^mpe_command_list_entries,

  mpe_command_list_entries: [STATIC, READ] array [1 .. 16] of
      clt$command_table_entry := [
  {} ['CREATE_RESTRUCTURED_MODULE     ', clc$nominal_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^create_restructured_module],
  {} ['CREATE_RESTRUCTURING_COMMANDS  ', clc$nominal_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^create_restructuring_commands],
  {} ['CRERC                          ', clc$abbreviation_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^create_restructuring_commands],
  {} ['CRERM                          ', clc$abbreviation_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^create_restructured_module],
  {} ['DISPLAY_PROGRAM_PROFILE        ', clc$nominal_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^display_program_profile],
  {} ['DISPP                          ', clc$abbreviation_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^display_program_profile],
  {} ['EXECUTE_INSTRUMENTED_TASK      ', clc$nominal_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^execute_instrumented_task],
  {} ['EXEIT                          ', clc$abbreviation_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^execute_instrumented_task],
  {} ['QUI                            ', clc$abbreviation_entry, clc$advertised_entry, 8,
        clc$automatically_log, clc$linked_call, ^quit],
  {} ['QUIT                           ', clc$nominal_entry, clc$advertised_entry, 8,
        clc$automatically_log, clc$linked_call, ^quit],
  {} ['RESPM                          ', clc$abbreviation_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^restore_program_measures],
  {} ['RESTORE_PROGRAM_MEASURES       ', clc$nominal_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^restore_program_measures],
  {} ['SAVE_PROGRAM_MEASURES          ', clc$nominal_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^save_program_measures],
  {} ['SAVPM                          ', clc$abbreviation_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^save_program_measures],
  {} ['SETPD                          ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^set_program_description],
  {} ['SET_PROGRAM_DESCRIPTION        ', clc$nominal_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^set_program_description]];


?? POP ??
?? EJECT ??

    VAR
      attribute_validation: ^fst$file_cycle_attributes,
      ignore_status: ost$status,
      interblock_file_name: ost$name,
      interblock_file_opened: boolean,
      interblock_id: amt$file_identifier,
      loader_file_name: ost$name,
      loader_file_opened: boolean,
      loader_id: amt$file_identifier,
      parameter: clt$value,
      segment_pointer: amt$segment_pointer;

    status.normal := TRUE;
    interblock_file_name := osc$null_name;
    interblock_file_opened := FALSE;
    loader_file_opened := FALSE;
    pmv$interblock_references_hdr := NIL;
    pmv$loader_seq_descriptor := NIL;

    clp$scan_parameter_list (parameter_list, meape_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    pmp$get_unique_name (loader_file_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmv$loader_description.mpe_loader_seq := loader_file_name;
    pmv$loader_description.apd_load := TRUE;

  /establish_files/
    BEGIN
      fsp$open_file (loader_file_name, amc$segment, ^work_file_attachment, NIL, ^work_file_attributes, NIL,
            NIL, loader_id, status);
      IF NOT status.normal THEN
        EXIT /establish_files/;
      IFEND;

      loader_file_opened := TRUE;
      amp$get_segment_pointer (loader_id, amc$sequence_pointer, segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /establish_files/;
      IFEND;

      RESET segment_pointer.sequence_pointer;
      NEXT pmv$loader_seq_descriptor IN segment_pointer.sequence_pointer;
      IF pmv$loader_seq_descriptor = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        EXIT /establish_files/;
      IFEND;

      pmv$loader_seq_descriptor^.seq_ptr := segment_pointer.sequence_pointer;
      pmv$loader_seq_descriptor^.file_id := loader_id;

      pmp$get_unique_name (interblock_file_name, status);
      IF NOT status.normal THEN
        EXIT /establish_files/;
      IFEND;

      pmv$loader_seq_descriptor^.first_interblock_segment_name := interblock_file_name;
      PUSH attribute_validation: [1 .. 4];
      attribute_validation^ [1].selector := fsc$file_contents_and_processor;
      attribute_validation^ [1].file_contents := fsc$data;
      attribute_validation^ [1].file_processor := fsc$unknown_processor;
      attribute_validation^ [2].selector := fsc$file_organization;
      attribute_validation^ [2].file_organization := amc$sequential;
      attribute_validation^ [3].selector := fsc$record_type;
      attribute_validation^ [3].record_type := amc$undefined;

{ Set the file limit to 2 GB.

      attribute_validation^ [4].selector := fsc$file_limit;
      attribute_validation^ [4].file_limit := 2000000000;

      fsp$open_file (interblock_file_name, amc$segment, ^work_file_attachment, NIL, attribute_validation,
            NIL, NIL, interblock_id, status);
      IF NOT status.normal THEN
        EXIT /establish_files/;
      IFEND;

      amp$get_segment_pointer (interblock_id, amc$sequence_pointer, segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /establish_files/;
      IFEND;

      RESET segment_pointer.sequence_pointer;
      NEXT pmv$interblock_references_hdr IN segment_pointer.sequence_pointer;
      IF pmv$interblock_references_hdr = NIL THEN
        osp$set_status_abnormal ('PM', pme$e_internal_mpe_seg_overflow, '', status);
        EXIT /establish_files/;
      IFEND;

      pmv$interblock_references_hdr^.file_id := interblock_id;
      pmv$loader_seq_descriptor^.last_interblock_segment := segment_pointer.sequence_pointer;

      ocp$create_transient_segment (amc$sequence_pointer, segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /establish_files/;
      IFEND;

      RESET segment_pointer.sequence_pointer;
      pmv$mpe_seq_descriptor.seq_ptr := segment_pointer.sequence_pointer;

      init_loader_seq_descriptor;
      init_interblock_references_hdr;
      init_mpe_seq_descriptor;
    END /establish_files/;

    IF NOT status.normal THEN
      IF interblock_file_name <> osc$null_name THEN
        IF interblock_file_opened THEN
          fsp$close_file (interblock_id, ignore_status);
        IFEND;
        amp$return (interblock_file_name, ignore_status);
      IFEND;
      IF loader_file_opened THEN
        fsp$close_file (loader_id, ignore_status);
      IFEND;
      amp$return (loader_file_name, ignore_status);
      RETURN;
    IFEND;

    pmp$establish_end_handler (^end_handler, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$push_utility (mpe_utility_name, clc$global_command_search, mpe_command_list, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_command_file (command_file, mpe_utility_name, mpe_prompt_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    release_files (ignore_status);

    pmp$disestablish_end_handler (^end_handler, ignore_status);

    clp$pop_utility (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


  PROCEND pmp$measure_program_execution;

MODEND pmm$mpe_command_handlers;

*DECK DECK=PMM$MPE_RECORD_CALL_AND_RETURN EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE  Program Management : APD Miscellaneous routines' ??
?? NEWTITLE := '  PMM$MPE_RECORD_CALL_AND_RETURN' ??
MODULE pmm$mpe_record_call_and_return;
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$segment_pointer
*copyc clt$file
*copyc ost$date
*copyc ost$stack_frame_save_area
*copyc pme$analyze_program_dynamics
*copyc pmt$loader_seq_descriptor
*copyc pmt$condition_information
*copyc pmt$condition
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$return
*copyc amp$set_segment_eoi
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$set_status_abnormal
*copyc pmp$abort
*copyc pmp$get_unique_name
*copyc pmp$get_apd_task_jobmode_stats
*copyc pmp$meape_segments_constrained

?? NEWTITLE := '    PROCESS_BLOCK_EXITS' ??
?? EJECT ??

  PROCEDURE [XDCL] process_block_exits
    (    condition: pmt$condition;
         condition_descriptor: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR status: ost$status);


    TYPE
      program_register = record
        filler: 0 .. 0ffff(16),
        instruction_opcode: ^0 .. 0ff(16),
      recend;

    CONST
      return_opcode = 04,
      pop_opcode = 06;

    VAR
      loader_seq_descriptor_ptr: ^pmt$loader_seq_descriptor,
      converter: record
        case 0 .. 1 of
        = 0 =
          stack_frame_save_area: ^ost$stack_frame_save_area,
        = 1 =
          p_register: ^program_register,
        casend,
      recend,
      current_job_statistics: pmt$apd_task_jobmode_statistics,
      final_job_statistics: pmt$apd_task_jobmode_statistics,
      interblock_reference_ptr: ^pmt$interblock_reference,
      interblock_references_hdr: ^pmt$interblock_references_hdr,
      interblock_reference_string: ^array [1 .. * ] of pmt$interblock_reference,
      opcode: 0 .. 0ff(16),
      p_register: program_register;


    loader_seq_descriptor_ptr := condition_descriptor;

    IF loader_seq_descriptor_ptr^.mpe_aborted THEN
      status.normal := TRUE;
      RETURN;
    ELSE
      pmp$get_apd_task_jobmode_stats (current_job_statistics);

      NEXT interblock_reference_ptr IN loader_seq_descriptor_ptr^.last_interblock_segment;
      IF interblock_reference_ptr = NIL THEN
        pmp$open_new_interblock_segment (loader_seq_descriptor_ptr^.seq_ptr);
        NEXT interblock_reference_ptr IN loader_seq_descriptor_ptr^.last_interblock_segment;
      IFEND;

      RESET loader_seq_descriptor_ptr^.last_interblock_segment;
      NEXT interblock_references_hdr IN loader_seq_descriptor_ptr^.last_interblock_segment;
      interblock_references_hdr^.number_of_interblock_references :=
            interblock_references_hdr^.number_of_interblock_references + 1;
      NEXT interblock_reference_string: [1 .. interblock_references_hdr^.number_of_interblock_references] IN
            loader_seq_descriptor_ptr^.last_interblock_segment;

      IF pmc$block_exit IN condition.reason THEN
        converter.stack_frame_save_area := save_area;
        p_register := converter.p_register^;
        opcode := p_register.instruction_opcode^;

        CASE opcode OF
        = return_opcode =
          interblock_reference_ptr^.reference_type := pmc$return;
          interblock_reference_ptr^.reference_time := current_job_statistics.jobmode_cptime -
                loader_seq_descriptor_ptr^.accumulated_intercept_time;
          interblock_reference_ptr^.page_fault_stats := current_job_statistics.paging_statistics;

        = pop_opcode =
          interblock_reference_ptr^.reference_type := pmc$pop;

        ELSE
          loader_seq_descriptor_ptr^.mpe_aborted := TRUE;
          osp$set_status_abnormal (pmc$program_management_id, pme$e_fatal_intercept_error, '', status);
          pmp$abort (status);
        CASEND;

      ELSE { pmc$program_termination or pmc$abort }

        interblock_reference_ptr^.reference_type := pmc$pop;
      IFEND;
      pmp$get_apd_task_jobmode_stats (final_job_statistics);

      loader_seq_descriptor_ptr^.accumulated_intercept_time :=
            loader_seq_descriptor_ptr^.accumulated_intercept_time +
            loader_seq_descriptor_ptr^.average_stats_request_time +
            (final_job_statistics.jobmode_cptime - current_job_statistics.jobmode_cptime);
    IFEND;

  PROCEND process_block_exits;
?? OLDTITLE ??
?? NEWTITLE := '    PROCESS_EXITS_FROM_APD' ??
?? EJECT ??

  PROCEDURE [XDCL] process_exit_from_apd
    (    condition: pmt$condition;
         condition_descriptor: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR status: ost$status);

    VAR
      loader_seq_descriptor_ptr: ^pmt$loader_seq_descriptor;


    loader_seq_descriptor_ptr := condition_descriptor;

    IF loader_seq_descriptor_ptr^.mpe_aborted THEN
      RETURN;
    IFEND;

    pmp$add_final_interblock_ref (loader_seq_descriptor_ptr);

  PROCEND process_exit_from_apd;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$add_final_interblock_ref', EJECT ??

{ PURPOSE:
{   The purpose of this request is to record the final interblock reference
{   for an instumented APD task in the interblock references file when the
{   task has completed or aborted.
{
{ NOTES:
{   The loader and interblock references processing files for an APD task are
{   are not closed here since the task may still execute an end handler
{   before terminating.  An end handler causes task termination to call this
{   procedure to record its last interblock reference.  The processing files
{   are closed at task termination after all possible calls to this procedure
{   have been made.

  PROCEDURE [XDCL] pmp$add_final_interblock_ref
    (    loader_seq_descriptor_p: ^pmt$loader_seq_descriptor);

    VAR
      current_job_statistics: pmt$apd_task_jobmode_statistics,
      interblock_reference_ptr: ^pmt$interblock_reference,
      interblock_references_hdr: ^pmt$interblock_references_hdr,
      interblock_reference_string: ^array [1 .. * ] of pmt$interblock_reference;

    IF (loader_seq_descriptor_p = NIL) OR (loader_seq_descriptor_p^.mpe_aborted) THEN
      RETURN;
    IFEND;

    NEXT interblock_reference_ptr IN loader_seq_descriptor_p^.last_interblock_segment;
    IF interblock_reference_ptr = NIL THEN
      pmp$open_new_interblock_segment (loader_seq_descriptor_p^.seq_ptr);
      NEXT interblock_reference_ptr IN loader_seq_descriptor_p^.last_interblock_segment;
    IFEND;

    RESET loader_seq_descriptor_p^.last_interblock_segment;
    NEXT interblock_references_hdr IN loader_seq_descriptor_p^.last_interblock_segment;
    interblock_references_hdr^.number_of_interblock_references :=
          interblock_references_hdr^.number_of_interblock_references + 1;
    NEXT interblock_reference_string: [1 .. interblock_references_hdr^.number_of_interblock_references] IN
          loader_seq_descriptor_p^.last_interblock_segment;

    pmp$get_apd_task_jobmode_stats (current_job_statistics);

    interblock_reference_ptr^.reference_type := pmc$final_return;
    interblock_reference_ptr^.reference_time := current_job_statistics.jobmode_cptime -
          loader_seq_descriptor_p^.accumulated_intercept_time;
    interblock_reference_ptr^.page_fault_stats := current_job_statistics.paging_statistics;

  PROCEND pmp$add_final_interblock_ref;
?? OLDTITLE ??
?? NEWTITLE := '  PMP$OPEN_NEW_INTERBLOCK_SEGMENT' ??
?? EJECT ??

  PROCEDURE [XDCL] pmp$open_new_interblock_segment
    (VAR loader_seq_descriptor_ptr: ^SEQ ( * ));

    VAR
      constrained: boolean,
      file_attachment: ^fst$attachment_options,
      file_id: amt$file_identifier,
      file_name: ost$name,
      ignore_status: ost$status,
      interblock_reference_string: ^array [1 .. * ] of pmt$interblock_reference,
      interblock_references_hdr: ^pmt$interblock_references_hdr,
      loader_seq_descriptor: ^pmt$loader_seq_descriptor,
      loader_seq_descriptor_ptr_copy: ^SEQ ( * ),
      mandated_creation_attributes: ^fst$file_cycle_attributes,
      old_segment_pointer: amt$segment_pointer,
      segment_pointer: amt$segment_pointer,
      status: ost$status;

    pmp$meape_segments_constrained (constrained);
    IF constrained THEN
      RETURN;
    IFEND;

    pmp$get_unique_name (file_name, status);
    IF NOT status.normal THEN
      pmp$abort (status);
    IFEND;

    PUSH file_attachment: [1 .. 1];
    file_attachment^ [1].selector := fsc$access_and_share_modes;
    file_attachment^ [1].access_modes.selector := fsc$specific_access_modes;
    file_attachment^ [1].access_modes.value := $fst$file_access_options
          [fsc$read, fsc$append, fsc$modify, fsc$shorten];
    file_attachment^ [1].share_modes.selector := fsc$determine_from_access_modes;

    PUSH mandated_creation_attributes: [1 .. 3];
    mandated_creation_attributes^ [1].selector := fsc$file_contents_and_processor;
    mandated_creation_attributes^ [1].file_contents := fsc$data;
    mandated_creation_attributes^ [1].file_processor := fsc$unknown_processor;
    mandated_creation_attributes^ [2].selector := fsc$file_organization;
    mandated_creation_attributes^ [2].file_organization := amc$sequential;
    mandated_creation_attributes^ [3].selector := fsc$record_type;
    mandated_creation_attributes^ [3].record_type := amc$undefined;

    fsp$open_file (file_name, amc$segment, file_attachment, NIL, mandated_creation_attributes, NIL, NIL,
          file_id, status);
    IF NOT status.normal THEN
      amp$return (file_name, ignore_status);
      pmp$abort (status);
    IFEND;

    amp$get_segment_pointer (file_id, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      fsp$close_file (file_id, ignore_status);
      amp$return (file_name, ignore_status);
      pmp$abort (status);
    IFEND;

    loader_seq_descriptor_ptr_copy := loader_seq_descriptor_ptr;
    RESET loader_seq_descriptor_ptr_copy;
    NEXT loader_seq_descriptor IN loader_seq_descriptor_ptr_copy;
    IF loader_seq_descriptor = NIL THEN
      osp$set_status_abnormal (pmc$program_management_id, pme$e_internal_mpe_seg_overflow, '', status);
      fsp$close_file (file_id, ignore_status);
      amp$return (file_name, ignore_status);
      pmp$abort (status);
    IFEND;

    RESET loader_seq_descriptor^.last_interblock_segment;
    NEXT interblock_references_hdr IN loader_seq_descriptor^.last_interblock_segment;
    IF interblock_references_hdr = NIL THEN
      loader_seq_descriptor^.mpe_aborted := TRUE;
      osp$set_status_abnormal (pmc$program_management_id, pme$e_internal_mpe_seg_overflow, '', status);
      fsp$close_file (file_id, ignore_status);
      amp$return (file_name, ignore_status);
      pmp$abort (status);
    IFEND;
    interblock_references_hdr^.next_segment_file_name := file_name;

    NEXT interblock_reference_string: [1 .. interblock_references_hdr^.number_of_interblock_references] IN
          loader_seq_descriptor^.last_interblock_segment;
    IF interblock_reference_string = NIL THEN
      loader_seq_descriptor^.mpe_aborted := TRUE;
      osp$set_status_abnormal (pmc$program_management_id, pme$e_internal_mpe_seg_overflow, '', status);
      interblock_references_hdr^.next_segment_file_name := osc$null_name;
      fsp$close_file (file_id, ignore_status);
      amp$return (file_name, ignore_status);
      pmp$abort (status);
    IFEND;

    old_segment_pointer.kind := amc$sequence_pointer;
    old_segment_pointer.sequence_pointer := loader_seq_descriptor^.last_interblock_segment;
    amp$set_segment_eoi (interblock_references_hdr^.file_id, old_segment_pointer, status);
    fsp$close_file (interblock_references_hdr^.file_id, status);

    loader_seq_descriptor^.last_interblock_segment := segment_pointer.sequence_pointer;
    loader_seq_descriptor^.number_of_interblock_segments :=
          loader_seq_descriptor^.number_of_interblock_segments + 1;
    RESET loader_seq_descriptor^.last_interblock_segment;
    NEXT interblock_references_hdr IN loader_seq_descriptor^.last_interblock_segment;
    IF interblock_references_hdr = NIL THEN
      loader_seq_descriptor^.mpe_aborted := TRUE;
      osp$set_status_abnormal (pmc$program_management_id, pme$e_internal_mpe_seg_overflow, '', status);
      fsp$close_file (file_id, ignore_status);
      pmp$abort (status);
    IFEND;

    interblock_references_hdr^.file_id := file_id;
    interblock_references_hdr^.number_of_interblock_references := 0;
    interblock_references_hdr^.next_segment_file_name := osc$null_name;

  PROCEND pmp$open_new_interblock_segment;
?? OLDTITLE ??
MODEND pmm$mpe_record_call_and_return;
*DECK DECK=PMM$MULTI_TASK_CONDITIONS EXPAND=TRUE
MODULE pmm$multi_task_conditions;

?? NEWTITLE := 'Global Declarations' ??
?? PUSH (LISTEXT := ON) ??
*copyc osc$unseen_mail_condition
*copyc osd$default_pragmats
*copyc ost$global_task_id
*copyc pme$condition_exceptions
*copyc pmk$keypoints
*copyc pmt$condition_name
*copyc pmt$task_id
?? POP ??
*copyc clp$find_unseen_mail_action
*copyc clp$validate_name
*copyc osp$set_status_abnormal
*copyc pmp$cause_task_condition
*copyc pmp$find_task_xcb
*copyc pmp$post_unseen_mail
*copyc pmp$propagate_unseen_mail
*copyc pmp$send_signal
*copyc tmc$signal_identifiers

?? TITLE := 'pmp$cause_inter_job_condition', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$cause_inter_job_condition
    (    condition: pmt$condition_name;
         task_id: ost$global_task_id;
     VAR status: ost$status);

    VAR
      signal: pmt$signal,
      vn: ost$name,
      valid: boolean,
      p_condition: ^pmt$condition_name;


    #keypoint (osk$entry, 0, pmk$cause_inter_job_condition);
    clp$validate_name (condition, vn, valid);
    IF NOT valid THEN
      osp$set_status_abnormal (pmc$program_management_id,
            pme$incorrect_condition_name, vn, status);
      #keypoint (osk$exit, 0, pmk$cause_inter_job_condition);
      RETURN;
    IFEND;
    IF (vn (1, 4) = 'CYE$') OR (vn (1, 4) = 'OSC$') THEN
      osp$set_status_abnormal (pmc$program_management_id,
            pme$incorrect_condition_name, vn, status);
      #keypoint (osk$exit, 0, pmk$cause_inter_job_condition);
      RETURN;
    IFEND;

    signal.identifier := pmc$multi_task_condition;
    p_condition := #LOC (signal.contents);
    p_condition^ := condition;

    pmp$send_signal (task_id, signal, status);

    #keypoint (osk$exit, 0, pmk$cause_inter_job_condition);

  PROCEND pmp$cause_inter_job_condition;
?? TITLE := 'pmp$multi_task_signal_handler', EJECT ??

  PROCEDURE [XDCL] pmp$multi_task_signal_handler
    (    originator: ost$global_task_id;
         signal: pmt$signal);

    VAR
      ignore_status: ost$status,
      p_condition: ^pmt$condition_name,
      unseen_mail_action: ^clt$unseen_mail_action;


    p_condition := #LOC (signal.contents);

    IF p_condition^ <> osc$unseen_mail_condition THEN
      pmp$cause_task_condition (p_condition^, NIL, FALSE, FALSE, FALSE, FALSE,
            ignore_status);
    ELSE
      clp$find_unseen_mail_action (unseen_mail_action);
      IF unseen_mail_action^ = clc$post_unseen_mail THEN
        pmp$post_unseen_mail;
      ELSE
        pmp$propagate_unseen_mail (ignore_status);
      IFEND;
    IFEND;

  PROCEND pmp$multi_task_signal_handler;

MODEND pmm$multi_task_conditions;
*DECK DECK=PMM$OBJECT_CODE_UTILITIES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Program Management : Object Code Utilities' ??
?? NEWTITLE := '  Global declarations', EJECT ??
MODULE pmm$object_code_utilities;
?? PUSH (LISTEXT := ON) ??
*copyc LLE$LOADER_STATUS_CONDITIONS
*copyc LLE$LOAD_MAP_DIAGNOSTICS
*copyc LLE$FIND_EP_DIAGNOSTICS
*copyc LLT$LOAD_MODULE
*copyc LLT$OBJECT_MODULE
*copyc LLT$LIBRARY_DICTIONARY_POINTERS
*copyc lot$loader_type_definitions
*copyc OSS$JOB_PAGED_LITERAL
*copyc OST$CALLER_IDENTIFIER
*copyc PME$EXECUTION_EXCEPTIONS
*copyc PME$PROGRAM_SERVICES_EXCEPTIONS
*copyc PMK$KEYPOINTS
*copyc PMT$OBJECT_LIBRARY_ADDRESS
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc clp$convert_string_to_file_ref
*copyc dbp$module_table_address
*copyc fsp$close_file
*copyc fsp$open_file
*copyc i#current_sequence_position
*copyc mmp$verify_access
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc pmp$establish_condition_handler
?? TITLE := '  [XDCL, #GATE] pmp$get_entry_point_dictionary', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_entry_point_dictionary
    (    library: ^SEQ ( * );
     VAR entry_point_dictionary: ^llt$entry_point_dictionary;
     VAR status: ost$status);


    VAR
      i: 0 .. llc$max_dictionaries_on_library,
      object_library: ^SEQ ( * ),
      object_library_header: ^llt$object_library_header,
      object_library_hdr: ^llt$object_library_header_v1_0,
      object_library_dictionary: ^llt$object_library_dictionaries;


    status.normal := TRUE;
    entry_point_dictionary := NIL;

    object_library := library;
    RESET object_library;

    NEXT object_library_header IN object_library;
    IF object_library_header = NIL THEN
      osp$set_status_abnormal ('PM', pme$library_header_missing, '', status);
      RETURN;
    IFEND;

    IF object_library_header^.version = llc$object_library_version THEN
      NEXT object_library_dictionary: [1 .. object_library_header^.number_of_dictionaries] IN object_library;
      IF object_library_dictionary = NIL THEN
        osp$set_status_abnormal ('PM', pme$library_header_missing, '', status);
        RETURN;
      IFEND;

    /find_entry_point_dictionary/
      FOR i := LOWERBOUND (object_library_dictionary^) TO UPPERBOUND (object_library_dictionary^) DO
        IF (object_library_dictionary^ [i].kind = llc$entry_point_dictionary) THEN
          entry_point_dictionary := #PTR (object_library_dictionary^ [i].entry_point_dictionary,
                object_library^);
          EXIT /find_entry_point_dictionary/;
        IFEND;
      FOREND /find_entry_point_dictionary/;

    ELSEIF object_library_header^.version = 'V1.0' THEN
      RESET object_library;
      NEXT object_library_hdr IN object_library;
      entry_point_dictionary := #PTR (object_library_hdr^.entry_point_dictionary, object_library^);

    ELSE
      osp$set_status_abnormal ('PM', pme$wrong_library_version, llc$object_library_version, status);
      RETURN;

    IFEND;

    IF entry_point_dictionary = NIL THEN
      osp$set_status_abnormal ('PM', pme$bad_entry_dictionary_ptr, llc$object_library_version, status);
    IFEND;
  PROCEND pmp$get_entry_point_dictionary;
?? TITLE := '  [XDCL, #GATE] pmp$position_object_library', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$position_object_library
    (VAR object_library: ^SEQ ( * );
         offset: ost$relative_pointer;
     VAR valid_position: boolean);


    VAR
      space: ^SEQ ( * );


    RESET object_library;

    IF offset <> 0 THEN
      NEXT space: [[REP offset OF cell]] IN object_library;
      valid_position := space <> NIL;

    ELSE
      valid_position := TRUE;

    IFEND;
  PROCEND pmp$position_object_library;
?? TITLE := '  [XDCL, #GATE] pmp$get_last_path_name', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_last_path_name
    (    path: fst$file_reference;
     VAR last_name: ost$name;
     VAR status: ost$status);

    VAR
      parsed_file_reference: fst$parsed_file_reference;


    clp$convert_string_to_file_ref (path, parsed_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    last_name := parsed_file_reference.path (parsed_file_reference.last_name.index,
          parsed_file_reference.last_name.size);

  PROCEND pmp$get_last_path_name;
?? TITLE := '[XDCL, #GATE] pmp$find_entry_point_in_library', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$find_entry_point_in_library
    (    object_library: ^SEQ ( * );
         entry_point_name: pmt$program_name;
     VAR address: pmt$object_library_address;
     VAR status: ost$status);

*copyc pmh$find_entry_point_in_library

?? NEWTITLE := '    unaccessable_library', EJECT ??

    PROCEDURE unaccessable_library
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      osp$set_status_from_condition ('PM', condition, save_area, status, handler_status);
      EXIT pmp$find_entry_point_in_library;
    PROCEND unaccessable_library;

?? OLDTITLE, EJECT ??

    VAR
      access_fault: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
            [pmc$system_conditions, $pmt$system_conditions [pmc$access_violation, pmc$invalid_segment_ring_0,
            pmc$address_specification], * ],
      access_fault_descriptor: pmt$established_handler,
      caller: ost$caller_identifier,
      entry_point_dictionary_item: llt$entry_point_dictionary_item,
      entry_point_found: boolean,
      ignore_status: ost$status,
      library: lot$load_file,
      module_header: ^llt$load_module_header,
      program_header: ^llt$library_member_header,
      scl_header: ^llt$library_member_header,
      verify_status: ost$status,
      version: string (4);

    #CALLER_ID (caller);

    status.normal := TRUE;
    pmp$establish_condition_handler (access_fault, ^unaccessable_library, ^access_fault_descriptor,
          ignore_status);

    pmp$verify_library (object_library, version, verify_status);
    IF verify_status.normal THEN
      entry_point_found := FALSE;
      find_entry_point_in_library (^entry_point_name, object_library, entry_point_found,
            entry_point_dictionary_item, verify_status);
      IF verify_status.normal THEN
        IF NOT entry_point_found THEN
          osp$set_status_abnormal ('PM', lle$entry_point_not_found, entry_point_name, status);
        ELSE
          CASE entry_point_dictionary_item.module_kind OF

          = llc$load_module =
            address.kind := llc$load_module;
            module_header := #PTR (entry_point_dictionary_item.module_header, object_library^);
            IF module_header <> NIL THEN
              library := object_library;
              get_load_module (^entry_point_name, module_header, library, address.load_module, status);
            ELSE
              osp$set_status_abnormal ('PM', lle$bad_load_header_ptr, '', status);
            IFEND;

          = llc$program_description =
            address.kind := llc$program_description;
            program_header := #PTR (entry_point_dictionary_item.program_header, object_library^);
            IF program_header <> NIL THEN
              address.program_description := #PTR (program_header^.member, object_library^);
              IF address.program_description <> NIL THEN
                RESET address.program_description;
              ELSE
                osp$set_status_abnormal ('PM', lle$bad_library_member_header, 'PROGRAM', status);
              IFEND;
            ELSE
              osp$set_status_abnormal ('PM', lle$bad_program_header_ptr, '', status);
            IFEND;

          = llc$command_procedure =
            address.kind := llc$command_procedure;
            scl_header := #PTR (entry_point_dictionary_item.command_header, object_library^);
            IF scl_header <> NIL THEN
              address.scl_procedure := #PTR (scl_header^.member, object_library^);
              IF address.scl_procedure <> NIL THEN
                RESET address.scl_procedure;
              ELSE
                osp$set_status_abnormal ('PM', lle$bad_library_member_header, 'SCL PROCEDURE', status);
              IFEND;
            ELSE
              osp$set_status_abnormal ('PM', lle$bad_scl_header_ptr, '', status);
            IFEND;
          ELSE
            ;
          CASEND;
        IFEND;
      ELSE
        status := verify_status;
      IFEND;
    ELSE
      status := verify_status;
    IFEND;


  PROCEND pmp$find_entry_point_in_library;
?? TITLE := '  find_entry_point_in_library', EJECT ??

  PROCEDURE find_entry_point_in_library
    (    name: {input} ^pmt$program_name;
         library_file: lot$load_file;
     VAR entry_point_found: boolean;
     VAR entry_point_dictionary_item: llt$entry_point_dictionary_item;
     VAR status: ost$status);

{  PURPOSE:
{    This procedure searches the entry_point dictionary of the specified library for name.
{    If the name is located, the corresponding entry_point dictionary item is returned.

?? NEWTITLE := '    search_entry_point_dictionary', EJECT ??

    PROCEDURE search_entry_point_dictionary
      (    name: {input} ^pmt$program_name;
           entry_point_dictionary: {input} ^llt$entry_point_dictionary;
       VAR entry_point_found {control} : boolean;
       VAR dictionary_index: 1 .. llc$max_entry_points_in_library);

      VAR
        temp: integer,
        lower: 1 .. llc$max_entry_points_in_library,
        upper: 0 .. llc$max_entry_points_in_library;

      lower := LOWERBOUND (entry_point_dictionary^);
      upper := UPPERBOUND (entry_point_dictionary^);
      entry_point_found := FALSE;

    /binary_search/
      WHILE (lower <= upper) AND (NOT entry_point_found) DO
        temp := lower + upper;
        dictionary_index := temp DIV 2;
        IF name^ = entry_point_dictionary^ [dictionary_index].name THEN
          entry_point_found := TRUE;
        ELSEIF name^ > entry_point_dictionary^ [dictionary_index].name THEN
          lower := dictionary_index + 1;
        ELSE
          upper := dictionary_index - 1;
        IFEND;
      WHILEND /binary_search/;
    PROCEND search_entry_point_dictionary;
?? OLDTITLE, EJECT ??

    VAR
      dictionary_index: 1 .. llc$max_entry_points_in_library,
      entry_point_dictionary: ^llt$entry_point_dictionary,
      i: 0 .. llc$max_dictionaries_on_library,
      library: lot$load_file,
      library_dictionary: ^llt$object_library_dictionaries,
      library_hdr: ^llt$object_library_header_v1_0,
      library_header: ^llt$object_library_header,
      number_of_entry_points: 0 .. llc$max_entry_points_in_library;

    status.normal := TRUE;
    entry_point_found := FALSE;

    library := library_file;
    RESET library;
    NEXT library_header IN library;

    IF library_header^.version = llc$object_library_version THEN
      NEXT library_dictionary: [1 .. library_header^.number_of_dictionaries] IN library;
      IF library_dictionary = NIL THEN
        osp$set_status_abnormal ('PM', lle$library_header_missing, '', status);
        RETURN;
      IFEND;

      number_of_entry_points := 0;

    /find_entry_point_dictionary/
      FOR i := LOWERBOUND (library_dictionary^) TO UPPERBOUND (library_dictionary^) DO
        IF (library_dictionary^ [i].kind = llc$entry_point_dictionary) THEN
          entry_point_dictionary := #PTR (library_dictionary^ [i].entry_point_dictionary, library^);
          number_of_entry_points := UPPERBOUND (entry_point_dictionary^);
          EXIT /find_entry_point_dictionary/;
        IFEND;
      FOREND /find_entry_point_dictionary/;

    ELSEIF library_header^.version = 'V1.0' THEN
      RESET library;
      NEXT library_hdr IN library;
      number_of_entry_points := library_hdr^.number_of_entry_points;
      entry_point_dictionary := #PTR (library_hdr^.entry_point_dictionary, library^);

    ELSE
      osp$set_status_abnormal ('PM', lle$wrong_library_version, llc$object_library_version, status);
      RETURN;
    IFEND;

    IF number_of_entry_points > 0 THEN
      search_entry_point_dictionary (name, entry_point_dictionary, entry_point_found, dictionary_index);
      IF entry_point_found THEN
        entry_point_dictionary_item := entry_point_dictionary^ [dictionary_index];
      IFEND;
    IFEND;
  PROCEND find_entry_point_in_library;
?? TITLE := '  [XDCL, #GATE] pmp$verify_library', EJECT ??
*copy pmh$verify_library

  PROCEDURE [XDCL, #GATE] pmp$verify_library
    (    library_file: ^SEQ ( * );
     VAR version: string (4);
     VAR status: ost$status);

    VAR
      entry_dictionary: ^llt$entry_point_dictionary,
      i: 0 .. llc$max_dictionaries_on_library,
      lib: ^cell,
      library: lot$load_file,
      library_dictionary: ^llt$object_library_dictionaries,
      library_hdr: ^llt$object_library_header_v1_0,
      library_header: ^llt$object_library_header,
      module_dictionary: ^llt$module_dictionary,
      number_of_entry_points: 0 .. llc$max_entry_points_in_library,
      number_of_modules: 0 .. llc$max_modules_in_library;

    status.normal := TRUE;

    lib := library_file;
    IF (lib = NIL) OR NOT mmp$verify_access (^lib, mmc$va_read) THEN
      osp$set_status_condition (pme$invalid_sequence_pointer, status);
      RETURN;
    IFEND;

    library := library_file;
    RESET library;

    NEXT library_header IN library;
    IF library_header = NIL THEN
      osp$set_status_abnormal ('PM', lle$library_header_missing, '', status);
      RETURN;
    IFEND;

    version := library_header^.version;

    IF library_header^.version = llc$object_library_version THEN
      NEXT library_dictionary: [1 .. library_header^.number_of_dictionaries] IN library;
      IF library_dictionary = NIL THEN
        osp$set_status_abnormal ('PM', lle$library_header_missing, '', status);
        RETURN;
      IFEND;

      number_of_modules := 0;
      number_of_entry_points := 0;

      FOR i := LOWERBOUND (library_dictionary^) TO UPPERBOUND (library_dictionary^) DO
        CASE library_dictionary^ [i].kind OF
        = llc$module_dictionary =
          module_dictionary := #PTR (library_dictionary^ [i].module_dictionary, library^);
          number_of_modules := UPPERBOUND (module_dictionary^);
        = llc$entry_point_dictionary =
          entry_dictionary := #PTR (library_dictionary^ [i].entry_point_dictionary, library^);
          number_of_entry_points := UPPERBOUND (entry_dictionary^);
        ELSE
        CASEND;
      FOREND;

    ELSEIF library_header^.version = 'V1.0' THEN
      RESET library;

      NEXT library_hdr IN library;
      IF library_hdr = NIL THEN
        osp$set_status_abnormal ('PM', lle$library_header_missing, '', status);
        RETURN;
      IFEND;

      number_of_modules := library_hdr^.number_of_modules;
      module_dictionary := #PTR (library_hdr^.module_dictionary, library^);
      number_of_entry_points := library_hdr^.number_of_entry_points;
      entry_dictionary := #PTR (library_hdr^.entry_point_dictionary, library^);

    ELSE
      osp$set_status_abnormal ('PM', lle$wrong_library_version, llc$object_library_version, status);
      RETURN;
    IFEND;

    IF number_of_modules = 0 THEN
      osp$set_status_abnormal ('PM', lle$empty_module_dictionary, '', status);
      RETURN;
    IFEND;

    IF module_dictionary = NIL THEN
      osp$set_status_abnormal ('PM', lle$bad_module_dictionary_ptr, '', status);
      RETURN;
    IFEND;

    IF number_of_entry_points <> 0 THEN
      IF entry_dictionary = NIL THEN
        osp$set_status_abnormal ('PM', lle$bad_entry_dictionary_ptr, '', status);
      IFEND;
    IFEND;

  PROCEND pmp$verify_library;
?? TITLE := '  [XDCL, #GATE] pmp$get_library_directories', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_library_dictionaries
    (    library: ^SEQ ( * );
     VAR dictionaries: llt$library_dictionary_pointers;
     VAR status: ost$status);

*copyc PMH$GET_LIBRARY_DICTIONARIES

    VAR
      i: 0 .. llc$max_dictionaries_on_library,
      library_dictionary: ^llt$object_library_dictionaries,
      local_library: ^SEQ ( * ),
      object_library_hdr: ^llt$object_library_header_v1_0,
      object_library_header: ^llt$object_library_header,
      version: string (4);

    #keypoint (osk$entry, 0, pmk$get_library_dictionaries);
    status. normal := TRUE;

    pmp$verify_library (library, version, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_library := library;
    RESET local_library;
    NEXT object_library_header IN local_library;

    dictionaries.library_version := version;
    dictionaries.module_dictionary := NIL;
    dictionaries.entry_point_dictionary := NIL;
    dictionaries.command_dictionary := NIL;
    dictionaries.function_dictionary := NIL;
    dictionaries.help_module_dictionary := NIL;
    dictionaries.message_module_dictionary := NIL;
    dictionaries.panel_dictionary := NIL;

    IF version = llc$object_library_version THEN
      NEXT library_dictionary: [1 .. object_library_header^.number_of_dictionaries] IN local_library;

      FOR i := LOWERBOUND (library_dictionary^) TO UPPERBOUND (library_dictionary^) DO
        CASE library_dictionary^ [i].kind OF
        = llc$module_dictionary =
          dictionaries.module_dictionary := #PTR (library_dictionary^ [i].module_dictionary, local_library^);
        = llc$entry_point_dictionary =
          dictionaries.entry_point_dictionary := #PTR (library_dictionary^ [i].entry_point_dictionary,
                local_library^);
        = llc$command_dictionary =
          dictionaries.command_dictionary := #PTR (library_dictionary^ [i].command_dictionary,
                local_library^);
        = llc$function_dictionary =
          dictionaries.function_dictionary := #PTR (library_dictionary^ [i].function_dictionary,
                local_library^);
        = llc$help_module_dictionary =
          dictionaries.help_module_dictionary := #PTR (library_dictionary^ [i].help_module_dictionary,
                local_library^);
        = llc$message_module_dictionary =
          dictionaries.message_module_dictionary := #PTR (library_dictionary^ [i].message_module_dictionary,
                local_library^);
        = llc$panel_dictionary =
          dictionaries.panel_dictionary := #PTR (library_dictionary^ [i].panel_dictionary, local_library^);
        ELSE
          ;
        CASEND;
      FOREND;

    ELSEIF object_library_header^.version = 'V1.0' THEN
      RESET local_library;
      NEXT object_library_hdr IN local_library;
      dictionaries.module_dictionary := #PTR (object_library_hdr^.module_dictionary, local_library^);

      IF object_library_hdr^.number_of_entry_points <> 0 THEN
        dictionaries.entry_point_dictionary := #PTR (object_library_hdr^.entry_point_dictionary,
              local_library^);
      IFEND;
    IFEND;

    #keypoint (osk$exit, 0, pmk$get_library_dictionaries);

  PROCEND pmp$get_library_dictionaries;
?? TITLE := '  [XDCL, #GATE] pmp$find_module_in_library', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$find_module_in_library
    (    name: {input} pmt$program_name;
         object_library: ^SEQ ( * );
     VAR address: pmt$object_library_address;
     VAR status: ost$status);

*copyc PMH$FIND_MODULE_IN_LIBRARY

?? NEWTITLE := '    unaccessible_library', EJECT ??

    PROCEDURE unaccessible_library
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      osp$set_status_from_condition ('PM', condition, save_area, status, handler_status);
      #keypoint (osk$exit, 0, pmk$find_module_in_library);
      EXIT pmp$find_module_in_library;
    PROCEND unaccessible_library;
?? OLDTITLE, EJECT ??

    VAR
      command_header: ^llt$library_member_header,
      command_description_header: ^llt$library_member_header,
      dictionary_index: 1 .. llc$max_modules_in_library,
      function_header: ^llt$library_member_header,
      function_description_header: ^llt$library_member_header,
      i: 0 .. llc$max_dictionaries_on_library,
      library: lot$load_file,
      library_dictionary: ^llt$object_library_dictionaries,
      library_hdr: ^llt$object_library_header_v1_0,
      library_header: ^llt$object_library_header,
      message_header: ^llt$library_member_header,
      module_dictionary: ^llt$module_dictionary,
      module_found: boolean,
      module_header: ^llt$load_module_header,
      number_of_modules: 0 .. llc$max_modules_in_library,
      object_text_descriptor: ^llt$object_text_descriptor,
      panel_header: ^llt$library_member_header,
      program_header: ^llt$library_member_header,
      version: string (4);

    #keypoint (osk$entry, 0, pmk$find_module_in_library);
    status.normal := TRUE;

    module_found := FALSE;
    library := object_library;
    RESET library;

    pmp$verify_library (library, version, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET library;
    NEXT library_header IN library;

    IF version = llc$object_library_version THEN

      NEXT library_dictionary: [1 .. library_header^.number_of_dictionaries] IN library;
      IF library_dictionary = NIL THEN
        osp$set_status_abnormal ('PM', lle$library_header_missing, '', status);
        #keypoint (osk$exit, 0, pmk$find_module_in_library);
        RETURN;
      IFEND;

      number_of_modules := 0;

    /find_module_dictionary/
      FOR i := LOWERBOUND (library_dictionary^) TO UPPERBOUND (library_dictionary^) DO
        IF (library_dictionary^ [i].kind = llc$module_dictionary) THEN
          module_dictionary := #PTR (library_dictionary^ [i].module_dictionary, library^);
          number_of_modules := UPPERBOUND (module_dictionary^);
          EXIT /find_module_dictionary/;
        IFEND;
      FOREND /find_module_dictionary/;

    ELSEIF library_header^.version = 'V1.0' THEN
      RESET library;
      NEXT library_hdr IN library;
      number_of_modules := library_hdr^.number_of_modules;
      module_dictionary := #PTR (library_hdr^.module_dictionary, library^);

    ELSE
      osp$set_status_abnormal ('PM', lle$wrong_library_version, llc$object_library_version, status);
      #keypoint (osk$exit, 0, pmk$find_module_in_library);
      RETURN;
    IFEND;

    IF number_of_modules = 0 THEN
      osp$set_status_abnormal ('PM', lle$empty_module_dictionary, '', status);
      #keypoint (osk$exit, 0, pmk$find_module_in_library);
      RETURN;
    IFEND;

    IF module_dictionary = NIL THEN
      osp$set_status_abnormal ('PM', lle$bad_module_dictionary_ptr, '', status);
      #keypoint (osk$exit, 0, pmk$find_module_in_library);
      RETURN;
    IFEND;

    search_for_module_in_dictionary (^name, module_dictionary, module_found, dictionary_index);

    IF module_found THEN
      CASE module_dictionary^ [dictionary_index].kind OF
      = llc$load_module =
        address.kind := llc$load_module;
        module_header := #PTR (module_dictionary^ [dictionary_index].module_header, library^);
        IF module_header <> NIL THEN
          get_load_module (^name, module_header, library, address.load_module, status);
        ELSE
          module_found := FALSE;
          osp$set_status_abnormal ('PM', lle$bad_load_header_ptr, '', status);
        IFEND;

      = llc$ppu_object_module =
        address.kind := llc$ppu_object_module;
        object_text_descriptor := #PTR (module_dictionary^ [dictionary_index].ppu_header, library^);
        IF (object_text_descriptor <> NIL) THEN
          get_ppu_module (^name, object_text_descriptor, library, address.ppu_object_module, status);
        ELSE
          module_found := FALSE;
          osp$set_status_abnormal ('PM', lle$bad_ppu_header_ptr, '', status);
        IFEND;

      = llc$program_description =
        address.kind := llc$program_description;
        program_header := #PTR (module_dictionary^ [dictionary_index].program_header, library^);
        IF program_header <> NIL THEN
          address.program_description := #PTR (program_header^.member, library^);
          IF address.program_description <> NIL THEN
            RESET address.program_description;
          ELSE
            module_found := FALSE;
            osp$set_status_abnormal ('PM', lle$bad_library_member_header, 'PROGRAM DESCRIPTION', status);
          IFEND;
        ELSE
          module_found := FALSE;
          osp$set_status_abnormal ('PM', lle$bad_program_header_ptr, '', status);
        IFEND;

      = llc$command_description =
        address.kind := llc$command_description;
        command_description_header := #PTR (module_dictionary^ [dictionary_index].command_description_header,
              library^);
        IF command_description_header <> NIL THEN
          address.command_description := #PTR (command_description_header^.member, library^);
          IF address.command_description <> NIL THEN
            RESET address.command_description;
          ELSE
            module_found := FALSE;
            osp$set_status_abnormal ('PM', lle$bad_library_member_header, 'COMMAND DESCRIPTION', status);
          IFEND;
        ELSE
          module_found := FALSE;
          osp$set_status_abnormal ('PM', lle$bad_program_header_ptr, '', status);
        IFEND;

      = llc$command_procedure =
        address.kind := llc$command_procedure;
        command_header := #PTR (module_dictionary^ [dictionary_index].command_header, library^);
        IF command_header <> NIL THEN
          address.scl_procedure := #PTR (command_header^.member, library^);
          IF address.scl_procedure <> NIL THEN
            RESET address.scl_procedure;
          ELSE
            module_found := FALSE;
            osp$set_status_abnormal ('PM', lle$bad_library_member_header, 'COMMAND PROCEDURE', status);
          IFEND;
        ELSE
          module_found := FALSE;
          osp$set_status_abnormal ('PM', lle$bad_scl_header_ptr, '', status);
        IFEND;

      = llc$function_procedure =
        address.kind := llc$function_procedure;
        function_header := #PTR (module_dictionary^ [dictionary_index].function_header, library^);
        IF function_header <> NIL THEN
          address.scl_procedure := #PTR (function_header^.member, library^);
          IF address.scl_procedure <> NIL THEN
            RESET address.scl_procedure;
          ELSE
            module_found := FALSE;
            osp$set_status_abnormal ('PM', lle$bad_library_member_header, 'FUNCTION PROCEDURE', status);
          IFEND;
        ELSE
          module_found := FALSE;
          osp$set_status_abnormal ('PM', lle$bad_scl_header_ptr, '', status);
        IFEND;

      = llc$function_description =
        address.kind := llc$function_description;
        function_description_header := #PTR (module_dictionary^ [dictionary_index].
              function_description_header, library^);
        IF function_description_header <> NIL THEN
          address.function_description := #PTR (function_description_header^.member, library^);
          IF address.function_description <> NIL THEN
            RESET address.function_description;
          ELSE
            module_found := FALSE;
            osp$set_status_abnormal ('PM', lle$bad_library_member_header, 'FUNCTION DESCRIPTION', status);
          IFEND;
        ELSE
          module_found := FALSE;
          osp$set_status_abnormal ('PM', lle$bad_program_header_ptr, '', status);
        IFEND;

      = llc$message_module =
        address.kind := llc$message_module;
        message_header := #PTR (module_dictionary^ [dictionary_index].message_header, library^);
        IF message_header <> NIL THEN
          address.message_module := #PTR (message_header^.member, library^);
          IF address.message_module <> NIL THEN
            RESET address.message_module;
          ELSE
            module_found := FALSE;
            osp$set_status_abnormal ('PM', lle$bad_library_member_header, 'MESSAGE MODULE', status);
          IFEND;
        ELSE
          module_found := FALSE;
          osp$set_status_abnormal ('PM', lle$bad_scl_header_ptr, '', status);
        IFEND;

      = llc$panel_module =
        address.kind := llc$panel_module;
        panel_header := #PTR (module_dictionary^ [dictionary_index].panel_header, library^);
        IF panel_header <> NIL THEN
          address.panel_module := #PTR (panel_header^.member, library^);
          IF address.panel_module <> NIL THEN
            RESET address.panel_module;
          ELSE
            module_found := FALSE;
            osp$set_status_abnormal ('PM', lle$bad_library_member_header, 'FORM MODULE', status);
          IFEND;
        ELSE
          module_found := FALSE;
          osp$set_status_abnormal ('PM', lle$bad_scl_header_ptr, '', status);
        IFEND;
      ELSE
        ;
      CASEND;

    ELSE
      osp$set_status_abnormal ('PM', lle$module_not_found, name, status);
    IFEND;

    #keypoint (osk$exit, 0, pmk$find_module_in_library);

  PROCEND pmp$find_module_in_library;
?? TITLE := '  search_for_module_in_dictionary', EJECT ??

  PROCEDURE search_for_module_in_dictionary
    (    name: {input} ^pmt$program_name;
     VAR module_dictionary: {input} ^llt$module_dictionary;
     VAR module_found {control} : boolean;
     VAR dictionary_index: 1 .. llc$max_modules_in_library);

    VAR
      search_index: 1 .. llc$max_modules_in_library;


  /sequential_search/
    FOR search_index := 1 TO UPPERBOUND (module_dictionary^) DO
      IF name^ = module_dictionary^ [search_index].name THEN
        dictionary_index := search_index;
        module_found := TRUE;
        RETURN;
      IFEND;
    FOREND /sequential_search/;
    module_found := FALSE;
  PROCEND search_for_module_in_dictionary;
?? TITLE := '  get_load_module', EJECT ??

  PROCEDURE get_load_module
    (    name: {input} ^pmt$program_name;
         module_header: ^llt$load_module_header;
     VAR library: lot$load_file;
     VAR load_module: ^llt$object_module;
     VAR status: ost$status);

    VAR
      object_text_descriptor_of_ident: ^llt$object_text_descriptor,
      object_text_descriptor_of_tra: ^llt$object_text_descriptor;

    status.normal := TRUE;

    object_text_descriptor_of_ident := #PTR (module_header^.interpretive_element, library^);
    object_text_descriptor_of_tra := #PTR (module_header^.interpretive_header.transfer_symbol, library^);

    RESET library TO object_text_descriptor_of_ident;
    NEXT load_module: [[REP (#OFFSET (object_text_descriptor_of_tra) + #SIZE (llt$object_text_descriptor) +
          #SIZE (llt$transfer_symbol) - #OFFSET (object_text_descriptor_of_ident)) OF cell]] IN library;
    IF load_module = NIL THEN
      osp$set_status_abnormal ('PM', lle$bad_module, name^, status);
      RETURN;
    IFEND;

  PROCEND get_load_module;
?? TITLE := '  get_ppu_module', EJECT ??

  PROCEDURE get_ppu_module
    (    name: {input} ^pmt$program_name;
         object_text_descriptor: ^llt$object_text_descriptor;
     VAR library: ^SEQ ( * );
     VAR ppu_object_module: ^llt$object_module;
     VAR status: ost$status);

    VAR
      current_sequence_position: ost$segment_offset,
      new_identification_record: ^llt$identification,
      new_object_text_descriptor: ^llt$object_text_descriptor,
      ppu_absolute: ^llt$ppu_absolute;

    status.normal := TRUE;

    RESET library TO object_text_descriptor;
    NEXT new_object_text_descriptor IN library;
    IF new_object_text_descriptor = NIL THEN
      osp$set_status_abnormal ('PM', lle$bad_module, name^, status);
      RETURN;
    IFEND;

    NEXT new_identification_record IN library;
    IF new_identification_record = NIL THEN
      osp$set_status_abnormal ('PM', lle$bad_module, name^, status);
      RETURN;
    IFEND;

    NEXT new_object_text_descriptor IN library;
    IF new_object_text_descriptor = NIL THEN
      osp$set_status_abnormal ('PM', lle$bad_module, name^, status);
      RETURN;
    IFEND;

    NEXT ppu_absolute: [0 .. new_object_text_descriptor^.number_of_words - 1] IN library;
    IF ppu_absolute = NIL THEN
      osp$set_status_abnormal ('PM', lle$bad_module, name^, status);
      RETURN;
    IFEND;

    current_sequence_position := i#current_sequence_position (library);

    RESET library TO object_text_descriptor;
    NEXT ppu_object_module: [[REP (current_sequence_position - #OFFSET (object_text_descriptor)) OF cell]] IN
          library;
    IF ppu_object_module = NIL THEN
      osp$set_status_abnormal ('PM', lle$bad_module, name^, status);
    IFEND;
  PROCEND get_ppu_module;
?? TITLE := '  [XDCL, #GATE] pmp$open_object_library', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$open_object_library
    (    file_name: amt$local_file_name;
     VAR file_identifier: amt$file_identifier;
     VAR object_library: ^SEQ ( * );
     VAR status: ost$status);

*copyc pmh$open_object_library

    VAR
      contains_data: boolean,
      current_attributes: array [1 .. 2] of amt$get_item,
      existing_file: boolean,
      local_file: boolean,
      read_attachment: [STATIC, READ, oss$job_paged_literal] array [1 .. 2] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$read]],
            [fsc$determine_from_access_modes]], [fsc$create_file, FALSE]],
      required_attributes: [STATIC, READ, oss$job_paged_literal] array [1 .. 1] of fst$file_cycle_attribute :=
            [[fsc$file_contents_and_processor, fsc$object_library, fsc$unknown_processor]],
      segment_pointer: amt$segment_pointer;

    #keypoint (osk$entry, 0, pmk$open_object_library);
    status.normal := TRUE;

    current_attributes [1].key := amc$file_contents;
    current_attributes [2].key := amc$file_structure;
    amp$get_file_attributes (file_name, current_attributes, local_file, existing_file, contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT contains_data THEN
      osp$set_status_abnormal ('PM', lle$empty_load_file, file_name, status);
      #keypoint (osk$exit, 0, pmk$open_object_library);
      RETURN;
    ELSEIF (current_attributes [1].file_contents <> amc$object) OR
          (current_attributes [2].file_structure <> amc$library) THEN
      osp$set_status_abnormal ('PM', lle$file_not_load_file, file_name, status);
      #keypoint (osk$exit, 0, pmk$open_object_library);
      RETURN;
    ELSE
      fsp$open_file (file_name, amc$segment, ^read_attachment, NIL, NIL, ^required_attributes, NIL,
            file_identifier, status);
      IF NOT status.normal THEN
        #keypoint (osk$exit, 0, pmk$open_object_library);
        RETURN;
      IFEND;

      amp$get_segment_pointer (file_identifier, amc$sequence_pointer, segment_pointer, status);
      IF NOT status.normal THEN
        #keypoint (osk$exit, 0, pmk$open_object_library);
        RETURN;
      IFEND;
    IFEND;
    object_library := segment_pointer.sequence_pointer;
    RESET object_library;

    #keypoint (osk$exit, 0, pmk$open_object_library);

  PROCEND pmp$open_object_library;

?? TITLE := '  [XDCL, #GATE] pmp$close_object_library', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$close_object_library
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

*copyc pmh$close_object_library

    #keypoint (osk$entry, 0, pmk$close_object_library);
    status.normal := TRUE;

    fsp$close_file (file_identifier, status);
    #keypoint (osk$exit, 0, pmk$close_object_library);

  PROCEND pmp$close_object_library;
?? TITLE := '  [XDCL, #GATE] pmp$get_application_information', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_application_information
    (    application_address: ost$pva;
     VAR application_module_name: ost$name;
     VAR application_identifier: llt$application_identifier;
     VAR library_privilege: ost$name;
     VAR status: ost$status);

*copyc pmh$get_application_information

?? NEWTITLE := '    find_section_for_pva', EJECT ??

    PROCEDURE find_section_for_pva
      (    module_item: ^dbt$module_address_table_item;
           pva: ost$pva;
       VAR pva_found: boolean);

{  PURPOSE:
{    This procedure searches for a PVA in the section items of
{    a module address table item in DEBUG'S module address table.
{    The PVA is found when it points within one of the sections
{    in the module.

      VAR
        section_item_index: llt$section_ordinal;

      pva_found := FALSE;
      section_item_index := 0;
      WHILE (NOT pva_found) AND (section_item_index <= UPPERBOUND (module_item^.section_item)) DO
        pva_found := ((pva.ring = module_item^.section_item [section_item_index].address.ring) AND
              (pva.seg = module_item^.section_item [section_item_index].address.seg) AND
              ((pva.offset >= module_item^.section_item [section_item_index].address.offset) AND
              (pva.offset < module_item^.section_item [section_item_index].address.offset +
              module_item^.section_item [section_item_index].length)));
        section_item_index := section_item_index + 1;
      WHILEND;

    PROCEND find_section_for_pva;

?? OLDTITLE ??
?? NEWTITLE := '    find_module_table_for_pva', EJECT ??

    PROCEDURE find_module_table_for_pva
      (    pva: ost$pva;
       VAR module_item: ^dbt$module_address_table_item);

{  PURPOSE:
{    This procedure searches the DEBUG module address table
{    for a PVA.

      VAR
        pva_found: boolean;

      module_item := dbp$module_table_address ();

      pva_found := FALSE;
      WHILE (NOT pva_found) AND (module_item <> NIL) DO
        find_section_for_pva (module_item, pva, pva_found);
        IF NOT pva_found THEN
          module_item := module_item^.next_module;
        IFEND;

      WHILEND;

    PROCEND find_module_table_for_pva;

?? OLDTITLE, EJECT ??

    VAR
      invalid_pva: ^cell,
      module_item: ^dbt$module_address_table_item,
      pva_length: integer,
      pva_string: string (15);

    status.normal := TRUE;

    find_module_table_for_pva (application_address, module_item);
    IF module_item = NIL THEN
      invalid_pva := #address (application_address.ring, application_address.seg, application_address.offset);
      STRINGREP (pva_string, pva_length, invalid_pva);
      osp$set_status_abnormal ('PM', pme$incorrect_applic_address, pva_string (1, pva_length), status);
      RETURN;
    IFEND;

    application_module_name := module_item^.name;
    IF module_item^.application_identifier = NIL THEN
      application_identifier.name := osc$null_name;
    ELSE
      application_identifier.name := module_item^.application_identifier^.name;
    IFEND;

{
{  Library_privilege is hard coded to 'OBJECT' until it can be obtained from
{  the file registration attributes in 1.3.1.
{

    library_privilege := 'OBJECT';

  PROCEND pmp$get_application_information;
MODEND pmm$object_code_utilities
*DECK DECK=PMM$OUTWARD_CALL EXPAND=TRUE
?? RIGHT := 110 ??
*copyc OSD$DEFAULT_PRAGMATS
?? TITLE := 'NOS/VE : Tasking : Outward call' ??
?? NEWTITLE := '  Global declarations', EJECT ??
MODULE pmm$outward_call;

{  PURPOSE:
{    This module contains procedures used to perform an outward call.
{  DESIGN:
{    The actual outward call involves usage of the POP instruction.  Since POP is not supported
{    by CYBIL, an assembly language helper procedure performs the actual outward call.  The
{    procedures in this module set up the environment for the outward call and then call
{    the helper procedure.
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc PMT$USER_PROGRAM
*copyc PMT$PROGRAM_PARAMETERS
*copyc PMT$STACK_SEGMENT
*copyc CYD$CYBIL_STRUCTURE_DEFINITIONS
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc OST$STATUS
*copyc OSK$KEYPOINTS
*copyc OSS$JOB_PAGED_LITERAL
*copyc PMK$KEYPOINTS
*copyc PME$DEBUG_EXCEPTIONS
?? POP ??
*copyc OSP$SYSTEM_ERROR
*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSP$GENERATE_MESSAGE
*copyc PMP$EXIT
*copyc PMP$TASK_DEBUG_MODE_ON
*copyc PMP$TASK_DEBUG_RING
*copyc PMP$LOAD_DEBUG_PROCEDURES
*copyc PMP$RETURN_TO_OUTWARD_CALL_SFSA
*copyc PMP$FIND_BEGIN_DEBUG
*copyc PMP$FIND_PROG_OPTIONS_AND_LIBS
*copyc PMP$INHIBIT_SYSTEM_CONDITIONS
*copyc PMP$ENABLE_SYSTEM_CONDITIONS
*copyc PMP$UPDATE_TOS_RING_3
*copyc PMP$ESTABLISH_CONDITION_HANDLER
*copyc PMV$ENABLE_INHIBIT_CONDITIONS

?? TITLE := '  [XDCL] pmp$outward_call', EJECT ??

  PROCEDURE [XDCL] pmp$outward_call (callee: ^ost$external_code_base_pointer;
        ring: ost$ring;
        parameter_list: ^cell;
        preceding_sfsa: ^ost$stack_frame_save_area;
    VAR stack_segment: ^pmt$stack_segment);

{  PURPOSE:
{    This procedure performs an outward call to a specified procedure in a specified ring.
{  NOTE:
{    All stack frames in the caller's ring are popped before the transfer is made to the
{    outer ring.

    VAR
      outward_call_sfsa: ^ost$stack_frame_save_area;

    pmp$build_outward_call_sfsa (callee, ring, parameter_list, preceding_sfsa, 0, stack_segment,
          outward_call_sfsa);
    pmp$return_to_outward_call_sfsa (outward_call_sfsa);

{   The above procedure is not expected to return.

  PROCEND pmp$outward_call;
?? TITLE := '  [XDCL] pmp$build_outward_call_sfsa', EJECT ??

  PROCEDURE [XDCL] pmp$build_outward_call_sfsa (callee: ^ost$external_code_base_pointer;
        ring: ost$ring;
        parameter_list: ^cell;
        preceding_sfsa: ^ost$stack_frame_save_area;
        stack_frame_size: ost$segment_length;
    VAR stack_segment: ^pmt$stack_segment;
    VAR outward_call_sfsa: ^ost$stack_frame_save_area);

{  PURPOSE:
{    This procedure builds a stack frame save area to be used in performing an outward call.

    VAR
      pva: ^cell,
      pad: ^SEQ ( * ),
      stack_frame: ^SEQ ( * ),
      psa: ^ost$stack_frame_save_area;

    IF stack_frame_size <> 0 THEN
      NEXT pva IN stack_segment;
{!  Use ALIGNED attribute to accomplish padding when PSR CILA247 is answered.
      NEXT pad: [[REP (8 - ((#offset (pva) + 1) MOD 8)) OF cell]] IN stack_segment;
      NEXT stack_frame: [[REP stack_frame_size OF cell]] IN stack_segment;
    IFEND;
    NEXT pva IN stack_segment;
{!  Use ALIGNED attribute to accomplish padding when PSR CILA247 is answered.
    NEXT pad: [[REP (8 - ((#offset (pva) + 1) MOD 8)) OF cell]] IN stack_segment;
    NEXT outward_call_sfsa IN stack_segment;

    { A4 is the last register that needs to be in the save area for this stack frame }
    pmp$update_tos_ring_3 (^outward_call_sfsa^.monitor_condition_register);

    outward_call_sfsa^.minimum_save_area.p_register.undefined1 := 0;
{!  Keys should be initialized based on segment attributes of the segment containing the
{!  procedure which is being called.
    psa := #previous_save_area ();
    outward_call_sfsa^.minimum_save_area.p_register.global_key := psa^.minimum_save_area.p_register.
          global_key;
    outward_call_sfsa^.minimum_save_area.p_register.undefined2 := 0;
    outward_call_sfsa^.minimum_save_area.p_register.local_key := psa^.minimum_save_area.p_register.local_key;
    outward_call_sfsa^.minimum_save_area.p_register.pva.ring := ring;
    outward_call_sfsa^.minimum_save_area.p_register.pva.seg := #segment (callee^.code_pva);
    outward_call_sfsa^.minimum_save_area.p_register.pva.offset := #offset (callee^.code_pva);
    outward_call_sfsa^.minimum_save_area.vmid := callee^.vmid;
    outward_call_sfsa^.minimum_save_area.undefined := 0;
    outward_call_sfsa^.minimum_save_area.a0_dynamic_space_pointer := outward_call_sfsa;
    outward_call_sfsa^.minimum_save_area.frame_descriptor.critical_frame_flag := FALSE;
    outward_call_sfsa^.minimum_save_area.frame_descriptor.on_condition_flag := FALSE;
    outward_call_sfsa^.minimum_save_area.frame_descriptor.undefined := 0;
    outward_call_sfsa^.minimum_save_area.frame_descriptor.x_starting := 1;
    outward_call_sfsa^.minimum_save_area.frame_descriptor.a_terminating := 4;
    outward_call_sfsa^.minimum_save_area.frame_descriptor.x_terminating := 0;
?? EJECT ??
    IF stack_frame_size <> 0 THEN
      outward_call_sfsa^.minimum_save_area.a1_current_stack_frame := stack_frame;
    ELSE
      outward_call_sfsa^.minimum_save_area.a1_current_stack_frame := outward_call_sfsa;
    IFEND;
    outward_call_sfsa^.minimum_save_area.user_mask := psa^.minimum_save_area.user_mask;
    outward_call_sfsa^.minimum_save_area.a2_previous_save_area := preceding_sfsa;
    outward_call_sfsa^.a3 := callee^.binding_pva;
    outward_call_sfsa^.a4 := parameter_list;
  PROCEND pmp$build_outward_call_sfsa;
?? TITLE := '  [XDCL] pmp$original_caller', EJECT ??

  PROCEDURE [XDCL] pmp$original_caller (user_program_cbp: ^ost$external_code_base_pointer;
        program_parameters: ^pmt$program_parameters);

{  PURPOSE:
{    This procedure transfers control to the starting procedure of the user program and
{    terminates the task if the starting procedure returns.  It is called (via PMP$OUTWARD_CALL
{    if necessary) in the ring in which the starting procedure will execute.

  PROCEDURE handle_block_exit_condition (conditions : pmt$condition;
        condition_descriptor : ^pmt$condition_information;
        save_area : ^ost$stack_frame_save_area;
        VAR status : ost$status);

    VAR
      prog_options_and_libs: ^pmt$prog_options_and_libraries;

    pmp$find_prog_options_and_libs (prog_options_and_libs);
    pmp$enable_system_conditions (prog_options_and_libs^.default_options^.conditions_enabled, local_status);
    pmp$inhibit_system_conditions (prog_options_and_libs^.default_options^.conditions_inhibited,
          local_status);

  PROCEND handle_block_exit_condition;

    VAR
      converter: record
        case 0 .. 1 of
        = 0 =
          pointer_to_procedure: cyt$pointer_to_procedure,
        = 1 =
          user_program: pmt$user_program,
        casend,
      recend,

      establish_descriptor: pmt$established_handler,
      conditions: pmt$condition,
      condition_handler: pmt$condition_handler,
      of_execution: cell,
      user_program_status: ost$status,
      pointer_to_procedure: cyt$pointer_to_procedure,
      user_program: pmt$user_program,
      local_status: ost$status;

    IF pmp$task_debug_mode_on () AND (pmp$task_debug_ring () > osc$tsrv_ring) THEN
      IF #ring (^of_execution) >= pmp$task_debug_ring () THEN
        pmp$load_debug_procedures (local_status);
        IF NOT local_status.normal THEN
          pmp$exit (local_status);
        IFEND;
        pmp$call_begin_debug (user_program_cbp^.code_pva);
      ELSE
        osp$set_status_abnormal ('PM', pme$unable_to_load_debug, 'DBP$BEGIN_DEBUG', local_status);
        osp$generate_message (local_status, local_status);
      IFEND;
    IFEND;

{ Because of the fashion in which popper works, if original caller is not called
{ from pmp$task_begin but via outward call, the condition handler will never
{ get executed because the stack is truncated immediately before original caller
{ is popped.  Therefore, the condition handler is only needed if an outward call
{ is not performed.

    IF #ring(^of_execution) <= osc$tsrv_ring THEN
      conditions.selector := pmc$block_exit_processing;
      conditions.reason := -$pmt$block_exit_reason[];
      condition_handler := ^handle_block_exit_condition;
      pmp$establish_condition_handler (conditions, condition_handler,
          ^establish_descriptor, local_status);
    IFEND;
    pointer_to_procedure.code_base_pointer_p := user_program_cbp;
    pointer_to_procedure.static_link := NIL;
    converter.pointer_to_procedure := pointer_to_procedure;
    user_program := converter.user_program;
    user_program_status.normal := TRUE;
    pmp$enable_system_conditions (pmv$enable_inhibit_conditions.enable_system_conditions, local_status);
    pmp$inhibit_system_conditions (pmv$enable_inhibit_conditions.inhibit_system_conditions, local_status);
    user_program^ (program_parameters^, user_program_status);
{   NOTE: a condition may arise when re-enabled but the condition mechanism
{         will ignore the condition in the original caller.
    pmp$exit (user_program_status);
  PROCEND pmp$original_caller;
?? TITLE := '  [XDCL] pmp$call_begin_debug', EJECT ??

  PROCEDURE [XDCL] pmp$call_begin_debug (starting_procedure_value: ^cell);

    VAR
      starting_procedure: ^cell,
      psa: ^ost$stack_frame_save_area,
      pva: ost$pva,
      begin_debug: dbt$begin_debug;

    IF starting_procedure_value <> NIL THEN
      starting_procedure := starting_procedure_value;
    ELSE
      psa := #previous_save_area ();
      pva := psa^.minimum_save_area.p_register.pva;
      starting_procedure := #address (pva.ring, pva.seg, pva.offset);
    IFEND;
    pmp$find_begin_debug (begin_debug);
    IF begin_debug <> NIL THEN
      begin_debug^ (starting_procedure);
    IFEND;
  PROCEND pmp$call_begin_debug;
MODEND pmm$outward_call;
*DECK DECK=PMM$PRESET_CONVERSION_TABLE EXPAND=TRUE
pmapct    ident
pmapct    alias    PMM$PRESET_CONVERSION_TABLE
.  PURPOSE:
.    This module defines the preset conversion table (used by procedures in
.    module pmm$default_loader_program_mgmt) which should in the JOB PAGED
.    LITERAL SECTION - this module should be deleted and definitions coded
.    in CYBIL in the aforementioned module when CYBIL handles 64 bit integer
.    constants.
.
.
. VAR
.   pmv$preset_conversion_table: [XDCL, #GATE, READ, oss$job_paged_literal]
.     array [pmt$initialization_value] of integer := [0,
.     0aaaaaaaaaaaaaaaa(16), 7000000000000000(16), 5000000000000000(16)];
.
.
joblit    SECTION  working,read,oss$job_paged_literal,0,8
          ref      joblit
joblit    alias    OSS$JOB_PAGED_LITERAL
.
          use      joblit
pmvpct    bss      0
zero      vfd,64   0
altone    vfd,64   0aaaaaaaaaaaaaaaa(16)
indef     vfd,64   07000000000000000(16)
inf       vfd,64   05000000000000000(16)
.
.
          defg     pmvpct
pmvpct    alias    PMV$PRESET_CONVERSION_TABLE
          end
*DECK DECK=PMM$PROCESS_INTERVAL_TIMER_MGR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Control - Process Interval Timer Manager' ??
MODULE pmm$process_interval_timer_mgr;




{   PURPOSE:
{     The purpose of this module is contain the procedures which manage the
{     process interval timer for program condition and the same time confine
{     the knowledge to this module.

{   DESIGN:
{     This module is designed to execute in rings 2 - 3.  The XDCL, #GATEed
{     procedures have a call bracket of 13.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osc$processor_defined_registers
*copyc osd$virtual_address
*copyc oss$task_private
*copyc ost$caller_identifier
*copyc ost$status
*copyc pme$condition_exceptions
*copyc pmk$keypoints
*copyc pmt$pit_value
?? POP ??
*copyc osp$set_status_condition
*copyc osp$verify_system_privilege
*copyc syp$set_process_interval_timer
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    pmv$pit_has_been_set: [STATIC, oss$task_private] boolean := FALSE,
    pmv$pit_was_set_in_ch: [STATIC, oss$task_private] boolean,
    pmv$where_pit_can_be_cleared: [STATIC, oss$task_private] ost$ring := LOWERVALUE (ost$ring);

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$set_process_interval_timer', EJECT ??
*copy pmh$set_process_interval_timer

  PROCEDURE [XDCL, #GATE] pmp$set_process_interval_timer
    (    microseconds: pmt$pit_value;
     VAR status: ost$status);

    #KEYPOINT (osk$entry, 0, pmk$set_process_interval_timer);

    status.normal := TRUE;
    IF (microseconds >= LOWERVALUE (pmt$pit_value)) AND (microseconds <= UPPERVALUE (pmt$pit_value)) THEN
      syp$set_process_interval_timer (microseconds, status);
      IF status.normal THEN
        pmv$pit_has_been_set := TRUE;
        pmv$pit_was_set_in_ch := TRUE; { Assume this is true for DISPOSE_PIT_CONDITION }
        pmv$where_pit_can_be_cleared := LOWERVALUE (pmv$where_pit_can_be_cleared);
      IFEND;
    ELSE
      osp$set_status_condition (pme$pit_value_out_of_range, status);
    IFEND;

    #KEYPOINT (osk$exit, 0, pmk$set_process_interval_timer);

  PROCEND pmp$set_process_interval_timer;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$pit_was_set', EJECT ??

  FUNCTION [XDCL, #GATE] pmp$pit_was_set: boolean;

    osp$verify_system_privilege;
    pmp$pit_was_set := pmv$pit_has_been_set;

  FUNCEND pmp$pit_was_set;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$set_where_pit_can_be_cleard', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$set_where_pit_can_be_cleard;


    VAR
      caller: ost$caller_identifier;


    #CALLER_ID (caller);

    osp$verify_system_privilege;
    IF caller.ring >= pmv$where_pit_can_be_cleared THEN
      pmv$where_pit_can_be_cleared := caller.ring + 1;
    IFEND;

  PROCEND pmp$set_where_pit_can_be_cleard;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$clear_pit_has_been_set', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$clear_pit_has_been_set;


    VAR
      caller: ost$caller_identifier;


    #CALLER_ID (caller);

    osp$verify_system_privilege;
    IF caller.ring >= pmv$where_pit_can_be_cleared THEN
      pmv$pit_has_been_set := FALSE;
    IFEND;

  PROCEND pmp$clear_pit_has_been_set;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$clear_pit_was_set_in_ch', EJECT ??

{ PURPOSE:
{   This routine helps remember if the pit was set inside a condition handler
{   for DISPOSE_PIT_CONDITION in PMM$DISPOSE_OF_CONDITIONS.

  PROCEDURE [XDCL, #GATE] pmp$clear_pit_was_set_in_ch;

    osp$verify_system_privilege;
    pmv$pit_was_set_in_ch := FALSE;

  PROCEND pmp$clear_pit_was_set_in_ch;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$pit_was_set_in_ch', EJECT ??

{ PURPOSE:
{   This routine helps remember if the pit was set inside a condition handler
{   for DISPOSE_PIT_CONDITION in PMM$DISPOSE_OF_CONDITIONS.

  FUNCTION [XDCL, #GATE] pmp$pit_was_set_in_ch: boolean;

    osp$verify_system_privilege;
    pmp$pit_was_set_in_ch := pmv$pit_was_set_in_ch;

  FUNCEND pmp$pit_was_set_in_ch;
?? OLDTITLE ??

MODEND pmm$process_interval_timer_mgr;
*DECK DECK=PMM$PROGRAM_ATTRIBUTES EXPAND=TRUE
?? 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;

*DECK DECK=PMM$PROGRAM_ATTRIBUTES_FD EXPAND=TRUE
create_function_description name = ($program_attributes $program_attribute) ..
      library = :$system.$system.osf$site_command_library ..
      starting_procedure = pmp$$program_attributes
*DECK DECK=PMM$PROGRAM_CONTROL_SERVICES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Program Control Services' ??
?? NEWTITLE := '  PMM$PROGRAM_CONTROL_SERVICES' ??
MODULE pmm$program_control_services;

{   PURPOSE:
{     The purpose of this module is to package contained procedures
{     so that they execute with the privileges necessary to read the
{     job private fixed and job private pageable sections; modify
{     task private section; and issue monitor requests.

{   DESIGN:
{     The procedures contained in this module have an execution bracket
{     of 1, 3 and a call bracket of 3.  The module is designed to execute
{     in the system core.

?? NEWTITLE := '    Global Declarations Referenced By This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc OST$EXECUTION_CONTROL_BLOCK
*copyc PME$DEFINE_HANDLER_EXCEPTIONS
*copyc PME$HUNG_RECIPIENT_TASK
*copyc PME$INSUFFICIENT_PRIVILEGE
*copyc PME$INVALID_TASK_ORIGIN_FLAG
*copyc PME$INVALID_TASK_ORIGIN_SIGNAL
*copyc PME$UNKNOWN_RECIPIENT_TASK
*copyc SYC$MONITOR_REQUEST_CODES
*copyc TMT$PREEMPTED_REASON
*copyc TMT$RB_SEND_SIGNAL
*copyc TMT$RB_SET_SYSTEM_FLAG
*copyc tmc$signal_identifiers
*copyc TME$MONITOR_MODE_EXCEPTIONS
?? POP ??

*copyc I#CALL_MONITOR
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$CYCLE
*copyc TMP$POST_MAINFRAME_SIGNAL

?? TITLE := '    PMP$SEND_SIGNAL', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc pmh$send_signal
?? POP ??

  PROCEDURE [XDCL, #GATE] pmp$send_signal (recipient: ost$global_task_id;
        signal: pmt$signal;
    VAR status: ost$status);

    TYPE
      signal_ids = set of pmt$signal_id;

    VAR
      tmv$valid_task_origin_signals: signal_ids;

    VAR
      send: tmt$rb_send_signal,
      ignore_status: ost$status;

    IF signal.identifier > tmc$last_signal_id_assigned THEN
      osp$set_status_abnormal(pmc$program_management_id, pme$invalid_identifier, '', status);
      RETURN;
    IFEND;

    tmv$valid_task_origin_signals := - $signal_ids [pmc$ss_child_terminated];
    status.normal := TRUE;
    IF (signal.identifier IN tmv$valid_task_origin_signals) THEN
      send.reqcode := syc$rc_mtr_send_signal;
      send.task_id := recipient;
      send.signal := signal;
      i#call_monitor (#LOC (send), #SIZE (send));
      IF NOT send.status.normal THEN
        CASE send.status.condition OF

        = tme$job_swapped_out, tme$mtr_signal_buffers_full =
          tmp$post_mainframe_signal (recipient, signal, status);
          IF status.normal THEN
            pmp$set_system_flag (tmc$mainframe_linked_signals, recipient, status);
          ELSE
            pmp$cycle (ignore_status);
            pmp$send_signal (recipient, signal, status);
          IFEND;

        = tme$invalid_global_taskid =
          osp$set_status_abnormal (pmc$program_management_id, pme$unknown_recipient_task, '', status);

        = tme$insufficient_privilege =
          osp$set_status_abnormal (pmc$program_management_id, pme$insufficient_privilege, '', status);

        = pme$hung_recipient_task =
          osp$set_status_abnormal (pmc$program_management_id, pme$hung_recipient_task, '', status);

        ELSE
        CASEND;
      IFEND;
    ELSE
      osp$set_status_abnormal (pmc$program_management_id, pme$invalid_task_origin_signal, '', status);
    IFEND;
  PROCEND pmp$send_signal;

?? TITLE := '    PMP$SET_SYSTEM_FLAG', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc pmh$set_system_flag
?? POP ??

  PROCEDURE [XDCL, #GATE] pmp$set_system_flag (flag_id: ost$system_flag;
        recipient: ost$global_task_id;
    VAR status: ost$status);

    VAR
      tmv$valid_task_origin_flags: tmt$system_flags;

    VAR
      set_system_flag: tmt$rb_set_system_flag;

    status.normal := TRUE;

    IF flag_id > tmc$last_system_flag THEN
      osp$set_status_abnormal (pmc$program_management_id, pme$invalid_identifier, '', status);
      RETURN;
    IFEND;

    tmv$valid_task_origin_flags := - $tmt$system_flags [];
    IF (flag_id IN tmv$valid_task_origin_flags) THEN
      set_system_flag.reqcode := syc$rc_set_system_flag;
      set_system_flag.task_id := recipient;
      set_system_flag.flag_id := flag_id;
      i#call_monitor (#LOC (set_system_flag), #SIZE (set_system_flag));
      IF NOT set_system_flag.status.normal THEN
        CASE set_system_flag.status.condition OF
        = tme$invalid_global_taskid =
          osp$set_status_abnormal (pmc$program_management_id, pme$unknown_recipient_task, '', status);
        = tme$insufficient_privilege =
          osp$set_status_abnormal (pmc$program_management_id, pme$insufficient_privilege, '', status);
        ELSE
        CASEND;
      IFEND;
    ELSE
      osp$set_status_abnormal (pmc$program_management_id, pme$invalid_task_origin_flag, '', status);
    IFEND;
  PROCEND pmp$set_system_flag;
?? OLDTITLE ??
MODEND pmm$program_control_services;
*DECK DECK=PMM$PROGRAM_EXECUTION_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE SCL Interpreter : Program Execution Commands' ??
MODULE pmm$program_execution_commands;

{
{ PURPOSE:
{   This module contains the processors for the execute_task, terminate_task,
{   set_program_attributes, and display_program_attributes commands as well
{   as the $program function.

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc cle$ecc_command_processing
*copyc cle$ecc_expression_result
*copyc cle$ecc_function_processing
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_parameter_list
*copyc clt$check_parameters_procedure
*copyc clt$work_area
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc ost$status
*copyc pfe$error_condition_codes
?? POP ??
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_file
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc clp$execute_named_task
*copyc clp$fetch_named_task_entry
*copyc clp$find_current_block
*copyc clp$find_named_task_group_list
*copyc clp$get_command_search_mode
*copyc clp$get_path_name
*copyc clp$horizontal_tab_display
*copyc clp$make_boolean_value
*copyc clp$make_file_value
*copyc clp$make_sized_string_value
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$set_command_kind
*copyc clp$trimmed_string_size
*copyc clv$nil_display_control
*copyc clv$standard_files
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc pmp$change_default_prog_options
*copyc pmp$change_job_library_list
*copyc pmp$execute
*copyc pmp$find_prog_options_and_libs
*copyc pmp$get_task_id
*copyc pmp$job_debug_ring
*copyc pmp$terminate
*copyc pmv$preset_conversion_table

  CONST
    max_term_error_level_str_size = 7, {warning
    max_preset_string_size = 25; {floating_point_indefinite

  VAR
    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$_set_program_attributes', EJECT ??

{ PURPOSE:
{  This routine processes the set_program_attribute command.
{

  PROCEDURE [XDCL] pmp$_set_program_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$setpa) set_program_attributes, set_program_attribute, setpa (
{   load_map, lm: file = $optional
{   load_map_options, load_map_option, lmo: any of
{       key all, none keyend
{       list of key
{         (segment, s)
{         (block, b)
{         (entry_point, ep)
{         (cross_reference, cr)
{       keyend
{     anyend = $optional
{   preset_value, pv: key
{       (zero, z)
{       (floating_point_indefinite, fpi)
{       (infinity, i)
{       (alternate_ones, ao)
{     keyend = $optional
{   termination_error_level, tel: key
{       (warning, w)
{       (error, e)
{       (fatal, f)
{     keyend = $optional
{   debug_input, di: file = $optional
{   debug_output, do: file = $optional
{   abort_file, af: file = $optional
{   debug_mode, dm: boolean = $optional
{   delete_libraries, delete_library, dl: any of
{       key all keyend
{       list of any of
{         key osf$task_services_library keyend
{         file
{       anyend
{     anyend = $optional
{   add_libraries, add_library, al: list of any of
{       key
{         osf$task_services_library
{       keyend
{       file
{     anyend = $optional
{   arithmetic_overflow, ao: boolean = $optional
{   arithmetic_loss_of_significance, alos: boolean = $optional
{   divide_fault, df: boolean = $optional
{   exponent_overflow, eo: boolean = $optional
{   exponent_underflow, eu: boolean = $optional
{   fp_indefinite, fpi, fi: boolean = $optional
{   fp_loss_of_significance, fplos, flos: boolean = $optional
{   invalid_bdp_data, ibdpd, ibd: boolean = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 43] of clt$pdt_parameter_name,
        parameters: array [1 .. 19] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: 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 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$keyword_type_qualifier,
              keyword_specs: array [1 .. 8] of clt$keyword_specification,
            recend,
          recend,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 8] of clt$keyword_specification,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 6] of clt$keyword_specification,
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
        type6: record
          header: clt$type_specification_header,
        recend,
        type7: record
          header: clt$type_specification_header,
        recend,
        type8: record
          header: clt$type_specification_header,
        recend,
        type9: 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,
            element_type_spec: 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,
              recend,
            recend,
          recend,
        recend,
        type10: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: 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,
            recend,
          recend,
        recend,
        type11: record
          header: clt$type_specification_header,
        recend,
        type12: record
          header: clt$type_specification_header,
        recend,
        type13: record
          header: clt$type_specification_header,
        recend,
        type14: record
          header: clt$type_specification_header,
        recend,
        type15: record
          header: clt$type_specification_header,
        recend,
        type16: record
          header: clt$type_specification_header,
        recend,
        type17: record
          header: clt$type_specification_header,
        recend,
        type18: record
          header: clt$type_specification_header,
        recend,
        type19: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 14, 34, 40, 117], clc$command, 43, 19, 0, 0, 0, 0, 19, 'OSM$SETPA'],
            [['ABORT_FILE                     ', clc$nominal_entry, 7],
            ['ADD_LIBRARIES                  ', clc$nominal_entry, 10],
            ['ADD_LIBRARY                    ', clc$alias_entry, 10],
            ['AF                             ', clc$abbreviation_entry, 7],
            ['AL                             ', clc$abbreviation_entry, 10],
            ['ALOS                           ', clc$abbreviation_entry, 12],
            ['AO                             ', clc$abbreviation_entry, 11],
            ['ARITHMETIC_LOSS_OF_SIGNIFICANCE', clc$nominal_entry, 12],
            ['ARITHMETIC_OVERFLOW            ', clc$nominal_entry, 11],
            ['DEBUG_INPUT                    ', clc$nominal_entry, 5],
            ['DEBUG_MODE                     ', clc$nominal_entry, 8],
            ['DEBUG_OUTPUT                   ', clc$nominal_entry, 6],
            ['DELETE_LIBRARIES               ', clc$nominal_entry, 9],
            ['DELETE_LIBRARY                 ', clc$alias_entry, 9],
            ['DF                             ', clc$abbreviation_entry, 13],
            ['DI                             ', clc$abbreviation_entry, 5],
            ['DIVIDE_FAULT                   ', clc$nominal_entry, 13],
            ['DL                             ', clc$abbreviation_entry, 9],
            ['DM                             ', clc$abbreviation_entry, 8],
            ['DO                             ', clc$abbreviation_entry, 6],
            ['EO                             ', clc$abbreviation_entry, 14],
            ['EU                             ', clc$abbreviation_entry, 15],
            ['EXPONENT_OVERFLOW              ', clc$nominal_entry, 14],
            ['EXPONENT_UNDERFLOW             ', clc$nominal_entry, 15],
            ['FI                             ', clc$abbreviation_entry, 16],
            ['FLOS                           ', clc$abbreviation_entry, 17],
            ['FPI                            ', clc$alias_entry, 16],
            ['FPLOS                          ', clc$alias_entry, 17],
            ['FP_INDEFINITE                  ', clc$nominal_entry, 16],
            ['FP_LOSS_OF_SIGNIFICANCE        ', clc$nominal_entry, 17],
            ['IBD                            ', clc$abbreviation_entry, 18],
            ['IBDPD                          ', clc$alias_entry, 18],
            ['INVALID_BDP_DATA               ', clc$nominal_entry, 18],
            ['LM                             ', clc$abbreviation_entry, 1],
            ['LMO                            ', clc$abbreviation_entry, 2],
            ['LOAD_MAP                       ', clc$nominal_entry, 1],
            ['LOAD_MAP_OPTION                ', clc$alias_entry, 2],
            ['LOAD_MAP_OPTIONS               ', clc$nominal_entry, 2],
            ['PRESET_VALUE                   ', clc$nominal_entry, 3],
            ['PV                             ', clc$abbreviation_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 19],
            ['TEL                            ', clc$abbreviation_entry, 4],
            ['TERMINATION_ERROR_LEVEL        ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [36, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [38, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 420, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [39, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 303, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [43, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 229, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [10, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [11, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 147, clc$optional_parameter, 0, 0],

{ PARAMETER 10

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 83, clc$optional_parameter, 0, 0],

{ PARAMETER 11

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 12

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 13

      [17, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 14

      [23, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 15

      [24, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 16

      [29, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 17

      [30, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 18

      [33, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 19

      [41, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type]],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 319, [[1, 0, clc$list_type],
            [303, 1, clc$max_list_size, FALSE], [[1, 0, clc$keyword_type],
            [8], [['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
            ['BLOCK                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
            ['CR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
            ['CROSS_REFERENCE                ', clc$nominal_entry, clc$normal_usage_entry, 4],
            ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 3],
            ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
            ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
            ['SEGMENT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]]]],

{ PARAMETER 3

      [[1, 0, clc$keyword_type], [8], [['ALTERNATE_ONES                 ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['AO                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['FLOATING_POINT_INDEFINITE      ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['FPI                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['I                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['INFINITY                       ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['Z                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['ZERO                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 4

      [[1, 0, clc$keyword_type], [6], [['E                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['ERROR                          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['F                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FATAL                          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['W                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['WARNING                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 5

      [[1, 0, clc$file_type]],

{ PARAMETER 6

      [[1, 0, clc$file_type]],

{ PARAMETER 7

      [[1, 0, clc$file_type]],

{ PARAMETER 8

      [[1, 0, clc$boolean_type]],

{ PARAMETER 9

      [[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]]], 83, [[1, 0, clc$list_type],
            [67, 1, clc$max_list_size, FALSE], [[1, 0, clc$union_type],
            [[clc$file_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['OSF$TASK_SERVICES_LIBRARY      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 3, [[1, 0, clc$file_type]]]]],

{ PARAMETER 10

      [[1, 0, clc$list_type], [67, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['OSF$TASK_SERVICES_LIBRARY      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 3, [[1, 0, clc$file_type]]]],

{ PARAMETER 11

      [[1, 0, clc$boolean_type]],

{ PARAMETER 12

      [[1, 0, clc$boolean_type]],

{ PARAMETER 13

      [[1, 0, clc$boolean_type]],

{ PARAMETER 14

      [[1, 0, clc$boolean_type]],

{ PARAMETER 15

      [[1, 0, clc$boolean_type]],

{ PARAMETER 16

      [[1, 0, clc$boolean_type]],

{ PARAMETER 17

      [[1, 0, clc$boolean_type]],

{ PARAMETER 18

      [[1, 0, clc$boolean_type]],

{ PARAMETER 19

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$load_map = 1,
      p$load_map_options = 2,
      p$preset_value = 3,
      p$termination_error_level = 4,
      p$debug_input = 5,
      p$debug_output = 6,
      p$abort_file = 7,
      p$debug_mode = 8,
      p$delete_libraries = 9,
      p$add_libraries = 10,
      p$arithmetic_overflow = 11,
      p$arithmetic_loss_of_significan = 12 {ARITHMETIC_LOSS_OF_SIGNIFICANCE} ,
      p$divide_fault = 13,
      p$exponent_overflow = 14,
      p$exponent_underflow = 15,
      p$fp_indefinite = 16,
      p$fp_loss_of_significance = 17,
      p$invalid_bdp_data = 18,
      p$status = 19;

    VAR
      pvt: array [1 .. 19] of clt$parameter_value;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      IF NOT (parameter_value_table^ [p$load_map].specified OR
            parameter_value_table^ [p$load_map_options].specified OR
            parameter_value_table^ [p$preset_value].specified OR
            parameter_value_table^ [p$termination_error_level].
            specified OR parameter_value_table^ [p$debug_input].
            specified OR parameter_value_table^ [p$debug_output].
            specified OR parameter_value_table^ [p$abort_file].
            specified OR parameter_value_table^ [p$debug_mode].
            specified OR parameter_value_table^ [p$arithmetic_overflow].
            specified OR parameter_value_table^ [p$arithmetic_loss_of_significan].specified OR
            parameter_value_table^ [p$divide_fault].specified OR
            parameter_value_table^ [p$exponent_overflow].specified OR
            parameter_value_table^ [p$exponent_underflow].specified OR
            parameter_value_table^ [p$fp_indefinite].specified OR
            parameter_value_table^ [p$fp_loss_of_significance].
            specified OR parameter_value_table^ [p$invalid_bdp_data].
            specified OR parameter_value_table^ [p$add_libraries].
            specified OR parameter_value_table^ [p$delete_libraries].specified) THEN
        osp$set_status_abnormal ('CL', cle$required_parameter_omitted, 'LOAD_MAP .. INVALID_BDP_DATA',
              status);
        RETURN;
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??

    VAR
      add_count: clt$list_size,
      add_libraries: ^pmt$object_library_list,
      changed_conditions: boolean,
      delete_count: clt$list_size,
      delete_libraries: ^pmt$object_library_list,
      element: ^clt$data_value,
      file: clt$file,
      library_index: clt$list_size,
      option_change: pmt$default_prog_options_change,
      option_count: clt$list_size,
      option_index: clt$list_size,
      value: ^clt$data_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    option_change.contents := $pmt$program_option_specifiers [];

    IF pvt [p$load_map].specified THEN
      option_change.contents := option_change.contents + $pmt$program_option_specifiers
            [pmc$load_map_file_specified];
      clp$convert_string_to_file (pvt [p$load_map].value^.file_value^, file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      option_change.map_file := file.local_file_name;
    IFEND;

    IF pvt [p$load_map_options].specified THEN
      option_change.contents := option_change.contents + $pmt$program_option_specifiers
            [pmc$load_map_options_specified];
      get_load_map_options (pvt [p$load_map_options], option_change.map_options, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$preset_value].specified THEN
      option_change.contents := option_change.contents + $pmt$program_option_specifiers
            [pmc$preset_specified];
      value := pvt [p$preset_value].value;
      IF value^.keyword_value = 'FLOATING_POINT_INDEFINITE' THEN
        option_change.preset := pmc$initialize_to_indefinite;
      ELSEIF value^.keyword_value = 'INFINITY' THEN
        option_change.preset := pmc$initialize_to_infinity;
      ELSEIF value^.keyword_value = 'ALTERNATE_ONES' THEN
        option_change.preset := pmc$initialize_to_alt_ones;
      ELSEIF value^.keyword_value = 'ZERO' THEN
        option_change.preset := pmc$initialize_to_zero;
      IFEND;
    IFEND;

    IF pvt [p$termination_error_level].specified THEN
      option_change.contents := option_change.contents + $pmt$program_option_specifiers
            [pmc$term_error_level_specified];
      value := pvt [p$termination_error_level].value;
      IF value^.keyword_value = 'WARNING' THEN
        option_change.termination_error_level := pmc$warning_load_errors;
      ELSEIF value^.keyword_value = 'ERROR' THEN
        option_change.termination_error_level := pmc$error_load_errors;
      ELSEIF value^.keyword_value = 'FATAL' THEN
        option_change.termination_error_level := pmc$fatal_load_errors;
      IFEND;
    IFEND;

    IF pvt [p$debug_input].specified THEN
      option_change.contents := option_change.contents + $pmt$program_option_specifiers
            [pmc$debug_input_specified];
      clp$convert_string_to_file (pvt [p$debug_input].value^.file_value^, file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      option_change.debug_input := file.local_file_name;
    IFEND;

    IF pvt [p$debug_output].specified THEN
      option_change.contents := option_change.contents + $pmt$program_option_specifiers
            [pmc$debug_output_specified];
      clp$convert_string_to_file (pvt [p$debug_output].value^.file_value^, file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      option_change.debug_output := file.local_file_name;
    IFEND;

    IF pvt [p$abort_file].specified THEN
      option_change.contents := option_change.contents + $pmt$program_option_specifiers
            [pmc$abort_file_specified];
      clp$convert_string_to_file (pvt [p$abort_file].value^.file_value^, file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      option_change.abort_file := file.local_file_name;
    IFEND;

    IF pvt [p$debug_mode].specified THEN
      option_change.contents := option_change.contents + $pmt$program_option_specifiers
            [pmc$debug_mode_specified];
      option_change.debug_mode := pvt [p$debug_mode].value^.boolean_value.value;
    IFEND;

    changed_conditions := FALSE;
    option_change.conditions_enabled := $pmt$system_conditions [];
    option_change.conditions_inhibited := $pmt$system_conditions [];
    IF pvt [p$arithmetic_overflow].specified THEN
      changed_conditions := TRUE;
      IF pvt [p$arithmetic_overflow].value^.boolean_value.value THEN
        option_change.conditions_enabled := option_change.conditions_enabled +
              $pmt$system_conditions [pmc$arithmetic_overflow];
      ELSE
        option_change.conditions_inhibited := option_change.conditions_inhibited +
              $pmt$system_conditions [pmc$arithmetic_overflow];
      IFEND;
    IFEND;

    IF pvt [p$arithmetic_loss_of_significan].specified THEN
      changed_conditions := TRUE;
      IF pvt [p$arithmetic_loss_of_significan].value^.boolean_value.value THEN
        option_change.conditions_enabled := option_change.conditions_enabled +
              $pmt$system_conditions [pmc$arithmetic_significance];
      ELSE
        option_change.conditions_inhibited := option_change.conditions_inhibited +
              $pmt$system_conditions [pmc$arithmetic_significance];
      IFEND;
    IFEND;

    IF pvt [p$divide_fault].specified THEN
      changed_conditions := TRUE;
      IF pvt [p$divide_fault].value^.boolean_value.value THEN
        option_change.conditions_enabled := option_change.conditions_enabled +
              $pmt$system_conditions [pmc$divide_fault];
      ELSE
        option_change.conditions_inhibited := option_change.conditions_inhibited +
              $pmt$system_conditions [pmc$divide_fault];
      IFEND;
    IFEND;

    IF pvt [p$exponent_overflow].specified THEN
      changed_conditions := TRUE;
      IF pvt [p$exponent_overflow].value^.boolean_value.value THEN
        option_change.conditions_enabled := option_change.conditions_enabled +
              $pmt$system_conditions [pmc$exponent_overflow];
      ELSE
        option_change.conditions_inhibited := option_change.conditions_inhibited +
              $pmt$system_conditions [pmc$exponent_overflow];
      IFEND;
    IFEND;

    IF pvt [p$exponent_underflow].specified THEN
      changed_conditions := TRUE;
      IF pvt [p$exponent_underflow].value^.boolean_value.value THEN
        option_change.conditions_enabled := option_change.conditions_enabled +
              $pmt$system_conditions [pmc$exponent_underflow];
      ELSE
        option_change.conditions_inhibited := option_change.conditions_inhibited +
              $pmt$system_conditions [pmc$exponent_underflow];
      IFEND;
    IFEND;

    IF pvt [p$fp_indefinite].specified THEN
      changed_conditions := TRUE;
      IF pvt [p$fp_indefinite].value^.boolean_value.value THEN
        option_change.conditions_enabled := option_change.conditions_enabled +
              $pmt$system_conditions [pmc$fp_indefinite];
      ELSE
        option_change.conditions_inhibited := option_change.conditions_inhibited +
              $pmt$system_conditions [pmc$fp_indefinite];
      IFEND;
    IFEND;

    IF pvt [p$fp_loss_of_significance].specified THEN
      changed_conditions := TRUE;
      IF pvt [p$fp_loss_of_significance].value^.boolean_value.value THEN
        option_change.conditions_enabled := option_change.conditions_enabled +
              $pmt$system_conditions [pmc$fp_significance_loss];
      ELSE
        option_change.conditions_inhibited := option_change.conditions_inhibited +
              $pmt$system_conditions [pmc$fp_significance_loss];
      IFEND;
    IFEND;

    IF pvt [p$invalid_bdp_data].specified THEN
      changed_conditions := TRUE;
      IF pvt [p$invalid_bdp_data].value^.boolean_value.value THEN
        option_change.conditions_enabled := option_change.conditions_enabled +
              $pmt$system_conditions [pmc$invalid_bdp_data];
      ELSE
        option_change.conditions_inhibited := option_change.conditions_inhibited +
              $pmt$system_conditions [pmc$invalid_bdp_data];
      IFEND;
    IFEND;

    IF changed_conditions THEN
      option_change.contents := option_change.contents + $pmt$program_option_specifiers
            [pmc$condition_specified];
    IFEND;

    IF option_change.contents <> $pmt$program_option_specifiers [] THEN
      pmp$change_default_prog_options (option_change, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    value := pvt [p$delete_libraries].value;
    IF NOT pvt [p$delete_libraries].specified THEN
      delete_libraries := NIL;
    ELSEIF value^.kind = clc$keyword { ALL} THEN
      PUSH delete_libraries: [1 .. 1];
      delete_libraries^ [1] := value^.keyword_value;
    ELSE
      delete_count := clp$count_list_elements (value);
      PUSH delete_libraries: [1 .. delete_count];
      FOR library_index := 1 TO delete_count DO
        element := value^.element_value;
        IF element^.kind = clc$keyword THEN
          delete_libraries^ [library_index] := element^.keyword_value;
        ELSE
          clp$convert_string_to_file (element^.file_value^, file, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          delete_libraries^ [library_index] := file.local_file_name;
        IFEND;
        value := value^.link;
      FOREND;
    IFEND;

    IF pvt [p$add_libraries].specified THEN
      value := pvt [p$add_libraries].value;
      add_count := clp$count_list_elements (value);
      PUSH add_libraries: [1 .. add_count];
      FOR library_index := 1 TO add_count DO
        element := value^.element_value;
        IF element^.kind = clc$keyword { ALL} THEN
          add_libraries^ [library_index] := element^.keyword_value;
        ELSE
          clp$convert_string_to_file (element^.file_value^, file, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          add_libraries^ [library_index] := file.local_file_name;
        IFEND;
        value := value^.link;
      FOREND;
    ELSE
      add_libraries := NIL;
    IFEND;

    pmp$change_job_library_list (delete_libraries, add_libraries, status);

  PROCEND pmp$_set_program_attributes;
?? TITLE := '[XDCL] pmp$_execute_task', EJECT ??

{ PURPOSE:
{  This is the command processor for the execute_task command.
{

  PROCEDURE [XDCL] pmp$_execute_task
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$exet) execute_task, exet (
{   files, file, f: list of file = $optional
{   parameters, parameter, p: string = $optional
{   libraries, library, l: list of any of
{       key
{         osf$task_services_library
{       keyend
{       file
{     anyend = $optional
{   modules, module, m: list of program_name = $optional
{   starting_procedure, sp: program_name = $optional
{   load_map, lm: file = $optional
{   load_map_options, load_map_option, lmo: any of
{       key all, none keyend
{       list of key
{         (segment, s)
{         (block, b)
{         (entry_point, ep)
{         (cross_reference, cr)
{       keyend
{     anyend = $optional
{   preset_value, pv: key
{       (zero, z)
{       (floating_point_indefinite, fpi)
{       (infinity, i)
{       (alternate_ones, ao)
{     keyend = $optional
{   termination_error_level, tel: key
{       (warning, w)
{       (error, e)
{       (fatal, f)
{     keyend = $optional
{   stack_size, ss: integer 1..osc$max_segment_length = $optional
{   debug_input, di: file = $optional
{   debug_output, do: file = $optional
{   abort_file, af: file = $optional
{   debug_mode, dm: boolean = $optional
{   task_name, tn: name = $optional
{   arithmetic_overflow, ao: boolean = $optional
{   arithmetic_loss_of_significance, alos: boolean = $optional
{   divide_fault, df: boolean = $optional
{   exponent_overflow, eo: boolean = $optional
{   exponent_underflow, eu: boolean = $optional
{   fp_indefinite, fpi, fi: boolean = $optional
{   fp_loss_of_significance, fplos, flos: boolean = $optional
{   invalid_bdp_data, ibdpd, ibd: boolean = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 55] of clt$pdt_parameter_name,
        parameters: array [1 .. 24] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: 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,
            recend,
          recend,
        recend,
        type4: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
        type6: record
          header: clt$type_specification_header,
        recend,
        type7: 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 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$keyword_type_qualifier,
              keyword_specs: array [1 .. 8] of clt$keyword_specification,
            recend,
          recend,
        recend,
        type8: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 8] of clt$keyword_specification,
        recend,
        type9: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 6] of clt$keyword_specification,
        recend,
        type10: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type11: record
          header: clt$type_specification_header,
        recend,
        type12: record
          header: clt$type_specification_header,
        recend,
        type13: record
          header: clt$type_specification_header,
        recend,
        type14: record
          header: clt$type_specification_header,
        recend,
        type15: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type16: record
          header: clt$type_specification_header,
        recend,
        type17: record
          header: clt$type_specification_header,
        recend,
        type18: record
          header: clt$type_specification_header,
        recend,
        type19: record
          header: clt$type_specification_header,
        recend,
        type20: record
          header: clt$type_specification_header,
        recend,
        type21: record
          header: clt$type_specification_header,
        recend,
        type22: record
          header: clt$type_specification_header,
        recend,
        type23: record
          header: clt$type_specification_header,
        recend,
        type24: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 14, 35, 15, 211], clc$command, 55, 24, 0, 0, 0, 0, 24, 'OSM$EXET'],
            [['ABORT_FILE                     ', clc$nominal_entry, 13],
            ['AF                             ', clc$abbreviation_entry, 13],
            ['ALOS                           ', clc$abbreviation_entry, 17],
            ['AO                             ', clc$abbreviation_entry, 16],
            ['ARITHMETIC_LOSS_OF_SIGNIFICANCE', clc$nominal_entry, 17],
            ['ARITHMETIC_OVERFLOW            ', clc$nominal_entry, 16],
            ['DEBUG_INPUT                    ', clc$nominal_entry, 11],
            ['DEBUG_MODE                     ', clc$nominal_entry, 14],
            ['DEBUG_OUTPUT                   ', clc$nominal_entry, 12],
            ['DF                             ', clc$abbreviation_entry, 18],
            ['DI                             ', clc$abbreviation_entry, 11],
            ['DIVIDE_FAULT                   ', clc$nominal_entry, 18],
            ['DM                             ', clc$abbreviation_entry, 14],
            ['DO                             ', clc$abbreviation_entry, 12],
            ['EO                             ', clc$abbreviation_entry, 19],
            ['EU                             ', clc$abbreviation_entry, 20],
            ['EXPONENT_OVERFLOW              ', clc$nominal_entry, 19],
            ['EXPONENT_UNDERFLOW             ', clc$nominal_entry, 20],
            ['F                              ', clc$abbreviation_entry, 1],
            ['FI                             ', clc$abbreviation_entry, 21],
            ['FILE                           ', clc$alias_entry, 1],
            ['FILES                          ', clc$nominal_entry, 1],
            ['FLOS                           ', clc$abbreviation_entry, 22],
            ['FPI                            ', clc$alias_entry, 21],
            ['FPLOS                          ', clc$alias_entry, 22],
            ['FP_INDEFINITE                  ', clc$nominal_entry, 21],
            ['FP_LOSS_OF_SIGNIFICANCE        ', clc$nominal_entry, 22],
            ['IBD                            ', clc$abbreviation_entry, 23],
            ['IBDPD                          ', clc$alias_entry, 23],
            ['INVALID_BDP_DATA               ', clc$nominal_entry, 23],
            ['L                              ', clc$abbreviation_entry, 3],
            ['LIBRARIES                      ', clc$nominal_entry, 3],
            ['LIBRARY                        ', clc$alias_entry, 3],
            ['LM                             ', clc$abbreviation_entry, 6],
            ['LMO                            ', clc$abbreviation_entry, 7],
            ['LOAD_MAP                       ', clc$nominal_entry, 6],
            ['LOAD_MAP_OPTION                ', clc$alias_entry, 7],
            ['LOAD_MAP_OPTIONS               ', clc$nominal_entry, 7],
            ['M                              ', clc$abbreviation_entry, 4],
            ['MODULE                         ', clc$alias_entry, 4],
            ['MODULES                        ', clc$nominal_entry, 4],
            ['P                              ', clc$abbreviation_entry, 2],
            ['PARAMETER                      ', clc$alias_entry, 2],
            ['PARAMETERS                     ', clc$nominal_entry, 2],
            ['PRESET_VALUE                   ', clc$nominal_entry, 8],
            ['PV                             ', clc$abbreviation_entry, 8],
            ['SP                             ', clc$abbreviation_entry, 5],
            ['SS                             ', clc$abbreviation_entry, 10],
            ['STACK_SIZE                     ', clc$nominal_entry, 10],
            ['STARTING_PROCEDURE             ', clc$nominal_entry, 5],
            ['STATUS                         ', clc$nominal_entry, 24],
            ['TASK_NAME                      ', clc$nominal_entry, 15],
            ['TEL                            ', clc$abbreviation_entry, 9],
            ['TERMINATION_ERROR_LEVEL        ', clc$nominal_entry, 9],
            ['TN                             ', clc$abbreviation_entry, 15]], [

{ PARAMETER 1

      [22, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 19, clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [44, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [32, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 83, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [41, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 19, clc$optional_parameter, 0, 0],

{ PARAMETER 5

      [50, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 6

      [36, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 7

      [38, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 420, clc$optional_parameter, 0, 0],

{ PARAMETER 8

      [45, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 303, clc$optional_parameter, 0, 0],

{ PARAMETER 9

      [54, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 229, clc$optional_parameter, 0, 0],

{ PARAMETER 10

      [49, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],

{ PARAMETER 11

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 12

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 13

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 14

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 15

      [52, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],

{ PARAMETER 16

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 17

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 18

      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 19

      [17, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 20

      [18, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 21

      [26, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 22

      [27, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 23

      [30, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],

{ PARAMETER 24

      [51, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE], [[1, 0, clc$file_type]]],

{ PARAMETER 2

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],

{ PARAMETER 3

      [[1, 0, clc$list_type], [67, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['OSF$TASK_SERVICES_LIBRARY      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 3, [[1, 0, clc$file_type]]]],

{ PARAMETER 4

      [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE], [[1, 0, clc$program_name_type]]],

{ PARAMETER 5

      [[1, 0, clc$program_name_type]],

{ PARAMETER 6

      [[1, 0, clc$file_type]],

{ PARAMETER 7

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type], FALSE, 2], 81,
            [[1, 0, clc$keyword_type], [2], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]], 319, [[1, 0, clc$list_type],
            [303, 1, clc$max_list_size, FALSE], [[1, 0, clc$keyword_type],
            [8], [['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
            ['BLOCK                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
            ['CR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
            ['CROSS_REFERENCE                ', clc$nominal_entry, clc$normal_usage_entry, 4],
            ['ENTRY_POINT                    ', clc$nominal_entry, clc$normal_usage_entry, 3],
            ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
            ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
            ['SEGMENT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]]]],

{ PARAMETER 8

      [[1, 0, clc$keyword_type], [8], [['ALTERNATE_ONES                 ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['AO                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['FLOATING_POINT_INDEFINITE      ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['FPI                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['I                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['INFINITY                       ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['Z                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['ZERO                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 9

      [[1, 0, clc$keyword_type], [6], [['E                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['ERROR                          ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['F                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FATAL                          ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['W                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['WARNING                        ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]],

{ PARAMETER 10

      [[1, 0, clc$integer_type], [1, osc$max_segment_length, 10]],

{ PARAMETER 11

      [[1, 0, clc$file_type]],

{ PARAMETER 12

      [[1, 0, clc$file_type]],

{ PARAMETER 13

      [[1, 0, clc$file_type]],

{ PARAMETER 14

      [[1, 0, clc$boolean_type]],

{ PARAMETER 15

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 16

      [[1, 0, clc$boolean_type]],

{ PARAMETER 17

      [[1, 0, clc$boolean_type]],

{ PARAMETER 18

      [[1, 0, clc$boolean_type]],

{ PARAMETER 19

      [[1, 0, clc$boolean_type]],

{ PARAMETER 20

      [[1, 0, clc$boolean_type]],

{ PARAMETER 21

      [[1, 0, clc$boolean_type]],

{ PARAMETER 22

      [[1, 0, clc$boolean_type]],

{ PARAMETER 23

      [[1, 0, clc$boolean_type]],

{ PARAMETER 24

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$files = 1,
      p$parameters = 2,
      p$libraries = 3,
      p$modules = 4,
      p$starting_procedure = 5,
      p$load_map = 6,
      p$load_map_options = 7,
      p$preset_value = 8,
      p$termination_error_level = 9,
      p$stack_size = 10,
      p$debug_input = 11,
      p$debug_output = 12,
      p$abort_file = 13,
      p$debug_mode = 14,
      p$task_name = 15,
      p$arithmetic_overflow = 16,
      p$arithmetic_loss_of_significan = 17 {ARITHMETIC_LOSS_OF_SIGNIFICANCE} ,
      p$divide_fault = 18,
      p$exponent_overflow = 19,
      p$exponent_underflow = 20,
      p$fp_indefinite = 21,
      p$fp_loss_of_significance = 22,
      p$invalid_bdp_data = 23,
      p$status = 24;

    VAR
      pvt: array [1 .. 24] of clt$parameter_value;

    VAR
      block: ^clt$block,
      caller_id: ost$caller_identifier,
      condition_specified: boolean,
      element: ^clt$data_value,
      enable_conditions: pmt$system_conditions,
      enable_inhibit_condition_size: 0 .. 1,
      enable_inhibit_conditions: ^pmt$enable_inhibit_conditions,
      file: clt$file,
      i: clt$list_size,
      inhibit_conditions: pmt$system_conditions,
      libraries: ^pmt$object_library_list,
      library_count: clt$list_size,
      map_option_count: clt$list_size,
      module_count: clt$list_size,
      modules: ^pmt$module_list,
      object_file_count: clt$list_size,
      object_files: ^pmt$object_file_list,
      parameters_p: ^record
        size: clt$parameter_list_text_size,
        value: clt$parameter_list_text,
      recend,
      program_attributes: ^pmt$program_attributes,
      program_descriptor: ^SEQ ( * ),
      search_mode: clt$command_search_modes,
      task_id: pmt$task_id,
      task_status: pmt$task_status,
      use_command_search_mode: boolean,
      value: ^clt$data_value;

    CONST
      ignore_command_file = osc$null_name;

    #CALLER_ID (caller_id);
    task_status.status.normal := TRUE;

    clp$find_current_block (block);
    use_command_search_mode := block^.use_command_search_mode;
    #SPOIL (use_command_search_mode);

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    object_file_count := clp$count_list_elements (pvt [p$files].value);
    library_count := clp$count_list_elements (pvt [p$libraries].value);
    module_count := clp$count_list_elements (pvt [p$modules].value);

    enable_conditions := $pmt$system_conditions [];
    inhibit_conditions := $pmt$system_conditions [];

    IF pvt [p$arithmetic_overflow].specified THEN
      IF pvt [p$arithmetic_overflow].value^.boolean_value.value THEN
        enable_conditions := enable_conditions + $pmt$system_conditions [pmc$arithmetic_overflow];
      ELSE
        inhibit_conditions := inhibit_conditions + $pmt$system_conditions [pmc$arithmetic_overflow];
      IFEND;
    IFEND;

    IF pvt [p$arithmetic_loss_of_significan].specified THEN
      IF pvt [p$arithmetic_loss_of_significan].value^.boolean_value.value THEN
        enable_conditions := enable_conditions + $pmt$system_conditions [pmc$arithmetic_significance];
      ELSE
        inhibit_conditions := inhibit_conditions + $pmt$system_conditions [pmc$arithmetic_significance];
      IFEND;
    IFEND;

    IF pvt [p$divide_fault].specified THEN
      IF pvt [p$divide_fault].value^.boolean_value.value THEN
        enable_conditions := enable_conditions + $pmt$system_conditions [pmc$divide_fault];
      ELSE
        inhibit_conditions := inhibit_conditions + $pmt$system_conditions [pmc$divide_fault];
      IFEND;
    IFEND;

    IF pvt [p$exponent_overflow].specified THEN
      IF pvt [p$exponent_overflow].value^.boolean_value.value THEN
        enable_conditions := enable_conditions + $pmt$system_conditions [pmc$exponent_overflow];
      ELSE
        inhibit_conditions := inhibit_conditions + $pmt$system_conditions [pmc$exponent_overflow];
      IFEND;
    IFEND;

    IF pvt [p$exponent_underflow].specified THEN
      IF pvt [p$exponent_underflow].value^.boolean_value.value THEN
        enable_conditions := enable_conditions + $pmt$system_conditions [pmc$exponent_underflow];
      ELSE
        inhibit_conditions := inhibit_conditions + $pmt$system_conditions [pmc$exponent_underflow];
      IFEND;
    IFEND;

    IF pvt [p$fp_indefinite].specified THEN
      IF pvt [p$fp_indefinite].value^.boolean_value.value THEN
        enable_conditions := enable_conditions + $pmt$system_conditions [pmc$fp_indefinite];
      ELSE
        inhibit_conditions := inhibit_conditions + $pmt$system_conditions [pmc$fp_indefinite];
      IFEND;
    IFEND;

    IF pvt [p$fp_loss_of_significance].specified THEN
      IF pvt [p$fp_loss_of_significance].value^.boolean_value.value THEN
        enable_conditions := enable_conditions + $pmt$system_conditions [pmc$fp_significance_loss];
      ELSE
        inhibit_conditions := inhibit_conditions + $pmt$system_conditions [pmc$fp_significance_loss];
      IFEND;
    IFEND;

    IF pvt [p$invalid_bdp_data].specified THEN
      IF pvt [p$invalid_bdp_data].value^.boolean_value.value THEN
        enable_conditions := enable_conditions + $pmt$system_conditions [pmc$invalid_bdp_data];
      ELSE
        inhibit_conditions := inhibit_conditions + $pmt$system_conditions [pmc$invalid_bdp_data];
      IFEND;
    IFEND;

    condition_specified := (inhibit_conditions + enable_conditions) <> $pmt$system_conditions [];
    enable_inhibit_condition_size := $INTEGER (condition_specified);

    PUSH program_descriptor: [[REP (#SIZE (pmt$program_attributes) +
          ((object_file_count + library_count) * #SIZE (amt$local_file_name)) +
          (module_count * #SIZE (pmt$program_name)) + (enable_inhibit_condition_size *
          #SIZE (pmt$enable_inhibit_conditions))) OF cell]];
    RESET program_descriptor;
    NEXT program_attributes IN program_descriptor;
    program_attributes^.contents := $pmt$prog_description_contents [];

    IF pvt [p$starting_procedure].specified THEN
      program_attributes^.contents := program_attributes^.contents +
            $pmt$prog_description_contents [pmc$starting_proc_specified];
      program_attributes^.starting_procedure := pvt [p$starting_procedure].value^.program_name_value;
    IFEND;

    IF object_file_count > 0 THEN
      program_attributes^.contents := program_attributes^.contents +
            $pmt$prog_description_contents [pmc$object_file_list_specified];
      program_attributes^.number_of_object_files := object_file_count;
      NEXT object_files: [1 .. object_file_count] IN program_descriptor;
      value := pvt [p$files].value;
      FOR i := 1 TO object_file_count DO
        element := value^.element_value;
        clp$convert_string_to_file (element^.file_value^, file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        object_files^ [i] := file.local_file_name;
        value := value^.link;
      FOREND;
    IFEND;

    IF pvt [p$parameters].specified THEN
      PUSH parameters_p: [STRLENGTH (pvt [p$parameters].value^.string_value^)];
      parameters_p^.size := STRLENGTH (pvt [p$parameters].value^.string_value^);
      parameters_p^.value := pvt [p$parameters].value^.string_value^;
    ELSE
      PUSH parameters_p: [0];
      parameters_p^.size := 0;
      parameters_p^.value := '';
    IFEND;

    IF module_count > 0 THEN
      program_attributes^.contents := program_attributes^.contents +
            $pmt$prog_description_contents [pmc$module_list_specified];
      program_attributes^.number_of_modules := module_count;
      NEXT modules: [1 .. module_count] IN program_descriptor;
      value := pvt [p$modules].value;
      FOR i := 1 TO module_count DO
        modules^ [i] := value^.element_value^.program_name_value;
        value := value^.link;
      FOREND;
    IFEND;

    IF library_count > 0 THEN
      program_attributes^.contents := program_attributes^.contents +
            $pmt$prog_description_contents [pmc$library_list_specified];
      program_attributes^.number_of_libraries := library_count;
      NEXT libraries: [1 .. library_count] IN program_descriptor;
      value := pvt [p$libraries].value;
      FOR i := 1 TO library_count DO
        element := value^.element_value;
        IF element^.kind = clc$keyword THEN
          libraries^ [i] := element^.keyword_value;
        ELSE
          clp$convert_string_to_file (element^.file_value^, file, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          libraries^ [i] := file.local_file_name;
        IFEND;
        value := value^.link;
      FOREND;
    IFEND;

    IF pvt [p$load_map].specified THEN
      program_attributes^.contents := program_attributes^.contents +
            $pmt$prog_description_contents [pmc$load_map_file_specified];
      clp$convert_string_to_file (pvt [p$load_map].value^.file_value^, file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      program_attributes^.load_map_file := file.local_file_name;
    IFEND;

    IF pvt [p$load_map_options].specified THEN
      program_attributes^.contents := program_attributes^.contents +
            $pmt$prog_description_contents [pmc$load_map_options_specified];
      get_load_map_options (pvt [p$load_map_options], program_attributes^.load_map_options, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$termination_error_level].specified THEN
      value := pvt [p$termination_error_level].value;
      program_attributes^.contents := program_attributes^.contents +
            $pmt$prog_description_contents [pmc$term_error_level_specified];
      IF value^.name_value = 'WARNING' THEN
        program_attributes^.termination_error_level := pmc$warning_load_errors;
      ELSEIF value^.name_value = 'ERROR' THEN
        program_attributes^.termination_error_level := pmc$error_load_errors;
      ELSEIF value^.name_value = 'FATAL' THEN
        program_attributes^.termination_error_level := pmc$fatal_load_errors;
      IFEND;
    IFEND;

    IF pvt [p$preset_value].specified THEN
      value := pvt [p$preset_value].value;
      program_attributes^.contents := program_attributes^.contents +
            $pmt$prog_description_contents [pmc$preset_specified];
      IF value^.name_value = 'FLOATING_POINT_INDEFINITE' THEN
        program_attributes^.preset := pmc$initialize_to_indefinite;
      ELSEIF value^.name_value = 'INFINITY' THEN
        program_attributes^.preset := pmc$initialize_to_infinity;
      ELSEIF value^.name_value = 'ALTERNATE_ONES' THEN
        program_attributes^.preset := pmc$initialize_to_alt_ones;
      ELSEIF value^.name_value = 'ZERO' THEN
        program_attributes^.preset := pmc$initialize_to_zero;
      IFEND;
    IFEND;

    IF pvt [p$stack_size].specified THEN
      program_attributes^.contents := program_attributes^.contents +
            $pmt$prog_description_contents [pmc$max_stack_size_specified];
      program_attributes^.maximum_stack_size := pvt [p$stack_size].value^.integer_value.value;
    IFEND;

    IF pvt [p$debug_input].specified THEN
      program_attributes^.contents := program_attributes^.contents +
            $pmt$prog_description_contents [pmc$debug_input_specified];
      clp$convert_string_to_file (pvt [p$debug_input].value^.file_value^, file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      program_attributes^.debug_input := file.local_file_name;
    IFEND;

    IF pvt [p$debug_output].specified THEN
      program_attributes^.contents := program_attributes^.contents +
            $pmt$prog_description_contents [pmc$debug_output_specified];
      clp$convert_string_to_file (pvt [p$debug_output].value^.file_value^, file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      program_attributes^.debug_output := file.local_file_name;
    IFEND;

    IF pvt [p$abort_file].specified THEN
      program_attributes^.contents := program_attributes^.contents +
            $pmt$prog_description_contents [pmc$abort_file_specified];
      clp$convert_string_to_file (pvt [p$abort_file].value^.file_value^, file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      program_attributes^.abort_file := file.local_file_name;
    IFEND;

    IF pvt [p$debug_mode].specified THEN
      program_attributes^.contents := program_attributes^.contents +
            $pmt$prog_description_contents [pmc$debug_mode_specified];
      program_attributes^.debug_mode := pvt [p$debug_mode].value^.boolean_value.value;
    IFEND;

    IF condition_specified THEN
      NEXT enable_inhibit_conditions IN program_descriptor;
      program_attributes^.contents := program_attributes^.contents +
            $pmt$prog_description_contents [pmc$condition_specified];
      enable_inhibit_conditions^.enable_system_conditions := enable_conditions;
      enable_inhibit_conditions^.inhibit_system_conditions := inhibit_conditions;

    IFEND;


    clp$set_command_kind (clc$command_is_execute_task);

    IF pvt [p$task_name].specified THEN

{ Asynchronous execute.

      clp$get_command_search_mode (search_mode);
      IF (search_mode = clc$exclusive_command_search) AND use_command_search_mode THEN
        osp$set_status_abnormal ('CL', cle$not_allowed_in_exclusive, 'EXECUTE_TASK', status);
        RETURN;
      IFEND;

      clp$execute_named_task (pvt [p$task_name].value^.name_value, caller_id.ring, program_descriptor^,
            #SEQ (parameters_p^) ^, ignore_command_file, task_id, status);
    ELSE

{ Synchronous execute.

      pmp$execute (program_descriptor^, #SEQ (parameters_p^) ^, osc$wait, task_id, task_status, status);
      IF status.normal AND (NOT task_status.status.normal) THEN
        status := task_status.status;
      IFEND;
    IFEND;

  PROCEND pmp$_execute_task;
?? TITLE := '[XDCL] pmp$_terminate_task', EJECT ??

{ PURPOSE:
{  This is the command processor for the terminate_task command.
{

  PROCEDURE [XDCL] pmp$_terminate_task
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$tert) terminate_task, tert (
{   task_name, task_names, tn: any of
{       key
{         all
{       keyend
{       list of name
{     anyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 4] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 14, 35, 47, 676], clc$command, 4, 2, 1, 0, 0, 0, 2, 'OSM$TERT'],
            [['STATUS                         ', clc$nominal_entry, 2],
            ['TASK_NAME                      ', clc$nominal_entry, 1],
            ['TASK_NAMES                     ', clc$alias_entry, 1],
            ['TN                             ', clc$abbreviation_entry, 1]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ 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]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$task_name = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

?? NEWTITLE := 'check_parent_and_tert', EJECT ??

    PROCEDURE [INLINE] check_parent_and_tert
      (    task_name: ost$name;
           all: boolean;
       VAR status {input, output} : ost$status);

      VAR
        terminate_status: ost$status;

      terminate_status.normal := TRUE;

      WHILE task_name <> named_task.name DO
        IF NOT (named_task.link = NIL) THEN
          named_task := named_task.link^
        ELSE
          IF status.normal THEN
            osp$set_status_abnormal ('CL', cle$task_not_found, task_name, status);
          ELSEIF status.condition = cle$task_not_found THEN
            osp$append_status_parameter (' ', task_name, status);
          IFEND;
          RETURN;
        IFEND;
      WHILEND;

      IF current_task_id = named_task.parent_task_id THEN
        IF NOT named_task.status.complete THEN
          pmp$terminate (named_task.id, terminate_status);
          IF NOT terminate_status.normal THEN
            IF status.normal THEN
              status := terminate_status;
            ELSEIF status.condition = terminate_status.condition THEN
              osp$append_status_parameter (osc$status_parameter_delimiter, task_name, status);
            IFEND;
          IFEND;
        ELSEIF NOT all THEN
          IF status.normal THEN
            osp$set_status_abnormal ('CL', cle$task_already_complete, task_name, status);
          ELSEIF status.condition = cle$task_already_complete THEN
            osp$append_status_parameter (' ', task_name, status);
          IFEND;
        IFEND;
      ELSEIF NOT all THEN
        IF status.normal THEN
          osp$set_status_abnormal ('CL', cle$task_not_found, task_name, status);
        ELSEIF status.condition = cle$task_not_found THEN
          osp$append_status_parameter (' ', task_name, status);
        IFEND;
      IFEND;

    PROCEND check_parent_and_tert;
?? OLDTITLE, EJECT ??

    VAR
      current_task_id: pmt$task_id,
      named_task: clt$named_task,
      named_task_list: ^clt$named_task,
      named_task_group_list: ^^clt$named_task,
      value: ^clt$data_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_task_id (current_task_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    value := pvt [p$task_name].value;
    IF value^.kind = clc$keyword { ALL} THEN
      clp$find_named_task_group_list (named_task_group_list);
      named_task_list := named_task_group_list^;
      WHILE named_task_list <> NIL DO
        named_task := named_task_list^;
        check_parent_and_tert (named_task_list^.name, TRUE, status);
        named_task_list := named_task_list^.link;
      WHILEND;
    ELSE
      WHILE value <> NIL DO
        IF value^.element_value <> NIL THEN
          clp$fetch_named_task_entry (value^.element_value^.name_value, named_task);
          check_parent_and_tert (value^.element_value^.name_value, FALSE, status);
        IFEND;
        value := value^.link;
      WHILEND;
    IFEND;

  PROCEND pmp$_terminate_task;
?? TITLE := '[XDCL] pmp$_display_program_attributes', EJECT ??

{ PURPOSE:
{  This is the command processor for the display_program_attribute command.
{

  PROCEDURE [XDCL] pmp$_display_program_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    CONST
      max_program_attb_name_size = 31;

{ PROCEDURE (osm$dispa) display_program_attributes, display_program_attribute, dispa (
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 26, 14, 36, 36, 578], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$DISPA'],
            [['O                              ', clc$abbreviation_entry, 1],
            ['OUTPUT                         ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 2]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type], '$output'],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

*copy clv$display_variables
?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;
*copy clp$new_page_procedure
?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

{ The display_program command has no subtitles,
{ this is merely a dummy routine used to keep
{ the module consistent with those that do produce subtitles.

    PROCEND put_subtitle;
?? TITLE := 'put_attribute', EJECT ??

    PROCEDURE put_attribute
      (    header: string ( * );
           value: string ( * ));

      VAR
        edited_header: string (tab_over),
        start_option: amt$term_option;

      CONST
        tab_over = max_program_attb_name_size + 5;

      status.normal := TRUE;
      start_option := amc$start;
      edited_header := header;
      edited_header (tab_over - 2) := ':';

      clp$put_partial_display (display_control, edited_header, clc$no_trim, start_option, status);
      IF NOT status.normal THEN
        EXIT pmp$_display_program_attributes
      IFEND;
      clp$put_partial_display (display_control, value, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        EXIT pmp$_display_program_attributes
      IFEND;

    PROCEND put_attribute;
?? TITLE := 'put_attribute_list', EJECT ??

    PROCEDURE put_attribute_list
      (    header: string ( * );
           value_count: integer;
           value: array [ * ] of string (osc$max_name_size));

      VAR
        edited_header: string (tab_over),
        start_option: amt$term_option,
        value_index: integer;

      CONST
        tab_over = max_program_attb_name_size + 6;

      status.normal := TRUE;
      start_option := amc$start;
      edited_header := header;
      edited_header (tab_over) := '(';
      edited_header (tab_over - 3) := ':';

      clp$put_partial_display (display_control, edited_header, clc$no_trim, start_option, status);
      IF NOT status.normal THEN
        EXIT pmp$_display_program_attributes
      IFEND;

      FOR value_index := 1 TO value_count DO
        IF (display_control.column_number + clp$trimmed_string_size (value [value_index]) + 2) >
              clv$page_width THEN
          clp$new_display_line (display_control, clc$next_display_line, status);
          IF NOT status.normal THEN
            EXIT pmp$_display_program_attributes
          IFEND;
          clp$horizontal_tab_display (display_control, tab_over, status);
          IF NOT status.normal THEN
            EXIT pmp$_display_program_attributes
          IFEND;
        IFEND;
        clp$put_partial_display (display_control, value [value_index], clc$trim, amc$continue, status);
        IF NOT status.normal THEN
          EXIT pmp$_display_program_attributes
        IFEND;
        IF value_index = value_count THEN
          clp$put_partial_display (display_control, ')', clc$no_trim, amc$terminate, status);
          IF NOT status.normal THEN
            EXIT pmp$_display_program_attributes
          IFEND;
        ELSE
          clp$put_partial_display (display_control, ', ', clc$no_trim, amc$continue, status);
          IF NOT status.normal THEN
            EXIT pmp$_display_program_attributes
          IFEND;
        IFEND;
      FOREND;

    PROCEND put_attribute_list;
?? TITLE := 'put_path_name_list', EJECT ??

    PROCEDURE put_path_name_list
      (    header: string ( * );
           path_array: array [1 .. * ] of fst$path);

      VAR
        chunk_index: integer,
        edited_header: string (tab_over),
        end_delimeter: string (1),
        path_name: fst$path,
        path_name_index: integer,
        path_name_size: 1 .. fsc$max_path_size,
        start_delimeter: string (1),
        start_option: amt$term_option;

      CONST
        tab_over = max_program_attb_name_size + 5;

      status.normal := TRUE;
      start_option := amc$start;
      edited_header := header;
      edited_header (tab_over - 2) := ':';

      clp$put_partial_display (display_control, edited_header, clc$no_trim, start_option, status);
      IF NOT status.normal THEN
        EXIT pmp$_display_program_attributes;
      IFEND;

      IF UPPERBOUND (path_array) = 1 THEN
        end_delimeter := ' ';
      ELSE
        clp$put_partial_display (display_control, '(', clc$trim, amc$continue, status);
        IF NOT status.normal THEN
          EXIT pmp$_display_program_attributes
        IFEND;
        end_delimeter := ')';
      IFEND;

      FOR path_name_index := 1 TO UPPERBOUND (path_array) DO
        path_name := path_array [path_name_index];
        path_name_size := clp$trimmed_string_size (path_array [path_name_index]);

        clp$build_path_subtitle (path_name, path_name_size, (clv$page_width - tab_over),
              clv$path_display_chunk_count, clv$path_display_chunks);

        FOR chunk_index := 1 TO clv$path_display_chunk_count DO
          clp$put_partial_display (display_control, path_name
                (clv$path_display_chunks [chunk_index].position, clv$path_display_chunks [chunk_index].
                length), clc$trim, amc$continue, status);
          IF NOT status.normal THEN
            EXIT pmp$_display_program_attributes
          IFEND;

          IF chunk_index = clv$path_display_chunk_count THEN
            IF path_name_index = UPPERBOUND (path_array) THEN
              clp$put_partial_display (display_control, end_delimeter, clc$trim, amc$terminate, status);
              IF NOT status.normal THEN
                EXIT pmp$_display_program_attributes
              IFEND;
            ELSE
              clp$put_partial_display (display_control, ',', clc$trim, amc$terminate, status);
              IF NOT status.normal THEN
                EXIT pmp$_display_program_attributes
              IFEND;
              clp$new_display_line (display_control, clc$next_display_line, status);
              IF NOT status.normal THEN
                EXIT pmp$_display_program_attributes
              IFEND;
              clp$horizontal_tab_display (display_control, (tab_over + 1), status);
              IF NOT status.normal THEN
                EXIT pmp$_display_program_attributes
              IFEND;
            IFEND;
          ELSE
            clp$put_partial_display (display_control, '..', clc$trim, amc$terminate, status);
            IF NOT status.normal THEN
              EXIT pmp$_display_program_attributes
            IFEND;
            clp$new_display_line (display_control, clc$next_display_line, status);
            IF NOT status.normal THEN
              EXIT pmp$_display_program_attributes
            IFEND;
            clp$horizontal_tab_display (display_control, (tab_over + 1), status);
            IF NOT status.normal THEN
              EXIT pmp$_display_program_attributes
            IFEND;
          IFEND;
        FOREND;
      FOREND;

    PROCEND put_path_name_list;
?? OLDTITLE, EJECT ??

    CONST
      max_map_option_string_size = 16, { cross_reference
      max_boolean_string_size = 3; {off

    VAR
      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'],
      boolean_string: [STATIC, READ, oss$job_paged_literal] array [boolean] of
            string (max_boolean_string_size) := ['off', 'on'];

    VAR
      attribute_array: array [1 .. 5] of ost$name,
      condition_enabled: boolean,
      debug_library_list: ^pmt$object_library_list,
      debug_mode: ost$string,
      default_program_options: pmt$program_options,
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      file_reference: fst$path,
      i: pmt$number_of_libraries,
      ignore_status: ost$status,
      initialization_value: pmt$initialization_value,
      job_library_list: ^pmt$object_library_list,
      map_option: pmc$no_load_map .. pmc$entry_point_xref,
      number_of_libraries: pmt$number_of_libraries,
      number_string: ost$string,
      path_name_array: ^array [1 .. * ] of fst$path,
      prog_options_and_libraries: ^pmt$prog_options_and_libraries,
      value_count: integer;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    osp$establish_block_exit_hndlr (^abort_handler);

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);
    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          default_ring_attributes, display_control, status);
    IF NOT status.normal THEN
      osp$disestablish_cond_handler;
      RETURN;
    IFEND;
    clv$titles_built := FALSE;
    clv$command_name := 'display_program_attributes';

    IF display_control.page_width < clc$narrow_page_width THEN
      clv$page_width := clc$narrow_page_width;
    ELSEIF display_control.page_width > clc$wide_page_width THEN
      clv$page_width := clc$wide_page_width;
    ELSE
      clv$page_width := display_control.page_width;
    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^;

    IF job_library_list = NIL THEN
      put_attribute ('Libraries', 'None');
    ELSE
      number_of_libraries := UPPERBOUND (job_library_list^);
      PUSH path_name_array: [1 .. number_of_libraries];
      FOR i := 1 TO number_of_libraries DO
        IF job_library_list^ [i] = 'OSF$TASK_SERVICES_LIBRARY' THEN
          path_name_array^ [i] := 'osf$task_services_library';
        ELSE
          clp$get_path_name (job_library_list^ [i], osc$full_message_level, file_reference);
          path_name_array^ [i] := file_reference;
        IFEND;
      FOREND;
      put_path_name_list ('Libraries', path_name_array^);
    IFEND;

    IF debug_library_list = NIL THEN
      put_attribute ('Debug_Libraries', 'None');
    ELSE
      number_of_libraries := UPPERBOUND (debug_library_list^);
      PUSH path_name_array: [1 .. number_of_libraries];
      FOR i := 1 TO number_of_libraries DO
        clp$get_path_name (debug_library_list^ [i], osc$full_message_level, file_reference);
        path_name_array^ [i] := file_reference;
      FOREND;
      put_path_name_list ('Debug_Libraries', path_name_array^);
    IFEND;

    PUSH path_name_array: [1 .. 1];
    clp$get_path_name (default_program_options.map_file, osc$full_message_level, file_reference);
    path_name_array^ [1] := file_reference;
    put_path_name_list ('Load_Map', path_name_array^);

    value_count := 0;
    FOR map_option := pmc$no_load_map TO pmc$entry_point_xref DO
      IF map_option IN default_program_options.map_options THEN
        value_count := value_count + 1;
        attribute_array [value_count] := map_option_string [map_option];
      IFEND;
    FOREND;
    IF value_count = 0 THEN
      put_attribute ('Load_Map_Options', 'None');
    ELSE
      put_attribute_list ('Load_Map_Options', value_count, attribute_array);
    IFEND;

    put_attribute ('Termination_Error_Level', termination_error_level_string
          [default_program_options.termination_error_level]);

  /display_preset/
    BEGIN
      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
          put_attribute ('Preset_Value', preset_string [initialization_value]);
          EXIT /display_preset/;
        IFEND;
      FOREND;
      clp$convert_integer_to_string (default_program_options.preset, 16, TRUE, number_string, ignore_status);
      put_attribute ('Preset_Value', number_string.value (1, number_string.size));
    END /display_preset/;

    clp$convert_integer_to_string (default_program_options.maximum_stack_size, 10, FALSE, number_string,
          ignore_status);
    put_attribute ('Maximum_Stack_Size', number_string.value (1, number_string.size));

    clp$convert_integer_to_string (pmp$job_debug_ring (), 10, FALSE, number_string, ignore_status);
    put_attribute ('Debug_Ring', number_string.value (1, number_string.size));

{ The following code prevents the full permanent file path name of the command file from being displayed,
{ in the case where the debug_input file corresponds to the default command file.  We do not want users
{ to see the name of the file in the input queue.

    IF default_program_options.debug_input = clv$standard_files [clc$sf_command_file].path_handle_name THEN
      path_name_array^ [1] := ':$local.command.1';
    ELSE
      clp$get_path_name (default_program_options.debug_input, osc$full_message_level, file_reference);
      path_name_array^ [1] := file_reference;
    IFEND;
    put_path_name_list ('Debug_Input', path_name_array^);

    clp$get_path_name (default_program_options.debug_output, osc$full_message_level, file_reference);
    path_name_array^ [1] := file_reference;
    put_path_name_list ('Debug_Output', path_name_array^);

    clp$get_path_name (default_program_options.abort_file, osc$full_message_level, file_reference);
    path_name_array^ [1] := file_reference;
    put_path_name_list ('Abort_File', path_name_array^);

    put_attribute ('Debug_Mode', boolean_string [default_program_options.debug_mode]);

    condition_enabled := (pmc$arithmetic_overflow IN default_program_options.conditions_enabled);
    put_attribute ('Arithmetic_Overflow', boolean_string [condition_enabled]);

    condition_enabled := (pmc$arithmetic_significance IN default_program_options.conditions_enabled);
    put_attribute ('Arithmetic_Loss_of_Significance', boolean_string [condition_enabled]);

    condition_enabled := (pmc$divide_fault IN default_program_options.conditions_enabled);
    put_attribute ('Divide_Fault', boolean_string [condition_enabled]);

    condition_enabled := (pmc$exponent_overflow IN default_program_options.conditions_enabled);
    put_attribute ('Exponent_Overflow', boolean_string [condition_enabled]);

    condition_enabled := (pmc$exponent_underflow IN default_program_options.conditions_enabled);
    put_attribute ('Exponent_Underflow', boolean_string [condition_enabled]);

    condition_enabled := (pmc$fp_indefinite IN default_program_options.conditions_enabled);
    put_attribute ('FP_Indefinite', boolean_string [condition_enabled]);

    condition_enabled := (pmc$fp_significance_loss IN default_program_options.conditions_enabled);
    put_attribute ('FP_Loss_of_Significance', boolean_string [condition_enabled]);

    condition_enabled := (pmc$invalid_bdp_data IN default_program_options.conditions_enabled);
    put_attribute ('Invalid_BDP_Data', boolean_string [condition_enabled]);

    clp$close_display (display_control, status);

    osp$disestablish_cond_handler;

  PROCEND pmp$_display_program_attributes;
?? TITLE := '[XDCL] pmp$$program', EJECT ??

{ PURPOSE:
{  This is the command processor for $program function.
{

  PROCEDURE [XDCL] pmp$$program
    (    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) $program (
{   attribute: key
{      (abort_file, af),
{      (arithmetic_loss_of_significance, alos),
{      (arithmetic_overflow, ao),
{      (debug_input, di),
{      (debug_mode, dm),
{      (debug_output, do),
{      (divide_fault, df),
{      (exponent_overflow, eo),
{      (exponent_underflow, eu),
{      (fp_indefinite, fpi, fi),
{      (fp_loss_of_significance, fplos, flos),
{      (invalid_bdp_data, ibdpd, ibd),
{      (load_map, lm),
{      (load_map_option, load_map_options, lmo),
{      (preset_value, pv),
{      (termination_error_level, tel),
{     keyend = $required
{   load_map_option: key
{       (block, b), (cross_reference, cr), (entry_point, ep),
{       (none), (segment, s)
{     keyend
{  )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 36] of clt$keyword_specification,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 9] of clt$keyword_specification,
        recend,
      recend := [[1, [88, 9, 26, 14, 33, 41, 87], clc$function, 2, 2, 1, 0, 0, 0, 0, 'OSM$PROGRAM'],
            [['ATTRIBUTE                      ', clc$nominal_entry, 1],
            ['LOAD_MAP_OPTION                ', clc$nominal_entry, 2]], [

{ 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, 1339, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [2, 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, 340, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$keyword_type], [36], [['ABORT_FILE                     ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['AF                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['ALOS                           ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['AO                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['ARITHMETIC_LOSS_OF_SIGNIFICANCE', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['ARITHMETIC_OVERFLOW            ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['DEBUG_INPUT                    ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['DEBUG_MODE                     ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['DEBUG_OUTPUT                   ', clc$nominal_entry,
            clc$normal_usage_entry, 6], ['DF                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 7], ['DI                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['DIVIDE_FAULT                   ', clc$nominal_entry,
            clc$normal_usage_entry, 7], ['DM                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['DO                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['EO                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 8], ['EU                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 9], ['EXPONENT_OVERFLOW              ', clc$nominal_entry,
            clc$normal_usage_entry, 8], ['EXPONENT_UNDERFLOW             ', clc$nominal_entry,
            clc$normal_usage_entry, 9], ['FI                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 10], ['FLOS                           ', clc$abbreviation_entry,
            clc$normal_usage_entry, 11], ['FPI                            ', clc$alias_entry,
            clc$normal_usage_entry, 10], ['FPLOS                          ', clc$alias_entry,
            clc$normal_usage_entry, 11], ['FP_INDEFINITE                  ', clc$nominal_entry,
            clc$normal_usage_entry, 10], ['FP_LOSS_OF_SIGNIFICANCE        ', clc$nominal_entry,
            clc$normal_usage_entry, 11], ['IBD                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 12], ['IBDPD                          ', clc$alias_entry,
            clc$normal_usage_entry, 12], ['INVALID_BDP_DATA               ', clc$nominal_entry,
            clc$normal_usage_entry, 12], ['LM                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 13], ['LMO                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 14], ['LOAD_MAP                       ', clc$nominal_entry,
            clc$normal_usage_entry, 13], ['LOAD_MAP_OPTION                ', clc$nominal_entry,
            clc$normal_usage_entry, 14], ['LOAD_MAP_OPTIONS               ', clc$alias_entry,
            clc$normal_usage_entry, 14], ['PRESET_VALUE                   ', clc$nominal_entry,
            clc$normal_usage_entry, 15], ['PV                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 15], ['TEL                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 16], ['TERMINATION_ERROR_LEVEL        ', clc$nominal_entry,
            clc$normal_usage_entry, 16]]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [9], [['B                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['BLOCK                          ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['CR                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['CROSS_REFERENCE                ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['ENTRY_POINT                    ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['EP                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['S                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['SEGMENT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 5]]]];

?? POP ??

    CONST
      p$attribute = 1,
      p$load_map_option = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      attribute_name: ost$name,
      default_program_options: pmt$program_options,
      initialization_value: pmt$initialization_value,
      map_option_enabled: boolean,
      path: fst$path,
      prog_options_and_libraries: ^pmt$prog_options_and_libraries,
      translated_string: string (osc$max_name_size);

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$find_prog_options_and_libs (prog_options_and_libraries);
    default_program_options := prog_options_and_libraries^.default_options^;

    attribute_name := pvt [p$attribute].value^.name_value;
    IF attribute_name = 'LOAD_MAP_OPTION' THEN
      IF NOT pvt [p$load_map_option].specified THEN
        osp$set_status_abnormal ('CL', cle$required_argument_omitted, '$PROGRAM(LOAD_MAP_OPTION,)', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, '2', status);

      ELSE
        IF pvt [p$load_map_option].value^.name_value = 'SEGMENT' THEN
          map_option_enabled := pmc$segment_map IN default_program_options.map_options;
        ELSEIF pvt [p$load_map_option].value^.name_value = 'BLOCK' THEN
          map_option_enabled := pmc$block_map IN default_program_options.map_options;
        ELSEIF pvt [p$load_map_option].value^.name_value = 'ENTRY_POINT' THEN
          map_option_enabled := pmc$entry_point_map IN default_program_options.map_options;
        ELSEIF pvt [p$load_map_option].value^.name_value = 'CROSS_REFERENCE' THEN
          map_option_enabled := pmc$entry_point_xref IN default_program_options.map_options;
        ELSE {IF pvt [p$load_map_option].value^.name_value = 'NONE' THEN }
          map_option_enabled := $pmt$load_map_options [] = default_program_options.map_options;
        IFEND;
        clp$make_boolean_value (map_option_enabled, clc$true_false_boolean, work_area, result);
      IFEND;

    ELSEIF pvt [p$load_map_option].specified THEN
      osp$set_status_abnormal ('CL', cle$too_many_arguments, '$PROGRAM', status);

    ELSEIF attribute_name = 'LOAD_MAP' THEN
      clp$get_path_name (default_program_options.map_file, osc$full_message_level, path);
      clp$make_file_value (path, work_area, result);

    ELSEIF attribute_name = 'PRESET_VALUE' THEN

    /return_preset/
      BEGIN
        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);
            EXIT /return_preset/;
          IFEND;
        FOREND;
        translated_string := 'NON_STANDARD';
      END /return_preset/;
      clp$make_sized_string_value (clp$trimmed_string_size (translated_string), work_area, result);
      result^.string_value^ := translated_string;

    ELSEIF attribute_name = 'TERMINATION_ERROR_LEVEL' THEN
      #TRANSLATE (osv$lower_to_upper, termination_error_level_string
            [default_program_options.termination_error_level], translated_string);
      clp$make_sized_string_value (clp$trimmed_string_size (translated_string), work_area, result);
      result^.string_value^ := translated_string;

    ELSEIF attribute_name = 'DEBUG_INPUT' THEN

{ The following code prevents the full permanent file path name of the command file from being displayed,
{ in the case where the debug_input file corresponds to the default command file.  We do not want users
{ to see the name of the file in the input queue.

      IF default_program_options.debug_input = clv$standard_files [clc$sf_command_file].path_handle_name THEN
        path := ':$LOCAL.COMMAND.1';
      ELSE
        clp$get_path_name (default_program_options.debug_input, osc$full_message_level, path);
      IFEND;
      clp$make_file_value (path, work_area, result);

    ELSEIF attribute_name = 'DEBUG_OUTPUT' THEN
      clp$get_path_name (default_program_options.debug_output, osc$full_message_level, path);
      clp$make_file_value (path, work_area, result);

    ELSEIF attribute_name = 'ABORT_FILE' THEN
      clp$get_path_name (default_program_options.abort_file, osc$full_message_level, path);
      clp$make_file_value (path, work_area, result);

    ELSEIF attribute_name = 'DEBUG_MODE' THEN
      clp$make_boolean_value (default_program_options.debug_mode, clc$true_false_boolean, work_area, result);

    ELSEIF attribute_name = 'ARITHMETIC_OVERFLOW' THEN
      clp$make_boolean_value (pmc$arithmetic_overflow IN default_program_options.conditions_enabled,
            clc$true_false_boolean, work_area, result);

    ELSEIF attribute_name = 'ARITHMETIC_LOSS_OF_SIGNIFICANCE' THEN
      clp$make_boolean_value (pmc$arithmetic_significance IN default_program_options.conditions_enabled,
            clc$true_false_boolean, work_area, result);

    ELSEIF attribute_name = 'DIVIDE_FAULT' THEN
      clp$make_boolean_value (pmc$divide_fault IN default_program_options.conditions_enabled,
            clc$true_false_boolean, work_area, result);

    ELSEIF attribute_name = 'EXPONENT_OVERFLOW' THEN
      clp$make_boolean_value (pmc$exponent_overflow IN default_program_options.conditions_enabled,
            clc$true_false_boolean, work_area, result);

    ELSEIF attribute_name = 'EXPONENT_UNDERFLOW' THEN
      clp$make_boolean_value (pmc$exponent_underflow IN default_program_options.conditions_enabled,
            clc$true_false_boolean, work_area, result);

    ELSEIF attribute_name = 'FP_INDEFINITE' THEN
      clp$make_boolean_value (pmc$fp_indefinite IN default_program_options.conditions_enabled,
            clc$true_false_boolean, work_area, result);

    ELSEIF attribute_name = 'FP_LOSS_OF_SIGNIFICANCE' THEN
      clp$make_boolean_value (pmc$fp_significance_loss IN default_program_options.conditions_enabled,
            clc$true_false_boolean, work_area, result);

    ELSEIF attribute_name = 'INVALID_BDP_DATA' THEN
      clp$make_boolean_value (pmc$invalid_bdp_data IN default_program_options.conditions_enabled,
            clc$true_false_boolean, work_area, result);

    IFEND;

  PROCEND pmp$$program;
?? TITLE := 'get_load_map_options', EJECT ??

  PROCEDURE get_load_map_options
    (    parameter: clt$parameter_value;
     VAR map_options: pmt$load_map_options;
     VAR status: ost$status);

    VAR
      map_option: pmc$segment_map .. pmc$entry_point_xref,
      value: ^clt$data_value;

    map_options := $pmt$load_map_options [];
    value := parameter.value;
    IF value^.kind = clc$keyword THEN
      IF value^.keyword_value = 'ALL' THEN
        map_options := map_options + $pmt$load_map_options [pmc$segment_map, pmc$block_map,
              pmc$entry_point_map, pmc$entry_point_xref];
      ELSE {keyword = NONE}
        map_options := map_options + $pmt$load_map_options [pmc$no_load_map];
      IFEND;
    ELSEIF value^.kind = clc$list THEN
      WHILE value <> NIL DO
        IF value^.element_value^.keyword_value = 'SEGMENT' THEN
          map_option := pmc$segment_map;
        ELSEIF value^.element_value^.keyword_value = 'BLOCK' THEN
          map_option := pmc$block_map;
        ELSEIF value^.element_value^.keyword_value = 'ENTRY_POINT' THEN
          map_option := pmc$entry_point_map;
        ELSE { CROSS_REFERENCE
          map_option := pmc$entry_point_xref;
        IFEND;
        IF map_option IN map_options THEN
          osp$set_status_abnormal ('CL', cle$redundancy_in_selections, 'LOAD_MAP_OPTIONS', status);
          RETURN;
        IFEND;
        map_options := map_options + $pmt$load_map_options [map_option];
        value := value^.link;
      WHILEND;
    IFEND;
  PROCEND get_load_map_options;
MODEND pmm$program_execution_commands;
*DECK DECK=PMM$PROGRAM_SERVICES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Program Management : Program Services' ??
MODULE pmm$program_services;

{ PURPOSE:
{   This module contains the program service routines for:
{
{         170 os type,
{         mainframe attributes,
{         microsecond clock,
{         os build_level,
{         os version,
{         processor attributes,
{         readying tasks,
{         task cp time

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
*IF NOT $true(osv$unix)
?? PUSH (LISTEXT := ON) ??
*copyc osc$processor_defined_registers
*copyc oss$mainframe_pageable
*copyc oss$mainframe_paged_literal
*copyc ost$170_os_type
*copyc ost$hardware_subranges
*copyc ost$page_size
*copyc ost$processor_element_id
*IFEND
*copyc ost$status
*IF NOT $true(osv$unix)
*copyc pme$unknown_recipient_task
*copyc pme$program_services_exceptions
*copyc pmk$keypoints
*copyc pmt$binary_cpu_attributes
*copyc pmt$binary_mainframe_id
*copyc pmt$cpu_attributes
*copyc pmt$mainframe_attributes
*copyc pmt$mainframe_id
*copyc pmt$os_name
*copyc pmt$processor_attributes
*copyc pmt$processor_model_number
*copyc pmt$processor_model_type
*copyc pmt$processor_serial_number
*copyc pmt$task_cp_time
*copyc pmt$task_jobmode_statistics
*copyc pmt$vector_capability
*copyc pmt$vector_degrade_state
*copyc pmt$vector_simulation
*copyc tmt$rb_fetch_task_statistics
*copyc tmt$rb_ready_task
?? POP ??
*copyc clp$convert_integer_to_rjstring
*copyc clp$trimmed_string_size
*copyc i#call_monitor
*copyc i#disable_traps
*copyc i#restore_traps
*copyc osp$get_cpu_model_definition
*copyc osp$get_global_cpu_model_def
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$find_executing_task_xcb
?? EJECT ??
*copyc mtv$cst0
*copyc mtv$scb
*copyc osv$170_os_type
*copyc osv$build_level
*IFEND
*copyc osv$os_defaults
*IF NOT $true(osv$unix)
*copyc pmv$cpu_data
*copyc pmv$mainframe_id
*IFEND
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    c$system_underscore = '$SYSTEM_',
    c$underscore = '_';

*IF NOT $true(osv$unix)
  TYPE
    t$mainframe_id_mask = RECORD
      CASE boolean OF
      = TRUE =
        mainframe_id: pmt$mainframe_id,
      = FALSE =
        dollar_system_underscore: string (8),
        model_number: string (pmc$processor_model_number_size),
        underscore: string (1),
        serial_number: string (pmc$processor_serial_num_size),
      CASEND,
    RECEND;
?? EJECT ??
  VAR
    v$digits: [STATIC, READ, oss$mainframe_paged_literal] SET OF char :=
          ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '0'];

?? OLDTITLE ??
?? NEWTITLE := 'pmp$convert_binary_mainframe_id', EJECT ??
*copy pmh$convert_binary_mainframe_id

{ NOTE:
{   This procedure deals with the pseudo model number.

  PROCEDURE [XDCL, #GATE] pmp$convert_binary_mainframe_id
    (    binary_mainframe_id: pmt$binary_mainframe_id;
     VAR mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      definition_found: boolean,
      global_processor_model_def: ost$processor_model_definition,
      mainframe_id_converter: t$mainframe_id_mask,
      processor_model_definition: ost$processor_model_definition,
      search_data: ost$processor_search_data;

    status.normal := TRUE;

    mainframe_id_converter.dollar_system_underscore := c$system_underscore;
    mainframe_id_converter.underscore := c$underscore;
    clp$convert_integer_to_rjstring (binary_mainframe_id.serial_number, 16, FALSE, '0',
          mainframe_id_converter.serial_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mainframe_id_converter.model_number := pmc$cyber_180_model_unknown;

    osp$get_global_cpu_model_def (global_processor_model_def);
    IF binary_mainframe_id.model_number = global_processor_model_def.pseudo_model_number THEN
      mainframe_id_converter.model_number (pmc$processor_model_number_size -
            clp$trimmed_string_size (global_processor_model_def.model_number_string) + 1, * ) :=
            global_processor_model_def.model_number_string;
    ELSE
      search_data.search_mode := osc$psm_by_pseudo_model_number;
      search_data.pseudo_model_number := binary_mainframe_id.model_number;
      osp$get_cpu_model_definition (search_data, definition_found, processor_model_definition);
      IF definition_found THEN
        mainframe_id_converter.model_number (pmc$processor_model_number_size -
              clp$trimmed_string_size (processor_model_definition.model_number_string) + 1, * ) :=
              processor_model_definition.model_number_string;
      IFEND;
    IFEND;
    mainframe_id := mainframe_id_converter.mainframe_id;

  PROCEND pmp$convert_binary_mainframe_id;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$convert_mainframe_to_binary', EJECT ??
*copy pmh$convert_mainframe_to_binary

{ NOTE:
{   This procedure deals with the pseudo model number.

  PROCEDURE [XDCL, #GATE] pmp$convert_mainframe_to_binary
    (    mainframe_id: pmt$mainframe_id;
     VAR binary_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

    TYPE
      t$serial_number_conversion = RECORD
        CASE boolean OF
        = TRUE =
          serial_number: ost$processor_serial_number,
        = FALSE =
          serial_number_array: PACKED ARRAY [1 .. pmc$processor_serial_num_size] OF 0 .. 0f(16),
        CASEND,
      RECEND;

    VAR
      converter: t$serial_number_conversion,
      definition_found: boolean,
      global_processor_model_def: ost$processor_model_definition,
      mainframe_id_converter: t$mainframe_id_mask,
      model_index: 1 .. pmc$processor_model_number_size - 1,
      model_number: string (pmc$processor_model_number_size),
      processor_model_definition: ost$processor_model_definition,
      search_data: ost$processor_search_data,
      serial_number_index: 1 .. pmc$processor_serial_num_size;

    status.normal := TRUE;

    mainframe_id_converter.mainframe_id := mainframe_id;
    IF (mainframe_id_converter.dollar_system_underscore <> c$system_underscore) OR
          (mainframe_id_converter.underscore <> c$underscore) THEN
      osp$set_status_abnormal ('PM', pme$invalid_mainframe_id, mainframe_id, status);
      RETURN;
    IFEND;

    FOR serial_number_index := 1 TO pmc$processor_serial_num_size DO
      IF mainframe_id_converter.serial_number (serial_number_index) IN v$digits THEN
        converter.serial_number_array [serial_number_index] :=
              $INTEGER (mainframe_id_converter.serial_number (serial_number_index)) - $INTEGER ('0');
      ELSE
        osp$set_status_abnormal ('PM', pme$invalid_mainframe_id, mainframe_id, status);
        RETURN;
      IFEND;
    FOREND;
    binary_mainframe_id.serial_number := converter.serial_number;

    model_number := pmc$cyber_180_model_unknown;

  /extract_model_number_from_id/
    FOR model_index := 1 TO pmc$processor_model_number_size - 1 DO
      IF mainframe_id_converter.model_number (model_index) <> '0' THEN
        model_number := mainframe_id_converter.model_number
              (model_index, pmc$processor_model_number_size - model_index + 1);
        EXIT /extract_model_number_from_id/;
      IFEND;
    FOREND /extract_model_number_from_id/;

    binary_mainframe_id.model_number := osc$cyber_180_model_unknown;

    osp$get_global_cpu_model_def (global_processor_model_def);
    IF model_number = global_processor_model_def.model_number_string THEN
      binary_mainframe_id.model_number := global_processor_model_def.pseudo_model_number;
    ELSE
      search_data.search_mode := osc$psm_by_model_number_string;
      search_data.model_number_string := model_number;
      osp$get_cpu_model_definition (search_data, definition_found, processor_model_definition);
      IF definition_found THEN
        binary_mainframe_id.model_number := processor_model_definition.pseudo_model_number;
      IFEND;
    IFEND;

  PROCEND pmp$convert_mainframe_to_binary;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_170_os_type', EJECT ??
*copy pmh$get_170_os_type

  PROCEDURE [XDCL, #GATE] pmp$get_170_os_type
    (VAR os_type: ost$170_os_type;
     VAR status: ost$status);

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, pmk$get_170_os_type);

    os_type := osv$170_os_type;

    #KEYPOINT (osk$exit, 0, pmk$get_170_os_type);
  PROCEND pmp$get_170_os_type;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_binary_cpu_attributes', EJECT ??
*copy pmh$get_binary_cpu_attributes

  PROCEDURE [XDCL, #GATE] pmp$get_binary_cpu_attributes
    (VAR cpu_attributes: pmt$binary_cpu_attributes;
     VAR status: ost$status);

    VAR
      index: 0 .. osc$maximum_processor_number;

    #KEYPOINT (osk$entry, 0, pmk$get_binary_cpu_attributes);

    status.normal := TRUE;
    cpu_attributes := pmv$cpu_data.binary_attributes;

    FOR index := 0 TO pmv$cpu_data.binary_attributes.highest_defined_cpu_number DO
      cpu_attributes.cpu [index].processor_state := mtv$cst0 [index].processor_state;
    FOREND;

    #KEYPOINT (osk$exit, 0, pmk$get_binary_cpu_attributes);

  PROCEND pmp$get_binary_cpu_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_binary_mainframe_id', EJECT ??
*copy pmh$get_binary_mainframe_id

  PROCEDURE [XDCL, #GATE] pmp$get_binary_mainframe_id
    (VAR mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

    #KEYPOINT (osk$entry, 0, pmk$get_binary_mainframe_id);

    status.normal := TRUE;

    mainframe_id.model_number := pmv$cpu_data.binary_attributes.cpu [0].processor_element_id.model_number;
    mainframe_id.serial_number := pmv$cpu_data.binary_attributes.cpu [0].processor_element_id.serial_number;

    #KEYPOINT (osk$exit, 0, pmk$get_binary_mainframe_id);

  PROCEND pmp$get_binary_mainframe_id;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_binary_processor_id', EJECT ??
*copy pmh$get_binary_processor_id

  PROCEDURE [XDCL, #GATE, INLINE] pmp$get_binary_processor_id
    (VAR processor_element_id: ost$processor_element_id;
     VAR status: ost$status);

    TYPE
      t$conversion_mask = RECORD
        CASE boolean OF
        = TRUE =
          integer_value: integer,
        = FALSE =
          element_id: ost$processor_element_id,
        CASEND,
      RECEND;

    VAR
      converter: t$conversion_mask;

    #KEYPOINT (osk$entry, 0, pmk$get_binary_processor_id);

    status.normal := TRUE;

    converter.integer_value := #READ_REGISTER (osc$pr_element_id);
    processor_element_id := converter.element_id;

    { The following is a kludge for the S0 model 50(16).  This model must be translated to model 52(16).

    IF processor_element_id.model_number = 50(16) THEN
      processor_element_id.model_number := osc$cyber_180_model_9303;
    IFEND;

    #KEYPOINT (osk$entry, 0, pmk$get_binary_processor_id);

  PROCEND pmp$get_binary_processor_id;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_cpu_attributes', EJECT ??
*copy pmh$get_cpu_attributes

  PROCEDURE [XDCL, #GATE] pmp$get_cpu_attributes
    (VAR cpu_attributes: pmt$cpu_attributes;
     VAR status: ost$status);

    VAR
      index: 0 .. osc$maximum_processor_number;

    #KEYPOINT (osk$entry, 0, pmk$get_cpu_attributes);

    status.normal := TRUE;
    cpu_attributes := pmv$cpu_data.attributes;

    FOR index := 0 TO pmv$cpu_data.attributes.highest_defined_cpu_number DO
      IF mtv$cst0 [index].processor_state = cmc$on THEN
        cpu_attributes.cpu [index].state := pmc$processor_state_on;
      ELSEIF mtv$cst0 [index].processor_state = cmc$off THEN
        cpu_attributes.cpu [index].state := pmc$processor_state_off;
      ELSE
        cpu_attributes.cpu [index].state := pmc$processor_state_down;
      IFEND;
    FOREND;

    #KEYPOINT (osk$exit, 0, pmk$get_cpu_attributes);

  PROCEND pmp$get_cpu_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_mainframe_attributes', EJECT ??
*copy pmh$get_mainframe_attributes

  PROCEDURE [XDCL, #GATE] pmp$get_mainframe_attributes
    (VAR mainframe_attributes: pmt$mainframe_attributes;
     VAR status: ost$status);

    VAR
      cpu_index: 0 .. osc$maximum_processor_number,
      global_processor_model_def: ost$processor_model_definition,
      index: integer,
      page_size: ost$page_size;

    status.normal := TRUE;
    osp$get_global_cpu_model_def (global_processor_model_def);

    FOR index := 1 TO UPPERBOUND (mainframe_attributes) DO
      CASE mainframe_attributes [index].key OF
      = pmc$mak_active_processors =
        mainframe_attributes [index].active_processors := 0;
        FOR cpu_index := 0 TO pmv$cpu_data.binary_attributes.highest_defined_cpu_number DO
          IF mtv$cst0 [cpu_index].processor_state = cmc$on THEN
            mainframe_attributes [index].active_processors :=
                  mainframe_attributes [index].active_processors + 1;
          IFEND;
        FOREND;

      = pmc$mak_microsecond_clock =
        mainframe_attributes [index].microsecond_clock := #FREE_RUNNING_CLOCK (0);

      = pmc$mak_mainframe_identifier =
        mainframe_attributes [index].mainframe_identifier := pmv$mainframe_id;

      = pmc$mak_page_size =
        pmp$get_page_size (page_size, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        mainframe_attributes [index].page_size := page_size;

      = pmc$mak_total_processors =
        mainframe_attributes [index].total_processors :=
              pmv$cpu_data.binary_attributes.highest_defined_cpu_number + 1;

      = pmc$mak_vector_capability =
        mainframe_attributes [index].vector_capability := global_processor_model_def.vector_capability;

      = pmc$mak_vectors_degraded =
        mainframe_attributes [index].vectors_degraded :=
              (mtv$scb.vector_simulation_control.vector_divide_degraded <> $ost$processor_id_set []) OR
              (global_processor_model_def.vector_capability = pmc$no_vectors);

      = pmc$mak_vector_simulation =
        mainframe_attributes [index].vector_simulation :=
              mtv$scb.vector_simulation_control.vector_simulation_attribute;

      = pmc$mak_null_attribute =

      ELSE
        osp$set_status_abnormal ('PM', pme$invalid_attribute_key, 'PMP$GET_MAINFRAME_ATTRIBUTES', status);
      CASEND;
    FOREND;

  PROCEND pmp$get_mainframe_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_mainframe_id', EJECT ??
*copy pmh$get_mainframe_id

  PROCEDURE [XDCL, #GATE] pmp$get_mainframe_id
    (VAR mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

    #KEYPOINT (osk$entry, 0, pmk$get_mainframe_id);

    status.normal := TRUE;

    mainframe_id := pmv$mainframe_id;

    #KEYPOINT (osk$exit, 0, pmk$get_mainframe_id);

  PROCEND pmp$get_mainframe_id;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_microsecond_clock', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_microsecond_clock
    (VAR microsecond: integer;
     VAR status: ost$status);

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, pmk$get_microsecond_clock);

    microsecond := #FREE_RUNNING_CLOCK (0);

    #KEYPOINT (osk$exit, 0, pmk$get_microsecond_clock);

  PROCEND pmp$get_microsecond_clock;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_os_build_level', EJECT ??
*copy pmh$get_os_build_level

  PROCEDURE [XDCL, #GATE] pmp$get_os_build_level
    (VAR build_level: pmt$os_name;
     VAR status: ost$status);

    #keypoint (osk$entry, 0, pmk$get_os_build_level);
    status.normal := TRUE;

    build_level := osv$build_level (1, pmc$os_name_size);
    #keypoint (osk$exit, 0, pmk$get_os_build_level);

  PROCEND pmp$get_os_build_level;
?? OLDTITLE ??
*IFEND
?? NEWTITLE := 'pmp$get_os_version', EJECT ??
*copy pmh$get_os_version

  PROCEDURE [XDCL, #GATE] pmp$get_os_version
    (VAR version: pmt$os_name;
     VAR status: ost$status);

    status.normal := TRUE;
*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, 0, pmk$get_os_version);
*IFEND

    version := osv$os_defaults_os_name;

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$exit, 0, pmk$get_os_version);
*IFEND

  PROCEND pmp$get_os_version;
*IF NOT $true(osv$unix)
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_page_size', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_page_size
    (VAR page_size: ost$page_size;
     VAR status: ost$status);

    { page size := (2**9) * (2**(u)) : u = number of right most 0's in 7 bit PSM register

    #KEYPOINT (osk$entry, 0, pmk$get_page_size);

    page_size := osc$min_page_size * (80(16) - #READ_REGISTER (osc$pr_page_size_mask));

    #KEYPOINT (osk$exit, 0, pmk$get_page_size);

  PROCEND pmp$get_page_size;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_processor_attributes', EJECT ??
*copy pmh$get_processor_attributes

  PROCEDURE [XDCL, #GATE] pmp$get_processor_attributes
    (VAR attributes: pmt$processor_attributes;
     VAR status: ost$status);

    VAR
      converter: RECORD
        CASE 0 .. 2 OF
        = 0 =
          intger: integer,
        = 1 =
          element_identifier: ost$processor_element_id,
        = 2 =
          packed_decimal: PACKED ARRAY [0 .. 15] OF 0 .. 0f(16),
        CASEND,
      RECEND,
      element_identifier: ost$processor_element_id;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, pmk$get_processor_attributes);

    converter.intger := #READ_REGISTER (osc$pr_element_id);
    element_identifier := converter.element_identifier;

    CASE (element_identifier.model_number DIV 10(16)) OF
    = 1 =
      attributes.model_number := pmc$cpu_model_p1;

    = 2 =
      attributes.model_number := pmc$cpu_model_p2;

    = 3 =
      attributes.model_number := pmc$cpu_model_p3;

    = 4 =
      attributes.model_number := pmc$cpu_model_p4;

    ELSE
      attributes.model_number := pmc$cpu_model_p2; {default}
    CASEND;

    attributes.serial_number := converter.packed_decimal [15] + (converter.packed_decimal [14] *
          10) + (converter.packed_decimal [13] * 100) + (converter.packed_decimal [12] * 1000);

    { page size := (2**9) * (2**(u)) : u = number of right most 0's in 7 bit PSM register

    attributes.page_size := osc$min_page_size * (128 - #READ_REGISTER (osc$pr_page_size_mask));

    #KEYPOINT (osk$exit, 0, pmk$get_processor_attributes);

  PROCEND pmp$get_processor_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_processor_id', EJECT ??
*copy pmh$get_processor_id

  PROCEDURE [XDCL, #GATE] pmp$get_processor_id
    (VAR model_type: pmt$processor_model_type;
     VAR model_number: pmt$processor_model_number;
     VAR serial_number: pmt$processor_serial_number;
     VAR status: ost$status);

    VAR
      cpu_index: 0 .. osc$maximum_processor_number,
      element_id: ost$processor_element_id;

    #KEYPOINT (osk$entry, 0, pmk$get_processor_id);

    status.normal := TRUE;

    pmp$get_binary_processor_id (element_id, status);
    FOR cpu_index := 0 TO osc$maximum_processor_number DO
      IF element_id = pmv$cpu_data.binary_attributes.cpu [cpu_index].processor_element_id THEN
        model_type := pmv$cpu_data.attributes.cpu [cpu_index].model_type;
        model_number := pmv$cpu_data.attributes.cpu [cpu_index].model_number;
        serial_number := pmv$cpu_data.attributes.cpu [cpu_index].serial_number;
      IFEND;
    FOREND;

    #KEYPOINT (osk$exit, 0, pmk$get_processor_id);

  PROCEND pmp$get_processor_id;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_pseudo_mainframe_id', EJECT ??

{ PURPOSE:
{   This procedure retrieves the binary representation of the value that uniquely
{   identifies the mainframe.  The pseudo binary model number is used.

  PROCEDURE [XDCL, #GATE] pmp$get_pseudo_mainframe_id
    (VAR mainframe_id: pmt$binary_mainframe_id);

    mainframe_id.model_number := pmv$cpu_data.pseudo_model_number [0];
    mainframe_id.serial_number := pmv$cpu_data.binary_attributes.cpu [0].processor_element_id.serial_number;

  PROCEND pmp$get_pseudo_mainframe_id;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_task_cp_time', EJECT ??
*copy pmh$get_task_cp_time

  PROCEDURE [XDCL, #GATE] pmp$get_task_cp_time
    (VAR cp_time: pmt$task_cp_time;
     VAR status: ost$status);

    VAR
      reqblk: tmt$rb_fetch_task_statistics;

    status.normal := TRUE;
    #KEYPOINT (osk$entry, 0, pmk$get_task_cp_time);

    reqblk.reqcode := syc$rc_fetch_task_statistics;
    i#call_monitor (#LOC (reqblk), #SIZE (reqblk));
    cp_time.monitor_time := reqblk.monitor_cptime;
    cp_time.task_time := reqblk.job_cptime;

    #KEYPOINT (osk$exit, 0, pmk$get_task_cp_time);

  PROCEND pmp$get_task_cp_time;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_task_jobmode_statistics', EJECT ??
*copy pmh$get_task_jobmode_statistics

{ NOTE: Any change made to this procedure should also be made to the procedure
{ PMP$GET_APD_TASK_JOBMODE_STATS.

  PROCEDURE [XDCL, #GATE, INLINE] pmp$get_task_jobmode_statistics
    (VAR jobmode_statistics: pmt$task_jobmode_statistics;
     VAR status: ost$status);

    VAR
      jobmode_cptime: integer,
      old_te: 0 .. 3,
      paging_statistics: ost$paging_statistics,
      xcb: ^ost$execution_control_block;

    status.normal := TRUE;

    i#disable_traps (old_te);
    pmp$find_executing_task_xcb (xcb);
    jobmode_cptime := xcb^.pit_count - #READ_REGISTER (osc$pr_process_interval_timer);
    paging_statistics := xcb^.paging_statistics;
    i#restore_traps (old_te);
    jobmode_statistics.jobmode_cptime := jobmode_cptime;
    jobmode_statistics.paging_statistics := paging_statistics;

  PROCEND pmp$get_task_jobmode_statistics;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$ready_task', EJECT ??
*copy pmh$ready_task

  PROCEDURE [XDCL, #GATE] pmp$ready_task
    (    task: ost$global_task_id;
     VAR status: ost$status);

    VAR
      ready_task: tmt$rb_ready_task;

    #KEYPOINT (osk$entry, (osk$m * ((task.index * 100(16)) + task.seqno)), pmk$ready_task);

    status.normal := TRUE;

    ready_task.reqcode := syc$rc_ready_task;
    ready_task.task_id := task;

    i#call_monitor (#LOC (ready_task), #SIZE (ready_task));

    IF NOT ready_task.status.normal THEN
      osp$set_status_condition (pme$unknown_recipient_task, status);
    IFEND;

    #KEYPOINT (osk$exit, 0, pmk$ready_task);

  PROCEND pmp$ready_task;
*IFEND
?? OLDTITLE ??
MODEND pmm$program_services;
*DECK DECK=PMM$PROGRAM_SERVICES_RING_1 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Program Management : Ring 1 Services' ??
MODULE pmm$program_services_ring_1;

{ PURPOSE:
{   This module contains the program-management ring 1 "service" interface procedures.

?? NEWTITLE := 'Global Declarations Referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_pageable
*copyc pmt$cpu_data
*copyc pmt$mainframe_id
?? POP ??
*copyc dsp$get_cpu_attributes
*copyc osp$get_cpu_model_definition
*copyc osp$get_global_cpu_model_def
?? OLDTITLE ??
?? NEWTITLE := 'Global Variables Declared in this Module', EJECT ??

  VAR
    pmv$cpu_data: [XDCL, #GATE, oss$mainframe_pageable] pmt$cpu_data,
    pmv$mainframe_id: [XDCL, #GATE, oss$mainframe_pageable] pmt$mainframe_id;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$initialize_cpu_attributes', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$initialize_cpu_attributes;

    CONST
      c$mainframe_id_prefix = '$SYSTEM_',
      c$mainframe_id_prefix_size = 8;

    TYPE
      t$serial_number_conversion = RECORD
        CASE boolean OF
        = TRUE =
          serial_number: ost$processor_serial_number,
        = FALSE =
          serial_number_array: PACKED ARRAY [1 .. pmc$processor_serial_num_size] OF 0 .. 0f(16),
        CASEND,
      RECEND;

    VAR
      converter: t$serial_number_conversion,
      cpu_attributes: dst$cpu_attributes,
      cpu_index: 0 .. osc$maximum_processor_number,
      definition_found: boolean,
      global_processor_model_def: ost$processor_model_definition,
      mainframe_id_index: 1 .. pmc$mainframe_id_size,
      model_number: pmt$processor_model_number,
      processor_model_definition: ost$processor_model_definition,
      search_data: ost$processor_search_data,
      serial_number: pmt$processor_serial_number,
      serial_number_index: 1 .. pmc$processor_serial_num_size;

?? NEWTITLE := 'change_space_to_zero', EJECT ??

    PROCEDURE change_space_to_zero
      (VAR data: string ( * ));

      VAR
        index: integer,
        length: integer;

      length := STRLENGTH (data);
      IF length > 0 THEN
        WHILE data (length) = ' ' DO
          FOR index := length DOWNTO 2 DO
            data (index) := data (index - 1);
          FOREND;
          data (1) := '0';
        WHILEND;
      IFEND;

    PROCEND change_space_to_zero;

?? OLDTITLE, EJECT ??

    dsp$get_cpu_attributes (cpu_attributes);
    osp$get_global_cpu_model_def (global_processor_model_def);

    pmv$cpu_data.binary_attributes.highest_defined_cpu_number := cpu_attributes.count - 1;
    pmv$cpu_data.attributes.highest_defined_cpu_number := cpu_attributes.count - 1;

    FOR cpu_index := 0 TO osc$maximum_processor_number DO

      { Assign values to the binary_attributes.  A kludge is needed to trap all S0 model numbers 50(16) and
      { 51(16).  They have to be translated into models 52(16) and 53(16) respectively.

      pmv$cpu_data.binary_attributes.cpu [cpu_index].processor_element_id :=
            cpu_attributes.cpu [cpu_index].element_id;
      IF pmv$cpu_data.binary_attributes.cpu [cpu_index].processor_element_id.model_number = 50(16) THEN
        pmv$cpu_data.binary_attributes.cpu [cpu_index].processor_element_id.model_number :=
               osc$cyber_180_model_9303;
      ELSEIF pmv$cpu_data.binary_attributes.cpu [cpu_index].processor_element_id.model_number = 51(16) THEN
        pmv$cpu_data.binary_attributes.cpu [cpu_index].processor_element_id.model_number :=
              osc$cyber_180_model_9301;
      IFEND;
      pmv$cpu_data.binary_attributes.cpu [cpu_index].processor_state := cpu_attributes.cpu [cpu_index].state;

      search_data.search_mode := osc$psm_by_real_model_number;
      search_data.real_model_number :=
            pmv$cpu_data.binary_attributes.cpu [cpu_index].processor_element_id.model_number;
      osp$get_cpu_model_definition (search_data, definition_found, processor_model_definition);
      pmv$cpu_data.pseudo_model_number [cpu_index] := processor_model_definition.pseudo_model_number;

      IF cpu_index < cpu_attributes.count THEN

        { Assign the processor model type.  The model type for all cpus is defined to be the same as the
        { global processor's model type.

        IF pmv$cpu_data.attributes.highest_defined_cpu_number > 0 THEN
          pmv$cpu_data.attributes.cpu [cpu_index].model_type :=
                global_processor_model_def.multiple_processor_model_type;
        ELSE
          pmv$cpu_data.attributes.cpu [cpu_index].model_type :=
                global_processor_model_def.processor_model_type;
        IFEND;

        { Assign the processor model number string.

        pmv$cpu_data.attributes.cpu [cpu_index].model_number :=
              global_processor_model_def.model_number_string;

        { Convert the integer serial number into a serial number string and convert the leading zeros to
        { blanks.

        converter.serial_number :=
              pmv$cpu_data.binary_attributes.cpu [cpu_index].processor_element_id.serial_number;
        FOR serial_number_index := 1 TO pmc$processor_serial_num_size DO
          pmv$cpu_data.attributes.cpu [cpu_index].serial_number (serial_number_index) :=
                $CHAR (converter.serial_number_array [serial_number_index] + $INTEGER ('0'));
        FOREND;
        WHILE pmv$cpu_data.attributes.cpu [cpu_index].serial_number (1) = '0' DO
          FOR serial_number_index := 1 TO pmc$processor_serial_num_size - 1 DO
            pmv$cpu_data.attributes.cpu [cpu_index].serial_number (serial_number_index) :=
                  pmv$cpu_data.attributes.cpu [cpu_index].serial_number (serial_number_index + 1);
          FOREND;
          pmv$cpu_data.attributes.cpu [cpu_index].serial_number (pmc$processor_serial_num_size) := ' ';
        WHILEND;

        { Retrieve the state of the processor.

        IF pmv$cpu_data.binary_attributes.cpu [cpu_index].processor_state = cmc$on THEN
          pmv$cpu_data.attributes.cpu [cpu_index].state := pmc$processor_state_on;
        ELSEIF pmv$cpu_data.binary_attributes.cpu [cpu_index].processor_state = cmc$off THEN
          pmv$cpu_data.attributes.cpu [cpu_index].state := pmc$processor_state_off;
        ELSE
          pmv$cpu_data.attributes.cpu [cpu_index].state := pmc$processor_state_down;
        IFEND;

      ELSE
        pmv$cpu_data.attributes.cpu [cpu_index].model_type := '';
        pmv$cpu_data.attributes.cpu [cpu_index].model_number := '';
        pmv$cpu_data.attributes.cpu [cpu_index].serial_number := '';
        pmv$cpu_data.attributes.cpu [cpu_index].state := '';
      IFEND;
    FOREND;

    serial_number := pmv$cpu_data.attributes.cpu [0].serial_number;
    model_number := pmv$cpu_data.attributes.cpu [0].model_number;
    change_space_to_zero (serial_number);
    change_space_to_zero (model_number);

    mainframe_id_index := 1;
    pmv$mainframe_id (mainframe_id_index, c$mainframe_id_prefix_size) := c$mainframe_id_prefix;
    mainframe_id_index := mainframe_id_index + c$mainframe_id_prefix_size;
    pmv$mainframe_id (mainframe_id_index, pmc$processor_model_number_size) := model_number;
    mainframe_id_index := mainframe_id_index + pmc$processor_model_number_size;
    pmv$mainframe_id (mainframe_id_index, 1) := '_';
    mainframe_id_index := mainframe_id_index + 1;
    pmv$mainframe_id (mainframe_id_index, pmc$processor_serial_num_size) := serial_number;

  PROCEND pmp$initialize_cpu_attributes;
?? OLDTITLE ??
MODEND pmm$program_services_ring_1;
*DECK DECK=PMM$PROGRAM_STATE_PROCESSOR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Program Management - VX/VE program state processor' ??
MODULE pmm$program_state_processor;

{ PURPOSE:
{   This module contains the routines necessary to support the VX/VE Fork.
{
{ DESIGN:
{   The procedures in this module execute in the ring of the caller (2DD).

?? NEWTITLE := 'Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc lot$loader_type_definitions
*copyc osd$virtual_address
*copyc ost$caller_identifier
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc pmc$program_management_id
*copyc pmd$program_state
*copyc pme$program_state_exceptions
?? POP ??
*copyc i#current_sequence_position
*copyc i#move
*copyc mmp$get_segment_length
*copyc mmp$preset_page_streaming
*copyc osp$set_status_condition
*copyc lov$allocated_segments
*copyc lov$highest_segment_index
*copyc pmk$keypoints
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$restore_program_state', EJECT ??
*copyc pmh$restore_program_state

  PROCEDURE [XDCL, #GATE] pmp$restore_program_state
    (    p_state_container: ^SEQ ( * );
         p_parameter: ^cell;
         parameter_length: 0 .. 0ffff(16);
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      container_p: ^SEQ ( * ),
      directory_p: ^pmt$segment_directory,
      ring: ost$valid_ring,
      save_area_p: ^cell,
      segment_count: pmt$segment_count,
      segment_length: ^array [ * ] of ost$segment_length,
      stack_expansion: integer,
      stack_expansion_p: ^SEQ ( * );

    #keypoint (osk$entry, 0, pmk$restore_program_state);
    #CALLER_ID (caller_id);
    container_p := p_state_container;

    ring := #RING (container_p);
    IF (caller_id.ring > ring) THEN
      ring := caller_id.ring;
    IFEND;
    validate_program_write (ring, lov$allocated_segments, lov$highest_segment_index, status);

    IF status.normal THEN
      validate_program_state (container_p, save_area_p, directory_p, status);
    IFEND;

    IF status.normal THEN
      segment_count := lov$highest_segment_index - LOWERBOUND (lov$allocated_segments^) + 1;
      PUSH segment_length: [1 .. segment_count];
      verify_program_identity (lov$allocated_segments, lov$highest_segment_index, directory_p, segment_count,
            segment_length, status);
    IFEND;

    IF status.normal THEN
      get_stack_expansion (directory_p, stack_expansion);
      IF (stack_expansion > 0) THEN
        PUSH stack_expansion_p: [[REP stack_expansion OF cell]];
      IFEND;
      restore_segment_info (directory_p, container_p, save_area_p, p_parameter, parameter_length,
            segment_count, segment_length);
    IFEND;
    #keypoint (osk$exit, 0, pmk$restore_program_state);
  PROCEND pmp$restore_program_state;
?? OLDTITLE ??
?? NEWTITLE := '[XDLC, #GATE] pmp$save_program_state', EJECT ??
*copyc pmh$save_program_state

  PROCEDURE [XDCL, #GATE] pmp$save_program_state
    (VAR p_state_container: ^SEQ ( * );
     VAR original_program: boolean;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      container_p: ^SEQ ( * ),
      program_state_p: ^pmt$program_state,
      ring: ost$valid_ring;

    #keypoint (osk$entry, 0, pmk$save_program_state);
    #CALLER_ID (caller_id);
    status.normal := TRUE;
    original_program := FALSE;
    container_p := p_state_container;

    ring := #RING (container_p);
    IF (caller_id.ring > ring) THEN
      ring := caller_id.ring;
    IFEND;
    validate_program_read (ring, lov$allocated_segments, lov$highest_segment_index, status);

    IF status.normal THEN
      NEXT program_state_p IN container_p;
      IF (program_state_p = NIL) THEN
        osp$set_status_condition (pme$state_container_full, status);
      ELSE
        program_state_p^.p_save_area := #PREVIOUS_SAVE_AREA ();
        program_state_p^.segment_count := lov$highest_segment_index - LOWERBOUND (lov$allocated_segments^) +
              1;
        save_segment_info (lov$allocated_segments, program_state_p^.segment_count, container_p, status);
      IFEND;
    IFEND;

    original_program := TRUE;
    IF status.normal THEN
      p_state_container := container_p;
    IFEND;
    #keypoint (osk$exit, 0, pmk$save_program_state);
  PROCEND pmp$save_program_state;
?? OLDTITLE ??
?? NEWTITLE := 'get_stack_expansion', EJECT ??

  PROCEDURE get_stack_expansion
    (    directory_p: ^pmt$segment_directory;
     VAR stack_expansion: integer);

    VAR
      directory_index: ost$segment,
      save_area_p: ^cell,
      stack_segment: ost$segment;

    save_area_p := #PREVIOUS_SAVE_AREA ();
    stack_segment := #SEGMENT (save_area_p);
    FOR directory_index := 1 TO UPPERBOUND (directory_p^) DO
      IF (stack_segment = directory_p^ [directory_index].segment_allocation.segment) THEN
        stack_expansion := directory_p^ [directory_index].saved_length - #OFFSET (save_area_p);
        RETURN;
      IFEND;
    FOREND;
    stack_expansion := 0;
  PROCEND get_stack_expansion;
?? OLDTITLE ??
?? NEWTITLE := 'move_bytes', EJECT ??

{ PURPOSE:
{   This procedure will move data from the source to the destination address.

  PROCEDURE move_bytes
    (    source_p: ^cell;
         destination_p: ^cell;
         length: 0 .. 7fffffff(16));

    CONST
      maximum_nonstreamed_size = 65536,
      prestreaming_transfer_size = 65536;

    VAR
      destination_free_behind: boolean,
      destination_status_p: ^ost$status,
      destination_transfer_size: 0 .. 15,
      source_free_behind: boolean,
      source_status_p: ^ost$status,
      source_transfer_size: 0 .. 15;

    IF length > maximum_nonstreamed_size THEN
      PUSH source_status_p;
      PUSH destination_status_p;
      mmp$preset_page_streaming ({ preset_and_save_ts_fb } TRUE, source_p, prestreaming_transfer_size,
            source_transfer_size, source_free_behind, source_status_p^);
      mmp$preset_page_streaming ({ preset_and_save_ts_fb } TRUE, destination_p, prestreaming_transfer_size,
            destination_transfer_size, destination_free_behind, destination_status_p^);
    IFEND;

    i#move (source_p, destination_p, length);

    IF length > maximum_nonstreamed_size THEN
      IF source_status_p^.normal THEN
        mmp$preset_page_streaming ({ preset_and_save_ts_fb } FALSE, source_p, prestreaming_transfer_size,
              source_transfer_size, source_free_behind, source_status_p^);
      IFEND;
      IF destination_status_p^.normal THEN
        mmp$preset_page_streaming ({ preset_and_save_ts_fb } FALSE, destination_p, prestreaming_transfer_size,
              destination_transfer_size, destination_free_behind, destination_status_p^);
      IFEND;
    IFEND;
  PROCEND move_bytes;
?? OLDTITLE ??
?? NEWTITLE := 'restore_segment', EJECT ??

  PROCEDURE restore_segment
    (    segment: ost$segment;
         ring: ost$valid_ring;
     VAR saved_segment_p: ^SEQ ( * );
         parameter_p: ^cell;
         parameter_length: 0 .. 0ffff(16));

    VAR
      destination_p: ^cell,
      first_length: integer,
      last_length: integer,
      source_p: ^SEQ ( * ),
      parameter: boolean,
      segment_length: ost$segment_length;

    destination_p := #ADDRESS (ring, segment, 0);
    segment_length := #SIZE (saved_segment_p^);
    parameter := (parameter_p <> NIL) AND (parameter_length > 0) AND (segment = #SEGMENT (parameter_p));
    IF parameter THEN
      first_length := #OFFSET (parameter_p);
      last_length := segment_length - first_length - parameter_length;
      RESET saved_segment_p;
      IF (first_length > 0) THEN
        NEXT source_p: [[REP first_length OF cell]] IN saved_segment_p;
        move_bytes (#LOC (source_p^), destination_p, first_length);
      IFEND;
      IF (last_length > 0) THEN
        NEXT source_p: [[REP parameter_length OF cell]] IN saved_segment_p;
        NEXT source_p: [[REP last_length OF cell]] IN saved_segment_p;
        destination_p := #ADDRESS (ring, segment, first_length + parameter_length);
        move_bytes (#LOC (source_p^), destination_p, last_length);
      IFEND;
    ELSE
      move_bytes (#LOC (saved_segment_p^), destination_p, segment_length);
    IFEND;
  PROCEND restore_segment;
?? OLDTITLE ??
?? NEWTITLE := 'restore_segment_info', EJECT ??

  PROCEDURE restore_segment_info
    (    directory_p: ^pmt$segment_directory;
         state_container_p: ^SEQ ( * );
         save_area_p: ^cell;
         parameter_p: ^cell;
         parameter_length: 0 .. 0ffff(16);
         segment_count: pmt$segment_count;
         segment_length: ^array [ * ] of ost$segment_length);

    VAR
      container_p: ^SEQ ( * ),
      directory_entry: pmt$segment_directory_entry,
      directory_index: ost$segment,
      ring: ost$valid_ring,
      saved_length: ost$segment_length,
      saved_segment_p: ^SEQ ( * ),
      segment: ost$segment,
      segment_allocation: lot$segment_allocation,
      temp_directory_p: ^pmt$segment_directory, { these temp variables are used so that the values get
      temp_save_area_p: ^cell, { copied into the procedure so they do not get overwritten
      temp_parameter_p: ^cell, { when the stack segment gets restored.
      temparameter_p_length: 0 .. 0ffff(16),
      temp_segment_count: pmt$segment_count,
      temp_segment_length: ^array [ * ] of ost$segment_length,
      writable_segment: boolean;

    temp_directory_p := directory_p;
    temp_save_area_p := save_area_p;
    temp_parameter_p := parameter_p;
    temparameter_p_length := parameter_length;
    temp_segment_count := segment_count;
    PUSH temp_segment_length: [1 .. temp_segment_count];
    temp_segment_length^ := segment_length^;
    container_p := state_container_p;
    set_save_area (NIL);
    FOR directory_index := 1 TO temp_segment_count DO
      directory_entry := temp_directory_p^ [directory_index];
      segment_allocation := directory_entry.segment_allocation;
      writable_segment := (segment_allocation.attributes.access_control.write_privilege <> osc$non_writable);
      saved_length := temp_segment_length^ [directory_index];
      IF (writable_segment AND (saved_length > 0)) THEN
        segment := segment_allocation.segment;
        ring := segment_allocation.attributes.r1;
        RESET container_p TO temp_directory_p;
        NEXT saved_segment_p: [[REP directory_entry.segment_offset OF cell]] IN container_p;
        NEXT saved_segment_p: [[REP saved_length OF cell]] IN container_p;
        restore_segment (segment, ring, saved_segment_p, temp_parameter_p, temparameter_p_length);
      IFEND;
    FOREND;
    set_save_area (temp_save_area_p);
  PROCEND restore_segment_info;
?? OLDTITLE ??
?? NEWTITLE := 'save_segment_info', EJECT ??

  PROCEDURE save_segment_info
    (    allocated_segments_p: ^array [ * ] of lot$segment_allocation;
         segment_count: pmt$segment_count;
     VAR container_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      directory_offset: ost$segment_length,
      directory_p: ^pmt$segment_directory,
      directory_index: ost$segment,
      index_offset: integer,
      segment_allocation: lot$segment_allocation,
      saved_length: ost$segment_length,
      segment_p: ^cell,
      saved_segment_p: ^SEQ ( * );

    status.normal := TRUE;
    index_offset := LOWERBOUND (allocated_segments_p^) - 1;
    directory_offset := i#current_sequence_position (container_p);

    NEXT directory_p: [1 .. segment_count] IN container_p;
    IF (directory_p = NIL) THEN
      osp$set_status_condition (pme$state_container_full, status);
      RETURN;
    IFEND;

    FOR directory_index := 1 TO segment_count DO
      segment_allocation := allocated_segments_p^ [directory_index + index_offset];
      segment_p := #ADDRESS (segment_allocation.attributes.r2, segment_allocation.segment, 0);
      IF (segment_allocation.attributes.access_control.write_privilege = osc$non_writable) THEN
        saved_length := 0;
      ELSEIF (segment_allocation.attributes.extensible OR segment_allocation.attributes.stack) THEN
        mmp$get_segment_length (segment_p, segment_allocation.attributes.r2, saved_length, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        saved_length := segment_allocation.current_length;
      IFEND;

      directory_p^ [directory_index].segment_allocation := segment_allocation;
      directory_p^ [directory_index].saved_length := saved_length;
      IF (saved_length = 0) THEN
        directory_p^ [directory_index].segment_offset := 0;
      ELSE
        directory_p^ [directory_index].segment_offset := i#current_sequence_position (container_p) -
              directory_offset;
        NEXT saved_segment_p: [[REP saved_length OF cell]] IN container_p;
        IF (saved_segment_p = NIL) THEN
          osp$set_status_condition (pme$state_container_full, status);
          RETURN;
        IFEND;
        move_bytes (segment_p, #LOC (saved_segment_p^), saved_length);
      IFEND;
    FOREND;
  PROCEND save_segment_info;
?? OLDTITLE ??
?? NEWTITLE := 'set_save_area', EJECT ??

  PROCEDURE set_save_area
    (    save_area_p: ^cell);

    VAR
      caller_p_save_area: ^ost$minimum_save_area;

    caller_p_save_area := #PREVIOUS_SAVE_AREA ();
    caller_p_save_area^.a2_previous_save_area := save_area_p;
  PROCEND set_save_area;
?? OLDTITLE ??
?? NEWTITLE := 'validate_program_read', EJECT ??

  PROCEDURE validate_program_read
    (    ring: ost$valid_ring;
         allocated_segments_p: ^array [ * ] of lot$segment_allocation;
         highest_segment_index: lot$allocated_segments_index;
     VAR status: ost$status);

    VAR
      index: lot$allocated_segments_index;

    status.normal := TRUE;
    IF (allocated_segments_p <> NIL) THEN
      FOR index := LOWERBOUND (allocated_segments_p^) TO highest_segment_index DO
        IF (ring > allocated_segments_p^ [index].attributes.r2) AND
              (allocated_segments_p^ [index].attributes.access_control.write_privilege <> osc$non_writable)
              THEN
          osp$set_status_condition (pme$unreadable_program_state, status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;
  PROCEND validate_program_read;
?? OLDTITLE ??
?? NEWTITLE := 'validate_program_state', EJECT ??

  PROCEDURE validate_program_state
    (VAR container_p: ^SEQ ( * );
     VAR save_area_p: ^cell;
     VAR directory_p: ^pmt$segment_directory;
     VAR status: ost$status);

    VAR
      program_state_p: ^pmt$program_state,
      saved_segment_p: ^SEQ ( * ),
      directory_index: ost$segment,
      saved_length: ost$segment_length,
      segment_offset: ost$segment_length;

    status.normal := TRUE;
    NEXT program_state_p IN container_p;
    IF (program_state_p = NIL) THEN
      osp$set_status_condition (pme$invalid_program_state, status);
      RETURN;
    IFEND;
    save_area_p := program_state_p^.p_save_area;

    NEXT directory_p: [1 .. program_state_p^.segment_count] IN container_p;
    IF (directory_p = NIL) THEN
      osp$set_status_condition (pme$invalid_program_state, status);
      RETURN;
    IFEND;

    FOR directory_index := 1 TO UPPERBOUND (directory_p^) DO
      saved_length := directory_p^ [directory_index].saved_length;
      IF (saved_length > 0) THEN
        segment_offset := directory_p^ [directory_index].segment_offset;
        RESET container_p TO directory_p;
        NEXT saved_segment_p: [[REP (segment_offset + saved_length) OF cell]] IN container_p;
        IF (saved_segment_p = NIL) THEN
          osp$set_status_condition (pme$invalid_program_state, status);
          RETURN;
        IFEND;
      IFEND;
    FOREND;
  PROCEND validate_program_state;
?? OLDTITLE ??
?? NEWTITLE := 'validate_program_write', EJECT ??

  PROCEDURE validate_program_write
    (    ring: ost$valid_ring;
         allocated_segments_p: ^array [ * ] of lot$segment_allocation;
         highest_segment_index: lot$allocated_segments_index;
     VAR status: ost$status);

    VAR
      index: lot$allocated_segments_index;

    status.normal := TRUE;
    IF (allocated_segments_p <> NIL) THEN
      FOR index := LOWERBOUND (allocated_segments_p^) TO highest_segment_index DO
        IF (ring > allocated_segments_p^ [index].attributes.r1) AND
              (allocated_segments_p^ [index].attributes.access_control.write_privilege <> osc$non_writable)
              THEN
          osp$set_status_condition (pme$unwritable_program_state, status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;
  PROCEND validate_program_write;
?? OLDTITLE ??
?? NEWTITLE := 'verify_program_identity', EJECT ??

  PROCEDURE verify_program_identity
    (    allocated_segments_p: ^array [ * ] of lot$segment_allocation;
         highest_segment_index: lot$allocated_segments_index;
         directory_p: ^pmt$segment_directory;
         segment_count: pmt$segment_count;
     VAR segment_length: ^array [ * ] of ost$segment_length;
     VAR status: ost$status);

    VAR
      directory_index: ost$segment,
      index_offset: integer;

    status.normal := TRUE;
    IF (segment_count > UPPERBOUND (directory_p^)) THEN
      osp$set_status_condition (pme$program_mismatch, status);
      RETURN;
    IFEND;
    index_offset := LOWERBOUND (allocated_segments_p^) - 1;
    FOR directory_index := 1 TO segment_count DO
      IF ((directory_p^ [directory_index].segment_allocation.attributes <>
            allocated_segments_p^ [directory_index + index_offset].attributes) OR
            (directory_p^ [directory_index].segment_allocation.segment <>
            allocated_segments_p^ [directory_index + index_offset].segment) OR
            (directory_p^ [directory_index].segment_allocation.current_length <
            allocated_segments_p^ [directory_index + index_offset].current_length) OR
            (directory_p^ [directory_index].segment_allocation.maximum_length <>
            allocated_segments_p^ [directory_index + index_offset].maximum_length)) THEN
        osp$set_status_condition (pme$program_mismatch, status);
        RETURN;
      IFEND;

      IF ((directory_p^ [directory_index].segment_allocation.attributes.extensible) OR
            (directory_p^ [directory_index].segment_allocation.attributes.stack)) THEN
        segment_length^ [directory_index] := directory_p^ [directory_index].saved_length;
      ELSE
        segment_length^ [directory_index] := allocated_segments_p^ [directory_index +
              index_offset].current_length;
      IFEND;
    FOREND;
  PROCEND verify_program_identity;
?? OLDTITLE ??
MODEND pmm$program_state_processor;
*DECK DECK=PMM$RECEIVE_FROM_QUEUE EXPAND=TRUE
?? SET (LISTCTS := OFF) ??
?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
?? NEWTITLE := 'NOS/VE: Program Control - Job Local Queues' ??
?? NEWTITLE := '  Global System Declarations' ??
MODULE pmm$receive_from_queue;
{   PURPOSE:
{    The purpose of this module is to support pmp$receive_from_queue.  The
{    module serves as screen in the processing of interactive conditions.

{   DESIGN:
{     The procedure contained in this module has an execution bracket of 1, 13.
?? EJECT ??
?? SET (LIST := OFF) ??
*copyc OST$STATUS
*copyc OST$WAIT
*copyc PMK$KEYPOINTS

?? SET (LIST := ON) ??

*copyc PMD$LOCAL_QUEUES
?? TITLE := '  Global External Procedures' ??
?? EJECT ??

*copyc PMH$RECEIVE_QUEUE_MESSAGE
*copyc PMP$RECEIVE_QUEUE_MESSAGE
?? TITLE := '  [XDCL, #gate] pmp$receive_from_queue' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$receive_from_queue (qid: pmt$queue_connection;
        wait: ost$wait;
    VAR message: pmt$message;
    VAR status: ost$status);
*copyc PMH$RECEIVE_FROM_QUEUE

    VAR
      receive_complete: boolean;

    status.normal := TRUE;
    #INLINE ('keypoint', osk$entry, 0, pmk$receive_from_queue);
    receive_complete := FALSE;
    REPEAT
      pmp$receive_queue_message (qid, wait, message, receive_complete, status);
    UNTIL receive_complete OR NOT status.normal;
    #INLINE ('keypoint', osk$exit, 0, pmk$receive_from_queue);
  PROCEND pmp$receive_from_queue;
MODEND pmm$receive_from_queue;
*DECK DECK=PMM$RUNANYWHERE_PRG_SERVICES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE: Program Management - Run-anywhere Program Services' ??
?? NEWTITLE := 'Global System Declarations' ??
MODULE pmm$runanywhere_prg_services;


{   PURPOSE:
{     This module contains procedures to process the following requests:
{       pmp$cycle
{       pmp$delay
{       syp$wait
{

{   DESIGN:
{     The procedures contained in the module are designed to execute with an
{     execute bracket of 1, 13 and a call bracket of 13.
{
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PMK$KEYPOINTS
*copyc TMT$RB_DELAY
*copyc TMT$RB_CYCLE
*copyc SYC$MONITOR_REQUEST_CODES
?? POP ??
?? TITLE := 'External Procedures' ??
?? EJECT ??
*copyc I#CALL_MONITOR
?? TITLE := '  [XDCL, #gate] pmp$delay' ??
  ?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$delay (milliseconds: integer;
    VAR status: ost$status);

*copyc PMH$DELAY

    CONST
      max_delay_time = 0ffffffffffff(16);

    VAR
      delay_time: integer,
      end_time: integer,
      delay: tmt$rb_delay;

    #KEYPOINT (osk$entry, 0, pmk$delay);

    status.normal := TRUE;
    delay_time := milliseconds * 1000;
    end_time := delay_time + #free_running_clock(0);
    IF end_time > max_delay_time THEN
      end_time := max_delay_time;
      IF delay_time > max_delay_time THEN
        delay_time := max_delay_time;
      IFEND;
    IFEND;

    delay.reqcode := syc$rc_delay;
    delay.expected_wait_time := delay_time;
    delay.requested_wait_time := end_time;

    WHILE (#free_running_clock (0) < delay.requested_wait_time) DO
      i#call_monitor (#LOC (delay), #SIZE (delay));
    WHILEND;

    #KEYPOINT (osk$exit, 0, pmk$delay);

  PROCEND pmp$delay;
?? TITLE := '  [XDCL, #gate] pmp$cycle' ??
  ?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$cycle (VAR status: ost$status);

*copyc PMH$CYCLE

TYPE
    psa_type = record
      fill: 0 .. 0ffff(16),
      p: ^cell,
      a0,a1: integer,
      fill2: 0 .. 0ffff(16),
      a2: ^psa_type,
    recend;

    VAR
      psa: ^psa_type,
      cycle_task: tmt$rb_cycle;

    #KEYPOINT (osk$exit, 0, pmk$cycle);

    status.normal := TRUE;
    cycle_task.reqcode := syc$rc_cycle;
    cycle_task.code := tmc$cyc_cycle_request;
    psa := #previous_save_area();
    cycle_task.p1 := psa^.p;
    IF psa^.a2 = NIL THEN
      cycle_task.p2 := NIL;
    ELSE
      cycle_task.p2 := psa^.a2^.p;
    IFEND;
    cycle_task.lock_value := 0;
    i#call_monitor (#LOC (cycle_task), #SIZE (cycle_task));

    #KEYPOINT (osk$exit, 0, pmk$cycle);

  PROCEND pmp$cycle;
?? TITLE := '  [XDCL, #gate] syp$wait' ??
  ?? EJECT ??

  PROCEDURE [XDCL, #GATE] syp$wait (milliseconds: 0..0ffffffffffff(16));

*copyc SYH$WAIT

    CONST
      max_wait_time = 0ffffffffffff(16);

    VAR
      end_time: integer,
      rb: tmt$rb_delay,
      wait_time: integer;

    wait_time := milliseconds * 1000;
    end_time := wait_time + #free_running_clock(0);
    IF end_time > max_wait_time THEN
      end_time := max_wait_time;
      IF wait_time > max_wait_time THEN
        wait_time := max_wait_time;
      IFEND;
    IFEND;

    rb.reqcode := syc$rc_delay;
    rb.expected_wait_time := wait_time;
    rb.requested_wait_time := end_time;

    i#call_monitor (#LOC (rb), #SIZE (rb));

  PROCEND syp$wait;
MODEND pmm$runanywhere_prg_services;
*DECK DECK=PMM$SET_OPERATION_INTERVAL_PD EXPAND=TRUE
create_program_description name=(set_operation_interval, setoi) ..
      starting_procedure=pmp$_set_operation_interval log_option=manual ..
      library=osf$current_library termination_error_level=warning ..
      load_map_options=none load_map=$null debug_mode=off
*DECK DECK=PMM$SET_OPERATION_PASSWORD_PD EXPAND=TRUE
create_program_description name=(set_operation_password, setop) ..
      starting_procedure=pmp$_set_operation_password log_option=manual ..
      library=osf$current_library termination_error_level=warning ..
      load_map_options=none load_map=$null debug_mode=off
*DECK DECK=PMM$SET_SPY_IDENTIFIER EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
?? RIGHT := 110 ??
??
NEWTITLE := 'Global Declarations', EJECT ??
MODULE pmm$set_spy_identifier;




  { Purpose: This module contains the program management routine for setting
  { the spy identifier PMV$SPY_IDENTIFIER.




  { *callc pmdsi }
  { *callc pmdpser }

  { *callc osdtps }
  { *callc osxssa }
?? PUSH (LISTEXT := ON) ??
*copyc PMT$SPY_IDENTIFIERS
*copyc PME$PROGRAM_SERVICES_EXCEPTIONS

*copyc OSS$TASK_SHARED
*copyc OSP$SET_STATUS_ABNORMAL
?? POP ??


  VAR
    pmv$spy_identifiers: [XDCL, oss$task_shared] pmt$spy_identifiers := [0, 0];


?? OLDTITLE ??
?? NEWTITLE := 'PMP$SET_SPY_IDENTIFIER', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$set_spy_identifier (low_identifier: pmt$spy_identifier;
        high_identifier: pmt$spy_identifier;
    VAR status: ost$status);


    status.normal := TRUE;

    IF (low_identifier > UPPERVALUE (pmt$spy_identifier)) OR
       (high_identifier > UPPERVALUE (pmt$spy_identifier)) THEN
      osp$set_status_abnormal ('PM', pme$invalid_spy_identifier, '', status);
      RETURN;
    IFEND;

    pmv$spy_identifiers.low_identifier := low_identifier;
    pmv$spy_identifiers.high_identifier := high_identifier;


  PROCEND pmp$set_spy_identifier;
?? OLDTITLE ??




MODEND pmm$set_spy_identifier.
*DECK DECK=PMM$STACK_FRAME_POPPER EXPAND=TRUE
 ?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Program Management: Stack Frame Popper', ??
?? NEWTITLE := '  PMM$STACK_FRAME_POPPER' ??
MODULE pmm$stack_frame_popper;

{  PURPOSE:
{    This module contains procedures which attempt to pop all outstanding stack frames at
{    program termination.  The purpose of this is to activate any established block_exit
{    condition handlers.
{  DESIGN:
{    Since CYBIL does not support the POP instruction, the actual popping of stack frames
{    does not occur in this module.  However, in order to minimize the amount of code
{    written in assembly language, most of the work of the stack frame popper is carried
{    out by procedures in this module.  The activities undertaken by this module include:
{
{        - Initiating block_exit condition handlers in a controlled environment.
{
{        - Managing ring_crossings within the stack frame thread.
{
{        - Detecting conditions which indicate that the stack has been destroyed.

?? NEWTITLE := '    Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_map_offsets
*copyc OSS$JOB_PAGED_LITERAL
*copyc OSC$PROCESSOR_DEFINED_REGISTERS
*copyc PME$EXECUTION_EXCEPTIONS
*copyc PMK$KEYPOINTS
?? POP ??
*copyc OSP$SET_STATUS_ABNORMAL
*copyc osp$set_status_condition
*copyc OSP$SET_STATUS_FROM_CONDITION
*copyc osp$generate_log_message
*copyc I#PTR
*copyc i#enable_traps
*copyc PMP$DISESTABLISH_COND_HANDLER
*copyc PMP$ESTABLISH_CONDITION_HANDLER
*copyc PMP$ESTABLISH_CH_IN_BLOCK
*copyc PMP$CONTINUE_TO_CAUSE
*copyc PMP$EXIT
*copyc PMP$TASK_DEBUG_MODE_ON
*copyc PMP$DEBUG_ABORT_FILE_SPECIFIED
*copyc PMP$TASK_DEBUG_RING
*copyc PMP$END_DEBUG_SHOULD_BE_CALLED
*copyc PMP$CALL_END_DEBUG
*copyc PMP$FIND_STACK_SEGMENT
*copyc PMP$BUILD_OUTWARD_CALL_SFSA
*copyc PMP$RETURN_TO_OUTWARD_CALL_SFSA
*copyc PMP$CALL_RING_CROSSING_PROC
*copyc PMP$RING_CROSSING_PROC_RETURN
*copyc PMP$RING_CROSSING_PROCEDURE
*copyc pmp$rtn_to_outwrd_call_sfsa_sff
*copyc pmp$set_task_execution_phase
*copyc PMP$POP_3_STACK_FRAMES

  TYPE
    pmt$established_handler_pair = record
      error: pmt$established_handler,
      block_exit: pmt$established_handler,
    recend;


  VAR
    error_conditions: [STATIC, READ, oss$job_paged_literal] pmt$condition := [pmc$condition_combination,
      $pmt$condition_combination [pmc$system_conditions, mmc$segment_access_condition,
      pmc$user_defined_condition]];

?? TITLE := '    PMP$POP_ALL_STACK_FRAMES', EJECT ??

  PROCEDURE [XDCL] pmp$pop_all_stack_frames;

{  PURPOSE:
{    This procedure initiates the process of popping all stack frames.  If called in or
{    above the debug_ring and debug_mode is active, then the termination procedure of the
{    debug facility is called.

    VAR
      end_debug_should_be_called: boolean,
      established_handler: pmt$established_handler,
      local_status: ost$status;

    #KEYPOINT (osk$entry, 0, pmk$pop_all_stack_frames);

    pmp$establish_condition_handler (error_conditions, ^error_condition_handler, ^established_handler,
          local_status);
    IF NOT local_status.normal THEN {stack is destroyed}
      pmp$terminate_popper (local_status);
    IFEND;

    pmp$end_debug_should_be_called (end_debug_should_be_called);

    IF end_debug_should_be_called THEN
      pmp$call_end_debug;
    IFEND;

    pmp$set_task_execution_phase (pmc$task_popping_stack_frames);

    pmp$intra_ring_popper (NIL);

  PROCEND pmp$pop_all_stack_frames;


?? TITLE := '    PMP$INTRA_RING_POPPER', EJECT ??

  PROCEDURE [XDCL] pmp$intra_ring_popper (established_handler_pair: ^pmt$established_handler_pair);

{  PURPOSE:
{    This procedure is responsible for directing the process of popping all stack frames
{    within a ring and performing an outward call to the ring_crossing_popper when a
{    ring crossing is detected.  The primary functions of intra_ring popping are to provide
{    controlled activation of block_exit condition handlers and to detect stack frame
{    inconsistencies which block further popping activity.
{  NOTE:
{    This procedure and PMP$POP_3_STACK_FRAMES operate as coroutines which POP all of
{    the stack frames in the ring in which they are activated.  The intra_ring_popper
{    is partitioned into coroutines in order to minimize the amount of code written
{    in assembley language.

    CONST
      minimum_stack_frame_size = 8;

    VAR
      converter: record
        case 0 .. 1 of
        = 0 =
          pointer_to_procedure: ^procedure,
        = 1 =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend,

      established_handler: pmt$established_handler,
      of_execution: cell,
      block_exit_condition: pmt$condition,
      target_sfsa: ^ost$stack_frame_save_area,
      preceding_sfsa: ^ost$stack_frame_save_area,
      ring_crossing_procedure_pva: ^cell,
      ring_crossing_return_pva: ^cell,
      stack_segment: ^pmt$stack_segment,
      popper_cbp: ^ost$external_code_base_pointer,
      popper_sfsa: ^ost$stack_frame_save_area,
      trap_enables: 0 .. 3,
      local_status: ost$status;

?? EJECT ??
    target_sfsa := #previous_save_area ();
    converter.pointer_to_procedure := ^pmp$call_ring_crossing_proc;
    ring_crossing_procedure_pva := converter.code_base_pointer^.code_pva;
    converter.pointer_to_procedure := ^pmp$ring_crossing_proc_return;
    ring_crossing_return_pva := converter.code_base_pointer^.code_pva;

{ If the target frame to pop is a user's frame, a condition handler to catch
{ system conditions is necessary.  If we let things fall to the default handler
{ it will call pmp$abort and an infinite loop will occur.

    IF established_handler_pair <> NIL THEN
      pmp$establish_ch_in_block (error_conditions, ^error_condition_handler, target_sfsa,
            ^established_handler_pair^.error, local_status);
      IF NOT local_status.normal THEN {stack is destroyed}
        pmp$terminate_popper (local_status);
      IFEND;
    ELSE
      pmp$establish_condition_handler (error_conditions, ^error_condition_handler, ^established_handler,
          local_status);
      IF NOT local_status.normal THEN {stack is destroyed}
        pmp$terminate_popper (local_status);
      IFEND;
    IFEND;

{ Are we about to pop original caller??

    preceding_sfsa := target_sfsa^.minimum_save_area.a2_previous_save_area;
    IF preceding_sfsa = NIL THEN
      local_status.normal := TRUE;
      pmp$terminate_popper (local_status);

    ELSE
{     IF target_sfsa^.minimum_save_area.frame_descriptor.critical_frame_flag THEN
{       block_exit_condition.selector := pmc$block_exit_processing;
{       block_exit_condition.reason := - $pmt$block_exit_reason [];
{       pmp$establish_ch_in_block (block_exit_condition, ^block_exit_handler, target_sfsa,
{             ^established_handler_pair^.block_exit, local_status);
{       IF NOT local_status.normal THEN {stack is destroyed}
{         pmp$terminate_popper (local_status);
{       IFEND;
{     IFEND;

{  If a ring crossing procedure frame exists for this stack then call ring_crossing_popper
{  to assure that delayed conditions and preemptive communications processed.

      IF preceding_sfsa^.minimum_save_area.p_register.pva.seg =
                                             #segment(ring_crossing_procedure_pva) THEN
        IF preceding_sfsa^.minimum_save_area.p_register.pva.offset >=
                                             #offset(ring_crossing_procedure_pva) THEN
          IF preceding_sfsa^.minimum_save_area.p_register.pva.offset <
                                             #offset(ring_crossing_return_pva) THEN
            preceding_sfsa := preceding_sfsa^.minimum_save_area.a2_previous_save_area;
            IF preceding_sfsa = NIL THEN
              local_status.normal := TRUE;
              pmp$terminate_popper (local_status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      IF #ring (preceding_sfsa) = #ring (^of_execution) THEN
        pmp$pop_3_stack_frames (#SIZE (pmt$established_handler_pair));
      ELSE
        pmp$find_stack_segment (#ring (preceding_sfsa), stack_segment);
        converter.pointer_to_procedure := ^ring_crossing_popper;
        popper_cbp := converter.code_base_pointer;
        pmp$build_outward_call_sfsa (popper_cbp, #ring (preceding_sfsa), NIL, preceding_sfsa,
              minimum_stack_frame_size + #SIZE (pmt$established_handler), stack_segment, popper_sfsa);
{       pmp$establish_ch_in_block (error_conditions, ^error_condition_handler, popper_sfsa, i#ptr
{             (minimum_stack_frame_size, popper_sfsa^.minimum_save_area.a1_current_stack_frame),
{             local_status);
{       IF NOT local_status.normal THEN
{         pmp$terminate_popper (local_status);
{       IFEND;

        #KEYPOINT (osk$entry, 0, pmk$ring_crossing_popper);    {Exit in ring_crossing_popper
        pmp$return_to_outward_call_sfsa (popper_sfsa);
      IFEND;
    IFEND;
  PROCEND pmp$intra_ring_popper;
?? TITLE := '   ring_crossing_popper', EJECT ??

  PROCEDURE ring_crossing_popper;

{  PURPOSE:
{    This procedure serves as the target of an outward call when the stack frame thread
{    crosses ring boundaries.  It is responsible for initiating the intra_ring_popper
{    process in the ring just entered.  If the entered ring is at or above the debug_ring and
{    debug_mode is active, then the termination procedure of the debug facility is called.

    VAR
      established_handler: pmt$established_handler,
      end_debug_should_be_called: boolean,
      local_status: ost$status;



{   The following must be the first thing done by this procedure (in order to disestablish
{   the pre_established condition_handler after the ring_crossing.

{   #write_register (osc$pr_clear_on_condition, 0);

    pmp$establish_condition_handler (error_conditions, ^error_condition_handler, ^established_handler,
          local_status);
    IF NOT local_status.normal THEN {stack is destroyed}
      #KEYPOINT (osk$exit, 0, pmk$ring_crossing_popper);   {Entry is in pmp$intra_ring_popper
      pmp$terminate_popper (local_status);
    IFEND;

    pmp$end_debug_should_be_called (end_debug_should_be_called);

    IF end_debug_should_be_called THEN
      pmp$call_end_debug;
    IFEND;


    #KEYPOINT (osk$exit, 0, pmk$ring_crossing_popper);   {Entry is in pmp$intra_ring_popper
    pmp$intra_ring_popper (NIL);
  PROCEND ring_crossing_popper;
?? TITLE := '  block_exit_handler', EJECT ??

  PROCEDURE block_exit_handler (condition: pmt$condition;
        descriptor: ^pmt$condition_information;
        save_area: ^ost$stack_frame_save_area;
    VAR status: ost$status);

{  PURPOSE:
{    This procedure exists to control the scope of user_program block_exit condition handlers.
{    It prohibits them from performing non_local exits.

    PROCEDURE internal_condition_handler (condition: pmt$condition;
          descriptor: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR internal_status: ost$status);

      IF (condition.selector = pmc$block_exit_processing) THEN
        status.normal := TRUE;
        EXIT block_exit_handler
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, status);
        status.normal := TRUE;
      IFEND;
    PROCEND internal_condition_handler;

    VAR
      internal_conditions: [STATIC, READ, oss$job_paged_literal] pmt$condition := [pmc$condition_combination,
        $pmt$condition_combination [pmc$system_conditions, pmc$block_exit_processing,
        mmc$segment_access_condition, ifc$interactive_condition, pmc$user_defined_condition]],
      established_handler: pmt$established_handler;

    pmp$establish_condition_handler (internal_conditions, ^internal_condition_handler, ^established_handler,
          status);
    IF NOT status.normal THEN {stack is destroyed}
      pmp$terminate_popper (status);
    IFEND;
    pmp$continue_to_cause (pmc$inhibit_standard_procedure, status);
    status.normal := TRUE;
  PROCEND block_exit_handler;
?? TITLE := '  error_condition_handler', EJECT ??

  PROCEDURE error_condition_handler (condition: pmt$condition;
        descriptor: ^pmt$condition_information;
        save_area: ^ost$stack_frame_save_area;
    VAR status: ost$status);

    VAR
      local_status: ost$status;

    osp$set_status_from_condition ('PM', condition, save_area, local_status, status);
    pmp$terminate_popper (local_status);
  PROCEND error_condition_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$terminate_popper', EJECT ??
*copy pmh$terminate_popper

  PROCEDURE [XDCL] pmp$terminate_popper
    (    message_status: ost$status);

    PROCEDURE reset_psa_to_nil;

      VAR
        psa: ^ost$minimum_save_area;

      psa := #previous_save_area ();
      psa^.a2_previous_save_area := NIL;
    PROCEND reset_psa_to_nil;

    VAR
      local_status: ost$status;

    reset_psa_to_nil;
    #KEYPOINT (osk$exit, 0, pmk$pop_all_stack_frames);
    IF message_status.normal THEN
      pmp$exit (message_status);
    ELSE
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], message_status, local_status);
      osp$set_status_condition (pme$stack_frame_popper_aborted, local_status);
      pmp$exit (local_status);
    IFEND;
  PROCEND pmp$terminate_popper;
MODEND pmm$stack_frame_popper;
*DECK DECK=PMM$STATUS_QUEUES_DEFINED EXPAND=TRUE

?? SET (LISTCTS := OFF) ??
?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
?? NEWTITLE := 'NOS/VE: Program Control - Job Local Queues' ??
?? NEWTITLE := '  pmm$manage_local_queues - Global System Declarations' ??
MODULE pmm$status_queues_defined;
{   PURPOSE:
{     The purpose of this module is to provide the interface to
{     pmp$status_queues_defined (See: NOS/VE Program Interface ERS - Program
{     Communications) and to declare the queue definition table in the
{     task shared SECTION.

{   DESIGN:
{     The procedure contained in this module is designed to execute with
{     an execution bracket of 1, 13 and a call bracket of 13.
?? EJECT ??
?? SET (LIST := OFF) ??
*copyc OST$STATUS
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$WAIT
*copyc PMK$KEYPOINTS
?? SET (LIST := ON) ??

*copyc PMD$LOCAL_QUEUES
?? TITLE := '  pmm$status_queues_defined - Global External Procedures' ??
?? EJECT ??
?? TITLE := '  pmm$status_queues_defined - Internal Declarations' ??
?? EJECT ??

*copyc PMT$QUEUE_DEFINITION
?? TITLE := '  [XDCL] pmv$queue_definition_table' ??
?? EJECT ??

  CONST
    unlocked = 0;

*copyc OSS$TASK_SHARED

  VAR
    pmv$queue_definition_table: [XDCL, oss$task_shared] record
      definition_lock: ost$signature_lock,
      queues: ^pmt$queue_definition_table, {NIL = local queues undefined}
    recend := [[unlocked], NIL];

?? TITLE := '  pmm$status_queues_defined - External Procedures' ??
?? EJECT ??
?? TITLE := '  [XDCL, #gate] pmp$status_queues_defined' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$status_queues_defined (VAR count: pmt$queues_per_job;
    VAR status: ost$status);
*copyc PMH$STATUS_QUEUES_DEFINED

    VAR
      q_index: pmt$queues_per_job,
      number_defined: pmt$queues_per_job;

    status.normal := TRUE;
    #INLINE ('keypoint', osk$entry, 0, pmk$status_queues_defined);
    count := 0;
    number_defined := 0;
    IF (pmv$queue_definition_table.queues <> NIL) THEN
      FOR q_index := LOWERBOUND (pmv$queue_definition_table.queues^) TO UPPERBOUND
            (pmv$queue_definition_table.queues^) DO
        IF (pmv$queue_definition_table.queues^ [q_index].definition <> NIL) THEN
          number_defined := number_defined + 1;
        IFEND;
      FOREND;
    IFEND;
    count := number_defined;
    #INLINE ('keypoint', osk$exit, 0, pmk$status_queues_defined);
  PROCEND pmp$status_queues_defined;
MODEND pmm$status_queues_defined;
*DECK DECK=PMM$SYSTEM_ADMIN_MISC_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Management Miscellaneous Administrator Commands' ??
MODULE pmm$system_admin_misc_commands;

{ PURPOSE:
{   This module contains miscellaneous commands used to secure the system on
{ specified mainframes.
{

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_value_table
*copyc clt$which_parameter
*copyc dse$interval_password_errors
*copyc ofe$error_codes
*copyc pme$new_password_does_not_match
?? POP ??
*copyc avp$system_administrator
*copyc clp$evaluate_parameters
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$change_operation_password
*copyc pmp$get_compact_date_time
*copyc pmp$lock_unlock_main_window
*copyc pmp$set_operation_password
*copyc pmp$set_operation_interval
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$_change_operation_password', EJECT ??

  PROCEDURE [XDCL] pmp$_change_operation_password
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$chaop) change_operation_password, chaop (
{   old_password, opw: (SECURE) name 7..7 = $required
{   new_password, npw: (CHECK, SECURE) name 7..7 = $required
{   verify_new_password, vnpw: (CHECK, SECURE) name 7..7 = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 2, 12, 12, 48, 55, 677],
    clc$command, 7, 4, 3, 0, 0, 0, 4, 'OSM$CHAOP'], [
    ['NEW_PASSWORD                   ',clc$nominal_entry, 2],
    ['NPW                            ',clc$abbreviation_entry, 2],
    ['OLD_PASSWORD                   ',clc$nominal_entry, 1],
    ['OPW                            ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['VERIFY_NEW_PASSWORD            ',clc$nominal_entry, 3],
    ['VNPW                           ',clc$abbreviation_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [7, 7]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [7, 7]],
{ PARAMETER 3
    [[1, 0, clc$name_type], [7, 7]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$old_password = 1,
      p$new_password = 2,
      p$verify_new_password = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

?? NEWTITLE := 'check_procedure', EJECT ??

    PROCEDURE check_procedure
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
        index: 1 .. 7,
        valid_password: string (7);

      status.normal := TRUE;

      IF NOT (which_parameter.specific) THEN
        IF (parameter_value_table^ [p$new_password].value^.name_value <>
              parameter_value_table^ [p$verify_new_password].value^.name_value) THEN
          osp$set_status_abnormal ('PM', pme$new_password_does_not_match, 'NEW_PASSWORD', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'VERIFY_NEW_PASSWORD', status);
          RETURN;
        IFEND;

        valid_password := parameter_value_table^ [p$new_password].value^.name_value;
        FOR index := 1 TO STRLENGTH (valid_password) DO
          IF NOT (((valid_password (index) >= 'A') AND (valid_password (index) <= 'Z')) OR
                ((valid_password (index) >= '0') AND (valid_password (index) <= '9'))) THEN
            osp$set_status_condition (dse$alphanumeric_password, status);
            RETURN;
          IFEND;
        FOREND;

      IFEND;

    PROCEND check_procedure;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'SYSTEM_ADMINISTRATION', status);
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_procedure, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$change_operation_password (pvt [p$old_password].value^.name_value,
          pvt [p$new_password].value^.name_value, status);

  PROCEND pmp$_change_operation_password;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$_disable_main_operator_wind', EJECT ??

  PROCEDURE [XDCL] pmp$_disable_main_operator_wind
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$dismow) disable_main_operator_window, dismow (
{   password, pw: (SECURE) name 7..7 = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 2, 6, 17, 42, 11, 12],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$DISMOW'], [
    ['PASSWORD                       ',clc$nominal_entry, 1],
    ['PW                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [7, 7]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$password = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    status.normal := TRUE;

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'SYSTEM_ADMINISTRATION', status);
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$lock_unlock_main_window (pvt [p$password].value^.name_value, TRUE, status);

  PROCEND pmp$_disable_main_operator_wind;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$_enable_main_operator_windo', EJECT ??

  PROCEDURE [XDCL] pmp$_enable_main_operator_windo
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$enamow) enable_main_operator_window, enamow (
{   password, pw: (SECURE) name 7..7 = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 2, 6, 17, 42, 42, 415],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$ENAMOW'], [
    ['PASSWORD                       ',clc$nominal_entry, 1],
    ['PW                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [7, 7]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$password = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    status.normal := TRUE;

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'SYSTEM_ADMINISTRATION', status);
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$lock_unlock_main_window (pvt [p$password].value^.name_value, FALSE, status);

  PROCEND pmp$_enable_main_operator_windo;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$_set_operation_password', EJECT ??

  PROCEDURE [XDCL] pmp$_set_operation_password
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$setop) set_operation_password, setop (
{   password, pw: (CHECK, SECURE) name 7..7 = $required
{   verify_password, vpw: (CHECK, SECURE) name 7..7 = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 2, 12, 12, 49, 20, 436],
    clc$command, 5, 3, 2, 0, 0, 0, 3, 'OSM$SETOP'], [
    ['PASSWORD                       ',clc$nominal_entry, 1],
    ['PW                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['VERIFY_PASSWORD                ',clc$nominal_entry, 2],
    ['VPW                            ',clc$abbreviation_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [7, 7]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [7, 7]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$password = 1,
      p$verify_password = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

?? NEWTITLE := 'check_procedure', EJECT ??

    PROCEDURE check_procedure
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);


      VAR
        index: 1 .. 7,
        valid_password: string (7);

      status.normal := TRUE;

      IF NOT (which_parameter.specific) THEN

        IF (parameter_value_table^ [p$password].value^.name_value <>
              parameter_value_table^ [p$verify_password].value^.name_value) THEN
          osp$set_status_abnormal ('PM', pme$new_password_does_not_match, 'PASSWORD', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'VERIFY_PASSWORD', status);
          RETURN;
        IFEND;

        valid_password := parameter_value_table^ [p$password].value^.name_value;
        FOR index := 1 TO STRLENGTH (valid_password) DO
          IF NOT (((valid_password (index) >= 'A') AND (valid_password (index) <= 'Z')) OR
                ((valid_password (index) >= '0') AND (valid_password (index) <= '9'))) THEN
            osp$set_status_condition (dse$alphanumeric_password, status);
            RETURN;
          IFEND;
        FOREND;

      IFEND;

    PROCEND check_procedure;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'SYSTEM_ADMINISTRATION', status);
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_procedure, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$set_operation_password (pvt [p$password].value^.name_value, status);

  PROCEND pmp$_set_operation_password;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$_set_operation_interval', EJECT ??

  PROCEDURE [XDCL] pmp$_set_operation_interval
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$setoi) set_operation_interval, setoi (
{   password, pw: (SECURE) name 7..7 = $required
{   month, m: integer 1..12 = $required
{   day, d: integer 1..31 = $required
{   year, y: integer 1900..2155 = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 2, 6, 17, 46, 26, 142],
    clc$command, 9, 5, 4, 0, 0, 0, 5, 'OSM$SETOI'], [
    ['D                              ',clc$abbreviation_entry, 3],
    ['DAY                            ',clc$nominal_entry, 3],
    ['M                              ',clc$abbreviation_entry, 2],
    ['MONTH                          ',clc$nominal_entry, 2],
    ['PASSWORD                       ',clc$nominal_entry, 1],
    ['PW                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['Y                              ',clc$abbreviation_entry, 4],
    ['YEAR                           ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [7, 7]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, 12, 10]],
{ PARAMETER 3
    [[1, 0, clc$integer_type], [1, 31, 10]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [1900, 2155, 10]],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$password = 1,
      p$month = 2,
      p$day = 3,
      p$year = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      current_date_time: ost$date_time,
      expiration_date: ost$date_time;


    status.normal := TRUE;

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'SYSTEM_ADMINISTRATION', status);
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    expiration_date.year := pvt [p$year].value^.integer_value.value - 1900;
    expiration_date.month := pvt [p$month].value^.integer_value.value;
    expiration_date.day := pvt [p$day].value^.integer_value.value;
    expiration_date.hour := 0;
    expiration_date.minute := 0;
    expiration_date.second := 0;
    expiration_date.millisecond := 0;

    pmp$get_compact_date_time (current_date_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (expiration_date.year < current_date_time.year) THEN
      osp$set_status_condition (dse$invalid_interval_entered, status);
      RETURN;
    ELSEIF (expiration_date.year = current_date_time.year) THEN
      IF (expiration_date.month < current_date_time.month) THEN
        osp$set_status_condition (dse$invalid_interval_entered, status);
        RETURN;
      ELSEIF (expiration_date.month = current_date_time.month) THEN
        IF (expiration_date.day < current_date_time.day) THEN
          osp$set_status_condition (dse$invalid_interval_entered, status);
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    pmp$set_operation_interval (pvt [p$password].value^.name_value, expiration_date, status);

  PROCEND pmp$_set_operation_interval;
?? OLDTITLE ??

MODEND pmm$system_admin_misc_commands;
*DECK DECK=PMM$SYSTEM_ADMIN_MISC_COM_R3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Management Miscellaneous Administrator Commands' ??
MODULE pmm$system_admin_misc_com_r3;

{ PURPOSE:
{   This module contains the ring3 interfaces for miscellaneous commands used
{ to secure the system on specified mainframes.
{

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ofe$error_codes
*copyc ost$date_time
*copyc ost$name
?? POP ??
*copyc avp$system_administrator
*copyc dsp$change_operation_password
*copyc dsp$lock_unlock_main_window
*copyc dsp$set_operation_password
*copyc dsp$set_operation_interval
*copyc osp$set_status_abnormal

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$change_operation_password', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$change_operation_password
    (    old_password: ost$name;
         new_password: ost$name;
     VAR status: ost$status);


    status.normal := TRUE;

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'SYSTEM_ADMINISTRATION', status);
      RETURN;
    IFEND;

    dsp$change_operation_password (old_password, new_password, status);

  PROCEND pmp$change_operation_password;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$lock_unlock_main_window', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$lock_unlock_main_window
    (    password: ost$name;
         lock_window: boolean;
     VAR status: ost$status);

    status.normal := TRUE;

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'SYSTEM_ADMINISTRATION', status);
      RETURN;
    IFEND;

    dsp$lock_unlock_main_window (password, lock_window, status);

  PROCEND pmp$lock_unlock_main_window;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$set_operation_password', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$set_operation_password
    (    password: ost$name;
     VAR status: ost$status);


    status.normal := TRUE;

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'SYSTEM_ADMINISTRATION', status);
      RETURN;
    IFEND;

    dsp$set_operation_password (password, status);

  PROCEND pmp$set_operation_password;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$set_operation_interval', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$set_operation_interval
    (    password: ost$name;
         date_time: ost$date_time;
     VAR status: ost$status);


    status.normal := TRUE;

    IF NOT avp$system_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'SYSTEM_ADMINISTRATION', status);
      RETURN;
    IFEND;

    dsp$set_operation_interval (password, date_time, status);

  PROCEND pmp$set_operation_interval;
?? OLDTITLE ??

MODEND pmm$system_admin_misc_com_r3;
*DECK DECK=PMM$SYSTEM_TIME_COMPUTATION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Program Management - System Time Computation' ??
MODULE pmm$system_time_computation;


{  PURPOSE:
{    This module contains the routines for computing system time:
{
{    pmp$compute_date_time
{    pmp$compute_day_of_week
{    pmp$compute_local_date_time
{    pmp$compute_time_dif_in_seconds
{    pmp$compute_universal_date_time

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc osd$integer_limits
*IFEND
*copyc oss$job_paged_literal
*copyc ost$date_time
*copyc ost$day_of_week
*copyc ost$time_zone
*copyc pme$system_time_exceptions
*copyc pmk$keypoints
*copyc pmt$time_increment
?? POP ??
*IF NOT $true(osv$unix)
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*IFEND
*copyc osp$set_status_condition
*IF NOT $true(osv$unix)
*copyc pmp$continue_to_cause
*IFEND
*copyc pmp$get_compact_date_time
*copyc pmp$this_is_a_leap_year
*copyc pmp$verify_compact_date
*copyc pmp$verify_compact_time
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    max_years = 2235, { 1980 + 255 }
    local_clock = 0;

  VAR
    leap_year: [STATIC, READ, oss$job_paged_literal] array [1 .. 12] of
          1 .. 31 := [31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31],

    non_leap_year: [STATIC, READ, oss$job_paged_literal] array [1 .. 12] of
          1 .. 31 := [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31];

  VAR
    leap_year_cummulative_days: [STATIC, READ, oss$job_paged_literal] array [0 .. 12] of
          0 .. 366 := [0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366],

    non_leap_year_cummulative_days: [STATIC, READ, oss$job_paged_literal] array [0 .. 12] of
          0 .. 366 := [0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365];

  VAR
    weekday_offsets: [STATIC, READ, oss$job_paged_literal] array [1 .. 12] of
          0 .. 6 := [0, 3, 3, 6, 1, 4, 6, 2, 5, 0, 3, 5];

?? OLDTITLE ??
*IF NOT $true(osv$unix)
?? NEWTITLE := 'compute_seconds_since_1980', EJECT ??

  PROCEDURE compute_seconds_since_1980
    (    date_time: ost$date_time;
     VAR seconds: ost$non_negative_integers);

    CONST
      seconds_in_a_day = 24 * 60 * 60,
      seconds_in_a_leap_year = 366 * seconds_in_a_day,
      seconds_in_a_non_leap_year = 365 * seconds_in_a_day;

    VAR
      this_year: 1900 .. 2155,
      year: 1900 .. 2155;

    this_year := date_time.year + 1900;
    seconds := 0;

    FOR year := 1980 TO (this_year - 1) DO
      IF pmp$this_is_a_leap_year (year) THEN
        seconds := seconds + seconds_in_a_leap_year;
      ELSE
        seconds := seconds + seconds_in_a_non_leap_year;
      IFEND;
    FOREND;

    IF pmp$this_is_a_leap_year (this_year) THEN
      seconds := seconds + (leap_year_cummulative_days [date_time.month - 1] * seconds_in_a_day);
    ELSE
      seconds := seconds + (non_leap_year_cummulative_days [date_time.month - 1] * seconds_in_a_day);
    IFEND;

    seconds := seconds + ((date_time.day - 1) * seconds_in_a_day);

    seconds := seconds + (((date_time.hour * 60 + date_time.minute) * 60) + date_time.second);

    IF date_time.millisecond > 500 THEN
      seconds := seconds + 1;
    IFEND;
  PROCEND compute_seconds_since_1980;
?? OLDTITLE ??
*IFEND
?? NEWTITLE := '[INLINE] verify_time_zone', EJECT ??

  PROCEDURE [INLINE] verify_time_zone
    (    time_zone: ost$time_zone;
     VAR status: ost$status);

    status.normal := TRUE;

    IF (time_zone.hours_from_gmt < -12) OR (time_zone.hours_from_gmt > 12) OR
          (time_zone.minutes_offset < -30) OR (time_zone.minutes_offset > 30) THEN
      osp$set_status_condition (pme$invalid_time_zone, status);
    IFEND;

  PROCEND verify_time_zone;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$compute_date_time', EJECT ??
*copyc pmh$compute_date_time

  PROCEDURE [XDCL, #GATE] pmp$compute_date_time
    (    base: ost$date_time;
         increment: pmt$time_increment;
     VAR result: ost$date_time;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
    VAR
      established_handler: pmt$established_handler;


?? NEWTITLE := 'arithmetic_overflow_handler', EJECT ??

    PROCEDURE arithmetic_overflow_handler
      (    conditions: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      IF (conditions.selector = pmc$system_conditions) AND (conditions.system_conditions =
            $pmt$system_conditions [pmc$arithmetic_overflow]) THEN
        osp$set_status_condition (pme$compute_overflow, status);
        #KEYPOINT (osk$exit, 0, pmk$compute_date_time);
        EXIT pmp$compute_date_time;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND arithmetic_overflow_handler;
?? OLDTITLE, EJECT ??
*IFEND


    VAR
      local_status: ost$status,

      temp: integer,
      millisecond: integer,
      second: integer,
      minute: integer,
      hour: integer,
      day: integer,
      month: integer,
      year: integer,

      days_in_the_month: ^array [1 .. 12] of 1 .. 31;

    #KEYPOINT (osk$entry, 0, pmk$compute_date_time);

    local_status.normal := TRUE;

*IF NOT $true(osv$unix)
    osp$establish_condition_handler (^arithmetic_overflow_handler, FALSE);
*IFEND

    pmp$verify_compact_time (base, local_status);

    IF local_status.normal THEN
      pmp$verify_compact_date (base, local_status);

      IF local_status.normal THEN
        millisecond := base.millisecond + increment.millisecond;

        temp {ms} := millisecond MOD 1000 {ms} ;
        second := (base.second + increment.second) + (millisecond DIV 1000 {ms/sec} );
        IF temp {ms} < 0 THEN
          result.millisecond := temp {ms} + 1000 {ms} ;
          second := second - 1 {sec} ;
        ELSE
          result.millisecond := temp {ms} ;
        IFEND;

        temp {sec} := second MOD 60 {sec} ;
        minute := (base.minute + increment.minute) + (second DIV 60 {sec/hr} );
        IF temp {sec} < 0 THEN
          result.second := temp {sec} + 60 {sec} ;
          minute := minute - 1 {min} ;
        ELSE
          result.second := temp {sec} ;
        IFEND;

        temp {min} := minute MOD 60 {min} ;
        hour := (base.hour + increment.hour) + (minute DIV 60 {min/hr} );
        IF temp < 0 THEN
          result.minute := temp {min} + 60 {min} ;
          hour := hour - 1 {hr} ;
        ELSE
          result.minute := temp {min} ;
        IFEND;

        temp {hr} := hour MOD 24 {hr} ;
        day := (base.day + increment.day) + (hour DIV 24 {hr/day} );
        IF temp < 0 THEN
          result.hour := temp {hr} + 24 {hr} ;
          day := day - 1 {day} ;
        ELSE
          result.hour := temp {hr} ;
        IFEND;

        month := base.month + increment.month;
        year := base.year + increment.year + 1900 {yr} ;

        IF month < 1 THEN
          year := year - 1 - (-month) DIV 12;
          month := 12 - (-month) MOD 12;
        ELSEIF month > 12 THEN
          year := year + (month - 1) DIV 12;
          month := (month - 1) MOD 12 + 1;
        IFEND;

        IF pmp$this_is_a_leap_year (year) THEN
          days_in_the_month := ^leap_year;
        ELSE
          days_in_the_month := ^non_leap_year;
        IFEND;

        IF day > 0 THEN
          WHILE day > days_in_the_month^ [month] DO
            day := day - days_in_the_month^ [month];
            month := month + 1 {mo} ;

            IF month > 12 {mo} THEN
              month := 1 {mo} ;
              year := year + 1 {yr} ;

              IF pmp$this_is_a_leap_year (year) THEN
                days_in_the_month := ^leap_year;
              ELSE
                days_in_the_month := ^non_leap_year;
              IFEND;
            IFEND;
          WHILEND;
        ELSE
          WHILE day <= 0 DO
            month := month - 1 {mo} ;

            IF month < 1 {mo} THEN
              month := 12 {mo} ;
              year := year - 1 {yr} ;

              IF pmp$this_is_a_leap_year (year) THEN
                days_in_the_month := ^leap_year;
              ELSE
                days_in_the_month := ^non_leap_year;
              IFEND;
            IFEND;

            day := day + days_in_the_month^ [month];
          WHILEND;
        IFEND;

        result.day := day;
        result.month := month;

        year := year - 1900 {yr} ;

        IF (year < LOWERVALUE (result.year)) OR (year > UPPERVALUE (result.year)) THEN
          osp$set_status_condition (pme$computed_year_out_of_range, status);
          #KEYPOINT (osk$exit, 0, pmk$compute_date_time);
          RETURN;
        IFEND;

        result.year := year;
      IFEND;
    IFEND;

    status := local_status;

    #KEYPOINT (osk$exit, 0, pmk$compute_date_time);

  PROCEND pmp$compute_date_time;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$compute_date_time_increment', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$compute_date_time_increment
    (    old: ost$date_time;
         new: ost$date_time;
     VAR increment: pmt$time_increment;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
    VAR
      established_descriptor: pmt$established_handler;

?? NEWTITLE := 'arithmetic_overflow_handler', EJECT ??

    PROCEDURE arithmetic_overflow_handler
      (    conditions: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);


      IF conditions.system_conditions = $pmt$system_conditions [pmc$arithmetic_overflow] THEN
        osp$set_status_condition (pme$compute_overflow, status);
        #KEYPOINT (osk$exit, 0, pmk$compute_date_time_increment);
        EXIT pmp$compute_date_time_increment;
      IFEND;

    PROCEND arithmetic_overflow_handler;
?? OLDTITLE, EJECT ??
*IFEND


    VAR
      local_status: ost$status,

      switch_values: boolean,

      temp: ost$date_time,
      old_val: ost$date_time,
      new_val: ost$date_time,

      millisecond: integer,
      second: integer,
      minute: integer,
      hour: integer,
      day: integer,
      month: integer,
      year: integer,

      days_in_month: ^array [1 .. 12] of 1 .. 31,

      old_year: integer;

    #KEYPOINT (osk$entry, 0, pmk$compute_date_time_increment);

    local_status.normal := TRUE;

*IF NOT $true(osv$unix)
    osp$establish_condition_handler (^arithmetic_overflow_handler, FALSE);
    IF NOT local_status.normal THEN
      status := local_status;
      #KEYPOINT (osk$exit, 0, pmk$compute_date_time_increment);
      RETURN;
    IFEND;
*IFEND

    pmp$verify_compact_time (old, local_status);

    IF NOT local_status.normal THEN
      status := local_status;
      #KEYPOINT (osk$exit, 0, pmk$compute_date_time_increment);
      RETURN;
    IFEND;

    pmp$verify_compact_date (old, local_status);

    IF NOT local_status.normal THEN
      status := local_status;
      #KEYPOINT (osk$exit, 0, pmk$compute_date_time_increment);
      RETURN;
    IFEND;

    pmp$verify_compact_time (new, local_status);

    IF NOT local_status.normal THEN
      status := local_status;
      #KEYPOINT (osk$exit, 0, pmk$compute_date_time_increment);
      RETURN;
    IFEND;

    pmp$verify_compact_date (new, local_status);

    IF NOT local_status.normal THEN
      status := local_status;
      #KEYPOINT (osk$exit, 0, pmk$compute_date_time_increment);
      RETURN;
    IFEND;

    old_val := old;
    new_val := new;

    switch_values := FALSE;

    IF new_val.year <> old_val.year THEN
      IF new_val.year < old_val.year THEN
        switch_values := TRUE;
      IFEND;
    ELSE
      IF new_val.month <> old_val.month THEN
        IF new_val.month < old_val.month THEN
          switch_values := TRUE;
        IFEND;
      ELSE
        IF new_val.day <> old_val.day THEN
          IF new_val.day < old_val.day THEN
            switch_values := TRUE;
          IFEND;
        ELSE
          IF new_val.hour <> old_val.hour THEN
            IF new_val.hour < old_val.hour THEN
              switch_values := TRUE;
            IFEND;
          ELSE
            IF new_val.minute <> old_val.minute THEN
              IF new_val.minute < old_val.minute THEN
                switch_values := TRUE;
              IFEND;
            ELSE
              IF new_val.second <> old_val.second THEN
                IF new_val.second < old_val.second THEN
                  switch_values := TRUE;
                IFEND;
              ELSE
                IF new_val.millisecond <> old_val.millisecond THEN
                  IF new_val.millisecond < old_val.millisecond THEN
                    switch_values := TRUE;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF switch_values THEN
      temp := old_val;
      old_val := new_val;
      new_val := temp;
    IFEND;

    millisecond := new_val.millisecond - old_val.millisecond;

    second := new_val.second - old_val.second;
    IF millisecond < 0 THEN
      increment.millisecond := millisecond + 1000;
      second := second - 1;
    ELSE
      increment.millisecond := millisecond;
    IFEND;

    minute := new_val.minute - old_val.minute;
    IF second < 0 THEN
      increment.second := second + 60;
      minute := minute - 1;
    ELSE
      increment.second := second;
    IFEND;
    hour := new_val.hour - old_val.hour;
    IF minute < 0 THEN
      increment.minute := minute + 60;
      hour := hour - 1;
    ELSE
      increment.minute := minute;
    IFEND;

    day := new_val.day - old_val.day;
    IF hour < 0 THEN
      increment.hour := hour + 24;
      day := day - 1;
    ELSE
      increment.hour := hour;
    IFEND;

    old_year := old_val.year + 1900;

    IF pmp$this_is_a_leap_year (old_year) THEN
      days_in_month := ^leap_year;
    ELSE
      days_in_month := ^non_leap_year;
    IFEND;

    month := new_val.month - old_val.month;
    IF day < 0 THEN
      month := month - 1;
      increment.day := days_in_month^ [old_val.month] + day;
    ELSE
      increment.day := day;
    IFEND;

    year := new_val.year - old_val.year;
    IF month < 0 THEN
      increment.month := month + 12;
      year := year - 1;
    ELSE
      increment.month := month;
    IFEND;

    increment.year := year;


    IF (year < LOWERVALUE (increment.year)) OR (year > UPPERVALUE (increment.year)) THEN
      osp$set_status_condition (pme$computed_year_out_of_range, status);
      #KEYPOINT (osk$exit, 0, pmk$compute_date_time_increment);
      RETURN;
    IFEND;

    IF switch_values THEN
      increment.millisecond := -increment.millisecond;
      increment.second := -increment.second;
      increment.minute := -increment.minute;
      increment.hour := -increment.hour;
      increment.day := -increment.day;
      increment.month := -increment.month;
      increment.year := -increment.year;
    IFEND;

*IF NOT $true(osv$unix)
    osp$disestablish_cond_handler;
*IFEND

    status := local_status;

    #KEYPOINT (osk$exit, 0, pmk$compute_date_time_increment);

  PROCEND pmp$compute_date_time_increment;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$compute_day_of_week', EJECT ??
*copyc pmh$compute_day_of_week

  PROCEDURE [XDCL, #GATE] pmp$compute_day_of_week
    (    date: ost$date_time;
     VAR day_of_week: ost$day_of_week;
     VAR status: ost$status);

    VAR
      year_mod_400: integer,
      day_index: 0 .. 6;

    #KEYPOINT (osk$entry, 0, pmk$compute_day_of_week);

    pmp$verify_compact_date (date, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, pmk$compute_day_of_week);
      RETURN;
    IFEND;

    year_mod_400 := ((date.year + 1900) MOD 400);
    day_index := ((year_mod_400 + ((year_mod_400 + 3) DIV 4) - ((year_mod_400 - 1) DIV
          100) + date.day + $INTEGER (pmp$this_is_a_leap_year (year_mod_400)) * $INTEGER (date.month >=
          3) + weekday_offsets [date.month] + 4) MOD 7);

    #UNCHECKED_CONVERSION (day_index, day_of_week);

    #KEYPOINT (osk$exit, 0, pmk$compute_day_of_week);

  PROCEND pmp$compute_day_of_week;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$compute_local_date_time', EJECT ??
*copyc pmh$compute_local_date_time

  PROCEDURE [XDCL, #GATE] pmp$compute_local_date_time
    (    universal_date_time: ost$date_time;
         time_zone: ost$time_zone;
     VAR local_date_time: ost$date_time;
     VAR status: ost$status);

    VAR
      time_zone_increment: pmt$time_increment;

    #KEYPOINT (osk$entry, 0, pmk$compute_local_date_time);

    status.normal := TRUE;
    pmp$verify_compact_date (universal_date_time, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, pmk$compute_local_date_time);
      RETURN;
    IFEND;
    pmp$verify_compact_time (universal_date_time, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, pmk$compute_local_date_time);
      RETURN;
    IFEND;
    verify_time_zone (time_zone, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, pmk$compute_local_date_time);
      RETURN;
    IFEND;

    IF time_zone.daylight_saving_time THEN
      time_zone_increment.hour := 1;
    ELSE
      time_zone_increment.hour := 0;
    IFEND;

    time_zone_increment.hour := (time_zone.hours_from_gmt + time_zone_increment.hour);
    time_zone_increment.minute := time_zone.minutes_offset;
    time_zone_increment.second := 0;
    time_zone_increment.millisecond := 0;
    time_zone_increment.year := 0;
    time_zone_increment.month := 0;
    time_zone_increment.day := 0;

    pmp$compute_date_time (universal_date_time, time_zone_increment, local_date_time, status);

    #KEYPOINT (osk$exit, 0, pmk$compute_local_date_time);

  PROCEND pmp$compute_local_date_time;

?? OLDTITLE ??
*IF NOT $true(osv$unix)
?? NEWTITLE := '[XDCL, #GATE] pmp$compute_time_dif_in_seconds', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$compute_time_dif_in_seconds
    (    old: ost$date_time;
         new: ost$date_time;
     VAR seconds: integer;
     VAR status: ost$status);

{ PURPOSE:
{ The purpose of this procedure is to compute the number of seconds that have
{ elapsed between the two dates given.  If the "old" date is greater than the
{ "new" date, the number of seconds returned is a negative value.

    VAR
      new_seconds: ost$non_negative_integers,
      old_seconds: ost$non_negative_integers;

    #KEYPOINT (osk$entry, 0, pmk$compute_time_dif_in_seconds);
    status.normal := TRUE;

    pmp$verify_compact_time (old, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, pmk$compute_time_dif_in_seconds);
      RETURN;
    IFEND;

    pmp$verify_compact_date (old, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, pmk$compute_time_dif_in_seconds);
      RETURN;
    IFEND;

    pmp$verify_compact_time (new, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, pmk$compute_time_dif_in_seconds);
      RETURN;
    IFEND;

    pmp$verify_compact_date (new, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, pmk$compute_time_dif_in_seconds);
      RETURN;
    IFEND;

    compute_seconds_since_1980 (old, old_seconds);
    compute_seconds_since_1980 (new, new_seconds);

    seconds := new_seconds - old_seconds;

    IF seconds = 0 THEN
      seconds := 1;
    IFEND;
    #KEYPOINT (osk$exit, 0, pmk$compute_time_dif_in_seconds);
  PROCEND pmp$compute_time_dif_in_seconds;
?? OLDTITLE ??
*IFEND
?? NEWTITLE := '[XDCL, #GATE] pmp$compute_universal_date_time', EJECT ??
*copyc pmh$compute_universal_date_time

  PROCEDURE [XDCL, #GATE] pmp$compute_universal_date_time
    (    local_date_time: ost$date_time;
         time_zone: ost$time_zone;
     VAR universal_date_time: ost$date_time;
     VAR status: ost$status);

    VAR
      time_zone_increment: pmt$time_increment;

    #KEYPOINT (osk$entry, 0, pmk$compute_universal_date_time);

    status.normal := TRUE;
    pmp$verify_compact_date (local_date_time, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, pmk$compute_universal_date_time);
      RETURN;
    IFEND;
    pmp$verify_compact_time (local_date_time, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, pmk$compute_universal_date_time);
      RETURN;
    IFEND;
    verify_time_zone (time_zone, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, pmk$compute_universal_date_time);
      RETURN;
    IFEND;

    IF time_zone.daylight_saving_time THEN
      time_zone_increment.hour := 1;
    ELSE
      time_zone_increment.hour := 0;
    IFEND;

    time_zone_increment.hour := -(time_zone.hours_from_gmt + time_zone_increment.hour);
    time_zone_increment.minute := -time_zone.minutes_offset;
    time_zone_increment.second := 0;
    time_zone_increment.millisecond := 0;
    time_zone_increment.year := 0;
    time_zone_increment.month := 0;
    time_zone_increment.day := 0;

    pmp$compute_date_time (local_date_time, time_zone_increment, universal_date_time, status);

    #KEYPOINT (osk$exit, 0, pmk$compute_universal_date_time);

  PROCEND pmp$compute_universal_date_time;

?? OLDTITLE ??
MODEND pmm$system_time_computation;
*DECK DECK=PMM$SYSTEM_TIME_DECLARATIONS EXPAND=TRUE
*DECK DECK=PMM$SYSTEM_TIME_REQUESTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE:  Program Management - System Time Requests' ??
MODULE pmm$system_time_requests;

{  PURPOSE:
{    This module contains the routines for the system time requests:
{
{    pmp$get_compact_date_time
{    pmp$get_date_time_at_timestamp
{    pmp$format_compact_date
{    pmp$format_compact_time
{    pmp$get_legible_date_time
{    pmp$get_date
{    pmp$get_time
{    pmp$get_system_time
{    pmp$get_time_zone
{    pmp$get_universal_date_time
{    pmp$get_date_time_defaults
{    pmp$date_time_compare
{

?? NEWTITLE := 'Global Declarations Referenced By This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc clt$date_time_form_string
*copyc oss$mainframe_paged_literal
*copyc ost$date
*copyc ost$date_time
*copyc ost$day_of_week
*IF NOT $true(osv$unix)
*copyc ost$free_running_clock
*IFEND
*copyc ost$time
*copyc pme$program_services_exceptions
*copyc pme$system_time_exceptions
*copyc pmk$keypoints
*copyc pmt$comparison_result
*copyc pmt$system_time
*copyc pmt$time_increment
*copyc pmt$use_time_zone
?? POP ??
*copyc osp$append_status_integer
*copyc osp$set_status_condition
*copyc pmp$this_is_a_leap_year
*IF $true(osv$unix)
*copyc pmp_get_date_time
*IFEND
?? EJECT ??
*IF NOT $true(osv$unix)
*copyc osv$base_system_time
*IFEND
*copyc osv$os_defaults
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    c$max_years = 2155; { 1900 + 255

  TYPE
    t$names_of_the_month = RECORD
      name: string (18),
      start_of_day: 0 .. 12,
    RECEND;
?? EJECT ??
  VAR
    v$leap_year: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 12] OF
          1 .. 31 := [31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31],

    v$non_leap_year: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 12] OF
          1 .. 31 := [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31];

  VAR
    v$leap_year_cummulative_days: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [0 .. 12] OF
          0 .. 366 := [0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366],

    v$non_leap_year_cummulat_days: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [0 .. 12] OF
          0 .. 366 := [0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365];

?? FMT (FORMAT := OFF) ??
  VAR
    v$month_names: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 12] OF t$names_of_the_month :=
         [['January   ,       ',  9 ],
          ['February   ,      ', 10 ],
          ['March   ,         ',  7 ],
          ['April   ,         ',  7 ],
          ['May   ,           ',  5 ],
          ['June   ,          ',  6 ],
          ['July   ,          ',  6 ],
          ['August   ,        ',  8 ],
          ['September   ,     ', 11 ],
          ['October   ,       ',  9 ],
          ['November   ,      ', 10 ],
          ['December   ,      ', 10 ]];

  VAR
    v$character_equivalent: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [0 .. 99] OF string ( 2 ) :=
         ['00', '01', '02', '03', '04', '05', '06', '07', '08', '09',
          '10', '11', '12', '13', '14', '15', '16', '17', '18', '19',
          '20', '21', '22', '23', '24', '25', '26', '27', '28', '29',
          '30', '31', '32', '33', '34', '35', '36', '37', '38', '39',
          '40', '41', '42', '43', '44', '45', '46', '47', '48', '49',
          '50', '51', '52', '53', '54', '55', '56', '57', '58', '59',
          '60', '61', '62', '63', '64', '65', '66', '67', '68', '69',
          '70', '71', '72', '73', '74', '75', '76', '77', '78', '79',
          '80', '81', '82', '83', '84', '85', '86', '87', '88', '89',
          '90', '91', '92', '93', '94', '95', '96', '97', '98', '99'];

?? FMT (FORMAT:=ON) ??
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] convert_integer_to_rj_string', EJECT ??

  PROCEDURE [INLINE] convert_integer_to_rj_string
    (    intger: integer;
         fill_character: char;
     VAR strng: string ( * ));

    VAR
      int: integer,
      length: integer,
      i: integer;

    int := intger;
    length := STRLENGTH (strng);

    REPEAT
      IF (length <= 0) THEN
        strng := '*******';
        RETURN;
      IFEND;

      strng (length) := $CHAR ((int MOD 10) + $INTEGER ('0'));

      length := length - 1;
      int := int DIV 10;
    UNTIL (int = 0);

    FOR i := 1 TO length DO
      strng (i) := fill_character;
    FOREND;

  PROCEND convert_integer_to_rj_string;
?? OLDTITLE ??
?? NEWTITLE := 'format_compact_date', EJECT ??

  PROCEDURE format_compact_date
    (    date_time: ost$date_time;
     VAR date: ost$date);

    VAR
      convert_year: 0 .. 255, { same as year range in ost$date_time
      ordinal_date: 0 .. (1000 * c$max_years),
      p: 0 .. 63;

    CASE date.date_format OF
    = osc$ordinal_date =
      ordinal_date := 1900 + date_time.year;
      IF pmp$this_is_a_leap_year (ordinal_date) THEN
        ordinal_date := (ordinal_date * 1000) + v$leap_year_cummulative_days [date_time.month - 1] +
              date_time.day;
      ELSE
        ordinal_date := (ordinal_date * 1000) + v$non_leap_year_cummulat_days [date_time.month - 1] +
              date_time.day;
      IFEND;

      convert_integer_to_rj_string (ordinal_date, '0', date.ordinal);

    = osc$month_date =
      date.month := v$month_names [date_time.month].name;
      p := v$month_names [date_time.month].start_of_day;
      date.month (p, 2) := v$character_equivalent [date_time.day];
      convert_integer_to_rj_string ((date_time.year + 1900), ' ', date.month (p + 4, 4));
      IF date_time.day < 10 THEN
        date.month (p - 1, * ) := date.month (p, * );
        date.month (p - 1) := ' ';
      IFEND;

    = osc$mdy_date =
      date.mdy := '**/**/**';
      date.mdy (1, 2) := v$character_equivalent [date_time.month];
      date.mdy (4, 2) := v$character_equivalent [date_time.day];
      convert_year := date_time.year;
      WHILE convert_year > 99 DO
        convert_year := convert_year - 100;
      WHILEND;
      date.mdy (7, 2) := v$character_equivalent [convert_year];

    = osc$dmy_date =
      date.dmy := '**.**.**';
      date.dmy (1, 2) := v$character_equivalent [date_time.day];
      date.dmy (4, 2) := v$character_equivalent [date_time.month];
      convert_year := date_time.year;
      WHILE convert_year > 99 DO
        convert_year := convert_year - 100;
      WHILEND;
      date.dmy (7, 2) := v$character_equivalent [convert_year];

    ELSE { = osc$iso_date =
      date.iso := '****-**-**';
      convert_integer_to_rj_string ((date_time.year + 1900), '0', date.iso (1, 4));
      date.iso (6, 2) := v$character_equivalent [date_time.month];
      date.iso (9, 2) := v$character_equivalent [date_time.day];

    CASEND;

  PROCEND format_compact_date;
?? OLDTITLE ??
?? NEWTITLE := 'format_compact_time', EJECT ??

  PROCEDURE format_compact_time
    (    date_time: ost$date_time;
         time_form_string: clt$date_time_form_string;
     VAR time {input output} : ost$time);

    CASE time.time_format OF
    = osc$ampm_time =
      IF date_time.hour < 12 THEN
        time.ampm := ' *:** AM';
        IF date_time.hour = 0 THEN
          time.ampm (1, 2) := '12';
        ELSE
          time.ampm (1, 2) := v$character_equivalent [date_time.hour];
          IF (date_time.hour < 10) THEN
            time.ampm (1) := ' ';
          IFEND;
        IFEND;
      ELSE
        time.ampm := ' *:** PM';
        IF date_time.hour = 12 THEN
          time.ampm (1, 2) := '12';
        ELSE
          time.ampm (1, 2) := v$character_equivalent [date_time.hour - 12];
          IF ((date_time.hour - 12) < 10) THEN
            time.ampm (1) := ' ';
          IFEND;
        IFEND;
      IFEND;

      time.ampm (4, 2) := v$character_equivalent [date_time.minute];

    = osc$hms_time =
      time.hms := '**:**:**';
      time.hms (1, 2) := v$character_equivalent [date_time.hour];
      time.hms (4, 2) := v$character_equivalent [date_time.minute];
      time.hms (7, 2) := v$character_equivalent [date_time.second];

    ELSE { = osc$millisecond_time =
      IF time_form_string = 'ISOT' THEN
        time.millisecond := '**.**.**,** ';
        time.millisecond (1, 2) := v$character_equivalent [date_time.hour];
        time.millisecond (4, 2) := v$character_equivalent [date_time.minute];
        time.millisecond (7, 2) := v$character_equivalent [date_time.second];
        convert_integer_to_rj_string (date_time.millisecond DIV 10, '0', time.millisecond (10, 2));
      ELSE
        time.millisecond := '**:**:**.***';
        time.millisecond (1, 2) := v$character_equivalent [date_time.hour];
        time.millisecond (4, 2) := v$character_equivalent [date_time.minute];
        time.millisecond (7, 2) := v$character_equivalent [date_time.second];
        convert_integer_to_rj_string (date_time.millisecond, '0', time.millisecond (10, 3));
      IFEND;
    CASEND;

  PROCEND format_compact_time;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] validate_date_format', EJECT ??

  PROCEDURE [INLINE] validate_date_format
    (    date_format: ost$date_formats;
     VAR validated_date_format: ost$date_formats;
     VAR status: ost$status);

    status.normal := TRUE;

    CASE date_format OF
    = osc$ordinal_date, osc$month_date, osc$mdy_date, osc$dmy_date, osc$iso_date =
      validated_date_format := date_format;

    = osc$default_date =
      validated_date_format := osv$os_defaults.system_date_format.date_format;

    ELSE
      osp$set_status_condition (pme$invalid_date_format, status);
    CASEND;

  PROCEND validate_date_format;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] validate_time_format', EJECT ??

  PROCEDURE [INLINE] validate_time_format
    (    time_format: ost$time_formats;
     VAR validated_time_format: ost$time_formats;
     VAR format_string: clt$date_time_form_string;
     VAR status: ost$status);

    status.normal := TRUE;

    CASE time_format OF
    = osc$ampm_time =
      validated_time_format := time_format;
      format_string := 'AMPM';

    = osc$hms_time =
      validated_time_format := time_format;
      format_string := 'HMS';

    = osc$millisecond_time =
      validated_time_format := time_format;
      format_string := 'MS';

    = osc$default_time =
      validated_time_format := osv$os_defaults.system_time_format.time_format;
      format_string := osv$os_defaults.system_time_format.format_string;

    ELSE
      osp$set_status_condition (pme$invalid_time_format, status);
    CASEND;

  PROCEND validate_time_format;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$date_time_compare', EJECT ??
*copy pmh$date_time_compare

  PROCEDURE [XDCL, #GATE] pmp$date_time_compare
    (    left_operand: ost$date_time;
         right_operand: ost$date_time;
     VAR comparison_result: pmt$comparison_result;
     VAR status: ost$status);

    pmp$verify_compact_date (left_operand, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$verify_compact_time (left_operand, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$verify_compact_date (right_operand, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$verify_compact_time (right_operand, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    comparison_result := pmc$equal;

    IF left_operand.year < right_operand.year THEN
      comparison_result := pmc$right_is_greater;
    ELSEIF left_operand.year > right_operand.year THEN
      comparison_result := pmc$left_is_greater;
    ELSEIF left_operand.month < right_operand.month THEN
      comparison_result := pmc$right_is_greater;
    ELSEIF left_operand.month > right_operand.month THEN
      comparison_result := pmc$left_is_greater;
    ELSEIF left_operand.day < right_operand.day THEN
      comparison_result := pmc$right_is_greater;
    ELSEIF left_operand.day > right_operand.day THEN
      comparison_result := pmc$left_is_greater;
    IFEND;

    IF (comparison_result = pmc$equal) THEN
      IF left_operand.hour < right_operand.hour THEN
        comparison_result := pmc$right_is_greater;
      ELSEIF left_operand.hour > right_operand.hour THEN
        comparison_result := pmc$left_is_greater;
      ELSEIF left_operand.minute < right_operand.minute THEN
        comparison_result := pmc$right_is_greater;
      ELSEIF left_operand.minute > right_operand.minute THEN
        comparison_result := pmc$left_is_greater;
      ELSEIF left_operand.second < right_operand.second THEN
        comparison_result := pmc$right_is_greater;
      ELSEIF left_operand.second > right_operand.second THEN
        comparison_result := pmc$left_is_greater;
      ELSEIF left_operand.millisecond < right_operand.millisecond THEN
        comparison_result := pmc$right_is_greater;
      ELSEIF left_operand.millisecond > right_operand.millisecond THEN
        comparison_result := pmc$left_is_greater;
      IFEND;
    IFEND;

  PROCEND pmp$date_time_compare;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$format_compact_date', EJECT ??
*copy pmh$format_compact_date

  PROCEDURE [XDCL, #GATE] pmp$format_compact_date
    (    date_time: ost$date_time;
         format: ost$date_formats;
     VAR date: ost$date;
     VAR status: ost$status);

    #KEYPOINT (osk$entry, 0, pmk$format_compact_date);

    status.normal := TRUE;

    pmp$verify_compact_date (date_time, status);

    IF status.normal THEN
      validate_date_format (format, date.date_format, status);

      IF status.normal THEN
        format_compact_date (date_time, date);
      IFEND;
    IFEND;

    #KEYPOINT (osk$exit, 0, pmk$format_compact_date);

  PROCEND pmp$format_compact_date;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$format_compact_time', EJECT ??
*copy pmh$format_compact_time

  PROCEDURE [XDCL, #GATE] pmp$format_compact_time
    (    date_time: ost$date_time;
         format: ost$time_formats;
     VAR time: ost$time;
     VAR status: ost$status);

    VAR
      time_form_string: string (clc$max_date_time_form_string);

    #KEYPOINT (osk$entry, 0, pmk$format_compact_time);

    status.normal := TRUE;

    pmp$verify_compact_time (date_time, status);

    IF status.normal THEN
      validate_time_format (format, time.time_format, time_form_string, status);

      IF status.normal THEN
        format_compact_time (date_time, time_form_string, time);
      IFEND;
    IFEND;

    #KEYPOINT (osk$exit, 0, pmk$format_compact_time);

  PROCEND pmp$format_compact_time;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_compact_date_time', EJECT ??
*copy pmh$get_compact_date_time

  PROCEDURE [XDCL, #GATE] pmp$get_compact_date_time
    (VAR date_time: ost$date_time;
     VAR status: ost$status);

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, 0, pmk$get_compact_date_time);

    status.normal := TRUE;

    pmp$get_date_time_at_timestamp (#FREE_RUNNING_CLOCK (0), pmc$use_system_local_time, date_time, status);

    #KEYPOINT (osk$exit, 0, pmk$get_compact_date_time);

*ELSE
    VAR
      hour: integer,
      ignore_isdst: integer,
      ignore_wday: integer,
      ignore_yday: integer,
      mday: integer,
      min: integer,
      month: integer,
      sec: integer,
      wday: integer,
      yday: integer,
      year: integer;


    status.normal := TRUE;
    pmp_get_date_time (sec, min, hour, mday, month, year, wday, yday,
          ignore_isdst);

    date_time.millisecond := 0;
    date_time.second := sec;
    date_time.minute := min;
    date_time.hour := hour;
    date_time.day := mday;
    date_time.month := month + 1;
    date_time.year := year;

    pmp$verify_compact_date (date_time, status);
    IF status.normal THEN
      pmp$verify_compact_time (date_time, status);
    IFEND;

*IFEND

  PROCEND pmp$get_compact_date_time;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_date', EJECT ??
*copy pmh$get_date

  PROCEDURE [XDCL, #GATE] pmp$get_date
    (    date_format: ost$date_formats;
     VAR date: ost$date;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      date_time: ost$date_time;

    #KEYPOINT (osk$entry, 0, pmk$get_date);

    status.normal := TRUE;
    local_status.normal := TRUE;

    validate_date_format (date_format, date.date_format, local_status);

    IF local_status.normal THEN
      pmp$get_compact_date_time (date_time, local_status);

      IF local_status.normal THEN
        format_compact_date (date_time, date);
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, pmk$get_date);

  PROCEND pmp$get_date;
?? OLDTITLE ??
*IF NOT $true(osv$unix)
?? NEWTITLE := '[XDCL, #GATE] pmp$get_date_time_at_timestamp', EJECT ??
*copy pmh$get_date_time_at_timestamp

  PROCEDURE [XDCL, #GATE] pmp$get_date_time_at_timestamp
    (    timestamp: integer;
         time_zone: pmt$use_time_zone;
     VAR date_time: ost$date_time;
     VAR status: ost$status);

    CONST
      c$ms_per_day = 24 * 60 * 60 * 1000;

    VAR
      base_system_time: ost$base_system_time,
      day: integer,
      days_in_the_month_p: ^ARRAY [1 .. 12] OF 1 .. 31,
      elapsed_time: integer,
      hour: -1 .. 47,
      minute: -30 .. 119,
      month: 1 .. 13,
      second: 0 .. 119,
      system_time_zone: ost$time_zone,
      year: 0 .. c$max_years;

    status.normal := TRUE;

    system_time_zone := osv$os_defaults.system_time_zone;
    base_system_time := osv$base_system_time;

    elapsed_time {ms} := (timestamp {us} - base_system_time.corresponding_microsecond_clock {us}) DIV 1000
          {us/ms};

    elapsed_time := elapsed_time + (base_system_time.hour * 3600 + base_system_time.minute *
          60 + base_system_time.second) * 1000;
    IF time_zone = pmc$use_universal_time THEN
      elapsed_time := elapsed_time - (system_time_zone.hours_from_gmt *
            3600 + system_time_zone.minutes_offset * 60) * 1000;
      IF system_time_zone.daylight_saving_time THEN
        elapsed_time := elapsed_time - 3600 * 1000;
      IFEND;
    IFEND;

    day := base_system_time.day + (elapsed_time DIV c$ms_per_day);
    elapsed_time := elapsed_time MOD c$ms_per_day;
    IF elapsed_time < 0 THEN
      elapsed_time := elapsed_time + c$ms_per_day;
      day := day - 1;
    IFEND;

    date_time.millisecond := elapsed_time {ms} MOD 1000 {ms} ;

    elapsed_time {sec} := elapsed_time {ms} DIV 1000 {ms/sec} ;
    date_time.second := elapsed_time {sec} MOD 60 {sec} ;

    elapsed_time {min} := elapsed_time {sec} DIV 60 {sec/min} ;
    date_time.minute := elapsed_time {min} MOD 60 {min} ;

    elapsed_time {hr} := elapsed_time {min} DIV 60 {min/hr} ;
    date_time.hour := elapsed_time {hr} MOD 24 {hr} ;

    month := base_system_time.month;
    year := base_system_time.year;

    IF pmp$this_is_a_leap_year (year) THEN
      days_in_the_month_p := ^v$leap_year;
    ELSE
      days_in_the_month_p := ^v$non_leap_year;
    IFEND;

    WHILE day < 1 DO
      IF month = 1 THEN
        month := 13;
        IF (year - 1 {yr} ) < LOWERVALUE (year) THEN
          osp$set_status_condition (pme$computed_year_out_of_range, status);
          RETURN;
        IFEND;
        year := year - 1;
        IF pmp$this_is_a_leap_year (year) THEN
          days_in_the_month_p := ^v$leap_year;
        ELSE
          days_in_the_month_p := ^v$non_leap_year;
        IFEND;
      IFEND;
      month := month - 1;
      day := day + days_in_the_month_p^ [month];
    WHILEND;

    WHILE day > days_in_the_month_p^ [month] DO
      day := day - days_in_the_month_p^ [month];
      month := month + 1 {mo} ;

      IF month > 12 {mo} THEN
        IF (year + 1 {yr} ) > UPPERVALUE (year) THEN
          osp$set_status_condition (pme$computed_year_out_of_range, status);
          RETURN;
        IFEND;

        month := 1 {mo} ;
        year := year + 1 {yr} ;

        IF pmp$this_is_a_leap_year (year) THEN
          days_in_the_month_p := ^v$leap_year;
        ELSE
          days_in_the_month_p := ^v$non_leap_year;
        IFEND;
      IFEND;
    WHILEND;

    date_time.day := day;
    date_time.month := month;
    date_time.year := year - 1900;

  PROCEND pmp$get_date_time_at_timestamp;
?? OLDTITLE ??
*IFEND
?? NEWTITLE := '[XDCL, #GATE] pmp$get_default_date_time_form', EJECT ??
*copy pmh$get_default_date_time_form

  PROCEDURE [XDCL, #GATE] pmp$get_default_date_time_form
    (VAR date_default: ost$default_date_format;
     VAR time_default: ost$default_time_format);

    date_default := osv$os_defaults.system_date_format;
    time_default := osv$os_defaults.system_time_format;

  PROCEND pmp$get_default_date_time_form;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_legible_date_time', EJECT ??
*copy pmh$get_legible_date_time

  PROCEDURE [XDCL, #GATE] pmp$get_legible_date_time
    (    date_format: ost$date_formats;
     VAR date: ost$date;
         time_format: ost$time_formats;
     VAR time: ost$time;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      date_time: ost$date_time,
      time_form_string: string (clc$max_date_time_form_string);

    #KEYPOINT (osk$entry, 0, pmk$get_legible_date_time);

    local_status.normal := TRUE;
    status.normal := TRUE;

    validate_date_format (date_format, date.date_format, local_status);

    IF local_status.normal THEN
      validate_time_format (time_format, time.time_format, time_form_string, local_status);

      IF local_status.normal THEN
        pmp$get_compact_date_time (date_time, local_status);

        IF local_status.normal THEN
          format_compact_time (date_time, time_form_string, time);
          format_compact_date (date_time, date);
        IFEND;
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;

    #KEYPOINT (osk$exit, 0, pmk$get_legible_date_time);

  PROCEND pmp$get_legible_date_time;
?? OLDTITLE ??
*IF NOT $true(osv$unix)
?? NEWTITLE := '[XDCL] pmp$get_system_time', EJECT ??
*copy pmh$get_system_time

  PROCEDURE [XDCL] pmp$get_system_time
    (VAR system_time: pmt$system_time;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      date_time: ost$date_time;

    local_status.normal := TRUE;
    status.normal := TRUE;

    system_time.free_running_clock := #FREE_RUNNING_CLOCK (0);
    pmp$get_date_time_at_timestamp (system_time.free_running_clock, pmc$use_system_local_time, date_time,
          local_status);
    IF local_status.normal THEN
      system_time.year := date_time.year + 1900;
      system_time.month := date_time.month;
      system_time.day := date_time.day;
      system_time.hour := date_time.hour;
      system_time.minute := date_time.minute;
      system_time.second := date_time.second;
      system_time.millisecond := date_time.millisecond;
    ELSE
      status := local_status;
    IFEND;
  PROCEND pmp$get_system_time;
?? OLDTITLE ??
*IFEND
?? NEWTITLE := '[XDCL, #GATE] pmp$get_time', EJECT ??
*copy pmh$get_time

  PROCEDURE [XDCL, #GATE] pmp$get_time
    (    time_format: ost$time_formats;
     VAR time: ost$time;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      date_time: ost$date_time,
      time_form_string: string (clc$max_date_time_form_string);

    #KEYPOINT (osk$entry, 0, pmk$get_time);

    local_status.normal := TRUE;
    status.normal := TRUE;

    validate_time_format (time_format, time.time_format, time_form_string, local_status);

    IF local_status.normal THEN
      pmp$get_compact_date_time (date_time, local_status);

      IF local_status.normal THEN
        format_compact_time (date_time, time_form_string, time);
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
    #KEYPOINT (osk$exit, 0, pmk$get_time);

  PROCEND pmp$get_time;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_time_zone', EJECT ??
*copy pmh$get_time_zone

  PROCEDURE [XDCL, #GATE] pmp$get_time_zone
    (VAR time_zone: ost$time_zone;
     VAR status: ost$status);

    #KEYPOINT (osk$entry, 0, pmk$get_time_zone);

    status.normal := TRUE;

    time_zone := osv$os_defaults.system_time_zone;

    #KEYPOINT (osk$exit, 0, pmk$get_time_zone);

  PROCEND pmp$get_time_zone;
?? OLDTITLE ??
*IF NOT $true(osv$unix)
?? NEWTITLE := '[XDCL, #GATE] pmp$get_universal_date_time', EJECT ??
*copy pmh$get_universal_date_time

  PROCEDURE [XDCL, #GATE] pmp$get_universal_date_time
    (VAR universal_date_time: ost$date_time;
     VAR status: ost$status);

    #KEYPOINT (osk$entry, 0, pmk$get_universal_date_time);

    status.normal := TRUE;

    pmp$get_date_time_at_timestamp (#FREE_RUNNING_CLOCK (0), pmc$use_universal_time, universal_date_time,
          status);

    #KEYPOINT (osk$exit, 0, pmk$get_universal_date_time);

  PROCEND pmp$get_universal_date_time;
?? OLDTITLE ??
*IFEND
?? NEWTITLE := '[XDCL, #GATE] pmp$verify_compact_date', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$verify_compact_date
    (    date: ost$date_time;
     VAR status: ost$status);

    status.normal := TRUE;

    IF (date.year < LOWERVALUE (date.year)) OR (date.year > UPPERVALUE (date.year)) THEN
      osp$set_status_condition (pme$invalid_year, status);
      osp$append_status_integer (osc$status_parameter_delimiter, date.year, 10, FALSE, status);
      RETURN;
    IFEND;

    IF (date.month < 1) OR (date.month > 12) THEN
      osp$set_status_condition (pme$invalid_month, status);
      osp$append_status_integer (osc$status_parameter_delimiter, date.month, 10, FALSE, status);
      RETURN;
    IFEND;

    IF pmp$this_is_a_leap_year (date.year + 1900 {yr} ) THEN
      IF (date.day < 1) OR (date.day > v$leap_year [date.month]) THEN
        osp$set_status_condition (pme$invalid_day, status);
        osp$append_status_integer (osc$status_parameter_delimiter, date.day, 10, FALSE, status);
        RETURN;
      IFEND;
    ELSE
      IF (date.day < 1) OR (date.day > v$non_leap_year [date.month]) THEN
        osp$set_status_condition (pme$invalid_day, status);
        osp$append_status_integer (osc$status_parameter_delimiter, date.day, 10, FALSE, status);
        RETURN;
      IFEND;
    IFEND;

  PROCEND pmp$verify_compact_date;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$verify_compact_time', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$verify_compact_time
    (    time: ost$date_time;
     VAR status: ost$status);

    status.normal := TRUE;

    IF time.millisecond > 999 THEN
      osp$set_status_condition (pme$invalid_millisecond, status);
      osp$append_status_integer (osc$status_parameter_delimiter, time.millisecond, 10, FALSE, status);
      RETURN;
    IFEND;

    IF time.second > 59 THEN
      osp$set_status_condition (pme$invalid_second, status);
      osp$append_status_integer (osc$status_parameter_delimiter, time.second, 10, FALSE, status);
      RETURN;
    IFEND;

    IF time.minute > 59 THEN
      osp$set_status_condition (pme$invalid_minute, status);
      osp$append_status_integer (osc$status_parameter_delimiter, time.minute, 10, FALSE, status);
      RETURN;
    IFEND;

    IF time.hour > 23 THEN
      osp$set_status_condition (pme$invalid_hour, status);
      osp$append_status_integer (osc$status_parameter_delimiter, time.hour, 10, FALSE, status);
      RETURN;
    IFEND;
  PROCEND pmp$verify_compact_time;
?? OLDTITLE ??
MODEND pmm$system_time_requests;
*DECK DECK=PMM$TASKING_HELPER_PROCEDURES EXPAND=TRUE
PMM$TASKING_HELPER_PROCEDURES  ident

*copyc sya$cybil_interface_procedures
*copyc sya$constants
*copyc sya$xp_and_sf_constants
*copyc osa$basic_register_equates

         use       code
         page
.
.
.-------------------------------------------------------------------------------
.
.  PROCEDURE [XDCL] pmp$return_to_outward_call_sfsa
.      (outward_call_sfsa: ^ost$stack_frame_save_area);
.
.  PURPOSE:
.    This procedure is a helper for PMP$OUTWARD_CALL.
.    This procedure returns to a stack_frame_save_area passed to it as an argument.
.    The stack_frame_save_area must reside in a less privileged ring.  This procedure
.    POPs all stack frames in the ring in which it is called, resets its PSA to point
.    to the target stack_frame_save_area, and executes a RETURN.
.-------------------------------------------------------------------------------
.
.
         def       RETRN
RETRN    alias     PMP$RETURN_TO_OUTWARD_CALL_SFSA
RETRN    procedur
sfsa     param     val,pointer
.
         isob      x2,x0,x0,0403(16) .isolate caller ring
.
         lx        x4,a3,bs_rcpclr   .Ring crossing procedure PVA
         isob      x4,x4,x0,2453(8)  .Isolate segment and offset
         lx        x6,a3,bs_rtprc    .End of ring crossing procedure PVA
         isob      x6,x6,x0,2453(8)  .Isolate segment and offset

return_1 cpyax     x3,a_psa
         isob      x3,x3,x0,0403(16) .isolate ring in a_psa
         brrne     x2,x3,return_2    .if ring crossing
         lx        x5,a_psa,0        .previous stack frame P
         isob      x5,x5,x0,2453(8)  .Isolate segment and offset
         brxge     x5,x6,pop_it      .If not in ring crossing procedure
         brxge     x5,x4,return_3    .If in ring crossing procedure
pop_it   pop
         brreq     x0,x0,return_1
.
return_2 ploada    a_psa,sfsa        .load target sfsa pointer
         return
.
return_3 ploada    a5,sfsa           .load target sfsa pointer
         sa        a5,a_psa,26       .Change ring crossing proc to
                                     .return to target sfsa.
         return
         page
.
.
.-------------------------------------------------------------------------------
.
.  PROCEDURE [XDCL] PMP$POP_3_STACK_FRAMES
.      (pad_size: ost$segment_offset);
.
.  PURPOSE:
.    This procedure is a helper for PMP$POP_ALL_STACK_FRAMES.
.    This procedure and PMP$INTRA_RING_POPPER operate as coroutines which POP all of
.    the stack frames in the ring in which they are activated.  The intra_ring_popper
.    is partitioned into coroutines in order to minimize the amount of code written
.    in assembly language.  Each time it is called this procedure POPs three stack
.    frames -- a frame for PMP$INTRA_RING_POPPER, a frame for the previous instance of
.    PMP$POP_3_STACK_FRAMES, and the next user frame to be processed.  When the
.    POPs have been performed, DSP is reset in order to prevent unwarranted stack growth.
.-------------------------------------------------------------------------------
.
.
.
.
         use       code
         def       pop3
POP3     alias     PMP$POP_3_STACK_FRAMES
pop3     procedur
pad_size param     val,subrange,4
.
         ploadx    xf,pad_size
         pop
         pop
         la        af,a_psa,10       .save original DSP value
         pop
         addaq     af,af,8           .insure space for condition handler stack
         cpyaa     ae,af
         addax     ae,xf             .increase DSP by pad_size
         addaq     a_dsp,ae,8        .increase DSP by ap_list size
         sa        af,ae,2           .store ap_list value
         ente      x0,00120(16)
         callseg   cbp,a_bindin,ae   .call PMP$INTRA_RING_POPPER
.
.  This return instruction is needed to seperate this procedure from the next
.  procedure so as to prevent confusion when this procedure's SFSA is saved on
.  the callseg.  The SFSA must not have PMP$CALL_RING_CROSSING_PROC's PVA as P.
.
         return
         page
.
.  PMP$CALL_RING_CROSSING_PROC
.
.  This purpose of this procedure is to call PMP$RING_CROSSING_PROCEDURE
.  when the possibility for a RING ALARM exists.
.  The FREE FLAG will be set when returning across the ring boundary.
.
.  local definitions
.
.  The following constant specifies a Frame Descriptor for a stack frame save area of
.  28(16) bytes.  This is used in conjunction with the CYBIL constant
.  mmc$ring_crossing_offset defined in the deck mmt$page_map_offsets.  Any changes to
.  This area must be reflected in that deck as well as the assembly language deck
.  sym$core_trap_handler.
.
x_enviro   equ      0130(16)        .Descriptor for CALL.
x_enviro_1 equ      0140(16)        .Descriptor for CALL.
.
. Stack frame offsets
.
plist     equ      8                       .Stack - start of param list
sframe    equ      plist+128               .Stack - Area to save live registers
svarlen   equ      sframe+216              .Length of stack variable area
          page
.
.  Ring Crossing Procedure Caller
.
          use      code
          def      rcpcalr
rcpcalr   alias    PMP$CALL_RING_CROSSING_PROC
rcpcalr   bss      0
          entl     x0,r_td                 .Disable traps
          cpyxs    x0,x0
          addaq    a0,a1,svarlen           .Push stack frame
          ente     x0,41ff(16)             .Descriptor for SMULT
          smult    x0,a1,sframe            .Save A4 - AF, X1 - XF

.
. Call PMP$RING_CROSSING_PROCEDURE.
.
          ente     x0,x_enviro             .Set frame descriptor.
          callseg  bs_rcp,a3,a0            .Call the procedure.
.
          cpyaa    a0,a1                   .POP the space we PUSHed.
.
. Now call the procedure rtproc to do the actual return so that the
. proper value for TOS is preserved.
.
          ente     x0,x_enviro             .Set frame descriptor.
          callseg  bs_rtprc,a3,a0          .Callee does not return to caller.
.
. WARNING - This procedure must follow the pmp$call_ring_crossing_proc
.           in order for pmp$return_to_outward_sfsa to work.  That procedure
.           makes a test to see if the P address is in the range of rcpcalr
.           to rtproc.
.
          def      rtproc
rtproc    alias    PMP$RING_CROSSING_PROC_RETURN
          align    0,8
.
rtproc    bss      0
          addaq    a0,a1,svarlen           .Push stack frame
          la       a4,a2,18                .Get callers CSF.
          la       a2,a2,26                .Use callers PSA.  This POPs caller.
.
. The following field definition is used to support the PSFSA instruction which is
. required for CYBER-2000 but is not available in the ASSEMBLER language yet.
. When it is available, replace the VFD line with the following line:
.         psfsa                            .Purge the SFSA pushdown (CYBER-2000 only)
.
          vfd,16   0701(16)                .Purge SFSA pushdown (CYBER-2000 only)
.
.  Call pmp$enable_job_free_flag.
.
          ente     x0,x_enviro_1
          callseg  bs_free,a3,a0
          entl     x0,r_ted                .Set TRAP-ENABLE-DELAY.
          cpyxs    x0,x0
          brcr     2,5,rtproc1             .Set Free Flag.
.
rtproc1   bss      0
          cpyaa    a0,a1                   .POP the space we PUSHed.
.
          ente     x0,41ff(16)             .Descriptor for LMULT
          lmult    x0,a4,sframe            .Restore A4 - AF, X1 - XF
          return
.
          page
.
.  Binding Section
.
          use      binding
.
         ref       procname
PROCNAME alias     PMP$INTRA_RING_POPPER
cbp      address   c,procname
.
          ref      rcp
rcp       alias    PMP$RING_CROSSING_PROCEDURE
bs_rcp    address  c,rcp
.
          ref      freeflag
freeflag  alias    PMP$ENABLE_JOB_FREE_FLAG
bs_free   address  c,freeflag
.
bs_rcpclr address  c,rcpcalr
.
bs_rtprc  address  c,rtproc

          end
*DECK DECK=PMM$TASKING_INTERFACES_RING_N EXPAND=TRUE
?? RIGHT := 110 ??
*copyc OSD$DEFAULT_PRAGMATS
?? TITLE := 'NOS/VE : Tasking : Execute/Wait Interfaces' ??
?? NEWTITLE := '  Global declarations', EJECT ??
MODULE pmm$tasking_interfaces_ring_n;

{  PURPOSE:
{    This module contains tasking program interfaces which run in the
{    ring of their caller so that the requests are responsive to
{    interactive breaks.
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_ID
*copyc OST$STATUS
*copyc OSK$KEYPOINTS
*copyc OSS$JOB_PAGED_LITERAL
*copyc OST$CALLER_IDENTIFIER
*copyc PMT$LOADER_SEQ_DESCRIPTOR
*copyc PMK$KEYPOINTS
?? POP ??

*copyc CLP$CONVERT_STRING_TO_FILE
*copyc FSP$OPEN_FILE
*copyc FSP$CLOSE_FILE
*copyc PMP$ESTABLISH_CONDITION_HANDLER
*copyc PMP$DISESTABLISH_COND_HANDLER
*copyc PMP$ESTABLISH_SEGMENT_ACCESS
*copyc PMP$AWAIT_TASK
*copyc PMP$EXECUTE_TASK
*copyc PMP$EXECUTE_PROCEDURE_AS_TASK
*copyc OSP$SET_STATUS_ABNORMAL


  VAR
    block_exit: [STATIC, READ, oss$job_paged_literal] pmt$condition := [pmc$condition_combination,
      $pmt$condition_combination [pmc$block_exit_processing]];

?? TITLE := '  [XDCL, #GATE] pmp$execute' ??
?? NEWTITLE := '    ensure_synchronization' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$execute (program_description: pmt$program_description;
        program_parameters: pmt$program_parameters;
        wait: ost$wait;
    VAR task_id: pmt$task_id;
    VAR task_status: pmt$task_status;
    VAR status: ost$status);

*copyc PMH$EXECUTE

?? EJECT ??

    VAR
      execute_task_id: pmt$task_id,
      ignore_status: ost$status;

    VAR
      mpe_description: [STATIC, READ, oss$job_paged_literal] pmt$loader_description := [FALSE, * , * ];

    PROCEDURE ensure_synchronization (condition: pmt$condition;
          condition_descriptor: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR ensure_status: ost$status);

      IF status.normal THEN
        pmp$await_task_termination (execute_task_id, ignore_status);
        task_id := execute_task_id;
      IFEND;
      ensure_status.normal := TRUE;
    PROCEND ensure_synchronization;

?? OLDTITLE ??

    VAR
      caller: ost$caller_identifier,
      nonlocal_exit: pmt$established_handler;

    #caller_id (caller);
    #KEYPOINT (osk$entry, 0, pmk$execute);
    task_status.complete := FALSE;
    status.normal := TRUE;
    task_id := LOWERVALUE (pmt$task_id);
    execute_task_id := LOWERVALUE (pmt$task_id);
    CASE wait OF
    = osc$wait =
      pmp$establish_condition_handler (block_exit, ^ensure_synchronization, ^nonlocal_exit, ignore_status);
      pmp$execute_task (caller.ring, program_description, mpe_description, program_parameters, osc$null_name,
            wait, FALSE, execute_task_id, task_status, status);
      IF status.normal THEN
        task_id := execute_task_id;
        pmp$await_task_termination (execute_task_id, status);
      IFEND;
      pmp$disestablish_cond_handler (block_exit, ignore_status);
    = osc$nowait =
      pmp$execute_task (caller.ring, program_description, mpe_description, program_parameters, osc$null_name,
            wait, FALSE, task_id, task_status, status);
    ELSE
      osp$set_status_abnormal ('PM', pme$invalid_wait_parameter, '', status);
    CASEND;
    #KEYPOINT (osk$exit, (1 - ORD (status.normal)) * 0, pmk$execute);
  PROCEND pmp$execute;

?? TITLE := '  [XDCL, #GATE] pmp$execute_procedure' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$execute_procedure (starting_procedure: pmt$user_program;
        parameters: pmt$program_parameters;
        critical_frame: ^ost$stack_frame_save_area;
    VAR task_id: pmt$task_id;
    VAR task_status: pmt$task_status;
    VAR status: ost$status);

*copyc PMH$EXECUTE_PROCEDURE


    VAR
      ignore_status: ost$status,
      caller: ost$caller_identifier;

    #caller_id (caller);
    #KEYPOINT (osk$entry, 0, pmk$execute_procedure);
    task_status.complete := FALSE;
    status.normal := TRUE;
    task_id := LOWERVALUE (pmt$task_id);
    pmp$execute_procedure_as_task (caller.ring, starting_procedure, parameters, critical_frame,
            task_id, task_status, status);
    #KEYPOINT (osk$exit, (1 - ORD (status.normal)) * 0, pmk$execute_procedure);
  PROCEND pmp$execute_procedure;
?? TITLE := '  [XDCL, #GATE] pmp$execute_with_apd' ??
?? NEWTITLE := '    ensure_synchronization' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$execute_with_apd (program_description: pmt$program_description;
        mpe_description: pmt$loader_description;
        program_parameters: pmt$program_parameters;
        wait: ost$wait;
    VAR task_id: pmt$task_id;
    VAR task_status: pmt$task_status;
    VAR status: ost$status);
*copyc PMH$EXECUTE

    VAR
      execute_task_id: pmt$task_id,
      ignore_status: ost$status;

    PROCEDURE ensure_synchronization (condition: pmt$condition;
          condition_descriptor: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR ensure_status: ost$status);

      IF status.normal THEN
        pmp$await_task_termination (execute_task_id, ignore_status);
        task_id := execute_task_id;
      IFEND;
      ensure_status.normal := TRUE;
    PROCEND ensure_synchronization;

?? OLDTITLE ??

    VAR
      caller: ost$caller_identifier,
      nonlocal_exit: pmt$established_handler;

    #caller_id (caller);
    task_status.complete := FALSE;
    status.normal := TRUE;
    task_id := LOWERVALUE (pmt$task_id);
    execute_task_id := LOWERVALUE (pmt$task_id);
    CASE wait OF
    = osc$wait =
      pmp$establish_condition_handler (block_exit, ^ensure_synchronization, ^nonlocal_exit, ignore_status);
      pmp$execute_task (caller.ring, program_description, mpe_description, program_parameters, osc$null_name,
            wait, FALSE, execute_task_id, task_status, status);
      IF status.normal THEN
        task_id := execute_task_id;
        pmp$await_task_termination (execute_task_id, status);
      IFEND;
      pmp$disestablish_cond_handler (block_exit, ignore_status);
    = osc$nowait =
      pmp$execute_task (caller.ring, program_description, mpe_description, program_parameters, osc$null_name,
            wait, FALSE, task_id, task_status, status);
    ELSE
      osp$set_status_abnormal ('PM', pme$invalid_wait_parameter, '', status);
    CASEND;
  PROCEND pmp$execute_with_apd;
?? TITLE := '  [XDCL, #GATE] pmp$await_task_termination', EJECT ??
?? NEWTITLE := '    ensure_wait_complete' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$await_task_termination (task_id: pmt$task_id;
    VAR status: ost$status);

*copyc PMH$AWAIT_TASK_TERMINATION

    VAR
      await_complete: boolean;



    PROCEDURE ensure_synchronization (condition: pmt$condition;
          condition_descriptor: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR ensure_status: ost$status);

      IF NOT await_complete THEN
        pmp$await_task_termination (task_id, status);
      IFEND;
      ensure_status.normal := TRUE;
    PROCEND ensure_synchronization;

?? OLDTITLE ??

    VAR
      nonlocal_exit: pmt$established_handler,
      await_status: ost$status,
      ignore_status: ost$status;

    await_complete := FALSE;
    status.normal := TRUE;
    #KEYPOINT (osk$entry, task_id MOD 100000(16) * osk$m, pmk$await_task_termination);
    pmp$establish_condition_handler (block_exit, ^ensure_synchronization, ^nonlocal_exit, ignore_status);
    REPEAT
      pmp$await_task (task_id, await_complete, await_status);
    UNTIL await_complete OR NOT await_status.normal;
    pmp$disestablish_cond_handler (block_exit, ignore_status);
    status := await_status;
    #KEYPOINT (osk$exit, (1 - ORD (status.normal)) * 0, pmk$await_task_termination);
  PROCEND pmp$await_task_termination;
?? TITLE := '  [XDCL, #GATE] pmp$execute_with_less_privilege' ??
?? NEWTITLE := '    ensure_synchronization' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$execute_with_less_privilege (target_ring: ost$valid_ring;
        program_description: pmt$program_description;
        program_parameters: pmt$program_parameters;
        wait: ost$wait;
        cl_task:boolean;
    VAR task_id: pmt$task_id;
    VAR task_status: pmt$task_status;
    VAR status: ost$status);

*copyc PMH$EXECUTE_WITH_LESS_PRIVILEGE

    VAR
      execute_task_id: pmt$task_id,
      ignore_status: ost$status;

    PROCEDURE ensure_synchronization (condition: pmt$condition;
          condition_descriptor: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR ensure_status: ost$status);

      IF status.normal THEN
        pmp$await_task_termination (execute_task_id, ignore_status);
        task_id := execute_task_id;
      IFEND;
      ensure_status.normal := TRUE;
    PROCEND ensure_synchronization;
?? OLDTITLE ??

    CONST
      no_command_file = osc$null_name;

    VAR
      caller: ost$caller_identifier,
      nonlocal_exit: pmt$established_handler;

    VAR
      mpe_description: [STATIC, READ, oss$job_paged_literal] pmt$loader_description := [FALSE, * , * ];

    #caller_id (caller);
    #KEYPOINT (osk$entry, 0, pmk$execute_with_less_privilege);
    IF (target_ring >= caller.ring) THEN
      task_status.complete := FALSE;
      status.normal := TRUE;
      task_id := LOWERVALUE (pmt$task_id);
      execute_task_id := LOWERVALUE (pmt$task_id);
      CASE wait OF
      = osc$wait =
        pmp$establish_condition_handler (block_exit, ^ensure_synchronization, ^nonlocal_exit, ignore_status);
        pmp$execute_task (target_ring, program_description, mpe_description, program_parameters,
              no_command_file, wait, cl_task, execute_task_id, task_status, status);
        IF status.normal THEN
          task_id := execute_task_id;
          pmp$await_task_termination (execute_task_id, status);
        IFEND;
        pmp$disestablish_cond_handler (block_exit, ignore_status);
      = osc$nowait =
        pmp$execute_task (target_ring, program_description, mpe_description, program_parameters,
              no_command_file, wait, cl_task, task_id, task_status, status);
      ELSE
        osp$set_status_abnormal ('PM', pme$invalid_wait_parameter, '', status);
      CASEND;
    ELSE
      osp$set_status_abnormal ('PM', pme$target_ring_error, '', status);
    IFEND;
    #KEYPOINT (osk$exit, (1 - ORD (status.normal)) * 0, pmk$execute_with_less_privilege);
  PROCEND pmp$execute_with_less_privilege;
?? TITLE := '  [XDCL, #GATE] pmp$execute_with_command_file' ??
?? NEWTITLE := '    ensure_synchronization' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$execute_with_command_file (target_ring: ost$valid_ring;
        program_description: pmt$program_description;
        program_parameters: pmt$program_parameters;
        command_file: amt$local_file_name;
        wait: ost$wait;
        cl_task:boolean;
    VAR task_id: pmt$task_id;
    VAR task_status: pmt$task_status;
    VAR status: ost$status);

*copyc pmh$execute_with_command_file

    VAR
      execute_task_id: pmt$task_id,
      ignore_status: ost$status;

    PROCEDURE ensure_synchronization (condition: pmt$condition;
          condition_descriptor: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR ensure_status: ost$status);

      IF status.normal THEN
        pmp$await_task_termination (execute_task_id, ignore_status);
        task_id := execute_task_id;
      IFEND;
      ensure_status.normal := TRUE;
    PROCEND ensure_synchronization;
?? OLDTITLE ??

    VAR
      caller: ost$caller_identifier,
      nonlocal_exit: pmt$established_handler;

    VAR
      mpe_description: [STATIC, READ, oss$job_paged_literal] pmt$loader_description := [FALSE, * , * ];

    #caller_id (caller);
    IF (target_ring >= caller.ring) THEN
      task_status.complete := FALSE;
      status.normal := TRUE;
      task_id := LOWERVALUE (pmt$task_id);
      execute_task_id := LOWERVALUE (pmt$task_id);
      CASE wait OF
      = osc$wait =
        pmp$establish_condition_handler (block_exit, ^ensure_synchronization, ^nonlocal_exit, ignore_status);
        pmp$execute_task (target_ring, program_description, mpe_description, program_parameters, command_file,
              wait, cl_task, execute_task_id, task_status, status);
        IF status.normal THEN
          task_id := execute_task_id;
          pmp$await_task_termination (execute_task_id, status);
        IFEND;
        pmp$disestablish_cond_handler (block_exit, ignore_status);
      = osc$nowait =
        pmp$execute_task (target_ring, program_description, mpe_description, program_parameters, command_file,
              wait, cl_task, task_id, task_status, status);
      ELSE
        osp$set_status_abnormal ('PM', pme$invalid_wait_parameter, '', status);
      CASEND;
    ELSE
      osp$set_status_abnormal ('PM', pme$target_ring_error, '', status);
    IFEND;
  PROCEND pmp$execute_with_command_file;
?? TITLE := '  [XDCL, #GATE] pmp$open_common_block_file', EJECT ??
  PROCEDURE [XDCL, #GATE] pmp$open_common_block_file (file: fst$file_reference;
        common_block: pmt$program_name;
    VAR segment_pointer: amt$segment_pointer;
    VAR status: ost$status);

*copyc pmh$open_common_block_file

    VAR
      file1: clt$file,
      file_identifier: amt$file_identifier,
      usage_attributes: array [1 .. 3] of fst$attachment_option,
      ignore_status: ost$status,
      caller_id: ost$caller_identifier;

    #keypoint (osk$entry, 0, pmk$open_common_block_file);
    status.normal := TRUE;
    #caller_id (caller_id);

    clp$convert_string_to_file (file, file1, ignore_status);
    usage_attributes [1].selector := fsc$validation_ring;
    usage_attributes [1].validation_ring := caller_id.ring;
    usage_attributes [2].selector := fsc$access_and_share_modes;
    usage_attributes [2].access_modes.selector := fsc$permitted_access_modes;
    usage_attributes [2].share_modes.selector := fsc$required_share_modes;
    usage_attributes [3].selector := fsc$create_file;
    usage_attributes [3].create_file := TRUE;

    fsp$open_file (file1.local_file_name, amc$segment, ^usage_attributes, NIL, NIL, NIL, NIL,
               file_identifier, status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, 0, pmk$open_common_block_file);
      RETURN
    IFEND;

    pmp$establish_segment_access (file_identifier, common_block, segment_pointer, status);

    IF NOT status.normal THEN
      fsp$close_file (file_identifier, ignore_status);
    IFEND;

    #keypoint (osk$exit, 0, pmk$open_common_block_file);

  PROCEND pmp$open_common_block_file;
MODEND pmm$tasking_interfaces_ring_n;
*DECK DECK=PMM$TASKING_SUPPORT_RING_1 EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE : Tasking : Ring 1 support' ??
?? NEWTITLE := '  Global declarations', EJECT ??
MODULE pmm$tasking_support_ring_1;



{  PURPOSE:
{    This module contains ring 1 procedures and data structures necessary to support tasking.
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc mmt$io_control_block
*copyc mmt$iocb_index
*copyc pme$execution_exceptions
*copyc pmp$send_signal
*copyc pmt$condition_name
*copyc pmt$task_cp_time
*copyc PMT$TASK_ID
*copyc OST$EXECUTION_CONTROL_BLOCK
*copyc OST$STATUS
*copyc OSE$HEAP_FULL_EXCEPTIONS
*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*copyc TME$MONITOR_MODE_EXCEPTIONS
*copyc OST$WAIT
*copyc OST$GLOBAL_TASK_ID
*copyc OSS$JOB_FIXED
*copyc OSC$PROCESSOR_DEFINED_REGISTERS
*copyc OSD$CODE_BASE_POINTER
*copyc tmc$signal_identifiers
*copyc OST$HEAP
*copyc OSK$KEYPOINTS
*copyc PMT$STACK_SEGMENT
*copyc PMK$KEYPOINTS
*copyc tmt$primary_task_list
?? POP ??
*copyc OSP$EXPAND_PTL
*copyc OSP$SYSTEM_ERROR
*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSP$INITIALIZE_SIG_LOCK
*copyc OSP$SET_MAINFRAME_SIG_LOCK
*copyc OSP$CLEAR_MAINFRAME_SIG_LOCK
*copyc I#CALL_MONITOR
*copyc JMP$JOB_MONITOR_XCB
*copyc PMP$CYCLE
*copyc pmp$get_task_cp_time
*copyc SYP$CYCLE
*copyc JMV$JCB
*copyc JMV$TASK_PRIVATE_TEMPL_P
*copyc OSV$JOB_FIXED_HEAP
*copyc PMV$TASK_TEMPLATE

  VAR
{!  This variable should be defined locally when system generator supports sections properly.
    job_xcb_list: [XREF, oss$job_fixed] record
      head: ^ost$execution_control_block,
      lock: ost$signature_lock,
    recend;

  CONST
    unexpected_abnormal_status = 'unexpected abnormal status';

?? TITLE := '  [XDCL, #GATE] pmp$initialize_task_xcb', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$initialize_job_xcb_list (job_monitor_task_id: pmt$task_id;
        job_monitor_tcb: ^cell;
        trap_handler: ^procedure);

{  PURPOSE:
{    This procedure adds the job_monitor XCB to the job XCB list and sets the trap handler pointer.

*copyc JMV$JOB_TRAP_HANDLER


    VAR
      xcb: ^ost$execution_control_block,
      local_status: ost$status;

{!  Temporary until locks can be initialized statically.
    osp$initialize_sig_lock (job_xcb_list.lock);
{!  End temporary code.
    xcb := jmp$job_monitor_xcb ();
    xcb^.link := NIL;
    xcb^.task_id := job_monitor_task_id;
    xcb^.task_control_block := #ADDRESS (osc$tmtr_ring, #SEGMENT (job_monitor_tcb),
        #OFFSET (job_monitor_tcb));
    xcb^.received_message_list.fill := 0;
    xcb^.received_message_list.next_received_message := NIL;
    xcb^.save9 {task_name} := '$JOBMNTR';
    job_xcb_list.head := xcb;
    jmv$job_trap_handler := trap_handler;
    pmv$task_template := jmv$task_private_templ_p;
  PROCEND pmp$initialize_job_xcb_list;
?? TITLE := '  [XDCL, #GATE] pmp$find_task_xcb', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$find_task_xcb (task_id: pmt$task_id;
    VAR xcb: ^ost$execution_control_block);

*copyc PMH$FIND_TASK_XCB

    lock_job_xcb_list;
    xcb := job_xcb_list.head;
    WHILE (xcb <> NIL) AND (xcb^.task_id <> task_id) DO
      xcb := xcb^.link;
    WHILEND;
    unlock_job_xcb_list;
  PROCEND pmp$find_task_xcb;
?? TITLE := '  [XDCL, #GATE] pmp$get_executing_task_gtid', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_executing_task_gtid (VAR global_task_id: ost$global_task_id);

*copyc PMH$GET_EXECUTING_TASK_GTID

    VAR
      xcb: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb);
    global_task_id := xcb^.global_task_id;
  PROCEND pmp$get_executing_task_gtid;
?? TITLE := '  [XDCL, #GATE] pmp$find_executing_task_xcb', EJECT ??

*copyc pmp$find_executing_task_xcb

?? TITLE := '  [XDCL, #GATE] pmp$create_child_xcb', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$create_child_xcb
    (    task_id: pmt$task_id;
         task_control_block: ^cell;
         initial_procedure: ^procedure;
         initial_ring: ost$ring;
         task_kind: ost$task_kind;
     VAR status: ost$status);

{  PURPOSE:
{    This procedure creates an XCB for a new child task and adds it to the job XCB list.

    VAR
      xcb,
      parent_xcb: ^ost$execution_control_block,
      osv$default_pit: [XREF] integer,
      code_base_pointer: ^ost$external_code_base_pointer,
      converter: record
        case 0 .. 3 of
        = 0 =
          procedure_pointer: ^procedure,
        = 1 =
          code_base_pointer: ^ost$external_code_base_pointer,
        = 2 =
          pva: ost$pva,
        = 3 =
          cell_p: ^cell,
        casend,
      recend;

    ALLOCATE xcb IN osv$job_fixed_heap^;
    IF #offset (xcb) > UPPERVALUE (tmt$xcb_offset_size) THEN
      FREE xcb IN osv$job_fixed_heap^;
      osp$set_status_abnormal ('PM', pme$xcb_offset_exceeds_maximum, '', status);
      RETURN;
    IFEND;
    xcb^ := pmv$task_template^.xcb;
    converter.procedure_pointer := initial_procedure;
    code_base_pointer := converter.code_base_pointer;
    xcb^.xp.p_register.pva.ring := initial_ring;
    xcb^.xp.p_register.pva.seg := #segment (code_base_pointer^.code_pva);
    xcb^.xp.p_register.pva.offset := #offset (code_base_pointer^.code_pva);
    xcb^.xp.a3 := #address (initial_ring, #segment (code_base_pointer^.binding_pva), #offset
          (code_base_pointer^.binding_pva));
    converter.pva := xcb^.xp.tos_registers [initial_ring].pva;
    xcb^.xp.a0_dynamic_space_pointer := converter.cell_p;
    xcb^.xp.a1_current_stack_frame := converter.cell_p;
    xcb^.xp.base_constant_1 := #offset (xcb) DIV 10000(16);
    xcb^.xp.base_constant_2 := #offset (xcb) MOD 10000(16);
    xcb^.xp.process_interval_timer_1 := osv$default_pit DIV 10000(16);
    xcb^.xp.process_interval_timer_2 := osv$default_pit MOD 10000(16);
    xcb^.pit_count := osv$default_pit;
    xcb^.task_id := task_id;
    xcb^.task_control_block := task_control_block;
    xcb^.received_message_list.fill := 0;
    xcb^.received_message_list.next_received_message := NIL;
    xcb^.task_kind := task_kind;
    xcb^.save9 {task_name} := osc$null_name;
    pmp$find_executing_task_xcb (parent_xcb);
    xcb^.processor_selections := parent_xcb^.processor_selections;
    xcb^.requested_processor_selections := parent_xcb^.requested_processor_selections;
    xcb^.relative_task_priority := 128;
    xcb^.dispatching_priority := parent_xcb^.dispatching_priority;
    xcb^.dispatching_priority_bias_id := parent_xcb^.dispatching_priority_bias_id;
    xcb^.dispatching_priority_bias := parent_xcb^.dispatching_priority_bias;
    lock_job_xcb_list;
    xcb^.link := job_xcb_list.head;
    job_xcb_list.head := xcb;
    unlock_job_xcb_list;

  PROCEND pmp$create_child_xcb;
?? TITLE := '  [XDCL, #GATE] pmp$release_child_xcb', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$release_child_xcb (task_id: pmt$task_id;
    VAR child_tcb: ^cell);

{  PURPOSE:
{    This procedure removes a child task's XCB from the job XCB list and frees the space occupied
{    by the XCB.

    VAR
      predecessor: ^^ost$execution_control_block,
      child_xcb: ^ost$execution_control_block;

    lock_job_xcb_list;
    predecessor := ^job_xcb_list.head;
    WHILE (predecessor^ <> NIL) AND (predecessor^^.task_id <> task_id) DO
      predecessor := ^predecessor^^.link;
    WHILEND;
    IF predecessor^ = NIL THEN
      unlock_job_xcb_list;
      osp$system_error ('child XCB lost', NIL);
    ELSE
      child_xcb := predecessor^;
      predecessor^ := child_xcb^.link;
      unlock_job_xcb_list;

      child_tcb := child_xcb^.task_control_block;

      FREE child_xcb IN osv$job_fixed_heap^;
    IFEND;
  PROCEND pmp$release_child_xcb;
?? TITLE := '  lock_job_xcb_list', EJECT ??

  PROCEDURE [INLINE] lock_job_xcb_list;

    VAR
      local_status: ost$status;

    osp$set_mainframe_sig_lock (job_xcb_list.lock);
  PROCEND lock_job_xcb_list;
?? TITLE := '  unlock_job_xcb_list', EJECT ??

  PROCEDURE [INLINE] unlock_job_xcb_list;

    VAR
      local_status: ost$status;

    osp$clear_mainframe_sig_lock (job_xcb_list.lock);
  PROCEND unlock_job_xcb_list;
?? TITLE := '  [XDCL, #GATE] pmp$initiate_child_task', EJECT ??

*copyc PMT$SPY_IDENTIFIER

  PROCEDURE [XDCL, #GATE] pmp$initiate_child_task (child: pmt$task_id;
        spy_identifier: pmt$spy_identifier;
        wait: ost$wait;
        VAR child_initiated: BOOLEAN);

{  PURPOSE:
{    This procedure issues the monitor request to activate a new child task.
*copyc TMT$RB_INITIATE_TASK

    VAR
      request_block: tmt$rb_initiate_task,
      local_status: ost$status;

    request_block.reqcode := syc$rc_initiate_task;
    pmp$find_task_xcb (child, request_block.xcb_p);
    IF spy_identifier > UPPERVALUE (pmt$spy_identifier) THEN
      osp$system_error ('invalid spy identifier', NIL);
    ELSE
      request_block.xcb_p^.xp.p_register.global_key := spy_identifier;
    IFEND;
    request_block.wait := osc$nowait;

  /issue_system_call/
    WHILE TRUE DO
      i#call_monitor (#LOC (request_block), #SIZE (request_block));
      IF request_block.status.normal THEN
        child_initiated := TRUE;
        RETURN
      ELSE
        IF request_block.status.condition = tme$ptl_full THEN
          osp$expand_ptl ({ unconditionally_expand } FALSE, local_status);
          IF NOT local_status.normal THEN
            child_initiated := FALSE;
            RETURN
          IFEND;
        ELSE
          osp$system_error (unexpected_abnormal_status, NIL);
        IFEND;
      IFEND;
    WHILEND /issue_system_call/;
  PROCEND pmp$initiate_child_task;
?? TITLE := '  [XDCL, #GATE] pmp$task_end', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$task_end (executing_task_id: pmt$task_id;
        parent_id: ost$global_task_id);

{  PURPOSE:
{    This procedure issues the monitor request to terminate task execution.
{  DESIGN:
{    If the task has an I/O control block for asynchronous I/O, the task must
{    cycle until all active I/O has completed.  The IOCB is freed, then the
{    monitor request to terminate task execution is issued.

*copyc TMT$RB_TASK_EXIT

    VAR
      io_active: boolean,
      iocb_index: mmt$iocb_index,
      iocb_ptr: ^mmt$io_control_block,
      local_status: ost$status,
      request_block: tmt$rb_task_exit,
      signal_contents_converter: ^^pmt$signal_contents,
      task_id: ^pmt$task_id,
      xcb_p: ^ost$execution_control_block;

      pmp$find_executing_task_xcb (xcb_p);
      IF xcb_p^.iocb_p <> NIL THEN

{ Wait for any active io to complete.  When all I/O is complete, free the iocb.

        iocb_ptr := xcb_p^.iocb_p;
        io_active := TRUE;
        WHILE io_active DO
          io_active := FALSE;
          /check_io_active/
          FOR iocb_index := LOWERBOUND (iocb_ptr^.iocb_table) TO iocb_ptr^.maximum_iocb_index_in_use DO
            IF iocb_ptr^.iocb_table [iocb_index].active_io_count > 0 THEN
              io_active := TRUE;
              pmp$cycle (local_status);
              EXIT /check_io_active/;
            IFEND;
          FOREND /check_io_active/;
        WHILEND;
        FREE xcb_p^.iocb_p IN osv$job_fixed_heap^;
      IFEND;

    request_block.reqcode := syc$rc_task_exit;
    request_block.signal.identifier := pmc$ss_child_terminated;
    task_id := ^executing_task_id;
    signal_contents_converter := #LOC (task_id);
    request_block.signal.contents := signal_contents_converter^^;
    request_block.parent_global_task_id := parent_id;

    #KEYPOINT (osk$exit, 0, pmk$task_begin_end);

  /issue_system_call/
    WHILE TRUE DO
      i#call_monitor (#LOC (request_block), #SIZE (request_block));
      IF request_block.status.normal THEN
        EXIT /issue_system_call/
      ELSEIF request_block.status.condition = tme$mtr_signal_buffers_full THEN
        pmp$cycle (local_status);
        IF NOT local_status.normal THEN
          osp$system_error (unexpected_abnormal_status, ^local_status);
        IFEND;
      ELSE
        osp$system_error (unexpected_abnormal_status, NIL);
      IFEND;
    WHILEND /issue_system_call/;
  PROCEND pmp$task_end;
?? TITLE := '  [XDCL, #GATE] pmp$update_tos_ring_1', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$update_tos_ring_1 (top_of_stack: ^cell);


    VAR
      converter: record
        case 0 .. 1 of
        = 0 =
          pva: ost$pva,
        = 1 =
          cell_pointer: ^cell,
        casend,
      recend,

      xcb: ^ost$execution_control_block,
      pva: ost$pva;


    pmp$find_executing_task_xcb (xcb);

    converter.cell_pointer := top_of_stack;
    pva := converter.pva;


    IF pva.seg = xcb^.xp.tos_registers [pva.ring].pva.seg THEN
      xcb^.xp.tos_registers [pva.ring].pva.offset := pva.offset;
    ELSE
      {! should never get here, but just in case.
    IFEND;


  PROCEND pmp$update_tos_ring_1;
?? TITLE := '  TEMPORARY procedures to support HCS tasking', EJECT ??
*copyc PMT$RAW_TASK_STATISTICS
?? NEWTITLE := '    [XDCL, #GATE] pmp$collect_raw_task_statistics', EJECT ??

{ PURPOSE:
{   The purpose of this request is to collect statistics for the
{   system command language DISPLAY_ACTIVE_TASKS command.
{
{ NOTES:
{   This procedure should only be used if approximate CPU statistics are
{   desired since the method of obtaining them (from xcb.cp_time) are not
{   accurate - the last task_time_slice is omitted.

  PROCEDURE [XDCL, #GATE] pmp$collect_raw_task_statistics (VAR active_task_count: 0 .. pmc$max_task_id;
    VAR active_task_statistics: array [1 .. * ] OF pmt$raw_task_statistics);

    VAR
      xcb: ^ost$execution_control_block;

    active_task_count := 0;
    lock_job_xcb_list;
    xcb := job_xcb_list.head;
    WHILE (xcb <> NIL) AND (active_task_count < UPPERBOUND (active_task_statistics)) DO
      active_task_count := active_task_count + 1;
      active_task_statistics [active_task_count].task_name := xcb^.save9 {task_name} ;
      active_task_statistics [active_task_count].cp_time.task_time :=
        xcb^.cp_time.time_spent_in_job_mode;
      active_task_statistics [active_task_count].cp_time.monitor_time :=
        xcb^.cp_time.time_spent_in_mtr_mode;
      active_task_statistics [active_task_count].page_fault_count := xcb^.paging_statistics.page_fault_count;
      xcb := xcb^.link;
    WHILEND;
    WHILE (xcb <> NIL) DO
      active_task_count := active_task_count + 1;
      xcb := xcb^.link;
    WHILEND;
    unlock_job_xcb_list;
  PROCEND pmp$collect_raw_task_statistics;
?? TITLE := '    [XDCL, #GATE] pmp$record_task_name', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$record_task_name (task_name: ost$name;
        override_old_name: boolean);

    VAR
      xcb: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb);
    IF override_old_name OR (xcb^.save9 {task_name} = osc$null_name) THEN
      xcb^.save9 {task_name} := task_name;
    IFEND;
  PROCEND pmp$record_task_name;
?? TITLE := '   [XDCL, #GATE] pmp$set_relative_priority_r1 ', EJECT ??

   PROCEDURE [XDCL, #GATE] pmp$set_relative_priority_r1
     (    priority: 0 .. 255);

{ The following procedure is the ring one interface to modify
{ or set the relative priority of a task. The relative priority
{ of a task is used in determining the dispatching order of the
{ task.

     VAR
       xcb_p: ^ost$execution_control_block;

     pmp$find_executing_task_xcb (xcb_p);

     xcb_p^.relative_task_priority := priority;
     xcb_p^.system_give_up_cpu := TRUE;
     jmv$jcb.ijle_p^.relative_priority_enabled := TRUE;

{ Issue a cycle request to force the task out of the DCT chain. This
{ will force the task to be re-positioned into the DCT chain at
{ the new priority.

     syp$cycle;

  PROCEND pmp$set_relative_priority_r1;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$cause_condition_in_tasks', EJECT ??
*copy pmh$cause_condition_in_tasks

    PROCEDURE [XDCL, #GATE] pmp$cause_condition_in_tasks
      (    condition_name: pmt$condition_name);

      VAR
        condition_name_p: ^pmt$condition_name,
        ignore_status: ost$status,
        signal: pmt$signal,
        xcb_p: ^ost$execution_control_block;

      signal.identifier := pmc$multi_task_condition;
      condition_name_p := #LOC (signal.contents);
      condition_name_p^ := condition_name;

      lock_job_xcb_list;
      xcb_p := job_xcb_list.head;
      WHILE (xcb_p <> NIL) DO
        pmp$send_signal (xcb_p^.global_task_id, signal, ignore_status);
        xcb_p := xcb_p^.link;
      WHILEND;
      unlock_job_xcb_list;
    PROCEND pmp$cause_condition_in_tasks;
?? OLDTITLE ??
MODEND pmm$tasking_support_ring_1;
*DECK DECK=PMM$TASKING_SUPPORT_RING_2 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Tasking : Ring 2 support' ??
MODULE pmm$tasking_support_ring_2;

{  PURPOSE:
{    This module contains ring 2 procedures and data structures necessary to support tasking.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc pmt$task_id
*copyc pmh$tmm$manage_signals_and_flag
*copyc pmt$task_control_block
*copyc clc$standard_file_names
*copyc pme$execution_exceptions
*copyc pmt$program_description
*copyc pmt$loader_seq_descriptor
*copyc pmt$max_number_of_tasks
*copyc pmt$program_parameters
*copyc pmt$os_stack_frame_word
*copyc pmt$task_status
*copyc osd$virtual_address
*copyc ost$status
*copyc ose$heap_full_exceptions
*copyc pme$debug_exceptions
*copyc pme$execution_exceptions
*copyc oss$job_pageable
*copyc ost$signature_lock_status
*copyc ost$stack_frame_save_area
?? POP ??
*copyc clp$find_current_job_synch_task
*copyc jmp$job_monitor_xcb
*copyc osp$clear_job_signature_lock
*copyc osp$fetch_locked_variable
*copyc osp$increment_locked_variable
*copyc osp$initialize_sig_lock
*copyc osp$set_job_signature_lock
*copyc osp$system_error
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$trap_handler
*copyc mmp$change_segment_inheritance
*copyc mmp$close_shared_stack
*copyc mmp$create_inherited_sdt
*copyc mmp$create_segment
*copyc mmp$create_shared_stack
*copyc mmp$delete_inherited_sdt
*copyc mmp$delete_non_inherited_segs
*copyc mmp$task_delete_inherited_sdt
*copyc pmp$create_child_xcb
*copyc pmp$release_child_xcb
*copyc pmp$cycle
*copyc pmp$exit
*copyc pmp$initialize_job_xcb_list
*copyc pmp$find_task_xcb
*copyc pmp$find_executing_task_xcb
*copyc pmp$find_executing_task_tcb
*copyc pmp$get_global_task_id
*copyc pmp$set_system_flag
*copyc sfp$update_job_limit_accum
*copyc tmp$find_ring_crossing_frame
*copyc oss$job_paged_literal
*copyc osv$job_pageable_heap
*copyc osv$task_shared_heap
*copyc pmv$popper_handler_established
*copyc pmv$task_execution_phase


  VAR
    pmv$ada_task_table_lock: [STATIC, oss$job_pageable] ost$signature_lock,
    pmv$job_monitor_tcb_p: [XDCL, #GATE, oss$job_pageable] ^pmt$task_control_block,
    pmv$task_control_block_lock: [STATIC, oss$job_pageable] ost$signature_lock,
    pmv$job_initialization_complete: [XDCL, #GATE, oss$job_pageable] boolean := FALSE,
    mpe_description: [STATIC, oss$job_pageable] pmt$loader_description := [FALSE, * , * ];

?? FMT (FORMAT := OFF) ??

  VAR
    tcb_proto: [STATIC, READ, oss$job_paged_literal] pmt$task_control_block := [
{ task_id                       } 0,
{ parent                        } NIL,
{ first_child                   } NIL,
{ next_sibling                  } NIL,
{ target_ring                   } osc$invalid_ring,
{ condition_environment_stack   } NIL,
{ flag_execution_ring           } [REP osc$maximum_system_flag + 1 of 0],
{ signal_execution_ring         } [0, 0, 0, 0],
{ task_local_signal_list        } [NIL, NIL],
{ task_kill_count               } 0,
{ task_kill_phase               } LOWERVALUE (pmt$task_execution_phase),
{ task_kind                     } osc$tk_nosve_task, [
{   program_description           } NIL,
{   mpe_description               } ^mpe_description,
{   program_parameters            } NIL,
{   termination_status            } NIL,
{   parent_task_status_variable   } NIL,
{   debug_table                   } NIL,
{   debug_input                   } clc$null_file,
{   debug_output                  } clc$null_file,
{   abort_file                    } clc$null_file,
{   initial_debug_mode            } pmc$debug_mode_off,
{   cl_task                       } FALSE,
{   ada_shared_stack_pointer      } [mmc$cell_pointer, NIL],
{   ada_critical_frame            } NIL,
{   ada_starting_procedure        } NIL,
{   ada_task_table                } NIL,
{   task_condition_count          } 0,
{   task_handler_count            } 0,
{   task_io_enabled               } TRUE]];

?? FMT (FORMAT := ON) ??

  VAR
    debug_table_proto: [STATIC, READ, oss$job_paged_literal] pmt$debug_table_info :=
          [[mmc$sequence_pointer, NIL], [mmc$sequence_pointer, NIL], NIL, NIL, NIL, NIL, 0];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$initialize_tasking_tables', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$initialize_tasking_tables
    (    job_monitor_initial_ring: ost$ring;
         job_monitor_program_description: ^pmt$program_description;
         job_monitor_parameters: ^pmt$program_parameters);

{  PURPOSE:
{    This procedure is responsible for initializing all tasking tables at job initiation and
{    generating entries in them for the job_monitor task.

    ALLOCATE pmv$job_monitor_tcb_p IN osv$job_pageable_heap^;
    pmv$job_monitor_tcb_p^ := tcb_proto;
    ALLOCATE pmv$job_monitor_tcb_p^.nosve.termination_status IN osv$task_shared_heap^;
    assign_task_id (pmv$job_monitor_tcb_p^.task_id);
    ALLOCATE pmv$job_monitor_tcb_p^.nosve.debug_table IN osv$task_shared_heap^;
    pmv$job_monitor_tcb_p^.nosve.debug_table^ := debug_table_proto;
    pmv$job_monitor_tcb_p^.nosve.program_description := job_monitor_program_description;
    pmv$job_monitor_tcb_p^.nosve.program_parameters := job_monitor_parameters;
    pmv$job_monitor_tcb_p^.nosve.termination_status^.normal := TRUE;
    pmv$job_monitor_tcb_p^.target_ring := job_monitor_initial_ring;
    osp$initialize_sig_lock (pmv$task_control_block_lock);
    osp$initialize_sig_lock (pmv$ada_task_table_lock);
    pmp$initialize_job_xcb_list (pmv$job_monitor_tcb_p^.task_id, pmv$job_monitor_tcb_p, ^pmp$trap_handler);
    pmv$job_initialization_complete := TRUE;
  PROCEND pmp$initialize_tasking_tables;
?? TITLE := '  [XDCL, #GATE] pmp$update_jmtr_tcb_target_ring', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$update_jmtr_tcb_target_ring
    (    job_monitor_initial_ring: ost$ring);

    VAR
      xcb: ^ost$execution_control_block,
      tcb: ^pmt$task_control_block;

    xcb := jmp$job_monitor_xcb ();
    tcb := xcb^.task_control_block;
    tcb^.target_ring := job_monitor_initial_ring;
  PROCEND pmp$update_jmtr_tcb_target_ring;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$create_shared_stack', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$create_shared_stack
    (    segment_attributes: ^array [ * ] of mmt$attribute_descriptor;
     VAR status: ost$status);

    VAR
      tcb: ^pmt$task_control_block,
      entry: pmt$max_number_of_tasks,
      entry1: pmt$max_number_of_tasks,
      task_ids: ^array [1 .. * ] of pmt$task_id;

{ Get the pointer to our task control block.

    pmp$find_executing_task_tcb (tcb);

{  Lock ada_task_table so that it is not altered during stack creation.

    osp$set_job_signature_lock (pmv$ada_task_table_lock);

{ Get task table from task control block.

    PUSH task_ids: [1 .. tcb^.nosve.ada_task_table^.current_entry + 1];
    entry1 := 1;
    FOR entry := 0 TO tcb^.nosve.ada_task_table^.current_entry DO
      task_ids^ [entry1] := tcb^.nosve.ada_task_table^.table [entry];
      entry1 := entry1 + 1;
    FOREND;

{ Call Memory Manager to create the shared stack.

    mmp$create_shared_stack (segment_attributes, mmc$cell_pointer, task_ids,
          tcb^.nosve.ada_shared_stack_pointer, status);

{  Unlock ada_task_table.

    osp$clear_job_signature_lock (pmv$ada_task_table_lock);

  PROCEND pmp$create_shared_stack;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$find_task_tcb', EJECT ??
*copy pmh$find_task_tcb

  PROCEDURE [XDCL, #GATE] pmp$find_task_tcb
    (    task_id: pmt$task_id;
     VAR tcb: ^pmt$task_control_block);

    VAR
      xcb: ^ost$execution_control_block;

    pmp$find_task_xcb (task_id, xcb);
    IF xcb = NIL THEN
      tcb := NIL;
    ELSE
      tcb := xcb^.task_control_block;
    IFEND;
  PROCEND pmp$find_task_tcb;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$create_task_environment', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$create_task_environment
    (    program_description: ^pmt$program_description;
         mpe_description: ^pmt$loader_description;
         program_parameters: ^pmt$program_parameters;
         parent_task_status_variable: ^pmt$task_status;
         target_ring: ost$ring;
         critical_frame: ^ost$stack_frame_save_area;
         starting_procedure: pmt$user_program;
         cl_task: boolean;
     VAR task_id: pmt$task_id;
     VAR status: ost$status);

{  PURPOSE:
{    This procedure is responsible for creating a fundamental task environment for a new
{    child task.

*copyc pmp$task_begin
?? NEWTITLE := '  create_child_tcb', EJECT ??

    PROCEDURE create_child_tcb
      (    task_id: pmt$task_id;
           program_description: ^pmt$program_description;
           mpe_description: ^pmt$loader_description;
           program_parameters: ^pmt$program_parameters;
           parent_task_status_variable: ^pmt$task_status;
           target_ring: ost$ring;
           cl_task: boolean;
       VAR child_tcb: ^pmt$task_control_block);

      VAR
        zero_length_sequence: [oss$job_pageable] SEQ (REP 0 of cell);

{  PURPOSE:
{    This procedure creates a TCB for a new child task.

      ALLOCATE child_tcb IN osv$job_pageable_heap^;
      child_tcb^ := tcb_proto;
      ALLOCATE child_tcb^.nosve.program_description: [[REP #SIZE (program_description^) OF cell]] IN
            osv$job_pageable_heap^;
      ALLOCATE child_tcb^.nosve.mpe_description IN osv$job_pageable_heap^;
      IF #SIZE (program_parameters^) > 0 THEN
        ALLOCATE child_tcb^.nosve.program_parameters: [[REP #SIZE (program_parameters^) OF cell]] IN
              osv$job_pageable_heap^;
      ELSE
        child_tcb^.nosve.program_parameters := ^zero_length_sequence;
      IFEND;
      ALLOCATE child_tcb^.nosve.termination_status IN osv$task_shared_heap^;
      ALLOCATE child_tcb^.nosve.debug_table IN osv$task_shared_heap^;
      child_tcb^.task_id := task_id;
      child_tcb^.nosve.debug_table^ := debug_table_proto;
      pmp$find_executing_task_tcb (child_tcb^.parent);

{  Lock parent_child list.  (Necessary if anyone other than parent scans child list.)

      osp$set_job_signature_lock (pmv$task_control_block_lock);

      child_tcb^.next_sibling := child_tcb^.parent^.first_child;
      child_tcb^.parent^.first_child := child_tcb;

{ The inheritance of the timesharing IO capability needs to be protected by a the lock to ensure that a task
{ does not get disabled from doing IO even after all conditions within the parent synchronous task chain have
{ disappeared.  For example:
{   Task A is the parent of task B.  Task B has IO disabled because of a condition in task A.  Task B begins
{ to create task C's environment.  Task A completes the conditions and begins to update the task environment.
{ There is a risk that task C will get its IO disabled by task B after task A has started updating
{ (re-enabling IO) in the appropriate tasks.

      child_tcb^.nosve.task_io_enabled := child_tcb^.parent^.nosve.task_io_enabled;

{  Unlock parent_child list.

      osp$clear_job_signature_lock (pmv$task_control_block_lock);

      child_tcb^.nosve.program_description^ := program_description^;
      child_tcb^.nosve.mpe_description^ := mpe_description^;
      child_tcb^.nosve.program_parameters^ := program_parameters^;
      child_tcb^.nosve.termination_status^.normal := TRUE;
      child_tcb^.nosve.parent_task_status_variable := parent_task_status_variable;
      child_tcb^.target_ring := target_ring;
      child_tcb^.nosve.cl_task := cl_task;

    PROCEND create_child_tcb;
?? OLDTITLE ??
?? NEWTITLE := ' create_ada_environment', EJECT ??

    PROCEDURE create_ada_environment
      (    child: ^pmt$task_control_block;
       VAR status: ost$status);

{  PURPOSE:
{    This procedure is responsible for adding the ADA asynchronous procedure information
{    into the task control block of a child task.
{

      IF NOT ((child^.parent^.nosve.ada_task_table <> NIL) AND
            (child^.parent^.nosve.ada_task_table^.current_entry <
            UPPERBOUND (child^.parent^.nosve.ada_task_table^.table))) THEN
        osp$set_status_abnormal ('PM', pme$no_available_stacks, '', status);
        osp$clear_job_signature_lock (pmv$ada_task_table_lock);
        RETURN
      IFEND;

      child^.nosve.ada_critical_frame := critical_frame^.minimum_save_area.a1_current_stack_frame;
      child^.nosve.ada_task_table := child^.parent^.nosve.ada_task_table;
      child^.nosve.ada_task_table^.current_entry := child^.nosve.ada_task_table^.current_entry + 1;
      child^.nosve.ada_task_table^.table [child^.nosve.ada_task_table^.current_entry] := task_id;
      child^.nosve.ada_starting_procedure := starting_procedure;
      osp$clear_job_signature_lock (pmv$ada_task_table_lock);

    PROCEND create_ada_environment;
?? OLDTITLE ??
?? NEWTITLE := 'copy_parent_debug_tables', EJECT ??

    PROCEDURE copy_parent_debug_tables
      (    child: ^pmt$task_control_block;
       VAR status: ost$status);

{  PURPOSE:
{    This procedure is responsible for copying the debug table information from the parent's
{    address space into the address space of the asynchronous procedure being initiated.
{

      VAR
        pva: ^cell,
        ring_attributes: array [1 .. 1] of mmt$attribute_descriptor;

{  Copy Parent Task debug tables.

      ring_attributes [1].keyword := mmc$kw_ring_numbers;
      ring_attributes [1].r1 := osc$tsrv_ring;
      ring_attributes [1].r2 := 0f(16);

      IF child^.parent^.nosve.debug_table^.module_segment.seq_pointer <> NIL THEN
        mmp$create_segment (^ring_attributes, mmc$sequence_pointer, 1,
              child^.nosve.debug_table^.module_segment, status);
        IF status.normal THEN
          child^.nosve.debug_table^.last_module_item := ^child^.nosve.debug_table^.
                first_module_address_table_item;
          RESET child^.nosve.debug_table^.module_segment.seq_pointer;
          child^.parent^.nosve.debug_table^.current_module_item :=
                child^.parent^.nosve.debug_table^.first_module_address_table_item;

        /copy_module_segment/
          WHILE child^.parent^.nosve.debug_table^.current_module_item <> NIL DO
            NEXT child^.nosve.debug_table^.current_module_item:
                  [0 .. child^.parent^.nosve.debug_table^.current_module_item^.greatest_section_ordinal] IN
                  child^.nosve.debug_table^.module_segment.seq_pointer;
            IF child^.nosve.debug_table^.current_module_item <> NIL THEN
              child^.nosve.debug_table^.current_module_item^ :=
                    child^.parent^.nosve.debug_table^.current_module_item^;
            ELSE
              osp$set_status_abnormal ('PM', pme$module_segment_overflow, '', status);
              EXIT /copy_module_segment/;
            IFEND;

            child^.nosve.debug_table^.last_module_item^ := child^.nosve.debug_table^.current_module_item;
            child^.nosve.debug_table^.last_module_item := ^child^.nosve.debug_table^.last_module_item^^.
                  next_module;
            child^.parent^.nosve.debug_table^.current_module_item :=
                  child^.parent^.nosve.debug_table^.current_module_item^.next_module;
          WHILEND /copy_module_segment/;

          child^.parent^.nosve.debug_table^.current_module_item := NIL;
          child^.nosve.debug_table^.current_module_item := NIL;

          IF status.normal THEN
            pva := child^.nosve.debug_table^.module_segment.seq_pointer;
            mmp$change_segment_inheritance (pva, mmc$si_transfer_segment, status);
          IFEND;

          IF status.normal AND (child^.parent^.nosve.debug_table^.entry_point_segment.seq_pointer <> NIL) THEN
            mmp$create_segment (^ring_attributes, mmc$sequence_pointer, 1,
                  child^.nosve.debug_table^.entry_point_segment, status);
            IF status.normal THEN
              RESET child^.nosve.debug_table^.entry_point_segment.seq_pointer;
              RESET child^.parent^.nosve.debug_table^.entry_point_segment.seq_pointer;
              NEXT child^.parent^.nosve.debug_table^.entry_point_table:
                    [1 .. child^.parent^.nosve.debug_table^.number_of_entry_point_items] IN
                    child^.parent^.nosve.debug_table^.entry_point_segment.seq_pointer;
              NEXT child^.nosve.debug_table^.entry_point_table:
                    [1 .. child^.parent^.nosve.debug_table^.number_of_entry_point_items] IN
                    child^.nosve.debug_table^.entry_point_segment.seq_pointer;
              IF child^.nosve.debug_table^.entry_point_table <> NIL THEN
                child^.nosve.debug_table^.entry_point_table^ :=
                      child^.parent^.nosve.debug_table^.entry_point_table^;
                child^.nosve.debug_table^.number_of_entry_point_items :=
                      child^.parent^.nosve.debug_table^.number_of_entry_point_items;
                pva := child^.nosve.debug_table^.entry_point_segment.seq_pointer;
                mmp$change_segment_inheritance (pva, mmc$si_transfer_segment, status);
              ELSE
                osp$set_status_abnormal ('PM', pme$entry_pt_segment_overflow, '', status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

    PROCEND copy_parent_debug_tables;
?? OLDTITLE, EJECT ??

    VAR
      local_status: ost$status,
      child_tcb: ^pmt$task_control_block,
      ignored_status: ost$status;

    sfp$update_job_limit_accum (avc$task_limit_name, 1, sfc$incremental_update, status);
    IF NOT status.normal THEN
      IF status.condition = sfe$limit_not_activated THEN
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    assign_task_id (task_id);
    IF starting_procedure <> NIL THEN
      osp$set_job_signature_lock (pmv$ada_task_table_lock);
    IFEND;

{!! NOTE: The procedure calls in this routine are order dependent.  IF the order is changed
{         without changing the reasons for the current order, the routine is gaurenteed
{         to break!

    create_child_tcb (task_id, program_description, mpe_description, program_parameters,
          parent_task_status_variable, target_ring, cl_task, child_tcb);
    pmp$create_child_xcb (task_id, child_tcb, ^pmp$task_begin, osc$tsrv_ring, child_tcb^.task_kind, status);
    IF status.normal THEN
      IF starting_procedure <> NIL THEN
        copy_parent_debug_tables (child_tcb, status);
      IFEND;
      IF status.normal THEN
        mmp$create_inherited_sdt (task_id, status);
        IF status.normal THEN
          IF starting_procedure <> NIL THEN
            create_ada_environment (child_tcb, status);

{!! NOTE:  Procedure create_ada_environment unlocks the ada_task_table.

          IFEND;
          IF status.normal THEN
            RETURN
          IFEND;
          mmp$delete_inherited_sdt (task_id, local_status);
          IF NOT local_status.normal THEN
            osp$system_error ('Error in clean up after create_ada_environment failed',
                  ^local_status);
          IFEND;
        IFEND;
      IFEND;
      pmp$release_child_xcb (task_id, child_tcb);
    IFEND;
    release_child_tcb (child_tcb);
    sfp$update_job_limit_accum (avc$task_limit_name, -1, sfc$incremental_update, ignored_status);

  PROCEND pmp$create_task_environment;
?? TITLE := '  assign_task_id', EJECT ??

  PROCEDURE assign_task_id
    (VAR task_id: pmt$task_id);

{  PURPOSE:
{    This procedure selects a task_id for assignment to a new task.

    TYPE
      pmt$task_id_last_assigned = record
        value: ALIGNED [0 MOD 8] ost$compare_swap_lock,
      recend;

    VAR
      initial_value: integer,
      new_task_id: integer,
      xcb: ^ost$execution_control_block,
      task_id_last_assigned: [STATIC] pmt$task_id_last_assigned := [UPPERVALUE (pmt$task_id)];

    REPEAT
      osp$fetch_locked_variable (task_id_last_assigned.value, initial_value);
      osp$increment_locked_variable (task_id_last_assigned.value, initial_value, new_task_id);
      task_id := new_task_id;
      pmp$find_task_xcb (task_id, xcb);
    UNTIL xcb = NIL;
  PROCEND assign_task_id;
?? TITLE := '  [XDCL, #GATE] pmp$fix_initial_debug' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$fix_initial_debug
    (    task_debug_mode: pmt$debug_mode;
         debug_input: amt$local_file_name;
         debug_output: amt$local_file_name;
         abort_file: amt$local_file_name);

    VAR
      tcb: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb);
    tcb^.nosve.initial_debug_mode := task_debug_mode;
    tcb^.nosve.debug_input := debug_input;
    tcb^.nosve.debug_output := debug_output;
    tcb^.nosve.abort_file := abort_file;
  PROCEND pmp$fix_initial_debug;
?? TITLE := '  [XDCL, #GATE] pmp$delete_non_inherited_segs' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$delete_non_inherited_segs
    (VAR status: ost$status);

{  PURPOSE:
{    This procedure is responsible for releasing all non-inherited segments
{    from the terminating task.


    VAR
      tcb: ^pmt$task_control_block;


    pmp$find_executing_task_tcb (tcb);
    IF tcb^.nosve.ada_starting_procedure <> NIL THEN
      unlink_ada_environment (tcb);
    IFEND;
    mmp$delete_non_inherited_segs (status);
  PROCEND pmp$delete_non_inherited_segs;
?? TITLE := '  [XDCL, #GATE] pmp$release_task_environment', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$release_task_environment
    (    task_id: pmt$task_id);

{  PURPOSE:
{    This procedure is responsible for releasing the space occupied by a terminated child
{    task's fundamental task environment.

    VAR
      child_tcb: ^pmt$task_control_block,
      xcb: ^ost$execution_control_block,
      ignored_status: ost$status,
      local_status: ost$status;


    pmp$find_task_xcb (task_id, xcb);
    WHILE NOT xcb^.task_has_terminated DO
      pmp$cycle (local_status);
    WHILEND;

    mmp$task_delete_inherited_sdt (task_id, local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('unexpected abnormal status', ^local_status);
    IFEND;
    pmp$release_child_xcb (task_id, child_tcb);
    release_child_tcb (child_tcb);
    sfp$update_job_limit_accum (avc$task_limit_name, -1, sfc$incremental_update, ignored_status);
  PROCEND pmp$release_task_environment;
?? TITLE := '  release_child_tcb', EJECT ??

  PROCEDURE release_child_tcb
    (VAR child_tcb: ^pmt$task_control_block);

{  PURPOSE:
{    This procedure releases the space occupied by a child task's TCB.

    VAR
      sibling: ^^pmt$task_control_block;

{  Lock parent_child list.  (Necessary if anyone other than parent scans child list.)

    osp$set_job_signature_lock (pmv$task_control_block_lock);

    sibling := ^child_tcb^.parent^.first_child;

  /delink_parent_child_tree/
    WHILE (sibling^ <> NIL) AND (sibling^ <> child_tcb) DO
      sibling := ^sibling^^.next_sibling;
    WHILEND /delink_parent_child_tree/;
    IF sibling^ = NIL THEN

{ Unlock parent_child list.

      osp$clear_job_signature_lock (pmv$task_control_block_lock);

      osp$system_error ('parent_child relationship', NIL);
    ELSE
      sibling^ := child_tcb^.next_sibling;
      FREE child_tcb^.nosve.termination_status IN osv$task_shared_heap^;
      FREE child_tcb^.nosve.debug_table IN osv$task_shared_heap^;
      FREE child_tcb^.nosve.program_description IN osv$job_pageable_heap^;
      FREE child_tcb^.nosve.mpe_description IN osv$job_pageable_heap^;
      IF #SIZE (child_tcb^.nosve.program_parameters^) > 0 THEN
        FREE child_tcb^.nosve.program_parameters IN osv$job_pageable_heap^;
      IFEND;

      IF (child_tcb^.nosve.ada_task_table <> NIL) AND (child_tcb^.nosve.ada_starting_procedure = NIL) THEN
        FREE child_tcb^.nosve.ada_task_table IN osv$task_shared_heap^;
      IFEND;

      FREE child_tcb IN osv$job_pageable_heap^;

{ Unlock parent_child list.

      osp$clear_job_signature_lock (pmv$task_control_block_lock);

    IFEND;
  PROCEND release_child_tcb;
?? OLDTITLE ??
?? NEWTITLE := 'unlink_ada_environment', EJECT ??

  PROCEDURE unlink_ada_environment
    (    child: ^pmt$task_control_block);

{  PURPOSE:
{    This procedure is responsible for unlinking the ADA asynchronous procedure information
{    from the task control block of the parent task.
{


    VAR
      entry1: pmt$max_number_of_tasks,
      task_ids: ^array [1 .. * ] of pmt$task_id,
      os_stack_frame_word: ^pmt$os_stack_frame_word,
      local_status: ost$status,
      entry_found: boolean,
      entry: pmt$max_number_of_tasks;


{  Lock ada_task_table..  (Necessary to assure synchronization during initiation and termination.)

    osp$set_job_signature_lock (pmv$ada_task_table_lock);

    IF (child^.nosve.ada_task_table = NIL) OR NOT (child^.nosve.ada_task_table^.current_entry <=
          UPPERBOUND (child^.nosve.ada_task_table^.table)) THEN
      osp$clear_job_signature_lock (pmv$ada_task_table_lock);
      osp$system_error ('ada task table error', NIL);
    IFEND;

{ Get task table from task control block.

    PUSH task_ids: [1 .. child^.nosve.ada_task_table^.current_entry + 1];
    entry1 := 1;
    FOR entry := 0 TO child^.nosve.ada_task_table^.current_entry DO
      task_ids^ [entry1] := child^.nosve.ada_task_table^.table [entry];
      entry1 := entry1 + 1;
    FOREND;

{ Call Memory Manager to close the shared stack.

    mmp$close_shared_stack (child^.nosve.ada_shared_stack_pointer, task_ids, local_status);

{ Find this task's task_id entry in the ADA task table.

    entry := 1;
    entry_found := TRUE;

  /find_task_entry/
    BEGIN
      WHILE entry <= child^.nosve.ada_task_table^.current_entry DO
        IF child^.nosve.ada_task_table^.table [entry] = child^.task_id THEN
          EXIT /find_task_entry/;
        IFEND;
        entry := entry + 1;
      WHILEND;
      entry_found := FALSE;
    END /find_task_entry/;

    IF NOT entry_found THEN

{ Unlock ada_task_table.

      osp$clear_job_signature_lock (pmv$ada_task_table_lock);
      osp$system_error ('ada task table error', NIL);
    IFEND;

{ Remove the entry from the list if it is not the last entry in the list.

    IF NOT (entry = child^.nosve.ada_task_table^.current_entry) THEN
      WHILE entry < child^.nosve.ada_task_table^.current_entry DO
        child^.nosve.ada_task_table^.table [entry] := child^.nosve.ada_task_table^.table [entry + 1];
        entry := entry + 1;
      WHILEND;
    IFEND;

    child^.nosve.ada_task_table^.current_entry := child^.nosve.ada_task_table^.current_entry - 1;

{ Unlock ada_task_table.

    osp$clear_job_signature_lock (pmv$ada_task_table_lock);

{ Decrement the caller's critical frame count.  We do not need to lock the frame count since we are
{ executing below the recognition ring.

    IF (child^.nosve.ada_critical_frame <> NIL) THEN
      os_stack_frame_word := child^.nosve.ada_critical_frame;
      IF (os_stack_frame_word^.ada_critical_frame) AND (os_stack_frame_word^.ada_critical_frame_count > 0)
            THEN
        os_stack_frame_word^.ada_critical_frame_count := os_stack_frame_word^.ada_critical_frame_count - 1;
        IF os_stack_frame_word^.ada_critical_frame_count = 0 THEN
          os_stack_frame_word^.ada_critical_frame := FALSE;
        IFEND;
      IFEND;
    IFEND;


  PROCEND unlink_ada_environment;
?? TITLE := ' [XDCL, #GATE] pmp$build_ada_task_table', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$build_ada_task_table
    (    number_of_tasks: pmt$max_number_of_tasks;
     VAR status: ost$status);


    VAR
      tcb: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb);
    IF (tcb^.nosve.ada_starting_procedure <> NIL) OR (tcb^.nosve.ada_task_table <> NIL) THEN
      osp$set_status_abnormal ('PM', pme$illegal_ada_control_task, '', status);
      RETURN;
    IFEND;

    ALLOCATE tcb^.nosve.ada_task_table: [0 .. number_of_tasks] IN osv$task_shared_heap^;

    tcb^.nosve.ada_task_table^.current_entry := 0;
    tcb^.nosve.ada_task_table^.table [tcb^.nosve.ada_task_table^.current_entry] := tcb^.task_id;

  PROCEND pmp$build_ada_task_table;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$disable_ts_io_in_tasks', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$disable_ts_io_in_tasks;

{ Purpose: This procedure is called to disable timesharing (interactive) IO in tasks.
{
{ Assumptions: This procedure is only called from the job monitor task.
{              The job monitor task cannot have any siblings.

    VAR
      job_monitor_xcb_p: ^ost$execution_control_block,
      job_monitor_tcb_p: ^pmt$task_control_block;

?? NEWTITLE := '      disable_io_in_tasks', EJECT ??

    PROCEDURE disable_io_in_tasks
      (    tcb_p: ^pmt$task_control_block);

      VAR
        sibling_tcb_p: ^pmt$task_control_block;

      sibling_tcb_p := tcb_p;
      WHILE sibling_tcb_p <> NIL DO
        sibling_tcb_p^.nosve.task_io_enabled := FALSE;

{ disable io in all the children of this task

        IF sibling_tcb_p^.first_child <> NIL THEN
          disable_io_in_tasks (sibling_tcb_p^.first_child);
        IFEND;

{ go on to disable the next sibling

        sibling_tcb_p := sibling_tcb_p^.next_sibling;
      WHILEND;
    PROCEND disable_io_in_tasks;

?? OLDTITLE, EJECT ??

{  Lock parent_child list.  (Necessary if anyone other than parent scans child list.)

    osp$set_job_signature_lock (pmv$task_control_block_lock);

    job_monitor_xcb_p := jmp$job_monitor_xcb ();
    job_monitor_tcb_p := job_monitor_xcb_p^.task_control_block;

{ Disable IO in all of the child tasks - including the current job synchronous task

    IF job_monitor_tcb_p^.first_child <> NIL THEN
      disable_io_in_tasks (job_monitor_tcb_p^.first_child);
    IFEND;

{ Unlock parent_child list.

    osp$clear_job_signature_lock (pmv$task_control_block_lock);

  PROCEND pmp$disable_ts_io_in_tasks;


?? TITLE := '    PMP$ENABLE_TS_IO_IN_TASKS', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$enable_ts_io_in_tasks;

{ Purpose: This procedure is used to re-enable timesharing (interactive) IO in tasks.
{
{ Assumptions: This procedure is typically called from the current job synchronous task.
{
{ Limitations: If a condition handler in a task with multiple interactive conditions
{              starts an asynchronous task and another condition occurs, the asynchronous
{              task will not be able to perform IO on the connection.  If it attempts to
{              it will "hang" waiting for IO to it to be enabled.

    VAR
      current_job_sync_task_id: pmt$task_id,
      synchronous_tcb_p: ^pmt$task_control_block,
      executing_task_tcb_p: ^pmt$task_control_block;

?? NEWTITLE := '      enable_io_in_tasks', EJECT ??

    PROCEDURE enable_io_in_tasks
      (    tcb_p: ^pmt$task_control_block);

      VAR
        sibling_tcb_p: ^pmt$task_control_block;

      sibling_tcb_p := tcb_p;
      WHILE sibling_tcb_p <> NIL DO
        sibling_tcb_p^.nosve.task_io_enabled := TRUE;

{ enable io in all the children of this task

        IF sibling_tcb_p^.first_child <> NIL THEN
          enable_io_in_tasks (sibling_tcb_p^.first_child);
        IFEND;

{ go on to enable the next sibling

        sibling_tcb_p := sibling_tcb_p^.next_sibling;
      WHILEND;
    PROCEND enable_io_in_tasks;

?? OLDTITLE, EJECT ??

{  Lock parent_child list.  (Necessary if anyone other than parent scans child list.)

    osp$set_job_signature_lock (pmv$task_control_block_lock);

{ Trace the synchronous task chain to determine what tasking subtree to
{ start re-enabling timesharing io in.
{ Trace back until we are at the job monitor task or until the current task's parent
{ is the last task in which interactive conditions have occured.
{   CASE 1.  current task is job monitor
{     a) job monitor has conditions - do nothing - job monitor is the only synchronous task
{                                   - in the job - all others are asynchronous (this is a
{                                   - side-effect from case 2.
{     b) job monitor has no conditions - enable all tasks in the job.
{   CASE 2.  current task's parent has conditions
{     enable io within the current task's parent - it may need to do IO to deal with its conditions.
{     enable io within the current task - it may need to do IO.
{     enable io within the current task's children (the parent's synchronous child and its children) - but
{       do not enable IO within this task's siblings - they are asynchronous and cannot do IO until
{       the parent has dealt with all timesharing (interactive) conditions.

    pmp$find_executing_task_tcb (synchronous_tcb_p);

    WHILE (synchronous_tcb_p^.parent <> NIL) AND (synchronous_tcb_p^.parent^.nosve.task_condition_count = 0)
          DO
      synchronous_tcb_p := synchronous_tcb_p^.parent;
    WHILEND;

{ Are we at the job monitor task - we are if parent = NIL

    IF synchronous_tcb_p^.parent = NIL THEN

{ Should we enable IO in all tasks in the job?

      IF synchronous_tcb_p^.nosve.task_condition_count = 0 THEN
        enable_io_in_tasks (synchronous_tcb_p^.first_child);
      ELSE

{ Do nothing

      IFEND;
    ELSE

{ We are NOT in job monitor.
{ Re-enable IO within the selected task, its parent, and its children - but NOT its siblings.

      synchronous_tcb_p^.parent^.nosve.task_io_enabled := TRUE;
      synchronous_tcb_p^.nosve.task_io_enabled := TRUE;
      enable_io_in_tasks (synchronous_tcb_p^.first_child);
    IFEND;

{ Unlock parent_child list.

    osp$clear_job_signature_lock (pmv$task_control_block_lock);
  PROCEND pmp$enable_ts_io_in_tasks;

?? TITLE := '    PMP$ENABLE_TIMESHARING_IO', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$enable_timesharing_io;

{ Purpose: This interface enables a task such that it can do io on the connection.
{
{ Assumptions: This procedure is called from the current job synchronous task.

    VAR
      executing_task_tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (executing_task_tcb_p);
    executing_task_tcb_p^.nosve.task_io_enabled := TRUE;
  PROCEND pmp$enable_timesharing_io;

?? TITLE := '    PMP$BEGIN_TIMESHARING_HANDLER', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$begin_timesharing_handler;

    VAR
      executing_task_tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (executing_task_tcb_p);
    executing_task_tcb_p^.nosve.task_handler_count := executing_task_tcb_p^.nosve.task_handler_count + 1;
  PROCEND pmp$begin_timesharing_handler;

?? TITLE := '    PMP$END_TIMESHARING_HANDLER', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$end_timesharing_handler;

    VAR
      executing_task_tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (executing_task_tcb_p);
    executing_task_tcb_p^.nosve.task_handler_count := executing_task_tcb_p^.nosve.task_handler_count - 1;

    IF executing_task_tcb_p^.nosve.task_handler_count = 0 THEN
      executing_task_tcb_p^.nosve.task_condition_count := 0;
    IFEND;
  PROCEND pmp$end_timesharing_handler;

?? TITLE := '    PMP$BEGIN_TIMESHARING_CONDITION', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$begin_timesharing_condition;

    VAR
      executing_task_tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (executing_task_tcb_p);
    executing_task_tcb_p^.nosve.task_condition_count := executing_task_tcb_p^.nosve.task_condition_count + 1;
  PROCEND pmp$begin_timesharing_condition;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$enable_ts_io_in_job', EJECT ??
*copy pmh$enable_ts_io_in_job

  PROCEDURE [XDCL, #GATE] pmp$enable_ts_io_in_job;

    VAR
      job_monitor_xcb_p: ^ost$execution_control_block,
      job_monitor_tcb_p: ^pmt$task_control_block;

?? NEWTITLE := 'enable_io_in_tasks', EJECT ??

    PROCEDURE enable_io_in_tasks
      (    tcb_p: ^pmt$task_control_block);

      VAR
        sibling_tcb_p: ^pmt$task_control_block;

      sibling_tcb_p := tcb_p;
      WHILE sibling_tcb_p <> NIL DO
        sibling_tcb_p^.nosve.task_io_enabled := TRUE;

{ enable io in all the children of this task

        IF sibling_tcb_p^.first_child <> NIL THEN
          enable_io_in_tasks (sibling_tcb_p^.first_child);
        IFEND;

{ go on to enable the next sibling

        sibling_tcb_p := sibling_tcb_p^.next_sibling;
      WHILEND;
    PROCEND enable_io_in_tasks;

?? OLDTITLE ??
?? EJECT ??

{ Find the job monitor task's Task Control Block.

    job_monitor_xcb_p := jmp$job_monitor_xcb ();
    job_monitor_tcb_p := job_monitor_xcb_p^.task_control_block;

{ Lock parent_child list.  (Necessary if anyone other than parent scans child list.)

    osp$set_job_signature_lock (pmv$task_control_block_lock);

{ Enable terminal IO in the job monitor task and all of the job's other tasks.

    job_monitor_tcb_p^.nosve.task_io_enabled := TRUE;
    enable_io_in_tasks (job_monitor_tcb_p^.first_child);

{ Unlock parent_child list.

    osp$clear_job_signature_lock (pmv$task_control_block_lock);
  PROCEND pmp$enable_ts_io_in_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$kill_task_flag_handler', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$kill_task_flag_handler
    (    flag_id: ost$system_flag);

    VAR
      local_status: ost$status,
      tcb_p: ^pmt$task_control_block;

?? NEWTITLE := 'kill_child_tasks', EJECT ??

{ PURPOSE:
{   This request flags the "endpoint" child tasks with the kill task flag.
{
{ NOTE:
{   The task control block lock must be set when this request is issued.

    PROCEDURE kill_child_tasks
      (    parent_tcb_p: ^pmt$task_control_block);

      VAR
        global_task_id: ost$global_task_id,
        local_status: ost$status,
        tcb_p: ^pmt$task_control_block;

      tcb_p := parent_tcb_p^.first_child;
      WHILE tcb_p <> NIL DO
        IF tcb_p^.first_child <> NIL THEN
          kill_child_tasks (tcb_p);
        ELSE

{ Send the task a KILL flag.

          pmp$get_global_task_id (tcb_p^.task_id, global_task_id, local_status);
          IF local_status.normal THEN
            pmp$set_system_flag (pmc$kill_task_flag, global_task_id, { ignore } local_status);
          IFEND;
        IFEND;
        tcb_p := tcb_p^.next_sibling;
      WHILEND;
    PROCEND kill_child_tasks;
?? OLDTITLE ??
?? NEWTITLE := 'truncate_stack', EJECT ??

{ PURPOSE:
{   The purpose of this request is to truncate the stack at the ring 3 ring
{ crossing frame.

    PROCEDURE truncate_stack;

      VAR
        local_status: ost$status,
        starting_frame_p: ^ost$stack_frame_save_area,
        xing_frame_p: ^ost$stack_frame_save_area;

      local_status.normal := TRUE;

{ Since the popper may be circumvented by truncating the stack clear the
{ popper handler established flag to force the next trap to protect the
{ stack frame popper.

      pmv$popper_handler_established := FALSE;

      starting_frame_p := NIL;
      tmp$find_ring_crossing_frame (starting_frame_p, xing_frame_p, local_status);
      IF NOT local_status.normal THEN
        pmp$exit (local_status);
      IFEND;

      starting_frame_p := xing_frame_p^.minimum_save_area.a2_previous_save_area;
      WHILE ((starting_frame_p <> NIL) AND (#RING (starting_frame_p) <= osc$tsrv_ring) AND
            local_status.normal) DO
        tmp$find_ring_crossing_frame (starting_frame_p, xing_frame_p, local_status);
        starting_frame_p := xing_frame_p^.minimum_save_area.a2_previous_save_area;
      WHILEND;

      IF local_status.normal THEN
        xing_frame_p^.minimum_save_area.a2_previous_save_area := NIL;

      ELSE
        pmp$exit (local_status);
      IFEND;

    PROCEND truncate_stack;
?? OLDTITLE ??

    pmp$find_executing_task_tcb (tcb_p);

{ Is the task an endpoint of the tasking tree - if so, consider it stuck and
{ kill it.

    IF tcb_p^.first_child = NIL THEN
      IF tcb_p^.task_kill_count < pmc$task_kill_count_maximum THEN
        tcb_p^.task_kill_count := tcb_p^.task_kill_count + 1;
      IFEND;

{ If the kill status was executing, simply call exit again.  If the task
{ execution phase has proceeded to another phase, save the new phase and
{ return.  Since the task has progressed in termination, wait until another
{ kill occurs before terminating the task.

      IF tcb_p^.task_kill_phase = pmc$task_executing THEN
        tcb_p^.task_kill_phase := pmv$task_execution_phase;
        osp$set_status_condition (pme$kill_task_requested, local_status);
        pmp$exit (local_status);

      ELSEIF tcb_p^.task_kill_phase < pmv$task_execution_phase THEN
        tcb_p^.task_kill_phase := pmv$task_execution_phase;

      ELSE

{ The task was terminating and has been killed before.  Truncate the stack at
{ the ring 3 (osc$tsrv_ring) ring crossing frame and call exit again.

        truncate_stack;
        osp$set_status_condition (pme$kill_task_requested, local_status);
        pmp$exit (local_status);
      IFEND;

    ELSE

{ Typically, only the job monitor task will execute this code.  It will also
{ be executed by a task that creates a child task before it recognizes a kill
{ flag.

{ Lock parent_child list.  (Necessary if anyone other than parent scans child list.)

      osp$set_job_signature_lock (pmv$task_control_block_lock);

      kill_child_tasks (tcb_p);
      osp$clear_job_signature_lock (pmv$task_control_block_lock);
    IFEND;
  PROCEND pmp$kill_task_flag_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$update_program_description', EJECT ??
*copy pmh$update_program_description

  PROCEDURE [XDCL, #GATE] pmp$update_program_description
    (    new_program_description: pmt$program_description);

    VAR
      tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb_p);
    FREE tcb_p^.nosve.program_description IN osv$job_pageable_heap^;

    ALLOCATE tcb_p^.nosve.program_description: [[REP #SIZE (new_program_description) OF cell]] IN
            osv$job_pageable_heap^;
    tcb_p^.nosve.program_description^ := new_program_description;

  PROCEND pmp$update_program_description;
?? OLDTITLE ??
MODEND pmm$tasking_support_ring_2;
*DECK DECK=PMM$TASKING_SUPPORT_RING_3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Tasking : Ring 3 support' ??
MODULE pmm$tasking_support_ring_3;

{  PURPOSE:
{    This module contains ring 3 procedures and data structures necessary to support tasking.

?? NEWTITLE := '  Global declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc gft$file_desc_entry_p
*copyc loc$deferred_entry_pt_library
*copyc ife$error_codes
*copyc loc$task_services_library_name
*copyc mmc$segment_manager_defaults
*copyc mme$condition_codes
*copyc pmt$task_id
*copyc pmt$task_control_block
*copyc pmt$program_description
*copyc pmt$task_state
*copyc pmt$stack_segment
*copyc pmt$segment_inheritance_options
*copyc pmt$loadable_rings
*copyc pmt$os_stack_frame_word
*copyc osc$unseen_mail_condition
*copyc osd$code_base_pointer
*copyc osd$virtual_address
*copyc ost$status
*copyc ost$execution_control_block
*copyc ost$caller_identifier
*copyc ost$global_task_id
*copyc ost$stack_frame_save_area
*copyc oss$task_private
*copyc oss$task_shared
*copyc pme$condition_exceptions
*copyc pme$execution_exceptions
*copyc pme$program_services_exceptions
*copyc osk$keypoints
*copyc pmk$keypoints
*copyc pmt$apd_task_jobmode_statistics
*copyc lot$loader_type_definitions
*copyc tmc$signal_identifiers
?? POP ??
*copyc clp$validate_name
*copyc gfp$get_fde_p
*copyc i#build_adaptable_seq_pointer
*copyc i#disable_traps
*copyc i#move
*copyc i#restore_traps
*copyc lop$augment_allocated_segments
*copyc mmp$change_segment_inheritance
*copyc mmp$create_segment
*copyc mmp$fetch_segment_attributes
*copyc mmp$reserve_segment_number
*copyc mmp$store_segment_attributes
*copyc mmp$validate_segment_number
*copyc osp$establish_condition_handler
*copyc osp$force_access_violation
*copyc osp$is_caller_system_privileged
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$system_error
*copyc osp$verify_system_privilege
*copyc osp$verify_system_segment
*copyc pmp$await_task_termination
*copyc pmp$build_ada_task_table
*copyc pmp$continue_to_cause
*copyc pmp$establish_condition_handler
*copyc pmp$exit
*copyc pmp$set_system_flag
*copyc pmp$send_signal
*copyc pmp$find_task_tcb
*copyc pmp$find_task_xcb
*copyc pmp$find_executing_task_xcb
*copyc pmp$find_executing_task_tcb
*copyc pmp$outward_call
*copyc pmp$set_relative_priority_r1
*copyc pmp$update_tos_ring_1
*copyc tmp$clear_wait_inhibited
*copyc clp$convert_integer_to_string
*copyc mmv$page_map_offsets
*copyc osv$page_size
*copyc pmv$debug_logging_enabled

  CONST
    child_xcb_lost = 'child XCB lost',
    unexpected_abnormal_status = 'unexpected abnormal status';

*copyc oss$job_paged_literal
*copyc lov$file_descriptors
*copyc lov$library_list
*copyc lov$allocated_segments
*copyc lov$highest_segment_index

  VAR
    pmv$unseen_mail_pending: [XDCL, STATIC, oss$task_shared] boolean := FALSE;

  VAR
    task_state: [STATIC, oss$task_private] pmt$task_state := pmc$task_active;

?? TITLE := '  [XDCL, #GATE] pmp$get_task_id', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_task_id
    (VAR task_id: pmt$task_id;
     VAR status: ost$status);

{  PURPOSE:
{    This procedure returns the task_id of the executing task.

    VAR
      xcb: ^ost$execution_control_block;

    #KEYPOINT (osk$entry, 0, pmk$get_task_id);
    pmp$find_executing_task_xcb (xcb);
    task_id := xcb^.task_id;
    status.normal := TRUE;
    #KEYPOINT (osk$exit, 0, pmk$get_task_id);
  PROCEND pmp$get_task_id;
?? TITLE := '  [XDCL] pmp$get_global_task_id', EJECT ??

  PROCEDURE [XDCL] pmp$get_global_task_id
    (    task_id: pmt$task_id;
     VAR global_task_id: ost$global_task_id;
     VAR status {control} : ost$status);

*copyc pmh$get_global_task_id


    VAR
      xcb: ^ost$execution_control_block;

    status.normal := TRUE;
    pmp$find_task_xcb (task_id, xcb);
    IF xcb = NIL THEN
      osp$set_status_condition (pme$unknown_task_id, status);
    ELSE
      global_task_id := xcb^.global_task_id;
    IFEND;
  PROCEND pmp$get_global_task_id;
?? TITLE := '  [XDCL, #GATE] pmp$task_state', EJECT ??

  FUNCTION [XDCL, #GATE] pmp$task_state: pmt$task_state;

*copyc pmh$task_state

    pmp$task_state := task_state;
  FUNCEND pmp$task_state;
?? TITLE := '  [XDCL] pmp$set_task_state', EJECT ??

  PROCEDURE [XDCL] pmp$set_task_state
    (    new_task_state: pmt$task_state);

    task_state := new_task_state;
  PROCEND pmp$set_task_state;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_termination_status', EJECT ??
*copy pmh$get_termination_status

  PROCEDURE [XDCL, #GATE] pmp$get_termination_status
    (VAR termination_status: ost$status);

    VAR
      tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb_p);
    IF tcb_p^.task_kind = osc$tk_nosve_task THEN
      termination_status := tcb_p^.nosve.termination_status^;
    ELSE { IF tcb_p^.task_kind = osc$tk_unix_task THEN
      termination_status.normal := TRUE;
    IFEND;
  PROCEND pmp$get_termination_status;
?? TITLE := '  [XDCL] pmp$flag_all_child_tasks', EJECT ??

  PROCEDURE [XDCL] pmp$flag_all_child_tasks
    (    system_flag: ost$system_flag;
     VAR status {control} : ost$status);

*copyc pmh$flag_all_child_tasks

{  NOTE:
{    This procedure assumes that the executing task's child list does not change while the
{    procedure is active.  This assumption is true as long as no pmp$wait calls are issued by
{    the procedure or its subordinates.

    VAR
      child: ^pmt$task_control_block,
      child_gtid: ost$global_task_id,
      local_status: ost$status,
      tcb_p: ^pmt$task_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_tcb (tcb_p);
    child := tcb_p^.first_child;
    WHILE child <> NIL DO
      pmp$get_global_task_id (child^.task_id, child_gtid, local_status);
      IF NOT local_status.normal THEN
        osp$system_error (child_xcb_lost, NIL);
      IFEND;
      pmp$set_system_flag (system_flag, child_gtid, status);
      IF NOT status.normal THEN
        IF status.condition = pme$unknown_recipient_task THEN
          status.normal := TRUE;
        ELSE
          RETURN
        IFEND;
      IFEND;
      child := child^.next_sibling;
    WHILEND;
  PROCEND pmp$flag_all_child_tasks;
?? TITLE := '  [XDCL] pmp$signal_all_child_tasks', EJECT ??

  PROCEDURE [XDCL] pmp$signal_all_child_tasks
    (    signal: pmt$signal;
     VAR status {control} : ost$status);

*copyc pmh$signal_all_child_tasks

{  NOTE:
{    This procedure assumes that the executing task's child list does not change while the
{    procedure is active.  This assumption is true as long as no pmp$wait calls are issued by
{    the procedure or its subordinates.

    VAR
      child: ^pmt$task_control_block,
      child_gtid: ost$global_task_id,
      local_status: ost$status,
      tcb_p: ^pmt$task_control_block;

    status.normal := TRUE;
    pmp$find_executing_task_tcb (tcb_p);
    child := tcb_p^.first_child;
    WHILE child <> NIL DO
      pmp$get_global_task_id (child^.task_id, child_gtid, local_status);
      IF NOT local_status.normal THEN
        osp$system_error (child_xcb_lost, NIL);
      IFEND;
      pmp$send_signal (child_gtid, signal, status);
      IF NOT status.normal THEN
        IF status.condition = pme$unknown_recipient_task THEN
          status.normal := TRUE;
        ELSE
          RETURN
        IFEND;
      IFEND;
      child := child^.next_sibling;
    WHILEND;
  PROCEND pmp$signal_all_child_tasks;
?? TITLE := '  [XDCL] pmp$verify_current_child', EJECT ??

  PROCEDURE [XDCL] pmp$verify_current_child
    (    task_id: pmt$task_id;
     VAR current_child {control} : boolean);

*copyc pmh$verify_child_task

{  NOTE:
{    This procedure assumes that the executing task's child list does not change while the
{    procedure is active.  This assumption is true as long as no pmp$wait calls are issued by
{    the procedure or its subordinates.

    VAR
      child: ^pmt$task_control_block,
      tcb_p: ^pmt$task_control_block;

    current_child := FALSE;
    pmp$find_executing_task_tcb (tcb_p);
    child := tcb_p^.first_child;

  /scan_child_list/
    WHILE child <> NIL DO
      IF task_id = child^.task_id THEN
        current_child := TRUE;
        EXIT /scan_child_list/;
      ELSE
        child := child^.next_sibling;
      IFEND;
    WHILEND /scan_child_list/;
  PROCEND pmp$verify_current_child;
?? TITLE := '  [XDCL, #GATE] pmp$await_ada_task', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$await_ada_task
    (    os_stack_frame_word: ^pmt$os_stack_frame_word);

*copy pmh$await_ada_task

{  NOTE:
{    This procedure assumes that the executing task's child list does not change while the
{    procedure is active.  This assumption is true while the procedure is not in wait.

    VAR
      status: ost$status,
      ada_child_found: boolean,
      child: ^pmt$task_control_block,
      tcb_p: ^pmt$task_control_block;

?? NEWTITLE := 'aat_condition_handler', EJECT ??

{ PURPOSE:
{   This condition handler detects a condition that goes off during termination
{   of an ADA task that has child tasks.  The condition is continued to the
{   ring crossing with the standard procedure executed.  If the continue
{   request returns with abnormal status, the task is terminated.  If a terminate
{   break was issued by the user, the task is terminated.

    PROCEDURE aat_condition_handler
      (    condition: pmt$condition;
           condition_information_p: ^pmt$condition_information;
           sfsa_p: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IF NOT handler_status.normal THEN
        pmp$exit (handler_status);
      ELSEIF (condition.selector = ifc$interactive_condition) AND
            (condition.interactive_condition = ifc$terminate_break) THEN
        osp$set_status_condition (ife$terminate_break_received, handler_status);
        pmp$exit (handler_status);
      IFEND;
    PROCEND aat_condition_handler;
?? OLDTITLE ??
?? EJECT ??

    osp$establish_condition_handler (^aat_condition_handler, {block_exit} FALSE);

    REPEAT
      ada_child_found := FALSE;
      pmp$find_executing_task_tcb (tcb_p);
      child := tcb_p^.first_child;

{ Find a child task that is an ADA asynchronous procedure that has the subject stack frame
{ as a critical frame.  If found, then await the termination of that task.  Return to the
{ caller when the critical frame count for this frame is zero.

    /find_ada_child/
      WHILE child <> NIL DO
        IF ((child^.nosve.ada_starting_procedure <> NIL) AND (child^.nosve.ada_critical_frame <> NIL)) AND
              (child^.nosve.ada_critical_frame = os_stack_frame_word) THEN
          ada_child_found := TRUE;
          EXIT /find_ada_child/;
        ELSE
          child := child^.next_sibling;
        IFEND;

      WHILEND /find_ada_child/;

      IF ada_child_found THEN
        pmp$await_task_termination (child^.task_id, status);

      ELSEIF os_stack_frame_word^.ada_critical_frame_count <> 0 THEN
        osp$set_status_condition (pme$ada_critical_frame_error, status);
        os_stack_frame_word^.ada_critical_frame_count := 0;
      IFEND;

    UNTIL os_stack_frame_word^.ada_critical_frame_count = 0;
    os_stack_frame_word^.ada_critical_frame := FALSE;

  PROCEND pmp$await_ada_task;
?? TITLE := '  [XDCL, #GATE] pmp$reserve_stack_segments', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$reserve_stack_segments
    (    number_of_tasks: pmt$max_number_of_tasks;
     VAR status: ost$status);

*copy pmh$reserve_stack_segments

    VAR
      seg_num_array: ^array [ * ] of ost$segment;

    #KEYPOINT (osk$entry, 0, pmk$reserve_stack_segments);

    status.normal := TRUE;

{ Assure caller is not an asynchronous procedure and build the task table for
{ use by segment manager when assigning shared stacks.

    pmp$build_ada_task_table (number_of_tasks, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, pmk$reserve_stack_segments);
      RETURN;
    IFEND;

{ Reserve <number_of_tasks> stack segments for use by asynchronous procedures.

    PUSH seg_num_array: [1 .. number_of_tasks];
    mmp$reserve_segment_number (TRUE, seg_num_array, status);

    #KEYPOINT (osk$exit, 0, pmk$reserve_stack_segments);

  PROCEND pmp$reserve_stack_segments;
?? TITLE := '  [XDCL, #GATE] pmp$change_inheritable_segments', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$change_inheritable_segments
    (    option: pmt$segment_inheritance_options;
     VAR status: ost$status);

*copy pmh$change_inheritable_segments

    VAR
      i: integer,
      index: lot$allocated_segments_index,
      loaded_rings: pmt$loadable_rings,
      library: ^lot$library_descriptor,
      previous_save_area: ^ost$stack_frame_save_area,
      pva: ^cell,
      ring: pmt$loadable_ring,
      tcb_p: ^pmt$task_control_block,
      caller: ost$caller_identifier;

    #KEYPOINT (osk$entry, 0, pmk$change_inheritable_segments);

    status.normal := TRUE;

    IF option <> pmc$inherit_code_and_data THEN
      osp$set_status_condition (pme$invalid_inheritance_option, status);
      RETURN;
    IFEND;

    #CALLER_ID (caller);

{ Insure that the caller is not an Asynchronous Procedure.

    pmp$find_executing_task_tcb (tcb_p);
    IF tcb_p^.nosve.ada_starting_procedure <> NIL THEN
      osp$set_status_condition (pme$illegal_ada_control_task, status);
      #KEYPOINT (osk$exit, 0, pmk$change_inheritable_segments);
      RETURN;
    IFEND;

{ Insure that the caller is not a multi-ring task.

    pmp$get_loaded_rings (loaded_rings);
    FOR ring := osc$sj_ring_2 TO osc$user_ring_2 DO
      IF (ring IN loaded_rings) AND (ring <> caller.ring) THEN
        osp$set_status_condition (pme$invalid_loaded_ring, status);
        #KEYPOINT (osk$exit, 0, pmk$change_inheritable_segments);
        RETURN;
      IFEND;
    FOREND;

{ Search LOV$ALLOCATED_SEGMENTS for all segments within the caller's ring privilege.
{ For each segment found call MMP$CHANGE_SEGMENT_INHERITANCE to make the segment inheritable.

    FOR index := 1 TO lov$highest_segment_index DO
      IF lov$allocated_segments^ [index].attributes.r2 >= caller.ring THEN
        pva := #ADDRESS (caller.ring, lov$allocated_segments^ [index].segment, 0);
        mmp$change_segment_inheritance (pva, mmc$si_share_segment, status);
        IF NOT status.normal THEN
          #KEYPOINT (osk$exit, 0, pmk$change_inheritable_segments);
          RETURN;
        IFEND;
      IFEND;
    FOREND;

{ Get the debug table segments so that callees may inherit them for debugging.
{ For each segment call MMP$CHANGE_SEGMENT_INHERITANCE to make the segment inheritable.

    IF tcb_p^.nosve.debug_table^.module_segment.seq_pointer <> NIL THEN
      pva := tcb_p^.nosve.debug_table^.module_segment.seq_pointer;
      mmp$change_segment_inheritance (pva, mmc$si_share_segment, status);
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, pmk$change_inheritable_segments);
        RETURN;
      IFEND;
    IFEND;

    IF tcb_p^.nosve.debug_table^.entry_point_segment.seq_pointer <> NIL THEN
      pva := tcb_p^.nosve.debug_table^.entry_point_segment.seq_pointer;
      mmp$change_segment_inheritance (pva, mmc$si_share_segment, status);
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, pmk$change_inheritable_segments);
        RETURN;
      IFEND;
    IFEND;

{ Now search LOV$LIBRARY_LIST.  Call MMP$CHANGE_SEGMENT_INHERITANCE for each open library.

    library := lov$library_list.first;

    WHILE (library <> NIL) DO
      IF (library^.library_open AND library^.library_valid) AND
            (library^.attributes.name <> loc$task_services_library_name) AND
            (library^.attributes.name (1, loc$deferred_entry_pt_lib_size) <>
            loc$deferred_entry_pt_library) THEN
        pva := library^.segment;
        mmp$change_segment_inheritance (pva, mmc$si_share_segment, status);
      IFEND;

      library := library^.nnext;
      IF (library = lov$library_list.first) OR (NOT status.normal) THEN
        #KEYPOINT (osk$exit, 0, pmk$change_inheritable_segments);
        RETURN;
      IFEND;
    WHILEND;

{ Now search LOV$FILE_DESCRIPTORS.  Call MMP$CHANGE_SEGMENT_INHERITANCE for
{ each object file that is a library.

    IF lov$file_descriptors <> NIL THEN
      FOR i := 1 TO UPPERBOUND (lov$file_descriptors^) DO
        pva := lov$file_descriptors^ [i].segment;
        mmp$change_segment_inheritance (pva, mmc$si_share_segment, status);
        IF NOT status.normal THEN
          #KEYPOINT (osk$exit, 0, pmk$change_inheritable_segments);
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    #KEYPOINT (osk$exit, 0, pmk$change_inheritable_segments);

  PROCEND pmp$change_inheritable_segments;
?? TITLE := '  [XDCL, #GATE] pmp$create_ada_heap', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$create_ada_heap
    (VAR heap_segment_pointer: mmt$segment_pointer;
     VAR status: ost$status);

*copy pmh$create_ada_heap

    VAR
      heap_segment_attributes: array [1 .. 1] of mmt$attribute_descriptor,
      tcb_p: ^pmt$task_control_block,
      caller: ost$caller_identifier;

    #KEYPOINT (osk$entry, 0, pmk$create_ada_heap);
    status.normal := TRUE;

    #CALLER_ID (caller);

{ Insure that the caller is not an Asynchronous Procedure.

    pmp$find_executing_task_tcb (tcb_p);
    IF tcb_p^.nosve.ada_starting_procedure <> NIL THEN
      osp$set_status_condition (pme$illegal_ada_control_task, status);
      #KEYPOINT (osk$exit, 0, pmk$create_ada_heap);
      RETURN;
    IFEND;

{ Create a heap segment in the ring of the caller.

    heap_segment_pointer.kind := mmc$heap_pointer;

    heap_segment_attributes [1].keyword := mmc$kw_ring_numbers;
    heap_segment_attributes [1].r1 := caller.ring;
    heap_segment_attributes [1].r2 := caller.ring;
    mmp$create_segment (^heap_segment_attributes, mmc$heap_pointer, 1, heap_segment_pointer, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, pmk$create_ada_heap);
      RETURN;
    IFEND;

{ Put an entry for this heap segment in LOV$ALLOCATED_SEGMENTS so that the segment will be
{ inherited by all subseqent ADA asynchronous procedures.

    IF lov$highest_segment_index = UPPERBOUND (lov$allocated_segments^) THEN
      lop$augment_allocated_segments;
    IFEND;

    lov$highest_segment_index := lov$highest_segment_index + 1;
    lov$allocated_segments^ [lov$highest_segment_index].current_length := mmc$default_maximum_seg_length;
    lov$allocated_segments^ [lov$highest_segment_index].maximum_length := mmc$default_maximum_seg_length;
    lov$allocated_segments^ [lov$highest_segment_index].segment :=
          #SEGMENT (heap_segment_pointer.heap_pointer);
    lov$allocated_segments^ [lov$highest_segment_index].attributes.access_control.execute_privilege :=
          osc$non_executable;
    lov$allocated_segments^ [lov$highest_segment_index].attributes.access_control.read_privilege :=
          osc$read_uncontrolled;
    lov$allocated_segments^ [lov$highest_segment_index].attributes.access_control.write_privilege :=
          osc$write_uncontrolled;
    lov$allocated_segments^ [lov$highest_segment_index].attributes.r1 := caller.ring;
    lov$allocated_segments^ [lov$highest_segment_index].attributes.r2 := caller.ring;
    lov$allocated_segments^ [lov$highest_segment_index].attributes.stack := FALSE;
    lov$allocated_segments^ [lov$highest_segment_index].attributes.extensible := FALSE;
    lov$allocated_segments^ [lov$highest_segment_index].attributes.debug_segment := FALSE;
    lov$allocated_segments^ [lov$highest_segment_index].attributes.apd_binding_segment := FALSE;

    #KEYPOINT (osk$exit, 0, pmk$create_ada_heap);

  PROCEND pmp$create_ada_heap;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$debug_logging_enabled', EJECT ??
*copy pmh$debug_logging_enabled

  FUNCTION [XDCL, #GATE] pmp$debug_logging_enabled: boolean;

    pmp$debug_logging_enabled := pmv$debug_logging_enabled;
  FUNCEND pmp$debug_logging_enabled;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$find_stack_segment', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$find_stack_segment
    (    ring: ost$ring;
     VAR stack_segment: ^pmt$stack_segment);

{  PURPOSE:
{    This procedure determines the stack segment associated with a specified ring in the
{    executing task.
{  NOTE:
{    This implementation is model_dependent.  A model_independent implementation requires a
{    monitor request to fetch the TOS register.
{    Consider moving this procedure to segment_management, since segment_management must
{    also handle stack segments in a model_independent fashion.  This would localize the
{    model_dependency considerations in a single area.

{!  This procedure should be gated if the stack_frame popper is to use it.

    VAR
      xcb: ^ost$execution_control_block,
      stack_segment_attributes: array [1 .. 2] of mmt$attribute_descriptor,
      stack_segment_pointer: mmt$segment_pointer,
      sequence_pointer: ^SEQ ( * ),
      tos_pointer: ^cell,
      local_status: ost$status;

    pmp$find_executing_task_xcb (xcb);
    tos_pointer := #ADDRESS (xcb^.xp.tos_registers [ring].pva.ring, xcb^.xp.tos_registers [ring].
          pva.seg, xcb^.xp.tos_registers [ring].pva.offset);
    IF tos_pointer = NIL THEN
      stack_segment_attributes [1].keyword := mmc$kw_ring_numbers;
      stack_segment_attributes [1].r1 := ring;
      stack_segment_attributes [1].r2 := ring;
      stack_segment_attributes [2].keyword := mmc$kw_software_attributes;
      stack_segment_attributes [2].software_attri_set := $mmt$software_attribute_set [mmc$sa_stack];
      mmp$create_segment (^stack_segment_attributes, mmc$sequence_pointer, 1, stack_segment_pointer,
            local_status);
      IF NOT local_status.normal THEN
        osp$system_error (unexpected_abnormal_status, ^local_status);
      IFEND;
      stack_segment := stack_segment_pointer.seq_pointer;
    ELSE
      i#build_adaptable_seq_pointer (xcb^.xp.tos_registers [ring].pva.ring,
            xcb^.xp.tos_registers [ring].pva.seg, 0, osc$maximum_offset,
            xcb^.xp.tos_registers [ring].pva.offset, sequence_pointer);
      stack_segment := sequence_pointer;
    IFEND;
  PROCEND pmp$find_stack_segment;
?? TITLE := '  [XDCL] pmp$get_loaded_rings', EJECT ??

  PROCEDURE [XDCL] pmp$get_loaded_rings
    (VAR loaded_rings: pmt$loadable_rings);

{  PURPOSE:
{    This procedure determines which rings in the executing task have had code sections loaded
{    into them, i.e., which rings have stack segments allocated.
{  NOTE:
{    This implementation is model_dependent.  A model_independent implementation requires a
{    monitor request to fetch the TOS register.
{    Consider moving this procedure to segment_management, since segment_management must
{    also handle stack segments in a model_independent fashion.  This would localize the
{    model_dependency considerations in a single area.

    VAR
      i: pmt$loadable_ring,
      tos_pointer: ^cell,
      xcb: ^ost$execution_control_block;

    loaded_rings := $pmt$loadable_rings [];
    pmp$find_executing_task_xcb (xcb);
    FOR i := LOWERVALUE (pmt$loadable_ring) TO UPPERVALUE (pmt$loadable_ring) DO
      tos_pointer := #ADDRESS (xcb^.xp.tos_registers [i].pva.ring, xcb^.xp.tos_registers [i].pva.seg,
            xcb^.xp.tos_registers [i].pva.offset);
      IF tos_pointer <> NIL THEN
        loaded_rings := loaded_rings + $pmt$loadable_rings [i];
      IFEND;
    FOREND;
  PROCEND pmp$get_loaded_rings;

?? TITLE := ' [XDCL, #GATE] pmp$get_program_size_in_bytes', EJECT ??

*copy pmh$get_program_size_in_bytes

  PROCEDURE [XDCL, #GATE] pmp$get_program_size_in_bytes
    (VAR program_size: ost$segment_length;
     VAR status: ost$status);

    VAR
      tcb_p: ^pmt$task_control_block;

    #KEYPOINT (osk$entry, 0, pmk$get_program_size_in_bytes);
    status.normal := TRUE;
    pmp$find_executing_task_tcb (tcb_p);
    IF tcb_p^.task_kind = osc$tk_nosve_task THEN
      program_size := #SIZE (tcb_p^.nosve.program_description^);
    ELSE { IF tcb_p^.task_kind = osc$tk_unix_task THEN
      program_size := 0;
    IFEND;
    #KEYPOINT (osk$exit, 0, pmk$get_program_size_in_bytes);
  PROCEND pmp$get_program_size_in_bytes;

?? TITLE := '  [XDCL, #GATE] pmp$get_program_size', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_program_size
    (VAR number_of_object_files: pmt$number_of_object_files;
     VAR number_of_modules: pmt$number_of_modules;
     VAR number_of_libraries: pmt$number_of_libraries;
     VAR status: ost$status);

    VAR
      program_description: ^pmt$program_description,
      program_attributes: ^pmt$program_attributes,
      tcb_p: ^pmt$task_control_block;

    #KEYPOINT (osk$entry, 0, pmk$get_program_size);
    status.normal := TRUE;
    pmp$find_executing_task_tcb (tcb_p);
    IF tcb_p^.task_kind = osc$tk_nosve_task THEN
      program_description := tcb_p^.nosve.program_description;
      RESET program_description;
      NEXT program_attributes IN program_description;
      IF (pmc$object_file_list_specified IN program_attributes^.contents) THEN
        number_of_object_files := program_attributes^.number_of_object_files;
      ELSE
        number_of_object_files := 0;
      IFEND;
      IF (pmc$module_list_specified IN program_attributes^.contents) THEN
        number_of_modules := program_attributes^.number_of_modules;
      ELSE
        number_of_modules := 0;
      IFEND;
      IF (pmc$library_list_specified IN program_attributes^.contents) THEN
        number_of_libraries := program_attributes^.number_of_libraries;
      ELSE
        number_of_libraries := 0;
      IFEND;
    ELSE { IF tcb_p^.task_kind = osc$tk_unix_task THEN
      number_of_object_files := 0;
      number_of_modules := 0;
      number_of_libraries := 0;
    IFEND;
    #KEYPOINT (osk$exit, 0, pmk$get_program_size);
  PROCEND pmp$get_program_size;
?? TITLE := '  [XDCL, #GATE] pmp$get_parent_calling_ring', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_parent_calling_ring
    (VAR ring: ost$valid_ring;
     VAR status: ost$status);

    VAR
      tcb_p: ^pmt$task_control_block;

    #KEYPOINT (osk$entry, 0, pmk$get_parent_calling_ring);

    status.normal := TRUE;
    pmp$find_executing_task_tcb (tcb_p);
    ring := tcb_p^.target_ring;

    #KEYPOINT (osk$exit, 0, pmk$get_parent_calling_ring);

  PROCEND pmp$get_parent_calling_ring;
?? TITLE := '  [XDCL, #GATE] pmp$get_program_description', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_program_description
    (VAR program_description: pmt$program_description;
     VAR status: ost$status);

    VAR
      current_program_descrip_size: ost$segment_length,
      new_program_description_size: ost$segment_length,
      tcb_p: ^pmt$task_control_block;

    #KEYPOINT (osk$entry, 0, pmk$get_program_description);
    status.normal := TRUE;
    pmp$find_executing_task_tcb (tcb_p);
    new_program_description_size := #SIZE (program_description);
    current_program_descrip_size := #SIZE (tcb_p^.nosve.program_description^);
    IF ((new_program_description_size = current_program_descrip_size) OR
          ((new_program_description_size + #SIZE (pmt$enable_inhibit_conditions)) =
          current_program_descrip_size)) THEN
      i#move (tcb_p^.nosve.program_description, ^program_description, new_program_description_size);
    ELSE
      osp$set_status_condition (pme$prog_description_size_error, status);
    IFEND;
    #KEYPOINT (osk$exit, 0, pmk$get_program_description);
  PROCEND pmp$get_program_description;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_apd_task_jobmode_stats', EJECT ??
*copy pmh$get_apd_task_jobmode_stats

{ NOTE: This procedure is called by the ASSEMBLE deck PMM$INTERCEPT_PROCEDURES.
{ Any changes made to PMP$GET_APD_TASK_JOBMODE_STATS may require a change to
{ PMM$INTERCEPT_PROCEDURES.

  PROCEDURE [XDCL, #GATE] pmp$get_apd_task_jobmode_stats
    (VAR jobmode_statistics: pmt$apd_task_jobmode_statistics);

    VAR
      old_te: 0 .. 3,
      xcb_p: ^ost$execution_control_block;

    i#disable_traps (old_te);
    pmp$find_executing_task_xcb (xcb_p);
    jobmode_statistics.jobmode_cptime := xcb_p^.pit_count - #READ_REGISTER (osc$pr_process_interval_timer);
    jobmode_statistics.paging_statistics.page_in_count :=
          xcb_p^.paging_statistics.page_in_count + xcb_p^.paging_statistics.pages_from_server;
    jobmode_statistics.paging_statistics.pages_reclaimed_from_queue :=
          xcb_p^.paging_statistics.pages_reclaimed_from_queue;
    jobmode_statistics.paging_statistics.new_pages_assigned := xcb_p^.paging_statistics.new_pages_assigned;
    jobmode_statistics.paging_statistics.page_fault_count := xcb_p^.paging_statistics.page_fault_count;
    i#restore_traps (old_te);

  PROCEND pmp$get_apd_task_jobmode_stats;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL, #GATE] pmp$update_tos_ring_3', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$update_tos_ring_3
    (    top_of_stack: ^cell);


    pmp$update_tos_ring_1 (top_of_stack);


  PROCEND pmp$update_tos_ring_3;
?? TITLE := '  [XDCL, #GATE] pmp$clear_wait_inhibited', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$clear_wait_inhibited
    (VAR was_wait_inhibited: boolean;
     VAR status: ost$status);

    #KEYPOINT (osk$entry, 0, pmk$clear_wait_inhibited);

    status.normal := TRUE;

    tmp$clear_wait_inhibited (was_wait_inhibited);

    #KEYPOINT (osk$exit, 0, pmk$clear_wait_inhibited);

  PROCEND pmp$clear_wait_inhibited;

?? TITLE := '  [XDCL, #GATE] pmp$get_parent_task_id', EJECT ??


*copyc pmh$get_parent_task_id
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$get_parent_task_id
    (    child_task_id: pmt$task_id;
     VAR parent_task_id: pmt$task_id;
     VAR status: ost$status);

    CONST
      base_16 = 16,
      include_radix = TRUE;

    VAR
      child_tcb: ^pmt$task_control_block,
      strng: ost$string;

    #KEYPOINT (osk$entry, 0, pmk$get_parent_task_id);

    status.normal := TRUE;

    pmp$find_task_tcb (child_task_id, child_tcb);
    IF (child_tcb = NIL) THEN
      clp$convert_integer_to_string (child_task_id, base_16, include_radix, strng, status);
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, pmk$get_parent_task_id);
        RETURN;
      IFEND;
      osp$set_status_abnormal ('PM', pme$task_id_not_found, strng.value (1, strng.size), status);
      #KEYPOINT (osk$exit, 0, pmk$get_parent_task_id);
      RETURN;
    IFEND;

    IF (child_tcb^.parent = NIL) THEN
      clp$convert_integer_to_string (child_task_id, base_16, include_radix, strng, status);
      IF NOT status.normal THEN
        #KEYPOINT (osk$exit, 0, pmk$get_parent_task_id);
        RETURN;
      IFEND;
      osp$set_status_abnormal ('PM', pme$task_has_no_parent, strng.value (1, strng.size), status);
      #KEYPOINT (osk$exit, 0, pmk$get_parent_task_id);
      RETURN;
    IFEND;

    parent_task_id := child_tcb^.parent^.task_id;

    #KEYPOINT (osk$exit, 0, pmk$get_parent_task_id);

  PROCEND pmp$get_parent_task_id;
?? TITLE := '  [XDCL, #GATE]  pmp$set_relative_priority', EJECT ??
*copyc pmh$set_relative_priority

  PROCEDURE [XDCL, #GATE] pmp$set_relative_priority
    (    priority: 0 .. 255;
     VAR status: ost$status);

    #KEYPOINT (osk$entry, 0, pmk$set_relative_priority);
    IF (priority < 0) OR (priority > 255) THEN
      osp$set_status_condition (pme$invalid_relative_priority, status);
      #KEYPOINT (osk$exit, 0, pmk$set_relative_priority);
      RETURN;
    IFEND;

    pmp$set_relative_priority_r1 (priority);
    #KEYPOINT (osk$exit, 0, pmk$set_relative_priority);
  PROCEND pmp$set_relative_priority;
?? TITLE := '  [XDCL, #GATE]  pmp$cause_intra_job_condition', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$cause_intra_job_condition
    (    condition: pmt$condition_name;
         task_id: pmt$task_id;
     VAR status: ost$status);

    VAR
      signal: pmt$signal,
      xcb: ^ost$execution_control_block,
      vn: ost$name,
      valid: boolean,
      p_condition: ^pmt$condition_name;

    #KEYPOINT (osk$entry, 0, pmk$cause_intra_job_condition);
    clp$validate_name (condition, vn, valid);
    IF NOT valid THEN
      osp$set_status_abnormal (pmc$program_management_id, pme$incorrect_condition_name, vn, status);
      #KEYPOINT (osk$exit, 0, pmk$cause_intra_job_condition);
      RETURN;
    IFEND;
    IF vn <> osc$unseen_mail_condition THEN
      IF (vn (1, 4) = 'CYE$') OR (vn (1, 4) = 'OSC$') THEN
        osp$set_status_abnormal (pmc$program_management_id, pme$incorrect_condition_name, vn, status);
        #KEYPOINT (osk$exit, 0, pmk$cause_intra_job_condition);
        RETURN;
      IFEND;
    IFEND;

    pmp$find_task_xcb (task_id, xcb);
    IF xcb = NIL THEN
      osp$set_status_condition (pme$unknown_recipient_task, status);
      #KEYPOINT (osk$exit, 0, pmk$cause_intra_job_condition);
      RETURN;
    IFEND;

    signal.identifier := pmc$multi_task_condition;
    p_condition := #LOC (signal.contents);
    p_condition^ := condition;

    pmp$send_signal (xcb^.global_task_id, signal, status);

    #KEYPOINT (osk$exit, 0, pmk$cause_intra_job_condition);

  PROCEND pmp$cause_intra_job_condition;
?? TITLE := '  [XDCL, #GATE] pmp$change_transient_to_write', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$change_transient_to_write
    (    segment: ^cell;
     VAR status: ost$status);

*copyc pmh$change_transient_to_write

    VAR
      caller_id: ost$caller_identifier,
      fde_entry_p: gft$file_desc_entry_p,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segment_attributes: array [1 .. 2] of mmt$attribute_descriptor;

    #KEYPOINT (osk$entry, 0, pmk$change_transient_to_write);
    #CALLER_ID (caller_id);

    status.normal := TRUE;
    mmp$validate_segment_number (#SEGMENT (segment), sdt_entry_p, sdtx_entry_p, status);
    IF NOT status.normal THEN
      osp$set_status_condition (mme$invalid_pva, status);
      #KEYPOINT (osk$exit, 0, pmk$change_transient_to_write);
      RETURN;
    IFEND;

    gfp$get_fde_p (sdtx_entry_p^.sfid, fde_entry_p);
    IF fde_entry_p = NIL THEN
      #KEYPOINT (osk$exit, 0, pmk$change_transient_to_write);
      RETURN;
    IFEND;

    IF fde_entry_p^.file_kind <> gfc$fk_unnamed_file THEN
      osp$set_status_condition (pme$not_transient_segment, status);
      #KEYPOINT (osk$exit, 0, pmk$change_transient_to_write);
      RETURN;
    IFEND;

    segment_attributes [1].keyword := mmc$kw_segment_access_control;
    segment_attributes [2].keyword := mmc$kw_ring_numbers;
    mmp$fetch_segment_attributes (segment, segment_attributes, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, pmk$change_transient_to_write);
      RETURN;
    IFEND;

    IF ((segment_attributes [2].r1 < caller_id.ring) OR (segment_attributes [2].r2 <>
          segment_attributes [2].r1)) THEN
      osp$set_status_condition (pme$segment_ring_error, status);
      #KEYPOINT (osk$exit, 0, pmk$change_transient_to_write);
      RETURN;
    IFEND;

    segment_attributes [1].access_control.write_privilege := osc$write_uncontrolled;
    segment_attributes [1].access_control.execute_privilege := osc$non_executable;
    mmp$store_segment_attributes (segment, osc$tsrv_ring, segment_attributes, status);

    #KEYPOINT (osk$exit, 0, pmk$change_transient_to_write);

  PROCEND pmp$change_transient_to_write;
?? TITLE := '  [XDCL, #GATE] pmp$change_transient_to_execute', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$change_transient_to_execute
    (    segment: ^cell;
     VAR status: ost$status);

*copyc pmh$change_transient_to_execute

    VAR
      caller_id: ost$caller_identifier,
      fde_entry_p: gft$file_desc_entry_p,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segment_attributes: array [1 .. 2] of mmt$attribute_descriptor;

    #KEYPOINT (osk$entry, 0, pmk$change_transient_to_execute);
    #CALLER_ID (caller_id);

    status.normal := TRUE;

    mmp$validate_segment_number (#SEGMENT (segment), sdt_entry_p, sdtx_entry_p, status);
    IF NOT status.normal THEN
      osp$set_status_condition (mme$invalid_pva, status);
      #KEYPOINT (osk$exit, 0, pmk$change_transient_to_write);
      RETURN;
    IFEND;

    gfp$get_fde_p (sdtx_entry_p^.sfid, fde_entry_p);
    IF fde_entry_p = NIL THEN
      #KEYPOINT (osk$exit, 0, pmk$change_transient_to_execute);
      RETURN;
    IFEND;

    IF fde_entry_p^.file_kind <> gfc$fk_unnamed_file THEN
      osp$set_status_condition (pme$not_transient_segment, status);
      #KEYPOINT (osk$exit, 0, pmk$change_transient_to_execute);
      RETURN;
    IFEND;

    segment_attributes [1].keyword := mmc$kw_segment_access_control;
    segment_attributes [2].keyword := mmc$kw_ring_numbers;
    mmp$fetch_segment_attributes (segment, segment_attributes, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, pmk$change_transient_to_execute);
      RETURN;
    IFEND;

    IF ((segment_attributes [2].r1 < caller_id.ring) OR (segment_attributes [2].r2 <>
          segment_attributes [2].r1)) THEN
      osp$set_status_condition (pme$segment_ring_error, status);
      #KEYPOINT (osk$exit, 0, pmk$change_transient_to_execute);
      RETURN;
    IFEND;

    segment_attributes [1].access_control.execute_privilege := osc$non_privileged;
    segment_attributes [1].access_control.write_privilege := osc$non_writable;
    mmp$store_segment_attributes (segment, osc$tsrv_ring, segment_attributes, status);

    #KEYPOINT (osk$exit, 0, pmk$change_transient_to_execute);

  PROCEND pmp$change_transient_to_execute;
?? TITLE := '  [XDCL, #GATE] pmp$change_transient_to_binding', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$change_transient_to_binding
    (    segment: ^cell;
     VAR status: ost$status);

*copyc pmh$change_transient_to_binding

    VAR
      caller_id: ost$caller_identifier,
      code_base_pointer_array: ^array [1 .. osc$max_segment_length DIV 8] of ost$internal_code_base_pointer,
      conversion_pointer: ^cell,
      fde_entry_p: gft$file_desc_entry_p,
      index: 1 .. osc$max_segment_length DIV 8,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segment_attributes: array [1 .. 3] of mmt$attribute_descriptor,
      segment_end_descriptor: pmt$established_handler;

    #KEYPOINT (osk$entry, 0, pmk$change_transient_to_binding);
    #CALLER_ID (caller_id);

    status.normal := TRUE;

    mmp$validate_segment_number (#SEGMENT (segment), sdt_entry_p, sdtx_entry_p, status);
    IF NOT status.normal THEN
      osp$set_status_condition (mme$invalid_pva, status);
      #KEYPOINT (osk$exit, 0, pmk$change_transient_to_write);
      RETURN;
    IFEND;

    gfp$get_fde_p (sdtx_entry_p^.sfid, fde_entry_p);
    IF fde_entry_p = NIL THEN
      #KEYPOINT (osk$exit, 0, pmk$change_transient_to_binding);
      RETURN;
    IFEND;

    IF fde_entry_p^.file_kind <> gfc$fk_unnamed_file THEN
      osp$set_status_condition (pme$not_transient_segment, status);
      #KEYPOINT (osk$exit, 0, pmk$change_transient_to_binding);
      RETURN;
    IFEND;

    segment_attributes [1].keyword := mmc$kw_segment_access_control;
    segment_attributes [2].keyword := mmc$kw_ring_numbers;
    segment_attributes [3].keyword := mmc$kw_max_segment_length;
    mmp$fetch_segment_attributes (segment, segment_attributes, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, pmk$change_transient_to_binding);
      RETURN;
    IFEND;

    IF ((segment_attributes [2].r1 < caller_id.ring) OR (segment_attributes [2].r2 <>
          segment_attributes [2].r1)) THEN
      osp$set_status_condition (pme$segment_ring_error, status);
      #KEYPOINT (osk$exit, 0, pmk$change_transient_to_binding);
      RETURN;
    IFEND;

    conversion_pointer := #ADDRESS (osc$tsrv_ring, #SEGMENT (segment), 0);
    code_base_pointer_array := conversion_pointer;

    FOR index := 1 TO segment_attributes [3].max_length DIV 8 DO
      IF code_base_pointer_array^ [index].r3 <> 0 THEN
        IF code_base_pointer_array^ [index].r3 <> caller_id.ring THEN
          osp$set_status_condition (pme$code_base_pointer_error, status);
          #KEYPOINT (osk$exit, 0, pmk$change_transient_to_binding);
          RETURN;
        IFEND;
      IFEND;
    FOREND;

    segment_attributes [1].access_control.read_privilege := osc$binding_segment;
    segment_attributes [1].access_control.write_privilege := osc$non_writable;
    segment_attributes [1].access_control.execute_privilege := osc$non_executable;
    mmp$store_segment_attributes (segment, osc$tsrv_ring, segment_attributes, status);

    #KEYPOINT (osk$exit, 0, pmk$change_transient_to_binding);

  PROCEND pmp$change_transient_to_binding;
?? TITLE := '  [XDCL, #GATE] pmp$change_binding_to_write', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$change_binding_to_write
    (    segment: ^cell;
     VAR status: ost$status);

*copyc pmh$change_binding_to_write

    VAR
      caller_id: ost$caller_identifier,
      fde_entry_p: gft$file_desc_entry_p,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      segment_attributes: array [1 .. 2] of mmt$attribute_descriptor;

    #KEYPOINT (osk$entry, 0, pmk$change_binding_to_write);
    #CALLER_ID (caller_id);

    status.normal := TRUE;
    mmp$validate_segment_number (#SEGMENT (segment), sdt_entry_p, sdtx_entry_p, status);
    IF NOT status.normal THEN
      osp$set_status_condition (mme$invalid_pva, status);
      #KEYPOINT (osk$exit, 0, pmk$change_transient_to_write);
      RETURN;
    IFEND;

    gfp$get_fde_p (sdtx_entry_p^.sfid, fde_entry_p);
    IF fde_entry_p = NIL THEN
      #KEYPOINT (osk$exit, 0, pmk$change_binding_to_write);
      RETURN;
    IFEND;

    IF fde_entry_p^.file_kind <> gfc$fk_unnamed_file THEN
      osp$set_status_condition (pme$not_transient_segment, status);
      #KEYPOINT (osk$exit, 0, pmk$change_binding_to_write);
      RETURN;
    IFEND;

    segment_attributes [1].keyword := mmc$kw_segment_access_control;
    segment_attributes [2].keyword := mmc$kw_ring_numbers;
    mmp$fetch_segment_attributes (segment, segment_attributes, status);
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, pmk$change_binding_to_write);
      RETURN;
    IFEND;

    IF ((segment_attributes [2].r1 < caller_id.ring) OR (segment_attributes [2].r2 <>
          segment_attributes [2].r1)) THEN
      osp$set_status_condition (pme$segment_ring_error, status);
      #KEYPOINT (osk$exit, 0, pmk$change_binding_to_write);
      RETURN;
    IFEND;

    segment_attributes [1].access_control.execute_privilege := osc$non_executable;
    segment_attributes [1].access_control.write_privilege := osc$write_uncontrolled;
    segment_attributes [1].access_control.read_privilege := osc$read_uncontrolled;
    mmp$store_segment_attributes (segment, osc$tsrv_ring, segment_attributes, status);

    #KEYPOINT (osk$exit, 0, pmk$change_binding_to_write);

  PROCEND pmp$change_binding_to_write;
?? OLDTITLE ??
?? NEWTITLE := '    [XDCL, #GATE] pmp$meape_segments_constrained', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$meape_segments_constrained
    (VAR constrained: boolean);

*copyc pmv$constrain_meape_segments

    constrained := pmv$constrain_meape_segments;
  PROCEND pmp$meape_segments_constrained;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL, #GATE] pmp$post_unseen_mail', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$post_unseen_mail;

{  This procedure records that unseen_mail condition processing has been postponed.

    IF osp$is_caller_system_privileged () THEN
      pmv$unseen_mail_pending := TRUE;
    IFEND;
  PROCEND pmp$post_unseen_mail;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL, #GATE] pmp$schedule_unseen_mail', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$schedule_unseen_mail;

{  This procedure records that unseen_mail condition processing is no longer postponed.

    IF osp$is_caller_system_privileged () THEN
      pmv$unseen_mail_pending := FALSE;
    IFEND;
  PROCEND pmp$schedule_unseen_mail;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$inward_call', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$inward_call
    (    callee: ^ost$external_code_base_pointer;
         target_ring: ost$ring;
         callee_parameter_list: ^cell;
         callee_previous_save_area: ^ost$stack_frame_save_area);

{ This request allows an operating system procedure executing in
{ a less privileged ring to call another operating system procedure
{ to execute in a more privileged ring.

    VAR
      stack_offset_pad_p: ^array [1 .. *] of cell,
      stack_segment: ^pmt$stack_segment;


    osp$verify_system_privilege;

    osp$verify_system_segment (callee^.code_pva);

    IF target_ring <= osc$tsrv_ring THEN
      osp$force_access_violation;
    IFEND;

    pmp$find_stack_segment (target_ring, stack_segment);
    RESET stack_segment;
    NEXT stack_offset_pad_p: [1 .. (mmv$page_map_offsets [mmc$pmo_user_stack] * osv$page_size) +
          mmc$ring_crossing_offset] IN stack_segment;
    pmp$outward_call (callee, target_ring, callee_parameter_list, callee_previous_save_area, stack_segment);

  PROCEND pmp$inward_call;
?? OLDTITLE ??

MODEND pmm$tasking_support_ring_3;
*DECK DECK=PMM$TASKING_SUPPORT_RING_6 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Program Management : Tasking support in ring 6' ??
MODULE pmm$tasking_support_ring_6;

{ PURPOSE:
{   This module contains the ring 6 interfaces to support tasking.


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc lle$load_map_diagnostics
*copyc pme$program_services_exceptions
*copyc pmk$keypoints
*copyc ost$caller_identifier
*copyc lot$loader_type_definitions
?? POP ??
*copyc mmp$store_segment_attributes
*copyc osp$append_status_integer
*copyc osp$begin_aam_activity_r1
*copyc osp$begin_subsystem_activity
*copyc osp$end_aam_activity_r1
*copyc osp$end_subsystem_activity
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$system_error
*copyc osp$test_aam_activity_r1
*copyc pmp$find_executing_task_xcb
*copyc pmp$get_executing_task_gtid

*copy lov$allocated_segments
*copy lov$highest_segment_index
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_executing_task_gtid_r6', EJECT ??
*copy pmh$get_executing_task_gtid_r6

  PROCEDURE [XDCL, #GATE] pmp$get_executing_task_gtid_r6
    (VAR global_task_id: ost$global_task_id);

    VAR
      local_global_task_id: ost$global_task_id;

    #KEYPOINT (osk$entry, 0, pmk$get_executing_task_gtid_r6);

    pmp$get_executing_task_gtid (local_global_task_id);
    global_task_id := local_global_task_id;

    #KEYPOINT (osk$exit, (osk$m * (global_task_id.index * 100(16) + global_task_id.seqno)),
          pmk$get_executing_task_gtid_r6);

  PROCEND pmp$get_executing_task_gtid_r6;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$expand_segment', EJECT ??
*copy pmh$expand_segment

  PROCEDURE [XDCL, #GATE] pmp$expand_segment
    (    pva: ^cell;
         length: ost$segment_length;
     VAR starting_pva: ^cell;
     VAR status: ost$status);



{ '{**' inserted to remove the requirement that the segment be a common block
{**   lov$common_blocks: [XREF] ^array [ * ] of lot$common_block_definition,
{**   i: integer,


    VAR
      attribute_fixer: array [1 .. 1] of mmt$attribute_descriptor,
      caller_id: ost$caller_identifier,
      j: integer,
      loader_pva: ^cell,
      segment: ^lot$segment_allocation,
      segment_number: ost$segment;

    #KEYPOINT (osk$entry, 0, pmk$expand_segment);
    #CALLER_ID (caller_id);
    status.normal := TRUE;

    segment_number := #SEGMENT (pva);

{** IF lov$common_blocks <> NIL THEN
{**   FOR i := LOWERBOUND (lov$common_blocks^) TO UPPERBOUND (lov$common_blocks^) DO
{**     IF segment_number = lov$common_blocks^ [i].address.segment THEN

    IF lov$allocated_segments <> NIL THEN
      FOR j := LOWERBOUND (lov$allocated_segments^) TO UPPERBOUND (lov$allocated_segments^) DO
        IF segment_number = lov$allocated_segments^ [j].segment THEN
          segment := ^lov$allocated_segments^ [j];
          IF (segment^.current_length + length) > segment^.maximum_length THEN
            osp$set_status_condition (lle$program_segment_overflow, status);
            osp$append_status_integer (osc$status_parameter_delimiter, segment_number, 10, FALSE, status);
            #KEYPOINT (osk$exit, 0, pmk$expand_segment);
            RETURN;
          IFEND;

          starting_pva := #ADDRESS (caller_id.ring, segment_number, segment^.current_length);
          loader_pva := #ADDRESS (loc$loader_ring, segment_number, 0);

          segment^.current_length := segment^.current_length + length;
          segment^.attributes.extensible := TRUE;

          attribute_fixer [1].keyword := mmc$kw_max_segment_length;
          attribute_fixer [1].max_length := segment^.current_length;

          mmp$store_segment_attributes (loader_pva, loc$loader_ring, attribute_fixer, status);

          #KEYPOINT (osk$exit, 0, pmk$expand_segment);
          RETURN;
        IFEND;
      FOREND;
    IFEND;

{**     IFEND;
{**   FOREND;
{** IFEND;

    osp$set_status_condition (pme$common_block_not_defined, status);
    osp$append_status_integer (osc$status_parameter_delimiter, segment_number, 10, FALSE, status);

    #KEYPOINT (osk$exit, 0, pmk$expand_segment);

  PROCEND pmp$expand_segment;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$begin_subsystem_activity', EJECT ??
*copy pmh$begin_subsystem_activity

  PROCEDURE [XDCL, #GATE] pmp$begin_subsystem_activity
    (VAR status: ost$status);

    VAR
      xcb_p: ^ost$execution_control_block;

    #KEYPOINT (osk$entry, 0, pmk$begin_subsystem_activity);
    status.normal := TRUE;
    pmp$find_executing_task_xcb (xcb_p);
    IF (xcb_p^.system_table_lock_count = 255) THEN
      osp$system_error ('Subsystem table lock count exceeded', ^status);
    IFEND;

    osp$begin_subsystem_activity;

    #KEYPOINT (osk$exit, 0, pmk$begin_subsystem_activity);

  PROCEND pmp$begin_subsystem_activity;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$end_subsystem_activity', EJECT ??
*copy pmh$end_subsystem_activity

  PROCEDURE [XDCL, #GATE] pmp$end_subsystem_activity
    (VAR status: ost$status);

    status.normal := TRUE;
    osp$end_subsystem_activity;

  PROCEND pmp$end_subsystem_activity;
?? OLDTITLE ??
?? NEWTITLE := 'aam debug routines', EJECT ??

{ PURPOSE:
{   These three routines are available for debug purposes in tracking down
{   problems in AAM.  If needed, the #GATE and XDCL can be re-added for the
{   period of time needed.

  PROCEDURE {XDCL, #GATE} osp$begin_aam_activity;

    osp$begin_aam_activity_r1;

  PROCEND osp$begin_aam_activity;

  PROCEDURE {XDCL, #GATE} osp$end_aam_activity;

    osp$end_aam_activity_r1;

  PROCEND osp$end_aam_activity;

  PROCEDURE {XDCL, #GATE} osp$test_aam_activity;

    osp$test_aam_activity_r1;

  PROCEND osp$test_aam_activity;
?? OLDTITLE ??
MODEND pmm$tasking_support_ring_6;
*DECK DECK=PMM$TASK_INITIATION EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE : Tasking : Task initiation' ??
?? NEWTITLE := '  Global declarations', EJECT ??
MODULE pmm$task_initiation;

{  PURPOSE:
{    This module contains procedures which control the initiation of a new task.
{  DESIGN:
{    The initiation of a new task is divided into two distinct phases.  The first phase occurs
{    in the parent task (the task issuing the PMP$EXECUTE request).  It consists of creating a
{    fundamental task environment and issuing a monitor request to activate the new task.
{    The second phase occurs in the child task (the new task).  It consists of loading the user
{    program into the task's address space and transferring to the user program.  Parameters
{    describing the program to be executed are passed from the parent task to the child task
{    thru job_global data structures.
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc mmt$attribute_keyword
*copyc pmt$program_description
*copyc pmt$program_parameters
*copyc pmt$task_control_block
*copyc pmt$os_stack_frame_word
*copyc pmt$task_cp_time
*copyc pmt$task_id
*copyc pmt$user_program
*copyc pmt$task_status
*copyc pmt$loadable_rings
*copyc ost$wait
*copyc ost$status
*copyc osd$code_base_pointer
*copyc ost$execution_control_block
*copyc cyd$cybil_structure_definitions
*copyc jmp$job_boot
*copyc jmp$job_monitor_xcb
*copyc syp$initialize_job
*copyc clp$job_boot
*copyc pmp$trap_handler
*copyc jmp$initialize_jcb
*copyc pmp$initialize_job_xcb_list
*copyc jmv$executing_within_system_job
*copyc ost$caller_identifier
*copyc oss$job_fixed
*copyc pme$execution_exceptions
*copyc pme$target_ring_error
*copyc pme$system_exceptions
*copyc osk$keypoints
*copyc pmc$default_user_stack_size
*copyc pmk$keypoints
*copyc osp$generate_message
*copyc sfp$emit_statistic
*copyc pmc$min_scc_program_execution
*copyc osp$reset_heap
*copyc osp$system_error
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
*copyc osp$set_signature_lock
*copyc osp$clear_signature_lock
*copyc osp$append_status_integer
*copyc i#move
*copyc i#build_adaptable_seq_pointer
*copyc clp$interpret_commands
*copyc clp$validate_name
*copyc clp$record_child_task
*copyc clp$erase_child_task
*copyc jmp$initialize_job_environment
*copyc jmp$job_begin
*copyc tmp$enable_preemptive_commo
*copyc osp$append_status_integer
*copyc osp$generate_log_message
*copyc pmp$create_shared_stack
*copyc pmp$end_debug_should_be_called
*copyc pmp$push_task_debug_mode
*copyc pmp$task_debug_mode_on
*copyc pmp$debug_abort_file_specified
*copyc pmp$set_task_debug_mode
*copyc pmp$set_task_debug_ring
*copyc pmp$task_debug_ring
*copyc pmp$exit
*copyc pmp$establish_condition_handler
*copyc pmp$continue_to_cause
*copyc pmp$create_task_environment
*copyc pmp$initiate_child_task
*copyc pmp$long_term_wait
*copyc pmp$release_task_environment
*copyc pmp$initialize_tasking_tables
*copyc pmp$find_executing_task_tcb
*copyc pmp$find_task_tcb
*copyc pmp$find_executing_task_xcb
*copyc pmp$call_begin_debug
*copyc pmp$find_prog_options_and_libs
*copyc pmp$find_stack_segment
*copyc pmp$original_caller
*copyc pmp$outward_call
*copyc pmp$update_jmtr_tcb_target_ring
*copyc pmp$update_program_description
*copyc pmp$get_task_cp_time
*copyc syp$initialize_job_template
*copyc lop$load_program
*copyc lop$reset_loader_for_2nd_load
*copyc lov$loader_options
*copyc osv$task_private_heap
*copyc mmv$page_map_offsets
*copyc osv$page_size
*copyc oss$task_private
*copyc oss$task_shared
*copyc oss$job_paged_literal
*copyc pmt$spy_identifier
*copyc pmt$spy_identifiers
*copyc pme$program_services_exceptions
*copyc pmv$debug_logging_enabled
*copyc pmv$job_monitor_tcb_p
*copyc syv$job_initialization_complete
*copyc syv$nosve_job_template
?? POP ??
?? TITLE := '    Global Declarations Declared by this Module.', EJECT ??

  VAR
    initialize_os_stack_frame_word: [STATIC, READ, oss$job_paged_literal] pmt$os_stack_frame_word :=
      [NIL, FALSE, FALSE, FALSE, FALSE, 0];

  VAR
    pmv$enable_inhibit_conditions: [XDCL, #GATE, oss$task_private] pmt$enable_inhibit_conditions;

?? TITLE := '  [XDCL, #GATE] pmp$execute_task', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$execute_task (target_ring: ost$valid_ring;
        program_description: pmt$program_description;
        mpe_description: pmt$loader_description;
        program_parameters: pmt$program_parameters;
        command_file: amt$local_file_name;
        wait: ost$wait;
        cl_task: boolean;
    VAR task_id: pmt$task_id;
    VAR task_status: pmt$task_status;
    VAR status: ost$status);

*copyc pmh$execute_task

{  PURPOSE:
{    This procedure is responsible for creating a new task and making it known to monitor.

    VAR
      pmv$spy_identifiers: [XREF, oss$task_shared] pmt$spy_identifiers,
      spy_identifier: pmt$spy_identifier,
      valid_program_params: ^pmt$program_parameters,
      caller: ost$caller_identifier,
      target_loaded_ring: ost$valid_ring,
      validated_program_description: ^pmt$program_description,
      local_task_id: pmt$task_id,
      local_status: ost$status,
      local_task_status: ^pmt$task_status,
      child_initiated: BOOLEAN;

    #caller_id (caller);

    IF #SIZE (program_description) > 0 THEN
      IF (caller.ring <= target_ring) THEN
        IF (target_ring < osc$tsrv_ring) THEN
          target_loaded_ring := osc$tsrv_ring;
        ELSE
          target_loaded_ring := target_ring;
        IFEND;
        status.normal := TRUE;
        local_status.normal := TRUE;
        PUSH validated_program_description: [[REP #SIZE (program_description) OF cell]];
        validate_program_description (program_description, validated_program_description, local_status);
        PUSH valid_program_params: [[REP #SIZE (program_parameters) OF cell]];
{ Copy them to validate access - if this fails an access violation will occur.
        valid_program_params^ := program_parameters;

        IF local_status.normal THEN
          { Validate write access to task_status from rings 2 or 3 (usually 3)
          local_task_status := ^task_status;
          local_task_status^.complete := FALSE;
          pmp$create_task_environment (validated_program_description, ^mpe_description, valid_program_params,
               ^task_status, target_loaded_ring, NIL, NIL, cl_task, local_task_id, local_status);
          IF local_status.normal THEN
            task_id := local_task_id;
            clp$record_child_task (target_loaded_ring, local_task_id, wait = osc$wait, command_file,
                  local_status);
            IF local_status.normal THEN
              spy_identifier := pmv$spy_identifiers.low_identifier;
              IF spy_identifier > UPPERVALUE (pmt$spy_identifier) THEN
                osp$set_status_abnormal ('PM', pme$invalid_spy_identifier, '', local_status);
                pmp$release_task_environment (local_task_id);
              ELSE
                REPEAT
                  pmp$initiate_child_task (local_task_id, spy_identifier, wait, child_initiated);
                  IF NOT child_initiated THEN
                    pmp$long_term_wait (1000, 1000);
                  IFEND;
                UNTIL child_initiated;
                IF spy_identifier < pmv$spy_identifiers.high_identifier THEN
                  pmv$spy_identifiers.low_identifier := spy_identifier + 1;
                IFEND;
              IFEND;
            ELSE
              pmp$release_task_environment (local_task_id);
            IFEND;
          IFEND;
        IFEND;
        IF NOT local_status.normal THEN
          status := local_status;
        IFEND;
      ELSE
        osp$set_status_abnormal ('PM', pme$target_ring_error, '', status);
      IFEND;
    ELSE
      osp$set_status_abnormal ('PM', pme$prog_description_too_small, 'program attributes', status);
    IFEND;

  PROCEND pmp$execute_task;
?? TITLE := '  [XDCL, #GATE] pmp$execute_procedure_as_task', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$execute_procedure_as_task (target_ring: ost$valid_ring;
        starting_procedure: pmt$user_program;
        program_parameters: pmt$program_parameters;
        critical_frame: ^ost$stack_frame_save_area;
    VAR task_id: pmt$task_id;
    VAR task_status: pmt$task_status;
    VAR status: ost$status);

*copy pmh$execute_procedure_as_task

    VAR
      pmv$spy_identifiers: [XREF, oss$task_shared] pmt$spy_identifiers,
      spy_identifier: pmt$spy_identifier,
      valid_program_params: ^pmt$program_parameters,
      caller: ost$caller_identifier,
      target_loaded_ring: ost$valid_ring,
      local_task_id: pmt$task_id,
      local_status: ost$status,
      local_task_status: ^pmt$task_status,
      previous_save_area: ^ost$stack_frame_save_area,
      os_stack_frame_word: ^pmt$os_stack_frame_word,
      tcb_p: ^pmt$task_control_block,
      valid_critical_frame: BOOLEAN,
      child_initiated: BOOLEAN;

    #caller_id (caller);

{ Validate the critical_frame value.  This value must be the pva of a stack frame save
{ area in the current task or the parameter is in error.

    valid_critical_frame := FALSE;
    previous_save_area := #previous_save_area ();

  /validate_critical_frame/
    WHILE previous_save_area <> NIL DO
      IF critical_frame = NIL THEN
        EXIT /validate_critical_frame/;
      IFEND;

{ Make sure that the critical frame is in the stack and not the one for pmp$original_caller.

      IF (previous_save_area = critical_frame) AND
              (previous_save_area^.minimum_save_area.a2_previous_save_area <> NIL) THEN
        valid_critical_frame := TRUE;
        EXIT /validate_critical_frame/;
      IFEND;
      previous_save_area := previous_save_area^.minimum_save_area.a2_previous_save_area;
    WHILEND /validate_critical_frame/;

    IF NOT valid_critical_frame THEN
      osp$set_status_abnormal ('PM', pme$invalid_critical_frame, '', status);
      RETURN;
    IFEND;

    os_stack_frame_word := critical_frame^.minimum_save_area.a1_current_stack_frame;
    IF critical_frame^.minimum_save_area.frame_descriptor.critical_frame_flag AND
       (os_stack_frame_word^.ada_critical_frame_count >= pmc$max_number_of_tasks) THEN
      osp$set_status_abnormal ('PM', pme$critical_frame_count_limit, '', status);
      RETURN;
    IFEND;

{ Validate the target_ring value.  This value must not be less than that of the caller,
{ and must be equal to the ring of the starting procedure.

    IF (caller.ring <= target_ring) AND (target_ring > osc$tsrv_ring) AND
           (target_ring = #RING (starting_procedure)) THEN
      target_loaded_ring := target_ring;
      status.normal := TRUE;
      local_status.normal := TRUE;

      PUSH valid_program_params: [[REP #SIZE (program_parameters) OF cell]];
{ Copy the parameters to validate access - if this fails an access violation will occur.
      valid_program_params^ := program_parameters;

{ Validate write access to task_status from rings 2 or 3 (usually 3).

      local_task_status := ^task_status;
      local_task_status^.complete := FALSE;

{ Use the program description and mpe description from the parent task.

      pmp$find_executing_task_tcb (tcb_p);
      pmp$create_task_environment (tcb_p^.nosve.program_description,
             tcb_p^.nosve.mpe_description, valid_program_params, ^task_status,
                  target_loaded_ring, critical_frame, starting_procedure,
                       FALSE, local_task_id, local_status);
      IF local_status.normal THEN
        task_id := local_task_id;

{ Record this child task with SCL.

        clp$record_child_task (target_loaded_ring, local_task_id, FALSE, osc$null_name, local_status);
        IF local_status.normal THEN
          spy_identifier := pmv$spy_identifiers.low_identifier;
          IF spy_identifier > UPPERVALUE (pmt$spy_identifier) THEN
            osp$set_status_abnormal ('PM', pme$invalid_spy_identifier, '', local_status);
            pmp$release_task_environment (local_task_id);
          ELSE

{ Generate the OS stack frame word entry for this instance for this critical frame

            critical_frame^.minimum_save_area.frame_descriptor.critical_frame_flag := TRUE;
            IF NOT critical_frame^.minimum_save_area.frame_descriptor.on_condition_flag THEN;
              critical_frame^.minimum_save_area.frame_descriptor.on_condition_flag := TRUE;
              os_stack_frame_word^ := initialize_os_stack_frame_word;
            IFEND;

{ We can add this instance to the frame count because we are executing below the recognition ring.

            os_stack_frame_word^.ada_critical_frame_count :=
                                  os_stack_frame_word^.ada_critical_frame_count + 1;
            os_stack_frame_word^.ada_critical_frame := TRUE;

{ Initiate this child task.

            REPEAT
              pmp$initiate_child_task (local_task_id, spy_identifier, osc$nowait, child_initiated);
              IF NOT child_initiated THEN
                pmp$long_term_wait (1000, 1000);
              IFEND;

            UNTIL child_initiated;
            IF spy_identifier < pmv$spy_identifiers.high_identifier THEN
              pmv$spy_identifiers.low_identifier := spy_identifier + 1;
            IFEND;
          IFEND;

        ELSE
          pmp$release_task_environment (local_task_id);
        IFEND;
      IFEND;

      IF NOT local_status.normal THEN
        status := local_status;
      IFEND;
    ELSE
      osp$set_status_abnormal ('PM', pme$target_ring_error, '', status);
    IFEND;

  PROCEND pmp$execute_procedure_as_task;
?? TITLE := '  [XDCL, #GATE] pmp$execute_within_task', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$execute_within_task (
        program_description: pmt$program_description;
        program_parameters: pmt$program_parameters;
    VAR status: ost$status);

    VAR
      first_time_called: [STATIC, oss$task_private] BOOLEAN := TRUE,
      validated_program_description: ^pmt$program_description,
      valid_program_params: ^pmt$program_parameters,
      code_base_pointer: ^ost$external_code_base_pointer,
      target_ring: ost$ring,
      tcb_p: ^pmt$task_control_block;

    status.normal := TRUE;

    IF NOT first_time_called THEN
      osp$set_status_abnormal ('PM', pme$2nd_call_to_execute_within, '', status);
      RETURN;
    IFEND;
    first_time_called := FALSE;

    PUSH validated_program_description: [[REP #SIZE (program_description) OF cell]];
    validate_program_description (program_description, validated_program_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH valid_program_params: [[REP #SIZE (program_parameters) OF cell]];
    { Copy them to validate access - if this fails an access violation will occur.
    valid_program_params^ := program_parameters;

    lop$reset_loader_for_2nd_load (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$find_executing_task_tcb (tcb_p);
    load_user_code_base_ptr (tcb_p^.target_ring, validated_program_description, NIL,
          FALSE, code_base_pointer);

{ The task is now the new task.  So, update it's program description.  There is
{ no reason to update the program parameters.

    pmp$update_program_description (validated_program_description^);

    target_ring := #RING (code_base_pointer^.code_pva);

    call_user_program (target_ring, code_base_pointer, valid_program_params);

    { The above procedure is not expected to return. }

    osp$system_error ('outward call error - pmp$execute_within_task', NIL);


  PROCEND pmp$execute_within_task;
?? TITLE := '  validate_program_description', EJECT ??

  PROCEDURE validate_program_description (program_description_value: pmt$program_description;
    VAR validated_program_description: ^pmt$program_description;
    VAR status {control} : ost$status);


{  NOTE:
{    This procedure assumes that the size of the program_description pointed to by
{    validated_program_description is the same as the size of program_description_value.


    TYPE
      valid_termination_error_level = set of pmt$termination_error_level,
      valid_preset_options = set of pmt$initialization_value;

    VAR
      program_description: ^pmt$program_description,
      program_attributes: ^pmt$program_attributes,
      validated_program_attributes: ^pmt$program_attributes,
      object_file_list: ^pmt$object_file_list,
      validated_object_file_list: ^pmt$object_file_list,
      i: pmt$number_of_object_files,
      module_list: ^pmt$module_list,
      validated_module_list: ^pmt$module_list,
      library_list: ^pmt$object_library_list,
      validated_library_list: ^pmt$object_library_list,
      j: pmt$number_of_libraries,
      valid_name: boolean,
      enable_inhibit_conditions: ^pmt$enable_inhibit_conditions,
      validated_conditions: ^pmt$enable_inhibit_conditions,
      name: ost$name;


    program_description := ^program_description_value;
    validated_program_description^ := program_description^;

    RESET program_description;
    RESET validated_program_description;

    NEXT program_attributes IN program_description;
    IF program_attributes = NIL THEN
      osp$set_status_abnormal ('PM', pme$prog_description_too_small, 'program_attributes', status);
      RETURN
    ELSE
      NEXT validated_program_attributes IN validated_program_description;
    IFEND;
?? EJECT ??
    IF pmc$object_file_list_specified IN program_attributes^.contents THEN
      IF (program_attributes^.number_of_object_files = 0) OR (program_attributes^.number_of_object_files >
            UPPERVALUE (pmt$number_of_object_files)) THEN
        osp$set_status_abnormal ('PM', pme$invalid_list_length, 'object files', status);
        osp$append_status_integer (' ', UPPERVALUE (pmt$number_of_object_files), 10, FALSE, status);
        RETURN
      ELSE
        NEXT object_file_list: [1 .. program_attributes^.number_of_object_files] IN program_description;
        IF object_file_list = NIL THEN
          osp$set_status_abnormal ('PM', pme$prog_description_too_small, 'object_file_list', status);
          RETURN
        ELSE
          NEXT validated_object_file_list: [1 .. program_attributes^.number_of_object_files] IN
                validated_program_description;
          FOR i := 1 TO program_attributes^.number_of_object_files DO
            clp$validate_name (object_file_list^ [i], name, valid_name);
            IF valid_name THEN
              validated_object_file_list^ [i] := name;
            ELSE
              osp$set_status_abnormal ('PM', pme$invalid_file_name, object_file_list^ [i], status);
              osp$append_status_parameter (' ', 'object', status);
              RETURN
            IFEND;
          FOREND;
        IFEND;
      IFEND;
    IFEND;

    IF pmc$module_list_specified IN program_attributes^.contents THEN
      IF (program_attributes^.number_of_modules = 0) OR (program_attributes^.number_of_modules > UPPERVALUE
            (pmt$number_of_modules)) THEN
        osp$set_status_abnormal ('PM', pme$invalid_list_length, 'modules', status);
        osp$append_status_integer (' ', UPPERVALUE (pmt$number_of_modules), 10, FALSE, status);
        RETURN
      ELSE
        NEXT module_list: [1 .. program_attributes^.number_of_modules] IN program_description;
        IF module_list = NIL THEN
          osp$set_status_abnormal ('PM', pme$prog_description_too_small, 'module_list', status);
          RETURN
        ELSE
          NEXT validated_module_list: [1 .. program_attributes^.number_of_modules] IN
                validated_program_description;
        IFEND;
      IFEND;
    IFEND;
?? EJECT ??
    IF pmc$library_list_specified IN program_attributes^.contents THEN
      IF (program_attributes^.number_of_libraries = 0) OR (program_attributes^.number_of_libraries >
            UPPERVALUE (pmt$number_of_libraries)) THEN
        osp$set_status_abnormal ('PM', pme$invalid_list_length, 'libraries', status);
        osp$append_status_integer (' ', UPPERVALUE (pmt$number_of_libraries), 10, FALSE, status);
        RETURN
      ELSE
        NEXT library_list: [1 .. program_attributes^.number_of_libraries] IN program_description;
        IF library_list = NIL THEN
          osp$set_status_abnormal ('PM', pme$prog_description_too_small, 'object_library_list', status);
          RETURN
        ELSE
          NEXT validated_library_list: [1 .. program_attributes^.number_of_libraries] IN
                validated_program_description;
          FOR j := 1 TO program_attributes^.number_of_libraries DO
            clp$validate_name (library_list^ [j], name, valid_name);
            IF valid_name THEN
              validated_library_list^ [j] := name;
            ELSE
              osp$set_status_abnormal ('PM', pme$invalid_file_name, library_list^ [j], status);
              osp$append_status_parameter (' ', 'library', status);
              RETURN
            IFEND;
          FOREND;
        IFEND;
      IFEND;
    IFEND;

    IF pmc$load_map_file_specified IN program_attributes^.contents THEN
      clp$validate_name (program_attributes^.load_map_file, name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal ('PM', pme$invalid_file_name, program_attributes^.load_map_file, status);
        osp$append_status_parameter (' ', 'load map', status);
        RETURN
      ELSE
        validated_program_attributes^.load_map_file := name;
      IFEND;
    IFEND;

    IF pmc$load_map_options_specified IN program_attributes^.contents THEN
      IF (pmc$no_load_map IN program_attributes^.load_map_options) AND ((program_attributes^.load_map_options
            - $pmt$load_map_options [pmc$no_load_map]) <> $pmt$load_map_options []) THEN
        osp$set_status_abnormal ('PM', pme$map_option_conflict, '', status);
        RETURN
      IFEND;
    IFEND;

?? EJECT ??
    IF pmc$term_error_level_specified IN program_attributes^.contents THEN
      IF NOT (program_attributes^.termination_error_level IN - $valid_termination_error_level []) THEN
        osp$set_status_abnormal ('PM', pme$invalid_term_error_level, '', status);
        RETURN
      IFEND;
    IFEND;

    IF pmc$preset_specified IN program_attributes^.contents THEN
      IF NOT (program_attributes^.preset IN - $valid_preset_options []) THEN
        osp$set_status_abnormal ('PM', pme$invalid_preset_option, '', status);
        RETURN
      IFEND;
    IFEND;

    IF pmc$max_stack_size_specified IN program_attributes^.contents THEN
      IF (program_attributes^.maximum_stack_size > UPPERVALUE (ost$segment_length)) OR (program_attributes^.
            maximum_stack_size = 0) THEN
        osp$set_status_abnormal ('PM', pme$invalid_stack_size_option, '', status);
        RETURN
      IFEND;
    IFEND;

    IF pmc$abort_file_specified IN program_attributes^.contents THEN
      clp$validate_name (program_attributes^.abort_file, name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal ('PM', pme$invalid_file_name, program_attributes^.abort_file, status);
        osp$append_status_parameter (' ', 'abort', status);
        RETURN
      ELSE
        validated_program_attributes^.abort_file := name;
      IFEND;
    IFEND;
?? EJECT ??
    IF pmc$debug_input_specified IN program_attributes^.contents THEN
      clp$validate_name (program_attributes^.debug_input, name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal ('PM', pme$invalid_file_name, program_attributes^.debug_input, status);
        osp$append_status_parameter (' ', 'debug input', status);
        RETURN
      ELSE
        validated_program_attributes^.debug_input := name;
      IFEND;
    IFEND;

    IF pmc$debug_output_specified IN program_attributes^.contents THEN
      clp$validate_name (program_attributes^.debug_output, name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal ('PM', pme$invalid_file_name, program_attributes^.debug_output, status);
        osp$append_status_parameter (' ', 'debug output', status);
        RETURN
      ELSE
        validated_program_attributes^.debug_output := name;
      IFEND;
    IFEND;

    IF pmc$condition_specified IN program_attributes^.contents THEN
      NEXT enable_inhibit_conditions IN program_description;
      IF enable_inhibit_conditions = NIL THEN
        osp$set_status_abnormal ('PM', pme$prog_description_too_small, 'enable_inhibit_conditions', status);
        RETURN
      ELSE
        NEXT validated_conditions IN validated_program_description;
      IFEND;
    IFEND;

  PROCEND validate_program_description;
?? TITLE := '  [XDCL] pmp$task_begin', EJECT ??

  PROGRAM pmp$task_begin;

{  PURPOSE:
{    This procedure receives control in a newly initiated task.  It is responsible for completing
{    the task environment and then loading and executing a specified program.
{  NOTE:
{    When this procedure receives control the full task_services environment is not intact.
{    Until this environment is completed, the activities which may be undertaken are limited.
{    The specific limitations are dependent on packaging and therefore are not itemized here.
*copyc pmv$job_initialization_complete

    VAR
      job_monitor_task: boolean,
      job_monitor_initial_ring: ost$ring,
      job_monitor_program_description: ^pmt$program_description,
      job_monitor_parameters: ^pmt$program_parameters,
      code_base_pointer: ^ost$external_code_base_pointer,
      target_ring: ost$ring,
      tcb_p: ^pmt$task_control_block,
      xcb: ^ost$execution_control_block,
      local_status: ost$status,
      ignore_status: ost$status;

    VAR
      gtid_converter: record
        case boolean of
        = false =
          global_task_id: ost$global_task_id,
        = true =
          integer_value: 0..0ffffff(16),
        casend,
      recend;

    VAR
      converter: record
        case 0 .. 1 of
        = 0 =
          procedure_pointer: pmt$user_program,
        = 1 =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend,

      maskable_system_conditions: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
        [pmc$system_conditions, $pmt$system_conditions [pmc$divide_fault, pmc$arithmetic_overflow,
        pmc$exponent_overflow, pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
        pmc$arithmetic_significance, pmc$invalid_bdp_data], * ],
      maskable_descriptor: pmt$established_handler;

?? NEWTITLE := '    handle_maskable_conditions' ??
?? EJECT ??

    PROCEDURE handle_maskable_conditions (condition: pmt$condition;
          condition_descriptor: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR status: ost$status);

{     PURPOSE:
{       The purpose of this procedure is to ensure that any maskable system
{       condition arising in pmp$task_begin is reported and causes the task
{       to be terminated.  The condition mechanism (PMM$DISPOSE_OF_CONDITIONS,
{       PMP$DISPOSE_UCR_CONDITIONS) assumes that any maskable condition
{       arising in a procedure whose A2 register is NIL, arose because that
{       condition was inhibited and the original caller is the procedure
{       in which the condition arose (i.e., task begin appears to be the
{       original caller).

      VAR
        ignore_status: ost$status;

      status.normal := TRUE;
      pmp$continue_to_cause (pmc$execute_standard_procedure, ignore_status);
    PROCEND handle_maskable_conditions;
?? OLDTITLE ??
?? TITLE := '    find_job_monitor_code_base_ptr', EJECT ??

  PROCEDURE [INLINE] find_job_monitor_code_base_ptr (VAR code_base_pointer: ^ost$external_code_base_pointer);


    VAR
      converter: record
        case 0 .. 1 of
        = 0 =
          procedure_pointer: ^procedure,
        = 1 =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend;


    converter.procedure_pointer := ^clp$interpret_commands;

    code_base_pointer := converter.code_base_pointer;


  PROCEND find_job_monitor_code_base_ptr;
?? EJECT ??

    #keypoint(osk$entry, 0, pmk$task_begin_end);
    #keypoint(osk$entry, 0, pmk$task_begin);

    pmp$find_executing_task_xcb (xcb);
    job_monitor_task := xcb = jmp$job_monitor_xcb ();

    IF job_monitor_task THEN
      syp$initialize_job;

{ NOTE: The job_monitor_initial_ring returned from the following call is not the target ring
{       of the outward call.  The target ring of the outward call is returned from the
{       later call to JMP$JOB_BEGIN.  This is because of a chicken and egg problem.  We need
{       to setup the tasking tables before enabling preemptive conditions but be can't know
{       the target ring until validation is done in JMP$JOB_BEGIN.  As a result, we simply
{       use a "temporary" value and update it before the outward call is done.

      IF NOT syv$job_initialization_complete THEN
        jmp$initialize_job_environment (job_monitor_initial_ring, job_monitor_program_description,
              job_monitor_parameters, local_status);
        IF NOT local_status.normal THEN
          osp$system_error ('unexpected abnormal status', ^local_status);
        IFEND;

        pmp$initialize_tasking_tables (job_monitor_initial_ring, job_monitor_program_description,
              job_monitor_parameters);
      ELSE
        jmp$initialize_jcb;
        pmp$initialize_job_xcb_list (pmv$job_monitor_tcb_p^.task_id, pmv$job_monitor_tcb_p,
              ^pmp$trap_handler);
      IFEND;
    IFEND;

    IF (NOT job_monitor_task) OR
       (NOT syv$job_initialization_complete) THEN
      initialize_task_private;
    IFEND;


    {The establishment of the handler for maskable system conditions is postponed until now, because if any
    {condition arose before this point it cannot be processed in the absence of the task private segment. In
    {fact any arising condition before this point will cause a recursion of of invalid segment faults.

    pmp$establish_condition_handler (maskable_system_conditions, ^handle_maskable_conditions,
          ^maskable_descriptor, ignore_status);

    tmp$enable_preemptive_commo;
    pmp$find_executing_task_tcb (tcb_p);

    IF job_monitor_task THEN
      IF NOT syv$job_initialization_complete THEN
        jmp$job_boot;
      IFEND;

{ The following is condition based on the system attribute ENABLE_PM_DEBUG_LOGGING.

      IF pmv$debug_logging_enabled THEN
        IF xcb = NIL THEN
          osp$system_error ('task XCB lost', NIL);
        ELSE
          gtid_converter.global_task_id := xcb^.global_task_id;
          osp$set_status_abnormal ('PM', pme$task_begin_information, { task_name } xcb^.save9, local_status);
          osp$append_status_integer (osc$status_parameter_delimiter, gtid_converter.integer_value, 16,
                true, local_status);
          osp$generate_log_message ($pmt$ascii_logset [pmc$system_log], local_status, ignore_status);
        IFEND;
      IFEND;

      #keypoint(osk$exit, 0, pmk$task_begin);
      clp$job_boot; {Does not return}
      osp$system_error ('outward call error', NIL);

    ELSEIF tcb_p^.nosve.ada_starting_procedure <> NIL THEN

      load_user_code_base_ptr (tcb_p^.target_ring, tcb_p^.nosve.program_description,
            tcb_p^.nosve.mpe_description, TRUE, code_base_pointer);
      converter.procedure_pointer := tcb_p^.nosve.ada_starting_procedure;
      code_base_pointer := converter.code_base_pointer;
      target_ring := #RING (code_base_pointer^.code_pva);
    ELSE
      load_user_code_base_ptr (tcb_p^.target_ring, tcb_p^.nosve.program_description,
            tcb_p^.nosve.mpe_description, FALSE,code_base_pointer);
      target_ring := #RING (code_base_pointer^.code_pva);
    IFEND;

{ The following is condition based on the system attribute ENABLE_PM_DEBUG_LOGGING.

    IF pmv$debug_logging_enabled THEN
      IF xcb = NIL THEN
        osp$system_error ('task XCB lost', NIL);
      ELSE
        gtid_converter.global_task_id := xcb^.global_task_id;
        osp$set_status_abnormal ('PM', pme$task_begin_information, { task_name } xcb^.save9, local_status);
        osp$append_status_integer (osc$status_parameter_delimiter, gtid_converter.integer_value, 16,
              true, local_status);
        osp$generate_log_message ($pmt$ascii_logset [pmc$system_log], local_status, ignore_status);
      IFEND;
    IFEND;

    #keypoint(osk$exit, 0, pmk$task_begin);
    call_user_program (target_ring, code_base_pointer, tcb_p^.nosve.program_parameters);

{   The above procedure is not expected to return.

    osp$system_error ('outward call error', NIL);


  PROCEND pmp$task_begin;
?? TITLE := '  initialize_task_private', EJECT ??

  PROCEDURE initialize_task_private;
*copyc pmv$task_template

    VAR
      i: integer,
      of_execution: cell,
      task_private_segment: ^cell;

    FOR i := 1 TO UPPERBOUND (pmv$task_template^.segment) DO
      task_private_segment := #address (#ring (^of_execution), pmv$task_template^.segment [i].number, 0);
    IF syv$nosve_job_template THEN
      i#move (pmv$task_template^.segment [i].content, task_private_segment, #SIZE (pmv$task_template^.segment
            [i].content^));
    ELSE
      {Initialize task templates
      syp$initialize_job_template (FALSE, NIL);
    IFEND;
    FOREND;
    osp$reset_heap (osv$task_private_heap, 100000000, FALSE, 1);
  PROCEND initialize_task_private;


?? TITLE := '    load_user_code_base_ptr', EJECT ??

  PROCEDURE load_user_code_base_ptr (
        target_ring: ost$ring;
        task_program_description: ^pmt$program_description;
        mpe_description: ^pmt$loader_description;
        ada_asynchronous_procedure: boolean;
    VAR user_program_cbp: ^ost$external_code_base_pointer);


    VAR
      enable_inhibit_conditions: ^pmt$enable_inhibit_conditions,
      program_description: ^pmt$program_description,
      program_attributes: ^pmt$program_attributes,
      segment_attributes: ARRAY [1 .. 5] of mmt$attribute_descriptor,
      starting_procedure: pmt$program_name,
      object_file_list: ^pmt$object_file_list,
      module_list: ^pmt$module_list,
      execute_library_list: ^pmt$object_library_list,
      prog_options_and_libraries: ^pmt$prog_options_and_libraries,
      tcb_p: ^pmt$task_control_block,
      loader_options: lot$loader_options,
      end_debug_should_be_called: boolean,
      ignore_status: ost$status,
      local_status: ost$status;


    sfp$emit_statistic (pml$task_begin, '', NIL, local_status);
    IF NOT local_status.normal THEN
      osp$generate_message (local_status, local_status);
    IFEND;

    program_description := task_program_description;

    RESET program_description;
    NEXT program_attributes IN program_description;

    pmp$find_prog_options_and_libs (prog_options_and_libraries);
    fix_program_options (program_attributes^, prog_options_and_libraries^.default_options^, loader_options);


    IF pmp$task_debug_mode_on () AND (pmp$task_debug_ring () <= osc$tsrv_ring) THEN
      pmp$call_begin_debug (NIL);
    IFEND;


    IF pmc$starting_proc_specified IN program_attributes^.contents THEN
      starting_procedure := program_attributes^.starting_procedure;
    ELSE
      starting_procedure := osc$null_name;
    IFEND;
?? EJECT ??

    IF pmc$object_file_list_specified IN program_attributes^.contents THEN
      NEXT object_file_list: [1 .. program_attributes^.number_of_object_files] IN program_description;
    ELSEIF NOT (pmc$starting_proc_specified IN program_attributes^.contents) AND NOT
          (pmc$module_list_specified IN program_attributes^.contents) THEN
      PUSH object_file_list: [1 .. 1];
      object_file_list^ [1] := 'LGO';
    ELSE
      object_file_list := NIL;
    IFEND;


    IF pmc$module_list_specified IN program_attributes^.contents THEN
      NEXT module_list: [1 .. program_attributes^.number_of_modules] IN program_description;
    ELSE
      module_list := NIL;
    IFEND;


    IF pmc$library_list_specified IN program_attributes^.contents THEN
      NEXT execute_library_list: [1 .. program_attributes^.number_of_libraries] IN program_description;
    ELSE
      execute_library_list := NIL;
    IFEND;

    IF pmc$condition_specified IN program_attributes^.contents THEN
      NEXT enable_inhibit_conditions IN program_description;
      pmv$enable_inhibit_conditions.enable_system_conditions := prog_options_and_libraries^.default_options^
            .conditions_enabled + enable_inhibit_conditions^.enable_system_conditions -
            enable_inhibit_conditions^.inhibit_system_conditions;
      pmv$enable_inhibit_conditions.inhibit_system_conditions := prog_options_and_libraries^.
            default_options^.conditions_inhibited + enable_inhibit_conditions^.inhibit_system_conditions -
            enable_inhibit_conditions^.enable_system_conditions;
    ELSE
      pmv$enable_inhibit_conditions.enable_system_conditions := prog_options_and_libraries^.default_options^
            .conditions_enabled;
      pmv$enable_inhibit_conditions.inhibit_system_conditions := prog_options_and_libraries^.
            default_options^.conditions_inhibited;
    IFEND;

?? EJECT ??

    pmp$find_executing_task_tcb (tcb_p);
    IF tcb_p^.nosve.ada_starting_procedure = NIL THEN
      record_loader_statistics (pml$call_loader);
      lop$load_program (object_file_list, module_list, execute_library_list, prog_options_and_libraries^.
          job_library_list, starting_procedure, target_ring, loader_options, mpe_description,
          user_program_cbp, local_status);
      record_loader_statistics (pml$return_from_loader);
    ELSE
      segment_attributes [1].keyword := mmc$kw_preset_value;
      segment_attributes [2].keyword := mmc$kw_segment_access_control;
      segment_attributes [3].keyword := mmc$kw_ring_numbers;
      segment_attributes [4].keyword := mmc$kw_max_segment_length;
      segment_attributes [5].keyword := mmc$kw_software_attributes;
      segment_attributes [1].preset_value := pmc$initialize_to_zero;
      segment_attributes [2].access_control.cache_bypass := FALSE;
      segment_attributes [2].access_control.execute_privilege := osc$non_executable;
      segment_attributes [2].access_control.read_privilege := osc$read_uncontrolled;
      segment_attributes [2].access_control.write_privilege := osc$write_uncontrolled;
      segment_attributes [3].r1 := tcb_p^.target_ring;
      segment_attributes [3].r2 := tcb_p^.target_ring;
      segment_attributes [4].max_length := loader_options.maximum_stack_size;
      segment_attributes [5].software_attri_set := $mmt$software_attribute_set [mmc$sa_stack];
      pmp$create_shared_stack (^segment_attributes, local_status);
      IF NOT local_status.normal THEN
        pmp$exit (local_status);
      IFEND;
    IFEND;

    IF NOT local_status.normal THEN
      pmp$end_debug_should_be_called (end_debug_should_be_called);
      IF end_debug_should_be_called THEN
        pmp$push_task_debug_mode (pmc$debug_mode_off, ignore_status);
      IFEND;
      pmp$exit (local_status);
    IFEND;


  PROCEND load_user_code_base_ptr;

?? OLDTITLE ??
?? TITLE := '  fix_program_options', EJECT ??

  PROCEDURE fix_program_options (program_attributes: pmt$program_attributes;
        job_default_program_options: pmt$program_options;
    VAR loader_options: lot$loader_options);
*copyc mmv$preset_conversion_table
*copyc pmp$get_processor_attributes
*copyc pmp$fix_initial_debug

    VAR
      task_debug_mode: pmt$debug_mode,
      processor_attributes: pmt$processor_attributes,
      debug_input: amt$local_file_name,
      debug_output: amt$local_file_name,
      abort_file: amt$local_file_name,
      local_status: ost$status;

?? EJECT ??

    IF (pmc$debug_input_specified IN program_attributes.contents) THEN
      debug_input := program_attributes.debug_input;
    ELSE
      debug_input := job_default_program_options.debug_input;
    IFEND;
    IF (pmc$debug_mode_specified IN program_attributes.contents) THEN
      task_debug_mode := (program_attributes.debug_mode AND (debug_input <> clc$null_file));
    ELSE
      task_debug_mode := (job_default_program_options.debug_mode AND (debug_input <> clc$null_file));
    IFEND;
    IF (pmc$debug_output_specified IN program_attributes.contents) THEN
      debug_output := program_attributes.debug_output;
    ELSE
      debug_output := job_default_program_options.debug_output;
    IFEND;
    IF (pmc$abort_file_specified IN program_attributes.contents) THEN
      abort_file := program_attributes.abort_file;
    ELSE
      abort_file := job_default_program_options.abort_file;
    IFEND;
    pmp$set_task_debug_ring;
    pmp$fix_initial_debug (task_debug_mode, debug_input, debug_output, abort_file);

    pmp$set_task_debug_mode (task_debug_mode, local_status);
    IF NOT local_status.normal THEN
      pmp$exit (local_status);
    IFEND;

    IF pmc$load_map_file_specified IN program_attributes.contents THEN
      loader_options.map_file := program_attributes.load_map_file;
    ELSE
      loader_options.map_file := job_default_program_options.map_file;
    IFEND;
    IF pmc$load_map_options_specified IN program_attributes.contents THEN
      IF pmc$no_load_map IN program_attributes.load_map_options THEN
        loader_options.map := $pmt$load_map_options [pmc$no_load_map];
      ELSE
        loader_options.map := program_attributes.load_map_options;
      IFEND;
    ELSE
      loader_options.map := job_default_program_options.map_options;
    IFEND;
?? EJECT ??
    IF pmc$term_error_level_specified IN program_attributes.contents THEN
      loader_options.termination_error_level := program_attributes.termination_error_level;
    ELSE
      loader_options.termination_error_level := job_default_program_options.termination_error_level;
    IFEND;
    IF pmc$preset_specified IN program_attributes.contents THEN
      loader_options.preset := mmv$preset_conversion_table [program_attributes.preset];
    ELSE
      loader_options.preset := job_default_program_options.preset;
    IFEND;
    IF pmc$max_stack_size_specified IN program_attributes.contents THEN
      IF (program_attributes.maximum_stack_size > pmc$maximum_user_stack_size) THEN
        loader_options.maximum_stack_size := pmc$maximum_user_stack_size;
      ELSE
        pmp$get_processor_attributes (processor_attributes, local_status);
        IF NOT local_status.normal THEN
          pmp$exit (local_status);
        IFEND;
        IF ((program_attributes.maximum_stack_size MOD processor_attributes.page_size) = 0) THEN
          loader_options.maximum_stack_size := program_attributes.maximum_stack_size;
        ELSE
          loader_options.maximum_stack_size := ((program_attributes.maximum_stack_size DIV
                processor_attributes.page_size) + 1) * processor_attributes.page_size;
        IFEND;
      IFEND;
    ELSE
      loader_options.maximum_stack_size := job_default_program_options.maximum_stack_size;
    IFEND;
    loader_options.debug_ring := pmp$task_debug_ring ();
  PROCEND fix_program_options;
?? NEWTITLE := '    record_loader_statisitics', EJECT ??

  PROCEDURE record_loader_statistics (kind: sft$statistic_code);


    VAR
      cp_time: pmt$task_cp_time,
      xcb: ^ost$execution_control_block,
      loader_statistics: [STATIC] array [1 .. 7] of sft$counter,
      local_status: ost$status,
      ignore_status: ost$status;

    local_status.normal := TRUE;

    pmp$find_executing_task_xcb (xcb);

    pmp$get_task_cp_time (cp_time, local_status);

    IF kind = pml$call_loader THEN
      IF local_status.normal THEN
        loader_statistics [1] := cp_time.task_time;
        loader_statistics [2] := cp_time.monitor_time;
      ELSE
        loader_statistics [1] := 0;
        loader_statistics [2] := 0;
      IFEND;

      loader_statistics [3] := xcb^.paging_statistics.page_fault_count;
      loader_statistics [4] := xcb^.paging_statistics.page_in_count;
      loader_statistics [5] := xcb^.paging_statistics.pages_reclaimed_from_queue;
      loader_statistics [6] := xcb^.paging_statistics.new_pages_assigned;
      loader_statistics [7] := xcb^.paging_statistics.pages_from_server;

      sfp$emit_statistic (pml$call_loader, '', NIL, ignore_status);

    ELSEIF kind = pml$return_from_loader THEN
      IF local_status.normal THEN
        loader_statistics [1] := cp_time.task_time - loader_statistics [1];
        loader_statistics [2] := cp_time.monitor_time - loader_statistics [2];
      ELSE
        loader_statistics [1] := 0;
        loader_statistics [2] := 0;
      IFEND;
      loader_statistics [3] := xcb^.paging_statistics.page_fault_count - loader_statistics [3];
      loader_statistics [4] := xcb^.paging_statistics.page_in_count - loader_statistics [4];
      loader_statistics [5] := xcb^.paging_statistics.pages_reclaimed_from_queue - loader_statistics [5];
      loader_statistics [6] := xcb^.paging_statistics.new_pages_assigned - loader_statistics [6];
      loader_statistics [7] := xcb^.paging_statistics.pages_from_server - loader_statistics [7];

      sfp$emit_statistic (pml$return_from_loader, xcb^.save9, ^loader_statistics,
            ignore_status);
    IFEND;


  PROCEND record_loader_statistics;
?? TITLE := '  call_user_program', EJECT ??

  PROCEDURE call_user_program (target_ring: ost$ring;
        user_program_cbp: ^ost$external_code_base_pointer;
        program_parameters: ^pmt$program_parameters);


    VAR
      converter: record
        case 0 .. 1 of
        = 0 =
          procedure_pointer: ^procedure (p1: ^ost$external_code_base_pointer;
            p2: ^pmt$program_parameters),
        = 1 =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend,


{ This variable is defined only to be used to take up space in the stack. }
      space_variable: ^array [*] of cell,

      stack_segment: ^pmt$stack_segment,
      tcb_p: ^pmt$task_control_block,
      original_caller_cbp: ^ost$external_code_base_pointer,
      local_status: ost$status;


{   NOTE:  The following variable declaration is sensitive to CYBIL argument list format.

    VAR
      original_caller_param_list: ^record
        right_just_val1: 0 .. 0ffff(16),
        user_program_cbp: ^ost$external_code_base_pointer,
        program_parameters_left: ^^pmt$program_parameters,
        left_just_val1: 0 .. 0ffff(16),
        program_parameters: ^pmt$program_parameters,
      recend;

 ?? EJECT ??

    pmp$find_executing_task_tcb (tcb_p);
    IF target_ring > osc$tsrv_ring THEN
      IF tcb_p^.nosve.ada_starting_procedure = NIL THEN
        pmp$find_stack_segment (target_ring, stack_segment);
      ELSE
        stack_segment := tcb_p^.nosve.ada_shared_stack_pointer.seq_pointer;
      IFEND;

      RESET stack_segment;
      NEXT original_caller_param_list IN stack_segment;
      original_caller_param_list^.user_program_cbp := user_program_cbp;

      IF #SIZE (program_parameters^) > 0 THEN
        NEXT original_caller_param_list^.program_parameters: [[REP #SIZE (program_parameters^) OF cell]] IN
              stack_segment;
      ELSE
        i#build_adaptable_seq_pointer (#ring (stack_segment), #segment (stack_segment), 0, 0, 0,
              original_caller_param_list^.program_parameters);
      IFEND;

      original_caller_param_list^.program_parameters^ := program_parameters^;
      original_caller_param_list^.program_parameters_left := ^original_caller_param_list^.program_parameters;
      converter.procedure_pointer := ^pmp$original_caller;
      original_caller_cbp := converter.code_base_pointer;
      pmp$outward_call (original_caller_cbp, target_ring, original_caller_param_list,
            NIL, stack_segment); { does not return }


    ELSEIF target_ring = osc$tsrv_ring THEN
      pmp$original_caller (user_program_cbp, program_parameters);

    ELSE
      osp$set_status_abnormal ('PM', pme$transfer_address_ring_error, '', local_status);
      pmp$exit (local_status);
    IFEND;

  PROCEND call_user_program;

MODEND pmm$task_initiation;
*DECK DECK=PMM$TASK_TERMINATION EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE : Tasking : Task termination' ??
?? NEWTITLE := '  Global declarations', EJECT ??
MODULE pmm$task_termination;

{  PURPOSE:
{    This module contains procedures which direct that portion of task termination which occurs
{    in the ring(s) of the user program.  This consists primarily of activating the debug facility,
{    if appropriate, and activating any block_exit handlers outstanding in the user program.
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$stack_frame_save_area
*copyc osk$keypoints
*copyc pmk$keypoints
*copyc oss$job_paged_literal
*copyc pme$debug_exceptions
?? POP ??
*copyc clp$set_processing_phase
*copyc clp$execute_job_epilog
*copyc osp$executing_in_job_monitor
*copyc osp$set_status_from_condition
*copyc osp$set_status_abnormal
*copyc osp$generate_log_message
*copyc osp$system_error
*copyc bap$loaded_ring_cleanup
*copyc bap$monitor_loaded_ring_cleanup
*copyc pmp$establish_condition_handler
*copyc pmp$execute_job_epilogs
*copyc pmp$get_termination_status
*copyc pmp$task_debug_mode_on
*copyc pmp$task_debug_ring
*copyc pmp$pop_all_stack_frames
*copyc pmp$find_end_debug
*copyc pmp$task_state
*copyc pmp$cleanup_loaded_rings
*copyc pmp$condition_task_termination
*copyc pmp$record_program_termination
*copyc pmp$get_termination_status
*copyc pmp$debug_abort_file_specified
*copyc pmp$set_debug_ending
*copyc pmp$load_debug_procedures
*copyc clv$processing_phase

  VAR
    conditions: [STATIC, READ, oss$job_paged_literal] pmt$condition := [pmc$condition_combination,
      $pmt$condition_combination [pmc$system_conditions, mmc$segment_access_condition]];

?? TITLE := '  [XDCL, #GATE] pmp$abort', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$abort (status: ost$status);

{  PURPOSE:
{    This procedure terminates the executing task.  It is intended that this interface be used
{    to indicate task termination due to some failure internal to the task.
{  NOTE:
{    This procedure must not return to its caller under any circumstances.

    VAR
      established_handler: pmt$established_handler,
      psa: ^ost$minimum_save_area,
      stack_frames_to_pop: boolean,
      local_status: ost$status;

    #keypoint (osk$entry, 0, pmk$abort);

{ The job monitor task should never "abort".  That is, the debugger cannot run
{ in the job monitor task.

    IF osp$executing_in_job_monitor () THEN
      pmp$exit (status);
    ELSE
      pmp$establish_condition_handler (conditions, ^terminate_program_cond_handler, ^established_handler,
            local_status);
      pmp$condition_task_termination;
      IF NOT local_status.normal THEN
        pmp$cleanup_loaded_rings;
      ELSE
        psa := #previous_save_area ();
        stack_frames_to_pop := psa^.a2_previous_save_area <> NIL;
        terminate_program (pmc$program_aborting, stack_frames_to_pop, status);
      IFEND;
      WHILE TRUE DO
      WHILEND;
    IFEND;
  PROCEND pmp$abort;
?? TITLE := '  [XDCL, #GATE] pmp$exit', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$exit (status: ost$status);

{  PURPOSE:
{    This procedure terminates the executing task.  It is intended that this interface be used
{    to indicate normal task termination or task termination due to some failure external to
{    the task (e.g., bad input parameters).
{  NOTE:
{    This procedure must not return to its caller under any circumstances.

    VAR
      established_handler: pmt$established_handler,
      psa: ^ost$minimum_save_area,
      stack_frames_to_pop: boolean,
      local_status: ost$status;

    #keypoint(osk$entry, 0, pmk$exit);
    pmp$establish_condition_handler (conditions, ^terminate_program_cond_handler, ^established_handler,
          local_status);
    pmp$condition_task_termination;
    IF NOT local_status.normal THEN
      pmp$cleanup_loaded_rings;
    ELSE
      psa := #previous_save_area ();
      stack_frames_to_pop := psa^.a2_previous_save_area <> NIL;
      terminate_program (pmc$program_exiting, stack_frames_to_pop, status);
    IFEND;
    WHILE TRUE DO
    WHILEND;
  PROCEND pmp$exit;
?? TITLE := '  terminate_program', EJECT ??

  PROCEDURE terminate_program (program_termination_mode: pmt$program_termination_mode;
        stack_frames_to_pop: boolean;
        status: ost$status);

{  PURPOSE:
{    This procedure directs the actual task termination for both PMP$EXIT and PMP$ABORT.
{  NOTE:
{    This procedure may be called more than once for a single task and must be reentrant.

    VAR
      end_debug_should_be_called: boolean;


    pmp$record_program_termination (status, program_termination_mode);

    IF stack_frames_to_pop THEN
      pmp$pop_all_stack_frames;
    ELSE
      pmp$end_debug_should_be_called (end_debug_should_be_called);
      IF end_debug_should_be_called THEN
        pmp$call_end_debug;
      IFEND;

      IF (osp$executing_in_job_monitor()) AND
           (clv$processing_phase <> clc$job_end_phase) THEN
        pmp$execute_job_epilogs;
      IFEND;

      pmp$cleanup_loaded_rings;
    IFEND;

  PROCEND terminate_program;
?? TITLE := '  terminate_program_cond_handler', EJECT ??

  PROCEDURE terminate_program_cond_handler (condition: pmt$condition;
        descriptor: ^pmt$condition_information;
        save_area: ^ost$stack_frame_save_area;
    VAR status: ost$status);


    VAR
      message: ost$status,
      ignore_status: ost$status;

    osp$set_status_from_condition ('PM', condition, save_area, message, ignore_status);
    osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], message, ignore_status);
    status.normal := TRUE;
    pmp$cleanup_loaded_rings;
  PROCEND terminate_program_cond_handler;
?? TITLE := '  [XDCL] pmp$end_debug_should_be_called', EJECT ??

  PROCEDURE [XDCL] pmp$end_debug_should_be_called (VAR end_debug_should_be_called: boolean);


    VAR
      of_execution: cell,
      abort_file_specified: boolean;


    pmp$debug_abort_file_specified (abort_file_specified);

    end_debug_should_be_called := (pmp$task_debug_mode_on () OR (abort_file_specified AND (pmp$task_state () =
          pmc$program_aborting))) AND (#ring (^of_execution) >= pmp$task_debug_ring ());


  PROCEND pmp$end_debug_should_be_called;
?? TITLE := '  [XDCL] pmp$call_end_debug', EJECT ??

  PROCEDURE [XDCL] pmp$call_end_debug;

{  PURPOSE:
{    This procedure is responsible for invoking the debug facility at program termination.

    VAR
      termination_status: ost$status,
      end_debug: dbt$end_debug,
      task_state: pmt$task_state,
      local_status: ost$status,
      log_status: ost$status;

    task_state := pmp$task_state ();
    IF (task_state < pmc$debug_ending) THEN
      pmp$set_debug_ending;
      pmp$find_end_debug (end_debug);
      IF end_debug <> NIL THEN
        pmp$get_termination_status (termination_status);
        end_debug^ (task_state = pmc$program_aborting, termination_status);
      ELSE
        osp$set_status_abnormal ('PM', pme$unable_to_load_debug, 'DBP$END_DEBUG', local_status);
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, log_status);
      IFEND;
    IFEND;
  PROCEND pmp$call_end_debug;
?? TITLE := '  [XDCL] pmp$loaded_ring_cleanup', EJECT ??

  PROCEDURE [XDCL] pmp$loaded_ring_cleanup;

{  PURPOSE:
{    This procedure exists to drive task cleanup procedures which must be executed in each
{    ring in which the user program executed.

    VAR
      ignored_status: ost$status;

    bap$loaded_ring_cleanup;
    ignored_status.normal := TRUE;
    pmp$exit (ignored_status);
  PROCEND pmp$loaded_ring_cleanup;

?? TITLE := '  [XDCL] pmp$monitor_loaded_ring_cleanup', EJECT ??

  PROCEDURE [XDCL] pmp$monitor_loaded_ring_cleanup;

{  PURPOSE:
{    This procedure exists to drive job monitor task cleanup procedures which must be executed in each
{    ring in which the user program executed.

    VAR
      ignored_status: ost$status;

    bap$monitor_loaded_ring_cleanup;
{  The following procedure call allows pmp$execute_job_epilogs to be re-entrant.
    clp$set_processing_phase (PRED (clv$processing_phase), ignored_status);
    ignored_status.normal := TRUE;
    pmp$exit (ignored_status);

  PROCEND pmp$monitor_loaded_ring_cleanup;

?? TITLE := '  [XDCL] pmp$execute_epilog', EJECT ??

  PROCEDURE [XDCL] pmp$execute_epilog;

{  PURPOSE:
{    This procedure exists to call the procedure clp$execute_job_epilog in the job monitor
{    execution ring.
{

    VAR
      status: ost$status;

    clp$execute_job_epilog;
    status.normal := TRUE;
    pmp$exit (status);

  PROCEND pmp$execute_epilog;

?? TITLE := '  [XDCL] pmp$call_end_handler', EJECT ??

  PROCEDURE [XDCL] pmp$call_end_handler;

{  PURPOSE:
{    This procedure exists to call the task end handler in the
{    ring in which it was established.

*copyc pmt$end_handler
*copyc pmv$end_handler_to_call

    VAR
      end_handler_term_status: ost$status,
      handler_status: ost$status;

    pmp$get_termination_status (end_handler_term_status);

{ Call the end handler.

    handler_status.normal := TRUE;
    pmv$end_handler_to_call^ (end_handler_term_status, handler_status);

    pmp$exit (handler_status);

  PROCEND pmp$call_end_handler;

MODEND pmm$task_termination;
*DECK DECK=PMM$TASK_TERMINATION_RING_3 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Tasking : Ring 3 task termination' ??
MODULE pmm$task_termination_ring_3;

{  PURPOSE:
{    This module contains procedures which direct that portion of task termination which occurs
{    in task services rings.  This consists primarily of dismantling the task environment.
{  DESIGN:
{    The dismantling of a task's environment is divided into two distinct phases.  The first
{    occurs in the terminating (child) task.  It consists of discarding all non_essential portions
{    of the task's address space and issuing a monitor request to relinquish the CPU.  The second
{    phase occurs in the task (the parent task) which originally initiated the terminating task.
{    It consists of discarding the remaining task environment.
{    Design of several procedures in this module reflects the fact that, if possible, a task
{    must terminate in spite of errors occurring in the task termination process.

?? NEWTITLE := '  Global declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avc$system_epilog
*copyc clc$compiling_for_test_harness
*copyc cle$epilog_file_missing
*copyc dmt$error_condition_codes
*copyc jme$job_monitor_conditions
*copyc jme$unable_to_alloc_all_space
*copyc jml$user_id
*copyc jmt$timesharing_signal
*copyc osc$dual_state_interactive
*copyc osd$code_base_pointer
*copyc osd$virtual_address
*copyc osk$keypoints
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc oss$task_shared
*copyc ost$caller_identifier
*copyc ost$global_task_id
*copyc pmc$min_scc_program_execution
*copyc pme$execution_exceptions
*copyc pme$system_exceptions
*copyc pmk$keypoints
*copyc pmt$loader_seq_descriptor
*copyc pmt$program_description
*copyc pmt$signal
*copyc pmt$task_control_block
*copyc pmt$task_execution_phase
*copyc pmt$task_state
*copyc pmt$task_termination_action
*copyc sfc$unlimited
*copyc tmc$signal_identifiers
*copyc tmc$wait_times
?? POP ??
*copyc amp$get_file_attributes
*copyc avp$end_account
*copyc avp$get_capability
*copyc avp$get_file_value
*copyc avp$security_option_active
*copyc bap$loaded_ring_cleanup
*copyc bap$monitor_loaded_ring_cleanup
*copyc bap$monitor_task_term_cleanup
*copyc bap$task_termination_cleanup
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$create_environment_variable
*copyc clp$delete_all_from_cmnd_list
*copyc clp$delete_variable
*copyc clp$delete_variables
*copyc clp$erase_child_task
*copyc clp$establish_sys_command_lib
*copyc clp$evaluate_file_reference
*copyc clp$find_task_block
*copyc clp$pop_terminated_blocks
*copyc clp$put_job_command_response
*copyc clp$record_application_units
*copyc clp$reset_work_area_positions
*copyc clp$set_job_command_search_mode
*copyc clp$update_applic_resources
*copyc cmp$task_termination_cleanup
*copyc fmp$detach_all_tape_files
*copyc fmp$unlock_path_table_at_tskend
*copyc ifp$stop_interactive
*copyc iip$clear_job_locks
*copyc iip$xt_stop_xterm
*copyc jmp$disable_user_breaks
*copyc jmp$emit_communication_stat
*copyc jmp$enable_terminal_io
*copyc jmp$get_job_class_epilog
*copyc jmp$is_xterm_job
*copyc jmp$job_end
*copyc jmp$release_generic_queue_files
*copyc jmp$release_input_files
*copyc jmp$release_output_files
*copyc jmp$set_interactive_cond_state
*copyc jmp$set_job_term_disposition
*copyc jmp$set_job_termination_status
*copyc jmp$system_error
*copyc lop$close_apd_processing_files
*copyc lop$delete_linkage_tree
*copyc lop$delete_loader_library_list
*copyc lop$get_loader_seq_descriptor
*copyc lop$terminate_loader
*copyc mlp$task_termination_cleanup
*copyc mmp$verify_access
*copyc nap$incoming_message_cleanup
*copyc nap$process_task_termination
*copyc ofp$task_end
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$executing_in_job_monitor
*copyc osp$generate_log_message
*copyc osp$generate_message
*copyc osp$get_status_severity
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$system_error
*copyc osp$test_aam_activity_r1
*copyc osp$verify_system_privilege
*copyc pfp$attach
*copyc pfp$clear_system_authority
*copyc pfp$convert_fs_to_pft$path
*copyc pfp$detach_reserved_cycles
*copyc pfp$task_termination_cleanup
*copyc pmp$add_final_interblock_ref
*copyc pmp$call_end_handler
*copyc pmp$collect_raw_task_statistics
*copyc pmp$continue_to_cause
*copyc pmp$cycle
*copyc pmp$debug_abort_file_specified
*copyc pmp$delete_non_inherited_segs
*copyc pmp$disconnect_task_from_queues
*copyc pmp$disestablish_cond_handler
*copyc pmp$enable_ts_io_in_job
*copyc pmp$establish_condition_handler
*copyc pmp$execute_epilog
*copyc pmp$exit
*copyc pmp$find_prog_options_and_libs
*copyc pmp$find_executing_task_tcb
*copyc pmp$find_executing_task_xcb
*copyc pmp$find_stack_segment
*copyc pmp$find_task_tcb
*copyc pmp$find_task_xcb
*copyc pmp$flag_all_child_tasks
*copyc pmp$generate_unique_name
*copyc pmp$get_global_task_id
*copyc pmp$get_job_mode
*copyc pmp$get_job_names
*copyc pmp$get_loaded_rings
*copyc pmp$get_task_cp_time
*copyc pmp$get_task_id
*copyc pmp$get_termination_status
*copyc pmp$init_default_prog_options
*copyc pmp$load_debug_procedures
*copyc pmp$loaded_ring_cleanup
*copyc pmp$log
*copyc pmp$log_ascii
*copyc pmp$long_term_wait
*copyc pmp$monitor_loaded_ring_cleanup
*copyc pmp$outward_call
*copyc pmp$push_task_debug_mode
*copyc pmp$release_task_environment
*copyc pmp$set_task_state
*copyc pmp$signal_all_child_tasks
*copyc pmp$task_debug_mode_on
*copyc pmp$task_debug_ring
*copyc pmp$task_end
*copyc pmp$task_state
*copyc pmp$verify_current_child
*copyc pmp$wait
*copyc qfp$set_job_attributes
*copyc sfp$change_file_space_limit
*copyc sfp$clear_job_routing_ctl_lock
*copyc sfp$emit_audit_statistic
*copyc sfp$emit_statistic
*copyc sfp$internal_emit_statistic
*copyc syp$pop_inhibit_job_recovery
*copyc syp$push_inhibit_job_recovery
*copyc tmp$disable_preemptive_commo
*copyc tmp$fetch_job_statistics
*copyc tmp$find_ring_crossing_frame

*copyc clv$applications_active
*copyc clv$processing_phase
*copyc clv$standard_files
*copyc jmv$executing_within_system_job
*copyc jmv$job_attributes
*copyc jmv$job_termination_status
*copyc jmv$terminal_io_disabled
*copyc lov$apd_load
*copyc pmv$debug_logging_enabled
*copyc pmv$end_handler_list

  VAR
    pmv$epilog_file: [XDCL, #GATE, oss$task_shared] string (fsc$max_path_size),
    pmv$task_execution_phase: [XDCL, #GATE, oss$task_private]
          pmt$task_execution_phase := LOWERVALUE (pmt$task_execution_phase),
    pmv$popper_handler_established: [XDCL, #GATE, oss$task_private] boolean := FALSE,
    termination_revocable: [STATIC] boolean := TRUE,
    termination_revocations: [STATIC] 0 .. 1000 := 0;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$exit_unix_task', EJECT ??
*copy pmh$exit_unix_task

  PROCEDURE [XDCL] pmp$exit_unix_task
    (    parent_task_gtid: ost$global_task_id;
         task_termination_action: pmt$task_termination_action);

?? NEWTITLE := 'truncate_stack', EJECT ??

{ PURPOSE:
{   The purpose of this request is to truncate the stack at the ring 3 ring
{ crossing frame.

    PROCEDURE truncate_stack;

      VAR
        local_status: ost$status,
        starting_frame_p: ^ost$stack_frame_save_area,
        xing_frame_p: ^ost$stack_frame_save_area;

      local_status.normal := TRUE;

{ Truncate the stack at the ring 3 ring crossing frame.

      starting_frame_p := NIL;
      tmp$find_ring_crossing_frame (starting_frame_p, xing_frame_p, local_status);
      IF NOT local_status.normal THEN
        pmp$exit (local_status);
      IFEND;

      starting_frame_p := xing_frame_p^.minimum_save_area.a2_previous_save_area;
      WHILE ((starting_frame_p <> NIL) AND (#RING (starting_frame_p) <= osc$tsrv_ring) AND
            local_status.normal) DO
        tmp$find_ring_crossing_frame (starting_frame_p, xing_frame_p, local_status);
        starting_frame_p := xing_frame_p^.minimum_save_area.a2_previous_save_area;
      WHILEND;

      IF local_status.normal THEN
        xing_frame_p^.minimum_save_area.a2_previous_save_area := NIL;

      ELSE
        pmp$exit (local_status);
      IFEND;

    PROCEND truncate_stack;
?? OLDTITLE ??

{ Record record the UNIX kernel termination information in the TCB.

{ Truncate the stack at the ring 3 ring crossing frame.

{ Send the task into termination.


  PROCEND pmp$exit_unix_task;
?? OLDTITLE ??
?? NEWTITLE := '  [XDCL, #GATE] pmp$record_program_termination', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$record_program_termination
    (    status: ost$status;
         program_termination_mode: pmt$program_termination_mode);

{  PURPOSE:
{    This procedure is called whenever a program terminates, i.e., calls PMP$EXIT or PMP$ABORT.
{    It records (in a secure location) the task completion status to be returned to the
{    executing task's parent in the event that the task actually terminates.  It also enables
{    abort_file processing when appropriate.
{  NOTE:
{    This procedure may be called more than once for a single task.  Only the first abnormal
{    status will be recorded.  Abort_file processing will be enabled only once.

    VAR
      ignore_status: ost$status;

?? NEWTITLE := 'rpt_condition_handler', EJECT ??

{ PURPOSE:
{   Condition handler for record_program_termination.

    PROCEDURE rpt_condition_handler
      (    condition: pmt$condition;
           descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        message: ost$status;

      IF (condition.selector <> ifc$interactive_condition) AND (condition.selector <> pmc$pit_condition) THEN
        osp$set_status_from_condition ('PM', condition, save_area, message, ignore_status);
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], message, ignore_status);
        pmp$disestablish_cond_handler (conditions, ignore_status);
        pmp$cleanup_loaded_rings; { does not return }
      IFEND;
    PROCEND rpt_condition_handler;
?? OLDTITLE, EJECT ??

    VAR
      caller: ost$caller_identifier,
      conditions: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
            [pmc$condition_combination, $pmt$condition_combination
            [pmc$system_conditions, mmc$segment_access_condition, ifc$interactive_condition,
            pmc$pit_condition]],
      established_handler: pmt$established_handler,
      program_description: ^pmt$program_description,
      program_attributes: ^pmt$program_attributes,
      tcb_p: ^pmt$task_control_block,
      abort_file_specified: boolean,
      local_status: ost$status;

    osp$verify_system_privilege;

    #CALLER_ID (caller);
    IF (caller.ring <= osc$tsrv_ring) THEN
      termination_revocable := FALSE;
    IFEND;

    IF jmv$executing_within_system_job THEN
      IF osp$executing_in_job_monitor () THEN
        jmp$system_error ('system job exit', ^status);
      IFEND;
    IFEND;

    pmp$establish_condition_handler (conditions, ^rpt_condition_handler, ^established_handler, local_status);
    IF NOT local_status.normal THEN
      pmp$cleanup_loaded_rings; { does not return }
    ELSE
      IF program_termination_mode > pmp$task_state () THEN
        pmp$set_task_state (program_termination_mode);
      IFEND;
      IF NOT status.normal THEN
        pmp$flag_all_child_tasks (pmc$sf_terminate_task, local_status);
        pmp$find_executing_task_tcb (tcb_p);
        WHILE tcb_p^.first_child <> NIL DO
          pmp$long_term_wait (tmc$infinite_wait, tmc$infinite_wait);
        WHILEND;
        IF tcb_p^.nosve.termination_status^.normal THEN
          tcb_p^.nosve.termination_status^ := status;
        ELSE
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], status, ignore_status);
        IFEND;
      IFEND;

      pmp$debug_abort_file_specified (abort_file_specified);

      IF ((program_termination_mode = pmc$program_aborting) AND (NOT pmp$task_debug_mode_on ()) AND
            abort_file_specified) THEN
        pmp$load_debug_procedures (ignore_status);

{status is ignored because a debugger may not be loadable at this point.

      IFEND;
    IFEND;
  PROCEND pmp$record_program_termination;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$revoke_program_termination', EJECT ??
*copy pmh$revoke_program_termination

  PROCEDURE [XDCL, #GATE] pmp$revoke_program_termination
    (VAR status: ost$status);

{  PURPOSE:
{    This procedure is called to revoke a previously recorded program termination.  This
{    interface is used when a process executing subsequent to a program terminating
{    (e.g., debug facility or block_exit handler) desires to restart the program.

    VAR
      tcb_p: ^pmt$task_control_block;

    #KEYPOINT (osk$entry, 0, pmk$revoke_program_termination);
    status.normal := TRUE;
    IF termination_revocable THEN
      IF (termination_revocations < UPPERVALUE (termination_revocations)) THEN
        pmp$set_task_state (pmc$task_active);
        pmp$find_executing_task_tcb (tcb_p);
        tcb_p^.nosve.termination_status^.normal := TRUE;
        termination_revocations := termination_revocations + 1;
      ELSE
        osp$set_status_abnormal ('PM', pme$maximum_term_revocations, '', status);
      IFEND;
    ELSE
      osp$set_status_abnormal ('PM', pme$termination_not_revocable, '', status);
    IFEND;
    #KEYPOINT (osk$exit, 0, pmk$revoke_program_termination);
  PROCEND pmp$revoke_program_termination;
?? TITLE := '  [XDCL, #GATE] pmp$cleanup_loaded_rings', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$cleanup_loaded_rings;


{  PURPOSE:
{    This procedure is responsible for calling ring_dependent task cleanup procedures in each
{    ring in which the user program executed.  Rings are processed in order of increasing
{    privilege.
{  NOTE:
{    This procedure is designed to be called several times within a single task.  (This is
{    necessary since activating cleanup procedures in a less privileged ring requires an
{    outward call, which destroys preceding stack frames.)  It utilizes state memory to
{    determine which ring, if any, to process on a particular call.  For each ring, at most one
{    attempt will be made to call ring_dependent cleanup procedures in that ring.

?? NEWTITLE := 'clr_condition_handler', EJECT ??

{ PURPOSE:
{   Ignore interactive and pit conditions, put any others in the job log and
{   call terminate_task.

    PROCEDURE clr_condition_handler
      (    condition: pmt$condition;
           descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        executing_ring: ost$ring,
        message: ost$status,
        ignore_status: ost$status;

      IF (condition.selector <> ifc$interactive_condition) AND (condition.selector <> pmc$pit_condition) THEN
        osp$set_status_from_condition ('PM', condition, save_area, message, ignore_status);
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], message, ignore_status);
        pmp$disestablish_cond_handler (conditions, ignore_status);
        program_ring := #RING (^executing_ring);
        terminate_task; { does not return }
      IFEND;
    PROCEND clr_condition_handler;
?? OLDTITLE, EJECT ??

    CONST
      debug_bit = 56;

    TYPE
      pmt$user_mask = set of 0 .. 63;

    VAR
      converter: record
        case 0 .. 3 of
        = 0 =
          register: integer,
        = 1 =
          user_mask: pmt$user_mask,
        = 2 =
          pointer_to_procedure: ^procedure,
        = 3 =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend;

    VAR
      pmv$end_handler_to_call: [XDCL, #GATE, STATIC, oss$task_private] pmt$end_handler := NIL;

    VAR
      program_ring: [STATIC, oss$task_private] pmt$loadable_ring := UPPERVALUE (pmt$loadable_ring),
      executing_ring: ost$ring,
      loaded_rings: pmt$loadable_rings,
      loader_seq_descriptor_p: ^pmt$loader_seq_descriptor,
      system_core_debugger_inactive: boolean,
      cleanup_cbp: ^ost$external_code_base_pointer,
      stack_segment: ^pmt$stack_segment,
      child_tasks_flagged: boolean,
      conditions: pmt$condition,
      established_handler: pmt$established_handler,
      tcb_p: ^pmt$task_control_block,
      handler: ^pmt$end_handler_desc,
      local_status: ost$status;

?? EJECT ??

    osp$verify_system_privilege;

    child_tasks_flagged := FALSE;
    termination_revocable := FALSE;
    pmp$set_task_execution_phase (pmc$task_loaded_ring_cleanup);

    system_core_debugger_inactive := (#READ_REGISTER (osc$pr_debug_list_pointer) DIV 100000000000(16) <> 1);

    IF program_ring < pmp$task_debug_ring () THEN
      IF pmp$task_debug_mode_on () THEN
        pmp$push_task_debug_mode (pmc$debug_mode_off, local_status);
      IFEND;

      IF system_core_debugger_inactive THEN
        converter.register := #READ_REGISTER (osc$pr_user_mask_reg);
        converter.user_mask := converter.user_mask - $pmt$user_mask [debug_bit];
        #WRITE_REGISTER (osc$pr_user_mask_reg, converter.register);
      IFEND;
    IFEND;

{ If this is an ADA parent we cannot procede further with children still executing.

    pmp$find_executing_task_tcb (tcb_p);
    IF (tcb_p^.nosve.ada_task_table <> NIL) AND (tcb_p^.nosve.ada_task_table^.table [0] = tcb_p^.task_id) THEN
      WHILE tcb_p^.first_child <> NIL DO
        IF (NOT tcb_p^.nosve.termination_status^.normal) AND (NOT child_tasks_flagged) THEN
          pmp$flag_all_child_tasks (pmc$sf_terminate_task, local_status);
          IF NOT local_status.normal THEN
            osp$system_error ('pmp$flag_all_child_tasks', ^local_status);
          IFEND;
          child_tasks_flagged := TRUE;
        IFEND;
        pmp$long_term_wait (tmc$infinite_wait, tmc$infinite_wait);
      WHILEND;
    IFEND;

    conditions.selector := pmc$condition_combination;
    conditions.combination := $pmt$condition_combination [pmc$system_conditions, mmc$segment_access_condition,
          ifc$interactive_condition, pmc$pit_condition];
    pmp$establish_condition_handler (conditions, ^clr_condition_handler, ^established_handler, local_status);

    IF local_status.normal THEN
      pmp$get_loaded_rings (loaded_rings);
      WHILE program_ring > #RING (^executing_ring) DO
        IF pmv$end_handler_list <> NIL THEN
          handler := pmv$end_handler_list^ [program_ring];
          WHILE handler <> NIL DO
            IF NOT ((handler^.disestablished) OR (handler^.called)) THEN
              handler^.called := TRUE;
              pmv$end_handler_to_call := handler^.end_handler;
              pmp$find_stack_segment (program_ring, stack_segment);
              RESET stack_segment;
              converter.pointer_to_procedure := ^pmp$call_end_handler;
              cleanup_cbp := converter.code_base_pointer;
              pmp$outward_call (cleanup_cbp, program_ring, NIL, NIL, stack_segment);
            IFEND;
            handler := handler^.link;
          WHILEND;
          IF (lov$apd_flags.apd_load AND (program_ring = tcb_p^.target_ring)) THEN

{ Determine if an end handler was called for the instrumented APD task.  If so, add the
{ final interblock reference.

            handler := pmv$end_handler_list^ [program_ring];
            WHILE ((handler <> NIL) AND (NOT handler^.called)) DO
              handler := handler^.link;
            WHILEND;
            IF handler <> NIL THEN
              lop$get_loader_seq_descriptor (loader_seq_descriptor_p);
              pmp$add_final_interblock_ref (loader_seq_descriptor_p);
            IFEND;
          IFEND;
        IFEND;

        program_ring := program_ring - 1;

        IF ((program_ring + 1) IN loaded_rings) THEN
          converter.pointer_to_procedure := ^pmp$loaded_ring_cleanup;
          cleanup_cbp := converter.code_base_pointer;

          pmp$find_stack_segment (program_ring + 1, stack_segment);
          RESET stack_segment;

          pmp$outward_call (cleanup_cbp, program_ring + 1, NIL, NIL, stack_segment);
        IFEND;
      WHILEND;
    IFEND;

    program_ring := #RING (^executing_ring);
    lop$terminate_loader;

    WHILE program_ring > osc$os_ring_1 DO
      IF pmv$end_handler_list <> NIL THEN
        handler := pmv$end_handler_list^ [program_ring];
        WHILE handler <> NIL DO
          IF NOT ((handler^.disestablished) OR (handler^.called)) THEN
            handler^.called := TRUE;
            pmv$end_handler_to_call := handler^.end_handler;
            pmp$call_end_handler;
          IFEND;
          handler := handler^.link;
        WHILEND;
        IF (lov$apd_flags.apd_load AND (program_ring = tcb_p^.target_ring)) THEN

{ Determine if an end handler was called for the instrumented APD task.  If so, add the
{ final interblock reference.

          handler := pmv$end_handler_list^ [program_ring];
          WHILE ((handler <> NIL) AND (NOT handler^.called)) DO
            handler := handler^.link;
          WHILEND;
          IF handler <> NIL THEN
            lop$get_loader_seq_descriptor (loader_seq_descriptor_p);
            pmp$add_final_interblock_ref (loader_seq_descriptor_p);
          IFEND;
        IFEND;
      IFEND;
      program_ring := program_ring - 1;
    WHILEND;

{ Close the files used for an instrumented APD task.

    IF lov$apd_flags.apd_load THEN
      lop$close_apd_processing_files;
    IFEND;

{ If the job is terminating, then delete all entries from the command list
{ since no user or site code can get control beyond this point.

    IF osp$executing_in_job_monitor () THEN
      clp$delete_all_from_cmnd_list ({ignore} local_status);
      clp$establish_sys_command_lib (NIL, local_status);
    IFEND;

    osp$test_aam_activity_r1;
    pfp$task_termination_cleanup;
    bap$loaded_ring_cleanup;

    IF pmp$task_debug_mode_on () THEN
      pmp$push_task_debug_mode (pmc$debug_mode_off, local_status);
    IFEND;

    IF system_core_debugger_inactive THEN
      converter.register := #READ_REGISTER (osc$pr_user_mask_reg);
      converter.user_mask := converter.user_mask - $pmt$user_mask [debug_bit];
      #WRITE_REGISTER (osc$pr_user_mask_reg, converter.register);
    IFEND;

    pmp$disestablish_cond_handler (conditions, local_status);

    terminate_task; { does not return }


  PROCEND pmp$cleanup_loaded_rings;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$execute_job_epilogs', EJECT ??
*copy pmh$execute_job_epilogs

  PROCEDURE [XDCL, #GATE] pmp$execute_job_epilogs;

{ TYPE
{   status = status
{ TYPEND

?? PUSH (LISTEXT := ON) ??

    VAR
      type_specification: [STATIC, READ, cls$declaration_section] record
        header: clt$type_specification_header,
      recend := [[1, 0, clc$status_type]];

?? POP ??

    VAR
      job_block: [STATIC, oss$task_private] ^clt$block := NIL,
      child_tasks_flagged: boolean,
      cleanup_cbp: ^ost$external_code_base_pointer,
      conditions: pmt$condition,
      converter: record
        case 1 .. 2 of
        = 1 =
          pointer_to_procedure: ^procedure,
        = 2 =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend,
      established_handler: pmt$established_handler,
      executing_ring: ost$ring,
      file_attributes: array [1 .. 1] of amt$get_item,
      ignore_status: ost$status,
      interrupt_capability: boolean,
      job_maximum_limit: sft$counter,
      job_mode: jmt$job_mode,
      job_termination_status: ost$status,
      job_termination_status_value: clt$data_value,
      job_warning_limit: sft$counter,
      loaded_rings: pmt$loadable_rings,
      local_status: ost$status,
      next_termination_phase: [STATIC, READ, oss$job_paged_literal] array
            [clc$job_begin_phase .. clc$job_end_phase] of clt$processing_phase :=
            [clc$job_end_phase, clc$system_epilog_phase, clc$system_epilog_phase, clc$class_epilog_phase,
            clc$account_epilog_phase, clc$project_epilog_phase,

{  The next termination phase for the user prolog is the user epilog; thus if
{  LOGOUT occurs in the user prolog, the user epilog is executed.  This is not
{  true for the other prologs, if LOGOUT occurs during one of them, the
{  corresponding epilog is skipped.

      clc$user_epilog_phase, clc$user_epilog_phase, clc$member_epilog_phase, clc$project_epilog_phase,
            clc$account_epilog_phase, clc$class_epilog_phase, clc$system_epilog_phase, clc$job_end_phase,
            clc$job_end_phase],
      operation_information: ^sft$audit_information,
      operation_status: ^ost$status,
      program_options_and_libraries: ^pmt$prog_options_and_libraries,
      program_ring: [STATIC, oss$task_private] pmt$loadable_ring := UPPERVALUE (pmt$loadable_ring),
      severity: ost$status_severity,
      stack_segment: ^pmt$stack_segment,
      statistic_data: jmt$comm_acct_statistic_data,
      tcb_p: ^pmt$task_control_block,
      unique_name: ost$unique_name;

?? NEWTITLE := 'eje_condition_handler', EJECT ??

    PROCEDURE eje_condition_handler
      (    condition: pmt$condition;
           descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status,
        message: ost$status;

      IF (condition.selector <> ifc$interactive_condition) AND (condition.selector <> pmc$pit_condition) THEN
        osp$set_status_from_condition ('PM', condition, save_area, message, ignore_status);
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], message, ignore_status);
        pmp$disestablish_cond_handler (conditions, ignore_status);
        pmp$exit (ignore_status);
      IFEND;

    PROCEND eje_condition_handler;
?? OLDTITLE ??
?? NEWTITLE := 'clean_up_blocks', EJECT ??

    PROCEDURE clean_up_blocks
      (VAR job_block: ^clt$block;
       VAR status: ost$status);

      VAR
        status_value: clt$data_value;


      clp$find_task_block (job_block, status);
      IF NOT status.normal THEN
        osp$system_error ('Unable to get pointer to SCL Task Block', ^status);
      IFEND;

      clp$pop_terminated_blocks (job_block, status);

      clp$delete_variable ('OSV$STATUS', ignore_status);
      status_value.kind := clc$status;
      status_value.status_value := ^status;
      clp$create_environment_variable ('OSV$STATUS', clc$job_scope, clc$read_write,
            clc$immediate_evaluation, #SEQ (type_specification), ^status_value, ignore_status);

      clp$reset_work_area_positions (ignore_status);

    PROCEND clean_up_blocks;
?? OLDTITLE ??
?? NEWTITLE := 'execute_epilog', EJECT ??

    PROCEDURE execute_epilog;

      VAR
        cycle_selector: pft$cycle_selector,
        epilog_path: ^pft$path,
        evaluated_file_reference: fst$evaluated_file_reference,
        file_reference_parsing_options: clt$file_ref_parsing_options,
        local_file_name: amt$local_file_name,
        password: pft$password,
        share_selections: pft$share_selections,
        tcb_p: ^pmt$task_control_block,
        usage_selections: pft$usage_selections;


      file_reference_parsing_options := $clt$file_ref_parsing_options [clc$file_ref_evaluation_stage];
      clp$evaluate_file_reference (pmv$epilog_file, file_reference_parsing_options, FALSE,
            evaluated_file_reference, local_status);
      IF local_status.normal THEN
        pmp$generate_unique_name (unique_name, ignore_status);
        local_file_name := unique_name.value;
        PUSH epilog_path: [1 .. evaluated_file_reference.number_of_path_elements];
        pfp$convert_fs_to_pft$path (evaluated_file_reference, epilog_path^);
        cycle_selector.cycle_option := pfc$highest_cycle;
        password := ' ';
        usage_selections := $pft$usage_selections [pfc$read, pfc$execute];
        share_selections := $pft$share_selections [pfc$read, pfc$execute];
        pfp$attach (local_file_name, epilog_path^, cycle_selector, password, usage_selections,
              share_selections, pfc$no_wait, local_status);
        IF local_status.normal THEN
          pmv$epilog_file (1, 7) := '$LOCAL.';
          pmv$epilog_file (8, * ) := local_file_name (1, 31);
        ELSEIF (local_status.condition = pfe$cycle_busy) OR
              (local_status.condition = pfe$usage_not_permitted) THEN

{ Let SCL have a try at it.

          local_status.normal := TRUE;
        IFEND;
      IFEND;

      IF local_status.normal THEN

{ Changing the command search mode from exclusive mode must be done from ring 3.

        IF clv$processing_phase > clc$user_epilog_phase THEN
          clp$set_job_command_search_mode (clc$global_command_search, local_status);
          IF NOT local_status.normal THEN
            osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
          IFEND;
        IFEND;

        converter.pointer_to_procedure := ^pmp$execute_epilog;
        cleanup_cbp := converter.code_base_pointer;
        pmp$find_executing_task_tcb (tcb_p);
        pmp$find_stack_segment (tcb_p^.target_ring, stack_segment);
        RESET stack_segment;
        pmp$outward_call (cleanup_cbp, tcb_p^.target_ring, NIL, NIL, stack_segment);
      ELSEIF local_status.condition = pfe$unknown_permanent_file THEN
        IF clv$processing_phase = clc$user_epilog_phase THEN
          osp$set_status_condition (cle$epilog_file_missing, local_status);
          osp$append_status_file (osc$status_parameter_delimiter, pmv$epilog_file, local_status);
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
        IFEND;
        local_status.normal := TRUE;
      IFEND;

    PROCEND execute_epilog;
?? OLDTITLE, EJECT ??

    osp$verify_system_privilege;

    IF clv$processing_phase < clc$user_epilog_phase THEN

{  The following code is executed only once during job monitor task termination.

      pmp$set_task_execution_phase (pmc$task_loaded_ring_cleanup);
      clean_up_blocks (job_block, local_status);
      IF jmv$terminal_io_disabled THEN
        jmp$enable_terminal_io;
      IFEND;

      IF jmv$job_termination_status = NIL THEN
        pmp$get_termination_status (job_termination_status);
        jmp$set_job_termination_status (job_termination_status);
      ELSE
        job_termination_status := jmv$job_termination_status^;
      IFEND;
      IF NOT job_termination_status.normal AND
            (job_termination_status.condition = dme$unable_to_alloc_all_space) THEN
        osp$set_status_abnormal ('JM', jme$unable_to_alloc_all_space, '', job_termination_status);
      IFEND;
      job_termination_status_value.kind := clc$status;
      job_termination_status_value.status_value := ^job_termination_status;
      clp$create_environment_variable ('OSV$JOB_TERMINATION_STATUS', clc$job_scope, clc$read_only,
            clc$immediate_evaluation, #SEQ (type_specification), ^job_termination_status_value,
            ignore_status);
      IF NOT job_termination_status.normal THEN
        osp$get_status_severity (job_termination_status.condition, severity, local_status);
        IF severity >= osc$error_status THEN
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], job_termination_status, ignore_status);
          osp$generate_message (job_termination_status, ignore_status);
        IFEND;
      IFEND;
    IFEND;

    child_tasks_flagged := FALSE;
    conditions.selector := pmc$condition_combination;
    conditions.combination := $pmt$condition_combination [pmc$system_conditions, mmc$segment_access_condition,
          ifc$interactive_condition, pmc$pit_condition];
    pmp$establish_condition_handler (conditions, ^eje_condition_handler, ^established_handler, local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('pmp$establish_condition_handler', ^local_status);
    IFEND;

    pmp$find_executing_task_tcb (tcb_p);
    WHILE tcb_p^.first_child <> NIL DO
      IF NOT child_tasks_flagged THEN
        pmp$flag_all_child_tasks (pmc$sf_terminate_task, local_status);
        IF NOT local_status.normal THEN
          osp$system_error ('pmp$flag_all_child_tasks', ^local_status);
        IFEND;
        child_tasks_flagged := TRUE;
      IFEND;
      pmp$long_term_wait (tmc$infinite_wait, tmc$infinite_wait);
    WHILEND;

    clv$processing_phase := next_termination_phase [clv$processing_phase];

    WHILE clv$processing_phase <> clc$job_end_phase DO
      CASE clv$processing_phase OF

      = clc$user_epilog_phase =

{ Execute user epilog

        avp$get_capability (avc$interrupt_epilogs, avc$user, interrupt_capability, local_status);
        IF NOT local_status.normal THEN
          IF (local_status.condition = ave$unknown_field) OR
                (local_status.condition = ave$field_was_deleted) THEN
            interrupt_capability := TRUE;
          ELSE
            osp$generate_log_message ($pmt$ascii_logset [pmc$system_log], local_status, ignore_status);
          IFEND;
          local_status.normal := TRUE;
        IFEND;

        IF NOT interrupt_capability THEN
          jmp$disable_user_breaks;
        IFEND;

        avp$get_file_value (avc$user_epilog, avc$user, pmv$epilog_file, local_status);
        IF local_status.normal THEN
          IF ((pmv$epilog_file (1, 5) <> '$NULL') AND (pmv$epilog_file (1, 12) <> '$LOCAL.$NULL')) THEN
            execute_epilog;
            IF NOT local_status.normal THEN
              osp$get_status_severity (local_status.condition, severity, ignore_status);
              IF severity >= osc$error_status THEN
                clp$put_job_command_response (' Following error in USER epilog:', ignore_status);
                osp$generate_message (local_status, ignore_status);
                local_status.normal := TRUE;
              IFEND;
            IFEND;
          IFEND;
        ELSE
          local_status.normal := TRUE;
        IFEND;

      = clc$project_epilog_phase =

{ Execute project epilog

        avp$get_file_value (avc$project_epilog, avc$project, pmv$epilog_file, local_status);
        IF local_status.normal THEN
          IF ((pmv$epilog_file (1, 5) <> '$NULL') AND (pmv$epilog_file (1, 12) <> '$LOCAL.$NULL')) THEN
            execute_epilog;
            IF NOT local_status.normal THEN
              osp$get_status_severity (local_status.condition, severity, ignore_status);
              IF severity >= osc$error_status THEN
                clp$put_job_command_response (' Following error in PROJECT epilog:', ignore_status);
                osp$generate_message (local_status, ignore_status);
                local_status.normal := TRUE;
              IFEND;
            IFEND;
          IFEND;
        ELSE
          local_status.normal := TRUE;
        IFEND;

      = clc$account_epilog_phase =

{ Execute account epilog

        avp$get_file_value (avc$account_epilog, avc$account, pmv$epilog_file, local_status);
        IF local_status.normal THEN
          IF ((pmv$epilog_file (1, 5) <> '$NULL') AND (pmv$epilog_file (1, 12) <> '$LOCAL.$NULL')) THEN
            execute_epilog;
            IF NOT local_status.normal THEN
              osp$get_status_severity (local_status.condition, severity, ignore_status);
              IF severity >= osc$error_status THEN
                clp$put_job_command_response (' Following error in ACCOUNT epilog:', ignore_status);
                osp$generate_message (local_status, ignore_status);
                local_status.normal := TRUE;
              IFEND;
            IFEND;
          IFEND;
        ELSE
          local_status.normal := TRUE;
        IFEND;

{ Execute job_class epilog

      = clc$class_epilog_phase =

        IF interrupt_capability THEN
          jmp$disable_user_breaks;
        IFEND;
        pmp$get_loaded_rings (loaded_rings);

        WHILE program_ring > #RING (^executing_ring) DO
          program_ring := program_ring - 1;
          IF ((program_ring + 1) IN loaded_rings) THEN
            converter.pointer_to_procedure := ^pmp$monitor_loaded_ring_cleanup;
            cleanup_cbp := converter.code_base_pointer;
            pmp$find_stack_segment (program_ring + 1, stack_segment);
            RESET stack_segment;
            pmp$outward_call (cleanup_cbp, program_ring + 1, NIL, NIL, stack_segment);
          IFEND;
        WHILEND;

{ Move the file space limits up to unlimited so the site epilogs always run.

        job_warning_limit := sfc$unlimited;
        job_maximum_limit := sfc$unlimited;
        sfp$change_file_space_limit (sfc$perm_file_space_limit, ^job_warning_limit, ^job_maximum_limit,
              {accumulator = } NIL, {job_warning_checking = } NIL);
        sfp$change_file_space_limit (sfc$temp_file_space_limit, ^job_warning_limit, ^job_maximum_limit,
              {accumulator = } NIL, {job_warning_checking = } NIL);

        bap$monitor_loaded_ring_cleanup;
        bap$monitor_task_term_cleanup;
        lop$delete_loader_library_list;
        lop$delete_linkage_tree;
        pmp$find_prog_options_and_libs (program_options_and_libraries);
        pmp$init_default_prog_options (program_options_and_libraries^.default_options, local_status);
        program_options_and_libraries^.job_library_list := NIL;
        program_options_and_libraries^.debug_library_list := NIL;
        program_options_and_libraries^.default_options^.debug_input :=
              clv$standard_files [clc$sf_command_file].path_handle_name;
        program_options_and_libraries^.default_options^.debug_output :=
              clv$standard_files [clc$sf_standard_output_file].path_handle_name;
        program_options_and_libraries^.default_options^.abort_file :=
              clv$standard_files [clc$sf_null_file].path_handle_name;
        fmp$detach_all_tape_files;
        clp$delete_variables (job_block^.variables);
        jmp$get_job_class_epilog (pmv$epilog_file, local_status);
        IF local_status.normal AND (pmv$epilog_file <> '') THEN
          execute_epilog;
          IF NOT local_status.normal THEN
            osp$get_status_severity (local_status.condition, severity, ignore_status);
            IF severity >= osc$error_status THEN
              clp$put_job_command_response (' Following error in JOB_CLASS epilog:', ignore_status);
              osp$generate_message (local_status, ignore_status);
              local_status.normal := TRUE;
            IFEND;
          IFEND;
        ELSE
          local_status.normal := TRUE;
        IFEND;

{ Execute system epilog

      = clc$system_epilog_phase =
        pmv$epilog_file := avc$system_epilog;

        ?IF NOT clc$compiling_for_test_harness THEN
          pmp$get_job_mode (job_mode, ignore_status);

          IF job_mode = jmc$batch THEN
            statistic_data.statistic_id := jmc$ca_standard_output_file;
            jmp$emit_communication_stat (statistic_data);
          ELSEIF job_mode = jmc$interactive_connected THEN
            statistic_data.statistic_id := jmc$ca_interactive_interval;
            jmp$emit_communication_stat (statistic_data);
          IFEND;

          IF avp$security_option_active (avc$vso_security_audit) THEN
            PUSH operation_information;
            operation_information^.audited_operation := sfc$ao_job_end;

{ This statistic has no counters or descriptive data.

            PUSH operation_status;
            operation_status^.normal := TRUE;
            sfp$emit_audit_statistic (operation_information^, operation_status^);
          IFEND;
          avp$end_account (local_status);
          IF NOT local_status.normal THEN
            osp$generate_log_message ($pmt$ascii_logset [pmc$system_log], local_status, ignore_status);
            local_status.normal := TRUE;
          IFEND;

          execute_epilog;
          IF NOT local_status.normal THEN
            osp$get_status_severity (local_status.condition, severity, ignore_status);
            IF severity >= osc$error_status THEN
              clp$put_job_command_response (' Following error in SYSTEM epilog:', ignore_status);
              osp$generate_message (local_status, ignore_status);
              local_status.normal := TRUE;
            IFEND;
          IFEND;
        ?IFEND;

      = clc$job_end_phase =
        RETURN;
      ELSE
        ;
      CASEND;

      clv$processing_phase := next_termination_phase [clv$processing_phase];

    WHILEND;

  PROCEND pmp$execute_job_epilogs;
?? TITLE := '  terminate_task' ??
?? EJECT ??

  PROCEDURE terminate_task;

{  PURPOSE:
{    This procedure initiates the dismantling of a task's environment.  Activation of this procedure
{    guarantees that the task will terminate (if possible).  No further user program codes will
{    be executed.
{  NOTE:
{    This procedure is implemented as several phases.  Although the normal case is for this
{    procedure to be called only once per task, it is designed to handle multiple calls.
{    (Multiple calls could occur due to conditions arising outside the scope of the procedure's
{    condition handler.)  State memory is used to insure a normal progression of phases in
{    the event of multiple calls.


    TYPE
      pmt$task_termination_phase = (null_phase, initial_phase, access_method_cleanup, permanent_files_cleanup,
            namve_cleanup, queue_file_management_cleanup, interactive_cleanup, incoming_message_cleanup,
            operator_facility_cleanup, memory_link_cleanup, local_queues_cleanup, preemptive_comm_cleanup,
            configuration_cleanup, emit_statistics, job_termination, release_segments, relinquish_cpu);

    VAR
      recovery_inhibited: [STATIC] boolean := FALSE,
      task_termination_phase: [STATIC] pmt$task_termination_phase := LOWERVALUE (pmt$task_termination_phase);

?? NEWTITLE := '    confine_environment' ??
?? NEWTITLE := '    asynchronous_condition_handler' ??
?? NEWTITLE := '    fatal_condition_handler' ??
?? EJECT ??

    PROCEDURE confine_environment;

{   PURPOSE:
{     The purpose of this procedure is to confine the task environment to terminate_task  by trucating
{     the stack.

      VAR
        terminate_task_sfsa: ^ost$stack_frame_save_area;

      terminate_task_sfsa := #PREVIOUS_SAVE_AREA ();
      terminate_task_sfsa^.minimum_save_area.a2_previous_save_area := NIL;
    PROCEND confine_environment;



?? OLDTITLE ??

    PROCEDURE asynchronous_condition_handler
      (    condition: pmt$condition;
           descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      IF (condition.selector <> pmc$pit_condition) THEN
        IF (task_termination_phase = PRED (initial_phase)) THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, status);
          IF NOT status.normal THEN
            pmp$exit (status);
          IFEND;
        ELSE
          status.normal := TRUE;

{   Interactive and job resource conditions are ignored after all child tasks
{   have terminated.

        IFEND;
      ELSE

{   Pit conditions are always ignored during task termination.

        status.normal := TRUE;
      IFEND;
    PROCEND asynchronous_condition_handler;




    PROCEDURE fatal_condition_handler
      (    condition: pmt$condition;
           descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status;

      osp$set_status_from_condition ('PM', condition, save_area, status, ignore_status);
      osp$system_error ('task cannot terminate', ^status);
    PROCEND fatal_condition_handler;
?? OLDTITLE, OLDTITLE, EJECT ??

    VAR
      tcb_p: ^pmt$task_control_block,
      parent_id: ost$global_task_id,
      job_mode: jmt$job_mode,
      asynchronous_conditions: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
            [pmc$condition_combination, $pmt$condition_combination
            [jmc$job_resource_condition, ifc$interactive_condition, pmc$pit_condition]],
      fatal_conditions: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
            [pmc$condition_combination, $pmt$condition_combination
            [pmc$system_conditions, mmc$segment_access_condition]],
      established_handler: ^pmt$established_handler,
      child_tasks_flagged: boolean,
      local_status: ost$status;

    confine_environment;
    PUSH established_handler;
    pmp$establish_condition_handler (asynchronous_conditions, ^asynchronous_condition_handler,
          established_handler, local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('pmp$establish - task end', ^local_status);
    IFEND;
    PUSH established_handler;
    pmp$establish_condition_handler (fatal_conditions, ^fatal_condition_handler, established_handler,
          local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('pmp$establish - task end', ^local_status);
    IFEND;
    child_tasks_flagged := FALSE;
    pmp$set_task_execution_phase (pmc$task_termination_cleanup);
    WHILE TRUE DO
      task_termination_phase := SUCC (task_termination_phase);
      CASE task_termination_phase OF
      = initial_phase =
        task_termination_phase := PRED (initial_phase); {inhibit phase advancement}
        pmp$set_task_state (pmc$task_terminating);
        pmp$find_executing_task_tcb (tcb_p);
        WHILE tcb_p^.first_child <> NIL DO

{  Loop until all child tasks have terminated.  The repetitive check of status
{  occurs for the following reason.  If a task has terminated with normal
{  status, and after reaching this point in termination gets flagged by its
{  parent to terminate, the termination status will be changed to abnormal
{  rather than exit being called within the task.  This means that the task
{  will at that time, flag its child tasks to tell them to terminate.  Note:
{  This process will only flag the children once.

          IF (NOT tcb_p^.nosve.termination_status^.normal) AND (NOT child_tasks_flagged) THEN
            pmp$flag_all_child_tasks (pmc$sf_terminate_task, local_status);
            IF NOT local_status.normal THEN
              osp$system_error ('pmp$flag_all_child_tasks', ^local_status);
            IFEND;
            child_tasks_flagged := TRUE;
          IFEND;
          pmp$long_term_wait (tmc$infinite_wait, tmc$infinite_wait);
        WHILEND;

{  Inhibit job recovery while the task terminates.  If recovery were to take
{  place while attempting to "cleanup" the results could get messy.  For
{  example, consider the case of BAM cleanup being called and then recovery
{  processing attempting to undo part of the cleanup.

        IF NOT recovery_inhibited THEN
          syp$push_inhibit_job_recovery;
          recovery_inhibited := TRUE;
        IFEND;
        pmp$disestablish_cond_handler (fatal_conditions, local_status);
        IF NOT local_status.normal THEN
          osp$system_error ('pmp$establish - task end', ^local_status);
        IFEND;
        task_termination_phase := initial_phase; {enable phase advancement}
?? EJECT ??

{   Call procedures to do necessary task_termination cleanup for other
{   functional areas.

      = access_method_cleanup =
        osp$test_aam_activity_r1;
        bap$task_termination_cleanup;
      = permanent_files_cleanup =
        pfp$detach_reserved_cycles (local_status); {ignore status}
      = namve_cleanup =
        nap$process_task_termination;
      = queue_file_management_cleanup =
        jmp$release_input_files;
        jmp$release_output_files;
        jmp$release_generic_queue_files;
      = interactive_cleanup =
        iip$clear_job_locks (local_status);
        IF jmv$job_attributes.originating_application_name = osc$dual_state_interactive THEN

{   For dual_state interactive origin jobs, job end processing MUST be done
{   before the memory link goes away - that is why this operation is done here
{   instead of job_end.

          pmp$get_job_mode (job_mode, local_status);
          IF NOT local_status.normal THEN
            osp$system_error ('pmp$get_job_mode', ^local_status);
          IFEND;
          IF osp$executing_in_job_monitor () AND (job_mode = jmc$interactive_connected) THEN
            ifp$stop_interactive;
          IFEND;
        ELSEIF jmp$is_xterm_job () THEN
          pmp$get_job_mode (job_mode, local_status);
          IF NOT local_status.normal THEN
            osp$system_error ('pmp$get_job_mode', ^local_status);
          IFEND;
          IF osp$executing_in_job_monitor () AND (job_mode = jmc$interactive_connected) THEN
            iip$xt_stop_xterm (local_status);
          IFEND;
        IFEND;
      = incoming_message_cleanup =
        nap$incoming_message_cleanup;
      = operator_facility_cleanup =
        ofp$task_end;
      = memory_link_cleanup =

{!  This phase exits only to cover task_services programming errors.

        mlp$task_termination_cleanup;
      = local_queues_cleanup =
        pmp$disconnect_task_from_queues;
      = preemptive_comm_cleanup =
        IF NOT osp$executing_in_job_monitor () THEN
          task_termination_phase := PRED (preemptive_comm_cleanup); { inhibit phase advancement }
          tmp$disable_preemptive_commo;
          task_termination_phase := preemptive_comm_cleanup; { enable phase advancement }
        IFEND;

      = configuration_cleanup =
        cmp$task_termination_cleanup;

      = emit_statistics =
        IF clv$applications_active > 0 THEN
          clp$record_application_units;
        IFEND;
        sfp$clear_job_routing_ctl_lock;

      = job_termination =
        IF osp$executing_in_job_monitor () THEN
          task_termination_phase := PRED (job_termination); { inhibit phase advancement }
          PUSH established_handler;
          pmp$establish_condition_handler (fatal_conditions, ^fatal_condition_handler, established_handler,
                local_status);
          IF NOT local_status.normal THEN
            osp$system_error ('pmp$establish - task end', ^local_status);
          IFEND;
          IF recovery_inhibited THEN
            syp$pop_inhibit_job_recovery;
            recovery_inhibited := FALSE;
          IFEND;
          jmp$job_end; { should not return }
        IFEND;
?? EJECT ??

      = release_segments =
        task_termination_phase := PRED (release_segments); { inhibit phase advancement }
        PUSH established_handler;
        pmp$establish_condition_handler (fatal_conditions, ^fatal_condition_handler, established_handler,
              local_status);
        IF NOT local_status.normal THEN
          osp$system_error ('pmp$establish - task end', ^local_status);
        IFEND;
        pmp$delete_non_inherited_segs (local_status);
        IF NOT local_status.normal THEN
          osp$system_error ('pmp$delete_non_inherited_segs', ^local_status);
        IFEND;
        task_termination_phase := release_segments; { enable phase advancement }

      = relinquish_cpu =
        task_termination_phase := PRED (relinquish_cpu); { inhibit phase advancment }
        PUSH established_handler;
        pmp$establish_condition_handler (fatal_conditions, ^fatal_condition_handler, established_handler,
              local_status);
        IF NOT local_status.normal THEN
          osp$system_error ('pmp$establish - task end', ^local_status);
        IFEND;
        pmp$find_executing_task_tcb (tcb_p);
        pmp$get_global_task_id (tcb_p^.parent^.task_id, parent_id, local_status);
        IF recovery_inhibited THEN
          syp$pop_inhibit_job_recovery;
          recovery_inhibited := FALSE;
        IFEND;
        pmp$task_end (tcb_p^.task_id, parent_id); { does not return }
      CASEND;
    WHILEND;
  PROCEND terminate_task;
?? TITLE := '  [XDCL] pmp$child_termination_handler', EJECT ??

  PROCEDURE [XDCL] pmp$child_termination_handler
    (    originator: ost$global_task_id;
         signal: pmt$signal);

{  PURPOSE:
{    This procedure is the handler for the signal pmc$ss_child_terminated.  This signal has a
{    recognition ring of 4 and is sent to a terminating task's parent task when the terminating task
{    relinquishes the CPU.  This procedure discards the last elements of the terminating child
{    task's environment.

    VAR
      converter: record
        case 0 .. 1 of
        = 0 =
          signal_contents: pmt$signal_contents,
        = 1 =
          task_id: pmt$task_id,
        casend,
      recend,

      task_id: pmt$task_id,
      current_child: boolean,
      ignore_status: ost$status,
      task_control_block: ^pmt$task_control_block,
      record_status: ost$status,
      local_status: ost$status;

?? EJECT ??

    PROCEDURE record_task_status
      (VAR tcb: pmt$task_control_block;
       VAR record_status: ost$status);

      VAR
        invalid_segment_condition: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
              [pmc$system_conditions, $pmt$system_conditions [pmc$invalid_segment_ring_0,
              pmc$access_violation], * ],
        seg_established_handler: pmt$established_handler,
        ignore_status: ost$status;


      PROCEDURE segment_condition_handler
        (    condition: pmt$condition;
             descriptor: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR status: ost$status);

        osp$set_status_abnormal ('PM', pme$task_status_inaccessible, '', record_status);
        EXIT record_task_status;
      PROCEND segment_condition_handler;


      record_status.normal := TRUE;
      pmp$establish_condition_handler (invalid_segment_condition, ^segment_condition_handler,
            ^seg_established_handler, local_status);
      IF NOT local_status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
        osp$generate_message (local_status, ignore_status);
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], tcb.nosve.termination_status^,
              ignore_status);
        osp$generate_message (tcb.nosve.termination_status^, ignore_status);
      ELSE
        IF mmp$verify_access (#LOC (tcb.nosve.parent_task_status_variable), mmc$va_write) THEN
          tcb.nosve.parent_task_status_variable^.status := tcb.nosve.termination_status^;
          tcb.nosve.parent_task_status_variable^.complete := TRUE;
        ELSE
          osp$set_status_abnormal ('PM', pme$task_status_inaccessible, '', record_status);
        IFEND;
      IFEND;
    PROCEND record_task_status;

?? EJECT ??

    converter.signal_contents := signal.contents;
    task_id := converter.task_id;

    pmp$verify_current_child (task_id, current_child);
    IF NOT current_child THEN
      osp$system_error ('unknown child terminated', NIL);
    ELSE
      clp$erase_child_task (task_id, local_status);
      IF NOT local_status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log, pmc$system_log], local_status,
              ignore_status);
      IFEND;
      issue_task_end_statistics (task_id);
      pmp$find_task_tcb (task_id, task_control_block);
      record_task_status (task_control_block^, record_status);
      pmp$release_task_environment (task_id);

      IF NOT record_status.normal THEN
        pmp$exit (record_status);
      IFEND;
    IFEND;
  PROCEND pmp$child_termination_handler;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$condition_task_termination', EJECT ??
*copy pmh$condition_task_termination

  PROCEDURE [XDCL, #GATE] pmp$condition_task_termination;

    VAR
      job_mode: jmt$job_mode,
      detached_job_wait_time_change: jmt$job_attribute_change,
      timesharing_signal: jmt$timesharing_signal,
      ignore_status: ost$status;

    osp$verify_system_privilege;
    pfp$clear_system_authority;
    fmp$unlock_path_table_at_tskend;
    pmp$get_job_mode (job_mode, ignore_status);

    IF osp$executing_in_job_monitor () THEN

{ Record the job as terminated

      jmp$set_job_term_disposition;

{ If the job is interactive ...

      IF job_mode <> jmc$batch THEN

{ Enable interactive conditions

        jmp$set_interactive_cond_state ({interactive_conditions_enabled} TRUE);

{ enable IO in all tasks and set the detached job wait time to zero.

        pmp$enable_ts_io_in_job;

        detached_job_wait_time_change.key := jmc$detached_job_wait_time;
        detached_job_wait_time_change.detached_job_wait_time := 0;
        qfp$set_job_attributes (detached_job_wait_time_change, ignore_status);

{ Wake up (ready) all tasks in the job.

        timesharing_signal.signal_id := jmc$timesharing_signal_id;
        timesharing_signal.signal_contents.signal_kind := jmc$timesharing_restart_tasks;
        timesharing_signal.signal_contents.restart_tasks := jmc$ts_restart_child_tasks;
        pmp$signal_all_child_tasks (timesharing_signal.signal, ignore_status);
      IFEND;
    IFEND;
  PROCEND pmp$condition_task_termination;


?? TITLE := 'TEMPORARY procedures for compatibility with HCS tasking', EJECT ??
?? NEWTITLE := 'issue_task_end_statistics', EJECT ??

  PROCEDURE issue_task_end_statistics
    (    task_id: pmt$task_id);

    VAR
      cp_time: pmt$task_cp_time,
      int: integer,
      ignore_status: ost$status,
      local_status: ost$status,
      raw_task_statistics: pmt$raw_task_statistics,
      task_statistics: array [1 .. 9] of sft$counter,
      task_exception_stats: array [1 .. 2] of sft$counter,
      task_exception_descp: string (100),
      task_exception_user_job_name: jmt$user_supplied_name,
      task_exception_sys_job_name: jmt$system_supplied_name,
      tcb_p: ^pmt$task_control_block,
      xcb_p: ^ost$execution_control_block;

    VAR
      gtid_converter: record
        case boolean of
        = FALSE =
          global_task_id: ost$global_task_id,
        = TRUE =
          integer_value: 0 .. 0ffffff(16),
        casend,
      recend;

    local_status.normal := TRUE;
    pmp$find_task_xcb (task_id, xcb_p);
    IF xcb_p = NIL THEN
      osp$system_error ('task XCB lost', NIL);
    ELSE
      tcb_p := xcb_p^.task_control_block;
      IF pmv$debug_logging_enabled THEN
        gtid_converter.global_task_id := xcb_p^.global_task_id;
        osp$set_status_abnormal ('PM', pme$task_end_information, { task_name } xcb_p^.save9, local_status);
        osp$append_status_integer (osc$status_parameter_delimiter, gtid_converter.integer_value, 16, TRUE,
              local_status);
        IF tcb_p^.nosve.termination_status^.normal THEN
          osp$append_status_integer (osc$status_parameter_delimiter, 0, 16, FALSE, local_status);
        ELSE
          osp$append_status_integer (osc$status_parameter_delimiter,
                tcb_p^.nosve.termination_status^.condition, 16, TRUE, local_status);
        IFEND;
        osp$generate_log_message ($pmt$ascii_logset [pmc$system_log], local_status, ignore_status);
      IFEND;
      raw_task_statistics.cp_time.task_time := xcb_p^.cp_time.time_spent_in_job_mode;
      raw_task_statistics.cp_time.monitor_time := xcb_p^.cp_time.time_spent_in_mtr_mode;
      raw_task_statistics.task_name := xcb_p^.save9 {task_name} ;
      raw_task_statistics.page_fault_count := xcb_p^.paging_statistics.page_fault_count;
      raw_task_statistics.working_set_max_used := xcb_p^.paging_statistics.working_set_max_used;
      raw_task_statistics.maxws_aio_slowdown := xcb_p^.maxws_aio_slowdown;
      issue_formatted_statistics (raw_task_statistics, ' Task complete  ', ignore_status);

      IF NOT jmv$executing_within_system_job THEN
        sfp$internal_emit_statistic (pml$task_name, xcb_p^.save9, NIL, xcb_p^.global_task_id, ignore_status);

        task_statistics [1] := raw_task_statistics.cp_time.task_time;
        task_statistics [2] := raw_task_statistics.cp_time.monitor_time;
        task_statistics [3] := xcb_p^.paging_statistics.page_fault_count;
        task_statistics [4] := xcb_p^.paging_statistics.page_in_count;
        task_statistics [5] := xcb_p^.paging_statistics.pages_reclaimed_from_queue;
        task_statistics [6] := xcb_p^.paging_statistics.new_pages_assigned;
        task_statistics [7] := xcb_p^.paging_statistics.working_set_max_used;
        task_statistics [8] := xcb_p^.maxws_aio_slowdown;
        task_statistics [9] := xcb_p^.paging_statistics.pages_from_server;

        sfp$internal_emit_statistic (pml$task_end, xcb_p^.save9, ^task_statistics, xcb_p^.global_task_id,
              ignore_status);

        IF xcb_p^.maxws_aio_slowdown > 0 THEN
          task_exception_user_job_name := ' ';
          task_exception_sys_job_name := ' ';
          pmp$get_job_names (task_exception_user_job_name, task_exception_sys_job_name, ignore_status);
          task_exception_stats [1] := xcb_p^.paging_statistics.working_set_max_used;
          task_exception_stats [2] := xcb_p^.maxws_aio_slowdown;
          task_exception_descp := ' ';
          STRINGREP (task_exception_descp, int, 'SN= ', task_exception_sys_job_name, ' JN= ',
                task_exception_user_job_name, ' TN= ', xcb_p^.save9);
          sfp$internal_emit_statistic (pml$task_end_exception, task_exception_descp, ^task_exception_stats,
                xcb_p^.global_task_id, ignore_status);
        IFEND;

      IFEND;
      IF clv$applications_active > 0 THEN
        clp$update_applic_resources (raw_task_statistics.cp_time, xcb_p^.paging_statistics);
      IFEND;
    IFEND;
  PROCEND issue_task_end_statistics;
?? TITLE := '    issue_formatted_statistics', EJECT ??

  PROCEDURE issue_formatted_statistics
    (    raw_task_statistics: pmt$raw_task_statistics;
         prefix: string (16);
     VAR status: ost$status);

    VAR
      message: string (105),
      strng: ost$string,
      i: integer;

    message (1, 16) := prefix;
    message (17, 31) := raw_task_statistics.task_name;
    pmp$log (message (1, 47), status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    message := '     job time =      0.000  monitor time =      0.000  page faults = **********';
    message (80, 26) := '  max working set = ******';
    i := (raw_task_statistics.cp_time.task_time + 500) DIV 1000;
    clp$convert_integer_to_rjstring (i DIV 1000, 10, FALSE, ' ', message (16, 7), status);
    clp$convert_integer_to_rjstring (i MOD 1000, 10, FALSE, '0', message (24, 3), status);
    i := (raw_task_statistics.cp_time.monitor_time + 500) DIV 1000;
    clp$convert_integer_to_rjstring (i DIV 1000, 10, FALSE, ' ', message (43, 7), status);
    clp$convert_integer_to_rjstring (i MOD 1000, 10, FALSE, '0', message (51, 3), status);
    clp$convert_integer_to_string (raw_task_statistics.page_fault_count, 10, FALSE, strng, status);
    IF status.normal THEN
      message (70, 10) := strng.value (1, strng.size);
    IFEND;
    clp$convert_integer_to_string (raw_task_statistics.working_set_max_used, 10, FALSE, strng, status);
    IF status.normal THEN
      message (100, 6) := strng.value (1, strng.size);
    IFEND;
    pmp$log (message, status);
    IF raw_task_statistics.maxws_aio_slowdown <> 0 THEN
      message := ' ';
      STRINGREP (message, i,
            '     Excess paging at Maximum Working Set limit (a job attribute) caused slowdown ',
            raw_task_statistics.maxws_aio_slowdown, ' times.');
      pmp$log (message, status);
    IFEND

  PROCEND issue_formatted_statistics;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$emit_job_end_statistics', EJECT ??
*copy pmh$emit_job_end_statistics

  PROCEDURE [XDCL] pmp$emit_job_end_statistics
    (VAR status: ost$status);

    VAR
      job_statistics: jmt$job_statistics,
      statistics: array [1 .. 8] of sft$counter,
      task_id: pmt$task_id;

    status.normal := TRUE;

{ Manufacture a LOGOUT command in the system log for the job.

    pmp$log_ascii ('LOGOUT', $pmt$ascii_logset [pmc$system_log], pmc$msg_origin_command, {ignore} status);

    pmp$get_task_id (task_id, { ignore } status);

{   This cycle request will cause dispatcher to update the XCB and IJL with the
{   latest available task and job statistic data.

    pmp$cycle ({ ignore } status);

    tmp$fetch_job_statistics (job_statistics, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    issue_task_end_statistics (task_id);

    statistics [1] := job_statistics.cp_time.time_spent_in_job_mode;
    statistics [2] := job_statistics.cp_time.time_spent_in_mtr_mode;
    statistics [3] := job_statistics.paging_statistics.page_fault_count;
    statistics [4] := job_statistics.paging_statistics.page_in_count;
    statistics [5] := job_statistics.paging_statistics.pages_reclaimed_from_queue;
    statistics [6] := job_statistics.paging_statistics.new_pages_assigned;
    statistics [7] := job_statistics.paging_statistics.working_set_max_used;
    statistics [8] := job_statistics.paging_statistics.pages_from_server;
    sfp$emit_statistic (jml$job_end_statistics, '', ^statistics, status);
  PROCEND pmp$emit_job_end_statistics;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$acquire_raw_task_statistics', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$acquire_raw_task_statistics
    (VAR active_task_count: 0 .. pmc$max_task_id;
     VAR active_task_statistics: array [1 .. * ] of pmt$raw_task_statistics);

    VAR
      task: 0 .. pmc$max_task_id,
      task_count: 0 .. pmc$max_task_id,
      task_statistics: ^array [1 .. * ] of pmt$raw_task_statistics;

    osp$verify_system_privilege;

    PUSH task_statistics: [1 .. UPPERBOUND (active_task_statistics)];
    pmp$collect_raw_task_statistics (task_count, task_statistics^);
    active_task_count := task_count;
    IF (task_count > UPPERBOUND (task_statistics^)) THEN
      task_count := UPPERBOUND (task_statistics^);
    IFEND;
    FOR task := 1 TO task_count DO
      active_task_statistics [task] := task_statistics^ [task];
    FOREND;


  PROCEND pmp$acquire_raw_task_statistics;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE, XDCL, #GATE] pmp$set_task_execution_phase', EJECT ??
*copy pmh$set_task_execution_phase

{ NOTE:
{   The task execution phase can only progress - it NEVER reverts to a previous
{   phase For example - when loaded_ring_cleanup is called - we will stop the
{   cleanup with calls to pmp$exit - this in turn, may call
{   pmp$pop_all_stack_frames - so we may try to set us back into popping when
{   we are actually to the the point of loaded_ring_cleanup.

  PROCEDURE [INLINE, XDCL, #GATE] pmp$set_task_execution_phase
    (    execution_phase: pmt$task_execution_phase);

    osp$verify_system_privilege;
    IF execution_phase > pmv$task_execution_phase THEN
      pmv$task_execution_phase := execution_phase;
    IFEND;
  PROCEND pmp$set_task_execution_phase;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$set_popper_handler_activity', EJECT ??
*copy pmh$set_popper_handler_activity

  PROCEDURE [XDCL, #GATE] pmp$set_popper_handler_activity
    (    active: boolean);

    osp$verify_system_privilege;
    pmv$popper_handler_established := active;
  PROCEND pmp$set_popper_handler_activity;
?? OLDTITLE ??
MODEND pmm$task_termination_ring_3;
*DECK DECK=PMM$USER_TIME_REQUESTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program_management - User time requests', EJECT ??
MODULE pmm$user_time_requests;


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc pme$program_services_exceptions
*copyc pmk$keypoints
?? POP ??
*copyc clp$convert_date_time_to_string
*copyc clp$convert_string_to_date_time
*copyc osp$set_status_condition
*copyc osp$verify_system_privilege
*copyc pmp$compute_day_of_week
*copyc pmp$get_compact_date_time
*copyc pmp$get_default_date_time_form
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$change_legible_date_format', EJECT ??
*copy pmh$change_legible_date_format

  PROCEDURE [XDCL] pmp$change_legible_date_format
    (    new_format: ost$date_formats;
     VAR date: ost$date;
     VAR status: ost$status);

    VAR
      date_string: ost$string,
      date_time: clt$date_time,
      def_date_format: ost$default_date_format,
      def_time_format: ost$default_time_format,
      format: ost$date_formats;

    status.normal := TRUE;
    osp$verify_system_privilege;

    validate_date_format (new_format, format, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE date.date_format OF
    = osc$month_date =
      clp$convert_string_to_date_time (date.month, 'MN D2, Y4', date_time, status);

    = osc$mdy_date =
      clp$convert_string_to_date_time (date.mdy, 'M2/D2/Y2', date_time, status);

    = osc$iso_date =
      clp$convert_string_to_date_time (date.iso, 'Y4-M2-D2', date_time, status);

    = osc$ordinal_date =
      clp$convert_string_to_date_time (date.ordinal, 'Y4J3', date_time, status);

    = osc$dmy_date =
      clp$convert_string_to_date_time (date.dmy, 'D2.M2.Y2', date_time, status);

    ELSE
      osp$set_status_condition (pme$invalid_date_format, status);
    CASEND;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF new_format = osc$default_date THEN
      pmp$get_default_date_time_form (def_date_format, def_time_format);
      format := def_date_format.date_format;
    IFEND;

    date.date_format := format;

    CASE format OF
    = osc$month_date =
      clp$convert_date_time_to_string (date_time, 'MN D2, Y4', date_string, status);
      date.month := date_string.value;

    = osc$mdy_date =
      clp$convert_date_time_to_string (date_time, 'M2/D2/Y2', date_string, status);
      date.mdy := date_string.value;

    = osc$iso_date =
      clp$convert_date_time_to_string (date_time, 'Y4-M2-D2', date_string, status);
      date.iso := date_string.value;

    = osc$ordinal_date =
      clp$convert_date_time_to_string (date_time, 'Y4J3', date_string, status);
      date.ordinal := date_string.value;

    = osc$dmy_date =
      clp$convert_date_time_to_string (date_time, 'D2.M2.Y2', date_string, status);
      date.dmy := date_string.value;

    CASEND;


  PROCEND pmp$change_legible_date_format;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_day_of_week', EJECT ??
*copy pmh$get_day_of_week

  PROCEDURE [XDCL, #GATE] pmp$get_day_of_week
    (VAR day_of_week: ost$day_of_week;
     VAR status: ost$status);

     VAR
       date_time: ost$date_time;

    #KEYPOINT (osk$entry, 0, pmk$get_day_of_week);

    pmp$get_compact_date_time (date_time, status);
    IF NOT status.normal THEN
     #KEYPOINT (osk$exit, 0, pmk$get_day_of_week);
     RETURN;
    IFEND;

    pmp$compute_day_of_week (date_time, day_of_week, status);

    #KEYPOINT (osk$exit, 0, pmk$get_day_of_week);

  PROCEND pmp$get_day_of_week;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] validate_date_format', EJECT ??

{ PURPOSE:
{   Verify that the date format is valid.

  PROCEDURE [INLINE] validate_date_format
    (    date_format: ost$date_formats;
     VAR validated_date_format: ost$date_formats;
     VAR status: ost$status);

    VAR
      def_date_format: ost$default_date_format,
      ignore_def_time_format: ost$default_time_format;

    status.normal := TRUE;

    CASE date_format OF
    = osc$ordinal_date, osc$month_date, osc$mdy_date, osc$dmy_date, osc$iso_date =
      validated_date_format := date_format;

    = osc$default_date =
      pmp$get_default_date_time_form (def_date_format, ignore_def_time_format);
      validated_date_format := def_date_format.date_format;

    ELSE
      osp$set_status_condition (pme$invalid_date_format, status);
    CASEND;

  PROCEND validate_date_format;
MODEND pmm$user_time_requests;
*DECK DECK=PMM$WAIT_SERVICES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE: Wait Services' ??
?? NEWTITLE := '  Global System Declarations' ??
MODULE pmm$wait_services;


{   PURPOSE:
{     The purpose of this module is to package contained procedures
{     so that they execute with the privileges necessary to issue the
{     wait monitor request and be callable only upto ring 6.

{   DESIGN:
{     The procedures contained in this module have an execution bracket
{     of 1, 6.  The procedures are callable only from within their
{     execution bracket.

?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$HARDWARE_SUBRANGES
*copyc OST$GLOBAL_TASK_ID
*copyc OST$CALLER_IDENTIFIER
*copyc PME$INSUFFICIENT_PRIVILEGE
*copyc SYC$MONITOR_REQUEST_CODES
*copyc TMV$NULL_GLOBAL_TASK_ID
*copyc pme$unknown_recipient_task
*copyc pmk$keypoints
?? POP ??
?? TITLE := '  Global External Procedures' ??
?? EJECT ??

*copyc I#CALL_MONITOR
*copyc TMT$RB_WAIT

?? TITLE := '  Internal Declarations' ??
?? EJECT ??
*copyc TMT$PREEMPTED_REASON
*copyc TMC$EXECUTION_RING_CONSTANTS

?? TITLE := '  External Procedures' ??
?? EJECT ??
*copyc OSP$SET_STATUS_ABNORMAL
*copyc TMP$WAIT
?? EJECT ??
   PROCEDURE [INLINE] wait_request_calc
     (   requested_ms: 0 .. 0ffffffffffff(16);
         expected_ms: 0 .. 0ffffffffffff(16);
         global_taskid: ost$global_task_id;
     VAR wait: tmt$rb_wait);

    VAR
      time: ost$free_running_clock;

     time := #free_running_clock (0);
     wait.reqcode := syc$rc_wait;

     IF (((requested_ms * 1000) + time) > UPPERVALUE (ost$free_running_clock)) THEN
       wait.requested_wait_time := UPPERVALUE (ost$free_running_clock);
     ELSE
       wait.requested_wait_time := (requested_ms * 1000) + time;
     IFEND;

     IF ((expected_ms * 1000) > UPPERVALUE (ost$free_running_clock)) THEN
       wait.expected_wait_time := UPPERVALUE (ost$free_running_clock);
     ELSE
       wait.expected_wait_time := expected_ms * 1000;
     IFEND;

     wait.global_taskid := global_taskid;

   PROCEND wait_request_calc;

?? TITLE := '  [XDCL, #GATE] pmp$wait', EJECT ??
*copyc PMH$WAIT

  PROCEDURE [XDCL, #GATE] pmp$wait (requested_ms: 0 .. 0ffffffffffff(16);
                  expected_ms: 0 .. 0ffffffffffff(16));

    VAR
      wait: tmt$rb_wait,
      global_taskid: ost$global_task_id,
      caller: ost$caller_identifier;

    #caller_id (caller);
    #keypoint (osk$entry, 0, pmk$wait);
    global_taskid := tmv$null_global_task_id;

    IF (caller.ring < tmc$highest_recognition_ring) THEN
      tmp$wait (global_taskid, tmc$wait, requested_ms, expected_ms);
    ELSE
      wait_request_calc (requested_ms, expected_ms, global_taskid, wait);
      i#call_monitor (#LOC (wait), #SIZE (wait));
    IFEND;

    #keypoint (osk$exit, 0, pmk$wait);


  PROCEND pmp$wait;
?? TITLE := 'PMP$READY_TASK_AND_WAIT',  EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$ready_task_and_wait (global_taskid: ost$global_task_id;
        requested_ms: 0 .. 0ffffffffffff(16);
        expected_ms: 0 .. 0ffffffffffff(16);
    VAR status: ost$status);
*copyc pmh$ready_task_and_wait

    VAR
      wait: tmt$rb_wait,
      caller: ost$caller_identifier;

   #KEYPOINT (osk$entry, 0, pmk$ready_task_and_wait);

   status.normal := TRUE;

   #caller_id (caller);

   IF caller.ring > 6 THEN
     osp$set_status_abnormal ('PM', pme$insufficient_privilege, '', status);
     #KEYPOINT (osk$exit, 0, pmk$ready_task_and_wait);
     RETURN;
   IFEND;

   IF (caller.ring < tmc$highest_signal_flag_ring) THEN
     tmp$wait (global_taskid, tmc$wait, requested_ms, expected_ms);
   ELSE
     wait_request_calc (requested_ms, expected_ms, global_taskid, wait);
     i#call_monitor (#LOC (wait), #SIZE (wait));
   IFEND;

   IF NOT wait.status.normal THEN
     osp$set_status_abnormal (pmc$program_management_id, pme$unknown_recipient_task, '', status);
   IFEND;

   #KEYPOINT (osk$exit, 0, pmk$ready_task_and_wait);

 PROCEND pmp$ready_task_and_wait;

?? TITLE := '  [XDCL, #GATE] pmp$long_term_wait', EJECT ??
*copyc PMH$LONG_TERM_WAIT
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$long_term_wait (requested_ms: 0 .. 0ffffffffffff(16);
                     expected_ms: 0 .. 0ffffffffffff(16));


    VAR
      wait: tmt$rb_wait,
      global_taskid: ost$global_task_id,
      caller: ost$caller_identifier;

    #caller_id (caller);
    #keypoint (osk$entry, 0, pmk$long_term_wait);
    global_taskid := tmv$null_global_task_id;

    IF (caller.ring < tmc$highest_recognition_ring) THEN
      tmp$wait (global_taskid, tmc$long_term_wait, requested_ms, expected_ms);
    ELSE
      wait_request_calc (requested_ms, expected_ms, global_taskid, wait);
      i#call_monitor (#LOC (wait), #SIZE (wait));
    IFEND;

    #keypoint (osk$exit, 0, pmk$long_term_wait);

  PROCEND pmp$long_term_wait;
MODEND pmm$wait_services;
*DECK DECK=PMP$ABORT EXPAND=FALSE

  PROCEDURE [XREF] pmp$abort (status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$ACQUIRE_RAW_TASK_STATISTICS EXPAND=FALSE
  PROCEDURE [XREF] pmp$acquire_raw_task_statistics
    (VAR active_task_count: 0 .. pmc$max_task_id;
     VAR active_task_statistics: array [1 .. * ] of pmt$raw_task_statistics);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$raw_task_statistics
*copyc pmt$task_id
?? POP ??
*DECK DECK=PMP$ACTIVATE_RING_ALARM EXPAND=FALSE
  PROCEDURE [XREF] pmp$activate_ring_alarm
    (VAR activate_ring_alarm: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PMP$ADD_FINAL_INTERBLOCK_REF EXPAND=FALSE

  PROCEDURE [XREF] pmp$add_final_interblock_ref
   (    loader_seq_descriptor_p: ^pmt$loader_seq_descriptor);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$loader_seq_descriptor
?? POP ??
*DECK DECK=PMP$APD_CALL_TO_USERS_PROCEDURE EXPAND=FALSE

  PROCEDURE [XREF] pmp$apd_call_to_users_procedure;
*DECK DECK=PMP$AWAIT_ADA_TASK EXPAND=FALSE


  PROCEDURE [XREF] pmp$await_ada_task  (
        os_stack_frame_word: ^pmt$os_stack_frame_word);

*copyc pmt$os_stack_frame_word
*DECK DECK=PMP$AWAIT_NONEMPTY_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] pmp$await_nonempty_queue (qid: pmt$queue_connection;
    requestor_ring: ost$ring;
    VAR nonempty_queue: boolean;
    VAR status: ost$status);

*copyc PMD$LOCAL_QUEUES
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
*copyc PME$LOCAL_QUEUE_EXCEPTIONS
*DECK DECK=PMP$AWAIT_TASK EXPAND=FALSE

  PROCEDURE [XREF] pmp$await_task (task_id: pmt$task_id;
    VAR wait_complete: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$AWAIT_TASK_TERMINATION EXPAND=FALSE

  PROCEDURE [XREF] pmp$await_task_termination (task_id: pmt$task_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_ID
*copyc OST$STATUS
*copyc PME$EXECUTION_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$BEGIN_SUBSYSTEM_ACTIVITY EXPAND=FALSE

  PROCEDURE [XREF] pmp$begin_subsystem_activity
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PMP$BEGIN_TIMESHARING_CONDITION EXPAND=FALSE

  PROCEDURE [XREF] pmp$begin_timesharing_condition;
*DECK DECK=PMP$BEGIN_TIMESHARING_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] pmp$begin_timesharing_handler;
*DECK DECK=PMP$BINARY_TO_ASCII EXPAND=FALSE

  PROCEDURE [XREF] pmp$binary_to_ascii (i: integer;
    VAR st: string(*);
    base: 2..16;
    pos: 1..255);
*DECK DECK=PMP$BINARY_TO_ASCII_FIT EXPAND=FALSE

  PROCEDURE [XREF] pmp$binary_to_ascii_fit
    (    int: integer;
         base: 2 .. 16;
         pos: 1 .. 255;
         length: 1 .. 255;
     VAR str: string ( * ));
*DECK DECK=PMP$BROADCAST_UNSEEN_MAIL EXPAND=FALSE
  PROCEDURE [XREF] pmp$broadcast_unseen_mail
    (    recipient_user: ost$user_identification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=PMP$BUILD_ADA_TASK_TABLE EXPAND=FALSE

  PROCEDURE [XREF] pmp$build_ada_task_table (
        number_of_tasks: pmt$max_number_of_tasks;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$max_number_of_tasks
*copyc pme$execution_exceptions
*copyc ose$heap_full_exceptions
*copyc ost$status
?? POP ??
*DECK DECK=PMP$BUILD_OUTWARD_CALL_SFSA EXPAND=FALSE

  PROCEDURE [XREF] pmp$build_outward_call_sfsa (callee:
    ^ost$external_code_base_pointer;
    ring: ost$ring;
    parameter_list: ^cell;
    preceding_sfsa: ^ost$stack_frame_save_area;
    stack_frame_size: ost$segment_length;
    VAR stack_segment: ^pmt$stack_segment;
    VAR outward_call_sfsa: ^ost$stack_frame_save_area);
?? PUSH (LISTEXT := ON) ??
*copyc OSD$CODE_BASE_POINTER
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc PMT$STACK_SEGMENT
?? POP ??
*DECK DECK=PMP$BUILD_RING_CROSSING_FRAME EXPAND=FALSE


  PROCEDURE [XREF] pmp$build_ring_crossing_frame (ring_crossing_sfsa: ^ost$stack_frame_save_area);

?? PUSH (LISTEXT := ON) ??
*copyc ost$stack_frame_save_area
?? POP ??
*DECK DECK=PMP$CALL_BEGIN_DEBUG EXPAND=FALSE

  PROCEDURE [XREF] pmp$call_begin_debug (starting_procedure: ^cell);
*DECK DECK=PMP$CALL_END_DEBUG EXPAND=FALSE

  PROCEDURE [XREF] pmp$call_end_debug;
*DECK DECK=PMP$CALL_END_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] pmp$call_end_handler;

*DECK DECK=PMP$CALL_RING_CROSSING_PROC EXPAND=FALSE


  PROCEDURE [XREF] pmp$call_ring_crossing_proc;
*DECK DECK=PMP$CAUSE_CONDITION EXPAND=FALSE

  PROCEDURE [XREF] pmp$cause_condition (condition_name: pmt$condition_name;
        condition_descriptor: ^pmt$condition_information;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$CONDITION_NAME
*copyc PMT$CONDITION_INFORMATION
*copyc OST$STATUS
*copyc PME$CONDITION_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$CAUSE_CONDITION_IN_TASKS EXPAND=FALSE

    PROCEDURE [XREF] pmp$cause_condition_in_tasks
      (    condition_name: pmt$condition_name);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$condition_name
?? POP ??
*DECK DECK=PMP$CAUSE_INTER_JOB_CONDITION EXPAND=FALSE
  PROCEDURE [XREF] pmp$cause_inter_job_condition
    (    condition: pmt$condition_name;
         task_id: ost$global_task_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc ost$status
*copyc pme$condition_exceptions
*copyc pmt$condition_name
?? POP ??
*DECK DECK=PMP$CAUSE_INTRA_JOB_CONDITION EXPAND=FALSE
  PROCEDURE [XREF] pmp$cause_intra_job_condition
    (    condition: pmt$condition_name;
         task_id: pmt$task_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$condition_exceptions
*copyc pme$unknown_recipient_task
*copyc pmt$condition_name
*copyc pmt$task_id
?? POP ??
*DECK DECK=PMP$CAUSE_TASK_CONDITION EXPAND=FALSE
  PROCEDURE [XREF] pmp$cause_task_condition
    (    condition_name: pmt$condition_name;
         condition_descriptor: ^pmt$condition_information;
         notify_scl: boolean;
         notify_debug: boolean;
         propagate_to_parent: boolean;
         call_default_handler: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pme$condition_exceptions
*copyc pmt$condition_information
*copyc pmt$condition_name
*copyc ost$status
?? POP ??

*DECK DECK=PMP$CHANGE_BINDING_TO_WRITE EXPAND=FALSE



  PROCEDURE [XREF] pmp$change_binding_to_write
    (    segment: ^cell;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$program_services_exceptions
?? POP ??
*DECK DECK=PMP$CHANGE_DATE_TIME EXPAND=FALSE
*DECK DECK=PMP$CHANGE_DEBUG_LIBRARY_LIST EXPAND=FALSE

  PROCEDURE [XREF] pmp$change_debug_library_list
   (    delete_libraries: ^pmt$object_library_list;
        add_libraries: ^pmt$object_library_list;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_DESCRIPTION
*copyc OST$STATUS
*copyc PME$EXECUTION_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$CHANGE_DEFAULT_PROG_OPTIONS EXPAND=FALSE

  PROCEDURE [XREF] pmp$change_default_prog_options
    (    change: pmt$default_prog_options_change;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$execution_exceptions
*copyc pmt$default_prog_options_change
?? POP ??
*DECK DECK=PMP$CHANGE_INHERITABLE_SEGMENTS EXPAND=FALSE

  PROCEDURE [XREF] pmp$change_inheritable_segments
    (    option: pmt$segment_inheritance_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$execution_exceptions
*copyc pmt$segment_inheritance_options
?? POP ??
*DECK DECK=PMP$CHANGE_JOB_LIBRARY_LIST EXPAND=FALSE

  PROCEDURE [XREF] pmp$change_job_library_list
    (    delete_libraries: ^pmt$object_library_list;
         add_libraries: ^pmt$object_library_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$execution_exceptions
*copyc pmt$program_description
?? POP ??
*DECK DECK=PMP$CHANGE_LEGIBLE_DATE_FORMAT EXPAND=FALSE

  PROCEDURE [XREF] pmp$change_legible_date_format
    (    {input} new_format: ost$date_formats;
     VAR {input, output} date: ost$date;
     VAR status: ost$status);

?? PUSH (LIST := OFF) ??
*copyc ost$date
*copyc ost$status
*copyc pme$system_time_exceptions
?? POP ??
*DECK DECK=PMP$CHANGE_OPERATION_PASSWORD EXPAND=FALSE

  PROCEDURE [XREF] pmp$change_operation_password
    (    old_password: ost$name;
         new_password: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=PMP$CHANGE_TERM_ERROR_LEVEL EXPAND=FALSE

  PROCEDURE [XREF] pmp$change_term_error_level
    (    new_termination_error_level: ost$status_severity;
     VAR old_termination_error_level: ost$status_severity;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$status_severity
?? POP ??
*DECK DECK=PMP$CHANGE_TRANSIENT_TO_BINDING EXPAND=FALSE



  PROCEDURE [XREF] pmp$change_transient_to_binding
    (    segment: ^cell;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$program_services_exceptions
?? POP ??
*DECK DECK=PMP$CHANGE_TRANSIENT_TO_EXECUTE EXPAND=FALSE




  PROCEDURE [XREF] pmp$change_transient_to_execute
    (    segment: ^cell;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$program_services_exceptions
?? POP ??
*DECK DECK=PMP$CHANGE_TRANSIENT_TO_WRITE EXPAND=FALSE




  PROCEDURE [XREF] pmp$change_transient_to_write
    (    segment: ^cell;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$program_services_exceptions
?? POP ??
*DECK DECK=PMP$CHILD_TERMINATION_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] pmp$child_termination_handler (originator:
    ost$global_task_id;
    signal: pmt$signal);
?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc PMT$SIGNAL
?? POP ??
*DECK DECK=PMP$CLEANUP_LOADED_RINGS EXPAND=FALSE
  PROCEDURE [XREF] pmp$cleanup_loaded_rings;

*DECK DECK=PMP$CLEAR_PIT_HAS_BEEN_SET EXPAND=FALSE
  PROCEDURE [XREF] pmp$clear_pit_has_been_set;

*DECK DECK=PMP$CLEAR_PIT_WAS_SET_IN_CH EXPAND=FALSE
  PROCEDURE [XREF] pmp$clear_pit_was_set_in_ch;

*DECK DECK=PMP$CLEAR_WAIT_INHIBITED EXPAND=FALSE

  PROCEDURE [XREF] pmp$clear_wait_inhibited
    (VAR was_wait_inhibited: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PMP$CLOSE_COMMON_BLOCK_FILE EXPAND=FALSE


  PROCEDURE [XREF] pmp$close_common_block_file
    (    common_block: pmt$program_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$put_program_actions
*copyc ame$ring_validation_errors
*copyc ost$status
*copyc pme$execution_exceptions
*copyc pmt$program_name

?? POP ??
*DECK DECK=PMP$CLOSE_OBJECT_LIBRARY EXPAND=FALSE


  PROCEDURE [XREF] pmp$close_object_library
    (    file_identifier: amt$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=PMP$COLLECT_RAW_TASK_STATISTICS EXPAND=FALSE

  PROCEDURE [XREF] pmp$collect_raw_task_statistics (VAR active_task_count: 0 ..
    pmc$max_task_id;
    VAR active_task_statistics: array [1 .. * ] OF pmt$raw_task_statistics);
?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_ID
*copyc PMT$RAW_TASK_STATISTICS
?? POP ??
*DECK DECK=PMP$COMPUTE_DATE_TIME EXPAND=FALSE

  PROCEDURE [XREF] pmp$compute_date_time
    (    base: ost$date_time;
         increment: pmt$time_increment;
     VAR result: ost$date_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$status
*copyc pmt$time_increment
?? POP ??
*DECK DECK=PMP$COMPUTE_DATE_TIME_INCREMENT EXPAND=TRUE

  PROCEDURE [XREF] pmp$compute_date_time_increment
    (    old: ost$date_time;
         new: ost$date_time;
     VAR increment: pmt$time_increment;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$status
*copyc pmt$time_increment
?? POP ??
*DECK DECK=PMP$COMPUTE_DAY_OF_WEEK EXPAND=FALSE

  PROCEDURE [XREF] pmp$compute_day_of_week
    (    date: ost$date_time;
     VAR day_of_week: ost$day_of_week;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$day_of_week
*copyc ost$status
?? POP ??
*DECK DECK=PMP$COMPUTE_LOCAL_DATE_TIME EXPAND=FALSE

  PROCEDURE [XREF] pmp$compute_local_date_time
    (    universal_date_time: ost$date_time;
         time_zone: ost$time_zone;
     VAR local_date_time: ost$date_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$status
*copyc ost$time_zone
?? POP ??
*DECK DECK=PMP$COMPUTE_TIME_DIF_IN_SECONDS EXPAND=FALSE

  PROCEDURE [XREF] pmp$compute_time_dif_in_seconds
    (    old: ost$date_time;
         new: ost$date_time;
     VAR seconds: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$status
?? POP ??
*DECK DECK=PMP$COMPUTE_UNIVERSAL_DATE_TIME EXPAND=FALSE

  PROCEDURE [XREF] pmp$compute_universal_date_time
    (    local_date_time: ost$date_time;
         time_zone: ost$time_zone;
     VAR universal_date_time: ost$date_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$status
*copyc ost$time_zone
?? POP ??
*DECK DECK=PMP$CONDITION_TASK_TERMINATION EXPAND=FALSE
  PROCEDURE [XREF] pmp$condition_task_termination;

*DECK DECK=PMP$CONNECT_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] pmp$connect_queue (name: pmt$queue_name;
    VAR qid: pmt$queue_connection;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMD$LOCAL_QUEUES
*copyc OST$STATUS
*copyc PME$LOCAL_QUEUE_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$CONTINUE_TO_CAUSE EXPAND=FALSE

  PROCEDURE [XREF] pmp$continue_to_cause (standard: pmt$standard_selection;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$STANDARD_SELECTION
*copyc OST$STATUS
*copyc PME$CONDITION_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$CONVERT_BINARY_MAINFRAME_ID EXPAND=FALSE
  PROCEDURE [XREF] pmp$convert_binary_mainframe_id
    (    binary_mainframe_id: pmt$binary_mainframe_id;
     VAR mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$binary_mainframe_id
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=PMP$CONVERT_BINARY_UNIQUE_NAME EXPAND=FALSE
  PROCEDURE [XREF] pmp$convert_binary_unique_name
    (    binary_name: ost$binary_unique_name;
     VAR name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=PMP$CONVERT_CPU_BINARY_TO_ASCII EXPAND=FALSE
*DECK DECK=PMP$CONVERT_ENTRY_POINT_TO_CMND EXPAND=FALSE

  PROCEDURE [INLINE] pmp$convert_entry_point_to_cmnd (entry_point_dictionary_item:
    llt$entry_point_dictionary_item;
        command_ordinal: clt$named_entry_ordinal;
    VAR command_dictionary_item: llt$command_dictionary_item);

?? PUSH (LISTEXT := ON) ??

    command_dictionary_item.name := entry_point_dictionary_item.name;
    command_dictionary_item.class := clc$nominal_entry;
    command_dictionary_item.availability := clc$advertised_entry;
    command_dictionary_item.ordinal := command_ordinal;
    command_dictionary_item.kind := entry_point_dictionary_item.kind;
    command_dictionary_item.log_option := clc$automatically_log;
    command_dictionary_item.module_kind := entry_point_dictionary_item.module_kind;
    CASE command_dictionary_item.module_kind OF
    = llc$command_procedure =
      command_dictionary_item.command_header := entry_point_dictionary_item.command_header;
    = llc$program_description =
      command_dictionary_item.program_header := entry_point_dictionary_item.program_header;
    = llc$load_module =
      command_dictionary_item.module_header := entry_point_dictionary_item.module_header;
    CASEND;

  PROCEND pmp$convert_entry_point_to_cmnd;

*copyc clt$named_entry_ordinal
*copyc llt$command_dictionary
*copyc llt$entry_point_dictionary
?? POP ??
*DECK DECK=PMP$CONVERT_MAINFRAME_TO_BINARY EXPAND=FALSE
  PROCEDURE [XREF] pmp$convert_mainframe_to_binary
    (    mainframe_id: pmt$mainframe_id;
     VAR binary_mainframe_id: pmt$binary_mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$program_services_exceptions
*copyc pmt$binary_mainframe_id
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=PMP$CONVERT_UNIQUE_TO_BINARY EXPAND=FALSE
  PROCEDURE [XREF] pmp$convert_unique_to_binary
    (    name: ost$name;
     VAR binary_unique_name: ost$binary_unique_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$binary_unique_name
*copyc ost$name
*copyc ost$status
*copyc pme$program_services_exceptions
?? POP ??
*DECK DECK=PMP$COPY_PROG_OPTIONS_AND_LIBS EXPAND=FALSE
*DECK DECK=PMP$CREATE_ADA_HEAP EXPAND=FALSE



  PROCEDURE [XREF] pmp$create_ada_heap (
    VAR heap_segment_pointer: mmt$segment_pointer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$attribute_keyword
*copyc ost$status
?? POP ??
*DECK DECK=PMP$CREATE_CHILD_XCB EXPAND=FALSE

  PROCEDURE [XREF] pmp$create_child_xcb
    (    task_id: pmt$task_id;
         task_control_block: ^cell;
         initial_procedure: ^procedure;
         initial_ring: ost$ring;
         task_kind: ost$task_kind;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
*copyc ost$task_kind
*copyc pmt$task_id
?? POP ??
*DECK DECK=PMP$CREATE_SHARED_STACK EXPAND=FALSE

  PROCEDURE [XREF] pmp$create_shared_stack  (
        segment_attributes: ^ARRAY [*] of mmt$attribute_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$task_id
*copyc osd$virtual_address
*copyc pme$execution_exceptions
*copyc ost$status
?? POP ??
*DECK DECK=PMP$CREATE_TASK_ENVIRONMENT EXPAND=FALSE

  PROCEDURE [XREF] pmp$create_task_environment (program_description:
    ^pmt$program_description;
        mpe_description: ^pmt$loader_description;
        program_parameters: ^pmt$program_parameters;
        parent_task_status_variable: ^pmt$task_status;
        target_ring: ost$ring;
        critical_frame: ^ost$stack_frame_save_area;
        starting_procedure: pmt$user_program;
        cl_task: boolean;
    VAR task_id: pmt$task_id;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pmt$user_program
*copyc PMT$PROGRAM_DESCRIPTION
*copyc PMT$LOADER_SEQ_DESCRIPTOR
*copyc PMT$PROGRAM_PARAMETERS
*copyc PMT$TASK_STATUS
*copyc OSD$VIRTUAL_ADDRESS
*copyc PMT$TASK_ID
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$CYCLE EXPAND=FALSE

  PROCEDURE [XREF] pmp$cycle
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=PMP$DATE_TIME_COMPARE EXPAND=FALSE
  PROCEDURE [XREF] pmp$date_time_compare
    (    left_operand: ost$date_time;
         right_operand: ost$date_time;
     VAR comparison_result: pmt$comparison_result;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$status
*copyc pme$system_time_exceptions
*copyc pmt$comparison_result
?? POP ??
*DECK DECK=PMP$DEBUG_ABORT_FILE_SPECIFIED EXPAND=FALSE

  PROCEDURE [XREF] pmp$debug_abort_file_specified (VAR abort_file_specified:
    boolean);
*DECK DECK=PMP$DEBUG_CRITICAL_FRAME EXPAND=FALSE
  PROCEDURE [XREF] pmp$debug_critical_frame (stack_frame: ^ost$stack_frame_save_area;
    VAR critical_stack_frame: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STACK_FRAME_SAVE_AREA
?? POP ??
*DECK DECK=PMP$DEBUG_LOGGING_ENABLED EXPAND=FALSE

  FUNCTION [XREF] pmp$debug_logging_enabled: boolean;
*DECK DECK=PMP$DEFINE_DEBUG_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pmp$define_debug_entry
    (    debug_code: pmt$debug_codes;
         low_address: pmt$debug_low_address;
         high_address: pmt$debug_high_address;
     VAR debug_id: pmt$debug_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmd$debug
*copyc pme$debug_exceptions
?? POP ??
*DECK DECK=PMP$DEFINE_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] pmp$define_queue (name: pmt$queue_name;
        removal_bracket: ost$ring;
        usage_bracket: ost$ring;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMD$LOCAL_QUEUES
*copyc OST$STATUS
*copyc PME$LOCAL_QUEUE_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$DELAY EXPAND=FALSE

  PROCEDURE [XREF] pmp$delay
    (    milliseconds: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=PMP$DELETE_CURRENT_ENVIRONMENT EXPAND=FALSE
  PROCEDURE [XREF] pmp$delete_current_environment
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$condition_exceptions
?? POP ??
*DECK DECK=PMP$DELETE_CURRENT_ENVIRON_R2 EXPAND=FALSE


  PROCEDURE [XREF] pmp$delete_current_environ_r2
    (    condition_ring: ost$ring;
     VAR status: ost$status);

*copyc osd$virtual_address
*copyc ost$status
*DECK DECK=PMP$DELETE_ENVIRONMENT EXPAND=FALSE
  PROCEDURE [XREF] pmp$delete_environment
    (    critical_frame: ^ost$stack_frame_save_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc pme$condition_exceptions
?? POP ??
*DECK DECK=PMP$DELETE_ENVIRONMENT_R2 EXPAND=FALSE


  PROCEDURE [XREF] pmp$delete_environment_r2
    (    condition_ring: ost$ring;
         critical_frame: ^ost$stack_frame_save_area;
     VAR status: ost$status);


*copyc osd$virtual_address
*copyc ost$stack_frame_save_area
*copyc ost$status
*DECK DECK=PMP$DELETE_NON_INHERITED_SEGS EXPAND=FALSE

  PROCEDURE [XREF] pmp$delete_non_inherited_segs (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$DESELECT_PROCESSOR EXPAND=FALSE
  PROCEDURE [XREF] pmp$deselect_processor (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PMP$DESELECT_PROCESSOR_R1 EXPAND=FALSE
 PROCEDURE [XREF] pmp$deselect_processor_r1 (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PMP$DETERMINE_PIT_SET EXPAND=FALSE

  PROCEDURE [XREF] pmp$determine_pit_set (VAR pit_was_set: boolean);

*DECK DECK=PMP$DISABLE_TS_IO_IN_TASKS EXPAND=FALSE

  PROCEDURE [XREF] pmp$disable_ts_io_in_tasks;
*DECK DECK=PMP$DISCONNECT_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] pmp$disconnect_queue (qid: pmt$queue_connection;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMD$LOCAL_QUEUES
*copyc OST$STATUS
*copyc PME$LOCAL_QUEUE_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$DISCONNECT_TASK_FROM_QUEUES EXPAND=FALSE

  PROCEDURE [XREF] pmp$disconnect_task_from_queues;

*DECK DECK=PMP$DISESTABLISH_COND_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] pmp$disestablish_cond_handler (conditions: pmt$condition;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$CONDITION
*copyc OST$STATUS
*copyc PME$CONDITION_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$DISESTABLISH_END_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] pmp$disestablish_end_handler
    (    end_handler: pmt$end_handler;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$condition_exceptions
*copyc pmt$end_handler
?? POP ??
*DECK DECK=PMP$DISESTABLISH_SEGMENT_ACCESS EXPAND=FALSE


  PROCEDURE [XREF] pmp$disestablish_segment_access
    (    common_block: pmt$program_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$access_validation_errors
*copyc ame$improper_file_id
*copyc ame$ring_validation_errors
*copyc ame$segment_validation_errors
*copyc ost$status
*copyc pme$execution_exceptions
*copyc pmt$program_name

?? POP ??
*DECK DECK=PMP$DISESTAB_END_HNDLR_IN_RING EXPAND=FALSE

  PROCEDURE [XREF] pmp$disestab_end_hndlr_in_ring
    (    end_handler: pmt$end_handler;
         ring: ost$ring;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
*copyc pme$condition_exceptions
*copyc pmt$end_handler
?? POP ??
*DECK DECK=PMP$DISPLAY_ACTIVE_TASKS EXPAND=FALSE

  PROCEDURE [XREF] pmp$display_active_tasks
    (    output: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=PMP$DISPOSE_INTERACTIVE_COND EXPAND=FALSE

  PROCEDURE [XREF] pmp$dispose_interactive_cond (interactive_condition: ift$interactive_condition);

?? PUSH (LISTEXT := ON) ??
*copyc ift$condition_codes
?? POP ??
*DECK DECK=PMP$DISPOSE_JOB_RESOURCE_COND EXPAND=FALSE

  PROCEDURE [XREF] pmp$dispose_job_resource_cond (job_resource_condition:
    jmt$job_resource_condition);

?? PUSH (LISTEXT := ON) ??
*copyc JMD$JOB_RESOURCE_CONDITION
?? POP ??
*DECK DECK=PMP$DISPOSE_MCR_CONDITIONS EXPAND=FALSE

  PROCEDURE [XREF] pmp$dispose_mcr_conditions (fault: ost$monitor_fault;
    sfsa: ^ost$stack_frame_save_area);

*copyc OST$MONITOR_FAULT
*copyc OST$STACK_FRAME_SAVE_AREA
*DECK DECK=PMP$DISPOSE_OF_DELAYED_COND EXPAND=FALSE

  PROCEDURE [XREF] pmp$dispose_of_delayed_cond (sfsa: ^ost$stack_frame_save_area);

*copyc OST$STACK_FRAME_SAVE_AREA
*DECK DECK=PMP$DISPOSE_SEGMENT_ACCESS_COND EXPAND=FALSE

  PROCEDURE [XREF] pmp$dispose_segment_access_cond (condition: mmt$segment_access_condition;
        sfsa: ^ost$stack_frame_save_area);

?? PUSH (LISTEXT := ON) ??
*copyc MMD$SEGMENT_ACCESS_CONDITION
*copyc OST$STACK_FRAME_SAVE_AREA
?? POP ??
*DECK DECK=PMP$DISPOSE_UCR_CONDITIONS EXPAND=FALSE

  PROCEDURE [XREF] pmp$dispose_ucr_conditions (VAR outstanding_ucr: ost$user_conditions;
    condition_save_area: ^ost$stack_frame_save_area;
    debug_index: 0 .. 31);

*copyc OSD$CONDITIONS
*copyc OST$STACK_FRAME_SAVE_AREA
*DECK DECK=PMP$EMIT_JOB_END_STATISTICS EXPAND=FALSE

  PROCEDURE [XREF] pmp$emit_job_end_statistics
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PMP$ENABLE_JOB_FREE_FLAG EXPAND=FALSE
  PROCEDURE [XREF] pmp$enable_job_free_flag;

*DECK DECK=PMP$ENABLE_SYSTEM_CONDITIONS EXPAND=FALSE

  PROCEDURE [XREF] pmp$enable_system_conditions (conditions:
    pmt$system_conditions;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$SYSTEM_CONDITIONS
*copyc OST$STATUS
*copyc PME$CONDITION_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$ENABLE_TIMESHARING_IO EXPAND=FALSE

  PROCEDURE [XREF] pmp$enable_timesharing_io;
*DECK DECK=PMP$ENABLE_TS_IO_IN_JOB EXPAND=FALSE

  PROCEDURE [XREF] pmp$enable_ts_io_in_job;
*DECK DECK=PMP$ENABLE_TS_IO_IN_TASKS EXPAND=FALSE

  PROCEDURE [XREF] pmp$enable_ts_io_in_tasks;
*DECK DECK=PMP$END_DEBUG_SHOULD_BE_CALLED EXPAND=FALSE

  PROCEDURE [XREF] pmp$end_debug_should_be_called (VAR
    end_debug_should_be_called: boolean);
*DECK DECK=PMP$END_SUBSYSTEM_ACTIVITY EXPAND=FALSE

  PROCEDURE [XREF] pmp$end_subsystem_activity
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PMP$END_TIMESHARING_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] pmp$end_timesharing_handler;
*DECK DECK=PMP$EO_INIT_PROGRAM_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] pmp$eo_init_program_attributes
    (    object: ^clt$environment_object_contents);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
?? POP ??
*DECK DECK=PMP$EO_POP_PROGRAM_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] pmp$eo_pop_program_attributes
    (    pop_reason: clt$env_object_pop_reason;
         object: ^clt$environment_object_contents;
         object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc clt$env_object_pop_reason
*copyc ost$status
?? POP ??
*DECK DECK=PMP$EO_PUSH_PROGRAM_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] pmp$eo_push_program_attributes
    (    push_reason: clt$env_object_push_reason;
         new_object: ^clt$environment_object_contents;
         new_object_in_current_task: boolean;
         pushed_object_in_current_task: boolean;
         pushed_object: ^clt$environment_object_contents;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_contents
*copyc clt$env_object_push_reason
*copyc ost$status
?? POP ??
*DECK DECK=PMP$EO_SIZE_PROGRAM_ATTRIBUTES EXPAND=FALSE

  FUNCTION [XREF] pmp$eo_size_program_attributes: clt$environment_object_size;

?? PUSH (LISTEXT := ON) ??
*copyc clt$environment_object_size
?? POP ??
*DECK DECK=PMP$ESTABLISH_CH_IN_BLOCK EXPAND=FALSE

  PROCEDURE [XREF] pmp$establish_ch_in_block
    (    conditions: pmt$condition;
         condition_handler: pmt$condition_handler;
         block: ^ost$stack_frame_save_area;
         establish_descriptor: ^pmt$established_handler;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc pme$condition_exceptions
*copyc pmt$condition
*copyc pmt$condition_handler
*copyc pmt$established_handler
?? POP ??
*DECK DECK=PMP$ESTABLISH_CH_OUTSIDE_BLOCK EXPAND=FALSE
  PROCEDURE [XREF] pmp$establish_ch_outside_block
    (    conditions: pmt$condition;
         condition_handler: pmt$condition_handler;
         block: ^ost$stack_frame_save_area;
         establish_descriptor: ^pmt$established_handler;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc pme$condition_exceptions
*copyc pmt$condition
*copyc pmt$condition_handler
*copyc pmt$established_handler
?? POP ??
*DECK DECK=PMP$ESTABLISH_CONDITION_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] pmp$establish_condition_handler (conditions: pmt$condition;
        condition_handler: pmt$condition_handler;
        establish_descriptor: ^pmt$established_handler;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$CONDITION
*copyc PMT$CONDITION_HANDLER
*copyc PMT$ESTABLISHED_HANDLER
*copyc OST$STATUS
*copyc PME$CONDITION_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$ESTABLISH_DEBUG_CFF EXPAND=FALSE

  PROCEDURE [XREF] pmp$establish_debug_cff
    (    critical_frame: ^ost$stack_frame_save_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc pme$condition_exceptions
?? POP ??
*DECK DECK=PMP$ESTABLISH_END_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] pmp$establish_end_handler
    (    end_handler: pmt$end_handler;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$condition_exceptions
*copyc pmt$end_handler
?? POP ??
*DECK DECK=PMP$ESTABLISH_END_HNDLR_IN_RING EXPAND=FALSE

  PROCEDURE [XREF] pmp$establish_end_hndlr_in_ring
    (    end_handler: pmt$end_handler;
         ring: ost$ring;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
*copyc pme$condition_exceptions
*copyc pmt$end_handler
?? POP ??
*DECK DECK=PMP$ESTABLISH_SEGMENT_ACCESS EXPAND=FALSE


  PROCEDURE [XREF] pmp$establish_segment_access
    (    file_identifier: amt$file_identifier;
         common_block: pmt$program_name;
     VAR segment_pointer: amt$segment_pointer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$access_validation_errors
*copyc ame$improper_file_id
*copyc ame$ring_validation_errors
*copyc ame$segment_validation_errors
*copyc amt$file_identifier
*copyc amt$segment_pointer
*copyc ost$status
*copyc pme$execution_exceptions
*copyc pmt$program_name

?? POP ??
*DECK DECK=PMP$EXECUTE EXPAND=FALSE

  PROCEDURE [XREF] pmp$execute (program_description: pmt$program_description;
        parameters: pmt$program_parameters;
        wait: ost$wait;
    VAR task_id: pmt$task_id;
    VAR task_status: pmt$task_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_DESCRIPTION
*copyc PMT$PROGRAM_PARAMETERS
*copyc OST$WAIT
*copyc PMT$TASK_ID
*copyc PMT$TASK_STATUS
*copyc OST$STATUS
*copyc PME$EXECUTION_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$EXECUTE_ASYNCHRONOUS EXPAND=FALSE

  PROCEDURE [XREF] pmp$execute_asynchronous (program_description:
    pmt$program_description;
    parameters: pmt$program_parameters;
    wait: ost$wait;
    VAR task_id: pmt$task_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_DESCRIPTION
*copyc PMT$PROGRAM_PARAMETERS
*copyc OST$WAIT
*copyc PMT$TASK_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$EXECUTE_EPILOG EXPAND=FALSE
  PROCEDURE [XREF] pmp$execute_epilog;
*DECK DECK=PMP$EXECUTE_JOB_EPILOGS EXPAND=FALSE
  PROCEDURE [XREF] pmp$execute_job_epilogs;

*DECK DECK=PMP$EXECUTE_PROCEDURE EXPAND=FALSE

  PROCEDURE [XREF] pmp$execute_procedure
    (    starting_procedure: pmt$user_program;
         parameters: pmt$program_parameters;
         critical_frame: ^ost$stack_frame_save_area;
     VAR task_id: pmt$task_id;
     VAR task_status: pmt$task_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc pme$execution_exceptions
*copyc pme$program_services_exceptions
*copyc pmt$program_parameters
*copyc pmt$task_id
*copyc pmt$task_status
*copyc pmt$user_program
?? POP ??
*DECK DECK=PMP$EXECUTE_PROCEDURE_AS_TASK EXPAND=FALSE


  PROCEDURE [XREF] pmp$execute_procedure_as_task (target_ring: ost$valid_ring;
        starting_procedure: pmt$user_program;
        parameters: pmt$program_parameters;
        critical_frame: ^ost$stack_frame_save_area;
    VAR task_id: pmt$task_id;
    VAR task_status: pmt$task_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$user_program
*copyc pmt$program_parameters
*copyc ost$stack_frame_save_area
*copyc pmt$task_id
*copyc pmt$task_status
*copyc ost$status
*copyc osd$virtual_address
*copyc pme$execution_exceptions
?? POP ??
*DECK DECK=PMP$EXECUTE_TASK EXPAND=FALSE

  PROCEDURE [XREF] pmp$execute_task (target_ring: ost$valid_ring;
        program_description: pmt$program_description;
        apd_description: pmt$loader_description;
        parameters: pmt$program_parameters;
        command_file: amt$local_file_name;
        wait: ost$wait;
        cl_task: boolean;
    VAR task_id: pmt$task_id;
    VAR task_status: pmt$task_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OSD$VIRTUAL_ADDRESS
*copyc PMT$PROGRAM_DESCRIPTION
*copyc PMT$PROGRAM_PARAMETERS
*copyc OST$WAIT
*copyc PMT$TASK_ID
*copyc PMT$LOADER_SEQ_DESCRIPTOR
*copyc PMT$TASK_STATUS
*copyc OST$STATUS
*copyc PME$EXECUTION_EXCEPTIONS
*copyc PME$TARGET_RING_ERROR
?? POP ??
*DECK DECK=PMP$EXECUTE_WITHIN_TASK EXPAND=TRUE

  PROCEDURE [XREF] pmp$execute_within_task (
        program_description: pmt$program_description;
        program_parameters: pmt$program_parameters;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$program_description
*copyc pmt$program_parameters
*copyc ost$status
?? POP ??
*DECK DECK=PMP$EXECUTE_WITH_APD EXPAND=FALSE

  PROCEDURE [XREF] pmp$execute_with_apd (program_description:
    pmt$program_description;
        mpe_description: pmt$loader_description;
        parameters: pmt$program_parameters;
        wait: ost$wait;
    VAR task_id: pmt$task_id;
    VAR task_status: pmt$task_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_DESCRIPTION
*copyc PMT$PROGRAM_PARAMETERS
*copyc OST$WAIT
*copyc PMT$TASK_ID
*copyc PMT$LOADER_SEQ_DESCRIPTOR
*copyc PMT$TASK_STATUS
*copyc OST$STATUS
*copyc PME$EXECUTION_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$EXECUTE_WITH_COMMAND_FILE EXPAND=FALSE
  PROCEDURE [XREF] pmp$execute_with_command_file (target_ring: ost$valid_ring;
        program_description: pmt$program_description;
        parameters: pmt$program_parameters;
        command_file: amt$local_file_name;
        wait: ost$wait;
        cl_task: boolean;
    VAR task_id: pmt$task_id;
    VAR task_status: pmt$task_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OSD$VIRTUAL_ADDRESS
*copyc PMT$PROGRAM_DESCRIPTION
*copyc PMT$PROGRAM_PARAMETERS
*copyc OST$WAIT
*copyc PMT$TASK_ID
*copyc PMT$TASK_STATUS
*copyc OST$STATUS
*copyc PME$EXECUTION_EXCEPTIONS
*copyc PME$TARGET_RING_ERROR
?? POP ??
*DECK DECK=PMP$EXECUTE_WITH_LESS_PRIVILEGE EXPAND=FALSE

  PROCEDURE [XREF] pmp$execute_with_less_privilege
    (    target_ring: ost$valid_ring;
         program_description: pmt$program_description;
         program_parameters: pmt$program_parameters;
         wait: ost$wait;
         cl_task: boolean;
     VAR task_id: pmt$task_id;
     VAR task_status: pmt$task_status;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
*copyc ost$wait
*copyc pme$execution_exceptions
*copyc pme$program_services_exceptions
*copyc pme$target_ring_error
*copyc pmt$program_description
*copyc pmt$program_parameters
*copyc pmt$task_id
*copyc pmt$task_status
?? POP ??
*DECK DECK=PMP$EXIT EXPAND=FALSE

  PROCEDURE [XREF] pmp$exit (status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$EXIT_UNIX_TASK EXPAND=FALSE

  PROCEDURE [XREF] pmp$exit_unix_task;

*DECK DECK=PMP$EXPAND_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] pmp$expand_segment
    (    pva: ^cell;
         length: ost$segment_length;
     VAR starting_pva: ^cell;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lle$load_map_diagnostics
*copyc osd$virtual_address
*copyc ost$status
*copyc pme$program_services_exceptions
?? POP ??

*DECK DECK=PMP$FIND_BEGIN_DEBUG EXPAND=FALSE

  PROCEDURE [XREF] pmp$find_begin_debug (VAR begin_debug: dbt$begin_debug);
?? PUSH (LISTEXT := ON) ??
*copyc DBT$BEGIN_DEBUG
?? POP ??
*DECK DECK=PMP$FIND_DEBUG EXPAND=FALSE

  PROCEDURE [XREF] pmp$find_debug (VAR debug: dbt$debug);
?? PUSH (LISTEXT := ON) ??
*copyc DBT$DEBUG
?? POP ??
*DECK DECK=PMP$FIND_END_DEBUG EXPAND=FALSE

  PROCEDURE [XREF] pmp$find_end_debug (VAR end_debug: dbt$end_debug);
?? PUSH (LISTEXT := ON) ??
*copyc DBT$END_DEBUG
?? POP ??
*DECK DECK=PMP$FIND_ENTRY_POINT_ADDRESS EXPAND=FALSE

  PROCEDURE [XREF] pmp$find_entry_point_address (entry_point_name:
    pmt$program_name;
    VAR address: pmt$object_library_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_NAME
*copyc PMT$OBJECT_LIBRARY_ADDRESS
*copyc OST$STATUS
*copyc LLE$FIND_EP_DIAGNOSTICS
*copyc LLE$LOAD_MAP_DIAGNOSTICS
?? POP ??
*DECK DECK=PMP$FIND_ENTRY_POINT_IN_LIBRARY EXPAND=TRUE



*copyc pmh$find_entry_point_in_library

  PROCEDURE [XREF] pmp$find_entry_point_in_library (object_library: ^SEQ ( * );
        entry_point_name: pmt$program_name;
    VAR address: pmt$object_library_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_NAME
*copyc PMT$OBJECT_LIBRARY_ADDRESS
*copyc OST$STATUS
*copyc LLE$FIND_EP_DIAGNOSTICS
*copyc LLE$LOAD_MAP_DIAGNOSTICS
?? POP ??
*DECK DECK=PMP$FIND_EXECUTING_TASK_TCB EXPAND=FALSE

  PROCEDURE [INLINE] pmp$find_executing_task_tcb
    (VAR tcb_p: ^pmt$task_control_block);

?? PUSH (LISTEXT := ON) ??

    VAR
      xcb_p: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb_p);
    tcb_p := xcb_p^.task_control_block;
  PROCEND pmp$find_executing_task_tcb;

*copyc ost$execution_control_block
*copyc pmt$task_control_block
*copyc pmp$find_executing_task_xcb
?? POP ??
*DECK DECK=PMP$FIND_EXECUTING_TASK_XCB EXPAND=FALSE

  PROCEDURE [INLINE] pmp$find_executing_task_xcb (VAR xcb:
    ^ost$execution_control_block);
?? PUSH (LISTEXT := ON) ??

{  The purpose of this request is to locate the execution_control_block
{  of the executing task.
{
{    PMP$FIND_EXECUTING_TASK_XCB (XCB)
{
{  XCB: (output) This parameter specifies the location of the excuting
{                task's execution_control_block.
{

    xcb := #address (1, osc$segnum_job_fixed_heap,
      #read_register (osc$pr_base_constant));
  PROCEND pmp$find_executing_task_xcb;
*copyc OST$EXECUTION_CONTROL_BLOCK
*copyc OST$HEAP
*copyc OSC$PROCESSOR_DEFINED_REGISTERS
?? POP ??
*DECK DECK=PMP$FIND_HANDLER_IN_STACK EXPAND=FALSE

  PROCEDURE [XREF] pmp$find_handler_in_stack (condition: pmt$internal_condition;
    save_area: ^ost$stack_frame_save_area;
    VAR established_handler: ^pmt$established_handler;
    VAR handler_save_area: ^ost$stack_frame_save_area;
    VAR find_status: ost$status);


*copyc PMT$INTERNAL_CONDITION
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc PMT$ESTABLISHED_HANDLER
*copyc OST$STATUS
*DECK DECK=PMP$FIND_HANDLER_IN_STACK_FRAME EXPAND=FALSE

  PROCEDURE [XREF] pmp$find_handler_in_stack_frame (condition: pmt$internal_condition;
    save_area: ^ost$stack_frame_save_area;
    VAR established_handler: ^pmt$established_handler;
    VAR handler_save_area: ^ost$stack_frame_save_area;
    VAR find_status: ost$status);


*copyc PMT$INTERNAL_CONDITION
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc PMT$ESTABLISHED_HANDLER
*copyc OST$STATUS
*DECK DECK=PMP$FIND_MODULE_IN_LIBRARY EXPAND=FALSE


  PROCEDURE [XREF] pmp$find_module_in_library
    (    name: pmt$program_name;
         object_library: ^SEQ ( * );
     VAR address: pmt$object_library_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lle$load_map_diagnostics
*copyc ost$status
*copyc pmt$object_library_address
*copyc pmt$program_name
?? POP ??

*DECK DECK=PMP$FIND_NEXT_HANDLER_IN_FRAME EXPAND=FALSE

  PROCEDURE [XREF] pmp$find_next_handler_in_frame (condition: pmt$internal_condition;
    save_area: ^ost$stack_frame_save_area;
    current_handler: ^pmt$established_handler;
    VAR established_handler: ^pmt$established_handler;
    VAR find_status: ost$status);

*copyc PMT$INTERNAL_CONDITION
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc PMT$ESTABLISHED_HANDLER
*copyc OST$STATUS
*DECK DECK=PMP$FIND_NEXT_HANDLER_IN_STACK EXPAND=FALSE

  PROCEDURE [XREF] pmp$find_next_handler_in_stack (condition: pmt$internal_condition;
    save_area: ^ost$stack_frame_save_area;
    current_handler: ^pmt$established_handler;
    VAR established_handler: ^pmt$established_handler;
    VAR handler_save_area: ^ost$stack_frame_save_area;
    VAR find_status: ost$status);

*copyc PMT$INTERNAL_CONDITION
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc PMT$ESTABLISHED_HANDLER
*copyc OST$STATUS
*DECK DECK=PMP$FIND_OPTNS_LIBS_FIRST_TIME EXPAND=FALSE
*DECK DECK=PMP$FIND_PROG_OPTIONS_AND_LIBS EXPAND=FALSE

  PROCEDURE [INLINE] pmp$find_prog_options_and_libs
    (VAR prog_options_and_libraries: ^pmt$prog_options_and_libraries);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_object_in_current_task: boolean,
      object: ^clt$environment_object_contents;


    clp$find_environment_object (clc$eo_program_attributes, object,
          ignore_object_in_current_task);

    prog_options_and_libraries := object;

  PROCEND pmp$find_prog_options_and_libs;

*copyc pmt$prog_options_and_libraries
?? POP ??
*copyc clp$find_environment_object
*DECK DECK=PMP$FIND_STACK_SEGMENT EXPAND=FALSE

  PROCEDURE [XREF] pmp$find_stack_segment (ring: ost$ring;
    VAR stack_segment: ^pmt$stack_segment);
?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc PMT$STACK_SEGMENT
?? POP ??
*DECK DECK=PMP$FIND_TASK_TCB EXPAND=FALSE

  PROCEDURE [XREF] pmp$find_task_tcb
    (    task_id: pmt$task_id;
     VAR tcb: ^pmt$task_control_block);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$task_id
*copyc pmt$task_control_block
?? POP ??
*DECK DECK=PMP$FIND_TASK_XCB EXPAND=FALSE

  PROCEDURE [XREF] pmp$find_task_xcb (task_id: pmt$task_id;
    VAR xcb: ^ost$execution_control_block);
?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_ID
*copyc OST$EXECUTION_CONTROL_BLOCK
?? POP ??
*DECK DECK=PMP$FIX_INITIAL_DEBUG EXPAND=FALSE

  PROCEDURE [XREF] pmp$fix_initial_debug (task_debug_mode: pmt$debug_mode;
        debug_input: amt$local_file_name;
        debug_output: amt$local_file_name;
        abort_file: amt$local_file_name);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$DEBUG_MODE
*copyc AMT$LOCAL_FILE_NAME
?? POP ??
*DECK DECK=PMP$FLAG_ALL_CHILD_TASKS EXPAND=FALSE

  PROCEDURE [XREF] pmp$flag_all_child_tasks (system_flag: ost$system_flag;
    VAR status {control} : ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$SYSTEM_FLAG
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$FORK_TASK EXPAND=FALSE

  PROCEDURE [XREF] pmp$fork_task
    (    u_area_source_segment: integer;
         u_area_destination_segment: integer;
     VAR child_task: boolean;
     VAR status: integer);

*DECK DECK=PMP$FORK_TASK_BOOT EXPAND=FALSE

  PROCEDURE [XREF] pmp$fork_task_boot;

*DECK DECK=PMP$FORMAT_COMPACT_DATE EXPAND=FALSE

  PROCEDURE [XREF] pmp$format_compact_date
    (    date_time: ost$date_time;
         format: ost$date_formats;
     VAR date: ost$date;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date
*copyc ost$date_time
*copyc ost$status
?? POP ??
*DECK DECK=PMP$FORMAT_COMPACT_TIME EXPAND=FALSE

  PROCEDURE [XREF] pmp$format_compact_time
    (    date_time: ost$date_time;
         format: ost$time_formats;
     VAR time: ost$time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$time
*copyc ost$status
?? POP ??
*DECK DECK=PMP$GENERATE_UNIQUE_NAME EXPAND=FALSE

  PROCEDURE [XREF] pmp$generate_unique_name (VAR name: ost$unique_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OSD$UNIQUE_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$GET_170_OS_TYPE EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_170_os_type
    (VAR os_type: ost$170_os_type;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$170_os_type
*copyc ost$status
?? POP ??
*DECK DECK=PMP$GET_ACCOUNT_PROJECT EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_account_project (VAR account: avt$account_name;
    VAR project: avt$project_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AVT$ACCOUNT_NAME
*copyc AVT$PROJECT_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$GET_APD_TASK_JOBMODE_STATS EXPAND=FALSE

{ NOTE:
{   This procedure is called by the ASSEMBLER deck PMM$INTERCEPT_PROCEDURES.
{ If this procedure call is changed PMM$INTERCEPT_PROCEDURES must be changed
{ or ANALYZE_PROGRAM_DYNAMICS will break.

  PROCEDURE [XREF] pmp$get_apd_task_jobmode_stats
    (VAR jobmode_statistics: pmt$apd_task_jobmode_statistics);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$apd_task_jobmode_statistics
?? POP ??
*DECK DECK=PMP$GET_APPLICATION_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_application_information
   (    application_address: ost$pva;
    VAR application_module_name: ost$name;
    VAR application_identifier: llt$application_identifier;
    VAR library_privilege: ost$name;
    VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc osd$virtual_address
*copyc ost$name
*copyc llt$application_identifier
*copyc ost$status
?? POP ??
*DECK DECK=PMP$GET_BINARY_CPU_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_binary_cpu_attributes (
    VAR cpu_attributes: pmt$binary_cpu_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$binary_cpu_attributes
?? POP ??
*DECK DECK=PMP$GET_BINARY_MAINFRAME_ID EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_binary_mainframe_id (
    VAR mainframe_id: pmt$binary_mainframe_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=PMP$GET_BINARY_PROCESSOR_ID EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_binary_processor_id (
    VAR processor_element_id: ost$processor_element_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$processor_element_id
*copyc ost$status
?? POP ??
*DECK DECK=PMP$GET_COMPACT_DATE_TIME EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_compact_date_time
    (VAR date_time: ost$date_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$status
?? POP ??
*DECK DECK=PMP$GET_CPU_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_cpu_attributes (
    VAR cpu_attributes: pmt$cpu_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$cpu_attributes
*copyc ost$status
?? POP ??
*DECK DECK=PMP$GET_CURRENT_ENVIRONMENT EXPAND=FALSE
  PROCEDURE [XREF] pmp$get_current_environment
    (VAR environment: pmt$condition_environment;
     VAR environment_present: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$condition_exceptions
*copyc pmt$condition_environment
?? POP ??
*DECK DECK=PMP$GET_CURRENT_ENVIRON_R2 EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_current_environ_r2
    (   condition_ring: ost$ring;
     VAR environment: pmt$condition_environment;
     VAR environment_present: boolean;
     VAR status: ost$status);

*copyc osd$virtual_address
*copyc pmt$condition_environment
*copyc ost$status
*DECK DECK=PMP$GET_DATE EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_date
    (    format: ost$date_formats;
     VAR date: ost$date;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date
*copyc ost$status
*copyc pme$program_services_exceptions
?? POP ??
*DECK DECK=PMP$GET_DATE_TIME_AT_TIMESTAMP EXPAND=FALSE
  PROCEDURE [XREF] pmp$get_date_time_at_timestamp
    (    timestamp: integer;
         time_zone: pmt$use_time_zone;
     VAR date_time: ost$date_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$status
*copyc pme$system_time_exceptions
*copyc pmt$use_time_zone
?? POP ??
*DECK DECK=PMP$GET_DAY_OF_WEEK EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_day_of_week
    (VAR day_of_week: ost$day_of_week;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$day_of_week
*copyc ost$status
?? POP ??
*DECK DECK=PMP$GET_DEBUG_ABORT_FILE EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_debug_abort_file
    (VAR abort_file_specified: boolean;
     VAR abort_file: amt$local_file_name);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
?? POP ??
*DECK DECK=PMP$GET_DEBUG_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_debug_entry
    (    debug_id: pmt$debug_identifier;
     VAR debug_code: pmt$debug_codes;
     VAR low_address: pmt$debug_low_address;
     VAR high_address: pmt$debug_high_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmd$debug
*copyc pme$debug_exceptions
?? POP ??
*DECK DECK=PMP$GET_DEBUG_ENVIRONMENT EXPAND=FALSE
  PROCEDURE [XREF] pmp$get_debug_environment (VAR debug_environment: pmt$debug_environment);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$DEBUG_ENVIRONMENT
?? POP ??
*DECK DECK=PMP$GET_DEBUG_ID EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_debug_id
    (    debug_index: 0 .. 63;
     VAR debug_id: pmt$debug_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmd$debug
*copyc pme$debug_exceptions
?? POP ??
*DECK DECK=PMP$GET_DEBUG_INPUT_FILE EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_debug_input_file
    (VAR input_file_specified: boolean;
     VAR input_file: amt$local_file_name);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
?? POP ??
*DECK DECK=PMP$GET_DEBUG_OUTPUT_FILE EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_debug_output_file
    (VAR output_file_specified: boolean;
     VAR output_file: amt$local_file_name);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
?? POP ??
*DECK DECK=PMP$GET_DEFAULT_DATE_TIME_FORM EXPAND=FALSE
  PROCEDURE [XREF] pmp$get_default_date_time_form
    (VAR date_default: ost$default_date_format;
     VAR time_default: ost$default_time_format);

?? PUSH (LISTEXT := ON) ??
*copyc ost$default_time_format
*copyc ost$default_date_format
?? POP ??
*DECK DECK=PMP$GET_DELAYED_CONDITION EXPAND=FALSE
  PROCEDURE [XREF] pmp$get_delayed_condition
    (VAR delayed_condition: pmt$delayed_condition;
     VAR condition_present: boolean;
     VAR another_condition_present: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$delayed_condition
?? POP ??
*DECK DECK=PMP$GET_ENTRY_POINT_DICTIONARY EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_entry_point_dictionary (library: ^SEQ ( * );
    VAR entry_point_dictionary: ^llt$entry_point_dictionary;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc llt$load_module
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$GET_EXECUTING_TASK_GTID EXPAND=FALSE

  PROCEDURE [INLINE] pmp$get_executing_task_gtid (VAR global_task_id:
    ost$global_task_id);
?? PUSH (LISTEXT := ON) ??

{  The purpose of this request is to return the global_task_id of the
{  executing task.
{
{    PMP$GET_EXECUTING_TASK_GTID (GLOBAL_TASK_ID)
{
{  GLOBAL_TASK_ID: (output) This parameter specifies the global_task_id of
{                           the executing task.
{

    VAR
      xcb_p: ^ost$execution_control_block;
*IF $variable(dfv$compile_mock_code,declared)<>'UNKNOWN'
    global_task_id.index := 22;
*ELSE
    xcb_p := #address(1, osc$segnum_job_fixed_heap,
      #read_register (osc$pr_base_constant));
    global_task_id := xcb_p^.global_task_id;
*IFEND
  PROCEND pmp$get_executing_task_gtid;
*copyc OST$GLOBAL_TASK_ID
*copyc OST$HEAP
*copyc OSC$PROCESSOR_DEFINED_REGISTERS
*copyc OST$EXECUTION_CONTROL_BLOCK
*copyc OSK$KEYPOINT_CLASS_CODES
*copyc OSK$COMMON_KEYPOINT_DEFINITIONS
?? POP ??
*DECK DECK=PMP$GET_EXECUTING_TASK_GTID_R6 EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_executing_task_gtid_r6
   (VAR global_task_id: ost$global_task_id);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
?? POP ??
*DECK DECK=PMP$GET_FAMILY_NAMES EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_family_names (
    VAR family_names: pmt$family_name_list;
    VAR name_count: pmt$family_name_count;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$program_services_exceptions
*copyc pmt$family_name_count
*copyc pmt$family_name_list
?? POP ??

*DECK DECK=PMP$GET_GLOBAL_TASK_ID EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_global_task_id (task_id: pmt$task_id;
    VAR global_task_id: ost$global_task_id;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_ID
*copyc OST$GLOBAL_TASK_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$GET_JOB_MODE EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_job_mode (VAR mode: jmt$job_mode;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc JMT$JOB_MODE
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$GET_JOB_MONITOR_GTID EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_job_monitor_gtid (
    VAR global_task_id: ost$global_task_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc ost$status
?? POP ??
*DECK DECK=PMP$GET_JOB_NAMES EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_job_names (
    VAR user_supplied_name: jmt$user_supplied_name;
    VAR system_supplied_name: jmt$system_supplied_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$user_supplied_name
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=PMP$GET_JOB_TASK_STATISTICS EXPAND=FALSE
  PROCEDURE [XREF] pmp$get_job_task_statistics
    (    statistic_data_p: ^array [1 .. * ] of pmt$job_task_statistics;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$job_task_statistics
*copyc ost$status
?? POP ??
*DECK DECK=PMP$GET_LAST_PATH_NAME EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_last_path_name
    (    path: fst$file_reference;
     VAR last_name: ost$name;
     VAR status: ost$status);

*copyc fst$file_reference
*copyc ost$name
*copyc ost$status
*DECK DECK=PMP$GET_LEGIBLE_DATE_TIME EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_legible_date_time
    (    date_format: ost$date_formats;
     VAR date: ost$date;
         time_format: ost$time_formats;
     VAR time: ost$time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date
*copyc ost$time
*copyc ost$status
?? POP ??
*DECK DECK=PMP$GET_LIBRARY_DICTIONARIES EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_library_dictionaries
    (    library: ^SEQ ( * );
     VAR dictionaries: llt$library_dictionary_pointers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lle$load_map_diagnostics
*copyc llt$library_dictionary_pointers
*copyc ost$status
*copyc pme$program_services_exceptions
?? POP ??
*DECK DECK=PMP$GET_LOADED_RINGS EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_loaded_rings (VAR loaded_rings: pmt$loadable_rings);
?? PUSH (LISTEXT := ON) ??
*copyc PMT$LOADABLE_RINGS
?? POP ??
*DECK DECK=PMP$GET_MAINFRAME_ATTRIBUTES EXPAND=FALSE
  PROCEDURE [XREF] pmp$get_mainframe_attributes
    (VAR mainframe_attributes: pmt$mainframe_attributes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pme$program_services_exceptions
*copyc ost$status
*copyc pmt$mainframe_attributes
?? POP ??
*DECK DECK=PMP$GET_MAINFRAME_ID EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_mainframe_id (
    VAR mainframe_id: pmt$mainframe_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=PMP$GET_MICROSECOND_CLOCK EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_microsecond_clock
    (VAR microsecond_clock: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PMP$GET_OS_BUILD_LEVEL EXPAND=FALSE
  PROCEDURE [XREF] pmp$get_os_build_level
    (VAR build_level: pmt$os_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$os_name
?? POP ??
*DECK DECK=PMP$GET_OS_VERSION EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_os_version
    (VAR version: pmt$os_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$os_name
?? POP ??
*DECK DECK=PMP$GET_PAGE_SIZE EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_page_size (
    VAR page_size: ost$page_size;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$page_size
*copyc ost$status
?? POP ??
*DECK DECK=PMP$GET_PARENT_CALLING_RING EXPAND=FALSE


  PROCEDURE [XREF] pmp$get_parent_calling_ring (VAR ring: ost$valid_ring;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$GET_PARENT_TASK_ID EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_parent_task_id
    (    child_task_id: pmt$task_id;
     VAR parent_task_id: pmt$task_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$program_services_exceptions
*copyc pmt$task_id
?? POP ??
*DECK DECK=PMP$GET_PROCESSOR_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_processor_attributes (VAR attributes:
    pmt$processor_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROCESSOR_ATTRIBUTES
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$GET_PROCESSOR_DESCRIPTIONS EXPAND=FALSE
  PROCEDURE [XREF] pmp$get_processor_descriptions (VAR processor_descriptions:
      pmt$processor_descriptions;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$processor_descriptions
?? POP ??
*DECK DECK=PMP$GET_PROCESSOR_DESCRIP_R1 EXPAND=FALSE
 PROCEDURE [XREF] pmp$get_processor_descrip_r1 (VAR processor_descriptions:
   pmt$processor_descriptions;
   VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$processor_descriptions
?? POP ??
*DECK DECK=PMP$GET_PROCESSOR_ID EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_processor_id (
    VAR model_type: pmt$processor_model_type;
    VAR model_number: pmt$processor_model_number;
    VAR serial_number: pmt$processor_serial_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$processor_model_number
*copyc pmt$processor_model_type
*copyc pmt$processor_serial_number
?? POP ??
*DECK DECK=PMP$GET_PROGRAM_DESCRIPTION EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_program_description (VAR program_description:
    pmt$program_description;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_DESCRIPTION
*copyc OST$STATUS
*copyc PME$EXECUTION_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$GET_PROGRAM_SIZE EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_program_size (VAR number_of_object_files:
    pmt$number_of_object_files;
    VAR number_of_modules: pmt$number_of_modules;
    VAR number_of_libraries: pmt$number_of_libraries;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_DESCRIPTION
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$GET_PROGRAM_SIZE_IN_BYTES EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_program_size_in_bytes
   (VAR program_size: ost$segment_length;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$status
?? POP ??
*DECK DECK=PMP$GET_PSEUDO_MAINFRAME_ID EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_pseudo_mainframe_id
    (VAR mainframe_id: pmt$binary_mainframe_id);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=PMP$GET_QUEUE_LIMITS EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_queue_limits (VAR queue_limits: pmt$queue_limits;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$QUEUE_LIMITS
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$GET_SRUS EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_srus (VAR srus: jmt$sru_count;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc JMD$SRU_COUNT
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$GET_SYSTEM_TIME EXPAND=FALSE
  PROCEDURE [XREF] pmp$get_system_time
    (VAR time: pmt$system_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$system_time
?? POP ??
*DECK DECK=PMP$GET_TASK_CP_TIME EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_task_cp_time (VAR cp_time: pmt$task_cp_time;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_CP_TIME
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$GET_TASK_ID EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_task_id (VAR task_id: pmt$task_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$GET_TASK_JOBMODE_STATISTICS EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_task_jobmode_statistics
    (VAR jobmode_statistics: pmt$task_jobmode_statistics;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$task_jobmode_statistics
?? POP ??
*DECK DECK=PMP$GET_TERMINATION_STATUS EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_termination_status (VAR termination_status:
    ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$GET_TIME EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_time
    (    format: ost$time_formats;
     VAR time: ost$time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$time
*copyc pme$program_services_exceptions
?? POP ??
*DECK DECK=PMP$GET_TIME_ZONE EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_time_zone
    (VAR time_zone: ost$time_zone;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$time_zone
?? POP ??
*DECK DECK=PMP$GET_UNIQUE_NAME EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_unique_name
    (VAR name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=PMP$GET_UNIVERSAL_DATE_TIME EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_universal_date_time
    (VAR universal_date_time: ost$date_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$status
?? POP ??
*DECK DECK=PMP$GET_USER_IDENTIFICATION EXPAND=FALSE

  PROCEDURE [XREF] pmp$get_user_identification (VAR identification:
    ost$user_identification;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$USER_IDENTIFICATION
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$INHIBIT_SYSTEM_CONDITIONS EXPAND=FALSE

  PROCEDURE [XREF] pmp$inhibit_system_conditions (conditions:
    pmt$system_conditions;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$SYSTEM_CONDITIONS
*copyc OST$STATUS
*copyc PME$CONDITION_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$INITIALIZE_CPU_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] pmp$initialize_cpu_attributes;
*DECK DECK=PMP$INITIALIZE_JOB_XCB_LIST EXPAND=FALSE

  PROCEDURE [XREF] pmp$initialize_job_xcb_list (job_monitor_task_id: pmt$task_id;
    job_monitor_tcb: ^cell;
    trap_handler: ^procedure);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_ID
?? POP ??
*DECK DECK=PMP$INITIALIZE_TASKING_TABLES EXPAND=FALSE

  PROCEDURE [XREF] pmp$initialize_tasking_tables (job_monitor_initial_ring:
    ost$ring;
    job_monitor_program_description: ^pmt$program_description;
    job_monitor_parameters: ^pmt$program_parameters);
?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc PMT$PROGRAM_DESCRIPTION
*copyc PMT$PROGRAM_PARAMETERS
?? POP ??
*DECK DECK=PMP$INITIAL_DEBUG_MODE_ON EXPAND=FALSE

  PROCEDURE [XREF] pmp$initial_debug_mode_on
    (VAR initial_debug_mode_on: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PMP$INITIAL_INTERCEPT_PROCEDURE EXPAND=FALSE

  PROCEDURE [XREF] pmp$initial_intercept_procedure;
*DECK DECK=PMP$INITIATE_CHILD_TASK EXPAND=FALSE

  PROCEDURE [XREF] pmp$initiate_child_task (task_id: pmt$task_id;
    spy_identifier: pmt$spy_identifier;
    wait: ost$wait;
    VAR child_initiated: BOOLEAN);
?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_ID
*copyc PMT$SPY_IDENTIFIER
*copyc OST$WAIT
?? POP ??
*DECK DECK=PMP$INIT_DEFAULT_PROG_OPTIONS EXPAND=FALSE

  PROCEDURE [XREF] pmp$init_default_prog_options (VAR default_program_options:
    ^pmt$program_options;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$program_options
?? POP ??
*DECK DECK=PMP$INTERCEPT_CALL_PROCEDURE EXPAND=FALSE

  PROCEDURE [XREF] pmp$intercept_call_procedure;
*DECK DECK=PMP$INWARD_CALL EXPAND=FALSE

  PROCEDURE [XREF] pmp$inward_call
    (    callee: ^ost$external_code_base_pointer;
         target_ring: ost$ring;
         callee_parameter_list: ^cell;
         callee_previous_save_area: ^ost$stack_frame_save_area);

?? PUSH (LISTEXT := ON) ??
*copyc osd$code_base_pointer
*copyc osd$virtual_address
*copyc ost$stack_frame_save_area
?? POP ??
*DECK DECK=PMP$IS_THERE_A_HANDLER_IN_STACK EXPAND=FALSE


  PROCEDURE [XREF] pmp$is_there_a_handler_in_stack (condition: pmt$internal_condition;
    save_area: ^ost$stack_frame_save_area;
    VAR established_handler: ^pmt$established_handler;
    VAR handler_save_area: ^ost$stack_frame_save_area;
    VAR find_status: ost$status);


*copyc PMT$INTERNAL_CONDITION
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc PMT$ESTABLISHED_HANDLER
*copyc OST$STATUS
*DECK DECK=PMP$JOB_DEBUG_RING EXPAND=FALSE

  FUNCTION [XREF] pmp$job_debug_ring: ost$ring;

?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
?? POP ??
*DECK DECK=PMP$KILL_TASK_FLAG_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] pmp$kill_task_flag_handler
    (    flag_id: ost$system_flag);

?? PUSH (LISTEXT := ON) ??
*copyc ost$system_flag
?? POP ??
*DECK DECK=PMP$LOAD EXPAND=FALSE

  PROCEDURE [XREF] pmp$load (name: pmt$program_name;
        kind: pmt$loaded_address_kind;
    VAR address: pmt$loaded_address;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_NAME
*copyc PMT$LOADED_ADDRESS
*copyc OST$STATUS
*copyc LLE$LOADER_STATUS_CONDITIONS
?? POP ??
*DECK DECK=PMP$LOADED_RING_CLEANUP EXPAND=FALSE

  PROCEDURE [XREF] pmp$loaded_ring_cleanup;
*DECK DECK=PMP$LOAD_DEBUG_PROCEDURES EXPAND=FALSE

  PROCEDURE [XREF] pmp$load_debug_procedures (VAR status {control} :
    ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$LOAD_ENTRY_POINT EXPAND=FALSE

  PROCEDURE [XREF] pmp$load_entry_point
    (    name: pmt$program_name;
         reference_ring: ost$valid_ring;
         reference_global_key: ost$key_lock_value;
         kind: pmt$loaded_address_kind;
     VAR address: pmt$loaded_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc lle$loader_status_conditions
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$loaded_address
*copyc pmt$program_name
?? POP ??
*DECK DECK=PMP$LOAD_FROM_LIBRARY EXPAND=FALSE

  PROCEDURE [XREF] pmp$load_from_library (name: pmt$program_name;
        ring: ost$ring;
        global_key: ost$key_lock_value;
        kind: pmt$loaded_address_kind;
        library: ^SEQ ( * );
        library_name: amt$local_file_name;
    VAR address: pmt$loaded_address;
    VAR status: ost$status);

*copyc PMT$PROGRAM_NAME
*copyc OSD$VIRTUAL_ADDRESS
*copyc PMT$LOADED_ADDRESS
*copyc AMT$LOCAL_FILE_NAME
*copyc LLE$LOADER_STATUS_CONDITIONS
*copyc OST$STATUS
*DECK DECK=PMP$LOAD_MODULE_FROM_LIBRARY EXPAND=FALSE

  PROCEDURE [XREF] pmp$load_module_from_library
    (    name: pmt$program_name;
         reference_ring: ost$valid_ring;
         kind: pmt$loaded_address_kind;
         library: fst$file_reference;
     VAR loaded_ring: ost$valid_ring;
     VAR call_bracket_ring: ost$valid_ring;
     VAR address: pmt$loaded_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc lle$loader_status_conditions
*copyc osd$virtual_address
*copyc ost$status
*copyc pmt$loaded_address
*copyc pmt$program_name
?? POP ??
*DECK DECK=PMP$LOCK_UNLOCK_MAIN_WINDOW EXPAND=FALSE

  PROCEDURE [XREF] pmp$lock_unlock_main_window
    (    password: ost$name;
         lock_window: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=PMP$LOG EXPAND=FALSE


  PROCEDURE [XREF] pmp$log (text: pmt$log_msg_text;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMD$SYSTEM_LOG_INTERFACE
*copyc PME$LOGGING_EXCEPTIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$LOG_ASCII EXPAND=FALSE


  PROCEDURE [XREF] pmp$log_ascii (text: pmt$log_msg_text;
        log: pmt$ascii_logset;
        origin: pmt$log_msg_origin;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMD$SYSTEM_LOG_INTERFACE
*copyc PME$LOGGING_EXCEPTIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$LONG_TERM_WAIT EXPAND=FALSE

  PROCEDURE [XREF] pmp$long_term_wait
    (    requested_ms: 0 .. 0ffffffffffff(16);
         expected_ms: 0 .. 0ffffffffffff(16));

*DECK DECK=PMP$MANAGE_SENSE_SWITCHES EXPAND=FALSE

  PROCEDURE [XREF] pmp$manage_sense_switches (on: pmt$sense_switches;
        off: pmt$sense_switches;
    VAR current: pmt$sense_switches;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$SENSE_SWITCHES
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$MEAPE_SEGMENTS_CONSTRAINED EXPAND=FALSE

  PROCEDURE [XREF] pmp$meape_segments_constrained
   (VAR constrained: boolean);
*DECK DECK=PMP$MODIFY_DEBUG_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pmp$modify_debug_entry
    (    debug_id: pmt$debug_identifier;
         debug_code: pmt$debug_codes;
         low_address: pmt$debug_low_address;
         high_address: pmt$debug_high_address;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmd$debug
*copyc pme$debug_exceptions
?? POP ??
*DECK DECK=PMP$MONITOR_LOADED_RING_CLEANUP EXPAND=FALSE


  PROCEDURE [XREF] pmp$monitor_loaded_ring_cleanup;
*DECK DECK=PMP$MULTI_TASK_SIGNAL_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] pmp$multi_task_signal_handler
    (    originator: ost$global_task_id;
         signal: pmt$signal);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc pmt$signal
?? POP ??
*DECK DECK=PMP$OPEN_COMMON_BLOCK_FILE EXPAND=FALSE


  PROCEDURE [XREF] pmp$open_common_block_file
    (    file: fst$file_reference;
         common_block: pmt$program_name;
     VAR segment_pointer: amt$segment_pointer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$access_validation_errors
*copyc ame$improper_file_id
*copyc ame$ring_validation_errors
*copyc ame$segment_validation_errors
*copyc amt$segment_pointer
*copyc fst$file_reference
*copyc ost$status
*copyc pme$execution_exceptions
*copyc pmt$program_name

?? POP ??
*DECK DECK=PMP$OPEN_OBJECT_LIBRARY EXPAND=FALSE


  PROCEDURE [XREF] pmp$open_object_library
    (    file_name: amt$local_file_name;
     VAR file_identifier: amt$file_identifier;
     VAR object_library: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc amt$file_identifier
*copyc lle$find_ep_diagnostics
*copyc lle$load_map_diagnostics
*copyc ost$status
?? POP ??

*DECK DECK=PMP$ORIGINAL_CALLER EXPAND=FALSE

  PROCEDURE [XREF] pmp$original_caller (user_program_cbp:
    ^ost$external_code_base_pointer;
    program_parameters: ^pmt$program_parameters);
?? PUSH (LISTEXT := ON) ??
*copyc OSD$CODE_BASE_POINTER
*copyc PMT$PROGRAM_PARAMETERS
?? POP ??
*DECK DECK=PMP$OUTWARD_CALL EXPAND=FALSE

  PROCEDURE [XREF] pmp$outward_call (callee: ^ost$external_code_base_pointer;
    ring: ost$ring;
    parameter_list: ^cell;
    preceding_sfsa: ^ost$stack_frame_save_area;
    VAR stack_segment: ^pmt$stack_segment);
?? PUSH (LISTEXT := ON) ??
*copyc OSD$CODE_BASE_POINTER
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc PMT$STACK_SEGMENT
?? POP ??
*DECK DECK=PMP$PIT_WAS_SET EXPAND=FALSE
  FUNCTION [XREF] pmp$pit_was_set: boolean;

*DECK DECK=PMP$PIT_WAS_SET_IN_CH EXPAND=FALSE
  FUNCTION [XREF] pmp$pit_was_set_in_ch: boolean;

*DECK DECK=PMP$POP_3_STACK_FRAMES EXPAND=FALSE

  PROCEDURE [XREF] pmp$pop_3_stack_frames (pad_size: ost$segment_length);
?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
?? POP ??
*DECK DECK=PMP$POP_ALL_STACK_FRAMES EXPAND=FALSE

  PROCEDURE [XREF] pmp$pop_all_stack_frames;
*DECK DECK=PMP$POP_INHIBIT_TERMINATION EXPAND=FALSE

  PROCEDURE [XREF] pmp$pop_inhibit_termination;

*DECK DECK=PMP$POP_TASK_DEBUG_MODE EXPAND=FALSE

  PROCEDURE [XREF] pmp$pop_task_debug_mode
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PMP$POSITION_OBJECT_LIBRARY EXPAND=FALSE

  PROCEDURE [XREF] pmp$position_object_library (VAR object_library: ^SEQ ( * );
        offset: ost$relative_pointer;
    VAR valid_position: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc llt$load_module
?? POP ??
*DECK DECK=PMP$POST_CURRENT_ENVIRONMENT EXPAND=FALSE
  PROCEDURE [XREF] pmp$post_current_environment
    (    environment {input, output} : ^pmt$condition_environment);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$condition_environment
?? POP ??
*DECK DECK=PMP$POST_CURRENT_ENVIRON_R2 EXPAND=FALSE

  PROCEDURE [XREF] pmp$post_current_environment_r2
    (    condition_ring: ost$ring;
     VAR environment: ^pmt$condition_environment);


*copyc osd$virtual_address
*copyc pmt$condition_environment
*DECK DECK=PMP$POST_DEBUG_ENVIRONMENT EXPAND=FALSE
  PROCEDURE [XREF] pmp$post_debug_environment (debug_environment: pmt$debug_environment);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$DEBUG_ENVIRONMENT
?? POP ??
*DECK DECK=PMP$POST_DELAYED_CONDITION EXPAND=FALSE
  PROCEDURE [XREF] pmp$post_delayed_condition
    (    delayed_condition: ^pmt$delayed_condition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$delayed_condition
?? POP ??
*DECK DECK=PMP$POST_UNSEEN_MAIL EXPAND=FALSE
  PROCEDURE [XREF] pmp$post_unseen_mail;

*DECK DECK=PMP$PROPAGATE_UNSEEN_MAIL EXPAND=FALSE

  PROCEDURE [INLINE] pmp$propagate_unseen_mail
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    status.normal := TRUE;
    pmp$schedule_unseen_mail;
    pmp$cause_task_condition (osc$unseen_mail_condition, NIL, TRUE, FALSE,
          FALSE, TRUE, status);

  PROCEND pmp$propagate_unseen_mail;

*copyc osc$unseen_mail_condition
*copyc ost$status
*copyc pmp$cause_task_condition
*copyc pmp$schedule_unseen_mail
?? POP ??
*DECK DECK=PMP$PURGE_INSTRUCTION_STACK EXPAND=FALSE

  PROCEDURE [XREF] pmp$purge_instruction_stack;
*DECK DECK=PMP$PUSH_INHIBIT_TERMINATION EXPAND=FALSE

  PROCEDURE [XREF] pmp$push_inhibit_termination;

*DECK DECK=PMP$PUSH_TASK_DEBUG_MODE EXPAND=FALSE

  PROCEDURE [XREF] pmp$push_task_debug_mode
    (    debug_mode: pmt$debug_mode;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lle$loader_status_conditions
*copyc lle$load_map_diagnostics
*copyc ost$status
*copyc pmt$debug_mode
?? POP ??
*DECK DECK=PMP$READY_TASK EXPAND=FALSE

  PROCEDURE [XREF] pmp$ready_task
    (    task: ost$global_task_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc ost$status
*copyc pme$unknown_recipient_task
?? POP ??
*DECK DECK=PMP$READY_TASK_AND_WAIT EXPAND=FALSE

  PROCEDURE [XREF] pmp$ready_task_and_wait
    (    global_taskid: ost$global_task_id;
         requested_ms: 0 .. 0ffffffffffff(16);
         expected_ms: 0 .. 0ffffffffffff(16);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc ost$status
*copyc pme$insufficient_privilege
*copyc pme$unknown_recipient_task
?? POP ??
*DECK DECK=PMP$RECEIVE_FROM_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] pmp$receive_from_queue (qid: pmt$queue_connection;
        wait: ost$wait;
    VAR message: pmt$message;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMD$LOCAL_QUEUES
*copyc OST$WAIT
*copyc OST$STATUS
*copyc PME$LOCAL_QUEUE_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$RECEIVE_QUEUE_MESSAGE EXPAND=FALSE
  PROCEDURE [XREF] pmp$receive_queue_message
    (    qid: pmt$queue_connection;
         wait: ost$wait;
     VAR message: pmt$message;
     VAR complete: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$wait
*copyc pmd$local_queues
*copyc pme$local_queue_exceptions
?? POP ??
*DECK DECK=PMP$RECORD_PROGRAM_TERMINATION EXPAND=FALSE
  PROCEDURE [XREF] pmp$record_program_termination
    (    status: ost$status;
         program_termination_mode: pmt$program_termination_mode);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$task_state
?? POP ??
*DECK DECK=PMP$RECORD_TASK_NAME EXPAND=FALSE

  PROCEDURE [XREF] pmp$record_task_name (task_name: ost$name;
    override_old_name {control} : boolean);
?? PUSH (LISTEXT := ON) ??
*copyc OST$NAME
?? POP ??
*DECK DECK=PMP$REINITIALIZE_MODULE EXPAND=FALSE
  PROCEDURE [XREF] pmp$reinitialize_module
    (    module_name: pmt$program_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := OFF) ??
*copyc lle$load_map_diagnostics
*copyc ost$status
*copyc pmt$program_name
?? POP ??
*DECK DECK=PMP$RELEASE_CHILD_XCB EXPAND=FALSE

  PROCEDURE [XREF] pmp$release_child_xcb (task_id: pmt$task_id;
    VAR child_tcb: ^cell);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_ID
?? POP ??
*DECK DECK=PMP$RELEASE_PROG_OPTNS_AND_LIBS EXPAND=FALSE
*DECK DECK=PMP$RELEASE_TASK_ENVIRONMENT EXPAND=FALSE

  PROCEDURE [XREF] pmp$release_task_environment (task_id: pmt$task_id);
?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_ID
?? POP ??
*DECK DECK=PMP$REMOVE_AWAIT_NONEMPTY_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] pmp$remove_await_nonempty_queue (qid: pmt$queue_connection);

*copyc PMD$LOCAL_QUEUES
*DECK DECK=PMP$REMOVE_DEBUG_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pmp$remove_debug_entry
    (    debug_id: pmt$debug_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmd$debug
*copyc pme$debug_exceptions
?? POP ??
*DECK DECK=PMP$REMOVE_ENTRY_POINT EXPAND=FALSE


  PROCEDURE [XREF] pmp$remove_entry_point (name: pmt$program_name;
    VAR status {control} : ost$status);
*copyc pmt$program_name
*copyc ost$status
*DECK DECK=PMP$REMOVE_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] pmp$remove_queue (name: pmt$queue_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMD$LOCAL_QUEUES
*copyc OST$STATUS
*copyc PME$LOCAL_QUEUE_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$RESERVE_STACK_SEGMENTS EXPAND=FALSE


  PROCEDURE [XREF] pmp$reserve_stack_segments
    (    number_of_tasks: pmt$max_number_of_tasks;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$execution_exceptions
*copyc pmt$max_number_of_tasks
?? POP ??
*DECK DECK=PMP$RESET_DEBUG_SCAN EXPAND=FALSE

  PROCEDURE [XREF] pmp$reset_debug_scan
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PMP$RESTORE_PROGRAM_STATE EXPAND=FALSE
  PROCEDURE [XREF] pmp$restore_program_state
    (    p_state_container: ^SEQ ( * );
         p_parameter: ^cell;
         parameter_length: 0 .. 0ffff(16);
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$program_state_exceptions
?? POP ??
*DECK DECK=PMP$RETURN_TO_OUTWARD_CALL_SFSA EXPAND=FALSE

  PROCEDURE [XREF] pmp$return_to_outward_call_sfsa (outward_call_sfsa:
    ^ost$stack_frame_save_area);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STACK_FRAME_SAVE_AREA
?? POP ??
*DECK DECK=PMP$REVOKE_PROGRAM_TERMINATION EXPAND=FALSE

  PROCEDURE [XREF] pmp$revoke_program_termination
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$execution_exceptions
?? POP ??
*DECK DECK=PMP$RING_CROSSING_PROCEDURE EXPAND=FALSE

  PROCEDURE [XREF] pmp$ring_crossing_procedure (VAR activate_alarm: boolean);
*DECK DECK=PMP$RING_CROSSING_PROC_RETURN EXPAND=FALSE


  PROCEDURE [XREF] pmp$ring_crossing_proc_return;
*DECK DECK=PMP$RTN_TO_OUTWRD_CALL_SFSA_SFF EXPAND=FALSE


  PROCEDURE [XREF] pmp$rtn_to_outwrd_call_sfsa_sff
    (    outward_call_sfsa: ^ost$stack_frame_save_area);

?? PUSH (LISTEXT := ON) ??
*copyc ost$stack_frame_save_area
?? POP ??
*DECK DECK=PMP$SAVE_PROGRAM_STATE EXPAND=FALSE
  PROCEDURE [XREF] pmp$save_program_state
    (VAR p_state_container: ^SEQ ( * );
     VAR original_program: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$program_state_exceptions
?? POP ??
*DECK DECK=PMP$SCHEDULE_UNSEEN_MAIL EXPAND=FALSE
  PROCEDURE [XREF] pmp$schedule_unseen_mail;

*DECK DECK=PMP$SELECT_PROCESSOR EXPAND=FALSE
  PROCEDURE [XREF] pmp$select_processor (id: ost$logical_processor_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$cpu_definitions
?? POP ??
*DECK DECK=PMP$SELECT_PROCESSOR_R1 EXPAND=FALSE
 PROCEDURE [XREF] pmp$select_processor_r1 (id: ost$logical_processor_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$cpu_definitions
?? POP ??
*DECK DECK=PMP$SEND_SIGNAL EXPAND=FALSE

  PROCEDURE [XREF] pmp$send_signal (recipient: ost$global_task_id;
    signal: pmt$signal;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc PMT$SIGNAL
*copyc OST$STATUS
*copyc PME$INVALID_TASK_ORIGIN_SIGNAL
*copyc PME$UNKNOWN_RECIPIENT_TASK
*copyc PME$INSUFFICIENT_PRIVILEGE
?? POP ??
*DECK DECK=PMP$SEND_TO_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] pmp$send_to_queue (qid: pmt$queue_connection;
        message: pmt$message;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMD$LOCAL_QUEUES
*copyc OST$STATUS
*copyc PME$LOCAL_QUEUE_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$SET_DEBUG_ENDING EXPAND=FALSE

  PROCEDURE [XREF] pmp$set_debug_ending;

*DECK DECK=PMP$SET_JOB_DEBUG_RING EXPAND=FALSE

  PROCEDURE [XREF] pmp$set_job_debug_ring (debug_ring: ost$ring;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$SET_OPERATION_INTERVAL EXPAND=FALSE

  PROCEDURE [XREF] pmp$set_operation_interval
    (    old_password: ost$name;
         expiration_date: ost$date_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=PMP$SET_OPERATION_PASSWORD EXPAND=FALSE

  PROCEDURE [XREF] pmp$set_operation_password
    (    password: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=PMP$SET_POPPER_HANDLER_ACTIVITY EXPAND=FALSE
  PROCEDURE [XREF] pmp$set_popper_handler_activity
    (    active: boolean);

*DECK DECK=PMP$SET_PROCESS_INTERVAL_TIMER EXPAND=FALSE

  PROCEDURE [XREF] pmp$set_process_interval_timer (microseconds: pmt$pit_value;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$PIT_VALUE
*copyc OST$STATUS
*copyc PME$CONDITION_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$SET_RELATIVE_PRIORITY EXPAND=FALSE


   PROCEDURE [XREF] pmp$set_relative_priority
     (    priority: 0 .. 255;
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pme$program_services_exceptions
?? POP ??
*DECK DECK=PMP$SET_RELATIVE_PRIORITY_R1 EXPAND=FALSE


  PROCEDURE [XREF] pmp$set_relative_priority_r1
    (    priority: 0 .. 255);
*DECK DECK=PMP$SET_SPY_IDENTIFIER EXPAND=FALSE

  PROCEDURE [XREF] pmp$set_spy_identifier (low_identifier: pmt$spy_identifier;
        high_identifier: pmt$spy_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$SPY_IDENTIFIER
*copyc OST$STATUS
*copyc PME$PROGRAM_SERVICES_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$SET_SYSTEM_FLAG EXPAND=FALSE

  PROCEDURE [XREF] pmp$set_system_flag (flag_id: ost$system_flag;
    recipient: ost$global_task_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$SYSTEM_FLAG
*copyc OST$GLOBAL_TASK_ID
*copyc OST$STATUS
*copyc PME$INVALID_TASK_ORIGIN_FLAG
*copyc PME$UNKNOWN_RECIPIENT_TASK
*copyc PME$INSUFFICIENT_PRIVILEGE
?? POP ??
*DECK DECK=PMP$SET_TASK_DEBUG_MODE EXPAND=FALSE

  PROCEDURE [XREF] pmp$set_task_debug_mode
    (    debug_mode: pmt$debug_mode;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc lle$loader_status_conditions
*copyc lle$load_map_diagnostics
*copyc ost$status
*copyc pmt$debug_mode
?? POP ??
*DECK DECK=PMP$SET_TASK_DEBUG_RING EXPAND=FALSE

  PROCEDURE [XREF] pmp$set_task_debug_ring;

*DECK DECK=PMP$SET_TASK_EXECUTION_PHASE EXPAND=FALSE
  PROCEDURE [XREF] pmp$set_task_execution_phase
    (    execution_phase: pmt$task_execution_phase);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$task_execution_phase
?? POP ??
*DECK DECK=PMP$SET_TASK_STATE EXPAND=FALSE

  PROCEDURE [XREF] pmp$set_task_state (new_task_state: pmt$task_state);
?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_STATE
?? POP ??
*DECK DECK=PMP$SET_WHERE_PIT_CAN_BE_CLEARD EXPAND=FALSE
  PROCEDURE [XREF] pmp$set_where_pit_can_be_cleard;

*DECK DECK=PMP$SIGNAL_ALL_CHILD_TASKS EXPAND=FALSE

  PROCEDURE [XREF] pmp$signal_all_child_tasks (signal: pmt$signal;
    VAR status {control} : ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PMT$SIGNAL
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$SIMULATE_CALL_OVERHEAD EXPAND=FALSE

  PROCEDURE [XREF] pmp$simulate_call_overhead;
*DECK DECK=PMP$SIMULATE_RETURN_OVERHEAD EXPAND=FALSE

  PROCEDURE [XREF] pmp$simulate_return_overhead;
*DECK DECK=PMP$STATUS_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] pmp$status_queue (qid: pmt$queue_connection;
    VAR counts: pmt$queue_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$QUEUE_STATUS
*copyc OST$STATUS
*copyc PME$LOCAL_QUEUE_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$STATUS_QUEUES_DEFINED EXPAND=FALSE

  PROCEDURE [XREF] pmp$status_queues_defined (VAR count: pmt$queues_per_job;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMD$LOCAL_QUEUES
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$TASK_BEGIN EXPAND=FALSE
  PROCEDURE [XREF] pmp$task_begin;
*DECK DECK=PMP$TASK_DEBUG_MODE_ON EXPAND=FALSE

  FUNCTION [XREF] pmp$task_debug_mode_on: pmt$debug_mode;

?? PUSH (LISTEXT := ON) ??
*copyc pmt$debug_mode
?? POP ??
*DECK DECK=PMP$TASK_DEBUG_RING EXPAND=FALSE

  FUNCTION [XREF] pmp$task_debug_ring: ost$ring;

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
?? POP ??
*DECK DECK=PMP$TASK_END EXPAND=FALSE

  PROCEDURE [XREF] pmp$task_end (executing_task_id: pmt$task_id;
    parent_id: ost$global_task_id);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_ID
*copyc OST$GLOBAL_TASK_ID
?? POP ??
*DECK DECK=PMP$TASK_STATE EXPAND=FALSE

  FUNCTION [XREF] pmp$task_state: pmt$task_state;
?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_STATE
?? POP ??
*DECK DECK=PMP$TERMINATE EXPAND=FALSE

  PROCEDURE [XREF] pmp$terminate (task_id: pmt$task_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_ID
*copyc OST$STATUS
*copyc PME$EXECUTION_EXCEPTIONS
?? POP ??
*DECK DECK=PMP$TERMINATED_WHILE_INHIBITED EXPAND=FALSE

  FUNCTION [XREF] pmp$terminated_while_inhibited: boolean;

*DECK DECK=PMP$TERMINATE_FLAG_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] pmp$terminate_flag_handler (flag_id: ost$system_flag);
?? PUSH (LISTEXT := ON) ??
*copyc OST$SYSTEM_FLAG
?? POP ??
*DECK DECK=PMP$TERMINATE_POPPER EXPAND=FALSE

  PROCEDURE [XREF] pmp$terminate_popper
    (    message_status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PMP$TERMINATE_TASK_WITHOUT_WAIT EXPAND=FALSE

  PROCEDURE [XREF] pmp$terminate_task_without_wait (task_id: pmt$task_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$task_id
?? POP ??
*DECK DECK=PMP$TEST_CONDITION_HANDLER EXPAND=FALSE

  PROCEDURE [XREF] pmp$test_condition_handler (conditions: pmt$condition;
        save_area: ^ost$stack_frame_save_area;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$CONDITION
*copyc PME$CONDITION_EXCEPTIONS
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc OST$STATUS
?? POP ??
*DECK DECK=PMP$THIS_IS_A_LEAP_YEAR EXPAND=FALSE

  FUNCTION [INLINE] pmp$this_is_a_leap_year (year: integer): boolean;

?? PUSH (LISTEXT := ON) ??

    pmp$this_is_a_leap_year := (((year MOD 4) = 0) AND ((year MOD 100) <> 0) OR (year MOD 400 = 0));


  FUNCEND pmp$this_is_a_leap_year;
?? POP ??
*DECK DECK=PMP$TRAP_HANDLER EXPAND=FALSE

    PROCEDURE [XREF] pmp$trap_handler;

*DECK DECK=PMP$TS_TASK_IO_ENABLED EXPAND=FALSE

  FUNCTION [INLINE] pmp$ts_task_io_enabled: boolean;

?? PUSH (LISTEXT := ON) ??
    VAR
      tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb_p);
    pmp$ts_task_io_enabled := tcb_p^.nosve.task_io_enabled;
  FUNCEND pmp$ts_task_io_enabled;

*copyc pmt$task_control_block
*copyc pmp$find_executing_task_tcb
?? POP ??
*DECK DECK=PMP$UPDATE_JMTR_TCB_TARGET_RING EXPAND=FALSE

  PROCEDURE [XREF] pmp$update_jmtr_tcb_target_ring (
        job_monitor_initial_ring: ost$ring);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
?? POP ??
*DECK DECK=PMP$UPDATE_PROGRAM_DESCRIPTION EXPAND=FALSE

  PROCEDURE [XREF] pmp$update_program_description
    (    new_program_description: pmt$program_description);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$program_description
?? POP ??
*DECK DECK=PMP$UPDATE_TOS_RING_1 EXPAND=FALSE

  PROCEDURE [XREF] pmp$update_tos_ring_1 (top_of_stack: ^cell);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$STACK_SEGMENT
?? POP ??
*DECK DECK=PMP$UPDATE_TOS_RING_3 EXPAND=FALSE

  PROCEDURE [XREF] pmp$update_tos_ring_3 (top_of_stack: ^cell);

?? PUSH (LISTEXT := ON) ??
*copyc PMT$STACK_SEGMENT
?? POP ??
*DECK DECK=PMP$VALIDATE_PREVIOUS_SAVE_AREA EXPAND=FALSE

  PROCEDURE [XREF] pmp$validate_previous_save_area
    (    current_save_area: ^ost$stack_frame_save_area;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc pme$condition_exceptions
?? POP ??
*DECK DECK=PMP$VERIFY_COMPACT_DATE EXPAND=FALSE
  PROCEDURE [XREF] pmp$verify_compact_date
    (    date: ost$date_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$status
*copyc pme$system_time_exceptions
?? POP ??
*DECK DECK=PMP$VERIFY_COMPACT_TIME EXPAND=FALSE
  PROCEDURE [XREF] pmp$verify_compact_time
    (    time: ost$date_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc ost$status
*copyc pme$system_time_exceptions
?? POP ??
*DECK DECK=PMP$VERIFY_CURRENT_CHILD EXPAND=FALSE

  PROCEDURE [XREF] pmp$verify_current_child (task_id: pmt$task_id;
    VAR current_child {control} : boolean);
?? PUSH (LISTEXT := ON) ??
*copyc PMT$TASK_ID
?? POP ??
*DECK DECK=PMP$VERIFY_LIBRARY EXPAND=FALSE

  PROCEDURE [XREF] pmp$verify_library
   (    library_file: ^SEQ ( * );
    VAR version: string(4);
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PMP$WAIT EXPAND=FALSE

  PROCEDURE [XREF] pmp$wait
    (    requested_ms: 0 .. 0ffffffffffff(16);
         expected_ms: 0 .. 0ffffffffffff(16));

*DECK DECK=PMP$ZERO_OUT_TABLE EXPAND=FALSE
  PROCEDURE [XREF] pmp$zero_out_table
    (    p: ^cell;
         len: ost$byte_count);

?? PUSH (LISTEXT := ON) ??
*copyc ost$hardware_subranges
?? POP ??

*DECK DECK=PMP$ZERO_TS_CONDITIONS_IN_TASK EXPAND=FALSE

  FUNCTION [INLINE] pmp$zero_ts_conditions_in_task: boolean;

?? PUSH (LISTEXT := ON) ??

    VAR
      tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb_p);
    pmp$zero_ts_conditions_in_task := tcb_p^.nosve.task_condition_count = 0;
  FUNCEND pmp$zero_ts_conditions_in_task;

*copyc pmt$task_control_block
*copyc pmp$find_executing_task_tcb
?? POP ??
*DECK DECK=PMT$ADAPTABLE_SEQUENCE EXPAND=FALSE

  TYPE
    pmt$adaptable_sequence = SEQ ( * );
*DECK DECK=PMT$APD_TASK_JOBMODE_STATISTICS EXPAND=FALSE

{ ******************************************************************************
{ NOTE:  This type is used by the ASSEMBLER deck PMM$INTERCEPT_PROCEDURES.
{ If this type is changed PMM$INTERCEPT_PROCEDURES may have to be changed too,
{ otherwise ANALYZE_PROGRAM_DYNAMICS will break.
{ ******************************************************************************

  TYPE
    pmt$apd_task_jobmode_statistics = record
      jobmode_cptime: integer,
      paging_statistics: pmt$paging_statistics,
    RECEND;

*copyc pmt$loader_seq_descriptor
*DECK DECK=PMT$ASCII_LOGS EXPAND=FALSE

  TYPE
    pmt$ascii_logs = pmc$system_log .. pmc$job_log;

*copyc pmt$logs
*DECK DECK=PMT$ASCII_LOGSET EXPAND=FALSE

  TYPE
    pmt$ascii_logset = set of pmt$ascii_logs;

*copyc pmt$ascii_logs
*DECK DECK=PMT$BINARY_CPU_ATTRIBUTES EXPAND=FALSE

  TYPE
    pmt$binary_cpu_attributes = record
      highest_defined_cpu_number: 0 .. osc$maximum_processor_number,
      cpu: array [0 .. osc$maximum_processor_number] of
            pmt$binary_cpu_attribute,
    recend;

  TYPE
    pmt$binary_cpu_attribute = record
      processor_element_id: ost$processor_element_id,
      processor_state: cmt$element_state,
    recend;

*copyc cmt$element_state
*copyc osc$maximum_processor_number
*copyc ost$processor_element_id
*DECK DECK=PMT$BINARY_LOGS EXPAND=FALSE

  TYPE
    pmt$binary_logs = pmc$job_account_log .. pmc$statistic_log;

*copyc pmt$logs
*DECK DECK=PMT$BINARY_LOGSET EXPAND=FALSE

  TYPE
    pmt$binary_logset = set of pmt$binary_logs;

*copyc pmt$binary_logs
*DECK DECK=PMT$BINARY_MAINFRAME_ID EXPAND=FALSE

  TYPE
    pmt$binary_mainframe_id = record
      model_number: ost$processor_model_number,
      serial_number: ost$processor_serial_number,
    recend;

*copyc ost$processor_model_number
*copyc ost$processor_serial_number
*DECK DECK=PMT$COMMON_BLOCK_INFORMATION EXPAND=FALSE

  TYPE
    pmt$common_block_information = record
      address: ^cell,
      length: ost$segment_length,
      extensible: boolean,
      access_attributes: llt$section_access_attributes,
    recend;

*copyc OSD$VIRTUAL_ADDRESS
*copyc LLT$SECTION_ACCESS_ATTRIBUTES
*DECK DECK=PMT$COMPARISON_RESULT EXPAND=FALSE
  TYPE
    pmt$comparison_result = (pmc$left_is_greater, pmc$equal,
          pmc$right_is_greater);

*DECK DECK=PMT$CONDITION EXPAND=FALSE
{ PURPOSE
{   This type serves two purposes.  It is used to define when a condition
{   handler should be called.  Then when the handler is called, it is used to
{   describe the specific condition that occurred.
{
{ DESIGN
{
{   When defining a condition:
{     SELECTOR:  Specifies the general kind of condition for which the handler
{       should be called.  Pmt$condition_combination should be used if all
{       errors of one or more kinds are to be trapped.  The more specific
{       conditions should be used if only a subset of that kind of condition
{       is to be selected.  If a selector with a case is selected, then the
{       case fields must be set to the specific condition or conditions to be
{       trapped.
{
{       The field UNTRANSLATABLE_POINTER is not used.
{
{   When a condition occurs:
{     SELECTOR:  Specifies the general class of the condition that occurred.
{       The selectors pmc$condition_combination and pmc$all_conditions are
{       not used.  The fields for the selector give more detail on the
{       specific condition that occured.  For sets, only one element will be
{       present.
{
{     UNTRANSLATABLE_POINTER:  If a system_condition occurred this gives the
{       value of the untranslatable pointer in the exchange package.

  TYPE
    pmt$condition = record
      case selector: pmt$condition_selector of
      = pmc$system_conditions =
        system_conditions: pmt$system_conditions,
        untranslatable_pointer: ost$pva,
      = pmc$block_exit_processing =
        reason: pmt$block_exit_reason,
      = jmc$job_resource_condition =
        job_resource_condition: jmt$job_resource_condition,
      = mmc$segment_access_condition =
        segment_access_condition: mmt$segment_access_condition,
      = ifc$interactive_condition =
        interactive_condition: ift$interactive_condition,
      = pmc$pit_condition =
        ,
      = pmc$user_defined_condition =
        user_condition_name: pmt$condition_name,
      = pmc$condition_combination =
        combination: pmt$condition_combination,
      casend,
    recend,

    pmt$condition_selector = (pmc$all_conditions, pmc$system_conditions,
      pmc$block_exit_processing, jmc$job_resource_condition,
      mmc$segment_access_condition, ifc$interactive_condition,
      pmc$pit_condition, pmc$user_defined_condition,
      pmc$condition_combination),

    pmt$block_exit_reason = set of (pmc$block_exit, pmc$program_termination,
      pmc$program_abort),

    pmt$condition_combination = set of pmc$system_conditions ..
      pmc$user_defined_condition;

*copyc ift$condition_codes
*copyc jmd$job_resource_condition
*copyc mmd$segment_access_condition
*copyc osd$virtual_address
*copyc pmt$condition_name
*copyc pmt$system_conditions

*DECK DECK=PMT$CONDITION_ENVIRONMENT EXPAND=FALSE

  TYPE
    pmt$condition_environment = record
      condition: pmt$internal_condition,
      condition_descriptor: ^cell,
      condition_save_area: ^ost$stack_frame_save_area,
      debug_index: 0 .. 31,
      established_descriptor: ^pmt$established_handler,
      handler_save_area: ^ost$stack_frame_save_area,
      next_environment: ^pmt$condition_environment,
    recend;

*copyc PMT$INTERNAL_CONDITION
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc PMT$ESTABLISHED_HANDLER
*DECK DECK=PMT$CONDITION_HANDLER EXPAND=FALSE
{ PURPOSE
{   Defines the calling sequence for a condition handler.  A condition handler
{   is a procedure which is executed when a condition occurs for which it has
{   been established.
{
{ DESIGN
{   CONDITION: Information on the specific condition that occurred.  The
{     selector will one of the conditions for which the handler was established
{     and never the values pmc$condition_combination or pmc$all_conditions.
{
{   CONDITION_DESCRIPTOR: Additional information optionally provided for user
{     conditions.  The specific meaning depends upon the user condition.  This
{     is normally NIL.
{
{   SAVE_AREA: A pointer to the stack frame save area of the procedure which
{     caused the condition.  Depending on the condition, the P address in the
{     save area may be that of the instruction causing the condition or the
{     instruction following.
{
{   STATUS: This is NOT the ordinary status variable.  It MUST NOT be set to
{     NORMAL upon entry or exit or used as the status variable on any call
{     except to PMP$CONTINUE_TO_CAUSE where it MUST be used.

  TYPE
    pmt$condition_handler = ^procedure
          (    condition {input} : pmt$condition;
               condition_descriptor {input} : ^pmt$condition_information;
               save_area {input, output} : ^ost$stack_frame_save_area;
           VAR status {output} : ost$status);

*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc pmt$condition
*copyc pmt$condition_information

*DECK DECK=PMT$CONDITION_IDENTIFIER EXPAND=FALSE

  TYPE
    pmt$condition_identifier = 0 .. 255;
*DECK DECK=PMT$CONDITION_INFORMATION EXPAND=FALSE

  TYPE
    pmt$condition_information = cell;

*DECK DECK=PMT$CONDITION_NAME EXPAND=FALSE

  TYPE
    pmt$condition_name = ost$name;

*copyc osc$cycle_busy_cond
*copyc osc$data_retrieval_req_cond
*copyc osc$job_recovery_condition_name
*copyc osc$space_unavailable_condition
*copyc osc$volume_unavailable_cond
*copyc ost$name
*DECK DECK=PMT$CPU_ATTRIBUTES EXPAND=FALSE

  TYPE
    pmt$cpu_attributes = record
      highest_defined_cpu_number: 0 .. osc$maximum_processor_number,
      cpu: array [0 .. osc$maximum_processor_number] of pmt$cpu_attribute,
    recend;

  TYPE
    pmt$cpu_attribute = RECORD
      model_type: pmt$processor_model_type,
      model_number: pmt$processor_model_number,
      serial_number: pmt$processor_serial_number,
      state: pmt$processor_state,
    recend;

*copyc osc$maximum_processor_number
*copyc pmt$processor_model_number
*copyc pmt$processor_model_type
*copyc pmt$processor_serial_number
*copyc pmt$processor_state

*DECK DECK=PMT$CPU_DATA EXPAND=FALSE

  TYPE
    pmt$cpu_data = RECORD
      binary_attributes: pmt$binary_cpu_attributes,
      attributes: pmt$cpu_attributes,
      pseudo_model_number: ARRAY [0 .. osc$maximum_processor_number] OF ost$processor_model_number,
    RECEND;

*copyc pmt$binary_cpu_attributes
*copyc pmt$cpu_attributes
*copyc ost$processor_model_number
*DECK DECK=PMT$DEBUG_ENVIRONMENT EXPAND=FALSE

  TYPE
    pmt$debug_environment = record
      debug_index: 0 .. 63,
      debug_mask: ost$debug_mask,
    recend;

*copyc OST$DEBUG_MASK
*DECK DECK=PMT$DEBUG_MODE EXPAND=FALSE

  TYPE
    pmt$debug_mode = boolean;

  CONST
    pmc$debug_mode_on = TRUE,
    pmc$debug_mode_off = FALSE;
*DECK DECK=PMT$DEBUG_TABLE_INFO EXPAND=FALSE


  TYPE
    pmt$debug_table_info = record
      module_segment: mmt$segment_pointer,
      entry_point_segment: mmt$segment_pointer,
      first_module_address_table_item: ^dbt$module_address_table_item,
      last_module_item: ^^dbt$module_address_table_item,
      current_module_item: ^dbt$module_address_table_item,
      entry_point_table: ^dbt$entry_point_table,
      number_of_entry_point_items: 0 .. dbc$max_entry_point_items,
    recend,

    pmt$line_address_table_list = record
      pointer: ^llt$line_address_table,
      link: ^pmt$line_address_table_list,
    recend,

    pmt$debug_symbol_table_list = record
      pointer: ^llt$debug_symbol_table,
      link: ^pmt$debug_symbol_table_list,
    recend,

    pmt$supplemental_dtable_list = record
      pointer: ^llt$supplemental_debug_tables,
      link: ^pmt$supplemental_dtable_list,
    recend;

?? PUSH (LISTEXT := OFF) ??
*copyc llt$line_address_table
*copyc llt$debug_symbol_table
*copyc llt$supplemental_debug_tables
*copyc dbt$module_address_table_item
*copyc dbt$entry_point_table
?? POP ??
*DECK DECK=PMT$DEFAULT_PROG_OPTIONS_CHANGE EXPAND=FALSE

  TYPE
    pmt$default_prog_options_change = record
      contents: pmt$program_option_specifiers,
      map_file: amt$local_file_name,
      map_options: pmt$load_map_options,
      termination_error_level: pmt$termination_error_level,
      preset: pmt$initialization_value,
      maximum_stack_size: ost$segment_length,
      debug_input: amt$local_file_name,
      debug_output: amt$local_file_name,
      abort_file: amt$local_file_name,
      debug_mode: pmt$debug_mode,
      conditions_enabled: pmt$system_conditions,
      conditions_inhibited: pmt$system_conditions,
    recend,

    pmt$program_option_specifiers = set of pmt$program_option_specifier,

    pmt$program_option_specifier = pmc$load_map_file_specified ..
      pmc$condition_specified;

*copyc amt$local_file_name
*copyc osd$virtual_address
*copyc pmt$debug_mode
*copyc pmt$program_description
*DECK DECK=PMT$DELAYED_CONDITION EXPAND=FALSE
  TYPE
    pmt$delayed_condition = record
      next_delayed_condition: ^ {BOUND} pmt$delayed_condition,
      case delayed_condition: (debug, job_resource, interactive,
            process_interval_timer, user_condition) of
      = debug =
        condition: pmt$internal_condition,
        condition_save_area: ost$stack_frame_save_area,
        debug_index: 0 .. 31,
      = job_resource =
        job_resource_condition: jmt$job_resource_condition,
      = interactive =
        interactive_condition: ift$interactive_condition,
      = user_condition =
        user_defined: pmt$condition_name,
        propagate_info: pmt$propagate_info,
        condition_descriptor: ^pmt$condition_information,
      = process_interval_timer =
        ,
      casend,
    recend;

*copyc ost$stack_frame_save_area
*copyc pmt$condition_information
*copyc pmt$condition_name
*copyc pmt$internal_condition
*DECK DECK=PMT$END_HANDLER EXPAND=FALSE

 TYPE
    pmt$end_handler = ^procedure (termination_status: ost$status;
      VAR status: ost$status);

?? PUSH ( LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PMT$END_HANDLER_DESC EXPAND=FALSE

 TYPE
    pmt$end_handler_ring_list = array [osc$min_ring .. osc$max_ring] of
      ^pmt$end_handler_desc,

    pmt$end_handler_desc = record
      link: ^pmt$end_handler_desc,
      end_handler: pmt$end_handler,
      disestablished: boolean,
      called: boolean,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc pmt$end_handler
?? POP ??
*DECK DECK=PMT$ENTRY_POINT_REFERENCE EXPAND=FALSE

  TYPE
    pmt$entry_point_reference = record
      entry_point: pmt$program_name,
      object_library: fst$path,
    recend;

*copyc fst$path
*copyc pmt$program_name
*DECK DECK=PMT$ESTABLISHED_HANDLER EXPAND=FALSE
{ PURPOSE
{
{   Defines a condition handler procedure and the conditions for which it
{   should be invoked.  Since a procedure may have multiple handlers, each for
{   multiple conditions, these records are linked together in a stack.  The on
{   condition flag in the stack frame is used to show the presence of one or
{   more established handlers.  If block exit processing is selected then the
{   critical frame flag is also set in the stack frame.
{
{ DESIGN
{   ESTABLISHED: Signifies that the condition has not been disestablished.
{
{   EST_HANDLER_STACK:  Link to the next handler in the condition stack.
{
{   HANDLER:  Pointer to the condition handler routine to be invoked when
{     the condition or conditions defined in ESTABLISHED_CONDITIONS occur.
{
{   ESTABLISHED_CONDITIONS:  What conditions the handler has been established
{     for.
{
{   HANDLER_ACTIVE:  Defines which system or segment access conditions the
{     handler is currently processing.  If an attempt is made to call the
{     handler with a condition already being processed by the handler then
{     the task is aborted by calling PMP$EXIT.

{ NOTE:
{   If this type changes, the procedure pmp$intercept_call_procedure in
{   pmm$intercept_procedures which establishes its own block exit condition
{   handler must also be changed.

  TYPE
    pmt$established_handler = record
      established: boolean,
      est_handler_stack: ^pmt$established_handler,
      handler: pmt$condition_handler,
      established_conditions: pmt$condition,
      handler_active: pmt$condition_handler_active,
    recend,

    pmt$condition_handler_active = record
      system: pmt$system_conditions,
      segment_access: mmt$segment_access_condition,
    recend;

*copyc pmt$condition
*copyc pmt$condition_handler
*DECK DECK=PMT$ESTABLISHED_HANDLER_INTERNL EXPAND=FALSE
{ PURPOSE
{   This type defines detail about the type pmt$established_handler which we do
{   not wish to show on the program interface.
{
{ DESIGN
{   For now, the only information in this type is an expanded definition of the
{   first byte which in the externalized type contains the boolean ESTABLISHED.
{   This expands this byte to allow seven additional flags with the following
{   meanings.
{
{   ESTABLISHED_OUTSIDE_BLOCK specifies that the handler was established with
{     the request pmp$establish_ch_outside_block and thus the descriptor could
{     reside anywhere.  If this flag is not set then the handler must be in the
{     stack.
{
{   HANDLER_ESTABLISHED specifies that the handler has been established and not
{     disestablished.  This corresponds with the ESTABLISHED flag in the
{     externalized type.

  TYPE
    pmt$established_handler_internl = packed record
      established_outside_block: boolean,
      unused_flag1: boolean,
      unused_flag2: boolean,
      unused_flag3: boolean,
      unused_flag4: boolean,
      unused_flag5: boolean,
      unused_flag6: boolean,
      handler_established: boolean,
    recend;
*DECK DECK=PMT$EXT_DEFAULT_COND_HANDLER EXPAND=FALSE

{ This Type describes the interface from Program Management to a
{ DEFAULT CONDition HANDLER supplied EXTernally from the OS.

  TYPE
    pmt$ext_default_cond_handler = procedure
          (    condition: pmt$condition;
               system_default_handler: ^pmt$sys_default_cond_handler;
           VAR status: ost$status);

*copyc ost$status
*copyc pmt$condition
*copyc pmt$sys_default_cond_handler
*DECK DECK=PMT$FAMILY_NAME_COUNT EXPAND=FALSE

  TYPE
    pmt$family_name_count = 0 .. pmc$family_name_count_maximum;

  CONST
    pmc$family_name_count_maximum = 255;

{ NOTE: The constant pmc$family_name_count_maximum is arbitrary
*DECK DECK=PMT$FAMILY_NAME_LIST EXPAND=FALSE

  TYPE
    pmt$family_name_list = ARRAY [1 .. *] OF ost$name;

*copyc ost$name

*DECK DECK=PMT$GLOBAL_BINARY_LOGS EXPAND=FALSE

  TYPE
    pmt$global_binary_logs = pmc$account_log .. pmc$statistic_log;

*copyc pmt$logs
*DECK DECK=PMT$GLOBAL_BINARY_LOGSET EXPAND=FALSE

  TYPE
    pmt$global_binary_logset = set of pmt$global_binary_logs;

*copyc pmt$global_binary_logs
*DECK DECK=PMT$GLOBAL_LOGS EXPAND=FALSE

  TYPE
    pmt$global_logs = pmc$account_log .. pmc$system_log;

*copyc pmt$logs
*DECK DECK=PMT$GLOBAL_LOGSET EXPAND=FALSE

  TYPE
    pmt$global_logset = set of pmt$global_logs;

*copyc pmt$global_logs
*DECK DECK=PMT$INITIALIZATION_VALUE EXPAND=FALSE

  TYPE
    pmt$initialization_value = (pmc$initialize_to_zero,
      pmc$initialize_to_alt_ones, pmc$initialize_to_indefinite,
      pmc$initialize_to_infinity);

*DECK DECK=PMT$INTERNAL_CONDITION EXPAND=FALSE

  TYPE
    pmt$condition_class = pmc$system_conditions .. pmc$user_defined_condition,

    pmt$propagate_info = record
      scope: (pmc$current_ring, pmc$current_task),
      notify_debug: boolean,
      notify_scl: boolean,
      call_default_handler: boolean,
      propagate_to_parent: boolean,
    recend,

    pmt$internal_condition = record
      case class: pmt$condition_class of
      = pmc$system_conditions =
        system: pmt$system_condition,
        untranslatable_pointer: ost$pva,
      = pmc$block_exit_processing =
        reason: pmt$block_exit_reason,
      = jmc$job_resource_condition =
        job_resource: jmt$job_resource_condition,
      = mmc$segment_access_condition =
        segment_access: mmt$segment_access_condition,
      = ifc$interactive_condition =
        interactive: ift$interactive_condition,
      = pmc$pit_condition =
        ,
      = pmc$user_defined_condition =
        user_defined: pmt$condition_name,
        propagate_info: pmt$propagate_info,
      casend,
    recend;

*copyc PMT$CONDITION
*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=PMT$JOB_LOG_ENTRY EXPAND=FALSE

  TYPE
    pmt$job_log_entry = packed record
      time: ost$millisecond_time,
      delimiter_1: string (1),
      origin: string (2),
      delimiter_2: string (1),
      text: pmt$log_msg_text,
    recend;

*copyc ost$time
*copyc pmt$log_msg_text
*DECK DECK=PMT$JOB_TASK_STATISTICS EXPAND=FALSE

  CONST
    pmc$cpu_time_maximum = 07fffffffffffffff(16),
    pmc$ready_task_count = 0ffff(16),
    pmc$working_set_size = 0ffffff(16);

  TYPE
    pmt$cpu_time = 0 .. pmc$cpu_time_maximum,
    pmt$ready_task_count = 0 .. pmc$ready_task_count,
    pmt$working_set_size = 0 .. pmc$working_set_size;

  TYPE
    pmt$paging_statistics = record
      page_in_count: 0 .. 0ffffffff(16),
      pages_reclaimed_from_queue: 0 .. 0ffffffff(16),
      new_pages_assigned: 0 .. 0ffffffff(16),
      pages_from_server:  0 .. 0ffffffff(16),
      page_fault_count:   0 .. 0ffffffffffff(16),
      working_set_max_used: 0 .. 0ffffff(16),
    recend;

  TYPE
    pmt$job_task_statistics = record
      case key: pmt$job_task_statistics_key of
      = pmc$jts_job_cpu =
        job_cpu_time: pmt$cpu_time,
      = pmc$jts_job_job_cpu =
        job_job_cpu_time: pmt$cpu_time,
      = pmc$jts_job_monitor_cpu =
        job_monitor_cpu_time: pmt$cpu_time,
      = pmc$jts_null_statistic =
        ,
      = pmc$jts_paging_statistics =
        paging_statistics: pmt$paging_statistics,
      = pmc$jts_ready_task_count =
        ready_task_count: pmt$ready_task_count,
      = pmc$jts_task_cpu =
        task_cpu_time: pmt$cpu_time,
      = pmc$jts_task_job_cpu =
        task_job_cpu_time: pmt$cpu_time,
      = pmc$jts_task_monitor_cpu =
        task_monitor_cpu_time: pmt$cpu_time,
      = pmc$jts_working_set_size =
        working_set_size: pmt$working_set_size,
      casend,
    recend;

  TYPE
    pmt$job_task_statistics_key = (pmc$jts_job_cpu, pmc$jts_job_job_cpu,
          pmc$jts_job_monitor_cpu, pmc$jts_null_statistic,
          pmc$jts_paging_statistics, pmc$jts_ready_task_count,
          pmc$jts_task_cpu, pmc$jts_task_job_cpu, pmc$jts_task_monitor_cpu,
          pmc$jts_working_set_size);

*DECK DECK=PMT$LINKER_DEBUG_TABLE_HEADER EXPAND=FALSE
  TYPE
    pmt$linker_debug_table_header = record
      version: pmt$linker_debug_table_version,
      build_level: pmt$os_name,
      date: ost$date,
      time: ost$time,
      number_of_modules: pmt$number_of_debug_items,
      first_module_address_table_item: REL (pmt$adaptable_sequence)
             ^pmt$module_item,
      number_of_entry_points: pmt$number_of_debug_items,
      entry_point_items: REL (pmt$adaptable_sequence) ^pmt$entry_point_items,
      number_of_addresses: pmt$number_of_debug_items,
      address_items: REL (pmt$adaptable_sequence) ^pmt$address_items,
    recend;

 CONST
    pmc$linker_debug_table_version = 'LDT_V0.2',
    pmc$maximum_debug_items = 0ffffffff(16);

  TYPE
    pmt$linker_debug_table_version = string (8),
    pmt$number_of_module_addr_items = pmt$number_of_debug_items,
    pmt$number_of_debug_items = 0 .. pmc$maximum_debug_items,
    pmt$entry_point_items = array [1 .. *] of pmt$entry_point_item,
    pmt$address_items = array [1 .. *] of pmt$address_item;

  TYPE
    pmt$module_item = record
      identification: llt$identification,
      next_module: REL (pmt$adaptable_sequence) ^pmt$module_item,
      number_of_line_address_tables: pmt$number_of_debug_items,
      line_address_tables: REL (pmt$adaptable_sequence) ^array [0 .. *] of
              ^llt$line_address_table,
      number_of_debug_symbol_tables: pmt$number_of_debug_items,
      debug_symbol_tables: REL (pmt$adaptable_sequence) ^array [0 .. *] of
              ^llt$debug_symbol_table,
      section_item: array [0 .. *] of pmt$section_item,
    recend;

  TYPE
    pmt$section_item = record
      kind: llt$section_kind,
      section_ordinal: llt$section_ordinal,
      address: pmt$segment_and_offset,
      length: ost$segment_length,
      segment_access_control: ost$segment_access_control,
      ring: pmt$ring_attributes,
      key_lock: ost$key_lock,
      name: pmt$program_name,
    recend;

  TYPE
    pmt$ring_attributes = record
      r1: ost$ring,
      r2: ost$ring,
      r3: ost$ring,
    recend;

  TYPE
    pmt$entry_point_item = record
      name: pmt$program_name,
      address: pmt$segment_and_offset,
    recend;

  TYPE
    pmt$address_item = record
      segment_offset: pmt$segment_and_offset,
      module_item: REL (pmt$adaptable_sequence) ^pmt$module_item,
      from_an_entry_point: boolean,
    recend;

  TYPE
    pmt$segment_and_offset = 0 .. 0fffffffffff(16);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$os_name
*copyc llt$identification
*copyc llt$section_address
*copyc llt$section_kind
*copyc osd$virtual_address
*copyc ost$segment_access_control
*copyc llt$line_address_table
*copyc llt$debug_symbol_table
*copyc pmt$adaptable_sequence
?? POP ??
*DECK DECK=PMT$LOADABLE_RINGS EXPAND=FALSE

  TYPE
    pmt$loadable_rings = set of pmt$loadable_ring,
    pmt$loadable_ring = ost$valid_ring;

*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=PMT$LOADED_ADDRESS EXPAND=FALSE


  TYPE
    pmt$loaded_address = record
      case kind: pmt$loaded_address_kind of
      = pmc$procedure_address =
        pointer_to_procedure: ^procedure,
      = pmc$data_address =
        pointer_to_data: ^cell,
      casend,
    recend,

    pmt$loaded_address_kind = (pmc$procedure_address, pmc$data_address);
*DECK DECK=PMT$LOADER_SEQ_DESCRIPTOR EXPAND=FALSE

{ ******************************************************************************
{ NOTE:  Some of the types in this deck are used by the ASSEMBLER deck
{ PMM$INTERCEPT_PROCEDURES.  If these types are changed PMM$INTERCEPT_PROCEDURES
{ may have to be upgraded too or ANALYZE_PROGRAM_DYNAMICS will break.
{ ******************************************************************************

  CONST
    mpe_remote_module_name = '{** REMOTE_MODULE **}',
    mpe_utility_name = 'MEASURE_PROGRAM_EXECUTION      ',
    mpe_prompt_string = 'MPE',
    mpe_verification_header = 'MPE1';


  TYPE
    pmt$loader_seq_descriptor = record
      seq_ptr: ^SEQ ( * ),
      mpe_aborted: boolean,
      file_id: amt$file_identifier,
      block_name_map_exists: boolean,
      local_block_id: pmt$block_id,
      remote_block_id: pmt$block_id,
      remote_block_name_map: ^array [0 .. * ] of pmt$block_name_map_entry,
      local_block_name_map: ^array [0 .. * ] of pmt$block_name_map_entry,
      first_interblock_segment_name:  amt$local_file_name,
      last_interblock_segment:  ^SEQ ( * ),
      number_of_interblock_segments: 1 .. 0fff(16),
      accumulated_intercept_time: pmt$reference_time,
      max_segment_length: 0 .. 7fffffff(16),
      number_of_intercepted_calls: pmt$number_of_interblock_refs,
      number_of_intercepted_returns: pmt$number_of_interblock_refs,
      accum_intercept_call_time: pmt$reference_time,
      accum_intercept_return_time: pmt$reference_time,
      average_intercept_call_time: pmt$reference_time,
      average_intercept_return_time: pmt$reference_time,
      average_stats_request_time: pmt$reference_time,
      timed_call_overhead: pmt$reference_time,
      timed_return_overhead: pmt$reference_time,
      untimed_call_overhead: pmt$reference_time,
      untimed_return_overhead: pmt$reference_time,
      average_null_procedure_time: pmt$reference_time,
    recend,

    pmt$interblock_references_hdr = record
      file_id: amt$file_identifier,
      number_of_interblock_references: pmt$number_of_interblock_refs,
      next_segment_file_name: amt$local_file_name,
    recend,

    pmc$interblock_references = SEQ ( * ),

    pmt$mpe_seq_descriptor = record
      seq_ptr: ^SEQ ( * ),
      creation_date: string (8),
      number_of_runs: 0 .. 0ffff(16),
      local_execution_time_totals: ^array [0 .. * ] of
        pmt$execution_time_totals,
      remote_execution_time_totals: ^array [0 .. * ] of
        pmt$execution_time_totals,
      connectivity_matrix: ^array [0 .. * ] of 0 .. 0ffffff(16),
      intercolumn_bond_matrix: ^array [1 .. * ] of 0 .. 0ffffffff(16),
    recend,

    pmt$mpe_environment_descriptor = record
      verification_header: string (4),
      creation_date: string (8),
      number_of_runs: 0 .. 0ffff(16),
      number_of_local_blocks: pmt$block_id,
      number_of_remote_blocks: pmt$block_id,
      target_text_path_name: clt$path_name,
      saved_environment: pmt$environment_contents,
      program_description_size: 0 .. osc$max_segment_length,
      program_description: ^llt$program_description,
    recend,


    pmt$number_of_interblock_refs = 0 .. 0ffffffff(16),


    pmt$block_name_map_entry = record
      module_name: pmt$program_name,
      section_ordinal: llt$section_ordinal,
      procedure_name: pmt$program_name,
    recend,



    pmt$execution_time_totals = record
      block_total: integer,
      remote_total: integer,
      block_paging_total: pmt$paging_statistics,
      remote_paging_total: pmt$paging_statistics,
      number_of_calls: 0 .. 0ffffffff(16),
    recend,


    pmt$interblock_reference = record
      reference_type: pmt$reference,
      reference_time: pmt$reference_time,
      block_id: pmt$block_identifier,
      page_fault_stats: pmt$paging_statistics,
    recend,

    pmt$reference_time = 0 .. 7fffffffffff(16),


    pmt$reference = (pmc$call, pmc$return, pmc$pop, pmc$final_return),

    pmt$paging_statistics = record
      page_in_count: 0 .. 0ffffffff(16),
      pages_reclaimed_from_queue: 0 .. 0ffffffff(16),
      new_pages_assigned: 0 .. 0ffffffff(16),
      page_fault_count:   0 .. 0ffffffffffff(16),
    recend,

    pmt$block_statistic = record
      link: ^pmt$block_statistic,
      block_id: pmt$block_identifier,
      call_time: pmt$reference_time,
      subordinate_time: pmt$reference_time,
      paging_stats: pmt$paging_statistics,
      subordinate_paging_stats: pmt$paging_statistics,
      pop_count: integer,
    recend,


    pmt$candidate_list = record
      local_block_id: pmt$block_id,
      cluster_merit: integer,
      best_position: ^pmt$candidate_list,
      link: ^pmt$candidate_list,
    recend,


    pmt$working_set_block_reference = record
      block_number: pmt$block_id,
      reference_time: pmt$reference_time,
      link: ^pmt$working_set_block_reference,
    recend,


    pmt$block_identifier = record
      local: boolean,
      block_number: pmt$block_id,
    recend,


    pmt$loader_description = record
      apd_load: boolean,
      target_text: clt$file,
      mpe_loader_seq: amt$local_file_name,
    recend,


    pmt$block_id = 0 .. 07fffffff(16),


    pmt$number_of_block_entries = record
      remote: pmt$block_id,
      local: pmt$block_id,
    recend,


    pmt$environment_contents = set of pmt$environment_content,

    pmt$environment_content = (pmc$connectivity_matrix,
      pmc$execution_time_totals),


    pmt$procedures = (pmc$all, pmc$local, pmc$remote),

    pmt$profile_order = (pmc$module_procedure, pmc$procedure, pmc$time);

*copyc PMT$PROGRAM_NAME
*copyc AMT$LOCAL_FILE_NAME
*copyc AMT$FILE_IDENTIFIER
*copyc CLT$FILE
*copyc LLT$PROGRAM_DESCRIPTION
*copyc llt$section_address
*DECK DECK=PMT$LOCAL_BINARY_LOGS EXPAND=FALSE

  TYPE
    pmt$local_binary_logs = pmc$job_account_log .. pmc$job_statistic_log;

*copyc pmt$logs
*DECK DECK=PMT$LOCAL_BINARY_LOGSET EXPAND=FALSE

  TYPE
    pmt$local_binary_logset = set of pmt$local_binary_logs;

*copyc pmt$local_binary_logs
*DECK DECK=PMT$LOGS EXPAND=FALSE

  TYPE
    pmt$logs = (pmc$job_account_log, pmc$job_statistic_log, pmc$account_log,
          pmc$engineering_log, pmc$history_log, pmc$security_log,
          pmc$statistic_log, pmc$system_log, pmc$job_log);

*DECK DECK=PMT$LOGSET EXPAND=FALSE

  TYPE
    pmt$logset = set of pmt$logs;

*copyc pmt$logs
*DECK DECK=PMT$LOG_MSG_ORIGIN EXPAND=FALSE

  TYPE
    pmt$log_msg_origin = (pmc$msg_origin_command, pmc$msg_origin_system,
          pmc$msg_origin_program, pmc$msg_origin_command_skip,
          pmc$msg_origin_recovery);

*DECK DECK=PMT$LOG_MSG_TEXT EXPAND=FALSE

  TYPE
    pmt$log_msg_text = string ( * );

*DECK DECK=PMT$MAINFRAME_ATTRIBUTE EXPAND=FALSE
  TYPE
    pmt$mainframe_attribute = record
      case key: pmt$mainframe_attribute_keys of
      = pmc$mak_active_processors =
        active_processors: pmt$number_of_processors,
      = pmc$mak_mainframe_identifier =
        mainframe_identifier: pmt$mainframe_id,
      = pmc$mak_microsecond_clock =
        microsecond_clock: integer,
      = pmc$mak_page_size =
        page_size: ost$page_size,
      = pmc$mak_total_processors =
        total_processors: pmt$number_of_processors,
      = pmc$mak_vector_capability =
        vector_capability: pmt$vector_capability,
      = pmc$mak_vectors_degraded =
        vectors_degraded: pmt$vector_degrade_state,
      = pmc$mak_vector_simulation =
        vector_simulation: pmt$vector_simulation,
      = pmc$mak_null_attribute = { This is unused. It is here for
        null_attribute: ost$name, { compatibility for future variants.
      casend,
    recend;

*copyc ost$name
*copyc ost$page_size
*copyc pmt$mainframe_attribute_keys
*copyc pmt$mainframe_id
*copyc pmt$number_of_processors
*copyc pmt$vector_capability
*copyc pmt$vector_degrade_state
*copyc pmt$vector_simulation
*DECK DECK=PMT$MAINFRAME_ATTRIBUTES EXPAND=FALSE
  TYPE
    pmt$mainframe_attributes = array [1 .. * ] of pmt$mainframe_attribute;

*copyc pmt$mainframe_attribute

*DECK DECK=PMT$MAINFRAME_ATTRIBUTE_KEYS EXPAND=FALSE
  TYPE
    pmt$mainframe_attribute_keys = 0 .. pmc$max_mainframe_attr_index;

  CONST
    pmc$mak_unknown_attribute = 0,
    pmc$mak_active_processors = 100,
    pmc$mak_microsecond_clock = 200,
    pmc$mak_mainframe_identifier = 300,
    pmc$mak_page_size = 400,
    pmc$mak_total_processors = 500,
    pmc$mak_vector_capability = 600,
    pmc$mak_vectors_degraded = 700,
    pmc$mak_vector_simulation = 800,
    pmc$mak_null_attribute = 900,

    pmc$max_mainframe_attr_index = 1000;

*DECK DECK=PMT$MAINFRAME_ID EXPAND=FALSE

{ The mainframe identifier is of the form $SYSTEM_MMMM_NNNN where MMMM is
{ the model number number of CPU 0 and NNNN is the serial number of cpu 0.

  TYPE
    pmt$mainframe_id = STRING (pmc$mainframe_id_size);

  CONST
    pmc$mainframe_id_size = 9 + pmc$processor_model_number_size +
          pmc$processor_serial_num_size;

  CONST
    pmc$null_mainframe_id = '$SYSTEM_0000_0000';

*copyc pmt$processor_model_number
*copyc pmt$processor_serial_number
*DECK DECK=PMT$MAX_NUMBER_OF_TASKS EXPAND=FALSE


  TYPE
    pmt$max_number_of_tasks = 0 .. pmc$max_number_of_tasks;


{  The following number is based on the maximum number of segment descriptors
{  available in the segment table that can be available for assignment as
{  shared stacks.

  CONST
    pmc$max_number_of_tasks = 4000;
*DECK DECK=PMT$MINIMUM_SAVE_AREA EXPAND=FALSE

  TYPE
    pmt$minimum_save_area = packed record
      p_register: ALIGNED [0 MOD 8] ost$p_register,
      vmid: ost$virtual_machine_identifier,
      undefined: 0 .. 0fff(16),
      a0_dynamic_space_pointer: ALIGNED [2 MOD 8] ost$pva,
      frame_descriptor: ost$frame_descriptor,
      a1_current_stack_frame: ALIGNED [2 MOD 8] ^pmt$os_stack_frame_word,
      user_mask: ost$user_conditions,
      a2_previous_save_area: ALIGNED [2 MOD 8] ^pmt$minimum_save_area,
    recend;

*copyc ost$stack_frame_save_area
*copyc pmt$os_stack_frame_word
*DECK DECK=PMT$NUMBER_OF_PROCESSORS EXPAND=FALSE
  TYPE
    pmt$number_of_processors = 0 .. pmc$maximum_processor_number;

  CONST
    pmc$maximum_processor_number = 15;

*DECK DECK=PMT$OBJECT_LIBRARY_ADDRESS EXPAND=FALSE

  TYPE
    pmt$object_library_address = record
      case kind: llt$library_module_kind of
      = llc$load_module =
        load_module: ^llt$object_module,
      = llc$ppu_object_module =
        ppu_object_module: ^llt$object_module,
      = llc$program_description =
        program_description: ^llt$program_description,
      = llc$command_procedure, llc$function_procedure =
        scl_procedure: ^clt$scl_procedure,
      = llc$command_description =
        command_description: ^llt$command_description,
      = llc$function_description =
        function_description: ^llt$function_description,
      = llc$message_module =
        message_module: ^ost$message_template_module,
      = llc$panel_module =
        panel_module: ^SEQ ( * ),
      casend,
    recend;

  TYPE
    llt$object_module = SEQ ( * );

*copyc clt$scl_procedure
*copyc llt$command_description
*copyc llt$function_description
*copyc llt$library_module_kind
*copyc llt$program_description
*copyc ost$message_template_module
*DECK DECK=PMT$OS_NAME EXPAND=FALSE

  CONST
    pmc$os_name_size = 22;

  TYPE
    pmt$os_name = string (pmc$os_name_size);
*DECK DECK=PMT$OS_STACK_FRAME_WORD EXPAND=FALSE

{  This deck defines the format of the first word of every NOS/VE stack frame.

{ NOTE:
{   If this type changes, the procedure pmp$intercept_call_procedure in
{   pmm$intercept_procedures which establishes its own block exit condition
{   handler must also be changed.

  TYPE
    pmt$os_stack_frame_word = packed record
      established_handler: ^pmt$established_handler,
      terminate_inhibit_frame: boolean,
      block_exit_frame: boolean,
      debug_cff_frame: boolean,
      ada_critical_frame: boolean,
      ada_critical_frame_count: 0 .. pmc$max_number_of_tasks,
    recend;

*copyc pmt$established_handler
*copyc pmt$max_number_of_tasks
*DECK DECK=PMT$PIT_VALUE EXPAND=FALSE

  TYPE
    pmt$pit_value = pmc$minimum_pit_value .. pmc$maximum_pit_value;

  CONST
    pmc$minimum_pit_value = 1000,
    pmc$maximum_pit_value = 7fffffff(16);

*DECK DECK=PMT$PROCESSOR_ATTRIBUTES EXPAND=FALSE

  TYPE
    pmt$processor_attributes = record
      model_number: pmt$cpu_model_number,
      serial_number: pmt$cpu_serial_number,
      page_size: ost$page_size,
    recend,

    pmt$processor = record
      serial_number: pmt$cpu_serial_number,
      model_number: pmt$cpu_model_number,
    recend;

  TYPE
    pmt$cpu_model_number = (pmc$cpu_model_p1, pmc$cpu_model_p2,
      pmc$cpu_model_p3, pmc$cpu_model_p4),

    pmt$cpu_serial_number = 0 .. 0ffff(16);

*copyc OST$PAGE_SIZE
*DECK DECK=PMT$PROCESSOR_DESCRIPTION EXPAND=FALSE
 TYPE
    pmt$processor_description = record
      id: ost$logical_processor_id,
      element_id: ost$cpu_element_id,
      state: cmt$element_state,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ost$cpu_definitions
*copyc cmt$element_state
?? POP ??
*DECK DECK=PMT$PROCESSOR_DESCRIPTIONS EXPAND=FALSE
 TYPE
    pmt$processor_descriptions = record
      count: 1 .. osc$max_number_of_processors,
      processor: array [0 .. osc$max_number_of_processors - 1] of
        pmt$processor_description,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc osc$multiprocessor_constants
*copyc pmt$processor_description
?? POP ??
*DECK DECK=PMT$PROCESSOR_MODEL_NUMBER EXPAND=FALSE

{ NOTE:
{   If model numbers are added or removed for vector processors from
{   the list of processor model numbers, the deck RAP$INSTALL_LIB99 and
{   RAP$INSTALL_MATH_LIBRARY must also be updated.

  TYPE
    pmt$processor_model_number = STRING (pmc$processor_model_number_size);

  CONST
    pmc$processor_model_number_size = 4;

  CONST
    pmc$cyber_180_model_unknown = '0000',
    pmc$cyber_180_model_815     = '815 ',
    pmc$cyber_180_model_825     = '825 ',
    pmc$cyber_180_model_830     = '830 ',
    pmc$cyber_180_model_810     = '810 ',
    pmc$cyber_180_model_835     = '835 ',
    pmc$cyber_180_model_855     = '855 ',
    pmc$cyber_180_model_845     = '845 ',
    pmc$cyber_180_model_860     = '860 ',
    pmc$cyber_180_model_850     = '850 ',
    pmc$cyber_180_model_840     = '840 ',
    pmc$cyber_180_model_845S    = '845S',
    pmc$cyber_180_model_855S    = '855S',
    pmc$cyber_180_model_840S    = '840S',
    pmc$cyber_900_model_9603    = '9603',
    pmc$cyber_900_model_9601    = '9601',
    pmc$cyber_900_model_960d    = '9603',   { Soviet Nuclear Safety System.
    pmc$cyber_900_model_960c    = '9601',   { Soviet Nuclear Safety System.
    pmc$cyber_180_model_990     = '990 ',
    pmc$cyber_180_model_990E    = '990E',
    pmc$cyber_900_model_992     = '9923',
    pmc$cyber_900_model_992a    = '9923',   { China Weather System.
    pmc$cyber_900_model_994     = '9943',
    pmc$cyber_2000_model_20s1   = '20S1',   { CPU 46, CM 46, IOU 46.
    pmc$cyber_2000_model_20u1   = '20U1',   { CPU 48, CM 46, IOU 46.
    pmc$cyber_2000_model_20v1   = '20V1',   { CPU 48, CM 48, IOU 46.
    pmc$cyber_180_model_930D    = '930D',
    pmc$cyber_180_model_9303    = '9303',
    pmc$cyber_180_model_9301    = '9301',
    pmc$cyber_900_model_9323    = '9323',
    pmc$cyber_900_model_9321    = '9321',
    pmc$cyber_180_model_930A    = '930A',
    pmc$cyber_900_model_932A    = '932A',
    pmc$cyber_180_model_930B    = '930B',
    pmc$cyber_180_model_930C    = '930C',
    pmc$cyber_900_model_932B    = '932B',

    pmc$cyber_900_model_9703    = '9703',   { CPU 3A, CM 35, IOU 40.
    pmc$cyber_900_model_9701    = '9701',   { CPU 3B, CM 35, IOU 40.
    pmc$cyber_900_model_970d    = '9703',   { CPU 3C, CM 35, IOU 40; Soviet.
    pmc$cyber_900_model_970c    = '9701',   { CPU 3D, CM 35, IOU 40; Soviet.
    pmc$cyber_900_model_9723    = '9723',   { CPU 3A, CM 35, IOU 44.
    pmc$cyber_900_model_9721    = '9721',   { CPU 3B, CM 35, IOU 44.
    pmc$cyber_900_model_972d    = '9723',   { CPU 3C, CM 35, IOU 44; Soviet.
    pmc$cyber_900_model_972c    = '9721';   { CPU 3D, CM 35, IOU 44; Soviet.

  CONST
    pmc$cyber_180_model_992     = '9923',   { Retained for compatibility only.
    pmc$cyber_180_model_994     = '9943',   { Retained for compatibility only.
    pmc$cyber_180_model_9321    = '9321',   { Retained for compatibility only.
    pmc$cyber_180_model_9323    = '9323',   { Retained for compatibility only.
    pmc$cyber_180_model_932A    = '932A',   { Retained for compatibility only.
    pmc$cyber_180_model_932B    = '932B',   { Retained for compatibility only.
    pmc$cyber_180_model_9601    = '9601',   { Retained for compatibility only.
    pmc$cyber_180_model_9603    = '9603';   { Retained for compatibility only.
*DECK DECK=PMT$PROCESSOR_MODEL_TYPE EXPAND=FALSE

  TYPE
    pmt$processor_model_type = string (pmc$processor_model_type_size);

  CONST
    pmc$processor_model_type_size = 20;

  CONST
    pmc$cyber_180_model_810_class    = 'CYBER 810 Class     ',
    pmc$cyber_180_model_815_class    = 'CYBER 815 Class     ',
    pmc$cyber_180_model_825_class    = 'CYBER 825 Class     ',
    pmc$cyber_180_model_830_class    = 'CYBER 830 Class     ',

    pmc$cyber_180_model_835_class    = 'CYBER 835 Class     ',

    pmc$cyber_180_model_840_class    = 'CYBER 840 Class     ',
    pmc$cyber_180_model_840s_class   = 'CYBER 840S Class    ',
    pmc$cyber_180_model_845_class    = 'CYBER 845 Class     ',
    pmc$cyber_180_model_845s_class   = 'CYBER 845S Class    ',
    pmc$cyber_180_model_850_class    = 'CYBER 850 Class     ',
    pmc$cyber_180_model_855_class    = 'CYBER 855 Class     ',
    pmc$cyber_180_model_855s_class   = 'CYBER 855S Class    ',
    pmc$cyber_180_model_860_class    = 'CYBER 860 Class     ',
    pmc$cyber_180_model_870_class    = 'CYBER 870 Class     ',

    pmc$cyber_900_model_96011_class  = 'CYBER 960-11 Class  ',
    pmc$cyber_900_model_96031_class  = 'CYBER 960-31 Class  ',
    pmc$cyber_900_model_96032_class  = 'CYBER 960-32 Class  ',
    pmc$cyber_900_model_97011_class  = 'CYBER 970-11 Class  ',
    pmc$cyber_900_model_97031_class  = 'CYBER 970-31 Class  ',
    pmc$cyber_900_model_97032_class  = 'CYBER 970-32 Class  ',
    pmc$cyber_900_model_97211_class  = 'CYBER 972-11 Class  ',
    pmc$cyber_900_model_97231_class  = 'CYBER 972-31 Class  ',
    pmc$cyber_900_model_97232_class  = 'CYBER 972-32 Class  ',

    pmc$cyber_180_model_990_class    = 'CYBER 990 Class     ',
    pmc$cyber_900_model_99231_class  = 'CYBER 992-31 Class  ',
    pmc$cyber_900_model_99232_class  = 'CYBER 992-32 Class  ',
    pmc$cyber_900_model_99431_class  = 'CYBER 994-31 Class  ',
    pmc$cyber_900_model_99432_class  = 'CYBER 994-32 Class  ',
    pmc$cyber_180_model_995_class    = 'CYBER 995 Class     ',

    pmc$cyber_2000_model_20s1_class  = 'CYBER 2000S-1 Class ',
    pmc$cyber_2000_model_20s2_class  = 'CYBER 2000S-2 Class ',
    pmc$cyber_2000_model_20u1_class  = 'CYBER 2000U-1 Class ',
    pmc$cyber_2000_model_20u2_class  = 'CYBER 2000U-2 Class ',
    pmc$cyber_2000_model_20v1_class  = 'CYBER 2000V-1 Class ',
    pmc$cyber_2000_model_20v2_class  = 'CYBER 2000V-2 Class ',

    pmc$cyber_180_model_930a_class   = 'CYBER 930-A Class   ',
    pmc$cyber_180_model_930b_class   = 'CYBER 930-B Class   ',
    pmc$cyber_180_model_930c_class   = 'CYBER 930-C Class   ',
    pmc$cyber_180_model_930d_class   = 'CYBER 930-D Class   ',
    pmc$cyber_180_model_93011_class  = 'CYBER 930-11 Class  ',
    pmc$cyber_180_model_93031_class  = 'CYBER 930-31 Class  ',
    pmc$cyber_900_model_932a_class   = 'CYBER 932-A Class   ',
    pmc$cyber_900_model_932b_class   = 'CYBER 932-B Class   ',
    pmc$cyber_900_model_93211_class  = 'CYBER 932-11 Class  ',
    pmc$cyber_900_model_93231_class  = 'CYBER 932-31 Class  ',
    pmc$cyber_900_model_93232_class  = 'CYBER 932-32 Class  ',
    pmc$cyber_180_unknown_class      = 'CYBER Unknown Class ';

{ The following are retained for compatability.  Please note that the values
{ for pmc$cyber_180_model_930_class and pmc$cyber_180_model_932_class will
{ no longer be returned by any NOS/VE interface.

  CONST
    pmc$cyber_180_model_930_class    = 'CYBER 930 Class     ',
    pmc$cyber_180_model_932_class    = 'CYBER 932 Class     ',
    pmc$cyber_180_model_96011_class  = 'CYBER 960-11 Class  ',
    pmc$cyber_180_model_96031_class  = 'CYBER 960-31 Class  ',
    pmc$cyber_180_model_96032_class  = 'CYBER 960-32 Class  ',
    pmc$cyber_180_model_99231_class  = 'CYBER 992-31 Class  ',
    pmc$cyber_180_model_99232_class  = 'CYBER 992-32 Class  ',
    pmc$cyber_180_model_99431_class  = 'CYBER 994-31 Class  ',
    pmc$cyber_180_model_99432_class  = 'CYBER 994-32 Class  ';
*DECK DECK=PMT$PROCESSOR_SERIAL_NUMBER EXPAND=FALSE

  TYPE
    pmt$processor_serial_number = string (pmc$processor_serial_num_size);

  CONST
    pmc$processor_serial_num_size = 4;
*DECK DECK=PMT$PROCESSOR_STATE EXPAND=FALSE

  TYPE
    pmt$processor_state = STRING (pmc$processor_state_size);

  CONST
    pmc$processor_state_size = 4;

  CONST
    pmc$processor_state_on = 'ON  ',
    pmc$processor_state_off = 'OFF ',
    pmc$processor_state_down = 'DOWN';
*DECK DECK=PMT$PROGRAM_DESCRIPTION EXPAND=FALSE

  CONST
    pmc$max_object_file_list = 0ffff(16),
    pmc$max_module_list = 0ffff(16),
    pmc$max_library_list = 0ffff(16);

  TYPE
{      A program description is a sequence of one to five variables: }
{        1) program_attributes: pmt$program_attributes - required; specifys }
{           presence or absence, and size of remaining four variables, }
{        2) object_file_list: pmt$object_file_list, }
{        3) module_list: pmt$module_list, }
{        4) object_library_list: pmt$object_library_list. }
{        5) enable_inhibit_conditions: pmt$enable_inhibit_conditions. }
    pmt$program_description = SEQ ( * ),

    pmt$program_attributes = record
      contents: pmt$prog_description_contents,
      starting_procedure: pmt$program_name,
      number_of_object_files: pmt$number_of_object_files,
      number_of_modules: pmt$number_of_modules,
      number_of_libraries: pmt$number_of_libraries,
      load_map_file: amt$local_file_name,
      load_map_options: pmt$load_map_options,
      termination_error_level: pmt$termination_error_level,
      preset: pmt$initialization_value,
      maximum_stack_size: ost$segment_length,
      debug_input: amt$local_file_name,
      debug_output: amt$local_file_name,
      abort_file: amt$local_file_name,
      debug_mode: pmt$debug_mode,
    recend,

    pmt$prog_description_contents = set of pmt$prog_description_content,

    pmt$prog_description_content = (pmc$starting_proc_specified,
      pmc$object_file_list_specified, pmc$module_list_specified,
      pmc$library_list_specified, pmc$load_map_file_specified,
      pmc$load_map_options_specified, pmc$term_error_level_specified,
      pmc$preset_specified, pmc$max_stack_size_specified,
      pmc$debug_input_specified, pmc$debug_output_specified,
      pmc$abort_file_specified, pmc$debug_mode_specified,
      pmc$condition_specified, pmc$pd_reserved_10,
      pmc$pd_reserved_9, pmc$pd_reserved_8,
      pmc$pd_reserved_7, pmc$pd_reserved_6, pmc$pd_reserved_5,
      pmc$pd_reserved_4, pmc$pd_reserved_3, pmc$pd_reserved_2,
      pmc$pd_reserved_1),

    pmt$object_file_list = array [1 .. * ] of amt$local_file_name,

    pmt$module_list = array [1 .. * ] of pmt$program_name,

    pmt$object_library_list = array [1 .. * ] of amt$local_file_name,

    pmt$enable_inhibit_conditions = record
      enable_system_conditions: pmt$system_conditions,
      inhibit_system_conditions: pmt$system_conditions,
    recend,

    pmt$number_of_object_files = 0 .. pmc$max_object_file_list,

    pmt$number_of_modules = 0 .. pmc$max_module_list,

    pmt$number_of_libraries = 0 .. pmc$max_library_list,

    pmt$load_map_options = set of pmt$load_map_option,

    pmt$load_map_option = (pmc$no_load_map, pmc$segment_map, pmc$block_map,
      pmc$entry_point_map, pmc$entry_point_xref),

    pmt$termination_error_level = (pmc$warning_load_errors,
      pmc$error_load_errors, pmc$fatal_load_errors);

*copyc AMT$LOCAL_FILE_NAME
*copyc OSD$VIRTUAL_ADDRESS
*copyc PMT$PROGRAM_NAME
*copyc PMT$DEBUG_MODE
*copyc PMT$SYSTEM_CONDITIONS
*copyc PMT$INITIALIZATION_VALUE
*DECK DECK=PMT$PROGRAM_NAME EXPAND=FALSE


TYPE
  pmt$program_name = ost$name;

*copyc OST$NAME
*DECK DECK=PMT$PROGRAM_OPTIONS EXPAND=FALSE

  TYPE
    pmt$program_options = record
      map_file: amt$local_file_name,
      map_options: pmt$load_map_options,
      termination_error_level: pmt$termination_error_level,
      preset: integer,
      maximum_stack_size: ost$segment_length,
      debug_input: amt$local_file_name,
      debug_output: amt$local_file_name,
      abort_file: amt$local_file_name,
      debug_mode: pmt$debug_mode,
      conditions_enabled: pmt$system_conditions,
      conditions_inhibited: pmt$system_conditions,
    recend;

*copyc PMT$PROGRAM_DESCRIPTION
*copyc OSD$VIRTUAL_ADDRESS
*copyc AMT$LOCAL_FILE_NAME
*copyc PMT$DEBUG_MODE
*DECK DECK=PMT$PROGRAM_PARAMETERS EXPAND=FALSE

  TYPE
    pmt$program_parameters = SEQ ( * );
*DECK DECK=PMT$PROG_OPTIONS_AND_LIBRARIES EXPAND=FALSE

  TYPE
    pmt$prog_options_and_libraries = record
      default_options: ^pmt$program_options,
      job_library_list: ^pmt$object_library_list,
      debug_library_list: ^pmt$object_library_list,
    recend;

*copyc pmt$program_description
*copyc pmt$program_options
*DECK DECK=PMT$QUEUE_DEFINITION EXPAND=FALSE

  TYPE
    pmt$queue_definition = record
      removal_lock: ost$signature_lock,
      definition: ^pmt$queue_specification,
    recend,

    pmt$queue_definition_table = array [*] of pmt$queue_definition,

    pmt$queue_specification = record
      name: pmt$queue_name,
      removal_bracket: ost$ring,
      usage_bracket: ost$ring,
      control: pmt$queue_control,
    recend,

    pmt$queue_control = record
      connection_lock: ost$signature_lock,
      connected_task_list: ^pmt$queue_connected_task,
      message_queue_lock: ost$signature_lock,
      message_queue: pmt$message_queue,
      waiting_task_lock: ost$signature_lock,
      waiting_task_queue: pmt$waiting_task_queue,
    recend,

    pmt$queue_connected_task = record
      task: pmt$task_id,
      next_connected_task: ^pmt$queue_connected_task,
    recend,

    pmt$message_queue = record
      number_messages: pmt$messages_per_queue,
      dequeue: ^pmt$queued_message,
      enqueue: ^^pmt$queued_message,
    recend,

    pmt$queued_message = record
      dequeue_thread: ^pmt$queued_message,
      message: pmt$message,
{*    segments: ^array [*] of mmt$queued_segments, ****not in NOS/VE R1
    recend,

    pmt$waiting_task_queue = record
      number_waiting_tasks: pmt$connected_tasks_per_queue,
      dequeue: ^pmt$queued_task,
      enqueue: ^^pmt$queued_task,
    recend,

    pmt$queued_task = record
      task: ost$global_task_id,
      next_task: ^pmt$queued_task,
    recend;

*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$GLOBAL_TASK_ID
*copyc PMT$TASK_ID
*copyc ost$signature_lock
*copyc PMD$LOCAL_QUEUES
*DECK DECK=PMT$QUEUE_LIMITS EXPAND=FALSE

  TYPE
    pmt$queue_limits = record
      maximum_queues: pmt$queues_per_job,
      maximum_connected: pmt$connected_tasks_per_queue,
      maximum_messages: pmt$messages_per_queue,
    recend;

*copyc PMD$LOCAL_QUEUES
*DECK DECK=PMT$QUEUE_STATUS EXPAND=FALSE

  TYPE
    pmt$queue_status = record
      connections: pmt$connected_tasks_per_queue,
      messages: pmt$messages_per_queue,
      waiting_tasks: pmt$connected_tasks_per_queue,
    recend;

*copyc PMD$LOCAL_QUEUES
*DECK DECK=PMT$RAW_TASK_STATISTICS EXPAND=FALSE

  TYPE
{!  Temporary for HCS compatibility.
    pmt$raw_task_statistics = record
      task_name: ost$name,
      cp_time: pmt$task_cp_time,
      page_fault_count: integer,
      maxws_aio_slowdown: 0 .. 0ffffff(16),
      working_set_max_used: 0 .. 0ffff(16),
    recend;

*copyc OST$NAME
*copyc pmt$task_cp_time
*DECK DECK=PMT$SEGMENT_INHERITANCE_OPTIONS EXPAND=FALSE


  TYPE
    pmt$segment_inheritance_options = (pmc$clear_inherited_segments,
      pmc$inherit_code_and_data);
*DECK DECK=PMT$SENSE_SWITCHES EXPAND=FALSE

  { Sense switch definition

  TYPE
    pmt$sense_switches = set OF 1 .. 8;

*DECK DECK=PMT$SIGNAL EXPAND=FALSE

  {Declarations for a SIGNAL}
  TYPE
    pmt$signal = record
      identifier: pmt$signal_id,
      contents: pmt$signal_contents,
    recend,

    pmt$signal_id = (tmc$signal_available_0, ofc$signal,
        mlc$signal_id, ifc$signal_id, pmc$ss_child_terminated,
        jmc$timesharing_signal_id, cmc$configuration_signal_id,
        jmc$sense_switch_signal_id, tmc$signal_available_8,
        jmc$job_resource_signal_id, dsc$deadstart_signal,
        tmc$signal_available_11, nac$network_device_error,
        tmc$signal_available_13, tmc$signal_available_14,
        pmc$multi_task_condition, nac$gt_deliver_data,
        nac$gt_send_data, nac$gt_deliver_connect_request,
        nac$se_deliver_data_signal, nac$se_send_data_signal,
        nac$se_disconnect_signal, tmc$signal_available_22,
        tmc$signal_available_23, tmc$signal_available_24,
        tmc$signal_available_25, tmc$signal_available_26,
        clc$scl_signal, tmc$signal_available_28,
        tmc$signal_available_29, tmc$signal_available_30,
        tmc$signal_available_31, tmc$signal_available_32,
        tmc$signal_available_33, tmc$signal_available_34,
        tmc$signal_available_35, tmc$signal_available_36,
        tmc$signal_available_37, tmc$signal_available_38,
        tmc$signal_available_39, tmc$signal_available_40,
        tmc$signal_available_41, tmc$signal_available_42,
        tmc$signal_available_43, tmc$signal_available_44,
        tmc$signal_available_45, tmc$signal_available_46,
        tmc$signal_available_47, tmc$signal_available_48,
        tmc$signal_available_49, tmc$signal_available_50,
        tmc$signal_available_51, tmc$signal_available_52,
        tmc$signal_available_53, tmc$signal_available_54,
        tmc$signal_available_55, tmc$signal_available_56,
        tmc$signal_available_57, tmc$signal_available_58,
        tmc$signal_available_59, tmc$signal_available_60,
        tmc$signal_available_61, tmc$signal_available_62,
        tmc$signal_available_63),

    pmt$signal_contents = array [1 .. pmc$max_signal_contents] of 0 .. 0ff(16);

  CONST
    pmc$max_signal_id = 63;

  CONST
    pmc$max_signal_contents = 32;

  CONST
    tmc$last_signal_id_assigned = tmc$signal_available_63;

*DECK DECK=PMT$SPY_IDENTIFIER EXPAND=FALSE

  TYPE
    pmt$spy_identifier = ost$key_lock_value;

?? PUSH (LISTEXT := ON) ??
*copyc OSD$VIRTUAL_ADDRESS
?? POP ??
*DECK DECK=PMT$SPY_IDENTIFIERS EXPAND=FALSE


  TYPE
    pmt$spy_identifiers = RECORD
      low_identifier: pmt$spy_identifier,
      high_identifier: pmt$spy_identifier,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc pmt$spy_identifier
?? POP ??
*DECK DECK=PMT$STACK_SEGMENT EXPAND=FALSE

  TYPE
    pmt$stack_segment = SEQ (REP osc$maximum_offset of cell);

*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=PMT$STANDARD_SELECTION EXPAND=FALSE

  TYPE
    pmt$standard_selection = (pmc$execute_standard_procedure,
      pmc$inhibit_standard_procedure);
*DECK DECK=PMT$SYSTEM_CONDITIONS EXPAND=FALSE

  TYPE
    pmt$system_condition = (pmc$detected_uncorrected_err, pmc$ua_unselectable,
      pmc$sw_unselectable, pmc$instruction_specification,
      pmc$address_specification, pmc$xr_unselectable, pmc$access_violation,
      pmc$environment_specification, pmc$xi_unselectable, pmc$pf_unselectable,
      pmc$sc_unselectable, pmc$sit_unselectable, pmc$invalid_segment_ring_0,
      pmc$out_call_in_return, pmc$sel_unselectable, pmc$tx_unselectable,
      pmc$privileged_instruction, pmc$unimplemented_instruction,
      pmc$ff_unselectable, pmc$pit_unselectable, pmc$inter_ring_pop,
      pmc$cff_unselectable, pmc$kypt_unselectable, pmc$divide_fault,
      pmc$debug_unselectable, pmc$arithmetic_overflow, pmc$exponent_overflow,
      pmc$exponent_underflow, pmc$fp_significance_loss, pmc$fp_indefinite,
      pmc$arithmetic_significance, pmc$invalid_bdp_data),

    pmt$system_conditions = set of pmt$system_condition;
*DECK DECK=PMT$SYSTEM_LOG_ENTRY EXPAND=FALSE

  TYPE
    pmt$system_log_entry = packed record
      time: ost$millisecond_time,
      delimiter_1: string (1),
      job_sequence_number: jmt$system_supplied_name,
      delimiter_2: string (1),
      origin: string (2),
      delimiter_3: string (1),
      text: pmt$log_msg_text,
    recend;

*copyc jmt$system_supplied_name
*copyc ost$time
*copyc pmt$log_msg_text

*DECK DECK=PMT$SYSTEM_TIME EXPAND=FALSE

  TYPE
    pmt$system_time = record
      millisecond: 0 .. 999,
      second: 0 .. 59,
      minute: 0 .. 59,
      hour: 0 .. 23,
      day: 1 .. 31,
      month: 1 .. 12,
      year: 0 .. 4095,
      free_running_clock: ost$free_running_clock,
    recend;

*copyc OST$HARDWARE_SUBRANGES
*DECK DECK=PMT$SYS_DEFAULT_COND_HANDLER EXPAND=FALSE

{ This Type describes the interface to a SYStem supplied DEFAULT
{ CONDition HANDLER.

  TYPE
    pmt$sys_default_cond_handler = procedure
          (    condition: pmt$condition;
           VAR status: ost$status);

*copyc ost$status
*copyc pmt$condition
*DECK DECK=PMT$TASK_CONTROL_BLOCK EXPAND=FALSE

  TYPE
    pmt$task_control_block = record
      task_id: pmt$task_id,
      parent: ^pmt$task_control_block,
      first_child: ^pmt$task_control_block,
      next_sibling: ^pmt$task_control_block,
      target_ring: ost$ring,
      condition_environment_stack: ^pmt$condition_environment,
      flag_execution_ring: array [ost$system_flag] of
            tmt$handler_execution_ring,
      signal_execution_ring: array [tmt$signal_buffers] of
            tmt$handler_execution_ring,
      task_local_signal_list: tmt$task_local_signal_list,
      task_kill_count: pmt$task_kill_count,
      task_kill_phase: pmt$task_execution_phase,
      case task_kind: ost$task_kind of
      = osc$tk_nosve_task =
        nosve: pmt$nosve_task_controls,
      = osc$tk_unix_task =
        unix: pmt$unix_task_controls,
      casend,
    recend;

  TYPE
    pmt$nosve_task_controls = record
      program_description: ^pmt$program_description,
      mpe_description: ^pmt$loader_description,
      program_parameters: ^pmt$program_parameters,
      termination_status: ^ost$status,
      parent_task_status_variable: ^pmt$task_status,
      debug_table: ^pmt$debug_table_info,
      debug_input: amt$local_file_name,
      debug_output: amt$local_file_name,
      abort_file: amt$local_file_name,
      initial_debug_mode: pmt$debug_mode,
      cl_task: boolean,
      ada_shared_stack_pointer: mmt$segment_pointer,
      ada_critical_frame: ^pmt$os_stack_frame_word,
      ada_starting_procedure: pmt$user_program,
      ada_task_table: ^pmt$ada_task_table,
      task_condition_count: pmt$ts_task_condition_count,
      task_handler_count: pmt$ts_task_handler_count,
      task_io_enabled: boolean,
    recend,

    pmt$ada_task_table = record
      current_entry: pmt$max_number_of_tasks,
      table: array [ * ] of pmt$task_id,
    recend;

TYPE
  pmt$unix_task_controls = record
    kernel_termination_complete: boolean,
    return_sfsa_address: ^ost$minimum_save_area,
    scl_booted: boolean,
    task_termination_action: pmt$task_termination_action,
    unix_parent_task_gtid: ost$global_task_id,
  recend;

*copyc amt$local_file_name
*copyc dbt$entry_point_table
*copyc dbt$module_address_table_item
*copyc mmt$attribute_keyword
*copyc osd$virtual_address
*copyc ost$global_task_id
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc ost$system_flag
*copyc ost$task_kind
*copyc pmt$condition_environment
*copyc pmt$debug_mode
*copyc pmt$debug_table_info
*copyc pmt$loader_seq_descriptor
*copyc pmt$max_number_of_tasks
*copyc pmt$os_stack_frame_word
*copyc pmt$program_description
*copyc pmt$program_parameters
*copyc pmt$task_execution_phase
*copyc pmt$task_id
*copyc pmt$task_kill_count
*copyc pmt$task_status
*copyc pmt$task_termination_action
*copyc pmt$ts_task_condition_count
*copyc pmt$ts_task_handler_count
*copyc pmt$user_program
*copyc tmt$handler_execution_ring
*copyc tmt$signal_buffers
*copyc tmt$task_local_signal_list
*DECK DECK=PMT$TASK_CP_TIME EXPAND=FALSE

  TYPE
    pmt$task_cp_time = record
*IF $true(osv$unix)
      task_time: 0 .. 7fffffff(16),
      monitor_time: 0 .. 7fffffff(16),
*ELSE
      task_time: 0 .. 7fffffffffff(16),
      monitor_time: 0 .. 7fffffffffff(16),
*IFEND
    recend;

*DECK DECK=PMT$TASK_DEBUG_MODE_STACK EXPAND=FALSE

  TYPE
    pmt$task_debug_mode_stack = record
      top_of_stack: pmc$min_elements_in_debug_stack .. pmc$max_elements_in_debug_stack,
      stack: ^pmt$debug_mode_stack,
    recend,

    pmt$debug_mode_stack = record
      element: array [pmc$min_elements_in_debug_stack .. pmc$max_elements_in_debug_stack] of pmt$debug_mode,
      previous_stack: ^pmt$debug_mode_stack,
    recend;

  CONST
    pmc$min_elements_in_debug_stack = 0,
    pmc$max_elements_in_debug_stack = 63;

*copyc PMT$DEBUG_MODE

*DECK DECK=PMT$TASK_EXECUTION_PHASE EXPAND=FALSE
  TYPE
    pmt$task_execution_phase = (pmc$task_executing,
          pmc$task_popping_stack_frames, pmc$task_loaded_ring_cleanup,
          pmc$task_termination_cleanup);

*DECK DECK=PMT$TASK_ID EXPAND=FALSE

  TYPE
    pmt$task_id = 0 .. pmc$max_task_id;

  CONST
*IF $true(osv$unix)
    pmc$max_task_id = 7fffffff(16);
*ELSE
    pmc$max_task_id = 0ffffffff(16);
*IFEND
*DECK DECK=PMT$TASK_JOBMODE_STATISTICS EXPAND=FALSE

  TYPE
    pmt$task_jobmode_statistics = RECORD
      jobmode_cptime: integer,
      paging_statistics: ost$paging_statistics,
    RECEND;
*copyc OST$PAGING_STATISTICS
*DECK DECK=PMT$TASK_KILL_COUNT EXPAND=FALSE

  TYPE
    pmt$task_kill_count = 0 .. pmc$task_kill_count_maximum;

  CONST
    pmc$task_kill_count_maximum = 255;
*DECK DECK=PMT$TASK_STATE EXPAND=FALSE

  TYPE
    pmt$task_state = (pmc$task_active, pmc$program_exiting,
      pmc$program_aborting, pmc$debug_ending, pmc$task_terminating),

    pmt$program_termination_mode = pmc$program_exiting .. pmc$program_aborting;
*DECK DECK=PMT$TASK_STATUS EXPAND=FALSE

  TYPE
    pmt$task_status = record
      complete: boolean,
      status: ost$status,
    recend;

*copyc OST$STATUS
*DECK DECK=PMT$TASK_TEMPLATE EXPAND=FALSE

  TYPE
    pmt$task_template = record
      xcb: ost$execution_control_block,
      segment: array [1 .. * ] of pmt$task_private_descriptor,
    recend,

    pmt$task_private_descriptor = record
      number: ost$segment,
      content: ^array [ * ] of cell,
    recend;

*copyc OST$EXECUTION_CONTROL_BLOCK
*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=PMT$TASK_TERMINATION_ACTION EXPAND=FALSE

  TYPE
    pmt$task_termination_action = (pmc$tta_dont_notify_parent_task,
          pmc$tta_ready_parent_task, pmc$tta_flag_parent_task,
          pmc$tta_signal_parent_task);

*DECK DECK=PMT$TASK_TERM_INHIBIT_COUNT EXPAND=FALSE

  TYPE
    pmt$task_term_inhibit_count = 0 .. pmc$max_task_term_inhibits;

  CONST
    pmc$max_task_term_inhibits = 5;

*DECK DECK=PMT$TIME_INCREMENT EXPAND=FALSE

  TYPE
    pmt$time_increment = record
      year: integer,
      month: integer,
      day: integer,
      hour: integer,
      minute: integer,
      second: integer,
      millisecond: integer,
    recend;

*DECK DECK=PMT$TS_TASK_CONDITION_COUNT EXPAND=FALSE

  TYPE
    pmt$ts_task_condition_count = 0 .. 4096(16);
*DECK DECK=PMT$TS_TASK_HANDLER_COUNT EXPAND=FALSE

  TYPE
    pmt$ts_task_handler_count = 0 .. 4096(16);
*DECK DECK=PMT$USER_PROGRAM EXPAND=FALSE

  TYPE
    pmt$user_program = ^procedure (parameters: pmt$program_parameters;
      VAR status: ost$status);

*copyc PMT$PROGRAM_PARAMETERS
*copyc OST$STATUS
*DECK DECK=PMT$USE_TIME_ZONE EXPAND=FALSE
TYPE
  pmt$use_time_zone = (pmc$use_universal_time, pmc$use_system_local_time);
*DECK DECK=PMT$VECTOR_CAPABILITY EXPAND=FALSE
    TYPE
       pmt$vector_capability = 0 .. 15;

    CONST
      pmc$extended_vectors = 1,
      pmc$standard_vectors = 2,
      pmc$no_vectors = 3;
*DECK DECK=PMT$VECTOR_DEGRADE_STATE EXPAND=FALSE
  TYPE
    pmt$vector_degrade_state = boolean;
*DECK DECK=PMT$VECTOR_SIMULATION EXPAND=FALSE
  TYPE
    pmt$vector_simulation = 0 .. 255;

  CONST
    pmc$vectors_simulated = 0,
    pmc$vectors_suspended = 1,
    pmc$vectors_aborted = 2;

*DECK DECK=PMT$VIRTUAL_MEMORY_IMAGE_HEADER EXPAND=FALSE

  { This deck defines the linked virtual memory image produced by the }
  { Virtual Environment Linker. }
  { This image is a sequence consisting of the following: }
  { 1) The virtual memory image header (PMT$VIRTUAL_MEMORY_IMAGE_HEADER) }
  { 2) For each segment in the image: }
  { 1) A linked segment description (PMT$LINKED_SEGMENT_DESCRIPTION) }
  { 2) The segment image itself. }


  TYPE
    pmt$virtual_memory_image_header = record
      version: pmt$image_version,
      system_core_id: ost$name,
      starting_procedure: ost$external_code_base_pointer,
      number_of_segments: ost$segment,
      pad_for_170_linker: array [1 .. 3] of 0 .. 0ff(16),
      length: ost$segment_length,
      exchange_package: ^ost$exchange_package,
    recend,

    pmt$image_version = string (8),

    pmt$linked_segment_description = record
      name: ost$name,
      segment_number: ost$segment,
      length: ost$segment_length,
      segment_descriptor: ost$segment_descriptor,
      software_attributes: mmt$software_attribute_set,
      pad_for_170_linker: array [1 .. 5] of 0 .. 0ff(16),
    recend;

  CONST
    pmc$image_version = 'VMI_V1.2';

*copyc OSD$VIRTUAL_ADDRESS
*copyc OST$SEGMENT_DESCRIPTOR
*copyc OSD$CODE_BASE_POINTER
*copyc OST$EXCHANGE_PACKAGE
*copyc ost$name
*copyc MMT$ATTRIBUTE_KEYWORD
*DECK DECK=PMT$WAIT_PREEMPTABILITY EXPAND=FALSE

  TYPE
    pmt$wait_preemptability = set of (pmc$wait, pmc$long_term_wait);

*DECK DECK=PMV$BINARY_CPU_ATTRIBUTES EXPAND=FALSE
*DECK DECK=PMV$CONSTRAIN_MEAPE_SEGMENTS EXPAND=FALSE

  VAR
    pmv$constrain_meape_segments: [XREF] boolean;
*DECK DECK=PMV$CPU0_ATTRIBUTES_INITIALIZED EXPAND=FALSE
*DECK DECK=PMV$CPU_ATTRIBUTES EXPAND=FALSE
*DECK DECK=PMV$CPU_DATA EXPAND=FALSE

  VAR
    pmv$cpu_data: [XREF] pmt$cpu_data;

?? PUSH (LISTEXT := ON) ??
*copyc pmt$cpu_data
?? POP ??
*DECK DECK=PMV$DEBUG_LOGGING_ENABLED EXPAND=FALSE

  VAR
    pmv$debug_logging_enabled: [XREF] boolean;
*DECK DECK=PMV$ENABLE_INHIBIT_CONDITIONS EXPAND=FALSE

  VAR
    pmv$enable_inhibit_conditions: [XREF] pmt$enable_inhibit_conditions;

?? PUSH (LISTEXT := ON) ??
*copyc pmt$program_description
?? POP ??
*DECK DECK=PMV$END_HANDLER_LIST EXPAND=FALSE

 VAR
    pmv$end_handler_list: [XREF] ^pmt$end_handler_ring_list;

?? PUSH (LISTEXT := ON) ??
*copyc pmt$end_handler_desc
?? POP ??
*DECK DECK=PMV$END_HANDLER_TERM_STATUS EXPAND=FALSE

 VAR
    pmv$end_handler_term_status: [XREF] ost$status;

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PMV$END_HANDLER_TO_CALL EXPAND=FALSE

 VAR
    pmv$end_handler_to_call: [XREF] pmt$end_handler;

?? PUSH (LISTEXT := ON) ??
*copyc pmt$end_handler
?? POP ??
*DECK DECK=PMV$EPILOG_FILE EXPAND=FALSE
  VAR
    pmv$epilog_file: [XREF, oss$task_shared] string (fsc$max_path_size);

*copyc fsc$max_path_size
*copyc oss$task_shared
*DECK DECK=PMV$EPILOG_LOCAL_FILE_NAME EXPAND=FALSE

  VAR
    pmv$epilog_local_file_name: [XREF] amt$local_file_name;
*copyc amt$local_file_name
*DECK DECK=PMV$JOB_DEBUG_RING EXPAND=FALSE

  VAR
    pmv$job_debug_ring: [XREF, oss$task_shared] ost$ring;

*copyc OSS$TASK_SHARED
*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=PMV$JOB_INITIALIZATION_COMPLETE EXPAND=FALSE

  VAR
    pmv$job_initialization_complete: [XREF, READ, oss$job_pageable] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc OSS$JOB_PAGEABLE
?? POP ??
*DECK DECK=PMV$JOB_LIBRARY_LIST EXPAND=FALSE

  VAR
    pmv$job_library_list: [XREF] ^pmt$object_library_list;

?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_DESCRIPTION
?? POP ??
*DECK DECK=PMV$JOB_MAXIMUM_LIMIT_EXCEEDED EXPAND=FALSE
  VAR
    pmv$job_maximum_limit_exceeded: [XREF, oss$job_pageable] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc oss$job_pageable
?? POP ??
*DECK DECK=PMV$JOB_MONITOR_TCB_P EXPAND=FALSE

  VAR
    pmv$job_monitor_tcb_p: [XREF, READ, oss$job_pageable]
          ^pmt$task_control_block;

?? PUSH (LISTEXT := ON) ??
*copyc oss$job_pageable
*copyc pmt$task_control_block
?? POP ??
*DECK DECK=PMV$MAINFRAME_ID EXPAND=FALSE

  VAR
    pmv$mainframe_id: [XREF] pmt$mainframe_id;

?? PUSH (LISTEXT := ON) ??
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=PMV$OS_NAME EXPAND=FALSE
*DECK DECK=PMV$POPPER_HANDLER_ESTABLISHED EXPAND=FALSE

  VAR
    pmv$popper_handler_established: [XREF, oss$task_private] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc oss$task_private
?? POP ??
*DECK DECK=PMV$PRESET_CONVERSION_TABLE EXPAND=FALSE

  VAR
    pmv$preset_conversion_table: [XREF, READ] array [pmt$initialization_value] of integer;

?? PUSH (LISTEXT := ON) ??
*copyc PMT$PROGRAM_DESCRIPTION
?? POP ??
*DECK DECK=PMV$PROG_OPTIONS_AND_LIBRARIES EXPAND=FALSE
*DECK DECK=PMV$QUANTUM EXPAND=FALSE

  VAR
    pmv$quantum: [XREF] integer;
*DECK DECK=PMV$QUEUE_DEFINITION_TABLE EXPAND=FALSE

*copyc OSS$TASK_SHARED

  VAR
    pmv$queue_definition_table: [XREF, oss$task_shared] record
      definition_lock: ost$signature_lock,
      queues: ^pmt$queue_definition_table, {NIL = local queues undefined}
    recend;

*copyc OST$TASK_ID
*copyc ost$signature_lock
*copyc PMT$QUEUE_DEFINITION
*DECK DECK=PMV$TASK_EXECUTION_PHASE EXPAND=FALSE

  VAR
    pmv$task_execution_phase: [XREF, oss$task_private] pmt$task_execution_phase;

?? PUSH (LISTEXT := ON) ??
*copyc oss$task_private
*copyc pmt$task_execution_phase
?? POP ??
*DECK DECK=PMV$TASK_TCB_P EXPAND=FALSE

*DECK DECK=PMV$TASK_TEMPLATE EXPAND=FALSE

  VAR
    pmv$task_template: [XREF, oss$job_fixed] ^pmt$task_template;

?? PUSH (LISTEXT := ON) ??
*copyc OSS$JOB_FIXED
*copyc PMT$TASK_TEMPLATE
?? POP ??
*DECK DECK=PMV$TASK_TERMINATION_ATTEMPTED EXPAND=FALSE

  VAR
    pmv$task_termination_attempted: [XREF, oss$task_private] boolean;

*copyc oss$task_private
*DECK DECK=PMV$TASK_TERM_INHIBIT_COUNT EXPAND=FALSE

  VAR
    pmv$task_term_inhibit_count: [XREF, oss$task_private]
          pmt$task_term_inhibit_count;

*copyc oss$task_private
*copyc pmt$task_term_inhibit_count
*DECK DECK=PMV$UNSEEN_MAIL_PENDING EXPAND=FALSE
  VAR
    pmv$unseen_mail_pending: [XREF, READ, STATIC, oss$task_shared] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc oss$task_shared
?? POP ??
*DECK DECK=PP895 EXPAND=TRUE
          IDENT  D895
          CIPPU
          TITLE  895 DRIVER FOR NIO CHANNEL
          COMMENT *SMD* LVL=04
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992


 CHANTYP  EQU    0           CHANNEL TYPE
*                            =0 FOR NIO CHANNEL VERSION OF DRIVER
*                            =1 FOR CIO CHANNEL VERSION OF DRIVER
 PRGNAM   MICRO  1,4,'A95N'  1ST 4 CHARACTERS OF OVERLAY NAME

*copyc pp895_common_deck
          END
/EOR
*DECK DECK=PP895CIO EXPAND=TRUE
          IDENT  D895CIO
          CIPPU
          MEMSEL 8
          TITLE  895 DRIVER FOR CIO CHANNEL
          COMMENT *SMD* LVL=04
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 PRGNAM   MICRO  1,4,'A95C'  1ST 4 CHARACTERS OF OVERLAY NAME

 NPP      EQU    1           NUMBER OF PPS
*                            = 1 IF ONE-PP DMA DRIVER
*                                   ALSO, IF ASSEMBLING THE ONE-PP
*                                   DRIVER, DELETE THE *COPYC PP895_COMMON_DECK
*                                   LINE IN FRONT OF THE TPP    ELSE   LINE
*                            = 2 IF TWO-PP DRIVER
 TPP      IFEQ   NPP,2
 CHANTYP  EQU    1           CHANNEL TYPE
*                            =0 FOR NIO CHANNEL VERSION OF DRIVER
*                            =1 FOR CIO CHANNEL VERSION OF DRIVER

 TPP      ELSE
*
*         THIS IS THE PP DRIVER THAT SUPPORTS THE 895 DISK SUBSYSTEM
*         ON A CIO CHANNEL.  THE DRIVER FOR THE CIO CHANNEL HAS PROGRAM
*         NAME D895CIO AND DECK NAME PP895CIO.  CONFIGURATION
*         MANAGEMENT LOADS THE CORRECT DRIVER.  IT PLUGS THE PP
*         INTERFACE TABLE RMA INTO LOCATIONS 72, 73.  LOCATION 0 OF
*         PP MEMORY MUST CONTAIN THE EXECUTION ADDRESS, MINUS ONE,
*         AT WHICH EXECUTION BEGINS.  THIS DRIVER USES THE DMA
*         HARDWARE AND ONLY USES ONE PP.  THE PP DRIVER FOR THE NIO
*         CHANNEL USES TWO PPS.  ITS PROGRAM NAME IS D895 AND ITS
*         DECK NAME IS PP895.
          LIST   -$
*copyc IODMAC1 "{RECORD DEFINITION MACROS}
*copyc IODMAC2 "{LOAD/STORE MACROS}
*copyc IODMAC3 "{GENERAL MACROS}
*copyc IODMAC4 "{GENERAL MACROS}
*copyc IODMAC5 "(OVERLAY MACROS)
          LIST   B,L,N,R
          TITLE  EQUATES SECTION
 FE       EQU    0           = 1 IF ENABLING FORCE ERROR CODE
 DC       EQU    22B         DISK CHANNEL
 BPS      EQU    4128        BYTES PER SECTOR
 NOU      EQU    8           NUMBER OF ACTIVE UNITS ALLOWED
 CTB      EQU    17770B-510B  CONFIDENCE TEST BUFFER
 OVST     EQU    16000B      OVERLAY STARTING ADDRESS
 RTRY     EQU    4           RETRY REQUEST 3 TIMES
 MAXCYL   EQU    885         MAXIMUM CYLINDER
 MAXTR    EQU    14          MAXIMUM TRACK
 MAXSEC   EQU    9           MAXIMUM SECTOR

* DISK FUNCTIONS

 F.CONECT EQU    0           CONNECT
 F.SEEK   EQU    1           SEEK
 F.READ   EQU    4           READ
 F.WRITE  EQU    5           WRITE
 F.OPCMP  EQU    10B         OPERATION COMPLETE
 F.GS     EQU    12B         GENERAL STATUS
 F.CONT   EQU    14B         CONTINUE
 F.FMP    EQU    16B         FORMAT PACK
 F.EDS    EQU    23B         EXTENDED DETAILED STATUS
 F.UDIR   EQU    32B         UDI READ
 F.UDIW   EQU    33B         UDI WRITE
 F.DMAR   EQU    43B         DMA READ
 F.DMAW   EQU    44B         DMA WRITE
 F.AUTOP  EQU    414B        AUTOLOAD FROM PP
 F.MC     EQU    0#8000      MASTER CLEAR CIO ADAPTER BOARD FUNCTION
 F.CTR    EQU    0#8200      CLEAR T REGISTERS
 F.SDI    EQU    0#8400      START DMA INPUT
 F.SDO    EQU    0#8600      START DMA OUTPUT
 F.CDM    EQU    0#8800      CLEAR DMA MODE
 F.CTM    EQU    0#8C00      CLEAR TEST MODE
 F.ETM    EQU    0#8E00      ENABLE TEST MODE
 F.WCR    EQU    0#9200      WRITE CONTROL REGISTER OF CIO ADAPTER
 F.RES    EQU    0#9400      READ ERROR STATUS REGISTER OF CIO ADAPTER
 F.ROS    EQU    0#9800      READ OPERATIONAL STATUS REGISTER
 F.RTR    EQU    0#9C00      READ T REGISTER
 F.WTR    EQU    0#9E00      WRITE T REGISTER

 GS4400   EQU    4400B       RECOVERY IN PROGRESS STATUS
 GS5020   EQU    5020B       SUBSYSTEM ERROR, SENSE BYTES PRESENT
          SPACE  5,20
*
*         ERROR CODES FOR LOCATION EC
*
 E00      EQU    0           NO CODE, CP MUST ISOLATE THE ERROR
 E01      EQU    1           INTERFACE ERROR
 E02      EQU    2           KZ BOARD ERROR
 E03      EQU    3           KX BOARD ERROR
 E04      EQU    4           CHANNEL ERROR
 E05      EQU    5           INCOMPLETE CHANNEL TRANSFER
 E06      EQU    6           PP - CCC DATA INTEGRITY ERROR
 E07      EQU    7           PP - UNIT DATA INTEGRITY ERROR
 E08      EQU    8           SEEK COMMAND TIMEOUT
 E09      EQU    9           CCC FAILURE
 E10      EQU    10          IOU FAILURE - OPERATIONAL STATUS WRONG
 E11      EQU    11          IOU FAILURE - TEST MODE DATA MISCOMPARE
 E12      EQU    12          UNCORRECTED CM ERROR
 E13      EQU    13          CM REJECT
 E14      EQU    14          INVALID CM RESPONSE
 E15      EQU    15          CM RESPONSE CODE PARITY ERROR
 E16      EQU    16          CMI READ DATA PARITY ERROR
 E17      EQU    17          OVERFLOW ERROR
 E18      EQU    18          JY BOARD ERROR
 E19      EQU    19          TRANSFER IN PROGRESS DID NOT CLEAR
 E20      EQU    20          T PRIME REGISTER NOT EMPTY
          SPACE  5,20
* INTERFACE ERROR CODES.

 E308     EQU    1410B       UNIT COMMUNICATION BUFFER IS TOO SMALL
 E501     EQU    2401B       INVALID COMMAND CODE
 E50A     EQU    2412B       INVALID SEQUENCE OF COMMANDS
          EJECT
* SELECTION SET (SS)
 SS       RECORD PACKED

          SUBRANGE 0,377B    (UNUSED)
 UNIT     SUBRANGE 0,377B    UNIT NUMBER

 CYL      PPWORD             CYLINDER ADDRESS
 TRACK    PPWORD             TRACK ADDRESS
 SECTOR   PPWORD             SECTOR ADDRESS
 UQT      STRUCT 6           UNIT INTERFACE TABLE (RMA, REFORMATTED)
 REQ      STRUCT 4           CURRENT REQUEST (UNFORMATTED RMA)
 PVA      STRUCT 6           PVA OF CURRENT REQUEST
 COM      STRUCT 6           COMMUNICATION BUFFER (RMA, REFORMATTED)
          SUBRANGE 0,3777B   (UNUSED)
 ENTRY    BOOLEAN            REQUEST ON QUEUE SELECTED
          SUBRANGE 0,17B     (UNUSED)
 LISTL    PPWORD             SAVED VALUE OF CMLISTL (DURING FORMATTING)
          PPWORD             (UNUSED)
 LASTC    PPWORD             OFFSET OF LAST COMMAND IN REQUEST
 LPP      PPWORD             LOGICAL PP NUMBER
          ALIGN  0,64
 CLKST    STRUCT 4           CLOCK START TIME
 SEEKTM   STRUCT 4           SEEK TIME
 DP       STRUCT 6           REFORMATTED RMA OF DELINK POINTER
          PPWORD             (UNUSED)
          MGEN   N.ENTRY
 M.ENTRY  EQU    MASK$
          MASKP  ENTRY
 K.ENTRY  EQU    MSK
          MGEN   N.UNIT
 M.UNIT   EQU    MASK$
 SS       RECEND

*         ALTERNATE USES OF SS TABLE DURING CONFIDENCE TEST

 CTME     EQU    /SS/P.PVA   START OF A 3-WORD TABLE WITH EACH WORD
                              CONTAINING THE HEAD AND SECTOR NUMBER
                              OF A MEDIA ERROR

* LOGICAL UNIT TABLE.

 LUT      RECORD PACKED
 LINK     PPWORD             ADDRESS OF THE NEXT LUT ENTRY
 OFFSET   PPWORD             INDEX INTO THE CM.DEV TABLE
          SUBRANGE 0,37777B  (UNUSED)
 OWNER    BOOLEAN            THIS PP HAS THE UNIT LOCKED
          BOOLEAN            (UNUSED)
 UIT      STRUCT 6           RMA OF THE UIT (REFORMATTED RMA)
          MGEN   N.OWNER
 M.OWNER  EQU    MASK$
          MASKP  OWNER
 K.OWNER  EQU    MSK

 LUT      RECEND
          SPACE  5,20
* PP INTERFACE TABLE
 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
 ACTCH    BOOLEAN            ACTIVE CHECK, THE PP CLEARS THIS BIT WITHIN 1 MINUTE
 IDLREQ   BOOLEAN            IDLE REQUEST
 RESREQ   BOOLEAN            RESUME REQUEST
 PPIDLE   BOOLEAN            PP IDLE
          SUBRANGE 0,3777B   UNUSED
 LOCK     BOOLEAN            PP TABLE LOCK
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
          STRUCT 24          UNUSED
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          SPACE  5,20
* UNIT DESCRIPTORS.

 UD       RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 SDIR     SUBRANGE 0,7       STORAGE DIRECTOR ADDRESS
          SUBRANGE 0,377B    (UNUSED)
 UNIT     SUBRANGE 0,37B     PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)
          MGEN   N.SDIR
 M.SDIR   EQU    MASK$
          MASKP  SDIR
 K.SDIR   EQU    MSK
          MGEN   N.UNIT
 M.UNIT   EQU    MASK$

 UD       RECEND
          SPACE  5,20
* UNIT INTERFACE TABLE

 UIT      RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
                               = 400B, 844-4X
                               = 401B, 885-1X
                               = 402B, 885-42
 QCNT     PPWORD             QUEUE COUNT
*
          ALIGN  16,64
 UBUFL    PPWORD             UNIT COMMUNICATION BUFFER LENGTH
 UBUF     RMA                UNIT COMMUNICATION BUFFER (RMA)
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

          MASKP  DSABLE
 K.DSABLE EQU    MSK

 UIT      RECEND
          SPACE  5,20
* PP REQUESTS.

 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS
                               0 - ATTEMPT RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
          ALIGN  0,64
 SWIT     BOOLEAN            SWITCH TO NEXT REQUEST
          ALIGN  16,64
 CYL      PPWORD             CYLINDER ADDRESS
 TRACK    PPWORD             TRACK ADDRESS
 SECTOR   PPWORD             SECTOR ADDRESS
 CMND     INTEGER            COMMAND SEQUENCE


          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$

 RQ       RECEND
          SPACE  5,20
* PP COMMAND.

 CM       RECORD PACKED

 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$

 CM       RECEND
          SPACE  5,20
* COMMAND CODES.

 C.IDLE   EQU    4           IDLE
 C.RESUME EQU    5           RESUME
 C.READ   EQU    100B        READ BYTES
 C.WRITE  EQU    120B        WRITE BYTES
 C.FORMAT EQU    164B        DISK FORMAT
          SPACE  5,20
* PP RESPONSE.

 RS       RECORD PACKED
 FILL1    BOOLEAN
 SHORT    BOOLEAN            IF SET, ONE-WORD RESPONSE
          SUBRANGE 0,77B     UNUSED
          SUBRANGE 0,377B    LOGICAL UNIT (FOR DEBUG)
          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST (UNUSED)
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
          ALIGN  0,64
          SUBRANGE 0,37B     (UNUSED)
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT
          BOOLEAN            (UNUSED)
 FTO      BOOLEAN            FUNCTION TIMEOUT
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
                               1 - RECOVERED ERROR
                               2 - COMMAND HAD EXPLICIT RESPONSE FLAG SET
                               3 - BOTH CONDITIONS 1 AND 2
 K.REC    EQU    1           RECOVERED ERROR
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)(NOT USED)

 CHAN     PPWORD             CHANNEL NUMBER
 SCYL     PPWORD             STARTING CYLINDER
 STRK     PPWORD             STARTING TRACK
 SSEC     PPWORD             STARTING SECTOR

 UNIT     PPWORD             UNIT NUMBER
 RTRY     PPWORD             REQUEST RETRY COUNT
 FTRK     PPWORD             FAILING TRACK
 FSEC     PPWORD             FAILING SECTOR

 DET      PPWORD             =1, IF DETAILED STATUS PRESENT
 ID       PPWORD
 K.FORS   EQU    200B        DISK FORMATTING STARTED
 K.FORE   EQU    400B        DISK FORMATTING ENDED
 K.UDN    EQU    20000B      UNIT DOWN
 K.CMDN   EQU    40000B      STORAGE DIRECTOR DOWN
 K.CHDN   EQU    100000B     CHANNEL DOWN
          PPWORD             (UNUSED)
          PPWORD             (UNUSED)
 GENST1   PPWORD             GENERAL STATUS OF THE FIRST TIME ERROR
                               WAS ENCOUNTERED
 GENST2   PPWORD             GENERAL STATUS OF THE LAST TIME ERROR
                               WAS ENCOUNTERED
 FUNTO    PPWORD             FUNCTION CODE IF FUNCTION TIMEOUT ERROR
          PPWORD             UNUSED
 FERREG   PPWORD             FIRST OCCURRENCE OF ERROR STATUS REGISTER (CIO ONLY)
 LERREG   PPWORD             LAST OCCURRENCE OF ERROR STATUS REGISTER (CIO ONLY)
 OS       PPWORD             OPERATIONAL STATUS
 EC       PPWORD             ERROR CODE (EXX)
          ALIGN  0,64
 DETAIL   STRUCT 40          DETAILED STATUS OF THE FIRST TIME ERROR
                             WAS ENCOUNTERED
 DET2     STRUCT 40          DETAILED STATUS OF THE LAST TIME ERROR
                             WAS ENCOUNTERED.

          MASKP  DATERR
 K.DATERR EQU    MSK
          MASKP  FTO
 K.FTO    EQU    MSK
          MASKP  SHORT
 K.SHORT  EQU    MSK

 RS       RECEND
          SPACE  5,20
* RESPONSE CODES.
 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    1           INTERMEDIATE RESPONSE
 R.NRM    EQU    2           NORMAL REQUEST TERMINATION
 R.ABN    EQU    3           ABNORMAL REQUEST TERMINATION
          SPACE  5,20
* PP COMMUNICATION BUFFER.

 CB       RECORD PACKED

          ALIGN  31,64
 SLAVE    BOOLEAN            NONZERO IF SLAVE PP (UNUSED)
 PARTNR   RMA                PARTNERS PPIT (RMA) (UNUSED)

 CONTRL   STRUCT 8           LOAD CONTROLWARE COMMAND
          STRUCT 8
 ODP      STRUCT 8           OVERLAY DIRECTORY POINTER
          STRUCT 56          (UNUSED)

          ALIGN  0,64
 SS       STRUCT 56          SS ENTRY

 SVAREA   STRUCT 16          SAVE PARAMETERS FOR DATA RETRIEVAL

          ALIGN  0,64

*         THERE IS A ONE CM WORD TABLE PER CONFIGURED UNIT.  CM.DEV
*         IS THE REFORMATTED RMA THAT POINTS TO IT.

 DEV      SUBRANGE 0,7777B
 CT       SUBRANGE 0,7       NONZERO WHEN CONFIDENCE TEST COMPLETE
                              1 - NO ERROR
                              2 - ERROR
                              4 - DATA INTEGRITY ERROR
 ACT      BOOLEAN            UNIT ACTIVE (IN PPS IN USE QUEUE)
          STRUCT 6           REFORMATTED RMA OF UNIT INTERFACE TABLE
          STRUCT 63*8        MAXIMUM OF 64 CONFIGURED UNITS
 BUF      STRUCT 5328        DATA BUFFER FOR CONFIDENCE TEST
                              BYTES = SECTOR (4128) + 8 TIMES
                              (SECTORS (10) X TRACKS (15))
          MASKP  ACT
 K.ACT    EQU    MSK


 CB       RECEND
          TITLE  DIRECT CELLS, CONSTANTS, TABLES
          CON    INIT-1

* DIRECT CELLS

 DH       BSSZ   3           REFORMATTED RMA OF OVERLAY DIRECTORY
 CM.PIT   BSSZ   3           CM ADDRESS OF PP INTERFACE TABLE (REFORMATED)

 T1       BSSZ   1
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1

* KEEP GNSTAT AND P1 ADJACENT.
 GNSTAT   BSSZ   1           GENERAL STATUS
 P1       BSSZ   1
 P2       BSSZ   1
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 P6       BSSZ   1
 WC       BSSZ   1           WORD COUNT TO READ/WRITE CM WORDS

 DEVL     CON    0           LENGTH OF DEV TABLE (SET BY INIT)
 CHAN     BSSZ   1           CHANNEL NUMBER
 CM.DEV   BSSZ   3           ADDRESS OF DEV TABLE IN COMMON AREA
 CMADR    BSSZ   3           CM ADDRESS

* THE NEXT 8 PP WORDS MUST BE CONTIGUOUS.  VALUES BC AND RMA MUST BE
* CONSECUTIVE.  THEY ARE WRITTEN INTO THE T REGISTER.

 SVCELLS  BSS
 BC       DATA   0           BYTE COUNT (NOT NECESSARY TO SAVE THIS)
 RMA      DATA   0,0         RMA
 CMLISTL  BSSZ   1           NUMBER OF CM WORDS IN ADDRESS-LENGTH PAIR LIST.
                             (INCLUDES THE NUMBER OF WORDS WHICH HAVEN'T
                             BEEN READ FROM CM.)
 LEN      BSSZ   1           TOTAL NUMBER OF BYTES TO TRANSFER
          BSSZ   1           (UNUSED)
 CMRMA    BSSZ   2           SAVED RMA OF DATA RMA LIST

 FNC      BSSZ   1           FUNCTION CODE (INTERNAL)
 SECPOS   BSSZ   1           SECTOR BUFFER TRANSFER POSITION (TO CM)
 USEQ     CON    0           QUEUE HEAD OF LUT ENTRIES IN USE (ACTIVE)
 EMPTQ    CON    LUT         QUEUE HEAD OF LUT ENTRIES NOT IN USE
 NCOMRQ   CON    0           NUMBER OF COMPLETED REQUESTS
 BAF      BSSZ   1           =0 IF ADDRESS MUST BE BACKED UP AFTER AN ERROR
 SWFLG    BSSZ   1           NONZERO IF A STREAMING REQUEST SWITCH WAS MADE
 COMLOOK  BSSZ   1           INDEX INTO DEV TABLE (TABLE START IS IN CM.DEV)
 LUTLOC   CON    0           ADDRESS OF CURRENT LUT ENTRY
 CLCUR    BSSZ   1           CHANNEL 14 CURRENT CLOCK
 CLMCS    BSSZ   1           CLOCK, MICROSECOND
 CLMLS    BSSZ   1           CLOCK, MILLISECOND
 CLSEC    BSSZ   1           CLOCK, SECOND
 RECOV    BSSZ   1           STEP OF RECOVERY ALGORITHM
 CF       BSSZ   1           CONTINUE FLAG USED TO CONTROL RECOVERED RESPONSES
 CTRC     BSSZ   1           CLEAR T REGISTER COUNTER
          BSS    72B-*
 DSRTP    DATA   2,0         PP INTERFACE TABLE RMA WHEN PP LOADED
 FT       EQU    DSRTP       0 IF FIRST DATA FUNCTION AFTER SEEK
 INPNT    EQU    DSRTP+1     IN POINTER FOR RESPONSE BUFFER
 CA       BSSZ   1           CONTINUE ADDRESS
 PPNO     CON    1           LOGICAL PP NUMBER
 PTF      BSSZ   1           IF 0 EXECUTE PATH TEST
 CTF      BSSZ   1           IF 0 EXECUTE CONFIDENCE TEST
          EJECT
          BSS    100B-*
          LJM    INIT        USED FOR OFF-LINE TESTING
          DATA   5           895 DRIVER (FOR ANAD PROC)
 HANG     CON    0           AN EASY WAY TO SEE CERTAIN PP HUNG ERRORS
          UJN    *
*
*         THE FOLLOWING CM ADDRESSES ARE SET DURING INITIALIZATION.
*         THE BYTE ADDRESS IS
*           RIGHTMOST 10 BITS OF WORD 0 CONCATENATED WITH
*           RIGHTMOST 12 BITS OF WORD 1 CONCATENATED WITH
*           RIGHTMOST 6 BITS OF WORD 2 CONCATENATED WITH
*           3 BITS OF ZEROS.

 CM.RS    BSSZ   3           CM ADDRESS OF RESPONSE BUFFER (REFORMATTED)
 CM.CB    BSSZ   3           CM ADDRESS OF PP COMMUNICATION BUFFER (REFORMATTED)
 CM.INT   BSSZ   3           CM ADDRESS OF INTERRUPT WORD (REFORMATTED)
 CM.CHAN  BSSZ   3           CM ADDRESS OF CHANNEL INTERLOCK TABLE (REFORMATTED)
 CTBRMA   BSSZ   2           CM ADDRESS OF CONFIDENCE TEST BUFFER
 IDLE     BSSZ   1           NONZERO IF IDLE COMMAND RECEIVED,
                               RESUME COMMAND RESETS IT TO 0
 STORS    BSSZ   1           STORE RESPONSE FLAG (USED BY RESPIN)
                               = 0, IF A RESPONSE IS SENT TO CM
                               = NONZERO, IF NO RESPONSE WAS SENT TO CM
 FUNCD    BSSZ   1           FUNCTION CODE
 FCOMRQ   BSSZ   2           FIRST COMPLETED REQUEST (RMA)
 CURRQ    BSSZ   2           RMA OF CURRENT REQUEST
 PRERQ    BSSZ   2           RMA OF PREVIOUS REQUEST
 CHLOCK   BSSZ   1           CLEARED IF CHANNEL LOCK IS SET
 CHLCNT   CON    C.CHCNT     NUMBER OF REQUESTS TO PROCESS BEFORE
                              CLEARING CHANNEL LOCK
 UTSAVE   BSSZ   1           STARTING OFFSET ON AN LUT SCAN
 NUMCM    BSSZ   1           NUMBER OF COMMANDS LEFT TO PROCESS IN THIS REQUEST
 FRST     BSSZ   1           = 0, IF FIRST TIME THROUGH UNCMND
 LIM      BSSZ   1           LIMIT OF RESPONSE BUFFER (IN 8-BIT BYTES)
 LCF      BSSZ   1           NONZERO IF CCC LOAD IN PROGRESS
 SIP      BSSZ   1           SEEK IN PROGRESS IF ZERO
 MD       BSSZ   1           = 0 IF NO MORE DATA TO TRANSFER
 DMF      BSSZ   1           DATA MISCOMPARE FLAG FOR CONFIDENCE TEST
 SPLUT    BSSZ   6           SPARE LOGICAL UNIT TABLE FOR CONFIDENCE TEST
 FBUF     CON    0           FIRST OF FORMAT PACK PARAMETERS
 FUN      CON    2300B
          CON    4000B       SET TO SPECIFY 4K SECTORS
 F        IFEQ   FE,1        FORCE ERROR CODE
 FEST     BSSZ   1           PASSES BEFORE FORCING ERROR
 FEND     BSSZ   1           NUMBER OF TIMES TO FORCE ERROR
 F        ENDIF


 C.CHCNT  EQU    37          NUMBER OF REQUESTS TO PROCESS BEFORE
                             CLEARING CHANNEL LOCK
 LUT      BSSZ   NOU*P.LUT   LOGICAL UNIT TABLES FOR 8 UNITS
 SS       BSSZ   P.SS        INFORMATION ABOUT THE SELECTED REQUEST
 RQ       BSSZ   P.RQ        THE REQUEST BEING PROCESSED
 CM       EQU    RQ+/RQ/P.CMND  COMMAND PORTION OF THE REQUEST
 CMLIST   BSSZ   P.CM        ONE ADDRESS AND LENGTH PAIR POINTING TO CM DATA
 RS       BSSZ   P.RS        RESPONSE BUFFER
 TL       EQU    *-LUT       LENGTH OF TABLES TO CLEAR AT INITIALIZATION
 IPIT     EQU    17600B      PP INTERFACE TABLE DURING INITIALIZATION
 UBUF     EQU    IPIT+P.PIT  UNIT INTERFACE TABLE DURING INITIALIZATION
 IBUF     EQU    UBUF+P.UIT  UNIT DESCRIPTIOR DURING INITIALIZATION
 CWBUF    EQU    RS+/RS/P.DETAIL START OF BUFFER FOR LOADING CONTROLWARE
 CTLN     EQU    5           LENGTH OF BUFFER USED FOR LOADING (CM WORDS)
          TITLE  MAIN DRIVER LOOP
** NAME -- MAIN
*
** PURPOSE -- THE MAIN DRIVER LOOP
*
** ENTRY
*         MAIN - FROM INIT AFTER DRIVER IS LOADED
*              - WHEN RESUME RECEIVED
*         MAIN5 - WHEN RETRYING A CONFIDENCE TEST ERROR
*               - WHEN EQUIPMENT IS DOWNED
*         MAIN30 - WHEN RETRYING A DISK REQUEST
*         MAIN45 - WHEN REQUEST COMPLETES WITHOUT ERROR
*                - IF MEDIA ERROR
          SPACE  2
 MAIN     BSS
          LOADOVL ITO        LOAD INITIALIZE TABLE OVERLAY
          RJM    IT          INITIALIZE TABLES
 MAIN5    BSS
          LOADOVL PTO        PATH TEST OVERLAY
          RJM    PT          PATH TEST
          LOADOVL CTO        LOAD CONFIDENCE TEST OVERLAY
          RJM    CT          CONFIDENCE TEST
 MAIN10   BSS
 F        IFEQ   FE,1        FORCE ERROR CODE
          RJM    FER         CHECK FOR AN ERROR TO FORCE
 F        ENDIF
          RJM    PPREQ       CHECK FOR ANY PP REQUESTS
          RJM    GETUD       SET UP NEW REQUESTS
          LDDL   USEQ
          ZJK    MAIN45      IF NO SEEKS ARE OUTSTANDING
          RJM    POLLON      POLL FOR ON-CYLINDER
          ZJK    MAIN10      IF A SEEK HAS NOT COMPLETED
          RJM    UREQ        READ UNIT REQUEST FROM CM
          RJM    SETRQ       SET UP FOR FIRST REQUEST
          RJM    SRESP       SET UP RESPONSE BUFFER
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
 MAIN30   BSS
          LDN    0
          STDL   SWFLG       CLEAR SWITCH FLAG
          STDL   SECPOS      SET SECTOR POSITION = 0
          LDML   UCMDPR,FNC  GET COMMAND PROCESSOR
          STDL   T1
          RJM    0,T1        PROCESS COMMAND
          LDN    F.OPCMP
          RJM    FUNC        RELEASE THE DRIVE
          LDDL   CF
          ZJN    MAIN40      IF CONTINUE NOT SENT
          LDML   RS+/RS/P.RTRY
          NJN    MAIN40      IF ERROR ALREADY REPORTED
          LDN    0
          STML   RS+/RS/P.SHORT  INDICATE ERROR RESPONSE
          LDK    C.RS*8
          STML   RS+/RS/P.RESPL  ERROR RESPONSE LENGTH
          LDC    0#5000
          STML   RS+/RS/P.RC  RECOVERED, INTERMEDIATE RESPONSE
          RJM    TERMP       SEND RECOVERED RESPONSE
 MAIN40   BSS
          LJM    TERM        SEND TERMINATION RESPONSE
 MAIN45   BSS
          SOML   CHLCNT
          NJN    MAIN55      IF PP DOESN'T HAVE TO GIVE UP CHANNEL
          RJM    CKC         CHECK IF CHANNEL MUST BE GIVEN UP
 MAIN55   BSS
          UJK    MAIN10

* UNIT COMMANDS
 UCMD     BSS
          CON    C.READ
          CON    C.WRITE
          CON    C.FORMAT

* PP COMMANDS.

          CON    C.IDLE
          CON    C.RESUME
 UCMDL    EQU    *-UCMD

* UNIT COMMAND PROCESSORS.
 UCMDPR   BSS
          CON    READ        READ BYTES
          CON    WRITE       WRITE BYTES
          CON    FMT         FORMAT DISK
          TITLE  READ AND WRITE ROUTINES
          SPACE  5,20
** NAME-- READ
*
** PURPOSE-- PROCESS READ DATA COMMAND.
*
** INPUT-- CMLISTL = NUMBER OF ADDRESS-LENGTH ENTRIES IN THE
*                    COMMAND WHICH ARE LEFT TO PROCESS.
*          CMLIST  = A TABLE OF THE ADDRESS-LENGTH PAIRS POINTING TO
*                    THE CM DATA AREA.
*
          SPACE  2
 READX    LJM    **
 READ     EQU    *-1
          LDC    READ25
          STDL   BAF         BACKUP ADDRESS FLAG
          STDL   CA          CONTINUE ADDRESS
 READ5    BSS
          LDDL   SECPOS
          NJN    READ30      IF READ FUNCTION ALREADY SENT
          LDN    F.READ      ISSUE READ FUNCTION TO DISK CONTROLLER
          RJM    FUNC
 READ10   EQU    *-1         FOR FORCING ERRORS
 READ25   BSS
          RJM    UDA         UPDATE DISK ADDRESS
          LDN    1
          STDL   BAF         BACKUP ADDRESS FLAG
          UJN    READ35
 READ30   BSS
          RJM    WFTE        WAIT FOR T PRIME REGISTER EMPTY
 READ35   BSS
          LDML   CMLIST+/CM/P.LEN  BYTES LEFT TO TRANSFER
          STDL   BC
          ADC    -BPS+32     CM BYTES PER SECTOR
          ADDL   SECPOS      BYTES ALREADY TRANSFERRED
          MJN    READ40      IF LESS THAN ONE SECTOR TO TRANSFER
          LDC    BPS-32
          SBDL   SECPOS
          STDL   BC          NUMBER OF BYTES TO TRANSFER
 READ40   BSS
          LDML   CMLIST+/CM/P.RMA
          STDL   RMA
          LDML   CMLIST+/CM/P.RMA+1
          STDL   RMA+1
          RJM    WTR         WRITE T REGISTER
 READ50   EQU    *-1         FOR FORCING ERRORS
          LDDL   SECPOS
          NJN    READ60      IF DMA ALREADY STARTED
          LDC    F.SDI       START DMA INPUT
          RJM    FUNC
          RJM    SVPTR       SAVE CM BUFFER POINTERS
          LDN    0
          STDL   BAF         BACUP ADDRESS FLAG
          LDDL   SWFLG
          ZJN    READ60      IF SWITCH FLAG NOT SET
          RJM    SWITCH      SWITCH TO NEXT REQUEST
 READ60   BSS
          LDDL   BC
          RADL   SECPOS      UPDATE SECTOR POSITION
          ADC    -BPS+32
          ZJN    READ65      IF END OF SECTOR
          LDDL   CMLISTL
          SBN    1
          ZJN    READ65      IF ALL DATA FOR THIS SECTOR TRANSFERRED
          RJM    UBT         UPDATE BYTES TRANSFERRED
          UJK    READ5
 READ65   BSS
          RJM    UBT         UPDATE BYTES TRANSFERRED
          LDC    BPS
          SBDL   SECPOS
          STDL   BC          BYTES OF DON'T CARE DATA
          LDML   CTBRMA      RMA OF DON'T CARE DATA
          STDL   RMA
          LDML   CTBRMA+1
          STDL   RMA+1
          RJM    WFTE        WAIT FOR T PRIME REGISTER EMPTY
          RJM    WTR         WRITE T REGISTER
 READ70   EQU    *-1         FOR FORCING ERRORS
          LDN    0#2E        EXPECTED OPERATIONAL STATUS
          RJM    WFTC        WAIT FOR TRANSFER COMPLETE
 F        IFEQ   FE,1        FOR FORCING ERRORS
          LDC    1
 READ80   EQU    *-1
          SBN    1
          NJN    *-1
 F        ENDIF
          LDML   MD
          NJK    READ5       IF MORE DATA TO TRANSFER
          RJM    GENSTAT     GET LAST GENERAL STATUS
          ZJK    READX       IF NO ERROR
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- WRITE
*
** PURPOSE-- PROCESS THE WRITE DATA COMMAND.
*
** INPUT-- CMLISTL = NUMBER OF ADDRESS-LENGTH-PAIR ENTRIES IN THE
*                    COMMAND WHICH ARE LEFT TO PROCESS.
*          CMLIST = LIST OF ADDRESS-LENGTH-PAIRS POINTING TO THE
*                   CM DATA AREA.
          SPACE  2
 WRIX     LJM    **
 WRITE    EQU    *-1
 WRI5     BSS
          LDDL   SECPOS
          NJN    WRI30       IF WRITE FUNCTION ALREADY SENT
          LDN    F.WRITE     ISSUE WRITE FUNCTION TO DISK CONTROLLER
          RJM    FUNC        ISSUE THE FUNCTION
 WRI10    EQU    *-1         FOR FORCING ERRORS
          RJM    UDA         UPDATE DISK ADDRESS
          UJN    WRI35
 WRI30    BSS
          RJM    WFTE        WAIT FOR T PRIME REGISTER EMPTY
 WRI35    BSS
          LDML   CMLIST+/CM/P.LEN  BYTES LEFT TO TRANSFER
          STDL   BC
          ADC    -BPS+32     CM BYTES PER SECTOR
          ADDL   SECPOS      BYTES ALREADY TRANSFERRED
          MJN    WRI40       IF LESS THAN ONE SECTOR TO TRANSFER
          LDC    BPS-32
          SBDL   SECPOS
          STDL   BC          NUMBER OF BYTES TO TRANSFER
 WRI40    BSS
          LDML   CMLIST+/CM/P.RMA
          STDL   RMA
          LDML   CMLIST+/CM/P.RMA+1
          STDL   RMA+1
          RJM    WTR         WRITE T REGISTER
 WRI50    EQU    *-1         FOR FORCING ERRORS
          LDDL   SECPOS
          NJN    WRI60       IF DMA ALREADY STARTED
          LDC    F.SDO       START DMA OUTPUT
          RJM    FUNC
          LDDL   SWFLG
          ZJN    WRI60       IF SWITCH FLAG NOT SET
          RJM    SWITCH      SWITCH TO NEXT REQUEST
 WRI60    BSS
          LDDL   BC
          RADL   SECPOS      UPDATE SECTOR POSITION
          ADC    -BPS+32
          ZJN    WRI65       IF END OF SECTOR
          LDDL   CMLISTL
          SBN    1
          ZJN    WRI65       IF ALL DATA FOR THIS SECTOR TRANSFERRED
          RJM    UBT         UPDATE BYTES TRANSFERRED
          UJK    WRI5
 WRI65    BSS
          RJM    UBT         UPDATE BYTES TRANSFERRED
          LDC    BPS
          SBDL   SECPOS
          STDL   BC          BYTES OF DON'T CARE DATA
          LDML   CTBRMA      RMA OF DON'T CARE DATA
          STDL   RMA
          LDML   CTBRMA+1
          STDL   RMA+1
          RJM    WFTE        WAIT FOR T PRIME REGISTER EMPTY
          RJM    WTR         WRITE T REGISTER
 WRI70    EQU    *-1         FOR FORCING ERRORS
          LDN    0#32        EXPECTED OPERATIONAL STATUS
          RJM    WFTC        WAIT FOR TRANSFER COMPLETE
 F        IFEQ   FE,1        FOR FORCING ERRORS
          LDC    1
 WRI80    EQU    *-1
          SBN    1
          NJN    *-1
 F        ENDIF
          LDML   MD
          NJK    WRI5        IF MORE DATA TO TRANSFER
          RJM    GENSTAT     GET LAST GENERAL STATUS
          ZJK    WRIX        IF NO ERROR
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          TITLE  RESIDENT ROUTINES
** NAME-- ACN
*
** PURPOSE-- ACTIVATE THE CHANNEL.  THIS ROUTINE IS NECESSARY TO
*            ALLOW AN OVERLAY TO ACTIVATE THE CHANNEL.  THE CHANNEL
*            NUMBER CAN NOT BE SAVED IN AN OVERLAY.
          SPACE  2
 ACNX     LJM    **
 ACN      EQU    *-1
          ACN    DC
          UJN    ACNX
          SPACE  5,20
** NAME-- CCLOCK
*
** PURPOSE-- CLEARS CHANNEL LOCK.
*
          SPACE  2
 CCLX     LJM    **
 CCLOCK   EQU    *-1
          LDML   CHLOCK
          NJK    CCLX        IF CHANNEL LOCK WAS NOT SET
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   P6
          LDDL   CHAN        CHANNEL NUMBER = OFFSET IN TABLE
          STDL   T5
          RJM    CLOCK       CLEAR CHANNEL LOCKWORD
          LDN    1
          STML   CHLOCK      INDICATE CHANNEL LOCK CLEARED
          UJK    CCLX
          SPACE  5,20
** NAME-- CKC
*
** PURPOSE-- CHECK IF CHANNEL MUST BE GIVEN UP
          SPACE  2
 CKCX     LJM    **
 CKC      EQU    *-1
          LDN    C.CHCNT     NUMBER OF REQUESTS TO PROCESS BEFORE
          STML   CHLCNT       GIVING UP THE CHANNEL
          LOADC  CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          ADDL   CHAN        CHANNEL  NUMBER IS OFFSET IN TABLE
          CRDL   T1          READ CHANNEL LOCKWORD
          LDDL   T2
          LPN    1
          ZJK    CKCX        IF NOT GIVING UP THE CHANNEL
          LDDL   DEVL
          ZJK    CKCX        IF NO UNITS
          RJM    CCLOCK      CLEAR THE CHANNEL LOCK
          PAUSE  130000      DELAY TO ALLOW MAINTENANCE TO GET THE CHANNEL
          RJM    SCLOCK      SET CHANNEL LOCK
          STDL   CTF         SO ERROR WILL BE REPORTED AS UNSOLICITED
          STDL   PTF
          LJM    MAIN5
          SPACE  5,20
** NAME-- CLOCK
*
** PURPOSE-- CLEAR LOCKWORD
*
** ENTRY
*         P6 = POINTER RMA
*         T5 = OFFSET TO LOCKWORD FROM RMA
*
** EXIT
*         A = 0 IF LOCK WAS CLEARED
          SPACE  2
 CLKX     LJM    **
 CLOCK    EQU    *-1
 CLK10    BSS
          LCN    0
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,P6        INTERFACE TABLE ADDRESS
          ADDL   T5          ADD OFFSET
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE
          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJN    CLK10       IF INTERMEDIATE VALUE
          LDDL   T4
          SBDL   PPNO
          ZJN    CLK30       IF THIS PP HAS THE LOCK SET
          LDDL   T6
          LMC    400000B
          CWDL   T1          RESTORE THE ORIGINAL LOCKWORD
          LDN    1
          UJK    CLKX        EXIT, LOCKWORD NOT CLEARED
 CLK30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK
          LMC    400000B
          CWDL   T1          CLEAR THE LOCKWORD
          LDN    0
          UJK    CLKX        EXIT, LOCKWORD CLEARED
          SPACE  5,20
** NAME-- CLRLOCK
*
** PURPOSE-- CLEARS UNIT LOCK IN UNIT INTERFACE TABLE.
*
** ENTRY
*         LUTLOC - POINTER TO CURRENT LOGICAL UNIT TABLE
          SPACE  2
 CLRLX    LJM    **
 CLRLOCK  EQU    *-1
          LDDL   LUTLOC        UNIT INTERFACE TABLE ADDRESS
          ADN    /LUT/P.UIT
          STDL   P6
          LDN    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR UNIT LOCKWORD
          NJN    CLR10       IF LOCK COULD NOT BE CLEARED
          STML   /LUT/P.OWNER,LUTLOC  CLEAR LOCKED FLAG
          UJK    CLRLX
 CLR10    BSS
          RJM    HANG
          SPACE  5,20
** NAME-- CQLOCK
*
** PURPOSE-- CLEARS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
          SPACE  2
 CQLX     LJM    **
 CQLOCK   EQU    *-1
          LDDL   LUTLOC      UNIT INTERFACE TABLE ADDRESS
          ADN    /LUT/P.UIT
          STDL   P6
          LDN    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CQLX
          SPACE  5,20
** NAME-- CSWIT
*
** PURPOSE-- CHECK IF A SWITCH SHOULD BE MADE TO THE NEXT
*            REQUEST.
*
** EXIT-- A REGISTER = 0, IF NOT SWITCH.
*         A REGISTER NONZERO, IF SWITCH.
          SPACE  2
 CSW100   BSS
          LDN    0
 CSWX     LJM    **
 CSWIT    EQU    *-1
          LDDL   CF
          NJN    CSW100      IF IN RECOVERY, DON'T SWITCH
          LDML   RS+/RS/P.RTRY
          NJN    CSW100      IF IN RECOVERY, DON'T SWITCH

* RE-READ THE SWITCH FLAG AND LINKAGE WORDS.

          LDN    2           NUMBER OF WORDS TO READ
          STDL   WC
          LOADF  SS+/SS/P.REQ  LOAD CM ADDRESS AND REFORMAT
          ADN    2
          CRML   RQ+2*4,WC   READ CURRENT REQUEST
          SBN    4
          CRML   RQ,WC       READ SWITCH FLAG BEFORE LINKAGE POINTERS
          LDML   RQ+/RQ/P.SWIT  CHECK IF REQUEST SWITCH FLAG SET
          SHN    -16+/RQ/N.SWIT+/RQ/L.SWIT
          STDL   SWFLG       SAVE SWITCH FLAG
          ZJK    CSWX        IF SWITCH FLAG IS NOT SET
          LDML   RQ+/RQ/P.NEXT  PUT RMA OF NEXT REQUEST IN SS TABLE
          STML   SS+/SS/P.REQ
          LDML   RQ+/RQ/P.NEXT+1
          STML   SS+/SS/P.REQ+1
          LDML   RQ+/RQ/P.NEXTPV  PUT PVA OF NEXT REQUEST IN SS TABLE
          STML   SS+/SS/P.PVA
          LDML   RQ+/RQ/P.NEXTPV+1
          STML   SS+/SS/P.PVA+1
          LDML   RQ+/RQ/P.NEXTPV+2
          STML   SS+/SS/P.PVA+2
          RJM    UREQ        READ NEXT REQUEST INTO RQ
          RJM    SAVSS       WRITE SS TABLE TO CM
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
          LDN    1
          UJK    CSWX        EXIT NONZERO
          SPACE  5,20
** NAME-- CTR
*
** PURPOSE-- CONFIDENCE TEST RECOVERY (THE CONFIDENCE TEST IS
*            CONSIDERED SUCCESSFUL IF NO MORE THAN 3 SECTORS OF
*            A CYLINDER HAVE UNRECOVERABLE MEDIA ERRORS)
*
** EXIT-- TO CALLING ROUTINE WITH
*           A = 0  DATA INTEGRITY ERROR OR MORE THAN 3 MEDIA ERRORS
*           A NOT 0  IF NOT A MEDIA ERROR
*         TO CTDT ROUTINE IF MEDIA ERROR
          SPACE  2
 CTR100   BSS
          LMN    4
 CTRX     LJM    **
 CTR      EQU    *-1
          RJM    RDT         READ DEVICE TABLE
          SHN    -1
          NJN    CTR100      IF NOT IN CONFIDENCE TEST
          LDML   RS+/RS/P.DET
          LMN    1
          NJN    CTRX        IF NOT MEDIA ERROR
          LDML   RS+/RS/P.GENST1
          LMC    GS5020
          NJN    CTRX        IF NOT MEDIA ERROR
          LDML   RS+/RS/P.DETAIL+4
          LPN    17B
          SBN    4
          ZJN    CTR10       IF FORMAT 4 (MEDIA ERROR)
          SBN    1           CHECK FOR FORMAT 5
          NJK    CTRX        IF NOT MEDIA ERROR
 CTR10    BSS
          STDL   T6          CLEAR INDEX TO MEDIA ERROR TABLE
          LDML   SS+/SS/P.TRACK
          LPN    77B
          SHN    8
          ADML   SS+/SS/P.SECTOR
          STDL   T5
 CTR20    BSS
          LDML   SS+CTME,T6
          SHN    2
          MJN    CTR30       IF TABLE ENTRY AVAILABLE
          SHN    -2
          LMDL   T5
          ZJN    CTR30       IF SECTOR IN TABLE
          AODL   T6
          LMN    3
          NJN    CTR20       IF MORE ENTRIES TO CHECK
          UJK    CTRX
*
*         THE CONFIDENCE TEST OVERLAY MUST ALREADY BE LOADED.  LOADING IT
*         HERE WOULD DESTROY RETURN JUMP ADDRESSES.
*
 CTR30    BSS
          LDDL   T5
          STML   SS+CTME,T6  PUT ADDRESS IN TABLE
          LDN    1
          STDL   FT          SO UDA WILL UPDATE ADDRESS
          RJM    UDA         UPDATE DISK ADDRESS
          LDDL   FNC
          ZJN    CTR40       IF READ
          LDML   SS+/SS/P.TRACK
          LPN    77B
          SBN    MAXTR+1
          ZJK    CTDT45      IF ERROR WAS ON LAST SECTOR OF CYLINDER
          LDN    0
          STDL   FT          INDICATE FIRST FUNCTION
          LJM    CTDT5       CONTINUE WRITING
 CTR40    BSS
          LDML   SS+/SS/P.TRACK
          LPN    77B
          SBN    MAXTR+1
          ZJK    CT80        IF ERROR WAS ON LAST SECTOR OF CYLINDER
          LDN    0
          LJM    CTDT50
          SPACE  5,20
** NAME-- DCN
*
** PURPOSE-- WAIT FOR CHANNEL EMPTY, THEN DISCONNECT THE CHANNEL
          SPACE  2
 DCNX     BSS
          DCN    DC+40B      DISCONNECT THE CHANNEL
          LJM    **
 DCN      EQU    *-1
          LCN    0
 DCN10    BSS
          EJM    DCNX,DC     IF CHANNEL EMPTY
          SBN    1
          NJN    DCN10       IF TIMEOUT NOT EXPIRED
          STML   RS+/RS/P.FUNTO  WORDS NOT TRANSFERRED
          LDN    E05         INCOMPLETE CHANNEL TRANSFERR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- DELRQ
*
** PURPOSE-- DELETE COMPLETED REQUEST FROM THE UNIT QUEUE.
*            SELECT THE NEXT REQUEST ON THE QUEUE IF ONE IS PRESENT.
*
** INPUTS-- SS+/SS/P.UQT = POINTER TO UNIT INTERFACE TABLE
*
** OUTPUTS-- T8 IS UNCHANGED
          SPACE  2
 DELX     LJM    **
 DELRQ    EQU    *-1
 DEL2     BSS
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    DEL2        IF LOCK COULD NOT BE SET

* DECREMENT QUEUE COUNTER.

          LOADR  SS+/SS/P.UQT  ADDRESS OF UNIT INTERFACE TABLE
          STDL   T1
          CRDL   P1          READ QUEUE COUNT
          LDDL   P1+/UIT/P.QCNT  DECREMENT QUEUE COUNT
          SBDL   NCOMRQ      NUMBER OF COMPLETED REQUESTS
          STDL   P1+/UIT/P.QCNT
          MJN    DEL3        IF INVALID QUEUE COUNT
          LDDL   T1
          LMC    400000B
          CWDL   P1          WRITE QUEUE COUNT

* RE-READ RMA CHAIN POINTERS OF CURRENT REQUEST.

 DEL3     BSS
          LDN    2
          STDL   P3
          LOADF  CURRQ       RMA OF CURRENT REQUEST
          CRML   RQ,P3       READ RMA CHAIN OF CURRENT REQUEST

          LOADR  SS+/SS/P.DP  DELINK POINTER
 DEL15    BSS
          STDL   P2
          ADN    1           POINT TO RMA INSTEAD OF PVA
          CRDL   T1          RMA OF A REQUEST
          LDDL   T3
          LMML   FCOMRQ
          NJN    DEL20       IF NOT COMPLETED REQUEST
          LDDL   T4
          LMML   FCOMRQ+1
          ZJN    DEL30       IF THIS IS A COMPLETED REQUEST
 DEL20    BSS
          LOADF  T3          UPDATE DELINK POINTER TO NEXT
          STML   SS+/SS/P.DP+2   REQUEST IN THE CHAIN
          LDDL   CMADR
          STML   SS+/SS/P.DP
          LDDL   CMADR+1
          STML   SS+/SS/P.DP+1
          LDDL   CMADR+2
          LMC    400000B
          UJN    DEL15

* DELINK COMPLETED REQUESTS.
* (P3 = 2.)

 DEL30    BSS
          LDDL   P2          CM ADDRESS OF REQUEST
          LMC    400000B
          CWML   RQ,P3       PVA AND RMA OF NEXT REQUEST IN CHAIN

*         SELECT NEXT REQUEST ON QUEUE

          LDN    0
          STDL   NCOMRQ      CLEAR COMPLETED REQUEST COUNT
          STML   SS+/SS/P.ENTRY  INDICATE NO REQUEST SELECTED
          LDML   RQ+/RQ/P.NEXT
          ADML   RQ+/RQ/P.NEXT+1
          NJN    DEL35       IF REQUEST EXISTS
          LDDL   P4
          ZJK    DEL40       IF QUEUE EMPTY
          RJM    SELRQ       SELECT FIRST REQUEST ON QUEUE
          UJK    DELX
 DEL35    BSS
          RJM    CQLOCK      CLEAR QUEUE LOCK
          LDML   RQ+/RQ/P.NEXT  SAVE RMA OF NEXT REQUEST
          STML   SS+/SS/P.REQ
          LDML   RQ+/RQ/P.NEXT+1
          STML   SS+/SS/P.REQ+1
          LDML   RQ+/RQ/P.NEXTPV  SAVE PVA OF NEXT REQUEST
          STML   SS+/SS/P.PVA
          LDML   RQ+/RQ/P.NEXTPV+1
          STML   SS+/SS/P.PVA+1
          LDML   RQ+/RQ/P.NEXTPV+2
          STML   SS+/SS/P.PVA+2
          LDN    /SS/K.ENTRY
          STML   SS+/SS/P.ENTRY  INDICATE REQUEST SELECTED
          RJM    SSA         SET SEEK ADDRESS
          UJN    DEL45
 DEL40    BSS
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
 DEL45    BSS
          RJM    SAVSS       SAVE SHARED TABLE
          UJK    DELX
          SPACE  5,20
** NAME-- DS
*
** PURPOSE-- GET DETAILED STATUS.  THIS PROVIDES MORE INFORMATION FOR AN
*            ERROR.  IT IS NOT THE CAUSE OF AN ERROR, SO AN ERROR TRYING
*            TO GET DETAILED STATUS DOES NOT GENERATE AN ERROR.
*
** NOTE -- MUST BE RESIDENT DUE TO CHANNEL INSTRUCTIONS
          SPACE  2
 DSX      LJM    **
 DS       EQU    *-1
          LDDL   GNSTAT
          STML   RS+/RS/P.GENST1 PUT GENERAL STATUS IN RESPONSE
          STML   RS+/RS/P.GENST2
          DCN    DC+40B      ENSURE THE CHANNEL IS INACTIVE
          LDN    F.EDS
          FAN    DC          ISSUE DETAILED STATUS FUNCTION
          LCN    0
 DS5      BSS
          IJM    DS10,DC     IF CHANNEL INACTIVE
          SBN    1
          NJN    DS5         IF TIMEOUT NOT EXPIRED
          UJK    DSX
 DS10     BSS
          LDN    20
          STDL   T1
          ACN    DC
          IAM    RS+/RS/P.DETAIL,DC INPUT DETAILED STATUS
          SFM    DS20,DC     IF ERROR
          NJN    DS20        IF ERROR
          LDN    1
          STML   RS+/RS/P.DET INDICATE DETAILED STATUS PRESENT
 DS20     BSS
          LDML   RS+/RS/P.DETAIL-1,T1 MAKE FIRST AND LAST DETAILED
          STML   RS+/RS/P.DETAIL+19,T1  STATUS THE SAME
          SODL   T1
          NJN    DS20
          UJK    DSX
          SPACE  5,20
** NAME-- EFP
*
** PURPOSE-- ERROR FLAG PROCESSING
          SPACE  2
 EFP      CON    0
          RJM    RES         READ ERROR STATUS REGISTER
          STML   RS+/RS/P.LERREG
          STML   RS+/RS/P.FERREG
          SHN    4
          PJN    EFP5        IF NOT UNCORRECTED CM RESPONSE
          LDN    E12
          UJN    EFP30
 EFP5     BSS
          SHN    1
          PJN    EFP10       IF NOT CM REJECT
          LDN    E13
          UJN    EFP30
 EFP10    BSS
          SHN    1
          PJN    EFP15       IF NOT INVALID CM RESPONSE
          LDN    E14
          UJN    EFP30
 EFP15    BSS
          SHN    1
          PJN    EFP20       IF NOT CM RESPONSE CODE PARITY ERROR
          LDN    E15
          UJN    EFP60
 EFP20    BSS
          SHN    1
          PJN    EFP25       IF NOT CMI READ DATA PARITY ERROR
          LDN    E16
          UJN    EFP60
 EFP25    BSS
          SHN    2
          PJN    EFP35       IF NOT OVERFLOW ERROR
          LDN    E17
 EFP30    BSS
          UJN    EFP60
 EFP35    BSS
          SHN    5
          PJN    EFP40       IF NOT KZ BOARD ERROR
          LDN    E02
          UJN    EFP60
 EFP40    BSS
          SHN    1
          PJN    EFP45       IF NOT JY BOARD ERROR
          LDN    E18
          UJN    EFP60
 EFP45    BSS
          SHN    1
          PJN    EFP50       IF NOT KX BOARD ERROR
          LDN    E03
          UJN    EFP60
 EFP50    BSS
          LDN    E04         CHANNEL ERROR
 EFP60    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- EP
*
** PURPOSE-- ERROR PROCESSING
*
** ENTRY
*         CA - ADDRESS TO GO FOR CONTINUE RECOVERY
*         COMLOOK - INDEX TO TABLE FOR FAILING UNIT
*         LUTLOC - POINTER TO LOGICAL UNIT TABLE
          SPACE  2
 EP       CON    0
          LDML   RS+/RS/P.RTRY
          NJN    EP5         IF NOT FIRST ERROR FOR REQUEST
          STDL   RECOV       CLEAR INDEX TO RECOVERY STEP
 EP5      BSS
          RJM    PPREQ       CHECK FOR IDLE REQUEST
          AODL   CTRC        INCREMENT CLEAR T REGISTER COUNTER
          LMN    3
          ZJK    EP15        IF CLEAR T REGISTER FAILS
          LDN    0
          STDL   FT          CLEAR FIRST TIME FLAG
          LDDL   CA
          ZJK    EP10        IF NOT SENDING CONTINUE
          LDDL   GNSTAT
          LMC    GS4400
          NJN    EP10        IF NOT SENDING CONTINUE
          LDML   RS+/RS/P.EC
          NJN    EP10        IF NOT SENDING CONTINUE (PARITY ERR ON GENSTAT)
          LDK    F.CTR       CLEAR T REGISTER
          RJM    FUNC
          LDN    0
          STDL   CTRC        CLEAR T REGISTER COUNTER
          LDN    F.CONT
          RJM    FUNC        SEND CONTINUE FUNCTION
          AODL   CF          INDICATE CONTINUE FUNCTION SENT
          LDDL   BAF         BACKUP ADDRESS FLAG
          NJN    EP7         IF ERROR ON CURRENT SECTOR
          RJM    RDT         READ DEVICE TABLE
          SHN    -1
          ZJN    EP7         IF ERROR DURING CONFIDENCE TEST
          LOADOVL ERO        LOAD ERROR RECOVERY OVERLAY
          RJM    RSTBP       RESTORE BACKUP POINTERS
 EP7      BSS
          LDN    0
          STDL   SECPOS      POINT TO BEGINNING OF SECTOR
          LJM    0,CA
 EP10     BSS
          LDK    F.CTR       CLEAR T REGISTER
          RJM    FUNC
 EP15     BSS
          LDN    0
          STDL   CTRC        CLEAR T REGISTER COUNTER
          LDDL   RECOV       INDEX TO RECOVERY PROCEDURE
          STDL   T1
          LDML   EPT,T1
          STDL   T1
          LJM    0,T1        EXECUTE NEXT STEP IN RECOVERY SEQUENCE
 EPT      BSS
          CON    EPA         RETRY THE REQUEST
          CON    EPB         CONFIDENCE TEST/FORMAT
          CON    EPC         AUTOLOAD CCC
          CON    EPD         LAST RECOVERY ATTEMPT FAILED
          CON    EPE         DOWN CHANNEL
          CON    EPF         DOWN UNIT
          CON    EPG         CLEAR UNIT LOCK
*
*         REQUEST RETRY
*
 EPA      BSS
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          RJM    CTR         CONFIDENCE TEST RECOVERY
          NJN    EPA20       IF ERROR LIMIT NOT REACHED
          AOML   RS+/RS/P.RTRY  REQUEST RETRY COUNTER
          UJK    EPC
 EPA20    BSS
          AOML   RS+/RS/P.RTRY  REQUEST RETRY COUNTER
          SBN    RTRY
          PJN    EPB         IF RETRY LIMIT
          UJK    EPC80
*
*         CONFIDENCE TEST/FORMAT UNIT
*
 EPB      BSS
          LDML   CTF
          ZJK    EPB20       IF IN SUBSYSTEM CONFIDENCE TEST
          LDDL   FNC
          SBN    2
          ZJK    EPD         IF FORMAT
          LDDL   RECOV
          LMN    1
          ZJN    EPB10       IF CONFIDENCE TEST ALREADY STARTED
          AODL   RECOV       INDEX TO NEXT RECOVERY STEP
          RJM    RDT         READ DEVICE TABLE
          LPN    /CB/K.ACT
          STDL   P2
          LDDL   CM.DEV+2
          ADDL   COMLOOK
          LMC    400000B
          CWDL   P2          ENABLE STARTING CONFIDENCE TEST
          LOADOVL CTO        LOAD CONFIDENCE TEST OVERLAY
          RJM    CT          CONFIDENCE TEST
          LDML   /LUT/P.OFFSET,LUTLOC
          STDL   COMLOOK     RESTORE INDEX TO DEVICE TABLE
          LJM    EPC80
 EPB10    BSS
          RJM    CTR         CONFIDENCE TEST RECOVERY
          UJN    EPC
 EPB20    BSS
          LDDL   PTF
          NJN    EPB30       IF PATH TEST COMPLETE
          LDN    4           EPE IS ENTRY FOR NEXT ERROR
          STDL   RECOV
          LJM    MAIN5
 EPB30    BSS
          LDN    0
          STDL   PTF         SO PATH TEST WILL BE RUN
          LOADOVL PTO        LOAD PATH TEST OVERLAY
          RJM    PT          EXECUTE PATH TEST
          LDN    3           EPD IS NEXT STEP IN RECOVRY ALGORITHM
          STDL   RECOV       DOWN UNIT IF FORMAT FAILS
          LOADOVL FMO        LOAD FORMAT OVERLAY
          LDC    MAXCYL-1
          STML   FBUF        CONFIDENCE TEST CYLINDER
          RJM    FC          FORMAT CONFIDENCE TEST CYLINDER
          LJM    MAIN5
*
*         AUTOLOAD CCC
*
 EPC      BSS
          LDDL   RECOV
          SBN    2
          ZJK    EPC50       IF LOAD ALREADY ATTEMPTED
          RJM    RDT         READ DEVICE TABLE
          SHN    -1
          SBN    1
          NJN    EPC40       IF CONFIDENCE TEST FAILED
          LDK    /RS/K.DATERR  INDICATE MEDIA ERROR
          STML   RS+/RS/P.HDWR
          LDC    R.ABN*0#4000  ABNORMAL TERMINATION
          STML   RS+/RS/P.RC  RESPONSE CODE
          RJM    RESP        SEND RESPONSE
          RJM    DELRQ       DELINK REQUEST
          LJM    EPE20
 EPC40    BSS
          ADN    1
          NJN    EPC50       IF ERROR CODE ALREADY STORED
          LDDL   P2
          LPN    1
          LMN    4
          STDL   P2
          LDDL   CM.DEV+2
          ADDL   COMLOOK
          ADC    400000B
          CWDL   P2          INDICATE CONFIDENCE TEST FAILED
 EPC50    BSS
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          LOADOVL PTO        LOAD NECESSARY OVERLAY
          LDML   RS+/RS/P.RTRY
          SBN    RTRY+1
          MJN    EPC60       IF NOT RETRY LIMIT
          LDN    4           DOWN CHANNEL IF CCC LOAD FAILS (EPE)
          UJN    EPC70
 EPC60    BSS
          LDN    2           RETRY LOAD IF LOAD FAILS (EPC)
 EPC70    BSS
          STDL   RECOV
          AOML   RS+/RS/P.RTRY  REQUEST RETRY COUNTER
          LDN    0
          STDL   PTF         SO PATH TEST WILL BE RUN
          RJM    PT          PATH TEST
          RJM    RDT         READ DEVICE TABLE
          SHN    -1
          LMN    4
          ZJK    EPF         DOWN UNIT IF DATA INTEGRITY ERROR
          LDML   RS+/RS/P.RTRY
          SBN    RTRY+2
          MJN    EPC80       IF NOT RETRY LIMIT
          LDN    3
          STDL   RECOV       NEXT STEP IS EPD
 EPC80    BSS
          LOADOVL ERO        LOAD ERROR RECOVERY OVERLAY
          RJM    RSTRQ       RESTART REQUEST (NO RETURN)
*
*         LAST RECOVERY ATTEMPT HAS FAILED, DOWN THE STORAGE
*         DIRECTOR OR THE DRIVE
*
 EPD      BSS
          LDML   RS+/RS/P.DET
          ZJK    EPF         IF NO DETAILED STATUS
          LDML   RS+/RS/P.GENST1
          LMC    0#A10
          NJK    EPF         IF NO SENSE BYTES
          LDML   RS+/RS/P.DETAIL
          SHN    7
          MJN    EPD10       IF STORAGE DIRECTOR FAILURE
          LDML   RS+/RS/P.DETAIL+4
          LPN    17B
          SBN    2
          MJK    EPF         IF NOT FORMAT 2 OR 3
          SBN    2
          PJK    EPF         IF NOT FORMAT 2 OR 3
 EPD10    BSS
          LDK    /RS/K.CMDN  STORAGE DIRECTOR DOWN
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          LOADOVL ERO        LOAD ERROR RECOVERY OVERLAY
          LDN    1           TURN OFF ALL UNITS ON STORAGE DIRECTOR
          UJN    EPE5
*
*         DOWN THE CHANNEL
*
 EPE      BSS
          LDK    /RS/K.CHDN  CHANNEL DOWNED
          STDL   PTF         TO PREVENT RUNNING PATH TEST
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          LOADOVL ERO        LOAD ERROR RECOVERY OVERLAY
          LDN    0           TURN OFF ALL UNITS ON CHANNEL
 EPE5     BSS
          RJM    OE          TURN OFF ALL UNITS ON THE EQUIPMENT
 EPE20    BSS
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          LDN    0
          STML   RS+/RS/P.HDWR  CLEAR STATUS WORD
          LDN    6
          STDL   RECOV       CLEAR UNIT LOCK IS NEXT STEP (EPG)
          LDN    F.OPCMP
          RJM    FUNC        ISSUE OPERATION COMPLETE
          UJN    EPG
*
*         DOWN THE UNIT
*
 EPF      BSS
          LOADOVL ERO        LOAD ERROR RECOVERY OVERLAY
          LDN    0           CLEAR THE REQUEST SELECTED FLAG
          STML   SS+/SS/P.ENTRY
          RJM    SAVSS       SAVE THE SS TABLE
          LDK    /RS/K.UDN   UNIT DOWNED
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RDT         READ DEVICE TABLE
          LOADC  P3          ADDRESS OF UNIT INTERFACE TABLE
          RJM    OFFUN       TURN OFF THE UNIT
          UJK    EPE20
*
*         CLEAR THE UNIT LOCK
*
 EPG      BSS
          RJM    WFUL        WAIT FOR UNIT LOCK.  THE PATH TEST DOES
                              NOT SET THE UNIT LOCK
          RJM    CLRLOCK     CLEAR UNIT LOCK
          STML   RS+/RS/P.RTRY  CLEAR REQUEST RETRY COUNTER
          LJM    MAIN5
          SPACE  5,20
** NAME-- EXLOD
*
** PURPOSE-- UTILITY TO EXECUTE A LOADC CM.CB MACRO.
*
** INPUT-- RJM EXLOD (NO PARAMETERS)
*
** OUTPUT-- R AND A REGISTERS CONTAIN ADDRESS OF COMMUNICATIONS BUFFER.
          SPACE  2
 EXLODX   LJM    **
 EXLOD    EQU    *-1
          LOADC  CM.CB
          UJN    EXLODX
 F        IFEQ   FE,1        FORCE ERROR CODE
          SPACE  5,20
** NAME-- FER
*
** PURPOSE-- FORCE ERROR ROUTINE.  THE ERROR CAN BE FORCED BY CHANGING
*            CENTRAL MEMORY AT BYTE 40.
          SPACE  2
 FERX     LJM    **
 FER      EQU    *-1
          LDN    8
          CRDL   P2          READ LOCATION WITH ERROR ROUTINE
          LDDL   P2
          ZJN    FERX        IF NOT FORCING AN ERROR
          STML   FEST
          LPN    77B
          STDL   P6          INDEX TO TABLE
          SBN    FETND-FET
          PJN    FERX        IF UNDEFINED VALUE
          LDN    0
          STDL   P2
          LDN    8
          CWDL   P2          INDICATE ERROR BEING FORCED
          LDML   FEST
          SHN    -8
          STML   FEST        FORCE ERROR START COUNT
          LDDL   P3
          STML   FEND        FORCE ERROR END COUNT
          LDML   FET,P6
          STDL   P2
          LJM    0,P2        JUMP TO FORCE ERROR ROUTINE
* TABLE OF ERRORS TO FORCE
 FET      BSS
          CON    FERX        NO ERROR
          CON    FERA        READ ONE TOO MANY WORDS
          CON    FERB        READ ONE TOO FEW WORDS
          CON    FERC        WRITE ONE TOO MANY WORDS
          CON    FERD        WRITE ONE TOO FEW WORDS
          CON    FERE        READ FUNCTION TIMEOUT
          CON    FERF        WRITE FUNCTION TIMEOUT
          CON    FERG        STATUS ERROR ON SEEK (ILLEGAL CYLINDER)
          CON    FERH        STATUS ERROR ON READ (ILLEGAL HEAD)
          CON    FERI        CHANGE ONE MEMORY LOCATION
          CON    FERJ        TEST TIMING ON READ
          CON    FERK        TEST TIMING ON WRITE
          CON    FERL        WRTIE CONTROL REG. TO FORCE ERROR ON READ
          CON    FERM        WRITE CONTROL REG. TO FORCE ERROR ON WRITE
          BSS    0           FERN (UNUSED)
          BSS    0           FERO (UNUSED)
          BSS    0           FERP - LOAD CONTROLWARE ERROR
          BSS    0           FERQ - FORMAT PACK ERROR
          BSS    0           FERR - PATH TEST ERROR
          BSS    0           FERS - CONFIDENCE TEST ERROR
          BSS    0           FERT - FORMAT WRONG RECORD SIZE
 FETND    BSS
          SPACE  5,20
** NAME-- FERA
*
** PURPOSE-- READ ONE TOO MANY WORDS
*
** ENTRY
*         40 = XX01 YYYY
*              X = BURSTS TO READ BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
*         50 = 00DD 00PP  DD = DRIVE NUMBER  PP = LOGICAL PP NUMBER
          SPACE  2
 FERA     BSS
          LDC    FERA10
          UJN    FERB5
 FERA10   CON    0
          LDN    10
          CRDL   T1
          LDML   SS+/SS/P.UNIT
          LMDL   T1
          NJK    FERB30      IF WRONG DRIVE
          LDDL   T2
          LMDL   PPNO
          NJK    FERB30      IF WRONG LOGICAL PP
          LDML   FEST
          NJN    FERB15      IF NOT TIME TO START FORCING ERROR
          LDML   FEND
          ZJN    FERB25      IF DONE FORCING ERRORS
          SOML   FEND
          LDN    2           READ ONE TOO MANY WORDS
          UJK    FERB37
          SPACE  5,20
** NAME-- FERB
*
** PURPOSE-- READ 1 TOO FEW WORDS
*
** ENTRY
*         40 = XX02 YYYY
*              X = BURSTS TO READ BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
*         50 = 00DD 00PP  DD = DRIVE NUMBER  PP = LOGICAL PP NUMBER
          SPACE  2
 FERB     BSS
          LDC    FERB10
 FERB5    BSS
          STML   READ70      MODIFY INSTRUCTION
          LJM    FERX
 FERB10   CON    0
          LDML   FEST
          ZJN    FERB20      IF FORCING THE ERROR
 FERB15   BSS
          SOML   FEST
          UJN    FERB30
 FERB20   BSS
          LDML   FEND
          NJN    FERB35      IF FORCING THE ERROR
 FERB25   BSS
          LDC    WTR         RESTORE INSTRUCTION
          STML   READ70
 FERB30   BSS
          UJN    FERB40
 FERB35   BSS
          SOML   FEND
          LCN    2           READ 1 TOO FEW WORDS
 FERB37   BSS
          RADL   BC
 FERB40   BSS
          RJM    WTR         WRITE TRANSFER REGISTER
          LJM    READ70+1
          SPACE  5,20
** NAME--FERC
*
** PURPOSE-- WRITE ONE TOO MANY WORDS
*
** ENTRY
*         40 = XX03 YYYY
*              X = BURSTS TO WRITE BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERC     BSS
          LDC    FERC10
          UJN    FERD5
 FERC10   CON    0
          LDML   FEST
          NJK    FERD15      IF NOT TIME TO START FORCING ERRORS
          LDML   FEND
          ZJK    FERD25      IF DONE FORCING ERRORS
          SOML   FEND
          LDN    2           WRITE ONE TOO MANY WORDS
          UJK    FERD37
          SPACE  5,20
** NAME-- FERD
*
** PURPOSE-- WRITE ONE TOO FEW WORDS
*
** ENTRY
*         40 = XX04 YYYY
*              X = BURSTS TO WRITE BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
*         50 = 00DD 00PP  DD = DRIVE NUMBER  PP = LOGICAL PP NUMBER
          SPACE  2
 FERD     BSS
          LDC    FERD10
 FERD5    BSS
          STML   WRI70       MODIFY INSTRUCTION
          LJM    FERX
 FERD10   CON    0
          LDN    10
          CRDL   T1
          LDML   SS+/SS/P.UNIT
          LMDL   T1
          NJK    FERD30      IF WRONG DRIVE NUMBER
          LDDL   T2
          LMDL   PPNO
          NJK    FERD30      IF WRONG LOGICAL PP
          LDML   FEST
          ZJN    FERD20      IF FORCING THE ERROR
 FERD15   BSS
          SOML   FEST
          UJN    FERD30
 FERD20   BSS
          LDML   FEND
          NJN    FERD35      IF FORCING THE ERROR
 FERD25   BSS
          LDC    WTR         RESTORE INSTRUCTION
          STML   WRI70
 FERD30   BSS
          UJN    FERD40
 FERD35   BSS
          SOML   FEND
          LCN    2           WRITE ONE TOO FEW WORDS
 FERD37   BSS
          RADL   BC
 FERD40   BSS
          RJM    WTR         WRITE T REGISTER
          LJM    WRI70+1
          SPACE  5,20
** NAME-- FERE
*
** PURPOSE--FORCE READ FUNCTION TIMEOUT ERROR
*
** ENTRY
*         40 = XX05 YYYY   FOR MASTER
*              X = BURSTS TO READ BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
*         50 = 00DD  00PP  DD= DRIVE NUMBER  PP = LOGICAL PP
          SPACE  2
 FERE     BSS
          LDC    FERE10      MODIFY INSTRUCTION
          STML   READ10
          LJM    FERX
 FERE10   CON    0
          LDN    10
          CRDL   T1
          LDML   SS+/SS/P.UNIT
          LMDL   T1
          NJK    FERE25      IF WRONG DRIVE NUMBER
          LDDL   T2
          LMDL   PPNO
          NJK    FERE25      IF WRONG LOGICAL PP
          LDML   FEST
          NJN    FERE20      IF NOT TIME TO FORCE ERROR
          LDML   FEND
          NJN    FERE30      IF FORCING AN ERROR
          LDC    FUNC        RESTORE INSTRUCTION
          STML   READ10
          UJN    FERE25
 FERE20   BSS
          SOML   FEST
 FERE25   BSS
          LDN    F.READ
          UJN    FERE35
 FERE30   BSS
          SOML   FEND
          LDN    3           A FUNCTION THAT GETS NO REPLY
 FERE35   BSS
          RJM    FUNC
          LJM    READ10+1
          SPACE  5,20
** NAME-- FERF
*
** PURPOSE-- FORCE FUNCTION TIMEOUT ON WRITE
*
** ENTRY
*         40 = XX06 YYYY   FOR MASTER
*              X = BURSTS TO READ BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
*         50 = 00DD 00PP  DD = DRIVE NUMBER  PP = LOGICAL PP
          SPACE  2
 FERF     BSS
          LDC    FERF10      MODIFY INSTRUCTION
          STML   WRI10
          LJM    FERX
 FERF10   CON    0
          LDN    10
          CRDL   T1
          LDML   SS+/SS/P.UNIT
          LMDL   T1
          NJK    FERF25      IF WRONG DRIVE NUMBER
          LDDL   T2
          LMDL   PPNO
          NJK    FERF25      IF WRONG LOGICAL PP
          LDML   FEST
          NJN    FERF20      IF NOT TIME TO FORCE ERROR
          LDML   FEND
          NJN    FERF30      IF FORCING AN ERROR
          LDC    FUNC
          STML   WRI10
          UJN    FERF25
 FERF20   BSS
          SOML   FEST
 FERF25   BSS
          LDN    F.WRITE
          UJN    FERF35
 FERF30   BSS
          SOML   FEND
          LDN    3           A FUNCTION THAT GETS NO REPLY
 FERF35   BSS
          RJM    FUNC
          LJM    WRI10+1
          SPACE  5,20
** NAME-- FERG
*
** PURPOSE-- FORCE STATUS ERROR ON SEEK DUE TO SENDING AN ILLEGAL CYLINDER
*            NUMBER
*
** ENTRY
*         40 = XX07 YYYY   FOR MASTER
*              X = BURSTS TO READ BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
*         50 = 00DD 00PP  DD = DRIVE NUMBER  PP = LOGICAL PP NUMBER
          SPACE  2
 FERG     BSS
          LDC    FERG10      MODIFY INSTRUCTION
          STML   SEEK10
          LJM    FERX
 FERG10   CON    0
          LDN    10
          CRDL   T1
          LDML   SS+/SS/P.UNIT
          LMDL   T1
          NJK    FERH40      IF NOT TIME TO FORCE THE ERROR
          LDDL   T2
          LMDL   PPNO
          NJK    FERH40
          LDML   FEST
          NJK    FERH30      IF NOT TIME TO FORCE ERROR
          LDML   FEND
          ZJN    FERH15      IF DONE FORCING ERRORS
          LDC    886         ILLEGAL CYLINDER NUMBER
          STML   SS+/SS/P.CYL
          UJN    FERH25
          SPACE  5,20
** NAME-- FERH
*
** PURPOSE-- FORCE A STATUS ERROR ON WRITE OR READ BY SENDING AN ILLEGAL
*            HEAD NUMBER
*
** ENTRY
*         40 = XX08 YYYY   FOR MASTER
*              X = BURSTS TO READ BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERH     BSS
          LDC    FERH10      MODIFY INSTRUCTION
          STML   SEEK10
          LJM    FERX
 FERH10   CON    0
          LDML   FEST
          NJN    FERH30      IF NOT TIME TO FORCE ERROR
          LDML   FEND
          NJN    FERH20      IF FORCING AN ERROR
 FERH15   BSS
          LDC    FUNC        RESTORE INSTRUCTION
          STML   SEEK10
          UJN    FERH40
 FERH20   BSS
          LDK    4017B       ILLEGAL HEAD NUMBER
          STML   SS+/SS/P.TRACK
 FERH25   BSS
          SOML   FEND
          UJN    FERH40
 FERH30   BSS
          SOML   FEST
 FERH40   BSS
          LDN    F.SEEK
          RJM    FUNC
          LJM    SEEK10+1
          SPACE  5,20
** NAME-- FERI
*
** PURPOSE-- CHANGE ONE MEMORY LOCATION
*         40 = 0009 0000 XXXX YYYY
*              X = ADDRESS
*              Y = VALUE
          SPACE  2
 FERI     BSS
          LDDL   P5
          STIL   P4
          LJM    MAIN10
          SPACE  5,20
** NAME-- FERJ
*
** PURPOSE-- TEST TIMING MARGIN ON A READ
*
** ENTRY
*         40 - 000A XXXX
*              XXXX TIMES .5 IS THE USEC DELAY PER READ FUNCTION
          SPACE  2
 FERJ     BSS
          LDDL   P3
          STML   READ80      MODIFY DELAY
          UJN    FERK10
          SPACE  5,20
** NAME-- FERK
*
** PURPOSE-- FORCE OVERRUN ERROR/TEST TIMING MARGIN ON A WRITE
*
** ENTRY
*         40 - 000B XXXX
*              XXXX TIMES .5 IS THE USEC DELAY PER WRITE FUNCTION
          SPACE  2
 FERK     BSS
          LDDL   P3
          STML   WRI80       MODIFY DELAY
 FERK10   BSS
          LJM    FERX
          SPACE  5,20
** NAME-- FERL
*
** PURPOSE-- WRITE CONTROL REGISTER TO FORCE AN ERROR ON READ
*
** ENTRY
*         40 = XX0C YYYY
*              X = BURSTS TO READ BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
*         50 = 00DD 00PP  DD = DRIVE NUMBER  PP = LOGICAL PP NUMBER
*         54 = CCCC  CCCC = CONTROL REGISTER VALUE
*                2100        SELECT 60-BIT CM WORD
*                500         INHIBIT FULL OUT
*                181         INVERT FUNCTION DECODE PROM PARITY
*                182         INVERT PP INPUT DATA PARITY
*                184         FORCE INVALID RESPONSE
*                185         INVERT RESPONSE CODE PARITY
*                186         INVERT CONTROL REGISTER PARITY
*                188         INVERT 12/16 SHIFTER PARITY
*                189         INVERT CONVERSION PARITY
*                18A         INVERT TRANSMIT PARITY
*                18B         INVERT CHANNEL INPUT DATA PARITY
*                190         FORCE ADAPTER INPUT PARITY BIT 0 LOW
*                191         FORCE ADAPTER INPUT PARITY BIT 1 LOW
*                192         FORCE T DATA PARITY BIT LOW
*                193         INVERT UPPER ADAPTER OUTPUT PARITY BIT
*                194         INVERT LOWER ADAPTER OUTPUT PARITY BIT
*                195         FORCE ADDRESS PARITY PREDICTION ERROR
*                196         FORCE BYTE COUNT EQUAL TO 0 ON JY BOARD
          SPACE  2
 FERL     BSS
          LDC    FERL10
          STML   READ50      MODIFY INSTRUCTION
          LJM    FERX
 FERL10   CON    0
          LDN    10
          CRDL   T1
          LDML   SS+/SS/P.UNIT
          LMDL   T1
          NJK    FERL40      IF WRONG DRIVE
          LDDL   T2
          LMDL   PPNO
          NJK    FERL40      IF WRONG LOGICAL PP
          LDML   FEST
          ZJN    FERL20      IF FORCING THE ERROR
          SOML   FEST
          UJN    FERL40
 FERL20   BSS
          LDML   FEND
          NJN    FERL35      IF FORCING THE ERROR
          LDC    WTR         RESTORE INSTRUCTION
          STML   READ50
          UJN    FERL40
 FERL35   BSS
          SOML   FEND
          LDDL   T3          VALUE TO STORE IN CONTROL REGISTER
          RJM    WCR         WRITE CONTROL REGISTER
 FERL40   BSS
          RJM    WTR         WRITE TRANSFER REGISTER
          LJM    READ50+1
          SPACE  5,20
** NAME-- FERM
*
** PURPOSE-- WRITE CONTROL REGISTER TO FORCE AN ERROR ON WRITE
*
** ENTRY
*         40 = XX0D YYYY
*              X = BURSTS TO WRITE BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
*         50 = 00DD 00PP  DD = DRIVE NUMBER  PP = LOGICAL PP NUMBER
*         54 = CCCC  CCCC = CONTROL REGISTER VALUE (SAME AS ROUTINE FERL)
          SPACE  2
 FERM     BSS
          LDC    FERM10
          STML   WRI50       MODIFY INSTRUCTION
          LJM    FERX
 FERM10   CON    0
          LDN    10
          CRDL   T1
          LDML   SS+/SS/P.UNIT
          LMDL   T1
          NJK    FERM40      IF WRONG DRIVE
          LDDL   T2
          LMDL   PPNO
          NJK    FERM40      IF WRONG LOGICAL PP
          LDML   FEST
          ZJN    FERM20      IF FORCING THE ERROR
          SOML   FEST
          UJN    FERM40
 FERM20   BSS
          LDML   FEND
          NJN    FERM35      IF FORCING THE ERROR
          LDC    WTR         RESTORE INSTRUCTION
          STML   WRI50
          UJN    FERM40
 FERM35   BSS
          SOML   FEND
          LDDL   T3          VALUE TO STORE IN CONTROL REGISTER
          RJM    WCR         WRITE CONTROL REGISTER
 FERM40   BSS
          RJM    WTR         WRITE TRANSFER REGISTER
          LJM    WRI50+1
          SPACE  5,20
** NAME-- FERP
*
** PURPOSE-- FORCE AN ERROR DURING LOADING OF CCC CONTROLWARE.  ONLY
*            THE DOCUMENTATION IS HERE.  THE LOAD CONTROLWARE ROUTINE
*            READS CENTRAL MEMORY AT BYTE 20
*                20 - 0010 XXXX
*            IF THE CODE OF 0010 IS PRESENT AND XXXX IS NONZERO, THE
*            LAST 40 WORDS OF CCC CONTROLWARE WILL NOT BE LOADED.  THIS
*            WILL FORCE A CHECKSUM ERROR.  XXXX IS THE NUMBER OF TIMES
*            TO FORCE THE ERROR.
          SPACE  5,20
** NAME-- FERQ
*
** PURPOSE-- FORCE AN ERROR DURING FORMAT OF A PACK.  ONLY THE DOCUMENTAION
*            IS HERE.  THE FORMAT ROUTINE READS AT BYTE LOCATION 20
*                20 - 0011 XXXX
*            IF THE CODE OF 0011 IS PRESENT AND XXXX IS NONZERO, THE FORMAT
*            PACK COMMAND WILL BE ISSUED TO THE CCC WITH AN ILLEGAL CYLINDER
*            NUMBER.  XXXX WILL BE DECREMENTED BY ONE FOR EACH ERROR FORCED.
          SPACE  5,20
** NAME-- FERR
*
** PURPOSE-- FORCE AN ERROR DURING THE PATH TEST.  ONLY THE DOCUMENTAION IS
*            HERE.  THE PATH TEST ROUTINE READS CM AT BYTE LOCATION 20
*                20 - 0012 XXXX
*            IF THE CODE IS 0012 AND XXXX IS NONZERO, THE PATH TEST WILL
*            WRITE THE WRONG PATTERN, WHICH WILL RESULT IN A DATA MISCOMPARE.
*            XXXX WILL BE DECREMENTED BY ONE FOR EACH ERROR FORCED.
          SPACE  5,20
** NAME-- FERS
*
** PURPOSE-- FORCE AN ERROR DURING THE CONFIDENCE TEST AND VERIFY TIMING
*            MARGINS FOR THE WRITE AND READ ROUTINES DURING THE CONFIDENCE
*            TEST.  IF THE CODE IS 0013, THEN THE DELAY COUNTS XXXX AND
*            YYYY WILL BE USED RATHER THAN THE DEFAULT VALUE WHICH IS CLOSE
*            TO ZERO.
*                20 - 0013 XXXX YYYY
*                    XXXX TIMES .5 IS THE DELAY BETWEEN WRITE FUNCTIONS
*                    YYYY TIMES .5 IS THE DELAY BETWEEN READ FUNCTIONS
          SPACE  5,20
** NAME-- FERT
*
** PURPOSE-- CREATE ERRORS BY FORMATTING WITH THE WRONG RECORD SIZE.  ONLY
*            THE DOCUMENTATION IS HERE.  THE FORMAT ROUTINE READS BYTE ADDRESS 20
*                20 - 0014 XXXX
*            IF THE CODE IS 0014, THE VALUE XXXX WILL BE USED TO DETERMINE THE
*            SECTOR SIZE TO FORMAT
*                0000 - SMALL SECTOR
*                0200 - NOS LARGE SECTOR
*                0800 - NOS/VE SECTOR (NO ERROR)
          SPACE  5,20
** NAME-- FERU
*
** PURPOSE-- FORCE AN ERROR WHILE WRITING DURING THE CONFIDENCE TEST.
*                20 - 0015 XXXX YYYY
*            IF THE CODE IS 15 AND XXXX IS NONZERO, THE CONTROL REGISTER
*            WILL BE LOADED WITH YYYY AND XXXX WILL BE DECREMENTED BY 1.
*                VALUES FOR YYYY ARE THE SAME AS FOR ROUTINE FERL
          SPACE  5,20
** NAME-- FERV
*
** PURPOSE-- FORCE AN ERROR WHILE READING DURING THE CONFIDENCE TEST.
*                20 - 0016 XXXX YYYY
*            IF THE CODE IS 16 AND XXXX IS NONZERO, THE CONTROL REGISTER
*            WILL BE LOADED WITH YYYY AND XXXX WILL BE DECREMENTED BY 1.
*                VALUES FOR YYYY ARE THE SAME AS FOR ROUTINE FERL
 F        ENDIF
          SPACE  5,20
** NAME-- FMT
*
** PURPOSE-- FORMAT A PORTION OF THE DISK
          SPACE  2
 FMT      CON    0
          LOADOVL FMO        LOAD FORMAT OVERLAY
          RJM    FORMD       FORMAT (NO RETURN)
 FMTR     BSS
          LOADOVL FMO        LOAD FORMAT OVERLAY
          LJM    FORMD20     RETRY THE FORMAT
          SPACE  5,20
** NAME-- FORMA
*
** PURPOSE-- FORMAT A CM REAL MEMORY ADDRESS.
*
** CALLING SEQUENCE-- LDC    ADDRESS
*                     RJM    FORMA
*
** INPUT-- - A REGISTER- IS THE ADDRESS OF A 2-WORD CM BYTE ADDRESS.
*
** OUTPUT-- -CMADR- IS THE ADDRESS OF THE RESULTING 3-WORD REFORMATED
*                CM ADDRESS.  THE FORMAT CAN BE USED BY THE LOADC MACRO.
*           -ADDRESS-, WORD 0, BITS 0-14 AND
*                      WORD 1, BITS 3-15, ARE REFORMATTED TO-
*           -CMADR-,   WORD 0, BITS 0-9,
*                      WORD 1, BITS 0-11,
*                      WORD 2, BITS 0-5.
          SPACE  2
 FORX     LJM    **
 FORMA    EQU    *-1
          STDL   T1

* REFORMAT CM ADDRESS.

          LDML   1,T1
          LPN    7
          NJN    FORM10      IF RMA ADDRESS ERROR
          LDIL   T1
          LPN    37B
          SHN    16
          LMML   1,T1
          SHN    9
          STD    CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   T1
          SHN    -5
          STD    CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMC    400000B
          UJK    FORX
 FORM10   BSS
          RJM    HANG
          SPACE  5,20
** NAME-- FUNC
*
** PURPOSE-- ISSUE FUNCTION TO DISK CONTROLLER.
*
** INPUT-- A REGISTER = FUNCTION CODE.
*
** EXIT
*         - TO CALLING ROUTINE IF NO ERROR.  THE CHANNEL WILL BE
*           ACTIVATED FOR ALL FUNCTIONS WITH BITS SET
*           AS FOLLOWS-- X XX1 XXX 1XX 11X X1X.
          SPACE  2
 FUN100   BSS
          LDML   FUNCD
          ZJN    FUN110      IF CONNECT FUNCTION
          LPC    10462B
          ZJN    FUNX        IF NO DATA TRANSFER
 FUN110   BSS
          ACN    DC          ACTIVATE THE CHANNEL
 FUNX     LJM    **
 FUNC     EQU    *-1
          DCN    DC+40B      ENSURE THE CHANNEL IS INACTIVE
          FAN    DC          ISSUE THE FUNCTION
          STML   FUNCD       SAVE FUNCTION CODE
          LDN    0           TIMEOUT 148 MS ON READS AND WRITES
          STDL   T1
          STDL   GNSTAT      CLEAR GENERAL STATUS
          LDN    3           TIMEOUT 3 TIMES LONGER FOR ALL OTHERS
          STDL   T2
 FUN10    BSS
          LDN    0
          IJM    FUN100,DC   IF CHANNEL INACTIVE
          SODL   T1
          NJN    FUN10       IF TIMEOUT NOT EXPIRED
          LDML   FUNCD       CHECK FOR A READ OR WRITE
          SBN    F.READ
          ZJN    FUN30       IF ITS A READ, QUIT TIMING
          SBN    F.WRITE-F.READ
          ZJN    FUN30       IF ITS A WRITE, QUIT TIMING
          SBN    F.CONT-F.WRITE
          ZJN    FUN20       IF CONTINUE, QUIT TIMING
          SODL   T2
          NJN    FUN10       GO TIME OUT SOME MORE
 FUN20    BSS
          LDML   FUNCD
          UJN    FUN40
 FUN30    BSS
          LDDL   FT
          ZJN    FUN20       IF FIRST SECTOR
          RJM    GENSTAT     GET GENERAL STATUS
          LDDL   FNC
          ADN    4           TIMEOUT ON 4 OR 5, NOT 12, FUNCTION
 FUN40    BSS
          STML   RS+/RS/P.FUNTO
          LDK    /RS/K.FTO
          STML   RS+/RS/P.HDWR
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- GENSTAT
*
** PURPOSE-- READ GENERAL STATUS FROM CONTROLLER.
*
** OUTPUT-- A REGISTER = GENERAL STATUS.
*           GNSTAT = GENERAL STATUS.
          SPACE  2
 GENSX    LJM    **
 GENSTAT  EQU    *-1
          LDN    F.GS        GENERAL STATUS FUNCTION CODE
          RJM    FUNC        ISSUE FUNCTION CODE
          LDN    1
          IAM    GNSTAT,DC   INPUT GENERAL STATUS
          NJN    GENS5       IF INPUT DID NOT COMPLETE
          CFM    GENS8,DC    CHECK AND CLEAR CHANNEL ERROR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 GENS5    BSS
          LJM    OUT30
 GENS8    BSS
          LDDL   GNSTAT      SAVE GENERAL STATUS
          ZJN    GENS30      IF NO ERRORS
          SBN    2           CHECK 'NOT ON CYLINDER'
          ZJN    GENS30      IF ONLY BUSY
          SBN    6           WAS THE STORAGE DIRECTOR AVAILABLE
          ZJN    GENS30      STORAGE DIRECTOR IS BUSY ELSEWHERE
          RJM    DS          DETAILED STATUS
          LDML   LCF
          ZJN    GENS15      IF NOT CCC LOAD FAILURE (CP MUST ISOLATE ERROR)
          LDN    E09         CCC LOAD FAILURE
          UJN    GENS20
 GENS15   BSS
          LDC    400000B     INDICATE DETAILED STATUS PRESENT
 GENS20   BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
 GENS30   BSS
          LDDL   GNSTAT      A REGISTER = GENERAL STATUS
          UJK    GENSX
          SPACE  5,20
** NAME-- GETUD
*
** PURPOSE-- GET A UNIT REQUEST FROM CM.
*
** OUTPUT-- THE SS TABLE IS FILLED WITH THE NEW UNIT REQUEST.
*
** NOTE-- THIS ONLY SELECTS A REQUEST IF THE QUEUE WAS PREVIOUSLY
*         EMPTY.  IF THE QUEUE IS NOT EMPTY, THE DELINK ROUTINE
*         SELECTS THE NEXT REQUEST.
          SPACE  2
 GETUX    LJM    **
 GETUD    EQU    *-1
          LDDL   DEVL
          ZJN    GETUX       IF NO UNITS
          LDN    0
          STDL   CF          CLEAR CONTINUE FLAG
          STML   SIP         INDICATE SEEK IN PROGRESS
          LDDL   COMLOOK
          STML   UTSAVE      SAVE STARTING POSITION IN TABLE
 GETUD3   BSS
          RJM    UC          UPDATE CLOCK
          LDN    1
          STDL   WC          CONSTANTS FOR CM I/O
          LDN    C.SS
          STDL   P1
          LDDL   EMPTQ
          ZJN    GETUX       NO AVAILABLE EMPTY ENTRIES
          AODL   COMLOOK     GO TO NEXT TABLE ENTRY
          SBD    DEVL
          MJN    GETUD5      IF NOT END OF TABLE
          LDN    0
          STDL   COMLOOK     SET BACK TO FIRST ENTRY
 GETUD5   BSS
          LDDL   EMPTQ
          STDL   LUTLOC      SET AVAILABLE ENTRY UP FOR POSSIBLE USE
          ADN    /LUT/P.UIT-1
          STML   GETUD7
          LOADC  CM.DEV      START LOOKING AT NEXT UNIT
          ADDL   COMLOOK
          CRDL   P2          SAVE UIT ADDRESS IN LUT
          CRML   -**,WC      GET ADDRESS OF UIT
 GETUD7   EQU    *-1
          LDDL   P2          CHECK IF DEVICE IS ACTIVE
          LPN    /CB/K.ACT
          NJK    GETUD80     IF ALREADY ACTIVE - SKIP TO NEXT ONE
          LOADC  P3
          CRDL   T1          FIRST WORD OF UIT
          ADN    /UIT/C.UBUF
          CRDL   T5          SECOND WORD OF UIT
          ADN    /UIT/C.NEXT-/UIT/C.UBUF
          CRDL   T3          SIXTH WORD OF UIT
          LDDL   T5          CHECK FOR A REQUEST
          ADDL   T6
          ZJK    GETUD80     NO REQUEST, GO TO NEXT ONE
          LDDL   T1+/UIT/P.DSABLE  CHECK IF UNIT IS DISABLED
          SHN    2+/UIT/L.DSABLE
          MJK    GETUD80     IF UNIT IS DISABLED
          LDIL   LUTLOC      REMOVE ENTRY FROM EMPTY QUEUE
          STDL   EMPTQ
          LDDL   USEQ        PLACE ENTRY ON 'IN USE' QUEUE
          STIL   LUTLOC
          LDDL   LUTLOC
          STDL   USEQ
          LDDL   COMLOOK
          STML   /LUT/P.OFFSET,LUTLOC  SAVE INDEX TO CM.DEV TABLE
          LDDL   P2
          LPC    177776B
          LMN    /CB/K.ACT
          STDL   P2          SET ACTIVE BIT IN THE CM.DEV TABLE
          LOADC  CM.DEV
          ADDL   COMLOOK
          CWDL   P2
          RJM    SETLOCK     LOCK THE UNIT
          ZJN    GETUD80     CANNOT LOCK, OTHER DRIVER HAS IT
          LOADF  T7
          CRML   SS,P1       READ SS TABLE
          LDML   SS+/SS/P.ENTRY
          NJN    GETUD40     IF ALREADY SELECTED, GO ON TO NEXT
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    GETUD80     IF QUEUE NOT LOCKED
          RJM    SELRQ       SELECT A REQUEST ON THIS UNIT
          UJN    GETUD80
 GETUD40  BSS
          RJM    USC         UPDATE SAVED CLOCK
 GETUD80  BSS
          LDDL   COMLOOK     CHECK IF LOOKED AT ALL ENTRIES
          SBML   UTSAVE
          NJK    GETUD3      IF NO
          UJK    GETUX       EXIT
          SPACE  5,20
** NAME-- GLIST
*
** PURPOSE-- READ THE CM ADDRESS LIST PORTION OF A COMMAND.
          SPACE  2
 GLIX     LJM    **
 GLIST    EQU    *-1
          LDN    1
          STDL   WC          NUMBER OF WORDS TO READ
          LOADF  CM+/CM/P.RMA  LOAD CM ADDRESS AND REFORMAT
          CRML   CMLIST,WC
          LDN    8
          RAML   CM+/CM/P.RMA+1  UPDATE RMA ADDRESS FOR NEXT READ
          STDL   CMRMA+1     SAVE IN CASE A BACKUP IS NEEDED
          SHN    -16
          RAML   CM+/CM/P.RMA
          STDL   CMRMA       SAVE IN CASE A BACKUP IS NEEDED
          LDML   CMLIST+/CM/P.LEN  ENSURE AN EVEN NUMBER OF CM WORDS
          ADN    7
          SCN    7
          STML   CMLIST+/CM/P.LEN
          UJK    GLIX
          SPACE  5,20
** NAME-- IN
*
** PURPOSE-- INPUT WORDS FROM THE CHANNEL
*
** ENTRY
*         A = WORDS TO INPUT
*         IN10 = LOCATION TO BE PLUGGED WITH ADDRESS TO STORE DATA
          SPACE  2
 INX      LJM    **
 IN       EQU    *-1
          IAM    *,DC
 IN10     EQU    *-1
          ZJN    INX         IF NO ERROR
          LJM    OUT20
          SPACE  5,20
** NAME-- INTERR
*
** PURPOSE-- REPORT AN INTERFACE ERROR
          SPACE  2
 INTERR   CON    0
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LDN    E01         INTERFACE ERROR
          STML   RS+/RS/P.EC
          LDN    0           CLEAR WORDS SO CP REPORTS CORRECT ERROR
          STML   RS+/RS/P.GENST1
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          RJM    HANG
          SPACE  5,20
** NAME-- INTRS
*
** PURPOSE-- SEND INTERMEDIATE RESPONSE.
          SPACE  2
 INTRSX   LJM    **
 INTRS    EQU    *-1
          LDN    0
          STML   RS+/RS/P.SHORT   INDICATE ERROR RESPONSE
          LDK    C.RS*8
          STML   RS+/RS/P.RESPL  RESPONSE LENGTH
          LDDL   CTF
          NJN    INTRS10     IF REQUEST EXISTS
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          UJK    INTRSX
 INTRS10  BSS
          LDK    R.INT*0#4000  INTERMEDIATE RESPONSE
          STML   RS+/RS/P.RC
          RJM    TERMP       SEND RESPONSE TO CM
          UJK    INTRSX
*COPYC IODMAC6
          SPACE  5,20
** NAME-- LOCK
*
** PURPOSE-- SET THE LOCKWORD
*
** ENTRY
*         P6 = RMA OFFSET
*         T5 = OFFSET TO LOCKWORD FROM RMA
*
** EXIT
*         A = 0 IF LOCK SUCCESSFULLY SET
          SPACE  2
 LOCKX    LJM    **
 LOCK     EQU    *-1
 LOCK1    BSS
          LCN    0
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,P6        TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

          LDDL   T1
          ZJN    LOCK5       IF LOCK COULD BE SET
          ADDL   T2
          ADC    -177777B-177777B
          ZJN    LOCK1       IF INTERMEDIATE VALUE
          LDDL   T2
          LPC    77777B
          ADC    100000B
          STDL   T2          SET THE VE BIT
          LDDL   T6
          LMC    400000B
          CWDL   T1          RESTORE THE LOCKWORD WITH THE VE BIT
          LDDL   T4
          SBDL   PPNO
          NJN    LOCK3       IF LOCK COULD NOT BE SET
          LDDL   T1
          ADC    -100000B
 LOCK3    BSS
          UJK    LOCKX       IF LOCK WAS ALREADY SET, EXIT A = 0
                             IF LOCK COULD NOT BE SET, EXIT A .NE. 0
 LOCK5    BSS
          LDC    100000B
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          LDDL   PPNO
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          SET THE LOCKWORD
          LDN    0
          UJK    LOCKX
          SPACE  5,20
** NAME-- OUT
*
** PURPOSE-- OUTPUT WORDS FROM THE PP TO THE CCC
*
** ENTRY
*         A = NUMBER OF WORDS TO OUTPUT
*         OUT10 = LOCATION TO BE PLUGGED WITH ADDRESS TO OUTPUT FROM
*
** EXIT   TO CALLING ROUTINE IF NO ERROR
          SPACE  2
 OUTX     LJM    **
 OUT      EQU    *-1
          STDL   T2          SAVE WORD COUNT
*
*         THIS TIMEOUT LOOP PREVENTS THE PP FROM HANGING ON AN ISI CHANNEL
*
          LCN    0
 OUT4     BSS
          EJM    OUT8,DC     IF CHANNEL EMPTY
          SBN    1
          NJN    OUT4        IF TIMEOUT NOT EXPIRED
          UJN    OUT40
 OUT8     BSS
          LDDL   T2
          OAM    *,DC        OUTPUT WORDS
 OUT10    EQU    *-1
          ZJN    OUTX        IF NO ERROR
 OUT20    BSS
          STDL   T4          WORDS NOT TRANSFERRED
          RJM    GENSTAT     GET GENERAL STATUS
          LDDL   T4
 OUT30    BSS
          STML   RS+/RS/P.FUNTO  WORDS NOT TRANSFERRED
 OUT40    BSS
          LDN    E05         INCOMPLETE CHANNEL TRANSFER
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- PAUS
*
** PURPOSE-- DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*            MICROSECONDS.
*
** INPUT-- A REGISTER SPECIFIES NUMBER OF MICROSECONDS
*          TO BE DELAYED.
*
** NOTE-- THIS IS SET UP FOR 4X PP TIMING.
          SPACE  2
 PAUSX    LJM    **
 PAUS     EQU    *-1
 PAUS10   BSS
          STDL   0           ONE MICROSECOND LOOP
          SBN    1
          NJN    PAUS10
          UJK    PAUSX
          SPACE  5,20
** NAME-- PCER
*
** PURPOSE-- PREPARE COMMON ERROR RESPONSE
*
** ENTRY
*         A = ERROR CODE FOR LOCATION /RS/P.EC
*         COMLOOK = INDEX TO DEVICE TABLE
          SPACE  2
 PCER     CON    0
          RJM    PER         PREPARE ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- PER
*
** PURPOSE-- PREPARE ERROR RESPONSE
*
** ENTRY
*         A = ERROR CODE FOR LOCATION ERRID
*         A = NEGATIVE VALUE IF DETAILED STATUS PRESENT
*         COMLOOK = INDEX TO DEVICE TABLE
          SPACE  2
 PERX     LJM    **
 PER      EQU    *-1
          STML   RS+/RS/P.EC  SAVE ERROR CODE
          MJN    PER3        IF DETAILED STATUS PRESENT
          LDN    0
          STML   RS+/RS/P.DET  CLEAR DETAILED STATUS PRESENT FLAG
 PER3     BSS
          LDDL   GNSTAT      SAVE GENERAL STATUS
          STML   RS+/RS/P.GENST1
          STML   RS+/RS/P.GENST2
          RJM    RDT         READ DEVICE TABLE
          LDDL   CTF
          ZJN    PER5        IF CONFIDENCE TEST FAILURE
          LDDL   P2          FIRST WORD OF DEVICE TABLE
          SHN    -1
          LPN    3
          NJN    PER10       IF NOT CONFIDENCE TEST FAILURE
 PER5     BSS
          STML   RS+/RS/P.STRK  STARTING TRACK
          STML   RS+/RS/P.SSEC  STARTING SECTOR
          LDC    MAXCYL-1
          UJN    PER11
 PER10    BSS
          LDN    1
          STDL   T2
          LDML   SIP
          NJN    PER13       IF SEEK COMPLETE
          RJM    SRESP       PUT PVA IN RESPONSE
          LDDL   FNC
          SBN    2
          NJN    PER12       IF NOT FORMAT
          STML   RS+/RS/P.STRK  STARTING TRACK
          STML   RS+/RS/P.SSEC  STARTING SECTOR
          LDML   FBUF
 PER11    BSS
          STML   RS+/RS/P.SCYL  STARTING CYLINDER
          UJN    PER20
 PER12    BSS
          LOADF  SS+/SS/P.REQ  RMA OF CURRENT REQUEST
          UJN    PER16
 PER13    BSS
          LOADF  CURRQ       RMA OF CURRENT REQUEST
 PER16    BSS
          ADN    3
          CRML   RS+/RS/P.CHAN,T2  SAVE CYLINDER, TRACK AND SECTOR
          LDDL   CHAN
          STML   RS+/RS/P.CHAN  SAVE CHANNEL NUMBER
 PER20    BSS
          LDML   RS+/RS/P.DET
          NJN    PER30       IF DETAILED STATUS VALID
          STDL   T1
 PER25    BSS
          LDN    0
          STML   RS+/RS/P.DETAIL,T1
          AODL   T1
          LMN    40
          NJN    PER25       IF MORE WORDS TO CLEAR
 PER30    BSS
          LOADC  P3          REFORMATTED RMA OF UIT
          CRDL   T1          FIRST WORD OF UNIT INTERFACE TABLE
          ADN    1
          CRDL   T2          SECOND WORD OF UIT
          LDDL   T1
          STML   RS+/RS/P.LU  LOGICAL UNIT
          LOADF  T4          RMA OF UNIT COMMUNICATIONS BUFFER
          CRDL   T1          FIRST WORD OF SS TABLE
          LDDL   T1
          STML   RS+/RS/P.UNIT  PHYSICAL UNIT NUMBER
          LDML   SS+/SS/P.TRACK
          LPN    77B
          STML   RS+/RS/P.FTRK  FAILING TRACK
          LDML   SS+/SS/P.SECTOR
          STML   RS+/RS/P.FSEC  FAILING SECTOR
          LDN    0
          STML   RS+/RS/P.ID  CLEAR ERROR ID
          LDML   RS+/RS/P.EC
          SBN    E02
          MJN    PER33       IF NO ERROR REGISTER
          SBN    E05-E02
          MJN    PER36       IF ERROR REGISTER PRESENT
          SBN    E12-E05
          MJN    PER33       IF NO ERROR REGISTER
          SBN    E19-E12
          MJN    PER36       IF ERROR REGISTER PRESENT
 PER33    BSS
          LDN    0           CLEAR VALUE FOR ERROR STATUS REGISTER
          STML   RS+/RS/P.FERREG
          STML   RS+/RS/P.LERREG
 PER36    BSS
          LDML   RS+/RS/P.EC
          ZJN    PER40       IF ERROR CODE ZERO
          SBN    E05
          ZJN    PER50       IF WORD COUNT STORED
          LDN    0
          UJN    PER45
 PER40    BSS
          LDML   RS+/RS/P.HDWR
          LPC    /RS/K.FTO
          NJN    PER50       IF FUNCTION IS SAVED
 PER45    BSS
          STML   RS+/RS/P.FUNTO  CLEAR FUNCTION OR WORD COUNT
 PER50    BSS
          LJM    PERX
          SPACE  5,20
** NAME-- PDR
*
** PURPOSE-- PREPARE NORMAL DISK RESPONSE
          SPACE  2
 PDRX     LJM    **
 PDR      EQU    *-1
          LDN    0
          STML   RS+/RS/P.HDWR  ABNORMAL STATUS
          LDN    8           SET RESPONSE LENGTH FOR NORMAL RESPONSE
          STML   RS+/RS/P.RESPL
          LDML   RQ+/RQ/P.LU  LOGICAL UNIT
          LPC    0#FF
          LMC    /RS/K.SHORT  INDICATE ONE-WORD RESPONSE
          STML   RS+/RS/P.SHORT
          UJK    PDRX
          SPACE  5,20
** NAME-- POLLON
*
** PURPOSE-- THIS ROUTINE POLLS UNITS FOR ON-CYLINDER
*
** INPUT-- IN USE QUEUE (USEQ)
*
** OUTPUT-- A REGISTER = 0, IF NOTHING WAS ON CYLINDER
*
*         POLLON SCANS THE 'IN USE' QUEUE TWICE.  FIRST IT LOOKS AT
*         ENTRIES FOR WHICH THE UNIT IS ALREADY LOCKED TO THIS
*         PP (P.OWNER=1).  IF NONE OF THESE HAVE COMPLETED SEEKS
*         PENDING, ANOTHER SCAN IS MADE, THIS TIME LOOKING AT UNITS
*         THAT ARE NOT YET LOCKED.
          SPACE  2
 POLLX    LJM    **
 POLLON   EQU    *-1
          LDN    C.SS
          STDL   WC
          LDN    /LUT/K.OWNER
 POLL10   BSS
          STDL   T8          SET T8 TO MATCH P.OWNER = 1
          LDN    USEQ
 POLL20   BSS
          STDL   LUTLOC      SET TO BEGINNING OF 'IN USE' QUEUE (-1)
 POLL30   BSS
          RJM    UC          UPDATE CLOCK
          LDDL   LUTLOC
          STDL   P1          SAVE POINTER TO PREVIOUS ENTRY
          LDIL   LUTLOC
          STDL   LUTLOC      GET NEXT ENTRY ON QUEUE
          NJN    POLL40      IF ENTRY EXISTS
          LDDL   T8
          ZJN    POLLX       IF SECOND PASS JUST FINISHED, EXIT
          LDN    0           SET T8 FOR NEXT PASS
          UJN    POLL10
 POLL40   BSS
          LDML   /LUT/P.OWNER,LUTLOC
          SBDL   T8
          NJN    POLL30      IF THIS PASS DOESN'T LOOK AT THIS ENTRY
          LDDL   T8
          NJN    POLL50      IF UNIT LOCKED
          RJM    SETLOCK     TRY TO LOCK THE UNIT
          ZJK    POLL30      IF LOCK COULD NOT BE SET
 POLL50   BSS
          LOADR  /LUT/P.UIT,LUTLOC  ADDRESS OF UIT
          ADN    /UIT/C.UBUF
          CRDL   P2          SECOND WORD OF UIT
          LOADF  P4          GET ADDRESS OF COMMUNICATION BUFFER
          CRML   SS,WC       READ SS ENTRY
          LDML   SS+/SS/P.ENTRY  HAS AN ENTRY BEEN SELECTED
          NJK    POLL60      IF REQUEST SELECTED
          LOADR  SS+/SS/P.UQT  ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T1
          ADN    /UIT/C.NEXT  OFFSET TO RMA OF DISK REQUEST
          CRDL   T3
          LDDL   T2
          SHN    2+/UIT/L.DSABLE
          MJN    POLL53      IF UNIT DISABLED
          LDDL   T5
          ADDL   T6
          NJN    POLL55      IF REQUEST PRESENT
*
*         CLEARING THE UNIT LOCK WITHOUT SELECTING A REQUEST COULD
*         CAUSE AN INFINITE LOOP IF TWO CHANNELS ARE SHARING THE UNIT.
*
 POLL53   BSS
          RJM    CLRLOCK     CLEAR THE UNIT LOCK
 POLL55   BSS
          LDIL   LUTLOC
          STIL   P1          REMOVE LUT ENTRY FROM 'IN USE' QUEUE
          LCN    0
          STDL   T2
          STDL   T3
          STDL   T4
          LMN    /CB/K.ACT
          STDL   T1
          LOADC  CM.DEV
          ADML   /LUT/P.OFFSET,LUTLOC
          RDCL   T1          CLEAR ACTIVE BIT IN CM.DEV TABLE
          LDDL   EMPTQ
          STIL   LUTLOC
          LDDL   LUTLOC
          STDL   EMPTQ       PUT LUT ENTRY ON THE EMPTY QUEUE
          LDDL   P1
          LJM    POLL20      GO TO NEXT ENTRY
 POLL60   BSS
          RJM    USC         UPDATE SAVED CLOCK
          LDML   /LUT/P.OFFSET,LUTLOC
          STDL   COMLOOK     INDEX TO DEVICE TABLE
          RJM    SEEKCK      ISSUE A SEEK FOR POLLING
          ZJN    POLL90      IF A SEEK HAS FINISHED
          LDDL   CLSEC
          SBML   SS+/SS/P.CLKST
          PJN    POLL70      IF CLOCK HASN'T WRAPPED
          ADC    0#10000
 POLL70   BSS
          SBN    10          10 SECOND MINIMUM TIMEOUT
          MJK    POLL80      IF NO TIMEOUT
          LDN    E08         SEEK OR FORMAT COMMAND TIMEOUT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
 POLL80   BSS
          LDN    F.OPCMP
          RJM    FUNC
          UJK    POLL30
 POLL90   BSS
          RJM    POLS        POLL SUBROUTINE
*
*         PUT LUTLOC AT END OF USEQ.  THIS HELPS KEEP USAGE OF UNITS
*         RANDOM.
*
          LDIL   LUTLOC
          ZJN    POLL110     IF ALREADY LAST ENTRY OF USEQ
          STIL   P1          REMOVE ENTRY FROM USEQ
 POLL100  BSS
          STDL   P1
          LDIL   P1
          NJN    POLL100     IF NOT END OF QUEUE
          STIL   LUTLOC
 POLL110  BSS
          LDDL   LUTLOC
          STIL   P1          ADD LUTLOC TO END OF USEQ
          UJK    POLLX
          SPACE  5,20
** NAME-- POLS
*
** PURPOSE-- POLL SUBROUTINE.  RELEASE UNIT LOCK ON OTHER UNITS.
          SPACE  2
 POLSX    BSS
          LDDL   P2
          STDL   LUTLOC      RESTORE POINTER TO CURRENT REQUEST
          LJM    **
 POLS     EQU    *-1
          RJM    SAVSS
          LDDL   LUTLOC
          STDL   P2          SAVE LUT POINTER
          LDN    USEQ
          STDL   LUTLOC      RESET TO BEGINNING OF QUEUE
          STML   SIP         INDICATE SEEK COMPLETE
 POLS10   BSS
          LDIL   LUTLOC
          ZJK    POLSX       IF END OF QUEUE
          STDL   LUTLOC
          SBDL   P2          IS THIS ENTRY THE CURRENT ONE
          ZJN    POLS10      IF YES, DON'T RELEASE THE LOCK
          LDML   /LUT/P.OWNER,LUTLOC  IS ENTRY LOCKED TO THIS PP
          ZJN    POLS10      IF UNLOCKED
          LOADR  /LUT/P.UIT,LUTLOC  ADDRESS OF UIT
          ADN    /UIT/C.UBUF
          CRDL   P3          ADDRESS OF COMMUNICATIONS BUFFER
          LOADF  P5          ADDRESS OF SS TABLE
          STDL   T1
          ADN    /SS/C.CLKST
          CRDL   T2          READ CLOCK FROM SS TABLE
          LDDL   T2
          STDL   T6          SAVE SECONDS PORTION OF CLOCK START
          LDDL   CLMLS       UPDATE SEEK TIME SO TIMEOUT WILL BE
          STDL   T5
 POLS15   BSS
          SBDL   T3           MORE ACCURATE
          PJN    POLS20      IF CLOCK HASN'T WRAPPED
          AODL   T6
          LDC    1000        MILLISECONDS PER SECOND
          RADL   T5
          UJN    POLS15
 POLS20   BSS
          STDL   T5          SAVE SEEK TIME (MILLISECONDS)
          LDDL   CLSEC
          SBDL   T6
          PJN    POLS30      IF CLOCK HASN'T WRAPPED
          ADC    0#10000
 POLS30   BSS
          STDL   T4          SAVE SEEK TIME (SECONDS)
          LDDL   T1
          ADC    400000B+/SS/C.CLKST
          CWDL   T2          SAVE CLOCK AND SEEK TIME IN SS TABLE
          RJM    CLRLOCK     CLEAR THE LOCK
          UJK    POLS10      GO LOOK AT THE NEXT ONE
          SPACE  5,20
** NAME-- PPREQ
*
** PURPOSE-- CHECK FOR ANY PP REQUESTS
          SPACE  2
 PPRQX    LJM    **
 PPREQ    EQU    *-1
          LCN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDC    0#7FFF      CLEAR ACTIVE CHECK BIT
          STDL   T4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          RDCL   T1          CLEAR ACTIVE BIT, READ IDLE/RESUME BITS
          LDDL   T4
          LPC    0#6000
          ZJN    PPRQX       IF NOT IDLE OR RESUME
          STDL   T5
          LOADOVL ERO        LOAD ERROR RECOVERY OVERLAY
          RJM    SPLOCK      SET PP TABLE LOCK
          RJM    PIR         PROCESS IDLE OR RESUME COMMAND (NO RETURN)
          SPACE  5,20
** NAME-- RDT
*
** PURPOSE-- READ DEVICE TABLE
          SPACE  2
 RDTX     LJM    **
 RDT      EQU    *-1
          LOADC  CM.DEV      ADDRESS OF DEVICE TABLE
          ADDL   COMLOOK     INDEX INTO TABLE
          CRDL   P2
          LDDL   P2
          UJN    RDTX
          SPACE  5,20
** NAME-- RES
*
** PURPOSE-- READ ERROR STATUS REGISTER OF CIO CHANNEL.
*
** EXIT-- A = STATUS REGISTER READ, OTHERWISE ZERO
*
** NOTE-- THIS ROUTINE MUST BE RESIDENT DUE TO CHANNEL INSTRUCTIONS
          SPACE  2
 RESX     LJM    **
 RES      EQU    *-1
          DCN    DC+40B      ENSURE THE CHANNEL IS INACTIVE
          LDC    F.RES       READ ERROR STATUS REGISTER FUNCTION
          FAN    DC
          LDDL   0           DELAY
          LDN    1
          IJM    RES25,DC    IF FUNCTION REPLY RECEIVED
 RES20    BSS
          LDN    0
          UJN    RESX
 RES25    BSS
          ACN    DC
          IAM    T1,DC       INPUT THE STATUS
*
*         THE ERROR FLAG IS NOT TESTED HERE.  THERE WERE TEST CASES
*         WHERE THE ERROR FLAG IS STILL SET AFTER THE INPUT AND THE
*         ERROR REGISTER IS ACCURATE.
*
          NJN    RES20       IF ERROR
          LDDL   T1
          UJK    RESX
          SPACE  5,20
** NAME-- RESP
*
** PURPOSE-- WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
*
** INPUT-- CM.PIT, CM.RS, LIM, /PIT/IN, /PIT/OUT, RS+/RS/P.RESPL
*
** OUTPUT-- /PIT/IN, RESPONSE BUFFER
          SPACE  2
 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  2
 RESPX    LJM    **
 RESP     EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDN    0
          STML   STORS       SET FLAG TO STORE RESPONSE
          LDML   CM+/CM/P.STOR  CHECK IF CALLER WANTS RESPONSE
          SHN    /CM/L.STOR+2
          MJN    RESP10      IF STORE RESPONSE FLAG IS SET
          LDML   RS+/RS/P.SHORT
          SHN    /RS/L.SHORT+2
          PJN    RESP10      IF NOT NORMAL RESPONSE, STORE RESPONSE
          AOML   STORS       NONZERO MEANS DO NOT STORE RESPONSE
          UJK    RESPX

* READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RESP10   BSS
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF 'IN' POINTER
          CRDL   P1          READ 'IN' POINTER

* CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDN    0
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE
          LDDL   INP
          SBDL   OUTP
          MJN    RESP20      IF IN .LT. OUT
          LDML   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP
 RESP20   BSS
          LDML   RS+/RS/P.RESPL  GET RESPONSE LENGTH
          ADDL   INP
          STDL   INPNT       IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          MJN    RESP30      IF ROOM IN BUFFER
          RJM    PPREQ       CHECK FOR IDLE REQUEST
          UJK    RESP10
 RESP30   BSS
          LDDL   INP
          SHN    -3
          STDL   T3          'IN' POINTER IN WORDS
          LDML   RS+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          LDDL   INPNT
          SBML   LIM
          MJN    RESP50      IF IN + RESPONSE LENGTH .LT. LIMIT
                             ONLY 1 BLOCK WRITE
          STDL   INPNT       IN + RESPONSE LENGTH - LIMIT = NEW 'IN' POINTER
          SHN    -3
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE

* WRITE RESPONSE TO CM.

          LDML   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADC    RS
          STML   RESP60      RESPONSE ADDRESS FOR 2ND BLOCK WRITE
 RESP50   BSS
          LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD 'IN' OFFSET
          CWML   RS,T4       WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          ZJN    RESP70      IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          LMC    400000B
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
                             (BEGINNING OF RESPONSE BUFFER)
 RESP60   EQU    *-1

 RESP70   BSS
          LJM    RESPX
          SPACE  5,20
** NAME-- RESPIN
*
** PURPOSE-- UPDATE THE 'IN' POINTER IN THE CM RESPONSE BUFFER.
*
** INPUT-- INPNT = NEW 'IN' POINTER.
          SPACE  2
 RESNX    LJM    **
 RESPIN   EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDML   STORS       CHECK IF CALLER WANTS RESPONSE
          NJK    RESNX       IF NO RESPONSE WAS SENT

* UPDATE THE 'IN' POINTER.

          LDN    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDDL   INPNT       NEW 'IN' POINTER
          STDL   P4
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   P1          WRITE NEW 'IN' POINTER TO CM

* INTERRUPT PROCESSOR. SETRQ ROUTINE SETS UP THIS INSTRUCTION.
          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   PPNO-3      SET LAST BYTE NONZERO
          INPN   1           INTERRUPT OR PSN
 INTPRC   EQU    *-1         INSTRUCTION MODIFIED
          UJK    RESNX
          SPACE  5,20
** NAME-- ROS
*
** PURPOSE-- READ OPERATIONAL STATUS
          SPACE  2
 ROSX     LJM    **
 ROS      EQU    *-1
          LDC    F.ROS       READ OPERATIONAL STATUS
          RJM    FUNC
          EJM    OUT40,DC    IF CHANNEL NOT FULL
          IAN    DC          INPUT OPERATIONAL STATUS
          STML   RS+/RS/P.OS  SAVE OPERATIONAL STATUS
          CFM    ROSX,DC     IF ERROR FLAG NOT SET
          LDC    F.CDM       CLEAR DMA MODE
          RJM    FUNC
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- SAVSS
*
** PURPOSE-- WRITE THE SS ENTRY TO THE COMMUNICATION BUFFER
*            IN THE UNIT INTERFACE TABLE.
*
** INPUT-- SS TABLE WHICH IDENTIFIES THE UNIT TABLE.
          SPACE  2
 SAVX     LJM    **
 SAVSS    EQU    *-1
          LDN    C.SS        NUMBER OF WORDS TO WRITE
          STDL   WC
          LOADR  SS+/SS/P.COM
          CWML   SS,WC       WRITE SS ENTRY TO UNIT COMM. BUFFER
          UJK    SAVX
          SPACE  5,20
** NAME-- SC
*
** PURPOSE-- SAVE CLOCK IN SS TABLE.  IT IS USED FOR TIMING OUT SEEK
*            COMMANDS
          SPACE  2
 SCX      LJM    **
 SC       EQU    *-1
          LDDL   CLSEC       SAVE CLOCK START TIME
          STML   SS+/SS/P.CLKST
          LDDL   CLMLS
          STML   SS+/SS/P.CLKST+1
          LDDL   PPNO        SAVE PP THAT DID LAST TIMING
          STML   SS+/SS/P.LPP
          LDN    0           CLEAR SEEK TIME
          STML   SS+/SS/P.SEEKTM
          STML   SS+/SS/P.SEEKTM+1
          UJN    SCX
          SPACE  5,20
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
*
** EXIT--  A = 0 WITH CHANNEL LOCK SET
          SPACE  2
 SCLX     LJM    **
 SCLOCK   EQU    *-1
 SCL30    BSS
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   P6
          LDDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    SCL30       IF LOCK WAS NOT SET
          STML   CHLOCK      INDICATE CHANNEL LOCK SET
          UJK    SCLX        EXIT, LOCK WAS SET
          SPACE  5,20
** NAME-- SEEKCK
*
** PURPOSE-- ISSUE A SEEK
          SPACE  2
 SEEX     LJM    **
 SEEKCK   EQU    *-1
          LDN    F.SEEK
          RJM    FUNC        ISSUE THE SEEK
 SEEK10   EQU    *-1         FOR FORCING ERRORS
          ACN    DC+40B      ACTIVATE THE CHANNEL
          LDN    0
          STDL   CA          DON'T ALLOW CONTINUE FUNCTION
          STDL   FT          FIRST TIME FLAG
          LDN    4
          OAM    SS+/SS/P.UNIT,DC  SEND SEEK FUNCTION PARAMETERS
          ZJN    SEEK20      IF NO ERROR
          LJM    OUT20
 SEEK20   BSS
          RJM    DCN         DISCONNECT THE CHANNEL
          RJM    GENSTAT     READ GENERAL STATUS
          UJN    SEEX
          SPACE  5,20
** NAME-- SEEKON
*
** PURPOSE-- ISSUE SEEK, CHECK FOR ERRORS, WAIT FOR ON-CYLINDER.
          SPACE  2
 SEKOX    LJM    **
 SEEKON   EQU    *-1
          LDDL   CLSEC
          STML   SS+/SS/P.CLKST
 SEK015   BSS
          RJM    SEEKCK      ISSUE SEEK AND RECOVER SEEK ERRORS
          ZJN    SEKOX       IF ON CYLINDER
          RJM    UC          UPDATE CLOCK
          LDDL   CLSEC
          SBML   SS+/SS/P.CLKST
          PJN    SEK020      IF CLOCK HASN'T WRAPPED
          ADC    0#10000
 SEK020   BSS
          SBN    5
          MJN    SEK015      IF TIMEOUT NOT EXPIRED
          LDN    E08         SEEK TIMEOUT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- SELRQ
*
** PURPOSE-- SELECTS THE FIRST REQUEST IN THE CHAIN FOR THE
*            CURRENT REQUEST.
*
** INPUTS-- SS+P.UQT = POINTER TO UNIT QUEUE TABLE.
*
** OUTPUTS-- RQ = CURRENT REQUEST.
*            SS+/SS/P.REQ
*            SS+/SS/P.CYL
*            SS+/SS/P.TRACK
*            SS+/SS/P.SECTOR
*
** NOTE-- ASSUMES UNIT QUEUE LOCK HAS BEEN SET.
          SPACE  2
 SELRQX   BSS
          RJM    CQLOCK      CLEAR QUEUE LOCK
 SELRQ10  BSS
          RJM    SAVSS       SAVE SHARED TABLE
          LJM    **
 SELRQ    EQU    *-1

* READ RMA OF NEXT REQUEST FROM UNIT QUEUE.
* SET CURRENT REQUEST = FIRST REQUEST IN QUEUE.

          LDN    2
          STDL   WC
          LOADR  SS+/SS/P.UQT  LOAD CM ADDRESS OF UIT
          ADN    /UIT/C.NEXTPV
          CRML   T1,WC       READ RMA OF FIRST REQUEST IN CHAIN
          LDDL   T7
          STML   SS+/SS/P.REQ  SET RMA OF CURRENT REQUEST
          LDDL   T8
          STML   SS+/SS/P.REQ+1
          ADDL   T7
          ZJK    SELRQX      IF QUEUE EMPTY
          LDDL   T2          SET PVA OF CURRENT REQUEST
          STML   SS+/SS/P.PVA
          LDDL   T3
          STML   SS+/SS/P.PVA+1
          LDDL   T4
          STML   SS+/SS/P.PVA+2
          RJM    CQLOCK      CLEAR QUEUE LOCK
          LDML   SS+/SS/P.UQT  SET DELINK POINTER TO BEGINNING OF QUEUE
          STML   SS+/SS/P.DP
          LDML   SS+/SS/P.UQT+1
          STML   SS+/SS/P.DP+1
          LDML   SS+/SS/P.UQT+2
          ADN    /UIT/C.NEXTPV  PVA IN UNIT INTERFACE TABLE
          STML   SS+/SS/P.DP+2
          RJM    SSA         SET SEEK ADDRESS
          LDK    /SS/K.ENTRY
          STML   SS+/SS/P.ENTRY  SET CURRENT REQUEST IN SS
          UJK    SELRQ10
          SPACE  5,20
** NAME-- SETLOCK
*
** PURPOSE-- SETS THE UNIT LOCK IN THE UNIT INTERFACE TABLE.
*
** INPUT-- SS TABLE WHICH IDENTIFIES THE UNIT TABLE.
*
** EXIT-- A REGISTER  .NE. 0  IF LOCK WAS SUCCESSFULLY SET.
*                     .EQ. 0  IF LOCK COULD NOT BE SET.
          SPACE  2
 SETL20   BSS
          LDN    0
          STML   /LUT/P.OWNER,LUTLOC  INDICATE LOCK NOT SET
 SETLX    LJM    **
 SETLOCK  EQU    *-1
          LDDL   LUTLOC
          ADN    /LUT/P.UIT    UNIT INTERFACE TABLE ADDRESS
          STDL   P6
          LDN    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJK    SETL20      IF LOCK COULD NOT BE SET
          LDN    /LUT/K.OWNER
          STML   /LUT/P.OWNER,LUTLOC  INDICATE LOCK SET
          UJK    SETLX
          SPACE  5,20
** NAME-- SETRQ
*
** PURPOSE-- SET UP FOR FIRST REQUEST.
          SPACE  2
 SETRQX   LJM    **
 SETRQ    EQU    *-1
          LDML   SS+/SS/P.REQ  SAVE RMA OF REQUEST
          STML   FCOMRQ      FIRST COMPLETED REQUEST (RMA)
          STML   CURRQ       CURRENT REQUEST (RMA)
          LDML   SS+/SS/P.REQ+1
          STML   FCOMRQ+1
          STML   CURRQ+1
          LDN    1
          STDL   NCOMRQ      NUMBER OF COMPLETED REQUESTS

* SET UP INTERRUPT PROCESSOR INSTRUCTION IF INTERRUPT IS SELECTED.

          LDML   RQ+/RQ/P.INT  CHECK IF INTERRUPT WAS SELECTED
          SHN    /RQ/L.INT+2
          MJN    SETR10      IF INTERRUPT SELECTED
          LDC    2400B       PSN INSTRUCTION
          UJN    SETR20

 SETR10   BSS
          LDML   RQ+/RQ/P.PORT  GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RQ/L.PORT+/RQ/N.PORT
          LPN    /RQ/M.PORT
          ADC    102600B     INPN INSTRUCTION
 SETR20   BSS
          STML   INTPRC
          UJK    SETRQX
          SPACE  5,20
** NAME-- SNDRSP
*
** PURPOSE-- SEND THE RESPONSE TO CM.
*            USED WHEN SWITCHING TO THE NEXT REQUEST.
          SPACE  2
 SNDX     LJM    **
 SNDRSP   EQU    *-1
          RJM    RESP        SEND RESPONSE TO CM
          RJM    RESPIN      UPDATE -IN- POINTER IN RESPONSE BUFFER
          RJM    SRESP       SET UP RESPONSE BUFFER
          UJK    SNDX
          SPACE  5,20
** NAME-- SNMSG
*
** PURPOSE-- SEND UNSOLICITED MESSAGE
          SPACE  2
 SNMSGX   LJM    **
 SNMSG    EQU    *-1
          LDN    0
          STML   RS+/RS/P.SHORT  INDICATE ERROR RESPONSE
          LDC    C.RS*8
          STML   RS+/RS/P.RESPL
          LDN    R.UNS
          STML   RS+/RS/P.RC  UNSOLICITED RESPONSE CODE
          RJM    RESP        SEND RESPONSE TO CM
          UJK    SNMSGX
          SPACE  5,20
** NAME-- SPLOCK
*
** PURPOSE-- SETS THE PP TABLE LOCK IN THE
*            PP INTERFACE TABLE.
          SPACE  2
 SPLX     LJM    **
 SPLOCK   EQU    *-1
 SPLOCK4  BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDN    1
          STDL   T4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          RDSL   T1          ATTEMPT TO SET PP TABLE LOCK
          LDDL   T4
          LPN    1
          ZJK    SPLX        IF LOCK SET
          UJK    SPLOCK4
          SPACE  5,20
** NAME-- SQLOCK
*
** PURPOSE-- SETS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
*
** INPUT-- SS TABLE WHICH IDENTIFIES THE UNIT TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  2
 SQLX     LJM    **
 SQLOCK   EQU    *-1
          LDDL   LUTLOC
          ADN    /LUT/P.UIT    UNIT INTERFACE TABLE ADDRESS
          STDL   P6
          LDN    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          UJK    SQLX
          SPACE  5,20
** NAME-- SRESP
*
** PURPOSE-- SET UP STATUS RESPONSE BUFFER.
          SPACE  2
 SREX     LJM    **
 SRESP    EQU    *-1
          LDML   SS+/SS/P.PVA        PUT PVA OF REQUEST IN RESPONSE BUFFER
          STML   RS+/RS/P.PVA
          LDML   SS+/SS/P.PVA+1
          STML   RS+/RS/P.PVA+1
          LDML   SS+/SS/P.PVA+2
          STML   RS+/RS/P.PVA+2
          LDN    0
          STML   RS+/RS/P.XFER   TRANSFER COUNT
          STML   RS+/RS/P.XFER+1
          LDN    4
          STML   SS+/SS/P.LASTC  OFFSET TO COMMAND
          UJK    SREX
          SPACE  5,20
** NAME-- SSA
*
** PURPOSE-- SET SEEK ADDRESS
          SPACE  2
 SSAX     LJM    **
 SSA      EQU    *-1
          RJM    UREQ        READ SELECTED REQUEST INTO RQ
          LDML   RQ+/RQ/P.CYL
          STML   SS+/SS/P.CYL  CYLINDER ADDRESS OF CURRENT REQUEST
          LDML   RQ+/RQ/P.TRACK
          ADC    4000B       SET SECTOR SIZE FOR HARDWARE
          STML   SS+/SS/P.TRACK  TRACK ADDRESS OF CURRENT REQUEST
          LDML   RQ+/RQ/P.SECTOR
          STML   SS+/SS/P.SECTOR  SECTOR ADDRESS OF CURRENT REQUEST
          RJM    SC          SAVE CLOCK
          UJK    SSAX
          SPACE  5,20
** NAME-- SVPTR
*
** PURPOSE-- SAVE BUFFER POINTERS IN CASE DATA RETRANSMISSION IS NEEDED.
          SPACE  2
 SVPTRX   LJM    **
 SVPTR    EQU    *-1
          LDML   CMLIST+/CM/P.LEN
          STDL   LEN         SAVE BYTE LENGTH
          LDN    2
          STDL   WC
          RJM    EXLOD       GET CM AREA ADDRESS
          ADN    /CB/C.SVAREA
          CWML   SVCELLS,WC  SAVE IT
          UJN    SVPTRX
          SPACE  5,20
** NAME-- SWITCH
*
** PURPOSE-- THE FIRST REQUEST AFTER A REQUEST SWITCH WAS SUCCESSFULLY
*            STARTED (NOW WE KNOW THAT NO ERRORS WERE DETECTED ON THE
*            PREVIOUS REQUEST). AT THIS POINT WE CAN UPDATE INTERNAL
*            POINTERS TO REFLECT THE REQUEST JUST STARTED.
          SPACE  2
 SWITCHX  LJM    **
 SWITCH   EQU    *-1
          LDN    0
          STDL   SWFLG       CLEAR SWITCH FLAG
          RJM    PDR         PREPARE DISK RESPONSE
          RJM    SNDRSP      SEND RESPONSE TO CM FOR LAST REQUEST
          AODL   NCOMRQ      INCREMENT NUMBER OF COMPLETED REQUESTS
          LDML   SS+/SS/P.SECTOR
          SBML   RQ+/RQ/P.SECTOR
          NJN    SW10        IF ERROR
          LDML   SS+/SS/P.TRACK
          LPN    77B
          SBML   RQ+/RQ/P.TRACK
          NJN    SW10        IF ERROR
          LDML   SS+/SS/P.CYL
          SBML   RQ+/RQ/P.CYL
          NJN    SW10        IF ERROR
          LDML   CURRQ       SAVE RMA OF PREVIOUS REQUEST
          STML   PRERQ
          LDML   CURRQ+1
          STML   PRERQ+1
          LDML   SS+/SS/P.REQ  SAVE RMA OF CURRENT REQUEST
          STML   CURRQ
          LDML   SS+/SS/P.REQ+1
          STML   CURRQ+1
          UJK    SWITCHX
 SW10     BSS
          RJM    HANG
          SPACE  5,20
** NAME-- TERM
*
** PURPOSE-- TERMINATE UNIT REQUEST
          SPACE  2
 TERM     BSS
          RJM    PDR         PREPARE DISK RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    DELRQ       DELINK COMPLETED REQUESTS FROM QUEUE
          RJM    RESPIN      UPDATE 'IN' POINTER FOR RESPONSE BUFFER
          RJM    CLRLOCK     CLEAR LOCK ON UNIT
          STML   RS+/RS/P.RTRY  CLEAR REQUEST RETRY COUNTER
          UJK    MAIN45      RETURN TO MAIN LOOP
          SPACE  5,20
** NAME-- TERMP
*
** PURPOSE-- SEND TERMINATION RESPONSE
          SPACE  2
 TERX     LJM    **
 TERMP    EQU    *-1
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
          UJK    TERX
          SPACE  5,20
** NAME-- UBT
*
** PURPOSE-- UPDATE BYTES TRANSFERRED
*
** EXIT--  MD = 0 IF NO MORE DATA
          SPACE  2
 UBTX     BSS
          STML   MD
          LJM    **
 UBT      EQU    *-1
          RJM    UC          UPDATE CLOCK
          LDML   BC          CM BYTES TRANSFERRED
          RAML   RS+/RS/P.XFER+1
          SHN    -16
          RAML   RS+/RS/P.XFER  UPDATE BYTES TRANSFERRED IN RESPONSE
          LDML   BC
          RAML   CMLIST+/CM/P.RMA+1  UPDATE CM ADDRESS
          SHN    -16
          RAML   CMLIST+/CM/P.RMA
          LDML   CMLIST+/CM/P.LEN
          SBML   BC
          STML   CMLIST+/CM/P.LEN
          NJN    UBT10       IF MORE BYTES TO TRANSFER TO THIS
                              CM ADDRESS
          SODL   CMLISTL
          ZJN    UBT20       IF END OF RMA LIST
          RJM    GLIST       READ NEXT ENTRY OF LIST
 UBT10    BSS
          LDN    1           INDICATE NO REQUEST SWITCH
          UJK    UBTX
 UBT20    BSS
          RJM    UNCMND      GET NEXT COMMAND
          NJN    UBT10       IF MORE COMMANDS
          RJM    CSWIT       CHECK FOR REQUEST SWITCH
          UJK    UBTX
          SPACE  5,20
** NAME-- UC
*
** PURPOSE-- UPDATE CLOCK.  THE CLOCK IS USED TO TIMEOUT COMMANDS.
          SPACE  2
 UCX      LJM    **
 UC       EQU    *-1
          LDDL   CLCUR
          STDL   P6          SAVE CURRENT CLOCK
          IAN    14B
          STDL   CLCUR
          SBDL   P6
          PJN    UC5         IF CLOCK HAS NOT WRAPPED
          ADC    10000B
 UC5      BSS
          RADL   CLMCS       UPDATE MICROSECOND PORTION OF CLOCK
          LDDL   CLMCS
          ADC    -2000
          MJN    UCX         IF LESS THAN 2 MILLISECONDS
          STDL   CLMCS
          LDN    2
          RADL   CLMLS       UPDATE MILLISECOND PORTION OF CLOCK
          ADC    -1000
          MJN    UCX         IF LESS THAN 1 SECOND
          STDL   CLMLS
          AODL   CLSEC       UPDATE SECOND PORTION OF CLOCK
          UJN    UCX
          SPACE  5,20
** NAME-- UDA
*
** PURPOSE-- UPDATE DISK ADDRESS.  USE OF FLAG FT KEEPS THE DISK
*            ADDRESS ACCURATE FOR ERROR REPORTING.
          SPACE  2
 UDA10    BSS
          AODL   FT          INDICATE NOT FIRST FUNCTION
 UDAX     LJM    **
 UDA      EQU    *-1
          LDDL   FT
          ZJN    UDA10       IF FIRST DATA FUNCTION
          AOML   SS+/SS/P.SECTOR UPDATE SECTOR
          SBN    MAXSEC+1
          MJN    UDAX        IF SAME TRACK
          STML   SS+/SS/P.SECTOR CLEAR SECTOR
          AOML   SS+/SS/P.TRACK UPDATE TRACK
          UJN    UDAX
          SPACE  5,20
** NAME-- UNCMND
*
** PURPOSE-- GET NEXT COMMAND.
*
** INPUT-- NUMCM, FRST, RS+/RS/P.LASTC
*
** OUTPUT-- CMLIST, FNC, RQ+/RQ/P.CMND
*           CMLISTL.
*
** EXIT-- A REGISTER = 0, IF NO MORE COMMANDS.
*         A REGISTER .NE. 0, IF NEXT COMMAND PRESENT.
          SPACE  2
 UNCX     LJM    **
 UNCMND   EQU    *-1
          LDML   NUMCM
          ZJN    UNCX        IF NO MORE COMMANDS, EXIT, A REGISTER = 0
          SOML   NUMCM       DECREMENT COMMAND COUNT
          LDML   FRST        HAS FIRST COMMAND BEEN PROCESSED
          ZJN    UNC10       IF FIRST COMMAND HASN'T BEEN PROCESSED

*         READ NEXT COMMAND FROM CM.

          AOML   SS+/SS/P.LASTC OFFSET TO COMMAND
          LDN    C.CM
          STDL   WC
          LOADF  SS+/SS/P.REQ  LOAD CM ADDRESS AND REFORMAT
          ADML   SS+/SS/P.LASTC ADD OFFSET OF COMMAND
          CRML   CM,WC       READ COMMAND FROM CM
 UNC10    BSS
          AOML   FRST        SET NONZERO

*         IF INDIRECT ADDRESS, READ CM ADDRESS LIST.

          LDN    0
          STDL   FNC         SET UP INTERNAL FUNCTION CODE
          LDML   CM+/CM/P.LEN  ENSURE AN EVEN NUMBER OF CM WORDS
          ADN    7
          SCN    7
          STML   CM+/CM/P.LEN
          STML   CMLIST+/CM/P.LEN
          SHN    -3
          STDL   CMLISTL     LENGTH OF CM ADDRESS AREA  (CM WORDS)
          LDML   CM+/CM/P.INDIR
          SHN    /CM/L.INDIR+2
          PJN    UNC15       IF NOT INDIRECT ADDRESS
          RJM    GLIST       GET CM ADDRESS LIST OF DATA AREA
          UJN    UNC30
 UNC15    BSS
          LDN    1
          STDL   CMLISTL     IF NOT INDIRECT, ONLY 1 COMMAND.
          LDML   CM+/CM/P.RMA
          STML   CMLIST+/CM/P.RMA
          LDML   CM+/CM/P.RMA+1
          STML   CMLIST+/CM/P.RMA+1

*         SET UP INTERNAL FUNCTION CODE, FNC.

 UNC30    BSS
          LDML   CM+/CM/P.CODE  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          SBML   UCMD,FNC    COMPARE COMMAND CODE
          ZJN    UNC40       IF COMMAND FOUND
          AODL   FNC
          SBN    UCMDL
          MJN    UNC30       IF MORE COMMANDS TO CHECK
          LDC    E501        ERROR IN COMMAND CODE
          RJM    INTERR      INTERFACE ERROR (NO RETURN)
 UNC40    BSS
          LDN    1           SET A REGISTER NONZERO FOR EXIT
          UJK    UNCX
          SPACE  5,20
** NAME-- UREQ
*
** PURPOSE-- READ A UNIT REQUEST FROM CM.
*
** INPUT-- SS TABLE WHICH IDENTIFIES THE UNIT QUEUE.
*
** OUTPUT-- RQ  CONTAINS CURRENT REQUEST.
*           FRST = 0
*           NUMCM = NUMBER OF COMMANDS.
          SPACE  2
 UREQX    LJM    **
 UREQ     EQU    *-1
          LDN    0
          STML   FRST        SET FLAG WHEN REQUEST IS READ
          LDN    3           NUMBER OF WORDS TO READ
          STDL   WC
          LOADF  SS+/SS/P.REQ  LOAD CM ADDRESS AND REFORMAT
          ADN    2
          CRML   RQ+2*4,WC   READ CURRENT REQUEST
          SBN    5
          CRML   RQ,WC       READ SWITCH FLAG BEFORE LINKAGE POINTERS
          LDML   RQ+/RQ/P.LEN  DETERMINE NUMBER OF COMMANDS
          SHN    -3
          SBN    /RQ/C.CMND
          STML   NUMCM       NUMBER OF COMMANDS
          UJK    UREQX
          SPACE  5,20
** NAME-- USC
*
** PURPOSE-- UPDATE SAVED CLOCK
          SPACE  2
 USCX     LJM    **
 USC      EQU    *-1
          LDDL   PPNO        LOGICAL PP NUMBER
          SBML   SS+/SS/P.LPP
          ZJN    USCX        IF CLOCK START VALUE ACCURATE
          LDDL   PPNO
          STML   SS+/SS/P.LPP
          LDDL   CLMLS
          STDL   P6
 USC5     BSS
          SBML   SS+/SS/P.SEEKTM+1
          STML   SS+/SS/P.CLKST+1
          PJN    USC10       IF CLOCK HASN'T WRAPPED
          AOML   SS+/SS/P.SEEKTM
          LDC    1000        MILLISECONDS PER SECOND
          RADL   P6
          UJN    USC5
 USC10    BSS
          LDDL   CLSEC
          SBML   SS+/SS/P.SEEKTM
          PJN    USC30       IF CLOCK HASN'T WRAPPED
          ADC    0#10000
 USC30    BSS
          STML   SS+/SS/P.CLKST
          RJM    SAVSS
          UJK    USCX
          SPACE  5,20
** NAME-- WCR
*
** PURPOSE-- WRITE CONTROL REGISTER VALUE
*
** ENTRY--  CONTENTS OF T3 IS CONTROL REGISTER VALUE
          SPACE  2
 WCRX     LJM    **
 WCR      EQU    *-1
          STDL   T3
          LDN    T3
          STML   OUT10       ADDRESS TO OUTPUT FROM
          LDC    F.WCR       WRITE CONTROL REGISTER
          RJM    FUNC
          LDN    1           WORDS TO OUTPUT
          RJM    OUT         OUTPUT DATA
          RJM    DCN         DISCONNECT THE CHANNEL
          UJN    WCRX
          SPACE  5,20
** NAME-- WFI
*
** PURPOSE-- WAIT FOR CHANNEL INACTIVE
          SPACE  2
 WFIX     LJM    **
 WFI      EQU    *-1
          LCN    0
 WFI10    BSS
          IJM    WFIX,DC     IF CHANNEL INACTIVE
          SBN    1
          NJN    WFI10       IF TIMEOUT NOT EXPIRED
          LJM    OUT20
          SPACE  5,20
** NAME-- WFTC
*
** PURPOSE-- WAIT FOR TRANSFER COMPLETE
*
** ENTRY-- A = EXPECTED OPERATIONAL STATUS
*
** EXIT-- TO CALLING ROUTINE IF NO ERROR
          SPACE  2
 WFTCX    BSS
          STDL   SECPOS      CLEAR SECTOR POSITION
          LDC    F.CDM       CLEAR DMA MODE
          RJM    FUNC
          LJM    **
 WFTC     EQU    *-1
          STDL   T7
          LDC    9677
          STDL   T8          T8 CONTROLS THE TIMEOUT
 WFTC10   BSS
          RJM    ROS         READ OPERATIONAL STATUS
          LMDL   T7
          ZJN    WFTCX       IF NO ERROR
          SODL   T8
          NJN    WFTC10      IF 150 MILLISECOND TIMEOUT NOT EXPIRED
          LDC    F.CDM       CLEAR DMA MODE
          RJM    FUNC
          RJM    GENSTAT     GET GENERAL STATUS
          LDN    E19         TRANSFER IN PROGRESS DID NOT CLEAR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE
          SPACE  5,20
** NAME-- WFTE
*
** PURPOSE-- WAIT FOR T PRIME REGISTER EMPTY
*
** EXIT - TO CALLING ROUTINE IF T PRIME REGISTER GOES EMPTY,
*         ELSE REPORT AN ERROR
          SPACE  2
 WFTEX    LJM    **
 WFTE     EQU    *-1
          LDC    9836
          STDL   T8          T8 CONTROLS THE TIMEOUT
 WFTE10   BSS
          RJM    ROS         READ OPERATIONAL STATUS
          LPN    2
          NJN    WFTEX       IF T PRIME REGISTER EMPTY
          SODL   T8
          NJN    WFTE10      IF 150 MILLISECOND TIMEOUT NOT EXPIRED
          LDC    F.CDM       CLEAR DMA MODE
          RJM    FUNC
          RJM    GENSTAT
          LDN    E20         T PRIME REGISTER NOT EMPTY
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- WFUL
*
** PURPOSE-- WAIT FOR UNIT LOCK
          SPACE  2
 WFULX    LJM    **
 WFUL     EQU    *-1
 WFUL10   BSS
          RJM    SETLOCK     SET UNIT LOCK
          NJN    WFULX       IF LOCK SET
          UJN    WFUL10
          SPACE  5,20
** NAME-- WTR
*
** PURPOSE-- WRITE T REGISTER
          SPACE  2
 WTRX     LJM    **
 WTR      EQU    *-1
          LDC    F.WTR       WRITE T REGISTER
          RJM    FUNC
          LDK    BC          ADDRESS OF T REGISTER VALUES
          STML   OUT10
          LDN    3           NUMBER OF WORDS IN T REGISTER
          RJM    OUT         OUTPUT PARAMETERS
          RJM    DCN         DISCONNECT THE CHANNEL
          UJN    WTRX
          ERRPL  *-OVST      IF RESIDENT CODE SPILLS INTO OVERLAY AREA
          SPACE  5,20
** NAME-- INIT
*
** PURPOSE-- REFORMAT AND SAVE ADDRESS OF PPIT AND OVERLAY
*            DIRECTORY.  THIS CODE MAY BE OVERLAYED AFTER IT
*            IS EXECUTED.
          SPACE  2
 INIT     BSS
          REFAD  DSRTP,CM.PIT REFORMAT ADDRESS OF PP INTERFACE TABLE
                               AND SAVE AT CM.PIT
          ADN    /PIT/C.CBUF
          CRDL   P1          READ RMA OF PP COMMUNICATIONS BUFFER
          LOADF  P3          REFORMAT ADDRESS OF COMMUNICATIONS BUFFER
          ADN    /CB/C.ODP
          CRDL   T1          READ RMA OF OVERLAY DIRECTORY
          REFAD  T3,DH       REFORMAT ADDRESS OF OVERLAY DIRECTORY
                              AND SAVE AT DH
          LJM    MAIN
          OVERLAY (CONFIDENCE TEST),OVST
          ROUTINE CTO        CONFIDENCE TEST OVERLAY
          SPACE  5,20
** NAME-- BCTB
*
** PURPOSE-- BUILD CONFIDENCE TEST BUFFER
          SPACE  2
 BCTBX    LJM    **
 BCTB     EQU    *-1
          IAN    14B
          STML   CTB         STARTING VALUE FOR INCREMENTING PATTERN
          STDL   P1
          LOADF  CTBRMA      CM ADDRESS OF CONFIDENCE TEST BUFFER
          STDL   P2
 BCTB10   BSS
          AODL   P1          BUILD INCREMENTING PATTERN
          STDL   T1
          AODL   P1
          STDL   T2
          AODL   P1
          STDL   T3
          AODL   P1
          STDL   T4
          SBML   CTB
          ADC    -P.CB-4+/CB/P.BUF
          PJN    BCTBX       IF ALL WORDS STORED
          LDDL   P2
          LMC    400000B
          CWDL   T1          STORE IN PP COMMUNICATIONS BUFFER
          AODL   P2
          UJK    BCTB10
          SPACE  5,20
** NAME-- CT
*
** PURPOSE-- CONFIDENCE TEST.  RESERVE DRIVE, WRITE, READ, VERIFY
*            DATA ON THE CONFIDENCE TEST CYLINDER, THEN RELEASE THE
*            DRIVE IF INITIALIZATION CONFIDENCE TEST.
*
** ENTRY
*         1) AT INITIALIZATION WHEN PP IS LOADED
*         2) WHEN PP IS RESUMED
*         3) DURING ERROR RECOVERY TO ISOLATE AN ERROR TO MEDIA
          SPACE  2
 CTX      BSS
          LDN    0
          STDL   COMLOOK     ENSURE COMLOOK HAS A LEGAL VALUE
          LDN    1
          STDL   CTF         CONFIDENCE TEST COMPLETE
          LJM    **
 CT       EQU    *-1
 F        IFEQ   FE,1        FOR FORCING ERRORS
          LDN    4
          CRDL   T1
          LDDL   T1
          LMN    0#13
          NJN    CT30        IF NOT MODIFYING THE DELAY
          LDDL   T2
          STML   CT10
          LDDL   T3
          STML   CT20
          UJN    CT30
 CT10     DATA   1           VALUE TIMES .5 IS WRITE DELAY
 CT20     DATA   1           VALUE TIMES .5 IS READ DELAY
 CT30     BSS
 F        ENDIF
          LDN    0
          STDL   COMLOOK
          UJN    CT50
 CT40     BSS
          AODL   COMLOOK     UPDATE TO NEXT UNIT
 CT50     BSS
          SBDL   DEVL
          PJN    CTX         IF END OF CONFIGURED UNITS
          RJM    RDT         READ DEVICE TABLE
          SHN    -1
          NJK    CT40        IF NOT RUNNING CONFIDENCE TEST
          LDDL   CTF
          NJN    CT60        IF ORIGINAL ERROR OCCURRED ON A REQUEST
          LDC    SPLUT       SPARE LOGICAL UNIT TABLE
          STDL   LUTLOC
          LDN    1
          STDL   WC
          LOADC  CM.DEV      ADDRESS OF DEVICE TABLE
          ADDL   COMLOOK     INDEX INTO TABLE
          CRML   SPLUT+2,WC  ADDRESS OF UNIT INTERFACE TABLE
 CT60     BSS
          RJM    PPREQ       CHECK FOR IDLE REQUEST
          RJM    WFUL        WAIT FOR UNIT LOCK
          RJM    RDT         READ DEVICE TABLE
          LOADC  P3          ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T1
          LDDL   T1+/UIT/P.DSABLE
          SHN    2+/UIT/L.DSABLE
          PJN    CT70        IF UNIT ENABLED
          RJM    CLRLOCK     CLEAR UNIT LOCK
          UJK    CT40
 CT70     BSS
          RJM    CTDT        CONFIDENCE TEST DATA TRANSFER
 CT80     BSS
          LDDL   CTF
          NJN    CT90        IF NOT INITIALIZATION CONFIDENCE TEST
          STML   RS+/RS/P.RTRY CLEAR RETRY COUNTER
          LDN    F.OPCMP
          RJM    FUNC        RELEASE THE DRIVE
          RJM    CLRLOCK     CLEAR UNIT LOCK
 CT90     BSS
          RJM    RDT         READ DEVICE TABLE
          LPN    /CB/K.ACT
          LMN    2
          STDL   P2          INDICATE CONFIDENCE TEST SUCCESSFUL
          LDML   CM.DEV+2
          ADDL   COMLOOK
          LMC    400000B
          CWDL   P2          SAVE IN DEVICE TABLE
          UJK    CT40
          SPACE  5,20
** NAME-- CTDT
*
** PURPOSE-- CONFIDENCE TEST DATA TRANSFER
          SPACE  2
 CTDTX    LJM    **
 CTDT     EQU    *-1
          LDN    F.OPCMP     OPERATION COMPLETE (ENSURE CHAINING IS CLEARED)
          RJM    FUNC
          LOADR  /LUT/P.UIT,LUTLOC  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.UBUF
          CRDL   T4          ADDRESS OF UNIT COMMUNICATIONS BUFFER
          LDN    C.SS
          STDL   WC
          LOADF  T6          ADDRESS OF SS TABLE
          CRML   SS,WC       READ SS TABLE
          LDC    MAXCYL-1
          STML   SS+/SS/P.CYL CONFIDENCE TEST CYLINDER
          LDC    4000B
          STML   SS+/SS/P.TRACK TRACK
          LDN    0
          STML   SS+/SS/P.SECTOR SECTOR
          STDL   FT          INDICATE FIRST FUNCTION
          LCN    0           MAKE MEDIA ERROR TABLE LOOK EMPTY
          STML   SS+CTME
          STML   SS+CTME+1
          STML   SS+CTME+2
          RJM    BCTB        BUILD CONFIDENCE TEST BUFFER
          LDML   RS+/RS/P.RTRY
          SBN    2
          MJN    CTDT5       IF NOT DOING UNCONDITIONAL RESERVE
          RJM    UR          UNCONDITIONAL RESERVE
 CTDT5    BSS
          RJM    SEEKON      WAIT FOR ON CYLINDER
*
*         WRITE THE CYLINDER (CM TO DISK)
*
          LDC    CTDT15
          STDL   CA          CONTINUE ADDRESS
          LDC    BPS
          STDL   BC          BYTE COUNT
          LDML   CTBRMA      CM ADDRESS TO GET DATA FROM
          STDL   RMA
          LDML   CTBRMA+1
          STDL   RMA+1
 CTDT10   BSS
          LDN    F.WRITE
          RJM    FUNC        WRITE FUNCTION
 CTDT15   BSS
          LDDL   FT
          ZJN    CTDT20      IF NOT TIME TO UPDATE CM
          LDN    8           UPDATE RMA TO NEXT SECTOR
          RAML   RMA+1
          SHN    -16
          RAML   RMA
 CTDT20   BSS
          RJM    UDA         UPDATE DISK ADDRESS
 F        IFEQ   FE,1
          LDN    4
          CRDL   T1
          LDDL   T1
          LMN    0#15
          NJN    CTDT25      IF NOT FORCING AN ERROR
          LDDL   T2
          ZJN    CTDT25      IF NOT FORCING AN ERROR
          SOML   T2
          LDN    4
          CWDL   T1
          LDDL   T3          CONTROL REGISTER VALUE
          RJM    WCR         WRITE CONTROL REGISTER
 CTDT25   BSS
 F        ENDIF
          RJM    WTR         WRITE T REGISTER
          LDC    F.SDO       START DMA OUTPUT
          RJM    FUNC
          LDN    0#32        EXPECTED OPERATIONAL STATUS
          RJM    WFTC        WAIT FOR TRANSFER COMPLETE
 F        IFEQ   FE,1        FOR FORCING ERRORS
          LDML   CT10
          SBN    1
          NJN    *-1         FOR TESTING
 F        ENDIF

          LDML   SS+/SS/P.SECTOR
          ADML   SS+/SS/P.TRACK
          LPN    77B
          SBN    MAXSEC+MAXTR
          NJK    CTDT10      IF MORE SECTORS TO TRANSFER
          RJM    GENSTAT     GET GENERAL STATUS
          NJK    CTDT90      IF ERROR
 CTDT45   BSS
          LDC    4000B
          STML   SS+/SS/P.TRACK CLEAR TRACK NUMBER
          LDN    0
          STML   SS+/SS/P.SECTOR  CLEAR SECTOR NUMBER
 CTDT50   BSS
          STDL   FT          INDICATE FIRST FUNCTION
          STDL   FNC         INDICATE READ OPERATION
          RJM    SEEKON      SEEK, WAIT FOR ON CYLINDER
*
*         READ THE CYLINDER (DISK TO CM)
*           ONLY THE DATA IN THE FIRST SECTOR OF EACH HEAD IS VERIFIED.
*           THIS ALLOWS THE PP TO STREAM DATA FOR 10 SECTORS.
*
          LDC    CTDT65
          STDL   CA          CONTINUE ADDRESS
          LDN    0
          STML   DMF         CLEAR DATA MISCOMPARE FLAG
          LDML   CTBRMA      CM ADDRESS TO PUT DATA
          STDL   RMA
          LDML   CTBRMA+1
          STDL   RMA+1
 CTDT60   BSS
          LDN    F.READ
          RJM    FUNC        SEND READ FUNCTION
          LDDL   FT
          ZJN    CTDT65      IF FIRST FUNCTION
          LDML   DMF
          ZJN    CTDT65      IF NO DATA MISCOMPARE
          LDN    E07         PP - DRIVE DATA INTEGRITY ERROR
          STDL   T1
          RJM    RDT         READ DEVICE TABLE
          LPN    /CB/K.ACT
          LMN    8
          STDL   P2
          LOADC  CM.DEV
          ADDL   COMLOOK
          CWDL   P2          INDICATE DATA INTEGRITY ERROR
          LDDL   T1
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
 CTDT65   BSS
          RJM    UDA         UPDATE DISK ADDRESS
 F        IFEQ   FE,1
          LDN    4
          CRDL   T1
          LDDL   T1
          LMN    0#16
          NJN    CTDT67A     IF NOT FORCING AN ERROR
          LDDL   T2
          ZJN    CTDT67A     IF NOT FORCING AN ERROR
          SOML   T2
          LDN    4
          CWDL   T1
          LDDL   T3          CONTROL REGISTER VALUE
          RJM    WCR         WRITE CONTROL REGISTER
 CTDT67A  BSS
 F        ENDIF
          RJM    WTR         WRITE TRANSFER REGISTER
          LDC    F.SDI       START DMA INPUT
          RJM    FUNC
          LDN    0#2E        EXPECTED OPERATIONAL STATUS
          RJM    WFTC        WAIT FOR TRANSFER COMPLETE
          LDML   SS+/SS/P.SECTOR
          NJN    CTDT80      IF NOT FIRST SECTOR OF TRACK
          RJM    VCTD        VERIFY CONFIDENCE TEST DATA
 CTDT80   BSS
 F        IFEQ   FE,1        FOR FORCING ERRORS
          LDML   CT20
          SBN    1
          NJN    *-1
 F        ENDIF

          LDML   SS+/SS/P.SECTOR
          ADML   SS+/SS/P.TRACK
          LPN    77B
          SBN    MAXSEC+MAXTR
          NJK    CTDT60      IF MORE SECTORS TO TRANSFER
          RJM    GENSTAT     GET GENERAL STATUS
          NJN    CTDT90      IF ERROR
          UJK    CTDTX
 CTDT90   BSS
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- UR
*
** PURPOSE-- UNCONDITIONAL RESERVE OF THE DRIVE
*
** NOTE-- UNCONDITIONAL RESERVE ONLY WORKS IF CHAINING HAS BEEN DROPPED
*         BY THE OTHER STORAGE DIRECTOR.
          SPACE  2
 URX      BSS
          LDN    F.OPCMP
          RJM    FUNC        OPERATION COMPLETE (DROP CHAINING)
          LJM    **
 UR       EQU    *-1
          LDN    F.CONECT
          RJM    FUNC        SEND CONNECT FUNCTION
          LDML   SS+/SS/P.UNIT
          ADC    4000B
          STDL   T1          UNIT NUMBER/UNRECOVERED RESPONSE
          LDN    T1
          STML   OUT10       ADDRESS TO OUTPUT FROM
          LDN    1
          RJM    OUT         OUTPUT PARAMETER WORD
          RJM    DCN         DISCONNECT THE CHANNEL
          RJM    GENSTAT     GET GENERAL STATUS
          ZJN    URX         IF NO ERROR
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- VCTD
*
** PURPOSE-- VERIFY CONFIDENCE TEST DATA
          SPACE  2
 VCTDX    LJM    **
 VCTD     EQU    *-1
          LDN    0
          STDL   P1
          LDML   SS+/SS/P.TRACK
          SHN    8
          STDL   P2          PUT CURRENT TRACK, SECTOR IN ONE WORD
 VCTD3    BSS
          LDML   SS+CTME,P1
          LMDL   P2
          ZJK    VCTDX       IF SECTOR NOT WRITTEN
          AODL   P1
          LMN    3
          NJN    VCTD3       IF MORE TABLE LOCATIONS TO CHECK
          LDC    BPS/8
          STDL   P3          CM WORDS PER SECTOR
          LDN    0
          STDL   T2
          LDML   SS+/SS/P.TRACK
          LPN    77B
          STDL   T1
 VCTD5    BSS
          ZJN    VCTD10      IF SECTORS TRANSFERRED CALCULATION DONE
          LDN    MAXSEC+1
          RADL   T2
          SODL   T1
          UJN    VCTD5
 VCTD10   BSS
          LDDL   T2          SECTORS TRANSFERRED
          SHN    2
          ADML   CTB
          STDL   P1          STARTING DATA PATTERN VALUE MINUS ONE
          LOADF  CTBRMA
          STDL   P2
 VCTD15   BSS
          LDDL   P2
          LMC    400000B
          CRDL   T4          READ WORD OF SECTOR
          AODL   P1
          SBDL   T4
          NJN    VCTD40      IF DATA MISCOMPARE
          AODL   P1
          SBDL   T5
          NJN    VCTD40      IF DATA MISCOMPARE
          AODL   P1
          SBDL   T6
          NJN    VCTD40      IF DATA MISCOMPARE
          AODL   P1
          SBDL   T7
          NJN    VCTD40      IF DATA MISCOMPARE
          AODL   P2
          SODL   P3
          NJN    VCTD15      IF MORE WORDS TO VERIFY
 VCTD40   BSS
          STML   DMF         INDICATE DATA MISCOMPARE
          UJK    VCTDX
          ERRPL  *-17777B    IF OVERFLOWING MEMORY
          OVERLAY (ERROR RECOVERY),OVST
          ROUTINE ERO        ERROR RECOVERY OVERLAY
          SPACE  5,20
** NAME-- OE
*
** PURPOSE-- TURN OFF ALL UNITS ON AN EQUIPMENT
*
** ENTRY
*         A = 0 TO TURN OFF ALL UNITS ON AN A CHANNEL
*         A NOT 0 TO TURN OFF ALL UNITS ON A STORAGE DIRECTOR
          SPACE  2
 OEX      LJM    **
 OE       EQU    *-1
          STDL   P2
          LDDL   DEVL
          ZJN    OEX         IF NO UNITS
          LDN    0
          STDL   COMLOOK     SET TO BEGINNING OF CM.DEV TABLE
          LDDL   LUTLOC
          STDL   P1          SAVE LUTLOC
          LDK    SPLUT       SPARE LOGICAL UNIT TABLE
          STDL   LUTLOC
 OE2      BSS
          LDN    1
          STDL   WC
          LOADC  CM.DEV      ADDRESS OF DEVICE TABLE
          ADDL   COMLOOK     INDEX INTO TABLE
          CRML   SPLUT+2,WC
          LOADR  SPLUT+/LUT/P.UIT
          CRDL   T1          GET FIRST WORD OF UIT
          ADN    /UIT/C.UBUF
          CRDL   T5          GET SECOND WORD OF UIT
          LDDL   T1+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJK    OE50        IF UNIT DISABLE ALREADY IS SET
          RJM    WFUL        WAIT FOR UNIT LOCK
          LDN    C.SS
          STDL   WC          LENGTH OF SS TABLE
          LOADF  T7
          CRML   SS,WC       READ SS ENTRY
          LDML   IDLE        IS THIS TRIP A RESULT OF AN IDLE COMMAND
          NJN    OE20        IF YES, AVOID TURNING OFF THE UNIT
          LDDL   P2
          ZJN    OE10        IF OFFING A CHANNEL
          LDML   RS+/RS/P.UNIT
          LMML   SS+/SS/P.UNIT
          LPN    40B
          NJN    OE20        IF DIFFERENT STORAGE DIRECTOR
 OE10     BSS
          LOADR  SPLUT+/LUT/P.UIT  ADDRESS OF UIT
          RJM    OFFUN       GO SET THE UNIT OFF
 OE20     BSS
          LDN    0           CLEAR THE REQUEST SELECTED FLAG
          STML   SS+/SS/P.ENTRY
          RJM    SAVSS       SAVE THE SS ENTRY
          RJM    CLRLOCK     UNLOCK UNIT
 OE50     BSS
          AODL   COMLOOK     ARE ALL UNITS PROCESSED?
          SBD    DEVL
          NJK    OE2         NO, GO TO THE NEXT ONE
          STDL   COMLOOK     ENSURE COMLOOK HAS LEGAL VALUE
          LDDL   P1
          STDL   LUTLOC      RESTORE LUTLOC
          LJM    OEX
          SPACE  5,20
** NAME-- OFFUN
*
** PURPOSE-- SET THE DISABLE FLAG IN THE UNIT INTERFACE TABLE.
*
** INPUT-- A & R REGISTERS = CM ADDRESS OF UNIT INTERFACE TABLE.
          SPACE  2
 OFUX     LJM    **
 OFFUN    EQU    *-1
          STDL   T1
          LDK    /UIT/K.DSABLE  SET UNIT DISABLE FLAG
          STDL   T3
          LDN    0
          STDL   T2
          STDL   T4
          STDL   T5
          LDDL   T1
          LMC    400000B
          RDSL   T2          -LOGICAL OR- THE UNIT DISABLE FLAG
          UJN    OFUX
          SPACE  5,20
** NAME-- PIR
*
** PURPOSE-- PROCESS IDLE OR RESUME COMMAND
          SPACE  2
 PIR      CON    0
          LDDL   T5
          SHN    /PIT/L.IDLREQ+2
          MJN    PIR10       IF IDLE REQUEST
          LDDL   T4          CLEAR ACTIVE CHECK BIT, RESUME REQUEST
          LPC    0#4FFE       BIT, IDLE STATUS BIT, AND LOCK BIT IN
          STDL   T4           PP INTERFACE TABLE
          LDDL   CM.PIT+2
          LMC    400000B
          CWDL   T1
          LDN    0
          STML   IDLE        CLEAR IDLE FLAG
          LJM    MAIN
 PIR10    BSS
          LDDL   NCOMRQ
          SBN    2
          MJN    PIR15       IF NO COMPLETED REQUESTS TO DELINK
          SOML   NCOMRQ      MAKE COMPLETED REQUEST COUNT ACCURATE
          LDML   PRERQ       DELINK REQUESTS FROM FCOMRQ THRU CURRQ
          STML   CURRQ
          LDML   PRERQ+1
          STML   CURRQ+1
          RJM    DELRQ       DELINK COMPLETED REQUESTS
 PIR15    BSS
          AOML   IDLE        SET IDLE FLAG
          LDN    0
          RJM    OE          CLEAR  UNIT LOCKS
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          LOADC  CM.PIT      ADDRESS OF PP INTERFACE TABLE
          CRDL   T1          READ FIRST WORD OF PP INTERFACE TABLE
          LDDL   T4
          LPC    0#2FFE      CLEAR ACTIVE CHECK BIT, IDLE REQUEST BIT,
          LMC    0#1000       CLEAR LOCK BIT, AND SET THE IDLE STATUS BIT
          STDL   T4
          LDDL   CM.PIT+2
          LMC    400000B
          CWDL   T1
 PIR20    BSS
          RJM    PPREQ       WAIT FOR RESUME
          UJN    PIR20
          SPACE  5,20
** NAME-- RSTBP
*
** PURPOSE-- RESTORE BUFFER POINTERS WHEN THE READ PROCESS HAS TO
*            BACK UP 1 SECTOR.
          SPACE  2
 RSTBPX   LJM    **
 RSTBP    EQU    *-1
          LDN    2           LENGTH OF SAVE AREA
          STDL   WC
          RJM    EXLOD       ADDRESS OF COMMUNICATIONS BUFFER
          ADN    /CB/C.SVAREA
          CRML   SVCELLS,WC  READ THE BACKED UP POINTERS
          LDDL   CMRMA       RESTORE RMA DATA POINTERS
          STML   CM+/CM/P.RMA
          LDDL   CMRMA+1
          STML   CM+/CM/P.RMA+1
          LDDL   LEN
          STML   CMLIST+/CM/P.LEN
          LDDL   RMA
          STML   CMLIST+/CM/P.RMA
          LDDL   RMA+1
          STML   CMLIST+/CM/P.RMA+1
          LDN    0
          STDL   SWFLG
          UJN    RSTBPX      EXIT
          SPACE  5,20
** NAME-- RSTRQ
*
** PURPOSE-- SET UP FOR REQUEST RETRY
          SPACE  2
 RSTRQ    CON    0
          LDN    0
          STML   RS+/RS/P.HDWR  CLEAR ERROR STATUS
          LDDL   CTF
          ZJK    MAIN5       IF ERROR DURING CONFIDENCE TEST
          LDN    F.OPCMP     OPERATION COMPLETE (ENSURE CHAINING IS CLEARED)
          RJM    FUNC
          LDDL   FNC
          SBN    2
          NJN    RSTRQ2      IF NOT FORMAT
          LJM    FMTR        FORMAT RETRY
 RSTRQ2   BSS
          LDN    0
          STDL   SWFLG       CLEAR SWITCH FLAG
          LDML   SIP
          ZJK    RSTRQ20     IF SEEK IN PROGRESS
          LDDL   NCOMRQ
          SBN    2
          MJN    RSTRQ10     IF NO COMPLETED REQUESTS TO DELINK
          SODL   NCOMRQ
          LDML   PRERQ       DELINK REQUESTS THROUGH CURRQ
          STML   CURRQ
          LDML   PRERQ+1
          STML   CURRQ+1
          RJM    DELRQ       DELINK COMPLETED REQUESTS
          UJN    RSTRQ25
 RSTRQ10  BSS
          LDML   CURRQ       RESTORE RMA OF CURRENT REQUEST
          STML   SS+/SS/P.REQ
          LDML   CURRQ+1
          STML   SS+/SS/P.REQ+1
          LDML   RS+/RS/P.PVA  RESTORE PVA OF CURRENT REQUEST
          STML   SS+/SS/P.PVA
          LDML   RS+/RS/P.PVA+1
          STML   SS+/SS/P.PVA+1
          LDML   RS+/RS/P.PVA+2
          STML   SS+/SS/P.PVA+2
          RJM    SSA         SET SEEK ADDRESS
          UJN    RSTRQ30
 RSTRQ20  BSS
          RJM    POLS        POLL SUBROUTINE
          RJM    UREQ        READ UNIT REQUEST FROM CM
 RSTRQ25  BSS
          RJM    SETRQ       SET UP FOR FIRST REQUEST
 RSTRQ30  BSS
          RJM    SAVSS       SAVE SS TABLE
          RJM    SRESP       SET UP RESPONSE BUFFER
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
          RJM    SEEKON      ISSUE SEEK
          LJM    MAIN30
          ERRPL  *-17777B    IF OVERFLOWING MEMORY
          OVERLAY (FORMAT PACK),OVST
          ROUTINE FMO        FORMAT OVERLAY
** NAME-- FC
*
** PURPOSE-- FORMAT ONE CYLINDER
          SPACE  2
 FCX      LJM    **
 FC       EQU    *-1
 F        IFEQ   FE,1        IF FORCING ERRORS
          LDN    4
          CRDL   T1
          LDDL   T1
          LMN    0#14
          NJN    FC4         IF NOT CHANGING THE RECORD SIZE
          LDDL   T2
          STML   FUN+1       SET RECORD SIZE
 FC4      BSS
 F        ENDIF
          LDML   SS+/SS/P.UNIT
          ADC    2300B       WRITE RECORDS, CYLINDER MODE
          STML   FUN         PUT UNIT ADDRESS IN PARAMETER LIST
          LDN    F.FMP
          RJM    FUNC        FORMAT FUNCTION
          LDC    FBUF
          STML   OUT10       ADDRESS OF FORMAT PARAMETERS
          LDN    18
          RJM    OUT         OUTPUT FORMAT PARAMETERS
          RJM    DCN         DISCONNECT THE CHANNEL
          LDDL   CLSEC
          STML   SS+/SS/P.CLKST
 FC10     BSS
          RJM    GENSTAT     GET GENERAL STATUS
          ZJK    FCX         IF FORMAT COMPLETE
          RJM    UC          UPDATE CLOCK
          LDDL   CLSEC
          SBML   SS+/SS/P.CLKST
          PJN    FC20        IF CLOCK HAS NOT WRAPPED
          ADC    0#10000
 FC20     BSS
          SBN    5
          MJN    FC10        IF TIMEOUT NOT EXPIRED
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- FORMD
*
** PURPOSE-- PROCESS TO FORMAT DISK COMMAND.
*
** INPUT-- CMLISTL = NUMBER OF ADDRESS-LENGTH ENTRIES IN THE
*                    COMMAND WHICH ARE LEFT TO PROCESS.
*          CMLIST  = A TABLE OF THE ADDRESS-LENGTH PAIRS POINTING TO
*                    THE CM DATA AREA.
          SPACE  2
 FORMD    CON    0
          LDN    E00
          RJM    PER         PREPARE ERROR RESPONSE
          LDK    /RS/K.FORS
          STML   RS+/RS/P.ID
          RJM    INTRS       TELL OPERATOR THAT FORMATTING IS STARTING

* THE CYL NUMBERS ARE AT ANOTHER LEVEL OF INDIRECTION.

          LDML   CMLIST+/CM/P.LEN  TAKE OUT 1 LEVEL OF INDIRECTION
          STML   CM+/CM/P.LEN
          SHN    -3          RESET CMLISTL
          STDL   CMLISTL
          LDML   CMLIST+/CM/P.RMA
          STML   CM+/CM/P.RMA
          LDML   CMLIST+/CM/P.RMA+1
          STML   CM+/CM/P.RMA+1
          RJM    GLIST       GO GET THE CYLINDER NUMBERS

 FORMD5   BSS
          LDML   CMLIST+/CM/P.RMA  STARTING CYLINDER
          STML   SS+/SS/P.CYL   PUT IT IN THE SS ENTRY
 FORMD10  BSS
          LDDL   CMLISTL
          STML   SS+/SS/P.LISTL  SAVE CURRENT CMLISTL POINTER
 FORMD20  BSS
          LDML   SS+/SS/P.CYL
          STML   FBUF        PUT CYLINDER NUMBER IN PARAMETER LIST
 F        IFEQ   FE,1        FOR FORCING ERRORS
          LDN    4
          CRDL   T1
          LDDL   T1
          LMN    0#11
          NJN    FORMD30     IF NOT FORCING AN ERROR
          LDDL   T2
          ZJN    FORMD30     IF NOT FORCING AN ERROR
          LCN    0           FORCE ERROR BY SENDING AN ILLEGAL
          STML   FBUF         CYLINDER NUMBER
          SODL   T2
          LDN    4
          CWDL   T1
 FORMD30  BSS
 F        ENDIF
          RJM    FC          FORMAT CYLINDER
          LDML   SS+/SS/P.LISTL
          STDL   CMLISTL     RESTORE SAVED CMLISTL POINTER
          LDML   CMLIST+/CM/P.RMA+1
          SBML   SS+/SS/P.CYL  CHECK IF FINISHED WITH RANGE
          ZJK    FORMD56     DONE
          LDN    1
          RAML   SS+/SS/P.CYL   SET TO NEXT CYLINDER
          RJM    PPREQ       CHECK FOR IDLE REQUEST
          UJK    FORMD10     GO DO THE NEXT CYLINDER
 FORMD56  BSS
          SODL   CMLISTL
          NJK    FORMD57     FORMAT IS NOT FINISHED
          LDN    F.OPCMP
          RJM    FUNC        RELEASE THE DRIVE
          LDN    E00
          RJM    PER         PREPARE ERROR RESPONSE
          LDK    /RS/K.FORE
          STML   RS+/RS/P.ID
          RJM    INTRS       TELL OPERATOR FORMAT FINISHED FOR 1 PACK
          LJM    TERM        EXIT - DONE
 FORMD57  BSS
          RJM    GLIST       GET NEXT ENTRY FROM LIST
          LJM    FORMD5      CONTINUE FORMATTING
          ERRPL  *-17777B    IF OVERFLOWING MEMORY
          OVERLAY (INITIALIZE TABLES),OVST
          ROUTINE ITO        INITIALIZE TABLES
** NAME-- CHGCH
*
** PURPOSE-- SET CHANNEL NUMBER IN INSTRUCTIONS
*
** INPUT-- CHAN = CHANNEL NUMBER
          SPACE  2
 CHGX     LJM    **
 CHGCH    EQU    *-1
          LDN    0
          STDL   T1          CHANGE DISK CHANNEL INSTRUCTIONS
 CHG10    BSS
          LDML   CONCH,T1    ADDRESS OF CHANNEL INSTRUCTIONS
          ZJN    CHGX        END OF LIST
          STDL   T2
          LDIL   T2
          SCN    37B
          LMDL   CHAN        CHANNEL NUMBER
          STIL   T2
          AODL   T1
          UJK    CHG10

 CONCH    BSS                TABLE OF DISK CHANNEL REFERENCES
 TDC+40B  HERE   DISK CHANNEL REFERENCES
 T40B+DC  HERE
 TDC      HERE
          CON    0           END OF TABLE
          SPACE  5,20
** NAME-- IT
*
** PURPOSE-- INITIALIZE TABLES
*
** ENTRY
*         CM.PIT - 3 LOCATIONS CONTAINING THE REFORMATTED PPIT RMA
          SPACE  2
 ITX      LJM    **
 IT       EQU    *-1
          LDC    LUT
          STDL   USEQ        QUEUE HEAD FOR IN USE UNITS
          STDL   EMPTQ       QUEUE HEAD FOR UNITS NOT IN USE

* READ PP_INTERFACE_TABLE.

          LDN    C.PIT
          STDL   WC
          LOADC  CM.PIT      LOAD CM ADDRESS OF PP INTERFACE TABLE
          CRML   IPIT,WC     READ PP INTERFACE TABLE
          LDML   IPIT+/PIT/P.PPNO  GET PP NUMBER
          STDL   PPNO
          LDML   IPIT+/PIT/P.UNITC  NUMBER OF UNIT DESCRIPTORS
          SHN    1
          STDL   T8          LENGTH OF UNIT DESCRIPTORS (CM WORDS)

* REFORMAT ADDRESS OF RESPONSE BUFFER.
* INITIALIZE CM.RS, LIM.

          REFAD  IPIT+/PIT/P.RSBUF,CM.RS  REFORMAT CM ADDRESS OF RESPONSE
                             BUFFER
          LDML   IPIT+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STML   LIM

* REFORMAT ADDRESS OF INTERRUPT WORD.

          REFAD  IPIT+/PIT/P.INT,CM.INT  REFORMAT CM ADDRESS OF
                             INTERRUPT WORD

* REFORMAT ADDRESS OF CHANNEL TABLE.

          REFAD  IPIT+/PIT/P.CHAN,CM.CHAN  REFORMAT CM ADDRESS OF
                             CHANNEL TABLE

*  REFORMAT ADDRESS OF PP COMMUNICATIONS BUFFER

          LOADC  CM.PIT      ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.CBUF  OFFSET OF PP COMMUNICATION BUFFER ADDRESS
          CRDL   P1          READ ADDRESS OF PP COMMUNICATION BUFFER
          LOADF  P3          REFORMAT CM ADDRESS OF PP COMMUNICATION BUFFER
          STML   CM.CB+2
          ADN    /CB/C.DEV
          STDL   CM.DEV+2
          LDDL   CMADR
          STML   CM.CB
          STDL   CM.DEV      ADDRESS OF DEVICE TABLE (ONE ENTRY FOR EACH UNIT)
          LDDL   CMADR+1
          STML   CM.CB+1
          STDL   CM.DEV+1
          LDDL   P2          GET LENGTH OF PP COMMUNICATION BUFFER
          ADC    -P.CB-P.CB
          PJN    IT20        IF COMMUNICATIONS BUFFER LARGE ENOUGH
          RJM    HANG

* INITIALIZE COMMUNICATION BUFFERS IN ALL UNIT INTERFACE TABLES.

 IT20     BSS
          LDK    /CB/P.BUF*2  SAVE RMA OF CONFIDENCE TEST BUFFER
          ADDL   P4
          STML   CTBRMA+1
          SHN    -16
          ADDL   P3
          STML   CTBRMA
          RJM    EXLOD       ADDRESS OF PP INTERFACE TABLE *TEMP
          CRDL   P1                                        *TEMP
          LDDL   P2                                        *TEMP
          LPN    1                                         *TEMP
          NJN    *           IF SLAVE PP                   *TEMP
          RJM    ICOM        INITIALIZE COMMUNICATION BUFFERS
          LJM    ITX
          SPACE  5,20
** NAME-- ICOM
*
** PURPOSE-- INITIALIZE THE UNIT COMMUNICATION BUFFER IN ALL THE UNIT
*            INTERFACE TABLES.
*            INITIALIZE ALL STATIC VARIABLES IN THE COMMUNICATION
*            BUFFER:  DEVICE TYPE, CHANNEL NUMBER, SEEK FUNCTION,
*            UNIT NUMBER, COMMUNICATION BUFFER (RMA), UNIT INTERFACE
*            TABLE (RMA).
          SPACE  2

* CHANGE DISK CHANNEL INSTRUCTIONS.

 ICOM100  BSS
          RJM    CHGCH       CHANGE DISK CHANNEL INSTRUCTIONS
          LDN    0
          STDL   USEQ        SET IN USE QUEUE TO EMPTY
 ICOMX    LJM    **
 ICOM     EQU    *-1
          LDN    0
          STDL   T7          INDEX TO UNIT DESCRIPTORS
          STDL   DEVL        CLEAR DEVICE TABLE LENGTH
          STDL   PTF         ENABLE RUN OF PATH TEST
          STDL   CTF         ENABLE RUN OF CONFIDENCE TEST
          LDDL   T8          LENGTH OF UNIT DESCRIPTORS (CM WORDS)
          ZJN    ICOMX       IF NO UNIT DESCRIPTORS

* ZERO OUT TABLES

          LDK    TL
          STDL   T1
 ICOM20   BSS
          LDN    0
          STML   LUT-1,T1     ZERO OUT TABLES
          SODL   T1
          NJN    ICOM20
 ICOM10   BSS
          LDDL   CM.PIT+2    CM ADDRESS OFFSET OF UNIT DESCRIPTORS
          ADN    C.PIT
          ADDL   T7
          STDL   CMADR+2
          LDN    C.UD        READ 2 CM WORDS
          STDL   WC
          LOADC  CM.PIT,CMADR+2
          CRML   IBUF,WC     READ UNIT DESCRIPTOR

* CHECK FOR NULL ENTRY.

          LDML   IBUF+/UD/P.UQT  RMA = 0 IF NULL ENTRY
          ADML   IBUF+/UD/P.UQT+1
          ZJK    ICOM80      IF NULL ENTRY

          LDC    LUT
          STDL   LUTLOC      SO SETLOCK, CLRLOCK WILL WORK
          REFAD  IBUF+/UD/P.UQT,LUT+/LUT/P.UIT
          RJM    WFUL        WAIT FOR UNIT LOCK
          LDN    C.SS        LENGTH OF SS TABLE
          STDL   WC
          LOADR  LUT+/LUT/P.UIT  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.UBUF
          CRDL   T1
          LOADF  T3          ADDRESS OF UNIT COMMUNICATIONS BUFFER
          CRML   SS,WC       READ SS TABLE
          REFAD  IBUF+/UD/P.UQT,SS+/SS/P.UQT  REFORMAT RMA ADDRESS OF
                             UNIT INTERFACE TABLE

* READ UNIT INTERFACE TABLE

          LDN    C.UIT
          STDL   WC
          LOADR  SS+/SS/P.UQT  LOAD ADDRESS OF UNIT INTERFACE TABLE
          CRML   UBUF,WC     READ UNIT INTERFACE TABLE

* GET CHANNEL NUMBER AND SAVE IT.

          LDML   IBUF+/UD/P.CHAN
          SHN    -8
          STDL   CHAN        CHANNEL NUMBER
          STML   RS+/RS/P.CHAN  SAVE IN RESPONSE BUFFER

* PUT PHYSICAL UNIT NUMBER IN SEEK FUNCTION.

          LDML   IBUF+/UD/P.UNIT
          LPN    /UD/M.UNIT
          STML   SS+/SS/P.UNIT
          LDML   IBUF+/UD/P.UNIT  ADD STORAGE DIRECTOR ADDRESS
          LPK    /UD/K.SDIR
          SHN    /UD/L.SDIR+10
          RAML   SS+/SS/P.UNIT

* REFORMAT COMMUNICATION BUFFER RMA.

          REFAD  UBUF+/UIT/P.UBUF,SS+/SS/P.COM

* CHECK THAT COMMUNICATION BUFFER IS LONG ENOUGH.

          LDML   UBUF+/UIT/P.UBUFL  NUMBER OF 8-BIT BYTES IN COMMUNICATION BUFFER
          SHN    -3          NUMBER OF CM WORDS
          SBN    C.SS        MUST BE LARGER THAN SS ENTRY
          PJN    ICOM70      IF COMMUNICATION BUFFER IS LARGE ENOUGH
                             ERROR - COMMUNICATION BUFFER TOO SMALL
          LDC    E308
          RJM    INTERR      INTERFACE ERROR (NO RETURN)

* SAVE SS ENTRY IN UNIT COMMUNICATION BUFFER.  NOTE THAT CONFIGURATION
* MANAGEMENT CLEARS THE UNIT COMMUNICATIONS BUFFER BEFORE THE DRIVER IS LOADED.

 ICOM70   BSS
          RJM    SAVSS       SAVE SS TABLE
          RJM    CLRLOCK     CLEAR UNIT LOCK
          LDML   UBUF+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJN    ICOM80      IF UNIT DISABLED

* SET AN ENTRY INTO THE CM.DEV TABLE.

          LDN    1
          STDL   WC
          LDN    0
          STML   SS+/SS/P.SECTOR  CLEAR ACTIVE AND CONFIDENCE TEST BITS
          LOADC  CM.DEV
          ADDL   DEVL
          CWML   SS+/SS/P.UQT-1,WC
          AODL   DEVL
          SBN    1
          ZJN    ICOM80      IF ONE, LINK MUST BE ZERO
          SBN    NOU         NUMBER OF UNITS
          PJN    ICOM80      IF TABLE FULL
          LDDL   USEQ
          ADN    P.LUT       POINTER TO NEXT LOGICAL UNIT ENTRY
          STIL   USEQ        FILL IN THE LINK FIELD
          LDN    P.LUT
          RADL   USEQ        SET POINTER TO NEXT ENTRY

* BUMP TO NEXT ENTRY.

 ICOM80   BSS
          LDN    C.UD
          RADL   T7          BUMP TO NEXT UNIT DESCRIPTOR ENTRY
          SBML   T8          CHECK FOR END OF UNIT DESCRIPTORS
          NJK    ICOM10      IF MORE UNIT DESCRIPTORS
          UJK    ICOM100     EXIT
          SPACE  5,20
** NAME-- SAVAD
*
** PURPOSE-- SAVE RMA THAT IS BEING FORMATTED BY REFAD AND
*            STORED IN LOCATIONS GREATER THAN 77
          SPACE  2
 SAVAX    LJM    **
 SAVAD    EQU    *-1
          STML   2,T2
          LDDL   CMADR
          STI    T2
          LDDL   CMADR+1
          STML   1,T2
          UJK    SAVAX
          ERRPL  *-IPIT      IF OVERFLOWING MEMORY
          OVERLAY (PATH TEST),OVST
          ROUTINE PTO        PATH TEST OVERLAY
          SPACE  5,20
** NAME-- BPTB
*
** PURPOSE-- BUILD PATH TEST BUFFER
          SPACE  2
 BPTBX    LJM    **
 BPTB     EQU    *-1
          LDN    0
          STDL   T1          INDEX TO BUFFER
 BPTB10   BSS
          LDC    0#FFF       PATTERN IS FFF,000,AAA,555,EBD REPEATED
          STML   CTB,T1
          LDN    0
          STML   CTB+1,T1
          LDC    0#AAA
          STML   CTB+2,T1
          SHN    -1
          STML   CTB+3,T1
          LDC    0#EBD
          STML   CTB+4,T1
          LDN    5
          RADL   T1
          ADC    -328
          PJN    BPTBX       IF DONE
          UJK    BPTB10
          SPACE  5,20
** NAME-- BTMP
*
** PURPOSE-- BUILD TEST MODE BUFFER.  WHEN WRITTEN TO CM, THE
*            PATTERN LOOKS LIKE
*                FFFF FFFF FFFF FFFF
*                0000 0000 0000 0000
*                1515 1515 1515 1515
*            REPEATED 5 TIMES.
          SPACE  5,20
 BTMPX    LJM    **
 BTMP     EQU    *-1
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
 BTMP10   BSS
          LDML   TMB,T2
          STML   CTB,T1
          AODL   T1
          AODL   T2
          LPN    17B
          STDL   T2
          NJN    BTMP10      IF MORE WORDS TO MOVE
          AODL   T3
          LMN    5
          NJN    BTMP10      IF PATTERN AT TMB NOT REPEATED 5 TIMES
          UJK    BTMPX
 TMB      BSS
          DATA   0#FFF,0#FFF,0#FFF,0#FFF
          DATA   0#FFF,0#F00,0,0
          DATA   0,0,1,0#515
          DATA   0#151,0#515,0#151,0#515
          SPACE  5,20
** NAME-- LOADCON
*
** PURPOSE-- LOAD CCC CONTROLWARE
          SPACE  2
 LOAX     LJM    **
 LOADCON  EQU    *-1
          LDN    1
          STDL   WC
          RJM    EXLOD       GET CM ADDRESS OF COMMUNICATION BUFFER
          ADN    /CB/C.CONTRL  CM ADDRESS OF CONTROLWARE COMMAND
          CRML   CM,WC       READ COMMAND
          LDML   CM+/CM/P.LEN
          SHN    -3
          STDL   CMLISTL     LENGTH OF CM ADDRESS AREA (CM WORDS)
          RJM    GLIST       GET CM ADDRESS LIST OF DATA AREA
          LDK    F.AUTOP     ISSUE LOAD CONTROLWARE FUNCTION
          STML   LCF         INDICATE LOAD IN PROGRESS
          RJM    FUNC        ISSUE THE FUNCTION

* SETUP NUMBER OF WORDS TO TRANSFER FROM THIS CM ADDRESS.

 LOA20    BSS
          LOADF  CMLIST+/CM/P.RMA  SET UP CM ADDRESS OF DATA AREA
          STDL   T8
 F        IFEQ   FE,1        FOR FORCING ERRORS (FERP)
          LDN    4
          CRDL   T1
          LDDL   T1
          LMN    0#10
          NJN    LOA25       IF NOT FORCING AN ERROR
          LDDL   T2
          ZJN    LOA25       IF NOT FORCING AN ERROR
          LDC    -2000
          RAML   CMLIST+/CM/P.LEN
          SODL   T2          DECREMENT THE FORCE ERROR COUNTER
          LDN    4
          CWDL   T1
 LOA25    BSS
 F        ENDIF
          LDML   CMLIST+/CM/P.LEN  NUMBER OF 8-BIT BYTES TO TRANSFER
          ADN    7           ROUND UP
          SHN    -3          NUMBER OF CM WORDS TO TRANSFER
          STDL   BC          TOTAL NUMBER OF CM WORDS TO TRANSFER
                             FROM THIS ADDRESS
          ZJK    LOA70       IF NO WORDS TO TRANSFER FROM THIS ADDRESS
 LOA30    BSS
          STDL   WC          COMPUTE NUMBER OF CM WORDS TO TRANSFER TO BUFFER
          SBN    CTLN        MAXIMUM SIZE OF BUFFER IN PP
          MJN    LOA40       IF LESS THAN PP BUFFER
          LDK    CTLN
          STDL   WC          NUMBER OF CM WORDS TO TRANSFER TO BUFFER

* TRANSFER DATA FROM CM.

 LOA40    BSS
          LDDL   T8          CM ADDRESS OF DATA AREA
          LMC    400000B
          CRML   CWBUF,WC    READ CONTROLWARE BINARY FROM CM
          STDL   T8          UPDATE CM ADDRESS

* CONVERT DATA TO ONE 8-BIT BYTE PER PP WORD.

          LDDL   WC          NUMBER OF CM WORDS
          SHN    3
          STDL   T2          NUMBER OF 8-BIT BYTES
          STDL   T3
          SHN    -1          NUMBER OF 16-BIT PP WORDS
          ADC    CWBUF-1
          STDL   T1
 LOA50    BSS
          LDIL   T1          CONVERT DATA
          LPC    377B
          STML   CWBUF-1,T2
          LDIL   T1
          SHN    -8
          STML   CWBUF-2,T2
          SODL   T1
          SODL   T2
          SODL   T2
          NJK    LOA50       IF MORE DATA

* SEND DATA TO CONTROLLER.

          LDC    CWBUF       ADDRESS TO OUTPUT FROM
          STML   OUT10
          LDDL   T3
          RJM    OUT         SEND DATA TO CCC
          LDDL   BC          UPDATE TOTAL WORDS LEFT TO TRANSFER
                               TO THIS CM ADDRESS.
          SBDL   WC
          STDL   BC
          NJK    LOA30       IF MORE WORDS TO TRANSFER FROM THIS CM ADDRESS

* GET NEXT CM ADDRESS OF DATA AREA.

 LOA70    BSS
          SODL   CMLISTL     DECREMENT ADDRESS-LENGTH-PAIR COUNT
          ZJN    LOA80       IF END OF ADDRESS-LENGTH-PAIRS IN COMMAND
          RJM    GLIST       GET NEXT ENTRY FROM LIST
          UJK    LOA20

* END OF DATA.  GET GENERAL STATUS.

 LOA80    BSS
          RJM    DCN         DISCONNECT THE CHANNEL
          RJM    GENSTAT     GET GENERAL STATUS
          NJN    LOA90       IF ERROR
          STML   LCF         INDICATE LOAD COMPLETE
          UJK    LOAX        IF NOT UNRECOVERED ERROR
 LOA90    BSS
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- PT
*
** PURPOSE-- PATH TEST.  LOAD CONTROLWARE, THEN DO FURTHER TESTING
*            ON THE PP TO CCC PATH.
          SPACE  2
 PT100    BSS
          AODL   PTF         INDICATE PATH TEST COMPLETE
 PTX      LJM    **
 PT       EQU    *-1
          LDDL   DEVL
          ZJN    PT100       IF NO UNITS
          LDDL   PTF
          NJN    PTX         IF NOT RUNNING PATH TEST
          RJM    SCLOCK      SET CHANNEL LOCK
          STDL   GNSTAT      CLEAR GENERAL STATUS
          LDDL   CTF
          NJN    PT10        IF ORIGINAL ERROR ON DISK REQUEST
          LDML   RS+/RS/P.RTRY
          NJN    PT10        IF ALREADY IN RECOVERY
          STDL   COMLOOK     CLEAR INDEX TO DEVICE TABLE
          LDC    SPLUT
          STDL   LUTLOC      SPARE LOGICAL UNIT TABLE
 PT10     BSS
          LDN    1
          STDL   WC
          LOADC  CM.DEV
          CRML   SPLUT+2,WC  PUT UIT IN A LOGICAL UNIT TABLE
                              FOR ERROR RECOVERY
          LDC    F.MC        MASTER CLEAR ADAPTER
          RJM    FUNC
          LDC    400B        CONTROL REGISTER VALUE
          RJM    WCR         WRITE CONTROL REGISTER
          RJM    TM          TEST MODE (THIS TESTS THE IOU)
          RJM    LOADCON     LOAD CONTROLWARE
          RJM    BPTB        BUILD PATH TEST BUFFER
 F        IFEQ   FE,1        FOR FORCING ERRORS (FERR)
          LDN    4
          CRDL   T1
          LDDL   T1
          LMN    0#12
          NJN    PT20        IF NOT FORCING AN ERROR
          LDDL   T2
          ZJN    PT20        IF NOT FORCING AN ERROR
          LDN    0           FORCE DATA MISCOMPARE BY WRITING
          STML   CTB          THE WRONG DATA PATTERN
          SODL   T2
          LDN    4
          CWDL   T1
 PT20     BSS
 F        ENDIF
          LDC    CTB
          STML   IN10        ADDRESS TO INPUT DATA
          STML   OUT10       ADDRESS TO OUTPUT DATA
          LDN    F.UDIW
          RJM    FUNC        UDI WRITE
          LDC    502B        WORDS TO OUTPUT
          RJM    OUT         OUTPUT DATA
          RJM    DCN         DISCONNECT THE CHANNEL
          RJM    GENSTAT     GET GENERAL STATUS
          NJN    PT30        IF ERROR
          LDN    F.UDIR
          RJM    FUNC        UDI READ

          LDC    502B        WORDS TO INPUT
          RJM    IN          INPUT DATA
          RJM    WFI         WAIT FOR INACTIVE
          RJM    GENSTAT     THIS CHECKS FOR ERROR FLAG
          RJM    VPTD        VERIFY PATH TEST DATA
          LDN    F.DMAW
          RJM    FUNC        DMA WRITE

          LDC    502B        WORDS TO OUTPUT
          RJM    OUT         OUTPUT DATA
          RJM    DCN         DISCONNECT THE CHANNEL
          RJM    GENSTAT     GET GENERAL STATUS
 PT30     BSS
          NJN    PT50        IF ERROR
          LDN    F.DMAR
          RJM    FUNC        DMA READ

          LDC    502B        WORDS TO INPUT
          RJM    IN          INPUT DATA
          RJM    WFI         WAIT FOR INACTIVE
          RJM    GENSTAT     GET GENERAL STATUS
          NJN    PT50        IF ERROR
          RJM    VPTD        VERIFY PATH TEST DATA
          UJK    PT100
 PT50     BSS
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- TM
*
** PURPOSE-- TEST MODE.  THIS TESTS THE DMA HARDWARE OF THE IOU.
*            IT WRITES DATA TO CM, VERIFIES DATA, READS DATA FROM
*            CM, THEN VERIFIES DATA.
          SPACE  2
 TMX      LJM    **
 TM       EQU    *-1

*         TEST MODE, PP TO CM.

          RJM    BTMP        BUILD TEST MODE PATTERN
          LDC    F.ETM       ENABLE TEST MODE
          RJM    FUNC
          LDC    120         SET UP T REGISTER VALUES
          STDL   BC           BYTE COUNT
          LDML   CTBRMA       CM ADDRESS TO WRITE TO
          STDL   RMA
          LDML   CTBRMA+1
          STDL   RMA+1
          RJM    WTR         WRITE T REGISTER
          LDC    F.SDI       DMA INPUT
          RJM    FUNC
          RJM    ACN         ACTIVATE THE CHANNEL
          LDC    CTB
          STML   OUT10       PP ADDRESS TO OUTPUT FROM
          LDC    80          12-BIT WORDS TO TRANSFER
          RJM    OUT         OUTPUT DATA TO BE PUT IN CM
          RJM    DCN         DISCONNECT THE CHANNEL
          RJM    ROS         READ OPERATIONAL STATUS
          LMC    0#6A
          NJK    TM20        IF ERROR
          LDN    15
          STDL   WC
          LOADF  RMA
          CRML   CTB+80,WC   READ DATA JUST WRITTEN BY TEST MODE
          RJM    VTMD        VERIFY TEST MODE DATA
          LDC    F.CDM       CLEAR DMA MODE
          RJM    FUNC
          LDC    F.CTM       CLEAR TEST MODE
          RJM    FUNC

*         TEST MODE (CM TO PP)

          LDC    F.ETM       ENABLE TEST MODE
          RJM    FUNC
          RJM    WTR         WRITE T REGISTER
          LDC    F.SDO       DMA OUTPUT
          RJM    FUNC
          RJM    ACN         ACTIVATE THE CHANNEL
          LDC    CTB+80
          STML   IN10
          LDC    80          12-BIT WORDS TO TRANSFER
          RJM    IN          INPUT DATA TO IN10
          RJM    ROS         READ OPERATIONAL STATUS
          LMC    0#72
          NJN    TM20        IF ERROR
          STDL   T1
 TM10     BSS
          LDML   CTB,T1
          LMML   CTB+80,T1
          NJN    TM50        IF ERROR
          AODL   T1
          LMC    80
          NJN    TM10        IF MORE WORDS TO VERIFY
          LDC    F.CDM       CLEAR DMA MODE
          RJM    FUNC
          LDC    F.CTM       CLEAR TEST MODE
          RJM    FUNC
          LJM    TMX
 TM20     BSS
          LDN    E10         IOU FAILURE - OPERATIONAL STATUS WRONG
          UJN    TM55
 TM50     BSS
          LDN    E11         IOU FAILURE - TEST MODE DATA MISCOMPARE
 TM55     BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- VPTD
*
** PURPOSE-- VERIFY PATH TEST DATA
          SPACE  2
 VPTDX    LJM    **
 VPTD     EQU    *-1
          LDN    0
          STDL   T1          INDEX TO BUFFER
 VPTD10   BSS
          LDC    7777B
          LMML   CTB,T1
          NJN    VPTD20      IF ERROR
          LDN    0
          LMML   CTB+1,T1
          NJN    VPTD20      IF ERROR
          LDC    0#AAA
          LMML   CTB+2,T1
          NJN    VPTD20      IF ERROR
          LDC    0#555
          LMML   CTB+3,T1
          NJN    VPTD20      IF ERROR
          LDC    0#EBD
          LMML   CTB+4,T1
          NJN    VPTD20      IF ERROR
          LDN    5
          RADL   T1
          ADC    -328
          PJK    VPTDX       IF ALL WORDS VERIFIED
          UJK    VPTD10
 VPTD20   BSS
          LDN    E06         PP - CCC DATA INTEGRITY
          STDL   T1
          RJM    RDT         READ DEVICE TABLE
          LPN    /CB/K.ACT
          LMN    8
          STDL   P2
          LOADC  CM.DEV
          ADDL   COMLOOK
          CWDL   P2          INDICATE DATA INTEGRITY ERROR
          LDDL   T1
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- VTMD
*
** PURPOSE-- VERIFY TEST MODE DATA
          SPACE  2
 VTMDX    LJM    **
 VTMD     EQU    *-1
          LDN    0
          STDL   T1
 VTMD10   BSS
          LDML   CTB+80,T1
          LMC    0#FFFF
          NJN    VTMD30      IF MISCOMPARE
          LDML   CTB+84,T1
          NJN    VTMD30      IF MISCOMPARE
          LDML   CTB+88,T1
          LMC    0#1515
          NJN    VTMD30      IF MISCOMPARE
          AODL   T1
          LPN    3
          NJN    VTMD10      IF MORE WORDS TO VERIFY
          LDN    8
          RADL   T1
          LMN    60
          NJN    VTMD10      IF MORE WORDS TO VERIFY
          UJK    VTMDX
 VTMD30   BSS
          LDN    E11         IOU FAILURE - TEST MODE DATA MISCOMPARE
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          ERRPL  *-CTB       IF OVERFLOWING MEMORY
 TPP      ENDIF
          END
/EOR
*DECK DECK=PP895_COMMON_DECK EXPAND=FALSE
*
*         THIS IS THE PP DRIVER THAT SUPPORTS THE 895 DISK SUBSYSTEM.
*         THE DRIVER FOR THE NIO CHANNEL HAS PROGRAM NAME D895 AND
*         DECK NAME PP895.  THE DRIVER FOR THE CIO CHANNEL HAS PROGRAM
*         NAME D895CIO AND DECK NAME PP895CIO.  CONFIGURATION
*         MANAGEMENT LOADS THE CORRECT DRIVER.  IT PLUGS THE PP
*         INTERFACE TABLE RMA INTO LOCATIONS 72, 73.  LOCATION 0 OF
*         PP MEMORY MUST CONTAIN THE EXECUTION ADDRESS, MINUS ONE,
*         AT WHICH EXECUTION BEGINS.  THE DECK NAME OF THE COMMON
*         DECK THAT THE TWO DRIVERS SHARE IS PP895_COMMON_DECK.
          LIST   -$
*copyc IODMAC1 "{RECORD DEFINITION MACROS}
*copyc IODMAC2 "{LOAD/STORE MACROS}
*copyc IODMAC3 "{GENERAL MACROS}
*copyc IODMAC4 "{GENERAL MACROS}
*copyc IODMAC5 "(OVERLAY MACROS)
          LIST   B,L,N,R
          TITLE  EQUATES SECTION
 FE       EQU    0           = 1 IF ENABLING FORCE ERROR CODE
 DC       EQU    22B         DISK CHANNEL
 SBYTE8   EQU    2752        NUMBER OF 12-BIT BYTES PER DISK SECTOR
 SBYTE9   EQU    2048        NUMBER OF 16-BIT BYTES PER MEMORY SECTOR
 NOU      EQU    8           NUMBER OF ACTIVE UNITS ALLOWED

*         THE NUMBER GIVEN FOR MASWDS, WHEN MULTIPLIED BY 16, MUST
*         THEN BE DIVISIBLE BY 12.

 MASWDS   EQU    228         NUMBER OF CM WORDS TO BE PROCESS BY MASTER
 M        IFEQ   CHANTYP,1
 MASBUF   EQU    17770B-MASWDS*16/4  STARTING ADDRESS OF MASTER BUFFER
 SLVBUF   EQU    17770B-2064+MASWDS*16/4  STARTING ADDRESS OF SLAVE BUFFER
 CTB      EQU    17770B-510B  CONFIDENCE TEST BUFFER
 M        ELSE
 MASBUF   EQU    7770B-MASWDS*16/4  STARTING ADDRESS OF MASTER BUFFER
 SLVBUF   EQU    7770B-2064+MASWDS*16/4  STARTING ADDRESS OF SLAVE BUFFER
 CTB      EQU    7770B-510B  CONFIDENCE TEST BUFFER
 M        ENDIF
 NRQ      EQU    MASBUF      HOLDS NEXT REQUEST DURING DELINKING
 RTRY     EQU    4           RETRY REQUEST 3 TIMES
 MAXCYL   EQU    885         MAXIMUM CYLINDER
 MAXTR    EQU    14          MAXIMUM TRACK
 MAXSEC   EQU    9           MAXIMUM SECTOR

* DISK FUNCTIONS

 F.CONECT EQU    0           CONNECT
 F.SEEK   EQU    1           SEEK
 F.READ   EQU    4           READ
 F.WRITE  EQU    5           WRITE
 F.OPCMP  EQU    10B         OPERATION COMPLETE
 F.GS     EQU    12B         GENERAL STATUS
 F.CONT   EQU    14B         CONTINUE
 F.FMP    EQU    16B         FORMAT PACK
 F.EDS    EQU    23B         EXTENDED DETAILED STATUS
 F.UDIR   EQU    32B         UDI READ
 F.UDIW   EQU    33B         UDI WRITE
 F.DMAR   EQU    43B         DMA READ
 F.DMAW   EQU    44B         DMA WRITE
 F.AUTOP  EQU    414B        AUTOLOAD FROM PP
 F.MCLEAR EQU    100000B     MASTER CLEAR CIO ADAPTOR BOARD FUNCTION
 F.WRCR   EQU    111000B     WRITE CONTROL REGISTER OF CIO ADAPTOR
 F.RDESR  EQU    112000B     READ ERROR STATUS REGISTER OF CIO ADAPTOR

 GS4400   EQU    4400B       RECOVERY IN PROGRESS STATUS
 GS5020   EQU    5020B       SUBSYSTEM ERROR, SENSE BYTES PRESENT
          SPACE  5,20
*
*         ERROR CODES FOR LOCATION EC
*
 E00      EQU    0           NO CODE, CP MUST ISOLATE THE ERROR
 E01      EQU    1           INTERFACE ERROR
 E02      EQU    2           KZ BOARD ERROR
 E03      EQU    3           KX BOARD ERROR
 E04      EQU    4           CHANNEL ERROR
 E05      EQU    5           INCOMPLETE CHANNEL TRANSFER
 E06      EQU    6           PP - CCC DATA INTEGRITY ERROR
 E07      EQU    7           PP - UNIT DATA INTEGRITY ERROR
 E08      EQU    8           SEEK COMMAND TIMEOUT
 E09      EQU    9           CCC FAILURE
          SPACE  5,20
* INTERFACE ERROR CODES.

 E308     EQU    1410B       UNIT COMMUNICATION BUFFER IS TOO SMALL
 E501     EQU    2401B       INVALID COMMAND CODE
 E50A     EQU    2412B       INVALID SEQUENCE OF COMMANDS
          EJECT
* SELECTION SET (SS)
 SS       RECORD PACKED

 FILL1    SUBRANGE 0,377B
 UNIT     SUBRANGE 0,377B    UNIT NUMBER

 CYL      PPWORD             CYLINDER ADDRESS
 TRACK    PPWORD             TRACK ADDRESS
 SECTOR   PPWORD             SECTOR ADDRESS
 UQT      STRUCT 6           UNIT INTERFACE TABLE (RMA, REFORMATTED)
 REQ      STRUCT 4           CURRENT REQUEST (UNFORMATTED RMA)
 PVA      STRUCT 6           PVA OF CURRENT REQUEST
 COM      STRUCT 6           COMMUNICATION BUFFER (RMA, REFORMATTED)
 FILL     SUBRANGE 0,3777B
 ENTRY    BOOLEAN            REQUEST ON QUEUE SELECTED
 FILLA    SUBRANGE 0,17B
 LISTL    PPWORD             SAVED VALUE OF CMLISTL (DURING FORMATTING)
          PPWORD             (UNUSED)
 LASTC    PPWORD             OFFSET OF LAST COMMAND IN REQUEST
 LPP      PPWORD             LOGICAL PP NUMBER
          ALIGN  0,64
 CLKST    STRUCT 4           CLOCK START TIME
 SEEKTM   STRUCT 4           SEEK TIME
 DP       STRUCT 6           REFORMATTED RMA OF DELINK POINTER
          PPWORD             (UNUSED)
          MGEN   N.ENTRY
 M.ENTRY  EQU    MASK$
          MASKP  ENTRY
 K.ENTRY  EQU    MSK
          MGEN   N.UNIT
 M.UNIT   EQU    MASK$
 SS       RECEND

*         ALTERNATE USES OF SS TABLE DURING CONFIDENCE TEST

 CTME     EQU    /SS/P.PVA   START OF A 3-WORD TABLE WITH EACH WORD
                              CONTAINING THE HEAD AND SECTOR NUMBER
                              OF A MEDIA ERROR

* LOGICAL UNIT TABLE.

 LUT      RECORD PACKED
 LINK     PPWORD             ADDRESS OF THE NEXT LUT ENTRY
 OFFSET   PPWORD             INDEX INTO THE CM.DEV TABLE
 FILL     SUBRANGE 0,37777B
 OWNER    BOOLEAN            THIS PP HAS THE UNIT LOCKED
 FILL1    BOOLEAN            UNUSED
 UIT      STRUCT 6           RMA OF THE UIT (REFORMATTED RMA)
          MGEN   N.OWNER
 M.OWNER  EQU    MASK$
          MASKP  OWNER
 K.OWNER  EQU    MSK

 LUT      RECEND
          SPACE  5,20
* PP INTERFACE TABLE
 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
 ACTCH    BOOLEAN            ACTIVE CHECK, THE PP CLEARS THIS BIT WITHIN 1 MINUTE
 IDLREQ   BOOLEAN            IDLE REQUEST
 RESREQ   BOOLEAN            RESUME REQUEST
 PPIDLE   BOOLEAN            PP IDLE
          SUBRANGE 0,3777B   UNUSED
 LOCK     BOOLEAN            PP TABLE LOCK
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
          STRUCT 24          UNUSED
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          SPACE  5,20
* UNIT DESCRIPTORS.

 UD       RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 SDIR     SUBRANGE 0,7       STORAGE DIRECTOR ADDRESS
 FILL1    SUBRANGE 0,377B
 UNIT     SUBRANGE 0,37B     PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)
          MGEN   N.SDIR
 M.SDIR   EQU    MASK$
          MASKP  SDIR
 K.SDIR   EQU    MSK
          MGEN   N.UNIT
 M.UNIT   EQU    MASK$

 UD       RECEND
          SPACE  5,20
* UNIT INTERFACE TABLE

 UIT      RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
                               = 400B, 844-4X
                               = 401B, 885-1X
                               = 402B, 885-42
 QCNT     PPWORD             QUEUE COUNT
*
          ALIGN  16,64
 UBUFL    PPWORD             UNIT COMMUNICATION BUFFER LENGTH
 UBUF     RMA                UNIT COMMUNICATION BUFFER (RMA)
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

          MASKP  DSABLE
 K.DSABLE EQU    MSK

 UIT      RECEND
          SPACE  5,20
* PP REQUESTS.

 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS
                               0 - ATTEMPT RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
          ALIGN  0,64
 SWIT     BOOLEAN            SWITCH TO NEXT REQUEST
          ALIGN  16,64
 CYL      PPWORD             CYLINDER ADDRESS
 TRACK    PPWORD             TRACK ADDRESS
 SECTOR   PPWORD             SECTOR ADDRESS
 CMND     INTEGER            COMMAND SEQUENCE


          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$

 RQ       RECEND
          SPACE  5,20
* PP COMMAND.

 CM       RECORD PACKED

 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$

 CM       RECEND
          SPACE  5,20
* COMMAND CODES.

 C.IDLE   EQU    4           IDLE
 C.RESUME EQU    5           RESUME
 C.READ   EQU    100B        READ BYTES
 C.WRITE  EQU    120B        WRITE BYTES
 C.FORMAT EQU    164B        DISK FORMAT
          SPACE  5,20
* PP RESPONSE.

 RS       RECORD PACKED
 FILL1    BOOLEAN
 SHORT    BOOLEAN            IF SET, ONE-WORD RESPONSE
          SUBRANGE 0,77B     UNUSED
          SUBRANGE 0,377B    LOGICAL UNIT (FOR DEBUG)
          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
          ALIGN  49,64       ALERT MASK
 COMPAR   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE INTERFACE
                             ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
 CHERR    BOOLEAN            CHANNEL PARITY ERROR
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION
                             OCCURRED ON INPUT OR INADEQUATE DATA RATE ON OUTPUT
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A
                             HARDWARE MALFUNCTION.  EX: UNIT NOT READY,
                             UNIT NOT CONNECTED.
 FTO      BOOLEAN            FUNCTION TIMEOUT
 CHERO    BOOLEAN            CHANNEL OUTPUT PARITY ERROR
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 - INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
                               1 - RECOVERED ERROR
                               2 - COMMAND HAD EXPLICIT RESPONSE FLAG SET
                               3 - BOTH CONDITIONS 1 AND 2
 K.REC    EQU    1           RECOVERED ERROR
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)(NOT USED)

 CHAN     PPWORD             CHANNEL NUMBER
 SCYL     PPWORD             STARTING CYLINDER
 STRK     PPWORD             STARTING TRACK
 SSEC     PPWORD             STARTING SECTOR

 UNIT     PPWORD             UNIT NUMBER
 RTRY     PPWORD             REQUEST RETRY COUNT
 FTRK     PPWORD             FAILING TRACK
 FSEC     PPWORD             FAILING SECTOR

 DET      PPWORD             =1, IF DETAILED STATUS PRESENT
 ID       PPWORD
 K.FORS   EQU    200B        DISK FORMATTING STARTED
 K.FORE   EQU    400B        DISK FORMATTING ENDED
 K.UDN    EQU    20000B      UNIT DOWN
 K.CMDN   EQU    40000B      STORAGE DIRECTOR DOWN
 K.CHDN   EQU    100000B     CHANNEL DOWN
 FILL2    PPWORD
 STRY     PPWORD             SECTOR RETRY COUNT

 GENST1   PPWORD             GENERAL STATUS OF THE FIRST TIME ERROR
                               WAS ENCOUNTERED
 GENST2   PPWORD             GENERAL STATUS OF THE LAST TIME ERROR
                               WAS ENCOUNTERED
 FUNTO    PPWORD             FUNCTION CODE IF FUNCTION TIMEOUT ERROR
          PPWORD             UNUSED
 FERREG   PPWORD             FIRST OCCURRENCE OF ERROR STATUS REGISTER (CIO ONLY)
 LERREG   PPWORD             LAST OCCURRENCE OF ERROR STATUS REGISTER (CIO ONLY)
          PPWORD             UNUSED
 EC       PPWORD             ERROR CODE (EXX)
          ALIGN  0,64
 DETAIL   STRUCT 40          DETAILED STATUS OF THE FIRST TIME ERROR
                             WAS ENCOUNTERED
 DET2     STRUCT 40          DETAILED STATUS OF THE LAST TIME ERROR
                             WAS ENCOUNTERED.

          MASKP  DATERR
 K.DATERR EQU    MSK
          MASKP  FTO
 K.FTO    EQU    MSK
          MASKP  SHORT
 K.SHORT  EQU    MSK

 RS       RECEND
          SPACE  5,20
* RESPONSE CODES.
 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    1           INTERMEDIATE RESPONSE
 R.NRM    EQU    2           NORMAL REQUEST TERMINATION
 R.ABN    EQU    3           ABNORMAL REQUEST TERMINATION
          SPACE  5,20
* PP COMMUNICATION BUFFER.

 CB       RECORD PACKED

          ALIGN  31,64
 SLAVE    BOOLEAN            NONZERO IF SLAVE PP
 PARTNR   RMA                PARTNERS PPIT (RMA)

 CONTRL   STRUCT 8           LOAD CONTROLWARE COMMAND
          STRUCT 8
 ODP      STRUCT 8           OVERLAY DIRECTORY POINTER
          STRUCT 16
          STRUCT 24

 MSGIN    PPWORD             MESSAGE TO MASTER FROM SLAVE

          ALIGN  0,64
 MSGOUT   PPWORD             MESSAGE TO SLAVE FROM MASTER

          ALIGN  0,64
 SS       STRUCT 56          SS ENTRY

 REQ      STRUCT 40          REQUEST

 SVAREA   STRUCT 48          SAVE PARAMETERS FOR DATA RETRIEVAL

          ALIGN  0,64

*         THERE IS A ONE CM WORD TABLE PER CONFIGURED UNIT.  CM.DEV
*         IS THE REFORMATTED RMA THAT POINTS TO IT.

 DEV      SUBRANGE 0,7777B
 CT       SUBRANGE 0,7       NONZERO WHEN CONFIDENCE TEST COMPLETE
                              1 - NO ERROR
                              2 - ERROR
                              4 - DATA INTEGRITY ERROR
 ACT      BOOLEAN            UNIT ACTIVE (IN PPS IN USE QUEUE)
          STRUCT 6           REFORMATTED RMA OF UNIT INTERFACE TABLE
          MASKP  ACT
 K.ACT    EQU    MSK
          MASKP  SLAVE
 K.SLAVE  EQU    MSK


 CB       RECEND
          SPACE  5,20
* COMMANDS BETWEEN PPS.

                                                            SENT BY
 C.GO     EQU    1           DONE WITH DISK FOR THIS SECTOR  BOTH
 C.REQ    EQU    2           START A DISK REQUEST            MASTER
 C.RTRY   EQU    3           RETRY REQUEST                   MASTER
 C.SWIT   EQU    4           SWITCH TO THE NEXT REQUEST      MASTER
 C.END    EQU    5           END OF THE DISK REQUEST         MASTER
 C.AREG   EQU    6           A REGISTER NONZERO              SLAVE
 C.CPE    EQU    7           CHANNEL PARITY ERROR            SLAVE
 C.RES    EQU    8           RESUME COMMAND                  MASTER
          TITLE  DIRECT CELLS, CONSTANTS, TABLES
          CON    INIT-1

* DIRECT CELLS

 DH       BSSZ   3           REFORMATTED RMA OF OVERLAY DIRECTORY
 CM.PIT   BSSZ   3           CM ADDRESS OF PP INTERFACE TABLE (REFORMATED)

 T1       BSSZ   1
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 T8       BSSZ   1

* KEEP GNSTAT AND P1 ADJACENT.
 GNSTAT   BSSZ   1           GENERAL STATUS
 P1       BSSZ   1
 P2       BSSZ   1
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 P6       BSSZ   1
 WC       BSSZ   1           WORD COUNT TO READ/WRITE CM WORDS

 DEVL     CON    0           LENGTH OF DEV TABLE (SET BY INIT)
 CHAN     BSSZ   1           CHANNEL NUMBER
 CM.DEV   BSSZ   3           ADDRESS OF DEV TABLE IN COMMON AREA
 CMADR    BSSZ   3           CM ADDRESS

* THE NEXT 8 PP WORDS MUST BE CONTIGUOUS.

 SVCELLS  BSS
 DATADD   BSSZ   3           CM ADDRESS OF DATA AREA
 CMLISTL  BSSZ   1           NUMBER OF CM WORDS IN ADDRESS-LENGTH PAIR LIST.
                             (INCLUDES THE NUMBER OF WORDS WHICH HAVENT
                             BEEN READ FROM CM.)
 WDS      BSSZ   1           NUMBER OF CM WORDS TO TRANSFER FROM CURRENT SECTOR.
 TWDS     BSSZ   1           TOTAL NUMBER OF CM WORDS TO TRANSFER TO THE
 CMRMA    BSSZ   2           SAVED RMA OF DATA RMA LIST

 FNC      BSSZ   1           FUNCTION CODE (INTERNAL)
 SECPOS   BSSZ   1           SECTOR BUFFER TRANSFER POSITION (TO CM)
 USEQ     CON    0           QUEUE HEAD OF LUT ENTRIES IN USE (ACTIVE)
 EMPTQ    CON    LUT         QUEUE HEAD OF LUT ENTRIES NOT IN USE
 NCOMRQ   CON    0           NUMBER OF COMPLETED REQUESTS
 TOGL     BSSZ   1           USED FOR TRANSFERRING ALTERNATE 1/2 SECTORS
 GOFLG    BSSZ   1           =0 IF ADDRESS MUST BE BACKED UP AFTER AN ERROR
 SWFLG    BSSZ   1           NONZERO IF A STREAMING REQUEST SWITCH WAS MADE
 SLAVE    BSSZ   1           NONZERO IF SLAVE PP
 COMLOOK  BSSZ   1           INDEX INTO DEV TABLE (TABLE START IS IN CM.DEV)
 LUTLOC   CON    0           ADDRESS OF CURRENT LUT ENTRY
 CLCUR    BSSZ   1           CHANNEL 14 CURRENT CLOCK
 CLMCS    BSSZ   1           CLOCK, MICROSECOND
 CLMLS    BSSZ   1           CLOCK, MILLISECOND
 CLSEC    BSSZ   1           CLOCK, SECOND
 RECOV    BSSZ   1           STEP OF RECOVERY ALGORITHM
 CF       BSSZ   1           CONTINUE FLAG USED TO CONTROL RECOVERED RESPONSES
 FT       BSSZ   1           0 IF FIRST DATA FUNCTION AFTER SEEK
          BSS    72B-*
 DSRTP    DATA   2,0         PP INTERFACE TABLE RMA WHEN PP LOADED
 WDSS     EQU    DSRTP       USED TO UPDATE BYTES TRANSFERRED IN RESPONSE STATUS
 INPNT    EQU    DSRTP+1     IN POINTER FOR RESPONSE BUFFER
 CA       BSSZ   1           CONTINUE ADDRESS
 PPNO     CON    1           LOGICAL PP NUMBER
 PTF      BSSZ   1           IF 0 EXECUTE PATH TEST
 CTF      BSSZ   1           IF 0 EXECUTE CONFIDENCE TEST
          EJECT
          BSS    100B-*
          LJM    INIT        USED FOR OFF-LINE TESTING
          DATA   5           895 DRIVER (FOR ANAD PROC)
 HANG     CON    0           AN EASY WAY TO SEE CERTAIN PP HUNG ERRORS
          UJN    *
*
*         THE FOLLOWING CM ADDRESSES ARE SET DURING INITIALIZATION.
*         THE BYTE ADDRESS IS
*           RIGHTMOST 10 BITS OF WORD 0 CONCATENATED WITH
*           RIGHTMOST 12 BITS OF WORD 1 CONCATENATED WITH
*           RIGHTMOST 6 BITS OF WORD 2 CONCATENATED WITH
*           3 BITS OF ZEROS.

 CM.RS    BSSZ   3           CM ADDRESS OF RESPONSE BUFFER (REFORMATTED)
 CM.CB    BSSZ   3           CM ADDRESS OF PP COMMUNICATION BUFFER (REFORMATTED)
 CM.MIN   BSSZ   3           CM ADDRESS OF -MESSAGE IN- BUFFER
 CM.MOUT  BSSZ   3           CM ADDRESS OF -MESSAGE OUT- BUFFER
 CM.INT   BSSZ   3           CM ADDRESS OF INTERRUPT WORD
 CM.CHAN  BSSZ   3           CM ADDRESS OF CHANNEL INTERLOCK TABLE
 IDLE     BSSZ   1           NONZERO IF IDLE COMMAND RECEIVED,
                               RESUME COMMAND RESETS IT TO 0
 STORS    BSSZ   1           STORE RESPONSE FLAG (USED BY RESPIN)
                               = 0, IF A RESPONSE IS SENT TO CM
                               = NONZERO, IF NO RESPONSE WAS SENT TO CM
 FUNCD    BSSZ   1           FUNCTION CODE
 FCOMRQ   BSSZ   2           FIRST COMPLETED REQUEST (RMA)
 CURRQ    BSSZ   2           RMA OF CURRENT REQUEST
 PRERQ    BSSZ   2           RMA OF PREVIOUS REQUEST
 CHLOCK   BSSZ   1           CLEARED IF CHANNEL LOCK IS SET
 CHLCNT   CON    C.CHCNT     NUMBER OF REQUESTS TO PROCESS BEFORE
                              CLEARING CHANNEL LOCK
 UTSAVE   BSSZ   1           STARTING OFFSET ON AN LUT SCAN
 NUMCM    BSSZ   1           NUMBER OF COMMANDS LEFT TO PROCESS IN THIS REQUEST
 FRST     BSSZ   1           = 0, IF FIRST TIME THROUGH UNCMND
 LIM      BSSZ   1           LIMIT OF RESPONSE BUFFER (IN 8-BIT BYTES)
 LCF      BSSZ   1           NONZERO IF CCC LOAD IN PROGRESS
 SIP      BSSZ   1           SEEK IN PROGRESS IF ZERO
 DMF      BSSZ   1           DATA MISCOMPARE FLAG FOR CONFIDENCE TEST
 SPLUT    BSSZ   6           SPARE LOGICAL UNIT TABLE FOR CONFIDENCE TEST
 FBUF     CON    0           FIRST OF FORMAT PACK PARAMETERS
 FUN      CON    2300B
          CON    4000B       SET TO SPECIFY 4K SECTORS
 F        IFEQ   FE,1        FORCE ERROR CODE
 FEST     BSSZ   1           PASSES BEFORE FORCING ERROR
 FEND     BSSZ   1           NUMBER OF TIMES TO FORCE ERROR
 F        ENDIF

* THE FOLLOWING 2 CONSTANTS DEFINE THE AMOUNT OF THE DATA ON THE DISK TO
* BE READ OR WRITTEN (EXPRESSED IN CHANNEL WORDS). TO DETERMINE THE NUMBER
* OF PP WORDS USED, MULTIPLY BY 3/4. THIS VALUE IS SLIGHTLY MORE THAN THE
* AMOUNT USED FROM THE SECTOR, BECAUSE THE TOTAL MUST BE DIVISIBLE BY BOTH
* 12 AND 16.
* THE FIRST CONSTANT IS FOR THE MASTER, THE SECOND FOR THE SLAVE.

 IOCOUNT  CON    MASWDS*16/3   MUST BE EXPRESSED AS CHANNEL WORDS ( 12 BIT)
          CON    SBYTE8-MASWDS*16/3  MUST BE SBYTE8-(IOCOUNT)

* THE 2 CONSTANTS THAT FOLLOW (SECWDS) MUST ADD UP TO THE BLOCK SIZE
* EXPRESSED IN CM WORDS.
* THE FIRST CONSTANT IS FOR THE MASTER, THE SECOND FOR THE SLAVE.

 SECWDS   CON    MASWDS      THIS NUMBER TIMES 16 MUST BE EVENLY
                             DIVISIBLE BY 12.
          CON    SBYTE9/4-MASWDS  CONSTANT MUST NOT BE SEPARATED FROM SECWDS

 C.CHCNT  EQU    37          NUMBER OF REQUESTS TO PROCESS BEFORE
                             CLEARING CHANNEL LOCK
 LUT      BSSZ   NOU*P.LUT   LOGICAL UNIT TABLES FOR 8 UNITS
 SS       BSSZ   P.SS        INFORMATION ABOUT THE SELECTED REQUEST
 RQ       BSSZ   P.RQ        THE REQUEST BEING PROCESSED (MUST FOLLOW SS)
 CM       EQU    RQ+/RQ/P.CMND  COMMAND PORTION OF THE REQUEST
 CMLIST   BSSZ   P.CM        ONE ADDRESS AND LENGTH PAIR POINTING TO CM DATA
 RS       BSSZ   P.RS        RESPONSE BUFFER
 TL       EQU    *-LUT       LENGTH OF TABLES TO CLEAR DURING INITIALIZATION
 C        IFEQ   CHANTYP,1
 IPIT     EQU    17600B      PP INTERFACE TABLE DURING INITIALIZATION
 C        ELSE
 IPIT     EQU    7600B       PP INTERFACE TABLE DURING INITIALIZATION
 C        ENDIF
 UBUF     EQU    IPIT+P.PIT  UNIT INTERFACE TABLE DURING INITIALIZATION
 IBUF     EQU    UBUF+P.UIT  UNIT DESCRIPTIOR DURING INITIALIZATION
 CWBUF    EQU    RS+/RS/P.DETAIL START OF BUFFER FOR LOADING CONTROLWARE
 CTLN     EQU    5           LENGTH OF BUFFER USED FOR LOADING (CM WORDS)
          TITLE  RESIDENT SLAVE ROUTINES
          SPACE  5,20
** NAME-- END
*
** PURPOSE-- IDLE LOOP FOR SLAVE
          SPACE  2
 END      BSS
 F        IFEQ   FE,1        FORCE ERROR CODE
          RJM    FER         CHECK FOR FORCE ERROR
 F        ENDIF
          RJM    GETMSG      LOOK FOR REQUEST FROM MASTER
          UJN    END         GO LOOK SOME MORE
          SPACE  5,20
** NAME-- REQ
*
** PURPOSE-- PROCESS THE -REQ- COMMAND FROM THE MASTER PP.
*            SET UP TO PROCESS A DISK REQUEST.
          SPACE  2
 REQ      BSS
          RJM    REQSW       READ DISK REQUEST
          LDN    C.GO
          STDL   GOFLG
          RJM    SEND        SEND -GO- TO PARTNER
          LJM    MAIN25      PROCESS REQUEST
          SPACE  5,20
** NAME-- REQSW.
*
** PURPOSE-- READ THE DISK REQUEST FROM THE PP COMMUNICATION
*            BUFFER.
          SPACE  2
 REQSX    LJM    **
 REQSW    EQU    *-1
          LDN    C.SS+C.RQ   NUMBER OF WORDS TO READ
          STDL   WC
          RJM    EXLOD       ADDRESS OF COMMUNICATION BUFFER
          ADN    /CB/C.SS    ADDRESS OF SS ENTRY
          CRML   SS,WC       READ SS TABLE AND REQUEST
          LDN    0
          STML   FRST        SET FLAG WHEN REQUEST IS READ
          LDML   RQ+/RQ/P.LEN  DETERMINE NUMBER OF COMMANDS
          SHN    -3
          SBN    /RQ/C.CMND
          STML   NUMCM       NUMBER OF COMMANDS
          UJK    REQSX
          SPACE  5,20
** NAME-- RESUME
*
** PURPOSE-- THE MASTER HAS RECEIVED A RESUME AND IS REINITIALIZING
*            TABLES.  LOCATIONS THE SLAVE READS ARE ALREADY INITIALIZED,
*            SO, JUST SEND A GO TO THE MASTER.
          SPACE  2
 RESUME   BSS
          LDN    C.GO
          RJM    SEND        SEND A GO TO THE MASTER
          LJM    END
          SPACE  5,20
** NAME-- SR
*
** PURPOSE-- ENTRY FOR SLAVE TO RETRY THE DATA TRANSFER FOR A SECTOR
          SPACE  2
 SR       BSS
          LDDL   GOFLG
          NJN    SR10        IF POINTERS CORRECT
          LOADOVL ERO        LOAD ERROR RECOVERY OVERLAY
          RJM    RSTBP       RESTORE POINTERS
 SR10     BSS
          LDN    1           RESET TOGL TO 1
          STDL   TOGL
          LJM    READ32      RETURN TO THE READ ROUTINE
          SPACE  5,20
** NAME-- SWIT
*
** PURPOSE-- ENTRY FOR SLAVE TO SWITCH TO NEXT REQUEST
          SPACE  2
 SWIT     BSS                SWITCH TO NEXT REQUEST
          RJM    REQSW       READ REQUEST FROM PP COMMUNICATION BUFFER
          RJM    SRESP       SET UP RESPONSE BUFFER
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
          LDDL   FNC         IS IT A READ
          ZJK    READ3       YES, RETURN TO THE READ ROUTINE
          LJM    WRI5        RETURN TO THE WRITE ROUTINE
          TITLE  RESIDENT MASTER AND SLAVE ROUTINES
** NAME -- MAIN
*
** PURPOSE -- THE MAIN DRIVER LOOP
*
** ENTRY
*         MAIN - FROM INIT AFTER DRIVER IS LOADED (MASTER AND SLAVE)
*              - WHEN RESUME RECEIVED (MASTER ONLY)
*         MAIN5 - WHEN RETRYING A CONFIDENCE TEST ERROR (MASTER ONLY)
*               - WHEN EQUIPMENT IS DOWNED
*         MAIN25 - ENTRY FOR SLAVE TO PROCESS A REQUEST
*         MAIN30 - WHEN RETRYING A DISK REQUEST (MASTER ONLY)
*         MAIN45 - WHEN REQUEST COMPLETES WITHOUT ERROR
*                - IF MEDIA ERROR
          SPACE  2
 MAIN     BSS
          LOADOVL ITO        LOAD INITIALIZE TABLE OVERLAY
          RJM    IT          INITIALIZE TABLES
 MAIN5    BSS
          LOADOVL PTO        PATH TEST OVERLAY
          RJM    PT          PATH TEST
          LOADOVL CTO        LOAD CONFIDENCE TEST OVERLAY
          RJM    CT          CONFIDENCE TEST
 MAIN10   BSS
 F        IFEQ   FE,1        FORCE ERROR CODE
          RJM    FER         CHECK FOR AN ERROR TO FORCE
 F        ENDIF
          RJM    PPREQ       CHECK FOR ANY PP REQUESTS
          RJM    GETUD       SET UP NEW REQUESTS
          LDDL   USEQ
          ZJK    MAIN50      IF NO SEEKS ARE OUTSTANDING
          RJM    POLLON      POLL FOR ON-CYLINDER
          ZJK    MAIN10      IF A SEEK HAS NOT COMPLETED
          RJM    UREQ        READ UNIT REQUEST FROM CM
          RJM    SETRQ       SET UP FOR FIRST REQUEST
 MAIN25   BSS
          RJM    SRESP       SET UP RESPONSE BUFFER
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
 MAIN30   BSS
          LDML   UCMDPR,FNC  GET COMMAND PROCESSOR
          STML   MAIN35
          RJM    **          PROCESS COMMAND (NO RETURN IF SLAVE)
 MAIN35   EQU    *-1
          RJM    UBT         UPDATE BYTES TRANSFERRED
          LDN    F.OPCMP
          RJM    FUNC        RELEASE THE DRIVE
          LDDL   CF
          ZJN    MAIN40      IF CONTINUE NOT SENT
          LDML   RS+/RS/P.RTRY
          NJN    MAIN40      IF ERROR ALREADY REPORTED
          LDN    0
          STML   RS+/RS/P.SHORT   INDICATE ERROR RESPONSE
          LDK    C.RS*8
          STML   RS+/RS/P.RESPL  ERROR RESPONSE LENGTH
          LDC    0#5000
          STML   RS+/RS/P.RC  RECOVERED, INTERMEDIATE RESPONSE
          RJM    TERMP       SEND RECOVERED RESPONSE
 MAIN40   BSS
          LJM    TERM        SEND TERMINATION RESPONSE
 MAIN45   BSS
          SOML   CHLCNT
          NJN    MAIN55      IF PP DOESN'T HAVE TO GIVE UP CHANNEL
 MAIN50   BSS
          RJM    CKC         CHECK IF CHANNEL MUST BE GIVEN UP
 MAIN55   BSS
          UJK    MAIN10

* UNIT COMMANDS
 UCMD     BSS
          CON    C.READ
          CON    C.WRITE
          CON    C.FORMAT

* PP COMMANDS.

          CON    C.IDLE
          CON    C.RESUME
 UCMDL    EQU    *-UCMD

* UNIT COMMAND PROCESSORS.
 UCMDPR   BSS
          CON    READ        READ BYTES
          CON    WRITE       WRITE BYTES
          CON    FMT         FORMAT DISK
          SPACE  5,20
** NAME-- EXLOD
*
** PURPOSE-- UTILITY TO EXECUTE A LOADC CM.CB MACRO.
*
** INPUT-- RJM EXLOD (NO PARAMETERS)
*
** OUTPUT-- R AND A REGISTERS CONTAIN ADDRESS OF COMMUNICATIONS BUFFER.
          SPACE  2
 EXLODX   LJM    **
 EXLOD    EQU    *-1
          LOADC  CM.CB
          UJN    EXLODX
          SPACE  5,20
** NAME-- FORMA
*
** PURPOSE-- FORMAT A CM REAL MEMORY ADDRESS.
*
** CALLING SEQUENCE-- LDC    ADDRESS
*                     RJM    FORMA
*
** INPUT-- - A REGISTER- IS THE ADDRESS OF A 2-WORD CM BYTE ADDRESS.
*
** OUTPUT-- -CMADR- IS THE ADDRESS OF THE RESULTING 3-WORD REFORMATED
*                CM ADDRESS.  THE FORMAT CAN BE USED BY THE LOADC MACRO.
*           -ADDRESS-, WORD 0, BITS 0-14 AND
*                      WORD 1, BITS 3-15, ARE REFORMATTED TO-
*           -CMADR-,   WORD 0, BITS 0-9,
*                      WORD 1, BITS 0-11,
*                      WORD 2, BITS 0-5.
          SPACE  2
 FORX     LJM    **
 FORMA    EQU    *-1
          STDL   T1

* REFORMAT CM ADDRESS.

          LDML   1,T1
          LPN    7
          NJN    FORM10      IF RMA ADDRESS ERROR
          LDIL   T1
          LPN    37B
          SHN    16
          LMML   1,T1
          SHN    9
          STD    CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   T1
          SHN    -5
          STD    CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMC    400000B
          UJK    FORX
 FORM10   BSS
          RJM    HANG
          SPACE  5,20
** NAME-- GETMSG
*
** PURPOSE-- CHECK FOR A MESSAGE FROM PARTNER PP.
*
** EXIT-- TO CALLING ROUTINE IF GO COMMAND, OTHERWISE THROUGH
*         THE JUMP TABLE.
          SPACE  2
 GETMX    LJM    **
 GETMSG   EQU    *-1
          LDN    0
          STDL   T1          ZERO OUT MESSAGE CODE WHEN IT IS READ
          STDL   T2
          STDL   T3
          STDL   T4
          LOADC  CM.MIN      CM ADDRESS OF MESSAGE CODE
          RDCL   T1          READ MESSAGE AREA
          LDDL   T1          GET MESSAGE CODE
          SBN    C.GO        CHECK FOR GO
          ZJK    GETMX       IF MESSAGE = GO
          MJN    GETMX       IF NO MESSAGE
          SBN    CPROCL+1    CHECK FOR VALID CODE
          MJN    GETM10      IF VALID CODE
          RJM    HANG        INVALID CODE

 GETM10   BSS
          LDML   CPROC-2,T1  GET ADDRESS OF COMMAND PROCESSOR
          STML   GETM20
          LJM    **          PROCESS COMMAND
 GETM20   EQU    *-1

                                                      SENT BY
 CPROC    BSS
          CON    REQ         PROCESS NEW REQUEST       MASTER
          CON    SR          SLAVE RETRY OF SECTOR     MASTER
          CON    SWIT        SWITCH TO NEW REQUEST     MASTER
          CON    END         END OF REQUEST            MASTER
          CON    SMA         A REGISTER NONZERO        SLAVE
          CON    SMB         CHANNEL PARITY ERROR      SLAVE
          CON    RESUME      RESUME COMMAND RECEIVED   MASTER
 CPROCL   EQU    *-CPROC
          SPACE  5,20
** NAME-- GLIST
*
** PURPOSE-- READ THE CM ADDRESS LIST PORTION OF A COMMAND.
          SPACE  2
 GLIX     LJM    **
 GLIST    EQU    *-1
          LDN    1
          STDL   WC          NUMBER OF WORDS TO READ
          LOADF  CM+/CM/P.RMA  LOAD CM ADDRESS AND REFORMAT
          CRML   CMLIST,WC
          LDN    8
          RAML   CM+/CM/P.RMA+1  UPDATE RMA ADDRESS FOR NEXT READ
          STDL   CMRMA+1     SAVE IN CASE A BACKUP IS NEEDED
          SHN    -16
          RAML   CM+/CM/P.RMA
          STDL   CMRMA       SAVE IN CASE A BACKUP IS NEEDED
          UJK    GLIX
*COPYC IODMAC6
          SPACE  5,20
** NAME-- PAUS
*
** PURPOSE-- DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*            MICROSECONDS.
*
** INPUT-- A REGISTER SPECIFIES NUMBER OF MICROSECONDS
*          TO BE DELAYED.
*
** NOTE-- THIS IS SET UP FOR 4X PP TIMING.
          SPACE  2
 PAUSX    LJM    **
 PAUS     EQU    *-1
 PAUS10   BSS
          STDL   0           ONE MICROSECOND LOOP
          SBN    1
          NJN    PAUS10
          UJK    PAUSX
          SPACE  5,20
** NAME-- READ
*
** PURPOSE-- PROCESS READ DATA COMMAND.
*
** INPUT-- CMLISTL = NUMBER OF ADDRESS-LENGTH ENTRIES IN THE
*                    COMMAND WHICH ARE LEFT TO PROCESS.
*          CMLIST  = A TABLE OF THE ADDRESS-LENGTH PAIRS POINTING TO
*                    THE CM DATA AREA.
*
** MASTER/SLAVE INTERACTION
*         MASTER                      SLAVE
*         1.  SEND REQUEST (READ)
*                                     2.  SEND GO (REQ)
*         3.  WAIT (READ32)
*         4.  FUNC (READ32)
*         5.  INPUT (READ35)
*         6.  SEND GO (READ46)
*             (REPEAT 3-6 PER SECTOR  7.  WAIT (READ32)
*                                     8.  INPUT (READ32)
*                                     9.  SEND GO (READ46)
*        10.  WAIT (READ82)               (REPEAT 7-9 PER SECTOR)
*             LAST SECTOR ONLY
*        11.  GENERAL STATUS
          SPACE  2
 READX    LJM    **
 READ     EQU    *-1
          LDDL   SLAVE
          NJN    READ1       IF SLAVE PP
          LDN    C.REQ
          STDL   GOFLG       SET GO FLAG
          RJM    SEND        SEND REQUEST TO SLAVE
          LDC    READ34
          STDL   CA          CONTINUE ADDRESS

 READ1    BSS
          LDN    0
          STDL   SWFLG       CLEAR SWITCH FLAG
          STDL   TOGL        TOGL = 0 TO START
          STDL   WDSS        USED TO UPDATE BYTES TRANSFERRED IN
                             RESPONSE TABLE
 READ3    BSS
          LDN    0
          STDL   SECPOS      SET SECTOR POSITION = 0

* SET UP NUMBER OF WORDS TO TRANSFER TO THIS CM ADDRESS.

 READ10   BSS
          LOADF  CMLIST+/CM/P.RMA  SET UP CM ADDRESS OF DATA AREA
          STDL   DATADD+2
          SRD    DATADD      SAVE R REGISTER
          LDML   CMLIST+/CM/P.LEN  NUMBER OF BYTES TO TRANSFER
          ADN    7           ROUND UP
          SHN    -3          NUMBER OF CM WORDS TO TRANSFER
          STDL   TWDS

* COMPUTE NUMBER OF WORDS TO TRANSFER FROM CURRENT BUFFER.

 READ20   BSS
          STDL   WDS         COMPUTE NUMBER OF WORDS FROM CURRENT BUFFER
          LDML   SECWDS,TOGL NUMBER OF WORDS FOR THE BUFFER FOR THIS PP
          SBDL   SECPOS      WORDS PREVIOUSLY TRANSFERRED FROM THIS BUFFER
          SBDL   WDS         SPACE AVAILABLE IN CM
          PJN    READ25      IF LESS THAN 1 PP WORTH
          LDML   SECWDS,TOGL
          SBDL   SECPOS
          STDL   WDS         NUMBER OF CM WORDS TO TRANSFER
 READ25   BSS
          LDDL   SECPOS      DATA STILL IN THE PP BUFFER
          NJK    READ51      GO MOVE IT TO CM
          LDDL   TOGL
          SBDL   SLAVE       TOGL = SLAVE MEANS I/O IS FOR REAL
          NJK    READ51      IF THIS PP DOES NOT READ THIS PORTION

* TRANSFER DATA FROM THE DISK.

 READ32   BSS
          RJM    WAITP       WAIT FOR A MESSAGE FROM PARTNER
          LDDL   SLAVE
          NJN    READ34A     IF SLAVE, ONLY INPUT THE DATA
          LDN    F.READ      ISSUE READ FUNCTION
          RJM    FUNC
 READ33   EQU    *-1         FOR FORCING ERRORS
 READ34   BSS
          RJM    UDA         UPDATE DISK ADDRESS
 READ34A  BSS
          AODL   GOFLG       SET GO FLAG
 READ35   BSS                INSTRUCTION MODIFIED WHEN FORCING ERRORS
          LDML   IOCOUNT,TOGL  AMOUNT OF DATA TO BE INPUT
          IAPM   7777B,DC    READ THE DATA
 READ36   EQU    *-1
          ZJN    READ40      IF ALL DATA RECEIVED
 READ38   BSS
          STDL   T4          WORDS NOT TRANSFERRED
          LDN    C.AREG      A REGISTER NONZERO
          UJN    READ44

* SEND A GO TO PARTNER.  NOTE THAT IT TAKES 35 MICROSECONDS FROM MASTER
* IAPM TO SLAVE IAPM AND ANOTHER 35 MICROSECONDS FROM SLAVE IAPM TO
* MASTER READ FUNCTION FOR THE NEXT SECTOR.

 READ40   BSS
 F        IFEQ   FE,1        FOR FORCING ERRORS
          LDC    1
 READ40G  EQU    *-1
          SBN    1
          NJN    *-1
 F        ENDIF
          LDDL   SLAVE
          ZJN    READ41      IF MASTER
          RJM    WFI         WAIT FOR INACTIVE
 READ41   BSS
          CFM    READ46,DC   IF ERROR FLAG NOT SET
          LDN    C.CPE       CHANNEL PARITY ERROR
 READ44   BSS
          RJM    RWEP        READ/WRITE ERROR PROCESSING (NO RETURN)
 READ46   BSS
          RJM    SVPTR       SAVE THE CM BUFFER POINTERS
          LDN    C.GO
          RJM    SEND        TELL PARTNER DONE WITH TRANSFER
          RJM    UC          UPDATE CLOCK
          LDN    0
          STDL   GOFLG       CLEAR GO FLAG

* TRANSFER DATA TO CM.

 READ51   BSS
          LDDL   TOGL
          SBDL   SLAVE       TOGL = SLAVE MEANS I/O IS FOR REAL
          NJN    READ55      IF PARTNER IS READING THE DISK
          LDDL   SECPOS      CALCULATE SECTOR
          SHN    2
          ADC    0
 READ52   EQU    *-1         BOTH WORDS OF INSTRUCTION ARE MODIFIED
          STML   READ53
          LDDL   WDS
          ZJN    READ55      IF 0 WORDS TO TRANSFER
          LOADC  DATADD      CM ADDRESS OF DATA AREA
          CWML   -**,WDS     SEND DATA TO CM
 READ53   EQU    *-1
          RJM    UBT         UPDATE BYTES TRANSFERRED

* FLIP THE TOGGLE IF PP BUFFER NOW GOING TO BE EMPTY.

 READ55   BSS
          LDDL   WDS
          RADL   SECPOS      UPDATE BUFFER POSITION
          SBML   SECWDS,TOGL CHECK FOR END OF BUFFER
          ZJN    READ57      IF END OF PP BUFFER
          LDDL   CMLISTL
          SBN    1           IS THIS THE LAST CM AREA
          NJN    READ58      NO, DON'T THROW AWAY DATA IN PP BUFFER
 READ57   BSS
          STDL   SECPOS      RESET BUFFER POSITION TO 0
          LDDL   TOGL
          LMN    1
          STDL   TOGL        FLIP THE TOGGLE
 READ58   BSS
          LDDL   SWFLG       WAS THIS THE FIRST I/O AFTER A REQUEST SWITCH
          ZJN    READ59      NO- (NEVER CAN BE FOR THE SLAVE)
          RJM    SWITCH      GO AND SWITCH THE REQUESTS
 READ59   BSS
          LDDL   WDS
          RADL   WDSS        SAVE BYTES TRANSFERRED FOR LATER UPDATE
          LDDL   WDS
          RADL   DATADD+2    UPDATE CM ADDRESS
          LDDL   TWDS        UPDATE TOTAL WORDS LEFT TO TRANSFER TO THIS
                             CM ADDRESS
          SBDL   WDS
          STDL   TWDS
          NJN    READ59A     IF NOT OUT OF DATA
          LDDL   CMLISTL
          SBN    1           IS THIS THE LAST CM AREA
          NJN    READ60      IF NO, UPDATE AND GO GET MORE REAL DATA
          LDDL   TOGL
          ZJN    READ60      IF THE SLAVE JUST FINISHED
          LDN    0           GO MAKE A DUMMY PASS FOR THE SLAVE
 READ59A  BSS
          UJK    READ20      IF MORE WORDS TO TRANSFER TO THIS CM ADDRESS

* GET NEXT CM ADDRESS OF DATA AREA.

 READ60   BSS
          SODL   CMLISTL     DECREMENT ADDRESS-LENGTH-PAIR COUNT
          ZJN    READ80      IF END OF ADDRESS-LENGTH-PAIRS IN COMMAND
          RJM    GLIST       GET NEXT ENTRY IN LIST
          UJK    READ10      GO CONTINUE READING
 READ80   BSS
          RJM    CSWIT       CHECK IF SWITCH TO NEXT REQUEST
          NJK    READ3       IF SWITCH TO NEXT REQUEST
 READ82   BSS
          RJM    WAITP       MASTER- WAIT FOR SLAVE TO FINISH READING
                             SLAVE- WAIT FOR MASTER TO SAY END
          RJM    GENSTAT     GET GENERAL STATUS
          ZJK    READX       IF NO ERROR
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- RWEP
*
** PURPOSE-- READ/WRITE ERROR PROCESSING
*
** ENTRY
*         A = 6  A REGISTER NONZERO
*         A = 7  CHANNEL PARITY ERROR
          SPACE  2
 RWEP     CON    0
          STDL   T8          SAVE TYPE OF ERROR
          LDDL   SLAVE
          ZJN    RWEP5       IF MASTER PP
          LDDL   T4
          STDL   T6          SAVE WORDS NOT TRANSFERRED
          LDDL   T8
          RJM    SEND        TELL MASTER ABOUT THE ERROR
          LJM    END         WAIT FOR DIRECTION FROM MASTER
 RWEP5    BSS
          LDDL   T4
          STML   RS+/RS/P.FUNTO  WORDS NOT TRANSFERRED IF E05
          RJM    GENSTAT     GET GENERAL STATUS
          LDDL   T8
          SBN    C.AREG
          ZJN    RWEP15      IF A REGISTER ERROR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 RWEP15   BSS
          LDN    E05         INCOMPLETE CHANNEL TRANSFER
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- SEND.
*
** PURPOSE-- SEND A MESSAGE TO THE PARTNER PP.
*
** ENTRY-- A REGISTER = MESSAGE CODE TO BE SENT.
          SPACE  2
 SENDX    LJM    **
 SEND     EQU    *-1
          STDL   T1          MESSAGE CODE
          LDK    46          MAX WAIT IS 30 SECONDS
          STDL   P2
          STDL   P1
 SEND20   BSS
          LOADC  CM.MOUT     CM ADDRESS OF MESSAGE OUT
          CRDL   T2          READ MESSAGE OUT AREA
          LDDL   T2
          NJN    SEND40      IF LAST MESSAGE WAS NOT RECEIVED
          LDDL   T6          WORDS NOT TRANSFERRED FOR A SLAVE ERROR
          STDL   T4
          LDML   CM.MOUT+2   CM ADDRESS OF MESSAGE OUT
          LMC    400000B
          CWDL   T1          WRITE MESSAGE TO CM AREA
          UJK    SENDX

 SEND40   BSS
          SODL   P1
          NJK    SEND20      IF NOT TIMED OUT
          SODL   P2
          NJK    SEND20      IF NOT TIMED OUT
          RJM    HANG        PARTNER DIED
          SPACE  5,20
** NAME-- SETRQ
*
** PURPOSE-- SET UP FOR FIRST REQUEST.
          SPACE  2
 SETRQX   LJM    **
 SETRQ    EQU    *-1
          LDML   SS+/SS/P.REQ  SAVE RMA OF REQUEST
          STML   FCOMRQ      FIRST COMPLETED REQUEST (RMA)
          STML   CURRQ       CURRENT REQUEST (RMA)
          LDML   SS+/SS/P.REQ+1
          STML   FCOMRQ+1
          STML   CURRQ+1
          LDN    1
          STDL   NCOMRQ      NUMBER OF COMPLETED REQUESTS
          LDDL   SLAVE
          NJN    SETRQX      SLAVE CAN QUIT SETUP HERE
          RJM    SETADD      PUT STARTING ADDRESS IN RESPONSE BUFFER

* SET UP INTERRUPT PROCESSOR INSTRUCTION IF INTERRUPT IS SELECTED.

          LDML   RQ+/RQ/P.INT  CHECK IF INTERRUPT WAS SELECTED
          SHN    /RQ/L.INT+2
          MJN    SETR10      IF INTERRUPT SELECTED
          LDC    2400B       PSN INSTRUCTION
          UJN    SETR20

 SETR10   BSS
          LDML   RQ+/RQ/P.PORT  GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RQ/L.PORT+/RQ/N.PORT
          LPN    /RQ/M.PORT
          ADC    102600B     INPN INSTRUCTION
 SETR20   BSS
          STML   INTPRC
          UJK    SETRQX
          SPACE  5,20
** NAME-- SRESP
*
** PURPOSE-- SET UP STATUS RESPONSE BUFFER.
          SPACE  2
 SREX     LJM    **
 SRESP    EQU    *-1
          LDML   SS+/SS/P.PVA        PUT PVA OF REQUEST IN RESPONSE BUFFER
          STML   RS+/RS/P.PVA
          LDML   SS+/SS/P.PVA+1
          STML   RS+/RS/P.PVA+1
          LDML   SS+/SS/P.PVA+2
          STML   RS+/RS/P.PVA+2
          LDN    0
          STML   RS+/RS/P.XFER   TRANSFER COUNT
          STML   RS+/RS/P.XFER+1
          LDN    4
          STML   SS+/SS/P.LASTC  OFFSET TO COMMAND
          UJK    SREX
          SPACE  5,20
** NAME-- SVPTR
*
** PURPOSE-- SAVE BUFFER POINTERS IN CASE DATA RETRANSMISSION IS NEEDED.
          SPACE  2
 SVPTRX   LJM    **
 SVPTR    EQU    *-1
          LDN    2
          STDL   WC
          RJM    EXLOD       GET CM AREA ADDRESS
          ADN    /CB/C.SVAREA
          ADDL   SLAVE       ADD 2 WORDS FOR SLAVE (GET OUT OF THE
          ADDL   SLAVE       SPACE THAT THE MASTER WILL BE USING)
          CWML   SVCELLS,WC  SAVE IT
          UJN    SVPTRX
          SPACE  5,20
** NAME-- UBT
*
** PURPOSE-- UPDATE BYTES TRANSFERRED
          SPACE  2
 UBTX     LJM    **
 UBT      EQU    *-1
          LDDL   WDSS        BYTES TRANSFERRED IN LAST SECTOR
          SHN    3
          RAML   RS+/RS/P.XFER+1
          SHN    -16
          RAML   RS+/RS/P.XFER UPDATE BYTES TRANSFERRED IN RESPONSE
          LDN    0
          STDL   WDSS
          UJN    UBTX
          SPACE  5,20
** NAME-- UC
*
** PURPOSE-- UPDATE CLOCK.  THE CLOCK IS USED TO TIMEOUT COMMANDS.
          SPACE  2
 UCX      LJM    **
 UC       EQU    *-1
          LDDL   CLCUR
          STDL   P6          SAVE CURRENT CLOCK
          IAN    14B
          STDL   CLCUR
          SBDL   P6
          PJN    UC5         IF CLOCK HAS NOT WRAPPED
          ADC    10000B
 UC5      BSS
          RADL   CLMCS       UPDATE MICROSECOND PORTION OF CLOCK
          LDDL   CLMCS
          ADC    -2000
          MJN    UCX         IF LESS THAN 2 MILLISECONDS
          STDL   CLMCS
          LDN    2
          RADL   CLMLS       UPDATE MILLISECOND PORTION OF CLOCK
          ADC    -1000
          MJN    UCX         IF LESS THAN 1 SECOND
          STDL   CLMLS
          AODL   CLSEC       UPDATE SECOND PORTION OF CLOCK
          UJN    UCX
          SPACE  5,20
** NAME-- UNCMND
*
** PURPOSE-- GET NEXT COMMAND.
*
** INPUT-- NUMCM, FRST, RS+/RS/P.LASTC
*
** OUTPUT-- CMLIST, FNC, RQ+/RQ/P.CMND
*           CMLISTL.
*
** EXIT-- A REGISTER = 0, IF NO MORE COMMANDS.
*         A REGISTER .NE. 0, IF NEXT COMMAND PRESENT.
          SPACE  2
 UNCX     LJM    **
 UNCMND   EQU    *-1
          LDML   NUMCM
          ZJN    UNCX        IF NO MORE COMMANDS, EXIT, A REGISTER = 0
          SOML   NUMCM       DECREMENT COMMAND COUNT
          LDML   FRST        HAS FIRST COMMAND BEEN PROCESSED
          ZJN    UNC10       IF FIRST COMMAND HASN'T BEEN PROCESSED

*         READ NEXT COMMAND FROM CM.

          AOML   SS+/SS/P.LASTC OFFSET TO COMMAND
          LDN    C.CM
          STDL   WC
          LOADF  SS+/SS/P.REQ  LOAD CM ADDRESS AND REFORMAT
          ADML   SS+/SS/P.LASTC ADD OFFSET OF COMMAND
          CRML   CM,WC       READ COMMAND FROM CM
 UNC10    AOML   FRST        SET NONZERO

*         IF INDIRECT ADDRESS, READ CM ADDRESS LIST.

          LDN    0
          STDL   FNC         SET UP INTERNAL FUNCTION CODE
          LDML   CM+/CM/P.LEN
          STML   CMLIST+/CM/P.LEN
          SHN    -3
          STDL   CMLISTL     LENGTH OF CM ADDRESS AREA  (CM WORDS)
          LDML   CM+/CM/P.INDIR
          SHN    /CM/L.INDIR+2
          PJN    UNC15       IF NOT INDIRECT ADDRESS
          RJM    GLIST       GET CM ADDRESS LIST OF DATA AREA
          UJN    UNC30
 UNC15    BSS
          LDN    1
          STDL   CMLISTL     IF NOT INDIRECT, ONLY 1 COMMAND.
          LDML   CM+/CM/P.RMA
          STML   CMLIST+/CM/P.RMA
          LDML   CM+/CM/P.RMA+1
          STML   CMLIST+/CM/P.RMA+1

*         SET UP INTERNAL FUNCTION CODE, FNC.

 UNC30    BSS
          LDML   CM+/CM/P.CODE  GET COMMAND CODE
          SHN    -16+/CM/N.CODE+/CM/L.CODE
          SBML   UCMD,FNC    COMPARE COMMAND CODE
          ZJN    UNC40       IF COMMAND FOUND
          AODL   FNC
          SBN    UCMDL
          MJN    UNC30       IF MORE COMMANDS TO CHECK
          LDDL   SLAVE
          ZJK    UNC31       NOT SLAVE
          RJM    HANG        NO ERROR RESPONSE FROM SLAVE
 UNC31    BSS
          LDC    E501        ERROR IN COMMAND CODE
          RJM    INTERR      INTERFACE ERROR (NO RETURN)
 UNC40    LDN    1           SET A REGISTER NONZERO FOR EXIT
          UJK    UNCX
          SPACE  5,20
** NAME-- WAITP
*
** PURPOSE-- WAIT FOR A MESSAGE FROM THE PARTNER PP.
          SPACE  2
 WAITX    LJM    **
 WAITP    EQU    *-1
 WAIT10   BSS
          RJM    GETMSG      GET MESSAGE FROM PARTNER
          ZJK    WAITX       IF MESSAGE = GO
          UJK    WAIT10      IF NO MESSAGE
          SPACE  5,20
** NAME-- WFI
*
** PURPOSE-- WAIT FOR CHANNEL INACTIVE
          SPACE  2
 WFIX     LJM    **
 WFI      EQU    *-1
          LCN    0
 WFI10    BSS
          IJM    WFIX,DC     IF CHANNEL INACTIVE
          SBN    1
          NJN    WFI10       IF TIMEOUT NOT EXPIRED
          LDDL   SLAVE
          NJK    READ38      IF SLAVE
          STDL   T4          WORDS NOT TRANSFERRED
          LDN    C.AREG      INCOMPLETE CHANNEL TRANSFER
          RJM    RWEP        READ WRITE ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- WRITE
*
** PURPOSE-- PROCESS THE WRITE DATA COMMAND.
*
** INPUT-- CMLISTL = NUMBER OF ADDRESS-LENGTH-PAIR ENTRIES IN THE
*                    COMMAND WHICH ARE LEFT TO PROCESS.
*          CMLIST = LIST OF ADDRESS-LENGTH-PAIRS POINTING TO THE
*                   CM DATA AREA.
          SPACE  2
 WRIX     LJM    **
 WRITE    EQU    *-1
          LDDL   SLAVE
          NJN    WRI3        IF SLAVE PP
          LDN    C.REQ
          STDL   GOFLG       SET GO FLAG
          RJM    SEND        SEND REQUEST TO SLAVE
 WRI3     BSS
          LDN    0
          STDL   WDSS        USED TO UPDATE BYTES TRANSFERRED IN
                             RESPONSE TABLE
          STDL   TOGL        TOGL = ZERO TO START
          STDL   SWFLG       CLEAR SWITCH FLAG
 WRI5     BSS
          LDN    0
          STDL   SECPOS      SET SECTOR POSITION = 0

* SETUP NUMBER OF WORDS TO TRANSFER FROM THIS CM ADDRESS.

 WRI20    BSS
          LOADF  CMLIST+/CM/P.RMA  SET UP CM ADDRESS OF DATA AREA
          STDL   DATADD+2
          SRD    DATADD      SAVE R REGISTER
          LDML   CMLIST+/CM/P.LEN  NUMBER OF 8-BIT BYTES TO TRANSFER
          ADN    7           ROUND UP
          SHN    -3          NUMBER OF CM WORDS TO TRANSFER
          STDL   TWDS        TOTAL NUMBER OF CM WORDS TO TRANSFER
                             FROM THIS ADDRESS
 WRI30    BSS
          STDL   WDS         COMPUTE NUMBER OF WORDS TO TRANSFER TO
                             CURRENT SECTOR
          LDML   SECWDS,TOGL NUMBER OF WORDS FOR THE SECTOR FOR THIS PP
          SBDL   SECPOS      WORDS PREVIOUSLY TRANSFERRED
          SBDL   WDS         WORDS AVAILABLE FROM CM
          PJN    WRI35       IF LESS THAN THIS PP NEEDS TO FILL BUFFER
          LDML   SECWDS,TOGL  NUMBER OF WORDS FOR THIS PP
          SBDL   SECPOS
          STDL   WDS         NUMBER OF CM WORDS CURRENTLY NEEDED

* TRANSFER DATA FROM CM.

 WRI35    BSS
          LDDL   TOGL
          SBDL   SLAVE       TOGL = SLAVE MEANS I/O IS FOR REAL

          NJN    WRI38       IF PARTNER WRITES, I DON'T NEED DATA
          LDDL   SECPOS      CALCULATE SECTOR BUFFER TRANSFER ADDRESS
          SHN    2
          ADC    0           BOTH WORDS OF THE INSTRUCTION ARE MODIFIED
 WRI36    EQU    *-1
          STML   WRI37
          LDDL   WDS
          ZJN    WRI38       IF ZERO WORDS TO TRANSFER
          LOADC  DATADD      CM ADDRESS OF DATA AREA

          CRML   -**,WDS     READ THE DATA
 WRI37    EQU    *-1

* UPDATE SECTOR POSITION.

 WRI38    BSS
          LDDL   WDS
          RADL   SECPOS      UPDATE SECTOR POSITION
          SBML   SECWDS,TOGL  CHECK FOR END OF BUFFER
          NJN    WRI39       IF NOT END OF BUFFER
          STDL   SECPOS      SET BACK TO BEGINNING OF BUFFER
          UJN    WRI46
 WRI39    BSS
          LDDL   CMLISTL     CHECK IF MORE CM ADDRESS-LENGTH-PAIRS
          SBN    1
          NJK    WRI69       IF MORE CM DATA TO TRANSFER
          LDN    0
          STDL   SECPOS      RESET SECTOR POSITION = 0

* WAIT FOR GO FROM PARTNER.

 WRI46    BSS
          LDDL   TOGL
          SBDL   SLAVE       TOGL = SLAVE MEANS I/O IS FOR REAL
          NJK    WRI64       IF PARTNER WRITES THIS SECTOR
          RJM    WAITP       WAIT FOR MESSAGE FROM PARTNER
          LDDL   SLAVE       IF SLAVE, CHANNEL IS ALREADY GOING
          NJN    WRI52       JUST GO AND MOVE THE DATA

* TRANSFER DATA TO DISK.

          LDN    F.WRITE     ISSUE WRITE FUNCTION TO DISK CONTROLLER
          RJM    FUNC        ISSUE THE FUNCTION (MASTER ONLY)
 WRI50    EQU    *-1         FOR FORCING ERRORS
          RJM    UDA         UPDATE DISK ADDRESS
          LDN    1
          STDL   GOFLG       SET GO FLAG
 WRI52    BSS
          LDML   IOCOUNT,TOGL  BUFFER SIZE
          OAPM   7777B,DC    WRITE TO DISK
 WRI53    EQU    *-1
          NJN    WRI56       IF NOT ALL WORDS TRANSFERRED
 F        IFEQ   FE,1        FOR FORCING ERRORS
          LDC    1
 WRI54    EQU    *-1
          SBN    1
          NJN    *-1
 F        ENDIF
          LDDL   SLAVE
          ZJN    WRI58       IF MASTER
          LDN    77B
 WRI55    BSS
          EJM    WRI57,DC    IF CHANNEL EMPTY
          SBN    1
          NJN    WRI55       IF TIMEOUT NOT EXPIRED
 WRI56    BSS
          STDL   T4          WORDS NOT TRANSFERRED
          LDN    C.AREG      NOT ALL WORDS TRANSFERRED
          UJN    WRI59
 WRI57    BSS
          DCN    DC+40B      DISCONNECT THE CHANNEL
 WRI58    BSS
          CFM    WRI60,DC    IF ERROR FLAG NOT SET
          LDN    C.CPE       CHANNEL PARITY ERROR
 WRI59    BSS
          RJM    RWEP        READ WRITE ERROR PROCESSING (NO RETURN)

* SEND A GO TO PARTNER/SAVE POINTERS/UPDATE CLOCK

 WRI60    BSS
          LDN    C.GO
          RJM    SEND        TELL PARTNER DONE WITH TRANSFER
          RJM    UC          UPDATE CLOCK
          LDN    0
          STDL   GOFLG       CLEAR GO FLAG
 WRI64    BSS
          RJM    UBT         UPDATE BYTES TRANSFERRED
          LDDL   SWFLG       WAS THIS THE FIRST I/O AFTER A REQUEST SWITCH
          ZJN    WRI68       NO- (NEVER CAN BE FOR THE SLAVE)
          RJM    SWITCH      GO AND SWITCH REQUESTS
 WRI68    BSS
          LDDL   TOGL        INVERT TOGGLE FLAG
          LMN    1
          STDL   TOGL
 WRI69    BSS
          LDDL   WDS
          RADL   WDSS        SAVE WORDS TRANSFERRED THIS SECTOR
          LDDL   WDS
          RADL   DATADD+2    UPDATE CM ADDRESS
          LDDL   TWDS        UPDATE TOTAL WORDS LEFT TO TRANSFER
                             FROM THIS CM ADDRESS.
          SBDL   WDS
          STDL   TWDS
          NJN    WRI69A      IF MORE TO TRANSFER FROM THIS CM ADDRESS
          LDDL   TOGL
          ZJN    WRI70       IF REALLY NO MORE TO TRANSFER
          LDDL   CMLISTL
          SBN    1           CHECK IF LAST CM ADDRESS POINTER
          NJN    WRI70       IF NO, GO GET THE NEXT DATA ADDRESS
 WRI69A   BSS
          LJM    WRI30       GO GET MORE DATA

* GET NEXT CM ADDRESS OF DATA AREA.

 WRI70    BSS
          SODL   CMLISTL     DECREMENT ADDRESS-LENGTH-PAIR COUNT
          ZJN    WRI74       IF END OF ADDRESS-LENGTH-PAIRS IN COMMAND
          RJM    GLIST       GET NEXT ENTRY OF LIST
          UJK    WRI20

* GET NEXT COMMAND.

WRI74     BSS
          RJM    UNCMND      GET NEXT COMMAND
          ZJN    WRI80       IF NO MORE COMMANDS
          LDDL   FNC         GET COMMAND CODE
          SBN    1
          ZJK    WRI20       IF WRITE
          LDC    E50A
          RJM    INTERR      INTERFACE ERROR (NO RETURN)

* END OF DATA.  GET GENERAL STATUS FOR LAST SECTOR

 WRI80    BSS
          RJM    CSWIT       CHECK IF SWITCH TO NEXT REQUEST
          NJK    WRI5        IF SWITCH TO NEXT REQUEST
 WRI82    BSS
          RJM    WAITP       WAIT FOR PARTNER (SLAVE NEVER RETURNS TO +1)
          RJM    GENSTAT     GET LAST GENERAL STATUS
          ZJK    WRIX        IF NO ERROR
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          ERRPL  *-SLVBUF    IF SLAVE CODE OVERFLOWS INTO THE DATA BUFFER
          TITLE  RESIDENT MASTER ROUTINES
** NAME-- CCLOCK
*
** PURPOSE-- CLEARS CHANNEL LOCK.
*
          SPACE  2
 CCLX     LJM    **
 CCLOCK   EQU    *-1
          LDML   CHLOCK
          NJK    CCLX        IF CHANNEL LOCK WAS NOT SET
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   P6
          LDDL   CHAN        CHANNEL NUMBER = OFFSET IN TABLE
          STDL   T5
          RJM    CLOCK       CLEAR CHANNEL LOCKWORD
          LDN    1
          STML   CHLOCK      INDICATE CHANNEL LOCK CLEARED
          UJK    CCLX
          SPACE  5,20
** NAME-- CKC
*
** PURPOSE-- CHECK IF CHANNEL MUST BE GIVEN UP
          SPACE  2
 CKCX     LJM    **
 CKC      EQU    *-1
          LDN    C.CHCNT     NUMBER OF REQUESTS TO PROCESS BEFORE
          STML   CHLCNT       GIVING UP THE CHANNEL
          LOADC  CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          ADDL   CHAN        CHANNEL  NUMBER IS OFFSET IN TABLE
          CRDL   T1          READ CHANNEL LOCKWORD
          LDDL   T2
          LPN    1
          ZJK    CKCX        IF NOT GIVING UP THE CHANNEL
          LDDL   DEVL
          ZJK    CKCX        IF NO UNITS
          RJM    CCLOCK      CLEAR THE CHANNEL LOCK
          PAUSE  130000      DELAY TO ALLOW MAINTENANCE TO GET THE CHANNEL
          RJM    SCLOCK      SET CHANNEL LOCK
          STDL   CTF         SO ERROR WILL BE REPORTED AS UNSOLICITED
          STDL   PTF
          LJM    MAIN5
          SPACE  5,20
** NAME-- CLOCK
*
** PURPOSE-- CLEAR LOCKWORD
*
** ENTRY
*         P6 = POINTER RMA
*         T5 = OFFSET TO LOCKWORD FROM RMA
*
** EXIT
*         A = 0 IF LOCK WAS CLEARED
          SPACE  2
 CLKX     LJM    **
 CLOCK    EQU    *-1
 CLK10    BSS
          LCN    0
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,P6        INTERFACE TABLE ADDRESS
          ADDL   T5          ADD OFFSET
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE
          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJN    CLK10       IF INTERMEDIATE VALUE
          LDDL   T4
          SBDL   PPNO
          ZJN    CLK30       IF THIS PP HAS THE LOCK SET
          LDDL   T6
          LMC    400000B
          CWDL   T1          RESTORE THE ORIGINAL LOCKWORD
          LDN    1
          UJK    CLKX        EXIT, LOCKWORD NOT CLEARED
 CLK30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK
          LMC    400000B
          CWDL   T1          CLEAR THE LOCKWORD
          LDN    0
          UJK    CLKX        EXIT, LOCKWORD CLEARED
          SPACE  5,20
** NAME-- CLRLOCK
*
** PURPOSE-- CLEARS UNIT LOCK IN UNIT INTERFACE TABLE.
*
** ENTRY
*         LUTLOC - POINTER TO CURRENT LOGICAL UNIT TABLE
          SPACE  2
 CLRLX    LJM    **
 CLRLOCK  EQU    *-1
          LDDL   LUTLOC        UNIT INTERFACE TABLE ADDRESS
          ADN    /LUT/P.UIT
          STDL   P6
          LDN    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR UNIT LOCKWORD
          NJN    CLR10       IF LOCK COULD NOT BE CLEARED
          STML   /LUT/P.OWNER,LUTLOC  CLEAR LOCKED FLAG
          UJK    CLRLX
 CLR10    BSS
          RJM    HANG
          SPACE  5,20
** NAME-- CQLOCK
*
** PURPOSE-- CLEARS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
          SPACE  2
 CQLX     LJM    **
 CQLOCK   EQU    *-1
          LDDL   LUTLOC      UNIT INTERFACE TABLE ADDRESS
          ADN    /LUT/P.UIT
          STDL   P6
          LDN    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    CLOCK       CLEAR THE LOCKWORD
          UJK    CQLX
          SPACE  5,20
** NAME-- CSWIT
*
** PURPOSE-- CHECK IF A SWITCH SHOULD BE MADE TO THE NEXT
*            REQUEST.  THE SWITCH IS DONE BY THE MASTER WHILE
*            THE SLAVE IS TRANSFERRING DATA.
*
** EXIT-- A REGISTER = 0, IF NOT SWITCH.
*         A REGISTER NONZERO, IF SWITCH.
          SPACE  2
 CSW100   BSS
          LDN    0
 CSWX     LJM    **
 CSWIT    EQU    *-1
          LDDL   SLAVE
          NJN    CSW100      IF SLAVE (SLAVE DOESN'T SWITCH)
          LDDL   CF
          NJN    CSW100      IF IN RECOVERY, DON'T SWITCH
          LDML   RS+/RS/P.RTRY
          NJN    CSW100      IF IN RECOVERY, DON'T SWITCH

* RE-READ THE SWITCH FLAG AND LINKAGE WORDS.

          LDN    2           NUMBER OF WORDS TO READ
          STDL   WC
          LOADF  SS+/SS/P.REQ  LOAD CM ADDRESS AND REFORMAT
          ADN    2
          CRML   RQ+2*4,WC   READ CURRENT REQUEST
          SBN    4
          CRML   RQ,WC       READ SWITCH FLAG BEFORE LINKAGE POINTERS
          LDML   RQ+/RQ/P.SWIT  CHECK IF REQUEST SWITCH FLAG SET
          SHN    -16+/RQ/N.SWIT+/RQ/L.SWIT
          STDL   SWFLG       SAVE SWITCH FLAG
          ZJK    CSWX        IF SWITCH FLAG IS NOT SET
          LDML   RQ+/RQ/P.NEXT  PUT RMA OF NEXT REQUEST IN SS TABLE
          STML   SS+/SS/P.REQ
          LDML   RQ+/RQ/P.NEXT+1
          STML   SS+/SS/P.REQ+1
          LDML   RQ+/RQ/P.NEXTPV  PUT PVA OF NEXT REQUEST IN SS TABLE
          STML   SS+/SS/P.PVA
          LDML   RQ+/RQ/P.NEXTPV+1
          STML   SS+/SS/P.PVA+1
          LDML   RQ+/RQ/P.NEXTPV+2
          STML   SS+/SS/P.PVA+2
          RJM    UREQ        READ NEXT REQUEST INTO RQ
          RJM    SAVSS       WRITE SS TABLE TO CM
          LDN    C.SWIT      SEND SWITCH MESSAGE TO SLAVE
          RJM    SEND
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
          LDN    1
          UJK    CSWX        EXIT NONZERO
          SPACE  5,20
** NAME-- CTR
*
** PURPOSE-- CONFIDENCE TEST RECOVERY (THE CONFIDENCE TEST IS
*            CONSIDERED SUCCESSFUL IF NO MORE THAN 3 SECTORS OF
*            A CYLINDER HAVE UNRECOVERABLE MEDIA ERRORS.
*
** EXIT-- TO CALLING ROUTINE WITH
*           A = 0  DATA INTEGRITY ERROR OR MORE THAN 3 MEDIA ERRORS
*           A NOT 0  IF NOT A MEDIA ERROR
*         TO CTDT ROUTINE IF MEDIA ERROR
          SPACE  2
 CTR100   BSS
          LMN    4
 CTRX     LJM    **
 CTR      EQU    *-1
          RJM    RDT         READ DEVICE TABLE
          SHN    -1
          NJN    CTR100      IF NOT IN CONFIDENCE TEST
          LDML   RS+/RS/P.DET
          LMN    1
          NJN    CTRX        IF NOT MEDIA ERROR
          LDML   RS+/RS/P.GENST1
          LMC    GS5020
          NJN    CTRX        IF NOT MEDIA ERROR
          LDML   RS+/RS/P.DETAIL+4
          LPN    17B
          SBN    4
          ZJN    CTR10       IF FORMAT 4 (MEDIA ERROR)
          SBN    1           CHECK FOR FORMAT 5
          NJK    CTRX        IF NOT MEDIA ERROR
 CTR10    BSS
          STDL   T6          CLEAR INDEX TO MEDIA ERROR TABLE
          LDML   SS+/SS/P.TRACK
          LPN    77B
          SHN    8
          ADML   SS+/SS/P.SECTOR
          STDL   T5
 CTR20    BSS
          LDML   SS+CTME,T6
          SHN    2
          MJN    CTR30       IF TABLE ENTRY AVAILABLE
          SHN    -2
          LMDL   T5
          ZJN    CTR30       IF SECTOR IN TABLE
          AODL   T6
          LMN    3
          NJN    CTR20       IF MORE ENTRIES TO CHECK
          UJK    CTRX
*
*         THE CONFIDENCE TEST OVERLAY MUST ALREADY BE LOADED.  LOADING IT
*         HERE WOULD DESTROY RETURN JUMP ADDRESSES.
*
 CTR30    BSS
          LDDL   T5
          STML   SS+CTME,T6  PUT ADDRESS IN TABLE
          LDN    1
          STDL   FT          SO UDA WILL UPDATE ADDRESS
          RJM    UDA         UPDATE DISK ADDRESS
          LDDL   FNC
          ZJN    CTR40       IF READ
          LDML   SS+/SS/P.TRACK
          LPN    77B
          SBN    MAXTR+1
          ZJK    CTDT45      IF ERROR WAS ON LAST SECTOR OF CYLINDER
          LDN    0
          STDL   FT          INDICATE FIRST FUNCTION
          LJM    CTDT20      CONTINUE WRITING
 CTR40    BSS
          LDML   SS+/SS/P.TRACK
          LPN    77B
          SBN    MAXTR+1
          ZJK    CT25        IF ERROR WAS ON LAST SECTOR OF CYLINDER
          LDN    0
          LJM    CTDT50
          SPACE  5,20
** NAME-- DCN
*
** PURPOSE-- WAIT FOR CHANNEL EMPTY, THEN DISCONNECT THE CHANNEL
          SPACE  2
 DCNX     BSS
          DCN    DC+40B      DISCONNECT THE CHANNEL
          LJM    **
 DCN      EQU    *-1
          LCN    0
 DCN10    BSS
          EJM    DCNX,DC     IF CHANNEL EMPTY
          SBN    1
          NJN    DCN10       IF TIMEOUT NOT EXPIRED
          STML   RS+/RS/P.FUNTO  WORDS NOT TRANSFERRED
          LDN    E05         INCOMPLETE CHANNEL TRANSFERR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- DELRQ
*
** PURPOSE-- DELETE COMPLETED REQUEST FROM THE UNIT QUEUE.
*            SELECT A NEW CURRENT REQUEST BASED UPON CYLINDER ADDRESS.
*
** INPUTS-- SS+P.UQT = POINTER TO UNIT QUEUE TABLE
*           RQ = COMPLETED REQUEST.
*
** OUTPUTS-- RQ = SELECTED REQUEST
*            T8 IS UNCHANGED
          SPACE  2
 DELX     LJM    **
 DELRQ    EQU    *-1
 DEL2     BSS
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    DEL2        IF LOCK COULD NOT BE SET

* DECREMENT QUEUE COUNTER.

          LOADR  SS+/SS/P.UQT  LOAD CM ADDRESS OF UNIT QUEUE TABLE
          STDL   T1
          CRDL   P1          READ QUEUE COUNT
          LDDL   P1+/UIT/P.QCNT  DECREMENT QUEUE COUNT
          SBDL   NCOMRQ      NUMBER OF COMPLETED REQUESTS
          STDL   P1+/UIT/P.QCNT
          MJN    DEL3        IF INVALID QUEUE COUNT
          LDDL   T1
          LMC    400000B
          CWDL   P1          WRITE QUEUE COUNT

* RE-READ RMA CHAIN POINTERS OF CURRENT REQUEST.

 DEL3     BSS
          LDN    2
          STDL   P3
          LOADF  CURRQ       RMA OF CURRENT REQUEST
          CRML   RQ,P3       READ RMA CHAIN OF CURRENT REQUEST

          LOADR  SS+/SS/P.DP  DELINK POINTER
 DEL15    BSS
          STDL   P2
          ADN    1           POINT TO RMA INSTEAD OF PVA
          CRDL   T1          RMA OF A REQUEST
          LDDL   T3
          LMML   FCOMRQ
          NJN    DEL20       IF NOT COMPLETED REQUEST
          LDDL   T4
          LMML   FCOMRQ+1
          ZJN    DEL30       IF THIS IS A COMPLETED REQUEST
 DEL20    BSS
          LOADF  T3          UPDATE DELINK POINTER TO NEXT
          STML   SS+/SS/P.DP+2   REQUEST IN THE CHAIN
          LDDL   CMADR
          STML   SS+/SS/P.DP
          LDDL   CMADR+1
          STML   SS+/SS/P.DP+1
          LDDL   CMADR+2
          LMC    400000B
          UJN    DEL15

* DELINK COMPLETED REQUESTS.
* (P3 = 2.)

 DEL30    BSS
          LDDL   P2          CM ADDRESS OF REQUEST
          LMC    400000B
          CWML   RQ,P3       PVA AND RMA OF NEXT REQUEST IN CHAIN

*         SELECT NEXT REQUEST ON QUEUE

          LDN    0
          STDL   NCOMRQ      CLEAR COMPLETED REQUEST COUNT
          STML   SS+/SS/P.ENTRY  INDICATE NO REQUEST SELECTED
          LDML   RQ+/RQ/P.NEXT
          ADML   RQ+/RQ/P.NEXT+1
          NJN    DEL35       IF REQUEST EXISTS
          LDDL   P4
          ZJK    DEL40       IF QUEUE EMPTY
          RJM    SELRQ       SELECT FIRST REQUEST ON QUEUE
          UJK    DELX
 DEL35    BSS
          RJM    CQLOCK      CLEAR QUEUE LOCK
          LDML   RQ+/RQ/P.NEXT  SAVE RMA OF NEXT REQUEST
          STML   SS+/SS/P.REQ
          LDML   RQ+/RQ/P.NEXT+1
          STML   SS+/SS/P.REQ+1
          LDML   RQ+/RQ/P.NEXTPV  SAVE PVA OF NEXT REQUEST
          STML   SS+/SS/P.PVA
          LDML   RQ+/RQ/P.NEXTPV+1
          STML   SS+/SS/P.PVA+1
          LDML   RQ+/RQ/P.NEXTPV+2
          STML   SS+/SS/P.PVA+2
          LDN    /SS/K.ENTRY
          STML   SS+/SS/P.ENTRY  INDICATE REQUEST SELECTED
          RJM    SSA         SET SEEK ADDRESS
          UJN    DEL45
 DEL40    BSS
          RJM    CQLOCK      CLEAR QUEUE LOCKWORD
 DEL45    BSS
          RJM    SAVSS       SAVE SHARED TABLE
          UJK    DELX
          SPACE  5,20
** NAME-- DS
*
** PURPOSE-- GET DETAILED STATUS.  THIS PROVIDES MORE INFORMATION FOR AN
*            ERROR.  IT IS NOT THE CAUSE OF AN ERROR, SO AN ERROR TRYING
*            TO GET DETAILED STATUS DOES NOT GENERATE AN ERROR.
*
** NOTE -- MUST BE RESIDENT DUE TO CHANNEL INSTRUCTIONS
          SPACE  2
 DSX      LJM    **
 DS       EQU    *-1
          LDDL   GNSTAT
          STML   RS+/RS/P.GENST1 PUT GENERAL STATUS IN RESPONSE
          STML   RS+/RS/P.GENST2
          DCN    DC+40B      ENSURE THE CHANNEL IS DISCONNECTED
          LDN    F.EDS
          FAN    DC          ISSUE DETAILED STATUS FUNCTION
          LCN    0
 DS5      BSS
          IJM    DS10,DC     IF CHANNEL INACTIVE
          SBN    1
          NJN    DS5         IF TIMEOUT NOT EXPIRED
          UJK    DSX
 DS10     BSS
          LDN    20
          STDL   T1
          ACN    DC
          IAM    RS+/RS/P.DETAIL,DC INPUT DETAILED STATUS
          SFM    DS20,DC     IF ERROR
          NJN    DS20        IF ERROR
          LDN    1
          STML   RS+/RS/P.DET INDICATE DETAILED STATUS PRESENT
 DS20     BSS
          LDML   RS+/RS/P.DETAIL-1,T1 MAKE FIRST AND LAST DETAILED
          STML   RS+/RS/P.DETAIL+19,T1  STATUS THE SAME
          SODL   T1
          NJN    DS20
          UJK    DSX
          SPACE  5,20
** NAME-- EFP
*
** PURPOSE-- ERROR FLAG PROCESSING
          SPACE  2
 EFP      CON    0
 F        IFEQ   CHANTYP,1
          RJM    RES         READ ERROR STATUS REGISTER
          STML   RS+/RS/P.LERREG
          STML   RS+/RS/P.FERREG
          SHN    15
          PJN    EFP10       IF NOT KZ BOARD ERROR
          LDN    E02
          UJN    EFP30
 EFP10    BSS
          SHN    2
          PJN    EFP20       IF NOT KX BOARD ERROR
          LDN    E03
          UJN    EFP30
 EFP20    BSS
 F        ENDIF
          LDN    E04
 EFP30    BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- EP
*
** PURPOSE-- ERROR PROCESSING
*
** ENTRY
*         CA - ADDRESS TO GO FOR CONTINUE RECOVERY
*         COMLOOK - INDEX TO TABLE FOR FAILING UNIT
*         LUTLOC - POINTER TO LOGICAL UNIT TABLE
          SPACE  2
 EP       CON    0
          LDML   RS+/RS/P.RTRY
          NJN    EP5         IF NOT FIRST ERROR FOR REQUEST
          STDL   RECOV       CLEAR INDEX TO RECOVERY STEP
 EP5      BSS
          RJM    PPREQ       CHECK FOR IDLE REQUEST
          LDN    0
          STDL   FT          CLEAR FIRST TIME FLAG
          LDDL   CA
          ZJN    EP10        IF NOT SENDING CONTINUE
          LDDL   GNSTAT
          LMC    GS4400
          NJN    EP10        IF NOT SENDING CONTINUE
          LDML   RS+/RS/P.EC
          NJN    EP10        IF NOT SENDING CONTINUE (PARITY ERR ON GENSTAT)
          LDN    F.CONT
          RJM    FUNC        SEND CONTINUE FUNCTION
          AODL   CF          INDICATE CONTINUE FUNCTION SENT
          LDDL   GOFLG
          NJN    EP7         IF ERROR ON CURRENT SECTOR
          RJM    RDT         READ DEVICE TABLE
          SHN    -1
          ZJN    EP7         IF ERROR DURING CONFIDENCE TEST
          LDN    C.RTRY
          RJM    SEND        TELL SLAVE TO BACK UP
          LOADOVL ERO        LOAD ERROR RECOVERY OVERLAY
          RJM    RSTBP       RESTORE BACKUP POINTERS
 EP7      BSS
          LJM    0,CA
 EP10     BSS
          LDDL   RECOV       INDEX TO RECOVERY PROCEDURE
          STDL   T1
          LDML   EPT,T1
          STML   EP20
          LJM    **          EXECUTE NEXT STEP IN RECOVERY SEQUENCE
 EP20     EQU    *-1
 EPT      BSS
          CON    EPA         RETRY THE REQUEST
          CON    EPB         CONFIDENCE TEST/FORMAT
          CON    EPC         AUTOLOAD CCC
          CON    EPD         LAST RECOVERY ATTEMPT FAILED
          CON    EPE         DOWN CHANNEL
          CON    EPF         DOWN UNIT
          CON    EPG         CLEAR UNIT LOCK
*
*         REQUEST RETRY
*
 EPA      BSS
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          RJM    CTR         CONFIDENCE TEST RECOVERY
          NJN    EPA20       IF ERROR LIMIT NOT REACHED
          AOML   RS+/RS/P.RTRY  REQUEST RETRY COUNTER
          UJK    EPC
 EPA20    BSS
          AOML   RS+/RS/P.RTRY  REQUEST RETRY COUNTER
          SBN    RTRY
          PJN    EPB         IF RETRY LIMIT
          UJK    EPC80
*
*         CONFIDENCE TEST/FORMAT UNIT
*
 EPB      BSS
          LDML   CTF
          ZJK    EPB20       IF IN SUBSYSTEM CONFIDENCE TEST
          LDDL   FNC
          SBN    2
          ZJK    EPD         IF FORMAT
          LDDL   RECOV
          LMN    1
          ZJN    EPB10       IF CONFIDENCE TEST ALREADY STARTED
          AODL   RECOV       INDEX TO NEXT RECOVERY STEP
          RJM    RDT         READ DEVICE TABLE
          LPN    /CB/K.ACT
          STDL   P2
          LDDL   CM.DEV+2
          ADDL   COMLOOK
          LMC    400000B
          CWDL   P2          ENABLE STARTING CONFIDENCE TEST
          LOADOVL CTO        LOAD CONFIDENCE TEST OVERLAY
          RJM    CT          CONFIDENCE TEST
          LDML   /LUT/P.OFFSET,LUTLOC
          STDL   COMLOOK     RESTORE INDEX TO DEVICE TABLE
          LJM    EPC80
 EPB10    BSS
          RJM    CTR         CONFIDENCE TEST RECOVERY
          UJN    EPC
 EPB20    BSS
          LDDL   PTF
          NJN    EPB30       IF PATH TEST COMPLETE
          LDN    4           EPE IS ENTRY FOR NEXT ERROR
          STDL   RECOV
          LJM    MAIN5
 EPB30    BSS
          LDN    0
          STDL   PTF         SO PATH TEST WILL BE RUN
          LOADOVL PTO        LOAD PATH TEST OVERLAY
          RJM    PT          EXECUTE PATH TEST
          LDN    3           EPD IS NEXT STEP IN RECOVRY ALGORITHM
          STDL   RECOV       DOWN UNIT IF FORMAT FAILS
          LOADOVL FMO        LOAD FORMAT OVERLAY
          LDC    MAXCYL-1
          STML   FBUF        CONFIDENCE TEST CYLINDER
          RJM    FC          FORMAT CONFIDENCE TEST CYLINDER
          LJM    MAIN5
*
*         AUTOLOAD CCC
*
 EPC      BSS
          LDDL   RECOV
          SBN    2
          ZJK    EPC50       IF LOAD ALREADY ATTEMPTED
          RJM    RDT         READ DEVICE TABLE
          SHN    -1
          SBN    1
          NJN    EPC40       IF CONFIDENCE TEST FAILED
          LDK    /RS/K.DATERR  INDICATE MEDIA ERROR
          STML   RS+/RS/P.HDWR
          LDC    R.ABN*0#4000  ABNORMAL TERMINATION
          STML   RS+/RS/P.RC  RESPONSE CODE
          RJM    RESP        SEND RESPONSE
          RJM    DELRQ       DELINK REQUEST
          LJM    EPE20
 EPC40    BSS
          ADN    1
          NJN    EPC50       IF ERROR CODE ALREADY STORED
          LDDL   P2
          LPN    1
          LMN    4
          STDL   P2
          LDDL   CM.DEV+2
          ADDL   COMLOOK
          ADC    400000B
          CWDL   P2          INDICATE CONFIDENCE TEST FAILED
 EPC50    BSS
          RJM    INTRS       SEND INTERMEDIATE RESPONSE
          LOADOVL PTO        LOAD NECESSARY OVERLAY
          LDML   RS+/RS/P.RTRY
          SBN    RTRY+1
          MJN    EPC60       IF NOT RETRY LIMIT
          LDN    4           DOWN CHANNEL IF CCC LOAD FAILS (EPE)
          UJN    EPC70
 EPC60    BSS
          LDN    2           RETRY LOAD IF LOAD FAILS (EPC)
 EPC70    BSS
          STDL   RECOV
          AOML   RS+/RS/P.RTRY  REQUEST RETRY COUNTER
          LDN    0
          STDL   PTF         SO PATH TEST WILL BE RUN
          RJM    PT          PATH TEST
          RJM    RDT         READ DEVICE TABLE
          SHN    -1
          LMN    4
          ZJK    EPF         DOWN UNIT IF DATA INTEGRITY ERROR
          LDML   RS+/RS/P.RTRY
          SBN    RTRY+2
          MJN    EPC80       IF NOT RETRY LIMIT
          LDN    3
          STDL   RECOV       NEXT STEP IS EPD
 EPC80    BSS
          LOADOVL ERO        LOAD ERROR RECOVERY OVERLAY
          RJM    RSTRQ       RESTART REQUEST (NO RETURN)
*
*         LAST RECOVERY ATTEMPT HAS FAILED, DOWN THE STORAGE
*         DIRECTOR OR THE DRIVE
*
 EPD      BSS
          LDML   RS+/RS/P.DET
          ZJK    EPF         IF NO DETAILED STATUS
          LDML   RS+/RS/P.GENST1
          LMC    0#A10
          NJK    EPF         IF NO SENSE BYTES
          LDML   RS+/RS/P.DETAIL
          SHN    7
          MJN    EPD10       IF STORAGE DIRECTOR FAILURE
          LDML   RS+/RS/P.DETAIL+4
          LPN    17B
          SBN    2
          MJK    EPF         IF NOT FORMAT 2 OR 3
          SBN    2
          PJK    EPF         IF NOT FORMAT 2 OR 3
 EPD10    BSS
          LDK    /RS/K.CMDN  STORAGE DIRECTOR DOWN
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          LOADOVL ERO        LOAD ERROR RECOVERY OVERLAY
          LDN    1           TURN OFF ALL UNITS ON STORAGE DIRECTOR
          UJN    EPE5
*
*         DOWN THE CHANNEL
*
 EPE      BSS
          LDK    /RS/K.CHDN  CHANNEL DOWNED
          STDL   PTF         TO PREVENT RUNNING PATH TEST
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          LOADOVL ERO        LOAD ERROR RECOVERY OVERLAY
          LDN    0           TO TURN OFF CHANNEL
 EPE5     BSS
          RJM    OE          TURN OFF ALL UNITS ON THE EQUIPMENT
 EPE20    BSS
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          LDN    0
          STML   RS+/RS/P.HDWR  CLEAR STATUS WORD
          LDN    6
          STDL   RECOV       CLEAR UNIT LOCK IS NEXT STEP (EPG)
          LDN    F.OPCMP
          RJM    FUNC        ISSUE OPERATION COMPLETE
          UJN    EPG
*
*         DOWN THE UNIT
*
 EPF      BSS
          LOADOVL ERO        LOAD ERROR RECOVERY OVERLAY
          LDN    0           CLEAR THE REQUEST SELECTED FLAG
          STML   SS+/SS/P.ENTRY
          RJM    SAVSS       SAVE THE SS TABLE
          LDK    /RS/K.UDN   UNIT DOWNED
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RDT         READ DEVICE TABLE
          LOADC  P3          ADDRESS OF UNIT INTERFACE TABLE
          RJM    OFFUN       TURN OFF THE UNIT
          UJK    EPE20
*
*         CLEAR THE UNIT LOCK
*
 EPG      BSS
          RJM    WFUL        WAIT FOR UNIT LOCK.  THE PATH TEST DOES
                              NOT SET THE UNIT LOCK
          RJM    CLRLOCK     CLEAR UNIT LOCK
          STML   RS+/RS/P.RTRY  CLEAR REQUEST RETRY COUNTER
          LJM    MAIN5
          SPACE  5,20
** NAME-- FUNC
*
** PURPOSE-- ISSUE FUNCTION TO DISK CONTROLLER.
*
** INPUT-- A REGISTER = FUNCTION CODE.
*
** EXIT
*         - TO CALLING ROUTINE IF NO ERROR.  THE CHANNEL WILL BE
*           ACTIVATED FOR ALL FUNCTIONS EXCEPT 10 AND 100000.
          SPACE  2
 FUN100   BSS
          LDML   FUNCD
          ZJN    FUN110      IF CONNECT FUNCTION
          LPC    77767B
          ZJN    FUNX        IF NO DATA TRANSFER
 FUN110   BSS
          ACN    DC          ACTIVATE THE CHANNEL
 FUNX     LJM    **
 FUNC     EQU    *-1
          DCN    DC+40B      ENSURE THE CHANNEL IS INACTIVE
          FAN    DC          ISSUE THE FUNCTION
          STML   FUNCD       SAVE FUNCTION CODE
          LDN    0           TIMEOUT 128 MS ON READS AND WRITES
          STDL   T1
          STDL   GNSTAT      CLEAR GENERAL STATUS
          LDN    3           TIMEOUT 3 TIMES LONGER FOR ALL OTHERS
          STDL   T2
 FUN10    BSS
          LDN    0
          IJM    FUN100,DC   IF CHANNEL INACTIVE
          SODL   T1
          NJN    FUN10       IF TIMEOUT NOT EXPIRED
          LDML   FUNCD       CHECK FOR A READ OR WRITE
          SBN    F.READ
          ZJN    FUN30       IF ITS A READ, QUIT TIMING
          SBN    F.WRITE-F.READ
          ZJN    FUN30       IF ITS A WRITE, QUIT TIMING
          SBN    F.CONT-F.WRITE
          ZJN    FUN20       IF CONTINUE, QUIT TIMING
          SODL   T2
          NJN    FUN10       GO TIME OUT SOME MORE
 FUN20    BSS
          LDML   FUNCD
          UJN    FUN40
 FUN30    BSS
          LDDL   FT
          ZJN    FUN20       IF FIRST SECTOR
          RJM    GENSTAT     GET GENERAL STATUS
          LDDL   FNC
          ADN    4           TIMEOUT 4 OR 5, NOT 12, FUNCTION
 FUN40    BSS
          STML   RS+/RS/P.FUNTO
          LDK    /RS/K.FTO
          STML   RS+/RS/P.HDWR
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- FMT
*
** PURPOSE-- FORMAT A PORTION OF THE DISK
          SPACE  2
 FMT      CON    0
          LOADOVL FMO        LOAD FORMAT OVERLAY
          RJM    FORMD       FORMAT (NO RETURN)
 FMTR     BSS
          LOADOVL FMO        LOAD FORMAT OVERLAY
          LJM    FORMD20     RETRY THE FORMAT
          SPACE  5,20
** NAME-- GENSTAT
*
** PURPOSE-- READ GENERAL STATUS FROM CONTROLLER.
*
** OUTPUT-- A REGISTER = GENERAL STATUS.
*           GNSTAT = GENERAL STATUS.
          SPACE  2
 GENSX    LJM    **
 GENSTAT  EQU    *-1
          LDN    F.GS        GENERAL STATUS FUNCTION CODE
          RJM    FUNC        ISSUE FUNCTION CODE
          LDN    1
          IAM    GNSTAT,DC   INPUT GENERAL STATUS
          NJN    GENS5       IF INPUT DID NOT COMPLETE
          CFM    GENS8,DC    CHECK AND CLEAR CHANNEL ERROR
          RJM    EFP         ERROR FLAG PROCESSING (NO RETURN)
 GENS5    BSS
          LJM    OUTPK30
 GENS8    BSS
          LDDL   GNSTAT      SAVE GENERAL STATUS
          ZJN    GENS30      IF NO ERRORS
          SBN    2           CHECK 'NOT ON CYLINDER'
          ZJN    GENS30      IF ONLY BUSY
          SBN    6           WAS THE STORAGE DIRECTOR AVAILABLE
          ZJN    GENS30      STORAGE DIRECTOR IS BUSY ELSEWHERE
          RJM    DS          DETAILED STATUS
          LDML   LCF
          ZJN    GENS15      IF NOT CCC LOAD FAILURE (CP MUST ISOLATE ERROR)
          LDN    E09         CCC LOAD FAILURE
          UJN    GENS20
 GENS15   BSS
          LDC    400000B     INDICATE DETAILED STATUS PRESENT
 GENS20   BSS
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
 GENS30   BSS
          LDDL   GNSTAT      A REGISTER = GENERAL STATUS
          UJK    GENSX
          SPACE  5,20
** NAME-- GETUD
*
** PURPOSE-- GET A UNIT REQUEST FROM CM.
*
** OUTPUT-- THE SS TABLE IS FILLED WITH THE NEW UNIT REQUEST.
*
** NOTE-- THIS ONLY SELECTS A REQUEST IF THE QUEUE WAS PREVIOUSLY
*         EMPTY.  IF THE QUEUE IS NOT EMPTY, THE DELINK ROUTINE
*         SELECTS THE NEXT REQUEST.
          SPACE  2
 GETUX    LJM    **
 GETUD    EQU    *-1
          LDDL   DEVL
          ZJN    GETUX       IF NO UNITS
          LDN    0
          STDL   CF          CLEAR CONTINUE FLAG
          STML   SIP         INDICATE SEEK IN PROGRESS
          LDDL   COMLOOK
          STML   UTSAVE      SAVE STARTING POSITION IN TABLE
 GETUD3   BSS
          RJM    UC          UPDATE CLOCK
          LDN    1
          STDL   WC          CONSTANTS FOR CM I/O
          LDN    C.SS
          STDL   P1
          LDDL   EMPTQ
          ZJN    GETUX       NO AVAILABLE EMPTY ENTRIES
          AODL   COMLOOK     GO TO NEXT TABLE ENTRY
          SBD    DEVL
          MJN    GETUD5      IF NOT END OF TABLE
          LDN    0
          STDL   COMLOOK     SET BACK TO FIRST ENTRY
 GETUD5   BSS
          LDDL   EMPTQ
          STDL   LUTLOC      SET AVAILABLE ENTRY UP FOR POSSIBLE USE
          ADN    /LUT/P.UIT-1
          STML   GETUD7
          LOADC  CM.DEV      START LOOKING AT NEXT UNIT
          ADDL   COMLOOK
          CRDL   P2          SAVE UIT ADDRESS IN LUT
          CRML   -**,WC      GET ADDRESS OF UIT
 GETUD7   EQU    *-1
          LDDL   P2          CHECK IF DEVICE IS ACTIVE
          LPN    /CB/K.ACT
          NJK    GETUD80     IF ALREADY ACTIVE - SKIP TO NEXT ONE
          LOADC  P3
          CRDL   T1          FIRST WORD OF UIT
          ADN    /UIT/C.UBUF
          CRDL   T5          SECOND WORD OF UIT
          ADN    /UIT/C.NEXT-/UIT/C.UBUF
          CRDL   T3          SIXTH WORD OF UIT
          LDDL   T5          CHECK FOR A REQUEST
          ADDL   T6
          ZJK    GETUD80     NO REQUEST, GO TO NEXT ONE
          LDDL   T1+/UIT/P.DSABLE  CHECK IF UNIT IS DISABLED
          SHN    2+/UIT/L.DSABLE
          MJK    GETUD80     IF UNIT IS DISABLED
          LDIL   LUTLOC      REMOVE ENTRY FROM EMPTY QUEUE
          STDL   EMPTQ
          LDDL   USEQ        PLACE ENTRY ON 'IN USE' QUEUE
          STIL   LUTLOC
          LDDL   LUTLOC
          STDL   USEQ
          LDDL   COMLOOK
          STML   /LUT/P.OFFSET,LUTLOC  SAVE INDEX TO CM.DEV TABLE
          LDDL   P2
          LPC    177776B
          LMN    /CB/K.ACT
          STDL   P2          SET ACTIVE BIT IN THE CM.DEV TABLE
          LOADC  CM.DEV
          ADDL   COMLOOK
          CWDL   P2
          RJM    SETLOCK     LOCK THE UNIT
          ZJN    GETUD80     CANNOT LOCK, OTHER DRIVER HAS IT
          LOADF  T7
          CRML   SS,P1       READ SS TABLE
          LDML   SS+/SS/P.ENTRY
          NJN    GETUD40     IF ALREADY SELECTED, GO ON TO NEXT
          RJM    SQLOCK      SET QUEUE LOCKWORD
          NJN    GETUD80     IF QUEUE NOT LOCKED
          RJM    SELRQ       SELECT A REQUEST ON THIS UNIT
          UJN    GETUD80
 GETUD40  BSS
          RJM    USC         UPDATE SAVED CLOCK
 GETUD80  BSS
          LDDL   COMLOOK     CHECK IF LOOKED AT ALL ENTRIES
          SBML   UTSAVE
          NJK    GETUD3      IF NO
          UJK    GETUX       EXIT
          SPACE  5,20
** NAME-- IN
*
** PURPOSE-- INPUT WORDS FROM THE CHANNEL
*
** ENTRY
*         A = WORDS TO INPUT
*         IN10 = LOCATION TO BE PLUGGED WITH ADDRESS TO STORE DATA
          SPACE  2
 INX      LJM    **
 IN       EQU    *-1
          IAM    *,DC
 IN10     EQU    *-1
          ZJN    INX         IF NO ERROR
          LJM    OUTPK20
          SPACE  5,20
** NAME-- INPK
*
** PURPOSE-- INPUT AND PACK WORDS FROM THE CHANNEL
*
** ENTRY
*         A = WORDS TO INPUT
*         INPK10 = LOCATION TO BE PLUGGED WITH ADDRESS TO STORE DATA
          SPACE  2
 INPKX    LJM    **
 INPK     EQU    *-1
          IAPM   *,DC
 INPK10   EQU    *-1
          ZJN    INPKX       IF NO ERROR
          LJM    OUTPK20
          SPACE  5,20
** NAME-- INTERR
*
** PURPOSE-- REPORT AN INTERFACE ERROR
          SPACE  2
 INTERR   CON    0
          STML   RS+/RS/P.IEC  INTERFACE ERROR CODE
          LDN    E01         INTERFACE ERROR
          STML   RS+/RS/P.EC
          LDN    0           CLEAR WORDS SO CP REPORTS CORRECT ERROR
          STML   RS+/RS/P.GENST1
          STML   RS+/RS/P.ID
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          RJM    HANG
          SPACE  5,20
** NAME-- INTRS
*
** PURPOSE-- SEND INTERMEDIATE RESPONSE.
          SPACE  2
 INTRSX   LJM    **
 INTRS    EQU    *-1
          LDN    0
          STML   RS+/RS/P.SHORT   INDICATE ERROR RESPONSE
          LDK    C.RS*8
          STML   RS+/RS/P.RESPL  RESPONSE LENGTH
          LDDL   CTF
          NJN    INTRS10     IF REQUEST EXISTS
          RJM    SNMSG       SEND UNSOLICITED MESSAGE
          RJM    RESPIN      UPDATE IN POINTER FOR RESPONSE BUFFER
          UJK    INTRSX
 INTRS10  BSS
          LDK    R.INT*0#4000  INTERMEDIATE RESPONSE
          STML   RS+/RS/P.RC
          RJM    TERMP       SEND RESPONSE TO CM
          UJK    INTRSX
          SPACE  5,20
** NAME-- LOCK
*
** PURPOSE-- SET THE LOCKWORD
*
** ENTRY
*         P6 = RMA OFFSET
*         T5 = OFFSET TO LOCKWORD FROM RMA
*
** EXIT
*         A = 0 IF LOCK SUCCESSFULLY SET
          SPACE  2
 LOCKX    LJM    **
 LOCK     EQU    *-1
 LOCK1    BSS
          LCN    0
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,P6        TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

          LDDL   T1
          ZJN    LOCK5       IF LOCK COULD BE SET
          ADDL   T2
          ADC    -177777B-177777B
          ZJN    LOCK1       IF INTERMEDIATE VALUE
          LDDL   T2
          LPC    77777B
          ADC    100000B
          STDL   T2          SET THE VE BIT
          LDDL   T6
          LMC    400000B
          CWDL   T1          RESTORE THE LOCKWORD WITH THE VE BIT
          LDDL   T4
          SBDL   PPNO
          NJN    LOCK3       IF LOCK COULD NOT BE SET
          LDDL   T1
          ADC    -100000B
 LOCK3    BSS
          UJK    LOCKX       IF LOCK WAS ALREADY SET, EXIT A = 0
                             IF LOCK COULD NOT BE SET, EXIT A .NE. 0
 LOCK5    BSS
          LDC    100000B
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          LDDL   PPNO
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          SET THE LOCKWORD
          LDN    0
          UJK    LOCKX
          SPACE  5,20
** NAME-- OUT
*
** PURPOSE-- OUTPUT WORDS FROM THE PP TO THE CCC
*
** ENTRY
*         A = NUMBER OF WORDS TO OUTPUT
*         OUT10 = LOCATION TO BE PLUGGED WITH ADDRESS TO OUTPUT FROM
*
** EXIT   TO CALLING ROUTINE IF NO ERROR
          SPACE  2
 OUTX     LJM    **
 OUT      EQU    *-1
          STDL   T2          SAVE WORD COUNT
*
*         THIS TIMEOUT LOOP PREVENTS THE PP FROM HANGING ON AN ISI CHANNEL
*
          LCN    0
 OUT4     BSS
          EJM    OUT8,DC     IF CHANNEL EMPTY
          SBN    1
          NJN    OUT4        IF TIMEOUT NOT EXPIRED
          UJN    OUTPK40
 OUT8     BSS
          LDDL   T2
          OAM    *,DC        OUTPUT WORDS
 OUT10    EQU    *-1
          ZJN    OUTX        IF NO ERROR
          UJN    OUTPK20
          SPACE  5,20
** NAME-- OUTPK
*
** PURPOSE-- OUTPUT PACKED DATA TO THE CHANNEL
*
** ENTRY
*         A = NUMBER OF WORDS TO OUTPUT
*         OUTPK10 = LOCATION TO BE PLUGGED WITH ADDRESS TO OUTPUT FROM
*
** EXIT   TO CALLING ROUTINE IF NO ERROR
          SPACE  2
 OUTPKX   LJM    **
 OUTPK    EQU    *-1
          OAPM   *,DC        OUTPUT WORDS
 OUTPK10  EQU    *-1
          ZJN    OUTPKX      IF NO ERROR
 OUTPK20  BSS
          STDL   T4          WORDS NOT TRANSFERRED
          RJM    GENSTAT     GET GENERAL STATUS
          LDDL   T4
 OUTPK30  BSS
          STML   RS+/RS/P.FUNTO  WORDS NOT TRANSFERRED
 OUTPK40  BSS
          LDN    E05         INCOMPLETE CHANNEL TRANSFER
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- PCER
*
** PURPOSE-- PREPARE COMMON ERROR RESPONSE
*
** ENTRY
*         A = ERROR CODE FOR LOCATION /RS/P.EC
*         COMLOOK = INDEX TO DEVICE TABLE
          SPACE  2
 PCER     CON    0
          RJM    PER         PREPARE ERROR RESPONSE
          RJM    EP          ERROR PROCESSING (NO RETURN)
          SPACE  5,20
** NAME-- PER
*
** PURPOSE-- PREPARE ERROR RESPONSE
*
** ENTRY
*         A = ERROR CODE FOR LOCATION ERRID
*         A = NEGATIVE VALUE IF DETAILED STATUS PRESENT
*         COMLOOK = INDEX TO DEVICE TABLE
          SPACE  2
 PERX     LJM    **
 PER      EQU    *-1
          STML   RS+/RS/P.EC  SAVE ERROR CODE
          MJN    PER3        IF DETAILED STATUS PRESENT
          LDN    0
          STML   RS+/RS/P.DET  CLEAR DETAILED STATUS PRESENT FLAG
 PER3     BSS
          LDDL   GNSTAT      SAVE GENERAL STATUS
          STML   RS+/RS/P.GENST1
          STML   RS+/RS/P.GENST2
          RJM    RDT         READ DEVICE TABLE
          LDDL   CTF
          ZJN    PER5        IF CONFIDENCE TEST FAILURE
          LDDL   P2          FIRST WORD OF DEVICE TABLE
          SHN    -1
          LPN    3
          NJN    PER10       IF NOT CONFIDENCE TEST FAILURE
 PER5     BSS
          STML   RS+/RS/P.STRK  STARTING TRACK
          STML   RS+/RS/P.SSEC  STARTING SECTOR
          LDC    MAXCYL-1
          UJN    PER11
 PER10    BSS
          LDN    1
          STDL   T2
          LDML   SIP
          NJN    PER13       IF SEEK COMPLETE
          RJM    SRESP       PUT PVA IN RESPONSE
          LDDL   FNC
          SBN    2
          NJN    PER12       IF NOT FORMAT
          STML   RS+/RS/P.STRK  STARTING TRACK
          STML   RS+/RS/P.SSEC  STARTING SECTOR
          LDML   FBUF
 PER11    BSS
          STML   RS+/RS/P.SCYL  STARTING CYLINDER
          UJN    PER20
 PER12    BSS
          LOADF  SS+/SS/P.REQ  RMA OF CURRENT REQUEST
          UJN    PER16
 PER13    BSS
          LOADF  CURRQ       RMA OF CURRENT REQUEST
 PER16    BSS
          ADN    3
          CRML   RS+/RS/P.CHAN,T2  SAVE CYLINDER, TRACK AND SECTOR
          LDDL   CHAN
          STML   RS+/RS/P.CHAN  SAVE CHANNEL NUMBER
 PER20    BSS
          LDML   RS+/RS/P.DET
          NJN    PER30       IF DETAILED STATUS VALID
          STDL   T1
 PER25    BSS
          LDN    0
          STML   RS+/RS/P.DETAIL,T1
          AODL   T1
          LMN    40
          NJN    PER25       IF MORE WORDS TO CLEAR
 PER30    BSS
          LOADC  P3          REFORMATTED RMA OF UIT
          CRDL   T1          FIRST WORD OF UNIT INTERFACE TABLE
          ADN    1
          CRDL   T2          SECOND WORD OF UIT
          LDDL   T1
          STML   RS+/RS/P.LU  LOGICAL UNIT
          LOADF  T4          RMA OF UNIT COMMUNICATIONS BUFFER
          CRDL   T1          FIRST WORD OF SS TABLE
          LDDL   T1
          STML   RS+/RS/P.UNIT  PHYSICAL UNIT NUMBER
          LDML   SS+/SS/P.TRACK
          LPN    77B
          STML   RS+/RS/P.FTRK  FAILING TRACK
          LDML   SS+/SS/P.SECTOR
          STML   RS+/RS/P.FSEC  FAILING SECTOR
          LDN    0
          STML   RS+/RS/P.ID  CLEAR ERROR ID
          LDML   RS+/RS/P.EC
          ZJN    PER40       IF ERROR CODE ZERO
          SBN    E05
          ZJN    PER50       IF WORD COUNT STORED
          LDN    0
          UJN    PER45
 PER40    BSS
          LDML   RS+/RS/P.HDWR
          LPC    /RS/K.FTO
          NJN    PER50       IF FUNCTION IS SAVED
 PER45    BSS
          STML   RS+/RS/P.FUNTO  CLEAR FUNCTION OR WORD COUNT
 PER50    BSS
          LJM    PERX
          SPACE  5,20
** NAME-- PDR
*
** PURPOSE-- PREPARE NORMAL DISK RESPONSE
          SPACE  2
 PDRX     LJM    **
 PDR      EQU    *-1
          LDN    0
          STML   RS+/RS/P.HDWR  ABNORMAL STATUS
          LDN    8           SET RESPONSE LENGTH FOR NORMAL RESPONSE
          STML   RS+/RS/P.RESPL
          LDML   RQ+/RQ/P.LU  LOGICAL UNIT
          LPC    0#FF
          LMC    /RS/K.SHORT  INDICATE ONE-WORD RESPONSE
          STML   RS+/RS/P.SHORT
          UJK    PDRX
          SPACE  5,20
** NAME-- POLLON
*
** PURPOSE-- THIS ROUTINE POLLS UNITS FOR ON-CYLINDER
*
** INPUT-- IN USE QUEUE (USEQ)
*
** OUTPUT-- A REGISTER = 0, IF NOTHING WAS ON CYLINDER
*
*         POLLON SCANS THE 'IN USE' QUEUE TWICE.  FIRST IT LOOKS AT
*         ENTRIES FOR WHICH THE UNIT IS ALREADY LOCKED TO THIS
*         PP (P.OWNER=1).  IF NONE OF THESE HAVE COMPLETED SEEKS
*         PENDING, ANOTHER SCAN IS MADE, THIS TIME LOOKING AT UNITS
*         THAT ARE NOT YET LOCKED.
          SPACE  2
 POLLX    LJM    **
 POLLON   EQU    *-1
          LDN    C.SS
          STDL   WC
          LDN    /LUT/K.OWNER
 POLL2    BSS
          STDL   TOGL        SET TOGL TO MATCH P.OWNER = 1
          LDN    USEQ
 POLL4    BSS
          STDL   LUTLOC      SET TO BEGINNING OF 'IN USE' QUEUE (-1)
 POLL6    BSS
          RJM    UC          UPDATE CLOCK
          LDDL   LUTLOC
          STDL   P1          SAVE POINTER TO PREVIOUS ENTRY
          LDIL   LUTLOC
          STDL   LUTLOC      GET NEXT ENTRY ON QUEUE
          NJN    POLL8       IF ENTRY EXISTS
          LDDL   TOGL
          ZJN    POLLX       IF SECOND PASS JUST FINISHED, EXIT
          LDN    0           SET TOGL FOR NEXT PASS
          UJN    POLL2
 POLL8    BSS
          LDML   /LUT/P.OWNER,LUTLOC
          SBDL   TOGL
          NJN    POLL6       IF THIS PASS DOESN'T LOOK AT THIS ENTRY
          LDDL   TOGL
          NJN    POLL10      IF UNIT ALREADY LOCKED
          RJM    SETLOCK     TRY TO LOCK THE UNIT
          ZJN    POLL6       IF LOCK COULD NOT BE SET
 POLL10   BSS
          LOADR  /LUT/P.UIT,LUTLOC  ADDRESS OF UIT
          ADN    /UIT/C.UBUF
          CRDL   P2          SECOND WORD OF UIT
          LOADF  P4          ADDRESS OF UNIT COMMUNICATION BUFFER
          CRML   SS,WC       READ SS ENTRY
          LDML   SS+/SS/P.ENTRY  HAS AN ENTRY BEEN SELECTED
          NJK    POLL25      IF REQUEST SELECTED
          LOADR  SS+/SS/P.UQT  ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T1
          ADN    /UIT/C.NEXT  OFFSET TO RMA OF DISK REQUEST
          CRDL   T3
          LDDL   T2
          SHN    2+/UIT/L.DSABLE
          MJN    POLL13      IF UNIT DISABLED
          LDDL   T5
          ADDL   T6
          NJN    POLL15      IF REQUEST PRESENT
*
*         CLEARING THE UNIT LOCK WITHOUT SELECTING A REQUEST COULD
*         CAUSE AN INFINITE LOOP IF TWO CHANNELS ARE SHARING THE UNIT.
*
 POLL13   BSS
          RJM    CLRLOCK     CLEAR UNIT LOCK
 POLL15   BSS
          LDIL   LUTLOC
          STIL   P1          REMOVE LUT ENTRY FROM 'IN USE' QUEUE
          LCN    0
          STDL   T2
          STDL   T3
          STDL   T4
          LMN    /CB/K.ACT
          STDL   T1
          LOADC  CM.DEV
          ADML   /LUT/P.OFFSET,LUTLOC
          RDCL   T1          CLEAR ACTIVE BIT IN CM.DEV TABLE
          LDDL   EMPTQ
          STIL   LUTLOC
          LDDL   LUTLOC
          STDL   EMPTQ       PUT LUT ENTRY ON THE EMPTY QUEUE
          LDDL   P1
          LJM    POLL4       GO TO NEXT ENTRY
 POLL25   BSS
          RJM    USC         UPDATE SAVED CLOCK
          LDML   /LUT/P.OFFSET,LUTLOC
          STDL   COMLOOK     INDEX TO DEVICE TABLE
          RJM    SEEKCK      ISSUE A SEEK FOR POLLING
          ZJN    POLL30      IF A SEEK HAS FINISHED
          LDDL   CLSEC
          SBML   SS+/SS/P.CLKST
          PJN    POLL27      IF CLOCK HASN'T WRAPPED
          ADC    0#10000
 POLL27   BSS
          SBN    10          10 SECOND MINIMUM TIMEOUT
          MJK    POLL28      IF NO TIMEOUT
          LDN    E08         SEEK OR FORMAT COMMAND TIMEOUT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
 POLL28   BSS
          LDN    F.OPCMP
          RJM    FUNC
          UJK    POLL6
 POLL30   BSS
          RJM    POLS        POLL SUBROUTINE
*
*         PUT LUTLOC AT END OF USEQ.  THIS HELPS KEEP USAGE OF UNITS
*         RANDOM.
*
          LDIL   LUTLOC
          ZJN    POLL50      IF ALREADY LAST ENTRY OF USEQ
          STIL   P1          REMOVE ENTRY FROM USEQ
 POLL40   BSS
          STDL   P1
          LDIL   P1
          NJN    POLL40      IF NOT END OF QUEUE
          STIL   LUTLOC
 POLL50   BSS
          LDDL   LUTLOC
          STIL   P1          ADD LUTLOC TO END OF USEQ
          UJK    POLLX
          SPACE  5,20
** NAME-- POLS
*
** PURPOSE-- POLL SUBROUTINE.  RELEASE UNIT LOCK ON OTHER UNITS.
          SPACE  2
 POLS40   BSS
          LDDL   P2
          STDL   LUTLOC      RESTORE POINTER TO CURRENT REQUEST
 POLSX    LJM    **
 POLS     EQU    *-1
          RJM    SAVSS
          LDDL   LUTLOC
          STDL   P2          SAVE LUT POINTER
          LDN    USEQ
          STDL   LUTLOC      RESET TO BEGINNING OF QUEUE
          STML   SIP         INDICATE SEEK COMPLETE
 POLS10   BSS
          LDIL   LUTLOC
          ZJK    POLS40      IF END OF QUEUE
          STDL   LUTLOC
          SBDL   P2          IS THIS ENTRY THE CURRENT ONE
          ZJN    POLS10      IF YES, DON'T RELEASE THE LOCK
          LDML   /LUT/P.OWNER,LUTLOC  IS ENTRY LOCKED TO THIS PP
          ZJN    POLS10      IF UNLOCKED
          LOADR  /LUT/P.UIT,LUTLOC  ADDRESS OF UIT
          ADN    /UIT/C.UBUF
          CRDL   P3          ADDRESS OF COMMUNICATIONS BUFFER
          LOADF  P5          ADDRESS OF SS TABLE
          STDL   T1
          ADN    /SS/C.CLKST
          CRDL   T2          READ CLOCK FROM SS TABLE
          LDDL   T2
          STDL   T6          SAVE SECONDS PORTION OF CLOCK START
          LDDL   CLMLS       UPDATE SEEK TIME SO TIMEOUT WILL BE
          STDL   T5           MORE ACCURATE
 POLS15   BSS
          SBDL   T3          CLOCK START TIME
          PJN    POLS20      IF CLOCK HASN'T WRAPPED
          AODL   T6
          LDC    1000        MILLISECONDS PER SECOND
          RADL   T5
          UJN    POLS15
 POLS20   BSS
          STDL   T5          SAVE SEEK TIME (MILLISECONDS)
          LDDL   CLSEC
          SBDL   T6          CLOCK START TIME
          PJN    POLS30      IF CLOCK HASN'T WRAPPED
          ADC    0#10000
 POLS30   BSS
          STDL   T4          SAVE SEEK TIME (SECONDS)
          LDDL   T1
          ADC    400000B+/SS/C.CLKST
          CWDL   T2          SAVE CLOCK AND SEEK TIME IN SS TABLE
          RJM    CLRLOCK     CLEAR THE LOCK
          UJK    POLS10      GO LOOK AT THE NEXT ONE
          SPACE  5,20
** NAME-- PPREQ
*
** PURPOSE-- CHECK FOR ANY PP REQUESTS
          SPACE  2
 PPRQX    LJM    **
 PPREQ    EQU    *-1
          LCN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDC    0#7FFF      CLEAR ACTIVE CHECK BIT
          STDL   T4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          RDCL   T1          CLEAR ACTIVE BIT, READ IDLE/RESUME BITS
          LDDL   T4
          LPC    0#6000
          ZJN    PPRQX       IF NOT IDLE OR RESUME
          STDL   T5
          LOADOVL ERO        LOAD ERROR RECOVERY OVERLAY
          RJM    SPLOCK      SET PP TABLE LOCK
          RJM    PIR         PROCESS IDLE OR RESUME COMMAND (NO RETURN)
          SPACE  5,20
** NAME-- RDT
*
** PURPOSE-- READ DEVICE TABLE
          SPACE  2
 RDTX     LJM    **
 RDT      EQU    *-1
          LOADC  CM.DEV      ADDRESS OF DEVICE TABLE
          ADDL   COMLOOK     INDEX INTO TABLE
          CRDL   P2
          LDDL   P2
          UJN    RDTX
 F        IFEQ   CHANTYP,1
          SPACE  5,20
** NAME-- RES
*
** PURPOSE-- READ ERROR STATUS REGISTER OF CIO CHANNEL.
*
** EXIT-- A = STATUS REGISTER READ, OTHERWISE ZERO
*
** NOTE-- THIS ROUTINE MUST BE RESIDENT DUE TO CHANNEL INSTRUCTIONS
          SPACE  2
 RESX     LJM    **
 RES      EQU    *-1
          DCN    DC+40B      ENSURE THE CHANNEL IS INACTIVE
          LDC    F.RDESR     READ ERROR STATUS REGISTER FUNCTION
          FAN    DC
          LCN    0
 RES10    BSS
          IJM    RES25,DC    IF FUNCTION REPLY RECEIVED
          SBN    1
          NJN    RES10       IF TIMEOUT NOT EXPIRED
 RES20    BSS
          LDN    0
          UJN    RESX
 RES25    BSS
          LDN    1
          ACN    DC
          IAM    T1,DC       INPUT THE STATUS
          SFM    RES20,DC    IF ERROR
          NJN    RES20       IF ERROR
          LDDL   T1
          UJK    RESX
 F        ENDIF
          SPACE  5,20
** NAME-- RESP
*
** PURPOSE-- WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
*
** INPUT-- CM.PIT, CM.RS, LIM, /PIT/IN, /PIT/OUT, RS+/RS/P.RESPL
*
** OUTPUT-- /PIT/IN, RESPONSE BUFFER
          SPACE  2
 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  2
 RESPX    LJM    **
 RESP     EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDN    0
          STML   STORS       SET FLAG TO STORE RESPONSE
          LDML   CM+/CM/P.STOR  CHECK IF CALLER WANTS RESPONSE
          SHN    /CM/L.STOR+2
          MJN    RESP10      IF STORE RESPONSE FLAG IS SET
          LDML   RS+/RS/P.SHORT
          SHN    /RS/L.SHORT+2
          PJN    RESP10      IF NOT NORMAL RESPONSE, STORE RESPONSE
          AOML   STORS       NONZERO MEANS DO NOT STORE RESPONSE
          UJK    RESPX

* READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RESP10   BSS
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF 'IN' POINTER
          CRDL   P1          READ 'IN' POINTER

* CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDN    0
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE
          LDDL   INP
          SBDL   OUTP
          MJN    RESP20      IF IN .LT. OUT
          LDML   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP
 RESP20   LDML   RS+/RS/P.RESPL  GET RESPONSE LENGTH
          ADDL   INP
          STDL   INPNT       IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          MJN    RESP30      IF ROOM IN BUFFER
          RJM    PPREQ       CHECK FOR IDLE REQUEST
          UJK    RESP10
 RESP30   BSS
          LDDL   INP
          SHN    -3
          STDL   T3          'IN' POINTER IN WORDS
          LDML   RS+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          LDDL   INPNT
          SBML   LIM
          MJN    RESP50      IF IN + RESPONSE LENGTH .LT. LIMIT
                             ONLY 1 BLOCK WRITE
          STDL   INPNT       IN + RESPONSE LENGTH - LIMIT = NEW 'IN' POINTER
          SHN    -3
          STDL   T5          NUMBER OF WORDS IN 2ND BLOCK WRITE

* WRITE RESPONSE TO CM.

          LDML   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADC    RS
          STML   RESP60      RESPONSE ADDRESS FOR 2ND BLOCK WRITE
 RESP50   BSS
          LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD 'IN' OFFSET
          CWML   RS,T4       WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          ZJN    RESP70      IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          LMC    400000B
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
                             (BEGINNING OF RESPONSE BUFFER)
 RESP60   EQU    *-1

 RESP70   BSS
          LJM    RESPX
          SPACE  5,20
** NAME-- RESPIN
*
** PURPOSE-- UPDATE THE 'IN' POINTER IN THE CM RESPONSE BUFFER.
*
** INPUT-- INPNT = NEW 'IN' POINTER.
          SPACE  2
 RESNX    LJM    **
 RESPIN   EQU    *-1

* CHECK IF RESPONSE SHOULD BE SENT TO CM.

          LDML   STORS       CHECK IF CALLER WANTS RESPONSE
          NJK    RESNX       IF NO RESPONSE WAS SENT

* UPDATE THE 'IN' POINTER.

          LDN    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDDL   INPNT       NEW 'IN' POINTER
          STDL   P4
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   P1          WRITE NEW 'IN' POINTER TO CM

* INTERRUPT PROCESSOR. SETRQ ROUTINE SETS UP THIS INSTRUCTION.
          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   PPNO-3      SET LAST BYTE NONZERO
 INTPRC   INPN   1           INTERRUPT OR PSN
          UJK    RESNX
          SPACE  5,20
** NAME-- SAVSS
*
** PURPOSE-- WRITE THE SS ENTRY TO THE COMMUNICATION BUFFER
*            IN THE UNIT INTERFACE TABLE.
*
** INPUT-- SS TABLE WHICH IDENTIFIES THE UNIT TABLE.
          SPACE  2
 SAVX     LJM    **
 SAVSS    EQU    *-1
          LDN    C.SS        NUMBER OF WORDS TO WRITE
          STDL   WC
          RJM    EXLOD       GET ADDRESS OF COMMUNICATION BUFFER
          ADN    /CB/C.SS    ADDRESS OF SS TABLE
          CWML   SS,WC       WRITE SS ENTRY TO PP COMM. BUFFER
          LOADR  SS+/SS/P.COM
          CWML   SS,WC       WRITE SS ENTRY TO UNIT COMM. BUFFER
          UJK    SAVX
          SPACE  5,20
** NAME-- SC
*
** PURPOSE-- SAVE CLOCK IN SS TABLE.  IT IS USED FOR TIMING OUT SEEK
*            COMMANDS
          SPACE  2
 SCX      LJM    **
 SC       EQU    *-1
          LDDL   CLSEC       SAVE CLOCK START TIME
          STML   SS+/SS/P.CLKST
          LDDL   CLMLS
          STML   SS+/SS/P.CLKST+1
          LDDL   PPNO        SAVE PP THAT DID LAST TIMING
          STML   SS+/SS/P.LPP
          LDN    0           CLEAR SEEK TIME
          STML   SS+/SS/P.SEEKTM
          STML   SS+/SS/P.SEEKTM+1
          UJN    SCX
          SPACE  5,20
** NAME-- SCLOCK
*
** PURPOSE-- SETS THE CHANNEL LOCK.
*
** EXIT--  A = 0 WITH CHANNEL LOCK SET
          SPACE  2
 SCLX     LJM    **
 SCLOCK   EQU    *-1
 SCL30    BSS
          LDC    CM.CHAN     CM ADDRESS OF CHANNEL INTERLOCK TABLE
          STDL   P6
          LDDL   CHAN        CHANNEL NUMBER IS OFFSET IN TABLE
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJN    SCL30       IF LOCK WAS NOT SET
          STML   CHLOCK      INDICATE CHANNEL LOCK SET
          UJK    SCLX        EXIT, LOCK WAS SET
          SPACE  5,20
** NAME-- SEEKCK
*
** PURPOSE-- ISSUE A SEEK
          SPACE  2
 SEEX     LJM    **
 SEEKCK   EQU    *-1
          LDN    F.SEEK
          RJM    FUNC        ISSUE THE SEEK
 SEEK10   EQU    *-1         FOR FORCING ERRORS
          LDN    0
          STDL   CA          DON'T ALLOW CONTINUE FUNCTION
          STDL   FT          FIRST TIME FLAG
          LDN    4
          OAM    SS+/SS/P.UNIT,DC  SEND SEEK FUNCTION PARAMETERS
          ZJN    SEEK20      IF NO ERROR
          LJM    OUTPK20
 SEEK20   BSS
          RJM    DCN         DISCONNECT THE CHANNEL
          RJM    GENSTAT     READ GENERAL STATUS
          UJN    SEEX
          SPACE  5,20
** NAME-- SEEKON
*
** PURPOSE-- ISSUE SEEK, CHECK FOR ERRORS, WAIT FOR ON-CYLINDER.
          SPACE  2
 SEKOX    LJM    **
 SEEKON   EQU    *-1
          LDDL   CLSEC
          STML   SS+/SS/P.CLKST
 SEK015   BSS
          RJM    SEEKCK      ISSUE SEEK AND RECOVER SEEK ERRORS
          ZJN    SEKOX       IF ON CYLINDER
          RJM    UC          UPDATE CLOCK
          LDDL   CLSEC
          SBML   SS+/SS/P.CLKST
          PJN    SEK020      IF CLOCK HASN'T WRAPPED
          ADC    0#10000
 SEK020   BSS
          SBN    5
          MJN    SEK015      IF TIMEOUT NOT EXPIRED
          LDN    E08         SEEK TIMEOUT
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- SELRQ.
*
** PURPOSE-- SELECTS THE FIRST REQUEST IN THE CHAIN FOR THE
*            CURRENT REQUEST.
*
** INPUTS-- SS+P.UQT = POINTER TO UNIT QUEUE TABLE.
*
** OUTPUTS-- RQ = CURRENT REQUEST.
*            SS+/SS/P.REQ
*            SS+/SS/P.CYL
*            SS+/SS/P.TRACK
*            SS+/SS/P.SECTOR
*            SS+/SS/M.CUR
*            SS+/SS/M.WRITE
*
** NOTE-- ASSUMES UNIT QUEUE LOCK HAS BEEN SET.
          SPACE  2
 SELRQX   BSS
          RJM    CQLOCK      CLEAR QUEUE LOCK
 SELRQ10  BSS
          RJM    SAVSS       SVE SHARED TABLE
          LJM    **
 SELRQ    EQU    *-1

* READ RMA OF NEXT REQUEST FROM UNIT QUEUE.
* SET CURRENT REQUEST = FIRST REQUEST IN QUEUE.

          LDN    2
          STDL   WC
          LOADR  SS+/SS/P.UQT  LOAD CM ADDRESS OF UIT
          ADN    /UIT/C.NEXTPV
          CRML   T1,WC       READ RMA OF FIRST REQUEST IN CHAIN
          LDDL   T7
          STML   SS+/SS/P.REQ  SET RMA OF CURRENT REQUEST
          LDDL   T8
          STML   SS+/SS/P.REQ+1
          ADDL   T7
          ZJK    SELRQX      IF QUEUE EMPTY
          LDDL   T2          SET PVA OF CURRENT REQUEST
          STML   SS+/SS/P.PVA
          LDDL   T3
          STML   SS+/SS/P.PVA+1
          LDDL   T4
          STML   SS+/SS/P.PVA+2
          RJM    CQLOCK      CLEAR QUEUE LOCK
          LDML   SS+/SS/P.UQT  SET DELINK POINTER TO BEGINNING OF QUEUE
          STML   SS+/SS/P.DP
          LDML   SS+/SS/P.UQT+1
          STML   SS+/SS/P.DP+1
          LDM    SS+/SS/P.UQT+2
          ADN    /UIT/C.NEXTPV  PVA IN UNIT INTERFACE TABLE
          STML   SS+/SS/P.DP+2
          RJM    SSA         SET SEEK ADDRESS
          LDK    /SS/K.ENTRY
          STML   SS+/SS/P.ENTRY  SET CURRENT REQUEST IN SS
          UJK    SELRQ10
          SPACE  5,20
** NAME-- SETADD
*
** PURPOSE-- SET STARTING DISK ADDRESS IN RESPONSE BUFFER.
          SPACE  2
 SETADDX  LJM    **
 SETADD   EQU    *-1
          LDML   SS+/SS/P.UNIT  UNIT NUMBER
          STML   RS+/RS/P.UNIT

* PUT STARTING ADDRESS IN RESPONSE BUFFER.

          LDML   SS+/SS/P.CYL  STARTING CYLINDER ADDRESS
          STML   RS+/RS/P.SCYL
          LDML   SS+/SS/P.TRACK  TRACK
          LPN    77B
          STML   RS+/RS/P.STRK
          LDML   SS+/SS/P.SECTOR  SECTOR
          STML   RS+/RS/P.SSEC
          UJK    SETADDX
          SPACE  5,20
** NAME-- SETLOCK
*
** PURPOSE-- SETS THE UNIT LOCK IN THE UNIT INTERFACE TABLE.
*
** INPUT-- SS TABLE WHICH IDENTIFIES THE UNIT TABLE.
*
** EXIT-- A REGISTER  .NE. 0  IF LOCK WAS SUCCESSFULLY SET.
*                     .EQ. 0  IF LOCK COULD NOT BE SET.
          SPACE  2
 SETL20   BSS
          LDN    0
          STML   /LUT/P.OWNER,LUTLOC  INDICATE LOCK NOT SET
 SETLX    LJM    **
 SETLOCK  EQU    *-1
          LDDL   LUTLOC
          ADN    /LUT/P.UIT    UNIT INTERFACE TABLE ADDRESS
          STDL   P6
          LDN    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          NJK    SETL20      IF LOCK COULD NOT BE SET
          LDN    /LUT/K.OWNER
          STML   /LUT/P.OWNER,LUTLOC  INDICATE LOCK SET
          UJK    SETLX
          SPACE  5,20
** NAME-- SMA
*
** PURPOSE-- SLAVE MESSAGE A.  TELL MASTER THAT THE SLAVE DETECTED
*            AN A REGISTER NONZERO ERROR.
          SPACE  2
 SMA      BSS
          LDN    C.AREG      A REGISTER NONZER ERROR
          UJN    SMB10
          SPACE  5,20
** NAME-- SMB
*
** PURPOSE-- SLAVE MESSAGE B.  TELL THE MASTER THAT THE SLAVE DETECTED
*            THE ERROR FLAG SET.
          SPACE  2
 SMB      BSS
          LDN    C.CPE       CHANNEL PARITY ERROR
 SMB10    BSS
          RJM    RWEP        READ WRITE ERROR PROCESSING (NO RETURN)




          SPACE  5,20
** NAME-- SNDRSP
*
** PURPOSE-- SEND THE RESPONSE TO CM.
*            USED WHEN SWITCHING TO THE NEXT REQUEST.
          SPACE  2
 SNDX     LJM    **
 SNDRSP   EQU    *-1
          RJM    RESP        SEND RESPONSE TO CM
          RJM    RESPIN      UPDATE -IN- POINTER IN RESPONSE BUFFER
          RJM    SRESP       SET UP RESPONSE BUFFER
          UJK    SNDX
          SPACE  5,20
** NAME-- SNMSG
*
** PURPOSE-- SEND UNSOLICITED MESSAGE
          SPACE  2
 SNMSGX   LJM    **
 SNMSG    EQU    *-1
          LDN    0
          STML   RS+/RS/P.SHORT  INDICATE ERROR RESPONSE
          LDC    C.RS*8
          STML   RS+/RS/P.RESPL
          LDN    R.UNS
          STML   RS+/RS/P.RC  UNSOLICITED RESPONSE CODE
          RJM    RESP        SEND RESPONSE TO CM
          UJK    SNMSGX
          SPACE  5,20
** NAME-- SPLOCK
*
** PURPOSE-- SETS THE PP TABLE LOCK IN THE
*            PP INTERFACE TABLE.
          SPACE  2
 SPLX     LJM    **
 SPLOCK   EQU    *-1
 SPLOCK4  BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          LDN    1
          STDL   T4
          LOADC  CM.PIT      CM ADDRESS OF PP INTERFACE TABLE
          RDSL   T1          ATTEMPT TO SET PP TABLE LOCK
          LDDL   T4
          LPN    1
          ZJK    SPLX        IF LOCK SET
          UJK    SPLOCK4
          SPACE  5,20
** NAME-- SQLOCK
*
** PURPOSE-- SETS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
*
** INPUT-- SS TABLE WHICH IDENTIFIES THE UNIT TABLE.
*
** EXIT-- A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  2
 SQLX     LJM    **
 SQLOCK   EQU    *-1
          LDDL   LUTLOC
          ADN    /LUT/P.UIT    UNIT INTERFACE TABLE ADDRESS
          STDL   P6
          LDN    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    LOCK        SET LOCKWORD
          UJK    SQLX
          SPACE  5,20
** NAME-- SSA
*
** PURPOSE-- SET SEEK ADDRESS
          SPACE  2
 SSAX     LJM    **
 SSA      EQU    *-1
          RJM    UREQ        READ SELECTED REQUEST INTO RQ
          LDML   RQ+/RQ/P.CYL
          STML   SS+/SS/P.CYL  CYLINDER ADDRESS OF CURRENT REQUEST
          LDML   RQ+/RQ/P.TRACK
          ADC    4000B       SET SECTOR SIZE FOR HARDWARE
          STML   SS+/SS/P.TRACK  TRACK ADDRESS OF CURRENT REQUEST
          LDML   RQ+/RQ/P.SECTOR
          STML   SS+/SS/P.SECTOR  SECTOR ADDRESS OF CURRENT REQUEST
          RJM    SC          SAVE CLOCK
          UJK    SSAX
          SPACE  5,20
** NAME-- SWITCH
*
** PURPOSE-- THE FIRST REQUEST AFTER A REQUEST SWITCH WAS SUCCESSFULLY
*            STARTED (NOW WE KNOW THAT NO ERRORS WERE DETECTED ON THE
*            PREVIOUS REQUEST). AT THIS POINT WE CAN UPDATE INTERNAL
*            POINTERS TO REFLECT THE REQUEST JUST STARTED.
          SPACE  2
 SWITCHX  LJM    **
 SWITCH   EQU    *-1
          LDN    0
          STDL   SWFLG       CLEAR SWITCH FLAG
          RJM    PDR         PREPARE DISK RESPONSE
          RJM    SNDRSP      SEND RESPONSE TO CM FOR LAST REQUEST
          AODL   NCOMRQ      INCREMENT NUMBER OF COMPLETED REQUESTS
          LDML   SS+/SS/P.SECTOR   ASDF
          SBML   RQ+/RQ/P.SECTOR
          NJN    SW10        IF ERROR
          LDML   SS+/SS/P.TRACK
          LPN    77B
          SBML   RQ+/RQ/P.TRACK
          NJN    SW10        IF ERROR
          LDML   SS+/SS/P.CYL
          SBML   RQ+/RQ/P.CYL
          NJN    SW10        IF ERROR
          LDML   CURRQ       SAVE RMA OF PREVIOUS REQUEST
          STML   PRERQ
          LDML   CURRQ+1
          STML   PRERQ+1
          LDML   SS+/SS/P.REQ  SAVE RMA OF CURRENT REQUEST
          STML   CURRQ
          LDML   SS+/SS/P.REQ+1
          STML   CURRQ+1
          UJK    SWITCHX
 SW10     BSS
          RJM    HANG
          SPACE  5,20
** NAME-- TERM
*
** PURPOSE-- TERMINATE UNIT REQUEST. (ONLY DONE BY MASTER)
          SPACE  2
 TERM     BSS
          RJM    PDR         PREPARE DISK RESPONSE
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    DELRQ       DELINK COMPLETED REQUESTS FROM QUEUE
          RJM    RESPIN      UPDATE 'IN' POINTER IN RESPONSE BUFFER
          RJM    CLRLOCK     CLEAR LOCK ON UNIT
          STML   RS+/RS/P.RTRY  CLEAR REQUEST RETRY COUNTER
          LDN    C.END
          RJM    SEND        SEND END MESSAGE TO SLAVE
          UJK    MAIN45      RETURN TO MAIN LOOP
          SPACE  5,20
** NAME-- TERMP
*
** PURPOSE-- SEND TERMINATION RESPONSE
          SPACE  2
 TERX     LJM    **
 TERMP    EQU    *-1
          RJM    RESP        SEND RESPONSE TO CPU
          RJM    RESPIN      UPDATE 'IN' POINTER FOR RESPONSE BUFFER
          UJK    TERX
          SPACE  5,20
** NAME-- UDA
*
** PURPOSE-- UPDATE DISK ADDRESS.  USE OF FLAG FT KEEPS THE DISK
*            ADDRESS ACCURATE FOR ERROR REPORTING.
          SPACE  2
 UDA10    BSS
          AODL   FT          INDICATE NOT FIRST FUNCTION
 UDAX     LJM    **
 UDA      EQU    *-1
          LDDL   FT
          ZJN    UDA10       IF FIRST DATA FUNCTION
          AOML   SS+/SS/P.SECTOR UPDATE SECTOR
          SBN    MAXSEC+1
          MJN    UDAX        IF SAME TRACK
          STML   SS+/SS/P.SECTOR CLEAR SECTOR
          AOML   SS+/SS/P.TRACK UPDATE TRACK
          UJN    UDAX
          SPACE  5,20
** NAME-- UREQ
*
** PURPOSE-- READ A UNIT REQUEST FROM CM.
*
** INPUT-- SS TABLE WHICH IDENTIFIES THE UNIT QUEUE.
*
** OUTPUT-- RQ  CONTAINS CURRENT REQUEST.
*           FRST = 0
*           NUMCM = NUMBER OF COMMANDS.
          SPACE  2
 UREQX    LJM    **
 UREQ     EQU    *-1
          LDN    0
          STML   FRST        SET FLAG WHEN REQUEST IS READ
          LDN    3           NUMBER OF WORDS TO READ
          STDL   WC
          LOADF  SS+/SS/P.REQ  LOAD CM ADDRESS AND REFORMAT
          ADN    2
          CRML   RQ+2*4,WC   READ CURRENT REQUEST
          SBN    5
          CRML   RQ,WC       READ SWITCH FLAG BEFORE LINKAGE POINTERS
          LDML   RQ+/RQ/P.LEN  DETERMINE NUMBER OF COMMANDS
          SHN    -3
          SBN    /RQ/C.CMND
          STML   NUMCM       NUMBER OF COMMANDS

* PUT REQUEST IN PP COMMUNICATION BUFFER.

          LDN    C.RQ
          STDL   WC
          RJM    EXLOD       GET CM ADDRESS OF COMMUNICATION BUFFER
          ADN    /CB/C.REQ
          CWML   RQ,WC       WRITE CURRENT REQUEST
          UJK    UREQX
          SPACE  5,20
** NAME-- USC
*
** PURPOSE-- UPDATE SAVED CLOCK
          SPACE  2
 USCX     LJM    **
 USC      EQU    *-1
          LDDL   PPNO        LOGICAL PP NUMBER
          SBML   SS+/SS/P.LPP
          ZJN    USCX        IF CLOCK START VALUE ACCURATE
          LDDL   PPNO
          STML   SS+/SS/P.LPP
          LDDL   CLMLS
          STDL   P6
 USC5     BSS
          SBML   SS+/SS/P.SEEKTM+1
          STML   SS+/SS/P.CLKST+1
          PJN    USC10       IF CLOCK HASN'T WRAPPED
          AOML   SS+/SS/P.SEEKTM
          LDC    1000        MILLISECONDS PER SECOND
          RADL   P6
          UJN    USC5
 USC10    BSS
          LDDL   CLSEC
          SBML   SS+/SS/P.SEEKTM
          PJN    USC30       IF CLOCK HASN'T WRAPPED
          ADC    0#10000
 USC30    BSS
          STML   SS+/SS/P.CLKST
          RJM    SAVSS
          UJK    USCX
          SPACE  5,20
** NAME-- WFUL
*
** PURPOSE-- WAIT FOR UNIT LOCK
          SPACE  2
 WFULX    LJM    **
 WFUL     EQU    *-1
 WFUL10   BSS
          RJM    SETLOCK     SET UNIT LOCK
          NJN    WFULX       IF LOCK SET
          UJN    WFUL10
          ERRPL  *-MASBUF    IF RESIDENT CODE SPILLS INTO DATA AREA
          SPACE  5,20
** NAME-- INIT
*
** PURPOSE-- REFORMAT AND SAVE ADDRESS OF PPIT AND OVERLAY
*            DIRECTORY.  THIS CODE MAY BE OVERLAYED AFTER IT
*            IS EXECUTED.
          SPACE  2
 INIT     BSS
          REFAD  DSRTP,CM.PIT REFORMAT ADDRESS OF PP INTERFACE TABLE
                               AND SAVE AT CM.PIT
          ADN    /PIT/C.CBUF
          CRDL   P1          READ RMA OF PP COMMUNICATIONS BUFFER
          LOADF  P3          REFORMAT ADDRESS OF COMMUNICATIONS BUFFER
          ADN    /CB/C.ODP
          CRDL   T1          READ RMA OF OVERLAY DIRECTORY
          REFAD  T3,DH       REFORMAT ADDRESS OF OVERLAY DIRECTORY
                              AND SAVE AT DH
 F        IFEQ   FE,1
          LOADOVL FEO        LOAD FORCE ERROR OVERLAY
 F        ENDIF
          LJM    MAIN
          OVERLAY (CONFIDENCE TEST),MASBUF
          ROUTINE CTO        CONFIDENCE TEST OVERLAY
          SPACE  5,20
** NAME-- BCTB
*
** PURPOSE-- BUILD CONFIDENCE TEST BUFFER
          SPACE  2
 BCTBX    LJM    **
 BCTB     EQU    *-1
          IAN    14B
          STML   CTB         STARTING VALUE FOR INCREMENTING PATTERN
          STDL   T1
          LDN    0
          STDL   T3          INDEX TO BUFFER
 BCTB10   BSS
          AODL   T1          BUILD INCREMENTING PATTERN
          STML   CTB+1,T3
          AODL   T3
          LMC    420B
          NJN    BCTB10      IF MORE WORDS TO STORE
          UJK    BCTBX
          SPACE  5,20
** NAME-- CT
*
** PURPOSE-- CONFIDENCE TEST.  RESERVE DRIVE, WRITE, READ, VERIFY
*            DATA ON THE CONFIDENCE TEST CYLINDER, THEN RELEASE THE
*            DRIVE IF INITIALIZATION CONFIDENCE TEST.
*
** ENTRY
*         1) AT INITIALIZATION WHEN PP IS LOADED
*         2) WHEN PP IS RESUMED
*         3) DURING ERROR RECOVERY TO ISOLATE AN ERROR TO MEDIA
          SPACE  2
 CTX      BSS
          LDN    0
          STDL   COMLOOK     ENSURE COMLOOK HAS A LEGAL VALUE
          LDN    1
          STDL   CTF         CONFIDENCE TEST COMPLETE
          LJM    **
 CT       EQU    *-1
 F        IFEQ   FE,1        FOR FORCING ERRORS
          LDN    4
          CRDL   T1
          LDDL   T1
          LMN    0#13
          NJN    CT5         IF NOT MODIFYING THE DELAY
          LDDL   T2
          STML   CTD1
          LDDL   T3
          STML   CTD2
          UJN    CT5
 CTD1     DATA   1           VALUE TIMES .5 IS WRITE DELAY
 CTD2     DATA   1           VALUE TIMES .5 IS READ DELAY
 CT5      BSS
 F        ENDIF
          LDN    0
          STDL   COMLOOK
          UJN    CT20
 CT10     BSS
          AODL   COMLOOK     UPDATE TO NEXT UNIT
 CT20     BSS
          SBDL   DEVL
          PJN    CTX         IF END OF CONFIGURED UNITS
          RJM    RDT         READ DEVICE TABLE
          SHN    -1
          NJK    CT10        IF NOT RUNNING CONFIDENCE TEST
          LDDL   CTF
          NJN    CT21        IF ORIGINAL ERROR OCCURRED ON A REQUEST
          LDC    SPLUT       SPARE LOGICAL UNIT TABLE
          STDL   LUTLOC
          LDN    1
          STDL   WC
          LOADC  CM.DEV      ADDRESS OF DEVICE TABLE
          ADDL   COMLOOK     INDEX INTO TABLE
          CRML   SPLUT+2,WC  ADDRESS OF UNIT INTERFACE TABLE
 CT21     BSS
          RJM    PPREQ       CHECK FOR IDLE REQUEST
          RJM    WFUL        WAIT FOR UNIT LOCK
          RJM    RDT         READ DEVICE TABLE
          LOADC  P3          ADDRESS OF UNIT INTERFACE TABLE
          CRDL   T1
          LDDL   T1+/UIT/P.DSABLE
          SHN    2+/UIT/L.DSABLE
          PJN    CT23        IF UNIT ENABLED
          RJM    CLRLOCK     CLEAR UNIT LOCK
          UJK    CT10
 CT23     BSS
          RJM    CTDT        CONFIDENCE TEST DATA TRANSFER
 CT25     BSS
          LDDL   CTF
          NJN    CT30        IF NOT INITIALIZATION CONFIDENCE TEST
          STML   RS+/RS/P.RTRY CLEAR RETRY COUNTER
          LDN    F.OPCMP
          RJM    FUNC        RELEASE THE DRIVE
          RJM    CLRLOCK     CLEAR UNIT LOCK
 CT30     BSS
          RJM    RDT         READ DEVICE TABLE
          LPN    /CB/K.ACT
          LMN    2
          STDL   P2          INDICATE CONFIDENCE TEST SUCCESSFUL
          LDML   CM.DEV+2
          ADDL   COMLOOK
          LMC    400000B
          CWDL   P2          SAVE IN DEVICE TABLE
          UJK    CT10
          SPACE  5,20
** NAME-- CTDT
*
** PURPOSE-- CONFIDENCE TEST DATA TRANSFER
          SPACE  2
 CTDTX    LJM    **
 CTDT     EQU    *-1
          LDN    F.OPCMP     OPERATION COMPLETE (ENSURE CHAINING IS CLEARED)
          RJM    FUNC
          LOADR  /LUT/P.UIT,LUTLOC  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.UBUF
          CRDL   T4          ADDRESS OF UNIT COMMUNICATIONS BUFFER
          LDN    C.SS
          STDL   WC
          LOADF  T6          ADDRESS OF SS TABLE
          CRML   SS,WC       READ SS TABLE
          LDC    MAXCYL-1
          STML   SS+/SS/P.CYL CONFIDENCE TEST CYLINDER
          LDC    4000B
          STML   SS+/SS/P.TRACK TRACK
          LDN    0
          STML   SS+/SS/P.SECTOR SECTOR
          STDL   FT          INDICATE FIRST FUNCTION
          LCN    0           MAKE MEDIA ERROR TABLE LOOK EMPTY
          STML   SS+CTME
          STML   SS+CTME+1
          STML   SS+CTME+2
          RJM    BCTB        BUILD CONFIDENCE TEST BUFFER
          LDML   RS+/RS/P.RTRY
          SBN    2
          MJN    CTDT20      IF NOT DOING UNCONDITIONAL RESERVE
          RJM    UR          UNCONDITIONAL RESERVE
 CTDT20   BSS
          RJM    SEEKON      WAIT FOR ON CYLINDER
*
*         WRITE THE CYLINDER
*           PP OUTPUTS 8 BLOCKS EACH OF LENGTH 530 OCTAL WORDS.
*           EACH BLOCK TAKES 402 OCTAL PP MEMORY LOCATIONS.
*
          LDC    CTDT35
          STDL   CA          CONTINUE ADDRESS
 CTDT30   BSS
          LDN    F.WRITE
          RJM    FUNC        WRITE FUNCTION
 CTDT35   BSS
          RJM    UDA         UPDATE DISK ADDRESS
          LDN    0
          STDL   T1          FIRST OF 8 BLOCKS
          LDN    1
          STDL   FNC         INDICATE WRITE OPERATION
          LDC    CTB
          STML   OUTPK10     ADDRESS TO OUTPUT FROM
 CTDT40   BSS
          LDC    530B        WORDS TO OUTPUT
          RJM    OUTPK       OUTPUT PACKED DATA
          AOML   OUTPK10     UPDATE ADDRESS TO OUTPUT FROM
          AODL   T1
          LPN    7
          STDL   T1          UPDATE BLOCK NUMBER
          NJN    CTDT40      IF MORE DATA IN SECTOR
          RJM    DCN         DISCONNECT THE CHANNEL

 F        IFEQ   FE,1        FOR FORCING ERRORS
          LDML   CTD1
          SBN    1
          NJN    *-1         FOR TESTING
 F        ENDIF

          AODL   FT          INDICATE NOT FIRST TIME
          LDML   SS+/SS/P.SECTOR
          ADML   SS+/SS/P.TRACK
          LPN    77B
          SBN    MAXSEC+MAXTR
          NJK    CTDT30      IF MORE SECTORS TO TRANSFER
          RJM    GENSTAT     GET GENERAL STATUS
          NJK    CTDT90      IF ERROR
 CTDT45   BSS
          LDC    4000B
          STML   SS+/SS/P.TRACK CLEAR TRACK NUMBER
          LDN    0
          STML   SS+/SS/P.SECTOR  CLEAR SECTOR NUMBER
 CTDT50   BSS
          STDL   FT          INDICATE FIRST FUNCTION
          STDL   FNC         INDICATE READ OPERATION
          RJM    SEEKON      SEEK, WAIT FOR ON CYLINDER
*
*         READ THE CYLINDER
*           PP INPUTS 8 BLOCKS, EACH OF LENGTH 530 OCTAL WORDS.
*           EACH BLOCK REQUIRES 402 OCTAL PP MEMORY LOCATIONS. ONLY
*           THE DATA IN THE FIRST SECTOR OF EACH HEAD IS VERIFIED.
*           THIS ALLOWS THE PP TO STREAM DATA FOR 10 SECTORS.
*
          LDC    CTDT65
          STDL   CA          CONTINUE ADDRESS
          LDC    CTB+1
          STML   INPK10      ADDRESS TO INPUT TO
          LDN    0
          STML   DMF         CLEAR DATA MISCOMPARE FLAG
 CTDT60   BSS
          LDN    F.READ
          RJM    FUNC        SEND READ FUNCTION
          LDDL   FT
          ZJN    CTDT65      IF FIRST FUNCTION
          LDML   DMF
          ZJN    CTDT65      IF NO DATA MISCOMPARE
          LDN    E07         PP - DRIVE DATA INTEGRITY ERROR
          STDL   T1
          RJM    RDT         READ DEVICE TABLE
          LPN    /CB/K.ACT
          LMN    8
          STDL   P2
          LOADC  CM.DEV
          ADDL   COMLOOK
          CWDL   P2          INDICATE DATA INTEGRITY ERROR
          LDDL   T1
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
 CTDT65   BSS
          RJM    UDA         UPDATE DISK ADDRESS
          LDN    0
          STDL   T1          FIRST OF 8 BLOCKS
 CTDT70   BSS
          LDC    530B        WORDS TO INPUT
          RJM    INPK        INPUT AND PACK DATA
          LDML   SS+/SS/P.SECTOR
          NJN    CTDT75      IF NOT FIRST SECTOR OF TRACK
          RJM    VCTD        VERIFY CONFIDENCE TEST DATA
 CTDT75   BSS
          AODL   T1
          LPN    7
          STDL   T1
          NJN    CTDT70      IF MORE DATA IN SECTOR
          RJM    WFI         WAIT FOR INACTIVE

 F        IFEQ   FE,1        FOR FORCING ERRORS
          LDML   CTD2
          SBN    1
          NJN    *-1
 F        ENDIF

          AODL   FT          INDICATE NOT FIRST SECTOR
          LDML   SS+/SS/P.SECTOR
          ADML   SS+/SS/P.TRACK
          LPN    77B
          SBN    MAXSEC+MAXTR
          NJK    CTDT60      IF MORE SECTORS TO TRANSFER
          RJM    GENSTAT     GET GENERAL STATUS
          NJN    CTDT90      IF ERROR
          UJK    CTDTX
 CTDT90   BSS
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- UR
*
** PURPOSE-- UNCONDITIONAL RESERVE OF THE DRIVE
*
** NOTE-- UNCONDITIONAL RESERVE ONLY WORKS IF CHAINING HAS BEEN DROPPED
*         BY THE OTHER STORAGE DIRECTOR.
          SPACE  2
 URX      BSS
          LDN    F.OPCMP
          RJM    FUNC        OPERATION COMPLETE (DROP CHAINING)
          LJM    **
 UR       EQU    *-1
          LDN    F.CONECT
          RJM    FUNC        SEND CONNECT FUNCTION
          LDML   SS+/SS/P.UNIT
          ADC    4000B
          STDL   T1          UNIT NUMBER/UNRECOVERED RESPONSE
          LDN    T1
          STML   OUT10       ADDRESS TO OUTPUT FROM
          LDN    1
          RJM    OUT         OUTPUT PARAMETER WORD
          RJM    DCN         DISCONNECT THE CHANNEL
          RJM    GENSTAT     GET GENERAL STATUS
          ZJN    URX         IF NO ERROR
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- VCTD
*
** PURPOSE-- VERIFY CONFIDENCE TEST DATA
*
** ENTRY
*         T1 = BLOCK NUMBER (0 TO 7) OF DATA READ
          SPACE  2
 VCTD40   BSS
          STML   DMF         INDICATE DATA MISCOMPARE
 VCTDX    LJM    **
 VCTD     EQU    *-1
          LDN    0
          STDL   P1
          LDML   SS+/SS/P.TRACK
          SHN    8
          STDL   P2          PUT CURRENT TRACK, SECTOR IN ONE WORD
 VCTD3    BSS
          LDML   SS+CTME,P1
          LMDL   P2
          ZJK    VCTDX       IF SECTOR NOT WRITTEN
          AODL   P1
          LMN    3
          NJN    VCTD3       IF MORE TABLE LOCATIONS TO CHECK
          LDC    402B
          STDL   T4          WORDS TO VERIFY
          LDML   CTB
          ADDL   T1
          STDL   T2          PATTERN FIRST WORD
          LDN    0
          STDL   T3          INDEX TO BUFFER
 VCTD20   BSS
          LDML   CTB+1,T3
          LMDL   T2
          NJN    VCTD40      IF ERROR
          AODL   T2
          AODL   T3
          SODL   T4
          NJN    VCTD20      IF MORE WORDS TO VERIFY
          UJK    VCTDX
          ERRPL  *-CTB       IF OVERFLOWING MEMORY
          OVERLAY (ERROR RECOVERY),MASBUF
          ROUTINE ERO        ERROR RECOVERY OVERLAY
          SPACE  5,20
** NAME-- OE
*
** PURPOSE-- TURN OFF ALL UNITS ON AN EQUIPMENT
*
** ENTRY
*         A = 0 TO TURN OFF ALL UNITS ON AN A CHANNEL
*         A NOT 0 TO TURN OFF ALL UNITS ON A STORAGE DIRECTOR
          SPACE  2
 OEX      LJM    **
 OE       EQU    *-1
          STDL   P2
          LDDL   DEVL
          ZJN    OEX         IF NO UNITS
          LDN    0
          STDL   COMLOOK     SET TO BEGINNING OF CM.DEV TABLE
          LDDL   LUTLOC
          STDL   P1          SAVE LUTLOC
          LDK    SPLUT       SPARE LOGICAL UNIT TABLE
          STDL   LUTLOC
 OE2      BSS
          LDN    1
          STDL   WC
          LOADC  CM.DEV      ADDRESS OF DEVICE TABLE
          ADDL   COMLOOK     INDEX INTO TABLE
          CRML   SPLUT+2,WC
          LOADR  SPLUT+/LUT/P.UIT
          CRDL   T1          GET FIRST WORD OF UIT
          ADN    /UIT/C.UBUF
          CRDL   T5          GET SECOND WORD OF UIT
          LDDL   T1+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJK    OE50        IF UNIT DISABLE ALREADY IS SET
          RJM    WFUL        WAIT FOR UNIT LOCK
          LDN    C.SS
          STDL   WC          LENGTH OF SS TABLE
          LOADF  T7
          CRML   SS,WC       READ SS ENTRY
          LDML   IDLE        IS THIS TRIP A RESULT OF AN IDLE COMMAND
          NJN    OE20        IF YES, AVOID TURNING OFF THE UNIT
          LDDL   P2
          ZJN    OE10        IF OFFING A CHANNEL
          LDML   RS+/RS/P.UNIT
          LMML   SS+/SS/P.UNIT
          LPN    40B
          NJN    OE20        IF DIFFERENT STORAGE DIRECTOR
 OE10     BSS
          LOADR  SPLUT+/LUT/P.UIT  ADDRESS OF UIT
          RJM    OFFUN       GO SET THE UNIT OFF
 OE20     BSS
          LDN    0           CLEAR THE REQUEST SELECTED FLAG
          STML   SS+/SS/P.ENTRY
          RJM    SAVSS       SAVE THE SS ENTRY
          RJM    CLRLOCK     UNLOCK UNIT
 OE50     BSS
          AODL   COMLOOK     ARE ALL UNITS PROCESSED?
          SBD    DEVL
          NJK    OE2         NO, GO TO THE NEXT ONE
          STDL   COMLOOK     ENSURE COMLOOK HAS LEGAL VALUE
          LDDL   P1
          STDL   LUTLOC      RESTORE LUTLOC
          LJM    OEX
          SPACE  5,20
** NAME-- OFFUN
*
** PURPOSE-- SET THE DISABLE FLAG IN THE UNIT INTERFACE TABLE.
*
** INPUT-- A & R REGISTERS = CM ADDRESS OF UNIT INTERFACE TABLE.
          SPACE  2
 OFUX     LJM    **
 OFFUN    EQU    *-1
          STDL   T1
          LDK    /UIT/K.DSABLE  SET UNIT DISABLE FLAG
          STDL   T3
          LDN    0
          STDL   T2
          STDL   T4
          STDL   T5
          LDDL   T1
          LMC    400000B
          RDSL   T2          -LOGICAL OR- THE UNIT DISABLE FLAG
          UJN    OFUX
          SPACE  5,20
** NAME-- PIR
*
** PURPOSE-- PROCESS IDLE OR RESUME COMMAND
          SPACE  2
 PIR      CON    0
          LDDL   T5
          SHN    /PIT/L.IDLREQ+2
          MJN    PIR10       IF IDLE REQUEST
          LDDL   T4          CLEAR ACTIVE CHECK BIT, RESUME REQUEST
          LPC    0#4FFE       BIT, IDLE STATUS BIT, AND LOCK BIT IN
          STDL   T4           PP INTERFACE TABLE
          LDDL   CM.PIT+2
          LMC    400000B
          CWDL   T1
          LDN    0
          STML   IDLE        CLEAR IDLE FLAG
          LDN    C.RES
          RJM    SEND        TELL SLAVE THAT RESUME OCCURRED
          LJM    MAIN
 PIR10    BSS
          LDDL   NCOMRQ
          SBN    2
          MJN    PIR15       IF NO COMPLETED REQUESTS TO DELINK
          SOML   NCOMRQ      MAKE COMPLETED REQUEST COUNT ACCURATE
          LDML   PRERQ       DELINK REQUESTS FROM FCOMRQ THRU CURRQ
          STML   CURRQ
          LDML   PRERQ+1
          STML   CURRQ+1
          RJM    DELRQ       DELINK COMPLETED REQUESTS
 PIR15    BSS
          AOML   IDLE        SET IDLE FLAG
          LDN    0
          RJM    OE          CLEAR UNIT LOCKS
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          LOADC  CM.PIT      ADDRESS OF PP INTERFACE TABLE
          CRDL   T1          READ FIRST WORD OF PP INTERFACE TABLE
          LDDL   T4
          LPC    0#2FFE      CLEAR ACTIVE CHECK BIT, IDLE REQUEST BIT,
          LMC    0#1000       CLEAR LOCK BIT, AND SET THE IDLE STATUS BIT
          STDL   T4
          LDDL   CM.PIT+2
          LMC    400000B
          CWDL   T1
 PIR20    BSS
          RJM    PPREQ       WAIT FOR RESUME
          UJN    PIR20
          SPACE  5,20
** NAME-- RSTBP
*
** PURPOSE-- RESTORE BUFFER POINTERS WHEN THE READ PROCESS HAS TO
*            BACK UP 1 SECTOR.
          SPACE  2
 RSTBPX   LJM    **
 RSTBP    EQU    *-1
          LDN    2           LENGTH OF SAVE AREA
          STDL   WC
          RJM    EXLOD       ADDRESS OF COMMUNICATIONS BUFFER
          ADN    /CB/C.SVAREA
          ADDL   SLAVE       ADD OFFSET SO MASTER AND SLAVE DO NOT USE
          ADDL   SLAVE        THE SAME AREA
          CRML   SVCELLS,WC  READ THE BACKED UP POINTERS
          LDDL   CMRMA       RESTORE RMA DATA POINTERS
          STML   CM+/CM/P.RMA
          LDDL   CMRMA+1
          STML   CM+/CM/P.RMA+1
          LDN    0
          STDL   SWFLG
          STDL   WDSS        AVOID COUNTING BYTES DURING RECOVERY
          UJN    RSTBPX      EXIT
          SPACE  5,20
** NAME-- RSTRQ
*
** PURPOSE-- SET UP FOR REQUEST RETRY
          SPACE  2
 RSTRQ    CON    0
          LDN    0
          STML   RS+/RS/P.HDWR  CLEAR ERROR STATUS
          LDDL   CTF
          ZJK    MAIN5       IF ERROR DURING CONFIDENCE TEST
          LDN    F.OPCMP     OPERATION COMPLETE (ENSURE CHAINING IS CLEARED)
          RJM    FUNC
          LDDL   FNC
          SBN    2
          NJN    RSTRQ2      IF NOT FORMAT
          LJM    FMTR        FORMAT RETRY
 RSTRQ2   BSS
          LDDL   GOFLG
          ZJN    RSTRQ4      IF ERROR ON PREVIOUS SECTOR
          LDDL   SWFLG
          ZJN    RSTRQ4      IF NOT SWITCHING REQUESTS
          RJM    SWITCH      SEND RESPONSE FOR GOOD REQUEST
 RSTRQ3   BSS
          SODL   NCOMRQ      DECREMENT COMPLETED REQUEST COUNT
          LDML   PRERQ
          STML   CURRQ
          LDML   PRERQ+1
          STML   CURRQ+1
          RJM    DELRQ       DELETE THE COMPLETED REQUEST
          UJK    RSTRQ25
 RSTRQ4   BSS
          LDML   SIP
          ZJK    RSTRQ20     IF SEEK IN PROGRESS
          LDDL   NCOMRQ
          SBN    2
          PJN    RSTRQ3      TO DELINK COMPLETED REQUESTS
          LDML   CURRQ       RESTORE RMA OF CURRENT REQUEST
          STML   SS+/SS/P.REQ
          LDML   CURRQ+1
          STML   SS+/SS/P.REQ+1
          LDML   RS+/RS/P.PVA  RESTORE PVA OF CURRENT REQUEST
          STML   SS+/SS/P.PVA
          LDML   RS+/RS/P.PVA+1
          STML   SS+/SS/P.PVA+1
          LDML   RS+/RS/P.PVA+2
          STML   SS+/SS/P.PVA+2
          RJM    SSA         SET SEEK ADDRESS
          UJN    RSTRQ30
 RSTRQ20  BSS
          RJM    POLS        POLL SUBROUTINE
          RJM    UREQ        READ UNIT REQUEST FROM CM
 RSTRQ25  BSS
          RJM    SETRQ       SET UP FOR FIRST REQUEST
 RSTRQ30  BSS
          RJM    SAVSS       SAVE SS TABLE
          RJM    SETADD      PUT STARTING ADDRESS IN RESPONSE BUFFER
          RJM    SRESP       SET UP RESPONSE BUFFER
          RJM    UNCMND      GET COMMAND AND SET UP TO PROCESS
          RJM    SEEKON      ISSUE SEEK
          LJM    MAIN30
 C        IFEQ   CHANTYP,1
          ERRPL  *-17777B
 C        ELSE
          ERRPL  *-7777B     IF OVERFLOWING MEMORY
 C        ENDIF
          OVERLAY (FORMAT PACK),MASBUF
          ROUTINE FMO        FORMAT OVERLAY
** NAME-- FC
*
** PURPOSE-- FORMAT ONE CYLINDER
          SPACE  2
 FCX      LJM    **
 FC       EQU    *-1
 F        IFEQ   FE,1        IF FORCING ERRORS
          LDN    4
          CRDL   T1
          LDDL   T1
          LMN    0#14
          NJN    FC4         IF NOT CHANGING THE RECORD SIZE
          LDDL   T2
          STML   FUN+1       SET RECORD SIZE
 FC4      BSS
 F        ENDIF
          LDML   SS+/SS/P.UNIT
          ADC    2300B       WRITE RECORDS, CYLINDER MODE
          STML   FUN         PUT UNIT ADDRESS IN PARAMETER LIST
          LDN    F.FMP
          RJM    FUNC        FORMAT FUNCTION
          LDC    FBUF
          STML   OUT10       ADDRESS OF FORMAT PARAMETERS
          LDN    18
          RJM    OUT         OUTPUT FORMAT PARAMETERS
          RJM    DCN         DISCONNECT THE CHANNEL
          LDDL   CLSEC
          STML   SS+/SS/P.CLKST
 FC10     BSS
          RJM    GENSTAT     GET GENERAL STATUS
          ZJK    FCX         IF FORMAT COMPLETE
          RJM    UC          UPDATE CLOCK
          LDDL   CLSEC
          SBML   SS+/SS/P.CLKST
          PJN    FC20        IF CLOCK HAS NOT WRAPPED
          ADC    0#10000
 FC20     BSS
          SBN    5
          MJN    FC10        IF TIMEOUT NOT EXPIRED
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- FORMD
*
** PURPOSE-- PROCESS TO FORMAT DISK COMMAND.
*
** INPUT-- CMLISTL = NUMBER OF ADDRESS-LENGTH ENTRIES IN THE
*                    COMMAND WHICH ARE LEFT TO PROCESS.
*          CMLIST  = A TABLE OF THE ADDRESS-LENGTH PAIRS POINTING TO
*                    THE CM DATA AREA.
          SPACE  2
 FORMD    CON    0
          LDN    E00
          RJM    PER         PREPARE ERROR RESPONSE
          LDK    /RS/K.FORS
          STML   RS+/RS/P.ID
          RJM    INTRS       TELL OPERATOR THAT FORMATTING IS STARTING

* THE CYL NUMBERS ARE AT ANOTHER LEVEL OF INDIRECTION.

          LDML   CMLIST+/CM/P.LEN  TAKE OUT 1 LEVEL OF INDIRECTION
          STML   CM+/CM/P.LEN
          SHN    -3          RESET CMLISTL
          STDL   CMLISTL
          LDML   CMLIST+/CM/P.RMA
          STML   CM+/CM/P.RMA
          LDML   CMLIST+/CM/P.RMA+1
          STML   CM+/CM/P.RMA+1
          RJM    GLIST       GO GET THE CYLINDER NUMBERS

 FORMD5   BSS
          LDML   CMLIST+/CM/P.RMA  STARTING CYLINDER
          STML   SS+/SS/P.CYL   PUT IT IN THE SS ENTRY
 FORMD10  BSS
          LDDL   CMLISTL
          STML   SS+/SS/P.LISTL  SAVE CURRENT CMLISTL POINTER
 FORMD20  BSS
          LDML   SS+/SS/P.CYL
          STML   FBUF        PUT CYLINDER NUMBER IN PARAMETER LIST
 F        IFEQ   FE,1        FOR FORCING ERRORS
          LDN    4
          CRDL   T1
          LDDL   T1
          LMN    0#11
          NJN    FORMD30     IF NOT FORCING AN ERROR
          LDDL   T2
          ZJN    FORMD30     IF NOT FORCING AN ERROR
          LCN    0           FORCE ERROR BY SENDING AN ILLEGAL
          STML   FBUF         CYLINDER NUMBER
          SODL   T2
          LDN    4
          CWDL   T1
 FORMD30  BSS
 F        ENDIF
          RJM    FC          FORMAT CYLINDER
          LDML   SS+/SS/P.LISTL
          STDL   CMLISTL     RESTORE SAVED CMLISTL POINTER
          LDML   CMLIST+/CM/P.RMA+1
          SBML   SS+/SS/P.CYL  CHECK IF FINISHED WITH RANGE
          ZJK    FORMD56     DONE
          LDN    1
          RAML   SS+/SS/P.CYL   SET TO NEXT CYLINDER
          RJM    PPREQ       CHECK FOR IDLE REQUEST
          UJK    FORMD10     GO DO THE NEXT CYLINDER
 FORMD56  BSS
          SODL   CMLISTL
          NJK    FORMD57     FORMAT IS NOT FINISHED
          LDN    F.OPCMP
          RJM    FUNC        RELEASE THE DRIVE
          LDN    E00
          RJM    PER         PREPARE ERROR RESPONSE
          LDK    /RS/K.FORE
          STML   RS+/RS/P.ID
          RJM    INTRS       TELL OPERATOR FORMAT FINISHED FOR 1 PACK
          LJM    TERM        EXIT - DONE
 FORMD57  BSS
          RJM    GLIST       GET NEXT ENTRY FROM LIST
          LJM    FORMD5      CONTINUE FORMATTING
 C        IFEQ   CHANTYP,1
          ERRPL  *-17777B
 C        ELSE
          ERRPL  *-7777B     IF OVERFLOWING MEMORY
 C        ENDIF
          OVERLAY (INITIALIZE TABLES),MASBUF
          ROUTINE ITO        INITIALIZE TABLES
** NAME-- CHGCH
*
** PURPOSE-- SET CHANNEL NUMBER IN INSTRUCTIONS
*
** INPUT-- CHAN = CHANNEL NUMBER
          SPACE  2
 CHGX     LJM    **
 CHGCH    EQU    *-1
          LDN    0
          STDL   T1          CHANGE DISK CHANNEL INSTRUCTIONS
 CHG10    LDML   CONCH,T1    ADDRESS OF CHANNEL INSTRUCTIONS
          ZJN    CHGX        END OF LIST
          STDL   T2
          LDIL   T2
          SCN    37B
          LMDL   CHAN        CHANNEL NUMBER
          STIL   T2
          AODL   T1
          UJK    CHG10

 CONCH    BSS                TABLE OF DISK CHANNEL REFERENCES
 TDC+40B  HERE   DISK CHANNEL REFERENCES
 T40B+DC  HERE
 TDC      HERE
          CON    0           END OF TABLE
          SPACE  5,20
** NAME-- FPART
*
** PURPOSE-- THE SLAVE MUST FIND THE MASTER PP AND USE ITS COMMUNICATION
*            BUFFER.
          SPACE  2
 FPAX     LJM    **
 FPART    EQU    *-1
          RJM    EXLOD       GET CM ADDRESS OF COMMUNICATION BUFFER
          CRDL   P1          READ CM ADDRESS OF PARTNERS PP-INTERFACE-TABLE
          LDDL   P1+/CB/P.SLAVE  CHECK IF THIS PP IS THE SLAVE
          LPK    /CB/K.SLAVE
          STDL   SLAVE       NONZERO IF THIS PP IS THE SLAVE
          ZJK    FPAX        IF THIS PP IS THE MASTER

* USE MASTER'S PP NUMBER.

          LOADF  P1+/CB/P.PARTNR  CM ADDRESS OF MASTER'S PP-INTERFACE-TABLE
          CRDL   T1          READ MASTER'S PP NUMBER
          LDDL   T1
          STDL   PPNO        USE MASTER'S PP NUMBER

* USE MASTER'S PP COMMUNICATION BUFFER.

          LDDL   CMADR+2     CM ADDRESS OF MASTERS PP-INTERFACE-TABLE
          LMC    400000B
          RJM    SETCB       SAVE ADDRESS OF COMMUNICATION BUFFER
          LDDL   CMADR+2     SWITCH IN AND OUT
          ADN    /CB/C.MSGIN
          STML   CM.MOUT+2
          ADN    /CB/C.MSGOUT-/CB/C.MSGIN
          STML   CM.MIN+2
          UJK    FPAX
          SPACE  5,20
** NAME-- IT
*
** PURPOSE-- INITIALIZE TABLES
*
** ENTRY
*         CM.PIT - 3 LOCATIONS CONTAINING THE REFORMATTED PPIT RMA
          SPACE  2
 ITX      LJM    **
 IT       EQU    *-1
          LDC    LUT
          STDL   USEQ        QUEUE HEAD FOR IN USE UNITS
          STDL   EMPTQ       QUEUE HEAD FOR UNITS NOT IN USE

* READ PP_INTERFACE_TABLE.

          LDN    C.PIT
          STDL   WC
          LOADC  CM.PIT      LOAD CM ADDRESS OF PP INTERFACE TABLE
          CRML   IPIT,WC     READ PP INTERFACE TABLE
          LDML   IPIT+/PIT/P.PPNO  GET PP NUMBER
          STDL   PPNO
          LDML   IPIT+/PIT/P.UNITC  NUMBER OF UNIT DESCRIPTORS
          SHN    1
          STDL   T8          LENGTH OF UNIT DESCRIPTORS (CM WORDS)

* REFORMAT ADDRESS OF RESPONSE BUFFER.
* INITIALIZE CM.RS, LIM.

          REFAD  IPIT+/PIT/P.RSBUF,CM.RS  REFORMAT CM ADDRESS OF RESPONSE
                             BUFFER
          LDML   IPIT+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STML   LIM

* REFORMAT ADDRESS OF INTERRUPT WORD.

          REFAD  IPIT+/PIT/P.INT,CM.INT  REFORMAT CM ADDRESS OF
                             INTERRUPT WORD

* REFORMAT ADDRESS OF CHANNEL TABLE.

          REFAD  IPIT+/PIT/P.CHAN,CM.CHAN  REFORMAT CM ADDRESS OF
                             CHANNEL TABLE

*  REFORMAT ADDRESS OF PP COMMUNICATIONS BUFFER

          LOADC  CM.PIT      ADDRESS OF PP INTERFACE TABLE
          RJM    SETCB       SAVE ADDRESS OF COMMUNICATIONS BUFFER

*  LOOK FOR A PARTNER PP.

          RJM    FPART       FIND PARTNER PP

* INITIALIZE COMMUNICATION BUFFERS IN ALL UNIT INTERFACE TABLES.

          RJM    ICOM        INITIALIZE COMMUNICATION BUFFERS

*
* SET UP MASTER/SLAVE DEPENDENT INSTRUCTIONS.

          LDDL   SLAVE
          NJN    INIT100     IF SLAVE PP
          LDC    MASBUF      ADDRESS OF MASTERS DATA BUFFER
          UJK    INIT110     GO FILL IN DATA ADDRESSES

 INIT100  BSS
          LDC    SLVBUF      ADDRESS OF SLAVE DATA BUFFER

* SET UP POINTERS TO THE CORRECT DATA BUFFER AND EXIT

 INIT110  BSS
          STML   READ36
          STML   WRI36
          STML   READ52
          STML   WRI53
          SHN    -12
          ADC    2100B       ADC INSTRUCTION
          STML   WRI36-1
          STML   READ52-1
          LDDL   SLAVE
          NJK    END         GO START THE SLAVE
          LJM    ITX
          SPACE  5,20
** NAME-- ICOM
*
** PURPOSE-- INITIALIZE THE UNIT COMMUNICATION BUFFER IN ALL THE UNIT
*            INTERFACE TABLES.
*            INITIALIZE ALL STATIC VARIABLES IN THE COMMUNICATION
*            BUFFER:  DEVICE TYPE, CHANNEL NUMBER, SEEK FUNCTION,
*            UNIT NUMBER, COMMUNICATION BUFFER (RMA), UNIT INTERFACE
*            TABLE (RMA).
          SPACE  2

* CHANGE DISK CHANNEL INSTRUCTIONS.

 ICOM100  BSS
          RJM    CHGCH       CHANGE DISK CHANNEL INSTRUCTIONS

* THE DISK CHANNEL IS ALSO USED TO LOAD THE PPS.  THEREFORE,
* THE PPS SHAKE HANDS BEFORE USING THE DISK CHANNEL.

          LDN    C.GO        EACH PP SENDS A -GO- TO PARTNER
          RJM    SEND
 ICOM110  BSS
          RJM    GETMSG      WAIT FOR PARTNER TO GET LOADED
          NJN    ICOM110     IF NOT A -GO- MESSAGE
          STDL   USEQ        SET IN USE QUEUE TO EMPTY
 ICOMX    LJM    **
 ICOM     EQU    *-1
          LDN    0
          STDL   T7          INDEX TO UNIT DESCRIPTORS
          STDL   DEVL        CLEAR DEVICE TABLE LENGTH
          STDL   PTF         ENABLE RUN OF PATH TEST
          STDL   CTF         ENABLE RUN OF CONFIDENCE TEST
          LDDL   T8          LENGTH OF UNIT DESCRIPTORS (CM WORDS)
          ZJN    ICOMX       IF NO UNIT DESCRIPTORS

*         ZERO OUT TABLES

          LDK    TL
          STDL   T1
 ICOM20   BSS
          LDN    0
          STML   LUT-1,T1     ZERO OUT TABLES
          SODL   T1
          NJN    ICOM20
 ICOM10   BSS
          LDDL   CM.PIT+2    CM ADDRESS OFFSET OF UNIT DESCRIPTORS
          ADN    C.PIT
          ADDL   T7
          STDL   CMADR+2
          LDN    C.UD        READ 2 CM WORDS
          STDL   WC
          LOADC  CM.PIT,CMADR+2
          CRML   IBUF,WC     READ UNIT DESCRIPTOR

* CHECK FOR NULL ENTRY.

          LDML   IBUF+/UD/P.UQT  RMA = 0 IF NULL ENTRY
          ADML   IBUF+/UD/P.UQT+1
          ZJK    ICOM80      IF NULL ENTRY

          LDDL   SLAVE
          NJK    ICOM40      IF SLAVE
          LDC    LUT
          STDL   LUTLOC      SO SETLOCK, CLRLOCK WILL WORK
          REFAD  IBUF+/UD/P.UQT,LUT+/LUT/P.UIT
          RJM    WFUL        WAIT FOR UNIT LOCK
          LDN    C.SS        LENGTH OF SS TABLE
          STDL   WC
          LOADR  LUT+/LUT/P.UIT  ADDRESS OF UNIT INTERFACE TABLE
          ADN    /UIT/C.UBUF
          CRDL   T1
          LOADF  T3          ADDRESS OF UNIT COMMUNICATIONS BUFFER
          CRML   SS,WC       READ SS TABLE
 ICOM40   BSS
          REFAD  IBUF+/UD/P.UQT,SS+/SS/P.UQT  REFORMAT RMA ADDRESS OF
                             UNIT INTERFACE TABLE

* READ UNIT INTERFACE TABLE

          LDN    C.UIT
          STDL   WC
          LOADR  SS+/SS/P.UQT  LOAD ADDRESS OF UNIT INTERFACE TABLE
          CRML   UBUF,WC     READ UNIT INTERFACE TABLE

* GET CHANNEL NUMBER SAVE IT.

          LDML   IBUF+/UD/P.CHAN
          SHN    -8
          STDL   CHAN        CHANNEL NUMBER
          STML   RS+/RS/P.CHAN  SAVE IN RESPONSE BUFFER

          LDDL   SLAVE       CHECK IF SLAVE PP
          NJK    ICOM100     LET MASTER INITIALIZE THE UNITS

* PUT PHYSICAL UNIT NUMBER IN SEEK FUNCTION.

          LDML   IBUF+/UD/P.UNIT
          LPN    /UD/M.UNIT
          STML   SS+/SS/P.UNIT
          LDML   IBUF+/UD/P.UNIT  ADD STORAGE DIRECTOR ADDRESS
          LPK    /UD/K.SDIR
          SHN    /UD/L.SDIR+10
          RAML   SS+/SS/P.UNIT

* REFORMAT COMMUNICATION BUFFER RMA.

          REFAD  UBUF+/UIT/P.UBUF,SS+/SS/P.COM

* CHECK THAT COMMUNICATION BUFFER IS LONG ENOUGH.

          LDML   UBUF+/UIT/P.UBUFL  NUMBER OF 8-BIT BYTES IN COMMUNICATION BUFFER
          SHN    -3          NUMBER OF CM WORDS
          SBN    C.SS        MUST BE LARGER THAN SS ENTRY
          PJN    ICOM70      IF COMMUNICATION BUFFER IS LARGE ENOUGH
                             ERROR - COMMUNICATION BUFFER TOO SMALL
          LDC    E308
          RJM    INTERR      INTERFACE ERROR (NO RETURN)

* SAVE SS ENTRY IN UNIT COMMUNICATION BUFFER.  NOTE THAT CONFIGURATION
* MANAGEMENT CLEARS THE UNIT COMMUNICATIONS BUFFER BEFORE THE DRIVER IS LOADED.

 ICOM70   BSS
          RJM    SAVSS       SAVE SS TABLE
          RJM    CLRLOCK     CLEAR UNIT LOCK
          LDML   UBUF+/UIT/P.DSABLE
          SHN    /UIT/L.DSABLE+2
          MJN    ICOM80      IF UNIT DISABLED

* SET AN ENTRY INTO THE CM.DEV TABLE.

          LDN    1
          STDL   WC
          LDN    0
          STML   SS+/SS/P.SECTOR  CLEAR ACTIVE AND CONFIDENCE TEST BITS
          LOADC  CM.DEV
          ADDL   DEVL
          CWML   SS+/SS/P.UQT-1,WC
          AODL   DEVL
          SBN    1
          ZJN    ICOM80      IF ONE, LINK MUST BE ZERO
          SBN    NOU         NUMBER OF UNITS
          PJN    ICOM80      IF TABLE FULL
          LDDL   USEQ
          ADN    P.LUT       POINTER TO NEXT LOGICAL UNIT ENTRY
          STIL   USEQ        FILL IN THE LINK FIELD
          LDN    P.LUT
          RADL   USEQ        SET POINTER TO NEXT ENTRY

* BUMP TO NEXT ENTRY.

 ICOM80   BSS
          LDN    C.UD
          RADL   T7          BUMP TO NEXT UNIT DESCRIPTOR ENTRY
          SBDL   T8          CHECK FOR END OF UNIT DESCRIPTORS
          NJK    ICOM10      IF MORE UNIT DESCRIPTORS
          UJK    ICOM100     EXIT
          SPACE  5,20
** NAME-- SAVAD
*
** PURPOSE-- SAVE RMA THAT IS BEING FORMATTED BY REFAD AND
*            STORED IN LOCATIONS GREATER THAN 77
          SPACE  2
 SAVAX    LJM    **
 SAVAD    EQU    *-1
          STML   2,T2
          LDDL   CMADR
          STI    T2
          LDDL   CMADR+1
          STML   1,T2
          UJK    SAVAX
          SPACE  5,20
** NAME-- SETCB
*
** PURPOSE-- REFORMAT AND SAVE ADDRESS OF COMMUNICATIONS BUFFER
*
** ENTRY-- A AND R REGISTERS POINT TO THE PP INTERFACE TABLE
          SPACE  2
 SETCBX   LJM    **
 SETCB    EQU    *-1
          ADN    /PIT/C.CBUF  OFFSET OF PP COMMUNICATION BUFFER ADDRESS
          CRDL   P1          READ ADDRESS OF PP COMMUNICATION BUFFER
          LOADF  P3          REFORMAT CM ADDRESS OF PP COMMUNICATION BUFFER
          STML   CM.CB+2
          ADN    /CB/C.MSGIN
          STML   CM.MIN+2
          ADN    /CB/C.MSGOUT-/CB/C.MSGIN
          STML   CM.MOUT+2
          ADC    /CB/C.DEV-/CB/C.MSGOUT
          STDL   CM.DEV+2
          LDDL   CMADR
          STML   CM.CB
          STML   CM.MIN      ADDRESS OF IN MESSAGE
          STML   CM.MOUT     ADDRESS OF OUT MESSAGE
          STDL   CM.DEV      ADDRESS OF DEVICE TABLE (ONE ENTRY FOR EACH UNIT)
          LDDL   CMADR+1
          STML   CM.CB+1
          STML   CM.MIN+1
          STML   CM.MOUT+1
          STDL   CM.DEV+1
          LDDL   P2          GET LENGTH OF PP COMMUNICATION BUFFER
          ADC    -P.CB-P.CB
          PJK    SETCBX      IF COMMUNICATIONS BUFFER LARGE ENOUGH
          RJM    HANG
          ERRPL  *-IPIT      IF OVERFLOWING MEMORY
          OVERLAY (PATH TEST),MASBUF
          ROUTINE PTO        PATH TEST OVERLAY
          SPACE  5,20
** NAME-- BPTB
*
** PURPOSE-- BUILD PATH TEST BUFFER
          SPACE  2
 BPTBX    LJM    **
 BPTB     EQU    *-1
          LDN    0
          STDL   T1          INDEX TO BUFFER
 BPTB10   BSS
          LDC    0#FFF       PATTERN IS FFF,000,AAA,555,EBD REPEATED
          STML   CTB,T1
          LDN    0
          STML   CTB+1,T1
          LDC    0#AAA
          STML   CTB+2,T1
          SHN    -1
          STML   CTB+3,T1
          LDC    0#EBD
          STML   CTB+4,T1
          LDN    5
          RADL   T1
          ADC    -328
          PJN    BPTBX       IF DONE
          UJK    BPTB10
          SPACE  5,20
** NAME-- LOADCON
*
** PURPOSE-- LOAD CCC CONTROLWARE
          SPACE  2
 LOAX     LJM    **
 LOADCON  EQU    *-1
          LDN    1
          STDL   WC
          RJM    EXLOD       GET CM ADDRESS OF COMMUNICATION BUFFER
          ADN    /CB/C.CONTRL  CM ADDRESS OF CONTROLWARE COMMAND
          CRML   CM,WC       READ COMMAND
          LDML   CM+/CM/P.LEN
          SHN    -3
          STDL   CMLISTL     LENGTH OF CM ADDRESS AREA (CM WORDS)
          RJM    GLIST       GET CM ADDRESS LIST OF DATA AREA
          LDK    F.AUTOP     ISSUE LOAD CONTROLWARE FUNCTION
          STML   LCF         INDICATE LOAD IN PROGRESS
          RJM    FUNC        ISSUE THE FUNCTION

* SETUP NUMBER OF WORDS TO TRANSFER FROM THIS CM ADDRESS.

 LOA20    BSS
          LOADF  CMLIST+/CM/P.RMA  SET UP CM ADDRESS OF DATA AREA
          STDL   DATADD+2
 F        IFEQ   FE,1        FOR FORCING ERRORS (FERP)
          LDN    4
          CRDL   T1
          LDDL   T1
          LMN    0#10
          NJN    LOA25       IF NOT FORCING AN ERROR
          LDDL   T2
          ZJN    LOA25       IF NOT FORCING AN ERROR
          LDC    -2000
          RAML   CMLIST+/CM/P.LEN
          SODL   T2          DECREMENT THE FORCE ERROR COUNTER
          LDN    4
          CWDL   T1
 LOA25    BSS
 F        ENDIF
          LDML   CMLIST+/CM/P.LEN  NUMBER OF 8-BIT BYTES TO TRANSFER
          ADN    7           ROUND UP
          SHN    -3          NUMBER OF CM WORDS TO TRANSFER
          STDL   TWDS        TOTAL NUMBER OF CM WORDS TO TRANSFER
                             FROM THIS ADDRESS
          ZJK    LOA70       IF NO WORDS TO TRANSFER FROM THIS ADDRESS
 LOA30    BSS
          STDL   WDS         COMPUTE NUMBER OF CM WORDS TO TRANSFER TO BUFFER
          SBN    CTLN        MAXIMUM SIZE OF BUFFER IN PP
          MJN    LOA40       IF LESS THAN PP BUFFER
          LDK    CTLN
          STDL   WDS         NUMBER OF CM WORDS TO TRANSFER TO BUFFER

* TRANSFER DATA FROM CM.

 LOA40    BSS
          LDDL   DATADD+2    CM ADDRESS OF DATA AREA
          LMC    400000B
          CRML   CWBUF,WDS   READ CONTROLWARE BINARY FROM CM
          STDL   DATADD+2    UPDATE CM ADDRESS

* CONVERT DATA TO ONE 8-BIT BYTE PER PP WORD.

          LDDL   WDS         NUMBER OF CM WORDS
          SHN    3
          STDL   T2          NUMBER OF 8-BIT BYTES
          STDL   T3
          SHN    -1          NUMBER OF 16-BIT PP WORDS
          ADC    CWBUF-1
          STDL   T1
 LOA50    BSS
          LDIL   T1          CONVERT DATA
          LPC    377B
          STML   CWBUF-1,T2
          LDIL   T1
          SHN    -8
          STML   CWBUF-2,T2
          SODL   T1
          SODL   T2
          SODL   T2
          NJK    LOA50       IF MORE DATA

* SEND DATA TO CONTROLLER.

          LDC    CWBUF       ADDRESS TO OUTPUT FROM
          STML   OUT10
          LDDL   T3
          RJM    OUT         SEND DATA TO CCC
          LDDL   TWDS        UPDATE TOTAL WORDS LEFT TO TRANSFER
                               TO THIS CM ADDRESS.
          SBDL   WDS
          STDL   TWDS
          NJK    LOA30       IF MORE WORDS TO TRANSFER FROM THIS CM ADDRESS

* GET NEXT CM ADDRESS OF DATA AREA.

 LOA70    BSS
          SODL   CMLISTL     DECREMENT ADDRESS-LENGTH-PAIR COUNT
          ZJN    LOA80       IF END OF ADDRESS-LENGTH-PAIRS IN COMMAND
          RJM    GLIST       GET NEXT ENTRY FROM LIST
          UJK    LOA20

* END OF DATA.  GET GENERAL STATUS.

 LOA80    BSS
          RJM    DCN         DISCONNECT THE CHANNEL
          RJM    GENSTAT     GET GENERAL STATUS
          NJN    LOA90       IF ERROR
          STML   LCF         INDICATE LOAD COMPLETE
          UJK    LOAX        IF NOT UNRECOVERED ERROR
 LOA90    BSS
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          SPACE  5,20
** NAME-- PT
*
** PURPOSE-- PATH TEST.  LOAD CONTROLWARE, THEN DO FURTHER TESTING
*            ON THE PP TO CCC PATH.
          SPACE  2
 PT100    BSS
          AODL   PTF         INDICATE PATH TEST COMPLETE
 PTX      LJM    **
 PT       EQU    *-1
          LDDL   DEVL
          ZJN    PT100       IF NO UNITS
          LDDL   PTF
          NJN    PTX         IF NOT RUNNING PATH TEST
          RJM    SCLOCK      SET CHANNEL LOCK
          STDL   GNSTAT      CLEAR GENERAL STATUS
          LDDL   CTF
          NJN    PT10        IF ORIGINAL ERROR ON DISK REQUEST
          LDML   RS+/RS/P.RTRY
          NJN    PT10        IF ALREADY IN RECOVERY
          STDL   COMLOOK     CLEAR INDEX TO DEVICE TABLE
          LDC    SPLUT
          STDL   LUTLOC      SPARE LOGICAL UNIT TABLE
 PT10     BSS
 F        IFEQ   CHANTYP,1   IF CIO CHANNEL
          LDC    F.MCLEAR    MASTER CLEAR ADAPTOR
          RJM    FUNC
          LDC    F.WRCR      WRITE CONTROL REGISTER
          RJM    FUNC
          LDC    INITAA
          STML   OUT10       ADDRESS TO OUTPUT FROM
          LDN    1           WORDS TO OUTPUT
          RJM    OUT         OUTPUT DATA
          RJM    DCN         DISCONNECT THE CHANNEL
 F        ENDIF
          LDN    1
          STDL   WC
          LOADC  CM.DEV
          CRML   SPLUT+2,WC  PUT UIT IN A LOGICAL UNIT TABLE
                              FOR ERROR RECOVERY
          RJM    LOADCON     LOAD CONTROLWARE
          RJM    BPTB        BUILD PATH TEST BUFFER
 F        IFEQ   FE,1        FOR FORCING ERRORS (FERR)
          LDN    4
          CRDL   T1
          LDDL   T1
          LMN    0#12
          NJN    PT20        IF NOT FORCING AN ERROR
          LDDL   T2
          ZJN    PT20        IF NOT FORCING AN ERROR
          LDN    0           FORCE DATA MISCOMPARE BY WRITING
          STML   CTB          THE WRONG DATA PATTERN
          SODL   T2
          LDN    4
          CWDL   T1
 PT20     BSS
 F        ENDIF
          LDC    CTB
          STML   IN10        ADDRESS TO INPUT DATA
          STML   OUT10       ADDRESS TO OUTPUT DATA
          LDN    F.UDIW
          RJM    FUNC        UDI WRITE
          LDC    502B        WORDS TO OUTPUT
          RJM    OUT         OUTPUT DATA
          RJM    DCN         DISCONNECT THE CHANNEL
          RJM    GENSTAT     GET GENERAL STATUS
          NJN    PT30        IF ERROR
          LDN    F.UDIR
          RJM    FUNC        UDI READ

          LDC    502B        WORDS TO INPUT
          RJM    IN          INPUT DATA
          RJM    WFI         WAIT FOR INACTIVE
          RJM    GENSTAT     THIS CHECKS FOR ERROR FLAG
          RJM    VPTD        VERIFY PATH TEST DATA
          LDN    F.DMAW
          RJM    FUNC        DMA WRITE

          LDC    502B        WORDS TO OUTPUT
          RJM    OUT         OUTPUT DATA
          RJM    DCN         DISCONNECT THE CHANNEL
          RJM    GENSTAT     GET GENERAL STATUS
 PT30     BSS
          NJN    PT50        IF ERROR
          LDN    F.DMAR
          RJM    FUNC        DMA READ

          LDC    502B        WORDS TO INPUT
          RJM    IN          INPUT DATA
          RJM    WFI         WAIT FOR INACTIVE
          RJM    GENSTAT     GET GENERAL STATUS
          NJN    PT50        IF ERROR
          RJM    VPTD        VERIFY PATH TEST DATA
          UJK    PT100
 PT50     BSS
          LDN    E00         CP MUST ISOLATE THE ERROR
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
 INITAA   CON    400B        VALUE FOR CONTROL REGISTER (CIO ONLY)
          SPACE  5,20
** NAME-- VPTD
*
** PURPOSE-- VERIFY PATH TEST DATA
          SPACE  2
 VPTDX    LJM    **
 VPTD     EQU    *-1
          LDN    0
          STDL   T1          INDEX TO BUFFER
 VPTD10   BSS
          LDC    7777B
          LMML   CTB,T1
          NJN    VPTD20      IF ERROR
          LDN    0
          LMML   CTB+1,T1
          NJN    VPTD20      IF ERROR
          LDC    0#AAA
          LMML   CTB+2,T1
          NJN    VPTD20      IF ERROR
          LDC    0#555
          LMML   CTB+3,T1
          NJN    VPTD20      IF ERROR
          LDC    0#EBD
          LMML   CTB+4,T1
          NJN    VPTD20      IF ERROR
          LDN    5
          RADL   T1
          ADC    -328
          PJK    VPTDX       IF ALL WORDS VERIFIED
          UJK    VPTD10
 VPTD20   BSS
          LDN    E06         PP - CCC DATA INTEGRITY
          STDL   T1
          RJM    RDT         READ DEVICE TABLE
          LPN    /CB/K.ACT
          LMN    8
          STDL   P2
          LOADC  CM.DEV
          ADDL   COMLOOK
          CWDL   P2          INDICATE DATA INTEGRITY ERROR
          LDDL   T1
          RJM    PCER        PREPARE COMMON ERROR RESPONSE (NO RETURN)
          ERRPL  *-CTB       IF OVERFLOWING MEMORY
 F        IFEQ   FE,1        FORCE ERROR CODE
          OVERLAY (FORCE ERROR CODE),14000B
          ROUTINE FEO        FORCE ERROR OVERLAY
** NAME-- FER
*
** PURPOSE-- FORCE ERROR ROUTINE.  THE ERROR CAN BE FORCED IN THE MASTER
*            PP BY CHANGING CENTRAL MEMORY AT BYTE 40 AND CAN BE FORCED IN THE
*            SLAVE PP BY CHANGING CENTRAL MEMORY AT BYTE 48.
          SPACE  2
 FERX     LJM    **
 FER      EQU    *-1
          LDN    8
          ADDL   SLAVE
          CRDL   P2          READ LOCATION WITH ERROR ROUTINE
          LDDL   P2
          ZJN    FERX        IF NOT FORCING AN ERROR
          STML   FEST
          LPN    77B
          STDL   P6          INDEX TO TABLE
          SBN    FETND-FET
          PJN    FERX        IF UNDEFINED VALUE
          LDN    0
          STDL   P2
          LDN    8
          ADDL   SLAVE
          CWDL   P2          INDICATE ERROR BEING FORCED
          LDML   FEST
          SHN    -8
          STML   FEST        FORCE ERROR START COUNT
          LDDL   P3
          STML   FEND        FORCE ERROR END COUNT
          LDML   FET,P6
          STDL   P2
          LJM    0,P2        JUMP TO FORCE ERROR ROUTINE
* TABLE OF ERRORS TO FORCE
 FET      BSS
          CON    FERX        NO ERROR
          CON    FERA        READ ONE TOO MANY WORDS
          CON    FERB        READ ONE TOO FEW WORDS
          CON    FERC        WRITE ONE TOO MANY WORDS
          CON    FERD        WRITE ONE TOO FEW WORDS
          CON    FERE        READ FUNCTION TIMEOUT
          CON    FERF        WRITE FUNCTION TIMEOUT
          CON    FERG        STATUS ERROR ON SEEK (ILLEGAL CYLINDER)
          CON    FERH        STATUS ERROR ON READ (ILLEGAL HEAD)
          CON    FERI        CHANGE ONE MEMORY LOCATION
          CON    FERJ        TEST TIMING ON READ
          CON    FERK        TEST TIMING ON WRITE
          BSS    0           FERP - LOAD CONTROLWARE ERROR
          BSS    0           FERQ - FORMAT PACK ERROR
          BSS    0           FERR - PATH TEST ERROR
          BSS    0           FERS - CONFIDENCE TEST ERROR
          BSS    0           FERT - FORMAT WRONG RECORD SIZE
 FETND    BSS
          SPACE  5,20
** NAME-- FERA
*
** PURPOSE-- READ ONE TOO MANY WORDS
*            (SAME RESULTS IF READ ONE TOO FEW)
*
** ENTRY
*         40 = XX01 YYYY   FOR MASTER (NOTE, SLAVE DETECTS ERROR)
*              X = BURSTS TO READ BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
*         50 = 00DD 00PP  DD = DRIVE NUMBER  PP = LOGICAL PP NUMBER
          SPACE  2
 FERA     BSS
          LDC    FERA10
          UJN    FERB5
 FERA10   BSS
          LDN    10
          CRDL   T1
          LDML   SS+/SS/P.UNIT
          LMDL   T1
          NJK    FERB30      IF WRONG DRIVE
          LDDL   T2
          LMDL   PPNO
          NJK    FERB30      IF WRONG LOGICAL PP
          LDML   FEST
          NJN    FERB15      IF NOT TIME TO START FORCING ERROR
          LDML   FEND
          ZJN    FERB25      IF DONE FORCING ERRORS
          SOML   FEND
          LDML   IOCOUNT,TOGL
          ADN    1           READ ONE TOO MANY WORDS
          UJK    FERB40
          SPACE  5,20
** NAME-- FERB
*
** PURPOSE-- READ 1 TOO FEW WORDS (SAME RESULTS AS FERA)
*
** ENTRY
*         40 = XX02 YYYY   FOR MASTER (NOTE, SLAVE DETECTS ERROR)
*              X = BURSTS TO READ BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERB     BSS
          LDC    FERB10
 FERB5    BSS
          STML   READ35+1    MODIFY INSTRUCTION
          LDC    100B
          STML   READ35
          LJM    FERX
 FERB10   BSS
          LDML   FEST
          ZJN    FERB20      IF FORCING THE ERROR
 FERB15   BSS
          SOML   FEST
          UJN    FERB30
 FERB20   BSS
          LDML   FEND
          NJN    FERB35      IF FORCING THE ERROR
 FERB25   BSS
          LDC    105000B+TOGL  RESTORE INSTRUCTION
          STML   READ35
          LDC    IOCOUNT
          STML   READ35+1
 FERB30   BSS
          LDML   IOCOUNT,TOGL
          UJN    FERB40
 FERB35   BSS
          SOML   FEND
          LDML   IOCOUNT,TOGL
          SBN    1           READ ONE TOO FEW WORDS
 FERB40   BSS
          LJM    READ36-1
          SPACE  5,20
** NAME--FERC
*
** PURPOSE-- WRITE ONE TOO MANY WORDS
*            (THIS IS NOT DETECTED BY HARDWARE)
*
** ENTRY
*         40 = XX03 YYYY   FOR MASTER (NOTE, SLAVE DETECTS ERROR)
*              X = BURSTS TO WRITE BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERC     BSS
          LDC    FERC10
          UJN    FERD5
 FERC10   BSS
          LDML   FEST
          NJK    FERD15      IF NOT TIME TO START FORCING ERRORS
          LDML   FEND
          ZJK    FERD25      IF DONE FORCING ERRORS
          SOML   FEND
          LDML   IOCOUNT,TOGL
          ADN    1           WRITE ONE TOO MANY WORDS
          UJK    FERD40
          SPACE  5,20
** NAME-- FERD
*
** PURPOSE-- WRITE ONE TOO FEW WORDS
*
** ENTRY
*         40 = XX04 YYYY   FOR MASTER (NOTE, SLAVE DETECTS ERROR)
*              X = BURSTS TO WRITE BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
*         50 = 00DD 00PP  DD = DRIVE NUMBER  PP = LOGICAL PP NUMBER
          SPACE  2
 FERD     BSS
          LDC    FERD10
 FERD5    BSS
          STML   WRI52+1     MODIFY INSTRUCTION
          LDC    100B
          STML   WRI52
          LJM    FERX
 FERD10   BSS
          LDN    10
          CRDL   T1
          LDML   SS+/SS/P.UNIT
          LMDL   T1
          NJK    FERD30      IF WRONG DRIVE NUMBER
          LDDL   T2
          LMDL   PPNO
          NJK    FERD30      IF WRONG LOGICAL PP
          LDML   FEST
          ZJN    FERD20      IF FORCING THE ERROR
 FERD15   BSS
          SOML   FEST
          UJN    FERD30
 FERD20   BSS
          LDML   FEND
          NJN    FERD35      IF FORCING THE ERROR
 FERD25   BSS
          LDC    105000B+TOGL  RESTORE INSTRUCTION
          STML   WRI52
          LDC    IOCOUNT
          STML   WRI52+1
 FERD30   BSS
          LDML   IOCOUNT,TOGL
          UJN    FERD40
 FERD35   BSS
          SOML   FEND
          LDML   IOCOUNT,TOGL
          SBN    1           WRITE ONE TOO FEW WORDS
 FERD40   BSS
          LJM    WRI53-1
          SPACE  5,20
** NAME-- FERE
*
** PURPOSE--FORCE READ FUNCTION TIMEOUT ERROR
*
** ENTRY
*         40 = XX05 YYYY   FOR MASTER
*              X = BURSTS TO READ BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
*         50 = 00DD  00PP  DD= DRIVE NUMBER  PP = LOGICAL PP
          SPACE  2
 FERE     BSS
          LDC    FERE10      MODIFY INSTRUCTION
          STML   READ33
          LJM    FERX
 FERE10   CON    0
          LDN    10
          CRDL   T1
          LDML   SS+/SS/P.UNIT
          LMDL   T1
          NJK    FERE25      IF WRONG DRIVE NUMBER
          LDDL   T2
          LMDL   PPNO
          NJK    FERE25      IF WRONG LOGICAL PP
          LDML   FEST
          NJN    FERE20      IF NOT TIME TO FORCE ERROR
          LDML   FEND
          NJN    FERE30      IF FORCING AN ERROR
          LDC    FUNC        RESTORE INSTRUCTION
          STML   READ33
          UJN    FERE25
 FERE20   BSS
          SOML   FEST
 FERE25   BSS
          LDN    F.READ
          UJN    FERE35
 FERE30   BSS
          SOML   FEND
          LDN    3           A FUNCTION THAT GETS NO REPLY
 FERE35   BSS
          RJM    FUNC
          LJM    READ33+1
          SPACE  5,20
** NAME-- FERF
*
** PURPOSE-- FORCE FUNCTION TIMEOUT ON WRITE
*
** ENTRY
*         40 = XX06 YYYY   FOR MASTER
*              X = BURSTS TO READ BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
*         50 = 00DD 00PP  DD = DRIVE NUMBER  PP = LOGICAL PP
          SPACE  2
 FERF     BSS
          LDC    FERF10      MODIFY INSTRUCTION
          STML   WRI50
          LJM    FERX
 FERF10   CON    0
          LDN    10
          CRDL   T1
          LDML   SS+/SS/P.UNIT
          LMDL   T1
          NJK    FERF25      IF WRONG DRIVE NUMBER
          LDDL   T2
          LMDL   PPNO
          NJK    FERF25      IF WRONG LOGICAL PP
          LDML   FEST
          NJN    FERF20      IF NOT TIME TO FORCE ERROR
          LDML   FEND
          NJN    FERF30      IF FORCING AN ERROR
          LDC    FUNC
          STML   WRI50
          UJN    FERF25
 FERF20   BSS
          SOML   FEST
 FERF25   BSS
          LDN    F.WRITE
          UJN    FERF35
 FERF30   BSS
          SOML   FEND
          LDN    3           A FUNCTION THAT GETS NO REPLY
 FERF35   BSS
          RJM    FUNC
          LJM    WRI50+1
          SPACE  5,20
** NAME-- FERG
*
** PURPOSE-- FORCE STATUS ERROR ON SEEK DUE TO SENDING AN ILLEGAL CYLINDER
*            NUMBER
*
** ENTRY
*         40 = XX07 YYYY   FOR MASTER
*              X = BURSTS TO READ BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
*         50 = 00DD 00PP  DD = DRIVE NUMBER  PP = LOGICAL PP NUMBER
          SPACE  2
 FERG     BSS
          LDC    FERG10      MODIFY INSTRUCTION
          STML   SEEK10
          LJM    FERX
 FERG10   CON    0
          LDN    10
          CRDL   T1
          LDML   SS+/SS/P.UNIT
          LMDL   T1
          NJK    FERH40      IF NOT TIME TO FORCE THE ERROR
          LDDL   T2
          LMDL   PPNO
          NJK    FERH40
          LDML   FEST
          NJK    FERH30      IF NOT TIME TO FORCE ERROR
          LDML   FEND
          ZJN    FERH15      IF DONE FORCING ERRORS
          LDC    886         ILLEGAL CYLINDER NUMBER
          STML   SS+/SS/P.CYL
          UJN    FERH25
          SPACE  5,20
** NAME-- FERH
*
** PURPOSE-- FORCE A STATUS ERROR ON WRITE OR READ BY SENDING AN ILLEGAL
*            HEAD NUMBER
*
** ENTRY
*         40 = XX08 YYYY   FOR MASTER
*              X = BURSTS TO READ BEFORE FORCING FIRST ERROR
*              Y = NUMBER OF TIMES TO FORCE THE ERROR
          SPACE  2
 FERH     BSS
          LDC    FERH10      MODIFY INSTRUCTION
          STML   SEEK10
          LJM    FERX
 FERH10   CON    0
          LDML   FEST
          NJN    FERH30      IF NOT TIME TO FORCE ERROR
          LDML   FEND
          NJN    FERH20      IF FORCING AN ERROR
 FERH15   BSS
          LDC    FUNC        RESTORE INSTRUCTION
          STML   SEEK10
          UJN    FERH40
 FERH20   BSS
          LDK    4017B       ILLEGAL HEAD NUMBER
          STML   SS+/SS/P.TRACK
 FERH25   BSS
          SOML   FEND
          UJN    FERH40
 FERH30   BSS
          SOML   FEST
 FERH40   BSS
          LDN    F.SEEK
          RJM    FUNC
          LJM    SEEK10+1
          SPACE  5,20
** NAME-- FERI
*
** PURPOSE-- CHANGE ONE MEMORY LOCATION
*         40 = 0009 0000 XXXX YYYY
*              X = ADDRESS
*              Y = VALUE
          SPACE  2
 FERI     BSS
          LDDL   P5
          STIL   P4
          LJM    MAIN10
          SPACE  5,20
** NAME-- FERJ
*
** PURPOSE-- TEST TIMING MARGIN ON A READ
*
** ENTRY
*         40 - 000A XXXX  FOR MASTER
*         48 - 000A XXXX  FOR SLAVE
*              XXXX TIMES .5 IS THE USEC DELAY PER READ FUNCTION
          SPACE  2
 FERJ     BSS
          LDDL   P3
          STML   READ40G     MODIFY DELAY
          UJN    FERK10
          SPACE  5,20
** NAME-- FERK
*
** PURPOSE-- FORCE OVERRUN ERROR/TEST TIMING MARGIN ON A WRITE
*
** ENTRY
*         40 - 000B XXXX  FOR MASTER
*         48 - 000B XXXX  FOR SLAVE
*              XXXX TIMES .5 IS THE USEC DELAY PER WRITE FUNCTION
          SPACE  2
 FERK     BSS
          LDDL   P3
          STML   WRI54       MODIFY DELAY
 FERK10   BSS
          LJM    FERX
          SPACE  5,20
** NAME-- FERP
*
** PURPOSE-- FORCE AN ERROR DURING LOADING OF CCC CONTROLWARE.  ONLY
*            THE DOCUMENTATION IS HERE.  THE LOAD CONTROLWARE ROUTINE
*            READS CENTRAL MEMORY AT BYTE 20
*                20 - 0010 XXXX
*            IF THE CODE OF 0010 IS PRESENT AND XXXX IS NONZERO, THE
*            LAST 40 WORDS OF CCC CONTROLWARE WILL NOT BE LOADED.  THIS
*            WILL FORCE A CHECKSUM ERROR.  XXXX IS THE NUMBER OF TIMES
*            TO FORCE THE ERROR.
          SPACE  5,20
** NAME-- FERQ
*
** PURPOSE-- FORCE AN ERROR DURING FORMAT OF A PACK.  ONLY THE DOCUMENTAION
*            IS HERE.  THE FORMAT ROUTINE READS AT BYTE LOCATION 20
*                20 - 0011 XXXX
*            IF THE CODE OF 0011 IS PRESENT AND XXXX IS NONZERO, THE FORMAT
*            PACK COMMAND WILL BE ISSUED TO THE CCC WITH AN ILLEGAL CYLINDER
*            NUMBER.  XXXX WILL BE DECREMENTED BY ONE FOR EACH ERROR FORCED.
          SPACE  5,20
** NAME-- FERR
*
** PURPOSE-- FORCE AN ERROR DURING THE PATH TEST.  ONLY THE DOCUMENTAION IS
*            HERE.  THE PATH TEST ROUTINE READS CM AT BYTE LOCATION 20
*                20 - 0012 XXXX
*            IF THE CODE IS 0012 AND XXXX IS NONZERO, THE PATH TEST WILL
*            WRITE THE WRONG PATTERN, WHICH WILL RESULT IN A DATA MISCOMPARE.
*            XXXX WILL BE DECREMENTED BY ONE FOR EACH ERROR FORCED.
          SPACE  5,20
** NAME-- FERS
*
** PURPOSE-- FORCE AN ERROR DURING THE CONFIDENCE TEST AND VERIFY TIMING
*            MARGINS FOR THE WRITE AND READ ROUTINES DURING THE CONFIDENCE
*            TEST.  IF THE CODE IS 0013, THEN THE DELAY COUNTS XXXX AND
*            YYYY WILL BE USED RATHER THAN THE DEFAULT VALUE WHICH IS CLOSE
*            TO ZERO.
*                20 - 0013 XXXX YYYY
*                    XXXX TIMES .5 IS THE DELAY BETWEEN WRITE FUNCTIONS
*                    YYYY TIMES .5 IS THE DELAY BETWEEN READ FUNCTIONS
          SPACE  5,20
** NAME-- FERT
*
** PURPOSE-- CREATE ERRORS BY FORMATTING WITH THE WRONG RECORD SIZE.  ONLY
*            THE DOCUMENTATION IS HERE.  THE FORMAT ROUTINE READS BYTE ADDRESS 20
*                20 - 0014 XXXX
*            IF THE CODE IS 0014, THE VALUE XXXX WILL BE USED TO DETERMINE THE
*            SECTOR SIZE TO FORMAT
*                0000 - SMALL SECTOR
*                0200 - NOS LARGE SECTOR
*                0800 - NOS/VE SECTOR (NO ERROR)
 F        ENDIF
*DECK DECK=PPM$1SI EXPAND=TRUE
          IDENT  1SI,SSI
          PERIPH
          BASE   MIXED
          SST
*COMMENT 1SI - SUBSYSTEM INITIALIZER.
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          TITLE  1SI - SUBSYSTEM INITIALIZER.
          SPACE  4
***       1SI - SUBSYSTEM INITIALIZER.
*         A. J. KOMOR. 76/01/22.
          SPACE  4
***       1SI IS CALLED BY 1DS TO INITIALIZE ONE OF THE FOLLOWING
*         SUBSYSTEMS BASED ON THE APPROPRIATE QUEUE PRIORITY -
*                1. NETWORK INTERFACE PROCESSOR (NIP).
*                2. REMOTE BATCH FACILITY (RBF).
*                3. TRANSACTION FACILITY (TAF).
*                4. INTERACTIVE FACILITY (IAF).
*                5. CYBER DATA CONTROL SUBSYSTEM (CDCS).
*                6. MESSAGE CONTROL SUBSYSTEM (MCS).
*                7. TIMESHARING STIMULATOR.
*                8. MASS STORAGE SUBSYSTEM (MSS).
*                9. TIME SHARING SUBSYSTEM (TELEX).
*                10. EXPORT/IMPORT SUBSYSTEM (EI200).
          SPACE  4
***       ENTRY PARAMETERS.
*
*                (JCIW+1) = QUEUE PRIORITY OF THE SUBSYSTEM
*                           TO BE INITIATED.
*                (CSBW+1) = 4TH AND 5TH CHARACTES OF THE PROCEDURE
*                           FILE NAME THAT THE OPERATOR ENTERED.
*                         = 7777B IF *TELEX* IS ENTERED.
*                         = 0 IF NO CHARACTERS.
*                (CSBW+2) = 6TH AND 7TH CHARACTERS OF THE PROCEDURE
*                           FILE NAME THAT THE OPERATOR ENTERED.
*                         = 0 IF NO CHARACTERS.
          SPACE  4
***       DAYFILE MESSAGES ISSUED.
*
*         * 1SI ILLEGAL REQUEST.*
*         QUEUE PRIORITY DOES NOT CORRESPOND TO ONE OF THE AFOREMEN-
*         TIONED SUBSYSTEMS.
*         * WAITING FOR STORAGE.*
*         1SI IS WAITING FOR THE FL REQUESTED.
          SPACE  4
*CALL     COMPMAC
*CALL     COMSACC
*CALL     COMSSCP
*CALL     COMSPFM
*CALL     COMSPRD
          TITLE  MACRO DEFINITIONS.
 SUBSYS   SPACE  4,10
**        SUBSYS - DEFINE SUBSYSTEM STARTUP PARAMETERS.
*
*         SUBSYS NAME,FL,CP
*                NAME = SUBSYSTEM NAME.
*                FL = INITIAL SUBSYSTEM FIELD LENGTH.
*                CP = INITIAL SUBSYSTEM CPU PRIORITY.


          PURGMAC  SUBSYS

 SUBSYS   MACRO  N,F,C
 ZERO     MICRO  1,3,*000*
 .N       MICRO  1,3,*N_ZERO*
          VFD    12/F,12/C
          VFD    42/0H_N,6/SYOT,12/0
          VFD    48/8LCALL(_".N",12/0
          VFD    60/0
          ENDM
          SPACE  4
*         SYMBOL DEFINITIONS.

 JC       EQU    27          JOB CONTROL INFORMATION ADDRESS
 CN       EQU    30 - 34     CM WORD BUFFER (5 LOCATIONS)
 SI       EQU    35          SUBSYSTEM INDEX
          SPACE  4
*         SUBSYSTEM INDICES.

 STMP     EQU    STPS-MNSC-1
 MCSP     EQU    MCPS-MNSC-1
 RBFP     EQU    RBPS-MNSC-1
 NAMP     EQU    NMPS-MNSC-1
 CDCP     EQU    CDPS-MNSC-1
 TAFP     EQU    TRPS-MNSC-1
 MSSP     EQU    MFPS-MNSC-1
 NVEP     EQU    NVPS-MNSC-1
 IAFP     EQU    TXPS-MNSC-1
 EXPP     EQU    EIPS-MNSC-1
          TITLE  MAIN PROGRAM.

*         MAIN PROGRAM.


          ORG    PPFW
 SSI      BSS    0
          RJM    PVE         PRESET FOR NOS/VE
          RJM    CEF         CHECK ERROR FLAG
          NJN    SSI1
          LDD    CP          READ QUEUE PRIORITY
          ADN    JCIW
          CRD    CM
          LDD    CM+1        CHECK FOR INVALID QUEUE PRIORITY
          ADC    -MNSC-1
          MJN    SSI1        IF NOT A SUBSYSTEM
          STD    SI
          RJM    ICP         INITIALIZE CONTROL POINT
          NJN    SSI1        IF ILLEGAL REQUEST
          MONITOR DPPM       DROP PPU
          LJM    PPR

 SSI1     LDC    =C* 1SI ILLEGAL REQUEST.*
          RJM    DFM         ISSUE DAYFILE MESSAGE
          MONITOR ABTM       ABORT CONTROL POINT
          LJM    PPR
          TITLE  SUBROUTINES.
 CEF      SPACE  4,10
***       CEF - CHECK ERROR FLAG.
*
*         EXIT   (A) = 0, IF NO ERROR FLAG.
*
*         USES   CM - CM+4.
*
*         CALLS  PRL.
*
*         MACROS PAUSE.


 CEF      SUBR               ENTRY/EXIT
          PAUSE
          LDD    CM+1
          ZJN    CEFX        IF NO ERROR FLAG SET
          LDD    CP          SET CONTROL CARD BUFFER EMPTY
          ADN    CSPW
          CRD    CM
          LDD    CM+4
          STD    CM+3
          LDD    CP
          ADN    CSPW
          CWD    CM
          UJN    CEFX        RETURN
 ICP      SPACE  4,10
***       ICP - INITIALIZE CONTROL POINT.
*
*         SET JOB NAME, CPU PRIORITY, REQUEST DESIRED STORAGE,
*         AND BUILD APPROPRIATE CONTROL STATEMENT BUFFER.
*
*         ENTRY  (SI) = SUBSYSTEM INDEX (QUEUE PRIORITY -MNSC -2).
*
*         EXIT   (A) .NE. 0 IF ILLEGAL REQUEST.
*
*         USES   JC, T0, T1, T2, CM - CM+4, CN - CN+4.
*
*         CALLS  CEF, CMX, ECX, FTN, RSI, RST.
*
*         MACROS MONITOR.


 ICP9     LDN    1           SET ERROR RETURN

 ICP      SUBR               ENTRY/EXIT

*         INITIALIZE CONTROL POINT.

          LDD    SI          CHECK VALIDITY OF SUBSYSTEM INDEX
          SBN    TCTRL+1
          PJN    ICP9        IF ILLEGAL REQUEST
          LDM    TCTR,SI     SET JOB CONTROL INFORMATION ADDRESS
          ZJN    ICP9        IF ILLEGAL REQUEST
          LDD    SI          CHECK IAF/TELEX INITIALIZATION
          SBN    IAFP
          NJN    ICP1        IF NOT IAF/TELEX INITIALIZATION
          LDD    CP          CHECK TELEX INITIALIZATION
          ADC    CSBW
          CRD    CN
          LDD    CN+1
          LMC    7777
          NJN    ICP1        IF NOT TELEX INITIALIZATION
          LDC    2REX        CHARACTERS 4 AND 5 OF *TELEX* TO BUFFER
          STD    CN+1
          LDD    CP
          ADC    CSBW
          CWD    CN
          LDC    TLXC        ADDRESS OF *TELEX* CONTROL TABLE
          UJN    ICP2        TELEX INITIALIZATON

 ICP1     LDM    TCTR,SI     ADDRESS OF JOB CONTROL INFORMATION TABLE
 ICP2     STD    JC
          ADN    2
          STM    ICPA
          ADN    7-2
          STM    ICPC
          ADN    13-7
          STM    ICPB
          LDD    CP          WRITE JOB NAME INTO CP AREA
          ADN    JNMW
          CWM    *,ON
 ICPA     EQU    *-1
          LDM    1,JC        SET CPU PRIORITY
          STD    CM+1
          LDN    0
          STD    CM+2
          MONITOR RPRM

*         REQUEST STORAGE.

 ICP3     LDM    0,JC        REQUEST FIELD LENGTH ASSIGNMENT
          ZJN    ICP4        IF NO FL REQUEST
          SBD    FL
          RJM    RSI
          ZJN    ICP5        IF FL ASSIGNED
          LDD    CP          SET WAITING FOR STORAGE
          ADN    MS2W
          CWM    =C*WAITING FOR STORAGE.*,TR
          RJM    CEF         CHECK ERROR FLAG
          ZJN    ICP3        IF NO ERROR FLAG, REISSUE FL REQUEST
 ICP4     LJM    ICP9        SET ERROR RESPONSE

 ICP5     LDN    0           CLEAR CONSOLE MESSAGE
          STD    CM
          LDD    CP
          ADN    MS2W
          CWD    CM

*         SET USER NUMBER AND USER INDEX.

          ADN    UIDW-MS2W
          CWM    UNUI,ON

*         SET CONTROL CARD BUFFER.

          LDD    CP          STORE CONTROL CARDS
          ADN    CSPW
          CRD    CM
          ADN    CSBW-CSPW   READ PROCEDURE FILE LETTERS
          CRD    CN
          LDC    CSBW
          STD    CM+3
          LDN    2           SET CM LENGTH OF CONTROL STATEMENT
          STD    T2
          ADC    CSBW
          STD    CM+4
          LDC    *
 ICPB     EQU    *-1
          STD    T1
          LDD    CN+1        SET PROCEDURE FILE NAME
          STI    T1
          ZJN    ICP6        IF NO CHARACTERS
          LPN    77
          ZJN    ICP7        IF ONE CHARACTER
          AOD    T1          ADVANCE CHARACTER ADDRESS
          LDD    CN+2
          STI    T1
          ZJN    ICP6        IF NO CHARACTERS
          LPN    77
          ZJN    ICP7        IF ONE CHARACTER
          AOD    T1          ADVANCE CHARACTER ADDRESS
 ICP6     LDC    1R)*100+1R)
 ICP7     LMN    1R)
          RAI    T1
          LDD    CP          UPDATE CONTROL STATEMENT POINTER WORD
          ADN    CSPW
          CWD    CM
          ADN    CSBW-CSPW
          CWM    *,T2
 ICPC     EQU    *-1

*         INITIALIZE SUBSYSTEM IDENTIFICATION WORD.

          LDN    ZERL        CLEAR SUBSYSTEM IDENTIFICATION WORD
          CRD    CM
          LDD    FL
          SBN    1
          MJN    ICP8        IF FL .LT. 100B
          LDD    RA          CLEAR SUBSYSTEM IDENTIFICATION WORD
          SHN    6
          ADN    SSIW
          CWD    CM
          ADN    1           CLEAR RECEIVING BUFFER WORD POINTER
          CWD    CM
          LDN    0           INDICATE NO ERRORS
 ICP8     LJM    ICPX        RETURN
 PVE      SPACE  4
**        PVE - PRESET FOR NOS/VE SUBSYSTEM.
*
*         USE *NVE* SUBSYSTEM RATHER THAT *MSS* IF A DUAL STATE
*         COMMUNICATION BLOCK IS DEFINED IN CMR.


 PVE      SUBR               ENTRY/EXIT
          LDC    DSBP
          CRD    CM          READ DUAL STATE BLOCK POINTER WORD
          LDD    CM
          ADD    CM+1
          ZJN    PVEX        IF NOT A DUAL STATE SYSTEM
          LDC    NVEC        CHANGE *MSS* ENTRY IN *TCTR* TO *NVE*
          STM    TCTR+NVEP
          UJN    PVEX        RETURN
          TITLE  TABLES.
 TCTR     SPACE  4,10
**        TCTR - JOB CONTROL TABLE.
*
*         ONE WORD ENTRY CONTAINING AN ADDRESS OF A JOB CONTROL WORD
*         FOR A PARTICULAR SUBSYSTEM.
*         INDEXED BY SUBSYSTEM INDEX (QUEUE PRIORITY - MNSC -2).


 TCTRL    MAX    RBFP,NAMP,TAFP,CDCP,MCSP,STMP,IAFP,EXPP

 TCTR     INDEX
          INDEX  MCSP,MCSC   ADDRESS OF *MCS* CONTROL TABLE
          INDEX  RBFP,RBFC   ADDRESS OF *RBF* CONTROL TABLE
          INDEX  NAMP,NAMC   ADDRESS OF *NAM* CONTROL TABLE
          INDEX  CDCP,CDCC   ADDRESS OF *CDCS* CONTROL TABLE
          INDEX  TAFP,TAFC   ADDRESS OF *TAF* CONTROL TABLE
          INDEX  STMP,STMC   ADDRESS OF *STIMULATOR*
          INDEX  MSSP,MSSC   ADDRESS OF *MSS* CONTROL TABLE
          INDEX  IAFP,IAFC   ADDRESS OF *IAF* CONTROL TABLE
          INDEX  EXPP,EXPC   ADDRESS OF *EI200* CONTROL TABLE
          INDEX  TCTRL+1
          SPACE  4
**        SUBSYSTEM CONTROL INFORMATION TABLE.
*
*T,       12/ FL , 12/ CP
*T,       42/ NAME , 6/*SYOT* , 12/0
*T,       60/ INITIAL SUBSYSTEM CONTROL CARD
*T,       60/ INITIAL SUBSYSTEM CONTROL CARD
*
*                FL = INITIAL SUBSYSTEM FIELD LENGTH.
*                CP = INITIAL SUBSYSTEM CPU PRIORITY
*                NAME = SUBSYSTEM NAME.
*
*         THE INITIAL SUBSYSTEM CONTROL CARD WILL BE A CALL TO
*         A PROCEDURE FILE THAT RESIDES ON USER NUMBER *SYSTEMX*.
*         THE PROCEDURE FILE NAME WILL BE CREATED AS FOLLOWS-
*                -THE FIRST THREE CHARACTERS OF THE PROCEDURE FILE
*                 NAME CONSISTS OF THE FIRST THREE CHARACTERS OF
*                 THE SUBSYSTEM NAME. IF THE SUBSYSTEM NAME IS LESS
*                 THAN THREE CHARACTERS, IT WILL BE PACKED WITH
*                 DISPLAY CODE ZERO,S.
*                -THE LAST FOUR CHARACTERS WILL BE SPECIFIED BY THE
*                 CONSOLE OPERATOR WHEN ENTERING THE SUBSYSTEM
*                 INITIATION DSD COMMAND.


 MCSC     SUBSYS MCS,60,MCCS
 RBFC     SUBSYS RBF,60,RBCS
 NAMC     SUBSYS NAM,60,NMCS
 CDCC     SUBSYS CDC,60,CZCS
 TAFC     SUBSYS TAF,60,TACS
 STMC     SUBSYS STM,60,60
 MSSC     SUBSYS MSS,60,MFCS
 NVEC     SUBSYS NVE,60,NVCS
 IAFC     SUBSYS IAF,600,IACS
 EXPC     SUBSYS EXP,60,EICS
 TLXC     SUBSYS TELEX,600,TXCS
          SPACE  4
**        USER NUMBER AND USER INDEX OF CONTROL POINT AREA.


 UNUI     VFD    42/7LSYSTEMX,18/SYUI
          SPACE  4
*         COMMON DECKS.

*CALL     COMPRJC
*CALL     COMPRSI
          END
*DECK DECK=PPP$HANDLE_FAULT_XXX EXPAND=FALSE

{
{    MONITOR FAULT HANDLERS - GENERAL:
{
{      For each monitor fault, corresponding to fault_id, a monitor
{      handler must be known to the monitor fault router.
{      router.
{
{      When a monitor fault is "received" by a task, the appropriate
{      fault handler is called by the fault router - current task
{      execution is preempted without regard to ring of execution. A
{      fault handler must be callable upto ring 13. The fault handler
{      is responsible for performing the necessary corrective action.
{      The specifics (structure) of a fault beyond ost$monitor_fault
{      are transparent to the monitor fault mechanism.
{
{      The general form of the interface to a fault handler is the
{      same for all fault identifiers.
{
{
{      EXAMPLE:
{
{   The purpose of this monitor fault is to process faults whose fault
{ identifiers are ppC$xxx, ...
{
{       ppP$handle_fault_xxx (FAULT, SAVE_AREA)
{
{ FAULT: (input) This parameter specifies the received monitor fault.
{
{ SAVE_AREA: (input) This parameter specifies the save area where the
{       fault occured.
{

  PROCEDURE [XREF] ppP$handle_fault_xxx (VAR fault: ost$monitor_fault;
    save_area: ^ost$stack_frame_save_area);

*copyc OST$MONITOR_FAULT
*copyc OST$STACK_FRAME_SAVE_AREA
*DECK DECK=PPP$HANDLE_FLAG_XXX EXPAND=FALSE

{
{    SYSTEM FLAG HANDLERS - GENERAL:
{
{      For each system flag, corresponding to flag_id, a system flag
{      handler must be known to the system flag router.
{
{      When a system flag is set in a task, the appropriate flag handler
{      is called by the flag router - non-NOS/VE code is preempted by
{      the flag handler.  It is the responsibility of a flag handler
{      to perform the actions associated with the system flag.
{
{      The general form of the interface to a flag handler is the same
{      for all flag_id's.
{
{
{      EXAMPLE:
{
{   The purpose of this flag handler is to process flags whose flag_id's
{ are ppC$xxx, ...
{
{       ppP$handle_flag_xxx (FLAG_ID)
{
{ FLAG_ID: (input) This parameter specifies the system flag which was
{       set.
{
{

  PROCEDURE [XREF] ppP$handle_flag_xxx (flag_id: ost$system_flag);

?? PUSH (LISTEXT := ON) ??
*copyc OST$SYSTEM_FLAG
?? POP ??
*DECK DECK=PPP$HANDLE_SIGNAL_XXX EXPAND=FALSE

{
{    SIGNAL HANDLERS - GENERAL:
{
{      For each signal, corresponding to signal_id, a signal handler
{      must be known to the signal router.
{
{      When a signal is "received" by a task, the appropriate signal
{      handler is called by the signal router - non-NOS/VE code is
{      preempted by the signal handler.  It is the responsibility of
{      signal handler to perform the actions specified by the signal.
{      The specifics (structure) of a signal beyond pmt$signal are
{      transparent to the signal mechanism.
{
{      The general form of the interface to a signal handler is the
{      same for all signal_id's.
{
{
{      EXAMPLE:
{
{   The purpose of this signal handler is to process signals whose
{ signal_id's are ppC$xxx, ...
{
{       ppP$handle_signal_xxx (ORIGINATOR, SIGNAL)
{
{ ORIGINATOR: (input) This parameter specifies the sender of the signal.
{
{ SIGNAL: (input) This parameter specifies the received signal.
{

  PROCEDURE [XREF] ppP$handle_signal_xxx (orginator: ost$global_task_id;
    signal: pmt$signal);

?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc PMT$SIGNAL
?? POP ??
*DECK DECK=PRODUCT_EPILOG EXPAND=TRUE
" All PRODUCT_FILES have been loaded to the $LOCAL catalog with file names
" which match their tape file identifiers.  The ring attributes of each file
" is (3, 13, 13).  If a file's BLOCK_TYPE=SYSTEM_SPECIFIED and RECORD_TYPE=
" UNKNOWN, the file was assumed to be an object library and the load process
" set the FILE_CONTENT to OBJECT and FILE_STRUCTURE to LIBRARY.

VAR
  rav$attach_status  : status
  rav$ignore_status  : status
  rav$local_file     : file
  rav$permanent_file : file
VAREND

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'
"
" During the deadstart process, the builtin library, operator library
" and sou library were copied from the deadstart file to $LOCAL.
"
" The following code loads the builtin library, operator library and
" sou library from $LOCAL to their permanent locations.
" The load is performed unconditionally.
" The assumption is made that the version of these files on the deadstart file
" is the version which should be used in production.
"
" Each file is attached.  If the attach is successful, the load can be performed.
" If the attach is not successful, all known file cycles are deleted, and the
" load is performed.
"
" If the attach was successful (ie. permanent file cycles already exist), it
" is important that they not be deleted before the load.  This is to allow
" recovering jobs which have previously attached these files to re-access
" them using the path handle name assigned on the attach.  Deleting these
" files will remove the path handle name from the path handle table.
"
" The load will be made to cycle 999 of each file.
"
" During an initial deadstart, no file cycles will be found, and the attach
" will fail.  However, the ignore status on the delete command makes an
" attempted delete acceptable.
"
" If the file or disk is corrupted, an attempt is made to delete all
" known cycles prior to loading the files to their permanent locations.
"
*IFEND

" Install $LOCAL.BUILTIN_LIBRARY to $SYSTEM.OSF$BUILTIN_LIBRARY.999.

rav$local_file = $local.builtin_library
rav$permanent_file = $system.osf$builtin_library

$system.attach_file f=rav$permanent_file am=all sm=none status=rav$attach_status
IF NOT rav$attach_status.normal THEN
  TASK ring=3
    REPEAT
      $system.delete_file f=rav$permanent_file status=rav$ignore_status
    UNTIL NOT rav$ignore_status.normal
  TASKEND
  request_mass_storage file=rav$permanent_file.999 file_class=q
IFEND

$system.copy_file i=rav$local_file o=rav$permanent_file.999
$system.detach_file f=rav$local_file

$system.change_file_attributes f=rav$permanent_file.999 ra=(3 13 13)
$system.create_file_permit f=rav$permanent_file.999 g=public
$system.detach_file f=rav$permanent_file.999

" Install $LOCAL.OPERATOR_LIBRARY to $SYSTEM.OSF$OPERATOR_LIBRARY.999

rav$local_file = $local.operator_library
rav$permanent_file = $system.osf$operator_library

$system.attach_file f=rav$permanent_file am=all sm=none status=rav$attach_status
IF NOT rav$attach_status.normal THEN
  TASK ring=3
    REPEAT
      $system.delete_file f=rav$permanent_file status=rav$ignore_status
    UNTIL NOT rav$ignore_status.normal
  TASKEND
  request_mass_storage file=rav$permanent_file.999 file_class=q
IFEND

$system.copy_file i=rav$local_file o=rav$permanent_file.999
$system.detach_file f=rav$local_file

$system.change_file_attributes f=rav$permanent_file.999 ra=(3 13 13)
$system.detach_file f=rav$permanent_file.999

" Install $LOCAL.SOU_LIBRARY to $SYSTEM.OSF$SOU_LIBRARY.999.

rav$local_file = $local.sou_library
rav$permanent_file = $system.osf$sou_library

$system.attach_file f=rav$permanent_file am=all sm=none status=rav$attach_status
IF NOT rav$attach_status.normal THEN
  TASK ring=3
    REPEAT
      $system.delete_file f=rav$permanent_file status=rav$ignore_status
    UNTIL NOT rav$ignore_status.normal
  TASKEND
  request_mass_storage file=rav$permanent_file.999 file_class=q
IFEND

$system.copy_file i=rav$local_file o=rav$permanent_file.999
$system.detach_file f=rav$local_file

$system.change_file_attributes f=rav$permanent_file.999 ra=(3 13 13)
$system.create_file_permit f=rav$permanent_file.999 g=public
$system.detach_file f=rav$permanent_file.999

$system.delete_variable n=rav$ignore_status
$system.delete_variable n=rav$attach_status
$system.delete_variable n=rav$local_file
$system.delete_variable n=rav$permanent_file
*DECK DECK=PTE$ECC_ANABL_EXCEPTIONS EXPAND=FALSE

?? NEWTITLE := 'pte$analyze_binary_log ----- ''PT'' 2000 .. 2500', EJECT ??
?? FMT (FORMAT := OFF) ??
{ Internal logging error codes.

*copyc pte$ecc_range_os

  CONST
    ptc$analyze_binary_log_e = ptc$min_ecc + 2000,
    ptc$analyze_binary_log_id = 'PT',

    pte$change_put_parameters_putf  = ptc$analyze_binary_log_e + 0,
    {E Parameters DISPLAY_HEADER, REPORT_INTERVAL, ROW_LABEL, ROW_LABEL_FORMAT}
    {, STRING, PAGE_HEADER, POP_COUNT, USE_PAGE_HEADERS, SELECTION and COUNTER}
    { are not allowed if put type is put_field.}

    pte$change_put_parameters_putfs = ptc$analyze_binary_log_e + 1,
    {E Parameters REPORT_INTERVAL, STRING, PAGE_HEADER, POP_COUNT,
    { USE_PAGE_HEADERS, SELECTION, ROW_LABEL and COUNTERS are not allowed}
    { if put type is put_field_summary.}

    pte$change_put_parameters_putif = ptc$analyze_binary_log_e + 2,
    {E Parameters DISPLAY_HEADER, STRING, PAGE_HEADER, POP_COUNT,}
    { USE_PAGE_HEADERS, SELECTION, ROW_LABEL_FORMAT and COUNTER are not}
    { allowed if put type is put_interval_field.}

    pte$change_put_parameters_putr  = ptc$analyze_binary_log_e + 3,
    {E Parameters DISPLAY_HEADER, REPORT_INTERVAL, ROW_LABEL, ROW_LABEL_FORMAT}
    {, FIELD, PAGE_HEADER, POP_COUNT, USE_PAGE_HEADERS, and STRING are not}
    { allowed if put type is put_record.}

    pte$change_put_parameters_puts  = ptc$analyze_binary_log_e + 4,
    {E Parameters DISPLAY_HEADER, REPORT_INTERVAL, ROW_LABEL, ROW_LABEL_FORMAT}
    {, FIELD, PAGE_HEADER, POP_COUNT, USE_PAGE_HEADERS, SELECTION and COUNTER}
    { are not allowed if put type is put_string.}

    pte$counter_and_text           = ptc$analyze_binary_log_e + 5,
    {E Both COUNTER and TEXT parameters specified, specify only one of them.}

    pte$counter_changed             = ptc$analyze_binary_log_e + 6,
    {E Counter +P1 is specified for put, but was already specified on the list}
    { of counters.}

    pte$counters_changed             = ptc$analyze_binary_log_e + 7,
    {E ALL is specified for COUNTER in put, but range of counters was already }
    {specified.}

    pte$date_time_range_order       = ptc$analyze_binary_log_e + 8,
    {E Range specified for DATE_TIME must be in ascending order.}

    pte$duplicate_file_name        = ptc$analyze_binary_log_e + 9,
    {E The file name +F specified more than once.}

    pte$duplicate_name             = ptc$analyze_binary_log_e + 10,
    {E The name +P specified more than once.}

    pte$duplicate_numbers          = ptc$analyze_binary_log_e + 11,
    {E The number +P specified more than once.}

    pte$error_processing_parameter  = ptc$analyze_binary_log_e + 12,
    {E Error processing parameter +P1.}

    pte$field_has_put              = ptc$analyze_binary_log_e + 13,
    {E FIELD +P1 cannot be deleted because it is referenced by a put entry(s).}

    pte$field_out_of_line_limits   = ptc$analyze_binary_log_e + 14,
    {E +P1 starting at column +P2 with width +P3 exceeds maximum line }
    {length.}

    pte$field_overlap               = ptc$analyze_binary_log_e + 15,
    {E +P1 starting at column +P2 overlaps previously defined field.}

    pte$generate_log_mode           = ptc$analyze_binary_log_e + 16,
    {E This command is not allowed while a put_record is defined.}

    pte$generate_none_mode          = ptc$analyze_binary_log_e + 17,
    {E This command is not allowed because no put(s) have been defined.}

    pte$generate_report_mode        = ptc$analyze_binary_log_e + 18,
    {E This command is not allowed while a put_field, put_interval_field, }
    {put_field_summary or put_string is defined.}

    pte$header_overflow              = ptc$analyze_binary_log_e + 19,
    {E Header '+P1' with length +P2 is longer than field width +P3.}

    pte$invalid_global_task_id     = ptc$analyze_binary_log_e + 20,
    {E +P1 is an invalid global task id.}

    pte$low_greater_than_high       = ptc$analyze_binary_log_e + 21,
    {E COUNTER range +P1 specified for put, must be in ascending order.}

    pte$mising_dtf_field            = ptc$analyze_binary_log_e + 22,
    {E Parameter ROW_LABEL_FORMAT for put_interval_field requires the }
    {date_time_format field.}

    pte$not_counter                 = ptc$analyze_binary_log_e + 23,
    {E Parameters MULTIPLIER, INCREMENTAL and COUNTER are not allowed if field}
    { is TEXT.}

    pte$not_counter_and_text       = ptc$analyze_binary_log_e + 24,
    {E Must specify either the COUNTER or TEXT parameter.}

    pte$not_descriptive_data        = ptc$analyze_binary_log_e + 25,
    {E Parameter TEXT is not allowed if field is COUNTER.}

    pte$not_put_and_number         = ptc$analyze_binary_log_e + 26,
    {E Must specify either the PUT or NUMBER parameter.}

    pte$predecessor_itself         = ptc$analyze_binary_log_e + 27,
    {E Selection not permited to be a predecessor of itself.

    pte$put_and_number             = ptc$analyze_binary_log_e + 28,
    {E Both PUT and NUMBER parameters specified, specify only one of them.}

    pte$redefined_field            = ptc$analyze_binary_log_e + 29,
    {E Field +P1 was already defined, specify a different name.}

    pte$redefined_put               = ptc$analyze_binary_log_e + 30,
    {E Put +P1 was already defined, specify different name.}

    pte$redefined_selection            = ptc$analyze_binary_log_e + 31,
    {E Selection +P1 was already defined, specify different name.}

    pte$selection_has_field            = ptc$analyze_binary_log_e + 32,
    {E Selection +P1 cannot be deleted because it is referenced by a field(s).}

    pte$selection_has_put              = ptc$analyze_binary_log_e + 33,
    {E Selection +P1 cannot be deleted because it is referenced by a put entry.}

    pte$selection_has_successor        = ptc$analyze_binary_log_e + 34,
    {E Selection +P1 cannot be deleted because it is referenced by a successor }
    {selection(s).}

    pte$selec_ref_by_another_put    = ptc$analyze_binary_log_e + 35,
    {E Selection +P1 cannot be specified for put because it is already referenced by }
    {another put.}

    pte$string_overflow             = ptc$analyze_binary_log_e + 36,
    {E String '+P1' length +P2 is longer than field width +P3.}

    pte$sum_overflow                = ptc$analyze_binary_log_e + 37,
    {E Sum overflow in counter +P1.}

    pte$task_id_index_out_of_range  = ptc$analyze_binary_log_e + 38,
    {E Task id index is out of range 0 .. 65535.}

    pte$task_id_seqno_out_of_range = ptc$analyze_binary_log_e + 39,
    {E Task id seqno is out of range 0 .. 255.}

    pte$too_many_fields             = ptc$analyze_binary_log_e + 40,
    {E Parameter ROW_LABEL_FORMAT for put_field_summary doesn't have the }
    {date_time_format field.}

    pte$undefined_field_for_change = ptc$analyze_binary_log_e + 41,
    {E Field +P1 is specified for change, but is not defined.}

    pte$undefined_field_for_delete = ptc$analyze_binary_log_e + 42,
    {E Field +P1 is specified for delete, but is not defined.}

    pte$undefined_field_for_dis    = ptc$analyze_binary_log_e + 43,
    {E Field +P1 is specified for display, but is not defined.}

    pte$undefined_field_for_put    = ptc$analyze_binary_log_e + 44,
    {E Field +P1 is specified for put, but is not defined.}

    pte$undefined_put_for_change    = ptc$analyze_binary_log_e + 45,
    {E Put +P1 is specified for change, but is not defined.}

    pte$undefined_put_for_delete    = ptc$analyze_binary_log_e + 46,
    {E Put +P1 is specified for delete, but is not defined.}

    pte$undefined_put_for_dis       = ptc$analyze_binary_log_e + 47,
    {E Put +P1 is specified for display, but is not defined.}

    pte$undefined_selec_for_change = ptc$analyze_binary_log_e + 48,
    {E Selection +P1 is specified for change, but is not defined.}

    pte$undefined_selec_for_delete = ptc$analyze_binary_log_e + 49,
    {E Selection +P1 is specified for delete, but is not defined.}

    pte$undefined_selec_for_dis    = ptc$analyze_binary_log_e + 50,
    {E Selection +P1 is specified for display, but is not defined.}

    pte$undefined_selec_for_field  = ptc$analyze_binary_log_e + 51,
    {E Selection +P1 is specified for field, but is not defined.}

    pte$undefined_selec_for_predec = ptc$analyze_binary_log_e + 52,
    {E Selection +P1 is specified for predecessor, but is not defined.}

    pte$undefined_selec_for_put    = ptc$analyze_binary_log_e + 53,
    {E Selection +P1 is specified for put, but is not defined.}

    pte$unexpected_end_of_file      = ptc$analyze_binary_log_e + 54,
    {E Unexpected end of file while reading +F1.}

    pte$job_and_task_predecessor   = ptc$analyze_binary_log_e + 55,
    {E Both JOB PREDECESSOR and TASK PREDECESSOR parameters specified, specify only one of them.}

    pte$task_predecessor_defined   = ptc$analyze_binary_log_e + 56,
    {E JOB PREDECESSOR specified while TASK PREDECESSOR is defined.}

    pte$job_predecessor_defined    = ptc$analyze_binary_log_e + 57,
    {E TASK PREDECESSOR specified while JOB PREDECESSOR is defined.}

    pte$circular_predecessor       = ptc$analyze_binary_log_e + 58,
    {E Circular predecessor definition is not allowed.}

    pte$mixed_selections           = ptc$analyze_binary_log_e + 59,
    {W The fields in put entry +P1 belong to more than one selection.}

    pte$all_occurrences_and_other   = ptc$analyze_binary_log_e + 60,
    {E Cannot mix ALL_OCCURRENCES display_option with other display_options in one PUT_FIELD. }

    pte$non_supported_summary_putif = ptc$analyze_binary_log_e + 61,
    {E Put interval field doesn't support LAST_OCCURRENCE and ALL_OCCURRENCE summary.}

    pte$many_field_type_parameters  = ptc$analyze_binary_log_e + 62,
    {E Only one of COUNTER, DESCRIPTIVE_DATA, HEADER, ELAPSED_TIME, STRING and ELAPSED_TIME_CALCULATION }
    {parameters may be specified, specify only one of them.}

    pte$no_field_type_parameter     = ptc$analyze_binary_log_e + 63,
    {E One of COUNTER, DESCRIPTIVE_DATA, HEADER, ELAPSED_TIME, STRING or ELAPSED_TIME_CALCULATION }
    {parameters must be specified.}

    pte$no_counter_in_etc_vps       = ptc$analyze_binary_log_e + 64,
    {E COUNTER_NUMBER field must be specified in parameter ELAPSED_TIME_CALCULATION when VALUE_PER_SECOND }
    {keyword specified for CALCULATION field.}

    pte$counter_in_etc_ops          = ptc$analyze_binary_log_e + 65,
    {E Counter attributes (COUNTER_NUMBER, MULTIPLIER, INCREMENTAL and ALLOW_NEGATIVE_INCREMENT) are not }
    {allowed when ELAPSED_TIME_CALCULATION is OCCURRENCE_PER_SECOND.

    pte$no_calculation_in_etc       = ptc$analyze_binary_log_e + 66,
    {E Parameter ELAPSED_TIME_CALCULATION was specified  without specifing the requierd CALCULATION field.}

    pte$no_elapsed_time_in_etc      = ptc$analyze_binary_log_e + 67,
    {E Parameter ELAPSED_TIME_CALCULATION was specified  without specifing the requierd ELAPSED_TIME field.}

    pte$no_counter_number           = ptc$analyze_binary_log_e + 68,
    {E Parameter COUNTER was specified without specifing the requierd COUNTER_NUMBER field.}

    pte$unsupported_display_option  = ptc$analyze_binary_log_e + 69,
    {E Display_options +P1 was specified for field +P2. This display_option isn't supported for field type }
    {+P3. }

    pte$field_is_not_a_counter     = ptc$analyze_binary_log_e + 70,
    {E Field +P1 is specified for put field summary, but is not a counter.}

    pte$headers_and_not_list     = ptc$analyze_binary_log_e + 71,
    {E Page headers specified in report list, but display_format LIST not chosen for generate_report.}

    pte$change_put_parameters_pusph  = ptc$analyze_binary_log_e + 72,
    {E Parameters DISPLAY_HEADER, REPORT_INTERVAL, ROW_LABEL, ROW_LABEL_FORMAT}
    {, FIELD, STRING, POP_COUNT, USE_PAGE_HEADERS, SELECTION and COUNTER}
    { are not allowed if put type is put_string.}

    pte$change_put_parameters_popph  = ptc$analyze_binary_log_e + 73,
    {E Parameters DISPLAY_HEADER, REPORT_INTERVAL, ROW_LABEL, ROW_LABEL_FORMAT}
    {, FIELD, PAGE_HEADER, STRING, USE_PAGE_HEADERS, SELECTION and COUNTER}
    { are not allowed if put type is put_string.}

    pte$change_put_parameters_putnp  = ptc$analyze_binary_log_e + 74,
    {E Parameters DISPLAY_HEADER, REPORT_INTERVAL, ROW_LABEL, ROW_LABEL_FORMAT}
    {, FIELD, PAGE_HEADER, POP_COUNT, STRING, SELECTION and COUNTER}
    { are not allowed if put type is put_string.}

    pte$no_input_logs = ptc$analyze_binary_log_e + 75,
    {E No default input log, so must specify input log for command.}

    pte$put_length_gt_page_width = ptc$analyze_binary_log_e + 76,
    {E Length of put exceeds file page width.}
    {      Put Number:  +P1 }

    pte$no_predecessor_for_et = ptc$analyze_binary_log_e + 77,
    {W Elapsed time based on predecessor, but this FIELD's SELECTION has no predecessor defined.}

    pte$scratch_segment_error = ptc$analyze_binary_log_e + 78,
    {E An error occurred in an internal scratch segment.}

    pte$incr_or_mult_not_allowed = ptc$analyze_binary_log_e + 79,
    {E INCREMENTAL and MULTIPLIER not allowed with this field type.}

    ptc$max_analyze_binary_log_e = ptc$analyze_binary_log_e+ 79;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=PTE$ECC_RANGE_OS EXPAND=FALSE

  CONST
    pt          = 'PT',
    ptc$min_ecc = (($INTEGER ('P') * 100(16)) + $INTEGER ('T')) * 1000000(16),
    ptc$max_ecc = ptc$min_ecc + 9999;
*DECK DECK=PTH$ANABL_ADD_FIELD EXPAND=FALSE
{    The purpose of this command is to allow the user to name a counter, descriptive
{ data field, or header field associated with a record.  Parameters are also
{ available that modify the value of the raw data to be used as the value of
{ the field (incremental, multiplier).  These named fields can be referred to
{ in the 'put_field_summary', 'put_interval_field', and 'put_field' report
{ specification commands.
{
{ FIELD:  This parameter is the name of the specified data item.  It must be a
{       valid SCL name.
{
{ SELECTION:  This parameter specifies the record the field is to be taken from.
{       Valid values for this parameter are selection names (SCL name).  If the
{       selection has not been defined, ANABL will issue an error.  In this case,
{       the field will not be defined.
{
{ COUNTER:  This parameter specifies which counter of the named record to use
{       for this field.  Either this parameter or the text parameter must be
{       non-null.  A value of NONE means a counter is not specified.  The
{       current maximum counter number is 255.
{
{ TEXT:  This parameter specifies a string to be named.  Most often this will
{       be used to name the descriptive data field or a substring of the
{       descriptive data field.  Either the text parameter or the counter
{       parameter must be specified.
{
{ MULTIPLIER:  This parameter specifies an integer to be used as a multiplier
{       for all values of the field.  To specify a divisor, you may either
{       specify the decimal ptc$fraction, (i.e. a divisor of 1000 is a multiplier
{       of .001) or you may specify the real expression (i.e. 1/1000).
{
{ INCREMENTAL:  This parameter specifies how field values are to be calculated.
{       If 'incremental' is false, then the value of the field is just as it is
{       found in the counter.  If 'incremental' is true, then the value of the
{       field is computed by subtracting the values of consecutive occurrences
{       of the counter and using this result as the value.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$counter_and_text
{             pte$not_counter_and_text
{             pte$redefined_field
{             pte$undefined_selec_for_field
*DECK DECK=PTH$ANABL_ADD_SELECTION EXPAND=FALSE
{    The purpose of this command is the initial creation of a selection.  Selections
{ are the definitions of what data is to be chosen from the input binary log.
{
{ SELECTION:  This parameter defines the name of the selection.  The name
{       specified here can be used throughout ANABL to refer to the selection.
{       Valid values for this parameter are SCL names.
{
{ STATISTIC_CODE:  The statistic is the primary criterion that defines possible
{       membership in a selection.  Valid values for this parameter are statistic
{       names (ie.  JM3, PM5, etc.) or the keyword NONE.  ANABL does not check
{       to see if the specified name is actually a statistic, but does check to
{       insure the specified value has the correct format for a statistic code.
{       Use of the keyword NONE causes selection of all statistics satisfying
{       the other selection criteria.  That is, the statistic identifier is not
{       a selection criterion.
{
{ TIME:  This optional parameter allows the user to restrict membership in a
{       selection to only those statistics that were emitted on the specified date
{       or within the specified date_time range.  Valid values for this
{       parameter are a single date_time or a range of date_time values.  This
{       parameter is used to specify dates, times, or both dates and times.
{       Values can be specified in any standard SCL date_time string format.
{       The null string (= '') means that date and/or time will not be a
{       selection criterion.  In this case, if all other selection criteria
{       match, a statistic will be selected no matter what date_time it was
{       emitted on.
{
{ CONTINUOUS_DATE_TIME:  The continuous_date_time parameter is used to modify
{       date_time selection.  Time selection is based on the time and
{       continuous_date_time parameters.  The value of the continuous_date_time
{       parameter affects how the values of the time parameter are interpreted
{       in the special case when both date and time are specified as a range.
{       All other cases have unambiguous interpretations, so the value of the
{       continuous_date_time parameter is irrelevant in these cases.  When the
{       value of the continuous_date_time parameter is FALSE, then the
{       specified time range is treated independently from the date range.
{       That is, for every date in the date range, selection selection is based on
{       the time range for that day.  A statistic in the input log satisfies
{       the time selection criteria if it was emitted on a date within the date
{       range and if on that date, it was emitted at a time within the time
{       range.  This is the way one would normally treat time range selection
{       if date selection were based on a single day or not specified at all.
{       When the value of the continuous_date_time parameter is TRUE, then the
{       two ranges, date and time, must be considered together.  The first time
{       in the time range only applies to the first date in the date range.
{       The second time in the time range only applies to the second date in
{       the date range.  A statistic in the input log satisfies the time
{       selection criteria if it occurs after the first time and date
{       combination, but before the second time and date combination.  Thus,
{       while the date the statistic was emitted on must fall withing the date
{       range, the time the statistic was emitted at is only important if the
{       date the statistic was emitted on is an endpoint of the date range.  In
{       fact, the second time range endpoint does not have to be greater than
{       the first.
{
{ DESCRIPTIVE_DATA:  This optional parameter allows the user to restrict
{       membership in a selection to only those statistics having a descriptive
{       data field that matches this specified string.  Values for this
{       parameter must be strings.  The null string (= '') means that the
{       descriptive data field will not be a selection criterion.  In this
{       case, if all other selection criteria match, a statistic will be
{       selected no matter what the value of its descriptive data is, or even
{       whether it does or does not have a descriptive data field.
{
{ JOB_PREDECESSOR:  This optional parameter allows the user to restrict
{       membership in a selection to only those statistics belonging to a job that
{       has previously logged a statistic that belongs to the specified selection.
{       Valid values for this parameter are SCL names.  These names must be
{       previously defined selection names.  A selection can only have one
{       job_predecessor selection.  It may have many successors.  The keyword NONE
{       means that job_predecessor will not be a selection criterion.
{
{ TASK_PREDECESSOR:  This optional parameter allows the user to restrict
{       membership in a selection to only those statistics belonging to a task
{       that has previously logged a statistic that belongs to the specified
{       selection.  Valid values for this parameter are SCL names.  These names must
{       be previously specified selection names.  A selection can only have one
{       task_predecessor selection.  It may have many successors.  The keyword
{       NONE means that task_predecessor will not be a selection criterion.
{
{ SYSTEM_JOB_NAME:  This optional parameter allows the user to restrict
{       membership in a selection to only those statistics that were emitted by
{       the specified job.  Valid value for this parameter is system supplied
{       job name.  The keyword NONE means ANABL will not use the job name as a
{       selection criterion.  In this case, if all other criteria match, a
{       statistic will be selected no matter what the value of its system
{       supplied job name is.
{
{ GLOBAL_TASK_ID:  This optional parameter allows the user to restrict
{       membership in a selection to only statistics that were emitted by the
{       specified task.  Valid value for this parameter is string specifying a
{       global task id.  The null string (='') means ANABL will not use the
{       task name as a selection criterion.  In this case, if all other
{       criteria match, a statistic will be selected no matter what the value
{       of its global task id is.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$date_time_e1
{             pte$invalid_global_task_id
{             pte$redefined_selection
{             pte$task_id_index_out_of_range
{             pte$task_id_seqno_out_of_range
{             pte$undefined_selec_for_predec
*DECK DECK=PTH$ANABL_CHANGE_FIELD EXPAND=FALSE
{    The purpose of this command is to allow the user to change attribute
{ values of an existing field.  The field to be changed is specified by the
{ field parameter.  If the field name is to be changed, the new name is given
{ in the new_field parameter.  All references to the field will be changed to
{ reflect the name change.  All other attribute value changes are accomplished
{ via parameters exactly as described in the add_field command.
{
{ FIELD:  This is the name of the field that is to be changed.  If the
{       specified name does not match an existing field, an error is issued
{       stating this and no fields are changed.
{
{ NEW_FIELD:  This parameter is the new name for the specified field.
{
{ RECORD:  The meaning of this parameter is the same as what is described in
{       the add_field command.
{
{ COUNTER:  The meaning of this parameter is the same as what is described in
{       the add_field command.
{
{ TEXT:  The meaning of this parameter is the same as what is described in the
{       add_field command.
{
{ MULTIPLIER:  The meaning of this parameter is the same as what is described
{       in the add_field command.
{
{ INCREMENTAL:  The meaning of this parameter is the same as what is described
{       in the add_field command.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$not_counter
{             pte$not_descriptive_data
{             pte$redefined_field
{             pte$undefined_field_for_change
{             pte$undefined_selec_for_field
*DECK DECK=PTH$ANABL_CHANGE_PUT EXPAND=FALSE
{    The purpose of this command is to allow the user to change a single output
{ list entry.  This is accomplished by using the put command output list
{ ordinal or optional name to select the report entry to be changed.  The
{ remaining parameters of this command can be used to change the relevant
{ attributes of the report entry.  Not all attributes will apply to all report
{ entries.  In the case where a user incorrrectly attempts to change an
{ attribute, ANABL will issue an informative error message.
{
{ PUT:  See the put_field_summay command for a description of this parameter.
{
{ NUMBER:  See the put_field_summay command for a description of this
{       parameter.
{
{ NEW_PUT:  This parameter allows the user to change the name of the selected
{       report entry.  This is valid for all report entries.
{
{ NEW_NUMBER:  This parameter allows the user to change the relative position
{       of the selected report entry in the report.  This is valid for all
{       report entries.
{
{ FIELD:  This parameter allows the user to change the list of fields
{           reported by the selected report entry.  This is valid for
{           put_field_summary, put_interval_field, and put_field.  The format
{           of this parameter is different from the field parameter of the
{           put_field_summary command.  You can change the field parameter of
{           the put_field_summary command using this format by specifying the
{           field_name field of this parameter, but not the summary calculation
{           field of this parameter.  If you specify a list of field_names for
{           a put_field_summary, you will have to enclose the list in double
{           parentheses rather than just single parentheses.  (ie chap p=sample
{           f=((f1,f2,f3)).)
{
{ SUMMARY_CALCULATION:  This parameter allows the user to change the
{       summary_calculations reported by a put_field_summary entries.  It is
{       not valid for any other report command.
{
{ DISPLAY_HEADERS:  This parameter allows the user to change the selection of
{       the display_headers parameter of put_field_summary entries.
{
{ ROW_LABEL:  This parameter allows the user to change the row labels of report
{       entries.
{
{ REPORT_INTERVAL:  This parameter allows the user to select a different report
{       interval for a put_interval_field command.
{
{ STRING:  This parameter allows the user to change the strings specified by a
{       put_strings entry.  It does not apply to other report entry types.
{
{ SELECTIONS:  This parameter allows the user to change the selections reported on a
{       put_record.
{
{ COUNTERS:  This parameter allows the user to select a different subset of
{       counters to be output from a put_record.
{
{ DESCRIPTIVE_DATA:  This parameter allows the user to select a different
{       substring of the descriptive data field to be output from a put_record
{       command.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$change_put_parameters_putf
{             pte$change_put_parameters_putfs
{             pte$change_put_parameters_putif
{             pte$change_put_parameters_putr
{             pte$change_put_parameters_puts
{             pte$counter_changed
{             pte$counters_changed
{             pte$duplicate_name
{             pte$error_processing_parameter
{             pte$field_out_of_line_limits
{             pte$field_overlap
{             pte$generate_none_mode
{             pte$header_overflow
{             pte$low_greater_than_high
{             pte$not_put_and_number
{             pte$put_and_number
{             pte$redefined_put
{             pte$selec_ref_by_another_put
{             pte$string_overflow
{             pte$undefined_field_for_put
{             pte$undefined_put_for_change
{             pte$undefined_selec_for_put
*DECK DECK=PTH$ANABL_CHANGE_SELECTION EXPAND=FALSE
{    This procedure processes the change_selection command.
{
{    The purpose of this command is to allow the user to change any of the
{ attributes of an existing record.  The record to be changed is identified by
{ the record parameter.  If one of the attributes to be changed is the record
{ name, this is done by specifying the new name in the new_record parameter.
{ In all other cases, the parameters have the same meaning as in the
{ add_selection command.
{
{ RECORD:  This is the name of the record the command is to change the
{       definition of.
{
{ NEW_RECORD:  Using this parameter causes the record name to be changed to the
{       value specified.  If this parameter is omitted, the name stays the
{       same.  Valid values for this parameter are SCL names.  All existing
{       references to the old name are changed to references to the new name.
{
{ STATISTIC:  This parameter has the same meaning as is described for the
{       add_selection command.
{
{    TIME :  This parameter has the same meaning as is described for the
{ add_selection command.
{
{ CONTINUOUS_DATE_TIME:  This parameter has the same meaning as is described
{       for the add_selection command.
{
{ DESCRIPTIVE_DATA:  This parameter has the same meaning as is described for
{       the add_selection command.
{
{ JOB_PREDECESSOR:  This parameter has the same meaning as is described for the
{       add_selection command.
{
{ TASK_PREDECESSOR:  This parameter has the same meaning as is described for
{       the add_selection command.
{
{ SYSTEM_JOB_NAME:  This parameter has the same meaning as is described for the
{       add_selection command.
{
{ GLOBAL_TASK_ID:  This parameter has the same meaning as is described for the
{       add_selection command.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$date_time_e1
{             pte$invalid_global_task_id
{             pte$redefined_selection
{             pte$task_id_index_out_of_range
{             pte$task_id_seqno_out_of_range
{             pte$undefined_selec_for_change
{             pte$undefined_selec_for_predec
*DECK DECK=PTH$ANABL_DELETE_FIELD EXPAND=FALSE
{    The purpose of this command is to allow users to delete existing field
{ definitions.  If a report entry references the named field, an error message
{ stating this will be issued, and the field will not be deleted.
{
{ FIELD:  The user may specify one field name, a list of field names, or the
{       keyword ALL.  If ANABL does not find a match for a specified field
{       name, it prints an error message giving the name that could not be
{       matched and continues with the next name to be deleted.  If ALL is
{       specified, then all field definitions are deleted.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$duplicate_name
{             pte$error_processing_parameter
{             pte$field_has_put
{             pte$undefined_field_for_delete
*DECK DECK=PTH$ANABL_DELETE_PUT EXPAND=FALSE
{ Selection of the report entries to be deleted is based solely on the report
{ entry ordinal.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$duplicate_name
{             pte$duplicate_numbers
{             pte$error_processing_parameter
{             pte$generate_none_mode
{             pte$undefined_put_for_delete
{             pte$not_put_and_number
{             pte$put_and_number
*DECK DECK=PTH$ANABL_DELETE_SELECTION EXPAND=FALSE
{    The purpose of this command is to allow the user to delete selections.
{ Deletion of a selection removes the selection from
{ ANABL's list of selections.  Once a selection is deleted, it cannot be
{ reused unless it is again created via an add_selection command.  All fields
{ associated with that selection must also be redefined using the add_field
{ command.  If a report entry references a selection that is to be deleted, an
{ error message stating this will be issued and the selection and its associated
{ fields will not be deleted.
{
{ SELECTION:  Valid values for this parameter are one SCL name, a list of SCL
{       names, or the keyword ALL.  If ANABL matches a specified name to the
{       name of a selection, that selection is deleted.  If no match is found for a
{       specified selection, ANABL dislays a message noting this and continues on
{       with the next name to be deleted.  If the keyword ALL is specified, all
{       selections are deleted.
{
{    - The procedure checks for selections that are pointing to FIELD & PUT.  If
{ any pointing of that kind exists in any of the selections, the user gets an
{ error message and is asked to corect the selection parameter.  - The delete
{ procedure decrements the successor count (job & task) of the predecessor
{ selection before deleting the selection.  - If the selection parameter is of list kind
{ then the procedure builds a list of selections to delete and tries to delete the
{ selections from the list.  - If a selection does not exist then the user gets an
{ error message and the procedure continues on with next selection tto be deleted.
{ - If a selection has a successor then the procedure puts it in a new list to be
{ deleted.  Hopefully, the sucessor selection will be on the list of selections to
{ delete.  Then procedure continues to delete the remainder of the list.  It
{ then tries to delete the new list.  The process continues to loop until no
{ more selections are deleted or the remainder list is empty.  Then if any selections
{ are left undeleted the user receives an error messege.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$duplicate_name
{             pte$error_processing_parameter
{             pte$selection_has_field
{             pte$selection_has_put
{             pte$selection_has_successor
{             pte$undefined_field_for_delete
*DECK DECK=PTH$ANABL_DISPLAY_FIELD EXPAND=FALSE
{    The purpose of this command is to allow the user to view the current field
{ definitions.
{
{ FIELD:  This parameter specifies the names of the fields to be displayed.  If
{       a named field is not found, ANABL prints an error message noting this,
{       and attempts to display the next field that was requested.  If the
{       keyword ALL is specified, then ANABL displays all defined fields.
{
{ DISPLAY_OPTION:  Two display options are available.  The display option NAME
{       causes just the names of fields to be displayed.  The display option
{       ALL causes all field attributes including the name to be displayed.
{
{ output:  This parameter allows the user to specify the file the field display
{       is written to.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$duplicate_name
{             pte$error_processing_parameter
{             pte$undefined_field_for_dis
*DECK DECK=PTH$ANABL_DISPLAY_LOGGED_STAT EXPAND=FALSE
{    The purpose of this command is to show the user what statistics exist in
{ the binary log.  The user can choose to see just the names of the statistics
{ in the log, or can obtain a more descriptive summary of the statistics in the
{ binary log.  The data for the 'full' report is always kept after this command
{ has been executed once.  This data is kept until the input log is changed to
{ a different file.  The data is kept to minimize the number of times the log
{ is read.
{
{
{ input:  This is the name of the binary log to be read.  It is an optional
{       parameter since the log to be read may already have been specified by
{       the change_defaults command.
{
{ output:  This is the name of the file the logged statistics report is to be
{       written to.
{
{ display_option:  This parameter selects what information is displayed to the
{       user.  The keyword NAMES causes ANABL to just display the names of
{       the logged statistics.  The keyword ALL causes ANABL to display the
{       name, number of occurrences in the log, time of first occurrence, time
{       of last occurrence, date of first occurrence, date of last occurrence
{       in the log, and the interval period for those statistics that occur
{       within an emission set.  A statistic whose emission set period changes
{       is counted as a new statistic.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$duplicate_file_name
{             pte$error_processing_parameter
{             pte$unexpected_end_of_file
*DECK DECK=PTH$ANABL_DISPLAY_PUT EXPAND=FALSE
{    The purpose of this command is to allow the user to examine the current
{ state of the output list specified to ANABL.  The user can choose to examine
{ a selected subrange of report entries, or all report entries.
{
{ PUT:  The report entry name.
{
{ NUMBER:  The report entry ordinal.  The user can chose to display a single
{       report entry by specifying its ordinal.  Specifying the keyword LAST
{       causes this command to display the report entry with the highest
{       ordinal.  Using the keyword ALL causes this command to display all
{       output report entries.
{
{ DISPLAY_OPTION:  The different types of displays available.  Valid values are
{       the keywords NAME, TYPE, ENTRY, or ALL.  The keyword NAME causes
{       display_put to list the names of the puts.  The keyword TYPE causes
{       display_put to display whether the put is a put_record, put_field,
{       put_field_summary, or put_interval_field.  The keyword ENTRY causes
{       display_put to display the fields or records to be output by each
{       specified put.
{
{ OUTPUT:  The output file the display is written to.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$duplicate_name
{             pte$duplicate_numbers
{             pte$error_processing_parameter
{             pte$generate_none_mode
{             pte$undefined_put_for_dis
{             pte$not_put_and_number
{             pte$put_and_number
*DECK DECK=PTH$ANABL_DISPLAY_SELECTION EXPAND=FALSE
{    The purpose of this command is to allow users to view their definitions of
{ records.  Users may select a list of records or request that all defined
{ records be displayed.
{
{ record:  This parameter lets the user select which records to display.  The
{       user may specify one or a list of record names.  In addition, the
{       keyword ALL can be specified to let the user view all defined records.
{
{ display_option:  This parameter lets the user select the amount of
{       information displayed about the records being displayed.  If the
{       keyword NAME is chosen, then just the record names are displayed.  If
{       the keyword ALL is specified, then all possible attributes are
{       displayed for each selected record.
{
{ output:  This parameter allows the user to specify the file the record
{       display is written to.  The default value is $output.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$duplicate_name
{             pte$undefined_selec_for_dis
{             pte$error_processing_parameter
*DECK DECK=PTH$ANABL_GENERATE_LOG EXPAND=FALSE
{    The purpose of this command is to cause ANABL to generate the currently
{ specified report.  This report specification must consist only of
{ put_field_summary, put_interval_field, or put_field commands.  If put_record
{ commands are present in the output list, an error will be flagged noting
{ these, and the report will be generated with no output from these commands.
{
{ INPUT:  This parameter selects the input binary log the report is to be
{       generated from.
{
{ OUTPUT:  This parameter specifies the file the report is written to.
{
{ DISPLAY_REPORT_HEADER:  This parameter allows the user to select whether or
{       not the report header is written to the output file.  This parameter is
{       useful for producing output files that can be directly fed into data
{       analysis programs.  Choosing to not print the header allows generation
{       of an output file where every line has the same format.
{
{ SUMMARIZE_DEFINED_DATA:  This parameter affects the amount of data that ANABL
{       summarizes as it reads a log.  In the default case where sdd = false,
{       ANABL only summarizes data for reported fields.  This is true even if
{       the set of defined fields is much larger than the set of reported
{       fields.  Setting this parameter to true causes ANABL to summarize all
{       defined fields even if they are not reported.  Users may wish to do
{       this if they believe they are going to generate more than one report
{       from the same log and defined data combination.  In this case, the log
{       will only need to be read once for all reports instead of once for
{       every report.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$duplicate_file_name
{             pte$error_processing_parameter
{             pte$generate_log_mode
{             pte$generate_none_mode
{             pte$unexpected_end_of_file
*DECK DECK=PTH$ANABL_GENERATE_REPORT EXPAND=FALSE
{    The purpose of this command is to cause ANABL to generate the currently
{ specified report.  This report specification must consist only of
{ put_field_summary, put_interval_field, or put_field commands.  If put_record
{ commands are present in the output list, an error will be flagged noting
{ these, and the report will be generated with no output from these commands.
{
{ INPUT:  This parameter selects the input binary log the report is to be
{       generated from.
{
{ OUTPUT:  This parameter specifies the file the report is written to.
{
{ DISPLAY_REPORT_HEADER:  This parameter allows the user to select whether or
{       not the report header is written to the output file.  This parameter is
{       useful for producing output files that can be directly fed into data
{       analysis programs.  Choosing to not print the header allows generation
{       of an output file where every line has the same format.
{
{ SUMMARIZE_DEFINED_DATA:  This parameter affects the amount of data that ANABL
{       summarizes as it reads a log.  In the default case where sdd = false,
{       ANABL only summarizes data for reported fields.  This is true even if
{       the set of defined fields is much larger than the set of reported
{       fields.  Setting this parameter to true causes ANABL to summarize all
{       defined fields even if they are not reported.  Users may wish to do
{       this if they believe they are going to generate more than one report
{       from the same log and defined data combination.  In this case, the log
{       will only need to be read once for all reports instead of once for
{       every report.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$duplicate_file_name
{             pte$error_processing_parameter
{             pte$generate_log_mode
{             pte$generate_none_mode
{             pte$unexpected_end_of_file
*DECK DECK=PTH$ANABL_PUT_FIELD EXPAND=FALSE
{    The purpose of this command is to allow the user to have more control of
{ the report format than is provided by the put_field_summary command.  The
{ trade off is that the user must specify both the fields and the summary
{ calculation for every field in the put_field.  For most summary calculations,
{ this subcommand generates a single report line having the following form:
{
{    field 1 .  .  .  field k
{
{    For the all_occurrences summary calculation, ANABL generates as many lines
{ as needed to print each occurrence of a FIELD's SELECTION in the input logs.
{
{    If the report exceeds the page length of the current output file, then a
{ new page is begun with a page header line consisting of the current operating
{ system level, the date, the time, and the page number.
{
{ PUT:  See the put_field_summary command for a description of this parameter.
{
{ NUMBER:  See the put_field_summary command for a description of this
{       parameter.
{
{ FIELD:  See the put_interval_field command for a description of this
{       parameter.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$error_processing_parameter
{             pte$field_out_of_line_limits
{             pte$field_overlap
{             pte$generate_log_mode
{             pte$redefined_put
{             pte$undefined_field_for_put
*DECK DECK=PTH$ANABL_PUT_FIELD_SUMMARY EXPAND=FALSE
{    The purpose of this command is to provide the user with a quick way of
{ examining the data.  Report formatting capabilities are limited.  This report
{ specification command cannot be used to report descriptive data strings.  The
{ output format is shown below.
{
{                              std         elap      sum  cnt
{               count sum mean dev min max time int /sec /sec
{ row label
{     .
{     .
{     .
{ row label
{
{    The elapsed_time_since_predecessor summary calculation is only valid for
{ fields taken from records with job or task predecessors specified.  When the
{ report exceeds the current display page of the output file, a page header is
{ written on the new page.  The first line of this header contains the
{ operating system level, the date, the time, and page number.  After
{ appropriate spacing, the current report column headers will be reprinted, if
{ they still apply.
{
{ PUT:  This optional parameter allows the user to name the report entry for
{       easy reference.
{
{ NUMBER:  The NUMBER parameter is an ordinal specifying where in the list of
{       output definition subcommands the current subcommand is to be placed.
{       If this parameter is not specified, the default is for the position to
{       be NEXT.  This means the new output specification subcommand will
{       follow all current output specification subcommands.  If an integer
{       value is specified, the new subcommand will occupy that ordinal
{       position.  The subcommands having ordinal position equal to or greater
{       than this position will all have their ordinal position increased by
{       one.  If an ordinal postion greater than the largest used ordinal is
{       specified, the effect will be the same as specifying NEXT.  The
{       specified ordinal position will not be used, but instead an ordinal
{       equal to one greater than the current last used ordinal is assigned to
{       this entry.
{
{ FIELD:  Valid values for this parameter are the names of previously defined
{       FIELDS.  The user may optionally associate a string to be used as the
{       row label with a field.  If no such string is specified, the row label
{       will be the field name.
{
{ SUMMARY_CALCULATION:  This parameter governs the data columns to be printed
{       as shown in the above output format template.  The columns contain
{       descriptive statistics specified by a list of keywords.  The keywords
{       may be specified as the only items in the list or format specifications
{       for the column the keyword will produce in the report can be included.
{       The format specification is determined by the start_column and the
{       column_width.
{
{    The calculations each keyword represents are specified below.
{
{     COUNT:  The number of occurrences of the field in the log.
{     SUM:  The sum of the values of all field occurrences.
{     MEAN:  The average as computed by 'sum/count'.
{     STANDARD_DEVIATION:  The normal standard deviation with a divisor of (n-1).
{     MINIMUM:  The minimum value of all field occurrences.
{     MAXIMUM:  The maximum value of all field occurrences.
{     INTERVAL:  The average time interval between data
{           item occurrences.  This is useful for periodic statistics such as
{           the OS statistics, where the interval is a fixed value.
{     COUNT_PER_SECOND:  The computed average 'count/interval'.  This is
{           useful for periodic statistics such as the OS statistics, where the
{           interval is a fixed value.
{     SUM_PER_SECOND:  The computed average 'sum/interval'.  This is useful for periodic
{           statistics such as the OS statistics, where the interval is a fixed value.
{     ELAPSED_TIME_SINCE_PREDECESSOR:  The average computed time
{           difference of the logged times between a record and its defined job
{           or task predecessor.  This is only valid for items where a
{           predecessor has been defined.
{
{    The column format fields are described below:
{
{     START_COLUMN:  This field allows the user to fix the column the display
{           of the corresponding named summary_calculation begins in.  If the
{           user does not specify a start_column for the summary calculation
{           list entry a start_column will be assigned to the column when the
{           report is generated.
{     COLUMN_WIDTH:  This field allows the user to
{           specify the width of this summary_calculation display.  If the user
{           does not specify a column_width for the summary calculation list
{           entry a column_width will be assigned to the column when the report
{           is generated.
{
{ DISPLAY_HEADERS:  This parameter selects whether or not column headers are
{       printed for the fields in this put_field_summary.  If a list of fields
{       is specified, new column headings will never be printed for the second
{       through last fields.  Thus, this parameter governs whether new column
{       headings are printed before the first row of data in a
{       put_field_summary command.  Having the ability to turn off column
{       header display allows the output generated by consecutive
{       put_field_summary commands to appear as though they were generated by a
{       single command.  If this parameter is not specified, column headings
{       are not printed.
{
{ ROW_LABEL_FORMAT:  This parameter allows the user to specify the format of
{       the row labels.  The start_column field fixes the column the row labels
{       will begin on.  The column width field limits the row labels to the
{       specified number of characters.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$error_processing_parameter
{             pte$field_out_of_line_limits
{             pte$field_overlap
{             pte$generate_log_mode
{             pte$redefined_put
{             pte$undefined_field_for_put
*DECK DECK=PTH$ANABL_PUT_INTERVAL_FIELD EXPAND=FALSE
{    The purpose of this command is to provide the user with a mechanism to
{ generate reports of data by time interval.  This type of report is most
{ useful for reporting periodic statistic values.  This subcommand generates
{ report lines having the following form:
{
{       interval range      label  . . .   label
{       t1..t2
{               .
{               .
{               .
{       tk-1..tk
{
{    In this example ti..tj represents a time range the reported data
{ describes.  The labels are to descibe the fields that occur in the column
{ below the label.  When the report exceeds the current page of the output
{ file, a page header is written on the new page.  The first line of this
{ header contains the operating system level, the current date and time and
{ page number.  After appropriate spacing, the current report column headers
{ will be reprinted, if they still apply.
{
{ PUT:  See the put_field_summary command for a description of this parameter.
{
{ NUMBER:  See the put_field_summary command for a description of this
{       parameter.
{
{ FIELDS:  This parameter requires the user to specify the list of fields and
{       to be displayed.  If the field is numeric, the summary calculation must
{       also be specified.  If the field is a string the summary calculation
{       will be ignored.  The user may also specify the column the field
{       summary is to start in and the width of the specified field summary.
{       The user may specify up to 10 field records to report.  The summary
{       calculations are reported in a single row in the order they are
{       specified.  The summary calculations are specified by keywords.  A
{       description of the meaning of each of these keywords is given in the
{       explanation of the summary_calculation parameter of the
{       put_field_summary command.  The start_column and column_width fields
{       work the same way they are described in the summary_calculation
{       parameter of the put_field_summary command.
{
{ COLUMN_HEADERS:  The column headers allow the user to label the fields being
{       summarized in the put_interval_field row.  The user is responsible for
{       matching up the column headers with the corresponding named field.  The
{       column headers may take two rows.  The string from the header_1 field
{       goes in the first row and the string from header_2 goes on the second
{       row.  If this parameter is not specified, the field name is used as a
{       column header.
{
{ REPORT_INTERVAL:  This parameter specifies the number of consecutive
{       occurrences of the specified fields to include as one interval.
{       Specifying a value of 1 would cause all occurences to be printed.
{       Specifying a value of 10 would cause 10 consecutive occurrences to be
{       summarized for one report interval.
{
{ ROW_LABEL_FORMAT:  The start_column and column_width fields work as described
{       in the description of the row_label_format parameter of the
{       put_field_summary command.  The date_time_format lets the user specify
{       a date time form string.  It must be a valid date time form string as
{       described in the SCL manual.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$error_processing_parameter
{             pte$field_out_of_line_limits
{             pte$field_overlap
{             pte$generate_log_mode
{             pte$header_overflow
{             pte$redefined_put
{             pte$undefined_field_for_put
*DECK DECK=PTH$ANABL_PUT_RECORD EXPAND=FALSE
{
{    This command allows the user to report all occurrences of a record from a
{ binary log.  Three output formats are available for this command.  These
{ formats are chosen at report generation time by the display_format parameter
{ on the generate_log command.  The options are legible_data, list, and binary.
{ Legible_data is intended to be used as input to a data base manager or report
{ formatter.  List is intended for human perusal of basically unformatted
{ statistics.  However, list can also be used for input to programs.  Binary
{ output has the same format as the input log.  It is intended to provide a
{ means of reducing the amount of data saved in a log.  The output templates
{ are given below:
{
{         Legible_Data Format
{
{              Column              Data
{              1 -            Statistic code
{                             Time stamp
{                             Date
{                             Job name
{                             Global Task ID
{                             Number of counters
{                             Length of descriptive data field
{                             Counter 1
{                             Counter 2
{                               .
{                               .
{                               .
{                             Counter K
{                             Descriptive data string

{         List Format

{          Row           Column              Data
{              1         1 -            Statistic code
{                                       Time stamp
{                                       Date
{                                       Job name
{                                       Global Task ID
{                                       Number of counters
{                                       Length of descriptive data field
{              2                        Counter 1
{                                       Counter 2
{                                         .
{                                         .
{            J-1                          .
{                                       Counter K
{              J                        Descriptive data string
{
{    Neither of these output formats allows for pagination.  They assume a
{ continuous output file.
{
{ PUT:  See the put_field_summary command for a description of this parameter.
{
{ NUMBER:  See the put_field_summary command for a description of this
{       parameter.
{
{ SELECTIONS:  This is the list of names of previously defined records that will
{       be reported.
{
{ COUNTERS:  This optional parameter allows the user to select which
{           counters of the specified statistic are counters of the specified
{           statistic are displayed and what base they are displayed in.  The
{           first element of each item in the counter list is a list of range
{           of counter numbers.  They have possible values from 1 to
{           sfc$max_number_of_counters (=255).  The keyword NONE means print no
{           counters.  The keyword ALL means print all the counters in the
{           record.  The second value is a single keyword specifying the base
{           the associated counters are to be displayed in.  Valid bases are
{           base_2, base_8, base_10, and base_16.  If no base is specified, the
{           base defaults to base_10.
{
{ DESCRIPTIVE_DATA:  This parameter allows the user to select all, part, or
{           none of the specified record's descriptive data field to be output
{           with the record.  The descriptive data string manipulation
{           functions can be used to choose all of the descriptive data field
{           or substrings of it.  Specifying the null string (='') causes no
{           descriptive data field to be output.  The default is to print all
{           of the descriptive data field.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$counter_changed
{             pte$counters_changed
{             pte$duplicate_name
{             pte$error_processing_parameter
{             pte$generate_report_mode
{             pte$redefined_put
{             pte$selec_ref_by_another_put
{             pte$undefined_selec_for_put
*DECK DECK=PTH$ANABL_PUT_STRING EXPAND=FALSE
{    The purpose of this command is to let the user insert a line of text
{ fields in a report.
{
{ PUT:  See the put_field_summary command for a description of this parameter.
{
{ NUMBER:  See the put_field_summary command for a description of this
{       parameter.
{
{ STRING:  This parameter specifies the string the user wishes to to insert in
{       the report.  the string is specified with the string field.  The
{       start_column field lets the user specify the column the first character
{       of the string will be in the report.  The column width let the user
{       limit the width of the string.
{
{ STATUS: This parameter specifies the request status.
{       CONDITIONS:
{             pte$field_out_of_line_limits
{             pte$field_overlap
{             pte$generate_log_mode
{             pte$redefined_put
{             pte$string_overflow
*DECK DECK=PTK$PERFORMANCE_KEYPOINTS EXPAND=FALSE

  CONST

    ptk$page_fault_segment = ptk$performance_base + 0,
      {R 'Page Fault Segment' 'segment' H12}

    ptk$page_fault_p_segment = ptk$performance_base + 1,
      {R 'Page Fault P Register' 'Segment' H12}

    ptk$page_fault_p_lower_offset = ptk$performance_base + 2,
      {R 'Page Fault P Lower Offset' 'Offset' H20}

    ptk$page_fault_gtid = ptk$performance_base + 3,
      {R 'Page Fault GTID' 'GTID' H20}

    ptk$page_fault_lower_offset = ptk$performance_base + 4,
      {R 'Page Fault Lower Offset' 'Offset' H20}

    ptk$page_fault_pfti = ptk$performance_base + 5,
      {R 'Page Fault Page Frame Table Index' 'PFTI' I20}

    ptk$page_fault_status = ptk$performance_base + 6,
      {R 'Page Fault Status' 'Status' I20}

    ptk$page_assigned_pfti = ptk$performance_base + 7,
      {R 'Page Assigned to queue' 'PFTI' I20}

    ptk$page_assigned_queue = ptk$performance_base + 8,
      {R 'Page Assign to queue' 'Queue' I20}

    ptk$new_job_name_1 = ptk$performance_base + 9,
      {R 'First part of job name'}

    ptk$new_job_name_2 = ptk$performance_base + 10,
      {R 'Second part of job name'}

    ptk$ajl_for_swap_out = ptk$performance_base + 11,
      {R 'AJL for job being swapped out' 'AJL' I20}

    ptk$pfti_for_swapout = ptk$performance_base + 12,
      {R 'PFTI for job being swapped out' 'PFTI' I20}

    ptk$swapin_job_name_1 = ptk$performance_base + 13,
      {R 'First part of job name at swapin'}

    ptk$swapin_job_name_2 = ptk$performance_base + 14,
      {R 'Second part of job name for swapin'}

    ptk$pfti_for_swapin = ptk$performance_base + 15,
      {R 'PFTI for Swapin' 'PFTI' I20}

    ptk$page_fault_p_upper_offset = ptk$performance_base + 16,
      {R 'Page Fault P register upper offset' 'offset' H20}

    ptk$page_fault_upper_offset = ptk$performance_base + 17,
      {R 'Page Fault upper offset' 'offset' H20}

    ptk$page_assigned_ijl = ptk$performance_base + 18,
      {R 'Page assigned to job' 'IJL' I20}

    ptk$page_fault_ijl = ptk$performance_base + 19,
      {R 'Page Fault for job' 'IJL' I20}

    ptk$aging_segment = ptk$performance_base + 20,
      {R 'Job aging' 'segment' H20}

    ptk$aging_page_number = ptk$performance_base + 21,
      {R 'Job aging page in segment' 'Page' I20}

    ptk$aging_ijl_ordinal = ptk$performance_base + 22,
      {R 'Job aging for job' 'IJL' I20}

    ptk$command_name = ptk$performance_base + 23,
      {R 'Command being processed' 'command' A6}

    ptk$command_ijl = ptk$performance_base + 24,
      {R 'Command for job' 'IJL' I20}

    ptk$aging_job_fixed = ptk$performance_base + 25,
      {R 'Aging job fixed' '# pages' I20}

    ptk$aging_modified_pages = ptk$performance_base + 26,
      {R 'Aging modified pages' '# Pages' I20}

    ptk$aging_pages_removed = ptk$performance_base + 27,
      {R 'Aging pages removed' '# Pages' I20}

    ptk$swapping_segment = ptk$performance_base + 30,
      {R 'Swapping segment' 'Segment' H20}

    ptk$swapping_job_fixed = ptk$performance_base + 31,
      {R 'Swapping pages in job fixed' '# Pages' I20}

    ptk$swapping_modified_pages = ptk$performance_base + 32,
      {R 'Swapping modified pages count' '# Pages' I20}

    ptk$swapping_removed_pages = ptk$performance_base + 33,
      {R 'Pages Removed at swapping' '# Pages' I20}

    ptk$swapping_ijl_ordinal = ptk$performance_base + 34,
      {R 'swapping IJL ordinal' 'IJL' I20}

    ptk$swapping_page_number = ptk$performance_base + 35,
      {R 'swapping page number' 'Page #' I20}

    ptk$allocate_gtid = ptk$performance_base + 40,
      {R 'Allocate GTID' 'GTID' H20}

    ptk$allocate_segment = ptk$performance_base + 41,
      {R 'Allocate in segment'  'segment' H20}

    ptk$allocate_lower_offset = ptk$performance_base + 42,
      {R 'Allocate at lower offset' 'offset' H20}

    ptk$allocate_p_segment = ptk$performance_base + 43,
      {R 'Allocate from P register'  'offset' H20}

    ptk$allocate_p_lower_offset = ptk$performance_base + 44,
      {R 'Allocate from P register lower offset' 'offset' H20}

    ptk$allocate_length = ptk$performance_base + 45,
      {R 'Allocation length' 'bytes' I20}

    ptk$allocate_upper_offset = ptk$performance_base + 46,
      {R 'Allocate in upper offset' 'offset' H20}

    ptk$allocate_p_upper_offset = ptk$performance_base + 47,
      {R 'Allocate from P upper offset' 'offset' H20}

    ptk$stack_p_segment = ptk$performance_base + 50,
      {R 'P register in stack' 'Segment' H20}

    ptk$stack_p_upper_offset = ptk$performance_base + 51,
      {R 'P register in stack offset' 'Lower' H20}

    ptk$stack_p_lower_offset = ptk$performance_base + 52,
      {R 'P register in stack offset' 'Lower' H20}

    ptk$stack_tos_segment = ptk$performance_base + 53,
      {R 'Top of stack' 'Segment' H20}

    ptk$stack_tos_upper_offset = ptk$performance_base + 54,
      {R 'Top of stack Upper offset' 'offset' H20}

    ptk$stack_tos_lower_offset = ptk$performance_base + 55,
      {R 'Top of stack Lower offset' 'offset' H20}

    ptk$stack_esa_segment = ptk$performance_base + 56,
      {R 'End save area segment' 'segment' H20}

    ptk$stack_esa_upper_offset = ptk$performance_base + 57,
      {R 'End save area upper offset' 'offset' H20}

    ptk$stack_esa_lower_offset = ptk$performance_base + 58,
      {R 'End save area lower offset' 'offset' H20}

    ptk$end_of_stack_trace = ptk$performance_base + 59,
      {R 'End of stack Trace' }

    ptk$stack_ijl_ordinal = ptk$performance_base + 60,
      {R 'Processing stack for IJL' 'IJL' I20}

    ptk$disk_unit = ptk$performance_base + 61,
      {R 'Disk unit and cylinder' H20}

    ptk$disk_allocation_address = ptk$performance_base + 62,
      {R 'Disk allocation mau address' 'mau addr' H20}

    ptk$disk_mau_offset = ptk$performance_base + 63,
      {R 'Disk mau offset'  'offset' H20}

    ptk$disk_transfer_length = ptk$performance_base + 64,
      {R 'Disk transfer length'  'length' I20}

    ptk$disk_mau_preset = ptk$performance_base + 65,
      {R 'MAU Preset' 'mau' H20}

    ptk$disk_sfid = ptk$performance_base + 66,
      {R 'SFID for disk request' 'sfid' H20}

    ptk$disk_byte_address = ptk$performance_base + 67,
      {R 'Byte offset of transfer' 'offset' H20}

    ptk$disk_function = ptk$performance_base + 68,
      {R 'Function issued to disk' 'function' H20}

    ptk$disk_ijlo = ptk$performance_base + 69,
      {R 'Ijl ordinal for request' 'ijl' I20}

    ptk$disk_task_id = ptk$performance_base + 70,
      {R 'Task id for disk request' 'task id' H20}

    ptk$disk_aste = ptk$performance_base + 71,
      {R 'Aste for disk request' 'aste' H20}

    ptk$disk_request_info = ptk$performance_base + 72,
      {R 'Disk Request info' '   ' H20}

    ptk$free_gtid = ptk$performance_base + 73,
      {R 'Free GTID' 'GTID' H20}

    ptk$free_segment = ptk$performance_base + 74,
      {R 'Free in segment'  'segment' H20}

    ptk$free_lower_offset = ptk$performance_base + 75,
      {R 'Free at lower offset' 'offset' H20}

    ptk$free_p_segment = ptk$performance_base + 76,
      {R 'Free from P register'  'offset' H20}

    ptk$free_p_lower_offset = ptk$performance_base + 77,
      {R 'Free from P register lower offset' 'offset' H20}

    ptk$free_length = ptk$performance_base + 78,
      {R 'Free length' 'bytes' I20}

    ptk$free_upper_offset = ptk$performance_base + 79,
      {R 'Free in upper offset' 'offset' H20}

    ptk$free_p_upper_offset = ptk$performance_base + 80,
      {R 'Free from P upper offset' 'offset' H20}

    ptk$upper_limit = ptk$performance_base + 99;

*copyc amk$base_keypoint_values
*copyc osk$keypoint_class_codes
*DECK DECK=PTM$ANALYZE_BINARY_LOG EXPAND=TRUE

?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON) ??
?? SET (LIST := ON, LISTCTS := OFF) ??
?? NEWTITLE := 'Analyze_Binary_Log - Analyze NOS/VE Binary Log' ??
MODULE ptm$analyze_binary_log;

{ PURPOSE:
{   This module contains the command and subcommands for the NOS/VE Analyze Binary Log Utility.  The utility
{ is used to read and report the contents of NOS/VE binary logs.
{
{ DESIGN:
{   This utility is a standalone utility outside of the operating system.  It is available to all users.
{
{   The utility can read active and non active logs.  Some active logs are restricted to certain  users,
{ e.g. account_log is restricted to an accounting administrator and the engineering_log is restricted to an
{ engineering_administrator.  This restriction will be implemented in a future release.  The only protection
{ for these logs are a file's ring attributes.
{
{   This utility runs in the caller's ring.
{
{ NOTES:
{   Applicable documents for the Analyze_Binary_Log utility include:
{   NOS/VE System Performance and maintenance, Volume 1
{
{   The procedures are arranged in two groups:
{   1)  Internal procedures are in alphabetical order
{   2)  Subcommand procedures are ordered as follows:
{       Add_Selection
{       Change_Selection
{       Delete_Selection
{       Display_Selection
{       Add_Field
{       Change_Field
{       Delete_Field
{       Display_Field
{       Put_Field_summary
{       Put_interval_Field
{       Put_Field
{       Put_String
{       Put_Record
{       Change_Put
{       Delete_Put
{       Display_Put
{       Generate_Report
{       Generate_Log
{       Change_Defaults
{       Display_Defaults
{       Display_Logged_Statistic
{       Quit

?? NEWTITLE := 'Global Declarations Referenced By This Module', EJECT ??

*copyc amp$fetch_access_information
*copyc amp$get_file_attributes
*copyc amp$get_next
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc amp$set_segment_eoi
*copyc bat$record_header_type
*copyc clp$begin_utility
*copyc clp$convert_date_time_to_string
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_file_ref
*copyc clp$convert_string_to_integer
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$get_variable
*copyc clp$get_reason_for_call
*copyc clp$include_file
*copyc clp$trimmed_string_size
*copyc clt$file_reference
*copyc clt$parameter_list
*copyc cyp$close_file
*copyc cyp$current_display_line
*copyc cyp$display_page_eject
*copyc cyp$display_page_length
*copyc cyp$display_standard_title
*copyc cyp$file_connected_to_terminal
*copyc cyp$open_file
*copyc cyp$page_width
*copyc cyp$put_next_line
*copyc cyp$start_new_display_page
*copyc cyp$write_end_of_line
*copyc fsp$close_file
*copyc fsp$open_file
*copyc lgt$log_read_activity
*copyc lgp$open_log_file
*copyc lgp$rewind_log_file
*copyc lgp$get_next_statistic
*copyc lgp$close_log_file
*copyc mlp$rsqrt
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc pmp$compute_date_time
*copyc pmp$compute_date_time_increment
*copyc pmp$continue_to_cause
*copyc pmp$get_unique_name
*copyc sfp$convert_stat_code_to_name
*copyc sfp$convert_stat_name_to_code
*copyc sft$statistic_buffer
*copyc sft$statistic_header
*copyc sfd$type_declarations

?? NEWTITLE := 'Command Table', EJECT ??

{ table n=anabl_cmd_table t=command s=local
{ command n=(add_selection, adds)                         p=add_selection_cmd             cm=local
{ command n=(change_selection, chas)                      p=change_selection_cmd          cm=local
{ command n=(delete_selection, delete_selections, dels)   p=delete_selection_cmd          cm=local
{ command n=(display_selection, display_selections, diss) p=display_selection_cmd         cm=local
{ command n=(add_field, addf)                             p=add_field_cmd                 cm=local
{ command n=(change_field, chaf)                          p=change_field_cmd              cm=local
{ command n=(delete_field, delete_fields, delf)           p=delete_field_cmd              cm=local
{ command n=(display_field, display_fields, disf)         p=display_field_cmd             cm=local
{ command n=(pop_page_header, popph)                      p=pop_page_header_cmd           cm=local
{ command n=(push_page_header, pusph)                     p=push_page_header_cmd          cm=local
{ command n=(put_field_summary, putfs)                    p=put_field_summary_cmd         cm=local
{ command n=(put_interval_field, putif)                   p=put_interval_field_cmd        cm=local
{ command n=(put_field, putf)                             p=put_field_cmd                 cm=local
{ command n=(put_new_page, putnp)                         p=put_new_page_cmd              cm=local
{ command n=(put_string, puts)                            p=put_string_cmd                cm=local
{ command n=(put_record, put_records, putr)               p=put_record_cmd                cm=local
{ command n=(change_put, chap)                            p=change_put_cmd                cm=local
{ command n=(delete_put, delp)                            p=delete_put_cmd                cm=local
{ command n=(display_put, disp)                           p=display_put_cmd               cm=local
{ command n=(generate_report, genr)                       p=generate_report_cmd           cm=local
{ command n=(generate_log, genl)                          p=generate_log_cmd              cm=local
{ command n=(change_defaults, change_default, chad)       p=change_defaults_cmd           cm=local
{ command n=(display_defaults, display_default, disd)     p=display_defaults_cmd          cm=local
{ command n=(display_logged_statistics, disls)            p=display_logged_statistics_cmd cm=local
{ command n=(quit, qui)                                   p=quit_cmd                      cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  anabl_cmd_table: [STATIC, READ] ^clt$command_table := ^anabl_cmd_table_entries,

  anabl_cmd_table_entries: [STATIC, READ] array [1 .. 57] of clt$command_table_entry := [
  {} ['ADDF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^add_field_cmd],
  {} ['ADDS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^add_selection_cmd],
  {} ['ADD_FIELD                      ', clc$nominal_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^add_field_cmd],
  {} ['ADD_SELECTION                  ', clc$nominal_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^add_selection_cmd],
  {} ['CHAD                           ', clc$abbreviation_entry, clc$normal_usage_entry, 22,
        clc$automatically_log, clc$linked_call, ^change_defaults_cmd],
  {} ['CHAF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^change_field_cmd],
  {} ['CHANGE_DEFAULT                 ', clc$alias_entry, clc$normal_usage_entry, 22,
        clc$automatically_log, clc$linked_call, ^change_defaults_cmd],
  {} ['CHANGE_DEFAULTS                ', clc$nominal_entry, clc$normal_usage_entry, 22,
        clc$automatically_log, clc$linked_call, ^change_defaults_cmd],
  {} ['CHANGE_FIELD                   ', clc$nominal_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^change_field_cmd],
  {} ['CHANGE_PUT                     ', clc$nominal_entry, clc$normal_usage_entry, 17,
        clc$automatically_log, clc$linked_call, ^change_put_cmd],
  {} ['CHANGE_SELECTION               ', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^change_selection_cmd],
  {} ['CHAP                           ', clc$abbreviation_entry, clc$normal_usage_entry, 17,
        clc$automatically_log, clc$linked_call, ^change_put_cmd],
  {} ['CHAS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^change_selection_cmd],
  {} ['DELETE_FIELD                   ', clc$nominal_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^delete_field_cmd],
  {} ['DELETE_FIELDS                  ', clc$alias_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^delete_field_cmd],
  {} ['DELETE_PUT                     ', clc$nominal_entry, clc$normal_usage_entry, 18,
        clc$automatically_log, clc$linked_call, ^delete_put_cmd],
  {} ['DELETE_SELECTION               ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^delete_selection_cmd],
  {} ['DELETE_SELECTIONS              ', clc$alias_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^delete_selection_cmd],
  {} ['DELF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^delete_field_cmd],
  {} ['DELP                           ', clc$abbreviation_entry, clc$normal_usage_entry, 18,
        clc$automatically_log, clc$linked_call, ^delete_put_cmd],
  {} ['DELS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^delete_selection_cmd],
  {} ['DISD                           ', clc$abbreviation_entry, clc$normal_usage_entry, 23,
        clc$automatically_log, clc$linked_call, ^display_defaults_cmd],
  {} ['DISF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^display_field_cmd],
  {} ['DISLS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 24,
        clc$automatically_log, clc$linked_call, ^display_logged_statistics_cmd],
  {} ['DISP                           ', clc$abbreviation_entry, clc$normal_usage_entry, 19,
        clc$automatically_log, clc$linked_call, ^display_put_cmd],
  {} ['DISPLAY_DEFAULT                ', clc$alias_entry, clc$normal_usage_entry, 23,
        clc$automatically_log, clc$linked_call, ^display_defaults_cmd],
  {} ['DISPLAY_DEFAULTS               ', clc$nominal_entry, clc$normal_usage_entry, 23,
        clc$automatically_log, clc$linked_call, ^display_defaults_cmd],
  {} ['DISPLAY_FIELD                  ', clc$nominal_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^display_field_cmd],
  {} ['DISPLAY_FIELDS                 ', clc$alias_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^display_field_cmd],
  {} ['DISPLAY_LOGGED_STATISTICS      ', clc$nominal_entry, clc$normal_usage_entry, 24,
        clc$automatically_log, clc$linked_call, ^display_logged_statistics_cmd],
  {} ['DISPLAY_PUT                    ', clc$nominal_entry, clc$normal_usage_entry, 19,
        clc$automatically_log, clc$linked_call, ^display_put_cmd],
  {} ['DISPLAY_SELECTION              ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^display_selection_cmd],
  {} ['DISPLAY_SELECTIONS             ', clc$alias_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^display_selection_cmd],
  {} ['DISS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^display_selection_cmd],
  {} ['GENERATE_LOG                   ', clc$nominal_entry, clc$normal_usage_entry, 21,
        clc$automatically_log, clc$linked_call, ^generate_log_cmd],
  {} ['GENERATE_REPORT                ', clc$nominal_entry, clc$normal_usage_entry, 20,
        clc$automatically_log, clc$linked_call, ^generate_report_cmd],
  {} ['GENL                           ', clc$abbreviation_entry, clc$normal_usage_entry, 21,
        clc$automatically_log, clc$linked_call, ^generate_log_cmd],
  {} ['GENR                           ', clc$abbreviation_entry, clc$normal_usage_entry, 20,
        clc$automatically_log, clc$linked_call, ^generate_report_cmd],
  {} ['POPPH                          ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^pop_page_header_cmd],
  {} ['POP_PAGE_HEADER                ', clc$nominal_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^pop_page_header_cmd],
  {} ['PUSH_PAGE_HEADER               ', clc$nominal_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^push_page_header_cmd],
  {} ['PUSPH                          ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^push_page_header_cmd],
  {} ['PUTF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^put_field_cmd],
  {} ['PUTFS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^put_field_summary_cmd],
  {} ['PUTIF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^put_interval_field_cmd],
  {} ['PUTNP                          ', clc$abbreviation_entry, clc$normal_usage_entry, 14,
        clc$automatically_log, clc$linked_call, ^put_new_page_cmd],
  {} ['PUTR                           ', clc$abbreviation_entry, clc$normal_usage_entry, 16,
        clc$automatically_log, clc$linked_call, ^put_record_cmd],
  {} ['PUTS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 15,
        clc$automatically_log, clc$linked_call, ^put_string_cmd],
  {} ['PUT_FIELD                      ', clc$nominal_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^put_field_cmd],
  {} ['PUT_FIELD_SUMMARY              ', clc$nominal_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^put_field_summary_cmd],
  {} ['PUT_INTERVAL_FIELD             ', clc$nominal_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^put_interval_field_cmd],
  {} ['PUT_NEW_PAGE                   ', clc$nominal_entry, clc$normal_usage_entry, 14,
        clc$automatically_log, clc$linked_call, ^put_new_page_cmd],
  {} ['PUT_RECORD                     ', clc$nominal_entry, clc$normal_usage_entry, 16,
        clc$automatically_log, clc$linked_call, ^put_record_cmd],
  {} ['PUT_RECORDS                    ', clc$alias_entry, clc$normal_usage_entry, 16,
        clc$automatically_log, clc$linked_call, ^put_record_cmd],
  {} ['PUT_STRING                     ', clc$nominal_entry, clc$normal_usage_entry, 15,
        clc$automatically_log, clc$linked_call, ^put_string_cmd],
  {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 25,
        clc$automatically_log, clc$linked_call, ^quit_cmd],
  {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 25,
        clc$automatically_log, clc$linked_call, ^quit_cmd]];

?? POP ??
?? OLDTITLE ??
*copyc pte$ecc_anabl_exceptions

?? NEWTITLE := 'Const', EJECT ??

  CONST
    ptc$blanks = '                                                                   ',
    ptc$stars = '*******************************************************************',
    ptc$base_2_length = 69, { String size for integer in base 2  (64 digits + 1 sign + 3 radix + 1 space) }
    ptc$base_8_length = 27, { String size for integer in base 8  (22 digits + 1 sign + 3 radix + 1 space) }
    ptc$base_10_length = 21, { String size for integer in base 10 (19 digits + 1 sign           + 1 space) }
    ptc$base_16_length = 22, { String size for integer in base 16 (16 digits + 1 sign + 4 radix + 1 space) }
    ptc$base_16_group_length = 26, { String size for integer in base 16 group (19 digits + 4 radix + 3 space)}
    ptc$date_time_record_size = 8, { #size(ost$date_time) }
    ptc$default_counter_fraction = 3,
    ptc$default_date_time_format = 'ISOD MILLISECOND',
    ptc$default_time_inc_format = 'SECONDS',
    ptc$default_row_label_size = osc$max_name_size,
    ptc$ddl_string_size = 3, { String size for descriptive_data_length - integer in the range of 0..255 }
    ptc$field_vector_size = 25,
    ptc$key_all_occurrences = 'ALL_OCCURRENCES',
    ptc$key_count = 'COUNT',
    ptc$key_count_per_second = 'COUNT_PER_SECOND',
    ptc$key_default = 'DEFAULT',
    ptc$key_end_time = 'END_TIME',
    ptc$key_first_occurrence = 'FIRST_OCCURRENCE',
    ptc$key_global_task_id = 'GLOBAL_TASK_ID',
    ptc$key_interval = 'INTERVAL',
    ptc$key_last_occurrence = 'LAST_OCCURRENCE',
    ptc$key_maximum = 'MAXIMUM',
    ptc$key_mean = 'MEAN',
    ptc$key_minimum = 'MINIMUM',
    ptc$key_seconds = 'SECONDS',
    ptc$key_standard_deviation = 'STANDARD_DEVIATION',
    ptc$key_sum = 'SUM',
    ptc$key_sum_per_second = 'SUM_PER_SECOND',
    ptc$key_start_time = 'START_TIME',
    ptc$key_statistic_code = 'STATISTIC_CODE',
    ptc$key_date_time = 'DATE_TIME',
    ptc$key_system_job_name = 'SYSTEM_JOB_NAME',
    ptc$key_time_increment = 'TIME_INCREMENT',
    ptc$key_time_range = 'TIME_RANGE',
    ptc$key_unspecified = 'UNSPECIFIED',
    ptc$key_none = 'NONE',
    ptc$key_number_of_counters = 'NUMBER_OF_COUNTERS',
    ptc$key_descriptive_data_length = 'DESCRIPTIVE_DATA_LENGTH',
    ptc$key_previous_occurrence = 'PREVIOUS_OCCURRENCE',
    ptc$key_predecessor = 'PREDECESSOR',
    ptc$key_predecessor_chain_head = 'PREDECESSOR_CHAIN_HEAD',
    ptc$key_occurrence_per_second = 'OCCURRENCE_PER_SECOND',
    ptc$key_value_per_second = 'VALUE_PER_SECOND',
    ptc$length_of_counter_field = 20,
    ptc$max_output_line_length = ptc$max_page_width,
    ptc$max_output_line_log_length = 20000,
    ptc$max_page_width = 10000,
    ptc$max_real = 5.2e1232,
    ptc$max_row_label_size = ptc$max_page_width,
    ptc$num_of_counter_string_size = 3, { String size for number_of_counters - integer in the range of 0..255}

{ Change ptc$max_tasks const to osc$max_tasks when osc$max_tasks changes from 4095 to 65535.

    ptc$max_tasks = 65535,
    ptc$statistics_array_size = 100,
    ptc$summary_vector_size = 10,
    ptc$tab = 9,
    ptc$task_id_index_string_size = 5, { String size for  task_id_index - integer in the range of 0..65535 }
    ptc$task_id_seqno_string_size = 3, { String size for  task_id_seqno - integer in the range of 0..255 }
    ptc$time_length = 12,
    ptc$utility_name = 'ANALYZE_BINARY_LOG             ';

?? OLDTITLE ??
?? NEWTITLE := 'Type', EJECT ??
?? NEWTITLE := 'field' ??

{  ANABL fields correspond to statistic counters and descriptive data fields.
{    They can also be simple strings.  A field is the basic addressable unit
{    in ANABL.

  TYPE
    field = record
      field_name: ost$name,
      field_chain_link_p: ^field,
      selection_p: ^selection,
      original_selection_p: ^selection,
      report_list_p: ^report_list,

      first_value: boolean,
      collect_summary: boolean,
      collect_all_occurrences: boolean,

      field_summary: field_summary_type,

{ These counter attributes are shared by counter_field and value_per_second_field.
{   Therefore they are fixed fields rather than in the variable part of the record.

      counter_number: 1 .. sfc$max_number_of_counters,
      multiplier: real,
      incremental: boolean,
      allow_negative_increment: boolean,
      last_value: integer,

      case field_type: type_of_field of

      = counter_field =
        first_counter_value: integer,
        last_counter_value: integer,
        counter_value_head_p: ^counter_value,
        counter_value_tail_p: ^counter_value,

      = descriptive_data_field =
        first_descriptive_value_p: ^sft$descriptive_data,
        last_descriptive_value_p: ^sft$descriptive_data,
        descriptive_value_head_p: ^descriptive_value,
        descriptive_value_tail_p: ^descriptive_value,

        subfield_position: 1 .. sfc$max_descriptive_data_size,
        subfield_length: 1 .. sfc$max_descriptive_data_size,
        subfield_number: 0 .. sfc$max_descriptive_data_size,
        subfield_delimiter: char,

      = date_time_field =
        first_date_time_value: ost$date_time,
        last_date_time_value: ost$date_time,
        date_time_value_head_p: ^date_time_value,
        date_time_value_tail_p: ^date_time_value,

      = statistic_code_field =
        first_statistic_code_value: sft$statistic_code,
        last_statistic_code_value: sft$statistic_code,
        statistic_code_value_head_p: ^statistic_code_value,
        statistic_code_value_tail_p: ^statistic_code_value,

      = system_job_name_field =
        first_system_job_name_value: jmt$system_supplied_name,
        last_system_job_name_value: jmt$system_supplied_name,
        system_job_name_value_head_p: ^system_job_name_value,
        system_job_name_value_tail_p: ^system_job_name_value,

      = global_task_id_field =
        first_global_task_id_value: ost$global_task_id,
        last_global_task_id_value: ost$global_task_id,
        global_task_id_value_head_p: ^global_task_id_value,
        global_task_id_value_tail_p: ^global_task_id_value,

      = number_of_counters_field =
        first_num_of_counters_value: 0 .. sfc$max_number_of_counters,
        last_num_of_counters_value: 0 .. sfc$max_number_of_counters,
        number_of_counters_value_head_p: ^number_of_counters_value,
        number_of_counters_value_tail_p: ^number_of_counters_value,

      = descriptive_data_size_field =
        first_dd_size_value: 0 .. sfc$max_descriptive_data_size,
        last_dd_size_value: 0 .. sfc$max_descriptive_data_size,
        dd_size_value_head_p: ^dd_size_value,
        dd_size_value_tail_p: ^dd_size_value,

      = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =
        first_elapsed_time_value: integer,
        last_elapsed_time_value: integer,
        elapsed_time_value_head_p: ^counter_value,
        elapsed_time_value_tail_p: ^counter_value,

      = value_per_second_field, occurrence_per_second_field =
        first_value_per_second_value: real,
        last_value_per_second_value: real,
        value_per_second_sum: real,
        value_per_second_minimum: real,
        value_per_second_maximum: real,
        value_per_second_value_head_p: ^real_value,
        value_per_second_value_tail_p: ^real_value,

        elapsed_time: elapsed_time_type,

      = text_field =
        descriptive_text_p: ^sft$descriptive_data,

      casend
    recend;

?? OLDTITLE ??
?? NEWTITLE := 'put_entry', EJECT ??

{  The put_entry is the basic report specification unit in ANABL.

  TYPE
    put_entry = record
      name: ost$name,
      put_chain_link_p: ^put_entry,
      field_vector: field_vector_type,
      header_1: string (ptc$max_page_width),
      header_2: string (ptc$max_page_width),
      max_used_column: 0..clc$max_integer,
      case put: put_type of

      = put_field_summary =
        fields_p: ^field_list,
        summary_vector: summary_vector_type,
        row_label_start_column: report_column,
        row_label_column_width: report_column,
        display_headers: boolean,

      = put_interval_field =
        row_label_type: (start_time, end_time, time_range, row_label_none, string_label),
        row_label: string (ptc$max_row_label_size),
        date_time_start_column: report_column,
        date_time_column_width: report_column,
        date_time_format_p: ^clt$date_time_form_string,
        report_interval: integer,

      = put_field =
        all_occurrences: boolean,

      = put_string =
        ,

      = put_record =
        selection_p: ^selection_list,
        delete_counters: boolean,
        counter_base: array [1 .. sfc$max_number_of_counters] of radix,
        descriptive_text_p: ^sft$descriptive_data,
        subfield_position: 1 .. sfc$max_descriptive_data_size,
        subfield_length: 1 .. sfc$max_descriptive_data_size,
        subfield_number: 0 .. sfc$max_descriptive_data_size,
        subfield_delimiter: char,

      = put_new_page =
        use_page_headers: boolean,

      = push_page_header =
        default_header: boolean,

      = pop_page_header =
        pop_all_headers: boolean,
        pop_count: integer,

      casend
    recend;

?? OLDTITLE ??
?? NEWTITLE := 'selection', EJECT ??

{  An ANABL selection corresponds to a statistic in a binary log.  A selection
{    lets the user specify criteria for choosing and grouping statistics from
{    a binary log.

  TYPE
    selection = record

{ Identification

      name: ost$name,
      selection_chain_link_p: ^selection,

{ Statistic Code selection

      statistic_specified: boolean,
      statistic_name: ost$name,
      statistic_code: sft$statistic_code,

{ Time selection

      date_time_specified: boolean,
      start_date_time: ost$date_time,
      end_date_time: ost$date_time,
      continuous_date_time: boolean,
      new_day_date_time: ost$date_time,

{ Descriptive data selection

      descriptive_specified: boolean,
      descriptive_subfield_p: ^descriptive_data_subfield,

{ Job predecessor selection

      predecessor_job_statistic_p: ^selection,

{ Task predecessor selection

      predecessor_task_statistic_p: ^selection,

{ Job membership selection

      job_name: jmt$system_supplied_name,

{ Task membership selection

      task_id_specified: boolean,
      task_id: ost$global_task_id,

      log_entry_p: ^put_entry,
      field_chain_p: ^field,
      number_of_successor_statistics: 0 .. clc$max_integer,
      successor_list_head_p: ^successor,
      successor_list_tail_p: ^successor,
      collect_date_time: boolean,
      date_time_value_head_p: ^date_time_value,
      date_time_value_tail_p: ^date_time_value,
      collect_predecessor_date_time: boolean,
      predecessor_dt_value_head_p: ^date_time_value,
      predecessor_dt_value_tail_p: ^date_time_value,
      statistic_location_p: ^statistic_location,
      incremental: boolean,
      incremental_counter_p: ^field,
      lost_interval: integer,
      skip_date_time: boolean,
      skip_date_time_head_p: ^skip_date_time,
      skip_date_time_tail_p: ^skip_date_time,
      shadow_fields: boolean,
      shadow_field_chain_p: ^field,
    recend;

?? OLDTITLE, EJECT ??

  TYPE
    active_fields_set = set of 1 .. ptc$field_vector_size,

    counter_value = record
      link_p: ^counter_value,
      index: 0 .. ptc$statistics_array_size,
      value_array: array [1 .. ptc$statistics_array_size] of integer,
    recend,

    dd_size_value = record
      link_p: ^dd_size_value,
      index: 0 .. ptc$statistics_array_size,
      value_array: array [1 .. ptc$statistics_array_size] of 0 .. sfc$max_descriptive_data_size,
    recend,

    descriptive_data_subfield = record
      descriptive_data_string_p: ^descriptive_data_string,
      subfield_position: 0 .. sfc$max_descriptive_data_size,
      subfield_length: 0 .. sfc$max_descriptive_data_size,
      subfield_number: 0 .. sfc$max_descriptive_data_size,
      subfield_delimiter: char,
      descriptive_subfield_link_p: ^descriptive_data_subfield,
    recend,

    descriptive_data_string = record
      descriptive_string_link_p: ^descriptive_data_string,
      descriptive_text: sft$descriptive_data,
    recend,

    descriptive_value = record
      link_p: ^descriptive_value,
      index: 0 .. ptc$statistics_array_size,
      value_array: array [1 .. ptc$statistics_array_size] of ^sft$descriptive_data,
    recend,

    date_time_value = record
      link_p: ^date_time_value,
      index: 0 .. ptc$statistics_array_size,
      value_array: array [1 .. ptc$statistics_array_size] of ost$date_time,
    recend,

    display_format_type = (binary, legible_data, list),

    elapsed_time_type = (previous_occurrence, predecessor, predecessor_chain_head),
    field_list = record
      field_p: ^field,
      link_p: ^field_list,
      row_label: string (ptc$max_row_label_size),
    recend,

    field_record_type = record
      field_p: ^field,
      summary: summary_type,
      start_column: report_column,
      column_width: report_column,
      shadow_field: boolean,
      shadow_field_p: ^field,
    recend,

    field_summary_type = record
      count: integer,
      sum: integer,
      mean: real,
      standard_deviation: real,
      square_sum: real,
      minimum: integer,
      maximum: integer,
      interval: integer,
      elapsed_time_since_predecessor: integer,
      count_per_second: real,
      sum_per_second: real,
      first_date_time: ost$date_time,
      last_date_time: ost$date_time,
      sum_overflow: boolean,
    recend,

    field_value_pointers = record
      counter_value_p: ^counter_value,
      descriptive_value_p: ^descriptive_value,
      date_time_p: ^date_time_value,
      statistic_code_value_p: ^statistic_code_value,
      system_job_name_value_p: ^system_job_name_value,
      global_task_id_value_p: ^global_task_id_value,
      number_of_counters_value_p: ^number_of_counters_value,
      dd_size_value_p: ^dd_size_value,
      elapsed_time_value_p: ^counter_value,
      value_per_second_value_p: ^real_value,
      skip_date_time_p: ^skip_date_time,
      lost_interval: integer,
      predecessor_date_time_p: ^date_time_value,
      value_index: 0 .. ptc$statistics_array_size,
      first_date_time: ost$date_time,
      last_date_time: ost$date_time,
      first: boolean,
    recend,

    field_value_type = array [1 .. ptc$field_vector_size] of field_value_pointers,

    field_vector_type = array [1 .. ptc$field_vector_size] of field_record_type,

    type_of_field = (undefined_field, counter_field, descriptive_data_field, date_time_field,
          statistic_code_field, system_job_name_field, global_task_id_field, number_of_counters_field,
          descriptive_data_size_field, text_field, previous_occurrence_field, predecessor_field,
          predecessor_chain_head_field, value_per_second_field, occurrence_per_second_field),

    global_task_id_value = record
      link_p: ^global_task_id_value,
      index: 0 .. ptc$statistics_array_size,
      value_array: array [1 .. ptc$statistics_array_size] of ost$global_task_id,
    recend,

    join_predecessor_status_type = (one_selection, no_predecessor_path, predecessor_path),

    log_file = record
      log_chain_link_p: ^log_file,
      active_log: boolean,
      log_file_identifier: lgt$log_file_identifier,
      file_identifier: amt$file_identifier,
      segment_pointer: amt$segment_pointer,
      access_level: amt$access_level,
      start_time: ost$date_time,
      end_time: ost$date_time,
      open: boolean,
      statistics_list_p: ^logged_statistic,
      log_file_name: fst$file_reference,
    recend,

    logged_statistic = record
      statistic_code: sft$statistic_code,
      link_p: ^logged_statistic,
      statistic_location_p: ^statistic_location,
      number_of_occurrences: 0 .. clc$max_integer,
      time_of_first_occurrences: ost$date_time,
      time_of_last_occurrences: ost$date_time,
    recend,

    name_list = record
      name: ost$name,
      link_p: ^name_list,
    recend,

    number_of_counters_value = record
      link_p: ^number_of_counters_value,
      index: 0 .. ptc$statistics_array_size,
      value_array: array [1 .. ptc$statistics_array_size] of 0 .. sfc$max_number_of_counters,
    recend,

    numbers_set = set of 1 .. 32767, { The maximum number elements in a set is 32767 }

    page_header_list_entry = record
      fwd_p: ^page_header_list_entry,
      bkw_p: ^page_header_list_entry,
      default_header: boolean,
      header_string: string (ptc$max_page_width),
    recend,

    put_type = (put_record, put_field, put_field_summary, put_interval_field, put_string, put_new_page,
                push_page_header, pop_page_header),

{ The order in radix is the order of the fixed counter length (see ptc$base_xx_length).

    radix = (base_0, base_10, base_16, base_16_group, base_8, base_2),

    real_value = record
      link_p: ^real_value,
      index: 0 .. ptc$statistics_array_size,
      value_array: array [1 .. ptc$statistics_array_size] of real,
    recend,

    report_column = 1 .. ptc$max_page_width,

    report_column_set = set of report_column,

    report_list = record
      report_p: ^put_entry,
      link_p: ^report_list,
      shadow: boolean,
    recend,

    selection_list = record
      selection_p: ^selection,
      link_p: ^selection_list,
    recend,

    selection_list_join = record
      selection_p: ^selection,
      tail: boolean,
      link_p: ^selection_list_join,
    recend,

    skip_date_time = record
      link_p: ^skip_date_time,
      skip_date_time: ost$date_time,
      date_time_after_skip: ost$date_time,
    recend,

    statistic_code_value = record
      link_p: ^statistic_code_value,
      index: 0 .. ptc$statistics_array_size,
      value_array: array [1 .. ptc$statistics_array_size] of sft$statistic_code,
    recend,

    statistic_location = record
      statistic_location_chain_link_p: ^statistic_location,
      statistic_index: 0 .. ptc$statistics_array_size,
      statistic_array: array [1 .. ptc$statistics_array_size] of ^sft$statistic_header,
    recend,

    successor = record
      global_task_id: ost$global_task_id,
      job_seq_number: jmt$system_supplied_name,
      successor_link_p: ^successor,
      date_time: ost$date_time,
      statistic_header_p: ^sft$statistic_header,
      counters_p: sft$counters,
      descriptive_data_p: ^sft$descriptive_data,
      predecessor_p: ^successor,
      selection_p: ^selection,
    recend,

    summary_type = (null, count, sum, mean, standard_deviation, minimum, maximum, first_occurrence,
          last_occurrence, all_occurrences, text, count_per_second, sum_per_second, interval,
          elapsed_time_since_predecessor),

    summary_vector_type = array [1 .. ptc$summary_vector_size] of record
      summary: summary_type,
      start_column: report_column,
      column_width: report_column,
    recend,

    system_job_name_value = record
      link_p: ^system_job_name_value,
      index: 0 .. ptc$statistics_array_size,
      value_array: array [1 .. ptc$statistics_array_size] of jmt$system_supplied_name,
    recend,

    time_increment_value = record
      link_p: ^time_increment_value,
      index: 0 .. ptc$statistics_array_size,
      value_array: array [1 .. ptc$statistics_array_size] of pmt$time_increment,
    recend,

    write_statistic_p = ^procedure (    log_entry_p: ^put_entry;
                                        statistic_header_p: ^sft$statistic_header;
                                        counters_p: sft$counters;
                                        descriptive_data_p: ^sft$descriptive_data;
                                    VAR status: ost$status);

?? OLDTITLE ??
?? NEWTITLE := 'Var', EJECT ??

  VAR
    ptv$active_log: boolean,
    ptv$clt_date_time: clt$date_time := [ * , TRUE, TRUE],
    ptv$conditions: [STATIC, READ] pmt$condition := [pmc$condition_combination,
          [pmc$block_exit_processing, ifc$interactive_condition]],
    ptv$counter_fraction: [STATIC] 0..clc$max_integer := ptc$default_counter_fraction,
    ptv$data_segment_p: amt$segment_pointer,
    ptv$date_time_format: string (clc$max_date_time_form_string) := ptc$default_date_time_format,
    ptv$default_input_log_list_p: [STATIC] ^clt$data_value := NIL,
    ptv$descriptive_data_size: record
      case float: boolean of
      = TRUE =
        ,
      = FALSE =
        number: 0 .. sfc$max_descriptive_data_size,
      casend
    recend,
    ptv$dt_format_for_increment: string (clc$max_date_time_form_string) := 'H24:MM:SS.S1000',
    ptv$display_file: fst$path,
    ptv$display_file_specifications: [STATIC, READ] array
          [1 .. 2] of cyt$file_specification := [[cyc$file_kind, cyc$display_file],
          [cyc$new_page_procedure, [cyc$standard_procedure, ptc$utility_name]]],
    ptv$display_format: display_format_type,
    ptv$display_report_header: boolean,
    ptv$end_of_segment: amt$segment_pointer,
    ptv$excel: boolean,
    ptv$fixed_counter_length: integer,
    ptv$generate: (none, log, report) := none,
    ptv$headers_specified: boolean,
    ptv$information_request: boolean,
    ptv$initial_field_summary: [STATIC, READ] field_summary_type := [0
          { count } , 0 { sum } , 0.0 { mean } , 0.0 { standard_deviation } , 0.0
          { square_sum } , clc$max_integer { minimum } , -clc$max_integer { maximum } , 0 { interval } , 0
          { elapsed_time_since_predecessor } , 0.0 { count_per_sec } , 0.0 { sum_per_sec } , *
          { first_date_time } , * { last_date_time } , FALSE { sum_overflow } ],
    ptv$input_log_chain_head_p: ^log_file := NIL,
    ptv$interval: [STATIC] pmt$time_increment := [0, 0, 0, 0, 0, 0, 0],
    ptv$interval_0: [STATIC, READ] pmt$time_increment := [0, 0, 0, 0, 0, 0, 0],
    ptv$legible_data_max_page_width: 1..ptc$max_page_width := ptc$max_page_width,
    ptv$line_length: 0 .. 65535,
    ptv$list_max_page_width: 1..ptc$max_page_width := cyc$wide_page_width,
    ptv$log_entry_chain_head_p: ^put_entry := NIL,

{ The value osc$null_name for file_processor is used to indicate a "don't care" state.

    ptv$log_file_attributes: [STATIC, READ] array [1 .. 2] of fst$file_cycle_attribute :=
          [[fsc$record_type, amc$variable], [fsc$file_contents_and_processor, fsc$binary_log, osc$null_name]],
    ptv$logged_statistic_chain_head: ^logged_statistic := NIL,
    ptv$maximum_line_length: 0..ptc$max_page_width,
    ptv$max_date_time: [STATIC, READ] ost$date_time := [255, 12, 31, 23, 59, 59, 999],
    ptv$min_date_time: [STATIC, READ] ost$date_time := [0, 1, 1, 0, 0, 0, 0],
    ptv$max_report_page_width: 1..ptc$max_page_width := ptc$max_page_width,
    ptv$max_report_width: integer := 0,
    ptv$number_of_counters: record
      fixed_format: boolean,
      case float: boolean of
      = TRUE =
        ,
      = FALSE =
        number: 0 .. sfc$max_number_of_counters,
      casend
    recend,
    ptv$one_day: pmt$time_increment := [0, 0, 1, 0, 0, 0, 0],
    ptv$output_file: cyt$file,
    ptv$output_line: string (ptc$max_output_line_length),
    ptv$output_line_length: integer,
    ptv$output_line_log: string (ptc$max_output_line_log_length),
    ptv$output_log_p: ^log_file := NIL,
    ptv$page_header_list_head_p: ^page_header_list_entry,
    ptv$page_header_list_tail_p: ^page_header_list_entry,
    ptv$predecessor_job_date_time: ost$date_time,
    ptv$predecessor_task_date_time: ost$date_time,
    ptv$predecessor_log_p: amt$segment_pointer,
    ptv$previous_header_fba: amt$file_byte_address,
    ptv$prompting_activted: boolean,
    ptv$report_entry_chain_head_p: ^put_entry := NIL,
    ptv$statistic_header_size: [STATIC, READ] integer := #SIZE (sft$statistic_header),
    ptv$selection_chain_head_p: ^selection := NIL,
    ptv$selection_chain_tail_p: ^selection := NIL,
    ptv$statistic_record_buffer: sft$statistic_buffer,
    ptv$text_file_specifications: [STATIC, READ] array [1 .. 2] of cyt$file_specification :=
          [[cyc$file_kind, cyc$text_file], [cyc$page_width, ptc$max_page_width]],
    ptv$time_increment_format: string (14) := ptc$default_time_inc_format;

?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'anabl_new_page_procedure', EJECT ??

{ The purpose of this procedure is to print page headers for new pages of a generated report.
{   It is only used for reports with display_format = LIST.

  PROCEDURE anabl_new_page_procedure (
        output_file: cyt$file;
        next_page_number: integer;
    VAR status: ost$status);

    VAR
      page_header_p: ^page_header_list_entry;

    cyp$display_page_eject (ptv$output_file, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    IF ptv$page_header_list_tail_p <> NIL THEN
{ At least one entry in page header list

      page_header_p := ptv$page_header_list_head_p;

{ Loop until the physical or logical end of the page header chain
{   physical end: page_header_p = NIL
{   logical end: page_header_p^.bkw_p = ptv$page_header_list_tail_p
{       Last page header we processed was the last one we wanted.

      WHILE (page_header_p <> NIL) AND (page_header_p^.bkw_p <> ptv$page_header_list_tail_p) DO
        IF page_header_p^.default_header THEN
{ Print default header
          cyp$display_standard_title (ptv$output_file, ptc$utility_name, 1, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        ELSE
{ Print header string
          ptv$output_line_length := clp$trimmed_string_size (page_header_p^.header_string);
          cyp$put_next_line (ptv$output_file, page_header_p^.header_string(1, ptv$output_line_length),
                status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;

        page_header_p := page_header_p^.fwd_p;
      WHILEND;

    IFEND;

  PROCEND anabl_new_page_procedure;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] add_statistic_to_successor_list', EJECT ??

{ PURPOSE:
{   The purpose of this request is to add a statistic to a job or task successor list.
{
{ DESIGN:
{      This procedure is called when a statistic is selected and checks if the current selection is a job
{   and/or task predecessor for another selection.  If the selection is a job predecessor then get the system
{   job name and date time from the curent statistic's header and save them.  If the selection is a task
{   predecessor then get the global task id, system job name and date time from the curent statistic's header
{   and save them.
{
{      Typically predecessors are used to match statistics emitted by the same task (or job) e.g. end of task
{   (or job) with the beginning of the task (or job).
{
{      The statistics data is saved in reverse order chain (new data added to the beginning of the chain).
{   That helps to improve select_statistic function performance because typically tasks (or jobs) that begin
{   earlier will end earlier and the predecessor scan in select_statistic will scan only the beginning of the
{   chain in order to find a matching predecessor.
{
{      There is a good chance of finding that the Global task id is not unique in the log (when the task ended
{   the global task id is free to be a global task id of another task).  In order to improve the matching
{   between statistics emitted by the same task a system job name is added to the data saved and the chain is
{   organized in reverse order.

  PROCEDURE [INLINE] add_statistic_to_successor_list
    (    selection_p { input, output } : ^selection;
         statistic_header_p: ^sft$statistic_header;
         counters_p: sft$counters;
         descriptive_data_p: ^sft$descriptive_data;
         predecessor_p: ^successor);

    VAR
      successor_p: ^successor;

    IF selection_p^.number_of_successor_statistics > 0 THEN
      NEXT successor_p IN ptv$data_segment_p.sequence_pointer;
      successor_p^.global_task_id := statistic_header_p^.task_id;
      successor_p^.job_seq_number := statistic_header_p^.job_name;
      successor_p^.date_time := statistic_header_p^.date_time;
      successor_p^.statistic_header_p := statistic_header_p;
      successor_p^.counters_p := counters_p;
      successor_p^.descriptive_data_p := descriptive_data_p;
      successor_p^.predecessor_p := predecessor_p;
      successor_p^.selection_p := selection_p;
      successor_p^.successor_link_p := selection_p^.successor_list_head_p;
      selection_p^.successor_list_head_p := successor_p;
    IFEND;

  PROCEND add_statistic_to_successor_list;

?? OLDTITLE ??
?? NEWTITLE := 'check_counter_parameter', EJECT ??

{ PURPOSE:
{   The purpose of this request is to check and process the counter parameter in
{ put_record & change_put subcommands.
{
{ DESIGN:
{   The procedure marks all the counters as base 0 (counters marked as base 0 are not printed).  If the
{ parameter is a keyword (NONE) then set delete_counters flag and return.  Or else for each record in the
{ record list set the range of counters with the base of that record.  If the keyword ALL is specified for
{ a range no other range can be specified.

  PROCEDURE check_counter_parameter
    (    counters: clt$parameter_value;
         temp_log_entry: ^put_entry;
     VAR status: ost$status);

    TYPE
      counter_change_set = set of 1 .. sfc$max_number_of_counters;

    VAR
      base: radix,
      counter_base_init_0: [STATIC, READ] array [1 .. sfc$max_number_of_counters] of radix :=
            [REP sfc$max_number_of_counters of base_0],
      counter_base_init_2: [STATIC, READ] array [1 .. sfc$max_number_of_counters] of radix :=
            [REP sfc$max_number_of_counters of base_2],
      counter_base_init_8: [STATIC, READ] array [1 .. sfc$max_number_of_counters] of radix :=
            [REP sfc$max_number_of_counters of base_8],
      counter_base_init_10: [STATIC, READ] array [1 .. sfc$max_number_of_counters] of radix :=
            [REP sfc$max_number_of_counters of base_10],
      counter_base_init_16: [STATIC, READ] array [1 .. sfc$max_number_of_counters] of radix :=
            [REP sfc$max_number_of_counters of base_16],
      counter_base_init_16_g: [STATIC, READ] array [1 .. sfc$max_number_of_counters] of radix :=
            [REP sfc$max_number_of_counters of base_16_group],
      counter_change: counter_change_set,
      counter_change_init: [STATIC, READ] array [1 .. sfc$max_number_of_counters] of boolean :=
            [REP sfc$max_number_of_counters of FALSE],
      errors_detected: boolean,
      failing_status: ost$status,
      high_counter: integer,
      index: integer,
      index_string: ost$string,
      low_counter: integer,
      value_p: ^clt$data_value;

    status.normal := TRUE;

    temp_log_entry^.delete_counters := FALSE;
    IF counters.specified THEN
      temp_log_entry^.counter_base := counter_base_init_0;
      IF counters.value^.kind = clc$keyword THEN
        temp_log_entry^.delete_counters := TRUE;
      ELSE
        value_p := counters.value;
        counter_change := $counter_change_set [];
        errors_detected := FALSE;
        WHILE value_p <> NIL DO
          IF value_p^.element_value^.field_values^ [2].value^.keyword_value = 'BASE_2' THEN
            base := base_2;
          ELSEIF value_p^.element_value^.field_values^ [2].value^.keyword_value = 'BASE_8' THEN
            base := base_8;
          ELSEIF value_p^.element_value^.field_values^ [2].value^.keyword_value = 'BASE_10' THEN
            base := base_10;
          ELSEIF value_p^.element_value^.field_values^ [2].value^.keyword_value = 'BASE_16' THEN
            base := base_16;
          ELSEIF value_p^.element_value^.field_values^ [2].value^.keyword_value = 'BASE_16_GROUP' THEN
            base := base_16_group;
          IFEND;

{ Keyword could be NONE, so must explicitly check for ALL

          IF (value_p^.element_value^.field_values^ [1].value^.kind = clc$keyword) AND
                (value_p^.element_value^.field_values^ [1].value^.keyword_value = 'ALL') THEN

{ ALL

            IF counter_change = $counter_change_set [] THEN
              CASE base OF
              = base_2 =
                temp_log_entry^.counter_base := counter_base_init_2;
              = base_8 =
                temp_log_entry^.counter_base := counter_base_init_8;
              = base_10 =
                temp_log_entry^.counter_base := counter_base_init_10;
              = base_16 =
                temp_log_entry^.counter_base := counter_base_init_16;
              = base_16_group =
                temp_log_entry^.counter_base := counter_base_init_16_g;
              ELSE
              CASEND;
            ELSE
              osp$set_status_condition (pte$counters_changed, failing_status);
              report_intermediate_error (failing_status, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
              errors_detected := TRUE;
            IFEND;
            counter_change := -$counter_change_set [];
          ELSE
            low_counter := value_p^.element_value^.field_values^ [1].value^.low_value^.integer_value.value;
            high_counter := value_p^.element_value^.field_values^ [1].value^.high_value^.integer_value.value;
            IF low_counter > high_counter THEN
              STRINGREP (ptv$output_line, ptv$output_line_length, low_counter, ' ..', high_counter);
              osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$low_greater_than_high,
                    ptv$output_line (1, ptv$output_line_length), failing_status);
              report_intermediate_error (failing_status, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
              errors_detected := TRUE;
            IFEND;

            FOR index := low_counter TO high_counter DO
              IF NOT (index IN counter_change) THEN
                temp_log_entry^.counter_base [index] := base;
                counter_change := counter_change + $counter_change_set [index];
              ELSE
                clp$convert_integer_to_string (index, 10, FALSE, index_string, status);
                IF NOT status.normal THEN
                  RETURN; {----->
                IFEND;
                osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$counter_changed, index_string.
                      value (1, index_string.size), failing_status);
                report_intermediate_error (failing_status, status);
                errors_detected := TRUE;
              IFEND;
            FOREND;
          IFEND;

          value_p := value_p^.link;
        WHILEND;

        IF errors_detected THEN
          osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, 'COUNTERS',
                status);
        IFEND;

        index := 1;
        WHILE (index <= sfc$max_number_of_counters) AND NOT temp_log_entry^.delete_counters DO
          IF temp_log_entry^.counter_base [index] = base_0 THEN
            temp_log_entry^.delete_counters := TRUE;
          IFEND;
          index := index + 1;
        WHILEND;
      IFEND;
    IFEND;

  PROCEND check_counter_parameter;

?? OLDTITLE ??
?? NEWTITLE := 'check_display_option', EJECT ??

{ PURPOSE:
{    The purpose of this request is to check the Display_Option field in the FIELD parameter for put_field and
{ change_put (field entries type) subcommands.
{
{ DESIGN:
{   The procedure counts the number of ALL_OCCURRENCES Display_Options and the number of any other
{ Display_Options.  If there is mix of ALL_OCCURRENCES and other Display_Options the procedure returns an
{ error.  The procedure returns parameter all_occurrences = TRUE if all the Display_Options are
{ ALL_OCCURRENCES.
{
{ NOTE:
{  - If ALL_OCCURRENCES display_option is used all the display_options must be ALL_OCCURRENCES.
{  - The Display_Option default is ALL_OCCURENCES.

  PROCEDURE check_display_option
    (    value: ^clt$data_value;
     VAR all_occurrences: boolean;
     VAR status: ost$status);

    VAR
      other_keyword: boolean,
      value_p: ^clt$data_value;

    status.normal := TRUE;

    all_occurrences := FALSE;
    other_keyword := FALSE;
    value_p := value;
    WHILE value_p <> NIL DO
      IF (value_p^.element_value^.field_values^ [2].value = NIL) OR
            (value_p^.element_value^.field_values^ [2].value^.keyword_value = ptc$key_all_occurrences) THEN
        all_occurrences := TRUE;
      ELSE
        other_keyword := TRUE;
      IFEND;
      value_p := value_p^.link;
    WHILEND;

    IF all_occurrences AND other_keyword THEN
      osp$set_status_condition (pte$all_occurrences_and_other, status);
      RETURN; {----->
    IFEND;

  PROCEND check_display_option;

?? OLDTITLE ??
?? NEWTITLE := 'check_fields_and_put_pointers', EJECT ??

{ PURPOSE:
{    The purpose of this request is to check and report if a selection(s) has field(s) and/or put(s).

  PROCEDURE check_fields_and_put_pointers
    (    selection_p: ^selection;
     VAR errors_detected: boolean;
     VAR status: ost$status);

    VAR
      failing_status: ost$status;

    status.normal := TRUE;

    IF selection_p^.field_chain_p <> NIL THEN
      osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$selection_has_field, selection_p^.name,
            failing_status);
      report_intermediate_error (failing_status, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      errors_detected := TRUE;
    IFEND;

    IF selection_p^.log_entry_p <> NIL THEN
      osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$selection_has_put, selection_p^.name,
            failing_status);
      report_intermediate_error (failing_status, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      errors_detected := TRUE;
    IFEND;

  PROCEND check_fields_and_put_pointers;

?? OLDTITLE ??
?? NEWTITLE := 'check_predecessor_path', EJECT ??

{ PURPOSE:
{   The purpose of this request is to ensure that the list of selections from a single put_field report
{     entry with ALL_OCCURRENCES all belong to a single predecessor path.
{
{ DESIGN:
{   The procedure scans the list of selections and sets all the selections that have a predecessor as tail
{ selection (only the selection at the head of the predecessor chain can not have a predecessor).  Then the
{ procedure resets the tail flag in any selection that is predecessor to another selection in the list.
{ Finally, if only one selection is the tail, the procedure checks if it is possible to get to all other
{ selections through the predecessor pointer.  If so there is a predecessor path.

  PROCEDURE check_predecessor_path
    (    report_entry_p: ^put_entry;
     VAR join_predecessor_status: join_predecessor_status_type;
     VAR selection_p: ^selection);

    VAR
      index: integer,
      selection_list_head_p: ^selection_list_join,
      selection_list_p: ^selection_list_join,
      prev_p: ^selection_list_join,
      next_p: ^selection_list_join,
      selection_list_tail_p: ^selection_list_join,
      tail_selection_p: ^selection_list_join;

?? NEWTITLE := 'sel1_in_sel2_chain', EJECT ??

{ PURPOSE:  Check if the first specified selection is in the second selection's
{   predecessor path.
{   Returns TRUE if sel1 is in sel2 predecessor path.
{   Returns FALSE if sel1 is not in sel2 predecessor path.

    FUNCTION sel1_in_sel2_chain
      (    sel1_p,
           sel2_p: ^selection_list_join): boolean;

      VAR
        pred_chain_entry_p: ^selection;

      sel1_in_sel2_chain := FALSE;

      IF sel2_p^.selection_p^.predecessor_job_statistic_p <> NIL THEN
        pred_chain_entry_p := sel2_p^.selection_p^.predecessor_job_statistic_p;
      ELSE
        pred_chain_entry_p := sel2_p^.selection_p^.predecessor_task_statistic_p;
      IFEND;
      WHILE pred_chain_entry_p <> NIL DO
        IF pred_chain_entry_p = sel1_p^.selection_p THEN
          sel1_in_sel2_chain := TRUE;
          RETURN; {----->
        ELSEIF pred_chain_entry_p^.predecessor_job_statistic_p <> NIL THEN
          pred_chain_entry_p := pred_chain_entry_p^.predecessor_job_statistic_p;
        ELSE
          pred_chain_entry_p := pred_chain_entry_p^.predecessor_task_statistic_p;
        IFEND;
      WHILEND;

{ Made it through sel2_p chain without finding a match
      sel1_in_sel2_chain := FALSE;

    FUNCEND sel1_in_sel2_chain;

?? OLDTITLE ??

{ Make list of selections involved in the put_field with all_occurrences

    selection_list_head_p := NIL;
    index := LOWERBOUND (field_vector_type);
    WHILE (index <= UPPERBOUND (field_vector_type)) AND (report_entry_p^.field_vector [index].
          summary <> null) DO
      selection_p := report_entry_p^.field_vector [index].field_p^.selection_p;

{ Check if the selection is in the selection list from previous field.

      selection_list_p := selection_list_head_p;
      WHILE (selection_list_p <> NIL) AND (selection_list_p^.selection_p <> selection_p) DO
        selection_list_p := selection_list_p^.link_p;
      WHILEND;

{ If selection isn't in the selection list add it to the list.

      IF selection_list_p = NIL THEN
        NEXT selection_list_p IN ptv$data_segment_p.sequence_pointer;
        selection_list_p^.link_p := NIL;
        selection_list_p^.selection_p := selection_p;
        IF selection_list_head_p = NIL THEN { The first selection in the list.
          selection_list_head_p := selection_list_p;
        ELSE
          selection_list_tail_p^.link_p := selection_list_p;
        IFEND;
        selection_list_tail_p := selection_list_p;
      IFEND;
      index := index + 1;
    WHILEND;

{  Check for only one selection involved in the put_field

    IF selection_list_head_p^.link_p = NIL THEN
      join_predecessor_status := one_selection;
      RETURN; {----->
    IFEND;

{ There is more than one selection in the put_field

    prev_p := selection_list_head_p;
    next_p := prev_p^.link_p;
{ Order selection list so that every entry after the head is contained in
{ the head's predecessor path
    WHILE next_p <> NIL DO
      IF sel1_in_sel2_chain (next_p, selection_list_head_p) THEN
{ advance next and previous pointers
        prev_p := next_p;
        next_p := next_p^.link_p;
      ELSEIF sel1_in_sel2_chain (selection_list_head_p, next_p) THEN
{ move next to head of list
        prev_p^.link_p := next_p^.link_p;
        next_p^.link_p := selection_list_head_p^.link_p;
        selection_list_head_p := next_p;
{ advance next, but not previous
        next_p := prev_p^.link_p;
      ELSE
{ Neither selection is contained in the other's chain, so no single chain exists
        join_predecessor_status := no_predecessor_path;
        RETURN; {----->
      IFEND;
    WHILEND;

{ Made it to end of selection list, so a single path exists
    selection_p := selection_list_head_p^.selection_p;
    join_predecessor_status := predecessor_path;

  PROCEND check_predecessor_path;

?? OLDTITLE ??
?? NEWTITLE := 'check_recursive_predecessor', EJECT ??

{ PURPOSE:
{   The purpose of this request is to ensure the selection's predecessor chain is not recursive.

  PROCEDURE check_recursive_predecessor
    (    selection_p: ^selection;
         predecessor_p: ^selection;
     VAR status: ost$status);

    VAR
      predecessor_selection_p: ^selection;

    status.normal := TRUE;

    predecessor_selection_p := predecessor_p;
    REPEAT
      IF predecessor_selection_p^.predecessor_job_statistic_p <> NIL THEN
        predecessor_selection_p := predecessor_selection_p^.predecessor_job_statistic_p;
      ELSE { Must be task predecessor
        predecessor_selection_p := predecessor_selection_p^.predecessor_task_statistic_p;
      IFEND;
    UNTIL (predecessor_selection_p = NIL) OR (predecessor_selection_p = selection_p);

    IF predecessor_selection_p = selection_p THEN
      osp$set_status_condition (pte$predecessor_itself, status);
    IFEND;

  PROCEND check_recursive_predecessor;

?? OLDTITLE ??
?? NEWTITLE := 'check_duplicate_field_name', EJECT ??

{ PURPOSE:
{   The purpose of this request is to ensure that the field_name is not used by a previously defined field in
{ any of the selections.
{
{ DESIGN:
{   Scan the field list in each of the selections in the selection list and check
{ if the field_name is the same as the new field name.

  PROCEDURE check_duplicate_field_name
    (    field_name: ost$name;
     VAR status: ost$status);

    VAR
      field_p: ^field,
      selection_p: ^selection;

    status.normal := TRUE;

    selection_p := ptv$selection_chain_head_p;
    WHILE selection_p <> NIL DO
      field_p := selection_p^.field_chain_p;
      WHILE (field_p <> NIL) AND (field_p^.field_name <> field_name) DO
        field_p := field_p^.field_chain_link_p;
      WHILEND;

      IF field_p <> NIL THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$redefined_field, field_name, status);
        RETURN; {----->
      IFEND;
      selection_p := selection_p^.selection_chain_link_p;
    WHILEND;

  PROCEND check_duplicate_field_name;

?? OLDTITLE ??
?? NEWTITLE := 'check_duplicate_selection_name', EJECT ??

{ PURPOSE:
{   The purpose of this request is to ensure that the selection_name is not used by a previously defined
{ selection.
{
{ DESIGN:
{   Scan the selection list and check if the selection_name is the same as the new selection name.

  PROCEDURE check_duplicate_selection_name
    (    selection_name: ost$name;
     VAR status: ost$status);

    VAR
      selection_p: ^selection;

    status.normal := TRUE;

    selection_p := ptv$selection_chain_head_p;
    WHILE (selection_p <> NIL) AND (selection_p^.name <> selection_name) DO
      selection_p := selection_p^.selection_chain_link_p;
    WHILEND;
    IF selection_p <> NIL THEN
      osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$redefined_selection, selection_name, status);
    IFEND;

  PROCEND check_duplicate_selection_name;

?? OLDTITLE ??
?? NEWTITLE := 'check_summary', EJECT ??

{ PURPOSE:
{   The purpose of this request is to check if the display option that the user selected is allowed for the
{ field type.

  PROCEDURE check_summary
    (    field_type: type_of_field;
         field_name: ost$name;
         display_option: ost$name;
     VAR summary: summary_type;
     VAR status: ost$status);

    TYPE
      summary_set_type = set of summary_type;

    CASE field_type OF

    = counter_field =
      { Counter field accept all display options.

    = number_of_counters_field, descriptive_data_size_field =
      IF summary IN $summary_set_type [interval, elapsed_time_since_predecessor] THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$unsupported_display_option, display_option,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
        CASE field_type OF
        = number_of_counters_field =
          osp$append_status_parameter (osc$status_parameter_delimiter, 'NUMBER OF COUNTER', status);
        = descriptive_data_size_field =
          osp$append_status_parameter (osc$status_parameter_delimiter, 'DESCRIPTIVE DATA SIZE', status);
        ELSE
        CASEND;
      IFEND;

    = descriptive_data_field, date_time_field, statistic_code_field, system_job_name_field,
          global_task_id_field =
      IF summary = sum THEN
        summary := first_occurrence;
      ELSEIF summary IN $summary_set_type [mean, standard_deviation, minimum, maximum, sum_per_second,
            interval, elapsed_time_since_predecessor] THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$unsupported_display_option, display_option,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
      IFEND;

    = previous_occurrence_field, predecessor_field, predecessor_chain_head_field, value_per_second_field,
          occurrence_per_second_field =
      IF summary IN $summary_set_type [sum_per_second, interval, elapsed_time_since_predecessor] THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$unsupported_display_option, display_option,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
      IFEND;

    = text_field =
      IF summary = sum THEN
        summary := first_occurrence;
      ELSEIF summary IN $summary_set_type [mean, standard_deviation, minimum, maximum, sum_per_second,
            interval, elapsed_time_since_predecessor, count, count_per_second] THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$unsupported_display_option, display_option,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, field_name, status);
      IFEND;

    ELSE
    CASEND;

  PROCEND check_summary;

?? OLDTITLE ??
?? NEWTITLE := 'check_undefined_selection', EJECT ??

{ PURPOSE:
{   The purpose of this request is to find the input selection name.
{     If the selection is defined then the procedure returns a pointer to the selection record,
{     If the selection is not defined, the procedure sets the status to abnormal.
{
{ DESIGN:
{   Scan the selection list and check if the selection_name is the name of a defined selection.

  PROCEDURE check_undefined_selection
    (    selection_name: ost$name;
         condition_code: integer;
     VAR selection_p: ^selection;
     VAR status: ost$status);

    status.normal := TRUE;

    selection_p := ptv$selection_chain_head_p;
    WHILE (selection_p <> NIL) AND (selection_p^.name <> selection_name) DO
      selection_p := selection_p^.selection_chain_link_p;
    WHILEND;
    IF selection_p = NIL THEN
      osp$set_status_abnormal (ptc$analyze_binary_log_id, condition_code, selection_name, status);
    IFEND;

  PROCEND check_undefined_selection;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] collect_counter', EJECT ??

{ PURPOSE
{   The purpose of this request is to collect information for a counter.
{
{ DESIGN
{   If the counter value is large, a sum overflow can occur when it computes the sum of the counter values.
{ If that happens, the utility issues an error message and all the summaries that depended on the sum (sum,
{ mean, standard_deviation and sum_per_second) are meaningless.
{   If a negative value is computed for an incremental counter and negative increments are not allowed, the
{ procedure does not use this value for any summary information.  The negative value
{ is allowed to be kept if all occurrences are being collected.  Write_field_all_occurrences and
{ write_interval_field will detect undesirable negative increments and not report them.
{
{
{ NOTE:
{  - IF a counter is missing from the statistic record (counter number is greater than the number of counters
{    in the statistic record) the counter value will be 0.

  PROCEDURE [INLINE] collect_counter
    (    statistic_header_p: ^sft$statistic_header;
         selection_p: ^selection;
         counters_p: sft$counters;
         field_p { input, output } : ^field);

    VAR
      counter_value: integer,
      counter_value_real: real,
      interval: pmt$time_increment,
      local_status: ost$status;

    IF field_p^.counter_number <= statistic_header_p^.number_of_counters THEN

      IF field_p^.incremental THEN
        IF field_p^.field_summary.count = 0 THEN
          field_p^.last_value := counters_p^ [field_p^.counter_number];
          field_p^.field_summary.first_date_time := statistic_header_p^.date_time;

{  Need to set count to 1 to get past here next time.  Count is decremented by
{    one in compute_summary.

          field_p^.field_summary.count := 1;
          RETURN; {----->
        ELSE
          counter_value := counters_p^ [field_p^.counter_number] - field_p^.last_value;
          field_p^.last_value := counters_p^ [field_p^.counter_number];
        IFEND;
      ELSE
        counter_value := counters_p^ [field_p^.counter_number];
      IFEND;
    ELSE
      counter_value := 0;
    IFEND;

{ Summary
{  Don't collect summary information if the counter value is negative and
{    negative increments are not allowed

      IF field_p^.collect_summary AND ((NOT field_p^.incremental) OR (counter_value >= 0) OR
            (field_p^.allow_negative_increment)) THEN

{ First Occurrence - in case of incremental counter this is the second count.

        IF field_p^.first_value THEN
          IF NOT field_p^.incremental THEN
            field_p^.field_summary.first_date_time := statistic_header_p^.date_time;
          IFEND;
          field_p^.first_counter_value := counter_value;
          field_p^.first_value := FALSE;
        IFEND;

{ Last Occurrence

        field_p^.last_counter_value := counter_value;

{ Count

        field_p^.field_summary.count := field_p^.field_summary.count + 1;

{ Sum

        IF NOT field_p^.field_summary.sum_overflow THEN
          IF UPPERVALUE (field_p^.field_summary.sum) - field_p^.field_summary.sum > counter_value THEN
            field_p^.field_summary.sum := field_p^.field_summary.sum + counter_value;
            counter_value_real := $REAL (counter_value);
            field_p^.field_summary.square_sum := field_p^.field_summary.square_sum + counter_value_real *
                  counter_value_real;
          ELSE
            field_p^.field_summary.sum_overflow := TRUE;
          IFEND;
        IFEND;

{ Minimum

        IF counter_value < field_p^.field_summary.minimum THEN
          field_p^.field_summary.minimum := counter_value;
        IFEND;

{ Maximum

        IF counter_value > field_p^.field_summary.maximum THEN
          field_p^.field_summary.maximum := counter_value;
        IFEND;

{ Elapsed_time_since_predecessor

        IF (selection_p^.predecessor_job_statistic_p <> NIL) OR
              (selection_p^.predecessor_task_statistic_p <> NIL) THEN
          IF selection_p^.predecessor_job_statistic_p <> NIL THEN
            pmp$compute_date_time_increment (ptv$predecessor_job_date_time, statistic_header_p^.date_time,
                  interval, local_status);
          ELSE
            pmp$compute_date_time_increment (ptv$predecessor_task_date_time, statistic_header_p^.date_time,
                  interval, local_status);
          IFEND;
          IF local_status.normal THEN
            field_p^.field_summary.elapsed_time_since_predecessor :=
                  field_p^.field_summary.elapsed_time_since_predecessor + interval_to_millisecond (interval);
          IFEND;
        IFEND;

      IFEND;

{ All Occurrences

      IF field_p^.collect_all_occurrences THEN
        IF field_p^.counter_value_tail_p^.index = ptc$statistics_array_size THEN
          NEXT field_p^.counter_value_tail_p^.link_p IN ptv$data_segment_p.sequence_pointer;
          field_p^.counter_value_tail_p := field_p^.counter_value_tail_p^.link_p;
          field_p^.counter_value_tail_p^.link_p := NIL;
          field_p^.counter_value_tail_p^.index := 0;
        IFEND;
        field_p^.counter_value_tail_p^.index := field_p^.counter_value_tail_p^.index + 1;
        field_p^.counter_value_tail_p^.value_array [field_p^.counter_value_tail_p^.index] := counter_value;
      IFEND;

  PROCEND collect_counter;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] collect_date_time', EJECT ??

{ PURPOSE
{   The purpose of this request is to collect date_time data.
{

  PROCEDURE [INLINE] collect_date_time
    (    statistic_header_p: ^sft$statistic_header;
         field_p { input, output } : ^field);

{ Summary

    IF field_p^.collect_summary THEN

{ First Occurrence

      IF field_p^.first_value THEN
        field_p^.first_date_time_value := statistic_header_p^.date_time;
        field_p^.field_summary.first_date_time := statistic_header_p^.date_time;
        field_p^.first_value := FALSE;
      IFEND;

{ Last Occurrence

      field_p^.last_date_time_value := statistic_header_p^.date_time;

{ Count

      field_p^.field_summary.count := field_p^.field_summary.count + 1;

    IFEND;

{ All Occurrences

    IF field_p^.collect_all_occurrences THEN
      IF field_p^.date_time_value_tail_p^.index = ptc$statistics_array_size THEN
        NEXT field_p^.date_time_value_tail_p^.link_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.date_time_value_tail_p := field_p^.date_time_value_tail_p^.link_p;
        field_p^.date_time_value_tail_p^.link_p := NIL;
        field_p^.date_time_value_tail_p^.index := 0;
      IFEND;
      field_p^.date_time_value_tail_p^.index := field_p^.date_time_value_tail_p^.index + 1;
      field_p^.date_time_value_tail_p^.value_array [field_p^.date_time_value_tail_p^.index] :=
            statistic_header_p^.date_time;
    IFEND;

  PROCEND collect_date_time;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] collect_descriptive_data', EJECT ??

{ PURPOSE
{   The purpose of this request is to collect descriptive data for put_field (display_option all_occurrences)
{ and put_interval_field report entry.

  PROCEDURE [INLINE] collect_descriptive_data
    (    statistic_header_p: ^sft$statistic_header;
         descriptive_p: ^sft$descriptive_data;
         field_p { input, output } : ^field);

    VAR
      null_subfield: boolean,
      substring_found: boolean,
      descriptive_data_length: integer,
      descriptive_data_start: integer;

{ Summary

    IF field_p^.collect_summary THEN

{ First Occurrence

      IF field_p^.first_value THEN
        field_p^.field_summary.first_date_time := statistic_header_p^.date_time;
        field_p^.first_value := FALSE;
        IF descriptive_p <> NIL THEN
          get_descriptive_data_subfield (descriptive_p, statistic_header_p^.descriptive_data_size,
                field_p^.subfield_position, field_p^.subfield_length, field_p^.subfield_number,
                field_p^.subfield_delimiter, null_subfield, substring_found, descriptive_data_start,
                descriptive_data_length);

          IF substring_found THEN
            NEXT field_p^.first_descriptive_value_p: [descriptive_data_length] IN
                  ptv$data_segment_p.sequence_pointer;
            field_p^.first_descriptive_value_p^ := descriptive_p^
                  (descriptive_data_start, descriptive_data_length);
          IFEND;
        IFEND;
      IFEND;

{ Last Occurrence
{    See end of collect all occurrences IF statement.

{ Count

      field_p^.field_summary.count := field_p^.field_summary.count + 1;

    IFEND;

{ All Occurrences

    IF field_p^.collect_all_occurrences THEN
      IF field_p^.descriptive_value_tail_p^.index = ptc$statistics_array_size THEN
        NEXT field_p^.descriptive_value_tail_p^.link_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.descriptive_value_tail_p := field_p^.descriptive_value_tail_p^.link_p;
        field_p^.descriptive_value_tail_p^.link_p := NIL;
        field_p^.descriptive_value_tail_p^.index := 0;
      IFEND;
      field_p^.descriptive_value_tail_p^.index := field_p^.descriptive_value_tail_p^.index + 1;

      IF descriptive_p <> NIL THEN
        get_descriptive_data_subfield (descriptive_p, statistic_header_p^.descriptive_data_size,
              field_p^.subfield_position, field_p^.subfield_length, field_p^.subfield_number,
              field_p^.subfield_delimiter, null_subfield, substring_found, descriptive_data_start,
              descriptive_data_length);
      ELSE
        substring_found := FALSE;
      IFEND;

      IF substring_found THEN
        NEXT field_p^.descriptive_value_tail_p^.value_array [field_p^.descriptive_value_tail_p^.
              index]: [descriptive_data_length] IN ptv$data_segment_p.sequence_pointer;
        field_p^.descriptive_value_tail_p^.value_array [field_p^.descriptive_value_tail_p^.index]^ :=
              descriptive_p^ (descriptive_data_start, descriptive_data_length);
      ELSE
        field_p^.descriptive_value_tail_p^.value_array [field_p^.descriptive_value_tail_p^.index] := NIL;
      IFEND;
      IF field_p^.collect_summary THEN
{  Assign last value pointer when all occurrences are being collected
        field_p^.last_descriptive_value_p := field_p^.descriptive_value_tail_p^.
              value_array [field_p^.descriptive_value_tail_p^.index]
      IFEND;
    ELSEIF field_p^.collect_summary THEN
      IF descriptive_p <> NIL THEN
        get_descriptive_data_subfield (descriptive_p, statistic_header_p^.descriptive_data_size,
              field_p^.subfield_position, field_p^.subfield_length, field_p^.subfield_number,
              field_p^.subfield_delimiter, null_subfield, substring_found, descriptive_data_start,
              descriptive_data_length);
      ELSE
        substring_found := FALSE;
      IFEND;

      IF substring_found THEN

{  Assign last value pointer if not collect all occurrences
        IF field_p^.last_descriptive_value_p = NIL THEN
          NEXT field_p^.last_descriptive_value_p: [sfc$max_descriptive_data_size] IN
                ptv$data_segment_p.sequence_pointer;
        IFEND;
        field_p^.last_descriptive_value_p^ := descriptive_p^ (descriptive_data_start,
              descriptive_data_length);
      IFEND;
    IFEND;

  PROCEND collect_descriptive_data;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] collect_descriptive_data_size', EJECT ??

{ PURPOSE
{   The purpose of this request is to collect data about the size of descriptive data fields.
{

  PROCEDURE [INLINE] collect_descriptive_data_size
    (    statistic_header_p: ^sft$statistic_header;
         field_p { input, output } : ^field);

    VAR
      counter_value_real: real;

{ Summary

    IF field_p^.collect_summary THEN

{ First Occurrence

      IF field_p^.first_value THEN
        field_p^.first_dd_size_value := statistic_header_p^.descriptive_data_size;
        field_p^.field_summary.first_date_time := statistic_header_p^.date_time;
        field_p^.first_value := FALSE;
      IFEND;

{ Last Occurrence

      field_p^.last_dd_size_value := statistic_header_p^.descriptive_data_size;

{ Count

      field_p^.field_summary.count := field_p^.field_summary.count + 1;

{ Sum

      IF NOT field_p^.field_summary.sum_overflow THEN
        IF UPPERVALUE (field_p^.field_summary.sum) - field_p^.field_summary.sum >
              statistic_header_p^.descriptive_data_size THEN
          field_p^.field_summary.sum := field_p^.field_summary.sum +
                statistic_header_p^.descriptive_data_size;
          counter_value_real := $REAL (statistic_header_p^.descriptive_data_size);
          field_p^.field_summary.square_sum := field_p^.field_summary.square_sum + counter_value_real *
                counter_value_real;
        ELSE
          field_p^.field_summary.sum_overflow := TRUE;
        IFEND;
      IFEND;

{ Minimum

      IF statistic_header_p^.descriptive_data_size < field_p^.field_summary.minimum THEN
        field_p^.field_summary.minimum := statistic_header_p^.descriptive_data_size;
      IFEND;

{ Maximum

      IF statistic_header_p^.descriptive_data_size > field_p^.field_summary.maximum THEN
        field_p^.field_summary.maximum := statistic_header_p^.descriptive_data_size;
      IFEND;

    IFEND;

{ All Occurrences

    IF field_p^.collect_all_occurrences THEN
      IF field_p^.dd_size_value_tail_p^.index = ptc$statistics_array_size THEN
        NEXT field_p^.dd_size_value_tail_p^.link_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.dd_size_value_tail_p := field_p^.dd_size_value_tail_p^.link_p;
        field_p^.dd_size_value_tail_p^.link_p := NIL;
        field_p^.dd_size_value_tail_p^.index := 0;
      IFEND;
      field_p^.dd_size_value_tail_p^.index := field_p^.dd_size_value_tail_p^.index + 1;
      field_p^.dd_size_value_tail_p^.value_array [field_p^.dd_size_value_tail_p^.index] :=
            statistic_header_p^.descriptive_data_size;
    IFEND;

  PROCEND collect_descriptive_data_size;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] collect_elapsed_time', EJECT ??

{ PURPOSE
{   The purpose of this request is to collect data about elapsed time fields.
{

  PROCEDURE [INLINE] collect_elapsed_time
    (    date_time_1: ost$date_time;
         date_time_2: ost$date_time;
         field_p { input, output } : ^field);

    VAR
      interval: pmt$time_increment,
      interval_value: integer,
      interval_value_real: real,
      local_status: ost$status;

    pmp$compute_date_time_increment (date_time_1, date_time_2, interval, local_status);
    interval_value := interval_to_millisecond (interval);

{ Summary

    IF field_p^.collect_summary THEN

{ First Occurrence

      IF field_p^.first_value THEN
        field_p^.first_elapsed_time_value := interval_value;
        field_p^.field_summary.first_date_time := date_time_1;
        field_p^.first_value := FALSE;
      IFEND;

{ Predecessor or predecessor_chain_head beginning statistics may not occur in
{  The same order as the successors, so test for earliest date_time.

      IF date_time_1_gt_date_time_2 (field_p^.field_summary.first_date_time, date_time_1) THEN
        field_p^.field_summary.first_date_time := date_time_1;
      IFEND;

{ Last Occurrence

      field_p^.last_elapsed_time_value := interval_value;

{ Count

      field_p^.field_summary.count := field_p^.field_summary.count + 1;

{ Sum

      IF NOT field_p^.field_summary.sum_overflow THEN
        IF UPPERVALUE (field_p^.field_summary.sum) - field_p^.field_summary.sum > interval_value THEN
          field_p^.field_summary.sum := field_p^.field_summary.sum + interval_value;
          interval_value_real := $REAL (interval_value);
          field_p^.field_summary.square_sum := field_p^.field_summary.square_sum + interval_value_real *
                interval_value_real;
        ELSE
          field_p^.field_summary.sum_overflow := TRUE;
        IFEND;
      IFEND;

{ Minimum

      IF interval_value < field_p^.field_summary.minimum THEN
        field_p^.field_summary.minimum := interval_value;
      IFEND;

{ Maximum

      IF interval_value > field_p^.field_summary.maximum THEN
        field_p^.field_summary.maximum := interval_value;
      IFEND;

    IFEND;

{ All Occurrences

    IF field_p^.collect_all_occurrences THEN
      IF field_p^.elapsed_time_value_tail_p^.index = ptc$statistics_array_size THEN
        NEXT field_p^.elapsed_time_value_tail_p^.link_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.elapsed_time_value_tail_p := field_p^.elapsed_time_value_tail_p^.link_p;
        field_p^.elapsed_time_value_tail_p^.link_p := NIL;
        field_p^.elapsed_time_value_tail_p^.index := 0;
      IFEND;
      field_p^.elapsed_time_value_tail_p^.index := field_p^.elapsed_time_value_tail_p^.index + 1;
      field_p^.elapsed_time_value_tail_p^.value_array [field_p^.elapsed_time_value_tail_p^.index] :=
            interval_value;
    IFEND;

  PROCEND collect_elapsed_time;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] collect_elapsed_time_calc', EJECT ??

{ PURPOSE
{   The purpose of this request is to collect data from calculations involving elapsed time values as
{ the denominator and possibly counter values as the numerator.
{

  PROCEDURE [INLINE] collect_elapsed_time_calc
    (    date_time_1: ost$date_time;
         date_time_2: ost$date_time;
         value: real;
         field_p { input, output } : ^field);

    VAR
      elapsed_time_value: real,
      field_value: real,
      interval: pmt$time_increment,
      local_status: ost$status;

    pmp$compute_date_time_increment (date_time_1, date_time_2, interval, local_status);
    elapsed_time_value := $REAL (interval_to_millisecond (interval));

{  Assign a value of 1 millisecond to the elapsed time if it equals 0

    IF elapsed_time_value < 1.0 THEN
      elapsed_time_value := 1.0;
    IFEND;
    field_value := value / elapsed_time_value;

{ Summary
{  Don't collect summary information if the field value is negative and
{    negative increments are not allowed

    IF field_p^.collect_summary AND ((field_value >= 0.0) OR (field_p^.allow_negative_increment)) THEN

{ First Occurrence

      IF field_p^.first_value THEN
        field_p^.first_value_per_second_value := field_value;
        field_p^.field_summary.first_date_time := date_time_2;
        field_p^.first_value := FALSE;
      IFEND;

{ Predecessor or predecessor_chain_head beginning statistics may not occur in
{  The same order as the successors, so test for earliest date_time.

      IF date_time_1_gt_date_time_2 (field_p^.field_summary.first_date_time, date_time_1) THEN
        field_p^.field_summary.first_date_time := date_time_1;
      IFEND;

{ Last Occurrence

      field_p^.last_value_per_second_value := field_value;

{ Count

      field_p^.field_summary.count := field_p^.field_summary.count + 1;

{ Sum

      field_p^.value_per_second_sum := field_p^.value_per_second_sum + field_value;
      field_p^.field_summary.square_sum := field_p^.field_summary.square_sum + field_value * field_value;

{ Minimum

      IF field_value < field_p^.value_per_second_minimum THEN
        field_p^.value_per_second_minimum := field_value;
      IFEND;

{ Maximum

      IF field_value > field_p^.value_per_second_maximum THEN
        field_p^.value_per_second_maximum := field_value;
      IFEND;

    IFEND;

{ All Occurrences

    IF field_p^.collect_all_occurrences THEN
      IF field_p^.value_per_second_value_tail_p^.index = ptc$statistics_array_size THEN
        NEXT field_p^.value_per_second_value_tail_p^.link_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.value_per_second_value_tail_p := field_p^.value_per_second_value_tail_p^.link_p;
        field_p^.value_per_second_value_tail_p^.link_p := NIL;
        field_p^.value_per_second_value_tail_p^.index := 0;
      IFEND;
      field_p^.value_per_second_value_tail_p^.index := field_p^.value_per_second_value_tail_p^.index + 1;
      field_p^.value_per_second_value_tail_p^.value_array [field_p^.value_per_second_value_tail_p^.index] :=
            field_value;
    IFEND;

  PROCEND collect_elapsed_time_calc;

?? OLDTITLE ??
?? NEWTITLE := 'collect_field', EJECT ??

{ PURPOSE:
{   The purpose of this request is to collect data from all types of fields based on the report entry
{     specifications.
{
{ DESIGN:
{   The procedure collects all the data that it needs for the defined report for the current selection.  If
{ one or more of the counters defined for the selection is incremental,
{ the procedure checks if the current statistic selection is based on date_time
{ with continuous_date_time = FALSE (selecting statistics in a window of time in the day) and the current
{ statistic is the first statistic in a new day, then the current statistic counter's value is a new base for
{ the incremental calculations.  The value of the nonincremental counters are ignored in order to match the
{ number of values collected for incremental and nonincremental counters defined for the same selection.  The
{ interval between the current statistic and the previous one is ignored.
{
{   The procedure collects date_time and predecessor date_time at the selection level.  That data will be
{ available for each field defined for that selection for the interval report.  At the field level the
{ procedure collects summary data for summary report and counter values for an interval report.
{
{ NOTE:
{   The feature called skip deadstart described above causes problems when incremental counters can receive
{ negative increments.  Analyze_Binary_Log assumes that there was a deadstart and computes the wrong values.
{ Because of that feature test PT0002 failed.
{   The feature statistic header fields undoes some of skip deadstart (New counter value < old counter value).
{ The number of values are matched in write_field_ao_report and write_interval_report.

  PROCEDURE collect_field
    (    selection_p: ^selection;
         statistic_header_p: ^sft$statistic_header;
         counters_p: sft$counters;
         descriptive_p: ^sft$descriptive_data;
         predecessor_p: ^successor;
     VAR status: ost$status);

    VAR
      field_p: ^field,
      successor_p: ^successor;

    status.normal := TRUE;

    IF selection_p^.incremental THEN
      process_incremental_selection (statistic_header_p, selection_p, counters_p, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    IFEND;

    collect_selection (statistic_header_p, selection_p);

    field_p := selection_p^.field_chain_p;
    WHILE field_p <> NIL DO

      CASE field_p^.field_type OF

      = counter_field =
        collect_counter (statistic_header_p, selection_p, counters_p, field_p);

      = descriptive_data_field =
        collect_descriptive_data (statistic_header_p, descriptive_p, field_p);

      = date_time_field =
        collect_date_time (statistic_header_p, field_p);

      = statistic_code_field =
        collect_statistic_code (statistic_header_p, field_p);

      = system_job_name_field =
        collect_system_job_name (statistic_header_p, field_p);

      = global_task_id_field =
        collect_global_task_id (statistic_header_p, field_p);

      = number_of_counters_field =
        collect_number_of_counters (statistic_header_p, field_p);

      = descriptive_data_size_field =
        collect_descriptive_data_size (statistic_header_p, field_p);

      = previous_occurrence_field, predecessor_field, predecessor_chain_head_field, value_per_second_field,
            occurrence_per_second_field =
        elapsed_time_calculation (statistic_header_p^.date_time, predecessor_p, statistic_header_p,
              counters_p, field_p);

      = text_field =
      CASEND;

      field_p^.field_summary.last_date_time := statistic_header_p^.date_time;
      field_p := field_p^.field_chain_link_p;

    WHILEND;

    field_p := selection_p^.shadow_field_chain_p;
    WHILE field_p <> NIL DO
      successor_p := predecessor_p;
      WHILE successor_p^.selection_p <> field_p^.original_selection_p DO
        successor_p := successor_p^.predecessor_p;
      WHILEND;

      CASE field_p^.field_type OF

      = counter_field =
        collect_counter (successor_p^.statistic_header_p, successor_p^.selection_p, successor_p^.counters_p,
              field_p);

      = descriptive_data_field =
        collect_descriptive_data (successor_p^.statistic_header_p, successor_p^.descriptive_data_p, field_p);

      = date_time_field =
        collect_date_time (successor_p^.statistic_header_p, field_p);

      = statistic_code_field =
        collect_statistic_code (successor_p^.statistic_header_p, field_p);

      = system_job_name_field =
        collect_system_job_name (successor_p^.statistic_header_p, field_p);

      = global_task_id_field =
        collect_global_task_id (successor_p^.statistic_header_p, field_p);

      = number_of_counters_field =
        collect_number_of_counters (successor_p^.statistic_header_p, field_p);

      = descriptive_data_size_field =
        collect_descriptive_data_size (successor_p^.statistic_header_p, field_p);

      = previous_occurrence_field, predecessor_field, predecessor_chain_head_field, value_per_second_field,
            occurrence_per_second_field =
        elapsed_time_calculation (successor_p^.statistic_header_p^.date_time, successor_p^.predecessor_p,
              successor_p^.statistic_header_p, successor_p^.counters_p, field_p);

      = text_field =
      CASEND;

      field_p^.field_summary.last_date_time := statistic_header_p^.date_time;
      field_p := field_p^.field_chain_link_p;

    WHILEND;

  PROCEND collect_field;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] collect_global_task_id', EJECT ??

{ PURPOSE
{   The purpose of this request is to collect global task id data.
{

  PROCEDURE [INLINE] collect_global_task_id
    (    statistic_header_p: ^sft$statistic_header;
         field_p { input, output } : ^field);

{ Summary

    IF field_p^.collect_summary THEN

{ First Occurrence

      IF field_p^.first_value THEN
        field_p^.first_global_task_id_value := statistic_header_p^.task_id;
        field_p^.field_summary.first_date_time := statistic_header_p^.date_time;
        field_p^.first_value := FALSE;
      IFEND;

{ Last Occurrence

      field_p^.last_global_task_id_value := statistic_header_p^.task_id;

{ Count

      field_p^.field_summary.count := field_p^.field_summary.count + 1;

    IFEND;

{ All Occurrences

    IF field_p^.collect_all_occurrences THEN
      IF field_p^.global_task_id_value_tail_p^.index = ptc$statistics_array_size THEN
        NEXT field_p^.global_task_id_value_tail_p^.link_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.global_task_id_value_tail_p := field_p^.global_task_id_value_tail_p^.link_p;
        field_p^.global_task_id_value_tail_p^.link_p := NIL;
        field_p^.global_task_id_value_tail_p^.index := 0;
      IFEND;
      field_p^.global_task_id_value_tail_p^.index := field_p^.global_task_id_value_tail_p^.index + 1;
      field_p^.global_task_id_value_tail_p^.value_array [field_p^.global_task_id_value_tail_p^.index] :=
            statistic_header_p^.task_id;
    IFEND;

  PROCEND collect_global_task_id;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] collect_number_of_counters', EJECT ??

{ PURPOSE
{   The purpose of this request is to collect data about the number of counters.
{

  PROCEDURE [INLINE] collect_number_of_counters
    (    statistic_header_p: ^sft$statistic_header;
         field_p { input, output } : ^field);

    VAR
      counter_value_real: real;

{ Summary

    IF field_p^.collect_summary THEN

{ First Occurrence

      IF field_p^.first_value THEN
        field_p^.first_num_of_counters_value := statistic_header_p^.number_of_counters;
        field_p^.field_summary.first_date_time := statistic_header_p^.date_time;
        field_p^.first_value := FALSE;
      IFEND;

{ Last Occurrence

      field_p^.last_num_of_counters_value := statistic_header_p^.number_of_counters;

{ Count

      field_p^.field_summary.count := field_p^.field_summary.count + 1;

{ Sum

      IF NOT field_p^.field_summary.sum_overflow THEN
        IF UPPERVALUE (field_p^.field_summary.sum) - field_p^.field_summary.sum >
              statistic_header_p^.number_of_counters THEN
          field_p^.field_summary.sum := field_p^.field_summary.sum + statistic_header_p^.number_of_counters;
          counter_value_real := $REAL (statistic_header_p^.number_of_counters);
          field_p^.field_summary.square_sum := field_p^.field_summary.square_sum + counter_value_real *
                counter_value_real;
        ELSE
          field_p^.field_summary.sum_overflow := TRUE;
        IFEND;
      IFEND;

{ Minimum

      IF statistic_header_p^.number_of_counters < field_p^.field_summary.minimum THEN
        field_p^.field_summary.minimum := statistic_header_p^.number_of_counters;
      IFEND;

{ Maximum

      IF statistic_header_p^.number_of_counters > field_p^.field_summary.maximum THEN
        field_p^.field_summary.maximum := statistic_header_p^.number_of_counters;
      IFEND;

    IFEND;

{ All Occurrences

    IF field_p^.collect_all_occurrences THEN
      IF field_p^.number_of_counters_value_tail_p^.index = ptc$statistics_array_size THEN
        NEXT field_p^.number_of_counters_value_tail_p^.link_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.number_of_counters_value_tail_p := field_p^.number_of_counters_value_tail_p^.link_p;
        field_p^.number_of_counters_value_tail_p^.link_p := NIL;
        field_p^.number_of_counters_value_tail_p^.index := 0;
      IFEND;
      field_p^.number_of_counters_value_tail_p^.index := field_p^.number_of_counters_value_tail_p^.index + 1;
      field_p^.number_of_counters_value_tail_p^.value_array
            [field_p^.number_of_counters_value_tail_p^.index] := statistic_header_p^.number_of_counters;
    IFEND;

  PROCEND collect_number_of_counters;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] collect_selection', EJECT ??

{ PURPOSE
{   The purpose of this request is to collect selection level data.
{     This is only date_time data.
{

  PROCEDURE [INLINE] collect_selection
    (    statistic_header_p: ^sft$statistic_header;
         selection_p { input, output } : ^selection);

    IF selection_p^.collect_date_time THEN
      IF selection_p^.date_time_value_tail_p^.index = ptc$statistics_array_size THEN
        NEXT selection_p^.date_time_value_tail_p^.link_p IN ptv$data_segment_p.sequence_pointer;
        selection_p^.date_time_value_tail_p := selection_p^.date_time_value_tail_p^.link_p;
        selection_p^.date_time_value_tail_p^.link_p := NIL;
        selection_p^.date_time_value_tail_p^.index := 0;
      IFEND;
      selection_p^.date_time_value_tail_p^.index := selection_p^.date_time_value_tail_p^.index + 1;
      selection_p^.date_time_value_tail_p^.value_array [selection_p^.date_time_value_tail_p^.index] :=
            statistic_header_p^.date_time;
      IF selection_p^.skip_date_time THEN
        selection_p^.skip_date_time_tail_p^.date_time_after_skip := statistic_header_p^.date_time;
        selection_p^.skip_date_time := FALSE;
      IFEND;
    IFEND;

    IF selection_p^.collect_predecessor_date_time THEN
      IF selection_p^.predecessor_dt_value_tail_p^.index = ptc$statistics_array_size THEN
        NEXT selection_p^.predecessor_dt_value_tail_p^.link_p IN ptv$data_segment_p.sequence_pointer;
        selection_p^.predecessor_dt_value_tail_p := selection_p^.predecessor_dt_value_tail_p^.link_p;
        selection_p^.predecessor_dt_value_tail_p^.link_p := NIL;
        selection_p^.predecessor_dt_value_tail_p^.index := 0;
      IFEND;
      selection_p^.predecessor_dt_value_tail_p^.index := selection_p^.predecessor_dt_value_tail_p^.index + 1;
      IF selection_p^.predecessor_job_statistic_p <> NIL THEN
        selection_p^.predecessor_dt_value_tail_p^.value_array
              [selection_p^.predecessor_dt_value_tail_p^.index] := ptv$predecessor_job_date_time;
      ELSEIF selection_p^.predecessor_task_statistic_p <> NIL THEN
        selection_p^.predecessor_dt_value_tail_p^.value_array
              [selection_p^.predecessor_dt_value_tail_p^.index] := ptv$predecessor_task_date_time;
      IFEND;
    IFEND;

  PROCEND collect_selection;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] collect_statistic_code', EJECT ??

{ PURPOSE
{   The purpose of this request is to collect statistic code data.
{

  PROCEDURE [INLINE] collect_statistic_code
    (    statistic_header_p: ^sft$statistic_header;
         field_p { input, output } : ^field);

{ Summary

    IF field_p^.collect_summary THEN

{ First Occurrence

      IF field_p^.first_value THEN
        field_p^.first_statistic_code_value := statistic_header_p^.statistic_code;
        field_p^.field_summary.first_date_time := statistic_header_p^.date_time;
        field_p^.first_value := FALSE;
      IFEND;

{ Last Occurrence

      field_p^.last_statistic_code_value := statistic_header_p^.statistic_code;

{ Count

      field_p^.field_summary.count := field_p^.field_summary.count + 1;

    IFEND;

{ All Occurrences

    IF field_p^.collect_all_occurrences THEN
      IF field_p^.statistic_code_value_tail_p^.index = ptc$statistics_array_size THEN
        NEXT field_p^.statistic_code_value_tail_p^.link_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.statistic_code_value_tail_p := field_p^.statistic_code_value_tail_p^.link_p;
        field_p^.statistic_code_value_tail_p^.link_p := NIL;
        field_p^.statistic_code_value_tail_p^.index := 0;
      IFEND;
      field_p^.statistic_code_value_tail_p^.index := field_p^.statistic_code_value_tail_p^.index + 1;
      field_p^.statistic_code_value_tail_p^.value_array [field_p^.statistic_code_value_tail_p^.index] :=
            statistic_header_p^.statistic_code;
    IFEND;

  PROCEND collect_statistic_code;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] collect_system_job_name', EJECT ??

{ PURPOSE
{   The purpose of this request is to collect system job name data.
{

  PROCEDURE [INLINE] collect_system_job_name
    (    statistic_header_p: ^sft$statistic_header;
         field_p { input, output } : ^field);

{ Summary

    IF field_p^.collect_summary THEN

{ First Occurrence

      IF field_p^.first_value THEN
        field_p^.first_system_job_name_value := statistic_header_p^.job_name;
        field_p^.field_summary.first_date_time := statistic_header_p^.date_time;
        field_p^.first_value := FALSE;
      IFEND;

{ Last Occurrence

      field_p^.last_system_job_name_value := statistic_header_p^.job_name;

{ Count

      field_p^.field_summary.count := field_p^.field_summary.count + 1;

    IFEND;

{ All Occurrences

    IF field_p^.collect_all_occurrences THEN
      IF field_p^.system_job_name_value_tail_p^.index = ptc$statistics_array_size THEN
        NEXT field_p^.system_job_name_value_tail_p^.link_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.system_job_name_value_tail_p := field_p^.system_job_name_value_tail_p^.link_p;
        field_p^.system_job_name_value_tail_p^.link_p := NIL;
        field_p^.system_job_name_value_tail_p^.index := 0;
      IFEND;
      field_p^.system_job_name_value_tail_p^.index := field_p^.system_job_name_value_tail_p^.index + 1;
      field_p^.system_job_name_value_tail_p^.value_array [field_p^.system_job_name_value_tail_p^.index] :=
            statistic_header_p^.job_name;
    IFEND;

  PROCEND collect_system_job_name;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] date_time_1_gt_date_time_2', EJECT ??

{ PURPOSE:
{   The purpose of this request is to check if date_time_1 is later than date_time_2.

  FUNCTION [INLINE] date_time_1_gt_date_time_2
    (    date_time_1: ost$date_time;
         date_time_2: ost$date_time): boolean;

    VAR
      date_time_c: ^cell,
      date_time_s_1: ^string (ptc$date_time_record_size),
      date_time_s_2: ^string (ptc$date_time_record_size);

{ Compare Date_Time mapped to string, because the comparison operators (>, <, >= & <=) cannot compare
{ date_time records. The alternative is to compare the fields.

    date_time_c := ^date_time_1;
    date_time_s_1 := date_time_c;
    date_time_c := ^date_time_2;
    date_time_s_2 := date_time_c;
    date_time_1_gt_date_time_2 := date_time_s_1^ > date_time_s_2^;

  FUNCEND date_time_1_gt_date_time_2;

?? OLDTITLE ??
?? NEWTITLE := 'compute_summary', EJECT ??

{ PURPOSE:
{   The purpose of this request is to compute the summary for put_field and put_field_summary reports.
{
{ DESIGN
{   The procedure computes mean, standard deviation, interval, count per second , sum per second and elapsed
{ time since predecessor.  If the counter is incremental the count is reduced by 1 to exclude the base value.
{ IF the count is 0 then the minimum and maximum are set to 0.

  PROCEDURE compute_summary
    (VAR status: ost$status);

    VAR
      failing_status: ost$status,
      interval: pmt$time_increment,
      interval_ms: integer,
      field_p: ^field,
      selection_p: ^selection,
      standard_deviation_v: real;

    status.normal := TRUE;

    selection_p := ptv$selection_chain_head_p;
    WHILE selection_p <> NIL DO
      field_p := selection_p^.field_chain_p;
      WHILE field_p <> NIL DO

        IF field_p^.collect_summary THEN

{ If counter is incremental then the first value is a base value and doesn't count.

          IF (field_p^.field_summary.count > 0) AND ((field_p^.incremental) OR
                (field_p^.field_type = previous_occurrence_field) OR
                ((field_p^.field_type = value_per_second_field) AND
                (field_p^.elapsed_time = previous_occurrence)) OR
                ((field_p^.field_type = occurrence_per_second_field) AND
                (field_p^.elapsed_time = previous_occurrence))) THEN
            field_p^.field_summary.count := field_p^.field_summary.count - 1;
          IFEND;

          IF field_p^.field_summary.count > 0 THEN

{  SUM

            IF field_p^.field_summary.sum_overflow THEN
              field_p^.field_summary.sum := 0;
              osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$sum_overflow, field_p^.field_name,
                    failing_status);
              report_intermediate_error (failing_status, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
            IFEND;

{  MEAN

            IF (field_p^.field_type = value_per_second_field) OR
                  (field_p^.field_type = occurrence_per_second_field) THEN

              field_p^.field_summary.mean := field_p^.value_per_second_sum /
                    $REAL (field_p^.field_summary.count);
            ELSE
              field_p^.field_summary.mean := $REAL (field_p^.field_summary.sum) /
                    $REAL (field_p^.field_summary.count);
            IFEND;

            pmp$compute_date_time_increment (field_p^.field_summary.first_date_time,
                  field_p^.field_summary.last_date_time, interval, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            interval_ms := interval_to_millisecond (interval) - selection_p^.lost_interval;

            IF interval_ms > 0 THEN

              field_p^.field_summary.count_per_second := ($REAL (field_p^.field_summary.count) /
                    $REAL (interval_ms) * 1000.0);

              field_p^.field_summary.sum_per_second := ($REAL (field_p^.field_summary.sum) *
                    field_p^.multiplier / $REAL (interval_ms) * 1000.0);

              IF field_p^.incremental THEN
                field_p^.field_summary.interval := interval_ms DIV field_p^.field_summary.count;
              ELSE
                field_p^.field_summary.interval := interval_ms DIV (field_p^.field_summary.count - 1);
              IFEND;

            IFEND;

            IF field_p^.field_summary.count > 1 THEN

{  S.D = (sum((x - mean(x))**2) / (count - 1))** 0.5
{  S.D = sqrt((sum(x)**2 + sum(mean(x)**2) - 2*mean(x)*sum(x)) / (count - 1))
{  S.D = sqrt(square_sum + mean(x)**2*count - 2*mean(x)*sum(x)) / (count - 1))

              IF (field_p^.field_type = value_per_second_field) OR
                    (field_p^.field_type = occurrence_per_second_field) THEN

                standard_deviation_v := (field_p^.field_summary.square_sum + field_p^.field_summary.mean *
                      field_p^.field_summary.mean * $REAL (field_p^.field_summary.count) - 2.0 *
                      field_p^.field_summary.mean * field_p^.value_per_second_sum) /
                      $REAL (field_p^.field_summary.count - 1);
                field_p^.field_summary.standard_deviation := mlp$rsqrt (standard_deviation_v);

              ELSE
                standard_deviation_v := (field_p^.field_summary.square_sum + field_p^.field_summary.mean *
                      field_p^.field_summary.mean * $REAL (field_p^.field_summary.count) - 2.0 *
                      field_p^.field_summary.mean * $REAL (field_p^.field_summary.sum)) /
                      $REAL (field_p^.field_summary.count - 1);
                field_p^.field_summary.standard_deviation := mlp$rsqrt (standard_deviation_v);
              IFEND;
            IFEND;

            IF field_p^.field_summary.elapsed_time_since_predecessor <> 0 THEN
              field_p^.field_summary.elapsed_time_since_predecessor :=
                    field_p^.field_summary.elapsed_time_since_predecessor DIV field_p^.field_summary.count;
            IFEND;

          ELSE
            field_p^.field_summary.minimum := 0;
            field_p^.field_summary.maximum := 0;
          IFEND;

        IFEND;

        field_p := field_p^.field_chain_link_p;
      WHILEND;
      selection_p := selection_p^.selection_chain_link_p;
    WHILEND;

  PROCEND compute_summary;

?? OLDTITLE ??
?? NEWTITLE := 'convert_integer_to_hex', EJECT ??

{ PURPOSE:
{   The purpose of this request is to convert an integer to its 64 bit hexadecimal string representation.
{
{ DESIGN
{   The procedure takes the counter integer supplied and determines whether it is positive or negative.  If
{ positive, it converts the integer into a hexadecimal string and inserts blanks after each group of four
{ characters.  If negative, it complements the upper bit of the input integer and proceeds as if it were
{ positive.  The upper character is then converted back to the corrected value after the string has been
{ created.  This value is returned to the caller.  e.g A0C4 2234 7785 F400(16)

  PROCEDURE convert_integer_to_hex
    (    counter: integer;
     VAR counter_string: string ( * );
     VAR status: ost$status);

    VAR
      positive_string: string (16),
      positive_value: integer;

    status.normal := TRUE;

    IF counter < 0 THEN
      positive_value := counter + 4000000000000000(16) + 4000000000000000(16);
      clp$convert_integer_to_rjstring (positive_value, 16, FALSE, '0', positive_string, status);
      CASE positive_string (1) OF
      = '0' =
        positive_string (1) := '8';
      = '1' =
        positive_string (1) := '9';
      = '2' =
        positive_string (1) := 'A';
      = '3' =
        positive_string (1) := 'B';
      = '4' =
        positive_string (1) := 'C';
      = '5' =
        positive_string (1) := 'D';
      = '6' =
        positive_string (1) := 'E';
      = '7' =
        positive_string (1) := 'F';
      ELSE
      CASEND;
    ELSE
      clp$convert_integer_to_rjstring (counter, 16, FALSE, '0', positive_string, status);
    IFEND;

{   '   xxxx xxxx xxxx xxxx(16)'

    counter_string (1, 26) := '';
    counter_string (4, 4) := positive_string (1, 4);
    counter_string (9, 4) := positive_string (5, 4);
    counter_string (14, 4) := positive_string (9, 4);
    counter_string (19, 4) := positive_string (13, 4);
    counter_string (23, 4) := '(16)';

  PROCEND convert_integer_to_hex;

?? OLDTITLE ??
?? NEWTITLE := 'convert_output_line_to_excel', EJECT ??

{ PURPOSE:
{   The purpose of this request is to convert a line of output (put_field, put_field_summary or
{ put_interval_field) from text format to EXCEL format.
{
{ DESIGN
{   The procedure copies the input line to a temporary string in case the same string is used as input and
{ output. The procedure copies fields from the original line to output_line based on the report_entry fields
{ position and adds the character TAB (ascii 09) between every field - EXCEL uses the TAB as seperator between
{ columns.

  PROCEDURE convert_output_line_to_excel
    (    report_entry_p: ^put_entry;
         input_line: string ( * <= ptc$max_page_width);
     VAR output_line: string ( * <= ptc$max_page_width);
     VAR output_line_length: integer);

    VAR
      index: integer,
      in_line: string (ptc$max_output_line_length),
      out_index: integer;

    in_line := input_line;
    output_line := '';
    out_index := 0;

    CASE report_entry_p^.put OF

    = put_field_summary =
      out_index := out_index + 1;
      output_line (out_index, report_entry_p^.row_label_column_width) :=
            in_line (report_entry_p^.row_label_start_column, report_entry_p^.row_label_column_width);
      out_index := out_index + report_entry_p^.row_label_column_width;
      output_line (out_index) := $CHAR (ptc$tab);

      FOR index := LOWERBOUND (summary_vector_type) TO UPPERBOUND (summary_vector_type) DO
        IF (report_entry_p^.summary_vector [index].summary <> null) THEN
          out_index := out_index + 1;
          output_line (out_index, report_entry_p^.summary_vector [index].column_width) :=
                in_line (report_entry_p^.summary_vector [index].
                start_column, report_entry_p^.summary_vector [index].column_width);
          out_index := out_index + report_entry_p^.summary_vector [index].column_width;
          output_line (out_index) := $CHAR (ptc$tab);
        IFEND;
      FOREND;

    = put_interval_field, put_field =
      IF (report_entry_p^.put = put_interval_field) AND (report_entry_p^.row_label_type <> row_label_none)
            THEN
        out_index := out_index + 1;
        output_line (out_index, report_entry_p^.date_time_column_width) :=
              in_line (report_entry_p^.date_time_start_column, report_entry_p^.date_time_column_width);
        out_index := out_index + report_entry_p^.date_time_column_width;
        output_line (out_index) := $CHAR (ptc$tab);
      IFEND;

      FOR index := LOWERBOUND (field_vector_type) TO UPPERBOUND (field_vector_type) DO
        IF (report_entry_p^.field_vector [index].summary <> null) THEN
          out_index := out_index + 1;
          output_line (out_index, report_entry_p^.field_vector [index].column_width) :=
                in_line (report_entry_p^.field_vector [index].start_column, report_entry_p^.
                field_vector [index].column_width);
          out_index := out_index + report_entry_p^.field_vector [index].column_width;
          output_line (out_index) := $CHAR (ptc$tab);
        IFEND;
      FOREND;
    ELSE
    CASEND;
    output_line_length := clp$trimmed_string_size (output_line (1, (out_index - 1)));

  PROCEND convert_output_line_to_excel;

?? OLDTITLE ??
?? NEWTITLE := 'interval_to_millisecond', EJECT ??

{ PURPOSE:
{   The purpose of this request is to convert a time_increment from pmt$time_increment record to millisecond
{ as integer.

  FUNCTION interval_to_millisecond
    (    date_time: pmt$time_increment): integer;

    interval_to_millisecond := date_time.year * 32140800000 + { 12 * 31 * 24 * 60 * 60 * 1000 }
          date_time.month * 2678400000 + {      31 * 24 * 60 * 60 * 1000 }
          date_time.day * 86400000 + {           24 * 60 * 60 * 1000 }
          date_time.hour * 3600000 + {                60 * 60 * 1000 }
          date_time.minute * 60000 + {                     60 * 1000 }
          date_time.second * 1000 + {                          1000 }
          date_time.millisecond;
  FUNCEND interval_to_millisecond;

?? OLDTITLE ??
?? NEWTITLE := 'delete_put', EJECT ??

{ PURPOSE:
{   The purpose of this request is to delete put_entry - free all the memory that was allocated to the
{ put_entry.

  PROCEDURE delete_put
    (VAR put_entry_p: ^put_entry);

    CASE put_entry_p^.put OF

    = put_field_summary =
      free_field_list (put_entry_p);

    = put_field =
      free_field_vector (put_entry_p);

    = put_interval_field =
      FREE put_entry_p^.date_time_format_p;
      free_field_vector (put_entry_p);

    = put_string =

{  No need to free pointers in put_string before freeing the put_string record.

    = put_record =
      free_selection_list (put_entry_p^.selection_p);
      IF put_entry_p^.descriptive_text_p <> NIL THEN
        FREE put_entry_p^.descriptive_text_p;
      IFEND;

    ELSE
    CASEND;
    FREE put_entry_p;

  PROCEND delete_put;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] elapsed_time_calculation', EJECT ??

{ PURPOSE
{   The purpose of this request is to set up for elapsed time or elapsed time calculation data collection.
{

  PROCEDURE [INLINE] elapsed_time_calculation
    (    date_time_2: ost$date_time;
         predecessor_p: ^successor;
         statistic_header_p: ^sft$statistic_header,
         counters_p: sft$counters;
         field_p { input, output } : ^field);

    VAR
      date_time_1: ost$date_time,
      elapsed_time: elapsed_time_type,
      field_value: real,
      predecessor_chain_head_p: ^successor;

{ Select the source for date_time_1

    CASE field_p^.field_type OF

    = previous_occurrence_field =
      elapsed_time := previous_occurrence;

    = predecessor_field =
      elapsed_time := predecessor;

    = predecessor_chain_head_field =
      elapsed_time := predecessor_chain_head;

    = value_per_second_field, occurrence_per_second_field =
      elapsed_time := field_p^.elapsed_time;

    CASEND;

{ If the field count is 0, field type is value_per_second_field and the counter is incremental the procedure
{ saves the base value for the counter.

    IF (field_p^.field_summary.count = 0) AND (field_p^.field_type = value_per_second_field) AND
          field_p^.incremental THEN
      IF field_p^.counter_number <= statistic_header_p^.number_of_counters THEN
        field_p^.last_value := counters_p^ [field_p^.counter_number];
        field_p^.field_summary.count := field_p^.field_summary.count + 1;
      IFEND;
      RETURN; {----->
    IFEND;

{ Set date_time_1 value.

    CASE elapsed_time OF
    = previous_occurrence =
      IF field_p^.field_summary.count = 0 THEN
        field_p^.field_summary.count := field_p^.field_summary.count + 1;
        RETURN; {----->
      ELSE
        date_time_1 := field_p^.field_summary.last_date_time;
      IFEND;

    = predecessor =
      IF predecessor_p <> NIL THEN
        date_time_1 := predecessor_p^.date_time;
      ELSE
        RETURN; {----->
      IFEND;

    = predecessor_chain_head =
      IF predecessor_p <> NIL THEN
        predecessor_chain_head_p := predecessor_p;
        WHILE predecessor_chain_head_p^.predecessor_p <> NIL DO
          predecessor_chain_head_p := predecessor_chain_head_p^.predecessor_p;
        WHILEND;
        date_time_1 := predecessor_chain_head_p^.date_time;
      ELSE
        RETURN; {----->
      IFEND;

    CASEND;

{ Call collect procedure.

    CASE field_p^.field_type OF

    = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =
      collect_elapsed_time (date_time_1, date_time_2, field_p);

    = value_per_second_field, occurrence_per_second_field =
      IF field_p^.field_type = value_per_second_field THEN
        IF field_p^.incremental THEN
          field_value := $REAL (counters_p^ [field_p^.counter_number] - field_p^.last_value);
          field_p^.last_value := counters_p^ [field_p^.counter_number];
        ELSE
          field_value := $REAL (counters_p^ [field_p^.counter_number]);
        IFEND;
      ELSE
        field_value := 1.0;
      IFEND;
      collect_elapsed_time_calc (date_time_1, date_time_2, field_value, field_p);

    CASEND;

  PROCEND elapsed_time_calculation;

?? OLDTITLE ??
?? NEWTITLE := 'free_descriptive_selection', EJECT ??

{ PURPOSE:
{   The purpose of this request is to FREE the list of descriptive values, when the descriptive_data is
{ deleted or the statistic selection is changed.

  PROCEDURE free_descriptive_selection
    (    descriptive_subfield_p: ^descriptive_data_subfield);

    VAR
      string_1_p: ^descriptive_data_string,
      string_2_p: ^descriptive_data_string,
      subfield_1_p: ^descriptive_data_subfield,
      subfield_2_p: ^descriptive_data_subfield;

    subfield_1_p := descriptive_subfield_p;
    WHILE subfield_1_p <> NIL DO
      string_1_p := subfield_1_p^.descriptive_data_string_p;
      WHILE string_1_p <> NIL DO
        string_2_p := string_1_p^.descriptive_string_link_p;
        FREE string_1_p;
        string_1_p := string_2_p;
      WHILEND;
      subfield_2_p := subfield_1_p^.descriptive_subfield_link_p;
      FREE subfield_1_p;
      subfield_1_p := subfield_2_p;
    WHILEND;

  PROCEND free_descriptive_selection;

?? OLDTITLE ??
?? NEWTITLE := 'free_field_list', EJECT ??

{ PURPOSE:
{   The purpose of this request is to FREE the list of pointers to fields in put_field_summary entry when the
{ report_entry is deleted or changed.

  PROCEDURE free_field_list
    (    report_entry_p: ^put_entry);

    VAR
      field_list_1_p: ^field_list,
      field_list_2_p: ^field_list,
      report_list_1_p: ^report_list,
      report_list_2_p: ^report_list;

    field_list_1_p := report_entry_p^.fields_p;
    WHILE field_list_1_p <> NIL DO

      report_list_1_p := field_list_1_p^.field_p^.report_list_p;
      WHILE report_list_1_p^.report_p <> report_entry_p DO
        report_list_2_p := report_list_1_p;
        report_list_1_p := report_list_1_p^.link_p;
      WHILEND;
      IF report_list_1_p = field_list_1_p^.field_p^.report_list_p THEN
        field_list_1_p^.field_p^.report_list_p := report_list_1_p^.link_p;
      ELSE
        report_list_2_p^.link_p := report_list_1_p^.link_p;
      IFEND;
      FREE report_list_1_p;

      field_list_2_p := field_list_1_p^.link_p;
      FREE field_list_1_p;
      field_list_1_p := field_list_2_p;
    WHILEND;

  PROCEND free_field_list;

?? OLDTITLE ??
?? NEWTITLE := 'free_field_value', EJECT ??

  PROCEDURE free_field_value
    (    field_p: ^field);

    CASE field_p^.field_type OF

    = counter_field =
      field_p^.counter_value_head_p := NIL;
      field_p^.counter_value_tail_p := NIL;

    = descriptive_data_field =
      field_p^.descriptive_value_head_p := NIL;
      field_p^.descriptive_value_tail_p := NIL;

    = date_time_field =
      field_p^.date_time_value_head_p := NIL;
      field_p^.date_time_value_tail_p := NIL;

    = statistic_code_field =
      field_p^.statistic_code_value_head_p := NIL;
      field_p^.statistic_code_value_tail_p := NIL;

    = system_job_name_field =
      field_p^.system_job_name_value_head_p := NIL;
      field_p^.system_job_name_value_tail_p := NIL;

    = global_task_id_field =
      field_p^.global_task_id_value_head_p := NIL;
      field_p^.global_task_id_value_tail_p := NIL;

    = number_of_counters_field =
      field_p^.number_of_counters_value_head_p := NIL;
      field_p^.number_of_counters_value_tail_p := NIL;

    = descriptive_data_size_field =
      field_p^.dd_size_value_head_p := NIL;
      field_p^.dd_size_value_tail_p := NIL;

    = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =
      field_p^.elapsed_time_value_head_p := NIL;
      field_p^.elapsed_time_value_tail_p := NIL;

    = value_per_second_field, occurrence_per_second_field =
      field_p^.value_per_second_value_head_p := NIL;
      field_p^.value_per_second_value_tail_p := NIL;

    = text_field =

    CASEND;

  PROCEND free_field_value;

?? OLDTITLE ??
?? NEWTITLE := 'free_field_vector', EJECT ??

{ PURPOSE:
{   The purpose of this request is to FREE the vector of pointers to fields in put_field and
{   put_interval_field entries when the report_entry is deleted or changed.

  PROCEDURE free_field_vector
    (    report_entry_p: ^put_entry);

    VAR
      index: integer,
      report_list_1_p: ^report_list,
      report_list_2_p: ^report_list;


    FOR index := LOWERBOUND (field_vector_type) TO UPPERBOUND (field_vector_type) DO
      IF (report_entry_p^.field_vector [index].summary <> null) THEN
        report_list_1_p := report_entry_p^.field_vector [index].field_p^.report_list_p;
        WHILE report_list_1_p^.report_p <> report_entry_p DO
          report_list_2_p := report_list_1_p;
          report_list_1_p := report_list_1_p^.link_p;
        WHILEND;
        IF report_list_1_p = report_entry_p^.field_vector [index].field_p^.report_list_p THEN
          report_entry_p^.field_vector [index].field_p^.report_list_p := report_list_1_p^.link_p;
        ELSE
          report_list_2_p^.link_p := report_list_1_p^.link_p;
        IFEND;
        FREE report_list_1_p;
      IFEND;
    FOREND;

  PROCEND free_field_vector;

?? OLDTITLE ??
?? NEWTITLE := 'free_selection_list', EJECT ??

{ PURPOSE:
{   The purpose of this request is to FREE the list of pointers to selections in put_record entry when the
{ log_entry is deleted or changed.

  PROCEDURE free_selection_list
    (    selection_list_p: ^selection_list);

    VAR
      selection_list_1_p: ^selection_list,
      selection_list_2_p: ^selection_list;

    selection_list_1_p := selection_list_p;
    WHILE selection_list_1_p <> NIL DO
      selection_list_1_p^.selection_p^.log_entry_p := NIL;
      selection_list_2_p := selection_list_1_p^.link_p;
      FREE selection_list_1_p;
      selection_list_1_p := selection_list_2_p;
    WHILEND;

  PROCEND free_selection_list;

?? OLDTITLE ??
?? NEWTITLE := 'get_date_time_format', EJECT ??

{ PURPOSE:
{   The purpose of this request is to let the user control ANABL's output date_time_format by reading the
{ value of an SCL variable the user can set before calling ANABL.
{   That lets the user of Analyze_Binary_Log set the date_time_format for date_time in generate_log (list
{ and legible_data logs) and display_logged_statistic.
{
{ DESIGN
{   The procedure reads the value of the SCL variable ptv$anabl_date_time_format.
{ It checks if the variable is a string type and copies the string to ptv$date_time_format string.
{ If status is not normal (the SCL variable doesn't exist or doesn't fit the working area) the status
{ recovers to normal and Analyze_Binary_Log continues with its default date_time_format.
{
{ NOTE:
{   Example for SCL variable for date_time format:
{     ptv$anabl_date_time_format: string ='ISOD  H24:MM:SS.S1000'

  PROCEDURE get_date_time_format;

    VAR
      access_mode: clt$data_access_mode,
      class: clt$variable_class,
      evaluation_method: clt$expression_eval_method,
      local_status: ost$status,
      type_specification_p: ^clt$type_specification,
      value_p: ^clt$data_value,
      work_area_p: ^SEQ ( * );

    local_status.normal := TRUE;

    PUSH work_area_p: [[REP 500 OF cell]];
    PUSH type_specification_p: [[REP 500 OF cell]];
    clp$get_variable ('ptv$anabl_date_time_format', work_area_p, class, access_mode, evaluation_method,
          type_specification_p, value_p, local_status);
    IF local_status.normal THEN
      IF value_p^.kind = clc$string THEN
        ptv$date_time_format := value_p^.string_value^;
      IFEND;
    IFEND;

  PROCEND get_date_time_format;

?? OLDTITLE ??
?? NEWTITLE := 'get_descriptive_data_subfield', EJECT ??

{ Return the "absolute location" of the descriptive data subfield
{ in the descriptive data field specified by
{  subfield number:  0 implies keyword ALL
{  subfield position
{  subfield length:  0 implies null substring
{ Indicate if
{  The subfield is a null string (='')
{  The substring was found

{ The caller must insure that descriptive_p <> NIL before calling this procedure

  PROCEDURE [INLINE] get_descriptive_data_subfield
    (    descriptive_p: ^sft$descriptive_data;
         descriptive_data_size: integer;
         subfield_position: 0 .. sfc$max_descriptive_data_size;
         subfield_length: 0 .. sfc$max_descriptive_data_size;
         subfield_number: 0 .. sfc$max_descriptive_data_size;
         subfield_delimiter: char;
     VAR null_subfield: boolean;
     VAR substring_found: boolean;
     VAR start: integer;
     VAR length: integer);

    TYPE
      delimiter = set of char;

    VAR
      select: delimiter,
      subfield_start: 1 .. sfc$max_descriptive_data_size,
      scan_start: 1 .. sfc$max_descriptive_data_size,
      scan_length: 1 .. sfc$max_descriptive_data_size,
      delimiter_found: boolean,
      subfield_count: integer;

    IF descriptive_data_size = 0 THEN
      start := 0;
      length := 0;
{ subfield_number = 0 means subfield_number = ALL
      IF subfield_number <= 1 THEN
        null_subfield := TRUE;
        IF subfield_length = 0 THEN
          substring_found := TRUE;
        ELSE
          substring_found := FALSE;
        IFEND;
      ELSE
        substring_found := FALSE;
        null_subfield := FALSE;
      IFEND;
    ELSE { descriptive_data_size > 0
      select := $delimiter [subfield_delimiter];

{ Initialize for case where subfield_number = ALL ( = 0 )
{ This is unnecessary if subfield_number > 0
      subfield_start := 1;
      scan_length := descriptive_data_size + 1;

{ Initialize for all cases
      subfield_count := 0;
      scan_start := 1;

{ Look for specified subfield until end of descriptive data field is found.
{ This loop is not executed even once if subfield_number = ALL
      WHILE (subfield_count < subfield_number) AND (scan_start <= descriptive_data_size) DO
        #SCAN (select, descriptive_p^ (scan_start, * ), scan_length, delimiter_found);
        subfield_count := subfield_count + 1;
        subfield_start := scan_start;
        scan_start := scan_start + scan_length;
      WHILEND;

{ Found the specified subfield
      IF (subfield_count = subfield_number) THEN
{ First character was delimiter, so null subfield
        IF scan_length = 1 THEN
          null_subfield := TRUE;
          start := subfield_start;
          length := 0;
          IF subfield_length = 0 THEN
            substring_found := TRUE;
          ELSE
            substring_found := FALSE;
          IFEND;
{ Subfield long enough for substring to start in it
        ELSEIF (subfield_position < scan_length) THEN
          null_subfield := FALSE;
          substring_found := TRUE;
          start := subfield_start + subfield_position - 1;
          IF subfield_length < scan_length - subfield_position THEN
            length := subfield_length;
          ELSE
            length := scan_length - subfield_position;
          IFEND;
        ELSE
          null_subfield := FALSE;
          substring_found := FALSE;
          start := 0;
          length := 0;
        IFEND;

{ Last character is the subfield delimiter, so the last subfield is null
      ELSEIF (subfield_count = subfield_number - 1) AND (descriptive_p^ (descriptive_data_size,
            1) = subfield_delimiter) THEN
        IF subfield_length = 0 THEN
          substring_found := TRUE;
        ELSE
          substring_found := FALSE;
        IFEND;
        null_subfield := TRUE;
        start := descriptive_data_size;
        length := 0;
      ELSE
{ Didn't find specified subfield
        null_subfield := FALSE;
        substring_found := FALSE;
        start := 0;
        length := 0;
      IFEND;
    IFEND;

  PROCEND get_descriptive_data_subfield;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_statistic_record', EJECT ??

{ PURPOSE:
{  The purpose of this request is to "read" a statistic record from the binary log file.
{
{ DESIGN
{  The procedure returns to the caller 3 pointers:
{    -  pointer to the statistic header.
{    -  pointer to the counters array.
{    -  pointer to the descriptive data string.
{  If the input file access level is segment (non-active binary log) the pointers point directly to the
{  record in the input file.
{   Otherwise if the input file access level is record (active binary log) the statistic record is copied
{  with amp$get_next to a record buffer (ptv$statistic_record_buffer) and the pointers point to to the record
{  buffer.
{  The procedure performs those steps to set the pointers
{    1) Use NEXT to skip the record header (only in segment access).
{    2) Use NEXT to put pointer on statistic header.
{    3) IF ptv$number_of_counters > 0 THEN use NEXT to put pointer on counter array.
{    4) IF descriptive_data_size > 0 THEN use NEXT to put pointer on descriptive_data.
{  The procedure returns:
{    - NIL for the statistic header when file postion at END OF INFORMATION.
{    - NIL for the counters when number of counters is 0.
{    - NIL for the descriptive data when the descriptive data size is 0.

  PROCEDURE [INLINE] get_statistic_record
    (    input_log_p: ^log_file;
     VAR statistic_header_p: ^sft$statistic_header;
     VAR counters_p: sft$counters;
     VAR descriptive_data_p: ^sft$descriptive_data;
     VAR status: ost$status);

    VAR
      file_position: amt$file_position,
      log_header_p: ^bat$record_header,
      record_byte_address: amt$file_byte_address,
      statistic_record_buffer_p: ^sft$statistic_buffer,
      transfer_count: amt$transfer_count;


    status.normal := TRUE;

    statistic_header_p := NIL;
    counters_p := NIL;
    descriptive_data_p := NIL;

    IF input_log_p^.access_level = amc$segment THEN
      NEXT log_header_p IN input_log_p^.segment_pointer.sequence_pointer;
      IF log_header_p <> NIL THEN
        NEXT statistic_header_p IN input_log_p^.segment_pointer.sequence_pointer;
        IF statistic_header_p = NIL THEN
          osp$set_status_condition (pte$unexpected_end_of_file, status);
          osp$append_status_file (osc$status_parameter_delimiter, input_log_p^.log_file_name, status);
          RETURN; {----->
        IFEND;

        IF statistic_header_p^.number_of_counters > 0 THEN
          NEXT counters_p: [1 .. statistic_header_p^.number_of_counters] IN
                input_log_p^.segment_pointer.sequence_pointer;
          IF counters_p = NIL THEN
            osp$set_status_condition (pte$unexpected_end_of_file, status);
            osp$append_status_file (osc$status_parameter_delimiter, input_log_p^.log_file_name, status);
            RETURN; {----->
          IFEND;
        IFEND;

        IF statistic_header_p^.descriptive_data_size > 0 THEN
          NEXT descriptive_data_p: [statistic_header_p^.descriptive_data_size] IN
                input_log_p^.segment_pointer.sequence_pointer;
          IF descriptive_data_p = NIL THEN
            osp$set_status_condition (pte$unexpected_end_of_file, status);
            osp$append_status_file (osc$status_parameter_delimiter, input_log_p^.log_file_name, status);
            RETURN; {----->
          IFEND;
        IFEND;
      IFEND;
    ELSE
      statistic_record_buffer_p := ^ptv$statistic_record_buffer;
      amp$get_next (input_log_p^.file_identifier, statistic_record_buffer_p,
            #SIZE (ptv$statistic_record_buffer), transfer_count, record_byte_address, file_position, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

      IF file_position <> amc$eoi THEN
        RESET statistic_record_buffer_p;
        NEXT statistic_header_p IN statistic_record_buffer_p;
        IF statistic_header_p^.number_of_counters > 0 THEN
          NEXT counters_p: [1 .. statistic_header_p^.number_of_counters] IN statistic_record_buffer_p;
        IFEND;
        IF statistic_header_p^.descriptive_data_size > 0 THEN
          NEXT descriptive_data_p: [statistic_header_p^.descriptive_data_size] IN statistic_record_buffer_p;
        IFEND;
      IFEND;

    IFEND;

  PROCEND get_statistic_record;

?? OLDTITLE ??
?? NEWTITLE := 'get_time_increment_format', EJECT ??

{ PURPOSE:
{   The purpose of this request is to get the time increment format from an SCL variable.  This lets the
{ user of Analyze_Binary_Log set the time increment format for interval and elapsed_time_since_predecessor
{ (put_field, put_field_summary and put_interval_field reports).
{
{ DESIGN
{   The procedure gets the value of the SCL variable ptv$anabl_time_increment_format.  It checks if the
{ variable is a keyword type and copies the string to ptv$time_increment_format string.
{ If the status is not normal (the SCL variable doesn't exist or doesn't fit the working area), the status
{ recovers to normal and Analyze_Binary_Log continues with its default time_increment_format.
{
{ NOTE:
{   Example for SCL variable for time increment format:
{     ptv$anabl_time_increment_format: key (time_increment ti) (seconds second s) keyend = ti

  PROCEDURE get_time_increment_format
    (VAR status: ost$status);

    VAR
      access_mode: clt$data_access_mode,
      class: clt$variable_class,
      evaluation_method: clt$expression_eval_method,
      local_status: ost$status,
      type_specification_p: ^clt$type_specification,
      value_p: ^clt$data_value,
      work_area_p: ^SEQ ( * );

{ ptv$time_increment_format can get the keyword value TIME_INCREMENT or SECONDS

    local_status.normal := TRUE;

    PUSH work_area_p: [[REP 500 OF cell]];
    PUSH type_specification_p: [[REP 500 OF cell]];
    clp$get_variable ('ptv$anabl_time_increment_format', work_area_p, class, access_mode, evaluation_method,
          type_specification_p, value_p, local_status);
    IF local_status.normal THEN
      IF value_p^.kind = clc$keyword THEN
        ptv$time_increment_format := value_p^.keyword_value;
      IFEND;
    IFEND;

  PROCEND get_time_increment_format;

?? OLDTITLE ??
?? NEWTITLE := 'initialize_field_values', EJECT ??

{ PURPOSE:
{   The purpose of this request is to initialize the statistics and the fields for collecting data for
{ Generate_Report before scanning the input log(s).

  PROCEDURE initialize_field_values
    (    field_p: ^field);

    field_p^.field_summary := ptv$initial_field_summary;

    IF (field_p^.field_type = value_per_second_field) OR (field_p^.field_type = occurrence_per_second_field)
          THEN
      field_p^.value_per_second_sum := 0.0;
      field_p^.value_per_second_minimum := ptc$max_real;
      field_p^.value_per_second_maximum := 0.0;
    IFEND;

    IF field_p^.collect_all_occurrences THEN
      CASE field_p^.field_type OF

      = counter_field =
        NEXT field_p^.counter_value_head_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.counter_value_tail_p := field_p^.counter_value_head_p;
        field_p^.counter_value_head_p^.link_p := NIL;
        IF field_p^.incremental THEN
{  Start with the second value in the value array to keep in sync with
{    non-incremental counters
          field_p^.counter_value_head_p^.index := 1;
        ELSE
          field_p^.counter_value_head_p^.index := 0;
        IFEND;

      = descriptive_data_field =
        NEXT field_p^.descriptive_value_head_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.descriptive_value_tail_p := field_p^.descriptive_value_head_p;
        field_p^.descriptive_value_head_p^.link_p := NIL;
        field_p^.descriptive_value_head_p^.index := 0;
        field_p^.first_descriptive_value_p := NIL;
        field_p^.last_descriptive_value_p := NIL;

      = date_time_field =
        NEXT field_p^.date_time_value_head_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.date_time_value_tail_p := field_p^.date_time_value_head_p;
        field_p^.date_time_value_head_p^.link_p := NIL;
        field_p^.date_time_value_head_p^.index := 0;

      = statistic_code_field =
        NEXT field_p^.statistic_code_value_head_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.statistic_code_value_tail_p := field_p^.statistic_code_value_head_p;
        field_p^.statistic_code_value_head_p^.link_p := NIL;
        field_p^.statistic_code_value_head_p^.index := 0;

      = system_job_name_field =
        NEXT field_p^.system_job_name_value_head_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.system_job_name_value_tail_p := field_p^.system_job_name_value_head_p;
        field_p^.system_job_name_value_head_p^.link_p := NIL;
        field_p^.system_job_name_value_head_p^.index := 0;

      = global_task_id_field =
        NEXT field_p^.global_task_id_value_head_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.global_task_id_value_tail_p := field_p^.global_task_id_value_head_p;
        field_p^.global_task_id_value_head_p^.link_p := NIL;
        field_p^.global_task_id_value_head_p^.index := 0;

      = number_of_counters_field =
        NEXT field_p^.number_of_counters_value_head_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.number_of_counters_value_tail_p := field_p^.number_of_counters_value_head_p;
        field_p^.number_of_counters_value_head_p^.link_p := NIL;
        field_p^.number_of_counters_value_head_p^.index := 0;

      = descriptive_data_size_field =
        NEXT field_p^.dd_size_value_head_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.dd_size_value_tail_p := field_p^.dd_size_value_head_p;
        field_p^.dd_size_value_head_p^.link_p := NIL;
        field_p^.dd_size_value_head_p^.index := 0;

      = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =
        NEXT field_p^.elapsed_time_value_head_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.elapsed_time_value_tail_p := field_p^.elapsed_time_value_head_p;
        field_p^.elapsed_time_value_head_p^.link_p := NIL;
        IF field_p^.field_type = previous_occurrence_field THEN
{  Start with the second value in the value array to keep in sync with
{    non-incremental counters
          field_p^.elapsed_time_value_head_p^.index := 1;
        ELSE
          field_p^.elapsed_time_value_head_p^.index := 0;
        IFEND;

      = value_per_second_field, occurrence_per_second_field =
        NEXT field_p^.value_per_second_value_head_p IN ptv$data_segment_p.sequence_pointer;
        field_p^.value_per_second_value_tail_p := field_p^.value_per_second_value_head_p;
        field_p^.value_per_second_value_head_p^.link_p := NIL;
        IF field_p^.incremental OR (field_p^.elapsed_time = previous_occurrence) THEN
{  Start with the second value in the value array to keep in sync with
{    non-incremental counters
          field_p^.value_per_second_value_head_p^.index := 1;
        ELSE
          field_p^.value_per_second_value_head_p^.index := 0;
        IFEND;

      = text_field =

      ELSE
      CASEND;

    IFEND;

  PROCEND initialize_field_values;

?? OLDTITLE ??
?? NEWTITLE := 'initialize_selection_values', EJECT ??

{ PURPOSE:
{   The purpose of this request is to initialize the statistics and the fields for collecting data for
{ Generate_Report before scanning the input log(s).
{
{ DESIGN
{   The procedure allocates and initializes storage space for interval reports (date_time and
{ predecessor_date_time for selection counter_value or descriptive_value for fields) and initializes
{ counter_variable for summary reports.

  PROCEDURE initialize_selection_values;

    VAR
      field_p: ^field,
      selection_p: ^selection;

    selection_p := ptv$selection_chain_head_p;
    WHILE selection_p <> NIL DO

      IF selection_p^.collect_date_time THEN
        NEXT selection_p^.date_time_value_head_p IN ptv$data_segment_p.sequence_pointer;
        selection_p^.date_time_value_tail_p := selection_p^.date_time_value_head_p;
        selection_p^.date_time_value_head_p^.link_p := NIL;
        selection_p^.date_time_value_head_p^.index := 0;
      IFEND;

      IF selection_p^.collect_predecessor_date_time THEN
        NEXT selection_p^.predecessor_dt_value_head_p IN ptv$data_segment_p.sequence_pointer;
        selection_p^.predecessor_dt_value_tail_p := selection_p^.predecessor_dt_value_head_p;
        selection_p^.predecessor_dt_value_head_p^.link_p := NIL;
        selection_p^.predecessor_dt_value_head_p^.index := 0;
      IFEND;

      field_p := selection_p^.field_chain_p;
      WHILE field_p <> NIL DO
        initialize_field_values (field_p);
        field_p := field_p^.field_chain_link_p;
      WHILEND;

      field_p := selection_p^.shadow_field_chain_p;
      WHILE field_p <> NIL DO
        initialize_field_values (field_p);
        field_p := field_p^.field_chain_link_p;
      WHILEND;

      selection_p := selection_p^.selection_chain_link_p;
    WHILEND;

  PROCEND initialize_selection_values;

?? OLDTITLE ??
?? NEWTITLE := 'initialize_write_field_ao', EJECT ??

{ PURPOSE:
{   The purpose of this request is to initialize the fields for an all_occurrences field report.
{
{
{ DESIGN:
{   For every non null summary in the field_vector the procedure initializes the report field.
{   The procedure checks that there are values collected for that field. If the check fails, the procedure
{ returns.  Otherwise the procedure adds 1 to number_of_active_fields and adds the field index to the
{ active_fields set.
{
{ The procedures sets:
{   - Value_index to 0.
{   - Pointer to the first counter value.
{
{ If the counter is incremental, then incremental flag is set to true.

  PROCEDURE initialize_write_field_ao
    (    report_entry_p: ^put_entry;
     VAR active_fields: active_fields_set;
     VAR field_value_p: field_value_type;
     VAR last_non_null_field: integer;
     VAR number_of_active_fields: integer;
     VAR status: ost$status);

    VAR
      field_p: ^field,
      index: integer;

    status.normal := TRUE;

{ Initialize print all_occurrences process

    number_of_active_fields := 0;
    active_fields := $active_fields_set [];

    index := LOWERBOUND (field_vector_type);
    WHILE (index <= UPPERBOUND (field_vector_type)) AND (report_entry_p^.field_vector [index].
          summary <> null) DO
      IF report_entry_p^.field_vector [index].field_p^.field_type <> text_field THEN

{  Can skip text fields because they are printed in the report until no other fields are active.
{  Initialize field

      /initialize_field_ao/
        BEGIN
          IF report_entry_p^.field_vector [index].shadow_field THEN
            field_p := report_entry_p^.field_vector [index].shadow_field_p;
          ELSE
            field_p := report_entry_p^.field_vector [index].field_p;
          IFEND;

          field_value_p [index].value_index := 0;
          field_value_p [index].first := FALSE;

          CASE field_p^.field_type OF

          = counter_field =
            IF field_p^.incremental THEN

{  If incremental, start with second value in value array.  This is where
{    initialize_fields started storing values.

              field_value_p [index].value_index := 1;
              field_value_p [index].first := TRUE;
            IFEND;
            IF field_p^.counter_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].counter_value_p := field_p^.counter_value_head_p;
            ELSE
              EXIT /initialize_field_ao/;
            IFEND;

          = descriptive_data_field =
            IF field_p^.descriptive_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].descriptive_value_p := field_p^.descriptive_value_head_p;
            ELSE
              EXIT /initialize_field_ao/;
            IFEND;

          = date_time_field =
            IF field_p^.date_time_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].date_time_p := field_p^.date_time_value_head_p;
            ELSE
              EXIT /initialize_field_ao/;
            IFEND;

          = statistic_code_field =
            IF field_p^.statistic_code_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].statistic_code_value_p := field_p^.statistic_code_value_head_p;
            ELSE
              EXIT /initialize_field_ao/;
            IFEND;

          = system_job_name_field =
            IF field_p^.system_job_name_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].system_job_name_value_p := field_p^.system_job_name_value_head_p;
            ELSE
              EXIT /initialize_field_ao/;
            IFEND;

          = global_task_id_field =
            IF field_p^.global_task_id_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].global_task_id_value_p := field_p^.global_task_id_value_head_p;
            ELSE
              EXIT /initialize_field_ao/;
            IFEND;

          = number_of_counters_field =
            IF field_p^.number_of_counters_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].number_of_counters_value_p := field_p^.number_of_counters_value_head_p;
            ELSE
              EXIT /initialize_field_ao/;
            IFEND;

          = descriptive_data_size_field =
            IF field_p^.dd_size_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].dd_size_value_p := field_p^.dd_size_value_head_p;
            ELSE
              EXIT /initialize_field_ao/;
            IFEND;

          = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =
            IF field_p^.field_type = previous_occurrence_field THEN

{  If incremental, start with second value in value array.  This is where
{    initialize_fields started storing values.

              field_value_p [index].value_index := 1;
              field_value_p [index].first := TRUE;
            IFEND;
            IF field_p^.elapsed_time_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].elapsed_time_value_p := field_p^.elapsed_time_value_head_p;
            ELSE
              EXIT /initialize_field_ao/;
            IFEND;

          = value_per_second_field, occurrence_per_second_field =
            IF field_p^.incremental OR (field_p^.elapsed_time = previous_occurrence) THEN

{  If incremental, start with second value in value array.  This is where
{    initialize_fields started storing values.

              field_value_p [index].value_index := 1;
              field_value_p [index].first := TRUE;
            IFEND;
            IF field_p^.value_per_second_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].value_per_second_value_p := field_p^.value_per_second_value_head_p;
            ELSE
              EXIT /initialize_field_ao/;
            IFEND;

          = text_field =
{  Should not get here since outer IF excludes text_field

          CASEND;

          active_fields := active_fields + $active_fields_set [index];
          number_of_active_fields := number_of_active_fields + 1;

        END /initialize_field_ao/;
      IFEND;

      index := index + 1;
    WHILEND;

    last_non_null_field := index - 1;

  PROCEND initialize_write_field_ao;

?? OLDTITLE ??
?? NEWTITLE := 'initialize_write_interval', EJECT ??

{ PURPOSE:
{   The purpose of this request is to initialize an interval field report.
{
{ DESIGN:
{   The procedure sets begin date_time to ptv$min_date_time (1900-01-01 00:00:00.000).  For every non null
{ summary in the field_vector the procedure initializes the report field.
{ If the report row_label_type is start_time, end_time or time_range then the procedure converts
{ begin_date_time to string.
{   The procedure checks that there are values collected for that counter.  If the report field summary is
{ elapsed_time_since_predecessor then the procedure checks to see that predecessor date_time was collected.
{ If one of the checks fails the procedure returns.  Otherwise the procedure adds 1 to number_of_active_fields
{ and the field index to the active_fields set.
{ The procedures sets:
{   - Value_index to 0.
{   - Pointer to the first counter value.
{   - Pointer to date_time.
{   - Pointer to skip_date_time.
{   - Lost_interval to 0,
{   - First_date_time value.
{   - First flag to true.
{
{ NOTE:
{ - Begin_date_time for fields is the minimum date_time from the first value of all the fields in
{   the report.

  PROCEDURE initialize_write_interval
    (    report_entry_p: ^put_entry;
     VAR active_fields: active_fields_set;
     VAR begin_date_time: ost$date_time;
     VAR field_value_p: field_value_type;
     VAR last_non_null_field: integer;
     VAR number_of_active_fields: integer;
     VAR status: ost$status);

    VAR
      field_p: ^field,
      index: integer;

    status.normal := TRUE;

{ Initialize print interval process

    begin_date_time := ptv$max_date_time;
    number_of_active_fields := 0;
    active_fields := $active_fields_set [];

    index := LOWERBOUND (field_vector_type);
    WHILE (index <= UPPERBOUND (field_vector_type)) AND (report_entry_p^.field_vector [index].
          summary <> null) DO
      IF report_entry_p^.field_vector [index].field_p^.field_type <> text_field THEN

      /initialize_interval_field/
        BEGIN
          IF report_entry_p^.field_vector [index].shadow_field THEN
            field_p := report_entry_p^.field_vector [index].shadow_field_p;
          ELSE
            field_p := report_entry_p^.field_vector [index].field_p;
          IFEND;

          field_value_p [index].value_index := 0;

          CASE field_p^.field_type OF

          = counter_field =
            IF field_p^.incremental THEN

{  If incremental, start with second value in value array.  This is where
{    initialize_fields started storing values.

              field_value_p [index].value_index := 1;
              field_value_p [index].first := TRUE;
            IFEND;
            IF field_p^.counter_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].counter_value_p := field_p^.counter_value_head_p;
            ELSE
              EXIT /initialize_interval_field/;
            IFEND;

          = descriptive_data_field =
            IF field_p^.descriptive_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].descriptive_value_p := field_p^.descriptive_value_head_p;
            ELSE
              EXIT /initialize_interval_field/;
            IFEND;

          = date_time_field =
            IF field_p^.date_time_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].date_time_p := field_p^.date_time_value_head_p;
            ELSE
              EXIT /initialize_interval_field/;
            IFEND;

          = statistic_code_field =
            IF field_p^.statistic_code_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].statistic_code_value_p := field_p^.statistic_code_value_head_p;
            ELSE
              EXIT /initialize_interval_field/;
            IFEND;

          = system_job_name_field =
            IF field_p^.system_job_name_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].system_job_name_value_p := field_p^.system_job_name_value_head_p;
            ELSE
              EXIT /initialize_interval_field/;
            IFEND;

          = global_task_id_field =
            IF field_p^.global_task_id_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].global_task_id_value_p := field_p^.global_task_id_value_head_p;
            ELSE
              EXIT /initialize_interval_field/;
            IFEND;

          = number_of_counters_field =
            IF field_p^.number_of_counters_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].number_of_counters_value_p := field_p^.number_of_counters_value_head_p;
            ELSE
              EXIT /initialize_interval_field/;
            IFEND;

          = descriptive_data_size_field =
            IF field_p^.dd_size_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].dd_size_value_p := field_p^.dd_size_value_head_p;
            ELSE
              EXIT /initialize_interval_field/;
            IFEND;

          = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =
            IF field_p^.field_type = previous_occurrence_field THEN

{  If incremental, start with second value in value array.  This is where
{    initialize_fields started storing values.

              field_value_p [index].value_index := 1;
              field_value_p [index].first := TRUE;
            IFEND;
            IF field_p^.elapsed_time_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].elapsed_time_value_p := field_p^.elapsed_time_value_head_p;
            ELSE
              EXIT /initialize_interval_field/;
            IFEND;

          = value_per_second_field, occurrence_per_second_field =
            IF field_p^.incremental OR (field_p^.elapsed_time = previous_occurrence) THEN

{  If incremental, start with second value in value array.  This is where
{    initialize_fields started storing values.

              field_value_p [index].value_index := 1;
              field_value_p [index].first := TRUE;
            IFEND;
            IF field_p^.value_per_second_value_head_p^.index > field_value_p [index].value_index THEN
              field_value_p [index].value_per_second_value_p := field_p^.value_per_second_value_head_p;
            ELSE
              EXIT /initialize_interval_field/;
            IFEND;

          = text_field =
{  Should not get here since outer IF excludes text_field

          CASEND;

          field_value_p [index].date_time_p := field_p^.selection_p^.date_time_value_head_p;
          field_value_p [index].skip_date_time_p := field_p^.selection_p^.skip_date_time_head_p;
          field_value_p [index].lost_interval := 0;

          IF report_entry_p^.field_vector [index].summary = elapsed_time_since_predecessor THEN
            IF field_p^.selection_p^.collect_predecessor_date_time THEN
              field_value_p [index].predecessor_date_time_p :=
                    field_p^.selection_p^.predecessor_dt_value_head_p;
            ELSE
              EXIT /initialize_interval_field/;
            IFEND;
          IFEND;

          field_value_p [index].first_date_time := field_value_p [index].
                date_time_p^.value_array [field_value_p [index].value_index + 1];
          field_value_p [index].first := TRUE;

          IF date_time_1_gt_date_time_2 (begin_date_time, field_value_p [index].
                 date_time_p^.value_array[field_value_p [index].value_index + 1]) THEN
            begin_date_time := field_value_p[index].date_time_p^.
                    value_array[field_value_p [index].value_index + 1];
          IFEND;

          active_fields := active_fields + $active_fields_set [index];
          number_of_active_fields := number_of_active_fields + 1;

        END /initialize_interval_field/;

      IFEND;
      index := index + 1;
    WHILEND;

    last_non_null_field := index - 1;

  PROCEND initialize_write_interval;

?? OLDTITLE ??
?? NEWTITLE := 'open_log_file', EJECT ??

{ PURPOSE:
{   The purpose of this request is to open input or output log files for the generate_log, generate_report and
{ display_logged_statistics commands.
{
{ DESIGN
{   If read mode is selected, the logging interfaces will be used to read the log.

  PROCEDURE open_log_file
    (VAR log_p: ^log_file;
         write_mode: boolean;
     VAR status: ost$status);

    VAR

{ The read access mode for output file is temporary until PSR NV0Q772 is answered.  Until then,
{   the open_file needs read access in order to open the file at EOI and get the previous header
{   file byte address.

      write_attachment_option: [STATIC, READ] array [1 .. 7] of fst$attachment_option := [
            {} [fsc$access_and_share_modes, [fsc$specific_access_modes,
            [fsc$read, fsc$shorten, fsc$append, fsc$modify]], [fsc$determine_from_access_modes]],
            {} [fsc$create_file, TRUE],
            {} [fsc$open_share_modes, []],
            {} [fsc$delete_data, TRUE],
            {} [fsc$error_exit_procedure, NIL],
            {} [fsc$free_behind, TRUE],
            {} [fsc$sequential_access, TRUE]];

    status.normal := TRUE;

    IF write_mode THEN
      fsp$open_file (log_p^.log_file_name, amc$segment, {attachment options=} ^write_attachment_option,
            {default creation attributes=} ^ptv$log_file_attributes,
            {mandated creation attributes=} ^ptv$log_file_attributes,
            {attribute validation=} ^ptv$log_file_attributes, {attribute override=} NIL,
            log_p^.file_identifier, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      log_p^.access_level := amc$segment;
      log_p^.active_log := FALSE;
      log_p^.log_file_identifier := osc$null_name;
    ELSE
      lgp$open_log_file (log_p^.log_file_name, log_p^.active_log, log_p^.log_file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      log_p^.access_level := amc$record;
    IFEND;

    IF log_p^.access_level = amc$segment THEN
      amp$get_segment_pointer (log_p^.file_identifier, amc$sequence_pointer, log_p^.segment_pointer, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    IFEND;

  PROCEND open_log_file;

?? OLDTITLE ??
?? NEWTITLE := 'open_report_file', EJECT ??

{ PURPOSE:
{   The purpose of this request is to open a text file for output from generate_report or generate_log.

  PROCEDURE open_report_file
    (   file_name: fst$file_reference;
        display_format: display_format_type;
    VAR file_id: cyt$file;
    VAR page_width: 0..ptc$max_page_width;
    VAR status: ost$status);

    VAR
      file_specifications: cyt$file_specifications,
      width_adjustment: 0..1;

    IF display_format = legible_data THEN

      PUSH file_specifications: [1 .. 2];
      file_specifications^ [1].selector := cyc$file_kind;
      file_specifications^ [1].file_kind := cyc$text_file;
      file_specifications^ [2].selector := cyc$page_width;
      file_specifications^ [2].page_width := ptv$legible_data_max_page_width;

      width_adjustment := 0;
    ELSE

      PUSH file_specifications: [1 .. 3];
      file_specifications^ [1].selector := cyc$file_kind;
      file_specifications^ [1].file_kind := cyc$display_file;
      file_specifications^ [2].selector := cyc$new_page_procedure;
      file_specifications^ [2].new_page_procedure.kind := cyc$user_specified_procedure;
      file_specifications^ [2].new_page_procedure.user_procedure := ^anabl_new_page_procedure;
      file_specifications^ [3].selector := cyc$page_width;
      file_specifications^ [3].page_width := ptv$list_max_page_width;

      width_adjustment := 1;
    IFEND;

    cyp$open_file (file_name, file_specifications, file_id, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    page_width := cyp$page_width (file_id) - width_adjustment;

  PROCEND open_report_file;

?? OLDTITLE ??
?? NEWTITLE := 'print_report', EJECT ??

{ PURPOSE:
{   The purpose of this request is to print the report for the generate_report subcommand.

  PROCEDURE print_report
    (VAR status: ost$status);

    VAR
      field_list_p: ^field_list,
      pop_count: integer,
      report_entry_p: ^put_entry;

    status.normal := TRUE;

    report_entry_p := ptv$report_entry_chain_head_p;
    WHILE report_entry_p <> NIL DO
      CASE report_entry_p^.put OF

      = put_field_summary =
        IF report_entry_p^.display_headers THEN
          IF report_entry_p^.header_1 <> ' ' THEN
            ptv$output_line_length := clp$trimmed_string_size (report_entry_p^.header_1);
            cyp$put_next_line (ptv$output_file, report_entry_p^.header_1 (1, ptv$output_line_length), status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;
          ptv$output_line_length := clp$trimmed_string_size (report_entry_p^.header_2);
          cyp$put_next_line (ptv$output_file, report_entry_p^.header_2 (1, ptv$output_line_length), status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;

        field_list_p := report_entry_p^.fields_p;
        WHILE field_list_p <> NIL DO
          IF field_list_p^.row_label = ' ' THEN
            write_counter_summary (field_list_p^.field_p, field_list_p^.field_p^.field_name, report_entry_p,
                  status);
          ELSE
            write_counter_summary (field_list_p^.field_p, field_list_p^.row_label, report_entry_p, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          field_list_p := field_list_p^.link_p;
        WHILEND;

      = put_interval_field =
        write_interval_report (report_entry_p, status);

      = put_field =
        IF report_entry_p^.all_occurrences THEN
          write_field_ao_report (report_entry_p, status);
        ELSE
          write_field_report (report_entry_p, status);
        IFEND;

      = put_string =
        ptv$output_line_length := clp$trimmed_string_size (report_entry_p^.header_1);
        cyp$put_next_line (ptv$output_file, report_entry_p^.header_1 (1, ptv$output_line_length), status);

      = put_new_page =
        IF report_entry_p^.use_page_headers THEN
          cyp$start_new_display_page (ptv$output_file, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

        ELSE
          cyp$display_page_eject (ptv$output_file, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;

      = push_page_header =

        IF ptv$page_header_list_tail_p <> NIL THEN {At least one entry in list

{ Reuse page_header_list entries, if available.
{ If not, then get a new one.

          IF ptv$page_header_list_tail_p^.fwd_p = NIL THEN
            NEXT ptv$page_header_list_tail_p^.fwd_p IN ptv$data_segment_p.sequence_pointer;
            ptv$page_header_list_tail_p^.fwd_p^.fwd_p := NIL;
            ptv$page_header_list_tail_p^.fwd_p^.bkw_p := ptv$page_header_list_tail_p;
          IFEND;
          ptv$page_header_list_tail_p := ptv$page_header_list_tail_p^.fwd_p;
        ELSE {No entries in page header list
       { Know head pointer <> NIL since report initialized with default header in list
          ptv$page_header_list_tail_p := ptv$page_header_list_head_p;
        IFEND;
        IF report_entry_p^.default_header THEN
          ptv$page_header_list_tail_p^.default_header := TRUE;
          ptv$page_header_list_tail_p^.header_string := '';
        ELSE
          ptv$page_header_list_tail_p^.default_header := FALSE;
          ptv$page_header_list_tail_p^.header_string := report_entry_p^.header_1;
        IFEND;

      = pop_page_header =

        IF report_entry_p^.pop_all_headers THEN
          ptv$page_header_list_tail_p := NIL;

        ELSE
          pop_count := 0;
          WHILE (ptv$page_header_list_tail_p <> NIL) AND (pop_count < report_entry_p^.pop_count) DO
            IF ptv$page_header_list_tail_p^.bkw_p = NIL THEN {Only one entry in list
              ptv$page_header_list_tail_p := NIL;
            ELSE {More than one entry in page header list
{ Pop off one page header list entry
              ptv$page_header_list_tail_p := ptv$page_header_list_tail_p^.bkw_p;
            IFEND;
            pop_count := pop_count + 1;
          WHILEND;
        IFEND;

      ELSE
      CASEND;
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      report_entry_p := report_entry_p^.put_chain_link_p;
    WHILEND;

  PROCEND print_report;

?? OLDTITLE ??
?? NEWTITLE := 'process_descriptive_selection', EJECT ??

{ PURPOSE:
{   The purpose of this request is to process the descriptive data parameter for add_selection and
{ change_selection subcommands.
{
{ DESIGN
{   The procedure receives a list of subfield descriptions and builds a list of pointers to descriptive_data
{ subfield records.  The procedure allocates a record for the descriptive subfields and calls process_subfield
{ to fill the subfield record with the subfield description (list of strings to match, position,
{ length, field number and field delimiter).
{
{ NOTE:
{   The procedure initializes the subfield records with the default values:
{     - subfield_position    1
{     - subfield_length      ALL (sfc$max_descriptive_data_size)
{     - subfield_number      ALL (0)
{     - subfield_delimiter   ','

  PROCEDURE process_descriptive_selection
    (    value: ^clt$data_value;
         selection_p: { output } ^selection);

    VAR
      initial_descriptive_subfield: [STATIC, READ] descriptive_data_subfield := [NIL
            { descriptive_data_string_p } , 1 { subfield_position } , sfc$max_descriptive_data_size
            { subfield_length } , 0 { subfield_number } , ',' { subfield_delimiter } , NIL
            { descriptive_subfield_link_p } ],
      subfield_p: ^descriptive_data_subfield,
      subfield_value: ^clt$data_value;


{ Get the list of subfield records.

    subfield_value := value;
    ALLOCATE selection_p^.descriptive_subfield_p;
    subfield_p := selection_p^.descriptive_subfield_p;
    subfield_p^ := initial_descriptive_subfield;
    process_subfield (subfield_value, subfield_p);
    subfield_value := subfield_value^.link;
    WHILE subfield_value <> NIL DO
      ALLOCATE subfield_p^.descriptive_subfield_link_p;
      subfield_p := subfield_p^.descriptive_subfield_link_p;
      subfield_p^ := initial_descriptive_subfield;
      process_subfield (subfield_value, subfield_p);
      subfield_value := subfield_value^.link;
    WHILEND;

  PROCEND process_descriptive_selection;

?? OLDTITLE ??
?? NEWTITLE := 'process_field_parameter_putfs', EJECT ??

{ PURPOSE:
{     The purpose of this request is to build a list of pointers to fields for put_field_summary & change_put
{   commands.
{
{ DESIGN
{   This procedure builds a list of pointers from the summary report entry to counters.  For each field name
{ in the field parameter the procedure allocates a pointer, sets the pointer to the counter with a name from
{ the field parameter, allocates a pointer in the counter report list and sets that pointer to the summary
{ report entry.
{
{ NOTE:
{   This procedure is looking only for fields of counter type.

  PROCEDURE process_field_parameter_putfs
    (    value: ^clt$data_value;
         report_entry_p: ^put_entry);

    VAR
      field_p: ^field,
      field_list_p: ^field_list,
      report_list_p: ^report_list,
      selection_p: ^selection,
      value_p: ^clt$data_value;

    value_p := value;
    WHILE value_p <> NIL DO
      IF report_entry_p^.fields_p = NIL THEN
        ALLOCATE report_entry_p^.fields_p;
        field_list_p := report_entry_p^.fields_p;
      ELSE
        ALLOCATE field_list_p^.link_p;
        field_list_p := field_list_p^.link_p;
      IFEND;
      field_p := NIL;
      selection_p := ptv$selection_chain_head_p;
      WHILE (selection_p <> NIL) AND (field_p = NIL) DO
        field_p := selection_p^.field_chain_p;
        WHILE (field_p <> NIL) AND (field_p^.field_name <> value_p^.element_value^.field_values^ [1].value^.
              name_value) DO
          field_p := field_p^.field_chain_link_p;
        WHILEND;
        selection_p := selection_p^.selection_chain_link_p;
      WHILEND;

      IF field_p^.report_list_p = NIL THEN
        ALLOCATE field_p^.report_list_p;
        report_list_p := field_p^.report_list_p;
      ELSE
        report_list_p := field_p^.report_list_p;
        WHILE report_list_p^.link_p <> NIL DO
          report_list_p := report_list_p^.link_p;
        WHILEND;
        ALLOCATE report_list_p^.link_p;
        report_list_p := report_list_p^.link_p;
      IFEND;
      report_list_p^.report_p := report_entry_p;
      report_list_p^.link_p := NIL;

      field_list_p^.field_p := field_p;

      IF value_p^.element_value^.field_values^ [2].value <> NIL THEN
        field_list_p^.row_label := value_p^.element_value^.field_values^ [2].value^.string_value^;
      ELSE
        field_list_p^.row_label := value_p^.element_value^.field_values^ [1].value^.name_value;
      IFEND;

      value_p := value_p^.link;
    WHILEND;
    field_list_p^.link_p := NIL;

  PROCEND process_field_parameter_putfs;

?? OLDTITLE ??
?? NEWTITLE := 'process_field_parameter_putif', EJECT ??

{ PURPOSE:
{   The purpose of this request is to set the pointers from interval field and field report entries to the
{ fields for put_field, put_interval_field and change_put subcommands.
{
{ DESIGN
{   This procedure sets pointers from the report entry field vector to the field.  The field name and type
{ (counter or descriptive_data) are in the report entry field vector.  The procedure allocates a pointer in
{ the field report list and sets that pointer to the report entry.

  PROCEDURE process_field_parameter_putif
    (    report_entry_p: ^put_entry);

    VAR
      index: integer,
      field_p: ^field,
      report_list_p: ^report_list;


    FOR index := LOWERBOUND (field_vector_type) TO UPPERBOUND (field_vector_type) DO
      IF report_entry_p^.field_vector [index].summary <> null THEN
        field_p := report_entry_p^.field_vector [index].field_p;
        IF field_p^.report_list_p = NIL THEN
          ALLOCATE field_p^.report_list_p;
          report_list_p := field_p^.report_list_p;
        ELSE
          report_list_p := field_p^.report_list_p;
          WHILE report_list_p^.link_p <> NIL DO
            report_list_p := report_list_p^.link_p;
          WHILEND;
          ALLOCATE report_list_p^.link_p;
          report_list_p := report_list_p^.link_p;
        IFEND;
        report_list_p^.report_p := report_entry_p;
        report_list_p^.link_p := NIL;
        report_list_p^.shadow := FALSE;
      IFEND;
    FOREND;

  PROCEND process_field_parameter_putif;

?? OLDTITLE ??
?? NEWTITLE := 'process_field_position', EJECT ??

{ PURPOSE:
{   The purpose of this request is to process the field (field_name, summary_calculation and
{ position_description) and row_label parameters for the put_interval_field, put_field & change_put
{ subcommands.
{
{ DESIGN
{   The procedure fills the report entry field vector with:
{     - pointer to fields
{     - summary_calculation (for counters the summary_calculation default is SUM and for descriptive data the
{       summary_calculation is always DESCRIPTIVE)
{     - postion (start_column and column_width) of the field in the report line
{     - fields column headers (only in interval_field report entry).
{
{   For interval_field report entry the procedure processes the row_label parameter in order to figure out
{ where in the report line the row_label position is.
{   If the procedure is called from Change_Put subcommand then the row_label and fields parameters are
{ optional and the procedure gets the missing position (row_label position or fields position from the report
{ entry.
{
{
{ put_field display options
{                                      ao  fo  lo  c  s  m  sd  min  max  sps  cps    i  etsp
{ Numeric
{      counter_field                    D  y    y  y  y  y   y   y    y    y    y     y    y
{      number_of_counters_field         D  y    y  y  y  y   y   y    y    y    y
{      descriptive_data_size_field      D  y    y  y  y  y   y   y    y    y    y
{      previous_occurrence_field        D  y    y  y  y  y   y   y    y         y
{      predecessor_field                D  y    y  y  y  y   y   y    y         y
{      predecessor_chain_head_field     D  y    y  y  y  y   y   y    y         y
{      value_per_second_field           D  y    y  y  y  y   y   y    y         y
{      occurrence_per_second_field      D  y    y  y  y  y   y   y    y         y
{ Textual
{      descriptive_data_field           D  y    y  y                            y
{      date_time_field                  D  y    y  y                            y
{      statistic_code_field             D  y    y  y                            y
{      system_job_name_field            D  y    y  y                            y
{      global_task_id_field             D  y    y  y                            y
{      text_field                       D  y    y
{
{ put_interval_field display options
{                                      ao  fo  lo  c  s  m  sd  min  max  sps  cps    i  elps
{ Numeric
{      counter_field                       y       y  D  y   y   y    y    y    y     y    y
{      number_of_counters_field            y       y  D  y   y   y    y    y    y
{      descriptive_data_size_field         y       y  D  y   y   y    y    y    y
{      previous_occurrence_field           y       y  D  y   y   y    y         y
{      predecessor_field                   y       y  D  y   y   y    y         y
{      predecessor_chain_head_field        y       y  D  y   y   y    y         y
{      value_per_second_field              y       y  D  y   y   y    y         y
{      occurrence_per_second_field         y       y  D  y   y   y    y         y
{ Textual
{      descriptive_data_field              D       y                            y
{      date_time_field                     D       y                            y
{      statistic_code_field                D       y                            y
{      system_job_name_field               D       y                            y
{      global_task_id_field                D       y                            y
{      text_field                          D

  PROCEDURE process_field_position
    (    field_parameter: clt$parameter_value;
         row_label: clt$parameter_value;
         report_entry_p: ^put_entry;
     VAR status: ost$status);

    VAR
      column: integer,
      column_index: report_column,
      errors_detected: boolean,
      failing_status: ost$status,
      field_name: ost$name,
      field_p: ^field,
      index: integer,
      initial_field_vector: [STATIC, READ] field_vector_type :=
            [REP ptc$field_vector_size of [NIL, null, * , * , FALSE, NIL]],
      max_column: 0..clc$max_integer,
      new_used_column: report_column_set,
      summary_index: summary_type,
      selection_p: ^selection,
      value_field_p: ^clt$data_value,
      value_position_p: ^clt$data_value,
      used_column: report_column_set;


    status.normal := TRUE;

    column := 1;
    max_column := 0;
    used_column := $report_column_set [];

    IF report_entry_p^.put = put_interval_field THEN

{ row_label

      IF row_label.value <> NIL THEN

{ row_label.label

        IF row_label.value^.field_values^ [1].value <> NIL THEN
          IF row_label.value^.field_values^ [1].value^.kind = clc$keyword THEN
            IF row_label.value^.field_values^ [1].value^.keyword_value = ptc$key_start_time THEN
              report_entry_p^.row_label_type := start_time;
            ELSEIF row_label.value^.field_values^ [1].value^.keyword_value = ptc$key_end_time THEN
              report_entry_p^.row_label_type := end_time;
            ELSEIF row_label.value^.field_values^ [1].value^.keyword_value = ptc$key_time_range THEN
              report_entry_p^.row_label_type := time_range;
            ELSEIF row_label.value^.field_values^ [1].value^.keyword_value = ptc$key_none THEN
              report_entry_p^.row_label_type := row_label_none;
            IFEND;
          ELSE
            report_entry_p^.row_label_type := string_label;
            report_entry_p^.row_label := row_label.value^.field_values^ [1].value^.string_value^;
          IFEND;
        IFEND;

{ row_label.date_time_start_column & row_label.date_time_column_width

        IF row_label.value^.field_values^ [2].value <> NIL THEN
          report_entry_p^.date_time_start_column := row_label.value^.field_values^ [2].value^.integer_value.
                value;
        IFEND;

        IF row_label.value^.field_values^ [3].value <> NIL THEN
          report_entry_p^.date_time_column_width := row_label.value^.field_values^ [3].value^.integer_value.
                value;
        IFEND;

{ row_label.date_time_format

        IF row_label.value^.field_values^ [4].value <> NIL THEN

{ Do not free old report_entry_p^.date_time_format_p

          ALLOCATE report_entry_p^.date_time_format_p: [#SIZE (row_label.value^.field_values^ [4].value^.
                string_value^)];
          report_entry_p^.date_time_format_p^ := row_label.value^.field_values^ [4].value^.string_value^;
        IFEND;

      IFEND;

      IF report_entry_p^.row_label_type <> row_label_none THEN
        column := report_entry_p^.date_time_start_column + report_entry_p^.date_time_column_width - 1;
        IF column > ptc$max_page_width THEN
          osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$field_out_of_line_limits, 'Row_Label',
                status);
          osp$append_status_integer (osc$status_parameter_delimiter, report_entry_p^.date_time_start_column,
                10, FALSE, status);
          osp$append_status_integer (osc$status_parameter_delimiter, report_entry_p^.date_time_column_width,
                10, FALSE, status);
          RETURN; {----->
        IFEND;
        IF column > max_column THEN
          max_column := column;
        IFEND;
        FOR column_index := report_entry_p^.date_time_start_column TO column DO
          used_column := used_column + $report_column_set [column_index];
        FOREND;
      IFEND;

    IFEND;

    IF field_parameter.value <> NIL THEN

      report_entry_p^.header_1 := '';
      report_entry_p^.header_2 := '';

      report_entry_p^.field_vector := initial_field_vector;
      value_field_p := field_parameter.value;
      index := 1;
      WHILE value_field_p <> NIL DO

{ field_name

        selection_p := ptv$selection_chain_head_p;
        field_name := value_field_p^.element_value^.field_values^ [1].value^.name_value;

      /find_field/
        WHILE selection_p <> NIL DO

          field_p := selection_p^.field_chain_p;
          WHILE (field_p <> NIL) AND (field_p^.field_name <> field_name) DO
            field_p := field_p^.field_chain_link_p;
          WHILEND;

          IF field_p <> NIL THEN
            report_entry_p^.field_vector [index].field_p := field_p;
            EXIT /find_field/; {----->
          IFEND;

          selection_p := selection_p^.selection_chain_link_p;
        WHILEND /find_field/;

{ display_option

        IF report_entry_p^.put = put_field THEN

          IF report_entry_p^.all_occurrences THEN
            report_entry_p^.field_vector [index].summary := all_occurrences;
          ELSE

            process_summary (value_field_p^.element_value^.field_values^ [2].value^.keyword_value,
                  report_entry_p^.field_vector [index].summary);
            check_summary (report_entry_p^.field_vector [index].field_p^.field_type,
                  report_entry_p^.field_vector [index].field_p^.field_name,
                  value_field_p^.element_value^.field_values^ [2].value^.keyword_value,
                  report_entry_p^.field_vector [index].summary,
                  status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            IF report_entry_p^.field_vector [index].field_p^.field_type = text_field THEN
              report_entry_p^.field_vector [index].summary := text;
            IFEND;

          IFEND;

        ELSE { report_entry_p^.put = put_interval_field

          IF value_field_p^.element_value^.field_values^ [2].value = NIL THEN
            CASE report_entry_p^.field_vector [index].field_p^.field_type OF
            = counter_field, number_of_counters_field, descriptive_data_size_field, previous_occurrence_field,
                  predecessor_field, predecessor_chain_head_field, value_per_second_field,
                  occurrence_per_second_field =
              report_entry_p^.field_vector [index].summary := sum;

            = descriptive_data_field, date_time_field, statistic_code_field, system_job_name_field,
                  global_task_id_field =
              report_entry_p^.field_vector [index].summary := first_occurrence;

            = text_field =
              report_entry_p^.field_vector [index].summary := text;

            ELSE
            CASEND;

          ELSEIF (value_field_p^.element_value^.field_values^ [2].value^.keyword_value <>
                ptc$key_last_occurrence) AND (value_field_p^.element_value^.field_values^ [2].value^.
                keyword_value <> ptc$key_all_occurrences) THEN
            process_summary (value_field_p^.element_value^.field_values^ [2].value^.keyword_value,
                  report_entry_p^.field_vector [index].summary);
            check_summary (report_entry_p^.field_vector [index].field_p^.field_type,
                  report_entry_p^.field_vector [index].field_p^.field_name,
                  value_field_p^.element_value^.field_values^ [2].value^.keyword_value,
                  report_entry_p^.field_vector [index].summary,
                  status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          ELSE
            osp$set_status_condition (pte$non_supported_summary_putif, status);
            RETURN; {----->
          IFEND;

        IFEND;

{ start_column & column_width

        process_position (value_field_p^.element_value^.field_values^ [3],
              value_field_p^.element_value^.field_values^ [4], report_entry_p^.field_vector [index].
              summary, report_entry_p^.field_vector [index].field_p^.field_type,
              report_entry_p^.field_vector [index].field_p^.field_name, column, used_column,
              report_entry_p^.field_vector [index].start_column,
              report_entry_p^.field_vector [index].column_width, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF column > max_column THEN
          max_column := column;
        IFEND;

        IF (report_entry_p^.put = put_interval_field) OR ((report_entry_p^.put = put_field) AND
              report_entry_p^.all_occurrences) THEN
{  header 1
          process_header (value_field_p^.element_value^.field_values^ [5], report_entry_p,
                report_entry_p^.field_vector [index].start_column,
                report_entry_p^.field_vector [index].column_width,
                report_entry_p^.field_vector [index].summary, report_entry_p^.field_vector [index].field_p,
                report_entry_p^.header_1, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

{  header 2
          process_header (value_field_p^.element_value^.field_values^ [6], report_entry_p,
                report_entry_p^.field_vector [index].start_column,
                report_entry_p^.field_vector [index].column_width,
                report_entry_p^.field_vector [index].summary, report_entry_p^.field_vector [index].field_p,
                report_entry_p^.header_2, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

        IFEND;

        value_field_p := value_field_p^.link;
        index := index + 1;
      WHILEND;
    ELSE

{ The next 3 lines execute only if the procedure was called from Change_Put command

      index := LOWERBOUND (field_vector_type);
      WHILE (index <= UPPERBOUND (field_vector_type)) AND (report_entry_p^.field_vector [index].summary <>
            null) DO
        FOR column_index := report_entry_p^.date_time_start_column TO column DO
          new_used_column := new_used_column + $report_column_set [column_index];
        FOREND;
        index := index + 1;
      WHILEND;
      IF (new_used_column * used_column) <> $report_column_set [] THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$field_overlap, 'Row_Label', status);
        osp$append_status_integer (osc$status_parameter_delimiter, report_entry_p^.date_time_start_column, 10,
              FALSE, status);
      IFEND;
    IFEND;
    report_entry_p^.max_used_column := max_column;

  PROCEND process_field_position;

?? OLDTITLE ??
?? NEWTITLE := 'process_field_type', EJECT ??

{ PURPOSE:
{   The purpose of this request is to determine the type of the field from the add_field or change_field
{ subcommand.
{
{ DESIGN:
{   The procedure gets the field type set by the caller and checks all the type parameters (counter,
{ descriptive_data, header, elapsed_time, string (text) and elapsed_time_calculation).
{ If only one of the parameters was specified, the procedure returns the type of field.  If more than
{ one of the parameters was specified, the procedure returns a status error.  If none of these parameters
{ were specified, the procedure returns the undefined type.

  PROCEDURE process_field_type
    (    counter: clt$parameter_value;
         descriptive_data: clt$parameter_value;
         header: clt$parameter_value;
         elapsed_time: clt$parameter_value;
         string_parameter: clt$parameter_value;
         elapsed_time_calculation: clt$parameter_value;
         text: clt$parameter_value;
     VAR field_type: type_of_field;
     VAR status: ost$status);

    IF counter.specified THEN
      field_type := counter_field;
    IFEND;

    IF descriptive_data.specified THEN
      IF field_type = undefined_field THEN
        field_type := descriptive_data_field;
      ELSE
        osp$set_status_condition (pte$many_field_type_parameters, status);
        RETURN; {----->
      IFEND;
    IFEND;

    IF header.specified THEN
      IF field_type = undefined_field THEN
        IF header.value^.keyword_value = ptc$key_statistic_code THEN
          field_type := statistic_code_field;
        ELSEIF header.value^.keyword_value = ptc$key_date_time THEN
          field_type := date_time_field;
        ELSEIF header.value^.keyword_value = ptc$key_system_job_name THEN
          field_type := system_job_name_field;
        ELSEIF header.value^.keyword_value = ptc$key_global_task_id THEN
          field_type := global_task_id_field;
        ELSEIF header.value^.keyword_value = ptc$key_number_of_counters THEN
          field_type := number_of_counters_field;
        ELSE {= ptc$key_descriptive_data_length }
          field_type := descriptive_data_size_field;
        IFEND;
      ELSE
        osp$set_status_condition (pte$many_field_type_parameters, status);
        RETURN; {----->
      IFEND;
    IFEND;

    IF elapsed_time.specified THEN
      IF field_type = undefined_field THEN
        IF elapsed_time.value^.keyword_value = ptc$key_previous_occurrence THEN
          field_type := previous_occurrence_field;
        ELSEIF elapsed_time.value^.keyword_value = ptc$key_predecessor THEN
          field_type := predecessor_field;
        ELSE { = ptc$key_predecessor_chain_head }
          field_type := predecessor_chain_head_field;
        IFEND;
      ELSE
        osp$set_status_condition (pte$many_field_type_parameters, status);
        RETURN; {----->
      IFEND;
    IFEND;

    IF elapsed_time_calculation.specified THEN
      IF field_type = undefined_field THEN

{   Calculation field in elapsed_time_calculation parameter is optional in change_field subcommand.  If this
{ field was not specified, the procedure will return undefined field_type.

        IF elapsed_time_calculation.value^.field_values^ [1].value <> NIL THEN
          IF elapsed_time_calculation.value^.field_values^ [1].value^.keyword_value =
                ptc$key_value_per_second THEN
            field_type := value_per_second_field;
          ELSEIF elapsed_time_calculation.value^.field_values^ [1].value^.keyword_value =
                ptc$key_occurrence_per_second THEN
            field_type := occurrence_per_second_field;
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (pte$many_field_type_parameters, status);
        RETURN; {----->
      IFEND;
    IFEND;

    IF string_parameter.specified THEN
      IF field_type = undefined_field THEN
        field_type := text_field;
      ELSE
        osp$set_status_condition (pte$many_field_type_parameters, status);
        RETURN; {----->
      IFEND;
    IFEND;

{ Start 1.4.1 compatibility code.

    IF text.specified THEN
      IF field_type = undefined_field THEN
        IF text.value^.kind = clc$record THEN
          field_type := descriptive_data_field;
        ELSE
          field_type := text_field;
        IFEND;
      ELSE
        osp$set_status_condition (pte$many_field_type_parameters, status);
        RETURN; {----->
      IFEND;
    IFEND;

{ End 1.4.1 compatibility code.

  PROCEND process_field_type;

?? OLDTITLE ??
?? NEWTITLE := 'process_global_task_id', EJECT ??

{ PURPOSE:
{   The purpose of this request is to translate a string that represents global_task_id to two integers
{ global_task_id index and global_task_id seqno.
{
{ NOTE:
{   The procedure expects to find a string in the follwing format 'mmmmm-nnn':
{     - mmmmm is the global_task_id index: an integer in the range 0..65535.
{     - nnn is the global_task_id seqno: an integer in the range 0..255.

  PROCEDURE process_global_task_id
    (    global_task_id: clt$data_value;
     VAR index_value: clt$integer;
     VAR seqno_value: clt$integer;
     VAR status: ost$status);

    VAR
      dash: [STATIC, READ] set of char := ['-'],
      dash_found: boolean,
      index: integer;

    #SCAN (dash, global_task_id.string_value^, index, dash_found);
    IF dash_found THEN
      clp$convert_string_to_integer (global_task_id.string_value^ (1, index - 1), index_value, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      IF (index_value.value < 0) OR (index_value.value > ptc$max_tasks) THEN
        osp$set_status_condition (pte$task_id_index_out_of_range, status);
        RETURN; {----->
      IFEND;
      clp$convert_string_to_integer (global_task_id.string_value^ (index + 1, * ), seqno_value, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      IF (seqno_value.value < 0) OR (seqno_value.value > 255) THEN
        osp$set_status_condition (pte$task_id_seqno_out_of_range, status);
        RETURN; {----->
      IFEND;
    ELSE
      osp$set_status_condition (pte$invalid_global_task_id, status);
      RETURN; {----->
    IFEND;

  PROCEND process_global_task_id;

?? OLDTITLE ??
?? NEWTITLE := 'process_header', EJECT ??

{ PURPOSE:
{   The purpose of this request is to construct the header string.
{
{ DESIGN
{   The procedure gets string (header) and the position (start_column and column_width) of the field in the
{ report line.  It checks if the string is longer than column width.  The string is placed in the report
{ entry header; right justified for counters and left justified for descriptive.
{
{ NOTE:
{  right justified
{  ---------------
{  count and count_per_second summary of all field types
{  counter_field
{  number_of_counters_field
{  descriptive_data_size_field
{  previous_occurrence_field
{  predecessor_field
{  predecessor_chain_head_field
{  value_per_second_field
{  occurrence_per_second_field
{
{  left justified
{  --------------
{  text_field
{  descriptive data_field (except count and count_per_second summary)
{  date_time_field (except count and count_per_second summary)
{  statistic_code_field (except count and count_per_second summary)
{  system_job_name_field (except count and count_per_second summary)
{  global_task_id_field (except count and count_per_second summary)

  PROCEDURE process_header
    (    header: clt$field_value;
         report_entry_p: ^put_entry;
         start_column: report_column;
         column_width: report_column;
         summary: summary_type;
         field_p: ^field;
     VAR report_header: string (ptc$max_page_width);
     VAR status: ost$status);

    VAR
      header_length: integer;

    status.normal := TRUE;

    IF header.value <> NIL THEN
      header_length := STRLENGTH (header.value^.string_value^);
      IF header_length <= column_width THEN
        IF (summary = count) OR (summary = count_per_second) THEN

{ The header is right justified in the field column.

          report_header (start_column + column_width - header_length, header_length) :=
                header.value^.string_value^;

        ELSE

          CASE field_p^.field_type OF
          = counter_field, number_of_counters_field, descriptive_data_size_field, previous_occurrence_field,
                predecessor_field, predecessor_chain_head_field, value_per_second_field,
                occurrence_per_second_field =

{ The header is right justified in the field column.

            report_header (start_column + column_width - header_length, header_length) :=
                  header.value^.string_value^;

          = descriptive_data_field, date_time_field, statistic_code_field, system_job_name_field,
                global_task_id_field, text_field =

{ The header is left justified in the field column.

            report_header (start_column, header_length) := header.value^.string_value^;

          CASEND;

        IFEND;
      ELSE
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$header_overflow, header.value^.string_value^,
              status);
        osp$append_status_integer (osc$status_parameter_delimiter, header_length, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, column_width, 10, FALSE, status);
        RETURN; {----->
      IFEND;
    IFEND;

  PROCEND process_header;

?? OLDTITLE ??
?? NEWTITLE := 'process_headers_putfs', EJECT ??

{ PURPOSE:
{   The purpose of this request is to construct the strings for field_summary report headers.
{
{ DESIGN
{   The procedure scans the report entry summary vector and for each summary the summary name is placed in
{ summary postion (start_column and column_width) right justified.

  PROCEDURE process_headers_putfs
    (    report_entry_p: ^put_entry);

    VAR
      index: integer;

    report_entry_p^.header_1 := '';
    report_entry_p^.header_2 := '';
    FOR index := LOWERBOUND (summary_vector_type) TO UPPERBOUND (summary_vector_type) DO

{ The code puts the column header justified to the right.  That way the code can compute the
{ first character position as start_column + column_width - the header string length.

      CASE report_entry_p^.summary_vector [index].summary OF

      = count =
        report_entry_p^.header_2 (report_entry_p^.summary_vector [index].start_column +
              report_entry_p^.summary_vector [index].column_width - 5, * ) := 'Count';

      = sum =
        report_entry_p^.header_2 (report_entry_p^.summary_vector [index].start_column +
              report_entry_p^.summary_vector [index].column_width - 3, * ) := 'Sum';

      = mean =
        report_entry_p^.header_2 (report_entry_p^.summary_vector [index].start_column +
              report_entry_p^.summary_vector [index].column_width - 4, * ) := 'Mean';

      = standard_deviation =
        report_entry_p^.header_1 (report_entry_p^.summary_vector [index].start_column +
              report_entry_p^.summary_vector [index].column_width - 8, * ) := 'Standard';
        report_entry_p^.header_2 (report_entry_p^.summary_vector [index].start_column +
              report_entry_p^.summary_vector [index].column_width - 9, * ) := 'Deviation';

      = minimum =
        report_entry_p^.header_2 (report_entry_p^.summary_vector [index].start_column +
              report_entry_p^.summary_vector [index].column_width - 7, * ) := 'Minimum';

      = maximum =
        report_entry_p^.header_2 (report_entry_p^.summary_vector [index].start_column +
              report_entry_p^.summary_vector [index].column_width - 7, * ) := 'Maximum';

      = interval =
        report_entry_p^.header_2 (report_entry_p^.summary_vector [index].start_column +
              report_entry_p^.summary_vector [index].column_width - 8, * ) := 'Interval';

      = count_per_second =
        report_entry_p^.header_1 (report_entry_p^.summary_vector [index].start_column +
              report_entry_p^.summary_vector [index].column_width - 5, * ) := 'Count';
        report_entry_p^.header_2 (report_entry_p^.summary_vector [index].start_column +
              report_entry_p^.summary_vector [index].column_width - 5, * ) := '/Sec';

      = sum_per_second =
        report_entry_p^.header_1 (report_entry_p^.summary_vector [index].start_column +
              report_entry_p^.summary_vector [index].column_width - 4, * ) := ' Sum';
        report_entry_p^.header_2 (report_entry_p^.summary_vector [index].start_column +
              report_entry_p^.summary_vector [index].column_width - 4, * ) := '/Sec';

      = elapsed_time_since_predecessor =
        report_entry_p^.header_1 (report_entry_p^.summary_vector [index].start_column +
              report_entry_p^.summary_vector [index].column_width - 7, * ) := 'Elapsed';
        report_entry_p^.header_2 (report_entry_p^.summary_vector [index].start_column +
              report_entry_p^.summary_vector [index].column_width - 7, * ) := ' Time';

      ELSE
      CASEND;
    FOREND;

  PROCEND process_headers_putfs;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] process_incremental_selection', EJECT ??

{ PURPOSE
{   The purpose of this request is to recognize when the day has changed.
{     It is only called when a selection has an incremental counter.
{

  PROCEDURE [INLINE] process_incremental_selection
    (    statistic_header_p: ^sft$statistic_header;
         selection_p { input, output } : ^selection;
         counters_p: sft$counters;
     VAR status: ost$status);

    VAR
      field_p: ^field,
      local_status: ost$status,
      interval: pmt$time_increment;

    status.normal := TRUE;
    local_status.normal := TRUE;

    IF (selection_p^.incremental_counter_p^.counter_number <= statistic_header_p^.number_of_counters) AND
          (selection_p^.incremental_counter_p^.field_summary.count > 0) THEN

{ First statistic in a new day window.  The counters are new base for incremental values,
{ the time interval between the last statistic and the new base are calculated and kept for interval,
{ sum_per_interval and count_per_interval summary.

      IF (selection_p^.date_time_specified AND NOT selection_p^.continuous_date_time AND
            NOT date_time_1_gt_date_time_2 (selection_p^.new_day_date_time, statistic_header_p^.date_time))
            THEN

        pmp$compute_date_time_increment (selection_p^.incremental_counter_p^.field_summary.last_date_time,
              statistic_header_p^.date_time, interval, local_status);
        IF NOT local_status.normal THEN
          RETURN; {----->
        IFEND;
        selection_p^.lost_interval := selection_p^.lost_interval + interval_to_millisecond (interval);

        field_p := selection_p^.field_chain_p;
        WHILE field_p <> NIL DO
          field_p^.field_summary.last_date_time := statistic_header_p^.date_time;
          IF field_p^.field_type = counter_field THEN
            field_p^.last_value := counters_p^ [field_p^.counter_number];
          IFEND;
          field_p := field_p^.field_chain_link_p;
        WHILEND;
        IF selection_p^.collect_date_time THEN
          IF NOT selection_p^.skip_date_time THEN
            IF selection_p^.skip_date_time_tail_p <> NIL THEN
              NEXT selection_p^.skip_date_time_tail_p^.link_p IN ptv$data_segment_p.sequence_pointer;
              selection_p^.skip_date_time_tail_p := selection_p^.skip_date_time_tail_p^.link_p;
            ELSE
              NEXT selection_p^.skip_date_time_head_p^.link_p IN ptv$data_segment_p.sequence_pointer;
              selection_p^.skip_date_time_tail_p := selection_p^.skip_date_time_head_p;
            IFEND;
            selection_p^.skip_date_time_tail_p^.link_p := NIL;
            selection_p^.skip_date_time := TRUE;
          IFEND;
          selection_p^.skip_date_time_tail_p^.skip_date_time := statistic_header_p^.date_time;
        IFEND;

        IF selection_p^.date_time_specified AND NOT selection_p^.continuous_date_time AND
              NOT date_time_1_gt_date_time_2 (selection_p^.new_day_date_time, statistic_header_p^.date_time)
              THEN

{ First statistic in a new day window.  The next new day date time is calculated.

          pmp$compute_date_time (selection_p^.new_day_date_time, ptv$one_day, selection_p^.new_day_date_time,
                local_status);
          IF NOT local_status.normal THEN
            RETURN; {----->
          IFEND;

        IFEND;

{  Return abnormal status so collect_field will terminate
        status.normal := FALSE;
        RETURN; {----->
      IFEND;
    ELSEIF (selection_p^.incremental_counter_p^.field_summary.count = 0) AND
          selection_p^.date_time_specified AND NOT selection_p^.continuous_date_time THEN

{ The first selected statistic (base statistic) set the current day. The time is taken from the selection
{ criteria and the day from the first statistic header.  Then the next new_day_date_time for the next new
{ base statistic incremented by one day.

      selection_p^.new_day_date_time := selection_p^.start_date_time;
      selection_p^.new_day_date_time.year := statistic_header_p^.date_time.year;
      selection_p^.new_day_date_time.month := statistic_header_p^.date_time.month;
      selection_p^.new_day_date_time.day := statistic_header_p^.date_time.day;
      pmp$compute_date_time (selection_p^.new_day_date_time, ptv$one_day, selection_p^.new_day_date_time,
            local_status);
      IF NOT local_status.normal THEN
        RETURN; {----->
      IFEND;
    IFEND;

  PROCEND process_incremental_selection;

?? OLDTITLE ??
?? NEWTITLE := 'process_input_parameter', EJECT ??

{ PURPOSE:
{   The purpose of this request is to open the input log(s) for the display_logged_statistics, generate_log
{ and generate_report (& use_log) commands.
{
{ DESIGN
{   The procedure:
{    1) Gets the new input files list.
{    2) Checks for duplicate file names in the list.
{    3) Compares the old list to the new list.
{    4) Closes files from the old list that are not in the new list and
{       FREEs the records that are allocated for input_log, logged_statistic & statistic_location.
{    5) Opens files from the new list that are not in the old list.
{
{ NOTE:
{   Analyze_Binary_Log tries to keep information about input log(s) (e.g. the logged statistic in each log).
{ The information is kept all the time that the file is open.  That way the files are not closed when the
{ subcommand that opens them is completed.  When a new list of files is given, the procedure tries to save the
{ information about the files that are already opened in the list of new files.

  PROCEDURE process_input_parameter
    (VAR value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      errors_detected: boolean,
      failing_status: ost$status,
      input_log_chain_tail: ^log_file,
      input_log_1_p: ^log_file,
      input_log_2_p: ^log_file,
      input_log_3_p: ^log_file,
      new_files: boolean,
      new_input_log_chain_head: ^log_file;

?? NEWTITLE := 'free_input_file', EJECT ??

{ PURPOSE:
{   The purpose of this request is to FREE the records that are allocated for input_log, logged_statistic and
{ statistic_location, when the file is closed.

    PROCEDURE free_input_file
      (VAR input_log_p: ^log_file);

      PROCEDURE free_statistics_list
        (VAR logged_statistic_p: ^logged_statistic);

        PROCEDURE free_statistic_location
          (VAR statistic_location_p: ^statistic_location);

          IF statistic_location_p^.statistic_location_chain_link_p <> NIL THEN
            free_statistic_location (statistic_location_p^.statistic_location_chain_link_p);
          IFEND;
          FREE statistic_location_p;

        PROCEND free_statistic_location;

        IF logged_statistic_p^.link_p <> NIL THEN
          free_statistics_list (logged_statistic_p^.link_p);
        IFEND;
        IF logged_statistic_p^.statistic_location_p <> NIL THEN
          free_statistic_location (logged_statistic_p^.statistic_location_p);
        IFEND;
        FREE logged_statistic_p;

      PROCEND free_statistics_list;

      IF input_log_p^.statistics_list_p <> NIL THEN
        free_statistics_list (input_log_p^.statistics_list_p);
      IFEND;

    PROCEND free_input_file;

?? OLDTITLE ??
?? NEWTITLE := 'free_logged_statistic', EJECT ??

{ PURPOSE:
{   The purpose of this request is to FREE the records that are allocated for logged_statistic.

    PROCEDURE free_logged_statistic;

      VAR
        logged_statistic_1_p: ^logged_statistic,
        logged_statistic_2_p: ^logged_statistic;

      logged_statistic_1_p := ptv$logged_statistic_chain_head;
      WHILE logged_statistic_1_p <> NIL DO
        logged_statistic_2_p := logged_statistic_1_p^.link_p;
        FREE logged_statistic_1_p;
        logged_statistic_1_p := logged_statistic_2_p;
      WHILEND;

    PROCEND free_logged_statistic;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

{ Get the new input files list.

    ALLOCATE new_input_log_chain_head: [#SIZE (value^.element_value^.file_value^)];
    input_log_chain_tail := new_input_log_chain_head;
    input_log_chain_tail^.log_file_name := value^.element_value^.file_value^;
    input_log_chain_tail^.open := FALSE;
    input_log_chain_tail^.statistics_list_p := NIL;
    value := value^.link;
    WHILE value <> NIL DO
      ALLOCATE input_log_chain_tail^.log_chain_link_p: [#SIZE (value^.element_value^.file_value^)];
      input_log_chain_tail := input_log_chain_tail^.log_chain_link_p;
      input_log_chain_tail^.log_file_name := value^.element_value^.file_value^;
      input_log_chain_tail^.access_level := amc$segment;
      input_log_chain_tail^.open := FALSE;
      input_log_chain_tail^.statistics_list_p := NIL;
      value := value^.link;
    WHILEND;
    input_log_chain_tail^.log_chain_link_p := NIL;

{ Compare old list to new list.

    input_log_1_p := ptv$input_log_chain_head_p;
    WHILE input_log_1_p <> NIL DO
      input_log_1_p^.open := FALSE;
      input_log_2_p := new_input_log_chain_head;
      WHILE input_log_2_p <> NIL DO
        IF input_log_1_p^.log_file_name = input_log_2_p^.log_file_name THEN

{ COPY

          input_log_2_p^.active_log := input_log_1_p^.active_log;
          input_log_2_p^.log_file_identifier := input_log_1_p^.log_file_identifier;
          input_log_2_p^.file_identifier := input_log_1_p^.file_identifier;
          input_log_2_p^.segment_pointer := input_log_1_p^.segment_pointer;
          input_log_2_p^.access_level := input_log_1_p^.access_level;
          input_log_2_p^.start_time := input_log_1_p^.start_time;
          input_log_2_p^.end_time := input_log_1_p^.end_time;
          input_log_2_p^.statistics_list_p := input_log_1_p^.statistics_list_p;
          input_log_2_p^.open := TRUE;
          input_log_1_p^.open := TRUE;
          input_log_1_p^.statistics_list_p := NIL;
          input_log_2_p := NIL;
        ELSE
          input_log_2_p := input_log_2_p^.log_chain_link_p;
        IFEND;
      WHILEND;
      input_log_1_p := input_log_1_p^.log_chain_link_p;
    WHILEND;

{ Close files from the old list that are not in the new list.

    input_log_1_p := ptv$input_log_chain_head_p;
    WHILE input_log_1_p <> NIL DO
      input_log_2_p := input_log_1_p^.log_chain_link_p;
      IF NOT input_log_1_p^.open THEN
        lgp$close_log_file (input_log_1_p^.log_file_identifier, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF ptv$logged_statistic_chain_head <> NIL THEN
          free_logged_statistic;
          ptv$logged_statistic_chain_head := NIL;
        IFEND;
      IFEND;
      free_input_file (input_log_1_p);
      FREE input_log_1_p;
      input_log_1_p := input_log_2_p;
    WHILEND;

{ Open files from the new list that are not in the old list.

    new_files := FALSE;
    ptv$input_log_chain_head_p := new_input_log_chain_head;
    input_log_1_p := ptv$input_log_chain_head_p;
    input_log_2_p := NIL;
    WHILE input_log_1_p <> NIL DO
      IF NOT input_log_1_p^.open THEN
        open_log_file (input_log_1_p, FALSE, status);
        IF NOT status.normal THEN
          WHILE input_log_1_p <> NIL DO
            IF NOT input_log_1_p^.open THEN
              input_log_3_p := input_log_1_p^.log_chain_link_p;
              FREE input_log_1_p;
              IF input_log_2_p <> NIL THEN
                input_log_2_p^.log_chain_link_p := input_log_3_p;
              ELSE
                ptv$input_log_chain_head_p := input_log_3_p;
              IFEND;
            ELSE
              input_log_2_p := input_log_1_p;
            IFEND;
            input_log_1_p := input_log_3_p;
          WHILEND;
          RETURN; {----->
        IFEND;
        new_files := TRUE;
      ELSE
        IF input_log_1_p^.access_level = amc$record THEN
          IF ptv$logged_statistic_chain_head <> NIL THEN
            free_logged_statistic;
            ptv$logged_statistic_chain_head := NIL;
          IFEND;
          free_input_file (input_log_1_p);
        IFEND;
      IFEND;
      input_log_2_p := input_log_1_p;
      input_log_1_p := input_log_1_p^.log_chain_link_p;
    WHILEND;

    IF (ptv$logged_statistic_chain_head <> NIL) AND new_files THEN
      free_logged_statistic;
      ptv$logged_statistic_chain_head := NIL;
    IFEND;

    IF new_files THEN
      ptv$active_log := FALSE;
      input_log_1_p := ptv$input_log_chain_head_p;
      WHILE input_log_1_p <> NIL DO
        ptv$active_log := (input_log_1_p^.access_level = amc$record) OR ptv$active_log;
        input_log_1_p := input_log_1_p^.log_chain_link_p;
      WHILEND;
    IFEND;

  PROCEND process_input_parameter;

?? OLDTITLE ??
?? NEWTITLE := 'process_number_parameter', EJECT ??

{ PURPOSE:
{   The purpose of this request is to position the new put entry (or changed put entry) in the list of put
{ entries, based on the number parameter for the put_field_summary, put_field, put_interval_field, put_record
{ and change_put subcommands.

  PROCEDURE process_number_parameter
    (    number: clt$data_value;
         temp_put_entry: ^put_entry;
     VAR put_entry_chain_head: ^put_entry);

    VAR
      position: integer,
      put_entry_p: ^put_entry;


    IF put_entry_chain_head <> NIL THEN
      IF number.kind = clc$integer THEN
        IF number.integer_value.value > 1 THEN
          position := 1;
          put_entry_p := put_entry_chain_head;
          WHILE (put_entry_p^.put_chain_link_p <> NIL) AND (position < number.integer_value.value - 1) DO
            put_entry_p := put_entry_p^.put_chain_link_p;
            position := position + 1;
          WHILEND;
          temp_put_entry^.put_chain_link_p := put_entry_p^.put_chain_link_p;
          put_entry_p^.put_chain_link_p := temp_put_entry;
        ELSE { number = 1 }
          temp_put_entry^.put_chain_link_p := put_entry_chain_head;
          put_entry_chain_head := temp_put_entry;
        IFEND;
      ELSE { last or next }
        put_entry_p := put_entry_chain_head;
        WHILE put_entry_p^.put_chain_link_p <> NIL DO
          put_entry_p := put_entry_p^.put_chain_link_p;
        WHILEND;
        put_entry_p^.put_chain_link_p := temp_put_entry;
      IFEND;
    ELSE
      put_entry_chain_head := temp_put_entry;
    IFEND;

  PROCEND process_number_parameter;

?? OLDTITLE ??
?? NEWTITLE := 'process_position', EJECT ??

{ PURPOSE:
{   The purpose of this request is to set the column position for a field in put_field and put_interval_field
{ or summary_calculation in put_field_summary.
{
{ DESIGN
{   The procedure receives the start_column, column_width, summary of the field and last used column.  If the
{ start_column was omitted from the subcommand parameter then the start_column will be set to create 1 column
{ space between the current field and last field (new start_column <-- last used column + 2).  The calling
{ procedure sets the last used column to -1 for the first field in order to set the default start_column to 1.
{ If the column_width was omitted from the subcommand parameter then the column_width will be set to:
{   -  6 for count summary
{   - 15 for sum, mean, standard_deviation, minimum, maximum, count_per_second and sum_per_second
{   - 12 for interval and elapsed_time_since_predecessor
{   - 31 for descriptive data and text
{ Last used column set and checked for line length overflow.

  PROCEDURE process_position
    (    start_column: clt$field_value;
         column_width: clt$field_value;
         summary: summary_type;
         field_type: type_of_field;
         field_name: string ( * <= osc$max_name_size);
     VAR column { input, output } : integer;
     VAR used_column { input, output } : report_column_set;
     VAR report_start_column: report_column;
     VAR report_column_width: report_column;
     VAR status: ost$status);

    VAR
      column_index: report_column,
      field_name_string: string (6 + osc$max_name_size),
      new_used_column: report_column_set;

    status.normal := TRUE;

    IF start_column.value <> NIL THEN
      report_start_column := start_column.value^.integer_value.value;
    ELSE
      report_start_column := column + 2;
    IFEND;

    IF column_width.value <> NIL THEN
      report_column_width := column_width.value^.integer_value.value;
    ELSE

{ Default column width for summary.

      CASE summary OF

      = count =
        report_column_width := 6; { Count range of 0..99999 }

      = sum, mean, standard_deviation, minimum, maximum, count_per_second, sum_per_second =
        report_column_width := 15;

      = interval, elapsed_time_since_predecessor =
        report_column_width := 12; { Time in the form H24:MM:SS.S1000 }

      = text =
        report_column_width := osc$max_name_size;

      = first_occurrence, last_occurrence, all_occurrences =
        CASE field_type OF
        = counter_field, value_per_second_field, occurrence_per_second_field =
          report_column_width := 15;

        = number_of_counters_field, descriptive_data_size_field =
          report_column_width := 4;

        = date_time_field, previous_occurrence_field, predecessor_field, predecessor_chain_head_field =
          report_column_width := 12;

        = statistic_code_field =
          report_column_width := 7;

        = system_job_name_field =
          report_column_width := 19;

        = global_task_id_field =
          report_column_width := 9;

        = descriptive_data_field, text_field =
          report_column_width := 31;

        ELSE
        CASEND;

      ELSE
      CASEND;
    IFEND;

    column := report_start_column + report_column_width - 1;
    IF column > ptc$max_page_width THEN
      osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$field_out_of_line_limits, 'Field', status);
      osp$append_status_integer (osc$status_parameter_delimiter, report_start_column, 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, report_column_width, 10, FALSE, status);
      RETURN; {----->
    IFEND;

    new_used_column := $report_column_set [];
    FOR column_index := report_start_column TO column DO
      new_used_column := new_used_column + $report_column_set [column_index];
    FOREND;
    IF (new_used_column * used_column) <> $report_column_set [] THEN
      field_name_string (1, * ) := 'Field';
      field_name_string (7, * ) := field_name;
      osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$field_overlap, field_name_string, status);
      osp$append_status_integer (osc$status_parameter_delimiter, report_start_column, 10, FALSE, status);
      RETURN; {----->
    IFEND;
    used_column := used_column + new_used_column;

  PROCEND process_position;

?? OLDTITLE ??
?? NEWTITLE := 'process_put_parameter', EJECT ??

{ PURPOSE:
{   The purpose of this request is to process the put parameter for the put_field_summary, put_field,
{ put_interval_field, put_record and change_put subcommands.  The procedure returns an error message if the
{ put parameter is the name of defined put entry.

  PROCEDURE process_put_parameter
    (    put: clt$data_value;
         put_entry_chain_head_p: ^put_entry;
     VAR name: ost$name;
     VAR status: ost$status);

    VAR
      put_entry_p: ^put_entry;

    name := put.name_value;
    put_entry_p := put_entry_chain_head_p;
    WHILE (put_entry_p <> NIL) AND (put_entry_p^.name <> name) DO
      put_entry_p := put_entry_p^.put_chain_link_p;
    WHILEND;
    IF put_entry_p <> NIL THEN
      osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$redefined_put, name, status);
      RETURN; {----->
    IFEND;

  PROCEND process_put_parameter;

?? OLDTITLE ??
?? NEWTITLE := 'process_selection_parameter', EJECT ??

{ PURPOSE:
{   The purpose of this request is to process the selection parameter for the put_record & change_put
{ commands.  The procedure constructs the selection list for the log entry (list of pointers to selection).

  PROCEDURE process_selection_parameter
    (VAR value_p: ^clt$data_value;
         temp_log_entry: ^put_entry);

    VAR
      selection_list_p: ^selection_list,
      selection_p: ^selection;


    ALLOCATE temp_log_entry^.selection_p;
    selection_list_p := temp_log_entry^.selection_p;
    selection_p := ptv$selection_chain_head_p;
    WHILE (selection_p <> NIL) AND (selection_p^.name <> value_p^.element_value^.name_value) DO
      selection_p := selection_p^.selection_chain_link_p;
    WHILEND;
    selection_p^.log_entry_p := temp_log_entry;
    selection_list_p^.selection_p := selection_p;
    value_p := value_p^.link;
    WHILE value_p <> NIL DO
      ALLOCATE selection_list_p^.link_p;
      selection_list_p := selection_list_p^.link_p;
      selection_p := ptv$selection_chain_head_p;
      WHILE (selection_p <> NIL) AND (selection_p^.name <> value_p^.element_value^.name_value) DO
        selection_p := selection_p^.selection_chain_link_p;
      WHILEND;
      selection_p^.log_entry_p := temp_log_entry;
      selection_list_p^.selection_p := selection_p;
      value_p := value_p^.link;
    WHILEND;
    selection_list_p^.link_p := NIL;

  PROCEND process_selection_parameter;

?? OLDTITLE ??
?? NEWTITLE := 'process_string', EJECT ??

{ PURPOSE:
{   The purpose of this request is to process the string parameter for the put_string, push_page_header,
{ and change_put commands.
{
{ DESIGN
{   The procedure receives a list of strings, start_column and column_width from the string parameter.  If
{ start_column was omitted from the subcommand parameter then the start_column will be set to create 1 column
{ space between the current field and last field (new start_column <-- last used column + 2).  The last used
{ column set to -1 for the first field in order to set the default start_column to 1.  If the column_width was
{ omitted from the on the subcommand parameter then the
{ column_width will be set to string length.

  PROCEDURE process_string
    (    string_parameter: clt$parameter_value;
         report_entry_p: ^put_entry;
     VAR status: ost$status);

    VAR
      column: integer,
      column_index: report_column,
      column_width: report_column,
      max_column: 0..clc$max_integer,
      new_used_column: report_column_set,
      start_column: report_column,
      string_length: integer,
      used_column: report_column_set,
      value_string_p: ^clt$data_value;

    status.normal := TRUE;

    max_column := 0;
    used_column := $report_column_set [];
    column := -1;
    report_entry_p^.header_1 := '';
    value_string_p := string_parameter.value;
    WHILE value_string_p <> NIL DO

      string_length := STRLENGTH (value_string_p^.element_value^.field_values^ [1].value^.string_value^);

      IF value_string_p^.element_value^.field_values^ [2].value <> NIL THEN
        start_column := value_string_p^.element_value^.field_values^ [2].value^.integer_value.value;
      ELSE
        start_column := column + 2;
      IFEND;

      IF value_string_p^.element_value^.field_values^ [3].value <> NIL THEN
        column_width := value_string_p^.element_value^.field_values^ [3].value^.integer_value.value;
      ELSE
        column_width := string_length;
      IFEND;

      IF string_length <= column_width THEN
        report_entry_p^.header_1 (start_column + column_width - string_length,
              string_length) := value_string_p^.element_value^.field_values^ [1].value^.string_value^;
      ELSE
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$string_overflow,
              value_string_p^.element_value^.field_values^ [1].value^.string_value^, status);
        osp$append_status_integer (osc$status_parameter_delimiter, string_length, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, column_width, 10, FALSE, status);
        RETURN; {----->
      IFEND;

      column := start_column + column_width - 1;
      IF column > ptc$max_page_width THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$field_out_of_line_limits, 'String', status);
        osp$append_status_integer (osc$status_parameter_delimiter, start_column, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, column_width, 10, FALSE, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      IFEND;
      IF column > max_column THEN
        max_column := column;
      IFEND;

      new_used_column := $report_column_set [];
      FOR column_index := start_column TO column DO
        new_used_column := new_used_column + $report_column_set [column_index];
      FOREND;
      IF (new_used_column * used_column) <> $report_column_set [] THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$field_overlap, 'String', status);
        osp$append_status_integer (osc$status_parameter_delimiter, start_column, 10, FALSE, status);
        RETURN; {----->
      IFEND;

      value_string_p := value_string_p^.link;
    WHILEND;
    report_entry_p^.max_used_column := max_column;

  PROCEND process_string;

?? OLDTITLE ??
?? NEWTITLE := 'process_subfield', EJECT ??

{ PURPOSE:
{   The purpose of this request is to process a descriptive data subfield from descriptive_data parameter for
{ process_descriptive_selection procedure.
{
{ DESIGN
{   The procedure builds a list of pointers to descriptive_data strings and fills the subfield_position,
{ subfield_length, subfield_number and subfield_delimiter.

  PROCEDURE process_subfield
    (    subfield_value: ^clt$data_value;
     VAR subfield_p: ^descriptive_data_subfield);

    VAR
      string_p: ^descriptive_data_string,
      string_value: ^clt$data_value;

{ Get the list of strings.

    string_value := subfield_value^.element_value^.field_values^ [1].value;
    ALLOCATE subfield_p^.descriptive_data_string_p: [#SIZE (string_value^.element_value^.string_value^)];
    string_p := subfield_p^.descriptive_data_string_p;
    string_p^.descriptive_text := string_value^.element_value^.string_value^;
    string_value := string_value^.link;
    WHILE string_value <> NIL DO
      ALLOCATE string_p^.descriptive_string_link_p: [#SIZE (string_value^.element_value^.string_value^)];
      string_p := string_p^.descriptive_string_link_p;
      string_p^.descriptive_text := string_value^.element_value^.string_value^;
      string_value := string_value^.link;
    WHILEND;
    string_p^.descriptive_string_link_p := NIL;

    IF subfield_value^.element_value^.field_values^ [2].value <> NIL THEN
      subfield_p^.subfield_position := subfield_value^.element_value^.field_values^ [2].value^.integer_value.
            value;
    IFEND;

    IF subfield_value^.element_value^.field_values^ [3].value <> NIL THEN
      IF subfield_value^.element_value^.field_values^ [3].value^.kind <> clc$keyword THEN
        subfield_p^.subfield_length := subfield_value^.element_value^.field_values^ [3].value^.integer_value.
              value;
      IFEND;
    IFEND;

    IF subfield_value^.element_value^.field_values^ [4].value <> NIL THEN
      IF subfield_value^.element_value^.field_values^ [4].value^.kind <> clc$keyword THEN
        subfield_p^.subfield_number := subfield_value^.element_value^.field_values^ [4].value^.integer_value.
              value;
      IFEND;
    IFEND;

    IF subfield_value^.element_value^.field_values^ [5].value <> NIL THEN
      subfield_p^.subfield_delimiter := subfield_value^.element_value^.field_values^ [5].value^.
            string_value^ (1);
    IFEND;

  PROCEND process_subfield;

?? OLDTITLE ??
?? NEWTITLE := 'process_summary', EJECT ??

{ PURPOSE:
{   The purpose of this request is to translate the summary keyword from string to summary_type.

  PROCEDURE process_summary
    (    summary_key: ost$name;
     VAR summary: summary_type);

    IF summary_key = ptc$key_first_occurrence THEN
      summary := first_occurrence;
    ELSEIF summary_key = ptc$key_last_occurrence THEN
      summary := last_occurrence;
    ELSEIF summary_key = ptc$key_count THEN
      summary := count;
    ELSEIF summary_key = ptc$key_sum THEN
      summary := sum;
    ELSEIF summary_key = ptc$key_mean THEN
      summary := mean;
    ELSEIF summary_key = ptc$key_standard_deviation THEN
      summary := standard_deviation;
    ELSEIF summary_key = ptc$key_minimum THEN
      summary := minimum;
    ELSEIF summary_key = ptc$key_maximum THEN
      summary := maximum;
    ELSEIF summary_key = ptc$key_interval THEN
      summary := interval;
    ELSEIF summary_key = ptc$key_count_per_second THEN
      summary := count_per_second;
    ELSEIF summary_key = ptc$key_sum_per_second THEN
      summary := sum_per_second;
    ELSE { summary_key = 'ELAPSED_TIME_SINCE_PREDECESSOR' }
      summary := elapsed_time_since_predecessor;
    IFEND;

  PROCEND process_summary;

?? OLDTITLE ??
?? NEWTITLE := 'process_summary_calculation', EJECT ??

{ PURPOSE:
{   The purpose of this request is to process the summary_calculation (summary and position_description) and
{ row_label parameters for the put_field_summary and change_put subcommands.
{
{ DESIGN
{   The procedure sets the summary_calculation (summary, start_column and column_width) in the report entry
{ summary vector and the row_label position.  The summary_calculation default is SUM.
{   If the procedure is called from the Change_Put subcommand, then the row_label and summary_calculation
{ parameters are optional and the procedure gets the missing position (row_label position or
{ summary_calculation position from the report entry.

  PROCEDURE process_summary_calculation
    (    summary_calculation: clt$parameter_value;
         row_label_format: clt$parameter_value;
         report_entry_p: ^put_entry;
     VAR status: ost$status);

    VAR
      column: integer,
      column_index: report_column,
      errors_detected: boolean,
      failing_status: ost$status,
      index: integer,
      initial_summary_vector: [STATIC, READ] summary_vector_type :=
            [REP ptc$summary_vector_size of [null, * , * ]],
      max_column: 0..clc$max_integer,
      used_column: report_column_set,
      value_position_p: ^clt$data_value,
      value_summary_p: ^clt$data_value;


    status.normal := TRUE;
    max_column := 0;

    IF row_label_format.value <> NIL THEN
      report_entry_p^.row_label_start_column := row_label_format.value^.field_values^ [1].value^.
            integer_value.value;
      report_entry_p^.row_label_column_width := row_label_format.value^.field_values^ [2].value^.
            integer_value.value;
    IFEND;

    column := report_entry_p^.row_label_start_column + report_entry_p^.row_label_column_width - 1;
    IF column > ptc$max_page_width THEN
      osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$field_out_of_line_limits, 'Row_Label', status);
      osp$append_status_integer (osc$status_parameter_delimiter, report_entry_p^.row_label_start_column, 10,
            FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, report_entry_p^.row_label_column_width, 10,
            FALSE, status);
      RETURN; {----->
    IFEND;
    IF column > max_column THEN
      max_column := column;
    IFEND;

    used_column := $report_column_set [];
    FOR column_index := report_entry_p^.row_label_start_column TO column DO
      used_column := used_column + $report_column_set [column_index];
    FOREND;

    IF summary_calculation.value <> NIL THEN
      report_entry_p^.summary_vector := initial_summary_vector;
      value_summary_p := summary_calculation.value;
      index := 1;
      WHILE value_summary_p <> NIL DO
        process_summary (value_summary_p^.element_value^.field_values^ [1].value^.keyword_value,
              report_entry_p^.summary_vector [index].summary);
        process_position (value_summary_p^.element_value^.field_values^ [2],
              value_summary_p^.element_value^.field_values^ [3],
              report_entry_p^.summary_vector [index].summary, counter_field, ' ', column, used_column,
              report_entry_p^.summary_vector [index].start_column,
              report_entry_p^.summary_vector [index].column_width, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF column > max_column THEN
          max_column := column;
        IFEND;
        value_summary_p := value_summary_p^.link;
        index := index + 1;
      WHILEND;
    ELSE

{ The next 3 lines execute only if the procedure was called from Change_Put command

      IF column >= report_entry_p^.summary_vector [1].start_column - 1 THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$field_overlap, 'Row_Label', status);
        osp$append_status_integer (osc$status_parameter_delimiter, report_entry_p^.row_label_start_column, 10,
              FALSE, status);
      IFEND;
    IFEND;
    report_entry_p^.max_used_column := max_column;

  PROCEND process_summary_calculation;

?? OLDTITLE ??
?? NEWTITLE := 'process_time_selection', EJECT ??

{ PURPOSE:
{   The purpose of this request is to process the time selection parameters for the add_selection and
{ change_selection subcommands.
{
{ DESIGN
{ This procedure adds the missing date or time to the start_date_time and end_date_time:
{   - start_date_time: 1900-01-01   as date
{                      00:00:00.000 as time
{   - end_date_time:   2155-12-31   as date
{                      23:59:59.999 as time
{
{  If start_date_time >= end_date_time the procedure returns an error mesage.

  PROCEDURE process_time_selection
    (    time: clt$parameter_value;
     VAR start_date_time: clt$date_time;
     VAR end_date_time: clt$date_time;
     VAR status: ost$status);

    status.normal := TRUE;

    start_date_time := time.value^.low_value^.date_time_value;
    end_date_time := time.value^.high_value^.date_time_value;
    IF NOT start_date_time.date_specified THEN
      start_date_time.value.year := 0; { 1900 }
      start_date_time.value.month := 1;
      start_date_time.value.day := 1;
    IFEND;
    IF NOT start_date_time.time_specified THEN
      start_date_time.value.hour := 0;
      start_date_time.value.minute := 0;
      start_date_time.value.second := 0;
      start_date_time.value.millisecond := 0;
    IFEND;
    IF NOT end_date_time.date_specified THEN
      end_date_time.value.year := 255; { 2155 }
      end_date_time.value.month := 12;
      end_date_time.value.day := 31;
    IFEND;
    IF NOT end_date_time.time_specified THEN
      end_date_time.value.hour := 23;
      end_date_time.value.minute := 59;
      end_date_time.value.second := 59;
      end_date_time.value.millisecond := 999;
    IFEND;

    IF NOT date_time_1_gt_date_time_2 (end_date_time.value, start_date_time.value) THEN
      osp$set_status_condition (pte$date_time_range_order, status);
      RETURN; {----->
    IFEND;

  PROCEND process_time_selection;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] put_statistic_record', EJECT ??

{ PURPOSE:
{  The purpose of this request is to "write" a statistic record to a binary log file.
{
{ DESIGN:
{  The procedure gets 3 pointers:
{    -  pointer to the statistic header.
{    -  pointer to the counters array.
{    -  pointer to the descriptive data string.
{  The procedure performs those steps to write the statistic:
{    1) Use NEXT to allocate the record header and fill the record header with header type, record length,
{       previous header file byte address and unique ID.
{    2) Use NEXT to allocate statistic header and copy the statistic header to output file.
{    3) IF number_of_counters > 0 THEN use NEXT to allocate counter array and copy the counters to output
{       file.
{    4) IF descriptive_data_size > 0 THEN use NEXT to allocate descriptive_data and copy the descriptive_data
{       to output file.
{    5) set the ptv$end_of_segment to end of the segment.

  PROCEDURE [INLINE] put_statistic_record
    (    output_log_p: ^log_file;
         statistic_header_p: ^sft$statistic_header;
         counters_p: sft$counters;
         descriptive_data_p: ^sft$descriptive_data;
     VAR status: ost$status);

    VAR
      counters_out_p: sft$counters,
      descriptive_data_out_p: ^sft$descriptive_data,
      log_header_out_p: ^bat$record_header,
      statistic_header_out_p: ^sft$statistic_header;

    status.normal := TRUE;

    NEXT log_header_out_p IN output_log_p^.segment_pointer.sequence_pointer;
    IF log_header_out_p = NIL THEN
      osp$set_status_condition (pte$unexpected_end_of_file, status);
      osp$append_status_file (osc$status_parameter_delimiter, output_log_p^.log_file_name, status);
      RETURN; {----->
    IFEND;
    log_header_out_p^.header_type := bac$full_record;
    log_header_out_p^.length := ptv$statistic_header_size + statistic_header_p^.number_of_counters *
          #SIZE (sft$counter) + statistic_header_p^.descriptive_data_size;
    log_header_out_p^.previous_header_fba := ptv$previous_header_fba;
    log_header_out_p^.unique_id := bac$record_header_unique_id;
    ptv$previous_header_fba := #OFFSET (log_header_out_p);

    NEXT statistic_header_out_p IN output_log_p^.segment_pointer.sequence_pointer;
    IF statistic_header_p = NIL THEN
      osp$set_status_condition (pte$unexpected_end_of_file, status);
      osp$append_status_file (osc$status_parameter_delimiter, output_log_p^.log_file_name, status);
      RETURN; {----->
    IFEND;
    statistic_header_out_p^ := statistic_header_p^;

    IF statistic_header_p^.number_of_counters > 0 THEN
      NEXT counters_out_p: [1 .. statistic_header_p^.number_of_counters] IN
            output_log_p^.segment_pointer.sequence_pointer;
      IF counters_out_p = NIL THEN
        osp$set_status_condition (pte$unexpected_end_of_file, status);
        osp$append_status_file (osc$status_parameter_delimiter, output_log_p^.log_file_name, status);
        RETURN; {----->
      IFEND;
      counters_out_p^ := counters_p^;
    IFEND;

    IF statistic_header_p^.descriptive_data_size > 0 THEN
      NEXT descriptive_data_out_p: [statistic_header_p^.descriptive_data_size] IN
            output_log_p^.segment_pointer.sequence_pointer;
      IF descriptive_data_out_p = NIL THEN
        osp$set_status_condition (pte$unexpected_end_of_file, status);
        osp$append_status_file (osc$status_parameter_delimiter, output_log_p^.log_file_name, status);
        RETURN; {----->
      IFEND;
      descriptive_data_out_p^ := descriptive_data_p^;
    IFEND;
    ptv$end_of_segment := output_log_p^.segment_pointer;

  PROCEND put_statistic_record;

?? OLDTITLE ??
?? NEWTITLE := 'put_statistic_in_scratch_seg', EJECT ??

{ PURPOSE:
{   The purpose of this request is to "write" a shadowed predecessor statistic record from active log to
{ temporary binary log file.
{
{ DESIGN:
{  The procedure gets 3 pointers:
{    -  pointer to the statistic header.
{    -  pointer to the counters array.
{    -  pointer to the descriptive data string.
{  The procedure performs the following steps to write the statistic:
{    1) Use NEXT to allocate record header and fill the record header with header type, record length,
{       previous header file byte address and unique ID.
{    2) Use NEXT to allocate statistic header and copy the statistic header to output file.
{    3) IF number_of_counters > 0 THEN use NEXT to allocate counter array and copy the counters to output
{       file.
{    4) IF descriptive_data_size > 0 THEN use NEXT to allocate descriptive_data and copy the descriptive_data
{       to output file.
{
{  The procedure returns 3 pointers:
{    -  pointer to the statistic header in the temporary log.
{    -  pointer to the counters array in the temporary log.
{    -  pointer to the descriptive data string in the temporary log.

  PROCEDURE put_statistic_in_scratch_seg
    (    statistic_header_p: ^sft$statistic_header;
         counters_p: sft$counters;
         descriptive_data_p: ^sft$descriptive_data;
     VAR statistic_header_out_p: ^sft$statistic_header;
     VAR counters_out_p: sft$counters;
     VAR descriptive_data_out_p: ^sft$descriptive_data;
     VAR status: ost$status);

    VAR
      log_header_out_p: ^bat$record_header;

    status.normal := TRUE;

    NEXT log_header_out_p IN ptv$predecessor_log_p.sequence_pointer;
    IF log_header_out_p = NIL THEN
      osp$set_status_condition (pte$scratch_segment_error, status);
      RETURN; {----->
    IFEND;
    log_header_out_p^.header_type := bac$full_record;
    log_header_out_p^.length := ptv$statistic_header_size + statistic_header_p^.number_of_counters *
          #SIZE (sft$counter) + statistic_header_p^.descriptive_data_size;
    log_header_out_p^.previous_header_fba := ptv$previous_header_fba;
    log_header_out_p^.unique_id := bac$record_header_unique_id;
    ptv$previous_header_fba := #OFFSET (log_header_out_p);

    NEXT statistic_header_out_p IN ptv$predecessor_log_p.sequence_pointer;
    IF statistic_header_p = NIL THEN
      osp$set_status_condition (pte$scratch_segment_error, status);
      RETURN; {----->
    IFEND;
    statistic_header_out_p^ := statistic_header_p^;

    IF statistic_header_p^.number_of_counters > 0 THEN
      NEXT counters_out_p: [1 .. statistic_header_p^.number_of_counters] IN
            ptv$predecessor_log_p.sequence_pointer;
      IF counters_out_p = NIL THEN
        osp$set_status_condition (pte$scratch_segment_error, status);
        RETURN; {----->
      IFEND;
      counters_out_p^ := counters_p^;
    ELSE
      counters_out_p := NIL;
    IFEND;

    IF statistic_header_p^.descriptive_data_size > 0 THEN
      NEXT descriptive_data_out_p: [statistic_header_p^.descriptive_data_size] IN
            ptv$predecessor_log_p.sequence_pointer;
      IF descriptive_data_out_p = NIL THEN
        osp$set_status_condition (pte$scratch_segment_error, status);
        RETURN; {----->
      IFEND;
      descriptive_data_out_p^ := descriptive_data_p^;
    ELSE
      descriptive_data_out_p := NIL;
    IFEND;

  PROCEND put_statistic_in_scratch_seg;

?? OLDTITLE ??
?? NEWTITLE := 'report_duplicate_name', EJECT ??

{ PURPOSE:
{ The purpose of this request is to check for and report duplicate names or file names in the parameter list.

  PROCEDURE report_duplicate_name
    (    value: ^clt$data_value;
         parameter: string ( * <= osc$max_name_size);
     VAR status: ost$status);

    VAR
      errors_detected: boolean,
      failing_status: ost$status,
      value_1_p: ^clt$data_value,
      value_2_p: ^clt$data_value;

    status.normal := TRUE;

{ Check for duplicate name in the list.

    errors_detected := FALSE;
    value_1_p := value;
    WHILE value_1_p <> NIL DO
      value_2_p := value_1_p^.link;
      WHILE value_2_p <> NIL DO
        CASE value_1_p^.element_value^.kind OF

        = clc$name =
          IF value_1_p^.element_value^.name_value = value_2_p^.element_value^.name_value THEN
            osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$duplicate_name,
                  value_1_p^.element_value^.name_value, failing_status);
            report_intermediate_error (failing_status, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            errors_detected := TRUE;
          IFEND;

        = clc$file =
          IF value_1_p^.element_value^.file_value^ = value_2_p^.element_value^.file_value^ THEN
            osp$set_status_condition (pte$duplicate_file_name, failing_status);
            osp$append_status_file (osc$status_parameter_delimiter, value_1_p^.element_value^.file_value^,
                  failing_status);
            report_intermediate_error (failing_status, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            errors_detected := TRUE;
          IFEND;
        ELSE
        CASEND;
        value_2_p := value_2_p^.link;
      WHILEND;
      value_1_p := value_1_p^.link;
    WHILEND;

    IF errors_detected THEN
      osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, parameter, status);
    IFEND;

  PROCEND report_duplicate_name;

?? OLDTITLE ??
?? NEWTITLE := 'report_duplicate_number', EJECT ??

{ PURPOSE:
{   The purpose of this request is to check for and report duplicate numbers in the parameter list.
{
{ DESIGN:
{   The procedure receives a pointer to a list of range of numbers, puts the numbers in a set and checks if
{ any number was given more than once.
{
{ NOTE:
{ - Set of integer is limited to numbers in the range 0..32767.
{ - The set is allocated in the subcommand procedure in order to save an allocation when the the number
{   parameter is checked more than once.

  PROCEDURE report_duplicate_number
    (    value: ^clt$data_value;
         parameter: string ( * <= osc$max_name_size);
     VAR numbers: ^numbers_set;
     VAR status: ost$status);

    VAR
      errors_detected: boolean,
      failing_status: ost$status,
      index: integer,
      index_string: ost$string,
      value_p: ^clt$data_value;

    status.normal := TRUE;

{ Check for duplicate number in the list.

    errors_detected := FALSE;
    numbers^ := $numbers_set [];
    value_p := value;
    WHILE value_p <> NIL DO
      IF value_p^.element_value^.low_value^.integer_value.value <=
            value_p^.element_value^.high_value^.integer_value.value THEN
        FOR index := value_p^.element_value^.low_value^.integer_value.value TO value_p^.element_value^.
              high_value^.integer_value.value DO
          IF NOT (index IN numbers^) THEN
            numbers^ := numbers^ +$numbers_set [index];
          ELSE
            clp$convert_integer_to_string (index, 10, FALSE, index_string, status);
            osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$duplicate_numbers, index_string.
                  value (1, index_string.size), failing_status);
            report_intermediate_error (failing_status, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            errors_detected := TRUE;
          IFEND;
        FOREND;
      ELSE
        STRINGREP (ptv$output_line, ptv$output_line_length,
              value_p^.element_value^.low_value^.integer_value.value, ' ..',
              value_p^.element_value^.high_value^.integer_value.value);
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$low_greater_than_high,
              ptv$output_line (1, ptv$output_line_length), failing_status);
        report_intermediate_error (failing_status, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        errors_detected := TRUE;
      IFEND;

      value_p := value_p^.link;
    WHILEND;

    IF errors_detected THEN
      osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, parameter, status);
    IFEND;

  PROCEND report_duplicate_number;

?? OLDTITLE ??
?? NEWTITLE := 'report_fields_and_put', EJECT ??

{ PURPOSE:
{   The purpose of this request is to check and report selection(s) with field(s) and/or put(s) for
{ delete_selection subcommand.
{
{ DESIGN:
{   The value parameter is a pointer to the selection names list or the keyword ALL.  The procedure checks the
{ selection(s) in the list (or all the selections).  If a selection has field(s) and/or put entries the
{ procedure reports an intermediate error job_command_response file and continues to check the next selection.
{ The procedure returns a status error if an intermediate error was reported.
{
{ NOTE:
{   Analyze_Binary_Log can't delete a selection with field(s) and/or put entries.  The user must delete or
{ change the field(s) and/or put entries before deleting the selection.

  PROCEDURE report_fields_and_put
    (    value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      errors_detected: boolean,
      selection_p: ^selection,
      value_p: ^clt$data_value;

    status.normal := TRUE;

    errors_detected := FALSE;
    value_p := value;
    IF value_p^.kind = clc$keyword THEN

{ Only keyword is 'ALL'
      selection_p := ptv$selection_chain_head_p;
      WHILE selection_p <> NIL DO
        check_fields_and_put_pointers (selection_p, errors_detected, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        selection_p := selection_p^.selection_chain_link_p;
      WHILEND;
    ELSE

{ LIST

      WHILE value_p <> NIL DO
        selection_p := ptv$selection_chain_head_p;
        WHILE (selection_p <> NIL) AND (selection_p^.name <> value_p^.element_value^.name_value) DO
          selection_p := selection_p^.selection_chain_link_p;
        WHILEND;
        IF selection_p <> NIL THEN
          check_fields_and_put_pointers (selection_p, errors_detected, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;
        value_p := value_p^.link;
      WHILEND;
    IFEND;

    IF errors_detected THEN
      osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, 'SELECTION',
            status);
    IFEND;

  PROCEND report_fields_and_put;

?? OLDTITLE ??
?? NEWTITLE := 'report_intermediate_error', EJECT ??

{ PURPOSE:
{   The purpose of this request is to report an intermediate error which has occurred during some process.
{
{ DESIGN:
{   The procedure gets a status record describing some intermediate error as a parameter and writes the error
{ text to the job_command_response file.

  PROCEDURE report_intermediate_error
    (    failing_status: ost$status;
     VAR status: ost$status);

    VAR
      access_selections: [STATIC, READ] array [1 .. 2] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes, [fsc$shorten, fsc$append]],
            [fsc$required_share_modes]], [fsc$access_and_share_modes,
            [fsc$specific_access_modes, [fsc$append]], [fsc$required_share_modes]]],
      byte_address: amt$file_byte_address,
      errors_file_id: amt$file_identifier,
      length_pointer: ^ost$status_message_line_size,
      line_count_pointer: ^ost$status_message_line_count,
      line_index: ost$status_message_line_count,
      message: ost$status_message,
      message_sequence: ^ost$status_message,
      text_pointer: ^ost$status_message_line;

    status.normal := TRUE;

    fsp$open_file (clc$job_command_response, amc$record, {attachment options=} ^access_selections,
          {Default_creation=} NIL, {Mandated_creation=} NIL, {Attirbute_validation=} NIL,
          {Attribute_override=} NIL, errors_file_id, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    osp$format_message (failing_status, osc$full_message_level, osc$max_status_message_line, message, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    message_sequence := ^message;
    RESET message_sequence;
    NEXT line_count_pointer IN message_sequence;

    FOR line_index := 1 TO line_count_pointer^ DO
      NEXT length_pointer IN message_sequence;
      NEXT text_pointer: [length_pointer^] IN message_sequence;
      amp$put_next (errors_file_id, text_pointer, length_pointer^, byte_address, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    FOREND;

    fsp$close_file (errors_file_id, status);

    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

  PROCEND report_intermediate_error;

?? OLDTITLE ??
?? NEWTITLE := 'report_put', EJECT ??

{ PURPOSE:
{   The purpose of this request is to check and report field(s) with put entries for delete_field subcommand.
{
{ DESIGN:
{   The value parameter is a pointer to the field names list or the keyword ALL.  The procedure checks the
{ field(s) in the list (or all the fields), if a field has a put entry the procedure reports an intermediate
{ error to job_command_response file and continues to check the next field.  The procedure returns a status
{ error if an intermediate error was reported.
{
{ NOTE:
{    Analyze_Binary_Log can't delete a field with a put entry.  The user must delete or change the put entries
{  before deleting the field.

  PROCEDURE report_put
    (    value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      errors_detected: boolean,
      failing_status: ost$status,
      field_p: ^field,
      selection_p: ^selection,
      value_p: ^clt$data_value;


    status.normal := TRUE;

    errors_detected := FALSE;
    value_p := value;
    IF value_p^.kind = clc$keyword THEN

{ Only keyword is 'ALL'

      selection_p := ptv$selection_chain_head_p;
      WHILE selection_p <> NIL DO

        field_p := selection_p^.field_chain_p;
        WHILE field_p <> NIL DO
          IF field_p^.report_list_p <> NIL THEN
            osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$field_has_put, field_p^.field_name,
                  failing_status);
            report_intermediate_error (failing_status, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            errors_detected := TRUE;
          IFEND;
          field_p := field_p^.field_chain_link_p;
        WHILEND;

        selection_p := selection_p^.selection_chain_link_p;
      WHILEND;
    ELSE

{ LIST

      WHILE value_p <> NIL DO
        selection_p := ptv$selection_chain_head_p;

      /find_field/
        WHILE selection_p <> NIL DO

          field_p := selection_p^.field_chain_p;
          WHILE (field_p <> NIL) AND (field_p^.field_name <> value_p^.element_value^.name_value) DO
            field_p := field_p^.field_chain_link_p;
          WHILEND;

          IF field_p <> NIL THEN
            IF field_p^.report_list_p <> NIL THEN
              osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$field_has_put, field_p^.field_name,
                    failing_status);
              report_intermediate_error (failing_status, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
              errors_detected := TRUE;
            IFEND;
            EXIT /find_field/; {----->
          IFEND;

          selection_p := selection_p^.selection_chain_link_p;
        WHILEND /find_field/;

        value_p := value_p^.link;
      WHILEND;
    IFEND;

    IF errors_detected THEN
      osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, 'FIELD', status);
    IFEND;

  PROCEND report_put;

?? OLDTITLE ??
?? NEWTITLE := 'report_undefined_counters', EJECT ??

{ PURPOSE:
{    The purpose of this request is to check and report undefined counter names in the parameter list for
{  put_field_summary and change_put (field_summary entry type) subcommands.
{
{ DESIGN:
{   The value parameter is a pointer to the field names list.  The procedure checks for each name in the list
{ for a defined counter with that name.  If the counter is undefined the procedure reports an intermediate
{ error to job_command_response file and continues to check the next field name.  The procedure returns a
{ status error if an intermediate error was reported.

  PROCEDURE report_undefined_counters
    (    value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      errors_detected: boolean,
      failing_status: ost$status,
      field_name: ost$name,
      field_p: ^field,
      selection_p: ^selection,
      value_p: ^clt$data_value;

    status.normal := TRUE;

    errors_detected := FALSE;
    value_p := value;
    WHILE value_p <> NIL DO

      field_p := NIL;
      selection_p := ptv$selection_chain_head_p;
      WHILE (selection_p <> NIL) AND (field_p = NIL) DO
        field_p := selection_p^.field_chain_p;
        WHILE (field_p <> NIL) AND (field_p^.field_name <> value_p^.element_value^.field_values^ [1].value^.
              name_value) DO
          field_p := field_p^.field_chain_link_p;
        WHILEND;
        selection_p := selection_p^.selection_chain_link_p;
      WHILEND;

      IF (field_p = NIL) OR (field_p^.field_type <> counter_field) THEN
        IF field_p = NIL THEN
          osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$undefined_field_for_put,
                value_p^.element_value^.field_values^ [1].value^.name_value, failing_status);
        ELSE { field_^.field_type <> counter_field }
          osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$field_is_not_a_counter,
                value_p^.element_value^.field_values^ [1].value^.name_value, failing_status);
        IFEND;
        report_intermediate_error (failing_status, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        errors_detected := TRUE;
      IFEND;

      value_p := value_p^.link;
    WHILEND;

    IF errors_detected THEN
      osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, 'FIELD', status);
    IFEND;

  PROCEND report_undefined_counters;

?? OLDTITLE ??
?? NEWTITLE := 'report_undefined_fields', EJECT ??

{ PURPOSE:
{    The purpose of this request is to check for and report undefined field names in the parameter list for
{  put_field,put_interval_field and change_put (field and interval_field entries type) subcommands.
{
{ DESIGN:
{   The value parameter is a pointer to the field names list.  The procedure checks each name in the list
{ to find a defined field (counter, descriptive_data or statistic_header) with that name.  If the field is
{ undefined the procedure reports an intermediate error to job_command_response file and continues to check
{ the next field name.  The procedure returns a status error if an intermediate error is reported.

  PROCEDURE report_undefined_fields
    (    value: ^clt$data_value;
     VAR status: ost$status);

    VAR
      errors_detected: boolean,
      failing_status: ost$status,
      field_name: ost$name,
      field_p: ^field,
      selection_p: ^selection,
      value_p: ^clt$data_value;

    status.normal := TRUE;

    errors_detected := FALSE;
    field_p := NIL;
    value_p := value;
    WHILE value_p <> NIL DO

      selection_p := ptv$selection_chain_head_p;

    /find_field/
      WHILE selection_p <> NIL DO

        field_p := selection_p^.field_chain_p;
        WHILE (field_p <> NIL) AND (field_p^.field_name <> value_p^.element_value^.field_values^ [1].value^.
              name_value) DO
          field_p := field_p^.field_chain_link_p;
        WHILEND;

        IF field_p <> NIL THEN
          EXIT /find_field/; {----->
        IFEND;

        selection_p := selection_p^.selection_chain_link_p;
      WHILEND /find_field/;

      IF field_p = NIL THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$undefined_field_for_put,
              value_p^.element_value^.field_values^ [1].value^.name_value, failing_status);
        report_intermediate_error (failing_status, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        errors_detected := TRUE;
      IFEND;

      value_p := value_p^.link;
    WHILEND;

    IF errors_detected THEN
      osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, 'FIELD', status);
    IFEND;

  PROCEND report_undefined_fields;

?? OLDTITLE ??
?? NEWTITLE := 'report_undefined_selections', EJECT ??

{ PURPOSE:
{    The purpose of this request is to check and report undefined selection names in the parameter list for
{  put_record and change_put (record entry type) subcommands.
{
{ DESIGN:
{   The value parameter is a pointer to the selection names list.  The procedure checks each name in the
{ list for a defined selection with that name.  If the selection is undefined the procedure reports an
{ intermediate error to job_command_response file and continues to check the next selection name.  The
{ procedure returns a status error if an intermediate error is reported.

  PROCEDURE report_undefined_selections
    (    value: ^clt$data_value;
         log_entry_p: ^put_entry;
     VAR status: ost$status);

    VAR
      errors_detected: boolean,
      failing_status: ost$status,
      selection_p: ^selection,
      value_p: ^clt$data_value;

    status.normal := TRUE;

    errors_detected := FALSE;
    value_p := value;
    WHILE value_p <> NIL DO
      selection_p := ptv$selection_chain_head_p;
      WHILE (selection_p <> NIL) AND (selection_p^.name <> value_p^.element_value^.name_value) DO
        selection_p := selection_p^.selection_chain_link_p;
      WHILEND;
      IF selection_p = NIL THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$undefined_selec_for_put,
              value_p^.element_value^.name_value, failing_status);
        report_intermediate_error (failing_status, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        errors_detected := TRUE;
      ELSEIF (selection_p^.log_entry_p <> NIL) AND (selection_p^.log_entry_p <> log_entry_p) THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$selec_ref_by_another_put,
              value_p^.element_value^.name_value, failing_status);
        report_intermediate_error (failing_status, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        errors_detected := TRUE;
      IFEND;
      value_p := value_p^.link;
    WHILEND;

    IF errors_detected THEN
      osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, 'SELECTION',
            status);
    IFEND;

  PROCEND report_undefined_selections;

?? OLDTITLE ??
?? NEWTITLE := 'reset_data_collection', EJECT ??

{ PURPOSE:
{   The purpose of this request is to reset the data collection before scanning the log(s) and collecting new
{ data.
{
{ DESIGN:
{   The procedure:
{     Frees:
{       - Successor lists.
{       - Date_time values.
{       - Predecessor date_time values.
{       - Field values.
{     Resets:
{       - Date_time collection.
{       - Predecessor date_time collection.
{       - Marking selections for shadow_fields.
{     Deletes:
{       - Shadow fields.

  PROCEDURE reset_data_collection;

    VAR
      field_p: ^field,
      index: integer,
      report_entry_p: ^put_entry,
      report_list_p: ^report_list,
      selection_p: ^selection;

    RESET ptv$data_segment_p.sequence_pointer;

    selection_p := ptv$selection_chain_head_p;
    WHILE selection_p <> NIL DO

      selection_p^.successor_list_head_p := NIL;
      selection_p^.date_time_value_head_p := NIL;
      selection_p^.date_time_value_tail_p := NIL;
      selection_p^.predecessor_dt_value_head_p := NIL;
      selection_p^.predecessor_dt_value_tail_p := NIL;
      selection_p^.shadow_field_chain_p := NIL;
      selection_p^.collect_date_time := FALSE;
      selection_p^.collect_predecessor_date_time := FALSE;
      selection_p^.shadow_fields := FALSE;

      field_p := selection_p^.field_chain_p;
      WHILE field_p <> NIL DO

        free_field_value (field_p);

        report_list_p := field_p^.report_list_p;
        WHILE report_list_p <> NIL DO
          report_list_p^.shadow := FALSE;
          report_list_p := report_list_p^.link_p;
        WHILEND;

        field_p := field_p^.field_chain_link_p;
      WHILEND;

      selection_p := selection_p^.selection_chain_link_p;
    WHILEND;

    report_entry_p := ptv$report_entry_chain_head_p;
    WHILE report_entry_p <> NIL DO
      IF report_entry_p^.put = put_field THEN
        FOR index := LOWERBOUND (field_vector_type) TO UPPERBOUND (field_vector_type) DO
          report_entry_p^.field_vector [index].shadow_field := FALSE;
          report_entry_p^.field_vector [index].shadow_field_p := NIL;
        FOREND;
      IFEND;
      report_entry_p := report_entry_p^.put_chain_link_p;
    WHILEND;

  PROCEND reset_data_collection;

?? OLDTITLE ??
?? NEWTITLE := 'scan_log_disls', EJECT ??

{ PURPOSE:
{  The purpose of this request is to scan the log for the display_logged_statistics subcommand.
{
{ DESIGN:
{   The procedure resets the segment log (rewinds the file for active log). It receives statistic records from
{ the log and generates a list of unique statistic codes in the log.  The procedure keeps the number of
{ occurrences of each statistic code, the time of first and last occurrences of each statistic code.
{
{ NOTE:
{   Display_logged_statistics scans an active log at every DISLS, but only needs to actually scan non_active
{   logs on the first DISLS.

  PROCEDURE scan_log_disls
    (    input_log_p: ^log_file;
     VAR status: ost$status);

    VAR
      counters_p: sft$counters,
      descriptive_data_p: ^sft$descriptive_data,
      logged_statistic_p: ^logged_statistic,
      p_logged_statistic_tail: ^logged_statistic,
      statistic_header_p: ^sft$statistic_header,
      statistic_location_p: ^statistic_location;

    status.normal := TRUE;

    lgp$rewind_log_file (input_log_p^.log_file_identifier, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    lgp$get_next_statistic (input_log_p^.log_file_identifier, ^ptv$statistic_record_buffer,
          statistic_header_p, counters_p, descriptive_data_p, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    WHILE statistic_header_p <> NIL DO
      logged_statistic_p := input_log_p^.statistics_list_p;
      WHILE (logged_statistic_p <> NIL) AND (statistic_header_p^.statistic_code <>
            logged_statistic_p^.statistic_code) DO
        p_logged_statistic_tail := logged_statistic_p;
        logged_statistic_p := logged_statistic_p^.link_p;
      WHILEND;
      IF logged_statistic_p = NIL THEN { New statistic code. }
        IF input_log_p^.statistics_list_p = NIL THEN { First statistic code. }
          ALLOCATE input_log_p^.statistics_list_p;
          logged_statistic_p := input_log_p^.statistics_list_p;
        ELSE
          logged_statistic_p := p_logged_statistic_tail;
          ALLOCATE logged_statistic_p^.link_p;
          logged_statistic_p := logged_statistic_p^.link_p;
        IFEND;
        logged_statistic_p^.statistic_code := statistic_header_p^.statistic_code;
        logged_statistic_p^.link_p := NIL;
        logged_statistic_p^.number_of_occurrences := 0;
        logged_statistic_p^.time_of_first_occurrences := statistic_header_p^.date_time;
        logged_statistic_p^.statistic_location_p := NIL;

      IFEND;
      logged_statistic_p^.number_of_occurrences := logged_statistic_p^.number_of_occurrences + 1;
      logged_statistic_p^.time_of_last_occurrences := statistic_header_p^.date_time;

      lgp$get_next_statistic (input_log_p^.log_file_identifier, ^ptv$statistic_record_buffer,
            statistic_header_p, counters_p, descriptive_data_p, status);
      IF NOT status.normal THEN
        IF status.condition = lge$end_of_log THEN
          status.normal := TRUE;
        IFEND;
        RETURN; {----->
      IFEND;
    WHILEND;
  PROCEND scan_log_disls;

?? OLDTITLE ??
?? NEWTITLE := 'scan_log_genl', EJECT ??

{ PURPOSE:
{  The purpose of this request is to scan the log for the generate_log subcommand.
{
{ DESIGN:
{   The procedure resets the segment log (rewinds the file for active log).  It receives statistic records
{ from the log and for every selection the procedure checks if the statistic record is selected.  If the
{ statistic is selected, the procedure calls add_statistic_to_successor_list.  If the selection has a log
{ entry and the statistic was not written to the output log by previous selection the procedure calls
{ write_statistic.
{
{ NOTE:
{   - The procedure write_statistic is write_statistic_to_Binary_log, write_statistic_to_list_log or
{     write_statistic_to_legible_log  depending on the type of output log (Binary/List/Legible).
{   - A selection can be selected by more than one selection but only the first selection that matches the
{     statistic and has a log entry will write the statistic into the output log.  The rest of the selections
{     may be for successor list.

  PROCEDURE scan_log_genl
    (    input_log_p: ^log_file;
         write_statistic: write_statistic_p;
     VAR status: ost$status);

    VAR
      print: boolean,
      counters_p: sft$counters,
      descriptive_data_p: ^sft$descriptive_data,
      predecessor_p: ^successor,
      statistic_header_p: ^sft$statistic_header,
      selection_p: ^selection;

    status.normal := TRUE;

    lgp$rewind_log_file (input_log_p^.log_file_identifier, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    lgp$get_next_statistic (input_log_p^.log_file_identifier, ^ptv$statistic_record_buffer,
          statistic_header_p, counters_p, descriptive_data_p, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    WHILE statistic_header_p <> NIL DO
      print := TRUE;
      selection_p := ptv$selection_chain_head_p;
      WHILE selection_p <> NIL DO
        IF select_statistic (selection_p, statistic_header_p, counters_p, descriptive_data_p, predecessor_p)
              THEN
          add_statistic_to_successor_list (selection_p, statistic_header_p, counters_p, descriptive_data_p,
                predecessor_p);
          IF print AND (selection_p^.log_entry_p <> NIL) THEN
            write_statistic^ (selection_p^.log_entry_p, statistic_header_p, counters_p, descriptive_data_p,
                  status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            print := FALSE;
          IFEND;
        IFEND;
        selection_p := selection_p^.selection_chain_link_p;
      WHILEND;
      lgp$get_next_statistic (input_log_p^.log_file_identifier, ^ptv$statistic_record_buffer,
            statistic_header_p, counters_p, descriptive_data_p, status);
      IF NOT status.normal THEN
        IF status.condition = lge$end_of_log THEN
          status.normal := TRUE;
        IFEND;
        RETURN; {----->
      IFEND;
    WHILEND;

  PROCEND scan_log_genl;

?? OLDTITLE ??
?? NEWTITLE := 'scan_log_genr', EJECT ??

{ PURPOSE:
{  The purpose of this request is to scan the log for the generate_report subcommand.
{
{ DESIGN:
{   The procedure resets the segment log (rewinds the file for active log). It receives statistic records from
{ the log and for each SELECTION the procedure checks if the statistic record matches the selection criteria.
{ If the statistic is selected the procedure calls add_statistic_to_successor_list and collect_field.
{
{ NOTE:
{   - A selection can be selected by more than one selection.

  PROCEDURE scan_log_genr
    (    input_log_p: ^log_file;
     VAR status: ost$status);

    VAR
      counters_p: sft$counters,
      descriptive_data_p: ^sft$descriptive_data,
      new_counters_p: sft$counters,
      new_descriptive_data_p: ^sft$descriptive_data,
      new_statistic_header_p: ^sft$statistic_header,
      predecessor_p: ^successor,
      selection_p: ^selection,
      statistic_header_p: ^sft$statistic_header,
      statistic_saved: boolean;

    status.normal := TRUE;

    lgp$rewind_log_file (input_log_p^.log_file_identifier, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    lgp$get_next_statistic (input_log_p^.log_file_identifier, ^ptv$statistic_record_buffer,
          statistic_header_p, counters_p, descriptive_data_p, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    WHILE statistic_header_p <> NIL DO
      statistic_saved := FALSE;
      selection_p := ptv$selection_chain_head_p;
      WHILE selection_p <> NIL DO
        IF select_statistic (selection_p, statistic_header_p, counters_p, descriptive_data_p, predecessor_p)
              THEN

          IF selection_p^.shadow_fields AND (input_log_p^.access_level = amc$record) AND
                NOT statistic_saved THEN
            put_statistic_in_scratch_seg (statistic_header_p, counters_p,
                  descriptive_data_p, new_statistic_header_p, new_counters_p, new_descriptive_data_p, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            statistic_saved := TRUE;
          IFEND;

          IF selection_p^.shadow_fields AND statistic_saved THEN
            add_statistic_to_successor_list (selection_p, new_statistic_header_p, new_counters_p,
                  new_descriptive_data_p, predecessor_p);
          ELSE
            add_statistic_to_successor_list (selection_p, statistic_header_p, counters_p, descriptive_data_p,
                  predecessor_p);
          IFEND;

          collect_field (selection_p, statistic_header_p, counters_p, descriptive_data_p, predecessor_p,
                status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

        IFEND;
        selection_p := selection_p^.selection_chain_link_p;
      WHILEND;
      lgp$get_next_statistic (input_log_p^.log_file_identifier, ^ptv$statistic_record_buffer,
            statistic_header_p, counters_p, descriptive_data_p, status);
      IF NOT status.normal THEN
        IF status.condition = lge$end_of_log THEN
          status.normal := TRUE;
        IFEND;
        RETURN; {----->
      IFEND;
    WHILEND;

  PROCEND scan_log_genr;

?? OLDTITLE ??
?? NEWTITLE := '[UNSAFE, INLINE] select_statistic', EJECT ??

{ PURPOSE:
{   The purpose of this request is to attempt to select a statistic by matching selection criteria in a
{ selection record with the statistic's attributes.
{
{ DESIGN:
{   The function checks if a selection criteria is specified and if it matches the corresponding statistic
{ attribute.  The function checks the statistic code, data_time , system job name, global task ID, job
{ predecessor, task predecessor and descriptive data.  The function checks the criteria until all the
{ specified criteria are satisfied or until one criterion is not satisfied.  If all criteria are satisfied,
{ the statistic is selected.  If one of the specified selection criteria is not satisfied, the statistic is
{ not selected.

  FUNCTION [UNSAFE, INLINE] select_statistic
    (    selection_p: ^selection;
         statistic_header_p: ^sft$statistic_header;
         counters_p: sft$counters;
         descriptive_data_p: ^sft$descriptive_data;
     VAR predecessor_p: ^successor): boolean;

    VAR
      date_time_c: ^cell,
      date_time_s_1: ^string (ptc$date_time_record_size),
      date_time_s_2: ^string (ptc$date_time_record_size),
      date_time_s_3: ^string (ptc$date_time_record_size),
      descriptive_data_length: integer,
      descriptive_data_start: integer,
      dt: integer,
      null_subfield: boolean,
      string_p: ^descriptive_data_string,
      subfield_p: ^descriptive_data_subfield,
      substring_found: boolean,
      successor_p: ^successor;

    select_statistic := FALSE;
    predecessor_p := NIL;

{ check statistic_code

    IF selection_p^.statistic_specified AND (statistic_header_p^.statistic_code <>
          selection_p^.statistic_code) THEN
      RETURN; {----->
    IFEND;

{ check date_time

    IF selection_p^.date_time_specified THEN

{ Compare Date_Time mapped to string, because the comparison operators (>, <, >= & <=) cannot compare
{ date_time records. The alternative is to compare the fields individually.

      date_time_c := ^statistic_header_p^.date_time;
      date_time_s_1 := date_time_c;
      date_time_c := ^selection_p^.start_date_time;
      date_time_s_2 := date_time_c;
      date_time_c := ^selection_p^.end_date_time;
      date_time_s_3 := date_time_c;
      IF (date_time_s_1^ <= date_time_s_2^) OR (date_time_s_1^ >= date_time_s_3^) THEN
        RETURN; {----->
      IFEND;
      IF NOT selection_p^.continuous_date_time THEN
        dt := statistic_header_p^.date_time.hour * 3600000 + statistic_header_p^.date_time.minute *
              60000 + statistic_header_p^.date_time.second * 1000 + statistic_header_p^.date_time.millisecond;
        IF (dt <= (selection_p^.start_date_time.hour * 3600000 + selection_p^.start_date_time.minute *
              60000 + selection_p^.start_date_time.second * 1000 +
              selection_p^.start_date_time.millisecond)) OR (dt >=
              (selection_p^.end_date_time.hour * 3600000 + selection_p^.end_date_time.minute *
              60000 + selection_p^.end_date_time.second * 1000 + selection_p^.end_date_time.millisecond)) THEN

          RETURN; {----->
        IFEND;
      IFEND;
    IFEND;

{ check Descriptive data

    IF selection_p^.descriptive_specified THEN

      subfield_p := selection_p^.descriptive_subfield_p;
      WHILE subfield_p <> NIL DO
        IF descriptive_data_p <> NIL THEN
          get_descriptive_data_subfield (descriptive_data_p, statistic_header_p^.descriptive_data_size,
                subfield_p^.subfield_position, subfield_p^.subfield_length, subfield_p^.subfield_number,
                subfield_p^.subfield_delimiter, null_subfield, substring_found, descriptive_data_start,
                descriptive_data_length);
        ELSE
          null_subfield := TRUE;
        IFEND;

        IF null_subfield THEN
          string_p := subfield_p^.descriptive_data_string_p;
          WHILE (string_p <> NIL) AND (string_p^.descriptive_text <> '') DO
            string_p := string_p^.descriptive_string_link_p;
          WHILEND;
          IF string_p = NIL THEN
            RETURN; {----->
          IFEND;
        ELSEIF substring_found THEN
          string_p := subfield_p^.descriptive_data_string_p;
          WHILE (string_p <> NIL) AND (descriptive_data_p^ (descriptive_data_start,
                descriptive_data_length) <> string_p^.descriptive_text) DO
            string_p := string_p^.descriptive_string_link_p;
          WHILEND;
          IF string_p = NIL THEN
            RETURN; {----->
          IFEND;
        ELSE
          RETURN; {----->
        IFEND;
        subfield_p := subfield_p^.descriptive_subfield_link_p;
      WHILEND;

    IFEND;

    predecessor_p := NIL;

{ check Job membership

    IF selection_p^.predecessor_job_statistic_p <> NIL THEN
      successor_p := selection_p^.predecessor_job_statistic_p^.successor_list_head_p;
      WHILE (successor_p <> NIL) AND (statistic_header_p^.job_name <> successor_p^.job_seq_number) DO
        successor_p := successor_p^.successor_link_p;
      WHILEND;
      IF successor_p = NIL THEN
        RETURN; {----->
      IFEND;
      predecessor_p := successor_p;
      ptv$predecessor_job_date_time := successor_p^.date_time;
    IFEND;

{ check Task membership

    IF selection_p^.predecessor_task_statistic_p <> NIL THEN
      successor_p := selection_p^.predecessor_task_statistic_p^.successor_list_head_p;
      WHILE (successor_p <> NIL) AND ((statistic_header_p^.task_id <> successor_p^.global_task_id) OR
            (statistic_header_p^.job_name <> successor_p^.job_seq_number)) DO
        successor_p := successor_p^.successor_link_p;
      WHILEND;
      IF successor_p = NIL THEN
        RETURN; {----->
      IFEND;
      predecessor_p := successor_p;
      ptv$predecessor_task_date_time := successor_p^.date_time;
    IFEND;

{ check Job name

    IF (selection_p^.job_name <> ' ') AND (statistic_header_p^.job_name <> selection_p^.job_name) THEN
      RETURN; {----->
    IFEND;

{ check Task name

    IF selection_p^.task_id_specified AND (statistic_header_p^.task_id <> selection_p^.task_id) THEN
      RETURN; {----->
    IFEND;

    select_statistic := TRUE;

  FUNCEND select_statistic;

?? OLDTITLE ??
?? NEWTITLE := 'set_counter_length', EJECT ??

{ PURPOSE:
{   The purpose of this request is to set the length of a fixed counter in the list file.
{
{ DESIGN:
{  The procedure checks all log entries for the longest counter base by comparing the ordinal number of the
{ base.
{
{ NOTE:
{   - In a list log when the counter_format is fixed all counters are written in the same length.
{   - The order in radix is the order of the fixed counter length (see ptc$base_xx_length).
{
{        radix          length
{        -----          ------
{        base_0
{        base_10          21
{        base_16          22
{        base_16_group    26
{        base_8           27
{        base_2           69

  PROCEDURE set_counter_length;

    VAR
      base: radix,
      index: integer,
      log_entry_p: ^put_entry;

    base := base_10;
    log_entry_p := ptv$log_entry_chain_head_p;
    WHILE log_entry_p <> NIL DO
      FOR index := 1 TO sfc$max_number_of_counters DO
        IF base < log_entry_p^.counter_base [index] THEN
          base := log_entry_p^.counter_base [index];
        IFEND;
      FOREND;
      log_entry_p := log_entry_p^.put_chain_link_p;
    WHILEND;

    CASE base OF
    = base_2 =
      ptv$fixed_counter_length := ptc$base_2_length;
    = base_8 =
      ptv$fixed_counter_length := ptc$base_8_length;
    = base_10 =
      ptv$fixed_counter_length := ptc$base_10_length;
    = base_16 =
      ptv$fixed_counter_length := ptc$base_16_length;
    = base_16_group =
      ptv$fixed_counter_length := ptc$base_16_group_length;
    ELSE
    CASEND;

  PROCEND set_counter_length;

?? OLDTITLE ??
?? NEWTITLE := 'set_elapsed_time_field', EJECT ??

{ PURPOSE:
{   The purpose of this request is to process the elapsed_time field in elapsed_time_calculation parameter for
{ add_field and change_field subcommands.

  PROCEDURE set_elapsed_time_field
    (    elapsed_time: clt$field_value;
         field_p { input, output } : ^field);

    IF elapsed_time.value <> NIL THEN
      IF elapsed_time.value^.keyword_value = ptc$key_previous_occurrence THEN
        field_p^.elapsed_time := previous_occurrence;
      ELSEIF elapsed_time.value^.keyword_value = ptc$key_predecessor THEN
        field_p^.elapsed_time := predecessor;
      ELSE { elapsed_time.value^.keyword_value = ptc$key_predecessor_chain_head
        field_p^.elapsed_time := predecessor_chain_head;
      IFEND;
    IFEND;

  PROCEND set_elapsed_time_field;

?? OLDTITLE ??
?? NEWTITLE := 'set_field_counter', EJECT ??

{ PURPOSE:
{   The purpose of this request is to process the counter parameter and the counter attributes in the
{ elapsed_time_calculation parameter for add_field and change_field subcommands.
{
{ DESIGN:
{   The field's number is:                           counter    elapsed_time_calculation
{                          counter_number              1                 3
{                          multiplier                  2                 4
{                          incremental                 3                 5
{                          allow_negative_increment    4                 6
{ NOTE:
{   Counter_number field is optional in change_field subcommand.

  PROCEDURE set_field_counter
    (    counter_value: ^clt$data_value;
         field_p { input, output } : ^field);

    VAR
      field_number: integer,
      long_real_value: record
        high: real,
        low: real,
      recend;

    IF field_p^.field_type = counter_field THEN
      field_number := 1;
    ELSE { field_p^field_type = value_per_second_field }
      field_number := 3;
    IFEND;

{ counter_number

    IF counter_value^.field_values^ [field_number].value <> NIL THEN
      field_p^.counter_number := counter_value^.field_values^ [field_number].value^.integer_value.value;
    IFEND;

{ multiplier

    IF counter_value^.field_values^ [field_number + 1].value <> NIL THEN
      #UNCHECKED_CONVERSION (counter_value^.field_values^ [field_number + 1].value^.real_value.value,
            long_real_value);
      field_p^.multiplier := long_real_value.high;
    IFEND;

{ incremental

    IF counter_value^.field_values^ [field_number + 2].value <> NIL THEN
      field_p^.incremental := counter_value^.field_values^ [field_number + 2].value^.boolean_value.value;
    IFEND;

{ allow_negative_increment

    IF counter_value^.field_values^ [field_number + 3].value <> NIL THEN
      field_p^.allow_negative_increment := counter_value^.field_values^ [field_number +
            3].value^.boolean_value.value;
    IFEND;

  PROCEND set_field_counter;

?? OLDTITLE ??
?? NEWTITLE := 'set_field_descriptive_data', EJECT ??

{ PURPOSE:
{   The purpose of this request is to set the length of the descriptive data field in the list file.
{

  PROCEDURE set_field_descriptive_data
    (    descriptive_data_value: ^clt$data_value;
         field_p: { output } ^field);

    IF descriptive_data_value^.field_values^ [1].value <> NIL THEN
      field_p^.subfield_position := descriptive_data_value^.field_values^ [1].value^.integer_value.value;
    IFEND;

    IF descriptive_data_value^.field_values^ [2].value <> NIL THEN
      IF descriptive_data_value^.field_values^ [2].value^.kind <> clc$keyword THEN
        field_p^.subfield_length := descriptive_data_value^.field_values^ [2].value^.integer_value.value;
      ELSE
        field_p^.subfield_length := sfc$max_descriptive_data_size;
      IFEND;
    IFEND;

    IF descriptive_data_value^.field_values^ [3].value <> NIL THEN
      IF descriptive_data_value^.field_values^ [3].value^.kind <> clc$keyword THEN
        field_p^.subfield_number := descriptive_data_value^.field_values^ [3].value^.integer_value.value;
      ELSE
        field_p^.subfield_number := 0;
      IFEND;
    IFEND;

    IF descriptive_data_value^.field_values^ [4].value <> NIL THEN
      field_p^.subfield_delimiter := descriptive_data_value^.field_values^ [4].value^.string_value^ (1);
    IFEND;

  PROCEND set_field_descriptive_data;

?? OLDTITLE ??
?? NEWTITLE := 'set_field_type', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to initialize elements of a field record that are unique to the type of
{   field.
{

  PROCEDURE set_field_type
    (    field_type: type_of_field;
         field_p: { output } ^field;
     VAR status: ost$status);

    status.normal := TRUE;

    CASE field_type OF

    = counter_field =
      field_p^.first_counter_value := 0;
      field_p^.last_counter_value := 0;
      field_p^.counter_value_head_p := NIL;
      field_p^.counter_value_tail_p := NIL;

      field_p^.counter_number := 1;
      field_p^.multiplier := 1.0;
      field_p^.incremental := FALSE;
      field_p^.allow_negative_increment := FALSE;
      field_p^.last_value := 0;

    = descriptive_data_field =
      field_p^.first_descriptive_value_p := NIL;
      field_p^.last_descriptive_value_p := NIL;
      field_p^.descriptive_value_head_p := NIL;
      field_p^.descriptive_value_tail_p := NIL;
      field_p^.subfield_position := 1;
      field_p^.subfield_length := sfc$max_descriptive_data_size;
      field_p^.subfield_number := 0; { ALL }
      field_p^.subfield_delimiter := ',';

    = date_time_field =
      field_p^.date_time_value_head_p := NIL;
      field_p^.date_time_value_tail_p := NIL;

    = statistic_code_field =
      field_p^.statistic_code_value_head_p := NIL;
      field_p^.statistic_code_value_tail_p := NIL;

    = system_job_name_field =
      field_p^.system_job_name_value_head_p := NIL;
      field_p^.system_job_name_value_tail_p := NIL;

    = global_task_id_field =
      field_p^.global_task_id_value_head_p := NIL;
      field_p^.global_task_id_value_tail_p := NIL;

    = number_of_counters_field =
      field_p^.number_of_counters_value_head_p := NIL;
      field_p^.number_of_counters_value_tail_p := NIL;

    = descriptive_data_size_field =
      field_p^.dd_size_value_head_p := NIL;
      field_p^.dd_size_value_tail_p := NIL;

    = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =
      field_p^.elapsed_time_value_head_p := NIL;
      field_p^.elapsed_time_value_tail_p := NIL;

{ If elapsed time based on a predecessor, but no predecessors are defined, signal an error
      IF ((field_p^.field_type = predecessor_field) OR (field_p^.field_type =
            predecessor_chain_head_field)) AND (field_p^.selection_p^.predecessor_job_statistic_p = NIL) AND
            (field_p^.selection_p^.predecessor_task_statistic_p = NIL) THEN
              osp$set_status_condition (pte$no_predecessor_for_et, status);
      IFEND;

    = value_per_second_field =
      field_p^.value_per_second_value_head_p := NIL;
      field_p^.value_per_second_value_tail_p := NIL;

      field_p^.counter_number := 1;
      field_p^.multiplier := 1.0;
      field_p^.incremental := FALSE;
      field_p^.allow_negative_increment := FALSE;
      field_p^.last_value := 0;

    = occurrence_per_second_field =
      field_p^.value_per_second_value_head_p := NIL;
      field_p^.value_per_second_value_tail_p := NIL;

    = text_field =

    ELSE
    CASEND;

  PROCEND set_field_type;

?? OLDTITLE ??
?? NEWTITLE := 'set_report_information', EJECT ??

{ PURPOSE:
{   The purpose of this request is to check and set report information (summary and/or interval).
{
{ DESIGN:
{   The procedure checks all selections and fields (counters and descriptive data) for the type of information
{ it needs to collect during the log scan.  Based on the type of report that the fields are going to appear
{ in, this procedure sets flags (in a set).  If an interval_field flag is set for one of the fields in a
{ selection, a collect date_time flag is set for that selection.  If an interval_field flag is set for one of
{ the fields in a selection and the selection has a predecessor, then a collect predecessor date_time flag is
{ set for that selection.

{ 1. Reset collects
{ 2. PUTIF                : collect_all_occurrences
{    PUTF all_occurrences : collect_all_occurrences
{    PUTF                 : collect_summary
{    PUTFs                : collect_summary

  PROCEDURE set_report_information;

    VAR
      field_p: ^field,
      report_list_p: ^report_list,
      selection_p: ^selection;


    selection_p := ptv$selection_chain_head_p;
    WHILE selection_p <> NIL DO

      selection_p^.incremental := FALSE;
      selection_p^.incremental_counter_p := NIL;
      selection_p^.skip_date_time := FALSE;
      selection_p^.lost_interval := 0;
      selection_p^.skip_date_time_head_p := NIL;
      selection_p^.skip_date_time_tail_p := NIL;

      field_p := selection_p^.field_chain_p;
      WHILE field_p <> NIL DO

        IF field_p^.field_type <> text_field THEN

          field_p^.first_value := TRUE;
          field_p^.collect_summary := FALSE;
          field_p^.collect_all_occurrences := FALSE;

          report_list_p := field_p^.report_list_p;
          WHILE report_list_p <> NIL DO

            CASE report_list_p^.report_p^.put OF

            = put_field =
              IF report_list_p^.report_p^.all_occurrences THEN
                IF NOT report_list_p^.shadow THEN
                  field_p^.collect_all_occurrences := TRUE;
                IFEND;
              ELSE
                field_p^.collect_summary := TRUE;
              IFEND;

            = put_field_summary =
              field_p^.collect_summary := TRUE;

            = put_interval_field =
              IF NOT report_list_p^.shadow THEN
                field_p^.collect_all_occurrences := TRUE;
                selection_p^.collect_date_time := TRUE;
                IF (report_list_p^.report_p^.row_label_type = start_time) OR
                      (report_list_p^.report_p^.row_label_type = end_time) OR
                      (report_list_p^.report_p^.row_label_type = time_range) THEN
                IFEND;
                IF ((selection_p^.predecessor_job_statistic_p <> NIL) OR
                      (selection_p^.predecessor_task_statistic_p <> NIL)) THEN
                  selection_p^.collect_predecessor_date_time := TRUE;
                IFEND;
              IFEND;

            ELSE
            CASEND;

            report_list_p := report_list_p^.link_p;
          WHILEND;

          IF NOT selection_p^.incremental AND ((field_p^.field_type = counter_field) OR
                (field_p^.field_type = value_per_second_field)) AND field_p^.incremental AND
                field_p^.allow_negative_increment THEN
            selection_p^.incremental := TRUE;
            selection_p^.incremental_counter_p := field_p;
          IFEND;

        IFEND;

        field_p := field_p^.field_chain_link_p;
      WHILEND;

      selection_p := selection_p^.selection_chain_link_p;
    WHILEND;

  PROCEND set_report_information;

?? OLDTITLE ??
?? NEWTITLE := 'set_shadow_fields', EJECT ??

{ PURPOSE:
{   The purpose of this check is to determine if there is a need to do predecessor joins for a
{ put_field report with all_occurrences display_option. If so, it sets shadow fields to collect the joined
{ data.
{
{ DESIGN:
{   The procedure scans the list of report entries for every field report entry with display_option
{ all_occurrences. The procedure checks if the data for the report is coming from more than one selection and
{ if all the selections that the data is coming from are linked together in one path of predecessors (task
{ and/or job).  Then the procedure finds the tail of the chain - a selection in the predecessor chain that is
{ not predecessor to any of the other selections in the list.  For every field in the report entry that does
{ not belong to the tail selection the procedure creates shadow fields in the tail selection in order to
{ collect the field occurences joined (in synchronization) with the field that belongs to the tail selection.
{
{ Example:
{
{   add_selection selection=job_begin statistic_code=jm0
{   add_selection selection=job_name  statistic_code=jm1  job_predecessor=job_begin
{   add_selection selection=job_mode  statistic_code=jm2  job_predecessor=job_name
{   add_selection selection=job_end   statistic_code=jm3  job_predecessor=job_mode
{   add_field field=user_name  selection=job_begin text=(1, 31)
{   add_field field=job_mode   selection=job_mode  text=(1, 11)
{   add_field field=job_jm_cpu selection=job_end   counter=1 m=0.000001
{   add_field field=job_mm_cpu selection=job_end   counter=2 m=0.000001
{   put_field field=((user_name,  all_occurrences,, 31, 'User Name') ..
{                    (job_mode,   all_occurrences,, 11, 'Job Mode') ..
{                    (job_jm_cpu, all_occurrences,, 15, 'JM CPU') ..
{                    (job_mm_cpu, all_occurrences,, 15, 'MM CPU'))
{   generate_report input=log output=out
{
{ For this example the procedure will find that the display_option for the put_field report entry is
{ all_occurrences and the data for the report is coming from 3 selections (job_begin job_mode and
{ job_end).  The 3 selections create a chain of predecessors and the job_end selection will be the tail
{ selection.  The procedure will create shadow fields for user_name and job_mode fields in job_end selection.
{ The data for the shadow field will be collected when a statistic is selected for job_end selection with
{ the data collection for job_end regular fields.
{
{   If the procedure sets the shadow flag and the active log flag is set too, the procedure opens a temporary
{ binary log file for saving the shadowed predecessor statistic records from active log.

{ NOTE:
{   - Not all the selections in the predecessors chain must be in the report - in the example job_name
{     selection does not have field(s) in the report but it's the link between job_mode selection and
{     job_begin selection.
{   - The tail selection can be a predecessor to a selection that does not have fields in the report.

  PROCEDURE set_shadow_fields
    (VAR status: ost$status);

    VAR
      field_p: ^field,
      index: integer,
      join_predecessor_status: join_predecessor_status_type,
      report_entry_number: integer,
      report_entry_p: ^put_entry,
      report_list_p: ^report_list,
      selection_p: ^selection,
      shadow_fields: boolean,
      unique_name: ost$name,
      warning_status: ost$status;

    status.normal := TRUE;

    shadow_fields := FALSE;
    report_entry_number := 0;
    report_entry_p := ptv$report_entry_chain_head_p;
    WHILE report_entry_p <> NIL DO
      report_entry_number := report_entry_number + 1;
      IF (report_entry_p^.put = put_field) AND report_entry_p^.all_occurrences THEN

        check_predecessor_path (report_entry_p, join_predecessor_status, selection_p);

        CASE join_predecessor_status OF
        = one_selection =

        = no_predecessor_path = { The fields are from more than one selection.
          IF report_entry_p^.name <> ' ' THEN
            osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$mixed_selections, report_entry_p^.name,
                  warning_status);
          ELSE
            osp$set_status_condition (pte$mixed_selections, warning_status);
            osp$append_status_integer (osc$status_parameter_delimiter, report_entry_number, 10, FALSE,
                  warning_status);
          IFEND;
          report_intermediate_error (warning_status, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

        = predecessor_path =
          index := LOWERBOUND (field_vector_type);
          WHILE (index <= UPPERBOUND (field_vector_type)) AND
                (report_entry_p^.field_vector [index].summary <> null) DO
            IF report_entry_p^.field_vector [index].field_p^.field_type <> text_field THEN
              IF selection_p <> report_entry_p^.field_vector [index].field_p^.selection_p THEN

{   Allocate a shadow counter field in the tail's selection. Initialize the counter by
{ copying the original counter, setting the put_set to put_interval_field, setting the original selection
{ pointer, setting the selection pointer to the tail selection, setting the field in the report entry as
{ shadow (setting the shadow flag and setting pointer to the shadow counter) and marking the original counter
{ report_list entry as shadowed.

                IF selection_p^.shadow_field_chain_p <> NIL THEN
                  NEXT field_p^.field_chain_link_p IN ptv$data_segment_p.sequence_pointer;
                  field_p := field_p^.field_chain_link_p;
                ELSE
                  NEXT selection_p^.shadow_field_chain_p IN ptv$data_segment_p.sequence_pointer;
                  field_p := selection_p^.shadow_field_chain_p;
                IFEND;
                field_p^ := report_entry_p^.field_vector [index].field_p^;
                field_p^.field_chain_link_p := NIL;
                field_p^.report_list_p := NIL;
                field_p^.collect_all_occurrences := TRUE;
                field_p^.original_selection_p := field_p^.selection_p;
                field_p^.selection_p := selection_p;
                field_p^.original_selection_p^.shadow_fields := TRUE;
                report_entry_p^.field_vector [index].shadow_field := TRUE;
                report_entry_p^.field_vector [index].shadow_field_p := field_p;

                report_list_p := report_entry_p^.field_vector [index].field_p^.report_list_p;
                WHILE report_list_p <> NIL DO
                  IF report_list_p^.report_p = report_entry_p THEN
                    report_list_p^.shadow := TRUE;
                  IFEND;
                  report_list_p := report_list_p^.link_p;
                WHILEND;
              IFEND;
            IFEND;
            index := index + 1;
          WHILEND;

          shadow_fields := TRUE;

        ELSE
        CASEND;

      IFEND;
      report_entry_p := report_entry_p^.put_chain_link_p;
    WHILEND;

    IF shadow_fields AND ptv$active_log THEN
      RESET ptv$predecessor_log_p.sequence_pointer;
    IFEND;

  PROCEND set_shadow_fields;

?? OLDTITLE ??
?? NEWTITLE := 'sort_list_by_statistic_code', EJECT ??

{   The purpose of this procedure is to sort the logged_statistic linked list in order
{ of increasing statistic code.
{ The procedure uses recursion to sort sublists of the whole list.  This is basically a
{ bubble sort for linked lists, rather than for an array.
{ The procedure is only called by itself and display_logged_statistics_cmd.

  PROCEDURE sort_list_by_statistic_code
    (VAR head_logged_stat_p: ^logged_statistic);

    VAR
      prev_logged_stat_p: ^logged_statistic,
      curr_logged_stat_p: ^logged_statistic,
      next_logged_stat_p: ^logged_statistic;

{ Only sort if list has more than one element.

    IF head_logged_stat_p^.link_p <> NIL THEN

{ Sort sub-list before sorting current list

      sort_list_by_statistic_code (head_logged_stat_p^.link_p);

{ Check order of first two elements in list.  If they need re-ordering, the
{ head of list pointer needs to be reassigned.

      next_logged_stat_p := head_logged_stat_p^.link_p;
      IF head_logged_stat_p^.statistic_code > next_logged_stat_p^.statistic_code THEN
        head_logged_stat_p^.link_p := next_logged_stat_p^.link_p;
        next_logged_stat_p^.link_p := head_logged_stat_p;
        head_logged_stat_p := next_logged_stat_p;
      IFEND;

{ Main sort loop

      prev_logged_stat_p := head_logged_stat_p;
      curr_logged_stat_p := prev_logged_stat_p^.link_p;
      next_logged_stat_p := curr_logged_stat_p^.link_p;
      WHILE next_logged_stat_p <> NIL DO
        IF curr_logged_stat_p^.statistic_code > next_logged_stat_p^.statistic_code THEN
           curr_logged_stat_p^.link_p := next_logged_stat_p^.link_p;
           next_logged_stat_p^.link_p := curr_logged_stat_p;
           prev_logged_stat_p^.link_p := next_logged_stat_p;
        IFEND;

        prev_logged_stat_p := prev_logged_stat_p^.link_p;
        curr_logged_stat_p := prev_logged_stat_p^.link_p;
        next_logged_stat_p := curr_logged_stat_p^.link_p;
      WHILEND;
    IFEND;

  PROCEND sort_list_by_statistic_code;

?? OLDTITLE ??
?? NEWTITLE := 'write_counter_summary', EJECT ??

{ PURPOSE:
{   The purpose of this request is to write one line of a field summary report.
{
{ DESIGN:
{   The procedure gets the counter with the summary values, the row_label string and the report entry.  The
{ procedure places the row label string and the string representation of the summary in the output line in the
{ specified report fields.
{
{ NOTE:
{  - In case of sum overflow during data collection the procedure writes '*' string in the report fields of
{    sum, mean, standard_deviation and sum_per_second.
{  - If the report field length is not enough to hold the summary string the procedure writes '*' string in
{    the report fields.

  PROCEDURE write_counter_summary
    (    field_p: ^field;
         row_label: string ( * <= ptc$max_row_label_size);
         report_entry_p: ^put_entry;
     VAR status: ost$status);

    VAR
      clt_date_time: [STATIC] clt$date_time := [ * , FALSE, TRUE],
      date_time_format: [STATIC] string (clc$max_date_time_form_string) := 'H24:MM:SS.S1000',
      date_time_string: ost$string,
      index: integer,
      output_line_length: integer;

    status.normal := TRUE;

    ptv$output_line := '';
    output_line_length := 0;
    ptv$output_line (report_entry_p^.row_label_start_column,
          report_entry_p^.row_label_column_width) := row_label;
    ptv$output_line_length := report_entry_p^.row_label_start_column +
          report_entry_p^.row_label_column_width - 1;

    index := LOWERBOUND (summary_vector_type);
    WHILE (index <= UPPERBOUND (summary_vector_type)) AND
          (report_entry_p^.summary_vector [index].summary <> null) DO
      CASE report_entry_p^.summary_vector [index].summary OF

      = count =
        clp$convert_integer_to_rjstring (field_p^.field_summary.count, 10, FALSE, ' ',
              ptv$output_line (report_entry_p^.summary_vector [index].start_column,
              report_entry_p^.summary_vector [index].column_width), status);
        IF NOT status.normal THEN
          IF status.condition = cle$string_too_short THEN
            ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                  report_entry_p^.summary_vector [index].column_width) := ptc$stars;
            status.normal := TRUE;
          ELSE
            RETURN; {----->
          IFEND;
        IFEND;

      = sum =
        IF NOT field_p^.field_summary.sum_overflow THEN
          IF field_p^.multiplier = 1.0 THEN
            clp$convert_integer_to_rjstring (field_p^.field_summary.sum, 10, FALSE, ' ',
                  ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                  report_entry_p^.summary_vector [index].column_width), status);
            IF NOT status.normal THEN
              IF status.condition = cle$string_too_short THEN
                ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                      report_entry_p^.summary_vector [index].column_width) := ptc$stars;
                status.normal := TRUE;
              ELSE
                RETURN; {----->
              IFEND;
            IFEND;
          ELSE
            STRINGREP (ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                  report_entry_p^.summary_vector [index].column_width), ptv$output_line_length,
                  ($REAL (field_p^.field_summary.sum) * field_p^.multiplier):
                  report_entry_p^.summary_vector [index].column_width: ptv$counter_fraction);
          IFEND;
        ELSE
          ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                report_entry_p^.summary_vector [index].column_width) := ptc$stars;
        IFEND;

      = mean =
        IF NOT field_p^.field_summary.sum_overflow THEN
          STRINGREP (ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                report_entry_p^.summary_vector [index].column_width), ptv$output_line_length,
                field_p^.field_summary.mean * field_p^.multiplier: report_entry_p^.summary_vector [index].
                column_width: ptv$counter_fraction);
        ELSE
          ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                report_entry_p^.summary_vector [index].column_width) := ptc$stars;
        IFEND;

      = standard_deviation =
        IF NOT field_p^.field_summary.sum_overflow THEN
          STRINGREP (ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                report_entry_p^.summary_vector [index].column_width), ptv$output_line_length,
                field_p^.field_summary.standard_deviation * field_p^.multiplier: report_entry_p^.
                summary_vector [index].column_width: ptv$counter_fraction);
        ELSE
          ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                report_entry_p^.summary_vector [index].column_width) := ptc$stars;
        IFEND;

      = minimum =
        IF field_p^.multiplier = 1.0 THEN
          clp$convert_integer_to_rjstring (field_p^.field_summary.minimum, 10, FALSE, ' ',
                ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                report_entry_p^.summary_vector [index].column_width), status);
        ELSE
          STRINGREP (ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                report_entry_p^.summary_vector [index].column_width), ptv$output_line_length,
                ($REAL (field_p^.field_summary.minimum) * field_p^.multiplier): report_entry_p^.
                summary_vector [index].column_width: ptv$counter_fraction);
        IFEND;

      = maximum =
        IF field_p^.multiplier = 1.0 THEN
          clp$convert_integer_to_rjstring (field_p^.field_summary.maximum, 10, FALSE, ' ',
                ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                report_entry_p^.summary_vector [index].column_width), status);
          IF NOT status.normal THEN
            IF status.condition = cle$string_too_short THEN
              ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                    report_entry_p^.summary_vector [index].column_width) := ptc$stars;
              status.normal := TRUE;
            ELSE
              RETURN; {----->
            IFEND;
          IFEND;
        ELSE
          STRINGREP (ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                report_entry_p^.summary_vector [index].column_width), ptv$output_line_length,
                ($REAL (field_p^.field_summary.maximum) * field_p^.multiplier): report_entry_p^.
                summary_vector [index].column_width: ptv$counter_fraction);
        IFEND;

      = interval =
        ptv$interval.millisecond := field_p^.field_summary.interval;
        IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
          pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          clp$convert_date_time_to_string (clt_date_time, date_time_format, date_time_string, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          ptv$output_line (report_entry_p^.summary_vector [index].start_column +
                report_entry_p^.summary_vector [index].column_width - ptc$time_length,
                report_entry_p^.summary_vector [index].column_width) := date_time_string.value (1, * );
        ELSE { ptv$time_increment_format = 'SECONDS'
          STRINGREP (ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                report_entry_p^.summary_vector [index].column_width), ptv$output_line_length,
                ($REAL (ptv$interval.millisecond) * 0.001): report_entry_p^.summary_vector [index].
                column_width: 3);
        IFEND;

      = count_per_second =
        STRINGREP (ptv$output_line (report_entry_p^.summary_vector [index].start_column,
              report_entry_p^.summary_vector [index].column_width), ptv$output_line_length,
              field_p^.field_summary.count_per_second: report_entry_p^.summary_vector [index].
              column_width: ptv$counter_fraction);

      = sum_per_second =
        IF NOT field_p^.field_summary.sum_overflow THEN
          STRINGREP (ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                report_entry_p^.summary_vector [index].column_width), ptv$output_line_length,
                field_p^.field_summary.sum_per_second: report_entry_p^.summary_vector [index].
                column_width: ptv$counter_fraction);
        ELSE
          ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                report_entry_p^.summary_vector [index].column_width) := ptc$stars;
        IFEND;

      = elapsed_time_since_predecessor =
        ptv$interval.millisecond := field_p^.field_summary.elapsed_time_since_predecessor;
        IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
          pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          clp$convert_date_time_to_string (clt_date_time, date_time_format, date_time_string, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          ptv$output_line (report_entry_p^.summary_vector [index].start_column +
                report_entry_p^.summary_vector [index].column_width - ptc$time_length,
                report_entry_p^.summary_vector [index].column_width) := date_time_string.value (1, * );
        ELSE { ptv$time_increment_format = 'SECONDS'
          STRINGREP (ptv$output_line (report_entry_p^.summary_vector [index].start_column,
                report_entry_p^.summary_vector [index].column_width), ptv$output_line_length,
                ($REAL (ptv$interval.millisecond) * 0.001): report_entry_p^.summary_vector [index].
                column_width: 3);
        IFEND;

      ELSE
      CASEND;
      IF report_entry_p^.summary_vector [index].summary <> null THEN
        ptv$output_line_length := report_entry_p^.summary_vector [index].start_column +
              report_entry_p^.summary_vector [index].column_width - 1;
      IFEND;
      IF output_line_length < (report_entry_p^.summary_vector [index].start_column +
            report_entry_p^.summary_vector [index].column_width - 1) THEN
        output_line_length := report_entry_p^.summary_vector [index].start_column +
              report_entry_p^.summary_vector [index].column_width - 1;
      IFEND;

      index := index + 1;
    WHILEND;

    IF ptv$excel THEN
      convert_output_line_to_excel (report_entry_p, ptv$output_line, ptv$output_line, ptv$output_line_length);
    ELSE
      ptv$output_line_length := output_line_length;
    IFEND;
    cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

  PROCEND write_counter_summary;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] write_descriptive_data_to_list', EJECT ??

{ PURPOSE:
{   The purpose of this request is to write a descriptive_data string to the list file, for display_selection
{ subcommand and write_statistic_to_list_log procedure.
{
{ DESIGN:
{   The procedure adds an apostrophe in the beginning and the end of the descriptive_data string.  The
{ procedure writes the descriptive_data string into the output file while folding the descriptive_data
{ string in order not to go over the file page_width.

  PROCEDURE [INLINE] write_descriptive_data_to_list
    (    descriptive_data: sft$descriptive_data;
         indent: integer;
     VAR status: ost$status);

    VAR
      index: integer,
      line_length: integer;

    status.normal := TRUE;

    ptv$output_line_log (1, indent) := '';
    ptv$output_line_log (indent + 1) := '''';
    ptv$output_line_log (indent + 2, #SIZE (descriptive_data)) := descriptive_data;
    ptv$output_line_log (indent + #SIZE (descriptive_data) + 2) := '''';
    line_length := indent + #SIZE (descriptive_data) + 2;
    index := 1;
    WHILE line_length > ptv$maximum_line_length DO
      cyp$put_next_line (ptv$output_file, ptv$output_line_log (index, ptv$maximum_line_length), status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      line_length := line_length - ptv$maximum_line_length;
      index := index + ptv$maximum_line_length;
    WHILEND;
    cyp$put_next_line (ptv$output_file, ptv$output_line_log (index, line_length), status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

  PROCEND write_descriptive_data_to_list;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] write_field_all_occurrences', EJECT ??

{ PURPOSE:
{   The purpose of this request is to write a field in an all_occurrences field report line.
{
{ DESIGN:
{   This procedure converts the field's value to a string and places it in the report field postion.  If
{ the field runs out of values the procedure deletes the field from the active_fields set and decrements the
{ number of active fields.

  PROCEDURE [INLINE] write_field_all_occurrences
    (    report_entry_field: field_record_type;
         index: integer;
     VAR active_fields: active_fields_set;
     VAR number_of_active_fields: integer;
     VAR field_value_entry: field_value_pointers;
     VAR status: ost$status);

    VAR
      clt_date_time: clt$date_time,
      date_time_string: ost$string,
      statistic_name: ost$name,
      task_id_index: string (ptc$task_id_index_string_size),
      task_id_seqno: string (ptc$task_id_seqno_string_size);

    status.normal := TRUE;

    IF field_value_entry.first AND ((report_entry_field.field_p^.incremental) OR
          (report_entry_field.field_p^.field_type = previous_occurrence_field) OR
          (((report_entry_field.field_p^.field_type = value_per_second_field) OR
          (report_entry_field.field_p^.field_type = occurrence_per_second_field)) AND
          (report_entry_field.field_p^.elapsed_time = previous_occurrence))) THEN

{  If this is the first value of an incremental type field, then skip this pass.
{    This is to keep in sync with non-incremental fields.  Do not let the
{    value_index be incremented.
{  Only incremental type fields have field_value_p^ [index].first set to TRUE by
{    initialize_write_occurrence.

      field_value_entry.first := FALSE;
      ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) := ptc$blanks;
      RETURN; {----->
    IFEND;

    field_value_entry.value_index := field_value_entry.value_index + 1;
    CASE report_entry_field.field_p^.field_type OF

    = counter_field =

      IF (field_value_entry.counter_value_p^.value_array [field_value_entry.value_index] >= 0) OR
            (report_entry_field.field_p^.allow_negative_increment) THEN
        IF report_entry_field.field_p^.multiplier = 1.0 THEN
          clp$convert_integer_to_rjstring (field_value_entry.counter_value_p^.
                value_array [field_value_entry.value_index], 10, FALSE, ' ',
                ptv$output_line (report_entry_field.start_column, report_entry_field.column_width), status);
          IF NOT status.normal THEN
            IF status.condition = cle$string_too_short THEN
              ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) := ptc$stars;
              status.normal := TRUE;
            ELSE
              RETURN; {----->
            IFEND;
          IFEND;
        ELSE
          STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                ptv$output_line_length, ($REAL (field_value_entry.counter_value_p^.
                value_array [field_value_entry.value_index]) * report_entry_field.field_p^.
                multiplier): report_entry_field.column_width: ptv$counter_fraction);
        IFEND;
      ELSE
        ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) := ptc$blanks;

      IFEND;

      IF field_value_entry.value_index = field_value_entry.counter_value_p^.index THEN
        IF field_value_entry.counter_value_p^.link_p <> NIL THEN
          field_value_entry.counter_value_p := field_value_entry.counter_value_p^.link_p;
          field_value_entry.value_index := 0;
        ELSE
          active_fields := active_fields - $active_fields_set [index];
          number_of_active_fields := number_of_active_fields - 1;
        IFEND;
      IFEND;

    = descriptive_data_field =
      IF field_value_entry.descriptive_value_p^.value_array [field_value_entry.value_index] <> NIL THEN
        ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) :=
              field_value_entry.descriptive_value_p^.value_array [field_value_entry.value_index]^ (1, * );
      IFEND;

      IF field_value_entry.value_index = field_value_entry.descriptive_value_p^.index THEN
        IF field_value_entry.descriptive_value_p^.link_p <> NIL THEN
          field_value_entry.descriptive_value_p := field_value_entry.descriptive_value_p^.link_p;
          field_value_entry.value_index := 0;
        ELSE
          active_fields := active_fields - $active_fields_set [index];
          number_of_active_fields := number_of_active_fields - 1;
        IFEND;
      IFEND;

    = date_time_field =
      ptv$clt_date_time.value := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];

      clp$convert_date_time_to_string (ptv$clt_date_time, ptv$date_time_format, date_time_string, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

      ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) :=
            date_time_string.value;

      IF field_value_entry.value_index = field_value_entry.date_time_p^.index THEN
        IF field_value_entry.date_time_p^.link_p <> NIL THEN
          field_value_entry.date_time_p := field_value_entry.date_time_p^.link_p;
          field_value_entry.value_index := 0;
        ELSE
          active_fields := active_fields - $active_fields_set [index];
          number_of_active_fields := number_of_active_fields - 1;
        IFEND;
      IFEND;

    = statistic_code_field =
      sfp$convert_stat_code_to_name (field_value_entry.statistic_code_value_p^.
            value_array [field_value_entry.value_index], statistic_name, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

      ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) := statistic_name;

      IF field_value_entry.value_index = field_value_entry.statistic_code_value_p^.index THEN
        IF field_value_entry.statistic_code_value_p^.link_p <> NIL THEN
          field_value_entry.statistic_code_value_p := field_value_entry.statistic_code_value_p^.link_p;
          field_value_entry.value_index := 0;
        ELSE
          active_fields := active_fields - $active_fields_set [index];
          number_of_active_fields := number_of_active_fields - 1;
        IFEND;
      IFEND;

    = system_job_name_field =

      ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) :=
            field_value_entry.system_job_name_value_p^.value_array [field_value_entry.value_index];

      IF field_value_entry.value_index = field_value_entry.system_job_name_value_p^.index THEN
        IF field_value_entry.system_job_name_value_p^.link_p <> NIL THEN
          field_value_entry.system_job_name_value_p := field_value_entry.system_job_name_value_p^.link_p;
          field_value_entry.value_index := 0;
        ELSE
          active_fields := active_fields - $active_fields_set [index];
          number_of_active_fields := number_of_active_fields - 1;
        IFEND;
      IFEND;

    = global_task_id_field =

      clp$convert_integer_to_rjstring (field_value_entry.global_task_id_value_p^.
            value_array [field_value_entry.value_index].index, 10, FALSE, '0', task_id_index, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

      clp$convert_integer_to_rjstring (field_value_entry.global_task_id_value_p^.
            value_array [field_value_entry.value_index].seqno, 10, FALSE, '0', task_id_seqno, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

      STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
            ptv$output_line_length, task_id_index, '-', task_id_seqno);

      IF field_value_entry.value_index = field_value_entry.global_task_id_value_p^.index THEN
        IF field_value_entry.global_task_id_value_p^.link_p <> NIL THEN
          field_value_entry.global_task_id_value_p := field_value_entry.global_task_id_value_p^.link_p;
          field_value_entry.value_index := 0;
        ELSE
          active_fields := active_fields - $active_fields_set [index];
          number_of_active_fields := number_of_active_fields - 1;
        IFEND;
      IFEND;

    = number_of_counters_field =

      clp$convert_integer_to_rjstring (field_value_entry.number_of_counters_value_p^.
            value_array [field_value_entry.value_index], 10, FALSE, ' ',
            ptv$output_line (report_entry_field.start_column, report_entry_field.column_width), status);

      IF field_value_entry.value_index = field_value_entry.number_of_counters_value_p^.index THEN
        IF field_value_entry.number_of_counters_value_p^.link_p <> NIL THEN
          field_value_entry.number_of_counters_value_p := field_value_entry.number_of_counters_value_p^.
                link_p;
          field_value_entry.value_index := 0;
        ELSE
          active_fields := active_fields - $active_fields_set [index];
          number_of_active_fields := number_of_active_fields - 1;
        IFEND;
      IFEND;

    = descriptive_data_size_field =

      clp$convert_integer_to_rjstring (field_value_entry.dd_size_value_p^.
            value_array [field_value_entry.value_index], 10, FALSE, ' ',
            ptv$output_line (report_entry_field.start_column, report_entry_field.column_width), status);

      IF field_value_entry.value_index = field_value_entry.dd_size_value_p^.index THEN
        IF field_value_entry.dd_size_value_p^.link_p <> NIL THEN
          field_value_entry.dd_size_value_p := field_value_entry.dd_size_value_p^.link_p;
          field_value_entry.value_index := 0;
        ELSE
          active_fields := active_fields - $active_fields_set [index];
          number_of_active_fields := number_of_active_fields - 1;
        IFEND;
      IFEND;

    = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =

      IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
        ptv$interval.millisecond := field_value_entry.elapsed_time_value_p^.
              value_array [field_value_entry.value_index];

        pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;

        clp$convert_date_time_to_string (clt_date_time, ptv$dt_format_for_increment, date_time_string,
              status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;

        ptv$output_line (report_entry_field.start_column + report_entry_field.column_width - ptc$time_length,
              report_entry_field.column_width) := date_time_string.value;

      ELSE {ptv$time_increment_format = 'SECONDS'

        STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
              ptv$output_line_length, $REAL (field_value_entry.elapsed_time_value_p^.
              value_array [field_value_entry.value_index]) * 0.001: report_entry_field.
              column_width: ptv$counter_fraction);

      IFEND;

      IF field_value_entry.value_index = field_value_entry.elapsed_time_value_p^.index THEN
        IF field_value_entry.elapsed_time_value_p^.link_p <> NIL THEN
          field_value_entry.elapsed_time_value_p := field_value_entry.elapsed_time_value_p^.link_p;
          field_value_entry.value_index := 0;
        ELSE
          active_fields := active_fields - $active_fields_set [index];
          number_of_active_fields := number_of_active_fields - 1;
        IFEND;
      IFEND;

    = value_per_second_field, occurrence_per_second_field =

      IF (field_value_entry.value_per_second_value_p^.value_array [field_value_entry.value_index] >= 0.0) OR
            (report_entry_field.field_p^.allow_negative_increment) THEN

        STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
              ptv$output_line_length, field_value_entry.value_per_second_value_p^.
              value_array [field_value_entry.value_index] * report_entry_field.field_p^.multiplier *
              1000.0: report_entry_field.column_width: ptv$counter_fraction);

      ELSE
        ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) := ptc$blanks;

      IFEND;

      IF field_value_entry.value_index = field_value_entry.value_per_second_value_p^.index THEN
        IF field_value_entry.value_per_second_value_p^.link_p <> NIL THEN
          field_value_entry.value_per_second_value_p := field_value_entry.value_per_second_value_p^.link_p;
          field_value_entry.value_index := 0;
        ELSE
          active_fields := active_fields - $active_fields_set [index];
          number_of_active_fields := number_of_active_fields - 1;
        IFEND;
      IFEND;

    = text_field =

    CASEND;

  PROCEND write_field_all_occurrences;

?? OLDTITLE ??
?? NEWTITLE := 'write_field_ao_report', EJECT ??

{ PURPOSE:
{   The purpose of this request is to write a field report when the display_option is all_occurrences.
{
{ DESIGN:
{   The procedure receives a pointer to a field entry.  The procedure writes the report headers, initializes
{ the report and while there is at least one active field (field with value that was not written) the
{ procedure writes report lines.

  PROCEDURE write_field_ao_report
    (    report_entry_p: ^put_entry;
     VAR status: ost$status);

    VAR
      active_fields: active_fields_set,
      index: integer,
      last_non_null_field: integer,
      number_of_active_fields: integer,
      output_line_length: integer,
      field_value_p: field_value_type;

    status.normal := TRUE;

    write_interval_header (report_entry_p, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    initialize_write_field_ao (report_entry_p, active_fields, field_value_p, last_non_null_field,
          number_of_active_fields, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

  /report/
    WHILE number_of_active_fields > 0 DO

{   Write one line of an all_occurrences field report.
{
{   Scan all the fields with the index range 1..last_non_null_field.  If the field is active,
{ call write_field_all_occurrences.  If the field is not active but it is a string field then
{ the string is placed in the report line.  Write the line into the output file.

      ptv$output_line := '';
      output_line_length := 0;

    /line/
      FOR index := LOWERBOUND (field_vector_type) TO last_non_null_field DO
        IF index IN active_fields THEN
          write_field_all_occurrences (report_entry_p^.field_vector [index], index, active_fields,
                number_of_active_fields, field_value_p [index], status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        ELSEIF report_entry_p^.field_vector [index].field_p^.field_type = text_field THEN

{   Field is a STRING. }

          ptv$output_line (report_entry_p^.field_vector [index].
                start_column, report_entry_p^.field_vector [index].column_width) :=
                report_entry_p^.field_vector [index].field_p^.descriptive_text_p^;

        IFEND;

{  Assumes fields printed in order of increasing start_column

        IF output_line_length < (report_entry_p^.field_vector [index].start_column +
              report_entry_p^.field_vector [index].column_width - 1) THEN
          output_line_length := report_entry_p^.field_vector [index].start_column +
                report_entry_p^.field_vector [index].column_width - 1;
        IFEND;
      FOREND /line/;

{   Once line is constructed, put it in its final form before output

      IF ptv$excel THEN
        convert_output_line_to_excel (report_entry_p, ptv$output_line, ptv$output_line,
              ptv$output_line_length);
      ELSE
        ptv$output_line_length := clp$trimmed_string_size (ptv$output_line (1, output_line_length));
      IFEND;

{   Put line to output file

      cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

    WHILEND /report/;

  PROCEND write_field_ao_report;

?? OLDTITLE ??
?? NEWTITLE := 'write_field_number', EJECT ??

{ PURPOSE:
{   The purpose of this request is to convert numeric values to strings for interval_field reports
{ and all_occurrences field reports.

  PROCEDURE write_field_number
    (    number: integer;
         field_vector_element: field_record_type;
     VAR status: ost$status);

    status.normal := TRUE;

    IF field_vector_element.field_p^.multiplier = 1.0 THEN
      clp$convert_integer_to_rjstring (number, 10, FALSE, ' ',
            ptv$output_line (field_vector_element.start_column, field_vector_element.column_width), status);
      IF NOT status.normal THEN
        IF status.condition = cle$string_too_short THEN
          ptv$output_line (field_vector_element.start_column, field_vector_element.column_width) := ptc$stars;
          status.normal := TRUE;
        ELSE
          RETURN; {----->
        IFEND;
      IFEND;
    ELSE
      STRINGREP (ptv$output_line (field_vector_element.start_column, field_vector_element.column_width),
            ptv$output_line_length, ($REAL (number) * field_vector_element.field_p^.
            multiplier): field_vector_element.column_width: ptv$counter_fraction);
    IFEND;

  PROCEND write_field_number;

?? OLDTITLE ??
?? NEWTITLE := 'write_field_report', EJECT ??

{ PURPOSE:
{   The purpose of this request is to write a field report.
{
{ DESIGN:
{   The procedure receives a pointer to a field entry.  For every non null summary in the field_vector the
{ procedures gets the required summary from the field.  The procedure places the string representation of
{ the summary in the output line in the specified report fields.
{
{ NOTE:
{  - In case of sum overflow during data collection the procedure writes '*' string in the report fields of
{    sum, mean, standard_deviation and sum_per_second.
{  - If the report field length is not enough to hold the summary string the procedure writes '*' string in
{    the report fields.

  PROCEDURE write_field_report
    (    report_entry_p: ^put_entry;
     VAR status: ost$status);

    VAR
      clt_date_time: [STATIC] clt$date_time := [ * , FALSE, TRUE],
      date_time_format_i: [STATIC] string (clc$max_date_time_form_string) := 'H24:MM:SS.S1000',
      date_time_string: ost$string,
      descriptive_data_length: integer,
      descriptive_data_start: integer,
      descriptive_p: ^sft$descriptive_data,
      index: integer,
      null_subfield: boolean,
      output_line_length: integer,
      statistic_name: ost$name,
      substring_found: boolean,
      task_id_index: string (ptc$task_id_index_string_size),
      task_id_seqno: string (ptc$task_id_seqno_string_size);

    status.normal := TRUE;

    ptv$output_line := '';
    output_line_length := 0;

    index := LOWERBOUND (field_vector_type);
    WHILE (index <= UPPERBOUND (field_vector_type)) AND (report_entry_p^.field_vector [index].
          summary <> null) DO

      CASE report_entry_p^.field_vector [index].summary OF

      = count =
        clp$convert_integer_to_rjstring (report_entry_p^.field_vector [index].field_p^.field_summary.count,
              10, FALSE, ' ', ptv$output_line (report_entry_p^.field_vector [index].start_column,
              report_entry_p^.field_vector [index].column_width), status);
        IF NOT status.normal THEN
          IF status.condition = cle$string_too_short THEN
            ptv$output_line (report_entry_p^.field_vector [index].
                  start_column, report_entry_p^.field_vector [index].column_width) := ptc$stars;
            status.normal := TRUE;
          ELSE
            RETURN; {----->
          IFEND;
        IFEND;

      = first_occurrence =
        CASE report_entry_p^.field_vector [index].field_p^.field_type OF

        = counter_field =
          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            write_field_number (report_entry_p^.field_vector [index].field_p^.first_counter_value,
                  report_entry_p^.field_vector [index], status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;

        = descriptive_data_field =
          IF report_entry_p^.field_vector [index].field_p^.first_descriptive_value_p <> NIL THEN
            get_descriptive_data_subfield (report_entry_p^.field_vector [index].field_p^.
                  first_descriptive_value_p, #SIZE (report_entry_p^.field_vector [index].field_p^.
                  first_descriptive_value_p^), report_entry_p^.field_vector [index].field_p^.
                  subfield_position, report_entry_p^.field_vector [index].field_p^.subfield_length,
                  report_entry_p^.field_vector [index].field_p^.subfield_number,
                  report_entry_p^.field_vector [index].field_p^.subfield_delimiter, null_subfield,
                  substring_found, descriptive_data_start, descriptive_data_length);
            ptv$output_line (report_entry_p^.field_vector [index].
                  start_column, report_entry_p^.field_vector [index].column_width) :=
                  report_entry_p^.field_vector [index].field_p^.first_descriptive_value_p^ (
                  descriptive_data_start, descriptive_data_length);
          IFEND;


        = date_time_field =
          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            ptv$clt_date_time.value := report_entry_p^.field_vector [index].field_p^.first_date_time_value;

            clp$convert_date_time_to_string (ptv$clt_date_time, ptv$date_time_format, date_time_string,
                  status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            ptv$output_line (report_entry_p^.field_vector [index].
                  start_column, report_entry_p^.field_vector [index].column_width) := date_time_string.value;
          IFEND;

        = statistic_code_field =
          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            sfp$convert_stat_code_to_name (report_entry_p^.field_vector [index].field_p^.
                  first_statistic_code_value, statistic_name, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            ptv$output_line (report_entry_p^.field_vector [index].
                  start_column, report_entry_p^.field_vector [index].column_width) := statistic_name;
          IFEND;

        = system_job_name_field =

          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            ptv$output_line (report_entry_p^.field_vector [index].
                  start_column, report_entry_p^.field_vector [index].column_width) :=
                  report_entry_p^.field_vector [index].field_p^.first_system_job_name_value;
          IFEND;

        = global_task_id_field =

          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            clp$convert_integer_to_rjstring (report_entry_p^.field_vector [index].field_p^.
                  first_global_task_id_value.index, 10, FALSE, '0', task_id_index, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            clp$convert_integer_to_rjstring (report_entry_p^.field_vector [index].field_p^.
                  first_global_task_id_value.seqno, 10, FALSE, '0', task_id_seqno, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                  report_entry_p^.field_vector [index].column_width), ptv$output_line_length, task_id_index,
                  '-', task_id_seqno);
          IFEND;

        = number_of_counters_field =

          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            clp$convert_integer_to_rjstring (report_entry_p^.field_vector [index].field_p^.
                  first_num_of_counters_value, 10, FALSE, ' ', ptv$output_line
                  (report_entry_p^.field_vector [index].start_column,
                  report_entry_p^.field_vector [index].column_width), status);

          IFEND;

        = descriptive_data_size_field =

          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            clp$convert_integer_to_rjstring (report_entry_p^.field_vector [index].field_p^.
                  first_dd_size_value, 10, FALSE, ' ', ptv$output_line
                  (report_entry_p^.field_vector [index].start_column,
                  report_entry_p^.field_vector [index].column_width), status);
          IFEND;

        = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =

          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
              ptv$interval.millisecond := report_entry_p^.field_vector [index].field_p^.
                    first_elapsed_time_value;

              pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              clp$convert_date_time_to_string (clt_date_time, ptv$dt_format_for_increment, date_time_string,
                    status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              ptv$output_line (report_entry_p^.field_vector [index].start_column +
                    report_entry_p^.field_vector [index].column_width - ptc$time_length,
                    report_entry_p^.field_vector [index].column_width) := date_time_string.value;
            ELSE {ptv$time_increment_format = 'SECONDS'

              STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                    report_entry_p^.field_vector [index].column_width),
                    ptv$output_line_length, $REAL (report_entry_p^.field_vector [index].field_p^.
                    first_elapsed_time_value) * 0.001: report_entry_p^.field_vector [index].column_width: 3);

            IFEND;
          IFEND;

        = value_per_second_field, occurrence_per_second_field =

          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                  report_entry_p^.field_vector [index].column_width), ptv$output_line_length,
                  report_entry_p^.field_vector [index].field_p^.first_value_per_second_value *
                  report_entry_p^.field_vector [index].field_p^.multiplier *
                  1000.0: report_entry_p^.field_vector [index].column_width: ptv$counter_fraction);
          IFEND;

        = text_field =

        CASEND;

      = last_occurrence =
        CASE report_entry_p^.field_vector [index].field_p^.field_type OF

        = counter_field =
          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            write_field_number (report_entry_p^.field_vector [index].field_p^.last_counter_value,
                  report_entry_p^.field_vector [index], status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;

        = descriptive_data_field =
          IF report_entry_p^.field_vector [index].field_p^.last_descriptive_value_p <> NIL THEN
            get_descriptive_data_subfield (report_entry_p^.field_vector [index].field_p^.
                  last_descriptive_value_p, #SIZE (report_entry_p^.field_vector [index].field_p^.
                  last_descriptive_value_p^), report_entry_p^.field_vector [index].field_p^.subfield_position,
                  report_entry_p^.field_vector [index].field_p^.subfield_length,
                  report_entry_p^.field_vector [index].field_p^.subfield_number,
                  report_entry_p^.field_vector [index].field_p^.subfield_delimiter, null_subfield,
                  substring_found, descriptive_data_start, descriptive_data_length);
            ptv$output_line (report_entry_p^.field_vector [index].
                  start_column, report_entry_p^.field_vector [index].column_width) :=
                  report_entry_p^.field_vector [index].field_p^.last_descriptive_value_p^ (
                  descriptive_data_start, descriptive_data_length);
          IFEND;


        = date_time_field =
          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            ptv$clt_date_time.value := report_entry_p^.field_vector [index].field_p^.last_date_time_value;

            clp$convert_date_time_to_string (ptv$clt_date_time, ptv$date_time_format, date_time_string,
                  status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            ptv$output_line (report_entry_p^.field_vector [index].
                  start_column, report_entry_p^.field_vector [index].column_width) := date_time_string.value;
          IFEND;

        = statistic_code_field =
          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            sfp$convert_stat_code_to_name (report_entry_p^.field_vector [index].field_p^.
                  last_statistic_code_value, statistic_name, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            ptv$output_line (report_entry_p^.field_vector [index].
                  start_column, report_entry_p^.field_vector [index].column_width) := statistic_name;
          IFEND;


        = system_job_name_field =

          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            ptv$output_line (report_entry_p^.field_vector [index].
                  start_column, report_entry_p^.field_vector [index].column_width) :=
                  report_entry_p^.field_vector [index].field_p^.last_system_job_name_value;
          IFEND;

        = global_task_id_field =

          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            clp$convert_integer_to_rjstring (report_entry_p^.field_vector [index].field_p^.
                  last_global_task_id_value.index, 10, FALSE, '0', task_id_index, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            clp$convert_integer_to_rjstring (report_entry_p^.field_vector [index].field_p^.
                  last_global_task_id_value.seqno, 10, FALSE, '0', task_id_seqno, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                  report_entry_p^.field_vector [index].column_width), ptv$output_line_length, task_id_index,
                  '-', task_id_seqno);
          IFEND;

        = number_of_counters_field =

          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            clp$convert_integer_to_rjstring (report_entry_p^.field_vector [index].field_p^.
                  last_num_of_counters_value, 10, FALSE, ' ', ptv$output_line
                  (report_entry_p^.field_vector [index].start_column,
                  report_entry_p^.field_vector [index].column_width), status);

          IFEND;

        = descriptive_data_size_field =

          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            clp$convert_integer_to_rjstring (report_entry_p^.field_vector [index].field_p^.last_dd_size_value,
                  10, FALSE, ' ', ptv$output_line (report_entry_p^.field_vector [index].start_column,
                  report_entry_p^.field_vector [index].column_width), status);
          IFEND;

        = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =

          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
              ptv$interval.millisecond := report_entry_p^.field_vector [index].field_p^.
                    last_elapsed_time_value;

              pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              clp$convert_date_time_to_string (clt_date_time, ptv$dt_format_for_increment, date_time_string,
                    status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              ptv$output_line (report_entry_p^.field_vector [index].start_column +
                    report_entry_p^.field_vector [index].column_width - ptc$time_length,
                    report_entry_p^.field_vector [index].column_width) := date_time_string.value;
            ELSE {ptv$time_increment_format = 'SECONDS'

              STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                    report_entry_p^.field_vector [index].column_width),
                    ptv$output_line_length, $REAL (report_entry_p^.field_vector [index].field_p^.
                    last_elapsed_time_value) * 0.001: report_entry_p^.field_vector [index].column_width: 3);

            IFEND;
          IFEND;

        = value_per_second_field, occurrence_per_second_field =

          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                  report_entry_p^.field_vector [index].column_width), ptv$output_line_length,
                  report_entry_p^.field_vector [index].field_p^.last_value_per_second_value *
                  report_entry_p^.field_vector [index].field_p^.multiplier *
                  1000.0: report_entry_p^.field_vector [index].column_width: ptv$counter_fraction);
          IFEND;

        = text_field =

        CASEND;

      = sum =

        IF NOT report_entry_p^.field_vector [index].field_p^.field_summary.sum_overflow THEN
          CASE report_entry_p^.field_vector [index].field_p^.field_type OF

          = value_per_second_field, occurrence_per_second_field =

            STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                  report_entry_p^.field_vector [index].column_width), ptv$output_line_length,
                  report_entry_p^.field_vector [index].field_p^.value_per_second_sum *
                  report_entry_p^.field_vector [index].field_p^.multiplier *
                  1000.0: report_entry_p^.field_vector [index].column_width: ptv$counter_fraction);

          = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =

            IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
              IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
                ptv$interval.millisecond := report_entry_p^.field_vector [index].field_p^.field_summary.sum;

                pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
                IF NOT status.normal THEN
                  RETURN; {----->
                IFEND;

                clp$convert_date_time_to_string (clt_date_time, ptv$dt_format_for_increment, date_time_string,
                      status);
                IF NOT status.normal THEN
                  RETURN; {----->
                IFEND;

                ptv$output_line (report_entry_p^.field_vector [index].start_column +
                      report_entry_p^.field_vector [index].column_width - ptc$time_length,
                      report_entry_p^.field_vector [index].column_width) := date_time_string.value;
              ELSE {ptv$time_increment_format = 'SECONDS'

                STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                      report_entry_p^.field_vector [index].column_width),
                      ptv$output_line_length, $REAL (report_entry_p^.field_vector [index].field_p^.
                      field_summary.sum) * 0.001: report_entry_p^.field_vector [index].
                      column_width: ptv$counter_fraction);

              IFEND;
            IFEND;

          ELSE { Other numeric field types have integer valued data

            write_field_number (report_entry_p^.field_vector [index].field_p^.field_summary.sum,
                  report_entry_p^.field_vector [index], status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          CASEND;
        ELSE
          ptv$output_line (report_entry_p^.field_vector [index].
                start_column, report_entry_p^.field_vector [index].column_width) := ptc$stars;
        IFEND;

      = mean =

        IF NOT report_entry_p^.field_vector [index].field_p^.field_summary.sum_overflow THEN
          CASE report_entry_p^.field_vector [index].field_p^.field_type OF

          = value_per_second_field, occurrence_per_second_field =

            STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                  report_entry_p^.field_vector [index].column_width), ptv$output_line_length,
                  report_entry_p^.field_vector [index].field_p^.field_summary.mean *
                  report_entry_p^.field_vector [index].field_p^.multiplier *
                  1000.0: report_entry_p^.field_vector [index].column_width: ptv$counter_fraction);

          = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =

            IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
              IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
                ptv$interval.millisecond := $INTEGER (report_entry_p^.field_vector [index].field_p^.
                      field_summary.mean);

                pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
                IF NOT status.normal THEN
                  RETURN; {----->
                IFEND;

                clp$convert_date_time_to_string (clt_date_time, ptv$dt_format_for_increment, date_time_string,
                      status);
                IF NOT status.normal THEN
                  RETURN; {----->
                IFEND;

                ptv$output_line (report_entry_p^.field_vector [index].start_column +
                      report_entry_p^.field_vector [index].column_width - ptc$time_length,
                      report_entry_p^.field_vector [index].column_width) := date_time_string.value;
              ELSE {ptv$time_increment_format = 'SECONDS'

                STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                      report_entry_p^.field_vector [index].column_width), ptv$output_line_length,
                      report_entry_p^.field_vector [index].field_p^.field_summary.mean *
                      0.001: report_entry_p^.field_vector [index].column_width: ptv$counter_fraction);

              IFEND;
            IFEND;

          ELSE

            STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                  report_entry_p^.field_vector [index].column_width), ptv$output_line_length,
                  report_entry_p^.field_vector [index].field_p^.field_summary.mean *
                  report_entry_p^.field_vector [index].field_p^.multiplier: report_entry_p^.
                  field_vector [index].column_width: ptv$counter_fraction);

          CASEND;
        ELSE
          ptv$output_line (report_entry_p^.field_vector [index].
                start_column, report_entry_p^.field_vector [index].column_width) := ptc$stars;
        IFEND;

      = standard_deviation =

        IF NOT report_entry_p^.field_vector [index].field_p^.field_summary.sum_overflow THEN
          CASE report_entry_p^.field_vector [index].field_p^.field_type OF

          = value_per_second_field, occurrence_per_second_field =

            STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                  report_entry_p^.field_vector [index].column_width), ptv$output_line_length,
                  report_entry_p^.field_vector [index].field_p^.field_summary.standard_deviation *
                  report_entry_p^.field_vector [index].field_p^.multiplier *
                  1000.0: report_entry_p^.field_vector [index].column_width: ptv$counter_fraction);

          = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =

            IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
              IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
                ptv$interval.millisecond := $INTEGER (report_entry_p^.field_vector [index].field_p^.
                      field_summary.standard_deviation);

                pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
                IF NOT status.normal THEN
                  RETURN; {----->
                IFEND;

                clp$convert_date_time_to_string (clt_date_time, ptv$dt_format_for_increment, date_time_string,
                      status);
                IF NOT status.normal THEN
                  RETURN; {----->
                IFEND;

                ptv$output_line (report_entry_p^.field_vector [index].start_column +
                      report_entry_p^.field_vector [index].column_width - ptc$time_length,
                      report_entry_p^.field_vector [index].column_width) := date_time_string.value;
              ELSE {ptv$time_increment_format = 'SECONDS'

                STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                      report_entry_p^.field_vector [index].column_width), ptv$output_line_length,
                      report_entry_p^.field_vector [index].field_p^.field_summary.standard_deviation *
                      0.001: report_entry_p^.field_vector [index].column_width: ptv$counter_fraction);

              IFEND;
            IFEND;

          ELSE

            STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                  report_entry_p^.field_vector [index].column_width), ptv$output_line_length,
                  report_entry_p^.field_vector [index].field_p^.field_summary.standard_deviation *
                  report_entry_p^.field_vector [index].field_p^.multiplier: report_entry_p^.
                  field_vector [index].column_width: ptv$counter_fraction);

          CASEND;
        ELSE
          ptv$output_line (report_entry_p^.field_vector [index].
                start_column, report_entry_p^.field_vector [index].column_width) := ptc$stars;
        IFEND;

      = minimum =

        CASE report_entry_p^.field_vector [index].field_p^.field_type OF

        = value_per_second_field, occurrence_per_second_field =

          STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                report_entry_p^.field_vector [index].column_width), ptv$output_line_length,
                report_entry_p^.field_vector [index].field_p^.value_per_second_minimum *
                report_entry_p^.field_vector [index].field_p^.multiplier *
                1000.0: report_entry_p^.field_vector [index].column_width: ptv$counter_fraction);

        = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =

          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
              ptv$interval.millisecond := report_entry_p^.field_vector [index].field_p^.field_summary.minimum;

              pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              clp$convert_date_time_to_string (clt_date_time, ptv$dt_format_for_increment, date_time_string,
                    status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              ptv$output_line (report_entry_p^.field_vector [index].start_column +
                    report_entry_p^.field_vector [index].column_width - ptc$time_length,
                    report_entry_p^.field_vector [index].column_width) := date_time_string.value;
            ELSE {ptv$time_increment_format = 'SECONDS'

              STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                    report_entry_p^.field_vector [index].column_width),
                    ptv$output_line_length, $REAL (report_entry_p^.field_vector [index].field_p^.
                    field_summary.minimum) * 0.001: report_entry_p^.field_vector [index].
                    column_width: ptv$counter_fraction);

            IFEND;
          IFEND;

        ELSE { Other numeric field types have integer valued data

          write_field_number (report_entry_p^.field_vector [index].field_p^.field_summary.minimum,
                report_entry_p^.field_vector [index], status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        CASEND;

      = maximum =

        CASE report_entry_p^.field_vector [index].field_p^.field_type OF

        = value_per_second_field, occurrence_per_second_field =

          STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                report_entry_p^.field_vector [index].column_width), ptv$output_line_length,
                report_entry_p^.field_vector [index].field_p^.value_per_second_maximum *
                report_entry_p^.field_vector [index].field_p^.multiplier *
                1000.0: report_entry_p^.field_vector [index].column_width: ptv$counter_fraction);

        = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =

          IF report_entry_p^.field_vector [index].field_p^.field_summary.count > 0 THEN
            IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
              ptv$interval.millisecond := report_entry_p^.field_vector [index].field_p^.field_summary.maximum;

              pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              clp$convert_date_time_to_string (clt_date_time, ptv$dt_format_for_increment, date_time_string,
                    status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              ptv$output_line (report_entry_p^.field_vector [index].start_column +
                    report_entry_p^.field_vector [index].column_width - ptc$time_length,
                    report_entry_p^.field_vector [index].column_width) := date_time_string.value;
            ELSE {ptv$time_increment_format = 'SECONDS'

              STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                    report_entry_p^.field_vector [index].column_width),
                    ptv$output_line_length, $REAL (report_entry_p^.field_vector [index].field_p^.
                    field_summary.maximum) * 0.001: report_entry_p^.field_vector [index].
                    column_width: ptv$counter_fraction);

            IFEND;
          IFEND;

        ELSE { Other numeric field types have integer valued data

          write_field_number (report_entry_p^.field_vector [index].field_p^.field_summary.maximum,
                report_entry_p^.field_vector [index], status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        CASEND;

      = interval =
        ptv$interval.millisecond := report_entry_p^.field_vector [index].field_p^.field_summary.interval;
        IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
          pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          clp$convert_date_time_to_string (clt_date_time, date_time_format_i, date_time_string, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          ptv$output_line (report_entry_p^.field_vector [index].
                start_column + report_entry_p^.field_vector [index].column_width - ptc$time_length,
                report_entry_p^.field_vector [index].column_width) := date_time_string.value (1, * );
        ELSE { ptv$time_increment_format = 'SECONDS'
          STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                report_entry_p^.field_vector [index].column_width), ptv$output_line_length,
                ($REAL (ptv$interval.millisecond) * 0.001): report_entry_p^.field_vector [index].
                column_width: 3);
        IFEND;

      = count_per_second =
        STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
              report_entry_p^.field_vector [index].column_width), ptv$output_line_length,
              report_entry_p^.field_vector [index].field_p^.field_summary.count_per_second: report_entry_p^.
              field_vector [index].column_width: ptv$counter_fraction);

      = sum_per_second =
        IF NOT report_entry_p^.field_vector [index].field_p^.field_summary.sum_overflow THEN
          STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                report_entry_p^.field_vector [index].column_width), ptv$output_line_length,
                report_entry_p^.field_vector [index].field_p^.field_summary.sum_per_second: report_entry_p^.
                field_vector [index].column_width: ptv$counter_fraction);
        ELSE
          ptv$output_line (report_entry_p^.field_vector [index].
                start_column, report_entry_p^.field_vector [index].column_width) := ptc$stars;
        IFEND;

      = elapsed_time_since_predecessor =
        ptv$interval.millisecond := report_entry_p^.field_vector [index].field_p^.field_summary.
              elapsed_time_since_predecessor;
        IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
          pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          clp$convert_date_time_to_string (clt_date_time, date_time_format_i, date_time_string, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          ptv$output_line (report_entry_p^.field_vector [index].
                start_column + report_entry_p^.field_vector [index].column_width - ptc$time_length,
                report_entry_p^.field_vector [index].column_width) := date_time_string.value (1, * );
        ELSE { ptv$time_increment_format = 'SECONDS'
          STRINGREP (ptv$output_line (report_entry_p^.field_vector [index].start_column,
                report_entry_p^.field_vector [index].column_width), ptv$output_line_length,
                ($REAL (ptv$interval.millisecond) * 0.001): report_entry_p^.field_vector [index].
                column_width: 3);
        IFEND;

      = text =
        IF report_entry_p^.field_vector [index].field_p^.descriptive_text_p <> NIL THEN
          ptv$output_line (report_entry_p^.field_vector [index].
                start_column, report_entry_p^.field_vector [index].column_width) :=
                report_entry_p^.field_vector [index].field_p^.descriptive_text_p^;
        IFEND;

      ELSE
      CASEND;

      IF output_line_length < (report_entry_p^.field_vector [index].start_column +
            report_entry_p^.field_vector [index].column_width - 1) THEN
        output_line_length := report_entry_p^.field_vector [index].start_column +
              report_entry_p^.field_vector [index].column_width - 1;
      IFEND;

      index := index + 1;
    WHILEND;

{  Prepare final format of line

    IF ptv$excel THEN
      convert_output_line_to_excel (report_entry_p, ptv$output_line, ptv$output_line, ptv$output_line_length);
    ELSE
      ptv$output_line_length := clp$trimmed_string_size (ptv$output_line (1, output_line_length));
    IFEND;

{  Put line to output file

    cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

  PROCEND write_field_report;

?? OLDTITLE ??
?? NEWTITLE := 'write_interval_header', EJECT ??

{ PURPOSE:
{   The purpose of this request is to write the report headers for an interval field report and
{ all_occurrences field report.

  PROCEDURE write_interval_header
    (    report_entry_p: ^put_entry;
     VAR status: ost$status);

    status.normal := TRUE;

{ Print interval headers

    IF report_entry_p^.header_1 <> ' ' THEN
      IF ptv$excel THEN
        convert_output_line_to_excel (report_entry_p, report_entry_p^.header_1, ptv$output_line,
              ptv$output_line_length);
      ELSE
        ptv$output_line_length := clp$trimmed_string_size (report_entry_p^.header_1);
        ptv$output_line := report_entry_p^.header_1 (1, ptv$output_line_length);
      IFEND;
      cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    IFEND;

    IF report_entry_p^.header_2 <> ' ' THEN
      IF ptv$excel THEN
        convert_output_line_to_excel (report_entry_p, report_entry_p^.header_2, ptv$output_line,
              ptv$output_line_length);
      ELSE
        ptv$output_line_length := clp$trimmed_string_size (report_entry_p^.header_1);
        ptv$output_line := report_entry_p^.header_2 (1, ptv$output_line_length);
      IFEND;
      cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    IFEND;

  PROCEND write_interval_header;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] write_interval_field', EJECT ??

{ PURPOSE:
{   The purpose of this request is to write a field in an interval field report line.
{
{ DESIGN:
{   This procedure has two parts.  The first part computes the summary and the second converts the summary to
{ string and places it in the report field postion.
{   Report_entry_p^.report_interval is the number of values that the procedure compute the summary from.  For
{ descriptive field if report_interval > 1 the procedure uses the first value and skips the rest.  If the
{ field runs out of values the procedure deletes the field from the active_fields set and decrements the
{ number of active fields.

  PROCEDURE [INLINE] write_interval_field
    (    report_entry_field: field_record_type;
         index: integer;
         report_interval: integer;
     VAR active_fields: active_fields_set;
     VAR number_of_active_fields: integer;
     VAR field_value_entry: field_value_pointers;
     VAR end_date_time: ost$date_time;
     VAR status: ost$status);

    VAR
      loop_count: integer,
      clt_date_time: clt$date_time,
      counter_value_real: real,
      date_time_format_i: string (clc$max_date_time_form_string),
      date_time_string: ost$string,
      dd_size_value_real: real,
      elapsed_time_value_real: real,
      mean_v: real,
      number_of_counters_value_real: real,
      descriptive_p: ^sft$descriptive_data,
      standard_deviation_v: real,
      statistic_name: ost$name,
      task_id_index: string (ptc$task_id_index_string_size),
      task_id_seqno: string (ptc$task_id_seqno_string_size),
      temp_interval: pmt$time_increment,
      field_summary: field_summary_type,
      interval_counter: integer,
      interval_date_time: ost$date_time,
      interval_dd_size: integer,
      interval_elapsed_time: integer,
      interval_global_task_id: ost$global_task_id,
      interval_number_of_counters: integer,
      interval_statistic_code: sft$statistic_code,
      interval_system_job_name: jmt$system_supplied_name,
      interval_value_per_second: real,
      value_per_second_value_real: real,
      value_per_second_sum: real,
      value_per_second_minimum: real,
      value_per_second_maximum: real;

    status.normal := TRUE;
    clt_date_time.date_specified := FALSE;
    clt_date_time.time_specified := TRUE;
    date_time_format_i := 'H24:MM:SS.S1000';

    field_summary := ptv$initial_field_summary;
    value_per_second_sum := 0.0;
    value_per_second_minimum := ptc$max_real;
    value_per_second_maximum := 0.0;

    CASE report_entry_field.field_p^.field_type OF

    = counter_field =
      loop_count := 0;

    /report_counter_interval/
      WHILE (index IN active_fields) AND (loop_count < report_interval) DO

        loop_count := loop_count + 1;

        IF field_value_entry.first AND report_entry_field.field_p^.incremental THEN
          field_value_entry.first := FALSE;
          end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
          IF report_interval = 1 THEN
            ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) := ptc$blanks;
            RETURN; {----->
          IFEND;
        ELSEIF (field_value_entry.counter_value_p^.value_array [field_value_entry.value_index + 1] >= 0) OR
              (report_entry_field.field_p^.allow_negative_increment) OR
              (NOT report_entry_field.field_p^.incremental) THEN

          field_value_entry.value_index := field_value_entry.value_index + 1;
          IF index = 1 THEN
            end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
          ELSE
            IF date_time_1_gt_date_time_2 (field_value_entry.date_time_p^.
                  value_array [field_value_entry.value_index], end_date_time ) THEN
              end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
            IFEND;
          IFEND;

          field_summary.count := field_summary.count + 1;
          CASE report_entry_field.summary OF

          = first_occurrence =
            IF field_summary.count = 1 THEN
              interval_counter := field_value_entry.counter_value_p^.
                    value_array [field_value_entry.value_index];
            IFEND;

          = count =

          = sum =
            field_summary.sum := field_summary.sum + field_value_entry.counter_value_p^.
                  value_array [field_value_entry.value_index];

          = mean =
            field_summary.sum := field_summary.sum + field_value_entry.counter_value_p^.
                  value_array [field_value_entry.value_index];

          = standard_deviation =
            field_summary.sum := field_summary.sum + field_value_entry.counter_value_p^.
                  value_array [field_value_entry.value_index];
            counter_value_real := $REAL (field_value_entry.counter_value_p^.
                  value_array [field_value_entry.value_index]);
            field_summary.square_sum := field_summary.square_sum + counter_value_real * counter_value_real;

          = minimum =
            IF field_summary.minimum > field_value_entry.counter_value_p^.
                  value_array [field_value_entry.value_index] THEN
              field_summary.minimum := field_value_entry.counter_value_p^.
                    value_array [field_value_entry.value_index];
            IFEND;

          = maximum =
            IF field_summary.maximum < field_value_entry.counter_value_p^.
                  value_array [field_value_entry.value_index] THEN
              field_summary.maximum := field_value_entry.counter_value_p^.
                    value_array [field_value_entry.value_index];
            IFEND;

          = interval, count_per_second, sum_per_second =
            IF (field_value_entry.skip_date_time_p <> NIL) AND
                  (field_value_entry.skip_date_time_p^.date_time_after_skip =
                  field_value_entry.date_time_p^.value_array [field_value_entry.value_index]) THEN
              pmp$compute_date_time_increment (field_value_entry.last_date_time,
                    field_value_entry.skip_date_time_p^.skip_date_time, temp_interval, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
              field_value_entry.lost_interval := field_value_entry.lost_interval +
                    interval_to_millisecond (temp_interval);
              field_value_entry.skip_date_time_p := field_value_entry.skip_date_time_p^.link_p;
            IFEND;

            field_value_entry.last_date_time := field_value_entry.date_time_p^.
                  value_array [field_value_entry.value_index];

            IF report_entry_field.summary = sum_per_second THEN
              field_summary.sum := field_summary.sum + field_value_entry.counter_value_p^.
                    value_array [field_value_entry.value_index];
            IFEND;

          = elapsed_time_since_predecessor =
            pmp$compute_date_time_increment (field_value_entry.predecessor_date_time_p^.
                  value_array [field_value_entry.value_index], field_value_entry.date_time_p^.
                  value_array [field_value_entry.value_index], temp_interval, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            field_summary.elapsed_time_since_predecessor := field_summary.elapsed_time_since_predecessor +
                  interval_to_millisecond (temp_interval);
            IF field_value_entry.value_index = field_value_entry.counter_value_p^.index THEN
              field_value_entry.predecessor_date_time_p := field_value_entry.predecessor_date_time_p^.link_p;
            IFEND;

          ELSE
          CASEND;

        ELSE { Incremental counter value is negative with no negative increment allowed
          field_value_entry.value_index := field_value_entry.value_index + 1;

        IFEND;

        IF field_value_entry.value_index = field_value_entry.counter_value_p^.index THEN
          IF field_value_entry.counter_value_p^.link_p <> NIL THEN
            field_value_entry.counter_value_p := field_value_entry.counter_value_p^.link_p;
            field_value_entry.date_time_p := field_value_entry.date_time_p^.link_p;
            field_value_entry.value_index := 0;
          ELSE
            active_fields := active_fields - $active_fields_set [index];
            number_of_active_fields := number_of_active_fields - 1;
          IFEND;
        IFEND;

      WHILEND /report_counter_interval/;

    = descriptive_data_field =

    /report_descriptive_interval/
      WHILE (index IN active_fields) AND (field_summary.count < report_interval) DO

        field_summary.count := field_summary.count + 1;
        field_value_entry.value_index := field_value_entry.value_index + 1;

        IF index = 1 THEN
          end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
        ELSE
          IF date_time_1_gt_date_time_2 (field_value_entry.date_time_p^.
                value_array [field_value_entry.value_index], end_date_time ) THEN
            end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
          IFEND;
        IFEND;

        IF field_summary.count = 1 THEN
          descriptive_p := field_value_entry.descriptive_value_p^.value_array [field_value_entry.value_index];
        IFEND;

        IF report_entry_field.summary = count_per_second THEN
          IF (field_value_entry.skip_date_time_p <> NIL) AND
                (field_value_entry.skip_date_time_p^.date_time_after_skip =
                field_value_entry.date_time_p^.value_array [field_value_entry.value_index]) THEN
            pmp$compute_date_time_increment (field_value_entry.last_date_time,
                  field_value_entry.skip_date_time_p^.skip_date_time, temp_interval, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            field_value_entry.lost_interval := field_value_entry.lost_interval +
                  interval_to_millisecond (temp_interval);
            field_value_entry.skip_date_time_p := field_value_entry.skip_date_time_p^.link_p;
          IFEND;

          field_value_entry.last_date_time := field_value_entry.date_time_p^.
                value_array [field_value_entry.value_index];
        IFEND;

        IF field_value_entry.value_index = field_value_entry.descriptive_value_p^.index THEN
          IF field_value_entry.descriptive_value_p^.link_p <> NIL THEN
            field_value_entry.descriptive_value_p := field_value_entry.descriptive_value_p^.link_p;
            field_value_entry.date_time_p := field_value_entry.date_time_p^.link_p;
            field_value_entry.value_index := 0;
          ELSE
            active_fields := active_fields - $active_fields_set [index];
            number_of_active_fields := number_of_active_fields - 1;
          IFEND;
        IFEND;

      WHILEND /report_descriptive_interval/;

    = date_time_field =

    /report_date_time_interval/
      WHILE (index IN active_fields) AND (field_summary.count < report_interval) DO

        field_summary.count := field_summary.count + 1;
        field_value_entry.value_index := field_value_entry.value_index + 1;

        IF index = 1 THEN
          end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
        ELSE
          IF date_time_1_gt_date_time_2 (field_value_entry.date_time_p^.
                value_array [field_value_entry.value_index], end_date_time ) THEN
            end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
          IFEND;
        IFEND;

        IF field_summary.count = 1 THEN
          interval_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
        IFEND;

        IF report_entry_field.summary = count_per_second THEN
          IF (field_value_entry.skip_date_time_p <> NIL) AND
                (field_value_entry.skip_date_time_p^.date_time_after_skip =
                field_value_entry.date_time_p^.value_array [field_value_entry.value_index]) THEN
            pmp$compute_date_time_increment (field_value_entry.last_date_time,
                  field_value_entry.skip_date_time_p^.skip_date_time, temp_interval, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            field_value_entry.lost_interval := field_value_entry.lost_interval +
                  interval_to_millisecond (temp_interval);
            field_value_entry.skip_date_time_p := field_value_entry.skip_date_time_p^.link_p;
          IFEND;

          field_value_entry.last_date_time := field_value_entry.date_time_p^.
                value_array [field_value_entry.value_index];
        IFEND;

        IF field_value_entry.value_index = field_value_entry.date_time_p^.index THEN
          IF field_value_entry.date_time_p^.link_p <> NIL THEN
            field_value_entry.date_time_p := field_value_entry.date_time_p^.link_p;
            field_value_entry.value_index := 0;
          ELSE
            active_fields := active_fields - $active_fields_set [index];
            number_of_active_fields := number_of_active_fields - 1;
          IFEND;
        IFEND;

      WHILEND /report_date_time_interval/;

    = statistic_code_field =

    /report_statistic_code_interval/
      WHILE (index IN active_fields) AND (field_summary.count < report_interval) DO

        field_summary.count := field_summary.count + 1;
        field_value_entry.value_index := field_value_entry.value_index + 1;

        IF index = 1 THEN
          end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
        ELSE
          IF date_time_1_gt_date_time_2 (field_value_entry.date_time_p^.
                value_array [field_value_entry.value_index], end_date_time ) THEN
            end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
          IFEND;
        IFEND;

        IF field_summary.count = 1 THEN
          interval_statistic_code := field_value_entry.statistic_code_value_p^.
                value_array [field_value_entry.value_index];
        IFEND;

        IF report_entry_field.summary = count_per_second THEN
          IF (field_value_entry.skip_date_time_p <> NIL) AND
                (field_value_entry.skip_date_time_p^.date_time_after_skip =
                field_value_entry.date_time_p^.value_array [field_value_entry.value_index]) THEN
            pmp$compute_date_time_increment (field_value_entry.last_date_time,
                  field_value_entry.skip_date_time_p^.skip_date_time, temp_interval, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            field_value_entry.lost_interval := field_value_entry.lost_interval +
                  interval_to_millisecond (temp_interval);
            field_value_entry.skip_date_time_p := field_value_entry.skip_date_time_p^.link_p;
          IFEND;

          field_value_entry.last_date_time := field_value_entry.date_time_p^.
                value_array [field_value_entry.value_index];
        IFEND;

        IF field_value_entry.value_index = field_value_entry.statistic_code_value_p^.index THEN
          IF field_value_entry.statistic_code_value_p^.link_p <> NIL THEN
            field_value_entry.statistic_code_value_p := field_value_entry.statistic_code_value_p^.link_p;
            field_value_entry.date_time_p := field_value_entry.date_time_p^.link_p;
            field_value_entry.value_index := 0;
          ELSE
            active_fields := active_fields - $active_fields_set [index];
            number_of_active_fields := number_of_active_fields - 1;
          IFEND;
        IFEND;

      WHILEND /report_statistic_code_interval/;

    = system_job_name_field =

    /report_system_job_name_interval/
      WHILE (index IN active_fields) AND (field_summary.count < report_interval) DO

        field_summary.count := field_summary.count + 1;
        field_value_entry.value_index := field_value_entry.value_index + 1;

        IF index = 1 THEN
          end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
        ELSE
          IF date_time_1_gt_date_time_2 (field_value_entry.date_time_p^.
                value_array [field_value_entry.value_index], end_date_time ) THEN
            end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
          IFEND;
        IFEND;

        IF field_summary.count = 1 THEN
          interval_system_job_name := field_value_entry.system_job_name_value_p^.
                value_array [field_value_entry.value_index];
        IFEND;

        IF report_entry_field.summary = count_per_second THEN
          IF (field_value_entry.skip_date_time_p <> NIL) AND
                (field_value_entry.skip_date_time_p^.date_time_after_skip =
                field_value_entry.date_time_p^.value_array [field_value_entry.value_index]) THEN
            pmp$compute_date_time_increment (field_value_entry.last_date_time,
                  field_value_entry.skip_date_time_p^.skip_date_time, temp_interval, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            field_value_entry.lost_interval := field_value_entry.lost_interval +
                  interval_to_millisecond (temp_interval);
            field_value_entry.skip_date_time_p := field_value_entry.skip_date_time_p^.link_p;
          IFEND;

          field_value_entry.last_date_time := field_value_entry.date_time_p^.
                value_array [field_value_entry.value_index];
        IFEND;

        IF field_value_entry.value_index = field_value_entry.system_job_name_value_p^.index THEN
          IF field_value_entry.system_job_name_value_p^.link_p <> NIL THEN
            field_value_entry.system_job_name_value_p := field_value_entry.system_job_name_value_p^.link_p;
            field_value_entry.date_time_p := field_value_entry.date_time_p^.link_p;
            field_value_entry.value_index := 0;
          ELSE
            active_fields := active_fields - $active_fields_set [index];
            number_of_active_fields := number_of_active_fields - 1;
          IFEND;
        IFEND;

      WHILEND /report_system_job_name_interval/;

    = global_task_id_field =

    /report_global_task_id_interval/
      WHILE (index IN active_fields) AND (field_summary.count < report_interval) DO

        field_summary.count := field_summary.count + 1;
        field_value_entry.value_index := field_value_entry.value_index + 1;

        IF index = 1 THEN
          end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
        ELSE
          IF date_time_1_gt_date_time_2 (field_value_entry.date_time_p^.
                value_array [field_value_entry.value_index], end_date_time ) THEN
            end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
          IFEND;
        IFEND;

        IF field_summary.count = 1 THEN
          interval_global_task_id := field_value_entry.global_task_id_value_p^.
                value_array [field_value_entry.value_index];
        IFEND;

        IF report_entry_field.summary = count_per_second THEN
          IF (field_value_entry.skip_date_time_p <> NIL) AND
                (field_value_entry.skip_date_time_p^.date_time_after_skip =
                field_value_entry.date_time_p^.value_array [field_value_entry.value_index]) THEN
            pmp$compute_date_time_increment (field_value_entry.last_date_time,
                  field_value_entry.skip_date_time_p^.skip_date_time, temp_interval, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            field_value_entry.lost_interval := field_value_entry.lost_interval +
                  interval_to_millisecond (temp_interval);
            field_value_entry.skip_date_time_p := field_value_entry.skip_date_time_p^.link_p;
          IFEND;

          field_value_entry.last_date_time := field_value_entry.date_time_p^.
                value_array [field_value_entry.value_index];
        IFEND;

        IF field_value_entry.value_index = field_value_entry.global_task_id_value_p^.index THEN
          IF field_value_entry.global_task_id_value_p^.link_p <> NIL THEN
            field_value_entry.global_task_id_value_p := field_value_entry.global_task_id_value_p^.link_p;
            field_value_entry.date_time_p := field_value_entry.date_time_p^.link_p;
            field_value_entry.value_index := 0;
          ELSE
            active_fields := active_fields - $active_fields_set [index];
            number_of_active_fields := number_of_active_fields - 1;
          IFEND;
        IFEND;

      WHILEND /report_global_task_id_interval/;

    = number_of_counters_field =

    /report_number_of_cnts_interval/
      WHILE (index IN active_fields) AND (field_summary.count < report_interval) DO

        field_summary.count := field_summary.count + 1;
        field_value_entry.value_index := field_value_entry.value_index + 1;

        IF index = 1 THEN
          end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
        ELSE
          IF date_time_1_gt_date_time_2 (field_value_entry.date_time_p^.
                value_array [field_value_entry.value_index], end_date_time ) THEN
            end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
          IFEND;
        IFEND;

        CASE report_entry_field.summary OF

        = first_occurrence =
          IF field_summary.count = 1 THEN
            interval_number_of_counters := field_value_entry.number_of_counters_value_p^.
                  value_array [field_value_entry.value_index];
          IFEND;

        = count =

        = sum =
          field_summary.sum := field_summary.sum + field_value_entry.number_of_counters_value_p^.
                value_array [field_value_entry.value_index];

        = mean =
          field_summary.sum := field_summary.sum + field_value_entry.number_of_counters_value_p^.
                value_array [field_value_entry.value_index];

        = standard_deviation =
          field_summary.sum := field_summary.sum + field_value_entry.number_of_counters_value_p^.
                value_array [field_value_entry.value_index];
          number_of_counters_value_real := $REAL (field_value_entry.number_of_counters_value_p^.
                value_array [field_value_entry.value_index]);
          field_summary.square_sum := field_summary.square_sum + number_of_counters_value_real *
                number_of_counters_value_real;

        = minimum =
          IF field_summary.minimum > field_value_entry.number_of_counters_value_p^.
                value_array [field_value_entry.value_index] THEN
            field_summary.minimum := field_value_entry.number_of_counters_value_p^.
                  value_array [field_value_entry.value_index];
          IFEND;

        = maximum =
          IF field_summary.maximum < field_value_entry.number_of_counters_value_p^.
                value_array [field_value_entry.value_index] THEN
            field_summary.maximum := field_value_entry.number_of_counters_value_p^.
                  value_array [field_value_entry.value_index];
          IFEND;

        = interval, count_per_second, sum_per_second =
          IF (field_value_entry.skip_date_time_p <> NIL) AND
                (field_value_entry.skip_date_time_p^.date_time_after_skip =
                field_value_entry.date_time_p^.value_array [field_value_entry.value_index]) THEN
            pmp$compute_date_time_increment (field_value_entry.last_date_time,
                  field_value_entry.skip_date_time_p^.skip_date_time, temp_interval, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            field_value_entry.lost_interval := field_value_entry.lost_interval +
                  interval_to_millisecond (temp_interval);
            field_value_entry.skip_date_time_p := field_value_entry.skip_date_time_p^.link_p;
          IFEND;

          field_value_entry.last_date_time := field_value_entry.date_time_p^.
                value_array [field_value_entry.value_index];

          IF report_entry_field.summary = sum_per_second THEN
            field_summary.sum := field_summary.sum + field_value_entry.number_of_counters_value_p^.
                  value_array [field_value_entry.value_index];
          IFEND;

        = elapsed_time_since_predecessor =
          pmp$compute_date_time_increment (field_value_entry.predecessor_date_time_p^.
                value_array [field_value_entry.value_index], field_value_entry.date_time_p^.
                value_array [field_value_entry.value_index], temp_interval, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          field_summary.elapsed_time_since_predecessor := field_summary.elapsed_time_since_predecessor +
                interval_to_millisecond (temp_interval);
          IF field_value_entry.value_index = field_value_entry.number_of_counters_value_p^.index THEN
            field_value_entry.predecessor_date_time_p := field_value_entry.predecessor_date_time_p^.link_p;
          IFEND;

        ELSE
        CASEND;

        IF field_value_entry.value_index = field_value_entry.number_of_counters_value_p^.index THEN
          IF field_value_entry.number_of_counters_value_p^.link_p <> NIL THEN
            field_value_entry.number_of_counters_value_p := field_value_entry.number_of_counters_value_p^.
                  link_p;
            field_value_entry.date_time_p := field_value_entry.date_time_p^.link_p;
            field_value_entry.value_index := 0;
          ELSE
            active_fields := active_fields - $active_fields_set [index];
            number_of_active_fields := number_of_active_fields - 1;
          IFEND;
        IFEND;

      WHILEND /report_number_of_cnts_interval/;

    = descriptive_data_size_field =

    /report_dd_size_interval/
      WHILE (index IN active_fields) AND (field_summary.count < report_interval) DO

        field_summary.count := field_summary.count + 1;
        field_value_entry.value_index := field_value_entry.value_index + 1;

        IF index = 1 THEN
          end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
        ELSE
          IF date_time_1_gt_date_time_2 (field_value_entry.date_time_p^.
                value_array [field_value_entry.value_index], end_date_time ) THEN
            end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
          IFEND;
        IFEND;

        CASE report_entry_field.summary OF

        = first_occurrence =
          IF field_summary.count = 1 THEN
            interval_dd_size := field_value_entry.dd_size_value_p^.
                  value_array [field_value_entry.value_index];
          IFEND;

        = count =

        = sum =
          field_summary.sum := field_summary.sum + field_value_entry.dd_size_value_p^.
                value_array [field_value_entry.value_index];

        = mean =
          field_summary.sum := field_summary.sum + field_value_entry.dd_size_value_p^.
                value_array [field_value_entry.value_index];

        = standard_deviation =
          field_summary.sum := field_summary.sum + field_value_entry.dd_size_value_p^.
                value_array [field_value_entry.value_index];
          dd_size_value_real := $REAL (field_value_entry.dd_size_value_p^.
                value_array [field_value_entry.value_index]);
          field_summary.square_sum := field_summary.square_sum + dd_size_value_real * dd_size_value_real;

        = minimum =
          IF field_summary.minimum > field_value_entry.dd_size_value_p^.
                value_array [field_value_entry.value_index] THEN
            field_summary.minimum := field_value_entry.dd_size_value_p^.
                  value_array [field_value_entry.value_index];
          IFEND;

        = maximum =
          IF field_summary.maximum < field_value_entry.dd_size_value_p^.
                value_array [field_value_entry.value_index] THEN
            field_summary.maximum := field_value_entry.dd_size_value_p^.
                  value_array [field_value_entry.value_index];
          IFEND;

        = interval, count_per_second, sum_per_second =
          IF (field_value_entry.skip_date_time_p <> NIL) AND
                (field_value_entry.skip_date_time_p^.date_time_after_skip =
                field_value_entry.date_time_p^.value_array [field_value_entry.value_index]) THEN
            pmp$compute_date_time_increment (field_value_entry.last_date_time,
                  field_value_entry.skip_date_time_p^.skip_date_time, temp_interval, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            field_value_entry.lost_interval := field_value_entry.lost_interval +
                  interval_to_millisecond (temp_interval);
            field_value_entry.skip_date_time_p := field_value_entry.skip_date_time_p^.link_p;
          IFEND;

          field_value_entry.last_date_time := field_value_entry.date_time_p^.
                value_array [field_value_entry.value_index];

          IF report_entry_field.summary = sum_per_second THEN
            field_summary.sum := field_summary.sum + field_value_entry.dd_size_value_p^.
                  value_array [field_value_entry.value_index];
          IFEND;

        = elapsed_time_since_predecessor =
          pmp$compute_date_time_increment (field_value_entry.predecessor_date_time_p^.
                value_array [field_value_entry.value_index], field_value_entry.date_time_p^.
                value_array [field_value_entry.value_index], temp_interval, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          field_summary.elapsed_time_since_predecessor := field_summary.elapsed_time_since_predecessor +
                interval_to_millisecond (temp_interval);
          IF field_value_entry.value_index = field_value_entry.dd_size_value_p^.index THEN
            field_value_entry.predecessor_date_time_p := field_value_entry.predecessor_date_time_p^.link_p;
          IFEND;

        ELSE
        CASEND;

        IF field_value_entry.value_index = field_value_entry.dd_size_value_p^.index THEN
          IF field_value_entry.dd_size_value_p^.link_p <> NIL THEN
            field_value_entry.dd_size_value_p := field_value_entry.dd_size_value_p^.link_p;
            field_value_entry.date_time_p := field_value_entry.date_time_p^.link_p;
            field_value_entry.value_index := 0;
          ELSE
            active_fields := active_fields - $active_fields_set [index];
            number_of_active_fields := number_of_active_fields - 1;
          IFEND;
        IFEND;

      WHILEND /report_dd_size_interval/;

    = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =
      loop_count := 0;

    /report_elapsed_time_interval/
      WHILE (index IN active_fields) AND (loop_count < report_interval) DO

        loop_count := loop_count + 1;

        IF field_value_entry.first AND (report_entry_field.field_p^.field_type = previous_occurrence_field)
              THEN

          field_value_entry.first := FALSE;

          IF report_interval = 1 THEN
            ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) := ptc$blanks;
            RETURN; {----->
          IFEND;
        ELSE

          field_value_entry.value_index := field_value_entry.value_index + 1;
          IF index = 1 THEN
            end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
          ELSE
            IF date_time_1_gt_date_time_2 (field_value_entry.date_time_p^.
                  value_array [field_value_entry.value_index], end_date_time ) THEN
              end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
            IFEND;
          IFEND;

          field_summary.count := field_summary.count + 1;
          CASE report_entry_field.summary OF

          = first_occurrence =
            IF field_summary.count = 1 THEN
              interval_elapsed_time := field_value_entry.elapsed_time_value_p^.
                    value_array [field_value_entry.value_index];
            IFEND;

          = count =

          = sum =
            field_summary.sum := field_summary.sum + field_value_entry.elapsed_time_value_p^.
                  value_array [field_value_entry.value_index];

          = mean =
            field_summary.sum := field_summary.sum + field_value_entry.elapsed_time_value_p^.
                  value_array [field_value_entry.value_index];

          = standard_deviation =
            field_summary.sum := field_summary.sum + field_value_entry.elapsed_time_value_p^.
                  value_array [field_value_entry.value_index];
            elapsed_time_value_real := $REAL (field_value_entry.elapsed_time_value_p^.
                  value_array [field_value_entry.value_index]);
            field_summary.square_sum := field_summary.square_sum + elapsed_time_value_real *
                  elapsed_time_value_real;

          = minimum =
            IF field_summary.minimum > field_value_entry.elapsed_time_value_p^.
                  value_array [field_value_entry.value_index] THEN
              field_summary.minimum := field_value_entry.elapsed_time_value_p^.
                    value_array [field_value_entry.value_index];
            IFEND;

          = maximum =
            IF field_summary.maximum < field_value_entry.elapsed_time_value_p^.
                  value_array [field_value_entry.value_index] THEN
              field_summary.maximum := field_value_entry.elapsed_time_value_p^.
                    value_array [field_value_entry.value_index];
            IFEND;

          = interval, count_per_second, sum_per_second =
            IF (field_value_entry.skip_date_time_p <> NIL) AND
                  (field_value_entry.skip_date_time_p^.date_time_after_skip =
                  field_value_entry.date_time_p^.value_array [field_value_entry.value_index]) THEN
              pmp$compute_date_time_increment (field_value_entry.last_date_time,
                    field_value_entry.skip_date_time_p^.skip_date_time, temp_interval, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
              field_value_entry.lost_interval := field_value_entry.lost_interval +
                    interval_to_millisecond (temp_interval);
              field_value_entry.skip_date_time_p := field_value_entry.skip_date_time_p^.link_p;
            IFEND;

            field_value_entry.last_date_time := field_value_entry.date_time_p^.
                  value_array [field_value_entry.value_index];

            IF report_entry_field.summary = sum_per_second THEN
              field_summary.sum := field_summary.sum + field_value_entry.elapsed_time_value_p^.
                    value_array [field_value_entry.value_index];
            IFEND;

          = elapsed_time_since_predecessor =
            pmp$compute_date_time_increment (field_value_entry.predecessor_date_time_p^.
                  value_array [field_value_entry.value_index], field_value_entry.date_time_p^.
                  value_array [field_value_entry.value_index], temp_interval, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            field_summary.elapsed_time_since_predecessor := field_summary.elapsed_time_since_predecessor +
                  interval_to_millisecond (temp_interval);
            IF field_value_entry.value_index = field_value_entry.elapsed_time_value_p^.index THEN
              field_value_entry.predecessor_date_time_p := field_value_entry.predecessor_date_time_p^.link_p;
            IFEND;

          ELSE
          CASEND;
        IFEND;

        IF field_value_entry.value_index = field_value_entry.elapsed_time_value_p^.index THEN
          IF field_value_entry.elapsed_time_value_p^.link_p <> NIL THEN
            field_value_entry.elapsed_time_value_p := field_value_entry.elapsed_time_value_p^.link_p;
            field_value_entry.date_time_p := field_value_entry.date_time_p^.link_p;
            field_value_entry.value_index := 0;
          ELSE
            active_fields := active_fields - $active_fields_set [index];
            number_of_active_fields := number_of_active_fields - 1;
          IFEND;
        IFEND;

      WHILEND /report_elapsed_time_interval/;

    = value_per_second_field, occurrence_per_second_field =
      loop_count := 0;

    /report_value_per_sec_interval/
      WHILE (index IN active_fields) AND (loop_count < report_interval) DO

        loop_count := loop_count + 1;

        IF field_value_entry.first AND ((report_entry_field.field_p^.incremental) OR
              (report_entry_field.field_p^.elapsed_time = previous_occurrence)) THEN

          field_value_entry.first := FALSE;
          IF report_interval = 1 THEN
            ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) := ptc$blanks;
            RETURN; {----->
          IFEND;

        ELSEIF (field_value_entry.value_per_second_value_p^.value_array [field_value_entry.value_index + 1] >=
              0.0) OR (report_entry_field.field_p^.allow_negative_increment) OR
              (NOT report_entry_field.field_p^.incremental) THEN

          field_value_entry.value_index := field_value_entry.value_index + 1;
          IF index = 1 THEN
            end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
          ELSE
            IF date_time_1_gt_date_time_2 (field_value_entry.date_time_p^.
                  value_array [field_value_entry.value_index], end_date_time ) THEN
              end_date_time := field_value_entry.date_time_p^.value_array [field_value_entry.value_index];
            IFEND;
          IFEND;

          field_summary.count := field_summary.count + 1;
          CASE report_entry_field.summary OF

          = first_occurrence =
            IF field_summary.count = 1 THEN
              interval_value_per_second := field_value_entry.value_per_second_value_p^.
                    value_array [field_value_entry.value_index];
            IFEND;

          = count =

          = sum =
            value_per_second_sum := value_per_second_sum + field_value_entry.value_per_second_value_p^.
                  value_array [field_value_entry.value_index];

          = mean =
            value_per_second_sum := value_per_second_sum + field_value_entry.value_per_second_value_p^.
                  value_array [field_value_entry.value_index];

          = standard_deviation =
            value_per_second_sum := value_per_second_sum + field_value_entry.value_per_second_value_p^.
                  value_array [field_value_entry.value_index];
            value_per_second_value_real := $REAL (field_value_entry.value_per_second_value_p^.
                  value_array [field_value_entry.value_index]);
            field_summary.square_sum := field_summary.square_sum + value_per_second_value_real *
                  value_per_second_value_real;

          = minimum =
            IF value_per_second_minimum > field_value_entry.value_per_second_value_p^.
                  value_array [field_value_entry.value_index] THEN
              value_per_second_minimum := field_value_entry.value_per_second_value_p^.
                    value_array [field_value_entry.value_index];
            IFEND;

          = maximum =
            IF value_per_second_maximum < field_value_entry.value_per_second_value_p^.
                  value_array [field_value_entry.value_index] THEN
              value_per_second_maximum := field_value_entry.value_per_second_value_p^.
                    value_array [field_value_entry.value_index];
            IFEND;

          = interval, count_per_second, sum_per_second =
            IF (field_value_entry.skip_date_time_p <> NIL) AND
                  (field_value_entry.skip_date_time_p^.date_time_after_skip =
                  field_value_entry.date_time_p^.value_array [field_value_entry.value_index]) THEN
              pmp$compute_date_time_increment (field_value_entry.last_date_time,
                    field_value_entry.skip_date_time_p^.skip_date_time, temp_interval, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
              field_value_entry.lost_interval := field_value_entry.lost_interval +
                    interval_to_millisecond (temp_interval);
              field_value_entry.skip_date_time_p := field_value_entry.skip_date_time_p^.link_p;
            IFEND;

            field_value_entry.last_date_time := field_value_entry.date_time_p^.
                  value_array [field_value_entry.value_index];

            IF report_entry_field.summary = sum_per_second THEN
              value_per_second_sum := value_per_second_sum + field_value_entry.value_per_second_value_p^.
                    value_array [field_value_entry.value_index];
            IFEND;

          = elapsed_time_since_predecessor =
            pmp$compute_date_time_increment (field_value_entry.predecessor_date_time_p^.
                  value_array [field_value_entry.value_index], field_value_entry.date_time_p^.
                  value_array [field_value_entry.value_index], temp_interval, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            field_summary.elapsed_time_since_predecessor := field_summary.elapsed_time_since_predecessor +
                  interval_to_millisecond (temp_interval);
            IF field_value_entry.value_index = field_value_entry.value_per_second_value_p^.index THEN
              field_value_entry.predecessor_date_time_p := field_value_entry.predecessor_date_time_p^.link_p;
            IFEND;

          ELSE
          CASEND;

        ELSE { Incremental value is negative with no negative increment allowed
          field_value_entry.value_index := field_value_entry.value_index + 1;

        IFEND;

        IF field_value_entry.value_index = field_value_entry.value_per_second_value_p^.index THEN
          IF field_value_entry.value_per_second_value_p^.link_p <> NIL THEN
            field_value_entry.value_per_second_value_p := field_value_entry.value_per_second_value_p^.link_p;
            field_value_entry.date_time_p := field_value_entry.date_time_p^.link_p;
            field_value_entry.value_index := 0;
          ELSE
            active_fields := active_fields - $active_fields_set [index];
            number_of_active_fields := number_of_active_fields - 1;
          IFEND;
        IFEND;

      WHILEND /report_value_per_sec_interval/;

    = text_field =

    CASEND;

    IF field_summary.count > 0 THEN

      CASE report_entry_field.summary OF

      = first_occurrence =

        CASE report_entry_field.field_p^.field_type OF

        = counter_field =
          write_field_number (interval_counter, report_entry_field, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

        = descriptive_data_field =

          IF descriptive_p <> NIL THEN
            ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) :=
                  descriptive_p^ (1, * );
          IFEND;

        = date_time_field =
          ptv$clt_date_time.value := interval_date_time;

          clp$convert_date_time_to_string (ptv$clt_date_time, ptv$date_time_format, date_time_string, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) :=
                date_time_string.value;

        = statistic_code_field =
          sfp$convert_stat_code_to_name (interval_statistic_code, statistic_name, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) :=
                statistic_name;

        = system_job_name_field =

          ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) :=
                interval_system_job_name;

        = global_task_id_field =

          clp$convert_integer_to_rjstring (interval_global_task_id.index, 10, FALSE, '0', task_id_index,
                status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          clp$convert_integer_to_rjstring (interval_global_task_id.seqno, 10, FALSE, '0', task_id_seqno,
                status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                ptv$output_line_length, task_id_index, '-', task_id_seqno);

        = number_of_counters_field =

          clp$convert_integer_to_rjstring (interval_number_of_counters, 10, FALSE, ' ',
                ptv$output_line (report_entry_field.start_column, report_entry_field.column_width), status);

        = descriptive_data_size_field =

          clp$convert_integer_to_rjstring (interval_dd_size, 10, FALSE, ' ',
                ptv$output_line (report_entry_field.start_column, report_entry_field.column_width), status);

        = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =

          IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
            ptv$interval.millisecond := interval_elapsed_time;

            pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            clp$convert_date_time_to_string (clt_date_time, ptv$dt_format_for_increment, date_time_string,
                  status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            ptv$output_line (report_entry_field.start_column + report_entry_field.column_width -
                  ptc$time_length, report_entry_field.column_width) := date_time_string.value;
          ELSE {ptv$time_increment_format = 'SECONDS'

            STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                  ptv$output_line_length, $REAL (interval_elapsed_time) *
                  0.001: report_entry_field.column_width: 3);

          IFEND;

        = value_per_second_field, occurrence_per_second_field =

          STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                ptv$output_line_length, interval_value_per_second * report_entry_field.field_p^.multiplier *
                1000.0: report_entry_field.column_width: ptv$counter_fraction);

        = text_field =

        CASEND;

      = count =
        clp$convert_integer_to_rjstring (field_summary.count, 10, FALSE, ' ',
              ptv$output_line (report_entry_field.start_column, report_entry_field.column_width), status);
        IF NOT status.normal THEN
          IF status.condition = cle$string_too_short THEN
            ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) := ptc$stars;
            status.normal := TRUE;
          ELSE
            RETURN; {----->
          IFEND;
        IFEND;

      = sum =

        CASE report_entry_field.field_p^.field_type OF

        = value_per_second_field, occurrence_per_second_field =

          STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                ptv$output_line_length, value_per_second_sum * report_entry_field.field_p^.multiplier *
                1000.0: report_entry_field.column_width: ptv$counter_fraction);

        = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =

          IF field_summary.count > 0 THEN
            IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
              ptv$interval.millisecond := field_summary.sum;

              pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              clp$convert_date_time_to_string (clt_date_time, ptv$dt_format_for_increment, date_time_string,
                    status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              ptv$output_line (report_entry_field.start_column + report_entry_field.column_width -
                    ptc$time_length, report_entry_field.column_width) := date_time_string.value;
            ELSE {ptv$time_increment_format = 'SECONDS'

              STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                    ptv$output_line_length, $REAL (field_summary.sum) *
                    0.001: report_entry_field.column_width: ptv$counter_fraction);

            IFEND;
          IFEND;

        ELSE { Other numeric field types have integer valued data

          write_field_number (field_summary.sum, report_entry_field, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        CASEND;

      = mean =

        CASE report_entry_field.field_p^.field_type OF

        = value_per_second_field, occurrence_per_second_field =

          IF field_summary.count > 0 THEN

            mean_v := value_per_second_sum / $REAL (field_summary.count);

            STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                  ptv$output_line_length, mean_v * report_entry_field.field_p^.multiplier *
                  1000.0: report_entry_field.column_width: ptv$counter_fraction);
          IFEND;

        = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =

          IF field_summary.count > 0 THEN

            mean_v := $REAL (field_summary.sum) / $REAL (field_summary.count);
            IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
              ptv$interval.millisecond := $INTEGER (mean_v);

              pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              clp$convert_date_time_to_string (clt_date_time, ptv$dt_format_for_increment, date_time_string,
                    status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              ptv$output_line (report_entry_field.start_column + report_entry_field.column_width -
                    ptc$time_length, report_entry_field.column_width) := date_time_string.value;
            ELSE {ptv$time_increment_format = 'SECONDS'

              STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                    ptv$output_line_length, mean_v * 0.001: report_entry_field.column_width:
                    ptv$counter_fraction);

            IFEND;
          IFEND;

        ELSE
          IF field_summary.count > 0 THEN

            mean_v := $REAL (field_summary.sum) / $REAL (field_summary.count);

            STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                  ptv$output_line_length, mean_v * report_entry_field.field_p^.multiplier: report_entry_field.
                  column_width: ptv$counter_fraction);

          IFEND;
        CASEND;

      = standard_deviation =

        CASE report_entry_field.field_p^.field_type OF

        = value_per_second_field, occurrence_per_second_field =

          IF field_summary.count > 1 THEN

            mean_v := value_per_second_sum / $REAL (field_summary.count);
            standard_deviation_v := (field_summary.square_sum + mean_v * mean_v *
                  $REAL (field_summary.count) - 2.0 * mean_v * value_per_second_sum) /
                  $REAL (field_summary.count - 1);
            standard_deviation_v := mlp$rsqrt (standard_deviation_v);

            STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                  ptv$output_line_length, standard_deviation_v * report_entry_field.field_p^.multiplier *
                  1000.0: report_entry_field.column_width: ptv$counter_fraction);
          IFEND;

        = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =

          IF field_summary.count > 1 THEN

            mean_v := $REAL (field_summary.sum) / $REAL (field_summary.count);
            standard_deviation_v := (field_summary.square_sum + mean_v * mean_v *
                  $REAL (field_summary.count) - 2.0 * mean_v * $REAL (field_summary.sum)) /
                  $REAL (field_summary.count - 1);
            standard_deviation_v := mlp$rsqrt (standard_deviation_v);

            IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
              ptv$interval.millisecond := $INTEGER (standard_deviation_v);

              pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              clp$convert_date_time_to_string (clt_date_time, ptv$dt_format_for_increment, date_time_string,
                    status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              ptv$output_line (report_entry_field.start_column + report_entry_field.column_width -
                    ptc$time_length, report_entry_field.column_width) := date_time_string.value;
            ELSE {ptv$time_increment_format = 'SECONDS'

              STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                    ptv$output_line_length, standard_deviation_v *
                    0.001: report_entry_field.column_width: ptv$counter_fraction);

            IFEND;
          IFEND;

        ELSE

          IF field_summary.count > 1 THEN

            mean_v := $REAL (field_summary.sum) / $REAL (field_summary.count);
            standard_deviation_v := (field_summary.square_sum + mean_v * mean_v *
                  $REAL (field_summary.count) - 2.0 * mean_v * $REAL (field_summary.sum)) /
                  $REAL (field_summary.count - 1);
            standard_deviation_v := mlp$rsqrt (standard_deviation_v);

            STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                  ptv$output_line_length, standard_deviation_v *
                  report_entry_field.field_p^.multiplier: report_entry_field.column_width:
                  ptv$counter_fraction);

          IFEND;
        CASEND;

      = minimum =

        CASE report_entry_field.field_p^.field_type OF

        = value_per_second_field, occurrence_per_second_field =

          STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                ptv$output_line_length, value_per_second_minimum * report_entry_field.field_p^.multiplier *
                1000.0: report_entry_field.column_width: ptv$counter_fraction);

        = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =

          IF field_summary.count > 0 THEN
            IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
              ptv$interval.millisecond := field_summary.minimum;

              pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              clp$convert_date_time_to_string (clt_date_time, ptv$dt_format_for_increment, date_time_string,
                    status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              ptv$output_line (report_entry_field.start_column + report_entry_field.column_width -
                    ptc$time_length, report_entry_field.column_width) := date_time_string.value;
            ELSE {ptv$time_increment_format = 'SECONDS'

              STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                    ptv$output_line_length, $REAL (field_summary.minimum) *
                    0.001: report_entry_field.column_width: ptv$counter_fraction);

            IFEND;
          IFEND;

        ELSE { Other numeric field types have integer valued data

          write_field_number (field_summary.minimum, report_entry_field, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        CASEND;

      = maximum =

        CASE report_entry_field.field_p^.field_type OF

        = value_per_second_field, occurrence_per_second_field =

          STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                ptv$output_line_length, value_per_second_maximum * report_entry_field.field_p^.multiplier *
                1000.0: report_entry_field.column_width: ptv$counter_fraction);

        = previous_occurrence_field, predecessor_field, predecessor_chain_head_field =

          IF field_summary.count > 0 THEN
            IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
              ptv$interval.millisecond := field_summary.maximum;

              pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              clp$convert_date_time_to_string (clt_date_time, ptv$dt_format_for_increment, date_time_string,
                    status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              ptv$output_line (report_entry_field.start_column + report_entry_field.column_width -
                    ptc$time_length, report_entry_field.column_width) := date_time_string.value;
            ELSE {ptv$time_increment_format = 'SECONDS'

              STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                    ptv$output_line_length, $REAL (field_summary.maximum) *
                    0.001: report_entry_field.column_width: ptv$counter_fraction);

            IFEND;
          IFEND;

        ELSE { Other numeric field types have integer valued data

          write_field_number (field_summary.maximum, report_entry_field, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        CASEND;

      = interval, count_per_second, sum_per_second =

        pmp$compute_date_time_increment (field_value_entry.first_date_time, field_value_entry.last_date_time,
              temp_interval, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;

        field_summary.interval := (interval_to_millisecond (temp_interval) - field_value_entry.lost_interval);

        field_value_entry.first_date_time := field_value_entry.last_date_time;
        field_value_entry.lost_interval := 0;

        CASE report_entry_field.summary OF

        = interval =
          IF field_value_entry.first AND (field_summary.count > 1) THEN
            ptv$interval.millisecond := field_summary.interval DIV (field_summary.count - 1);
            field_value_entry.first := FALSE;
          ELSE
            ptv$interval.millisecond := field_summary.interval DIV (field_summary.count);
          IFEND;
          IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
            pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            clp$convert_date_time_to_string (clt_date_time, date_time_format_i, date_time_string, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            ptv$output_line (report_entry_field.start_column + report_entry_field.column_width -
                  ptc$time_length, report_entry_field.column_width) := date_time_string.value (1, * );
          ELSE { ptv$time_increment_format = 'SECONDS'
            STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                  ptv$output_line_length, ($REAL (ptv$interval.millisecond) *
                  0.001): report_entry_field.column_width: 3);
          IFEND;

        = count_per_second =
          IF field_summary.interval > 0 THEN
            STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                  ptv$output_line_length, ($REAL (field_summary.count) / $REAL (field_summary.interval) *
                  1000.0): report_entry_field.column_width: ptv$counter_fraction);
          IFEND;

        = sum_per_second =
          IF field_summary.interval > 0 THEN
            STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                  ptv$output_line_length, ($REAL (field_summary.sum) *
                  report_entry_field.field_p^.multiplier / $REAL (field_summary.interval) *
                  1000.0): report_entry_field.column_width: ptv$counter_fraction);
          IFEND;

        ELSE
        CASEND;

      = elapsed_time_since_predecessor =
        ptv$interval.millisecond := field_summary.elapsed_time_since_predecessor DIV field_summary.count;
        IF ptv$time_increment_format = 'TIME_INCREMENT' THEN
          pmp$compute_date_time (ptv$min_date_time, ptv$interval, clt_date_time.value, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          clp$convert_date_time_to_string (clt_date_time, date_time_format_i, date_time_string, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          ptv$output_line (report_entry_field.start_column + report_entry_field.column_width -
                ptc$time_length, report_entry_field.column_width) := date_time_string.value (1, * );
        ELSE { ptv$time_increment_format = 'SECONDS'
          STRINGREP (ptv$output_line (report_entry_field.start_column, report_entry_field.column_width),
                ptv$output_line_length, ($REAL (ptv$interval.millisecond) *
                0.001): report_entry_field.column_width: 3);
        IFEND;

      = text =
        IF descriptive_p <> NIL THEN
          ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) :=
                descriptive_p^ (1, * );
        IFEND;

      ELSE
      CASEND;

    ELSE {field_summary.count = 0
      ptv$output_line (report_entry_field.start_column, report_entry_field.column_width) := ptc$blanks;

    IFEND;

  PROCEND write_interval_field;

?? OLDTITLE ??
?? NEWTITLE := 'write_interval_report', EJECT ??

{ PURPOSE:
{   The purpose of this request is to write an interval field report.
{
{ DESIGN:
{   The procedure receives a pointer to an interval field entry.  The procedure writes the report headers,
{ initializes the report and while there is at least one active field (field with value that was not written)
{ the procedure writes report lines.
{   The procedure scans all the fields with the index range 1..last_non_null_field.  If the field is active
{ the procedure calls write_interval_field.  If the field is not active but it is a string field then the
{ string is placed in the report line.  If the report row_label_type is start_time, end_time or time_range
{ then the procedure converts end_date_time to string.  The procedure adds the row_label to the report line
{ and writes the line into the output file.

  PROCEDURE write_interval_report
    (    report_entry_p: ^put_entry;
     VAR status: ost$status);

    VAR
      active_fields: active_fields_set,
      begin_date_time: ost$date_time,
      begin_date_time_string: ost$string,
      clt_date_time: [STATIC] clt$date_time := [ * , FALSE, TRUE],
      date_time_format_i: [STATIC] string (clc$max_date_time_form_string) := 'H24:MM:SS.S1000',
      date_time_string: ost$string,
      end_date_time: ost$date_time,
      end_date_time_string: ost$string,
      field_p: ^field,
      field_value_p: field_value_type,
      index: integer,
      last_non_null_field: integer,
      number_of_active_fields: integer,
      output_line_length: integer;

    status.normal := TRUE;
    end_date_time := ptv$min_date_time;

    write_interval_header (report_entry_p, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    initialize_write_interval (report_entry_p, active_fields, begin_date_time, field_value_p,
          last_non_null_field, number_of_active_fields, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    IF (report_entry_p^.row_label_type <> row_label_none) AND
          (report_entry_p^.row_label_type <> string_label) THEN
      ptv$clt_date_time.value := begin_date_time;
      clp$convert_date_time_to_string (ptv$clt_date_time, report_entry_p^.date_time_format_p^,
            begin_date_time_string, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    IFEND;

  /report/
    WHILE number_of_active_fields > 0 DO

{  Write one line of report
{    Initialize line

      ptv$output_line := '';
      output_line_length := 0;

    /line/

{  Format each field in report line

      FOR index := LOWERBOUND (field_vector_type) TO last_non_null_field DO
        IF index IN active_fields THEN

          write_interval_field (report_entry_p^.field_vector [index], index, report_entry_p^.report_interval,
                active_fields, number_of_active_fields, field_value_p [index], end_date_time, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

        ELSEIF report_entry_p^.field_vector [index].field_p^.field_type = text_field THEN
          { Field is a STRING. }
          ptv$output_line (report_entry_p^.field_vector [index].
                start_column, report_entry_p^.field_vector [index].column_width) :=
                report_entry_p^.field_vector [index].field_p^.descriptive_text_p^;
        IFEND;

        IF output_line_length < (report_entry_p^.field_vector [index].start_column +
              report_entry_p^.field_vector [index].column_width - 1) THEN
          output_line_length := report_entry_p^.field_vector [index].start_column +
                report_entry_p^.field_vector [index].column_width - 1;
        IFEND
      FOREND /line/;

{  Format row label of report line.  Is it date_time or a string?

      IF (report_entry_p^.row_label_type <> row_label_none) AND
            (report_entry_p^.row_label_type <> string_label) THEN

        ptv$clt_date_time.value := end_date_time;
        clp$convert_date_time_to_string (ptv$clt_date_time, report_entry_p^.date_time_format_p^,
              end_date_time_string, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;

        CASE report_entry_p^.row_label_type OF
        = start_time =
          ptv$output_line (report_entry_p^.date_time_start_column,
                report_entry_p^.date_time_column_width) := begin_date_time_string.value;

        = end_time =
          ptv$output_line (report_entry_p^.date_time_start_column,
                report_entry_p^.date_time_column_width) := end_date_time_string.value;

        = time_range =
          STRINGREP (ptv$output_line (report_entry_p^.date_time_start_column,
                report_entry_p^.date_time_column_width), ptv$output_line_length,
                begin_date_time_string.value (1, begin_date_time_string.size), ' .. ',
                end_date_time_string.value (1, end_date_time_string.size));

        ELSE
        CASEND;

        begin_date_time := end_date_time;
        begin_date_time_string := end_date_time_string;

      ELSEIF report_entry_p^.row_label_type = string_label THEN
        ptv$output_line (report_entry_p^.date_time_start_column,
              report_entry_p^.date_time_column_width) := report_entry_p^.row_label;
      IFEND;

{  Prepare final format of report line

      IF ptv$excel THEN
        convert_output_line_to_excel (report_entry_p, ptv$output_line, ptv$output_line,
              ptv$output_line_length);
      ELSE
        ptv$output_line_length := clp$trimmed_string_size (ptv$output_line (1, output_line_length));
      IFEND;

{  Output report line

      cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

    WHILEND /report/;

  PROCEND write_interval_report;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] write_statistic_header', EJECT ??

{ PURPOSE:
{   The purpose of this request is to convert a statistic header to a string for
{ write_statistic_to_legible_log and write_statistic_to_list_log.
{
{ DESIGN:
{   The procedure converts the statistic code, date_time, global task ID, number of counters and descriptive
{ data size to strings.  It concatenate the strings with system job name to form one string.

  PROCEDURE [INLINE] write_statistic_header
    (    statistic_header_p: ^sft$statistic_header;
         descriptive_data_length: integer;
     VAR output_line: string ( * );
     VAR output_line_length: integer;
     VAR status: ost$status);

    VAR
      counter: string (ptc$length_of_counter_field),
      date_time_string: ost$string,
      descriptive_data_length_string: string (ptc$ddl_string_size),
      number_of_counters_string: string (ptc$num_of_counter_string_size),
      statistic_name: ost$name,
      task_id_index: string (ptc$task_id_index_string_size),
      task_id_seqno: string (ptc$task_id_seqno_string_size);

    status.normal := TRUE;

    sfp$convert_stat_code_to_name (statistic_header_p^.statistic_code, statistic_name, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    ptv$clt_date_time.value := statistic_header_p^.date_time;
    clp$convert_date_time_to_string (ptv$clt_date_time, ptv$date_time_format, date_time_string, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    clp$convert_integer_to_rjstring (statistic_header_p^.task_id.index, 10, FALSE, '0', task_id_index,
          status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    clp$convert_integer_to_rjstring (statistic_header_p^.task_id.seqno, 10, FALSE, '0', task_id_seqno,
          status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    IF ptv$number_of_counters.float THEN
      clp$convert_integer_to_rjstring (statistic_header_p^.number_of_counters, 10, FALSE, ' ',
            number_of_counters_string, status);
    ELSE
      clp$convert_integer_to_rjstring (ptv$number_of_counters.number, 10, FALSE, ' ',
            number_of_counters_string, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    IF ptv$descriptive_data_size.float THEN
      clp$convert_integer_to_rjstring (descriptive_data_length, 10, FALSE, ' ',
            descriptive_data_length_string, status);
    ELSE
      clp$convert_integer_to_rjstring (ptv$descriptive_data_size.number, 10, FALSE, ' ',
            descriptive_data_length_string, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    STRINGREP (output_line, output_line_length, statistic_name (1, 7),
          '  ', date_time_string.value (1, date_time_string.size): date_time_string.size, '  ',
          statistic_header_p^.job_name, '  ', { job_name: jmt$system_supplied_name,   }
          task_id_index, '-', task_id_seqno, '  ', number_of_counters_string, '  ',
          descriptive_data_length_string);

  PROCEND write_statistic_header;

?? OLDTITLE ??
?? NEWTITLE := 'write_statistic_to_binary_log', EJECT ??

{ PURPOSE:
{  The purpose of this request is to write a statistic record into binary log file.
{
{ DESIGN:
{   The procedure receives 3 pointers:
{    -  pointer to the statistic header.
{    -  pointer to the counters array.
{    -  pointer to the descriptive data string.
{   If the statistic record is written into the output log without any changes from the input (number of
{ counters, descriptive data size etc.) then the procedure calls put_statistic_record with the original
{ pointers.  Otherwise  the procedure creates a new statistic record with 3 new pointers, copies the
{ data with the required changes from the input record into the output record and calls put_statistic_record
{ with the new pointers.
{
{ NOTE:
{ - The procedure processes the log_entry counter base to in order to write only the required counters.
{ - The procedure processes ptv$number_of_counter in order to write a fixed number of counters or a floating
{   number.
{   - If the number of counters is fixed and fewer than the number of available counters from the statistic
{     (after processing the log_entry counter base) the procedure ignores the extra counters.
{   - If the number of counters is fixed and more than the number of available counters from the statistic
{     (after processing the log_entry counter base) the procedure pads the output log with zero values.
{ - This procedure uses the base in the log_entry counter base only to delete counters (base 0).

  PROCEDURE write_statistic_to_binary_log
    (    log_entry_p: ^put_entry;
         statistic_header_p: ^sft$statistic_header;
         counters_p: sft$counters;
         descriptive_data_in_p: ^sft$descriptive_data;
     VAR status: ost$status);

    VAR
      counters_out_p: sft$counters,
      descriptive_data_length: integer,
      descriptive_data_out_p: ^sft$descriptive_data,
      descriptive_data_p: ^sft$descriptive_data,
      descriptive_data_start: integer,
      index: integer,
      log_header_out_p: ^bat$record_header,
      null_subfield: boolean,
      number_of_counters: integer,
      statistic_header_out_p: ^sft$statistic_header,
      substring_found: boolean;

    status.normal := TRUE;

    IF log_entry_p^.descriptive_text_p = NIL THEN
      descriptive_data_p := descriptive_data_in_p;
      get_descriptive_data_subfield (descriptive_data_p, statistic_header_p^.descriptive_data_size,
            log_entry_p^.subfield_position, log_entry_p^.subfield_length, log_entry_p^.subfield_number,
            log_entry_p^.subfield_delimiter, null_subfield, substring_found, descriptive_data_start,
            descriptive_data_length);
    ELSE
      descriptive_data_p := log_entry_p^.descriptive_text_p;
      descriptive_data_start := 1;
      descriptive_data_length := #SIZE (log_entry_p^.descriptive_text_p^);
    IFEND;

    IF ptv$number_of_counters.float AND ptv$descriptive_data_size.float AND
          NOT log_entry_p^.delete_counters AND (statistic_header_p^.descriptive_data_size =
          descriptive_data_length) THEN
      put_statistic_record (ptv$output_log_p, statistic_header_p, counters_p, descriptive_data_p, status);
    ELSE
      PUSH statistic_header_out_p;
      statistic_header_out_p^ := statistic_header_p^;
      IF ptv$number_of_counters.float AND NOT log_entry_p^.delete_counters THEN
        counters_out_p := counters_p;
      ELSEIF ptv$number_of_counters.float THEN

{ delete_counters

        number_of_counters := 0;
        FOR index := 1 TO statistic_header_p^.number_of_counters DO
          IF log_entry_p^.counter_base [index] <> base_0 THEN
            number_of_counters := number_of_counters + 1;
          IFEND;
        FOREND;
        statistic_header_out_p^.number_of_counters := number_of_counters;
        IF number_of_counters > 0 THEN
          PUSH counters_out_p: [1 .. statistic_header_out_p^.number_of_counters];
          number_of_counters := 1;
          FOR index := 1 TO statistic_header_p^.number_of_counters DO
            IF log_entry_p^.counter_base [index] <> base_0 THEN
              counters_out_p^ [number_of_counters] := counters_p^ [index];
              number_of_counters := number_of_counters + 1;
            IFEND;
          FOREND;
        ELSE
          counters_out_p := NIL;
        IFEND;
      ELSE
        statistic_header_out_p^.number_of_counters := ptv$number_of_counters.number;
        IF ptv$number_of_counters.number > 0 THEN
          PUSH counters_out_p: [1 .. statistic_header_out_p^.number_of_counters];
          index := 1;
          number_of_counters := 1;
          WHILE (number_of_counters <= ptv$number_of_counters.number) AND
                (index <= statistic_header_p^.number_of_counters) DO
            IF log_entry_p^.counter_base [index] <> base_0 THEN
              counters_out_p^ [number_of_counters] := counters_p^ [index];
              number_of_counters := number_of_counters + 1;
            IFEND;
            index := index + 1;
          WHILEND;
          FOR index := number_of_counters TO ptv$number_of_counters.number DO
            counters_out_p^ [index] := 0;
          FOREND;
        ELSE
          counters_out_p := NIL;
        IFEND;
      IFEND;

      IF ptv$descriptive_data_size.float THEN
        IF descriptive_data_length <> 0 THEN
          IF statistic_header_p^.descriptive_data_size = descriptive_data_length THEN
            descriptive_data_out_p := descriptive_data_p;
          ELSE
            statistic_header_out_p^.descriptive_data_size := ptv$descriptive_data_size.number;
            PUSH descriptive_data_out_p: [statistic_header_out_p^.descriptive_data_size];
            descriptive_data_out_p^ := descriptive_data_p^ (descriptive_data_start, descriptive_data_length);
          IFEND;
        IFEND;
      ELSE
        IF ptv$descriptive_data_size.number > 0 THEN
          statistic_header_out_p^.descriptive_data_size := ptv$descriptive_data_size.number;
          PUSH descriptive_data_out_p: [statistic_header_out_p^.descriptive_data_size];
          IF ptv$descriptive_data_size.number <= descriptive_data_length THEN
            descriptive_data_out_p^ := descriptive_data_p^ (descriptive_data_start,
                  ptv$descriptive_data_size.number);
          ELSEIF descriptive_data_length > 0 THEN
            descriptive_data_out_p^ := descriptive_data_p^ (descriptive_data_start, descriptive_data_length);
          ELSE
            descriptive_data_out_p^ := '';
          IFEND;
        ELSE
          statistic_header_out_p^.descriptive_data_size := 0;
          descriptive_data_out_p := NIL;
        IFEND;
      IFEND;

      put_statistic_record (ptv$output_log_p, statistic_header_out_p, counters_out_p, descriptive_data_out_p,
            status);
    IFEND;

  PROCEND write_statistic_to_binary_log;

?? OLDTITLE, EJECT ??
?? NEWTITLE := '[INLINE] write_counter_legible_log', EJECT ??

{ PURPOSE:
{   The purpose of this request is to convert an integer to the string representation of the integer in the
{ required base and format (fixed/unfixed).

  PROCEDURE [INLINE] write_counter_legible_log
    (    counter: integer;
         base: radix;
     VAR output_line: string ( * );
     VAR output_line_length: integer;
     VAR status: ost$status);

    VAR
      counter_string: ost$string;

    status.normal := TRUE;

    IF ptv$number_of_counters.fixed_format THEN
      CASE base OF
      = base_2 =
        clp$convert_integer_to_rjstring (counter, 2, TRUE, ' ', output_line (1, ptc$base_2_length), status);
        output_line_length := output_line_length + ptc$base_2_length;
      = base_8 =
        clp$convert_integer_to_rjstring (counter, 8, TRUE, ' ', output_line (1, ptc$base_8_length), status);
        output_line_length := output_line_length + ptc$base_8_length;
      = base_10 =
        clp$convert_integer_to_rjstring (counter, 10, FALSE, ' ', output_line (1, ptc$base_10_length),
              status);
        output_line_length := output_line_length + ptc$base_10_length;
      = base_16 =
        clp$convert_integer_to_rjstring (counter, 16, TRUE, ' ', output_line (1, ptc$base_16_length), status);
        output_line_length := output_line_length + ptc$base_16_length;
      = base_16_group =
        convert_integer_to_hex (counter, output_line (1, ptc$base_16_group_length), status);
        output_line_length := output_line_length + ptc$base_16_group_length;
      ELSE
      CASEND;
    ELSE
      CASE base OF
      = base_2 =
        clp$convert_integer_to_string (counter, 2, TRUE, counter_string, status);
      = base_8 =
        clp$convert_integer_to_string (counter, 8, TRUE, counter_string, status);
      = base_10 =
        clp$convert_integer_to_string (counter, 10, FALSE, counter_string, status);
      = base_16 =
        clp$convert_integer_to_string (counter, 16, TRUE, counter_string, status);
      = base_16_group =
        convert_integer_to_hex (counter, output_line (1, ptc$base_16_group_length), status);
        output_line_length := output_line_length + ptc$base_16_group_length;
      ELSE
      CASEND;
      IF base <> base_16_group THEN
        output_line (1) := ' ';
        output_line (2, counter_string.size) := counter_string.value (1, counter_string.size);
        output_line_length := output_line_length + counter_string.size + 1;
      IFEND;
    IFEND;

    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

  PROCEND write_counter_legible_log;

?? OLDTITLE ??
?? NEWTITLE := 'write_statistic_to_legible_log', EJECT ??

{ PURPOSE:
{  The purpose of this request is to write a statistic record into legible log file.
{
{ DESIGN:
{   The procedure receives 3 pointers:
{    -  pointer to the statistic header.
{    -  pointer to the counters array.
{    -  pointer to the descriptive data string.
{  The procedure tries to write the output record in one line but if the output file page_width is not enough
{  it folds the output line into a few lines in the output log.
{
{ NOTE:
{ - The procedure processes the log_entry counter base in order to write only the required counters.
{ - The procedure processes ptv$number_of_counter in order to write a fixed number of counters or a floating
{   number.
{   - If the number of counters is fixed and fewer than the number of available counters from the statistic
{     (after processing the log_entry counter base) the procedure ignores the extra counters.
{   - If the number of counters is fixed and more than the number of available counters from the statistic
{     (after processing the log_entry counter base) the procedure pads the output log with zero values.
{ - This procedure uses the base in the log_entry counter base to delete counters (base 0) and to write the
{   counters in the specified base.

  PROCEDURE write_statistic_to_legible_log
    (    log_entry_p: ^put_entry;
         statistic_header_p: ^sft$statistic_header;
         counters_p: sft$counters;
         descriptive_data_in_p: ^sft$descriptive_data;
     VAR status: ost$status);

    VAR
      descriptive_data_length: integer,
      descriptive_data_p: ^sft$descriptive_data,
      descriptive_data_start: integer,
      index: integer,
      line_length: integer,
      null_subfield: boolean,
      number_of_counters: integer,
      substring_found: boolean;

    status.normal := TRUE;

    IF log_entry_p^.descriptive_text_p = NIL THEN
      descriptive_data_p := descriptive_data_in_p;
      get_descriptive_data_subfield (descriptive_data_p, statistic_header_p^.descriptive_data_size,
            log_entry_p^.subfield_position, log_entry_p^.subfield_length, log_entry_p^.subfield_number,
            log_entry_p^.subfield_delimiter, null_subfield, substring_found, descriptive_data_start,
            descriptive_data_length);
    ELSE
      descriptive_data_p := log_entry_p^.descriptive_text_p;
      descriptive_data_start := 1;
      descriptive_data_length := #SIZE (log_entry_p^.descriptive_text_p^);
    IFEND;

    write_statistic_header (statistic_header_p, descriptive_data_length, ptv$output_line_log,
          ptv$output_line_length, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    IF ptv$number_of_counters.float THEN
      FOR index := 1 TO statistic_header_p^.number_of_counters DO
        IF log_entry_p^.counter_base [index] <> base_0 THEN
          write_counter_legible_log (counters_p^ [index], log_entry_p^.counter_base [index],
                ptv$output_line_log (ptv$output_line_length + 1, * ), ptv$output_line_length, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;
      FOREND;
    ELSE
      index := 1;
      number_of_counters := 1;
      WHILE (number_of_counters <= ptv$number_of_counters.number) AND
            (index <= statistic_header_p^.number_of_counters) DO
        IF log_entry_p^.counter_base [index] <> base_0 THEN
          write_counter_legible_log (counters_p^ [index], log_entry_p^.counter_base [index],
                ptv$output_line_log (ptv$output_line_length + 1, * ), ptv$output_line_length, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          number_of_counters := number_of_counters + 1;
        IFEND;
        index := index + 1;
      WHILEND;
      FOR index := number_of_counters TO ptv$number_of_counters.number DO
        write_counter_legible_log (0, base_10, ptv$output_line_log (ptv$output_line_length + 1, * ),
              ptv$output_line_length, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      FOREND;
    IFEND;

    ptv$output_line_log (ptv$output_line_length + 1) := ' ';
    IF ptv$descriptive_data_size.float THEN
      IF descriptive_data_length <> 0 THEN
        ptv$output_line_log (ptv$output_line_length + 2, descriptive_data_length) :=
              descriptive_data_p^ (descriptive_data_start, descriptive_data_length);
        ptv$output_line_length := ptv$output_line_length + descriptive_data_length + 1;
      IFEND;
    ELSEIF ptv$descriptive_data_size.number > 0 THEN
      IF descriptive_data_length <> 0 THEN
        IF ptv$descriptive_data_size.number <= descriptive_data_length THEN
          ptv$output_line_log (ptv$output_line_length + 2, ptv$descriptive_data_size.number) :=
                descriptive_data_p^ (descriptive_data_start, ptv$descriptive_data_size.number);
          ptv$output_line_length := ptv$output_line_length + ptv$descriptive_data_size.number + 1;
        ELSE
          ptv$output_line_log (ptv$output_line_length + 2, ptv$descriptive_data_size.number) :=
                descriptive_data_p^ (descriptive_data_start, descriptive_data_length);
          ptv$output_line_length := ptv$output_line_length + ptv$descriptive_data_size.number + 1;
        IFEND;
      ELSE
        ptv$output_line_log (ptv$output_line_length + 2, ptv$descriptive_data_size.number) := '';
      IFEND;
    IFEND;

    line_length := ptv$output_line_length;
    index := 1;
    WHILE line_length > ptv$maximum_line_length DO
      cyp$put_next_line (ptv$output_file, ptv$output_line_log (index, ptv$maximum_line_length), status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      line_length := line_length - ptv$maximum_line_length;
      index := index + ptv$maximum_line_length;
    WHILEND;
    cyp$put_next_line (ptv$output_file, ptv$output_line_log (index, line_length), status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

  PROCEND write_statistic_to_legible_log;

?? OLDTITLE ??
?? NEWTITLE := 'write_statistic_to_list_log', EJECT ??

{ PURPOSE:
{  The purpose of this request is to write a statistic record into list log file.
{
{ DESIGN:
{   The procedure receives 3 pointers:
{    -  pointer to the statistic header.
{    -  pointer to the counters array.
{    -  pointer to the descriptive data string.
{ The procedure writes the statistic record on one line, the counters on a new line, folding the counters on
{ as few lines as necessary, with the number of the first counter in every line at the beginning of the line
{ and the descriptive data with apostrophes on a new line folded as necessary.
{
{ NOTE:
{ - The procedure processes the log_entry counter base in order to write only the required counters.
{ - The procedure processes ptv$number_of_counter in order to write a fixed number of counters or a floating
{   number.
{   - If the number of counters is fixed and fewer than the number of available counters from the statistic
{     (after processing the log_entry counter base) the procedure ignores the extra counters.
{   - If the number of counters is fixed and more than the number of available counters from the statistic
{     (after processing the log_entry counter base) the procedure doesn't pad the output log with zero values.
{ - This procedure uses the base in the log_entry counter base to delete counters (base 0) and to write the
{   counters in the specified base.
{ - In a list log when the counter_format is fixed all counters are written in the same length.

  PROCEDURE write_statistic_to_list_log
    (    log_entry_p: ^put_entry;
         statistic_header_p: ^sft$statistic_header;
         counters_p: sft$counters;
         descriptive_data_in_p: ^sft$descriptive_data;
     VAR status: ost$status);

    VAR
      counter_string: string (ptc$max_output_line_length),
      descriptive_data_length: integer,
      descriptive_data_p: ^sft$descriptive_data,
      descriptive_data_start: integer,
      index: integer,
      line_length: integer,
      null_subfield: boolean,
      number_of_counters: integer,
      substring_found: boolean;

?? NEWTITLE := '[INLINE] convert_counter_to_string', EJECT ??

{ PURPOSE:
{   The purpose of this request is to convert an integer to the string representation of the integer in the
{ required base and format (fixed/unfixed).

    PROCEDURE [INLINE] convert_counter_to_string
      (    counter_value: integer;
           base: radix;
       VAR length { input, output } : integer;
       VAR output_string: string (ptc$max_output_line_length);
       VAR status: ost$status);

      VAR
        counter_string: ost$string;

      status.normal := TRUE;

      IF ptv$number_of_counters.fixed_format THEN
        CASE base OF
        = base_2 =
          clp$convert_integer_to_rjstring (counter_value, 2, TRUE, ' ', output_string (1, length), status);
        = base_8 =
          clp$convert_integer_to_rjstring (counter_value, 8, TRUE, ' ', output_string (1, length), status);
        = base_10 =
          clp$convert_integer_to_rjstring (counter_value, 10, FALSE, ' ', output_string (1, length), status);
        = base_16 =
          clp$convert_integer_to_rjstring (counter_value, 16, TRUE, ' ', output_string (1, length), status);
        = base_16_group =
          convert_integer_to_hex (counter_value, output_string (1, length), status);
        ELSE
        CASEND;
      ELSE
        CASE base OF
        = base_2 =
          clp$convert_integer_to_string (counter_value, 2, TRUE, counter_string, status);
        = base_8 =
          clp$convert_integer_to_string (counter_value, 8, TRUE, counter_string, status);
        = base_10 =
          clp$convert_integer_to_string (counter_value, 10, FALSE, counter_string, status);
        = base_16 =
          clp$convert_integer_to_string (counter_value, 16, TRUE, counter_string, status);
        = base_16_group =
          convert_integer_to_hex (counter_value, output_string (1, ptc$base_16_group_length), status);
          length := ptc$base_16_group_length;
        ELSE
        CASEND;
        IF base <> base_16_group THEN
          output_string (1) := ' ';
          output_string (2, counter_string.size) := counter_string.value (1, counter_string.size);
          length := counter_string.size + 1;
        IFEND;
      IFEND;

      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

    PROCEND convert_counter_to_string;

?? OLDTITLE ??
?? NEWTITLE := '[INLINE] write_counter_to_list', EJECT ??

{ PURPOSE:
{  The purpose of this request is to write a counter into list log file.
{
{ DESIGN:
{   If the output line length plus the length of the new counter is longer than the output file page width
{   the procedure writes the line into output log, adds in the beginning of the line the number of the first
{   counter in the new line (the number of current counters) and adds the counter (the string) to the line.
{
{ NOTE:
{ - The first time the procedure is called it writes the statistic header.  The last line of the counters
{   is written to the log in the write_statistic_to_list_log procedure before writing the descriptive_data.

    PROCEDURE [INLINE] write_counter_to_list
      (VAR status: ost$status);

      status.normal := TRUE;

      line_length := line_length + ptv$fixed_counter_length;
      IF line_length >= ptv$maximum_line_length THEN
        cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        clp$convert_integer_to_rjstring (index, 10, FALSE, ' ',
              ptv$output_line (1, ptc$num_of_counter_string_size), status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        ptv$output_line (ptc$num_of_counter_string_size + 1) := ':';
        ptv$output_line_length := ptc$num_of_counter_string_size + 1;
      IFEND;
      ptv$output_line (ptv$output_line_length + 1, ptv$fixed_counter_length) := counter_string;
      ptv$output_line_length := ptv$output_line_length + ptv$fixed_counter_length;
      line_length := ptv$output_line_length;

    PROCEND write_counter_to_list;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    cyp$put_next_line (ptv$output_file, ' ', status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    IF log_entry_p^.descriptive_text_p = NIL THEN
      descriptive_data_p := descriptive_data_in_p;
      get_descriptive_data_subfield (descriptive_data_p, statistic_header_p^.descriptive_data_size,
            log_entry_p^.subfield_position, log_entry_p^.subfield_length, log_entry_p^.subfield_number,
            log_entry_p^.subfield_delimiter, null_subfield, substring_found, descriptive_data_start,
            descriptive_data_length);
    ELSE
      descriptive_data_p := log_entry_p^.descriptive_text_p;
      descriptive_data_start := 1;
      descriptive_data_length := #SIZE (log_entry_p^.descriptive_text_p^);
    IFEND;

    write_statistic_header (statistic_header_p, descriptive_data_length, ptv$output_line,
          ptv$output_line_length, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    line_length := ptv$max_report_page_width;
    IF ptv$number_of_counters.float THEN
      FOR index := 1 TO statistic_header_p^.number_of_counters DO
        IF log_entry_p^.counter_base [index] <> base_0 THEN
          convert_counter_to_string (counters_p^ [index], log_entry_p^.counter_base [index],
                ptv$fixed_counter_length, counter_string, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          write_counter_to_list (status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;
      FOREND;
    ELSE
      index := 1;
      number_of_counters := 1;
      WHILE (number_of_counters <= ptv$number_of_counters.number) AND
            (index <= statistic_header_p^.number_of_counters) DO
        IF log_entry_p^.counter_base [index] <> base_0 THEN
          convert_counter_to_string (counters_p^ [index], log_entry_p^.counter_base [index],
                ptv$fixed_counter_length, counter_string, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          write_counter_to_list (status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          number_of_counters := number_of_counters + 1;
        IFEND;
        index := index + 1;
      WHILEND;
      IF number_of_counters <= ptv$number_of_counters.number THEN
        convert_counter_to_string (0, base_10, ptv$fixed_counter_length, counter_string, status);
      IFEND;
      FOR index := number_of_counters TO ptv$number_of_counters.number DO
        write_counter_to_list (status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      FOREND;
    IFEND;

{ This call writes the last line of counters if there are counters to print or the statistic header.

    cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    IF descriptive_data_p <> NIL THEN
      write_descriptive_data_to_list (descriptive_data_p^ (descriptive_data_start, descriptive_data_length),
            0, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
    IFEND;

  PROCEND write_statistic_to_list_log;

?? OLDTITLE ??
?? NEWTITLE := 'ANABL Subcommands' ??
?? NEWTITLE := 'add_selection_cmd', EJECT ??

{ This procedure processes the add_selection command.

*copyc pth$anabl_add_selection

  PROCEDURE add_selection_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (ptm$anabl_adds) add_selection, adds (
{   selection, s: (CHECK) name = $required
{   statistic_code , sc: (CHECK) statistic_code = $optional
{   time, t: (CHECK) range of date_time = $optional
{   continuous_date_time, cdt: boolean = false
{   descriptive_data, dd: list of record
{       string: list of string 0..sfc$max_descriptive_data_size
{       position: integer 0..sfc$max_descriptive_data_size = $optional
{       length: any of
{         key
{           all
{         keyend
{         integer 0..sfc$max_descriptive_data_size
{       anyend = $optional
{       field_number: any of
{         key
{            all
{         keyend
{         integer 1..sfc$max_descriptive_data_size
{       anyend = $optional
{       field_delimiter: string 1 = $optional
{     recend = $optional
{   job_predecessor, jp: (CHECK) name = $optional
{   task_predecessor, tp: (CHECK) name = $optional
{   system_job_name, sjn: name 19..19 = $optional
{   global_task_id, gti: (CHECK) string 3..9 = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 19] of clt$pdt_parameter_name,
      parameters: array [1 .. 10] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$range_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$date_time_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$list_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$string_type_qualifier,
            recend,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_5: clt$field_specification,
          element_type_spec_5: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type10: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 9, 10, 13, 12, 854],
    clc$command, 19, 10, 1, 0, 0, 0, 10, 'PTM$ANABL_ADDS'], [
    ['CDT                            ',clc$abbreviation_entry, 4],
    ['CONTINUOUS_DATE_TIME           ',clc$nominal_entry, 4],
    ['DD                             ',clc$abbreviation_entry, 5],
    ['DESCRIPTIVE_DATA               ',clc$nominal_entry, 5],
    ['GLOBAL_TASK_ID                 ',clc$nominal_entry, 9],
    ['GTI                            ',clc$abbreviation_entry, 9],
    ['JOB_PREDECESSOR                ',clc$nominal_entry, 6],
    ['JP                             ',clc$abbreviation_entry, 6],
    ['S                              ',clc$abbreviation_entry, 1],
    ['SC                             ',clc$abbreviation_entry, 2],
    ['SELECTION                      ',clc$nominal_entry, 1],
    ['SJN                            ',clc$abbreviation_entry, 8],
    ['STATISTIC_CODE                 ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 10],
    ['SYSTEM_JOB_NAME                ',clc$nominal_entry, 8],
    ['T                              ',clc$abbreviation_entry, 3],
    ['TASK_PREDECESSOR               ',clc$nominal_entry, 7],
    ['TIME                           ',clc$nominal_entry, 3],
    ['TP                             ',clc$abbreviation_entry, 7]],
    [
{ PARAMETER 1
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$extended_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$extended_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$extended_parameter_checking, 12, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 5],
{ PARAMETER 5
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 423, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$extended_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$extended_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$extended_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$statistic_code_type]],
{ PARAMETER 3
    [[1, 0, clc$range_type], [5],
      [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time
  ], $clt$date_time_tenses [clc$past, clc$present, clc$future]]]
    ],
{ PARAMETER 4
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 5
    [[1, 0, clc$list_type], [407, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$record_type], [5],
      ['STRING                         ', clc$required_field, 24], [[1, 0,
  clc$list_type], [8, 0, clc$max_list_size, FALSE],
          [[1, 0, clc$string_type], [0, sfc$max_descriptive_data_size, FALSE]]
        ],
      ['POSITION                       ', clc$optional_field, 20], [[1, 0,
  clc$integer_type], [0, sfc$max_descriptive_data_size, 10]],
      ['LENGTH                         ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [0, sfc$max_descriptive_data_size, 10]]
        ],
      ['FIELD_NUMBER                   ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [1, sfc$max_descriptive_data_size, 10]]
        ],
      ['FIELD_DELIMITER                ', clc$optional_field, 8], [[1, 0,
  clc$string_type], [1, 1, FALSE]]
      ]
    ],
{ PARAMETER 6
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 7
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 8
    [[1, 0, clc$name_type], [19, 19]],
{ PARAMETER 9
    [[1, 0, clc$string_type], [3, 9, FALSE]],
{ PARAMETER 10
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$selection = 1,
      p$statistic_code = 2,
      p$time = 3,
      p$continuous_date_time = 4,
      p$descriptive_data = 5,
      p$job_predecessor = 6,
      p$task_predecessor = 7,
      p$system_job_name = 8,
      p$global_task_id = 9,
      p$status = 10;

    VAR
      pvt: array [1 .. 10] of clt$parameter_value;

    VAR
      end_date_time: clt$date_time,
      index_value: clt$integer,
      initial_selection: [STATIC, READ] selection := [ * { name } , NIL
            { selection_chain_link_p } , FALSE { statistic_specified } , *
            { statistic_name } , * { statistic_code } , FALSE { date_time_specified } , *
            { start_date_time } , * { end_date_time } , TRUE { continuous_date_time } , *
            { new_day_date_time } , FALSE { descriptive_specified } , NIL
            { descriptive_subfield_p } , NIL { predecessor_job_statistic_p } , NIL
            { predecessor_task_statistic_p } , jmc$blank_system_supplied_name { job_name } , FALSE
            { task_id_specified } , [ * { index } , * { seqno } ], NIL { log_entry_p } , NIL
            { field_chain_p } , 0 { number_of_successor_statistics } , NIL { successor_list_head_p } , NIL
            { successor_list_tail_p } , FALSE { collect_date_time } , NIL { date_time_value_head_p } , NIL
            { date_time_value_tail_p } , FALSE { collect_predecessor_date_time } , NIL
            {  predecessor_dt_value_head_p } , NIL {  predecessor_dt_value_tail_p } , NIL
            { statistic_location_p } , FALSE { incremental } , NIL { incremental_counter_p } , 0
            { lost_interval } , FALSE { skip_date_time } , NIL { skip_date_time_head_p } , NIL
            { skip_date_time_tail_p } , FALSE { shadow_fields } , NIL { shadow_field_chain_p } ],
      selection_p: ^selection,
      seqno_value: clt$integer,
      start_date_time: clt$date_time,
      temp_selection: ^selection;

?? NEWTITLE := 'check_add_selection', EJECT ??

    PROCEDURE check_add_selection
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
        end_time: integer,
        start_time: integer;

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF

        = p$selection =
          check_duplicate_selection_name (pvt [p$selection].value^.name_value, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          temp_selection^.name := pvt [p$selection].value^.name_value;

        = p$statistic_code =
          temp_selection^.statistic_specified := FALSE;
          IF pvt [p$statistic_code].specified THEN
            temp_selection^.statistic_code := pvt [p$statistic_code].value^.statistic_code_value;
            sfp$convert_stat_code_to_name (temp_selection^.statistic_code, temp_selection^.statistic_name,
                  status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            temp_selection^.statistic_specified := TRUE;
          IFEND;

        = p$time =
          temp_selection^.date_time_specified := FALSE;
          IF pvt [p$time].specified THEN
            process_time_selection (pvt [p$time], start_date_time, end_date_time, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            temp_selection^.start_date_time := start_date_time.value;
            temp_selection^.end_date_time := end_date_time.value;
            temp_selection^.date_time_specified := TRUE;
          IFEND;

        = p$job_predecessor =
          temp_selection^.predecessor_job_statistic_p := NIL;
          IF pvt [p$job_predecessor].specified THEN
            check_undefined_selection (pvt [p$job_predecessor].value^.name_value,
                  pte$undefined_selec_for_predec, temp_selection^.predecessor_job_statistic_p, status);
          IFEND;

        = p$task_predecessor =
          temp_selection^.predecessor_task_statistic_p := NIL;
          IF pvt [p$task_predecessor].specified THEN
            check_undefined_selection (pvt [p$task_predecessor].value^.name_value,
                  pte$undefined_selec_for_predec, temp_selection^.predecessor_task_statistic_p, status);
          IFEND;

        = p$global_task_id =
          IF pvt [p$global_task_id].specified THEN
            process_global_task_id (pvt [p$global_task_id].value^, index_value, seqno_value, status);
          IFEND;

        ELSE
        CASEND;
      ELSE
        IF temp_selection^.date_time_specified AND NOT pvt [p$continuous_date_time].value^.boolean_value.
              value THEN
          start_time := temp_selection^.start_date_time.hour *
                3600000 + temp_selection^.start_date_time.minute *
                60000 + temp_selection^.start_date_time.second *
                1000 + temp_selection^.start_date_time.millisecond;
          end_time := temp_selection^.end_date_time.hour * 3600000 + temp_selection^.end_date_time.minute *
                60000 + temp_selection^.end_date_time.second * 1000 +
                temp_selection^.end_date_time.millisecond;
          IF start_time >= end_time THEN
            osp$set_status_condition (pte$date_time_range_order, status);
            RETURN; {----->
          IFEND;
        IFEND;

        IF pvt [p$job_predecessor].specified AND pvt [p$task_predecessor].specified THEN
          osp$set_status_condition (pte$job_and_task_predecessor, status);
          RETURN; {----->
        IFEND;

      IFEND;

    PROCEND check_add_selection;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    ALLOCATE temp_selection;
    temp_selection^ := initial_selection;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_add_selection, ^pvt, status);
    IF NOT status.normal THEN
      FREE temp_selection;
      RETURN; {----->
    IFEND;

{ continuous_date_time

    temp_selection^.continuous_date_time := pvt [p$continuous_date_time].value^.boolean_value.value;

{ descriptive_data

    IF pvt [p$descriptive_data].specified THEN
      process_descriptive_selection (pvt [p$descriptive_data].value, temp_selection);
      temp_selection^.descriptive_specified := TRUE;
    IFEND;

{ job_predecessor

    IF temp_selection^.predecessor_job_statistic_p <> NIL THEN
      temp_selection^.predecessor_job_statistic_p^.number_of_successor_statistics :=
            temp_selection^.predecessor_job_statistic_p^.number_of_successor_statistics + 1;
    IFEND;

{ task_predecessor

    IF temp_selection^.predecessor_task_statistic_p <> NIL THEN
      temp_selection^.predecessor_task_statistic_p^.number_of_successor_statistics :=
            temp_selection^.predecessor_task_statistic_p^.number_of_successor_statistics + 1;
    IFEND;

{ system_job_name

    IF pvt [p$system_job_name].specified THEN
      temp_selection^.job_name := pvt [p$system_job_name].value^.
            name_value (1, jmc$system_supplied_name_size);
    IFEND;

{ global_task_id

    IF pvt [p$global_task_id].specified THEN
      temp_selection^.task_id.index := index_value.value;
      temp_selection^.task_id.seqno := seqno_value.value;
      temp_selection^.task_id_specified := TRUE;
    IFEND;

    IF ptv$selection_chain_head_p <> NIL THEN
      ptv$selection_chain_tail_p^.selection_chain_link_p := temp_selection;
      ptv$selection_chain_tail_p := temp_selection;
    ELSE
      ptv$selection_chain_head_p := temp_selection;
      ptv$selection_chain_tail_p := temp_selection;
    IFEND;

  PROCEND add_selection_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'change_selection_cmd', EJECT ??

*copyc pth$anabl_change_selection

  PROCEDURE change_selection_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{    PROCEDURE (ptm$anabl_chas) change_selection, chas (
{    selection, s: (CHECK) name = $required
{    new_selection, ns: (CHECK) name = $optional
{    statistic_code, sc: (CHECK) any of
{        key
{          none
{        keyend
{        statistic_code
{      anyend = $optional
{    time, t: (CHECK) any of
{        key
{          none
{        keyend
{        range of date_time
{      anyend = $optional
{    continuous_date_time, cdt: boolean = $optional
{    descriptive_data, dd: any of
{        key
{          none
{        keyend
{        list of record
{        string: list of string 0..sfc$max_descriptive_data_size = $optional
{          position: integer 0..sfc$max_descriptive_data_size = $optional
{          length: any of
{            key
{              all
{            keyend
{            integer 0..sfc$max_descriptive_data_size
{          anyend = $optional
{          field_number: any of
{            key
{              all
{            keyend
{            integer 1..sfc$max_descriptive_data_size
{          anyend = $optional
{          field_delimiter: string 1 = $optional
{        recend
{      anyend = $optional
{    job_predecessor, jp: (CHECK) any of
{        key
{          none
{        keyend
{        name
{      anyend = $optional
{    task_predecessor, tp: (CHECK) any of
{        key
{          none
{        keyend
{        name
{      anyend = $optional
{    system_job_name, sjn: any of
{        key
{          none
{        keyend
{        name 19..19
{      anyend = $optional
{    global_task_id, gti: (CHECK) any of
{        key
{          none
{        keyend
{        string 3..9
{      anyend = $optional
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 21] of clt$pdt_parameter_name,
      parameters: array [1 .. 11] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: 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,
        recend,
      recend,
      type4: 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$range_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$date_time_type_qualifier,
          recend,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
      type6: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: record
              header: clt$type_specification_header,
              qualifier: clt$list_type_qualifier,
              element_type_spec: record
                header: clt$type_specification_header,
                qualifier: clt$string_type_qualifier,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
            field_spec_3: clt$field_specification,
            element_type_spec_3: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_4: clt$field_specification,
            element_type_spec_4: 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$integer_type_qualifier,
              recend,
            recend,
            field_spec_5: clt$field_specification,
            element_type_spec_5: record
              header: clt$type_specification_header,
              qualifier: clt$string_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type7: 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$name_type_qualifier,
        recend,
      recend,
      type8: 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$name_type_qualifier,
        recend,
      recend,
      type9: 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$name_type_qualifier,
        recend,
      recend,
      type10: 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$string_type_qualifier,
        recend,
      recend,
      type11: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 9, 10, 17, 38, 378],
    clc$command, 21, 11, 1, 0, 0, 0, 11, 'PTM$ANABL_CHAS'], [
    ['CDT                            ',clc$abbreviation_entry, 5],
    ['CONTINUOUS_DATE_TIME           ',clc$nominal_entry, 5],
    ['DD                             ',clc$abbreviation_entry, 6],
    ['DESCRIPTIVE_DATA               ',clc$nominal_entry, 6],
    ['GLOBAL_TASK_ID                 ',clc$nominal_entry, 10],
    ['GTI                            ',clc$abbreviation_entry, 10],
    ['JOB_PREDECESSOR                ',clc$nominal_entry, 7],
    ['JP                             ',clc$abbreviation_entry, 7],
    ['NEW_SELECTION                  ',clc$nominal_entry, 2],
    ['NS                             ',clc$abbreviation_entry, 2],
    ['S                              ',clc$abbreviation_entry, 1],
    ['SC                             ',clc$abbreviation_entry, 3],
    ['SELECTION                      ',clc$nominal_entry, 1],
    ['SJN                            ',clc$abbreviation_entry, 9],
    ['STATISTIC_CODE                 ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 11],
    ['SYSTEM_JOB_NAME                ',clc$nominal_entry, 9],
    ['T                              ',clc$abbreviation_entry, 4],
    ['TASK_PREDECESSOR               ',clc$nominal_entry, 8],
    ['TIME                           ',clc$nominal_entry, 4],
    ['TP                             ',clc$abbreviation_entry, 8]],
    [
{ PARAMETER 1
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$extended_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$extended_parameter_checking, 5, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$extended_parameter_checking, 67, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$extended_parameter_checking, 76, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 487, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$extended_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$extended_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$extended_parameter_checking, 72, clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$statistic_code_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$statistic_code_type]]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$range_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    12, [[1, 0, clc$range_type], [5],
        [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time
  ], $clt$date_time_tenses [clc$past, clc$present, clc$future]]]
      ]
    ],
{ PARAMETER 5
    [[1, 0, clc$boolean_type]],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    423, [[1, 0, clc$list_type], [407, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$record_type], [5],
        ['STRING                         ', clc$optional_field, 24], [[1, 0,
  clc$list_type], [8, 0, clc$max_list_size, FALSE],
            [[1, 0, clc$string_type], [0, sfc$max_descriptive_data_size, FALSE]
  ]
          ],
        ['POSITION                       ', clc$optional_field, 20], [[1, 0,
  clc$integer_type], [0, sfc$max_descriptive_data_size, 10]],
        ['LENGTH                         ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
          FALSE, 2],
          44, [[1, 0, clc$keyword_type], [1], [
            ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
            ],
          20, [[1, 0, clc$integer_type], [0, sfc$max_descriptive_data_size, 10]
  ]
          ],
        ['FIELD_NUMBER                   ', clc$optional_field, 84], [[1, 0,
  clc$union_type], [[clc$integer_type, clc$keyword_type],
          FALSE, 2],
          44, [[1, 0, clc$keyword_type], [1], [
            ['ALL                            ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
            ],
          20, [[1, 0, clc$integer_type], [1, sfc$max_descriptive_data_size, 10]
  ]
          ],
        ['FIELD_DELIMITER                ', clc$optional_field, 8], [[1, 0,
  clc$string_type], [1, 1, FALSE]]
        ]
      ]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [19, 19]]
    ],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$string_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [3, 9, FALSE]]
    ],
{ PARAMETER 11
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$selection = 1,
      p$new_selection = 2,
      p$statistic_code = 3,
      p$time = 4,
      p$continuous_date_time = 5,
      p$descriptive_data = 6,
      p$job_predecessor = 7,
      p$task_predecessor = 8,
      p$system_job_name = 9,
      p$global_task_id = 10,
      p$status = 11;

    VAR
      pvt: array [1 .. 11] of clt$parameter_value;

    VAR
      end_date_time: clt$date_time,
      index_value: clt$integer,
      job_predecessor_p: ^selection,
      selection_p: ^selection,
      seqno_value: clt$integer,
      start_date_time: clt$date_time,
      statistic_name: ost$name,
      task_predecessor_p: ^selection,
      temp_selection: ^selection,
      value: ^clt$data_value;

?? NEWTITLE := 'check_change_selection', EJECT ??

    PROCEDURE check_change_selection
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
        end_time: integer,
        new_time_range: boolean,
        new_not_continuous_date_time: boolean,
        start_time: integer;

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF

        = p$selection =
          check_undefined_selection (pvt [p$selection].value^.name_value, pte$undefined_selec_for_change,
                temp_selection, status);

        = p$new_selection =
          IF pvt [p$new_selection].specified THEN
            check_duplicate_selection_name (pvt [p$new_selection].value^.name_value, status);
          IFEND;

        = p$statistic_code =
          IF pvt [p$statistic_code].specified AND (pvt [p$statistic_code].value^.kind =
                clc$statistic_code) THEN
            sfp$convert_stat_code_to_name (pvt [p$statistic_code].value^.statistic_code_value, statistic_name,
                  status);
          IFEND;

        = p$time =
          IF pvt [p$time].specified AND (pvt [p$time].value^.kind = clc$range) THEN { Range of clc$date_time }
            process_time_selection (pvt [p$time], start_date_time, end_date_time, status);
          IFEND;

        = p$job_predecessor =
          IF pvt [p$job_predecessor].specified AND (pvt [p$job_predecessor].value^.kind = clc$name) THEN
            check_undefined_selection (pvt [p$job_predecessor].value^.name_value,
                  pte$undefined_selec_for_predec, job_predecessor_p, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            IF job_predecessor_p = temp_selection THEN
              osp$set_status_condition (pte$predecessor_itself, status);
              RETURN; {----->
            IFEND;
            check_recursive_predecessor (temp_selection, job_predecessor_p, status);
          IFEND;

        = p$task_predecessor =
          IF pvt [p$task_predecessor].specified AND (pvt [p$task_predecessor].value^.kind = clc$name) THEN
            check_undefined_selection (pvt [p$task_predecessor].value^.name_value,
                  pte$undefined_selec_for_predec, task_predecessor_p, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            IF task_predecessor_p = temp_selection THEN
              osp$set_status_condition (pte$predecessor_itself, status);
              RETURN; {----->
            IFEND;
            check_recursive_predecessor (temp_selection, task_predecessor_p, status);
          IFEND;

        = p$global_task_id =
          IF pvt [p$global_task_id].specified AND (pvt [p$global_task_id].value^.kind = clc$string) THEN
            process_global_task_id (pvt [p$global_task_id].value^, index_value, seqno_value, status);
          IFEND;

        ELSE
        CASEND;
      ELSE

{ If a new time range was specified and continuous_date_time is FALSE, or
{   if continuous_date_time was changed to FALSE and a time range was specified or time had
{   already been used as a selection criterion, then check for a valid time range.

        new_time_range := (pvt [p$time].specified AND (pvt [p$time].value^.kind = clc$range));
        new_not_continuous_date_time := (pvt [p$continuous_date_time].specified AND
              NOT pvt [p$continuous_date_time].value^.boolean_value.value);

        IF (new_time_range AND (new_not_continuous_date_time OR NOT temp_selection^.continuous_date_time)) OR
           (new_not_continuous_date_time AND (new_time_range OR temp_selection^.date_time_specified)) THEN

          IF pvt [p$time].specified THEN
            start_time := start_date_time.value.hour * 3600000 + start_date_time.value.minute *
                  60000 + start_date_time.value.second * 1000 + start_date_time.value.millisecond;
            end_time := end_date_time.value.hour * 3600000 + end_date_time.value.minute *
                  60000 + end_date_time.value.second * 1000 + end_date_time.value.millisecond;
          ELSE
            start_time := temp_selection^.start_date_time.hour *
                  3600000 + temp_selection^.start_date_time.minute *
                  60000 + temp_selection^.start_date_time.second *
                  1000 + temp_selection^.start_date_time.millisecond;
            end_time := temp_selection^.end_date_time.hour * 3600000 + temp_selection^.end_date_time.minute *
                  60000 + temp_selection^.end_date_time.second *
                  1000 + temp_selection^.end_date_time.millisecond;
          IFEND;
          IF start_time >= end_time THEN
            osp$set_status_condition (pte$date_time_range_order, status);
            RETURN; {----->
          IFEND;
        IFEND;

        IF pvt [p$job_predecessor].specified AND (pvt [p$job_predecessor].value^.kind = clc$name) AND
              pvt [p$task_predecessor].specified AND (pvt [p$task_predecessor].value^.kind = clc$name) THEN
          osp$set_status_condition (pte$job_and_task_predecessor, status);
          RETURN; {----->
        IFEND;

        IF pvt [p$job_predecessor].specified AND (pvt [p$job_predecessor].value^.kind = clc$name) AND
              (temp_selection^.predecessor_task_statistic_p <> NIL) AND NOT pvt [p$task_predecessor].specified
              { none } THEN
          osp$set_status_condition (pte$task_predecessor_defined, status);
          RETURN; {----->
        ELSEIF pvt [p$task_predecessor].specified AND (pvt [p$task_predecessor].value^.kind = clc$name) AND
              (temp_selection^.predecessor_job_statistic_p <> NIL) AND NOT pvt [p$job_predecessor].specified
              { none } THEN
          osp$set_status_condition (pte$job_predecessor_defined, status);
          RETURN; {----->
        IFEND;

      IFEND;

    PROCEND check_change_selection;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_change_selection, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

{ new_selection

    IF pvt [p$new_selection].specified THEN
      temp_selection^.name := pvt [p$new_selection].value^.name_value;
    IFEND;

{ statistic_code

    IF pvt [p$statistic_code].specified THEN
      IF pvt [p$statistic_code].value^.kind = clc$statistic_code THEN
        temp_selection^.statistic_code := pvt [p$statistic_code].value^.statistic_code_value;
        temp_selection^.statistic_name := statistic_name;
        temp_selection^.statistic_specified := TRUE;
      ELSE { none }
        temp_selection^.statistic_specified := FALSE;
      IFEND;
    IFEND;

{ time

    IF pvt [p$time].specified THEN
      IF pvt [p$time].value^.kind = clc$range THEN { Range of clc$date_time }
        temp_selection^.start_date_time := start_date_time.value;
        temp_selection^.end_date_time := end_date_time.value;
        temp_selection^.date_time_specified := TRUE;
      ELSE { none }
        temp_selection^.date_time_specified := FALSE;
      IFEND;
    IFEND;

{ continuous_date_time

    IF pvt [p$continuous_date_time].specified THEN
      temp_selection^.continuous_date_time := pvt [p$continuous_date_time].value^.boolean_value.value;
    IFEND;

{ descriptive_data

    IF pvt [p$descriptive_data].specified THEN
      IF pvt [p$descriptive_data].value^.kind = clc$list THEN
        free_descriptive_selection (temp_selection^.descriptive_subfield_p);
        process_descriptive_selection (pvt [p$descriptive_data].value, temp_selection);
        temp_selection^.descriptive_specified := TRUE;
      ELSE { none }
        free_descriptive_selection (temp_selection^.descriptive_subfield_p);
        temp_selection^.descriptive_specified := FALSE
      IFEND;
    IFEND;

{ job_predecessor

    IF pvt [p$job_predecessor].specified THEN
      IF temp_selection^.predecessor_job_statistic_p <> NIL THEN
        temp_selection^.predecessor_job_statistic_p^.number_of_successor_statistics :=
              temp_selection^.predecessor_job_statistic_p^.number_of_successor_statistics - 1;
      IFEND;
      IF pvt [p$job_predecessor].value^.kind = clc$name THEN
        temp_selection^.predecessor_job_statistic_p := job_predecessor_p;
        temp_selection^.predecessor_job_statistic_p^.number_of_successor_statistics :=
              temp_selection^.predecessor_job_statistic_p^.number_of_successor_statistics + 1;
      ELSE { none }
        temp_selection^.predecessor_job_statistic_p := NIL;
      IFEND;
    IFEND;

{ task_predecessor

    IF pvt [p$task_predecessor].specified THEN
      IF temp_selection^.predecessor_task_statistic_p <> NIL THEN
        temp_selection^.predecessor_task_statistic_p^.number_of_successor_statistics :=
              temp_selection^.predecessor_task_statistic_p^.number_of_successor_statistics - 1;
      IFEND;
      IF pvt [p$task_predecessor].value^.kind = clc$name THEN
        temp_selection^.predecessor_task_statistic_p := task_predecessor_p;
        temp_selection^.predecessor_task_statistic_p^.number_of_successor_statistics :=
              temp_selection^.predecessor_task_statistic_p^.number_of_successor_statistics + 1;
      ELSE { none }
        temp_selection^.predecessor_task_statistic_p := NIL;
      IFEND;
    IFEND;

{ job_name

    IF pvt [p$system_job_name].specified THEN
      IF pvt [p$system_job_name].value^.kind = clc$name THEN
        temp_selection^.job_name := pvt [p$system_job_name].
              value^.name_value (1, jmc$system_supplied_name_size);
      ELSE { none }
        temp_selection^.job_name := jmc$blank_system_supplied_name;
      IFEND;
    IFEND;

{ global_task_id

    IF pvt [p$global_task_id].specified THEN
      IF pvt [p$global_task_id].value^.kind = clc$string THEN
        temp_selection^.task_id.index := index_value.value;
        temp_selection^.task_id.seqno := seqno_value.value;
        temp_selection^.task_id_specified := TRUE;
      ELSE { none }
        temp_selection^.task_id_specified := FALSE;
      IFEND;
    IFEND;

  PROCEND change_selection_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'delete_selection_cmd', EJECT ??

{ This procedure processes the delete_selection command.

*copyc pth$anabl_delete_selection

  PROCEDURE delete_selection_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (ptm$anabl_dels) delete_selection, dels (
{  selection, selections, s: (CHECK) any of
{      key
{        all
{      keyend
{      list of name
{    anyend = $required
{  status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 28, 10, 28, 28, 835],
    clc$command, 4, 2, 1, 0, 0, 0, 2, 'PTM$ANABL_DELS'], [
    ['S                              ',clc$abbreviation_entry, 1],
    ['SELECTION                      ',clc$nominal_entry, 1],
    ['SELECTIONS                     ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 85, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$selection = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      delete_more: boolean,
      delete_selection_list_head: ^name_list,
      delete_selection_list_1_p: ^name_list,
      delete_selection_list_2: ^name_list,
      delete_status: boolean,
      errors_detected: boolean,
      failing_status: ost$status,
      new_delete_selection_list_head: ^name_list,
      selection_1_p: ^selection,
      selection_2_p: ^selection,
      value_p: ^clt$data_value;

?? NEWTITLE := 'check_delete_selection', EJECT ??

    PROCEDURE check_delete_selection
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$selection =
          IF pvt [p$selection].value^.kind = clc$list THEN
            report_duplicate_name (pvt [p$selection].value, 'SELECTION', status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;
          report_fields_and_put (pvt [p$selection].value, status);
        ELSE
        CASEND;
      IFEND;

    PROCEND check_delete_selection;

?? OLDTITLE, EJECT ??

    PROCEDURE delete
      (    delete_selection_list_p: ^name_list;
       VAR delete_status: boolean;
       VAR status: ost$status);

      status.normal := TRUE;

      selection_1_p := ptv$selection_chain_head_p;
      selection_2_p := ptv$selection_chain_head_p;
      WHILE (selection_1_p <> NIL) AND (selection_1_p^.name <> delete_selection_list_p^.name) DO
        selection_2_p := selection_1_p;
        selection_1_p := selection_1_p^.selection_chain_link_p;
      WHILEND;

      IF selection_1_p <> NIL THEN
        IF selection_1_p^.number_of_successor_statistics = 0 THEN

          IF selection_1_p^.predecessor_job_statistic_p <> NIL THEN
            selection_1_p^.predecessor_job_statistic_p^.number_of_successor_statistics :=
                  selection_1_p^.predecessor_job_statistic_p^.number_of_successor_statistics - 1;
          IFEND;

          IF selection_1_p^.predecessor_task_statistic_p <> NIL THEN
            selection_1_p^.predecessor_task_statistic_p^.number_of_successor_statistics :=
                  selection_1_p^.predecessor_task_statistic_p^.number_of_successor_statistics - 1;
          IFEND;

          IF selection_1_p = ptv$selection_chain_head_p THEN
            ptv$selection_chain_head_p := selection_1_p^.selection_chain_link_p;
          ELSE
            selection_2_p^.selection_chain_link_p := selection_1_p^.selection_chain_link_p;
          IFEND;
          free_descriptive_selection (selection_1_p^.descriptive_subfield_p);
          FREE selection_1_p;

          delete_status := TRUE;
        ELSE
          delete_status := FALSE;
        IFEND;
      ELSE
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$undefined_selec_for_delete,
              delete_selection_list_p^.name, failing_status);
        report_intermediate_error (failing_status, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        errors_detected := TRUE;
        delete_status := TRUE;
      IFEND;

    PROCEND delete;


    status.normal := TRUE;
    errors_detected := FALSE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_delete_selection, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    IF pvt [p$selection].value^.kind = clc$keyword THEN

{ ALL

      selection_1_p := ptv$selection_chain_head_p;
      WHILE selection_1_p <> NIL DO
        selection_2_p := selection_1_p^.selection_chain_link_p;
        FREE selection_1_p;
        selection_1_p := selection_2_p;
      WHILEND;
      ptv$selection_chain_head_p := NIL;
    ELSE

{ LIST

      value_p := pvt [p$selection].value;
      PUSH delete_selection_list_head;
      delete_selection_list_1_p := delete_selection_list_head;
      delete_selection_list_1_p^.name := value_p^.element_value^.name_value;
      value_p := value_p^.link;
      WHILE value_p <> NIL DO
        PUSH delete_selection_list_1_p^.link_p;
        delete_selection_list_1_p := delete_selection_list_1_p^.link_p;
        delete_selection_list_1_p^.name := value_p^.element_value^.name_value;
        value_p := value_p^.link;
      WHILEND;
      delete_selection_list_1_p^.link_p := NIL;

      delete_more := TRUE;
      WHILE (delete_selection_list_head <> NIL) AND delete_more DO
        delete_selection_list_1_p := delete_selection_list_head;
        delete_more := FALSE;
        new_delete_selection_list_head := NIL;
        WHILE delete_selection_list_1_p <> NIL DO
          delete (delete_selection_list_1_p, delete_status, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          IF delete_status THEN
            delete_more := TRUE;
          ELSE
            IF new_delete_selection_list_head = NIL THEN
              PUSH new_delete_selection_list_head;
              delete_selection_list_2 := new_delete_selection_list_head;
            ELSE
              PUSH delete_selection_list_2^.link_p;
              delete_selection_list_2 := delete_selection_list_2^.link_p;
            IFEND;
            delete_selection_list_2^.name := delete_selection_list_1_p^.name;
            delete_selection_list_2^.link_p := NIL;
          IFEND;
          delete_selection_list_1_p := delete_selection_list_1_p^.link_p;
        WHILEND;
        delete_selection_list_head := new_delete_selection_list_head;
      WHILEND;

      IF delete_selection_list_head <> NIL THEN
        delete_selection_list_1_p := delete_selection_list_head;
        WHILE delete_selection_list_1_p <> NIL DO
          osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$selection_has_successor,
                delete_selection_list_1_p^.name, failing_status);
          report_intermediate_error (failing_status, status);
          delete_selection_list_1_p := delete_selection_list_1_p^.link_p;
        WHILEND;
        errors_detected := TRUE;
      IFEND;

      IF ptv$selection_chain_head_p <> NIL THEN
        ptv$selection_chain_tail_p := ptv$selection_chain_head_p;
        WHILE ptv$selection_chain_tail_p^.selection_chain_link_p <> NIL DO
          ptv$selection_chain_tail_p := ptv$selection_chain_tail_p^.selection_chain_link_p;
        WHILEND;
      IFEND;

      IF errors_detected THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, 'SELECTION',
              status);
        RETURN; {----->
      IFEND;
    IFEND;

  PROCEND delete_selection_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'display_selection_cmd', EJECT ??

{ This procedure processes the display_selection command.

*copyc pth$anabl_display_selection

  PROCEDURE display_selection_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (ptm$anabl_diss) display_selection, diss (
{  selection, selections, s: (CHECK) any of
{      key
{        all
{      keyend
{      list of name
{    anyend = all
{  display_option, do: key
{      (name, names, n)
{      all
{    keyend = name
{  output, o: file = $output
{  status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 28, 10, 36, 42, 520],
    clc$command, 8, 4, 0, 0, 0, 0, 4, 'PTM$ANABL_DISS'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['S                              ',clc$abbreviation_entry, 1],
    ['SELECTION                      ',clc$nominal_entry, 1],
    ['SELECTIONS                     ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 85,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NAME                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['NAMES                          ', clc$alias_entry, clc$normal_usage_entry, 1]]
    ,
    'name'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$selection = 1,
      p$display_option = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      errors_detected: boolean,
      failing_status: ost$status,
      number: integer,
      put_entry_p: ^put_entry,
      selection_p: ^selection,
      task_id_index: string (ptc$task_id_index_string_size),
      task_id_seqno: string (ptc$task_id_seqno_string_size),
      value_p: ^clt$data_value;

?? NEWTITLE := 'check_display_selection', EJECT ??

    PROCEDURE check_display_selection
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$selection =
          IF pvt [p$selection].value^.kind = clc$list THEN
            report_duplicate_name (pvt [p$selection].value, 'SELECTION', status);
          IFEND;
        ELSE
        CASEND;
      IFEND;

    PROCEND check_display_selection;

?? OLDTITLE ??
?? NEWTITLE := 'format_selection_display', EJECT ??

    PROCEDURE format_selection_display
      (VAR status: ost$status);

      VAR
        date_time_string_1: ost$string,
        date_time_string_2: ost$string,
        field_p: ^field,
        length_string: ost$string,
        string_p: ^descriptive_data_string,
        subfield_number_string: ost$string,
        subfield_p: ^descriptive_data_subfield;

      status.normal := TRUE;

      IF pvt [p$display_option].value^.keyword_value = 'ALL' THEN

        STRINGREP (ptv$output_line, ptv$output_line_length, ' Selection : ', selection_p^.name);
        cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;

        IF selection_p^.statistic_specified OR selection_p^.date_time_specified OR
              selection_p^.descriptive_specified OR (selection_p^.predecessor_job_statistic_p <> NIL) OR
              (selection_p^.predecessor_task_statistic_p <> NIL) OR
              (selection_p^.job_name <> jmc$blank_system_supplied_name) OR selection_p^.task_id_specified THEN

          cyp$put_next_line (ptv$output_file, '   Selection Criteria', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          IF selection_p^.statistic_specified THEN
            ptv$output_line (1, 24) := '     Statistic Code   : ';
            ptv$output_line (25, 7) := selection_p^.statistic_name (1, 7);
          IFEND;
          cyp$put_next_line (ptv$output_file, ptv$output_line (1, 32), status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          IF selection_p^.date_time_specified THEN
            ptv$clt_date_time.value := selection_p^.start_date_time;
            clp$convert_date_time_to_string (ptv$clt_date_time, ptv$date_time_format, date_time_string_1,
                  status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            ptv$clt_date_time.value := selection_p^.end_date_time;
            clp$convert_date_time_to_string (ptv$clt_date_time, ptv$date_time_format, date_time_string_2,
                  status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            STRINGREP (ptv$output_line, ptv$output_line_length, '     Time             : ',
                  date_time_string_1.value (1, date_time_string_1.size): date_time_string_1.size, ' .. ',
                  date_time_string_2.value (1, date_time_string_2.size): date_time_string_2.size);
            cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            STRINGREP (ptv$output_line, ptv$output_line_length, '     Continuous       : ',
                  selection_p^.continuous_date_time);
            cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;

          IF selection_p^.descriptive_specified THEN
            cyp$put_next_line (ptv$output_file, '     Descriptive Data :', status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            subfield_p := selection_p^.descriptive_subfield_p;
            WHILE subfield_p <> NIL DO
              IF subfield_p^.subfield_length = sfc$max_descriptive_data_size THEN
                length_string.value := 'ALL';
                length_string.size := 3;
              ELSE
                clp$convert_integer_to_string (subfield_p^.subfield_length, 10, FALSE, length_string, status);
              IFEND;

              IF subfield_p^.subfield_number = 0 THEN
                subfield_number_string.value := 'ALL';
                subfield_number_string.size := 3;
              ELSE
                clp$convert_integer_to_string (subfield_p^.subfield_number, 10, FALSE, subfield_number_string,
                      status);
              IFEND;

              STRINGREP (ptv$output_line, ptv$output_line_length, '       Position : ',
                    subfield_p^.subfield_position, '  Length : ', length_string.value (1, length_string.size),
                    '  Field Number : ', subfield_number_string.value (1, subfield_number_string.size),
                    '  Field Delimiter : ''', subfield_p^.subfield_delimiter, '''');
              cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              cyp$put_next_line (ptv$output_file, '       String(s) :', status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
              string_p := subfield_p^.descriptive_data_string_p;
              WHILE string_p <> NIL DO
                write_descriptive_data_to_list (string_p^.descriptive_text
                      (1, #SIZE (string_p^.descriptive_text)), 9, status);
                IF NOT status.normal THEN
                  RETURN; {----->
                IFEND;
                string_p := string_p^.descriptive_string_link_p;
              WHILEND;
              subfield_p := subfield_p^.descriptive_subfield_link_p;
            WHILEND;
          IFEND;

          IF selection_p^.predecessor_job_statistic_p <> NIL THEN
            STRINGREP (ptv$output_line, ptv$output_line_length, '     Job predecessor selection : ',
                  selection_p^.predecessor_job_statistic_p^.name);
            cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;

          IF selection_p^.predecessor_task_statistic_p <> NIL THEN
            STRINGREP (ptv$output_line, ptv$output_line_length, '     Task predecessor selection : ',
                  selection_p^.predecessor_task_statistic_p^.name);
            cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;

          IF selection_p^.job_name <> jmc$blank_system_supplied_name THEN
            STRINGREP (ptv$output_line, ptv$output_line_length, '     Job Name         : ',
                  selection_p^.job_name);
            cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;

          IF selection_p^.task_id_specified THEN
            clp$convert_integer_to_rjstring (selection_p^.task_id.index, 10, FALSE, '0', task_id_index,
                  status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            clp$convert_integer_to_rjstring (selection_p^.task_id.seqno, 10, FALSE, '0', task_id_seqno,
                  status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            STRINGREP (ptv$output_line, ptv$output_line_length, '     Task ID          : ', task_id_index,
                  '-', task_id_seqno);
            cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;

        ELSE
          cyp$put_next_line (ptv$output_file, '   Selection Criteria : No Selection', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;

        IF selection_p^.number_of_successor_statistics > 0 THEN

          cyp$put_next_line (ptv$output_file, '   Usage', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          STRINGREP (ptv$output_line, ptv$output_line_length, '     Number of successor statistics  : ',
                selection_p^.number_of_successor_statistics);
          cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

        ELSE
          cyp$put_next_line (ptv$output_file, '   Usage : No References', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;

        IF selection_p^.log_entry_p <> NIL THEN
          put_entry_p := ptv$log_entry_chain_head_p;
          number := 1;
          WHILE selection_p^.log_entry_p <> put_entry_p DO
            put_entry_p := put_entry_p^.put_chain_link_p;
            number := number + 1;
          WHILEND;
          cyp$put_next_line (ptv$output_file, '   Put log reference :', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          STRINGREP (ptv$output_line, ptv$output_line_length, '     Number : ', number, '   Name : ',
                selection_p^.log_entry_p^.name);
          cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;

        IF selection_p^.field_chain_p <> NIL THEN

          cyp$put_next_line (ptv$output_file, '   Field References', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          cyp$put_next_line (ptv$output_file, 'Field Name                      Field Type', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          field_p := selection_p^.field_chain_p;
          WHILE field_p <> NIL DO

            CASE field_p^.field_type OF

            = counter_field =
              STRINGREP (ptv$output_line, ptv$output_line_length, field_p^.field_name,
                    ' Counter                Counter Number: ', field_p^.counter_number: 4);

            = descriptive_data_field =
              STRINGREP (ptv$output_line, ptv$output_line_length, field_p^.field_name, ' Descriptive Data');

            = date_time_field =
              STRINGREP (ptv$output_line, ptv$output_line_length, field_p^.field_name, ' Date Time');

            = statistic_code_field =
              STRINGREP (ptv$output_line, ptv$output_line_length, field_p^.field_name, ' Statistic Code');

            = system_job_name_field =
              STRINGREP (ptv$output_line, ptv$output_line_length, field_p^.field_name, ' System Job Name');

            = global_task_id_field =
              STRINGREP (ptv$output_line, ptv$output_line_length, field_p^.field_name, ' Global Task ID');

            = number_of_counters_field =
              STRINGREP (ptv$output_line, ptv$output_line_length, field_p^.field_name, ' Number of Counters');

            = descriptive_data_size_field =
              STRINGREP (ptv$output_line, ptv$output_line_length, field_p^.field_name,
                    ' Descriptive Data Size');

            = previous_occurrence_field =
              STRINGREP (ptv$output_line, ptv$output_line_length, field_p^.field_name,
                    ' Previous Occurrence');

            = predecessor_field =
              STRINGREP (ptv$output_line, ptv$output_line_length, field_p^.field_name, ' Predecessor');

            = predecessor_chain_head_field =
              STRINGREP (ptv$output_line, ptv$output_line_length, field_p^.field_name,
                    ' Predecessor Chain Head');

            = value_per_second_field =
              STRINGREP (ptv$output_line, ptv$output_line_length, field_p^.field_name, ' Value Per Second');

            = occurrence_per_second_field =
              STRINGREP (ptv$output_line, ptv$output_line_length, field_p^.field_name,
                    ' Occurrence Per Second');

            = text_field =
              STRINGREP (ptv$output_line, ptv$output_line_length, field_p^.field_name, ' Text');

            CASEND;

            cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            field_p := field_p^.field_chain_link_p;
          WHILEND;

        IFEND;

        cyp$put_next_line (ptv$output_file, ' ', status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      ELSE
        cyp$put_next_line (ptv$output_file, selection_p^.name, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      IFEND;

    PROCEND format_selection_display;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_display_selection, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

{ Opens output file.

    cyp$open_file (pvt [p$output].value^.file_value^, ^ptv$display_file_specifications, ptv$output_file,
          status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    ptv$maximum_line_length := cyp$page_width (ptv$output_file);
    IF ptv$maximum_line_length > 132 THEN
      ptv$maximum_line_length := 132;
    IFEND;

    errors_detected := FALSE;
    IF pvt [p$selection].value^.kind = clc$keyword THEN

{ ALL

      selection_p := ptv$selection_chain_head_p;
      WHILE selection_p <> NIL DO
        format_selection_display (status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        selection_p := selection_p^.selection_chain_link_p;
      WHILEND;
    ELSE

{ LIST

      value_p := pvt [p$selection].value;
      WHILE value_p <> NIL DO
        selection_p := ptv$selection_chain_head_p;
        WHILE (selection_p <> NIL) AND (value_p^.element_value^.name_value <> selection_p^.name) DO
          selection_p := selection_p^.selection_chain_link_p;
        WHILEND;
        IF selection_p <> NIL THEN
          format_selection_display (status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        ELSE
          errors_detected := TRUE;
          osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$undefined_selec_for_dis,
                value_p^.element_value^.name_value, failing_status);
          report_intermediate_error (failing_status, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          errors_detected := TRUE;
        IFEND;
        value_p := value_p^.link;
      WHILEND;
    IFEND;

    cyp$close_file (ptv$output_file, cyc$default_open_position, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    IF errors_detected THEN
      osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, 'SELECTION',
            status);
      RETURN; {----->
    IFEND;

  PROCEND display_selection_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'add_field_cmd', EJECT ??

{ This procedure processes the add_field command.

*copyc pth$anabl_add_field

  PROCEDURE add_field_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (ptm$anabl_addf) add_field, addf (
{  field, f: (CHECK) name = $required
{  selection, s: (CHECK) name = $required
{  counter, c: record
{      counter_number: integer 1..sfc$max_number_of_counters
{      multiplier: real = $optional
{      incremental: boolean = $optional
{      allow_negative_increment: boolean = $optional
{    recend = $optional
{  descriptive_data, dd: record
{      position: integer 1..sfc$max_descriptive_data_size = $optional
{      length: any of
{        key
{          all
{        keyend
{        integer 1..sfc$max_descriptive_data_size
{      anyend = $optional
{      field_number: any of
{        key
{          all
{        keyend
{        integer 1..sfc$max_descriptive_data_size
{      anyend = $optional
{      field_delimiter: string 1 = $optional
{    recend = $optional
{  header, h: key
{      (statistic_code , sc)
{      (date_time, dt)
{      (system_job_name, sjn)
{      (global_task_id, gti)
{      (number_of_counters, noc)
{      (descriptive_data_length, ddl)
{    keyend = $optional
{    elapsed_time, et: key
{      (previous_occurrence, po)
{      (predecessor, p)
{      (predecessor_chain_head, pch)
{    keyend = $optional
{  string, str: string 0..sfc$max_descriptive_data_size = $optional
{  elapsed_time_calculation, etc: (CHECK) record
{      calculation: key
{        (value_per_second, vps)
{        (occurrence_per_second, ops)
{      keyend
{      elapsed_time: key
{        (previous_occurrence, po)
{        (predecessor, p)
{        (predecessor_chain_head, pch)
{      keyend
{      counter_number: integer 1..sfc$max_number_of_counters = $optional
{      multiplier: real = $optional
{      incremental: boolean = $optional
{      allow_negative_increment: boolean = $optional
{    recend = $optional
{  text, t: (hidden) any of
{      string 0..sfc$max_descriptive_data_size
{      record
{        position: integer 1..sfc$max_descriptive_data_size = $optional
{        length: any of
{          key
{            (all, a)
{          keyend
{          integer 1..sfc$max_descriptive_data_size
{        anyend = $optional
{        field_number: any of
{          key
{            (all, a)
{          keyend
{          integer 1..sfc$max_descriptive_data_size
{        anyend = $optional
{        field_delimiter: string 1 = $optional
{      recend
{    anyend = $optional
{  multiplier, m: (hidden) real = $optional
{  incremental, i: (hidden) boolean = $optional
{  status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 23] of clt$pdt_parameter_name,
      parameters: array [1 .. 12] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$real_type_qualifier,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
        recend,
        field_spec_4: clt$field_specification,
        element_type_spec_4: record
          header: clt$type_specification_header,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: 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$integer_type_qualifier,
          recend,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: 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$integer_type_qualifier,
          recend,
        recend,
        field_spec_4: clt$field_specification,
        element_type_spec_4: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 12] of clt$keyword_specification,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 6] of clt$keyword_specification,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_4: clt$field_specification,
        element_type_spec_4: record
          header: clt$type_specification_header,
          qualifier: clt$real_type_qualifier,
        recend,
        field_spec_5: clt$field_specification,
        element_type_spec_5: record
          header: clt$type_specification_header,
        recend,
        field_spec_6: clt$field_specification,
        element_type_spec_6: record
          header: clt$type_specification_header,
        recend,
      recend,
      type9: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: 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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$real_type_qualifier,
      recend,
      type11: record
        header: clt$type_specification_header,
      recend,
      type12: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 28, 10, 51, 31, 378],
    clc$command, 23, 12, 2, 0, 3, 0, 12, 'PTM$ANABL_ADDF'], [
    ['C                              ',clc$abbreviation_entry, 3],
    ['COUNTER                        ',clc$nominal_entry, 3],
    ['DD                             ',clc$abbreviation_entry, 4],
    ['DESCRIPTIVE_DATA               ',clc$nominal_entry, 4],
    ['ELAPSED_TIME                   ',clc$nominal_entry, 6],
    ['ELAPSED_TIME_CALCULATION       ',clc$nominal_entry, 8],
    ['ET                             ',clc$abbreviation_entry, 6],
    ['ETC                            ',clc$abbreviation_entry, 8],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FIELD                          ',clc$nominal_entry, 1],
    ['H                              ',clc$abbreviation_entry, 5],
    ['HEADER                         ',clc$nominal_entry, 5],
    ['I                              ',clc$abbreviation_entry, 11],
    ['INCREMENTAL                    ',clc$nominal_entry, 11],
    ['M                              ',clc$abbreviation_entry, 10],
    ['MULTIPLIER                     ',clc$nominal_entry, 10],
    ['S                              ',clc$abbreviation_entry, 2],
    ['SELECTION                      ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 12],
    ['STR                            ',clc$abbreviation_entry, 7],
    ['STRING                         ',clc$nominal_entry, 7],
    ['T                              ',clc$abbreviation_entry, 9],
    ['TEXT                           ',clc$nominal_entry, 9]],
    [
{ PARAMETER 1
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 212,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 347,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 451,
  clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 8
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 668,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [23, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 449,
  clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [16, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 35, clc$optional_parameter,
  0, 0],
{ PARAMETER 11
    [14, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 12
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$record_type], [4],
    ['COUNTER_NUMBER                 ', clc$required_field, 20], [[1, 0, clc$integer_type], [1,
  sfc$max_number_of_counters, 10]],
    ['MULTIPLIER                     ', clc$optional_field, 35], [[1, 0, clc$real_type],
      [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
      [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]]
      ],
    ['INCREMENTAL                    ', clc$optional_field, 3], [[1, 0, clc$boolean_type]],
    ['ALLOW_NEGATIVE_INCREMENT       ', clc$optional_field, 3], [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 4
    [[1, 0, clc$record_type], [4],
    ['POSITION                       ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  sfc$max_descriptive_data_size, 10]],
    ['LENGTH                         ', clc$optional_field, 84], [[1, 0, clc$union_type], [[
      clc$integer_type, clc$keyword_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      20, [[1, 0, clc$integer_type], [1, sfc$max_descriptive_data_size, 10]]
      ],
    ['FIELD_NUMBER                   ', clc$optional_field, 84], [[1, 0, clc$union_type], [[
      clc$integer_type, clc$keyword_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      20, [[1, 0, clc$integer_type], [1, sfc$max_descriptive_data_size, 10]]
      ],
    ['FIELD_DELIMITER                ', clc$optional_field, 8], [[1, 0, clc$string_type], [1, 1, FALSE]]
    ],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [12], [
    ['DATE_TIME                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['DDL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['DESCRIPTIVE_DATA_LENGTH        ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['DT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['GLOBAL_TASK_ID                 ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['GTI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['NOC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['NUMBER_OF_COUNTERS             ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['SC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SJN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['STATISTIC_CODE                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['SYSTEM_JOB_NAME                ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [6], [
    ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['PCH                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['PO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['PREDECESSOR                    ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['PREDECESSOR_CHAIN_HEAD         ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['PREVIOUS_OCCURRENCE            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 7
    [[1, 0, clc$string_type], [0, sfc$max_descriptive_data_size, FALSE]],
{ PARAMETER 8
    [[1, 0, clc$record_type], [6],
    ['CALCULATION                    ', clc$required_field, 155], [[1, 0, clc$keyword_type], [4], [
      ['OCCURRENCE_PER_SECOND          ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['OPS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['VALUE_PER_SECOND               ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['VPS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1]]
      ],
    ['ELAPSED_TIME                   ', clc$required_field, 229], [[1, 0, clc$keyword_type], [6], [
      ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['PCH                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['PO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['PREDECESSOR                    ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['PREDECESSOR_CHAIN_HEAD         ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['PREVIOUS_OCCURRENCE            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    ['COUNTER_NUMBER                 ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  sfc$max_number_of_counters, 10]],
    ['MULTIPLIER                     ', clc$optional_field, 35], [[1, 0, clc$real_type],
      [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
      [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]]
      ],
    ['INCREMENTAL                    ', clc$optional_field, 3], [[1, 0, clc$boolean_type]],
    ['ALLOW_NEGATIVE_INCREMENT       ', clc$optional_field, 3], [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$record_type, clc$string_type],
    FALSE, 2],
    8, [[1, 0, clc$string_type], [0, sfc$max_descriptive_data_size, FALSE]],
    421, [[1, 0, clc$record_type], [4],
      ['POSITION                       ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  sfc$max_descriptive_data_size, 10]],
      ['LENGTH                         ', clc$optional_field, 121], [[1, 0, clc$union_type], [[
        clc$integer_type, clc$keyword_type],
        FALSE, 2],
        81, [[1, 0, clc$keyword_type], [2], [
          ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
          ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [1, sfc$max_descriptive_data_size, 10]]
        ],
      ['FIELD_NUMBER                   ', clc$optional_field, 121], [[1, 0, clc$union_type], [[
        clc$integer_type, clc$keyword_type],
        FALSE, 2],
        81, [[1, 0, clc$keyword_type], [2], [
          ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
          ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [1, sfc$max_descriptive_data_size, 10]]
        ],
      ['FIELD_DELIMITER                ', clc$optional_field, 8], [[1, 0, clc$string_type], [1, 1, FALSE]]
      ]
    ],
{ PARAMETER 10
    [[1, 0, clc$real_type],
    [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
    [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]]
    ],
{ PARAMETER 11
    [[1, 0, clc$boolean_type]],
{ PARAMETER 12
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$field = 1,
      p$selection = 2,
      p$counter = 3,
      p$descriptive_data = 4,
      p$header = 5,
      p$elapsed_time = 6,
      p$string = 7,
      p$elapsed_time_calculation = 8,
      p$text = 9,
      p$multiplier = 10,
      p$incremental = 11,
      p$status = 12;

    VAR
      pvt: array [1 .. 12] of clt$parameter_value;

    VAR
      field_p: ^field,
      field_type: type_of_field,

{ The record initial_field must be initialized with a field type, that type is date_time_field.

      initial_field: [STATIC, READ] field := [ * { field_name } , NIL
            { field_chain_link_p } , NIL { selection_p } , NIL { original_selection_p } , NIL
            { report_list_p } , FALSE { first_value } , FALSE { collect_summary } , FALSE
            { collect_all_occurrences } , [0 { count } , 0 { sum } , 0.0 { mean } ,
            0.0 { standard_deviation }, 0.0 { square_sum } , clc$max_integer { minimum } , -clc$max_integer
            { maximum } , 0 { interval } , 0 { elapsed_time_since_predecessor } , 0.0 { count_per_sec } , 0.0
            { sum_per_sec } , * { first_date_time } , * { last_date_time } , FALSE { sum_overflow } ], 1
            { counter_number } , 1.0 { multiplier } , FALSE { incremental } , FALSE
            { allow_negative_increment } , 0 { last_value } , date_time_field
            { field_type } , * { first_date_time_value } , * { last_date_time_value } , NIL
            { date_time_value_head_p } , NIL { date_time_value_tail_p } ],
      long_real_value: record
        high: real,
        low: real,
      recend,
      selection_p: ^selection;

?? NEWTITLE := 'check_add_field', EJECT ??

    PROCEDURE check_add_field
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF

        = p$field =
          check_duplicate_field_name (pvt [p$field].value^.name_value, status);

        = p$selection =
          check_undefined_selection (pvt [p$selection].value^.name_value, pte$undefined_selec_for_field,
                selection_p, status);

        = p$elapsed_time_calculation =
          IF pvt [p$elapsed_time_calculation].value^.field_values^ [1].value^.keyword_value =
                ptc$key_value_per_second THEN
            IF pvt [p$elapsed_time_calculation].value^.field_values^ [3].value = NIL { counter_number } THEN
              osp$set_status_condition (pte$no_counter_in_etc_vps, status);
            IFEND;
          ELSE { = ptc$key_occurrence_per_second }
            IF (pvt [p$elapsed_time_calculation].value^.field_values^ [3].value <> NIL)
                  { counter_number } OR (pvt [p$elapsed_time_calculation].value^.field_values^ [4].
                  value <> NIL) { multiplier } OR (pvt [p$elapsed_time_calculation].value^.field_values^ [5].
                  value <> NIL) { incremental } OR (pvt [p$elapsed_time_calculation].value^.field_values^ [6].
                  value <> NIL) { allow_negative_increment } THEN
              osp$set_status_condition (pte$counter_in_etc_ops, status);
            IFEND;
          IFEND;

        ELSE
        CASEND;
      IFEND;

    PROCEND check_add_field;

?? OLDTITLE ??
?? NEWTITLE := 'allocate_field', EJECT ??

    PROCEDURE allocate_field;

      IF selection_p^.field_chain_p <> NIL THEN
        field_p := selection_p^.field_chain_p;
        WHILE field_p^.field_chain_link_p <> NIL DO
          field_p := field_p^.field_chain_link_p;
        WHILEND;
        ALLOCATE field_p^.field_chain_link_p;
        field_p := field_p^.field_chain_link_p;
      ELSE
        ALLOCATE selection_p^.field_chain_p;
        field_p := selection_p^.field_chain_p;
      IFEND;

      field_p^ := initial_field;
      field_p^.field_name := pvt [p$field].value^.name_value;
      field_p^.selection_p := selection_p;
      field_p^.field_type := field_type;

    PROCEND allocate_field;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    field_type := undefined_field;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_add_field, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    process_field_type (pvt [p$counter], pvt [p$descriptive_data], pvt [p$header], pvt [p$elapsed_time],
          pvt [p$string], pvt [p$elapsed_time_calculation], pvt[p$text], field_type, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    IF field_type = undefined_field THEN
      osp$set_status_condition (pte$no_field_type_parameter, status);
      RETURN;
    IFEND;

    IF (pvt [p$incremental].specified OR pvt [p$multiplier].specified) THEN

{  Incremental and multiplier are valid only for counter_field, value_per_second_field and
{  occurrence_per_second_field.

      IF NOT ((field_type = counter_field) OR
              (field_type = value_per_second_field) OR
              (field_type = occurrence_per_second_field)) THEN
          osp$set_status_condition (pte$incr_or_mult_not_allowed, status);
          RETURN;
      IFEND;
    IFEND;

    allocate_field;
    set_field_type (field_type, field_p, status);

{ Start 1.4.1 compatibility code.

      IF pvt [p$incremental].specified THEN
        field_p^.incremental := pvt [p$incremental].value^.boolean_value.value;
      IFEND;

      IF pvt [p$multiplier].specified THEN
        #UNCHECKED_CONVERSION (pvt [p$multiplier].value^.real_value.value, long_real_value);
        field_p^.multiplier := long_real_value.high;
      IFEND;

{ End 1.4.1 compatibility code.

    CASE field_type OF

    = counter_field =
      set_field_counter (pvt [p$counter].value, field_p);

    = descriptive_data_field =
      IF pvt [p$descriptive_data].specified THEN
        set_field_descriptive_data (pvt [p$descriptive_data].value, field_p);
      ELSE { text parameter specified - 1.4.1 compatibility code }
        set_field_descriptive_data (pvt [p$text].value, field_p);
      IFEND;

    = value_per_second_field =
      set_field_counter (pvt [p$elapsed_time_calculation].value, field_p);
      set_elapsed_time_field (pvt [p$elapsed_time_calculation].value^.field_values^ [2], field_p);

    = occurrence_per_second_field =
      set_elapsed_time_field (pvt [p$elapsed_time_calculation].value^.field_values^ [2], field_p);

    = text_field =
      IF pvt [p$string].specified THEN
        ALLOCATE field_p^.descriptive_text_p: [#SIZE (pvt [p$string].value^.string_value^)];
        field_p^.descriptive_text_p^ := pvt [p$string].value^.string_value^;
      ELSE { text parameter specified - 1.4.1 compatibility code }
        ALLOCATE field_p^.descriptive_text_p: [#SIZE (pvt [p$text].value^.string_value^)];
        field_p^.descriptive_text_p^ := pvt [p$text].value^.string_value^;
      IFEND;

    ELSE
    CASEND;

  PROCEND add_field_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'change_field_cmd', EJECT ??

{ This procedure processes the change_field command.

*copyc pth$anabl_change_field

  PROCEDURE change_field_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (ptm$anabl_chaf) change_field, chaf (
{  field, f: (CHECK) name = $required
{  new_field, nf: (CHECK) name = $optional
{  selection, s: (CHECK) name = $optional
{  counter, c: (CHECK) record
{      counter_number: integer 1..sfc$max_number_of_counters = $optional
{      multiplier: real = $optional
{      incremental: boolean = $optional
{      allow_negative_increment: boolean = $optional
{    recend = $optional
{  descriptive_data, dd: record
{      position: integer 1..sfc$max_descriptive_data_size = $optional
{      length: any of
{        key
{          all
{        keyend
{        integer 1..sfc$max_descriptive_data_size
{      anyend = $optional
{      field_number: any of
{        key
{          all
{        keyend
{        integer 1..sfc$max_descriptive_data_size
{      anyend = $optional
{      field_delimiter: string 1 = $optional
{    recend = $optional
{  header, h: key
{      (statistic_code , sc)
{      (date_time, dt)
{      (system_job_name, sjn)
{      (global_task_id, gti)
{      (number_of_counters, noc)
{      (descriptive_data_length, ddl)
{    keyend = $optional
{    elapsed_time, et: key
{      (previous_occurrence, po)
{      (predecessor, p)
{      (predecessor_chain_head, pch)
{    keyend = $optional
{  string, str: string 0..sfc$max_descriptive_data_size = $optional
{  elapsed_time_calculation, etc: (CHECK) record
{      calculation: key
{        (value_per_second, vps)
{        (occurrence_per_second, ops)
{      keyend = $optional
{      elapsed_time: key
{        (previous_occurrence, po)
{        (predecessor, p)
{        (predecessor_chain_head, pch)
{      keyend = $optional
{      counter_number: integer 1..sfc$max_number_of_counters = $optional
{      multiplier: real = $optional
{      incremental: boolean = $optional
{      allow_negative_increment: boolean = $optional
{    recend = $optional
{  text, t: (hidden) any of
{      string 0..sfc$max_descriptive_data_size
{      record
{        position: integer 1..sfc$max_descriptive_data_size = $optional
{        length: any of
{          key
{            (all, a)
{          keyend
{          integer 1..sfc$max_descriptive_data_size
{        anyend = $optional
{        field_number: any of
{          key
{            (all, a)
{          keyend
{          integer 1..sfc$max_descriptive_data_size
{        anyend = $optional
{        field_delimiter: string 1 = $optional
{      recend
{    anyend = $optional
{  multiplier, m: (hidden) real = $optional
{  incremental, i: (hidden) boolean = $optional
{  status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 25] of clt$pdt_parameter_name,
      parameters: array [1 .. 13] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$real_type_qualifier,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
        recend,
        field_spec_4: clt$field_specification,
        element_type_spec_4: record
          header: clt$type_specification_header,
        recend,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: 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$integer_type_qualifier,
          recend,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: 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$integer_type_qualifier,
          recend,
        recend,
        field_spec_4: clt$field_specification,
        element_type_spec_4: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 12] of clt$keyword_specification,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 6] of clt$keyword_specification,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_4: clt$field_specification,
        element_type_spec_4: record
          header: clt$type_specification_header,
          qualifier: clt$real_type_qualifier,
        recend,
        field_spec_5: clt$field_specification,
        element_type_spec_5: record
          header: clt$type_specification_header,
        recend,
        field_spec_6: clt$field_specification,
        element_type_spec_6: record
          header: clt$type_specification_header,
        recend,
      recend,
      type10: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: 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 .. 2] of clt$keyword_specification,
            recend,
            type_size_2: clt$type_specification_size,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$real_type_qualifier,
      recend,
      type12: record
        header: clt$type_specification_header,
      recend,
      type13: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 28, 11, 0, 41, 494],
    clc$command, 25, 13, 1, 0, 3, 0, 13, 'PTM$ANABL_CHAF'], [
    ['C                              ',clc$abbreviation_entry, 4],
    ['COUNTER                        ',clc$nominal_entry, 4],
    ['DD                             ',clc$abbreviation_entry, 5],
    ['DESCRIPTIVE_DATA               ',clc$nominal_entry, 5],
    ['ELAPSED_TIME                   ',clc$nominal_entry, 7],
    ['ELAPSED_TIME_CALCULATION       ',clc$nominal_entry, 9],
    ['ET                             ',clc$abbreviation_entry, 7],
    ['ETC                            ',clc$abbreviation_entry, 9],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FIELD                          ',clc$nominal_entry, 1],
    ['H                              ',clc$abbreviation_entry, 6],
    ['HEADER                         ',clc$nominal_entry, 6],
    ['I                              ',clc$abbreviation_entry, 12],
    ['INCREMENTAL                    ',clc$nominal_entry, 12],
    ['M                              ',clc$abbreviation_entry, 11],
    ['MULTIPLIER                     ',clc$nominal_entry, 11],
    ['NEW_FIELD                      ',clc$nominal_entry, 2],
    ['NF                             ',clc$abbreviation_entry, 2],
    ['S                              ',clc$abbreviation_entry, 3],
    ['SELECTION                      ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 13],
    ['STR                            ',clc$abbreviation_entry, 8],
    ['STRING                         ',clc$nominal_entry, 8],
    ['T                              ',clc$abbreviation_entry, 10],
    ['TEXT                           ',clc$nominal_entry, 10]],
    [
{ PARAMETER 1
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 212,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 347,
  clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 451,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 9
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 668,
  clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [25, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 449,
  clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [16, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 35, clc$optional_parameter,
  0, 0],
{ PARAMETER 12
    [14, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 13
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 4
    [[1, 0, clc$record_type], [4],
    ['COUNTER_NUMBER                 ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  sfc$max_number_of_counters, 10]],
    ['MULTIPLIER                     ', clc$optional_field, 35], [[1, 0, clc$real_type],
      [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
      [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]]
      ],
    ['INCREMENTAL                    ', clc$optional_field, 3], [[1, 0, clc$boolean_type]],
    ['ALLOW_NEGATIVE_INCREMENT       ', clc$optional_field, 3], [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 5
    [[1, 0, clc$record_type], [4],
    ['POSITION                       ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  sfc$max_descriptive_data_size, 10]],
    ['LENGTH                         ', clc$optional_field, 84], [[1, 0, clc$union_type], [[
      clc$integer_type, clc$keyword_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      20, [[1, 0, clc$integer_type], [1, sfc$max_descriptive_data_size, 10]]
      ],
    ['FIELD_NUMBER                   ', clc$optional_field, 84], [[1, 0, clc$union_type], [[
      clc$integer_type, clc$keyword_type],
      FALSE, 2],
      44, [[1, 0, clc$keyword_type], [1], [
        ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
        ],
      20, [[1, 0, clc$integer_type], [1, sfc$max_descriptive_data_size, 10]]
      ],
    ['FIELD_DELIMITER                ', clc$optional_field, 8], [[1, 0, clc$string_type], [1, 1, FALSE]]
    ],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [12], [
    ['DATE_TIME                      ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['DDL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
    ['DESCRIPTIVE_DATA_LENGTH        ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['DT                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['GLOBAL_TASK_ID                 ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['GTI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['NOC                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['NUMBER_OF_COUNTERS             ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['SC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SJN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['STATISTIC_CODE                 ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['SYSTEM_JOB_NAME                ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 7
    [[1, 0, clc$keyword_type], [6], [
    ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['PCH                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['PO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['PREDECESSOR                    ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['PREDECESSOR_CHAIN_HEAD         ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['PREVIOUS_OCCURRENCE            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 8
    [[1, 0, clc$string_type], [0, sfc$max_descriptive_data_size, FALSE]],
{ PARAMETER 9
    [[1, 0, clc$record_type], [6],
    ['CALCULATION                    ', clc$optional_field, 155], [[1, 0, clc$keyword_type], [4], [
      ['OCCURRENCE_PER_SECOND          ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['OPS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['VALUE_PER_SECOND               ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['VPS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1]]
      ],
    ['ELAPSED_TIME                   ', clc$optional_field, 229], [[1, 0, clc$keyword_type], [6], [
      ['P                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['PCH                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['PO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['PREDECESSOR                    ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['PREDECESSOR_CHAIN_HEAD         ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['PREVIOUS_OCCURRENCE            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    ['COUNTER_NUMBER                 ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  sfc$max_number_of_counters, 10]],
    ['MULTIPLIER                     ', clc$optional_field, 35], [[1, 0, clc$real_type],
      [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
      [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]]
      ],
    ['INCREMENTAL                    ', clc$optional_field, 3], [[1, 0, clc$boolean_type]],
    ['ALLOW_NEGATIVE_INCREMENT       ', clc$optional_field, 3], [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$record_type, clc$string_type],
    FALSE, 2],
    8, [[1, 0, clc$string_type], [0, sfc$max_descriptive_data_size, FALSE]],
    421, [[1, 0, clc$record_type], [4],
      ['POSITION                       ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  sfc$max_descriptive_data_size, 10]],
      ['LENGTH                         ', clc$optional_field, 121], [[1, 0, clc$union_type], [[
        clc$integer_type, clc$keyword_type],
        FALSE, 2],
        81, [[1, 0, clc$keyword_type], [2], [
          ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
          ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [1, sfc$max_descriptive_data_size, 10]]
        ],
      ['FIELD_NUMBER                   ', clc$optional_field, 121], [[1, 0, clc$union_type], [[
        clc$integer_type, clc$keyword_type],
        FALSE, 2],
        81, [[1, 0, clc$keyword_type], [2], [
          ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
          ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [1, sfc$max_descriptive_data_size, 10]]
        ],
      ['FIELD_DELIMITER                ', clc$optional_field, 8], [[1, 0, clc$string_type], [1, 1, FALSE]]
      ]
    ],
{ PARAMETER 11
    [[1, 0, clc$real_type],
    [[{-$INFINITY} 3, [[0D000(16), 0(16)], [0D000(16), 0(16)]]],
    [{$INFINITY} 3, [[5000(16), 0(16)], [5000(16), 0(16)]]]]
    ],
{ PARAMETER 12
    [[1, 0, clc$boolean_type]],
{ PARAMETER 13
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$field = 1,
      p$new_field = 2,
      p$selection = 3,
      p$counter = 4,
      p$descriptive_data = 5,
      p$header = 6,
      p$elapsed_time = 7,
      p$string = 8,
      p$elapsed_time_calculation = 9,
      p$text = 10,
      p$multiplier = 11,
      p$incremental = 12,
      p$status = 13;

    VAR
      pvt: array [1 .. 13] of clt$parameter_value;

    VAR
      field_p: ^field,
      field_1_p: ^field,
      long_real_value: record
        high: real,
        low: real,
      recend,
      new_field_type: type_of_field,
      new_selection_p: ^selection,
      selection_p: ^selection,
      test_field_type: type_of_field;

?? NEWTITLE := 'check_change_field', EJECT ??

    PROCEDURE check_change_field
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);


      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF

        = p$field =
          selection_p := ptv$selection_chain_head_p;

        /change/
          WHILE selection_p <> NIL DO

            field_p := selection_p^.field_chain_p;
            WHILE (field_p <> NIL) AND (field_p^.field_name <> pvt [p$field].value^.name_value) DO
              field_p := field_p^.field_chain_link_p;
            WHILEND;

            IF field_p <> NIL THEN
              EXIT /change/; {----->
            IFEND;

            selection_p := selection_p^.selection_chain_link_p;
          WHILEND /change/;
          IF field_p = NIL THEN
            osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$undefined_field_for_change,
                  pvt [p$field].value^.name_value, status);
          IFEND;

        = p$new_field =
          IF pvt [p$new_field].specified THEN
            check_duplicate_field_name (pvt [p$new_field].value^.name_value, status);
          IFEND;

        = p$selection =
          IF pvt [p$selection].specified THEN
            check_undefined_selection (pvt [p$selection].value^.name_value, pte$undefined_selec_for_field,
                  new_selection_p, status);
          IFEND;

        = p$counter =
          IF (field_p <> NIL) AND (field_p^.field_type <> counter_field) AND
                (pvt [p$counter].value^.field_values^ [1].value = NIL) { counter_number } THEN

{ User must specify counter_number in order to change the type of the field to counter field type.

            osp$set_status_condition (pte$no_counter_number, status);
          IFEND;

        = p$elapsed_time_calculation =
          IF (field_p^.field_type <> value_per_second_field) AND
                (field_p^.field_type <> occurrence_per_second_field) THEN

{ User must specify calculation and elapsed_time in order to change the type of the field to
{ occurrence_per_second field type or value_per_second field type.

            IF pvt [p$elapsed_time_calculation].value^.field_values^ [1].value = NIL { calculation } THEN

{ User specified parameter elapsed_time_calculation when the current field type isn't value_per_second_field
{ or occurrence_per_second_field and didn't specify the required field calculation.

              osp$set_status_condition (pte$no_calculation_in_etc, status);
              RETURN; {----->
            IFEND;

            IF pvt [p$elapsed_time_calculation].value^.field_values^ [2].value = NIL { elapsed_time } THEN

{ User specified parameter elapsed_time_calculation when the current field type isn't value_per_second_field
{ or occurrence_per_second_field and didn't specify the required field elapsed_time.

              osp$set_status_condition (pte$no_elapsed_time_in_etc, status);
              RETURN; {----->
            IFEND;

          IFEND;

          IF (field_p^.field_type <> value_per_second_field) AND
                (pvt [p$elapsed_time_calculation].value^.field_values^ [1].value^.keyword_value =
                ptc$key_value_per_second) AND (pvt [p$elapsed_time_calculation].value^.field_values^ [3].
                value = NIL) { counter_number } THEN

{ User must specify counter_number in order to change the type of the field to value_per_second field type.

            osp$set_status_condition (pte$no_counter_in_etc_vps, status);
            RETURN; {----->
          IFEND;

          IF ((field_p^.field_type = occurrence_per_second_field) AND
                (pvt [p$elapsed_time_calculation].value^.field_values^ [1].value = NIL)) OR
                ((pvt [p$elapsed_time_calculation].value^.field_values^ [1].value <> NIL) AND
                (pvt [p$elapsed_time_calculation].value^.field_values^ [1].value^.keyword_value =
                ptc$key_occurrence_per_second)) THEN
            IF (pvt [p$elapsed_time_calculation].value^.field_values^ [3].value <> NIL)
                  { counter_number } OR (pvt [p$elapsed_time_calculation].value^.field_values^ [4].
                  value <> NIL) { multiplier } OR (pvt [p$elapsed_time_calculation].value^.field_values^ [5].
                  value <> NIL) { incremental } OR (pvt [p$elapsed_time_calculation].value^.field_values^ [6].
                  value <> NIL) { allow_negative_increment} THEN
              osp$set_status_condition (pte$counter_in_etc_ops, status);
              RETURN; {----->
            IFEND;
          IFEND;

        ELSE
        CASEND;
      IFEND;

    PROCEND check_change_field;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    new_field_type := undefined_field;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_change_field, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    process_field_type (pvt [p$counter], pvt [p$descriptive_data], pvt [p$header], pvt [p$elapsed_time],
          pvt [p$string], pvt [p$elapsed_time_calculation], pvt [p$text], new_field_type, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    IF (new_field_type = undefined_field) AND pvt [p$elapsed_time_calculation].specified THEN

{   Elapsed_time_calculation parameter was specified without specifying the field calculation.  The new field
{ type is the current field type (value_per_second_field or occurrence_per_second_field).

      new_field_type := field_p^.field_type;
    IFEND;

    IF (pvt [p$incremental].specified OR pvt [p$multiplier].specified) THEN

{  Incremental and multiplier are valid only for counter_field, value_per_second_field and
{  occurrence_per_second_field.  If a field type is specified on the change_field command
{  check using the new field type, otherwise check using the existing field type.

      IF new_field_type = undefined_field THEN
        test_field_type := field_p^.field_type;
      ELSE
        test_field_type := new_field_type;
      IFEND;

      IF NOT ((test_field_type = counter_field) OR
              (test_field_type = value_per_second_field) OR
              (test_field_type = occurrence_per_second_field)) THEN
          osp$set_status_condition (pte$incr_or_mult_not_allowed, status);
          RETURN;
      IFEND;
    IFEND;

{ Start 1.4.1 compatibility code.

    IF pvt [p$incremental].specified THEN
      field_p^.incremental := pvt [p$incremental].value^.boolean_value.value;
    IFEND;

    IF pvt [p$multiplier].specified THEN
      #UNCHECKED_CONVERSION (pvt [p$multiplier].value^.real_value.value, long_real_value);
      field_p^.multiplier := long_real_value.high;
    IFEND;

{ End 1.4.1 compatibility code.

    IF pvt [p$new_field].specified THEN
      field_p^.field_name := pvt [p$new_field].value^.name_value;
    IFEND;

    IF pvt [p$selection].specified THEN
      IF selection_p^.field_chain_p = field_p THEN
        selection_p^.field_chain_p := field_p^.field_chain_link_p;
      ELSE
        field_1_p := selection_p^.field_chain_p;
        WHILE field_1_p^.field_chain_link_p <> field_p DO
          field_1_p := field_1_p^.field_chain_link_p;
        WHILEND;
        field_1_p^.field_chain_link_p := field_p^.field_chain_link_p;
      IFEND;

      IF new_selection_p^.field_chain_p <> NIL THEN
        field_1_p := new_selection_p^.field_chain_p;
        WHILE field_1_p^.field_chain_link_p <> NIL DO
          field_1_p := field_1_p^.field_chain_link_p;
        WHILEND;
        field_1_p^.field_chain_link_p := field_p;
      ELSE
        new_selection_p^.field_chain_p := field_p;
      IFEND;
      field_p^.field_chain_link_p := NIL;
      field_p^.selection_p := new_selection_p;
    IFEND;

    IF new_field_type <> undefined_field THEN

      IF field_p^.field_type = text_field THEN
        FREE field_p^.descriptive_text_p;
      IFEND;

      IF new_field_type <> field_p^.field_type THEN
        field_p^.field_type := new_field_type;
        set_field_type (new_field_type, field_p, status);
      IFEND;

      CASE new_field_type OF

      = counter_field =
        set_field_counter (pvt [p$counter].value, field_p);

      = descriptive_data_field =
        IF pvt [p$descriptive_data].specified THEN
          set_field_descriptive_data (pvt [p$descriptive_data].value, field_p);
        ELSE { text parameter specified - 1.4.1 compatibility code }
          set_field_descriptive_data (pvt [p$text].value, field_p);
        IFEND;

      = value_per_second_field =
        set_field_counter (pvt [p$elapsed_time_calculation].value, field_p);
        set_elapsed_time_field (pvt [p$elapsed_time_calculation].value^.field_values^ [2], field_p);

      = occurrence_per_second_field =
        set_elapsed_time_field (pvt [p$elapsed_time_calculation].value^.field_values^ [2], field_p);

      = text_field =
        IF pvt [p$string].specified THEN
          ALLOCATE field_p^.descriptive_text_p: [#SIZE (pvt [p$string].value^.string_value^)];
          field_p^.descriptive_text_p^ := pvt [p$string].value^.string_value^;
        ELSE { text parameter specified - 1.4.1 compatibility code }
          ALLOCATE field_p^.descriptive_text_p: [#SIZE (pvt [p$text].value^.string_value^)];
          field_p^.descriptive_text_p^ := pvt [p$text].value^.string_value^;
        IFEND;

      ELSE
      CASEND;

    IFEND;

  PROCEND change_field_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'delete_field_cmd', EJECT ??

{ This procedure processes the delete_field command.

*copyc pth$anabl_delete_field

  PROCEDURE delete_field_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (ptm$anabl_delf) delete_field, delf (
{  field, fields, f: (CHECK) any of
{      key
{        all
{      keyend
{      list of name
{    anyend = $required
{  status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 27, 12, 46, 13, 237],
    clc$command, 4, 2, 1, 0, 0, 0, 2, 'PTM$ANABL_DELF'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FIELD                          ',clc$nominal_entry, 1],
    ['FIELDS                         ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 85, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$field = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      delete_status: boolean,
      errors_detected: boolean,
      failing_status: ost$status,
      field_1_p: ^field,
      field_2_p: ^field,
      selection_p: ^selection,
      value_p: ^clt$data_value;

?? NEWTITLE := 'check_delete_field', EJECT ??

    PROCEDURE check_delete_field
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$field =
          IF pvt [p$field].value^.kind = clc$list THEN
            report_duplicate_name (pvt [p$field].value, 'FIELD', status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;
          report_put (pvt [p$field].value, status);
        ELSE
        CASEND;
      IFEND;

    PROCEND check_delete_field;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    errors_detected := FALSE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_delete_field, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    IF pvt [p$field].value^.kind = clc$keyword THEN

{ ALL

      selection_p := ptv$selection_chain_head_p;
      WHILE selection_p <> NIL DO

        field_1_p := selection_p^.field_chain_p;
        WHILE field_1_p <> NIL DO
          field_2_p := field_1_p^.field_chain_link_p;
          IF field_1_p^.field_type = text_field THEN
            FREE field_1_p^.descriptive_text_p;
          IFEND;
          FREE field_1_p;
          field_1_p := field_2_p;
        WHILEND;
        selection_p^.field_chain_p := NIL;

        selection_p := selection_p^.selection_chain_link_p;
      WHILEND;
    ELSE

{ LIST

      value_p := pvt [p$field].value;
      WHILE value_p <> NIL DO
        delete_status := FALSE;
        selection_p := ptv$selection_chain_head_p;

      /delete/
        WHILE selection_p <> NIL DO

          field_1_p := selection_p^.field_chain_p;
          field_2_p := selection_p^.field_chain_p;
          WHILE (field_1_p <> NIL) AND (field_1_p^.field_name <> value_p^.element_value^.name_value) DO
            field_2_p := field_1_p;
            field_1_p := field_1_p^.field_chain_link_p;
          WHILEND;

          IF field_1_p <> NIL THEN
            IF field_1_p = selection_p^.field_chain_p THEN
              selection_p^.field_chain_p := field_1_p^.field_chain_link_p;
            ELSE
              field_2_p^.field_chain_link_p := field_1_p^.field_chain_link_p;
            IFEND;
            IF field_1_p^.field_type = text_field THEN
              FREE field_1_p^.descriptive_text_p;
            IFEND;
            FREE field_1_p;
            delete_status := TRUE;
            EXIT /delete/; {----->
          IFEND;

          selection_p := selection_p^.selection_chain_link_p;
        WHILEND /delete/;

        IF NOT delete_status THEN
          osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$undefined_field_for_delete,
                value_p^.element_value^.name_value, failing_status);
          report_intermediate_error (failing_status, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          errors_detected := TRUE;
        IFEND;

        value_p := value_p^.link;
      WHILEND;
      IF errors_detected THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, 'FIELD', status);
        RETURN; {----->
      IFEND;
    IFEND;

  PROCEND delete_field_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'display_field_cmd', EJECT ??

{ This procedure processes the display_field command.

*copyc pth$anabl_display_field

  PROCEDURE display_field_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (ptm$anabl_disf) display_field, disf (
{  field, fields, f: (CHECK) any of
{      key
{        all
{      keyend
{      list of name
{    anyend = all
{  display_option, do: key
{      (all, a)
{      (name, names, n)
{    keyend = name
{  output, o: file = $output
{  status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 27, 12, 46, 59, 719],
    clc$command, 8, 4, 0, 0, 0, 0, 4, 'PTM$ANABL_DISF'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FIELD                          ',clc$nominal_entry, 1],
    ['FIELDS                         ',clc$alias_entry, 1],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 85,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [5], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['NAME                           ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['NAMES                          ', clc$alias_entry, clc$normal_usage_entry, 2]]
    ,
    'name'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$field = 1,
      p$display_option = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      display_status: boolean,
      errors_detected: boolean,
      failing_status: ost$status,
      field_p: ^field,
      number: integer,
      put_entry_p: ^put_entry,
      report_list_p: ^report_list,
      selection_p: ^selection,
      value_p: ^clt$data_value;


?? NEWTITLE := 'check_display_field', EJECT ??

    PROCEDURE check_display_field
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$field =
          IF pvt [p$field].value^.kind = clc$list THEN
            report_duplicate_name (pvt [p$field].value, 'FIELD', status);
          IFEND;
        ELSE
        CASEND;
      IFEND;

    PROCEND check_display_field;

?? OLDTITLE ??
?? NEWTITLE := 'display_report_list', EJECT ??

    PROCEDURE display_report_list
      (VAR status: ost$status);

      status.normal := TRUE;

      cyp$put_next_line (ptv$output_file, '   Put Report Reference :', status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

      WHILE report_list_p <> NIL DO
        put_entry_p := ptv$report_entry_chain_head_p;
        number := 1;
        WHILE report_list_p^.report_p <> put_entry_p DO
          put_entry_p := put_entry_p^.put_chain_link_p;
          number := number + 1;
        WHILEND;
        CASE report_list_p^.report_p^.put OF
        = put_field =
          STRINGREP (ptv$output_line, ptv$output_line_length, '     Number : ', number, '   Name : ',
                report_list_p^.report_p^.name, '  Put Type : Put Field');
        = put_field_summary =
          STRINGREP (ptv$output_line, ptv$output_line_length, '     Number : ', number, '   Name : ',
                report_list_p^.report_p^.name, '  Put Type : Put Field Summary');
        = put_interval_field =
          STRINGREP (ptv$output_line, ptv$output_line_length, '     Number : ', number, '   Name : ',
                report_list_p^.report_p^.name, '  Put Type : Put Interval Field');
        ELSE
        CASEND;
        cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        report_list_p := report_list_p^.link_p;
      WHILEND;

    PROCEND display_report_list;

?? OLDTITLE ??
?? NEWTITLE := 'format_counter_display', EJECT ??

    PROCEDURE format_counter_display
      (VAR status: ost$status);

      VAR
        length_string: ost$string,
        subfield_number_string: ost$string;

      status.normal := TRUE;

      STRINGREP (ptv$output_line, ptv$output_line_length, '     Counter Number: ',
            field_p^.counter_number: 4);
      cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

      STRINGREP (ptv$output_line, ptv$output_line_length, '     Multiplier: ', field_p^.multiplier);
      cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

      IF field_p^.incremental THEN
        cyp$put_next_line (ptv$output_file, '     Incremental Counter', status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        IF field_p^.allow_negative_increment THEN
          cyp$put_next_line (ptv$output_file, '     Allow Negative Increment', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;
      IFEND;

    PROCEND format_counter_display;

?? OLDTITLE ??
?? NEWTITLE := 'format_descriptive_data_display', EJECT ??

    PROCEDURE format_descriptive_data_display
      (VAR status: ost$status);

      VAR
        length_string: ost$string,
        subfield_number_string: ost$string;

      status.normal := TRUE;

      cyp$put_next_line (ptv$output_file, '  Field Type: Descriptive Data', status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

      IF field_p^.subfield_length = sfc$max_descriptive_data_size THEN
        length_string.value := 'ALL';
        length_string.size := 3;
      ELSE
        clp$convert_integer_to_string (field_p^.subfield_length, 10, FALSE, length_string, status);
      IFEND;

      IF field_p^.subfield_number = 0 THEN
        subfield_number_string.value := 'ALL';
        subfield_number_string.size := 3;
      ELSE
        clp$convert_integer_to_string (field_p^.subfield_number, 10, FALSE, subfield_number_string, status);
      IFEND;

      STRINGREP (ptv$output_line, ptv$output_line_length, '     Position: ', field_p^.subfield_position,
            '  Length: ', length_string.value (1, length_string.size), '  Field Number: ',
            subfield_number_string.value (1, subfield_number_string.size), '  Field Delimiter: ''',
            field_p^.subfield_delimiter, '''');
      cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

    PROCEND format_descriptive_data_display;

?? OLDTITLE ??
?? NEWTITLE := 'format_field_display', EJECT ??

    PROCEDURE format_field_display
      (VAR status: ost$status);

      VAR
        length_string: ost$string,
        subfield_number_string: ost$string;

      status.normal := TRUE;

      IF pvt [p$display_option].value^.keyword_value = 'ALL' THEN

        STRINGREP (ptv$output_line, ptv$output_line_length, ' Field: ', field_p^.field_name);
        cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;

        STRINGREP (ptv$output_line, ptv$output_line_length, '   Selection: ', selection_p^.name);
        cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;

        CASE field_p^.field_type OF

        = counter_field =
          cyp$put_next_line (ptv$output_file, '  Field Type: Counter', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          format_counter_display (status);

        = descriptive_data_field =
          format_descriptive_data_display (status);

        = date_time_field =
          cyp$put_next_line (ptv$output_file, '  Field Type: Date Time', status);

        = statistic_code_field =
          cyp$put_next_line (ptv$output_file, '  Field Type: Statistic Code', status);

        = system_job_name_field =
          cyp$put_next_line (ptv$output_file, '  Field Type: System Job Name', status);

        = global_task_id_field =
          cyp$put_next_line (ptv$output_file, '  Field Type: Global Task ID', status);

        = number_of_counters_field =
          cyp$put_next_line (ptv$output_file, '  Field Type: Number of Counters', status);

        = descriptive_data_size_field =
          cyp$put_next_line (ptv$output_file, '  Field Type: Descriptive Data Size', status);

        = previous_occurrence_field =
          cyp$put_next_line (ptv$output_file, '  Field Type: Elapsed Time Since Previous Occurrence', status);

        = predecessor_field =
          cyp$put_next_line (ptv$output_file, '  Field Type: Elapsed Time Since Predecessor', status);

        = predecessor_chain_head_field =
          cyp$put_next_line (ptv$output_file, '  Field Type: Elapsed Time Since Predecessor Chain Head',
                status);

        = text_field =
          cyp$put_next_line (ptv$output_file, '  Field Type: Text', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          STRINGREP (ptv$output_line, ptv$output_line_length, '     Text: ', field_p^.descriptive_text_p^);
          cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);

        = value_per_second_field, occurrence_per_second_field =
          IF field_p^.field_type = value_per_second_field THEN
            cyp$put_next_line (ptv$output_file, '  Field Type: Value Per Second', status);
          ELSE
            cyp$put_next_line (ptv$output_file, '  Field Type: Occurrence Per Second', status);
          IFEND;
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          CASE field_p^.elapsed_time OF
          = previous_occurrence =
            cyp$put_next_line (ptv$output_file, '     Elapsed Time: Previous Occurrence', status);

          = predecessor =
            cyp$put_next_line (ptv$output_file, '     Elapsed Time: Predecessor', status);

          = predecessor_chain_head =
            cyp$put_next_line (ptv$output_file, '     Elapsed Time: Predecessor Chain Head', status);

          ELSE
          CASEND;
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          IF field_p^.field_type = value_per_second_field THEN
            format_counter_display (status);
          IFEND;

        ELSE
        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;


        IF field_p^.report_list_p <> NIL THEN
          report_list_p := field_p^.report_list_p;
          display_report_list (status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;

        cyp$put_next_line (ptv$output_file, ' ', status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;

      ELSE
        cyp$put_next_line (ptv$output_file, field_p^.field_name, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      IFEND;

    PROCEND format_field_display;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_display_field, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

{ Opens output file.

    cyp$open_file (pvt [p$output].value^.file_value^, ^ptv$display_file_specifications, ptv$output_file,
          status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    ptv$maximum_line_length := cyp$page_width (ptv$output_file);
    IF ptv$maximum_line_length > 132 THEN
      ptv$maximum_line_length := 132;
    IFEND;

    errors_detected := FALSE;
    IF pvt [p$field].value^.kind = clc$keyword THEN
      IF pvt [p$field].value^.keyword_value = 'ALL' THEN

{ ALL

        selection_p := ptv$selection_chain_head_p;
        WHILE selection_p <> NIL DO

          field_p := selection_p^.field_chain_p;
          WHILE field_p <> NIL DO
            format_field_display (status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            field_p := field_p^.field_chain_link_p;
          WHILEND;

          selection_p := selection_p^.selection_chain_link_p;
        WHILEND;
      IFEND;
    ELSE

{ LIST

      value_p := pvt [p$field].value;
      WHILE value_p <> NIL DO
        display_status := FALSE;
        selection_p := ptv$selection_chain_head_p;

      /display/
        WHILE selection_p <> NIL DO

          field_p := selection_p^.field_chain_p;
          WHILE (field_p <> NIL) AND (field_p^.field_name <> value_p^.element_value^.name_value) DO
            field_p := field_p^.field_chain_link_p;
          WHILEND;
          IF field_p <> NIL THEN
            format_field_display (status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            display_status := TRUE;
            EXIT /display/; {----->
          IFEND;

          selection_p := selection_p^.selection_chain_link_p;
        WHILEND /display/;

        IF NOT display_status THEN
          osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$undefined_field_for_dis,
                value_p^.element_value^.name_value, failing_status);
          report_intermediate_error (failing_status, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          errors_detected := TRUE;
        IFEND;

        value_p := value_p^.link;
      WHILEND;
    IFEND;

    cyp$close_file (ptv$output_file, cyc$default_open_position, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    IF errors_detected THEN
      osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, 'FIELD', status);
      RETURN; {----->
    IFEND;

  PROCEND display_field_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'put_field_summary_cmd', EJECT ??

{ This procedure processes the put_field_summary command.

*copyc pth$anabl_put_field_summary

  PROCEDURE put_field_summary_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (ptm$anabl_putfs) put_field_summary, putfs (
{   field, fields, f: (CHECK) list of record
{       field_name: name
{       row_label: string = $optional
{     recend = $required
{   display_option, do, summary_calculation, sc: list of record
{       calculation: key
{         (count, c)
{         (sum, s)
{         (mean, m, average, avg)
{         (standard_deviation, sd)
{         (minimum, min)
{         (maximum, max)
{         (count_per_second, cps)
{         (sum_per_second, sps)
{       hidden_key
{         (interval, i)
{         (elapsed_time_since_predecessor, etsp)
{       keyend
{       start_column: integer 1..ptc$max_page_width = $optional
{       column_width: integer 1..ptc$max_page_width = $optional
{     recend = ((count 32 10) (sum 43 15) (mean 59 15) (standard_deviation 85 15) (minimum 101 15) ..
{    (maximum 117 15))
{   display_headers, dh: boolean = false
{   row_label_format, rlf: record
{       start_column: integer 1..ptc$max_page_width
{       column_width: integer 1..ptc$max_page_width
{     recend = (1 31)
{   put, p: (CHECK) name = $optional
{   number, n: any of
{       key
{         (next, n)
{       keyend
{       integer 1..clc$max_integer
{     anyend = next
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 16] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 22] of clt$keyword_specification,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        default_value: string (104),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (6),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type6: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 27, 12, 50, 36, 746],
    clc$command, 16, 7, 1, 0, 0, 0, 7, 'PTM$ANABL_PUTFS'], [
    ['DH                             ',clc$abbreviation_entry, 3],
    ['DISPLAY_HEADERS                ',clc$nominal_entry, 3],
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DO                             ',clc$alias_entry, 2],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FIELD                          ',clc$nominal_entry, 1],
    ['FIELDS                         ',clc$alias_entry, 1],
    ['N                              ',clc$abbreviation_entry, 6],
    ['NUMBER                         ',clc$nominal_entry, 6],
    ['P                              ',clc$abbreviation_entry, 5],
    ['PUT                            ',clc$nominal_entry, 5],
    ['RLF                            ',clc$abbreviation_entry, 4],
    ['ROW_LABEL_FORMAT               ',clc$nominal_entry, 4],
    ['SC                             ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 7],
    ['SUMMARY_CALCULATION            ',clc$alias_entry, 2]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 108,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 992,
  clc$optional_default_parameter, 0, 104],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 119,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 6
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 7
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [92, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$record_type], [2],
      ['FIELD_NAME                     ', clc$required_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['ROW_LABEL                      ', clc$optional_field, 8], [[1, 0, clc$string_type], [0,
  clc$max_string_size, FALSE]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [976, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$record_type], [3],
      ['CALCULATION                    ', clc$required_field, 821], [[1, 0, clc$keyword_type], [22], [
        ['AVERAGE                        ', clc$alias_entry, clc$normal_usage_entry, 3],
        ['AVG                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['COUNT                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['COUNT_PER_SECOND               ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['CPS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
        ['ELAPSED_TIME_SINCE_PREDECESSOR ', clc$nominal_entry, clc$hidden_entry, 10],
        ['ETSP                           ', clc$abbreviation_entry, clc$hidden_entry, 10],
        ['I                              ', clc$abbreviation_entry, clc$hidden_entry, 9],
        ['INTERVAL                       ', clc$nominal_entry, clc$hidden_entry, 9],
        ['M                              ', clc$alias_entry, clc$normal_usage_entry, 3],
        ['MAX                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['MAXIMUM                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['MEAN                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['MIN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['MINIMUM                        ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['SD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['SPS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
        ['STANDARD_DEVIATION             ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['SUM                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['SUM_PER_SECOND                 ', clc$nominal_entry, clc$normal_usage_entry, 8]]
        ],
      ['START_COLUMN                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]],
      ['COLUMN_WIDTH                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]]
      ]
    ,
    '((count 32 10) (sum 43 15) (mean 59 15) (standard_deviation 85 15) (minimum 101 15)    (maximum 117 15))'
  ],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 4
    [[1, 0, clc$record_type], [2],
    ['START_COLUMN                   ', clc$required_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]],
    ['COLUMN_WIDTH                   ', clc$required_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]]
    ,
    '(1 31)'],
{ PARAMETER 5
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['NEXT                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, clc$max_integer, 10]]
    ,
    'next'],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$field = 1,
      p$display_option = 2,
      p$display_headers = 3,
      p$row_label_format = 4,
      p$put = 5,
      p$number = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;


    VAR
      initial_put_field_summary_entry: [STATIC, READ] put_entry :=
            ['                               ' { name }, NIL { put_chain_link_p } ,
            [REP ptc$field_vector_size of [NIL, null, * , * , FALSE, NIL]]
            { field_vector } , ' ' { header_1 } , ' ' { header_2 } , 0 {max_used_column}, put_field_summary
            { put } , NIL { fields } , [REP 10 of [null, * , * ]] { summary_vector } , 1
            { row_label_start_column } , 20 { row_label_column_width } , * { display_headers } ],
      report_entry_p: ^put_entry,
      temp_report_entry: ^put_entry;

?? NEWTITLE := 'check_put_field_summary', EJECT ??

    PROCEDURE check_put_field_summary
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$put =
          temp_report_entry^.name := '';
          IF pvt [p$put].specified THEN
            process_put_parameter (pvt [p$put].value^, ptv$report_entry_chain_head_p, temp_report_entry^.name,
                  status);
          IFEND;

        = p$field =
          report_undefined_counters (pvt [p$field].value, status);

        ELSE
        CASEND;
      ELSE

{ summary_calculation & row_label_format

        process_summary_calculation (pvt [p$display_option], pvt [p$row_label_format],
              temp_report_entry, status);
      IFEND;

    PROCEND check_put_field_summary;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$get_reason_for_call (ptv$information_request, ptv$display_file, ptv$prompting_activted, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    IF NOT ptv$information_request THEN

      IF ptv$generate = log THEN
        clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
        osp$set_status_condition (pte$generate_log_mode, status);
        RETURN; {----->
      IFEND;

      ALLOCATE temp_report_entry;
      temp_report_entry^ := initial_put_field_summary_entry;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_put_field_summary, ^pvt, status);
    IF NOT status.normal THEN
      IF NOT ptv$information_request THEN
        FREE temp_report_entry;
      IFEND;
      RETURN; {----->
    IFEND;

    ptv$generate := report;

{ number

    process_number_parameter (pvt [p$number].value^, temp_report_entry, ptv$report_entry_chain_head_p);

{ display_headers

    temp_report_entry^.display_headers := pvt [p$display_headers].value^.boolean_value.value;
    process_headers_putfs (temp_report_entry);

{ field

    process_field_parameter_putfs (pvt [p$field].value, temp_report_entry);

  PROCEND put_field_summary_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'put_interval_field_cmd', EJECT ??

{ This procedure processes the put_interval_field command.

*copyc pth$anabl_put_interval_field

  PROCEDURE put_interval_field_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{    PROCEDURE (ptm$anabl_putif) put_interval_field, putif (
{    field, fields, f: (CHECK) list 1..ptc$field_vector_size of record
{        field_name: name
{        display_option: key
{          (first_occurrence, fo)
{          (count, c)
{          (sum, s)
{          (mean, m, average, avg)
{          (standard_deviation, sd)
{          (minimum, min)
{          (maximum, max)
{          (count_per_second, cps)
{          (sum_per_second, sps)
{        hidden_key
{          (interval, i)
{          (elapsed_time_since_predecessor, etsp)
{        keyend = $optional
{        start_column: integer 1..ptc$max_page_width = $optional
{        column_width: integer 1..ptc$max_page_width = $optional
{        header_1: string 1..ptc$max_page_width = $optional
{        header_2: string 1..ptc$max_page_width = $optional
{      recend = $required
{    report_interval, ri: integer 1..10000 = 1
{    row_label, rl: record
{        label: any of
{          key
{            (start_time, st)
{            (end_time, et)
{            (time_range, tr)
{            (none, n)
{          keyend
{          string
{        anyend = $optional
{        start_column: integer 1..ptc$max_page_width = $optional
{        column_width: integer 1..ptc$max_page_width = $optional
{        date_time_format: string = $optional
{      recend = (time_range 1 31 'HMS')
{    put, p: (CHECK) name = $optional
{    number, n: any of
{        key
{          (next, n)
{        keyend
{        integer 1..clc$max_integer
{      anyend = next
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 12] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 24] of clt$keyword_specification,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_5: clt$field_specification,
          element_type_spec_5: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
          field_spec_6: clt$field_specification,
          element_type_spec_6: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: 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 .. 8] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_4: clt$field_specification,
        element_type_spec_4: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        default_value: string (23),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type5: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 27, 12, 51, 49, 370],
    clc$command, 12, 6, 1, 0, 0, 0, 6, 'PTM$ANABL_PUTIF'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FIELD                          ',clc$nominal_entry, 1],
    ['FIELDS                         ',clc$alias_entry, 1],
    ['N                              ',clc$abbreviation_entry, 5],
    ['NUMBER                         ',clc$nominal_entry, 5],
    ['P                              ',clc$abbreviation_entry, 4],
    ['PUT                            ',clc$nominal_entry, 4],
    ['REPORT_INTERVAL                ',clc$nominal_entry, 2],
    ['RI                             ',clc$abbreviation_entry, 2],
    ['RL                             ',clc$abbreviation_entry, 3],
    ['ROW_LABEL                      ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 1195,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 3
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 530,
  clc$optional_default_parameter, 0, 23],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [1179, 1, ptc$field_vector_size, FALSE],
      [[1, 0, clc$record_type], [6],
      ['FIELD_NAME                     ', clc$required_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['DISPLAY_OPTION                 ', clc$optional_field, 895], [[1, 0, clc$keyword_type], [24], [
        ['AVERAGE                        ', clc$alias_entry, clc$normal_usage_entry, 4],
        ['AVG                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['COUNT                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['COUNT_PER_SECOND               ', clc$nominal_entry, clc$normal_usage_entry, 8],
        ['CPS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
        ['ELAPSED_TIME_SINCE_PREDECESSOR ', clc$nominal_entry, clc$hidden_entry, 11],
        ['ETSP                           ', clc$abbreviation_entry, clc$hidden_entry, 11],
        ['FIRST_OCCURRENCE               ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['FO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['I                              ', clc$abbreviation_entry, clc$hidden_entry, 10],
        ['INTERVAL                       ', clc$nominal_entry, clc$hidden_entry, 10],
        ['M                              ', clc$alias_entry, clc$normal_usage_entry, 4],
        ['MAX                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
        ['MAXIMUM                        ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['MEAN                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['MIN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['MINIMUM                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['SD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['SPS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
        ['STANDARD_DEVIATION             ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['SUM                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['SUM_PER_SECOND                 ', clc$nominal_entry, clc$normal_usage_entry, 9]]
        ],
      ['START_COLUMN                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]],
      ['COLUMN_WIDTH                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]],
      ['HEADER_1                       ', clc$optional_field, 8], [[1, 0, clc$string_type], [1,
  ptc$max_page_width, FALSE]],
      ['HEADER_2                       ', clc$optional_field, 8], [[1, 0, clc$string_type], [1,
  ptc$max_page_width, FALSE]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [1, 10000, 10],
    '1'],
{ PARAMETER 3
    [[1, 0, clc$record_type], [4],
    ['LABEL                          ', clc$optional_field, 331], [[1, 0, clc$union_type], [[
      clc$keyword_type, clc$string_type],
      FALSE, 2],
      303, [[1, 0, clc$keyword_type], [8], [
        ['END_TIME                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['ET                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['ST                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['START_TIME                     ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['TIME_RANGE                     ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['TR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3]]
        ],
      8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
      ],
    ['START_COLUMN                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]],
    ['COLUMN_WIDTH                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]],
    ['DATE_TIME_FORMAT               ', clc$optional_field, 8], [[1, 0, clc$string_type], [0,
  clc$max_string_size, FALSE]]
    ,
    '(time_range 1 31 ''HMS'')'],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['NEXT                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, clc$max_integer, 10]]
    ,
    'next'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$field = 1,
      p$report_interval = 2,
      p$row_label = 3,
      p$put = 4,
      p$number = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      initial_put_interval_field: [STATIC, READ] put_entry :=
            ['                               ' { name } , NIL { put_chain_link_p } ,
            [REP ptc$field_vector_size of [NIL, null, * , * , FALSE, NIL]]
            { field_vector } , ' ' { header_1 } , ' ' { header_2 } , 0 {max_used_column},
            put_interval_field { put } , end_time { row_label_type } , ' ' { row_label } , 1
            { date_time_start_column } , ptc$default_row_label_size { date_time_column_width } , NIL
            { date_time_format } , 1 { report_interval } ],
      report_entry_p: ^put_entry,
      temp_report_entry: ^put_entry;

?? NEWTITLE := 'check_put_interval_field', EJECT ??

    PROCEDURE check_put_interval_field
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$put =
          temp_report_entry^.name := '';
          IF pvt [p$put].specified THEN
            process_put_parameter (pvt [p$put].value^, ptv$report_entry_chain_head_p, temp_report_entry^.name,
                  status);
          IFEND;

        = p$field =
          report_undefined_fields (pvt [p$field].value, status);

        ELSE
        CASEND;
      ELSE

{ field (field_name, summary_calculation, position_description and headers).

        process_field_position (pvt [p$field], pvt [p$row_label], temp_report_entry, status);
      IFEND;

    PROCEND check_put_interval_field;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$get_reason_for_call (ptv$information_request, ptv$display_file, ptv$prompting_activted, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    IF NOT ptv$information_request THEN

      IF ptv$generate = log THEN
        clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
        osp$set_status_condition (pte$generate_log_mode, status);
        RETURN; {----->
      IFEND;

      ALLOCATE temp_report_entry;
      temp_report_entry^ := initial_put_interval_field;
      ALLOCATE temp_report_entry^.date_time_format_p: [3];
      temp_report_entry^.date_time_format_p^ := 'HMS';

    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_put_interval_field, ^pvt, status);
    IF NOT status.normal THEN
      IF NOT ptv$information_request THEN
        FREE temp_report_entry^.date_time_format_p;
        FREE temp_report_entry;
      IFEND;
      RETURN; {----->
    IFEND;

    ptv$generate := report;

{ field

    process_field_parameter_putif (temp_report_entry);

{ number

    process_number_parameter (pvt [p$number].value^, temp_report_entry, ptv$report_entry_chain_head_p);

{ report_interval

    temp_report_entry^.report_interval := pvt [p$report_interval].value^.integer_value.value;

  PROCEND put_interval_field_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'put_field_cmd', EJECT ??

{ This procedure processes the put_field_cmd command.

*copyc pth$anabl_put_field

  PROCEDURE put_field_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (ptm$anabl_putf) put_field, putf (
{   field, fields, f: (CHECK) list 1..ptc$field_vector_size of record
{       field_name: name
{       display_option: key
{         (all_occurrences, all_occurrence, ao, detail, d)
{         (first_occurrence, fo)
{         (last_occurrence, lo)
{         (count, c)
{         (sum, s)
{         (mean, m, average, avg)
{         (standard_deviation, sd)
{         (minimum, min)
{         (maximum, max)
{         (count_per_second, cps)
{         (sum_per_second, sps)
{       hidden_key
{         (interval, i)
{         (elapsed_time_since_predecessor, etsp)
{       keyend = $optional
{       start_column: integer 1..ptc$max_page_width = $optional
{       column_width: integer 1..ptc$max_page_width = $optional
{       header_1: string 1..ptc$max_page_width = $optional
{       header_2: string 1..ptc$max_page_width = $optional
{     recend = $required
{   put, p: (CHECK) name = $optional
{   number, n: any of
{       key
{         (next, n)
{       keyend
{       integer 1..clc$max_integer
{     anyend = next
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 31] of clt$keyword_specification,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_5: clt$field_specification,
          element_type_spec_5: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
          field_spec_6: clt$field_specification,
          element_type_spec_6: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 27, 12, 52, 34, 92],
    clc$command, 8, 4, 1, 0, 0, 0, 4, 'PTM$ANABL_PUTF'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FIELD                          ',clc$nominal_entry, 1],
    ['FIELDS                         ',clc$alias_entry, 1],
    ['N                              ',clc$abbreviation_entry, 3],
    ['NUMBER                         ',clc$nominal_entry, 3],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PUT                            ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 1454,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [1438, 1, ptc$field_vector_size, FALSE],
      [[1, 0, clc$record_type], [6],
      ['FIELD_NAME                     ', clc$required_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['DISPLAY_OPTION                 ', clc$optional_field, 1154], [[1, 0, clc$keyword_type], [31], [
        ['ALL_OCCURRENCE                 ', clc$alias_entry, clc$normal_usage_entry, 1],
        ['ALL_OCCURRENCES                ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['AO                             ', clc$alias_entry, clc$normal_usage_entry, 1],
        ['AVERAGE                        ', clc$alias_entry, clc$normal_usage_entry, 6],
        ['AVG                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['COUNT                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['COUNT_PER_SECOND               ', clc$nominal_entry, clc$normal_usage_entry, 10],
        ['CPS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
        ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['DETAIL                         ', clc$alias_entry, clc$normal_usage_entry, 1],
        ['ELAPSED_TIME_SINCE_PREDECESSOR ', clc$nominal_entry, clc$hidden_entry, 13],
        ['ETSP                           ', clc$abbreviation_entry, clc$hidden_entry, 13],
        ['FIRST_OCCURRENCE               ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['FO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['I                              ', clc$abbreviation_entry, clc$hidden_entry, 12],
        ['INTERVAL                       ', clc$nominal_entry, clc$hidden_entry, 12],
        ['LAST_OCCURRENCE                ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['LO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['M                              ', clc$alias_entry, clc$normal_usage_entry, 6],
        ['MAX                            ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
        ['MAXIMUM                        ', clc$nominal_entry, clc$normal_usage_entry, 9],
        ['MEAN                           ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['MIN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
        ['MINIMUM                        ', clc$nominal_entry, clc$normal_usage_entry, 8],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['SD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
        ['SPS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
        ['STANDARD_DEVIATION             ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['SUM                            ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['SUM_PER_SECOND                 ', clc$nominal_entry, clc$normal_usage_entry, 11]]
        ],
      ['START_COLUMN                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]],
      ['COLUMN_WIDTH                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]],
      ['HEADER_1                       ', clc$optional_field, 8], [[1, 0, clc$string_type], [1,
  ptc$max_page_width, FALSE]],
      ['HEADER_2                       ', clc$optional_field, 8], [[1, 0, clc$string_type], [1,
  ptc$max_page_width, FALSE]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['NEXT                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, clc$max_integer, 10]]
    ,
    'next'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$field = 1,
      p$put = 2,
      p$number = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      all_occurrences: boolean,
      initial_put_field: [STATIC, READ] put_entry := ['                               ' { name } , NIL
            { put_chain_link_p } , [REP ptc$field_vector_size of [NIL, null, * , * , FALSE, NIL]]
            { field_vector } , ' ' { header_1 } , ' ' { header_2 } , 0 {max_used_column}, put_field { put } ,
            FALSE { all_occurrences } ],
      report_entry_p: ^put_entry,
      temp_report_entry: ^put_entry;

?? NEWTITLE := 'check_put_field', EJECT ??

    PROCEDURE check_put_field
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$put =
          temp_report_entry^.name := '';
          IF pvt [p$put].specified THEN
            process_put_parameter (pvt [p$put].value^, ptv$report_entry_chain_head_p, temp_report_entry^.name,
                  status);
          IFEND;

        = p$field =
          report_undefined_fields (pvt [p$field].value, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          check_display_option (pvt [p$field].value, all_occurrences, status);
          temp_report_entry^.all_occurrences := all_occurrences;

        ELSE
        CASEND;
      IFEND;

    PROCEND check_put_field;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$get_reason_for_call (ptv$information_request, ptv$display_file, ptv$prompting_activted, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    IF NOT ptv$information_request THEN

      IF ptv$generate = log THEN
        clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
        osp$set_status_condition (pte$generate_log_mode, status);
        RETURN; {----->
      IFEND;

      ALLOCATE temp_report_entry;
      temp_report_entry^ := initial_put_field;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_put_field, ^pvt, status);
    IF NOT status.normal THEN
      IF NOT ptv$information_request THEN
        FREE temp_report_entry;
      IFEND;
      RETURN; {----->
    IFEND;

{ field (field_name, summary_calculation and position_description).

    process_field_position (pvt [p$field], pvt [p$field], temp_report_entry, status);

    ptv$generate := report;

{ field

    process_field_parameter_putif (temp_report_entry);

{ number

    process_number_parameter (pvt [p$number].value^, temp_report_entry, ptv$report_entry_chain_head_p);

  PROCEND put_field_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'put_string_cmd', EJECT ??

{ This procedure processes the put_string command.

*copyc pth$anabl_put_string

  PROCEDURE put_string_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (ptm$anabl_puts) put_string, puts (
{   string, strings, str: (CHECK) list of record
{       string: string 1..ptc$max_page_width
{       start_column: integer 1..ptc$max_page_width = $optional
{       column_width: integer 1..ptc$max_page_width = $optional
{     recend = $required
{   put, p: (CHECK) name = $optional
{   number, n: any of
{       key
{         (next, n)
{       keyend
{       integer 1..clc$max_integer
{     anyend = next
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 27, 12, 53, 18, 167],
    clc$command, 8, 4, 1, 0, 0, 0, 4, 'PTM$ANABL_PUTS'], [
    ['N                              ',clc$abbreviation_entry, 3],
    ['NUMBER                         ',clc$nominal_entry, 3],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PUT                            ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['STR                            ',clc$abbreviation_entry, 1],
    ['STRING                         ',clc$nominal_entry, 1],
    ['STRINGS                        ',clc$alias_entry, 1]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 179,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [163, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$record_type], [3],
      ['STRING                         ', clc$required_field, 8], [[1, 0, clc$string_type], [1,
  ptc$max_page_width, FALSE]],
      ['START_COLUMN                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]],
      ['COLUMN_WIDTH                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['NEXT                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, clc$max_integer, 10]]
    ,
    'next'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$string = 1,
      p$put = 2,
      p$number = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      initial_put_string: [STATIC, READ] put_entry := ['                               ' { name } , NIL
            { put_chain_link_p } , [REP ptc$field_vector_size of [NIL, null, * , * , FALSE, NIL]]
            { field_vector } , ' ' { header_1 } , ' ' { header_2 } , 0 {max_used_column},
            put_string { put } ],
      report_entry_p: ^put_entry,
      temp_report_entry: ^put_entry;

?? NEWTITLE := 'check_put_string', EJECT ??

    PROCEDURE check_put_string
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$put =
          temp_report_entry^.name := '';
          IF pvt [p$put].specified THEN
            process_put_parameter (pvt [p$put].value^, ptv$report_entry_chain_head_p, temp_report_entry^.name,
                  status);
          IFEND;

        = p$string =
          process_string (pvt [p$string], temp_report_entry, status);

        ELSE
        CASEND;
      IFEND;

    PROCEND check_put_string;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$get_reason_for_call (ptv$information_request, ptv$display_file, ptv$prompting_activted, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    IF NOT ptv$information_request THEN

      IF ptv$generate = log THEN
        clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
        osp$set_status_condition (pte$generate_log_mode, status);
        RETURN; {----->
      IFEND;

      ALLOCATE temp_report_entry;
      temp_report_entry^ := initial_put_string;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_put_string, ^pvt, status);
    IF NOT status.normal THEN
      IF NOT ptv$information_request THEN
        FREE temp_report_entry;
      IFEND;
      RETURN; {----->
    IFEND;

    ptv$generate := report;

{ number

    process_number_parameter (pvt [p$number].value^, temp_report_entry, ptv$report_entry_chain_head_p);

  PROCEND put_string_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'push_page_header', EJECT ??

{ This procedure processes the push_page_header command.

  PROCEDURE push_page_header_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{     PROCEDURE (ptm$anabl_pusph) push_page_header, pusph (
{     page_header, ph: (CHECK) any of
{         key
{           default
{         keyend
{         list of record
{           string: string
{           start_column: integer 1..ptc$max_page_width = $optional
{           column_width: integer 1..ptc$max_page_width = $optional
{         recend
{       anyend = default
{     put, p: (CHECK) name = $optional
{     number, n: any of
{         key
{           (next, n)
{         keyend
{         integer 1..clc$max_integer
{       anyend = next
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: record
              header: clt$type_specification_header,
              qualifier: clt$string_type_qualifier,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
            field_spec_3: clt$field_specification,
            element_type_spec_3: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
        recend,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 27, 12, 54, 25, 13],
    clc$command, 7, 4, 0, 0, 0, 0, 4, 'PTM$ANABL_PUSPH'], [
    ['N                              ',clc$abbreviation_entry, 3],
    ['NUMBER                         ',clc$nominal_entry, 3],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PAGE_HEADER                    ',clc$nominal_entry, 1],
    ['PH                             ',clc$abbreviation_entry, 1],
    ['PUT                            ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 243,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    179, [[1, 0, clc$list_type], [163, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$record_type], [3],
        ['STRING                         ', clc$required_field, 8], [[1, 0, clc$string_type], [0,
  clc$max_string_size, FALSE]],
        ['START_COLUMN                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]],
        ['COLUMN_WIDTH                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]]
        ]
      ]
    ,
    'default'],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['NEXT                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, clc$max_integer, 10]]
    ,
    'next'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$page_header = 1,
      p$put = 2,
      p$number = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      initial_page_header: [STATIC, READ] put_entry := ['                               ' { name } , NIL
            { put_chain_link_p } , [REP ptc$field_vector_size of [NIL, null, * , * , FALSE, NIL]]
            { field_vector } , ' ' { header_1 } , ' ' { header_2 } , 0 {max_used_column},
            push_page_header { put }, TRUE {default_header}],
      report_entry_p: ^put_entry,
      temp_report_entry: ^put_entry;

?? NEWTITLE := 'check_push_page_header', EJECT ??

    PROCEDURE check_push_page_header
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$put =
          temp_report_entry^.name := '';
          IF pvt [p$put].specified THEN
            process_put_parameter (pvt [p$put].value^, ptv$report_entry_chain_head_p, temp_report_entry^.name,
                  status);
          IFEND;

        = p$page_header =
          IF (pvt [p$page_header].value^.kind = clc$keyword) THEN

{ The only keyword is DEFAULT.
            temp_report_entry^.default_header := TRUE;
          ELSE {header string specified
            temp_report_entry^.default_header := FALSE;
            process_string (pvt [p$page_header], temp_report_entry, status);
          IFEND;
        ELSE
        CASEND;
      IFEND;

    PROCEND check_push_page_header;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$get_reason_for_call (ptv$information_request, ptv$display_file, ptv$prompting_activted, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    IF NOT ptv$information_request THEN

      IF ptv$generate = log THEN
        clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
        osp$set_status_condition (pte$generate_log_mode, status);
        RETURN; {----->
      IFEND;

      ALLOCATE temp_report_entry;
      temp_report_entry^ := initial_page_header;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_push_page_header, ^pvt, status);
    IF NOT status.normal THEN
      IF NOT ptv$information_request THEN
        FREE temp_report_entry;
      IFEND;
      RETURN; {----->
    IFEND;

    ptv$generate := report;
    ptv$headers_specified := TRUE;

{ number

    process_number_parameter (pvt [p$number].value^, temp_report_entry, ptv$report_entry_chain_head_p);

  PROCEND push_page_header_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'pop_page_header_cmd', EJECT ??

{ This procedure processes the pop_page_header command.

  PROCEDURE pop_page_header_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{      PROCEDURE (ptm$anabl_popph) pop_page_header, popph (
{      pop_count, pc: any of
{          key
{            all
{          keyend
{          integer 1..clc$max_integer
{        anyend = 1
{      put, p: (CHECK) name = $optional
{      number, n: any of
{          key
{            (next, n)
{          keyend
{          integer 1..clc$max_integer
{        anyend = next
{      status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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$integer_type_qualifier,
        recend,
        default_value: string (1),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 27, 12, 55, 21, 866],
    clc$command, 7, 4, 0, 0, 0, 0, 4, 'PTM$ANABL_POPPH'], [
    ['N                              ',clc$abbreviation_entry, 3],
    ['NUMBER                         ',clc$nominal_entry, 3],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PC                             ',clc$abbreviation_entry, 1],
    ['POP_COUNT                      ',clc$nominal_entry, 1],
    ['PUT                            ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, clc$max_integer, 10]]
    ,
    '1'],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['NEXT                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, clc$max_integer, 10]]
    ,
    'next'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$pop_count = 1,
      p$put = 2,
      p$number = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      initial_pop_header: [STATIC, READ] put_entry := ['                               ' { name } , NIL
            { put_chain_link_p } , [REP ptc$field_vector_size of [NIL, null, * , * , FALSE, NIL]]
            { field_vector } , ' ' { header_1 } , ' ' { header_2 } , 0 {max_used_column},
            pop_page_header { put }, FALSE {pop_all_headers}, 1 {pop_count}],
      report_entry_p: ^put_entry,
      temp_report_entry: ^put_entry;

?? NEWTITLE := 'check_pop_page_header', EJECT ??

    PROCEDURE check_pop_page_header
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$put =
          temp_report_entry^.name := '';
          IF pvt [p$put].specified THEN
            process_put_parameter (pvt [p$put].value^, ptv$report_entry_chain_head_p, temp_report_entry^.name,
                  status);
          IFEND;

        ELSE
        CASEND;
      IFEND;

    PROCEND check_pop_page_header;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$get_reason_for_call (ptv$information_request, ptv$display_file, ptv$prompting_activted, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    IF NOT ptv$information_request THEN

      IF ptv$generate = log THEN
        clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
        osp$set_status_condition (pte$generate_log_mode, status);
        RETURN; {----->
      IFEND;

      ALLOCATE temp_report_entry;
      temp_report_entry^ := initial_pop_header;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_pop_page_header, ^pvt, status);
    IF NOT status.normal THEN
      IF NOT ptv$information_request THEN
        FREE temp_report_entry;
      IFEND;
      RETURN; {----->
    IFEND;

    ptv$generate := report;
    ptv$headers_specified := TRUE;

{ pop count
    IF pvt[p$pop_count].value^.kind = clc$keyword THEN

{ Only keyword is pop_count = ALL
      temp_report_entry^.pop_all_headers := TRUE;

    ELSE { Count specified

      temp_report_entry^.pop_count := pvt [p$pop_count].value^.integer_value.value;

    IFEND;

{ number

    process_number_parameter (pvt [p$number].value^, temp_report_entry, ptv$report_entry_chain_head_p);


  PROCEND pop_page_header_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'put_new_page_cmd', EJECT ??

{ This procedure processes the put_new_page command.

  PROCEDURE put_new_page_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{     PROCEDURE (ptm$anabl_putnp) put_new_page, putnp (
{     use_page_headers, use_page_header, uph: boolean = TRUE
{     put, p: (CHECK) name = $optional
{     number, n: any of
{         key
{           (next, n)
{         keyend
{         integer 1..clc$max_integer
{       anyend = next
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 27, 12, 56, 17, 194],
    clc$command, 8, 4, 0, 0, 0, 0, 4, 'PTM$ANABL_PUTNP'], [
    ['N                              ',clc$abbreviation_entry, 3],
    ['NUMBER                         ',clc$nominal_entry, 3],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PUT                            ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['UPH                            ',clc$abbreviation_entry, 1],
    ['USE_PAGE_HEADER                ',clc$alias_entry, 1],
    ['USE_PAGE_HEADERS               ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['NEXT                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, clc$max_integer, 10]]
    ,
    'next'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$use_page_headers = 1,
      p$put = 2,
      p$number = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      initial_put_new_page: [STATIC, READ] put_entry := ['                               ' { name } , NIL
            { put_chain_link_p } , [REP ptc$field_vector_size of [NIL, null, * , * , FALSE, NIL]]
            { field_vector } , ' ' { header_1 } , ' ' { header_2 } , 0 {max_used_column},
            put_new_page { put }, TRUE {use_page_headers}],
      report_entry_p: ^put_entry,
      temp_report_entry: ^put_entry;

?? NEWTITLE := 'check_put_new_page', EJECT ??

    PROCEDURE check_put_new_page
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$put =
          temp_report_entry^.name := '';
          IF pvt [p$put].specified THEN
            process_put_parameter (pvt [p$put].value^, ptv$report_entry_chain_head_p, temp_report_entry^.name,
                  status);
          IFEND;

        ELSE
        CASEND;
      IFEND;

    PROCEND check_put_new_page;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$get_reason_for_call (ptv$information_request, ptv$display_file, ptv$prompting_activted, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    IF NOT ptv$information_request THEN

      IF ptv$generate = log THEN
        clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
        osp$set_status_condition (pte$generate_log_mode, status);
        RETURN; {----->
      IFEND;

      ALLOCATE temp_report_entry;
      temp_report_entry^ := initial_put_new_page;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_put_new_page, ^pvt, status);
    IF NOT status.normal THEN
      IF NOT ptv$information_request THEN
        FREE temp_report_entry;
      IFEND;
      RETURN; {----->
    IFEND;

    ptv$generate := report;
    ptv$headers_specified := TRUE;

{ use_report_headers

      temp_report_entry^.use_page_headers := pvt [p$use_page_headers].value^.boolean_value.value;

{ number

    process_number_parameter (pvt [p$number].value^, temp_report_entry, ptv$report_entry_chain_head_p);

  PROCEND put_new_page_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'put_record_cmd', EJECT ??

{ This procedure processes the put_record command.

*copyc pth$anabl_put_record

  PROCEDURE put_record_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (ptm$anabl_putr) put_record, putr (
{   selection, selections, s: (CHECK) list of name = $required
{   counter, counters, c: (CHECK) any of
{       key
{         none
{       keyend
{       list 1..sfc$max_number_of_counters of record
{         counter_number: any of
{           key
{             all
{           keyend
{           range of integer 1..sfc$max_number_of_counters
{         anyend
{         base: key
{           (base_2, b2)
{           (base_8, b8)
{           (base_10, b10)
{           (base_16, b16)
{           (base_16_group, b16g)
{         keyend
{       recend
{     anyend = ((all b10))
{   descriptive_data, dd: any of
{       string 0..sfc$max_descriptive_data_size
{       record
{         position: integer 1..sfc$max_descriptive_data_size = $optional
{         length: any of
{           key
{             all
{           keyend
{           integer 1..sfc$max_descriptive_data_size
{         anyend = $optional
{         field_number: any of
{           key
{             all
{           keyend
{           integer 1..sfc$max_descriptive_data_size
{         anyend = $optional
{         field_delimiter: string 1 = $optional
{       recend
{     anyend = (1, all, all, ',')
{   put, p: (CHECK) name = $optional
{   number, n: any of
{       key
{         (next, n)
{       keyend
{       integer 1..clc$max_integer
{     anyend = next
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: 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$range_type_qualifier,
                element_type_spec: record
                  header: clt$type_specification_header,
                  qualifier: clt$integer_type_qualifier,
                recend,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$keyword_type_qualifier,
              keyword_specs: array [1 .. 10] of clt$keyword_specification,
            recend,
          recend,
        recend,
        default_value: string (11),
      recend,
      type3: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
        default_value: string (18),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type5: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 28, 11, 16, 31, 569],
    clc$command, 13, 6, 1, 0, 0, 0, 6, 'PTM$ANABL_PUTR'], [
    ['C                              ',clc$abbreviation_entry, 2],
    ['COUNTER                        ',clc$nominal_entry, 2],
    ['COUNTERS                       ',clc$alias_entry, 2],
    ['DD                             ',clc$abbreviation_entry, 3],
    ['DESCRIPTIVE_DATA               ',clc$nominal_entry, 3],
    ['N                              ',clc$abbreviation_entry, 5],
    ['NUMBER                         ',clc$nominal_entry, 5],
    ['P                              ',clc$abbreviation_entry, 4],
    ['PUT                            ',clc$nominal_entry, 4],
    ['S                              ',clc$abbreviation_entry, 1],
    ['SELECTION                      ',clc$nominal_entry, 1],
    ['SELECTIONS                     ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 21, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 627,
  clc$optional_default_parameter, 0, 11],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 375,
  clc$optional_default_parameter, 0, 18],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 6
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    563, [[1, 0, clc$list_type], [547, 1, sfc$max_number_of_counters, FALSE],
        [[1, 0, clc$record_type], [2],
        ['COUNTER_NUMBER                 ', clc$required_field, 91], [[1, 0, clc$union_type], [[
          clc$keyword_type, clc$range_type],
          FALSE, 2],
          44, [[1, 0, clc$keyword_type], [1], [
            ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
            ],
          27, [[1, 0, clc$range_type], [20],
              [[1, 0, clc$integer_type], [1, sfc$max_number_of_counters, 10]]
            ]
          ],
        ['BASE                           ', clc$required_field, 377], [[1, 0, clc$keyword_type], [10], [
          ['B10                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
          ['B16                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
          ['B16G                           ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
          ['B2                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
          ['B8                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
          ['BASE_10                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
          ['BASE_16                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
          ['BASE_16_GROUP                  ', clc$nominal_entry, clc$normal_usage_entry, 5],
          ['BASE_2                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
          ['BASE_8                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
          ]
        ]
      ]
    ,
    '((all b10))'],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$record_type, clc$string_type],
    FALSE, 2],
    8, [[1, 0, clc$string_type], [0, sfc$max_descriptive_data_size, FALSE]],
    347, [[1, 0, clc$record_type], [4],
      ['POSITION                       ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  sfc$max_descriptive_data_size, 10]],
      ['LENGTH                         ', clc$optional_field, 84], [[1, 0, clc$union_type], [[
        clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [1, sfc$max_descriptive_data_size, 10]]
        ],
      ['FIELD_NUMBER                   ', clc$optional_field, 84], [[1, 0, clc$union_type], [[
        clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [1, sfc$max_descriptive_data_size, 10]]
        ],
      ['FIELD_DELIMITER                ', clc$optional_field, 8], [[1, 0, clc$string_type], [1, 1, FALSE]]
      ]
    ,
    '(1, all, all, '','')'],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['NEXT                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, clc$max_integer, 10]]
    ,
    'next'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$selection = 1,
      p$counter = 2,
      p$descriptive_data = 3,
      p$put = 4,
      p$number = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      initial_log_entry: [STATIC, READ] put_entry := ['                               ' { name } , NIL
            { put_chain_link_p } , [REP ptc$field_vector_size of [NIL, null, * , * , FALSE, NIL]]
            { field_vector } , ' ' { header_1 } , ' ' { header_2 } , 0 {max_used_column},
            put_record { put } , NIL { records } , FALSE { delete_counters } ,
            [REP sfc$max_number_of_counters of base_10] { counter_base } , NIL
            { descriptive_text_p } , 1 { subfield_position } , sfc$max_descriptive_data_size
            { subfield_length } , 0 {  subfield_number } , ',' { subfield_delimiter } ],
      log_entry_p: ^put_entry,
      value_p: ^clt$data_value,
      temp_log_entry: ^put_entry;

?? NEWTITLE := 'check_put_record', EJECT ??

    PROCEDURE check_put_record
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$put =
          temp_log_entry^.name := '';
          IF pvt [p$put].specified THEN
            process_put_parameter (pvt [p$put].value^, ptv$log_entry_chain_head_p, temp_log_entry^.name,
                  status);
          IFEND;

        = p$selection =
          report_duplicate_name (pvt [p$selection].value, 'SELECTION', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          report_undefined_selections (pvt [p$selection].value, NIL, status);

        = p$counter =
          check_counter_parameter (pvt [p$counter], temp_log_entry, status);

        ELSE
        CASEND;
      IFEND;

    PROCEND check_put_record;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$get_reason_for_call (ptv$information_request, ptv$display_file, ptv$prompting_activted, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    IF NOT ptv$information_request THEN

      IF ptv$generate = report THEN
        clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
        osp$set_status_condition (pte$generate_report_mode, status);
        RETURN; {----->
      IFEND;

      ALLOCATE temp_log_entry;
      temp_log_entry^ := initial_log_entry;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_put_record, ^pvt, status);
    IF NOT status.normal THEN
      IF NOT ptv$information_request THEN
        FREE temp_log_entry;
      IFEND;
      RETURN; {----->
    IFEND;

    ptv$generate := log;

{ records

    process_selection_parameter (pvt [p$selection].value, temp_log_entry);

{ number

    process_number_parameter (pvt [p$number].value^, temp_log_entry, ptv$log_entry_chain_head_p);

{ descriptive_data

    IF pvt [p$descriptive_data].value^.kind = clc$record THEN

      IF pvt [p$descriptive_data].value^.field_values^ [1].value <> NIL THEN
        temp_log_entry^.subfield_position := pvt [p$descriptive_data].value^.field_values^ [1].
              value^.integer_value.value;
      IFEND;

      IF pvt [p$descriptive_data].value^.field_values^ [2].value <> NIL THEN
        IF pvt [p$descriptive_data].value^.field_values^ [2].value^.kind <> clc$keyword THEN
          temp_log_entry^.subfield_length := pvt [p$descriptive_data].value^.field_values^ [2].
                value^.integer_value.value;
        IFEND;
      IFEND;

      IF pvt [p$descriptive_data].value^.field_values^ [3].value <> NIL THEN
        IF pvt [p$descriptive_data].value^.field_values^ [3].value^.kind <> clc$keyword THEN
          temp_log_entry^.subfield_number := pvt [p$descriptive_data].value^.field_values^ [3].
                value^.integer_value.value;
        IFEND;
      IFEND;

      IF pvt [p$descriptive_data].value^.field_values^ [4].value <> NIL THEN
        temp_log_entry^.subfield_delimiter := pvt [p$descriptive_data].value^.field_values^ [4].
              value^.string_value^ (1);
      IFEND;

    ELSE

      ALLOCATE temp_log_entry^.descriptive_text_p: [#SIZE (pvt [p$descriptive_data].value^.string_value^)];
      temp_log_entry^.descriptive_text_p^ := pvt [p$descriptive_data].value^.string_value^;

    IFEND;

  PROCEND put_record_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'change_put_cmd', EJECT ??

{ This procedure processes the change_put command.

*copyc pth$anabl_change_put

  PROCEDURE change_put_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{    PROCEDURE (ptm$anabl_chap) change_put, chap (
{    put, p: name = $optional
{    number, n: any of
{        key
{          (last, l)
{        keyend
{        integer 1..clc$max_integer
{      anyend = $optional
{    new_put, np: (CHECK) name = $optional
{    new_number, nn: any of
{        key
{          (last, l)
{        keyend
{        integer 1..clc$max_integer
{      anyend = $optional
{    field, fields, f: any of
{        list of record
{          field_name: name
{          row_label: string = $optional
{        recend
{        list 1..ptc$field_vector_size of record
{          field_name: name
{          display_option: key
{            (all_occurrences, all_occurrence, ao, detail, d)
{            (first_occurrence, fo)
{            (last_occurrence, lo)
{            (count, c)
{            (sum, s)
{            (mean, m, average, avg)
{            (standard_deviation, sd)
{            (minimum, min)
{            (maximum, max)
{            (count_per_second, cps)
{            (sum_per_second, sps)
{          hidden_key
{            (interval, i)
{            (elapsed_time_since_predecessor, etsp)
{          keyend = $optional
{          start_column: integer 1..ptc$max_page_width = $optional
{          column_width: integer 1..ptc$max_page_width = $optional
{          header_1: string 1..ptc$max_page_width = $optional
{          header_2: string 1..ptc$max_page_width = $optional
{        recend
{      anyend = $optional
{    display_option, do, summary_calculation, sc: list of record
{        calculation: key
{          (count, c)
{          (sum, s)
{          (mean, m, average, avg)
{          (standard_deviation, sd)
{          (minimum, min)
{          (maximum, max)
{          (count_per_second, cps)
{          (sum_per_second, sps)
{        hidden_key
{          (interval, i)
{          (elapsed_time_since_predecessor, etsp)
{        keyend
{        start_column: integer 1..ptc$max_page_width = $optional
{        column_width: integer 1..ptc$max_page_width = $optional
{      recend = $optional
{    display_headers, dh: boolean = false
{    row_label, rl: record
{        label: any of
{          key
{            (start_time, st)
{            (end_time, et)
{            (time_range, tr)
{            (none, n)
{          keyend
{          string
{        anyend = $optional
{        start_column: integer 1..ptc$max_page_width = $optional
{        column_width: integer 1..ptc$max_page_width = $optional
{        date_time_format: string = $optional
{      recend = (time_range 1 21 'HMS')
{    row_label_format, rlf: record
{          start_column: integer 1..ptc$max_page_width
{          column_width: integer 1..ptc$max_page_width
{        recend = $optional
{    report_interval, ri: integer 1..10000 = $optional
{    string, strings, str: list 1..11 of string = $optional
{    page_header, ph: (CHECK) any of
{        key
{          default
{        keyend
{        list of record
{          string: string
{          start_column: integer 1..ptc$max_page_width = $optional
{          column_width: integer 1..ptc$max_page_width = $optional
{        recend
{      anyend = $optional
{    pop_count, pc: any of
{        key
{          all
{        keyend
{        integer 1..clc$max_integer
{      anyend = $optional
{    use_page_headers, use_page_header, uph: boolean = $optional
{    selection, s: list of name = $optional
{    counter, counters, c: any of
{        key
{          none
{        keyend
{        list 1..sfc$max_number_of_counters of record
{          counter_number: any of
{            key
{              all
{            keyend
{            range of integer 1..sfc$max_number_of_counters
{          anyend
{          base: key
{            (base_2, b2)
{            (base_8, b8)
{            (base_10, b10)
{            (base_16, b16)
{            (base_16_group, b16g)
{          keyend
{        recend
{      anyend = $optional
{    descriptive_data, dd: any of
{        string 0..sfc$max_descriptive_data_size
{        record
{          position: integer 1..sfc$max_descriptive_data_size = $optional
{          length: any of
{            key
{              all
{            keyend
{            integer 1..sfc$max_descriptive_data_size
{          anyend = $optional
{          field_number: any of
{            key
{              all
{            keyend
{            integer 1..sfc$max_descriptive_data_size
{          anyend = $optional
{          field_delimiter: string 1 = $optional
{        recend
{      anyend = $optional
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 41] of clt$pdt_parameter_name,
      parameters: array [1 .. 18] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type4: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type5: 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$string_type_qualifier,
            recend,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$keyword_type_qualifier,
              keyword_specs: array [1 .. 31] of clt$keyword_specification,
            recend,
            field_spec_3: clt$field_specification,
            element_type_spec_3: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
            field_spec_4: clt$field_specification,
            element_type_spec_4: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
            field_spec_5: clt$field_specification,
            element_type_spec_5: record
              header: clt$type_specification_header,
              qualifier: clt$string_type_qualifier,
            recend,
            field_spec_6: clt$field_specification,
            element_type_spec_6: record
              header: clt$type_specification_header,
              qualifier: clt$string_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 22] of clt$keyword_specification,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
      recend,
      type7: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: 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 .. 8] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_4: clt$field_specification,
        element_type_spec_4: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        default_value: string (23),
      recend,
      type9: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type10: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type12: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: record
              header: clt$type_specification_header,
              qualifier: clt$string_type_qualifier,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
            field_spec_3: clt$field_specification,
            element_type_spec_3: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type13: 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$integer_type_qualifier,
        recend,
      recend,
      type14: record
        header: clt$type_specification_header,
      recend,
      type15: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type16: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$record_type_qualifier,
            field_spec_1: clt$field_specification,
            element_type_spec_1: 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$range_type_qualifier,
                element_type_spec: record
                  header: clt$type_specification_header,
                  qualifier: clt$integer_type_qualifier,
                recend,
              recend,
            recend,
            field_spec_2: clt$field_specification,
            element_type_spec_2: record
              header: clt$type_specification_header,
              qualifier: clt$keyword_type_qualifier,
              keyword_specs: array [1 .. 10] of clt$keyword_specification,
            recend,
          recend,
        recend,
      recend,
      type17: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_3: clt$field_specification,
          element_type_spec_3: 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$integer_type_qualifier,
            recend,
          recend,
          field_spec_4: clt$field_specification,
          element_type_spec_4: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
      recend,
      type18: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 28, 11, 19, 3, 366],
    clc$command, 41, 18, 0, 0, 0, 0, 18, 'PTM$ANABL_CHAP'], [
    ['C                              ',clc$abbreviation_entry, 16],
    ['COUNTER                        ',clc$nominal_entry, 16],
    ['COUNTERS                       ',clc$alias_entry, 16],
    ['DD                             ',clc$abbreviation_entry, 17],
    ['DESCRIPTIVE_DATA               ',clc$nominal_entry, 17],
    ['DH                             ',clc$abbreviation_entry, 7],
    ['DISPLAY_HEADERS                ',clc$nominal_entry, 7],
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 6],
    ['DO                             ',clc$alias_entry, 6],
    ['F                              ',clc$abbreviation_entry, 5],
    ['FIELD                          ',clc$nominal_entry, 5],
    ['FIELDS                         ',clc$alias_entry, 5],
    ['N                              ',clc$abbreviation_entry, 2],
    ['NEW_NUMBER                     ',clc$nominal_entry, 4],
    ['NEW_PUT                        ',clc$nominal_entry, 3],
    ['NN                             ',clc$abbreviation_entry, 4],
    ['NP                             ',clc$abbreviation_entry, 3],
    ['NUMBER                         ',clc$nominal_entry, 2],
    ['P                              ',clc$abbreviation_entry, 1],
    ['PAGE_HEADER                    ',clc$nominal_entry, 12],
    ['PC                             ',clc$abbreviation_entry, 13],
    ['PH                             ',clc$abbreviation_entry, 12],
    ['POP_COUNT                      ',clc$nominal_entry, 13],
    ['PUT                            ',clc$nominal_entry, 1],
    ['REPORT_INTERVAL                ',clc$nominal_entry, 10],
    ['RI                             ',clc$abbreviation_entry, 10],
    ['RL                             ',clc$abbreviation_entry, 8],
    ['RLF                            ',clc$abbreviation_entry, 9],
    ['ROW_LABEL                      ',clc$nominal_entry, 8],
    ['ROW_LABEL_FORMAT               ',clc$nominal_entry, 9],
    ['S                              ',clc$abbreviation_entry, 15],
    ['SC                             ',clc$abbreviation_entry, 6],
    ['SELECTION                      ',clc$nominal_entry, 15],
    ['STATUS                         ',clc$nominal_entry, 18],
    ['STR                            ',clc$abbreviation_entry, 11],
    ['STRING                         ',clc$nominal_entry, 11],
    ['STRINGS                        ',clc$alias_entry, 11],
    ['SUMMARY_CALCULATION            ',clc$alias_entry, 6],
    ['UPH                            ',clc$abbreviation_entry, 14],
    ['USE_PAGE_HEADER                ',clc$alias_entry, 14],
    ['USE_PAGE_HEADERS               ',clc$nominal_entry, 14]],
    [
{ PARAMETER 1
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 121,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1582,
  clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 992,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 8
    [29, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 530,
  clc$optional_default_parameter, 0, 23],
{ PARAMETER 9
    [30, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 119,
  clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 11
    [36, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 24, clc$optional_parameter,
  0, 0],
{ PARAMETER 12
    [20, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 243,
  clc$optional_parameter, 0, 0],
{ PARAMETER 13
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84, clc$optional_parameter,
  0, 0],
{ PARAMETER 14
    [41, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 15
    [33, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 16
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 627,
  clc$optional_parameter, 0, 0],
{ PARAMETER 17
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 375,
  clc$optional_parameter, 0, 0],
{ PARAMETER 18
    [34, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['LAST                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, clc$max_integer, 10]]
    ],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['LAST                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, clc$max_integer, 10]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$list_type],
    FALSE, 2],
    108, [[1, 0, clc$list_type], [92, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$record_type], [2],
        ['FIELD_NAME                     ', clc$required_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
        ['ROW_LABEL                      ', clc$optional_field, 8], [[1, 0, clc$string_type], [0,
  clc$max_string_size, FALSE]]
        ]
      ],
    1454, [[1, 0, clc$list_type], [1438, 1, ptc$field_vector_size, FALSE],
        [[1, 0, clc$record_type], [6],
        ['FIELD_NAME                     ', clc$required_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
        ['DISPLAY_OPTION                 ', clc$optional_field, 1154], [[1, 0, clc$keyword_type], [31], [
          ['ALL_OCCURRENCE                 ', clc$alias_entry, clc$normal_usage_entry, 1],
          ['ALL_OCCURRENCES                ', clc$nominal_entry, clc$normal_usage_entry, 1],
          ['AO                             ', clc$alias_entry, clc$normal_usage_entry, 1],
          ['AVERAGE                        ', clc$alias_entry, clc$normal_usage_entry, 6],
          ['AVG                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
          ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
          ['COUNT                          ', clc$nominal_entry, clc$normal_usage_entry, 4],
          ['COUNT_PER_SECOND               ', clc$nominal_entry, clc$normal_usage_entry, 10],
          ['CPS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10],
          ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
          ['DETAIL                         ', clc$alias_entry, clc$normal_usage_entry, 1],
          ['ELAPSED_TIME_SINCE_PREDECESSOR ', clc$nominal_entry, clc$hidden_entry, 13],
          ['ETSP                           ', clc$abbreviation_entry, clc$hidden_entry, 13],
          ['FIRST_OCCURRENCE               ', clc$nominal_entry, clc$normal_usage_entry, 2],
          ['FO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
          ['I                              ', clc$abbreviation_entry, clc$hidden_entry, 12],
          ['INTERVAL                       ', clc$nominal_entry, clc$hidden_entry, 12],
          ['LAST_OCCURRENCE                ', clc$nominal_entry, clc$normal_usage_entry, 3],
          ['LO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
          ['M                              ', clc$alias_entry, clc$normal_usage_entry, 6],
          ['MAX                            ', clc$abbreviation_entry, clc$normal_usage_entry, 9],
          ['MAXIMUM                        ', clc$nominal_entry, clc$normal_usage_entry, 9],
          ['MEAN                           ', clc$nominal_entry, clc$normal_usage_entry, 6],
          ['MIN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
          ['MINIMUM                        ', clc$nominal_entry, clc$normal_usage_entry, 8],
          ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
          ['SD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
          ['SPS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 11],
          ['STANDARD_DEVIATION             ', clc$nominal_entry, clc$normal_usage_entry, 7],
          ['SUM                            ', clc$nominal_entry, clc$normal_usage_entry, 5],
          ['SUM_PER_SECOND                 ', clc$nominal_entry, clc$normal_usage_entry, 11]]
          ],
        ['START_COLUMN                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]],
        ['COLUMN_WIDTH                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]],
        ['HEADER_1                       ', clc$optional_field, 8], [[1, 0, clc$string_type], [1,
  ptc$max_page_width, FALSE]],
        ['HEADER_2                       ', clc$optional_field, 8], [[1, 0, clc$string_type], [1,
  ptc$max_page_width, FALSE]]
        ]
      ]
    ],
{ PARAMETER 6
    [[1, 0, clc$list_type], [976, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$record_type], [3],
      ['CALCULATION                    ', clc$required_field, 821], [[1, 0, clc$keyword_type], [22], [
        ['AVERAGE                        ', clc$alias_entry, clc$normal_usage_entry, 3],
        ['AVG                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['COUNT                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['COUNT_PER_SECOND               ', clc$nominal_entry, clc$normal_usage_entry, 7],
        ['CPS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
        ['ELAPSED_TIME_SINCE_PREDECESSOR ', clc$nominal_entry, clc$hidden_entry, 10],
        ['ETSP                           ', clc$abbreviation_entry, clc$hidden_entry, 10],
        ['I                              ', clc$abbreviation_entry, clc$hidden_entry, 9],
        ['INTERVAL                       ', clc$nominal_entry, clc$hidden_entry, 9],
        ['M                              ', clc$alias_entry, clc$normal_usage_entry, 3],
        ['MAX                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['MAXIMUM                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
        ['MEAN                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['MIN                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['MINIMUM                        ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['SD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['SPS                            ', clc$abbreviation_entry, clc$normal_usage_entry, 8],
        ['STANDARD_DEVIATION             ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['SUM                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['SUM_PER_SECOND                 ', clc$nominal_entry, clc$normal_usage_entry, 8]]
        ],
      ['START_COLUMN                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]],
      ['COLUMN_WIDTH                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]]
      ]
    ],
{ PARAMETER 7
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 8
    [[1, 0, clc$record_type], [4],
    ['LABEL                          ', clc$optional_field, 331], [[1, 0, clc$union_type], [[
      clc$keyword_type, clc$string_type],
      FALSE, 2],
      303, [[1, 0, clc$keyword_type], [8], [
        ['END_TIME                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['ET                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['ST                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['START_TIME                     ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['TIME_RANGE                     ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['TR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3]]
        ],
      8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
      ],
    ['START_COLUMN                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]],
    ['COLUMN_WIDTH                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]],
    ['DATE_TIME_FORMAT               ', clc$optional_field, 8], [[1, 0, clc$string_type], [0,
  clc$max_string_size, FALSE]]
    ,
    '(time_range 1 21 ''HMS'')'],
{ PARAMETER 9
    [[1, 0, clc$record_type], [2],
    ['START_COLUMN                   ', clc$required_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]],
    ['COLUMN_WIDTH                   ', clc$required_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]]
    ],
{ PARAMETER 10
    [[1, 0, clc$integer_type], [1, 10000, 10]],
{ PARAMETER 11
    [[1, 0, clc$list_type], [8, 1, 11, FALSE],
      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 12
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    179, [[1, 0, clc$list_type], [163, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$record_type], [3],
        ['STRING                         ', clc$required_field, 8], [[1, 0, clc$string_type], [0,
  clc$max_string_size, FALSE]],
        ['START_COLUMN                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]],
        ['COLUMN_WIDTH                   ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  ptc$max_page_width, 10]]
        ]
      ]
    ],
{ PARAMETER 13
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, clc$max_integer, 10]]
    ],
{ PARAMETER 14
    [[1, 0, clc$boolean_type]],
{ PARAMETER 15
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 16
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    563, [[1, 0, clc$list_type], [547, 1, sfc$max_number_of_counters, FALSE],
        [[1, 0, clc$record_type], [2],
        ['COUNTER_NUMBER                 ', clc$required_field, 91], [[1, 0, clc$union_type], [[
          clc$keyword_type, clc$range_type],
          FALSE, 2],
          44, [[1, 0, clc$keyword_type], [1], [
            ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
            ],
          27, [[1, 0, clc$range_type], [20],
              [[1, 0, clc$integer_type], [1, sfc$max_number_of_counters, 10]]
            ]
          ],
        ['BASE                           ', clc$required_field, 377], [[1, 0, clc$keyword_type], [10], [
          ['B10                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
          ['B16                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
          ['B16G                           ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
          ['B2                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
          ['B8                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
          ['BASE_10                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
          ['BASE_16                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
          ['BASE_16_GROUP                  ', clc$nominal_entry, clc$normal_usage_entry, 5],
          ['BASE_2                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
          ['BASE_8                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
          ]
        ]
      ]
    ],
{ PARAMETER 17
    [[1, 0, clc$union_type], [[clc$record_type, clc$string_type],
    FALSE, 2],
    8, [[1, 0, clc$string_type], [0, sfc$max_descriptive_data_size, FALSE]],
    347, [[1, 0, clc$record_type], [4],
      ['POSITION                       ', clc$optional_field, 20], [[1, 0, clc$integer_type], [1,
  sfc$max_descriptive_data_size, 10]],
      ['LENGTH                         ', clc$optional_field, 84], [[1, 0, clc$union_type], [[
        clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [1, sfc$max_descriptive_data_size, 10]]
        ],
      ['FIELD_NUMBER                   ', clc$optional_field, 84], [[1, 0, clc$union_type], [[
        clc$integer_type, clc$keyword_type],
        FALSE, 2],
        44, [[1, 0, clc$keyword_type], [1], [
          ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
          ],
        20, [[1, 0, clc$integer_type], [1, sfc$max_descriptive_data_size, 10]]
        ],
      ['FIELD_DELIMITER                ', clc$optional_field, 8], [[1, 0, clc$string_type], [1, 1, FALSE]]
      ]
    ],
{ PARAMETER 18
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$put = 1,
      p$number = 2,
      p$new_put = 3,
      p$new_number = 4,
      p$field = 5,
      p$display_option = 6,
      p$display_headers = 7,
      p$row_label = 8,
      p$row_label_format = 9,
      p$report_interval = 10,
      p$string = 11,
      p$page_header = 12,
      p$pop_count = 13,
      p$use_page_headers = 14,
      p$selection = 15,
      p$counter = 16,
      p$descriptive_data = 17,
      p$status = 18;

    VAR
      pvt: array [1 .. 18] of clt$parameter_value;

    VAR
      all_occurrences: boolean,
      index: integer,
      number: integer,
      put_entry_chain_head: ^put_entry,
      put_number: string (15),
      put_entry_p: ^put_entry,
      put_entry_1_p: ^put_entry,
      temp_put_entry: ^put_entry;

?? NEWTITLE := 'check_change_put', EJECT ??

    PROCEDURE check_change_put
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$new_put =
          IF pvt [p$new_put].specified THEN
            put_entry_p := put_entry_chain_head;
            WHILE (put_entry_p <> NIL) AND (put_entry_p^.name <> pvt [p$new_put].value^.name_value) DO
              put_entry_p := put_entry_p^.put_chain_link_p;
            WHILEND;
            IF put_entry_p <> NIL THEN
              osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$redefined_put,
                    pvt [p$new_put].value^.name_value, status);
              RETURN; {----->
            IFEND;
          IFEND;
        ELSE
        CASEND;
      ELSE

        IF pvt [p$put].specified AND pvt [p$number].specified THEN
          osp$set_status_condition (pte$put_and_number, status);
          RETURN; {----->
        IFEND;

        IF (NOT pvt [p$put].specified) AND (NOT pvt [p$number].specified) THEN
          osp$set_status_condition (pte$not_put_and_number, status);
          RETURN; {----->
        IFEND;

{ p$put, p$number

        put_entry_p := put_entry_chain_head;
        IF pvt [p$put].specified THEN
          number := 1;
          WHILE (put_entry_p <> NIL) AND (put_entry_p^.name <> pvt [p$put].value^.name_value) DO
            put_entry_p := put_entry_p^.put_chain_link_p;
            number := number + 1;
          WHILEND;
          IF put_entry_p = NIL THEN
            osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$undefined_put_for_change,
                  pvt [p$put].value^.name_value, status);
            RETURN; {----->
          IFEND;
        ELSE
          number := 1;
          WHILE (put_entry_p <> NIL) AND (number < pvt [p$number].value^.integer_value.value) DO
            put_entry_p := put_entry_p^.put_chain_link_p;
            number := number + 1;
          WHILEND;
          IF put_entry_p = NIL THEN
            put_number := 'number ';
            STRINGREP (put_number (8, * ), ptv$output_line_length, pvt [p$number].value^.integer_value.value);
            osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$undefined_put_for_change, put_number,
                  status);
            RETURN; {----->
          IFEND;
        IFEND;

        temp_put_entry^ := put_entry_p^;

        CASE put_entry_p^.put OF

        = put_field_summary =

          IF pvt [p$report_interval].specified OR pvt [p$string].specified OR pvt [p$selection].
                specified OR pvt [p$counter].specified OR pvt [p$descriptive_data].
                specified OR pvt [p$row_label].specified OR pvt [p$page_header].specified
                 OR pvt [p$pop_count].specified OR pvt [p$use_page_headers].specified THEN
            osp$set_status_condition (pte$change_put_parameters_putfs, status);
            RETURN; {----->
          IFEND;

          IF pvt [p$field].specified THEN
            report_undefined_counters (pvt [p$field].value, status);
          IFEND;

          IF pvt [p$display_option].specified OR pvt [p$row_label_format].specified THEN

{ summary_calculation & row_label_format

            process_summary_calculation (pvt [p$display_option], pvt [p$row_label_format],
                  temp_put_entry, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            process_headers_putfs (temp_put_entry);
          IFEND;

        = put_interval_field =

          IF pvt [p$display_headers].specified OR pvt [p$string].specified OR pvt [p$selection].
                specified OR pvt [p$counter].specified OR pvt [p$descriptive_data].
                specified OR pvt [p$row_label_format].specified OR pvt [p$page_header].specified
                OR pvt [p$pop_count].specified OR pvt [p$use_page_headers].specified THEN
            osp$set_status_condition (pte$change_put_parameters_putif, status);
            RETURN; {----->
          IFEND;

          IF pvt [p$field].specified THEN
            report_undefined_fields (pvt [p$field].value, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;

          IF pvt [p$field].specified OR pvt [p$row_label].specified THEN

{ field (field_name, summary_calculation, position_description and headers).

            process_field_position (pvt [p$field], pvt [p$row_label], temp_put_entry, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;

        = put_field =

          IF pvt [p$display_headers].specified OR pvt [p$string].specified OR pvt [p$selection].
                specified OR pvt [p$counter].specified OR pvt [p$descriptive_data].
                specified OR pvt [p$row_label_format].specified OR pvt [p$page_header].specified
                OR pvt [p$pop_count].specified OR pvt [p$use_page_headers].specified THEN
            osp$set_status_condition (pte$change_put_parameters_putf, status);
            RETURN; {----->
          IFEND;

          IF pvt [p$field].specified THEN
            report_undefined_fields (pvt [p$field].value, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            check_display_option (pvt [p$field].value, all_occurrences, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

{ field (field_name, summary_calculation and position_description and headers).

            temp_put_entry^.all_occurrences := all_occurrences;
            process_field_position (pvt [p$field], pvt [p$field], temp_put_entry, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;

        = put_string =

          IF pvt [p$display_headers].specified OR pvt [p$field].specified OR pvt [p$report_interval].
                specified OR pvt [p$row_label_format].specified OR pvt [p$selection].
                specified OR pvt [p$counter].specified OR pvt [p$descriptive_data].
                specified OR pvt [p$row_label].specified OR pvt [p$page_header].specified
                OR pvt [p$pop_count].specified OR pvt [p$use_page_headers].specified THEN
            osp$set_status_condition (pte$change_put_parameters_puts, status);
            RETURN; {----->
          IFEND;

          IF pvt [p$string].specified THEN
            process_string (pvt [p$string], temp_put_entry, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;

        = push_page_header =

          IF pvt [p$display_headers].specified OR pvt [p$field].specified OR pvt [p$report_interval].
                specified OR pvt [p$row_label_format].specified OR pvt [p$selection].
                specified OR pvt [p$counter].specified OR pvt [p$descriptive_data].
                specified OR pvt [p$row_label].specified OR pvt [p$string].specified
                OR  pvt [p$pop_count].specified OR  pvt [p$use_page_headers].specified THEN
            osp$set_status_condition (pte$change_put_parameters_pusph, status);
            RETURN; {----->
          IFEND;

          IF pvt [p$page_header].specified THEN
            IF (pvt [p$page_header].value^.kind = clc$keyword) THEN

  { The only keyword is DEFAULT.
              temp_put_entry^.default_header := TRUE;
            ELSE {header string specified
              temp_put_entry^.default_header := FALSE;
              process_string (pvt [p$page_header], temp_put_entry, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
            IFEND;
          IFEND;

        = pop_page_header =

          IF pvt [p$display_headers].specified OR pvt [p$field].specified OR pvt [p$report_interval].
                specified OR pvt [p$row_label_format].specified OR pvt [p$selection].
                specified OR pvt [p$counter].specified OR pvt [p$descriptive_data].
                specified OR pvt [p$row_label].specified OR pvt [p$string].specified
                OR  pvt [p$page_header].specified OR  pvt [p$use_page_headers].specified THEN
            osp$set_status_condition (pte$change_put_parameters_popph, status);
            RETURN; {----->
          IFEND;

        = put_new_page =

          IF pvt [p$display_headers].specified OR pvt [p$field].specified OR pvt [p$report_interval].
                specified OR pvt [p$row_label_format].specified OR pvt [p$selection].
                specified OR pvt [p$counter].specified OR pvt [p$descriptive_data].
                specified OR pvt [p$row_label].specified OR pvt [p$string].specified
                OR  pvt [p$page_header].specified OR  pvt [p$pop_count].specified THEN
            osp$set_status_condition (pte$change_put_parameters_putnp, status);
            RETURN; {----->
          IFEND;

        = put_record =

          IF pvt [p$display_headers].specified OR pvt [p$string].specified OR
                pvt [p$report_interval].specified OR pvt [p$row_label_format].specified OR
                pvt [p$field].specified OR pvt [p$row_label].specified OR pvt [p$page_header].specified
                OR pvt [p$pop_count].specified OR pvt [p$use_page_headers].specified THEN
            osp$set_status_condition (pte$change_put_parameters_putr, status);
            RETURN; {----->
          IFEND;

          IF pvt [p$selection].specified THEN
            report_duplicate_name (pvt [p$selection].value, 'SELECTION', status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            report_undefined_selections (pvt [p$selection].value, put_entry_p, status);
          IFEND;

          IF pvt [p$counter].specified THEN
            check_counter_parameter (pvt [p$counter], temp_put_entry, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;

        ELSE
        CASEND;

      IFEND;

    PROCEND check_change_put;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$get_reason_for_call (ptv$information_request, ptv$display_file, ptv$prompting_activted, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    IF NOT ptv$information_request THEN

      CASE ptv$generate OF
      = report =
        put_entry_chain_head := ptv$report_entry_chain_head_p;
      = log =
        put_entry_chain_head := ptv$log_entry_chain_head_p;
      = none =
        clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
        osp$set_status_condition (pte$generate_none_mode, status);
        RETURN; {----->
      ELSE
      CASEND;

      ALLOCATE temp_put_entry;

    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_change_put, ^pvt, status);
    IF NOT status.normal THEN
      IF NOT ptv$information_request THEN
        FREE temp_put_entry;
      IFEND;
      RETURN; {----->
    IFEND;

{ new_number

    IF pvt [p$new_number].specified THEN
      IF put_entry_p <> put_entry_chain_head THEN
        put_entry_1_p := put_entry_chain_head;
        FOR index := 1 TO (number - 2) DO
          put_entry_1_p := put_entry_1_p^.put_chain_link_p;
        FOREND;
        put_entry_1_p^.put_chain_link_p := put_entry_p^.put_chain_link_p;
      ELSE
        put_entry_chain_head := put_entry_p^.put_chain_link_p;
      IFEND;
      put_entry_p^.put_chain_link_p := NIL;
      process_number_parameter (pvt [p$new_number].value^, put_entry_p, ptv$report_entry_chain_head_p);
    IFEND;

{ new_put

    IF pvt [p$new_put].specified THEN
      temp_put_entry^.name := pvt [p$new_put].value^.name_value;
    IFEND;

{ display_headers

    IF pvt [p$display_headers].specified THEN
      temp_put_entry^.display_headers := pvt [p$display_headers].value^.boolean_value.value;
      IF temp_put_entry^.display_headers THEN
        process_headers_putfs (temp_put_entry);
      IFEND;
    IFEND;

{ report_interval

    IF pvt [p$report_interval].specified THEN
      temp_put_entry^.report_interval := pvt [p$report_interval].value^.integer_value.value;
    IFEND;

{ descriptive_data

    IF pvt [p$descriptive_data].specified THEN
      IF pvt [p$descriptive_data].value^.kind = clc$record THEN

        IF temp_put_entry^.descriptive_text_p <> NIL THEN
          FREE temp_put_entry^.descriptive_text_p;
          temp_put_entry^.subfield_position := 1;
          temp_put_entry^.subfield_length := sfc$max_descriptive_data_size;
          temp_put_entry^.subfield_number := 0;
          temp_put_entry^.subfield_delimiter := ',';
        IFEND;

        IF pvt [p$descriptive_data].value^.field_values^ [1].value <> NIL THEN
          temp_put_entry^.subfield_position := pvt [p$descriptive_data].value^.field_values^ [1].
                value^.integer_value.value;
        IFEND;

        IF pvt [p$descriptive_data].value^.field_values^ [2].value <> NIL THEN
          IF pvt [p$descriptive_data].value^.field_values^ [2].value^.kind <> clc$keyword THEN
            temp_put_entry^.subfield_length := pvt [p$descriptive_data].value^.field_values^ [2].
                  value^.integer_value.value;
          ELSE
            temp_put_entry^.subfield_length := sfc$max_descriptive_data_size;
          IFEND;
        IFEND;

        IF pvt [p$descriptive_data].value^.field_values^ [3].value <> NIL THEN
          IF pvt [p$descriptive_data].value^.field_values^ [3].value^.kind <> clc$keyword THEN
            temp_put_entry^.subfield_number := pvt [p$descriptive_data].value^.field_values^ [3].
                  value^.integer_value.value;
          ELSE
            temp_put_entry^.subfield_number := 0;
          IFEND;
        IFEND;

        IF pvt [p$descriptive_data].value^.field_values^ [4].value <> NIL THEN
          temp_put_entry^.subfield_delimiter := pvt [p$descriptive_data].value^.field_values^ [4].
                value^.string_value^ (1);
        IFEND;

      ELSE

        IF temp_put_entry^.descriptive_text_p <> NIL THEN
          FREE temp_put_entry^.descriptive_text_p;
        IFEND;

        ALLOCATE temp_put_entry^.descriptive_text_p: [#SIZE (pvt [p$descriptive_data].value^.string_value^)];
        temp_put_entry^.descriptive_text_p^ := pvt [p$descriptive_data].value^.string_value^;

      IFEND;
    IFEND;

{ Page format control

    IF pvt [p$pop_count].specified THEN
      temp_put_entry^.pop_count := pvt [p$pop_count].value^.integer_value.value;
    ELSEIF pvt [p$use_page_headers].specified THEN
      temp_put_entry^.use_page_headers := pvt [p$use_page_headers].value^.boolean_value.value;
    IFEND;

{ field & records

    IF pvt [p$field].specified OR pvt [p$selection].specified THEN
      CASE put_entry_p^.put OF

      = put_field_summary =
        free_field_list (put_entry_p);
        put_entry_p^ := temp_put_entry^;
        put_entry_p^.fields_p := NIL;
        process_field_parameter_putfs (pvt [p$field].value, put_entry_p);

      = put_interval_field, put_field =
        IF put_entry_p^.put = put_interval_field THEN
          FREE put_entry_p^.date_time_format_p;
        IFEND;
        free_field_vector (put_entry_p);
        put_entry_p^ := temp_put_entry^;
        process_field_parameter_putif (put_entry_p);

      = put_record =
        free_selection_list (put_entry_p^.selection_p);
        put_entry_p^ := temp_put_entry^;
        put_entry_p^.selection_p := NIL;
        process_selection_parameter (pvt [p$selection].value, put_entry_p);

      ELSE
      CASEND;
    ELSE
      put_entry_p^ := temp_put_entry^;
    IFEND;

    FREE temp_put_entry;

  PROCEND change_put_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'delete_put_cmd', EJECT ??

{ This procedure processes the delete_put command.

*copyc pth$anabl_delete_put

  PROCEDURE delete_put_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (ptm$anabl_delp) delete_put, delp (
{  put, p: (CHECK) any of
{      key
{        all
{      keyend
{      list of name
{    anyend = $optional
{  number, n: (CHECK) any of
{      key
{        all
{        (last, l)
{      keyend
{      list of range of integer 1..clc$max_integer
{    anyend = $optional
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: 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 .. 3] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 28, 11, 20, 9, 409],
    clc$command, 5, 3, 0, 0, 0, 0, 3, 'PTM$ANABL_DELP'], [
    ['N                              ',clc$abbreviation_entry, 2],
    ['NUMBER                         ',clc$nominal_entry, 2],
    ['P                              ',clc$abbreviation_entry, 1],
    ['PUT                            ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 85, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 181,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['LAST                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    43, [[1, 0, clc$list_type], [27, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$range_type], [20],
          [[1, 0, clc$integer_type], [1, clc$max_integer, 10]]
        ]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$put = 1,
      p$number = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      delete_more: boolean,
      delete_status: boolean,
      errors_detected: boolean,
      failing_status: ost$status,
      number: integer,
      numbers: ^numbers_set,
      put_entry_chain_head: ^put_entry,
      put_entry_1_p: ^put_entry,
      put_entry_2_p: ^put_entry,
      selection_p: ^selection,
      value_p: ^clt$data_value;

?? NEWTITLE := 'check_delete_put', EJECT ??

    PROCEDURE check_delete_put
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$put =
          IF pvt [p$put].value^.kind = clc$list THEN
            report_duplicate_name (pvt [p$put].value, 'PUT', status);
          IFEND;
        = p$number =
          IF pvt [p$number].value^.kind = clc$list THEN
            ALLOCATE numbers;
            report_duplicate_number (pvt [p$number].value, 'NUMBER', numbers, status);
          IFEND;
        ELSE
        CASEND;
      ELSE
        IF pvt [p$put].specified AND pvt [p$number].specified THEN
          osp$set_status_condition (pte$put_and_number, status);
        IFEND;
        IF (NOT pvt [p$put].specified) AND (NOT pvt [p$number].specified) THEN
          osp$set_status_condition (pte$not_put_and_number, status);
        IFEND;
      IFEND;

    PROCEND check_delete_put;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$get_reason_for_call (ptv$information_request, ptv$display_file, ptv$prompting_activted, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    IF NOT ptv$information_request THEN
      CASE ptv$generate OF
      = report =
        put_entry_chain_head := ptv$report_entry_chain_head_p;
      = log =
        put_entry_chain_head := ptv$log_entry_chain_head_p;
      = none =
        clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
        osp$set_status_condition (pte$generate_none_mode, status);
        RETURN; {----->
      ELSE
      CASEND;

      numbers := NIL;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_delete_put, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    errors_detected := FALSE;
    IF pvt [p$put].specified THEN

{ PUT

      IF pvt [p$put].value^.kind = clc$keyword THEN

{ ALL

        put_entry_1_p := put_entry_chain_head;
        WHILE put_entry_1_p <> NIL DO
          put_entry_2_p := put_entry_1_p^.put_chain_link_p;
          delete_put (put_entry_1_p);
          put_entry_1_p := put_entry_2_p;
        WHILEND;
        put_entry_chain_head := NIL;
      ELSE

{ LIST

        value_p := pvt [p$put].value;
        WHILE value_p <> NIL DO
          put_entry_1_p := put_entry_chain_head;
          put_entry_2_p := put_entry_chain_head;
          WHILE (put_entry_1_p <> NIL) AND (value_p^.element_value^.name_value <> put_entry_1_p^.name) DO
            put_entry_2_p := put_entry_1_p;
            put_entry_1_p := put_entry_1_p^.put_chain_link_p;
          WHILEND;
          IF put_entry_1_p <> NIL THEN
            IF put_entry_1_p = put_entry_chain_head THEN
              put_entry_chain_head := put_entry_1_p^.put_chain_link_p;
              delete_put (put_entry_1_p);
            ELSE
              put_entry_2_p^.put_chain_link_p := put_entry_1_p^.put_chain_link_p;
              delete_put (put_entry_1_p);
            IFEND;
          ELSE
            errors_detected := TRUE;
            osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$undefined_put_for_delete,
                  value_p^.element_value^.name_value, failing_status);
            report_intermediate_error (failing_status, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            errors_detected := TRUE;
          IFEND;
          value_p := value_p^.link;
        WHILEND;
      IFEND;
      IF errors_detected THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, 'PUT', status);
      IFEND;
    ELSE

{ NUMBER

      IF pvt [p$number].value^.kind = clc$keyword THEN
        IF pvt [p$number].value^.name_value = 'LAST' THEN
          put_entry_1_p := put_entry_chain_head;
          put_entry_2_p := put_entry_chain_head;
          WHILE put_entry_1_p^.put_chain_link_p <> NIL DO
            put_entry_2_p := put_entry_1_p;
            put_entry_1_p := put_entry_1_p^.put_chain_link_p;
          WHILEND;
          IF put_entry_1_p = put_entry_chain_head THEN
            put_entry_chain_head := NIL;
          ELSE
            put_entry_2_p^.put_chain_link_p := NIL;
          IFEND;
          delete_put (put_entry_1_p);
        ELSE

{ ALL

          put_entry_1_p := put_entry_chain_head;
          WHILE put_entry_1_p <> NIL DO
            put_entry_2_p := put_entry_1_p^.put_chain_link_p;
            delete_put (put_entry_1_p);
            put_entry_1_p := put_entry_2_p;
          WHILEND;
          put_entry_chain_head := NIL;
        IFEND;
      ELSE

{ LIST

        number := 1;
        put_entry_1_p := put_entry_chain_head;
        put_entry_2_p := put_entry_chain_head;
        WHILE put_entry_1_p <> NIL DO
          IF number IN numbers^ THEN
            IF put_entry_1_p = put_entry_chain_head THEN
              put_entry_chain_head := put_entry_1_p^.put_chain_link_p;
              delete_put (put_entry_1_p);
              put_entry_1_p := put_entry_chain_head;
              put_entry_2_p := put_entry_chain_head;
            ELSE
              put_entry_2_p^.put_chain_link_p := put_entry_1_p^.put_chain_link_p;
              delete_put (put_entry_1_p);
              put_entry_1_p := put_entry_2_p^.put_chain_link_p;
            IFEND;
            numbers^ := numbers^ -$numbers_set [number];
          ELSE
            put_entry_2_p := put_entry_1_p;
            put_entry_1_p := put_entry_1_p^.put_chain_link_p;
          IFEND;
          number := number + 1;
        WHILEND;
        IF numbers^ <> $numbers_set [] THEN
          osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, 'NUMBER',
                status);
        IFEND;
      IFEND;
      IF errors_detected THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, 'NUMBER', status);
      IFEND;
    IFEND;

{ If delete_put deletes any put block the procedure most not bypass this code before exit. That way there is
{ no RETURN after osp$set_status_abnormal.

    CASE ptv$generate OF
    = report =
      ptv$report_entry_chain_head_p := put_entry_chain_head;
    = log =
      ptv$log_entry_chain_head_p := put_entry_chain_head;
    ELSE
    CASEND;

    IF put_entry_chain_head = NIL THEN
      ptv$generate := none;
      ptv$headers_specified := FALSE;
    IFEND;

    IF numbers <> NIL THEN
      FREE numbers;
    IFEND;

  PROCEND delete_put_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'display_put_cmd', EJECT ??

{ This procedure processes the display_put command.

*copyc pth$anabl_display_put

  PROCEDURE display_put_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (ptm$anabl_disp) display_put, disp (
{    put, p    : (check) any of
{                  key
{                    all
{                  keyend
{                  list of name
{                anyend = $optional
{    number, n : (check) any of
{                  key
{                    all
{                    (last, l)
{                  keyend
{                  list of range of integer 1..clc$max_integer
{                anyend = $optional
{    display_option, do : list of key
{                           all
{                           (entries e)
{                           (name names n)
{                           (type t)
{                         keyend = name
{    output ,o : file = $output
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: 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 .. 3] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 8] of clt$keyword_specification,
        recend,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 28, 11, 43, 15, 828],
    clc$command, 9, 5, 0, 0, 0, 0, 5, 'PTM$ANABL_DISP'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 3],
    ['DO                             ',clc$abbreviation_entry, 3],
    ['N                              ',clc$abbreviation_entry, 2],
    ['NUMBER                         ',clc$nominal_entry, 2],
    ['O                              ',clc$abbreviation_entry, 4],
    ['OUTPUT                         ',clc$nominal_entry, 4],
    ['P                              ',clc$abbreviation_entry, 1],
    ['PUT                            ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 85, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 181,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 319,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['LAST                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    43, [[1, 0, clc$list_type], [27, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$range_type], [20],
          [[1, 0, clc$integer_type], [1, clc$max_integer, 10]]
        ]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$list_type], [303, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [8], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['ENTRIES                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['NAME                           ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['NAMES                          ', clc$alias_entry, clc$normal_usage_entry, 3],
      ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['TYPE                           ', clc$nominal_entry, clc$normal_usage_entry, 4]]
      ]
    ,
    'name'],
{ PARAMETER 4
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$put = 1,
      p$number = 2,
      p$display_option = 3,
      p$output = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    TYPE
      display_option_type = set of (ptc$name, ptc$type, ptc$entries, ptc$all);

    VAR
      base: radix,
      display_option: display_option_type,
      errors_detected: boolean,
      failing_status: ost$status,
      index: integer,
      low_index: integer,
      number: integer,
      numbers: ^numbers_set,
      put_entry_chain_head: ^put_entry,
      put_entry_p: ^put_entry,
      selection_list_p: ^selection_list,
      value_p: ^clt$data_value;

?? NEWTITLE := 'check_display_put', EJECT ??

    PROCEDURE check_display_put
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$put =
          IF pvt [p$put].value^.kind = clc$list THEN
            report_duplicate_name (pvt [p$put].value, 'PUT', status);
          IFEND;
        = p$number =
          IF pvt [p$number].value^.kind = clc$list THEN
            ALLOCATE numbers;
            report_duplicate_number (pvt [p$number].value, 'NUMBER', numbers, status);
          IFEND;
        ELSE
        CASEND;
      ELSE
        IF pvt [p$put].specified AND pvt [p$number].specified THEN
          osp$set_status_condition (pte$put_and_number, status);
        IFEND;
        IF (NOT pvt [p$put].specified) AND (NOT pvt [p$number].specified) THEN
          osp$set_status_condition (pte$not_put_and_number, status);
        IFEND;
      IFEND;

    PROCEND check_display_put;

?? OLDTITLE ??
?? NEWTITLE := 'format_put_display', EJECT ??

    PROCEDURE format_put_display
      (VAR status: ost$status);

      VAR
        base_string: string (20),
        base_string_length: integer,
        field_list_p: ^field_list,
        index: integer,
        length_string: ost$string,
        subfield_number_string: ost$string,
        summary_string: ost$name;

?? NEWTITLE := 'format_put_field_summary', EJECT ??

      PROCEDURE format_put_field_summary
        (VAR status: ost$status);


        status.normal := TRUE;

        IF ptc$entries IN display_option THEN
          cyp$put_next_line (ptv$output_file, '   Field(s)', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          cyp$put_next_line (ptv$output_file, '     Counter Name                      Row Label', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          field_list_p := put_entry_p^.fields_p;
          WHILE field_list_p <> NIL DO
            STRINGREP (ptv$output_line, ptv$output_line_length, '     ', field_list_p^.field_p^.field_name,
                  '   ', field_list_p^.row_label (1, put_entry_p^.row_label_column_width));
            cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            field_list_p := field_list_p^.link_p;
          WHILEND;
        IFEND;

        IF ptc$type IN display_option THEN
          cyp$put_next_line (ptv$output_file, '   Put Type : Put Field Summary', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          cyp$put_next_line (ptv$output_file, '     Summary Calculation & Position Description', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          cyp$put_next_line (ptv$output_file, '       Summary                          Column  Length',
                status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          cyp$put_next_line (ptv$output_file, '       -------                          ------  ------',
                status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          FOR index := LOWERBOUND (summary_vector_type) TO UPPERBOUND (summary_vector_type) DO
            CASE put_entry_p^.summary_vector [index].summary OF
            = count =
              summary_string := 'Count';
            = sum =
              summary_string := 'Sum';
            = mean =
              summary_string := 'Mean';
            = standard_deviation =
              summary_string := 'Standard Deviation';
            = minimum =
              summary_string := 'Minimum';
            = maximum =
              summary_string := 'Maximum';
            = interval =
              summary_string := 'Interval';
            = count_per_second =
              summary_string := 'Count Per Second';
            = sum_per_second =
              summary_string := 'Sum Per Second';
            = elapsed_time_since_predecessor =
              summary_string := 'Elapsed Time Since Predecessor';
            = text =
              summary_string := 'Descriptive Data';
            ELSE
            CASEND;
            IF put_entry_p^.summary_vector [index].summary <> null THEN
              STRINGREP (ptv$output_line, ptv$output_line_length, '       ', summary_string,
                    put_entry_p^.summary_vector [index].start_column: 4, ' ',
                    (put_entry_p^.summary_vector [index].start_column +
                    put_entry_p^.summary_vector [index].column_width - 1):
                    4, put_entry_p^.summary_vector [index].column_width: 4);
              ptv$output_line (43, 2) := '..';
              cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
            IFEND;
          FOREND;

          STRINGREP (ptv$output_line, ptv$output_line_length, '     Row Label Format :  Column ',
                put_entry_p^.row_label_start_column: 4, ' ', (put_entry_p^.row_label_start_column +
                put_entry_p^.row_label_column_width - 1): 4, '  Length ',
                put_entry_p^.row_label_column_width);
          ptv$output_line (37, 2) := '..';
          cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          STRINGREP (ptv$output_line, ptv$output_line_length, '     Display Headers : ',
                put_entry_p^.display_headers);
          cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          IF put_entry_p^.display_headers THEN
            IF put_entry_p^.header_1 <> ' ' THEN
              cyp$put_next_line (ptv$output_file, '    Header 1', status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
              cyp$put_next_line (ptv$output_file, put_entry_p^.header_1, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
            IFEND;

            IF put_entry_p^.header_2 <> ' ' THEN
              cyp$put_next_line (ptv$output_file, '    Header 2', status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
              cyp$put_next_line (ptv$output_file, put_entry_p^.header_2, status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
            IFEND;
          IFEND;
        IFEND;

      PROCEND format_put_field_summary;

?? OLDTITLE ??
?? NEWTITLE := 'format_put_field', EJECT ??

      PROCEDURE format_put_field
        (VAR status: ost$status);

        VAR
          join_predecessor_status: join_predecessor_status_type,
          selection_p: ^selection;

?? NEWTITLE := 'format_put_field_headers', EJECT ??

        PROCEDURE format_put_field_headers
          (VAR status: ost$status);

          status.normal := TRUE;

          IF put_entry_p^.header_1 <> ' ' THEN
            cyp$put_next_line (ptv$output_file, '    Header 1', status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            cyp$put_next_line (ptv$output_file, put_entry_p^.header_1, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;

          IF put_entry_p^.header_2 <> ' ' THEN
            cyp$put_next_line (ptv$output_file, '    Header 2', status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            cyp$put_next_line (ptv$output_file, put_entry_p^.header_2, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;

        PROCEND format_put_field_headers;

?? OLDTITLE, EJECT ??

        status.normal := TRUE;

        IF ptc$entries IN display_option THEN
          IF NOT (ptc$type IN display_option) THEN
            cyp$put_next_line (ptv$output_file, '   Field(s)', status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            FOR index := LOWERBOUND (field_vector_type) TO UPPERBOUND (field_vector_type) DO
              IF (put_entry_p^.field_vector [index].summary <> null) THEN
                STRINGREP (ptv$output_line, ptv$output_line_length, '     ', put_entry_p^.
                      field_vector [index].field_p^.field_name);
                cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
                IF NOT status.normal THEN
                  RETURN; {----->
                IFEND;
              IFEND;
            FOREND;
          IFEND;
        IFEND;

        IF ptc$type IN display_option THEN
          IF put_entry_p^.put = put_interval_field THEN
            cyp$put_next_line (ptv$output_file, '   Put Type : Put Interval Field', status);
          ELSE
            cyp$put_next_line (ptv$output_file, '   Put Type : Put Field', status);
          IFEND;
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          cyp$put_next_line (ptv$output_file, '     Field, Display Option & Position Description', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          cyp$put_next_line (ptv$output_file,
                '   Field                           Display Option                   Column  Len', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          cyp$put_next_line (ptv$output_file,
                '   -----                           --------------                   ------  ---', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          FOR index := LOWERBOUND (field_vector_type) TO UPPERBOUND (field_vector_type) DO
            CASE put_entry_p^.field_vector [index].summary OF
            = count =
              summary_string := 'Count';
            = sum =
              summary_string := 'Sum';
            = mean =
              summary_string := 'Mean';
            = standard_deviation =
              summary_string := 'Standard Deviation';
            = minimum =
              summary_string := 'Minimum';
            = maximum =
              summary_string := 'Maximum';
            = interval =
              summary_string := 'Interval';
            = count_per_second =
              summary_string := 'Count Per Second';
            = sum_per_second =
              summary_string := 'Sum Per Second';
            = elapsed_time_since_predecessor =
              summary_string := 'Elapsed Time Since Predecessor';
            = text =
              summary_string := 'Text';
            = all_occurrences =
              summary_string := 'All Occurrences';
            = last_occurrence =
              summary_string := 'Last Occurrences';
            = first_occurrence =
              summary_string := 'First Occurrences';
            ELSE
            CASEND;
            IF put_entry_p^.field_vector [index].summary <> null THEN
              STRINGREP (ptv$output_line, ptv$output_line_length, '   ',
                    put_entry_p^.field_vector [index].field_p^.field_name, ' ', summary_string,
                    put_entry_p^.field_vector [index].start_column: 4, ' ',
                    (put_entry_p^.field_vector [index].start_column +
                    put_entry_p^.field_vector [index].column_width - 1): 4,
                    put_entry_p^.field_vector [index].column_width: 4);
              ptv$output_line (71, 2) := '..';
              cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
            IFEND;
          FOREND;

          IF put_entry_p^.put = put_interval_field THEN

            CASE put_entry_p^.row_label_type OF

            = start_time =
              STRINGREP (ptv$output_line, ptv$output_line_length, '   Row Label Type : Start_Time');

            = end_time =
              cyp$put_next_line (ptv$output_file, '   Row Label Type : End_Time', status);

            = time_range =
              cyp$put_next_line (ptv$output_file, '   Row Label Type : Time_Range', status);

            = row_label_none =
              cyp$put_next_line (ptv$output_file, '   Row Label Type : None', status);

            = string_label =
              STRINGREP (ptv$output_line, ptv$output_line_length, '   Row Label Type : String   ''',
                    put_entry_p^.row_label (1, put_entry_p^.date_time_column_width), '''');
              cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);

            ELSE
            CASEND;
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            IF put_entry_p^.row_label_type <> row_label_none THEN
              STRINGREP (ptv$output_line, ptv$output_line_length, '   Row Label Format :  Column ',
                    put_entry_p^.date_time_start_column: 4, ' ', (put_entry_p^.date_time_start_column +
                    put_entry_p^.date_time_column_width - 1): 4, '  Length ',
                    put_entry_p^.date_time_column_width);
              ptv$output_line (35, 2) := '..';
              cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;

              IF put_entry_p^.row_label_type <> string_label THEN
                STRINGREP (ptv$output_line, ptv$output_line_length, '   Date Time Format  ''',
                      put_entry_p^.date_time_format_p^, '''');
                cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
                IF NOT status.normal THEN
                  RETURN; {----->
                IFEND;
              IFEND;
            IFEND;

            STRINGREP (ptv$output_line, ptv$output_line_length, '   Report Interval :',
                  put_entry_p^.report_interval);
            cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            format_put_field_headers (status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

          IFEND;

          IF (put_entry_p^.put = put_field) AND put_entry_p^.all_occurrences THEN

            format_put_field_headers (status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

            check_predecessor_path (put_entry_p, join_predecessor_status, selection_p);

            CASE join_predecessor_status OF
            = one_selection =

            = no_predecessor_path = { The fields are from more than one selection.
              cyp$put_next_line (ptv$output_file, '    The field in the put entry belong to more than one' CAT
                    ' selection but join predecessor was not active.', status);

            = predecessor_path =
              cyp$put_next_line (ptv$output_file, '    The field in the put entry belong to more than one' CAT
                    ' selection and join predecessor is active.', status);

            ELSE
            CASEND;
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;

          IFEND;

        IFEND;

      PROCEND format_put_field;

?? OLDTITLE ??
?? NEWTITLE := 'format_put_string', EJECT ??

      PROCEDURE format_put_string
        (VAR status: ost$status);

        status.normal := TRUE;

        IF ptc$type IN display_option THEN
          cyp$put_next_line (ptv$output_file, '   Put Type : Put String', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          cyp$put_next_line (ptv$output_file, '    string :', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          cyp$put_next_line (ptv$output_file, put_entry_p^.header_1, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;

      PROCEND format_put_string;

?? OLDTITLE ??
?? NEWTITLE := 'format_push_page_header', EJECT ??

      PROCEDURE format_push_page_header
        (VAR status: ost$status);

        status.normal := TRUE;

        IF ptc$type IN display_option THEN
          cyp$put_next_line (ptv$output_file, '   Put Type : Push Page Header', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          cyp$put_next_line (ptv$output_file, '     Header :', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          IF put_entry_p^.default_header THEN
            cyp$put_next_line (ptv$output_file, '  DEFAULT HEADER', status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          ELSE
            cyp$put_next_line (ptv$output_file, put_entry_p^.header_1, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;
        IFEND;

      PROCEND format_push_page_header;

?? OLDTITLE ??
?? NEWTITLE := 'format_pop_page_header', EJECT ??

      PROCEDURE format_pop_page_header
        (VAR status: ost$status);

        VAR
          pop_count_string: string(3);

        status.normal := TRUE;

        IF ptc$type IN display_option THEN
          cyp$put_next_line (ptv$output_file, '   Put Type : Pop Page Header', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          cyp$put_next_line (ptv$output_file, '    Pop Count :', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          IF put_entry_p^.pop_all_headers THEN
            cyp$put_next_line (ptv$output_file, '  ALL HEADERS', status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          ELSE
            clp$convert_integer_to_rjstring (put_entry_p^.pop_count, 10, FALSE, ' ', pop_count_string,
                  status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            cyp$put_next_line (ptv$output_file, pop_count_string, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;
        IFEND;

      PROCEND format_pop_page_header;

?? OLDTITLE ??
?? NEWTITLE := 'format_put_new_page', EJECT ??

      PROCEDURE format_put_new_page
        (VAR status: ost$status);

        VAR
          use_page_headers_string: string(5);

        status.normal := TRUE;

        IF ptc$type IN display_option THEN
          cyp$put_next_line (ptv$output_file, '   Put Type : Put New Page', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          cyp$put_next_line (ptv$output_file, '    Use Page Headers:', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          IF put_entry_p^.use_page_headers THEN
            cyp$put_next_line (ptv$output_file, ' TRUE', status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          ELSE
            cyp$put_next_line (ptv$output_file, 'FALSE', status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;
        IFEND;

      PROCEND format_put_new_page;

?? OLDTITLE ??
?? NEWTITLE := 'format_put_record', EJECT ??

      PROCEDURE format_put_record
        (VAR status: ost$status);

        status.normal := TRUE;

        IF ptc$entries IN display_option THEN
          cyp$put_next_line (ptv$output_file, '   Record(s)', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          selection_list_p := put_entry_p^.selection_p;
          WHILE selection_list_p <> NIL DO
            STRINGREP (ptv$output_line, ptv$output_line_length, '     ', selection_list_p^.selection_p^.name);
            cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            selection_list_p := selection_list_p^.link_p;
          WHILEND;
        IFEND;

        IF ptc$type IN display_option THEN
          cyp$put_next_line (ptv$output_file, '   Put Type : Put Record', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

{ Counter parameter

          cyp$put_next_line (ptv$output_file, '     Counters and base', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

          cyp$put_next_line (ptv$output_file, '       Counters      Base', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          STRINGREP (ptv$output_line, ptv$output_line_length, '       --------      ----');
          cyp$put_next_line (ptv$output_file, '       --------      ----', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

{ Put_record allows users to specify different bases for ranges of counters.  The following loop detects
{   when the base changes in the counter array.  If the base changes, then the old base is output
{   together with the range of counters that base was applied to.  The counter range is given by the
{   variables low_index..(index-1).

          low_index := 1;
          base := put_entry_p^.counter_base [1];
          FOR index := 1 TO sfc$max_number_of_counters DO
            IF base <> put_entry_p^.counter_base [index] THEN
              CASE base OF
              = base_0 =
                base_string := '  none';
                base_string_length := 6;
              = base_2 =
                base_string := '  base_2';
                base_string_length := 8;
              = base_8 =
                base_string := '  base_8';
                base_string_length := 8;
              = base_10 =
                base_string := '  base_10';
                base_string_length := 9;
              = base_16 =
                base_string := '  base_16';
                base_string_length := 9;
              = base_16_group =
                base_string := '  base_16_group';
                base_string_length := 15;
              ELSE
              CASEND;
              STRINGREP (ptv$output_line, ptv$output_line_length, '        ', low_index: 4, ' ..',
                    index - 1: 4, base_string (1, base_string_length));
              cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
              IF NOT status.normal THEN
                RETURN; {----->
              IFEND;
              base := put_entry_p^.counter_base [index];
              low_index := index;
            IFEND;
          FOREND;

{ Output the final base and counter range, since the loop will not detect a change for the last
{   counter range.

          CASE base OF
          = base_0 =
            base_string := '  none';
            base_string_length := 6;
          = base_2 =
            base_string := '  base_2';
            base_string_length := 8;
          = base_8 =
            base_string := '  base_8';
            base_string_length := 8;
          = base_10 =
            base_string := '  base_10';
            base_string_length := 9;
          = base_16 =
            base_string := '  base_16';
            base_string_length := 9;
          = base_16_group =
            base_string := '  base_16_group';
            base_string_length := 15;
          ELSE
          CASEND;
          STRINGREP (ptv$output_line, ptv$output_line_length, '        ', low_index: 4, ' ..',
                sfc$max_number_of_counters: 4, base_string (1, base_string_length));
          cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

{ Descriptive_data parameter

          IF put_entry_p^.descriptive_text_p <> NIL THEN
            STRINGREP (ptv$output_line, ptv$output_line_length, '     Descriptive Text     : ',
                  put_entry_p^.descriptive_text_p^);
            cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          ELSE

            IF put_entry_p^.subfield_length = sfc$max_descriptive_data_size THEN
              length_string.value := 'ALL';
              length_string.size := 3;
            ELSE
              clp$convert_integer_to_string (put_entry_p^.subfield_length, 10, FALSE, length_string, status);
            IFEND;

            IF put_entry_p^.subfield_number = 0 THEN
              subfield_number_string.value := 'ALL';
              subfield_number_string.size := 3;
            ELSE
              clp$convert_integer_to_string (put_entry_p^.subfield_number, 10, FALSE, subfield_number_string,
                    status);
            IFEND;

            STRINGREP (ptv$output_line, ptv$output_line_length, '     Position : ',
                  put_entry_p^.subfield_position, '  Length : ', length_string.value (1, length_string.size),
                  '  Field Number : ', subfield_number_string.value (1, subfield_number_string.size),
                  '  Field Delimiter : ''', put_entry_p^.subfield_delimiter, '''');
            cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;
        IFEND;

      PROCEND format_put_record;

?? OLDTITLE, EJECT ??

      status.normal := TRUE;

      STRINGREP (ptv$output_line, ptv$output_line_length, ' Number :', number);
      cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

      IF (ptc$name IN display_option) AND (put_entry_p^.name <> ' ') THEN
        STRINGREP (ptv$output_line, ptv$output_line_length, '   Put : ', put_entry_p^.name);
        cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      IFEND;

      IF (ptc$entries IN display_option) OR (ptc$type IN display_option) THEN
        CASE put_entry_p^.put OF

        = put_field_summary =
          format_put_field_summary (status);

        = put_interval_field, put_field =
          format_put_field (status);

        = put_string =
          format_put_string (status);

        = put_record =
          format_put_record (status);

        = push_page_header =
          format_push_page_header (status);

        = pop_page_header =
          format_pop_page_header (status);

        = put_new_page =
          format_put_new_page (status);

        ELSE
        CASEND;
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      IFEND;

      cyp$put_next_line (ptv$output_file, ' ', status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

    PROCEND format_put_display;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$get_reason_for_call (ptv$information_request, ptv$display_file, ptv$prompting_activted, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    IF NOT ptv$information_request THEN
      CASE ptv$generate OF
      = report =
        put_entry_chain_head := ptv$report_entry_chain_head_p;
      = log =
        put_entry_chain_head := ptv$log_entry_chain_head_p;
      = none =
        clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
        osp$set_status_condition (pte$generate_none_mode, status);
        RETURN; {----->
      ELSE
      CASEND;

      numbers := NIL;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_display_put, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

{ display_option

    display_option := $display_option_type [];
    value_p := pvt [p$display_option].value;
    WHILE value_p <> NIL DO
      IF value_p^.element_value^.keyword_value = 'NAME' THEN
        display_option := display_option + $display_option_type [ptc$name];
      ELSEIF value_p^.element_value^.keyword_value = 'TYPE' THEN
        display_option := display_option + $display_option_type [ptc$type];
      ELSEIF value_p^.element_value^.keyword_value = 'ENTRIES' THEN
        display_option := display_option + $display_option_type [ptc$entries];
      ELSEIF value_p^.element_value^.keyword_value = 'ALL' THEN
        display_option := $display_option_type [ptc$entries, ptc$type, ptc$name];
      IFEND;
      value_p := value_p^.link;
    WHILEND;

{ Opens output file.

    cyp$open_file (pvt [p$output].value^.file_value^, ^ptv$display_file_specifications, ptv$output_file,
          status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    errors_detected := FALSE;
    IF pvt [p$put].specified THEN

{ PUT

      IF pvt [p$put].value^.kind = clc$keyword THEN
        IF pvt [p$put].value^.keyword_value = 'ALL' THEN

{ ALL

          put_entry_p := put_entry_chain_head;
          number := 1;
          WHILE put_entry_p <> NIL DO
            format_put_display (status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            put_entry_p := put_entry_p^.put_chain_link_p;
            number := number + 1;
          WHILEND;
        IFEND;
      ELSE

{ LIST

        value_p := pvt [p$put].value;
        WHILE value_p <> NIL DO
          put_entry_p := put_entry_chain_head;
          number := 1;
          WHILE (put_entry_p <> NIL) AND (value_p^.element_value^.name_value <> put_entry_p^.name) DO
            put_entry_p := put_entry_p^.put_chain_link_p;
            number := number + 1;
          WHILEND;
          IF put_entry_p <> NIL THEN
            format_put_display (status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          ELSE
            errors_detected := TRUE;
            osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$undefined_put_for_dis,
                  value_p^.element_value^.name_value, failing_status);
            report_intermediate_error (failing_status, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            errors_detected := TRUE;
          IFEND;
          value_p := value_p^.link;
        WHILEND;
      IFEND;
      IF errors_detected THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, 'PUT', status);
      IFEND;
    ELSE

{ NUMBER

      IF pvt [p$number].value^.kind = clc$keyword THEN
        IF pvt [p$number].value^.name_value = 'LAST' THEN
          put_entry_p := put_entry_chain_head;
          WHILE put_entry_p^.put_chain_link_p <> NIL DO
            put_entry_p := put_entry_p^.put_chain_link_p;
          WHILEND;
          format_put_display (status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        ELSE

{ ALL

          put_entry_p := put_entry_chain_head;
          number := 1;
          WHILE put_entry_p <> NIL DO
            format_put_display (status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            put_entry_p := put_entry_p^.put_chain_link_p;
            number := number + 1;
          WHILEND;
        IFEND;
      ELSE

{ range

        number := 1;
        put_entry_p := put_entry_chain_head;
        WHILE put_entry_p <> NIL DO
          IF number IN numbers^ THEN
            format_put_display (status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            numbers^ := numbers^ -$numbers_set [number];
          IFEND;
          put_entry_p := put_entry_p^.put_chain_link_p;
          number := number + 1;
        WHILEND;
        IF numbers^ <> $numbers_set [] THEN
          osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, 'NUMBER',
                status);
        IFEND;
      IFEND;
      IF errors_detected THEN
        osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$error_processing_parameter, 'NUMBER', status);
      IFEND;
    IFEND;

    cyp$close_file (ptv$output_file, cyc$default_open_position, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    IF numbers <> NIL THEN
      FREE numbers;
    IFEND;

  PROCEND display_put_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'generate_report_cmd', EJECT ??

{ This procedure processes the generate_report command.

*copyc pth$anabl_generate_report

  PROCEDURE generate_report_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{    PROCEDURE (ptm$anabl_genr) generate_report, genr (
{    input, i: (CHECK) list of file = $optional
{    output, o: file = $output
{    display_format, df: (CHECK) key
{        (list, l)
{        (legible_data, ld)
{        (excel, e)
{      keyend = list
{    summarize_defined_data, sdd: (HIDDEN) boolean = false
{    display_report_header, drh: (HIDDEN) boolean = true
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 11] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type5: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 27, 13, 0, 48, 888],
    clc$command, 11, 6, 0, 0, 2, 0, 6, 'PTM$ANABL_GENR'], [
    ['DF                             ',clc$abbreviation_entry, 3],
    ['DISPLAY_FORMAT                 ',clc$nominal_entry, 3],
    ['DISPLAY_REPORT_HEADER          ',clc$nominal_entry, 5],
    ['DRH                            ',clc$abbreviation_entry, 5],
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['SDD                            ',clc$abbreviation_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 6],
    ['SUMMARIZE_DEFINED_DATA         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 19, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 229,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
    [11, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 5
    [3, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 6
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [6], [
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['EXCEL                          ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['LD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['LEGIBLE_DATA                   ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['LIST                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'list'],
{ PARAMETER 4
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 5
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$input = 1,
      p$output = 2,
      p$display_format = 3,
      p$summarize_defined_data = 4,
      p$display_report_header = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      input_log_p: ^log_file,
      length_errors: boolean,
      put_entry_p: ^put_entry,
      put_number: 1..clc$max_integer;

?? NEWTITLE := 'check_generate_report', EJECT ??

    PROCEDURE check_generate_report
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
        input_file_list: ^clt$data_value,
        input_log_list_p: ^clt$data_value;

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$input =
          report_duplicate_name (pvt [p$input].value, 'INPUT', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
{ A  variable 'input_file_list' is assigned the value of pvt [p$input].value
{ and passed as first parameter to the 'process_input_parameter' procedure
{ instead of 'pvt [p$input].value', because the 'process_input_parameter'
{ modifies the value of the first parameter.
          input_file_list := pvt [p$input].value;
          process_input_parameter (input_file_list, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;

        = p$display_format =
          IF ptv$headers_specified AND NOT (pvt[p$display_format].value^.keyword_value = 'LIST') THEN
            osp$set_status_condition (pte$headers_and_not_list, status);
          IFEND;

        ELSE
        CASEND;

      ELSEIF NOT pvt [p$input].specified THEN
        IF ptv$default_input_log_list_p = NIL THEN
          osp$set_status_condition (pte$no_input_logs, status);
        ELSE
          input_log_list_p := ptv$default_input_log_list_p;
          process_input_parameter (input_log_list_p, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;
      IFEND;

    PROCEND check_generate_report;

?? OLDTITLE ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE
{   This procedure handles interactive conditions.

{ DESIGN
{   This procedure will close the ptv$output_file

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF condition.selector = pmc$block_exit_processing THEN
        cyp$close_file (ptv$output_file, cyc$default_open_position, ignore_status);
      ELSE
        osp$set_status_from_condition ('PT', condition, save_area, status, ignore_status);
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        status.normal := TRUE;
      IFEND;

    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$get_reason_for_call (ptv$information_request, ptv$display_file, ptv$prompting_activted, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    IF NOT ptv$information_request THEN
      CASE ptv$generate OF
      = report =
      = log =
        clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
        osp$set_status_condition (pte$generate_log_mode, status);
        RETURN; {----->
      = none =
        clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
        osp$set_status_condition (pte$generate_none_mode, status);
        RETURN; {----->
      ELSE
      CASEND;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_generate_report, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    ptv$display_report_header := pvt [p$display_report_header].value^.boolean_value.value;

    ptv$excel := FALSE;
    IF pvt [p$display_format].value^.keyword_value = 'LEGIBLE_DATA' THEN
      ptv$display_format := legible_data;
    ELSEIF pvt [p$display_format].value^.keyword_value = 'EXCEL' THEN
      ptv$display_format := legible_data;
      ptv$excel := TRUE;
    ELSE
      ptv$display_format := list;
    IFEND;

    open_report_file (pvt [p$output].value^.file_value^, ptv$display_format, ptv$output_file,
          ptv$maximum_line_length, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    put_number := 1;
    length_errors := FALSE;
    put_entry_p := ptv$report_entry_chain_head_p;
    WHILE put_entry_p <> NIL DO
      IF put_entry_p^.max_used_column > ptv$maximum_line_length THEN
        IF length_errors THEN
          osp$append_status_integer (osc$status_parameter_delimiter, put_number, 10, FALSE, status);
        ELSE
          length_errors := TRUE;
          osp$set_status_abnormal (ptc$analyze_binary_log_id, pte$put_length_gt_page_width, '', status);
        IFEND;
      IFEND;
      put_entry_p := put_entry_p^.put_chain_link_p;
      put_number := put_number + 1;
    WHILEND;
    IF length_errors THEN
      RETURN; {----->
    IFEND;

    osp$establish_condition_handler (^condition_handler, TRUE);

    reset_data_collection;
    set_shadow_fields (status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    set_report_information;
    initialize_selection_values;

    IF ptv$display_format = list THEN
{ Sequence pointer reset by reset_data_collection.
      NEXT ptv$page_header_list_head_p IN ptv$data_segment_p.sequence_pointer;
      ptv$page_header_list_tail_p := ptv$page_header_list_head_p;
      ptv$page_header_list_tail_p^.fwd_p := NIL;
      ptv$page_header_list_tail_p^.bkw_p := NIL;
      ptv$page_header_list_tail_p^.default_header := TRUE;
      ptv$page_header_list_tail_p^.header_string := '';

    IFEND;

    input_log_p := ptv$input_log_chain_head_p;
    WHILE input_log_p <> NIL DO
      scan_log_genr (input_log_p, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      input_log_p := input_log_p^.log_chain_link_p;
    WHILEND;

    compute_summary (status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    print_report (status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    cyp$close_file (ptv$output_file, cyc$default_open_position, status);
    osp$disestablish_cond_handler;

  PROCEND generate_report_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'generate_log_cmd', EJECT ??

{ This procedure processes the generate_log command.

*copyc pth$anabl_generate_log

  PROCEDURE generate_log_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (ptm$anabl_genl) generate_log, genl (
{   input, i: (CHECK) list of file = $optional
{   output, o: file = $required
{   display_format, df: key
{       (list, l)
{       (legible_data, ld)
{       (binary, b)
{     keyend = legible_data
{   counter_format, cf: key
{       (fixed, f)
{       (variable, unfixed, uf, v)
{     keyend = variable
{   number_of_counters, noc: any of
{       key
{         all
{       keyend
{       integer 0..sfc$max_number_of_counters
{     anyend = all
{   descriptive_data_length, ddl: any of
{       key
{         all
{       keyend
{       integer 0..sfc$max_descriptive_data_size
{     anyend = all
{   sort_key, sk: (HIDDEN) key
{       (statistic, s)
{       (time, t)
{     keyend = time
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 15] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (12),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
        default_value: string (8),
      recend,
      type5: 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$integer_type_qualifier,
        recend,
        default_value: string (3),
      recend,
      type6: 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$integer_type_qualifier,
        recend,
        default_value: string (3),
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (4),
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 28, 12, 34, 49, 18],
    clc$command, 15, 8, 1, 0, 1, 0, 8, 'PTM$ANABL_GENL'], [
    ['CF                             ',clc$abbreviation_entry, 4],
    ['COUNTER_FORMAT                 ',clc$nominal_entry, 4],
    ['DDL                            ',clc$abbreviation_entry, 6],
    ['DESCRIPTIVE_DATA_LENGTH        ',clc$nominal_entry, 6],
    ['DF                             ',clc$abbreviation_entry, 3],
    ['DISPLAY_FORMAT                 ',clc$nominal_entry, 3],
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['NOC                            ',clc$abbreviation_entry, 5],
    ['NUMBER_OF_COUNTERS             ',clc$nominal_entry, 5],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['SK                             ',clc$abbreviation_entry, 7],
    ['SORT_KEY                       ',clc$nominal_entry, 7],
    ['STATUS                         ',clc$nominal_entry, 8]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 19, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 12],
{ PARAMETER 4
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 6
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 7
    [14, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 8
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [6], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['BINARY                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['LD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['LEGIBLE_DATA                   ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['LIST                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'legible_data'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [6], [
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['FIXED                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['UF                             ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['UNFIXED                        ', clc$alias_entry, clc$normal_usage_entry, 2],
    ['V                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['VARIABLE                       ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'variable'],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, sfc$max_number_of_counters, 10]]
    ,
    'all'],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, sfc$max_descriptive_data_size, 10]]
    ,
    'all'],
{ PARAMETER 7
    [[1, 0, clc$keyword_type], [4], [
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['STATISTIC                      ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['T                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TIME                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'time'],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$input = 1,
      p$output = 2,
      p$display_format = 3,
      p$counter_format = 4,
      p$number_of_counters = 5,
      p$descriptive_data_length = 6,
      p$sort_key = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    VAR
      access_information: [STATIC] array [1 .. 1] of amt$access_info := [
            {} [ * { item_returned } , amc$previous_record_address { key } , * { previous_record_address } ]],
      file_attributes: array [1 .. 1] of amt$get_item,
      local_file: boolean,
      contains_data: boolean,
      old_file: boolean,
      ignore_status: ost$status,
      input_log_p: ^log_file,
      sort_key: (statistic, time);

?? NEWTITLE := 'check_generate_log', EJECT ??

    PROCEDURE check_generate_log
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
        input_file_list: ^clt$data_value,
        input_log_list_p: ^clt$data_value;

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$input =
          report_duplicate_name (pvt [p$input].value, 'INPUT', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
{ A  variable 'input_file_list' is assigned the value of pvt [p$input].value
{ and passed as first parameter to the 'process_input_parameter' procedure
{ instead of 'pvt [p$input].value', because the 'process_input_parameter'
{ modifies the value of the first parameter.
          input_file_list := pvt [p$input].value;
          process_input_parameter (input_file_list, status);
        ELSE
        CASEND;
      ELSEIF NOT pvt [p$input].specified THEN
        IF ptv$default_input_log_list_p = NIL THEN
          osp$set_status_condition (pte$no_input_logs, status);
        ELSE
          input_log_list_p := ptv$default_input_log_list_p;
          process_input_parameter (input_log_list_p, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;
      IFEND;

    PROCEND check_generate_log;

?? OLDTITLE ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE
{   This procedure handles interactive conditions.

{ DESIGN
{   This procedure will close the ptv$output_file

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF condition.selector = pmc$block_exit_processing THEN
        CASE ptv$display_format OF
        = legible_data, list =
          cyp$close_file (ptv$output_file, cyc$default_open_position, ignore_status);
        = binary =
          amp$set_segment_eoi (ptv$output_log_p^.file_identifier, ptv$end_of_segment, ignore_status);
          fsp$close_file (ptv$output_log_p^.file_identifier, ignore_status);
        ELSE
        CASEND;
        osp$set_status_from_condition ('PT', condition, save_area, status, ignore_status);
      ELSE
        osp$set_status_from_condition ('PT', condition, save_area, status, ignore_status);
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        status.normal := TRUE;
      IFEND;

    PROCEND condition_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$get_reason_for_call (ptv$information_request, ptv$display_file, ptv$prompting_activted, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    IF NOT ptv$information_request THEN
      CASE ptv$generate OF
      = report =
        clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
        osp$set_status_condition (pte$generate_report_mode, status);
        RETURN; {----->
      = log =
      = none =
        clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
        osp$set_status_condition (pte$generate_none_mode, status);
        RETURN; {----->
      ELSE
      CASEND;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_generate_log, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

{ counter_format

    IF pvt [p$counter_format].value^.keyword_value = 'FIXED' THEN
      ptv$number_of_counters.fixed_format := TRUE;
    ELSE
      ptv$number_of_counters.fixed_format := FALSE;
    IFEND;

{ number_of_counters

    IF pvt [p$number_of_counters].value^.kind = clc$integer THEN
      ptv$number_of_counters.float := FALSE;
      ptv$number_of_counters.number := pvt [p$number_of_counters].value^.integer_value.value;
    ELSE { clc$keyword }
      ptv$number_of_counters.float := TRUE;
    IFEND;

{ descriptive_data_length

    IF pvt [p$descriptive_data_length].value^.kind = clc$integer THEN
      ptv$descriptive_data_size.float := FALSE;
      ptv$descriptive_data_size.number := pvt [p$descriptive_data_length].value^.integer_value.value;
    ELSE { clc$keyword }
      ptv$descriptive_data_size.float := TRUE;
    IFEND;

{ sort_key

    IF pvt [p$sort_key].value^.keyword_value = 'STATISTIC' THEN
      sort_key := statistic;
    ELSE
      sort_key := time;
    IFEND;

{ The following calls get the output format, output file name and opens the output file.

{ display_format

    IF pvt [p$display_format].value^.keyword_value = 'LEGIBLE_DATA' THEN
      ptv$display_format := legible_data;
    ELSEIF pvt [p$display_format].value^.keyword_value = 'LIST' THEN
      ptv$display_format := list;
    ELSE
      ptv$display_format := binary;
    IFEND;

    CASE ptv$display_format OF
    = legible_data, list =

      open_report_file (pvt [p$output].value^.file_value^, ptv$display_format, ptv$output_file,
            ptv$maximum_line_length, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      IF ptv$display_format = list THEN
        set_counter_length;
{ Sequence pointer reset by reset_data_collection.
        NEXT ptv$page_header_list_head_p IN ptv$data_segment_p.sequence_pointer;
        ptv$page_header_list_tail_p := ptv$page_header_list_head_p;
        ptv$page_header_list_tail_p^.fwd_p := NIL;
        ptv$page_header_list_tail_p^.bkw_p := NIL;
        ptv$page_header_list_tail_p^.default_header := TRUE;
        ptv$page_header_list_tail_p^.header_string := '';
      IFEND;

    = binary =
      ALLOCATE ptv$output_log_p: [#SIZE (pvt [p$output].value^.file_value^)];
      ptv$output_log_p^.log_file_name := pvt [p$output].value^.file_value^;
      open_log_file (ptv$output_log_p, TRUE, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      ptv$end_of_segment := ptv$output_log_p^.segment_pointer;
      amp$fetch_access_information (ptv$output_log_p^.file_identifier, access_information, status);
      IF NOT status.normal THEN
        fsp$close_file (ptv$output_log_p^.file_identifier, ignore_status);
        RETURN; {----->
      IFEND;
      ptv$previous_header_fba := access_information [1].previous_record_address;
    ELSE
    CASEND;
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    osp$establish_condition_handler (^condition_handler, TRUE);

    input_log_p := ptv$input_log_chain_head_p;
    WHILE input_log_p <> NIL DO

      CASE ptv$display_format OF

      = legible_data =
        scan_log_genl (input_log_p, ^write_statistic_to_legible_log, status);

      = list =
        cyp$put_next_line (ptv$output_file, ' ', status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        STRINGREP (ptv$output_line, ptv$output_line_length, 'Log scanned: ', input_log_p^.log_file_name);
        cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        scan_log_genl (input_log_p, ^write_statistic_to_list_log, status);

      = binary =
        scan_log_genl (input_log_p, ^write_statistic_to_binary_log, status);

      ELSE
      CASEND;
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      input_log_p := input_log_p^.log_chain_link_p;
    WHILEND;

    CASE ptv$display_format OF
    = legible_data, list =
      cyp$close_file (ptv$output_file, cyc$default_open_position, status);
    = binary =
      amp$set_segment_eoi (ptv$output_log_p^.file_identifier, ptv$output_log_p^.segment_pointer, status);
      fsp$close_file (ptv$output_log_p^.file_identifier, status);
    ELSE
    CASEND;
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND generate_log_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'change_defaults_cmd', EJECT ??

{ This procedure processes the change_defaults command.

  PROCEDURE change_defaults_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{      PROCEDURE (ptm$anabl_chad) change_defaults, chad (
{      counter_fraction, cf: any of
{          key
{            default
{          keyend
{          integer 0..clc$max_integer
{        anyend = $optional
{      date_time_format, dtf: any of
{          key
{            default
{          keyend
{          string
{        anyend = $optional
{      input_log, log, il, l: (CHECK) any of
{          key
{            unspecified
{          keyend
{          list of file
{        anyend = $optional
{      legible_data_max_page_width, ldmpw: any of
{          key
{            default
{          keyend
{          integer 1..ptc$max_page_width
{        anyend = $optional
{      list_max_page_width, lmpw: any of
{          key
{            default
{          keyend
{          integer 1..ptc$max_page_width
{        anyend = $optional
{      time_increment_format, tif: key
{          (seconds s)
{          (time_increment, ti)
{          default
{        keyend = $optional
{      status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 15] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] 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$integer_type_qualifier,
        recend,
      recend,
      type2: 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$string_type_qualifier,
        recend,
      recend,
      type3: 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,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type4: 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$integer_type_qualifier,
        recend,
      recend,
      type5: 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$integer_type_qualifier,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 27, 13, 2, 27, 522],
    clc$command, 15, 7, 0, 0, 0, 0, 7, 'PTM$ANABL_CHAD'], [
    ['CF                             ',clc$abbreviation_entry, 1],
    ['COUNTER_FRACTION               ',clc$nominal_entry, 1],
    ['DATE_TIME_FORMAT               ',clc$nominal_entry, 2],
    ['DTF                            ',clc$abbreviation_entry, 2],
    ['IL                             ',clc$alias_entry, 3],
    ['INPUT_LOG                      ',clc$nominal_entry, 3],
    ['L                              ',clc$abbreviation_entry, 3],
    ['LDMPW                          ',clc$abbreviation_entry, 4],
    ['LEGIBLE_DATA_MAX_PAGE_WIDTH    ',clc$nominal_entry, 4],
    ['LIST_MAX_PAGE_WIDTH            ',clc$nominal_entry, 5],
    ['LMPW                           ',clc$abbreviation_entry, 5],
    ['LOG                            ',clc$alias_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 7],
    ['TIF                            ',clc$abbreviation_entry, 6],
    ['TIME_INCREMENT_FORMAT          ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 72, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 83, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84, clc$optional_parameter,
  0, 0],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [0, clc$max_integer, 10]]
    ],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$string_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    8, [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['UNSPECIFIED                    ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    19, [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$file_type]]
      ]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, ptc$max_page_width, 10]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, ptc$max_page_width, 10]]
    ],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [5], [
    ['DEFAULT                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SECONDS                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['TI                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['TIME_INCREMENT                 ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$counter_fraction = 1,
      p$date_time_format = 2,
      p$input_log = 3,
      p$legible_data_max_page_width = 4,
      p$list_max_page_width = 5,
      p$time_increment_format = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

    VAR
      input_data_value_p: ^clt$data_value,
      save_data_value_p: ^clt$data_value,
      input_log_p: ^clt$data_value,
      next_input_log_p: ^clt$data_value;

?? NEWTITLE := 'check_change_defaults', EJECT ??

    PROCEDURE check_change_defaults
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$input_log =
          IF pvt [p$input_log].value^.kind <> clc$keyword THEN
{  Must be a list of files.
            report_duplicate_name (pvt [p$input_log].value, 'INPUT', status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
          IFEND;
        ELSE
        CASEND;
      IFEND;

    PROCEND check_change_defaults;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_change_defaults, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

{  Counter fraction

   IF pvt [p$counter_fraction].specified THEN
     IF pvt [p$counter_fraction].value^.kind = clc$keyword THEN
{  Only keyword is default
       ptv$counter_fraction := ptc$default_counter_fraction;
     ELSE
       ptv$counter_fraction := pvt [p$counter_fraction].value^.integer_value.value;
     IFEND;
   IFEND;

{  Date time format

   IF pvt [p$date_time_format].specified THEN
     IF pvt [p$date_time_format].value^.kind = clc$keyword THEN
{  Only keyword is default
       ptv$date_time_format := ptc$default_date_time_format;
     ELSE
       ptv$date_time_format := pvt [p$date_time_format].value^.string_value^;
     IFEND;
   IFEND;

{  Input Log

   IF pvt [p$input_log].specified THEN

{    FREE all input logs in list for all specified values of input_log

     input_log_p := ptv$default_input_log_list_p;
     ptv$default_input_log_list_p := NIL;
     WHILE input_log_p <> NIL DO
       next_input_log_p := input_log_p^.link;
       FREE input_log_p^.element_value^.file_value;
       FREE input_log_p^.element_value;
       FREE input_log_p;
       input_log_p := next_input_log_p;
     WHILEND;

     IF pvt [p$input_log].value^.kind <> clc$keyword THEN

{  Only keyword is 'UNSPECIFIED'.
{  If not 'UNSPECIFIED', then copy input list of logs to saved list of logs.

       IF pvt [p$input_log].value <> NIL THEN
{  ALLOCATE first input_log file entry
         ALLOCATE ptv$default_input_log_list_p;
         ptv$default_input_log_list_p^ := pvt [p$input_log].value^;
         ptv$default_input_log_list_p^.link := NIL;
         ALLOCATE ptv$default_input_log_list_p^.element_value;
         ptv$default_input_log_list_p^.element_value^ := pvt [p$input_log].value^.element_value^;
         ALLOCATE ptv$default_input_log_list_p^.element_value^.file_value:
             [#SIZE (pvt [p$input_log].value^.element_value^.file_value^)];
         ptv$default_input_log_list_p^.element_value^.file_value^ :=
               pvt [p$input_log].value^.element_value^.file_value^;
       IFEND;
{  Point to second input_log file entry, if there is one
       input_data_value_p := pvt [p$input_log].value^.link;
{  Point to first saved input_log file entry
       save_data_value_p := ptv$default_input_log_list_p;
       WHILE input_data_value_p <> NIL DO
{  ALLOCATE next saved input_log file entry
         ALLOCATE save_data_value_p^.link;
         save_data_value_p := save_data_value_p^.link;
         save_data_value_p^ := input_data_value_p^;
         ALLOCATE save_data_value_p^.element_value;
         save_data_value_p^.element_value^ := input_data_value_p^.element_value^;
         ALLOCATE save_data_value_p^.element_value^.file_value:
             [#SIZE (input_data_value_p^.element_value^.file_value^)];
         save_data_value_p^.element_value^.file_value^ :=
               input_data_value_p^.element_value^.file_value^;
         input_data_value_p := input_data_value_p^.link;
       WHILEND;

     IFEND;
   IFEND;

{  Legible Data Max Page Width

   IF pvt [p$legible_data_max_page_width].specified THEN
     IF pvt [p$legible_data_max_page_width].value^.kind = clc$keyword THEN
{  Only keyword is default
       ptv$legible_data_max_page_width := ptc$max_page_width;
     ELSE
       ptv$legible_data_max_page_width := pvt [p$legible_data_max_page_width].value^.integer_value.value;
     IFEND;
   IFEND;

{  List Max Page Width

   IF pvt [p$list_max_page_width].specified THEN
     IF pvt [p$list_max_page_width].value^.kind = clc$keyword THEN
{  Only keyword is default
       ptv$list_max_page_width := cyc$wide_page_width;
     ELSE
       ptv$list_max_page_width := pvt [p$list_max_page_width].value^.integer_value.value;
     IFEND;
   IFEND;

{  Time Increment format

   IF pvt [p$time_increment_format].specified THEN
     IF pvt [p$time_increment_format].value^.keyword_value = ptc$key_default THEN
       ptv$time_increment_format := ptc$default_time_inc_format;
     ELSE
       ptv$time_increment_format := pvt [p$time_increment_format].value^.keyword_value;
     IFEND;
   IFEND;

  PROCEND change_defaults_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'display_defaults_cmd', EJECT ??

{ This procedure processes the display_defaults command.

  PROCEDURE display_defaults_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{      PROCEDURE (ptm$anabl_disd) display_defaults, disd (
{      display_option, do: list of key
{        (counter_fraction, cf)
{        (date_time_format, dtf)
{        (input_log, log, il, l)
{        (legible_data_max_page_width, ldmpw)
{        (list_max_page_width, lmpw)
{        (time_increment_format, tif)
{        all
{      keyend = all
{      output, o: file = $output
{      status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 15] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 27, 13, 3, 21, 910],
    clc$command, 5, 3, 0, 0, 0, 0, 3, 'PTM$ANABL_DISD'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 1],
    ['DO                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 578,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [562, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [15], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 7],
      ['CF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['COUNTER_FRACTION               ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['DATE_TIME_FORMAT               ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['DTF                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['IL                             ', clc$alias_entry, clc$normal_usage_entry, 3],
      ['INPUT_LOG                      ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['L                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['LDMPW                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['LEGIBLE_DATA_MAX_PAGE_WIDTH    ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['LIST_MAX_PAGE_WIDTH            ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['LMPW                           ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['LOG                            ', clc$alias_entry, clc$normal_usage_entry, 3],
      ['TIF                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['TIME_INCREMENT_FORMAT          ', clc$nominal_entry, clc$normal_usage_entry, 6]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$display_option = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

      VAR
        date_time_string_length: integer,
        input_log_p: ^clt$data_value,
        value_p: ^clt$data_value;

    status.normal := TRUE;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

{ Open output file.

    cyp$open_file (pvt [p$output].value^.file_value^, ^ptv$display_file_specifications, ptv$output_file,
          status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    ptv$maximum_line_length := cyp$page_width (ptv$output_file);
    IF ptv$maximum_line_length > 132 THEN
      ptv$maximum_line_length := 132;
    IFEND;

{  Put Label

    cyp$put_next_line (ptv$output_file, ' ANABL Default Values: ', status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    value_p := pvt [p$display_option].value;
    WHILE value_p <> NIL DO

{  Counter Fraction
      IF (value_p^.element_value^.keyword_value = 'ALL') OR
         (value_p^.element_value^.keyword_value = 'COUNTER_FRACTION') THEN
        STRINGREP (ptv$output_line, ptv$output_line_length, '         Counter Fraction : ',
              ptv$counter_fraction);
        cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      IFEND;

{  Date Time Format
      IF (value_p^.element_value^.keyword_value = 'ALL') OR
         (value_p^.element_value^.keyword_value = 'DATE_TIME_FORMAT') THEN
        date_time_string_length := clp$trimmed_string_size (ptv$date_time_format);
        STRINGREP (ptv$output_line, ptv$output_line_length, '         Date Time Format : ',
              ptv$date_time_format(1, date_time_string_length));
        cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      IFEND;

{  Legible Data Max Page Width
      IF (value_p^.element_value^.keyword_value = 'ALL') OR
         (value_p^.element_value^.keyword_value = 'LEGIBLE_DATA_MAX_PAGE_WIDTH') THEN
        STRINGREP (ptv$output_line, ptv$output_line_length, '    Legible data max page width : ',
              ptv$legible_data_max_page_width);
        cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      IFEND;

{  List Max Page Width
      IF (value_p^.element_value^.keyword_value = 'ALL') OR
         (value_p^.element_value^.keyword_value = 'LIST_MAX_PAGE_WIDTH') THEN
        STRINGREP (ptv$output_line, ptv$output_line_length, '    List max page width : ',
              ptv$list_max_page_width);
        cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      IFEND;

{  Time Increment Format
      IF (value_p^.element_value^.keyword_value = 'ALL') OR
         (value_p^.element_value^.keyword_value = 'TIME_INCREMENT_FORMAT') THEN
        STRINGREP (ptv$output_line, ptv$output_line_length, '    Time Increment Format : ',
              ptv$time_increment_format);
        cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      IFEND;

{  Input Log list
      IF (value_p^.element_value^.keyword_value = 'ALL') OR
         (value_p^.element_value^.keyword_value = 'INPUT_LOG') THEN
        IF ptv$default_input_log_list_p = NIL THEN
          cyp$put_next_line (ptv$output_file,'    Input Log List        : UNSPECIFIED' , status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        ELSE
          cyp$put_next_line (ptv$output_file,'    Input Log List        : ' , status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
          input_log_p := ptv$default_input_log_list_p;
          WHILE input_log_p <> NIL DO
            cyp$put_next_line (ptv$output_file, input_log_p^.element_value^.file_value^, status);
            IF NOT status.normal THEN
              RETURN; {----->
            IFEND;
            input_log_p := input_log_p^.link;
          WHILEND;
        IFEND;
      IFEND;

{  Max Report Page Width
{     IF (value_p^.element_value^.keyword_value = 'ALL') OR
{        (value_p^.element_value^.keyword_value = 'MAX_REPORT_PAGE_WIDTH') THEN
{       STRINGREP (ptv$output_line, ptv$output_line_length, '    Max Report Page Width : ',
{             ptv$max_report_page_width);
{       cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
{       IF NOT status.normal THEN
{         RETURN; {----->
{       IFEND;
{     IFEND;

      value_p := value_p^.link;
    WHILEND;

{  Close output file

    cyp$close_file (ptv$output_file, cyc$default_open_position, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

  PROCEND display_defaults_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'display_logged_statistics_cmd', EJECT ??

{ This procedure processes the  DISPLAY_LOGGED_STATISTICS  command.

*copyc pth$anabl_display_logged_stat

  PROCEDURE display_logged_statistics_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (ptm$anabl_disls) display_logged_statistics, disls (
{   input, i: (CHECK) list of file = $optional
{   output, o: file = $output
{   display_option, do: key
{       (name, names, n)
{       all
{     keyend = names
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 28, 12, 39, 23, 74],
    clc$command, 7, 4, 0, 0, 0, 0, 4, 'PTM$ANABL_DISLS'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 3],
    ['DO                             ',clc$abbreviation_entry, 3],
    ['I                              ',clc$abbreviation_entry, 1],
    ['INPUT                          ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$extended_parameter_checking, 19, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['N                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['NAME                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['NAMES                          ', clc$alias_entry, clc$normal_usage_entry, 1]]
    ,
    'names'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$input = 1,
      p$output = 2,
      p$display_option = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    CONST
      full_header_1 = 'statistic    number of    first occurrence      last occurrence',
      full_header_2 = '  code      occurrences    date       time      date       time',
      header_1 = 'statistic',
      header_2 = '  code';

    VAR
      date_time_string_1: ost$string,
      date_time_string_2: ost$string,
      found: boolean,
      full: boolean,
      input_log_p: ^log_file,
      logged_statistic_chain_tail: ^logged_statistic,
      logged_statistic_1_p: ^logged_statistic,
      logged_statistic_2_p: ^logged_statistic,
      page_length: integer,
      statistic_name: ost$name;

?? NEWTITLE := 'check_display_logged_stat', EJECT ??

    PROCEDURE check_display_logged_stat
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      VAR
        input_file_list: ^clt$data_value,
        input_log_list_p: ^clt$data_value;

      status.normal := TRUE;

      IF which_parameter.specific THEN
        CASE which_parameter.number OF
        = p$input =
          report_duplicate_name (pvt [p$input].value, 'INPUT', status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
{ A  variable 'input_file_list' is assigned the value of pvt [p$input].value
{ and passed as first parameter to the 'process_input_parameter' procedure
{ instead of 'pvt [p$input].value', because the 'process_input_parameter'
{ modifies the value of the first parameter.
          input_file_list := pvt [p$input].value;
          process_input_parameter (input_file_list, status);
        ELSE
        CASEND;
      ELSEIF NOT pvt [p$input].specified THEN
        IF ptv$default_input_log_list_p = NIL THEN
          osp$set_status_condition (pte$no_input_logs, status);
        ELSE
          input_log_list_p := ptv$default_input_log_list_p;
          process_input_parameter (input_log_list_p, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;
      IFEND;

    PROCEND check_display_logged_stat;

?? OLDTITLE ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE
{   This procedure handles interactive conditions.

{ DESIGN
{   This procedure will close the ptv$output_file

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF condition.selector = pmc$block_exit_processing THEN
        cyp$close_file (ptv$output_file, cyc$default_open_position, ignore_status);
      ELSE
        osp$set_status_from_condition ('PT', condition, save_area, status, ignore_status);
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
        status.normal := TRUE;
      IFEND;

    PROCEND condition_handler;

?? OLDTITLE ??
?? NEWTITLE := 'display_new_page_header', EJECT ??

    PROCEDURE display_new_page_header
      (VAR status: ost$status);

      status.normal := TRUE;

      IF full THEN
        cyp$put_next_line (ptv$output_file, full_header_1, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        cyp$put_next_line (ptv$output_file, full_header_2, status);
      ELSE
        cyp$put_next_line (ptv$output_file, header_1, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        cyp$put_next_line (ptv$output_file, header_2, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;

    PROCEND display_new_page_header;


?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_display_logged_stat, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

{ Opens output file.

    cyp$open_file (pvt [p$output].value^.file_value^, ^ptv$display_file_specifications, ptv$output_file,
          status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    osp$establish_condition_handler (^condition_handler, TRUE);

{ cyp$put_next_line (ptv$output_file, pvt [p$output].value^.file_value^, status);

    page_length := cyp$display_page_length (ptv$output_file);

    full := pvt [p$display_option].value^.keyword_value = 'ALL';

    IF ptv$logged_statistic_chain_head = NIL THEN
      input_log_p := ptv$input_log_chain_head_p;
      WHILE input_log_p <> NIL DO
        IF input_log_p^.statistics_list_p = NIL THEN
          scan_log_disls (input_log_p, status);
          IF NOT status.normal THEN
            RETURN; {----->
          IFEND;
        IFEND;
        logged_statistic_1_p := input_log_p^.statistics_list_p;
        WHILE logged_statistic_1_p <> NIL DO
          logged_statistic_2_p := ptv$logged_statistic_chain_head;
          found := FALSE;
          WHILE (logged_statistic_2_p <> NIL) AND NOT found DO
            IF logged_statistic_1_p^.statistic_code = logged_statistic_2_p^.statistic_code THEN
              logged_statistic_2_p^.number_of_occurrences := logged_statistic_2_p^.number_of_occurrences +
                    logged_statistic_1_p^.number_of_occurrences;

              IF date_time_1_gt_date_time_2 (logged_statistic_2_p^.time_of_first_occurrences,
                    logged_statistic_1_p^.time_of_first_occurrences) THEN
                logged_statistic_2_p^.time_of_first_occurrences :=
                      logged_statistic_1_p^.time_of_first_occurrences;
              IFEND;
              IF date_time_1_gt_date_time_2 (logged_statistic_1_p^.time_of_last_occurrences,
                    logged_statistic_2_p^.time_of_last_occurrences) THEN
                logged_statistic_2_p^.time_of_last_occurrences :=
                      logged_statistic_1_p^.time_of_last_occurrences;
              IFEND;
              found := TRUE;
            IFEND;
            logged_statistic_2_p := logged_statistic_2_p^.link_p;
          WHILEND;
          IF NOT found THEN
            IF ptv$logged_statistic_chain_head = NIL THEN
              ALLOCATE ptv$logged_statistic_chain_head;
              logged_statistic_chain_tail := ptv$logged_statistic_chain_head;
            ELSE
              ALLOCATE logged_statistic_chain_tail^.link_p;
              logged_statistic_chain_tail := logged_statistic_chain_tail^.link_p;
            IFEND;
            logged_statistic_chain_tail^ := logged_statistic_1_p^;
            logged_statistic_chain_tail^.link_p := NIL;
          IFEND;
          logged_statistic_1_p := logged_statistic_1_p^.link_p;
        WHILEND;
        input_log_p := input_log_p^.log_chain_link_p;
      WHILEND;
    IFEND;

    IF ptv$logged_statistic_chain_head <> NIL THEN
      sort_list_by_statistic_code (ptv$logged_statistic_chain_head);
    IFEND;

    display_new_page_header (status);

{ STRINGREP (ptv$output_line, ptv$output_line_length,' ', cyp$file_connected_to_terminal(ptv$output_file));
{ cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);

    logged_statistic_1_p := ptv$logged_statistic_chain_head;
    WHILE logged_statistic_1_p <> NIL DO

{     IF not cyp$file_connected_to_terminal(ptv$output_file) THEN

      IF pvt [p$output].value^.file_value^ <> ':$LOCAL.$OUTPUT.1' THEN
        IF cyp$current_display_line (ptv$output_file) >= page_length THEN
          display_new_page_header (status);
        IFEND;
      IFEND;
      sfp$convert_stat_code_to_name (logged_statistic_1_p^.statistic_code, statistic_name, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      IF full THEN
        ptv$clt_date_time.value := logged_statistic_1_p^.time_of_first_occurrences;
        clp$convert_date_time_to_string (ptv$clt_date_time, ptv$date_time_format, date_time_string_1, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        ptv$clt_date_time.value := logged_statistic_1_p^.time_of_last_occurrences;
        clp$convert_date_time_to_string (ptv$clt_date_time, ptv$date_time_format, date_time_string_2, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
        STRINGREP (ptv$output_line, ptv$output_line_length, ' ', statistic_name (1, 7), '    ',
              logged_statistic_1_p^.number_of_occurrences: 11, '  ', date_time_string_1.
              value (1, date_time_string_1.size): date_time_string_1.size, '  ', date_time_string_2.
              value (1, date_time_string_2.size): date_time_string_2.size);
      ELSE
        STRINGREP (ptv$output_line, ptv$output_line_length, ' ', statistic_name (1, 7));
      IFEND;
      cyp$put_next_line (ptv$output_file, ptv$output_line (1, ptv$output_line_length), status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      logged_statistic_1_p := logged_statistic_1_p^.link_p;
    WHILEND;

    cyp$close_file (ptv$output_file, cyc$default_open_position, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND display_logged_statistics_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'quit_cmd', EJECT ??

{ This procedure processes the QUIT command.  It ends the command file scan by the SCL interpreter and causes
{ ANALYZE_BINARY_LOG to terminate.

  PROCEDURE quit_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ptm$anabl_qui) quit, qui (status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 9, 29, 11, 25, 30, 154], clc$command, 1, 1, 0, 0, 0, 0, 1, 'PTM$ANABL_QUI'],
            [['STATUS                         ', clc$nominal_entry, 1]], [
{ PARAMETER 1
      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    clp$end_include (ptc$utility_name, status);

  PROCEND quit_cmd;

?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'analyze_binary_log Main Program', EJECT ??

{ Main program

  PROGRAM ptp$_analyze_binary_log
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      utility_attributes: [STATIC] array [1 .. 2] of clt$utility_attribute :=
            [[clc$utility_command_table, * ], [clc$utility_prompt, [3, 'ABL']]];

{  PROCEDURE (ptm$anabl) analyze_binary_log, anabl (status)

?? 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,
      recend,
    recend := [
    [1,
    [89, 6, 28, 12, 45, 0, 241],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'PTM$ANABL'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      unique_name: ost$name;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    get_date_time_format;
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    get_time_increment_format (status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_none, ptv$predecessor_log_p, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_none, ptv$data_segment_p, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

{ The following call adds the utility command table to the SCL command list.

    utility_attributes [1].command_table := anabl_cmd_table;

    clp$begin_utility (ptc$utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    clp$include_file (clc$current_command_input, '', ptc$utility_name, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    clp$end_utility (ptc$utility_name, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    mmp$delete_scratch_segment (ptv$predecessor_log_p, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

    mmp$delete_scratch_segment (ptv$data_segment_p, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;

  PROCEND ptp$_analyze_binary_log;

MODEND ptm$analyze_binary_log;
*DECK DECK=PTM$ANALYZE_BINARY_LOG_PD EXPAND=TRUE
create_program_description name=(analyze_binary_log anabl) sp=ptp$_analyze_binary_log ..
      l=('$system.osf$system_library' osf$task_services_library '$system.common.mlf$library') ..
      tel=warning lmo=none lm=$null dm=off
*DECK DECK=PTM$CHANGE_SCHEDULING_ATTRIB EXPAND=TRUE
PROCEDURE change_scheduling_attributes, chasa (
  class_names, cn: (by_name) list of name = $optional
  cpu_dispatching_allocation, cda: (by_name) any of
        key default keyend
        record
          dispatching_priority: range of key p1 p2 p3 p4 p5 p6 p7 p8 keyend
          minimum_percent: integer 0..100 = $optional
          maximum_percent: integer 0..100 = $optional
          enforce_maximum: boolean = $optional
        recend
      anyend = $optional
  cpu_dispatching_interval, cdi: (by_name) integer 1..600 = $optional
  dispatching_control, dc: (by_name) any of
        key default keyend
        list 1..5 of record
          dispatching_priority: key default p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 keyend
          service_time: any of
            key unlimited keyend
            integer
           anyend = $optional
          minor_timeslice: integer = $optional
          major_timeslice: integer = $optional
         recend
      anyend = $optional
  guaranteed_service_quantum, gsq: (by_name) integer = $optional
  immediate_initiation_candidate, iic: (by_name) boolean = $optional
  initial_service_class, isc: (by_name) name = $optional
  initiation_level, il: (by_name) integer = $optional
  maximum_active_jobs, maxaj, maj: (by_name) integer = $optional
  maximum_working_set, maxws: (by_name) integer = $optional
  minimum_working_set, minws: (by_name) integer = $optional
  page_aging_interval, pai: (by_name) integer = $optional
  scheduling_priority, schp: (by_name) any of
        key default keyend
        record
          minimum: integer = $optional
          maximum: integer = $optional
          swap_age_increment: integer = $optional
          ready_task_increment: integer = $optional
        recend
      anyend = $optional
  selection_priority, selp: (by_name) any of
        key default keyend
        record
          initial: integer = $optional
          maximum: integer = $optional
          increment: integer = $optional
        recend
      anyend = $optional
  status)

  VAR
    service_class_attributes: list of string = ..
       ('dispatching_control', 'guaranteed_service_quantum', 'maximum_active_jobs', 'scheduling_priority')
    job_class_attributes: list of string = ..
       ('immediate_initiation_candidate', 'initial_service_class', 'initiation_level', 'minimum_working_set', ..
        'page_aging_interval', 'selection_priority', 'maximum_working_set')
    all_attributes: list of string = $join(service_class_attributes, job_class_attributes)
    controls: list of string = ('cpu_dispatching_allocation', 'cpu_dispatching_interval')
  VAREND

  check_parameters: ..
  FOR EACH attribute IN all_attributes DO
    IF $specified($data_name(attribute)) THEN
      IF NOT $specified(class_names) THEN
        EXIT_PROC WITH $status(FALSE, 'PT', 0, 'Must specify CLASS_NAMES parameter with attributes.')
      ELSE
        EXIT check_parameters
      IFEND
    IFEND
  FOREND check_parameters

  manage_active_scheduling
    IF $specified(class_names) THEN
      FOR EACH class_name IN $parameter_value(class_names) DO
        display_value v='-- Changing '//class_name//' scheduling attributes...' o=$response
        FOR EACH attribute IN job_class_attributes DO
          IF $specified($data_name(attribute)) THEN
            display_value v='         '//attribute//' = '//$parameter($data_name(attribute)) o=$response
            include_command c='change_job_class cn=class_name '//attribute//'='//$parameter($data_name(attribute))
          IFEND
        FOREND
        FOR EACH attribute IN service_class_attributes DO
          IF $specified($data_name(attribute)) THEN
            display_value v='         '//attribute//' = '//$parameter($data_name(attribute)) o=$response
            include_command c='change_service_class cn=class_name '//attribute//'='//$parameter($data_name(attribute))
          IFEND
        FOREND
      FOREND
    IFEND
    FOR EACH control IN controls DO
      IF $specified($data_name(control)) THEN
        display_value v='-- Changing '//$name(control)//' to '//$parameter($data_name(control))  o=$response
        include_command c='change_controls '//control//'='//$parameter($data_name(control))
      IFEND
    FOREND
  quit save_change=true

PROCEND change_scheduling_attributes

*DECK DECK=PTM$CREATE_BENCHMARK_ENVIRONMNT EXPAND=TRUE
PROC create_benchmark_environment, crebe (
  family_name, fn       : name = $required
  nos_family_name, nfn  : name = nve
  user_name, un         : name = eval
  password, pw          : name = evalx
  maintenance_limit, ml : integer 0 .. 999 = 25
  set_limits, sl        : boolean = true
  status)


  crev ignore k=status

  display_value '-- BEGIN create_benchmark_environment.'

  display_value '--   Adding performance and benchmark command libraries to command list.'
  set_command_list d=$system.performance_tools.ptf$benchmark_command_library status=ignore
  set_command_list a=$system.performance_tools.ptf$benchmark_command_library
  set_command_list d=$system.performance_tools.ptf$command_library status=ignore
  set_command_list a=$system.performance_tools.ptf$command_library

  display_value '--   Attaching SMF$LIBRARY.'
  detach_file $system.sort.smf$library status=ignore
  detach_file smf$library status=ignore
  attach_file $system.sort.smf$library

  display_value '--   Creating performance variables.'
  IF $variable(ptv$family_name, declared) = 'UNKNOWN' THEN
    crev ptv$family_name k=string s=job
  ELSE
    crev ptv$family_name k=string s=xref
  IFEND
  ptv$family_name = $string($value(family_name))
  IF $variable(ptv$user_name, declared) = 'UNKNOWN' THEN
    crev ptv$user_name k=string s=job
  ELSE
    crev ptv$user_name k=string s=xref
  IFEND
  ptv$user_name = $string($value(user_name))
  IF $variable(ptv$password, declared) = 'UNKNOWN' THEN
    crev ptv$password k=string s=job
  ELSE
    crev ptv$password k=string s=xref
  IFEND
  ptv$password = $string($value(password))
  IF $variable(ptv$batch_and_ia_limits_at_0, declared) = 'UNKNOWN' THEN
    crev ptv$batch_and_ia_limits_at_0 k=boolean s=job value=false
  ELSE
    crev ptv$batch_and_ia_limits_at_0 k=boolean s=xref
  IFEND
  IF $variable(ptv$nos_family_name, declared) = 'UNKNOWN' THEN
    crev ptv$nos_family_name k=string s=job
  ELSE
    crev ptv$nos_family_name k=string s=xref
  IFEND
  ptv$nos_family_name = $string($value(nos_family_name))
  IF $variable(ptv$benchmark_type, declared) = 'UNKNOWN' THEN
    crev ptv$benchmark_type k=string s=job
  ELSE
    crev ptv$benchmark_type k=string s=xref
  IFEND
  ptv$benchmark_type = 'NONE'
  IF $variable(ptv$benchmark, declared) = 'UNKNOWN' THEN
    crev ptv$benchmark k=string s=job
  ELSE
    crev ptv$benchmark k=string s=xref
  IFEND
  ptv$benchmark = 'NONE'
  IF $variable(ptv$byops_run, declared) = 'UNKNOWN' THEN
    crev ptv$byops_run k=boolean s=job
  ELSE
    crev ptv$byops_run k=boolean s=xref
  IFEND
  ptv$byops_run = FALSE

  "********************************************************************"
  "*  If we are going to run IVX benchmarks on a                      *"
  "*  separate UNIX system, there is no need to set the limits and    *"
  "*  link attributes.                                                *"
  "********************************************************************"
  IF set_limits THEN
    display_value '--   Setting link attributes to ('//ptv$user_name//', '//ptv$nos_family_name//') '//ptv$password//'.'
    setla ($name(ptv$user_name), $name(ptv$nos_family_name)) $name(ptv$password)

    if  $job(operator) then
      display_value '--   Setting default family to '//ptv$family_name//'.'
      change_job_attribute_defaults login_family=$name(ptv$family_name)

      display_value '--   Setting INTERACTIVE and BATCH limits to 0.'
      set_job_class_limits job_class=batch number=0
      set_job_class_limits job_class=interactive number=0
      ptv$batch_and_ia_limits_at_0 = true
      display_value '--   Setting MAINTENANCE limit to '//$strrep($value(maintenance_limit))//'.'
      set_job_class_limits job_class=maintenance number=$value(maintenance_limit)
    else
      display_value '--'
      display_value '**  CHANGE_JOB_ATTRIBUTE_DEFAULTS FN='//$string($value(family_name))//'  should be done at the console.'
      display_value '**  SET_JOB_CLASS_LIMITS BATCH        0  should be done at the console.'
      display_value '**  SET_JOB_CLASS_LIMITS INTERACTIVE  0  should be done at the console.'
      display_value '**  SET_JOB_CLASS_LIMITS MAINTENANCE 999  should be done at the console.'
      ptv$batch_and_ia_limits_at_0 = false
    ifend
  IFEND

  display_value '-- END create_benchmark_environment.'


PROCEND create_benchmark_environment
*DECK DECK=PTM$ENTER_BENCHMARK_ENVIRONMENT EXPAND=TRUE
PROCEDURE enter_benchmark_environment, entbe (
  subcommand_libraries, sl : list of file = ..
   ($system.performance_tools.ptf$command_library, ..
    $system.performance_tools.ptf$benchmark_command_library )
  status)

   VAR
     ignore_status: status
     local_status: status
     subcommand_library : file
     subcommand_libraries : list of file = $parameter_value(subcommand_libraries)
   VAREND

   PUSH command_list
   FOR EACH subcommand_library IN subcommand_libraries DO
     create_command_list_entry e=subcommand_library status=local_status
     IF NOT local_status.normal AND local_status.condition <> cle$duplicate_command_list_ent THEN
      EXIT_PROC WITH local_status
     IFEND
   FOREND

   subcommand_libraries = $join($fname($string($source)), subcommand_libraries)
   UTILITY name=enter_benchmark_environment p='EBE' l=subcommand_libraries

     command n=(backup_benchmark_catalog, bacbc)
     command n=(change_scheduling_attributes, chasa)
     command n=(change_statistic_collection, chasc)
     command n=(change_keypoint_collection, chakc)
     command n=(change_spi_data_collection, chasdc)
     command n=(define_benchmark_users, defbu)
     command n=(display_benchmark_environment, disbe)
     command n=(duplicate_user_catalogs, dupuc)
     command n=(execute_streamtest,exes)
     command n=(expand_benchmark_decks, expbd)
     command n=(move_empower_files, movef)
     command n=(prevent_job_activation, preja)
     command n=(quit) p=quit_benchmark_environment
     command n=(run_benchmark, runb)
     command n=(run_standard_batch, runsb)
     command n=(setup_batch_ibl)
     command n=(setup_fse_ibl)
     command n=(setup_cbl)
     command n=(setup_hotkey)
     command n=(setup_ibl)
     command n=(setup_ivxed)
     command n=(setup_ivxex)
     command n=(setup_ivxvi)
     command n=(setup_nsb)
     command n=(setup_nsb_scalar)
     command n=(setup_nsb_vector)
     command n=(setup_sbl)
     command n=(setup_scl)
     command n=(setup_sibl)
     command n=(start_performance_collection, stapc)
     command n=(stop_performance_collection, stopc)
     command n=(submit_benchmark_jobs, subj)
     tablend

     VAR

" These variables must be declared first"

       bev$main_collection_catalog      : (utility) file = $user
       bev$benchmark                    : (utility) name = unspecified_benchmark
     VAREND

     VAR
       bev$active_task_info             : (utility, read) record
              at_start                       : file
              at_stop                        : file
              recend = ($fname($unique), $fname($unique))
       bev$backup_tape_vsn              : (utility) string 1..6 = 'DATA'
       bev$benchmark_environment        : (utility) boolean = true
       bev$benchmark_job_classes        : (utility) list of name = ()
       bev$collection_started_at        : (utility) string = '--------'
       bev$collection_stopped_at        : (utility) string = '--------'
       bev$engineering_log              : (utility) file = ..
              $fname($string(bev$main_collection_catalog)//'.'//bev$benchmark//'.ENGINEERING_LOG')
       bev$files_to_display             : (utility) list of file = ..
                                            ($system.scu.bound_product ..
                                             $system.scu.command_library ..
                                             $system.scu.scu_editor_help ..
                                             $system.scu.scu_editor_teach ..
                                             $system.fortran.bound_product ..
                                             $system.fortran.flf$library ..
                                             $system.cobol.bound_product ..
                                             $system.cobol.cbf$4dd_library)
       bev$keypoint_collection          : (utility) record
              environment                    : key job, j, system, s, sample_system, ss, sample_job, sj, keyend
              monitor_mask                   : list of any of key all, keyend, integer 0..15, anyend
              job_mask                       : list of any of key all, keyend, integer 0..15, anyend
              wait                           : boolean
              multiprocessor                 : key single, all, keyend
              keypoint_count                 : any of integer 1..250000000, key (no_collection, nc) keyend, anyend
              keypoint_buffer_size           : integer 1..32
              data_string                    : string 0..32
              performance                    : list of key memory, heap, swapping, aging, swap_trace, age_trace, ..
                   disk, command, all, none, keyend
              recend
       bev$keypoint_collection_files    : (utility) record
              file_1                         : file
              file_2                         : file
              recend = ..
                 ($fname($string(bev$main_collection_catalog)//'.'//bev$benchmark//'.KEYPOINT_COLLECTION_FILE'),..
                  $fname($string(bev$main_collection_catalog)//'.'//bev$benchmark//'.KEYPOINT_COLLECTION_FILE_2'))
       bev$performance_statistics_log   : (utility) file = ..
              $fname($string(bev$main_collection_catalog)//'.'//bev$benchmark//'.PERFORMANCE_STATISTICS')
       bev$performance_summary_file     : (utility) file = ..
              $fname($string(bev$main_collection_catalog)//'.'//bev$benchmark//'.PERFORMANCE_SUMMARY')
       bev$special_processing_commands  : (utility, read) record
              at_start                       : file
              at_stop                        : file
              recend = ($fname($unique), $fname($unique))
       bev$spi_data_collection_file     : (utility) file = ..
              $fname($string(bev$main_collection_catalog)//'.'//bev$benchmark//'.SPI_DATA_COLLECTION_FILE')
       bev$spi_data_collection          : (utility) record
              spi_identifier                 : integer 0..63
              number_of_spi_samples          : any of integer 100..100000000, key (no_collection, nc) keyend, anyend
              spi_sampling_interval          : integer 1..10000
              wait                           : boolean
              processors                     : list of key p0, p1, p2, p3, p4, p5, all, keyend
              data_string                    : string 0..32
              recend
       bev$statistic_collection         : (utility) record
              system_statistics              : list of statistic_code
              immediate_emission_set         : list 0..50 of statistic_code
              set_1_periodic_statistics      : list 0..50 of statistic_code
              set_1_emission_period          : any of integer, time_increment, anyend
              set_2_periodic_statistics      : list 0..50 of statistic_code
              set_2_emission_period          : any of integer, time_increment, anyend
              set_3_periodic_statistics      : list 0..50 of statistic_code
              set_3_emission_period          : any of integer, time_increment, anyend
              set_4_periodic_statistics      : list 0..50 of statistic_code
              set_4_emission_period          : any of integer, time_increment, anyend
              recend
       bev$subcommand_libraries         : (utility, read) list of file = $parameter_value(subcommand_libraries)

       bev$user_number_field_length     : (utility) integer = 3
     VAREND

     change_statistic_collection ..
          ss=( " user name               "  JM0 ..
               " job name                "  JM1 ..
               " job mode                "  JM2 ..
               " job end                 "  JM3 ..
               " task begin              "  PM0 ..
               " task starting procedure "  PM1 ..
               " task name               "  PM2 ..
               " taskend                 "  PM3 ..
               " loader begin            "  PM4 ..
               " loader end              "  PM5 ..
               " end accounting          "  AV7 ..
               " edit file begin         "  ES0 ..
               " edit file end           "  ES1 ..
               " edit deck begin         "  ES2 ..
               " edit deck end           "  ES3 ..
               " Cobol compilation       " CB0 ..
               " Fortran Compilation     " FC0 ..
               " Fortran program Unit    " FC1 ..
               " Fortran V2 compilation  " FV0 ..
               " Fortran V2 program unit " FV1 ) ..
         ies=( " job memory interval     "  OS0 ..
               " paging monitor interval "  OS1 ..
               " system io statistics    "  OS2 ..
               " io channel statistics   "  OS3 ..
               " io unit statistics      "  OS4 ..
               " disk unit space stat    "  OS5 ..
               " cpu usage statistic     "  OS6 ..
               " service class statistic "  OS7 ..
               " job class statistic     "  OS8 ..
               " system job data         "  OS9 ..
               " system task data        "  OS10 ..
               " memory utilization      "  OS11 ..
               " job count statistic     "  OS12 ..
               " page streaming stat     "  OS13 ..
               " key monitor request     "  OS14 ..
               " cpu dispatching stat    "  OS15 ..
               " page faults rejected    "  OS16 ..
               " system job data         "  OS9005 ..
               " swap state transitions  "  OS9007 ..
               " swapping page counts    "  OS9008 ..
               " aging data              "  OS9010 ..
               " monitor requests        "  OS9011 ..
               " job count data          "  OS9013 ..
               "namve layer and ME stats "  NA0 ..
               "namve intranet layer     "  NA1 ..
               "namve OSI ME and layer   "  NA2 ..
               "namve channel connect OSI"  NA3 ..
               "statistics interval begin"  OS9998 ..
               "statistics interval end  "  OS9999 ) ..
          s1ps=(OS0 OS1 OS2 OS3 OS4 OS5 OS6 OS7 OS8 OS9 OS10 OS11 OS12 OS13 OS14 ..
                OS15 OS16 OS9005 OS9007 OS9008 OS9010 OS9011 OS9013 ..
                NA0 NA1 NA2 NA3) ..
          s1ep=1 ..
          s2ps=() s2ep=1 s3ps=() s3ep=1 s4ps=() s4ep=1

     change_spi_data_collection si=0 noss=5000000 ssi=50 w=false p=all ..
          ds='spi data collection utility'

     change_keypoint_collection e=system mm=all jm=all w=true m=single ..
          kc=no_collection kbs=1 ds='keypoint collection utility' p=none

     put_line l=('" This file contains any special commands to be executed by start_performance_collection."') ..
          o=bev$special_processing_commands.at_start
     put_line l=('" This file contains any special commands to be executed by stop_performance_collection."') ..
          o=bev$special_processing_commands.at_stop

     IF $file($user.performance_tools.benchmark_prolog, permanent) THEN
       include_file f=$user.performance_tools.benchmark_prolog
     IFEND

     include_file f=$command_of_caller u=$utility(name)

     delete_file f=bev$special_processing_commands.at_start
     delete_file f=bev$special_processing_commands.at_stop
     delete_file f=bev$active_task_info.at_start status=ignore_status
     delete_file f=bev$active_task_info.at_stop status=ignore_status
   UTILITYEND

   POP command_list

PROCEND enter_benchmark_environment
*DECK DECK=PTM$QUIT_BENCHMARK_ENVIRONMENT EXPAND=TRUE
PROCEDURE quit_benchmark_environment (status)

  EXIT enter_benchmark_environment

PROCEND quit_benchmark_environment
*DECK DECK=PTREAD EXPAND=TRUE
?? RIGHT := 79, LEFT := 1 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
MODULE ptread;

*copyc pxiotyp
*copyc bizclos
*copyc bizget
*copyc bizopen
*copyc bizput
*copyc bizweof
*copyc bizweor
*copyc fzmark
*copyc fzwords
*copyc zutps2d
*copyc zn7pmsg
*copyc zutpcsa
?? NEWTITLE := '~~~~~   put message in dayfile', EJECT ??

{}
{write string into dayfile}
{}

  PROCEDURE [XDCL] dyfstring (s: string ( * );
        dayfile: 0 .. 7);

    VAR
      dcm: array [1 .. 8] of packed array [0 .. 9] of 0 .. 3f(16),
      dcwi: integer,
      dcci: 0 .. 9,
      si: ost$string_index,
      eol: boolean;

    si := 1;
    dcwi := 1;
    dcci := 0;
    eol := TRUE;
    utp$convert_string_to_dc_string (utc$ascii64, dcm, dcwi, dcci, s, si, eol);
    n7p$issue_dayfile_message (#LOC (dcm), dayfile);
  PROCEND dyfstring;
{}
{send message and number to dayfile}
{}

  PROCEDURE [XDCL] dyfstrnum (s: string ( * );
        value: integer;
        dayfile: 0 .. 7);

    VAR
      new_s: ^string ( * ),
      n,
      i: integer;

    i := STRLENGTH (s);
    PUSH new_s: [i + 10];
    new_s^ (1, i) := s (1, i);
    new_s^ (i + 1, 10) := '          ';
    STRINGREP (new_s^ (i + 1, 10), n, value);
    dyfstring (new_s^, 3);
  PROCEND dyfstrnum;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   Read tape test', EJECT ??

  PROCEDURE [XREF] NROPEN;
  PROCEDURE [XREF] NWOPEN;
  PROCEDURE [XREF] NREADN;
  PROCEDURE [XREF] NWRITE;
  PROCEDURE [XREF] NCLOSE;


  PROGRAM  read_tape_test ALIAS 'RT2000' (plength: string(7);
    pmultifile: string(7);
    pmultivol: string(7);
    puserrec: string(7));

    TYPE
      schar = string(7),
      ftab = packed record
        lfn: 0 .. 3ffffffffff(16),
        ln: 0 .. 0f(16),             { level number
        at: 0 .. 0f(16),             { abnormal termination
        eoi: boolean,                { end of information
        code: 0 .. 7f(16),           { request return code
        bo: boolean,                 { binary operation
        ocb: boolean,                { operation complete bit
      recend,
      wrec = packed record
        u8b1: 0 .. 0ff(16),
        rn1: 0 .. 0ffffff(16),
        wnlen: 0 .. 0fffffff(16),
        wnlenl: 0 .. 15,         { 2
        u8b2: 0 .. 0ff(16),
        rn2: 0 .. 0ffffff(16),
        wnu2: 0 .. 0ffffff(16),
        wnl2: 0 .. 0ff(16),      { 3
        u8b3: 0 .. 0ff(16),
        rn3: 0 .. 0ffffff(16),
        wnu3: 0 .. 0fffff(16),
        wnl3: 0 .. 0fff(16),     { 4
        u8b4: 0 .. 0ff(16),
        rn4: 0 .. 0ffffff(16),
        wnu4: 0 .. 0ffff(16),
        wnl4: 0 .. 0ffff(16),    { 5
        u8b5: 0 .. 0ff(16),
        rn5: 0 .. 0ffffff(16),
        wnu5: 0 .. 0fff(16),
        wnl5: 0 .. 0fffff(16),   { 6
        u8b6: 0 .. 0ff(16),
        rn6: 0 .. 0ffffff(16),
        wnu6: 0 .. 0ff(16),
        wnl6: 0 .. 0ffffff(16),  { 7
        u8b7: 0 .. 0ff(16),
        rn7: 0 .. 0ffffff(16),
        wnu7: 0 .. 015,
        wnl7: 0 .. 0fffffff(16), { 8
        u8b8: 0 .. 0ff(16),
        rn8: 0 .. 0ffffff(16),
        wn8: 0 .. 0ffffffff(16), { 9
        u8b9: 0 .. 0ff(16),
        rnu9: 0 .. 0fffff(16),
        rnl9: 0 .. 15,           { 10
        wn9: 0 .. 0ffffffff(16),
        u8b10: 0 .. 0ff(16),
        rnu10: 0 .. 0ffff(16),
        rnl10: 0 .. 0ff(16),     { 11
        wn10: 0 .. 0ffffffff(16),
        u8b11: 0 .. 0ff(16),
        rnu11: 0 .. 0fff(16),
        rnl11: 0 .. 0fff(16),    { 12
        wn11: 0 .. 0ffffffff(16),
        u8b12: 0 .. 0ff(16),
        rnu12: 0 .. 0ff(16),
        rnl12: 0 .. 0ffff(16),   { 13
        wn12: 0 .. 0ffffffff(16),
        u8b13: 0 .. 0ff(16),
        rnu13: 0 .. 15,
        rnl13: 0 .. 0fffff(16),  { 14
        wn13: 0 .. 0ffffffff(16),
        u8b14: 0 .. 0ff(16),
        rn14: 0 .. 0ffffff(16),  { 15
        wn14: 0 .. 0ffffffff(16),
        u8bu15: 0 .. 15,
        u8bl15: 0 .. 15,         { 16
        rn15: 0 .. 0ffffff(16),
        wn15: 0 .. 0ffffffff(16),
      recend;

    CONST
      max_multiple = 34,
      max_ve_data_record = 33024,  { bits per record 4128*8 }
      min_words = 16;

    VAR
      length: [STATIC] integer := 32,
      test_flag: [STATIC] boolean := FALSE,
      BDATA: [XREF] array[1 .. 36] OF wrec,
      FET: [XREF] packed array[0 .. 12] OF integer,
      FET2: [XREF] packed array[0 .. 12] OF integer,
      FILE2: [XREF] integer,
      PARST3: [XREF] integer,
      pfet: ^ftab,
      multi_file: [STATIC] boolean := FALSE,
      multi_vol: [STATIC] boolean := FALSE,
      status: [STATIC] boolean := FALSE,
      arg: array[1..4] OF schar,
      integ1: integer,
      integ2: integer,
      record_number: integer,
      word_no: integer,
      record_count: integer,
      test_size: [STATIC] integer := 10,  {records per file}
      second_vol: [STATIC] boolean := FALSE,
      intchr1: char,
      intvar: integer,
      min_block: record
        err_msg: string (24),
        record_length: integer,   { ve 64 bits
        record_number: integer,   { ve 24 bits
        word_number: integer,     { ve 32 bits
      recend,
      err_file: ^cell,
      err_file_name: string(7),
      file_w: ^cell,
      file_w_name: string(7),
      nos180_file: ^cell,
      nos180_file_name: string (7),
      file_mark_position: file_mark;

  PROCEDURE set_fet;
    IF (multi_vol) AND (FILE2 <> 0) THEN
      pfet := #LOC(FET2);
    ELSE
      pfet := #LOC(FET);
    IFEND;
  PROCEND set_fet;

  PROCEDURE check_for_end_of_reel;
    set_fet;
    IF (pfet^.at = 1) THEN
      dyfstring ('END OF REEL', 3);
      NCLOSE;
      IF multi_vol THEN
        second_vol := TRUE;
      IFEND;
      IF (multi_vol) AND (FILE2 = 0) THEN
        FILE2 := 7;
        NROPEN;
        set_fet;
        integ2 := pfet^.at;
        IF integ2 <> 0 THEN
          dyfstrnum ('ABNORMAL STATUS OPEN2', integ2, 3);
        IFEND;
        NREADN;
        set_fet;
      IFEND;
    IFEND;
  PROCEND check_for_end_of_reel;

  PROCEDURE read_file_mark;
     NREADN;
     check_for_end_of_reel;
     IF (pfet^.ln <> 15) THEN
        integ1 := pfet^.ln;
        dyfstrnum ('EOF FILE POSITION ERROR', integ1, 3);
        min_block.err_msg := 'EOF FILE POSITION ERROR ';
        put_out_errorfile;
     IFEND;
  PROCEND read_file_mark;

  PROCEDURE put_out_errorfile;
    IF status = FALSE THEN
      err_file_name := 'FT2000';
      bi#open (err_file, err_file_name, new#, output#, first#);
      status := TRUE;
    IFEND;
    dyfstrnum ('ERROR ON RECORD', record_number, 3);
    min_block.record_number := record_number;
    min_block.record_length := ((BDATA[1].wnlen * 16) + BDATA[1].wnlenl);
    bi#put (err_file, #LOC(min_block), #SIZE(min_block));
  PROCEND put_out_errorfile;

  PROCEDURE record_number_error;
     dyfstrnum ('DATA RECORD NUMBER ERROR', record_count, 3);
     min_block.err_msg := 'DATA RECORD NUMBER ERROR';
     put_out_errorfile;
  PROCEND record_number_error;

  PROCEDURE word_error;
     dyfstrnum ('DATA WORD NUMBER ERROR', word_no, 3);
     min_block.err_msg := ' DATA WORD NUMBER ERROR';
     min_block.word_number := word_no;
     put_out_errorfile;
  PROCEND word_error;

  PROCEDURE verify_data_record;

    word_no := BDATA[1].wnl2;
    IF (word_no <> 2) THEN
      word_error;
    IFEND;
    word_no := BDATA[1].wnl3;
    IF (word_no <> 3) THEN
      word_error;
    IFEND;
    word_no := BDATA[1].wnl4;
    IF (word_no <> 4) THEN
      word_error;
    IFEND;
    word_no := BDATA[1].wnl5;
    IF (word_no <> 5) THEN
      word_error;
    IFEND;
    word_no := BDATA[1].wnl6;
    IF (word_no <> 6) THEN
      word_error;
    IFEND;
    word_no := BDATA[1].wnl7;
    IF (word_no <> 7) THEN
      word_error;
    IFEND;
    word_no := BDATA[1].wn8;
    IF (word_no <> 8) THEN
      word_error;
    IFEND;
    word_no := BDATA[1].wn9;
    IF (word_no <> 9) THEN
      word_error;
    IFEND;
    word_no := BDATA[1].wn10;
    IF (word_no <> 10) THEN
      word_error;
    IFEND;
    word_no := BDATA[1].wn11;
    IF (word_no <> 11) THEN
      word_error;
    IFEND;
    word_no := BDATA[1].wn12;
    IF (word_no <> 12) THEN
      word_error;
    IFEND;
    word_no := BDATA[1].wn13;
    IF (word_no <> 13) THEN
      word_error;
    IFEND;
    word_no := BDATA[1].wn14;
    IF (word_no <> 14) THEN
      word_error;
    IFEND;
    word_no := BDATA[1].wn15;
    IF (word_no <> 15) THEN
      word_error;
    IFEND;
    record_count := BDATA[1].rn3;
    IF (record_count <> record_number) THEN
      record_number_error;
    IFEND;
    record_count := BDATA[1].rn4;
    IF (record_count <> record_number) THEN
      record_number_error;
    IFEND;
    record_count := BDATA[1].rn5;
    IF (record_count <> record_number) THEN
      record_number_error;
    IFEND;
    record_count := BDATA[1].rn6;
    IF (record_count <> record_number) THEN
      record_number_error;
    IFEND;
    record_count := BDATA[1].rn7;
    IF (record_count <> record_number) THEN
      record_number_error;
    IFEND;
    record_count := BDATA[1].rn8;
    IF (record_count <> record_number) THEN
      record_number_error;
    IFEND;
  PROCEND verify_data_record;

  PROCEDURE read_tape;

    VAR
      rec_length: integer,
      words_per_get: integer,
      inl: integer,
      i: integer;

    FOR i := 1 TO test_size DO
      NREADN;
      IF test_flag THEN
       bi#put (file_w, #LOC(BDATA), 551);
       bi#weor (file_w);
      IFEND;
      check_for_end_of_reel;
      integ2 := pfet^.at;
      IF (integ2 <> 0) THEN
        dyfstrnum ('ABNORMAL STATUS', integ2, 3);
      IFEND;
      IF test_flag THEN
        dyfstrnum ('WORDS READ', PARST3, 3);
      IFEND;
      IF (pfet^.ln <> 15) THEN
        IF i=1 THEN
          verify_data_record;
        IFEND;
      ELSE  { pfet^.ln = 15
        dyfstring ('INCORRECT END OF FILE', 3);
        min_block.err_msg := ' INCORRECT END OF FILE ';
        put_out_errorfile;
      IFEND;
      record_number := record_number + 1;
    FOREND;
  PROCEND read_tape;


{BEGIN MAIN PT2000 PROGRAM}


   utp$get_control_statement_args ( arg);

      intchr1 := arg[2](1);
      IF (intchr1 = 'T') THEN
        dyfstring ('MULTI FILE', 3);
        multi_file := TRUE;
      IFEND;
      intchr1 := arg[3](1);
      IF (intchr1 = 'T') THEN
        dyfstring ('CYBIL NO MULTI VOL', 3);
        multi_vol := FALSE;
      IFEND;
      intchr1 := arg[1](1);
      CASE  intchr1 OF
      = '0' =
        integ1 := 0;
      = '1' =
        integ1 := 10;
      = '2' =
        integ1 := 20;
      = '3' =
        integ1 := 30;
      ELSE
        integ1 := 100;
      CASEND;
      intchr1 := arg[1](2);
      CASE intchr1 OF
      = '0' =
        integ2 := 0;
      = '1' =
        integ2 := 1;
      = '2' =
        integ2 := 2;
      = '3' =
        integ2 := 3;
      = '4' =
        integ2 := 4;
      = '5' =
        integ2 := 5;
      = '6' =
        integ2 := 6;
      = '7' =
        integ2 := 7;
      = '8' =
        integ2 := 8;
      = '9' =
        integ2 := 9;
      ELSE
        integ2 := 40;
      CASEND;
      length := integ1 + integ2;

    dyfstrnum ('LENGTH', length, 3);
    IF length > max_multiple THEN
      dyfstrnum ('LENGTH OF RECORD IS TOO LARGE', length, 3);
      min_block.err_msg := 'LENGTH RECORD TOO LARGE ';
      put_out_errorfile;
      length := max_multiple;
    IFEND;
    intchr1 := arg[4](1);
    IF (intchr1 = 'U') THEN
      dyfstring ('USER BLOCK TYPE', 3);
      test_size := 10;
    ELSE
      test_size := 9600 * length;
      test_size := (test_size DIV max_ve_data_record) + 1;
    IFEND;
    IF (intchr1 = 'W') THEN
      test_flag := TRUE;
    IFEND;
    dyfstrnum ('RECORDS PER FILE', test_size, 3);
    IF test_flag THEN
      file_w_name := 'TESTV';
      bi#open (file_w, file_w_name, new#, output#, first#);
    IFEND;
{Open test file}
    NROPEN;
    pfet := #LOC(FET);
    IF ((pfet^.at = 1) OR (pfet^.ln = 15)) THEN
      dyfstring ('FILE POSITION ERROR', 3);
      min_block.err_msg := ' FILE POSITION ERROR    ';
      put_out_errorfile;
    IFEND;
    integ2 := pfet^.at;
    IF integ2 <> 0 THEN
      dyfstrnum ('ABNORMAL STATUS AT OPEN', integ2, 3);
      min_block.err_msg := 'ABNORMAL STATUS AT OPEN';
      put_out_errorfile;
    IFEND;
    record_number := 1;
    read_tape;
    IF multi_file THEN
      read_file_mark;
      read_tape;
      read_file_mark;
    IFEND;
    IF multi_vol THEN
      WHILE (second_vol = FALSE) DO
      read_tape;
      IF multi_file THEN
        read_file_mark;
        read_tape;
        read_file_mark;
      IFEND;
      WHILEND;
      NCLOSE;
    ELSE
      NCLOSE;
    IFEND;
    IF test_flag THEN
      bi#close (file_w, first#);
    IFEND;

    IF status THEN
      bi#close (err_file, first#);
    IFEND;
{}
  PROCEND read_tape_test;
MODEND ptread;
*DECK DECK=PTWRITE EXPAND=TRUE
?? RIGHT := 79, LEFT := 1 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
MODULE ptwrite;

*copyc pxiotyp
*copyc bizclos
*copyc bizopen
*copyc bizput
*copyc bizweof
*copyc bizweor
*copyc fzmark
*copyc fzwords
*copyc zutps2d
*copyc zn7pmsg
*copyc zutpcsa
?? NEWTITLE := '~~~~~   put message in dayfile', EJECT ??

{}
{write string into dayfile}
{}

  PROCEDURE [XDCL] dyfstring (s: string ( * );
        dayfile: 0 .. 7);

    VAR
      dcm: array [1 .. 8] of packed array [0 .. 9] of 0 .. 3f(16),
      dcwi: integer,
      dcci: 0 .. 9,
      si: ost$string_index,
      eol: boolean;

    si := 1;
    dcwi := 1;
    dcci := 0;
    eol := TRUE;
    utp$convert_string_to_dc_string (utc$ascii64, dcm, dcwi, dcci, s, si, eol);
    n7p$issue_dayfile_message (#LOC (dcm), dayfile);
  PROCEND dyfstring;
{}
{send message and number to dayfile}
{}

  PROCEDURE [XDCL] dyfstrnum (s: string ( * );
        value: integer;
        dayfile: 0 .. 7);

    VAR
      new_s: ^string ( * ),
      n,
      i: integer;

    i := STRLENGTH (s);
    PUSH new_s: [i + 10];
    new_s^ (1, i) := s (1, i);
    new_s^ (i + 1, 10) := '          ';
    STRINGREP (new_s^ (i + 1, 10), n, value);
    dyfstring (new_s^, 3);
  PROCEND dyfstrnum;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   Write tape test', EJECT ??

  PROCEDURE [XREF] NROPEN;
  PROCEDURE [XREF] NWOPEN;
  PROCEDURE [XREF] FWRITE;
  PROCEDURE [XREF] NWRITE;
  PROCEDURE [XREF] NCLOSE;


  PROGRAM  write_tape_test ALIAS 'WT2300' (plength: string(7);
    pmultifile: string(7);
    pmultivol: string(7));

    TYPE
      schar = string(7),
      ftab = packed record
        lfn: 0 .. 3ffffffffff(16),
        ln: 0 .. 0f(16),             { level number
        at: 0 .. 0f(16),             { abnormal termination
        eoi: boolean,                { end of information
        code: 0 .. 7f(16),           { request return code
        bo: boolean,                 { binary operation
        ocb: boolean,                { operation complete bit
      recend,
      wrec = packed record
        u8b1: 0 .. 0ff(16),
        rn1: 0 .. 0ffffff(16),
        wnlen: 0 .. 0fffffff(16),
        wnlenl: 0 .. 15,         { 2
        u8b2: 0 .. 0ff(16),
        rn2: 0 .. 0ffffff(16),
        wnu2: 0 .. 0ffffff(16),
        wnl2: 0 .. 0ff(16),      { 3
        u8b3: 0 .. 0ff(16),
        rn3: 0 .. 0ffffff(16),
        wnu3: 0 .. 0fffff(16),
        wnl3: 0 .. 0fff(16),     { 4
        u8b4: 0 .. 0ff(16),
        rn4: 0 .. 0ffffff(16),
        wnu4: 0 .. 0ffff(16),
        wnl4: 0 .. 0ffff(16),    { 5
        u8b5: 0 .. 0ff(16),
        rn5: 0 .. 0ffffff(16),
        wnu5: 0 .. 0fff(16),
        wnl5: 0 .. 0fffff(16),   { 6
        u8b6: 0 .. 0ff(16),
        rn6: 0 .. 0ffffff(16),
        wnu6: 0 .. 0ff(16),
        wnl6: 0 .. 0ffffff(16),  { 7
        u8b7: 0 .. 0ff(16),
        rn7: 0 .. 0ffffff(16),
        wnu7: 0 .. 015,
        wnl7: 0 .. 0fffffff(16), { 8
        u8b8: 0 .. 0ff(16),
        rn8: 0 .. 0ffffff(16),
        wn8: 0 .. 0ffffffff(16), { 9
        u8b9: 0 .. 0ff(16),
        rnu9: 0 .. 0fffff(16),
        rnl9: 0 .. 15,           { 10
        wn9: 0 .. 0ffffffff(16),
        u8b10: 0 .. 0ff(16),
        rnu10: 0 .. 0ffff(16),
        rnl10: 0 .. 0ff(16),     { 11
        wn10: 0 .. 0ffffffff(16),
        u8b11: 0 .. 0ff(16),
        rnu11: 0 .. 0fff(16),
        rnl11: 0 .. 0fff(16),    { 12
        wn11: 0 .. 0ffffffff(16),
        u8b12: 0 .. 0ff(16),
        rnu12: 0 .. 0ff(16),
        rnl12: 0 .. 0ffff(16),   { 13
        wn12: 0 .. 0ffffffff(16),
        u8b13: 0 .. 0ff(16),
        rnu13: 0 .. 15,
        rnl13: 0 .. 0fffff(16),  { 14
        wn13: 0 .. 0ffffffff(16),
        u8b14: 0 .. 0ff(16),
        rn14: 0 .. 0ffffff(16),  { 15
        wn14: 0 .. 0ffffffff(16),
        u8bu15: 0 .. 15,
        u8bl15: 0 .. 15,         { 16
        rn15: 0 .. 0ffffff(16),
        wn15: 0 .. 0ffffffff(16),
      recend;

    CONST
      max_multiple = 34,
      max_ve_data = 4128,
      min_words = 16,
      large_jobs =1001(16);  {cio buffer size faster data xfer}

    VAR
      length: [STATIC] integer := 32,
      test_flag: [STATIC] boolean := FALSE,
      BUFF: [XREF] array[1 .. 36] OF wrec,
      FET: [XREF] packed array[0 .. 12] OF integer,
      FET2: [XREF] packed array[0 .. 12] OF integer,
      FILE2: [XREF] integer,
      PARST3: [XREF] integer,
      pfet: ^ftab,
      multi_file: [STATIC] boolean := FALSE,
      multi_vol: [STATIC] boolean := FALSE,
      status: [STATIC] boolean := FALSE,
      arg: array[1..4] OF schar,
      integ1: integer,
      integ2: integer,
      record_number: integer,
      word_no: integer,
      test_size: [STATIC] integer := 512,  {60 bit words}
      second_vol: [STATIC] boolean := FALSE,
      intchr1: char,
      intvar: integer,
      min_block: record
        err_msg: string (24),
        record_length: integer,   { ve 64 bits
        record_number: integer,   { ve 24 bits
        word_number: integer,     { ve 32 bits
      recend,
      buf1: [STATIC] wrec,
      cmdata: packed record
        rdata: packed array[1 .. 34] of wrec,
        lastdb: packed array[1 .. 6] OF 0 .. 15,
      recend,
      err_file: ^cell,
      err_file_name: string(7),
      vol2_file: ^cell,
      vol2_file_name: string(7),
      nos180_file: ^cell,
      nos180_file_name: string (7),
      file_mark_position: file_mark;

  PROCEDURE check_for_eoi;
    f#mark (nos180_file, file_mark_position);
    IF file_mark_position = eoi# THEN
      second_vol := TRUE;
      bi#weof (nos180_file);
      bi#weof (nos180_file);
      bi#close (nos180_file, first#);
      vol2_file_name := 'T22300';
      bi#open (vol2_file, vol2_file_name, new#, output#, first#);
    IFEND;
  PROCEND check_for_eoi;

  PROCEDURE initialize_data_record ;

    buf1.u8b1 := 0;
    buf1.rn1 := 0;
    buf1.wnlen := (length * 120) DIV 16;
    buf1.wnlenl := (length * 120) MOD 10(16);
    buf1.u8b2 := 29;
    buf1.rn2 := record_number;
    buf1.wnu2 := 0;
    buf1.wnl2 := 2;
    buf1.u8b3 := 29;
    buf1.rn3 := record_number;
    buf1.wnu2 := 0;
    buf1.wnl3 := 3;
    buf1.u8b4 := 29;
    buf1.rn4 := record_number;
    buf1.wnu4 := 0;
    buf1.wnl4 := 4;
    buf1.u8b5 := 29;
    buf1.rn5 := record_number;
    buf1.wnu5 := 0;
    buf1.wnl5 := 5;
    buf1.u8b6 := 29;
    buf1.rn6 := record_number;
    buf1.wnu6 := 0;
    buf1.wnl6 := 6;
    buf1.u8b7 := 29;
    buf1.rn7 := record_number;
    buf1.wnu7 := 0;
    buf1.wnl7 := 7;
    buf1.u8b8 := 29;
    buf1.rn8 := record_number;
    buf1.wn8 := 8;
    buf1.u8b9 := 29;
    buf1.rnu9 := record_number DIV 16;
    buf1.rnl9 := record_number MOD 10(16);
    buf1.wn9 := 9;
    buf1.u8b10 := 29;
    buf1.rnu10 := record_number DIV 100(16);
    buf1.rnl10 := record_number MOD 100(16);
    buf1.rnl10 := record_number;
    buf1.wn10 := 10;
    buf1.u8b11 := 29;
    buf1.rnu11 := record_number DIV 1000(16);
    buf1.rnl11 := record_number MOD 1000(16);
    buf1.rnl11 := record_number;
    buf1.wn11 := 11;
    buf1.u8b12 := 29;
    buf1.rnu12 := record_number DIV 10000(16);
    buf1.rnl12 := record_number MOD 10000(16);
    buf1.rnl12 := record_number;
    buf1.wn12 := 12;
    buf1.u8b13 := 29;
    buf1.rnu13 := record_number DIV 100000(16);
    buf1.rnl13 := record_number MOD 100000(16);
    buf1.rnl13 := record_number;
    buf1.wn13 := 13;
    buf1.u8b14 := 29;
    buf1.rn14 := record_number;
    buf1.wn14 := 14;
    buf1.u8bu15 := 1;
    buf1.u8bl15 := 13;
    buf1.rn15 := record_number;
    buf1.wn15 := 15;
  PROCEND initialize_data_record;

  PROCEDURE update_record;
    word_no := buf1.wn15 + 1;
    buf1.wnlen := word_no DIV 16;
    buf1.wnlenl := word_no MOD 10(16);
    word_no := word_no + 1;
    buf1.wnu2 := word_no DIV 100(16);
    buf1.wnl2 := word_no MOD 100(16);
    word_no := word_no + 1;
    buf1.wnu3 := word_no DIV 1000(16);
    buf1.wnl3 := word_no MOD 1000(16);
    buf1.wnl4 := buf1.wnl4 + 15;
    buf1.wnl5 := buf1.wnl5 + 15;
    buf1.wnl6 := buf1.wnl6 + 15;
    buf1.wnl7 := buf1.wnl7 + 15;
    buf1.wn8 := buf1.wn8 + 15;
    buf1.wn9 := buf1.wn9 + 15;
    buf1.wn10 := buf1.wn10 + 15;
    buf1.wn11 := buf1.wn11 + 15;
    buf1.wn12 := buf1.wn12 + 15;
    buf1.wn13 := buf1.wn13 + 15;
    buf1.wn14 := buf1.wn14 + 15;
    buf1.wn15 := buf1.wn15 + 15;
  PROCEND update_record;

  PROCEDURE set_fet;
    IF (multi_vol) AND (FILE2 <> 0) THEN
      pfet := #LOC(FET2);
    ELSE
      pfet := #LOC(FET);
    IFEND;
  PROCEND set_fet;

  PROCEDURE check_for_end_of_reel;
    set_fet;
    IF (pfet^.at = 1) THEN
      dyfstring ('END OF REEL', 3);
      IF multi_vol THEN
        second_vol := TRUE;
      IFEND;
      NCLOSE;
      IF (multi_vol) AND (FILE2 = 0) THEN
        FILE2 := 7;
        NWOPEN;
        set_fet;
        integ2 := pfet^.at;
        IF integ2 <> 0 THEN
          dyfstrnum ('ABNORMAL STATUS OPEN2', integ2, 3);
        IFEND;
      IFEND;
    IFEND;
  PROCEND check_for_end_of_reel;

  PROCEDURE write_file_mark;
    IF test_flag THEN
      FWRITE;
      check_for_end_of_reel;
    ELSE
      IF second_vol THEN
        bi#weof (vol2_file);
      ELSE
        bi#weof (nos180_file);
      IFEND;
    IFEND;
  PROCEND write_file_mark;

  PROCEDURE put_out_errorfile;
    IF status = FALSE THEN
      err_file_name := 'FT2300';
      bi#open (err_file, err_file_name, new#, output#, first#);
      status := TRUE;
    IFEND;
    bi#put (err_file, #LOC(min_block), #SIZE(min_block));
  PROCEND put_out_errorfile;

  PROCEDURE write_tape;

    VAR
      rec_length: integer,
      record_count: integer,
      i: integer;

    FOR record_count := 1 TO 10 DO
      initialize_data_record;
      IF test_flag THEN
        BUFF[1] := buf1;
      ELSE
        cmdata.rdata[1] := buf1;
      IFEND;
      buf1.u8b1 := 29;
      buf1.rn1 := record_number;
      FOR i := 2 TO length DO
        update_record;
        IF test_flag THEN
          BUFF[i] := buf1;
        ELSE
          cmdata.rdata[i] := buf1;
        IFEND;
      FOREND;
      IF test_flag THEN
        FET[2] := test_size + PARST3;
        FET[3] := PARST3;
        NWRITE;
        set_fet;
        integ2 := pfet^.at;
        IF integ2 <> 0 THEN
          dyfstrnum ('ABNORMAL STATUS', integ2, 3);
        IFEND;
        check_for_end_of_reel;
      ELSE
        bi#put (nos180_file, #LOC (cmdata), test_size);
        bi#weor (nos180_file);
        IF multi_vol THEN
          check_for_eoi;
        IFEND;
      IFEND;
      record_number := record_number + 1;
    FOREND;
  PROCEND write_tape;


{BEGIN MAIN PT2300 PROGRAM}


   utp$get_control_statement_args ( arg);

      intchr1 := arg[2](1);
      IF (intchr1 = 'T') THEN
        dyfstring ('MULTI FILE', 3);
        multi_file := TRUE;
      IFEND;
      intchr1 := arg[3](1);
      IF (intchr1 = 'T') THEN
        dyfstring ('MULTI VOL', 3);
        multi_vol := TRUE;
      IFEND;
      intchr1 := arg[1](1);
      CASE  intchr1 OF
      = '0' =
        integ1 := 0;
      = '1' =
        integ1 := 10;
      = '2' =
        integ1 := 20;
      = '3' =
        integ1 := 30;
      ELSE
        integ1 := 40;
      CASEND;
      intchr1 := arg[1](2);
      CASE intchr1 OF
      = '0' =
        integ2 := 0;
      = '1' =
        integ2 := 1;
      = '2' =
        integ2 := 2;
      = '3' =
        integ2 := 3;
      = '4' =
        integ2 := 4;
      = '5' =
        integ2 := 5;
      = '6' =
        integ2 := 6;
      = '7' =
        integ2 := 7;
      = '8' =
        integ2 := 8;
      = '9' =
        integ2 := 9;
      ELSE
        integ2 := 40;
      CASEND;
      length := integ1 + integ2;

    dyfstrnum ('LENGTH', length, 3);
    IF length > max_multiple THEN
      dyfstrnum ('LENGTH OF RECORD IS TOO LARGE', length, 3);
      min_block.err_msg := 'LENGTH RECORD TOO LARGE ';
      put_out_errorfile;
      length := max_multiple;
    IFEND;
    test_size := min_words * length;
    intchr1 := arg[4](1);
    IF (intchr1 = 'W') THEN
      test_flag := TRUE;
    IFEND;
    IF test_flag THEN
      NWOPEN;
      set_fet;
      integ2 := pfet^.at;
      IF integ2 <> 0 THEN
        dyfstrnum ('ABNORMAL STATUS AT OPEN', integ2, 3);
        min_block.err_msg := 'ABNORMAL STATUS AT OPEN';
        put_out_errorfile;
      IFEND;
    ELSE
      nos180_file_name := 'CT2300'; {nosve tape}
{Open test file}
      bi#open (nos180_file, nos180_file_name, new#, output#, first#);
    IFEND;
    record_number := 1;
    write_tape;
    IF multi_file THEN
      write_file_mark;
      write_tape;
      write_file_mark;
    IFEND;
    IF multi_vol THEN
      WHILE (second_vol = FALSE) DO
        IF test_flag THEN
          check_for_end_of_reel;
        ELSE
          check_for_eoi;
        IFEND;
        write_tape;
        IF multi_file THEN
          write_file_mark;
          write_tape;
          write_file_mark;
        IFEND;
      WHILEND;
      IF test_flag THEN
        NCLOSE;
      ELSE
        bi#close (nos180_file, first#);
      IFEND;
    ELSE
      IF test_flag THEN
        NCLOSE;
      ELSE
        bi#close (nos180_file, first#);
      IFEND;
    IFEND;

    IF status THEN
      bi#close (err_file, first#);
    IFEND;
{}
  PROCEND write_tape_test;
MODEND ptwrite;
*DECK DECK=PUC$DELETE_ALL_FILES_MESSAGE EXPAND=FALSE

  CONST
    puc$delete_all_files_message = 'PUM$DELETE_ALL_FILES           ';
*DECK DECK=PUD$BACKUP_FILE EXPAND=FALSE

  TYPE
    put$backup_record_type = (puc$backup_item_identifier,
      puc$backup_hierarchy_list, puc$backup_set_info, puc$backup_family_info,
      puc$backup_family_content_info, puc$backup_catalog_info,
      puc$backup_catalog_content_info, puc$backup_file_info,
      puc$backup_cycle_info, puc$backup_cycle_data, puc$backup_system_label),

    put$backup_item_info_type = (puc$backup_item_set_info,
      puc$backup_item_family_info, puc$backup_item_catalog_info,
      puc$backup_item_file_info, puc$backup_item_cycle_info),

    put$backup_item_info = record
      case item_type: put$backup_item_info_type of
      = puc$backup_item_set_info =
        set_item_info: pft$p_info_record,
      = puc$backup_item_family_info =
        family_item_info: pft$p_info_record,
        family_content_info: pft$p_info_record,
      = puc$backup_item_catalog_info =
        catalog_item_info: pft$p_info_record,
      = puc$backup_item_file_info =
        file_item_info: pft$p_info_record,
      = puc$backup_item_cycle_info =
        cycle_item_info: put$backup_file_cycle_info,
      casend,
    recend,

    put$backup_file_item_path = record
      item_path_header: put$backup_file_record_header,
      item_path_descriptor: put$backup_item_descriptor,
    recend,

    put$backup_item_descriptor = record
      pf_utility_entry: put$entry,
      catalog_header: put$catalog_header,
    recend,

    put$backup_file_hierarchy_list = record
      hierarchy_list_header: put$backup_file_record_header,
      hierarchy_list: put$hierarchy_list,
    recend,

    put$backup_file_record_header = record
      kind: put$backup_record_type,
      size: put$half_integer,
    recend,

    put$backup_file_cycle_info = record
      body_size: put$half_integer,
      body: ^cell,
    recend;

  TYPE
    put$backup_file_version_name = ost$name;

  CONST
    puc$backup_file_version_1 = 'BACKUP_FILE_VERSION_001        ',
    puc$backup_file_version_2 = 'BACKUP_FILE_VERSION_002        ';


?? PUSH (LISTEXT := ON) ??
*copyc OST$NAME
*copyc OST$USER_IDENTIFICATION
*copyc PFD$CATALOG_INFO
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PUD$HIERARCHY_LIST
*copyc STD$SET_NAME
?? POP ??
*DECK DECK=PUD$CYCLE_REFERENCE EXPAND=FALSE
 TYPE
    put$cycle_reference_options = (puc$cycle_omitted, puc$lowest_cycle,
      puc$highest_cycle, puc$specific_cycle, puc$next_highest_cycle,
      puc$next_lowest_cycle),

    put$cycle_reference_selections = set of put$cycle_reference_options;
*DECK DECK=PUD$HIERARCHY_LIST EXPAND=FALSE

  TYPE
    put$hierarchy_list = record
      pf_entry: put$entry,
      date_time: ost$date_time,
      catalog_header: put$catalog_header,
    recend;


  TYPE
    put$catalog_header = record
      set_name: stt$set_name,
      logical_path_length: 0 .. 7fffffff(16),
      path: pft$path,
    recend;


  TYPE
    put$entry_type = (puc$valid_set_entry, puc$valid_family_entry,
      puc$valid_catalog_entry, puc$valid_pf_entry, puc$valid_cycle_entry,
      puc$invalid_entry);

  TYPE
    put$entry = record
      case entry_type: put$entry_type of
      = puc$valid_set_entry =
        set_name: stt$set_name,
      = puc$valid_family_entry =
        family_name: pft$name,
      = puc$valid_catalog_entry =
        catalog_name: pft$name,
      = puc$valid_pf_entry =
        pfn: pft$name,
      = puc$valid_cycle_entry =
        pf_selector: put$pf_selector,
      = puc$invalid_entry =
        ,
      casend,
    recend,


    put$pf_selector = record
      pfn: pft$name,
      cycle_selector: pft$cycle_selector,
    recend,
    put$half_integer = - 7fffffff(16) .. 7fffffff(16);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc OST$DATE_TIME
*copyc STD$SET_NAME
?? POP ??
*DECK DECK=PUD$LIST_OPTIONS EXPAND=FALSE
 TYPE
    put$cycle_display_options = (puc$cdo_identifier, puc$cdo_size,
      puc$cdo_creation_date_time, puc$cdo_access_date_time,
      puc$cdo_modification_date_time, puc$cdo_expiration_date,
      puc$cdo_access_count, puc$cdo_global_file_name, puc$cdo_recorded_vsn,
      puc$cdo_alternate_storage, puc$cdo_alternate_mod_date_time,
      puc$cdo_alternate_size, puc$cdo_action_descriptor);

  TYPE
    put$cycle_display_selections = set of put$cycle_display_options;

  TYPE
    put$action_descriptor = string (14);

  CONST
    puc$unknown_cycle_size = (amc$file_byte_limit - 17),

    puc$released_cycle_size = (amc$file_byte_limit - 18),

    puc$unknown_recorded_vsn = '------',

    puc$nonexistent_recorded_vsn = 'NO VSN',

    puc$item_backed_up = 'ITEM BACKED UP';

  VAR
    puv$unknown_global_file_name: [READ, pus$literals] ost$binary_unique_name
      := [0, osc$cyber_180_model_unknown, 1980, 1, 1, 0, 0, 0, 0, 0],

    puv$no_expiration_date: [READ, pus$literals] ost$date_time := [255, 12, 31,
      23, 59, 59, 999];

  TYPE
    put$file_display_options = (puc$fdo_identifier, puc$fdo_account,
      puc$fdo_project, puc$fdo_action_descriptor);

  TYPE
    put$file_display_selections = set of put$file_display_options;

  CONST
    puc$unknown_account = ' UNKNOWN ACCOUNT               ',
    puc$unknown_project = ' UNKNOWN PROJECT               ';

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
*copyc osd$unique_name
*copyc amd$file_attributes
*copyc pus$literals
?? POP ??
*DECK DECK=PUD$SELECTION_CRITERIA EXPAND=FALSE

  TYPE
    put$selection_criteria_mode = (puc$created, puc$accessed, puc$modified, puc$expired);

  TYPE
    put$selection_criteria = record
      mode: put$selection_criteria_mode,
      after_date_time_selected: boolean,
      after_date_time: ost$date_time,
      before_date_time_selected: boolean,
      before_date_time: ost$date_time,
      after_time_after_before_time: boolean,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc ost$date_time
?? POP ??
*DECK DECK=PUDSSEV EXPAND=FALSE

  TYPE
    put$status_severity = (puc$normal_status, puc$informative_status,
      puc$warning_status, puc$error_status, puc$fatal_status,
      puc$catastrophic_status);


  TYPE
    puc$termination_error_level = puc$fatal_status;
*DECK DECK=PUE$ERROR_CONDITION_CODES EXPAND=FALSE
?? FMT (FORMAT := OFF) ??
?? NEWTITLE := 'Permanent File Utility Exception Conditon Codes' ??

  CONST
    puc$min_ecc = (($INTEGER ('P') * 100(16)) + $INTEGER ('U')) * 1000000(16),
    puc$max_ecc = puc$min_ecc + 999,
    puc$pf_utility_id = 'PU',

    pue$unexpected_file_position = puc$min_ecc + 101,
    {E Unexpected reference to file position for parameter +P1.

    pue$path_too_short = puc$min_ecc + 102,
    {E The parameter +P1 is too short for this request.  +P2 is the first
    { value.  +P3

    pue$backup_label_type_commands    = puc$min_ecc + 103,
    {W The CHANGE_BACKUP_LABEL_TYPE and DISPLAY_BACKUP_LABEL_TYPE commands
    { are no longer supported.  If you want to create an unlabeled backup file
    { you must specify FILE_LABEL_TYPE=UNLABELED using the SET_FILE_ATTRIBUTES
    { command for the backup file before the BACKUP_PERMANENT_FILES command
    { or the RESTORE_PERMANENT_FILES subcommand.  A labeled backup file is
    { assumed.

    pue$null_backup_file_required = puc$min_ecc + 105,
    {E The NULL_BACKUP_FILE_OPTION parameter is only available when the backup
    { file is of device class NULL.

    pue$unable_to_read_catalog_info  = puc$min_ecc + 106,
    {E Internal: Unable to read catalog information + P1.

    pue$unusable_restore_file = puc$min_ecc + 500,
    {E Unrecoverable error occurred using backup file - +P1 +P2 +P3 +P4.

    pue$invalid_file_connection = puc$min_ecc + 501,
    {E The selected backup file, +F, must not be connected to target
    { files with differing device classes or file label types, or with improper
    { block types and record types.

    pue$no_restore_no_find = puc$min_ecc + 502,
    {E Unable to find +P1 +P2 +P3 on backup file - no restore performed.

    pue$unexpected_cycle_on_nfn = puc$min_ecc + 505,
    {E A cycle was specified on the +P1 parameter but not on the FILE
    { parameter.

    pue$invalid_device_type = puc$min_ecc + 506,
    {E The selected backup file +F must be a mass storage, magnetic tape,
    { or null file.

    pue$unexpected_item_requested = puc$min_ecc + 507,
    {E An unexpected item was found on the backup file.  +P1 Contact site
    { analyst.

    pue$new_catalog_already_exists = puc$min_ecc + 508,
    {E The new catalog +P1 already exists.

    pue$new_file_already_exists = puc$min_ecc + 509,
    {E The new file +P1 already exists.

    pue$new_cycle_already_exists = puc$min_ecc + 510,
    {E File +P1 cycle +P2 already exists.

    pue$unknown_set = puc$min_ecc + 518,
    {E The requested set +P1 does not exist.  Contact site analyst.

    pue$incompatible_backup_version = puc$min_ecc + 519,
    {F The backup file +P1 is incompatible with the current system.  Contact
    { your site analyst.
    {+N3 Supported versions:  +P2
    {+N3 Recorded version:    +P3

    pue$restore_cycle_requires_file = puc$min_ecc + 522,
    {E INTERNAL: - Create file from cycle entry

    pue$unable_to_read_version = puc$min_ecc + 523,
    {W Unable to read version number from backup file: read: +P1.  Item
    { skipped.

    pue$path_too_long = puc$min_ecc + 524,
    {E The +P1 parameter is too long for this request.

    pue$item_already_excluded = puc$min_ecc + 525,
    {E The +P1 +P2 +P3 is already excluded from backup/delete.

    pue$item_never_excluded = puc$min_ecc + 526,
    {E Internal: The +P1 +P2 +P3 is not currently excluded from backup/delete.

    pue$both_file_catalog_specified = puc$min_ecc + 527,
    {E The FILE parameter and the CATALOG parameter must not both be specified
    { on the RESTORE_EXCLUDED_FILE_CYCLES subcommand.

    pue$new_name_specified_alone = puc$min_ecc + 528,
    {E The NEW_NAME parameter may only be specified if the FILE or CATALOG
    { parameters are specified.

    pue$multiple_list_file = puc$min_ecc + 529,
    {E Internal: An attempt was made to specify list file +P1 when +P2 is
    { already in use.

    pue$date_part_omitted = puc$min_ecc + 530,
    {E The date portion of the +P1 parameter was omitted but is required.

    pue$before_after_time_equal = puc$min_ecc + 531,
    {E The two date_time values are exactly equal.  A zero length window of
    { time for INCLUDE_CYCLES is not allowed.

    pue$not_system_administrator = puc$min_ecc + 534,
    {E You must be the system or family administrator to use the +P1 request
    { +P2.  +P3

    pue$bad_cycle_selections = puc$min_ecc + 535,
    {E Internal: Null allowed_cycle_selections for parameter +P1.

    pue$incorrect_cycle_reference = puc$min_ecc + 536,
    {E +P1 was specified for parameter +P2. +N4 +P3+P4+P5+P6+P7+P8 may be
    { specified.

    pue$error_summary_status = puc$min_ecc + 537,
    {W +P1 error+P2 occurred during subcommand. +N3 Check list file +F3.
    { +N3 +P4+P5+P6+P7+P8+P8

    pue$volume_not_active = puc$min_ecc + 539,
    {E Volume +P1 is not active.

    pue$nil_data_file_pointer = puc$min_ecc + 540,
    {E Internal: A nil value was returned for +P1 on the data file +F2.

    pue$unknown_gfn = puc$min_ecc + 541,
    {E Internal: The global file name +P1 was NOT found on data file +F2.

    pue$data_file_already_selected = puc$min_ecc + 543,
    {E Internal: Data file +F1 is already selected.

    pue$number_of_items = puc$min_ecc + 544,
    {I +P1 catalogs, files, or cycles found.

    pue$backup_condition = puc$min_ecc + 546,
    {E A condition occurred in backup.  Check list file.

    pue$restore_condition = puc$min_ecc + 547,
    {E A condition occurred on restore.  Check list file.

    pue$unowned_users_included = puc$min_ecc + 548,
    {E As family administrator you may only use the +P1 request on users in
    { your family. +N2 The INCLUDE_USERS request may be used to select the
    { users in your family.

    pue$must_restore_as_family = puc$min_ecc + 549,
    {E A family catalog may only be restored as a family catalog, using the +P1
    { request.

    pue$cant_restore_as_family = puc$min_ecc + 550,
    {E A user catalog may not be restored as a family catalog, using the +P1
    { request.

    pue$must_restore_as_subcatalog = puc$min_ecc + 551,
    {E A subcatalog may only be restored as a subcatalog, NOT as a FAMILY or
    { USER catalog, using the +P1 request.

    pue$new_name_must_be_different = puc$min_ecc + 552,
    {E The name specified on the +P1 parameter must be different than the name
    { specified on the +P2 parameter.

    pue$not_system_operator = puc$min_ecc + 553,
    {E You must be the operator to use the +P1 request.

    pue$label_mismatch = puc$min_ecc + 554,
    {E Backup_label_type is UNLABELLED, but the tape volume was labelled and
    { the vsn specified on REQUEST_MAGNETIC_TAPE +P1 does not match the
    { recorded_vsn on the tape volume.

    pue$entered_size_below_minimum = puc$min_ecc + 601,
    {E The specified maximum size of +P1 was less than the current minimum size
    { of +P2.

    pue$entered_size_above_maximum = puc$min_ecc + 602,
    {E The specified minimum size of +P1 was greater than the current maximum
    { size of +P2.

    pue$no_cycle_direct_array_entry = puc$min_ecc + 603,
    {E Internal: File +F1 cycle +P1 could not be found in the cycle directory
    { array returned by PFP$GET_ITEM_INFO.

    pue$user_set_rai_true = puc$min_ecc + 606,
    {E System or family administrator privilege is required to set the
    { RESTORE_ARCHIVE_INFORMATION parameter of the SET_RESTORE_OPTIONS
    { subcommand to TRUE.

    pue$empty_cycle_partition = puc$min_ecc + 607,
    {E Specifying the cycle number on the BACKUP_FILE subcommand when backing
    { up a released cycle and not including off-line data is not permitted,
    { as neither archive information nor data would be backed up.

    pue$incv_and_offline_conflict = puc$min_ecc + 608,
    {E VSNs may not be specified with the INCLUDE_VOLUME subcommand when
    { including off-line data with the INCLUDE_DATA parameter of the
    { SET_BACKUP_OPTIONS subcommand.

    pue$user_set_iai_true = puc$min_ecc + 609,
    {E System or family administrator privilege is required to set the
    { INCLUDE_ARCHIVE_INFORMATION parameter of the SET_BACKUP_OPTIONS
    { subcommand to TRUE.

    pue$create_replace_conflict = puc$min_ecc + 612,
    {E  CREATE_OBJECTS and REPLACE_CYCLE_DATA cannot both be FALSE.

    pue$ucs_rai_conflict = puc$min_ecc + 613,
    {E The UPDATE_CYCLE_STATISTICS and RESTORE_ARCHIVE_INFORMATION parameters
    { cannot both be set to TRUE.

    pue$not_all_permits_restored = puc$min_ecc + 614,
    {W Not all +P permits were restored.

    pue$original_ms_attr_ignored = puc$min_ecc + 615,
    {W File +F1 could not be restored with the same mass storage
    { attributes that it had when it was backed up.

    pue$original_init_vol_ignored = puc$min_ecc + 616,
    {W File +F1 could not be restored to initial volume +P2 on which
    { it resided when it was backed up.

    pue$original_file_class_ignored = puc$min_ecc + 617,
    {W File +F1 could not be restored to file class +P2 on which it
    { resided when it was backed up.

    pue$archive_info_not_backed_up = puc$min_ecc + 618,
    {E Cycle can not be backed up because the data resides   }
    { offline and neither offline data nor archive information is }
    { included.
    { +N3 Use the SET_BACKUP_OPTIONS subcommand to specify either
    { OFFLINE_DATA for the INCLUDE_DATA parameter or TRUE for the
    { INCLUDE_ARCHIVE_INFORMATION parameter.

    pue$backed_up_with_write_access = puc$min_ecc + 619,
    {W +F was backed up while attached for write access.}
    { +N1 The backup may be inconsistent unless precautions were taken}
    { to prevent modifications during the backup.}

    pue$unrecovered_ms_read_error = puc$min_ecc + 620,
    {E An unrecovered mass storage read error occurred on
    { file +F1 which contains  +P2 bytes.  You will only
    { be able to restore +P3 bytes from the backup file.

    pue$no_objects_selected = puc$min_ecc + 621,
    {E Either the FILE or the CATALOG parameter must be specified.}

    pue$object_not_restored = puc$min_ecc + 622,
    {E +P1 +P2 was not restored because it was not found on the backup file.

    pue$archive_info_not_restored = puc$min_ecc + 623,
    {E Archive information was not restored because +P1.

    pue$redundant_objects_selected = puc$min_ecc + 624,
    {E Redundant +P1 specification +P2 is not allowed.}

    pue$delaf_command_terminated = puc$min_ecc + 625,
    {E DELETE_ALL_FILES command terminated.}

    pue$delete_all_files_completed = puc$min_ecc + 626,
    {I DELETE_ALL_FILES command completed.}

    pue$cannot_specify_none_for_iec = puc$min_ecc + 627,
    {E NONE cannot be specified for the INCLUDE_EXCEPTION_CONDITIONS
    { parameter when +P.}

    pue$released_cycle_rai_false = puc$min_ecc + 628,
    {E +P1 not restored because it was offline when backed up and archive}
    { information is not restored when RESTORE_ARCHIVE_INFORMATION is FALSE.}

    pue$bad_integer_subrange = puc$min_ecc + 629,
    {E Integer subrange +P is not in ascending order.}

    pue$site_option_ignored = puc$min_ecc + 630,
    {W The +P3 value for cycle +P2 of file +P1 has been changed to NULL because}
    { you are not validated to use a value of +P4.}

    puc$null_parameter = '';

?? OLDTITLE ??
?? FMT (FORMAT := ON) ??
*DECK DECK=PUH$BUILD_NEW_ONLINE_CAT_HEAD EXPAND=FALSE
{
{   This procedure  takes  the  requested  catalog,  and  the new_catalog_name
{  parameters, and the name of the found catalog  header,  and  builds  a  new
{  online catalog header.  For example:
{ catalog_header = NVESET.  A .  B
{ new_catalog_header = NVESET .  DOG
{ found_catalog_header = NVESET .  A .  B .  FRED
{ new_online_catalog_header => NVESET .  DOG .  FRED
{ The determination of whether the found item is under the requested item must
{ have  been  done  outside  of  this  procedure.  The size of the new catalog
{ header is assumed correct.
{
{       PUP$BUILD_NEW_ONLINE_CAT_HEAD (CATALOG_HEADER, NEW_CATALOG_HEADER,
{         FOUND_CATALOG_HEADER, NEW_ONLINE_CATALOG_HEADER)
{
{ CATALOG_HEADER:  (input) This parameter specifies the catalog header for the
{       catalog or file parameter on the restore subcommand.
{
{ NEW_CATALOG_HEADER: (input) This parameter specifies the catalog header  for
{       the  new  catalog  name  or  new  file  name parameters on the restore
{       subcommand.
{
{ FOUND_CATALOG_HEADER: (input) This parameter specifies  the  catalog  header
{       for the item found on the backup file.
{
{ NEW_ONLINE_CATALOG_HEADER:  (output)  This parameter returns the name of the
{       catalog header to be used in restoring the new item.
{
*DECK DECK=PUH$COMPARE_ITEM_DESCRIPTOR EXPAND=FALSE
{
{   The purpose  of  this  request is to compare 2 pf utility item descriptors
{ (defined  by  an  entry,  and  catalog  header)  to  determine  if  the  two
{ descriptors are equal, or if the first descriptor is above the second one in
{ the permanent file catalog tree.   "Above"  indicates  closer  to  the  root
{ catalog (or for users, this is closer to the master catalog).
{
{       PUP$COMPARE_ITEM_DESCRIPTOR (PUT_ENTRY_A, CAT_HEADER_A,
{         PUT_ENTRY_B, CAT_HEADER_B, A_EQUALS_B, A_ABOVE_B)
{
{ PUT_ENTRY_A: (input) This is the entry  describing  the  entry  type,  entry
{       name, and possibly cycle selector.
{
{ CAT_HEADER_A:  (input)  This  is  the catalog header that describes the full
{       path to the item.
{
{ PUT_ENTRY_B: (input) This is the entry for the second item.
{
{ CAT_HEADER_B: (input) This is the path to the second item.
{
{ A_EQUALS_B: (output) This indicates whether the two descriptors describe the
{       same item in the catalog tree.
{
{ A_ABOVE_B:  (output) This indicates whether item A is above (as in closer to
{       the root) B in the permanent file catalog tree.
{
{
*DECK DECK=PUH$COMPARE_PATHS EXPAND=FALSE
{
{   The purpose  of  this  request  is  to compare two permanent file paths to
{ determine if the two paths are equal, or if path A is above path B,  in  the
{ catalog  tree.   For example, if path A = DOG.CAT, and path B = DOG.CAT.FRED
{ then the result will be that A is not equal B, and A is above B.
{
{       PUP$COMPARE_PATHS (PATH_A, PATH_B, A_EQUALS_B, A_ABOVE_B)
{
{ PATH_A: (input) This describes the first permanent file path.
{
{ PATH_B: (input) This describes the second permanent file path.
{
{ A_EQUALS_B: (output) This returns whether the two paths are equal.
{
{ A_ABOVE_B: (output) This returns whether path A is above (that is parent  or
{       grandparent of) path B.
{
{
*DECK DECK=PUH$DETERMINE_IF_ITEM_EXISTS EXPAND=FALSE
{
{   The purpose  of  this request is to determine if an item (catalog, file or
{ cycle) currently exists in the permanent file catalog.
{
{       PUP$DETERMINE_IF_ITEM_EXISTS (PATH, ITEM_TO_DETERMINE,
{         CYCLE_LEVEL_SELECTED,
{         CYCLE_SELECTOR, ITEM_EXISTS, ITEM_TYPE, STATUS)
{
{ PATH: (input) This parameter specifies the permanent file path to be used.
{
{ ITEM_TO_DETERMINE: (input)  This  parameter  specifies  which  item  in  the
{       permanent  file  path  is  to  be  checked.  This can be a number from
{       LOWERBOUND  (path)  to  UPPERBOUND(path).   This  is   not   used   if
{       cycle_level_selected.
{
{ CYCLE_LEVEL_SELECTED:  (input) This specifies whether the item to check is a
{       cycle.  If this is specified as TRUE the full  path  as  specified  is
{       used,  as  well as the cycle selector parameter.  If this parameter is
{       FALSE  then  the  item_to_determine  parameter  is   used,   and   the
{       cycle_selector parameter is ignored.
{
{ CYCLE_SELECTOR:  (input)  This  specifies the permanent file cycle.  This is
{       only used if cycle_level_selected.
{
{ ITEM_EXISTS: (output) This parameter returns whether the item was  found  in
{       the current permanent file system.
{
{ ITEM_TYPE: (output) If the item exists then this returns whether the item is
{       a family, catalog, file, or cycle entry.
{
{ STATUS: (output) This parameter returns the request  status.   Possible  bad
{       conditions  may  be  caused  by  the (item_to_determine - 1) level not
{       currently existing.
{
{       CONDITIONS:
{
{       IDENTIFIER: puc$pf_utility_id
{
*DECK DECK=PUH$DETERMINE_PATH EXPAND=FALSE
{
{   The purpose  of  this  procedure  is  to determine if a path exists in the
{ permanent file catalog system.  If the path does exist the type of the  path
{ (catalog  or permanent file) is returned.  If the parent (or grandparent) of
{ the item to determine does not exist, then an error status is returned.
{
{       PUP$DETERMINE_PATH_EXISTENCE (PATH, ITEM_TO_DETERMINE, PATH_EXISTS,
{         PATH_TYPE, STATUS)
{
{ PATH: (input) This parameter specifies the permanent file catalog path.
{
{ ITEM_TO_DETERMINE:  (input)  This parameter specifies which item in the path
{       is to be checked for current existence.
{
{ PATH_EXISTS: (output) This parameter returns whether the item  to  determine
{       exists in the current permanent file catalog.
{
{ PATH_TYPE:  (output)  This  parameter  returns  the  type  of  the  item, IF
{       path_exists.
{
{ STATUS: (output) This parameter returns the request  status.   Possible  bad
{       status  may be returned if item_to_determine - n (where n>=1) does not
{       exists in the permanent file catalog.
{
{       CONDITIONS:
{
{       IDENTIFIER: puc$pf_utility_id
{
*DECK DECK=PUH$FIND_CYCLE_ENTRY EXPAND=FALSE
{
{   The purpose  of  this  interface  is to call the permanent file manager to
{ obtain a cycle array entry for the specified permanent file cycle.
{
{       PUP$FIND_CYCLE_ENTRY (PATH, CYCLE_SELECTOR, CYCLE_ENTRY, STATUS)
{
{ PATH: (input) This parameter specifies the name of the permanent file.
{
{ CYCLE_SELECTOR:  (input)  This  parameter  specifies  the   specific   cycle
{       desired.
{
{ CYCLE_ENTRY:  (output) This parameter returns the permanent file cycle array
{       entry for the specified cycle.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: puc$pf_utility_id
{
*DECK DECK=PUH$FIND_RESTORE_ENTRY EXPAND=FALSE
{
{   The purpose  of  this procedure is to find an item on the backup file.  An
{ item is described by a permanent file utility  entry,  and  catalog  header.
{ The  backup  file  is assumed open prior to this call.  If the item is found
{ the backup file is left positioned just after the item  descriptor  for  the
{ found  entry.  If the item is not found on the backup file (and there are no
{ IO errors on the backup file) the status condition of pue$no_restore_no_find
{ is returned, and the backup file is left positioned at puc$eoi.
{
{       PUP$FIND_RESTORE_ENTRY (ENTRY, CATALOG_HEADER, BACKUP_FILE_ID,
{         FILE_POSITION, STATUS)
{
{ ENTRY: (input) This parameter specifies  the  permanent  file  entry.   This
{       describes  the type of the item; set, family, catalog, permanent file,
{       or cycle.  If the item is a cycle it includes the cycle number for the
{       permanent file.
{
{ CATALOG_HEADER:  (input) This parameter specifies the catalog header for the
{       item.  This is merely the set name and permanent file path.
{
{ BACKUP_FILE_ID: (input, output) This parameter specifies the pf utility file
{       identifier for the backup file.
{
{ FILE_POSITION:  (output)  This  parameter  returns the file position for the
{       backup file.  If the item was not found on the  backup  file,  a  file
{       position of puc$eoi is returned.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: pue$incompatible_backup_version
{                   pue$no_restore_no_find
{                   pue$unexpected_item_requested
{
{       IDENTIFIER: puc$pf_utility_id
{
*DECK DECK=PUH$GET_FILE_PASSWORD EXPAND=FALSE
{
{   The purpose of this routine is to return the file password for a file.  If
{ the user is not permitted to know this password, or if the file path is  not
{ a  file  the  caller  has  access to, osc$null_name will be returned for the
{ password.
{
{       PUP$GET_FILE_PASSWORD (FILE_PATH, PASSWORD)
{
{ FILE_PATH: (input) This parameter specifies the name of the  permanent  file
{       whose password is to be obtained.
{
{ PASSWORD:  (output)  This parameter returns the file password.  If any error
{       occurred, or if the requester is not permitted to  the  password  then
{       osc$null_name is returned.
{
*DECK DECK=PUH$GET_PART EXPAND=FALSE
{
{   The purpose of this procedure is to read from the backup file.  This reads
{ working_storage_length bytes into the area specified by the working  storage
{ area.
{
{       PUP$GET_PART (BACKUP_FILE_ID, WORKING_STORAGE_AREA,
{         WORKING_STORAGE_LENGTH,
{         FILE_POSITION, STATUS)
{
{ BACKUP_FILE_ID:  (input, output) This parameter specifies the identifier for
{       the   backup   file.    This   identifier   was   returned   on    the
{       pup$open_backup_file request.
{
{ WORKING_STORAGE_AREA:  (output)  This  parameter  specifies a pointer to the
{       area where the data is to  be  read  into  (the  destination  for  the
{       data).
{
{ WORKING_STORAGE_LENGTH:  (input)  This parameter specifies how many bytes of
{       data to read from the backup file.
{
{ FILE_POSITION: (output) This parameter returns the permanent file  utilities
{       file position.
{       puc$partition_boundary indicates that all data has  been  gotten  from
{       this logical partition.  puc$eoi indicates that we have read up to the
{       end of the backup file.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: pue$unusable_restore_file
{                   This indicates that the transfer count returned was
{                   different that working storage length requested.
{
{       IDENTIFIER: puc$pf_utility_id
{
*DECK DECK=PUH$OPEN_BACKUP_FILE EXPAND=FALSE
{
{   The purpose  of  this  request  is to open a permanent file utility backup
{ file.  The permanent file utility file identifier  is  initialized  on  this
{ request and should be used on subsequent input/output requests on the backup
{ file.
{
{       PUP$OPEN_BACKUP_FILE (BACKUP_FILE_LFN, OPEN_POSITION, FILE_ID, STATUS)
{
{ BACKUP_FILE_LFN: (input) This parameter specifies the  name  of  the  backup
{       file.  This must be either a mass storage, null, or magnetic tape file.
{
{ OPEN_POSITION:  (input)  This parameter specifies the position that the file
{       is to be opened at.  Either amc$open_no_positioning,  amc$open_at_boi,
{       or   amc$open_at_eoi.   If  the  backup  file  is  a  tape  file  then
{       amc$open_no_positioning means at the  start  of  the  last  file,  and
{       amc$open_at_boi means at the start of the first volume.
{
{ FILE_ID:  (output)  This  parameter  returns the permanent file utility file
{       identifier that is used on  all  subsequent  requests  on  the  backup
{       file.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: pue$invalid_device_type
{
{       IDENTIFIER: puc$pf_utility_id
{
*DECK DECK=PUH$OPEN_FILE_FOR_SEG_ACCESS EXPAND=FALSE
{
{   This routine  opens  a  file  for  segment  access.   The  pointer that is
{ returned is a sequence pointer and has  been  reset.   This  routine  avoids
{ loading  any  file  access procedure, error exit procedure, or collate table
{ associated with the file.  The permanent file label is not  written  to  the
{ catalog as a result of this call.
{
{       PUP$OPEN_FILE_FOR_SEG_ACCESS (LFN, SEGMENT_POINTER, STATUS)
{
{ LFN: (input) This parameter specifies the name of the file to open.
{
{ SEGMENT_POINTER: (output) This returns the segment  pointer  for  the  file.
{       This is a mmc$segment pointer.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: puc$pf_utility_id
{
*DECK DECK=PUH$RESTORE_CYCLE_ITEM EXPAND=FALSE
{
{   The purpose  of  this request is to restore a cycle item, cycle label, and
{ cycle data.  The backup_file is assumed to  be  positioned  after  the  item
{ descriptor  for the cycle (before the cycle_array_entry).  The requester has
{ the option of choosing whether the cycle_array_entry should be put.
{
{       PUP$RESTORE_CYCLE_ITEM (FILE_ENTRY, NEW_FILE_NAME_PATH,
{         NEW_FILE_NAME_CYCLE_SELECTOR, PASSWORD, CONTINUE_IF_CYCLE_EXISTS,
{         BACKUP_FILE_ID, FILE_POSITION, STATUS)
{
{ FILE_ENTRY: (input) This parameter  specifies  the  permanent  file  utility
{       entry, as found on the backup file.
{
{ NEW_FILE_NAME_PATH:  (input)  This  parameter  specifies  the  name  of  the
{       permanent file to be used online.
{
{ NEW_FILE_NAME_CYCLE_SELECTOR: (input) This  parameter  specifies  the  cycle
{       selector to be used online.
{
{ PASSWORD:  (input)  This  parameter  specifies  the  password  to be used in
{       restoring the cycle.
{
{ CONTINUE_IF_CYCLE_EXISTS:  (input)  This  parameter  specifies  whether  the
{       process  should  continue if the cycle array entry already exists.  If
{       this is specified as TRUE, the processing will continue if  the  cycle
{       array  entry  already  exists.   If this is FALSE, then all processing
{       terminates if the cycle already exists.  In both cases data  must  NOT
{       already be defined for the cycle.
{
{ BACKUP_FILE_ID: (input, output) This parameter specifies the backup file.
{
{ FILE_POSITION:  (output)  This  parameter  returns  the  file position, as a
{       result of this request.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: puc$pf_utility_id
{
*DECK DECK=PUH$RESTORE_ITEM_INFO EXPAND=FALSE
{
{   The purpose of this procedure is to restore the item_info for a catalog or
{ permanent file.  The item_info was originally obtained  from  the  permanent
{ file get info interfaces, and is viewed as a black box to the permanent file
{ utilities.  The item info contains information  about  the  permits  on  the
{ catalog  or  file.   If the item is a catalog, restoring this item_info does
{ NOT restore subfiles, or cause them to be registered in the catalog.  If the
{ item is a permanent file though, restoring this WILL causes all cycles to be
{ registered in the permanent file catalog, although the data for  the  cycles
{ is  not  restored  yet.   This  procedure assumes that the given catalog has
{ already  been  found  on   the   backup_file   (for   example,   using   the
{ pup$find_restore_entry  interface) and the backup file is assumed positioned
{ immediately after the  item_descriptor  for  the  item.   The  item_info  is
{ assumed  to  be next.  If the restore is successful the multi_item_info (for
{ catalogs) and hierarchy_list are skipped.  The caller of this  interface  is
{ assumed to have constructed the new name to be used online.
{
{       PUP$RESTORE_ITEM_INFO (NEW_ONLINE_CAT_HEAD, CATALOG, BACKUP_FILE,
{         FILE_POSITION, STATUS)
{
{ NEW_ONLINE_CAT_HEAD: (input) This parameter specifies the name that is to be
{       used as the name in restoring the item.
{
{ CATALOG:  (input)  This  parameter  specifies  whether  the  item is to be a
{       catalog or permanent file.  This interface can not used for cycles.
{
{ BACKUP_FILE:   (input,   output)   This   parameter   specifies   the   file
{       identification of the backup file.
{
{ FILE_POSITION:  (output)  This  parameter  returns  the file position of the
{       backup file after the request is complete.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: puc$pf_utility_id
{
*DECK DECK=PUH$RESTORE_SUB_LEVELS EXPAND=FALSE
{
{    The purpose of this procedure is to restore all items on the backup file
{ at or below a specified object in the permanent file catalog.  Items that
{ already exist in the catalog are not restored and are skipped over on the
{ backup file.  The backup file is assumed to have been opened and to be
{ positioned at the start of a logical partition.  The backup file is left
{ positioned at PUC$EOI.
{
{       PUP$RESTORE_SUB_LEVELS (ENTRY, CATALOG_HEADER, PASSWORD_SPECIFIED,
{             PASSWORD, NEW_CATALOG_HEADER, RESTORE_N_LEVELS,
{             P_SELECTED_CYCLES, BACKUP_FILE_ID, STATUS)
{
{ ENTRY: (input)  This parameter specifies the name of the object on the backup
{       file that is to be restored.
{
{ CATALOG_HEADER: (input)  This parameter specifies the catalog path of the
{       objects on the backup file that are to be restored.
{
{ NEW_CATALOG_HEADER: (input)  This parameter specifies the catalog to which
{       the objects are to be restored.
{
{ PASSWORD_SPECIFIED: (input)  This parameter specifies whether or not a
{       password is provided.
{
{ PASSWORD: (input)  This parameter specifies the password if it is provided.
{
{ RESTORE_N_LEVEL: (input)  If TRUE is specified for this parameter, an attempt
{       will be made to restore the objects specified by the ENTRY and
{       CATALOG_HEADER parameters.  If FALSE is specified, then only items
{       below the specified object will be restored.
{
{       For example if the ENTRY and CATALOG_HEADER parameters are specified as
{       A.B, the NEW_CATALOG_HEADER parameter is specified as A.B.C,
{       RESTORE_N_LEVELS is specified as TRUE and A.B was found on the backup
{       file, an attempt will be made to restore the object to A.B.C.
{       Irregardless of this parameter, if A.B.D is found on the backup file,
{       an attempt will be made to restore it.
{
{ P_SELECTED_CYCLES: (input, output)  This parameter provides a list of cycle
{       pairs (backup file cycle and new file cycle) for each cycle of a file
{       object that is to be restored.
{
{ BACKUP_FILE_ID: (input, output)  This parameter specifies the file identifier
{       of the backup file.
{
{ STATUS: (ouput) This parameter specifies the request status.
{       CONDITION:
{                   pue$incompatible_backup_version
{                   pue$no_restore_no_find
{
*DECK DECK=PUH$REWIND_BACKUP_FILE EXPAND=FALSE
{
{   This procedure rewinds the permanent file utility backup file.  The backup
{ file must not be open when this procedure is called.  If the file is a  tape
{ file  which  has  not  previously  been  opened within current the job, this
{ request will cause the volume associated with the tape file to be mounted.
{
{       PUP$REWIND_BACKUP_FILE (BACKUP_FILE, STATUS)
{
{ BACKUP_FILE: (input) This parameter specifies the name of the backup file to
{       be rewound.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: puc$pf_utility_id
{
*DECK DECK=PUH$SKIP_LOGICAL_PARTITION EXPAND=FALSE
{
{   The purpose  of  this procedure is to skip to the next backup file logical
{ partition.  This routine can be called independent of what device the backup
{ file  resides  on.   If  the  skip  encounters  end  of information the file
{ position of puc$eoi will be returned.
{
{       PUP$SKIP_LOGICAL_PARTITION (BACKUP_FILE_ID, FILE_POSITION, STATUS)
{
{ BACKUP_FILE_ID: (input, output) This parameter specifies the  identification
{       of the backup file.
{
{ FILE_POSITION: (output) This parameter returns the file position as a result
{       of the skip.  In general  this  is  either  puc$partition_boundary  or
{       puc$eoi.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: puc$pf_utility_id
{
*DECK DECK=PUH$VALIDATE_N_N_MINUS_1 EXPAND=FALSE
{
{   This procedure  verifies that the N level of the given path exists online,
{  and that the N - 1 level does NOT exist online.  This is of primary use for
{  the RESTORE_PERMANENT_FILE utility.
{
{       PUP$VALIDATE_N_N_MINUS_1 (PATH, N_TYPE, CYCLE_SELECTOR,
{         STATUS)
{
{ PATH: (input) This parameter specifies the path to the file or catalog.
{
{ N_TYPE: (input) This specifies the expected type of the N item in the path.
{      If this is puc$valid_cycle_entry the cycle_selector is used
{
{ CYCLE_SELECTOR: (input) This specifies a permanent file cycle selector.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{                   pue$new_file_already_exists
{                   pue$new_cycle_already_exists
{                   pue$n_minus_1_doesnt_exist
{
{       IDENTIFIER: puc$pf_utility_id
{
*DECK DECK=PUH$VERIFY_CATALOG_PATH EXPAND=FALSE
{
{   The purpose of this procedure is to verify that a catalog as designated by
{ a catalog path exists in the current permanent file catalog system.  A error
{ condition is returned if the path describes a file instead of a catalog.
{
{       PUP$VERIFY_CATALOG_PATH (CATALOG_PATH, STATUS)
{
{ CATALOG_PATH: (input) This parameter specifies the catalog to check.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: pue$path_not_catalog
{                   pue$item_doesnt_exist
{
{       IDENTIFIER: puc$pf_utility_id
{
*DECK DECK=PUH$VERIFY_FILE_PATH EXPAND=FALSE
{
{   The purpose  of this procedure is to verify that a file as designated by a
{ file path exists in the current permanent file system.  A error condition is
{ returned if the path describes a file instead of a file.
{
{       PUP$VERIFY_FILE_PATH (FILE_PATH, STATUS)
{
{ FILE_PATH: (input) This parameter specifies the file to check.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: pue$path_not_file
{                   pue$item_doesnt_exist
{
{       IDENTIFIER: puc$pf_utility_id
{
*DECK DECK=PUM$ADVISED_IO EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  advised_io ', EJECT ??
MODULE pum$advised_io;
{
{   This module contains those procedures that manage puts, and gets from
{ the backup file in an "advised" manner.  For gets this implies that the
{ access to the destination wsa is sequential, that is, once gotten, there is
{ not a need to rereference the data.  For puts this implies that the
{ access from the source wsa is sequential.  These routines interfaces to
{ the mmp$advise_in, and mmp$advise_out_in request, as a means of assisting the OS in
{ managing pages, and hence improving performance.
{   The use of static variables allows advising parameters to be changed.
{ ADVISE_SELECTED: indicates whether advising should be done.
{ MINIMUM_SIZE: This indicates the minimum size gets or puts that should be
{   advised.
{ ADVISE_SIZE:  This indicates the amount of data that should be read at
{   one time.  Each get or put is broken up into repeated gets/ put of this
{   size.
{ ADVISE_LOOK_AHEAD This indicates the number of blocks of data of size
{   advise size that should be advised in initially.  This allows the advise
{   to actually bring the pages in from disk before the data is read.  Subsequent
{   advisings are of units of advise_size, but are for pages to be read on the
{   next + advise_look_ahead - 1   read.
{ FREE_BEHIND: This indicates whether the free behind attribute should be
{   set on the segment at open time.
{ ADVISE_IN_WHILE_RESTORING: When true advise_out_in is done, when false
{   only advise_out is done.
{
{ EXAMPLE:
{   Suppose we have the file
{   ABCDEF
{     if the advise_look_ahead was 3, and the advise_size was one character
{     we would initially advise in:
{   ABC
{     then read
{   A
{     then advise out A,  advise in D
{  and so on through the file.
{  IF advise_look_ahead is set to 1, the pages are advised just prior to
{  reading the data.
{ With this algorithm the page is always advised_out immediatly after being
{ read.  This is done since there is no need to go backwards and read the data.  If the file
{ was record access, there might be a need to go back and update the
{ previous record header, in that case a revised free behind stategy should be used.
{


?? NEWTITLE := '   Global Declarations', EJECT ??
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc i#ptr
*copyc mmp$advise_in
*copyc mmp$advise_out
*copyc mmp$advise_out_in
*copyc mmp$touch_all_pages
*copyc pup$crack_boolean
*copyc pup$display_integer
*copyc pup$display_line
*copyc pup$display_volume_switch
*copyc pup$get_part
*copyc pup$put_next
*copyc pup$put_partial
*copyc puv$bacpf_cycle_data_total
*copyc puv$trace_selected
?? TITLE := '    Global Variables', EJECT ??

  VAR
    advise_in_while_restoring: boolean := TRUE,
    advise_selected: boolean := TRUE,
    minimum_size_to_advise: amt$working_storage_length := 4000(16),
    advise_size: amt$working_storage_length := 18000(16),
    advise_look_ahead: integer := 3;

  VAR
    puv$free_behind_selected :[XDCL] boolean := FALSE;

?? TITLE := '    [XDCL] pup$advised_get_part ', EJECT ??

  PROCEDURE [XDCL] pup$advised_get_part
    (VAR bfid: put$file_identifier;
         wsa: ^cell;
         wsl: amt$working_storage_length;
     VAR file_position: put$file_position;
     VAR transfer_count: amt$file_length;
     VAR status: ost$status);

    VAR
      advise_in_length: integer,
      advise_in_wsa: ^cell,
      ignored_status: ost$status,
      move_wsa: ^cell,
      move_wsl: integer,
      next_move_wsa: ^cell,
      next_move_wsl: integer,
      partial_transfer_count: amt$file_length,
      total_advised_in: integer,
      total_wsl_moved: integer;

    transfer_count := 0;

    IF (NOT advise_selected) OR (wsl < minimum_size_to_advise) THEN
      display (' not advising');
      pup$get_part (bfid, wsa, wsl, file_position, transfer_count, status);
    ELSE
      display_integer (' pup$advised_get_part wsl:', wsl);
      total_wsl_moved := 0;
      IF wsl <= advise_size THEN
        move_wsl := wsl;
      ELSE
        move_wsl := advise_size;
      IFEND;
      move_wsa := wsa;

      IF advise_in_while_restoring THEN
        advise_in_length := min ((wsl - total_wsl_moved), (advise_size * advise_look_ahead));
        advise_in_wsa := wsa;
        display_integer ('  mmp$advise_in : ', advise_in_length);
        mmp$advise_in (advise_in_wsa, advise_in_length, status);
        IF NOT status.normal THEN
          display_status (status);
          RETURN;
        IFEND;
        total_advised_in := advise_in_length;
      IFEND;

      next_move_wsl := move_wsl;
      REPEAT
        pup$get_part (bfid, move_wsa, move_wsl, file_position, partial_transfer_count, status);
        transfer_count := transfer_count + partial_transfer_count;
        IF NOT status.normal OR (file_position = puc$eoi) THEN
          IF NOT status.normal THEN
            pup$display_integer (' NOT ABLE TO READ ALL DATA, READ: ', total_wsl_moved, ignored_status);
          IFEND;
          RETURN;
        IFEND;
        total_wsl_moved := total_wsl_moved + move_wsl;
        next_move_wsa := i#ptr (total_wsl_moved, wsa);
        IF (total_wsl_moved + next_move_wsl) >= wsl THEN
          next_move_wsl := wsl - total_wsl_moved;
        IFEND;
        IF advise_in_while_restoring THEN
          advise_in_wsa := i#ptr (total_advised_in, wsa);
          advise_in_length := min ((wsl - total_advised_in), advise_size);
          display_integer (' mmp$advise_out_in   out:', move_wsl);
          display_integer ('     in: ', advise_in_length);
          mmp$advise_out_in (move_wsa, move_wsl, advise_in_wsa, advise_in_length, status);
          IF NOT status.normal THEN
            display_status (status);
            RETURN;
          IFEND;
          total_advised_in := total_advised_in + advise_in_length;
        ELSE
          mmp$advise_out (move_wsa, move_wsl, status);
        IFEND;
        move_wsa := next_move_wsa;
        move_wsl := next_move_wsl;
      UNTIL (total_wsl_moved >= wsl);
    IFEND;

    IF (bfid.device_class = rmc$magnetic_tape_device) AND status.normal THEN
      pup$display_volume_switch (bfid);
    IFEND;

  PROCEND pup$advised_get_part;

?? TITLE := '    [XDCL] pup$advised_put_next ', EJECT ??

  PROCEDURE [XDCL] pup$advised_put_next (VAR bfid: put$file_identifier;
        wsa: ^cell;
        wsl: amt$working_storage_length;
    VAR status: ost$status);

{
{  This procedure breaks up a put_next into "advised" amount.
{  A put_next is equivalent to:
{     -  put_partial term_option=amc$terminate
{  or
{     -  put_partial term_option=amc$start
{        followed by 0 .. N put_partial term_option=amc$continue
{        finally put_partial term_option=amc$terminate

    CONST
      check_volume_switch_interval = 10000000;

    VAR
      advise_in_length: integer,
      advise_in_wsa: ^cell,
      ignored_status: ost$status,
      move_wsa: ^cell,
      move_wsl: integer,
      next_move_wsa: ^cell,
      next_move_wsl: integer,
      term_option: amt$term_option,
      total_advised_in: integer,
      volume_switch_count: integer;

    puv$bacpf_cycle_data_total := 0;
    #SPOIL (puv$bacpf_cycle_data_total);
    IF (NOT advise_selected) OR (wsl < minimum_size_to_advise) THEN
      display (' not advising');
      mmp$touch_all_pages (wsa, wsl);
      pup$put_next (bfid, wsa, wsl, status);
    ELSE
      display_integer (' pup$advised_put_next wsl:', wsl);
      IF wsl <= advise_size THEN
        term_option := amc$terminate;
        move_wsl := wsl;
      ELSE
        term_option := amc$start;
        move_wsl := advise_size;
      IFEND;
      move_wsa := wsa;

      { compute initial advise in amount
      advise_in_length := min ((wsl - puv$bacpf_cycle_data_total), (advise_size * advise_look_ahead));
      advise_in_wsa := wsa;
      display_integer ('  mmp$advise_in : ', advise_in_length);
      mmp$advise_in (advise_in_wsa, advise_in_length, status);
      IF NOT status.normal THEN
        display_status (status);
        RETURN;
      IFEND;
      total_advised_in := advise_in_length;

      volume_switch_count := 0;
      next_move_wsl := move_wsl;
      REPEAT
        mmp$touch_all_pages (move_wsa, move_wsl);
        pup$put_partial (bfid, move_wsa, move_wsl, term_option, status);
        IF NOT status.normal THEN
          pup$display_integer (' UNABLE TO WRITE ALL DATA, WROTE:', puv$bacpf_cycle_data_total,
               ignored_status);
          RETURN;
        IFEND;

        puv$bacpf_cycle_data_total := puv$bacpf_cycle_data_total + move_wsl;
        #SPOIL (puv$bacpf_cycle_data_total);
        next_move_wsa := i#ptr (puv$bacpf_cycle_data_total, wsa);
        IF (puv$bacpf_cycle_data_total + next_move_wsl) >= wsl THEN
          term_option := amc$terminate;
          next_move_wsl := wsl - puv$bacpf_cycle_data_total;
        ELSE
          term_option := amc$continue;
        IFEND;
        advise_in_wsa := i#ptr (total_advised_in, wsa);
        advise_in_length := min ((wsl - total_advised_in), advise_size);
        display_integer (' mmp$advise_out_in   out:', move_wsl);
        display_integer ('     in: ', advise_in_length);
        mmp$advise_out (move_wsa, move_wsl, status);
        IF NOT status.normal THEN
          display_status (status);
          RETURN;
        IFEND;

        total_advised_in := total_advised_in + advise_in_length;
        volume_switch_count := volume_switch_count + move_wsl;
        move_wsa := next_move_wsa;
        move_wsl := next_move_wsl;

        IF (volume_switch_count > check_volume_switch_interval) AND
              (bfid.device_class = rmc$magnetic_tape_device) THEN
          pup$display_volume_switch (bfid);
          volume_switch_count := 0;
        IFEND;
      UNTIL (puv$bacpf_cycle_data_total >= wsl);
    IFEND;
  PROCEND pup$advised_put_next;

?? TITLE := '    [XDCL] pup$display_advise_cmd ', EJECT ??

  PROCEDURE [XDCL] pup$display_advise_cmd (parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? RIGHT := 110 ??
{
{
{
{ pdt disac_pdt (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      disac_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^disac_pdt_names,
        ^disac_pdt_params];

    VAR
      disac_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
        clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      disac_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??
    clp$scan_parameter_list (parameter_list, disac_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_advise_selections;
  PROCEND pup$display_advise_cmd;

?? TITLE := '    [XDCL] pup$select_advise_in_cmd ', EJECT ??

  PROCEDURE [XDCL] pup$select_advise_in_cmd (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{ pdt advise_in_pdt (advise, a: boolean = true
{  minimum_size, ms: integer = 4000(16)
{  advise_size, as: integer = 18000(16)
{  advise_look_ahead, ala: integer 0 .. 10 = 3
{  free_behind, fb: boolean = false
{  advise_in_while_restoring, aiwr: boolean = true
{  status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    advise_in_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^advise_in_pdt_names,
  ^advise_in_pdt_params];

  VAR
    advise_in_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 13] of
  clt$parameter_name_descriptor := [['ADVISE', 1], ['A', 1], ['MINIMUM_SIZE', 2], ['MS', 2], ['ADVISE_SIZE', 3
  ], ['AS', 3], ['ADVISE_LOOK_AHEAD', 4], ['ALA', 4], ['FREE_BEHIND', 5], ['FB', 5], [
  'ADVISE_IN_WHILE_RESTORING', 6], ['AIWR', 6], ['STATUS', 7]];

  VAR
    advise_in_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 7] of clt$parameter_descriptor := [

{ ADVISE A }
    [[clc$optional_with_default, ^advise_in_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ MINIMUM_SIZE MS }
    [[clc$optional_with_default, ^advise_in_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, clc$min_integer, clc$max_integer]],

{ ADVISE_SIZE AS }
    [[clc$optional_with_default, ^advise_in_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, clc$min_integer, clc$max_integer]],

{ ADVISE_LOOK_AHEAD ALA }
    [[clc$optional_with_default, ^advise_in_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, 0, 10]],

{ FREE_BEHIND FB }
    [[clc$optional_with_default, ^advise_in_pdt_dv5], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ ADVISE_IN_WHILE_RESTORING AIWR }
    [[clc$optional_with_default, ^advise_in_pdt_dv6], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    advise_in_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

  VAR
    advise_in_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (8) := '4000(16)';

  VAR
    advise_in_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (9) := '18000(16)';

  VAR
    advise_in_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '3';

  VAR
    advise_in_pdt_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';

  VAR
    advise_in_pdt_dv6: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      local_advise_in_while_restoring: boolean,
      local_advise_selected: boolean,
      local_advise_size: amt$working_storage_length,
      local_free_behind: boolean,
      local_minimum: amt$working_storage_length,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, advise_in_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_boolean ('ADVISE', local_advise_selected, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_boolean ('FREE_BEHIND', local_free_behind, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF local_advise_selected THEN
      clp$get_value ('MINIMUM_SIZE', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      local_minimum := value.int.value;

      clp$get_value ('ADVISE_SIZE', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      local_advise_size := value.int.value;

      clp$get_value ('ADVISE_LOOK_AHEAD', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      pup$crack_boolean ('ADVISE_IN_WHILE_RESTORING', local_advise_in_while_restoring, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      advise_look_ahead := value.int.value;
      advise_selected := TRUE;
      minimum_size_to_advise := local_minimum;
      advise_in_while_restoring := local_advise_in_while_restoring;
      advise_size := local_advise_size;
    ELSE
      advise_selected := FALSE;
    IFEND;
    puv$free_behind_selected := local_free_behind;
    display_advise_selections;
  PROCEND pup$select_advise_in_cmd;


?? TITLE := '    display_advise_selections ', EJECT ??

  PROCEDURE display_advise_selections;

    VAR
      status: ost$status;

    IF advise_selected THEN
      pup$display_line (' ADVISE = TRUE', status);
      pup$display_integer (' MINIMUM_SIZE ', minimum_size_to_advise, status);
      pup$display_integer (' ADVISE_SIZE', advise_size, status);
      pup$display_integer (' ADVISE LOOK AHEAD ', advise_look_ahead, status);
      IF advise_in_while_restoring THEN
        pup$display_line (' ADVISE_IN_WHILE_RESTORING= TRUE', status);
      ELSE
        pup$display_line (' ADVISE_IN_WHILE_RESTORING= FALSE.', status);
      IFEND;
    ELSE
      pup$display_line (' ADVISE = FALSE.', status);
    IFEND;
    IF puv$free_behind_selected THEN
      pup$display_line (' FREE_BEHIND = TRUE', status);
    ELSE
      pup$display_line (' FREE_BEHIND = FALSE.', status);
    IFEND;
  PROCEND display_advise_selections;


?? TITLE := '    [INLINE] min ', EJECT ??

  FUNCTION [INLINE] min (number_one: integer;
        number_two: integer): integer;

    IF number_one < number_two THEN
      min := number_one;
    ELSE
      min := number_two;
    IFEND;
  FUNCEND min;
MODEND pum$advised_io;
*DECK DECK=PUM$BACKUP_CATALOG EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  backup_catalog ', EJECT ??
MODULE pum$backup_catalog;
{PURPOSE:
{     This module contains the procedures which produce a BACKUP copy
{  of a specified catalog as well as a BACKUP copy of each subcatalog,
{  file, and cycle which is registered in the subsequent tree structure
{  of the specified catalog.
?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avp$system_administrator
*copyc clp$scan_parameter_list
*copyc clt$file
*copyc fst$path
*copyc fst$path_size
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc ofp$display_status_message
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc ost$caller_identifier
*copyc ost$name
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pft$cycle_reservation_criteria
*copyc pfp$convert_pf_path_to_fs_path
*copyc pfp$convert_pft$path_to_string
*copyc pfp$detach_reserved_cycles
*copyc pfp$find_direct_info_record
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_family_set
*copyc pfp$get_item_info
*copyc pfp$get_multi_item_info
*copyc pfp$get_reserved_item_info
*copyc pud$backup_file
*copyc pud$hierarchy_list
*copyc pup$abort_output
*copyc pup$backup_family_request
*copyc pup$backup_file
*copyc pup$build_catalog_header
*copyc pup$build_entry
*copyc pup$build_hierarchy_list
*copyc pup$build_new_catalog_header
*copyc pup$check_if_item_excluded
*copyc pup$check_if_subitem_excluded
*copyc pup$crack_catalog
*copyc pup$display_backup_output_total
*copyc pup$display_excluded_item
*copyc pup$excluded_highest_cycles
*copyc pup$get_status_severity
*copyc pup$get_summary_status
*copyc pup$initialize_backup_listing
*copyc pup$output_catalog
*copyc pup$verify_catalog_path
*copyc pup$verify_family_administrator
*copyc pup$write_catalog_header
*copyc pup$write_os_status
*copyc pup$write_status_to_listing
*copyc put$file_identifier
*copyc puv$backup_criteria
*copyc puv$backup_information
*copyc puv$backup_file_id
*copyc puv$bacpf_backup_file_version
*copyc puv$global_backup_file_id
*copyc puv$include_archive_information
*copyc puv$include_data_options
*copyc puv$include_exceptions
*copyc puv$include_volumes_option
*copyc puv$maximum_cycle_size
*copyc puv$minimum_cycle_size
*copyc puv$p_included_volumes
*copyc puv$trace_selected
*copyc rmt$recorded_vsn
*copyc std$set_name
?? POP ??
?? TITLE := '    Global Variables', EJECT ??
?? TITLE := '    [XDCL] pup$backup_catalog ', EJECT ??

  PROCEDURE [XDCL] pup$backup_catalog (catalog_entry: put$entry;
        pf_utility_catalog_header: put$catalog_header;
        catalog_item_info: pft$p_info_record;
        pf_utility_hierarchy_list: put$hierarchy_list;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);
{PURPOSE:
{     this procedure produces a BACKUP copy of a specified catalog
{  as well as each file and cycle registered in the catalog.
{NOTE:
{     recursion is used in this procedure to process each subcatalog
{  registered in the specified catalog.

    VAR
      catalog_content_info: amt$segment_pointer,
      catalog_excluded: boolean,
      catalog_info: put$backup_item_info,
      cycle_selector: pft$cycle_selector,
      file_info_selections: pft$file_info_selections,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      group: pft$group,
      i: put$half_integer,
      ignore_status: ost$status,
      local_status: ost$status,
      message_length: integer,
      message_string: string (ofc$max_display_message),
      next_catalog_entry: put$entry,
      p_body: pft$p_info,
      p_catalog_directory: pft$p_directory_array,
      p_cycle_reservation_criteria: ^pft$cycle_reservation_criteria,
      p_file_description: pft$p_file_description,
      p_info_record: pft$p_info_record,
      p_item_record: pft$p_info_record,
      p_new_catalog_header: ^put$catalog_header,
      path_string: ost$string,
      permanent_file_excluded: boolean,
      pf_entry: put$entry,
      recorded_vsn: rmt$recorded_vsn,
      subitem_excluded: boolean;

    CONST
      for_catalog_string = 'for catalog',
      message_prefix = 'Backing up ',
      message_prefix_length = 11;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           ignore_condition_information: ^pmt$condition_information;
           ignore_save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      clean_up;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??
?? NEWTITLE := 'clean_up', EJECT ??

    PROCEDURE clean_up;

      IF p_cycle_reservation_criteria <> NIL THEN
        pfp$detach_reserved_cycles (local_status);
        p_cycle_reservation_criteria := NIL;
        #SPOIL (p_cycle_reservation_criteria);
      IFEND;

      IF catalog_content_info.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (catalog_content_info, local_status);
        catalog_content_info.sequence_pointer := NIL;
        #SPOIL (catalog_content_info.sequence_pointer);
      IFEND;

    PROCEND clean_up;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    local_status.normal := TRUE;
    p_cycle_reservation_criteria := NIL;
    catalog_content_info.kind := amc$sequence_pointer;
    catalog_content_info.sequence_pointer := NIL;
    #SPOIL (catalog_content_info, p_cycle_reservation_criteria);
    osp$establish_block_exit_hndlr (^abort_handler);

{
{ OUTPUT CATALOG ITEM
{

    pfp$convert_pft$path_to_string (pf_utility_catalog_header.path, path_string);

    message_string (1, ofc$max_display_message) := message_prefix;
    IF (path_string.size + message_prefix_length) > ofc$max_display_message THEN
      message_string (message_prefix_length + 1, ofc$max_display_message - message_prefix_length) :=
            path_string.value (1, ofc$max_display_message - message_prefix_length);
      message_string (ofc$max_display_message, 1) := '>';
    ELSE
      message_string (message_prefix_length + 1, path_string.size) := path_string.value (1, path_string.size);
    IFEND;

    ofp$display_status_message (message_string (1, ofc$max_display_message), ignore_status);

    pup$write_catalog_header (pf_utility_catalog_header, ignore_status);

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, catalog_content_info, status);
    IF status.normal THEN
      IF puv$bacpf_backup_file_version = puc$backup_file_version_1 THEN
        IF puv$include_archive_information THEN
          file_info_selections := - $pft$file_info_selections [pfc$file_cycles_version_2];
        ELSE
          file_info_selections :=
                - $pft$file_info_selections [pfc$archive_descriptors, pfc$file_cycles_version_2];
        IFEND;
      ELSEIF puv$bacpf_backup_file_version = puc$backup_file_version_2 THEN
        IF puv$include_archive_information THEN
          file_info_selections := - $pft$file_info_selections [pfc$file_cycles];
        ELSE
          file_info_selections :=
                - $pft$file_info_selections [pfc$archive_descriptors, pfc$file_cycles];
        IFEND;
      IFEND;

      IF avp$system_administrator () AND (puv$bacpf_backup_file_version = puc$backup_file_version_2) AND
            puv$include_exceptions THEN
        PUSH p_cycle_reservation_criteria;
        build_cycle_reservation_crit (p_cycle_reservation_criteria);
      IFEND;

      RESET catalog_content_info.sequence_pointer;
      group.group_type := pfc$public;

      pup$check_if_subitem_excluded (pf_utility_catalog_header, subitem_excluded);
      IF subitem_excluded THEN
        pfp$get_multi_item_info (pf_utility_catalog_header.path, group, - $pft$catalog_info_selections [],
              file_info_selections, catalog_content_info.sequence_pointer, status);
      ELSE
        pfp$get_reserved_item_info (pf_utility_catalog_header.path, group, - $pft$catalog_info_selections [],
              file_info_selections, p_cycle_reservation_criteria, catalog_content_info.sequence_pointer,
              status);
      IFEND;
      IF status.normal THEN
        RESET catalog_content_info.sequence_pointer;
        pfp$find_next_info_record (catalog_content_info.sequence_pointer, p_info_record, status);
        IF status.normal THEN
          catalog_info.item_type := puc$backup_item_catalog_info;
          catalog_info.catalog_item_info := catalog_item_info {single item info } ;
          pup$output_catalog (catalog_entry, pf_utility_catalog_header, catalog_info,
                pf_utility_hierarchy_list, pf_backup_file_id, status);
        IFEND;
        IF NOT status.normal THEN
          pup$abort_output (catalog_entry, pf_backup_file_id, status, local_status);
        IFEND;
      IFEND;
    IFEND;

{
    IF status.normal THEN
      pfp$find_directory_array (p_info_record, p_catalog_directory, status);
      IF status.normal AND (p_catalog_directory <> NIL) THEN
        PUSH p_new_catalog_header: [1 .. (UPPERBOUND (pf_utility_catalog_header.path) + 1)];
{
{
{        BACKUP SUB FILES
        FOR i := LOWERBOUND (p_catalog_directory^) TO UPPERBOUND (p_catalog_directory^) DO
          CASE p_catalog_directory^ [i].name_type OF
          = pfc$file_name =
            pup$build_entry (p_catalog_directory^ [i].name, cycle_selector, puc$valid_pf_entry, pf_entry);
            p_body := ^p_info_record^.body;
            pfp$find_direct_info_record (p_body, p_catalog_directory^ [i].info_offset, p_item_record, status);
            IF status.normal THEN
              pup$build_new_catalog_header (pf_entry, pf_utility_catalog_header, p_new_catalog_header^);
              pup$check_if_item_excluded (pf_entry, p_new_catalog_header^, permanent_file_excluded);
              IF permanent_file_excluded THEN
                pup$display_excluded_item (pf_entry, p_new_catalog_header^, status);
              ELSE
                pup$backup_file (pf_entry, {password_provided =} FALSE, osc$null_name, p_new_catalog_header^,
                      pf_utility_hierarchy_list, pf_backup_file_id, p_item_record, status);
              IFEND;
            IFEND;
            pup$write_status_to_listing (pf_entry, status, local_status);
            IF NOT puv$global_backup_file_id.backup_file_open THEN
              {
              { pup$backup_catalog encountered an error writing to the backup_file and closed it.
              { Return the abnormal status to the caller.
              {
              RETURN;
            IFEND;
            status.normal := TRUE;
          = pfc$catalog_name =
          ELSE
          CASEND;
        FOREND;

        IF p_cycle_reservation_criteria <> NIL THEN
          pfp$detach_reserved_cycles (status);
          p_cycle_reservation_criteria := NIL;
          #SPOIL (p_cycle_reservation_criteria);
        IFEND;
{
{
{        BACKUP SUB CATALOGS
        FOR i := LOWERBOUND (p_catalog_directory^) TO UPPERBOUND (p_catalog_directory^) DO
          CASE p_catalog_directory^ [i].name_type OF
          = pfc$catalog_name =
            pup$build_entry (p_catalog_directory^ [i].name, cycle_selector, puc$valid_catalog_entry,
                  next_catalog_entry);
            pup$build_new_catalog_header (next_catalog_entry, pf_utility_catalog_header,
                  p_new_catalog_header^);
            pup$check_if_item_excluded (next_catalog_entry, p_new_catalog_header^, catalog_excluded);
            IF catalog_excluded THEN
              pup$display_excluded_item (next_catalog_entry, p_new_catalog_header^, status);
            ELSE
              p_body := ^p_info_record^.body;
              pfp$find_direct_info_record (p_body, p_catalog_directory^ [i].info_offset, p_item_record,
                    status);
              IF status.normal THEN
                pup$backup_catalog (next_catalog_entry, p_new_catalog_header^, p_item_record,
                      pf_utility_hierarchy_list, pf_backup_file_id, status);
              IFEND;

              IF NOT status.normal THEN
                IF status.condition = pfe$catalog_volume_unavailable THEN
                  recorded_vsn := status.text.value (2,6);
                  pfp$convert_pf_path_to_fs_path (p_new_catalog_header^.path, fs_path, fs_path_size);
                  osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_volume_unavailable,
                        recorded_vsn, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, for_catalog_string, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, fs_path (1, fs_path_size),
                        status);
                ELSEIF status.condition = pfe$catalog_volume_not_online THEN
                  recorded_vsn := status.text.value (2,6);
                  pfp$convert_pf_path_to_fs_path (p_new_catalog_header^.path, fs_path, fs_path_size);
                  osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$catalog_volume_not_online,
                        recorded_vsn, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, for_catalog_string, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter, fs_path (1, fs_path_size),
                        status);
                IFEND;
                pup$write_status_to_listing (next_catalog_entry, status, local_status);
              IFEND;

              IF NOT puv$global_backup_file_id.backup_file_open THEN
                {
                { pup$backup_catalog encountered an error writing to the backup_file and closed it.
                { Return the abnormal status to the caller.
                {
                RETURN;
              IFEND;
              status.normal := TRUE;
            IFEND;
          = pfc$file_name =
          ELSE
          CASEND;
        FOREND;
      IFEND;
    IFEND;

    clean_up;
    osp$disestablish_cond_handler;

  PROCEND pup$backup_catalog;

?? TITLE := '    [XDCL] pup$backup_catalog_command ', EJECT ??

  PROCEDURE [XDCL] pup$backup_catalog_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

    VAR
      local_status: ost$status,
      p_path: ^pft$path,
      path_container: clt$path_container,
      set_name: stt$set_name;

    display (' entering pup$backup_catalog_command');
    IF puv$trace_selected THEN
      IF puc$include_unreleasable_data IN puv$include_data_options THEN
        display ('   unreleasable data included');
      IFEND;
      IF puc$include_releasable_data IN puv$include_data_options THEN
        display ('   releasable data included');
      IFEND;
      IF puc$include_offline_data IN puv$include_data_options THEN
        display ('   offline data included');
      IFEND;
    IFEND;

    crack_backup_catalog (parameter_list, path_container, p_path, status);
    IF status.normal THEN
      IF UPPERBOUND(p_path^) = pfc$family_name_index THEN
        pup$verify_family_administrator (' BACKUP_CATALOG', p_path^[pfc$family_name_index],
              status);
        IF status.normal THEN
          pfp$get_family_set (p_path^ [pfc$family_name_index], set_name, status);
          IF status.normal THEN
            pup$backup_family_request (set_name, p_path^[pfc$family_name_index], puv$backup_file_id, status);
          IFEND;
        ELSE
          osp$append_status_parameter (osc$status_parameter_delimiter, ' to backup a family',
                status);
        IFEND;
      ELSE
        pup$backup_catalog_request (p_path^, puv$backup_file_id, status);
      IFEND;
    IFEND;
  PROCEND pup$backup_catalog_command;

?? TITLE := '    pup$backup_catalog_request ', EJECT ??

  PROCEDURE pup$backup_catalog_request (catalog_path: pft$path;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);

    VAR
      catalog_entry: put$entry,
      catalog_item_info: amt$segment_pointer,
      dummy_cycle_selector: pft$cycle_selector,
      group: pft$group,
      i: put$half_integer,
      local_status: ost$status,
      p_body: pft$p_info,
      p_catalog_directory: pft$p_directory_array,
      p_hierarchy_list: ^put$hierarchy_list,
      p_info_record: pft$p_info_record,
      p_item_record: pft$p_info_record,
      set_name: stt$set_name;

    status.normal := TRUE;
    local_status.normal := TRUE;

    pfp$get_family_set (catalog_path [pfc$family_name_index], set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$build_entry (catalog_path [UPPERBOUND (catalog_path)], dummy_cycle_selector, puc$valid_catalog_entry,
          catalog_entry);
    PUSH p_hierarchy_list: [1 .. UPPERBOUND (catalog_path)];
    pup$build_catalog_header (set_name, ^catalog_path, p_hierarchy_list^.catalog_header);
    pup$build_hierarchy_list (catalog_entry, p_hierarchy_list^.catalog_header, p_hierarchy_list^, status);
    IF status.normal THEN
      pup$verify_catalog_path (catalog_path, status);
      IF status.normal THEN
        mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, catalog_item_info, status);
        IF status.normal THEN
          RESET catalog_item_info.sequence_pointer;
          group.group_type := pfc$public;
          pfp$get_item_info (catalog_path, group, - $pft$catalog_info_selections [], $pft$file_info_selections
                [], catalog_item_info.sequence_pointer, status);
          IF status.normal THEN
            RESET catalog_item_info.sequence_pointer;
            pfp$find_next_info_record (catalog_item_info.sequence_pointer, p_info_record, status);
            IF status.normal THEN
              pfp$find_directory_array (p_info_record, p_catalog_directory, status);
              IF status.normal AND (p_catalog_directory <> NIL) THEN
                p_body := ^p_info_record^.body;
                pfp$find_direct_info_record (p_body, p_catalog_directory^ [LOWERBOUND (p_catalog_directory^)].
                      info_offset, p_item_record, status);
                IF status.normal THEN
                  pup$initialize_backup_listing (p_hierarchy_list^, pf_backup_file_id, puv$backup_information,
                        status);
                  IF status.normal THEN
                    pup$backup_catalog (catalog_entry, p_hierarchy_list^.catalog_header, p_item_record,
                          p_hierarchy_list^, pf_backup_file_id, status);
                  IFEND;
                  pup$display_backup_output_total;
                  pup$get_summary_status (status);
                  pup$write_os_status (status, local_status);
                IFEND;
              IFEND;
            IFEND;
          IFEND;
          mmp$delete_scratch_segment (catalog_item_info, local_status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND pup$backup_catalog_request;

?? TITLE := '    build_cycle_reservation_crit ', EJECT ??

  PROCEDURE build_cycle_reservation_crit
    (    p_cycle_reservation_criteria: ^pft$cycle_reservation_criteria);

    VAR
      caller_id: ost$caller_identifier;

    #CALLER_ID (caller_id);

    p_cycle_reservation_criteria^.date_selection_criteria := puv$backup_criteria;
    p_cycle_reservation_criteria^.maximum_cycle_size := puv$maximum_cycle_size;
    p_cycle_reservation_criteria^.minimum_cycle_size := puv$minimum_cycle_size;

    p_cycle_reservation_criteria^.p_volume_list := puv$p_included_volumes;
    p_cycle_reservation_criteria^.include_volumes_option := puv$include_volumes_option;
    p_cycle_reservation_criteria^.exclude_highest_cycles := pup$excluded_highest_cycles ();
    p_cycle_reservation_criteria^.validation_ring := caller_id.ring;

  PROCEND build_cycle_reservation_crit;

?? TITLE := '    crack_backup_catalog ', EJECT ??

  PROCEDURE crack_backup_catalog (parameter_list: clt$parameter_list;
    VAR path_container: clt$path_container;
    VAR p_path: ^pft$path;
    VAR status: ost$status);

{ pdt backup_catalog_pdt (
{ catalog,c:file=$required
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      backup_catalog_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^backup_catalog_pdt_names, ^backup_catalog_pdt_params];

    VAR
      backup_catalog_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['CATALOG', 1], ['C', 1], ['STATUS', 2]];

    VAR
      backup_catalog_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor
        := [

{ CATALOG C }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??



    clp$scan_parameter_list (parameter_list, backup_catalog_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_catalog ('CATALOG', path_container, p_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
  PROCEND crack_backup_catalog;
MODEND pum$backup_catalog;
*DECK DECK=PUM$BACKUP_CYCLE EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := ' NOS/VE Backup/Restore Utilities:  backup_cycle', EJECT ??
MODULE pum$backup_cycle;

{  PURPOSE:
{    This module contains procedures required to produce a backup copy of a
{    specified cycle.

?? NEWTITLE := '  Global Declarations' ??
?? PUSH (LISTEXT := ON) ??
*copyc amp$get_file_attributes
*copyc amp$log_keyed_file_backup
*copyc amp$return
*copyc avp$system_administrator
*copyc avp$family_administrator
*copyc clp$convert_string_to_file
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc cyd$run_time_error_condition
*copyc dmp$get_stored_fmd_header_info
*copyc dmp$get_stored_fmd_volume_list
*copyc fmp$get_files_volume_info
*copyc fsp$build_file_ref_from_elems
*copyc fsp$expand_file_label
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$establish_condition_handler
*copyc osp$log_io_read_error
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc ost$caller_identifier
*copyc pfd$catalog
*copyc pfd$catalog_info
*copyc pfe$external_archive_conditions
*copyc pfp$convert_device_class_to_pf
*copyc pfp$find_archive_info
*copyc pfp$find_cycle_array_extended
*copyc pfp$find_cycle_directory
*copyc pfp$find_cycle_entry
*copyc pfp$find_cycle_entry_version_2
*copyc pfp$find_cycle_label
*copyc pfp$find_cycle_media
*copyc pfp$find_direct_info_record
*copyc pfp$find_directory_array
*copyc pfp$find_next_archive_entry
*copyc pfp$find_next_info_record
*copyc pfp$get_family_set
*copyc pfp$get_item_info
*copyc pfp$get_ownership
*copyc pfp$release_data
*copyc pfp$retrieve_archived_file
*copyc pfp$utility_attach
*copyc pft$cycle_info_desc_version_1
*copyc pft$cycle_info_desc_version_2
*copyc pmp$continue_to_cause
*copyc pmp$date_time_compare
*copyc pmp$execute_with_less_privilege
*copyc pmp$get_unique_name
*copyc pmt$program_parameters
*copyc pud$hierarchy_list
*copyc pue$error_condition_codes
*copyc pup$abort_output
*copyc pup$all_volumes_included
*copyc pup$build_catalog_header
*copyc pup$build_entry
*copyc pup$build_hierarchy_list
*copyc pup$check_if_size_included
*copyc pup$check_if_volume_included
*copyc pup$check_site_backup_options
*copyc pup$convert_cycle_path_to_strng
*copyc pup$display_blank_lines
*copyc pup$display_integer
*copyc pup$display_line
*copyc pup$find_cycle_info_record
*copyc pup$get_cycle_array
*copyc pup$get_cycle_array_version_2
*copyc pup$initialize_backup_listing
*copyc pup$output_cycle
*copyc pup$set_unknown_cycle_status
*copyc pup$store_file_gfn
*copyc pup$verify_file_path
*copyc pup$write_cycle_display
*copyc pup$write_file_display
*copyc pup$write_excluded_cycle
*copyc pup$write_logical_partition
*copyc pup$write_os_status
*copyc pup$write_status_to_listing
*copyc put$file_display_info
*copyc put$log_keyed_file_parameters
*copyc puv$bacpf_cycle_data_total
*copyc puv$backup_information
*copyc puv$backup_share_modes
*copyc puv$bacpf_backup_file_version
*copyc puv$cycle_display_selections
*copyc puv$data_file_selected
*copyc puv$exclude_catalog_information
*copyc puv$include_archive_information
*copyc puv$include_data_options
*copyc puv$include_exceptions
*copyc puv$last_volume_number
*copyc puv$null_original_unique_name
*copyc puv$null_res_cycle_array_ent_sp
*copyc puv$null_reserved_cycle_info_sp
*copyc puv$read_data_on_null_bf
*copyc puv$trace_selected
?? POP ??
?? TITLE := '    Global Variables', EJECT ??

  VAR
    puv$log_keyed_file_backup: boolean := TRUE;

  VAR
    number_of_cycles_backed_up: integer := 0,
    number_of_cycles_overflowed: integer := 0,
    total_cycle_data_backed_up: integer := 0;

  VAR
    default_program_attributes: [STATIC, READ] pmt$program_attributes :=
          [[pmc$starting_proc_specified, pmc$library_list_specified], 'PUP$R4_LOG_KEYED_FILE_BACKUP', 0, 0,
          1, osc$null_name, [pmc$no_load_map], pmc$error_load_errors, pmc$initialize_to_zero,
          osc$max_segment_length, osc$null_name, osc$null_name, osc$null_name, FALSE];

?? TITLE := '  [XDCL] pup$backup_cycle', EJECT ??

  PROCEDURE [XDCL] pup$backup_cycle
    (    cycle_entry: put$entry;
         password: pft$password;
         pf_utility_catalog_header: put$catalog_header;
         cycle_array_entry: pft$cycle_array_entry_version_2;
         pf_utility_hierarchy_list: put$hierarchy_list;
         check_cycle_included: boolean;
     VAR file_display_info: put$file_display_info;
     VAR p_cycle_info_record: { input } pft$p_info_record;
     VAR file_archive_info: { input/output } amt$segment_pointer;
     VAR p_cycle_array_extended_record: pft$p_info_record;
     VAR p_cycle_directory_array: pft$p_cycle_directory_array;
     VAR pf_backup_file_id: put$file_identifier;
     VAR status: ost$status);


    PROCEDURE backup_abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        display_status: ost$status,
        condition_status: ost$status,
        construction_status: ost$status,
        run_time_status: ^ost$status;

      CASE condition.selector OF

      = pmc$system_conditions, mmc$segment_access_condition =
        { Display the reason for the condition.
        pup$display_line (' Condition occurred in backing up file.', display_status);
        IF (condition.selector = mmc$segment_access_condition) AND
                (condition.segment_access_condition.identifier = mmc$sac_io_read_error) THEN
          PUSH p_path_string;
          pup$convert_cycle_path_to_strng (pf_utility_catalog_header.path, cycle_number, p_path_string^);
          osp$set_status_abnormal (puc$pf_utility_id, pue$unrecovered_ms_read_error,
                p_path_string^.value (1,p_path_string^.size), status);
          osp$append_status_integer (osc$status_parameter_delimiter, cycle_length, 10, false, status);
          osp$append_status_integer (osc$status_parameter_delimiter, puv$bacpf_cycle_data_total, 10, false,
                status);
          pup$write_os_status (status, display_status);
          osp$log_io_read_error (p_path_string^.value (1,p_path_string^.size), gfc$fk_job_permanent_file,
                condition.segment_access_condition.segment);
        ELSE
          osp$set_status_from_condition (puc$pf_utility_id, condition, save_area, condition_status,
                construction_status);
          IF construction_status.normal THEN
            pup$write_os_status (condition_status, display_status);
          ELSE
            pup$write_os_status (construction_status, display_status);
          IFEND;
        IFEND;
        pup$write_logical_partition (pf_backup_file_id, construction_status);

        osp$set_status_abnormal (puc$pf_utility_id, pue$backup_condition, '', status);
        current_pf_lfn_usable := FALSE;
        EXIT pup$backup_cycle;

      = pmc$user_defined_condition =
        IF condition.user_condition_name = cye$run_time_condition THEN
          run_time_status := condition_information;
          status := run_time_status^;
          EXIT pup$backup_cycle;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
          RETURN;
        IFEND;

      = pmc$block_exit_processing =
        IF (NOT cycle_array_entry.cycle_reservation.cycle_reserved) AND cycle_attached THEN
          amp$return (pf_lfn, local_status);
        IFEND;
        RETURN;

      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      CASEND;

    PROCEND backup_abort_handler;

?? EJECT ??

    VAR
      action_descriptor: put$action_descriptor,
      backup_with_write_access: boolean,
      call_log_keyed_file_backup: boolean,
      contains_data: boolean,
      current_pf_lfn_usable: [STATIC] boolean := FALSE,
      cycle_attached: boolean,
      cycle_damage_symptoms: fst$cycle_damage_symptoms,
      cycle_included: boolean,
      cycle_info: put$backup_item_info,
      cycle_length: amt$file_length,
      cycle_number: pft$cycle_number,
      existing_file: boolean,
      fmd_exists: boolean,
      fmd_header: pft$fmd_header,
      fmd_size: integer,
      gfn: ost$binary_unique_name,
      ignore_status: ost$status,
      info_size: integer,
      label_exists: boolean,
      local_file: boolean,
      local_status: ost$status,
      ownership: pft$ownership,
      path_string: ost$string,
      p_archive_list: pft$p_info_record,
      p_cycle_label: ^SEQ ( * ),
      p_cycle_media_description: pft$p_file_media_description,
      p_cycle_info_desc_version_1: ^pft$cycle_info_desc_version_1,
      p_cycle_info_desc_version_2: ^pft$cycle_info_desc_version_2,
      p_cycle_info_fmd: ^SEQ ( * ),
      p_cycle_media_description_fmd: ^SEQ ( * ),
      p_file_attributes: ^amt$get_attributes,
      p_fmd: ^SEQ ( * ),
      p_path_string: ^ost$string,
      p_volume_list: ^pft$volume_list,
      perform_utility_attach: boolean,
      pf_lfn: [STATIC] amt$local_file_name,
      retrieve_allowed: boolean,
      start_volume: amt$volume_number,
      usage_selections: pft$usage_selections,
      utility_attach_allowed: boolean,
      utility_attach_attempted: boolean,
      variant_path: pft$variant_path;

    display (' entering pup$backup_cycle');
    osp$establish_condition_handler (^backup_abort_handler, { Block_exit =} TRUE);
    cycle_attached := FALSE;
    #SPOIL (cycle_attached);

    IF NOT (avp$family_administrator() OR avp$system_administrator()) THEN
      puv$include_archive_information := FALSE;
    IFEND;

    pfp$find_cycle_media (p_cycle_info_record, p_cycle_media_description, status);
    IF status.normal THEN
       fmd_exists := TRUE;
    ELSEIF status.condition = pfe$unknown_cycle_media THEN
      fmd_exists := FALSE;
      status.normal := TRUE;
    ELSE
      RETURN;
    IFEND;

    action_descriptor := ' ';
    backup_with_write_access := FALSE;
    call_log_keyed_file_backup := FALSE;
    cycle_damage_symptoms := $fst$cycle_damage_symptoms [];
    cycle_number := cycle_array_entry.cycle_number;
    cycle_included := TRUE;
    local_status.normal := TRUE;
    p_volume_list := NIL;
    perform_utility_attach := (pf_backup_file_id.device_class <> rmc$null_device) OR
          ((pf_backup_file_id.device_class = rmc$null_device) AND
          (puv$read_data_on_null_bf OR puv$include_exceptions));
    retrieve_allowed := FALSE;
    start_volume := puv$last_volume_number;
    utility_attach_allowed := TRUE;
    utility_attach_attempted := FALSE;
    gfn := puv$unknown_global_file_name;

    pup$check_site_backup_options (cycle_array_entry, cycle_included);
    IF NOT cycle_included THEN
      action_descriptor := 'EXCLUDE SITE';
    ELSE
      IF cycle_array_entry.device_class = rmc$mass_storage_device THEN
        {
        { Get the volume list from the fmd if needed.
        { Determine if the cycle is excluded from this backup by a previous
        { INCLUDE_VOLUMES command.
        {
        IF ((NOT pup$all_volumes_included ()) OR (puc$cdo_recorded_vsn IN puv$cycle_display_selections))
              AND fmd_exists THEN
          dmp$get_stored_fmd_header_info (^p_cycle_media_description^.file_media_descriptor, fmd_header,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          PUSH p_volume_list: [1 .. fmd_header.number_of_subfiles];
          dmp$get_stored_fmd_volume_list (^p_cycle_media_description^.file_media_descriptor, p_volume_list,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          pup$check_if_volume_included (p_volume_list, cycle_included);
          IF NOT cycle_included THEN
            action_descriptor := 'EXCLUDE VOLUME';
          IFEND;

        IFEND;


        {
        {    Exclude the cycle if neither archive information nor data will be backed up.
        {
        IF (((NOT fmd_exists) AND NOT (puc$include_offline_data IN puv$include_data_options))
              OR ((NOT (puc$include_unreleasable_data IN puv$include_data_options))
              AND (NOT (puc$include_releasable_data IN puv$include_data_options)) AND fmd_exists))
              AND NOT puv$include_archive_information THEN
          cycle_included := FALSE;
          action_descriptor := 'EXCLUDE CYCLE';
        {
        {   If data that has not been released is to be included on the backup file (which is the default),
        { and the cycle data has not been released, then the cycle will be backed up.  Otherwise, the cycle's
        { archive information must be read to determine whether or not to back up the cycle.
        {
        ELSEIF NOT ((puc$include_releasable_data IN puv$include_data_options) AND fmd_exists
              AND (puc$include_unreleasable_data IN puv$include_data_options)) THEN
          IF (file_archive_info.sequence_pointer = NIL) AND NOT puv$include_archive_information THEN
            {
            {    Archive information was not read from the catalog, because archive information was not to be
            {  backed up.  Therefore, it is not contained in the cycle info record passed to this procedure.
            {  However, it has been determined that the cycle's archive information must be read from the
            {  catalog to decide if the cycle should be backed up.  Thus, the catalog must be read again to
            {  obtain this information.
            {
            get_archive_item_info (cycle_array_entry, pf_utility_catalog_header, file_archive_info,
                  p_cycle_array_extended_record, p_cycle_directory_array, p_cycle_info_record, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
          pfp$find_archive_info (p_cycle_info_record, p_archive_list, status);
          display (' pfp$find_archive_info');
          IF NOT status.normal THEN
            IF status.condition = pfe$unknown_archive_info THEN
              display (' status is PFE$UNKNOWN_ARCHIVE_LIST: status.normal changed to TRUE');
              status.normal := TRUE;
              p_archive_list := NIL;
            ELSE
              display_status (status);
              RETURN;
            IFEND;
          IFEND;
          {
          {    Check if the cycle should be excluded based upon whether or not it is archived.
          {
          check_for_arc_related_exclusion (p_archive_list, cycle_array_entry, check_cycle_included,
                fmd_exists, cycle_included, action_descriptor, utility_attach_allowed, retrieve_allowed,
                cycle_length, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      ELSEIF cycle_array_entry.device_class = rmc$magnetic_tape_device THEN
        retrieve_allowed := FALSE;
        utility_attach_allowed := FALSE;
        cycle_length := puc$released_cycle_size;
      IFEND;
    IFEND;

    IF (cycle_array_entry.data_residence = pfc$offline_data) AND
          (NOT puv$exclude_catalog_information) THEN
      IF NOT puv$include_archive_information AND
           NOT (puc$include_offline_data IN puv$include_data_options) THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$archive_info_not_backed_up, '', status);
      ELSE
        IF avp$family_administrator() AND (NOT avp$system_administrator()) THEN
          variant_path.complete_path := FALSE;
          variant_path.p_path := ^pf_utility_catalog_header.path;
          pfp$get_ownership (variant_path, {system_privilege} TRUE, ownership, status);
          IF NOT status.normal OR (NOT (pfc$family_owner IN ownership)) THEN
            osp$set_status_abnormal (puc$pf_utility_id, pue$archive_info_not_backed_up, '', status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF utility_attach_allowed AND cycle_included THEN
      IF NOT current_pf_lfn_usable THEN
        pmp$get_unique_name (pf_lfn, status);
      IFEND;
{
{ Data for an archived file that resides offline is retrieved prior to the
{ utility attach when OFFLINE_DATA is incuded in the set specified by the
{ INCLUDE_DATA SET_RESTORE_OPTIONS parameter and:
{
{    a) The backup file is not $NULL.
{
{    b) The backup file is $NULL and READ_DATA is specified for the
{       NULL_BACKUP_FILE_OPTION parameter of the SET_RESTORE_OPTIONS subcommand.
{
      IF retrieve_allowed THEN
        IF (pf_backup_file_id.device_class <> rmc$null_device) OR
              ((pf_backup_file_id.device_class = rmc$null_device) AND puv$read_data_on_null_bf) THEN
          pfp$retrieve_archived_file (pf_utility_catalog_header.path, cycle_array_entry.cycle_number,
            password, { wait } osc$wait, status);
        ELSE
          perform_utility_attach := FALSE;
        IFEND;
      IFEND;
      IF status.normal AND perform_utility_attach THEN
        utility_attach_attempted := TRUE;
        display (' pfp$utility_attach user''s permanent file');
        IF NOT cycle_array_entry.cycle_reservation.cycle_reserved THEN
          PUSH p_path_string;
          pup$convert_cycle_path_to_strng (pf_utility_catalog_header.path, cycle_number, p_path_string^);
          IF (p_path_string^.value(1,36) = ':$SYSTEM.$SYSTEM.AAM.AAF$44D_LIBRARY') THEN
            usage_selections := $pft$usage_selections [pfc$read, pfc$execute];
          ELSE
            usage_selections := $pft$usage_selections [pfc$read];
          IFEND;
          pfp$utility_attach (pf_lfn, pf_utility_catalog_header.path,
                cycle_entry.pf_selector.cycle_selector, password, usage_selections,
                $pft$share_selections [pfc$read, pfc$execute], pfc$no_wait,
                $fst$cycle_damage_symptoms [fsc$respf_modification_mismatch, fsc$parent_catalog_restored],
                cycle_damage_symptoms, cycle_number, status);
          IF ((($pft$usage_selections [pfc$append, pfc$modify, pfc$shorten] *
                puv$backup_share_modes) <> $pft$usage_selections []) AND
                (NOT status.normal) AND (status.condition = pfe$cycle_busy)) THEN
            pfp$utility_attach (pf_lfn, pf_utility_catalog_header.path,
                  cycle_entry.pf_selector.cycle_selector, password, usage_selections,
                  puv$backup_share_modes, pfc$no_wait,
                  $fst$cycle_damage_symptoms [fsc$respf_modification_mismatch, fsc$parent_catalog_restored],
                  cycle_damage_symptoms, cycle_number, status);
            backup_with_write_access := status.normal;
          IFEND;
          display_status (status);
          display (' pfp$utility_attach complete');
        IFEND;
        cycle_attached := (cycle_array_entry.cycle_reservation.cycle_reserved OR status.normal);
      IFEND;
    IFEND;

    IF status.normal AND utility_attach_allowed AND cycle_included THEN
      IF cycle_array_entry.device_class = rmc$mass_storage_device THEN
        pup$get_file_attributes (pf_lfn, cycle_array_entry, cycle_length, gfn, status);
      IFEND;
      IF status.normal AND (NOT cycle_array_entry.cycle_reservation.cycle_reserved) AND
              check_cycle_included THEN
        pup$check_if_size_included (cycle_length, cycle_included);
        IF NOT cycle_included THEN
          action_descriptor := 'EXCLUDE SIZE';
        IFEND;
      IFEND;
    IFEND;

    IF (NOT utility_attach_allowed) OR retrieve_allowed THEN
      PUSH p_volume_list: [1 .. 1];
      p_volume_list^ [1] := puc$nonexistent_recorded_vsn;
    IFEND;

    IF status.normal THEN
      IF cycle_included THEN
        IF (cycle_length = 0) AND (NOT perform_utility_attach) AND (NOT puv$include_exceptions) THEN
        { Obtain correct cycle length for busy file cycle since 0 is returned in the cycle array.
          pup$convert_cycle_path_to_strng (pf_utility_catalog_header.path, cycle_number, path_string);
          PUSH p_file_attributes: [1 .. 1];
          p_file_attributes^ [1].key := amc$file_length;
          amp$get_file_attributes (path_string.value(1, path_string.size), p_file_attributes^,
                local_file, existing_file, contains_data, status);
          IF status.normal AND existing_file AND contains_data THEN
            cycle_length := p_file_attributes^ [1].file_length;
          IFEND;
        IFEND;
        IF file_display_info.display THEN
          pup$write_file_display (file_display_info.pf_entry,
                 file_display_info.p_file_description^.charge_id.account,
                 file_display_info.p_file_description^.charge_id.project, ignore_status);
          file_display_info.display := FALSE;
        IFEND;
        pup$write_cycle_display (cycle_entry, cycle_array_entry, cycle_length, gfn, p_volume_list,
              p_cycle_array_extended_record, p_cycle_directory_array, status);
        IF puv$data_file_selected THEN
          pup$store_file_gfn (gfn, pf_utility_catalog_header.path, cycle_entry.pf_selector.cycle_selector,
                local_status);
        IFEND;
        IF cycle_damage_symptoms <> $fst$cycle_damage_symptoms [ ] THEN
          IF fsc$respf_modification_mismatch IN cycle_damage_symptoms THEN
            pup$display_line (' --  Warning Cycle damaged: respf_modification_mismatch --', local_status);
          IFEND;
          IF fsc$parent_catalog_restored IN cycle_damage_symptoms THEN
            pup$display_line (' --  Warning Cycle damaged: parent_catalog_restored --', local_status);
          IFEND;
        IFEND;
        display (' pfp$find_cycle_label');
        pfp$find_cycle_label (p_cycle_info_record, p_cycle_label, local_status);
        display_status (local_status);
        label_exists := local_status.normal;
        IF NOT label_exists THEN
          local_status.normal := TRUE;
          RESET p_cycle_label;
          PUSH p_cycle_label: [[REP 1 OF CELL]];
        IFEND;
        cycle_info.item_type := puc$backup_item_cycle_info;
        IF puv$bacpf_backup_file_version = puc$backup_file_version_1 THEN
          PUSH p_cycle_info_desc_version_1;
          p_cycle_info_desc_version_1^.cycle_number := cycle_array_entry.cycle_number;
          p_cycle_info_desc_version_1^.cycle_statistics := cycle_array_entry.cycle_statistics;
          p_cycle_info_desc_version_1^.expiration_date_time := cycle_array_entry.expiration_date_time;
          cycle_info.cycle_item_info.body_size := #SIZE(p_cycle_info_desc_version_1^);
          cycle_info.cycle_item_info.body := p_cycle_info_desc_version_1;
        ELSEIF puv$bacpf_backup_file_version = puc$backup_file_version_2 THEN
          IF fmd_exists THEN
            fmd_size := #SIZE(p_cycle_media_description^.file_media_descriptor);
          ELSE
            fmd_size := 1;
          IFEND;
          PUSH p_cycle_info_desc_version_2: [[REP fmd_size OF cell]];
          p_cycle_info_desc_version_2^.cycle_damage_symptoms := cycle_array_entry.cycle_damage_symptoms;
          p_cycle_info_desc_version_2^.cycle_number := cycle_array_entry.cycle_number;
          p_cycle_info_desc_version_2^.cycle_statistics := cycle_array_entry.cycle_statistics;
          IF cycle_array_entry.data_modification_date_time.year > 0 THEN
            p_cycle_info_desc_version_2^.data_modification_date_time :=
                  cycle_array_entry.data_modification_date_time;
          ELSE
            p_cycle_info_desc_version_2^.data_modification_date_time :=
                  cycle_array_entry.cycle_statistics.modification_date_time;
          IFEND;
          pfp$convert_device_class_to_pf (cycle_array_entry.device_class,
                p_cycle_info_desc_version_2^.device_class);
          p_cycle_info_desc_version_2^.expiration_date_time := cycle_array_entry.expiration_date_time;
          p_cycle_info_desc_version_2^.original_unique_name := cycle_array_entry.original_unique_name;
          p_cycle_info_desc_version_2^.sparse_backup_file_format := FALSE;
          p_cycle_info_desc_version_2^.shared_queue_info := cycle_array_entry.shared_queue_info;
          p_cycle_info_desc_version_2^.retrieve_option := cycle_array_entry.retrieve_option;;
          p_cycle_info_desc_version_2^.site_backup_option := cycle_array_entry.site_backup_option;;
          p_cycle_info_desc_version_2^.site_archive_option := cycle_array_entry.site_archive_option;;
          p_cycle_info_desc_version_2^.site_release_option := cycle_array_entry.site_release_option;;
          p_cycle_info_desc_version_2^.reserved_cycle_info_space := puv$null_reserved_cycle_info_sp;
          IF fmd_exists THEN
            p_cycle_info_desc_version_2^.fmd_checksum := p_cycle_media_description^.checksum;
            p_fmd := ^p_cycle_media_description^.file_media_descriptor;
            RESET p_fmd;
            NEXT p_cycle_media_description_fmd: [[REP fmd_size OF cell]] IN p_fmd;
            p_fmd := ^p_cycle_info_desc_version_2^.file_media_descriptor;
            RESET p_fmd;
            NEXT p_cycle_info_fmd: [[REP fmd_size OF cell]] IN p_fmd;
            p_cycle_info_fmd^ := p_cycle_media_description_fmd^;
            cycle_info.cycle_item_info.body_size := #SIZE(p_cycle_info_desc_version_2^);
          ELSE
            p_cycle_info_desc_version_2^.fmd_checksum := 0;
            cycle_info.cycle_item_info.body_size := #SIZE(p_cycle_info_desc_version_2^) - 1;
          IFEND;
          cycle_info.cycle_item_info.body := p_cycle_info_desc_version_2;
        IFEND;
        pup$output_cycle (pf_lfn, cycle_entry, pf_utility_catalog_header, cycle_info, cycle_array_entry,
              label_exists,
              p_cycle_label^, pf_utility_hierarchy_list, cycle_length, utility_attach_allowed,
              pf_backup_file_id, status);
        display (' pup$output_cycle');
        display_status (status);
        IF status.normal THEN
          IF backup_with_write_access THEN
            PUSH p_path_string;
            pup$convert_cycle_path_to_strng (pf_utility_catalog_header.path, cycle_number, p_path_string^);
            osp$set_status_abnormal (puc$pf_utility_id, pue$backed_up_with_write_access,
                  p_path_string^.value (1, p_path_string^.size), status);
            pup$write_os_status (status, local_status);
            status.normal := TRUE;
          IFEND;
          number_of_cycles_backed_up := number_of_cycles_backed_up + 1;
          IF cycle_length <> puc$released_cycle_size THEN
            total_cycle_data_backed_up := total_cycle_data_backed_up + cycle_length;
          IFEND;
          IF (p_volume_list <> NIL) AND (UPPERBOUND (p_volume_list^) > 1) THEN
            number_of_cycles_overflowed := number_of_cycles_overflowed + 1;
          IFEND;
          IF label_exists THEN
            check_aam_file_attributes (p_cycle_label, call_log_keyed_file_backup, local_status);
          IFEND
        ELSE
          pup$abort_output (cycle_entry, pf_backup_file_id, status, local_status);
        IFEND;
      ELSE
        pup$write_excluded_cycle (cycle_entry, cycle_array_entry, cycle_length, gfn, p_volume_list,
              p_cycle_array_extended_record, p_cycle_directory_array, action_descriptor, status);
      IFEND;
    IFEND;

    IF cycle_attached THEN
      IF NOT cycle_array_entry.cycle_reservation.cycle_reserved THEN
        display (' amp$return cycle');
        amp$return (pf_lfn, local_status);
        cycle_attached := FALSE;
      IFEND;
      IF call_log_keyed_file_backup THEN
        log_keyed_file_backup (pf_utility_catalog_header.path, cycle_number, password, start_volume,
              puv$last_volume_number, pf_backup_file_id, puv$backup_information);
      IFEND;
      display_status (local_status);
    IFEND;

    IF retrieve_allowed AND ((pf_backup_file_id.device_class <> rmc$null_device) OR
           ((pf_backup_file_id.device_class = rmc$null_device) AND puv$read_data_on_null_bf)) THEN
      pfp$release_data (pf_utility_catalog_header.path, cycle_entry.pf_selector.cycle_selector, password,
            local_status);
    IFEND;

 {  If the data for a file in another user's catalog is offline and the user is permitted to read
 {  the file, backup is allowed but the data will not be released after the backup.

    IF (NOT local_status.normal) AND (local_status.condition = pfe$usage_not_permitted) THEN
      local_status.normal := TRUE;
    IFEND;

    IF utility_attach_attempted THEN
      current_pf_lfn_usable := status.normal;
    IFEND;

    display_status (local_status);
    IF (NOT local_status.normal) AND status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pup$backup_cycle;

?? TITLE := '    [XDCL] pup$backup_cycle_request', EJECT ??

  PROCEDURE [XDCL] pup$backup_cycle_request (file_path: pft$path;
        cycle_selector: pft$cycle_selector;
        password: pft$password;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);

    VAR
      cycle_array_entry: pft$cycle_array_entry_version_2,
      cycle_entry: put$entry,
      cycle_index: pft$array_index,
      file_display_info: put$file_display_info,
      file_info_selections: pft$file_info_selections,
      file_item_info: pft$p_info_record,
      group: pft$group,
      local_status: ost$status,
      p_cycle_array_version_1: pft$p_cycle_array,
      p_cycle_array_version_2: ^pft$cycle_array_version_2,
      p_cycle_array_extended_record: pft$p_info_record,
      p_cycle_directory_array: pft$p_cycle_directory_array,
      p_cycle_info_record: pft$p_info_record,
      p_hierarchy_list: ^put$hierarchy_list,
      segment_pointer: amt$segment_pointer,
      set_name: stt$set_name;

    display (' entering pup$backup_cycle_request');
    local_status.normal := TRUE;
    status.normal := TRUE;
    file_display_info.display := FALSE;

    pfp$get_family_set (file_path [pfc$family_name_index], set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$build_entry (file_path [UPPERBOUND (file_path)], cycle_selector, puc$valid_cycle_entry, cycle_entry);
    PUSH p_hierarchy_list: [1 .. UPPERBOUND (file_path)];
    pup$build_catalog_header (set_name, ^file_path, p_hierarchy_list^.catalog_header);
    pup$build_hierarchy_list (cycle_entry, p_hierarchy_list^.catalog_header, p_hierarchy_list^, status);
    IF status.normal THEN
      pup$verify_file_path (file_path, status);
      IF status.normal THEN
        mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, segment_pointer, status);
        IF status.normal THEN
          group.group_type := pfc$public;
          IF puv$bacpf_backup_file_version = puc$backup_file_version_1 THEN
            file_info_selections := $pft$file_info_selections [pfc$file_directory,
                pfc$file_cycles, pfc$cycle_media_descriptor, pfc$cycle_label_descriptor,
                pfc$archive_descriptors];
          ELSEIF puv$bacpf_backup_file_version = puc$backup_file_version_2 THEN
            file_info_selections := $pft$file_info_selections [pfc$file_directory,
                pfc$file_cycles_version_2, pfc$cycle_media_descriptor, pfc$cycle_label_descriptor,
                pfc$archive_descriptors];
          IFEND;
          pfp$get_item_info (file_path, group, $pft$catalog_info_selections [], file_info_selections,
                segment_pointer.sequence_pointer, status);
          IF status.normal THEN
            IF puv$bacpf_backup_file_version = puc$backup_file_version_1 THEN
              pup$get_cycle_array (segment_pointer.sequence_pointer, p_cycle_array_version_1, file_item_info,
                    status);
              IF status.normal THEN
                pfp$find_cycle_entry (p_cycle_array_version_1, cycle_selector, cycle_index, status);
                IF status.normal THEN
                  cycle_array_entry.bytes_allocated := 0;
                  cycle_array_entry.cycle_damage_symptoms := $fst$cycle_damage_symptoms [];
                  cycle_array_entry.cycle_number := p_cycle_array_version_1^ [cycle_index].cycle_number;
                  cycle_array_entry.cycle_statistics :=
                        p_cycle_array_version_1^ [cycle_index].cycle_statistics;
                  cycle_array_entry.data_modification_date_time :=
                        p_cycle_array_version_1^ [cycle_index].cycle_statistics.modification_date_time;
                  cycle_array_entry.data_residence := pfc$unreleasable_data;
                  cycle_array_entry.device_class := rmc$mass_storage_device;
                  cycle_array_entry.eoi := 0;
                  cycle_array_entry.expiration_date_time :=
                        p_cycle_array_version_1^ [cycle_index].expiration_date_time;
                  cycle_array_entry.original_unique_name := puv$null_original_unique_name;
                  cycle_array_entry.sparse_allocation := FALSE;
                  cycle_array_entry.cycle_reservation.cycle_reserved := FALSE;
                  cycle_array_entry.reserved_cycle_array_entry_sp := puv$null_res_cycle_array_ent_sp;
                ELSE
                  pup$set_unknown_cycle_status (file_path [UPPERBOUND (file_path)], cycle_selector, status);
                IFEND;
              IFEND;
            ELSEIF puv$bacpf_backup_file_version = puc$backup_file_version_2 THEN
              pup$get_cycle_array_version_2 (segment_pointer.sequence_pointer, p_cycle_array_version_2,
                    file_item_info, status);
              IF status.normal THEN
                pfp$find_cycle_entry_version_2 (p_cycle_array_version_2, cycle_selector, cycle_index, status);
                IF status.normal THEN
                  cycle_array_entry := p_cycle_array_version_2^ [cycle_index];
                ELSE
                  pup$set_unknown_cycle_status (file_path [UPPERBOUND (file_path)], cycle_selector, status);
                IFEND;
              IFEND;
            IFEND;
            IF status.normal THEN
              pfp$find_cycle_array_extended (file_item_info, p_cycle_array_extended_record, status);
              IF status.normal THEN
                pfp$find_cycle_directory (p_cycle_array_extended_record, p_cycle_directory_array, status);
                IF status.normal THEN
                  pup$initialize_backup_listing (p_hierarchy_list^, pf_backup_file_id,
                        puv$backup_information, status);
                  IF status.normal THEN
                    pup$find_cycle_info_record (p_cycle_array_extended_record, p_cycle_directory_array,
                          cycle_array_entry.cycle_number, ^p_hierarchy_list^.catalog_header.path,
                          p_cycle_info_record, status);
                    IF status.normal THEN
                      { reset cycle_number in case of $HIGH or $LOW}
                      cycle_entry.pf_selector.cycle_selector.cycle_option := pfc$specific_cycle;
                      cycle_entry.pf_selector.cycle_selector.cycle_number := cycle_array_entry.cycle_number;
                      pup$backup_cycle (cycle_entry, password, p_hierarchy_list^.catalog_header,
                            cycle_array_entry, p_hierarchy_list^, { check_cycle_included  } FALSE,
                            file_display_info, p_cycle_info_record, segment_pointer,
                            p_cycle_array_extended_record, p_cycle_directory_array, pf_backup_file_id,
                            status);
                      pup$display_backup_output_total;
                    IFEND;
                  IFEND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
          mmp$delete_scratch_segment (segment_pointer, local_status);
        IFEND;
      IFEND;
    IFEND;
    pup$write_status_to_listing (cycle_entry, status, local_status);
  PROCEND pup$backup_cycle_request;

?? TITLE := '    [XDCL] pup$display_backup_output_total', EJECT ??

  PROCEDURE [XDCL] pup$display_backup_output_total;

    VAR
      local_status: ost$status;

    pup$display_blank_lines (3, local_status);
    pup$display_line (' BACKUP SUMMARY: ', local_status);
    pup$display_integer ('   NUMBER OF CYCLES BACKED UP: ', number_of_cycles_backed_up, local_status);
    number_of_cycles_backed_up := 0;
    IF puc$cdo_recorded_vsn IN puv$cycle_display_selections THEN
      pup$display_integer ('   NUMBER OF CYCLES ON MULTIPLE VOLUMES: ', number_of_cycles_overflowed,
            local_status);
      number_of_cycles_overflowed := 0;
    IFEND;
    pup$display_integer ('   TOTAL CYCLE DATA BACKED UP: ', total_cycle_data_backed_up, local_status);
    total_cycle_data_backed_up := 0;
  PROCEND pup$display_backup_output_total;

?? TITLE := '  pup$get_file_attributes', EJECT ??

  PROCEDURE [XDCL] pup$get_file_attributes
    (    lfn: fst$file_reference;
         cycle_array_entry: pft$cycle_array_entry_version_2;
     VAR file_length: amt$file_length;
     VAR gfn: ost$binary_unique_name;
     VAR status: ost$status);

    VAR
      contains_data: boolean,
      existing_file: boolean,
      local_file: boolean,
      p_file_attributes: ^amt$get_attributes;


    IF (puv$bacpf_backup_file_version = puc$backup_file_version_2) AND (cycle_array_entry.eoi > 0) THEN
      file_length := cycle_array_entry.eoi;
      gfn := cycle_array_entry.original_unique_name;
    ELSE
      PUSH p_file_attributes: [1 .. 2];
      p_file_attributes^ [1].key := amc$file_length;
      p_file_attributes^ [2].key := amc$global_file_name;
      amp$get_file_attributes (lfn, p_file_attributes^, local_file, existing_file, contains_data, status);
      IF status.normal THEN
        IF existing_file AND contains_data THEN
          file_length := p_file_attributes^ [1].file_length;
        ELSE
          file_length := 0;
        IFEND;
        display_integer (' user file length: ', file_length);
        gfn := p_file_attributes^ [2].global_file_name;
      IFEND;
    IFEND;
  PROCEND pup$get_file_attributes;

?? TITLE := '    [XDCL] pup$log_keyed_file_backup', EJECT ??

  PROCEDURE [XDCL] pup$log_keyed_file_backup
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt logkfb_pdt (selected, s: boolean = true
{  status)

?? PUSH (LISTEXT := ON) ??

  VAR
    logkfb_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^logkfb_pdt_names,
      ^logkfb_pdt_params];

  VAR
    logkfb_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['SELECTED', 1], ['S', 1], ['STATUS', 2]];

  VAR
    logkfb_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ SELECTED S }
    [[clc$optional_with_default, ^logkfb_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$boolean_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    logkfb_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';


?? POP ??

    VAR
      value: clt$value;

    clp$scan_parameter_list (parameter_list, logkfb_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('SELECTED', 1, 1, clc$Low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    puv$log_keyed_file_backup := value.bool.value;
    IF puv$log_keyed_file_backup THEN
      pup$display_line (' LOGGING KEYED FILE BACKUPS', status);
    ELSE
      pup$display_line (' NOT LOGGING KEYED FILE BACKUPS', status);
    IFEND;
  PROCEND pup$log_keyed_file_backup;

?? TITLE := '    [XDCL, #GATE] pup$r4_log_keyed_file_backup', EJECT ??

  PROCEDURE [XDCL, #GATE] pup$r4_log_keyed_file_backup
    (    program_parameters: pmt$program_parameters;
     VAR status: ost$status);

    VAR
      p_log_keyed_file_parameters: ^put$log_keyed_file_parameters,
      p_parameters: ^SEQ( *),
      p_volume_list: ^rmt$volume_list;

    p_parameters := ^program_parameters;
    RESET p_parameters;
    NEXT p_log_keyed_file_parameters IN p_parameters;
    NEXT p_volume_list: [1 .. p_log_keyed_file_parameters^.volume_list_size] IN p_parameters;

    amp$log_keyed_file_backup (p_log_keyed_file_parameters^.path, p_log_keyed_file_parameters^.password,
          p_log_keyed_file_parameters^.global_file_name, p_log_keyed_file_parameters^.backup_information,
          p_volume_list^, status);
  PROCEND pup$r4_log_keyed_file_backup;

?? TITLE := '    check_aam_file_attributes ', EJECT ??

  PROCEDURE check_aam_file_attributes
    (    p_cycle_label: ^SEQ ( * );
     VAR call_log_keyed_file_backup: boolean;
     VAR status: ost$status);

    TYPE
      file_organization_set = set of amt$file_organization;

    VAR
      file_previously_opened: boolean,
      label_size: integer,
      p_local_cycle_label: ^SEQ (*),
      p_physical_file_label: ^pft$physical_file_label,
      p_static_label_attributes: ^bat$static_label_attributes;

    IF NOT puv$log_keyed_file_backup THEN
      RETURN;
    IFEND;

    p_local_cycle_label := p_cycle_label;
    label_size := #SIZE(p_local_cycle_label^) - #SIZE(pft$checksum);
    RESET p_local_cycle_label;
    NEXT p_physical_file_label: [[REP label_size OF CELL]] IN p_local_cycle_label;

    PUSH p_static_label_attributes;
    fsp$expand_file_label (^p_physical_file_label^.file_label, p_static_label_attributes^,
          file_previously_opened, status);
    IF status.normal AND file_previously_opened THEN
      call_log_keyed_file_backup := ((p_static_label_attributes^.file_organization_source <>
            amc$undefined_attribute) AND (p_static_label_attributes^.file_organization IN
            $file_organization_set [amc$indexed_sequential, amc$direct_access, amc$system_key])) AND
            ((p_static_label_attributes^.logging_options_source <> amc$undefined_attribute) AND
            (amc$enable_media_recovery IN p_static_label_attributes^.logging_options));
    IFEND;

  PROCEND check_aam_file_attributes;

?? TITLE := '    check_for_arc_related_exclusion', EJECT ??

  PROCEDURE check_for_arc_related_exclusion (
        p_archive_list: { input } pft$p_info_record;
        cycle_array_entry: pft$cycle_array_entry_version_2;
        check_cycle_included: boolean;
        fmd_exists: boolean;
    VAR cycle_included: {i/o} boolean;
    VAR action_descriptor: {i/o} put$action_descriptor;
    VAR utility_attach_allowed: {i/o} boolean;
    VAR retrieve_allowed: {i/o} boolean;
    VAR cycle_length: amt$file_length;
    VAR status: ost$status);

    VAR
      cycle_archived: boolean,
      data_modification_date_time: ost$date_time;

    cycle_length := puc$released_cycle_size;
    cycle_archived := FALSE;

    IF p_archive_list = NIL THEN
      status.normal := TRUE;
    ELSE
      IF cycle_array_entry.data_modification_date_time.year > 0 THEN
        data_modification_date_time := cycle_array_entry.data_modification_date_time;
      ELSE
        data_modification_date_time := cycle_array_entry.cycle_statistics.modification_date_time;
      IFEND;
      check_if_cycle_archived (data_modification_date_time, p_archive_list, cycle_archived,
            status);
      display (' check_if_cycle_archived');
      display_status (status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF cycle_archived THEN
        IF check_cycle_included THEN
          pup$check_if_size_included (cycle_array_entry.eoi, cycle_included);
          IF NOT cycle_included THEN
            action_descriptor := 'EXCLUDE SIZE';
          ELSEIF (NOT pup$all_volumes_included ()) AND NOT fmd_exists THEN
            cycle_included := NOT puv$exclude_catalog_information;
            action_descriptor := 'EXCLUDE VOLUME';
          IFEND;
        ELSEIF (NOT fmd_exists) AND (NOT (puc$include_offline_data IN puv$include_data_options)) THEN
          osp$set_status_abnormal (puc$pf_utility_id, pue$empty_cycle_partition, '', status);
          RETURN;
        IFEND;

        IF cycle_included THEN
          IF (NOT (puc$include_releasable_data IN puv$include_data_options)) AND fmd_exists
                AND NOT puv$include_archive_information THEN
            cycle_included := FALSE;
            action_descriptor := 'EXCLUDE CYCLE';
          ELSEIF ((NOT fmd_exists) AND NOT (puc$include_offline_data IN puv$include_data_options)) OR
                ((NOT (puc$include_releasable_data IN puv$include_data_options)) AND fmd_exists) THEN
            IF NOT (avp$family_administrator() OR avp$system_administrator()) THEN
              cycle_included := FALSE;
              action_descriptor := 'EXCLUDE ADMINISTRATOR';
            ELSE
              utility_attach_allowed := FALSE;
            IFEND;
          ELSEIF (puc$include_offline_data IN puv$include_data_options) AND NOT fmd_exists AND
                (cycle_array_entry.data_residence <> pfc$unreleasable_data) THEN
            retrieve_allowed := TRUE;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF ((NOT (puc$include_unreleasable_data IN puv$include_data_options)) AND
          ((p_archive_list = NIL) OR NOT cycle_archived) AND fmd_exists) OR
       ((NOT (puc$include_releasable_data IN puv$include_data_options)) AND
       cycle_archived AND fmd_exists) THEN
      cycle_included := FALSE;
      action_descriptor := 'EXCLUDE CYCLE';
    IFEND;

  PROCEND check_for_arc_related_exclusion;

?? TITLE := '    check_if_cycle_archived ', EJECT ??

  PROCEDURE check_if_cycle_archived
   (    data_modification_date_time: ost$date_time;
        p_archive_list: {i^/o^} pft$p_info_record;
    VAR cycle_archived: boolean;
    VAR status: ost$status);

    VAR
      archive_identification: pft$archive_identification,
      comparison_result: pmt$comparison_result,
      p_archive_entry: pft$p_archive_array_entry,
      p_archive_group: pft$p_info_record,
      p_archive_list_body: pft$p_info,
      p_archive_media: pft$p_amd;

    status.normal := TRUE;
    cycle_archived := FALSE;
    p_archive_list_body := ^p_archive_list^.body;
    IF p_archive_list_body = NIL THEN
      RETURN;
    IFEND;
    archive_identification.application_identifier := osc$null_name;
    archive_identification.media_identifier.media_device_class := osc$null_name;
    archive_identification.media_identifier.media_volume_identifier := '';
    RESET p_archive_list_body;
  /search_archive_list/
    REPEAT
      pfp$find_next_archive_entry (archive_identification, p_archive_list_body, p_archive_group,
            p_archive_entry, p_archive_media, status);
      IF status.normal AND (p_archive_entry <> NIL) THEN
        pmp$date_time_compare (p_archive_entry^.archive_date_time, data_modification_date_time,
              comparison_result, status);
        IF status.normal AND (comparison_result = pmc$left_is_greater) THEN
          cycle_archived := TRUE;
          EXIT /search_archive_list/;
        IFEND;
      IFEND;
    UNTIL (NOT status.normal) OR (p_archive_entry = NIL);

    IF status.condition = pfe$unknown_info_record THEN
      status.normal := TRUE;  { cycle not duplicated }
    IFEND;
  PROCEND check_if_cycle_archived;

?? TITLE := '    get_archive_item_info', EJECT ??

  PROCEDURE get_archive_item_info (
        cycle_array_entry: pft$cycle_array_entry_version_2;
        pf_utility_catalog_header: put$catalog_header;
    VAR file_archive_info: amt$segment_pointer;
    VAR p_cycle_array_extended_record: pft$p_info_record;
    VAR p_cycle_directory_array: pft$p_cycle_directory_array;
    VAR p_cycle_info_record: pft$p_info_record;
    VAR status: ost$status);

    VAR
      group: pft$group,
      p_directory_array: pft$p_directory_array,
      p_info_record: pft$p_info_record,
      p_item_record: pft$p_info_record;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, file_archive_info, status);
    IF status.normal THEN
      group.group_type := pfc$public;
      RESET file_archive_info.sequence_pointer;
      pfp$get_item_info (pf_utility_catalog_header.path, group, $pft$catalog_info_selections [],
            $pft$file_info_selections [pfc$cycle_media_descriptor, pfc$cycle_label_descriptor,
            pfc$archive_descriptors], file_archive_info.sequence_pointer, status);
      display (' pfp$get_item_info');
      display_status (status);
      IF status.normal THEN
        RESET file_archive_info.sequence_pointer;
        pfp$find_next_info_record (file_archive_info.sequence_pointer, p_info_record, status);
        display (' pfp$find_next_info_record');
        display_status (status);
        IF status.normal THEN
          pfp$find_directory_array (p_info_record, p_directory_array, status);
          display (' pfp$find_directory_array');
          display_status (status);
          IF status.normal THEN
            pfp$find_direct_info_record (^p_info_record^.body,
                  p_directory_array^ [LOWERBOUND (p_directory_array^)].info_offset, p_item_record,
                  status);
            display (' pfp$find_direct_info_record');
            display_status (status);
            IF status.normal THEN
              pfp$find_cycle_array_extended (p_item_record, p_cycle_array_extended_record, status);
              display (' pfp$find_cycle_array_extended');
              display_status (status);
              IF status.normal THEN
                pfp$find_cycle_directory (p_cycle_array_extended_record, p_cycle_directory_array, status);
                display (' pfp$find_cycle_directory');
                display_status (status);
                IF status.normal THEN
                  pup$find_cycle_info_record (p_cycle_array_extended_record, p_cycle_directory_array,
                        cycle_array_entry.cycle_number, ^pf_utility_catalog_header.path,
                        p_cycle_info_record, status);
                  display (' pup$find_cycle_info_record');
                  display_status (status);
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND get_archive_item_info;

?? TITLE := '    log_keyed_file_backup', EJECT ??

  PROCEDURE log_keyed_file_backup
    (    path: pft$path;
         cycle_number: pft$cycle_number;
         password: pft$password;
         starting_tape_volume_number: amt$volume_number;
         ending_tape_volume_number: amt$volume_number;
         backup_file_id: put$file_identifier,
         backup_information: amt$backup_information);

    CONST
      library_path = ':$SYSTEM.$SYSTEM.OSF$BUILTIN_LIBRARY';

    VAR
      caller_id: ost$caller_identifier,
      cycle_path_string: ost$string,
      cl_file: clt$file,
      null_global_file_name: [READ, pus$literals] ost$binary_unique_name :=
            [0, osc$cyber_180_model_unknown, 1980, 1, 1, 0, 0, 0, 0, 0],
      p_libraries: ^pmt$object_library_list,
      p_log_keyed_file_parameters: ^put$log_keyed_file_parameters,
      p_parameters: ^SEQ ( * ),
      p_program_attributes: ^pmt$program_attributes,
      p_program_description: ^pmt$program_description,
      p_temp_volume_list: ^rmt$volume_list,
      p_volume_info: ^array [ * ] of fmt$volume_info,
      p_volume_list: ^rmt$volume_list,
      saved_file_path: fst$path,
      status: ost$status,
      task_id: pmt$task_id,
      task_status: pmt$task_status,
      volume: amt$volume_number;

    CASE backup_file_id.device_class OF
    = rmc$mass_storage_device =
      IF backup_information.file_path (1, 7) = ':$LOCAL' THEN
        RETURN;
      IFEND;
      PUSH p_volume_list: [1 .. 1];

    = rmc$magnetic_tape_device =
      { Fetch the volume list.
      PUSH p_volume_list: [starting_tape_volume_number .. ending_tape_volume_number];
      PUSH p_volume_info: [starting_tape_volume_number .. ending_tape_volume_number];
      FOR volume := starting_tape_volume_number TO ending_tape_volume_number DO
        p_volume_info^ [volume].key := fmc$volume;
        p_volume_info^ [volume].requested_volume_number := volume;
      FOREND;
      fmp$get_files_volume_info (backup_file_id.lfn, p_volume_info^, status);
      IF NOT status.normal THEN
        pup$write_os_status (status, status);
        pup$display_line (' UNABLE TO GET TAPE INFO TO LOG KEYED FILE BACKUP', status);
        RETURN;
      IFEND;
      FOR volume := starting_tape_volume_number TO ending_tape_volume_number DO
        IF p_volume_info^ [volume].item_returned THEN
          p_volume_list^ [volume] := p_volume_info^ [volume].volume;
        ELSE
          pup$display_line (' UNABLE TO LOG KEYED FILE BACKUP', status);
          pup$display_integer (' TAPE VOLUME INFO NOT RETURNED FOR VOLUME NUMBER: ', volume, status);
          RETURN;
        IFEND;
      FOREND;

    ELSE {null device}
      RETURN;
    CASEND;

    #CALLER_ID (caller_id);
    pup$convert_cycle_path_to_strng (path, cycle_number, cycle_path_string);
    saved_file_path := cycle_path_string.value (1, cycle_path_string.size);
    IF caller_id.ring >= 4 THEN
      display (' amp$log_keyed_file_backup');
      amp$log_keyed_file_backup (saved_file_path, password, null_global_file_name, backup_information,
            p_volume_list^, status);
    ELSE
      clp$convert_string_to_file (library_path, cl_file, status);
      IF status.normal THEN
        PUSH p_program_description: [[REP (#SIZE (pmt$program_attributes) + #SIZE (amt$local_file_name)) OF
              cell]];
        RESET p_program_description;
        NEXT p_program_attributes IN p_program_description;
        p_program_attributes^ := default_program_attributes;
        NEXT p_libraries: [1 .. 1] IN p_program_description;
        p_libraries^ [1] := cl_file.local_file_name;

        PUSH p_parameters: [[REP #SIZE (put$log_keyed_file_parameters) + #SIZE (p_volume_list^) OF cell]];
        RESET p_parameters;
        NEXT p_log_keyed_file_parameters IN p_parameters;
        p_log_keyed_file_parameters^.path := saved_file_path;
        p_log_keyed_file_parameters^.path_size := cycle_path_string.size;
        p_log_keyed_file_parameters^.password := password;
        p_log_keyed_file_parameters^.global_file_name := null_global_file_name;
        p_log_keyed_file_parameters^.backup_information := backup_information;
        p_log_keyed_file_parameters^.volume_list_size := UPPERBOUND (p_volume_list^) -
              LOWERBOUND(p_volume_list^) + 1;
        NEXT p_temp_volume_list: [LOWERBOUND(p_volume_list^) .. UPPERBOUND (p_volume_list^)] IN p_parameters;
        p_temp_volume_list^ := p_volume_list^;

        display (' Call pmp$execute_with_less_privilege');
        pmp$execute_with_less_privilege ({execution_ring} 4, p_program_description^, p_parameters^,
              osc$wait, {cl_task} FALSE, task_id, task_status, status);
      IFEND;
    IFEND;

    IF NOT status.normal THEN
      pup$write_os_status (status, status);
      pup$display_line (' UNABLE TO LOG KEYED FILE BACKUP', status);
      RETURN;
    IFEND;
  PROCEND log_keyed_file_backup;

?? SKIP := 2 ??
MODEND pum$backup_cycle;
*DECK DECK=PUM$BACKUP_FILE EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  backup_file ', EJECT ??
MODULE pum$backup_file;
{PURPOSE:
{     this module contains procedures required to produce a BACKUP copy
{  of a specified file as well as a BACKUP copy of each cycle
{  registered in the file.
?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$evaluate_parameters
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc ost$string
*copyc ost$user_identification
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfp$find_cycle_array
*copyc pfp$find_cycle_array_extended
*copyc pfp$find_cycle_array_version_2
*copyc pfp$find_cycle_directory
*copyc pfp$find_direct_info_record
*copyc pfp$find_directory_array
*copyc pfp$find_file_description
*copyc pfp$find_next_info_record
*copyc pfp$get_family_set
*copyc pfp$get_item_info
*copyc pud$backup_file
*copyc pud$hierarchy_list
*copyc pud$list_options
*copyc pup$abort_output
*copyc pup$backup_cycle
*copyc pup$backup_cycle_request
*copyc pup$build_catalog_header
*copyc pup$build_entry
*copyc pup$build_hierarchy_list
*copyc pup$check_cycle_access
*copyc pup$check_if_item_excluded
*copyc pup$check_site_backup_options
*copyc pup$crack_pf_file_reference
*copyc pup$display_backup_output_total
*copyc pup$display_excluded_item
*copyc pup$display_line
*copyc pup$excluded_highest_cycles
*copyc pup$get_summary_status
*copyc pup$initialize_backup_listing
*copyc pup$output_file
*copyc pup$sort_cycle_array_version_2
*copyc pup$verify_file_path
*copyc pup$write_excluded_cycle
*copyc pup$write_file_display
*copyc pup$write_os_status
*copyc pup$write_status_to_listing
*copyc put$file_display_info
*copyc put$file_identifier
*copyc puv$backup_information
*copyc puv$backup_file_id
*copyc puv$bacpf_backup_file_version
*copyc puv$display_excluded_items
*copyc puv$global_backup_file_id
*copyc puv$include_archive_information
*copyc puv$null_original_unique_name
*copyc puv$null_res_cycle_array_ent_sp
*copyc puv$trace_selected
*copyc std$set_name
?? POP ??
?? TITLE := '    Global Variables', EJECT ??
?? TITLE := '    [XDCL] pup$backup_file ', EJECT ??

  PROCEDURE [XDCL] pup$backup_file
    (    pf_entry: put$entry;
         password_provided: boolean;
         password: pft$password;
         pf_utility_catalog_header: put$catalog_header;
         pf_utility_hierarchy_list: put$hierarchy_list;
     VAR pf_backup_file_id: put$file_identifier;
         file_item_info: pft$p_info_record;
     VAR status: ost$status);

    VAR
      action_descriptor: put$action_descriptor,
      backup_item_info: put$backup_item_info,
      cycle_entry: put$entry,
      cycle_included: boolean,
      cycle_selector: pft$cycle_selector,
      file_display_info: put$file_display_info,
      file_archive_info: amt$segment_pointer,
      i: put$half_integer,
      ignore_status: ost$status,
      j: pft$array_index,
      local_password: pft$password,
      local_status: ost$status,
      p_cycle_array_version_1: pft$p_cycle_array,
      p_cycle_array_version_2: ^pft$cycle_array_version_2,
      p_cycle_array_extended_record: pft$p_info_record,
      p_cycle_directory_array: pft$p_cycle_directory_array,
      p_cycle_info_record: pft$p_info_record,
      p_file_description: pft$p_file_description;

    display (' entering pup$backup_file');
    status.normal := TRUE;
    local_status.normal := TRUE;
    pfp$find_file_description (file_item_info, p_file_description, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    file_display_info.display := TRUE;
    file_display_info.pf_entry := pf_entry;
    file_display_info.p_file_description := p_file_description;
    IF password_provided THEN
      local_password := password;
    ELSE
      local_password := p_file_description^.password;
    IFEND;
    IF puv$display_excluded_items THEN
      pup$write_file_display (pf_entry, p_file_description^.charge_id.account,
            p_file_description^.charge_id.project, ignore_status);
      file_display_info.display := FALSE;
    IFEND;
    backup_item_info.item_type := puc$backup_item_file_info;
    backup_item_info.file_item_info := file_item_info;
    pup$output_file (pf_entry, pf_utility_catalog_header, backup_item_info, pf_utility_hierarchy_list,
          pf_backup_file_id, status);
    IF NOT status.normal THEN
      pup$abort_output (pf_entry, pf_backup_file_id, status, local_status);
      RETURN;
    IFEND;
    IF puv$bacpf_backup_file_version = puc$backup_file_version_1 THEN
      pfp$find_cycle_array (file_item_info, p_cycle_array_version_1, status);
      IF status.normal AND (p_cycle_array_version_1 = NIL) THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_cycle_array, '', status);
      IFEND;
      display (' pfp$find_cycle_array');
      display_status (status);
    ELSEIF puv$bacpf_backup_file_version = puc$backup_file_version_2 THEN
      pfp$find_cycle_array_version_2 (file_item_info, p_cycle_array_version_2, status);
      IF status.normal AND (p_cycle_array_version_2 = NIL) THEN
        osp$set_status_abnormal (pfc$permanent_file_manager_id, pfe$unknown_cycle_array, '', status);
      IFEND;
      display (' pfp$find_cycle_array_version_2');
      display_status (status);
    IFEND;
    IF status.normal THEN
      pfp$find_cycle_array_extended (file_item_info, p_cycle_array_extended_record, status);
      display (' pfp$find_cycle_array_extended');
      display_status (status);
      IF status.normal THEN
        pfp$find_cycle_directory (p_cycle_array_extended_record, p_cycle_directory_array, status);
        display (' pfp$find_cycle_directory');
        display_status (status);
        IF status.normal THEN
          IF puv$bacpf_backup_file_version = puc$backup_file_version_1 THEN
            PUSH p_cycle_array_version_2: [1 .. UPPERBOUND (p_cycle_array_version_1^)];
            FOR j := 1 TO UPPERBOUND (p_cycle_array_version_1^) DO
              p_cycle_array_version_2^ [j].bytes_allocated := 0;
              p_cycle_array_version_2^ [j].cycle_damage_symptoms := $fst$cycle_damage_symptoms [];
              p_cycle_array_version_2^ [j].cycle_number := p_cycle_array_version_1^ [j].cycle_number;
              p_cycle_array_version_2^ [j].cycle_statistics := p_cycle_array_version_1^ [j].cycle_statistics;
              p_cycle_array_version_2^ [j].data_modification_date_time :=
                    p_cycle_array_version_1^ [j].cycle_statistics.modification_date_time;
              p_cycle_array_version_2^ [j].data_residence := pfc$unreleasable_data;
              p_cycle_array_version_2^ [j].device_class := rmc$mass_storage_device;
              p_cycle_array_version_2^ [j].eoi := 0;
              p_cycle_array_version_2^ [j].expiration_date_time :=
                    p_cycle_array_version_1^ [j].expiration_date_time;
              p_cycle_array_version_2^ [j].original_unique_name := puv$null_original_unique_name;
              p_cycle_array_version_2^ [j].sparse_allocation := FALSE;
              p_cycle_array_version_2^ [j].cycle_reservation.cycle_reserved := FALSE;
              p_cycle_array_version_2^ [j].reserved_cycle_array_entry_sp :=
                    puv$null_res_cycle_array_ent_sp;
            FOREND;
          IFEND;
          IF pup$excluded_highest_cycles () > 0 THEN
            pup$sort_cycle_array_version_2 (p_cycle_array_version_2^);
          IFEND;
          file_archive_info.sequence_pointer := NIL;
          FOR i := LOWERBOUND (p_cycle_array_version_2^) TO (UPPERBOUND (p_cycle_array_version_2^)) DO
            cycle_selector.cycle_option := pfc$specific_cycle;
            cycle_selector.cycle_number := p_cycle_array_version_2^ [i].cycle_number;
            pup$build_entry (pf_entry.pfn, cycle_selector, puc$valid_cycle_entry, cycle_entry);
            pup$check_cycle_inclusion (pf_utility_catalog_header, cycle_entry, p_cycle_array_version_2^, i,
                  cycle_included, action_descriptor);
            IF cycle_included THEN
              {
              {    This code takes advantage of the fact that the cycle array and the cycle directory array
              {  contain the same cycle numbers in the same order.
              {
              pfp$find_direct_info_record (^p_cycle_array_extended_record^.body,
                    p_cycle_directory_array^ [i].info_offset, p_cycle_info_record, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              pup$backup_cycle (cycle_entry, local_password, pf_utility_catalog_header,
                    p_cycle_array_version_2^ [i], pf_utility_hierarchy_list, { check_cycle_included } TRUE,
                    file_display_info, p_cycle_info_record, file_archive_info, p_cycle_array_extended_record,
                    p_cycle_directory_array, pf_backup_file_id, status);
              pup$write_status_to_listing (cycle_entry, status, local_status);
              IF NOT puv$global_backup_file_id.backup_file_open THEN
                {
                { pup$backup_catalog encountered an error writing to the backup_file and closed it.
                { Return the abnormal status to the caller.
                {
                RETURN;
              IFEND;
              status.normal := TRUE;
            ELSE
              pup$write_excluded_cycle (cycle_entry, p_cycle_array_version_2^ [i], puc$unknown_cycle_size,
                    puv$unknown_global_file_name, {recorded vsn} NIL, p_cycle_array_extended_record,
                    p_cycle_directory_array, action_descriptor, local_status);
            IFEND;
          FOREND;
          IF file_archive_info.sequence_pointer <> NIL THEN
            mmp$delete_scratch_segment (file_archive_info, local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pup$backup_file;

?? TITLE := '    [XDCL] pup$backup_file_command ', EJECT ??

  PROCEDURE [XDCL] pup$backup_file_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      cycle_selector: pft$cycle_selector,
      cycle_specified: boolean,
      local_status: ost$status,
      p_path: ^pft$path,
      password: pft$password,
      path_container: clt$path_container;

    crack_backup_file (parameter_list, p_path, path_container, cycle_specified, cycle_selector, password,
          status);
    IF status.normal THEN
      IF cycle_specified THEN
        pup$backup_cycle_request (p_path^, cycle_selector, password, puv$backup_file_id, status);
      ELSE
        pup$backup_file_request (p_path^, password, puv$backup_file_id, status);
      IFEND;
    IFEND;
  PROCEND pup$backup_file_command;

?? TITLE := '    pup$backup_file_request ', EJECT ??

  PROCEDURE pup$backup_file_request
    (    file_path: pft$path;
         password: pft$password;
     VAR pf_backup_file_id: put$file_identifier;
     VAR status: ost$status);

    VAR
      dummy_cycle_selector: pft$cycle_selector,
      file_info_selections: pft$file_info_selections,
      file_item_info: amt$segment_pointer,
      group: pft$group,
      local_status: ost$status,
      p_body: pft$p_info,
      p_directory_array: pft$p_directory_array,
      p_hierarchy_list: ^put$hierarchy_list,
      p_info_record: pft$p_info_record,
      p_item_record: pft$p_info_record,
      pf_entry: put$entry,
      pf_lfn: amt$local_file_name,
      set_name: stt$set_name;

    status.normal := TRUE;

    pfp$get_family_set (file_path [pfc$family_name_index], set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$build_entry (file_path [UPPERBOUND (file_path)], dummy_cycle_selector, puc$valid_pf_entry, pf_entry);
    PUSH p_hierarchy_list: [1 .. UPPERBOUND (file_path)];
    pup$build_catalog_header (set_name, ^file_path, p_hierarchy_list^.catalog_header);
    pup$build_hierarchy_list (pf_entry, p_hierarchy_list^.catalog_header, p_hierarchy_list^, status);
    IF status.normal THEN
      pup$verify_file_path (file_path, status);
      IF status.normal THEN
        mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, file_item_info, status);
        IF status.normal THEN
          IF puv$bacpf_backup_file_version = puc$backup_file_version_1 THEN
            IF puv$include_archive_information THEN
              file_info_selections := - $pft$file_info_selections [pfc$file_cycles_version_2];
            ELSE
              file_info_selections :=
                    - $pft$file_info_selections [pfc$archive_descriptors, pfc$file_cycles_version_2];
            IFEND;
          ELSEIF puv$bacpf_backup_file_version = puc$backup_file_version_2 THEN
            IF puv$include_archive_information THEN
              file_info_selections := - $pft$file_info_selections [pfc$file_cycles];
            ELSE
              file_info_selections :=
                    - $pft$file_info_selections [pfc$archive_descriptors, pfc$file_cycles];
            IFEND;
          IFEND;
          group.group_type := pfc$public;
          RESET file_item_info.sequence_pointer;
          pfp$get_item_info (file_path, group, $pft$catalog_info_selections [], file_info_selections,
                file_item_info.sequence_pointer, status);
          IF status.normal THEN
            RESET file_item_info.sequence_pointer;
            pfp$find_next_info_record (file_item_info.sequence_pointer, p_info_record, status);
            IF status.normal THEN
              pfp$find_directory_array (p_info_record, p_directory_array, status);
              IF status.normal AND (p_directory_array <> NIL) THEN
                p_body := ^p_info_record^.body;
                pfp$find_direct_info_record (p_body, p_directory_array^ [LOWERBOUND (p_directory_array^)].
                      info_offset, p_item_record, status);
                IF status.normal THEN
                  pup$initialize_backup_listing (p_hierarchy_list^, pf_backup_file_id, puv$backup_information,
                        status);
                  IF status.normal THEN
                    pup$backup_file (pf_entry, {password_provided =} TRUE, password,
                          p_hierarchy_list^.catalog_header, p_hierarchy_list^, pf_backup_file_id,
                          p_item_record, status);
                  IFEND;
                  pup$display_backup_output_total;
                  pup$get_summary_status (status);
                  pup$write_os_status (status, local_status);
                IFEND;
              IFEND;
            IFEND;
          IFEND;
          mmp$delete_scratch_segment (file_item_info, local_status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND pup$backup_file_request;

?? TITLE := '    [XDCL] pup$check_cycle_inclusion ', EJECT ??

  PROCEDURE [XDCL] pup$check_cycle_inclusion
    (    catalog_header: put$catalog_header;
         cycle_entry: put$entry;
         sorted_cycle_array: pft$cycle_array_version_2;
         cycle_array_index: integer;
     VAR cycle_included: boolean;
     VAR action_descriptor: put$action_descriptor);

    VAR
      cycle_excluded: boolean;

    action_descriptor := '';
    cycle_included := TRUE;
    pup$check_site_backup_options (sorted_cycle_array [cycle_array_index], cycle_included);
    IF NOT cycle_included THEN
      action_descriptor := 'EXCLUDE SITE';
    ELSE
      IF cycle_array_index > (UPPERBOUND (sorted_cycle_array) - pup$excluded_highest_cycles ()) THEN
        cycle_included := FALSE;
        action_descriptor := 'EXCLUDE HIGH';
      ELSE
        pup$check_if_item_excluded (cycle_entry, catalog_header, cycle_excluded);
        cycle_included := NOT cycle_excluded;
        IF cycle_excluded THEN
          action_descriptor := 'EXCLUDE FILE';
        ELSE
          pup$check_cycle_access (sorted_cycle_array [cycle_array_index], cycle_included);
          IF NOT cycle_included THEN
            action_descriptor := 'EXCLUDE CYCLE';
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND pup$check_cycle_inclusion;


?? TITLE := '    crack_backup_file ', EJECT ??

  PROCEDURE crack_backup_file
    (    parameter_list: clt$parameter_list;
     VAR p_path: ^pft$path;
     VAR path_container: clt$path_container;
     VAR cycle_specified: boolean;
     VAR cycle_selector: pft$cycle_selector;
     VAR password: pft$password;
     VAR status: ost$status);


{ PROCEDURE (osm$bacf) backup_file, bacf (
{   file, f: file = $required
{   password, pw: (SECURE) any of
{       key
{         none
{       keyend
{       name
{     anyend = none
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: 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$name_type_qualifier,
          recend,
          default_value: string (4),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 20, 12, 57, 6, 159], clc$command, 5, 3, 1, 0, 0, 0, 3, 'OSM$BACF'],
            [['F                              ', clc$abbreviation_entry, 1],
            ['FILE                           ', clc$nominal_entry, 1],
            ['PASSWORD                       ', clc$nominal_entry, 2],
            ['PW                             ', clc$abbreviation_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3]], [
{ PARAMETER 1
      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [3, clc$normal_usage_entry, clc$secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 69, clc$optional_default_parameter, 0, 4],
{ PARAMETER 3
      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$file_type]],
{ PARAMETER 2
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]], 'none'],
{ PARAMETER 3
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$file = 1,
      p$password = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{crack file
    pup$crack_pf_file_reference (pvt [p$file].value^.file_value^,
          $put$cycle_reference_selections [puc$cycle_omitted, puc$specific_cycle, puc$highest_cycle,
          puc$lowest_cycle], 'FILE', path_container, p_path, cycle_specified, cycle_selector, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$password].value^.kind = clc$name THEN
      password := pvt [p$password].value^.name_value;
    ELSE {keyword = NONE}
      password := osc$null_name;
    IFEND;
  PROCEND crack_backup_file;
MODEND pum$backup_file;
*DECK DECK=PUM$BACKUP_FILE_INPUT EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Backup/Restore Utilities : Backup File Input' ??
MODULE pum$backup_file_input;

{ PURPOSE:
{   This module contains those routines that read from the backup file.  These
{   routines are used by the restore permanent file utility.

?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc fst$path
*copyc osd$integer_limits
*copyc ost$date_time
*copyc ost$name
*copyc pfc$null_shared_queue
*copyc pfd$archive_definitions
*copyc pfd$catalog_info
*copyc pfe$external_archive_conditions
*copyc pfe$internal_error_conditions
*copyc pft$cycle_info_desc_version_1
*copyc pft$cycle_info_desc_version_2
*copyc pft$date_time
*copyc pmt$comparison_result
*copyc pud$backup_file
*copyc pud$hierarchy_list
*copyc pud$list_options
*copyc pue$error_condition_codes
*copyc put$selected_object
?? POP ??
?? EJECT ??
*copyc amp$close
*copyc avp$family_administrator
*copyc avp$system_administrator
*copyc clp$get_fs_path_string
*copyc fsp$build_file_ref_from_elems
*copyc fsp$change_cycle_date_time
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$set_status_abnormal
*copyc osv$initial_exception_context
*copyc pfp$convert_device_class_to_rm
*copyc pfp$convert_pft$path_to_fs_path
*copyc pfp$delete_all_archive_entries
*copyc pfp$delete_cycle_data
*copyc pfp$find_archive_info
*copyc pfp$find_cycle_array
*copyc pfp$find_cycle_array_extended
*copyc pfp$find_cycle_array_version_2
*copyc pfp$find_cycle_directory
*copyc pfp$find_cycle_media
*copyc pfp$find_file_description
*copyc pfp$find_next_archive_entry
*copyc pfp$get_object_information
*copyc pfp$get_ownership
*copyc pfp$put_archive_info
*copyc pfp$put_cycle_info
*copyc pfp$put_family_info
*copyc pfp$put_item_info
*copyc pfp$put_master_catalog_info
*copyc pmp$date_time_compare
*copyc pup$build_entry
*copyc pup$build_new_online_cat_head
*copyc pup$check_cycle_access
*copyc pup$compare_item_descriptor
*copyc pup$compare_paths
*copyc pup$determine_if_item_exists
*copyc pup$display_boolean
*copyc pup$display_item_descriptor
*copyc pup$display_line
*copyc pup$display_blank_lines
*copyc pup$find_cycle_info_record
*copyc pup$format_date_time
*copyc pup$get_file_password
*copyc pup$get_item_descriptor
*copyc pup$get_next_hierarchy_list
*copyc pup$get_next_record_header
*copyc pup$get_part
*copyc pup$physical_path_length
*copyc pup$restore_cycle_item
*copyc pup$set_abnormal_entry_status
*copyc pup$set_object_abnormal
*copyc pup$skip_logical_partition
*copyc pup$skip_physical_partition
*copyc pup$validate_n_n_minus_1
*copyc pup$verify_catalog_path
*copyc pup$verify_file_path
*copyc pup$write_os_status
*copyc pup$write_path
*copyc pup$write_status_to_listing
*copyc pup$write_sub_path
*copyc puv$backup_criteria
*copyc puv$create_objects
*copyc puv$cycle_display_selections
*copyc puv$mass_storage_info
*copyc puv$null_original_unique_name
*copyc puv$null_res_cycle_array_ent_sp
*copyc puv$p_included_volumes
*copyc puv$purge_cycle_options
*copyc puv$replace_cycle_data
*copyc puv$require_modification_match
*copyc puv$respf_backup_file_version
*copyc puv$respf_backup_file_version
*copyc puv$restore_archive_information
*copyc puv$trace_selected
*copyc puv$volumes_switched_forward

?? TITLE := '  Global Declarations Declared by this module', EJECT ??

    CONST
      include_radix = TRUE,
      radix = 10;

    VAR
      p_cycle_array_extended_record: pft$p_info_record := NIL,
      p_cycle_directory_array: pft$p_cycle_directory_array := NIL;

?? TITLE := '    [XDCL] pup$find_restore_entry ', EJECT ??
*copyc puh$find_restore_entry

  PROCEDURE [XDCL] pup$find_restore_entry (entry: put$entry;
        catalog_header: put$catalog_header;
    VAR backup_file_id: put$file_identifier;
    VAR file_position: put$file_position;
    VAR status: ost$status);

    VAR
      entry_found: boolean,
      local_status: ost$status,
      p_item_description: ^put$backup_item_descriptor,
      record_header: put$backup_file_record_header,
      requested_subset_found: boolean,
      stored_backup_file_version: put$backup_file_version_name;

    entry_found := FALSE;

  /loop_through_partitions/
    REPEAT
      pup$locate_valid_version (backup_file_id, stored_backup_file_version, file_position, status);
      IF status.normal AND (file_position <> puc$eoi) THEN
        pup$get_next_record_header (backup_file_id, record_header, file_position, status);
        IF status.normal THEN
          IF (record_header.kind = puc$backup_item_identifier) AND (record_header.size > 0) THEN
            ALLOCATE p_item_description: [1 .. record_header.size];
            pup$get_item_descriptor (backup_file_id, p_item_description^, file_position, status);
            IF status.normal THEN
              pup$compare_item_descriptor (entry, catalog_header, p_item_description^.pf_utility_entry,
                    p_item_description^.catalog_header, entry_found, requested_subset_found);
            IFEND;
            FREE p_item_description;
          ELSE
            osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_item_requested, ' identifier', status);
          IFEND;
        IFEND;
        pup$write_os_status (status, local_status);
        status.normal := TRUE;
        IF NOT entry_found AND (file_position = puc$mid_partition) THEN
          pup$skip_logical_partition (backup_file_id, file_position, status);
        IFEND;
      IFEND;
    UNTIL entry_found OR (file_position = puc$eoi) OR (NOT status.normal);

    IF status.normal AND NOT entry_found THEN
      pup$set_abnormal_entry_status (entry, pue$no_restore_no_find, status);
    IFEND;
  PROCEND pup$find_restore_entry;

?? TITLE := '    [XDCL] pup$get_backup_cycle_info ', EJECT ??

  PROCEDURE [XDCL] pup$get_backup_cycle_info
   (VAR backup_file_id: put$file_identifier;
    VAR file_position: put$file_position;
    VAR cycle_array_entry: pft$cycle_array_entry_version_2;
    VAR p_file_media_descriptor: ^SEQ ( * );
    VAR status: ost$status);

{  This routine extracts the cycle array entry from the backup file.

    VAR
      fmd_size: integer,
      p_cycle_info_desc_version_1: ^pft$cycle_info_desc_version_1,
      p_cycle_info_desc_version_2: ^pft$cycle_info_desc_version_2,
      p_cycle_info_fmd: ^SEQ ( * ),
      p_fmd: ^SEQ ( * ),
      record_header: put$backup_file_record_header,
      rm_device_class: rmt$device_class,
      transfer_count: amt$file_length;

    pup$get_next_record_header (backup_file_id, record_header, file_position, status);
    IF status.normal THEN
      IF (file_position = puc$mid_partition) AND (record_header.kind = puc$backup_cycle_info) THEN
        IF puv$respf_backup_file_version = puc$backup_file_version_1 THEN
          PUSH p_cycle_info_desc_version_1;
          pup$get_part (backup_file_id, p_cycle_info_desc_version_1, #SIZE (p_cycle_info_desc_version_1^),
                file_position, transfer_count, status);
          IF status.normal THEN
            cycle_array_entry.bytes_allocated := 0;
            cycle_array_entry.cycle_damage_symptoms := $fst$cycle_damage_symptoms [];
            cycle_array_entry.cycle_number := p_cycle_info_desc_version_1^.cycle_number;
            cycle_array_entry.cycle_statistics := p_cycle_info_desc_version_1^.cycle_statistics;
            cycle_array_entry.data_modification_date_time :=
                  p_cycle_info_desc_version_1^.cycle_statistics.modification_date_time;
            cycle_array_entry.data_residence := pfc$unreleasable_data;
            cycle_array_entry.device_class := rmc$mass_storage_device;
            cycle_array_entry.eoi := 0;
            cycle_array_entry.expiration_date_time := p_cycle_info_desc_version_1^.expiration_date_time;
            cycle_array_entry.original_unique_name := puv$null_original_unique_name;
            cycle_array_entry.retrieve_option := pfc$always_retrieve;
            cycle_array_entry.shared_queue_info.defined := FALSE;
            cycle_array_entry.site_archive_option := pfc$null_site_archive_option;
            cycle_array_entry.site_backup_option := pfc$null_site_backup_option;
            cycle_array_entry.site_release_option := pfc$null_site_release_option;
            cycle_array_entry.sparse_allocation := FALSE;
            cycle_array_entry.reserved_cycle_array_entry_sp := puv$null_res_cycle_array_ent_sp;
            p_file_media_descriptor := NIL;
          IFEND;
        ELSEIF puv$respf_backup_file_version = puc$backup_file_version_2 THEN
          IF record_header.size > (#SIZE(pft$cycle_info_desc_version_2: [[REP 1 OF cell]]) - 1) THEN
            fmd_size := record_header.size - (#SIZE(pft$cycle_info_desc_version_2: [[REP 1 OF cell]]) - 1);
          ELSE
            fmd_size := 1;
          IFEND;
          PUSH p_cycle_info_desc_version_2: [[REP fmd_size OF cell]];
          pup$get_part (backup_file_id, p_cycle_info_desc_version_2, record_header.size, file_position,
                transfer_count, status);
          IF status.normal AND p_cycle_info_desc_version_2^.sparse_backup_file_format THEN
            osp$set_status_abnormal (puc$pf_utility_id, pfe$sparse_allocation_format,
                 'backup cycle info', status);
          IFEND;
          IF status.normal AND ((p_cycle_info_desc_version_2^.device_class <> pfc$magnetic_tape_device) AND
                (p_cycle_info_desc_version_2^.device_class <> pfc$mass_storage_device)) THEN
            osp$set_status_abnormal (puc$pf_utility_id, pfe$unsupported_device_class,
                 'backup cycle info', status);
          IFEND;
          IF status.normal THEN
            cycle_array_entry.bytes_allocated := 0;
            cycle_array_entry.cycle_damage_symptoms := p_cycle_info_desc_version_2^.cycle_damage_symptoms;
            cycle_array_entry.cycle_number := p_cycle_info_desc_version_2^.cycle_number;
            cycle_array_entry.cycle_statistics := p_cycle_info_desc_version_2^.cycle_statistics;
            cycle_array_entry.data_modification_date_time :=
                  p_cycle_info_desc_version_2^.data_modification_date_time;
            cycle_array_entry.data_residence := pfc$unreleasable_data;
            pfp$convert_device_class_to_rm (p_cycle_info_desc_version_2^.device_class, rm_device_class);
            cycle_array_entry.device_class := rm_device_class;
            cycle_array_entry.eoi := 0;
            cycle_array_entry.expiration_date_time := p_cycle_info_desc_version_2^.expiration_date_time;
            cycle_array_entry.original_unique_name := p_cycle_info_desc_version_2^.original_unique_name;
            cycle_array_entry.retrieve_option := p_cycle_info_desc_version_2^.retrieve_option;
            cycle_array_entry.shared_queue_info := p_cycle_info_desc_version_2^.shared_queue_info;
            cycle_array_entry.site_archive_option := p_cycle_info_desc_version_2^.site_archive_option;
            cycle_array_entry.site_backup_option := p_cycle_info_desc_version_2^.site_backup_option;
            cycle_array_entry.site_release_option := p_cycle_info_desc_version_2^.site_release_option;
            cycle_array_entry.sparse_allocation := FALSE;
            cycle_array_entry.reserved_cycle_array_entry_sp := puv$null_res_cycle_array_ent_sp;
            IF fmd_size > 1 THEN
              ALLOCATE p_file_media_descriptor: [[REP fmd_size OF cell]];
              p_fmd := ^p_cycle_info_desc_version_2^.file_media_descriptor;
              NEXT p_cycle_info_fmd: [[REP fmd_size OF cell]] IN p_fmd;
              p_file_media_descriptor^ := p_cycle_info_fmd^;
            ELSE
              p_file_media_descriptor := NIL;
            IFEND;
          IFEND;
        IFEND;
      ELSE
        osp$set_status_abnormal (puc$pf_utility_id, pue$unusable_restore_file, 'backup cycle info', status);
      IFEND;
    IFEND;
  PROCEND pup$get_backup_cycle_info;

?? TITLE := '    [XDCL] pup$locate_valid_version ', EJECT ??

  PROCEDURE [XDCL] pup$locate_valid_version (
    VAR backup_file_id: put$file_identifier;
    VAR stored_backup_file_version_name: put$backup_file_version_name;
    VAR file_position: put$file_position;
    VAR status: ost$status);

    VAR
      local_status: ost$status,
      transfer_count: amt$file_length;

  /search_for_valid_version/
    WHILE TRUE DO
      pup$get_part (backup_file_id, ^stored_backup_file_version_name, #SIZE (stored_backup_file_version_name),
            file_position, transfer_count, status);
      IF status.normal THEN
        validate_version_number (stored_backup_file_version_name, backup_file_id, status);
      IFEND;
      IF status.normal OR ((NOT status.normal) AND( status.condition = pue$incompatible_backup_version)) THEN
        EXIT /search_for_valid_version/;
      ELSEIF file_position = puc$eoi THEN
        status.normal := TRUE;
        EXIT /search_for_valid_version/;
      ELSE
        IF puv$volumes_switched_forward THEN
          display (' eat status');
          display_status (status);
        ELSE
          pup$write_os_status (status, local_status);
        IFEND;
        pup$skip_logical_partition (backup_file_id, file_position, status);
        IF (NOT status.normal) OR (file_position = puc$eoi) THEN
          EXIT /search_for_valid_version/;
        IFEND;
      IFEND;
    WHILEND /search_for_valid_version/;

  PROCEND pup$locate_valid_version;

?? TITLE := '  [XDCL] pup$restore_catalog_info', EJECT ??

  PROCEDURE [XDCL] pup$restore_catalog_info
    (    new_online_cat_header: put$catalog_header;
     VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    VAR
      all_permits_restored: boolean,
      backup_file_version: pft$backup_file_version,
      context: ost$ecp_exception_context,
      initial_pass: boolean,
      local_status: ost$status,
      p_info_record: pft$p_info_record,
      permit_status: ost$status,
      record_header: put$backup_file_record_header,
      transfer_count: amt$file_length;

    initial_pass := TRUE;
    pup$write_path (new_online_cat_header.path, local_status);

    { Get item info.

    pup$get_next_record_header (backup_file_id, record_header, file_position, status);
    IF status.normal THEN
      IF (file_position = puc$mid_partition) AND ((record_header.kind = puc$backup_family_info) OR
            (record_header.kind = puc$backup_catalog_info)) AND (record_header.size > 0) THEN
        PUSH p_info_record: [[REP record_header.size OF cell]];
        pup$get_part (backup_file_id, p_info_record, #SIZE (p_info_record^), file_position,
              transfer_count, status);
      ELSE
        osp$set_status_abnormal (puc$pf_utility_id, pue$unusable_restore_file, ' info ', status);
      IFEND;
    IFEND;

    { Put item info.

    IF status.normal THEN
      CASE new_online_cat_header.logical_path_length OF
      = pfc$family_name_index =
        REPEAT
          pfp$put_family_info (new_online_cat_header.set_name,
                new_online_cat_header.path [pfc$family_name_index], p_info_record, status);
          IF NOT status.normal THEN
            IF initial_pass THEN
              initial_pass := FALSE;
              context := osv$initial_exception_context;
              context.file.selector := osc$ecp_pf_path;
              context.file.file_reference := ^new_online_cat_header.path [pfc$family_name_index];
              context.catalog_object := TRUE;
            IFEND;
            context.condition_status := status;
            osp$enforce_exception_policies (context);
            status := context.condition_status;
          IFEND;
        UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context.wait);
      = pfc$master_catalog_name_index =
        REPEAT
          pfp$put_master_catalog_info (new_online_cat_header.set_name,
                new_online_cat_header.path [pfc$family_name_index],
                new_online_cat_header.path [pfc$master_catalog_name_index], p_info_record, status);
          IF NOT status.normal THEN
            IF initial_pass THEN
              initial_pass := FALSE;
              context := osv$initial_exception_context;
              context.file.selector := osc$ecp_pf_path;
              context.file.file_reference := ^new_online_cat_header.path [pfc$master_catalog_name_index];
              context.catalog_object := TRUE;
            IFEND;
            context.condition_status := status;
            osp$enforce_exception_policies (context);
            status := context.condition_status;
          IFEND;
        UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context.wait);
      ELSE
        IF puv$respf_backup_file_version = puc$backup_file_version_1 THEN
          backup_file_version := pfc$backup_file_version_1;
        ELSEIF puv$respf_backup_file_version = puc$backup_file_version_2 THEN
          backup_file_version := pfc$backup_file_version_2;
        IFEND;
        pfp$put_item_info (new_online_cat_header.path, p_info_record, {puv$restore_archive_information}
              FALSE, puv$backup_criteria, backup_file_version, all_permits_restored, status);
      CASEND;
    IFEND;

    IF status.normal THEN
      IF NOT all_permits_restored THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$not_all_permits_restored, 'catalog', status);
        pup$write_os_status (status, local_status);
      IFEND;
    ELSE
      IF NOT all_permits_restored THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$not_all_permits_restored, 'catalog', permit_status);
        pup$write_os_status (permit_status, local_status);
      IFEND;

      IF status.condition = pfe$name_already_subcatalog THEN
        pup$display_line ('    -- CATALOG ALREADY EXISTS', local_status);
      ELSE
        pup$write_os_status (status, local_status);
      IFEND;
    IFEND;
  PROCEND pup$restore_catalog_info;

?? TITLE := '    [XDCL] pup$restore_selected_objects ', EJECT ??

  PROCEDURE [XDCL] pup$restore_selected_objects
    (    p_selected_objects: ^put$selected_object;
     VAR backup_file_id: put$file_identifier;
     VAR status: ost$status);

    VAR
      all_objects_restored: boolean,
      cycle_count: integer,
      cycle_index: integer,
      entry_found: boolean,
      file_position: put$file_position,
      found_entry: put$entry,
      local_entry_found: boolean,
      local_requested_subset_found: boolean,
      local_status: ost$status,
      new_entry: put$entry,
      p_current_object: ^put$selected_object,
      p_cycle_entries: ^array [1 .. *] of put$entry,
      p_cycle_object: ^put$selected_object,
      p_item_description: ^put$backup_item_descriptor,
      p_search_object: ^put$selected_object,
      p_selected_cycles: ^array [1 .. *] of put$selected_cycle_info,
      p_subset_object: ^put$selected_object,
      record_header: put$backup_file_record_header,
      requested_subset_found: boolean,
      restore_entry: boolean,
      stored_backup_file_version: put$backup_file_version_name;

    entry_found := FALSE;

  /loop_through_partitions/
    REPEAT
      pup$locate_valid_version (backup_file_id, stored_backup_file_version, file_position, status);
      IF status.normal AND (file_position <> puc$eoi) THEN
        pup$get_next_record_header (backup_file_id, record_header, file_position, status);
        IF status.normal THEN
          IF (record_header.kind = puc$backup_item_identifier) AND (record_header.size >= 1) THEN
            ALLOCATE p_item_description: [1 .. record_header.size];
            pup$get_item_descriptor (backup_file_id, p_item_description^, file_position, status);
            IF status.normal THEN
              all_objects_restored := TRUE;
              cycle_count := 0;
              entry_found := FALSE;
              found_entry := p_item_description^.pf_utility_entry;
              p_cycle_entries := NIL;
              p_search_object := p_selected_objects;
              p_selected_cycles := NIL;
              p_subset_object := NIL;
              requested_subset_found := FALSE;
              restore_entry := FALSE;

            /search_selected_objects/
              WHILE p_search_object <> NIL DO
                all_objects_restored := (all_objects_restored AND p_search_object^.object_restored);
                pup$compare_item_descriptor (p_search_object^.entry, p_search_object^.p_catalog_header^,
                      p_item_description^.pf_utility_entry, p_item_description^.catalog_header,
                      local_entry_found, local_requested_subset_found);
                IF local_entry_found THEN
                  IF NOT entry_found THEN
                    entry_found := TRUE;
                    p_current_object := p_search_object;
                  IFEND;
                  IF (p_search_object^.entry.entry_type = puc$valid_pf_entry) AND
                        (p_search_object^.selected_cycle_info.selected_cycle.cycle_specified OR
                        p_search_object^.selected_cycle_info.new_selected_cycle.cycle_specified) THEN
                    cycle_count := cycle_count + 1;
                  IFEND;
                ELSEIF local_requested_subset_found THEN
                  IF NOT requested_subset_found THEN
                    p_subset_object := p_search_object;
                    requested_subset_found := TRUE;
                  IFEND;
                  IF (p_search_object^.entry.entry_type = puc$valid_pf_entry) AND
                        (p_search_object^.selected_cycle_info.selected_cycle.cycle_specified OR
                        p_search_object^.selected_cycle_info.new_selected_cycle.cycle_specified) THEN
                    cycle_count := cycle_count + 1;
                  IFEND;
                IFEND;
                p_search_object := p_search_object^.link;
              WHILEND /search_selected_objects/;

              IF requested_subset_found AND (NOT entry_found) THEN
                p_current_object := p_subset_object;
              IFEND;

              IF entry_found OR requested_subset_found THEN
                IF p_item_description^.pf_utility_entry.entry_type = puc$valid_pf_entry THEN
                  restore_entry := TRUE;
                  new_entry := p_current_object^.new_entry;
                  IF cycle_count > 0 THEN
                    PUSH p_selected_cycles: [1 .. cycle_count];
                    PUSH p_cycle_entries: [1 .. cycle_count];
                    p_search_object := p_selected_objects;
                    cycle_index := 1;
                  /collect_selected_cycles/
                    WHILE p_search_object <> NIL DO
                      pup$compare_item_descriptor (p_search_object^.entry, p_search_object^.p_catalog_header^,
                            p_item_description^.pf_utility_entry, p_item_description^.catalog_header,
                            local_entry_found, local_requested_subset_found);
                      IF (local_entry_found OR local_requested_subset_found) AND
                            (p_search_object^.entry.entry_type = puc$valid_pf_entry) THEN
                        p_search_object^.object_restored := TRUE;
                        p_selected_cycles^ [cycle_index] := p_search_object^.selected_cycle_info;
                        p_cycle_entries^ [cycle_index].entry_type := puc$valid_cycle_entry;
                        p_cycle_entries^ [cycle_index].pf_selector.pfn :=
                              p_search_object^.entry.pfn;
                        p_cycle_entries^ [cycle_index].pf_selector.cycle_selector :=
                              p_search_object^.selected_cycle_info.selected_cycle.cycle_selector;
                        cycle_index := cycle_index + 1;
                      IFEND;
                      p_search_object := p_search_object^.link;
                    WHILEND /search_selected_objects/;
                  IFEND;
                  pup$write_sub_path (p_current_object^.p_new_catalog_header^.path,
                        LOWERBOUND (p_current_object^.p_new_catalog_header^.path),
                        UPPERBOUND (p_current_object^.p_new_catalog_header^.path) - 1, status);
                ELSEIF p_item_description^.pf_utility_entry.entry_type = puc$valid_cycle_entry THEN
                  p_search_object := p_selected_objects;
                /search_cycle_objects/
                  WHILE p_search_object <> NIL DO
                    IF (p_search_object^.entry.entry_type = puc$valid_cycle_entry) AND
                          p_search_object^.object_restored THEN
                      p_search_object := p_search_object^.link;
                      CYCLE /search_cycle_objects/;
                    IFEND;
                    pup$compare_item_descriptor (p_search_object^.entry, p_search_object^.p_catalog_header^,
                          p_item_description^.pf_utility_entry, p_item_description^.catalog_header,
                          local_entry_found, local_requested_subset_found);
                    IF local_entry_found THEN
                      restore_entry := TRUE;
                      p_current_object := p_search_object;
                      new_entry := found_entry;
                      PUSH p_selected_cycles: [1 .. 1];
                      p_selected_cycles ^[1] := p_search_object^.selected_cycle_info;
                      EXIT /search_cycle_objects/
                    ELSEIF local_requested_subset_found THEN
                      IF p_search_object^.entry.entry_type = puc$valid_pf_entry THEN
                        IF p_search_object^.selected_cycle_info.selected_cycle.cycle_specified THEN
                          IF (p_search_object^.selected_cycle_info.selected_cycle.cycle_selector.
                                cycle_option = pfc$specific_cycle) AND
                                (p_search_object^.selected_cycle_info.selected_cycle.cycle_selector.
                                cycle_number = p_item_description^.pf_utility_entry.pf_selector.
                                cycle_selector.cycle_number) THEN
                            p_search_object^.object_restored := TRUE;
                          IFEND;
                        ELSEIF NOT p_search_object^.selected_cycle_info.new_selected_cycle.cycle_specified
                              THEN
                          restore_entry := TRUE;
                          p_current_object := p_search_object;
                          new_entry := found_entry;
                          EXIT /search_cycle_objects/
                        IFEND;
                      ELSEIF p_search_object^.entry.entry_type = puc$valid_cycle_entry THEN
                        restore_entry := TRUE;
                        p_current_object := p_search_object;
                        new_entry := p_current_object^.new_entry;
                        PUSH p_selected_cycles: [1 .. 1];
                        p_selected_cycles ^[1] := p_search_object^.selected_cycle_info;
                        EXIT /search_cycle_objects/
                      ELSE
                        restore_entry := TRUE;
                        p_current_object := p_search_object;
                        new_entry := found_entry;
                        PUSH p_selected_cycles: [1 .. 1];
                        p_selected_cycles ^[1].selected_cycle.cycle_specified := TRUE;
                        p_selected_cycles ^[1].selected_cycle.cycle_selector :=
                              p_item_description^.pf_utility_entry.pf_selector.cycle_selector;
                        p_selected_cycles ^[1].new_selected_cycle.cycle_specified := TRUE;
                        p_selected_cycles ^[1].new_selected_cycle.cycle_selector :=
                              p_item_description^.pf_utility_entry.pf_selector.cycle_selector;
                        EXIT/search_cycle_objects/
                      IFEND;
                    IFEND;
                    p_search_object := p_search_object^.link;
                  WHILEND /search_cycle_objects/;
                ELSE
                  restore_entry := TRUE;
                  new_entry := found_entry;
                IFEND;

                IF restore_entry THEN
                  p_current_object^.object_restored := TRUE;

                  restore_found_entry (p_current_object^.p_catalog_header^, {password_specified} FALSE,
                        {password} osc$null_name, p_item_description^.catalog_header, found_entry,
                        p_current_object^.p_new_catalog_header^, new_entry, p_selected_cycles, backup_file_id,
                        file_position, local_status);

                  IF local_status.normal THEN
                    IF p_current_object^.entry.entry_type = puc$valid_pf_entry THEN
                      IF p_cycle_entries <> NIL THEN
                        FOR cycle_index := 1 TO UPPERBOUND (p_cycle_entries^) DO
                          IF (p_cycle_entries^ [cycle_index].pf_selector.cycle_selector.cycle_option =
                                pfc$highest_cycle) OR
                                (p_cycle_entries^ [cycle_index].pf_selector.cycle_selector.cycle_option =
                                pfc$lowest_cycle) THEN
                            p_cycle_object := p_selected_objects;
                          /change_cycle_object/
                            WHILE p_cycle_object <> NIL DO
                              pup$compare_item_descriptor (p_cycle_object^.entry,
                                    p_cycle_object^.p_catalog_header^, p_cycle_entries^ [cycle_index],
                                    p_item_description^.catalog_header, local_entry_found,
                                    local_requested_subset_found);
                              IF (local_entry_found OR local_requested_subset_found) AND
                                    (p_cycle_object^.entry.entry_type = puc$valid_cycle_entry) THEN
                                p_cycle_object^.entry.pf_selector.cycle_selector :=
                                      p_selected_cycles ^[cycle_index].selected_cycle.cycle_selector;
                                p_cycle_object^.selected_cycle_info.selected_cycle.cycle_selector :=
                                      p_selected_cycles ^[cycle_index].selected_cycle.cycle_selector;
                                EXIT /change_cycle_object/;
                              IFEND;
                              p_cycle_object := p_cycle_object^.link;
                            WHILEND /change_cycle_object/;
                          IFEND;
                        FOREND;
                      IFEND;
                    ELSEIF p_current_object^.entry.entry_type = puc$valid_cycle_entry THEN
                      all_objects_restored := TRUE;
                      p_search_object := p_selected_objects;
                    /check_selected_objects/
                      WHILE p_search_object <> NIL DO
                        all_objects_restored := (all_objects_restored AND p_search_object^.object_restored);
                        IF NOT all_objects_restored THEN
                          EXIT /check_selected_objects/;
                        IFEND;
                        p_search_object := p_search_object^.link;
                      WHILEND /check_selected_objects/;
                      IF all_objects_restored THEN
                        FREE p_item_description;
                        RETURN;
                      IFEND;
                    IFEND;
                  IFEND;
                IFEND;
              ELSEIF all_objects_restored THEN
                FREE p_item_description;
                RETURN;
              IFEND;
            IFEND;
            FREE p_item_description;
          ELSE
            osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_item_requested, ' identifer',
                  status);
          IFEND;
        IFEND;

        pup$write_os_status (status, status);
        IF file_position = puc$mid_partition THEN
          pup$skip_logical_partition (backup_file_id, file_position, status);
        IFEND;
      IFEND;
    UNTIL NOT status.normal OR (file_position = puc$eoi);

    p_current_object := p_selected_objects;

  /locate_unprocessed_objects/
    WHILE p_current_object <> NIL DO
      IF NOT p_current_object^.object_restored THEN
        pup$set_object_abnormal(p_current_object, pue$object_not_restored, local_status);
        pup$write_os_status (local_status, local_status);
      IFEND;
      p_current_object := p_current_object^.link;
    WHILEND /locate_unprocessed_objects/;

  PROCEND pup$restore_selected_objects;

?? TITLE := '    [XDCL] pup$restore_sub_levels ', EJECT ??
*copyc puh$restore_sub_levels

  PROCEDURE [XDCL] pup$restore_sub_levels
   (    entry: put$entry;
        catalog_header: put$catalog_header;
        password_specified: boolean;
        password: pft$password;
        new_catalog_header: put$catalog_header;
        restore_n_levels: boolean;
        p_selected_cycles: ^array [1 .. *] of put$selected_cycle_info;
    VAR backup_file_id: put$file_identifier;
    VAR status: ost$status);

    VAR
      any_entry_found: boolean,
      cycle_entry: put$entry,
      entry_found: boolean,
      file_position: put$file_position,
      found_entry: put$entry,
      high_or_low_cycle_number: integer,
      local_status: ost$status,
      p_item_description: ^put$backup_item_descriptor,
      record_header: put$backup_file_record_header,
      requested_subset_found: boolean,
      stored_backup_file_version: put$backup_file_version_name;

    entry_found := FALSE;
    any_entry_found := FALSE;

  /loop_through_partitions/
    REPEAT
      pup$locate_valid_version (backup_file_id, stored_backup_file_version, file_position, status);
      IF status.normal AND (file_position <> puc$eoi) THEN
        pup$get_next_record_header (backup_file_id, record_header, file_position, status);
        IF status.normal THEN
          IF (record_header.kind = puc$backup_item_identifier) AND (record_header.size >= 1) THEN
            ALLOCATE p_item_description: [1 .. record_header.size];
            pup$get_item_descriptor (backup_file_id, p_item_description^, file_position, status);
            IF status.normal THEN
              found_entry := p_item_description^.pf_utility_entry;
              pup$compare_item_descriptor (entry, catalog_header, found_entry, p_item_description^.
                    catalog_header, entry_found, requested_subset_found);
              IF requested_subset_found OR (entry_found AND restore_n_levels) THEN
                any_entry_found := (p_selected_cycles = NIL) OR
                      ((p_selected_cycles <> NIL) AND
                      (NOT p_selected_cycles^ [1].selected_cycle.cycle_specified) AND
                      (NOT p_selected_cycles^ [1].new_selected_cycle.cycle_specified));
                IF NOT entry_found AND NOT restore_n_levels AND
                      (found_entry.entry_type = puc$valid_pf_entry) AND
                      (UPPERBOUND (p_item_description^.catalog_header.path) = 3) THEN
                  pup$write_sub_path (p_item_description^.catalog_header.path,
                        LOWERBOUND (p_item_description^.catalog_header.path),
                        UPPERBOUND (p_item_description^.catalog_header.path) - 1, status);
                IFEND;
                restore_found_entry (catalog_header, password_specified, password,
                      p_item_description^.catalog_header, found_entry, new_catalog_header, found_entry,
                      p_selected_cycles, backup_file_id, file_position, local_status);
                IF local_status.normal AND (p_selected_cycles <> NIL) AND
                      (found_entry.entry_type = puc$valid_cycle_entry) AND
                      (p_selected_cycles^ [1].selected_cycle.cycle_selector.cycle_number =
                      found_entry.pf_selector.cycle_selector.cycle_number) THEN
                  any_entry_found := TRUE;
                  FREE p_item_description;
                  EXIT /loop_through_partitions/;
                IFEND;
              IFEND;
            IFEND;
            FREE p_item_description;
          ELSE
            osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_item_requested, ' identifer', status);
          IFEND;
        IFEND;
        pup$write_os_status (status, status);
        IF file_position = puc$mid_partition THEN
          pup$skip_logical_partition (backup_file_id, file_position, status);
        IFEND;
      IFEND;
    UNTIL NOT status.normal OR (file_position = puc$eoi);
    IF status.normal AND (NOT any_entry_found) THEN
      IF (p_selected_cycles <> NIL) AND ((p_selected_cycles^ [1].selected_cycle.cycle_specified) OR
            (p_selected_cycles^ [1].new_selected_cycle.cycle_specified)) THEN
        cycle_entry.entry_type := puc$valid_cycle_entry;
        cycle_entry.pf_selector.pfn := entry.pfn;
        cycle_entry.pf_selector.cycle_selector :=
              p_selected_cycles^ [1].selected_cycle.cycle_selector;
        pup$set_abnormal_entry_status (cycle_entry, pue$no_restore_no_find, status);
      ELSE
        pup$set_abnormal_entry_status (entry, pue$no_restore_no_find, status);
      IFEND;
    IFEND;
  PROCEND pup$restore_sub_levels;

?? TITLE := '    check_included_volumes ', EJECT ??

  PROCEDURE check_included_volumes
   (    file_reference: fst$path;
    VAR cycle_included: boolean;
    VAR status: ost$status);

    VAR
      catalog_depth: fst$catalog_depth,
      include_index: ost$positive_integers,
      information_request: fst$goi_information_request,
      object_info: ^fst$goi_object_information,
      object_info_sequence: ^SEQ (*),
      object_info_sequence_size: ost$positive_integers,
      p_volume_list: ^rmt$volume_list,
      volume_index: ost$positive_integers;

    IF puv$p_included_volumes = NIL THEN
      cycle_included := TRUE;
      RETURN;
    ELSE
      cycle_included := FALSE;
    IFEND;

    information_request.catalog_depth.depth_specification := fsc$specific_depth;
    information_request.catalog_depth.depth := 1;
    information_request.object_information_requests := $fst$goi_object_info_requests
          [fsc$goi_cycle_device_info];
    object_info_sequence_size := #SIZE (fst$goi_object_information) + fsc$max_path_size +
          #SIZE (fst$goi_object) + #SIZE (fst$device_information);
    PUSH object_info_sequence: [[REP object_info_sequence_size OF cell]];
    pfp$get_object_information (file_reference, information_request, {p_validation_criteria} NIL,
          object_info_sequence, status);
    IF status.normal THEN
      RESET object_info_sequence;
      NEXT object_info IN object_info_sequence;
      IF object_info^.object^.cycle_device_information^.mass_storage_device_info.resides_online THEN
        p_volume_list := object_info^.object^.cycle_device_information^.mass_storage_device_info.volume_list;
        IF p_volume_list <> NIL THEN
          FOR volume_index := LOWERBOUND (p_volume_list^) TO UPPERBOUND (p_volume_list^) DO
            FOR include_index := LOWERBOUND (puv$p_included_volumes^) TO
                  UPPERBOUND (puv$p_included_volumes^) DO
              IF p_volume_list^ [volume_index].recorded_vsn = puv$p_included_volumes^ [include_index] THEN
                cycle_included := TRUE;
                RETURN;
              IFEND;
            FOREND;
          FOREND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND check_included_volumes;

?? TITLE := '    put_cycle_list_from_file_info ', EJECT ??

  PROCEDURE put_cycle_list_from_file_info
   (    file_info: pft$p_info_record;
        file_path: pft$path;
        password_selector: pft$password_selector;
        restore_archive_information: boolean;
        p_selected_cycles: ^array [1 .. *] of put$selected_cycle_info;
    VAR number_of_cycles_put: integer);

    VAR
      archive_identification: pft$archive_identification,
      archive_modification_date_time: ost$date_time,
      backup_file_cycle_selector: pft$cycle_selector,
      catalog_cycle_selector: pft$cycle_selector,
      comparison_result: pmt$comparison_result,
      cycle_array_entry: pft$cycle_array_entry_version_2,
      cycle_damage_symptoms: fst$cycle_damage_symptoms,
      cycle_included: boolean,
      cycle_index: integer,
      file_reference: fst$path,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      high_index: integer,
      highest_cycle_number: pft$cycle_number,
      i: integer,
      ignore_status: ost$status,
      local_status: ost$status,
      low_index: integer,
      lowest_cycle_number: pft$cycle_number,
      modification_date_time_found: boolean,
      new_access_date_time: fst$date_time,
      new_modification_date_time: fst$date_time,
      p_archive_entry: pft$p_archive_array_entry,
      p_archive_group: pft$p_info_record,
      p_archive_info: pft$p_info_record,
      p_archive_list_body: pft$p_info,
      p_archive_media: pft$p_amd,
      p_cycle_info_record: pft$p_info_record,
      p_cycle_list_version_1: pft$p_cycle_array,
      p_cycle_list_version_2: ^pft$cycle_array_version_2,
      p_cycle_media_description: pft$p_file_media_description,
      restored_file_cycle_selector: pft$cycle_selector;

    number_of_cycles_put := 0;
    IF p_selected_cycles = NIL THEN
     RETURN;
    IFEND;

    pfp$find_cycle_array_extended (file_info, p_cycle_array_extended_record, local_status);
    IF local_status.normal THEN
      pfp$find_cycle_directory (p_cycle_array_extended_record, p_cycle_directory_array, local_status);
      IF local_status.normal THEN
        IF puv$respf_backup_file_version = puc$backup_file_version_1 THEN
          pfp$find_cycle_array (file_info, p_cycle_list_version_1, local_status);
        ELSEIF puv$respf_backup_file_version = puc$backup_file_version_2 THEN
          pfp$find_cycle_array_version_2 (file_info, p_cycle_list_version_2, local_status);
        IFEND;
        IF local_status.normal AND (((puv$respf_backup_file_version = puc$backup_file_version_1) AND
              (p_cycle_list_version_1 <> NIL)) OR
              ((puv$respf_backup_file_version = puc$backup_file_version_2) AND
              (p_cycle_list_version_2 <> NIL))) THEN
          IF puv$respf_backup_file_version = puc$backup_file_version_1 THEN
            low_index := LOWERBOUND (p_cycle_list_version_1^);
            high_index := UPPERBOUND (p_cycle_list_version_1^);
          ELSEIF puv$respf_backup_file_version = puc$backup_file_version_2 THEN
            low_index := LOWERBOUND (p_cycle_list_version_2^);
            high_index := UPPERBOUND (p_cycle_list_version_2^);
          IFEND;

          IF puv$respf_backup_file_version = puc$backup_file_version_1 THEN
            lowest_cycle_number := p_cycle_list_version_1^ [low_index].cycle_number;
            highest_cycle_number := p_cycle_list_version_1^ [low_index].cycle_number;
          ELSEIF puv$respf_backup_file_version = puc$backup_file_version_2 THEN
            lowest_cycle_number := p_cycle_list_version_2^ [low_index].cycle_number;
            highest_cycle_number := p_cycle_list_version_2^ [low_index].cycle_number;
          IFEND;

          FOR i := low_index TO high_index DO
            IF puv$respf_backup_file_version = puc$backup_file_version_1 THEN
              IF p_cycle_list_version_1^ [i].cycle_number > highest_cycle_number THEN
                highest_cycle_number := p_cycle_list_version_1^ [i].cycle_number;
              IFEND;
              IF p_cycle_list_version_1^ [i].cycle_number < lowest_cycle_number THEN
                lowest_cycle_number := p_cycle_list_version_1^ [i].cycle_number;
              IFEND;
            ELSEIF puv$respf_backup_file_version = puc$backup_file_version_2 THEN
              IF p_cycle_list_version_2^ [i].cycle_number > highest_cycle_number THEN
                highest_cycle_number := p_cycle_list_version_2^ [i].cycle_number;
              IFEND;
              IF p_cycle_list_version_2^ [i].cycle_number < lowest_cycle_number THEN
                lowest_cycle_number := p_cycle_list_version_2^ [i].cycle_number;
              IFEND;
            IFEND;
          FOREND;

        /selected_cycles_loop/
          FOR cycle_index := 1 TO UPPERBOUND (p_selected_cycles^) DO
            backup_file_cycle_selector.cycle_option := pfc$specific_cycle;
            IF p_selected_cycles^ [cycle_index].selected_cycle.cycle_specified THEN
              IF p_selected_cycles^ [cycle_index].selected_cycle.cycle_selector.cycle_option =
                    pfc$specific_cycle THEN
                backup_file_cycle_selector.cycle_number :=
                      p_selected_cycles^ [cycle_index].selected_cycle.cycle_selector.cycle_number;
              ELSEIF p_selected_cycles^ [cycle_index].selected_cycle.cycle_selector.cycle_option =
                    pfc$lowest_cycle THEN
                backup_file_cycle_selector.cycle_number := lowest_cycle_number;
              ELSEIF p_selected_cycles^ [cycle_index].selected_cycle.cycle_selector.cycle_option =
                    pfc$highest_cycle THEN
                backup_file_cycle_selector.cycle_number := highest_cycle_number;
              IFEND;
              p_selected_cycles^ [cycle_index].selected_cycle.cycle_selector :=
                    backup_file_cycle_selector;
            IFEND;

          /specific_cycle_loop/
            FOR i := low_index TO high_index DO
              IF p_selected_cycles^ [cycle_index].selected_cycle.cycle_specified OR
                    p_selected_cycles^ [cycle_index].new_selected_cycle.cycle_specified THEN
                IF ((puv$respf_backup_file_version = puc$backup_file_version_1) AND
                      (backup_file_cycle_selector.cycle_number <> p_cycle_list_version_1^ [i].cycle_number))
                      THEN
                  CYCLE /specific_cycle_loop/;
                ELSEIF ((puv$respf_backup_file_version = puc$backup_file_version_2) AND
                      (backup_file_cycle_selector.cycle_number <> p_cycle_list_version_2^ [i].cycle_number))
                      THEN
                  CYCLE /specific_cycle_loop/;
                IFEND;
              ELSE
                IF puv$respf_backup_file_version = puc$backup_file_version_1 THEN
                  backup_file_cycle_selector.cycle_number := p_cycle_list_version_1^ [i].cycle_number;
                ELSEIF puv$respf_backup_file_version = puc$backup_file_version_2 THEN
                  backup_file_cycle_selector.cycle_number := p_cycle_list_version_2^ [i].cycle_number;
                IFEND;
              IFEND;

              pup$find_cycle_info_record (p_cycle_array_extended_record, p_cycle_directory_array,
                    backup_file_cycle_selector.cycle_number, ^file_path, p_cycle_info_record, local_status);
              IF local_status.normal THEN
                pfp$find_cycle_media (p_cycle_info_record, p_cycle_media_description, local_status);
                IF (NOT local_status.normal) AND (local_status.condition = pfe$unknown_cycle_media) THEN
                  local_status.normal := TRUE;
                  IF NOT restore_archive_information THEN
                    {
                    {  Do not write the cycle array entry if neither archive information nor data are to
                    {  be restored.
                    {
                    CYCLE /specific_cycle_loop/;
                  IFEND;
                IFEND;
              IFEND;
              IF NOT local_status.normal THEN
                pup$write_os_status (local_status, local_status);
                RETURN;
              IFEND;
              IF puv$respf_backup_file_version = puc$backup_file_version_1 THEN
                cycle_array_entry.bytes_allocated := 0;
                cycle_array_entry.cycle_damage_symptoms := $fst$cycle_damage_symptoms [];
                IF p_selected_cycles^ [cycle_index].new_selected_cycle.cycle_specified THEN
                  cycle_array_entry.cycle_number :=
                        p_selected_cycles^ [cycle_index].new_selected_cycle.cycle_selector.cycle_number;
                ELSE
                  cycle_array_entry.cycle_number := p_cycle_list_version_1^ [i].cycle_number;
                IFEND;
                cycle_array_entry.cycle_statistics := p_cycle_list_version_1^ [i].cycle_statistics;
                cycle_array_entry.data_modification_date_time :=
                      p_cycle_list_version_1^ [i].cycle_statistics.modification_date_time;
                cycle_array_entry.data_residence := pfc$unreleasable_data;
                cycle_array_entry.device_class := rmc$mass_storage_device;
                cycle_array_entry.eoi := 0;
                cycle_array_entry.expiration_date_time :=p_cycle_list_version_1^ [i].expiration_date_time;
                cycle_array_entry.original_unique_name := puv$null_original_unique_name;
                cycle_array_entry.retrieve_option := pfc$always_retrieve;
                cycle_array_entry.shared_queue_info.defined := FALSE;
                cycle_array_entry.site_archive_option := pfc$null_site_archive_option;
                cycle_array_entry.site_backup_option := pfc$null_site_backup_option;
                cycle_array_entry.site_release_option := pfc$null_site_release_option;
                cycle_array_entry.sparse_allocation := FALSE;
                cycle_array_entry.reserved_cycle_array_entry_sp := puv$null_res_cycle_array_ent_sp;
              ELSEIF puv$respf_backup_file_version = puc$backup_file_version_2 THEN
                cycle_array_entry := p_cycle_list_version_2^ [i];
                IF p_selected_cycles^ [cycle_index].new_selected_cycle.cycle_specified THEN
                  cycle_array_entry.cycle_number :=
                        p_selected_cycles^ [cycle_index].new_selected_cycle.cycle_selector.cycle_number;
                  cycle_array_entry.retrieve_option := pfc$always_retrieve;
                  cycle_array_entry.site_archive_option := pfc$null_site_archive_option;
                  cycle_array_entry.site_backup_option := pfc$null_site_backup_option;
                  cycle_array_entry.site_release_option := pfc$null_site_release_option;
                IFEND;
              IFEND;
              catalog_cycle_selector.cycle_option := pfc$specific_cycle;
              catalog_cycle_selector.cycle_number := cycle_array_entry.cycle_number;
              pup$check_cycle_access (cycle_array_entry, cycle_included);
              IF cycle_included THEN
                IF (puv$mass_storage_info.shared_queue <> pfc$null_shared_queue) AND
                      (cycle_array_entry.device_class = rmc$mass_storage_device) THEN
                  cycle_array_entry.shared_queue_info.defined := TRUE;
                  cycle_array_entry.shared_queue_info.shared_queue := puv$mass_storage_info.shared_queue;
                IFEND;
                IF NOT puv$create_objects THEN
                  pup$validate_n_n_minus_1 (file_path, puc$valid_cycle_entry, catalog_cycle_selector,
                        local_status);
                  IF (local_status.normal) OR ((NOT local_status.normal) AND
                        (local_status.condition = pue$restore_cycle_requires_file)) THEN
                    local_status.normal := TRUE;
                    CYCLE /specific_cycle_loop/
                  IFEND;
                IFEND;

                pfp$put_cycle_info (file_path, catalog_cycle_selector, password_selector, cycle_array_entry,
                      local_status);
                IF local_status.normal THEN
                  IF restore_archive_information THEN
                    pfp$put_archive_info (file_path, catalog_cycle_selector, p_cycle_info_record,
                          local_status);
                  IFEND;
                ELSEIF puv$replace_cycle_data AND ((local_status.condition = pfe$duplicate_cycle) OR
                      (local_status.condition = pfe$duplicate_offline_cycle)) THEN
                    {  If the backup file contains archive info, replace the
                    {  online data with the archive info. Make sure there is
                    {  archive info on the backup file before the online data
                    {  is deleted.
                  pfp$find_archive_info (p_cycle_info_record, p_archive_info, local_status);
                  IF local_status.normal AND restore_archive_information THEN
                    fsp$build_file_ref_from_elems (^file_path, file_reference, local_status);
                    IF local_status.normal THEN
                      check_included_volumes (file_reference, cycle_included, local_status);
                      IF local_status.normal AND cycle_included THEN
                        puv$purge_cycle_options.preserve_cycle_entry := puv$replace_cycle_data;
                        IF puv$purge_cycle_options.preserve_cycle_entry THEN
                          puv$purge_cycle_options.preserve_archive_info := FALSE;
                          puv$purge_cycle_options.preserve_file_label := FALSE;
                          puv$purge_cycle_options.preserve_modification_date_time := FALSE;
                        IFEND;
                        pfp$delete_cycle_data (file_path, catalog_cycle_selector, {password} osc$null_name,
                              puv$purge_cycle_options, local_status);
                        pfp$put_archive_info (file_path, catalog_cycle_selector, p_cycle_info_record,
                              local_status);
                        IF local_status.normal THEN
                          modification_date_time_found := FALSE;
                          archive_identification.application_identifier := osc$null_name;
                          archive_identification.media_identifier.media_device_class := osc$null_name;
                          archive_identification.media_identifier.media_volume_identifier := '';
                          p_archive_list_body := ^p_archive_info^.body;
                          REPEAT
                            pfp$find_next_archive_entry (archive_identification, p_archive_list_body,
                                  p_archive_group, p_archive_entry, p_archive_media, local_status);
                            IF local_status.normal THEN
                              IF modification_date_time_found THEN
                                pmp$date_time_compare (p_archive_entry^.archive_date_time,
                                       archive_modification_date_time, comparison_result, local_status);
                                IF comparison_result = pmc$left_is_greater THEN
                                  archive_modification_date_time :=
                                        p_archive_entry^.modification_date_time;
                                IFEND;
                              ELSE
                                modification_date_time_found := TRUE;
                                archive_modification_date_time := p_archive_entry^.modification_date_time;
                              IFEND;
                            IFEND;
                          UNTIL (p_archive_list_body = NIL) OR NOT local_status.normal;

                          IF modification_date_time_found THEN
                            new_access_date_time.value_specified := FALSE;
                            new_modification_date_time.value_specified := TRUE;
                            new_modification_date_time.date_time := archive_modification_date_time;
                            fsp$build_file_ref_from_elems (^file_path, file_reference, local_status);
                            fsp$change_cycle_date_time (file_reference, {password} osc$null_name,
                                      ^new_access_date_time, ^new_modification_date_time, local_status);
                          IFEND;
                        IFEND;
                      IFEND;
                    IFEND;
                  IFEND;
                IFEND;
                IF local_status.normal THEN
                  number_of_cycles_put := number_of_cycles_put + 1;
                ELSEIF (local_status.condition <> pfe$duplicate_cycle) AND
                      (local_status.condition <> pfe$duplicate_offline_cycle) THEN
                  RETURN;
                IFEND;
              IFEND;
            FOREND /specific_cycle_loop/;
          FOREND /selected_cycles_loop/;
        IFEND;
      ELSE
        p_cycle_array_extended_record := NIL;
      IFEND;
    ELSE
      p_cycle_array_extended_record := NIL;
    IFEND;
    IF (NOT local_status.normal) AND (local_status.condition <> pfe$duplicate_cycle) AND
          (local_status.condition <> pfe$duplicate_offline_cycle) THEN
      pup$write_os_status (local_status, local_status);
    IFEND;
  PROCEND put_cycle_list_from_file_info;

?? TITLE := '  restore_file_info', EJECT ??

  PROCEDURE restore_file_info
    (    new_online_cat_header: put$catalog_header;
         password_specified: boolean;
         password: pft$password;
         p_selected_cycles: {i/o} ^array [1 .. *] of put$selected_cycle_info;
     VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    VAR
      all_permits_restored: boolean,
      backup_file_version: pft$backup_file_version,
      cycle_index: integer,
      dummy_cycle_selector: pft$cycle_selector,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      ignore_status: ost$status,
      length: integer,
      listing_string: string (90),
      local_status: ost$status,
      number_of_cycles_put: integer,
      ownership: pft$ownership,
      p_cycle_array: pft$p_cycle_array,
      p_cycle_array_version_2: ^pft$cycle_array_version_2,
      p_file_description: pft$p_file_description,
      p_file_info_record: pft$p_info_record,
      p_local_selected_cycles: ^array [1 .. *] of put$selected_cycle_info,
      password_selector: pft$password_selector,
      put_cycle_list: boolean,
      record_header: put$backup_file_record_header,
      restore_archive_information: boolean,
      transfer_count: amt$file_length,
      variant_path: pft$variant_path;

    display (' entering restore_file_info');
    listing_string := '';
    listing_string (5, * ) := new_online_cat_header.path [UPPERBOUND (new_online_cat_header.path)];
    pup$display_line (listing_string, local_status);

    all_permits_restored := FALSE;
    put_cycle_list := FALSE;
    p_local_selected_cycles := p_selected_cycles;

    pup$get_next_record_header (backup_file_id, record_header, file_position, status);
    IF status.normal THEN
      IF (file_position = puc$mid_partition) AND (record_header.kind = puc$backup_file_info) AND
            (record_header.size > 0) THEN
        PUSH p_file_info_record: [[REP record_header.size OF cell]];
        pup$get_part (backup_file_id, p_file_info_record, #SIZE (p_file_info_record^), file_position,
              transfer_count, status);
      ELSE
        osp$set_status_abnormal (puc$pf_utility_id, pue$unusable_restore_file, ' info ', status);
      IFEND;
    IFEND;

    IF status.normal THEN
      restore_archive_information := puv$restore_archive_information;
      IF avp$family_administrator() AND (NOT avp$system_administrator()) THEN
        variant_path.complete_path := FALSE;
        variant_path.p_path := ^new_online_cat_header.path;
        pfp$get_ownership (variant_path, {system_privilege} TRUE, ownership, status);
        IF NOT status.normal OR (NOT (pfc$family_owner IN ownership)) THEN
          restore_archive_information := FALSE;
          osp$set_status_abnormal (puc$pf_utility_id, pue$archive_info_not_restored,
                'you are not the family administrator', local_status);
          pup$write_os_status (local_status, ignore_status);
        IFEND
      IFEND;

      IF puv$trace_selected THEN
        pup$display_boolean (' puv$restore_archive_information = ', puv$restore_archive_information,
              local_status);
        pup$display_boolean (' restore_archive_information = ', restore_archive_information, local_status);
      IFEND;

      IF (p_selected_cycles = NIL) OR ((p_selected_cycles <> NIL) AND
            (NOT p_selected_cycles^ [1].selected_cycle.cycle_specified) AND
            (NOT p_selected_cycles^ [1].new_selected_cycle.cycle_specified)) THEN
        display (' pfp$put_item_info');

        IF puv$respf_backup_file_version = puc$backup_file_version_1 THEN
          backup_file_version := pfc$backup_file_version_1;
          pfp$find_cycle_array (p_file_info_record, p_cycle_array, status);
          IF NOT status.normal THEN
            p_cycle_array := NIL;
          IFEND;
        ELSEIF puv$respf_backup_file_version = puc$backup_file_version_2 THEN
          backup_file_version := pfc$backup_file_version_2;
          pfp$find_cycle_array_version_2 (p_file_info_record, p_cycle_array_version_2, status);
          IF NOT status.normal THEN
            p_cycle_array_version_2 := NIL;
          IFEND;
        IFEND;

        IF (backup_file_version = pfc$backup_file_version_2) AND (p_cycle_array_version_2 <> NIL) THEN
          FOR cycle_index := LOWERBOUND (p_cycle_array_version_2^) TO
                UPPERBOUND (p_cycle_array_version_2^) DO
            IF (puv$mass_storage_info.shared_queue <> pfc$null_shared_queue) AND
                  (p_cycle_array_version_2^ [cycle_index].device_class = rmc$mass_storage_device) THEN
              p_cycle_array_version_2^ [cycle_index].shared_queue_info.defined := TRUE;
              p_cycle_array_version_2^ [cycle_index].shared_queue_info.shared_queue :=
                    puv$mass_storage_info.shared_queue;
            IFEND;
          FOREND;
        IFEND;

        IF NOT puv$create_objects THEN
          pup$validate_n_n_minus_1 (new_online_cat_header.path, puc$valid_pf_entry, dummy_cycle_selector,
                local_status);
          IF local_status.normal THEN
            pup$display_line (
                  'File cannot be created when FALSE is specified for the CREATE_OBJECTS parameter',
                  ignore_status);
            RETURN;
          IFEND;
        IFEND;

        pfp$put_item_info (new_online_cat_header.path, p_file_info_record, restore_archive_information,
              puv$backup_criteria, backup_file_version, all_permits_restored, status);
        IF puv$trace_selected THEN
          display_status (status);
        IFEND;
        IF (NOT status.normal) AND (status.condition = pfe$name_already_permanent_file) THEN

{       If the file exists and there are some cycles without data, (i.e OFFLINE)
{       construct the p_selected_cycles array to restore the cycle_entries.

          status.normal := TRUE;
          IF backup_file_version = pfc$backup_file_version_1 THEN
            IF p_cycle_array <> NIL THEN
              PUSH p_local_selected_cycles: [1 .. UPPERBOUND (p_cycle_array^)];
              FOR cycle_index := LOWERBOUND (p_cycle_array^) TO
                    UPPERBOUND (p_cycle_array^) DO
                p_local_selected_cycles^ [cycle_index].selected_cycle.cycle_specified := TRUE;
                p_local_selected_cycles^ [cycle_index].selected_cycle.cycle_selector.cycle_option :=
                      pfc$specific_cycle;
                p_local_selected_cycles^ [cycle_index].selected_cycle.cycle_selector.cycle_number :=
                      p_cycle_array^ [cycle_index].cycle_number;
              FOREND;
              put_cycle_list := TRUE;
            IFEND;
          ELSEIF  backup_file_version = pfc$backup_file_version_2 THEN
            IF p_cycle_array_version_2 <> NIL THEN
              PUSH p_local_selected_cycles: [1 .. UPPERBOUND (p_cycle_array_version_2^)];
              FOR cycle_index := LOWERBOUND (p_cycle_array_version_2^) TO
                    UPPERBOUND (p_cycle_array_version_2^) DO
                p_local_selected_cycles^ [cycle_index].selected_cycle.cycle_specified := TRUE;
                p_local_selected_cycles^ [cycle_index].selected_cycle.cycle_selector.cycle_option :=
                      pfc$specific_cycle;
                p_local_selected_cycles^ [cycle_index].selected_cycle.cycle_selector.cycle_number :=
                      p_cycle_array_version_2^ [cycle_index].cycle_number;
              FOREND;
              put_cycle_list := TRUE;
            IFEND;
          IFEND;
        IFEND;
        IF NOT all_permits_restored THEN
          osp$set_status_abnormal (puc$pf_utility_id, pue$not_all_permits_restored, 'file', local_status);
          pup$write_os_status (local_status, ignore_status);
        IFEND;
      ELSE
        put_cycle_list := TRUE;
      IFEND;
    IFEND;

    IF status.normal THEN
      IF puc$cdo_alternate_storage IN puv$cycle_display_selections THEN
        pfp$find_cycle_array_extended (p_file_info_record, p_cycle_array_extended_record, status);
        IF status.normal THEN
          pfp$find_cycle_directory (p_cycle_array_extended_record, p_cycle_directory_array, status);
        IFEND;
        IF NOT status.normal THEN
          p_cycle_array_extended_record := NIL;
          pup$write_os_status (status, local_status);
          status.normal := TRUE;
        IFEND;
      IFEND;
    IFEND;

    IF put_cycle_list THEN
      IF password_specified THEN
        password_selector.password_specified := pfc$specific_password_option;
        password_selector.password := password;
      ELSE
        pfp$find_file_description (p_file_info_record, p_file_description, local_status);
        IF local_status.normal THEN
          password_selector.password_specified := pfc$specific_password_option;
          password_selector.password := p_file_description^.password;
        ELSE
          password_selector.password_specified := pfc$default_password_option;
        IFEND;
      IFEND;
      put_cycle_list_from_file_info (p_file_info_record, new_online_cat_header.path, password_selector,
            restore_archive_information, p_local_selected_cycles, number_of_cycles_put);
      IF ((p_selected_cycles = NIL) OR ((p_selected_cycles <> NIL) AND
            (NOT p_selected_cycles^ [1].selected_cycle.cycle_specified) AND
            (NOT p_selected_cycles^ [1].new_selected_cycle.cycle_specified))) AND
            (number_of_cycles_put > 0) THEN
        STRINGREP (listing_string, length, '    -- FILE ALREADY EXISTS: ', number_of_cycles_put,
              '  CYCLE ENTRIES RESTORED');
        pup$display_line (listing_string (1, length), local_status);
      IFEND;
    IFEND;

    IF (NOT puv$replace_cycle_data) OR ((NOT status.normal) AND
          (status.condition <> pfe$duplicate_cycle)) THEN
      pup$write_os_status (status, local_status);
    IFEND;
    display (' leaving restore_file_info');

  PROCEND restore_file_info;

?? TITLE := '    restore_found_entry ', EJECT ??

  PROCEDURE restore_found_entry
   (    catalog_header: put$catalog_header;
        password_specified: boolean;
        password: pft$password;
        found_catalog_header: put$catalog_header;
        found_entry: put$entry;
        new_catalog_header: put$catalog_header;
        new_entry: put$entry;
        p_selected_cycles: {i/o} ^array [1 .. *] of put$selected_cycle_info;
    VAR backup_file_id: put$file_identifier;
    VAR file_position: put$file_position;
    VAR status: ost$status);

{  The purpose of this routine is to "process" a found entry.  This includes:
{  build a new online path
{     restore the item (PF will return bad status if item exists)

    VAR
      cycle_selector: pft$cycle_selector,
      ignore_status: ost$status,
      item_type: put$entry_type,
      listing_string: string (90),
      local_status: ost$status,
      new_online_path_length: integer,
      p_new_online_catalog_header: ^put$catalog_header,
      password_selector: pft$password_selector;

    new_online_path_length := pup$physical_path_length (new_catalog_header.logical_path_length +
          found_catalog_header.logical_path_length - catalog_header.logical_path_length);
    PUSH p_new_online_catalog_header: [1 .. new_online_path_length];
    pup$build_new_online_cat_head (catalog_header, new_catalog_header, found_catalog_header,
          p_new_online_catalog_header^);

    CASE found_entry.entry_type OF
    = puc$valid_set_entry =
    = puc$valid_family_entry =
      IF puv$create_objects THEN
        pup$restore_catalog_info (p_new_online_catalog_header^, backup_file_id, file_position, status);
      ELSE
        pup$write_path (p_new_online_catalog_header^.path, ignore_status);
        pup$display_line ('Family cannot be created when FALSE is specified for the CREATE_OBJECTS parameter',
              ignore_status);
        pup$display_blank_lines (1, ignore_status);
      IFEND;
    = puc$valid_catalog_entry =
      IF puv$create_objects THEN
        pup$restore_catalog_info (p_new_online_catalog_header^, backup_file_id, file_position, status);
      ELSE
        pup$write_path (p_new_online_catalog_header^.path, ignore_status);
        pup$verify_catalog_path (p_new_online_catalog_header^.path, local_status);
        IF local_status.normal THEN
          pup$display_line ('    -- CATALOG ALREADY EXISTS', ignore_status);
        ELSE
          pup$display_line (
                'Catalog cannot be created when FALSE is specified for the CREATE_OBJECTS parameter',
                ignore_status);
          pup$display_blank_lines (1, ignore_status);
        IFEND;
      IFEND;
    = puc$valid_pf_entry =
      puv$purge_cycle_options.preserve_cycle_entry := puv$replace_cycle_data;
      IF puv$purge_cycle_options.preserve_cycle_entry THEN
        puv$purge_cycle_options.preserve_archive_info := FALSE;
        puv$purge_cycle_options.preserve_file_label := FALSE;
        puv$purge_cycle_options.preserve_modification_date_time := FALSE;
      IFEND;
      restore_file_info (p_new_online_catalog_header^, password_specified, password, p_selected_cycles,
              backup_file_id, file_position, status);
    = puc$valid_cycle_entry =
      IF password_specified THEN
        password_selector.password_specified := pfc$specific_password_option;
        password_selector.password := password;
      ELSE
        password_selector.password_specified := pfc$default_password_option;
      IFEND;

      puv$purge_cycle_options.preserve_cycle_entry := puv$replace_cycle_data;
      IF puv$purge_cycle_options.preserve_cycle_entry THEN
        puv$purge_cycle_options.preserve_archive_info := TRUE;
        puv$purge_cycle_options.preserve_file_label := TRUE;
        puv$purge_cycle_options.preserve_modification_date_time := TRUE;
      IFEND;

      cycle_selector.cycle_option := pfc$specific_cycle;
      IF (p_selected_cycles = NIL) OR ((p_selected_cycles <> NIL) AND
            (NOT p_selected_cycles^ [1].selected_cycle.cycle_specified) AND
            (NOT p_selected_cycles^ [1].new_selected_cycle.cycle_specified)) THEN
        cycle_selector.cycle_number := new_entry.pf_selector.cycle_selector.cycle_number;
        pup$restore_cycle_item (found_entry, p_new_online_catalog_header^.path, cycle_selector,
              password_selector, p_cycle_array_extended_record, p_cycle_directory_array, backup_file_id,
              file_position, status);
      ELSE
        IF p_selected_cycles^ [1].selected_cycle.cycle_selector.cycle_number =
              found_entry.pf_selector.cycle_selector.cycle_number THEN
          IF p_selected_cycles^ [1].new_selected_cycle.cycle_specified THEN
            cycle_selector.cycle_number :=
                  p_selected_cycles^ [1].new_selected_cycle.cycle_selector.cycle_number;
          ELSE
            cycle_selector.cycle_number :=
                  p_selected_cycles^ [1].selected_cycle.cycle_selector.cycle_number;
          IFEND;
          pup$restore_cycle_item (found_entry, p_new_online_catalog_header^.path, cycle_selector,
                password_selector, p_cycle_array_extended_record, p_cycle_directory_array, backup_file_id,
                file_position, status);
        IFEND;
      IFEND;
    ELSE
      osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_item_requested, ' entry ', status);
      pup$write_os_status (status, local_status);
    CASEND;
  PROCEND restore_found_entry;

?? TITLE := '    validate_version_number ', EJECT ??

  PROCEDURE validate_version_number
   (    stored_backup_file_version_name: put$backup_file_version_name;
        backup_file_id: put$file_identifier;
    VAR status: ost$status);

    CONST
      number_of_supported_versions = 2,
      supported_version_str_len = 23,
      supported_versions_str_len = (number_of_supported_versions * supported_version_str_len) +
            ((number_of_supported_versions - 1) * 2);

    VAR
      backup_file_path: fst$path,
      backup_file_path_size: fst$path_size,
      ignore_path_handle: fmt$path_handle,
      local_status: ost$status,
      p_supported_version_names: ^array [1 .. number_of_supported_versions] of
            string (supported_version_str_len),
      p_supported_versions_str: ^string (supported_versions_str_len),
      supported_versions_str_len_var: integer;

    status.normal := TRUE;
    IF (stored_backup_file_version_name = puc$backup_file_version_1) OR
          (stored_backup_file_version_name = puc$backup_file_version_2) THEN
      puv$respf_backup_file_version := stored_backup_file_version_name;
    ELSE
      IF (stored_backup_file_version_name (1,20) = 'BACKUP_FILE_VERSION_') AND
         ('3' <= stored_backup_file_version_name (supported_version_str_len)) AND
            (stored_backup_file_version_name (supported_version_str_len) <= '9') THEN
        clp$get_fs_path_string (backup_file_id.lfn, backup_file_path, backup_file_path_size,
              ignore_path_handle, local_status);
        osp$set_status_abnormal (puc$pf_utility_id, pue$incompatible_backup_version,
              backup_file_path (1, backup_file_path_size), status);
        PUSH p_supported_version_names;
        p_supported_version_names^ [1] := puc$backup_file_version_1;
        p_supported_version_names^ [2] := puc$backup_file_version_2;
        PUSH p_supported_versions_str;
        STRINGREP (p_supported_versions_str^, supported_versions_str_len_var, p_supported_version_names^ [1],
              ', ', p_supported_version_names^ [2]);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              p_supported_versions_str^ (1, supported_versions_str_len), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, stored_backup_file_version_name,
              status);
      ELSE
        osp$set_status_abnormal (puc$pf_utility_id, pue$unable_to_read_version,
              stored_backup_file_version_name, status);
      IFEND;
    IFEND;
  PROCEND validate_version_number;

?? OLDTITLE, SKIP := 2 ??
MODEND pum$backup_file_input;
*DECK DECK=PUM$BACKUP_FILE_OUTPUT EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  backup_file_output ', EJECT ??
MODULE pum$backup_file_output;
{PURPOSE:
{     This module contains procedures required to produce the
{  physical BACKUP copies.

?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amp$close
*copyc amp$get_file_attributes
*copyc mmp$close_segment
*copyc osp$append_status_integer
*copyc osp$set_status_abnormal
*copyc ost$caller_identifier
*copyc pfp$open_file_segment
*copyc pfv$reserved_cycle_info
*copyc pud$backup_file
*copyc pud$hierarchy_list
*copyc pue$error_condition_codes
*copyc pup$advised_put_next
*copyc pup$allow_job_termination
*copyc pup$display_blank_lines
*copyc pup$display_integer
*copyc pup$display_line
*copyc pup$open_file_for_seg_access
*copyc pup$put_next
*copyc pup$put_partial
*copyc pup$write_logical_partition
*copyc pup$write_status_to_listing
*copyc pus$literals
*copyc put$file_identifier
*copyc puv$exclude_catalog_information
*copyc puv$global_backup_file_id
*copyc puv$read_data_on_null_bf
*copyc puv$trace_selected
*copyc puv$bacpf_backup_file_version
*copyc std$set_name
?? POP ??
?? TITLE := '    Global Variables', EJECT ??
?? TITLE := '    [XDCL] pup$abort_output ', EJECT ??

  PROCEDURE [XDCL] pup$abort_output
    (    pf_utility_entry: put$entry;
     VAR pf_backup_file_id: put$file_identifier;
         bad_status: ost$status;
     VAR status: ost$status);

    pup$write_status_to_listing (pf_utility_entry, bad_status, status);
    IF puv$global_backup_file_id.backup_file_open THEN
      pup$write_logical_partition (pf_backup_file_id, status);
    IFEND;
  PROCEND pup$abort_output;

?? TITLE := '    [XDCL] pup$output_catalog ', EJECT ??

  PROCEDURE [XDCL] pup$output_catalog (catalog_entry: put$entry;
        pf_utility_catalog_header: put$catalog_header;
        info: put$backup_item_info;
        pf_utility_hierarchy_list: put$hierarchy_list;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);

    IF (pf_backup_file_id.device_class = rmc$null_device) OR puv$exclude_catalog_information THEN
      pup$allow_job_termination;
      status.normal := TRUE;
      RETURN;
    IFEND;

    output_backup_version_name (pf_backup_file_id, status);
    IF status.normal THEN
      output_backup_item_path (catalog_entry, pf_utility_catalog_header, pf_backup_file_id, status);
      IF status.normal THEN
        output_item_info (catalog_entry, info, pf_backup_file_id, status);
        IF status.normal THEN
          output_hierarchy_list (pf_utility_hierarchy_list, pf_backup_file_id, status);
          IF status.normal THEN
            pup$write_logical_partition (pf_backup_file_id, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pup$output_catalog;

?? TITLE := '    [XDCL] pup$output_cycle ', EJECT ??

  PROCEDURE [XDCL] pup$output_cycle (lfn: amt$local_file_name;
        cycle_entry: put$entry;
        pf_utility_catalog_header: put$catalog_header;
        cycle_info: put$backup_item_info;
        cycle_array_entry: pft$cycle_array_entry_version_2;
        cycle_label_exists: boolean;
        cycle_label: SEQ ( * );
        pf_utility_hierarchy_list: put$hierarchy_list;
        cycle_length: amt$file_length;
        data_exists: boolean;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);

    VAR
      pfid: amt$file_identifier;

    IF (pf_backup_file_id.device_class = rmc$null_device) AND NOT puv$read_data_on_null_bf THEN
      pup$allow_job_termination;
      status.normal := TRUE;
      RETURN;
    IFEND;

    output_backup_version_name (pf_backup_file_id, status);
    IF status.normal THEN
      output_backup_item_path (cycle_entry, pf_utility_catalog_header, pf_backup_file_id, status);
      IF status.normal THEN
        output_item_info (cycle_entry, cycle_info, pf_backup_file_id, status);
        IF status.normal THEN
          pup$output_system_label (cycle_label_exists, cycle_label, pf_backup_file_id, status);
          IF status.normal THEN
            output_hierarchy_list (pf_utility_hierarchy_list, pf_backup_file_id, status);
            IF data_exists AND status.normal THEN
              output_cycle_data (lfn, cycle_array_entry, cycle_length, pf_backup_file_id, status);
            IFEND;
            IF status.normal THEN
              pup$write_logical_partition (pf_backup_file_id, status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pup$output_cycle;

?? TITLE := '    [XDCL] pup$output_family ', EJECT ??

  PROCEDURE [XDCL] pup$output_family (family_entry: put$entry;
        pf_utility_catalog_header: put$catalog_header;
        info: put$backup_item_info;
        pf_utility_hierarchy_list: put$hierarchy_list;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);


    IF (pf_backup_file_id.device_class = rmc$null_device) OR puv$exclude_catalog_information THEN
      pup$allow_job_termination;
      status.normal := TRUE;
      RETURN;
    IFEND;

    output_backup_version_name (pf_backup_file_id, status);
    IF status.normal THEN
      output_backup_item_path (family_entry, pf_utility_catalog_header, pf_backup_file_id, status);
      IF status.normal THEN
        output_item_info (family_entry, info, pf_backup_file_id, status);
        IF status.normal THEN
          output_hierarchy_list (pf_utility_hierarchy_list, pf_backup_file_id, status);
          IF status.normal THEN
            pup$write_logical_partition (pf_backup_file_id, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pup$output_family;

?? TITLE := '    [XDCL] pup$output_file ', EJECT ??

  PROCEDURE [XDCL] pup$output_file (pf_entry: put$entry;
        pf_utility_catalog_header: put$catalog_header;
        info: put$backup_item_info;
        pf_utility_hierarchy_list: put$hierarchy_list;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);


    IF (pf_backup_file_id.device_class = rmc$null_device) OR puv$exclude_catalog_information THEN
      pup$allow_job_termination;
      status.normal := TRUE;
      RETURN;
    IFEND;

    output_backup_version_name (pf_backup_file_id, status);
    IF status.normal THEN
      output_backup_item_path (pf_entry, pf_utility_catalog_header, pf_backup_file_id, status);
      IF status.normal THEN
        output_item_info (pf_entry, info, pf_backup_file_id, status);
        IF status.normal THEN
          output_hierarchy_list (pf_utility_hierarchy_list, pf_backup_file_id, status);
          IF status.normal THEN
            pup$write_logical_partition (pf_backup_file_id, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pup$output_file;

?? TITLE := '    [XDCL] pup$output_set ', EJECT ??

  PROCEDURE [XDCL] pup$output_set (set_entry: put$entry;
        pf_utility_catalog_header: put$catalog_header;
        info: put$backup_item_info;
        pf_utility_hierarchy_list: put$hierarchy_list;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);


    IF (pf_backup_file_id.device_class = rmc$null_device) OR puv$exclude_catalog_information THEN
      pup$allow_job_termination;
      status.normal := TRUE;
      RETURN;
    IFEND;

    output_backup_version_name (pf_backup_file_id, status);
    IF status.normal THEN
      output_backup_item_path (set_entry, pf_utility_catalog_header, pf_backup_file_id, status);
      IF status.normal THEN
        output_item_info (set_entry, info, pf_backup_file_id, status);
        IF status.normal THEN
          output_hierarchy_list (pf_utility_hierarchy_list, pf_backup_file_id, status);
          IF status.normal THEN
            pup$write_logical_partition (pf_backup_file_id, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pup$output_set;

?? TITLE := '    pup$output_system_label ', EJECT ??

  PROCEDURE pup$output_system_label (label_exists: boolean;
        label: SEQ ( * );
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);

    VAR
      record_header: put$backup_file_record_header;

    record_header.kind := puc$backup_system_label;
    IF label_exists THEN
      record_header.size := #SIZE (label);
      pup$put_partial (pf_backup_file_id, ^record_header, #SIZE (record_header), amc$start, status);
      IF status.normal THEN
        pup$put_partial (pf_backup_file_id, ^label, #SIZE (label), amc$terminate, status);
      IFEND;
    ELSE
      record_header.size := 0;
      pup$put_next (pf_backup_file_id, ^record_header, #SIZE (record_header), status);
    IFEND;
  PROCEND pup$output_system_label;

?? TITLE := ' open_reserved_cycle ', EJECT ??

  PROCEDURE open_reserved_cycle
    (    system_file_id: dmt$system_file_id;
         caller_id: ost$caller_identifier;
     VAR segment_pointer: mmt$segment_pointer;
     VAR status: ost$status);

    display (' pfp$open_file_segment');
    pfp$open_file_segment (system_file_id, caller_id.ring, segment_pointer, status);
    RESET segment_pointer.seq_pointer;

  PROCEND open_reserved_cycle;

?? TITLE := '    output_backup_item_path ', EJECT ??

  PROCEDURE output_backup_item_path
   (    pf_utility_entry: put$entry;
        pf_utility_catalog_header: put$catalog_header;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);

    VAR
      p_backup_file_item_path: ^put$backup_file_item_path;

    PUSH p_backup_file_item_path: [LOWERBOUND (pf_utility_catalog_header.path) .. UPPERBOUND
          (pf_utility_catalog_header.path)];

    p_backup_file_item_path^.item_path_descriptor.catalog_header := pf_utility_catalog_header;
    p_backup_file_item_path^.item_path_descriptor.pf_utility_entry := pf_utility_entry;

    p_backup_file_item_path^.item_path_header.kind := puc$backup_item_identifier;
    p_backup_file_item_path^.item_path_header.size := UPPERBOUND (p_backup_file_item_path^.
          item_path_descriptor.catalog_header.path);
    pup$put_next (pf_backup_file_id, p_backup_file_item_path, #SIZE (p_backup_file_item_path^), status);
  PROCEND output_backup_item_path;

?? TITLE := '    output_backup_version_name ', EJECT ??

  PROCEDURE [INLINE] output_backup_version_name (VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);

    VAR
      backup_version_name: put$backup_file_version_name;

    backup_version_name := puv$bacpf_backup_file_version;
    pup$put_next (pf_backup_file_id, ^backup_version_name, #SIZE (backup_version_name), status);
  PROCEND output_backup_version_name;

?? TITLE := '    output_cycle_data ', EJECT ??

  PROCEDURE output_cycle_data (lfn: amt$local_file_name;
        cycle_array_entry: pft$cycle_array_entry_version_2;
        file_length: amt$file_length;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      file_segment_pointer: mmt$segment_pointer,
      local_status: ost$status,
      p_backup_file_item_header: ^put$backup_file_record_header,
      user_file_id: amt$file_identifier;

    PUSH p_backup_file_item_header;
    p_backup_file_item_header^.kind := puc$backup_cycle_data;
    p_backup_file_item_header^.size := file_length;
    IF p_backup_file_item_header^.size = 0 THEN
      pup$put_next (pf_backup_file_id, p_backup_file_item_header, #SIZE (p_backup_file_item_header^), status);
    ELSE
      pup$put_next (pf_backup_file_id, p_backup_file_item_header, #SIZE (p_backup_file_item_header^), status);
      IF status.normal THEN
        #CALLER_ID (caller_id);
        IF cycle_array_entry.cycle_reservation.cycle_reserved THEN
          open_reserved_cycle (pfv$reserved_cycle_info.p_reserved_cycles^
                [cycle_array_entry.cycle_reservation.reserved_cycle_index].system_file_id, caller_id,
                file_segment_pointer, status);
        ELSE
          pup$open_file_for_seg_access (lfn, file_segment_pointer, status);
        IFEND;
        IF status.normal THEN
          pup$advised_put_next (pf_backup_file_id, file_segment_pointer.seq_pointer, file_length,
                status);
          mmp$close_segment (file_segment_pointer, caller_id.ring, local_status);
          IF status.normal AND NOT local_status.normal THEN
            status := local_status;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND output_cycle_data;

?? TITLE := '    output_hierarchy_list ', EJECT ??

  PROCEDURE output_hierarchy_list (pf_utility_hierarchy_list: put$hierarchy_list;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);

    VAR
      p_hierarchy_list_record: ^put$backup_file_hierarchy_list;

    PUSH p_hierarchy_list_record: [LOWERBOUND (pf_utility_hierarchy_list.catalog_header.path) .. UPPERBOUND
          (pf_utility_hierarchy_list.catalog_header.path)];

    p_hierarchy_list_record^.hierarchy_list_header.kind := puc$backup_hierarchy_list;
    p_hierarchy_list_record^.hierarchy_list_header.size := UPPERBOUND (pf_utility_hierarchy_list.
          catalog_header.path);
    p_hierarchy_list_record^.hierarchy_list := pf_utility_hierarchy_list;
    pup$put_next (pf_backup_file_id, p_hierarchy_list_record, #SIZE (p_hierarchy_list_record^), status);
  PROCEND output_hierarchy_list;

?? TITLE := '    output_item_info ', EJECT ??

  PROCEDURE output_item_info (pfu_entry: put$entry;
        info: put$backup_item_info;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);


{    The size field in the record header for the item_record (pf_entry,
{  catalog_entry , family_entry, AND set_entry should be the size
{  of the adaptable sequence part of the info record.

    VAR
      p_backup_file_record_header: ^put$backup_file_record_header;

    PUSH p_backup_file_record_header;
    CASE pfu_entry.entry_type OF
    = puc$valid_cycle_entry =
      p_backup_file_record_header^.kind := puc$backup_cycle_info;
      p_backup_file_record_header^.size := info.cycle_item_info.body_size;
      pup$put_partial (pf_backup_file_id, p_backup_file_record_header, #SIZE (p_backup_file_record_header^),
            amc$start, status);
      IF status.normal THEN
        pup$put_partial (pf_backup_file_id, info.cycle_item_info.body, info.cycle_item_info.body_size,
              amc$terminate, status);
      IFEND;
    = puc$valid_pf_entry =
      p_backup_file_record_header^.kind := puc$backup_file_info;
      p_backup_file_record_header^.size := (info.file_item_info^.body_size);
      pup$put_partial (pf_backup_file_id, p_backup_file_record_header, #SIZE (p_backup_file_record_header^),
            amc$start, status);
      IF status.normal THEN
        pup$put_partial (pf_backup_file_id, info.file_item_info, #SIZE (info.file_item_info^), amc$terminate,
              status);
      IFEND;
    = puc$valid_catalog_entry =
      {output catalog info
      p_backup_file_record_header^.kind := puc$backup_catalog_info;
      p_backup_file_record_header^.size := (info.catalog_item_info^.body_size);
      pup$put_partial (pf_backup_file_id, p_backup_file_record_header, #SIZE (p_backup_file_record_header^),
            amc$start, status);
      IF status.normal THEN
        pup$put_partial (pf_backup_file_id, info.catalog_item_info, #SIZE (info.catalog_item_info^),
              amc$terminate, status);
      IFEND;
    = puc$valid_family_entry =
      p_backup_file_record_header^.kind := puc$backup_family_info;
      p_backup_file_record_header^.size := (info.family_item_info^.body_size);
      pup$put_partial (pf_backup_file_id, p_backup_file_record_header, #SIZE (p_backup_file_record_header^),
            amc$start, status);
      IF status.normal THEN
        pup$put_partial (pf_backup_file_id, info.family_item_info, #SIZE (info.family_item_info^),
              amc$terminate, status);
      IFEND;
    = puc$valid_set_entry =
      p_backup_file_record_header^.kind := puc$backup_set_info;
      p_backup_file_record_header^.size := (info.set_item_info^.body_size);
      pup$put_partial (pf_backup_file_id, p_backup_file_record_header, #SIZE (p_backup_file_record_header^),
            amc$start, status);
      IF status.normal THEN
        pup$put_partial (pf_backup_file_id, info.set_item_info, #SIZE (info.set_item_info^), amc$terminate,
              status);
      IFEND;
    ELSE
    CASEND;
  PROCEND output_item_info;

MODEND pum$backup_file_output;
*DECK DECK=PUM$BACKUP_LABEL_TYPE_COMMANDS EXPAND=TRUE
*copyc osd$default_pragmats

MODULE pum$backup_label_type_commands;

?? PUSH (LISTEXT := ON) ??
*copyc clp$evaluate_parameters
*copyc osp$set_status_condition
*copyc cld$value
*copyc cle$ecc_parameter_list
*copyc pue$error_condition_codes
*copyc ost$status
?? POP ??
?? EJECT ??


  PROCEDURE [XDCL, #GATE] pup$display_backup_flt_cmd (
        parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE (osm$disblt) display_backup_label_type, disblt (
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 11, 18, 13, 21, 35, 955],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$DISBLT'], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF status.normal THEN
      osp$set_status_condition (pue$backup_label_type_commands, status);
    IFEND;

  PROCEND pup$display_backup_flt_cmd;
?? EJECT ??

  PROCEDURE [XDCL] pup$change_backup_flt_cmd (
        parameter_list: clt$parameter_list;
    VAR status: ost$status);

{   PROCEDURE (osm$chablt) change_backup_label_type, chablt (
{     file_label_type, flt: key
{         (labeled, labelled, l)
{         (unlabeled, unlabelled, u)
{       keyend = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 9, 25, 14, 36, 36, 768],
    clc$command, 3, 2, 1, 0, 0, 0, 2, 'OSM$CHABLT'], [
    ['FILE_LABEL_TYPE                ',clc$nominal_entry, 1],
    ['FLT                            ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 229, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [6], [
    ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
    ['LABELED                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['LABELLED                       ', clc$alias_entry,
  clc$normal_usage_entry, 1],
    ['U                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
    ['UNLABELED                      ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['UNLABELLED                     ', clc$alias_entry,
  clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file_label_type = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF status.normal THEN
      osp$set_status_condition (pue$backup_label_type_commands, status);
    IFEND;

  PROCEND pup$change_backup_flt_cmd;

MODEND pum$backup_label_type_commands;
*DECK DECK=PUM$BACKUP_PERMANENT_FILE EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  backup_permanent_file ', EJECT ??
MODULE pum$backup_permanent_file;
{
{  This module contains the command table and entry and exit points for
{  the BACKUP_PERMANENT_FILES utility.  The processing for the
{  SET_BACKUP_OPTIONS subcommand is also within this module.
{
?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amp$close
*copyc amt$backup_information
*copyc avp$family_administrator
*copyc avp$system_administrator
*copyc clp$convert_integer_to_string
*copyc clp$end_scan_command_file
*copyc clp$evaluate_parameters
*copyc clp$get_value
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$scan_command_file
*copyc clp$scan_parameter_list
*copyc osd$integer_limits
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc ost$string
*copyc pud$backup_file
*copyc pue$error_condition_codes
*copyc pup$all_volumes_included
*copyc pup$close_backup_file
*copyc pup$close_display_file
*copyc pup$crack_file
*copyc pup$crack_file_reference
*copyc pup$display_blank_lines
*copyc pup$display_boolean
*copyc pup$display_line
*copyc pup$open_backup_file
*copyc pup$open_display_file
*copyc pus$literals
*copyc put$file_identifier
*copyc put$exclude_site_backup_options
*copyc put$include_data_options
*copyc puv$trace_selected
?? POP ??
?? TITLE := '    Global Variables', EJECT ??

  VAR
    { Backup file information }
    puv$backup_information: [XDCL, STATIC] amt$backup_information,
    puv$backup_file_id: [XDCL, STATIC] put$file_identifier,
    puv$bacpf_cycle_data_total: [XDCL, STATIC] ost$non_negative_integers,
    puv$bacpf_backup_file_version: [XDCL, STATIC] put$backup_file_version_name :=
          puc$backup_file_version_2,
    puv$null_original_unique_name: [XDCL, STATIC] ost$binary_unique_name := [0, 0, 1980, 1, 1, 0, 0, 0, 0, 0],
    puv$null_res_cycle_array_ent_sp: [XDCL, STATIC] array [1 .. 46] of boolean := [REP 46 OF FALSE],
    puv$null_reserved_cycle_info_sp: [XDCL, STATIC] array [1 .. 55] of boolean := [REP 55 OF FALSE];

  VAR
    { Backup options }
    puv$backup_share_modes: [XDCL, STATIC] pft$usage_selections :=
          $pft$usage_selections[pfc$read, pfc$execute],
    puv$exclude_catalog_information: [XDCL, STATIC] boolean := FALSE,
    puv$exclude_site_backup_options: [XDCL] put$exclude_site_backup_options :=
          $put$exclude_site_backup_options [],
    puv$include_archive_information: [XDCL] boolean,
    puv$include_data_options: [XDCL] put$include_data_options :=
          $put$include_data_options [puc$include_releasable_data, puc$include_unreleasable_data],
    puv$include_exceptions: [XDCL, STATIC] boolean := TRUE,
    puv$read_data_on_null_bf: [XDCL, STATIC] boolean := FALSE;


  CONST
    puc$backup_utility_name = 'BACKUP_PERMANENT_FILES         ';

?? TITLE := '    [XDCL] pup$backup_permanent_file ', EJECT ??

  PROCEDURE [XDCL] pup$backup_permanent_file (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ table backup_command_list type=command section_name=pus$literals, ..
{   scope=local
{ command allow_rtbt_test processor=pup$allow_rtbt_test call_method=xref ..
{   availability=hidden   log=automatic
{ command (backup_all_files, bacaf) processor=pup$backup_all_files_command ..
{   call_method=xref                                        ..
{   availability=advertised, log=automatic
{ command (backup_catalog bacc) processor=pup$backup_catalog_command ..
{   call_method=xref                                  ..
{   availability=advertised,       log=automatic
{ command (backup_file bacf) processor=pup$backup_file_command ..
{   call_method=xref availability=advertised,                        ..
{                   log=manual
{ command (backup_set bacs) processor=pup$backup_set_command ..
{   call_method=xref availability=advertised,                        ..
{                   log=manual
{ command (close_volume) processor=pup$close_volume call_method=xref ..
{   availability=hidden log=automatic
{ command (delete_all_files) processor=pup$delete_all_files_cm ..
{   call_method=xref availability=advertised,                        ..
{               log=automatic
{ command (delete_catalog_contents delete_catalog_content, delcc)          ..
{   processor=pup$delete_catalog_contents_cm             ..
{   call_method=xref                      ..
{   availability=advertised, log=automatic
{ command (delete_file_contents delete_file_content, delfc) ..
{   processor=pup$delete_file_command                                ..
{     call_method=xref       availability=advertised, log=manual
{ command (display_active_volumes) processor=pup$display_volumes_command ..
{   call_method=xref                                  ..
{   availability=hidden,       log=automatic
{ command display_advise processor=pup$display_advise_cmd call_method=xref ..
{   availability=hidden                                   ..
{   log=automatic
{ command (display_all_users) processor=pup$display_all_users_command ..
{   call_method=xref                      availability=hidden        ..
{       ,       log=automatic
{ command (display_backup_directives) processor=pup$display_directives ..
{   call_method=xref                                  ..
{   availability=hidden,       log=automatic
{ command (display_backup_options display_backup_option disbo) ..
{   processor=pup$display_backup_options_cm           ..
{   call_method=local availability=advertised log=automatic
{ command (display_exclude_highest_cycles) ..
{   processor=pup$display_exc_highest_cycles call_method=xref        ..
{   availability=hidden, ..
{   log=automatic
{ command (display_excluded_items) processor=pup$display_excluded_items ..
{   call_method=xref                                  ..
{   availability=hidden,       log=automatic
{ command (display_include_empty_catalogs) ..
{   processor=pup$display_delete_empty_cat_cm call_method=xref       ..
{   availability=hidden, ..
{   log=automatic
{ command (display_included_cycles) processor=pup$dis_included_cycles_cm ..
{   call_method=xref                                  ..
{   availability=hidden,       log=automatic
{ command (display_included_volumes) ..
{   processor=pup$display_included_volumes call_method=xref          ..
{                                 availability=hidden, log=automatic
{ command (display_list_options) processor=pup$display_list_options ..
{   call_method=xref       availability=hidden,                      ..
{               log=automatic
{ command (exclude_catalog excc) processor=pup$exclude_catalog_command ..
{   call_method=xref                                  ..
{   availability=advertised      , log=automatic
{ command (exclude_file excf) processor=pup$exclude_pf_command ..
{   call_method=xref availability=advertised,                        ..
{                   log=automatic
{ command (exclude_highest_cycles, exclude_highest_cycle, exchc)       ..
{   processor=pup$exclude_highest_cycles_cm                          ..
{   call_method=xref       availability=advertised, ..
{   log=automatic
{ command (include_all_files) processor=pup$include_all_files ..
{   call_method=xref availability=hidden,                            ..
{               log=automatic
{ command (include_catalog) processor=pup$include_catalog_command ..
{   call_method=xref availability=hidden,                            ..
{               log=automatic
{ command (include_cycles include_cycle, incc) ..
{   processor=pup$backup_include_cycles call_method=xref             ..
{                              availability=advertised, log=automatic
{ command (include_empty_catalogs, include_empty_catalog, incec) ..
{   processor=pup$include_empty_catalog_cm                           ..
{   call_method=xref availability=advertised, ..
{   log=automatic
{ command (include_excluded_items) processor=pup$include_excluded_items ..
{   call_method=xref                                  ..
{   availability=hidden,       log=automatic
{ command (include_large_cycles include_large_cycle, inclc) ..
{   processor=pup$include_large_cycles_cmd                           ..
{   call_method=xref availability=advertised, ..
{   log=automatic
{ command (include_master_catalogs include_master_catalog incmc)           ..
{   processor=pup$include_master_catalog_cmd            ..
{   call_method=xref availability=advertised,                      ..
{   log=automatic
{ command (include_permanent_file) processor=pup$include_pf_command ..
{   call_method=xref       availability=hidden,                      ..
{               log=automatic
{ command (include_small_cycles, include_small_cycle, incsc) ..
{   processor=pup$include_small_cycles_cmd,                          ..
{   call_method=xref availability=advertised ..
{   log=automatic
{ command (include_users include_user, incu) ..
{   processor=pup$include_users_command call_method=xref             ..
{                              availability=advertised, log=automatic
{ command (include_volumes include_volume, incv) ..
{   processor=pup$backup_include_volumes_cmd     call_method=xref    ..
{   availability=advertised, ..
{   log=automatic
{ command (log_keyed_file_backup logkfb) ..
{   processor=pup$log_keyed_file_backup call_method=xref             ..
{   availability=hidden ..
{   log=automatic
{ command (push_restore) processor=pup$restore_permanent_file ..
{   call_method=xref availability=hidden,                            ..
{               log=automatic
{ command (putrace) processor=pup$trace call_method=xref ..
{   availability=hidden, log=automatic
{ command (quit qui) processor=pup$quit call_method=local ..
{   availability=advertised, log=automatic
{ command (select_advise_in) processor=pup$select_advise_in_cmd ..
{   call_method=xref  availability=hidden                            ..
{         log=automatic,
{ command (select_data_file) processor=pup$select_data_file ..
{   call_method=xref availability=hidden,                            ..
{         log=automatic
{ command (set_backup_options, set_backup_option, setbo) ..
{   processor=set_backup_options_subcommand                          ..
{             call_method=local availability=advertised log=automatic
{ command (set_list_options, set_list_option, setlo) ..
{   processor=pup$set_list_options_command                           ..
{   call_method=xref       availability=advertised, ..
{   log=automatic
{ command (sort_users soru) processor=pup$sort_users_command ..
{   call_method=xref availability=advertised,                        ..
{                   log=automatic

?? PUSH (LISTEXT := ON) ??

VAR
  backup_command_list: [STATIC, READ, pus$literals] ^clt$command_table
      := ^backup_command_list_entries,

  backup_command_list_entries: [STATIC, READ, pus$literals] array [1 ..
      78] of clt$command_table_entry := [
  {} ['ALLOW_RTBT_TEST                ', clc$nominal_entry,
        clc$hidden_entry, 1, clc$automatically_log, clc$linked_call,
        ^pup$allow_rtbt_test],
  {} ['BACAF                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^pup$backup_all_files_command],
  {} ['BACC                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^pup$backup_catalog_command],
  {} ['BACF                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 4, clc$manually_log, clc$linked_call,
        ^pup$backup_file_command],
  {} ['BACKUP_ALL_FILES               ', clc$nominal_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^pup$backup_all_files_command],
  {} ['BACKUP_CATALOG                 ', clc$nominal_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$linked_call,
        ^pup$backup_catalog_command],
  {} ['BACKUP_FILE                    ', clc$nominal_entry,
        clc$normal_usage_entry, 4, clc$manually_log, clc$linked_call,
        ^pup$backup_file_command],
  {} ['BACKUP_SET                     ', clc$nominal_entry,
        clc$normal_usage_entry, 5, clc$manually_log, clc$linked_call,
        ^pup$backup_set_command],
  {} ['BACS                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 5, clc$manually_log, clc$linked_call,
        ^pup$backup_set_command],
  {} ['CLOSE_VOLUME                   ', clc$nominal_entry,
        clc$hidden_entry, 6, clc$automatically_log, clc$linked_call,
        ^pup$close_volume],
  {} ['DELCC                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 8, clc$automatically_log, clc$linked_call,
        ^pup$delete_catalog_contents_cm],
  {} ['DELETE_ALL_FILES               ', clc$nominal_entry,
        clc$normal_usage_entry, 7, clc$automatically_log, clc$linked_call,
        ^pup$delete_all_files_cm],
  {} ['DELETE_CATALOG_CONTENT         ', clc$alias_entry,
        clc$normal_usage_entry, 8, clc$automatically_log, clc$linked_call,
        ^pup$delete_catalog_contents_cm],
  {} ['DELETE_CATALOG_CONTENTS        ', clc$nominal_entry,
        clc$normal_usage_entry, 8, clc$automatically_log, clc$linked_call,
        ^pup$delete_catalog_contents_cm],
  {} ['DELETE_FILE_CONTENT            ', clc$alias_entry,
        clc$normal_usage_entry, 9, clc$manually_log, clc$linked_call,
        ^pup$delete_file_command],
  {} ['DELETE_FILE_CONTENTS           ', clc$nominal_entry,
        clc$normal_usage_entry, 9, clc$manually_log, clc$linked_call,
        ^pup$delete_file_command],
  {} ['DELFC                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 9, clc$manually_log, clc$linked_call,
        ^pup$delete_file_command],
  {} ['DISBO                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 14, clc$automatically_log, clc$linked_call,
        ^pup$display_backup_options_cm],
  {} ['DISPLAY_ACTIVE_VOLUMES         ', clc$nominal_entry,
        clc$hidden_entry, 10, clc$automatically_log, clc$linked_call,
        ^pup$display_volumes_command],
  {} ['DISPLAY_ADVISE                 ', clc$nominal_entry,
        clc$hidden_entry, 11, clc$automatically_log, clc$linked_call,
        ^pup$display_advise_cmd],
  {} ['DISPLAY_ALL_USERS              ', clc$nominal_entry,
        clc$hidden_entry, 12, clc$automatically_log, clc$linked_call,
        ^pup$display_all_users_command],
  {} ['DISPLAY_BACKUP_DIRECTIVES      ', clc$nominal_entry,
        clc$hidden_entry, 13, clc$automatically_log, clc$linked_call,
        ^pup$display_directives],
  {} ['DISPLAY_BACKUP_OPTION          ', clc$alias_entry,
        clc$normal_usage_entry, 14, clc$automatically_log, clc$linked_call,
        ^pup$display_backup_options_cm],
  {} ['DISPLAY_BACKUP_OPTIONS         ', clc$nominal_entry,
        clc$normal_usage_entry, 14, clc$automatically_log, clc$linked_call,
        ^pup$display_backup_options_cm],
  {} ['DISPLAY_EXCLUDED_ITEMS         ', clc$nominal_entry,
        clc$hidden_entry, 16, clc$automatically_log, clc$linked_call,
        ^pup$display_excluded_items],
  {} ['DISPLAY_EXCLUDE_HIGHEST_CYCLES ', clc$nominal_entry,
        clc$hidden_entry, 15, clc$automatically_log, clc$linked_call,
        ^pup$display_exc_highest_cycles],
  {} ['DISPLAY_INCLUDED_CYCLES        ', clc$nominal_entry,
        clc$hidden_entry, 18, clc$automatically_log, clc$linked_call,
        ^pup$dis_included_cycles_cm],
  {} ['DISPLAY_INCLUDED_VOLUMES       ', clc$nominal_entry,
        clc$hidden_entry, 19, clc$automatically_log, clc$linked_call,
        ^pup$display_included_volumes],
  {} ['DISPLAY_INCLUDE_EMPTY_CATALOGS ', clc$nominal_entry,
        clc$hidden_entry, 17, clc$automatically_log, clc$linked_call,
        ^pup$display_delete_empty_cat_cm],
  {} ['DISPLAY_LIST_OPTIONS           ', clc$nominal_entry,
        clc$hidden_entry, 20, clc$automatically_log, clc$linked_call,
        ^pup$display_list_options],
  {} ['EXCC                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 21, clc$automatically_log, clc$linked_call,
        ^pup$exclude_catalog_command],
  {} ['EXCF                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 22, clc$automatically_log, clc$linked_call,
        ^pup$exclude_pf_command],
  {} ['EXCHC                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 23, clc$automatically_log, clc$linked_call,
        ^pup$exclude_highest_cycles_cm],
  {} ['EXCLUDE_CATALOG                ', clc$nominal_entry,
        clc$normal_usage_entry, 21, clc$automatically_log, clc$linked_call,
        ^pup$exclude_catalog_command],
  {} ['EXCLUDE_FILE                   ', clc$nominal_entry,
        clc$normal_usage_entry, 22, clc$automatically_log, clc$linked_call,
        ^pup$exclude_pf_command],
  {} ['EXCLUDE_HIGHEST_CYCLE          ', clc$alias_entry,
        clc$normal_usage_entry, 23, clc$automatically_log, clc$linked_call,
        ^pup$exclude_highest_cycles_cm],
  {} ['EXCLUDE_HIGHEST_CYCLES         ', clc$nominal_entry,
        clc$normal_usage_entry, 23, clc$automatically_log, clc$linked_call,
        ^pup$exclude_highest_cycles_cm],
  {} ['INCC                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 26, clc$automatically_log, clc$linked_call,
        ^pup$backup_include_cycles],
  {} ['INCEC                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 27, clc$automatically_log, clc$linked_call,
        ^pup$include_empty_catalog_cm],
  {} ['INCLC                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 29, clc$automatically_log, clc$linked_call,
        ^pup$include_large_cycles_cmd],
  {} ['INCLUDE_ALL_FILES              ', clc$nominal_entry,
        clc$hidden_entry, 24, clc$automatically_log, clc$linked_call,
        ^pup$include_all_files],
  {} ['INCLUDE_CATALOG                ', clc$nominal_entry,
        clc$hidden_entry, 25, clc$automatically_log, clc$linked_call,
        ^pup$include_catalog_command],
  {} ['INCLUDE_CYCLE                  ', clc$alias_entry,
        clc$normal_usage_entry, 26, clc$automatically_log, clc$linked_call,
        ^pup$backup_include_cycles],
  {} ['INCLUDE_CYCLES                 ', clc$nominal_entry,
        clc$normal_usage_entry, 26, clc$automatically_log, clc$linked_call,
        ^pup$backup_include_cycles],
  {} ['INCLUDE_EMPTY_CATALOG          ', clc$alias_entry,
        clc$normal_usage_entry, 27, clc$automatically_log, clc$linked_call,
        ^pup$include_empty_catalog_cm],
  {} ['INCLUDE_EMPTY_CATALOGS         ', clc$nominal_entry,
        clc$normal_usage_entry, 27, clc$automatically_log, clc$linked_call,
        ^pup$include_empty_catalog_cm],
  {} ['INCLUDE_EXCLUDED_ITEMS         ', clc$nominal_entry,
        clc$hidden_entry, 28, clc$automatically_log, clc$linked_call,
        ^pup$include_excluded_items],
  {} ['INCLUDE_LARGE_CYCLE            ', clc$alias_entry,
        clc$normal_usage_entry, 29, clc$automatically_log, clc$linked_call,
        ^pup$include_large_cycles_cmd],
  {} ['INCLUDE_LARGE_CYCLES           ', clc$nominal_entry,
        clc$normal_usage_entry, 29, clc$automatically_log, clc$linked_call,
        ^pup$include_large_cycles_cmd],
  {} ['INCLUDE_MASTER_CATALOG         ', clc$alias_entry,
        clc$normal_usage_entry, 30, clc$automatically_log, clc$linked_call,
        ^pup$include_master_catalog_cmd],
  {} ['INCLUDE_MASTER_CATALOGS        ', clc$nominal_entry,
        clc$normal_usage_entry, 30, clc$automatically_log, clc$linked_call,
        ^pup$include_master_catalog_cmd],
  {} ['INCLUDE_PERMANENT_FILE         ', clc$nominal_entry,
        clc$hidden_entry, 31, clc$automatically_log, clc$linked_call,
        ^pup$include_pf_command],
  {} ['INCLUDE_SMALL_CYCLE            ', clc$alias_entry,
        clc$normal_usage_entry, 32, clc$automatically_log, clc$linked_call,
        ^pup$include_small_cycles_cmd],
  {} ['INCLUDE_SMALL_CYCLES           ', clc$nominal_entry,
        clc$normal_usage_entry, 32, clc$automatically_log, clc$linked_call,
        ^pup$include_small_cycles_cmd],
  {} ['INCLUDE_USER                   ', clc$alias_entry,
        clc$normal_usage_entry, 33, clc$automatically_log, clc$linked_call,
        ^pup$include_users_command],
  {} ['INCLUDE_USERS                  ', clc$nominal_entry,
        clc$normal_usage_entry, 33, clc$automatically_log, clc$linked_call,
        ^pup$include_users_command],
  {} ['INCLUDE_VOLUME                 ', clc$alias_entry,
        clc$normal_usage_entry, 34, clc$automatically_log, clc$linked_call,
        ^pup$backup_include_volumes_cmd],
  {} ['INCLUDE_VOLUMES                ', clc$nominal_entry,
        clc$normal_usage_entry, 34, clc$automatically_log, clc$linked_call,
        ^pup$backup_include_volumes_cmd],
  {} ['INCMC                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 30, clc$automatically_log, clc$linked_call,
        ^pup$include_master_catalog_cmd],
  {} ['INCSC                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 32, clc$automatically_log, clc$linked_call,
        ^pup$include_small_cycles_cmd],
  {} ['INCU                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 33, clc$automatically_log, clc$linked_call,
        ^pup$include_users_command],
  {} ['INCV                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 34, clc$automatically_log, clc$linked_call,
        ^pup$backup_include_volumes_cmd],
  {} ['LOGKFB                         ', clc$abbreviation_entry,
        clc$hidden_entry, 35, clc$automatically_log, clc$linked_call,
        ^pup$log_keyed_file_backup],
  {} ['LOG_KEYED_FILE_BACKUP          ', clc$nominal_entry,
        clc$hidden_entry, 35, clc$automatically_log, clc$linked_call,
        ^pup$log_keyed_file_backup],
  {} ['PUSH_RESTORE                   ', clc$nominal_entry,
        clc$hidden_entry, 36, clc$automatically_log, clc$linked_call,
        ^pup$restore_permanent_file],
  {} ['PUTRACE                        ', clc$nominal_entry,
        clc$hidden_entry, 37, clc$automatically_log, clc$linked_call,
        ^pup$trace],
  {} ['QUI                            ', clc$abbreviation_entry,
        clc$normal_usage_entry, 38, clc$automatically_log, clc$linked_call,
        ^pup$quit],
  {} ['QUIT                           ', clc$nominal_entry,
        clc$normal_usage_entry, 38, clc$automatically_log, clc$linked_call,
        ^pup$quit],
  {} ['SELECT_ADVISE_IN               ', clc$nominal_entry,
        clc$hidden_entry, 39, clc$automatically_log, clc$linked_call,
        ^pup$select_advise_in_cmd],
  {} ['SELECT_DATA_FILE               ', clc$nominal_entry,
        clc$hidden_entry, 40, clc$automatically_log, clc$linked_call,
        ^pup$select_data_file],
  {} ['SETBO                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 41, clc$automatically_log, clc$linked_call,
        ^set_backup_options_subcommand],
  {} ['SETLO                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 42, clc$automatically_log, clc$linked_call,
        ^pup$set_list_options_command],
  {} ['SET_BACKUP_OPTION              ', clc$alias_entry,
        clc$normal_usage_entry, 41, clc$automatically_log, clc$linked_call,
        ^set_backup_options_subcommand],
  {} ['SET_BACKUP_OPTIONS             ', clc$nominal_entry,
        clc$normal_usage_entry, 41, clc$automatically_log, clc$linked_call,
        ^set_backup_options_subcommand],
  {} ['SET_LIST_OPTION                ', clc$alias_entry,
        clc$normal_usage_entry, 42, clc$automatically_log, clc$linked_call,
        ^pup$set_list_options_command],
  {} ['SET_LIST_OPTIONS               ', clc$nominal_entry,
        clc$normal_usage_entry, 42, clc$automatically_log, clc$linked_call,
        ^pup$set_list_options_command],
  {} ['SORT_USERS                     ', clc$nominal_entry,
        clc$normal_usage_entry, 43, clc$automatically_log, clc$linked_call,
        ^pup$sort_users_command],
  {} ['SORU                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 43, clc$automatically_log, clc$linked_call,
        ^pup$sort_users_command]];

  PROCEDURE [XREF] pup$allow_rtbt_test
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$backup_all_files_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$backup_catalog_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$backup_file_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$backup_include_cycles
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$backup_include_volumes_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$backup_set_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$close_volume
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$delete_all_files_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$delete_catalog_contents_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$delete_file_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$display_advise_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$display_all_users_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$display_delete_empty_cat_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$display_directives
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$display_excluded_items
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$display_exc_highest_cycles
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$display_included_volumes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$display_list_options
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$display_volumes_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$dis_included_cycles_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$exclude_catalog_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$exclude_highest_cycles_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$exclude_pf_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$include_all_files
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$include_catalog_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$include_empty_catalog_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$include_excluded_items
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$include_large_cycles_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$include_master_catalog_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$include_pf_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$include_small_cycles_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$include_users_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$log_keyed_file_backup
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$restore_permanent_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$select_advise_in_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$select_data_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$set_list_options_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$sort_users_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$trace
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??


    VAR
      backup_file: amt$local_file_name,
      command_file: amt$local_file_name,
      list_file: amt$local_file_name,
      local_status: ost$status;

    status.normal := TRUE;
    local_status.normal := TRUE;
    crack_bacpf (parameter_list, backup_file, list_file, status);
    IF status.normal THEN
      pup$open_display_file (list_file, status);
      IF status.normal THEN
        pup$open_backup_file (backup_file, puc$backup_permanent_files, amc$open_at_boi,
            puv$backup_file_id, status);
        IF status.normal THEN
          puv$include_archive_information := avp$family_administrator () OR avp$system_administrator ();

          clp$push_utility (puc$backup_utility_name, clc$global_command_search, backup_command_list, NIL,
                status);
          IF status.normal THEN
            command_file := '$COMMAND';
            clp$scan_command_file (command_file, puc$backup_utility_name, 'PUB', status);
            clp$pop_utility (local_status);
            IF status.normal AND (NOT local_status.normal) THEN
              status := local_status;
            IFEND;
          IFEND;
          pup$close_backup_file (puv$backup_file_id, local_status);
          IF status.normal AND (NOT local_status.normal) THEN
            status := local_status;
          IFEND;
        IFEND;
        pup$close_display_file (list_file, local_status);
        IF status.normal AND (NOT local_status.normal) THEN
          status := local_status;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pup$backup_permanent_file;

?? TITLE := '    pup$quit ', EJECT ??

  PROCEDURE pup$quit (parameter_list: clt$parameter_list;
    VAR status: ost$status);
{ pdt pfu_quit_pdt()

    VAR
      pfu_quit_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

    status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, pfu_quit_pdt, status);
    IF status.normal THEN
      clp$end_scan_command_file (puc$backup_utility_name, status);
    IFEND;
  PROCEND pup$quit;

?? TITLE := '    crack_bacpf ', EJECT ??

  PROCEDURE crack_bacpf (parameter_list: clt$parameter_list;
    VAR backup_file_lfn: amt$local_file_name;
    VAR list_file: amt$local_file_name;
    VAR status: ost$status);


{ pdt pf_backup_pf_pdt (
{ backup_file,bf:file=$required
{ list,l:file=$list
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pf_backup_pf_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^pf_backup_pf_pdt_names,
        ^pf_backup_pf_pdt_params];

    VAR
      pf_backup_pf_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
        clt$parameter_name_descriptor := [['BACKUP_FILE', 1], ['BF', 1], ['LIST', 2], ['L', 2], ['STATUS',
        3]];

    VAR
      pf_backup_pf_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor
        := [

{ BACKUP_FILE BF }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ LIST L }
      [[clc$optional_with_default, ^pf_backup_pf_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      pf_backup_pf_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := '$list';

?? POP ??

    VAR
      value: clt$value;

    clp$scan_parameter_list (parameter_list, pf_backup_pf_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('BACKUP_FILE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    backup_file_lfn := value.file.local_file_name;

    pup$crack_file_reference ('LIST', list_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND crack_bacpf;

?? TITLE := '    pup$display_backup_options_cm', EJECT ??
  PROCEDURE pup$display_backup_options_cm (
        parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE (pup$disbo) display_backup_options, display_backup_option, disbo (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [97, 1, 31, 15, 42, 52, 298],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'PUP$DISBO'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      high: integer,
      ignore_status: ost$status,
      local_status: ost$status,
      low: integer,
      option: integer,
      option_string: ost$string,
      s: ost$string,
      subrange: integer;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$display_line (' Backup_Options', ignore_status);

    pup$display_blank_lines (1, ignore_status);

    s.value (1, 35) := '   Backup_File_Version           : ';
    s.size := 35;
    s.value (s.size + 1, 31) := puv$bacpf_backup_file_version;
    s.size := s.size + 31;
    pup$display_line (s.value (1, s.size), ignore_status);

    s.value (1, 35) := '   Exclude_Catalog_Information   : ';
    s.size := 35;
    IF puv$exclude_catalog_information THEN
      s.value (s.size + 1, 4) := 'True';
      s.size := s.size + 4;
    ELSE
      s.value (s.size + 1, 5) := 'False';
      s.size := s.size + 5;
    IFEND;
    pup$display_line (s.value (1, s.size), ignore_status);

    s.value (1, 35) := '   Exclude_Site_Backup_Option    : ';
    s.size := 35;
    IF puv$exclude_site_backup_options = $put$exclude_site_backup_options [] THEN
      s.value (s.size + 1, 4) := 'None';
      s.size := s.size + 4;
    ELSEIF puv$exclude_site_backup_options = -$put$exclude_site_backup_options [] THEN
      s.value (s.size + 1, 3) := 'All';
      s.size := s.size + 3;
    ELSE
      s.value (s.size + 1, 1) := '(';
      s.size := s.size + 1;
      option := 0;
    /all_exclude_options/
      WHILE option <= 255 DO
        IF option IN puv$exclude_site_backup_options THEN
          low := option;
          high := option;
        /exclude_range/
          FOR subrange := (low + 1) TO 255 DO
            IF subrange IN puv$exclude_site_backup_options THEN
              high := high + 1;
            ELSE
              EXIT /exclude_range/;
            IFEND;
          FOREND /exclude_range/;
          IF low <> high THEN
            clp$convert_integer_to_string (low, {radix} 10, {include_radix} FALSE, option_string,
                  local_status);
            IF local_status.normal THEN
              s.value (s.size + 1, option_string.size) := option_string.value (1, option_string.size);
              s.size := s.size + option_string.size;
            IFEND;
            s.value (s.size + 1, 2) := '..';
            s.size := s.size + 2;
            clp$convert_integer_to_string (high, {radix} 10, {include_radix} FALSE, option_string,
                  local_status);
            IF local_status.normal THEN
              s.value (s.size + 1, option_string.size) := option_string.value (1, option_string.size);
              s.size := s.size + option_string.size;
            IFEND;
          ELSE
            clp$convert_integer_to_string (low, {radix} 10, {include_radix} FALSE, option_string,
                  local_status);
            IF local_status.normal THEN
              s.value (s.size + 1, option_string.size) := option_string.value (1, option_string.size);
              s.size := s.size + option_string.size;
            IFEND;
          IFEND;
          s.value (s.size + 1, 1) := ' ';
          s.size := s.size + 1;
          low := high;
          option := high + 1;
          CYCLE /all_exclude_options/;
        IFEND;
        option := option + 1;
      WHILEND /all_exclude_options/;
      s.value (s.size, 1) := ')';
    IFEND;
    pup$display_line (s.value (1, s.size), ignore_status);

    s.value (1, 35) := '   Include_Archive_Information   : ';
    s.size := 35;
    IF puv$include_archive_information THEN
      s.value (s.size + 1, 4) := 'True';
      s.size := s.size + 4;
    ELSE
      s.value (s.size + 1, 5) := 'False';
      s.size := s.size + 5;
    IFEND;
    pup$display_line (s.value (1, s.size), ignore_status);

    s.value (1, 36) := '   Include_Data                  : (';
    s.size := 36;
    IF puc$include_unreleasable_data IN puv$include_data_options THEN
      s.value (s.size + 1, 18) := 'Unreleasable_Data ';
      s.size := s.size + 18;
    IFEND;
    IF puc$include_releasable_data IN puv$include_data_options THEN
      s.value (s.size + 1, 16) := 'Releasable_Data ';
      s.size := s.size + 16;
    IFEND;
    IF puc$include_offline_data IN puv$include_data_options THEN
      s.value (s.size + 1, 13) := 'Offline_Data ';
      s.size := s.size + 13;
    IFEND;
    s.value (s.size, 1) := ')';
    pup$display_line (s.value (1, s.size), ignore_status);

    s.value (1, 35) := '   Include_Exception_Conditions  : ';
    s.size := 35;
    IF puv$include_exceptions THEN
      s.value (s.size + 1, 3) := 'All';
      s.size := s.size + 3;
    ELSE
      s.value (s.size + 1, 4) := 'None';
      s.size := s.size + 4;
    IFEND;
    pup$display_line (s.value (1, s.size), ignore_status);

    s.value (1, 35) := '   Null_File_Backup_Option       : ';
    s.size := 35;
    IF puv$read_data_on_null_bf THEN
      s.value (s.size + 1, 27) := 'Reading Data on Null Backup';
      s.size := s.size + 27;
    ELSE
      s.value (s.size + 1, 31) := 'Not Reading Data on Null Backup';
      s.size := s.size + 31;
    IFEND;
    pup$display_line (s.value (1, s.size), ignore_status);

    s.value (1, 35) := '   Share_Modes                   : ';
    s.size := 35;
    IF puv$backup_share_modes = $pft$usage_selections [] THEN
      s.value (s.size + 1, 4) := 'None';
      s.size := s.size + 4;
    ELSE
      s.value (s.size + 1, 1) := '(';
      s.size := s.size + 1;
      IF pfc$read IN puv$backup_share_modes THEN
        s.value (s.size + 1, 5) := 'Read ';
        s.size := s.size + 5;
      IFEND;
      IF pfc$shorten IN puv$backup_share_modes THEN
        s.value (s.size + 1, 8) := 'Shorten ';
        s.size := s.size + 8;
      IFEND;
      IF pfc$append IN puv$backup_share_modes THEN
        s.value (s.size + 1, 7) := 'Append ';
        s.size := s.size + 7;
      IFEND;
      IF pfc$modify IN puv$backup_share_modes THEN
        s.value (s.size + 1, 7) := 'Modify ';
        s.size := s.size + 7;
      IFEND;
      IF pfc$execute IN puv$backup_share_modes THEN
        s.value (s.size + 1, 8) := 'Execute ';
        s.size := s.size + 8;
      IFEND;
      s.value (s.size, 1) := ')';
    IFEND;
    pup$display_line (s.value (1, s.size), ignore_status);

    pup$display_blank_lines (1, ignore_status);

  PROCEND pup$display_backup_options_cm;

?? TITLE := '  set_backup_options_subcommand' , EJECT ??

  PROCEDURE set_backup_options_subcommand
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$setbo) set_backup_option, set_backup_options, setbo (
{   exclude_catalog_information, eci: boolean = $optional
{   null_backup_file_option, nbfo: key
{       (read_data, rd)
{     keyend = $optional
{   include_archive_information, iai: boolean = $optional
{   include_data, id: any of
{       list of key
{         (offline_data, od)
{         (releasable_data, rd)
{         (unreleasable_data, ud)
{       keyend
{       key
{         all
{       keyend
{     anyend = (releasable_data, unreleasable_data)
{   backup_file_version, bfv: integer 1..2 = 2
{   exclude_site_backup_option, esbo: (BY_NAME, ADVANCED) any of
{       key
{         all, none
{       keyend
{       list of range of integer 0..255
{     anyend = $optional
{   include_exception_conditions, iec: (BY_NAME) key
{       all, none
{     keyend = $optional
{   share_modes, sm: (BY_NAME, ADVANCED) any of
{       key
{         all
{       keyend
{       list of key
{         (append, a)
{         (execute, e)
{         (modify, m)
{         (read, r)
{         (shorten, s)
{         (write, w)
{       keyend
{     anyend = (execute read)
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 17] of clt$pdt_parameter_name,
      parameters: array [1 .. 9] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: 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$list_type_qualifier_v2,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 6] of clt$keyword_specification,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (36),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (1),
      recend,
      type6: 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 .. 2] 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$range_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$integer_type_qualifier,
            recend,
          recend,
        recend,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
      recend,
      type8: 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 .. 12] of clt$keyword_specification,
          recend,
        recend,
        default_value: string (14),
      recend,
      type9: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [97, 1, 21, 15, 12, 16, 92],
    clc$command, 17, 9, 0, 2, 0, 0, 9, 'OSM$SETBO'], [
    ['BACKUP_FILE_VERSION            ',clc$nominal_entry, 5],
    ['BFV                            ',clc$abbreviation_entry, 5],
    ['ECI                            ',clc$abbreviation_entry, 1],
    ['ESBO                           ',clc$abbreviation_entry, 6],
    ['EXCLUDE_CATALOG_INFORMATION    ',clc$nominal_entry, 1],
    ['EXCLUDE_SITE_BACKUP_OPTION     ',clc$nominal_entry, 6],
    ['IAI                            ',clc$abbreviation_entry, 3],
    ['ID                             ',clc$abbreviation_entry, 4],
    ['IEC                            ',clc$abbreviation_entry, 7],
    ['INCLUDE_ARCHIVE_INFORMATION    ',clc$nominal_entry, 3],
    ['INCLUDE_DATA                   ',clc$nominal_entry, 4],
    ['INCLUDE_EXCEPTION_CONDITIONS   ',clc$nominal_entry, 7],
    ['NBFO                           ',clc$abbreviation_entry, 2],
    ['NULL_BACKUP_FILE_OPTION        ',clc$nominal_entry, 2],
    ['SHARE_MODES                    ',clc$nominal_entry, 8],
    ['SM                             ',clc$abbreviation_entry, 8],
    ['STATUS                         ',clc$nominal_entry, 9]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 2
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 309,
  clc$optional_default_parameter, 0, 36],
{ PARAMETER 5
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 6
    [6, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 144,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81, clc$optional_parameter,
  0, 0],
{ PARAMETER 8
    [15, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 531,
  clc$optional_default_parameter, 0, 14],
{ PARAMETER 9
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [2], [
    ['RD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['READ_DATA                      ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 3
    [[1, 0, clc$boolean_type]],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    245, [[1, 0, clc$list_type], [229, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [6], [
        ['OD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['OFFLINE_DATA                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['RD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['RELEASABLE_DATA                ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['UD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['UNRELEASABLE_DATA              ', clc$nominal_entry, clc$normal_usage_entry, 3]]
        ]
      ],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    '(releasable_data, unreleasable_data)'],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [1, 2, 10],
    '2'],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    43, [[1, 0, clc$list_type], [27, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$range_type], [20],
          [[1, 0, clc$integer_type], [0, 255, 10]]
        ]
      ]
    ],
{ PARAMETER 7
    [[1, 0, clc$keyword_type], [2], [
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 8
    [[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]]
      ],
    467, [[1, 0, clc$list_type], [451, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [12], [
        ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['APPEND                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['EXECUTE                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['MODIFY                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['READ                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['SHORTEN                        ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['WRITE                          ', clc$nominal_entry, clc$normal_usage_entry, 6]]
        ]
      ]
    ,
    '(execute read)'],
{ PARAMETER 9
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$exclude_catalog_information = 1,
      p$null_backup_file_option = 2,
      p$include_archive_information = 3,
      p$include_data = 4,
      p$backup_file_version = 5,
      p$exclude_site_backup_option = 6,
      p$include_exception_conditions = 7,
      p$share_modes = 8,
      p$status = 9;

    VAR
      pvt: array [1 .. 9] of clt$parameter_value;

    VAR
      exclude_site_backup_option: ^clt$data_value,
      high: integer,
      ignore_status: ost$status,
      include_data_option: ^clt$data_value,
      include_site_backup_option: ^clt$data_value,
      invalid_subrange: ost$string,
      local_status: ost$status,
      local_usage_share_value: ^clt$data_value,
      low: integer,
      option: integer,
      option_string: ost$string,
      s: ost$string,
      share_mode_value: clt$keyword,
      usage_share_selections: pft$usage_selections;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$display_line (' Set_Backup_Options', ignore_status);
    pup$display_blank_lines (1, ignore_status);

    IF pvt [p$backup_file_version].value^.integer_value.value = 1 THEN
      puv$bacpf_backup_file_version := puc$backup_file_version_1;
    ELSEIF pvt [p$backup_file_version].value^.integer_value.value = 2 THEN
      puv$bacpf_backup_file_version := puc$backup_file_version_2;
    IFEND;
    s.value (1, 25) := '   Backup_File_Version = ';
    s.size := 25;
    s.value (s.size + 1, 31) := puv$bacpf_backup_file_version;
    s.size := s.size + 31;
    pup$display_line (s.value (1, s.size), ignore_status);

    IF pvt [p$exclude_catalog_information ].specified THEN
      puv$exclude_catalog_information := pvt [p$exclude_catalog_information ].value^.boolean_value.value;
      s.value (1, 33) := '   Exclude_Catalog_Information = ';
      s.size := 33;
      IF puv$exclude_catalog_information THEN
        s.value (s.size + 1, 4) := 'True';
        s.size := s.size + 4;
      ELSE
        s.value (s.size + 1, 5) := 'False';
        s.size := s.size + 5;
      IFEND;
      pup$display_line (s.value (1, s.size), ignore_status);
    IFEND;

    IF pvt [p$exclude_site_backup_option].specified THEN
      exclude_site_backup_option := pvt [p$exclude_site_backup_option].value;
      s.value := '   Exclude_Site_Backup_Option = ';
      s.size := 32;
      IF exclude_site_backup_option^.keyword_value = 'NONE' THEN
        puv$exclude_site_backup_options := $put$exclude_site_backup_options [];
        s.value (s.size + 1, 4) := 'None';
        s.size := s.size + 4;
      ELSEIF exclude_site_backup_option^.keyword_value = 'ALL' THEN
        puv$exclude_site_backup_options := -$put$exclude_site_backup_options [];
        s.value (s.size + 1, 3) := 'All';
        s.size := s.size + 3;
      ELSE
        s.value (s.size + 1, 1) := '(';
        s.size := s.size + 1;
        WHILE exclude_site_backup_option <> NIL DO
          low := exclude_site_backup_option^.element_value^.low_value^.integer_value.value;
          high := exclude_site_backup_option^.element_value^.high_value^.integer_value.value;
          IF low > high THEN
            clp$convert_integer_to_string (low, {radix} 10, {include_radix} FALSE, option_string,
                  local_status);
            IF local_status.normal THEN
              invalid_subrange.value (1, option_string.size) := option_string.value (1, option_string.size);
              invalid_subrange.size := option_string.size;
              invalid_subrange.value (invalid_subrange.size + 1, 2) := '..';
              invalid_subrange.size := invalid_subrange.size + 2;
              clp$convert_integer_to_string (high, {radix} 10, {include_radix} FALSE, option_string,
                    local_status);
              IF local_status.normal THEN
                invalid_subrange.value (invalid_subrange.size + 1, option_string.size) :=
                      option_string.value (1, option_string.size);
                invalid_subrange.size := invalid_subrange.size + option_string.size;
                osp$set_status_abnormal (puc$pf_utility_id, pue$bad_integer_subrange,
                      invalid_subrange.value (1, invalid_subrange.size), status);
                RETURN;
              IFEND;
            IFEND;
          IFEND;
          clp$convert_integer_to_string (low, {radix} 10, {include_radix} FALSE, option_string,
                local_status);
          IF local_status.normal THEN
            s.value (s.size + 1, option_string.size) :=
                  option_string.value (1, option_string.size);
            s.size := s.size + option_string.size;
          IFEND;
          IF low <> high THEN
            s.value (s.size + 1, 2) := '..';
            s.size := s.size + 2;
            clp$convert_integer_to_string (high, {radix} 10, {include_radix} FALSE, option_string,
                  local_status);
            IF local_status.normal THEN
              s.value (s.size + 1, option_string.size) :=
                    option_string.value (1, option_string.size);
              s.size := s.size + option_string.size;
            IFEND;
          IFEND;
          s.value (s.size + 1, 1) := ' ';
          s.size := s.size + 1;
          FOR option := low TO high DO
            puv$exclude_site_backup_options := puv$exclude_site_backup_options +
                  $put$exclude_site_backup_options [option];
          FOREND;
          exclude_site_backup_option := exclude_site_backup_option^.link;
        WHILEND;
        s.value (s.size, 1) := ')';
      IFEND;
      pup$display_line (s.value (1, s.size), ignore_status);
    IFEND;

    IF pvt [p$include_archive_information].specified THEN
      IF pvt [p$include_archive_information].value^.boolean_value.value AND
            NOT (avp$family_administrator () OR avp$system_administrator ())  THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$user_set_iai_true, '', status);
        RETURN;
      ELSE
        puv$include_archive_information := pvt [p$include_archive_information].value^.boolean_value.value;
        s.value (1, 33) := '   Include_Archive_Information = ';
        s.size := 33;
        IF puv$include_archive_information THEN
          s.value (s.size + 1, 4) := 'True';
          s.size := s.size + 4;
        ELSE
          s.value (s.size + 1, 5) := 'False';
          s.size := s.size + 5;
        IFEND;
        pup$display_line (s.value (1, s.size), ignore_status);
      IFEND;
    ELSE
      puv$include_archive_information := avp$family_administrator () OR avp$system_administrator ();
      s.value (1, 47) := '   Include_Archive_Information (Unspecified) = ';
      s.size := 47;
      IF puv$include_archive_information THEN
        s.value (s.size + 1, 4) := 'True';
        s.size := s.size + 4;
      ELSE
        s.value (s.size + 1, 5) := 'False';
        s.size := s.size + 5;
      IFEND;
      pup$display_line (s.value (1, s.size), ignore_status);
    IFEND;

    include_data_option := pvt [p$include_data].value;
    puv$include_data_options := $put$include_data_options [];
    s.value := '   Include_Data = ';
    s.size := 18;
    IF include_data_option^.kind = clc$keyword THEN  { Checks for the keyword ALL. }
      IF NOT pup$all_volumes_included () THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$incv_and_offline_conflict, '', status);
        RETURN;
      ELSE
        puv$include_data_options := - $put$include_data_options [];
        s.value (s.size + 1, 4) := 'All ';
        s.size := s.size + 4;
      IFEND;
    ELSE
      s.value (s.size + 1, 1) := '(';
      s.size := s.size + 1;
      WHILE include_data_option <> NIL DO
        IF include_data_option^.element_value^.keyword_value = 'OFFLINE_DATA' THEN
          IF NOT pup$all_volumes_included () THEN
            osp$set_status_abnormal (puc$pf_utility_id, pue$incv_and_offline_conflict, '', status);
            RETURN;
          ELSE
            s.value (s.size + 1, 13) := 'Offline_Data ';
            s.size := s.size + 13;
            puv$include_data_options := puv$include_data_options +
                  $put$include_data_options [puc$include_offline_data];
          IFEND;
        ELSEIF include_data_option^.element_value^.keyword_value = 'RELEASABLE_DATA' THEN
          s.value (s.size + 1, 16) := 'Releasable_Data ';
          s.size := s.size + 16;
          puv$include_data_options := puv$include_data_options
                + $put$include_data_options [puc$include_releasable_data];
        ELSEIF include_data_option^.element_value^.keyword_value = 'UNRELEASABLE_DATA' THEN
          s.value (s.size + 1, 18) := 'Unreleasable_Data ';
          s.size := s.size + 18;
          puv$include_data_options := puv$include_data_options
                + $put$include_data_options [puc$include_unreleasable_data];
        IFEND;
        include_data_option := include_data_option^.link;
      WHILEND;
      s.value (s.size, 1) := ')';
    IFEND;
    pup$display_line (s.value (1, s.size), ignore_status);

    IF pvt [p$include_exception_conditions].specified THEN
      s.value := '   Include_Exception_Conditions =  ';
      s.size := 35;
      IF pvt [p$include_exception_conditions].value^.keyword_value = 'ALL' THEN
        puv$include_exceptions := TRUE;
        s.value (s.size + 1, 3) := 'All';
        s.size := s.size + 3;
      ELSE { include_exception_conditions = 'NONE'}
        IF (puv$backup_file_id.device_class <> rmc$null_device) THEN
          osp$set_status_abnormal (puc$pf_utility_id, pue$cannot_specify_none_for_iec,
                '$NULL is not specified for the BACKUP_FILE parameter', status);
          RETURN;
        ELSEIF (puv$backup_file_id.device_class = rmc$null_device) AND
                puv$read_data_on_null_bf THEN
          osp$set_status_abnormal (puc$pf_utility_id, pue$cannot_specify_none_for_iec,
                'READ_DATA is specified for the NULL_BACKUP_FILE_OPTION parameter', status);
          RETURN;
        ELSE
          puv$include_exceptions := FALSE;
          s.value (s.size + 1, 4) := 'None';
          s.size := s.size + 4;
        IFEND;
      IFEND;
      pup$display_line (s.value (1, s.size), ignore_status);
    IFEND;

    IF pvt [p$null_backup_file_option].specified THEN
      IF puv$backup_file_id.device_class = rmc$null_device THEN
        s.value := '   Null_Backup_File_Option = ';
        s.size := 29;
        IF pvt [p$null_backup_file_option].value^.keyword_value = 'READ_DATA' THEN
          puv$read_data_on_null_bf := TRUE;
          s.value (s.size + 1, 27) := 'Reading Data on Null Backup';
          s.size := s.size + 27;
        ELSE
          puv$read_data_on_null_bf := FALSE;
          s.value (s.size + 1, 31) := 'Not Reading Data on Null Backup';
          s.size := s.size + 31;
        IFEND;
        pup$display_line (s.value (1, s.size), ignore_status);
      ELSE
        osp$set_status_abnormal (puc$pf_utility_id, pue$null_backup_file_required, '', status);
        RETURN;
      IFEND;
    IFEND;

    s.value := '   Share_Modes = ';
    s.size := 17;
    local_usage_share_value := pvt [p$share_modes].value;
    IF local_usage_share_value^.kind = clc$keyword THEN
      usage_share_selections := - $pft$usage_selections [];
      s.value (s.size + 1, 3) := 'All ';
      s.size := s.size + 3;
    ELSE
      usage_share_selections := $pft$usage_selections [];
      s.value (s.size + 1, 1) := '(';
      s.size := s.size + 1;
      WHILE local_usage_share_value <> NIL DO
        share_mode_value := local_usage_share_value^.element_value^.keyword_value;
        IF share_mode_value = 'APPEND' THEN
          usage_share_selections := usage_share_selections + $pft$usage_selections [pfc$append];
          s.value (s.size + 1, 7) := 'Append ';
          s.size := s.size + 7;
        ELSEIF share_mode_value = 'EXECUTE' THEN
          usage_share_selections := usage_share_selections + $pft$usage_selections [pfc$execute];
          s.value (s.size + 1, 8) := 'Execute ';
          s.size := s.size + 8;
        ELSEIF share_mode_value = 'MODIFY' THEN
          usage_share_selections := usage_share_selections + $pft$usage_selections [pfc$modify];
          s.value (s.size + 1, 7) := 'Modify ';
          s.size := s.size + 7;
        ELSEIF share_mode_value = 'READ' THEN
          usage_share_selections := usage_share_selections + $pft$usage_selections [pfc$read];
          s.value (s.size + 1, 5) := 'Read ';
          s.size := s.size + 5;
        ELSEIF share_mode_value = 'SHORTEN' THEN
          usage_share_selections := usage_share_selections + $pft$usage_selections [pfc$shorten];
          s.value (s.size + 1, 8) := 'Shorten ';
          s.size := s.size + 8;
        ELSEIF share_mode_value = 'WRITE' THEN
          usage_share_selections := usage_share_selections +
                $pft$usage_selections[pfc$append, pfc$modify, pfc$shorten];
          s.value (s.size + 1, 6) := 'Write ';
          s.size := s.size + 6;
        IFEND;
         local_usage_share_value := local_usage_share_value^.link;
      WHILEND;
      s.value (s.size, 1) := ')';
    IFEND;
    puv$backup_share_modes := usage_share_selections;
    pup$display_line (s.value (1, s.size), ignore_status);
    pup$display_blank_lines (1, ignore_status);

  PROCEND set_backup_options_subcommand;

MODEND pum$backup_permanent_file;
*DECK DECK=PUM$BACKUP_SET EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  backup_set ', EJECT ??
MODULE pum$backup_set;


{PURPOSE:
{     this module contains the procedures which produce a BACKUP copy
{  of a specified set as well as a BACKUP copy of each family,
{  catalog,file, and cycle registered in the set.
?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc clp$get_value
*copyc clp$scan_command_line
*copyc clp$scan_parameter_list
*copyc clt$file
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc ost$status
*copyc ost$string
*copyc ost$user_identification
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfp$find_direct_info_record
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_family_item_info
*copyc pfp$get_family_info
*copyc pfp$get_family_set
*copyc pfp$get_master_catalog_info
*copyc pfp$get_set_list
*copyc pud$backup_file
*copyc pud$hierarchy_list
*copyc pup$abort_output
*copyc pup$backup_catalog
*copyc pup$build_catalog_header
*copyc pup$build_entry
*copyc pup$build_hierarchy_list
*copyc pup$build_new_catalog_header
*copyc pup$check_if_item_excluded
*copyc pup$crack_boolean
*copyc pup$crack_user_range_list
*copyc pup$display_backup_output_total
*copyc pup$display_blank_lines
*copyc pup$display_excluded_item
*copyc pup$display_line
*copyc pup$get_status_severity
*copyc pup$get_summary_status
*copyc pup$initialize_backup_listing
*copyc pup$output_family
*copyc pup$output_set
*copyc pup$sort_directory
*copyc pup$verify_catalog_path
*copyc pup$verify_family_administrator
*copyc pup$verify_system_administrator
*copyc pup$write_catalog_header
*copyc pup$write_os_status
*copyc pup$write_path
*copyc pup$write_status_to_listing
*copyc put$file_identifier
*copyc put$user_range_list
*copyc puv$backup_information
*copyc puv$backup_file_id
*copyc puv$global_backup_file_id
*copyc std$set_name
?? POP ??
?? TITLE := '    Global Variables', EJECT ??

  VAR
    user_range_list_container: [STATIC] put$user_range_list_container,

    puv$p_user_range_list: [XDCL] ^put$user_range_list := NIL;

  VAR
    puv$sort_users: [XDCL] boolean := FALSE;



?? TITLE := '    [XDCL] pup$backup_all_files_command ', EJECT ??

  PROCEDURE [XDCL] pup$backup_all_files_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{  pdt backup_all_files_pdt (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      backup_all_files_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^backup_all_files_pdt_names, ^backup_all_files_pdt_params];

    VAR
      backup_all_files_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
        clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      backup_all_files_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
        clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      local_status: ost$status;

    pup$verify_system_administrator ('BACKUP_ALL_FILES               ', puv$p_user_range_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, backup_all_files_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$display_line (' BACKUP ALL FILES: ', status);
    pup$backup_all_files_request (puv$backup_file_id, status);
  PROCEND pup$backup_all_files_command;

?? TITLE := '    [XDCL] pup$backup_set_command ', EJECT ??

  PROCEDURE [XDCL] pup$backup_set_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{   pdt backup_set_pdt (set_name, sn: name 1 .. 31 = $required
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    backup_set_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^backup_set_pdt_names,
      ^backup_set_pdt_params];

  VAR
    backup_set_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['SET_NAME', 1], ['SN', 1], ['STATUS', 2]];

  VAR
    backup_set_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ SET_NAME SN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, 31]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      dummy_cycle_selector: pft$cycle_selector,
      local_status: ost$status,
      p_hierarchy_list: ^put$hierarchy_list,
      set_entry: put$entry,
      set_name: stt$set_name,
      str: string (80),
      strl: integer,
      value: clt$value;

    pup$verify_system_administrator ('BACKUP_SET                     ', puv$p_user_range_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, backup_set_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('SET_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    set_name := value.name.value;

    pup$build_entry (set_name, dummy_cycle_selector, puc$valid_set_entry, set_entry);
    PUSH p_hierarchy_list: [1 .. 1];
    pup$build_catalog_header (set_name, NIL, p_hierarchy_list^.catalog_header);
    pup$build_hierarchy_list (set_entry, p_hierarchy_list^.catalog_header, p_hierarchy_list^, status);
    IF status.normal THEN
      pup$initialize_backup_listing (p_hierarchy_list^, puv$backup_file_id,
            puv$backup_information, status);
      STRINGREP (str, strl, ' BACKUP SET: ', set_name);
      pup$display_line (str (1, strl), status);
      pup$backup_set_request (set_entry, p_hierarchy_list, puv$backup_file_id, status);
      pup$display_backup_output_total;
      pup$get_summary_status (status);
      pup$write_os_status (status, local_status);
    IFEND;

  PROCEND pup$backup_set_command;

?? TITLE := '    pup$backup_all_files_request ', EJECT ??

  PROCEDURE pup$backup_all_files_request (VAR backup_file_id: put$file_identifier;
    VAR status: ost$status);

    VAR
      cset: stt$number_of_sets,
      dummy_cycle_selector: pft$cycle_selector,
      local_status: ost$status,
      number_of_sets: stt$number_of_sets,
      p_hierarchy_list: ^put$hierarchy_list,
      set_entry: put$entry,
      set_list: ^stt$set_list,
      set_name: stt$set_name,
      str: string (80),
      strl: integer;

    number_of_sets := 20;
    FOR cset := 1 TO 2 DO
      PUSH set_list: [1 .. number_of_sets];
      pfp$get_set_list (set_list^, number_of_sets, status);
    FOREND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    set_name := set_list^ [1];
    pup$build_entry (set_name, dummy_cycle_selector, puc$valid_set_entry, set_entry);
    PUSH p_hierarchy_list: [1 .. 1];
    pup$build_catalog_header (set_name, NIL, p_hierarchy_list^.catalog_header);
    pup$build_hierarchy_list (set_entry, p_hierarchy_list^.catalog_header, p_hierarchy_list^, status);
    IF status.normal THEN
      pup$initialize_backup_listing (p_hierarchy_list^, puv$backup_file_id,
            puv$backup_information, status);
      FOR cset := 1 TO number_of_sets DO
        STRINGREP (str, strl, ' BACKUP SET: ', set_list^ [cset]);
        pup$display_line (str (1, strl), status);
        set_name := set_list^ [cset];
        pup$build_entry (set_name, dummy_cycle_selector, puc$valid_set_entry, set_entry);
        pup$build_catalog_header (set_name, NIL, p_hierarchy_list^.catalog_header);
        pup$build_hierarchy_list (set_entry, p_hierarchy_list^.catalog_header, p_hierarchy_list^, status);
        pup$backup_set_request (set_entry, p_hierarchy_list, backup_file_id, status);
      FOREND;
      pup$display_backup_output_total;
      pup$get_summary_status (status);
      pup$write_os_status (status, local_status);
    IFEND;

  PROCEND pup$backup_all_files_request;

?? TITLE := '    pup$backup_family ', EJECT ??

  PROCEDURE pup$backup_family (family_entry: put$entry;
        pf_utility_catalog_header: put$catalog_header;
        pf_utility_hierarchy_list: put$hierarchy_list;
    VAR pf_backup_file_id: put$file_identifier;
    VAR family_item_info: pft$p_info_record;
    VAR family_content_info: pft$p_info_record;
    VAR status: ost$status);

    VAR
      backup_item_info: put$backup_item_info,
      catalog_entry: put$entry,
      cycle_selector: pft$cycle_selector,
      i: put$half_integer,
      local_status: ost$status,
      p_body: pft$p_info,
      p_item_record: pft$p_info_record,
      p_master_catalog_directory: pft$p_directory_array,
      p_new_catalog_header: ^put$catalog_header,
      status_severity: put$status_severity,
      user_excluded: boolean,
      user_in_range: boolean;

    pup$display_blank_lines (5, status);
    pup$write_catalog_header (pf_utility_catalog_header, status);
    backup_item_info.item_type := puc$backup_item_family_info;
    backup_item_info.family_item_info := family_item_info;
    pup$output_family (family_entry, pf_utility_catalog_header, backup_item_info, pf_utility_hierarchy_list,
          pf_backup_file_id, status);
    IF NOT status.normal THEN
      pup$abort_output (family_entry, pf_backup_file_id, status, local_status);
      RETURN;
    IFEND;
    pfp$find_directory_array (family_content_info, p_master_catalog_directory, status);
    IF status.normal AND (p_master_catalog_directory <> NIL) THEN
      IF puv$sort_users THEN
        pup$sort_directory (p_master_catalog_directory^, p_master_catalog_directory^);
      IFEND;
      PUSH p_new_catalog_header: [LOWERBOUND (pf_utility_catalog_header.path) .. (UPPERBOUND
            (pf_utility_catalog_header.path) + 1)];
      FOR i := LOWERBOUND (p_master_catalog_directory^) TO UPPERBOUND (p_master_catalog_directory^) DO
        pup$check_if_user_in_range (family_entry.family_name, p_master_catalog_directory^ [i].name,
              user_in_range);
        IF user_in_range THEN
          pup$build_entry (p_master_catalog_directory^ [i].name, cycle_selector, puc$valid_catalog_entry,
                catalog_entry);
          pup$build_new_catalog_header (catalog_entry, pf_utility_catalog_header, p_new_catalog_header^);
          pup$check_if_item_excluded (catalog_entry, p_new_catalog_header^, user_excluded);
          IF user_excluded THEN
            pup$display_excluded_item (catalog_entry, p_new_catalog_header^, status);
          ELSE
            p_body := ^family_content_info^.body;
            pfp$find_direct_info_record (p_body, p_master_catalog_directory^ [i].info_offset, p_item_record,
                  status);
            IF status.normal THEN
              pup$backup_catalog (catalog_entry, p_new_catalog_header^, p_item_record,
                    pf_utility_hierarchy_list, pf_backup_file_id, status);
            IFEND;
            pup$write_status_to_listing (catalog_entry, status, local_status);
            IF NOT puv$global_backup_file_id.backup_file_open THEN
              {
              { pup$backup_catalog encountered an error writing to the backup_file and closed it.
              { Return the abnormal status to the caller.
              {
              RETURN;
            IFEND;
            status.normal := TRUE;
          IFEND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND pup$backup_family;

?? TITLE := '    pup$backup_family_request', EJECT ??

  PROCEDURE [XDCL] pup$backup_family_request
    (    set_name: stt$set_name;
         family_name: pft$name;
     VAR pf_backup_file_id: put$file_identifier;
     VAR status: ost$status);


    VAR
      backup_item_info: put$backup_item_info,
      dummy_cycle_selector: pft$cycle_selector,
      family_entry: put$entry,
      family_info: amt$segment_pointer,
      family_path: array [1 .. 1] of pft$name,
      local_set_name: stt$set_name,
      local_status: ost$status,
      master_catalog_info: amt$segment_pointer,
      p_body: pft$p_info,
      p_family_content: pft$p_info_record,
      p_family_directory: pft$p_directory_array,
      p_family_info: pft$p_info_record,
      p_hierarchy_list: ^put$hierarchy_list,
      p_info_record: pft$p_info_record;

    status.normal := TRUE;
    local_status.normal := TRUE;
    pup$build_entry (family_name, dummy_cycle_selector, puc$valid_family_entry, family_entry);
    family_path [1] := family_name;
    PUSH p_hierarchy_list: [1 .. 1];
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, family_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET family_info.sequence_pointer;
    pfp$get_family_item_info (family_name,  -$pft$catalog_info_selections [],
          local_set_name, family_info.sequence_pointer, status);
    IF status.normal THEN
      pup$build_catalog_header (local_set_name, ^family_path, p_hierarchy_list^.catalog_header);
      pup$build_hierarchy_list (family_entry, p_hierarchy_list^.catalog_header, p_hierarchy_list^, status);
      IF status.normal THEN
        RESET family_info.sequence_pointer;
        pfp$find_next_info_record (family_info.sequence_pointer, p_info_record, status);
        IF status.normal THEN
          pup$initialize_backup_listing (p_hierarchy_list^, pf_backup_file_id, puv$backup_information,
                status);
          IF status.normal THEN
            pfp$find_directory_array (p_info_record, p_family_directory, status);
            p_body := ^p_info_record^.body;
            IF status.normal AND (p_family_directory <> NIL) THEN
              pfp$find_direct_info_record (p_body, p_family_directory^ [1].info_offset, p_family_info,
                    status);
              IF status.normal THEN
                mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, master_catalog_info,
                      status);
              IFEND;
              IF status.normal THEN
                RESET master_catalog_info.sequence_pointer;
                pfp$get_master_catalog_info (local_set_name, family_name, -$pft$catalog_info_selections [],
                      master_catalog_info.sequence_pointer, status);
                IF status.normal THEN
                  RESET master_catalog_info.sequence_pointer;
                  pfp$find_next_info_record (master_catalog_info.sequence_pointer, p_family_content, status);
                  IF status.normal THEN
                    pup$backup_family (family_entry, p_hierarchy_list^.catalog_header, p_hierarchy_list^,
                          pf_backup_file_id, p_family_info, p_family_content, status);
                  IFEND;
                IFEND;
                mmp$delete_scratch_segment (master_catalog_info, local_status);
              IFEND;
            IFEND;
            pup$display_backup_output_total;
            pup$get_summary_status (status);
            pup$write_os_status (status, local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    mmp$delete_scratch_segment (family_info, local_status);
  PROCEND pup$backup_family_request;
?? TITLE := '    pup$backup_set ', EJECT ??

  PROCEDURE pup$backup_set (set_entry: put$entry;
        pf_utility_catalog_header: put$catalog_header;
        pf_utility_hierarchy_list: put$hierarchy_list;
    VAR pf_backup_file_id: put$file_identifier;
    VAR set_item_info: pft$p_info_record;
    VAR status: ost$status);

    VAR
      backup_item_info: put$backup_item_info,
      cycle_selector: pft$cycle_selector,
      family_entry: put$entry,
      family_excluded: boolean,
      family_in_range: boolean,
      i: put$half_integer,
      local_status: ost$status,
      master_catalog_info: amt$segment_pointer,
      p_body: pft$p_info,
      p_family_content: pft$p_info_record,
      p_family_directory: pft$p_directory_array,
      p_family_info: pft$p_info_record,
      p_new_catalog_header: ^put$catalog_header,
      set_name: stt$set_name,
      status_severity: put$status_severity;

    backup_item_info.item_type := puc$backup_item_set_info;
    backup_item_info.set_item_info := set_item_info;
    pup$output_set (set_entry, pf_utility_catalog_header, backup_item_info, pf_utility_hierarchy_list,
          pf_backup_file_id, status);
    IF NOT status.normal THEN
      pup$abort_output (set_entry, pf_backup_file_id, status, local_status);
      RETURN;
    IFEND;
    pfp$find_directory_array (set_item_info, p_family_directory, status);
    IF status.normal AND (p_family_directory <> NIL) THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, master_catalog_info, status);
      IF status.normal THEN
        PUSH p_new_catalog_header: [LOWERBOUND (pf_utility_catalog_header.path) .. UPPERBOUND
              (pf_utility_catalog_header.path)];

        p_body := ^set_item_info^.body;

      /loop_through_families/
        FOR i := LOWERBOUND (p_family_directory^) TO UPPERBOUND (p_family_directory^) DO
          pfp$get_family_set (p_family_directory^ [i].name, set_name, status);
          IF set_name <> set_entry.set_name THEN
            CYCLE /loop_through_families/;
          IFEND;
          pup$check_if_family_in_range (p_family_directory^ [i].name, family_in_range);
          IF family_in_range THEN
            pup$build_entry (p_family_directory^ [i].name, cycle_selector, puc$valid_family_entry,
                  family_entry);
            pup$build_new_catalog_header (family_entry, pf_utility_catalog_header, p_new_catalog_header^);
            pup$check_if_item_excluded (family_entry, p_new_catalog_header^, family_excluded);
            IF family_excluded THEN
              pup$display_excluded_item (family_entry, p_new_catalog_header^, status);
            ELSE
              pfp$find_direct_info_record (p_body, p_family_directory^ [i].info_offset, p_family_info,
                    status);
              IF status.normal THEN
                RESET master_catalog_info.sequence_pointer;
                pfp$get_master_catalog_info (set_entry.set_name, p_family_directory^ [i].name, -
                      $pft$catalog_info_selections [], master_catalog_info.sequence_pointer, status);
              IFEND;
              IF status.normal THEN
                RESET master_catalog_info.sequence_pointer;
                pfp$find_next_info_record (master_catalog_info.sequence_pointer, p_family_content, status);
                IF status.normal THEN
                  pup$backup_family (family_entry, p_new_catalog_header^, pf_utility_hierarchy_list,
                        pf_backup_file_id, p_family_info, p_family_content, status);
                IFEND;
              IFEND;
              pup$write_status_to_listing (family_entry, status, local_status);
              IF NOT puv$global_backup_file_id.backup_file_open THEN
                {
                { pup$backup_catalog encountered an error writing to the backup_file and closed it.
                { Return the abnormal status to the caller.
                {
                EXIT /loop_through_families/;
              IFEND;
              status.normal := TRUE;
            IFEND;
          IFEND;
        FOREND /loop_through_families/;
        mmp$delete_scratch_segment (master_catalog_info, local_status);
      IFEND;
    IFEND;
  PROCEND pup$backup_set;

?? TITLE := '    pup$backup_set_request ', EJECT ??

  PROCEDURE pup$backup_set_request (set_entry: put$entry;
        p_hierarchy_list: ^put$hierarchy_list;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);


    VAR
      family_info: amt$segment_pointer,
      local_status: ost$status,
      p_info_record: pft$p_info_record;

    status.normal := TRUE;
    local_status.normal := TRUE;
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, family_info, status);
      IF status.normal THEN
        RESET family_info.sequence_pointer;
        pfp$get_family_info (set_entry.set_name, - $pft$catalog_info_selections [], family_info.
              sequence_pointer, status);
        IF status.normal THEN
          RESET family_info.sequence_pointer;
          pfp$find_next_info_record (family_info.sequence_pointer, p_info_record, status);
          IF status.normal THEN
            IF status.normal THEN
              pup$backup_set (set_entry, p_hierarchy_list^.catalog_header, p_hierarchy_list^,
                    pf_backup_file_id, p_info_record, status);
            IFEND;
          IFEND;
        IFEND;
        mmp$delete_scratch_segment (family_info, local_status);
      IFEND;
  PROCEND pup$backup_set_request;

?? TITLE := '    [XDCL] pup$check_if_family_in_range ', EJECT ??

  PROCEDURE [XDCL] pup$check_if_family_in_range (family_name: pft$name;
    VAR family_in_range: boolean);

    VAR
      user_range_index: integer;

    family_in_range := FALSE;
    IF puv$p_user_range_list = NIL THEN
      family_in_range := TRUE;
    ELSE
      FOR user_range_index := 1 TO UPPERBOUND (puv$p_user_range_list^) DO
        IF (family_name >= puv$p_user_range_list^ [user_range_index] [clc$low] [pfc$family_name_index]) AND
              (family_name <= puv$p_user_range_list^ [user_range_index] [clc$high] [pfc$family_name_index])
              THEN
          family_in_range := TRUE;
          RETURN;
        IFEND;
      FOREND;
    IFEND;
  PROCEND pup$check_if_family_in_range;

?? TITLE := '    [XDCL] pup$check_if_user_in_range ', EJECT ??

  PROCEDURE [XDCL] pup$check_if_user_in_range (family_name: pft$name;
        user_name: pft$name;
    VAR user_in_range: boolean);

    VAR
      user_range_index: integer;

    user_in_range := FALSE;
    IF puv$p_user_range_list = NIL THEN
      user_in_range := TRUE;
    ELSE
      FOR user_range_index := 1 TO UPPERBOUND (puv$p_user_range_list^) DO
        IF (family_name >= puv$p_user_range_list^ [user_range_index] [clc$low] [pfc$family_name_index]) AND
              (family_name <= puv$p_user_range_list^ [user_range_index] [clc$high] [pfc$family_name_index])
              THEN
          IF (user_name >= puv$p_user_range_list^ [user_range_index] [clc$low]
                [pfc$master_catalog_name_index]) AND (user_name <= puv$p_user_range_list^ [user_range_index]
                [clc$high] [pfc$master_catalog_name_index]) THEN
            user_in_range := TRUE;
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND pup$check_if_user_in_range;

?? TITLE := '    [XDCL] pup$display_all_users_command ', EJECT ??

  PROCEDURE [XDCL] pup$display_all_users_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);


?? RIGHT := 110 ??
{ pdt display_all_users_pdt(
{  resolve_users, ru: boolean = true
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_all_users_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^display_all_users_pdt_names, ^display_all_users_pdt_params];

    VAR
      display_all_users_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['RESOLVE_USERS', 1], ['RU', 1], ['STATUS', 2]];

    VAR
      display_all_users_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
        clt$parameter_descriptor := [

{ RESOLVE_USERS RU }
      [[clc$optional_with_default, ^display_all_users_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$boolean_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      display_all_users_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

?? POP ??

    VAR
      set_list: ^stt$set_list,
      cset,
      number_of_sets: stt$number_of_sets,
      resolve_users: boolean;

    pup$verify_system_administrator ('DISPLAY_ALL_USERS              ', puv$p_user_range_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, display_all_users_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_boolean ('RESOLVE_USERS', resolve_users, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF resolve_users THEN

      number_of_sets := 20;
      FOR cset := 1 TO 2 DO
        PUSH set_list: [1 .. number_of_sets];
        pfp$get_set_list (set_list^, number_of_sets, status);
      FOREND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      FOR cset := 1 TO number_of_sets DO
        pup$display_set_request (set_list^ [cset], puv$sort_users, status);
      FOREND;
    ELSE
      display_user_range_list (status);
    IFEND;
  PROCEND pup$display_all_users_command;

?? TITLE := '    [XDCL] pup$display_directives ', EJECT ??

  PROCEDURE [XDCL] pup$display_directives (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT display_directives_pdt (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_directives_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^display_directives_pdt_names, ^display_directives_pdt_params];

    VAR
      display_directives_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
        clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      display_directives_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
        clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??clp$scan_parameter_list (parameter_list, display_directives_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_command_line (' DISPLAY_ALL_USERS FALSE', status);
    pup$write_os_status (status, status);

    IF puv$sort_users THEN
      pup$display_line (' SORTING USERS ON BACKUP', status);
    ELSE
      pup$display_line (' NOT sorting users ', status);
    IFEND;

    clp$scan_command_line (' DISPLAY_EXCLUDED_ITEMS ', status);
    pup$write_os_status (status, status);

    clp$scan_command_line (' DISPLAY_EXCLUDE_HIGHEST_CYCLES', status);
    pup$write_os_status (status, status);

    clp$scan_command_line (' DISPLAY_INCLUDED_CYCLES', status);
    pup$write_os_status (status, status);

    clp$scan_command_line (' DISPLAY_INCLUDE_EMPTY_CATALOGS ', status);
    pup$write_os_status (status, status);

    clp$scan_command_line (' DISPLAY_INCLUDED_VOLUMES', status);
    pup$write_os_status (status, status);

    clp$scan_command_line (' DISPLAY_LIST_OPTIONS', status);
    pup$write_os_status (status, status);
  PROCEND pup$display_directives;

?? TITLE := '    [XDCL] pup$display_set_request ', EJECT ??

  PROCEDURE [XDCL] pup$display_set_request (set_name: stt$set_name;
        sort_users: boolean;
    VAR status: ost$status);

    VAR
      family_in_range: boolean,
      family_info: amt$segment_pointer,
      i: put$half_integer,
      local_status: ost$status,
      p_family_directory: pft$p_directory_array,
      p_info_record: pft$p_info_record,
      p_sorted_directory: pft$p_directory_array;

    status.normal := TRUE;
    local_status.normal := TRUE;
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, family_info, status);
    IF status.normal THEN
      RESET family_info.sequence_pointer;
      pfp$get_family_info (set_name, - $pft$catalog_info_selections [], family_info.sequence_pointer, status);
      IF status.normal THEN
        RESET family_info.sequence_pointer;
        pfp$find_next_info_record (family_info.sequence_pointer, p_info_record, status);
        IF status.normal THEN
          pfp$find_directory_array (p_info_record, p_family_directory, status);
          IF status.normal AND (p_family_directory <> NIL) THEN
            IF sort_users THEN
              PUSH p_sorted_directory: [1 .. UPPERBOUND (p_family_directory^)];
              pup$sort_directory (p_family_directory^, p_sorted_directory^);
            ELSE
              p_sorted_directory := p_family_directory;
            IFEND;
            FOR i := LOWERBOUND (p_sorted_directory^) TO UPPERBOUND (p_sorted_directory^) DO
              pup$check_if_family_in_range (p_sorted_directory^ [i].name, family_in_range);
              IF family_in_range THEN
                display_family (set_name, p_sorted_directory^ [i].name, sort_users, status);
              IFEND;
            FOREND;
          IFEND;
        IFEND;
      IFEND;
      mmp$delete_scratch_segment (family_info, local_status);
    IFEND;
  PROCEND pup$display_set_request;

?? TITLE := '    [XDCL] pup$include_all_files ', EJECT ??

  PROCEDURE [XDCL] pup$include_all_files (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT include_all_files_pdt (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      include_all_files_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^include_all_files_pdt_names, ^include_all_files_pdt_params];

    VAR
      include_all_files_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
        clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      include_all_files_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
        clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    clp$scan_parameter_list (parameter_list, include_all_files_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$verify_system_administrator (osc$null_name, puv$p_user_range_list, status);
    IF status.normal THEN
      clp$scan_command_line ('INCLUDE_USERS ALL', status);
      pup$write_os_status (status, status);
    IFEND;

    clp$scan_command_line (' INCLUDE_EXCLUDED_ITEMS ', status);
    pup$write_os_status (status, status);

    clp$scan_command_line (' INCLUDE_CYCLES ALL', status);
    pup$write_os_status (status, status);

    clp$scan_command_line (' EXCLUDE_HIGHEST_CYCLES 0', status);
    pup$write_os_status (status, status);

    clp$scan_command_line (' INCLUDE_EMPTY_CATALOGS FALSE', status);
    pup$write_os_status (status, status);

    clp$scan_command_line (' INCLUDE_LARGE_CYCLES 0', status);
    pup$write_os_status (status, status);

    clp$scan_command_line (' INCLUDE_VOLUME ALL', status);
    pup$write_os_status (status, status);
  PROCEND pup$include_all_files;

?? TITLE := '    [XDCL] pup$include_users_command ', EJECT ??

  PROCEDURE [XDCL] pup$include_users_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ pdt include_users_pdt(
{ users, user, u: list 1 .. puc$max_number_of_user_ranges range of file ..
{  OR key all = $required
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      include_users_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^include_users_pdt_names,
        ^include_users_pdt_params];

    VAR
      include_users_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
        clt$parameter_name_descriptor := [['USERS', 1], ['USER', 1], ['U', 1], ['STATUS', 2]];

    VAR
      include_users_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor
        := [

{ USERS USER U }
      [[clc$required], 1, puc$max_number_of_user_ranges, 1, 1, clc$value_range_allowed,
        [^include_users_pdt_kv1, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      include_users_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['ALL'];

?? POP ??

    VAR
      p_user_container: ^put$user_range_list_container,
      temp_p_user_range_list: ^put$user_range_list,
      temp_user_container: put$user_range_list_container,
      uncracked_parameter: ost$string;

    { The family_name parameter isn't used by pup$verify_family_administrator.
    {
    pup$verify_family_administrator ('INCLUDE_USERS', {family_name} osc$null_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, include_users_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_user_range_list ('USERS', uncracked_parameter, temp_user_container, temp_p_user_range_list,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF temp_p_user_range_list = NIL THEN
      puv$p_user_range_list := NIL;
    ELSE
      p_user_container := ^user_range_list_container;
      RESET p_user_container;
      NEXT puv$p_user_range_list: [1 .. UPPERBOUND (temp_p_user_range_list^)] IN p_user_container;
      puv$p_user_range_list^ := temp_p_user_range_list^;
    IFEND;
    pup$display_line (' INCLUDE USERS: ', status);
    pup$display_line (uncracked_parameter.value (1, uncracked_parameter.size), status);
  PROCEND pup$include_users_command;

?? TITLE := '    [XDCL] pup$sort_users_command ', EJECT ??

  PROCEDURE [XDCL] pup$sort_users_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? RIGHT := 110 ??
{ pdt sort_users_pdt (alphabetical_order, ao: boolean = true
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      sort_users_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^sort_users_pdt_names,
        ^sort_users_pdt_params];

    VAR
      sort_users_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['ALPHABETICAL_ORDER', 1], ['AO', 1], ['STATUS', 2]];

    VAR
      sort_users_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor :=
        [

{ ALPHABETICAL_ORDER AO }
      [[clc$optional_with_default, ^sort_users_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$boolean_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      sort_users_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

?? POP ??

    VAR
      local_sort_users: boolean;

    pup$verify_system_administrator ('SORT_USERS                     ', puv$p_user_range_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, sort_users_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_boolean ('ALPHABETICAL_ORDER', local_sort_users, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    puv$sort_users := local_sort_users;
  PROCEND pup$sort_users_command;

?? TITLE := '    display_family ', EJECT ??

  PROCEDURE display_family (set_name: stt$set_name;
        family_name: pft$name;
        sort_users: boolean;
    VAR status: ost$status);

    VAR
      i: put$half_integer,
      local_status: ost$status,
      master_catalog_info: amt$segment_pointer,
      p_family_content: pft$p_info_record,
      p_master_catalog_directory: pft$p_directory_array,
      p_sorted_directory: pft$p_directory_array,
      user_in_range: boolean,
      user_path: array [1 .. 2] of pft$name;

    user_path [1] := family_name;
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, master_catalog_info, status);
    IF status.normal THEN
      RESET master_catalog_info.sequence_pointer;
      pfp$get_master_catalog_info (set_name, family_name, - $pft$catalog_info_selections [],
            master_catalog_info.sequence_pointer, status);
      IF status.normal THEN
        RESET master_catalog_info.sequence_pointer;
        pfp$find_next_info_record (master_catalog_info.sequence_pointer, p_family_content, status);
        IF status.normal THEN
          pfp$find_directory_array (p_family_content, p_master_catalog_directory, status);
          IF status.normal AND (p_master_catalog_directory <> NIL) THEN
            IF sort_users THEN
              PUSH p_sorted_directory: [1 .. UPPERBOUND (p_master_catalog_directory^)];
              pup$sort_directory (p_master_catalog_directory^, p_sorted_directory^);
            ELSE
              p_sorted_directory := p_master_catalog_directory;
            IFEND;
            FOR i := LOWERBOUND (p_sorted_directory^) TO UPPERBOUND (p_sorted_directory^) DO
              pup$check_if_user_in_range (family_name, p_sorted_directory^ [i].name, user_in_range);
              IF user_in_range THEN
                user_path [2] := p_sorted_directory^ [i].name;
                pup$write_path (user_path, status);
              IFEND;
            FOREND;
          IFEND;
        IFEND;
      IFEND;
      mmp$delete_scratch_segment (master_catalog_info, local_status);
    IFEND;
  PROCEND display_family;

?? TITLE := '    display_user_range_list ', EJECT ??

  PROCEDURE display_user_range_list (VAR status: ost$status);

    VAR
      user_range_index: integer;

    IF puv$p_user_range_list = NIL THEN
      pup$display_line (' ALL USERS SELECTED', status);
    ELSE
      FOR user_range_index := 1 TO UPPERBOUND (puv$p_user_range_list^) DO
        pup$display_line (' range ', status);
        pup$display_line (' low user: ', status);
        pup$write_path (puv$p_user_range_list^ [user_range_index] [clc$low], status);
        pup$display_line (' high user:', status);
        pup$write_path (puv$p_user_range_list^ [user_range_index] [clc$high], status);
      FOREND;
    IFEND;
  PROCEND display_user_range_list;


MODEND pum$backup_set;
*DECK DECK=PUM$CHANGE_ALL_PERMITS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  change_all_permits ', EJECT ??
MODULE pum$change_all_permits;
{
{   The purpose of this module is to allow changing all permits in the system,
{   family, catalog, or file.
{   Currently, this only supports changing the family name in the permits.
{   This is required when the family name has been changed via the
{   CHANGE_FAMILY command,  or the family was restored to a different
{   family with RESTORE_CATALOG.
{   All permits, regardless of group, that contain the specified family name
{   will be changed.
{   These commands only work for the system or family administrator, catalog or
{   file owner.
{
?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc cld$path_description
*copyc cld$value
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc clt$parsed_path
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$name
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfp$delete_catalog_permit
*copyc pfp$delete_permit
*copyc pfp$find_direct_info_record
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$find_permit_array
*copyc pfp$get_family_info
*copyc pfp$get_family_set
*copyc pfp$get_item_info
*copyc pfp$get_master_catalog_info
*copyc pfp$get_multi_item_info
*copyc pfp$get_set_list
*copyc pfp$permit
*copyc pfp$permit_catalog
*copyc pud$hierarchy_list
*copyc pue$error_condition_codes
*copyc pup$build_catalog_header
*copyc pup$build_entry
*copyc pup$build_new_path
*copyc pup$check_if_family_in_range
*copyc pup$check_if_item_excluded
*copyc pup$check_if_user_in_range
*copyc pup$crack_catalog
*copyc pup$crack_permanent_file
*copyc pup$display_blank_lines
*copyc pup$display_excluded_item
*copyc pup$display_integer
*copyc pup$display_line
*copyc pup$get_summary_status
*copyc pup$initialize_summary_status
*copyc pup$sort_directory
*copyc pup$verify_family_administrator
*copyc pup$verify_system_administrator
*copyc pup$write_os_status
*copyc pup$write_path
*copyc put$user_range_list
*copyc puv$p_user_range_list
*copyc puv$sort_users
*copyc puv$trace_selected
?? POP ??
?? TITLE := '    Global Variables', EJECT ??

  VAR
    total_catalog_permits_changed: integer := 0,
    total_file_permits_changed: integer := 0;

?? TITLE := '    [XDCL] pup$change_all_permits_cm ', EJECT ??

  PROCEDURE [XDCL] pup$change_all_permits_cm (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{  pdt change_all_permits_pdt (
{    family_name, fn: name = $required
{    new_family_name, nfn: name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      change_all_permits_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^change_all_permits_pdt_names, ^change_all_permits_pdt_params];

    VAR
      change_all_permits_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
        clt$parameter_name_descriptor := [['FAMILY_NAME', 1], ['FN', 1], ['NEW_FAMILY_NAME', 2], ['NFN', 2],
        ['STATUS', 3]];

    VAR
      change_all_permits_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
        clt$parameter_descriptor := [

{ FAMILY_NAME FN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ NEW_FAMILY_NAME NFN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      local_status: ost$status,
      new_permit_family: pft$name,
      set_list: ^stt$set_list,
      cset,
      number_of_sets: stt$number_of_sets,
      old_permit_family: pft$name;

    pup$verify_system_administrator ('CHANGE_ALL_PERMITS             ', puv$p_user_range_list, status);
    IF NOT status.normal THEN
      IF status.condition = pue$unowned_users_included THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$not_system_administrator,
              'CHANGE_ALL_PERMITS', status);
      IFEND;
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, change_all_permits_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_family_names (old_permit_family, new_permit_family, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$display_line (' CHANGE_ALL_PERMITS ', status);
    pup$display_line (old_permit_family, status);
    pup$display_line (new_permit_family, status);

    pup$initialize_summary_status;
    total_catalog_permits_changed := 0;
    total_file_permits_changed := 0;

    number_of_sets := 20;
    FOR cset := 1 TO 2 DO
      PUSH set_list: [1 .. number_of_sets];
      pfp$get_set_list (set_list^, number_of_sets, status);
    FOREND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    FOR cset := 1 TO number_of_sets DO
      pup$change_set_permits (set_list^ [cset], old_permit_family, new_permit_family, status);
    FOREND;

    display_change_permit_totals;
    pup$get_summary_status (status);
    pup$write_os_status (status, local_status);
  PROCEND pup$change_all_permits_cm;
?? TITLE := '    pup$change_set_permits ', EJECT ??

  PROCEDURE pup$change_set_permits (set_name: stt$set_name;
        old_permit_family: pft$name;
        new_permit_family: pft$name;
    VAR status: ost$status);

    VAR
      dummy_cycle_selector: pft$cycle_selector,
      family_entry: put$entry,
      family_excluded: boolean,
      family_in_range: boolean,
      family_info: amt$segment_pointer,
      family_path: array [1 .. 1] of pft$name,
      i: put$half_integer,
      local_status: ost$status,
      p_family_catalog_header: ^put$catalog_header,
      p_family_directory: pft$p_directory_array,
      p_info_record: pft$p_info_record;

    status.normal := TRUE;
    local_status.normal := TRUE;
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, family_info, status);
    IF status.normal THEN
      RESET family_info.sequence_pointer;
      pfp$get_family_info (set_name, $pft$catalog_info_selections [pfc$catalog_directory], family_info.
            sequence_pointer, status);
      IF status.normal THEN
        RESET family_info.sequence_pointer;
        pfp$find_next_info_record (family_info.sequence_pointer, p_info_record, status);
        IF status.normal THEN
          pfp$find_directory_array (p_info_record, p_family_directory, status);
          IF status.normal AND (p_family_directory <> NIL) THEN
            PUSH p_family_catalog_header: [1 .. 1];

          /process_families/
            FOR i := LOWERBOUND (p_family_directory^) TO UPPERBOUND (p_family_directory^) DO
              pup$check_if_family_in_range (p_family_directory^ [i].name, family_in_range);
              IF family_in_range THEN
                family_path [pfc$family_name_index] := p_family_directory^ [i].name;
                pup$build_entry (p_family_directory^ [i].name, dummy_cycle_selector, puc$valid_family_entry,
                      family_entry);
                pup$build_catalog_header (set_name, ^family_path, p_family_catalog_header^);
                pup$check_if_item_excluded (family_entry, p_family_catalog_header^, family_excluded);
                IF family_excluded THEN
                  pup$display_excluded_item (family_entry, p_family_catalog_header^, status);
                ELSE
                  pup$change_family_permits (set_name, p_family_directory^ [i].name, old_permit_family,
                        new_permit_family, status);
                IFEND;
              IFEND;
            FOREND /process_families/;
          IFEND;
        IFEND;
      IFEND;
      mmp$delete_scratch_segment (family_info, local_status);
    IFEND;
  PROCEND pup$change_set_permits;
?? TITLE := '    pup$change_family_permits ', EJECT ??

{  This procedure assumes there are not permits at the family level, and
{  only changes the permits on each master catalog.

  PROCEDURE pup$change_family_permits (set_name: stt$set_name;
        family_name: pft$name;
        old_permit_family: pft$name;
        new_permit_family: pft$name;
    VAR status: ost$status);

    VAR
      dummy_cycle_selector: pft$cycle_selector,
      entry: put$entry,
      family_content_info: amt$segment_pointer,
      i: put$half_integer,
      local_status: ost$status,
      p_family_content: pft$p_info_record,
      p_master_catalog_directory: pft$p_directory_array,
      p_permit_array: pft$p_permit_array,
      p_user_catalog_header: ^put$catalog_header,
      p_user_record: pft$p_info_record,
      user_excluded: boolean,
      user_in_range: boolean,
      user_path: array [1 .. 2] of pft$name;

    user_path [pfc$family_name_index] := family_name;
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, family_content_info, status);
    IF status.normal THEN
      RESET family_content_info.sequence_pointer;
      pfp$get_master_catalog_info (set_name, family_name, $pft$catalog_info_selections [pfc$catalog_directory,
            pfc$catalog_permits], family_content_info.sequence_pointer, status);
      IF status.normal THEN
        RESET family_content_info.sequence_pointer;
        pfp$find_next_info_record (family_content_info.sequence_pointer, p_family_content, status);
        IF status.normal THEN
          pfp$find_directory_array (p_family_content, p_master_catalog_directory, status);
          IF status.normal AND (p_master_catalog_directory <> NIL) THEN
            IF puv$sort_users THEN
              pup$sort_directory (p_master_catalog_directory^, p_master_catalog_directory^);
            IFEND;
            PUSH p_user_catalog_header: [1 .. 2];

          /change_users/
            FOR i := LOWERBOUND (p_master_catalog_directory^) TO UPPERBOUND (p_master_catalog_directory^) DO
              pup$check_if_user_in_range (family_name, p_master_catalog_directory^ [i].name, user_in_range);
              IF user_in_range THEN
                user_path [pfc$master_catalog_name_index] := p_master_catalog_directory^ [i].name;
                pup$build_entry (user_path [pfc$master_catalog_name_index], dummy_cycle_selector,
                      puc$valid_catalog_entry, entry);
                pup$build_catalog_header (set_name, ^user_path, p_user_catalog_header^);
                pup$check_if_item_excluded (entry, p_user_catalog_header^, user_excluded);
                IF user_excluded THEN
                  pup$display_excluded_item (entry, p_user_catalog_header^, status);
                ELSE
                  pfp$find_direct_info_record (^p_family_content^.body, p_master_catalog_directory^ [i].
                        info_offset, p_user_record, status);
                  IF status.normal THEN
                    pfp$find_permit_array (p_user_record, p_permit_array, status);
                    IF status.normal THEN
                      change_catalog_permits (user_path, p_permit_array, old_permit_family, new_permit_family,
                            status);
                      IF NOT status.normal THEN
                        pup$write_os_status (status, status);
                      IFEND;
                      change_catalog_content_permits (user_path, old_permit_family, new_permit_family,
                            status);
                    IFEND;
                  IFEND;
                  pup$write_os_status (status, status);
                IFEND;
              IFEND;
            FOREND /change_users/;
          IFEND;
        IFEND;
      IFEND;
      mmp$delete_scratch_segment (family_content_info, local_status);
    IFEND;
  PROCEND pup$change_family_permits;
?? TITLE := '    [XDCL] pup$change_catalog_permits_cm ', EJECT ??

  PROCEDURE [XDCL] pup$change_catalog_permits_cm (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{  PDT change_cat_permits_pdt (
{     catalog, c: file = $required
{     family_name, fn: name = $required
{     new_family_name, nfn: name = $required
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      change_cat_permits_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^change_cat_permits_pdt_names, ^change_cat_permits_pdt_params];

    VAR
      change_cat_permits_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
        clt$parameter_name_descriptor := [['CATALOG', 1], ['C', 1], ['FAMILY_NAME', 2], ['FN', 2], [
        'NEW_FAMILY_NAME', 3], ['NFN', 3], ['STATUS', 4]];

    VAR
      change_cat_permits_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
        clt$parameter_descriptor := [

{ CATALOG C }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ FAMILY_NAME FN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ NEW_FAMILY_NAME NFN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??
    VAR
      local_status: ost$status,
      new_permit_family: pft$name,
      old_permit_family: pft$name,
      p_path: ^pft$path,
      path_container: clt$path_container,
      set_name: stt$set_name;

    clp$scan_parameter_list (parameter_list, change_cat_permits_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_catalog ('CATALOG', path_container, p_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF UPPERBOUND (p_path^) = pfc$family_name_index THEN
      pup$verify_family_administrator ('CHANGE_CATALOG_PERMITS', p_path^ [pfc$family_name_index], status);
      IF NOT status.normal THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, ' to change a family', status);
        RETURN;
      IFEND;
    IFEND;

    crack_family_names (old_permit_family, new_permit_family, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$display_line (' CHANGE_CATALOG_PERMITS', status);
    pup$write_path (p_path^, status);
    pup$display_line (old_permit_family, status);
    pup$display_line (new_permit_family, status);

    total_catalog_permits_changed := 0;
    total_file_permits_changed := 0;
    pup$initialize_summary_status;

    IF UPPERBOUND (p_path^) = pfc$family_name_index THEN
      pfp$get_family_set (p_path^ [pfc$family_name_index], set_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pup$change_family_permits (set_name, p_path^ [pfc$family_name_index], old_permit_family,
            new_permit_family, status);
    ELSE
      pup$change_catalog_permits (p_path^, old_permit_family, new_permit_family, status);
    IFEND;

    display_change_permit_totals;
    pup$get_summary_status (status);
    pup$write_os_status (status, local_status);
  PROCEND pup$change_catalog_permits_cm;
?? TITLE := '    pup$change_catalog_permits ', EJECT ??

  PROCEDURE pup$change_catalog_permits (path: pft$path;
        old_permit_family: pft$name;
        new_permit_family: pft$name;
    VAR status: ost$status);

    VAR
      catalog_info: amt$segment_pointer,
      entry: put$entry,
      index: integer,
      group: pft$group,
      local_status: ost$status,
      p_catalog_header: ^put$catalog_header,
      p_directory_array: pft$p_directory_array,
      p_info_record: pft$p_info_record,
      p_permit_array: pft$p_permit_array,
      set_name: stt$set_name;

    status.normal := TRUE;
    PUSH p_catalog_header: [1 .. UPPERBOUND (path)];

    pfp$get_family_set (path [pfc$family_name_index], set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$build_catalog_header (set_name, ^path, p_catalog_header^);
    IF status.normal THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, catalog_info, status);
    IFEND;
    IF status.normal THEN
      RESET catalog_info.sequence_pointer;
      group.group_type := pfc$public;
      pfp$get_item_info (path, group, $pft$catalog_info_selections [pfc$catalog_directory,
            pfc$catalog_permits], $pft$file_info_selections [], catalog_info.sequence_pointer, status);
      IF status.normal THEN
        RESET catalog_info.sequence_pointer;
        pfp$find_next_info_record (catalog_info.sequence_pointer, p_info_record, status);
        IF status.normal THEN
          pfp$find_directory_array (p_info_record, p_directory_array, status);
          IF p_directory_array <> NIL THEN
            pfp$find_direct_info_record (^p_info_record^.body, p_directory_array^ [1].info_offset,
                  p_info_record, status);
            IF status.normal THEN
              pfp$find_permit_array (p_info_record, p_permit_array, status);
              IF status.normal THEN
                change_catalog_permits (path, p_permit_array, old_permit_family, new_permit_family, status);
              IFEND;
              pup$write_os_status (status, local_status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
      mmp$delete_scratch_segment (catalog_info, local_status);
    IFEND;
    change_catalog_content_permits (path, old_permit_family, new_permit_family, status);
  PROCEND pup$change_catalog_permits;

?? TITLE := '    change_catalog_content_permits ', EJECT ??

{ This procedure assumes that the permit for the catalog has already been changed.
{ This routine will change the permits associated will all subcatalogs,
{ and files within the specified catalog.

  PROCEDURE change_catalog_content_permits (path: pft$path;
        old_permit_family: pft$name;
        new_permit_family: pft$name;
    VAR status: ost$status);

    VAR
      catalog_content_info: amt$segment_pointer,
      dummy_cycle_selector: pft$cycle_selector,
      entry: put$entry,
      group: pft$group,
      index: integer,
      item_excluded: boolean,
      local_status: ost$status,
      p_catalog_header: ^put$catalog_header,
      p_catalog_info: pft$p_info_record,
      p_directory_array: pft$p_directory_array,
      p_file_info: pft$p_info_record,
      p_info_record: pft$p_info_record,
      p_new_path: ^pft$path,
      p_permit_array: pft$p_permit_array,
      set_name: stt$set_name;


    pfp$get_family_set (path [pfc$family_name_index], set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, catalog_content_info, status);
    IF status.normal THEN
      RESET catalog_content_info.sequence_pointer;
      group.group_type := pfc$public;
      pfp$get_multi_item_info (path, group, $pft$catalog_info_selections [pfc$catalog_directory,
            pfc$catalog_permits], $pft$file_info_selections [pfc$file_directory, pfc$file_permits],
            catalog_content_info.sequence_pointer, status);
      IF status.normal THEN
        RESET catalog_content_info.sequence_pointer;
        pfp$find_next_info_record (catalog_content_info.sequence_pointer, p_info_record, status);
        IF status.normal THEN
          pfp$find_directory_array (p_info_record, p_directory_array, status);
          IF status.normal AND (p_directory_array <> NIL) THEN
            PUSH p_catalog_header: [1 .. UPPERBOUND (path) + 1];
            PUSH p_new_path: [1 .. (UPPERBOUND (path) + 1)];

          /change_files/
            FOR index := LOWERBOUND (p_directory_array^) TO UPPERBOUND (p_directory_array^) DO
              CASE p_directory_array^ [index].name_type OF
              = pfc$file_name =
                pup$build_new_path (path, p_directory_array^ [index].name, p_new_path^);
                pup$build_catalog_header (set_name, p_new_path, p_catalog_header^);
                pup$build_entry (p_directory_array^ [index].name, dummy_cycle_selector, puc$valid_pf_entry,
                      entry);
                pup$check_if_item_excluded (entry, p_catalog_header^, item_excluded);
                IF item_excluded THEN
                  pup$display_excluded_item (entry, p_catalog_header^, status);
                ELSE
                  pfp$find_direct_info_record (^p_info_record^.body, p_directory_array^ [index].info_offset,
                        p_file_info, status);
                  IF status.normal THEN
                    pfp$find_permit_array (p_file_info, p_permit_array, status);
                    IF status.normal THEN
                      change_file_permits (p_new_path^, p_permit_array, old_permit_family, new_permit_family,
                            status);
                    IFEND;
                  IFEND;
                  pup$write_os_status (status, local_status);
                  status.normal := TRUE;
                IFEND;
              ELSE
              CASEND;
            FOREND /change_files/;

          /change_catalogs/
            FOR index := LOWERBOUND (p_directory_array^) TO UPPERBOUND (p_directory_array^) DO

              CASE p_directory_array^ [index].name_type OF
              = pfc$catalog_name =
                pup$build_new_path (path, p_directory_array^ [index].name, p_new_path^);
                pup$build_catalog_header (set_name, p_new_path, p_catalog_header^);
                pup$build_entry (p_directory_array^ [index].name, dummy_cycle_selector,
                      puc$valid_catalog_entry, entry);
                pup$check_if_item_excluded (entry, p_catalog_header^, item_excluded);
                IF item_excluded THEN
                  pup$display_excluded_item (entry, p_catalog_header^, status);
                ELSE
                  pfp$find_direct_info_record (^p_info_record^.body, p_directory_array^ [index].info_offset,
                        p_catalog_info, status);
                  IF status.normal THEN
                    pfp$find_permit_array (p_catalog_info, p_permit_array, status);
                    IF status.normal THEN
                      change_catalog_permits (p_new_path^, p_permit_array, old_permit_family,
                            new_permit_family, status);
                    IFEND;
                  IFEND;
                  pup$write_os_status (status, local_status);
                  change_catalog_content_permits (p_new_path^, old_permit_family, new_permit_family, status);
                  pup$write_os_status (status, local_status);
                  status.normal := TRUE;
                IFEND;
              ELSE
              CASEND;
            FOREND /change_catalogs/;
          IFEND;
        IFEND;
      IFEND;
      mmp$delete_scratch_segment (catalog_content_info, local_status);
    IFEND;
    pup$write_os_status (status, local_status);
  PROCEND change_catalog_content_permits;
?? TITLE := '  change_catalog_permits', EJECT ??

  PROCEDURE change_catalog_permits (path: pft$path;
        p_permit_array: pft$p_permit_array;
        old_permit_family: pft$name;
        new_permit_family: pft$name;
    VAR status: ost$status);

    VAR
      local_status: ost$status,
      new_permit_group: pft$group,
      p: pft$array_index;

    status.normal := TRUE;
    IF p_permit_array = NIL THEN
      RETURN;
    IFEND;

  /process_permit_list/
    FOR p := 1 TO UPPERBOUND (p_permit_array^) DO
      CASE p_permit_array^ [p].group.group_type OF
      = pfc$public =
        ;
      ELSE
        { This uses the variant record    'trick' since the family  is    always the first field
        {of all of the variants.
        IF p_permit_array^ [p].group.family_description.family = old_permit_family THEN
          new_permit_group := p_permit_array^ [p].group;
          new_permit_group.family_description.family := new_permit_family;
          display (' pfp$permit_catalog ');
          pfp$permit_catalog (path, new_permit_group, p_permit_array^ [p].usage_permissions, p_permit_array^
                [p].share_requirements, p_permit_array^ [p].application_info, status);
          IF status.normal THEN
            display (' pfp$delete_catalog_permit');
            pfp$delete_catalog_permit (path, p_permit_array^ [p].group, status);
            IF status.normal THEN
              total_catalog_permits_changed := total_catalog_permits_changed + 1;
            ELSE
              pup$display_line (' -- unable to delete old catalog permit ', local_status);
              pup$write_path (path, local_status);
              pup$write_os_status (status, local_status);
            IFEND;
          ELSE
            pup$display_line (' -- unable to create new catalog permit ', local_status);
            pup$write_path (path, local_status);
            pup$write_os_status (status, local_status);
          IFEND;
        IFEND;
      CASEND;
    FOREND /process_permit_list/;

  PROCEND change_catalog_permits;

?? TITLE := '    [XDCL] pup$change_file_permits_command ', EJECT ??

  PROCEDURE [XDCL] pup$change_file_permits_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{  pdt change_file_permits_pdt (
{  file,f:file=$required
{  family_name, fn: name = $required
{  new_family_name, nfn: name = $required
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      change_file_permits_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^change_file_permits_pdt_names, ^change_file_permits_pdt_params];

    VAR
      change_file_permits_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
        clt$parameter_name_descriptor := [['FILE', 1], ['F', 1], ['FAMILY_NAME', 2], ['FN', 2], [
        'NEW_FAMILY_NAME', 3], ['NFN', 3], ['STATUS', 4]];

    VAR
      change_file_permits_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
        clt$parameter_descriptor := [

{ FILE F }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ FAMILY_NAME FN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ NEW_FAMILY_NAME NFN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      cycle_selector: pft$cycle_selector,
      cycle_selector_specified: boolean,
      local_status: ost$status,
      new_permit_family: pft$name,
      old_permit_family: pft$name,
      p_path: ^pft$path,
      path_container: clt$path_container;

    clp$scan_parameter_list (parameter_list, change_file_permits_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_permanent_file ('FILE', - $put$cycle_reference_selections [], path_container, p_path,
          cycle_selector_specified, cycle_selector, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_family_names (old_permit_family, new_permit_family, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$display_line (' CHANGE_FILE_PERMITS', status);
    pup$write_path (p_path^, status);
    pup$display_line (old_permit_family, status);
    pup$display_line (new_permit_family, status);

    pup$initialize_summary_status;
    total_file_permits_changed := 0;
    total_catalog_permits_changed := 0;

    pup$change_file_permits (p_path^, old_permit_family, new_permit_family, status);

    display_change_permit_totals;
    pup$get_summary_status (status);
    pup$write_os_status (status, local_status);
  PROCEND pup$change_file_permits_command;

?? TITLE := '    pup$change_file_permits ', EJECT ??

  PROCEDURE pup$change_file_permits (path: pft$path;
        old_permit_family: pft$name;
        new_permit_family: pft$name;
    VAR status: ost$status);

    VAR
      entry: put$entry,
      index: integer,
      file_info: amt$segment_pointer,
      group: pft$group,
      local_status: ost$status,
      p_catalog_header: ^put$catalog_header,
      p_directory: pft$p_directory_array,
      p_permit_array: pft$p_permit_array,
      p_info_record: pft$p_info_record,
      set_name: stt$set_name;


    pfp$get_family_set (path [pfc$family_name_index], set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_catalog_header: [1 .. UPPERBOUND (path)];
    pup$build_catalog_header (set_name, ^path, p_catalog_header^);
    IF status.normal THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, file_info, status);
    IFEND;
    IF status.normal THEN
      RESET file_info.sequence_pointer;
      group.group_type := pfc$public;
      pfp$get_item_info (path, group, $pft$catalog_info_selections [], $pft$file_info_selections
            [pfc$file_directory, pfc$file_permits], file_info.sequence_pointer, status);
      IF status.normal THEN
        RESET file_info.sequence_pointer;
        pfp$find_next_info_record (file_info.sequence_pointer, p_info_record, status);
      IFEND;
      IF status.normal THEN
        pfp$find_directory_array (p_info_record, p_directory, status);
      IFEND;
      IF status.normal AND (p_directory = NIL) THEN
        osp$set_status_abnormal ('PU', pfe$unknown_permanent_file, path [UPPERBOUND (path)], status);
      IFEND;
      IF status.normal THEN
        pfp$find_direct_info_record (^p_info_record^.body, p_directory^ [1].info_offset, p_info_record,
              status);
      IFEND;
      IF status.normal THEN
        pfp$find_permit_array (p_info_record, p_permit_array, status);
      IFEND;
      IF status.normal THEN
        change_file_permits (path, p_permit_array, old_permit_family, new_permit_family, status);
      IFEND;
      mmp$delete_scratch_segment (file_info, local_status);
    IFEND;
  PROCEND pup$change_file_permits;
?? TITLE := '  change_file_permits', EJECT ??

  PROCEDURE change_file_permits (path: pft$path;
        p_permit_array: pft$p_permit_array;
        old_permit_family: pft$name;
        new_permit_family: pft$name;
    VAR status: ost$status);

    VAR
      local_status: ost$status,
      new_permit_group: pft$group,
      p: pft$array_index;

    status.normal := TRUE;
    IF p_permit_array = NIL THEN
      RETURN;
    IFEND;

  /process_file_permits/
    FOR p := 1 TO UPPERBOUND (p_permit_array^) DO
      CASE p_permit_array^ [p].group.group_type OF
      = pfc$public =
        ;
      ELSE
        { This uses the variant record    'trick' since the family  is    always the first field
        {of all of the variants.
        IF p_permit_array^ [p].group.family_description.family = old_permit_family THEN
          new_permit_group := p_permit_array^ [p].group;
          new_permit_group.family_description.family := new_permit_family;
          display (' pfp$permit ');
          pfp$permit (path, new_permit_group, p_permit_array^ [p].usage_permissions, p_permit_array^ [p].
                share_requirements, p_permit_array^ [p].application_info, status);
          IF status.normal THEN
            display (' pfp$delete_permit');
            pfp$delete_permit (path, p_permit_array^ [p].group, status);
            IF status.normal THEN
              total_file_permits_changed := total_file_permits_changed + 1;
            ELSE
              pup$display_line (' -- unable to delete old file permit ', local_status);
              pup$write_path (path, local_status);
              pup$write_os_status (status, local_status);
            IFEND;
          ELSE
            pup$display_line (' -- unable to create new file permit ', local_status);
            pup$write_path (path, local_status);
            pup$write_os_status (status, local_status);
          IFEND;
        IFEND;
      CASEND;
    FOREND /process_file_permits/;

  PROCEND change_file_permits;
?? TITLE := ' crack_family_names', EJECT ??

  PROCEDURE [INLINE] crack_family_names (VAR old_permit_family: pft$name;
    VAR new_permit_family: pft$name;
    VAR status: ost$status);

    VAR
      value: clt$value;

    clp$get_value ('FAMILY_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    old_permit_family := value.name.value;

    clp$get_value ('NEW_FAMILY_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    new_permit_family := value.name.value;

    IF old_permit_family = new_permit_family THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$new_name_must_be_different, 'NEW_FAMILY_NAME', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, ' FAMILY_NAME', status);
    IFEND;

  PROCEND crack_family_names;

?? TITLE := '    display_change_permit_totals ', EJECT ??

  PROCEDURE display_change_permit_totals;

    VAR
      local_status: ost$status;

    pup$display_blank_lines (1, local_status);
    pup$display_line (' CHANGE SUMMARY: ', local_status);
    pup$display_integer ('   NUMBER OF CATALOG PERMITS CHANGED:', total_catalog_permits_changed,
          local_status);
    pup$display_integer ('   NUMBER OF FILE PERMITS CHANGED:', total_file_permits_changed, local_status);
  PROCEND display_change_permit_totals;


MODEND pum$change_all_permits;
*DECK DECK=PUM$COMMON_MODULES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  common_modules ', EJECT ??
MODULE pum$common_modules;
{
{  This module contains procedures of common interest to both backup and restore
{  processing.
{
?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amt$local_file_name
*copyc avp$family_administrator
*copyc avp$system_administrator
*copyc cld$parameter_list
*copyc cld$value
*copyc clt$file
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osd$integer_limits
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$name
*copyc ost$status
*copyc pfe$error_condition_codes
*copyc pfe$internal_error_conditions
*copyc pfp$convert_pf_path_to_fs_path
*copyc pfp$find_cycle_array
*copyc pfp$find_cycle_array_version_2
*copyc pfp$find_cycle_entry_version_2
*copyc pfp$find_direct_info_record
*copyc pfp$find_directory_array
*copyc pfp$find_file_description
*copyc pfp$find_next_info_record
*copyc pfp$get_family_set
*copyc pfp$get_item_info
*copyc pfp$get_master_catalog_info
*copyc pmp$get_compact_date_time
*copyc pmp$get_user_identification
*copyc pud$hierarchy_list
*copyc pue$error_condition_codes
*copyc pus$literals
*copyc put$file_identifier
*copyc put$selected_object
*copyc put$user_range_list
*copyc std$set_name
?? POP ??
?? TITLE := '    Global Variables', EJECT ??

  VAR
    no_file_info_selections: [pus$literals, READ] pft$file_info_selections := $pft$file_info_selections [],
    no_catalog_info_selections: [pus$literals, READ] pft$catalog_info_selections :=
      $pft$catalog_info_selections [];

?? TITLE := '    [XDCL] pup$build_catalog_header ', EJECT ??

  PROCEDURE [XDCL] pup$build_catalog_header
   (    set_name: stt$set_name;
        p_path: ^pft$path;
    VAR catalog_header: put$catalog_header);

{  PURPOSE:
{    This procedure builds a pf utility catalog header.
{    - set_name
{    - p_path  This specifies the pf_path (starting with family) of the
{      backup item.  This should be specifies to NIL if there is no path.

    catalog_header.set_name := set_name;
    IF p_path = NIL THEN
      catalog_header.logical_path_length := 0;
    ELSE
      catalog_header.logical_path_length := UPPERBOUND (p_path^);
      catalog_header.path := p_path^;
    IFEND;
  PROCEND pup$build_catalog_header;

?? TITLE := '    [XDCL] pup$build_entry ', EJECT ??

  PROCEDURE [XDCL] pup$build_entry (pf_name: pft$name;
        cycle_selector: pft$cycle_selector;
        entry_type: put$entry_type;
    VAR pf_utility_entry: put$entry);

{  PURPOSE:
{    This procedure builds a pf utility entry.
{    - pf_name parameter specifies the name of the entry that is being
{    backed up. (eg. For a backup_catalog this is the catalog_name)
{    - cycle_selector
{      This is only used for entry_type = puc$valid_cycle_entry
{    - entry_type
{      This specifies the type of the item that is being backed up.
{      Choices are:
{        puc$valid_set_entry
{        puc$valid_family_entry
{        puc$valid_catalog_entry
{        puc$valid_pf_entry
{        puc$valid_cycle_entry
    pf_utility_entry.entry_type := entry_type;
    CASE entry_type OF
    = puc$valid_cycle_entry =
      pf_utility_entry.pf_selector.pfn := pf_name;
      pf_utility_entry.pf_selector.cycle_selector := cycle_selector;
    = puc$valid_pf_entry =
      pf_utility_entry.pfn := pf_name;
    = puc$valid_catalog_entry =
      pf_utility_entry.catalog_name := pf_name;
    = puc$valid_family_entry =
      pf_utility_entry.family_name := pf_name;
    = puc$valid_set_entry =
      pf_utility_entry.set_name := pf_name;
    ELSE
    CASEND;
  PROCEND pup$build_entry;

?? TITLE := '    [XDCL] pup$build_hierarchy_list ', EJECT ??

  PROCEDURE [XDCL] pup$build_hierarchy_list (pf_utility_entry: put$entry;
        catalog_header: put$catalog_header;
    VAR hierarchy_list: put$hierarchy_list;
    VAR status: ost$status);

{
{  PURPOSE:
{    This builds a pf utility hierarchy list by combining an entry, and
{    catalog header.

    status.normal := TRUE;
    hierarchy_list.pf_entry := pf_utility_entry;
    hierarchy_list.catalog_header := catalog_header;
    pmp$get_compact_date_time (hierarchy_list.date_time, status);
  PROCEND pup$build_hierarchy_list;

?? TITLE := '    [XDCL] pup$build_new_catalog_header ', EJECT ??

  PROCEDURE [XDCL] pup$build_new_catalog_header (pfu_entry: put$entry;
        pf_utility_catalog_header: put$catalog_header;
    VAR pf_util_new_catalog_header: put$catalog_header);

{
{  PURPOSE:
{    This builds a new pf utility catalog header.
{    The new catalog header must have a logical length one greater than the
{    old catalog header.  The name for the new path is taken from the
{    pf entry input.


    VAR
      i: put$half_integer,
      new_name: pft$name;

    pf_util_new_catalog_header.set_name := pf_utility_catalog_header.set_name;
    pf_util_new_catalog_header.logical_path_length := pf_utility_catalog_header.logical_path_length + 1;
    IF pf_utility_catalog_header.logical_path_length > 0 THEN
      FOR i := LOWERBOUND (pf_utility_catalog_header.path) TO UPPERBOUND (pf_utility_catalog_header.path) DO
        pf_util_new_catalog_header.path [i] := pf_utility_catalog_header.path [i];
      FOREND;
    IFEND;
    CASE pfu_entry.entry_type OF
    = puc$valid_family_entry =
      new_name := pfu_entry.family_name;
    = puc$valid_catalog_entry =
      new_name := pfu_entry.catalog_name;
    = puc$valid_pf_entry =
      new_name := pfu_entry.pfn;
    = puc$valid_cycle_entry =
      new_name := pfu_entry.pfn;
    ELSE
    CASEND;
    pf_util_new_catalog_header.path [pf_util_new_catalog_header.logical_path_length] := new_name;
  PROCEND pup$build_new_catalog_header;

?? TITLE := '    [XDCL] pup$build_new_online_cat_head ', EJECT ??
*copyc puh$build_new_online_cat_head

  PROCEDURE [XDCL] pup$build_new_online_cat_head (catalog_header: put$catalog_header;
        new_catalog_header: put$catalog_header;
        found_catalog_header: put$catalog_header;
    VAR new_online_catalog_header: put$catalog_header);

    VAR
      i: integer,
      new_online_index: integer;

    new_online_index := 0;
    new_online_catalog_header.set_name := found_catalog_header.set_name;
    FOR i := 1 TO new_catalog_header.logical_path_length DO
      new_online_index := new_online_index + 1;
      new_online_catalog_header.path [new_online_index] := new_catalog_header.path [i];
    FOREND;

    FOR i := (catalog_header.logical_path_length + 1) TO found_catalog_header.logical_path_length DO
      new_online_index := new_online_index + 1;
      new_online_catalog_header.path [new_online_index] := found_catalog_header.path [i];
    FOREND;
    new_online_catalog_header.logical_path_length := new_online_index;
  PROCEND pup$build_new_online_cat_head;

?? TITLE := '    [XDCL] pup$build_new_path ', EJECT ??

  PROCEDURE [XDCL] pup$build_new_path (path: pft$path;
        new_name: pft$name;
    VAR new_path: pft$path);

{  PURPOSE:
{    This routine takes an old path and appends a new name onto it.
{    The new_path is assumed to be one at least one larger than the old path.


    VAR
      index: integer;

    FOR index := LOWERBOUND (path) TO UPPERBOUND (path) DO
      new_path [index] := path [index];
    FOREND;
    new_path [(UPPERBOUND (path) + 1)] := new_name;
  PROCEND pup$build_new_path;

?? TITLE := '    pup$compare_catalog_header ', EJECT ??

  PROCEDURE pup$compare_catalog_header (cat_header_a: put$catalog_header;
        cat_header_b: put$catalog_header;
    VAR a_equals_b: boolean;
    VAR a_above_b: boolean);

{  PURPOSE:
{    The purpose of this procedure is to compare catalog headers to determine
{    if they are equal, or if cat_header_a is above cat_header_b in the
{    PF catalog tree.

    {Do not check set names, just use family names
    IF (cat_header_a.logical_path_length > 0) AND (cat_header_b.logical_path_length > 0) THEN
      pup$compare_paths (cat_header_a.path, cat_header_b.path, a_equals_b, a_above_b);
    ELSE
      { at least one of the catalog headers has a path length of zero.
      a_equals_b := cat_header_a.logical_path_length = cat_header_b.logical_path_length;
      a_above_b := cat_header_b.logical_path_length > cat_header_a.logical_path_length;
    IFEND;
  PROCEND pup$compare_catalog_header;

?? TITLE := '    [XDCL] pup$compare_cycle_selectors ', EJECT ??

  PROCEDURE [XDCL] pup$compare_cycle_selectors (cycle_selector_a: pft$cycle_selector;
        cycle_selector_b: pft$cycle_selector;
    VAR a_equals_b: boolean);

    a_equals_b := cycle_selector_a.cycle_option = cycle_selector_b.cycle_option;
    IF a_equals_b AND (cycle_selector_a.cycle_option = pfc$specific_cycle) THEN
      a_equals_b := cycle_selector_a.cycle_number = cycle_selector_b.cycle_number;
    IFEND;
  PROCEND pup$compare_cycle_selectors;



?? TITLE := '    [XDCL] pup$compare_dates ', EJECT ??

  PROCEDURE [XDCL] pup$compare_dates (date_time_a: ost$date_time;
        date_time_b: ost$date_time;
    VAR a_later_than_b: boolean);

{  This procedure compares date_time_a and date_time_b to determine
{  If date_time_a is later chronilogically than date_time_b.
{---------- I I M  E-------------> a_later_than_b
{   date_a        date_b         FALSE
{   date_b     date_a            TRUE
{        date_b = date_a         FALSE

    IF date_time_a.year > date_time_b.year THEN
      a_later_than_b := TRUE;
    ELSEIF date_time_a.year < date_time_b.year THEN
      a_later_than_b := FALSE
    ELSE
      IF date_time_a.month > date_time_b.month THEN
        a_later_than_b := TRUE;
      ELSEIF date_time_a.month < date_time_b.month THEN
        a_later_than_b := FALSE
      ELSE
        IF date_time_a.day > date_time_b.day THEN
          a_later_than_b := TRUE;
        ELSEIF date_time_a.day < date_time_b.day THEN
          a_later_than_b := FALSE
        ELSE
          IF date_time_a.hour > date_time_b.hour THEN
            a_later_than_b := TRUE;
          ELSEIF date_time_a.hour < date_time_b.hour THEN
            a_later_than_b := FALSE
          ELSE
            IF date_time_a.minute > date_time_b.minute THEN
              a_later_than_b := TRUE;
            ELSEIF date_time_a.minute < date_time_b.minute THEN
              a_later_than_b := FALSE
            ELSE
              IF date_time_a.second > date_time_b.second THEN
                a_later_than_b := TRUE;
              ELSEIF date_time_a.second < date_time_b.second THEN
                a_later_than_b := FALSE
              ELSE
                IF date_time_a.millisecond > date_time_b.millisecond THEN
                  a_later_than_b := TRUE;
                ELSE
                  a_later_than_b := FALSE
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pup$compare_dates;

?? TITLE := '    [XDCL] pup$compare_item_descriptor ', EJECT ??
*copyc puh$compare_item_descriptor
{truth chart for comparison
{===========================
{
{    CATALOG HEADERS                                              RESULTS
{a_above_b   a_equals_b     a_b_entry_equal         a_equals_b       a_above_b
{______________________________________________________________________________
{
{f              t                t                      t               f
{
{
{                                f                      f       (a.entry_type = file)
{                                                                   and
{                                                               (b_entry_type = cycle
{                                                                         AND
{                                                               a_entry.pfn =
{                                                               b_entry.pf_selector.pfn
{
{
{_________________________________________________________________________________
{
{
{t              f               t                      f        a_entry_type = catalog
{                                                               family or set
{
{
{f              f               t                      f        f
{
{
{
{t              f               f                      f        a_entry_type = catalog
{                                                               family or set
{
{
{f              f               f                      f        f
{
{=============================================================================
?? EJECT ??
  PROCEDURE [XDCL] pup$compare_item_descriptor (put_entry_a: put$entry;
        cat_header_a: put$catalog_header;
        put_entry_b: put$entry;
        cat_header_b: put$catalog_header;
    VAR a_equals_b: boolean;
    VAR a_above_b: boolean);

    VAR
      a_b_entry_equal: boolean,
      a_cat_head_above_b: boolean,
      a_cat_head_equal_b: boolean;

    pup$compare_catalog_header (cat_header_a, cat_header_b, a_cat_head_equal_b, a_cat_head_above_b);
    compare_entries (put_entry_a, put_entry_b, a_b_entry_equal);
    a_equals_b := a_cat_head_equal_b AND a_b_entry_equal;
    IF a_cat_head_equal_b THEN
      a_above_b := (NOT a_b_entry_equal) AND (((put_entry_a.entry_type = puc$valid_pf_entry) AND (put_entry_b.
            entry_type = puc$valid_cycle_entry)) AND (put_entry_a.pfn = put_entry_b.pf_selector.pfn));
    ELSE
      a_above_b := a_cat_head_above_b AND ((put_entry_a.entry_type = puc$valid_set_entry) OR (put_entry_a.
            entry_type = puc$valid_family_entry) OR (put_entry_a.entry_type = puc$valid_catalog_entry));
    IFEND;
  PROCEND pup$compare_item_descriptor;

?? TITLE := '    [XDCL] pup$compare_paths ', EJECT ??
*copyc puh$compare_paths

  PROCEDURE [XDCL] pup$compare_paths (path_a: pft$path;
        path_b: pft$path;
    VAR a_equals_b: boolean;
    VAR a_above_b: boolean);


    VAR
      a_equals_start_of_b: boolean,
      i: integer,
      length_path_a: integer,
      length_path_b: integer;

    length_path_a := UPPERBOUND (path_a);
    length_path_b := UPPERBOUND (path_b);

    IF length_path_a > length_path_b THEN
      a_above_b := FALSE;
      a_equals_b := FALSE;
    ELSE
      a_equals_start_of_b := TRUE;
      {This compares the a path with the first part of the b path.

    /search_for_unequal/
      FOR i := 1 TO length_path_a DO
        IF path_a [i] <> path_b [i] THEN
          a_equals_start_of_b := FALSE;
          EXIT /search_for_unequal/;
        IFEND;
      FOREND /search_for_unequal/;

{determine if a equals b}
      a_equals_b := (length_path_a = length_path_b) AND a_equals_start_of_b;
      a_above_b := a_equals_start_of_b AND (length_path_a < length_path_b);
    IFEND;
  PROCEND pup$compare_paths;

?? TITLE := '    [XDCL] pup$convert_cycle_path_to_strng ', EJECT ??

  PROCEDURE [XDCL] pup$convert_cycle_path_to_strng (path: pft$path;
        cycle_number: pft$cycle_number;
    VAR path_name: ost$string);

{   This procedure converts a path to a string.  The string is a path
{ name suitable for printing and follows the standard form, i.e. it begins
{ with :family_name, contains no blanks, and separates each name with a
{ period.

    VAR
      cycle_string: string (20),
      cycle_string_length: integer,
      found: boolean,
      last_name_index: integer,
      last_name_length: 0 .. osc$max_name_size + 1,
      name_length: 1 .. osc$max_name_size + 1,
      path_index: integer,
      path_name_length: integer,
      space_character: [pus$literals, READ] packed array [0 .. 255] of boolean := [REP 32 of FALSE, TRUE, REP
        223 of FALSE];

    STRINGREP (cycle_string, cycle_string_length, cycle_number);
    cycle_string (1) := '.';
    path_name.value (1) := ':';
    path_name_length := 1;

    last_name_index := UPPERBOUND (path);
    #scan (space_character, path [last_name_index], last_name_length, found);
    last_name_length := last_name_length - 1;

    FOR path_index := 1 TO last_name_index - 1 DO
      IF (path [path_index] = osc$null_name) OR (path [path_index] = '') THEN
        path_name.value (path_name_length + 1, 2) := '?.';
        path_name_length := path_name_length + 2;
      ELSE
        #scan (space_character, path [path_index], name_length, found);
        name_length := name_length - 1;
        IF path_name_length + name_length + (2 * ((last_name_index - 1) - path_index)) + last_name_length >
              osc$max_string_size THEN
          {
          { The path name would be too long, so a '?' is substituted for this
          { name in the path.
          {
          path_name.value (path_name_length + 1, 2) := '?.';
          path_name_length := path_name_length + 2;
        ELSE
          STRINGREP (path_name.value, path_name_length, path_name.value (1, path_name_length), path
                [path_index] (1, name_length), '.');
        IFEND;
      IFEND;
    FOREND;

    STRINGREP (path_name.value, path_name_length, path_name.value (1, path_name_length), path
          [last_name_index] (1, last_name_length), cycle_string (1, cycle_string_length));
    path_name.size := path_name_length;
  PROCEND pup$convert_cycle_path_to_strng;

?? TITLE := '    [XDCL] pup$convert_path_to_string ', EJECT ??

  PROCEDURE [XDCL] pup$convert_path_to_string (path: pft$path;
    VAR path_name: ost$string);

{   This procedure converts a path to a string.  The string is a path
{ name suitable for printing and follows the standard form, i.e. it begins
{ with :family_name, contains no blanks, and separates each name with a
{ period.

    VAR
      found: boolean,
      last_name_index: integer,
      last_name_length: 0 .. osc$max_name_size + 1,
      name_length: 1 .. osc$max_name_size + 1,
      path_index: integer,
      path_name_length: integer,
      space_character: [pus$literals, READ] packed array [0 .. 255] of boolean := [REP 32 of FALSE, TRUE, REP
        223 of FALSE];

    path_name.value (1) := ':';
    path_name_length := 1;

    last_name_index := UPPERBOUND (path);
    #scan (space_character, path [last_name_index], last_name_length, found);
    last_name_length := last_name_length - 1;

    FOR path_index := 1 TO last_name_index - 1 DO
      IF (path [path_index] = osc$null_name) OR (path [path_index] = '') THEN
        path_name.value (path_name_length + 1, 2) := '?.';
        path_name_length := path_name_length + 2;
      ELSE
        #scan (space_character, path [path_index], name_length, found);
        name_length := name_length - 1;
        IF path_name_length + name_length + (2 * ((last_name_index - 1) - path_index)) + last_name_length >
              osc$max_string_size THEN
          {
          { The path name would be too long, so a '?' is substituted for this
          { name in the path.
          {
          path_name.value (path_name_length + 1, 2) := '?.';
          path_name_length := path_name_length + 2;
        ELSE
          STRINGREP (path_name.value, path_name_length, path_name.value (1, path_name_length), path
                [path_index] (1, name_length), '.');
        IFEND;
      IFEND;
    FOREND;

    STRINGREP (path_name.value, path_name_length, path_name.value (1, path_name_length), path
          [last_name_index] (1, last_name_length));
    path_name.size := path_name_length;
  PROCEND pup$convert_path_to_string;

?? TITLE := '    [XDCL] pup$determine_if_set_exists ', EJECT ??

  PROCEDURE [XDCL] pup$determine_if_set_exists (set_name: stt$set_name;
    VAR set_exists: boolean;
    VAR status: ost$status);

      set_exists := TRUE;
      status.normal := TRUE;

  PROCEND pup$determine_if_set_exists;

?? TITLE := '    [XDCL] pup$find_cycle_entry ', EJECT ??
*copyc puh$find_cycle_entry

  PROCEDURE [XDCL] pup$find_cycle_entry
   (    path: pft$path;
        cycle_selector: pft$cycle_selector;
    VAR cycle_entry: pft$cycle_array_entry_version_2;
    VAR status: ost$status);

    VAR
      cycle_index: pft$array_index,
      group: pft$group,
      local_status: ost$status,
      p_cycle_array: ^pft$cycle_array_version_2,
      p_item_record: pft$p_info_record,
      segment_pointer: amt$segment_pointer;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, segment_pointer, status);
    IF status.normal THEN
      group.group_type := pfc$public;
      pfp$get_item_info (path, group, $pft$catalog_info_selections [],
            $pft$file_info_selections [pfc$file_directory, pfc$file_cycles_version_2],
            segment_pointer.sequence_pointer, status);
      IF status.normal THEN
        pup$get_cycle_array_version_2 (segment_pointer.sequence_pointer, p_cycle_array, p_item_record,
              status);
        IF status.normal THEN
          pfp$find_cycle_entry_version_2 (p_cycle_array, cycle_selector, cycle_index, status);
          IF status.normal THEN
            cycle_entry := p_cycle_array^ [cycle_index];
          ELSEIF status.condition = pfe$unknown_cycle THEN
            pup$set_unknown_cycle_status (path [UPPERBOUND (path)], cycle_selector, status);
          IFEND;
        IFEND;
        mmp$delete_scratch_segment (segment_pointer, local_status);
      IFEND;
    IFEND;
  PROCEND pup$find_cycle_entry;

?? TITLE := '    [XDCL] pup$find_cycle_info_record ', EJECT ??

  PROCEDURE [XDCL] pup$find_cycle_info_record
   (    p_cycle_array_extended_record: pft$p_info_record;
        p_cycle_directory_array: pft$p_cycle_directory_array;
        cycle_number: pft$cycle_number;
        p_path: pft$p_path;
    VAR p_cycle_info_record: pft$p_info_record;
    VAR status: ost$status);

    VAR
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      i: ost$positive_integers;

    FOR i := 1 TO UPPERBOUND (p_cycle_directory_array^) DO
      IF p_cycle_directory_array^ [i].cycle_number = cycle_number THEN
        pfp$find_direct_info_record (^p_cycle_array_extended_record^.body,
              p_cycle_directory_array^ [i].info_offset, p_cycle_info_record, status);
        RETURN;
      IFEND;
    FOREND;
    pfp$convert_pf_path_to_fs_path (p_path^, fs_path, fs_path_size);
    osp$set_status_abnormal (puc$pf_utility_id, pue$no_cycle_direct_array_entry, '', status);
    osp$append_status_parameter (osc$status_parameter_delimiter, fs_path (1, fs_path_size), status);
    osp$append_status_integer (osc$status_parameter_delimiter, cycle_number, 10, FALSE, status);
  PROCEND pup$find_cycle_info_record;

?? TITLE := '    [XDCL] pup$get_cycle_array ', EJECT ??

  PROCEDURE [XDCL] pup$get_cycle_array (
    VAR sequence_pointer: ^SEQ ( * );
    VAR p_cycle_array: pft$p_cycle_array;
    VAR p_item_record: pft$p_info_record;
    VAR status: ost$status);

{
{  PURPOSE:
{    This procedure attempts to find the cycle array for a file.
{    A sequence must be supplied, in which the cycle array will be stored.

    VAR
      p_body: pft$p_info,
      p_directory_array: pft$p_directory_array,
      p_info_record: pft$p_info_record;

    p_cycle_array := NIL;
    RESET sequence_pointer;
    pfp$find_next_info_record (sequence_pointer, p_info_record, status);
    IF status.normal THEN
      pfp$find_directory_array (p_info_record, p_directory_array, status);
      IF status.normal AND (p_directory_array <> NIL) THEN
        p_body := ^p_info_record^.body;
        pfp$find_direct_info_record (p_body, p_directory_array^ [LOWERBOUND (p_directory_array^)].
              info_offset, p_item_record, status);
        IF status.normal THEN
          pfp$find_cycle_array (p_item_record, p_cycle_array, status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND pup$get_cycle_array;

?? TITLE := '    [XDCL] pup$get_cycle_array_version_2 ', EJECT ??

  PROCEDURE [XDCL] pup$get_cycle_array_version_2 (
    VAR sequence_pointer: ^SEQ ( * );
    VAR p_cycle_array_version_2: ^pft$cycle_array_version_2;
    VAR p_item_record: pft$p_info_record;
    VAR status: ost$status);

{
{  PURPOSE:
{    This procedure attempts to find the cycle array for a file.
{    A sequence must be supplied, in which the cycle array will be stored.


    VAR
      p_body: pft$p_info,
      p_directory_array: pft$p_directory_array,
      p_info_record: pft$p_info_record;

    p_cycle_array_version_2 := NIL;
    RESET sequence_pointer;
    pfp$find_next_info_record (sequence_pointer, p_info_record, status);
    IF status.normal THEN
      pfp$find_directory_array (p_info_record, p_directory_array, status);
      IF status.normal AND (p_directory_array <> NIL) THEN
        p_body := ^p_info_record^.body;
        pfp$find_direct_info_record (p_body, p_directory_array^ [LOWERBOUND (p_directory_array^)].
              info_offset, p_item_record, status);
        IF status.normal THEN
          pfp$find_cycle_array_version_2 (p_item_record, p_cycle_array_version_2, status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND pup$get_cycle_array_version_2;

?? TITLE := '    [XDCL] pup$get_file_password ', EJECT ??
*copyc puh$get_file_password

  PROCEDURE [XDCL] pup$get_file_password (file_path: pft$path;
    VAR password: pft$password);


    VAR
      file_info: pft$file_info_selections,
      file_item_info: amt$segment_pointer,
      group: pft$group,
      p_body: pft$p_info,
      p_directory_array: pft$p_directory_array,
      p_file_description: pft$p_file_description,
      p_info_record: pft$p_info_record,
      p_item_record: pft$p_info_record,
      status: ost$status;

    password := osc$null_name;
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, file_item_info, status);
    IF status.normal THEN
      group.group_type := pfc$public;
      file_info := $pft$file_info_selections [pfc$file_directory, pfc$file_description];
      pfp$get_item_info (file_path, group, no_catalog_info_selections, file_info, file_item_info.
            sequence_pointer, status);
      IF status.normal THEN
        RESET file_item_info.sequence_pointer;
        pfp$find_next_info_record (file_item_info.sequence_pointer, p_info_record, status);
        IF status.normal THEN
          p_body := ^p_info_record^.body;
          pfp$find_directory_array (p_info_record, p_directory_array, status);
          IF status.normal AND (p_directory_array <> NIL) THEN
            pfp$find_direct_info_record (p_body, p_directory_array^ [LOWERBOUND (p_directory_array^)].
                  info_offset, p_item_record, status);
            IF status.normal THEN
              pfp$find_file_description (p_item_record, p_file_description, status);
              IF status.normal THEN
                password := p_file_description^.password;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
      mmp$delete_scratch_segment (file_item_info, status);
    IFEND;
  PROCEND pup$get_file_password;

?? TITLE := '    [XDCL] pup$set_abnormal_entry_status ', EJECT ??

  PROCEDURE [XDCL] pup$set_abnormal_entry_status (entry: put$entry;
        condition: ost$status_condition;
    VAR status: ost$status);

{  The template is assumed to have 3 spaces for parameters


    CASE entry.entry_type OF
    = puc$valid_set_entry =
      osp$set_status_abnormal (puc$pf_utility_id, condition, 'set ', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, entry.set_name, status);
    = puc$valid_family_entry =
      osp$set_status_abnormal (puc$pf_utility_id, condition, 'family ', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, entry.family_name, status);
    = puc$valid_catalog_entry =
      osp$set_status_abnormal (puc$pf_utility_id, condition, 'catalog ', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, entry.catalog_name, status);
    = puc$valid_pf_entry =
      osp$set_status_abnormal (puc$pf_utility_id, condition, 'permanent file ', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, entry.pfn, status);
    = puc$valid_cycle_entry =
      osp$set_status_abnormal (puc$pf_utility_id, condition, 'permanent file cycle ', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, entry.pf_selector.pfn, status);
      osp$append_status_integer (osc$status_parameter_delimiter, entry.pf_selector.cycle_selector.
            cycle_number, 10, FALSE, status);
    ELSE
      osp$set_status_abnormal (puc$pf_utility_id, condition, 'INVALID ENTRY ', status);
    CASEND;
  PROCEND pup$set_abnormal_entry_status;

?? TITLE := '    [XDCL] pup$set_object_abnormal ', EJECT ??

  PROCEDURE [XDCL] pup$set_object_abnormal
    (   p_object: ^put$selected_object;
        condition: ost$status_condition;
    VAR status: ost$status);

  VAR
    fs_path_size: fst$path_size,
    os_string: ost$string,
    p_fs_path: ^fst$path;

{  The template is assumed to have 2 spaces for parameters


    CASE p_object^.entry.entry_type OF
    = puc$valid_set_entry =
      osp$set_status_abnormal (puc$pf_utility_id, condition, 'Set ', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_object^.entry.set_name, status);
    = puc$valid_family_entry =
      osp$set_status_abnormal (puc$pf_utility_id, condition, 'Family ', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_object^.entry.family_name, status);
    = puc$valid_catalog_entry =
      osp$set_status_abnormal (puc$pf_utility_id, condition, 'Catalog ', status);
      PUSH p_fs_path;
      pfp$convert_pf_path_to_fs_path(p_object^.p_catalog_header^.path, p_fs_path^, fs_path_size);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_fs_path^(1, fs_path_size), status);
    = puc$valid_pf_entry =
      osp$set_status_abnormal (puc$pf_utility_id, condition, 'Permanent file ', status);
      PUSH p_fs_path;
      pfp$convert_pf_path_to_fs_path(p_object^.p_catalog_header^.path, p_fs_path^, fs_path_size);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_fs_path^(1, fs_path_size), status);
    = puc$valid_cycle_entry =
      osp$set_status_abnormal (puc$pf_utility_id, condition, 'Permanent file cycle ', status);
      IF p_object^.entry.pf_selector.cycle_selector.cycle_option = pfc$specific_cycle THEN
        pup$convert_cycle_path_to_strng (p_object^.p_catalog_header^.path,
              p_object^.entry.pf_selector.cycle_selector.cycle_number, os_string);
        osp$append_status_parameter (osc$status_parameter_delimiter, os_string.value(1, os_string.size),
              status);
      ELSE
        PUSH p_fs_path;
        pfp$convert_pf_path_to_fs_path (p_object^.p_catalog_header^.path, p_fs_path^, fs_path_size);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_fs_path^ (1, fs_path_size), status);
      IFEND;
    ELSE
      osp$set_status_abnormal (puc$pf_utility_id, condition, 'INVALID ENTRY ', status);
    CASEND;
  PROCEND pup$set_object_abnormal;

?? TITLE := '    [XDCL] pup$set_unknown_cycle_status ', EJECT ??

  PROCEDURE [XDCL] pup$set_unknown_cycle_status (file_name: pft$name;
        cycle_selector: pft$cycle_selector;
    VAR status: ost$status);
    osp$set_status_abnormal (puc$pf_utility_id, pfe$unknown_cycle, file_name, status);
    CASE cycle_selector.cycle_option OF
    = pfc$lowest_cycle =
      osp$append_status_parameter (osc$status_parameter_delimiter, '$LOW', status);
    = pfc$highest_cycle =
      osp$append_status_parameter (osc$status_parameter_delimiter, '$HIGH', status);
    = pfc$specific_cycle =
      osp$append_status_integer (osc$status_parameter_delimiter, cycle_selector.cycle_number, 10, FALSE,
            status);
    CASEND;
  PROCEND pup$set_unknown_cycle_status;

?? TITLE := '    [XDCL, #GATE] pup$sort_cycle_array ', EJECT ??

  PROCEDURE [XDCL, #GATE] pup$sort_cycle_array (VAR sorted_cycle_array: pft$cycle_array);


    PROCEDURE quicksort (lower: integer;
          upper: integer);

      VAR
        i: integer,
        j: integer,
        x: pft$cycle_array_entry,
        w: pft$cycle_array_entry;

      i := lower;
      j := upper;

      x := sorted_cycle_array [(lower + upper) DIV 2];
      REPEAT
        WHILE sorted_cycle_array [i].cycle_number < x.cycle_number DO
          i := i + 1;
        WHILEND;
        WHILE x.cycle_number < sorted_cycle_array [j].cycle_number DO
          j := j - 1;
        WHILEND;
        IF i <= j THEN
          w := sorted_cycle_array [i];
          sorted_cycle_array [i] := sorted_cycle_array [j];
          sorted_cycle_array [j] := w;
          i := i + 1;
          j := j - 1;
        IFEND;
      UNTIL i > j;
      IF lower < j THEN
        quicksort (lower, j);
      IFEND;
      IF i < upper THEN
        quicksort (i, upper);
      IFEND;
    PROCEND quicksort;

    quicksort (1, UPPERBOUND (sorted_cycle_array));
  PROCEND pup$sort_cycle_array;

?? TITLE := '    [XDCL, #GATE] pup$sort_cycle_array_version_2 ', EJECT ??

  PROCEDURE [XDCL, #GATE] pup$sort_cycle_array_version_2 (VAR sorted_cycle_array: pft$cycle_array_version_2);


    PROCEDURE quicksort (lower: integer;
          upper: integer);

      VAR
        i: integer,
        j: integer,
        x: pft$cycle_array_entry_version_2,
        w: pft$cycle_array_entry_version_2;

      i := lower;
      j := upper;

      x := sorted_cycle_array [(lower + upper) DIV 2];
      REPEAT
        WHILE sorted_cycle_array [i].cycle_number < x.cycle_number DO
          i := i + 1;
        WHILEND;
        WHILE x.cycle_number < sorted_cycle_array [j].cycle_number DO
          j := j - 1;
        WHILEND;
        IF i <= j THEN
          w := sorted_cycle_array [i];
          sorted_cycle_array [i] := sorted_cycle_array [j];
          sorted_cycle_array [j] := w;
          i := i + 1;
          j := j - 1;
        IFEND;
      UNTIL i > j;
      IF lower < j THEN
        quicksort (lower, j);
      IFEND;
      IF i < upper THEN
        quicksort (i, upper);
      IFEND;
    PROCEND quicksort;

    quicksort (1, UPPERBOUND (sorted_cycle_array));
  PROCEND pup$sort_cycle_array_version_2;

?? TITLE := '    [XDCL, #GATE] pup$sort_directory ', EJECT ??

  PROCEDURE [XDCL, #GATE] pup$sort_directory (unsorted_directory: pft$directory_array;
    VAR sorted_directory: pft$directory_array);


    PROCEDURE quicksort (lower: integer;
          upper: integer);

      VAR
        i: integer,
        j: integer,
        x: pft$directory_array_entry,
        w: pft$directory_array_entry;

      i := lower;
      j := upper;

      x := sorted_directory [(lower + upper) DIV 2];
      REPEAT
        WHILE sorted_directory [i].name < x.name DO
          i := i + 1;
        WHILEND;
        WHILE x.name < sorted_directory [j].name DO
          j := j - 1;
        WHILEND;
        IF i <= j THEN
          w := sorted_directory [i];
          sorted_directory [i] := sorted_directory [j];
          sorted_directory [j] := w;
          i := i + 1;
          j := j - 1;
        IFEND;
      UNTIL i > j;
      IF lower < j THEN
        quicksort (lower, j);
      IFEND;
      IF i < upper THEN
        quicksort (i, upper);
      IFEND;
    PROCEND quicksort;

    sorted_directory := unsorted_directory;
    quicksort (1, UPPERBOUND (sorted_directory));
  PROCEND pup$sort_directory;

?? TITLE := '    [XDCL] pup$validate_n_n_minus_1 ', EJECT ??
*copyc puh$validate_n_n_minus_1

  PROCEDURE [XDCL] pup$validate_n_n_minus_1 (path: pft$path;
        n_type: put$entry_type;
        cycle_selector: pft$cycle_selector;
    VAR status: ost$status);

    VAR
      cycle_entry: pft$cycle_array_entry_version_2,
      i: integer,
      p_n_minus_1_path: ^pft$path;

    status.normal := TRUE;
    { Verify N minus 1 exists online
    CASE n_type OF
    = puc$valid_family_entry =

    = puc$valid_catalog_entry, puc$valid_pf_entry =
      PUSH p_n_minus_1_path: [1 .. (UPPERBOUND (path) - 1)];
      FOR i := 1 TO UPPERBOUND (p_n_minus_1_path^) DO
        p_n_minus_1_path^ [i] := path [i];
      FOREND;
      pup$verify_catalog_path (p_n_minus_1_path^, status);

    = puc$valid_cycle_entry =
      pup$verify_file_path (path, status);
      IF NOT status.normal AND (status.condition = pfe$unknown_permanent_file) THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$restore_cycle_requires_file, '', status);
      IFEND;
    ELSE
    CASEND;

    { Verify N does not exist
    IF status.normal THEN
      CASE n_type OF
      = puc$valid_family_entry, puc$valid_catalog_entry =
        pup$verify_catalog_path (path, status);
        IF status.normal THEN
          osp$set_status_abnormal (puc$pf_utility_id, pue$new_catalog_already_exists, path [UPPERBOUND
                (path)], status);
        ELSEIF (status.condition = pfe$unknown_last_subcatalog) OR (status.condition =
              pfe$unknown_nth_subcatalog) THEN
          status.normal := TRUE;
        ELSEIF (status.condition = pfe$unknown_family) AND (UPPERBOUND(path) = pfc$family_name_index) THEN
          status.normal := TRUE;
        ELSEIF (status.condition = pfe$unknown_master_catalog) AND (UPPERBOUND(path) =
              pfc$master_catalog_name_index) THEN
          status.normal := TRUE;
        IFEND;

      = puc$valid_pf_entry =
        pup$verify_file_path (path, status);
        IF status.normal THEN
          osp$set_status_abnormal (puc$pf_utility_id, pue$new_file_already_exists, path [UPPERBOUND (path)],
                status);
        ELSEIF status.condition = pfe$unknown_permanent_file THEN
          status.normal := TRUE;
        IFEND;

      = puc$valid_cycle_entry =
        IF cycle_selector.cycle_option = pfc$specific_cycle THEN
          { $high, $low are OK
          pup$find_cycle_entry (path, cycle_selector, cycle_entry, status);
          IF status.normal THEN
            osp$set_status_abnormal (puc$pf_utility_id, pue$new_cycle_already_exists, path [UPPERBOUND
                  (path)], status);
            osp$append_status_integer (osc$status_parameter_delimiter, cycle_selector.cycle_number, 10, FALSE,
                  status);
          ELSEIF status.condition = pfe$unknown_cycle THEN
            status.normal := TRUE;
          IFEND;
        IFEND;
      ELSE
      CASEND;
    IFEND;

  PROCEND pup$validate_n_n_minus_1;

?? TITLE := '    [XDCL] pup$verify_catalog_path ', EJECT ??
*copyc puh$verify_catalog_path

  PROCEDURE [XDCL] pup$verify_catalog_path (catalog_path: pft$path;
    VAR status: ost$status);

    VAR
      catalog_info: pft$catalog_info_selections,
      file_info: pft$file_info_selections,
      group: pft$group,
      local_status: ost$status,
      segment: amt$segment_pointer,
      set_name: stt$set_name;


    pfp$get_family_set (catalog_path [pfc$family_name_index], set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, segment, status);
    IF status.normal THEN
      catalog_info := $pft$catalog_info_selections [pfc$catalog_directory, pfc$catalog_description];
      IF UPPERBOUND(catalog_path) = pfc$family_name_index THEN
        pfp$get_master_catalog_info (set_name, catalog_path[pfc$family_name_index], catalog_info,
             segment.sequence_pointer, status);
      ELSE
        group.group_type := pfc$public;
        file_info := $pft$file_info_selections [];
        pfp$get_item_info (catalog_path, group, catalog_info, file_info, segment.sequence_pointer, status);
      IFEND;
      mmp$delete_scratch_segment (segment, local_status);
    IFEND;
  PROCEND pup$verify_catalog_path;

?? TITLE := '    [XDCL] pup$verify_file_path ', EJECT ??
*copyc puh$verify_file_path

  PROCEDURE [XDCL] pup$verify_file_path (file_path: pft$path;
    VAR status: ost$status);

    VAR
      catalog_info: pft$catalog_info_selections,
      file_info: pft$file_info_selections,
      group: pft$group,
      local_status: ost$status,
      segment: amt$segment_pointer;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, segment, status);
    IF status.normal THEN
      group.group_type := pfc$public;
      catalog_info := $pft$catalog_info_selections [];
      file_info := $pft$file_info_selections [pfc$file_description];
      pfp$get_item_info (file_path, group, catalog_info, file_info, segment.sequence_pointer, status);
      mmp$delete_scratch_segment (segment, local_status);
    IFEND;
  PROCEND pup$verify_file_path;


?? TITLE := '    [XDCL] pup$verify_family_administrator ', EJECT ??

  PROCEDURE [XDCL] pup$verify_family_administrator (request_name: string (* <= osc$max_name_size);
        family_name: pft$name;
    VAR status: ost$status);

    status.normal := TRUE;

    IF (NOT avp$family_administrator ()) AND (NOT avp$system_administrator ()) THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$not_system_administrator, request_name, status);
    IFEND;

  PROCEND pup$verify_family_administrator;
?? TITLE := '    [XDCL] pup$verify_system_administrator ', EJECT ??

  PROCEDURE [XDCL] pup$verify_system_administrator (request_name: string (* <= osc$max_name_size);
        p_included_users: ^put$user_range_list;
    VAR status: ost$status);

    VAR
      low_or_high: clt$low_or_high,
      non_administrated_user_included: boolean,
      range: 1 .. puc$max_number_of_user_ranges,
      user_identification: ost$user_identification;

    status.normal := TRUE;

    pmp$get_user_identification (user_identification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT avp$system_administrator () THEN
      IF NOT avp$family_administrator () THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$not_system_administrator, request_name, status);
        RETURN;
      ELSE
        IF p_included_users = NIL THEN
          { All users are included
          non_administrated_user_included := TRUE;
        ELSE
          non_administrated_user_included := FALSE;

        /check_included_ranges/
          FOR range := 1 TO UPPERBOUND (p_included_users^) DO
            FOR low_or_high := clc$low TO clc$high DO
              IF user_identification.family <> p_included_users^ [range] [low_or_high] [pfc$family_name_index]
                    THEN
                non_administrated_user_included := TRUE;
                EXIT /check_included_ranges/;
              IFEND;
            FOREND;
          FOREND /check_included_ranges/;
        IFEND;
        IF non_administrated_user_included THEN
          osp$set_status_abnormal (puc$pf_utility_id, pue$unowned_users_included, request_name, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND pup$verify_system_administrator;

?? TITLE := '    bubble_sort_directory ', EJECT ??

  PROCEDURE bubble_sort_directory (unsorted_directory: pft$directory_array;
    VAR sorted_directory: pft$directory_array);

    { bubble sort

    VAR
      i: integer,
      local_entry: pft$directory_array_entry,
      exchange_done: boolean,
      number_of_times_repeated: integer;

    sorted_directory := unsorted_directory;
    number_of_times_repeated := 0;
    REPEAT
      exchange_done := FALSE;
      FOR i := 1 TO (UPPERBOUND (sorted_directory) - (number_of_times_repeated + 1)) DO
        IF sorted_directory [i].name > sorted_directory [i + 1].name THEN
          local_entry := sorted_directory [i];
          sorted_directory [i] := sorted_directory [i + 1];
          sorted_directory [i + 1] := local_entry;
          exchange_done := TRUE;
        IFEND;
      FOREND;
      number_of_times_repeated := number_of_times_repeated + 1;
    UNTIL NOT exchange_done;
  PROCEND bubble_sort_directory;

?? TITLE := '    compare_entries ', EJECT ??

  PROCEDURE compare_entries (put_entry_a: put$entry;
        put_entry_b: put$entry;
    VAR a_equals_b: boolean);

{   This compares two pf entries to determine if they are equal.

    a_equals_b := FALSE;
    IF put_entry_a.entry_type = put_entry_b.entry_type THEN
      CASE put_entry_a.entry_type OF
      = puc$valid_set_entry =
        a_equals_b := put_entry_a.set_name = put_entry_b.set_name;
      = puc$valid_family_entry =
        a_equals_b := put_entry_a.family_name = put_entry_b.family_name;
      = puc$valid_catalog_entry =
        a_equals_b := put_entry_a.catalog_name = put_entry_b.catalog_name;
      = puc$valid_pf_entry =
        a_equals_b := put_entry_a.pfn = put_entry_b.pfn;
      = puc$valid_cycle_entry =
        pup$compare_cycle_selectors (put_entry_a.pf_selector.cycle_selector, put_entry_b.pf_selector.
              cycle_selector, a_equals_b);
        a_equals_b := a_equals_b AND (put_entry_a.pf_selector.pfn = put_entry_b.pf_selector.pfn);
      ELSE
        a_equals_b := TRUE;
      CASEND;
    IFEND;
  PROCEND compare_entries;
MODEND pum$common_modules;
*DECK DECK=PUM$CRACK_VALUES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  crack_values ', EJECT ??
MODULE pum$crack_values;
{
{  This module contains to crack common parameters on backup and
{  restore subcommands.
{
?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc cld$value
*copyc cle$ecc_file_reference
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_parameter_list
*copyc cle$ecc_proc_declaration
*copyc clp$convert_cyc_ref_to_cyc_sel
*copyc clp$convert_str_to_path_handle
*copyc clp$get_fs_path_elements
*copyc clp$get_parameter
*copyc clp$get_path_description
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$test_range
*copyc clt$file_reference
*copyc fsc$local
*copyc fsp$convert_fs_structure_to_pf
*copyc fsp$evaluate_file_reference
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$date_time
*copyc ost$name
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pmp$get_user_identification
*copyc pud$cycle_reference
*copyc pue$error_condition_codes
*copyc pus$literals
*copyc put$user_range_list
*copyc rmd$volume_declarations
?? POP ??
?? TITLE := '    Global Variables', EJECT ??
?? TITLE := '    [XDCL] pup$crack_backup_file ', EJECT ??

  PROCEDURE [XDCL] pup$crack_backup_file
    (    file: fst$file_reference;
     VAR backup_file_phn: fst$path_handle_name;
     VAR status: ost$status);

{ The purpose of this routine is to crack a refernece of the type
{     <file>
{ Here the utility is only interested in obtaining an lfn, and does not
{ retain the path.
{ No file position may be specified.

    VAR
      evaluated_file_reference: fst$evaluated_file_reference;

    clp$convert_str_to_path_handle (file, FALSE {NOT delete_allowed} , FALSE {NOT resolve_path} , FALSE
          {NOT include_open_pos_in_handle} , backup_file_phn, evaluated_file_reference, status);
    IF status.normal THEN
      IF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_file_position, 'BACKUP_FILE', status);
      IFEND;
    IFEND;
  PROCEND pup$crack_backup_file;
?? TITLE := '    [XDCL] pup$crack_boolean ', EJECT ??

  PROCEDURE [XDCL] pup$crack_boolean
    (    parameter_name: string ( * );
     VAR boolean_value: boolean;
     VAR status: ost$status);

    VAR
      value: clt$value;

    boolean_value := TRUE;
    clp$get_value (parameter_name, 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    boolean_value := value.bool.value;
  PROCEND pup$crack_boolean;

?? TITLE := '    [XDCL] pup$crack_catalog ', EJECT ??

  PROCEDURE [XDCL] pup$crack_catalog
    (    parameter_name: string ( * );
     VAR path_container: clt$path_container;
     VAR p_path: ^pft$path;
     VAR status: ost$status);

{ The purpose of this routine is to crack a reference of the type
{     < catalog>
{ Callers are responsible for validating the length of the path returned.
{ No file position or cycle selector may be specified.
{

    VAR
      cycle_selector: pft$cycle_selector,
      cycle_selector_specified: boolean,
      value: clt$value;

    clp$get_value (parameter_name, 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind = clc$unknown_value THEN
      p_path := NIL;
      RETURN;
    IFEND;
    crack_path (value, parameter_name, pfc$family_name_index,
          $put$cycle_reference_selections [puc$cycle_omitted], path_container, p_path,
          cycle_selector_specified, cycle_selector, status);
  PROCEND pup$crack_catalog;
?? TITLE := '    [XDCL] pup$crack_file ', EJECT ??

  PROCEDURE [XDCL] pup$crack_file
    (    parameter_name: string ( * );
     VAR file_lfn: amt$local_file_name;
     VAR status: ost$status);

{ The purpose of this routine is to crack a refernece of the type
{     <file>
{ Here the utilities is only interested in obtaining a lfn, and does not
{ retain the path.
{ No file position may be specified.

    VAR
      cycle_selector: clt$cycle_selector,
      file_reference: clt$file_reference,
      open_position: clt$open_position,
      p_path: ^pft$path,
      path_container: clt$path_container,
      value: clt$value;

    clp$get_value (parameter_name, 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind = clc$unknown_value THEN
      p_path := NIL;
      RETURN;
    IFEND;
    clp$get_path_description (value.file, file_reference, path_container, p_path, cycle_selector,
          open_position, status);
    IF status.normal THEN
      IF open_position.specified THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_file_position, parameter_name, status);
      ELSE
        file_lfn := value.file.local_file_name;
      IFEND;
    IFEND;
  PROCEND pup$crack_file;
?? TITLE := '    [XDCL] pup$crack_file_reference ', EJECT ??

  PROCEDURE [XDCL] pup$crack_file_reference
    (    parameter_name: string ( * );
     VAR lfn: amt$local_file_name;
     VAR status: ost$status);

{ The purpose of this routine is to crack a reference of the type
{     < file reference>
{ All defaulting of file position and dealing of a path (if specified)
{ will be handled by the BAM file routines.
{

    VAR
      value: clt$value;

    clp$get_value (parameter_name, 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    lfn := value.file.local_file_name;
  PROCEND pup$crack_file_reference;
?? TITLE := '    [XDCL] pup$crack_name_list ', EJECT ??

  PROCEDURE [XDCL] pup$crack_name_list
    (    parameter_name: string ( * );
     VAR name_list_container: SEQ (REP 20 of ost$name);
     VAR p_name_list: ^array [1 .. * ] of ost$name;
     VAR status: ost$status);

    VAR
      i: integer,
      number_of_names: 0 .. clc$max_value_sets,
      p_name_list_container: ^SEQ (REP 20 of ost$name),
      value: clt$value;

    clp$get_set_count (parameter_name, number_of_names, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    p_name_list := NIL;
    IF number_of_names > 0 THEN
      IF number_of_names > (#SIZE (name_list_container) DIV #SIZE (ost$name)) THEN
        osp$set_status_abnormal (puc$pf_utility_id, cle$too_many_values, parameter_name, status);
        RETURN;
      ELSE
        p_name_list_container := ^name_list_container;
        RESET p_name_list_container;
        NEXT p_name_list: [1 .. number_of_names] IN p_name_list_container;
      IFEND;
    IFEND;
    FOR i := 1 TO number_of_names DO
      clp$get_value (parameter_name, i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      p_name_list^ [i] := value.name.value;
    FOREND;
  PROCEND pup$crack_name_list;
?? TITLE := '    [XDCL] pup$crack_password ', EJECT ??

  PROCEDURE [XDCL] pup$crack_password
    (    parameter_name: string ( * );
     VAR password: pft$password;
     VAR status: ost$status);

{  This routine defaults a password if it was not specified.

    VAR
      value: clt$value;

    clp$get_value (parameter_name, 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.name.value = 'NONE' THEN
      password := osc$null_name;
    ELSE
      password := value.name.value;
    IFEND;
  PROCEND pup$crack_password;
?? TITLE := '    [XDCL] pup$crack_permanent_file ', EJECT ??

  PROCEDURE [XDCL] pup$crack_permanent_file
    (    parameter_name: string ( * );
         allowed_cycle_references: put$cycle_reference_selections;
     VAR path_container: clt$path_container;
     VAR p_path: ^pft$path;
     VAR cycle_selector_specified: boolean;
     VAR cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

{ The purpose of this routine is to crack a reference of the type
{     < file>
{ Here the utility needs the path, and cycle selector.
{ No file position may be specified.
{ The path must contain at least pfc$master_catalog_name_index + 1
{ number of names.
{

    VAR
      value: clt$value;


    clp$get_value (parameter_name, 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind = clc$unknown_value THEN
      p_path := NIL;
      RETURN;
    IFEND;

    crack_path (value, parameter_name, pfc$master_catalog_name_index + 1, allowed_cycle_references,
          path_container, p_path, cycle_selector_specified, cycle_selector, status);
  PROCEND pup$crack_permanent_file;

?? TITLE := '    [XDCL] pup$crack_pf_file_reference ', EJECT ??

  PROCEDURE [XDCL] pup$crack_pf_file_reference
    (    file: fst$file_reference;
         allowed_cycle_references: put$cycle_reference_selections;
         parameter_name: string(*);
     VAR path_container: clt$path_container;
     VAR p_path: ^pft$path;
     VAR cycle_selector_specified: boolean;
     VAR cycle_selector: pft$cycle_selector;
     VAR status: ost$status);

{ The purpose of this routine is to crack a reference of the type
{     < file>
{ Here the utility needs the path, and cycle selector.
{ No file position may be specified.
{ The path must contain at least pfc$master_catalog_name_index + 1
{ number of names.
{

    VAR
      cl_cycle_selector: clt$cycle_selector,
      evaluated_file_reference: fst$evaluated_file_reference,
      maximum_path_elements_allowed: integer,
      p_path_container: ^clt$path_container;

    status.normal := TRUE;
    fsp$evaluate_file_reference (file, FALSE {NOT command_file_reference_allowed} , evaluated_file_reference,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter_name = 'CATALOG' THEN
      maximum_path_elements_allowed := pfc$master_catalog_name_index;
    ELSE
      maximum_path_elements_allowed := pfc$master_catalog_name_index + 1;
    IFEND;

    p_path_container := ^path_container;
    RESET p_path_container;
    NEXT p_path: [1 .. evaluated_file_reference.number_of_path_elements] IN p_path_container;
    fsp$convert_fs_structure_to_pf (evaluated_file_reference, p_path);

    IF p_path^ [1] = fsc$local THEN
      osp$set_status_abnormal (puc$pf_utility_id, cle$not_permitted_on_loc_file, 'backup or restore', status);
    ELSE
      IF (UPPERBOUND (p_path^)) < maximum_path_elements_allowed THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$path_too_short, parameter_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_path^ [1], status);
      ELSEIF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_file_position, 'FILE', status);
      ELSE
        clp$convert_cyc_ref_to_cyc_sel (evaluated_file_reference.cycle_reference, cl_cycle_selector);
        verify_cycle_selection (parameter_name, allowed_cycle_references, cl_cycle_selector, status);
        IF status.normal THEN
          cycle_selector_specified := cl_cycle_selector.specification <> clc$cycle_omitted;
          IF cycle_selector_specified THEN
            cycle_selector := cl_cycle_selector.value;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND pup$crack_pf_file_reference;
?? TITLE := '    [XDCL] pup$crack_user_range_list ', EJECT ??

  PROCEDURE [XDCL] pup$crack_user_range_list
    (    parameter_name: string ( * );
     VAR uncracked_parameter: ost$string;
     VAR list_container: put$user_range_list_container;
     VAR p_user_range_list: ^put$user_range_list;
     VAR status: ost$status);

    VAR
      all_specified: boolean,
      default_names: [STATIC, READ, pus$literals] array [clt$low_or_high] of ost$name :=
            [puc$default_low_name, puc$default_high_name],
      number_of_ranges_specified: 0 .. clc$max_value_sets,
      p_list_container: ^put$user_range_list_container,
      range_element: clt$low_or_high,
      user_range_index: 1 .. clc$max_value_sets,
      value: clt$value;

    clp$get_parameter (parameter_name, uncracked_parameter, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    check_first_value_for_all (parameter_name, number_of_ranges_specified, all_specified, status);
    IF (NOT status.normal) OR all_specified THEN
      p_user_range_list := NIL;
      RETURN;
    IFEND;

    p_list_container := ^list_container;
    RESET p_list_container;
    NEXT p_user_range_list: [1 .. number_of_ranges_specified] IN p_list_container;

    FOR user_range_index := 1 TO number_of_ranges_specified DO
      FOR range_element := clc$low TO clc$high DO
        clp$get_value (parameter_name, user_range_index, 1, range_element, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF value.kind <> clc$file_value THEN
          osp$set_status_abnormal (puc$pf_utility_id, cle$all_must_be_used_alone, parameter_name, status);
          RETURN;
        IFEND;
        get_user_path (parameter_name, value, default_names [range_element],
              p_user_range_list^ [user_range_index] [range_element], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
      {Verify that the low user is not greater alphabetically than the high
      IF (p_user_range_list^ [user_range_index] [clc$low] [pfc$family_name_index] >
            p_user_range_list^ [user_range_index] [clc$high] [pfc$family_name_index]) OR
            ((p_user_range_list^ [user_range_index] [clc$low] [pfc$family_name_index] =
            p_user_range_list^ [user_range_index] [clc$high] [pfc$family_name_index]) AND
            (p_user_range_list^ [user_range_index] [clc$low] [pfc$master_catalog_name_index] >
            p_user_range_list^ [user_range_index] [clc$high] [pfc$master_catalog_name_index])) THEN
        osp$set_status_abnormal (puc$pf_utility_id, cle$low_greater_than_high, parameter_name, status);
        RETURN;
      IFEND;
    FOREND;
  PROCEND pup$crack_user_range_list;

?? TITLE := '    [XDCL] pup$determine_if_all_selected ', EJECT ??

  PROCEDURE [XDCL] pup$determine_if_all_selected
    (    name_list: array [1 .. * ] of ost$name;
         parameter_name: string ( * );
     VAR all_selected: boolean;
     VAR status: ost$status);

    VAR
      i: integer;

    status.normal := TRUE;
    all_selected := name_list [1] = 'ALL';
    IF all_selected AND (UPPERBOUND (name_list) > 1) THEN
      osp$set_status_abnormal (puc$pf_utility_id, cle$all_must_be_used_alone, parameter_name, status);
      RETURN;
    IFEND;

    FOR i := 2 TO UPPERBOUND (name_list) DO
      IF name_list [i] = 'ALL' THEN
        osp$set_status_abnormal (puc$pf_utility_id, cle$all_must_be_used_alone, parameter_name, status);
        RETURN;
      IFEND;
    FOREND;
  PROCEND pup$determine_if_all_selected;

?? TITLE := '    [XDCL] pup$determine_if_none_selected ', EJECT ??

  PROCEDURE [XDCL] pup$determine_if_none_selected
    (    name_list: array [1 .. * ] of ost$name;
         parameter_name: string ( * );
     VAR none_selected: boolean;
     VAR status: ost$status);

    VAR
      i: integer;

    status.normal := TRUE;
    none_selected := name_list [1] = 'NONE';
    IF none_selected AND (UPPERBOUND (name_list) > 1) THEN
      osp$set_status_abnormal (puc$pf_utility_id, cle$none_must_be_used_alone, parameter_name, status);
      RETURN;
    IFEND;

    FOR i := 2 TO UPPERBOUND (name_list) DO
      IF name_list [i] = 'NONE' THEN
        osp$set_status_abnormal (puc$pf_utility_id, cle$none_must_be_used_alone, parameter_name, status);
        RETURN;
      IFEND;
    FOREND;
  PROCEND pup$determine_if_none_selected;
?? TITLE := '    check_first_value_for_all ', EJECT ??

  PROCEDURE check_first_value_for_all
    (    parameter_name: string ( * );
     VAR number_of_value_sets: 0 .. clc$max_value_sets;
     VAR all_specified: boolean;
     VAR status: ost$status);

    VAR
      range_specified: boolean,
      value: clt$value;

    all_specified := FALSE;
    clp$get_set_count (parameter_name, number_of_value_sets, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_value (parameter_name, 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (value.kind = clc$name_value) AND (value.name.value = 'ALL') THEN
      IF number_of_value_sets > 1 THEN
        osp$set_status_abnormal (puc$pf_utility_id, cle$all_must_be_used_alone, parameter_name, status);
      ELSE
        clp$test_range (parameter_name, 1, 1, range_specified, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        all_specified := NOT range_specified;
        IF range_specified THEN
          osp$set_status_abnormal (puc$pf_utility_id, cle$all_must_be_used_alone, parameter_name, status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND check_first_value_for_all;
?? TITLE := '    convert_cycle_selector ', EJECT ??

  PROCEDURE convert_cycle_selector
    (    cl_cycle_selector: clt$cycle_selector;
     VAR pu_cycle_selector: put$cycle_reference_options);

    CASE cl_cycle_selector.specification OF
    = clc$cycle_omitted =
      pu_cycle_selector := puc$cycle_omitted;
    = clc$cycle_specified =
      CASE cl_cycle_selector.value.cycle_option OF
      = pfc$lowest_cycle =
        pu_cycle_selector := puc$lowest_cycle;
      = pfc$highest_cycle =
        pu_cycle_selector := puc$highest_cycle;
      = pfc$specific_cycle =
        pu_cycle_selector := puc$specific_cycle;
      ELSE
      CASEND;
    = clc$cycle_next_highest =
      pu_cycle_selector := puc$next_highest_cycle;
    = clc$cycle_next_lowest =
      pu_cycle_selector := puc$next_lowest_cycle;
    ELSE
    CASEND;
  PROCEND convert_cycle_selector;
?? TITLE := '    convert_name_to_month ', EJECT ??

  PROCEDURE convert_name_to_month
    (    month_name: ost$name;
     VAR month_number: 1 .. 12);

    VAR
      names_of_the_month: [STATIC, READ, pus$literals] array [1 .. 12] of ost$name := ['JANUARY', 'FEBRUARY',
            'MARCH', 'APRIL', 'MAY', 'JUNE', 'JULY', 'AUGUST', 'SEPTEMBER', 'OCTOBER', 'NOVEMBER',
            'DECEMBER'];

    FOR month_number := 1 TO 12 DO
      IF names_of_the_month [month_number] = month_name THEN
        RETURN;
      IFEND;
    FOREND;
    month_number := 12;
  PROCEND convert_name_to_month;
?? TITLE := '    crack_path ', EJECT ??

  PROCEDURE crack_path
    (    value: clt$value;
         parameter_name: string ( * );
         minimum_path_length: pft$array_index;
         allowed_cycle_references: put$cycle_reference_selections;
     VAR path_container: clt$path_container;
     VAR p_path: ^pft$path;
     VAR cycle_selector_specified: boolean;
     VAR cycle_selector: pft$cycle_selector;
     VAR status: ost$status);


    VAR
      cl_cycle_selector: clt$cycle_selector,
      evaluated_file_reference: fst$evaluated_file_reference,
      p_path_container: ^clt$path_container;

    status.normal := TRUE;
    clp$get_fs_path_elements (value.file.local_file_name, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    p_path_container := ^path_container;
    RESET p_path_container;
    NEXT p_path: [1 .. evaluated_file_reference.number_of_path_elements] IN p_path_container;
    fsp$convert_fs_structure_to_pf (evaluated_file_reference, p_path);

    IF p_path^ [1] = fsc$local THEN
      osp$set_status_abnormal (puc$pf_utility_id, cle$not_permitted_on_loc_file, 'backup or restore', status);
    ELSE
      IF (UPPERBOUND (p_path^)) < minimum_path_length THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$path_too_short, parameter_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_path^ [1], status);
      ELSEIF evaluated_file_reference.path_handle_info.path_handle.open_position.specified THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_file_position, parameter_name, status);
      ELSE
        clp$convert_cyc_ref_to_cyc_sel (evaluated_file_reference.cycle_reference, cl_cycle_selector);
        verify_cycle_selection (parameter_name, allowed_cycle_references, cl_cycle_selector, status);
        IF status.normal THEN
          cycle_selector_specified := cl_cycle_selector.specification <> clc$cycle_omitted;
          IF cycle_selector_specified THEN
            cycle_selector := cl_cycle_selector.value;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND crack_path;


?? TITLE := '    get_user_path ', EJECT ??

  PROCEDURE get_user_path
    (    parameter_name: string ( * );
         value: clt$value;
         default_user_name: pft$name;
     VAR user_path: put$user_path;
     VAR status: ost$status);

    VAR
      cycle_selector: pft$cycle_selector,
      cycle_selector_specified: boolean,
      p_user_path: ^array [1 .. * ] of pft$name,
      user_path_container: clt$path_container;

    crack_path (value, parameter_name, 1, $put$cycle_reference_selections [puc$cycle_omitted],
          user_path_container, p_user_path, cycle_selector_specified, cycle_selector, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (UPPERBOUND (p_user_path^)) > pfc$master_catalog_name_index THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$path_too_long, parameter_name, status);
    ELSE { the path is ok to use }
      IF UPPERBOUND (p_user_path^) = pfc$master_catalog_name_index THEN
        user_path := p_user_path^;
      ELSE {default the user name}
        user_path [pfc$family_name_index] := p_user_path^ [pfc$family_name_index];
        user_path [pfc$master_catalog_name_index] := default_user_name;
      IFEND;
    IFEND;
  PROCEND get_user_path;

?? TITLE := '    verify_cycle_selection ', EJECT ??

  PROCEDURE verify_cycle_selection
    (    parameter_name: string ( * );
         allowed_cycle_selections: put$cycle_reference_selections;
         specified_cycle_selection: clt$cycle_selector;
     VAR status: ost$status);

    VAR
      cycle_selector: put$cycle_reference_options,
      cycle_selector_name_table: [STATIC, READ, pus$literals] array [put$cycle_reference_options] of
            ost$name := [' NO CYCLE REFERENCE', ' $LOW', ' $HIGH', ' A SPECIFIC CYCLE NUMBER', ' $NEXT',
            ' $NEXT_LOW'],
      check_set: put$cycle_reference_selections,
      delimiter: char,
      first_element: boolean,
      pu_cycle_selector: put$cycle_reference_options;

    status.normal := TRUE;
    IF allowed_cycle_selections = $put$cycle_reference_selections [] THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$bad_cycle_selections, parameter_name, status);
      RETURN;
    IFEND;
    convert_cycle_selector (specified_cycle_selection, pu_cycle_selector);
    IF NOT (pu_cycle_selector IN allowed_cycle_selections) THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$incorrect_cycle_reference,
            cycle_selector_name_table [pu_cycle_selector], status);
      delimiter := osc$status_parameter_delimiter;
      osp$append_status_parameter (delimiter, parameter_name, status);
      check_set := $put$cycle_reference_selections [];
      first_element := TRUE;
      FOR cycle_selector := LOWERVALUE (put$cycle_reference_options)
            TO UPPERVALUE (put$cycle_reference_options) DO
        IF cycle_selector IN allowed_cycle_selections THEN
          check_set := check_set + $put$cycle_reference_selections [cycle_selector];
          IF (check_set = allowed_cycle_selections) AND (NOT first_element) THEN
            delimiter := osc$status_parameter_delimiter;
            osp$append_status_parameter (delimiter, ' or ', status);
          IFEND;
          first_element := FALSE;
          osp$append_status_parameter (delimiter, cycle_selector_name_table [cycle_selector], status);
          delimiter := ',';
        IFEND;
      FOREND;
    IFEND;
  PROCEND verify_cycle_selection;

MODEND pum$crack_values;
*DECK DECK=PUM$DATA_FILE EXPAND=TRUE
*copyc osd$default_pragmats
?? RIGHT := 110 ??
??
NEWTITLE := ' NOS/VE Backup/Restore Utilities:  data_file ', EJECT ??
MODULE pum$data_file;
{
{
{   This module provides procedures to process the "data file".
{ The data file is a binary form output of a backup listing.
{ To select a data file, the user should issue the select_data_file
{ request prior to a backup subcommand.
{   The data file currently really only provides a mapping being global_file_name
{ and full path name.  Thus one may run this and save the data file, and later
{ query the data file looking for a specific global_file_name either by
{ the pup$find_stored_file_gfn cybil interface, or the search_data_file
{ subcommand of restore.  Please note:  the search_data_file subcommand
{ is not very robust about improper input, so be carefull.
{
?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amp$close
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amt$local_file_name
*copyc clp$convert_string_to_integer
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc pfd$permanent_file_definitions
*copyc pfp$get_family_set
*copyc pmp$convert_unique_to_binary
*copyc pud$backup_file
*copyc pue$error_condition_codes
*copyc pup$convert_gfn_to_string
*copyc pup$crack_file_reference
*copyc pup$write_cycle_selector
*copyc pup$write_path
?? POP ??
?? TITLE := '    Global Variables', EJECT ??

  VAR
    puv$data_file_selected: [XDCL, STATIC] boolean := FALSE,
    gfn_file: [STATIC] amt$local_file_name := 'GFNFILE                        ',
    p_sequence: [STATIC] ^SEQ ( * ) := NIL,
    p_number_of_cycles: [STATIC] ^integer := NIL;

  CONST
    puc$current_data_file_version = 'BACKUP_DATA_FILE_VERSION_001   ';

?? TITLE := '    pup$find_stored_file_gfn ', EJECT ??

  PROCEDURE pup$find_stored_file_gfn (gfn_file: amt$local_file_name;
        gfn: ost$binary_unique_name;
    VAR path_container: SEQ (REP 2000 OF cell);
    VAR cycle_selector: pft$cycle_selector;
    VAR status: ost$status);

    VAR
      file_id: amt$file_identifier,
      gfn_found: boolean,
      gfn_string: string (60),
      i: integer,
      local_status: ost$status,
      p_container: ^SEQ (REP 2000 of cell),
      p_gfn: ^ost$binary_unique_name,
      p_item_descriptor: ^put$backup_item_descriptor,
      p_number_of_cycles: ^integer,
      p_path: ^pft$path,
      p_path_length: ^integer,
      p_record_header: ^put$backup_file_record_header,
      p_version: ^ost$name,
      segment: amt$segment_pointer;

    gfn_found := FALSE;
    amp$open (gfn_file, amc$segment, NIL, file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_id, amc$sequence_pointer, segment, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET segment.sequence_pointer;
    NEXT p_version IN segment.sequence_pointer;
    IF p_version = NIL THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$nil_data_file_pointer, 'NIl version', status);
      RETURN;
    ELSEIF (p_version^ <> puc$current_data_file_version) THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$incompatible_backup_version, p_version^, status);
      RETURN;
    IFEND;
    NEXT p_number_of_cycles IN segment.sequence_pointer;
    IF p_number_of_cycles = NIL THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$nil_data_file_pointer, 'NIL cycles', status);
    ELSE

    /search_file/
      FOR i := 1 TO p_number_of_cycles^ DO
        NEXT p_gfn IN segment.sequence_pointer;
        IF p_gfn = NIL THEN
          osp$set_status_abnormal (puc$pf_utility_id, pue$nil_data_file_pointer, ' NIL GFN', status);
          EXIT /search_file/;
        IFEND;
        NEXT p_record_header IN segment.sequence_pointer;
        IF p_record_header = NIL THEN
          osp$set_status_abnormal (puc$pf_utility_id, pue$nil_data_file_pointer, ' NIL record_header',
                status);
          EXIT /search_file/;
        IFEND;
        NEXT p_item_descriptor: [1 .. p_record_header^.size] IN segment.sequence_pointer;
        IF p_item_descriptor = NIL THEN
          osp$set_status_abnormal (puc$pf_utility_id, pue$nil_data_file_pointer, ' NIL item_descriptor',
                status);
          EXIT /search_file/;
        IFEND;
        IF p_gfn^ = gfn THEN
          gfn_found := TRUE;
          p_container := ^path_container;
          RESET p_container;
          NEXT p_path_length IN p_container;
          p_path_length^ := p_record_header^.size;
          NEXT p_path: [1 .. p_path_length^] IN p_container;
          IF p_path = NIL THEN
            osp$set_status_abnormal (puc$pf_utility_id, pue$nil_data_file_pointer, ' NIL path', status);
            EXIT /search_file/;
          IFEND;
          p_path^ := p_item_descriptor^.catalog_header.path;
          cycle_selector := p_item_descriptor^.pf_utility_entry.pf_selector.cycle_selector;
          status.normal := TRUE;
          EXIT /search_file/;
        IFEND;
      FOREND /search_file/;
    IFEND;
    IF status.normal AND NOT gfn_found THEN
      pup$convert_gfn_to_string (gfn, gfn_string);
      osp$set_status_abnormal (puc$pf_utility_id, pue$unknown_gfn, gfn_string, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, gfn_file, status);
    IFEND;
    amp$close (file_id, local_status);
  PROCEND pup$find_stored_file_gfn;

?? TITLE := '    [XDCL] pup$search_data_file ', EJECT ??

  PROCEDURE [XDCL] pup$search_data_file (parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? RIGHT := 110 ??
{ pdt search_data_file (global_file_name, gfn:name = $required
{  data_file, df: file = $local.gfnfile
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      search_data_file: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^search_data_file_names,
        ^search_data_file_params];

    VAR
      search_data_file_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
        clt$parameter_name_descriptor := [['GLOBAL_FILE_NAME', 1], ['GFN', 1], ['DATA_FILE', 2], ['DF', 2],
        ['STATUS', 3]];

    VAR
      search_data_file_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor
        := [

{ GLOBAL_FILE_NAME GFN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ DATA_FILE DF }
      [[clc$optional_with_default, ^search_data_file_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      search_data_file_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (14) := '$local.gfnfile';

?? POP ??

    VAR
      cycle_selector: pft$cycle_selector,
      gfn_file: amt$local_file_name,
      global_file_name: ost$binary_unique_name,
      p_container: ^SEQ (REP 2000 of cell),
      p_path: ^pft$path,
      p_path_length: ^integer,
      path_container: SEQ (REP 2000 of cell),
      value: clt$value;

    clp$scan_parameter_list (parameter_list, search_data_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('GLOBAL_FILE_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pmp$convert_unique_to_binary (value.name.value, global_file_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_file_reference ('DATA_FILE', gfn_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$find_stored_file_gfn (gfn_file, global_file_name, path_container, cycle_selector, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    p_container := ^path_container;
    RESET p_container;
    NEXT p_path_length IN p_container;
    NEXT p_path: [1 .. p_path_length^] IN p_container;

    pup$write_path (p_path^, status);
    pup$write_cycle_selector (cycle_selector, status);
  PROCEND pup$search_data_file;

?? TITLE := '    [XDCL] pup$select_data_file ', EJECT ??

  PROCEDURE [XDCL] pup$select_data_file (parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? RIGHT := 110 ??
{ PDT select_data_file_pdt (data_file, df: file = $local.gfnfile
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      select_data_file_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^select_data_file_pdt_names, ^select_data_file_pdt_params];

    VAR
      select_data_file_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['DATA_FILE', 1], ['DF', 1], ['STATUS', 2]];

    VAR
      select_data_file_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
        clt$parameter_descriptor := [

{ DATA_FILE DF }
      [[clc$optional_with_default, ^select_data_file_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      select_data_file_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (14) := '$local.gfnfile';

?? POP ??

    VAR
      gfn_file_id: amt$file_identifier,
      segment: amt$segment_pointer,
      p_version: ^ost$name;

    clp$scan_parameter_list (parameter_list, select_data_file_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF puv$data_file_selected THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$data_file_already_selected, gfn_file, status);
      RETURN;
    IFEND;

    pup$crack_file_reference ('DATA_FILE', gfn_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (gfn_file, amc$segment, NIL, gfn_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (gfn_file_id, amc$sequence_pointer, segment, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    puv$data_file_selected := TRUE;
    RESET segment.sequence_pointer;
    p_sequence := segment.sequence_pointer;
    NEXT p_version IN p_sequence;
    IF p_version = NIL THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$nil_data_file_pointer, ' NIL version', status);
      RETURN;
    IFEND;
    p_version^ := puc$current_data_file_version;
    NEXT p_number_of_cycles IN p_sequence;
    IF p_number_of_cycles = NIL THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$nil_data_file_pointer, 'NIL cycles', status);
    ELSE
      p_number_of_cycles^ := 0;
    IFEND;
  PROCEND pup$select_data_file;


?? TITLE := '    [XDCL] pup$store_file_gfn ', EJECT ??

  PROCEDURE [XDCL] pup$store_file_gfn (gfn: ost$binary_unique_name;
        path: pft$path;
        cycle_selector: pft$cycle_selector;
    VAR status: ost$status);

    VAR
      p_gfn: ^ost$binary_unique_name,
      p_item_descriptor: ^put$backup_item_descriptor,
      p_record_header: ^put$backup_file_record_header,
      set_name: stt$set_name;

    status.normal := TRUE;

    pfp$get_family_set (path [pfc$family_name_index], set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_number_of_cycles = NIL THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$nil_data_file_pointer,
        ' p_number_of_cycles NIL in pup$store_file_gfn', status);
      RETURN;
    IFEND;
    p_number_of_cycles^ := p_number_of_cycles^ + 1;

    NEXT p_gfn IN p_sequence;
    IF p_gfn = NIL THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$nil_data_file_pointer, ' p_gfn ', status);
      RETURN;
    IFEND;
    p_gfn^ := gfn;

    NEXT p_record_header IN p_sequence;
    IF p_record_header = NIL THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$nil_data_file_pointer, ' p_record_header ', status);
      RETURN;
    IFEND;
    p_record_header^.size := UPPERBOUND (path);
    p_record_header^.kind := puc$backup_item_identifier;

    NEXT p_item_descriptor: [1 .. UPPERBOUND (path)] IN p_sequence;
    IF p_item_descriptor = NIL THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$nil_data_file_pointer, ' p_item_descriptor ', status);
      RETURN;
    IFEND;
    p_item_descriptor^.pf_utility_entry.entry_type := puc$valid_cycle_entry;
    p_item_descriptor^.pf_utility_entry.pf_selector.pfn := path [UPPERBOUND (path)];
    p_item_descriptor^.pf_utility_entry.pf_selector.cycle_selector := cycle_selector;

    p_item_descriptor^.catalog_header.set_name := set_name;
    p_item_descriptor^.catalog_header.logical_path_length := UPPERBOUND (path);
    p_item_descriptor^.catalog_header.path := path;
  PROCEND pup$store_file_gfn;

MODEND pum$data_file;
*DECK DECK=PUM$DELETE_ALL EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  delete_all ', EJECT ??
MODULE pum$delete_all;

?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amp$return
*copyc amt$local_file_name
*copyc cld$parameter_list
*copyc cld$value
*copyc clp$get_value
*copyc clp$evaluate_parameters
*copyc clp$scan_parameter_list
*copyc dmp$get_stored_fmd_header_info
*copyc dmp$get_stored_fmd_volume_list
*copyc jmp$system_job
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$name
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfp$find_cycle_array_extended
*copyc pfp$find_cycle_directory
*copyc pfp$find_cycle_media
*copyc pfp$find_direct_info_record
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_family_info
*copyc pfp$get_family_set
*copyc pfp$get_item_info
*copyc pfp$get_master_catalog_info
*copyc pfp$get_multi_item_info
*copyc pfp$get_set_list
*copyc pfp$log_status
*copyc pfp$purge
*copyc pfp$purge_catalog
*copyc pfp$purge_master_catalog
*copyc pfp$utility_attach
*copyc pft$file_media_description
*copyc pmp$get_job_mode
*copyc pmp$get_user_identification
*copyc pmp$get_unique_name
*copyc puc$delete_all_files_message
*copyc pud$hierarchy_list
*copyc pue$error_condition_codes
*copyc pup$all_volumes_included
*copyc pup$allow_job_termination
*copyc pup$build_catalog_header
*copyc pup$build_entry
*copyc pup$build_new_path
*copyc pup$check_cycle_inclusion
*copyc pup$check_if_family_in_range
*copyc pup$check_if_item_excluded
*copyc pup$check_if_size_included
*copyc pup$check_if_user_in_range
*copyc pup$check_if_volume_included
*copyc pup$crack_boolean
*copyc pup$crack_catalog
*copyc pup$crack_pf_file_reference
*copyc pup$display_blank_lines
*copyc pup$display_boolean
*copyc pup$display_excluded_item
*copyc pup$display_integer
*copyc pup$display_line
*copyc pup$get_cycle_array_version_2
*copyc pup$get_file_attributes
*copyc pup$get_file_password
*copyc pup$get_summary_status
*copyc pup$initialize_summary_status
*copyc pup$sort_cycle_array_version_2
*copyc pup$sort_directory
*copyc pup$verify_family_administrator
*copyc pup$verify_file_path
*copyc pup$verify_system_administrator
*copyc pup$write_cycle_display_header
*copyc pup$write_cycle_selector
*copyc pup$write_deleted_cycle
*copyc pup$write_excluded_cycle
*copyc pup$write_os_status
*copyc pup$write_path
*copyc pup$write_status_to_listing
*copyc put$user_range_list
*copyc puv$p_user_range_list
*copyc puv$backup_information
*copyc puv$cycle_display_selections
*copyc puv$sort_users
*copyc rap$prompt_via_menu
?? POP ??
?? TITLE := '    Global Variables', EJECT ??

  VAR
    delete_catalogs: boolean := FALSE,
    delete_master_catalogs: boolean := FALSE;

  VAR
    exclude_highest_cycles: 0 .. pfc$maximum_cycle_number := 0;

  VAR
    total_bytes_deleted: integer := 0,
    number_of_cycles_deleted: integer := 0;


?? TITLE := '    [XDCL] pup$delete_all_files_cm ', EJECT ??

  PROCEDURE [XDCL] pup$delete_all_files_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE (osm$delaf) delete_all_files (
{    delete_confirmation, dc: boolean = $optional
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 5, 1, 13, 8, 48, 90],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$DELAF'], [
    ['DC                             ',clc$abbreviation_entry, 1],
    ['DELETE_CONFIRMATION            ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$delete_confirmation = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      cset: stt$number_of_sets,
      ignore_status: ost$status,
      job_mode: jmt$job_mode,
      local_status: ost$status,
      menu_selections_p: ^array [*] of ost$name,
      number_of_sets: stt$number_of_sets,
      selection_chosen: ost$name,
      set_list: ^stt$set_list;

    pup$verify_system_administrator ('DELETE_ALL_FILES               ', puv$p_user_range_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_job_mode (job_mode, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (pvt [p$delete_confirmation].specified AND
          pvt [p$delete_confirmation].value^.boolean_value.value AND
          (jmp$system_job() OR (job_mode <> jmc$batch))) OR
          (NOT pvt [p$delete_confirmation].specified AND
          (jmp$system_job() OR (job_mode <> jmc$batch))) THEN

{ Display a menu to the operator to confirm the deletion of all files.

      PUSH menu_selections_p: [1..2];
      menu_selections_p^ [1] := 'CONTINUE_REQUEST';
      menu_selections_p^ [2] := 'TERMINATE_REQUEST';
      rap$prompt_via_menu ({ menu_module } puc$delete_all_files_message, menu_selections_p^,
            { menu_parameters } NIL, { prompting_option } $rat$prompting_options[],
            selection_chosen, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF selection_chosen = 'TERMINATE_REQUEST' THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$delaf_command_terminated, ' ', status);
        RETURN;
      IFEND;
    IFEND;
    pup$display_line (' DELETE_ALL_FILES ', status);
    pup$initialize_summary_status;
    total_bytes_deleted := 0;
    number_of_cycles_deleted := 0;
    pup$write_cycle_display_header (status);
    number_of_sets := 20;
    FOR cset := 1 TO 2 DO
      PUSH set_list: [1 .. number_of_sets];
      pfp$get_set_list (set_list^, number_of_sets, status);
    FOREND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    FOR cset := 1 TO number_of_sets DO
      pup$delete_set_contents (set_list^ [cset], delete_catalogs, status);
    FOREND;
    display_deletion_totals;
    pup$get_summary_status (status);

{ Return an informative message in the job and system logs to report the execution of a
{ DELETE_ALL_FILES subcommand of BACKUP_PERMANENT_FILES.

    osp$set_status_abnormal (puc$pf_utility_id, pue$delete_all_files_completed, ' ', local_status);
    pfp$log_status ($pmt$ascii_logset [pmc$system_log, pmc$job_log], local_status);
  PROCEND pup$delete_all_files_cm;
?? TITLE := '    pup$delete_catalog_contents ', EJECT ??

  PROCEDURE pup$delete_catalog_contents
    (    path: pft$path;
         delete_catalogs: boolean;
     VAR status: ost$status);

    VAR
      dummy_cycle_selector: pft$cycle_selector,
      entry: put$entry,
      group: pft$group,
      index: integer,
      item_excluded: boolean,
      local_status: ost$status,
      p_catalog_header: ^put$catalog_header,
      p_directory_array: pft$p_directory_array,
      p_info_record: pft$p_info_record,
      p_new_path: ^pft$path,
      password: pft$password,
      segment_pointer: amt$segment_pointer,
      set_name: stt$set_name;


    pfp$get_family_set (path [pfc$family_name_index], set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$write_path (path, status);
    IF status.normal THEN
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, segment_pointer, status);
      IF status.normal THEN
        group.group_type := pfc$public;
        pfp$get_multi_item_info (path, group, $pft$catalog_info_selections
              [pfc$catalog_directory, pfc$catalog_description], $pft$file_info_selections
              [pfc$file_directory, pfc$file_description], segment_pointer.sequence_pointer, status);
        IF status.normal THEN
          RESET segment_pointer.sequence_pointer;
          pfp$find_next_info_record (segment_pointer.sequence_pointer, p_info_record, status);
          IF status.normal THEN
            pfp$find_directory_array (p_info_record, p_directory_array, status);
            IF status.normal AND (p_directory_array <> NIL) THEN
              PUSH p_catalog_header: [1 .. UPPERBOUND (path) + 1];
              PUSH p_new_path: [1 .. (UPPERBOUND (path) + 1)];
              FOR index := LOWERBOUND (p_directory_array^) TO UPPERBOUND (p_directory_array^) DO
                CASE p_directory_array^ [index].name_type OF
                = pfc$file_name =
                  pup$allow_job_termination;
                  pup$build_new_path (path, p_directory_array^ [index].name, p_new_path^);
                  pup$build_catalog_header (set_name, p_new_path, p_catalog_header^);
                  pup$build_entry (p_directory_array^ [index].name, dummy_cycle_selector, puc$valid_pf_entry,
                        entry);
                  pup$check_if_item_excluded (entry, p_catalog_header^, item_excluded);
                  IF item_excluded THEN
                    pup$display_excluded_item (entry, p_catalog_header^, status);
                  ELSE
                    pup$get_file_password (p_new_path^, password);
                    pup$delete_file_contents (p_new_path^, password, status);
                    pup$write_os_status (status, local_status);
                    status.normal := TRUE;
                  IFEND;
                ELSE
                CASEND;
              FOREND;

              FOR index := LOWERBOUND (p_directory_array^) TO UPPERBOUND (p_directory_array^) DO
                CASE p_directory_array^ [index].name_type OF
                = pfc$catalog_name =
                  pup$allow_job_termination;
                  pup$build_new_path (path, p_directory_array^ [index].name, p_new_path^);
                  pup$build_catalog_header (set_name, p_new_path, p_catalog_header^);
                  pup$build_entry (p_directory_array^ [index].name, dummy_cycle_selector,
                        puc$valid_catalog_entry, entry);
                  pup$check_if_item_excluded (entry, p_catalog_header^, item_excluded);
                  IF item_excluded THEN
                    pup$display_excluded_item (entry, p_catalog_header^, status);
                  ELSE
                    pup$delete_catalog_contents (p_new_path^, delete_catalogs, status);
                    pup$write_os_status (status, local_status);
                    status.normal := TRUE;
                  IFEND;
                ELSE
                CASEND;
              FOREND;
            IFEND;
          IFEND;
        IFEND;
        mmp$delete_scratch_segment (segment_pointer, local_status);
      IFEND;
      IF status.normal THEN
        IF UPPERBOUND (path) > pfc$master_catalog_name_index THEN
          IF delete_catalogs THEN
            pfp$purge_catalog (path, status);
            IF status.normal THEN
              pup$display_line ('-- catalog DELETED ', status);
            IFEND;
          ELSE
            pup$display_line (' --catalog NOT deleted', local_status);
          IFEND;
        ELSE
          IF delete_master_catalogs THEN
            pfp$purge_master_catalog (set_name, path [pfc$family_name_index],
                  path [pfc$master_catalog_name_index], status);
            IF status.normal THEN
              pup$display_line (' -- MASTER CATALOG DELETED', status);
            ELSE
              pup$write_os_status (status, status);
            IFEND;
          ELSE
            pup$display_line (' -- MASTER CATALOG NOT DELETED', status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    pup$write_os_status (status, local_status);
  PROCEND pup$delete_catalog_contents;
?? TITLE := '    [XDCL] pup$delete_catalog_contents_cm ', EJECT ??

  PROCEDURE [XDCL] pup$delete_catalog_contents_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt del_catalog_contents_pdt (
{ catalog,c:file=$required
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      del_catalog_contents_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^del_catalog_contents_pdt_names, ^del_catalog_contents_pdt_params];

    VAR
      del_catalog_contents_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['CATALOG', 1], ['C', 1], ['STATUS', 2]];

    VAR
      del_catalog_contents_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ CATALOG C }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      local_status: ost$status,
      path_container: clt$path_container,
      p_path: ^pft$path,
      set_name: stt$set_name;

    clp$scan_parameter_list (parameter_list, del_catalog_contents_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_catalog ('CATALOG', path_container, p_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF UPPERBOUND (p_path^) = pfc$family_name_index THEN
      pup$verify_family_administrator ('DELETE_CATALOG_CONTENTS', p_path^ [pfc$family_name_index], status);
      IF NOT status.normal THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, ' to delete a family', status);
      IFEND;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$get_family_set (p_path^ [pfc$family_name_index], set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$display_line (' DELETE_CATALOG_CONTENTS', status);
    pup$write_path (p_path^, status);
    pup$write_cycle_display_header (status);
    pup$initialize_summary_status;
    total_bytes_deleted := 0;
    number_of_cycles_deleted := 0;
    IF UPPERBOUND (p_path^) = pfc$family_name_index THEN
      delete_family_contents (set_name, p_path^ [pfc$family_name_index], delete_catalogs, status);
    ELSE
      pup$delete_catalog_contents (p_path^, delete_catalogs, status);
    IFEND;
    display_deletion_totals;
    pup$get_summary_status (status);
  PROCEND pup$delete_catalog_contents_cm;


?? TITLE := '    [XDCL] pup$delete_file_command ', EJECT ??

  PROCEDURE [XDCL] pup$delete_file_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      p_path: ^pft$path,
      password: pft$password,
      path_container: clt$path_container;


    crack_delete_file (parameter_list, path_container, p_path, password, status);
    IF status.normal THEN
      pup$verify_file_path (p_path^, status);
      IF status.normal THEN
        pup$display_line (' DELETE_FILE_CONTENTS', status);
        pup$write_path (p_path^, status);
        pup$write_cycle_display_header (status);
        pup$initialize_summary_status;
        total_bytes_deleted := 0;
        number_of_cycles_deleted := 0;
        pup$delete_file_contents (p_path^, password, status);
        display_deletion_totals;
        pup$get_summary_status (status);
        pup$write_os_status (status, local_status);
      IFEND;
    IFEND;
  PROCEND pup$delete_file_command;

?? TITLE := '    pup$delete_file_contents ', EJECT ??

  PROCEDURE pup$delete_file_contents
    (    path: pft$path;
         password: pft$password;
     VAR status: ost$status);

    VAR
      action_descriptor: put$action_descriptor,
      any_cycle_deleted: boolean,
      cycle_included: boolean,
      cycle_selector: pft$cycle_selector,
      data_resides_offline: boolean,
      entry: put$entry,
      file_id: amt$file_identifier,
      fmd_header: pft$fmd_header,
      gfn: ost$binary_unique_name,
      group: pft$group,
      index: pft$cycle_count,
      length: amt$file_length,
      local_status: ost$status,
      output_line: string (78),
      p_catalog_header: ^put$catalog_header,
      p_cycle_array: ^pft$cycle_array_version_2,
      p_cycle_array_extended_record: pft$p_info_record,
      p_cycle_directory_array: pft$p_cycle_directory_array,
      p_cycle_info_record: pft$p_info_record,
      p_cycle_media_description: pft$p_file_media_description,
      p_info_record: pft$p_info_record,
      p_volume_list: ^pft$volume_list,
      set_name: stt$set_name,
      sequence_pointer: amt$segment_pointer;

    pfp$get_family_set (path [pfc$family_name_index], set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_line := '';
    output_line (5, * ) := path [UPPERBOUND (path)];
    pup$display_line (output_line, local_status);
    PUSH p_catalog_header: [1 .. UPPERBOUND (path)];
    pup$build_catalog_header (set_name, ^path, p_catalog_header^);
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, sequence_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /delete_file_contents/
    BEGIN
      group.group_type := pfc$public;
      pfp$get_item_info (path, group, $pft$catalog_info_selections [],
            $pft$file_info_selections [pfc$file_directory, pfc$file_cycles_version_2,
            pfc$cycle_media_descriptor], sequence_pointer.sequence_pointer, status);
      IF NOT status.normal THEN
        EXIT /delete_file_contents/;
      IFEND;
      pup$get_cycle_array_version_2 (sequence_pointer.sequence_pointer, p_cycle_array, p_info_record, status);
      IF (NOT status.normal) OR (p_cycle_array = NIL) THEN
        EXIT /delete_file_contents/;
      IFEND;

      any_cycle_deleted := FALSE;
      pfp$find_cycle_array_extended (p_info_record, p_cycle_array_extended_record, status);
      IF NOT status.normal THEN
        EXIT /delete_file_contents/;
      IFEND;

      pfp$find_cycle_directory (p_cycle_array_extended_record, p_cycle_directory_array, status);
      IF NOT status.normal THEN
        EXIT /delete_file_contents/;
      IFEND;

      IF pup$excluded_highest_cycles () > 0 THEN
        pup$sort_cycle_array_version_2 (p_cycle_array^);
      IFEND;

    /delete_all_cycles/
      FOR index := LOWERBOUND (p_cycle_array^) TO (UPPERBOUND (p_cycle_array^)) DO
        cycle_selector.cycle_option := pfc$specific_cycle;
        cycle_selector.cycle_number := p_cycle_array^ [index].cycle_number;
        pup$build_entry (path [UPPERBOUND (path)], cycle_selector, puc$valid_cycle_entry, entry);
        pup$check_cycle_inclusion (p_catalog_header^, entry, p_cycle_array^, index, cycle_included,
              action_descriptor);
        IF cycle_included THEN
          {
          { This code takes advantage of the fact that the cycle array and the
          { cycle directory array contain the same cycle numbers in the same order.
          {
          pfp$find_direct_info_record (^p_cycle_array_extended_record^.body,
                p_cycle_directory_array^ [index].info_offset, p_cycle_info_record, status);
          IF NOT status.normal THEN
            EXIT /delete_file_contents/;
          IFEND;

          pfp$find_cycle_media (p_cycle_info_record, p_cycle_media_description, status);
          IF status.normal THEN
            {
            { Get the volume list from the fmd if needed.
            { Determine if the cycle is excluded from this backup by a previous
            { INCLUDE_VOLUMES command.
            {
            IF (p_cycle_array^ [index].device_class = rmc$mass_storage_device) AND
                  ((puc$cdo_recorded_vsn IN puv$cycle_display_selections) OR
                  (NOT pup$all_volumes_included ())) THEN
              dmp$get_stored_fmd_header_info (^p_cycle_media_description^.file_media_descriptor, fmd_header,
                    status);
              IF NOT status.normal THEN
                EXIT /delete_file_contents/;
              IFEND;

              PUSH p_volume_list: [1 .. fmd_header.number_of_subfiles];
              dmp$get_stored_fmd_volume_list (^p_cycle_media_description^.file_media_descriptor,
                    p_volume_list, status);
              IF NOT status.normal THEN
                EXIT /delete_file_contents/;
              IFEND;

              pup$check_if_volume_included (p_volume_list, cycle_included);
              IF NOT cycle_included THEN
                action_descriptor := 'EXCLUDE VOLUME';
              IFEND;
            IFEND;
          ELSE { pfp$find_cycle_media failed.
            IF status.condition = pfe$unknown_cycle_media THEN
              cycle_included := TRUE;
              status.normal := TRUE;
              p_volume_list := NIL;
            ELSE
              EXIT /delete_file_contents/;
            IFEND;
          IFEND;

          IF cycle_included THEN
            check_attached_file_attributes (path, cycle_selector, password, p_cycle_array^[index], gfn,
                  length, cycle_included, data_resides_offline, action_descriptor, status);
            IF status.normal AND cycle_included AND data_resides_offline THEN
              length := puc$released_cycle_size;
              PUSH p_volume_list: [1 .. 1];
              p_volume_list^ [1] := puc$nonexistent_recorded_vsn;

{ Call pup$check_if_volume_included to see if the user has issued the include_volume command
{ within this BACPF session.

              pup$check_if_volume_included (p_volume_list, cycle_included);
              IF NOT cycle_included THEN
                action_descriptor := 'EXCLUDE VOLUME';
              IFEND;
            IFEND;
          IFEND;

          IF status.normal THEN
            IF cycle_included THEN
              pfp$purge (path, cycle_selector, password, status);
              IF NOT status.normal THEN
                EXIT /delete_all_cycles/;
              IFEND;
              any_cycle_deleted := TRUE;
              IF length <> puc$released_cycle_size THEN
                total_bytes_deleted := total_bytes_deleted + length;
              IFEND;
              number_of_cycles_deleted := number_of_cycles_deleted + 1;
              pup$write_deleted_cycle (entry, p_cycle_array^ [index], length, gfn, p_volume_list,
                     p_cycle_array_extended_record, p_cycle_directory_array, status);
            ELSE
              pup$write_excluded_cycle (entry, p_cycle_array^ [index], length, gfn, p_volume_list,
                    p_cycle_array_extended_record, p_cycle_directory_array,
                    action_descriptor, status);
            IFEND;
          ELSE
            pup$write_status_to_listing (entry, status, local_status);
          IFEND;
        ELSE
          pup$write_excluded_cycle (entry, p_cycle_array^ [index], puc$unknown_cycle_size,
                puv$unknown_global_file_name, {recorded vsn} NIL, p_cycle_array_extended_record,
                p_cycle_directory_array, action_descriptor, status);
        IFEND;
      FOREND /delete_all_cycles/;
    END /delete_file_contents/;

    mmp$delete_scratch_segment (sequence_pointer, local_status);

    IF NOT any_cycle_deleted THEN
      pup$display_line ('       No cycles deleted', local_status);
    IFEND;
  PROCEND pup$delete_file_contents;

?? TITLE := '    pup$delete_set_contents ', EJECT ??

  PROCEDURE pup$delete_set_contents
    (    set_name: stt$set_name;
         delete_catalogs: boolean;
     VAR status: ost$status);

    VAR
      dummy_cycle_selector: pft$cycle_selector,
      family_entry: put$entry,
      family_excluded: boolean,
      family_in_range: boolean,
      family_info: amt$segment_pointer,
      family_path: array [1 .. 1] of pft$name,
      i: put$half_integer,
      local_status: ost$status,
      p_family_catalog_header: ^put$catalog_header,
      p_family_directory: pft$p_directory_array,
      p_info_record: pft$p_info_record;

    status.normal := TRUE;
    local_status.normal := TRUE;
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, family_info, status);
    IF status.normal THEN
      RESET family_info.sequence_pointer;
      pfp$get_family_info (set_name, $pft$catalog_info_selections
            [pfc$catalog_directory, pfc$catalog_description], family_info.sequence_pointer, status);
      IF status.normal THEN
        RESET family_info.sequence_pointer;
        pfp$find_next_info_record (family_info.sequence_pointer, p_info_record, status);
        IF status.normal THEN
          pfp$find_directory_array (p_info_record, p_family_directory, status);
          IF status.normal AND (p_family_directory <> NIL) THEN
            PUSH p_family_catalog_header: [1 .. 1];
            FOR i := LOWERBOUND (p_family_directory^) TO UPPERBOUND (p_family_directory^) DO
              pup$check_if_family_in_range (p_family_directory^ [i].name, family_in_range);
              IF family_in_range THEN
                family_path [pfc$family_name_index] := p_family_directory^ [i].name;
                pup$build_entry (p_family_directory^ [i].name, dummy_cycle_selector, puc$valid_family_entry,
                      family_entry);
                pup$build_catalog_header (set_name, ^family_path, p_family_catalog_header^);
                pup$check_if_item_excluded (family_entry, p_family_catalog_header^, family_excluded);
                IF family_excluded THEN
                  pup$display_excluded_item (family_entry, p_family_catalog_header^, status);
                ELSE
                  delete_family_contents (set_name, p_family_directory^ [i].name, delete_catalogs, status);
                IFEND;
              IFEND;
            FOREND;
          IFEND;
        IFEND;
      IFEND;
      mmp$delete_scratch_segment (family_info, local_status);
    IFEND;
  PROCEND pup$delete_set_contents;
?? TITLE := '    [XDCL] pup$display_delete_empty_cat_cm ', EJECT ??

  PROCEDURE [XDCL] pup$display_delete_empty_cat_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt display_delec_pdt (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_delec_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^display_delec_pdt_names, ^display_delec_pdt_params];

    VAR
      display_delec_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      display_delec_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
            clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??
    clp$scan_parameter_list (parameter_list, display_delec_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$display_boolean (' INCLUDE_EMPTY_CATALOGS = ', delete_catalogs, status);
    pup$display_boolean (' INCLUDE_MASTER_CATALOGS = ', delete_master_catalogs, status);
  PROCEND pup$display_delete_empty_cat_cm;
?? TITLE := '    [XDCL] pup$display_exc_highest_cycles ', EJECT ??

  PROCEDURE [XDCL] pup$display_exc_highest_cycles
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt display_exchc_pdt (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_exchc_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^display_exchc_pdt_names, ^display_exchc_pdt_params];

    VAR
      display_exchc_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      display_exchc_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
            clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??
    clp$scan_parameter_list (parameter_list, display_exchc_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF exclude_highest_cycles = 0 THEN
      pup$display_line (' NO HIGH CYCLES EXCLUDED', status);
    ELSE
      pup$display_integer (' EXCLUDE HIGHEST CYCLES: ', exclude_highest_cycles, status);
    IFEND;
  PROCEND pup$display_exc_highest_cycles;
?? TITLE := '    [XDCL] pup$exclude_highest_cycles_cm ', EJECT ??

  PROCEDURE [XDCL] pup$exclude_highest_cycles_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{   PDT exc_highest_cycles_pdt (
{    number_of_cycles, noc: integer 0 .. pfc$maximum_cycle_number or key all = 3
{    status)

?? PUSH (LISTEXT := ON) ??

    VAR
      exc_highest_cycles_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^exc_highest_cycles_pdt_names, ^exc_highest_cycles_pdt_params];

    VAR
      exc_highest_cycles_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['NUMBER_OF_CYCLES', 1], ['NOC', 1], ['STATUS', 2]];

    VAR
      exc_highest_cycles_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ NUMBER_OF_CYCLES NOC }
      [[clc$optional_with_default, ^exc_highest_cycles_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [^exc_highest_cycles_pdt_kv1, clc$integer_value, 0, pfc$maximum_cycle_number]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      exc_highest_cycles_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            ost$name := ['ALL'];

    VAR
      exc_highest_cycles_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '3';

?? POP ??

    VAR
      value: clt$value;

    clp$scan_parameter_list (parameter_list, exc_highest_cycles_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('NUMBER_OF_CYCLES', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind = clc$integer_value THEN
    exclude_highest_cycles := value.int.value;
    ELSE {ALL
    exclude_highest_cycles := pfc$maximum_cycle_number;
    IFEND;
    pup$display_integer (' EXCLUDING HIGHEST CYCLES: ', exclude_highest_cycles, status);
  PROCEND pup$exclude_highest_cycles_cm;

?? TITLE := '    [XDCL] pup$excluded_highest_cycles ', EJECT ??

  FUNCTION [XDCL] pup$excluded_highest_cycles: 0 .. pfc$maximum_cycle_number;

    pup$excluded_highest_cycles := exclude_highest_cycles;
  FUNCEND pup$excluded_highest_cycles;

?? TITLE := '    [XDCL] pup$include_empty_catalog_cm ', EJECT ??

  PROCEDURE [XDCL] pup$include_empty_catalog_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT include_empty_cat_pdt (
{  delete_catalogs, delete_catalog, dc: boolean = true
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      include_empty_cat_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^include_empty_cat_pdt_names, ^include_empty_cat_pdt_params];

    VAR
      include_empty_cat_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
            clt$parameter_name_descriptor := [['DELETE_CATALOGS', 1], ['DELETE_CATALOG', 1], ['DC', 1],
            ['STATUS', 2]];

    VAR
      include_empty_cat_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ DELETE_CATALOGS DELETE_CATALOG DC }
      [[clc$optional_with_default, ^include_empty_cat_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$boolean_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      include_empty_cat_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

?? POP ??

    VAR
      local_delete_catalogs: boolean;

    clp$scan_parameter_list (parameter_list, include_empty_cat_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_boolean ('DELETE_CATALOGS', local_delete_catalogs, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    delete_catalogs := local_delete_catalogs;
    pup$display_boolean (' INCLUDE_EMPTY_CATALOGS ', delete_catalogs, status);
  PROCEND pup$include_empty_catalog_cm;

?? TITLE := '    [XDCL] pup$include_master_catalog_cmd', EJECT ??

  PROCEDURE [XDCL] pup$include_master_catalog_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{  PDT include_master_cat_pdt (
{   delete_master_catalogs, delete_master_catalog, dmc: boolean = true
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      include_master_cat_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^include_master_cat_pdt_names, ^include_master_cat_pdt_params];

    VAR
      include_master_cat_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
            clt$parameter_name_descriptor := [['DELETE_MASTER_CATALOGS', 1], ['DELETE_MASTER_CATALOG', 1],
            ['DMC', 1], ['STATUS', 2]];

    VAR
      include_master_cat_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ DELETE_MASTER_CATALOGS DELETE_MASTER_CATALOG DMC }
      [[clc$optional_with_default, ^include_master_cat_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$boolean_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      include_master_cat_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

?? POP ??

    VAR
      local_delete_catalogs: boolean,
      user_name: ost$user_identification;

    pmp$get_user_identification (user_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$verify_family_administrator ('INCLUDE_MASTER_CATALOGS ', user_name.family, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, include_master_cat_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_boolean ('DELETE_MASTER_CATALOGS', local_delete_catalogs, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    delete_master_catalogs := local_delete_catalogs;
    pup$display_boolean (' INCLUDE_MASTER_CATALOGS ', delete_master_catalogs, status);
  PROCEND pup$include_master_catalog_cmd;

?? TITLE := '    check_attached_file_attributes ', EJECT ??

  PROCEDURE check_attached_file_attributes
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
         password: pft$password;
         cycle_array_entry: pft$cycle_array_entry_version_2;
     VAR gfn: ost$binary_unique_name;
     VAR length: amt$file_length;
     VAR cycle_included: boolean;
     VAR data_resides_offline: boolean;
     VAR action_descriptor: put$action_descriptor;
     VAR status: ost$status);

    VAR
      cycle_damage_symptoms: fst$cycle_damage_symptoms,
      cycle_number: pft$cycle_number,
      lfn: amt$local_file_name,
      local_status: ost$status,
      log_base_recovery_enabled: boolean;

    data_resides_offline := FALSE;
    pmp$get_unique_name (lfn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF puv$backup_information.media <> rmc$null_device THEN
      pfp$utility_attach (lfn, path, cycle_selector, password, $pft$usage_selections [pfc$read],
            $pft$share_selections [pfc$read, pfc$execute], pfc$no_wait,
            $fst$cycle_damage_symptoms [fsc$respf_modification_mismatch, fsc$parent_catalog_restored],
            cycle_damage_symptoms, cycle_number, status);
    ELSE
      pfp$utility_attach (lfn, path, cycle_selector, password, $pft$usage_selections [],
            - $pft$share_selections [], pfc$no_wait, $fst$cycle_damage_symptoms
            [fsc$respf_modification_mismatch, fsc$parent_catalog_restored], cycle_damage_symptoms,
            cycle_number, status);
    IFEND;
    IF NOT status.normal THEN
      IF status.condition = pfe$cycle_data_resides_offline THEN
        status.normal := TRUE;
        data_resides_offline := TRUE;
        length := cycle_array_entry.eoi;
        gfn := cycle_array_entry.original_unique_name;
        pup$check_if_size_included (length, cycle_included);
      ELSEIF (status.condition = pfe$undefined_data) OR
            (status.condition = pfe$volume_unavailable) OR
            (status.condition = pfe$cycles_media_missing) OR
            (status.condition = pfe$parent_catalog_restored) OR
            (status.condition = pfe$media_image_inconsistent) OR
            (status.condition = pfe$respf_modification_mismatch) OR
            (status.condition = pfe$volume_not_online) THEN
        status.normal := TRUE;
        length := cycle_array_entry.eoi;
        gfn := cycle_array_entry.original_unique_name;
        pup$check_if_size_included (length, cycle_included);
      IFEND;
      RETURN;
    IFEND;

    pup$get_file_attributes (lfn, cycle_array_entry, length, gfn, status);
    IF status.normal THEN
      pup$check_if_size_included (length, cycle_included);
      IF NOT cycle_included THEN
        action_descriptor := 'EXCLUDE SIZE';
      IFEND;
      amp$return (lfn, status);
    ELSE
      amp$return (lfn, local_status);
    IFEND;
  PROCEND check_attached_file_attributes;
?? TITLE := '    crack_delete_file ', EJECT ??

  PROCEDURE crack_delete_file
    (    parameter_list: clt$parameter_list;
     VAR path_container: clt$path_container;
     VAR p_path: ^pft$path;
     VAR password: pft$password;
     VAR status: ost$status);


{   PROCEDURE (osm$bacpf_delfc) delete_file_contents, delete_file_content, delfc (
{     file, f: file = $required
{     password, pw: (SECURE) any of
{         key
{           none
{         keyend
{         name
{       anyend = none
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: 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$name_type_qualifier,
        recend,
        default_value: string (4),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 2, 28, 16, 30, 32, 773],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'OSM$BACPF_DELFC'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['PASSWORD                       ',clc$nominal_entry, 2],
    ['PW                             ',clc$abbreviation_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 69,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'none'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$password = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      cycle_selector_specified: boolean,
      cycle_selector: pft$cycle_selector;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_pf_file_reference (pvt [p$file].value^.file_value^, -$put$cycle_reference_selections [],
          'FILE', path_container, p_path, cycle_selector_specified, cycle_selector, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$password].value^.kind = clc$name THEN
      password := pvt [p$password].value^.name_value;
    ELSE {keyword = NONE}
      password := osc$null_name;
    IFEND;
  PROCEND crack_delete_file;

?? TITLE := '    delete_family_contents ', EJECT ??

  PROCEDURE delete_family_contents
    (    set_name: stt$set_name;
         family_name: pft$name;
         delete_catalogs: boolean;
     VAR status: ost$status);

    VAR
      dummy_cycle_selector: pft$cycle_selector,
      entry: put$entry,
      i: put$half_integer,
      local_status: ost$status,
      master_catalog_info: amt$segment_pointer,
      p_family_content: pft$p_info_record,
      p_master_catalog_directory: pft$p_directory_array,
      p_user_catalog_header: ^put$catalog_header,
      user_excluded: boolean,
      user_in_range: boolean,
      user_path: array [1 .. 2] of pft$name;

    user_path [pfc$family_name_index] := family_name;
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, master_catalog_info, status);
    IF status.normal THEN
      RESET master_catalog_info.sequence_pointer;
      pfp$get_master_catalog_info (set_name, family_name, $pft$catalog_info_selections
            [pfc$catalog_directory, pfc$catalog_description], master_catalog_info.sequence_pointer, status);
      IF status.normal THEN
        RESET master_catalog_info.sequence_pointer;
        pfp$find_next_info_record (master_catalog_info.sequence_pointer, p_family_content, status);
        IF status.normal THEN
          pfp$find_directory_array (p_family_content, p_master_catalog_directory, status);
          IF status.normal AND (p_master_catalog_directory <> NIL) THEN
            IF puv$sort_users THEN
              pup$sort_directory (p_master_catalog_directory^, p_master_catalog_directory^);
            IFEND;
            PUSH p_user_catalog_header: [1 .. 2];
            FOR i := LOWERBOUND (p_master_catalog_directory^) TO UPPERBOUND (p_master_catalog_directory^) DO
              pup$check_if_user_in_range (family_name, p_master_catalog_directory^ [i].name, user_in_range);
              IF user_in_range THEN
                user_path [pfc$master_catalog_name_index] := p_master_catalog_directory^ [i].name;
                pup$build_entry (user_path [pfc$master_catalog_name_index], dummy_cycle_selector,
                      puc$valid_catalog_entry, entry);
                pup$build_catalog_header (set_name, ^user_path, p_user_catalog_header^);
                pup$check_if_item_excluded (entry, p_user_catalog_header^, user_excluded);
                IF user_excluded THEN
                  pup$display_excluded_item (entry, p_user_catalog_header^, status);
                ELSE
                  pup$delete_catalog_contents (user_path, delete_catalogs, status);
                IFEND;
              IFEND;
            FOREND;
          IFEND;
        IFEND;
      IFEND;
      mmp$delete_scratch_segment (master_catalog_info, local_status);
    IFEND;
  PROCEND delete_family_contents;


?? TITLE := '    display_deletion_totals ', EJECT ??

  PROCEDURE display_deletion_totals;

    VAR
      local_status: ost$status;

    pup$display_blank_lines (3, local_status);
    pup$display_line (' DELETE SUMMARY: ', local_status);
    pup$display_integer ('   NUMBER OF CYCLES DELETED: ', number_of_cycles_deleted, local_status);
    number_of_cycles_deleted := 0;
    pup$display_integer ('   TOTAL CYCLE DATA DELETED: ', total_bytes_deleted, local_status);
    total_bytes_deleted := 0;
  PROCEND display_deletion_totals;
MODEND pum$delete_all;
*DECK DECK=PUM$DISPLAY_BACKUP_FILE EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  display_backup_file ', EJECT ??
MODULE pum$display_backup_file;
{
{  This contains processing for the the DISPLAY_BACKUP_FILE subcommand
{  and $BACKUP_FILE function.
{  This may read tapes produced by BACKUP_FILE_VERSION_001 or BACKUP_FILE_VERSION_002
{
?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ost$name
*copyc pud$backup_file
*copyc pud$hierarchy_list
*copyc pue$error_condition_codes
*copyc pus$literals
?? POP ??
?? EJECT ??

*copyc bav$task_file_table
*copyc clp$get_fs_path_string
*copyc clp$get_path_name
*copyc clp$get_value
*copyc clp$scan_argument_list
*copyc clp$scan_parameter_list
*copyc clp$trimmed_string_size
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_integer
*copyc osp$set_status_abnormal
*copyc pup$advised_get_part
*copyc pup$close_backup_file
*copyc pup$convert_cycle_path_to_strng
*copyc pup$convert_path_to_string
*copyc pup$crack_boolean
*copyc pup$crack_file
*copyc pup$display_blank_lines
*copyc pup$display_catalog_info
*copyc pup$display_cycle_info_desc_v1
*copyc pup$display_cycle_info_desc_v2
*copyc pup$display_file_info
*copyc pup$display_file_label
*copyc pup$display_integer
*copyc pup$display_item_descriptor
*copyc pup$display_line
*copyc pup$format_date_time
*copyc pup$get_item_descriptor
*copyc pup$get_next_hierarchy_list
*copyc pup$get_next_record_header
*copyc pup$get_part
*copyc pup$get_summary_status
*copyc pup$initialize_summary_status
*copyc pup$locate_valid_version
*copyc pup$open_backup_file
*copyc pup$skip_logical_partition
*copyc pup$write_os_status
*copyc puv$prev_open_by_$backup_file
*copyc puv$respf_backup_file_version

?? TITLE := '    Global Variables', EJECT ??

  VAR
    number_of_cycles_displayed: integer := 0,
    total_bytes_displayed: integer := 0;


  CONST
    puc$maximum_partitions = 1000000000;

  VAR
    puv$record_header_name_table: [READ, pus$literals] array [put$backup_record_type] of
          ost$name := ['puc$backup_item_identifier', 'puc$backup_hierarchy_list', 'puc$backup_set_info',
          'puc$backup_family_info', 'puc$backup_family_content_info', 'puc$backup_catalog_info',
          'puc$backup_catalog_content_info', 'puc$backup_file_info', 'puc$backup_cycle_info',
          'puc$backup_cycle_data', 'puc$backup_system_label'];

  TYPE
    put$display_bf_options = (puc$dbf_identifier, puc$dbf_descriptor, puc$dbf_read_cycle_data,
          puc$dbf_catalog_info);

  VAR
    display_backup_file_table: [STATIC, pus$literals, READ] array [1 .. 8] of record
      name: ost$name,
      display_option: put$display_bf_options,
    recend := [
          {} ['IDENTIFIER                     ', puc$dbf_identifier],
          {} ['I                              ', puc$dbf_identifier],
          {} ['DESCRIPTOR                     ', puc$dbf_descriptor],
          {} ['D                              ', puc$dbf_descriptor],
          {} ['READ_DATA                      ', puc$dbf_read_cycle_data],
          {} ['RD                             ', puc$dbf_read_cycle_data],
          {} ['CATALOG_INFO                   ', puc$dbf_catalog_info],
          {} ['CI                             ', puc$dbf_catalog_info]];


?? TITLE := '    [XDCL] pup$$backup_file ', EJECT ??

  PROCEDURE [XDCL] pup$$backup_file
    (    function_name: clt$name;
         argument_list: string ( * );
     VAR value: clt$value;
     VAR status: ost$status);

    VAR
      backup_file_adt: [STATIC, READ, cls$adt] array [1 .. 2] of clt$argument_descriptor := [
            {1} [[clc$required], [NIL, clc$file_value]],
            {2} [[clc$optional_with_default, ^default_selection], [^selection_keywords, clc$keyword_value]]],

      default_selection: [STATIC, READ, cls$adt_names_and_defaults] string (10) := 'IDENTIFIER',

      selection_keywords: [STATIC, READ, cls$adt_names_and_defaults] array [1 .. 4] of
            ost$name := ['IDENTIFIER', 'I', 'IDENTIFIER_TYPE', 'IT'];


    VAR
      avt: array [1 .. 2] of clt$value,
      backup_file_id: put$file_identifier,
      backup_file_position: put$file_position,
      entry_type_string: ost$string,
      local_status: ost$status,
      p_item_descriptor: ^put$backup_item_descriptor,
      path_string: ost$string,
      record_header: put$backup_file_record_header,
      stored_backup_file_version: put$backup_file_version_name;

    clp$scan_argument_list (function_name, argument_list, ^backup_file_adt, ^avt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    puv$prev_open_by_$backup_file := false;
    pup$open_backup_file (avt [1].file.local_file_name, puc$display_backup_file, amc$open_at_boi,
          backup_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    backup_file_id.operation := puc$$backup_file;

    pup$locate_valid_version (backup_file_id, stored_backup_file_version, backup_file_position, status);
    IF status.normal THEN
      pup$get_next_record_header (backup_file_id, record_header, backup_file_position, status);
      IF status.normal THEN
        PUSH p_item_descriptor: [1 .. record_header.size];
        pup$get_item_descriptor (backup_file_id, p_item_descriptor^, backup_file_position, status);
        IF status.normal THEN
          IF (avt [2].name.value = 'IDENTIFIER_TYPE') OR (avt [2].name.value = 'IT') THEN
            convert_entry_type_to_string (p_item_descriptor^.pf_utility_entry.entry_type, entry_type_string);
            value.descriptor := 'STRING';
            value.kind := clc$string_value;
            value.str.size := entry_type_string.size;
            value.str.value := entry_type_string.value;
          ELSE { IDENTIFIER OR I}
            convert_item_descriptor_to_strn (p_item_descriptor^, path_string);
            value.descriptor := 'STRING';
            value.kind := clc$string_value;
            value.str.size := path_string.size;
            value.str.value := path_string.value;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    pup$close_backup_file (backup_file_id, local_status);
  PROCEND pup$$backup_file;

?? TITLE := '    pup$display_backup_file ', EJECT ??

  PROCEDURE pup$display_backup_file
    (VAR backup_file_id: put$file_identifier;
         display_option: put$display_bf_options;
         number_to_display: integer;
     VAR status: ost$status);

    VAR
      file_position: put$file_position,
      local_status: ost$status,
      number_displayed: integer,
      p_item_description: ^put$backup_item_descriptor,
      record_header: put$backup_file_record_header,
      stored_backup_file_version: put$backup_file_version_name;

    status.normal := TRUE;
    number_displayed := 0;

  /loop_through_partitions/
    REPEAT
      pup$locate_valid_version (backup_file_id, stored_backup_file_version, file_position, status);
      IF status.normal AND (file_position <> puc$eoi) THEN
        pup$display_line ('------------------------------', status);
        IF display_option <> puc$dbf_identifier THEN
          pup$display_line (stored_backup_file_version, status);
        IFEND;
        pup$get_next_record_header (backup_file_id, record_header, file_position, status);
        IF status.normal THEN
          IF display_option <> puc$dbf_identifier THEN
            pup$display_record_header (record_header);
          IFEND;
          IF (record_header.kind = puc$backup_item_identifier) AND (record_header.size >= 1) THEN
            ALLOCATE p_item_description: [1 .. record_header.size];
            pup$get_item_descriptor (backup_file_id, p_item_description^, file_position, status);
            IF status.normal THEN
              pup$display_line (p_item_description^.catalog_header.set_name, status);
              pup$display_item_descriptor ('', p_item_description^.catalog_header,
                    p_item_description^.pf_utility_entry, status);
              number_displayed := number_displayed + 1;
              IF display_option <> puc$dbf_identifier THEN
                display_full_entry (display_option, backup_file_id, file_position,
                      p_item_description^.pf_utility_entry.entry_type, status);
              IFEND;
            IFEND;
            FREE p_item_description;
          ELSE
            pup$display_line (' expecting backup_item_identifier, entry skipped', status);
          IFEND;
        IFEND;
        pup$write_os_status (status, local_status);
        status.normal := TRUE;
        IF file_position = puc$mid_partition THEN
          pup$skip_logical_partition (backup_file_id, file_position, status);
        IFEND;
      IFEND;
    UNTIL NOT status.normal OR (file_position = puc$eoi) OR (number_displayed >= number_to_display);
    IF (status.normal) AND (number_to_display > number_displayed) AND
          (number_to_display <> puc$maximum_partitions) THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$number_of_items, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, number_displayed, 10, FALSE, status);
    IFEND;
    pup$write_os_status (status, status);
  PROCEND pup$display_backup_file;

?? TITLE := '    [XDCL] pup$display_backup_file_command ', EJECT ??

  PROCEDURE [XDCL] pup$display_backup_file_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      backup_file: amt$local_file_name,
      display_option: put$display_bf_options,
      local_status: ost$status,
      number_to_display: 1 .. puc$maximum_partitions;

    crack_disbf (parameter_list, backup_file, display_option, number_to_display, status);
    IF status.normal THEN
      pup$display_backup_file_request (backup_file, display_option, number_to_display, status);
      pup$write_os_status (status, local_status);
    IFEND;
  PROCEND pup$display_backup_file_command;

?? TITLE := '    pup$display_backup_file_request ', EJECT ??

  PROCEDURE pup$display_backup_file_request
    (    backup_file: amt$local_file_name;
         display_option: put$display_bf_options;
         number_to_display: 1 .. puc$maximum_partitions;
     VAR status: ost$status);

    TYPE
      character_set = set of char;

    VAR
      backup_file_id: put$file_identifier,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      path_handle: fmt$path_handle;

    pup$display_line (' DISPLAY BACKUP FILE:', status);
    pup$initialize_summary_status;

    pup$open_backup_file (backup_file, puc$display_backup_file, amc$open_at_boi, backup_file_id, status);
    IF status.normal THEN
      clp$get_fs_path_string (bav$task_file_table^ [backup_file_id.file_id.ordinal].local_file_name,
            fs_path, fs_path_size, path_handle, local_status);
      IF fs_path_size > osc$max_string_size THEN
        fs_path_size := osc$max_string_size;
      IFEND;
      pup$display_line (fs_path (1, fs_path_size), status);
      number_of_cycles_displayed := 0;
      total_bytes_displayed := 0;
      pup$display_backup_file (backup_file_id, display_option, number_to_display, status);
      pup$close_backup_file (backup_file_id, local_status);
      IF display_option <> puc$dbf_identifier THEN
        display_display_totals;
      IFEND;
      pup$get_summary_status (status);
    IFEND;
  PROCEND pup$display_backup_file_request;

?? TITLE := '    pup$display_record_header ', EJECT ??

  PROCEDURE pup$display_record_header
    (    record_header: put$backup_file_record_header);

    VAR
      number_length: integer,
      record_header_descriptor: string (78),
      status: ost$status;

    CASE record_header.kind OF
    = puc$backup_item_identifier, puc$backup_hierarchy_list, puc$backup_set_info, puc$backup_family_info,
          puc$backup_family_content_info, puc$backup_catalog_info, puc$backup_catalog_content_info,
          puc$backup_file_info, puc$backup_cycle_info, puc$backup_cycle_data, puc$backup_system_label =
      record_header_descriptor := ' ';
      STRINGREP (record_header_descriptor, number_length, ' Record header type: ',
            puv$record_header_name_table [record_header.kind], '  Size: ', record_header.size);
      pup$display_line (record_header_descriptor, status);
    ELSE
      pup$display_line (' INVALID RECORD HEADER ENCOUNTERED', status);
    CASEND;
  PROCEND pup$display_record_header;


?? TITLE := '    convert_entry_type_to_string ', EJECT ??

  PROCEDURE convert_entry_type_to_string
    (    entry_type: put$entry_type;
     VAR entry_string: ost$string);

    CASE entry_type OF
    = puc$valid_set_entry =
      entry_string.size := 3;
      entry_string.value := 'SET';
    = puc$valid_family_entry, puc$valid_catalog_entry =
      entry_string.size := 7;
      entry_string.value := 'CATALOG';
    = puc$valid_pf_entry =
      entry_string.size := 4;
      entry_string.value := 'FILE';
    = puc$valid_cycle_entry =
      entry_string.size := 5;
      entry_string.value := 'CYCLE';
    ELSE
      entry_string.size := 7;
      entry_string.value := 'UNKNOWN';
    CASEND;
  PROCEND convert_entry_type_to_string;

?? TITLE := '    convert_item_descriptor_to_strn ', EJECT ??

  PROCEDURE convert_item_descriptor_to_strn
    (    item_descriptor: put$backup_item_descriptor;
     VAR item_string: ost$string);

    IF item_descriptor.catalog_header.logical_path_length = 0 THEN
      item_string.value := item_descriptor.catalog_header.set_name;
      item_string.size := clp$trimmed_string_size (item_descriptor.catalog_header.set_name);
    ELSE
      CASE item_descriptor.pf_utility_entry.entry_type OF
      = puc$valid_cycle_entry =
        pup$convert_cycle_path_to_strng (item_descriptor.catalog_header.path,
              item_descriptor.pf_utility_entry.pf_selector.cycle_selector.cycle_number, item_string);
      ELSE
        pup$convert_path_to_string (item_descriptor.catalog_header.path, item_string);
      CASEND;
    IFEND;
  PROCEND convert_item_descriptor_to_strn;

?? TITLE := '    convert_name_to_option ', EJECT ??

  PROCEDURE convert_name_to_option
    (    name: ost$name;
     VAR display_bf_option: put$display_bf_options;
     VAR status: ost$status);

    VAR
      i: integer;

    status.normal := TRUE;
    FOR i := 1 TO UPPERBOUND (display_backup_file_table) DO
      IF display_backup_file_table [i].name = name THEN
        display_bf_option := display_backup_file_table [i].display_option;
        RETURN;
      IFEND;
    FOREND;
    osp$set_status_abnormal (puc$pf_utility_id, cle$name_not_a_keyword_value, name, status);
  PROCEND convert_name_to_option;

?? TITLE := '    crack_disbf ', EJECT ??

  PROCEDURE crack_disbf
    (    parameter_list: clt$parameter_list;
     VAR backup_file: amt$local_file_name;
     VAR display_option: put$display_bf_options;
     VAR number_to_display: 1 .. puc$maximum_partitions;
     VAR status: ost$status);

?? RIGHT := 110 ??

{ pdt display_backup_file_pdt (
{ backup_file,bf:file=$required
{  display_option, do: key identifier, i, descriptor, d, read_data, ..
{    rd, catalog_info, ci = identifier
{ number, n: integer 1 .. puc$maximum_partitions or key all = all
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_backup_file_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^display_backup_file_pdt_names, ^display_backup_file_pdt_params];

    VAR
      display_backup_file_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
            clt$parameter_name_descriptor := [['BACKUP_FILE', 1], ['BF', 1], ['DISPLAY_OPTION', 2], ['DO', 2],
            ['NUMBER', 3], ['N', 3], ['STATUS', 4]];

    VAR
      display_backup_file_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
            clt$parameter_descriptor := [

{ BACKUP_FILE BF }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ DISPLAY_OPTION DO }
      [[clc$optional_with_default, ^display_backup_file_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
            [^display_backup_file_pdt_kv2, clc$keyword_value]],

{ NUMBER N }
      [[clc$optional_with_default, ^display_backup_file_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed,
            [^display_backup_file_pdt_kv3, clc$integer_value, 1, puc$maximum_partitions]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      display_backup_file_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 8] of
            ost$name := ['IDENTIFIER', 'I', 'DESCRIPTOR', 'D', 'READ_DATA', 'RD', 'CATALOG_INFO', 'CI'];

    VAR
      display_backup_file_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            ost$name := ['ALL'];

    VAR
      display_backup_file_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (10) := 'identifier';

    VAR
      display_backup_file_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

?? POP ??

    VAR
      value: clt$value;


    clp$scan_parameter_list (parameter_list, display_backup_file_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_file ('BACKUP_FILE', backup_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DISPLAY_OPTION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    convert_name_to_option (value.name.value, display_option, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('NUMBER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind = clc$name_value THEN
      { ALL selected
      number_to_display := puc$maximum_partitions;
    ELSE
      number_to_display := value.int.value;
    IFEND;
  PROCEND crack_disbf;


?? TITLE := '    display_backup_cycle_info ', EJECT ??

  PROCEDURE display_backup_cycle_info
    (VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

{  This routine extracts the cycle array entry from the backup file.

    VAR
      fmd_size: integer,
      local_status: ost$status,
      p_cycle_info_desc_version_1: ^pft$cycle_info_desc_version_1,
      p_cycle_info_desc_version_2: ^pft$cycle_info_desc_version_2,
      p_file_media_descriptor: ^SEQ ( * ),
      record_header: put$backup_file_record_header,
      transfer_count: amt$file_length;

    pup$get_next_record_header (backup_file_id, record_header, file_position, status);
    IF status.normal THEN
      pup$display_record_header (record_header);
      IF (file_position = puc$mid_partition) AND (record_header.kind = puc$backup_cycle_info) THEN
        IF puv$respf_backup_file_version = puc$backup_file_version_1 THEN
          PUSH p_cycle_info_desc_version_1;
          pup$get_part (backup_file_id, p_cycle_info_desc_version_1, #SIZE (p_cycle_info_desc_version_1^),
                file_position, transfer_count, status);
          IF status.normal THEN
            pup$display_cycle_info_desc_v1 (p_cycle_info_desc_version_1, 4);
          IFEND;
        ELSEIF puv$respf_backup_file_version = puc$backup_file_version_2 THEN
          IF record_header.size > (#SIZE(pft$cycle_info_desc_version_2: [[REP 1 OF cell]]) - 1) THEN
            fmd_size := record_header.size - (#SIZE(pft$cycle_info_desc_version_2: [[REP 1 OF cell]]) - 1);
          ELSE
            fmd_size := 1;
          IFEND;
          PUSH p_cycle_info_desc_version_2: [[REP fmd_size OF cell]];
          pup$get_part (backup_file_id, p_cycle_info_desc_version_2, record_header.size, file_position,
                transfer_count, status);
          IF status.normal THEN
            IF fmd_size > 1 THEN
              p_file_media_descriptor := ^p_cycle_info_desc_version_2^.file_media_descriptor;
            ELSE
              p_file_media_descriptor := NIL;
            IFEND;
            pup$display_cycle_info_desc_v2 (p_cycle_info_desc_version_2, p_file_media_descriptor, 4);
          IFEND;
        IFEND;
      ELSE
        pup$display_line (' Unexpected item encountered, expecting: puc$backup_cycle_info', status);
        osp$set_status_abnormal (puc$pf_utility_id, pue$unusable_restore_file, '', status);
      IFEND;
    IFEND;
  PROCEND display_backup_cycle_info;

?? TITLE := '    display_catalog_entry ', EJECT ??

  PROCEDURE display_catalog_entry
    (    display_option: put$display_bf_options;
     VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      p_info_record: pft$p_info_record,
      record_header: put$backup_file_record_header,
      transfer_count: amt$file_length;

    IF display_option = puc$dbf_catalog_info THEN
      display_catalog_info (backup_file_id, file_position, status);
    ELSE
      display_item_record (puc$backup_catalog_info, backup_file_id, file_position, status);
    IFEND;

    IF status.normal THEN
      { determine what version of the backup_file we are displaying.
      { BACKUP_FILE_VERSION_001 has a puc$backup_catalog_content_info while 002 does not.
      pup$get_next_record_header (backup_file_id, record_header, file_position, status);
      IF status.normal THEN
        pup$display_record_header (record_header);
        CASE record_header.kind OF
        = puc$backup_catalog_content_info =
          { skip over the item info.
          IF record_header.size > 0 THEN
            PUSH p_info_record: [[REP record_header.size OF cell]];
            pup$get_part (backup_file_id, p_info_record, #SIZE (p_info_record^), file_position,
                  transfer_count, status);
            pup$write_os_status (status, local_status);
            IF status.normal THEN
              display_hierarchy_list (backup_file_id, file_position, status);
            IFEND;
          ELSE
            pup$display_integer (' unexpected record header size: ', record_header.size, local_status);
          IFEND;

        = puc$backup_hierarchy_list =
          display_hierarchy_list_info (record_header.size, backup_file_id, file_position, status);
        ELSE
          pup$display_line (' Unexpected item encountered, expecting: puc$backup_hierachy_list, or puc$backup'
                CAT '_catalog_content_info', status);
          osp$set_status_abnormal (puc$pf_utility_id, pue$unusable_restore_file, '', status);
        CASEND;
      IFEND;
    IFEND;
  PROCEND display_catalog_entry;
?? TITLE := '    display_catalog_info', EJECT ??

  PROCEDURE display_catalog_info
    (VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      outputline: string (200),
      outputline_index: integer,
      p_info_record: pft$p_info_record,
      record_header: put$backup_file_record_header,
      transfer_count: amt$file_length;

    pup$get_next_record_header (backup_file_id, record_header, file_position, status);
    IF status.normal THEN
      pup$display_record_header (record_header);
      IF (record_header.kind = puc$backup_family_info) OR (record_header.kind = puc$backup_catalog_info) THEN
        IF record_header.size > 0 THEN
          PUSH p_info_record: [[REP record_header.size OF cell]];
          pup$get_part (backup_file_id, p_info_record, #SIZE (p_info_record^), file_position,
                transfer_count, status);
          IF status.normal THEN
            pup$display_catalog_info (osc$null_name, p_info_record, 2, status);
          IFEND;
          pup$write_os_status (status, local_status);
        ELSE
          pup$display_integer (' unexpected record header size: ', record_header.size, local_status);
        IFEND;
      ELSE
        STRINGREP (outputline, outputline_index, ' Unexpected record header kind.  Expecting: ',
              ' Catalog or Family info ');
        pup$display_line (outputline (1, outputline_index), status);
        osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_item_requested, '', status);
      IFEND;
    IFEND;
  PROCEND display_catalog_info;

?? TITLE := '    display_cycle_entry ', EJECT ??

  PROCEDURE display_cycle_entry
    (    display_option: put$display_bf_options;
     VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    VAR
      record_header: put$backup_file_record_header;

    display_backup_cycle_info (backup_file_id, file_position, status);
    IF status.normal THEN
      number_of_cycles_displayed := number_of_cycles_displayed + 1;
      display_label_record (backup_file_id, file_position, status);
      IF status.normal THEN
        display_hierarchy_list (backup_file_id, file_position, status);
        IF status.normal THEN
          pup$get_next_record_header (backup_file_id, record_header, file_position, status);
          IF status.normal THEN
            pup$display_record_header (record_header);
            IF record_header.kind = puc$backup_cycle_data THEN
              IF display_option = puc$dbf_read_cycle_data THEN
                read_cycle_data (record_header.size, backup_file_id, file_position, status);
              IFEND;
              IF status.normal THEN
                total_bytes_displayed := total_bytes_displayed + record_header.size;
              IFEND;
            ELSE
              pup$display_line (' invalid record header type expecting: cycle_data ', status);
            IFEND;
          ELSEIF status.condition = pue$unusable_restore_file THEN
            pup$display_line (' Cycle data not present', status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND display_cycle_entry;

?? TITLE := '    display_date_time ', EJECT ??

  PROCEDURE display_date_time
    (    descriptor: string ( * <= 90);
         date_time: ost$date_time);

    VAR
      status: ost$status,
      working_string: string (120),
      date_time_string: string (30);

    working_string := descriptor;
    pup$format_date_time (date_time, date_time_string);
    working_string ((STRLENGTH (descriptor) + 1), * ) := date_time_string;
    pup$display_line (working_string (1, (STRLENGTH (descriptor) + 30)), status);
  PROCEND display_date_time;

?? TITLE := '    display_display_totals ', EJECT ??

  PROCEDURE display_display_totals;

    VAR
      local_status: ost$status;

    pup$display_blank_lines (3, local_status);
    pup$display_line (' DISPLAY SUMMARY: ', local_status);
    pup$display_integer ('   NUMBER OF CYCLES DISPLAYED: ', number_of_cycles_displayed, local_status);
    number_of_cycles_displayed := 0;
    pup$display_integer ('   TOTAL CYCLE DATA DISPLAYED: ', total_bytes_displayed, local_status);
    total_bytes_displayed := 0;
  PROCEND display_display_totals;

?? TITLE := '    display_family_entry ', EJECT ??

  PROCEDURE display_family_entry
    (    display_option: put$display_bf_options;
     VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      p_info_record: pft$p_info_record,
      record_header: put$backup_file_record_header,
      transfer_count: amt$file_length;

    IF display_option = puc$dbf_catalog_info THEN
      display_catalog_info (backup_file_id, file_position, status);
    ELSE
      display_item_record (puc$backup_family_info, backup_file_id, file_position, status);
    IFEND;
    IF status.normal THEN
      { determine what version of the backup_file we are displaying.
      pup$get_next_record_header (backup_file_id, record_header, file_position, status);
      IF status.normal THEN
        pup$display_record_header (record_header);
        CASE record_header.kind OF
        = puc$backup_family_content_info =
          {version 001
          { skip over the item info.
          IF record_header.size > 0 THEN
            PUSH p_info_record: [[REP record_header.size OF cell]];
            pup$get_part (backup_file_id, p_info_record, #SIZE (p_info_record^), file_position,
                  transfer_count, status);
            pup$write_os_status (status, local_status);
            IF status.normal THEN
              display_hierarchy_list (backup_file_id, file_position, status);
            IFEND;
          ELSE
            pup$display_integer (' unexpected record header size: ', record_header.size, local_status);
          IFEND;
        = puc$backup_hierarchy_list =
          {version 002
          display_hierarchy_list_info (record_header.size, backup_file_id, file_position, status);
        ELSE
          pup$display_line (' Unexpected item encountered, expecting: puc$backup_hierachy_list, or puc$backup'
                CAT '_catalog_content_info', status);
          osp$set_status_abnormal (puc$pf_utility_id, pue$unusable_restore_file, '', status);
        CASEND;
      IFEND;
    IFEND;

  PROCEND display_family_entry;

?? TITLE := '    display_file_info', EJECT ??

  PROCEDURE display_file_info
    (VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      outputline: string (200),
      outputline_index: integer,
      p_info_record: pft$p_info_record,
      record_header: put$backup_file_record_header,
      transfer_count: amt$file_length;

    pup$get_next_record_header (backup_file_id, record_header, file_position, status);
    IF status.normal THEN
      pup$display_record_header (record_header);
      IF (record_header.kind = puc$backup_file_info) THEN
        IF record_header.size > 0 THEN
          PUSH p_info_record: [[REP record_header.size OF cell]];
          pup$get_part (backup_file_id, p_info_record, #SIZE (p_info_record^), file_position,
                transfer_count, status);
          IF status.normal THEN
            pup$display_file_info (osc$null_name, p_info_record, 2, status);
          IFEND;
          pup$write_os_status (status, local_status);
        ELSE
          pup$display_integer (' unexpected record header size: ', record_header.size, local_status);
        IFEND;
      ELSE
        STRINGREP (outputline, outputline_index, ' Unexpected record header kind.  Expecting: ',
              ' File info ');
        pup$display_line (outputline (1, outputline_index), status);
        osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_item_requested, '', status);
      IFEND;
    IFEND;
  PROCEND display_file_info;
?? TITLE := '    display_full_entry ', EJECT ??

  PROCEDURE display_full_entry
    (    display_option: put$display_bf_options;
     VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
         entry_type: put$entry_type;
     VAR status: ost$status);

    CASE entry_type OF
    = puc$valid_set_entry =
      display_set_entry (display_option, backup_file_id, file_position, status);
    = puc$valid_family_entry =
      display_family_entry (display_option, backup_file_id, file_position, status);
    = puc$valid_catalog_entry =
      display_catalog_entry (display_option, backup_file_id, file_position, status);
    = puc$valid_pf_entry =
      display_pf_entry (display_option, backup_file_id, file_position, status);
    = puc$valid_cycle_entry =
      display_cycle_entry (display_option, backup_file_id, file_position, status);
    = puc$invalid_entry =
      pup$display_line (' PUC$INVALID_ENTRY ', status);
    ELSE
      pup$display_line (' UNSELECTED CASE ON ENTRY TYPE', status);
    CASEND;
  PROCEND display_full_entry;

?? TITLE := '    display_hierarchy_list ', EJECT ??

  PROCEDURE display_hierarchy_list
    (VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    VAR
      record_header: put$backup_file_record_header;

    pup$get_next_record_header (backup_file_id, record_header, file_position, status);
    IF status.normal THEN
      pup$display_record_header (record_header);
      IF record_header.kind = puc$backup_hierarchy_list THEN
        display_hierarchy_list_info (record_header.size, backup_file_id, file_position, status);
      ELSE
        pup$display_line ('Unexpected record header: expecting puc$backup_hierarchy_list', status);
      IFEND;
    IFEND;
  PROCEND display_hierarchy_list;
?? TITLE := '    display_hierarchy_list_info ', EJECT ??

  PROCEDURE display_hierarchy_list_info
    (    size: integer;
     VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    VAR
      date_time_string: string (30),
      local_status: ost$status,
      p_hierarchy_list: ^put$hierarchy_list;

    IF size > 0 THEN
      PUSH p_hierarchy_list: [1 .. size];
      pup$get_next_hierarchy_list (backup_file_id, p_hierarchy_list^, file_position, status);
      IF status.normal THEN
        display_date_time (' Item backed up on: ', p_hierarchy_list^.date_time);
        pup$display_item_descriptor (' Produced by backup of: ', p_hierarchy_list^.catalog_header,
              p_hierarchy_list^.pf_entry, status);
        IF (p_hierarchy_list^.catalog_header.logical_path_length = 0) THEN
          pup$display_line ('   backup_all_files ', status);
        IFEND;
      IFEND;
    ELSE
      pup$display_integer (' unexpected size for hierarchy list: ', size, status);
    IFEND;
  PROCEND display_hierarchy_list_info;

?? TITLE := '    display_item_record ', EJECT ??

  PROCEDURE display_item_record
    (    expected_item_type: put$backup_record_type;
     VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      outputline: string (200),
      outputline_index: integer,
      p_info_record: pft$p_info_record,
      record_header: put$backup_file_record_header,
      transfer_count: amt$file_length;

    pup$get_next_record_header (backup_file_id, record_header, file_position, status);
    IF status.normal THEN
      pup$display_record_header (record_header);
      IF record_header.kind = expected_item_type THEN
        IF record_header.size > 0 THEN
          PUSH p_info_record: [[REP record_header.size OF cell]];
          pup$get_part (backup_file_id, p_info_record, #SIZE (p_info_record^), file_position,
                transfer_count, status);
          pup$write_os_status (status, local_status);
        ELSE
          pup$display_integer (' unexpected record header size: ', record_header.size, local_status);
        IFEND;
      ELSE
        STRINGREP (outputline, outputline_index, ' Unexpected record header kind.  Expecting: ',
              puv$record_header_name_table [expected_item_type]);
        pup$display_line (outputline (1, outputline_index), status);
        osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_item_requested, '', status);
      IFEND;
    IFEND;
  PROCEND display_item_record;

?? TITLE := '    display_label_record ', EJECT ??

  PROCEDURE display_label_record
    (VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      p_label: ^SEQ ( * ),
      record_header: put$backup_file_record_header,
      transfer_count: amt$file_length;

    pup$get_next_record_header (backup_file_id, record_header, file_position, status);
    IF status.normal THEN
      pup$display_record_header (record_header);
      IF record_header.kind = puc$backup_system_label THEN
        IF record_header.size > 0 THEN
          PUSH p_label: [[REP record_header.size OF cell]];
          pup$get_part (backup_file_id, p_label, #SIZE (p_label^), file_position, transfer_count,
                status);
          IF status.normal THEN
            pup$display_file_label (p_label^, 2, status);
          IFEND;
          pup$write_os_status (status, local_status);
        IFEND;
      ELSE
        pup$display_line (' Unexpected record header kind expecting: puc$backup_system_label', status);
        osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_item_requested, '', status);
      IFEND;
    IFEND;
  PROCEND display_label_record;


?? TITLE := '    display_pf_entry ', EJECT ??

  PROCEDURE display_pf_entry
    (    display_option: put$display_bf_options;
     VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    IF display_option = puc$dbf_catalog_info THEN
      display_file_info (backup_file_id, file_position, status);
    ELSE
      display_item_record (puc$backup_file_info, backup_file_id, file_position, status);
    IFEND;

    IF status.normal THEN
      display_hierarchy_list (backup_file_id, file_position, status);
    IFEND;


  PROCEND display_pf_entry;

?? TITLE := '    display_set_entry ', EJECT ??

  PROCEDURE display_set_entry
    (    display_option: put$display_bf_options;
     VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);


    display_item_record (puc$backup_set_info, backup_file_id, file_position, status);

    IF status.normal THEN
      display_hierarchy_list (backup_file_id, file_position, status);
    IFEND;


  PROCEND display_set_entry;

?? TITLE := '    read_cycle_data ', EJECT ??

  PROCEDURE read_cycle_data
    (    cycle_data_size: integer;
     VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      segment: amt$segment_pointer,
      transfer_count: amt$file_length;

    IF cycle_data_size <= 0 THEN
      pup$display_line (' No cycle data. ', status);
    ELSE
      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, segment, status);
      IF NOT status.normal THEN
        pup$display_line ('unable to create transient segment', local_status);
        RETURN;
      IFEND;
      pup$display_line (' Reading cycle data. ', status);
      pup$advised_get_part (backup_file_id, segment.sequence_pointer, cycle_data_size, file_position,
            transfer_count, status);
      IF status.normal THEN
        pup$display_line (' Able to read cycle data. ', status);
      ELSE
        pup$write_os_status (status, local_status);
        pup$display_line (' Unable to read cycle data. ', local_status);
      IFEND;
      mmp$delete_scratch_segment (segment, status);
    IFEND;
  PROCEND read_cycle_data;

MODEND pum$display_backup_file;
*DECK DECK=PUM$DISPLAY_CATALOGS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  display_catalogs ', EJECT ??
MODULE pum$display_catalogs;

{ PURPOSE:
{   This module contains procedures to display information from the permanent
{   file catalog.


?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc dmt$stored_fmd
*copyc dmt$stored_ms_fmd_header
*copyc dmt$stored_tape_fmd
*copyc dmt$stored_tape_fmd_version
*copyc fmt$static_label_header
*copyc gft$file_kind
*copyc pfc$system_shared_queue_name
*copyc pft$cycle_info_desc_version_1
*copyc pft$cycle_info_desc_version_2
*copyc pft$device_class
*copyc pud$backup_file
*copyc pue$error_condition_codes
*copyc pus$literals
?? POP ??
?? EJECT ??
*copyc clp$scan_parameter_list
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$set_status_abnormal
*copyc pfc$system_shared_queue_name
*copyc pfp$convert_device_class_to_rm
*copyc pfp$convert_ord_to_shared_queue
*copyc pfp$find_archive_info
*copyc pfp$find_catalog_description
*copyc pfp$find_catalog_media
*copyc pfp$find_cycle_array
*copyc pfp$find_cycle_array_extended
*copyc pfp$find_cycle_array_version_2
*copyc pfp$find_cycle_directory
*copyc pfp$find_cycle_label
*copyc pfp$find_cycle_media
*copyc pfp$find_direct_info_record
*copyc pfp$find_directory_array
*copyc pfp$find_file_description
*copyc pfp$find_log_array
*copyc pfp$find_next_archive_entry
*copyc pfp$find_next_info_record
*copyc pfp$find_permit_array
*copyc pfp$get_family_info
*copyc pfp$get_item_info
*copyc pfp$get_master_catalog_info
*copyc pfp$get_multi_item_info
*copyc pfp$get_rem_media_req_info
*copyc pfp$get_rem_media_volume_list
*copyc pfp$get_set_list
*copyc pmp$convert_binary_unique_name
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pup$convert_gfn_to_string
*copyc pup$display_boolean
*copyc pup$display_integer
*copyc pup$display_line
*copyc pup$verify_system_administrator
*copyc puv$respf_backup_file_version

?? TITLE := '*** GLOBAL DEFINITIONS ***', EJECT ??

  CONST
    end_of_line = $CHAR (255);

  VAR
    catalog_info_selections: [READ, pus$literals] pft$catalog_info_selections :=
          [pfc$catalog_directory, pfc$catalog_description, pfc$catalog_permits, pfc$catalog_media_descriptor],
    file_info_selections: [READ, pus$literals] pft$file_info_selections :=
          [pfc$file_directory, pfc$file_description, pfc$file_permits, pfc$file_cycles_version_2,
          pfc$file_log, pfc$cycle_media_descriptor, pfc$cycle_label_descriptor],
    highest_date_time: [READ, pus$literals] ost$date_time := [255, 12, 31, 23, 59, 59, 999],
    master_catalog_path: [READ, pus$literals] array [1 .. 2] of pft$name := [osc$null_name, osc$null_name],
    no_file_info_selections: [READ, pus$literals] pft$file_info_selections := [],
    public_group: [READ, pus$literals] pft$group := [pfc$public];

?? TITLE := '*** PUP$DISPLAY_ALL_CATALOGS ***', EJECT ??
{       PUP$DISPLAY_ALL_CATALOGS -
{

  PROCEDURE pup$display_all_catalogs;

    VAR
      directory_entry: pft$directory_array_entry,
      family_name: pft$name,
      index: pft$array_index,
      name_type: pft$name_type,
      offset: pft$info_offset,
      p_catalog_record: pft$p_info_record,
      p_directory_array: pft$p_directory_array,
      p_info: pft$p_info,
      p_info_body: pft$p_info,
      p_info_record: pft$p_info_record,
      segment_pointer: amt$segment_pointer,
      set_list: ^stt$set_list,
      cset,
      number_of_sets: stt$number_of_sets,
      status: ost$status;

    display_line (' Start of pfp$display_all_catalogs.');
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, segment_pointer, status);
    p_info := segment_pointer.sequence_pointer;
    RESET p_info;
    number_of_sets := 20;
    FOR cset := 1 TO 2 DO
      PUSH set_list: [1 .. number_of_sets];
      pfp$get_set_list (set_list^, number_of_sets, status);
    FOREND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    FOR cset := 1 TO number_of_sets DO
    pfp$get_family_info (set_list^ [cset], catalog_info_selections, p_info, status);
    IF status.normal THEN
      RESET p_info;
      pfp$find_next_info_record (p_info, p_info_record, status);
      IF status.normal THEN
        pfp$find_directory_array (p_info_record, p_directory_array, status);
        IF status.normal THEN
          IF (p_directory_array <> NIL) THEN
            p_info_body := ^p_info_record^.body;

          /process_directory_array/
            FOR index := 1 TO UPPERBOUND (p_directory_array^) DO
              display_blank_line;
              directory_entry := p_directory_array^ [index];
              family_name := directory_entry.name;
              name_type := directory_entry.name_type;
              offset := directory_entry.info_offset;
              IF (name_type = pfc$catalog_name) THEN
                pfp$find_direct_info_record (p_info_body, offset, p_catalog_record, status);
                IF status.normal THEN
                  pup$display_catalog_info (family_name, p_catalog_record, 2, status);
                  IF status.normal THEN
                    display_blank_line;
                    display_family_content (set_list^ [cset], family_name, 4, p_info, status);
                  IFEND;
                IFEND;
                IF NOT status.normal THEN
                  EXIT /process_directory_array/;
                IFEND;
              IFEND;
            FOREND /process_directory_array/;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    FOREND;
    mmp$delete_scratch_segment (segment_pointer, status);
    display_line (' End of pfp$display_all_catalogs.');
  PROCEND pup$display_all_catalogs;
?? TITLE := '*** PUP$DISPLAY_ALL_CATALOGS_CMD ***', EJECT ??

  PROCEDURE [XDCL] pup$display_all_catalogs_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


?? RIGHT := 110 ??
{ pdt disac_pdt (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      disac_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^disac_pdt_names, ^disac_pdt_params];

    VAR
      disac_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      disac_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??
    pup$verify_system_administrator ('DISPLAY_ALL_CATALOGS           ', NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, disac_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$display_all_catalogs;
  PROCEND pup$display_all_catalogs_cmnd;

?? TITLE := '*** PUP$DISPLAY_CATALOG_INFO ***', EJECT ??

  PROCEDURE [XDCL] pup$display_catalog_info
    (    catalog_name: pft$name;
         p_catalog_record: pft$p_info_record;
         output_column: integer;
     VAR status: ost$status);

    VAR
      p_catalog_description: pft$p_catalog_description,
      p_catalog_media_description: pft$p_catalog_media_description,
      p_catalog_fmd: ^SEQ ( * );

    IF catalog_name <> '' THEN
      display_blanks (output_column - 1);
      display ('Catalog_name: ');
      display_name (catalog_name);
      display_line ('');
    IFEND;
    pfp$find_catalog_description (p_catalog_record, p_catalog_description, status);
    IF status.normal THEN
      display_charge_id (p_catalog_description^.charge_id, output_column + 2);
      display_blank_line;
      display_permit_info (p_catalog_record, output_column + 2, status);

      pfp$find_catalog_media (p_catalog_record, p_catalog_media_description, p_catalog_fmd, status);
      IF status.normal THEN
        display_catalog_media (p_catalog_media_description^, p_catalog_fmd, output_column + 2);
      ELSEIF status.condition = pfe$unknown_catalog_media THEN
        display_blanks (output_column + 1);
        display_line (' Catalog media not present ');
        status.normal := TRUE;
      IFEND;
    IFEND;
  PROCEND pup$display_catalog_info;

?? TITLE := '*** [XDCL] PUP$DISPLAY_CYCLE_INFO_DESC_V1 ***', EJECT ??
{       PUP$DISPLAY_CYCLE_INFO_DESC_V1
{

  PROCEDURE [XDCL] pup$display_cycle_info_desc_v1
    (    p_cycle_info_desc_version_1: ^pft$cycle_info_desc_version_1;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Cycle_number: ');
    display_integer (p_cycle_info_desc_version_1^.cycle_number);
    display_line ('');

    display_cycle_statistics (p_cycle_info_desc_version_1^.cycle_statistics, output_column);

    display_expiration_date_time (p_cycle_info_desc_version_1^.expiration_date_time, output_column);

  PROCEND pup$display_cycle_info_desc_v1;

?? TITLE := '*** [XDCL] PUP$DISPLAY_CYCLE_INFO_DESC_V2 ***', EJECT ??
{       PUP$DISPLAY_CYCLE_INFO_DESC_V2
{

  PROCEDURE [XDCL] pup$display_cycle_info_desc_v2
    (    p_cycle_info_desc_version_2: ^pft$cycle_info_desc_version_2;
         p_file_media_descriptor: ^SEQ ( * ),
         output_column: integer);

    VAR
      device_class: rmt$device_class,
      ignore: ost$status,
      local_status: ost$status,
      shared_queue_name: ost$name,
      unique_name: ost$name;

    display_cycle_damage_symptoms (p_cycle_info_desc_version_2^.cycle_damage_symptoms, output_column);

    display_blanks (output_column - 1);
    display ('Cycle_number: ');
    display_integer (p_cycle_info_desc_version_2^.cycle_number);
    display_line ('');

    display_cycle_statistics (p_cycle_info_desc_version_2^.cycle_statistics, output_column);

    display_blanks (output_column - 1);
    display ('Data_modification_date_time: ');
    display_date_time (p_cycle_info_desc_version_2^.data_modification_date_time);
    display_line ('');

    display_pf_device_class (p_cycle_info_desc_version_2^.device_class, output_column);

    display_expiration_date_time (p_cycle_info_desc_version_2^.expiration_date_time, output_column);

    display_blanks (output_column - 1);
    pmp$convert_binary_unique_name (p_cycle_info_desc_version_2^.original_unique_name, unique_name, ignore);
    display ('Original_unique_name: ');
    display (unique_name);
    display_line ('');

    display_blanks (output_column - 1);
    display ('Sparse_backup_file_format: ');
    display_boolean (p_cycle_info_desc_version_2^.sparse_backup_file_format);
    display_line ('');

    display_blanks (output_column - 1);
    display ('Shared_queue: ');
    IF p_cycle_info_desc_version_2^.shared_queue_info.defined THEN
      pfp$convert_ord_to_shared_queue (p_cycle_info_desc_version_2^.shared_queue_info.shared_queue,
            shared_queue_name, local_status);
      IF NOT local_status.normal THEN
        shared_queue_name := pfc$system_shared_queue_name;
      IFEND;
    ELSE
      shared_queue_name := pfc$system_shared_queue_name;
    IFEND;
    display (shared_queue_name);
    display_line ('');

    display_retrieve_option (p_cycle_info_desc_version_2^.retrieve_option, output_column);

    display_blanks (output_column - 1);
    display ('Site_archive_option: ');
    display_integer (p_cycle_info_desc_version_2^.site_archive_option);
    display_line ('');

    display_blanks (output_column - 1);
    display ('Site_backup_option: ');
    display_integer (p_cycle_info_desc_version_2^.site_backup_option);
    display_line ('');

    display_blanks (output_column - 1);
    display ('Site_release_option: ');
    display_integer (p_cycle_info_desc_version_2^.site_release_option);
    display_line ('');

    display_blanks (output_column - 1);
    display ('Fmd_checksum: ');
    display_integer (p_cycle_info_desc_version_2^.fmd_checksum);
    display_line ('');

    IF p_file_media_descriptor <> NIL THEN
      pfp$convert_device_class_to_rm (p_cycle_info_desc_version_2^.device_class, device_class);
      pup$display_fmd (device_class, p_file_media_descriptor^, output_column,
            ignore);
    ELSE
      display_blanks (output_column - 1);
      display_line ('File Media Descriptor Not Present');
    IFEND;

  PROCEND pup$display_cycle_info_desc_v2;

?? TITLE := '*** PUP$DISPLAY_FILE_INFO ***', EJECT ??
{       PUP$DISPLAY_FILE_INFO -
{

  PROCEDURE [XDCL] pup$display_file_info
    (    file_name: pft$name;
         p_file_record: pft$p_info_record;
         output_column: integer;
     VAR status: ost$status);

    VAR
      column: integer;

    IF file_name <> osc$null_name THEN
      display_blanks (output_column - 1);
      display ('File_name: ');
      display_name (file_name);
      display_line ('');
    IFEND;

    column := output_column + 2;
    display_file_description (p_file_record, column, status);
    IF status.normal THEN
      display_blank_line;
      display_permit_info (p_file_record, column, status);
    IFEND;

    IF status.normal THEN
      display_blank_line;
      display_log_info (p_file_record, column, status);
    IFEND;

    IF status.normal THEN
      display_blank_line;
      display_cycle_info (p_file_record, column, status);
    IFEND;

    IF status.normal THEN
      display_blank_line;
      display_cycle_info_extended (p_file_record, column, status);
    IFEND;
  PROCEND pup$display_file_info;
?? TITLE := '*** PUP$DISPLAY_FILE_LABEL ***', EJECT ??

  PROCEDURE [XDCL] pup$display_file_label
    (    file_label: SEQ ( * );
         output_column: integer;
     VAR status: ost$status);

    VAR
      p_file_label_header: ^fmt$static_label_header,
      p_label: ^SEQ ( * ),
      p_stored_checksum: ^integer;

    p_label := ^file_label;
    display_blanks (output_column);
    display_line (' File label ');
    RESET p_label;
    NEXT p_stored_checksum IN p_label;
    IF p_stored_checksum = NIL THEN
      osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes, 'static label checksum',
            status);
      RETURN;
    ELSE
      display_blanks (output_column + 2);
      display (' Checksum : ');
      display_integer (p_stored_checksum^);
      display_line ('');
    IFEND;

    NEXT p_file_label_header IN p_label;
    IF p_file_label_header = NIL THEN
      osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes, ' p_file_label_header',
            status);
      RETURN;
    IFEND;

    IF p_file_label_header^.unique_character = '%' THEN
      display_blanks (output_column + 2);
      IF p_file_label_header^.file_previously_opened THEN
        display_line (' File previously opened ');
        display_blanks (output_column + 2);
        display (' Ring Attributes = (');
        display_integer (p_file_label_header^.ring_attributes.r1);
        display (', ');
        display_integer (p_file_label_header^.ring_attributes.r2);
        display (', ');
        display_integer (p_file_label_header^.ring_attributes.r3);
        display (')');
        display_line ('');
      ELSE
        display_line (' File not opened ');
      IFEND;
      display_blanks (output_column + 2);
      display (' job_routing_label_size');
      display_integer (p_file_label_header^.job_routing_label_size);
      display_line ('');
      display_blanks (output_column + 2);
      display (' revision_level');
      display_integer (p_file_label_header^.revision_level);
      display_line ('');
    ELSE { unique character <> '%' }
      display_blanks (output_column + 2);
      display_line (' Not current revision of label ');
    IFEND;

  PROCEND pup$display_file_label;
?? TITLE := ' [XDCL]  PUP$DISPLAY_FMD', EJECT ??

  PROCEDURE [XDCL] pup$display_fmd
    (    device_class: rmt$device_class;
         fmd: SEQ ( * );
         output_column: integer;
     VAR status: ost$status);

    VAR
      file_kind: [STATIC, READ, pus$literals] array [gft$file_kind] of ost$name := [
            {} 'File_kind job_permanent_file',
            {} 'File_kind device_file',
            {} 'File_kind save 2',
            {} 'File_kind save 3',
            {} 'File_kind catalog',
            {} 'File_kind job local file',
            {} 'File_kind unnamed_file',
            {} 'File_kind global_unnamed_file',
            {} 'File_kind monitor_only_file'];

    VAR
      access_kinds: [STATIC, READ, pus$literals] array [dmc$read_access .. dmc$write_access] of ost$name :=
            ['dmc$read_access',
            {} 'dmc$write_access'];

    VAR
      write_lock: [STATIC, READ, pus$literals] array [dmc$no_write_lock .. dmc$write_flush_lock] of
            ost$name := [
            {} 'dmc$no_write_lock',
            {} 'dmc$write_lock',
            {} 'dmc$write_flush_lock'];

    VAR
      disk_class: [STATIC, READ, pus$literals] array [dmt$class_member] of ost$name := ['  A', ' B', ' C',
            ' D', ' E', ' F', ' G', ' H', ' I', ' J', ' K', ' L', ' M', ' N', ' O', ' P', ' Q', ' R', ' S',
            ' T', ' U', ' V', ' W', ' X', ' Y', ' Z'];

    VAR
      ms_volume_count: dmt$fmd_index,
      p_ms_fmd: ^dmt$stored_fmd,
      p_ms_fmd_header: ^dmt$stored_ms_fmd_header,
      p_ms_fmd_subfile: ^dmt$stored_ms_fmd_subfile,
      p_ms_fmd_version: ^dmt$stored_ms_version_number,
      p_tape_fmd: ^pft$fmd,
      p_tape_fmd_header: ^dmt$stored_tape_fmd_header,
      p_tape_fmd_version: ^dmt$stored_tape_fmd_version,
      p_volume_list: ^rmt$volume_list,
      removable_media_req_info: fmt$removable_media_req_info,
      subfile: integer,
      tape_volume_count: 0 .. amc$max_vol_number,
      unique_name_string: string (60),
      volume: integer;

    display_rm_device_class (device_class, output_column);

    IF device_class = rmc$mass_storage_device THEN

      p_ms_fmd := ^fmd;
      RESET p_ms_fmd;
      NEXT p_ms_fmd_version IN p_ms_fmd;
      IF p_ms_fmd_version = NIL THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$unable_to_read_catalog_info,
              'NIL mass storage fmd_version', status);
        RETURN;
      IFEND;
      NEXT p_ms_fmd_header: [dmc$current_fmd_version] IN p_ms_fmd;
      IF p_ms_fmd_header = NIL THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$unable_to_read_catalog_info, 'NIL fmd_header',
              status);
        RETURN;
      IFEND;
      ms_volume_count:= p_ms_fmd_header^.version_0_0.number_fmds;

      display_blanks (output_column - 1);
      display_line ('File Media Descriptor');

      display_blanks (output_column + 1);
      display ('Fmd header');
      display_line ('');

      display_blanks (output_column + 3);
      display ('Fmd_version_number: ');
      display_integer (p_ms_fmd_header^.fmd_version_number);
      display_line ('');

      display_blanks (output_column + 3);
      display ('Clear_space ');
      display_boolean (p_ms_fmd_header^.version_0_0.clear_space);
      display_line ('');

      display_blanks (output_column + 3);
      display ('File_hash ');
      display_integer (p_ms_fmd_header^.version_0_0.file_hash);
      display_line ('');

      display_blanks (output_column + 3);
      display ('File_limit ');
      display_integer (p_ms_fmd_header^.version_0_0.file_limit);
      display_line ('');

      display_blanks (output_column + 3);
      display_line (file_kind [p_ms_fmd_header^.version_0_0.file_kind]);

      display_blanks (output_column + 3);
      display ('Locked_file.required');
      display_boolean (p_ms_fmd_header^.version_0_0.locked_file.required);
      IF p_ms_fmd_header^.version_0_0.locked_file.required THEN
        display_line ('');
        display_blanks (output_column + 5);
        IF (p_ms_fmd_header^.version_0_0.locked_file.locks = dmc$read_access) OR
              (p_ms_fmd_header^.version_0_0.locked_file.locks = dmc$write_access) THEN
          display (access_kinds [p_ms_fmd_header^.version_0_0.locked_file.locks]);
        ELSE
          display ('unknown lock');
        IFEND;
        display (', Read_lock_count');
        display_integer (p_ms_fmd_header^.version_0_0.locked_file.read_lock_count);
        display (',');
        display (write_lock [p_ms_fmd_header^.version_0_0.locked_file.write_lock]);
      IFEND;
      display_line ('');

      display_blanks (output_column + 3);
      display ('Number_of_volumes ');
      display_integer (ms_volume_count);
      display_line ('');

      display_blanks (output_column + 3);
      display ('Overflow_allowed ');
      display_boolean (p_ms_fmd_header^.version_0_0.overflow_allowed);
      display_line ('');

      display_blanks (output_column + 3);
      display ('Preset_value ');
      display_integer (p_ms_fmd_header^.version_0_0.preset_value);
      display_line ('');

      display_blanks (output_column + 3);
      display ('Requested_allocation_size ');
      display_integer (p_ms_fmd_header^.version_0_0.requested_allocation_size);
      display_line ('');

      display_blanks (output_column + 3);
      display ('Requested_class ');
      display (disk_class [p_ms_fmd_header^.version_0_0.requested_class]);
      display_line ('');

      display_blanks (output_column + 3);
      display ('Requested_class_ordinal ');
      display_integer (p_ms_fmd_header^.version_0_0.requested_class_ordinal);
      display_line ('');

      display_blanks (output_column + 3);
      display ('Requested_transfer_size ');
      display_integer (p_ms_fmd_header^.version_0_0.requested_transfer_size);
      display_line ('');

      display_blanks (output_column + 3);
      display ('Requested_volume (rvsn, set) : (');
      display_name (p_ms_fmd_header^.version_0_0.requested_volume.recorded_vsn);
      display (', ');
      display_name (p_ms_fmd_header^.version_0_0.requested_volume.setname);
      display_line (')');

      FOR subfile := 1 TO ms_volume_count DO

        display_blanks (output_column + 1);
        display ('Subfile number ');
        display_integer (subfile);
        display_line ('');

        NEXT p_ms_fmd_subfile: [dmc$current_fmd_version] IN p_ms_fmd;
        IF p_ms_fmd_subfile = NIL THEN
          osp$set_status_abnormal (puc$pf_utility_id, pue$unable_to_read_catalog_info, 'NIL stored_subfile ',
                status);
          RETURN;
        IFEND;

        display_blanks (output_column + 3);
        display ('Fmd_version_number ');
        display_integer (p_ms_fmd_subfile^.fmd_version_number);
        display_line ('');

        display_blanks (output_column + 3);
        display ('Recorded_vsn: ');
        display_line (p_ms_fmd_subfile^.version_0_0.recorded_vsn);

        display_blanks (output_column + 3);
        display ('Byte_address ');
        display_integer (p_ms_fmd_subfile^.version_0_0.stored_byte_address * dmc$byte_address_converter);
        display_line ('');

        display_blanks (output_column + 3);
        display ('Device_file_list_index ');
        display_integer (p_ms_fmd_subfile^.version_0_0.device_file_list_index);
        display_line ('');

        pup$convert_gfn_to_string (p_ms_fmd_subfile^.version_0_0.internal_vsn, unique_name_string);
        display_blanks (output_column + 3);
        display ('Internal_vsn ');
        display_line (unique_name_string);

      FOREND;

    ELSEIF device_class = rmc$magnetic_tape_device THEN

      p_tape_fmd := ^fmd;
      RESET p_tape_fmd;
      NEXT p_tape_fmd_version IN p_tape_fmd;
      IF p_tape_fmd_version = NIL THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$unable_to_read_catalog_info, 'NIL tape fmd_version',
              status);
        RETURN;
      IFEND;

      display_blanks (output_column + 1);
      display ('Fmd header');
      display_line ('');

      display_blanks (output_column + 3);
      display ('Fmd_version_number: ');
      display_integer ($INTEGER(p_tape_fmd_version^));
      display_line ('');

      pfp$get_rem_media_req_info (p_tape_fmd, ^removable_media_req_info, tape_volume_count, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_density (removable_media_req_info.density, output_column + 4);

      display_blanks (output_column + 3);
      display ('Removable_media_group: ');
      display_name (removable_media_req_info.removable_media_group);
      display_line ('');

      display_blanks (output_column + 3);
      display ('Number_of_volumes ');
      display_integer (tape_volume_count);
      display_line ('');

      display_blanks (output_column + 3);
      display ('Volume_overflow_allowed: ');
      display_boolean (removable_media_req_info.volume_overflow_allowed);
      display_line ('');

      PUSH p_volume_list: [1 .. tape_volume_count];
      pfp$get_rem_media_volume_list (p_tape_fmd, p_volume_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      FOR volume := 1 TO tape_volume_count DO

        display_blanks (output_column + 3);
        display ('Volume number ');
        display_integer (volume);
        display_line ('');

        display_blanks (output_column + 5);
        display ('Recorded_vsn: ');
        display (p_volume_list^ [volume].recorded_vsn);
        display_line ('');

        display_blanks (output_column + 5);
        display ('External_vsn: ');
        display (p_volume_list^ [volume].external_vsn);
        display_line ('');

      FOREND;

    IFEND;

  PROCEND pup$display_fmd;

?? TITLE := '*** PUP$DISPLAY_MASTER_CATALOG ***', EJECT ??
{       PUP$DISPLAY_MASTER_CATALOG -
{

  PROCEDURE [XDCL] pup$display_master_catalog;

    VAR
      master_catalog_name: pft$name,
      offset: pft$info_offset,
      p_catalog_record: pft$p_info_record,
      p_directory_array: pft$p_directory_array,
      p_info: pft$p_info,
      p_info_body: pft$p_info,
      p_info_record: pft$p_info_record,
      segment_pointer: amt$segment_pointer,
      status: ost$status;

    display_line (' Start of pfp$display_master_catalog.');
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, segment_pointer, status);
    p_info := segment_pointer.sequence_pointer;
    RESET p_info;
    pfp$get_item_info (master_catalog_path, public_group, catalog_info_selections, no_file_info_selections,
          p_info, status);
    IF status.normal THEN
      RESET p_info;
      pfp$find_next_info_record (p_info, p_info_record, status);
      IF status.normal THEN
        pfp$find_directory_array (p_info_record, p_directory_array, status);
        IF status.normal THEN
          master_catalog_name := p_directory_array^ [1].name;
          offset := p_directory_array^ [1].info_offset;
          p_info_body := ^p_info_record^.body;
          pfp$find_direct_info_record (p_info_body, offset, p_catalog_record, status);
          IF status.normal THEN
            pup$display_catalog_info (master_catalog_name, p_catalog_record, 2, status);
            IF status.normal THEN
              RESET p_info;
              display_blank_line;
              display_catalog_content (master_catalog_path, 4, p_info, status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    mmp$delete_scratch_segment (segment_pointer, status);
    display_line (' End of pfp$display_master_catalog.');
  PROCEND pup$display_master_catalog;
?? TITLE := '    [XDCL] pup$display_master_catalog_cmnd ', EJECT ??

  PROCEDURE [XDCL] pup$display_master_catalog_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? RIGHT := 110 ??
{ pdt dismc_pdt (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      dismc_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^dismc_pdt_names, ^dismc_pdt_params];

    VAR
      dismc_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      dismc_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??


    clp$scan_parameter_list (parameter_list, dismc_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$display_master_catalog;
  PROCEND pup$display_master_catalog_cmnd;

?? TITLE := '*** DISPLAY ***', EJECT ??
{       DISPLAY -
{

  PROCEDURE display
    (    strng: string ( * ));

    VAR
      index: [STATIC] integer := 1,
      line: [STATIC] string (255),
      size: integer,
      space: integer,
      status: ost$status;

    size := STRLENGTH (strng);
    IF (size > 0) THEN
      IF (strng = end_of_line) THEN
        pup$display_line (line (1, (index - 1)), status);
        index := 1;
      ELSE
        space := STRLENGTH (line) - index + 1;
        IF (size > space) THEN
          size := space;
        IFEND;
        line (index, size) := strng (1, size);
        index := index + size;
      IFEND;
    IFEND;
  PROCEND display;
?? TITLE := '*** DISPLAY_ACCESS_COUNT ***', EJECT ??
{       DISPLAY_ACCESS_COUNT -
{

  PROCEDURE display_access_count
    (    access_count: pft$access_count;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Access_count: ');
    display_integer (access_count);
    display_line ('');
  PROCEND display_access_count;
?? TITLE := '*** DISPLAY_ACCESS_DATE_TIME ***', EJECT ??
{       DISPLAY_ACCESS_DATE_TIME -
{

  PROCEDURE display_access_date_time
    (    access_date_time: ost$date_time;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Access_date_time: ');
    display_date_time (access_date_time);
    display_line ('');
  PROCEND display_access_date_time;
?? TITLE := '*** DISPLAY_ACCOUNT_NAME ***', EJECT ??
{       DISPLAY_ACCOUNT_NAME -
{

  PROCEDURE display_account_name
    (    account_name: avt$account_name;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Account: ');
    display_name (account_name);
    display_line ('');
  PROCEND display_account_name;

?? TITLE := '*** DISPLAY_AMD ***', EJECT ??
{       DISPLAY_AMD -
{

  PROCEDURE display_amd (
    VAR p_amd: pft$p_amd;
        output_column: integer);

    VAR
      amd_string_size: integer,
      p_amd_string: ^string (*);

    RESET p_amd;
    amd_string_size := #SIZE (p_amd^);
    NEXT p_amd_string: [amd_string_size] IN p_amd;

    display_blanks (output_column);
    display ('Archive Media Descriptor: ');
    display_line (p_amd_string^ (1, amd_string_size));

  PROCEND display_amd;

?? TITLE := '*** DISPLAY_APPLICATION_INFO ***', EJECT ??
{       DISPLAY_APPLICATION_INFO -
{

  PROCEDURE display_application_info
    (    application_info: pft$application_info;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Application_info: ');
    display_name (application_info);
    display_line ('');
  PROCEND display_application_info;

?? TITLE := '*** DISPLAY_ARCHIVE_ARRAY_ENTRY ***', EJECT ??
{       DISPLAY_ARCHIVE_ARRAY_ENTRY
{

  PROCEDURE display_archive_array_entry (
        p_archive_array_entry: pft$p_archive_array_entry;
        output_column: integer);

    display_blanks (output_column);
    display ('Version: ');
    IF p_archive_array_entry^.version = pfc$archive_entry_version_1 THEN
      display_line ('pfc$archive_entry_version_1');
    ELSEIF p_archive_array_entry^.version = pfc$archive_entry_version_2 THEN
      display_line ('pfc$archive_entry_version_2');
    ELSEIF p_archive_array_entry^.version = pfc$archive_entry_version_3 THEN
      display_line ('pfc$archive_entry_version_3');
    ELSEIF p_archive_array_entry^.version = pfc$archive_entry_version_4 THEN
      display_line ('pfc$archive_entry_version_4');
    ELSEIF p_archive_array_entry^.version = pfc$archive_entry_version_5 THEN
      display_line ('pfc$archive_entry_version_5');
    ELSEIF p_archive_array_entry^.version = pfc$archive_entry_version_6 THEN
      display_line ('pfc$archive_entry_version_6');
    ELSEIF p_archive_array_entry^.version = pfc$archive_entry_version_7 THEN
      display_line ('pfc$archive_entry_version_7');
    ELSEIF p_archive_array_entry^.version = pfc$archive_entry_version_8 THEN
      display_line ('pfc$archive_entry_version_8');
    IFEND;

    display_blanks (output_column);
    display ('Archive_date_time: ');
    display_date_time (p_archive_array_entry^.archive_date_time);
    display_line ('');

    display_blanks (output_column);
    display_line ('Archive_identification');

    display_blanks (output_column + 2);
    display ('Application_identifier: ');
    display_name (p_archive_array_entry^.archive_identification.application_identifier);
    display_line ('');

    display_blanks (output_column + 2);
    display ('Media_device_class: ');
    display_name (p_archive_array_entry^.archive_identification.media_identifier.media_device_class);
    display_line ('');

    display_blanks (output_column + 2);
    display ('Media_volume_identifier: ');
    display_name (p_archive_array_entry^.archive_identification.media_identifier.media_volume_identifier);
    display_line ('');

    display_blanks (output_column);
    display ('File_size: ');
    display_integer (p_archive_array_entry^.file_size);
    display_line ('');

    display_blanks (output_column);
    display ('Last_release_date_time: ');
    display_date_time (p_archive_array_entry^.last_release_date_time);
    display_line ('');

    display_blanks (output_column);
    display_line ('Last_retrieval_status');

    display_blanks (output_column + 2);
    display ('Retrieval_date_time: ');
    display_date_time (p_archive_array_entry^.last_retrieval_status.retrieval_date_time);
    display_line ('');

    display_blanks (output_column + 4);
    display_line ('Status');

    display_blanks (output_column + 6);
    display ('Normal: ');
    display_boolean (p_archive_array_entry^.last_retrieval_status.normal);
    display_line ('');

    IF NOT p_archive_array_entry^.last_retrieval_status.normal THEN
      display_blanks (output_column + 6);
      display ('Condition: ');
      display_integer (p_archive_array_entry^.last_retrieval_status.condition);
      display_line ('');
    IFEND;

    display_modification_date_time (p_archive_array_entry^.modification_date_time, output_column + 1);

    display_blanks (output_column);
    display_line ('Release_candidate');

    display_blanks (output_column + 2);
    display ('Releasable:');
    display_boolean (p_archive_array_entry^.release_candidate.releasable);
    display_line ('');

    IF p_archive_array_entry^.release_candidate.releasable THEN
      display_blanks (output_column + 2);
      display ('Mark_date_time: ');
      display_date_time (p_archive_array_entry^.release_candidate.mark_date_time);
      display_line ('');
    IFEND;

  PROCEND display_archive_array_entry;

?? TITLE := '*** DISPLAY_ARCHIVE_INFO ***', EJECT ??
{       DISPLAY_ARCHIVE_INFO
{

  PROCEDURE display_archive_info (
        p_archive_info_record: { input } pft$p_info_record;
        output_column: integer);

    VAR
      archive_identification: pft$archive_identification,
      p_archive_array_entry: pft$p_archive_array_entry,
      p_info_record: pft$p_info_record,
      p_info: pft$p_info,
      p_amd: pft$p_amd,
      status: ost$status;

    display_blank_line;
    display_blanks (output_column);
    display_line ('Archive Info ');
    p_info := ^p_archive_info_record^.body;
    archive_identification.application_identifier := osc$null_name;
    archive_identification.media_identifier.media_device_class := osc$null_name;
    archive_identification.media_identifier.media_volume_identifier := '';

    REPEAT
      pfp$find_next_archive_entry (archive_identification, p_info, p_info_record,
          p_archive_array_entry, p_amd, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      display_blanks (output_column + 2);
      display_line ('Archive Entry ');
      IF p_archive_array_entry <> NIL THEN
        display_archive_array_entry (p_archive_array_entry, output_column + 2);
      IFEND;
      IF p_amd <> NIL THEN
        display_amd (p_amd, output_column + 2);
      IFEND;
      display_blank_line;
    UNTIL FALSE;

  PROCEND display_archive_info;

?? TITLE := '*** DISPLAY_BOOLEAN  ***', EJECT ??

  PROCEDURE display_boolean
    (    value: boolean);

    IF value THEN
      display (' TRUE ');
    ELSE
      display (' FALSE ');
    IFEND;
  PROCEND display_boolean;
?? TITLE := '*** DISPLAY_BLANK_LINE ***', EJECT ??
{       DISPLAY_BLANK_LINE -
{

  PROCEDURE display_blank_line;

    display_line (' ');
  PROCEND display_blank_line;
?? TITLE := '*** DISPLAY_BLANKS ***', EJECT ??
{       DISPLAY_BLANKS -
{

  PROCEDURE display_blanks
    (    blank_count: integer);

    VAR
      blanks: [STATIC] string (255) := ' ',
      size: integer;

    size := STRLENGTH (blanks);
    IF (size > blank_count) THEN
      size := blank_count;
    IFEND;
    IF (size > 0) THEN
      display (blanks (1, size));
    IFEND;
  PROCEND display_blanks;
?? TITLE := '*** DISPLAY_CATALOG_CONTENT ***', EJECT ??
{       DISPLAY_CATALOG_CONTENT -
{

  PROCEDURE display_catalog_content
    (    path: pft$path;
         output_column: integer;
         p_info: pft$p_info;
     VAR status: ost$status);

    VAR
      directory_entry: pft$directory_array_entry,
      index: pft$array_index,
      item_name: pft$name,
      local_p_info: pft$p_info,
      name_type: pft$name_type,
      offset: pft$info_offset,
      p_directory_array: pft$p_directory_array,
      p_info_body: pft$p_info,
      p_info_record: pft$p_info_record,
      p_item_record: pft$p_info_record,
      p_successor_path: ^pft$path,
      successor_index: pft$array_index;

    successor_index := UPPERBOUND (path) + 1;
    PUSH p_successor_path: [1 .. successor_index];

  /copy_path/
    FOR index := 1 TO UPPERBOUND (path) DO
      p_successor_path^ [index] := path [index];
    FOREND /copy_path/;
    local_p_info := p_info;
    pfp$get_multi_item_info (path, public_group, catalog_info_selections, file_info_selections, local_p_info,
          status);
    IF status.normal THEN
      local_p_info := p_info;
      pfp$find_next_info_record (local_p_info, p_info_record, status);
      IF status.normal THEN
        pfp$find_directory_array (p_info_record, p_directory_array, status);
        IF status.normal THEN
          IF (p_directory_array <> NIL) THEN
            p_info_body := ^p_info_record^.body;

          /process_directory_array/
            FOR index := 1 TO UPPERBOUND (p_directory_array^) DO
              display_blank_line;
              directory_entry := p_directory_array^ [index];
              item_name := directory_entry.name;
              name_type := directory_entry.name_type;
              offset := directory_entry.info_offset;
              pfp$find_direct_info_record (p_info_body, offset, p_item_record, status);
              IF status.normal THEN
                CASE name_type OF
                = pfc$file_name =
                  pup$display_file_info (item_name, p_item_record, output_column, status);
                = pfc$catalog_name =
                  pup$display_catalog_info (item_name, p_item_record, output_column, status);
                  IF status.normal THEN
                    display_blank_line;
                    p_successor_path^ [successor_index] := item_name;
                    display_catalog_content (p_successor_path^, output_column + 2, local_p_info, status);
                  IFEND;
                ELSE
                CASEND;
              IFEND;
              IF NOT status.normal THEN
                EXIT /process_directory_array/;
              IFEND;
            FOREND /process_directory_array/;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND display_catalog_content;
?? TITLE := '*** DISPLAY_CATALOG_MEDIA  ***', EJECT ??

  PROCEDURE display_catalog_media
    (    catalog_media_description: pft$catalog_media_description;
         p_catalog_media: ^SEQ ( * );
         output_column: integer);

    VAR
      unique_name: ost$name,
      ignore: ost$status;

    display_blanks (output_column - 1);
    display_line ('Catalog media description ');
    pmp$convert_binary_unique_name (catalog_media_description.internal_name, unique_name, ignore);
    display_blanks (output_column + 1);
    display ('Internal name :');
    display (unique_name);
    display_line ('');

    display_blanks (output_column + 1);
    IF catalog_media_description.catalog_type = pfc$external_catalog THEN
      display_line ('External catalog ');

      display_blanks (output_column + 1);
      pmp$convert_binary_unique_name (catalog_media_description.global_file_name, unique_name, ignore);
      display ('Global file name: ');
      display (unique_name);
      display_line ('');

      display_blanks (output_column + 1);
      display ('Checksum ');
      display_integer (catalog_media_description.checksum);
      display_line ('');

      display_blanks (output_column + 1);
      display ('Media type [version=');
      display_integer ($INTEGER (catalog_media_description.file_media_type.media_version));

      pup$display_fmd (catalog_media_description.file_media_type.device_class, p_catalog_media^,
            output_column + 1, ignore);
    ELSE
      display_line ('Internal catalog ');
    IFEND;

  PROCEND display_catalog_media;

?? TITLE := '*** DISPLAY_CHARGE_ID ***', EJECT ??
{       DISPLAY_CHARGE_ID -
{

  PROCEDURE display_charge_id
    (    charge_id: pft$charge_id;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Charge_id: ');
    display_name (charge_id.account);
    display (', ');
    display_name (charge_id.project);
    display_line ('');
  PROCEND display_charge_id;
?? TITLE := '*** DISPLAY_CREATION_DATE_TIME ***', EJECT ??
{       DISPLAY_CREATION_DATE_TIME -
{

  PROCEDURE display_creation_date_time
    (    creation_date_time: ost$date_time;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Creation_date_time: ');
    display_date_time (creation_date_time);
    display_line ('');
  PROCEND display_creation_date_time;

?? TITLE := '*** DISPLAY_CYCLE_ARRAY_ENTRY_V1 ***', EJECT ??
{       DISPLAY_CYCLE_ARRAY_ENTRY_V1
{

  PROCEDURE display_cycle_array_entry_v1
    (    cycle_array_entry: pft$cycle_array_entry;
         output_column: integer);

    VAR
      ignore: ost$status;

    display_blanks (output_column - 1);
    display ('Cycle_number: ');
    display_integer (cycle_array_entry.cycle_number);
    display_line ('');

    display_cycle_statistics (cycle_array_entry.cycle_statistics, output_column);

    display_expiration_date_time (cycle_array_entry.expiration_date_time, output_column);

  PROCEND display_cycle_array_entry_v1;

?? TITLE := '*** DISPLAY_CYCLE_ARRAY_ENTRY_V2 ***', EJECT ??
{       DISPLAY_CYCLE_ARRAY_ENTRY_V2
{

  PROCEDURE display_cycle_array_entry_v2
    (    cycle_array_entry: pft$cycle_array_entry_version_2;
         output_column: integer);

    VAR
      ignore: ost$status,
      local_status: ost$status,
      shared_queue_name: ost$name,
      unique_name: ost$name;

    display_blanks (output_column - 1);
    display ('Bytes_allocated: ');
    display_integer (cycle_array_entry.bytes_allocated);
    display_line ('');

    display_cycle_damage_symptoms (cycle_array_entry.cycle_damage_symptoms, output_column);

    display_blanks (output_column - 1);
    display ('Cycle_number: ');
    display_integer (cycle_array_entry.cycle_number);
    display_line ('');

    display_cycle_statistics (cycle_array_entry.cycle_statistics, output_column);

    display_blanks (output_column - 1);
    display ('Data_modification_date_time: ');
    display_date_time (cycle_array_entry.data_modification_date_time);
    display_line ('');

    display_data_residence (cycle_array_entry.data_residence, output_column);

    display_rm_device_class (cycle_array_entry.device_class, output_column);

    display_blanks (output_column - 1);
    display ('EOI: ');
    display_integer (cycle_array_entry.bytes_allocated);
    display_line ('');

    display_expiration_date_time (cycle_array_entry.expiration_date_time, output_column);

    display_blanks (output_column - 1);
    pmp$convert_binary_unique_name (cycle_array_entry.original_unique_name, unique_name, ignore);
    display ('Original_unique_name: ');
    display (unique_name);
    display_line ('');

    display_blanks (output_column - 1);
    display ('Sparse_allocation: ');
    display_boolean (cycle_array_entry.sparse_allocation);
    display_line ('');

    display_blanks (output_column - 1);
    display ('Shared_queue: ');
    IF cycle_array_entry.shared_queue_info.defined THEN
      pfp$convert_ord_to_shared_queue (cycle_array_entry.shared_queue_info.shared_queue, shared_queue_name,
            local_status);
      IF NOT local_status.normal THEN
        shared_queue_name := pfc$system_shared_queue_name;
      IFEND;
    ELSE
      shared_queue_name := pfc$system_shared_queue_name;
    IFEND;
    display (shared_queue_name);
    display_line ('');

    display_retrieve_option (cycle_array_entry.retrieve_option, output_column);

    display_blanks (output_column - 1);
    display ('Site_archive_option: ');
    display_integer (cycle_array_entry.site_archive_option);
    display_line ('');

    display_blanks (output_column - 1);
    display ('Site_backup_option: ');
    display_integer (cycle_array_entry.site_backup_option);
    display_line ('');

    display_blanks (output_column - 1);
    display ('Site_release_option: ');
    display_integer (cycle_array_entry.site_release_option);
    display_line ('');

  PROCEND display_cycle_array_entry_v2;

?? TITLE := '*** DISPLAY_CYCLE_DAMAGE_SYMPTOMS ***', EJECT ??
{       DISPLAY_CYCLE_DAMAGE_SYMPTOMS -
{

  PROCEDURE display_cycle_damage_symptoms
    (    cycle_damage_symptoms: fst$cycle_damage_symptoms;
         output_column: integer);

    VAR
      first_selection: boolean,
      cycle_damage_symptom: fst$cycle_damage_symptom;

    display_blanks (output_column - 1);
    display ('Cycle_damage_symptoms: [');
    first_selection := TRUE;

  /display_damage_symptoms/
    FOR cycle_damage_symptom := LOWERVALUE (cycle_damage_symptom) TO UPPERVALUE (cycle_damage_symptom) DO
      IF (cycle_damage_symptom IN cycle_damage_symptoms) THEN
        IF NOT first_selection THEN
          display (', ');
        IFEND;
        first_selection := FALSE;
        CASE cycle_damage_symptom OF
        = fsc$media_image_inconsistent =
          display ('Media_image_inconsistent');
        = fsc$respf_modification_mismatch =
          display ('Respf_modification_mismatch');
        = fsc$cycle_restored =
          display ('Cycle_restored');
        = fsc$parent_catalog_restored =
          display ('Parent_catalog_restored');
        ELSE
        CASEND;
      IFEND;
    FOREND /display_damage_symptoms/;
    display_line (']');
  PROCEND display_cycle_damage_symptoms;

?? TITLE := ' *** DISPLAY_CYCLE_EXTENDED_ENTRY ***', EJECT ??

  PROCEDURE display_cycle_extended_entry
    (    cycle_array_entry: pft$cycle_directory_array_entry;
         p_cycle_info_record: pft$p_info_record;
         output_column: integer);

    VAR
      binary_name: ost$name,
      p_archive_list: pft$p_info_record,
      p_cycle_label: ^SEQ ( * ),
      p_fmd_description: pft$p_file_media_description,
      status: ost$status;

    display_blanks (output_column - 1);
    display ('Cycle info extended cycle : ');
    display_integer (cycle_array_entry.cycle_number);
    display_line ('');

    pmp$convert_binary_unique_name (cycle_array_entry.internal_name, binary_name, status);
    display_blanks (output_column);
    display ('Internal name : ');
    display (binary_name);
    display_line ('');

    display_blanks (output_column);
    display ('Info offset : ');
    display_integer (cycle_array_entry.info_offset);
    display_line ('');

    display_blanks (output_column);
    display ('Cycle number: ');
    display_integer (cycle_array_entry.cycle_number);
    display_line ('');

    pfp$find_cycle_media (p_cycle_info_record, p_fmd_description, status);
    IF status.normal THEN
      pmp$convert_binary_unique_name (p_fmd_description^.global_file_name, binary_name, status);

      display_blanks (output_column);
      display ('Global file name : ');
      display (binary_name);
      display_line ('');

      display_blanks (output_column);
      display ('Checksum : ');
      display_integer (p_fmd_description^.checksum);
      display_line ('');

      display_blanks (output_column);
      display ('Media type [version=');
      display_integer ($INTEGER (p_fmd_description^.file_media_type.media_version));

      pup$display_fmd (p_fmd_description^.file_media_type.device_class,
            p_fmd_description^.file_media_descriptor, output_column, status);

    ELSE
      status.normal := TRUE;
      display_line (' Unable to locate file media info ');
    IFEND;

    pfp$find_cycle_label (p_cycle_info_record, p_cycle_label, status);
    IF status.normal THEN
      pup$display_file_label (p_cycle_label^, output_column, status);
    ELSE
      status.normal := TRUE;
      display_line (' Unable to find cycle label ');
    IFEND;

    pfp$find_archive_info (p_cycle_info_record, p_archive_list, status);
    IF status.normal AND (p_archive_list <> NIL) THEN
      display_archive_info (p_archive_list, output_column);
    ELSE
      status.normal := TRUE;
      display_line (' Unable to find archive info ');
    IFEND;

  PROCEND display_cycle_extended_entry;

?? TITLE := '*** DISPLAY_CYCLE_INFO ***', EJECT ??
{       DISPLAY_CYCLE_INFO -
{

  PROCEDURE display_cycle_info
    (    p_file_record: pft$p_info_record;
         output_column: integer;
     VAR status: ost$status);

    VAR
      cycle_index: pft$array_index,
      p_cycle_array_version_1: ^pft$cycle_array,
      p_cycle_array_version_2: ^pft$cycle_array_version_2;

    IF puv$respf_backup_file_version = puc$backup_file_version_1 THEN
      pfp$find_cycle_array (p_file_record, p_cycle_array_version_1, status);
    ELSEIF puv$respf_backup_file_version = puc$backup_file_version_2 THEN
      pfp$find_cycle_array_version_2 (p_file_record, p_cycle_array_version_2, status);
    IFEND;

    IF status.normal THEN
      display_blanks (output_column - 1);
      display_line ('Cycles: ');
      IF puv$respf_backup_file_version = puc$backup_file_version_1 THEN
        IF (p_cycle_array_version_1 <> NIL) THEN
        /display_all_version_1_cycles/
          FOR cycle_index := 1 TO UPPERBOUND (p_cycle_array_version_1^) DO
            display_blank_line;
            display_cycle_array_entry_v1 (p_cycle_array_version_1^ [cycle_index], output_column + 2);
          FOREND /display_all_version_1_cycles/;
        IFEND;
      ELSEIF puv$respf_backup_file_version = puc$backup_file_version_2 THEN
        IF (p_cycle_array_version_2 <> NIL) THEN
        /display_all_version_2_cycles/
          FOR cycle_index := 1 TO UPPERBOUND (p_cycle_array_version_2^) DO
            display_blank_line;
            display_cycle_array_entry_v2 (p_cycle_array_version_2^ [cycle_index], output_column + 2);
          FOREND /display_all_version_2_cycles/;
        IFEND;
      IFEND;
    IFEND;
  PROCEND display_cycle_info;

?? TITLE := '*** DISPLAY_CYCLE_INFO_EXTENDED ***', EJECT ??
{       DISPLAY_CYCLE_INFO_EXTENDED -
{

  PROCEDURE display_cycle_info_extended
    (    p_file_record: pft$p_info_record;
         output_column: integer;
     VAR status: ost$status);

    VAR
      cycle_index: pft$array_index,
      p_cycle_array_extended_record: pft$p_info_record,
      p_cycle_directory_array: pft$p_cycle_directory_array,
      p_cycle_info_extended_body: pft$p_info,
      p_cycle_info_record: pft$p_info_record;

    pfp$find_cycle_array_extended (p_file_record, p_cycle_array_extended_record, status);
    IF status.normal THEN
      p_cycle_info_extended_body := ^p_cycle_array_extended_record^.body;

      pfp$find_cycle_directory (p_cycle_array_extended_record, p_cycle_directory_array, status);
      IF status.normal AND (p_cycle_directory_array <> NIL) THEN
        display_blanks (output_column - 1);
        display_line ('Cycles Extended : ');

      /display_all_cycles/
        FOR cycle_index := 1 TO UPPERBOUND (p_cycle_directory_array^) DO
          pfp$find_direct_info_record (p_cycle_info_extended_body,
                p_cycle_directory_array^ [cycle_index].info_offset, p_cycle_info_record, status);
          IF status.normal THEN
            display_blank_line;
            display_cycle_extended_entry (p_cycle_directory_array^ [cycle_index], p_cycle_info_record,
                  output_column + 2);
          ELSE
            RETURN;
          IFEND
        FOREND /display_all_cycles/;
      IFEND;
    ELSEIF (status.condition = pfe$unknown_cycle_array) THEN
      display_blanks (output_column - 1);
      display_line ('Cycle fmd, label, and archive information not included ');
      status.normal := TRUE;
    IFEND;
  PROCEND display_cycle_info_extended;
?? TITLE := '*** DISPLAY_CYCLE_STATISTICS ***', EJECT ??
{       DISPLAY_CYCLE_STATISTICS -
{

  PROCEDURE display_cycle_statistics
    (    cycle_statistics: pft$cycle_statistics;
         output_column: integer);

    VAR
      column: integer;

    display_blanks (output_column - 1);
    display_line ('Statistics: ');
    column := output_column + 2;
    display_creation_date_time (cycle_statistics.creation_date_time, column);
    display_modification_date_time (cycle_statistics.modification_date_time, column);
    display_access_date_time (cycle_statistics.access_date_time, column);
    display_access_count (cycle_statistics.access_count, column);
  PROCEND display_cycle_statistics;
?? TITLE := '*** DISPLAY_DATE_TIME ***', EJECT ??
{       DISPLAY_DATE_TIME -
{

  PROCEDURE display_date_time
    (    date_time: ost$date_time);

    VAR
      date: ost$date,
      status: ost$status,
      time: ost$time;

    pmp$format_compact_date (date_time, osc$mdy_date, date, status);
    display (date.mdy);
    display (' ');
    pmp$format_compact_time (date_time, osc$millisecond_time, time, status);
    display (time.millisecond);
  PROCEND display_date_time;

?? TITLE := '*** DISPLAY_DATA_RESIDENCE ***', EJECT ??
{       DISPLAY_DATA_RESIDENCE
{

  PROCEDURE display_data_residence
    (    data_residence: pft$data_residence;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Data_residence: ');

    CASE data_residence OF
    = pfc$unreleasable_data =
      display ('pfc$unreleasable_data');
    = pfc$releasable_data =
      display ('pfc$releasable_data');
    = pfc$release_data_requested =
      display ('pfc$release_data_requested');
    = pfc$offline_data =
      display ('pfc$offline_data');
    ELSE
      display ('pfc$unreleasable_data');
    CASEND;

    display_line ('');

  PROCEND display_data_residence;

?? TITLE := '*** DISPLAY_TAPE_DENSITY ***', EJECT ??
{       DISPLAY_TAPE_DENSITY
{

  PROCEDURE display_density
    (    density: rmt$density;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Density: ');

    CASE density OF
    = rmc$200 =
      display ('rmc$200');
    = rmc$556 =
      display ('rmc$556');
    = rmc$800 =
      display ('rmc$800');
    = rmc$1600 =
      display ('rmc$1600');
    = rmc$6250 =
      display ('rmc$6250');
    = rmc$38000 =
      display ('rmc$38000');
    ELSE
      display ('undefined');
    CASEND;

    display_line ('');

  PROCEND display_density;

?? TITLE := '*** DISPLAY_EXPIRATION_DATE_TIME ***', EJECT ??
{       DISPLAY_EXPIRATION_DATE_TIME -
{

  PROCEDURE display_expiration_date_time
    (    expiration_date_time: ost$date_time;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Expiration_date_time: ');
    IF (expiration_date_time = highest_date_time) THEN
      display ('None');
    ELSE
      display_date_time (expiration_date_time);
    IFEND;
    display_line ('');

  PROCEND display_expiration_date_time;
?? TITLE := '*** DISPLAY_FAMILY_CONTENT ***', EJECT ??
{       DISPLAY_FAMILY_CONTENT -
{

  PROCEDURE display_family_content
    (    set_name: stt$set_name;
         family_name: pft$name;
         output_column: integer;
         p_info: pft$p_info;
     VAR status: ost$status);

    VAR
      directory_entry: pft$directory_array_entry,
      index: pft$array_index,
      local_p_info: pft$p_info,
      master_catalog_name: pft$name,
      master_catalog_path: array [1 .. 2] of pft$name,
      name_type: pft$name_type,
      offset: pft$info_offset,
      p_catalog_record: pft$p_info_record,
      p_directory_array: pft$p_directory_array,
      p_info_body: pft$p_info,
      p_info_record: pft$p_info_record;

    local_p_info := p_info;
    pfp$get_master_catalog_info (set_name, family_name, catalog_info_selections, local_p_info, status);
    IF status.normal THEN
      local_p_info := p_info;
      pfp$find_next_info_record (local_p_info, p_info_record, status);
      IF status.normal THEN
        pfp$find_directory_array (p_info_record, p_directory_array, status);
        IF status.normal THEN
          IF (p_directory_array <> NIL) THEN
            master_catalog_path [pfc$family_name_index] := family_name;
            p_info_body := ^p_info_record^.body;

          /process_directory_array/
            FOR index := 1 TO UPPERBOUND (p_directory_array^) DO
              display_blank_line;
              directory_entry := p_directory_array^ [index];
              master_catalog_name := directory_entry.name;
              name_type := directory_entry.name_type;
              offset := directory_entry.info_offset;
              IF (name_type = pfc$catalog_name) THEN
                pfp$find_direct_info_record (p_info_body, offset, p_catalog_record, status);
                IF status.normal THEN
                  pup$display_catalog_info (master_catalog_name, p_catalog_record, output_column, status);
                  IF status.normal THEN
                    display_blank_line;
                    master_catalog_path [pfc$master_catalog_name_index] := master_catalog_name;
                    display_catalog_content (master_catalog_path, output_column + 2, local_p_info, status);
                  IFEND;
                IFEND;
                IF NOT status.normal THEN
                  EXIT /process_directory_array/;
                IFEND;
              IFEND;
            FOREND /process_directory_array/;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND display_family_content;
?? TITLE := '*** DISPLAY_FAMILY_NAME ***', EJECT ??
{       DISPLAY_FAMILY_NAME -
{

  PROCEDURE display_family_name
    (    family_name: ost$family_name;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Family: ');
    display_name (family_name);
    display_line ('');
  PROCEND display_family_name;
?? TITLE := '*** DISPLAY_FILE_DESCRIPTION ***', EJECT ??
{       DISPLAY_FILE_DESCRIPTION -
{

  PROCEDURE display_file_description
    (    p_file_record: pft$p_info_record;
         output_column: integer;
     VAR status: ost$status);

    VAR
      p_file_description: pft$p_file_description;

    pfp$find_file_description (p_file_record, p_file_description, status);
    IF status.normal THEN
      display_password (p_file_description^.password, output_column);
      display_charge_id (p_file_description^.charge_id, output_column);
      display_logging (p_file_description^.logging_selection, output_column);
    IFEND;
  PROCEND display_file_description;
?? TITLE := '*** DISPLAY_GROUP ***', EJECT ??
{       DISPLAY_GROUP -
{

  PROCEDURE display_group
    (    group: pft$group;
         output_column: integer);

    VAR
      column: integer;

    display_blanks (output_column - 1);
    display_line ('Group:');
    column := output_column + 2;
    display_group_type (group.group_type, column);
    CASE group.group_type OF
    = pfc$public =
    = pfc$family =
      display_family_name (group.family_description.family, column);
    = pfc$account =
      display_family_name (group.account_description.family, column);
      display_account_name (group.account_description.account, column);
    = pfc$project =
      display_family_name (group.project_description.family, column);
      display_account_name (group.project_description.account, column);
      display_project_name (group.project_description.project, column);
    = pfc$user =
      display_family_name (group.user_description.family, column);
      display_user_name (group.user_description.user, column);
    = pfc$user_account =
      display_family_name (group.user_account_description.family, column);
      display_account_name (group.user_account_description.account, column);
      display_user_name (group.user_account_description.user, column);
    = pfc$member =
      display_family_name (group.member_description.family, column);
      display_user_name (group.member_description.user, column);
      display_account_name (group.member_description.account, column);
      display_project_name (group.member_description.project, column);
    ELSE
    CASEND;
  PROCEND display_group;
?? TITLE := '*** DISPLAY_GROUP_TYPE ***', EJECT ??
{       DISPLAY_GROUP_TYPE -
{

  PROCEDURE display_group_type
    (    group_type: pft$group_types;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Group_type: ');
    CASE group_type OF
    = pfc$public =
      display ('Public');
    = pfc$family =
      display ('Family');
    = pfc$account =
      display ('Account');
    = pfc$project =
      display ('Project');
    = pfc$user =
      display ('User');
    = pfc$user_account =
      display ('User_account');
    = pfc$member =
      display ('Member');
    ELSE
    CASEND;
    display_line ('');
  PROCEND display_group_type;
?? TITLE := '*** DISPLAY_INTEGER ***', EJECT ??
{       DISPLAY_INTEGER -
{

  PROCEDURE display_integer
    (    intgr: integer);

    VAR
      length: integer,
      strng: string (30);

    STRINGREP (strng, length, intgr);
    display (strng (1, length));
  PROCEND display_integer;
?? TITLE := '*** DISPLAY_LINE ***', EJECT ??
{       DISPLAY_LINE -
{

  PROCEDURE display_line
    (    strng: string ( * ));

    display (strng);
    display (end_of_line);
  PROCEND display_line;
?? TITLE := '*** DISPLAY_LOG_ENTRY ***', EJECT ??
{       DISPLAY_LOG_ENTRY -
{

  PROCEDURE display_log_entry
    (    log_entry: pft$log_array_entry;
         output_column: integer);

    display_family_name (log_entry.user_id.family, output_column);
    display_user_name (log_entry.user_id.user, output_column);
    display_access_date_time (log_entry.access_date_time, output_column);
    display_access_count (log_entry.access_count, output_column);

    display_blanks (output_column - 1);
    display ('Last_cycle: ');
    display_integer (log_entry.last_cycle);
    display_line ('');
  PROCEND display_log_entry;
?? TITLE := '*** DISPLAY_LOGGING ***', EJECT ??
{       DISPLAY_LOGGING -
{

  PROCEDURE display_logging
    (    logging: pft$log;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Logging: ');
    CASE logging OF
    = pfc$log =
      display ('Log');
    = pfc$no_log =
      display ('No_log');
    ELSE
    CASEND;
    display_line ('');
  PROCEND display_logging;
?? TITLE := '*** DISPLAY_LOG_INFO ***', EJECT ??
{       DISPLAY_LOG_INFO -
{

  PROCEDURE display_log_info
    (    p_file_record: pft$p_info_record;
         output_column: integer;
     VAR status: ost$status);

    VAR
      log_index: pft$array_index,
      p_log_array: pft$p_log_array;

    pfp$find_log_array (p_file_record, p_log_array, status);
    IF status.normal THEN
      display_blanks (output_column - 1);
      IF (p_log_array = NIL) THEN
        display_line ('Log: None ');
      ELSE
        display_line ('Log: ');

      /display_all_logs/
        FOR log_index := 1 TO UPPERBOUND (p_log_array^) DO
          display_blank_line;
          display_log_entry (p_log_array^ [log_index], output_column + 2);
        FOREND /display_all_logs/;
      IFEND;
    IFEND;
  PROCEND display_log_info;
?? TITLE := '*** DISPLAY_MODIFICATION_DATE_TIME ***', EJECT ??
{       DISPLAY_MODIFICATION_DATE_TIME -
{

  PROCEDURE display_modification_date_time
    (    modification_date_time: ost$date_time;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Modification_date_time: ');
    display_date_time (modification_date_time);
    display_line ('');
  PROCEND display_modification_date_time;
?? TITLE := '*** DISPLAY_NAME ***', EJECT ??
{       DISPLAY_NAME -
{

  PROCEDURE display_name
    (    name: string ( * <= 31));

    VAR
      size: integer;

    size := STRLENGTH (name);
    WHILE ((size > 0) AND (name (size) = ' ')) DO
      size := size - 1;
    WHILEND;
    display (name (1, size));
  PROCEND display_name;
?? TITLE := '*** DISPLAY_PASSWORD ***', EJECT ??
{       DISPLAY_PASSWORD -
{

  PROCEDURE display_password
    (    password: pft$password;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Password: ');
    display_name (password);
    display_line ('');
  PROCEND display_password;
?? TITLE := '*** DISPLAY_PERMIT_ENTRY ***', EJECT ??
{       DISPLAY_PERMIT_ENTRY -
{

  PROCEDURE display_permit_entry
    (    permit_entry: pft$permit_array_entry;
         output_column: integer);

    display_group (permit_entry.group, output_column);
    display_usage (permit_entry.usage_permissions, output_column);
    display_share (permit_entry.share_requirements, output_column);
    display_application_info (permit_entry.application_info, output_column);
  PROCEND display_permit_entry;
?? TITLE := '*** DISPLAY_PERMIT_INFO ***', EJECT ??
{       DISPLAY_PERMIT_INFO -
{

  PROCEDURE display_permit_info
    (    p_file_record: pft$p_info_record;
         output_column: integer;
     VAR status: ost$status);

    VAR
      p_permit_array: pft$p_permit_array,
      permit_index: pft$array_index;

    pfp$find_permit_array (p_file_record, p_permit_array, status);
    IF status.normal THEN
      display_blanks (output_column - 1);
      IF p_permit_array = NIL THEN
        display_line ('Permits: None ');
      ELSE
        display_line ('Permits:');

      /display_all_permits/
        FOR permit_index := 1 TO UPPERBOUND (p_permit_array^) DO
          display_permit_entry (p_permit_array^ [permit_index], output_column + 2);
        FOREND /display_all_permits/;
      IFEND;
    IFEND;
  PROCEND display_permit_info;

?? TITLE := '*** DISPLAY_PF_DEVICE_CLASS ***', EJECT ??
{       DISPLAY_PF_DEVICE_CLASS
{

  PROCEDURE display_pf_device_class
    (    pf_device_class: pft$device_class;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Device_class: ');

    CASE pf_device_class OF
    = pfc$connected_file_device =
      display ('pfc$connected_file_device');
    = pfc$interstate_link_device =
      display ('pfc$interstate_link_device');
    = pfc$local_queue_device =
      display ('pfc$local_queue_device');
    = pfc$log_device =
      display ('pfc$log_device');
    = pfc$magnetic_tape_device =
      display ('pfc$magnetic_tape_device');
    = pfc$mass_storage_device =
      display ('pfc$mass_storage_device');
    = pfc$memory_resident_device =
      display ('pfc$memory_resident_device');
    = pfc$network_device =
      display ('pfc$network_device');
    = pfc$null_device =
      display ('pfc$null_device');
    = pfc$pipeline_device =
      display ('pfc$pipeline_device');
    = pfc$rhfam_device =
      display ('pfc$rhfam_device');
    = pfc$terminal_device =
      display ('pfc$terminal_device');
    ELSE
      display ('pfc$mass_storage_device');
    CASEND;

    display_line ('');

  PROCEND display_pf_device_class;

?? TITLE := '*** DISPLAY_PROJECT_NAME ***', EJECT ??
{       DISPLAY_PROJECT_NAME -
{

  PROCEDURE display_project_name
    (    project_name: avt$project_name;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Project: ');
    display_name (project_name);
    display_line ('');
  PROCEND display_project_name;

?? TITLE := '*** DISPLAY_RM_DEVICE_CLASS ***', EJECT ??
{       DISPLAY_RM_DEVICE_CLASS
{

  PROCEDURE display_rm_device_class
    (    rm_device_class: rmt$device_class;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Device_class: ');

    CASE rm_device_class OF
    = rmc$connected_file_device =
      display ('rmc$connected_file_device');
    = rmc$interstate_link_device =
      display ('rmc$interstate_link_device');
    = rmc$local_queue_device =
      display ('rmc$local_queue_device');
    = rmc$log_device =
      display ('rmc$log_device');
    = rmc$magnetic_tape_device =
      display ('rmc$magnetic_tape_device');
    = rmc$mass_storage_device =
      display ('rmc$mass_storage_device');
    = rmc$memory_resident_device =
      display ('rmc$memory_resident_device');
    = rmc$network_device =
      display ('rmc$network_device');
    = rmc$null_device =
      display ('rmc$null_device');
    = rmc$pipeline_device =
      display ('rmc$pipeline_device');
    = rmc$rhfam_device =
      display ('rmc$rhfam_device');
    = rmc$terminal_device =
      display ('rmc$terminal_device');
    ELSE
      display ('rmc$mass_storage_device');
    CASEND;

    display_line ('');

  PROCEND display_rm_device_class;

?? TITLE := '*** DISPLAY_RETRIEVE_OPTION ***', EJECT ??
{       DISPLAY_RETRIEVE_OPTION
{

  PROCEDURE display_retrieve_option
    (    retrieve_option: pft$retrieve_option;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('Retrieve_option: ');

    CASE retrieve_option OF
    = pfc$always_retrieve =
      display ('pfc$always_retrieve');
    = pfc$explicit_retrieve_only =
      display ('pfc$explicit_retrieve_only');
    = pfc$admin_retrieve_only =
      display ('pfc$admin_retrieve_only');
    CASEND;

    display_line ('');

  PROCEND display_retrieve_option;

?? TITLE := '*** DISPLAY_SHARE ***', EJECT ??
{       DISPLAY_SHARE -
{

  PROCEDURE display_share
    (    share: pft$share_requirements;
         output_column: integer);

    VAR
      first_selection: boolean,
      share_option: pft$share_options;

    display_blanks (output_column - 1);
    display ('Share: ');
    first_selection := TRUE;

  /display_share_options/
    FOR share_option := LOWERVALUE (share_option) TO UPPERVALUE (share_option) DO
      IF (share_option IN share) THEN
        IF NOT first_selection THEN
          display (', ');
        IFEND;
        first_selection := FALSE;
        CASE share_option OF
        = pfc$read =
          display ('Read');
        = pfc$shorten =
          display ('Shorten');
        = pfc$append =
          display ('Append');
        = pfc$modify =
          display ('Modify');
        = pfc$execute =
          display ('Execute');
        ELSE
        CASEND;
      IFEND;
    FOREND /display_share_options/;
    display_line ('');
  PROCEND display_share;
?? TITLE := '*** DISPLAY_USAGE ***', EJECT ??
{       DISPLAY_USAGE -
{

  PROCEDURE display_usage
    (    usage: pft$permit_selections;
         output_column: integer);

    VAR
      first_selection: boolean,
      usage_option: pft$permit_options;

    display_blanks (output_column - 1);
    display ('Usage: ');
    first_selection := TRUE;

  /display_usage_options/
    FOR usage_option := LOWERVALUE (usage_option) TO UPPERVALUE (usage_option) DO
      IF (usage_option IN usage) THEN
        IF NOT first_selection THEN
          display (', ');
        IFEND;
        first_selection := FALSE;
        CASE usage_option OF
        = pfc$read =
          display ('Read');
        = pfc$shorten =
          display ('Shorten');
        = pfc$append =
          display ('Append');
        = pfc$modify =
          display ('Modify');
        = pfc$execute =
          display ('Execute');
        = pfc$cycle =
          display ('Cycle');
        = pfc$control =
          display ('Control');
        ELSE
        CASEND;
      IFEND;
    FOREND /display_usage_options/;
    display_line ('');
  PROCEND display_usage;
?? TITLE := '*** DISPLAY_USER_NAME ***', EJECT ??
{       DISPLAY_USER_NAME -
{

  PROCEDURE display_user_name
    (    user_name: ost$user_name;
         output_column: integer);

    display_blanks (output_column - 1);
    display ('User: ');
    display_name (user_name);
    display_line ('');
  PROCEND display_user_name;
?? SKIP := 4 ??
MODEND pum$display_catalogs;
*DECK DECK=PUM$EXCLUDED_ITEM_MANAGEMENT EXPAND=TRUE
*copyc osd$default_pragmats
?? RIGHT := 110 ??
??
NEWTITLE := ' NOS/VE Backup/Restore Utilities:  excluded_item_management ', EJECT ??
MODULE pum$excluded_item_management;

?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$scan_parameter_list
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc pfp$get_family_set
*copyc pud$hierarchy_list
*copyc pue$error_condition_codes
*copyc pup$build_catalog_header
*copyc pup$build_entry
*copyc pup$compare_item_descriptor
*copyc pup$compare_paths
*copyc pup$crack_catalog
*copyc pup$crack_permanent_file
*copyc pup$display_item_descriptor
*copyc pup$display_line
*copyc pup$find_cycle_entry
*copyc pup$set_abnormal_entry_status
*copyc pup$verify_catalog_path
*copyc pup$verify_family_administrator
*copyc pup$verify_file_path
*copyc pup$write_path
*copyc put$excluded_item_entry
?? POP ??
?? TITLE := '    Global Variables', EJECT ??

  VAR
    excluded_item_list: put$excluded_item_list := [REP 6 of NIL];

?? TITLE := '    [XDCL] pup$check_if_item_excluded ', EJECT ??

  PROCEDURE [XDCL] pup$check_if_item_excluded (entry: put$entry;
        catalog_header: put$catalog_header;
    VAR item_excluded: boolean);

    pup$search_item_list (entry, catalog_header, excluded_item_list [entry.entry_type], item_excluded);
  PROCEND pup$check_if_item_excluded;

?? TITLE := '    [XDCL] pup$check_if_subitem_excluded ', EJECT ??

  PROCEDURE [XDCL] pup$check_if_subitem_excluded (catalog_header: put$catalog_header;
    VAR subitem_excluded: boolean);

  {This procedure determines whether a catlog contains files or subcatalogs that
  {have been excluded by BACPF EXCLUDE_FILE or EXCLUDE_CATALOG subcommands.

    VAR
      entry_type: put$entry_type,
      ignore_a_equals_b: boolean,
      p_item_entry: ^put$excluded_item_entry;

    subitem_excluded := FALSE;
    FOR entry_type := puc$valid_catalog_entry TO puc$valid_cycle_entry DO
      p_item_entry :=  excluded_item_list [entry_type];
      WHILE (p_item_entry <> NIL) DO
        pup$compare_paths (catalog_header.path, p_item_entry^.catalog_header.path, ignore_a_equals_b,
              subitem_excluded);
        IF NOT subitem_excluded THEN
          p_item_entry := p_item_entry^.p_next_excluded_entry;
        ELSE
          RETURN;
        IFEND;
      WHILEND;
    FOREND;
  PROCEND pup$check_if_subitem_excluded;

?? TITLE := '    [XDCL] pup$display_excluded_items ', EJECT ??

  PROCEDURE [XDCL] pup$display_excluded_items (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT display_excluded_pdt (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_excluded_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^display_excluded_pdt_names, ^display_excluded_pdt_params];

    VAR
      display_excluded_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
        clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      display_excluded_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
        clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      entry_type: put$entry_type,
      item_found_excluded: boolean,
      p_item_entry: ^put$excluded_item_entry;

    clp$scan_parameter_list (parameter_list, display_excluded_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    item_found_excluded := FALSE;
    FOR entry_type := puc$valid_family_entry TO puc$valid_cycle_entry DO
      p_item_entry := excluded_item_list [entry_type];
      IF p_item_entry <> NIL THEN
        item_found_excluded := TRUE;
        CASE entry_type OF
        = puc$valid_family_entry, puc$valid_catalog_entry =
          pup$display_line (' EXCLUDED_CATALOGS ----', status);
        = puc$valid_pf_entry =
          pup$display_line (' EXCLUDED PERMANENT FILES ----', status);
        ELSE
          pup$display_line (' EXCLUDED CYCLES ----', status);
        CASEND;
        WHILE p_item_entry <> NIL DO
          pup$display_item_descriptor ('----', p_item_entry^.catalog_header, p_item_entry^.entry, status);
          p_item_entry := p_item_entry^.p_next_excluded_entry;
        WHILEND;
      IFEND;
    FOREND;
    IF NOT item_found_excluded THEN
      pup$display_line (' ALL CATALOGS, AND FILES INCLUDED', status);
    IFEND;
  PROCEND pup$display_excluded_items;


?? TITLE := '    [XDCL] pup$exclude_catalog_command ', EJECT ??

  PROCEDURE [XDCL] pup$exclude_catalog_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT exclude_catalog_pdt (
{  catalog,c: file = $REQUIRED
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      exclude_catalog_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^exclude_catalog_pdt_names, ^exclude_catalog_pdt_params];

    VAR
      exclude_catalog_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['CATALOG', 1], ['C', 1], ['STATUS', 2]];

    VAR
      exclude_catalog_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
        clt$parameter_descriptor := [

{ CATALOG C }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      catalog_path_container: clt$path_container,
      dummy_cycle_selector: pft$cycle_selector,
      entry: put$entry,
      entry_type: put$entry_type,
      p_catalog_header: ^put$catalog_header,
      p_catalog_path: ^pft$path,
      set_name: stt$set_name;

    clp$scan_parameter_list (parameter_list, exclude_catalog_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_catalog ('CATALOG', catalog_path_container, p_catalog_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$verify_catalog_path (p_catalog_path^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF UPPERBOUND (p_catalog_path^) = pfc$family_name_index THEN
      entry_type := puc$valid_family_entry;
      pup$verify_family_administrator (' EXCLUDE_CATALOG', p_catalog_path^ [UPPERBOUND (p_catalog_path^)],
            status);
      IF NOT status.normal THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, ' to exclude a family ', status);
        RETURN;
      IFEND;
    ELSE
      entry_type := puc$valid_catalog_entry;
    IFEND;


    pfp$get_family_set (p_catalog_path^ [pfc$family_name_index], set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$build_entry (p_catalog_path^ [UPPERBOUND (p_catalog_path^)], dummy_cycle_selector,
          entry_type, entry);
    PUSH p_catalog_header: [1 .. UPPERBOUND (p_catalog_path^)];
    pup$build_catalog_header (set_name, p_catalog_path, p_catalog_header^);
    exclude_item (entry, p_catalog_header^, status);
    IF status.normal THEN
      pup$display_item_descriptor (' EXCLUDE_CATALOG ', p_catalog_header^, entry, status);
    IFEND;
  PROCEND pup$exclude_catalog_command;


?? TITLE := '    [XDCL] pup$exclude_pf_command ', EJECT ??

  PROCEDURE [XDCL] pup$exclude_pf_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT exclude_pf_pdt (
{  file, f: file = $required
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      exclude_pf_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^exclude_pf_pdt_names,
        ^exclude_pf_pdt_params];

    VAR
      exclude_pf_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['FILE', 1], ['F', 1], ['STATUS', 2]];

    VAR
      exclude_pf_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor :=
        [

{ FILE F }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      cycle_array_entry: pft$cycle_array_entry_version_2,
      cycle_selector: pft$cycle_selector,
      cycle_selector_specified: boolean,
      entry: put$entry,
      p_catalog_header: ^put$catalog_header,
      p_pf_path: ^pft$path,
      pf_path_container: clt$path_container,
      set_name: stt$set_name;

    clp$scan_parameter_list (parameter_list, exclude_pf_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_permanent_file ('FILE', $put$cycle_reference_selections [puc$cycle_omitted, puc$specific_cycle,
          puc$highest_cycle, puc$lowest_cycle], pf_path_container, p_pf_path, cycle_selector_specified,
          cycle_selector, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_selector_specified THEN
      pup$find_cycle_entry (p_pf_path^, cycle_selector, cycle_array_entry, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      cycle_selector.cycle_option := pfc$specific_cycle;
      cycle_selector.cycle_number := cycle_array_entry.cycle_number;
      pup$build_entry (p_pf_path^ [UPPERBOUND (p_pf_path^)], cycle_selector, puc$valid_cycle_entry, entry);
    ELSE { permanent file path
      pup$verify_file_path (p_pf_path^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pup$build_entry (p_pf_path^ [UPPERBOUND (p_pf_path^)], cycle_selector, puc$valid_pf_entry, entry);
    IFEND;

    pfp$get_family_set (p_pf_path^ [pfc$family_name_index], set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_catalog_header: [1 .. UPPERBOUND (p_pf_path^)];
    pup$build_catalog_header (set_name, p_pf_path, p_catalog_header^);
    exclude_item (entry, p_catalog_header^, status);
    IF status.normal THEN
      pup$display_item_descriptor (' EXCLUDE_PERMANENT_FILE ', p_catalog_header^, entry, status);
    IFEND;
  PROCEND pup$exclude_pf_command;

?? TITLE := '    [XDCL] pup$include_catalog_command ', EJECT ??

  PROCEDURE [XDCL] pup$include_catalog_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT include_catalog_pdt (
{  catalog,c: file = $REQUIRED
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      include_catalog_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^include_catalog_pdt_names, ^include_catalog_pdt_params];

    VAR
      include_catalog_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['CATALOG', 1], ['C', 1], ['STATUS', 2]];

    VAR
      include_catalog_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
        clt$parameter_descriptor := [

{ CATALOG C }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      catalog_path_container: clt$path_container,
      dummy_cycle_selector: pft$cycle_selector,
      entry: put$entry,
      entry_type: put$entry_type,
      p_catalog_header: ^put$catalog_header,
      p_catalog_path: ^pft$path,
      set_name: stt$set_name;


    clp$scan_parameter_list (parameter_list, include_catalog_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_catalog ('CATALOG', catalog_path_container, p_catalog_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    pfp$get_family_set (p_catalog_path^ [pfc$family_name_index], set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF UPPERBOUND (p_catalog_path^) = pfc$family_name_index THEN
      entry_type := puc$valid_family_entry;
    ELSE
      entry_type := puc$valid_catalog_entry;
    IFEND;
    pup$build_entry (p_catalog_path^ [UPPERBOUND (p_catalog_path^)], dummy_cycle_selector,
          entry_type, entry);
    PUSH p_catalog_header: [1 .. UPPERBOUND (p_catalog_path^)];
    pup$build_catalog_header (set_name, p_catalog_path, p_catalog_header^);
    include_item (entry, p_catalog_header^, status);
    IF status.normal THEN
      pup$display_item_descriptor (' INCLUDE_CATALOG ', p_catalog_header^, entry, status);
    IFEND;
  PROCEND pup$include_catalog_command;

?? TITLE := '    [XDCL] pup$include_excluded_items ', EJECT ??

  PROCEDURE [XDCL] pup$include_excluded_items (parameter_list: clt$parameter_list;
    VAR status: ost$status);
{ PDT include_exc_items_pdt (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      include_exc_items_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^include_exc_items_pdt_names, ^include_exc_items_pdt_params];

    VAR
      include_exc_items_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
        clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      include_exc_items_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
        clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      entry_kind: put$entry_type;

    clp$scan_parameter_list (parameter_list, include_exc_items_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR entry_kind := LOWERBOUND (excluded_item_list) TO UPPERBOUND (excluded_item_list) DO
      delete_all_items (excluded_item_list [entry_kind]);
    FOREND;
    pup$display_line (' ALL FILES INCLUDED ', status);
  PROCEND pup$include_excluded_items;

?? TITLE := '    [XDCL] pup$include_pf_command ', EJECT ??

  PROCEDURE [XDCL] pup$include_pf_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT include_pf_pdt (
{  file, f: file = $required
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      include_pf_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^include_pf_pdt_names,
        ^include_pf_pdt_params];

    VAR
      include_pf_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['FILE', 1], ['F', 1], ['STATUS', 2]];

    VAR
      include_pf_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor :=
        [

{ FILE F }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      cycle_selector: pft$cycle_selector,
      cycle_selector_specified: boolean,
      entry: put$entry,
      p_catalog_header: ^put$catalog_header,
      p_pf_path: ^pft$path,
      pf_path_container: clt$path_container,
      set_name: stt$set_name;


    clp$scan_parameter_list (parameter_list, include_pf_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_permanent_file ('FILE', $put$cycle_reference_selections [puc$cycle_omitted, puc$specific_cycle],
          pf_path_container, p_pf_path, cycle_selector_specified, cycle_selector, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF cycle_selector_specified THEN
      pup$build_entry (p_pf_path^ [UPPERBOUND (p_pf_path^)], cycle_selector, puc$valid_cycle_entry, entry);
    ELSE { permanent file path
      pup$build_entry (p_pf_path^ [UPPERBOUND (p_pf_path^)], cycle_selector, puc$valid_pf_entry, entry);
    IFEND;

    pfp$get_family_set (p_pf_path^ [pfc$family_name_index], set_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_catalog_header: [1 .. UPPERBOUND (p_pf_path^)];
    pup$build_catalog_header (set_name, p_pf_path, p_catalog_header^);
    include_item (entry, p_catalog_header^, status);
    IF status.normal THEN
      pup$display_item_descriptor (' INCLUDE_PERMANENT_FILE ', p_catalog_header^, entry, status);
    IFEND;
  PROCEND pup$include_pf_command;

?? TITLE := '    pup$search_item_list ', EJECT ??

  PROCEDURE pup$search_item_list (entry: put$entry;
        catalog_header: put$catalog_header;
        p_root: ^put$excluded_item_entry;
    VAR item_found: boolean);

    VAR
      a_above_b: boolean,
      p_item_entry: ^put$excluded_item_entry;

    item_found := FALSE;
    p_item_entry := p_root;
    WHILE (p_item_entry <> NIL) AND (NOT item_found) DO
      pup$compare_item_descriptor (entry, catalog_header, p_item_entry^.entry, p_item_entry^.catalog_header,
            item_found, a_above_b);
      IF NOT item_found THEN
        p_item_entry := p_item_entry^.p_next_excluded_entry;
      IFEND;
    WHILEND;
  PROCEND pup$search_item_list;

?? TITLE := '    delete_all_items ', EJECT ??

  PROCEDURE delete_all_items (VAR p_root: ^put$excluded_item_entry);

    VAR
      p_next_item: ^put$excluded_item_entry;

    WHILE p_root <> NIL DO
      p_next_item := p_root^.p_next_excluded_entry;
      FREE p_root;
      p_root := p_next_item;
    WHILEND;
  PROCEND delete_all_items;

?? TITLE := '    delete_item ', EJECT ??

  PROCEDURE delete_item (entry: put$entry;
        catalog_header: put$catalog_header;
    VAR p_root: ^put$excluded_item_entry;
    VAR deleted_entry: boolean);

    VAR
      a_above_b: boolean,
      p_item_entry: ^put$excluded_item_entry,
      p_previous_entry_pointer: ^^put$excluded_item_entry;

    deleted_entry := FALSE;
    p_item_entry := p_root;
    p_previous_entry_pointer := ^p_root;
    WHILE (p_item_entry <> NIL) AND (NOT deleted_entry) DO
      pup$compare_item_descriptor (entry, catalog_header, p_item_entry^.entry, p_item_entry^.catalog_header,
            deleted_entry, a_above_b);
      IF deleted_entry THEN
        p_previous_entry_pointer^ := p_item_entry^.p_next_excluded_entry;
        FREE p_item_entry;
      ELSE
        p_previous_entry_pointer := ^p_item_entry^.p_next_excluded_entry;
        p_item_entry := p_item_entry^.p_next_excluded_entry;
      IFEND;
    WHILEND;
  PROCEND delete_item;

?? TITLE := '    exclude_item ', EJECT ??

  PROCEDURE exclude_item (entry: put$entry;
        catalog_header: put$catalog_header;
    VAR status: ost$status);

    VAR
      item_found: boolean;

    pup$search_item_list (entry, catalog_header, excluded_item_list [entry.entry_type], item_found);
    IF item_found THEN
      pup$set_abnormal_entry_status (entry, pue$item_already_excluded, status);
    ELSE
      insert_item (entry, catalog_header, excluded_item_list [entry.entry_type]);
      status.normal := TRUE;
    IFEND;
  PROCEND exclude_item;


?? TITLE := '    include_item ', EJECT ??

  PROCEDURE include_item (entry: put$entry;
        catalog_header: put$catalog_header;
    VAR status: ost$status);

    VAR
      item_found: boolean;

    status.normal := TRUE;
    delete_item (entry, catalog_header, excluded_item_list [entry.entry_type], item_found);
    IF NOT item_found THEN
      pup$set_abnormal_entry_status (entry, pue$item_never_excluded, status);
    IFEND;
  PROCEND include_item;

?? TITLE := '    insert_item ', EJECT ??

  PROCEDURE insert_item (entry: put$entry;
        catalog_header: put$catalog_header;
    VAR p_root: ^put$excluded_item_entry);

    VAR
      p_old_root: ^put$excluded_item_entry;

    p_old_root := p_root;
    ALLOCATE p_root: [1 .. UPPERBOUND (catalog_header.path)];
    p_root^.entry := entry;
    p_root^.catalog_header := catalog_header;
    p_root^.p_next_excluded_entry := p_old_root;
  PROCEND insert_item;

MODEND pum$excluded_item_management;
*DECK DECK=PUM$EXTRACT_ERRORS_FROM_LISTING EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'PUM$EXTRACT_ERRORS_FROM_LISTING' ??
MODULE pum$extract_errors_from_listing;
?? PUSH (LISTEXT := ON) ??
*copyc ost$stack_frame_save_area
*copyc pmt$condition
*copyc pmt$condition_information
?? POP ??
*copyc amp$get_next
*copyc amp$put_next
*copyc amp$put_partial
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_str_to_path_handle
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc pmp$continue_to_cause
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler

  VAR
    abort_conditions: [STATIC, READ] pmt$condition :=
          [pmc$condition_combination, [pmc$block_exit_processing, ifc$interactive_condition]];


?? TITLE := 'condition handler', EJECT ??
{ PURPOSE:
{   This procedure is a condition handler which will be executed in the event
{   of a pause break or a terminate break.

  PROCEDURE condition_handler
    (    condition: pmt$condition;
         condition_description: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR cond_status: ost$status);

    pmp$continue_to_cause (pmc$execute_standard_procedure, cond_status);
  PROCEND condition_handler;
  PROCEDURE [XDCL, #GATE] pup$extract_errors_from_listing
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (osm$extefl) extract_errors_from_listing, extefl (
{     backup_listing, bl: file = $required
{     output, o: file = $output
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 1, 18, 13, 38, 39, 697],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'OSM$EXTEFL'], [
    ['BACKUP_LISTING                 ',clc$nominal_entry, 1],
    ['BL                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$backup_listing = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      attachment_option: array [1 .. 2] of fst$attachment_option,
      backup_file_path: fst$path,
      backup_file_path_size: fst$path_size,
      backup_path_handle_name: fst$path_handle_name,
      blank_string: [STATIC] string (132) :=
            '                                ' CAT
            '                                                                ' CAT
            '                                    ',
      byte_address: amt$file_byte_address,
      established_abort_handler: pmt$established_handler,
      evaluated_file_reference: fst$evaluated_file_reference,
      file_position: amt$file_position,
      input_line: string (132),
      listing_file_identifier: amt$file_identifier,
      local_status: ost$status,
      output_file_identifier: amt$file_identifier,
      output_file_path: fst$path,
      output_file_path_size: fst$path_size,
      output_path_handle_name: fst$path_handle_name,
      tranfer_count: amt$transfer_count;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$establish_condition_handler (abort_conditions, ^condition_handler, ^established_abort_handler,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /extract_errors/
    BEGIN
      clp$convert_str_to_path_handle (pvt [p$backup_listing].value^.file_value^, {delete_allowed} TRUE,
            {resolve_path} TRUE, {include_open_pos_in_handle} TRUE, backup_path_handle_name,
            evaluated_file_reference, status);
      IF NOT status.normal THEN
        EXIT /extract_errors/;
      IFEND;

      clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} TRUE,
            backup_file_path, backup_file_path_size, status);
      IF NOT status.normal THEN
        EXIT /extract_errors/;
      IFEND;

      clp$convert_str_to_path_handle (pvt [p$output].value^.file_value^, {delete_allowed} TRUE,
            {resolve_path} TRUE, {include_open_pos_in_handle} TRUE, output_path_handle_name,
            evaluated_file_reference, status);
      IF NOT status.normal THEN
        EXIT /extract_errors/;
      IFEND;

      clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} TRUE,
            output_file_path, output_file_path_size, status);
      IF NOT status.normal THEN
        EXIT /extract_errors/;
      IFEND;

      attachment_option [1].selector := fsc$access_and_share_modes;
      attachment_option [1].access_modes.selector := fsc$specific_access_modes;
      attachment_option [1].access_modes.value := $fst$file_access_options [fsc$read];
      attachment_option [1].share_modes.selector := fsc$specific_share_modes;
      attachment_option [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
      attachment_option [2].selector := fsc$create_file;
      attachment_option [2].create_file := FALSE;

      fsp$open_file (backup_file_path, amc$record, ^attachment_option, {default_creation_attributes} NIL,
            {mandated_creation_attributes} NIL, {attribute_validation} NIL, {attribute_override} NIL,
            listing_file_identifier, status);
      IF NOT status.normal THEN
        EXIT /extract_errors/;
      IFEND;

      fsp$open_file (output_file_path, amc$record, {file_attachment} NIL, {default_creation_attributes} NIL,
            {mandated_creation_attributes} NIL, {attribute_validation} NIL, {attribute_override} NIL,
            output_file_identifier, status);
      IF NOT status.normal THEN
        EXIT /extract_errors/;
      IFEND;

      input_line := blank_string;
      amp$get_next (listing_file_identifier, ^input_line, #SIZE (input_line), tranfer_count, byte_address,
            file_position, status);
      IF NOT status.normal THEN
        EXIT /extract_errors/;
      IFEND;

      WHILE file_position <> amc$eoi DO
        IF input_line (3, 7) = '--ERROR' THEN
          amp$put_partial (output_file_identifier, ^input_line, tranfer_count, byte_address, amc$start,
                status);
          IF NOT status.normal THEN
            EXIT /extract_errors/;
          IFEND;

          input_line := blank_string;
          amp$get_next (listing_file_identifier, ^input_line, #SIZE (input_line), tranfer_count,
                byte_address, file_position, status);
          IF NOT status.normal THEN
            EXIT /extract_errors/;
          IFEND;

          WHILE input_line (3) <> ' ' DO
            input_line := input_line(2, (#SIZE (input_line) - 1));
            amp$put_partial (output_file_identifier, ^input_line, tranfer_count - 1, byte_address,
                  amc$continue, status);
            IF NOT status.normal THEN
              EXIT /extract_errors/;
            IFEND;

            input_line := blank_string;
            amp$get_next (listing_file_identifier, ^input_line, #SIZE (input_line), tranfer_count,
                  byte_address, file_position, status);
            IF NOT status.normal THEN
              EXIT /extract_errors/;
            IFEND;
          WHILEND;
          amp$put_partial (output_file_identifier, NIL, 0, byte_address, amc$terminate, status);
          IF NOT status.normal THEN
            EXIT /extract_errors/;
          IFEND;

          input_line := blank_string;
          amp$put_next (output_file_identifier, ^input_line, tranfer_count, byte_address, status);
          IF NOT status.normal THEN
            EXIT /extract_errors/;
          IFEND;
        IFEND;

        input_line := blank_string;
        amp$get_next (listing_file_identifier, ^input_line, #SIZE (input_line), tranfer_count, byte_address,
              file_position, status);
        IF NOT status.normal THEN
          EXIT /extract_errors/;
        IFEND;
      WHILEND;
    END /extract_errors/;

    fsp$close_file (listing_file_identifier, local_status);
    IF status.normal THEN
      status := local_status;
    IFEND;
    fsp$close_file (output_file_identifier, local_status);
    IF status.normal THEN
      status := local_status;
    IFEND;

    pmp$disestablish_cond_handler (abort_conditions, local_status);
    IF status.normal THEN
      status := local_status;
    IFEND;
  PROCEND pup$extract_errors_from_listing;

MODEND pum$extract_errors_from_listing;
*DECK DECK=PUM$INCLUDE_CYCLES EXPAND=TRUE
*copyc osd$default_pragmats
?? RIGHT := 110 ??
??
NEWTITLE := ' NOS/VE Backup/Restore Utilities:  include_cycles ', EJECT ??
MODULE pum$include_cycles;

?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
*copyc cle$ecc_parsing
*copyc clp$evaluate_parameters
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc osp$append_status_integer
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc pfd$catalog_info
*copyc pmp$compute_date_time
*copyc pmp$date_time_compare
*copyc pmp$get_compact_date_time
*copyc pud$hierarchy_list
*copyc pud$selection_criteria
*copyc pue$error_condition_codes
*copyc pup$crack_boolean
*copyc pup$crack_date_time
*copyc pup$display_integer
*copyc pup$display_line
*copyc pup$format_date_time
*copyc pus$literals
*copyc puv$exclude_site_backup_options
?? POP ??
?? TITLE := '    Global Variables', EJECT ??

  VAR
    puv$maximum_cycle_size: [XDCL, STATIC] amt$file_length := amc$file_byte_limit,
    puv$minimum_cycle_size: [XDCL, STATIC] amt$file_length := 0;

  VAR
    before_default_increment: [pus$literals, READ] pmt$time_increment := [0, 0, 1, 0, 0, 0, 0] {1 day} ,
    selection_criteria_name_table: [STATIC, READ, pus$literals] array [put$selection_criteria_mode] of string
      (9) := ['CREATED', 'ACCESSED', 'MODIFIED', 'EXPIRED'];

  VAR
    puv$backup_criteria: [XDCL] put$selection_criteria := [ *, FALSE, *, FALSE, *, * ];

?? TITLE := '    [XDCL] pup$backup_include_cycles ', EJECT ??

  PROCEDURE [XDCL] pup$backup_include_cycles (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE (osm$bacpf_incc) include_cycles, include_cycle, incc (
{   selection_criteria, sc:
{     key
{       (created, c)
{       (accessed, a)
{       (modified, m)
{       (expired, e)
{       (ignore_date_time, idt)
{     keyend = $required
{   after, a: date_time = 1980-01-01.00:00:00.000
{   before, b: date_time = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 10] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$date_time_type_qualifier,
        default_value: string (23),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$date_time_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 12, 11, 13, 18, 59, 393],
    clc$command, 7, 4, 1, 0, 0, 0, 4, 'OSM$BACPF_INCC'], [
    ['A                              ',clc$abbreviation_entry, 2],
    ['AFTER                          ',clc$nominal_entry, 2],
    ['B                              ',clc$abbreviation_entry, 3],
    ['BEFORE                         ',clc$nominal_entry, 3],
    ['SC                             ',clc$abbreviation_entry, 1],
    ['SELECTION_CRITERIA             ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 377,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 23],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [10], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['ACCESSED                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CREATED                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['EXPIRED                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['IDT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['IGNORE_DATE_TIME               ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['MODIFIED                       ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 2
    [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [clc$past
  , clc$present, clc$future]],
    '1980-01-01.00:00:00.000'],
{ PARAMETER 3
    [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [clc$past
  , clc$present, clc$future]]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$selection_criteria = 1,
      p$after = 2,
      p$before = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      all_selected: boolean,
      comparison_result: pmt$comparison_result,
      current_date_time: ost$date_time,
      date_time_string: string (25),
      ignore_status: ost$status,
      input_date_time_after: ost$date_time,
      input_date_time_before: ost$date_time,
      input_selection_mode: put$selection_criteria_mode,
      output_line: string (80),
      output_line_index: integer;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    input_date_time_after := pvt [p$after].value^.date_time_value.value;
    IF NOT pvt [p$after].value^.date_time_value.date_specified THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$date_part_omitted,
            'AFTER', status);
      RETURN;
    IFEND;

    IF NOT pvt [p$after].value^.date_time_value.time_specified THEN
      input_date_time_after.hour := 0;
      input_date_time_after.minute := 0;
      input_date_time_after.second := 0;
      input_date_time_after.millisecond := 0;
    IFEND;

    IF pvt [p$before].specified THEN
      input_date_time_before := pvt [p$before].value^.date_time_value.value;
      IF NOT pvt [p$before].value^.date_time_value.date_specified THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$date_part_omitted, 'BEFORE', status);
        RETURN;
      IFEND;
      IF NOT pvt [p$before].value^.date_time_value.time_specified THEN
        input_date_time_before.hour := 0;
        input_date_time_before.minute := 0;
        input_date_time_before.second := 0;
        input_date_time_before.millisecond := 0;
      IFEND;
    ELSE
      pmp$get_compact_date_time (current_date_time, status);
      IF status.normal THEN
        pmp$compute_date_time (current_date_time, before_default_increment, input_date_time_before, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    puv$backup_criteria.after_date_time_selected := FALSE;
    puv$backup_criteria.before_date_time_selected := FALSE;
    IF (pvt [p$selection_criteria].value^.keyword_value = 'IGNORE_DATE_TIME') THEN
      pup$display_line (' INCLUDE CYCLES IGNORE_DATE_TIME', status);
    ELSE
      IF input_date_time_after = input_date_time_before THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$before_after_time_equal, '', status);
      ELSE
      /find_selection_criteria_name/
        FOR input_selection_mode := puc$created TO puc$expired DO
          IF selection_criteria_name_table [input_selection_mode] =
                pvt [p$selection_criteria].value^.keyword_value THEN
            EXIT /find_selection_criteria_name/;
          IFEND;
        FOREND /find_selection_criteria_name/;
        { CL will detect the case of an illegal selection criteria mode

        puv$backup_criteria.mode := input_selection_mode;
        output_line := ' INCLUDE CYCLES ';
        output_line (17, * ) := selection_criteria_name_table [input_selection_mode];
        pup$display_line (output_line, status);
        puv$backup_criteria.after_date_time_selected := TRUE;
        puv$backup_criteria.after_date_time := input_date_time_after;
        pup$format_date_time (input_date_time_after, date_time_string);
        output_line := '  AFTER  ';
        output_line (10, * ) := date_time_string;
        pup$display_line (output_line, status);
        puv$backup_criteria.before_date_time_selected := TRUE;
        puv$backup_criteria.before_date_time := input_date_time_before;
        pup$format_date_time (input_date_time_before, date_time_string);
        output_line := '  BEFORE ';
        output_line (10, * ) := date_time_string;
        pup$display_line (output_line, status);
        pmp$date_time_compare (puv$backup_criteria.after_date_time, puv$backup_criteria.before_date_time,
              comparison_result, ignore_status);
        puv$backup_criteria.after_time_after_before_time := (comparison_result = pmc$left_is_greater);
      IFEND;
    IFEND;
  PROCEND pup$backup_include_cycles;

?? TITLE := '    [XDCL] pup$check_cycle_access ', EJECT ??

  PROCEDURE [XDCL] pup$check_cycle_access
        (cycle_array_entry: pft$cycle_array_entry_version_2;
    VAR cycle_included: boolean);

    VAR
      before_time_after_cycle_time: boolean,
      comparison_result: pmt$comparison_result,
      cycle_date_time: ost$date_time,
      cycle_time_after_after_time: boolean,
      ignore_status: ost$status;

    IF (NOT puv$backup_criteria.after_date_time_selected) AND
          (NOT puv$backup_criteria.before_date_time_selected) THEN
      cycle_included := TRUE;
    ELSE
      select_cycle_date_time (cycle_array_entry, puv$backup_criteria.mode, cycle_date_time);
      IF puv$backup_criteria.after_date_time_selected THEN
        pmp$date_time_compare (cycle_date_time, puv$backup_criteria.after_date_time, comparison_result,
              ignore_status);
        cycle_time_after_after_time := (comparison_result = pmc$left_is_greater);
      IFEND;
      IF puv$backup_criteria.before_date_time_selected THEN
        pmp$date_time_compare (puv$backup_criteria.before_date_time, cycle_date_time, comparison_result,
              ignore_status);
        before_time_after_cycle_time := (comparison_result = pmc$left_is_greater);
      IFEND;
      IF puv$backup_criteria.after_date_time_selected AND puv$backup_criteria.before_date_time_selected THEN
        IF puv$backup_criteria.after_time_after_before_time THEN
          cycle_included := cycle_time_after_after_time OR before_time_after_cycle_time;
        ELSE
          cycle_included := cycle_time_after_after_time AND before_time_after_cycle_time;
        IFEND;
      ELSEIF puv$backup_criteria.after_date_time_selected THEN
        cycle_included := cycle_time_after_after_time;
      ELSE
        cycle_included := before_time_after_cycle_time;
      IFEND;
    IFEND;

    IF cycle_array_entry.sparse_allocation OR ((cycle_array_entry.device_class <> rmc$magnetic_tape_device)
          AND (cycle_array_entry.device_class <> rmc$mass_storage_device)) THEN
      cycle_included := FALSE;
    IFEND;

  PROCEND pup$check_cycle_access;

?? TITLE := '    [XDCL] pup$check_if_size_included ', EJECT ??

  PROCEDURE [XDCL] pup$check_if_size_included (cycle_size: amt$file_length;
    VAR cycle_included: boolean);

    cycle_included := (cycle_size >= puv$minimum_cycle_size) AND (cycle_size <= puv$maximum_cycle_size);

  PROCEND pup$check_if_size_included;

?? TITLE := '    [XDCL] pup$check_site_backup_options ', EJECT ??

  PROCEDURE [XDCL] pup$check_site_backup_options
        (cycle_array_entry: pft$cycle_array_entry_version_2;
    VAR cycle_included: boolean);

    cycle_included :=
          NOT (cycle_array_entry.site_backup_option IN puv$exclude_site_backup_options);

  PROCEND pup$check_site_backup_options;

?? TITLE := '    [XDCL] pup$dis_included_cycles_cm ', EJECT ??

  PROCEDURE [XDCL] pup$dis_included_cycles_cm (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{  PDT dis_included_cycles_pdt (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      dis_included_cycles_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^dis_included_cycles_pdt_names, ^dis_included_cycles_pdt_params];

    VAR
      dis_included_cycles_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
        clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      dis_included_cycles_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
        clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    clp$scan_parameter_list (parameter_list, dis_included_cycles_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$display_included_cycles;
  PROCEND pup$dis_included_cycles_cm;

?? TITLE := '    [XDCL] pup$display_included_cycles ', EJECT ??

  PROCEDURE [XDCL] pup$display_included_cycles;

    VAR
      date_time_string: string (25),
      status: ost$status;

    IF (NOT puv$backup_criteria.after_date_time_selected) AND
          (NOT puv$backup_criteria.before_date_time_selected) THEN
      pup$display_line (' ALL CYCLES SELECTED', status);
    ELSEIF puv$backup_criteria.after_date_time_selected AND
          puv$backup_criteria.before_date_time_selected THEN
      IF puv$backup_criteria.after_time_after_before_time THEN
        pup$display_line (' cycles NOT ', status);
        pup$display_line (selection_criteria_name_table [puv$backup_criteria.mode], status);
        pup$display_line (' within the following window will be backed up', status);
      ELSE
        pup$display_line (' cycles ', status);
        pup$display_line (selection_criteria_name_table [puv$backup_criteria.mode], status);
        pup$display_line (' within the following window will be backed up', status);
      IFEND;
      pup$display_line (' before date time', status);
      pup$format_date_time (puv$backup_criteria.before_date_time, date_time_string);
      pup$display_line (date_time_string, status);
      pup$display_line (' after date time', status);
      pup$format_date_time (puv$backup_criteria.after_date_time, date_time_string);
      pup$display_line (date_time_string, status);
    ELSEIF puv$backup_criteria.after_date_time_selected THEN
      pup$display_line (' cycles ', status);
      pup$display_line (selection_criteria_name_table [puv$backup_criteria.mode], status);
      pup$display_line (' after the following date will be backed up', status);
      pup$format_date_time (puv$backup_criteria.after_date_time, date_time_string);
      pup$display_line (date_time_string, status);
    ELSE {puv$backup_criteria.before_date_time_selected}
      pup$display_line (' cycles', status);
      pup$display_line (selection_criteria_name_table [puv$backup_criteria.mode], status);
      pup$display_line (' before the follwing date will be backed up', status);
      pup$format_date_time (puv$backup_criteria.before_date_time, date_time_string);
      pup$display_line (date_time_string, status);
    IFEND;
    pup$display_integer (' Minimum_cycle_size: ', puv$minimum_cycle_size, status);
    pup$display_integer (' Maximum_cycle_size: ', puv$maximum_cycle_size, status);
  PROCEND pup$display_included_cycles;


?? TITLE := '    [XDCL] pup$include_large_cycles_cmd ', EJECT ??

  PROCEDURE [XDCL] pup$include_large_cycles_cmd (parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? RIGHT := 110 ??
{ PDT include_large_cycles_pdt (minimum_size, ms: integer 0 .. amc$file_byte_limit = $required
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      include_large_cycles_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^include_large_cycles_pdt_names, ^include_large_cycles_pdt_params];

    VAR
      include_large_cycles_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['MINIMUM_SIZE', 1], ['MS', 1], ['STATUS', 2]];

    VAR
      include_large_cycles_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
        clt$parameter_descriptor := [

{ MINIMUM_SIZE MS }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0,
        amc$file_byte_limit]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      value: clt$value;

    clp$scan_parameter_list (parameter_list, include_large_cycles_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('MINIMUM_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF puv$maximum_cycle_size < value.int.value THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$entered_size_above_maximum, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, value.int.value, value.int.radix,
            value.int.radix_specified, status);
      osp$append_status_integer (osc$status_parameter_delimiter, puv$maximum_cycle_size,
            value.int.radix, value.int.radix_specified, status);
    ELSE
      puv$minimum_cycle_size := value.int.value;
      pup$display_integer (' INCLUDING CYCLES OF LENGTH AT LEAST: ', puv$minimum_cycle_size, status);
    IFEND;

  PROCEND pup$include_large_cycles_cmd;

?? TITLE := '    [XDCL] pup$include_small_cycles_cmd ', EJECT ??

  PROCEDURE [XDCL] pup$include_small_cycles_cmd (parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? RIGHT := 110 ??

{ pdt include_small_cycles_pdt (
{   maximum_size, ms: integer 0 .. amc$file_byte_limit OR ..
{                       KEY maximum = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    include_small_cycles_pdt: [STATIC, READ, cls$pdt]
      clt$parameter_descriptor_table := [^include_small_cycles_pdt_names,
      ^include_small_cycles_pdt_params];

  VAR
    include_small_cycles_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults]
      array [1 .. 3] of clt$parameter_name_descriptor := [['MAXIMUM_SIZE', 1],
      ['MS', 1], ['STATUS', 2]];

  VAR
    include_small_cycles_pdt_params: [STATIC, READ, cls$pdt_parameters] array [
      1 .. 2] of clt$parameter_descriptor := [

{ MAXIMUM_SIZE MS }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^
      include_small_cycles_pdt_kv1, clc$integer_value, 0, amc$file_byte_limit
      ]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

  VAR
    include_small_cycles_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults]
      array [1 .. 1] of ost$name := ['MAXIMUM'];

?? POP ??

    VAR
      value: clt$value;

    clp$scan_parameter_list (parameter_list, include_small_cycles_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('MAXIMUM_SIZE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF puv$minimum_cycle_size > value.int.value THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$entered_size_below_minimum, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, value.int.value, value.int.radix,
            value.int.radix_specified, status);
      osp$append_status_integer (osc$status_parameter_delimiter, puv$minimum_cycle_size,
            value.int.radix, value.int.radix_specified, status);
    ELSE
      puv$maximum_cycle_size := value.int.value;
      pup$display_integer (' INCLUDING CYCLES OF LENGTH AT MOST: ', puv$maximum_cycle_size, status);
    IFEND;

  PROCEND pup$include_small_cycles_cmd;

?? TITLE := '    [XDCL] pup$restore_include_cycles ', EJECT ??

  PROCEDURE [XDCL] pup$restore_include_cycles (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE (osm$respf_incc) include_cycles, include_cycle, incc (
{   selection_criteria, sc:
{     key
{       (created, c)
{       (accessed, a)
{       (modified, m)
{       (expired, e)
{       (ignore_date_time, idt)
{     keyend = $required
{   after, a: date_time = 1980-01-01.00:00:00.000
{   before, b: date_time = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 10] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$date_time_type_qualifier,
        default_value: string (23),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$date_time_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 12, 11, 13, 19, 9, 773],
    clc$command, 7, 4, 1, 0, 0, 0, 4, 'OSM$RESPF_INCC'], [
    ['A                              ',clc$abbreviation_entry, 2],
    ['AFTER                          ',clc$nominal_entry, 2],
    ['B                              ',clc$abbreviation_entry, 3],
    ['BEFORE                         ',clc$nominal_entry, 3],
    ['SC                             ',clc$abbreviation_entry, 1],
    ['SELECTION_CRITERIA             ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 377,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$optional_default_parameter, 0, 23],
{ PARAMETER 3
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [10], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['ACCESSED                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['C                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['CREATED                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['EXPIRED                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['IDT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
    ['IGNORE_DATE_TIME               ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['MODIFIED                       ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 2
    [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [clc$past
  , clc$present, clc$future]],
    '1980-01-01.00:00:00.000'],
{ PARAMETER 3
    [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [clc$past
  , clc$present, clc$future]]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$selection_criteria = 1,
      p$after = 2,
      p$before = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      all_selected: boolean,
      comparison_result: pmt$comparison_result,
      current_date_time: ost$date_time,
      date_time_string: string (25),
      ignore_status: ost$status,
      input_date_time_after: ost$date_time,
      input_date_time_before: ost$date_time,
      input_selection_mode: put$selection_criteria_mode,
      output_line: string (80),
      output_line_index: integer;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    input_date_time_after := pvt [p$after].value^.date_time_value.value;
    IF NOT pvt [p$after].value^.date_time_value.date_specified THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$date_part_omitted,
            'AFTER', status);
      RETURN;
    IFEND;
    IF NOT pvt [p$after].value^.date_time_value.time_specified THEN
      input_date_time_after.hour := 0;
      input_date_time_after.minute := 0;
      input_date_time_after.second := 0;
      input_date_time_after.millisecond := 0;
    IFEND;

    IF pvt [p$before].specified THEN
      input_date_time_before := pvt [p$before].value^.date_time_value.value;
      IF NOT pvt [p$before].value^.date_time_value.date_specified THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$date_part_omitted, 'BEFORE', status);
        RETURN;
      IFEND;
      IF NOT pvt [p$before].value^.date_time_value.time_specified THEN
        input_date_time_before.hour := 0;
        input_date_time_before.minute := 0;
        input_date_time_before.second := 0;
        input_date_time_before.millisecond := 0;
      IFEND;
    ELSE
      pmp$get_compact_date_time (current_date_time, status);
      IF status.normal THEN
        pmp$compute_date_time (current_date_time, before_default_increment, input_date_time_before, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    puv$backup_criteria.after_date_time_selected := FALSE;
    puv$backup_criteria.before_date_time_selected := FALSE;
    IF (pvt [p$selection_criteria].value^.keyword_value = 'IGNORE_DATE_TIME') THEN
      pup$display_line (' INCLUDE CYCLES IGNORE_DATE_TIME', status);
    ELSE
      IF input_date_time_after = input_date_time_before THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$before_after_time_equal, '', status);
      ELSE
      /find_selection_criteria_name/
        FOR input_selection_mode := puc$created TO puc$expired DO
          IF selection_criteria_name_table [input_selection_mode] =
                pvt [p$selection_criteria].value^.keyword_value THEN
            EXIT /find_selection_criteria_name/;
          IFEND;
        FOREND /find_selection_criteria_name/;
        { CL will detect the case of an illegal selection criteria mode

        puv$backup_criteria.mode := input_selection_mode;
        output_line := ' INCLUDE CYCLES ';
        output_line (17, * ) := selection_criteria_name_table [input_selection_mode];
        pup$display_line (output_line, status);
        puv$backup_criteria.after_date_time_selected := TRUE;
        puv$backup_criteria.after_date_time := input_date_time_after;
        pup$format_date_time (input_date_time_after, date_time_string);
        output_line := '  AFTER  ';
        output_line (10, * ) := date_time_string;
        pup$display_line (output_line, status);
        puv$backup_criteria.before_date_time_selected := TRUE;
        puv$backup_criteria.before_date_time := input_date_time_before;
        pup$format_date_time (input_date_time_before, date_time_string);
        output_line := '  BEFORE ';
        output_line (10, * ) := date_time_string;
        pup$display_line (output_line, status);
        pmp$date_time_compare (puv$backup_criteria.after_date_time, puv$backup_criteria.before_date_time,
              comparison_result, ignore_status);
        puv$backup_criteria.after_time_after_before_time := (comparison_result = pmc$left_is_greater);
      IFEND;
    IFEND;
  PROCEND pup$restore_include_cycles;

?? TITLE := '    select_cycle_date_time ', EJECT ??

  PROCEDURE select_cycle_date_time
   (    cycle_array_entry: pft$cycle_array_entry_version_2;
        selection_criteria_mode: put$selection_criteria_mode;
    VAR cycle_date_time: ost$date_time);

    CASE selection_criteria_mode OF
    = puc$created =
      cycle_date_time := cycle_array_entry.cycle_statistics.creation_date_time;
    = puc$accessed =
      cycle_date_time := cycle_array_entry.cycle_statistics.access_date_time;
    = puc$modified =
      cycle_date_time := cycle_array_entry.cycle_statistics.modification_date_time;
    = puc$expired =
      cycle_date_time := cycle_array_entry.expiration_date_time;
    CASEND;
  PROCEND select_cycle_date_time;

MODEND pum$include_cycles;
*DECK DECK=PUM$INCLUDE_VOLUMES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  include_volumes ', EJECT ??
MODULE pum$include_volumes;

?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_miscellaneous
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc clv$non_alphanumeric
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc pft$volume_list
*copyc pue$error_condition_codes
*copyc pup$display_line
*copyc put$include_volumes_option
*copyc puv$include_data_options
*copyc rmd$volume_declarations
*copyc stp$get_pf_volumes
?? POP ??
?? TITLE := '    Global Variables', EJECT ??

  VAR
    puv$include_volumes_option: [XDCL, STATIC] put$include_volumes_option := puc$multiple_volumes,
    puv$p_included_volumes: [XDCL, STATIC] ^array [1 .. * ] of rmt$recorded_vsn := NIL;

?? TITLE := '    [XDCL] pup$all_volumes_included ', EJECT ??

  FUNCTION [XDCL] pup$all_volumes_included: boolean;

    pup$all_volumes_included := (puv$p_included_volumes = NIL);
  FUNCEND pup$all_volumes_included;

?? TITLE := '    [XDCL] pup$check_if_volume_included ', EJECT ??

  PROCEDURE [XDCL] pup$check_if_volume_included
    (    p_volume_list: ^pft$volume_list;
     VAR volume_included: boolean);

    VAR
      file_volume: integer,
      included_volume: integer;

    IF puv$p_included_volumes = NIL THEN
      volume_included := TRUE;
    ELSEIF p_volume_list = NIL THEN
      volume_included := FALSE;
    ELSE
      volume_included := FALSE;

      IF puv$include_volumes_option = puc$initial_volume THEN

      /search_for_volume_one/
        FOR included_volume := 1 TO UPPERBOUND (puv$p_included_volumes^) DO
          IF p_volume_list^ [1] = puv$p_included_volumes^ [included_volume] THEN
            volume_included := TRUE;
            EXIT /search_for_volume_one/;
          IFEND;
        FOREND /search_for_volume_one/;

       ELSE { multiple volumes

       /search_included_volumes/
         FOR included_volume := 1 TO UPPERBOUND (puv$p_included_volumes^) DO
            FOR file_volume := 1 to UPPERBOUND(p_volume_list^) DO
              IF p_volume_list^ [file_volume] = puv$p_included_volumes^ [included_volume] THEN
                volume_included := TRUE;
                EXIT /search_included_volumes/;
              IFEND;
            FOREND;
         FOREND;
      IFEND;
    IFEND;
  PROCEND pup$check_if_volume_included;

?? TITLE := '    [XDCL] pup$display_included_volumes ', EJECT ??

  PROCEDURE [XDCL] pup$display_included_volumes (parameter_list: clt$parameter_list;
    VAR status: ost$status);
{ PDT display_volumes_pdt (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_volumes_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^display_volumes_pdt_names, ^display_volumes_pdt_params];

    VAR
      display_volumes_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
        clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      display_volumes_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
        clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    clp$scan_parameter_list (parameter_list, display_volumes_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_included_volumes ({display_cycle_selection =} TRUE, status);
  PROCEND pup$display_included_volumes;

?? TITLE := '    [XDCL] pup$display_volumes_command ', EJECT ??

  PROCEDURE [XDCL] pup$display_volumes_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? RIGHT := 110 ??
{ PDT display_volumes_pdt (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_volumes_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^display_volumes_pdt_names, ^display_volumes_pdt_params];

    VAR
      display_volumes_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
        clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      display_volumes_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
        clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      current_pf_guess: integer,
      i: integer,
      number_of_volumes: integer,
      p_volume_list: ^pft$volume_list;

    clp$scan_parameter_list (parameter_list, display_volumes_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    number_of_volumes := 2;
    REPEAT
      current_pf_guess := number_of_volumes;
      PUSH p_volume_list: [1 .. current_pf_guess];
      stp$get_pf_volumes (p_volume_list^, number_of_volumes, status);
    UNTIL (NOT status.normal) OR (current_pf_guess >= number_of_volumes);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO number_of_volumes DO
      pup$display_line (p_volume_list^ [i], status);
    FOREND;
  PROCEND pup$display_volumes_command;


?? TITLE := '    pup$backup_include_volumes_cmd ', EJECT ??

  PROCEDURE [XDCL] pup$backup_include_volumes_cmd (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT backup_include_vol_pdt (
{   recorded_vsns, recorded_vsn, rvsn: list of name 1 .. 6 or key all = $required
{   cycle_selection, cs: key initial_volume, iv, multiple_volumes, mv = multiple_volumes
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    backup_include_vol_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^backup_include_vol_pdt_names, ^backup_include_vol_pdt_params];

  VAR
    backup_include_vol_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
      clt$parameter_name_descriptor := [['RECORDED_VSNS', 1], ['RECORDED_VSN', 1], ['RVSN', 1], [
      'CYCLE_SELECTION', 2], ['CS', 2], ['STATUS', 3]];

  VAR
    backup_include_vol_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
      clt$parameter_descriptor := [

{ RECORDED_VSNS RECORDED_VSN RVSN }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [^backup_include_vol_pdt_kv1,
      clc$name_value, 1, 6]],

{ CYCLE_SELECTION CS }
    [[clc$optional_with_default, ^backup_include_vol_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [^
      backup_include_vol_pdt_kv2, clc$keyword_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    backup_include_vol_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := [
      'ALL'];

  VAR
    backup_include_vol_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := [
      'INITIAL_VOLUME','IV','MULTIPLE_VOLUMES','MV'];

  VAR
    backup_include_vol_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (16) := 'multiple_volumes';

?? POP ??

    VAR
      number_of_volumes: 0 .. clc$max_value_sets,
      p_volume_list: ^pft$volume_list,
      temp_include_volumes_option: put$include_volumes_option;

    clp$scan_parameter_list (parameter_list, backup_include_vol_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('RECORDED_VSNS', number_of_volumes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_volume_list: [1..number_of_volumes];
    crack_recorded_vsn (p_volume_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_cycle_selection (temp_include_volumes_option, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF p_volume_list <> NIL THEN
      IF puc$include_offline_data IN puv$include_data_options THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$incv_and_offline_conflict, '', status);
        RETURN;
      IFEND;
    IFEND;

    IF puv$p_included_volumes <> NIL THEN
      FREE puv$p_included_volumes;
    IFEND;

    IF p_volume_list = NIL THEN
      { include all volumes
      puv$p_included_volumes := NIL;
    ELSE
      ALLOCATE puv$p_included_volumes: [1 .. UPPERBOUND (p_volume_list^)];
      puv$p_included_volumes^ := p_volume_list^;
    IFEND;
    puv$include_volumes_option := temp_include_volumes_option;
    display_included_volumes ({display_cycle_selection =} TRUE, status);
  PROCEND pup$backup_include_volumes_cmd;

?? TITLE := '    pup$restore_include_volumes_cmd ', EJECT ??

  PROCEDURE [XDCL] pup$restore_include_volumes_cmd (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT restore_include_vol_pdt (
{   recorded_vsns, recorded_vsn, rvsn: list of name 1 .. 6 or key all = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    restore_include_vol_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^restore_include_vol_pdt_names, ^restore_include_vol_pdt_params];

  VAR
    restore_include_vol_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
      clt$parameter_name_descriptor := [['RECORDED_VSNS', 1], ['RECORDED_VSN', 1], ['RVSN', 1], ['STATUS', 2]
      ];

  VAR
    restore_include_vol_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
      clt$parameter_descriptor := [

{ RECORDED_VSNS RECORDED_VSN RVSN }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [^restore_include_vol_pdt_kv1,
      clc$name_value, 1, 6]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    restore_include_vol_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := [
      'ALL'];

?? POP ??

    VAR
      number_of_volumes: 0 .. clc$max_value_sets,
      p_volume_list: ^pft$volume_list;

    clp$scan_parameter_list (parameter_list, restore_include_vol_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('RECORDED_VSNS', number_of_volumes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_volume_list: [1..number_of_volumes];
    crack_recorded_vsn (p_volume_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF puv$p_included_volumes <> NIL THEN
      FREE puv$p_included_volumes;
    IFEND;

    IF p_volume_list = NIL THEN
      { Include all volumes.
      puv$p_included_volumes := NIL;
    ELSE
      ALLOCATE puv$p_included_volumes: [1 .. UPPERBOUND (p_volume_list^)];
      puv$p_included_volumes^ := p_volume_list^;
    IFEND;

    display_included_volumes ({display_cycle_selection =} FALSE, status);

  PROCEND pup$restore_include_volumes_cmd;
?? TITLE := '    [XDCL] pup$verify_volume_list ', EJECT ??

  PROCEDURE [XDCL] pup$verify_volume_list (volume_list: array [1 .. * ] OF rmt$recorded_vsn;
    VAR status: ost$status);

{ This verifies that all volumes in the volume_list are active in the system

    VAR
      current_pf_guess: integer,
      i: integer,
      j: integer,
      number_of_volumes: integer,
      p_pf_volume_list: ^array [1 .. * ] of rmt$recorded_vsn,
      volume_found: boolean;

    {Get active volumes
    number_of_volumes := 2;
    REPEAT
      current_pf_guess := number_of_volumes;
      PUSH p_pf_volume_list: [1 .. current_pf_guess];
      stp$get_pf_volumes (p_pf_volume_list^, number_of_volumes, status);
    UNTIL (NOT status.normal) OR (current_pf_guess >= number_of_volumes);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO UPPERBOUND (volume_list) DO
      volume_found := FALSE;
      { search the active pf volume list for this volume

    /check_if_volume_active/
      FOR j := 1 TO number_of_volumes DO
        IF volume_list [i] = p_pf_volume_list^ [j] THEN
          volume_found := TRUE;
          EXIT /check_if_volume_active/;
        IFEND;
      FOREND /check_if_volume_active/;
      IF NOT volume_found THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$volume_not_active, volume_list [i], status);
        RETURN;
      IFEND;
    FOREND;
  PROCEND pup$verify_volume_list;

?? TITLE := '    crack_recorded_vsn ', EJECT ??

  PROCEDURE crack_recorded_vsn (
    VAR p_volume_list: ^pft$volume_list;
    VAR status: ost$status);

    VAR
      i: integer,
      value: clt$value;

    FOR i := 1 TO UPPERBOUND(p_volume_list^) DO
      clp$get_value ('RECORDED_VSNS', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.name.value = 'ALL' THEN
        IF i = 1 THEN
          p_volume_list := NIL;
        ELSE
          osp$set_status_abnormal (puc$pf_utility_id, cle$all_must_be_used_alone, 'RECORDED_VSNS', status);
        IFEND;
        RETURN;
      IFEND;
      p_volume_list^ [i] := value.name.value;
    FOREND;

  PROCEND crack_recorded_vsn;

?? TITLE := '    crack_cycle_selection ', EJECT ??

  PROCEDURE crack_cycle_selection (
    VAR include_volumes_option: put$include_volumes_option;
    VAR status: ost$status);

    VAR
      value: clt$value;

    clp$get_value ('CYCLE_SELECTION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
       RETURN;
    IFEND;
    IF value.name.value (1) = 'I' THEN
      include_volumes_option := puc$initial_volume;
    ELSE
      include_volumes_option := puc$multiple_volumes;
    IFEND;
  PROCEND crack_cycle_selection;

?? TITLE := '    display_included_volumes ', EJECT ??

  PROCEDURE display_included_volumes (
         display_cycle_selection: boolean;
     VAR status: ost$status);

    VAR
      i: integer;

    IF puv$p_included_volumes = NIL THEN
      pup$display_line (' INCLUDE_VOLUMES ALL ', status);
    ELSE
      pup$display_line (' INCLUDE_VOLUMES: ', status);
      FOR i := 1 TO UPPERBOUND (puv$p_included_volumes^) DO
        pup$display_line (puv$p_included_volumes^ [i], status);
      FOREND;
      IF display_cycle_selection THEN
      IF puv$include_volumes_option = puc$initial_volume THEN
          pup$display_line (' CYCLE_SELECTION=INITIAL_VOLUME', status);
        ELSE
          pup$display_line (' CYCLE_SELECTION=MULTIPLE_VOLUME', status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND display_included_volumes;

MODEND pum$include_volumes;
*DECK DECK=PUM$LISTING_OUTPUT EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  listing_output ', EJECT ??
MODULE pum$listing_output;
{
{ This handles all output to the listing files on backup and restore.
{ This also includes the SET_LIST_OPTIONS subcommand processing.
{
?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
*copyc amp$fetch_access_information
*copyc amt$backup_information
*copyc amt$local_file_name
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$open_display
*copyc clp$put_display
*copyc clp$scan_parameter_list
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$format_message
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pfe$external_archive_conditions
*copyc pfp$find_archive_info
*copyc pfp$find_next_archive_entry
*copyc pmp$convert_binary_unique_name
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pmp$get_compact_date_time
*copyc pmp$get_mainframe_id
*copyc pud$hierarchy_list
*copyc pue$error_condition_codes
*copyc pup$compare_cycle_selectors
*copyc pup$compare_paths
*copyc pup$crack_boolean
*copyc pup$crack_name_list
*copyc pup$determine_if_all_selected
*copyc pup$determine_if_none_selected
*copyc pup$fetch_current_volume
*copyc pup$find_cycle_info_record
*copyc pup$initialize_restore_totals
*copyc pus$literals
*copyc put$file_identifier
*copyc puv$include_archive_information
*copyc puv$restore_archive_information
*copyc puv$include_data_options
*copyc std$set_name
?? POP ??
?? TITLE := '    Global Variables', EJECT ??

  VAR
    puv$display_excluded_items: [STATIC, XDCL] boolean := FALSE,
    puv$listing_display_control: [STATIC, XDCL] clt$display_control;

  VAR
    backup_restore_names_equal: [STATIC] boolean := TRUE,
    error_count: [STATIC] integer := 0,
    last_error_status: [STATIC] ost$status := [TRUE],
    listing_file_lfn: [STATIC] amt$local_file_name,
    number_of_opens: [STATIC] integer := 0;

  TYPE
    label_types = amc$labelled .. amc$unlabelled,
    tape_densities = rmc$200 .. rmc$38000;

  VAR
    blank_char_scan_set: [READ, pus$literals] set of char := [' '],
    catalog_list_separator: [pus$literals, READ] string (1) := '.',
    cycle_template: [pus$literals, READ] string (8) := 'CYCLE = ',
    density_name: [pus$literals, READ] array [tape_densities] of string (10) := [
      {} 'RMC$200',
      {} 'RMC$556',
      {} 'MT9$800',
      {} 'MT9$1600',
      {} 'MT9$6250',
      {} 'MT18$38000'],
    label_type_name: [pus$literals, READ] array [label_types] OF string (21) := [
      {} 'LABELLED',
      {} 'NON_STANDARD_LABELLED',
      {} 'UNLABELLED'],
    path_template: [pus$literals, READ] string (1) := ':',
    pfn_template: [pus$literals, READ] string (17) := 'PERMANENT_FILE   ',
    unable_to_process_template: [pus$literals, READ] string (24) := '***UNABLE TO PROCESS***';

  CONST
    puc$minimum_list_page_width = 55,

    puc$maximum_list_page_width = 255,

    puc$header_line_separator =
          '--------------------------------------------------------------------------------'
      CAT '--------------------------------------------------------------------------------'
      CAT '--------------------------------------------------------------------------------'
      CAT '---------------',


    puc$continuation_string = '.. ',

    puc$initial_line_space = '    ';

  VAR
    no_expiration_date: [READ, pus$literals] ost$date_time := [255, 12, 31, 23, 59, 59, 999];


?? TITLE := '    List options', EJECT ??
*copyc pud$list_options

?? TITLE := '    Cycle Display Tables', EJECT ??

  VAR
    puv$cycle_display_selections: [STATIC, XDCL] put$cycle_display_selections :=
          [puc$cdo_identifier, puc$cdo_size, puc$cdo_modification_date_time, puc$cdo_action_descriptor];

  VAR
    system_minimal_cdo: [pus$literals, READ] put$cycle_display_selections := [puc$cdo_identifier,
      puc$cdo_action_descriptor];

  VAR
    cycle_display_selection_table: [pus$literals, STATIC, READ] array [1 .. 24] of record
      name: ost$name,
      display_option: put$cycle_display_options,
    recend := [
      {} ['IDENTIFIER                     ', puc$cdo_identifier],
      {} ['SIZE                           ', puc$cdo_size],
      {} ['S                              ', puc$cdo_size],
      {} ['CREATION_DATE_TIME             ', puc$cdo_creation_date_time],
      {} ['CDT                            ', puc$cdo_creation_date_time],
      {} ['ACCESS_DATE_TIME               ', puc$cdo_access_date_time],
      {} ['ADT                            ', puc$cdo_access_date_time],
      {} ['MODIFICATION_DATE_TIME         ', puc$cdo_modification_date_time],
      {} ['MDT                            ', puc$cdo_modification_date_time],
      {} ['EXPIRATION_DATE                ', puc$cdo_expiration_date],
      {} ['ED                             ', puc$cdo_expiration_date],
      {} ['ACCESS_COUNT                   ', puc$cdo_access_count],
      {} ['AC                             ', puc$cdo_access_count],
      {} ['GLOBAL_FILE_NAME               ', puc$cdo_global_file_name],
      {} ['GFN                            ', puc$cdo_global_file_name],
      {} ['RECORDED_VSN                   ', puc$cdo_recorded_vsn],
      {} ['RVSN                           ', puc$cdo_recorded_vsn],
      {} ['ALTERNATE_FILE_MEDIA_DESCRIPTOR', puc$cdo_alternate_storage],
      {} ['AFMD                           ', puc$cdo_alternate_storage],
      {} ['ALTERNATE_FILE_MEDIA_DESCRIPTOR', puc$cdo_alternate_mod_date_time],
      {} ['AFMD                           ', puc$cdo_alternate_mod_date_time],
      {} ['ALTERNATE_FILE_MEDIA_DESCRIPTOR', puc$cdo_alternate_size],
      {} ['AFMD                           ', puc$cdo_alternate_size],
      {} ['ACTION_DESCRIPTOR              ', puc$cdo_action_descriptor]];

  VAR
    cycle_display_header_table: [pus$literals, STATIC, READ] array [put$cycle_display_options] of record
      size: 0 .. 100,
      header: string (100),
    recend := [
      {} [38, 'PF_NAME.CYCLE'],
      {} [18, '     SIZE'],
      {} [25, 'CREATION DATE/TIME'],
      {} [25, 'ACCESS DATE/TIME'],
      {} [25, 'MODIFICATION DATE/TIME'],
      {} [25, 'EXPIRATION DATE'],
      {} [16, 'ACCESS COUNT'],
      {} [40, 'GLOBAL_FILE_NAME'],
      {} [17, 'RECORDED_VSN(S)'],
      {} [35, 'ALTERNATE STORAGE'],
      {} [36, 'ALTERNATE MODIFICATION DATE/TIME'],
      {} [18, 'ALTERNATE SIZE'],
      {} [16, 'EXCLUSION']];


?? TITLE := '    File Display Tables', EJECT ??

  VAR
    file_display_selection_table: [pus$literals, STATIC, READ] array [1 .. 6] of record
      name: ost$name,
      display_option: put$file_display_options,
    recend := [
      {} ['IDENTIFIER                     ', puc$fdo_identifier],
      {} ['ACCOUNT                        ', puc$fdo_account],
      {} ['A                              ', puc$fdo_account],
      {} ['PROJECT                        ', puc$fdo_project],
      {} ['P                              ', puc$fdo_project],
      {} ['ACTION_DESCRIPTOR              ', puc$fdo_action_descriptor]];

  VAR
    file_display_header_table: [pus$literals, STATIC, READ] array [put$file_display_options] of record
      size: 0 .. 50,
      header: string (50),
    recend := [
      {} [33, 'PF_NAME'],
      {} [33, 'ACCOUNT'],
      {} [33, 'PROJECT'],
      {} [16, 'ACTION DESCRIPTOR']];


  VAR
    file_display_selections: put$file_display_selections := [puc$fdo_identifier,
      puc$fdo_action_descriptor],

    system_minimal_fdo: [pus$literals, STATIC, READ] put$file_display_selections := [puc$fdo_identifier,
      puc$fdo_action_descriptor];

?? TITLE := '    [XDCL] pup$close_display_file ', EJECT ??

  PROCEDURE [XDCL] pup$close_display_file (list_file_lfn: amt$local_file_name;
    VAR status: ost$status);

    number_of_opens := number_of_opens - 1;
    status.normal := TRUE;
    IF number_of_opens <= 0 THEN
      clp$close_display (puv$listing_display_control, status);
    IFEND;
  PROCEND pup$close_display_file;

?? TITLE := '    [XDCL] pup$convert_gfn_to_string ', EJECT ??

  PROCEDURE [XDCL] pup$convert_gfn_to_string (binary_name: ost$binary_unique_name;
    VAR result_string: string (60));

    VAR
      unique_name: ost$name,
      ignore_status: ost$status;

    pmp$convert_binary_unique_name (binary_name, unique_name, ignore_status);
    result_string := unique_name;
  PROCEND pup$convert_gfn_to_string;

?? TITLE := '    [XDCL] pup$display_blank_lines ', EJECT ??

  PROCEDURE [XDCL] pup$display_blank_lines (number_of_lines: integer;
    VAR status: ost$status);

    VAR
      i: integer,
      output_string: string (2);

    output_string := ' ';
    status.normal := TRUE;
    FOR i := 1 TO number_of_lines DO
      clp$put_display (puv$listing_display_control, output_string, clc$no_trim, status);
    FOREND;
  PROCEND pup$display_blank_lines;

?? TITLE := '    [XDCL] pup$display_boolean ', EJECT ??

  PROCEDURE [XDCL] pup$display_boolean (descriptor: string ( * <= 255);
        value: boolean;
    VAR status: ost$status);

    VAR
      total_length: integer,
      working_string: string (200);

    STRINGREP (working_string, total_length, descriptor, ' ', value);
    pup$display_line (working_string (1, total_length), status);
  PROCEND pup$display_boolean;


?? TITLE := '    [XDCL] pup$display_excluded_item ', EJECT ??

  PROCEDURE [XDCL] pup$display_excluded_item (entry: put$entry;
        catalog_header: put$catalog_header;
    VAR status: ost$status);

    IF puv$display_excluded_items THEN
      pup$display_item_descriptor ('--- EXCLUDING ----------', catalog_header, entry, status);
      pup$display_line ('------------------------', status);
    IFEND;
  PROCEND pup$display_excluded_item;

?? TITLE := '    [XDCL] pup$display_integer ', EJECT ??

  PROCEDURE [XDCL] pup$display_integer (descriptor: string ( * <= 256);
        number: integer;
    VAR status: ost$status);

    VAR
      total_length: integer,
      working_string: string (200);

    STRINGREP (working_string, total_length, descriptor, ' ', number);
    pup$display_line (working_string (1, total_length), status);
  PROCEND pup$display_integer;

?? TITLE := '    [XDCL] pup$display_item_descriptor ', EJECT ??

  PROCEDURE [XDCL] pup$display_item_descriptor (descriptor_header: string ( * );
        catalog_header: put$catalog_header;
        entry: put$entry;
    VAR status: ost$status);

    IF descriptor_header <> '' THEN
      pup$display_line (descriptor_header, status);
    IFEND;
    pup$write_catalog_header (catalog_header, status);
    CASE entry.entry_type OF
    = puc$valid_pf_entry =
      pup$display_line (' PERMANENT FILE', status);
    = puc$valid_cycle_entry =
      pup$write_cycle_entry (entry, status);
    ELSE
    CASEND;
  PROCEND pup$display_item_descriptor;

?? TITLE := '    [XDCL] pup$display_line ', EJECT ??

  PROCEDURE [XDCL] pup$display_line (output_string: string ( * <= 256);
    VAR status: ost$status);

    clp$put_display (puv$listing_display_control, output_string, clc$trim, status);
  PROCEND pup$display_line;

?? TITLE := '    [XDCL] pup$display_list_options ', EJECT ??

  PROCEDURE [XDCL] pup$display_list_options (parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? RIGHT := 110 ??
{ pdt display_list_options_pdt (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_list_options_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^display_list_options_pdt_names, ^display_list_options_pdt_params];

    VAR
      display_list_options_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
        clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      display_list_options_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
        clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      cycle_display_option: put$cycle_display_options,
      file_display_option: put$file_display_options,
      j: integer;

    clp$scan_parameter_list (parameter_list, display_list_options_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF puv$display_excluded_items THEN
      pup$display_line (' Displaying excluded items.', status);
    ELSE
      pup$display_line (' NOT displaying excluded items', status);
    IFEND;

    pup$display_line (' file_display_selections: ', status);
    FOR file_display_option := LOWERVALUE (put$file_display_options) TO UPPERVALUE (put$file_display_options)
          DO
      IF file_display_option IN file_display_selections THEN

      /find_fdo_option_name/
        FOR j := 1 TO UPPERBOUND (file_display_selection_table) DO
          IF file_display_option = file_display_selection_table [j].display_option THEN
            pup$display_line (file_display_selection_table [j].name, status);
            EXIT /find_fdo_option_name/;
          IFEND;
        FOREND /find_fdo_option_name/;
      IFEND;
    FOREND;


    pup$display_line (' cycle_display_selections: ', status);
    FOR cycle_display_option := LOWERVALUE (put$cycle_display_options) TO UPPERVALUE
          (put$cycle_display_options) DO
      IF cycle_display_option IN puv$cycle_display_selections THEN

      /find_cdo_option_name/
        FOR j := 1 TO UPPERBOUND (cycle_display_selection_table) DO
          IF cycle_display_option = cycle_display_selection_table [j].display_option THEN
            pup$display_line (cycle_display_selection_table [j].name, status);
            EXIT /find_cdo_option_name/;
          IFEND;
        FOREND /find_cdo_option_name/;
      IFEND;
    FOREND;
  PROCEND pup$display_list_options;
?? TITLE := '    [XDCL] pup$format_date_time ', EJECT ??

  PROCEDURE [XDCL] pup$format_date_time (date_time: ost$date_time;
    VAR date_time_string: string ( * ));

    VAR
      date: ost$date,
      status: ost$status,
      time: ost$time;

    date_time_string := '    ';
    pmp$format_compact_date (date_time, osc$mdy_date, date, status);
    date_time_string := date.mdy;
{ should use osc$hms_time osc$millisecond only for TESTING
    pmp$format_compact_time (date_time, osc$millisecond_time, time, status);
    date_time_string (10, * ) := time.millisecond;
  PROCEND pup$format_date_time;

?? TITLE := '    [XDCL] pup$get_summary_status ', EJECT ??

  PROCEDURE [XDCL] pup$get_summary_status (VAR status {input, output} : ost$status);

    VAR
      line_count: ost$status_message_line_count,
      p_line_count: ^ost$status_message_line_count,
      p_line_size: ^ost$status_message_line_size,
      p_message: ^ost$status_message,
      p_message_line: ^string ( * ),
      request_status: ost$status,
      singular_string: string (1);

    IF status.normal THEN
      IF error_count > 0 THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$error_summary_status, '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, error_count, 10, FALSE, status);
        singular_string := ' ';
        IF error_count > 1 THEN
          singular_string := 's';
        IFEND;
        osp$append_status_parameter (osc$status_parameter_delimiter, singular_string, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, listing_file_lfn, status);
        IF (error_count = 1) AND (NOT last_error_status.normal) THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, ' Single abnormal status: ', status);
          PUSH p_message;
          osp$format_message (last_error_status, osc$brief_message_level, osc$max_string_size, p_message^,
                request_status);
          IF NOT request_status.normal THEN
            RETURN;
          IFEND;
          RESET p_message;
          NEXT p_line_count IN p_message;
          IF p_line_count^ > 0 THEN
            FOR line_count := 1 TO (p_line_count^) DO
              NEXT p_line_size IN p_message;
              NEXT p_message_line: [p_line_size^] IN p_message;
              osp$append_status_parameter (osc$status_parameter_delimiter, p_message_line^, status);
            FOREND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pup$get_summary_status;

?? TITLE := '    [XDCL] pup$initialize_backup_listing ', EJECT ??

  PROCEDURE [XDCL] pup$initialize_backup_listing (pf_utility_hierarchy_list: put$hierarchy_list;
        backup_file_id: put$file_identifier;
        backup_information: amt$backup_information;
    VAR status: ost$status);


{
{  PURPOSE:
{    This procedure initializes a listing on a backup_permanent_file
{    subcommand.  Displayed are the item being backed up, and the time of the
{    backup.

    VAR
      file: clt$file,
      local_status: ost$status,
      outputline: string (osc$max_string_size),
      outputline_index: integer,
      mainframe_id: pmt$mainframe_id,
      volume_description: rmt$volume_descriptor,
      volume_number: amt$volume_number;

    error_count := 0;
    last_error_status.normal := TRUE;
    display_archive_options (status);
    pup$display_blank_lines (2, status);
    outputline := 'LISTING PRODUCED BY BACKUP OF:';
    clp$put_display (puv$listing_display_control, outputline, clc$trim, status);
    IF status.normal THEN
      pup$write_catalog_header (pf_utility_hierarchy_list.catalog_header, status);
      IF status.normal THEN
        CASE pf_utility_hierarchy_list.pf_entry.entry_type OF
        = puc$valid_cycle_entry =
          pup$write_cycle_entry (pf_utility_hierarchy_list.pf_entry, status);
        = puc$valid_pf_entry =
          write_pf_entry (pf_utility_hierarchy_list.pf_entry, status);
        ELSE
        CASEND;
        pmp$get_mainframe_id (mainframe_id, status);
        pup$format_date_time (pf_utility_hierarchy_list.date_time, outputline);
        outputline (40, *) := mainframe_id;
        clp$put_display (puv$listing_display_control, outputline, clc$trim, status);
        CASE backup_file_id.device_class OF
        = rmc$magnetic_tape_device =
          { Display enough information here so that a user would know how to request the tape
          { to restore it.
          pup$fetch_current_volume (backup_file_id, volume_number, volume_description, status);
          IF status.normal THEN
            STRINGREP (outputline, outputline_index, 'TAPE NUMBER:', volume_number,
              '     EXTERNAL VSN: ', volume_description.external_vsn,
              '     DENSITY: ', density_name [backup_information.density],
              '     ', label_type_name [backup_file_id.label_type]);
            pup$display_line (outputline (1, outputline_index), status);
            IF status.normal AND (backup_file_id.label_type <> amc$unlabelled) THEN
              STRINGREP (outputline, outputline_index,
                '                   RECORDED VSN: ', volume_description.recorded_vsn);
              pup$display_line (outputline (1, outputline_index), status);
            IFEND;
          ELSE
            pup$write_os_status (status, local_status);
          IFEND;
        = rmc$mass_storage_device =
          clp$put_display (puv$listing_display_control, backup_information.file_path,
                clc$trim, status);
        ELSE
          pup$display_line ('TO $NULL ', status);
        CASEND;
        pup$write_cycle_display_header (status);
      IFEND;
    IFEND;
  PROCEND pup$initialize_backup_listing;

?? TITLE := '    [XDCL] pup$initialize_restore_listing ', EJECT ??

  PROCEDURE [XDCL] pup$initialize_restore_listing (descriptor: string ( * );
        old_catalog_header: put$catalog_header;
        old_entry: put$entry;
        new_catalog_path: pft$path;
        new_cycle_selector: pft$cycle_selector;
    VAR status: ost$status);

    VAR
      date_time: ost$date_time,
      date_time_string: string (80),
      old_above_new: boolean;

    error_count := 0;
    last_error_status.normal := TRUE;
    pup$initialize_restore_totals;
    pup$display_boolean (' RESTORE_ARCHIVE_INFORMATION =', puv$restore_archive_information, status);
    pup$display_blank_lines (2, status);
    pup$display_line (' LISTING PRODUCED BY', status);
    pup$display_line (descriptor, status);
    IF old_entry.entry_type = puc$valid_set_entry THEN
      backup_restore_names_equal := TRUE;
    ELSE
      pup$write_sub_path (old_catalog_header.path, LOWERBOUND (old_catalog_header.path),
          UPPERBOUND (old_catalog_header.path), status);
      CASE old_entry.entry_type OF
      = puc$valid_cycle_entry =
        pup$write_cycle_selector (old_entry.pf_selector.cycle_selector, status);
      ELSE
      CASEND;

{ determine if the backup name equals the restore name
      pup$compare_paths (old_catalog_header.path, new_catalog_path, backup_restore_names_equal,
            old_above_new);
      IF backup_restore_names_equal THEN
        IF old_entry.entry_type = puc$valid_cycle_entry THEN
          pup$compare_cycle_selectors (old_entry.pf_selector.cycle_selector, new_cycle_selector,
                backup_restore_names_equal);
        IFEND;
      IFEND;
      IF NOT backup_restore_names_equal THEN
        pup$display_line ('  NEW NAME:', status);
        pup$write_sub_path (new_catalog_path, LOWERBOUND (new_catalog_path), UPPERBOUND (new_catalog_path),
              status);
        IF old_entry.entry_type = puc$valid_cycle_entry THEN
          pup$write_cycle_selector (new_cycle_selector, status);
        IFEND;
      IFEND;
    IFEND;
    pmp$get_compact_date_time (date_time, status);
    pup$format_date_time (date_time, date_time_string);
    pup$display_line (date_time_string, status);

    pup$write_cycle_display_header (status);
  PROCEND pup$initialize_restore_listing;

?? TITLE := '    [XDCL] pup$initialize_summary_status ', EJECT ??

  PROCEDURE [XDCL] pup$initialize_summary_status;

    error_count := 0;
    last_error_status.normal := TRUE;
  PROCEND pup$initialize_summary_status;

?? TITLE := '    [XDCL] pup$open_display_file ', EJECT ??

  PROCEDURE [XDCL] pup$open_display_file (list_file_lfn: amt$local_file_name;
    VAR status: ost$status);

    VAR
      cl_list_file: clt$file;

    IF number_of_opens > 0 THEN
      IF listing_file_lfn = list_file_lfn THEN
        status.normal := TRUE;
        number_of_opens := number_of_opens + 1;
      ELSE
        osp$set_status_abnormal (puc$pf_utility_id, pue$multiple_list_file, list_file_lfn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, listing_file_lfn, status);
      IFEND;
    ELSE
      cl_list_file.local_file_name := list_file_lfn;
      clp$open_display (cl_list_file, NIL, puv$listing_display_control, status);
      IF status.normal THEN
        IF (puv$listing_display_control.page_width < puc$minimum_list_page_width) THEN
          puv$listing_display_control.page_width := puc$minimum_list_page_width;
        ELSEIF (puv$listing_display_control.page_width > puc$maximum_list_page_width) THEN
          puv$listing_display_control.page_width := puc$maximum_list_page_width;
        IFEND;
        listing_file_lfn := list_file_lfn;
        number_of_opens := 1;
      IFEND;
    IFEND;
  PROCEND pup$open_display_file;


?? TITLE := '    [XDCL] pup$set_list_options ', EJECT ??

  PROCEDURE [XDCL] pup$set_list_options (file_selections: put$file_display_selections;
        cycle_selections: put$cycle_display_selections;
        excluded_items_selection : boolean;
    VAR status: ost$status);

    status.normal := TRUE;
    file_display_selections := file_selections + system_minimal_fdo;
    puv$cycle_display_selections := cycle_selections + system_minimal_cdo;
    puv$display_excluded_items := excluded_items_selection;
  PROCEND pup$set_list_options;


?? TITLE := '    [XDCL] pup$set_list_options_command ', EJECT ??

  PROCEDURE [XDCL] pup$set_list_options_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

    VAR
      cycle_options: put$cycle_display_selections,
      excluded_items_selection: boolean,
      file_options: put$file_display_selections;

    crack_set_list_options (parameter_list, file_options, cycle_options, excluded_items_selection, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$set_list_options (file_options, cycle_options, excluded_items_selection, status);
  PROCEND pup$set_list_options_command;
?? TITLE := '    [XDCL] pup$write_catalog_header ', EJECT ??

  PROCEDURE [XDCL] pup$write_catalog_header (pf_utility_catalog_header: put$catalog_header;
    VAR status: ost$status);

    VAR
      length: integer,
      outputline: string (osc$max_string_size);

    status.normal := TRUE;
{       STRINGREP (outputline, length, set_template, catalog_header.set_name);
{    pup$display_line (outputline (1, length), status);
    IF pf_utility_catalog_header.logical_path_length > 0 THEN
      pup$write_path (pf_utility_catalog_header.path, status);
    IFEND;
  PROCEND pup$write_catalog_header;
?? TITLE := '    [XDCL] pup$write_cycle_display ', EJECT ??

  PROCEDURE [XDCL] pup$write_cycle_display
   (    pf_entry: put$entry;
        cycle_array_entry: pft$cycle_array_entry_version_2;
        file_length: amt$file_length;
        global_file_name: ost$binary_unique_name;
        p_recorded_vsns: ^ ARRAY [1 .. *] of rmt$recorded_vsn;
        p_cycle_array_extended_record: pft$p_info_record;
        p_cycle_directory_array: pft$p_cycle_directory_array;
    VAR status: ost$status);

    write_cycle_display (pf_entry, cycle_array_entry, file_length, global_file_name, p_recorded_vsns,
          p_cycle_array_extended_record, p_cycle_directory_array, puc$item_backed_up, status);

  PROCEND pup$write_cycle_display;
?? TITLE := '    [XDCL] pup$write_cycle_display_header ', EJECT ??

  PROCEDURE [XDCL] pup$write_cycle_display_header (VAR status: ost$status);

    VAR
      current_position: integer,
      i: put$cycle_display_options,
      outputline: string (osc$max_string_size);

    status.normal := TRUE;
    pup$display_blank_lines (2, status);
    pup$display_line ('CATALOG', status);
    pup$write_file_display_header (status);
    STRINGREP (outputline, current_position, puc$initial_line_space);
    FOR i := LOWERVALUE (put$cycle_display_options) TO PRED (puc$cdo_action_descriptor) DO
      IF i IN puv$cycle_display_selections THEN
        IF (current_position + cycle_display_header_table [i].size) > puv$listing_display_control.page_width
              THEN
          { Start a new line
          pup$display_line (outputline (1, current_position), status);
          STRINGREP (outputline, current_position, puc$initial_line_space, puc$continuation_string);
        IFEND;
        STRINGREP (outputline, current_position, outputline (1, current_position), cycle_display_header_table
              [i].header (1, cycle_display_header_table [i].size));
      IFEND;
    FOREND;
    pup$display_line (outputline (1, current_position), status);

    outputline := puc$header_line_separator;
    pup$display_line (outputline (1, puv$listing_display_control.page_width), status);
  PROCEND pup$write_cycle_display_header;

?? TITLE := '    pup$write_cycle_entry ', EJECT ??

  PROCEDURE pup$write_cycle_entry (pf_entry: put$entry;
    VAR status: ost$status);

    VAR
      index: integer,
      outputline: string (osc$max_string_size);

    status.normal := TRUE;
    outputline := ' ';
    outputline (1, STRLENGTH (pfn_template)) := pfn_template;
{    outputline (STRLENGTH (pfn_template) + 1, * ) := pf_entry.pf_selector.pfn;
    clp$put_display (puv$listing_display_control, outputline, clc$trim, status);
    IF status.normal THEN
      pup$write_cycle_selector (pf_entry.pf_selector.cycle_selector, status);
    IFEND;
  PROCEND pup$write_cycle_entry;

?? TITLE := '    [XDCL] pup$write_cycle_selector ', EJECT ??

  PROCEDURE [XDCL] pup$write_cycle_selector (cycle_selector: pft$cycle_selector;
    VAR status: ost$status);

    VAR
      index: integer,
      outputline: string (osc$max_string_size);

    status.normal := TRUE;
    outputline := ' ';
    outputline (1, STRLENGTH (cycle_template)) := cycle_template;
    CASE cycle_selector.cycle_option OF
    = pfc$highest_cycle =
      outputline (STRLENGTH (cycle_template) + 1, * ) := '$HIGH';
    = pfc$lowest_cycle =
      outputline (STRLENGTH (cycle_template) + 1, * ) := '$LOW';
    = pfc$specific_cycle =
      outputline (STRLENGTH (cycle_template) + 1, * ) := '    ';
      STRINGREP (outputline (STRLENGTH (cycle_template) + 1, * ), index, cycle_selector.cycle_number);
    ELSE
      ;
    CASEND;
    clp$put_display (puv$listing_display_control, outputline, clc$trim, status);
  PROCEND pup$write_cycle_selector;

?? TITLE := '    [XDCL] pup$write_deleted_cycle ', EJECT ??

  PROCEDURE [XDCL] pup$write_deleted_cycle
   (    pf_entry: put$entry;
        cycle_array_entry: pft$cycle_array_entry_version_2;
        file_length: amt$file_length;
        global_file_name: ost$binary_unique_name;
        p_recorded_vsns: ^ array [1 .. *] of rmt$recorded_vsn;
        p_cycle_array_extended_record: pft$p_info_record;
        p_cycle_directory_array: pft$p_cycle_directory_array;
    VAR status: ost$status);

    write_cycle_display (pf_entry, cycle_array_entry, file_length, global_file_name, p_recorded_vsns,
          p_cycle_array_extended_record, p_cycle_directory_array, '     DELETED  ',
          status);

  PROCEND pup$write_deleted_cycle;

?? TITLE := '    [XDCL] pup$write_excluded_cycle ', EJECT ??

  PROCEDURE [XDCL] pup$write_excluded_cycle
   (    pf_entry: put$entry;
        cycle_array_entry: pft$cycle_array_entry_version_2;
        file_length: amt$file_length;
        global_file_name: ost$binary_unique_name;
        p_recorded_vsns: ^ array [1 .. *] of rmt$recorded_vsn;
        p_cycle_array_extended_record: pft$p_info_record;
        p_cycle_directory_array: pft$p_cycle_directory_array;
        exclusion_descriptor: put$action_descriptor;
    VAR status: ost$status);

    IF puv$display_excluded_items THEN
      write_cycle_display (pf_entry, cycle_array_entry, file_length, global_file_name,
            p_recorded_vsns, p_cycle_array_extended_record, p_cycle_directory_array, exclusion_descriptor,
            status);
    IFEND;

  PROCEND pup$write_excluded_cycle;

?? TITLE := '    [XDCL] pup$write_file_display ', EJECT ??

  PROCEDURE [XDCL] pup$write_file_display (pf_entry: put$entry;
        account: avt$account_name;
        project: avt$project_name;
    VAR status: ost$status);

    VAR
      current_position: integer,
      i: put$file_display_options,
      outputline: string (osc$max_string_size);

    outputline := ' ';
    status.normal := TRUE;
    STRINGREP (outputline, current_position, puc$initial_line_space);
    FOR i := LOWERVALUE (put$file_display_options) TO UPPERVALUE (put$file_display_options) DO
      IF i IN file_display_selections THEN
        IF (current_position + file_display_header_table [i].size) > puv$listing_display_control.page_width
              THEN
          { start a new line }
          pup$display_line (outputline (1, current_position), status);
          outputline := ' ';
          STRINGREP (outputline, current_position, puc$initial_line_space, puc$continuation_string);
        IFEND;
        CASE i OF
        = puc$fdo_identifier =
          STRINGREP (outputline, current_position, outputline (1, current_position), pf_entry.pf_selector.
                pfn);
        = puc$fdo_project =
          STRINGREP (outputline, current_position, outputline (1, current_position), project);
        = puc$fdo_account =
          STRINGREP (outputline, current_position, outputline (1, current_position), account);
        = puc$fdo_action_descriptor =
          {?????/?????????????
        ELSE
        CASEND;
      IFEND;
    FOREND;
    pup$display_line (outputline (1, current_position), status);
  PROCEND pup$write_file_display;

?? TITLE := '    pup$write_file_display_header ', EJECT ??

  PROCEDURE pup$write_file_display_header (VAR status: ost$status);

    VAR
      current_position: integer,
      i: put$file_display_options,
      outputline: string (osc$max_string_size);

    status.normal := TRUE;
    STRINGREP (outputline, current_position, puc$initial_line_space);
    FOR i := LOWERVALUE (put$file_display_options) TO puc$fdo_project DO
      IF i IN file_display_selections THEN
        IF (current_position + file_display_header_table [i].size) > puv$listing_display_control.page_width
              THEN
          { Start a new line
          pup$display_line (outputline (1, current_position), status);
          STRINGREP (outputline, current_position, puc$initial_line_space, puc$continuation_string);
        IFEND;
        STRINGREP (outputline, current_position, outputline (1, current_position), file_display_header_table
              [i].header (1, file_display_header_table [i].size));
      IFEND;
    FOREND;
    pup$display_line (outputline (1, current_position), status);
  PROCEND pup$write_file_display_header;

?? TITLE := '    [XDCL] pup$write_os_status ', EJECT ??

  PROCEDURE [XDCL] pup$write_os_status (status: ost$status;
    VAR request_status: ost$status);

{  This routine writes a status variable to the output file.  If the status
{  is normal nothing is output, but if the status is NOT normal, the
{  status message is formatted and output.

    VAR
      line_count: ost$status_message_line_count,
      outputline: string (osc$max_string_size),
      p_line_count: ^ost$status_message_line_count,
      p_line_size: ^ost$status_message_line_size,
      p_message: ^ost$status_message,
      p_message_line: ^string ( * );

    request_status.normal := TRUE;
    IF status.normal THEN
      RETURN;
    IFEND;
    last_error_status := status;
    error_count := error_count + 1;
    PUSH p_message;
    osp$format_message (status, osc$full_message_level, puv$listing_display_control.page_width, p_message^,
          request_status);
    IF NOT request_status.normal THEN
      RETURN;
    IFEND;
    RESET p_message;
    NEXT p_line_count IN p_message;
    IF p_line_count^ > 0 THEN
      FOR line_count := 1 TO (p_line_count^) DO
        NEXT p_line_size IN p_message;
        NEXT p_message_line: [p_line_size^] IN p_message;
        outputline := '   ';
        outputline (1, p_line_size^) := p_message_line^;
        clp$put_display (puv$listing_display_control, outputline, clc$trim, request_status);
        IF NOT request_status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND;
    pup$display_blank_lines (1, request_status);
  PROCEND pup$write_os_status;

?? TITLE := '    [XDCL] pup$write_path ', EJECT ??

  PROCEDURE [XDCL] pup$write_path (path: pft$path;
    VAR status: ost$status);

    pup$write_sub_path (path, LOWERBOUND (path), UPPERBOUND (path), status);
  PROCEND pup$write_path;

?? TITLE := '    [XDCL] pup$write_status_to_listing ', EJECT ??

  PROCEDURE [XDCL] pup$write_status_to_listing (pf_utility_entry: put$entry;
        bad_status: ost$status;
    VAR status: ost$status);

    VAR
      k: integer,
      name_length: put$half_integer,
      outputline: string (osc$max_string_size),
      outputline_index: put$half_integer;

    status.normal := TRUE;
    IF bad_status.normal THEN
      RETURN;
    IFEND;
    outputline := '     ';
    outputline_index := 1;
    CASE pf_utility_entry.entry_type OF
    = puc$valid_cycle_entry =
      outputline_index := 6;
      calculate_name_length (pf_utility_entry.pf_selector.pfn, name_length);
      outputline (outputline_index, name_length) := pf_utility_entry.pf_selector.pfn;
      CASE pf_utility_entry.pf_selector.cycle_selector.cycle_option OF
      = pfc$lowest_cycle =
        outputline ((outputline_index + name_length), 5) := '.$LOW';
      = pfc$highest_cycle =
        outputline ((outputline_index + name_length), 6) := '.$HIGH';
      = pfc$specific_cycle =
        STRINGREP (outputline (outputline_index + name_length, 4), k, pf_utility_entry.pf_selector.
              cycle_selector.cycle_number);
        outputline (outputline_index + name_length) := '.';
      CASEND;
    = puc$valid_pf_entry =
      outputline_index := 6;
      calculate_name_length (pf_utility_entry.pfn, name_length);
      outputline (outputline_index, name_length) := pf_utility_entry.pfn;
    = puc$valid_catalog_entry =
      calculate_name_length (pf_utility_entry.catalog_name, name_length);
      outputline (outputline_index, name_length) := pf_utility_entry.catalog_name;
    = puc$valid_family_entry =
      calculate_name_length (pf_utility_entry.family_name, name_length);
      outputline (outputline_index, name_length) := pf_utility_entry.family_name;
    = puc$valid_set_entry =
      calculate_name_length (pf_utility_entry.set_name, name_length);
      outputline (outputline_index, name_length) := pf_utility_entry.set_name;
    = puc$invalid_entry =
      name_length := 0;
    ELSE
    CASEND;
    outputline_index := outputline_index + name_length + 6;
    outputline (outputline_index, STRLENGTH (unable_to_process_template)) := unable_to_process_template;
    clp$put_display (puv$listing_display_control, outputline, clc$trim, status);
    pup$write_os_status (bad_status, status);
  PROCEND pup$write_status_to_listing;

?? TITLE := '    [XDCL] pup$write_sub_path ', EJECT ??

  PROCEDURE [XDCL] pup$write_sub_path (path: pft$path;
        lower: integer;
        upper: integer;
    VAR status: ost$status);

{  PURPOSE:
{    This procedure writes a pf path to the list file designated by
{    puv$listing_display_control.

    VAR
      index: put$half_integer,
      name_length: put$half_integer,
      new_outputline_index: put$half_integer,
      outputline: string (osc$max_string_size),
      outputline_index: put$half_integer;

    status.normal := TRUE;
    outputline_index := 1;
    outputline (outputline_index, * ) := '     ';
    outputline (outputline_index, STRLENGTH (path_template)) := path_template;
    outputline_index := outputline_index + STRLENGTH (path_template);

  /display_loop/
    FOR index := lower TO upper DO
      calculate_name_length (path [index], name_length);
      new_outputline_index := outputline_index + name_length + STRLENGTH (catalog_list_separator);
      IF new_outputline_index > puv$listing_display_control.page_width THEN
        clp$put_display (puv$listing_display_control, outputline, clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display_loop/;
        IFEND;
        outputline_index := 4;
        outputline := puc$continuation_string;
        new_outputline_index := outputline_index + name_length + STRLENGTH (catalog_list_separator);
      IFEND;
      outputline (outputline_index, name_length) := path [index];
      IF index < upper THEN
        {This assures there isnt a trailing separator }
        outputline (outputline_index + name_length, STRLENGTH (catalog_list_separator)) :=
              catalog_list_separator;
      IFEND;
      outputline_index := new_outputline_index;
    FOREND /display_loop/;
    IF outputline_index > 1 THEN
      clp$put_display (puv$listing_display_control, outputline, clc$trim, status);
    IFEND;
  PROCEND pup$write_sub_path;
?? TITLE := '    [INLINE] calculate_name_length ', EJECT ??

  PROCEDURE [INLINE] calculate_name_length (name: ost$name;
    VAR name_length: put$half_integer);

    VAR
      found: boolean;

    #scan (blank_char_scan_set, name, name_length, found);
    IF found THEN
      name_length := name_length - 1;
    ELSE
      name_length := STRLENGTH (name);
    IFEND;
  PROCEND calculate_name_length;

?? TITLE := '    convert_name_to_cdo ', EJECT ??

  PROCEDURE convert_name_to_cdo (name: ost$name;
    VAR cycle_display_option: put$cycle_display_options;
    VAR status: ost$status);

    VAR
      i: integer;

    status.normal := TRUE;
    FOR i := 1 TO UPPERBOUND (cycle_display_selection_table) DO
      IF cycle_display_selection_table [i].name = name THEN
        cycle_display_option := cycle_display_selection_table [i].display_option;
        RETURN;
      IFEND;
    FOREND;
    osp$set_status_abnormal (puc$pf_utility_id, cle$name_not_a_keyword_value, name, status);
  PROCEND convert_name_to_cdo;

?? TITLE := '    convert_name_to_fdo ', EJECT ??

  PROCEDURE convert_name_to_fdo (name: ost$name;
    VAR file_display_option: put$file_display_options;
    VAR status: ost$status);

    VAR
      i: integer;

    status.normal := TRUE;
    FOR i := 1 TO UPPERBOUND (file_display_selection_table) DO
      IF file_display_selection_table [i].name = name THEN
        file_display_option := file_display_selection_table [i].display_option;
        RETURN;
      IFEND;
    FOREND;
    osp$set_status_abnormal (puc$pf_utility_id, cle$name_not_a_keyword_value, name, status);
  PROCEND convert_name_to_fdo;


?? TITLE := '    crack_cycle_display_selection ', EJECT ??

  PROCEDURE crack_cycle_display_selection (parameter_name: string ( * );
    VAR cycle_display_selection: put$cycle_display_selections;
    VAR status: ost$status);

    VAR
      all_selected: boolean,
      cycle_display_option: put$cycle_display_options,
      i: 1 .. 20,
      name_list_container: SEQ (REP 20 of ost$name),
      none_selected: boolean,
      p_name_list: ^array [1 .. * ] of ost$name;

    pup$crack_name_list (parameter_name, name_list_container, p_name_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$determine_if_all_selected (p_name_list^, parameter_name, all_selected, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pup$determine_if_none_selected (p_name_list^, parameter_name, none_selected, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF all_selected THEN
      cycle_display_selection := - $put$cycle_display_selections [];
    ELSEIF none_selected THEN
      cycle_display_selection := $put$cycle_display_selections [];
    ELSE
      cycle_display_selection := $put$cycle_display_selections [];
      FOR i := 1 TO UPPERBOUND (p_name_list^) DO
        convert_name_to_cdo (p_name_list^ [i], cycle_display_option, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        cycle_display_selection := cycle_display_selection + $put$cycle_display_selections
              [cycle_display_option];
      FOREND;
    IFEND;

  PROCEND crack_cycle_display_selection;

?? TITLE := '    crack_file_display_selection ', EJECT ??

  PROCEDURE crack_file_display_selection (parameter_name: string ( * );
    VAR file_display_selection: put$file_display_selections;
    VAR status: ost$status);

    VAR
      all_selected: boolean,
      file_display_option: put$file_display_options,
      i: 1 .. 20,
      name_list_container: SEQ (REP 20 of ost$name),
      none_selected: boolean,
      p_name_list: ^array [1 .. * ] of ost$name;

    pup$crack_name_list (parameter_name, name_list_container, p_name_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$determine_if_all_selected (p_name_list^, parameter_name, all_selected, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pup$determine_if_none_selected (p_name_list^, parameter_name, none_selected, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF all_selected THEN
      file_display_selection := - $put$file_display_selections [];
    ELSEIF none_selected THEN
      file_display_selection := $put$file_display_selections [];
    ELSE
      file_display_selection := $put$file_display_selections [];
      FOR i := 1 TO UPPERBOUND (p_name_list^) DO
        convert_name_to_fdo (p_name_list^ [i], file_display_option, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        file_display_selection := file_display_selection + $put$file_display_selections [file_display_option];
      FOREND;
    IFEND;

  PROCEND crack_file_display_selection;




?? TITLE := '    crack_set_list_options ', EJECT ??

  PROCEDURE crack_set_list_options (parameter_list: clt$parameter_list;
    VAR file_display_selections: put$file_display_selections;
    VAR cycle_display_selections: put$cycle_display_selections;
    VAR excluded_items_selection: boolean;
    VAR status: ost$status);

{  PDT setlo_pdt (
{  file_display_options,file_display_option,fdo: list of key account, a, project, p, all, none = none
{  cycle_display_options,cycle_display_option,cdo: list of key creation_date_time,cdt, ..
{  access_date_time,adt,modification_date_time,mdt,expiration_date,ed,..
{   access_count,ac,size,s,recorded_vsn,rvsn,global_file_name,gfn,alternate_file_media_descriptor,afmd,..
{   all,none = (size,modification_date_time)
{  display_excluded_items, display_excluded_item, dei: boolean = false
{  status)

?? PUSH (LISTEXT := ON) ??

  VAR
    setlo_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^setlo_pdt_names, ^setlo_pdt_params
      ];

  VAR
    setlo_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 10] of
      clt$parameter_name_descriptor := [['FILE_DISPLAY_OPTIONS', 1], ['FILE_DISPLAY_OPTION', 1], ['FDO', 1], [
      'CYCLE_DISPLAY_OPTIONS', 2], ['CYCLE_DISPLAY_OPTION', 2], ['CDO', 2], ['DISPLAY_EXCLUDED_ITEMS', 3], [
      'DISPLAY_EXCLUDED_ITEM', 3], ['DEI', 3], ['STATUS', 4]];

  VAR
    setlo_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor := [

{ FILE_DISPLAY_OPTIONS FILE_DISPLAY_OPTION FDO }
    [[clc$optional_with_default, ^setlo_pdt_dv1], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [^
      setlo_pdt_kv1, clc$keyword_value]],

{ CYCLE_DISPLAY_OPTIONS CYCLE_DISPLAY_OPTION CDO }
    [[clc$optional_with_default, ^setlo_pdt_dv2], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [^
      setlo_pdt_kv2, clc$keyword_value]],

{ DISPLAY_EXCLUDED_ITEMS DISPLAY_EXCLUDED_ITEM DEI }
    [[clc$optional_with_default, ^setlo_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$boolean_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    setlo_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of ost$name := ['ACCOUNT','A',
      'PROJECT','P','ALL','NONE'];

  VAR
      setlo_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 20] of ost$name := [
      'CREATION_DATE_TIME','CDT','ACCESS_DATE_TIME','ADT','MODIFICATION_DATE_TIME','MDT','EXPIRATION_DATE',
        'ED','ACCESS_COUNT','AC','SIZE','S','RECORDED_VSN','RVSN','GLOBAL_FILE_NAME','GFN',
        'ALTERNATE_FILE_MEDIA_DESCRIPTOR', 'AFMD', 'ALL', 'NONE'];

  VAR
    setlo_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'none';

  VAR
    setlo_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (29) := '(size,modification_date_time)';

  VAR
    setlo_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';

?? POP ??

    clp$scan_parameter_list (parameter_list, setlo_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_file_display_selection ('FILE_DISPLAY_OPTIONS', file_display_selections, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_cycle_display_selection ('CYCLE_DISPLAY_OPTIONS', cycle_display_selections, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_boolean ('DISPLAY_EXCLUDED_ITEMS', excluded_items_selection, status);
  PROCEND crack_set_list_options;

?? TITLE := '    display_archive_options ', EJECT ??

  PROCEDURE display_archive_options (VAR status: ost$status);

    pup$display_boolean (' INCLUDE_ARCHIVE_INFORMATION =', puv$include_archive_information, status);
    IF status.normal THEN
      IF puc$include_offline_data IN puv$include_data_options THEN
        pup$display_line (' INCLUDING OFFLINE DATA', status);
      IFEND;
      IF status.normal THEN
        IF (puc$include_releasable_data IN puv$include_data_options) THEN
          pup$display_line (' INCLUDING RELEASABLE DATA', status);
        IFEND;
        IF status.normal THEN
          IF (puc$include_unreleasable_data IN puv$include_data_options) THEN
            pup$display_line (' INCLUDING UNRELEASABLE DATA', status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND display_archive_options;

?? TITLE := '    {inline} edit_integer ', EJECT ??

  PROCEDURE {inline} edit_integer (int: integer;
    VAR str {input, output} : ost$string);

    VAR
      i: ost$string_size,
      ignore_status: ost$status,
      j: ost$string_size,
      temp_str: ost$string;

    clp$convert_integer_to_string (int, 10, FALSE, temp_str, ignore_status);
    IF str.size < (temp_str.size + ((temp_str.size - 1) DIV 3)) THEN
      str.size := temp_str.size + ((temp_str.size - 1) DIV 3);
    IFEND;
    j := str.size;
    FOR i := temp_str.size DOWNTO 1 DO
      str.value (j) := temp_str.value (i);
      j := j - 1;
      IF (i > 1) AND (((temp_str.size - i) MOD 3) = 2) THEN
        str.value (j) := ',';
        j := j - 1;
      IFEND;
    FOREND;
    str.value (1, j) := '';

  PROCEND edit_integer;

?? TITLE := '    write_cycle_display ', EJECT ??

  PROCEDURE write_cycle_display
   (    pf_entry: put$entry;
        cycle_array_entry: pft$cycle_array_entry_version_2;
        file_length: amt$file_length;
        global_file_name: ost$binary_unique_name;
        p_recorded_vsns: ^ ARRAY [ 1 .. *] of rmt$recorded_vsn;
        p_cycle_array_extended_record: pft$p_info_record;
        p_cycle_directory_array: pft$p_cycle_directory_array;
        action_descriptor: put$action_descriptor;
    VAR status: ost$status);


    VAR
      alternate_storage_string: string (76),
      alternate_storage_string_size: integer,
      archive_group_count: pft$archive_count,
      archive_identification: pft$archive_identification,
      current_position: integer,
      date_time_string: string (25),
      file_length_string: string (25),
      gfn_string: string (60),
      i: put$cycle_display_options,
      ignore_status: ost$status,
      k: integer,
      name_length: put$half_integer,
      outputline: string (osc$max_string_size),
      p_archive_entry: pft$p_archive_array_entry,
      p_archive_group: pft$p_info_record,
      p_archive_list: pft$p_info_record,
      p_archive_list_body: pft$p_info,
      p_archive_media: pft$p_amd,
      p_cycle_info_record: pft$p_info_record,
      p_path: pft$p_path,
      starting_position: integer,
      volume: amt$volume_number;

    status.normal := TRUE;
    outputline := ' ';
    date_time_string := ' ';
    STRINGREP (outputline, current_position, puc$initial_line_space);
    current_position := current_position + 1;

    /process_cycle_display_options/
    FOR i := LOWERVALUE (put$cycle_display_options) TO UPPERVALUE (put$cycle_display_options) DO
      IF i IN puv$cycle_display_selections THEN
        IF (i <> puc$cdo_action_descriptor) OR ((i = puc$cdo_action_descriptor) AND (action_descriptor <>
              puc$item_backed_up)) THEN
          IF (current_position + cycle_display_header_table [i].size) >
                puv$listing_display_control.page_width THEN

{ Start a new line

            pup$display_line (outputline (1, current_position), ignore_status);
            outputline := ' ';
            STRINGREP (outputline, current_position, puc$initial_line_space,
                  puc$continuation_string);
            current_position := current_position + 1;
          IFEND;
          CASE i OF
          = puc$cdo_identifier =
            calculate_name_length (pf_entry.pf_selector.pfn, name_length);
            outputline (current_position, name_length) := pf_entry.pf_selector.pfn;
            CASE pf_entry.pf_selector.cycle_selector.cycle_option OF
            = pfc$lowest_cycle =
              outputline ((current_position + name_length), 5) := '.$LOW';
            = pfc$highest_cycle =
              outputline ((current_position + name_length), 6) := '.$HIGH';
            = pfc$specific_cycle =
              STRINGREP (outputline (current_position + name_length, 4), k, pf_entry.pf_selector.
                    cycle_selector.cycle_number);
              outputline (current_position + name_length) := '.';
            CASEND;
          = puc$cdo_size =
            IF cycle_array_entry.device_class = rmc$mass_storage_device THEN
              IF file_length = puc$unknown_cycle_size THEN
                outputline (current_position + 2, 7) := 'UNKNOWN';
              ELSEIF file_length = puc$released_cycle_size THEN
                outputline (current_position + 2, 8) := 'RELEASED';
              ELSE
                STRINGREP (file_length_string, k, file_length);
                outputline ((current_position + 9 - k), k) := file_length_string (1, k);
              IFEND;
            ELSEIF cycle_array_entry.device_class = rmc$magnetic_tape_device THEN
              outputline (current_position + 2, 13) := 'MAGNETIC_TAPE';
            IFEND;
          = puc$cdo_creation_date_time =
            pup$format_date_time (cycle_array_entry.cycle_statistics.creation_date_time, date_time_string);
            outputline (current_position, cycle_display_header_table [i].size) := date_time_string;
          = puc$cdo_access_date_time =
            pup$format_date_time (cycle_array_entry.cycle_statistics.access_date_time, date_time_string);
            outputline (current_position, cycle_display_header_table [i].size) := date_time_string;
          = puc$cdo_modification_date_time =
            pup$format_date_time (cycle_array_entry.cycle_statistics.modification_date_time,
                  date_time_string);
            outputline (current_position, cycle_display_header_table [i].size) := date_time_string;
          = puc$cdo_expiration_date =
            IF cycle_array_entry.expiration_date_time = no_expiration_date THEN
              outputline (current_position, 4) := 'NONE';
            ELSE
              pup$format_date_time (cycle_array_entry.expiration_date_time, date_time_string);
              outputline (current_position, cycle_display_header_table [i].size) := date_time_string;
            IFEND;
          = puc$cdo_access_count =
            STRINGREP (outputline (current_position, * ), k,
                  cycle_array_entry.cycle_statistics.access_count);
          = puc$cdo_global_file_name =
            IF global_file_name = puv$unknown_global_file_name THEN
              outputline (current_position, 7) := 'UNKNOWN';
            ELSE
              pup$convert_gfn_to_string (global_file_name, gfn_string);
              outputline (current_position, 40) := gfn_string;
            IFEND;
          = puc$cdo_recorded_vsn =
            IF p_recorded_vsns = NIL THEN
              outputline (current_position + 1, 7) := 'UNKNOWN';
            ELSEIF p_recorded_vsns^ [1] = puc$nonexistent_recorded_vsn THEN
              outputline (current_position + 1, 8) := 'RELEASED';
            ELSEIF upperbound (p_recorded_vsns^) = 1 THEN
              outputline (current_position + 1, 6) := p_recorded_vsns^ [1];
            ELSE { Volume list
              starting_position := current_position;
              outputline (current_position) := '(';
              current_position := current_position + 1;
              FOR volume := 1 to upperbound (p_recorded_vsns^) DO
                IF (current_position + 7) >= puv$listing_display_control.page_width THEN

{ Start a new line

                  pup$display_line (outputline (1, current_position), ignore_status);
                  outputline := ' ';
                  STRINGREP (outputline, current_position, puc$initial_line_space,
                        puc$continuation_string, ' ');
                IFEND;
                outputline (current_position, 6) := p_recorded_vsns^[volume];
                current_position := current_position + 7;
              FOREND;
              outputline (current_position - 1) := ')';
              IF current_position > (starting_position + cycle_display_header_table [i].size) THEN

{ Force this line out to allow the action_descriptor to be aligned

                pup$display_line (outputline (1, current_position), ignore_status);
                outputline := ' ';
                STRINGREP (outputline, current_position, puc$initial_line_space,
                      puc$continuation_string, ' ');
              IFEND;
              CYCLE /process_cycle_display_options/;
            IFEND;
          = puc$cdo_alternate_storage =
            PUSH p_path: [1 .. 1];
            p_path^ [1] := pf_entry.pf_selector.pfn;
            pup$find_cycle_info_record (p_cycle_array_extended_record, p_cycle_directory_array,
                  cycle_array_entry.cycle_number, p_path, p_cycle_info_record, status);
            IF status.normal THEN
              pfp$find_archive_info (p_cycle_info_record, p_archive_list, status);
              IF (NOT status.normal) AND (status.condition = pfe$unknown_archive_info) THEN
                outputline (current_position, 4) := 'NONE';
              ELSEIF status.normal THEN
                archive_identification.application_identifier := osc$null_name;
                archive_identification.media_identifier.media_device_class := osc$null_name;
                archive_identification.media_identifier.media_volume_identifier := '';
                p_archive_list_body := ^p_archive_list^.body;
                archive_group_count := 0;
                REPEAT
                  pfp$find_next_archive_entry (archive_identification, p_archive_list_body,
                      p_archive_group, p_archive_entry, p_archive_media, status);
                  IF status.normal THEN
                    calculate_name_length (p_archive_entry^.archive_identification.application_identifier,
                          name_length);
                    pup$format_date_time (p_archive_entry^.modification_date_time, date_time_string);
                    STRINGREP (alternate_storage_string, alternate_storage_string_size,
                          p_archive_entry^.archive_identification.application_identifier);
                    IF (current_position + alternate_storage_string_size) >=
                          puv$listing_display_control.page_width THEN
                      pup$display_line (outputline (1, current_position), ignore_status);
                      outputline := ' ';
                      STRINGREP (outputline, current_position, puc$initial_line_space,
                            puc$continuation_string, ' ');
                    IFEND;
                    outputline (current_position, alternate_storage_string_size) :=
                          alternate_storage_string;
                    current_position := current_position + alternate_storage_string_size + 1;
                    STRINGREP (alternate_storage_string, alternate_storage_string_size,
                          ' ', date_time_string);
                    IF (current_position + alternate_storage_string_size) >=
                          puv$listing_display_control.page_width THEN
                      pup$display_line (outputline (1, current_position), ignore_status);
                      outputline := ' ';
                      STRINGREP (outputline, current_position, puc$initial_line_space,
                            puc$continuation_string, ' ');
                    IFEND;
                    outputline (current_position, alternate_storage_string_size) :=
                          alternate_storage_string;
                    current_position := current_position + alternate_storage_string_size + 1;
                    STRINGREP (alternate_storage_string, alternate_storage_string_size,
                          ' ', p_archive_entry^.file_size:14);
                    IF (current_position + alternate_storage_string_size) >=
                          puv$listing_display_control.page_width THEN
                      pup$display_line (outputline (1, current_position), ignore_status);
                      outputline := ' ';
                      STRINGREP (outputline, current_position, puc$initial_line_space,
                            puc$continuation_string, ' ');
                    IFEND;
                    outputline (current_position, alternate_storage_string_size) :=
                          alternate_storage_string;
                    current_position := current_position + alternate_storage_string_size + 1;
                    archive_group_count := archive_group_count + 1;
                    IF (p_archive_list_body <> NIL)
                          AND ((current_position + 7) >= puv$listing_display_control.page_width) THEN

{ Start a new line

                      pup$display_line (outputline (1, current_position), ignore_status);
                      outputline := ' ';
                      STRINGREP (outputline, current_position, puc$initial_line_space,
                            puc$continuation_string, ' ');
                    IFEND;
                  IFEND;
                UNTIL (p_archive_list_body = NIL) OR NOT status.normal;
                CYCLE /process_cycle_display_options/;
              IFEND;
            IFEND;
          = puc$cdo_action_descriptor =
            outputline (current_position, 14) := action_descriptor;
          ELSE
          CASEND;
          current_position := current_position + cycle_display_header_table [i].size;
        IFEND;
      IFEND;
    FOREND /process_cycle_display_options/;

    IF current_position > 8 THEN

{ Display the remaining line if it has more than continuation marks on it.

      pup$display_line (outputline (1, current_position), ignore_status);
    IFEND;

  PROCEND write_cycle_display;



?? TITLE := '    write_pf_entry ', EJECT ??

  PROCEDURE write_pf_entry (pf_entry: put$entry;
    VAR status: ost$status);

    VAR
      outputline: string (osc$max_string_size);

    status.normal := TRUE;
    outputline := ' ';
    outputline (1, STRLENGTH (pfn_template)) := pfn_template;
{    outputline (STRLENGTH (pfn_template) + 1, * ) := pf_entry.pfn;
    clp$put_display (puv$listing_display_control, outputline, clc$trim, status);
  PROCEND write_pf_entry;


MODEND pum$listing_output;
*DECK DECK=PUM$LOG_KEYED_FILE_BACKUP_STUB EXPAND=TRUE
*copyc osd$default_pragmats
MODULE pum$log_keyed_file_backup_stub;
{
{ This module provides a stub for the AAM interface used by
{ the backup utility.  This should be included in the library
{ osf$unbound_pf_utilities to use this stub.
{ This is included only for testing and should not normally
{ be included with the backup utility.
?? PUSH (LISTEXT := ON) ??
*copyc amt$backup_information
*copyc fst$path
*copyc osd$unique_name
*copyc ost$status
*copyc puv$trace_selected
*copyc rmt$volume_list
?? POP ??
  TYPE
    tape_densities = rmc$200 .. rmc$6250;

  VAR
    density_name: [READ] array [tape_densities] of string (8) := [
          {} 'rmc$200',
          {} 'rmc$556',
          {} 'rmc$800',
          {} 'rmc$1600',
          {} 'rmc$6250'];

  TYPE
    tape_classes = rmc$mt7 .. rmc$mt9;

  VAR
    class_name: [READ] array [tape_classes] of string (8) := [
          {} 'rmc$mt7',
          {} 'rmc$mt9'];

  PROCEDURE [XDCL, #GATE] amp$log_keyed_file_backup
    (    saved_file_path: fst$path;
         saved_file_global_name: ost$binary_unique_name;
         backup_information: amt$backup_information;
         volume_list: rmt$volume_list;
     VAR status: ost$status);

    VAR
      i: integer;

    display (saved_file_path (1, 125));
    IF backup_information.media = rmc$magnetic_tape_device THEN
      display (' ---- tape backup ---- ');
      display (class_name [backup_information.class]);
      display (density_name [backup_information.density]);
      FOR i :=  LOWERBOUND (volume_list) TO UPPERBOUND (volume_list) DO
        display_integer (' -- vsn (recorded, external) ', i);
        display (volume_list [i].recorded_vsn);
        display (volume_list [i].external_vsn);
      FOREND;
    ELSE
      display (' ---- ms backup ---- ');
      display (backup_information.file_path (1, 125));
    IFEND;
    status.normal := TRUE;
  PROCEND amp$log_keyed_file_backup;
MODEND pum$log_keyed_file_backup_stub;

*DECK DECK=PUM$MANAGE_BACKUP_FILE_IO EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? TITLE := '  NOS/VE Backup/Restore Utilities:  manage_backup_file_io', EJECT ??
MODULE pum$manage_backup_file_io;
{
{  PURPOSE:
{    This module manages interfaces to the access method to read or write the
{  backup file.
{
?? NEWTITLE := '    Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amp$close
*copyc amp$close_volume
*copyc amp$fetch
*copyc amp$fetch_access_information
*copyc amp$file
*copyc amp$get_file_attributes
*copyc amp$get_next
*copyc amp$get_partial
*copyc amp$put_next
*copyc amp$put_partial
*copyc amp$rewind
*copyc amp$skip
*copyc amp$skip_tape_marks
*copyc amp$write_end_partition
*copyc amp$write_tape_mark
*copyc amt$backup_information
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_str_to_path_handle
*copyc clp$get_fs_path_string
*copyc clp$scan_parameter_list
*copyc dme$tape_errors
*copyc fmp$get_files_volume_info
*copyc fsp$close_file
*copyc fsp$get_tape_label_attributes
*copyc fsp$open_file
*copyc fsp$set_file_reference_abnormal
*copyc fst$goi_object_information
*copyc fst$tape_attachment_information
*copyc osd$integer_limits
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$translate_bytes
*copyc ost$name
*copyc pfp$get_object_information
*copyc pfp$put_family_info
*copyc pfp$put_item_info
*copyc pfp$put_master_catalog_info
*copyc pud$backup_file
*copyc pud$hierarchy_list
*copyc pue$error_condition_codes
*copyc pup$allow_job_termination
*copyc pup$build_new_online_cat_head
*copyc pup$compare_item_descriptor
*copyc pup$compare_item_descriptor
*copyc pup$crack_boolean
*copyc pup$determine_if_item_exists
*copyc pup$display_blank_lines
*copyc pup$display_integer
*copyc pup$display_item_descriptor
*copyc pup$display_line
*copyc pup$fetch_backup_label_type
*copyc pup$get_file_password
*copyc pup$restore_cycle_item
*copyc pup$write_os_status
*copyc pup$write_path
*copyc pus$literals
*copyc put$file_identifier
*copyc put$file_position
*copyc put$global_backup_file_id
*copyc put$operation
*copyc puv$backup_file_id
*copyc puv$backup_information
*copyc puv$prev_open_by_$backup_file
*copyc puv$trace_selected
*copyc rmt$device_class
?? POP ??

?? EJECT ??
?? TITLE := '    Global Variables', EJECT ??

  VAR
    puv$allow_rtbt_test: boolean := FALSE,
    puv$global_backup_file_id: [XDCL] put$global_backup_file_id := [FALSE],
    puv$last_volume_number: [XDCL] amt$volume_number := 1,
    puv$volumes_switched_forward: [XDCL] boolean := FALSE;

  VAR
    backup_file_info_request: [pus$literals, READ] fst$goi_information_request :=
      [[fsc$specific_depth, 1], [fsc$goi_job_environment_info]],
    skipped_tape_mark: boolean := FALSE,
    volume_position_table: [pus$literals, READ] array [amt$volume_position] of string (25) := [
      'AMC$AFTER_DATA_BLOCK', 'AMC$AFTER_TAPE_MARK', 'AMC$BEFORE_TAPEMARK', 'AMC$BOV', 'AMC$EOV',
      'AMC$MID_BOV_LABEL_GROUP', 'AMC$MID_EOF_LABEL_GROUP', 'AMC$MID_EOV_LABEL_GROUP',
      'AMC$MID_HDR_LABEL_GROUP', 'AMC$POSITION_UNCERTAIN'];

?? TITLE := '    [XDCL] pup$allow_rtbt_test', EJECT ??

  PROCEDURE [XDCL] pup$allow_rtbt_test (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{
{ This allows specifying record or block types other than those normally used
{ by backup and restore.  This should be used only for TESTING.
{

{ pdt rtbt_test_pdt (selection, s: boolean = true
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      rtbt_test_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^rtbt_test_pdt_names,
        ^rtbt_test_pdt_params];

    VAR
      rtbt_test_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['SELECTION', 1], ['S', 1], ['STATUS', 2]];

    VAR
      rtbt_test_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ SELECTION S }
      [[clc$optional_with_default, ^rtbt_test_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$boolean_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      rtbt_test_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

?? POP ??

    clp$scan_parameter_list (parameter_list, rtbt_test_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_boolean ('SELECTION', puv$allow_rtbt_test, status);
  PROCEND pup$allow_rtbt_test;

?? TITLE := '    [XDCL] pup$close_backup_file', EJECT ??

  PROCEDURE [XDCL] pup$close_backup_file
   (VAR file_id: put$file_identifier;
    VAR status: ost$status);

    display (' Enter pup$close backup file');

    IF puv$global_backup_file_id.backup_file_open THEN
      fsp$close_file (file_id.file_id, status);
      display_status (status);
    IFEND;

    IF file_id.operation = puc$$backup_file THEN
      puv$prev_open_by_$backup_file := TRUE;
    ELSE
      puv$prev_open_by_$backup_file := FALSE;
    IFEND;

    puv$global_backup_file_id.backup_file_open := FALSE;
  PROCEND pup$close_backup_file;

?? TITLE := '    [XDCL] pup$close_volume', EJECT ??

  PROCEDURE [XDCL] pup$close_volume (
        parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT close_volume_pdt (
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    close_volume_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^close_volume_pdt_names,
  ^close_volume_pdt_params];

  VAR
    close_volume_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
  clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    close_volume_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor
  := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    clp$scan_parameter_list (parameter_list, close_volume_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display (' Enter pup$close_volume');
    amp$close_volume (puv$backup_file_id.file_id, status);

  PROCEND pup$close_volume;

?? TITLE := '    determine_backup_file_attr', EJECT ??

  PROCEDURE determine_backup_file_attr
    (VAR file_id: {input, output} put$file_identifier;
     VAR mandated_creation_attributes: ^fst$file_cycle_attributes;
     VAR file_attachment: ^fst$attachment_options;
     VAR attribute_validation: ^fst$file_cycle_attributes;
     VAR backup_file_phn: fst$path_handle_name;
     VAR status: ost$status);

{ This routine determines the device class of a file and file attributes of the backup file.

    CONST
      file_connections = 15, {generous limit for estimating size of sequence}

      {target file attribute array indices:
      tf_bt = 1,
      tf_dc = 2,
      tf_fc = 3,
      tf_flt = 4,
      tf_rt = 5,

     {file attachment array indices:
      amsm =1 {access and share modes},
      osm = 2 {open share modes},
      pr = 3  {private read},
      cf = 4  {create file},
      op = 5  {open position},
      fsp = 6 {file set position},
      rl = 7  {rewrite labels},

     {file cycle attribute array indices:
      bt = 1    {block type},
      rt = 2    {record type},
      flt = 3   {file label type},
      fcfp = 4  {file contents and processor};

    VAR
      backup_file_path: fst$path,
      backup_file_path_size: fst$path_size,
      connected_files_list: ^fst$target_file_list,
      contains_data: boolean,
      evaluated_file_reference: fst$evaluated_file_reference,
      file_attributes: array [1 .. 5] of amt$get_item,
      file_previously_opened: boolean,
      ignore_path_handle: fmt$path_handle,
      ignore_returned_attributes: fst$tla_returned_attributes,
      index: ost$positive_integers,
      information_request: fst$goi_information_request,
      local_file: boolean,
      local_status: ost$status,
      p_object_info_seq: ^SEQ ( * ),
      p_object_information: ^fst$goi_object_information,
      true_device_class: rmt$device_class;

    display (' amp$get_file_attributes');
    file_attributes [1].key := amc$label_type;
    file_attributes [2].key := amc$open_position;
    file_attributes [3].key := amc$device_class;
    file_attributes [4].key := amc$null_attribute;
    file_attributes [5].key := amc$null_attribute;
    amp$get_file_attributes (file_id.lfn, file_attributes, local_file, file_previously_opened,
          contains_data, status);
    IF status.normal THEN
      file_id.label_type := file_attributes [1].label_type;
      file_id.open_position := file_attributes [2].open_position;
      file_id.device_class := file_attributes [3].device_class;

      true_device_class := file_attributes [3].device_class;
      backup_file_phn := file_id.lfn;

      CASE file_id.device_class OF
      = rmc$mass_storage_device =
        display ('   MASS_STORAGE');
        file_id.record_type := amc$variable;
      = rmc$magnetic_tape_device =
        display ('   TAPE');
        IF file_id.label_type = amc$unlabelled THEN
          file_id.record_type := amc$undefined;
        ELSE
          file_id.record_type := amc$variable;
        IFEND;
      = rmc$null_device =
        display ('   NULL');
        file_id.record_type := amc$variable;
      = rmc$connected_file_device =
        display ('   CONNECTED_FILE_DEVICE');
        PUSH p_object_info_seq: [[REP #SIZE(fst$goi_object_information) OF cell,
              REP fsc$max_path_size OF cell, REP #SIZE (fst$goi_object) OF cell,
              REP #SIZE (fst$job_environment_information) OF cell,
              REP (file_connections * #SIZE (fst$path)) OF cell]];
        information_request := backup_file_info_request;
        pfp$get_object_information (file_id.lfn, information_request, NIL, p_object_info_seq, status);
        IF NOT status.normal THEN
          display_status (status);
          RETURN;
        IFEND;
        RESET p_object_info_seq;
        NEXT p_object_information IN p_object_info_seq;
        IF (p_object_information <> NIL) AND (p_object_information^.object <> NIL) AND
              (p_object_information^.object^.job_environment_information <> NIL) AND
              (p_object_information^.object^.job_environment_information^.connected_files <> NIL) THEN
          connected_files_list := p_object_information^.object^.job_environment_information^.connected_files;
          file_attributes [tf_bt].key := amc$block_type;
          file_attributes [tf_dc].key := amc$device_class;
          file_attributes [tf_fc].key := amc$file_contents;
          file_attributes [tf_flt].key := amc$label_type;
          file_attributes [tf_rt].key := amc$record_type;
          FOR index := 1 TO UPPERBOUND (connected_files_list^) DO
            amp$get_file_attributes (connected_files_list^ [index], file_attributes, local_file,
                  file_previously_opened, contains_data, status);
            IF status.normal THEN
              IF index = 1 THEN
                file_id.device_class := file_attributes [tf_dc].device_class;
                file_id.label_type := file_attributes [tf_flt].label_type;
                CASE file_id.device_class OF
                = rmc$magnetic_tape_device =
                  IF file_id.label_type = amc$unlabeled THEN
                    file_id.record_type := amc$undefined;
                  ELSE
                    file_id.record_type := amc$variable;
                  IFEND;
                = rmc$mass_storage_device, rmc$null_device =
                  file_id.record_type := amc$variable;
                ELSE
                  osp$set_status_condition (pue$invalid_device_type, status);
                  osp$append_status_file (osc$status_parameter_delimiter, connected_files_list^ [index],
                        status);
                CASEND;
              ELSE
                IF file_attributes [tf_dc].device_class = file_id.device_class THEN
                  IF (file_attributes [tf_dc].device_class = rmc$magnetic_tape_device) AND
                        (file_attributes [tf_flt].label_type <> file_id.label_type) THEN
                    osp$set_status_condition (pue$invalid_file_connection, status);
                    clp$get_fs_path_string (file_id.lfn, backup_file_path, backup_file_path_size,
                          ignore_path_handle, local_status);
                    osp$append_status_file (osc$status_parameter_delimiter,
                          backup_file_path (1, backup_file_path_size), status);
                  IFEND;
                ELSE
                  osp$set_status_condition (pue$invalid_file_connection, status);
                  clp$get_fs_path_string (file_id.lfn, backup_file_path, backup_file_path_size,
                        ignore_path_handle, local_status);
                  osp$append_status_file (osc$status_parameter_delimiter,
                        backup_file_path (1, backup_file_path_size), status);
                IFEND;
              IFEND;
            IFEND;
            IF ((file_id.device_class = rmc$mass_storage_device) OR
                  ((file_id.device_class = rmc$magnetic_tape_device) AND
                  (file_id.label_type = amc$unlabeled) AND (file_id.record_type = amc$undefined))) AND
                  (file_attributes [tf_bt].block_type <> amc$system_specified) THEN
              osp$set_status_condition (pue$invalid_file_connection, status);
              clp$get_fs_path_string (file_id.lfn, backup_file_path, backup_file_path_size,
                    ignore_path_handle, local_status);
              osp$append_status_file (osc$status_parameter_delimiter,
                    backup_file_path (1, backup_file_path_size), status);
            IFEND;
            IF NOT status.normal THEN
              display_status (status);
              RETURN;
            IFEND;
          FOREND;

{ Convert the oldest target file path to a path handle name for input to pup$fetch_backup_information

          clp$convert_str_to_path_handle (connected_files_list^ [UPPERBOUND (connected_files_list^)],
                {delete_allowed} FALSE, {resolve_path} TRUE, {include_open_pos_in_handle} FALSE,
                backup_file_phn, evaluated_file_reference, status);
          IF NOT status.normal THEN
            display_status (status);
            RETURN;
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (pue$invalid_device_type, status);
        clp$get_fs_path_string (file_id.lfn, backup_file_path, backup_file_path_size, ignore_path_handle,
              local_status);
        osp$append_status_file (osc$status_parameter_delimiter, backup_file_path (1, backup_file_path_size),
              status);
        display_status (status);
      CASEND;

      IF file_id.device_class = rmc$magnetic_tape_device THEN
        IF file_id.record_type = amc$undefined THEN
          mandated_creation_attributes^[bt].selector := fsc$block_type;
          mandated_creation_attributes^[bt].block_type := amc$system_specified;
        ELSEIF file_id.record_type = amc$variable THEN
          mandated_creation_attributes^[bt].selector := fsc$null_attribute;
        IFEND;
        mandated_creation_attributes^[flt].selector := fsc$file_label_type;
        mandated_creation_attributes^[flt].file_label_type := file_id.label_type;
      ELSE
        mandated_creation_attributes^[bt].selector := fsc$block_type;
        mandated_creation_attributes^[bt].block_type := amc$system_specified;
        mandated_creation_attributes^[flt].selector := fsc$null_attribute;
      IFEND;
      mandated_creation_attributes^[rt].selector := fsc$record_type;
      mandated_creation_attributes^[rt].record_type := file_id.record_type;
      mandated_creation_attributes^[fcfp].selector := fsc$file_contents_and_processor;
      mandated_creation_attributes^[fcfp].file_contents := 'FILE_BACKUP';
      mandated_creation_attributes^[fcfp].file_processor := osc$null_name;

      IF file_id.device_class = rmc$magnetic_tape_device THEN
        IF file_id.record_type = amc$undefined THEN
          attribute_validation^[bt].selector := fsc$block_type;
          attribute_validation^[bt].block_type := amc$system_specified;
        ELSEIF file_id.record_type = amc$variable THEN
          attribute_validation^[bt].selector := fsc$null_attribute;
        IFEND;
      ELSE
        attribute_validation^[bt].selector := fsc$block_type;
        attribute_validation^[bt].block_type := amc$system_specified;
      IFEND;
      attribute_validation^[rt].selector := fsc$record_type;
      attribute_validation^[rt].record_type := file_id.record_type;
      attribute_validation^[flt].selector := fsc$null_attribute;

      file_attachment^[amsm].selector := fsc$access_and_share_modes;
      file_attachment^[amsm].access_modes.selector := fsc$specific_access_modes;
      file_attachment^[amsm].share_modes.selector := fsc$specific_share_modes;
      file_attachment^[osm].selector := fsc$open_share_modes;
      file_attachment^[pr].selector := fsc$private_read;
      file_attachment^[cf].selector := fsc$create_file;
      file_attachment^[op].selector := fsc$open_position;
      file_attachment^[fsp].selector := fsc$null_attachment_option;
      file_attachment^[rl].selector := fsc$null_attachment_option;

      IF file_id.operation = puc$backup_permanent_files THEN

        file_attachment^[pr].selector := fsc$null_attachment_option;
        file_attachment^[cf].create_file := TRUE;
        file_attachment^[op].open_position := file_id.open_position;
        CASE true_device_class OF
          = rmc$null_device =
            file_attachment^[amsm].access_modes.value :=
                $fst$file_access_options [fsc$read, fsc$append, fsc$shorten];
            file_attachment^[amsm].share_modes.value := $fst$file_access_options [];
            file_attachment^[osm].open_share_modes := -$fst$file_access_options [];

          = rmc$connected_file_device, rmc$mass_storage_device =
            file_attachment^[amsm].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
            file_attachment^[amsm].share_modes.value := $fst$file_access_options [];
            file_attachment^[osm].open_share_modes := $fst$file_access_options [];

          = rmc$magnetic_tape_device =
            file_attachment^[amsm].access_modes.value := $fst$file_access_options [fsc$append, fsc$shorten];
            file_attachment^[amsm].share_modes.value := $fst$file_access_options [];
            file_attachment^[osm].open_share_modes := $fst$file_access_options [fsc$read];
            file_attachment^[fsp].selector := fsc$tape_attachment;
            file_attachment^[fsp].tape_attachment.selector := fsc$tape_file_set_position;
            file_attachment^[fsp].tape_attachment.tape_file_set_position.position :=
                  fsc$tape_beginning_of_set;
            file_attachment^[rl].selector := fsc$tape_attachment;
            file_attachment^[rl].tape_attachment.selector := fsc$tape_rewrite_labels;
            file_attachment^[rl].tape_attachment.tape_rewrite_labels := (file_id.open_position =
                amc$open_at_boi);

            {A CHATLA command overrides the above defaults}

            fsp$get_tape_label_attributes (file_id.lfn, fsc$tla_explicit_specification, file_attachment^,
                  ignore_returned_attributes, local_status);
        ELSE
        CASEND;
      ELSE

        file_attachment^[cf].create_file := FALSE;
        file_attachment^[op].open_position := file_id.open_position;
        CASE true_device_class OF
          = rmc$null_device =
            file_attachment^[amsm].access_modes.value := $fst$file_access_options [fsc$read];
            file_attachment^[amsm].share_modes.value := $fst$file_access_options [fsc$read];
            file_attachment^[osm].open_share_modes := -$fst$file_access_options [];
            file_attachment^[pr].private_read := FALSE;

          = rmc$mass_storage_device =
            file_attachment^[amsm].access_modes.value := $fst$file_access_options [fsc$read];
            file_attachment^[amsm].share_modes.value := $fst$file_access_options [fsc$read, fsc$execute];
            file_attachment^[osm].open_share_modes :=
                $fst$file_access_options [fsc$read, fsc$append, fsc$shorten];
            file_attachment^[pr].private_read := FALSE;

          = rmc$magnetic_tape_device =
            file_attachment^[amsm].access_modes.value := $fst$file_access_options [fsc$read];
            file_attachment^[amsm].share_modes.value := $fst$file_access_options [];
            file_attachment^[osm].open_share_modes :=
                $fst$file_access_options [fsc$read, fsc$append, fsc$shorten];
            file_attachment^[pr].private_read := TRUE;
            file_attachment^[fsp].selector := fsc$tape_attachment;
            file_attachment^[fsp].tape_attachment.selector := fsc$tape_file_set_position;
            file_attachment^[fsp].tape_attachment.tape_file_set_position.position :=
                  fsc$tape_beginning_of_set;
            file_attachment^[rl].selector := fsc$tape_attachment;
            file_attachment^[rl].tape_attachment.selector := fsc$tape_rewrite_labels;
            file_attachment^[rl].tape_attachment.tape_rewrite_labels := FALSE;

            {A CHATLA command overrides the above defaults}

            fsp$get_tape_label_attributes (file_id.lfn, fsc$tla_explicit_specification, file_attachment^,
                  ignore_returned_attributes, local_status);

            IF puv$prev_open_by_$backup_file THEN
              file_attachment^[fsp].tape_attachment.tape_file_set_position.position :=
                    fsc$tape_current_file;
            IFEND;
        ELSE
        CASEND;
      IFEND;

    ELSE
      display_status (status);
      file_id.device_class := rmc$mass_storage_device;
      file_id.label_type := amc$labelled;
      file_id.open_position := amc$open_at_boi;
    IFEND;

  PROCEND determine_backup_file_attr;

?? TITLE := '    [XDCL] pup$display_volume_switch', EJECT ??

  PROCEDURE [XDCL] pup$display_volume_switch (backup_file_id: put$file_identifier);

{ This procedure displays the external and recorded vsn of the current volume if
{ a volume switch has occurred.

    VAR
      current_volume: rmt$recorded_vsn,
      current_volume_number: amt$volume_number,
      local_status: ost$status,
      outputline: string (80),
      outputline_index: integer,
      status: ost$status,
      volume_description: rmt$volume_descriptor;

    fetch_volume_number (backup_file_id, current_volume_number);
    puv$volumes_switched_forward := (current_volume_number > puv$last_volume_number);
    IF current_volume_number <> puv$last_volume_number THEN
      puv$last_volume_number := current_volume_number;
      pup$display_blank_lines (6, local_status);
      STRINGREP (outputline, outputline_index, ' NOW ON TAPE NUMBER: ', puv$last_volume_number);
      get_volume_description (backup_file_id.file_id, current_volume_number, volume_description, status);
      IF status.normal THEN
        STRINGREP (outputline, outputline_index, outputline (1, outputline_index), '      EXTERNAL VSN: ',
              volume_description.external_vsn);
      ELSE
        display_status (status);
      IFEND;

      IF backup_file_id.label_type <> amc$unlabelled THEN
        STRINGREP (outputline, outputline_index, outputline (1, outputline_index), '      RECORDED VSN: ',
              volume_description.recorded_vsn);
        pup$display_line ('******************************************************************************',
              local_status);
        pup$display_line (outputline (1, outputline_index), local_status);
        pup$display_line ('******************************************************************************',
              local_status);
      ELSE
        pup$display_line ('****************************************************', local_status);
        pup$display_line (outputline (1, outputline_index), local_status);
        pup$display_line ('****************************************************', local_status);
      IFEND;
      pup$display_blank_lines (6, local_status);
    IFEND;
  PROCEND pup$display_volume_switch;

?? TITLE := '    [XDCL] pup$fetch_backup_information', EJECT ??

  PROCEDURE [XDCL] pup$fetch_backup_information
    (    device_class: rmt$device_class;
         backup_file_phn: fst$path_handle_name;
     VAR backup_information: amt$backup_information;
     VAR status: ost$status);

    CONST
      command_file_reference_allowed = TRUE,
      include_open_position = TRUE,
      record_path = TRUE,
      resolve_to_catalog = TRUE;

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      file_registered: boolean,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      ignore_status: ost$status,
      p_path: ^pft$path,
      path_handle_name: fst$path_handle_name,
      path_resolution: fst$path_resolution,
      tape_volume_info: array [1 .. 2] of fmt$volume_info,
      temporary_file: boolean;

    backup_information.media := device_class;

    CASE device_class OF
    = rmc$mass_storage_device =
      clp$convert_str_to_path_handle (backup_file_phn, {delete_allowed =} TRUE,
            {resolve_path =} TRUE, NOT include_open_position, path_handle_name, evaluated_file_reference,
            status);
      IF status.normal THEN
        clp$convert_file_ref_to_string (evaluated_file_reference, NOT include_open_position, fs_path,
              fs_path_size, ignore_status);
        backup_information.file_path := fs_path (1, fs_path_size);
      IFEND;

    = rmc$magnetic_tape_device =
      tape_volume_info [1].key := fmc$tape_class;
      tape_volume_info [2].key := fmc$tape_density;
      fmp$get_files_volume_info (backup_file_phn, tape_volume_info, status);
      IF NOT status.normal THEN
        RETURN
      IFEND;
      backup_information.class := tape_volume_info [1].tape_class;
      backup_information.density := tape_volume_info [2].tape_density;
    ELSE
    CASEND;
  PROCEND pup$fetch_backup_information;

?? TITLE := '    [XDCL] pup$fetch_current_volume', EJECT ??

  PROCEDURE [XDCL] pup$fetch_current_volume
    (   backup_file_id: put$file_identifier;
     VAR volume_number: amt$volume_number;
     VAR volume_description: rmt$volume_descriptor;
     VAR status: ost$status);

    fetch_volume_number (backup_file_id, volume_number);
    get_volume_description (backup_file_id.file_id, volume_number, volume_description, status);
  PROCEND pup$fetch_current_volume;

?? TITLE := '    [XDCL] pup$get_part', EJECT ??
*copyc puh$get_part

  PROCEDURE [XDCL] pup$get_part
    (VAR backup_file_id: put$file_identifier {source} ;
         wsa: ^cell {destination} ;
         working_storage_length: amt$working_storage_length;
     VAR file_position: put$file_position;
     VAR transfer_count: amt$file_length;
     VAR status: ost$status);

    VAR
      bam_file_position: amt$file_position,
      partial_transfer_count: amt$transfer_count,
      previous_status: ost$status;

    transfer_count := 0;

    get_partial (backup_file_id, wsa, working_storage_length, partial_transfer_count, bam_file_position,
          file_position, status);
    IF status.normal THEN
      transfer_count := partial_transfer_count;
      IF partial_transfer_count <> working_storage_length THEN
        display (' **** mismatch on transfer count ****');
        osp$set_status_abnormal (puc$pf_utility_id, pue$unusable_restore_file,
              ' data lost, requested (bytes):', status);
        osp$append_status_integer (osc$status_parameter_delimiter, working_storage_length, 10, FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, '  actually received:', status);
        osp$append_status_integer (osc$status_parameter_delimiter, partial_transfer_count, 10, FALSE, status);
        IF (partial_transfer_count <= 0) AND (bam_file_position = amc$eoi) AND (file_position <> puc$eoi) THEN
          { Tape file: Attempt to force end_of_volume.
          previous_status := status;
          get_partial (backup_file_id, wsa, working_storage_length, partial_transfer_count, bam_file_position,
                file_position, status);
          IF status.normal AND (file_position <> puc$eoi) AND ((NOT puv$volumes_switched_forward) OR
                (working_storage_length <> #SIZE (put$backup_file_version_name))) THEN
            pup$write_os_status (previous_status, status);
            pup$display_line (' Unexpected volume position after 0 transfer count.', status);
            IF partial_transfer_count <> working_storage_length THEN
              display (' **** mismatch on transfer count ****');
              osp$set_status_abnormal (puc$pf_utility_id, pue$unusable_restore_file,
                    ' data lost, requested (bytes):', status);
              osp$append_status_integer (osc$status_parameter_delimiter, working_storage_length, 10, FALSE,
                    status);
              osp$append_status_parameter (osc$status_parameter_delimiter, '  actually received:', status);
              osp$append_status_integer (osc$status_parameter_delimiter, partial_transfer_count, 10, FALSE,
                    status);
            IFEND;
          IFEND;
        IFEND
      IFEND;
    IFEND;
  PROCEND pup$get_part;

?? TITLE := '    [XDCL] pup$open_backup_file', EJECT ??
*copy puh$open_backup_file

  PROCEDURE [XDCL] pup$open_backup_file (backup_file_lfn: amt$local_file_name;
        operation: put$operation;
        open_position: amt$open_position;
    VAR file_id: put$file_identifier;
    VAR status: ost$status);

    CONST
      av_max = 3,
      fa_max = 7,
      mca_max = 4;

    VAR
      attribute_validation: ^fst$file_cycle_attributes,
      backup_file_efr: fst$evaluated_file_reference,
      backup_file_phn: fst$path_handle_name,
      byte_address: amt$file_byte_address,
      default_creation_attributes: ^fst$file_cycle_attributes,
      fetch_attributes: array [1 .. 1] of amt$fetch_item,
      file_attachment: ^fst$attachment_options,
      file_position: amt$file_position,
      ignore_status: ost$status,
      mandated_creation_attributes: ^fst$file_cycle_attributes,
      os_status: ost$error,
      transfer_count: amt$transfer_count,
      volume_description: rmt$volume_descriptor;

    display (' pup$open_backup_file');
    file_id.lfn := backup_file_lfn;
    file_id.operation := operation;

    PUSH mandated_creation_attributes: [1 .. mca_max];
    PUSH file_attachment: [1 .. fa_max];
    PUSH attribute_validation: [1 .. av_max];

    determine_backup_file_attr (file_id, mandated_creation_attributes, file_attachment,
          attribute_validation, backup_file_phn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    default_creation_attributes := NIL;

    IF puv$global_backup_file_id.backup_file_open THEN
      display (' Close backup file prior to open.');
      pup$close_backup_file (puv$global_backup_file_id.backup_file_id, status);
    IFEND;

    display_open_position (file_id.open_position);
    display (' fsp$open_file backup_file');
    fsp$open_file (backup_file_lfn, {access_level} amc$record, file_attachment,
        default_creation_attributes, mandated_creation_attributes, attribute_validation,
        {override_attributes} NIL, file_id.file_id, status);
    display_status (status);
    puv$global_backup_file_id.backup_file_open := status.normal;
    IF puv$global_backup_file_id.backup_file_open THEN
      puv$global_backup_file_id.backup_file_id := file_id;
      pup$fetch_backup_information (file_id.device_class, backup_file_phn, puv$backup_information, status);
    IFEND;

    IF status.normal THEN
      display_integer (' backup_file_id.ordinal:', file_id.file_id.ordinal);
    IFEND;

  PROCEND pup$open_backup_file;

?? TITLE := '    [XDCL] pup$put_next', EJECT ??

  PROCEDURE [XDCL] pup$put_next (VAR file_id: put$file_identifier;
        wsa: ^cell;
        wsl: amt$working_storage_length;
    VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      local_status: ost$status;

    display_integer (' *** amp$put_next wsl: ', wsl);

    amp$put_next (file_id.file_id, wsa, wsl, byte_address, local_status);
    IF local_status.normal THEN
      display_integer ('     STATUS NORMAL byte address: ', byte_address);
    ELSE
      display_status (local_status);
    IFEND;
    process_write_status (local_status, file_id, status);
  PROCEND pup$put_next;

?? TITLE := '    [XDCL] pup$put_partial', EJECT ??

  PROCEDURE [XDCL] pup$put_partial (VAR file_id: put$file_identifier;
        wsa: ^cell;
        wsl: amt$working_storage_length;
        term_option: amt$term_option;
    VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      local_status: ost$status;

    display_integer (' *** amp$put_partial wsl: ', wsl);
    display_term_option (term_option);
    amp$put_partial (file_id.file_id, wsa, wsl, byte_address, term_option, local_status);
    IF local_status.normal THEN
      display_integer ('     STATUS NORMAL byte address: ', byte_address);
    ELSE
      display_status (local_status);
    IFEND;
    process_write_status (local_status, file_id, status);
  PROCEND pup$put_partial;

?? TITLE := '    [XDCL] pup$skip_logical_partition', EJECT ??
*copy puh$skip_logical_partition

  PROCEDURE [XDCL] pup$skip_logical_partition (VAR backup_file_id: put$file_identifier;
    VAR file_position: put$file_position;
    VAR status: ost$status);

    VAR
      bam_file_position: amt$file_position,
      local_status: ost$status,
      tape_failure_isolation: amt$tape_failure_isolation,
      volume_position: amt$volume_position;

    display (' *** pup$skip_logical_partition');
    pup$allow_job_termination;

    CASE backup_file_id.device_class OF
    = rmc$mass_storage_device, rmc$null_device =
      display ('     amp$skip amc$forward amc$skip_partition');
      amp$skip (backup_file_id.file_id, amc$forward, amc$skip_partition, {skip_count =} 0, bam_file_position,
            status);
      display_status (status);
      IF status.normal THEN
        convert_to_logical_position (backup_file_id, bam_file_position, file_position, status);
      ELSEIF status.condition = ame$skip_encountered_eoi THEN
        file_position := puc$eoi;
        status.normal := TRUE;
      IFEND;

    = rmc$magnetic_tape_device =
      IF backup_file_id.label_type = amc$unlabelled THEN
        display ('     amp$skip amc$forward amc$skip_tape_mark 1');
        amp$skip (backup_file_id.file_id, amc$forward, amc$skip_tape_mark, {skip_count =} 1,
            bam_file_position, status);
        display_status (status);
        skipped_tape_mark := TRUE;
        IF status.normal THEN
          { Check if we've skipped into EOV.
          verify_vol_position_after_skip (backup_file_id, file_position, status);
        ELSEIF status.condition = ame$skip_encountered_eoi THEN
          file_position := puc$eoi;
          status.normal := TRUE;
        ELSE { An unexpected error occurred. Close out the tape file and try again.
          pup$write_os_status (status, status);
          pup$display_line (' ----- SKIPPING PAST ERROR', local_status);
          pup$skip_physical_partition (backup_file_id, file_position, status);
          IF status.normal THEN
            pup$display_line (' ----- SKIP SUCCESSFULL', local_status);
          IFEND;
        IFEND;
        IF status.normal THEN
          pup$display_volume_switch (backup_file_id);
        IFEND;
        IF status.normal AND puv$volumes_switched_forward THEN
          { Tapes may have positioned one tape mark too far. Reposition to start
          { of reel.
          display ('     amp$skip amc$backward 3');
          amp$skip (backup_file_id.file_id, amc$backward, amc$skip_tape_mark, {skip_count =} 3,
                bam_file_position, status);
          display_status (status);
          verify_vol_position_after_skip (backup_file_id, file_position, status);
        IFEND;
      ELSE
        /skip_loop/
        WHILE TRUE DO
          display ('     amp$skip amc$forward amc$skip_partition');
          amp$skip (backup_file_id.file_id, amc$forward, amc$skip_partition, {skip_count =} 0,
              bam_file_position, status);
          display_status (status);
          IF status.normal THEN
            pup$display_volume_switch (backup_file_id);
          IFEND;
          IF status.normal THEN
            convert_to_logical_position (backup_file_id, bam_file_position, file_position, status);
            EXIT /skip_loop/;
          ELSEIF status.condition = ame$skip_encountered_eoi THEN
            file_position := puc$eoi;
            status.normal := TRUE;
            EXIT /skip_loop/;
          ELSEIF status.condition = ame$improper_record_header THEN
            pup$display_line (' Record header error - file or catalog information has been lost.',
                local_status);
            pup$write_os_status (status, local_status);
            CYCLE /skip_loop/;
          ELSEIF status.condition = ame$unrecovered_read_error THEN
            fetch_tape_failure_isolation (backup_file_id, tape_failure_isolation);
            IF (tape_failure_isolation.failed_at_current_position) AND
                (amc$tfm_data_parity_error IN tape_failure_isolation.failure_modes) THEN
              pup$display_line (' Unrecovered read error - file or catalog information has been lost.',
                  local_status);
              pup$write_os_status (status, local_status);
              CYCLE /skip_loop/;
            ELSE
              EXIT /skip_loop/;
            IFEND;
          ELSE
              EXIT /skip_loop/;
          IFEND;
        WHILEND /skip_loop/;
      IFEND;
    ELSE
    CASEND;
    display (' end pup$skip_logical_partition');
  PROCEND pup$skip_logical_partition;

?? TITLE := '    [XDCL] pup$skip_physical_partition', EJECT ??

  PROCEDURE [XDCL] pup$skip_physical_partition (VAR backup_file_id: put$file_identifier;
    VAR file_position: put$file_position;
    VAR status: ost$status);

    VAR
      bam_file_position: amt$file_position,
      local_status: ost$status;

    display (' *** pup$skip_physical_partition');
    CASE backup_file_id.device_class OF
    = rmc$mass_storage_device, rmc$null_device =
      pup$skip_logical_partition (backup_file_id, file_position, status);

    = rmc$magnetic_tape_device =
      IF backup_file_id.label_type = amc$unlabelled THEN
        { Use the close, skip, open sequence in this routine so that any error
        { conditions will be reset by the close.
        pup$close_backup_file (backup_file_id, status);
        IF status.normal THEN
          display ('     amp$skip_tape_mark amc$forward 1');
          amp$skip_tape_marks (backup_file_id.lfn, amc$forward, 1, status);
          display_status (status);
          file_position := puc$partition_boundary;
          pup$open_backup_file (backup_file_id.lfn, puc$restore_permanent_files, amc$open_no_positioning,
              backup_file_id, local_status);
          IF status.normal THEN
            status := local_status;
          IFEND;
          IF status.normal THEN
            verify_vol_position_after_skip (backup_file_id, file_position, status);
          IFEND;
        IFEND;
      ELSE
        pup$skip_logical_partition (backup_file_id, file_position, status);
      IFEND;
    ELSE
    CASEND;
    display (' end pup$skip_physical_partition');
  PROCEND pup$skip_physical_partition;

?? TITLE := '    [XDCL] pup$write_logical_partition', EJECT ??

  PROCEDURE [XDCL] pup$write_logical_partition (VAR backup_file_id: put$file_identifier;
    VAR status: ost$status);

    VAR
      local_status: ost$status;

    CASE backup_file_id.device_class OF
    = rmc$mass_storage_device, rmc$null_device =
      display (' *** amp$write_end_partition');
      amp$write_end_partition (backup_file_id.file_id, local_status);

    = rmc$magnetic_tape_device =
      IF backup_file_id.label_type = amc$unlabelled THEN
        display (' *** amp$write_tape_mark ***');
        amp$write_tape_mark (backup_file_id.file_id, local_status);
        IF local_status.normal THEN
          pup$display_volume_switch (backup_file_id);
        IFEND;
      ELSE
        display (' *** amp$write_end_partition');
        amp$write_end_partition (backup_file_id.file_id, local_status);
        IF local_status.normal THEN
          pup$display_volume_switch (backup_file_id);
        IFEND;
      IFEND;
    ELSE
    CASEND;
    display_status (local_status);
    process_write_status (local_status, backup_file_id, status);
    pup$allow_job_termination;
  PROCEND pup$write_logical_partition;


?? TITLE := '    [INLINE] convert_to_logical_position', EJECT ??

  PROCEDURE [INLINE] convert_to_logical_position (file_id: put$file_identifier;
        bam_file_position: amt$file_position;
    VAR utility_file_position: put$file_position;
    VAR status: ost$status);

{ This routine converts a bam file position into a pf utility file position.
{ The pf utility does not use/recognize end-of-record, and for magnetic tape
{ uses a single tapemark as a partition boundary.

    VAR
      ignored_status: ost$status,
      volume_position: amt$volume_position;

    status.normal := TRUE;
    display_file_position (bam_file_position);

    CASE bam_file_position OF
    = amc$boi =
      utility_file_position := puc$boi;

    = amc$bop, amc$eop =
      { Or do these need to be seperated?
      utility_file_position := puc$partition_boundary;

    = amc$mid_record, amc$eor =
      utility_file_position := puc$mid_partition;

    = amc$eoi =
      utility_file_position := puc$eoi;
      IF (file_id.device_class = rmc$magnetic_tape_device) AND
          (file_id.label_type = amc$unlabelled) THEN
        fetch_volume_position (file_id, volume_position, status);
        IF status.normal THEN
          IF volume_position = amc$after_tapemark THEN
            utility_file_position := puc$partition_boundary;
          ELSEIF volume_position = amc$eov THEN
            utility_file_position := puc$eoi;
          ELSE
            utility_file_position := puc$partition_boundary;
            pup$display_line (' ** ERROR ** CONFUSED VOLUME POSITION **', ignored_status);
            pup$display_line (volume_position_table [volume_position], ignored_status);
          IFEND;
        IFEND;
      IFEND;
    ELSE
    CASEND;
  PROCEND convert_to_logical_position;

?? TITLE := '    [INLINE] display_file_position', EJECT ??

  PROCEDURE [INLINE] display_file_position (file_position: amt$file_position);

    CASE file_position OF
    = amc$boi =
      display ('    amc$boi');
    = amc$bop =
      display ('    amc$bop');
    = amc$eop =
      display ('    amc$eop');
    = amc$mid_record =
      display ('    amc$mid_record');
    = amc$eor =
      display ('    amc$eor');
    = amc$eoi =
      display ('    amc$eoi');
    ELSE
      display ('    unknown file position');
    CASEND;
  PROCEND display_file_position;

?? TITLE := '    [INLINE] display_open_position', EJECT ??

  PROCEDURE [INLINE] display_open_position (open_position: amt$open_position);
    CASE open_position OF
    = amc$open_no_positioning =
      display ('    amc$open_no_positioning');
    = amc$open_at_boi =
      display ('    amc$open_at_boi');
    = amc$open_at_eoi =
      display ('    amc$open_at_eoi');
    ELSE
      display ('    unknown open position');
    CASEND;
  PROCEND display_open_position;

?? TITLE := '    [INLINE] display_term_option', EJECT ??

  PROCEDURE [INLINE] display_term_option (term_option: amt$term_option);
    CASE term_option OF
    = amc$start =
      display ('    amc$start');
    = amc$continue =
      display ('    amc$continue');
    = amc$terminate =
      display ('    amc$terminate');
    ELSE
      display ('    unknown term option');
    CASEND;
  PROCEND display_term_option;

?? TITLE := '    [INLINE] display_volume_position', EJECT ??

  PROCEDURE [INLINE] display_volume_position (volume_position: amt$volume_position);

    CASE volume_position OF
    = amc$after_data_block =
      display ('    amc$after_data_block');
    = amc$after_tapemark =
      display ('    amc$after_tapemark');
    = amc$before_tapemark =
      display ('    amc$before_tapemark');
    = amc$bov =
      display ('    amc$bov');
    = amc$eov =
      display ('    amc$eov');
    = amc$mid_bov_label_group =
      display ('    amc$mid_bov_label_group');
    = amc$mid_eof_label_group =
      display ('    amc$mid_eof_label_group');
    = amc$mid_eov_label_group =
      display ('    amc$mid_eov_label_group');
    = amc$mid_hdr_label_group =
      display ('    amc$mid_hdr_label_group');
    = amc$position_uncertain =
      display ('    amc$position_uncertain');
    ELSE
      display ('    unknown volume position');
    CASEND;
  PROCEND display_volume_position;

?? TITLE := '    fetch_volume_number', EJECT ??

  PROCEDURE fetch_volume_number (backup_file_id: put$file_identifier;
    VAR volume_number: amt$volume_number);

    VAR
      access_info: array [1 .. 1] of amt$access_info,
      local_status: ost$status;

    access_info [1].key := amc$volume_number;
    display (' amp$fetch volume_number');
    amp$fetch_access_information (backup_file_id.file_id, access_info, local_status);
    IF local_status.normal THEN
      IF access_info [1].item_returned THEN
        volume_number := access_info [1].volume_number;
      ELSE
        pup$display_line (' VOLUME NUMBER NOT RETURNED FROM FETCH', local_status);
        volume_number := 1;
      IFEND;
    ELSE
      pup$write_os_status (local_status, local_status);
      volume_number := 1;
    IFEND;
    display_integer (' current volume number:', volume_number);
  PROCEND fetch_volume_number;

?? TITLE := '    fetch_volume_position', EJECT ??

  PROCEDURE fetch_volume_position (file_id: put$file_identifier;
    VAR volume_position: amt$volume_position;
    VAR status: ost$status);

    VAR
      p_access_information: ^amt$access_information;

    PUSH p_access_information: [1 .. 1];
    p_access_information^ [1].key := amc$volume_position;
    display (' amp$fetch_access_information amc$volume_position');
    amp$fetch_access_information (file_id.file_id, p_access_information^, status);
    display_status (status);
    IF status.normal THEN
      volume_position := p_access_information^ [1].volume_position;
      display_volume_position (volume_position);
    IFEND;
  PROCEND fetch_volume_position;

?? TITLE := '    fetch_tape_failure_isolation', EJECT ??

  PROCEDURE fetch_tape_failure_isolation (backup_file_id: put$file_identifier;
    VAR tape_failure_isolation: amt$tape_failure_isolation);

    VAR
      access_info: array [1 .. 1] of amt$access_info,
      local_status: ost$status;

    access_info [1].key := amc$tape_failure_isolation;
    display (' amp$fetch tape_failure_isolation');
    amp$fetch_access_information (backup_file_id.file_id, access_info, local_status);
    IF local_status.normal THEN
      IF access_info [1].item_returned THEN
        tape_failure_isolation := access_info [1].tape_failure_isolation;
      ELSE
        pup$display_line (' TAPE FAILURE ISOLATION NOT RETURNED FROM FETCH', local_status);
        tape_failure_isolation.failed_at_current_position := FALSE;
        tape_failure_isolation.failure_modes := $amt$tape_failure_modes[];
      IFEND;
    ELSE
      pup$write_os_status (local_status, local_status);
      tape_failure_isolation.failed_at_current_position := FALSE;
      tape_failure_isolation.failure_modes := $amt$tape_failure_modes[];
    IFEND;
  PROCEND fetch_tape_failure_isolation;


?? TITLE := '    [INLINE] get_partial', EJECT ??

  PROCEDURE [INLINE] get_partial (VAR backup_file_id: put$file_identifier;
        wsa: ^cell;
        working_storage_length: amt$working_storage_length;
    VAR transfer_count: amt$transfer_count;
    VAR bam_file_position: amt$file_position;
    VAR file_position: put$file_position;
    VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      local_status: ost$status,
      record_length: amt$max_record_length;

    display_integer (' *** amp$get_partial wsl: ', working_storage_length);
    bam_file_position := amc$mid_record;
    amp$get_partial (backup_file_id.file_id, wsa, working_storage_length, record_length, transfer_count,
          byte_address, bam_file_position, amc$no_skip, status);
    IF status.normal THEN
      display_integer ('     STATUS NORMAL transfer_count: ', transfer_count);
      display_integer ('     byte_address: ', byte_address);
      display_integer ('     record_length: ', record_length);
    ELSE
      display_status (status);
    IFEND;
    convert_to_logical_position (backup_file_id, bam_file_position, file_position, local_status);
  PROCEND get_partial;

?? TITLE := '    get_volume_description', EJECT ??

  PROCEDURE get_volume_description (
        file_id: amt$file_identifier;
        volume_number: amt$volume_number;
    VAR volume_description: rmt$volume_descriptor;
    VAR status: ost$status);

    VAR
      access_info: array [1 .. 1] of amt$access_info;

    access_info [1].key := amc$volume_description;
    access_info [1].volume_index := volume_number;
    amp$fetch_access_information (file_id, access_info, status);
    IF status.normal THEN
      volume_description := access_info [1].volume_description;
    IFEND;
  PROCEND get_volume_description;

?? TITLE := '    [INLINE] process_write_status', EJECT ??

  PROCEDURE [INLINE] process_write_status
   (    amp_status: ost$status;
    VAR backup_file_id: put$file_identifier;
    VAR pu_status: ost$status);

    VAR
      file_position: amt$file_position,
      ignore_status: ost$status,
      recovery_status: ost$status;

    IF amp_status.normal THEN
      pu_status.normal := TRUE;
    ELSE
      pu_status := amp_status;
      IF pu_status.condition = ame$no_write_ring THEN
        RETURN;
      IFEND;

      IF pu_status.condition = dme$operator_stop THEN
        pup$close_backup_file (backup_file_id, ignore_status);
        RETURN;
      IFEND;

      CASE backup_file_id.device_class OF
      = rmc$magnetic_tape_device =
        pup$close_backup_file (backup_file_id, recovery_status);
        IF NOT recovery_status.normal THEN
          pup$display_line (' Unable to close backup file.', ignore_status);
        IFEND;
      ELSE {null or mass_storage}
        display (' amp$skip amc$backward amc$skip_partition 0');
        amp$skip (backup_file_id.file_id, amc$backward, amc$skip_partition, 0, file_position,
              recovery_status);
      CASEND;

      IF recovery_status.normal THEN
        pup$display_line (' BACKUP GOOD TO PREVIOUS FILE WRITTEN', ignore_status);
      ELSE
        pup$display_line (' Error recovery failed:', ignore_status);
        pup$write_os_status (recovery_status, ignore_status);
        pup$display_line (' CURRENT VOLUME UNUSABLE; PREVIOUS VOLUMES READABLE', ignore_status);
      IFEND;
    IFEND;
  PROCEND process_write_status;

?? TITLE := '    verify_vol_position_after_skip', EJECT ??

  PROCEDURE verify_vol_position_after_skip (backup_file_id: put$file_identifier;
    VAR file_position: put$file_position;
    VAR status: ost$status);

    VAR
      volume_position: amt$volume_position;

    fetch_volume_position (backup_file_id, volume_position, status);
    IF status.normal THEN
      CASE volume_position OF
      = amc$eov =
        file_position := puc$eoi;
      = amc$after_tapemark =
        file_position := puc$partition_boundary;
      ELSE
        file_position := puc$partition_boundary; {tape bug}
      CASEND;
    IFEND;
  PROCEND verify_vol_position_after_skip;
?? SKIP := 2 ??
MODEND pum$manage_backup_file_io;
*DECK DECK=PUM$MANAGE_BACKUP_LABEL_TYPE EXPAND=TRUE
*DECK DECK=PUM$PF_DEBUGGING_AIDES EXPAND=TRUE
?? RIGHT := 110 ??
??
NEWTITLE := ' NOS/VE Backup/Restore Utilities:  pf_debugging_aides ', EJECT ??
MODULE pum$pf_debugging_aides;
{
{  This module contains those subcommands, associated with debugging or
{ displaying information about the permanent file catalog.
{
?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc fmd$volume_info
*copyc ost$caller_identifier
*copyc pfc$null_shared_queue
*copyc pue$error_condition_codes
*copyc rmc$unspecified_allocation_size
*copyc rmc$unspecified_file_class
*copyc rmc$unspecified_file_size
*copyc rmc$unspecified_vsn
?? POP ??
?? EJECT ??
*copyc amp$close
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$set_segment_eoi
*copyc clp$convert_cyc_ref_to_cyc_sel
*copyc clp$evaluate_parameters
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc fmp$get_files_volume_info
*copyc fsp$close_file
*copyc fsp$convert_fs_structure_to_pf
*copyc fsp$evaluate_file_reference
*copyc fsp$open_file
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc pfp$define_catalog
*copyc pfp$define_mass_storage_catalog
*copyc pfp$define_master_catalog
*copyc pfp$detach_jobs_catalogs
*copyc pfp$get_attached_pf_table
*copyc pfp$get_catalog_alarm_table
*copyc pfp$get_catalog_segment
*copyc pfp$get_family_set
*copyc pfp$get_queued_catalog_table
*copyc pfp$get_stored_fmd
*copyc pfp$get_stored_fmd_size
*copyc pfp$purge_master_catalog
*copyc pfp$purge_object
*copyc pfp$put_catalog_segment
*copyc pup$convert_gfn_to_string
*copyc pup$crack_boolean
*copyc pup$crack_catalog
*copyc pup$crack_file
*copyc pup$crack_permanent_file
*copyc pup$crack_pf_file_reference
*copyc pup$display_boolean
*copyc pup$display_fmd
*copyc pup$display_integer
*copyc pup$display_line
*copyc pup$write_os_status
*copyc pup$write_path
*copyc puv$listing_display_control
*copyc rmp$build_mass_storage_info
*copyc stp$display_all_sets
*copyc stp$display_volume

?? TITLE := '  [XDCL] pup$create_ms_catalog_cmnd ', EJECT ??

  PROCEDURE [XDCL] pup$create_ms_catalog_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PDT create_ms_cat_pdt (
{ catalog, c                   : file = $required
{ catalog_type, ct             :   key external, internal = external
{ allocation_size, as          : integer 16384..16777215 = $optional
{ file_class, fc               : name 1 = $optional
{ initial_volume, iv           : name 1..6 = $optional
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      create_ms_cat_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^create_ms_cat_pdt_names, ^create_ms_cat_pdt_params];

    VAR
      create_ms_cat_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 11] of
            clt$parameter_name_descriptor := [['CATALOG', 1], ['C', 1], ['CATALOG_TYPE', 2], ['CT', 2],
            ['ALLOCATION_SIZE', 3], ['AS', 3], ['FILE_CLASS', 4], ['FC', 4], ['INITIAL_VOLUME', 5], ['IV', 5],
            ['STATUS', 6]];

    VAR
      create_ms_cat_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 6] of
            clt$parameter_descriptor := [

{ CATALOG C }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ CATALOG_TYPE CT }
      [[clc$optional_with_default, ^create_ms_cat_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
            [^create_ms_cat_pdt_kv2, clc$keyword_value]],

{ ALLOCATION_SIZE AS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 16384, 16777215]],

{ FILE_CLASS FC }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, 1]],

{ INITIAL_VOLUME IV }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, 6]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      create_ms_cat_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of
            ost$name := ['EXTERNAL', 'INTERNAL'];

    VAR
      create_ms_cat_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (8) := 'external';

?? POP ??

    VAR
      allocation_size: rmt$allocation_size,
      caller_id: ost$caller_identifier,
      catalog_type: pft$catalog_types,
      initial_volume: rmt$recorded_vsn,
      mass_storage_class: rmt$mass_storage_class,
      p_mass_storage_info: ^fmt$mass_storage_request_info,
      p_path: ^pft$path,
      path_container: clt$path_container,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, create_ms_cat_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_catalog ('CATALOG', path_container, p_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('CATALOG_TYPE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.name.value = 'INTERNAL' THEN
      catalog_type := pfc$internal_catalog;
    ELSE
      catalog_type := pfc$external_catalog;

      clp$get_value ('ALLOCATION_SIZE', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.kind = clc$integer_value THEN
        allocation_size := value.int.value;
      ELSE
        allocation_size := rmc$unspecified_allocation_size;
      IFEND;

      clp$get_value ('FILE_CLASS', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.kind = clc$name_value THEN
        mass_storage_class := value.name.value (1);
      ELSE
        mass_storage_class := rmc$unspecified_file_class;
      IFEND;

      clp$get_value ('INITIAL_VOLUME', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.kind = clc$name_value THEN
        initial_volume := value.name.value (1, 6);
      ELSE
        initial_volume := rmc$unspecified_vsn;
      IFEND;
    IFEND;

    #CALLER_ID (caller_id);
    PUSH p_mass_storage_info;
    rmp$build_mass_storage_info (allocation_size, rmc$unspecified_file_size, initial_volume,
          mass_storage_class, {shared_queue} pfc$null_shared_queue, rmc$unspecified_transfer_size,
          {volume_overflow_allowed} FALSE, caller_id.ring,
          p_mass_storage_info, status);
    IF status.normal THEN
      pfp$define_mass_storage_catalog (p_path^, catalog_type, p_mass_storage_info, status);
    IFEND;
  PROCEND pup$create_ms_catalog_cmnd;

?? TITLE := ' [XDCL] pup$defmc_command ', EJECT ??

  PROCEDURE [XDCL] pup$defmc_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

    VAR
      charge_id: pft$charge_id,
      local_status: ost$status,
      p_path: ^pft$path,
      path_container: clt$path_container,
      set_name: stt$set_name;


    crack_master_catalog (parameter_list, path_container, p_path, status);
    IF status.normal THEN
      pup$display_line (' Define master catalog', local_status);
      pup$write_path (p_path^, local_status);
      charge_id.account := '  ';
      charge_id.project := ' ';

      pfp$get_family_set (p_path^ [pfc$family_name_index], set_name, status);
      IF status.normal THEN
        pfp$define_master_catalog (set_name, p_path^ [pfc$family_name_index], p_path^
              [pfc$master_catalog_name_index], charge_id, status);
      IFEND;
      pup$write_os_status (status, local_status);
    IFEND;
  PROCEND pup$defmc_command;

?? TITLE := ' [XDCL] pup$detach_all_catalogs ', EJECT ??
  PROCEDURE [XDCL] pup$detach_all_catalogs
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt detach_all_cats_pdt

?? PUSH (LISTEXT := ON) ??

    VAR
      detach_all_cats_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??

    clp$scan_parameter_list (parameter_list, detach_all_cats_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pfp$detach_jobs_catalogs;
  PROCEND pup$detach_all_catalogs;
?? TITLE := ' [XDCL] pup$display_ast ', EJECT ??

  PROCEDURE [XDCL] pup$display_ast
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt display_ast (status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_ast: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^display_ast_names, ^display_ast_params];

    VAR
      display_ast_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
            clt$parameter_name_descriptor := [['STATUS', 1]];

    VAR
      display_ast_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??
    clp$scan_parameter_list (parameter_list, display_ast, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    stp$display_all_sets (puv$listing_display_control, status);
  PROCEND pup$display_ast;
?? TITLE := ' [XDCL] pup$display_vst ', EJECT ??

  PROCEDURE [XDCL] pup$display_vst
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{  pdt display_vst (recorded_vsn, rvsn: name 1..6=$required
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      display_vst: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^display_vst_names, ^display_vst_params];

    VAR
      display_vst_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['RECORDED_VSN', 1], ['RVSN', 1], ['STATUS', 2]];

    VAR
      display_vst_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ RECORDED_VSN RVSN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, 6]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      recorded_vsn: rmt$recorded_vsn,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, display_vst, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_value ('RECORDED_VSN', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    recorded_vsn := value.name.value (1, 6);
    stp$display_volume (recorded_vsn, puv$listing_display_control, status);
  PROCEND pup$display_vst;

?? TITLE := '    [XDCL] pup$get_attached_pf_table_cm ', EJECT ??

  PROCEDURE [XDCL] pup$get_attached_pf_table_cm (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{  pdt get_attached_pf_table (
{    output, o: file = $required
{    status)

?? PUSH (LISTEXT := ON) ??

    VAR
      get_attached_pf_table: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^get_attached_pf_table_names, ^get_attached_pf_table_params];

    VAR
      get_attached_pf_table_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['OUTPUT', 1], ['O', 1], ['STATUS', 2]];

    VAR
      get_attached_pf_table_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
        clt$parameter_descriptor := [

{ OUTPUT O }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      file_id: amt$file_identifier,
      local_status: ost$status,
      output_file: amt$local_file_name,
      segment_pointer: amt$segment_pointer;

    clp$scan_parameter_list (parameter_list, get_attached_pf_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_file ('OUTPUT', output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (output_file, amc$segment, NIL, file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_id, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET segment_pointer.sequence_pointer;

    pfp$get_attached_pf_table (segment_pointer.sequence_pointer, status);
    IF NOT status.normal THEN
      amp$close (file_id, local_status);
      RETURN;
    IFEND;

    amp$set_segment_eoi (file_id, segment_pointer, status);

    amp$close (file_id, local_status);
  PROCEND pup$get_attached_pf_table_cm;


?? TITLE := '    [XDCL] pup$get_catalog_alarm_table_cm ', EJECT ??

  PROCEDURE [XDCL] pup$get_catalog_alarm_table_cm (parameter_list: clt$parameter_list;
    VAR status: ost$status);



{   pdt get_catalog_alarm_table (
{     output, o: file = $required
{     status)

?? PUSH (LISTEXT := ON) ??

    VAR
      get_catalog_alarm_table: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^get_catalog_alarm_table_names, ^get_catalog_alarm_table_params];

    VAR
      get_catalog_alarm_table_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['OUTPUT', 1], ['O', 1], ['STATUS', 2]];

    VAR
      get_catalog_alarm_table_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
        clt$parameter_descriptor := [

{ OUTPUT O }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      file_id: amt$file_identifier,
      local_status: ost$status,
      output_file: amt$local_file_name,
      segment_pointer: amt$segment_pointer;

    clp$scan_parameter_list (parameter_list, get_catalog_alarm_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_file ('OUTPUT', output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (output_file, amc$segment, NIL, file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_id, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET segment_pointer.sequence_pointer;

    pfp$get_catalog_alarm_table (segment_pointer.sequence_pointer, status);
    IF NOT status.normal THEN
      amp$close (file_id, local_status);
      RETURN;
    IFEND;

    amp$set_segment_eoi (file_id, segment_pointer, status);

    amp$close (file_id, local_status);
  PROCEND pup$get_catalog_alarm_table_cm;



?? TITLE := '    [XDCL] pup$get_catalog_segment_cm ', EJECT ??

  PROCEDURE [XDCL] pup$get_catalog_segment_cm (parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? RIGHT := 110 ??
{ pdt get_catalog_segment_pdt (
{  catalog, c: file = $required
{  output, o: file = $required
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      get_catalog_segment_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^get_catalog_segment_pdt_names, ^get_catalog_segment_pdt_params];

    VAR
      get_catalog_segment_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
        clt$parameter_name_descriptor := [['CATALOG', 1], ['C', 1], ['OUTPUT', 2], ['O', 2], ['STATUS', 3]];

    VAR
      get_catalog_segment_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
        clt$parameter_descriptor := [

{ CATALOG C }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ OUTPUT O }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      file_id: amt$file_identifier,
      local_status: ost$status,
      output_file: amt$local_file_name,
      p_path: ^pft$path,
      path_container: clt$path_container,
      segment_pointer: amt$segment_pointer;

    clp$scan_parameter_list (parameter_list, get_catalog_segment_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_catalog ('CATALOG', path_container, p_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_file ('OUTPUT', output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (output_file, amc$segment, NIL, file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_id, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET segment_pointer.sequence_pointer;

    pfp$get_catalog_segment (p_path^, segment_pointer.sequence_pointer, status);
    IF NOT status.normal THEN
      amp$close (file_id, local_status);
      RETURN;
    IFEND;

    amp$set_segment_eoi (file_id, segment_pointer, status);
    amp$close (file_id, local_status);
  PROCEND pup$get_catalog_segment_cm;

?? TITLE := '    [XDCL] pup$get_file_fmd_cm ', EJECT ??

  PROCEDURE [XDCL] pup$get_file_fmd_cm (parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? RIGHT := 110 ??



{ pdt get_file_fmd_pdt (
{  file, f, catalog, c: file = $required
{  output, o: file = $required
{  format: boolean = true
{  status)

?? PUSH (LISTEXT := ON) ??

  VAR
    get_file_fmd_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^get_file_fmd_pdt_names,
      ^get_file_fmd_pdt_params];

  VAR
    get_file_fmd_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 8] of
      clt$parameter_name_descriptor := [['FILE', 1], ['F', 1], ['CATALOG', 1], ['C', 1], ['OUTPUT', 2], ['O',
      2], ['FORMAT', 3], ['STATUS', 4]];

  VAR
    get_file_fmd_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor
      := [

{ FILE F CATALOG C }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ OUTPUT O }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ FORMAT }
    [[clc$optional_with_default, ^get_file_fmd_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$boolean_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    get_file_fmd_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

?? POP ??
     VAR
      catalog: boolean,
      catalog_recreated: boolean,
      cycle_selector: pft$cycle_selector,
      cycle_specified: boolean,
      device_class: rmt$device_class,
      file_gfn: ost$binary_unique_name,
      file_gfn_string: string (60),
      file_id: amt$file_identifier,
      fmd_size: dmt$stored_fmd_size,
      format: boolean,
      local_status: ost$status,
      output_file: amt$local_file_name,
      p_path: ^pft$path,
      p_table_info: pft$p_table_info,
      path_container: clt$path_container,
      segment_pointer: amt$segment_pointer;

    clp$scan_parameter_list (parameter_list, get_file_fmd_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_permanent_file ('FILE', - $put$cycle_reference_selections [], path_container,
          p_path, cycle_specified, cycle_selector, status);
    IF NOT status.normal THEN
      IF status.condition = pue$path_too_short THEN
        cycle_specified := FALSE;
        pup$crack_catalog ('FILE', path_container, p_path, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    IF NOT cycle_specified THEN
      cycle_selector.cycle_option := pfc$highest_cycle;
    IFEND;

    pup$crack_file ('OUTPUT', output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_boolean ('FORMAT', format, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (output_file, amc$segment, NIL, file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_id, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET segment_pointer.sequence_pointer;

    pfp$get_stored_fmd_size (p_path^, cycle_selector, device_class, file_gfn, fmd_size, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$convert_gfn_to_string (file_gfn, file_gfn_string);
    pup$display_line (' Global file name', status);
    pup$display_line (file_gfn_string, status);

    NEXT p_table_info: [[REP fmd_size OF cell]] IN segment_pointer.sequence_pointer;
    IF p_table_info = NIL THEN
      osp$set_status_abnormal ('GS', 333000, ' Nil p info ', status);
      RETURN;
    IFEND;

    pfp$get_stored_fmd (p_path^, cycle_selector, catalog, catalog_recreated, file_gfn,
        p_table_info^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF catalog THEN
      pup$display_boolean (' CATALOG recreated ', catalog_recreated, status);
    IFEND;

    IF format THEN
      pup$display_fmd (device_class, p_table_info^, 3, status);
    IFEND;

    amp$set_segment_eoi (file_id, segment_pointer, status);

    amp$close (file_id, local_status);
  PROCEND pup$get_file_fmd_cm;


?? TITLE := '    [XDCL] pup$get_file_info ', EJECT ??

  PROCEDURE [XDCL] pup$get_file_info
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PDT get_file_info_pdt (
{   file, f: file = $required
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    get_file_info_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^get_file_info_pdt_names,
      ^get_file_info_pdt_params];

  VAR
    get_file_info_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['FILE', 1], ['F', 1], ['OUTPUT', 2], ['O', 2], ['STATUS', 3]];

  VAR
    get_file_info_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor
      := [

{ FILE F }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ OUTPUT O }
    [[clc$optional_with_default, ^get_file_info_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    get_file_info_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$output';

?? POP ??
    VAR
      current_volume: amt$volume_number,
      file_reference: amt$local_file_name,
      ignore_status: ost$status,
      output_lfn: amt$local_file_name,
      output_line: string(21),
      value: clt$value,
      volume_count: amt$volume_number,
      volume_info: array [1 .. 1] of fmt$volume_info;

    clp$scan_parameter_list (parameter_list, get_file_info_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('FILE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    file_reference := value.file.local_file_name;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output_lfn := value.file.local_file_name;

    output_line := ' Recorded_vsn:       ';
    volume_info [1].key := fmc$number_of_volumes;

    fmp$get_files_volume_info (file_reference, volume_info, status);

    IF status.normal AND volume_info[1].item_returned THEN
      volume_count := volume_info[1].number_of_volumes;
      FOR current_volume := 1 to volume_count DO
        volume_info[1].key := fmc$volume;
        volume_info[1].requested_volume_number := current_volume;

        fmp$get_files_volume_info (file_reference, volume_info, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        output_line(16,6) := volume_info[1].volume.recorded_vsn;
        pup$display_line (output_line, ignore_status);
      FOREND;
    IFEND;
  PROCEND pup$get_file_info;

?? TITLE := '    [XDCL] pup$get_queued_catalog_table_cm ', EJECT ??

  PROCEDURE [XDCL] pup$get_queued_catalog_table_cm (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{  pdt get_queued_catalog_table (
{    output, o: file = $required
{    status)

?? PUSH (LISTEXT := ON) ??

    VAR
      get_queued_catalog_table: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^get_queued_catalog_table_names, ^get_queued_catalog_table_params];

    VAR
      get_queued_catalog_table_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['OUTPUT', 1], ['O', 1], ['STATUS', 2]];

    VAR
      get_queued_catalog_table_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
        clt$parameter_descriptor := [

{ OUTPUT O }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      file_id: amt$file_identifier,
      local_status: ost$status,
      output_file: amt$local_file_name,
      segment_pointer: amt$segment_pointer;

    clp$scan_parameter_list (parameter_list, get_queued_catalog_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_file ('OUTPUT', output_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (output_file, amc$segment, NIL, file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_id, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET segment_pointer.sequence_pointer;

    pfp$get_queued_catalog_table (segment_pointer.sequence_pointer, status);
    IF NOT status.normal THEN
      amp$close (file_id, local_status);
      RETURN;
    IFEND;

    amp$set_segment_eoi (file_id, segment_pointer, status);

    amp$close (file_id, local_status);
  PROCEND pup$get_queued_catalog_table_cm;

?? TITLE := '    [XDCL] pup$display_fmd_cmd ', EJECT ??

  PROCEDURE [XDCL] pup$display_fmd_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE display_fmd (
{     file, f, catalog, c: file = $required
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 3, 5, 14, 50, 25, 252],
    clc$command, 5, 2, 1, 0, 0, 0, 2, ''], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CATALOG                        ',clc$alias_entry, 1],
    ['F                              ',clc$alias_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      catalog: boolean,
      catalog_recreated: boolean,
      cl_cycle_selector: clt$cycle_selector,
      device_class: rmt$device_class,
      evaluated_file_reference: fst$evaluated_file_reference,
      file_gfn: ost$binary_unique_name,
      file_gfn_string: string (60),
      fmd_seq_p: ^SEQ ( * ),
      fmd_size: dmt$stored_fmd_size,
      p_path: ^pft$path,
      p_table_info: pft$p_table_info;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    fsp$evaluate_file_reference (pvt [p$file].value^.file_value^, FALSE
          {NOT command_file_reference_allowed} , evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_path: [1 .. evaluated_file_reference.number_of_path_elements];
    fsp$convert_fs_structure_to_pf (evaluated_file_reference, p_path);

    clp$convert_cyc_ref_to_cyc_sel (evaluated_file_reference.cycle_reference, cl_cycle_selector);

    pfp$get_stored_fmd_size (p_path^, cl_cycle_selector.value, device_class, file_gfn, fmd_size, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH fmd_seq_p: [[REP fmd_size OF cell]];
    RESET fmd_seq_p;

    pup$convert_gfn_to_string (file_gfn, file_gfn_string);
    pup$display_line (' Global file name', status);
    pup$display_line (file_gfn_string, status);

    NEXT p_table_info: [[REP fmd_size OF cell]] IN fmd_seq_p;
    IF p_table_info = NIL THEN
      osp$set_status_abnormal ('GS', 333000, ' Nil p info ', status);
      RETURN;
    IFEND;

    pfp$get_stored_fmd (p_path^, cl_cycle_selector.value, catalog, catalog_recreated, file_gfn, p_table_info^,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF catalog THEN
      pup$display_boolean (' CATALOG recreated ', catalog_recreated, status);
    IFEND;

    pup$display_fmd (device_class, p_table_info^, 3, status);

  PROCEND pup$display_fmd_cmd;


?? TITLE := '    [XDCL] pup$purge_object_cm ', EJECT ??

  PROCEDURE [XDCL] pup$purge_object_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE purge_object (
{    object, o: file = $required
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 4, 4, 10, 6, 25, 78],
    clc$command, 3, 2, 1, 0, 0, 0, 2, ''], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OBJECT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$object = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      cycle_selector_specified: boolean,
      cycle_selector: pft$cycle_selector,
      p_path: ^pft$path,
      path_container: clt$path_container;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_pf_file_reference (pvt [p$object].value^.file_value^,
          $put$cycle_reference_selections [puc$cycle_omitted], 'OBJECT', path_container, p_path,
          cycle_selector_specified, cycle_selector, status);

    pfp$purge_object (p_path^, status);

  PROCEND pup$purge_object_cm;

?? TITLE := '   [XDCL] pup$purmc_command ', EJECT ??

  PROCEDURE [XDCL] pup$purmc_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

    VAR
      local_status: ost$status,
      p_path: ^pft$path,
      path_container: clt$path_container,
      set_name: stt$set_name;

    crack_master_catalog (parameter_list, path_container, p_path, status);
    IF status.normal THEN
      pup$display_line (' Purge master catalog', local_status);
      pup$write_path (p_path^, local_status);

      pfp$get_family_set (p_path^ [pfc$family_name_index], set_name, status);
      IF status.normal THEN
        pfp$purge_master_catalog (set_name, p_path^ [pfc$family_name_index], p_path^
              [pfc$master_catalog_name_index], status);
      IFEND;
      pup$write_os_status (status, local_status);
    IFEND;

  PROCEND pup$purmc_command;

?? TITLE := '    [XDCL] pup$put_catalog_segment_cm ', EJECT ??

  PROCEDURE [XDCL] pup$put_catalog_segment_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE put_catalog_segment (
{    catalog_segment, cs: file = $required
{    catalog, c: file = $required
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 3, 29, 15, 58, 40, 425],
    clc$command, 5, 3, 2, 0, 0, 0, 3, ''], [
    ['C                              ',clc$abbreviation_entry, 2],
    ['CATALOG                        ',clc$nominal_entry, 2],
    ['CATALOG_SEGMENT                ',clc$nominal_entry, 1],
    ['CS                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$catalog_segment = 1,
      p$catalog = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      p_attachment_options: ^fst$attachment_options,
      cycle_selector_specified: boolean,
      cycle_selector: pft$cycle_selector,
      file_id: amt$file_identifier,
      local_status: ost$status,
      output_file: amt$local_file_name,
      p_path: ^pft$path,
      path_container: clt$path_container,
      segment_pointer: amt$segment_pointer;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_attachment_options: [1..2];
    p_attachment_options^[1].selector := fsc$access_and_share_modes;
    p_attachment_options^[1].access_modes.selector := fsc$specific_access_modes;
    p_attachment_options^[1].access_modes.value := $fst$file_access_options[fsc$read];
    p_attachment_options^[1].share_modes.selector := fsc$specific_share_modes;
    p_attachment_options^[1].share_modes.value := $fst$file_access_options[];
    p_attachment_options^[2].selector := fsc$create_file;
    p_attachment_options^[2].create_file := FALSE;

    fsp$open_file (pvt [p$catalog_segment].value^.file_value^, amc$segment, p_attachment_options, NIL, NIL,
          NIL, NIL, file_id, status);

    amp$get_segment_pointer (file_id, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET segment_pointer.sequence_pointer;

    pup$crack_pf_file_reference (pvt [p$catalog].value^.file_value^,
          $put$cycle_reference_selections [puc$cycle_omitted], 'CATALOG', path_container, p_path,
          cycle_selector_specified, cycle_selector, status);

    pfp$define_catalog (p_path^, local_status);

    pfp$put_catalog_segment (p_path^, segment_pointer.sequence_pointer, status);
    IF NOT status.normal THEN
      fsp$close_file (file_id, local_status);
      RETURN;
    IFEND;

    fsp$close_file (file_id, local_status);
  PROCEND pup$put_catalog_segment_cm;

?? TITLE := '    crack_master_catalog ', EJECT ??

  PROCEDURE crack_master_catalog (parameter_list: clt$parameter_list;
    VAR path_container: clt$path_container;
    VAR p_path: ^pft$path;
    VAR status: ost$status);

{ pdt purge_master_catalog (
{ user,u:file=$required
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      purge_master_catalog: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^purge_master_catalog_names, ^purge_master_catalog_params];

    VAR
      purge_master_catalog_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['USER', 1], ['U', 1], ['STATUS', 2]];

    VAR
      purge_master_catalog_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
        clt$parameter_descriptor := [

{ USER U }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    clp$scan_parameter_list (parameter_list, purge_master_catalog, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_catalog ('USER', path_container, p_path, status);
    IF status.normal AND (UPPERBOUND (p_path^) < pfc$master_catalog_name_index) THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$path_too_short, 'PURGE/DEFINE_MASTER_CATALOG',
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_path^[1], status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
           ' Specify both FAMILY and USER as a path ', status);
    IFEND;
  PROCEND crack_master_catalog;

MODEND pum$pf_debugging_aides;
*DECK DECK=PUM$PF_UTILITY_DEFINITIONS EXPAND=TRUE
?? RIGHT := 110 ??
??
NEWTITLE := ' NOS/VE Backup/Restore Utilities:  pf_utility_definitions ', EJECT ??
MODULE pum$pf_utility_definitions;
?? TITLE := '   pud$hierarchy_list ', EJECT ??
*copy pud$hierarchy_list
?? TITLE := '   pud$backup_file ', EJECT ??
*copy pud$backup_file
?? TITLE := '   put$include_data_options ', EJECT ??
*copy put$include_data_options
?? TITLE := '   put$excluded_item_entry ', EJECT ??
*copy put$excluded_item_entry
?? TITLE := '   pud$cycle_reference ', EJECT ??
*copy pud$cycle_reference
?? TITLE := '   put$user_range_list ', EJECT ??
*copy put$user_range_list
?? TITLE := '   pus$literals ', EJECT ??
*copy pus$literals
?? TITLE := '   pud$list_options ', EJECT ??
*copy pud$list_options
?? TITLE := '   put$file_identifier ', EJECT ??
*copy put$file_identifier
?? TITLE := '   put$file_position ', EJECT ??
*copy put$file_position
?? TITLE := '   pud$selection_criteria ', EJECT ??
*copy pud$selection_criteria
?? TITLE := '   put$status_severity ', EJECT ??
*copy put$status_severity
?? TITLE := '   pue$error_condition_codes ', EJECT ??
*copy pue$error_condition_codes
MODEND pum$pf_utility_definitions;
*DECK DECK=PUM$RESOURCE_HELP_MESSAGES EXPAND=TRUE
~"  CREATE_MESSAGE_MODULE PUM$DELETE_ALL_FILES$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                     NOS/VE Delete All Files Menu

    A DELETE_ALL_FILES subcommand has been entered.  This command will
    delete all files selected by BACKUP_PERMANENT_FILE include or exclude
    subcommands.  If there are no include or exclude subcommands preceding
    the command, all files in the system will be deleted.

    You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_REQUEST

      ~P1 - Continue the deletion of all selected files.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TERMINATE_REQUEST
      ~P1 - Terminate the command.

~"**
~"CREATE_FULL_HELP_MESSAGE
      This menu is presented to inform you that a job has entered the
      DELETE_ALL_FILES subcommand to delete all the files selected by
      BACKUP_PERMANENT_FILE include or exclude subcommands.  Caution is
      required if no include or exclude subcommands are specified
      because all the files in the system will be deleted.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CONTINUE_REQUEST
      This choice continues execution of the DELETE_ALL_FILES subcommand.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=TERMINATE_REQUEST
      This choice terminates the DELETE_ALL_FILES subcommand.  It allows
      the user or system operator to prevent the deletion of files by the
      DELETE_ALL_FILES subcommand.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROMPT
  Enter choice or ? for HELP:
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
*DECK DECK=PUM$RESTORE_ALL_FILES EXPAND=TRUE
*copyc osd$default_pragmats
?? RIGHT := 110 ??
??
NEWTITLE := ' NOS/VE Backup/Restore Utilities:  restore_all_files ', EJECT ??
MODULE pum$restore_all_files;

?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amp$get_file_attributes
*copyc amt$local_file_name
*copyc avp$family_administrator
*copyc avp$system_administrator
*copyc clp$scan_parameter_list
*copyc osc$nosve_system_set
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc pud$hierarchy_list
*copyc pue$error_condition_codes
*copyc pup$build_catalog_header
*copyc pup$build_entry
*copyc pup$close_backup_file
*copyc pup$crack_file
*copyc pup$determine_if_set_exists
*copyc pup$determine_record_type
*copyc pup$display_restore_totals
*copyc pup$get_summary_status
*copyc pup$initialize_restore_listing
*copyc pup$open_backup_file
*copyc pup$restore_sub_levels
*copyc pup$set_restore_subcmd_defaults
*copyc pup$write_os_status
*copyc std$set_name
?? POP ??
?? TITLE := '    Global Variables', EJECT ??

?? TITLE := '    [XDCL] pup$restore_all_files_command ', EJECT ??

  PROCEDURE [XDCL] pup$restore_all_files_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

    VAR
      backup_file: amt$local_file_name,
      local_status: ost$status;

    crack_resaf (parameter_list, backup_file, status);
    IF status.normal THEN
      restore_all_files (backup_file, status);
    IFEND;
  PROCEND pup$restore_all_files_command;

?? TITLE := '    crack_resaf ', EJECT ??

  PROCEDURE crack_resaf (parameter_list: clt$parameter_list;
    VAR backup_file: amt$local_file_name;
    VAR status: ost$status);

{ pdt restore_all_files_pdt (
{ backup_file,bf:file=$required
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      restore_all_files_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^restore_all_files_pdt_names, ^restore_all_files_pdt_params];

    VAR
      restore_all_files_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['BACKUP_FILE', 1], ['BF', 1], ['STATUS', 2]];

    VAR
      restore_all_files_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
        clt$parameter_descriptor := [

{ BACKUP_FILE BF }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    clp$scan_parameter_list (parameter_list, restore_all_files_pdt, status);
    IF status.normal THEN
      pup$crack_file ('BACKUP_FILE', backup_file, status);
    IFEND;
  PROCEND crack_resaf;

?? TITLE := '    restore_all_files ', EJECT ??

  PROCEDURE restore_all_files (backup_file: amt$local_file_name;
    VAR status: ost$status);

    restore_existing_set ( {set_name=} osc$nosve_system_set,
          {new_set_name=} osc$nosve_system_set, backup_file, status);
  PROCEND restore_all_files;

?? TITLE := '    restore_existing_set ', EJECT ??

  PROCEDURE restore_existing_set (set_name: stt$set_name;
        new_set_name: stt$set_name;
        backup_file: amt$local_file_name;
    VAR status: ost$status);

    VAR
      backup_file_id: put$file_identifier,
      dummy_cycle_selector: pft$cycle_selector,
      local_status: ost$status,
      p_catalog_header: ^put$catalog_header,
      p_new_catalog_header: ^put$catalog_header,
      set_entry: put$entry,
      set_exists: boolean;

    pup$build_entry (set_name, dummy_cycle_selector, puc$valid_set_entry, set_entry);
    PUSH p_catalog_header: [1 .. 1];
    pup$build_catalog_header (set_name, NIL, p_catalog_header^);
    PUSH p_new_catalog_header: [1 .. 1];
    pup$build_catalog_header (new_set_name, NIL, p_new_catalog_header^);
    pup$determine_if_set_exists (new_set_name, set_exists, status);
    IF status.normal THEN
      IF set_exists THEN
        pup$open_backup_file (backup_file, puc$restore_permanent_files, amc$open_at_boi,
            backup_file_id, status);
        IF status.normal THEN
          pup$initialize_restore_listing (' RESTORE ALL FILES: ', p_catalog_header^, set_entry,
                p_new_catalog_header^.path, dummy_cycle_selector, status);
          IF status.normal THEN
            pup$set_restore_subcmd_defaults (NOT (avp$system_administrator() OR avp$family_administrator()));
            pup$restore_sub_levels (set_entry, p_catalog_header^, {password_specified} FALSE,
                  {password} osc$null_name, p_new_catalog_header^, {restore_n_levels} FALSE,
                  {p_selected_cycles} NIL, backup_file_id, status);
          IFEND;
          pup$close_backup_file (backup_file_id, local_status);
          IF status.normal THEN
            status := local_status;
          IFEND;
          pup$display_restore_totals;
          pup$get_summary_status (status);
          pup$write_os_status (status, local_status);
        IFEND;
      ELSE
        osp$set_status_abnormal (puc$pf_utility_id, pue$unknown_set, new_set_name, status);
      IFEND;
    IFEND;
  PROCEND restore_existing_set;
MODEND pum$restore_all_files;
*DECK DECK=PUM$RESTORE_CATALOG EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  restore_catalog ', EJECT ??
MODULE pum$restore_catalog;

?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc avp$family_administrator
*copyc avp$system_administrator
*copyc clp$scan_parameter_list
*copyc osc$nosve_system_set
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc pud$backup_file
*copyc pud$hierarchy_list
*copyc pue$error_condition_codes
*copyc pup$build_catalog_header
*copyc pup$build_entry
*copyc pup$close_backup_file
*copyc pup$compare_paths
*copyc pup$crack_catalog
*copyc pup$crack_file
*copyc pup$display_restore_totals
*copyc pup$find_restore_entry
*copyc pup$get_summary_status
*copyc pup$initialize_restore_listing
*copyc pup$open_backup_file
*copyc pup$restore_catalog_info
*copyc pup$restore_sub_levels
*copyc pup$set_restore_subcmd_defaults
*copyc pup$skip_logical_partition
*copyc pup$validate_n_n_minus_1
*copyc pup$verify_family_administrator
*copyc pup$write_os_status
*copyc puv$restore_archive_information
?? POP ??
?? TITLE := '    Global Variables', EJECT ??
?? TITLE := '    [XDCL] pup$restore_catalog_command ', EJECT ??

  PROCEDURE [XDCL] pup$restore_catalog_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

    VAR
      backup_file: amt$local_file_name,
      catalog_path_container: clt$path_container,
      local_status: ost$status,
      new_catalog_path_container: clt$path_container,
      path_1_above_path_2: boolean,
      paths_equal: boolean,
      p_catalog_path: ^pft$path,
      p_new_catalog_path: ^pft$path;

    crack_restore_catalog (parameter_list, catalog_path_container, p_catalog_path, new_catalog_path_container,
          p_new_catalog_path, backup_file, status);
    IF status.normal THEN
      CASE UPPERBOUND (p_new_catalog_path^) OF
      = pfc$family_name_index =
        pup$verify_family_administrator (' RESTORE_CATALOG ', p_new_catalog_path^ [pfc$family_name_index],
              status);
        IF NOT status.normal THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, ' to restore a family ', status);
        IFEND;
      = pfc$master_catalog_name_index =
        pup$verify_family_administrator (' RESTORE_CATALOG ', p_new_catalog_path^ [pfc$family_name_index],
              status);
        IF NOT status.normal THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, ' to restore a user ', status);
        IFEND;
      ELSE
      CASEND;
    IFEND;
    IF status.normal THEN
      pup$restore_catalog_request (p_catalog_path^, p_new_catalog_path^, backup_file, status);
    IFEND;
  PROCEND pup$restore_catalog_command;

?? TITLE := '    pup$restore_catalog_request ', EJECT ??

  PROCEDURE pup$restore_catalog_request (catalog_path: pft$path;
        new_catalog_path: pft$path;
        backup_file: amt$local_file_name;
    VAR status: ost$status);

    VAR
      backup_file_id: put$file_identifier,
      catalog_entry: put$entry,
      catalog_entry_type: put$entry_type,
      dummy_cycle_selector: pft$cycle_selector,
      dummy_password: pft$password,
      file_position: put$file_position,
      item_exists: boolean,
      local_status: ost$status,
      new_catalog_entry_type: put$entry_type,
      p_catalog_header: ^put$catalog_header,
      p_new_catalog_header: ^put$catalog_header;

    IF UPPERBOUND (catalog_path) = pfc$family_name_index THEN
      catalog_entry_type := puc$valid_family_entry;
    ELSE
      catalog_entry_type := puc$valid_catalog_entry;
    IFEND;

    IF UPPERBOUND (new_catalog_path) = pfc$family_name_index THEN
      new_catalog_entry_type := puc$valid_family_entry;
    ELSE
      new_catalog_entry_type := puc$valid_catalog_entry;
    IFEND;

    pup$build_entry (catalog_path [UPPERBOUND (catalog_path)], dummy_cycle_selector, catalog_entry_type,
          catalog_entry);
    PUSH p_catalog_header: [1 .. UPPERBOUND (catalog_path)];
    pup$build_catalog_header (osc$nosve_system_set, ^catalog_path, p_catalog_header^);
    PUSH p_new_catalog_header: [1 .. UPPERBOUND (new_catalog_path)];
    pup$build_catalog_header (osc$nosve_system_set, ^new_catalog_path, p_new_catalog_header^);
    pup$validate_n_n_minus_1 (new_catalog_path, new_catalog_entry_type, dummy_cycle_selector, status);
    IF status.normal THEN
      pup$open_backup_file (backup_file, puc$restore_permanent_files, amc$open_at_boi,
          backup_file_id, status);
      IF status.normal THEN
        pup$initialize_restore_listing (' RESTORE CATALOG: ', p_catalog_header^, catalog_entry,
              new_catalog_path, dummy_cycle_selector, status);
        IF status.normal THEN
          pup$set_restore_subcmd_defaults (NOT (avp$system_administrator() OR avp$family_administrator()));
          pup$restore_sub_levels (catalog_entry, p_catalog_header^, {password_specified} FALSE,
                {password} osc$null_name, p_new_catalog_header^, {restore_n_levels} TRUE,
                {p_selected_cycles} NIL, backup_file_id, status);
          pup$display_restore_totals;
          pup$get_summary_status (status);
          pup$write_os_status (status, local_status);
        IFEND;
        pup$close_backup_file (backup_file_id, local_status);
        IF status.normal THEN
          status := local_status;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pup$restore_catalog_request;

?? TITLE := '    crack_restore_catalog ', EJECT ??

  PROCEDURE crack_restore_catalog (parameter_list: clt$parameter_list;
    VAR catalog_path_container: clt$path_container;
    VAR p_catalog_path: ^pft$path;
    VAR new_catalog_path_container: clt$path_container;
    VAR p_new_catalog_path: ^pft$path;
    VAR backup_file: amt$local_file_name;
    VAR status: ost$status);

{ pdt restore_catalog_pdt (
{ catalog,c:file=$required
{ backup_file,bf:file=$required
{ new_catalog_name,ncn:file
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      restore_catalog_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^restore_catalog_pdt_names, ^restore_catalog_pdt_params];

    VAR
      restore_catalog_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
        clt$parameter_name_descriptor := [['CATALOG', 1], ['C', 1], ['BACKUP_FILE', 2], ['BF', 2], [
        'NEW_CATALOG_NAME', 3], ['NCN', 3], ['STATUS', 4]];

    VAR
      restore_catalog_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
        clt$parameter_descriptor := [

{ CATALOG C }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ BACKUP_FILE BF }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ NEW_CATALOG_NAME NCN }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??


    clp$scan_parameter_list (parameter_list, restore_catalog_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_catalog ('CATALOG', catalog_path_container, p_catalog_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_file ('BACKUP_FILE', backup_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_catalog ('NEW_CATALOG_NAME', new_catalog_path_container, p_new_catalog_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF p_new_catalog_path = NIL THEN
      {default it }
      p_new_catalog_path := p_catalog_path;
    ELSE
      CASE UPPERBOUND (p_catalog_path^) OF
      = pfc$family_name_index =
        IF UPPERBOUND (p_new_catalog_path^) > pfc$family_name_index THEN
          osp$set_status_abnormal (puc$pf_utility_id, pue$must_restore_as_family, ' RESTORE_CATALOG',
                status);
        IFEND;
      = pfc$master_catalog_name_index =
        IF UPPERBOUND (p_new_catalog_path^) = pfc$family_name_index THEN
          osp$set_status_abnormal (puc$pf_utility_id, pue$cant_restore_as_family, ' RESTORE_CATALOG',
                status);
        IFEND;
      ELSE {subcatalog
        IF UPPERBOUND (p_new_catalog_path^) <= pfc$master_catalog_name_index THEN
          osp$set_status_abnormal (puc$pf_utility_id, pue$must_restore_as_subcatalog,
                ' RESTORE_CATALOG', status);
        IFEND;
      CASEND;
    IFEND;
  PROCEND crack_restore_catalog;
MODEND pum$restore_catalog;
*DECK DECK=PUM$RESTORE_CYCLE_CONTENTS EXPAND=TRUE
MODULE pum$restore_cycle_contents;
MODEND pum$restore_cycle_contents;
*DECK DECK=PUM$RESTORE_EXCLUDED_FILE_CYCLE EXPAND=TRUE
*copyc osd$default_pragmats
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  restore_excluded_file_cycles ', EJECT ??
MODULE pum$restore_excluded_file_cycle;
{
{  This contains processing for the RESTORE_EXCLUDED_FILE_CYCLES subcommand.
{
?? NEWTITLE := '   Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avp$family_administrator
*copyc avp$system_administrator
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc osc$nosve_system_set
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_abnormal
*copyc pfp$put_cycle_info
*copyc pfp$replace_rem_media_fmd
*copyc pfe$error_condition_codes
*copyc pue$error_condition_codes
*copyc pup$build_catalog_header
*copyc pup$build_entry
*copyc pup$build_new_online_cat_head
*copyc pup$close_backup_file
*copyc pup$compare_item_descriptor
*copyc pup$compare_paths
*copyc pup$crack_catalog
*copyc pup$crack_file
*copyc pup$crack_permanent_file
*copyc pup$display_line
*copyc pup$display_restore_totals
*copyc pup$find_cycle_entry
*copyc pup$format_date_time
*copyc pup$get_backup_cycle_info
*copyc pup$get_item_descriptor
*copyc pup$get_next_record_header
*copyc pup$get_summary_status
*copyc pup$initialize_restore_listing
*copyc pup$locate_valid_version
*copyc pup$open_backup_file
*copyc pup$physical_path_length
*copyc pup$restore_cycle_content
*copyc pup$restore_label
*copyc pup$set_abnormal_entry_status
*copyc pup$set_restore_subcmd_defaults
*copyc pup$skip_logical_partition
*copyc pup$verify_catalog_path
*copyc pup$verify_family_administrator
*copyc pup$verify_file_path
*copyc pup$write_cycle_display
*copyc pup$write_os_status
*copyc pup$write_os_status
*copyc pup$write_status_to_listing
*copyc pup$write_sub_path
*copyc pup$write_sub_path
*copyc put$restore_data_selections
*copyc puv$purge_cycle_options
*copyc puv$replace_cycle_data
*copyc puv$require_modification_match
*copyc puv$trace_selected
?? POP ??
?? TITLE := '    Global Declarations Declared by This Module', EJECT ??
?? TITLE := ' [XDCL] pup$crack_resefc_selection ', EJECT ??
  PROCEDURE [XDCL] pup$crack_resefc_selection
    (    parameter: string ( * );
     VAR restore_options: put$restore_data_selections;
     VAR status: ost$status);

    VAR
      option: 0 .. clc$max_value_sets,
      set_count: 0 .. clc$max_value_sets,
      value: clt$value;

    restore_options := $put$restore_data_selections [];
    clp$get_set_count (parameter, set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR option := 1 TO set_count DO
      clp$get_value (parameter, option, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.name.value (1) = 'M' THEN
        restore_options := restore_options + $put$restore_data_selections [puc$media_missing];
      ELSEIF value.name.value (1) = 'N' THEN
        restore_options := restore_options + $put$restore_data_selections [puc$no_data_defined];
      ELSEIF value.name.value (1) = 'V' THEN
        restore_options := restore_options + $put$restore_data_selections [puc$volume_unavailable];
      IFEND;
    FOREND;
  PROCEND pup$crack_resefc_selection;
?? TITLE := '  [XDCL] pup$restore_cycle_if_excluded ', EJECT ??

  PROCEDURE [XDCL] pup$restore_cycle_if_excluded
    (    requested_entry: put$entry;
         catalog_header: put$catalog_header;
         new_catalog_header: put$catalog_header;
         new_cycle_selector: pft$cycle_selector;
         found_entry: put$entry;
         found_catalog_header: put$catalog_header;
         restore_selections: put$restore_data_selections;
         p_cycle_array_extended_record: pft$p_info_record;
         p_cycle_directory_array: pft$p_cycle_directory_array;
     VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    VAR
      backup_cycle_array_entry: pft$cycle_array_entry_version_2,
      cycle_length: amt$file_length,
      ignore_status: ost$status,
      label_exists: boolean,
      local_status: ost$status,
      mandated_modification_time: pft$mandated_modification_time,
      new_cycle_entry: put$entry,
      new_online_path_length: integer,
      p_file_media_descriptor: ^SEQ ( * ),
      p_label: ^ SEQ ( * ),
      p_new_online_catalog_header: ^put$catalog_header,
      password_selector: pft$password_selector,
      record_header: put$backup_file_record_header;

    status.normal := TRUE;
    new_online_path_length := pup$physical_path_length (new_catalog_header.logical_path_length +
          found_catalog_header.logical_path_length - catalog_header.logical_path_length);
    PUSH p_new_online_catalog_header: [1 .. new_online_path_length];
    pup$build_new_online_cat_head (catalog_header, new_catalog_header, found_catalog_header,
          p_new_online_catalog_header^);
    pup$build_entry (p_new_online_catalog_header^.path [UPPERBOUND (p_new_online_catalog_header^.path)],
          new_cycle_selector, puc$valid_cycle_entry, new_cycle_entry);
    pup$get_backup_cycle_info (backup_file_id, file_position, backup_cycle_array_entry,
          p_file_media_descriptor, status);
    IF status.normal THEN
      IF file_position = puc$mid_partition THEN
        password_selector.password_specified := pfc$default_password_option;
        pfp$put_cycle_info (p_new_online_catalog_header^.path, new_cycle_selector, password_selector,
              backup_cycle_array_entry, ignore_status);
        IF puv$require_modification_match THEN
          mandated_modification_time.verify_option := pfc$verify_modification_time;
        ELSE
          mandated_modification_time.verify_option := pfc$replace_modification_time;
        IFEND;
        mandated_modification_time.specified_modification_time :=
              backup_cycle_array_entry.data_modification_date_time;
        pup$restore_label (record_header, label_exists, p_label, backup_file_id, file_position, status);
        IF status.normal THEN
          IF file_position = puc$partition_boundary THEN
            cycle_length := puc$released_cycle_size;
          IFEND;
          pup$restore_cycle_content (p_new_online_catalog_header^.path, new_cycle_selector,
                password_selector, record_header, label_exists, p_label, p_file_media_descriptor,
                restore_selections, mandated_modification_time, backup_file_id, file_position,
                cycle_length, status);
          IF status.normal AND (backup_cycle_array_entry.device_class = rmc$magnetic_tape_device)
                AND (p_file_media_descriptor <> NIL) THEN
            pfp$replace_rem_media_fmd (p_new_online_catalog_header^.path, new_cycle_selector,
                  password_selector, p_file_media_descriptor, status);
            IF NOT status.normal THEN
              pup$display_line (' REMOVABLE MEDIA ATTRIBUTES PROBABLY LOST - UNUSABLE FILE ',
                    local_status);
              pup$write_os_status (status, local_status);
            IFEND;
          IFEND;
        IFEND;
      ELSE
        osp$set_status_abnormal (puc$pf_utility_id, pue$unusable_restore_file, ' unexpected file position',
              status);
      IFEND;

      IF p_label <> NIL THEN
        FREE p_label;
      IFEND;
      IF p_file_media_descriptor <> NIL THEN
        FREE p_file_media_descriptor;
      IFEND;
      IF status.normal THEN
        display_new_catalog_path (p_new_online_catalog_header^.path);
        pup$write_cycle_display (new_cycle_entry, backup_cycle_array_entry, cycle_length,
              puv$unknown_global_file_name, {recorded vsns} NIL, p_cycle_array_extended_record,
              p_cycle_directory_array, status);
        IF (NOT puv$require_modification_match) AND (backup_cycle_array_entry.cycle_statistics.
              modification_date_time <> mandated_modification_time.existing_modification_time) AND
              (file_position <> puc$partition_boundary) THEN
              {puc$partition_boundary imply that it is a released cycle}
          display_date_time ('  -- Restore replaced modification, Previous modification time: ',
                mandated_modification_time.existing_modification_time);
        IFEND;
      ELSE
        CASE status.condition OF
        = pfe$catalog_full, pfe$incorrect_password, pfe$invalid_ring_access, pfe$lfn_in_use,
              pfe$pf_system_error, pfe$usage_not_permitted =
          pup$write_status_to_listing (new_cycle_entry, status, local_status);
          status := local_status;
        ELSE
          display_status (status);
          status.normal := TRUE;
        CASEND;
      IFEND;
    IFEND;
  PROCEND pup$restore_cycle_if_excluded;
?? TITLE := '    [XDCL] pup$restore_excluded_cycles_cm ', EJECT ??

  PROCEDURE [XDCL] pup$restore_excluded_cycles_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      backup_file_id: put$file_identifier,
      backup_file_lfn: amt$local_file_name,
      cycle_array_entry: pft$cycle_array_entry_version_2,
      cycle_selector: pft$cycle_selector,
      entry: put$entry,
      item_path_container: clt$path_container,
      item_type: put$entry_type,
      local_status: ost$status,
      new_cycle_selector: pft$cycle_selector,
      new_entry: put$entry,
      new_item_path_container: clt$path_container,
      new_item_path_contaner: clt$path_container,
      p_catalog_header: ^put$catalog_header,
      p_item_path: ^pft$path,
      p_new_catalog_header: ^put$catalog_header,
      p_new_item_path: ^pft$path,
      restore_selections: put$restore_data_selections;

    crack_resefc (parameter_list, p_item_path, item_path_container, item_type, cycle_selector,
          backup_file_lfn, p_new_item_path, new_item_path_container, new_cycle_selector, restore_selections,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    CASE item_type OF
    = puc$valid_family_entry =
      pup$verify_family_administrator ('RESTORE_EXCLUDED_FILE_CYCLES',
            p_new_item_path^ [pfc$family_name_index], status);
      IF status.normal THEN
        pup$verify_catalog_path (p_new_item_path^, status);
      ELSE
        osp$append_status_parameter (osc$status_parameter_delimiter, ' to restore to a family', status);
      IFEND;
    = puc$valid_catalog_entry =
      pup$verify_catalog_path (p_new_item_path^, status);
    = puc$valid_pf_entry =
      pup$verify_file_path (p_new_item_path^, status);
    = puc$valid_cycle_entry =
      pup$find_cycle_entry (p_new_item_path^, new_cycle_selector, cycle_array_entry, status);
    ELSE
    CASEND;
    IF status.normal THEN

      pup$open_backup_file (backup_file_lfn, puc$restore_permanent_files, amc$open_at_boi, backup_file_id,
            status);
      IF status.normal THEN
        IF item_type = puc$valid_set_entry THEN
          pup$build_entry (osc$nosve_system_set, cycle_selector, item_type, entry);
          new_entry := entry;
          PUSH p_catalog_header: [1 .. 1];
          pup$build_catalog_header (osc$nosve_system_set, NIL, p_catalog_header^);
          p_new_catalog_header := p_catalog_header;
          pup$set_restore_subcmd_defaults (NOT (avp$system_administrator() OR avp$family_administrator()));
        ELSE
          pup$build_entry (p_item_path^ [UPPERBOUND (p_item_path^)], cycle_selector, item_type, entry);
          PUSH p_catalog_header: [1 .. UPPERBOUND (p_item_path^)];
          pup$build_catalog_header (osc$nosve_system_set, p_item_path, p_catalog_header^);
          pup$build_entry (p_new_item_path^ [UPPERBOUND (p_new_item_path^)], new_cycle_selector, item_type,
                new_entry);
          PUSH p_new_catalog_header: [1 .. UPPERBOUND (p_new_item_path^)];
          pup$build_catalog_header (osc$nosve_system_set, p_new_item_path, p_new_catalog_header^);
          pup$set_restore_subcmd_defaults (NOT (avp$system_administrator() OR avp$family_administrator()));
        IFEND;

        pup$initialize_restore_listing (' RESTORE EXCLUDED FILE CYCLES ', p_catalog_header^, entry,
              p_new_catalog_header^.path, new_cycle_selector, status);
        restore_excluded_file_cycles (entry, p_catalog_header^, new_entry, p_new_catalog_header^,
              restore_selections, backup_file_id, status);
        pup$close_backup_file (backup_file_id, local_status);
        IF status.normal THEN
          status := local_status;
        IFEND;
        pup$display_restore_totals;
        pup$get_summary_status (status);
        pup$write_os_status (status, local_status);
      IFEND;
    IFEND;
  PROCEND pup$restore_excluded_cycles_cm;


?? TITLE := '    crack_resefc ', EJECT ??

  PROCEDURE crack_resefc
    (    parameter_list: clt$parameter_list;
     VAR p_item_path: ^pft$path;
     VAR item_path_container: clt$path_container;
     VAR item_type: put$entry_type;
     VAR cycle_selector: pft$cycle_selector;
     VAR backup_file: amt$local_file_name;
     VAR p_new_item_path: ^pft$path;
     VAR new_item_path_container: clt$path_container;
     VAR new_cycle_selector: pft$cycle_selector;
     VAR restore_options: put$restore_data_selections;
     VAR status: ost$status);

{ PDT restore_excluded_cycles (
{  file, f: file
{  catalog, c: file
{  backup_file, bf: file = $required
{  new_name, nn, new_catalog_name, ncn, new_file_name, nfn: file
{  restore_options, restore_option, ro: list of key media_missing mm ..
{     no_data_defined ndd volume_unavailable vu = (media_missing no_data_defined volume_unavailable)
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      restore_excluded_cycles: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^restore_excluded_cycles_names, ^restore_excluded_cycles_params];

    VAR
      restore_excluded_cycles_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 16] of
            clt$parameter_name_descriptor := [['FILE', 1], ['F', 1], ['CATALOG', 2], ['C', 2],
            ['BACKUP_FILE', 3], ['BF', 3], ['NEW_NAME', 4], ['NN', 4], ['NEW_CATALOG_NAME', 4], ['NCN', 4],
            ['NEW_FILE_NAME', 4], ['NFN', 4], ['RESTORE_OPTIONS', 5], ['RESTORE_OPTION', 5], ['RO', 5],
            ['STATUS', 6]];

    VAR
      restore_excluded_cycles_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 6] of
            clt$parameter_descriptor := [

{ FILE F }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ CATALOG C }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ BACKUP_FILE BF }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ NEW_NAME NN NEW_CATALOG_NAME NCN NEW_FILE_NAME NFN }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ RESTORE_OPTIONS RESTORE_OPTION RO }
      [[clc$optional_with_default, ^restore_excluded_cycles_dv5], 1, clc$max_value_sets, 1, 1,
            clc$value_range_not_allowed, [^restore_excluded_cycles_kv5, clc$keyword_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      restore_excluded_cycles_kv5: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
            ost$name := ['MEDIA_MISSING', 'MM', 'NO_DATA_DEFINED', 'NDD', 'VOLUME_UNAVAILABLE', 'VU'];

    VAR
      restore_excluded_cycles_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (50) :=
            '(media_missing no' CAT '_data_defined volume_unavailable)';

?? POP ??

    VAR
      catalog_path_container: clt$path_container,
      cycle_specified: boolean,
      p_catalog_path: ^pft$path,
      p_container: ^clt$path_container,
      value: clt$value;

    clp$scan_parameter_list (parameter_list, restore_excluded_cycles, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ crack FILE parameter
    pup$crack_permanent_file ('FILE', $put$cycle_reference_selections [puc$cycle_omitted, puc$specific_cycle],
          item_path_container, p_item_path, cycle_specified, cycle_selector, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF p_item_path <> NIL THEN
      {FILE parameter specified
      IF cycle_specified THEN
        item_type := puc$valid_cycle_entry;
      ELSE
        item_type := puc$valid_pf_entry;
      IFEND;
    IFEND;

{ crack CATALOG parameter
    pup$crack_catalog ('CATALOG', catalog_path_container, p_catalog_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (p_catalog_path <> NIL) AND (p_item_path <> NIL) THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$both_file_catalog_specified, '', status);
      RETURN;
    IFEND;

{ crack BACKUP_FILE parameter
    pup$crack_file ('BACKUP_FILE', backup_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ crack NEW_NAME parameter
    IF (p_catalog_path = NIL) AND (p_item_path = NIL) THEN
      clp$get_value ('NEW_NAME', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.kind = clc$unknown_value THEN
        {default
        item_type := puc$valid_set_entry;
        p_new_item_path := NIL;
      ELSE
        osp$set_status_abnormal (puc$pf_utility_id, pue$new_name_specified_alone, '', status);
        RETURN;
      IFEND;
    ELSEIF (p_item_path <> NIL) THEN
      {NEW_NAME describes a permanent file
      pup$crack_permanent_file ('NEW_NAME', $put$cycle_reference_selections
            [puc$cycle_omitted, puc$highest_cycle, puc$lowest_cycle, puc$specific_cycle],
            new_item_path_container, p_new_item_path, cycle_specified, new_cycle_selector, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (p_new_item_path = NIL) THEN
        p_new_item_path := p_item_path;
        IF item_type = puc$valid_cycle_entry THEN
          new_cycle_selector := cycle_selector;
        IFEND;
      ELSE
        IF item_type = puc$valid_cycle_entry THEN
          IF NOT cycle_specified THEN
            new_cycle_selector.cycle_option := pfc$highest_cycle;
          IFEND;
        ELSE
          IF cycle_specified THEN
            osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_cycle_on_nfn, 'NEW_NAME', status);
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    ELSE
      { CATALOG item
      IF UPPERBOUND (p_catalog_path^) = pfc$family_name_index THEN
        item_type := puc$valid_family_entry
      ELSE
        item_type := puc$valid_catalog_entry;
      IFEND;
      p_container := ^item_path_container;
      RESET p_container;
      NEXT p_item_path: [1 .. UPPERBOUND (p_catalog_path^)] IN p_container;
      p_item_path^ := p_catalog_path^;
      pup$crack_catalog ('NEW_NAME', new_item_path_container, p_new_item_path, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF p_new_item_path = NIL THEN
        p_new_item_path := p_item_path;
      ELSE
        CASE UPPERBOUND (p_item_path^) OF
        = pfc$family_name_index =
          IF UPPERBOUND (p_new_item_path^) > pfc$family_name_index THEN
            osp$set_status_abnormal (puc$pf_utility_id, pue$must_restore_as_family,
                  '  RESTORE_EXCLUDED_FILE_CYCLES', status);
            RETURN;
          IFEND;
        = pfc$master_catalog_name_index =
          IF UPPERBOUND (p_new_item_path^) = pfc$family_name_index THEN
            osp$set_status_abnormal (puc$pf_utility_id, pue$cant_restore_as_family,
                  '  RESTORE_EXCLUDED_FILE_CYCLES', status);
            RETURN;
          IFEND;
        ELSE {subcatalog
          IF UPPERBOUND (p_new_item_path^) <= pfc$family_name_index THEN
            osp$set_status_abnormal (puc$pf_utility_id, pue$must_restore_as_subcatalog,
                  ' RESTORE_EXCLUDED_FILE_CYCLES', status);
            RETURN;
          IFEND;
        CASEND;
      IFEND;
    IFEND;

{ crack RESTORE_OPTIONS parameter
   pup$crack_resefc_selection ('RESTORE_OPTIONS', restore_options, status);

  PROCEND crack_resefc;

?? TITLE := '    display_date_time ', EJECT ??

  PROCEDURE display_date_time
    (    descriptor: string ( * <= 90);
         date_time: ost$date_time);

    VAR
      status: ost$status,
      working_string: string (120),
      date_time_string: string (30);

    working_string := descriptor;
    pup$format_date_time (date_time, date_time_string);
    working_string ((STRLENGTH (descriptor) + 1), * ) := date_time_string;
    pup$display_line (working_string (1, (STRLENGTH (descriptor) + 30)), status);
  PROCEND display_date_time;
?? TITLE := '    display_new_catalog_path ', EJECT ??

  PROCEDURE display_new_catalog_path
    (    new_file_path: pft$path);

    VAR
      i: integer,
      local_status: ost$status,
      new_path_above_old_path: boolean,
      new_path_equals_old_path: boolean,
      p_last_catalog_path: [STATIC] ^pft$path := NIL,
      p_new_catalog_path: ^pft$path;

    PUSH p_new_catalog_path: [1 .. (UPPERBOUND (new_file_path) - 1)];
    FOR i := 1 TO UPPERBOUND (p_new_catalog_path^) DO
      p_new_catalog_path^ [i] := new_file_path [i];
    FOREND;
    IF p_last_catalog_path = NIL THEN
      ALLOCATE p_last_catalog_path: [1 .. UPPERBOUND (p_new_catalog_path^)];
      p_last_catalog_path^ := p_new_catalog_path^;
      pup$write_sub_path (p_new_catalog_path^, 1, UPPERBOUND (p_new_catalog_path^), local_status);
    ELSE
      pup$compare_paths (p_new_catalog_path^, p_last_catalog_path^, new_path_equals_old_path,
            new_path_above_old_path);
      IF NOT new_path_equals_old_path THEN
        FREE p_last_catalog_path;
        ALLOCATE p_last_catalog_path: [1 .. UPPERBOUND (p_new_catalog_path^)];
        p_last_catalog_path^ := p_new_catalog_path^;
        pup$write_sub_path (p_new_catalog_path^, 1, UPPERBOUND (p_new_catalog_path^), local_status);
      IFEND;
    IFEND;
  PROCEND display_new_catalog_path;


?? TITLE := '    restore_excluded_file_cycles ', EJECT ??

  PROCEDURE restore_excluded_file_cycles
    (    requested_entry: put$entry;
         catalog_header: put$catalog_header;
         new_entry: put$entry;
         new_catalog_header: put$catalog_header;
         restore_selections: put$restore_data_selections;
     VAR backup_file_id: put$file_identifier;
     VAR status: ost$status);

    VAR
      any_cycle_found: boolean,
      entry_found: boolean,
      file_position: put$file_position,
      found_entry: put$entry,
      local_status: ost$status,
      new_cycle_selector: pft$cycle_selector,
      p_item_description: ^put$backup_item_descriptor,
      record_header: put$backup_file_record_header,
      requested_subset_found: boolean,
      stored_backup_file_version: put$backup_file_version_name;

    any_cycle_found := FALSE;

  /loop_through_partitions/
    REPEAT
      pup$locate_valid_version (backup_file_id, stored_backup_file_version, file_position, status);
      IF status.normal AND (file_position <> puc$eoi) THEN
        pup$get_next_record_header (backup_file_id, record_header, file_position, status);
        IF status.normal THEN
          IF (record_header.kind = puc$backup_item_identifier) AND (record_header.size >= 1) THEN
            ALLOCATE p_item_description: [1 .. record_header.size];
            pup$get_item_descriptor (backup_file_id, p_item_description^, file_position, status);
            IF status.normal THEN
              found_entry := p_item_description^.pf_utility_entry;
              IF found_entry.entry_type = puc$valid_cycle_entry THEN
                pup$compare_item_descriptor (requested_entry, catalog_header, found_entry,
                      p_item_description^.catalog_header, entry_found, requested_subset_found);
                IF requested_subset_found OR entry_found THEN
                  any_cycle_found := TRUE;
                  IF entry_found THEN
                    new_cycle_selector := new_entry.pf_selector.cycle_selector;
                  ELSE
                    new_cycle_selector := found_entry.pf_selector.cycle_selector;
                  IFEND;
                  puv$purge_cycle_options.preserve_cycle_entry := puv$replace_cycle_data;
                  IF puv$purge_cycle_options.preserve_cycle_entry THEN
                    puv$purge_cycle_options.preserve_archive_info := TRUE;
                    puv$purge_cycle_options.preserve_file_label := TRUE;
                    puv$purge_cycle_options.preserve_modification_date_time := TRUE;
                  IFEND;
                  pup$restore_cycle_if_excluded (requested_entry, catalog_header, new_catalog_header,
                        new_cycle_selector, found_entry, p_item_description^.catalog_header,
                        restore_selections, { p_cycle_array_extended_record := } NIL,
                        { p_cycle_directory_array := } NIL, backup_file_id, file_position, status);
                IFEND;
              IFEND;
            IFEND;
            FREE p_item_description;
          ELSE
            osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_item_requested, ' identifier ',
                  status);
          IFEND;
        IFEND;
        pup$write_os_status (status, local_status);
        status.normal := TRUE;
        IF file_position = puc$mid_partition THEN
          pup$skip_logical_partition (backup_file_id, file_position, status);
        IFEND;
      IFEND;
    UNTIL NOT status.normal OR (file_position = puc$eoi);
    IF status.normal AND NOT any_cycle_found THEN
      IF requested_entry.entry_type = puc$valid_set_entry THEN
        osp$set_status_abnormal (puc$pf_utility_id, pue$no_restore_no_find, 'a valid cycle entry', status);
      ELSE
        pup$set_abnormal_entry_status (requested_entry, pue$no_restore_no_find, status);
      IFEND;
    IFEND;
  PROCEND restore_excluded_file_cycles;
MODEND pum$restore_excluded_file_cycle;
*DECK DECK=PUM$RESTORE_EXISTING_CATALOG EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  restore_existing_catalog ', EJECT ??
MODULE pum$restore_existing_catalog;

?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc avp$family_administrator
*copyc avp$system_administrator
*copyc clp$scan_parameter_list
*copyc osc$nosve_system_set
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc pud$backup_file
*copyc pud$hierarchy_list
*copyc pue$error_condition_codes
*copyc pup$build_catalog_header
*copyc pup$build_entry
*copyc pup$close_backup_file
*copyc pup$compare_paths
*copyc pup$crack_catalog
*copyc pup$crack_file
*copyc pup$display_restore_totals
*copyc pup$get_summary_status
*copyc pup$initialize_restore_listing
*copyc pup$open_backup_file
*copyc pup$restore_sub_levels
*copyc pup$set_restore_subcmd_defaults
*copyc pup$verify_catalog_path
*copyc pup$verify_family_administrator
*copyc pup$write_os_status
*copyc puv$restore_archive_information
?? POP ??
?? TITLE := '    Global Variables', EJECT ??
?? TITLE := '    [XDCL] pup$restore_existing_catalog_cm ', EJECT ??

  PROCEDURE [XDCL] pup$restore_existing_catalog_cm (parameter_list: clt$parameter_list;
    VAR status: ost$status);

    VAR
      backup_file: amt$local_file_name,
      catalog_path_container: clt$path_container,
      local_status: ost$status,
      new_catalog_path_container: clt$path_container,
      path_1_above_path_2: boolean,
      paths_equal: boolean,
      p_catalog_path: ^pft$path,
      p_new_catalog_path: ^pft$path;

    crack_resec (parameter_list, catalog_path_container, p_catalog_path, new_catalog_path_container,
          p_new_catalog_path, backup_file, status);
    IF status.normal THEN
      IF UPPERBOUND (p_new_catalog_path^) = pfc$family_name_index THEN
        pup$verify_family_administrator ('RESTORE_EXISTING_CATALOG',
              p_new_catalog_path^[pfc$family_name_index], status);
        IF NOT status.normal THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, ' to restore to a family', status);
        IFEND;
      IFEND;
      IF status.normal THEN
        pup$restore_existing_cat_req (p_catalog_path^, p_new_catalog_path^, backup_file, status);
        pup$write_os_status (status, local_status);
      IFEND;
    IFEND;
  PROCEND pup$restore_existing_catalog_cm;

?? TITLE := '    pup$restore_existing_cat_req ', EJECT ??

  PROCEDURE pup$restore_existing_cat_req (catalog_path: pft$path;
        new_catalog_path: pft$path;
        backup_file: amt$local_file_name;
    VAR status: ost$status);

    VAR
      backup_file_id: put$file_identifier,
      catalog_entry: put$entry,
      catalog_entry_type: put$entry_type,
      dummy_cycle_selector: pft$cycle_selector,
      dummy_password: pft$password,
      local_status: ost$status,
      p_catalog_header: ^put$catalog_header,
      p_new_catalog_header: ^put$catalog_header;

    IF UPPERBOUND(catalog_path) = pfc$family_name_index THEN
      catalog_entry_type := puc$valid_family_entry;
    ELSE
      catalog_entry_type := puc$valid_catalog_entry;
    IFEND;
    pup$build_entry (catalog_path [UPPERBOUND (catalog_path)], dummy_cycle_selector, catalog_entry_type,
          catalog_entry);
    PUSH p_catalog_header: [1 .. UPPERBOUND (catalog_path)];
    pup$build_catalog_header (osc$nosve_system_set, ^catalog_path, p_catalog_header^);
    PUSH p_new_catalog_header: [1 .. UPPERBOUND (new_catalog_path)];
    pup$build_catalog_header (osc$nosve_system_set, ^new_catalog_path, p_new_catalog_header^);
    pup$verify_catalog_path (new_catalog_path, status);
    IF status.normal THEN
      pup$open_backup_file (backup_file, puc$restore_permanent_files, amc$open_at_boi,
          backup_file_id, status);
      IF status.normal THEN
        pup$initialize_restore_listing (' RESTORE EXISTING CATALOG:', p_catalog_header^, catalog_entry,
              new_catalog_path, dummy_cycle_selector, status);
        IF status.normal THEN
          pup$set_restore_subcmd_defaults (NOT (avp$system_administrator() OR avp$family_administrator()));
          pup$restore_sub_levels (catalog_entry, p_catalog_header^, {password_specified} FALSE,
                {password} osc$null_name, p_new_catalog_header^, {restore_n_levels} FALSE,
                {p_selected_cycles} NIL, backup_file_id, status);
        IFEND;
        pup$close_backup_file (backup_file_id, local_status);
        IF status.normal THEN
          status := local_status;
        IFEND;
        pup$display_restore_totals;
        pup$get_summary_status (status);
      IFEND;
    IFEND;
  PROCEND pup$restore_existing_cat_req;

?? TITLE := '    crack_resec ', EJECT ??

  PROCEDURE crack_resec (parameter_list: clt$parameter_list;
    VAR catalog_path_container: clt$path_container;
    VAR p_catalog_path: ^pft$path;
    VAR new_catalog_path_container: clt$path_container;
    VAR p_new_catalog_path: ^pft$path;
    VAR backup_file: amt$local_file_name;
    VAR status: ost$status);

{ pdt restore_existing_cat_pdt (
{ catalog,c:file=$required
{ backup_file,bf:file=$required
{ new_catalog_name,ncn:file
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      restore_existing_cat_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^restore_existing_cat_pdt_names, ^restore_existing_cat_pdt_params];

    VAR
      restore_existing_cat_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
        clt$parameter_name_descriptor := [['CATALOG', 1], ['C', 1], ['BACKUP_FILE', 2], ['BF', 2], [
        'NEW_CATALOG_NAME', 3], ['NCN', 3], ['STATUS', 4]];

    VAR
      restore_existing_cat_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
        clt$parameter_descriptor := [

{ CATALOG C }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ BACKUP_FILE BF }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ NEW_CATALOG_NAME NCN }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??


    clp$scan_parameter_list (parameter_list, restore_existing_cat_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_catalog ('CATALOG', catalog_path_container, p_catalog_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_file ('BACKUP_FILE', backup_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_catalog ('NEW_CATALOG_NAME', new_catalog_path_container, p_new_catalog_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF p_new_catalog_path = NIL THEN
      p_new_catalog_path := p_catalog_path;
    ELSE
      CASE UPPERBOUND (p_catalog_path^) OF
      = pfc$family_name_index =
        IF UPPERBOUND (p_new_catalog_path^) > pfc$family_name_index THEN
          osp$set_status_abnormal (puc$pf_utility_id, pue$must_restore_as_family,
                '  RESTORE_EXISTING_CATALOG', status);
        IFEND;
      = pfc$master_catalog_name_index =
        IF UPPERBOUND (p_new_catalog_path^) = pfc$family_name_index THEN
          osp$set_status_abnormal (puc$pf_utility_id, pue$cant_restore_as_family,
                '  RESTORE_EXISTING_CATALOG', status);
        IFEND;
      ELSE {subcatalog
        IF UPPERBOUND (p_new_catalog_path^) <= pfc$family_name_index THEN
          osp$set_status_abnormal (puc$pf_utility_id, pue$must_restore_as_subcatalog,
                ' RESTORE_EXISTING_CATALOG', status);
        IFEND;
      CASEND;
    IFEND;
  PROCEND crack_resec;
MODEND pum$restore_existing_catalog;
*DECK DECK=PUM$RESTORE_EXISTING_FILE EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  restore_existing_file ', EJECT ??
MODULE pum$restore_existing_file;

?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc avp$family_administrator
*copyc avp$system_administrator
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc osc$nosve_system_set
*copyc pud$backup_file
*copyc pud$hierarchy_list
*copyc pue$error_condition_codes
*copyc pup$build_catalog_header
*copyc pup$build_entry
*copyc pup$close_backup_file
*copyc pup$compare_paths
*copyc pup$crack_backup_file
*copyc pup$crack_pf_file_reference
*copyc pup$display_restore_totals
*copyc pup$get_summary_status
*copyc pup$initialize_restore_listing
*copyc pup$open_backup_file
*copyc pup$restore_sub_levels
*copyc pup$set_restore_subcmd_defaults
*copyc pup$verify_file_path
*copyc pup$write_os_status
*copyc puv$restore_archive_information
?? POP ??
?? TITLE := '    Global Variables', EJECT ??
?? TITLE := '    [XDCL] pup$restore_existing_file_cm ', EJECT ??

  PROCEDURE [XDCL] pup$restore_existing_file_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      backup_file: amt$local_file_name,
      backup_file_id: put$file_identifier,
      cycle_entry: put$entry,
      cycle_selector: pft$cycle_selector,
      cycle_specified: boolean,
      entry_type: put$entry_type,
      file_entry: put$entry,
      file_path_container: clt$path_container,
      local_status: ost$status,
      new_cycle_selector: pft$cycle_selector,
      new_cycle_specified: boolean,
      new_file_path_container: clt$path_container,
      p_catalog_header: ^put$catalog_header,
      p_file_path: ^pft$path,
      p_new_catalog_header: ^put$catalog_header,
      p_new_file_path: ^pft$path,
      p_selected_cycles: ^array [1 .. *] of put$selected_cycle_info,
      password: pft$password,
      path_1_above_path_2: boolean,
      paths_equal: boolean;

    crack_restore_existing_file (parameter_list, file_path_container, p_file_path, cycle_specified,
          cycle_selector, password, new_file_path_container, p_new_file_path, new_cycle_specified,
          new_cycle_selector, backup_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_selected_cycles: [1 .. 1];
    IF cycle_specified THEN
      p_selected_cycles ^[1].selected_cycle.cycle_specified := TRUE;
      p_selected_cycles ^[1].selected_cycle.cycle_selector := cycle_selector;
    ELSE
      p_selected_cycles ^[1].selected_cycle.cycle_specified := FALSE;
    IFEND;

    IF new_cycle_specified THEN
      p_selected_cycles ^[1].new_selected_cycle.cycle_specified := TRUE;
      p_selected_cycles ^[1].new_selected_cycle.cycle_selector := new_cycle_selector;
      IF NOT cycle_specified THEN
        cycle_specified := TRUE;
        cycle_selector.cycle_option := pfc$highest_cycle;
        p_selected_cycles ^[1].selected_cycle.cycle_specified := TRUE;
        p_selected_cycles ^[1].selected_cycle.cycle_selector.cycle_option := pfc$highest_cycle;
      IFEND;
    ELSE
      p_selected_cycles ^[1].new_selected_cycle.cycle_specified := FALSE;
    IFEND;

    pup$build_entry (p_file_path^ [UPPERBOUND (p_file_path^)], cycle_selector, puc$valid_pf_entry,
          file_entry);
    PUSH p_catalog_header: [1 .. UPPERBOUND (p_file_path^)];
    pup$build_catalog_header (osc$nosve_system_set, p_file_path, p_catalog_header^);
    PUSH p_new_catalog_header: [1 .. UPPERBOUND (p_new_file_path^)];
    pup$build_catalog_header (osc$nosve_system_set, p_new_file_path, p_new_catalog_header^);
    pup$verify_file_path (p_new_file_path^, status);
    IF status.normal THEN
      pup$open_backup_file (backup_file, puc$restore_permanent_files, amc$open_at_boi, backup_file_id,
            status);
      IF status.normal THEN
        IF cycle_specified THEN
          pup$build_entry (p_file_path^ [UPPERBOUND (p_file_path^)], cycle_selector,
                puc$valid_cycle_entry, cycle_entry);
          IF new_cycle_specified THEN
            pup$initialize_restore_listing ('RESTORE CYCLE OF EXISTING FILE:', p_catalog_header^,
                  cycle_entry, p_new_file_path^, new_cycle_selector, status);
          ELSE
            pup$initialize_restore_listing (' RESTORE EXISTING FILE: ', p_catalog_header^, cycle_entry,
                  p_new_file_path^, cycle_selector, status);
          IFEND;
        ELSE
          IF new_cycle_specified THEN
            pup$build_entry (p_file_path^ [UPPERBOUND (p_file_path^)], cycle_selector,
                  puc$valid_cycle_entry, cycle_entry);
            pup$initialize_restore_listing ('RESTORE CYCLE OF EXISTING FILE:', p_catalog_header^,
                  cycle_entry, p_new_file_path^, new_cycle_selector, status);
          ELSE
            pup$initialize_restore_listing (' RESTORE EXISTING FILE: ', p_catalog_header^, file_entry,
                  p_new_file_path^, cycle_selector, status);
          IFEND;
        IFEND;
        IF status.normal THEN
          pup$set_restore_subcmd_defaults (NOT (avp$system_administrator() OR avp$family_administrator()));
          pup$restore_sub_levels (file_entry, p_catalog_header^, {password_specified} TRUE, password,
                p_new_catalog_header^, {restore_n_levels} TRUE, p_selected_cycles, backup_file_id, status);
        IFEND;
        pup$close_backup_file (backup_file_id, local_status);
        IF status.normal THEN
          status := local_status;
        IFEND;
        pup$display_restore_totals;
        pup$get_summary_status (status);
      IFEND;
    IFEND;
    pup$write_os_status (status, local_status);

  PROCEND pup$restore_existing_file_cm;

?? TITLE := '    crack_restore_existing_file ', EJECT ??

  PROCEDURE crack_restore_existing_file
    (    parameter_list: clt$parameter_list;
     VAR file_path_container: clt$path_container;
     VAR p_file_path: ^pft$path;
     VAR cycle_specified: boolean;
     VAR cycle_selector: pft$cycle_selector;
     VAR password: pft$password;
     VAR new_file_path_container: clt$path_container;
     VAR p_new_file_path: ^pft$path;
     VAR new_cycle_specified: boolean;
     VAR new_cycle_selector: pft$cycle_selector;
     VAR backup_file: amt$local_file_name;
     VAR status: ost$status);

{ PROCEDURE (osm$resef) restore_existing_file, resef (
{   file, f: file = $required
{   backup_file, bf: file = $required
{   password, pw: (SECURE) any of
{       key
{         none
{       keyend
{       name
{     anyend = none
{   new_file_name, nfn: file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 9] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: 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$name_type_qualifier,
          recend,
          default_value: string (4),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 20, 12, 59, 14, 296], clc$command, 9, 5, 2, 0, 0, 0, 5, 'OSM$RESEF'],
            [['BACKUP_FILE                    ', clc$nominal_entry, 2],
            ['BF                             ', clc$abbreviation_entry, 2],
            ['F                              ', clc$abbreviation_entry, 1],
            ['FILE                           ', clc$nominal_entry, 1],
            ['NEW_FILE_NAME                  ', clc$nominal_entry, 4],
            ['NFN                            ', clc$abbreviation_entry, 4],
            ['PASSWORD                       ', clc$nominal_entry, 3],
            ['PW                             ', clc$abbreviation_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 5]], [
{ PARAMETER 1
      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 3
      [7, clc$normal_usage_entry, clc$secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 69, clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 5
      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$file_type]],
{ PARAMETER 2
      [[1, 0, clc$file_type]],
{ PARAMETER 3
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]], 'none'],
{ PARAMETER 4
      [[1, 0, clc$file_type]],
{ PARAMETER 5
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$file = 1,
      p$backup_file = 2,
      p$password = 3,
      p$new_file_name = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      evaluated_file_reference: fst$evaluated_file_reference;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_pf_file_reference (pvt [p$file].value^.file_value^,
          $put$cycle_reference_selections [puc$cycle_omitted, puc$lowest_cycle, puc$highest_cycle,
          puc$specific_cycle], 'FILE', file_path_container, p_file_path, cycle_specified, cycle_selector,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_backup_file (pvt [p$backup_file].value^.file_value^, backup_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$password].value^.kind = clc$name THEN
      password := pvt [p$password].value^.name_value;
    ELSE {keyword = NONE}
      password := osc$null_name;
    IFEND;

    IF pvt [p$new_file_name].specified THEN
      pup$crack_pf_file_reference (pvt [p$new_file_name].value^.file_value^,
            $put$cycle_reference_selections [puc$cycle_omitted, puc$specific_cycle, puc$next_highest_cycle],
            'NEW_FILE_NAME', new_file_path_container, p_new_file_path,
            new_cycle_specified, new_cycle_selector, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF new_cycle_specified THEN
        clp$evaluate_file_reference (pvt [p$new_file_name].value^.file_value^,
              $clt$file_ref_parsing_options [], {resolve_cycle_number} TRUE, evaluated_file_reference,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        new_cycle_selector.cycle_option := pfc$specific_cycle;
        new_cycle_selector.cycle_number := evaluated_file_reference.cycle_reference.cycle_number;
      IFEND;
    ELSE
      new_cycle_specified := FALSE;
      p_new_file_path := p_file_path;
    IFEND;

  PROCEND crack_restore_existing_file;
MODEND pum$restore_existing_file;
*DECK DECK=PUM$RESTORE_FILE EXPAND=TRUE
*copyc osd$default_pragmats
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  restore_file ', EJECT ??
MODULE pum$restore_file;

?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$ring_validation_errors
*copyc osc$nosve_system_set
*copyc osc$space_unavailable_condition
*copyc osd$virtual_address
*copyc osk$keypoint_class_codes
*copyc ost$caller_identifier
*copyc pfc$null_shared_queue
*copyc pue$error_condition_codes
*copyc rme$request_mass_storage
?? POP ??
?? EJECT ??
*copyc amp$close
*copyc amp$get_segment_pointer
*copyc amp$return
*copyc amp$set_segment_eoi
*copyc avp$family_administrator
*copyc avp$system_administrator
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc dmp$get_stored_fmd_header_info
*copyc fsp$change_cycle_date_time
*copyc mmp$close_segment
*copyc mmp$open_segment
*copyc mmp$set_segment_length
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$enforce_exception_policies
*copyc osp$establish_condition_handler
*copyc osp$file_access_condition
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osv$initial_exception_context
*copyc pfp$change_res_to_releasable
*copyc pfp$convert_pf_cy_path_to_strng
*copyc pfp$convert_pft$path_to_fs_path
*copyc pfp$define_data
*copyc pfp$delete_cycle_data
*copyc pfp$get_family_set
*copyc pfp$purge
*copyc pfp$put_cycle_info
*copyc pfp$r3_change_cycle_date_time
*copyc pfp$r3_release_data
*copyc pfp$replace_rem_media_fmd
*copyc pfp$save_released_file_label
*copyc pfp$validate_site_options
*copyc pmp$cause_task_condition
*copyc pmp$continue_to_cause
*copyc pmp$get_unique_name
*copyc pue$error_condition_codes
*copyc pup$advised_get_part
*copyc pup$build_catalog_header
*copyc pup$build_entry
*copyc pup$check_cycle_access
*copyc pup$close_backup_file
*copyc pup$compare_paths
*copyc pup$crack_backup_file
*copyc pup$crack_pf_file_reference
*copyc pup$display_blank_lines
*copyc pup$display_integer
*copyc pup$format_date_time
*copyc pup$get_backup_cycle_info
*copyc pup$get_next_hierarchy_list
*copyc pup$get_next_record_header
*copyc pup$get_part
*copyc pup$get_summary_status
*copyc pup$initialize_restore_listing
*copyc pup$open_backup_file
*copyc pup$restore_file_info
*copyc pup$restore_sub_levels
*copyc pup$set_restore_subcmd_defaults
*copyc pup$skip_logical_partition
*copyc pup$validate_n_n_minus_1
*copyc pup$write_cycle_display
*copyc pup$write_os_status
*copyc pup$write_status_to_listing
*copyc puv$create_objects
*copyc puv$free_behind_selected
*copyc puv$mass_storage_info
*copyc puv$p_included_volumes
*copyc puv$purge_cycle_options
*copyc puv$replace_cycle_data
*copyc puv$require_modification_match
*copyc puv$restore_archive_information
*copyc puv$trace_selected
*copyc puv$update_cycle_statistics
*copyc rmp$build_mass_storage_info
*copyc rmp$validate_mass_storage_info
*copyc srp$store_system_label

?? TITLE := '    Global Variables', EJECT ??

  CONST
    include_radix = TRUE,
    radix = 10;

  VAR
    number_of_cycles_restored: integer := 0,
    total_cycle_data_restored: integer := 0;

?? TITLE := '    [XDCL] pup$display_restore_totals ', EJECT ??

  PROCEDURE [XDCL] pup$display_restore_totals;

    VAR
      local_status: ost$status;

    pup$display_blank_lines (3, local_status);
    pup$display_line (' RESTORE SUMMARY: ', local_status);
    pup$display_integer ('   NUMBER OF CYCLES RESTORED: ', number_of_cycles_restored, local_status);
    number_of_cycles_restored := 0;
    pup$display_integer ('   TOTAL CYCLE DATA RESTORED: ', total_cycle_data_restored, local_status);
    total_cycle_data_restored := 0;
  PROCEND pup$display_restore_totals;

?? TITLE := '    [XDCL] pup$initialize_restore_totals ', EJECT ??

  PROCEDURE [XDCL] pup$initialize_restore_totals;

    total_cycle_data_restored := 0;
    number_of_cycles_restored := 0;
  PROCEND pup$initialize_restore_totals;

?? TITLE := '    [XDCL, INLINE] pup$open_file_for_seg_access ', EJECT ??
*copyc puh$open_file_for_seg_access

  PROCEDURE [XDCL, INLINE] pup$open_file_for_seg_access
    (    lfn: amt$local_file_name;
     VAR segment_pointer: mmt$segment_pointer;
     VAR status: ost$status);

   VAR
      seg_attribute: array [1 .. 1] OF mmt$attribute_descriptor;

    display (' mmp$open_segment users file');
    IF puv$free_behind_selected THEN
      seg_attribute[1].keyword := mmc$kw_software_attributes;
      seg_attribute[1].software_attri_set :=
            $mmt$software_attribute_set [mmc$sa_free_behind];
      mmp$open_segment (lfn, ^seg_attribute, mmc$sequence_pointer, segment_pointer, status);
    ELSE
      mmp$open_segment (lfn, NIL, mmc$sequence_pointer, segment_pointer, status);
    IFEND;

    RESET segment_pointer.seq_pointer;

  PROCEND pup$open_file_for_seg_access;

?? TITLE := '    [XDCL] pup$restore_cycle_content ', EJECT ??

  PROCEDURE [XDCL] pup$restore_cycle_content (
        new_file_name_path: pft$path;
        new_file_name_cycle_selector: pft$cycle_selector;
        password_selector: pft$password_selector;
        record_header: put$backup_file_record_header;
        label_exists: boolean;
        p_label: ^SEQ ( * );
        p_fmd: ^SEQ ( * );
        restore_selections: put$restore_data_selections;
    VAR mandated_modification_time: pft$mandated_modification_time;
    VAR backup_file_id: put$file_identifier;
    VAR file_position: put$file_position;
    VAR cycle_length: amt$file_length;
    VAR status: ost$status);

    VAR
      local_status: ost$status;

    status.normal := TRUE;

    CASE file_position OF
    = puc$mid_partition =
      IF record_header.kind = puc$backup_cycle_data THEN
        display_integer (' define_cycle_contents puc$mid_partition; size = ', record_header.size);
        cycle_length := record_header.size;
        define_cycle_contents (new_file_name_path, new_file_name_cycle_selector, password_selector,
              label_exists, p_label^, p_fmd, restore_selections, record_header.size,
              mandated_modification_time, backup_file_id, file_position, status);
      ELSE
        osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_item_requested, ' cycle data ', status);
        display_status (status);
        pup$display_line (' FILE DATA OR ATTRIBUTES POSSIBLY LOST.', local_status);
      IFEND;
    = puc$partition_boundary =
      display (' define_cycle_contents puc$partition_boundary; size = 0 (data_released or magnetic_tape}');
      cycle_length := puc$released_cycle_size;
      define_released_cycle (new_file_name_path, new_file_name_cycle_selector, password_selector,
            label_exists, p_label, status);
    ELSE
      osp$set_status_abnormal (puc$pf_utility_id, pue$unusable_restore_file, 'unexpected file position',
            status);
      display_status (status);
      pup$display_line (' FILE DATA OR ATTRIBUTES POSSIBLY LOST.', local_status);
    CASEND;
  PROCEND pup$restore_cycle_content;

?? TITLE := '    [XDCL] pup$restore_cycle_item ', EJECT ??
*copyc puh$restore_cycle_item

  PROCEDURE [XDCL] pup$restore_cycle_item
    (    file_entry: put$entry;
         new_file_name_path: pft$path;
         new_file_name_cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         p_cycle_array_extended_record: pft$p_info_record;
         p_cycle_directory_array: pft$p_cycle_directory_array;
     VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    VAR
      cycle_array_entry: pft$cycle_array_entry_version_2,
      cycle_defined: boolean,
      cycle_included: boolean,
      cycle_length: amt$file_length,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      label_exists: boolean,
      local_access_date_time: fst$date_time,
      local_creation_date_time: fst$date_time,
      local_mod_date_time: fst$date_time,
      local_status: ost$status,
      mandated_modification_time: pft$mandated_modification_time,
      new_file_entry: put$entry,
      p_fmd: ^SEQ ( * ),
      p_label: ^ seq (*),
      p_path_string: ^ost$string,
      password: pft$password,
      record_header: put$backup_file_record_header,
      restore_selections: [STATIC, READ] put$restore_data_selections := [puc$no_data_defined];

    pup$build_entry (new_file_name_path [UPPERBOUND (new_file_name_path)], new_file_name_cycle_selector,
          puc$valid_cycle_entry, new_file_entry);
{
{   input cycle array entry
    cycle_defined := FALSE;
    pup$get_backup_cycle_info (backup_file_id, file_position, cycle_array_entry, p_fmd, status);
{
    IF status.normal THEN
      pup$check_cycle_access (cycle_array_entry, cycle_included);
      IF cycle_included THEN
        IF file_position = puc$mid_partition THEN
          IF (puv$require_modification_match) AND (NOT puv$replace_cycle_data) THEN
            mandated_modification_time.verify_option := pfc$verify_modification_time;
          ELSE
            mandated_modification_time.verify_option := pfc$replace_modification_time;
          IFEND;
          mandated_modification_time.specified_modification_time :=
                cycle_array_entry.data_modification_date_time;
          mandated_modification_time.existing_modification_time :=
                cycle_array_entry.data_modification_date_time;
          pup$restore_label (record_header, label_exists, p_label, backup_file_id, file_position, status);
          IF status.normal THEN
            IF file_position = puc$partition_boundary THEN
              IF puv$restore_archive_information THEN
                cycle_length := puc$released_cycle_size;
              ELSE
                PUSH p_path_string;
                pfp$convert_pf_cy_path_to_strng (new_file_name_path,
                      new_file_name_cycle_selector.cycle_number, p_path_string^);
                osp$set_status_abnormal (puc$pf_utility_id, pue$released_cycle_rai_false,
                      p_path_string^.value (1, p_path_string^.size), status);
              IFEND;
            IFEND;
            IF status.normal AND (puv$restore_archive_information OR (file_position <> puc$partition_boundary)
                  OR (cycle_array_entry.device_class = rmc$magnetic_tape_device)) THEN
              IF (puv$mass_storage_info.shared_queue <> pfc$null_shared_queue) AND
                    (cycle_array_entry.device_class = rmc$mass_storage_device) THEN
                cycle_array_entry.shared_queue_info.defined := TRUE;
                cycle_array_entry.shared_queue_info.shared_queue := puv$mass_storage_info.shared_queue;
              IFEND;
              IF puv$create_objects THEN
                IF cycle_array_entry.site_archive_option <> pfc$null_site_archive_option THEN
                  pfp$validate_site_options (new_file_name_path [pfc$family_name_index],
                        cycle_array_entry.site_archive_option, pfc$null_site_backup_option,
                        pfc$null_site_release_option, status);
                  IF NOT status.normal THEN
                    pfp$convert_pft$path_to_fs_path (new_file_name_path, fs_path, fs_path_size);
                    osp$set_status_abnormal (puc$pf_utility_id, pue$site_option_ignored,
                          fs_path (1, fs_path_size), status);
                    osp$append_status_integer (osc$status_parameter_delimiter,
                          new_file_name_cycle_selector.cycle_number, radix, NOT include_radix, status);
                    osp$append_status_parameter (osc$status_parameter_delimiter, 'SITE_ARCHIVE_OPTION',
                          status);
                    osp$append_status_integer (osc$status_parameter_delimiter,
                          cycle_array_entry.site_archive_option, radix, NOT include_radix, status);
                    pup$write_os_status (status, local_status);
                    cycle_array_entry.site_archive_option := pfc$null_site_archive_option;
                  IFEND;
                IFEND;
                IF cycle_array_entry.site_backup_option <> pfc$null_site_backup_option THEN
                  pfp$validate_site_options (new_file_name_path [pfc$family_name_index],
                        pfc$null_site_archive_option, cycle_array_entry.site_backup_option,
                        pfc$null_site_release_option, status);
                  IF NOT status.normal THEN
                    pfp$convert_pft$path_to_fs_path (new_file_name_path, fs_path, fs_path_size);
                    osp$set_status_abnormal (puc$pf_utility_id, pue$site_option_ignored,
                          fs_path (1, fs_path_size), status);
                    osp$append_status_integer (osc$status_parameter_delimiter,
                          new_file_name_cycle_selector.cycle_number, radix, NOT include_radix, status);
                    osp$append_status_parameter (osc$status_parameter_delimiter, 'SITE_BACKUP_OPTION',
                          status);
                    osp$append_status_integer (osc$status_parameter_delimiter,
                          cycle_array_entry.site_backup_option, radix, NOT include_radix, status);
                    pup$write_os_status (status, local_status);
                    cycle_array_entry.site_backup_option := pfc$null_site_backup_option;
                  IFEND;
                IFEND;
                IF cycle_array_entry.site_release_option <> pfc$null_site_release_option THEN
                  pfp$validate_site_options (new_file_name_path [pfc$family_name_index],
                        pfc$null_site_archive_option, pfc$null_site_backup_option,
                        cycle_array_entry.site_release_option, status);
                  IF NOT status.normal THEN
                    pfp$convert_pft$path_to_fs_path (new_file_name_path, fs_path, fs_path_size);
                    osp$set_status_abnormal (puc$pf_utility_id, pue$site_option_ignored,
                          fs_path (1, fs_path_size), status);
                    osp$append_status_integer (osc$status_parameter_delimiter,
                          new_file_name_cycle_selector.cycle_number, radix, NOT include_radix, status);
                    osp$append_status_parameter (osc$status_parameter_delimiter, 'SITE_RELEASE_OPTION',
                          status);
                    osp$append_status_integer (osc$status_parameter_delimiter,
                          cycle_array_entry.site_release_option, radix, NOT include_radix, status);
                    pup$write_os_status (status, local_status);
                    cycle_array_entry.site_release_option := pfc$null_site_release_option;
                  IFEND;
                IFEND;
                pfp$put_cycle_info (new_file_name_path, new_file_name_cycle_selector, password_selector,
                      cycle_array_entry, status);
                cycle_defined := status.normal;
                IF NOT status.normal AND ((status.condition = pfe$duplicate_cycle) OR
                      (status.condition = pfe$duplicate_offline_cycle)) THEN
                  status.normal := TRUE;
                IFEND;
              IFEND;
              IF status.normal THEN
                pup$restore_cycle_content (new_file_name_path, new_file_name_cycle_selector,
                      password_selector, record_header, label_exists, p_label, p_fmd, restore_selections,
                      mandated_modification_time, backup_file_id, file_position, cycle_length, status);
              IFEND;
 {Update the cycle statistics to those on the backup in case of replaced cycles
              IF status.normal AND (NOT puv$update_cycle_statistics) AND puv$replace_cycle_data THEN
                IF password_selector.password_specified = pfc$specific_password_option THEN
                  password := password_selector.password;
                ELSE
                  password := osc$null_name;
                IFEND;
                local_access_date_time.value_specified := TRUE;
                local_access_date_time.date_time :=  cycle_array_entry.cycle_statistics.access_date_time;
                local_creation_date_time.value_specified := TRUE;
                local_creation_date_time.date_time :=  cycle_array_entry.cycle_statistics.creation_date_time;
                local_mod_date_time.value_specified := TRUE;
                local_mod_date_time.date_time := cycle_array_entry.cycle_statistics.modification_date_time;
                PUSH p_path_string;
                pfp$convert_pf_cy_path_to_strng (new_file_name_path,
                      new_file_name_cycle_selector.cycle_number, p_path_string^);
                update_replaced_cycle_stats (p_path_string^.value (1, p_path_string^.size),
                      password, ^local_access_date_time, ^local_creation_date_time,
                      ^local_mod_date_time, status);
              IFEND;
              IF status.normal AND (cycle_array_entry.device_class = rmc$magnetic_tape_device)
                    AND (p_fmd <> NIL) THEN
                pfp$replace_rem_media_fmd (new_file_name_path, new_file_name_cycle_selector,
                      password_selector, p_fmd, status);
                IF NOT status.normal THEN
                  pup$display_line (' REMOVABLE MEDIA ATTRIBUTES PROBABLY LOST - UNUSABLE FILE ',
                        local_status);
                  pup$write_os_status (status, local_status);
                IFEND;
              IFEND;
            IFEND;
          IFEND;
          IF p_label <> NIL THEN
            FREE p_label;
          IFEND;
          IF p_fmd <> NIL THEN
            FREE p_fmd;
          IFEND;
        ELSE
          osp$set_status_abnormal (puc$pf_utility_id, pue$unusable_restore_file, ' unexpected file position',
                status);
        IFEND;
      IFEND;
    IFEND;
    IF status.normal THEN
      IF cycle_included THEN
        pup$write_cycle_display (new_file_entry, cycle_array_entry, cycle_length,
              puv$unknown_global_file_name, {recorded vsns} NIL, p_cycle_array_extended_record,
              p_cycle_directory_array, status);
        IF ((NOT puv$require_modification_match) OR puv$replace_cycle_data) AND
              (cycle_array_entry.cycle_statistics.modification_date_time <>
              mandated_modification_time.existing_modification_time) THEN
          IF puv$replace_cycle_data THEN
            display_date_time ('  -- Restore replaced data, modification date/time of previous data: ',
                  mandated_modification_time.existing_modification_time);
          ELSE
            display_date_time ('  -- Restore replaced modification, Previous modification time: ',
                  mandated_modification_time.existing_modification_time);
          IFEND;
        IFEND;
      IFEND;
    ELSE
      IF (NOT puv$create_objects) AND ((status.condition = pfe$unknown_permanent_file) OR
            (status.condition = pfe$unknown_cycle) OR (status.condition = pfe$unknown_last_subcatalog) OR
            (status.condition = pfe$unknown_nth_subcatalog)) THEN
        status.normal := TRUE;
      ELSE
        pup$write_status_to_listing (new_file_entry, status, local_status);
      IFEND;
    IFEND;
    IF cycle_defined AND NOT status.normal THEN
      pup$display_line (' cycle_defined and NOT status.normal, delete_file required', local_status);
    IFEND;
  PROCEND pup$restore_cycle_item;

?? TITLE := '    [XDCL] pup$restore_file_command ', EJECT ??

  PROCEDURE [XDCL] pup$restore_file_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      backup_file: amt$local_file_name,
      backup_file_id: put$file_identifier,
      cycle_entry: put$entry,
      cycle_selector: pft$cycle_selector,
      cycle_specified: boolean,
      dummy_cycle_selector: pft$cycle_selector,
      entry_type: put$entry_type,
      file_entry: put$entry,
      file_path_container: clt$path_container,
      local_status: ost$status,
      new_cycle_selector: pft$cycle_selector,
      new_cycle_specified: boolean,
      new_file_path_container: clt$path_container,
      p_catalog_header: ^put$catalog_header,
      p_file_path: ^pft$path,
      p_new_catalog_header: ^put$catalog_header,
      p_new_file_path: ^pft$path,
      p_selected_cycles: ^array [1 .. *] of put$selected_cycle_info,
      password: pft$password,
      password_specified: boolean,
      path_1_above_path_2: boolean,
      paths_equal: boolean;

    crack_restore_file (parameter_list, file_path_container, p_file_path, cycle_specified, cycle_selector,
          password, new_file_path_container, p_new_file_path, new_cycle_specified, new_cycle_selector,
          backup_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH p_selected_cycles: [1 .. 1];

    IF cycle_specified THEN
      p_selected_cycles ^[1].selected_cycle.cycle_specified := TRUE;
      p_selected_cycles ^[1].selected_cycle.cycle_selector := cycle_selector;
    ELSE
      p_selected_cycles ^[1].selected_cycle.cycle_specified := FALSE;
    IFEND;

    IF new_cycle_specified THEN
      p_selected_cycles ^[1].new_selected_cycle.cycle_specified := TRUE;
      p_selected_cycles ^[1].new_selected_cycle.cycle_selector := new_cycle_selector;
      IF NOT cycle_specified THEN
        cycle_specified := TRUE;
        cycle_selector.cycle_option := pfc$highest_cycle;
        p_selected_cycles ^[1].selected_cycle.cycle_specified := TRUE;
        p_selected_cycles ^[1].selected_cycle.cycle_selector := cycle_selector;
      IFEND;
    ELSE
      p_selected_cycles ^[1].new_selected_cycle.cycle_specified := FALSE;
    IFEND;

    pup$build_entry (p_file_path^ [UPPERBOUND (p_file_path^)], cycle_selector, puc$valid_pf_entry,
          file_entry);
    PUSH p_catalog_header: [1 .. UPPERBOUND (p_file_path^)];
    pup$build_catalog_header (osc$nosve_system_set, p_file_path, p_catalog_header^);
    PUSH p_new_catalog_header: [1 .. UPPERBOUND (p_new_file_path^)];
    pup$build_catalog_header (osc$nosve_system_set, p_new_file_path, p_new_catalog_header^);
    pup$validate_n_n_minus_1 (p_new_file_path^, puc$valid_pf_entry, dummy_cycle_selector, status);
    IF (cycle_specified OR new_cycle_specified) AND (NOT status.normal) AND
          (status.condition = pue$new_file_already_exists) THEN
      { Allow the cycle to be restored when the file already exists.
      status.normal := TRUE;
      password_specified := TRUE;
    ELSE
      password_specified := FALSE;
      password := osc$null_name;
    IFEND;
    IF status.normal THEN
      pup$open_backup_file (backup_file, puc$restore_permanent_files, amc$open_at_boi, backup_file_id,
            status);
      IF status.normal THEN
        IF cycle_specified THEN
          pup$build_entry (p_file_path^ [UPPERBOUND (p_file_path^)], cycle_selector,
                puc$valid_cycle_entry, cycle_entry);
          IF new_cycle_specified THEN
            pup$initialize_restore_listing ('RESTORE FILE CYCLE:', p_catalog_header^, cycle_entry,
                  p_new_file_path^, new_cycle_selector, status);
          ELSE
            pup$initialize_restore_listing ('RESTORE FILE CYCLE:', p_catalog_header^, cycle_entry,
                  p_new_file_path^, cycle_selector, status);
          IFEND;
        ELSE
          IF new_cycle_specified THEN
            pup$build_entry (p_file_path^ [UPPERBOUND (p_file_path^)], cycle_selector,
                  puc$valid_cycle_entry, cycle_entry);
            pup$initialize_restore_listing (' RESTORE FILE CYCLE: ', p_catalog_header^, cycle_entry,
                  p_new_file_path^, new_cycle_selector, status);
          ELSE
            pup$initialize_restore_listing (' RESTORE FILE: ', p_catalog_header^, file_entry,
                  p_new_file_path^, cycle_selector, status);
          IFEND;
        IFEND;
        IF status.normal THEN
          pup$set_restore_subcmd_defaults (NOT (avp$system_administrator() OR avp$family_administrator()));
          pup$restore_sub_levels (file_entry, p_catalog_header^, password_specified, password,
                p_new_catalog_header^, {restore_n_levels} TRUE, p_selected_cycles, backup_file_id, status);
        IFEND;
        pup$close_backup_file (backup_file_id, local_status);
        IF status.normal THEN
          status := local_status;
        IFEND;
        pup$display_restore_totals;
        pup$get_summary_status (status);
      IFEND;
    IFEND;
    pup$write_os_status (status, local_status);

  PROCEND pup$restore_file_command;

?? TITLE := '    [XDCL] pup$restore_label ', EJECT ??

  PROCEDURE [XDCL] pup$restore_label (
    VAR record_header: put$backup_file_record_header;
    VAR label_exists: boolean;
    VAR p_label: { output } ^SEQ ( * );
    VAR backup_file_id: put$file_identifier;
    VAR file_position: put$file_position;
    VAR status: ost$status);

    VAR
      local_status: ost$status,
      transfer_count: amt$file_length;

{   input system label
    p_label := NIL;
    pup$get_next_record_header (backup_file_id, record_header, file_position, status);
    IF status.normal THEN
      IF file_position = puc$mid_partition THEN
        IF record_header.kind = puc$backup_system_label THEN
          label_exists := record_header.size > 0;
          IF label_exists THEN
            ALLOCATE p_label: [[REP record_header.size OF cell]];
            RESET p_label;
            pup$get_part (backup_file_id, ^p_label^, #SIZE (p_label^), file_position, transfer_count,
                  status);
          ELSE
            ALLOCATE p_label: [[REP 5 OF cell]];
          IFEND;
        ELSE
          osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_item_requested, ' label ', status);
        IFEND;
      ELSE
        osp$set_status_abnormal (puc$pf_utility_id, pue$unusable_restore_file, 'unexpected file position',
              status);
      IFEND;
    IFEND;
{
    IF status.normal THEN
      IF file_position = puc$mid_partition THEN
        pup$skip_hierarchy_list (backup_file_id, file_position, status);
      ELSE
        osp$set_status_abnormal (puc$pf_utility_id, pue$unusable_restore_file, ' unexpected file position',
              status);
      IFEND;
    IFEND;
{  input cycle data
    IF status.normal THEN
      IF file_position = puc$mid_partition THEN
        pup$get_next_record_header (backup_file_id, record_header, file_position, status);
        IF file_position = puc$partition_boundary THEN
          display (' puc$partition_boundary');
          status.normal := TRUE;
        ELSEIF NOT status.normal THEN
          pup$display_line (' FILE DATA OR ATTRIBUTES POSSIBLY LOST.', local_status);
        IFEND;
        display_status (status);
      ELSE
        osp$set_status_abnormal (puc$pf_utility_id, pue$unusable_restore_file, 'unexpected file position',
              status);
      IFEND;
    IFEND;
  PROCEND pup$restore_label;

?? TITLE := '    [XDCL] pup$skip_hierarchy_list ', EJECT ??

  PROCEDURE [XDCL] pup$skip_hierarchy_list
    (VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    VAR
      p_hierarchy_list: ^put$hierarchy_list,
      record_header: put$backup_file_record_header;

    pup$get_next_record_header (backup_file_id, record_header, file_position, status);
    IF status.normal THEN
      IF file_position = puc$mid_partition THEN
        IF (record_header.kind = puc$backup_hierarchy_list) AND (record_header.size >= 1) THEN
          PUSH p_hierarchy_list: [1 .. record_header.size];
          pup$get_next_hierarchy_list (backup_file_id, p_hierarchy_list^, file_position, status);
        ELSE
          osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_item_requested, ' hierarchy list',
                status);
        IFEND;
      ELSE
        osp$set_status_abnormal (puc$pf_utility_id, pue$unusable_restore_file, 'unexpected file position',
              status);
      IFEND;
    IFEND;
  PROCEND pup$skip_hierarchy_list;

?? TITLE := '    crack_restore_file ', EJECT ??

  PROCEDURE crack_restore_file
    (    parameter_list: clt$parameter_list;
     VAR file_path_container: clt$path_container;
     VAR p_file_path: ^pft$path;
     VAR cycle_specified: boolean;
     VAR cycle_selector: pft$cycle_selector;
     VAR password: pft$password;
     VAR new_file_path_container: clt$path_container;
     VAR p_new_file_path: ^pft$path;
     VAR new_cycle_specified: boolean;
     VAR new_cycle_selector: pft$cycle_selector;
     VAR backup_file: amt$local_file_name;
     VAR status: ost$status);

{ PROCEDURE (osm$resf) restore_file, resf (
{   file, f: file = $required
{   backup_file, bf: file = $required
{   password, pw: (SECURE) any of
{       key
{         none
{       keyend
{       name
{     anyend = none
{   new_file_name, nfn: file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 9] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: 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$name_type_qualifier,
          recend,
          default_value: string (4),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [87, 10, 20, 12, 57, 54, 434], clc$command, 9, 5, 2, 0, 0, 0, 5, 'OSM$RESF'],
            [['BACKUP_FILE                    ', clc$nominal_entry, 2],
            ['BF                             ', clc$abbreviation_entry, 2],
            ['F                              ', clc$abbreviation_entry, 1],
            ['FILE                           ', clc$nominal_entry, 1],
            ['NEW_FILE_NAME                  ', clc$nominal_entry, 4],
            ['NFN                            ', clc$abbreviation_entry, 4],
            ['PASSWORD                       ', clc$nominal_entry, 3],
            ['PW                             ', clc$abbreviation_entry, 3],
            ['STATUS                         ', clc$nominal_entry, 5]], [
{ PARAMETER 1
      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 3
      [7, clc$normal_usage_entry, clc$secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 69, clc$optional_default_parameter, 0, 4],
{ PARAMETER 4
      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 5
      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$file_type]],
{ PARAMETER 2
      [[1, 0, clc$file_type]],
{ PARAMETER 3
      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]], 'none'],
{ PARAMETER 4
      [[1, 0, clc$file_type]],
{ PARAMETER 5
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$file = 1,
      p$backup_file = 2,
      p$password = 3,
      p$new_file_name = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      evaluated_file_reference: fst$evaluated_file_reference;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_pf_file_reference (pvt [p$file].value^.file_value^,
          $put$cycle_reference_selections [puc$cycle_omitted, puc$lowest_cycle, puc$highest_cycle,
          puc$specific_cycle], 'FILE', file_path_container, p_file_path, cycle_specified, cycle_selector,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_backup_file (pvt [p$backup_file].value^.file_value^, backup_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$password].value^.kind = clc$name THEN
      password := pvt [p$password].value^.name_value;
    ELSE {keyword = NONE}
      password := osc$null_name;
    IFEND;

    IF pvt [p$new_file_name].specified THEN
      pup$crack_pf_file_reference (pvt [p$new_file_name].value^.file_value^,
            $put$cycle_reference_selections [puc$cycle_omitted, puc$specific_cycle, puc$next_highest_cycle],
            'NEW_FILE_NAME', new_file_path_container, p_new_file_path, new_cycle_specified,
            new_cycle_selector, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF new_cycle_specified THEN
        clp$evaluate_file_reference (pvt [p$new_file_name].value^.file_value^,
              $clt$file_ref_parsing_options [], {resolve_cycle_number} TRUE, evaluated_file_reference,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        new_cycle_selector.cycle_option := pfc$specific_cycle;
        new_cycle_selector.cycle_number := evaluated_file_reference.cycle_reference.cycle_number;
      IFEND;
    ELSE
      new_cycle_specified := FALSE;
      p_new_file_path := p_file_path;
    IFEND;

  PROCEND crack_restore_file;

?? TITLE := '    define_cycle_contents', EJECT ??

  PROCEDURE define_cycle_contents
    (    new_file_name_path: pft$path;
         new_file_name_cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         label_exists: boolean;
         label: SEQ ( * );
         p_fmd: ^SEQ ( * );
         restore_selections: put$restore_data_selections;
         cycle_length: amt$file_length;
     VAR mandated_modification_time: pft$mandated_modification_time;
     VAR backup_file_id: put$file_identifier;
     VAR file_position: { input, output } put$file_position;
     VAR status: ost$status);

{ This routine restores a cycle's label and contents.

  PROCEDURE restore_abort_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    VAR
      exception_information: ^ost$condition_information,
      condition_status: ost$status,
      construction_status: ost$status,
      display_status: ost$status;

    CASE condition.selector OF
    = pmc$system_conditions, mmc$segment_access_condition =
      {
      { Display the reason for the condition.
      {
      pup$display_line (' Condition occurred in restoring cycle.', display_status);
      osp$set_status_from_condition (puc$pf_utility_id, condition, save_area, condition_status,
            construction_status);
      IF construction_status.normal THEN
        pup$write_os_status (condition_status, display_status);
      ELSE
        pup$write_os_status (construction_status, display_status);
      IFEND;
      osp$set_status_abnormal (puc$pf_utility_id, pue$restore_condition, '', status);
      current_pf_lfn_usable := FALSE;
      EXIT define_cycle_contents;
    = pmc$user_defined_condition =
      {
      { Process file exception conditions that occur on the call to pfp$define_data or
      { during segment access.  The raised_conditions set is initialized so no condition is
      { raised by osp$enforce_exception_policies should the policy be to wait; this would cause
      { a death spiral of recursion.  If the policy is to wait, we simply exit this handler to
      { retry whatever we were doing.  Otherwise, we exit the restore with abnormal status.
      {

      IF (condition.user_condition_name = osc$volume_unavailable_cond) OR (condition.user_condition_name =
           osc$space_unavailable_condition) THEN

        exception_information := condition_information;
        IF exception_information <> NIL THEN
          context^.condition_status := exception_information^.exception_status;
        ELSEIF condition.user_condition_name = osc$space_unavailable_condition THEN
          osp$set_status_condition (ame$space_unavailable, context^.condition_status);
        ELSEIF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$set_status_condition (pfe$volume_unavailable, context^.condition_status);
        IFEND;

        osp$enforce_exception_policies (context^);
        #SPOIL (context^);

        IF (NOT osp$file_access_condition (context^.condition_status)) OR (NOT context^.wait) THEN
          {
          { Display the reason for the condition.
          {
          pup$display_line (' Condition occurred in restoring cycle.', display_status);
          pup$write_os_status (context^.condition_status, display_status);
          osp$set_status_abnormal (puc$pf_utility_id, pue$restore_condition, '', status);

          current_pf_lfn_usable := FALSE;
          EXIT define_cycle_contents;
        IFEND;
      IFEND;
    ELSE
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    CASEND;
  PROCEND restore_abort_handler;

?? EJECT ??

    VAR
      allocation_size: rmt$allocation_size,
      caller_id: ost$caller_identifier,
      context: ^ost$ecp_exception_context,
      current_pf_lfn_usable: [STATIC] boolean := FALSE,
      data_residence: pft$data_residence,
      externalized_info: ost$condition_information,
      fmd_header_info: pft$fmd_header,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      ignore_status: ost$status,
      initial_volume: rmt$recorded_vsn,
      local_label_exists: boolean,
      local_status: ost$status,
      mass_storage_class: rmt$mass_storage_class,
      mass_storage_class_string: string (1),
      mass_storage_request_info: fmt$mass_storage_request_info,
      new_pf_lfn: [STATIC] amt$local_file_name,
      p_release_data_info: ^pft$release_data_info,
      password: pft$password,
      pu_status: ost$status,
      set_name: stt$set_name,
      transfer_count: amt$file_length,
      transfer_size: fst$transfer_size,
      validate_mass_storage_info: boolean,
      volume_overflow_allowed: boolean;

    #CALLER_ID (caller_id);

    PUSH context;
    context^ := osv$initial_exception_context;
    context^.file.selector := osc$ecp_pf_path;
    context^.file.pf_path := ^new_file_name_path;
    context^.file.cycle_selector := new_file_name_cycle_selector;
    context^.raised_conditions := -$fst$file_access_conditions [];
    IF password_selector.password_specified = pfc$specific_password_option THEN
      context^.password := password_selector.password;
    IFEND;
    #SPOIL (context^);

    osp$establish_condition_handler (^restore_abort_handler, { block_exit = } FALSE);

    IF NOT current_pf_lfn_usable THEN
      pmp$get_unique_name (new_pf_lfn, ignore_status);
    IFEND;

    mass_storage_request_info := puv$mass_storage_info;
    validate_mass_storage_info := FALSE;

    IF p_fmd <> NIL THEN
      dmp$get_stored_fmd_header_info (p_fmd, fmd_header_info, status);
      IF status.normal THEN

        allocation_size := puv$mass_storage_info.allocation_size;
        IF puv$mass_storage_info.allocation_size = rmc$unspecified_allocation_size THEN
          allocation_size := fmd_header_info.requested_allocation_size;
        IFEND;

        transfer_size := puv$mass_storage_info.transfer_size;
        IF puv$mass_storage_info.transfer_size = rmc$unspecified_transfer_size THEN
          transfer_size := fmd_header_info.requested_transfer_size;
        IFEND;

        mass_storage_class := puv$mass_storage_info.mass_storage_class;
        IF puv$mass_storage_info.mass_storage_class = rmc$unspecified_file_class THEN
          mass_storage_class := fmd_header_info.requested_class;
          IF (NOT avp$system_administrator ())
                AND (fmd_header_info.requested_class <> rmc$msc_user_permanent_files) THEN
            validate_mass_storage_info := TRUE;
          IFEND;
        IFEND;

        initial_volume := puv$mass_storage_info.initial_volume;
        IF puv$mass_storage_info.initial_volume = rmc$unspecified_vsn THEN
          IF fmd_header_info.requested_volume.recorded_vsn <> rmc$unspecified_vsn THEN
            pfp$get_family_set (new_file_name_path [pfc$family_name_index], set_name, status);
            IF status.normal AND (set_name= fmd_header_info.requested_volume.setname) THEN
              initial_volume := fmd_header_info.requested_volume.recorded_vsn;
              validate_mass_storage_info := TRUE;
            IFEND;
          IFEND;
        IFEND;

        volume_overflow_allowed := puv$mass_storage_info.volume_overflow_allowed;
        IF avp$system_administrator () AND puv$mass_storage_info.volume_overflow_allowed THEN
            volume_overflow_allowed := fmd_header_info.overflow_allowed;
        IFEND;
      IFEND;

      IF status.normal THEN
        display (' rmp$build_mass_storage_info');
        rmp$build_mass_storage_info (allocation_size, rmc$unspecified_file_size, initial_volume,
              mass_storage_class, puv$mass_storage_info.shared_queue, transfer_size,
              volume_overflow_allowed, caller_id.ring, ^mass_storage_request_info, status);
      IFEND;
    IFEND;

    IF NOT status.normal THEN
      pfp$convert_pft$path_to_fs_path (new_file_name_path, fs_path, fs_path_size);
      osp$set_status_abnormal (puc$pf_utility_id, pue$original_ms_attr_ignored,
            fs_path (1, fs_path_size), pu_status);
      pup$write_os_status (pu_status, ignore_status);
      pup$write_os_status (status, ignore_status);
      mass_storage_request_info := puv$mass_storage_info;
      validate_mass_storage_info := FALSE;
    IFEND;

    IF validate_mass_storage_info THEN
      display (' rmp$validate_mass_storage_info');
      pfp$get_family_set (new_file_name_path [pfc$family_name_index], set_name, status);
      IF status.normal THEN
        rmp$validate_mass_storage_info (set_name, {object_permanent} TRUE,
              {object_type} pfc$file_object, ^mass_storage_request_info, status);
      IFEND;
      IF NOT status.normal THEN
        IF (status.condition = rme$unknown_volume)
              OR (status.condition = rme$vsn_not_part_of_set) THEN
          pfp$convert_pft$path_to_fs_path (new_file_name_path, fs_path, fs_path_size);
          osp$set_status_abnormal (puc$pf_utility_id, pue$original_init_vol_ignored,
                fs_path (1, fs_path_size), pu_status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                mass_storage_request_info.initial_volume, pu_status);
          pup$write_os_status (pu_status, ignore_status);
          pup$write_os_status (status, ignore_status);
          mass_storage_request_info := puv$mass_storage_info;
        ELSEIF  status.condition = rme$file_class_not_valid THEN
          pfp$convert_pft$path_to_fs_path (new_file_name_path, fs_path, fs_path_size);
          osp$set_status_abnormal (puc$pf_utility_id, pue$original_file_class_ignored,
                fs_path (1, fs_path_size), pu_status);
          mass_storage_class_string := mass_storage_request_info.mass_storage_class;
          osp$append_status_parameter (osc$status_parameter_delimiter, mass_storage_class_string, pu_status);
          pup$write_os_status (pu_status, ignore_status);
          pup$write_os_status (status, ignore_status);
          mass_storage_request_info := puv$mass_storage_info;
        ELSE
          pfp$convert_pft$path_to_fs_path (new_file_name_path, fs_path, fs_path_size);
          osp$set_status_abnormal (puc$pf_utility_id, pue$original_ms_attr_ignored,
                fs_path (1, fs_path_size), pu_status);
          pup$write_os_status (pu_status, ignore_status);
          IF status.condition <> rme$job_not_valid THEN
            pup$write_os_status (status, ignore_status);
          IFEND;
          mass_storage_request_info := puv$mass_storage_info;
        IFEND;
      IFEND;
    IFEND;

    display (' pfp$define_data');
  /define_data/
    WHILE TRUE DO
      pfp$define_data (new_pf_lfn, new_file_name_path, new_file_name_cycle_selector,
            puv$update_cycle_statistics, password_selector, ^mass_storage_request_info,
            puv$p_included_volumes, puv$purge_cycle_options, puv$replace_cycle_data, restore_selections,
            {wait_on_volume} (mass_storage_request_info.initial_volume = rmc$unspecified_vsn),
            mandated_modification_time, data_residence, status);
      IF NOT status.normal THEN
        IF ((status.condition = pfe$volume_unavailable) OR (status.condition = pfe$volume_not_online)) THEN
          {
          { This case only occurs if the INITIAL_VOLUME option was chosen
          {
          pfp$convert_pft$path_to_fs_path (new_file_name_path, fs_path, fs_path_size);
          osp$set_status_abnormal (puc$pf_utility_id, pue$original_init_vol_ignored,
                fs_path (1, fs_path_size), pu_status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                mass_storage_request_info.initial_volume, pu_status);
          pup$write_os_status (pu_status, ignore_status);
          pup$write_os_status (status, ignore_status);
          mass_storage_request_info.initial_volume := rmc$unspecified_vsn;
          CYCLE /define_data/;
        ELSEIF osp$file_access_condition (status) THEN
          {
          { The most likely condition is space unavailable but we do not assume
          { it.  We merely choose it as a representative file access condition
          { to raise.  This invokes the restore_abort_handler to process this
          { condition from pfp$define_data in the same manner as would occur
          { during data access.  If a wait policy is in effect, the wait occurs
          { in the handler defined for this procedure.  After the wait, we
          { retry pfp$define_data.  If no wait is to occur, we exit
          { DEFINE_CYCLE_DATA from the restore_abort_handler and do not return
          { here.
          {

          externalized_info.when_handler_status := TRUE;
          externalized_info.exception_status := status;
          pmp$cause_task_condition (osc$space_unavailable_condition, ^externalized_info,
                {notify_scl} TRUE, {notify_debug} FALSE, {propagate_to_parent} TRUE,
                {call_default_handler} FALSE, ignore_status);
          CYCLE /define_data/;
        IFEND;
      IFEND;
      EXIT /define_data/;
    WHILEND;

    IF status.normal THEN
    { While retrieving a file, the label is not restored,
    { because the label in the catalog may be more current.
      local_label_exists := label_exists AND (puv$replace_cycle_data OR (data_residence <> pfc$offline_data));
      input_cycle_contents (cycle_length, data_residence, new_pf_lfn, local_label_exists, label,
            new_file_name_path, new_file_name_cycle_selector, password_selector, backup_file_id,
            file_position, transfer_count, status);
      IF status.normal THEN
        number_of_cycles_restored := number_of_cycles_restored + 1;
        total_cycle_data_restored := total_cycle_data_restored + transfer_count;
      ELSE
        display_status (status);
        IF status.condition <> ame$ring_validation_error THEN
          pup$display_line (' FILE DATA OR ATTRIBUTES POSSIBLY LOST.', ignore_status);
        IFEND;
      IFEND;

      display (' Amp$return user''s new permanent file.');
      amp$return (new_pf_lfn, local_status);
      IF puv$trace_selected THEN
        IF NOT local_status.normal THEN
          IF status.normal THEN
            status := local_status;
          IFEND;
          pup$write_os_status (local_status, ignore_status);
        IFEND;
      IFEND;
    IFEND;

    IF (data_residence = pfc$offline_data) AND (NOT puv$update_cycle_statistics) THEN
      IF status.normal AND (transfer_count = cycle_length) THEN
        pfp$change_res_to_releasable (new_file_name_path, new_file_name_cycle_selector, ignore_status);
      ELSE
        IF password_selector.password_specified = pfc$default_password_option THEN
          password := osc$null_name;
        ELSE
          password := password_selector.password;
        IFEND;

        PUSH p_release_data_info;
        p_release_data_info^.perform_changes := TRUE;
        p_release_data_info^.release_attached_cycle_data := TRUE;
        p_release_data_info^.update_last_release_date_time := FALSE;
        p_release_data_info^.valid_archive_entry_required := TRUE;

        REPEAT
          pfp$r3_release_data (new_file_name_path, new_file_name_cycle_selector, password,
                p_release_data_info, local_status);
          IF NOT local_status.normal THEN
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_pf_path;
            context^.file.pf_path := ^new_file_name_path;
            context^.file.cycle_selector := new_file_name_cycle_selector;
            context^.password := password;
            context^.condition_status := local_status;
            osp$enforce_exception_policies (context^);
            local_status := context^.condition_status;
          IFEND;
        UNTIL local_status.normal OR (NOT osp$file_access_condition (local_status)) OR (NOT context^.wait);
      IFEND;
    IFEND;

    current_pf_lfn_usable := status.normal;
  PROCEND define_cycle_contents;

?? TITLE := '    define_released_cycle', EJECT ??

  PROCEDURE define_released_cycle
    (    new_file_name_path: pft$path;
         new_file_name_cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         label_exists: boolean;
         p_label: ^SEQ ( * );
     VAR status: ost$status);

  PROCEDURE released_restore_abort_handler
    (    condition: pmt$condition;
         condition_information: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR handler_status: ost$status);

    VAR
      condition_status: ost$status,
      construction_status: ost$status,
      display_status: ost$status;

    IF (condition.selector = pmc$system_conditions) OR (condition.selector = mmc$segment_access_condition)
          THEN
      { Display the reason for the condition.
      pup$display_line (' Condition occurred in restoring cycle.', display_status);
      osp$set_status_from_condition (puc$pf_utility_id, condition, save_area, condition_status,
            construction_status);
      IF construction_status.normal THEN
        pup$write_os_status (condition_status, display_status);
      ELSE
        pup$write_os_status (construction_status, display_status);
      IFEND;
      osp$set_status_abnormal (puc$pf_utility_id, pue$restore_condition, '', status);
      EXIT define_released_cycle;
    ELSE
      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
    IFEND;
  PROCEND released_restore_abort_handler;

?? EJECT ??

    VAR
      local_status: ost$status;

    osp$establish_condition_handler (^released_restore_abort_handler, { block_exit } FALSE);

    status.normal := TRUE;
    IF label_exists THEN
      input_cycle_label (new_file_name_path, new_file_name_cycle_selector, password_selector, p_label,
            status);
    IFEND;
    IF status.normal THEN
      number_of_cycles_restored := number_of_cycles_restored + 1;
    ELSEIF puv$create_objects THEN
      display_status (status);
      pup$display_line (' FILE ATTRIBUTES POSSIBLY LOST.', local_status);
    IFEND;
  PROCEND define_released_cycle;

?? TITLE := '    display_date_time ', EJECT ??

  PROCEDURE display_date_time
    (    descriptor: string ( * <= 90);
         date_time: ost$date_time);

    VAR
      status: ost$status,
      working_string: string (120),
      date_time_string: string (30);

    working_string := descriptor;
    pup$format_date_time (date_time, date_time_string);
    working_string ((STRLENGTH (descriptor) + 1), * ) := date_time_string;
    pup$display_line (working_string (1, (STRLENGTH (descriptor) + 30)), status);
  PROCEND display_date_time;

?? TITLE := '    input_cycle_contents ', EJECT ??

  PROCEDURE input_cycle_contents
    (   file_length: amt$file_length;
        data_residence: pft$data_residence;
        new_pf_lfn: amt$local_file_name;
        label_exists: boolean;
        label: SEQ ( * );
        path: pft$path;
        cycle_selector: pft$cycle_selector;
        password_selector: pft$password_selector;
    VAR backup_file_id: put$file_identifier;
    VAR file_position: put$file_position;
    VAR transfer_count: amt$file_length;
    VAR status: ost$status);

{  This routine reads in the cycle data and label into a defined file.

    VAR
      caller_id: ost$caller_identifier,
      cycle_segment: mmt$segment_pointer,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      local_status: ost$status,
      password: pft$password,
      purge_cycle_options: pft$purge_cycle_options,
      restore_label_status: ost$status;

    status.normal := TRUE;
    transfer_count := 0;

    IF file_length > 0 THEN
      pup$open_file_for_seg_access (new_pf_lfn, cycle_segment, status);
      IF status.normal THEN
        restore_label_status.normal := TRUE;
        #CALLER_ID (caller_id);

      /store_label_and_data/
        BEGIN
          IF label_exists THEN

            { The restore label is done here since the restore label routine enforces that the
            { file must have an eoi of 0. IF the restore_label was done prior to the open, the
            { open would prevent restoring a file with rings lower than the running ring.
            {
            { NOTE:  the restore_label will prevent restoring files with r1 lower than
            { the user's minimum valid ring UNLESS one is the SYSTEM ADMINISTRATOR.

            display (' srp$store_system_label');
            srp$store_system_label (new_pf_lfn, label, restore_label_status);
            display_status (restore_label_status);
            IF NOT restore_label_status.normal THEN
              IF restore_label_status.condition = ame$ring_validation_error THEN
                status := restore_label_status;
                amp$return (new_pf_lfn, local_status);
                purge_cycle_options.enforce_password_validation := FALSE;
                purge_cycle_options.enforce_ring_validation := FALSE;
                purge_cycle_options.preserve_cycle_entry := FALSE;
                pfp$delete_cycle_data (path, cycle_selector, {password} osc$null_name,
                      purge_cycle_options, local_status);
                osp$set_status_abnormal (amc$access_method_id, ame$ring_validation_error,
                      '', status);
                pfp$convert_pft$path_to_fs_path (path, fs_path, fs_path_size);
                osp$append_status_file (osc$status_parameter_delimiter,
                      fs_path (1, fs_path_size), status);
                osp$append_status_parameter (osc$status_parameter_delimiter,
                      'restore', status);
                EXIT /store_label_and_data/;
              ELSE
                pup$display_line (' FILE ATTRIBUTES PROBABLY LOST - RESTORING DATA', local_status);
                pup$write_os_status (restore_label_status, local_status);
              IFEND;
            IFEND;
          IFEND;
          display_integer (' get the user''s file data restored:', file_length);
          pup$advised_get_part (backup_file_id, cycle_segment.seq_pointer, file_length,
                file_position, transfer_count, status);
          display_integer (' pup$advised_get_part complete:', transfer_count);
          IF (data_residence = pfc$offline_data) AND (NOT puv$update_cycle_statistics) THEN
            mmp$set_segment_length (cycle_segment.seq_pointer, caller_id.ring, file_length, local_status);
            display_integer (' mmp$set_segment_length complete:', file_length);
          ELSE
            mmp$set_segment_length (cycle_segment.seq_pointer, caller_id.ring, transfer_count, local_status);
            display_integer (' mmp$set_segment_length complete:', transfer_count);
          IFEND;
          IF NOT local_status.normal THEN
            pup$write_os_status (local_status, local_status);
          IFEND;
        END /store_label_and_data/;

        mmp$close_segment (cycle_segment, caller_id.ring, local_status);
        IF NOT local_status.normal THEN
          pup$write_os_status (local_status, local_status);
        IFEND;
        IF status.normal THEN
          IF restore_label_status.normal THEN
            status := local_status;
          ELSE
            status := restore_label_status;
          IFEND;
        IFEND;
      IFEND;

    ELSE { No data in file
      IF label_exists THEN
        input_cycle_label (path, cycle_selector, password_selector, ^label, status);
      IFEND;
    IFEND;
  PROCEND input_cycle_contents;

?? TITLE := '    input_cycle_label ', EJECT ??

  PROCEDURE input_cycle_label
    (   path: pft$path;
        cycle_selector: pft$cycle_selector;
        password_selector: pft$password_selector;
        p_label: fmt$p_file_label;
    VAR status: ost$status);

    VAR
      local_status: ost$status;

    display (' pfp$save_released_file_label');
    pfp$save_released_file_label (path, cycle_selector, puv$update_cycle_statistics, password_selector,
          p_label, status);
    IF NOT status.normal AND puv$create_objects THEN
      pup$display_line (' FILE ATTRIBUTES PROBABLY LOST - EMPTY FILE ', local_status);
      pup$write_os_status (status, local_status);
    IFEND;
  PROCEND input_cycle_label;

?? TITLE := 'update_replaced_cycle_stats', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to update the cycle statistics of a
{   replaced cycle
{

  PROCEDURE update_replaced_cycle_stats
    (    file: fst$file_reference;
         password: pft$password;
         p_new_access_date_time: ^fst$date_time;
         p_new_creation_date_time: ^fst$date_time;
         p_new_modification_date_time: ^fst$date_time;
     VAR status: ost$status);

    VAR
      context: ^ost$ecp_exception_context;

    context := NIL;

    REPEAT
      pfp$r3_change_cycle_date_time (file, password, p_new_access_date_time, p_new_creation_date_time,
            p_new_modification_date_time, status);
      IF NOT status.normal THEN
        IF context = NIL THEN
          PUSH context;
          context^ := osv$initial_exception_context;
          context^.file.selector := osc$ecp_file_reference;
          context^.file.file_reference := ^file;
          context^.password := password;
        IFEND;
        context^.condition_status := status;
        osp$enforce_exception_policies (context^);
        status := context^.condition_status;
      IFEND;
    UNTIL status.normal OR (NOT osp$file_access_condition (status)) OR (NOT context^.wait);

  PROCEND update_replaced_cycle_stats;

MODEND pum$restore_file;
*DECK DECK=PUM$RESTORE_MISSING_CATALOGS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  restore_missing_catalogs ', EJECT ??
MODULE pum$restore_missing_catalogs;

{  This contains processing for the RESTORE_MISSING_CATALOGS and
{  the SET_RESTORE_MISSING_CATALOGS subcommands.

?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avp$family_administrator
*copyc avp$system_administrator
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc osc$nosve_system_set
*copyc osd$integer_limits
*copyc osp$set_status_abnormal
*copyc pfe$error_condition_codes
*copyc pfp$build_sorted_dfl
*copyc pfp$detach_jobs_catalogs
*copyc pfp$get_family_set
*copyc pfp$find_cycle_array_extended
*copyc pfp$find_cycle_directory
*copyc pfp$put_catalog_media_info
*copyc pfp$put_file_media_info
*copyc pfp$set_restore_status
*copyc pft$cycle_count
*copyc pue$error_condition_codes
*copyc pup$build_catalog_header
*copyc pup$build_entry
*copyc pup$close_backup_file
*copyc pup$compare_item_descriptor
*copyc pup$crack_catalog
*copyc pup$crack_file
*copyc pup$crack_resefc_selection
*copyc pup$display_integer
*copyc pup$display_line
*copyc pup$display_restore_totals
*copyc pup$get_item_descriptor
*copyc pup$get_next_record_header
*copyc pup$get_part
*copyc pup$get_summary_status
*copyc pup$initialize_restore_listing
*copyc pup$locate_valid_version
*copyc pup$open_backup_file
*copyc pup$restore_cycle_if_excluded
*copyc pup$set_abnormal_entry_status
*copyc pup$set_restore_subcmd_defaults
*copyc pup$skip_logical_partition
*copyc pup$verify_system_administrator
*copyc pup$write_os_status
*copyc pup$write_path
*copyc puv$respf_backup_file_version
*copyc puv$cycle_display_selections
?? POP ??
?? TITLE := '    Global Variables', EJECT ??

  VAR
    puv$catalogs_recovered: ost$non_negative_integers := 0,
    puv$catalogs_recreated: ost$non_negative_integers := 0,
    puv$cycles_entry_recreated: ost$non_negative_integers := 0,
    puv$cycles_fmd_restored: ost$non_negative_integers := 0;

?? TITLE := '    [XDCL] pup$restore_missing_catalogs_cm ', EJECT ??

  PROCEDURE [XDCL] pup$restore_missing_catalogs_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      backup_file_id: put$file_identifier,
      backup_file_lfn: amt$local_file_name,
      catalog_entry: put$entry,
      catalog_path_container: clt$path_container,
      catalog_type: put$entry_type,
      dummy_cycle_selector: pft$cycle_selector,
      local_status: ost$status,
      p_catalog_header: ^put$catalog_header,
      p_catalog_path: ^pft$path,
      restore_excluded_file_cycles: put$restore_data_selections,
      set_name: stt$set_name;

    pup$verify_system_administrator ('RESTORE_MISSING_CATALOGS', NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    crack_restore_missing_catalogs (parameter_list, catalog_type, p_catalog_path, catalog_path_container,
          restore_excluded_file_cycles, backup_file_lfn, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF catalog_type = puc$valid_set_entry THEN
      pup$build_entry (osc$nosve_system_set, dummy_cycle_selector, catalog_type, catalog_entry);
      PUSH p_catalog_header: [1 .. 1];
      pup$build_catalog_header (osc$nosve_system_set, NIL, p_catalog_header^);
    ELSE { Family, Master catalog, or Subcatalog }
      pfp$get_family_set (p_catalog_path^ [pfc$family_name_index], set_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pup$build_entry (p_catalog_path^ [UPPERBOUND (p_catalog_path^)], dummy_cycle_selector, catalog_type,
            catalog_entry);
      PUSH p_catalog_header: [1 .. UPPERBOUND (p_catalog_path^)];
      pup$build_catalog_header (set_name, p_catalog_path, p_catalog_header^);
    IFEND;

    pup$open_backup_file (backup_file_lfn, puc$restore_permanent_files, amc$open_at_boi, backup_file_id,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$set_restore_subcmd_defaults (NOT (avp$system_administrator() OR avp$family_administrator()));

    pfp$build_sorted_dfl (status);
    IF NOT status.normal THEN
      pup$close_backup_file (backup_file_id, local_status);
      RETURN;
    IFEND;


    pup$initialize_restore_listing (' RESTORE MISSING CATALOGS  ', p_catalog_header^, catalog_entry,
          p_catalog_header^.path, dummy_cycle_selector, status);

    puv$catalogs_recovered := 0;
    puv$catalogs_recreated := 0;
    puv$cycles_entry_recreated := 0;
    puv$cycles_fmd_restored := 0;
    restore_missing_catalogs (catalog_entry, p_catalog_header^, restore_excluded_file_cycles, backup_file_id,
          status);
    pup$close_backup_file (backup_file_id, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

    pup$display_restore_totals;
    pup$display_integer ('   NUMBER OF CATALOGS RECOVERED ', puv$catalogs_recovered, local_status);
    pup$display_integer ('   NUMBER OF CATALOGS RECREATED FROM BACKUP ', puv$catalogs_recreated,
          local_status);
    pup$display_integer ('   NUMBER OF CYCLE ENTRIES RECREATED ', puv$cycles_entry_recreated, local_status);
    pup$display_integer ('   NUMBER OF CYCLES DATA RECOVERED ', puv$cycles_fmd_restored, local_status);

    pup$get_summary_status (status);
    pup$write_os_status (status, local_status);

    pfp$detach_jobs_catalogs;

  PROCEND pup$restore_missing_catalogs_cm;
?? TITLE := '  [XDCL] pup$set_restore_missing_catalog ', EJECT ??

  PROCEDURE [XDCL] pup$set_restore_missing_catalog
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{  pdt set_restore_missing_cat (
{    operation, o: key start, end = $required
{    status)

?? PUSH (LISTEXT := ON) ??

    VAR
      set_restore_missing_cat: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^set_restore_missing_cat_names, ^set_restore_missing_cat_params];

    VAR
      set_restore_missing_cat_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['OPERATION', 1], ['O', 1], ['STATUS', 2]];

    VAR
      set_restore_missing_cat_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
            clt$parameter_descriptor := [

{ OPERATION O }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed,
            [^set_restore_missing_cat_kv1, clc$keyword_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      set_restore_missing_cat_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of
            ost$name := ['START', 'END'];

?? POP ??

    VAR
      value: clt$value;

    pup$verify_system_administrator ('SET_RESTORE_MISSING_CATALOGS', NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, set_restore_missing_cat, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('OPERATION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.name.value = 'START' THEN
      pfp$set_restore_status ({restore_missing_catalogs_done= } FALSE, status);
      IF status.normal THEN
        pup$display_line ('SET_RESTORE_MISSING_CATALOG OPERATION=START', status);
      IFEND;
    ELSE {'END'
      pfp$set_restore_status ({restore_missing_catalogs_done= } TRUE, status);
      IF status.normal THEN
        pup$display_line ('SET_RESTORE_MISSING_CATALOG OPERATION=END', status);
      IFEND;
    IFEND;

  PROCEND pup$set_restore_missing_catalog;
?? TITLE := '    crack_restore_missing_catalogs ', EJECT ??

  PROCEDURE crack_restore_missing_catalogs
    (    parameter_list: clt$parameter_list;
     VAR catalog_type: put$entry_type;
     VAR p_catalog_path: ^pft$path;
     VAR catalog_path_container: clt$path_container;
     VAR restore_excluded_file_cycles: put$restore_data_selections;
     VAR backup_file: amt$local_file_name;
     VAR status: ost$status);



{ PDT restore_missing_cats_pdt (
{  catalog, c: file
{  restore_excluded_file_cycles, refc: list of key none, media_missing mm ..
{     no_data_defined ndd volume_unavailable vu = (media_missing no_data_defined)
{  backup_file, bf: file = $required
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      restore_missing_cats_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^restore_missing_cats_pdt_names, ^restore_missing_cats_pdt_params];

    VAR
      restore_missing_cats_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
            clt$parameter_name_descriptor := [['CATALOG', 1], ['C', 1], ['RESTORE_EXCLUDED_FILE_CYCLES', 2],
            ['REFC', 2], ['BACKUP_FILE', 3], ['BF', 3], ['STATUS', 4]];

    VAR
      restore_missing_cats_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
            clt$parameter_descriptor := [

{ CATALOG C }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ RESTORE_EXCLUDED_FILE_CYCLES REFC }
      [[clc$optional_with_default, ^restore_missing_cats_pdt_dv2], 1, clc$max_value_sets, 1, 1,
            clc$value_range_not_allowed, [^restore_missing_cats_pdt_kv2, clc$keyword_value]],

{ BACKUP_FILE BF }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      restore_missing_cats_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
            ost$name := ['NONE', 'MEDIA_MISSING', 'MM', 'NO_DATA_DEFINED', 'NDD', 'VOLUME_UNAVAILABLE', 'VU'];

    VAR
      restore_missing_cats_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (31) :=
            '(media_missing n' CAT 'o_data_defined)';

?? POP ??

    clp$scan_parameter_list (parameter_list, restore_missing_cats_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_catalog ('CATALOG', catalog_path_container, p_catalog_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (p_catalog_path = NIL) THEN
      { If no CATALOG is specified, default to everything on the backup file.
      catalog_type := puc$valid_set_entry;
    ELSEIF UPPERBOUND (p_catalog_path^) = pfc$family_name_index THEN
      catalog_type := puc$valid_family_entry
    ELSE
      catalog_type := puc$valid_catalog_entry;
    IFEND;

    pup$crack_file ('BACKUP_FILE', backup_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_resefc_selection ('RESTORE_EXCLUDED_FILE_CYCLES', restore_excluded_file_cycles, status);

  PROCEND crack_restore_missing_catalogs;

?? TITLE := '  restore_missing_catalogs ', EJECT ??

  PROCEDURE restore_missing_catalogs
    (    catalog_entry: put$entry;
         catalog_header: put$catalog_header;
         restore_excluded_file_cycles: put$restore_data_selections;
     VAR backup_file_id: {Input, Output} put$file_identifier;
     VAR status: ost$status);

    VAR
      anything_found: boolean,
      catalog_child_found: boolean,
      catalog_found: boolean,
      file_position: put$file_position,
      found_entry: put$entry,
      local_status: ost$status,
      p_cycle_array_extended_record: pft$p_info_record,
      p_cycle_directory_array: pft$p_cycle_directory_array,
      p_found_item_description: ^put$backup_item_descriptor,
      record_header: put$backup_file_record_header,
      stored_backup_file_version: put$backup_file_version_name;

    p_cycle_array_extended_record := NIL;
    p_cycle_directory_array := NIL;
    anything_found := FALSE;

  /loop_through_partitions/
    REPEAT
      pup$locate_valid_version (backup_file_id, stored_backup_file_version, file_position, status);
      IF status.normal AND (file_position <> puc$eoi) THEN
        pup$get_next_record_header (backup_file_id, record_header, file_position, status);
        IF status.normal THEN
          IF (record_header.kind = puc$backup_item_identifier) AND (record_header.size >= 1) THEN
            ALLOCATE p_found_item_description: [1 .. record_header.size];
            pup$get_item_descriptor (backup_file_id, p_found_item_description^, file_position, status);
            IF status.normal THEN
              found_entry := p_found_item_description^.pf_utility_entry;
              pup$compare_item_descriptor (catalog_entry, catalog_header, found_entry,
                    p_found_item_description^.catalog_header, catalog_found, catalog_child_found);
              IF catalog_found OR catalog_child_found THEN
                anything_found := TRUE;
                CASE found_entry.entry_type OF
                = puc$valid_set_entry =
                = puc$valid_family_entry, puc$valid_catalog_entry =
                  restore_catalog_media (p_found_item_description^.catalog_header, catalog_found,
                        backup_file_id, file_position, status);
                  IF NOT status.normal AND catalog_found THEN
                    RETURN;
                  IFEND;
                = puc$valid_pf_entry =
                  restore_file_media (p_found_item_description^.catalog_header, p_cycle_array_extended_record,
                        p_cycle_directory_array, backup_file_id, file_position, status);
                = puc$valid_cycle_entry =
                  IF restore_excluded_file_cycles <> $put$restore_data_selections [] THEN
                    pup$restore_cycle_if_excluded (found_entry, p_found_item_description^.catalog_header,
                          p_found_item_description^.catalog_header, found_entry.pf_selector.cycle_selector,
                          found_entry, p_found_item_description^.catalog_header, restore_excluded_file_cycles,
                          p_cycle_array_extended_record, p_cycle_directory_array, backup_file_id,
                          file_position, status);
                  IFEND;
                ELSE
                CASEND;
              IFEND;
            IFEND;
            FREE p_found_item_description;
          ELSE
            osp$set_status_abnormal (puc$pf_utility_id, pue$unexpected_item_requested, ' identifier ',
                  status);
          IFEND;
        IFEND;
        pup$write_os_status (status, local_status);
        status.normal := TRUE;
        IF file_position = puc$mid_partition THEN
          pup$skip_logical_partition (backup_file_id, file_position, status);
        IFEND;
      IFEND;
    UNTIL NOT status.normal OR (file_position = puc$eoi);
    IF status.normal AND NOT anything_found THEN
      pup$set_abnormal_entry_status (catalog_entry, pue$no_restore_no_find, status);
    IFEND;
  PROCEND restore_missing_catalogs;

?? TITLE := '    restore_catalog_media ', EJECT ??

  PROCEDURE restore_catalog_media
    (    catalog_header: put$catalog_header;
         catalog_specified_on_subcommand: boolean;
     VAR backup_file_id: {Input, Output} put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      p_catalog_group: pft$p_info_record,
      record_header: put$backup_file_record_header,
      restore_catalog_status: pft$restore_catalog_status,
      transfer_count: amt$file_length;

    {input  catalog item info}
    pup$get_next_record_header (backup_file_id, record_header, file_position, status);
    IF status.normal THEN
      IF (file_position = puc$mid_partition) AND ((record_header.kind = puc$backup_family_info) OR
            (record_header.kind = puc$backup_catalog_info)) AND (record_header.size > 0) THEN
        PUSH p_catalog_group: [[REP record_header.size OF cell]];
        pup$get_part (backup_file_id, p_catalog_group, #SIZE (p_catalog_group^), file_position,
              transfer_count, status);
      ELSE
        osp$set_status_abnormal (puc$pf_utility_id, pue$unusable_restore_file, ' catalog info ', status);
      IFEND;
    IFEND;

    {put catalog item info }
    IF status.normal THEN
      pfp$put_catalog_media_info (catalog_header.path, p_catalog_group, catalog_header.set_name,
          restore_catalog_status, status);
      IF status.normal THEN
        CASE restore_catalog_status OF
        = pfc$catalog_already_exists =
          { Display nothing.
        = pfc$catalog_recreated =
          puv$catalogs_recreated := puv$catalogs_recreated + 1;
          pup$write_path (catalog_header.path, local_status);
          pup$display_line ('                     CATALOG RECREATED FROM BACKUP', local_status);
        = pfc$catalog_recovered =
          puv$catalogs_recovered := puv$catalogs_recovered + 1;
          pup$write_path (catalog_header.path, local_status);
          pup$display_line ('                     CATALOG RECOVERED', local_status);
        ELSE
        CASEND;
      ELSE
        IF catalog_specified_on_subcommand THEN
          { If there was an error on the catalog specified on the subcommand
          { return the status, so the user sees it.
        ELSE
          CASE status.condition OF
          = pfe$last_name_not_subcatalog =
            { A file already exists of the same name in the catalog.
            status.normal := TRUE;
          = pfe$unknown_last_subcatalog =
            { The parent catalog was not recreated, so the catalog must have
            { been deleted since the backup.
            status.normal := TRUE;
          ELSE
          CASEND;
        IFEND;
      IFEND;
    IFEND;
    IF NOT status.normal THEN
      pup$write_path (catalog_header.path, local_status);
      pup$write_os_status (status, local_status);
    IFEND;
  PROCEND restore_catalog_media;
?? TITLE := '    restore_file_media ', EJECT ??

  PROCEDURE restore_file_media
    (    catalog_header: put$catalog_header;
     VAR p_cycle_array_extended_record: pft$p_info_record;
     VAR p_cycle_directory_array: pft$p_cycle_directory_array;
     VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

    VAR
      backup_file_version: pft$backup_file_version,
      cycles_fmd_recovered: pft$cycle_count,
      cycle_entries_recreated: pft$cycle_count,
      file_display_string: string (80),
      file_display_string_length: integer,
      file_entry_recreated: boolean,
      local_status: ost$status,
      p_file_group: pft$p_info_record,
      record_header: put$backup_file_record_header,
      transfer_count: amt$file_length;

    {input item info}
    pup$get_next_record_header (backup_file_id, record_header, file_position, status);
    IF status.normal THEN
      IF (file_position = puc$mid_partition) AND (record_header.kind = puc$backup_file_info) AND
            (record_header.size > 0) THEN
        PUSH p_file_group: [[REP record_header.size OF cell]];
        pup$get_part (backup_file_id, p_file_group, #SIZE (p_file_group^), file_position, transfer_count,
              status);
      ELSE
        osp$set_status_abnormal (puc$pf_utility_id, pue$unusable_restore_file, ' file info ', status);
      IFEND;
    IFEND;

{put item info }
    IF status.normal THEN
      IF puv$respf_backup_file_version = puc$backup_file_version_1 THEN
        backup_file_version := pfc$backup_file_version_1;
      ELSEIF puv$respf_backup_file_version = puc$backup_file_version_2 THEN
        backup_file_version := pfc$backup_file_version_2;
      IFEND;
    pfp$put_file_media_info (catalog_header.path, p_file_group, catalog_header.set_name,
            backup_file_version, file_entry_recreated, cycles_fmd_recovered, cycle_entries_recreated, status);
    IFEND;

    IF status.normal THEN
      IF puc$cdo_alternate_storage IN puv$cycle_display_selections THEN
        pfp$find_cycle_array_extended (p_file_group, p_cycle_array_extended_record, status);
        IF status.normal THEN
          pfp$find_cycle_directory (p_cycle_array_extended_record, p_cycle_directory_array, status);
        IFEND;
        IF NOT status.normal THEN
          p_cycle_array_extended_record := NIL;
        IFEND;
      IFEND;
      IF file_entry_recreated OR (cycles_fmd_recovered > 0) OR (cycle_entries_recreated > 0) THEN
        puv$cycles_entry_recreated := puv$cycles_entry_recreated + cycle_entries_recreated;
        puv$cycles_fmd_restored := puv$cycles_fmd_restored + cycles_fmd_recovered;
        pup$write_path (catalog_header.path, local_status);
        file_display_string_length := 0;
        file_display_string := ' ';
        IF file_entry_recreated THEN
          STRINGREP (file_display_string, file_display_string_length, '   FILE RECREATED ---');
        ELSE
          file_display_string_length := 2;
        IFEND;
        STRINGREP (file_display_string, file_display_string_length,
              file_display_string (1, file_display_string_length), '-- CYCLES RECREATED ',
              cycle_entries_recreated, ',');
        STRINGREP (file_display_string, file_display_string_length,
              file_display_string (1, file_display_string_length), '-- CYCLES RECOVERED ',
              cycles_fmd_recovered);
        pup$display_line (file_display_string (1, file_display_string_length), local_status);
      IFEND;
    ELSE
      p_cycle_array_extended_record := NIL;
      CASE status.condition OF
      = pfe$name_not_permanent_file =
        { A catalog of the same name has been created since the backup.
        status.normal := TRUE;
      = pfe$unknown_permanent_file =
        { The parent catalog was not recreated, so we did not create the file.
        status.normal := TRUE;
      ELSE
      CASEND;
    IFEND;
    IF NOT status.normal THEN
      pup$write_path (catalog_header.path, local_status);
      pup$write_os_status (status, local_status);
    IFEND;
  PROCEND restore_file_media;

MODEND pum$restore_missing_catalogs;
*DECK DECK=PUM$RESTORE_OBJECT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  restore_object ' ??
MODULE pum$restore_object;

?? PUSH (LISTEXT := ON) ??
*copyc avp$family_administrator
*copyc avp$system_administrator
*copyc clp$convert_file_ref_to_string
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pfp$convert_pft$path_to_string
*copyc pup$build_catalog_header
*copyc pup$build_entry
*copyc pup$close_backup_file
*copyc pup$compare_item_descriptor
*copyc pup$crack_pf_file_reference
*copyc pup$crack_backup_file
*copyc pup$display_restore_totals
*copyc pup$get_summary_status
*copyc pup$initialize_restore_listing
*copyc pup$open_backup_file
*copyc pup$restore_selected_objects
*copyc pup$set_restore_subcmd_defaults

*copyc osc$nosve_system_set
*copyc pue$error_condition_codes
*copyc put$selected_object
?? POP ??


?? TITLE := '    [XDCL] pup$restore_object_command ', EJECT ??

  PROCEDURE [XDCL] pup$restore_object_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$reso) restore_objects, restore_object, reso(
{   files, file, f: list of record
{       file: file
{       new_file_name: file = $optional
{     recend = $optional
{   catalogs, catalog, c: list of record
{       catalog: file
{       new_catalog_name: file = $optional
{     recend = $optional
{   backup_file, bf: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 8, 20, 10, 30, 20, 249],
    clc$command, 9, 4, 1, 0, 0, 0, 4, 'OSM$RESO'], [
    ['BACKUP_FILE                    ',clc$nominal_entry, 3],
    ['BF                             ',clc$abbreviation_entry, 3],
    ['C                              ',clc$abbreviation_entry, 2],
    ['CATALOG                        ',clc$alias_entry, 2],
    ['CATALOGS                       ',clc$nominal_entry, 2],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$alias_entry, 1],
    ['FILES                          ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 101, clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 101, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [85, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [2],
      ['FILE                           ', clc$required_field, 3], [[1, 0,
  clc$file_type]],
      ['NEW_FILE_NAME                  ', clc$optional_field, 3], [[1, 0,
  clc$file_type]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [85, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [2],
      ['CATALOG                        ', clc$required_field, 3], [[1, 0,
  clc$file_type]],
      ['NEW_CATALOG_NAME               ', clc$optional_field, 3], [[1, 0,
  clc$file_type]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$file_type]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$files = 1,
      p$catalogs = 2,
      p$backup_file = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      backup_file: amt$local_file_name,
      backup_file_id: put$file_identifier,
      current_file: ^clt$data_value,
      cycle_selector: pft$cycle_selector,
      cycle_specified: boolean,
      duplicate_cycle_entry: boolean,
      entry_found: boolean,
      evaluated_file_reference: fst$evaluated_file_reference,
      local_status: ost$status,
      new_cycle_selector: pft$cycle_selector,
      new_cycle_specified: boolean,
      new_path_container: clt$path_container,
      p_current_object: ^put$selected_object,
      p_current_pf_object: ^put$selected_object,
      p_new_path: ^pft$path,
      p_path: ^pft$path,
      p_path_string: ^fst$path,
      p_previous_object: ^put$selected_object,
      p_search_object: ^put$selected_object,
      p_selected_objects: ^put$selected_object,
      path_container: clt$path_container,
      path_string_size: fst$path_size,
      requested_subset_found: boolean,
      set_entry: put$entry;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (NOT pvt [p$files].specified) AND (NOT pvt [p$catalogs].specified) THEN
      osp$set_status_condition (pue$no_objects_selected, status);
      RETURN;
    IFEND;

    PUSH p_selected_objects;
    p_current_object := p_selected_objects;
    p_current_object^.p_catalog_header := NIL;
    p_current_object^.p_new_catalog_header := NIL;
    p_current_object^.object_restored := FALSE;
    p_current_object^.link := NIL;

    {
    { Process the FILES parameter.
    {

    IF pvt [p$files].specified THEN
      current_file := pvt [p$files].value;

      WHILE (current_file <> NIL) AND (current_file^.element_value <> NIL) DO
        IF p_current_object = NIL THEN
          PUSH p_current_object;
          p_current_object^.p_catalog_header := NIL;
          p_current_object^.p_new_catalog_header := NIL;
          p_current_object^.object_restored := FALSE;
          p_current_object^.link := NIL;
          p_previous_object^.link := p_current_object;
        IFEND;

        pup$crack_pf_file_reference (current_file^.element_value^.field_values^ [1].value^.file_value^,
              $put$cycle_reference_selections [puc$cycle_omitted, puc$lowest_cycle, puc$highest_cycle,
              puc$specific_cycle], 'FILE', path_container, p_path, cycle_specified, cycle_selector,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        pup$build_entry (p_path^ [UPPERBOUND (p_path^)], cycle_selector, puc$valid_pf_entry,
              p_current_object^.entry);
        p_current_pf_object := p_current_object;

        PUSH p_current_object^.p_catalog_header: [1 .. UPPERBOUND (p_path^)];
        pup$build_catalog_header (osc$nosve_system_set, p_path, p_current_object^.p_catalog_header^);

        IF current_file^.element_value^.field_values^ [2].value <> NIL THEN
          pup$crack_pf_file_reference (current_file^.element_value^.field_values^ [2].value^.file_value^,
                $put$cycle_reference_selections [puc$cycle_omitted, puc$next_highest_cycle,
                puc$specific_cycle], 'FILE', new_path_container, p_new_path, new_cycle_specified,
                new_cycle_selector, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF new_cycle_specified THEN
            clp$evaluate_file_reference (current_file^.element_value^.field_values^ [2].value^.file_value^,
                  $clt$file_ref_parsing_options [], {resolve_cycle_number} TRUE, evaluated_file_reference,
                  status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            new_cycle_selector.cycle_option := pfc$specific_cycle;
            new_cycle_selector.cycle_number := evaluated_file_reference.cycle_reference.cycle_number;
            p_current_object^.selected_cycle_info.new_selected_cycle.cycle_specified := TRUE;
            p_current_object^.selected_cycle_info.new_selected_cycle.cycle_selector := new_cycle_selector;
            IF NOT cycle_specified THEN
              cycle_specified := TRUE;
              cycle_selector.cycle_option := pfc$highest_cycle;
            IFEND;
          ELSE
            p_current_object^.selected_cycle_info.new_selected_cycle.cycle_specified := FALSE;
            p_current_object^.p_new_catalog_header := p_current_object^.p_catalog_header;
          IFEND;
          pup$build_entry (p_new_path^ [UPPERBOUND (p_new_path^)], new_cycle_selector, puc$valid_cycle_entry,
                p_current_object^.new_entry);
          PUSH p_current_object^.p_new_catalog_header: [1 .. UPPERBOUND (p_new_path^)];
          pup$build_catalog_header (osc$nosve_system_set, p_new_path,
                p_current_object^.p_new_catalog_header^);
        ELSE
          pup$build_entry (p_path^ [UPPERBOUND (p_path^)], cycle_selector, puc$valid_pf_entry,
                p_current_object^.new_entry);
          PUSH p_current_object^.p_new_catalog_header: [1 .. UPPERBOUND (p_path^)];
          pup$build_catalog_header (osc$nosve_system_set, p_path, p_current_object^.p_new_catalog_header^);
          p_current_object^.selected_cycle_info.new_selected_cycle.cycle_specified := FALSE;
        IFEND;

        IF cycle_specified THEN
          pup$build_entry (p_path^ [UPPERBOUND (p_path^)], cycle_selector, puc$valid_cycle_entry,
                p_current_object^.new_entry);
          p_current_object^.selected_cycle_info.selected_cycle.cycle_specified := TRUE;
          p_current_object^.selected_cycle_info.selected_cycle.cycle_selector := cycle_selector;
          p_previous_object := p_current_object;
          p_current_object := p_current_object^.link;
          IF p_current_object = NIL THEN
            PUSH p_current_object;
            p_current_object^ := p_previous_object^;
            p_previous_object^.link := p_current_object;
          IFEND;
          pup$build_entry (p_path^ [UPPERBOUND (p_path^)], cycle_selector, puc$valid_cycle_entry,
                p_current_object^.entry);
          IF (current_file^.element_value^.field_values^ [2].value = NIL) THEN
            pup$build_entry (p_path^ [UPPERBOUND (p_path^)], cycle_selector, puc$valid_cycle_entry,
                  p_current_object^.new_entry);
          IFEND;
        ELSE
          pup$build_entry (p_path^ [UPPERBOUND (p_path^)], cycle_selector, puc$valid_pf_entry,
                p_current_object^.new_entry);
          p_current_object^.selected_cycle_info.selected_cycle.cycle_specified := FALSE;
        IFEND;

        p_search_object := p_selected_objects;
        WHILE p_search_object <> NIL DO
          IF NOT ((p_search_object = p_current_pf_object) OR (p_search_object = p_current_object)) THEN
            pup$compare_item_descriptor (p_search_object^.entry, p_search_object^.p_catalog_header^,
                  p_current_object^.entry, p_current_object^.p_catalog_header^, entry_found,
                  requested_subset_found);
            IF entry_found THEN
              duplicate_cycle_entry := same_cycle_specified (p_search_object, p_current_object);
            ELSEIF cycle_specified AND (p_search_object^.entry.entry_type = puc$valid_pf_entry) AND
                  requested_subset_found THEN
              duplicate_cycle_entry := same_cycle_specified (p_search_object, p_current_pf_object);
            ELSEIF (NOT cycle_specified) AND (p_search_object^.entry.entry_type = puc$valid_cycle_entry) THEN
              pup$compare_item_descriptor (p_current_object^.entry, p_current_object^.p_catalog_header^,
                    p_search_object^.entry, p_search_object^.p_catalog_header^, entry_found,
                    requested_subset_found);
              duplicate_cycle_entry := requested_subset_found;
            ELSE
              duplicate_cycle_entry := FALSE;
            IFEND;

            IF duplicate_cycle_entry THEN
              clp$evaluate_file_reference (current_file^.element_value^.field_values^ [1].value^.file_value^,
                    $clt$file_ref_parsing_options [], {resolve_cycle_number} FALSE,
                    evaluated_file_reference, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              PUSH p_path_string;
              clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} FALSE,
                    p_path_string^, path_string_size, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              osp$set_status_abnormal (puc$pf_utility_id, pue$redundant_objects_selected, 'file', status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    p_path_string^ (1, path_string_size), status);
              RETURN;
            IFEND;
          IFEND;
          p_search_object := p_search_object^.link;
        WHILEND;

        p_previous_object := p_current_object;
        p_current_object := p_current_object^.link;
        current_file := current_file^.link;
      WHILEND;
    IFEND;

    {
    { Process CATALOGS parameter.
    {
    IF pvt [p$catalogs].specified THEN
      current_file := pvt [p$catalogs].value;

      WHILE (current_file <> NIL) AND (current_file^.element_value <> NIL) DO
        IF p_current_object = NIL THEN
          PUSH p_current_object;
          p_current_object^.p_catalog_header := NIL;
          p_current_object^.p_new_catalog_header := NIL;
          p_current_object^.object_restored := FALSE;
          p_current_object^.link := NIL;
          p_previous_object^.link := p_current_object;
        IFEND;

        pup$crack_pf_file_reference (current_file^.element_value^.field_values^ [1].value^.file_value^,
              $put$cycle_reference_selections [puc$cycle_omitted], 'CATALOG', path_container, p_path,
              cycle_specified, cycle_selector, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        pup$build_entry (p_path^ [UPPERBOUND (p_path^)], cycle_selector, puc$valid_catalog_entry,
              p_current_object^.entry);

        PUSH p_current_object^.p_catalog_header: [1 .. UPPERBOUND (p_path^)];
        pup$build_catalog_header (osc$nosve_system_set, p_path, p_current_object^.p_catalog_header^);

        IF current_file^.element_value^.field_values^ [2].value <> NIL THEN
          pup$crack_pf_file_reference (current_file^.element_value^.field_values^ [2].value^.file_value^,
                $put$cycle_reference_selections [puc$cycle_omitted], 'CATALOG', path_container, p_path,
                cycle_specified, cycle_selector, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          pup$build_entry (p_path^ [UPPERBOUND (p_path^)], cycle_selector, puc$valid_catalog_entry,
                p_current_object^.new_entry);

          PUSH p_current_object^.p_new_catalog_header: [1 .. UPPERBOUND (p_path^)];
          pup$build_catalog_header (osc$nosve_system_set, p_path, p_current_object^.p_new_catalog_header^);
        ELSE
          p_current_object^.new_entry := p_current_object^.entry;
          p_current_object^.p_new_catalog_header := p_current_object^.p_catalog_header;
        IFEND;

        p_search_object := p_selected_objects;
        WHILE p_search_object <> NIL DO
          IF p_search_object <> p_current_object THEN
            pup$compare_item_descriptor (p_search_object^.entry, p_search_object^.p_catalog_header^,
                  p_current_object^.entry, p_current_object^.p_catalog_header^, entry_found,
                  requested_subset_found);
            IF entry_found THEN
              clp$evaluate_file_reference (current_file^.element_value^.field_values^ [1].value^.file_value^,
                    $clt$file_ref_parsing_options [], {resolve_cycle_number} FALSE,
                    evaluated_file_reference, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              PUSH p_path_string;
              clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} FALSE,
                    p_path_string^, path_string_size, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;

              osp$set_status_abnormal (puc$pf_utility_id, pue$redundant_objects_selected, 'catalog', status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    p_path_string^ (1, path_string_size), status);
              RETURN;
            IFEND;
          IFEND;
          p_search_object := p_search_object^.link;
        WHILEND;
        current_file := current_file^.link;
        p_previous_object := p_current_object;
        p_current_object := p_current_object^.link;
      WHILEND;
    IFEND;

    pup$crack_backup_file (pvt [p$backup_file].value^.file_value^, backup_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$open_backup_file (backup_file, puc$restore_permanent_files, amc$open_at_boi, backup_file_id, status);
    IF status.normal THEN
      set_entry.entry_type := puc$valid_set_entry;
      set_entry.set_name := osc$nosve_system_set;
      pup$initialize_restore_listing (' RESTORE OBJECT:', p_selected_objects^.p_catalog_header^, set_entry,
            p_selected_objects^.p_catalog_header^.path, cycle_selector, status);
      IF status.normal THEN
        pup$set_restore_subcmd_defaults (NOT (avp$system_administrator() OR avp$family_administrator()));
        pup$restore_selected_objects (p_selected_objects, backup_file_id, status);
        pup$display_restore_totals;
      IFEND;

      pup$close_backup_file (backup_file_id, local_status);
      IF status.normal THEN
        status := local_status;
      IFEND;
      pup$get_summary_status (status);
    IFEND;

  PROCEND pup$restore_object_command;

  FUNCTION same_cycle_specified
    (    p_search_object: ^put$selected_object;
         p_current_object: ^put$selected_object): boolean;

    IF p_search_object^.selected_cycle_info.selected_cycle.cycle_specified AND
          p_current_object^.selected_cycle_info.selected_cycle.cycle_specified THEN
      CASE p_search_object^.selected_cycle_info.selected_cycle.cycle_selector.cycle_option OF
      = pfc$highest_cycle =
        same_cycle_specified :=
              p_current_object^.selected_cycle_info.selected_cycle.cycle_selector.cycle_option =
              pfc$highest_cycle;
      = pfc$lowest_cycle =
        same_cycle_specified :=
              p_current_object^.selected_cycle_info.selected_cycle.cycle_selector.cycle_option =
              pfc$lowest_cycle;
      = pfc$specific_cycle =
        same_cycle_specified :=
              ((p_current_object^.selected_cycle_info.selected_cycle.cycle_selector.cycle_option =
              pfc$specific_cycle) AND
              (p_search_object^.selected_cycle_info.selected_cycle.cycle_selector.cycle_number =
              p_current_object^.selected_cycle_info.selected_cycle.cycle_selector.cycle_number));
      CASEND;
    ELSE
      same_cycle_specified := TRUE;
    IFEND;

  FUNCEND same_cycle_specified;

MODEND pum$restore_object;
*DECK DECK=PUM$RESTORE_PERMANENT_FILES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := ' NOS/VE Backup/Restore Utilities:  restore_permanent_files ', EJECT ??
MODULE pum$restore_permanent_files;
{
{   This module contains processing the extry point and command table
{ for the restore_permanent_files utility, and well as processing for the
{ SET_RESTORE_OPTIONS subcommand.
{
?? NEWTITLE := '   Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmt$class
*copyc fmt$mass_storage_request_info
*copyc ost$caller_identifier
*copyc ost$status
*copyc ost$string
*copyc pfc$null_shared_queue
*copyc pfc$system_shared_queue_name
*copyc pft$purge_cycle_options
*copyc pud$backup_file
*copyc pue$error_condition_codes
*copyc pus$literals
*copyc rmc$unspecified_allocation_size
*copyc rmc$unspecified_file_class
*copyc rmc$unspecified_file_size
*copyc rmc$unspecified_vsn
*copyc rmd$volume_declarations
*copyc rmt$allocation_size
*copyc rmt$recorded_vsn
?? POP ??
?? EJECT ??
*copyc avp$family_administrator
*copyc avp$system_administrator
*copyc clp$end_scan_command_file
*copyc clp$evaluate_parameters
*copyc clp$get_value
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$scan_command_file
*copyc clp$scan_parameter_list
*copyc clp$trimmed_string_size
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pfp$convert_shared_queue_to_ord
*copyc pfp$convert_ord_to_shared_queue
*copyc pup$close_display_file
*copyc pup$crack_boolean
*copyc pup$crack_file_reference
*copyc pup$display_blank_lines
*copyc pup$display_boolean
*copyc pup$display_integer
*copyc pup$display_line
*copyc pup$open_display_file
*copyc pup$write_os_status
*copyc rmp$build_mass_storage_info
*copyc rmp$convert_keyword_to_class

?? TITLE := '    Global Variables', EJECT ??

  TYPE
    restore_option_source = (set_restore_options_command, subcommand_default, utility_default);

  VAR
    puv$create_objects: [XDCL, STATIC] boolean := TRUE,
    puv$mass_storage_info: [XDCL, STATIC] fmt$mass_storage_request_info := [
          {allocation_size} rmc$unspecified_allocation_size,
          {estimated_file_size} rmc$unspecified_file_size,
          {initial_volume} rmc$unspecified_vsn,
          {maintenance_job} FALSE,
          {mass_storage_class} rmc$unspecified_file_class,
          {shared_queue} pfc$null_shared_queue,
          {transfer_size} rmc$unspecified_transfer_size,
          {user_privilege} rmc$normal_user,
          {volume_overflow_allowed} TRUE],
    puv$purge_cycle_options: [XDCL, STATIC] pft$purge_cycle_options := [
          {enforce_password_validation} TRUE,
          {enforce_ring_validation} TRUE,
          {preserve_cycle_entry} FALSE],
    puv$prev_open_by_$backup_file: [XDCL, STATIC] boolean := FALSE,
    puv$replace_cycle_data: [XDCL, STATIC] boolean := FALSE,
    puv$require_modification_match: [XDCL, STATIC] boolean := TRUE,
    puv$respf_backup_file_version: [XDCL, STATIC] put$backup_file_version_name,
    puv$restore_archive_information: [XDCL] boolean,
    puv$trace_selected: [XDCL, STATIC] boolean := FALSE,
    puv$update_cycle_statistics: [XDCL, STATIC] boolean := FALSE;

  VAR
    rai_specified: [STATIC] boolean := FALSE,
    update_cycle_statistics_source: [STATIC] restore_option_source := utility_default;

  CONST
    puc$restore_utility_name = 'RESTORE_PERMANENT_FILES        ';

?? TITLE := '    [XDCL] pup$quit_restore ', EJECT ??

  PROCEDURE [XDCL] pup$quit_restore (parameter_list: clt$parameter_list;
    VAR status: ost$status);
{
{ pdt pfu_quit_restore_pdt()

?? PUSH (LISTEXT := ON) ??

    VAR
      pfu_quit_restore_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??
    status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, pfu_quit_restore_pdt, status);
    IF status.normal THEN
      clp$end_scan_command_file (puc$restore_utility_name, status);
    IFEND;
  PROCEND pup$quit_restore;

?? TITLE := '    [XDCL] pup$restore_permanent_file ', EJECT ??

  PROCEDURE [XDCL] pup$restore_permanent_file
   (    parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ table restore_command_list type=command section_name=pus$literals scope=local
{ command (allow_rtbt_test) processor=pup$allow_rtbt_test call_method=xref availability=hidden log=automatic
{ command (analyze_server_keypoints, anask) processor=dfp$analyze_server_keypoints call_method=xref       ..
{   availability=hidden log=automatic
{ command (change_all_permits, chaap) processor=pup$change_all_permits_cm call_method=xref       ..
{   availability=advertised log=automatic
{ command (change_catalog_permits, chacp) processor=pup$change_catalog_permits_cm call_method=xref       ..
{   availability=advertised log=automatic
{ command (change_file_permits, chafp) processor=pup$change_file_permits_command call_method=xref       ..
{   availability=hidden log=automatic
{ command (create_mass_storage_catalog, cremsc) processor=pup$create_ms_catalog_cmnd call_method=xref     ..
{     availability=hidden log=automatic
{ command (define_master_catalog) processor=pup$defmc_command call_method=xref availability=hidden       ..
{   log=automatic
{ command (detach_all_catalogs, detac) processor=pup$detach_all_catalogs call_method=xref       ..
{   availability=hidden log=automatic
{ command (display_all_catalogs) processor=pup$display_all_catalogs_cmnd call_method=xref       ..
{   availability=hidden log=automatic
{ command (display_advise) processor=pup$display_advise_cmd call_method=xref availability=hidden ..
{   log=automatic
{ command (display_ast) processor=pup$display_ast call_method=xref availability=hidden log=automatic
{ command (display_backup_file, disbf) processor=pup$display_backup_file_command call_method=xref       ..
{   availability=advertised log=automatic
{ command display_fmd processor=pup$display_fmd_cmd call_method=xref availability=hidden log=automatic
{ command (display_master_catalog) processor=pup$display_master_catalog_cmnd call_method=xref       ..
{   availability=hidden log=automatic
{ command (display_restore_options display_restore_option disro) processor=pup$display_restore_options_cm ..
{         call_method=local availability=advertised log=automatic
{ command (display_vst) processor=pup$display_vst call_method=xref availability=hidden log=automatic
{ command (get_attached_pf_table) processor=pup$get_attached_pf_table_cm call_method=xref       ..
{   availability=hidden log=automatic
{ command (get_catalog_alarm_table) processor=pup$get_catalog_alarm_table_cm call_method=xref       ..
{   availability=hidden log=automatic
{ command (get_catalog_segment) processor=pup$get_catalog_segment_cm call_method=xref availability=hidden ..
{         log=automatic
{ command (get_file_info) processor=pup$get_file_info call_method=xref availability=hidden log=automatic
{ command (get_queued_catalog_table) processor=pup$get_queued_catalog_table_cm call_method=xref       ..
{   availability=hidden log=automatic
{ command (get_stored_fmd) processor=pup$get_file_fmd_cm call_method=xref availability=hidden log=automatic
{ command (include_cycles include_cycle incc) processor=pup$restore_include_cycles call_method=xref       ..
{   availability=advertised log=automatic
{ command (include_volumes include_volume incv) processor=pup$restore_include_volumes_cmd ..
{   call_method=xref       availability=advertised log=automatic
{ command (purge_master_catalog) processor=pup$purmc_command call_method=xref availability=hidden       ..
{   log=automatic
{ command (purge_object) processor=pup$purge_object_cm call_method=xref availability=hidden log=automatic
{ command (push_backup) processor=pup$backup_permanent_file call_method=xref availability=hidden ..
{   log=automatic
{ command (put_catalog_segment) processor=pup$put_catalog_segment_cm call_method=xref availability=hidden ..
{         log=automatic
{ command (putrace) processor=pup$trace call_method=local availability=hidden log=automatic
{ command (quit, qui) processor=pup$quit_restore call_method=local availability=advertised log=automatic
{ command (restore_all_files, resaf) processor=pup$restore_all_files_command call_method=xref       ..
{   availability=advertised log=automatic
{ command (restore_catalog, resc) processor=pup$restore_catalog_command call_method=xref       ..
{   availability=advertised log=automatic
{ command (restore_excluded_file_cycles, restore_excluded_file_cycle, resefc)       ..
{   processor=pup$restore_excluded_cycles_cm call_method=xref availability=advertised log=automatic
{ command (restore_existing_catalog, resec) processor=pup$restore_existing_catalog_cm call_method=xref    ..
{      availability=advertised log=automatic
{ command (restore_existing_file, resef) processor=pup$restore_existing_file_cm call_method=xref       ..
{   availability=advertised log=manual
{ command (restore_file, resf) processor=pup$restore_file_command call_method=xref ..
{   availability=advertised       log=manual
{ command (restore_objects, restore_object, reso) processor=pup$restore_object_command call_method=xref   ..
{       availability=advertised log=automatic
{ command (restore_missing_catalogs, restore_missing_catalog, resmc)       ..
{   processor=pup$restore_missing_catalogs_cm call_method=xref availability=advertised log=automatic
{ command (search_data_file) processor=pup$search_data_file call_method=xref availability=hidden ..
{   log=automatic
{ command (select_advise_in) processor=pup$select_advise_in_cmd call_method=xref availability=hidden      ..
{    log=automatic
{ command (set_list_options, set_list_option, setlo) processor=pup$set_list_options_command       ..
{   call_method=xref availability=advertised log=automatic
{ command (set_restore_options, set_restore_option, setro) processor=pup$set_restore_options_command      ..
{    call_method=local availability=advertised log=automatic
{ command (set_restore_missing_catalogs, set_restore_missing_catalog, setrmc)       ..
{   processor=pup$set_restore_missing_catalog call_method=xref availability=advertised log=automatic

?? PUSH (LISTEXT := ON) ??

VAR
  restore_command_list: [STATIC, READ, pus$literals] ^clt$command_table := ^restore_command_list_entries,

  restore_command_list_entries: [STATIC, READ, pus$literals] array [1 .. 74] of clt$command_table_entry := [
  {} ['ALLOW_RTBT_TEST                ', clc$nominal_entry, clc$hidden_entry, 1,
        clc$automatically_log, clc$linked_call, ^pup$allow_rtbt_test],
  {} ['ANALYZE_SERVER_KEYPOINTS       ', clc$nominal_entry, clc$hidden_entry, 2,
        clc$automatically_log, clc$linked_call, ^dfp$analyze_server_keypoints],
  {} ['ANASK                          ', clc$abbreviation_entry, clc$hidden_entry, 2,
        clc$automatically_log, clc$linked_call, ^dfp$analyze_server_keypoints],
  {} ['CHAAP                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^pup$change_all_permits_cm],
  {} ['CHACP                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^pup$change_catalog_permits_cm],
  {} ['CHAFP                          ', clc$abbreviation_entry, clc$hidden_entry, 5,
        clc$automatically_log, clc$linked_call, ^pup$change_file_permits_command],
  {} ['CHANGE_ALL_PERMITS             ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^pup$change_all_permits_cm],
  {} ['CHANGE_CATALOG_PERMITS         ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^pup$change_catalog_permits_cm],
  {} ['CHANGE_FILE_PERMITS            ', clc$nominal_entry, clc$hidden_entry, 5,
        clc$automatically_log, clc$linked_call, ^pup$change_file_permits_command],
  {} ['CREATE_MASS_STORAGE_CATALOG    ', clc$nominal_entry, clc$hidden_entry, 6,
        clc$automatically_log, clc$linked_call, ^pup$create_ms_catalog_cmnd],
  {} ['CREMSC                         ', clc$abbreviation_entry, clc$hidden_entry, 6,
        clc$automatically_log, clc$linked_call, ^pup$create_ms_catalog_cmnd],
  {} ['DEFINE_MASTER_CATALOG          ', clc$nominal_entry, clc$hidden_entry, 7,
        clc$automatically_log, clc$linked_call, ^pup$defmc_command],
  {} ['DETAC                          ', clc$abbreviation_entry, clc$hidden_entry, 8,
        clc$automatically_log, clc$linked_call, ^pup$detach_all_catalogs],
  {} ['DETACH_ALL_CATALOGS            ', clc$nominal_entry, clc$hidden_entry, 8,
        clc$automatically_log, clc$linked_call, ^pup$detach_all_catalogs],
  {} ['DISBF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^pup$display_backup_file_command],
  {} ['DISPLAY_ADVISE                 ', clc$nominal_entry, clc$hidden_entry, 10,
        clc$automatically_log, clc$linked_call, ^pup$display_advise_cmd],
  {} ['DISPLAY_ALL_CATALOGS           ', clc$nominal_entry, clc$hidden_entry, 9,
        clc$automatically_log, clc$linked_call, ^pup$display_all_catalogs_cmnd],
  {} ['DISPLAY_AST                    ', clc$nominal_entry, clc$hidden_entry, 11,
        clc$automatically_log, clc$linked_call, ^pup$display_ast],
  {} ['DISPLAY_BACKUP_FILE            ', clc$nominal_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^pup$display_backup_file_command],
  {} ['DISPLAY_FMD                    ', clc$nominal_entry, clc$hidden_entry, 13,
        clc$automatically_log, clc$linked_call, ^pup$display_fmd_cmd],
  {} ['DISPLAY_MASTER_CATALOG         ', clc$nominal_entry, clc$hidden_entry, 14,
        clc$automatically_log, clc$linked_call, ^pup$display_master_catalog_cmnd],
  {} ['DISPLAY_RESTORE_OPTION         ', clc$alias_entry, clc$normal_usage_entry, 15,
        clc$automatically_log, clc$linked_call, ^pup$display_restore_options_cm],
  {} ['DISPLAY_RESTORE_OPTIONS        ', clc$nominal_entry, clc$normal_usage_entry, 15,
        clc$automatically_log, clc$linked_call, ^pup$display_restore_options_cm],
  {} ['DISPLAY_VST                    ', clc$nominal_entry, clc$hidden_entry, 16,
        clc$automatically_log, clc$linked_call, ^pup$display_vst],
  {} ['DISRO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 15,
        clc$automatically_log, clc$linked_call, ^pup$display_restore_options_cm],
  {} ['GET_ATTACHED_PF_TABLE          ', clc$nominal_entry, clc$hidden_entry, 17,
        clc$automatically_log, clc$linked_call, ^pup$get_attached_pf_table_cm],
  {} ['GET_CATALOG_ALARM_TABLE        ', clc$nominal_entry, clc$hidden_entry, 18,
        clc$automatically_log, clc$linked_call, ^pup$get_catalog_alarm_table_cm],
  {} ['GET_CATALOG_SEGMENT            ', clc$nominal_entry, clc$hidden_entry, 19,
        clc$automatically_log, clc$linked_call, ^pup$get_catalog_segment_cm],
  {} ['GET_FILE_INFO                  ', clc$nominal_entry, clc$hidden_entry, 20,
        clc$automatically_log, clc$linked_call, ^pup$get_file_info],
  {} ['GET_QUEUED_CATALOG_TABLE       ', clc$nominal_entry, clc$hidden_entry, 21,
        clc$automatically_log, clc$linked_call, ^pup$get_queued_catalog_table_cm],
  {} ['GET_STORED_FMD                 ', clc$nominal_entry, clc$hidden_entry, 22,
        clc$automatically_log, clc$linked_call, ^pup$get_file_fmd_cm],
  {} ['INCC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 23,
        clc$automatically_log, clc$linked_call, ^pup$restore_include_cycles],
  {} ['INCLUDE_CYCLE                  ', clc$alias_entry, clc$normal_usage_entry, 23,
        clc$automatically_log, clc$linked_call, ^pup$restore_include_cycles],
  {} ['INCLUDE_CYCLES                 ', clc$nominal_entry, clc$normal_usage_entry, 23,
        clc$automatically_log, clc$linked_call, ^pup$restore_include_cycles],
  {} ['INCLUDE_VOLUME                 ', clc$alias_entry, clc$normal_usage_entry, 24,
        clc$automatically_log, clc$linked_call, ^pup$restore_include_volumes_cmd],
  {} ['INCLUDE_VOLUMES                ', clc$nominal_entry, clc$normal_usage_entry, 24,
        clc$automatically_log, clc$linked_call, ^pup$restore_include_volumes_cmd],
  {} ['INCV                           ', clc$abbreviation_entry, clc$normal_usage_entry, 24,
        clc$automatically_log, clc$linked_call, ^pup$restore_include_volumes_cmd],
  {} ['PURGE_MASTER_CATALOG           ', clc$nominal_entry, clc$hidden_entry, 25,
        clc$automatically_log, clc$linked_call, ^pup$purmc_command],
  {} ['PURGE_OBJECT                   ', clc$nominal_entry, clc$hidden_entry, 26,
        clc$automatically_log, clc$linked_call, ^pup$purge_object_cm],
  {} ['PUSH_BACKUP                    ', clc$nominal_entry, clc$hidden_entry, 27,
        clc$automatically_log, clc$linked_call, ^pup$backup_permanent_file],
  {} ['PUTRACE                        ', clc$nominal_entry, clc$hidden_entry, 29,
        clc$automatically_log, clc$linked_call, ^pup$trace],
  {} ['PUT_CATALOG_SEGMENT            ', clc$nominal_entry, clc$hidden_entry, 28,
        clc$automatically_log, clc$linked_call, ^pup$put_catalog_segment_cm],
  {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 30,
        clc$automatically_log, clc$linked_call, ^pup$quit_restore],
  {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 30,
        clc$automatically_log, clc$linked_call, ^pup$quit_restore],
  {} ['RESAF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 31,
        clc$automatically_log, clc$linked_call, ^pup$restore_all_files_command],
  {} ['RESC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 32,
        clc$automatically_log, clc$linked_call, ^pup$restore_catalog_command],
  {} ['RESEC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 34,
        clc$automatically_log, clc$linked_call, ^pup$restore_existing_catalog_cm],
  {} ['RESEF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 35,
        clc$manually_log, clc$linked_call, ^pup$restore_existing_file_cm],
  {} ['RESEFC                         ', clc$abbreviation_entry, clc$normal_usage_entry, 33,
        clc$automatically_log, clc$linked_call, ^pup$restore_excluded_cycles_cm],
  {} ['RESF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 36,
        clc$manually_log, clc$linked_call, ^pup$restore_file_command],
  {} ['RESMC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 38,
        clc$automatically_log, clc$linked_call, ^pup$restore_missing_catalogs_cm],
  {} ['RESO                           ', clc$abbreviation_entry, clc$normal_usage_entry, 37,
        clc$automatically_log, clc$linked_call, ^pup$restore_object_command],
  {} ['RESTORE_ALL_FILES              ', clc$nominal_entry, clc$normal_usage_entry, 31,
        clc$automatically_log, clc$linked_call, ^pup$restore_all_files_command],
  {} ['RESTORE_CATALOG                ', clc$nominal_entry, clc$normal_usage_entry, 32,
        clc$automatically_log, clc$linked_call, ^pup$restore_catalog_command],
  {} ['RESTORE_EXCLUDED_FILE_CYCLE    ', clc$alias_entry, clc$normal_usage_entry, 33,
        clc$automatically_log, clc$linked_call, ^pup$restore_excluded_cycles_cm],
  {} ['RESTORE_EXCLUDED_FILE_CYCLES   ', clc$nominal_entry, clc$normal_usage_entry, 33,
        clc$automatically_log, clc$linked_call, ^pup$restore_excluded_cycles_cm],
  {} ['RESTORE_EXISTING_CATALOG       ', clc$nominal_entry, clc$normal_usage_entry, 34,
        clc$automatically_log, clc$linked_call, ^pup$restore_existing_catalog_cm],
  {} ['RESTORE_EXISTING_FILE          ', clc$nominal_entry, clc$normal_usage_entry, 35,
        clc$manually_log, clc$linked_call, ^pup$restore_existing_file_cm],
  {} ['RESTORE_FILE                   ', clc$nominal_entry, clc$normal_usage_entry, 36,
        clc$manually_log, clc$linked_call, ^pup$restore_file_command],
  {} ['RESTORE_MISSING_CATALOG        ', clc$alias_entry, clc$normal_usage_entry, 38,
        clc$automatically_log, clc$linked_call, ^pup$restore_missing_catalogs_cm],
  {} ['RESTORE_MISSING_CATALOGS       ', clc$nominal_entry, clc$normal_usage_entry, 38,
        clc$automatically_log, clc$linked_call, ^pup$restore_missing_catalogs_cm],
  {} ['RESTORE_OBJECT                 ', clc$alias_entry, clc$normal_usage_entry, 37,
        clc$automatically_log, clc$linked_call, ^pup$restore_object_command],
  {} ['RESTORE_OBJECTS                ', clc$nominal_entry, clc$normal_usage_entry, 37,
        clc$automatically_log, clc$linked_call, ^pup$restore_object_command],
  {} ['SEARCH_DATA_FILE               ', clc$nominal_entry, clc$hidden_entry, 39,
        clc$automatically_log, clc$linked_call, ^pup$search_data_file],
  {} ['SELECT_ADVISE_IN               ', clc$nominal_entry, clc$hidden_entry, 40,
        clc$automatically_log, clc$linked_call, ^pup$select_advise_in_cmd],
  {} ['SETLO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 41,
        clc$automatically_log, clc$linked_call, ^pup$set_list_options_command],
  {} ['SETRMC                         ', clc$abbreviation_entry, clc$normal_usage_entry, 43,
        clc$automatically_log, clc$linked_call, ^pup$set_restore_missing_catalog],
  {} ['SETRO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 42,
        clc$automatically_log, clc$linked_call, ^pup$set_restore_options_command],
  {} ['SET_LIST_OPTION                ', clc$alias_entry, clc$normal_usage_entry, 41,
        clc$automatically_log, clc$linked_call, ^pup$set_list_options_command],
  {} ['SET_LIST_OPTIONS               ', clc$nominal_entry, clc$normal_usage_entry, 41,
        clc$automatically_log, clc$linked_call, ^pup$set_list_options_command],
  {} ['SET_RESTORE_MISSING_CATALOG    ', clc$alias_entry, clc$normal_usage_entry, 43,
        clc$automatically_log, clc$linked_call, ^pup$set_restore_missing_catalog],
  {} ['SET_RESTORE_MISSING_CATALOGS   ', clc$nominal_entry, clc$normal_usage_entry, 43,
        clc$automatically_log, clc$linked_call, ^pup$set_restore_missing_catalog],
  {} ['SET_RESTORE_OPTION             ', clc$alias_entry, clc$normal_usage_entry, 42,
        clc$automatically_log, clc$linked_call, ^pup$set_restore_options_command],
  {} ['SET_RESTORE_OPTIONS            ', clc$nominal_entry, clc$normal_usage_entry, 42,
        clc$automatically_log, clc$linked_call, ^pup$set_restore_options_command]];

  PROCEDURE [XREF] dfp$analyze_server_keypoints
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$allow_rtbt_test
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$backup_permanent_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$change_all_permits_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$change_catalog_permits_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$change_file_permits_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$create_ms_catalog_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$defmc_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$detach_all_catalogs
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$display_advise_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$display_all_catalogs_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$display_ast
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$display_backup_file_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$display_fmd_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$display_master_catalog_cmnd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$display_vst
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$get_attached_pf_table_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$get_catalog_alarm_table_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$get_catalog_segment_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$get_file_fmd_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$get_file_info
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$get_queued_catalog_table_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$purge_object_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$purmc_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$put_catalog_segment_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$restore_all_files_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$restore_catalog_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$restore_excluded_cycles_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$restore_existing_catalog_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$restore_existing_file_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$restore_file_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$restore_include_cycles
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$restore_include_volumes_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$restore_missing_catalogs_cm
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$restore_object_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$search_data_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$select_advise_in_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$set_list_options_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] pup$set_restore_missing_catalog
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??

{ table restore_function_list type=function section_name=pus$literals scope=local
{ function name=($backup_file, $bf) processor=pup$$backup_file call_method=xref availability=advertised

?? PUSH (LISTEXT := ON) ??

    VAR
      restore_function_list: [STATIC, READ, pus$literals] ^clt$function_table :=
        ^restore_function_list_entries,

      restore_function_list_entries: [STATIC, READ, pus$literals] array [1 .. 2] of clt$function_table_entry
        := [
        {} ['$BACKUP_FILE                   ', clc$nominal_entry, clc$advertised_entry, 1, clc$linked_call,
        ^pup$$backup_file],
        {} ['$BF                            ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$linked_call, ^pup$$backup_file]];

?? TITLE := '    [XREF] pup$$backup_file ', EJECT ??

    PROCEDURE [XREF] pup$$backup_file (function_name: clt$name;
          argument_list: string ( * );
      VAR value: clt$value;
      VAR status: ost$status);

?? POP ??
?? EJECT ??


{ pdt pf_restore_pdt (
{ list,l:file = $LIST
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pf_restore_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^pf_restore_pdt_names,
        ^pf_restore_pdt_params];

    VAR
      pf_restore_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['LIST', 1], ['L', 1], ['STATUS', 2]];

    VAR
      pf_restore_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor :=
        [

{ LIST L }
      [[clc$optional_with_default, ^pf_restore_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      pf_restore_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := '$LIST';

?? POP ??

    VAR
      command_file: amt$local_file_name,
      list_file_lfn: amt$local_file_name,
      local_status: ost$status;

    status.normal := TRUE;
    local_status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, pf_restore_pdt, status);
    IF status.normal THEN
      command_file := '$COMMAND';
      pup$crack_file_reference ('LIST', list_file_lfn, status);
      IF status.normal THEN
        pup$open_display_file (list_file_lfn, status);
        IF status.normal THEN
          puv$restore_archive_information := avp$family_administrator () OR avp$system_administrator ();
          clp$push_utility (puc$restore_utility_name, clc$global_command_search, restore_command_list,
                restore_function_list, status);
          IF status.normal THEN
            clp$scan_command_file (command_file, puc$restore_utility_name, 'PUR', status);
            clp$pop_utility (local_status);
            IF status.normal AND (NOT local_status.normal) THEN
              status := local_status;
            IFEND;
          IFEND;
          pup$close_display_file (list_file_lfn, local_status);
          IF status.normal AND (NOT local_status.normal) THEN
            status := local_status;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND pup$restore_permanent_file;

?? TITLE := '    pup$display_restore_options_cm', EJECT ??
  PROCEDURE pup$display_restore_options_cm (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE (pup$disro) display_restore_options, disro (
{   status)

?? 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,
      recend,
    recend := [
    [1,
    [92, 2, 7, 15, 4, 39, 796],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'PUP$DISRO'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      display_string: string(osc$max_name_size + 35),
      ignore_status: ost$status,
      local_rai: boolean,
      shared_queue_name: ost$name;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$display_line (' Restore_Options', ignore_status);

    pup$display_blank_lines (1, status);

    IF puv$mass_storage_info.allocation_size = rmc$unspecified_allocation_size THEN
      pup$display_line ('   Allocation_Size               : Unspecified', ignore_status);
    ELSE
      pup$display_integer ('   Allocation_Size               : ', puv$mass_storage_info.allocation_size,
            ignore_status);
    IFEND;

    pup$display_boolean ('   Create_Objects                :', puv$create_objects, ignore_status);

    IF puv$mass_storage_info.mass_storage_class = rmc$unspecified_file_class THEN
      pup$display_line ('   File_Class                    : Unspecified', ignore_status);
    ELSE
      display_string (1, 35) := '   File_Class                    : ';
      display_string (36, 1) := puv$mass_storage_info.mass_storage_class;
      pup$display_line (display_string(1, 36), ignore_status);
    IFEND;

    IF puv$mass_storage_info.initial_volume = rmc$unspecified_vsn THEN
      pup$display_line ('   Initial_Volume                : Unspecified', ignore_status);
    ELSE
      display_string (1, 41) := '   Initial_Volume                :       ';
      display_string (36, 6) := puv$mass_storage_info.initial_volume;
      pup$display_line (display_string (1, 41), ignore_status);
    IFEND;

    pup$display_boolean ('   Replace_Cycle_Data            :', puv$replace_cycle_data, ignore_status);

    pup$display_boolean ('   Require_Matching_Modification :', puv$require_modification_match, ignore_status);

    IF rai_specified THEN
      local_rai := puv$restore_archive_information;
    ELSE
      local_rai := avp$family_administrator () OR avp$system_administrator ();
    IFEND;
    pup$display_boolean ('   Restore_Archive_Information   :', local_rai, ignore_status);

    IF puv$mass_storage_info.shared_queue = pfc$null_shared_queue THEN
      shared_queue_name := pfc$system_shared_queue_name;
    ELSE
      pfp$convert_ord_to_shared_queue (puv$mass_storage_info.shared_queue, shared_queue_name, status);
      IF NOT status.normal THEN
        shared_queue_name := pfc$system_shared_queue_name;
      IFEND;
    IFEND;
    display_string (1, osc$max_name_size + 35) := '   Shared_Queue                  : ';
    display_string (36, osc$max_name_size) := shared_queue_name;
    pup$display_line (display_string (1, osc$max_name_size + 35), ignore_status);

    pup$set_restore_subcmd_defaults (NOT (avp$system_administrator() OR avp$family_administrator()));
    pup$display_boolean ('   Update_Cycle_Statistics       :', puv$update_cycle_statistics, ignore_status);

    pup$display_boolean ('   Volume_Overflow_Allowed       :', puv$mass_storage_info.volume_overflow_allowed,
          ignore_status);

    pup$display_blank_lines (1, status);

  PROCEND pup$display_restore_options_cm;

?? TITLE := '    pup$set_restore_options_command ', EJECT ??

  PROCEDURE pup$set_restore_options_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PROCEDURE (pup$setro) set_restore_options, setro (
{   allocation_size, as: (BY_NAME) any of
{       key
{         ($unspecified, unspecified, u)
{       keyend
{       integer 16384..16777215
{     anyend = $optional
{   create_objects, co: (BY_NAME) any of
{       key
{         ($unspecified, unspecified, u)
{       keyend
{       boolean
{     anyend = $optional
{   file_class, fc: (BY_NAME) any of
{       key
{         product
{         (service_critical_product, scp)
{         (system_critical_file, scf)
{         (system_permanent_file, spf)
{         (user_permanent_file, upf)
{         ($unspecified, unspecified)
{       keyend
{       name 1..1
{     anyend = $optional
{   initial_volume, iv: (BY_NAME) any of
{       key
{         ($unspecified, unspecified, u)
{       keyend
{       name 1..6
{     anyend = $optional
{   replace_cycle_data, rcd: (BY_NAME) any of
{       key
{         ($unspecified, unspecified, u)
{       keyend
{       boolean
{     anyend = $optional
{   require_matching_modification, rmm: (BY_NAME) any of
{       key
{         ($unspecified, unspecified, u)
{       keyend
{       boolean
{     anyend = $optional
{   restore_archive_information, rai: (BY_NAME) any of
{       key
{         ($unspecified, unspecified, u)
{       keyend
{       boolean
{     anyend = $optional
{   shared_queue, sq: (BY_NAME, ADVANCED) key
{       site_01, site_02, site_03, site_04, site_05, site_06, site_07, site_08, site_09, site_10, site_11
{       site_12, site_13, site_14, site_15, site_16, site_17, site_18, site_19, site_20, site_21, site_22
{       site_23, site_24, site_25
{       (system, s)
{       ($unspecified, unspecified, u)
{     keyend = $optional
{   update_cycle_statistics, ucs: (BY_NAME) any of
{       key
{         ($unspecified, unspecified, u)
{       keyend
{       boolean
{     anyend = $optional
{   volume_overflow_allowed, voa: (BY_NAME) any of
{       key
{         ($unspecified, unspecified, u)
{       keyend
{       boolean
{     anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 21] of clt$pdt_parameter_name,
      parameters: array [1 .. 11] 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
      recend,
      type2: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type3: 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 .. 11] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type4: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type5: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type6: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type7: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 30] of clt$keyword_specification,
      recend,
      type9: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type10: 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 .. 3] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type11: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [93, 10, 26, 12, 39, 48, 309],
    clc$command, 21, 11, 0, 1, 0, 0, 11, 'PUP$SETRO'], [
    ['ALLOCATION_SIZE                ',clc$nominal_entry, 1],
    ['AS                             ',clc$abbreviation_entry, 1],
    ['CO                             ',clc$abbreviation_entry, 2],
    ['CREATE_OBJECTS                 ',clc$nominal_entry, 2],
    ['FC                             ',clc$abbreviation_entry, 3],
    ['FILE_CLASS                     ',clc$nominal_entry, 3],
    ['INITIAL_VOLUME                 ',clc$nominal_entry, 4],
    ['IV                             ',clc$abbreviation_entry, 4],
    ['RAI                            ',clc$abbreviation_entry, 7],
    ['RCD                            ',clc$abbreviation_entry, 5],
    ['REPLACE_CYCLE_DATA             ',clc$nominal_entry, 5],
    ['REQUIRE_MATCHING_MODIFICATION  ',clc$nominal_entry, 6],
    ['RESTORE_ARCHIVE_INFORMATION    ',clc$nominal_entry, 7],
    ['RMM                            ',clc$abbreviation_entry, 6],
    ['SHARED_QUEUE                   ',clc$nominal_entry, 8],
    ['SQ                             ',clc$abbreviation_entry, 8],
    ['STATUS                         ',clc$nominal_entry, 11],
    ['UCS                            ',clc$abbreviation_entry, 9],
    ['UPDATE_CYCLE_STATISTICS        ',clc$nominal_entry, 9],
    ['VOA                            ',clc$abbreviation_entry, 10],
    ['VOLUME_OVERFLOW_ALLOWED        ',clc$nominal_entry, 10]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 158,
  clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 141,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 439,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 143,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 141,
  clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 141,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 141,
  clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [15, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 1117,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 141,
  clc$optional_parameter, 0, 0],
{ PARAMETER 10
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 141,
  clc$optional_parameter, 0, 0],
{ PARAMETER 11
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['UNSPECIFIED                    ', clc$alias_entry, clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [16384, 16777215, 10]]
    ],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['UNSPECIFIED                    ', clc$alias_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    414, [[1, 0, clc$keyword_type], [11], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['PRODUCT                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['SCF                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['SCP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['SERVICE_CRITICAL_PRODUCT       ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['SPF                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['SYSTEM_CRITICAL_FILE           ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['SYSTEM_PERMANENT_FILE          ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['UNSPECIFIED                    ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['UPF                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['USER_PERMANENT_FILE            ', clc$nominal_entry, clc$normal_usage_entry, 5]]
      ],
    5, [[1, 0, clc$name_type], [1, 1]]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['UNSPECIFIED                    ', clc$alias_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, 6]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['UNSPECIFIED                    ', clc$alias_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['UNSPECIFIED                    ', clc$alias_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['UNSPECIFIED                    ', clc$alias_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 8
    [[1, 0, clc$keyword_type], [30], [
    ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 27],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 26],
    ['SITE_01                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['SITE_02                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['SITE_03                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['SITE_04                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['SITE_05                        ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['SITE_06                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['SITE_07                        ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['SITE_08                        ', clc$nominal_entry, clc$normal_usage_entry, 8],
    ['SITE_09                        ', clc$nominal_entry, clc$normal_usage_entry, 9],
    ['SITE_10                        ', clc$nominal_entry, clc$normal_usage_entry, 10],
    ['SITE_11                        ', clc$nominal_entry, clc$normal_usage_entry, 11],
    ['SITE_12                        ', clc$nominal_entry, clc$normal_usage_entry, 12],
    ['SITE_13                        ', clc$nominal_entry, clc$normal_usage_entry, 13],
    ['SITE_14                        ', clc$nominal_entry, clc$normal_usage_entry, 14],
    ['SITE_15                        ', clc$nominal_entry, clc$normal_usage_entry, 15],
    ['SITE_16                        ', clc$nominal_entry, clc$normal_usage_entry, 16],
    ['SITE_17                        ', clc$nominal_entry, clc$normal_usage_entry, 17],
    ['SITE_18                        ', clc$nominal_entry, clc$normal_usage_entry, 18],
    ['SITE_19                        ', clc$nominal_entry, clc$normal_usage_entry, 19],
    ['SITE_20                        ', clc$nominal_entry, clc$normal_usage_entry, 20],
    ['SITE_21                        ', clc$nominal_entry, clc$normal_usage_entry, 21],
    ['SITE_22                        ', clc$nominal_entry, clc$normal_usage_entry, 22],
    ['SITE_23                        ', clc$nominal_entry, clc$normal_usage_entry, 23],
    ['SITE_24                        ', clc$nominal_entry, clc$normal_usage_entry, 24],
    ['SITE_25                        ', clc$nominal_entry, clc$normal_usage_entry, 25],
    ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 26],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 27],
    ['UNSPECIFIED                    ', clc$alias_entry, clc$normal_usage_entry, 27]]
    ],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['UNSPECIFIED                    ', clc$alias_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$boolean_type, clc$keyword_type],
    FALSE, 2],
    118, [[1, 0, clc$keyword_type], [3], [
      ['$UNSPECIFIED                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['UNSPECIFIED                    ', clc$alias_entry, clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 11
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$allocation_size = 1,
      p$create_objects = 2,
      p$file_class = 3,
      p$initial_volume = 4,
      p$replace_cycle_data = 5,
      p$require_matching_modification = 6,
      p$restore_archive_information = 7,
      p$shared_queue = 8,
      p$update_cycle_statistics = 9,
      p$volume_overflow_allowed = 10,
      p$status = 11;

    VAR
      pvt: array [1 .. 11] of clt$parameter_value;

    VAR
      caller_id: ost$caller_identifier,
      display_string: string(osc$max_name_size + 18),
      file_class: rmt$mass_storage_class,
      ignore_status: ost$status,
      local_co: boolean,
      local_mass_storage_info: fmt$mass_storage_request_info,
      local_rai: boolean,
      local_rcd: boolean,
      local_ucs: boolean;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_mass_storage_info := puv$mass_storage_info;

    IF pvt [p$allocation_size].specified THEN
      IF pvt [p$allocation_size].value^.kind = clc$keyword THEN
        local_mass_storage_info.allocation_size := rmc$unspecified_allocation_size;
      ELSE
        local_mass_storage_info.allocation_size := pvt [p$allocation_size].value^.integer_value.value;
      IFEND;
    IFEND;

    IF pvt [p$file_class].specified THEN
      IF pvt [p$file_class].value^.kind = clc$keyword THEN
        IF pvt [p$file_class].value^.keyword_value = '$UNSPECIFIED' THEN
          file_class := rmc$unspecified_file_class;
        ELSE
          rmp$convert_keyword_to_class (pvt [p$file_class].value^.keyword_value,
                file_class, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        local_mass_storage_info.mass_storage_class := file_class;
      ELSE
        local_mass_storage_info.mass_storage_class := pvt [p$file_class].value^.name_value (1);
      IFEND;
    IFEND;

    IF pvt [p$initial_volume].specified THEN
      IF pvt [p$initial_volume].value^.kind = clc$keyword THEN
        local_mass_storage_info.initial_volume := rmc$unspecified_vsn;
      ELSE
        local_mass_storage_info.initial_volume := pvt [p$initial_volume].value^.name_value (1, 6);
      IFEND;
    IFEND;

    IF pvt [p$shared_queue].specified THEN
      IF (pvt [p$shared_queue].value^.keyword_value = '$UNSPECIFIED') OR
            (pvt [p$shared_queue].value^.keyword_value = 'SYSTEM') THEN
        local_mass_storage_info.shared_queue := pfc$null_shared_queue;
      ELSE
        pfp$convert_shared_queue_to_ord (pvt [p$shared_queue].value^.keyword_value,
               local_mass_storage_info.shared_queue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    IF pvt [p$volume_overflow_allowed].specified THEN
      IF pvt [p$volume_overflow_allowed].value^.kind = clc$keyword THEN
        local_mass_storage_info.volume_overflow_allowed := TRUE;
      ELSE
        local_mass_storage_info.volume_overflow_allowed :=
              pvt [p$volume_overflow_allowed].value^.boolean_value.value;
      IFEND;
    IFEND;

    #CALLER_ID(caller_id);
    rmp$build_mass_storage_info (local_mass_storage_info.allocation_size,
          local_mass_storage_info.estimated_file_size, local_mass_storage_info.initial_volume,
          local_mass_storage_info.mass_storage_class, local_mass_storage_info.shared_queue,
          local_mass_storage_info.transfer_size, local_mass_storage_info.volume_overflow_allowed,
          caller_id.ring, ^local_mass_storage_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$create_objects].specified THEN
      IF pvt [p$create_objects].value^.kind = clc$keyword THEN
        local_co := TRUE;
      ELSE
        local_co := pvt [p$create_objects].value^.boolean_value.value;
      IFEND;
    ELSE
      local_co := puv$create_objects;
    IFEND;

    IF pvt [p$replace_cycle_data].specified THEN
      IF pvt [p$replace_cycle_data].value^.kind = clc$keyword THEN
        local_rcd := FALSE;
      ELSE
        local_rcd := pvt [p$replace_cycle_data].value^.boolean_value.value;
      IFEND;
    ELSE
      local_rcd := puv$replace_cycle_data;
    IFEND;

    IF (NOT local_co) AND (NOT local_rcd) THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$create_replace_conflict, '', status);
      RETURN;
    IFEND;

    IF pvt [p$update_cycle_statistics].specified THEN
      IF pvt [p$update_cycle_statistics].value^.kind = clc$keyword THEN
        local_ucs := FALSE;
      ELSE
        local_ucs := pvt [p$update_cycle_statistics].value^.boolean_value.value;
      IFEND;
    ELSE
      local_ucs := puv$update_cycle_statistics;
    IFEND;

    IF pvt [p$restore_archive_information].specified AND
          (pvt [p$restore_archive_information].value^.kind <> clc$keyword) AND
          pvt [p$restore_archive_information].value^.boolean_value.value AND
          (NOT (avp$family_administrator () OR avp$system_administrator ())) THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$user_set_rai_true, '', status);
      RETURN;
    IFEND;

    IF pvt [p$restore_archive_information].specified THEN
      IF pvt [p$restore_archive_information].value^.kind = clc$keyword THEN
        local_rai := avp$family_administrator () OR avp$system_administrator ();
      ELSE
        local_rai := pvt [p$restore_archive_information].value^.boolean_value.value;
      IFEND;
    ELSE
      IF rai_specified THEN
        local_rai := puv$restore_archive_information;
      ELSE
        local_rai := avp$family_administrator () OR avp$system_administrator ();
      IFEND;
    IFEND;

    IF (pvt [p$restore_archive_information].specified OR pvt [p$update_cycle_statistics].specified) AND
          (local_rai AND local_ucs) THEN
      osp$set_status_abnormal (puc$pf_utility_id, pue$ucs_rai_conflict, '', status);
      RETURN;
    IFEND;

    puv$mass_storage_info := local_mass_storage_info;

    pup$display_line (' Set_Restore_Options', ignore_status);
    pup$display_blank_lines (1, status);

    IF pvt [p$allocation_size].specified THEN
      IF pvt [p$allocation_size].value^.kind = clc$keyword THEN
        pup$display_line ('   Allocation_Size : Unspecified', ignore_status);
      ELSE
        pup$display_integer ('   Allocation_Size : ', puv$mass_storage_info.allocation_size, ignore_status);
      IFEND;
    IFEND;

    IF pvt [p$create_objects].specified THEN
      puv$create_objects := local_co;
      IF pvt [p$create_objects].value^.kind = clc$keyword THEN
        pup$display_line ('   Create Objects : Unspecified', ignore_status);
      ELSE
        pup$display_boolean ('   Create Objects : ', puv$create_objects, ignore_status);
      IFEND;
    IFEND;

    IF pvt [p$replace_cycle_data].specified THEN
      puv$replace_cycle_data := local_rcd;
      IF pvt [p$replace_cycle_data].value^.kind = clc$keyword THEN
        pup$display_line ('   Replace Cycle Data : Unspecified', ignore_status);
      ELSE
        pup$display_boolean ('   Replace Cycle Data : ', puv$replace_cycle_data, ignore_status);
      IFEND;
      puv$purge_cycle_options.preserve_cycle_entry := puv$replace_cycle_data;
      IF puv$purge_cycle_options.preserve_cycle_entry THEN
        puv$purge_cycle_options.preserve_archive_info := TRUE;
        puv$purge_cycle_options.preserve_file_label := TRUE;
        puv$purge_cycle_options.preserve_modification_date_time := TRUE;
      IFEND;
    IFEND;

    IF pvt [p$file_class].specified THEN
      IF pvt [p$file_class].value^.kind = clc$keyword THEN
        IF pvt [p$file_class].value^.keyword_value = '$UNSPECIFIED' THEN
          pup$display_line ('   File_Class : Unspecified', ignore_status);
        ELSE
          display_string (1, osc$max_name_size + 16) := '   File_Class : ';
          display_string (17, osc$max_name_size) := pvt [p$file_class].value^.keyword_value;
          pup$display_line (display_string (1, osc$max_name_size + 16), ignore_status);
        IFEND;
      ELSE
        display_string (1, 16) := '   File_Class : ';
        display_string (17, 1) := puv$mass_storage_info.mass_storage_class;
        pup$display_line (display_string(1, 17), ignore_status);
      IFEND;
    IFEND;

    IF pvt [p$initial_volume].specified THEN
      IF pvt [p$initial_volume].value^.kind = clc$keyword THEN
        pup$display_line ('   Initial_Volume : Unspecified', ignore_status);
      ELSE
        display_string (1, 26) := '   Initial_Volume :       ';
        display_string (21, 6) := puv$mass_storage_info.initial_volume;
        pup$display_line (display_string (1, 26), ignore_status);
      IFEND;
    IFEND;

    IF pvt [p$require_matching_modification].specified THEN
      IF pvt [p$require_matching_modification].value^.kind = clc$keyword THEN
        puv$require_modification_match := TRUE;
      ELSE
        puv$require_modification_match := pvt [p$require_matching_modification].value^.boolean_value.value;
      IFEND;
      pup$display_boolean ('   Require_Matching_Modification :', puv$require_modification_match,
            ignore_status);
    IFEND;

    IF pvt [p$restore_archive_information].specified THEN
      puv$restore_archive_information := local_rai;
      IF pvt [p$restore_archive_information].value^.kind = clc$keyword THEN
        rai_specified := FALSE;
      ELSE
        rai_specified := TRUE;
      IFEND;
      pup$display_boolean ('   Restore_Archive_Information :', puv$restore_archive_information,
          ignore_status);
    IFEND;

    IF pvt [p$shared_queue].specified THEN
      IF pvt [p$shared_queue].value^.keyword_value = '$UNSPECIFIED' THEN
        pup$display_line ('   Shared_Queue : Unspecified', ignore_status);
      ELSE
        display_string (1, osc$max_name_size + 18) := '   Shared_Queue : ';
        display_string (19, osc$max_name_size) := pvt [p$shared_queue].value^.keyword_value;
        pup$display_line (display_string (1, osc$max_name_size + 18), ignore_status);
      IFEND;
    IFEND;

    IF pvt [p$update_cycle_statistics].specified THEN
      IF pvt [p$update_cycle_statistics].value^.kind = clc$keyword THEN
        update_cycle_statistics_source := utility_default;
        puv$update_cycle_statistics := FALSE;
      ELSE
        update_cycle_statistics_source := set_restore_options_command;
        puv$update_cycle_statistics := local_ucs;
      IFEND;
      pup$display_boolean ('   Update_Cycle_Statistics :', puv$update_cycle_statistics, ignore_status);
    IFEND;

    IF pvt [p$volume_overflow_allowed].specified THEN
      pup$display_boolean ('   Volume_Overflow_Allowed :', puv$mass_storage_info.volume_overflow_allowed,
            ignore_status);
    IFEND;
    pup$display_blank_lines (1, status);

  PROCEND pup$set_restore_options_command;

?? TITLE := '    [XDCL] pup$set_restore_subcmd_defaults ', EJECT ??

  PROCEDURE [XDCL] pup$set_restore_subcmd_defaults (update_cycle_statistics: boolean);

    IF NOT (update_cycle_statistics_source = set_restore_options_command) THEN
      puv$update_cycle_statistics := update_cycle_statistics;
      update_cycle_statistics_source := subcommand_default;
    IFEND;
  PROCEND pup$set_restore_subcmd_defaults;

?? TITLE := '    [XDCL] pup$trace ', EJECT ??

  PROCEDURE [XDCL] pup$trace (parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? RIGHT := 110 ??
{ pdt putrace_pdt (selection, s: boolean = true
{  status)

?? PUSH (LISTEXT := ON) ??

    VAR
      putrace_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^putrace_pdt_names,
        ^putrace_pdt_params];

    VAR
      putrace_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['SELECTION', 1], ['S', 1], ['STATUS', 2]];

    VAR
      putrace_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ SELECTION S }
      [[clc$optional_with_default, ^putrace_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$boolean_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      putrace_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

?? POP ??

    clp$scan_parameter_list (parameter_list, putrace_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pup$crack_boolean ('SELECTION', puv$trace_selected, status);
  PROCEND pup$trace;

MODEND pum$restore_permanent_files;
*DECK DECK=PUP$ABORT_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] pup$abort_output (pf_utility_entry: put$entry;
    VAR pf_backup_file_id: put$file_identifier;
        bad_status: ost$status;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
*copyc PUT$FILE_IDENTIFIER
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$ADVISED_GET_PART EXPAND=FALSE

  PROCEDURE [XREF] pup$advised_get_part
    (VAR backup_file_id: put$file_identifier;
         wsa: ^cell;
         working_storage_length: amt$working_storage_length;
     VAR file_position: put$file_position;
     VAR transfer_count: amt$file_length;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_length
*copyc amt$working_storage_length
*copyc ost$status
*copyc put$file_identifier
*copyc put$file_position
?? POP ??
*DECK DECK=PUP$ADVISED_PUT_NEXT EXPAND=FALSE
  PROCEDURE [XREF] pup$advised_put_next (VAR bfid: put$file_identifier;
        wsa: ^cell;
        wsl: amt$working_storage_length;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc put$file_identifier
*copyc amt$working_storage_length
?? POP ??
*DECK DECK=PUP$ALLOW_JOB_TERMINATION EXPAND=FALSE
?? TITLE := '    [INLINE] pup$allow_job_termination', EJECT ??

  PROCEDURE [INLINE] pup$allow_job_termination;

{ This allows the terminate_job command to take effect for jobs running below
{ the normal ring of recognition for terminate_job.  For jobs running >= the
{ terminate_job recognition ring, termination may occur at anytime.  The
{ utilities are not really interested in waiting, but pmp$wait allows the
{ terminate_job to take effect regardless of ring of execution.

    CONST
      puc$min_job_termination_ring = 4;

    VAR
      caller_id: ost$caller_identifier;

    #caller_id (caller_id);
    IF caller_id.ring < puc$min_job_termination_ring THEN
      pmp$wait (0, 0);
    IFEND;
  PROCEND pup$allow_job_termination;

*copyc ost$caller_identifier
*copyc pmp$wait
*DECK DECK=PUP$ALL_VOLUMES_INCLUDED EXPAND=FALSE
  FUNCTION [XREF] pup$all_volumes_included: boolean;

*DECK DECK=PUP$BACKUP_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pup$backup_catalog (catalog_entry: put$entry;
        pf_utility_catalog_header: put$catalog_header;
        catalog_item_info: pft$p_info_record;
        pf_utility_hierarchy_list: put$hierarchy_list;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
*copyc PUT$FILE_IDENTIFIER
*copyc PFD$CATALOG_INFO
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$BACKUP_CYCLE EXPAND=FALSE

  PROCEDURE [XREF] pup$backup_cycle
    (    cycle_entry: put$entry;
         password: pft$password;
         pf_utility_catalog_header: put$catalog_header;
         cycle_array_entry: pft$cycle_array_entry_version_2;
         pf_utility_hierarchy_list: put$hierarchy_list;
         check_cycle_included: boolean;
     VAR file_display_info: put$file_display_info;
     VAR p_cycle_info_record: { input } pft$p_info_record;
     VAR file_archive_info: { input/output } amt$segment_pointer;
     VAR p_cycle_array_extended_record: pft$p_info_record;
     VAR p_cycle_directory_array: pft$p_cycle_directory_array;
     VAR pf_backup_file_id: put$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$segment_pointer
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pud$hierarchy_list
*copyc put$file_identifier
?? POP ??
*DECK DECK=PUP$BACKUP_CYCLE_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] pup$backup_cycle_request (file_path: pft$path;
        cycle_selector: pft$cycle_selector;
        password: pft$password;
    VAR backup_file_id: put$file_identifier;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc PFD$PERMANENT_FILE_DEFINitions
*copyc put$file_identifier
?? POP ??
*DECK DECK=PUP$BACKUP_FAMILY_REQUEST EXPAND=TRUE
  PROCEDURE [XREF] pup$backup_family_request (set_name: stt$set_name;
        family_name: pft$name;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc put$file_identifier
*copyc std$set_name
?? POP ??
*DECK DECK=PUP$BACKUP_FILE EXPAND=FALSE

  PROCEDURE [XREF] pup$backup_file (pf_entry: put$entry;
        password_provided: boolean;
        password: pft$password;
        pf_utility_catalog_header: put$catalog_header;
        pf_utility_hierarchy_list: put$hierarchy_list;
    VAR pf_backup_file_id: put$file_identifier;
        info: pft$p_info_record;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PUT$FILE_IDENTIFIER
*copyc PFD$CATALOG_INFO
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$BACKUP_PERMANENT_FILE EXPAND=FALSE

  PROCEDURE [XREF] pup$backup_permanent_file ALIAS 'puxbpf' (parameter_list:
    clt$parameter_list;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc CLD$PARAMETER_LIST
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$BUILD_CATALOG_HEADER EXPAND=FALSE

  PROCEDURE [XREF] pup$build_catalog_header
   (    set_name: stt$set_name;
        p_path: ^pft$path;
    VAR catalog_header: put$catalog_header);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc std$set_name
?? POP ??
*DECK DECK=PUP$BUILD_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pup$build_entry ALIAS 'puxbent' (pf_name: pft$name;
        cycle_selector: pft$cycle_selector;
        entry_type: put$entry_type;
    VAR pf_utility_entry: put$entry);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PUD$HIERARCHY_LIST
?? POP ??
*DECK DECK=PUP$BUILD_HIERARCHY_LIST EXPAND=FALSE

  PROCEDURE [XREF] pup$build_hierarchy_list ALIAS 'puxbhl' (pf_utility_entry:
    put$entry;
        catalog_header: put$catalog_header;
    VAR hierarchy_list: put$hierarchy_list;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$BUILD_NEW_CATALOG_HEADER EXPAND=FALSE

  PROCEDURE [XREF] pup$build_new_catalog_header (pfu_entry: put$entry;
        pf_utility_catalog_header: put$catalog_header;
    VAR pf_util_new_catalog_header: put$catalog_header);
?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
?? POP ??
*DECK DECK=PUP$BUILD_NEW_ONLINE_CAT_HEAD EXPAND=FALSE



  PROCEDURE [XREF] pup$build_new_online_cat_head ALIAS 'puxbnoc'
    (catalog_header: put$catalog_header;
        new_catalog_header: put$catalog_header;
        found_catalog_header: put$catalog_header;
    VAR new_online_catalog_header: put$catalog_header);
?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
?? POP ??
*DECK DECK=PUP$BUILD_NEW_PATH EXPAND=FALSE

  PROCEDURE [XREF] pup$build_new_path ALIAS 'puxbunp' (path: pft$path;
        new_name: pft$name;
    VAR new_path: pft$path);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
?? POP ??
*DECK DECK=PUP$CHECK_CYCLE_ACCESS EXPAND=FALSE


  PROCEDURE [XREF] pup$check_cycle_access
    (    cycle_array_entry: pft$cycle_array_entry_version_2;
     VAR cycle_included: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_info
?? POP ??
*DECK DECK=PUP$CHECK_CYCLE_INCLUSION EXPAND=FALSE

  PROCEDURE [XREF] pup$check_cycle_inclusion
    (    catalog_header: put$catalog_header;
         cycle_entry: put$entry;
         cycle_array: pft$cycle_array_version_2;
         cycle_array_index: integer;
     VAR cycle_included: boolean;
     VAR action_descriptor: put$action_descriptor);

?? PUSH (LISTEXT := ON) ??
*copyc pud$hierarchy_list
*copyc pud$list_options
*copyc pfd$catalog_info
?? POP ??
*DECK DECK=PUP$CHECK_IF_FAMILY_IN_RANGE EXPAND=FALSE
  PROCEDURE [XREF] pup$check_if_family_in_range alias 'puxcifr' (family_name: pft$name;
    VAR family_in_range: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
?? POP ??
*DECK DECK=PUP$CHECK_IF_ITEM_EXCLUDED EXPAND=FALSE
  PROCEDURE [XREF] pup$check_if_item_excluded ALIAS 'puxciie' (entry:
    put$entry;
        catalog_header: put$catalog_header;
    VAR item_excluded: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
?? POP ??
*DECK DECK=PUP$CHECK_IF_SIZE_INCLUDED EXPAND=FALSE
 PROCEDURE [XREF] pup$check_if_size_included (cycle_size: amt$file_length;
    VAR cycle_included: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
?? POP ??
*DECK DECK=PUP$CHECK_IF_SUBITEM_EXCLUDED EXPAND=FALSE
  PROCEDURE [XREF] pup$check_if_subitem_excluded
    (    pf_utility_catalog_header: put$catalog_header;
     VAR subitem_excluded: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
?? POP ??
*DECK DECK=PUP$CHECK_IF_USER_IN_RANGE EXPAND=FALSE
  PROCEDURE [XREF] pup$check_if_user_in_range alias 'puxciur' (family_name: pft$name;
        user_name: pft$name;
    VAR user_in_range: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
?? POP ??
*DECK DECK=PUP$CHECK_IF_VOLUME_INCLUDED EXPAND=FALSE
  PROCEDURE [XREF] pup$check_if_volume_included
    (    p_volume_list: ^pft$volume_list;
     VAR volume_included: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc pft$volume_list
?? POP ??
*DECK DECK=PUP$CHECK_SITE_BACKUP_OPTIONS EXPAND=FALSE

  PROCEDURE [XREF] pup$check_site_backup_options
    (    cycle_array_entry: pft$cycle_array_entry_version_2;
     VAR cycle_included: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_info
?? POP ??
*DECK DECK=PUP$CLOSE_BACKUP_FILE EXPAND=FALSE

  PROCEDURE [XREF] pup$close_backup_file ALIAS 'puxclbf' (VAR file_id:
    put$file_identifier;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUT$FILE_IDENTIFIER
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$CLOSE_DISPLAY_FILE EXPAND=FALSE

  PROCEDURE [XREF] pup$close_display_file (lfn: amt$local_file_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$COMPARE_CYCLE_SELECTORS EXPAND=FALSE

  PROCEDURE [XREF] pup$compare_cycle_selectors ALIAS 'puxcocs'
    (cycle_selector_a: pft$cycle_selector;
        cycle_selector_b: pft$cycle_selector;
    VAR a_equals_b: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
?? POP ??
*DECK DECK=PUP$COMPARE_ITEM_DESCRIPTOR EXPAND=FALSE

  PROCEDURE [XREF] pup$compare_item_descriptor ALIAS 'puxcid' (put_entry_a:
    put$entry;
        cat_header_a: put$catalog_header;
        put_entry_b: put$entry;
        cat_header_b: put$catalog_header;
    VAR a_equals_b: boolean;
    VAR a_subset_of_b: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
?? POP ??
*DECK DECK=PUP$COMPARE_PATHS EXPAND=FALSE

  PROCEDURE [XREF] pup$compare_paths ALIAS 'puxcopa' (path_a: pft$path;
        path_b: pft$path;
    VAR a_equals_b: boolean;
    VAR a_above_b: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
?? POP ??
*DECK DECK=PUP$CONSTRUCT_VOLUME_LIST EXPAND=TRUE
PROCEDURE (hidden) pup$construct_volume_list (
  vsn_prefix, vp: any of
      name 1..5
      string 1..5
      integer 0..99999
    anyend = $optional
  vsn_count, vc: integer 1..11881376 = 9
  vsn_suffix, vs: any of
      name 1..5
      string 1..5
      integer 0..99998
    anyend = $optional
  increment_scheme, is: key
      (alphabetic, a)
      (decimal, d)
    keyend = decimal
  volume_list, vl: (VAR) list of string 6 = $required
  status)

  "$FORMAT=OFF
  VAR
    base_digit: integer = $ord('A')
    counter: integer 0 .. 11881376 = 0
    decimal_increment: boolean = (increment_scheme=decimal)
    prefix: string 0..6
    prefix_size: integer 0..6
    suffix: string 0..11
    suffix_size: integer 1..6
  VAREND

  "$FORMAT=ON"

  IF $specified(vsn_prefix) THEN
    prefix=$translate(lower_to_upper, $string(vsn_prefix))
    prefix_size=$size(prefix)
  ELSE
    prefix=''
    prefix_size=0
  IFEND

  suffix_size=6 - prefix_size

  IF decimal_increment THEN
    counter = 1
  IFEND

  IF $specified(vsn_suffix) THEN
    value_type=$generic_type(vsn_suffix)
    IF (value_type = 'INTEGER') AND decimal_increment THEN
      counter=vsn_suffix
      max_counter_value=10 ** (suffix_size)
    ELSEIF ((value_type = 'NAME') OR (value_type = 'STRING')) AND (NOT decimal_increment) THEN
      " Determine numeric equivalent of suffix.
      specified_suffix=$translate(lower_to_upper, $string(vsn_suffix))
      specified_suffix_size=$size(specified_suffix)
      power=1
      FOR i = specified_suffix_size TO 1 BY - 1 DO
        counter=counter + (($ord(specified_suffix(i)) - base_digit)* power)
        power=26 * power
      FOREND
      max_counter_value=26 ** (suffix_size)
    ELSE
      EXIT_PROC WITH $status(false, 'PU', 3330, ' INCREMENT_SCHEME of '//is..
//' is incompatible with type of             vsn_suffix.')
    IFEND
  ELSE
    IF decimal_increment THEN
      max_counter_value=10 ** (suffix_size)
    ELSE
      max_counter_value=26 ** (suffix_size)
    IFEND
  IFEND

  IF (counter + vsn_count)> max_counter_value THEN
    EXIT_PROC WITH $status(false, 'PU', 3330, ..
          'VSN_COUNT too large for specified VSN_SUFFIX.')
  IFEND

"$FORMAT=OFF
VAR
   vsn_array: ARRAY counter .. (counter + vsn_count-1) of string 6
VAREND
"$FORMAT=OFF

  IF decimal_increment THEN
    FOR i = counter TO counter+vsn_count-1 DO
       vsn_array(i) = prefix//$justify(''//i,suffix_size,right,'0')
    FOREND
  ELSE
    FOR i = counter TO counter+vsn_count-1 DO
      value = i
      suffix = ''
      FOR j = 1 TO suffix_size DO
        suffix = $char($mod(value, 26)+base_digit) // suffix
        value = value / 26
      FOREND
      vsn_array(i) = prefix // suffix
    FOREND
  IFEND
  volume_list = vsn_array

PROCEND pup$construct_volume_list
*DECK DECK=PUP$CONVERT_CYCLE_PATH_TO_STRNG EXPAND=FALSE
 PROCEDURE [XREF] pup$convert_cycle_path_to_strng (path: pft$path;
        cycle_number: pft$cycle_number;
    VAR path_string: ost$string);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
*copyc ost$string
?? POP ??
*DECK DECK=PUP$CONVERT_GFN_TO_STRING EXPAND=FALSE
  PROCEDURE [XREF] pup$convert_gfn_to_string (binary_name: ost$binary_unique_name;
    VAR result_string: string (60));
?? PUSH (LISTEXT := ON) ??
*copyc osd$unique_name
?? POP ??
*DECK DECK=PUP$CONVERT_PATH_TO_STRING EXPAND=FALSE
 PROCEDURE [XREF] pup$convert_path_to_string (path: pft$path;
    VAR path_string: ost$string);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
*copyc ost$string
?? POP ??
*DECK DECK=PUP$CRACK_BACKUP_FILE EXPAND=FALSE

  PROCEDURE [XREF] pup$crack_backup_file (file: fst$file_reference;
    VAR backup_file_phn: fst$path_handle_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc fst$path_handle_name
*copyc ost$status
?? POP ??

*DECK DECK=PUP$CRACK_BOOLEAN EXPAND=FALSE

  PROCEDURE [XREF] pup$crack_boolean ALIAS 'puxcboo' (parameter_name: string (
    * );
    VAR boolean_value: boolean;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$CRACK_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pup$crack_catalog ALIAS 'puxcrc' (parameter_name: string ( *
    );
    VAR path_container: clt$path_container;
    VAR p_path: ^pft$path;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc CLD$PATH_DESCRIPTION
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$CRACK_DATE_TIME EXPAND=FALSE

  PROCEDURE [XREF] pup$crack_date_time ALIAS 'puxcrdt' (VAR date_time:
    ost$date_time;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$DATE_TIME
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$CRACK_FILE EXPAND=FALSE


  PROCEDURE [XREF] pup$crack_file ALIAS 'puxcrf' (parameter_name: string ( * );
    VAR file_lfn: amt$local_file_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$CRACK_FILE_REFERENCE EXPAND=FALSE

  PROCEDURE [XREF] pup$crack_file_reference ALIAS 'puxcrfr' (parameter_name:
    string ( * );
    VAR lfn: amt$local_file_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$CRACK_NAME_LIST EXPAND=FALSE
  PROCEDURE [XREF] pup$crack_name_list (parameter_name: string ( * );
    VAR name_list_container: SEQ (REP 20 OF ost$name);
    VAR p_name_list: ^array [1 .. * ] OF ost$name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*COPYC OST$NAME
*COPYC OST$STATUS
?? POP ??
*DECK DECK=PUP$CRACK_PASSWORD EXPAND=FALSE

  PROCEDURE [XREF] pup$crack_password ALIAS 'puxcrpw' (parameter_name: string (
    * );
    VAR password: pft$password;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$CRACK_PERMANENT_FILE EXPAND=FALSE
 PROCEDURE [XREF] pup$crack_permanent_file ALIAS 'puxcrpf' (parameter_name:
  string ( * );
        allowed_cycle_references: put$cycle_reference_selections;
    VAR path_container: clt$path_container;
    VAR p_path: ^pft$path;
    VAR cycle_selector_specified: boolean;
    VAR cycle_selector: pft$cycle_selector;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
*copyc cld$path_description
*copyc ost$status
*copyc pud$cycle_reference
?? POP ??
*DECK DECK=PUP$CRACK_PF_FILE_REFERENCE EXPAND=FALSE

  PROCEDURE [XREF] pup$crack_pf_file_reference
   (    file: fst$file_reference;
        allowed_cycle_references: put$cycle_reference_selections;
        parameter_name: string(*);
    VAR path_container: clt$path_container;
    VAR p_path: ^pft$path;
    VAR cycle_selector_specified: boolean;
    VAR cycle_selector: pft$cycle_selector;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cld$path_description
*copyc fst$file_reference
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pud$cycle_reference
?? POP ??
*DECK DECK=PUP$CRACK_RESEFC_SELECTION EXPAND=FALSE
  PROCEDURE [XREF] pup$crack_resefc_selection
    (    parameter: string ( * );
     VAR restore_options: put$restore_data_selections;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc put$restore_data_selections
?? POP ??
*DECK DECK=PUP$CRACK_USER_RANGE_LIST EXPAND=FALSE
  PROCEDURE [XREF] pup$crack_user_range_list ALIAS 'puxcurl' (parameter_name: string ( * );
    VAR uncracked_parameter: ost$string;
    VAR list_container: put$user_range_list_container;
    VAR p_user_range_list: ^put$user_range_list;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STRING
*copyc PUT$USER_RANGE_LIST
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$CREATE_AGED_FILE_BACKUP EXPAND=TRUE
PROCEDURE create_aged_file_backup, creafb, archive_files, arcf (
  date, d: date_time = $required
  vsn_prefix, vsnp, vp: any of
      name 1..5
      string 1..5
      integer 1..99999
    anyend = $optional
  vsn_count, vsnc, vc: integer 1..11881376 = 9
  increment_scheme, is: key
      alphabetic, a, decimal, d
    keyend = decimal
  vsn_list, vsnl: list of any of
      name 1..6
      string 1..6
    anyend = $optional
  file_label_type, flt: key
      (labeled, labelled, l)
      (unlabeled, unlabelled, u)
    keyend = labeled
  type, t: key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = mt9$6250
  backup_file, bf: file = $optional
  output_disposition, odi: any of
      key
        (discard_all_output, dao),(discard_standard_output, dso),
        (printer, p),(wait_queue, wt, wq)
      keyend
      file
    anyend = puv$create_aged_file_backup, printer
  status)

"  The purpose of this procedure is to create a batch job to backup
"  and delete all files on the system not accessed since the specified date.
"
"  The files are backed up in alphabetic order sorted by family and user.
"  The files in the $system catalog will not be archived.
"
"  To support the use of labelled backup tapes the list of VSN's for the
"  backup tapes are generated by the procedure. The value of the VSN's
"  depends on the values for vsn_prefix, vsn_count and increment_scheme.
"
"  PARAMETERS:
"    date, d: Files last accessed before the date specified will be included
"       in the archive. This parameter is required.
"
"    vsn_prefix, vsnp: Specify a one to five character name, string or integer
"      that will become the leftmost characters in the list of VSN's generated
"      by the procedure.
"
"    vsn_count, vsnc: The number of backup tapes in the set. The number of
"      tapes actually required for a backup will be unknown until the
"      backup is complete; however, this parameter must be specified to
"      provide enough information to generate a list of VSN's for labelled
"      tapes. The value specified should be larger than the actual amount
"      required. The backup will stop after all the data has been backed up
"      and use only the number of tapes required to hold the data.
"
"    increment_scheme, is: This parameter determines the format for the
"      rightmost characters of the VSN's generated by this procedure.
"      Decimal mode is the default. Alphabetic mode is for situations
"      where a decimal increment scheme does not allow enough tapes.
"
"    vsn_list, vsnl: A list of magnetic tape external VSNs generated by
"      a calling procedure such as SELECT_OPERATOR_MENU.  This parameter
"      value overrides the vsn_prefix, vsn_count, and increment_scheme VSN
"      generation parameters.
"
"    file_label_type, flt: This parameter specifies the type of label
"      on the backup tapes you are using. If this parameter is not specified,
"      then LABELED is used.
"
"    type, t: This parameter specifies the density of the backup tapes
"      you are using.
"
"    backup_file: This parameter is used to create a permanent backup
"      file, which can be either a permanent mass storage file or a permanent
"      tape file.  If this parameter is specified, the following parameters
"      will be ignored.
"
"          file_label_type
"          increment_scheme
"          type
"          vsn_count
"          vsn_list
"          vsn_prefix
"
"    output_disposition, odi: This parameter specifies the destination of the
"      output generated.  The default for this parameter is 'PRINTER'
"
" VSN Generation Examples:
"   vsn_prefix=part vsn_count=12 increment_scheme=decimal ==>part01-part12
"   vsn_prefix=part vsn_count=12 increment_scheme=alphabetic ==>partaa-partal
"
"   vsn_prefix=A1 vsn_count=27 increment_scheme=decimal ==>A10001-A10027
"   vsn_prefix=A1 vsn_count=27 increment_scheme=alphabetic ==>A1AAAA-A1AABA

  VAR
    access_date: string = $date_time_string('ISOD.HMS' date)
    backup_file_created: boolean = FALSE
    job_file: file = $unique(:$local)
    volume_list: list 1 .. $max_list of string 6
  VAREND

  IF $specified(backup_file) THEN
    IF $string($file_attributes(backup_file, lifetime)) <> 'UNLIMITED'  THEN
      EXIT procedure WITH $status(false, 'PU', 3330, 'The file specified '//..
'by the BACKUP_FILE parameter must be a permanent mass storage file or a permanent tape file.')
    ELSE
      IF NOT $string($file_attributes(backup_file, registered))='YES' THEN
        create_file f=backup_file
        detach_file f=backup_file
        backup_file_created = TRUE
      IFEND
    IFEND
  ELSE
    IF $specified(vsn_list) THEN
      delete_variable volume_list
      volume_list = $apply(vsn_list, $string(x))
    ELSE
      pup$construct_volume_list vsn_count=vsn_count vsn_prefix=vsn_prefix increment_scheme=increment_scheme ..
            volume_list=volume_list
    IFEND
  IFEND

  IF $specified(backup_file) THEN
    attach_or_request_command = 'attach_file am=write local_file_name=backup_file file= '//$string(backup_file)
  ELSE
    attach_or_request_command = 'request_magnetic_tape file=$local.backup_file ring=yes type='//$string(type)// ..
          ' external_vsn='//$string(volume_list, source)// ..
          '; set_file_attributes file=$local.backup_file file_label_type='//$string(file_label_type)
  IFEND

"Create a file containing a batch job to do the actual backup.
COLLECT_TEXT output=job_file sm='?' until='**END_COLLECT**'
  JOB job_name=archive job_class=system magnetic_tape_limit=unlimited output_disposition=?output_disposition?
    ?attach_or_request_command?

    WHEN any_fault DO
     IF ?backup_file_created? THEN
       change_file_attributes file=$local.backup_file ring_attributes=(11,11,11)
     IFEND
     detach_file file=$local.backup_file
     display_value osv$status
     send_operator_message ' CREATE_AGED_FILE_BACKUP aborting -check listing '
    WHENEND

    SYSTEM_OPERATOR_UTILITY CAPABILITY=SYSTEM_ADMINISTRATION
    TASK ring=3
      backup_permanent_files backup_file=$local.backup_file list=$local.archive_list
        set_list_options cycle_display_options=(size modification_date_time access_date_time)
        include_cycles selection_criteria=accessed before=?access_date?
        exclude_catalog catalog=$system
        backup_all_files
        delete_all_files
      QUIT
      print_file file=$local.archive_list copies=2
      IF ?backup_file_created? THEN
        change_file_attributes file=$local.backup_file ring_attributes=(11,11,11)
      IFEND
      detach_file file=$local.backup_file
    TASKEND
    QUIT

  JOBEND
**END_COLLECT**

  include_file file=job_file
  detach_file file=job_file

PROCEND create_aged_file_backup
*DECK DECK=PUP$CREATE_CATALOG_BACKUP EXPAND=TRUE
PROCEDURE create_catalog_backup, crecb, backup_catalogs, bacc (
  vsn_prefix, vsnp, vp: any of
      name 1..5
      string 1..5
      integer 1..99999
    anyend = $optional
  vsn_count, vsnc, vc: integer 1..11881376 = 9
  increment_scheme, is: key
      (alphabetic, a)
      (decimal, d)
    keyend = decimal
  vsn_list, vsnl: list of any of
      name 1..6
      string 1..6
    anyend = $optional
  file_label_type, flt: key
      (labeled, labelled, l)
      (unlabeled, unlabelled, u)
    keyend = labeled
  type, t: key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = mt9$6250
  backup_file, bf: file = $optional
  output_disposition, odi: any of
      key
        (discard_all_output, dao),(discard_standard_output, dso),
        (printer, p),(wait_queue, wt, wq)
      keyend
      file
    anyend = puv$create_catalog_backup, printer
  status)

"  The purpose of this procedure is to create a batch job to backup all
"  catalogs on the system to a set of backup tapes or to a permanent backup
"  file.  The catalogs are backed up in alphabetic order sorted by family and
"  user.  This procedure may be run while there are currently active users.
"
"  The backup tapes or the backup file produced by this procedure may be used
"  as input to the RESTORE_UNRECONCILED_CATALOGS and RESTORE_CATALOGED_FILES
"  procs.  If this backup set or the backup file is used as input to the
"  RESTORE_CATALOGED_FILES proc, the set of partial tapes or the permanent
"  backup file containing the partial backups, if any, need to be
"  restored next, to restore the most recent catalog information.
"
"  To support the use of labelled backup tapes the list of VSN's for the
"  backup tapes are generated by the procedure. The value of the VSN's
"  depends on the values for vsn_prefix, vsn_count and increment_scheme.
"
"  PARAMETERS:
"    vsn_prefix, vsnp: Specify a one to five character name, string or integer
"      that will become the leftmost characters in the list of VSN's generated
"      by the procedure.
"
"    vsn_count, vsnc: The number of backup tapes in the set. The number of
"      tapes actually required for a backup will be unknown until the
"      backup is complete; however, this parameter must be specified to
"      provide enough information to generate a list of VSN's for labelled
"      tapes. The value specified should be larger than the actual amount
"      required. The backup will stop after all the data has been backed up
"      and use only the number of tapes required to hold the data.
"
"    increment_scheme, is: This parameter determines the format for the
"      rightmost characters of the VSN's generated by this procedure.
"      Decimal mode is the default. Alphabetic mode is for situations
"      where a decimal increment scheme does not allow enough tapes.
"
"    vsn_list, vsnl: A list of magnetic tape external VSNs generated by
"      a calling procedure such as SELECT_OPERATOR_MENU.  This parameter
"      value overrides the vsn_prefix, vsn_count, and increment_scheme VSN
"      generation parameters.
"
"    file_label_type, flt: This parameter specifies the type of label
"      on the backup tapes you are using. If this parameter is not specified,
"      then LABELED is used.
"
"    backup_file: This parameter is used to create a permanent backup
"      file, which can be either a permanent mass storage file or a permanent
"      tape file.  If this parameter is specified, the following parameters
"      will be ignored.
"
"          file_label_type
"          increment_scheme
"          type
"          vsn_count
"          vsn_list
"          vsn_prefix
"
"    type, t: This parameter specifies the density of the backup tapes
"      you are using.
"
"    output_disposition, odi: This parameter specifies the destination of the
"      output generated.  The default for this parameter is 'PRINTER'
"
"    help, h: This parameter causes documentation for this procedure to
"      be written to the specified file. The procedure will not be run
"      in this case.
"
" VSN Generation Examples:
"   vsn_prefix=part vsn_count=12 increment_scheme=decimal    ==>part01-part12
"   vsn_prefix=part vsn_count=12 increment_scheme=alphabetic ==>partaa-partal
"
"   vsn_prefix=A1 vsn_count=27 increment_scheme=decimal    ==>A10001-A10027
"   vsn_prefix=A1 vsn_count=27 increment_scheme=alphabetic ==>A1AAAA-A1AABA

  VAR
    backup_file_created: boolean = FALSE
    job_file: file = $unique(:$local)
    volume_list: list 1 .. $max_list of string 6
  VAREND

  IF $specified(backup_file) THEN
    IF $string($file_attributes(backup_file, lifetime)) <> 'UNLIMITED'  THEN
      EXIT procedure WITH $status(false, 'PU', 3330, 'The file specified '//..
'by the BACKUP_FILE parameter must be a permanent mass storage file or a permanent tape file.')
    ELSE
      IF NOT $string($file_attributes(backup_file, registered))='YES' THEN
        create_file f=backup_file
        detach_file f=backup_file
        backup_file_created = TRUE
      IFEND
    IFEND
  ELSE
    IF $specified(vsn_list) THEN
      delete_variable volume_list
      volume_list = $apply(vsn_list, $string(x))
    ELSE
      pup$construct_volume_list vsn_count=vsn_count vsn_prefix=vsn_prefix increment_scheme=increment_scheme ..
            volume_list=volume_list
    IFEND
  IFEND

  IF $specified(backup_file) THEN
    attach_or_request_command = 'attach_file am=write local_file_name=backup_file file= '//$string(backup_file)
  ELSE
    attach_or_request_command = 'request_magnetic_tape file=$local.backup_file ring=yes type='//$string(type)// ..
          ' external_vsn='//$string(volume_list, source)// ..
          '; set_file_attributes file=$local.backup_file file_label_type='//$string(file_label_type)
  IFEND

"Create a file containing a batch job to do the actual backup.
COLLECT_TEXT output=job_file sm='?' until='**END_COLLECT**'
  JOB job_name=create_catalog_backup job_class=system magnetic_tape_limit=unlimited output_disposition=?output_disposition?
    ?attach_or_request_command?

    WHEN any_fault DO
     detach_file file=$local.backup_file
     display_value osv$status
     send_operator_message ' CREATE_CATALOG_BACKUP aborting -check listing '
    WHENEND

    SYSTEM_OPERATOR_UTILITY capability=system_administration
      backup_permanent_files backup_file=$local.backup_file
        VAR
          ignore_status: status
        VAREND
        set_list_options display_excluded_items=false
        set_backup_options include_archive_information=TRUE
        exclude_highest_cycles number_of_cycles=all
        exclude_catalog  $system.$df$client_mainframes  status=ignore_status
        backup_all_files
      QUIT
    END_SYSTEM_OPERATOR_UTILITY
    detach_file file=$local.backup_file
  JOBEND
**END_COLLECT**

  include_file file=job_file
  detach_file file=job_file

PROCEND create_catalog_backup
*DECK DECK=PUP$CREATE_FULL_BACKUP EXPAND=TRUE
PROCEDURE create_full_backup, crefb, full_backup, fulb (
  vsn_prefix, vsnp, vp: any of
      name 1..5
      string 1..5
      integer 1..99999
    anyend = $optional
  vsn_count, vsnc, vc: integer 1..11881376 = 9
  increment_scheme, is: key
      (alphabetic, a)
      (decimal, d)
    keyend = decimal
  vsn_list, vsnl: list 1..$max_list of any of
      string 1..6
      name 1..6
    anyend = $optional
  file_label_type, flt: key
      (labeled, labelled, l)
      (unlabeled, unlabelled, u)
    keyend = labeled
  type, t: key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = mt9$6250
  backup_file, bf: file = $optional
  backup_catalogs, bc: boolean = TRUE
  backup_system_family, bsf: boolean = TRUE
  output_disposition, odi: any of
      key
        (discard_all_output, dao),(discard_standard_output, dso),
        (printer, p),(wait_queue, wt, wq)
      keyend
      file
    anyend = puv$create_full_backup, printer
  status)

"  The purpose of this procedure is to create a batch job to backup
"  all files on the system to a set of backup tapes or to a permanent backup
"  file.
"
"  The files are backed up in alphabetic order sorted by family and user.
"  The files in the catalog $system.aam.shared_recovery_log are
"  backed up last because AAM stores backup information in this catalog.
"
"  After the backup is complete the HPA monitor job will be restarted.
"
"  A file, $system.date_of_full_backup, is created that contains the
"  date and time the full backup began. This information is used by the
"  partial_backup procedure to determine what files it should back up.
"
"  To support the use of labelled backup tapes the list of VSN's for the
"  backup tapes are generated by the procedure. The value of the VSN's
"  depends on the values for vsn_prefix, vsn_count and increment_scheme.
"
"  PARAMETERS:
"    vsn_prefix, vsnp: Specify a one to five character name, string or integer
"      that will become the leftmost characters in the list of VSN's generated
"      by the procedure.
"
"    vsn_count, vsnc: The number of backup tapes in the set. The number of
"      tapes actually required for a backup will be unknown until the
"      backup is complete; however, this parameter must be specified to
"      provide enough information to generate a list of VSN's for labelled
"      tapes. The value specified should be larger than the actual amount
"      required. The backup will stop after all the data has been backed up
"      and use only the number of tapes required to hold the data.
"
"    increment_scheme, is: This parameter determines the format for the
"      rightmost characters of the VSN's generated by this procedure.
"      Decimal mode is the default. Alphabetic mode is for situations
"      where a decimal increment scheme does not allow enough tapes.
"
"    vsn_list, vsnl: A list of magnetic tape external VSNs generatated by
"      an calling procedure such as SELECT_OPERATOR_MENU.  This parameter
"      value overrides the vsn_prefix, vsn_count, and increment_scheme VSN
"      generation parameters.
"
"    file_label_type, flt: This parameter specifies the type of label
"      on the backup tapes you are using. If this parameter is not specified,
"      then LABELED is used.
"
"    type, t: This parameter specifies the density of the backup tapes
"      you are using.
"
"    backup_file: This parameter is used to create a permanent backup
"      file, which can be either a permanent mass storage file or a permanent
"      tape file.  If this parameter is specified, the following parameters
"      will be ignored.
"
"          file_label_type
"          increment_scheme
"          type
"          vsn_count
"          vsn_list
"          vsn_prefix
"
"    backup_catalogs, bc: This parameter specifies if the catalog information
"      should be included in the backup. The default for this parameter is TRUE.
"
"    backup_system_family, bsf: This parameter specifies if the $system
"      family should be included in the backup. The defualt for this parameter
"      is TRUE.
"
"    output_disposition, odi: This parameter specifies the destination of the
"      output generated.  The default for this parameter is 'PRINTER'
"
" VSN Generation Examples:
"   vsn_prefix=part vsn_count=12 increment_scheme=decimal    ==>part01-part12
"   vsn_prefix=part vsn_count=12 increment_scheme=alphabetic ==>partaa-partal
"
"   vsn_prefix=A1 vsn_count=27 increment_scheme=decimal    ==>A10001-A10027
"   vsn_prefix=A1 vsn_count=27 increment_scheme=alphabetic ==>A1AAAA-A1AABA

  VAR
    backup_file_created: boolean = FALSE
    job_file: file = $unique(:$local)
    volume_list: list 1 .. $max_list of string 6
  VAREND

  IF $specified(backup_file) THEN
    IF $string($file_attributes(backup_file, lifetime)) <> 'UNLIMITED'  THEN
      EXIT procedure WITH $status(false, 'PU', 3330, 'The file specified '//..
'by the BACKUP_FILE parameter must be a permanent mass storage file or a permanent tape file.')
    ELSE
      IF NOT $string($file_attributes(backup_file, registered))='YES' THEN
        create_file f=backup_file
        detach_file f=backup_file
        backup_file_created = TRUE
      IFEND
    IFEND
  ELSE
    IF $specified(vsn_list) THEN
      delete_variable volume_list
      volume_list = $apply(vsn_list, $string(x))
    ELSE
      pup$construct_volume_list vsn_count=vsn_count vsn_prefix=vsn_prefix increment_scheme=increment_scheme ..
            volume_list=volume_list
    IFEND
  IFEND

  IF $specified(backup_file) THEN
    attach_or_request_command = 'attach_file am=write local_file_name=backup_file file= '//$string(backup_file)
  ELSE
    attach_or_request_command = 'request_magnetic_tape file=$local.backup_file ring=yes type='//$string(type)// ..
          ' external_vsn='//$string(volume_list, source)// ..
          '; set_file_attributes file=$local.backup_file file_label_type='//$string(file_label_type)
  IFEND

"Create a file containing a batch job to do the actual backup.
COLLECT_TEXT output=job_file sm='?' until='**END_COLLECT**'
  JOB job_name=fullback job_class=system magnetic_tape_limit=unlimited output_disposition=?output_disposition?
    ?attach_or_request_command?
    date=$date(mdy)
    time=$time(hms)

    WHEN any_fault DO
     IF ?backup_file_created? THEN
       change_file_attributes file=$local.backup_file ring_attributes=(11,11,11)
     IFEND
     detach_file file=$local.backup_file
     display_value osv$status
     send_operator_message ' CREATE_FULL_BACKUP aborting -check listing '
    WHENEND

    SYSTEM_OPERATOR_UTILITY CAPABILITIES=(SYSTEM_ADMINISTRATION SYSTEM_DISPLAYS)

    VAR
      empty_list: list 0 .. 0 of string
      exclude_status: status
      family_list: list of name = ()
      rml_is_active: boolean
      rms_status: status
    VAREND

    LOGICAL_CONFIGURATION_UTILITY
      FOR each set in $active_sets() DO
        family_list = $join($active_set_families(set), family_list)
      FOREND
    QUIT

    rml_is_active = FALSE
    IF $file($system.rms.rsf$command_library, permanent) THEN
      PUSH command_list
      create_command_list_entry $system.rms.rsf$command_library status=rms_status
      IF $library(active)<>empty_list THEN
        rml_is_active = TRUE
        rml_catalog = $path($array($library(active))(1), catalog)
        rml = $array($library(active))(1)
        IF $string($file_attributes(rml, log_residence)) <> 'NONE' THEN
          exclude_recovery_logs_cmd = 'exclude_catalog catalog = '//..
                $string($file_attributes(rml, log_residence))
          backup_recovery_logs_cmd = 'backup_catalog catalog = '//..
                $string($file_attributes(rml, log_residence))
        ELSE
          exclude_recovery_logs_cmd = '"No recovery logs configured."'
          backup_recovery_logs_cmd = '"No recovery logs configured."'
        IFEND
      IFEND
      POP command_list
    IFEND;

    TASK ring=3
      backup_permanent_files backup_file=$local.backup_file
        set_backup_options include_archive_information=TRUE
        set_backup_options exclude_catalog_information=?$NOT(backup_catalogs)?
        IF "include $system catalog =" ?backup_system_family? THEN
          "$system family included in backup.
        ELSE
          exclude_catalog catalog=:$system status=exclude_status
        IFEND

        FOR EACH family_name IN family_list DO
          exclude_catalog catalog=$fname(':'//$string(family_name)//'.$SYSTEM.$JOB_INPUT_QUEUE')..
                status=exclude_status
        FOREND

        exclude_catalog catalog=$system.$df$client_mainframes status=exclude_status
        exclude_catalog catalog=$system.aam.shared_recovery_log status=exclude_status

        IF rml_is_active THEN
          exclude_catalog catalog=$fname(rml_catalog)
          include_line exclude_recovery_logs_cmd
        IFEND

        backup_all_files

        IF exclude_status.normal THEN
          backup_catalog catalog=$system.aam.shared_recovery_log
        IFEND

        IF rml_is_active THEN
          close_volume
          backup_catalog catalog=$fname(rml_catalog)
          include_line backup_recovery_logs_cmd
        IFEND;

      QUIT
      IF ?backup_file_created? THEN
        change_file_attributes file=$local.backup_file ring_attributes=(11,11,11)
      IFEND
      detach_file file=$local.backup_file
    TASKEND
    QUIT

    put_line line=date output=$user.date_of_full_backup.$boi
    put_line line=time output=$user.date_of_full_backup.$eoi

    include_file file=$system.hardware_maintenance.hpa.hpf$start_monitor_job
  JOBEND
**END_COLLECT**

  include_file file=job_file
  detach_file file=job_file

PROCEND create_full_backup
*DECK DECK=PUP$CREATE_PARTIAL_BACKUP EXPAND=TRUE
PROCEDURE create_partial_backup, crepb, partial_backup, parb (
  vsn_prefix, vsnp, vp: any of
      name 1..5
      string 1..5
      integer 1..99999
    anyend = $optional
  vsn_count, vsnc, vc: integer 1..11881376 = 9
  increment_scheme, is: key
      alphabetic, a, decimal, d
    keyend = decimal
  vsn_list, vsnl: list of any of
      string 1..6
      name 1..6
    anyend = $optional
  file_label_type, flt: key
      (labeled, labelled, l)
      (unlabeled, unlabelled, u)
    keyend = labeled
  type, t: key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = mt9$6250
  backup_file, bf: file = $optional
  backup_catalogs, bc: boolean = TRUE
  backup_system_family, bsf: boolean = TRUE
  date, d: date_time = $optional
  output_disposition, odi: any of
      key
        (discard_all_output, dao),(discard_standard_output, dso),
        (printer, p),(wait_queue, wt, wq)
      keyend
      file
    anyend = puv$create_partial_backup, printer
  status)

"  The purpose of this procedure is to create a batch job to backup
"  all files on the system modified since the last full backup.
"  The date and time of the last full backup are stored in the file
"  $system.date_of_full_backup by the full backup procedure.
"  If desired, the date and time can be specified using the parameter
"  supplied. This method will take precedence over the values stored
"  in the file.
"
"  The files are backed up in alphabetic order sorted by family and user.
"  The files in the catalog $system.aam.shared_recovery_log are
"  backed up last because AAM stores backup information in this catalog.
"
"  After the backup is complete the HPA monitor job will be restarted.
"
"  To support the use of labelled backup tapes the list of VSN's for the
"  backup tapes are generated by the procedure. The value of the VSN's
"  depends on the values for vsn_prefix, vsn_count and increment_scheme.
"
"  PARAMETERS:
"    vsn_prefix, vsnp: Specify a one to five character name, string or integer
"      that will become the leftmost characters in the list of VSN's generated
"      by the procedure.
"
"    vsn_count, vsnc: The number of backup tapes in the set. The number of
"      tapes actually required for a backup will be unknown until the
"      backup is complete; however, this parameter must be specified to
"      provide enough information to generate a list of VSN's for labelled
"      tapes. The value specified should be larger than the actual amount
"      required. The backup will stop after all the data has been backed up
"      and use only the number of tapes required to hold the data.
"
"    increment_scheme, is: This parameter determines the format for the
"      rightmost characters of the VSN's generated by this procedure.
"      Decimal mode is the default. Alphabetic mode is for situations
"      where a decimal increment scheme does not allow enough tapes.
"
"    vsn_list, vsnl: A list of magnetic tape external VSNs generated by
"      a calling procedure such as SELECT_OPERATOR_MENU.  This parameter
"      value overrides the vsn_prefix, vsn_count, and increment_scheme VSN
"      generation parameters.
"
"    file_label_type, flt: This parameter specifies the type of label
"      on the backup tapes you are using. If this parameter is not specified,
"      then LABELED is used.
"
"    type, t: This parameter specifies the density of the backup tapes
"      you are using.
"
"    backup_file: This parameter is used to create a permanent backup
"      file, which can be either a permanent mass storage file or a permanent
"      tape file.  If this parameter is specified, the following parameters
"      will be ignored.
"
"          file_label_type
"          increment_scheme
"          type
"          vsn_count
"          vsn_list
"          vsn_prefix
"
"    backup_catalogs, bc: This parameter specifies if the catalog information
"      should be included in the backup. The default for this parameter is TRUE.
"
"    backup_system_family, bsf: This parameter specifies if the $system
"      family should be included in the backup. The defualt for this parameter
"      is TRUE.
"
"    date, d: Files modified after the date specified will be included
"       in the partial backup.
"
"    output_disposition, odi: This parameter specifies the destination of the
"      output generated.  The default for this parameter is 'PRINTER'
"
" VSN Generation Examples:
"   vsn_prefix=part vsn_count=12 increment_scheme=decimal ==>part01-part12
"   vsn_prefix=part vsn_count=12 increment_scheme=alphabetic ==>partaa-partal
"
"   vsn_prefix=A1 vsn_count=27 increment_scheme=decimal ==>A10001-A10027
"   vsn_prefix=A1 vsn_count=27 increment_scheme=alphabetic ==>A1AAAA-A1AABA

  VAR
    backup_file_created: boolean = FALSE
    job_file: file = $unique(:$local)
    modification_date: string
    volume_list: list 1 .. $max_list of string 6
  VAREND

  IF $specified(backup_file) THEN
    IF $string($file_attributes(backup_file, lifetime)) <> 'UNLIMITED'  THEN
      EXIT procedure WITH $status(false, 'PU', 3330, 'The file specified '//..
'by the BACKUP_FILE parameter must be a permanent mass storage file or a permanent tape file.')
    ELSE
      IF NOT $string($file_attributes(backup_file, registered))='YES' THEN
        create_file f=backup_file
        detach_file f=backup_file
        backup_file_created = TRUE
      IFEND
    IFEND
  ELSE
    IF $specified(vsn_list) THEN
      delete_variable volume_list
      volume_list = $apply(vsn_list, $string(x))
    ELSE
      pup$construct_volume_list vsn_count=vsn_count vsn_prefix=vsn_prefix increment_scheme=increment_scheme ..
            volume_list=volume_list
    IFEND
  IFEND

  IF $specified(backup_file) THEN
    attach_or_request_command = 'attach_file am=write local_file_name=backup_file file= '//$string(backup_file)
  ELSE
    attach_or_request_command = 'request_magnetic_tape file=$local.backup_file ring=yes type='//$string(type)// ..
          ' external_vsn='//$string(volume_list, source)// ..
          '; set_file_attributes file=$local.backup_file file_label_type='//$string(file_label_type)
  IFEND

"Get date and time to begin partial backup.
  IF $specified(date) THEN
    modification_date = $date_time_string('ISOD.HMS' date)
  ELSE
    attach_file file=$user.date_of_full_backup open_position=$asis
    VAR
      full_backup_date: string
      full_backup_time: string
      converted_date: string
    VAREND
    accept_line variable=full_backup_date input=$user.date_of_full_backup
    accept_line variable=full_backup_time input=$user.date_of_full_backup

    converted_date = $date_time_string('ISOD' $date_time(full_backup_date 'MDY'))
    modification_date = converted_date // '.' // full_backup_time
  IFEND

"Create a file containing a batch job to do the actual backup.
COLLECT_TEXT output=job_file sm='?' until='**END_COLLECT**'
  JOB job_name=partialback job_class=system magnetic_tape_limit=unlimited output_disposition=?output_disposition?
    ?attach_or_request_command?

    WHEN any_fault DO
     IF ?backup_file_created? THEN
       change_file_attributes file=$local.backup_file ring_attributes=(11,11,11)
     IFEND
     detach_file file=$local.backup_file
     display_value osv$status
     send_operator_message ' CREATE_PARTIAL_BACKUP aborting -check listing '
    WHENEND

    SYSTEM_OPERATOR_UTILITY CAPABILITIES=(SYSTEM_ADMINISTRATION SYSTEM_DISPLAYS)

    VAR
      empty_list: list 0 .. 0 of string
      exclude_status: status
      family_list: list of name = ()
      rml_is_active: boolean
      rms_status: status
    VAREND

    LOGICAL_CONFIGURATION_UTILITY
      FOR each set in $active_sets() DO
        family_list = $join($active_set_families(set), family_list)
      FOREND
    QUIT

    rml_is_active = FALSE
    IF $file($system.rms.rsf$command_library, permanent) THEN
      PUSH command_list
      create_command_list_entry $system.rms.rsf$command_library status=rms_status
      IF $library(active)<>empty_list THEN
        rml_is_active = TRUE
        rml_catalog = $path($array($library(active))(1), catalog)
        rml = $array($library(active))(1)
        IF $string($file_attributes(rml, log_residence)) <> 'NONE' THEN
          exclude_recovery_logs_cmd = 'exclude_catalog catalog = '//..
                $string($file_attributes(rml, log_residence))
          backup_recovery_logs_cmd = 'backup_catalog catalog = '//..
                $string($file_attributes(rml, log_residence))
        ELSE
          exclude_recovery_logs_cmd = '"No recovery logs configured."'
          backup_recovery_logs_cmd = '"No recovery logs configured."'
        IFEND
      IFEND
      POP command_list
    IFEND;

    TASK ring=3
      backup_permanent_files backup_file=$local.backup_file
        set_backup_options include_archive_information=TRUE
        set_backup_options exclude_catalog_information=?$NOT(backup_catalogs)?
        IF "include $system catalog =" ?backup_system_family? THEN
          "$system family included in backup.
        ELSE
          exclude_catalog catalog=:$system status=exclude_status
        IFEND

        FOR EACH family_name IN family_list DO
          exclude_catalog catalog=$fname(':'//$string(family_name)//'.$SYSTEM.$JOB_INPUT_QUEUE')..
                status=exclude_status
        FOREND

        exclude_catalog catalog=$system.$df$client_mainframes status=exclude_status
        exclude_catalog catalog=$system.aam.shared_recovery_log status=exclude_status

        include_cycles selection_criteria=modified after=?modification_date?

        IF rml_is_active THEN
          exclude_catalog catalog=$fname(rml_catalog)
          include_line exclude_recovery_logs_cmd
        IFEND

        backup_all_files

        IF exclude_status.normal THEN
          backup_catalog catalog=$system.aam.shared_recovery_log
        IFEND

        IF rml_is_active THEN
          close_volume
          include_cycles selection_criteria=ignore_date_time
          backup_catalog catalog=$fname(rml_catalog)
          include_line backup_recovery_logs_cmd
        IFEND;

      QUIT
      IF ?backup_file_created? THEN
        change_file_attributes file=$local.backup_file ring_attributes=(11,11,11)
      IFEND
      detach_file file=$local.backup_file
    TASKEND
    QUIT

    include_file file=$system.hardware_maintenance.hpa.hpf$start_monitor_job
  JOBEND
**END_COLLECT**

  include_file file=job_file
  detach_file file=job_file
  detach_file file=$user.date_of_full_backup

PROCEND create_partial_backup
*DECK DECK=PUP$DELETE_EXPIRED_FILES EXPAND=TRUE

PROCEDURE delete_expired_files, delef (
  output_disposition, odi: any of
      key
        (discard_all_output, dao),(discard_standard_output, dso),
        (printer, p),(wait_queue, wt, wq)
      keyend
      file
    anyend = puv$delete_expired_files, printer
  status)

  "The purpose of this procedure is to initiate a batch job
  "to delete all the currently expired files.

  JOB job_name=delete_expired_files job_class=system output_disposition=output_disposition
    SYSTEM_OPERATOR_UTILITY capability=system_administration
      TASK RING=3
        BACKUP_PERMANENT_FILES backup_file=$null list=$output
          set_list_options cycle_display_options=(size, modification_date_time, expiration_date)
          sort_users
          include_cycles selection_criteria=expired before=$now
          delete_all_files
        QUIT
      TASKEND
    END_SYSTEM_OPERATOR_UTILITY
  JOBEND

PROCEND delete_expired_files
*DECK DECK=PUP$DETERMINE_IF_ALL_SELECTED EXPAND=FALSE
  PROCEDURE [XREF]  pup$determine_if_all_selected (name_list: array [1 .. * ] OF ost$name;
        parameter_name: string ( * );
    VAR all_selected: boolean;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*COPYC OST$NAME
*COPYC OST$STATUS
?? POP ??
*DECK DECK=PUP$DETERMINE_IF_ITEM_EXISTS EXPAND=FALSE

  PROCEDURE [XREF] pup$determine_if_item_exists ALIAS 'puxdiie' (path:
    pft$path;
        item_to_determine: integer;
        cycle_level_selected: boolean;
        cycle_selector: pft$cycle_selector;
    VAR item_exists: boolean;
    VAR item_type: put$entry_type;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$DETERMINE_IF_NONE_SELECTED EXPAND=FALSE
  PROCEDURE [XREF]  pup$determine_if_none_selected (name_list: array [1 .. * ] OF ost$name;
        parameter_name: string ( * );
    VAR none_selected: boolean;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*COPYC OST$NAME
*COPYC OST$STATUS
?? POP ??
*DECK DECK=PUP$DETERMINE_IF_SET_EXISTS EXPAND=FALSE

  PROCEDURE [XREF] pup$determine_if_set_exists ALIAS 'puxdise' (set_name:
    stt$set_name;
    VAR set_exists: boolean;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc STD$SET_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$DETERMINE_PATH_EXISTENCE EXPAND=FALSE

  PROCEDURE [XREF] pup$determine_path_existence ALIAS 'puxdpe' (path: pft$path;
        item_to_determine: integer;
    VAR path_exists: boolean;
    VAR path_type: put$entry_type;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc PUD$HIERARCHY_LIST
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$DETERMINE_RECORD_TYPE EXPAND=FALSE

  PROCEDURE [XREF] pup$determine_record_type ALIAS 'puxdrc' (backup_file_lfn:
    amt$local_file_name;
    VAR device_class: rmt$device_class;
    VAR record_type: amt$record_type;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc RMT$DEVICE_CLASS
*copyc AMD$FILE_ATTRIBUTES
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$DISPLAY_ALL_FILES EXPAND=TRUE
PROCEDURE display_all_files, disaf (
  recorded_vsn, rvsn: list of any of
      key
        all
      keyend
      name 1..6
    anyend = all
  output_disposition, odi: any of
      key
        (discard_all_output, dao),(discard_standard_output, dso),
        (printer, p),(wait_queue, wt, wq)
      keyend
      file
    anyend = puv$display_all_files, printer
  status)

  IF $specified(recorded_vsn) THEN
    include_volumes_command = 'include_volumes recorded_vsns=' // $string($parameter_value(recorded_vsn), source)
  ELSE
    include_volumes_command = 'include_volumes recorded_vsns=all'
  IFEND

  JOB job_name=display_all_files job_class=system substitution_mark='?' output_disposition=output_disposition
    " display all files on the specified volumes
    SYSTEM_OPERATOR_UTILITY capability=system_administration
      TASK ring=3
        BACKUP_PERMANENT_FILES backup_file=$null
          set_list_options cycle_display_options=(recorded_vsn modification_date_time access_date_time size)..
                 display_excluded_items=false
          set_backup_options exclude_catalog_information=true include_exception_conditions=none
          ?include_volumes_command?
          backup_all_files
        QUIT
      TASKEND
    QUIT
  JOBEND

PROCEND display_all_files
*DECK DECK=PUP$DISPLAY_BACKUP_OUTPUT_TOTAL EXPAND=TRUE
 PROCEDURE [XREF] pup$display_backup_output_total;
*DECK DECK=PUP$DISPLAY_BLANK_LINES EXPAND=FALSE

  PROCEDURE [XREF] pup$display_blank_lines ALIAS 'puxdbl' (number_of_lines:
    integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$DISPLAY_BOOLEAN EXPAND=FALSE
  PROCEDURE [XREF] pup$display_boolean (descriptor: string ( * <= 255);
        value: boolean;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PUP$DISPLAY_CATALOG_INFO EXPAND=FALSE
  PROCEDURE [XREF] pup$display_catalog_info
    (    catalog_name: pft$name;
         p_catalog_record: pft$p_info_record;
         output_column: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc ost$status
?? POP ??
*DECK DECK=PUP$DISPLAY_CYCLE_ARRAY_ENTRY EXPAND=FALSE
  PROCEDURE  [XREF] pup$display_cycle_array_entry
    (    cycle_entry: pft$cycle_array_entry;
         output_column: integer);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_info
?? POP ??
*DECK DECK=PUP$DISPLAY_CYCLE_INFO_DESC_V1 EXPAND=FALSE

  PROCEDURE [XREF] pup$display_cycle_info_desc_v1
    (    p_cycle_info_desc_version_1: ^pft$cycle_info_desc_version_1;
         output_column: integer);

?? PUSH (LISTEXT := ON) ??
*copyc pft$cycle_info_desc_version_1
?? POP ??

*DECK DECK=PUP$DISPLAY_CYCLE_INFO_DESC_V2 EXPAND=FALSE

  PROCEDURE [XREF] pup$display_cycle_info_desc_v2
    (    p_cycle_info_desc_version_2: ^pft$cycle_info_desc_version_2;
         p_file_media_description: ^SEQ ( * );
         output_column: integer);

?? PUSH (LISTEXT := ON) ??
*copyc pft$cycle_info_desc_version_2
*copyc pft$file_media_description
?? POP ??
*DECK DECK=PUP$DISPLAY_EXCLUDED_ITEM EXPAND=FALSE
  PROCEDURE [XREF] pup$display_excluded_item ALIAS 'puxdei' (entry: put$entry;
        catalog_header: put$catalog_header;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$DISPLAY_FILE_INFO EXPAND=FALSE
   PROCEDURE [XREF] pup$display_file_info
    (    file_name: pft$name;
         p_file_record: pft$p_info_record;
         output_column: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc ost$status
?? POP ??
*DECK DECK=PUP$DISPLAY_FILE_LABEL EXPAND=FALSE
   PROCEDURE [XREF] pup$display_file_label
    (    file_label: SEQ ( * );
         output_column: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PUP$DISPLAY_FMD EXPAND=FALSE

  PROCEDURE [XREF] pup$display_fmd
    (     device_class: rmt$device_class;
          fmd: SEQ ( * );
          output_column: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$device_class
?? POP ??
*DECK DECK=PUP$DISPLAY_INTEGER EXPAND=FALSE
  PROCEDURE [XREF] pup$display_integer (descriptor: string ( * <= 256 );
        number: integer;
     var status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$DISPLAY_ITEM_DESCRIPTOR EXPAND=FALSE

  PROCEDURE [XREF] pup$display_item_descriptor ALIAS 'puxdid'
    (descriptor_header: string ( * );
        catalog_header: put$catalog_header;
        entry: put$entry;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$DISPLAY_LINE EXPAND=FALSE

  PROCEDURE [XREF] pup$display_line ALIAS 'puxdisp' (output_string: string ( *
<= 256    );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$DISPLAY_RESTORE_TOTALS EXPAND=FALSE
 PROCEDURE [XREF] pup$display_restore_totals;
*DECK DECK=PUP$DISPLAY_SUBSET_FOUND_HEADER EXPAND=FALSE

  PROCEDURE [XREF] pup$display_subset_found_header ALIAS 'puxdsfh'
    (catalog_header: put$catalog_header;
        found_entry: put$entry;
        new_catalog_header: put$catalog_header;
        new_entry: put$entry;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PUD$HIERARCHY_LIST
?? POP ??
*DECK DECK=PUP$DISPLAY_UNRECONCILED_FILES EXPAND=TRUE
PROCEDURE display_unreconciled_files, disuf (
  catalog, c: any of
      key
        all
      keyend
      file
    anyend = $optional
  set_name, sn: name = $optional
  display_options, display_option, do: key
      all
      (missing, m)
      (unavailable, u)
    keyend = all
  output, o: file = $output
  missing_count, mc: (VAR) integer = $optional
  unavailable_count, uc: (VAR) integer = $optional
  status)

  "$FORMAT=OFF
  VAR
    backup_listing: file = $fname('$local.'//$unique)
    count: integer
    display_missing: boolean =(display_option=all) or (display_option=missing)
    display_unavailable: boolean =(display_option=all) or (display_option= ..
       unavailable)
    error_listing: file = $fname('$local.'//$unique)
    file_paths: list of file
    ignore_status: status
    lines: list 0..$max_list of string
    mc:integer = 0
    mc_text: string = $status_code_string(pfe$catalog_volume_not_online)//'--'
    mf:integer = 0
    mf_text: string = $status_code_string(pfe$volume_not_online)//'--'
    output_file_open: boolean
    output_file_path: file
    uc:integer  = 0
    uc_text: string = $status_code_string(pfe$catalog_volume_unavailable)//'--'
    uf:integer  = 0
    uf_text: string = $status_code_string(pfe$volume_unavailable)//'--'
  VAREND

  "$FORMAT=ON"

  WHEN ANY_FAULT DO
    detach_file backup_listing status=ignore_status
    detach_file error_listing status=ignore_status
  WHENEND

  $source.pup$generate_backup_listing catalog=catalog set_name=set_name ..
        backup_listing=backup_listing
  execute_task library=$system.osf$builtin_library starting_procedure=pup$extract_errors_from_listing ..
        parameters='backup_listing=backup_listing,output=error_listing'
  get_line variable=lines input=error_listing

  lines=$select(lines $size(x)>18)

  IF display_missing THEN
    mc=$size($select(lines x(11, 8)=mc_text))
    mf=$size($select(lines x(11, 9)=mf_text))
  IFEND

  IF display_unavailable THEN
    uc=$size($select(lines x(11, 8)=uc_text))
    uf=$size($select(lines x(11, 9)=uf_text))
  IFEND

  output_file_path = output
  output_file_open = FALSE

  IF (mc+mf+uc+uf)> 0 THEN
    count=$size(lines)
    i=1
    REPEAT
      IF lines(i)(3, 7) = '--ERROR' THEN
        IF (((lines(i)(11, 9)=mf_text) OR (lines(i)(11, 8)=mc_text)) AND ..
              display_missing) OR (((lines(i)(11, 9)=uf_text) OR ..
              (lines(i)(11, 8)=uc_text)) AND display_unavailable) THEN
          REPEAT
            put_line lines(i) o=output_file_path.$eoi
            IF NOT output_file_open THEN
              file_paths = $file_cycles(output_file_path, paths)
              output_file_path = file_paths(1)
              output_file_open = TRUE
            IFEND
            i=i+1
          UNTIL (i>count) OR ($scan_any(' ' lines(i)(2))<> 0)
        ELSE
          i=i+1
        IFEND
      ELSE
        i=i+1
      IFEND
    UNTIL i>count
  IFEND

COLLECT_TEXT output_file_path.$eoi

 *************************Summary******************************
**

  IF NOT output_file_open THEN
    file_paths = $file_cycles(output_file_path, paths)
    output_file_path = file_paths(1)
  IFEND

  IF display_missing THEN
COLLECT_TEXT output_file_path.$eoi sm='?'

 Number of missing catalogs: ?mc?
 Number of missing files   : ?mf?
**
  IFEND

  IF display_unavailable THEN
COLLECT_TEXT output_file_path.$eoi sm='?'

 Number of unavailable catalogs: ?uc?
 Number of unavailable files   : ?uf?
**
  IFEND

  IF $specified(unavailable_count) THEN
    unavailable_count=uc + uf
  IFEND

  IF $specified(missing_count) THEN
    missing_count=mc + mf
  IFEND

  detach_file backup_listing status=ignore_status
  detach_file error_listing status=ignore_status

PROCEND display_unreconciled_files
*DECK DECK=PUP$DISPLAY_VOLUME_SWITCH EXPAND=FALSE

  PROCEDURE [XREF] pup$display_volume_switch (backup_file_id:
    put$file_identifier);
?? PUSH (LISTEXT := ON) ??
*copyc PUT$FILE_IDENTIFIER
?? POP ??
*DECK DECK=PUP$EXCLUDED_HIGHEST_CYCLES EXPAND=FALSE
  FUNCTION [XREF] pup$excluded_highest_cycles: 0 .. pfc$maximum_cycle_number;
?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
?? POP ??

*DECK DECK=PUP$FETCH_BACKUP_INFORMATION EXPAND=FALSE
  PROCEDURE [XREF] pup$fetch_backup_information
    (    device_class: rmt$device_class;
         backup_file_phn: fst$path_handle_name;
     VAR backup_information: amt$backup_information;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc amt$backup_information
*copyc fst$path_handle_name
*copyc ost$status
*copyc rmt$device_class
?? POP ??
*DECK DECK=PUP$FETCH_BACKUP_LABEL_TYPE EXPAND=FALSE
*DECK DECK=PUP$FETCH_CURRENT_VOLUME EXPAND=FALSE
  PROCEDURE [XREF] pup$fetch_current_volume
    (    backup_file_id: put$file_identifier;
     VAR volume_number: amt$volume_number;
     VAR volume_description: rmt$volume_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amd$information
*copyc ost$status
*copyc put$file_identifier
*copyc rmt$volume_descriptor
?? POP ??
*DECK DECK=PUP$FIND_CYCLE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pup$find_cycle_entry
    (    path: pft$path;
         cycle_selector: pft$cycle_selector;
     VAR cycle_entry: pft$cycle_array_entry_version_2;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PUP$FIND_CYCLE_INFO_RECORD EXPAND=FALSE

  PROCEDURE [XREF] pup$find_cycle_info_record
   (    p_cycle_array_extended_record: pft$p_info_record;
        p_cycle_directory_array: pft$p_cycle_directory_array;
        cycle_number: pft$cycle_number;
        p_path: pft$p_path;
    VAR p_cycle_info_record: pft$p_info_record;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$complete_path
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PUP$FIND_RESTORE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] pup$find_restore_entry ALIAS 'puxfre' (entry: put$entry;
        catalog_header: put$catalog_header;
    VAR backup_file_id: put$file_identifier;
    VAR file_position: put$file_position;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
*copyc PUT$FILE_IDENTIFIER
*copyc PUT$FILE_POSITION
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$FORMAT_DATE_TIME EXPAND=FALSE

  PROCEDURE [XREF] pup$format_date_time ALIAS 'puxfodt' (date_time:
    ost$date_time;
    VAR date_time_string: string ( * ));

?? PUSH (LISTEXT := ON) ??
*copyc OST$DATE_TIME
?? POP ??
*DECK DECK=PUP$GENERATE_BACKUP_LISTING EXPAND=TRUE
PROCEDURE (HIDDEN) pup$generate_backup_listing (
  catalog, c: any of
      key
        all
      keyend
      file
    anyend = $optioanal
  set_name, sn: name = $optional
  backup_listing, bl: file = $required
  status)

"$FORMAT=OFF
VAR
  ignore_status:status
VAREND

"$FORMAT=ON

  IF $specified(catalog) AND $specified(set_name) THEN
    EXIT_PROC WITH $status(false, 'US', 3330, ..
'Either the CATALOG or the SET_NAME parameter may be specified bu..
t not both.')

  ELSEIF NOT $specified(catalog) AND NOT $specified(set_name) THEN
    EXIT_PROC WITH $status(false, 'US', 3330, ..
'Either the CATALOG or the SET_NAME  parameter must be specified.')

  ELSEIF $variable(cmv$deadstart_simulation, defined) THEN
    BACKUP_PERMANENT_FILES backup_file=$null list=backup_listing
      backup_catalog catalog=cmv$rss_working_catalog
    QUIT
    IF $variable(cmv$simulate_missing_files, defined) THEN
"$FORMAT=OFF
VAR
  missing_file_code: status_code = $status_code(pfe$volume_not_online)
  missing_cat_code: status_code =  $status_code(pfe$catalog_volume_not_online)
  unavail_file_code: status_code= $status_code(pfe$volume_unavailable)
  unavail_cat_code: status_code =  $status_code(pfe$catalog_volume_unavailable)
  short_mf: status = $status(false,'PF',missing_file_code,':nve.ajl.x')
  long_mf: status = $status(false,'PF',missing_file_code,':nve.ajl.aaaaaaaaa..
aaaaaaaaaaaaaaaaaaaaa.bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb.cccccccccccccccccccc..
ddddddddddddddddddddddddddddddddddddddddddddddd.e')
  short_uf:status = $status(false,'PF',unavail_file_code,':nve.ajl.y')
  long_uf: status = $status(false,'PF',unavail_file_code,':nve.ajl.aaaaaaaaa..
aaaaaaaaaaaaaaaaaaaaa.bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb.cccccccccccccccccccc..
ddddddddddddddddddddddddddddddddddddddddddddddd.e')
  missing_cat: status = $status(false,'PF',missing_cat_code,'vsn001')
  unavail_cat: status = $status(false,'PF',unavail_cat_code,'vsn002')
VAREND
"$FORMAT=ON
      put_line '       ' o=backup_listing.$eoi
      put_line ' xxxxxx' o=backup_listing.$eoi
      put_lines $apply($status_message(short_mf, 132, full), '  '//x) ..
            o=backup_listing.$eoi
      put_line ' yyyyyy' o=backup_listing.$eoi
      put_lines $apply($status_message(long_mf, 132, full), '  '//x) ..
            o=backup_listing.$eoi
      put_line ' zzzzzz' o=backup_listing.$eoi
      put_lines $apply($status_message(short_uf, 132, full), '  '//x) ..
            o=backup_listing.$eoi
      put_line ' aaaaaa' o=backup_listing.$eoi
      put_lines $apply($status_message(long_uf, 132, full), '  '//x) ..
            o=backup_listing.$eoi
      put_lines $apply($status_message(missing_cat, 132, full), '  '//x) ..
            o=backup_listing.$eoi
      put_lines $apply($status_message(unavail_cat, 132, full), '  '//x) ..
            o=backup_listing.$eoi
      delete_variable cmv$simulate_missing_files status=ignore_status
    IFEND
  ELSEIF $specified(catalog) THEN
    IF ($generic_type(catalog)= key) AND (catalog = all) THEN
      TASK ring=3
        BACKUP_PERMANENT_FILES backup_file=$null list=backup_listing
          backup_all_files
        QUIT
        change_file_attributes file=backup_listing ring_attributes=(11, 11, ..
              11)
      TASKEND
    ELSE
      BACKUP_PERMANENT_FILES backup_file=$null list=backup_listing
        backup_catalog catalog=catalog
      QUIT
    IFEND
  ELSEIF $specified(set_name) THEN
    TASK ring=3
      BACKUP_PERMANENT_FILES backup_file=$null list=backup_listing
        backup_set set_name=set_name
      QUIT
      change_file_attributes file=backup_listing ring_attributes=(11, 11, 11)
    TASKEND
  IFEND

PROCEND pup$generate_backup_listing

*DECK DECK=PUP$GET_BACKUP_CYCLE_INFO EXPAND=FALSE

  PROCEDURE [XREF] pup$get_backup_cycle_info
    (VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR cycle_array_entry: pft$cycle_array_entry_version_2;
     VAR p_file_media_descriptor: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc put$file_identifier
*copyc put$file_position
?? POP ??

*DECK DECK=PUP$GET_CYCLE_ARRAY EXPAND=FALSE

  PROCEDURE [XREF] pup$get_cycle_array ALIAS 'puxgcya' (
    VAR sequence_pointer: ^SEQ ( * );
    VAR p_cycle_array: pft$p_cycle_array;
    VAR p_item_record: pft$p_info_record;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$CATALOG_INFO
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$GET_CYCLE_ARRAY_VERSION_2 EXPAND=FALSE

  PROCEDURE [XREF] pup$get_cycle_array_version_2
    (VAR sequence_pointer: ^SEQ ( * );
     VAR p_cycle_array_version_2: ^pft$cycle_array_version_2;
     VAR p_item_record: pft$p_info_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
?? POP ??
*DECK DECK=PUP$GET_FILE_ATTRIBUTES EXPAND=FALSE
  PROCEDURE [XREF] pup$get_file_attributes
    (    lfn: fst$file_reference;
         cycle_array_entry: pft$cycle_array_entry_version_2;
     VAR file_length: amt$file_length;
     VAR gfn: ost$binary_unique_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_length
*copyc fst$file_reference
*copyc ost$binary_unique_name
*copyc ost$status
*copyc pfd$catalog_info
?? POP ??
*DECK DECK=PUP$GET_FILE_PASSWORD EXPAND=FALSE



  PROCEDURE [XREF] pup$get_file_password ALIAS 'puxgfpw' (file_path: pft$path;
    VAR password: pft$password);
?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
?? POP ??
*DECK DECK=PUP$GET_ITEM_DESCRIPTOR EXPAND=FALSE

  PROCEDURE [INLINE] pup$get_item_descriptor
    (VAR backup_file_id: put$file_identifier;
     VAR item_descriptor: put$backup_item_descriptor;
     VAR file_position: put$file_position;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      transfer_count: amt$file_length;

    pup$get_part (backup_file_id, ^item_descriptor, #SIZE (item_descriptor), file_position, transfer_count,
          status);
  PROCEND pup$get_item_descriptor;

*copyc pup$get_part
*copyc put$file_identifier
*copyc put$file_position
?? POP ??
*DECK DECK=PUP$GET_NEXT_HIERARCHY_LIST EXPAND=FALSE

  PROCEDURE [INLINE] pup$get_next_hierarchy_list
    (VAR backup_file_id: put$file_identifier;
     VAR hierarchy_list: put$hierarchy_list;
     VAR file_position: put$file_position;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_transfer_count: amt$file_length;

    pup$get_part (backup_file_id, ^hierarchy_list, #SIZE (hierarchy_list), file_position,
          ignore_transfer_count, status);
  PROCEND pup$get_next_hierarchy_list;

*copyc pud$hierarchy_list
*copyc pup$get_part
*copyc put$file_identifier
*copyc put$file_position
?? POP ??
*DECK DECK=PUP$GET_NEXT_RECORD_HEADER EXPAND=FALSE

  PROCEDURE [INLINE] pup$get_next_record_header
    (VAR backup_file_id: put$file_identifier;
     VAR record_header: put$backup_file_record_header;
     VAR file_position: put$file_position;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      transfer_count: amt$file_length;

    pup$get_part (backup_file_id, ^record_header, #SIZE (put$backup_file_record_header), file_position,
          transfer_count, status);
  PROCEND pup$get_next_record_header;

*copyc pud$backup_file
*copyc pup$get_part
*copyc put$file_identifier
*copyc put$file_position
?? POP ??
*DECK DECK=PUP$GET_PART EXPAND=FALSE

  PROCEDURE [XREF] pup$get_part
    (VAR backup_file_id: put$file_identifier;
         wsa: ^cell;
         working_storage_length: amt$working_storage_length;
     VAR file_position: put$file_position;
     VAR transfer_count: amt$file_length;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_length
*copyc amt$working_storage_length
*copyc ost$status
*copyc put$file_identifier
*copyc put$file_position
?? POP ??
*DECK DECK=PUP$GET_STATUS_SEVERITY EXPAND=FALSE

?? PUSH (LISTEXT := ON) ??
*copyc OSP$GET_STATUS_SEVERITY
*copyc PUE$ERROR_CONDITION_CODES
*copyc ame$open_validation_errors
*copyc ame$put_program_actions
*copyc PUT$STATUS_SEVERITY
?? POP ??

  PROCEDURE [INLINE] pup$get_status_severity (status: ost$status;
    VAR status_severity: put$status_severity);

    VAR
      ignore_status: ost$status,
      os_severity: ost$status_severity;

    IF status.normal THEN
      status_severity := puc$normal_status;
    ELSE
      CASE status.condition OF
      = ame$unrecovered_write_error , ame$no_write_ring =
        status_severity := puc$fatal_status;
      ELSE
        osp$get_status_severity (status.condition, os_severity, ignore_status);
        CASE os_severity OF
        = osc$informative_status =
          status_severity := puc$informative_status;
        = osc$warning_status =
          status_severity := puc$warning_status;
        = osc$error_status =
          status_severity := puc$error_status;
        = osc$fatal_status =
          status_severity := puc$fatal_status;
        ELSE
          status_severity := puc$catastrophic_status;
        CASEND;
      CASEND;
    IFEND;
  PROCEND pup$get_status_severity;
*DECK DECK=PUP$GET_SUMMARY_STATUS EXPAND=FALSE
 PROCEDURE [XREF] pup$get_summary_status (VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=PUP$INITIALIZE_BACKUP_LISTING EXPAND=FALSE

  PROCEDURE [XREF] pup$initialize_backup_listing (pf_utility_hierarchy_list:
    put$hierarchy_list;
   file_id: put$file_identifier;
    backup_information: amt$backup_information;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
*copyc put$file_identifier
*copyc OST$STATUS
*copyc amt$backup_information
?? POP ??
*DECK DECK=PUP$INITIALIZE_RESTORE_LISTING EXPAND=FALSE

  PROCEDURE [XREF] pup$initialize_restore_listing ALIAS 'puxinrl' (descriptor:
    string ( * );
        old_catalog_header: put$catalog_header;
        old_entry: put$entry;
        new_catalog_path: pft$path;
        new_cycle_selector: pft$cycle_selector;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$INITIALIZE_RESTORE_TOTALS EXPAND=FALSE
 PROCEDURE [XREF] pup$initialize_restore_totals;
*DECK DECK=PUP$INITIALIZE_SUMMARY_STATUS EXPAND=FALSE
  PROCEDURE [XREF] pup$initialize_summary_status;
*DECK DECK=PUP$LABEL_TAPE_VOLUMES EXPAND=TRUE
PROCEDURE label_tape_volumes, label_tape_volume, labtv (
  element_name, en: name = $optional
  vsn_prefix, vsnp: any of
      name 1..5
      string 1..5
      integer 1..99998
    anyend = $optional
  vsn_count, vsnc: integer 1..11881376 = $required
  character_set, cs: (by_name) key
      (ascii, a)
      (ebcdic, e)
    keyend = ascii
  file_accessibility_code, fac: (by_name, secure) string 1 = $optional
  increment_scheme, is: (by_name) key
      (alphabetic, a)
      (decimal, d)
    keyend = decimal
  label_standard_version, lsv: (by_name) string 1 = '4'
  owner_identifier, oi: (by_name, secure) string 1..14 = $optional
  type, t: (by_name) key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = osd$initv_type, mt9$1600
  volume_accessibility_code, vac: (by_name, secure) string 1 = $optional
  status)

"  The purpose of this procedure is to label a set
"  of tapes. The list of VSN's for the tapes are generated by
"  pup$construct_volume_list.  The values of the VSNs depends on the values for
"  vsn_prefix, vsn_count and increment_scheme.
"
"  This process uses the initialize_tape_volume subcommand of the
"  system_operator_utility to label the backup tapes. There will
"  not be a normal tape request when doing this. A message will appear
"  in the operator action window, please ready (element_name). When a
"  tape is mounted and the drive is ready the menu for labeling tapes
"  will describe the label operation about to be executed and ask for
"  confirmation. This process will repeat until all tapes have been
"  labelled.
"
"  PARAMETERS:
"    element_name, en: Specify the element name of the tape drive on which
"       you are going to label the backup tapes.  The element name must be
"       omitted for volumes that are robotically mounted since the system
"       will select the element name but must be specified for volumes that
"       are manually mounted.
"
"    vsn_prefix, vsnp: Specify a one to five character name, string or integer
"      that will become the leftmost characters in the list of VSN's generated
"      by the procedure.
"
"    vsn_count, vsnc: The number of backup tapes in the set.
"
"    character_set, cs: This parameter determines the character
"      set (ASCII or EBCDIC) used in recording the labels on tape.
"
"    file_accessibility_code, fac: This parameter specifies the file
"      accessibility code that is written into the accessibility code
"      field of the HDR1 label.
"
"    increment_scheme, is: This parameter determines the format for the
"      rightmost characters of the VSN's generated by this procedure.
"      Decimal mode is the default. Alphabetic mode is for situations
"      where a decimal increment scheme does not allow enough tapes.
"
"    label_standard_version, lsv: This parameter specifies the version
"      number of the ANSI standard to record on the tape volume label.
"
"    owner_identifier, oi: This parameter specifies the name of the tape
"      owner.
"
"    type, t: This parameter specifies the density of the backup tapes
"      you are using.
"
"    volume_accessibility_code, vac: This parameter specifies the volume
"      accessibility code that is written into the accessibility code field
"      of the VOL1 label.
"
" VSN Generation Examples:
"   vsn_prefix=part vsn_count=12 increment_scheme=decimal    ==>part01-part12
"   vsn_prefix=part vsn_count=12 increment_scheme=alphabetic ==>partaa-partal
"
"   vsn_prefix=A1 vsn_count=27 increment_scheme=decimal    ==>A10001-A10027
"   vsn_prefix=A1 vsn_count=27 increment_scheme=alphabetic ==>A1AAAA-A1AABA

"$FORMAT=OFF
VAR
  label_tape_volume_status: status
  vsn_list: list 1 .. $max_list of string 6
VAREND
"$FORMAT=ON

  pup$construct_volume_list vsn_count=vsn_count vsn_prefix=vsn_prefix increment_scheme=increment_scheme ..
        volume_list=vsn_list

  FOR i = 1 TO vsn_count DO
    IF $specified(element_name) THEN
      initialize_tape_volume element_name=element_name recorded_vsn=vsn_list(i) type=type ..
            owner_identifier=owner_identifier volume_accessibility_code=volume_accessibility_code ..
            file_accessibility_code=file_accessibility_code character_set=character_set ..
            label_standard_version=label_standard_version status=label_tape_volume_status
    ELSE
      initialize_tape_volume recorded_vsn=vsn_list(i) type=type ..
            owner_identifier=owner_identifier volume_accessibility_code=volume_accessibility_code ..
            file_accessibility_code=file_accessibility_code character_set=character_set ..
            label_standard_version=label_standard_version status=label_tape_volume_status
    IFEND
    IF NOT label_tape_volume_status.normal THEN
      put_line ' ** WARNING ** LABEL_TAPE_VOLUMES encountered the following abnormal status.' o=$output
      display_value label_tape_volume_status
      EXIT_PROC
    IFEND
  FOREND

PROCEND label_tape_volumes
*DECK DECK=PUP$LOCATE_VALID_VERSION EXPAND=FALSE

  PROCEDURE [XREF] pup$locate_valid_version (VAR
    backup_file_id: put$file_identifier;
    VAR stored_backup_file_version: put$backup_file_version_name;
    VAR file_position: put$file_position;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUT$FILE_IDENTIFIER
*copyc PUT$FILE_POSITION
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$OPEN_BACKUP_FILE EXPAND=FALSE

  PROCEDURE [XREF] pup$open_backup_file (backup_file_lfn: amt$local_file_name;
        operation: put$operation;
        open_position: amt$open_position;
    VAR file_id: put$file_identifier;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc AMT$OPEN_POSITION
*copyc PUT$FILE_IDENTIFIER
*copyc PUT$OPERATION
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$OPEN_DISPLAY_FILE EXPAND=FALSE

  PROCEDURE [XREF] pup$open_display_file (lfn: amt$local_file_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$OPEN_FILE_FOR_SEG_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] pup$open_file_for_seg_access
    (    lfn: amt$local_file_name;
     VAR segment_pointer: mmt$segment_pointer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc mmt$attribute_keyword
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$OUTPUT_CATALOG EXPAND=FALSE

  PROCEDURE [XREF] pup$output_catalog (catalog_entry: put$entry;
        pf_utility_catalog_header: put$catalog_header;
        catalog_info: put$backup_item_info;
        pf_utility_hierarchy_list: put$hierarchy_list;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
*copyc PUD$BACKUP_FILE
*copyc PUT$FILE_IDENTIFIER
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$OUTPUT_CYCLE EXPAND=FALSE

  PROCEDURE [XREF] pup$output_cycle (lfn: amt$local_file_name;
        cycle_entry: put$entry;
        pf_utility_catalog_header: put$catalog_header;
        cycle_info: put$backup_item_info;
        cycle_array_entry: pft$cycle_array_entry_version_2;
        cycle_label_exists: boolean;
        cycle_label: SEQ ( * );
        pf_utility_hierarchy_list: put$hierarchy_list;
        cycle_length: amt$file_length;
        data_exists: boolean;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc pfd$catalog_info
*copyc PUD$HIERARCHY_LIST
*copyc PUD$BACKUP_FILE
*copyc PUT$FILE_IDENTIFIER
*copyc AMD$FILE_ATTRIBUTES
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$OUTPUT_DATE_OF_BACKUP EXPAND=FALSE

  PROCEDURE [XREF] pup$output_date_of_backup ALIAS 'puxodob' (hierarchy_list:
    put$hierarchy_list;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$OUTPUT_FAMILY EXPAND=FALSE

  PROCEDURE [XREF] pup$output_family (family_entry: put$entry;
        pf_utility_catalog_header: put$catalog_header;
        info: put$backup_item_info;
        pf_utility_hierarchy_list: put$hierarchy_list;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
*copyc PUD$BACKUP_FILE
*copyc PUT$FILE_IDENTIFIER
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$OUTPUT_FILE EXPAND=FALSE

  PROCEDURE [XREF] pup$output_file (pf_entry: put$entry;
        pf_utility_catalog_header: put$catalog_header;
        info: put$backup_item_info;
        pf_utility_hierarchy_list: put$hierarchy_list;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
*copyc PUD$BACKUP_FILE
*copyc PUT$FILE_IDENTIFIER
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$OUTPUT_SET EXPAND=FALSE

  PROCEDURE [XREF] pup$output_set (set_entry: put$entry;
        pf_utility_catalog_header: put$catalog_header;
        set_info: put$backup_item_info;
        pf_utility_hierarchy_list: put$hierarchy_list;
    VAR pf_backup_file_id: put$file_identifier;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
*copyc PUD$BACKUP_FILE
*copyc PUT$FILE_IDENTIFIER
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$PHYSICAL_PATH_LENGTH EXPAND=FALSE

  FUNCTION [INLINE] pup$physical_path_length (logical_path_length: integer): integer;
?? PUSH (LISTEXT := ON) ??
    IF logical_path_length <= 0 THEN
      pup$physical_path_length := 1;
    ELSE
      pup$physical_path_length := logical_path_length;
    IFEND;
  FUNCEND pup$physical_path_length;
?? POP ??
*DECK DECK=PUP$PUT_NEXT EXPAND=FALSE

  PROCEDURE [XREF] pup$put_next ALIAS 'puxputn' (VAR file_id:
    put$file_identifier;
        wsa: ^cell;
        wsl: amt$working_storage_length;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUT$FILE_IDENTIFIER
*copyc OST$STATUS
*copyc AMT$WORKING_STORAGE_LENGTH
?? POP ??
*DECK DECK=PUP$PUT_PARTIAL EXPAND=FALSE

  PROCEDURE [XREF] pup$put_partial ALIAS 'puxputp' (VAR file_id:
    put$file_identifier;
        wsa: ^cell;
        wsl: amt$working_storage_length;
        term_option: amt$term_option;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUT$FILE_IDENTIFIER
*copyc AMT$WORKING_STORAGE_LENGTH
*copyc OST$STATUS
*copyc AMT$TERM_OPTION
?? POP ??
*DECK DECK=PUP$RESTORE_ALL_CYCLE_CONTENTS EXPAND=FALSE

  PROCEDURE [XREF] pup$restore_all_cycle_contents ALIAS 'puxracc'
    (requested_entry: put$entry;
        catalog_header: put$catalog_header;
        new_entry: put$entry;
        new_catalog_header: put$catalog_header;
        restore_selections: put$restore_data_selections;
    VAR backup_file_id: put$file_identifier;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
*copyc PUT$FILE_IDENTIFIER
*copyc put$restore_data_selections
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$RESTORE_CATALOGED_FILES EXPAND=TRUE
PROCEDURE restore_cataloged_files, rescf, restore, res (
  restore_catalogs, rc: boolean = $required
  vsn_prefix, vsnp, vp: any of
      name 1..5
      string 1..5
      integer 1..99999
    anyend = $optional
  vsn_count, vsnc, vc: integer 1..11881376 = 9
  vsn_suffix, vsns, vs: any of
      name 1..5
      string 1..5
      integer 1..99999
    anyend = $optional
  increment_scheme, is: key
      (alphabetic, a)
      (decimal, d)
    keyend = decimal
  vsn_list, vsnl: list of any of
      name 1..6
      string 1..6
    anyend = $optional
  file_label_type, flt: key
      (labeled, labelled, l)
      (unlabeled, unlabelled, u)
    keyend = labeled
  type, t: key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = mt9$6250
  backup_file, bf: file = $optional
  execution_mode, em: key
      (batch_job, bj)
      (asynchronous_task, at)
      (synchronous_task, st)
    keyend = batch_job
  output, o: file = $list
  status)


"  The purpose of this procedure is to restore files from a set
"  of backup tapes or from a permanent backup file.
"  The list of VSN's for the backup tapes are generated by the procedure
"  depending on the values for vsn_prefix, vsn_count, vsn_suffix and
"  increment_scheme.
"
"  PARAMETERS:
"    restore_catalogs, rc: This parameter specifies whether the catalog
"      information on this set of backup tapes should be restored.
"      When specified as false, only the cycle information is restored.
"      If restoring from several sets of backup tapes the initial restore
"      should restore the most recent catalog information available and
"      all successive restores should restore the cycle data only.
"
"    vsn_prefix, vsnp: Specify a one to five character name, string or integer
"      that will become the leftmost characters in the list of VSN's generated
"      by the procedure.
"
"    vsn_count, vsnc: The number of backup tapes in the set. This parameter
"      determines how many VSN's will be in the list generated by the
"      procedure.
"
"    vsn_suffix, vsns: This parameter specifies the rightmost characters of
"      the first vsn in the set you wish to restore. A name or string value
"      should be supplied for an alphabetic increment scheme and an integer
"      for a decimal increment scheme. This parameter should only be used when
"      problems are encountered during a restore that make it necessary to
"      restart the restore at a point other than the first reel.
"
"    increment_scheme, is: This parameter determines the format for the
"      rightmost characters of the VSN's generated by this procedure.
"      Decimal mode is the default. Alphabetic mode is for situations
"      where a decimal increment scheme does not allow enough tapes.
"
"    vsn_list, vsnl: A list of magnetic tape external VSNs generated by
"      an calling procedure such as SELECT_OPERATOR_MENU.  This parameter
"      value overrides the vsn_prefix, vsn_count, and increment_scheme VSN
"      generation parameters.
"
"    file_label_type, flt: This parameter specifies the type of label
"      on the backup tapes you are using. If this parameter is not specified,
"      then LABELED is used.
"
"    type, t: This parameter specifies the density of the backup tapes
"      you are using.
"
"    backup_file: This parameter is used to restore from a permanent backup
"      file, which can be either a permanent mass storage file or a permanent
"      tape file.  If this parameter is specified, the following parameters
"      will be ignored.
"
"          file_label_type
"          increment_scheme
"          type
"          vsn_count
"          vsn_list
"          vsn_prefix
"          vsn_suffix
"
" Note: If the execution mode is asynchronous_task or synchronous_task and
"       the backup file is attached prior to calling this procedure, the
"       backup file must be attached with a LOCAL_FILE_NAME of BACKUP_FILE.
"
"    execution_mode, em: This parameter specifies the mode of execution for
"      the task restoring the data.  When a file or catalog required for job
"      initiation is missing a batch job cannot be used to restore the data.
"      The default is to execute as a batch job.
"
"    output, o: This parameter specifies the file to which the output from
"      the restore session will be written.  When an EXECUTION_MODE of
"      asynchronous_task or synchronous_task is selected the output
"      parameter must be specified. The default is $LIST.
"
" VSN Generation Examples:
"   vsn_prefix=part vsn_count=12 increment_scheme=decimal ==>part01-part12
"   vsn_prefix=part vsn_count=12 increment_scheme=alphabetic ==>partaa-partal
"
"   vsn_prefix=A1 vsn_count=27 increment_scheme=decimal ==>A10001-A10027
"   vsn_prefix=A1 vsn_count=27 increment_scheme=alphabetic ==>A1AAAA-A1AABA
"
"   vsn_prefix=full vsn_count=4 vsn_suffix=7 is=decimal ==> FULL07-FULL10
"   vsn_prefix=full vsn_count=4 vsn_suffix=E is=alphabetic ==> FULLAE-FULLAH
"
" Restore Examples:
" Note:- In the examples below, the backup is refered to as a set of backup
" tapes from a full or partial backup, but the backup can also be on a
" permanent mass storage file or a permanent tape file.
"
" 1. There is only one set of backup tapes (from the last full backup).
"    restore restore_catalogs=true vsn_prefix=full vsn_count=17
"
" 2. There is a set of partial backup tapes (from partial_backup)
"    and a set of full backup tapes (from full_backup).
"
"    restore restore_catalogs=true vsn_prefix=part vsn_count=5
"      After the all partial tapes have been requested and
"      the job, restore, completes do:
"    restore restore_catalogs=false vsn_prefix=full vsn_count=17
"      The operator should assign_device all tapes specified.
"
"    If a site arranges their backups such that they do a partial
"    backup of files modified for each day, they must do a restore
"    for each set of partials (starting with the most recently generated
"    and working backwards through each partial set) and finally restore
"    for the set of full backups.
"
"    restore restore_catalogs=true vsn_prefix=part vsn_count=5
"
"    Wait for the initial restore job to complete and
"    for each set partial backup tapes remaining do:
"    restore restore_catalogs=false vsn_prefix=part vsn_count=5
"
"    When the final partial restore has completed start
"    a restore job for the full backup tapes.
"    restore restore_catalogs=false vsn_prefix=full vsn_count=17
"
" 3. If there are both a set of partial tapes and full tapes, and
"    for some reason an error occurs attempting to restore the fourth
"    tape in the set of partials, you can restart in the middle
"    of a set using the vsn_suffix parameter.
"
"      This job aborts on forth tape.
"      restore restore_catalogs=on vsn_prefix=part vsn_count=6
"
"      This command will start a restore job for tapes part05 & part06.
"      restore restore_catalogs=on vsn_prefix=part vsn_count=2 vsn_suffix=5
"
"      Then after all partial tapes are read restore the full backup.
"      restore restore_catalogs=off vsn_prefix=full vsn_count=17
"
" 4. If, for some reason, the set of partial tapes is completely
"     unreadable you must skip that days partials and begin the
"     restore with the previous days backup.
"
"     restore restore_catalogs=on vsn_prefix=part vsn_count=5
"     restore restore_catalogs=off vsn_prefix=full vsn_count=17
"
"    If, for some reason, the set of full backup tapes is lost or
"    is completely unreadable the following operations must be performed.
"     a) Restore the current weeks partials, most recent first.
"     b) Restore the previous weeks partials, most recent first.
"     c) restore the previous weeks full backups.
"
"    restore rc=on vsn_prefix=pafr vsn_count=4  - Most recent partial
"    restore rc=off vsn_prefix=path vsn_count=5  - Remainder of current
"                           .                      weeks partials
"                           .
"    restore rc=off vsn_prefix=pbfr vsn_count=6  - Previous week partials
"                           .
"                           .
"    restore rc=off vsn_prefix=fbsu vsn_count=20  - Previous weeks full backup

  VAR
    backup_file_already_attached: boolean = FALSE
    job_file: file = $unique(:$local)
    volume_list: list 1 .. $max_list of string 6
  VAREND

  IF $specified(backup_file) THEN
    IF $string($file_attributes(backup_file, lifetime)) <> 'UNLIMITED'  THEN
      EXIT procedure WITH $status(false, 'PU', 3330, 'The file specified '//..
'by the BACKUP_FILE parameter must be a permanent mass storage file or a permanent tape file.')
    ELSE
      IF NOT $string($file_attributes(backup_file, registered))='YES' THEN
        EXIT procedure WITH $status(false, 'PU', 3330, 'The file specified '//..
'by the BACKUP_FILE parameter must be an existing permanent mass storage file or a permanent tape file.')
      IFEND
    IFEND
  ELSE
    IF $specified(vsn_list) THEN
      delete_variable volume_list
      volume_list = $apply(vsn_list, $string(x))
    ELSE
      pup$construct_volume_list vsn_count=vsn_count vsn_prefix=vsn_prefix increment_scheme=increment_scheme ..
            vsn_suffix=vsn_suffix volume_list=volume_list
    IFEND
  IFEND

  IF $string(execution_mode)(1) = 'B' THEN
    execution_mode_command = 'JOB job_name=restore job_class=system magnetic_tape_limit=unlimited'
    terminate_execution_command = 'JOBEND'
  ELSEIF $string(execution_mode)(1) = 'S' THEN
    execution_mode_command = ''
    terminate_execution_command = ''
  ELSE
    execution_mode_command = 'TASK task_name=restore'
    terminate_execution_command = 'TASKEND'
  IFEND

  IF ($string(execution_mode)(1) <> 'B') AND NOT $specified(output) THEN
    EXIT procedure WITH $status(false, 'PU', 0, ..
'The OUTPUT parameter must be specified when an EXECUTION_MODE other than BATCH_JOB is selected.')
  IFEND

  IF $specified(backup_file) THEN
    IF $string($file_attributes(backup_file, attached)) = 'YES' AND ..
         $string(execution_mode)(1) <> 'B' THEN
      IF NOT $nil($select_string($string($file_attributes(backup_file, potential_job_access)),'READ')) THEN
        IF NOT $string($file_attributes($local.backup_file, registered))='YES' THEN
          EXIT procedure WITH $status(false, 'PU', 3330, 'If the file specified '//..
'by the BACKUP_FILE parameter is already attached, the LOCAL_FILE_NAME must be BACKUP_FILE.')
        IFEND
        attach_or_request_command = ''
        backup_file_already_attached = TRUE
      ELSE
        attach_or_request_command = 'attach_file am=read local_file_name=backup_file file= '//$string(backup_file)
      IFEND
    ELSE
      attach_or_request_command = 'attach_file am=read local_file_name=backup_file file= '//$string(backup_file)
    IFEND
  ELSE
    attach_or_request_command = 'request_magnetic_tape file=$local.backup_file ring=no type='//$string(type)// ..
          ' external_vsn='//$string(volume_list, source)// ..
          '; set_file_attributes file=$local.backup_file file_label_type='//$string(file_label_type)
  IFEND

"Create a file containing a batch job to do the actual restore.
COLLECT_TEXT output=job_file sm='?' until='**END_COLLECT**'
  ?execution_mode_command?
    IF NOT $variable(ignore_status, local) THEN
      VAR
        ignore_status: status
      VAREND
    IFEND
    create_command_list_entry entry=$system.osf$builtin_library status=ignore_status
    create_command_list_entry entry=$system.osf$sou_library status=ignore_status
    ?attach_or_request_command?

    WHEN any_fault DO
     IF NOT ?backup_file_already_attached? THEN
       detach_file file=$local.backup_file
     IFEND
     display_value osv$status
     send_operator_message ' RESTORE_CATALOGED_FILES aborted -check listing '
    WHENEND

    SYSTEM_OPERATOR_UTILITY CAPABILITY=SYSTEM_ADMINISTRATION
    TASK ring=3
      restore_permanent_files list=?output?
        set_restore_options update_cycle_statistics=FALSE restore_archive_information=TRUE
        IF "restore_catalogs =" ?restore_catalogs? THEN
          restore_all_files backup_file=$local.backup_file
        ELSE
          restore_excluded_file_cycles backup_file=$local.backup_file
        IFEND
      QUIT
      change_file_attributes file=?output? ring_attributes=(11 11 11) status=ignore_status
    TASKEND
    IF NOT ?backup_file_already_attached? THEN
      detach_file file=$local.backup_file
    IFEND
    QUIT
  ?terminate_execution_command?
**END_COLLECT**

  include_file file=job_file
  detach_file file=job_file

PROCEND restore_cataloged_files
*DECK DECK=PUP$RESTORE_CATALOG_INFO EXPAND=FALSE
  PROCEDURE [XREF] pup$restore_catalog_info (new_online_cat_head: put$catalog_header;
    VAR backup_file: put$file_identifier;
    VAR file_position: put$file_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pud$hierarchy_list
*copyc put$file_identifier
*copyc put$file_position
*copyc ost$status
?? POP ??
*DECK DECK=PUP$RESTORE_CYCLE_CONTENT EXPAND=FALSE

  PROCEDURE [XREF] pup$restore_cycle_content (
        new_file_name_path: pft$path;
        new_file_name_cycle_selector: pft$cycle_selector;
        password_selector: pft$password_selector;
        record_header: put$backup_file_record_header;
        label_exists: boolean;
        p_label: ^SEQ ( * );
        p_fmd: ^SEQ ( * );
        restore_selections: put$restore_data_selections;
    VAR mandated_modification_time: pft$mandated_modification_time;
    VAR backup_file_id: put$file_identifier;
    VAR file_position: put$file_position;
    VAR cycle_length: amt$file_length;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
*copyc ost$name
*copyc ost$status
*copyc pfd$mandated_modification_time
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*copyc pud$backup_file
*copyc put$file_identifier
*copyc put$file_position
*copyc put$restore_data_selections
?? POP ??
*DECK DECK=PUP$RESTORE_CYCLE_IF_EXCLUDED EXPAND=FALSE
  PROCEDURE [XREF] pup$restore_cycle_if_excluded
    (    requested_entry: put$entry;
         catalog_header: put$catalog_header;
         new_catalog_header: put$catalog_header;
         new_cycle_selector: pft$cycle_selector;
         found_entry: put$entry;
         found_catalog_header: put$catalog_header;
         restore_selections: put$restore_data_selections;
         p_cycle_array_extended_record: pft$p_info_record;
         p_cycle_directory_array: pft$p_cycle_directory_array;
     VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$permanent_file_definitions
*copyc pud$backup_file
*copyc pud$hierarchy_list
*copyc put$file_identifier
*copyc put$file_position
*copyc put$restore_data_selections
?? POP ??

















*DECK DECK=PUP$RESTORE_CYCLE_ITEM EXPAND=FALSE

  PROCEDURE [XREF] pup$restore_cycle_item
    (    file_entry: put$entry;
         new_file_name_path: pft$path;
         new_file_name_cycle_selector: pft$cycle_selector;
         password_selector: pft$password_selector;
         p_cycle_array_extended_record: pft$p_info_record;
         p_cycle_directory_array: pft$p_cycle_directory_array;
     VAR backup_file_id: put$file_identifier;
     VAR file_position: put$file_position;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$catalog_info
*copyc pfd$password_selector
*copyc pfd$permanent_file_definitions
*copyc pud$hierarchy_list
*copyc put$file_identifier
*copyc put$file_position
?? POP ??
*DECK DECK=PUP$RESTORE_FILE_INFO EXPAND=FALSE
  PROCEDURE [XREF] pup$restore_file_info (new_online_cat_head: put$catalog_header;
        put_cycle_list_if_file_exists: boolean;
        password_provided: boolean;
        password: pft$password;
    VAR backup_file: put$file_identifier;
    VAR file_position: put$file_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pud$hierarchy_list
*copyc put$file_identifier
*copyc put$file_position
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PUP$RESTORE_LABEL EXPAND=FALSE

  PROCEDURE [XREF] pup$restore_label (
    VAR record_header: put$backup_file_record_header;
    VAR label_exists: boolean;
    VAR p_label: { output } ^SEQ ( * );
    VAR backup_file_id: put$file_identifier;
    VAR file_position: put$file_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pud$backup_file
*copyc put$file_identifier
*copyc put$file_position
?? POP ??
*DECK DECK=PUP$RESTORE_PERMANENT_FILE EXPAND=FALSE

  PROCEDURE [XREF] pup$restore_permanent_file ALIAS 'puxrpf' (parameter_list:
    clt$parameter_list;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc CLD$PARAMETER_LIST
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$RESTORE_SELECTED_OBJECTS EXPAND=FALSE

  PROCEDURE [XREF] pup$restore_selected_objects
   (    p_selected_objects: ^put$selected_object;
    VAR backup_file_id: put$file_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc put$file_identifier
*copyc put$selected_object
*copyc ost$status
?? POP ??
*DECK DECK=PUP$RESTORE_SUB_LEVELS EXPAND=FALSE

  PROCEDURE [XREF] pup$restore_sub_levels
    (    entry: put$entry;
         catalog_header: put$catalog_header;
         password_specified: boolean;
         password: pft$password;
         new_catalog_header: put$catalog_header;
         restore_n_levels: boolean;
         p_selected_cycles: {i/o} ^array [1 .. *] of put$selected_cycle_info;
     VAR backup_file_id: put$file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc pud$hierarchy_list
*copyc put$file_identifier
*copyc put$selected_cycle_info
?? POP ??
*DECK DECK=PUP$RESTORE_UNRECONCILED_CATS EXPAND=TRUE
PROCEDURE restore_unreconciled_catalogs, resuc, restore_missing_catalogs, resmc (
  vsn_prefix, vsnp, vp: any of
      name 1..5
      string 1..5
      integer 1..99999
    anyend = $optional
  vsn_count, vsnc, vc: integer 1..11881376 = 9
  vsn_suffix, vsns, vs: any of
      name 1..5
      string 1..5
      integer 1..99999
    anyend = $optional
  increment_scheme, is: key
      (alphabetic, a)
      (decimal, d)
    keyend = decimal
  vsn_list, vsnl: list of any of
      name 1..6
      string 1..6
    anyend = $optional
  file_label_type, flt: key
      (labeled, labelled, l)
      (unlabeled, unlabelled, u)
    keyend = labeled
  type, t: key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = mt9$6250
  backup_file, bf: file = $optional
  restore_excluded_file_cycles, refc: list of key
      none
      (media_missing, mm)
      (no_data_defined, ndd)
      (volume_unavailable, vu)
    keyend = (no_data_defined media_missing volume_unavailable)
  execution_mode, em: key
      (batch_job, bj)
      (asynchronous_task, at)
      (synchronous_task, st)
    keyend = batch_job
  output, o: file = $list
  status)


"   The purpose of this procedure is to restore catalogs from a set
"   of backup tapes or from a permanent backup file in the event of the
"   loss of a catalog device.  This procedure will restore the catalogs
"   that were on the failing device (or devices) to the remaining devices
"   from the latest backup tapes or from the specified permanent backup file.
"
"   This procedure is only available from the console.
"
"   This procedure may not be used to restore catalogs on the system
"   device.
"
"   Cycles residing on catalogs so restored  will be marked with the  damage
"   condition of 'parent_catalog_restored', and 'respf_modification_mismatch' .
"   Users may use the  change_catalog_entry command to clear this
"   damage condition.
"
"   When the operator has ensured that the catalog restoration has completed
"   the operator should type from the console:
"   respf
"     set_restore_missing_catalogs operation=end
"   quit
"
"  PARAMETERS:
"    vsn_prefix, vsnp: Specify a one to five character name, string or integer
"      that will become the leftmost characters in the list of VSN's generated
"      by the procedure.
"
"    vsn_count, vsnc: The number of backup tapes in the set. This parameter
"      determines how many VSN's will be in the list generated by the
"      procedure.
"
"    vsn_suffix, vsns: This parameter specifies the rightmost characters of
"      the first vsn in the set you wish to restore. A name or string value
"      should be supplied for an alphabetic increment scheme and an integer
"      for a decimal increment scheme. This parameter should only be used when
"      problems are encountered during a restore that make it necessary to
"      restart the restore at a point other than the first reel.
"
"    increment_scheme, is: This parameter determines the format for the
"      rightmost characters of the VSN's generated by this procedure.
"      Decimal mode is the default. Alphabetic mode is for situations
"      where a decimal increment scheme does not allow enough tapes.
"
"    vsn_list, vsnl: A list of magnetic tape external VSNs generated by
"      a calling procedure such as SELECT_OPERATOR_MENU.  This parameter
"      value overrides the vsn_prefix, vsn_count, and increment_scheme VSN
"      generation parameters.
"
"    file_label_type, flt: This parameter specifies the type of label
"      on the backup tapes you are using. If this parameter is not specified,
"      then LABELED is used.
"
"    type, t: This parameter specifies the density of the backup tapes
"      you are using.
"
"    backup_file: This parameter is used to restore from a permanent backup
"      file, which can be either a permanent mass storage file or a permanent
"      tape file.  If this parameter is specified, the following parameters
"      will be ignored.
"
"          file_label_type
"          increment_scheme
"          type
"          vsn_count
"          vsn_list
"          vsn_prefix
"          vsn_suffix
"
" Note: If the execution mode is asynchronous_task or synchronous_task and
"       the backup file is attached prior to calling this procedure, the
"       backup file must be attached with a LOCAL_FILE_NAME of BACKUP_FILE.
"
"    restore_excluded_file_cycles,refc: The purpose of
"       this parameter is to direct the restore process whether to
"       restore any data found on the set of backup tapes used when
"       restoring missing catalogs.  This is useful, for example, when
"       the site's most recent catalog backup is a partial backup and
"       contains both the most recent catalog image and data.
"
"       Data will be restored under the same criteria as the
"       RESTORE_EXCLUDED_FILE_CYCLES subcommand;  namely if the
"       cycle has no data defined for it, or if the cycle data resides
"       on a media missing or volume that is unavailable.
"       INCLUDE_VOLUMES subcommand affect the operation of this parameter.
"
"       Omission will cause data to be restored if it is on the backup file,
"       and is no described in the catalog, or is in on a device that is
"       missing.
"
"    execution_mode, em: This parameter specifies the mode of execution for
"      the task restoring the data.  When a file or catalog required for job
"      initiation is missing a batch job cannot be used to restore the data.
"      The default is to execute as a batch job.
"
"    output, o: This parameter specifies the file to which the output from
"      the restore session will be written.  When an EXECUTION_MODE of
"      asynchronous_task or synchronous_task is selected the output
"      parameter must be specified. The default is $LIST.
"
" VSN Generation Examples:
"   vsn_prefix=part vsn_count=12 increment_scheme=decimal    ==>part01-part12
"   vsn_prefix=part vsn_count=12 increment_scheme=alphabetic ==>partaa-partal
"
"   vsn_prefix=A1 vsn_count=27 increment_scheme=decimal    ==>A10001-A10027
"   vsn_prefix=A1 vsn_count=27 increment_scheme=alphabetic ==>A1AAAA-A1AABA
"
"   vsn_prefix=full vsn_count=4 vsn_suffix=7 is=decimal    ==> FULL07-FULL10
"   vsn_prefix=full vsn_count=4 vsn_suffix=E is=alphabetic ==> FULLAE-FULLAH
"

  VAR
    backup_file_already_attached: boolean = FALSE
    job_file: file = $unique(:$local)
    volume_list: list 1 .. $max_list of string 6
  VAREND

  IF $specified(backup_file) THEN
    IF $string($file_attributes(backup_file, lifetime)) <> 'UNLIMITED'  THEN
      EXIT procedure WITH $status(false, 'PU', 3330, 'The file specified '//..
'by the BACKUP_FILE parameter must be a permanent mass storage file or a permanent tape file.')
    ELSE
      IF NOT $string($file_attributes(backup_file, registered))='YES' THEN
        EXIT procedure WITH $status(false, 'PU', 3330, 'The file specified '//..
'by the BACKUP_FILE parameter must be an existing permanent mass storage file or a permanent tape file.')
      IFEND
    IFEND
  ELSE
    IF $specified(vsn_list) THEN
      delete_variable volume_list
      volume_list = $apply(vsn_list, $string(x))
    ELSE
      pup$construct_volume_list vsn_count=vsn_count vsn_prefix=vsn_prefix increment_scheme=increment_scheme ..
            vsn_suffix=vsn_suffix volume_list=volume_list
    IFEND
  IFEND

  IF $string(execution_mode)(1) = 'B' THEN
    execution_mode_command = 'JOB job_name=restore_missing_catalog job_class=system magnetic_tape_limit=unlimited'
    terminate_execution_command = 'JOBEND'
  ELSEIF $string(execution_mode)(1) = 'S' THEN
    execution_mode_command = ''
    terminate_execution_command = ''
  ELSE
    execution_mode_command = 'TASK task_name=restore_missing_catalog'
    terminate_execution_command = 'TASKEND'
  IFEND

  IF ($string(execution_mode)(1) <> 'B') AND NOT $specified(output) THEN
    EXIT procedure WITH $status(false, 'PU', 0, ..
'The OUTPUT parameter must be specified when an EXECUTION_MODE other than BATCH_JOB is selected.')
  IFEND

  IF $specified(backup_file) THEN
    IF $string($file_attributes(backup_file, attached)) = 'YES' AND ..
         $string(execution_mode)(1) <> 'B' THEN
      IF NOT $nil($select_string($string($file_attributes(backup_file, potential_job_access)),'READ')) THEN
        IF NOT $string($file_attributes($local.backup_file, registered))='YES' THEN
          EXIT procedure WITH $status(false, 'PU', 3330, 'If the file specified '//..
'by the BACKUP_FILE parameter is already attached, the LOCAL_FILE_NAME must be BACKUP_FILE.')
        IFEND
        attach_or_request_command = ''
        backup_file_already_attached = TRUE
      ELSE
        attach_or_request_command = 'attach_file am=read local_file_name=backup_file file= '//$string(backup_file)
      IFEND
    ELSE
      attach_or_request_command = 'attach_file am=read local_file_name=backup_file file= '//$string(backup_file)
    IFEND
  ELSE
    attach_or_request_command = 'request_magnetic_tape file=$local.backup_file ring=no type='//$string(type)// ..
          ' external_vsn='//$string(volume_list, source)// ..
          '; set_file_attributes file=$local.backup_file file_label_type='//$string(file_label_type)
  IFEND

  RESTORE_PERMANENT_FILES
    set_restore_missing_catalogs operation=start
  QUIT

"Create a file containing a batch job to do the actual restore.
COLLECT_TEXT output=job_file sm='?' until='**END_COLLECT**'
  ?execution_mode_command?
    IF NOT $variable(ignore_status, local) THEN
      VAR
        ignore_status: status
      VAREND
    IFEND
    create_command_list_entry entry=$system.osf$builtin_library status=ignore_status
    create_command_list_entry entry=$system.osf$sou_library status=ignore_status
    ?attach_or_request_command?

    WHEN any_fault DO
     IF NOT ?backup_file_already_attached? THEN
       detach_file file=$local.backup_file
     IFEND
     display_value osv$status
     send_operator_message ' RESTORE_UNRECONCILED_CATALOGS aborting -check listing '
    WHENEND

    SYSTEM_OPERATOR_UTILITY CAPABILITY=SYSTEM_ADMINISTRATION
    TASK ring=3
      restore_permanent_files list=?output?
        set_restore_options update_cycle_statistics=FALSE restore_archive_information=TRUE
        set_restore_options require_matching_modification=FALSE
        restore_missing_catalogs backup_file=$local.backup_file ..
           restore_excluded_file_cycles=?$string($parameter_value(restore_excluded_file_cycles), source)?
        send_operator_message 'RESTORE END-IF last job do:RESPF;SET_RESTORE_MISSING_CATALOG END'
      QUIT
      change_file_attributes file=?output? ring_attributes=(11 11 11) status=ignore_status
    TASKEND
    IF NOT ?backup_file_already_attached? THEN
      detach_file file=$local.backup_file
    IFEND
    QUIT
  ?terminate_execution_command?
**END_COLLECT**

  include_file file=job_file
  detach_file file=job_file

PROCEND restore_unreconciled_catalogs
*DECK DECK=PUP$RESTORE_UNRECONCILED_FILES EXPAND=TRUE
PROCEDURE restore_unreconciled_files, resuf, restore_lost_cycles, reslc (
  vsn_prefix, vsnp, vp: any of
      name 1..5
      string 1..5
      integer 1..99999
    anyend = $optional
  vsn_count, vsnc, vc: integer 1..11881376 = 9
  vsn_suffix, vsns, vs: any of
      name 1..5
      string 1..5
      integer 1..99999
    anyend = $optional
  increment_scheme, is: key
      (alphabetic, a)
      (decimal, d)
    keyend = decimal
  vsn_list, vsnl: list of any of
      name 1..6
      string 1..6
    anyend = $optional
  file_label_type, flt: key
      (labeled, labelled, l)
      (unlabeled, unlabelled, u)
    keyend = labeled
  type, t: key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = mt9$6250
  backup_file, bf: file = $optional
  recorded_vsns, recorded_vsn, rvsn: list of any of
      key
        all
      keyend
      name 1..6
    anyend = all
  restore_options, ro: list of key
      (media_missing, mm)
      (no_data_defined, ndd)
      (volume_unavailable, vu)
    keyend = (media_missing no_data_defined volume_unavailable)
  execution_mode, em: key
      (batch_job, bj)
      (asynchronous_task, at)
      (synchronous_task, st)
    keyend = batch_job
  output, o: file = $list
  status)


"  The purpose of this procedure is to restore files from a set of
"  backup tapes or from a permanent backup file in the advent of the
"  loss of a single device.  This procedure will restore the files that
"  were on the failing device to the remaining devices from the latest
"  backup tapes or from the specified permanent backup file.
"
"  This procedure should be run first for the most recent partials and then
"  for all remaining partials in reverse order in which they were made and
"  finally for the full backup tapes (or the permanent backup file containing
"  the full backup).
"
"  Restored cycles that have been modified since the date of the
"  backup will be marked as damaged. Users may use the
"  change_catalog_entry command to clear this damage condition.
"
"  PARAMETERS:
"    vsn_prefix, vsnp: Specify a one to five character name, string or integer
"      that will become the leftmost characters in the list of VSN's generated
"      by the procedure.
"
"    vsn_count, vsnc: The number of backup tapes in the set. This parameter
"      determines how many VSN's will be in the list generated by the
"      procedure.
"
"    vsn_suffix, vsns: This parameter specifies the rightmost characters of
"      the first vsn in the set you wish to restore. A name or string value
"      should be supplied for an alphabetic increment scheme and an integer
"      for a decimal increment scheme. This parameter should only be used when
"      problems are encountered during a restore that make it necessary to
"      restart the restore at a point other than the first reel.
"
"    increment_scheme, is: This parameter determines the format for the
"      rightmost characters of the VSN's generated by this procedure.
"      Decimal mode is the default. Alphabetic mode is for situations
"      where a decimal increment scheme does not allow enough tapes.
"
"    vsn_list, vsnl: A list of magnetic tape external VSNs generated by
"      a calling procedure such as SELECT_OPERATOR_MENU.  This parameter
"      value overrides the vsn_prefix, vsn_count, and increment_scheme VSN
"      generation parameters.
"
"    file_label_type, flt: This parameter specifies the type of label
"      on the backup tapes you are using. If this parameter is not specified,
"      then LABELED is used.
"
"    type, t: This parameter specifies the density of the backup tapes
"      you are using.
"
"    backup_file: This parameter is used to restore from a permanent backup
"      file, which can be either a permanent mass storage file or a permanent
"      tape file.  If this parameter is specified, the following parameters
"      will be ignored.
"
"          file_label_type
"          increment_scheme
"          type
"          vsn_count
"          vsn_list
"          vsn_prefix
"          vsn_suffix
"
" Note: If the execution mode is asynchronous_task or synchronous_task and
"       the backup file is attached prior to calling this procedure, the
"       backup file must be attached with a LOCAL_FILE_NAME of BACKUP_FILE.
"
"    recorded_vsns, recorded_vsn, rvsn: Specify the recorded_vsn(s) of the
"      devices that failed and require their files to be restored. Omission
"      causes files to be restored for all files that reside on a downed
"      device.
"
"    restore_options, ro: Specify the types of lost cycles to restore.
"      Media_missing will restore cycles with a media_missing damage
"      condition. This condition is usually encountered when a device
"      is removed from the configuration during a deadstart.
"      No_data_defined will restore cycles whose cycle information
"      has been restored but the actual data has not been restored.
"      Volume_unavailable will restore cycles that reside on a device
"      that was downed since the last deadstart.
"
"    execution_mode, em: This parameter specifies the mode of execution for
"      the task restoring the data.  When a file or catalog required for job
"      initiation is missing a batch job cannot be used to restore the data.
"      The default is to execute as a batch job.
"
"    output, o: This parameter specifies the file to which the output from
"      the restore session will be written.  When an EXECUTION_MODE of
"      asynchronous_task or synchronous_task is selected the output
"      parameter must be specified. The default is $LIST.
"
" VSN Generation Examples:
"  vsn_prefix=part vsn_count=12 increment_scheme=decimal    ==>part01-part12
"  vsn_prefix=part vsn_count=12 increment_scheme=alphabetic ==>partaa-partal
"
"  vsn_prefix=A1 vsn_count=27 increment_scheme=decimal    ==>A10001-A10027
"  vsn_prefix=A1 vsn_count=27 increment_scheme=alphabetic ==>A1AAAA-A1AABA
"
"  vsn_prefix=full vsn_count=4 vsn_suffix=7 is=decimal    ==> FULL07-FULL10
"  vsn_prefix=full vsn_count=4 vsn_suffix=E is=alphabetic ==> FULLAE-FULLAH

  VAR
    backup_file_already_attached: boolean = FALSE
    job_file: file = $unique(:$local)
    volume_list: list 1 .. $max_list of string 6
  VAREND

  IF $specified(backup_file) THEN
    IF $string($file_attributes(backup_file, lifetime)) <> 'UNLIMITED'  THEN
      EXIT procedure WITH $status(false, 'PU', 3330, 'The file specified '//..
'by the BACKUP_FILE parameter must be a permanent mass storage file or a permanent tape file.')
    ELSE
      IF NOT $string($file_attributes(backup_file, registered))='YES' THEN
        EXIT procedure WITH $status(false, 'PU', 3330, 'The file specified '//..
'by the BACKUP_FILE parameter must be an existing permanent mass storage file or a permanent tape file.')
      IFEND
    IFEND
  ELSE
    IF $specified(vsn_list) THEN
      delete_variable volume_list
      volume_list = $apply(vsn_list, $string(x))
    ELSE
      pup$construct_volume_list vsn_count=vsn_count vsn_prefix=vsn_prefix increment_scheme=increment_scheme ..
            vsn_suffix=vsn_suffix volume_list=volume_list
    IFEND
  IFEND

  IF $string(execution_mode)(1) = 'B' THEN
    execution_mode_command = 'JOB job_name=restore_lost_cycles job_class=system magnetic_tape_limit=unlimited'
    terminate_execution_command = 'JOBEND'
  ELSEIF $string(execution_mode)(1) = 'S' THEN
    execution_mode_command = ''
    terminate_execution_command = ''
  ELSE
    execution_mode_command = 'TASK task_name=restore_lost_cycles'
    terminate_execution_command = 'TASKEND'
  IFEND

  IF ($string(execution_mode)(1) <> 'B') AND NOT $specified(output) THEN
    EXIT procedure WITH $status(false, 'PU', 0, ..
'The OUTPUT parameter must be specified when an EXECUTION_MODE other than BATCH_JOB is selected.')
  IFEND

  IF $specified(backup_file) THEN
    IF $string($file_attributes(backup_file, attached)) = 'YES' AND ..
         $string(execution_mode)(1) <> 'B' THEN
      IF NOT $nil($select_string($string($file_attributes(backup_file, potential_job_access)),'READ')) THEN
        IF NOT $string($file_attributes($local.backup_file, registered))='YES' THEN
          EXIT procedure WITH $status(false, 'PU', 3330, 'If the file specified '//..
'by the BACKUP_FILE parameter is already attached, the LOCAL_FILE_NAME must be BACKUP_FILE.')
        IFEND
        attach_or_request_command = ''
        backup_file_already_attached = TRUE
      ELSE
        attach_or_request_command = 'attach_file am=read local_file_name=backup_file file= '//$string(backup_file)
      IFEND
    ELSE
      attach_or_request_command = 'attach_file am=read local_file_name=backup_file file= '//$string(backup_file)
    IFEND
  ELSE
    attach_or_request_command = 'request_magnetic_tape file=$local.backup_file ring=no type='//$string(type)// ..
          ' external_vsn='//$string(volume_list, source)// ..
          '; set_file_attributes file=$local.backup_file file_label_type='//$string(file_label_type)
  IFEND

"Create a file containing a batch job to do the actual restore.
COLLECT_TEXT output=job_file sm='?' until='**END_COLLECT**'
  ?execution_mode_command?
    IF NOT $variable(ignore_status, local) THEN
      VAR
        ignore_status: status
      VAREND
    IFEND
    create_command_list_entry entry=$system.osf$builtin_library status=ignore_status
    create_command_list_entry entry=$system.osf$sou_library status=ignore_status
    ?attach_or_request_command?

    WHEN any_fault DO
     IF NOT ?backup_file_already_attached? THEN
       detach_file file=$local.backup_file
     IFEND
     display_value osv$status
     send_operator_message ' RESTORE_UNRECONCILED_FILES aborted -check listing '
    WHENEND

    SYSTEM_OPERATOR_UTILITY CAPABILITY=SYSTEM_ADMINISTRATION
    TASK ring=3
      restore_permanent_files list=?output?
        include_volumes recorded_vsn=?$string($parameter_value(recorded_vsn), source)?
        set_restore_options update_cycle_statistics=FALSE restore_archive_information=TRUE
        set_restore_options require_matching_modification=FALSE
        restore_excluded_file_cycles backup_file=$local.backup_file ..
               restore_options=?$string($parameter_value(restore_options), source)?
      QUIT
      change_file_attributes file=?output? ring_attributes=(11 11 11) status=ignore_status
    TASKEND
    IF NOT ?backup_file_already_attached? THEN
      detach_file file=$local.backup_file
    IFEND
    QUIT
  ?terminate_execution_command?
**END_COLLECT**

  include_file file=job_file
  detach_file file=job_file

PROCEND restore_unreconciled_files
*DECK DECK=PUP$RETRIEVE_QUALIFIED_FILES EXPAND=TRUE
PROCEDURE retrieve_qualified_files, retqf (
  retrieve_file_list, rfl: file = $required
  accessed_after, aa: date_time = $optional
  accessed_before, ab: date_time = $optional
  created_after, ca: date_time = $optional
  created_before, cb: date_time = $optional
  duplicated_after, da: date_time = $optional
  duplicated_before, db: date_time = $optional
  expired_after, ea: date_time = $optional
  expired_before, eb: date_time = $optional
  modified_after, ma: date_time = $optional
  modified_before, mb: date_time = $optional
  retrieved_after, ra: date_time = $optional
  retrieved_before, rb: date_time = $optional
  size_greater_than, sgt: integer = $optional
  size_less_than, slt: integer = $optional
  total_megabyte_limit, tml: integer = $optional
  pause_for_retrieval, pfr: boolean = TRUE
  pause_trigger_point, ptp: integer 1..4000 = 2000
  retrieval_trigger_point, rtp: integer 1..100 = 100
  status)

  VAR
    candidate: boolean
    chunk_size: integer = 1000
    date_parameter_specified: boolean
    file_name: file
    files: list 0 .. 100 of string (512)
    files_analyzed: integer = 0
    files_retrieved: integer = 0
    handler_entered: boolean = false
    ignore_status: status
    local_status: status
    min_allocation_unit: integer = 16384
    one_mb: integer = 1048576
    path_string: string (512)
    pause_counter: integer = 0
    permanent_file: boolean = ($file_attributes(retrieve_file_list lifetime)(1).lifetime = unlimited)
    retrieval_list: list of file = ()
    size_accumulator: integer = 0
    size_limit: integer = $max_integer
  VAREND

  WHEN any_fault exit terminate DO
    IF NOT handler_entered THEN
      handler_entered = true
      change_catalog_access flush_catalogs=true
      IF permanent_file THEN
        detach_file f=retrieve_file_list status=ignore_status
      IFEND
      IF ($size(retrieval_list) > 0) THEN
        retrieve_files file=retrieval_list wait_for_retrieval=false
        files_retrieved = files_retrieved + $size(retrieval_list)
      IFEND
      delete_variable attrib status=ignore_status
      delete_variable file_list status=ignore_status
      stop_time = $time
      display_value (' Files Processed: '//files_analyzed)
      display_value (' Files Processed: '//files_analyzed) o=$job_log
      display_value (' Files Retrieved: '//files_retrieved)
      display_value (' Files Retrieved: '//files_retrieved) o=$job_log
      display_value (' Retrieval Byte Limit: '//size_limit)
      display_value (' Retrieval Byte Limit: '//size_limit) o=$job_log
      display_value (' Bytes Retrieved: '//size_accumulator)
      display_value (' Bytes Retrieved: '//size_accumulator) o=$job_log
      display_value (' Started At: '//start_time)
      display_value (' Started At: '//start_time) o=$job_log
      display_value (' Stopped At: '//stop_time)
      display_value (' Stopped At: '//stop_time) o=$job_log
    IFEND
    EXIT retrieve_qualified_files WITH osv$status
  WHENEND

  start_time = $time
  date_parameter_specified = $specified(accessed_after) OR $specified(accessed_before)
  date_parameter_specified = date_parameter_specified OR $specified(created_after) OR $specified(created_before)
  date_parameter_specified = date_parameter_specified OR $specified(duplicated_after) OR $specified(duplicated_before)
  date_parameter_specified = date_parameter_specified OR $specified(expired_after) OR $specified(expired_before)
  date_parameter_specified = date_parameter_specified OR $specified(modified_after) OR $specified(modified_before)
  date_parameter_specified = date_parameter_specified OR $specified(retrieved_after) OR $specified(retrieved_before)
  IF $specified(total_megabyte_limit) THEN
    IF (total_megabyte_limit > 0) AND (total_megabyte_limit < ($max_integer/one_mb)) THEN
      size_limit = total_megabyte_limit * one_mb
    IFEND
  IFEND

  change_catalog_access flush_catalogs=false

  IF permanent_file THEN
    attach_file f=retrieve_file_list local_file_name=$name($unique()) private_read=false status=local_status
  IFEND

  IF local_status.normal THEN
    execute_task sp=pfp$get_file_list p='file=retrieve_file_list.$boi variable_name=file_list list_size=chunk_size' ..
          l=$system.osf$task_services_library status=local_status
  main_block: ..
    WHILE local_status.normal AND ($size(file_list) > 0) DO
      attrib = $file_attributes(file_list, (creation_date_time cycle_number device_class expiration_date last_access_date_time ..
            last_modification_date_time lifetime object_type path registered secondary_residence size))

      FOR EACH file_ref IN attrib DO
        files_analyzed = files_analyzed + 1
        IF file_ref.registered AND (file_ref.lifetime = 'UNLIMITED') AND (file_ref.device_class = 'MASS_STORAGE') AND ..
              (file_ref.object_type = 'CYCLE') THEN
          candidate = false
          IF date_parameter_specified THEN

            IF $specified(accessed_after) THEN
              candidate = candidate OR (file_ref.last_access_date_time > accessed_after)
            IFEND
            IF (NOT candidate) AND $specified(accessed_before) THEN
              candidate = candidate OR (file_ref.last_access_date_time < accessed_before)
            IFEND

            IF (NOT candidate) AND $specified(created_after) THEN
              candidate = candidate OR (file_ref.creation_date_time > created_after)
            IFEND
            IF (NOT candidate) AND $specified(created_before) THEN
              candidate = candidate OR (file_ref.creation_date_time < created_before)
            IFEND

            IF (NOT candidate) AND $specified(modified_after) THEN
              candidate = candidate OR (file_ref.last_modification_date_time > modified_after)
            IFEND
            IF (NOT candidate) AND $specified(modified_before) THEN
              candidate = candidate OR (file_ref.last_modification_date_time < modified_before)
            IFEND

            IF (NOT candidate) AND (NOT $nil(file_ref.secondary_residence)) THEN
              FOR i = 1 TO $size(file_ref.secondary_residence) DO
                IF $specified(duplicated_after) THEN
                  candidate = candidate OR (file_ref.secondary_residence(i).duplication_date_time > duplicated_after)
                IFEND
                IF (NOT candidate) AND $specified(duplicated_before) THEN
                  candidate = candidate OR (file_ref.secondary_residence(i).duplication_date_time < duplicated_before)
                IFEND

                IF (NOT candidate) AND ..
                      ($name($generic_type(file_ref.secondary_residence(i).last_data_retrieval_date_time)) <> 'KEY') THEN
                  IF $specified(retrieved_after) THEN
                    candidate = candidate OR (file_ref.secondary_residence(i).last_data_retrieval_date_time > retrieved_after)
                  IFEND
                  IF (NOT candidate) AND $specified(retrieved_before) THEN
                    candidate = candidate OR (file_ref.secondary_residence(i).last_data_retrieval_date_time < retrieved_before)
                  IFEND
                IFEND
              FOREND
            IFEND

            IF (NOT candidate) AND ($name($generic_type(file_ref.expiration_date)) <> 'KEY') THEN
              IF $specified(expired_after) THEN
                candidate = candidate OR (file_ref.expiration_date > expired_after)
              IFEND
              IF $specified(expired_before) THEN
                candidate = candidate OR (file_ref.expiration_date < expired_before)
              IFEND
            IFEND

            IF candidate AND $specified(size_greater_than) AND (NOT $specified(size_less_than)) THEN
              candidate = (file_ref.size > size_greater_than)
            ELSEIF candidate AND $specified(size_less_than) AND (NOT $specified(size_greater_than)) THEN
              candidate = (file_ref.size < size_less_than)
            ELSEIF candidate AND $specified(size_less_than) AND $specified(size_greater_than) THEN
              candidate = ((file_ref.size > size_greater_than) AND (file_ref.size < size_less_than))
            IFEND
          ELSE
            IF $specified(size_greater_than) AND (NOT $specified(size_less_than)) THEN
              candidate = (file_ref.size > size_greater_than)
            ELSEIF $specified(size_less_than) AND (NOT $specified(size_greater_than)) THEN
              candidate = (file_ref.size < size_less_than)
            ELSEIF $specified(size_less_than) AND $specified(size_greater_than) THEN
              candidate = ((file_ref.size > size_greater_than) AND (file_ref.size < size_less_than))
            ELSE
              candidate = true
            IFEND
          IFEND

          IF candidate THEN
            path_string = $string(file_ref.path)//'.'//$string(file_ref.cycle_number)
            IF ($size(retrieval_list) > 0) THEN
              IF $size(retrieval_list) = retrieval_trigger_point THEN
                files_retrieved = files_retrieved + retrieval_trigger_point
                retrieve_files file=retrieval_list wait_for_retrieval=false
                pause_counter = pause_counter + retrieval_trigger_point
                IF pause_for_retrieval AND (pause_counter >= pause_trigger_point) THEN
                  send_operator_message message=..
'RETRIEVE_QUALIFIED_FILES - waiting for retrievals.  Acknowledge this message to process more retrieval candidates.' ..
                        operator_class=removable_media_operator
                  pause_counter = 0
                IFEND
                retrieval_list = $list_of($fname(path_string))
              ELSE
                retrieval_list = $join(retrieval_list $fname(path_string))
              IFEND
            ELSE
              retrieval_list = $list_of($fname(path_string))
            IFEND
            size_accumulator = size_accumulator + ..
                  (((file_ref.size + min_allocation_unit - 1)/min_allocation_unit)* min_allocation_unit)
            IF size_accumulator >= size_limit THEN
              EXIT main_block
            IFEND
          IFEND
        IFEND
      FOREND
      delete_variable attrib status=ignore_status
      execute_task sp=pfp$get_file_list p='file=retrieve_file_list.$asis variable_name=file_list list_size=chunk_size' ..
            l=$system.osf$task_services_library status=local_status
    WHILEND main_block
  IFEND
  EXIT_PROC WHEN (NOT local_status.normal) AND (local_status.condition <> ame$input_after_eoi) with local_status

PROCEND retrieve_qualified_files
*DECK DECK=PUP$SET_ABNORMAL_ENTRY_STATUS EXPAND=FALSE
  PROCEDURE [XREF] pup$set_abnormal_entry_status ALIAS 'puxsaes' (entry:
    put$entry;
        condition: ost$status_condition;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PUD$HIERARCHY_LIST
?? POP ??
*DECK DECK=PUP$SET_OBJECT_ABNORMAL EXPAND=FALSE

  PROCEDURE [XREF] pup$set_object_abnormal
    (   p_object: ^put$selected_object;
        condition: ost$status_condition;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc put$selected_object
*copyc ost$status
?? POP ??
*DECK DECK=PUP$SET_RESTORE_SUBCMD_DEFAULTS EXPAND=FALSE
  PROCEDURE [XREF] pup$set_restore_subcmd_defaults (update_cycle_statistics: boolean);

*DECK DECK=PUP$SET_UNKNOWN_CYCLE_STATUS EXPAND=FALSE

  PROCEDURE [XREF] pup$set_unknown_cycle_status (file_name: pft$name;
        cycle_selector: pft$cycle_selector;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$SKIP_LOGICAL_PARTITION EXPAND=FALSE

  PROCEDURE [XREF] pup$skip_logical_partition ALIAS 'puxskip' (VAR
    backup_file_id: put$file_identifier;
    VAR file_position: put$file_position;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PUT$FILE_IDENTIFIER
*copyc PUT$FILE_POSITION
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$SKIP_PHYSICAL_PARTITION EXPAND=FALSE
  PROCEDURE [XREF] pup$skip_physical_partition ALIAS 'puxskpp' (VAR backup_file_id: put$file_identifier;
    VAR file_position: put$file_position;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUT$FILE_IDENTIFIER
*copyc PUT$FILE_POSITION
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$SORT_CYCLE_ARRAY EXPAND=FALSE
 PROCEDURE [XREF]  pup$sort_cycle_array ALIAS 'puxsca' (VAR sorted_cycle_array:
    pft$cycle_array);
?? push (listext := on) ??
*copyc PFD$CATALOG_INFO
?? POP ??
*DECK DECK=PUP$SORT_CYCLE_ARRAY_VERSION_2 EXPAND=FALSE
                                                                                                              
  PROCEDURE [XREF] pup$sort_cycle_array_version_2                                                             
    (VAR sorted_cycle_array: pft$cycle_array_version_2);                                                      
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc pfd$catalog_info                                                                                       
?? POP ??                                                                                                     
*DECK DECK=PUP$SORT_DIRECTORY EXPAND=FALSE
  PROCEDURE [XREF] pup$sort_directory (unsorted_directory: pft$directory_array;
    VAR sorted_directory: pft$directory_array);
?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_info
?? POP ??
*DECK DECK=PUP$STORE_BACKUP_LABEL_TYPE EXPAND=FALSE
*DECK DECK=PUP$STORE_FILE_GFN EXPAND=FALSE
  PROCEDURE [XREF] pup$store_file_gfn (gfn: ost$binary_unique_name;
        path: pft$path;
        cycle_selector: pft$cycle_selector;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*COPYC OSD$UNIQUE_NAME
*COPYC OST$STATUS
*COPYC PFD$PERMANENT_FILE_DEFINITIONS
?? POP ??
*DECK DECK=PUP$VALIDATE_N_N_MINUS_1 EXPAND=FALSE

  PROCEDURE [XREF] pup$validate_n_n_minus_1 (path: pft$path;
     n_type: put$entry_type;
        cycle_selector: pft$cycle_selector;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$VERIFY_CATALOG_PATH EXPAND=FALSE

  PROCEDURE [XREF] pup$verify_catalog_path ALIAS 'puxvcp' (catalog_path:
    pft$path;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$VERIFY_FAMILY_ADMINISTRATOR EXPAND=TRUE
  PROCEDURE [XREF] pup$verify_family_administrator (request_name: string (* <= osc$max_name_size) ;
        family_name: pft$name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=PUP$VERIFY_FILE_PATH EXPAND=FALSE

  PROCEDURE [XREF] pup$verify_file_path ALIAS 'puxvfp' (file_path: pft$path;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$VERIFY_SYSTEM_ADMINISTRATOR EXPAND=FALSE
  PROCEDURE [XREF] pup$verify_system_administrator (request_name: string (* <= osc$max_name_size);
        p_included_users: ^put$user_range_list;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc put$user_range_list
*copyc ost$status
?? POP ??
*DECK DECK=PUP$VERIFY_VOLUME_LIST EXPAND=FALSE
  PROCEDURE [XREF] pup$verify_volume_list (volume_list: array [1 .. * ] OF rmt$recorded_vsn;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmd$volume_declarations
?? POP ??
*DECK DECK=PUP$WRITE_CATALOG_HEADER EXPAND=FALSE

  PROCEDURE [XREF] pup$write_catalog_header (cat_head: put$catalog_header;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$WRITE_CYCLE_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] pup$write_cycle_display
    (    pf_entry: put$entry;
         cycle_entry: pft$cycle_array_entry_version_2;
         file_length: amt$file_length;
         global_file_name: ost$binary_unique_name;
         p_recorded_vsns: ^array [1 .. * ] of rmt$recorded_vsn;
         p_cycle_array_extended_record: pft$p_info_record;
         p_cycle_directory_array: pft$p_cycle_directory_array;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_length
*copyc osd$unique_name
*copyc ost$status
*copyc pfd$catalog_info
*copyc pud$hierarchy_list
*copyc pud$list_options
*copyc rmd$volume_declarations
?? POP ??


*DECK DECK=PUP$WRITE_CYCLE_DISPLAY_HEADER EXPAND=FALSE

  PROCEDURE [XREF] pup$write_cycle_display_header ALIAS 'puxwcdh' (VAR status:
    ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$WRITE_CYCLE_SELECTOR EXPAND=FALSE

  PROCEDURE [XREF] pup$write_cycle_selector ALIAS 'puxwcys' (pf_selector:
    pft$cycle_selector;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$WRITE_DELETED_CYCLE EXPAND=FALSE

  PROCEDURE [XREF] pup$write_deleted_cycle
    (    pf_entry: put$entry;
         cycle_entry: pft$cycle_array_entry_version_2;
         file_length: amt$file_length;
         global_file_name: ost$binary_unique_name;
         p_recorded_vsns: ^array [1 .. * ] of rmt$recorded_vsn;
         p_cycle_array_extended_record: pft$p_info_record;
         p_cycle_directory_array: pft$p_cycle_directory_array;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_length
*copyc osd$unique_name
*copyc ost$status
*copyc pfd$catalog_info
*copyc pud$hierarchy_list
*copyc pud$list_options
*copyc rmd$volume_declarations
?? POP ??
*DECK DECK=PUP$WRITE_EXCLUDED_CYCLE EXPAND=FALSE

  PROCEDURE [XREF] pup$write_excluded_cycle
    (    pf_entry: put$entry;
         cycle_array_entry: pft$cycle_array_entry_version_2;
         file_length: amt$file_length;
         global_file_name: ost$binary_unique_name;
         p_recorded_vsn: ^array [1 .. * ] of rmt$recorded_vsn;
         p_cycle_array_extended_record: pft$p_info_record;
         p_cycle_directory_array: pft$p_cycle_directory_array;
         exclusion_descriptor: put$action_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_length
*copyc osd$unique_name
*copyc ost$status
*copyc pfd$catalog_info
*copyc pud$hierarchy_list
*copyc pud$list_options
*copyc rmd$volume_declarations
?? POP ??
*DECK DECK=PUP$WRITE_FILE_DISPLAY EXPAND=FALSE
  PROCEDURE [XREF] pup$write_file_display (pf_entry: put$entry;
        account: avt$account_name;
        project: avt$project_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pud$backup_file
*copyc avt$account_name
*copyc avt$project_name
*copyc ost$status
?? POP ??
*DECK DECK=PUP$WRITE_LOGICAL_PARTITION EXPAND=FALSE

  PROCEDURE [XREF] pup$write_logical_partition ALIAS 'puxwlp' (VAR
    backup_file_id: put$file_identifier;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc PUT$FILE_IDENTIFIER
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$WRITE_OS_STATUS EXPAND=FALSE

  PROCEDURE [XREF] pup$write_os_status ALIAS 'puxwoss' (status: ost$status;
    VAR request_status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$WRITE_PATH EXPAND=FALSE

  PROCEDURE [XREF] pup$write_path ALIAS 'puxwpat' (path: pft$path;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$WRITE_STATUS_TO_LISTING EXPAND=FALSE

  PROCEDURE [XREF] pup$write_status_to_listing ALIAS 'puxwstl'
    (pf_utility_entry: put$entry;
        bad_status: ost$status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
*copyc OST$STATUS
?? POP ??
*DECK DECK=PUP$WRITE_SUB_PATH EXPAND=FALSE

  PROCEDURE [XREF] pup$write_sub_path ALIAS 'puxwspa' (path: pft$path;
        lower: integer;
        upper: integer;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc PFD$PERMANENT_FILE_DEFINITIONS
?? POP ??
*DECK DECK=PUS$LITERALS EXPAND=FALSE

  SECTION
    pus$literals: READ;
*DECK DECK=PUT$EXCLUDED_ITEM_ENTRY EXPAND=FALSE

  TYPE
    put$excluded_item_entry = record
      p_next_excluded_entry: ^put$excluded_item_entry,
      entry: put$entry,
      catalog_header: put$catalog_header,
    recend,

    put$excluded_item_list = array [put$entry_type] of
      ^put$excluded_item_entry;

?? PUSH (LISTEXT := ON) ??
*copyc PUD$HIERARCHY_LIST
?? POP ??
*DECK DECK=PUT$EXCLUDE_SITE_BACKUP_OPTIONS EXPAND=FALSE

  TYPE
    put$exclude_site_backup_options = SET OF 0 .. 255;
*DECK DECK=PUT$FILE_DISPLAY_INFO EXPAND=FALSE

  TYPE
    put$file_display_info = record
      case display: boolean of
      = TRUE =
        pf_entry: put$entry,
        p_file_description: pft$p_file_description,
      = FALSE =
        ,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_info
*copyc pud$hierarchy_list
?? POP ??
*DECK DECK=PUT$FILE_IDENTIFIER EXPAND=FALSE

  TYPE
    put$file_identifier = record
      lfn: amt$local_file_name,
      file_id: amt$file_identifier,
      device_class: rmt$device_class,
      label_type: amt$label_type,
      open_position: amt$open_position,
      operation: put$operation,
      record_type: amt$record_type,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_IDENTIFIER
*copyc RMT$DEVICE_CLASS
*copyc AMT$LABEL_TYPE
*copyc AMT$LOCAL_FILE_NAME
*copyc AMT$OPEN_POSITION
*copyc AMT$RECORD_TYPE
*copyc PUT$OPERATION
?? POP ??
*DECK DECK=PUT$FILE_POSITION EXPAND=FALSE

  TYPE
    put$file_position = (puc$boi, puc$mid_partition, puc$partition_boundary,
      puc$eoi);
*DECK DECK=PUT$GLOBAL_BACKUP_FILE_ID EXPAND=FALSE
  TYPE
    put$global_backup_file_id = record
      case backup_file_open: boolean of
      = TRUE =
        backup_file_id: put$file_identifier,
      = FALSE =
      CASEND,
    recend;

*copyc put$file_identifier
*DECK DECK=PUT$INCLUDE_DATA_OPTIONS EXPAND=FALSE

  TYPE
    put$include_data_options = SET OF (puc$include_offline_data,
                                       puc$include_releasable_data,
                                       puc$include_unreleasable_data);










*DECK DECK=PUT$INCLUDE_VOLUMES_OPTION EXPAND=FALSE

  TYPE
    put$include_volumes_option = (puc$initial_volume, puc$multiple_volumes);

*DECK DECK=PUT$LOG_KEYED_FILE_PARAMETERS EXPAND=FALSE

  TYPE
    put$log_keyed_file_parameters = record
      path: fst$path,
      path_size: fst$path_size,
      password: pft$password,
      global_file_name: ost$binary_unique_name,
      backup_information: amt$backup_information,
      volume_list_size: ost$positive_integers,
    recend;

*copyc amt$backup_information
*copyc fst$path
*copyc fst$path_size
*copyc osd$integer_limits
*copyc ost$binary_unique_name
*copyc pfd$permanent_file_definitions
*DECK DECK=PUT$OPERATION EXPAND=FALSE

  TYPE
    put$operation = (puc$backup_permanent_files, puc$restore_permanent_files, puc$display_backup_file,
          puc$$backup_file);
*DECK DECK=PUT$RESTORE_DATA_SELECTIONS EXPAND=FALSE

  TYPE
    put$restore_data_options = (puc$media_missing, puc$no_data_defined, puc$volume_unavailable),
    put$restore_data_selections = set of put$restore_data_options;
*DECK DECK=PUT$SELECTED_CYCLE EXPAND=FALSE

  TYPE
    put$selected_cycle = record
      case cycle_specified: boolean of
      = TRUE =
        cycle_selector: pft$cycle_selector,
      = FALSE =
        ,
      casend,
    recend;

*copyc pud$hierarchy_list
*DECK DECK=PUT$SELECTED_CYCLE_INFO EXPAND=FALSE

  TYPE
    put$selected_cycle_info = record
      selected_cycle: put$selected_cycle,
      new_selected_cycle: put$selected_cycle,
    recend;

*copyc put$selected_cycle
*DECK DECK=PUT$SELECTED_OBJECT EXPAND=FALSE

  TYPE
    put$selected_object = record
      entry: put$entry,
      p_catalog_header: ^put$catalog_header,
      new_entry: put$entry,
      p_new_catalog_header: ^put$catalog_header,
      selected_cycle_info: put$selected_cycle_info,
      object_restored: boolean,
      link: ^put$selected_object,
    recend;

*copyc pud$hierarchy_list
*copyc put$selected_cycle_info
*DECK DECK=PUT$STATUS_SEVERITY EXPAND=FALSE
 TYPE
    put$status_severity = (puc$normal_status, puc$informative_status,
      puc$warning_status, puc$error_status, puc$fatal_status,
      puc$catastrophic_status);


  VAR
    puv$termination_error_level: [READ, pus$literals] put$status_severity :=
      puc$fatal_status;

?? PUSH (LISTEXT := ON) ??
*copyc pus$literals
?? POP ??
*DECK DECK=PUT$USER_RANGE_LIST EXPAND=FALSE

  TYPE
    put$user_range_list = array [1 .. * ] of put$user_range,

    put$user_range = array [clt$low_or_high] of put$user_path,

    put$user_path = array [pfc$family_name_index ..
      pfc$master_catalog_name_index] of pft$name;

  CONST
    puc$max_number_of_user_ranges = 20;

  CONST
    puc$default_low_name = '#                              ',
    puc$default_high_name = 'zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz';


  TYPE
    put$user_range_list_container = SEQ (REP puc$max_number_of_user_ranges of
      put$user_range);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$PERMANENT_FILE_DEFINITIONS
*copyc CLD$PARAMETER_LIMITS
?? POP ??
*DECK DECK=PUV$BACKUP_CRITERIA EXPAND=FALSE

  VAR
    puv$backup_criteria: [XREF] put$selection_criteria;

?? PUSH (LISTEXT := ON) ??
*copyc pud$selection_criteria
?? POP ??
*DECK DECK=PUV$BACKUP_FILE_ID EXPAND=FALSE

  VAR
    puv$backup_file_id: [XREF] put$file_identifier;

?? PUSH (LISTEXT := ON) ??
*copyc put$file_identifier
?? POP ??
*DECK DECK=PUV$BACKUP_INFORMATION EXPAND=FALSE

  VAR
    puv$backup_information: [XREF] amt$backup_information;
?? PUSH (LISTEXT := ON) ??
*copyc amt$backup_information
?? POP ??

*DECK DECK=PUV$BACKUP_SHARE_MODES EXPAND=FALSE

  VAR
    puv$backup_share_modes: [XREF] pft$usage_selections;
?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_attributes
?? POP ??
*DECK DECK=PUV$BACPF_BACKUP_FILE_VERSION EXPAND=FALSE
                                                                                                              
  VAR                                                                                                         
    puv$bacpf_backup_file_version: [XREF] put$backup_file_version_name;                                       
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc pud$backup_file                                                                                        
?? POP ??                                                                                                     
*DECK DECK=PUV$BACPF_CYCLE_DATA_TOTAL EXPAND=FALSE


    VAR
      puv$bacpf_cycle_data_total: [XREF] ost$non_negative_integers;

?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
?? POP ??
*DECK DECK=PUV$CREATE_OBJECTS EXPAND=TRUE

  VAR
    puv$create_objects: [XREF] boolean;
*DECK DECK=PUV$CYCLE_DISPLAY_SELECTIONS EXPAND=FALSE
  VAR
    puv$cycle_display_selections: [XREF] put$cycle_display_selections;
?? PUSH (LISTEXT := ON) ??
*copyc pud$List_options
?? POP ??
*DECK DECK=PUV$DATA_FILE_SELECTED EXPAND=FALSE
  VAR
    puv$data_file_selected: [XREF] boolean;










*DECK DECK=PUV$DISPLAY_EXCLUDED_ITEMS EXPAND=FALSE

  VAR
    puv$display_excluded_items: [XREF] boolean;
*DECK DECK=PUV$EXCLUDE_CATALOG_INFORMATION EXPAND=FALSE
  VAR
    puv$exclude_catalog_information: [XREF] boolean;

*DECK DECK=PUV$EXCLUDE_SITE_BACKUP_OPTIONS EXPAND=FALSE

  VAR
    puv$exclude_site_backup_options: [XREF] put$exclude_site_backup_options;

?? PUSH (LISTEXT := ON) ??
*copyc put$exclude_site_backup_options
?? POP ??
*DECK DECK=PUV$FREE_BEHIND_SELECTED EXPAND=FALSE

  VAR
    puv$free_behind_selected :[XREF] boolean;
*DECK DECK=PUV$GLOBAL_BACKUP_FILE_ID EXPAND=FALSE

  VAR
    puv$global_backup_file_id: [XREF] put$global_backup_file_id;

?? PUSH (LISTEXT := ON) ??
*copyc put$global_backup_file_id
?? POP ??
*DECK DECK=PUV$INCLUDE_ARCHIVE_INFORMATION EXPAND=FALSE

  VAR
    puv$include_archive_information: [XREF] boolean;
*DECK DECK=PUV$INCLUDE_DATA_OPTIONS EXPAND=FALSE

  VAR
    puv$include_data_options: [XREF] put$include_data_options;

?? PUSH (LISTEXT := ON) ??
*copyc put$include_data_options
?? POP ??
*DECK DECK=PUV$INCLUDE_EXCEPTIONS EXPAND=FALSE

  VAR
    puv$include_exceptions: [XREF] boolean;
*DECK DECK=PUV$INCLUDE_VOLUMES_OPTION EXPAND=FALSE

 VAR
   puv$include_volumes_option: [XREF] put$include_volumes_option;

*copyc put$include_volumes_option
*DECK DECK=PUV$INITIAL_VOLUME EXPAND=FALSE
  VAR
    puv$initial_volume: [XREF] rmt$recorded_vsn;
?? PUSH (LISTEXT := ON) ??
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=PUV$LAST_VOLUME_NUMBER EXPAND=FALSE
  VAR
    puv$last_volume_number: [XREF] amt$volume_number;
?? PUSH (LISTEXT := ON) ??
*copyc amt$volume_number
?? POP ??
*DECK DECK=PUV$LISTING_DISPLAY_CONTROL EXPAND=FALSE

  VAR
    puv$listing_display_control: [XREF] clt$display_control;

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
?? POP ??
*DECK DECK=PUV$MASS_STORAGE_INFO EXPAND=FALSE

  VAR
    puv$mass_storage_info: [XREF] fmt$mass_storage_request_info;

?? PUSH (LISTEXT := ON) ??
*copyc fmt$mass_storage_request_info
?? POP ??
*DECK DECK=PUV$MAXIMUM_CYCLE_SIZE EXPAND=FALSE

  VAR
    puv$maximum_cycle_size: [XREF] amt$file_length;

*copyc amt$file_length
*DECK DECK=PUV$MINIMUM_CYCLE_SIZE EXPAND=FALSE

  VAR
    puv$minimum_cycle_size: [XREF] amt$file_length;

*copyc amt$file_length
*DECK DECK=PUV$NULL_ORIGINAL_UNIQUE_NAME EXPAND=FALSE

  VAR
    puv$null_original_unique_name: [XREF] ost$binary_unique_name;

?? PUSH (LISTEXT := ON) ??
*copyc osd$unique_name
?? POP ??
*DECK DECK=PUV$NULL_RESERVED_CYCLE_INFO_SP EXPAND=FALSE

  VAR
    puv$null_reserved_cycle_info_sp: [XREF] array [1 .. 55] of boolean;
*DECK DECK=PUV$NULL_RES_CYCLE_ARRAY_ENT_SP EXPAND=FALSE

  VAR
    puv$null_res_cycle_array_ent_sp: [XREF] array [1 .. 46] of boolean;
*DECK DECK=PUV$PREV_OPEN_BY_$BACKUP_FILE EXPAND=FALSE

    VAR
      puv$prev_open_by_$backup_file: [XREF, STATIC] boolean;
*DECK DECK=PUV$PURGE_CYCLE_OPTIONS EXPAND=TRUE

  VAR
    puv$purge_cycle_options: [XREF] pft$purge_cycle_options;

*copyc pft$purge_cycle_options
*DECK DECK=PUV$P_INCLUDED_VOLUMES EXPAND=FALSE
  VAR
    puv$p_included_volumes: [XREF] ^array [1 .. * ] of rmt$recorded_vsn;

*DECK DECK=PUV$P_USER_RANGE_LIST EXPAND=FALSE
  VAR
    puv$p_user_range_list: [XREF] ^put$user_range_list;
?? PUSH (LISTEXT := ON) ??
*copyc put$user_range_list
?? POP ??
*DECK DECK=PUV$READ_DATA_ON_NULL_BF EXPAND=FALSE
  VAR
    puv$read_data_on_null_bf: [XREF] boolean;


*DECK DECK=PUV$REPLACE_CYCLE_DATA EXPAND=TRUE

  VAR
    puv$replace_cycle_data: [XREF] boolean;
*DECK DECK=PUV$REQUIRE_MODIFICATION_MATCH EXPAND=FALSE
  VAR
    puv$require_modification_match: [XREF] boolean;

*DECK DECK=PUV$RESPF_BACKUP_FILE_VERSION EXPAND=FALSE
                                                                                                              
  VAR                                                                                                         
    puv$respf_backup_file_version: [XREF] put$backup_file_version_name;                                       
                                                                                                              
?? PUSH (LISTEXT := ON) ??                                                                                    
*copyc pud$backup_file                                                                                        
?? POP ??                                                                                                     
*DECK DECK=PUV$RESTORE_ARCHIVE_INFORMATION EXPAND=FALSE

  VAR
    puv$restore_archive_information: [XREF] boolean;
*DECK DECK=PUV$SORT_USERS EXPAND=FALSE

  VAR
    puv$sort_users: [XREF] boolean;
*DECK DECK=PUV$TRACE_SELECTED EXPAND=FALSE
?? PUSH (LISTEXT := ON) ??
*copyc PUP$DISPLAY_LINE
*copyc PUP$DISPLAY_INTEGER
*copyc PUP$WRITE_OS_STATUS

  VAR
    puv$trace_selected: [XREF] boolean;

?? POP ??

  PROCEDURE [INLINE] display (display_line: string ( * <= 256));

    VAR
      status: ost$status;

    IF NOT puv$trace_selected THEN
      RETURN;
    IFEND;
    pup$display_line (display_line, status);
  PROCEND display;

  PROCEDURE [INLINE] display_integer (descriptor: string ( * <= 256);
        number: integer);

    VAR
      local_status: ost$status;

    IF NOT puv$trace_selected THEN
      RETURN;
    IFEND;
    pup$display_integer (descriptor, number, local_status);
  PROCEND display_integer;

  PROCEDURE [INLINE] display_status (status: ost$status);


    VAR
      request_status: ost$status;

    IF NOT puv$trace_selected THEN
      RETURN;
    IFEND;
    IF status.normal THEN
      display (' STATUS NORMAL ');
      RETURN;
    IFEND;
    pup$write_os_status (status, request_status);
  PROCEND display_status;
?? PUSH (LISTEXT := ON) ??
*copyc OSP$FORMAT_MESSAGE
?? POP ??
*DECK DECK=PUV$UPDATE_CYCLE_STATISTICS EXPAND=FALSE
  VAR
    puv$update_cycle_statistics: [XREF] boolean;
*DECK DECK=PUV$VOLUMES_SWITCHED_FORWARD EXPAND=FALSE
  VAR
    puv$volumes_switched_forward: [XREF] boolean;
*DECK DECK=PUV$VOLUME_OVERFLOW_ALLOWED EXPAND=FALSE
  VAR
    puv$volume_overflow_allowed: [XREF] boolean;
*DECK DECK=QCI$NOSVE_MAINTENANCE EXPAND=FALSE

create_subproduct_deck..
  name=nosve_maintenance..
  description='NOS/VE Deadstart Tape Maintenance Files'..
  installation_scheme=cycle_based..
  internal_level=?wev$os_level?..
  level=?wev$release_level?..
  licensed_product=nos_ve..
  subproduct_installation_path=:$system.$system.nosve_maintenance..
  additional_products=none..
  auto_install=true..
  correction_base_level=?wev$os_level?..
  date_level='?wev$release_date?'..
  development_group='AHPD'..
  hidden=false..
  installation_path_option=not_definable..
  installer_procedure=$system.software_maintenance.raf$library.install_nosve_maintenance ..
  primary_subproduct=true..
  product_dependencies=none..
  stamp_files=true..
  subproduct_priority=low

create_file_deck..
  name=osf$bound_job_template_223..
  path=$system.nosve_maintenance.link_input_files.osf$bound_job_template_223..
  subproduct=nosve_maintenance..
  intve_path='!wev$server_development_base!.os.?wev$build_level?.bound_job_template_223'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$bound_job_template_236..
  path=$system.nosve_maintenance.link_input_files.osf$bound_job_template_236..
  subproduct=nosve_maintenance..
  intve_path='!wev$server_development_base!.os.?wev$build_level?.bound_job_template_236'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$bound_job_template_23d..
  path=$system.nosve_maintenance.link_input_files.osf$bound_job_template_23d..
  subproduct=nosve_maintenance..
  intve_path='!wev$server_development_base!.os.?wev$build_level?.bound_job_template_23d'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$bound_job_template_2dd..
  path=$system.nosve_maintenance.link_input_files.osf$bound_job_template_2dd..
  subproduct=nosve_maintenance..
  intve_path='!wev$server_development_base!.os.?wev$build_level?.bound_job_template_2dd'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$bound_monitor..
  path=$system.nosve_maintenance.link_input_files.osf$bound_monitor..
  subproduct=nosve_maintenance..
  intve_path='!wev$server_development_base!.os.?wev$build_level?.bound_monitor'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$bound_system_core_113..
  path=$system.nosve_maintenance.link_input_files.osf$bound_system_core_113..
  subproduct=nosve_maintenance..
  intve_path='!wev$server_development_base!.os.?wev$build_level?.bound_system_core_113'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$bound_system_core_133..
  path=$system.nosve_maintenance.link_input_files.osf$bound_system_core_133..
  subproduct=nosve_maintenance..
  intve_path='!wev$server_development_base!.os.?wev$build_level?.bound_system_core_133'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$bound_system_core_13d..
  path=$system.nosve_maintenance.link_input_files.osf$bound_system_core_13d..
  subproduct=nosve_maintenance..
  intve_path='!wev$server_development_base!.os.?wev$build_level?.bound_system_core_13d'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$bound_system_core_1dd..
  path=$system.nosve_maintenance.link_input_files.osf$bound_system_core_1dd..
  subproduct=nosve_maintenance..
  intve_path='!wev$server_development_base!.os.?wev$build_level?.bound_system_core_1dd'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$version..
  path=$system.nosve_maintenance.link_input_files.os_version..
  subproduct=nosve_maintenance..
  intve_path='!wev$server_development_base!.os.?wev$build_level?.version'..
  format=legible_data..
  correction_format=replacement..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

*DECK DECK=QCI$QCU_NOSVE_MAINTENANCE EXPAND=FALSE



create_subproduct_deck..
  name=nosve_maintenance..
  description='NOS/VE QCU Deadstart Tape Maintenance Files'..
  installation_scheme=cycle_based..
  internal_level=?wev$os_level?..
  level=?wev$release_level?..
  licensed_product=nos_ve..
  subproduct_installation_path=:$system.$system.nosve_maintenance..
  additional_products=none..
  auto_install=true..
  correction_base_level=?wev$os_level?..
  date_level='?wev$release_date?'..
  development_group='AHPD'..
  hidden=false..
  installation_path_option=not_definable..
  installer_procedure=$system.software_maintenance.raf$library.install_nosve_maintenance ..
  primary_subproduct=true..
  product_dependencies=none..
  stamp_files=true..
  subproduct_priority=low

create_file_deck..
  name=osf$bound_job_template_223..
  path=$system.nosve_maintenance.link_input_files.osf$bound_job_template_223..
  subproduct=nosve_maintenance..
  intve_path='?wev$working_catalog?.object.bound_job_template_223'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$bound_job_template_236..
  path=$system.nosve_maintenance.link_input_files.osf$bound_job_template_236..
  subproduct=nosve_maintenance..
  intve_path='?wev$working_catalog?.object.bound_job_template_236'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$bound_job_template_23d..
  path=$system.nosve_maintenance.link_input_files.osf$bound_job_template_23d..
  subproduct=nosve_maintenance..
  intve_path='?wev$working_catalog?.object.bound_job_template_23d'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$bound_job_template_2dd..
  path=$system.nosve_maintenance.link_input_files.osf$bound_job_template_2dd..
  subproduct=nosve_maintenance..
  intve_path='?wev$working_catalog?.object.bound_job_template_2dd'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$bound_monitor..
  path=$system.nosve_maintenance.link_input_files.osf$bound_monitor..
  subproduct=nosve_maintenance..
  intve_path='?wev$working_catalog?.object.bound_monitor'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$bound_system_core_113..
  path=$system.nosve_maintenance.link_input_files.osf$bound_system_core_113..
  subproduct=nosve_maintenance..
  intve_path='?wev$working_catalog?.object.bound_system_core_113'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$bound_system_core_133..
  path=$system.nosve_maintenance.link_input_files.osf$bound_system_core_133..
  subproduct=nosve_maintenance..
  intve_path='?wev$working_catalog?.object.bound_system_core_133'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$bound_system_core_13d..
  path=$system.nosve_maintenance.link_input_files.osf$bound_system_core_13d..
  subproduct=nosve_maintenance..
  intve_path='?wev$working_catalog?.object.bound_system_core_13d'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$bound_system_core_1dd..
  path=$system.nosve_maintenance.link_input_files.osf$bound_system_core_1dd..
  subproduct=nosve_maintenance..
  intve_path='?wev$working_catalog?.object.bound_system_core_1dd'..
  format=object_library..
  correction_format=object_library..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

create_file_deck..
  name=osf$version..
  path=$system.nosve_maintenance.link_input_files.os_version..
  subproduct=nosve_maintenance..
  intve_path='?wev$working_catalog?.object.version'..
  format=legible_data..
  correction_format=replacement..
  access_mode=NONE..
  share_mode=NONE..
  ring_attributes=(13,13,13)..
  storage_class=product

*DECK DECK=QCM$APPLY_CORRECTION EXPAND=TRUE


?? RIGHT := 110 ??
?? NEWTITLE := 'MANFC utility: APPLY_OBJECT_CORRECTION subcommand.' ??
MODULE qcm$apply_correction;

{ PURPOSE:
{   This module contains the interface that interprets the SCL parameters
{   and passes them into the CYBIL interface QCM$APPLY_OBJECT_CORRECTION.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
?? POP ??
*copyc clp$evaluate_parameters
*copyc qcp$apply_object_correction

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] qcp$apply_correction', EJECT ??

{ PURPOSE:
{   This interface interprets the SCL parameters and to make a call to the
{   CYBIL interface QCM$APPLY_OBJECT_CORRECTION.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE [XDCL] qcp$apply_correction
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE appocc_pdt (
{   base_file, bf: file = $required
{   correction_file, cf: file = $required
{   target_file, tf: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 10, 6, 9, 54, 52, 58],
    clc$command, 7, 4, 3, 0, 0, 0, 4, 'APPOCC_PDT'], [
    ['BASE_FILE                      ',clc$nominal_entry, 1],
    ['BF                             ',clc$abbreviation_entry, 1],
    ['CF                             ',clc$abbreviation_entry, 2],
    ['CORRECTION_FILE                ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['TARGET_FILE                    ',clc$nominal_entry, 3],
    ['TF                             ',clc$abbreviation_entry, 3]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$file_type]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$base_file = 1,
    p$correction_file = 2,
    p$target_file = 3,
    p$status = 4;

  VAR
    pvt: array [1 .. 4] of clt$parameter_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    qcp$apply_object_correction (pvt [p$base_file].value^.file_value^,
          pvt [p$correction_file].value^.file_value^, pvt [p$target_file].value^.file_value^,
          status);

  PROCEND qcp$apply_correction;
MODEND qcm$apply_correction;
*DECK DECK=QCM$APPLY_OBJECT_CORRECTION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'MANFC Utility: QCP$APPLY_OBJECT_CORRECTION Interface.' ??
MODULE qcm$apply_object_correction;
{ PURPOSE:
{   The module contains the interface to apply an object library correction.
{
{ DESIGN:
{  This compiled module resides in RAF$LIBRARY.
{
{  NOTES:
{
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$condition_codes
*copyc oct$metapatch_header
*copyc oct$move_items
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$return
*copyc amp$set_segment_eoi
*copyc fsp$close_file
*copyc fsp$open_file
*copyc ocp$apply_corrector
*copyc ocp$apply_move_items
*copyc ocp$build_first_intermediate_ol
*copyc ocp$checksum
*copyc qcp$copy
*copyc osp$append_status_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pmp$get_unique_name
*copyc qcp$open_file
?? OLDTITLE, NEWTITLE := '[XDCL] qcp$apply_object_correction', EJECT ??

{ PURPOSE:
{   This interface applys an object correction to the base file
{   and returns the result in the target file.
{
{ DESIGN:
{
{
{ NOTES:
{

  PROCEDURE [XDCL] qcp$apply_object_correction
    (    base_file: fst$file_reference;
         correction_file: fst$file_reference;
         target_file { output } : fst$file_reference;
     VAR status: ost$status);

    VAR
      attribute: array [1 .. 1] of fst$file_cycle_attribute,
      base_object_library: amt$segment_pointer,
      base_fid: amt$file_identifier,
      base_file_open: boolean,
      correction_fid: amt$file_identifier,
      correction_file_open: boolean,
      correction_sequence: amt$segment_pointer,
      corrector: ^SEQ ( * ),
      first_temp_fid: amt$file_identifier,
      first_temp_file: ost$name,
      first_temp_file_open: boolean,
      first_temp_object_library: amt$segment_pointer,
      ignore_status: ost$status,
      local_status: ost$status,
      metapatch: ^SEQ ( * ),
      metapatch_header: ^oct$metapatch_header,
      move_items: ^oct$move_items,
      new_checksum: integer,
      old_checksum: integer,
      predictor: ^SEQ ( * ),
      second_temp_fid: amt$file_identifier,
      second_temp_file: ost$name,
      second_temp_file_open: boolean,
      second_temp_object_library: amt$segment_pointer,
      target_object_library: amt$segment_pointer,
      target_fid: amt$file_identifier,
      target_file_open: boolean,
      write_attachment: array [1 .. 2] of fst$attachment_option;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   Return any open files and delete any sequences.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF base_file_open THEN
        fsp$close_file (base_fid, ignore_status);
        base_file_open := FALSE;
      IFEND;

      IF target_file_open THEN
        fsp$close_file (target_fid, ignore_status);
        target_file_open := FALSE;
      IFEND;

      IF correction_file_open THEN
        fsp$close_file (correction_fid, ignore_status);
        correction_file_open := FALSE;
      IFEND;

      IF first_temp_file_open THEN
        fsp$close_file (first_temp_fid, ignore_status);
        first_temp_file_open := FALSE;
        amp$return(first_temp_file, ignore_status);
      IFEND;

      IF second_temp_file_open THEN
        fsp$close_file (second_temp_fid, ignore_status);
        second_temp_file_open := FALSE;
        amp$return(second_temp_file, ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    base_file_open := FALSE;
    target_file_open := FALSE;
    correction_file_open := FALSE;
    first_temp_file_open := FALSE;
    second_temp_file_open := FALSE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      qcp$open_file (^base_file, amc$segment, fsc$read, FALSE, NIL, base_fid, base_file_open, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (base_fid, amc$sequence_pointer, base_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      qcp$open_file (^correction_file, amc$segment, fsc$read, FALSE, NIL, correction_fid,
            correction_file_open, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (correction_fid, amc$sequence_pointer, correction_sequence, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      metapatch := correction_sequence.sequence_pointer;

      write_attachment [1].selector := fsc$access_and_share_modes;
      write_attachment [1].access_modes.selector := fsc$specific_access_modes;
      write_attachment [1].access_modes.value := $fst$file_access_options
            [fsc$read, fsc$shorten, fsc$append, fsc$modify];
      write_attachment [1].share_modes.selector := fsc$determine_from_access_modes;
      write_attachment [2].selector := fsc$create_file;
      write_attachment [2].create_file := TRUE;

      attribute [1].selector := fsc$file_contents_and_processor;
      attribute [1].file_contents := fsc$object_library;
      attribute [1].file_processor := fsc$unknown_processor;

      fsp$open_file (target_file, amc$segment, ^write_attachment, ^attribute, NIL, NIL, NIL, target_fid,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (target_fid, amc$sequence_pointer, target_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      pmp$get_unique_name (first_temp_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fsp$open_file (first_temp_file, amc$segment, ^write_attachment, NIL, NIL, NIL, NIL, first_temp_fid,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      first_temp_file_open := TRUE;

      amp$get_segment_pointer (first_temp_fid, amc$sequence_pointer, first_temp_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      RESET metapatch;
      NEXT metapatch_header IN metapatch;
      IF metapatch_header = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment, 'METAPATCH', status);
        EXIT /main/;
      IFEND;

      old_checksum := ocp$checksum (base_object_library.sequence_pointer);

      IF old_checksum <> metapatch_header^.old_checksum THEN
        osp$set_status_abnormal ('RA', rae$corr_base_checksum_mismatch, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, base_file, status);
        EXIT /main/;
      IFEND;

      IF metapatch_header^.predictor_size > 0 THEN
        predictor := #PTR (metapatch_header^.predictor, metapatch^);
        RESET metapatch TO predictor;
        NEXT predictor: [[REP metapatch_header^.predictor_size OF cell]] IN metapatch;
        IF predictor = NIL THEN
          osp$set_status_abnormal ('RA', rae$accessed_beyond_segment, 'METAPATCH', status);
          RETURN;
        IFEND;

        ocp$build_first_intermediate_ol (predictor, base_object_library.sequence_pointer,
              first_temp_object_library.sequence_pointer, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
      ELSE
        qcp$copy (base_object_library.sequence_pointer, first_temp_object_library.sequence_pointer, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
      IFEND;

      pmp$get_unique_name (second_temp_file, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      fsp$open_file (second_temp_file, amc$segment, ^write_attachment, NIL, NIL, NIL, NIL, second_temp_fid,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      second_temp_file_open := TRUE;

      amp$get_segment_pointer (second_temp_fid, amc$sequence_pointer, second_temp_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF metapatch_header^.number_of_move_items > 0 THEN
        move_items := #PTR (metapatch_header^.move_items, metapatch^);
        RESET metapatch TO move_items;
        NEXT move_items: [1 .. metapatch_header^.number_of_move_items] IN metapatch;
        IF move_items = NIL THEN
          osp$set_status_abnormal ('RA', rae$accessed_beyond_segment, 'METAPATCH', status);
          EXIT /main/;
        IFEND;

        ocp$apply_move_items (first_temp_object_library.sequence_pointer, move_items,
              metapatch_header^.number_of_move_items, second_temp_object_library.sequence_pointer);
      ELSE
        qcp$copy (first_temp_object_library.sequence_pointer, second_temp_object_library.sequence_pointer,
              status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
      IFEND;

      IF metapatch_header^.corrector_size > 0 THEN
        corrector := #PTR (metapatch_header^.corrector, metapatch^);
        RESET metapatch TO corrector;
        NEXT corrector: [[REP metapatch_header^.corrector_size OF cell]] IN metapatch;
        IF corrector = NIL THEN
          osp$set_status_abnormal ('RA', rae$accessed_beyond_segment, 'METAPATCH', status);
          EXIT /main/;
        IFEND;

        ocp$apply_corrector (corrector, second_temp_object_library.sequence_pointer,
              target_object_library.sequence_pointer);
      ELSE
        qcp$copy (second_temp_object_library.sequence_pointer, target_object_library.sequence_pointer,
              status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
      IFEND;

      amp$set_segment_eoi (target_fid, target_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      fsp$close_file (target_fid, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      target_file_open := FALSE;

      qcp$open_file (^target_file, amc$segment, fsc$read, FALSE, NIL, target_fid, target_file_open, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (target_fid, amc$sequence_pointer, target_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      new_checksum := ocp$checksum (target_object_library.sequence_pointer);
      IF new_checksum <> metapatch_header^.new_checksum THEN
        osp$set_status_abnormal ('QC', rae$error_in_object_library, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, correction_file, status);
        osp$append_status_file (osc$status_parameter_delimiter, base_file, status);
        EXIT /main/;
      IFEND;

    END /main/;

    IF base_file_open THEN
      fsp$close_file (base_fid, local_status);
      base_file_open := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF target_file_open THEN
      fsp$close_file (target_fid, local_status);
      target_file_open := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF correction_file_open THEN
      fsp$close_file (correction_fid, local_status);
      correction_file_open := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF first_temp_file_open THEN
      fsp$close_file (first_temp_fid, local_status);
      first_temp_file_open := FALSE;
      amp$return(first_temp_file, ignore_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF second_temp_file_open THEN
      fsp$close_file (second_temp_fid, local_status);
      second_temp_file_open := FALSE;
      amp$return(second_temp_file, ignore_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

   osp$disestablish_cond_handler;

  PROCEND qcp$apply_object_correction;
?? OLDTITLE ??
MODEND qcm$apply_object_correction;
*DECK DECK=QCM$BACK_DS_CATALOG EXPAND=TRUE

PROCEDURE qcp$back_ds_catalog (
 output, o: file = $output
  status)

      VAR
        qcv$system: (XDCL) file = $SYSTEM
      VAREND



IF $file($value(output) open_position) = '$BOI' THEN
   ofile = $string($value(output)) //'.$ASIS'
ELSE
   ofile = $string($value(output))
IFEND

  "$FORMAT=OFF"
  VAR
    name_sou_library: name = sou_library
    name_builtin_library: name = builtin_library
    name_dcfile: name = dcfile
    name_deadstart_catalog: name = deadstart_catalog
    name_deadstart_commands_catalog: name = deadstart_commands
    name_jt_link_map: name = job_template_link_map
    name_link_input_catalog: name = link_input_files
    name_link_output_catalog: name = link_output_files
    name_mf_config_catalog: name = mf_config_files
    name_mf_config_files: name = mf_config_files
    name_non_boot_drivers_catalog: name = non_boot_drivers
    name_non_boot_drivers_file: name = non_boot_drivers
    name_nosve_maintenance_catalog: name = nosve_maintenance
    name_os_version_file: name = os_version
    name_osf$builtin_library: name = osf$builtin_library
    name_osf$sou_library: name = osf$sou_library
    name_physical_config: name = physical_config
    name_physical_configuration: name = physical_configuration
    name_product_files_catalog: name = product_files
    name_prolog_file: name = prolog_file
    name_prolog_library: name = prolog_library
    name_sc_link_map: name = system_core_link_map
    name_site_maintenance_catalog: name = site_os_maintenance
    name_system_debug_table: name = system_debug_table
  VAREND
  "$FORMAT=ON"

    crev backup_file k=string v='$user.bkff'
    crev qcu_catalog k=string v='$SYSTEM.QCU_MAINTENANCE'


  VAR
    bacpf_file: file = $local//$name($unique)
    command_file: file = $local//$name($unique)
    configuration_files_catalog: file
    ignore_status: status
    local_status: status

    name_qcu_maintenance_catalog: name = qcu_maintenance
    name_qcu_log_file: name = qcu_log
    name_qcu_field_maintenance: name = field_maintenance
    name_qcu_state: name = site_modifications
    name_os_version: name = os_version
    name_deadstart_commands: name = deadstart_commands

    new_sou_library: file
    new_builtin_library: file
    new_deadstart_catalog: file
    new_link_output_catalog: file
    new_non_boot_drivers_file: file
    new_version_catalog: file

    nosve_sou_library: file
    nosve_builtin_library: file
    nosve_deadstart_catalog: file
    nosve_link_input_catalog: file
    nosve_maintenance_catalog: file
    nosve_non_boot_drivers_file: file
    nosve_version_file: file

    qcu_maintenance_catalog: file
    qcu_link_input_catalog: file
    qcu_log_file: file
    qcu_state_file: file
    qcu_field_maintenance_catalog: file
    qcu_version_file: file

    site_sou_library: file
    site_builtin_library: file
    site_maintenance_catalog: file
    site_non_boot_drivers_catalog: file

    system_level: name
    text: string
  VAREND
  "$FORMAT=ON"

     IF NOT $file($fname(qcu_catalog),catalog) THEN
      crec $fname(qcu_catalog)
     IFEND

  putl ' '
  putl '     Collect System Materials'
  putl ' '

 delc $system.qcu_maintenance.link_input_files do=cac status=ignore_status
 BACPF BF=$fname(backup_file)
 BACC $SYSTEM.NOSVE_MAINTENANCE.LINK_INPUT_FILES
 QUIT

 RESPF l=$null
 RESC $SYSTEM.NOSVE_MAINTENANCE.LINK_INPUT_FILES BF=$fname(backup_file) ..
     NCN=$SYSTEM.QCU_MAINTENANCE.LINK_INPUT_FILES
 QUIT
 delf $fname(backup_file) status=ignore_status

main_block: ..
  BLOCK



    nosve_maintenance_catalog = qcv$system//name_nosve_maintenance_catalog
    nosve_deadstart_catalog = nosve_maintenance_catalog//name_deadstart_catalog
    nosve_non_boot_drivers_file = nosve_deadstart_catalog//name_non_boot_drivers_file
    nosve_builtin_library = nosve_deadstart_catalog//name_product_files_catalog//name_builtin_library
    nosve_sou_library = nosve_deadstart_catalog//name_product_files_catalog//name_sou_library
    nosve_link_input_catalog = nosve_maintenance_catalog//name_link_input_catalog

    qcu_field_maintenance_catalog = qcv$system//name_qcu_field_maintenance
    qcu_log_file = qcu_field_maintenance_catalog//name_qcu_log_file
    qcu_state_file = qcu_field_maintenance_catalog//name_qcu_state
    qcu_maintenance_catalog = qcv$system//name_qcu_maintenance_catalog
    qcu_link_input_catalog = qcu_maintenance_catalog//name_link_input_catalog
    qcu_version_file = qcu_link_input_catalog//name_os_version

     IF NOT $file(qcu_maintenance_catalog,catalog) THEN
       $system.put_line ' ' o=$fname(ofile//'.$eoi')
       $system.put_line '                        STOP' o=$fname(ofile//'.$eoi')
       $system.put_line '          Material necessary for the generation of ' o=$fname(ofile//'.$eoi')
       $system.put_line '          a new correction system is not available.'   o=$fname(ofile//'.$eoi')
       $system.put_line '          You must issue a INSTALL_FIELD_CORRECTION'     o=$fname(ofile//'.$eoi')
       $system.put_line '          request before attempting to generate a'  o=$fname(ofile//'.$eoi')
       $system.put_line '          new correction system.'       o=$fname(ofile//'.$eoi')
       $system.put_line ' ' o=$fname(ofile//'.$eoi')
       delete_catalog qcu_field_maintenance_catalog cac status=ignore_status
       EXIT_PROC
     IFEND
     IF NOT $file(qcu_field_maintenance_catalog,catalog) THEN
       $system.put_line ' ' o=$fname(ofile//'.$eoi')
       $system.put_line '                        STOP' o=$fname(ofile//'.$eoi')
       $system.put_line '          Material necessary for the generation of ' o=$fname(ofile//'.$eoi')
       $system.put_line '          a new correction system is not available.'   o=$fname(ofile//'.$eoi')
       $system.put_line '          You must issue a INSTALL_FIELD_CORRECTION'     o=$fname(ofile//'.$eoi')
       $system.put_line '          request before attempting to generate a'  o=$fname(ofile//'.$eoi')
       $system.put_line '          new correction system.'       o=$fname(ofile//'.$eoi')
       $system.put_line ' ' o=$fname(ofile//'.$eoi')
       EXIT_PROC
     IFEND

    $system.delete_file f=qcu_state_file status=ignore_status
    get_correction_level ovf=qcu_version_file sl=system_level status=local_status
    EXIT main_block WHEN NOT local_status.normal

    site_maintenance_catalog = qcv$system//name_site_maintenance_catalog
    site_non_boot_drivers_catalog = site_maintenance_catalog//name_non_boot_drivers_catalog
    site_builtin_library = site_maintenance_catalog//name_osf$builtin_library
    site_sou_library = site_maintenance_catalog//name_osf$sou_library

    configuration_files_catalog = site_maintenance_catalog//name_deadstart_commands
    new_version_catalog = qcu_maintenance_catalog//system_level
    new_deadstart_catalog = new_version_catalog//name_deadstart_catalog
    new_link_output_catalog = new_version_catalog//name_link_output_catalog
    new_non_boot_drivers_file = new_deadstart_catalog//name_non_boot_drivers_file
    new_builtin_library = new_deadstart_catalog//name_product_files_catalog//name_builtin_library
    new_sou_library = new_deadstart_catalog//name_product_files_catalog//name_sou_library



  build_dc_block: ..
    BLOCK

      $system.delete_file qcu_log_file status=ignore_status

" initialize the new deadstart catalog - delete the old, create the new.

      $system.delete_catalog c=new_version_catalog do=catalog_and_contents status=ignore_status
COLLECT_TEXT o=command_file until='**' sm='?'
      $system.create_catalog c=new_version_catalog
      $system.create_catalog c=new_deadstart_catalog
      $system.create_catalog c=new_link_output_catalog
**
      $system.include_file f=command_file status=local_status
      $system.delete_file f=command_file status=ignore_status
      EXIT build_dc_block WHEN NOT local_status.normal

      $system.put_line ' ' o=$fname(ofile//'.$eoi')
      $system.put_line '     Begin Backup to the Base System' o=$fname(ofile//'.$eoi')
      $system.put_line '              Deadstart Catalog Path is ...' o=qcu_log_file.$EOI
      $system.put_line '      '//$string(new_deadstart_catalog) o=qcu_log_file.$EOI
      $system.put_line ' ' o=qcu_log_file.$EOI


" Move the deadstart catalog from nosve_maintenance to
" qcu_maintenance to use as a base for the new system.

COLLECT_TEXT o=command_file until='**'
  $system.BACKUP_PERMANENT_FILE bf=bacpf_file
    backup_catalog c=nosve_deadstart_catalog
    quit
  $system.RESTORE_PERMANENT_FILE l=$null
    restore_existing_catalog c=nosve_deadstart_catalog ..
                             ncn=new_deadstart_catalog ..
                             bf=bacpf_file
    quit
  $system.BACKUP_PERMANENT_FILE bf=$null
    exclude_highest_cycle number_of_cycles=1
    delete_catalog_content c=new_deadstart_catalog
    quit

**
      $system.include_file f=command_file status=local_status
      $system.delete_file f=command_file status=ignore_status
      $system.delete_file f=bacpf_file status=ignore_status
      EXIT build_dc_block WHEN NOT local_status.normal




"   If there are local changes to the sites builtin_library then
"   combine the site-specified version of the file with the
"   system released version of the file and put the result in
"   the file new_builtin_library.


  IF $file(site_builtin_library permanent) THEN
    $system.put_line ' '
    $system.put_line '      Combining the sites BUILTIN_LIBRARY' o=$fname(ofile//'.$eoi')
    $system.put_line '                               with' o=$fname(ofile//'.$eoi')
    $system.put_line '              the systems BUILTIN_LIBRARY' o=$fname(ofile//'.$eoi')

    $system.put_line 'BUILTIN_LIBRARY'   o=qcu_state_file.$eoi  status=ignore_status

COLLECT_TEXT o=command_file until='**'
  $system.CREATE_OBJECT_LIBRARY
    add_modules l=nosve_builtin_library
    combine_modules l=site_builtin_library
    generate_library l=new_builtin_library
  QUIT
**
    $system.include_file command_file status=local_status
    $system.delete_file command_file status=ignore_status

  IFEND

"   If there are local changes to the sites sou_library then
"   combine the site-specified version of the file with the
"   system released version of the file and put the result in
"   the file new_sou_library.


  IF $file(site_sou_library permanent) THEN
    $system.put_line ' '
    $system.put_line '      Combining the sites SOU_LIBRARY' o=$fname(ofile//'.$eoi')
    $system.put_line '                               with' o=$fname(ofile//'.$eoi')
    $system.put_line '              the systems SOU_LIBRARY' o=$fname(ofile//'.$eoi')

    $system.put_line 'SOU_LIBRARY'   o=qcu_state_file.$eoi  status=ignore_status

COLLECT_TEXT o=command_file until='**'
  $system.CREATE_OBJECT_LIBRARY
    add_modules l=nosve_sou_library
    combine_modules l=site_sou_library
    generate_library l=new_sou_library
  QUIT
**
    $system.include_file command_file status=local_status
    $system.delete_file command_file status=ignore_status

  IFEND


      copy_configuration configuration_files_catalog=configuration_files_catalog ..
            deadstart_catalog=new_deadstart_catalog status=local_status
      EXIT build_dc_block WHEN NOT local_status.normal
       putl ' '
       putl '     Begin Generation of the Base System'
       putl ' '

      $system.put_line '    Begin link of OS files    ' o=qcu_log_file.$EOI

      link_generated_qcu ..
            nlic=qcu_link_input_catalog slic=site_maintenance_catalog ..
            dc=new_deadstart_catalog loc=new_link_output_catalog ..
            output=$value(output) status=local_status
      EXIT build_dc_block WHEN NOT local_status.normal

      $system.put_line ' Completed link of OS files ' o=qcu_log_file.$eoi



      combine_drivers nnbdf=nosve_non_boot_drivers_file ..
            snbdc=site_non_boot_drivers_catalog ..
            nbdf=new_non_boot_drivers_file status=local_status
      EXIT build_dc_block WHEN NOT local_status.normal
      $system.put_line ' Completed driver combine' o=qcu_log_file.$eoi

      $system.put_line '     End Generation of the Corrected System' o=output
      $system.put_line '                  the ' o=output
      $system.put_line '     New deadstart catalog path is ..' o=output
      $system.put_line '        '//$string(new_deadstart_catalog)  o=output
      $system.put_line ' ' o=output
    BLOCKEND build_dc_block

  BLOCKEND main_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal
  $system.put_line 'Normal completion from back_cs' o=qcu_log_file.$eoi

  qcp$establish_backup_catalog  new_deadstart_catalog  status

  $system.put_line 'Return from backup catalog ' o=qcu_log_file.$eoi


PROCEND qcp$back_ds_catalog
*DECK DECK=QCM$BASE_PRODUCT_TABLE EXPAND=TRUE

create_variable name=product_table_input kind=string value=$unique
collect_text output=$fname(product_table_input) until='///end product table///' substitution_mark='?'
*copyc qci$nosve_maintenance
///end product table///

include_file file=$fname(product_table_input)
delete_file file=$fname(product_table_input)
*DECK DECK=QCM$BCU_HELPER_JT223 EXPAND=TRUE

MODULE qcm$bcu_helper_jt223;

{ This is a dummy module that will be modified and compiled at each
{ BCU level to ensure that the library associated with this deck is
{ rebuilt.
{
{ This is for level L826AA

MODEND qcm$bcu_helper_jt223;
*DECK DECK=QCM$BCU_HELPER_JT236 EXPAND=TRUE

MODULE qcm$bcu_helper_jt236;

{ This is a dummy module that will be modified and compiled at each
{ BCU level to ensure that the library associated with this deck is
{ rebuilt.
{
{ This is for level L826AA

MODEND qcm$bcu_helper_jt236;
*DECK DECK=QCM$BCU_HELPER_JT23D EXPAND=TRUE

MODULE qcm$bcu_helper_jt23d;

{ This is a dummy module that will be modified and compiled at each
{ BCU level to ensure that the library associated with this deck is
{ rebuilt.
{
{ This is for level L826AA

MODEND qcm$bcu_helper_jt23d;
*DECK DECK=QCM$BCU_HELPER_JT2DD EXPAND=TRUE

MODULE qcm$bcu_helper_jt2dd;

{ This is a dummy module that will be modified and compiled at each
{ BCU level to ensure that the library associated with this deck is
{ rebuilt.
{
{ This is for level L826AA

MODEND qcm$bcu_helper_jt2dd;
*DECK DECK=QCM$BCU_HELPER_MONITOR EXPAND=TRUE

MODULE qcm$bcu_helper_monitor;

{ This is a dummy module that will be modified and compiled at each
{ BCU level to ensure that the library associated with this deck is
{ rebuilt.
{
{ This is for level L826AA

MODEND qcm$bcu_helper_monitor;
*DECK DECK=QCM$BCU_HELPER_SC113 EXPAND=TRUE

MODULE qcm$bcu_helper_sc113;

{ This is a dummy module that will be modified and compiled at each
{ BCU level to ensure that the library associated with this deck is
{ rebuilt.
{
{ This is for level L826AA

MODEND qcm$bcu_helper_sc113;
*DECK DECK=QCM$BCU_HELPER_SC133 EXPAND=TRUE

MODULE qcm$bcu_helper_sc133;

{ This is a dummy module that will be modified and compiled at each
{ BCU level to ensure that the library associated with this deck is
{ rebuilt.
{
{ This is for level L826AA

MODEND qcm$bcu_helper_sc133;
*DECK DECK=QCM$BCU_HELPER_SC13D EXPAND=TRUE

MODULE qcm$bcu_helper_sc13d;

{ This is a dummy module that will be modified and compiled at each
{ BCU level to ensure that the library associated with this deck is
{ rebuilt.
{
{ This is for level L826AA

MODEND qcm$bcu_helper_sc13d;
*DECK DECK=QCM$BCU_HELPER_SC1DD EXPAND=TRUE

MODULE qcm$bcu_helper_sc1dd;

{ This is a dummy module that will be modified and compiled at each
{ BCU level to ensure that the library associated with this deck is
{ rebuilt.
{
{ This is for level L826AA

MODEND qcm$bcu_helper_sc1dd;
*DECK DECK=QCM$BUILD_SCORE_HEADER EXPAND=TRUE
PROC qcp$build_score_header


crev work k=string
crev msg  k=string
crev ignore k=status

crev hh_path k=string v=':$SYSTEM.$SYSTEM.FIELD_MAINTENANCE.HISTORY_HEADER'
crev lh_path k=string v=':$SYSTEM.$SYSTEM.FIELD_MAINTENANCE.LIBRARY_HEADER'



IF NOT $file($fname(hh_path),permanent) THEN
 create_file $fname(hh_path) status=ignore
 msg = 'Correction    Sys      Installed       Based '
 put_line msg o=$fname(hh_path//'.$eoi') status=ignore
 msg = '  Ident      Ident       Over            On         Date'
 msg = msg//'      Time      Active '
 put_line msg o=$fname(hh_path//'.$eoi') status=ignore
 msg = '........................................................'
 msg = msg//'.......................'
 put_line msg o=$fname(hh_path//'.$eoi') status=ignore
IFEND

IF NOT $file($fname(lh_path),permanent) THEN
 create_file $fname(lh_path) status=ignore
 msg = '                  Libraries                           '
 msg = msg//'    Site    '
 putl msg o=$fname(lh_path//'.$eoi') status=ignore
 msg = '                  Modified                            '
 msg = msg//'  Modified    '
 putl msg o=$fname(lh_path//'.$eoi') status=ignore
 msg = '.............................................     .....'
 msg = msg//'................'
 putl msg o=$fname(lh_path//'.$eoi') status=ignore
IFEND


detach_file $fname(hh_path) status=ignore
detach_file $fname(lh_path) status=ignore

PROCEND qcp$build_score_header
*DECK DECK=QCM$BUILD_TASK_LIB EXPAND=TRUE

PROC qcm$build_task_lib, build_task_lib, buitll (
  preserved_file_path, pfp: file = $required
  cybil_run_time_library, crtl: file = $required
  delete_modules, dm: file = $local.$null
  status)


IF $variable(wev$build_level, declared) <> 'LOCAL' THEN
  IF $variable(wev$build_level, declared) <> 'UNKNOWN' THEN
    create_variable wev$build_level kind=string scope=xref
  ELSE
    create_variable wev$build_level kind=string scope=xdcl value='NONE'
  IFEND
IFEND
IF $variable(wev$feature_catalog, declared) <> 'LOCAL' THEN
  IF $variable(wev$feature_catalog, declared) <> 'UNKNOWN' THEN
    create_variable wev$feature_catalog k=string scope=xref
  ELSE
    create_variable wev$feature_catalog k=string s=xdcl v='NONE'
  IFEND
IFEND
IF $variable(wev$feature_build_level, declared) <> 'LOCAL' THEN
  IF $variable(wev$feature_build_level, declared) <> 'UNKNOWN' THEN
    create_variable wev$feature_build_level k=string scope=xref
  ELSE
    create_variable wev$feature_build_level k=string s=xdcl v='OBJECT'
  IFEND
IFEND
IF $variable(wev$working_catalog, declared) <> 'LOCAL' THEN
  IF $variable(wev$working_catalog, declared) <> 'UNKNOWN' THEN
    create_variable wev$working_catalog k=string scope=xref
  ELSE
    create_variable wev$working_catalog k=string s=xdcl v='NONE'
  IFEND
IFEND
IF $variable(wev$working_build_level, declared) <> 'LOCAL' THEN
  IF $variable(wev$working_build_level, declared) <> 'UNKNOWN' THEN
    create_variable wev$working_build_level k=string scope=xref
  ELSE
    create_variable wev$working_build_level k=string s=xdcl v='OBJECT'
  IFEND
IFEND


  create_variable wev$product_name k=string s=xdcl value='OS'

  create_variable (ignore_status, local_status) kind=status
  create_variable tasks_library kind=string value='$LOCAL.'//$unique
  create_variable no_libraries_merged k=boolean

  create_variable result_library k=string value=$string($value(preserved_file_path))//'.tasks'

build_task_lib: ..
  BLOCK

    combine_objects object_library=osf$tasks rol=$fname(tasks_library) nlm=no_libraries_merged ..
          oml=cyf$run_time_library dm=$value(delete_modules) status=local_status

    EXIT build_task_lib WHEN NOT local_status.normal

    EXIT build_task_lib WHEN no_libraries_merged

    delete_file $fname(result_library) status=ignore_status
    CREATE_OBJECT_LIBRARY status=local_status
      add_module $fname(tasks_library)
      satisfy_external_references l=$value(cybil_run_time_library)
      omit_library lto=cyf$run_time_library
      generate_library $fname(result_library)
    QUIT

  BLOCKEND build_task_lib

  detach_file $fname(tasks_library) status=ignore_status
  IF $file($fname(result_library), permanent) THEN
    detach_file $fname(result_library) status=ignore_status
  IFEND

  EXIT_PROC WITH local_status

PROCEND qcm$build_task_lib

*DECK DECK=QCM$COMBINE_DRIVERS EXPAND=TRUE
PROCEDURE qcp$combine_drivers (
  nosve_non_boot_drivers_file, nnbdf: file = $required
  site_non_boot_drivers_catalog, snbdc: file = $required
  non_boot_drivers_file, nbdf: file = $required
  status)

"
"   The purpose of this request is to combine PP routines
"supplied by the site with the released version of the
"non_boot_drivers (specified by the first parameter).
"A catalog may optionally exist containing site-supplied PP
"routines.  If so, they are combined with the release version and
"placed on the non_boot_drivers_file.  If the site_non_boot_drivers
"catalog does not exist, this routine returns with a normal status.
"



  VAR
    command_file: file = $local//$name($unique)
    format_status: status
    formatted_count: integer = 0
    formatted_pp: file = $local//$name($unique)
    ignore_status: status
    local_status: status
    pp_add_status: status
    pp_count: integer = 0
    pp_status: status
    scratch_file: file = $local//$name($unique)
    site_pp: string
  VAREND


build_block: ..
  BLOCK

    list_catalog c=site_non_boot_drivers_catalog fl=scratch_file ..
          d=1 fc=pp_count status=pp_status

    IF (NOT pp_status.normal) OR (pp_status.normal AND (pp_count = 0)) THEN
      EXIT build_block
    IFEND

    $system.put_line ' Builing new non_boot_drivers file ...' o=$response

    VAR
      pp_files: array 1 .. pp_count of string
    VAREND

    $system.accept_line v=pp_files i=scratch_file status=local_status
    $system.detach_file scratch_file status=ignore_status
    EXIT build_block WHEN NOT local_status.normal

COLLECT_TEXT o=command_file until='END FORMAT COLLECT' sm='?' status=local_status
    manage_deadstart_files
      create_binary_formatted_file
        add_record i=nosve_non_boot_drivers_file f=NVE_FILE
        FOR i = 1 TO pp_count DO
          site_pp = $path($fname(pp_files(i)), last)
          $system.include_line 'format_binary_record i=$fname(pp_files(i)) o=formatted_pp f=CIP_PERIPHERAL_PROCESSOR' ..
             status=format_status
          IF format_status.normal THEN
            formatted_count = formatted_count + 1
            $system.include_line 'add_record i=formatted_pp f=NVE_FILE' status=pp_add_status
            IF NOT pp_add_status.normal THEN
              $system.put_line $strrep($status(FALSE, 'RA', rae$unable_to_add_formatted_pp, pp_files(i)) o=$response
            IFEND
            $system.delete_file f=formatted_pp status=ignore_status
          ELSE
            $system.put_line $strrep($status(FALSE, 'RA', rae$unable_to_format_pp, site_pp)) o=$response
          IFEND
        FOREND
        generate_file o=non_boot_drivers_file ff=NVE_FILE
      quit
    quit
END FORMAT COLLECT


    $system.include_file f=command_file status=local_status
    $system.delete_file f=command_file status=ignore_status
    EXIT build_block WHEN NOT local_status.normal

    IF NOT (pp_count = formatted_count) THEN
      text = 'PP catalog ' // $string(site_non_boot_drivers_catalog)
      local_status = $status(false, 'RA', rae$not_all_files_processed, text)
    IFEND
    EXIT build_block WHEN NOT local_status.normal

  BLOCKEND build_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND qcp$combine_drivers
*DECK DECK=QCM$COMBINE_OBJECTS EXPAND=TRUE


PROC qcm$combine_objects, combine_objects  (
  delete_modules, dm         : file = $local.$null
  object_library, ol         : name = $required
  result_object_library, rol : file = $required
  omit_library, oml          : name or key none = none
  no_libraries_merged, nlm   : var of boolean = $optional
  status                     : var of status = $optional
  )


IF NOT $variable(wev$default_file_server defined) THEN
  VAR
    wev$default_file_server : (ENVIRONMENT) string
  VAREND
  check_default_file_server
IFEND
IF NOT $variable(wev$default_dev_base_family defined) THEN
  VAR
    wev$default_dev_base_family : (ENVIRONMENT) string
  VAREND
  set_environment_defaults
IFEND
VAR
  development_base : file = wev$development_base, $fname(wev$default_dev_base_family//'.INTVE')
  wev$development_base : (ENVIRONMENT) string = $string(development_base)
  server_development_base : file = wev$server_development_base, $fname($string(wev$default_file_server)//..
$trim($substr(wev$development_base, $scan_string('.', wev$development_base), $strlen(wev$development_base))))
  wev$server_development_base : (ENVIRONMENT) string = $string(server_development_base)
VAREND
IF $variable(wev$product_name, declared) <> 'LOCAL' THEN
  IF $variable(wev$product_name, declared) <> 'UNKNOWN' THEN
    create_variable wev$product_name k=string scope=xref
  ELSE
    create_variable wev$product_name k=string s=xdcl v='OS'
  IFEND
IFEND
IF $variable(wev$build_level, declared) <> 'LOCAL' THEN
  IF $variable(wev$build_level, declared) <> 'UNKNOWN' THEN
    create_variable wev$build_level kind=string scope=xref
  ELSE
    create_variable wev$build_level kind=string scope=xdcl value='NONE'
  IFEND
IFEND
IF $variable(wev$feature_catalog, declared) <> 'LOCAL' THEN
  IF $variable(wev$feature_catalog, declared) <> 'UNKNOWN' THEN
    create_variable wev$feature_catalog k=string scope=xref
  ELSE
    create_variable wev$feature_catalog k=string s=xdcl v='NONE'
  IFEND
IFEND
IF $variable(wev$feature_build_level, declared) <> 'LOCAL' THEN
  IF $variable(wev$feature_build_level, declared) <> 'UNKNOWN' THEN
    create_variable wev$feature_build_level k=string scope=xref
  ELSE
    create_variable wev$feature_build_level k=string s=xdcl v='OBJECT'
  IFEND
IFEND
IF $variable(wev$working_catalog, declared) <> 'LOCAL' THEN
  IF $variable(wev$working_catalog, declared) <> 'UNKNOWN' THEN
    create_variable wev$working_catalog k=string scope=xref
  ELSE
    create_variable wev$working_catalog k=string s=xdcl v='NONE'
  IFEND
IFEND
IF $variable(wev$working_build_level, declared) <> 'LOCAL' THEN
  IF $variable(wev$working_build_level, declared) <> 'UNKNOWN' THEN
    create_variable wev$working_build_level k=string scope=xref
  ELSE
    create_variable wev$working_build_level k=string s=xdcl v='OBJECT'
  IFEND
IFEND

  create_variable local_status kind=status
  create_variable ignore_status kind=status
  create_variable file_connection_deleted kind=status
  create_variable path_status kind=status
  create_variable object_library kind=string value=$string($value(object_library))
  create_variable bl_path kind=string value=wev$server_development_base//'.'//wev$product_name//'.'//wev$build_level
  create_variable bl_maint_path kind=string value=bl_path//'.MAINTENANCE'
  create_variable bl_file kind=string value=bl_maint_path//'.'//object_library
  create_variable wc_wbl_maint_path kind=string ..
        value=wev$working_catalog//'.'//wev$working_build_level//'.MAINTENANCE'
  create_variable wc_file kind=string value=wc_wbl_maint_path//'.'//object_library
  create_variable wc_file_exists kind=boolean value=false
  create_variable fc_fbl_maint_path kind=string ..
        value=wev$feature_catalog//'.'//wev$feature_build_level//'.MAINTENANCE'
  create_variable fc_file kind=string value=fc_fbl_maint_path//'.'//object_library
  create_variable fc_file_exists kind=boolean value=false
  create_variable possible_to_change_library kind=boolean
  create_variable delete_modules kind=boolean ..
        value=($path($value(delete_modules), last)<>'$NULL')

proc_block: ..
  BLOCK

    IF wev$feature_catalog <> 'NONE' THEN
      display_catalog c=$fname(fc_fbl_maint_path) do=permits o=$null status=path_status
      IF path_status.normal THEN
        IF $file($fname(fc_file), assigned) THEN
          detach_file $fname(fc_file) status=ignore_status
          fc_file_exists = true
        IFEND
      IFEND
    IFEND

    IF wev$working_catalog <> 'NONE' THEN
      display_catalog c=$fname(wc_wbl_maint_path) do=permits o=$null status=path_status
      IF path_status.normal THEN
        IF $file($fname(wc_file), assigned) THEN
          detach_file $fname(wc_file) status=ignore_status
          wc_file_exists = true
        IFEND
      IFEND
    IFEND

    possible_to_change_library = wc_file_exists OR fc_file_exists OR delete_modules
    IF NOT possible_to_change_library THEN
      EXIT proc_block
    IFEND

    CREATE_OBJECT_LIBRARY

    creol_block: ..
      BLOCK

      establish_base: ..
        BLOCK

          display_catalog c=$fname(bl_maint_path) do=permits o=$null status=path_status
          IF path_status.normal THEN
            IF $file($fname(bl_file), assigned) THEN
              add_modules library=$fname(bl_file) status=local_status
              EXIT creol_block WHEN NOT local_status.normal
              EXIT establish_base
            IFEND
          IFEND
          display_catalog c=$fname(bl_path) do=permits o=$null status=path_status
          IF path_status.normal THEN
            bl_file = bl_path // '.' // object_library
            IF $file($fname(bl_file), assigned) THEN
              add_modules library=$fname(bl_file) status=local_status
              EXIT creol_block WHEN NOT local_status.normal
              EXIT establish_base
            IFEND
          IFEND
          local_status = $status(false, 'WE', wee$missing_object_library, object_library, bl_path, bl_maint_path)
          EXIT creol_block
        BLOCKEND establish_base

        put_line ' Combining libraries onto '//$string($value(result_object_library))//'    From:' ..
              o=$response status=ignore_status
        put_line '        '//bl_file o=$response status=ignore_status


        delete_file_connection sf=$local.$errors file=$local.output status=file_connection_deleted

        IF delete_modules THEN
          include_file $value(delete_modules) status=local_status
          EXIT creol_block WHEN NOT local_status.normal
        IFEND

        IF fc_file_exists THEN
          combine_modules library=$fname(fc_file) status=local_status
          EXIT creol_block WHEN NOT local_status.normal
          put_line '        '//fc_file o=$response status=ignore_status
        IFEND

        IF wc_file_exists THEN
          combine_modules library=$fname(wc_file) status=local_status
          EXIT creol_block WHEN NOT local_status.normal
          put_line '        '//wc_file o=$response status=ignore_status
        IFEND

        IF $string($value(omit_library)) <> 'NONE' THEN
          change_module_attributes m=all ol=$value(omit_library) status=local_status
          EXIT creol_block WHEN NOT local_status.normal
        IFEND


        IF object_library = 'OSF$BOOT_MONITOR' THEN
          reorder_modules dsm$boot_interrupt_handler p=before status=ignore_status
        ELSEIF object_library = 'OSF$MONITOR' THEN
          reorder_modules mtm$monitor_interrupt_handler p=before status=ignore_status
        ELSEIF object_library = 'OSF$SYSTEM_CORE_113' THEN
          reorder_modules sym$job_fixed_template p=before status=ignore_status
        IFEND

        generate_library library=$value(result_object_library) status=local_status
        EXIT creol_block WHEN NOT local_status.normal

      BLOCKEND creol_block

      IF file_connection_deleted.normal THEN
        create_file_connection sf=$local.$errors file=$local.output status=ignore_status
      IFEND
    QUIT

    EXIT proc_block WHEN NOT local_status.normal

  BLOCKEND proc_block

  IF $specified(no_libraries_merged) THEN
    $value(no_libraries_merged) = NOT possible_to_change_library
  IFEND

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND qcm$combine_objects
*DECK DECK=QCM$COMMIT_BASE_SYSTEM EXPAND=TRUE
PROCEDURE qcp$commit_base_system (
  set_flag, sf: boolean = true
  status)

VAR
  local_status: status
VAREND




    dsp$commit_new_system set_flag status=local_status
   putl ''
   putl '      The next deadstart will reinstate the base system'
   putl ''



PROCEND qcp$commit_base_system

*DECK DECK=QCM$COMMIT_SYSTEM EXPAND=TRUE


PROCEDURE qcp$commit_system (
  set_flag, sf: boolean = true
  output, o: file = $output
  status)

VAR
  local_status: status
  ignore: status
VAREND


      IF $file($value(output) open_position) = '$BOI' THEN
        rewind_file $value(output) status=ignore
        ofile = $string($value(output))//'.$ASIS'
      ELSE
        ofile = $string($value(output))
      IFEND

  IF NOT $job(system) THEN
    putl '                   STOP ' o=$fname(ofile)
    putl '    The command COMMIT_CORRECTION_SYSTEM must' o=$fname(ofile)
    putl '    be initiated from a system job.'           o=$fname(ofile)
    putl ' '                                             o=$fname(ofile)
    EXIT_PROC
  IFEND


  crev qcu_base k=string v='$SYSTEM.QCU_MAINTENANCE'
  crev df_path  k=string v='$SYSTEM.QCU_MAINTENANCE.LINK_INPUT_FILES'
  crev qcu_id   k=string v='$SYSTEM.QCU_MAINTENANCE.IDENTIFICATION'
  crev work k=string
   accl work i=$fname(qcu_id)
    al = $size(work)
    qcu_base = qcu_base//'.'//$substr(work,1,al)

      IF NOT $file($fname(qcu_base),catalog) THEN
       putl '               STOP ' o=$fname(ofile//'.$eoi')
       putl '      It is necessary to invoke the commands' o=$fname(ofile//'.$eoi')
       putl '      Generate_Correction_System and Establish_' o=$fname(ofile//'.$eoi')
       putl '      Correction_System prior to calling'        o=$fname(ofile//'.$eoi')
       putl '      Commit_Correction_System.'                 o=$fname(ofile//'.$eoi')
       putl ' '                                               o=$fname(ofile//'.$eoi')
       EXIT_PROC
      IFEND

    dsp$commit_new_system set_flag status=local_status





PROCEND qcp$commit_system
*DECK DECK=QCM$CONVERT_CONFIGURATION EXPAND=TRUE
PROCEDURE (HIDDEN) qcp$convert_configuration (
  prolog_file, pf: file = $required
  new_prolog_library, npl: file = $required
  old_prolog_library, opl: file = $optional
  status)

"$FORMAT=OFF
VAR
ignore_status:status
new_library: file =new_prolog_library
VAREND

"$FORMAT=ON

COLLECT_TEXT $local.create_prolog_file until='end_crepf'
PROCEDURE (HIDDEN) cmp$create_prolog (
  prolog_name, pn: name = $name($mainframe(identifier))
  file, f: key
      (lcu_mainframe_subcommands, lms)
      (lcu_network_subcommands, lns)
      (pcu_subcommands, ps)
    keyend = $required
  until, u: string = '**'
  input, i: file = cmd$crep_input, $command
  output, o: file = cmd$crep_output,
    $system.site_os_maintenance.deadstart_commands.prolog_library
  output_format, of: key
      (command_library, cl)
      (source_library, sl)
    keyend = cmd$crep_output_format, command_library
  deck_prefix, dp: name 1..12 = cmd$crep_deck_prefix, none
  modification_name: name = cmd$crep_modification, $name($job(user))
  status)

"$format=off
var
   converted_prolog : file =$local.temp_prolog_file
   ignore_status :status
   key: name
   status: status
   work_file:file
varend

"$format=on

  IF prolog_name = none THEN
    EXIT_PROC WITH $status(false, 'US', 001, ..
          ' The name NONE is an unacceptable name for a prolog.')
  IFEND

  PUSH command_list
  create_command_list_entry $local status=ignore_status
  PUSH file_connections

COLLECT_TEXT converted_prolog sm='~' until='end of proc'
PROCEDURE ~prolog_name~ (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
end_prolog_file

PROCEND ~prolog_name~
end of proc

  delete_file $local.lcu_mainframe_subcommands status=ignore_status
  delete_file $local.lcu_network_subcommands status=ignore_status
  delete_file $local.pcu_subcommands status=ignore_status

  IF (output_format = command_library) OR (output_format = cl) THEN
    CREATE_OBJECT_LIBRARY
      delete_file_connection $errors $local.output status=ignore_status
      add_module m=prolog_name l=output status=status
      IF status.normal THEN
        generate_library format=scl_proc library=$local.cmf$crep_temp
        $local.cmf$crep_temp
      IFEND
    QUIT
  ELSE "source_library"
    deck = $name($string(deck_prefix)//$string(prolog_name))
    SOURCE_CODE_UTILITY
      use_library output status=status
      IF status.normal THEN
        IF $deck(deck) THEN
          extract_deck deck source=$local.cmf$crep_temp status=status
          IF status.normal THEN
            include_command '$local.cmf$crep_temp' status=ignore_status
          IFEND
        IFEND
      IFEND
    QUIT
  IFEND

  key = $name($string(file))
"$format=off
  IF $file($local//key, size) = 0 THEN
    work_file = $local//key
  ELSE
COLLECT_TEXT $output sm='?'
  FIle ?file? ignored - already defined in prolog ?prolog_name?.
**
    work_file = $null
  IFEND
"$format=on

  include_line ..
        'collect_text input=input output=work_file until='//$quote(until)

  EDIT_FILE converted_prolog p=$null o=$null
    create_variable status k=status
    locate_text 'COLLECT_TEXT $local.pcu_subcommands' status=status
    IF status.normal THEN
      read_file $local.pcu_subcommands p=after status=ignore_status
    IFEND

    locate_text 'COLLECT_TEXT $local.lcu_mainframe_subcommands' status=status
    IF status.normal THEN
      read_file $local.lcu_mainframe_subcommands p=after status=ignore_status
    IFEND

    locate_text 'COLLECT_TEXT $local.lcu_network_subcommands' status=status
    IF status.normal THEN
      read_file $local.lcu_network_subcommands p=after status=ignore_status
    IFEND
  QUIT

  IF (output_format = command_library) OR (output_format = cl) THEN
    CREATE_OBJECT_LIBRARY
      combine_module l=output status=ignore_status
      combine_module library=converted_prolog
      generate_library library=output
    QUIT
  ELSE "source_library"
    SOURCE_CODE_UTILITY
      IF $file(output, opened) THEN
        use_library output
      ELSE
        create_library result=output
      IFEND

      IF NOT $modification(modification_name) THEN
        create_modification modification_name status=ignore_status
      IFEND
      IF NOT $deck(deck) THEN
        create_deck deck=deck modification=modification_name
      IFEND
      EDIT_DECK deck=deck modification=modification_name p=$null o=$null
        delete_lines l=all status=ignore_status
        read_file file=converted_prolog p=b
      END
    QUIT
  IFEND

  delete_file converted_prolog status=ignore_status
  delete_file $local.lcu_mainframe_subcommands status=ignore_status
  delete_file $local.lcu_network_subcommands status=ignore_status
  delete_file $local.pcu_subcommands status=ignore_status
  delete_file $local.cmf$crep_temp status=ignore_status

PROCEND cmp$create_prolog
end_crepf

  delete_variable cmd$crep_input status=ignore_status
  create_default_variable name=cmd$crep_input default='$command_of_caller'

  delete_variable cmd$crep_output status=ignore_status
  create_default_variable name=cmd$crep_output default=$string(new_library)

  IF $specified(old_prolog_library) THEN
    CREATE_OBJECT_LIBRARY
      add_module old_prolog_library status=ignore_status
      combine_module new_library status=ignore_status
      generate_library new_library status=ignore_status
    QUIT
  IFEND

  include_file prolog_file

  delete_variable cmd$crep_input status=ignore_status
  delete_variable cmd$crep_output status=ignore_status

PROCEND qcp$convert_configuration
*DECK DECK=QCM$COPY EXPAND=TRUE
?? RIGHT := 110 ??
MODULE qcm$copy;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc mmp$set_access_selections
*copyc syp$advised_move_bytes
?? POP ??

  PROCEDURE [XDCL] qcp$copy (old_ol: ^SEQ ( * );
    VAR new_ol: ^SEQ ( * );
    VAR status: ost$status);

    VAR
      length: integer;

    length := #SIZE (old_ol^);
    mmp$set_access_selections (old_ol, mmc$as_sequential, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    mmp$set_access_selections (new_ol, mmc$as_sequential, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    syp$advised_move_bytes (old_ol, new_ol, length, status);

  PROCEND qcp$copy;
MODEND qcm$copy;

*DECK DECK=QCM$COPY_CONFIGURATION EXPAND=TRUE


PROCEDURE qcp$copy_configuration (
  configuration_files_catalog, cfc: file = $required
  deadstart_catalog, dc: file = $required
  status)

"
"   This procedure copies the files DCFILE, PROLOG_LIBRARY, and
"PHYSICAL_CONFIG from the configuration files catalog to their
"appropriate places in the deadstart catalog.  These files will
"only be copied if they exist.
"
putl ' '
putl '       Checking for presence of site configuration files.'

  VAR
    name_builtin_library: name = builtin_library
    name_osf$builtin_library: name = osf$builtin_library
    name_sou_library: name = sou_library
    name_osf$sou_library: name = osf$sou_library
    name_dcfile: name = dcfile
    name_deadstart_catalog: name = deadstart_catalog
    name_deadstart_commands_catalog: name = deadstart_commands
    name_jt_link_map: name = job_template_link_map
    name_link_input_catalog: name = link_input_files
    name_link_output_catalog: name = link_output_files
    name_mf_config_catalog: name = mf_config_files
    name_mf_config_files: name = mf_config_files
    name_non_boot_drivers_catalog: name = non_boot_drivers
    name_non_boot_drivers_file: name = non_boot_drivers
    name_nosve_maintenance_catalog: name = nosve_maintenance
    name_os_version_file: name = os_version
    name_physical_config: name = physical_config
    name_physical_configuration: name = physical_configuration
    name_product_files_catalog: name = product_files
    name_prolog_file: name = prolog_file
    name_prolog_library: name = prolog_library
    name_sc_link_map: name = system_core_link_map
    name_site_maintenance_catalog: name = site_os_maintenance
    name_system_debug_table: name = system_debug_table
  VAREND


  VAR
    command_file: file = $unique($local)
    ignore_status: status
    lcu_mainframe_subcommands: file = $unique($local)
    lcu_status: status
    local_status: status
    message: string

    new_dcfile: file
    new_lcu_mainframe_subcommands: file
    new_physical_config: file
    new_prolog_library: file

    old_prolog_file: file

    site_dcfile: file
    site_physical_config: file
    site_physical_configuration: file
    site_prolog_library: file
  VAREND

  site_dcfile = configuration_files_catalog//name_dcfile
  site_physical_config = configuration_files_catalog//name_physical_config
  site_physical_configuration = configuration_files_catalog//name_physical_configuration
  site_prolog_library = configuration_files_catalog//name_prolog_library

  new_dcfile = deadstart_catalog//name_dcfile
  new_lcu_mainframe_subcommands = deadstart_catalog//name_mf_config_files.LCU_MF_SUBCMDS
  new_physical_config = deadstart_catalog//name_mf_config_files//name_physical_config
  new_prolog_library = deadstart_catalog//name_mf_config_files//name_prolog_library

  old_prolog_file = configuration_files_catalog//name_prolog_file

copy_block: ..
  BLOCK

    IF $file(site_dcfile, permanent) THEN
      $system.copy_file site_dcfile new_dcfile status=local_status
      EXIT copy_block WHEN NOT local_status.normal
    IFEND

    IF ($file(site_physical_config, permanent)) OR ($file(site_physical_configuration, permanent)) THEN
      IF $file(site_physical_config, permanent) THEN
        $system.copy_file site_physical_config new_physical_config status=local_status
      ELSE
        $system.copy_file site_physical_configuration new_physical_config status=local_status
      IFEND
      EXIT copy_block WHEN NOT local_status.normal
    IFEND



    IF $file(site_prolog_library, permanent) THEN
      $system.copy_file site_prolog_library new_prolog_library status=local_status
      EXIT copy_block WHEN NOT local_status.normal


COLLECT_TEXT command_file until='**'
        $system.create_object_library
          add_module l=site_prolog_library
          generate_library l=lcu_mainframe_subcommands f=sp
          quit
        $system.delete_file f=$local.lcu_mainframe_subcommands status=ignore_status
        $system.delete_file f=$local.pcu_subcommands status=ignore_status
        $system.delete_file f=$local.lcu_network_subcommands status=ignore_status

        $system.include_command $strrep(lcu_mainframe_subcommands)

        $system.copy_file $local.lcu_mainframe_subcommands new_lcu_mainframe_subcommands
        $system.delete_file f=$local.lcu_mainframe_subcommands status=ignore_status
        $system.delete_file f=$local.pcu_subcommands status=ignore_status
        $system.delete_file f=$local.lcu_network_subcommands status=ignore_status
        $system.delete_file f=lcu_mainframe_subcommands status=ignore_status
**
      $system.include_file f=command_file status=lcu_status
      $system.delete_file f=command_file status=ignore_status
      IF NOT lcu_status.normal THEN
        put_line l= ' ' o=$response
        put_line l= '                          NOTICE' o=$response
        put_line l= '    Error while processing LCU_Mainframe_Subcommands file' o=$response
        put_line l='                    Skipping this file' o=$response
      IFEND
    IFEND

  BLOCKEND copy_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal


PROCEND qcp$copy_configuration

*DECK DECK=QCM$CORRECT_V_FILES EXPAND=TRUE

?? RIGHT := 110 ??
?? NEWTITLE := '  qcm$correct_v_file' , EJECT ??
MODULE qcm$correct_v_file;

{ Purpose:  This module contains the necessary code to correct
{           a file with a bad end-of-information.


*copyc amp$close
*copyc amp$get_next
*copyc amp$open
*copyc amp$put_next
*copyc amp$skip
*copyc clp$get_value
*copyc clp$scan_parameter_list


?? TITLE := '    qcp$correct_v_file', EJECT ??

  PROCEDURE [XDCL] qcp$correct_v_file (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{ PDT fix_eoi_pdt (
{       file, f : file = $REQUIRED
{       status)

?? PUSH (LISTEXT := ON) ??

  VAR
    fix_eoi_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^fix_eoi_pdt_names,
      ^fix_eoi_pdt_params];

  VAR
    fix_eoi_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['FILE', 1], ['F', 1], ['STATUS', 2]];

  VAR
    fix_eoi_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ FILE F }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    CONST
      working_storage_area_size = 100000;

    VAR
      value: clt$value,
      working_storage_area: ^ SEQ ( * ),
      access_selections: amt$file_access_selections,
      transfer_count: amt$transfer_count,
      byte_address: amt$file_byte_address,
      file_position: amt$file_position,
      file_identifier: amt$file_identifier,
      ignore_status: ost$status;

    status.normal := true;
    ignore_status.normal := true;

    clp$scan_parameter_list (parameter_list, fix_eoi_pdt, status);
    if not status.normal then
      return;
    ifend;

    clp$get_value ('FILE', 1, 1, clc$low, value, status);
    if not status.normal then
      return;
    ifend;

    push working_storage_area: [[rep working_storage_area_size of cell]];

    push access_selections: [1 .. 2];
    access_selections^[1].key := amc$access_mode;
    access_selections^[1].access_mode := $pft$usage_selections [ pfc$shorten,pfc$append,pfc$read];
    access_selections^[2].key := amc$open_position;
    access_selections^[2].open_position := amc$open_at_boi;

    amp$open (value.file.local_file_name, amc$record, access_selections, file_identifier, status);
    if not status.normal then
      return;
    ifend;

    repeat
      amp$get_next (file_identifier, working_storage_area, working_storage_area_size, transfer_count,
                  byte_address, file_position, status);
    until not status.normal;

    if status.condition= ame$improper_record_header then
      status.normal := true;

      amp$skip (file_identifier, amc$backward, amc$skip_record, 1, file_position, status);
      if not status.normal then
        amp$close (file_identifier, ignore_status);
        return;
      ifend;

      amp$get_next (file_identifier, working_storage_area, working_storage_area_size, transfer_count,
                 byte_address, file_position, status);
      if not status.normal then
        amp$close (file_identifier, ignore_status);
        return;
      ifend;

      amp$skip (file_identifier, amc$backward, amc$skip_record, 1, file_position, status);
      if not status.normal then
        amp$close (file_identifier, ignore_status);
        return;
      ifend;

      amp$put_next (file_identifier, working_storage_area, transfer_count, byte_address, status);
      if not status.normal then
        amp$close (file_identifier, ignore_status);
        return;
      ifend;

      amp$close (file_identifier, status);
    else
      if status.condition = ame$input_after_eoi then
        status.normal := TRUE;
      ifend;
      amp$close (file_identifier, ignore_status);
    ifend;
  PROCEND qcp$correct_v_file;
MODEND qcm$correct_v_file;
*DECK DECK=QCM$DISPLAY_ACTIVE_COUNT EXPAND=TRUE

PROCEDURE qcm$display_active_count disac (
 output o: file = output )

IF $file($value(output) open_position) = '$BOI' THEN
  ofile = $string($value(output))//'.$ASIS'
ELSE
  ofile = $string($value(output))
IFEND
putl ''
putl '                   Active I/O Count - 1.4.1' o=$fname(ofile)
putl ' ' o=$fname(ofile)
req_heap = $sa(iov$request_heap)
req_len = 160
req_map = $sa(iov$request_heap_map)
u_offset = 07A(16)
crev active_count k=integer

FOR i = 0 TO 254 DO
  map = $mem(req_map+i/8, 1)
  map_bit = $mod(map/(2**(7-$mod(i, 8))), 2)
  IF map_bit <> 0 THEN
    cu = $mem(req_heap+req_len*i+u_offset,2)
    IF cu <> 0 THEN
    active_count = active_count+1
    IFEND
  IFEND
FOREND

IF active_count = 0 THEN
 putl ' ' o=$fname(ofile)
 putl '          There are no outstanding I/O requests' o=$fname(ofile)
ELSE
 active_counter = $strrep(active_count 10)
 putl ' ' o=$fname(ofile)
 putl '  There are '//active_counter//' outstanding I/O requests' ..
o=$fname(ofile)
IFEND

PROCEND qcm$display_active_count
*DECK DECK=QCM$DISPLAY_CORRECTION EXPAND=TRUE

PROC qcp$display_correction (
correction_identifier, ci: name = $required
output, o: file = $output
)


crev ignore k=status
crev check k=boolean v=FALSE
crev msg k=string



IF $file($value(output) open_position) = '$BOI' THEN
   ofile = $string($value(output)) //'.$ASIS'
ELSE
   ofile = $string($value(output))
IFEND

crev cb_path k=string v=':$SYSTEM.$SYSTEM.FIELD_MAINTENANCE.'
     cb_path = cb_path//$string($value(correction_identifier))//'.HEADER'
check = $file($fname(cb_path),permanent)

IF NOT check THEN
  putl ' ' o=$fname(ofile)
  putl '                   STOP '        o=$fname(ofile//'.$eoi')
  putl '     There is no information available relating'  o=$fname(ofile//'.$eoi')
  putl '     to correction '//$string($value(correction_identifier)) o=$fname(ofile//'.$eoi')
  putl ' '  o=$fname(ofile//'.$eoi')
  EXIT_PROC
IFEND

copf $fname(cb_path) $fname(ofile//'.$eoi')


PROCEND qcp$display_correction
*DECK DECK=QCM$DISPLAY_DCT EXPAND=TRUE



PROC qcm$display_dct, disdct (
  output, o: FILE = output
  status)

  crev cnt
  crev dsp k=string d=0..16
  dsp(0) = 'NULL PTT ENTRIES'
  dsp(1) = 'UNDEFINED '
  dsp(2) = 'PRIORITY 1 = MIN DISPATCHING PRIORITY'
  dsp(3) = 'PRIORITY 2'
  dsp(4) = 'PRIORITY 3'
  dsp(5) = 'PRIORITY 4'
  dsp(6) = 'PRIORITY 5'
  dsp(7) = 'PRIORITY 6'
  dsp(8) = 'PRIORITY 7 = SYSTEM JOB, VOLUME SPACE MANAGER'
  dsp(9) = 'PRIORITY 8 = JOB SCHEDULER'
  dsp(10) = 'PRIORITY 9 = SPLIT ALLOC,  ADMINISTER LOG, MLI HELPER'
  dsp(11) = 'PRIORITY 10'
  dsp(12) = 'PRIORITY 11'
  dsp(13) = 'PRIORITY 12'
  dsp(14) = 'PRIORITY 13'
  dsp(15) = 'PRIORITY 14'
  dsp(16) = 'MAX DISPATCHING RIORITY'

  dct_base = $sa(tmv$dct)
  dct_entry_length = 8(16) "due to alignment"
  true_dct_entry_length = 4(16)
  ptl_base = $mem($sa(tmv$ptl_p))
  ptl_entry_length = 20(16)


    putl '-'
    putl   '         Dispatch Control Table  1.4.1/1.4.2'
    FOR i = 0 TO 16 DO

      queue_head = $mem(dct_base+(dct_entry_length*i) 2)
      queue_tail = $mem(dct_base+(dct_entry_length*i)+2 2)

      putl '0DCT: Priority = '//dsp(i)

      task_index = queue_head

         IF task_index <> 0 THEN
           cnt = 1
         ELSE
           cnt = 0
         IFEND

          WHILE task_index <> queue_tail
          cnt = cnt + 1
          task_index = $mem(ptl_base+(ptl_entry_length * task_index) 2)
          WHILEND

          putl '      Task Count = '//$strrep(cnt,10)
     FOREND


PROCEND qcm$display_dct
*DECK DECK=QCM$DISPLAY_FAULT_BUFFER EXPAND=TRUE
PROC qcm$display_fault_buffer, disfb (
xcb: integer = $required
status)

chad am=rma
crev work k=string
crev base k=integer v=$value(xcb)

base = base + 221(16)
size = 59
putl '-'
putl '                    XCB fault buffers - 1.4.1/1.4.2 '
putl ''
putl '   Buffers.Present  = '//$strrep($mem(base,1),16)
base = base + 1
putl '   Buffers.Reserved = '//$strrep($mem(base,1),16)
base = base + 1
FOR i = 1 to 4 DO
   putl ''
   putl ' Buffer '//$strrep(i)//'.Identifier = '//$strrep($mem(base,1),16)
    base = base + 1
    FOR j = 1 to 32 DO
     work = '           Contents.'//$strrep(j)
     work = work//$substr('',1,25-$strlen(work))//'=  '//$strrep($mem(base,1),16)
     putl  work
     base = base + 1
    FOREND
   putl ''
   putl '              P Reg = '//$strrep($mem(base,8),16)
   base = base + 8
   putl '                 A0 = '//$strrep($mem(base,6),16)
   base = base + 6
   putl '                 A1 = '//$strrep($mem(base,6),16)
   base = base + 6
   putl '                 A2 = '//$strrep($mem(base,6),16)
   base = base + 6
FOREND

chad am=pva

PROCEND qcm$display_fault_buffer
*DECK DECK=QCM$DISPLAY_LOCKED_SEGMENTS EXPAND=TRUE
PROC qcm$display_locked_segments, disls (
  ajl_ordinal, ao: integer or key all, a = all
  output, o: file = $output
  status)


  crev s k=status
  IF $file($value(output) open_position) = '$BOI' THEN
    rewind_file $value(output) status=s
    output_file = $string($value(output)) // '.$asis'
  ELSE
    output_file = $string($value(output))
  IFEND
  change_default e=m am=pva

  crev field_len integer
  crev field_off integer
"Constants:
  in_use = 0 "offset into ajl entry of in use flag
  job_fixed_seg_num = 14(16) "relative to monitor address space
  job_monitor_xcb_offset = 100(16)" from start of job fixed
  ost$execution_control_block field=save9 offset=field_off length=field_len
  task_name = field_off/8  "offset into the XCB
  ost$execution_control_block field=link offset=field_off  length=field_len
  link = field_off/8 "offset into xcb
  ost$execution_control_block field=sdtx_p offset=field_off  length=field_len
  sdtx_p_offset = field_off/8 "offset into xcb
  mmt$segment_descriptor_extended field=segment_lock offset=field_off length=field_len
  segment_lock = field_off/8 "offset into segment descriptor table extended
  jmt$job_control_block field=job_name offset=field_off  length=field_len
  job_name = field_off/8 "offset into job control block
  jmt$job_control_block field=user_id offset=field_off   length=field_len
  user_id = field_off/8 "offset into job control block

  ajl_p = $sa(jmv$ajl_p)
  ajl = $mem(ajl_p)
  IF $nil_pva(ajl) THEN
    put_line '1the active job list has not yet been established.' ..
          o=$fname(output_file)
    EXIT_PROC
  IFEND
  ajl_entry_size = $mem(ajl_p+14 4)
  system_ajl_ordinal = $mem(ajl_p+10 4)
  number_of_entries = $mem(ajl_p+6 4) / ajl_entry_size
  last_ajl_ordinal = system_ajl_ordinal + number_of_entries - 1
  system_job_fixed = system_ajl_ordinal + job_fixed_seg_num
  system_job_monitor_xcb = $rma(..
        ((system_job_fixed*100000000(16))+job_monitor_xcb_offset))
  change_default e=job
  change_processor_register jps=system_job_monitor_xcb
  jmv$jcb = 300000000(16) "($sa(jmv$jcb))
  create_variable monitor_functions k=string d=0..74
  f1 = $unique
  create_monitor_func_file ($fname(f1))
  accl monitor_functions $fname(f1)
  delf $fname(f1)
  create_variable swap_status k=string d=0..16
  f1 = $unique
  create_swap_status_file ($fname(f1))
  accl swap_status $fname(f1)
  delf $fname(f1)

  IF $value_kind(ajl_ordinal) = 'INTEGER' THEN
    start_ajl_ordinal = $value(ajl_ordinal)
    IF start_ajl_ordinal > last_ajl_ordinal THEN
      putl ' ordinal is beyond end of active job list' o=$fname(output_file)
      EXIT_PROC
    IFEND
    last_ajl_ordinal = start_ajl_ordinal
  ELSE
    start_ajl_ordinal = system_ajl_ordinal
  IFEND


crev cctqm k=(string,256) value= '????????????'//..
'???????????????????? !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijkl'//..
'mnopqrstuvwxyz{|}~????????????????????????????????????????????????????????????????????????????????'//..
'?????????????????????????????????????????????????'

  FOR ajl_ord = start_ajl_ordinal TO last_ajl_ordinal DO

    ajl_entry = ajl + (ajl_ord * ajl_entry_size)

    IF $mem(ajl_entry+in_use, 1) = 1 THEN "process entry

      putl '0processing ajl ordinal '//$strrep(ajl_ord,16) o=$fname(output_file)

      seg_num = ajl_ord + job_fixed_seg_num
      pva = (seg_num * 100000000(16)) + job_monitor_xcb_offset
      job_monitor_xcb = $rma(pva monitor)
      change_processor_register jps=job_monitor_xcb

      IF ajl_ord <> system_ajl_ordinal THEN
        putl '0job name = '//$trim($translate(cctqm $ms(jmv$jcb+job_name 31))) o=$fname(output_file)
      IFEND
      putl '0user id = '//$trim($translate(cctqm $ms(jmv$jcb+user_id 31))) o=$fname(output_file)

      task_xcb = $mem($sa(job_xcb_list))

    process_tasks: ..
      REPEAT
        change_processor_register jps=$rma(task_xcb)

  " Look for locked segments.

        sdtx_p = task_xcb + sdtx_p_offset
        sdtx_length = $mem(sdtx_p+6 4)
        sdtx_size = $mem(sdtx_p+14 4)
        number_of_entries = sdtx_length / sdtx_size
        found = FALSE
        sdtx_p = $mem(sdtx_p 6)

        FOR index = 0 to number_of_entries - 1 DO
          entry_p = sdtx_p + sdtx_size * index
          lock = $mem(entry_p+segment_lock 1)
          IF lock <> 0 THEN
            IF NOT found THEN
               put_line '0Task name = '//$trim($ms((task_xcb+task_name) 31)) ..
                o=$fname(output_file)
              mcr = $process_register(mcr)
              mcr = mcr / 10(16)
              temp = mcr / 2
              temp = temp * 2
              IF mcr = temp THEN
                function = $mem(task_xcb+088(16) 1)
                IF (function > 0) AND (function < 75) THEN
                  putl ' monitor request = '//monitor_functions(function) o=$fname(output_file)
                IFEND
              IFEND
            IFEND
            putl ' SEGMENT '//$strrep(index) o=$fname(output_file)
            dism entry_p sdtx_size t='SEGMENT '//$strrep(index)   o=$fname(output_file)
            found = true
          IFEND
        FOREND

        IF found THEN
          display_call e=job o=$fname(output_file) ..
                t=$strrep(ajl_ord)//' '//$ms((task_xcb+task_name) 24)
        IFEND


        EXIT process_tasks WHEN $rma(task_xcb) = job_monitor_xcb
        task_xcb = $mem(task_xcb+link)

      UNTIL $nil_pva(task_xcb)

    IFEND

  FOREND

PROCEND qcm$display_locked_segments
*DECK DECK=QCM$DISPLAY_PP_ASSIGNMENTS EXPAND=TRUE
PROCEDURE qcm$display_pp_assignments, disppa (
 status )

chad e=m
crev ssr k=integer v= 400001000(16)
ssr = ssr + 64(16)*8     "offset of pp assignment table

" If first bit of byte is set (80 for instance) then VE owns the resource.
"
" If byte is 0F or FF then VE can't have access to it.
"
" If byte is zero then VE can use the resource if it needs it.
"

" The vpp array in ssr consists of four blocks of 32(8) bytes,
" the blocks represent
"                      NIO pp's for IOU 0
"                      CIO pp's for IOU 0
"                      NIO pp's for IOU 1
"                      CIO pp's for IOU 1
"
" The following pps are eligable for assignment,
" 0 - 3, 4 - 7, 10-12
" 20 - 23, 24 - 31, 32
" PPs 13 - 17 and 33 and 34 can never be assigned because
" there is no channel counterpart (actually there is a
" channel but no pp)


putl '-'
putl '          PP and Channel assignments from SSR'
putl ' '
lpp = 0
lch = 0

ppp = 0
pch = 0

crev base k=string d=1..4
base(1) = 'NIO PPs on IOU 0'
base(2) = 'CIO PPs on IOU 0'
base(3) = 'NIO PPs on IOU 1'
base(4) = 'CIO PPs on IOU 1'

FOR j = 1 TO 4 DO
  putl '-'
  putl ' '//base(j)
  putl ' '
FOR i = 0 TO 33(8) DO
 pch = $mem(ssr,1)
 ppp = $mem(ssr+1,1)
   chm = ' '
   IF pch = 0 THEN
      chm = 'Available'
   ELSE
      IF pch - 0f(16) = 0 THEN
         chm = 'Not Available'
      IFEND
   IFEND
   IF chm = '' THEN
      pch = pch - 80(16)
      chm = 'Is assigned to PP '//$strrep(pch,8)
   IFEND


   ppm = ' '
   IF ppp = 0 THEN
      ppm = 'Available'
   ELSE
      IF ppp - 0f(16) = 0 THEN
         ppm = 'Not Available'
      IFEND
   IFEND
   IF ppm = '' THEN
      ppp = ppp - 80(16)
      ppm = 'Is assigned to channel '//$strrep(ppp,8)
   IFEND
msg =' CH '//$strrep(i,8)
msg = msg//$substr('',1,7-$strlen(msg))//chm
msg = msg//$substr('',1,27-$strlen(msg))//' PP '//$strrep(i,8)
msg = msg//$substr('',1,35-$strlen(msg))//ppm
putl '     '//msg

  ssr = ssr+2
  FOREND
FOREND



PROCEND qcm$display_pp_assignments
*DECK DECK=QCM$DISPLAY_QCU_CORRECTION EXPAND=TRUE

PROC qcm$display_qcu_correction, display_qcu_correction, disqc (
qcu_ident           : name = $required
status )


crev ignore k=status
crev qi k=string v=$string($value(qcu_ident))
crev work k=string
crev msg k=string
crev count
crev base k=string v=$substr(qi,1,4)
crev valid k=boolean s=xdcl

validate_qcu_base $value(qcu_ident) valid
IF NOT valid THEN
 putl ' The value '//qi//' is not a valid system level'
 EXIT_PROC
IFEND

crev qcu_path k=string v=':CSERV.CSERV.QCU.'//base//'.data.$asis'
crev psr_path k=string v=':CSERV.ARHOPS.'
crev temp k=string v=$unique//'.$asis'
crev pl_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_PL'
crev na_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_NA'
crev cb_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_CB'

delf $fname(pl_path) status=ignore
delf $fname(na_path) status=ignore
delc $fname(cb_path) do=cac status=ignore
detf $fname(qcu_path) status=ignore
attf $fname(qcu_path) op=$asis status=ignore

crev psr k=string v=''
crev found k=boolean
crev break k=string v='_'
crev link_path k=string

accl v=work  i=$fname(qcu_path) lc=count
WHILE count > 0 DO
 IF $substr(work,1,6) = qi THEN
    psr = $substr(work,11,7)
    found = true
    EXIT
 IFEND
accl v=work i=$fname(qcu_path) lc=count
WHILEND

IF NOT found THEN
 putl ' The value '//qi//' does not represent a valid qcu identifier'
 EXIT_PROC
IFEND

psr_path = psr_path//psr


RESPF l=$fname(temp)
DISBF BF=$fname(psr_path)
QUIT

crev counter
rewf $fname(temp) status=ignore
WHILE counter < 2 DO
 accl v=work i=$fname(temp) lc=count
 IF $substr(work,2,1) = ':' THEN
  counter = counter + 1
 IFEND
WHILEND

crev base_path k=string
crev name_path k=string
crev head_path k=string

link_path = work
count = $scan_string(break,work)
count = count -1
base_path = $substr(work,1,count)
name_path = base_path//'_names'
head_path = base_path//'_pl'
rewf $fname(temp) status=ignore

RESPF l=$fname(temp)
RESC c=$fname(link_path) ncn=$fname(cb_path) bf=$fname(psr_path)
RESF f=$fname(name_path) nfn=$fname(na_path) bf=$fname(psr_path)
RESF f=$fname(head_path) nfn=$fname(pl_path) bf=$fname(psr_path)
QUIT

crev o k=string v=$unique
crev previous_base k=string
count = 1
attf $fname(pl_path) op=$asis
 msg =  '       FIELD CORRECTION DESCRIPTION FOR '//$strrep(qi)
 putl ' '//msg o=$fname(o//'.$eoi')
 putl '' o=$fname(o//'.$eoi')
accl v=work i=$fname(pl_path) lc=count
WHILE count <> 0 DO
 IF $substr(work,8,10) = 'Identifier' THEN
    putl '             QCU '//$substr(work,8,$strlen(work)) o=$fname(o//'.$eoi')
 ELSEIF $substr(work,8,4) = 'Type' THEN
    putl '             '//$substr(work,8,$strlen(work)) o=$fname(o//'.$eoi')
 ELSEIF $substr(work,8,5) = 'Creat' THEN
    putl '             '//$substr(work,8,$strlen(work)) o=$fname(o//'.$eoi')
 ELSEIF $substr(work,8,6) = 'Medium' THEN
    putl '             '//$substr(work,8,$strlen(work)) o=$fname(o//'.$eoi')
 ELSEIF $substr(work,11,7) = 'Product' THEN
    putl '             '//$substr(work,11,$strlen(work)) o=$fname(o//'.$eoi')
 ELSEIF $substr(work,6,6) = 'Correc' THEN
    putl '             '//$substr(work,6,$strlen(work)) o=$fname(o//'.$eoi')
    previous_base = $substr(work,22,12)
 ELSEIF $substr(work,6,6) = 'Answer' THEN
    putl '             '//$substr(work,6,$strlen(work)) o=$fname(o//'.$eoi')
 IFEND
accl v=work i=$fname(pl_path) lc=count
WHILEND
rewf $fname(o) status=ignore
copf $fname(o)

delf $fname(pl_path) status=ignore
delf $fname(na_path) status=ignore
delc $fname(cb_path) do=cac status=ignore


PROCEND qcm$display_qcu_correction
*DECK DECK=QCM$DISPLAY_SCOREBOARD EXPAND=TRUE


PROC qcp$display_scoreboard (
output, o: file = $output
status )

crev ignore k=status
crev work k=string
crev count v=1



IF $file($value(output) open_position) = '$BOI' THEN
   ofile = $string($value(output)) //'.$ASIS'
ELSE
   ofile = $string($value(output))
IFEND

crev hi_path k=string v=':$SYSTEM.$SYSTEM.FIELD_MAINTENANCE.HISTORY.$ASIS'
crev hb_path k=string v=':$SYSTEM.$SYSTEM.FIELD_MAINTENANCE'
crev hp_path k=string v=':$SYSTEM.$SYSTEM.FIELD_MAINTENANCE.HISTORY_PAGE'
crev hh_path k=string v=':$SYSTEM.$SYSTEM.FIELD_MAINTENANCE.HISTORY_HEADER'
crev lh_path k=string v=':$SYSTEM.$SYSTEM.FIELD_MAINTENANCE.LIBRARY_HEADER'
crev lb_path k=string v=':$SYSTEM.$SYSTEM.FIELD_MAINTENANCE.LIBRARIES'
crev sm_path k=string v=':$SYSTEM.$SYSTEM.FIELD_MAINTENANCE.SITE_MODIFICATIONS'

crev temp k=string v=$unique

crev check k=boolean
delf $fname(lh_path) status=ignore
checkc = $file($fname(hb_path),catalog)
checkf = $file($fname(hi_path),permanent)

IF NOT (checkc AND checkf) THEN
 putl ''  o=$fname(ofile//'.$eoi')
 putl '                      WARNING' o=$fname(ofile//'.$eoi')
 putl '          There are no corrections currently installed' o=$fname(ofile//'.$eoi')
 putl '          against the base level system.' o=$fname(ofile//'.$eoi')
 putl '' o=$fname(ofile//'.$eoi')
 EXIT_PROC
IFEND

" Go set up scoreboard headers

  build_score_header

detf $fname(hi_path) status=ignore
attf $fname(hi_path) op=$asis
delf $fname(hp_path) status=ignore
copf $fname(hh_path) $fname(hp_path//'.$eoi')

accl v=work i=$fname(hi_path) lc=count
WHILE count > 0 DO
 putl $substr(work,2,$strlen(work)) o=$fname(hp_path//'.$eoi')
 accl v=work i=$fname(hi_path) lc=count
WHILEND

rewf $fname(hp_path) status=ignore
copf $fname(hp_path) $fname(ofile//'.$eoi')
copf $fname(lh_path) $fname(ofile//'.$eoi')
delf $fname(hp_path) status=ignore
crev temp2 k=string v=$unique

crev t1 k=string d=1..50 v=''
crev t2 k=string d=1..50 v=''
crev t3 k=string
crev c1 v=1
crev c2 v=1

IF  $file($fname(lb_path),permanent) THEN

  detf $fname(lb_path) status=ignore
  attf $fname(lb_path) op=$asis
  accl t1(c1) i=$fname(lb_path) lc=count
   WHILE count > 0 DO
     c1 = c1+1
     accl t1(c1) i=$fname(lb_path) lc=count
   WHILEND

   FOR i = 1 TO c1 DO
    IF t1(i) <> 'OSF$VERSION' THEN
      t2(c2) = t1(i)
      c2 = c2+1
    IFEND
   FOREND

   FOR i = 1 TO c1 DO
     t1(i) = ''
   FOREND

    c1 = 1
   FOR i = 1 TO c2 DO
    IF t2(i) <> '' THEN
      t3 = t2(i)
       FOR j = i+1 TO c2 DO
         IF t2(j) = t3 THEN
            t2(j) = ''
            t3 = t3//' *'
        IFEND
       FOREND
          t1(c1) = t3
          c1 = c1+1
    IFEND
   FOREND
FOR i = 1 TO 40 DO
t2(i) = ''
FOREND

c2=1
crev c3
IF $file($fname(sm_path),permanent) THEN
 attf $fname(sm_path) op=$asis
 accl work i=$fname(sm_path) lc=count
  WHILE count > 0 DO
   t2(c2) = work
   c2 = c2+1
  accl work i=$fname(sm_path) lc=count
  WHILEND
IFEND
c2=c2-1
c3=1
FOR i = 1 TO c1 by 2 DO
IF t1(i) <> '' THEN
 msg = $trim($substr(t1(i),1,22))
 msg = msg//$trim($substr('',1,24-$strlen(msg))//t1(i+1))
  IF c2 > 0 THEN
   msg = msg//$trim($substr('',1,50-$strlen(msg))//t2(c3))
   c3 = c3+1
   c2 = c2-1
  IFEND
   put_line ' '//msg  o=$fname(ofile//'.$eoi')
IFEND
FOREND
   msg = ''
  IF c2 > 0 THEN
   msg = msg//$trim($substr('',1,50-$strlen(msg))//t2(c3))
   c3 = c3+1
   c2 = c2-1
  IFEND
   put_line ' '//msg  o=$fname(ofile//'.$eoi')
IFEND
detf $fname(lb_path) status=ignore
detf $fname(sm_path) status=ignore
delf $fname(hh_path) status=ignore
delf $fname(lh_path) status=ignore
detf $fname(hi_path) status=ignore


PROCEND qcp$display_scoreboard
*DECK DECK=QCM$DISPLAY_SFID EXPAND=TRUE
PROC qcm$display_sfid, dissfid(
sfid:integer = $required
output,o=$output
continue, c:boolean = false
display_option, do:key brief, b, full, f = full
status)




IF $file($value(output) open_position)='$BOI' THEN
  output_file=$string($value(output))//'.$asis'
  ELSE
  output_file=$string($value(output))
IFEND

fid_index=$integer($value(sfid)/10000(16))
fid_file_residence=$integer($value(sfid)-(fid_index*10000(16)))/100(16)
fid_file_hash=$integer($mod($value(sfid),100(16)))

IF fid_file_residence<>01 THEN
  pftr=$symbol_address(dmv$job_file_table_root)
ELSE
  pftr=$symbol_address(dmv$system_file_table_root)
IFEND

dmt$fdt_pointer_size=$mem(pftr+14,4)
first_fte=$mem(pftr)
fde_size=$memory(first_fte+2c(16) 4)
fde_entry_size=$memory(first_fte+34(16) 4)
entries_per_chunk=fde_size/fde_entry_size
pftr_entry_offset=26(16)
p_chunk_residence=$mem((fid_index/entries_per_chunk)*dmt$fdt_pointer_size+first_fte+pftr_entry_offset)
offset_within_chunk=(($MOD(fid_index,entries_per_chunk))*fde_entry_size)
current_fde_entry=(p_chunk_residence+offset_within_chunk)
create_variable name=file_types kind=string dimension=0..6
file_types(0)='dmc$permanent file'
file_types(1)='dmc$device file'
file_types(2)='dmc$temp named file'
file_types(3)='dmc$temp unnamed file'
file_types(4)='dmc$catalog'
file_types(5)='dmc$temp global'
file_types(6)='dmc$server file'
file_type_offset=3f(16)
create_variable name=queue_statuses kind=string dimension=0..2
queue_statuses(0)='dmc$global_shared'
queue_statuses(1)='dmc$job_shared'
queue_statuses(2)='dmc$job_working_set'
queue_status_offset=5a(16)
create_variable name=monitor_flags kind=string dimension=0..3
monitor_flags(0)='dmc$no monitor flag'
monitor_flags(1)='dmc$assign file'
monitor_flags(2)='dmc$build subfile FAT'
monitor_flags(3)='dmc$allocate more space'
create_variable name=monitor_flag_offset      kind=integer value=50(16)
create_variable name=modified_offset          kind=integer value=34(16)
create_variable name=attached_in_write_offset kind=integer value=55(16)
create_variable name=purged_offset            kind=integer value=59(16)
create_variable name=global_name_offset       kind=integer value=19(16)
create_variable name=asid_offset              kind=integer value=24(16)
create_variable name=available_offset         kind=integer value=26(16)
create_variable name=clear_space_offset       kind=integer value=27(16)
create_variable name=eof_byte_address_offset  kind=integer value=28(16)
create_variable name=eoi_byte_address_offset  kind=integer value=2e(16)
create_variable name=file_limit_offset        kind=integer value=35(16)
create_variable name=file_lock_offset         kind=integer value=3b(16)
create_variable name=preset_value_offset      kind=integer value=40(16)
create_variable name=p_file_medium_des_offset kind=integer value=48(16)
create_variable name=usage_count_offset       kind=integer value=51(16)
create_variable name=read_write_count_offset  kind=integer value=53(16)
create_variable name=delete_count_offset      kind=integer value=56(16)
create_variable name=file_hash_thread_offset  kind=integer value=5b(16)
create_variable name=file_entry_index_offset  kind=integer value=61(16)
create_variable name=time_stamp_offset        kind=integer value=63(16)

IF $strrep($value(output))='$OUTPUT' THEN
  put_line '1FILE DESCRIPTOR ENTRY   SFID = '//$strrep($value(sfid),16)//' (16)' o=$fname(output_file)
IFEND

IF ($strrep($value(display_option))='BRIEF') = ($strrep($value(display_option))='B') THEN
  display_memory current_fde_entry b=fde_entry_size title='                  SFID='//$strrep($value(sfid),16)..
  o=$fname(output_file)
IFEND


put_line '   ' o=$fname(output_file)
put_line ' file type = '//file_types($memory(current_fde_entry+file_type_offset,1)) o=$fname(output_file)
put_line ' queue status = '//queue_statuses($memory(current_fde_entry+queue_status_offset,1)) o=$fname(output_file)
put_line ' monitor flag = '//monitor_flags($memory(current_fde_entry+monitor_flag_offset,1)) o=$fname(output_file)
available_integer=$memory(current_fde_entry+available_offset,1)
available=(available_integer=$integer(true))
put_line ' available = '//$strrep(available) o=$fname(output_file)
modified_integer=$memory(current_fde_entry+modified_offset,1)
modified=(modified_integer=$integer(true))
put_line ' file_modified = '//$strrep(modified) o=$fname(output_file)
attached_in_write_integer=$memory(current_fde_entry+attached_in_write_offset,1)
attached_in_write=(attached_in_write_integer=$integer(true))
put_line ' attached_in_write = '//$strrep(attached_in_write) o=$fname(output_file)
purged_integer=$memory(current_fde_entry+purged_offset,1)
purged=(purged_integer=$integer(true))
put_line ' purged = '//$strrep(purged) o=$fname(output_file)
clear_space_integer=$memory(current_fde_entry+clear_space_offset,1)
clear_space=(clear_space_integer=$integer(true))
put_line ' clear_space = '//$strrep(clear_space) o=$fname(output_file)
display_binary_unique_name pva=current_fde_entry+global_name_offset o=$value(output) cs=' global_file_name = '
put_line ' asid = '//$strrep($memory(current_fde_entry+asid_offset,2),16)//' (16)'    o=$fname(output_file)
put_line ' eof byte address= '//$strrep($memory(current_fde_entry+eof_byte_address_offset,6),16)//' (16)' o=$fname(output_file)
put_line ' eoi byte address = '//$strrep($memory(current_fde_entry+eoi_byte_address_offset,6),16)//' (16)' o=$fname(output_file)
put_line ' file limit = '//$strrep($memory(current_fde_entry+file_limit_offset,6),16)//' (16)' o=$fname(output_file)
put_line ' preset value = '//$strrep($memory(current_fde_entry+preset_value_offset,8),16)//' (16)' o=$fname(output_file)
put_line ' file medium descriptor offset = '//$strrep($memory(current_fde_entry+p_file_medium_des_offset,8),16)//' (16)'..
 o=$fname(output_file)

IF $value(continue)=true THEN
  create_variable name=pass_parameter kind=integer scope=xref
  IF fid_file_residence=1 THEN
    pass_parameter=$memory(current_fde_entry+p_file_medium_des_offset,8)+100000000(16)
  ELSE
    pass_parameter=$memory(current_fde_entry+p_file_medium_des_offset,8)+300000000(16)
  IFEND
IFEND

put_line ' usage count = '//$strrep($memory(current_fde_entry+usage_count_offset,2),16)//' (16)'  o=$fname(output_file)
put_line ' read write count = '//$strrep($memory(current_fde_entry+read_write_count_offset,2),16)//' (16)' o=$fname(output_file)
put_line ' delete count = '//$strrep($memory(current_fde_entry+delete_count_offset,3),16)//' (16)' o=$fname(output_file)
put_line ' file hash thread = '//$strrep($memory(current_fde_entry+file_hash_thread_offset,6),16)//' (16)' o=$fname(output_file)
put_line ' file entry index = '//$strrep($memory(current_fde_entry+file_entry_index_offset,2),16)//' (16)' o=$fname(output_file)
put_line ' time stamp = '//$strrep($memory(current_fde_entry+time_stamp_offset,5),16)//' (16)' o=$fname(output_file)

dl_asid=$memory(current_fde_entry+asid_offset,2)

PROCEND qcm$display_sfid
*DECK DECK=QCM$DISPLAY_SWAP_BUFFER EXPAND=TRUE
PROC qcm$display_swap_buffer, dissb (
status )

crev work k=string
crev codes k=string d=0 .. 3
     codes(0) = 'Job out'
     codes(1) = 'Mon out'
     codes(2) = 'Job in'
     codes(3) = 'Mon in'

crev msg k=string
base = $sa(jsv$sched_swapping_requests)
offset = $mem(base+7,1)
base = base + 16


     putl '-'
     putl '           Display Swap Trace Buffer - 1.4.1/1.4.2'
     putl '                  the swap offset is '//$strrep(offset,10)
     putl '-'


    FOR i = 1 TO offset DO
     j = $mem(base,1)
     msg = ' Swap Mode = '//codes(j)
     msg = msg//$substr('',1,20-$strlen(msg))//'   IJL = '//$strrep($mem(base+2,1),16)
     msg = msg//$substr('',1,35-$strlen(msg))//' Time Stamp = '//$strrep($mem(base+4,6),16)
     putl msg
     base = base + 16
    FOREND

   putl '-'

PROCEND qcm$display_swap_buffer
*DECK DECK=QCM$ESTABLISH_BACKUP_CATALOG EXPAND=TRUE

PROCEDURE qcp$establish_backup_catalog (
  deadstart_cat,dc: file = $required
  output,o: file = $output
  status)


  VAR
    deadstart_catalog: string
    ignore: status
    level: string
  VAREND



      IF $file($value(output) open_position) = '$BOI' THEN
        rewind_file $value(output) status=ignore
        ofile = $string($value(output))//'.$ASIS'
      ELSE
        ofile = $string($value(output))
      IFEND

    deadstart_catalog = $string($value(deadstart_cat))

  "  Create the global variables.


  " This deck contains lists of record names used on deadstart tapes.

*copyc dst$deadstart_record_lists

  VAR
    catalog_files_list: list 0 .. $max_list OF name
    catalog_path: string
    command_status: status
    current_file : name
    file_name: string
    files_list: list 0 .. $max_list OF file
    files_name_list: list 0 .. $max_list OF name
    index: integer
    local_status: status
    main_path: string
    previous_catalog_path: string
  VAREND

  main_path = $string(deadstart_catalog)
  files_list = ()
  files_name_list = ()

  "  Use the standard required files list to determine if all of the required files exist in the
  "  deadstart catalog.

  create_files_list: FOR index = 1 TO deadstart_file_count DO
    IF deadstart_file_list(index).site_catalog = 'CIP' THEN
      CYCLE create_files_list
    IFEND

    "  Ensure that the required file exists.  If so, add it to the deadstart files list.

    IF deadstart_file_list(index).site_catalog = ' ' THEN
      catalog_path = main_path
    ELSE
      catalog_path = main_path//'.'//deadstart_file_list(index).site_catalog
    IFEND

    file_name = catalog_path//'.'//deadstart_file_list(index).tape_name
    IF (NOT $file($fname(file_name), permanent)) AND deadstart_file_list(index).site_required THEN
      local_status = $status(FALSE, 'DS', dse$required_file_missing, file_name)
      EXIT PROCEDURE WITH local_status
    IFEND

    IF deadstart_file_list(index).tape_name <> 'PRODUCT_EPILOG' THEN

      "  Add the file to the files list and the files name list.

      IF $file($fname(file_name), permanent) THEN
        files_list = $add($fname(file_name), files_list)
        files_name_list = $add($name(deadstart_file_list(index).tape_name), files_name_list)
      IFEND
      previous_catalog_path = catalog_path

    ELSE

      "  Before adding the product epilog file, process any other files that may exist in the product files
      "  catalog.  Determine if there are any by getting the catalog contents and subtracting the file names
      "  that have already been processed.

      catalog_files_list = $catalog_contents($fname(previous_catalog_path), include_files)
      catalog_files_list = $difference(catalog_files_list, files_name_list)
      WHILE NOT $nil(catalog_files_list) DO
        current_file = $first(catalog_files_list)
        catalog_files_list = $rest(catalog_files_list)

        "  Ensure that the file name is less than 18 characters in length and add it to the files list.

        IF $file($fname(previous_catalog_path//'.'//$string(current_file)), opened) THEN
          IF $strlen($string(current_file)) < 18 THEN
            files_list = $add($fname(previous_catalog_path//'.'//$string(current_file)), files_list)
          ELSE
            local_status = $status(FALSE, 'DS', dse$file_name_too_long, previous_catalog_path//'.'//$string(current_file))
            EXIT PROCEDURE WITH local_status
          IFEND
        IFEND
      WHILEND

      "  Add the product epilog file to the files list.

      files_list = $add($fname(file_name), files_list)
    IFEND
  FOREND create_files_list

  "  Since elements are added to lists at the beginning, the deadstart files list must be be reversed to make
  "  it in the correct order.

  files_list = $reverse(files_list)


  include_command c='install_deadstart_file df=files_list status=local_status' status=command_status

  IF local_status.normal THEN
    put_line ' ' o=$fname(ofile//'.$eoi')
    put_line l='       **  Correction system withdrawn  **'  o=$fname(ofile//'.$eoi')
    put_line ' ' o=$fname(ofile//'.$eoi')
  ELSE
    put_line l='     Failure attempting to withdraw correction system. ' o=$fname(ofile//'.$eoi')
    put_line ' ' o=$fname(ofile//'.$eoi')
  IFEND
    putl ' MANFC/' o=$fname(ofile//'.$eoi')
  EXIT PROCEDURE WITH local_status WHEN NOT local_status.normal

PROCEND qcp$establish_backup_catalog
*DECK DECK=QCM$ESTABLISH_DEADSTART_CATALOG EXPAND=TRUE

PROCEDURE qcp$establish_deadstart_catalog (
  status)

  VAR
    local_status: status
    ignore_status: status
  VAREND

  WHEN any_fault DO
    put_line l=' Establish Correction System failed with:'
    put_line l=$string(osv$status)
    EXIT PROCEDURE WITH osv$status
  WHENEND
   move_ds_catalog  status=local_status

  EXIT PROCEDURE WITH local_status
PROCEND qcp$establish_deadstart_catalog

*DECK DECK=QCM$ESTABLISH_QCU EXPAND=TRUE

PROCEDURE qcp$establish_qcu (
  output,o: file = $output
  status)

  VAR
    ignore: status
    local_status: status
    ck_path: file = :$SYSTEM.$SYSTEM.FIELD_MAINTENANCE
    id_path: file = :$SYSTEM.$SYSTEM.QCU_MAINTENANCE.identification
    deadstart_catalog: string
    level: string
    check: boolean
  VAREND


      IF $file($value(output) open_position) = '$BOI' THEN
        rewind_file $value(output) status=ignore
        ofile = $string($value(output))//'.$ASIS'
      ELSE
        ofile = $string($value(output))
      IFEND




    crev history k=string v=':$SYSTEM.$SYSTEM.FIELD_MAINTENANCE.HISTORY'
    crev clear k=string v='$LOCAL.HISTORY'
    crev temp k=string v=$unique

    $system.accept_line v=level i=id_path
    deadstart_catalog = ':$SYSTEM.$SYSTEM.QCU_MAINTENANCE.'//level//'.deadstart_catalog'


  "  Create the global variables.
    delv csv$estqcu_catalog_specified status=ignore
    delv csv$estqcu_existing_catalog status=ignore

  VAR
    csv$estqcu_catalog_specified: (JOB) boolean = TRUE
    csv$estqcu_existing_catalog: (JOB) file
  VAREND

   crev lc_path k=string
   lc_path = deadstart_catalog
    csv$estqcu_existing_catalog = deadstart_catalog

    IF NOT $file($fname(lc_path),catalog) THEN
       putl '                    STOP'   o=$fname(ofile)
       putl '      There is no system available to establish.'   o=$fname(ofile)
       putl '      It will be necessary to issue GENERATE_'      o=$fname(ofile)
       putl '      CORRECTION_SYSTEM prior to reissueing'        o=$fname(ofile)
       putl '      ESTABLISH_CORRECTION_SYSTEM.'                 o=$fname(ofile)
       putl ' '                                                  o=$fname(ofile)
       EXIT_PROC
    IFEND


    crev work k=string
    crev work1 k=string
    crev count
    delf $fname(temp) status=ignore
    delf $fname(clear) status=ignore
    detf $fname(history) status=ignore
    attf $fname(history) op=$asis
    accl work i=$fname(history) lc=count
     WHILE count > 0 DO
      work1 = $substr(work,1,74)
      work1 = work1//'YES'
      putl work1 o=$fname(temp//'.$eoi')
    accl work i=$fname(history) lc=count
     WHILEND
    rewf $fname(temp) status=ignore
    detf $fname(history) status=ignore
    delf $fname(history) status=ignore
    copf $fname(temp) $fname(history)
    detf $fname(history)  status=ignore


  "  Execute a task to install the deadstart file.

  TASK tn=install_ds_catalog_to_disk
    VAR
      command_status: status
      ignore_status: status
      local_status: status
    VAREND

 MANAGE_FIELD_CHANGES
  put_line ' '
  put_line '     Establishing the Correction System     '
  put_line '                 Please'
  put_line '   Wait on the completion message "** New system established **"'
  put_line ' '

   incc c='establish_deadstart_catalog status=local_status' ..
      status=command_status
      IF NOT command_status.normal THEN
        local_status = command_status
      IFEND
  QUIT

    IF NOT local_status.normal THEN
    putl ' Establish Correction system returned the following error:'
    disv local_status
    IFEND


    delete_variable n=csv$estqcu_catalog_specified
    delete_variable n=csv$estqcu_existing_catalog
  TASKEND


 PROCEND qcp$establish_qcu

*DECK DECK=QCM$ESTABLISH_QCU_ENVIRONMENT EXPAND=TRUE

PROC qcp$establish_qcu_environment (
correction, c: name = $required
correction_file_path, cfp: file = $required
check:VAR of boolean
output, o: file = $output
status )

crev ignore k=status
crev count
crev level_ident k=string v='A'
crev running_system k=string
crev check k=boolean v=FALSE
crev work k=string
crev path_name k=string
crev ci k=string v=$string($value(correction))
crev qev$ccu k=boolean v=FALSE s=xdcl
crev qev$previous_base k=string s=xdcl
crev qev$correction_base k=string s=xref
path_name = $string(qev$correction_base)

$value(check) = TRUE


      IF $file($value(output) open_position) = '$BOI' THEN
        rewind_file $value(output) status=ignore
        ofile = $string($value(output))//'.$ASIS'
      ELSE
        ofile = $string($value(output))
      IFEND

crev cf_path k=string v=$string($value(correction_file_path))
crev cc_path k=string v=path_name
crev cn_path k=string v=path_name//'.'//$string($value(correction))
crev cb_path k=string v=path_name//'.'//$string($value(correction))
     cb_path = cb_path//'.LINK_INPUT_FILES'
crev na_path k=string v=path_name//'.'//$string($value(correction))
     na_path = na_path//'.NAMES'
crev pl_path k=string v=path_name//'.'//$string($value(correction))
     pl_path = pl_path//'.HEADER'
crev temp2 k=string v=$unique//'.$asis'
crev lb_path k=string v=path_name//'.LIBRARIES'
crev cp_path k=string v=path_name//'.PATHS'
crev ll_path k=string v=path_name//'.LINK_INPUT_FILES'


check = $file($fname(cf_path),permanent)

IF NOT check THEN
 putl '                      WARNING  ' o=$fname(ofile//'.$eoi')
 putl ' The Correction File Path provided does not describe a file' o=$fname(ofile//'.$eoi')
 putl ' path known to the system. Please correct the situation and' o=$fname(ofile//'.$eoi')
 putl ' reissue the request.'                                       o=$fname(ofile//'.$eoi')
 putl ''                                                            o=$fname(ofile//'.$eoi')
 $value(check) = FALSE
 EXIT_PROC
IFEND

crec  $fname(cc_path) status=ignore
delc  $fname(cb_path) do=cac status=ignore
delf  $fname(na_path) status=ignore
detf  $fname(pl_path) status=ignore
delf  $fname(pl_path) status=ignore
crec  $fname(cn_path) status=ignore
crec  $fname(ll_path) status=ignore

crev break k=string v='_'
crev temp k=string v=$unique//'.$asis'
crev link_path k=string
crev qcu_ident k=string
crev system_ident k=string

content = $file($fname(cf_path),fc)
IF content <> 'FILE_BACKUP' THEN
 putl '                     WARNING ' o=$fname(ofile//'.$eoi')
 putl ' The correction path provided describes a file with improper' o=$fname(ofile//'.$eoi')
 putl ' file attributes. The file_content attribute must be set to'  o=$fname(ofile//'.$eoi')
 putl ' FILE_BACKUP to describe a proper correction packet file. File' o=$fname(ofile//'.$eoi')
 putl ' path '//cf_path//' has a file_content attribute of '//content  o=$fname(ofile//'.$eoi')
 putl ''                                                               o=$fname(ofile//'.$eoi')

 $value(check) = FALSE
 EXIT_PROC
IFEND


RESPF l=$fname(temp)
DISBF BF=$fname(cf_path)
QUIT

crev cross
crev counter
rewf $fname(temp) status=ignore
WHILE counter < 2 DO
 accl v=work i=$fname(temp) lc=count
 IF $substr(work,2,1) = ':' THEN
  counter = counter + 1
   IFEND
  cross = cross + 1
   IF cross > 10 THEN
      putl '                     WARNING  '   o=$fname(ofile//'.$eoi')
      putl ''                                 o=$fname(ofile//'.$eoi')
      putl ' The contents of the correction file are not as expected.'  o=$fname(ofile//'.$eoi')
      putl ' Either the path provided does not describe a proper'       o=$fname(ofile//'.$eoi')
      putl ' correction packet file or the file attributes are improper.' o=$fname(ofile//'.$eoi')
      putl ''                                                             o=$fname(ofile//'.$eoi')
      putl ' The required file attributes are fc=FILE_BACKUP, fs=DATA,'   o=$fname(ofile//'.$eoi')
      putl ' fp=UNKNOWN and rt=VARIABLE.'                                 o=$fname(ofile//'.$eoi')
      putl ''                                                             o=$fname(ofile//'.$eoi')
      putl ' Please correct the situation and reissue the request.'       o=$fname(ofile//'.$eoi')
      putl ''   o=$fname(ofile//'.$eoi')
      $value(check) = FALSE
      EXIT_PROC
 IFEND
WHILEND

crev base_path k=string
crev name_path k=string
crev head_path k=string

link_path = work
count = $scan_string(break,work)
count = count -1
base_path = $substr(work,1,count)
name_path = base_path//'_names'
head_path = base_path//'_pl'

RESPF l=$fname(temp)
RESC c=$fname(link_path) ncn=$fname(cb_path) bf=$fname(cf_path)
RESF f=$fname(name_path) nfn=$fname(na_path) bf=$fname(cf_path)
RESF f=$fname(head_path) nfn=$fname(pl_path) bf=$fname(cf_path)
QUIT


crev previous_base k=string
crev msg k=string
crev msg1 k=string
count = 1
detf $fname(pl_path) status=ignore
attf $fname(pl_path) op=$asis
 putl '' o=$fname(temp2)
 msg =  '       FIELD CORRECTION DESCRIPTION FOR '//$string($value(correction))
 putl ' '//msg o=$fname(temp2//'.$eoi')
 putl ' ' o=$fname(temp2//'.$EOI')
accl v=work i=$fname(pl_path) lc=count
WHILE count <> 0 DO
 IF $substr(work,8,10) = 'Identifier' THEN
    msg ='             QCU Identifier:    '
    msg = msg//$substr(work,21,6)
    putl msg o=$fname(temp2//'.$eoi')
    qcu_ident = $trim($substr(work,20,7))
 ELSEIF $substr(work,6,6) = 'Answer' THEN
    msg1 ='             Answers:           '
    msg1 = msg//$substr(work,20,$strlen(work))
    putl msg  o=$fname(temp2//'.$eoi')
    IF $substr(work,21,7) = 'GENERIC' THEN
         msg1 ='             Type:              CCU '
         qev$ccu = TRUE
    IFEND
 ELSEIF $substr(work,8,4) = 'Type' THEN
         msg1 ='             Type:              SINGLE '
         msg1 = msg//$substr(work,21,10)

 ELSEIF $substr(work,8,5) = 'Creat' THEN
    msg ='             Creation:          '
    msg = msg//$substr(work,21,19)
    putl msg o=$fname(temp2//'.$eoi')
 ELSEIF $substr(work,8,6) = 'Medium' THEN
    msg ='             Medium:            ELECTRONIC/'
    msg = msg//$substr(work,21,4)
    putl msg o=$fname(temp2//'.$eoi')
 ELSEIF $substr(work,11,7) = 'Product' THEN
    msg ='             Product:           '
    msg = msg//$substr(work,19,$strlen(work))
    putl msg o=$fname(temp2//'.$eoi')
 ELSEIF $substr(work,4,10) = 'Subproduct' THEN

    msg ='             Subproduct:        '
    msg = msg//$substr(work,15,17)
    putl msg o=$fname(temp2//'.$eoi')
 ELSEIF $substr(work,6,6) = 'Correc' THEN
    msg ='             Based on:          '
    msg = msg//$substr(work,22,12)
    putl msg  o=$fname(temp2//'.$eoi')
    previous_base = $substr(work,22,12)
    putl msg1 o=$fname(temp2//'.$eoi')
 IFEND

accl v=work i=$fname(pl_path) lc=count
WHILEND
    msg = '             Correction Path:   '
    msg = msg//$string($value(correction_file_path))
    putl msg  o=$fname(temp2//'.$eoi')



  crev hi_path k=string v=path_name//'.HISTORY.$ASIS'
  crev ho_path k=string v=path_name//'.HISTORY_LINE'

  delf $fname(ho_path) status=ignore
  detf $fname(hi_path) status=ignore

"**************************************************************************
" Update the installed code history file and retrieve the last QCU or BCU
" installed. If the history file currently does not exist create it.
" Return the last base value in variable qev$correction_base
"**************************************************************************
   crev history k=boolean v=FALSE
   history = $file($fname(hi_path),permanent)


   crev libs k=string
   crev libt k=string
   crev last_base k=string v=''
      IF $translate(ltu,$substr(previous_base,10,1))= 'X' THEN
         last_base = $substr(previous_base,6,4)
      ELSE
         last_base = $substr(previous_base,6,6)
      IFEND
   count = 1

   crev rs_path k=string v='$system.nosve_maintenance.link_input_files.os_version'
   incf $fname(rs_path)

   running_system = $string(level_id)
 IF running_system <> last_base  THEN
    putl '-'                            o=$fname(ofile//'.$eoi')
    putl '                   WARNING  ' o=$fname(ofile//'.$eoi')
    putl '      The correction '//$strrep(ci)//' was not manufactured' o=$fname(ofile//'.$eoi')
    putl '      against the system base at which you are currently'    o=$fname(ofile//'.$eoi')
    putl '      running.     '                                         o=$fname(ofile//'.$eoi')
    putl ' '                                                           o=$fname(ofile//'.$eoi')
    putl '      Installed system is '//level_id//' based'             o=$fname(ofile//'.$eoi')
    putl ' '                                                           o=$fname(ofile//'.$eoi')
    putl '      '//$strrep(ci)//' is '//last_base//' system based.' o=$fname(ofile//'.$eoi')
    putl ' '                                                       o=$fname(ofile//'.$eoi')
    putl '      The correction cannot be applied.'                 o=$fname(ofile//'.$eoi')
    putl ' '                                                       o=$fname(ofile//'.$eoi')
    $value(check) = FALSE
    detf $fname(pl_path) status=ignore
    delc $fname(cn_path) do=cac status=ignore
    EXIT_PROC
 IFEND


IF history THEN
   attf $fname(hi_path) op=$asis
   accl work i=$fname(hi_path) lc=count

    WHILE count <> 0 DO
          IF $substr(work,3,7) = $strrep(ci)  THEN
            putl '            WARNING '  o=$fname(ofile//'.$eoi')
            putl ' The correction specified is already installed' o=$fname(ofile//'.$eoi')
            putl ' '                                              o=$fname(ofile//'.$eoi')
             detf $fname(hi_path) status=ignore
             $value(check) = FALSE
             EXIT_PROC
          IFEND
        accl work i=$fname(hi_path) lc=count
    WHILEND

    detf $fname(hi_path) status=ignore
   count = 1
   attf $fname(hi_path) op=$asis
   accl work i=$fname(hi_path) lc=count

    WHILE count <> 0 DO
          IF work <> '' THEN
             last_base = $substr(work,3,7)
"            level_ident = $substr(work,19,1)
 "           level_ident = $char($ord(level_ident)+1)
             work = ''
          IFEND
        accl work i=$fname(hi_path) lc=count
    WHILEND
IFEND
crev c1
crev work1 k=string
crev psr k=string
crev lib k=string
crev ck_path k=string
detf $fname(na_path) status=ignore
attf $fname(na_path) op=$asis
 accl work i=$fname(na_path) lc=count
  WHILE count > 0 DO
   IF work <> 'OSF$VERSION' THEN
     lib = '.OSF$BOUND_'//$substr(work,5,$strlen(work))
     ck_path = ll_path//lib
      IF $file($fname(ck_path),permanent) THEN
       $value(check) = FALSE
         detf $fname(cp_path) status=ignore
         attf $fname(cp_path) op=$asis
         accl work1 i=$fname(cp_path) lc=c1

          WHILE c1 > 0 DO
           IF $substr(work1,1,29) = $substr(lib,2,29) THEN
             psr = $substr(work1,30,8)
           IFEND
           accl work1 i=$fname(cp_path) lc=c1
          WHILEND
           detf $fname(cp_path) status=ignore

         putl ' '
         putl '                     WARNING' o=$fname(ofile//'.$eoi')
         putl '      Modifications associated with correction '//ci  o=$fname(ofile//'.$eoi')
         putl '      conflict with previously installed corrections. It' o=$fname(ofile//'.$eoi')
         putl '      is not possible to install these modifications over' o=$fname(ofile//'.$eoi')
         putl '      the existing base. In order to successfully install' o=$fname(ofile//'.$eoi')
         putl '      the correction it will be necessary to withdraw'     o=$fname(ofile//'.$eoi')
         putl '      correction '//psr                                    o=$fname(ofile//'.$eoi')
         putl ' '                                                         o=$fname(ofile//'.$eoi')
        detf $fname(na_path) status=ignore
        detf $fname(hi_path) status=ignore
       EXIT_PROC
      IFEND
     IFEND
       accl work i=$fname(na_path) lc=count
    WHILEND

   crev user_ident k=string

   detf $fname(hi_path) status=ignore
" Manufacture a new system level id for this correction
  IF NOT qev$ccu THEN

   putl '    The Identifier for this correction system is of the form'  o=$fname(ofile)
   putl '    '//$substr(qcu_ident,2,5)//'Cn where n is a user supplied sub-identifier. Please'  o=$fname(ofile)
   accl v=work i=input lc=count p='   Enter a character to be used as the system sub-identifier - '
   user_ident = $translate(ltu,($substr(work,1,1)))
   putl ' ' o=$fname(ofile)
   putl '    The new system identifier will be '//$substr(qcu_ident,2,5)//'C'//user_ident  o=$fname(ofile)
   putl ' '   o=$fname(ofile)
   qcul = $size(qcu_ident)
   system_ident = $substr(qcu_ident,2,qcul-1)//'_C'//user_ident
   main_ident = 'C'//user_ident
   ELSE
   putl ' '
   putl ' Identifiers are no longer user supplied for a CCU'
   putl ' '
   system_ident = qcu_ident
   IFEND



   msg = ''
   msg = '  '//$strrep(ci)
   msg = msg//$substr('',1,13-$strlen(msg))//system_ident
   msg = msg//$substr('',1,25-$strlen(msg))//last_base
   msg = msg//$substr('',1,37-$strlen(msg))//previous_base
   msg = msg//$substr('',1,51-$strlen(msg))//$date(mdy)
   msg = msg//$substr('',1,62-$strlen(msg))//$time(hms)
   msg = msg//$substr('',1,75-$strlen(msg))//'NO'
   putl msg o=$fname(ho_path)

   qev$previous_base  = previous_base

   detf $fname(ho_path) status=ignore

" Go save the header file
    msg = '             System Identifier: '
    msg = msg//system_ident
    putl msg  o=$fname(temp2//'.$eoi')
     rewf $fname(temp2)  status=ignore
     detf $fname(pl_path) status=ignore
     copf $fname(temp2) $fname(pl_path)


detf $fname(na_path) status=ignore
attf $fname(na_path) op=$asis

accl work i=$fname(na_path) lc=count
WHILE count > 0 DO
 IF work <> 'OSF$VERSION' THEN
   putl work o=$fname(lb_path//'.$eoi')
 IFEND
accl work i=$fname(na_path) lc=count
WHILEND
detf $fname(na_path) status=ignore


modify_version,$value(correction),qcu_ident,system_ident


PROCEND qcp$establish_qcu_environment

*DECK DECK=QCM$FILE_REPAIR_UTILITY EXPAND=TRUE

?? RIGHT := 110 ??
?? NEWTITLE := 'FILE_REPAIR_UTILITY: FILRU Utility Command.' ??
MODULE qcm$file_repair_utility;

{ PURPOSE:
{   This module contains the command interface to set up and control the
{   file repair utility.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc qct$installation_defaults
?? POP ??
*copyc clp$begin_utility
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc fst$file_reference

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    qcv$filru_utility_name: [XDCL] clt$utility_name := 'FILE_REPAIR_UTILITY';


?? FMT (FORMAT := ON) ??

?? TITLE := '[XDCL] qcp$file_repair_utility', EJECT ??

{ PURPOSE:
{   This command interface sets up the FILE_REPAIR_UTILITY utility
{   session.
{
{ DESIGN:
{   This follows standard utility design.
{
{ NOTES:
{


PROCEDURE [XDCL] qcp$repair_files
                (parameter_list: clt$parameter_list;
                 VAR status: ost$status);


 { PROCEDURE fileru_pdt (
{ status)

?? 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,
      recend,
    recend := [
    [1,
    [91, 4, 22, 11, 44, 22, 447],
    clc$command, 1, 1, 0, 0, 0, 0, 1, ''], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


{ table n=filru_command_table t=command s=xdcl
{ command n=(correct_v_file, corvf) p=qcp$correct_v_file cm=xref
{ command n=(quit, qui) p=qcp$quit_filru cm=xref
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  filru_command_table: [XDCL, READ] ^clt$command_table :=
      ^filru_command_table_entries,

  filru_command_table_entries: [STATIC, READ] array [1 .. 4] of
      clt$command_table_entry := [
  {} ['CORRECT_V_FILE                 ', clc$nominal_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^qcp$correct_v_file],
  {} ['CORVF                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 1, clc$automatically_log, clc$linked_call,
        ^qcp$correct_v_file],
  {} ['QUI                            ', clc$abbreviation_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^qcp$quit_filru],
  {} ['QUIT                           ', clc$nominal_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$linked_call,
        ^qcp$quit_filru]];

  PROCEDURE [XREF] qcp$correct_v_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] qcp$quit_filru
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??




?? PUSH (LISTEXT := ON) ??

VAR
  filru_function_table: [XDCL, READ] ^clt$function_processor_table := ^filru_function_table_entries,

  filru_function_table_entries: [STATIC, READ] array [1 .. 1] of clt$function_proc_table_entry := [
  {} ['$READ_DATA               ', clc$nominal_entry, clc$hidden_entry, 1, clc$linked_call,
        ^qcp$functions]];

  PROCEDURE [XREF] qcp$functions
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? POP ??

    CONST
      prompt_size = 5,
      prompt_value = 'FILRU';

    VAR
      utility_attributes_p: ^clt$utility_attributes;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH utility_attributes_p: [1 .. 4];
    utility_attributes_p^ [1].key := clc$utility_command_search_mode;
    utility_attributes_p^ [1].command_search_mode := clc$global_command_search;
    utility_attributes_p^ [2].key := clc$utility_command_table;
    utility_attributes_p^ [2].command_table := filru_command_table;
    utility_attributes_p^ [3].key := clc$utility_function_proc_table;
    utility_attributes_p^ [3].function_processor_table := filru_function_table;
    utility_attributes_p^ [4].key := clc$utility_prompt;
    utility_attributes_p^ [4].prompt.size := prompt_size;
    utility_attributes_p^ [4].prompt.value := prompt_value;

    clp$begin_utility (qcv$filru_utility_name, utility_attributes_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, prompt_value, qcv$filru_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (qcv$filru_utility_name, status);

  PROCEND qcp$repair_files;


MODEND qcm$file_repair_utility;
*DECK DECK=QCM$FILE_REPAIR_UTILITY_PD EXPAND=TRUE

  create_program_description (file_repair_utility, filru) ..
     sp=qcp$repair_files l=osf$current_library dm=no lm=$null ..
     lmo=none
*DECK DECK=QCM$FUNCTIONS EXPAND=TRUE
MODULE qcm$functions;
*copyc osd$default_pragmats

?? PUSH (LISTEXT := ON) ??
*copyc clt$work_area
*copyc cle$work_area_overflow
*copyc clt$data_value
*copyc ost$status
*copyc clt$parameter_list
?? POP ??


PROCEDURE [XDCL] qcp$functions
 ( parameter_list: clt$parameter_list;
 VAR work_area: ^clt$work_area;
 VAR result: ^clt$data_value;
 VAR status: ost$status);


PROCEND qcp$functions;
MODEND qcm$functions;
*DECK DECK=QCM$GENERATE_LEVELS EXPAND=TRUE


PROCEDURE qcm$generate_levels, generate_levels, genls  (
  qcu_ident, qi: data_name = $required
  status)


  VAR
    wev$working_catalog :(XREF) string
    wev$build_level :(XREF) string
    wev$development_base :(XREF) string
    product_table :(XDCL) string
    base_table: (XDCL) string
    pacs_catalog :(XDCL) string
    licensed_products : string = 'all'
    include_subproducts : name
    exclude_subproducts : name
    use_alternate_intve_paths : boolean = FALSE
    alternate_intve_paths_file : string= $unique
    catalog_count : integer
    copy_error : boolean= false
    create_target_catalog : string
    element_count : integer
    errors_found : boolean
    error_output : string= $unique
    formats : list 0..$max_list of string
    formats_file : string= $unique
    ignore_status : status
    intve_paths : list 0..$max_list of string
    intve_paths_file : string= $unique
    local_status : status
    pacs_commands_file : string= $unique
    pacs_paths : list 0..$max_list of string
    pacs_paths_file : string= $unique
    pacs_status : status
    source_file : string
    subproduct_file : string= $unique
    subproduct_list : list 0..$max_list of string
    target_file : string
    temp_list : list 0..$max_list of string
    temp_subproduct_file : string= $unique
    compile_file : string = $unique
    get_all : boolean = FALSE
    ignore : status
    selection_criteria_file : string = $unique
    wev$pacs_catalog : string = $string(pacs_catalog)
  VAREND

putl ''
putl ' Begin Levels generation'


product_table = wev$working_catalog
product_table = product_table//'.object.maintenance.qcf$qcu_product_table'
base_table = wev$development_base//'.os.'//wev$build_level//'.'
pacs_catalog = '.'//$job(user)//'.'//$string(qcu_ident)//'_PB'

 disc $fname(pacs_catalog) do=permits output=$null status=local_status
    IF NOT local_status.normal THEN
      IF local_status.condition = PFE$UNKNOWN_LAST_SUBCATALOG THEN
        create_catalog catalog=$fname(pacs_catalog) status=local_status
      IFEND
      EXIT_PROC with local_status WHEN NOT local_status.normal
    IFEND

get_products pt=$fname(product_table) ..
  pacc=$fname(pacs_catalog) ..
  lp=all,,,aip=$fname(alternate_intve_paths_file),ip=$fname(intve_paths_file) ..
  f=$fname(formats_file),pp=$fname(pacs_paths_file)  ..
  pc=$fname(pacs_commands_file) status=local_status

      EXIT_PROC with local_status WHEN NOT local_status.normal

    accl v=formats i=$fname(formats_file) status=local_status
       EXIT_PROC WITH local_status  WHEN NOT local_status.normal

    accl v=intve_paths i=$fname(intve_paths_file) status=local_status
       EXIT_PROC WITH local_status  WHEN NOT local_status.normal

       EXIT_PROC  WHEN ($size(formats) <> $size(intve_paths))

    FOR list = 1 TO $size(intve_paths) DO
      verify_file_entry file_name=$fname(intve_paths(list)) format=$name(formats(list)) status=local_status

      IF NOT local_status.normal THEN
      p1 = $translate(ltu,intve_paths(list))
      c1 = $scan_string('BOUND',p1)
          IF c1 > 0 THEN
            n1 = $substr(p1,c1,$strlen(p1)-c1+1)
          ELSE
            n1 = 'VERSION'
          IFEND
       copf $fname(base_table//n1) $fname(intve_paths(list))
      IFEND
    FOREND

    accl v=pacs_paths i=$fname(pacs_paths_file) status=local_status
       EXIT_PROC WITH local_status  WHEN NOT local_status.normal

       EXIT_PROC  WHEN ($size(intve_paths) <> $size(pacs_paths))


      get_subproduct_list pt=$fname(product_table) licensed_product=all ..
                output=$fname(temp_subproduct_file//'.$eoi') status=local_status
             EXIT_PROC WITH local_status  WHEN NOT local_status.normal


      standardize_name_list i=$fname(temp_subproduct_file) o=$fname(subproduct_file) ..
              status=local_status
             EXIT_PROC WITH local_status  WHEN NOT local_status.normal

    accl v=subproduct_list i=$fname(subproduct_file) status=local_status
       EXIT_PROC WITH local_status  WHEN NOT local_status.normal


    FOR EACH subcatalog IN subproduct_list DO
      delcc  c=pacs_catalog//$name(subcatalog) do=cc status=ignore
    FOREND


  copy_block: ..
    BLOCK

    file_entry_loop: ..
      FOR file_position = 1 TO $size(intve_paths) DO
        source_file = intve_paths(file_position)
        target_file = pacs_paths(file_position)
        create_target_catalog = pacs_paths(file_position)
        element_count = $path($fname(create_target_catalog), count)
        VAR
          catalog_element : array 1..element_count of string
        VAREND
      save_catalog_paths: ..
        FOR catalog_position = 3 TO (element_count - 1) DO
          catalog_element(catalog_position) = $path($fname(create_target_catalog), catalog)
          create_target_catalog = $path($fname(create_target_catalog), catalog)
        FOREND save_catalog_paths
      create_catalog_loop: ..
        FOR catalog_count = (element_count - 1) TO 3 BY - 1 DO
          create_catalog catalog=$fname(catalog_element(catalog_count)) status=local_status
          EXIT copy_block WHEN NOT local_status.normal AND ..
                local_status.condition <> PFE$NAME_ALREADY_SUBCATALOG
          local_status.normal = true
        FOREND create_catalog_loop
        delete_variable name=catalog_element status=ignore_status
        copy_file input=$fname(source_file) output=$fname(target_file) status=local_status
        IF NOT local_status.normal AND ..
           local_status.condition <> FSE$EMPTY_INPUT_FILE THEN
          disv local_status output=$response status=ignore_status
          local_status = $status(true)
          copy_error = true
        IFEND
      FOREND file_entry_loop
      IF copy_error THEN
        local_status = $status(false, 'WE', wee$errors_in_pacs_catalog)
      IFEND

    BLOCKEND copy_block
    EXIT_PROC  WHEN NOT local_status.normal


    VAR
       myfile: string = '.'//$job(user)//'.'//qcu_ident//'_QF'
       temp2 : string = $unique
       level : string
       work : string
    VAREND

    copf $fname(pacs_commands_file) $fname(myfile)
    detf $fname(myfile) status=ignore

    EDIF f=$fname(myfile)  p=$null o=$fname(temp2)
       rewf $fname(temp2)
       l ' level='
       QUIT

    accl v=work i=$fname(temp2)
    level = $substr(work,19,6)
    EDIF f=$fname(myfile) p=$null o=$null
       R level $string(qcu_ident)
       QUIT

    rewf $fname(myfile) status=ignore
    include_command command='PACKAGE_SOFTWARE' status=pacs_status
  pacs_block: ..
    BLOCK
      EXIT pacs_block WHEN NOT pacs_status.normal
      include_file file=$fname(myfile) status=local_status
    BLOCKEND pacs_block
    include_command command='quit' status=ignore_status

    IF NOT pacs_status.normal THEN
      IF NOT local_status.normal THEN
        display_value value=pacs_status output=$response status=ignore_status
        EXIT_PROC
      ELSE
        local_status = pacs_status
        EXIT_PROC WITH local_status
      IFEND
    ELSEIF NOT local_status.normal THEN
      EXIT_PROC WITH local_status
    IFEND

  detach_file file=$fname(alternate_intve_paths_file) status=ignore_status
  detach_file file=$fname(error_output) status=ignore_status
  detach_file file=$fname(formats_file) status=ignore_status
  detach_file file=$fname(intve_paths_file) status=ignore_status
  detach_file file=$fname(pacs_commands_file) status=ignore_status
  detach_file file=$fname(pacs_paths_file) status=ignore_status
  detach_file file=$fname(subproduct_file) status=ignore_status
  detach_file file=$fname(temp_subproduct_file) status=ignore_status

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND qcm$generate_levels
*DECK DECK=QCM$GENERATE_PLATFORM EXPAND=TRUE
PROCEDURE qcm$generate_platform, generate_platform, genpf  (
  qcu_ident, qi: data_name = $required
  status)


  VAR
    wev$working_catalog :(XREF) string
    product_table :(XDCL) string
    pacs_catalog :(XDCL) string
    licensed_products : string = 'all'
    include_subproducts : name
    exclude_subproducts : name
    use_alternate_intve_paths : boolean = FALSE
    alternate_intve_paths_file : string= $unique
    catalog_count : integer
    copy_error : boolean= false
    create_target_catalog : string
    element_count : integer
    errors_found : boolean
    error_output : string= $unique
    formats : list 0..$max_list of string
    formats_file : string= $unique
    ignore_status : status
    intve_paths : list 0..$max_list of string
    intve_paths_file : string= $unique
    local_status : status
    pacs_commands_file : string= $unique
    pacs_paths : list 0..$max_list of string
    pacs_paths_file : string= $unique
    pacs_status : status
    source_file : string
    subproduct_file : string= $unique
    subproduct_list : list 0..$max_list of string
    target_file : string
    temp_list : list 0..$max_list of string
    temp_subproduct_file : string= $unique
    compile_file : string = $unique
    get_all : boolean = FALSE
    ignore : status
    selection_criteria_file : string = $unique
    wev$pacs_catalog : string = $string(pacs_catalog)

  VAREND

putl ''
putl ' Begin Platform generation'
genpc_block: ..
  BLOCK


product_table = wev$working_catalog
product_table = product_table//'.object.maintenance.qcf$base_product_table'
pacs_catalog = '.'//$job(user)//'.'//$string(qcu_ident)//'_PA'

 disc $fname(pacs_catalog) do=permits output=$null status=local_status
    IF NOT local_status.normal THEN
      IF local_status.condition = PFE$UNKNOWN_LAST_SUBCATALOG THEN
        create_catalog catalog=$fname(pacs_catalog) status=local_status
      IFEND
      EXIT_PROC with local_status WHEN NOT local_status.normal
    IFEND
get_products pt=$fname(product_table) ..
  pacc=$fname(pacs_catalog) ..
  lp=all,,,aip=$fname(alternate_intve_paths_file),ip=$fname(intve_paths_file) ..
  f=$fname(formats_file),pp=$fname(pacs_paths_file)  ..
  pc=$fname(pacs_commands_file) status=local_status

      EXIT_PROC with local_status WHEN NOT local_status.normal

    accept_line variable=formats input=$fname(formats_file) status=local_status
    EXIT genpc_block WHEN NOT local_status.normal
    IF use_alternate_intve_paths THEN
      accept_line variable=intve_paths input=$fname(alternate_intve_paths_file) status=local_status
      EXIT genpc_block WHEN NOT local_status.normal
    ELSE
      accept_line variable=intve_paths input=$fname(intve_paths_file) status=local_status
      EXIT genpc_block WHEN NOT local_status.normal
    IFEND
    EXIT genpc_block WHEN ($size(formats) <> $size(intve_paths))
    set_file_attributes file=$fname(error_output) page_format=continuous status=ignore_status
    FOR list = 1 TO $size(intve_paths) DO
      verify_file_entry file_name=$fname(intve_paths(list)) format=$name(formats(list)) status=local_status
      IF NOT local_status.normal THEN
        display_value value=local_status output=$fname(error_output//'.$eoi') status=ignore_status
        errors_found = true
      IFEND
    FOREND
    IF errors_found THEN
      copy_file input=$fname(error_output) output=$response status=ignore_status
      local_status = $status(false, 'WE', wee$errors_in_product_table)
      EXIT genpc_block
    IFEND

    accept_line variable=pacs_paths input=$fname(pacs_paths_file) status=local_status
    EXIT genpc_block WHEN NOT local_status.normal

    EXIT genpc_block WHEN ($size(intve_paths) <> $size(pacs_paths))


  get_subproduct_list_block: ..
    BLOCK

      get_subproduct_list pt=$fname(product_table) licensed_product=all ..
          output=$fname(temp_subproduct_file//'.$eoi') status=local_status
      EXIT get_subproduct_list_block WHEN NOT local_status.normal
      standardize_name_list input=$fname(temp_subproduct_file) output=$fname(subproduct_file) ..
          status=local_status
      EXIT get_subproduct_list_block WHEN NOT local_status.normal

    BLOCKEND get_subproduct_list_block
    EXIT genpc_block WHEN NOT local_status.normal

    accept_line variable=subproduct_list input=$fname(subproduct_file) status=local_status
    EXIT genpc_block WHEN NOT local_status.normal

    FOR EACH subcatalog IN subproduct_list DO
      delete_catalog catalog=pacs_catalog//$name(subcatalog) delete_option=catalog_and_contents ..
            status=ignore_status
    FOREND

  copy_block: ..
    BLOCK

    file_entry_loop: ..
      FOR file_position = 1 TO $size(intve_paths) DO
        source_file = intve_paths(file_position)
        target_file = pacs_paths(file_position)
        create_target_catalog = pacs_paths(file_position)
        element_count = $path($fname(create_target_catalog), count)
        VAR
          catalog_element : array 1..element_count of string
        VAREND
      save_catalog_paths: ..
        FOR catalog_position = 3 TO (element_count - 1) DO
          catalog_element(catalog_position) = $path($fname(create_target_catalog), catalog)
          create_target_catalog = $path($fname(create_target_catalog), catalog)
        FOREND save_catalog_paths
      create_catalog_loop: ..
        FOR catalog_count = (element_count - 1) TO 3 BY - 1 DO
          create_catalog catalog=$fname(catalog_element(catalog_count)) status=local_status
          EXIT copy_block WHEN NOT local_status.normal AND ..
                local_status.condition <> PFE$NAME_ALREADY_SUBCATALOG
          local_status.normal = true
        FOREND create_catalog_loop
        delete_variable name=catalog_element status=ignore_status
        copy_file input=$fname(source_file) output=$fname(target_file) status=local_status
        IF NOT local_status.normal THEN
          display_value value=local_status output=$response status=ignore_status
          local_status = $status(true)
          copy_error = true
        IFEND
      FOREND file_entry_loop
      IF copy_error THEN
        local_status = $status(false, 'WE', wee$errors_in_pacs_catalog)
      IFEND

    BLOCKEND copy_block
    EXIT genpc_block WHEN NOT local_status.normal

    VAR
       myfile: string = '.'//$job(user)//'.'//qcu_ident//'_CF'
    VAREND

    copf $fname(pacs_commands_file) $fname(myfile)
    detf $fname(myfile) status=ignore


    include_command command='PACKAGE_SOFTWARE' status=pacs_status
  pacs_block: ..
    BLOCK
      EXIT pacs_block WHEN NOT pacs_status.normal
      include_file file=$fname(pacs_commands_file) status=local_status
    BLOCKEND pacs_block
    include_command command='quit' status=ignore_status

    IF NOT pacs_status.normal THEN
      IF NOT local_status.normal THEN
        display_value value=pacs_status output=$response status=ignore_status
        EXIT genpc_block
      ELSE
        local_status = pacs_status
        EXIT genpc_block
      IFEND
    ELSEIF NOT local_status.normal THEN
      EXIT genpc_block
    IFEND

  BLOCKEND genpc_block
  detach_file file=$fname(alternate_intve_paths_file) status=ignore_status
  detach_file file=$fname(error_output) status=ignore_status
  detach_file file=$fname(formats_file) status=ignore_status
  detach_file file=$fname(intve_paths_file) status=ignore_status
  detach_file file=$fname(pacs_commands_file) status=ignore_status
  detach_file file=$fname(pacs_paths_file) status=ignore_status
  detach_file file=$fname(subproduct_file) status=ignore_status
  detach_file file=$fname(temp_subproduct_file) status=ignore_status

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND qcm$generate_platform
*DECK DECK=QCM$GENERATE_QCU_DEADSTART_CAT EXPAND=TRUE
PROCEDURE qcp$generate_qcu_deadstart_cat (
 output, o: file = $output
  status)

      VAR
        qcv$system: (XDCL) file = $SYSTEM
      VAREND



IF $file($value(output) open_position) = '$BOI' THEN
   ofile = $string($value(output)) //'.$ASIS'
ELSE
   ofile = $string($value(output))
IFEND

  "$FORMAT=OFF"
  VAR
    name_sou_library: name = sou_library
    name_builtin_library: name = builtin_library
    name_dcfile: name = dcfile
    name_deadstart_catalog: name = deadstart_catalog
    name_deadstart_commands_catalog: name = deadstart_commands
    name_jt_link_map: name = job_template_link_map
    name_link_input_catalog: name = link_input_files
    name_link_output_catalog: name = link_output_files
    name_mf_config_catalog: name = mf_config_files
    name_mf_config_files: name = mf_config_files
    name_non_boot_drivers_catalog: name = non_boot_drivers
    name_non_boot_drivers_file: name = non_boot_drivers
    name_nosve_maintenance_catalog: name = nosve_maintenance
    name_os_version_file: name = os_version
    name_osf$builtin_library: name = osf$builtin_library
    name_osf$sou_library: name = osf$sou_library
    name_physical_config: name = physical_config
    name_physical_configuration: name = physical_configuration
    name_product_files_catalog: name = product_files
    name_prolog_file: name = prolog_file
    name_prolog_library: name = prolog_library
    name_sc_link_map: name = system_core_link_map
    name_site_maintenance_catalog: name = site_os_maintenance
    name_system_debug_table: name = system_debug_table
  VAREND
  "$FORMAT=ON"


  VAR
    bacpf_file: file = $local//$name($unique)
    command_file: file = $local//$name($unique)
    configuration_files_catalog: file
    ignore_status: status
    local_status: status

    name_qcu_maintenance_catalog: name = qcu_maintenance
    name_qcu_log_file: name = qcu_log
    name_qcu_field_maintenance: name = field_maintenance
    name_qcu_state: name = site_modifications
    name_os_version: name = os_version
    name_deadstart_commands: name = deadstart_commands

    new_sou_library: file
    new_builtin_library: file
    new_deadstart_catalog: file
    new_link_output_catalog: file
    new_non_boot_drivers_file: file
    new_version_catalog: file

    nosve_sou_library: file
    nosve_builtin_library: file
    nosve_deadstart_catalog: file
    nosve_link_input_catalog: file
    nosve_maintenance_catalog: file
    nosve_non_boot_drivers_file: file
    nosve_version_file: file

    qcu_maintenance_catalog: file
    qcu_link_input_catalog: file
    qcu_log_file: file
    qcu_state_file: file
    qcu_field_maintenance_catalog: file
    qcu_version_file: file

    site_sou_library: file
    site_builtin_library: file
    site_maintenance_catalog: file
    site_non_boot_drivers_catalog: file

    system_level: name
    text: string
  VAREND
  "$FORMAT=ON"



main_block: ..
  BLOCK



    nosve_maintenance_catalog = qcv$system//name_nosve_maintenance_catalog
    nosve_deadstart_catalog = nosve_maintenance_catalog//name_deadstart_catalog
    nosve_non_boot_drivers_file = nosve_deadstart_catalog//name_non_boot_drivers_file
    nosve_builtin_library = nosve_deadstart_catalog//name_product_files_catalog//name_builtin_library
    nosve_sou_library = nosve_deadstart_catalog//name_product_files_catalog//name_sou_library
    nosve_link_input_catalog = nosve_maintenance_catalog//name_link_input_catalog

    qcu_field_maintenance_catalog = qcv$system//name_qcu_field_maintenance
    qcu_log_file = qcu_field_maintenance_catalog//name_qcu_log_file
    qcu_state_file = qcu_field_maintenance_catalog//name_qcu_state
    qcu_maintenance_catalog = qcv$system//name_qcu_maintenance_catalog
    qcu_link_input_catalog = qcu_maintenance_catalog//name_link_input_catalog
    qcu_version_file = qcu_link_input_catalog//name_os_version

     IF NOT $file(qcu_maintenance_catalog,catalog) THEN
       $system.put_line ' ' o=$fname(ofile//'.$eoi')
       $system.put_line '                        STOP' o=$fname(ofile//'.$eoi')
       $system.put_line '          Material necessary for the generation of ' o=$fname(ofile//'.$eoi')
       $system.put_line '          a new correction system is not available.'   o=$fname(ofile//'.$eoi')
       $system.put_line '          You must issue a INSTALL_FIELD_CORRECTION'     o=$fname(ofile//'.$eoi')
       $system.put_line '          request before attempting to generate a'  o=$fname(ofile//'.$eoi')
       $system.put_line '          new correction system.'       o=$fname(ofile//'.$eoi')
       $system.put_line ' ' o=$fname(ofile//'.$eoi')
       delete_catalog qcu_field_maintenance_catalog cac status=ignore_status
       EXIT_PROC
     IFEND
     IF NOT $file(qcu_field_maintenance_catalog,catalog) THEN
       $system.put_line ' ' o=$fname(ofile//'.$eoi')
       $system.put_line '                        STOP' o=$fname(ofile//'.$eoi')
       $system.put_line '          Material necessary for the generation of ' o=$fname(ofile//'.$eoi')
       $system.put_line '          a new correction system is not available.'   o=$fname(ofile//'.$eoi')
       $system.put_line '          You must issue a INSTALL_FIELD_CORRECTION'     o=$fname(ofile//'.$eoi')
       $system.put_line '          request before attempting to generate a'  o=$fname(ofile//'.$eoi')
       $system.put_line '          new correction system.'       o=$fname(ofile//'.$eoi')
       $system.put_line ' ' o=$fname(ofile//'.$eoi')
       EXIT_PROC
     IFEND

    $system.delete_file f=qcu_state_file status=ignore_status
    get_correction_level ovf=qcu_version_file sl=system_level status=local_status
    EXIT main_block WHEN NOT local_status.normal

    site_maintenance_catalog = qcv$system//name_site_maintenance_catalog
    site_non_boot_drivers_catalog = site_maintenance_catalog//name_non_boot_drivers_catalog
    site_builtin_library = site_maintenance_catalog//name_osf$builtin_library
    site_sou_library = site_maintenance_catalog//name_osf$sou_library

    configuration_files_catalog = site_maintenance_catalog//name_deadstart_commands
    new_version_catalog = qcu_maintenance_catalog//system_level
    new_deadstart_catalog = new_version_catalog//name_deadstart_catalog
    new_link_output_catalog = new_version_catalog//name_link_output_catalog
    new_non_boot_drivers_file = new_deadstart_catalog//name_non_boot_drivers_file
    new_builtin_library = new_deadstart_catalog//name_product_files_catalog//name_builtin_library
    new_sou_library = new_deadstart_catalog//name_product_files_catalog//name_sou_library



  build_dc_block: ..
    BLOCK

      $system.delete_file qcu_log_file status=ignore_status

" initialize the new deadstart catalog - delete the old, create the new.

      $system.delete_catalog c=new_version_catalog do=catalog_and_contents status=ignore_status
COLLECT_TEXT o=command_file until='**' sm='?'
      $system.create_catalog c=new_version_catalog
      $system.create_catalog c=new_deadstart_catalog
      $system.create_catalog c=new_link_output_catalog
**
      $system.include_file f=command_file status=local_status
      $system.delete_file f=command_file status=ignore_status
      EXIT build_dc_block WHEN NOT local_status.normal

      $system.put_line ' ' o=$fname(ofile//'.$eoi')
      $system.put_line '     Begin Generation of the Corrected System' o=$fname(ofile//'.$eoi')
      $system.put_line '              Deadstart Catalog Path is ...' o=qcu_log_file.$EOI
      $system.put_line '      '//$string(new_deadstart_catalog) o=qcu_log_file.$EOI
      $system.put_line ' ' o=qcu_log_file.$EOI


" Move the deadstart catalog from nosve_maintenance to
" qcu_maintenance to use as a base for the new system.

COLLECT_TEXT o=command_file until='**'
  $system.BACKUP_PERMANENT_FILE bf=bacpf_file
    backup_catalog c=nosve_deadstart_catalog
    quit
  $system.RESTORE_PERMANENT_FILE l=$null
    restore_existing_catalog c=nosve_deadstart_catalog ..
                             ncn=new_deadstart_catalog ..
                             bf=bacpf_file
    quit
  $system.BACKUP_PERMANENT_FILE bf=$null
    exclude_highest_cycle number_of_cycles=1
    delete_catalog_content c=new_deadstart_catalog
    quit

**
      $system.include_file f=command_file status=local_status
      $system.delete_file f=command_file status=ignore_status
      $system.delete_file f=bacpf_file status=ignore_status
      EXIT build_dc_block WHEN NOT local_status.normal




"   If there are local changes to the sites builtin_library then
"   combine the site-specified version of the file with the
"   system released version of the file and put the result in
"   the file new_builtin_library.


  IF $file(site_builtin_library permanent) THEN
    $system.put_line ' '
    $system.put_line '      Combining the sites BUILTIN_LIBRARY' o=$fname(ofile//'.$eoi')
    $system.put_line '                               with' o=$fname(ofile//'.$eoi')
    $system.put_line '              the systems BUILTIN_LIBRARY' o=$fname(ofile//'.$eoi')

    $system.put_line 'BUILTIN_LIBRARY'   o=qcu_state_file.$eoi  status=ignore_status

COLLECT_TEXT o=command_file until='**'
  $system.CREATE_OBJECT_LIBRARY
    add_modules l=nosve_builtin_library
    combine_modules l=site_builtin_library
    generate_library l=new_builtin_library
  QUIT
**
    $system.include_file command_file status=local_status
    $system.delete_file command_file status=ignore_status

  IFEND

"   If there are local changes to the sites sou_library then
"   combine the site-specified version of the file with the
"   system released version of the file and put the result in
"   the file new_sou_library.


  IF $file(site_sou_library permanent) THEN
    $system.put_line ' '
    $system.put_line '      Combining the sites SOU_LIBRARY' o=$fname(ofile//'.$eoi')
    $system.put_line '                               with' o=$fname(ofile//'.$eoi')
    $system.put_line '              the systems SOU_LIBRARY' o=$fname(ofile//'.$eoi')

    $system.put_line 'SOU_LIBRARY'   o=qcu_state_file.$eoi  status=ignore_status

COLLECT_TEXT o=command_file until='**'
  $system.CREATE_OBJECT_LIBRARY
    add_modules l=nosve_sou_library
    combine_modules l=site_sou_library
    generate_library l=new_sou_library
  QUIT
**
    $system.include_file command_file status=local_status
    $system.delete_file command_file status=ignore_status

  IFEND


      copy_configuration configuration_files_catalog=configuration_files_catalog ..
            deadstart_catalog=new_deadstart_catalog status=local_status
      EXIT build_dc_block WHEN NOT local_status.normal




      $system.put_line '    Begin link of OS files    ' o=qcu_log_file.$EOI

      link_generated_qcu ..
            nlic=qcu_link_input_catalog slic=site_maintenance_catalog ..
            dc=new_deadstart_catalog loc=new_link_output_catalog ..
            output=$value(output) status=local_status
      EXIT build_dc_block WHEN NOT local_status.normal

      $system.put_line ' Completed link of OS files ' o=qcu_log_file.$eoi



      combine_drivers nnbdf=nosve_non_boot_drivers_file ..
            snbdc=site_non_boot_drivers_catalog ..
            nbdf=new_non_boot_drivers_file status=local_status
      EXIT build_dc_block WHEN NOT local_status.normal
      $system.put_line ' Completed driver combine' o=qcu_log_file.$eoi

      $system.put_line '     End Generation of the Corrected System' o=output
      $system.put_line '                  the ' o=output
      $system.put_line '     New deadstart catalog path is ..' o=output
      $system.put_line '        '//$string(new_deadstart_catalog)  o=output
      $system.put_line ' ' o=output
    BLOCKEND build_dc_block

  BLOCKEND main_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal
  $system.put_line 'Normal completion from gencs' o=qcu_log_file.$eoi

PROCEND qcp$generate_qcu_deadstart_cat
*DECK DECK=QCM$GENERATE_QCU_DS_TAPE EXPAND=TRUE
PROCEDURE qcm$generate_qcu_ds_tape, generate_qcu_ds_tape, genqdt (
  external_vsn, evsn: string 1..6 = $required
  recorded_vsn, rvsn: string 1..6 = $optional
  type, t: any of
      key
        mt9$1600
        mt9$6250
        mt18$38000
      keyend
    anyend = mt9$6250
  delete_tape_files, dtf: boolean = TRUE
  product_files, pf: list of file = $optional
  build_level, bl: name = $optional
  feature_catalog, fc: any of
      key
        none
      keyend
      file
    anyend = none
  feature_build_level, fbl: name = object
  working_catalog, wc: any of
      key
        none
      keyend
      file
    anyend = none
  working_build_level, wbl: name = object
  status)

IF NOT $variable(wev$default_file_server defined) THEN
  VAR
    wev$default_file_server : (ENVIRONMENT) string
  VAREND
  check_default_file_server
IFEND
IF NOT $variable(wev$default_dev_base_family defined) THEN
  VAR
    wev$default_dev_base_family : (ENVIRONMENT) string
  VAREND
  set_environment_defaults
IFEND
VAR
  development_base : file = wev$development_base, $fname(wev$default_dev_base_family//'.INTVE')
  wev$development_base : (ENVIRONMENT) string = $string(development_base)
  server_development_base : file = wev$server_development_base, $fname($string(wev$default_file_server)//..
$trim($substr(wev$development_base, $scan_string('.', wev$development_base), $strlen(wev$development_base))))
  wev$server_development_base : (ENVIRONMENT) string = $string(server_development_base)
VAREND
IF $specified(build_level) THEN
  create_variable wev$build_level kind=string scope=xdcl ..
    value=$string($value(build_level))
ELSEIF $variable(wev$build_level,declared) = 'NONLOCAL' THEN
  create_variable wev$build_level kind=string scope=xref
ELSE
  create_variable wev$build_level kind=string scope=xdcl value='NONE'
IFEND

IF $specified(feature_catalog) THEN
  create_variable wev$feature_catalog kind=string scope=xdcl ..
    value=$string($value(feature_catalog))
ELSEIF $variable(wev$feature_catalog,declared) = 'NONLOCAL' THEN
  create_variable wev$feature_catalog kind=string scope=xref
ELSE
  create_variable wev$feature_catalog kind=string scope=xdcl ..
    value=$string($value(feature_catalog))
IFEND

IF $specified(feature_build_level) THEN
  create_variable wev$feature_build_level kind=string scope=xdcl ..
    value=$string($value(feature_build_level))
ELSEIF $variable(wev$feature_build_level,declared) = 'NONLOCAL' THEN
  create_variable wev$feature_build_level kind=string scope=xref
ELSE
  create_variable wev$feature_build_level kind=string scope=xdcl ..
    value=$string($value(feature_build_level))
IFEND


IF $specified(working_catalog) THEN
  create_variable wev$working_catalog kind=string scope=xdcl value=$string($value(working_catalog))
ELSEIF $variable(wev$working_catalog, declared) = 'NONLOCAL' THEN
  create_variable wev$working_catalog kind=string scope=xref
ELSE
  create_variable wev$working_catalog kind=string value='NONE'
IFEND
IF wev$working_catalog = 'NONE' THEN
  EXIT_PROC WITH $status(false, 'WE', wee$unspecified_working_cat)
IFEND

IF ($variable(wev$ignore_status, declared) = 'LOCAL') OR ($variable(wev$local_status, declared) = 'LOCAL') ..
      THEN
  EXIT_PROC WITH $status(false, 'WE', wee$declared_status_variables)
IFEND

create_variable (wev$ignore_status, wev$local_status) k=status

attach_file $fname(wev$working_catalog//'.source_library') status=wev$local_status
detach_file $fname(wev$working_catalog//'.source_library') status=wev$ignore_status
IF (wev$local_status.normal = false) AND (..
      ($condition(wev$local_status.condition) = 'PFE$UNKNOWN_LAST_SUBCATALOG') OR ..
      ($condition(wev$local_status.condition) = 'PFE$UNKNOWN_NTH_SUBCATALOG')) THEN
  delete_variable (wev$ignore_status, wev$local_status)
  EXIT_PROC WITH $status(false, 'WE', wee$undefined_working_catalog)
IFEND

delete_variable (wev$ignore_status, wev$local_status)
IF $specified(working_build_level) THEN
  create_variable wev$working_build_level kind=string scope=xdcl ..
    value=$string($value(working_build_level))
ELSEIF $variable(wev$working_build_level,declared) = 'NONLOCAL' THEN
  create_variable wev$working_build_level kind=string scope=xref
ELSE
  create_variable wev$working_build_level kind=string scope=xdcl ..
    value=$string($value(working_build_level))
IFEND


  "$FORMAT=OFF"
  TYPE
    files_record: RECORD
    name: string 0 .. $max_name
    file_id: string 1 .. 17
    RECEND
  TYPEND
  "$FORMAT=ON"

  "$FORMAT=OFF"
  VAR
    bl_path: string
    block_type: name
    boot_image_exists : boolean
    build_level_path: string
    cip_path: string
    deadstart_files_defined: boolean = FALSE
    deadstart_lists: string 0 .. $max_name = $unique
    deadstart_tape: string 0 .. $max_name = $unique
    fbl_path: string
    fbl_pp_path: string
    file_count: integer
    file_id: string 0 .. $max_name
    file_name: file
    ignore_status: status
    index: integer
    local_status: status
    maintenance_path: string
    message : string
    pps_exists : boolean
    record_type: name
    wbl_path: string
    wbl_pp_path: string
    temp_product_list: list 0 .. $max_list of file
    total_deadstart_file_count: integer
  VAREND
  "$FORMAT=ON"

gendt_block: ..
  BLOCK

    IF wev$build_level = 'NONE' THEN
      local_status=$status(false, 'WE', wee$unspecified_build_level_var)
      EXIT gendt_block
    IFEND

    cip_path='('
    build_level_path='('
    maintenance_path='('


    wbl_path=wev$working_catalog//'.'//wev$working_build_level
    wbl_pp_path=wbl_path//'.maintenance.osf$pp'
    cip_path=cip_path//wbl_path//'.cip '
    build_level_path=build_level_path//wbl_path//' '
    maintenance_path=maintenance_path//wbl_path//'.maintenance '


    IF wev$feature_catalog <> 'NONE' THEN
      fbl_path=wev$feature_catalog//'.'//wev$feature_build_level
      fbl_pp_path=fbl_path//'.maintenance.osf$pp'
      cip_path=cip_path//fbl_path//'.cip '
      build_level_path=build_level_path//fbl_path//' '
      maintenance_path=maintenance_path//fbl_path//'.maintenance '
    IFEND


    bl_path=wev$server_development_base//'.OS.'//wev$build_level
    cip_path=cip_path//bl_path//'.cip)'
    build_level_path=build_level_path//bl_path//')'
    maintenance_path=maintenance_path//bl_path//'.maintenance)'


    boot_image_exists = $file($fname(wbl_path//'.boot_image'), permanent) OR ..
          $file($fname(fbl_path//'.boot_image'), permanent)

    pps_exists = ($file($fname(wbl_pp_path), catalog) AND ..
          NOT $nil($catalog_contents($fname(wbl_pp_path), include_files)))
    IF wev$feature_catalog <> 'NONE' THEN
      pps_exists = pps_exists OR ($file($fname(fbl_pp_path), catalog) AND ..
          NOT $nil($catalog_contents($fname(fbl_pp_path), include_files)))
    IFEND

    IF boot_image_exists OR pps_exists THEN
      putl ''
      put_line l=' Build CIP and NON_BOOT_DRIVERS files.' o=$response
      generate_cip_components status=local_status
      EXIT gendt_block WHEN NOT local_status.normal
    IFEND

    putl ''
    put_line l=' Generate QCU Deadstart tape ' o=$response

    get_source d=dst$deadstart_record_lists s=$fname(deadstart_lists) pn=os status=local_status
    EXIT gendt_block WHEN NOT local_status.normal
    include_file f=$fname(deadstart_lists) status=local_status
    EXIT gendt_block WHEN NOT local_status.normal

    IF $specified(product_files) THEN
      total_deadstart_file_count=deadstart_file_count + $size(product_files)
    ELSE
      total_deadstart_file_count=deadstart_file_count
    IFEND

    "$FORMAT=OFF"
    VAR
      deadstart_files: ARRAY 1 .. total_deadstart_file_count OF files_record
    VAREND
    "$FORMAT=ON"

    FOR index = 1 TO total_deadstart_file_count DO
      deadstart_files(index).name=$unique
    FOREND
    deadstart_files_defined=true

    putl ''
    put_line l=' Acquire files.' o=$response

    file_count=1
    FOR index = 1 TO deadstart_file_count DO
      IF index = deadstart_file_count THEN
        IF $specified(product_files) THEN
          temp_product_list=product_files
          WHILE NOT $nil(temp_product_list) DO
            file_name=$first(temp_product_list)
            temp_product_list=$rest(temp_product_list)
            attach_file f=file_name lfn=$name(deadstart_files(file_count).name) am=(read, execute) sm=(read,..
                   execute) status=local_status
            EXIT gendt_block WHEN NOT local_status.normal
            put_line l='   Attaching  '//file_name o=$response
            file_id=$strrep($first($reverse($path_elements(file_name))))
            IF $size(file_id)> 17 THEN
              deadstart_files(file_count).file_id=file_id(1, 17)
            ELSE
              deadstart_files(file_count).file_id=file_id
            IFEND
            file_count=file_count + 1
          WHILEND
        IFEND
      IFEND
      include_line sl='acqqf fn=$name(deadstart_file_list(index).disk_name) ..
            lfn=$name(deadstart_files(file_count).name) ..
            sc='//$vname(deadstart_file_list(index).integration_path) status=local_status
      EXIT gendt_block WHEN NOT local_status.normal
      deadstart_files(file_count).file_id=deadstart_file_list(index).tape_name
      file_count=file_count + 1
    FOREND


    put_line l=' Begin writing the deadstart tape.' o=$response
    IF $specified(recorded_vsn) THEN
      message = ' Pls blank label '//external_vsn//': internal vsn='//recorded_vsn//', density='//type
      request_operator_action message=message status=ignore_status
      request_magnetic_tape f=$fname(deadstart_tape) evsn=external_vsn rvsn=recorded_vsn t=type r=true ..
            status=local_status
    ELSE
      request_magnetic_tape f=$fname(deadstart_tape) evsn=external_vsn t=type r=true status=local_status
    IFEND
    EXIT gendt_block WHEN NOT local_status.normal
    set_file_attribute f=$fname(deadstart_tape) flt=labelled status=local_status
    EXIT gendt_block WHEN NOT local_status.normal

      IF type = 'MT18$38000' THEN
       maxbl = 32640
      ELSE
       maxbl = 4128
      IFEND;

    FOR index = 1 TO total_deadstart_file_count DO
      get_block_and_record_type i=$fname(deadstart_files(index).name) bt=block_type rt=record_type ..
            status=local_status
      EXIT gendt_block WHEN NOT local_status.normal
      change_tape_label_attributes f=$fname(deadstart_tape) fsp=next_file rl=true ..
            fi=deadstart_files(index).file_id bt=block_type rt=record_type status=local_status
      EXIT gendt_block WHEN NOT local_status.normal
"     put_line l=' Copying the file, '//deadstart_files(index).file_id//', to the deadstart tape.' o=$response
      copy_file i=$fname(deadstart_files(index).name) o=$fname(deadstart_tape) status=local_status
      EXIT gendt_block WHEN NOT local_status.normal
    FOREND

    putl ''
    put_line l=' Generate DS tape complete' o=$response


    IF delete_tape_files THEN
"     put_line l=' Deleting tape files.' o=$response
      delete_file f=$fname(wbl_path//'.boot_image') status=ignore_status
      delete_file f=$fname(wbl_path//'.monitor_image') status=ignore_status
      delete_file f=$fname(wbl_path//'.system_core_image') status=ignore_status
      delete_file f=$fname(wbl_path//'.dcfile') status=ignore_status
      delete_file f=$fname(wbl_path//'.non_boot_drivers') status=ignore_status
      delete_file f=$fname(wbl_path//'.job_image') status=ignore_status
      delete_file f=$fname(wbl_path//'.system_core_symbol_table') status=ignore_status
      delete_file f=$fname(wbl_path//'.builtin_library') status=ignore_status
      delete_file f=$fname(wbl_path//'.operator_library') status=ignore_status
      delete_catalog c=$fname(wbl_path//'.cip') do=catalog_and_contents status=ignore_status
      delete_file f=$fname(wbl_path//'.files_attributes') status=ignore_status
    IFEND

"   put_line l=' End generate_deadstart_tape.' o=$response
  BLOCKEND gendt_block

  detach_file f=$fname(deadstart_lists) status=ignore_status
  detach_file f=$fname(deadstart_tape) status=ignore_status
  IF deadstart_files_defined THEN
    FOR index = 1 TO total_deadstart_file_count DO
      detach_file f=$fname(deadstart_files(index).name) status=ignore_status
    FOREND
  IFEND

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND qcm$generate_qcu_ds_tape

*DECK DECK=QCM$GET_CORRECTION_LEVEL EXPAND=TRUE

PROCEDURE qcp$get_correction_level (
 os_version_file, ovf :file = $required
 system_level, sl     : (VAR) name = $required
 status)

VAR
 level_string: string
 local_status: status
VAREND

$system.include_file f=os_version_file status=local_status
IF local_status.normal THEN
 IF $variable(level_id, defined) THEN
  system_level = level_id
 ELSE
  level_string = $trim($substr(version_id,16,6))
  system_level = $name('level_'//level_String)
 IFEND
ELSE
 EXIT procedure WITH local_status WHEN NOT local_status.normal
IFEND

PROCEND qcp$get_correction_level
*DECK DECK=QCM$GET_PRODUCTS EXPAND=TRUE



PROC qcm$get_products, get_products, getpr (
  product_table, pt                    : file = $required
  pacs_catalog, pacc                   : file = $required
  licensed_products, licensed_product, ..
  lp                                   : list of name or key all = $optional
  include_subproducts, ..
  include_subproduct, is               : list of name = $optional
  exclude_subproducts, ..
  exclude_subproduct, es               : list of name = $optional
  intve_paths, ip                      : file = $optional
  alternate_intve_paths, aip           : file = $optional
  formats, f                           : file = $optional
  pacs_paths, pp                       : file = $optional
  pacs_commands, pc                    : file = $optional
  status                               : var of status = $optional
  )


  create_variable name=alternate_intve_paths_file kind=(string, $max_name) value=$unique
  create_variable name=compile_file kind=(string, $max_name) value=$unique
  create_variable name=formats_file kind=(string, $max_name) value=$unique
  create_variable name=get_all kind=boolean value=false
  create_variable name=get_alternate_intve_paths kind=boolean value=$specified(alternate_intve_paths)
  create_variable name=get_formats kind=boolean value=$specified(formats)
  create_variable name=get_intve_paths kind=boolean value=$specified(intve_paths)
  create_variable name=get_pacs_commands kind=boolean value=$specified(pacs_commands)
  create_variable name=get_pacs_paths kind=boolean value=$specified(pacs_paths)
  create_variable name=ignore_status kind=status
  create_variable name=intve_paths_file kind=(string, $max_name) value=$unique
  create_variable name=local_status kind=status
  create_variable name=pacs_commands_file kind=(string, $max_name) value=$unique
  create_variable name=pacs_paths_file kind=(string, $max_name) value=$unique
  create_variable name=selection_criteria_file kind=(string, $max_name) value=$unique
  create_variable name=wev$pacs_catalog kind=string value=$string($value(pacs_catalog))

getpti_block: ..
  BLOCK
        put_line line='include_group group=subproduct' ..
              output=$fname(selection_criteria_file//'.$eoi') status=local_status
        EXIT getpti_block WHEN NOT local_status.normal

IF $specified(include_subproducts) THEN
      FOR count = 1 TO $size(include_subproducts) DO
        put_line line='include_deck deck='//$string($value(include_subproducts, count)) ..
              output=$fname(selection_criteria_file//'.$eoi') status=local_status
        EXIT getpti_block WHEN NOT local_status.normal
      FOREND
IFEND

IF $specified(exclude_subproducts) THEN
      FOR count = 1 TO $size(exclude_subproducts) DO
        put_line line='exclude_deck deck='//$string($value(exclude_subproducts, count)) ..
              output=$fname(selection_criteria_file//'.$eoi') status=local_status
        EXIT getpti_block WHEN NOT local_status.normal
      FOREND
IFEND


    SCU
    scu_block: ..
      BLOCK
        use_library base=$value(product_table) result=$local.$null status=local_status
        EXIT scu_block WHEN NOT local_status.normal
        expand_deck deck=none compile=$fname(compile_file) ..
              selection_criteria=$fname(selection_criteria_file) status=local_status
      BLOCKEND scu_block
      include_command command='quit no' status=ignore_status
"$command=quit format=true

    EXIT getpti_block WHEN NOT local_status.normal
    include_file file=$fname(compile_file) status=local_status
    EXIT getpti_block WHEN NOT local_status.normal

      copy_file input=$fname(intve_paths_file) output=$value(intve_paths) status=local_status
      EXIT getpti_block WHEN NOT local_status.normal

      copy_file input=$fname(alternate_intve_paths_file) output=$value(alternate_intve_paths) status=local_status
      EXIT getpti_block WHEN NOT local_status.normal

      copy_file input=$fname(pacs_paths_file) output=$value(pacs_paths) status=local_status
      EXIT getpti_block WHEN NOT local_status.normal

      copy_file input=$fname(pacs_commands_file) output=$value(pacs_commands) status=local_status
      EXIT getpti_block WHEN NOT local_status.normal

      copy_file input=$fname(formats_file) output=$value(formats) status=local_status
      EXIT getpti_block WHEN NOT local_status.normal

  BLOCKEND getpti_block

  detach_file file=$fname(alternate_intve_paths_file) status=ignore_status
  detach_file file=$fname(compile_file) status=ignore_status
  detach_file file=$fname(formats_file) status=ignore_status
  detach_file file=$fname(intve_paths_file) status=ignore_status
  detach_file file=$fname(pacs_commands_file) status=ignore_status
  detach_file file=$fname(pacs_paths_file) status=ignore_status
  detach_file file=$fname(selection_criteria_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND qcm$get_products

*DECK DECK=QCM$INSTALL_CORRECTION EXPAND=TRUE

PROC qcp$install_correction (
correction_identifier, ci: name 1 .. 7 = $required
correction_file_path, cfp: file = $required
output, o: file = $output
status )

crev local_status k=status
crev ignore k=status
crev msg k=string
crev work k=string
crev count
crev check k=boolean


IF $file($value(output) open_position) = '$BOI' THEN
   ofile = $string($value(output)) //'.$ASIS'
ELSE
   ofile = $string($value(output))
IFEND

"**********************************************************************
" Establish the default values for this session
"**********************************************************************
crev qev$correction_base k=string s=xdcl
crev qev$installation_base k=string s=xdcl
crev qev$modifier_base k=string s=xdcl
crev qev$correction_identifier k=string s=xdcl



"**************************************************************************
" Setup default values
"**************************************************************************
qev$correction_base   =   ':$SYSTEM.$SYSTEM.FIELD_MAINTENANCE'
qev$target_base       =   ':$SYSTEM.$SYSTEM.QCU_MAINTENANCE'
qev$modifier_base     =   ':$SYSTEM.$SYSTEM.NOSVE_MAINTENANCE'
qev$correction        =   $string($value(correction_identifier))


crev tc_path k=string v=qev$target_base//'.LINK_INPUT_FILES'
crev cc_path k=string v=qev$correction_base//'.'//qev$correction
     cc_path = cc_path//'.LINK_INPUT_FILES'
crev er_path k=string v=qev$correction_base//'.'//qev$correction

crev mc_path k=string v=qev$modifier_base//'.LINK_INPUT_FILES'
crev id_path k=string v=qev$target_base//'.identification'
crev name_path k=string v=qev$correction_base//'.'//qev$correction//'.NAMES.$ASIS'
crev temp1 k=string v=$unique//'.$asis'
crev temp2 k=string v=$unique//'.$asis'
crev li_path k=string v=qev$correction_base//'.'//qev$correction
     li_path = li_path//'.LINK_INPUT_FILES.OS_VERSION'
crev ll_path k=string v=qev$correction_base//'.LINK_INPUT_FILES'
crev cp_path k=string v=qev$correction_base//'.PATHS'
crev psr_path k=string v=qev$correction_base//'.PSRS'


" Make sure that the field_maintenance and correction base
" catalogs exist.

detf $fname(cp_path) status=ignore

IF NOT  $file($fname(qev$modifier_base),catalog) THEN
 putl ' Unable to generate a correction system due to absence' o=$fname(ofile//)
 putl ' of the '//qev$modifier_base//' catalog' o=$fname(ofile//)
 EXIT_PROC
IFEND

crec $fname(qev$target_base) status=ignore
crec $fname(tc_path) status=ignore

putl ''   o=$fname(ofile//'.$eoi')
putl '    Begin Correction Installation' o=$fname(ofile//'.$eoi')
putl '' o=$fname(ofile//'.$eoi')
"**********************************************************************
" Fetch the repair record via the correction file path and initialize
" the correction base environment. The repair record is broken into
" three files and one catalog:
" NAMES - a file containing the names of the libraries modified by
"         this correction.
" HEADER - an image of the corrections repair record header.
"
" FIELD_MAINTENANCE.(correction id).LINK_INPUT_FILES. this is the
"         catalog that contains the modified binaries.
"
" PSRS - a file containing a list of all PSRs corrected by the contents
"        of this correction package.
"**********************************************************************
establish_qcu_environment,$value(correction_identifier), ..
 $value(correction_file_path),check
            IF NOT check THEN
              EXIT_PROC
            IFEND
include_file $fname(li_path)
" save the identifier for later use
putl $string(level_id) o=$fname(id_path)

display_catalog $fname(cc_path) o=$fname(temp2)
rewf $fname(temp2) status=ignore
crev libnew k=string d=1..20 v=''
crev libnc v=1
accl v=work i=$fname(temp2//'.$asis') lc=count
WHILE count >0 DO
 IF $substr(work,5,5) = 'FILE:' THEN
   libnew(libnc) = $substr(work,11,$strlen(work))
   libnc = libnc + 1
 IFEND
 accl v=work i=$fname(temp2//'.$asis') lc=count
WHILEND

display_catalog $fname(mc_path) o=$fname(temp1)
rewf $fname(temp1) status=ignore
crev libold k=string d=1..20 v=''
crev liboc v=1
accl v=work i=$fname(temp1//'.$asis') lc=count
WHILE count >0 DO
 IF $substr(work,5,5) = 'FILE:' THEN
   libold(liboc) = $substr(work,11,$strlen(work))
   liboc = liboc + 1
 IFEND
 accl v=work i=$fname(temp1//'.$asis') lc=count
WHILEND

 crev bf_path k=string
 crev cf_path k=string
 crev tf_path k=string
 crev lf_path k=string
 crev repair  k=boolean


       FOR i = 1 TO liboc-1 DO
         IF libold(i) <> 'OS_VERSION' THEN
            lib = libold(i)
                repair = FALSE
              FOR j = 1 TO libnc DO
                IF libnew(j) = lib THEN
                   repair = TRUE
                   EXIT
                IFEND
              FOREND
          IFEND
            cf_path = cc_path//'.'//lib
            bf_path = mc_path//'.'//lib
            tf_path = tc_path//'.'//lib
            lf_path = ll_path//'.'//lib
          IF repair THEN
               putl '       Repairing Library '//lib   o=$fname(ofile//'.$eoi')
               apply_correction,$fname(bf_path),$fname(cf_path),$fname(tf_path),status=local_status
                IF NOT local_status.normal THEN
                 EXIT_PROC WITH local_status
                IFEND
                  " Save the paths and modified libraries
                 rewf $fname(tf_path) status=ignore
                 copf $fname(tf_path) $fname(lf_path)
                  msg = $trim(lib)
                  msg = msg//$substr('',1,30-$strlen(msg))//ci
                  putl msg  o=$fname(cp_path//'.$eoi')

           ELSE
             IF $file($fname(lf_path),permanent) THEN
                copy_file $fname(lf_path) $fname(tf_path) status=local_status
             ELSE
                copy_file $fname(bf_path) $fname(tf_path) status=local_status
             IFEND
               IF NOT local_status.normal THEN
                  EXIT_PROC WITH local_status
               IFEND
           IFEND
           FOREND

           copy_file $fname(cc_path//'.OS_VERSION') $fname(tc_path//'.OS_VERSION') status=local_status
               IF NOT local_status.normal THEN
                  EXIT_PROC WITH local_status
               IFEND

crev hi_path k=string v=qev$correction_base//'.HISTORY'
crev ho_path k=string v=qev$correction_base//'.HISTORY_LINE'
copf $fname(ho_path) $fname(hi_path//'.$eoi')
delf $fname(ho_path) status=ignore
detf $fname(hi_path) status=ignore
detf $fname(cp_path) status=ignore

        putl '' o=$fname(ofile//'.$eoi')
        putl '     End Installation of '//qev$correction//' Correction Level' o=$fname(ofile//'.$eoi')
        putl '' o=$fname(ofile//'.$eoi')

PROCEND qcp$Install_correction
*DECK DECK=QCM$LINK_GENERATED_QCU EXPAND=TRUE

PROCEDURE qcp$link_generated_qcu (
  nosve_link_input_catalog, nlic: file = $required
  site_link_input_catalog, slic: file = $required
  deadstart_catalog, dc: file = $required
  link_output_catalog, loc: file = $required
  output, o: file = $output
  status)



VAR
 qcv$system: file = $SYSTEM
 ignore: status
VAREND

  "$FORMAT=OFF
  VAR
    directives_file: file = $LOCAL//$name($unique)
    qcu_log: file = qcv$system.field_maintenance.qcu_log
    qcu_state: file = qcv$system.field_maintenance.site_modifications
    ignore_status: status
    job_file: file = $LOCAL//$name($unique)
    jt_virtual_memory_string: string
    jt_link_map: string
    link_errors: file = $unique(:$local)
    link_input_catalog: string
    local_job_template_223: string = '$LOCAL.'//$unique
    local_job_template_23d: string = '$LOCAL.'//$unique
    local_status: status
    monitor_debug_table: string = '$LOCAL.'//$unique
    monitor_symbols_string: string = '$LOCAL.'//$unique
    monitor_virtual_memory_string: string = '$LOCAL.'//$unique
    new_deadstart_catalog: string
    new_link_output_catalog: string
    ol_job_template_223: string
    ol_job_template_236: string
    ol_job_template_23d: string
    ol_job_template_2dd: string
    ol_system_core_113: string
    ol_system_core_133: string
    ol_system_core_13d: string
    ol_system_core_1dd: string
    ol_monitor: string
    ol_message_templates: string
    os_version: string
    pageable_segment: integer = 2
    sc_link_map: string
    site_bound_job_template_223: string
    site_bound_job_template_23d: string
    site_os_maintenance: string
    system_core_debug_table: string = '$LOCAL.'//$unique
    system_debug_table: string
    system_symbols_string: string = '$LOCAL.'//$unique
    system_virtual_memory_string: string = '$LOCAL.'//$unique
    wired_segment: integer = 1
  VAREND
  "$FORMAT=ON"

        ofile = $string($value(output))


putl '         link input catalog ='                 o=qcu_log.$eoi
putl '                  '//nosve_link_input_catalog  o=qcu_log.$eoi
putl '         site input catalog ='                 o=qcu_log.$eoi
putl '                  '//site_link_input_catalog   o=qcu_log.$eoi
putl '         deadstart catalog  ='                 o=qcu_log.$eoi
putl '                  '//deadstart_catalog         o=qcu_log.$eoi
putl '         link output catalog ='                o=qcu_log.$eoi
putl '                  '//link_output_catalog       o=qcu_log.$eoi

  link_input_catalog = $string(nosve_link_input_catalog)

  site_os_maintenance = $string(site_link_input_catalog)
  site_bound_job_template_223 = site_os_maintenance // '.OSF$BOUND_JOB_TEMPLATE_223'
  site_bound_job_template_23d = site_os_maintenance // '.OSF$BOUND_JOB_TEMPLATE_23D'

  new_deadstart_catalog = $string(deadstart_catalog)
  new_link_output_catalog = $string(link_output_catalog)



link_block: ..
  BLOCK




    jt_virtual_memory_string = new_deadstart_catalog // '.job_image'
    monitor_virtual_memory_string = new_deadstart_catalog // '.monitor_image'
    system_virtual_memory_string = new_deadstart_catalog // '.system_core_image'
    jt_link_map = new_link_output_catalog // '.job_template_link_map'
    sc_link_map = new_link_output_catalog // '.system_core_link_map'
    system_debug_table = new_link_output_catalog // '.system_debug_table'






    ol_monitor = link_input_catalog // '.osf$bound_monitor'




    ol_system_core_113 = link_input_catalog // '.osf$bound_system_core_113'
    ol_system_core_133 = link_input_catalog // '.osf$bound_system_core_133'
    ol_system_core_13d = link_input_catalog // '.osf$bound_system_core_13d'
    ol_system_core_1dd = link_input_catalog // '.osf$bound_system_core_1dd'





    ol_job_template_223 = link_input_catalog // '.osf$bound_job_template_223'
    ol_job_template_236 = link_input_catalog // '.osf$bound_job_template_236'
    ol_job_template_23d = link_input_catalog // '.osf$bound_job_template_23d'
    ol_job_template_2dd = link_input_catalog // '.osf$bound_job_template_2dd'
    ol_message_templates = link_input_catalog // '.osf$message_templates'





    os_version = link_input_catalog // '.os_version'
    $system.include_file f=$fname(os_version) status=local_status
    $system.detach_file f=$fname(os_version) status=ignore_status
    EXIT link_block WHEN NOT local_status.normal





    IF $file($fname(site_bound_job_template_223) permanent) THEN

      $system.put_line ' ' o=$fname(ofile//'.$eoi')
      $system.put_line '      Combining the  sites JOB_TEMPLATE_223 library'  o=$fname(ofile//'.$eoi')
      $system.put_line '                                with'      o=$fname(ofile//'.$eoi')
      $system.put_line '               the systems JOB_TEMPLATE_223 library'  o=$fname(ofile//'.$eoi')

      $system.put_line 'OSF$JOB_TEMPLATE_223'    o= qcu_state.$eoi

COLLECT_TEXT o=job_file until='**'
  $system.CREATE_OBJECT_LIBRARY
    add_modules l=$fname(ol_job_template_223)
    replace_modules l=$fname(site_bound_job_template_223)
    generate_library l=$fname(local_job_template_223)
  QUIT
  ol_job_template_223 = local_job_template_223
**
      $system.include_file f=job_file status=local_status
      $system.delete_file f=job_file status=ignore_status
      EXIT link_block WHEN NOT local_status.normal
    IFEND


    IF $file($fname(site_bound_job_template_23d) permanent) THEN
      $system.put_line ' ' o=$fname(ofile//'.$eoi')
      $system.put_line '      Combining the sites JOB_TEMPLATE_23D library'  o=$fname(ofile//'.$eoi')
      $system.put_line '                                with'      o=$fname(ofile//'.$eoi')
      $system.put_line '              the systems JOB_TEMPLATE_23D library'  o=$fname(ofile//'.$eoi')

      $system.put_line 'OSF$JOB_TEMPLATE_23D'   o= qcu_state.$eoi

COLLECT_TEXT o=job_file until='**'
  $system.CREATE_OBJECT_LIBRARY
    add_modules l=$fname(ol_job_template_23d)
    replace_modules l=$fname(site_bound_job_template_23d)
    generate_library l=$fname(local_job_template_23d)
  QUIT
  ol_job_template_23d = local_job_template_23d
**
      $system.include_file job_file status=local_status
      $system.delete_file job_file status=ignore_status
      EXIT link_block WHEN NOT local_status.normal
    IFEND




    map_file_string = $trim(sc_link_map)


    $system.put_line '   Linking monitor.' o=qcu_log.$eoi

COLLECT_TEXT directives_file until='**' status=ignore_status
  $system.LINK_VIRTUAL_ENVIRONMENT
*copy raf$monitor_linker_commands
  QUIT
**

    $system.include_file f=directives_file status=local_status
    $system.delete_file f=directives_file status=ignore_status
    EXIT link_block WHEN NOT local_status.normal




    input_debug_table = monitor_debug_table

    $system.put_line '   Linking system core.' o=qcu_log.$eoi

COLLECT_TEXT directives_file until='**' status=ignore_status
  $system.LINK_VIRTUAL_ENVIRONMENT
*copy raf$system_core_linker_commands
  QUIT
**

    $system.include_file f=directives_file status=local_status
    $system.delete_file f=directives_file status=ignore_status
    EXIT link_block WHEN NOT local_status.normal




    map_file_string = jt_link_map
    input_debug_table = system_core_debug_table

    $system.put_line '   Linking job template.' o=qcu_log.$eoi

COLLECT_TEXT directives_file until='**' status=ignore_status
  $system.LINK_VIRTUAL_ENVIRONMENT
    use_object_library $system.cybil.cyf$run_time_library ring_brackets=(3 13 13)
*copy raf$job_template_linker_comnds
  QUIT
**

    $system.include_file f=directives_file status=local_status
    $system.delete_file f=directives_file status=ignore_status
    EXIT link_block WHEN NOT local_status.normal

    search_link_map link_map=$fname(jt_link_map) output=link_errors status=local_status
    EXIT link_block WHEN NOT local_status.normal

    IF $file_attributes(link_errors, size) <> 0 THEN
      $system.put_line '   Linker errors found.  See file: ' o=$fname(ofile//'.$eoi')
      $system.put_line '      '//jt_link_map o=$fname(ofile//'.$eoi')
      EXIT link_block
    IFEND

    $system.put_line '' o=$fname(ofile//'.$eoi')
    $system.change_file_attribute $fname(monitor_virtual_memory_string) ui=build_id status=ignore_status
    $system.put_line '        Monitor Virtual Memory Image is installed' o=$fname(ofile//'.$eoi')
    $system.put_line '                      and' o=$fname(ofile//'.$eoi')
    $system.change_file_attribute $fname(system_virtual_memory_string) ui=build_id status=ignore_status
    $system.put_line '        System Core Virtual Memory Image is installed ' o=$fname(ofile//'.$eoi')
    $system.put_line '                      and' o=$fname(ofile//'.$eoi')
    $system.change_file_attribute $fname(jt_virtual_memory_string) ui=build_id status=ignore_status
    $system.put_line '        Job Template Virtual Memory Image is installed ' o=$fname(ofile//'.$eoi')
    $system.put_line '                      and' o=$fname(ofile//'.$eoi')
    $system.change_file_attribute $fname(sc_link_map) ui=build_id status=ignore_status

    $system.change_file_attribute $fname(jt_link_map) ui=build_id status=ignore_status

    $system.change_file_attribute $fname(system_debug_table) ui=build_id status=ignore_status
    $system.put_line '        System Debug Table is installed ' o=$fname(ofile//'.$eoi')
    $system.put_line ' ' o=$fname(ofile//'.$eoi')

  BLOCKEND link_block

  $system.detach_file f=$fname(ol_system_core_113) status=ignore_status
  $system.detach_file f=$fname(ol_system_core_133) status=ignore_status
  $system.detach_file f=$fname(ol_system_core_13d) status=ignore_status
  $system.detach_file f=$fname(ol_system_core_1dd) status=ignore_status
  $system.detach_file f=$fname(ol_monitor) status=ignore_status
  $system.detach_file f=$fname(ol_job_template_223) status=ignore_status
  $system.detach_file f=$fname(ol_job_template_236) status=ignore_status
  $system.detach_file f=$fname(ol_job_template_23d) status=ignore_status
  $system.detach_file f=$fname(ol_job_template_2dd) status=ignore_status
  $system.detach_file f=$fname(ol_message_templates) status=ignore_status
  $system.detach_file f=$fname(sc_link_map) status=ignore_status
  $system.detach_file f=$fname(system_core_debug_table) status=ignore_status
  $system.detach_file f=$fname(system_debug_table) status=ignore_status
  $system.detach_file f=$fname(system_symbols_string) status=ignore_status
  $system.detach_file f=$fname(system_virtual_memory_string) status=ignore_status
  $system.detach_file f=$fname(monitor_debug_table) status=ignore_status
  $system.detach_file f=$fname(monitor_symbols_string) status=ignore_status
  $system.detach_file f=$fname(monitor_virtual_memory_string) status=ignore_status
  $system.detach_file f=$fname(jt_virtual_memory_string) status=ignore_status
  $system.detach_file f=$fname(jt_link_map) status=ignore_status
  $system.detach_file f=link_errors status=ignore_status

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND qcp$link_generated_qcu
*DECK DECK=QCM$LINK_QCU EXPAND=TRUE


PROC qcm$link_qcu,link_qcu, linqcu (
  link_job_template, ljt              : boolean = true
  link_system_core, lsc               : boolean = false
  bind_operating_system, bos          : boolean = false
  save_bound_libraries, sbl           : boolean = false
  delete_modules, dm                  : file = $null
  operating_system_identifier, osi    : string 1..5 = $optional
  product_set_identifier, psi         : string 1..6 = $optional
  release_identifier, ri              : string 1..5 = $optional
  psr_summary_identifier, pi          : string 1..6 = $optional
  display_options, do                 : key errors, e, full, f = errors
  accept_warning, accept_warnings, aw : boolean = false
  development_base, db                : file = .intve
  product_name, pn                    : name = os
  build_level, bl                     : name = $optional
  feature_catalog, fc                 : file or key none = none
  feature_build_level, fbl            : name = object
  working_catalog, wc                 : file = $user
  working_build_level, wbl            : name = object
  status                              : var of status = $optional
  )




IF $specified(development_base) THEN
  VAR
    wev$development_base : (ENVIRONMENT) string = $string(development_base)
    server_development_base : (ENVIRONMENT) file = development_base
    wev$server_development_base : (ENVIRONMENT) string = wev$development_base
  VAREND
ELSE
  IF NOT $variable(wev$default_file_server, defined) THEN
    VAR
      wev$default_file_server : (ENVIRONMENT) string
    VAREND
    check_default_file_server
  IFEND
  IF NOT $variable(wev$default_dev_base_family, defined) THEN
    VAR
      wev$default_dev_base_family : (ENVIRONMENT) string
    VAREND
    set_environment_defaults
  IFEND
  VAR
    dev_base_catalog : string =$trim($substr($string(development_base), ..
        $scan_string('.', $string(development_base)), $strlen($string(development_base))))
    development_base : file = wev$development_base, $fname(wev$default_dev_base_family//dev_base_catalog)
    wev$development_base : (ENVIRONMENT) string = $string(development_base)
    server_development_base : file = wev$server_development_base, $fname(wev$default_file_server//dev_base_catalog)
    wev$server_development_base : (ENVIRONMENT) string = $string(server_development_base)
  VAREND
IFEND
IF $specified(product_name) THEN
  create_variable wev$product_name kind=string scope=xdcl ..
    value=$string($value(product_name))
ELSEIF $variable(wev$product_name,declared) = 'NONLOCAL' THEN
  create_variable wev$product_name kind=string scope=xref
ELSE
  create_variable wev$product_name kind=string scope=xdcl ..
    value=$string($value(product_name))
IFEND

IF $specified(build_level) THEN
  create_variable wev$build_level kind=string scope=xdcl ..
    value=$string($value(build_level))
ELSEIF $variable(wev$build_level,declared) = 'NONLOCAL' THEN
  create_variable wev$build_level kind=string scope=xref
ELSE
  create_variable wev$build_level kind=string scope=xdcl value='NONE'
IFEND

IF $specified(feature_catalog) THEN
  create_variable wev$feature_catalog kind=string scope=xdcl ..
    value=$string($value(feature_catalog))
ELSEIF $variable(wev$feature_catalog,declared) = 'NONLOCAL' THEN
  create_variable wev$feature_catalog kind=string scope=xref
ELSE
  create_variable wev$feature_catalog kind=string scope=xdcl ..
    value=$string($value(feature_catalog))
IFEND

IF $specified(feature_build_level) THEN
  create_variable wev$feature_build_level kind=string scope=xdcl ..
    value=$string($value(feature_build_level))
ELSEIF $variable(wev$feature_build_level,declared) = 'NONLOCAL' THEN
  create_variable wev$feature_build_level kind=string scope=xref
ELSE
  create_variable wev$feature_build_level kind=string scope=xdcl ..
    value=$string($value(feature_build_level))
IFEND


IF $specified(working_catalog) THEN
  create_variable wev$working_catalog kind=string scope=xdcl value=$string($value(working_catalog))
ELSEIF $variable(wev$working_catalog, declared) = 'NONLOCAL' THEN
  create_variable wev$working_catalog kind=string scope=xref
ELSE
  create_variable wev$working_catalog kind=string value='NONE'
IFEND
IF wev$working_catalog = 'NONE' THEN
  EXIT_PROC WITH $status(false, 'WE', wee$unspecified_working_cat)
IFEND

IF ($variable(wev$ignore_status, declared) = 'LOCAL') OR ($variable(wev$local_status, declared) = 'LOCAL') ..
      THEN
  EXIT_PROC WITH $status(false, 'WE', wee$declared_status_variables)
IFEND

create_variable (wev$ignore_status, wev$local_status) k=status

attach_file $fname(wev$working_catalog//'.source_library') status=wev$local_status
detach_file $fname(wev$working_catalog//'.source_library') status=wev$ignore_status
IF (wev$local_status.normal = false) AND (..
      ($condition(wev$local_status.condition) = 'PFE$UNKNOWN_LAST_SUBCATALOG') OR ..
      ($condition(wev$local_status.condition) = 'PFE$UNKNOWN_NTH_SUBCATALOG')) THEN
  delete_variable (wev$ignore_status, wev$local_status)
  EXIT_PROC WITH $status(false, 'WE', wee$undefined_working_catalog)
IFEND

delete_variable (wev$ignore_status, wev$local_status)
IF $specified(working_build_level) THEN
  create_variable wev$working_build_level kind=string scope=xdcl ..
    value=$string($value(working_build_level))
ELSEIF $variable(wev$working_build_level,declared) = 'NONLOCAL' THEN
  create_variable wev$working_build_level kind=string scope=xref
ELSE
  create_variable wev$working_build_level kind=string scope=xdcl ..
    value=$string($value(working_build_level))
IFEND



  create_variable n=binary_file kind=string
  create_variable n=binding_directives k=string value='$local.'//$unique
  create_variable n=boot_modified kind=boolean
  create_variable n=bound_library k=string
  create_variable n=build_id kind=(string 22)
  create_variable n=catastrophic_severity k=integer v=5
  create_variable n=compressed_file kind=string
  create_variable n=compress_status kind=status
  create_variable n=cumulative_status kind=status
  create_variable n=display_linker_status kind=status
  create_variable n=error_severity k=integer v=3
  create_variable n=fatal_severity k=integer v=4
  create_variable n=files_generated k=boolean v=false
  create_variable n=first_library_index k=integer
  create_variable n=highest_severity k=integer v=0
  create_variable n=ignore_status kind=status
  create_variable n=informative_severity k=integer v=1
  create_variable n=job_virtual_memory_string kind=string
  create_variable n=jt_virtual_memory_string kind=string value='$local.virtual_memory_image'
  create_variable n=last_library_index k=integer
  create_variable n=linker_directives kind=string value='$local.'//$unique
  create_variable n=local_status kind=status
  create_variable n=map_file_string kind=string value='$local.system_core_link_map'
  create_variable n=monitor_debug_table kind=string value='$local.'//$unique
  create_variable n=monitor_symbols_string kind=string value='$local.'//$unique
  create_variable n=monitor_virtual_memory_string kind=string value='$local.'//$unique
  create_variable n=normal_severity k=integer v=0
  create_variable n=no_libraries_merged k=boolean
  create_variable n=sli k=integer value=0
  create_variable n=system_core_debug_table kind=string value='$local.system_core_debug_table'
  create_variable n=system_debug_table kind=string value='$local.system_debug_table'
  create_variable n=system_symbols_file_name kind=string value='.system_core_symbol_table'
  create_variable n=system_symbols_string kind=string value='$local'//system_symbols_file_name
  create_variable n=system_virtual_memory_string kind=string value='$local.'//$unique
  create_variable n=tying_path kind=string
  create_variable n=version_id kind=(string 22)
  create_variable n=warning_severity k=integer v=2


  create_variable ol_monitor kind=string value='$local.osf$monitor'
  create_variable ol_system_core_113 kind=string value='$local.osf$system_core_113'
  create_variable ol_system_core_133 kind=string value='$local.osf$system_core_133'
  create_variable ol_system_core_13d kind=string value='$local.osf$system_core_13d'
  create_variable ol_system_core_1dd kind=string value='$local.osf$system_core_1dd'
  create_variable ol_job_template_223 kind=string value='$local.osf$job_template_223'
  create_variable ol_job_template_236 kind=string value='$local.osf$job_template_236'
  create_variable ol_job_template_23d kind=string value='$local.osf$job_template_23d'
  create_variable ol_job_template_2dd kind=string value='$local.osf$job_template_2dd'
  create_variable ol_message_templates kind=string value='$local.osf$message_templates'


link_operating_system: ..
  BLOCK

  boot_modified = ((wev$feature_catalog <> 'NONE') AND ..
        ($file($fname(wev$feature_catalog//'.'//wev$feature_build_level//'.maintenance.osf$boot_job'), ..
        permanent) OR $file(..
        $fname(wev$feature_catalog//'.'//wev$feature_build_level//'.maintenance.osf$boot_monitor'), ..
        permanent))) OR ((wev$working_catalog <> 'NONE') AND ..
        ($file($fname(wev$working_catalog//'.'//wev$working_build_level//'.maintenance.osf$boot_job'), ..
        permanent) OR $file(..
        $fname(wev$working_catalog//'.'//wev$working_build_level//'.maintenance.osf$boot_monitor'), ..
        permanent)))

  IF boot_modified THEN
    link_boot do=$value(display_options) dm=$value(delete_modules) sbl=$value(save_bound_libraries) status=local_status
    IF NOT local_status.normal THEN
      IF $vname($severity(local_status.condition)//'_severity') > highest_severity THEN
        highest_severity = $vname($severity(local_status.condition)//'_severity')
        cumulative_status = local_status
      IFEND
      display_value v=local_status o=$job_log
    IFEND
    EXIT link_operating_system WHEN ((highest_severity > warning_severity) AND (NOT $value(accept_warnings)))
  IFEND



  create_variable system_libraries k=(string, $max_name) d=30
  system_libraries(1) = 'osf$monitor'
  system_libraries(2) = 'ol_monitor'
  system_libraries(3) = 'monitor'
  system_libraries(4) = 'osf$system_core_113'
  system_libraries(5) = 'ol_system_core_113'
  system_libraries(6) = 'system_core_113'
  system_libraries(7) = 'osf$system_core_133'
  system_libraries(8) = 'ol_system_core_133'
  system_libraries(9) = 'system_core_133'
  system_libraries(10) = 'osf$system_core_13d'
  system_libraries(11) = 'ol_system_core_13d'
  system_libraries(12) = 'system_core_13d'
  system_libraries(13) = 'osf$system_core_1dd'
  system_libraries(14) = 'ol_system_core_1dd'
  system_libraries(15) = 'system_core_1dd'
  system_libraries(16) = 'osf$job_template_223'
  system_libraries(17) = 'ol_job_template_223'
  system_libraries(18) = 'job_template_223'
  system_libraries(19) = 'osf$job_template_236'
  system_libraries(20) = 'ol_job_template_236'
  system_libraries(21) = 'job_template_236'
  system_libraries(22) = 'osf$job_template_23d'
  system_libraries(23) = 'ol_job_template_23d'
  system_libraries(24) = 'job_template_23d'
  system_libraries(25) = 'osf$job_template_2dd'
  system_libraries(26) = 'ol_job_template_2dd'
  system_libraries(27) = 'job_template_2dd'
  system_libraries(28) = 'osf$message_templates'
  system_libraries(29) = 'ol_message_templates'
  system_libraries(30) = 'NONE'


  create_variable job_template_library_index k=integer value=16

  log_statistic pn=link_operating_system s=dp000001 t=begin status=ignore_status



  build_object_library_path = wev$server_development_base // '.' // wev$product_name // '.' // wev$build_level // ..
        '.maintenance'
  build_preserved_file_path = wev$server_development_base // '.' // wev$product_name // '.' // wev$build_level
  IF wev$feature_catalog <> 'NONE' THEN
    feature_object_library_path = wev$feature_catalog // '.' // wev$feature_build_level // '.maintenance'
    feature_preserved_file_path = wev$feature_catalog // '.' // wev$feature_build_level
  ELSE
    feature_object_library_path = wev$feature_catalog
    feature_preserved_file_path = wev$feature_catalog
  IFEND

  working_object_library_path = wev$working_catalog // '.' // wev$working_build_level // '.maintenance'
  preserved_file_path = wev$working_catalog // '.' // wev$working_build_level
  display_catalog $fname(preserved_file_path) output=$null status=local_status
  IF NOT local_status.normal THEN
    create_catalog $fname(preserved_file_path) status=local_status
    IF NOT local_status.normal THEN
      put_line ' Cannot create '//preserved_file_path//' catalog due to following error:' output=$response, ..
            status=ignore_status
      display_value local_status output=$response status=ignore_status
    IFEND
  IFEND



    command_line = 'build_system_identifiers bi=build_id vi=version_id'
    command_line = command_line // ' if=' // preserved_file_path // '.version'
    IF NOT $variable(wev$use_release_id defined) THEN
      return_path file_name=tying file_type=general path=tying_path status=local_status
      EXIT link_operating_system WHEN NOT local_status.normal
      include_file $fname(tying_path) status=local_status
      EXIT link_operating_system WHEN NOT local_status.normal
    IFEND
    command_line = command_line // ' return_release_values=' // wev$use_release_id
    IF $specified(operating_system_identifier) THEN
      command_line = command_line // ' osl=''' // $value(operating_system_identifier) // ''''
    IFEND
    IF $specified(product_set_identifier) THEN
      command_line = command_line // ' psl=''' // $value(product_set_identifier) // ''''
    IFEND
    IF $specified(release_identifier) THEN
      command_line = command_line // ' rl=''' // $value(release_identifier) // ''''
    ELSE
      create_variable name=wev$nosve_version kind=string scope=xref status=local_status
      IF NOT local_status.normal AND $condition(local_status.condition) <> 'CLE$VAR_ALREADY_CREATED' THEN
        return_path file_name=tying file_type=general path=tying_path status=local_status
        EXIT link_operating_system WHEN NOT local_status.normal
        include_file $fname(tying_path) status=local_status
        EXIT link_operating_system WHEN NOT local_status.normal
      IFEND
      command_line = command_line // ' rl=''' // wev$nosve_version // ''''
    IFEND
    IF $specified(psr_summary_identifier) THEN
      command_line = command_line // ' pl=''' // $value(psr_summary_identifier) // ''''
    ELSE
      create_variable name=wev$psr_version kind=string scope=xref status=local_status
      IF NOT local_status.normal AND $condition(local_status.condition) <> 'CLE$VAR_ALREADY_CREATED' THEN
        return_path file_name=tying file_type=general path=tying_path status=local_status
        EXIT link_operating_system WHEN NOT local_status.normal
        include_file $fname(tying_path) status=local_status
        EXIT link_operating_system WHEN NOT local_status.normal
      IFEND
      command_line = command_line // ' pl=''' // wev$psr_version// ''''
    IFEND

    include_line command_line status=local_status
    EXIT link_operating_system WHEN NOT local_status.normal

     put_line ' Establish the environment' o=output

    create_variable wev$cybil_level kind=string scope=xref status=local_status
    IF NOT local_status.normal AND $condition(local_status.condition) <> 'CLE$VAR_ALREADY_CREATED' THEN
      return_path file_name=tying file_type=general path=tying_path status=local_status
      EXIT link_operating_system WHEN NOT local_status.normal
      include_file $fname(tying_path) status=local_status
      EXIT link_operating_system WHEN NOT local_status.normal
    IFEND

    create_variable wev$aam_level kind=string scope=xref status=local_status
    IF NOT local_status.normal AND $condition(local_status.condition) <> 'CLE$VAR_ALREADY_CREATED' THEN
      return_path file_name=tying file_type=general path=tying_path status=local_status
      EXIT link_operating_system WHEN NOT local_status.normal
      include_file $fname(tying_path) status=local_status
      EXIT link_operating_system WHEN NOT local_status.normal
    IFEND


    include_line 'locate_file cyf$run_time_library cyf$$$run_library sc=('//preserved_file_path//' '//..
feature_preserved_file_path//' '//wev$server_development_base//'.cybil.'//wev$cybil_level//' $SYSTEM.cybil)'

  sc_jt_processing: ..
    BLOCK

      EXIT sc_jt_processing WHEN NOT ($value(link_system_core) OR $value(link_job_template))

      first_library_index = job_template_library_index
      last_library_index = $variable(system_libraries, upper_bound)

      IF ($value(link_system_core)) THEN
        first_library_index = $variable(system_libraries, lower_bound)
        IF NOT $value(link_job_template) THEN
          last_library_index = job_template_library_index - 3
        IFEND
      IFEND

      IF $value(bind_operating_system) THEN


        get_source d=raf$binding_directives e=true s=$fname(binding_directives) status=local_status
        EXIT link_operating_system WHEN NOT local_status.normal

        include_file $fname(binding_directives) status=local_status
        detach_file $fname(binding_directives) status=ignore_status
        EXIT link_operating_system WHEN NOT local_status.normal
      IFEND


    merge_libraries: ..
      FOR sli = first_library_index TO last_library_index BY 3 DO
        combine_objects dm=$value(delete_modules) ol=$name(system_libraries(sli)) ..
              rol=$fname($vname(system_libraries(sli+1))) oml=cyf$run_time_library nlm=no_libraries_merged ..
              status=local_status
        IF NOT local_status.normal THEN
          IF $vname($severity(local_status.condition)//'_severity') > highest_severity THEN
            highest_severity = $vname($severity(local_status.condition)//'_severity')
            cumulative_status = local_status
          IFEND
          display_value v=local_status o=$job_log
        IFEND
        EXIT merge_libraries WHEN local_status.normal = false


        IF no_libraries_merged THEN
          IF $value(bind_operating_system) AND (system_libraries(sli + 2) <> 'NONE') THEN
            $vname(system_libraries(sli+1)) = build_preserved_file_path // '.bound_' // ..
                  system_libraries(sli + 2)
          ELSE
            $vname(system_libraries(sli+1)) = build_object_library_path // '.' // system_libraries(sli)
          IFEND
        ELSE

          IF ($value(bind_operating_system)) AND (system_libraries(sli + 2) <> 'NONE') THEN
            IF $value(save_bound_libraries) THEN
              bound_library = preserved_file_path // '.bound_' // system_libraries(sli + 2)
            ELSE
              bound_library = '$local.bound_' // system_libraries(sli + 2)
            IFEND

            delete_file $fname(bound_library) status=ignore_status
            PUSH file_connections
            create_file_connection sf=$errors f=$job_log status=ignore_status
            bind_os_library bd=$fname($vname('bd_'//system_libraries(sli+2))) ..
                  ul=$fname($vname(system_libraries(sli+1))) bl=$fname(bound_library) status=local_status
            POP file_connections

            IF local_status.normal THEN
              $vname(system_libraries(sli+1)) = bound_library
            ELSE
              IF $vname($severity(local_status.condition)//'_severity') > highest_severity THEN
                highest_severity = $vname($severity(local_status.condition)//'_severity')
                cumulative_status = local_status
              IFEND
              display_value v=local_status o=$job_log
            IFEND
          IFEND
        IFEND
      FOREND merge_libraries
      EXIT link_operating_system WHEN ((highest_severity > normal_severity) AND (NOT $value(accept_warnings)))
      EXIT link_operating_system WHEN highest_severity > warning_severity


    generate_linked_system: ..
      BLOCK


        IF highest_severity > normal_severity THEN
          display_value v='' o=$response
          display_value v='Ignoring warnings, begin linking...' o=$response
          display_value v='' o=$response
        IFEND

        put_line '        Link System.' output=$response
        map_file_string = preserved_file_path // '.system_core_link_map'
        system_symbols_file_name = '.system_core_symbol_table'


        system_core_debug_table = preserved_file_path // '.system_core_debug_table'
        system_debug_table = preserved_file_path // '.system_debug_table'
        monitor_virtual_memory_string = preserved_file_path // '.monitor_image'
        system_virtual_memory_string = preserved_file_path // '.system_core_image'


        get_source d=raf$linker_directives s=$fname(linker_directives) e=true status=local_status
        EXIT generate_linked_system WHEN NOT local_status.normal

        include_file $fname(linker_directives) status=local_status
        detach_file $fname(linker_directives) status=ignore_status
        EXIT generate_linked_system WHEN NOT local_status.normal

        IF $value(link_system_core) THEN
          wired_segment = 1
          pageable_segment = 2

          detach_file $fname(map_file_string) status=ignore_status
          create_file $fname(map_file_string//'.$next')
          new_cycle = $file($fname(map_file_string), cycle_number)
          IF new_cycle > 1 THEN
            delete_file_name = map_file_string // '.' // $strrep(new_cycle-1)
            delete_file $fname(delete_file_name) status=ignore_status
          IFEND

          system_symbols_string = preserved_file_path // system_symbols_file_name

          detach_file $fname(system_symbols_string) status=ignore_status
          create_file $fname(system_symbols_string//'.$next')
          new_cycle = $file($fname(system_symbols_string), cycle_number)
          IF new_cycle > 1 THEN
            delete_file_name = system_symbols_string // '.' // $strrep(new_cycle-1)
            delete_file $fname(delete_file_name) status=ignore_status
          IFEND


          put_line '        Link Monitor.' output=$response status=ignore_status

          LINK_VIRTUAL_ENVIRONMENT
            include_file $fname(monitor_linker_commands) status=local_status
          QUIT

          detach_file $fname(monitor_linker_commands) status=ignore_status
          EXIT generate_linked_system WHEN NOT local_status.normal


          put_line '       Link System Core.' output=$response status=ignore_status


          IF NOT $file($fname(monitor_debug_table), assigned) THEN
            local_status = $status(false, 'WE', wee$missing_debug_table, debug_table_kind)
            EXIT generate_linked_system
          IFEND

          LINK_VIRTUAL_ENVIRONMENT
            include_file $fname(system_core_linker_commands) status=local_status
          QUIT

          detach_file $fname(system_core_linker_commands) status=ignore_status
          detach_file $fname(system_core_debug_table) status=ignore_status
          detach_file $fname(monitor_debug_table) status=ignore_status
          detach_file $fname(build_real_memory_commands) status=ignore_status
          detach_file $fname(monitor_virtual_memory_string) status=ignore_status
          detach_file $fname(monitor_symbols_string) status=ignore_status
          detach_file $fname(system_virtual_memory_string) status=ignore_status
          detach_file $fname(map_file_string) status=ignore_status
          EXIT generate_linked_system WHEN NOT local_status.normal
        ELSE


          IF $file($fname(preserved_file_path//system_symbols_file_name), permanent) THEN
            system_symbols_string = preserved_file_path // system_symbols_file_name
            detach_file $fname(system_symbols_string//'.$high') status=ignore_status
            attach_file $fname(system_symbols_string//'.$high') wait=true status=local_status
            EXIT generate_linked_system WHEN NOT local_status.normal
          ELSEIF (wev$feature_catalog <> 'NONE') AND ..
                ($file($fname(feature_preserved_file_path//system_symbols_file_name), permanent)) THEN
            system_symbols_string = feature_preserved_file_path // system_symbols_file_name
            detach_file $fname(system_symbols_string//'.$high') status=ignore_status
            attach_file $fname(system_symbols_string//'.$high') wait=true status=local_status
            EXIT generate_linked_system WHEN NOT local_status.normal
          ELSEIF $file($fname(build_preserved_file_path//system_symbols_file_name), permanent) THEN
            system_symbols_string = build_preserved_file_path // system_symbols_file_name
            detach_file $fname(system_symbols_string//'.$high') status=ignore_status
            attach_file $fname(system_symbols_string//'.$high') wait=true status=local_status
            EXIT generate_linked_system WHEN NOT local_status.normal
          ELSE
            put_line ' ERROR - '//system_symbols_file_name//' does not exist in:' o=$output ..
                  status=ignore_status
            put_line '     working catalog = '//preserved_file_path o=$output status=ignore_status
            put_line '     feature catalog = '//feature_preserved_file_path o=$output status=ignore_status
            put_line '     build catalog = '//build_preserved_file_path o=$output status=ignore_status
            EXIT generate_linked_system
          IFEND
        IFEND

        IF $value(link_job_template) = true THEN
          jt_virtual_memory_string = preserved_file_path // '.job_image'
          map_file_string = preserved_file_path // '.job_template_link_map'

          detach_file $fname(map_file_string) status=ignore_status
          create_file $fname(map_file_string//'.$next')
          new_cycle = $file($fname(map_file_string), cycle_number)
          IF new_cycle > 1 THEN
            delete_file_name = map_file_string // '.' // $strrep(new_cycle-1)
            delete_file $fname(delete_file_name) status=ignore_status
          IFEND

          detach_file $fname(jt_virtual_memory_string) status=ignore_status
          create_file $fname(jt_virtual_memory_string//'.$next')
          new_cycle = $file($fname(jt_virtual_memory_string), cycle_number)
          IF new_cycle > 1 THEN
            delete_file_name = jt_virtual_memory_string // '.' // $strrep(new_cycle-1)
            delete_file $fname(delete_file_name) status=ignore_status
          IFEND


          put_line '       Link Job Template.' output=$response status=ignore_status

          IF NOT $file($fname(system_core_debug_table), assigned) THEN
            IF wev$feature_catalog <> 'NONE' THEN
              IF $file($fname(feature_preserved_file_path//'.system_core_debug_table'), assigned) THEN
                system_core_debug_table = feature_preserved_file_path // '.system_core_debug_table'
              ELSE
                system_core_debug_table = build_preserved_file_path // '.system_core_debug_table'
              IFEND
            ELSE
              system_core_debug_table = build_preserved_file_path // '.system_core_debug_table'
            IFEND
          IFEND

          IF $file($fname(system_core_debug_table), assigned) THEN
           put_line ' '    o=$response status=ignore_status
          ELSE
            local_status = $status(false, 'WE', wee$missing_core_debug_table)
            EXIT generate_linked_system
          IFEND

          LINK_VIRTUAL_ENVIRONMENT
            include_file $fname(job_template_linker_commands) status=local_status
          QUIT

          detach_file $fname(job_template_linker_commands) status=ignore_status
          detach_file $fname(jt_virtual_memory_string) status=ignore_status
          detach_file $fname(map_file_string) status=ignore_status
          detach_file ($fname(system_symbols_string)) status=ignore_status
          detach_file $fname(monitor_debug_table) status=ignore_status
          detach_file $fname(system_debug_table) status=ignore_status
          EXIT generate_linked_system WHEN NOT local_status.normal
        IFEND




        files_generated = true

        IF $value(link_system_core) OR $value(link_job_template) THEN
          show_errors do=$value(display_options) status=display_linker_status
          IF NOT display_linker_status.normal THEN
            EXIT generate_linked_system
          IFEND
        IFEND
      BLOCKEND generate_linked_system
      EXIT link_operating_system WHEN NOT local_status.normal
    BLOCKEND sc_jt_processing


    IF wev$feature_catalog = 'NONE' THEN
      include_line 'locate_file unbound_fortran_interface aam$$$unbound_fortran_interface            sc=('..
//preserved_file_path//'.maintenance '//wev$server_development_base//'.aam.'//wev$aam_level//'.maintenance)'
    ELSE " Feature catalog exists "
      include_line 'locate_file unbound_fortran_interface aam$$$unbound_fortran_interface            sc=('..
//preserved_file_path//'.maintenance '//feature_preserved_file_path//'.maintenance '//wev$server_development_base//..
'.aam.'//wev$aam_level//'.maintenance)'
    IFEND

    build_deadstart_library pfp=$fname(preserved_file_path), crtl=$local.cyf$$$run_library ..
          dm=$value(delete_modules) status=local_status
    EXIT link_operating_system WHEN NOT local_status.normal


    build_builtin_library pfp=$fname(preserved_file_path), crtl=$local.cyf$$$run_library ..
          aamuc=$local.aam$$$unbound_fortran_interface dm=$value(delete_modules) status=local_status

    EXIT link_operating_system WHEN NOT local_status.normal


    build_task_lib pfp=$fname(preserved_file_path), crtl=$local.cyf$$$run_library ..
          dm=$value(delete_modules) status=local_status

    EXIT link_operating_system WHEN NOT local_status.normal

    put_line ' ' output=$response

  BLOCKEND link_operating_system


  detach_file $local.cyf$$$run_library status=ignore_status
  detach_file $local.aam$$$unbound_fortran_interface status=ignore_status
  detach_file $fname(linker_directives) status=ignore_status
  detach_file $fname(system_core_debug_table) status=ignore_status
  detach_file $fname(monitor_debug_table) status=ignore_status
  detach_file $fname(monitor_virtual_memory_string) status=ignore_status
  detach_file $fname(monitor_symbols_string) status=ignore_status
  detach_file $fname(system_virtual_memory_string) status=ignore_status
  detach_file $fname(map_file_string) status=ignore_status
  detach_file $fname(jt_virtual_memory_string) status=ignore_status
  detach_file $fname(system_symbols_string) status=ignore_status
  detach_file $fname(system_debug_table) status=ignore_status

  IF $variable(monitor_linker_commands, declared) = 'LOCAL' THEN
    detach_file $fname(monitor_linker_commands) status=ignore_status
    detach_file $fname(system_core_linker_commands) status=ignore_status
    detach_file $fname(build_real_memory_commands) status=ignore_status
    detach_file $fname(job_template_linker_commands) status=ignore_status
  IFEND

  IF $variable(system_libraries, defined) THEN
    FOR sli = $variable(system_libraries, lower_bound) TO $variable(system_libraries, upper_bound) BY 3 DO
      detach_file $fname($vname(system_libraries(sli+1))) status=ignore_status
      IF $variable($name('bd_'//system_libraries(sli+2)), declared) = 'LOCAL' THEN
        detach_file $fname($vname('bd_'//system_libraries(sli+2))) status=ignore_status
      IFEND
    FOREND
  IFEND

  IF NOT display_linker_status.normal THEN
    IF NOT local_status.normal THEN
      display_value value=local_status output=$response
      local_status = display_linker_status
    ELSE
      local_status = display_linker_status
    IFEND
  IFEND

  IF ((highest_severity > normal_severity) AND (NOT local_status.normal) AND ..
        ($condition(local_status.condition) <> $condition(cumulative_status.condition))) THEN
    display_value v=local_status o=$response
  IFEND
  IF highest_severity > normal_severity THEN
    IF ((highest_severity <= warning_severity) AND ($value(accept_warnings)) AND (files_generated)) THEN
      local_status = $status(false, 'WE', wee$warning_linos_files_made, $severity(cumulative_status.condition))
    ELSEIF ((highest_severity <= warning_severity) AND ($value(accept_warnings)) AND NOT files_generated) THEN
      local_status = $status(false, 'WE', wee$error_linos_no_files, $severity(cumulative_status.condition))
    ELSEIF ((highest_severity <= warning_severity) AND (NOT $value(accept_warnings)) AND NOT files_generated) THEN
      local_status = $status(false, 'WE', wee$error_linos_no_files, $severity(cumulative_status.condition))
    ELSEIF ((highest_severity <= warning_severity) AND (NOT $value(accept_warnings)) AND files_generated) THEN
      local_status = $status(false, 'WE', wee$warning_linos_files_made, $severity(cumulative_status.condition))
    ELSEIF highest_severity >= error_severity THEN
      local_status = $status(false, 'WE', wee$error_linos_no_files, $severity(cumulative_status.condition))
    IFEND
  IFEND

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND qcm$link_qcu
*DECK DECK=QCM$LIST_CATALOG EXPAND=TRUE
PROCEDURE qcp$list_catalog (
  catalog, c: file = $required
  file_list, fl: file = $null
  depth, d: integer 1..$max_integer = 1
  file_count, fc: (VAR) integer = $optional
  status)



"  The purpose of this request is to create a file listing of all the files
"under the specified catalog and it's subcatalogs.  Each file is listed by
"it's complete path name and a count is kept on the total number of files
"found if parameter file_count is specified.  NOTE: File_count must be initialized
"to '0' by the caller in order to work properly.


  VAR
    ignore_status: status
    local_status: status
    scratch_file: file = $LOCAL//$name($unique)
    new_catalog: file
  VAREND


"  A catalog listing is obtained and processed line by line.
"An end of list marker is placed at the bottom of the list to
"determine when to stop list processing.  The DEPTH parameter
"is used to indicate how many subcatalog level to traverse
"looking for files.  The procedure decrements it by one.
"When the depth parameter = 0, subsequent catalogs are not searched.


  depth = depth - 1
  $system.set_file_attributes f=scratch_file fc=legible pf=continuous pw=65000
  $system.display_catalog c=catalog do=identifier o=scratch_file status=local_status
  IF NOT local_status.normal THEN
    $system.delete_file f=scratch_file status=ignore_status
    EXIT procedure WITH local_status
  IFEND

  $system.rewind_file f=scratch_file status=ignore_status
  LOOP
    line = ' '
    $system.accept_line v=line i=scratch_file//$name('$asis') status=local_status
    EXIT WHEN (NOT local_status.normal) OR (line = ' ')
    index = $scan_string('CATALOG:', line)

    IF (index <> 0) AND (depth > 0) THEN


"  The catalog contains a subcatalog that is to be processed before
"continuing with the current catalog and the current catalog depth has
"not been exceeded.


      new_catalog = catalog//$name($substring(line, index+9, $size(line)-(index+8)))
      IF $specified(file_count) THEN
        qcp$list_catalog new_catalog file_list depth file_count status=local_status
      ELSE
        qcp$list_catalog new_catalog file_list depth status=local_status
      IFEND
      EXIT WHEN NOT local_status.normal
    ELSE

      index = $scan_string('FILE:', line) + 6
      IF index > 6 THEN


"  The catalog contains a file.  Construct the path and add it to the file list.


        $system.put_line $string(catalog)//'.'//$substring(line, index, $size(line)-index+1) ..
              o=file_list//$name('$eoi') status=local_status
        EXIT WHEN NOT local_status.normal
        IF $specified(file_count) THEN
          file_count = file_count + 1
        IFEND
      IFEND
    IFEND

  LOOPEND
  $system.delete_file f=scratch_file status=ignore_status

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND qcp$list_catalog

*DECK DECK=QCM$LOCATE_FILE EXPAND=TRUE


PROC qcm$locate_file, locate_file,  locf (
  file_name, fn       : name = $required
  local_file_name, lfn: name
  search_catalogs, sc : list of file
  status)

  create_variable check_status kind=status
  create_variable found kind=boolean value=false
  create_variable lfn kind=string

  IF NOT $specified(local_file_name) THEN
    lfn = $string($value(file_name))
  ELSE
    lfn = $string($value(local_file_name))
  IFEND

  IF $file($fname('$local.'//lfn), opened) THEN
    check_status.normal = true
    EXIT_PROC WITH check_status
  IFEND

  IF $specified(search_catalogs) THEN
    FOR i = 1 TO $set_count(search_catalogs) DO
      IF $path($value(sc i), count) = 2 AND $path($value(sc i), catalog) = ':$LOCAL' THEN
        "This is not a valid path name - go on to next one."
      ELSE
        attach_file $fname($string($value(sc i))//'.'//$string($value(file_name))) lfn=$name(lfn) ..
              am=(read execute) sm=(read execute) status=check_status
        IF check_status.normal THEN
          found = true
        IFEND
      IFEND
    FOREND
  IFEND

  IF found THEN
    check_status.normal = true
  IFEND

  EXIT_PROC WITH check_status

PROCEND qcm$locate_file
*DECK DECK=QCM$MAKCCU_PHASE_100 EXPAND=TRUE

PROCEDURE makccu_phase_100, makccu100  (
site_code, qcu: name = $required
status )

crev count
crev work k=string
crev ignore k=status
crev msg k=string
crev qi   k=string v=$string($value(site_code))
crev wev$working_catalog k=string scope=xref
work_path = wev$working_catalog
crev psrs

crev scu_path k=string v='$USER.'//qi//'_scu_base'
crev sc_path k=string v='$USER.'//qi//'_criteria'
crev hdr_path k=string v='.CSERV.CCU.PSRS.HEADER_FILE'
crev trl_path k=string v='.CSERV.CCU.PSRS.TRAILER_FILE'
crev data_file k=string v='$USER.'//qi//'_PSR_BASE'
crev psr_info k=string v='.CSERV.CCU.PSRS.'//qi
crev r1_line k=string v='qcv$psrs_p^.psr_entries['
crev r2_line k=string v= '].psr_ident := '
crev r3_line k=string v='qcv$psrs_p^.psr_entries['
crev r4_line k=string v= '].feature_ident := '

detf $fname(psr_info) status=ignore
delf $fname(data_file) status=ignore
delf $fname(scu_path) status=ignore
delf $fname(sc_path) status=ignore

attf f=$fname(psr_info) op=$asis
copf $fname(hdr_path) $fname(data_file)
putl ' ' o=$fname(data_file//'.$eoi')

    accl v=work i=$fname(psr_info) lc=count
   WHILE count <> 0 DO
    psrs = psrs + 1
    msg = '        '//r1_line//psrs
    msg = msg//r2_line//''''
    msg = msg//$substr(work,8,7)
    msg = msg//''';'
    putl msg o=$fname(data_file//'.$eoi')

    msg = '        '//r3_line//psrs
    msg = msg//r4_line//''''
    msg = msg//$substr(work,36,$strlen(work)-34)
    msg = msg//''';'
    putl msg o=$fname(data_file//'.$eoi')
    putl ' ' o=$fname(data_file//'.$eoi')


    accl v=work i=$fname(psr_info) lc=count
   WHILEND
  putl '  qcv$psrs_p^.item_count := '//psrs//';' o=$fname(data_file//'.$eoi')
 copf $fname(trl_path) $fname(data_file//'.$eoi')


   cresl r=$fname(scu_path)

colt o=$fname(sc_path)
INCM special
**

 delfc $output output
 SCU
   usel b=$fname(scu_path)  r=$fname(scu_path)
   cred d=psr_statistics m=special s=$fname(data_file)
   chad d=psr_statistics g=(oss$source,cybil,osf$system_core_13d) p='cybil'
   quit


 COMS d=psr_statistics ab=$fname(scu_path)  sc=$fname(sc_path) l=l2
 crefc $output output

 detf $fname(data_file) status=ignore
 detf $fname(hdr_path) status=ignore
 detf $fname(trl_path) status=ignore
 detf $fname(scu_path) status=ignore
 detf $fname(obj_path) status=ignore
 detf $fname(sc_path) status=ignore
 delf $fname(scu_path) status=ignore
 delf $fname(obj_path) status=ignore
 delf $fname(sc_path) status=ignore
 delf $fname(data_file) status=ignore
 detf l2

PROCEND makccu_phase_100
*DECK DECK=QCM$MAKE_CORRECTION_DS_TAPE EXPAND=TRUE
PROCEDURE qcp$make_correction_ds_tape (
  external_vsn, evsn, ev: any of
      string 1..6
      name 1..6
    anyend = $optional
  recorded_vsn, rvsn, rv: any of
      string 1..6
      name 1..6
    anyend = $optional
  type, t: any of
      key
        mt9$1600
        mt9$6250
        mt18$38000
      keyend
    anyend = mt9$6250
  product_files, pf: (HIDDEN) list of file = $optional
  output, o: file = $output
  removable_media_group, rmg: (BY_NAME, ADVANCED) any of
      key
        none
      keyend
      name
    anyend = osd$reqmt_removable_media_group, none
  unload_deadstart_tape, udt: boolean = TRUE
  status)

*copyc dst$deadstart_record_lists

  crev ignore k=status

      IF $file($value(output) open_position) = '$BOI' THEN
        rewind_file $value(output) status=ignore
        ofile = $string($value(output))//'.$ASIS'
      ELSE
        ofile = $string($value(output))
      IFEND

 putl ' '  o=$fname(ofile)
 put_line '     Generate Correction Deadstart Tape'  o=$fname(ofile)



  TYPE
    files_record: RECORD
      name: string 0 .. $max_name
      file_id: string 1 .. 17
    RECEND
  TYPEND

   crev deadstart_base k=string v='$system.qcu_maintenance'
   crev deadstart_catalog k=string
   crev id_path k=string v= deadstart_base//'.identification'

   detf $fname(id_path) status=ignore

  VAR
    work: string
    block_type: name
    deadstart_tape: string 0 .. $max_name = $unique
    file_count: integer
    file_id: string 0 .. $max_name
    file_name: file
    file_name_string: string
    ignore_status: status
    index: integer
    local_status: status
    record_type: name
    temp_product_list: list 0 .. $max_list of file
    total_deadstart_file_count: integer
  VAREND

  IF $specified(product_files) THEN
    total_deadstart_file_count = deadstart_file_count + $size(product_files)
  ELSE
    total_deadstart_file_count = deadstart_file_count
  IFEND

  VAR
    deadstart_files: ARRAY 1 .. total_deadstart_file_count OF files_record
  VAREND

  FOR index = 1 TO total_deadstart_file_count DO
    deadstart_files(index).name = $unique
  FOREND

    IF NOT $file($fname(deadstart_base),catalog) THEN
      putl ' '                                        o=$fname(ofile//'.$eoi')
      putl '                     STOP' o=$fname(ofile//'.$eoi')
      putl '      No deadstart catalog material is currently'   o=$fname(ofile//'.$eoi')
      putl '      available. It will be necessary to issue the' o=$fname(ofile//'.$eoi')
      putl '      Generate_correction_system (GENCS) command'   o=$fname(ofile//'.$eoi')
      putl '      to create new deadstart catalog material '    o=$fname(ofile//'.$eoi')
      putl '      prior to reissueing this command.'            o=$fname(ofile//'.$eoi')
      putl ' '                                                  o=$fname(ofile//'.$eoi')
      EXIT_PROC
    IFEND

  crevdt_block: BLOCK
    attach_file f=$fname(id_path) op=$asis
    accl work i=$fname(id_path)
    deadstart_catalog = deadstart_base//'.'//work//'.deadstart_catalog'
    detf $fname(id_path) status=ignore
    display_catalog c=$fname(deadstart_catalog) o=$null status=local_status
    EXIT crevdt_block WHEN NOT local_status.normal

    IF NOT $specified(external_vsn) AND NOT $specified(recorded_vsn) THEN
      IF removable_media_group = 'NONE' THEN
        local_status = $status(FALSE, 'DS', dse$vsn_required)
        EXIT crevdt_block
      IFEND
    IFEND

    " Acquire the deadstart files.


    file_count = 1
    acquire_files: FOR index = 1 TO deadstart_file_count DO
      IF index = deadstart_file_count THEN
        IF $specified(product_files) THEN
          temp_product_list = product_files
          WHILE NOT $nil(temp_product_list) DO
            file_name = $first(temp_product_list)
            temp_product_list = $rest(temp_product_list)
            attach_file f=file_name lfn=$name(deadstart_files(file_count).name) am=(read execute) ..
                  sm=(read execute) status=local_status
            EXIT crevdt_block WHEN NOT local_status.normal
            file_id = $strrep($first($reverse($path_elements(file_name))))
            IF $size(file_id) > 17 THEN
              deadstart_files(file_count).file_id = file_id(1, 17)
            ELSE
              deadstart_files(file_count).file_id = file_id
            IFEND
            file_count = file_count + 1
          WHILEND
        IFEND
      IFEND

      IF deadstart_file_list(index).site_catalog = '' THEN
        file_name_string = $string(deadstart_catalog)//'.'//deadstart_file_list(index).tape_name
      ELSE
        file_name_string = $string(deadstart_catalog)//'.'//deadstart_file_list(index).site_catalog//'.'// ..
              deadstart_file_list(index).tape_name
      IFEND
      attach_file f=$fname(file_name_string) lfn=$name(deadstart_files(file_count).name) am=(read execute) ..
            sm=(read execute) status=local_status
      IF NOT local_status.normal THEN
        IF deadstart_file_list(index).site_required THEN
          EXIT crevdt_block
        ELSE
          CYCLE acquire_files
        IFEND
      IFEND
      deadstart_files(file_count).file_id = deadstart_file_list(index).tape_name
      file_count = file_count + 1
    FOREND acquire_files


    " Request the deadstart tape.

    IF NOT $specified(external_vsn) AND NOT $specified(recorded_vsn) THEN
      request_magnetic_tape f=$fname(deadstart_tape) r=TRUE ..
            t=type rmg=removable_media_group status=local_status
    ELSEIF NOT $specified(external_vsn) THEN
      request_magnetic_tape f=$fname(deadstart_tape) rvsn=recorded_vsn r=TRUE ..
            t=type rmg=removable_media_group status=local_status
    ELSEIF NOT $specified(recorded_vsn) THEN
      request_magnetic_tape f=$fname(deadstart_tape) evsn=external_vsn r=TRUE ..
            t=type rmg=removable_media_group status=local_status
    ELSE
      request_magnetic_tape f=$fname(deadstart_tape) evsn=external_vsn ..
            rvsn=recorded_vsn r=TRUE t=type rmg=removable_media_group ..
            status=local_status
    IFEND
    EXIT crevdt_block WHEN NOT local_status.normal

    set_file_attribute f=$fname(deadstart_tape) flt=labelled status=local_status
    EXIT crevdt_block WHEN NOT local_status.normal

    IF type = 'MT18$38000' THEN
       maxbl=32640
    ELSE
       maxbl=4128
    IFEND

    " Copy the deadstart files to the deadstart tape.

    putl ' '                                                    o=$fname(ofile//'.$eoi')
    put_line l='     Move files to the deadstart tape.'   o=$fname(ofile//'.$eoi')
    putl ' '                                              o=$fname(ofile//'.$eoi')


    FOR index = 1 TO (file_count - 1) DO
      get_block_and_record_type i=$fname(deadstart_files(index).name) bt=block_type rt=record_type ..
            status=local_status
      EXIT crevdt_block WHEN NOT local_status.normal
      change_tape_label_attributes f=$fname(deadstart_tape) fsp=next_file rl=TRUE ..
            fi=deadstart_files(index).file_id bt=block_type rt=record_type status=local_status
      EXIT crevdt_block WHEN NOT local_status.normal
      put_line l='     Copy '//deadstart_files(index).file_id o=$response
      copy_file i=$fname(deadstart_files(index).name) o=$fname(deadstart_tape) status=local_status
      EXIT crevdt_block WHEN NOT local_status.normal
    FOREND

    putl ' '  o=$fname(ofile//'.$eoi')
    put_line l=' Deadstart tape written.' o=$fname(ofile//'.$eoi')

  BLOCKEND crevdt_block

  detach_file f=$fname(deadstart_tape) uv=unload_deadstart_tape status=ignore_status

  FOR index = 1 TO total_deadstart_file_count DO
    detach_file f=$fname(deadstart_files(index).name) status=ignore_status
  FOREND

  EXIT PROCEDURE WITH local_status WHEN NOT local_status.normal

PROCEND qcp$make_correction_ds_tape
*DECK DECK=QCM$MAKE_QCU EXPAND=TRUE

PROC make_quick_corrective_update,  makqcu (
qcu_ident, qcu : name = $required
help, hp: key of help, hp, nohelp, np = nohelp
delivery_medium, dm: list of key tape, t, electronic, e, both, b = electronic
include_deadstart_tape, idt: boolean = FALSE
no_pause, np: boolean = FALSE
 status)


setta hp=off
crev work k=string
crev work1 k=string
crev ignore k=status
crev use_oc k=boolean v=TRUE
crev check k=boolean v=FALSE
crev predecessor k=boolean v=FALSE
crev local_status k=boolean
crev msg k=string
crev base k=string
crev qi   k=string v=$string($value(qcu_ident))
crev omap_path k=string v=':CSERV.CSERV.DEBUG_TABLES.'//$strrep(qi)
crev wev$working_catalog k=string scope=xref
crev wev$development_base k=string scope=xref
crev wev$build_level k=string s=xref

crev ty_path k=string v=wev$development_base//'.OS.'
     ty_path = ty_path//wev$build_level//'.TYING'

incf $fname(ty_path)
tl = $strlen(wev$release_level)

IF tl < 10 THEN
wev$release_level = 'R142_L727xx'
IFEND



crev name k=string d=1..50 v=''
crev found k=boolean v=FALSE
crev rejects k=string d=1..50  v=''
crev rcnt v=1

name(1) = 'OSF$MONITOR'
name(2) = 'OSF$SYSTEM_CORE_113'
name(3) = 'OSF$SYSTEM_CORE_133'
name(4) = 'OSF$SYSTEM_CORE_13D'
name(5) = 'OSF$SYSTEM_CORE_1DD'
name(6) = 'OSF$JOB_TEMPLATE_223'
name(7) = 'OSF$JOB_TEMPLATE_236'
name(8) = 'OSF$JOB_TEMPLATE_23D'
name(9) = 'OSF$JOB_TEMPLATE_2DD'
name(10) = 'OSF$VERSION'
name(11) = 'OSF$MESSAGE_TEMPLATES'
name(12) = 'OSF$BOOT_JOB'
  IF $string($value(help)) = 'HELP' OR $string($value(help)) = 'HP'  THEN
   makqcu12,check
   IF NOT check THEN
    EXIT_PROC
   IFEND
  IFEND

crev qev$os_level k=string v= $string($value(qcu_ident)) s=xdcl
crev qev$release_level k=string s=xdcl
crev qev$release_date k=string v=$date(mdy) s=xdcl

"************************************************************************
" Go initialize the Object catalog.
"************************************************************************
  makqcu11 $value(qcu_ident),check
   IF check THEN
    EXIT_PROC
   IFEND

p1 = $substr(qi,5,2)
putl ' '
putl ' Generating QCU materials'
putl ' '


"************************************************************************
" Announce type of media being produced
"************************************************************************
crev typet k=boolean v=FALSE       "generate only tape
crev typeb k=boolean v=FALSE       "generate both tape and electronic
crev typee k=boolean v=TRUE        "generate only elctronic
crev dtype k=string v='ELECTRONIC'
IF $string($value(delivery_medium)) = 'TAPE' OR..
 $string($value(delivery_medium)) = 'T' THEN
    typee = FALSE
    typet = TRUE
    dtype = 'TAPE'

ELSE
 IF $string($value(delivery_medium)) = 'BOTH' OR..
  $string($value(delivery_medium)) = 'B' THEN
    typee = FALSE
    typeb = TRUE
    dtype = 'BOTH'
 IFEND
IFEND
putl ' You have selected a QCU packaging medium for'
IF typeb THEN
putl '              both'
putl '          Tape delivery'
putl '              and'
putl '          Electronic delivery'
ELSEIF typet THEN
putl '          Tape delivery'
ELSE
putl '          Electronic delivery'
IFEND

"*******************************************************************************
"   This section will search the CSERV data base to ensure that a QCU
"   identifier was specified that is known to the system. A failure
"   here means that an invalid QCU ident was specified, or, the caller
"   of the procedure forgot to do a ASSQCU first, or, the CSERV data
"   base is corrupted, or, ??.
"******************************************************************************
putl ' '
putl ' Validating QCU identifier '
putl '           '//qi

IF $strlen(qi) <> 6 THEN
 putl ' An invalid identifier was specified'
 EXIT_PROC
IFEND

qcm$validate_qcu_base,qcu_ident,found

IF NOT found THEN
 putl '-'
 putl '                   ABORTING'
 putl ''
 putl '       '//$substr(qi,1,4)//' is not a system level that is'
 putl '       currently supported by this process.'
 putl '-'
 EXIT_PROC
IFEND

ipath = '.cserv.qcu.'//$substr(qi,1,4)//'.data.$asis'
detf $fname(ipath) status=ignore
attf $fname(ipath)
crev count
crev flag k=boolean v=FALSE
crev qev$qcu_base k=string s=xdcl status=ignore
crev qev$psr k=string s=xdcl status=ignore

accl v=work i=$fname(ipath) lc=count
WHILE count > 0 DO
 level = $substr(work,5,2)
 IF level <> p1 THEN
   accl v=work i=$fname(ipath) lc=count
 ELSE
   flag = TRUE
    qev$qcu_base = $Trim($substr(work,63,6))  "get base that qcu is built on
    qev$psr = $substr(work,11,7)              "get psr that qcu corrects
   accl v=work i=$fname(ipath) lc=count
 IFEND
WHILEND

   detf $fname(ipath) status=ignore
  IF NOT flag THEN
    putl ' '
    putl ' QCU ident '//qi//' is not known to the system '
    putl ' '
    putl ' Aborting request'
    putl ' '
    EXIT_PROC
  IFEND
"*******************************************************************************
"    This section  establishes path values.
"*******************************************************************************
work_path = wev$working_catalog
crev lib_path k=string v=work_path//'.OBJECT.MAINTENANCE'
crev imap_path k=string v=work_path//'.OBJECT.SYSTEM_DEBUG_TABLE'
crev e1_path k=string v=work_path//'.OBJECT.MONITOR_TEMPLATE'
crev e2_path k=string v=work_path//'.OBJECT.SYSTEM_CORE_DEBUG_TABLE'
crev e3_path k=string v=work_path//'.OBJECT.SYSTEM_CORE_SYMBOL_TABLE'
crev e4_path k=string v=work_path//'.OBJECT.SYSTEM_CORE_TEMPLATE'
crev e5_path k=string v=work_path//'.OBJECT.VIRTUAL_MEMORY_IMAGE'


"*******************************************************************************
" This section will show which libraries have been generated
"******************************************************************************
temp1_path = $unique//'.$asis'

name_path = '.'//$job(user)//'.'//$strrep(qi)//'_NAMES.$ASIS'
temp3_path = $unique//'.$asis'


delete_file $fname(name_path) status=ignore

crev bcus k=string d=1..30
crev bcnt v=19                " this is a temporary value till we automate


bcus(1) = '18521 - L727   - 1.4.2'
bcus(2) = '18525 - L727AA - 1.4.2'
bcus(3) = '18526 - L727AB - 1.4.2'
bcus(4) = '18527 - L727AC - 1.4.2'
bcus(5) = '18528 - L727AD - 1.4.2'
bcus(6) = '18529 - L727AE - 1.4.2'
bcus(7) = '18530 - L727AF - 1.4.2'
bcus(8) = '18531 - L727AG - 1.4.2'
bcus(9) = '17838 - L716   - 1.4.1'
bcus(10) = '17839 - L716AA - 1.4.1'
bcus(11) = '17840 - L716AB - 1.4.1'
bcus(12) = '17841 - L716AC - 1.4.1'
bcus(13) = '17842 - L716AD - 1.4.1'
bcus(14) = '17843 - L716AE - 1.4.1'
bcus(15) = '17844 - L716AF - 1.4.1'
bcus(16) = '17845 - L716AG - 1.4.1'
bcus(17) = '17846 - L716AH - 1.4.1'
bcus(18) = '17847 - L716AI - 1.4.1'
bcus(19) = '17848 - L716AJ - 1.4.1'

build = wev$build_level


detf $fname(work_path) status=ignore

 FOR i = 1 TO bcnt DO
  IF $substr(build,7,5) = $substr(bcus(i),1,5) THEN
    msg = $substr(bcus(i),9,6)
    base = $substr(bcus(i),18,5)
    EXIT
  IFEND
 FOREND


putl ' '
putl ' The system identifiers being used are'
putl '           RI = '//base
putl '           PI = '//qi
putl ' '
putl ' You specified that the corrections are based on'
putl '            '//msg
putl '    via the SETWE command'
putl '             and'
putl ' Should be applied on top of '
putl '            '//qev$qcu_base
putl '    via the ASSQCU command'
putl ' '


"*****************************************************************************
" See if there is a PACS catalog in .cserv.debug_tables to
" build on. Else, use the working catalog base.
"*****************************************************************************
  crev check_ic k=string v='.CSERV.DEBUG_TABLES.'//qev$qcu_base//'_QCU'
  predecessor = $file($fname(check_ic),permanent)

IF NOT predecessor THEN
 IF qev$qcu_base <> msg THEN
 putl ''
 putl ''
 putl '                     BE WARNED '
 putl ''
 putl ' Although specified by the '//$substr(qi,1,4)//' qcu data base, it seems'
 putl ' There is no predecessor QCU material available for '//qev$qcu_base//'.'
 putl ''
 putl ' You have the options of continuing or aborting this session.'
 putl ' If you should choose to continue, the '//msg//' base will'
 putl ' be used in it''s stead.'
 putl ' '
 putl ''
 putl ''
 IFEND
IFEND

IF $value(no_pause) = FALSE THEN
putl ' Enter QUIT if you do not wish to continue'
putl '        else, NEXT/RETURN'
accl v=work p='   ' i=input lc=count
  IF $TRANSLATE(LTU,$substr(work,1,1)) = 'Q' THEN
      EXIT_PROC
  IFEND
IFEND

putl ''
putl ' Begin QCU material collection'

" ***********************************************************************
" If generating a 1.4.1 QCU it is necessary to use the 1.4.2 or
" higher command library to compensate for and error in the raf$library.
"************************************************************************
IF base = '1.4.1' THEN

putl '-'
putl ' Note : Building a 1.4.1 QCU requires the presence of the'
putl '        .intve.r142_l727.os.build.maintenance.command_library'
putl '        in your command list. Otherwise a FATAL LL 164 error'
putl '        will abort the process.'
putl ''
putl '        If necessary, you may add the command library now ... '
putl ''
putl '        Enter GO when ready to continue the makqcu process.'
putl ''
accl v=work i=input p= '? ' lc=count
  WHILE count <> 0
   IF $translate(ltu,$substr(work,1,2)) = 'GO' THEN
      EXIT
   IFEND
    incl work
    accl v=work i=input p= '? '
  WHILEND
IFEND

"****************************************************************************
" Verify that the libraries in the Maintenance subcatalog are all part
" of the NOSVE_MAINTENANCE subproduct. Report any exceptions and query
" the user for directions.
"*****************************************************************************
disc $fname(lib_path) o=$fname(temp1_path)
rewf $fname(temp1_path)
crev libs k=string d=1..100  v=''
crev libc v=1

count = 1
WHILE count > 0 DO
  accl v=work i=$fname(temp1_path) lc=count
  IF $substr(work,5,5) = 'FILE:' AND count > 0 ..
   AND $substr(work,11,3) <> 'RAF' THEN
   libc = libc + 1
   libs(libc) = $trim($substr(work,11,31))
  IFEND
WHILEND


IF libc <> 0 THEN
 FOR j = 1 TO libc DO
    found = FALSE
   FOR i = 1 TO 50 DO
     IF name(i) = libs(j) THEN
        found = true
     IFEND
   FOREND
    IF NOT found THEN
     rejects(rcnt) = libs(j)
     rcnt = rcnt + 1
    IFEND
   FOREND

  rcnt = rcnt-1
 IF rcnt > 0 THEN
  putl '-'
   putl '-'
   putl '                 BE WARNED'
   putl ''
   putl ' This QCU specifies libraries that are not candidates for'
   putl ' electronic delivery and installation. You have the options '
   putl ' of continuing or aborting this session. If you choose to'
   putl ' continue, the end product of the following libraries will'
   putl ' not be included as part of the QCU''s electronic or tape'
   putl ' CP deliverables. If the libraries are DS tape resident'
   putl ' they will be included as part ot the IDT option if'
   putl ' selected.'
   putl ''
     FOR i = 1 TO rcnt DO
      putl '                '//rejects(i)
     FOREND
   putl '-'
   putl ''
   putl ''
   putl '    Enter QUIT if you do not wish to continue'
   putl '           else, NEXT/RETURN'
   accl v=work p='   ' i=input lc=count
  IF $TRANSLATE(LTU,$substr(work,1,1)) = 'Q' THEN
      EXIT_PROC
  IFEND
 IFEND
    detf $fname(temp1_path) status=ignore
IFEND





"**************************************************************************
" Go get the library names for the predecessor QCU for verification and
" the PAC modification for use as a feature catalog.
"*************************************************************************
 crev oname k=string d=1..100
 crev oc v=1

  IF predecessor THEN
   makqcu7,$value(qcu_ident),$name(qev$qcu_base)
   crev fc_path k=string v='.'//$job(user)//'.'//qev$qcu_base
   crev nl_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_NL.$ASIS'

   attf $fname(nl_path) status=ignore
   count = 1
   WHILE count > 0 DO
    accl v=work i=$fname(nl_path) lc=count
    IF count <> 0 THEN
       oname(oc) = work
       oc = oc + 1
    IFEND
   WHILEND
  IFEND

"*******************************************************************************
" Make sure that the predecessor QCU is actually included in this one.
"*******************************************************************************
  crev valid k=boolean v=FALSE

    FOR j = 1 TO oc DO
      IF oname(j) = 'OSF$VERSION' THEN
         j = j+1
      IFEND
    FOR i = 1 TO libc DO
      IF oname(j) = libs(i) THEN
       valid = TRUE
      IFEND
    FOREND
    IF NOT valid THEN
       crev m1 k=string v=$strrep(qi)
       crev m2 k=string v=qev$qcu_base
    putl ''
    putl '-'
    putl '-'
    putl ''
    putl '                    BE WARNED'
    putl ''
    putl ' QCU '//m1//' claims to be based on QCU '//m2//'. However,'
    putl ' materials provided with this session are not logically'
    putl ' connected to the materials used to construct '//m2//'.'
    putl ''
    putl ' Should you choose to continue, the "base" value specified by '
    putl ' the qcu data base for '//m1//' will be ignored and the '//msg
    putl ' base as specified by the working environment will be used.'
   putl ''
   putl ''
   putl ''
   putl ''
   putl ''
   putl '     Enter QUIT if you do not wish to continue'
   putl '            else, NEXT/RETURN'
   accl v=work p='   ' i=input lc=count
      IF $TRANSLATE(LTU,$substr(work,1,1)) = 'Q' THEN
       delcc $fname(fc_path) status=ignore
       delc $fname(fc_path) status=ignore
       delf $fname(nl_path) status=ignore

          EXIT_PROC
      ELSE
          use_oc = FALSE
          EXIT
      IFEND
     IFEND
    FOREND
delv libs status=ignore
delv libc status=ignore

"************************************************************************
" Now go link the system.
"************************************************************************
putl ''
putl '        Linking the QCU'

  linqcu,lsc=on,bos=on,sbl=on,ri=base,pi=qi,wc=$fname(work_path)..
,bl=$name(build)



"******************************************************************************
" This section moves the debug table generated by the QCU link to the cserv
" debug_tables catalog. Once moved it purges the users version of the table.
"******************************************************************************
putl ' '
putl '        Moving debug tables from '
putl '    '//imap_path
putl '                   to   '
putl '    '//omap_path
putl ' '

           copf $fname(imap_path) $fname(omap_path)  status=ignore





"**************************************************************************
" Get all the file names from the maintenance catalog for use in building
" the PACS catalog.
"**************************************************************************
disc $fname(lib_path) o=$fname(temp1_path)
rewf $fname(temp1_path)
crev libs k=string d=1..100  v=''
crev libc v=1


"**************************************************************************
" Add identifier osf$version since it's always modified by a QCU.
"**************************************************************************
   putl 'OSF$VERSION' o=$fname(name_path)
   libs(libc) = 'OSF$VERSION'


count = 1
WHILE count > 0 DO
  accl v=work i=$fname(temp1_path) lc=count
  IF $substr(work,5,5) = 'FILE:' AND count > 0 ..
   AND $substr(work,11,3) <> 'RAF' THEN
   putl $substr(work,11,31) o=$fname(name_path//'.$EOI')
   libc = libc + 1
   libs(libc) = $trim($substr(work,11,31))
  IFEND
WHILEND

IF use_oc THEN
 FOR i = 1 TO libc DO
  n1 = libs(i)
   FOR j = 1 TO oc DO
     IF n1 = oname(j) THEN
       oname(j) = ''
     IFEND
   FOREND
 FOREND

    FOR i = 1 TO oc DO
      IF oname(i) <> '' AND $substr(oname(i),1,3) <> 'RAF' THEN
       putl oname(i) o=$fname(name_path//'.$EOI')
      IFEND
    FOREND
IFEND

putl ' '
detf $fname(name_path) status=ignore
attf $fname(name_path) status=ignore
rewf $fname(name_path)

IF libc = 0 THEN
   putl ' There are no libraries to generate'
   putl ' Aborting request'
ELSE
putl ' This QCU modified the following libraries'
  count = 1
 WHILE count > 0 DO
  accl v=work i=$fname(name_path) lc=count
    IF count <> 0 THEN
      putl '          '//work
    IFEND
 WHILEND
IFEND




"****************************************************************************
" Go establish the correct platform (base) for the QCU generation.
"****************************************************************************
    makqcu10,$value(qcu_ident)


"****************************************************************************
" Go generate the corrections for the QCU
"****************************************************************************
    makqcu1,$value(qcu_ident),typee,local_status,$value(no_pause)


     IF  local_status = TRUE THEN



"***************************************************************************
" Generate a deadstart tape if requested with vsn=QCU_ident + D preface
"**************************************************************************
    IF $value(include_deadstart_tape) = TRUE THEN
     putl ' Generating deadstart tape with vsn of '//$string(D)//$substr(qi,2,5)
     putl '       At '//$time(hms)//'  On '//$date(mdy)

     work = 'GENQDT evsn=''D'//$substr(qi,2,5)//''''
     incl work
   IFEND
 delf $fname(temp1_path) status=ignore
 delf $fname(name_path) status=ignore
IFEND


crev a1 k=string v='.'//$job(user)//'.'//$strrep(qi)//'_DF'
crev a2 k=string v='.'//$job(user)//'.'//$strrep(qi)//'_NL'
crev a3 k=string v='.'//$job(user)//'.'//$strrep(qi)//'_PL'
crev a4 k=string v='.'//$job(user)//'.'//$strrep(qi)//'_FC'
crev a5 k=string v='.'//$job(user)//'.'//$strrep(qi)//'_CF'
crev a6 k=string v='.'//$job(user)//'.'//$strrep(qi)//'_QF'
crev a7 k=string v='.'//$job(user)//'.'//$strrep(qi)//'_PA'
crev a8 k=string v='.'//$job(user)//'.'//$strrep(qi)//'_PB'






 delf $fname(e1_path) status=ignore    "get rid of unnecessary files
 delf $fname(e2_path) status=ignore
 delf $fname(e3_path) status=ignore
 delf $fname(e4_path) status=ignore
 delf $fname(e5_path) status=ignore
 delf $fname(imap_path) status=ignore

 delf $fname(a1) status=ignore
 delf $fname(a2) status=ignore
 delf $fname(a3) status=ignore
 delc $fname(a4) do=cac status=ignore
 delf $fname(a5) status=ignore
 delf $fname(a6) status=ignore
 delc $fname(a7) do=cac status=ignore
 delc $fname(a8) do=cac status=ignore

delcc $fname(fc_path) status=ignore
delc $fname(fc_path) status=ignore

putl ' '
putl ' QCU generation complete'
putl ' '

setta hp=on        " reset the hold page option

 PROCEND make_quick_corrective_update
*DECK DECK=QCM$MAKE_QCU_PHASE_1 EXPAND=TRUE

PROC makqcu_phase_1, makqcu1  (
qcu_ident, qcu: name = $required
delivery_medium, dm: boolean
continue : VAR of boolean
no_pause, np : boolean)

"******************************************************************************
" This phase will produce a catalog containing all the modified OS
" libraries and generate the QCU correction package.
"
" At completion, the new CP will be in $user.qcu_FC (Field changes)
"******************************************************************************

$value(continue) = TRUE
crev count
crev work k=string
crev ignore k=status
crev msg k=string
crev qi   k=string v=$string($value(qcu_ident))
crev wev$working_catalog k=string scope=xref
crev wev$build_level k=string scope=xref
crev qev$psr k=string scope=xref
p1 = $substr(qi,5,2)
work_path = wev$working_catalog
build = wev$build_level


"******************************************************************************
" This section will search the PACS catalog and locate the path
" descriptor for each library generated. The purpose of this is to aid
" in determining what materials make up the QCU.
"******************************************************************************
crev temp1_path k=string v=$unique//'.$asis'

"*****************************************************************************
" Define base level, current level and previous correction catalog paths
" for use by the define correction subproduct.
"*****************************************************************************
crev blc_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_PA'
     blc_path = blc_path//'.NOSVE_MAINTENANCE'

crev clc_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_PB'
     clc_path = clc_path//'.NOSVE_MAINTENANCE'

crev pcc_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_PB'

crev fcc_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_FC'

crev first k=boolean v=true
crev r k=integer d=1..3
crev local_status  k=status
crev cnt v=0
crev mypath k=string v=''
crev idnt k=string v=''
crev found k=boolean
crev type
crev element k=string

delcc $fname(fcc_path) status=ignore
delc  $fname(fcc_path) status=ignore




putl ' '
putl ' Building  new staging data for '
putl ''
putl '        PSR   '//$string(qev$psr)
putl ' '
putl '             And now ...'
putl ''

PACS

putl '   "Would you tell me, please, which way I ought to go from here."'
 CRESC   status=local_status
        EXIT_PROC with local_status WHEN NOT local_status.normal

putl '   "That depends a great deal on where you want to get to," said the cat.'


  DEFC n=NOSVE_MAINTENANCE blc=$fname(blc_path) clc=$fname(clc_path) status=local_status
        EXIT_PROC with local_status WHEN NOT local_status.normal
putl '   "I don''t much care where --," said Alice.'
putl '   "Then it doesn''t matter which way you go," ...'

   CHACA  pa=$name(qev$psr)
        EXIT_PROC with local_status WHEN NOT local_status.normal


putl '   "-- So long as I get somewhere," ...'
putl '   "Oh, you''re sure to do that," said the cat,'
   GENC pc=$fname(fcc_path)  status=local_status
        EXIT_PROC with local_status WHEN NOT local_status.normal


 QUIT
QUIT
        EXIT_PROC with local_status WHEN NOT local_status.normal

putl '    "If you only walk long enough."'



"***********************************************************************
" The correction package is complete
"***********************************************************************

IF $value(continue) THEN
   makqcu2,$value(qcu_ident),$value(delivery_medium),$value(no_pause)
IFEND

 PROCEND makqcu_phase_1
*DECK DECK=QCM$MAKE_QCU_PHASE_10 EXPAND=TRUE

PROC make_qcu_phase_10, makqcu10 (
qcu_ident, qi: name = $required
status )

putl ''
putl ' Establish Platform and Level environment'
putl ''
crev ignore k=status
crev wev$working_catalog k=string s=xref
crev qev$os_level k=string v= $string($value(qcu_ident)) s=xref
crev qev$release_level k=string s=xref
crev qev$release_date k=string v=$date(mdy) s=xref
crev qi k=string v=$string($value(qcu_ident))

crev pa_path k=string v='.'//$job(user)//'.'//$value(qcu_ident)//'_PA'
     pa_path = pa_path//'.NOSVE_MAINTENANCE'

crev pb_path k=string v='.'//$job(user)//'.'//$value(qcu_ident)//'_PB'
     pb_path = pb_path//'.NOSVE_MAINTENANCE'

crev e1_path k=string v='.'//$job(user)//'.'//$value(qcu_ident)//'_CF'
crev e2_path k=string v='.'//$job(user)//'.'//$value(qcu_ident)//'_QF'
crev e3_path k=string v='.'//$job(user)//'.'//$value(qcu_ident)//'_FC'
crev sc_path k=string v='.'//$job(user)//'.'//$value(qcu_ident)//'_SC'

"*************************************************************************
" Initialize the PACS catalogs (base and correction)
"*************************************************************************
  delcc $fname(pa_path) status=ignore
  delcc $fname(pb_path) status=ignore
  delf $fname(e1_path) status=ignore
  delf $fname(e2_path) status=ignore
  delcc $fname(e3_path) status=ignore
  delc $fname(e3_path) status=ignore



"*************************************************************************
" Go expand the raf$ product tables to identify the subproduct under
" construction.
"*************************************************************************

" Special case 1.4.2 until product table mods are incorporated
IF $substr(qi,2,3) = '727' THEN
  makqcu9,$value(qcu_ident)
  coms d=qcm$base_product_table sc=$fname(sc_path) l=$null
  makqcu9,$value(qcu_ident)
  coms d=qcm$qcu_product_table sc=$fname(sc_path)
ELSE
  makqcu9,$value(qcu_ident)
  coms d=qcm$base_product_table l=$null
  makqcu9,$value(qcu_ident)
  coms d=qcm$qcu_product_table  l=$null
IFEND

  delf $fname(sc_path) status=ignore


"*************************************************************************
" Go get rid of unnecessary libraries in qcf$ decks
"*************************************************************************
  makqcu6 $value(qcu_ident)


"*************************************************************************
" Go generate the base platform tables and the level tables
"*************************************************************************
  genpf $value(qcu_ident)
  genls $value(qcu_ident)




PROCEND make_qcu_phase_10
*DECK DECK=QCM$MAKE_QCU_PHASE_11 EXPAND=TRUE
PROC make_qcu_phase_11, makqcu11 (
  qcu_ident, qi: name = $required
  check, c: VAR of boolean
  status )

crev ignore k=status
crev wev$working_catalog k=string s=xref
crev stop k=boolean v=FALSE

crev w_path k=string v='.'//$job(user)//'.'//$value(qcu_ident)//'_WC.$ASIS'

crev l_path k=string v= wev$working_catalog//'.OBJECT'

crev a_path k=string v= wev$working_catalog//'.OBJECT.MAINTENANCE'
     a_path = a_path//'.QCF$BASE_PRODUCT_TABLE'

crev b_path k=string v= wev$working_catalog//'.OBJECT.MAINTENANCE'
     b_path = b_path//'.QCF$QCU_PRODUCT_TABLE'

putl ' '
putl ' '
putl ' Leveling the Platform Environment'

detf $fname(a_path) status=ignore
detf $fname(b_path) status=ignore
delf f=($fname(a_path),$fname(a_path//'.$low'),$fname(a_path//'.$low')) status=ignore
delf f=($fname(b_path),$fname(b_path//'.$low'),$fname(b_path//'.$low')) status=ignore

check = FALSE

stop = $file($fname(l_path),catalog)


IF NOT stop THEN
putl '-'
putl '-'
putl '                        ABORTING '
putl ' '
putl ' There is no OBJECT subcatalog in the working catalog specified.'
putl ' It will be necessary to compile any modules that comprise QCU'
putl ' '//$string(qcu_ident)//' before attempting another MAKQCU. The other possibility'
putl ' is that the working environment specifies an inappropriate value'
putl ' for working catalog.'
putl '-'

$value(check) = TRUE
EXIT_PROC
IFEND


delf $fname(w_path) status=ignore

disc $fname(l_path) o=$fname(w_path)
detf $fname(w_path) status=ignore
attf $fname(w_path) status=ignore
crev count  v=1
crev work k=string
WHILE count > 0 DO
accl v=work i=$fname(w_path) lc=count
IF count = 0 THEN
   EXIT
IFEND

IF $substr(work,5,5) = 'FILE:' THEN
 delf $fname(l_path//'.'//$substr(work,11,$strlen(work)))
IFEND
WHILEND

delf $fname(w_path) status=ignore



PROCEND make_qcu_phase_11
*DECK DECK=QCM$MAKE_QCU_PHASE_12 EXPAND=TRUE

PROC make_qcu_phase_12, makqcu12 (
     check, c: VAR of boolean
     status )

crev work k=string
crev count
$value(check) = TRUE

"***********************************************************************
" This procedure provides help information
"***********************************************************************

putl '-'
putl '     MAKQCU uses the output produced by the COMS procedure'
putl '     to generates a binary code correction set suitable for    '
putl '     transmitting electronically via various link methods.  '
putl ' '
putl '     The binary correction set produced is moved to files in'
putl '     the user catalog of :CSERV.ARHOPS on system ORANGE and'
putl '     it is also moved to :DSB.SERVICE on system SYSTEMB for'
putl '     access by external customers. '
putl ''
putl '     The requirments of this procedure are that the   '
putl '     working environment be established in terms of    '
putl '     build level and working catalog and that the features  '
putl '     making up the QCU have been compiled. The MAKQCU    '
putl '     performs its own link.'



putl ''
putl ' Enter QUIT if you do not wish to continue'
putl '        else, NEXT/RETURN'
accl v=work p='   ' i=input lc=count
  IF $TRANSLATE(LTU,$substr(work,1,1)) = 'Q' THEN
      $value(check) = FALSE
  IFEND


PROCEND make_qcu_phase_12
*DECK DECK=QCM$MAKE_QCU_PHASE_2 EXPAND=TRUE
PROC makqcu_phase_2, makqcu2 (
qcu_ident           : name = $required
delivery_medium,  dm: boolean
no_pause, np : boolean
status )


crev ignore k=status
crev qi k=string v=$string($value(qcu_ident))
crev wev$working_catalog k=string s=xref
crev wev$build_level k=string s=xref
crev work k=string
crev count
crev qev$psr k=string s=xref



crev oc_path  k=string v='.'//$job(user)//'.'//$strrep(qi)//'_OC'
crev pack  k=string v='.'//$job(user)//'.'//$strrep(qi)//'_PL'
crev df_path  k=string v='.'//$job(user)//'.'//$strrep(qi)//'_DF'
crev pc_path  k=string v='.'//$job(user)//'.'//$strrep(qi)//'_FC'
crev pl_path  k=string v='.'//$job(user)//'.'//$strrep(qi)//'_OC.'
     pl_path = pl_path//'RAF$PACKING_LIST'

delcc $fname(oc_path) status=ignore
delc  $fname(oc_path) status=ignore
delf  $fname(df_path) status=ignore

crev ty_path k=string v=wev$development_base//'.OS.'
     ty_path = ty_path//wev$build_level//'.TYING'

incf $fname(ty_path)

putl ''
putl ' Building Repair Record'
putl ''
disv wev$release_level
PACS
   CREOD
     DEFINE_ORDER i=$value(qcu_ident) m=disk t=correction
        ADD_SUBPRODUCT  pc=$fname(pc_path)  l=wev$release_level
        WRITE_DEFINITION oc=$fname(oc_path)
     QUIT
   WRITE_ORDER oc=$fname(oc_path) df=$fname(df_path)

  putl ''
  putl ''
  putl ' The QCU attributes are:'
  putl ' '
   DISPLAY_PACKING_LIST $fname(pl_path)
   DISPLAY_PACKING_LIST $fname(pl_path) o=$fname(pack)
 QUIT


putl ''
IF NOT $value(no_pause) THEN
   putl ' Pause to review correction information. Please'
   putl ' enter QUIT if you do not wish to continue'
   putl '        else, NEXT/RETURN'
   accl v=work p='   ' i=input lc=count
  IF $TRANSLATE(LTU,$substr(work,1,1)) = 'Q' THEN
      EXIT_PROC
  IFEND
IFEND

detf $fname(df_path) status=ignore
delcc $fname(oc_path) status=ignore
delc $fname(oc_path) status=ignore


makqcu3,$value(qcu_ident),$value(delivery_medium)


PROCEND makqcu_phase_2


*DECK DECK=QCM$MAKE_QCU_PHASE_3 EXPAND=TRUE
PROC makqcu_phase_3, makqcu3 (
qcu: name = $required
delivery_medium, dm:  boolean
status )


crev qev$psr k=string s=xref
crev ignore k=status
crev qi k=string v=$string($value(qcu))
crev work k=string
crev wev$working_catalog k=string s=xref

crev c_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_BACKUP'
crev t_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_TEMP'

crec $fname(c_path) status=ignore

"*************************************************************************
" This section establishes variables and the environment for this proc
" and cleans up the post-build environment.
"*************************************************************************


crev pa_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_PA'
crev pb_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_PB'
crev qf_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_QF'
crev cf_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_CF'
crev new_pac k=string v=wev$working_catalog//'.OBJECT.MAINTENANCE'
crev df_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_DF'
crev qcu_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_QCU'
crev na_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_NAMES'
crev pl_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_PL'
crev psr_path k=string v=':CSERV.ARHOPS.'//qev$psr


crev cp_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_QCU.DISK_FILE'
crev qn_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_QCU.NAMES'
crev li_path k=string v='.'//$job(user)//'.'//$strrep(qi)
     li_path = li_path//'_FC.LINK_INPUT_FILES'


crec $fname(qcu_path) status=ignore
copf $fname(df_path) $fname(cp_path)
copf $fname(na_path) $fname(qn_path)


delf $fname(new_pac//'.RAF$PRODUCT_TABLE') status=ignore
delf $fname(new_pac//'.RAF$QCU_PRODUCT_TABLE') status=ignore
"******************************************************************************
"
" Copy the new QCU catalog to the CSERV debug_tables catalog for future use
"******************************************************************************
work = 'BACPF,l=$null,BF='//$strrep(t_path)
work = work//'; BACC '//li_path
work = work//'; BACF '//na_path
work = work//'; BACF '//pl_path
work = work//'; QUIT'
incl work

rewf $fname(t_path) status=ignore
copf $fname(t_path) $fname(psr_path)
delf $fname(t_path) status=ignore
delcc $fname(c_path) status=ignore
delc $fname(c_path) status=ignore
putl ''
putl ' Moving QCU History files from'
putl '        '//$translate(ltu,qcu_path)
putl '               to'
putl '   '//$translate(ltu,psr_path)
putl ''
putl ''


delcc $fname(pa_path) status=ignore
delc  $fname(pa_path) status=ignore
delf $fname(cf_path) status=ignore
delf $fname(qf_path) status=ignore
delcc $fname(pb_path) status=ignore
delc $fname(pb_path) status=ignore
delcc $fname(qcu_path) status=ignore
delc $fname(qcu_path) status=ignore
delcc $fname(li_path) status=ignore
delc $fname(li_path) status=ignore


  makqcu4,$value(qcu),$value(delivery_medium)


PROCEND makqcu_phase_3
*DECK DECK=QCM$MAKE_QCU_PHASE_4 EXPAND=TRUE



PROCEDURE makqcu_phase_4, makqcu4 (
qcu: name = $required
delivery_medium, dm: boolean
status )


crev ignore k=status
crev qi k=string v=$string($value(qcu))
crev work k=string
crev wev$working_catalog k=string s=xref
crev qev$psr k=string s=xref
crev qev$qcu_base k=string s=xref
crev count1
crev count2
crev blank k=string v=' '
crev comma k=string v=','
crev msg k=string

crev temp1 k=string v=$unique//'.$asis'
crev psr_path k=string v=':CSERV.ARHOPS.'//$translate(ltu,qev$psr)
crev save_cp  k=string v=':DSB.SERVICE.'//$translate(ltu,qev$psr)
crev cp_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_DF'
crev hi_path k=string v=':CSERV.ARHOPS.HISTORY.$EOI'
crev ds_path k=string v=':DSB.SERVICE.HISTORY'
crev temp2 k=string v=$unique

crerv DSB 'LOGIN SERVICE CENTER DSB'

copf $fname(ds_path) $fname(temp2)

detf $fname(hi_path) status=ignore

putl ' Moving QCU Corrections from'
putl '        '//cp_path
putl '               To'
putl '   '//save_cp
putl '               And'
putl '    '//psr_path

copf $fname(psr_path) $fname(save_cp)



disce $fname(psr_path) do=c o=$fname(temp1)
rewf $fname(temp1) status=ignore

FOR i = 1 TO 3 DO
accl v=work i=$fname(temp1)
FOREND

msg = $substr(work,13,8)

    count1 = $scan_not_any(blank,msg)
    work = $substr(msg,count1,$strlen(msg))
    msg = $trim(work)


work = ' '
FOR i = 1 TO $strlen(msg) DO
  IF $substr(msg,i,1) <> ',' THEN
    work = work//$substr(msg,i,1)
  IFEND
FOREND

count2 = $integer(work)
count1 = count2/7200

work = '  '//$translate(ltu,qev$psr)//'        '//$strrep(qi)//'          '
work = work//$translate(ltu,qev$qcu_base)//'          '//msg//'         '
work = work//$strrep(count1)//' Minutes'

putl work o=$fname(hi_path//'.$EOI')
putl work o=$fname(temp2//'.$EOI')

rewf $fname(temp2) status=ignore
copf $fname(temp2) $fname(ds_path)

putl ''
putl ' Completed electronic packaging'
putl ''

delrv DSB

only_electronic =  $value(delivery_medium)
IF NOT only_electronic THEN
  makqcu5,$value(qcu)
ELSE
IFEND

PROCEND makqcu_phase_4

*DECK DECK=QCM$MAKE_QCU_PHASE_5 EXPAND=TRUE

PROC makqcu_phase_5, makqcu5 (
qcu: name = $required
status )

"******************************************************************************
" This procedure creates a tape copy of the correction package.
"******************************************************************************

crev ignore k=status
crev qi k=string v=$string($value(qcu))
crev work k=string
crev wev$working_catalog k=string s=xref
crev cp_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_DF'
p1 = $substr(qi,5,2)
putl ' Generating QCU correction tape, VSN = '//$strrep(qi)
crev q_path k=string v=$strrep(qi)

work = 'REQMT $local.'//$strrep(q_path)//',t=mt9$6250,r=yes,evsn='
work=work//''''//$strrep(qi)//''''
incl work

work = 'BACPF l=$null bf= $local.'//$strrep(q_path)
work = work//'; BACF $user.'//$strrep(qi)//'_DF'
work = work//'; QUIT'

incl work

putl ''
putl ' Completed corrections tape '
putl ''

PROCEND makqcu_phase_5

*DECK DECK=QCM$MAKE_QCU_PHASE_6 EXPAND=TRUE

PROC make_qcu_phase_6, makqcu6 (
qcu_ident, qi: name = $required
status )


"*******************************************************************************
" This procedure deletes the deck calls from qcf$product_table and
" qcf$qcu_product_table that are not related to the current correction.
"*******************************************************************************



crev wev$working_catalog k=string s=xref
crev local_status k=status
crev ignore k=status

crev a_path k=string v='.'//$job(user)//'.'//$strrep(qcu_ident)//'_ae.$ASIS'
crev b_path k=string v='.'//$job(user)//'.'//$strrep(qcu_ident)//'_names.$asis'
crev c_path k=string v= $unique
crev al_path k=string v= wev$working_catalog//'.OBJECT.MAINTENANCE.'
     al_path = al_path//'QCF$BASE_PRODUCT_TABLE'

crev bl_path k=string v= wev$working_catalog//'.OBJECT.MAINTENANCE.'
     bl_path = bl_path//'QCF$QCU_PRODUCT_TABLE'

delf $fname(a_path) status=ignore


SCU
  usel $fname(al_path)
  edid d=NOSVE_MAINTENANCE  p=$null m=SPECIAL o=$fname(a_path)
  rewf $fname(a_path)
  l '*copy ' n=all
  quit
QUIT

detf $fname(a_path) status=ignore
attf $fname(a_path)

crev entry k=string d=1..20 v=''
crev work k=string
crev count v=1
crev cnt v=1
crev modified k=boolean v=FALSE

detf $fname(b_path) status=ignore
attf $fname(b_path)

WHILE count > 0 DO
 accl v=work i=$fname(b_path) lc=count
  IF work <> ' ' AND count <> 0 THEN
   entry(cnt) = $substr(work,5,$strlen(work)-4)
   cnt = cnt + 1
  IFEND
WHILEND

cnt = cnt-1

rewf $fname(a_path) status=ignore
count = 1

WHILE count > 0 DO
     accl v=work i=$fname(a_path) lc=count
     l1 = $substr(work,18,$strlen(work)-17)
     flagger = FALSE
   FOR i = 1 TO cnt DO
     IF entry(i) =  l1 THEN
      flagger = TRUE
     IFEND
   FOREND
     IF NOT flagger AND $substr(work,12,7) <> 'VERSION' THEN
      putl 'delt t='''//$substr(work,2,$strlen(work)-1)//''''..
        o=$fname(c_path//'.$EOI')
      modified = TRUE
     IFEND
WHILEND

"******************************************************************************
" Make sure there is somthing to modify in the library, else exit.
"******************************************************************************
IF NOT modified THEN
   EXIT_PROC
IFEND

rewf $fname(c_path) status=ignore

putl ''
putl ' Modifying the platform product table'
SCU
  usel $fname(al_path) r=$fname(al_path//'.$NEXT')
  edid d=NOSVE_MAINTENANCE  p=$null m=SPECIAL o=$null
  incf $fname(c_path)
  quit
QUIT,YES

rewf $fname(c_path) status=ignore


putl ''
putl ' Modifying the levels product table'
SCU
  usel $fname(bl_path) r=$fname(bl_path//'.$NEXT')
  edid d=NOSVE_MAINTENANCE  p=$null m=SPECIAL o=$null
  incf $fname(c_path)
  quit
QUIT,YES


delf $fname(a_path) status=ignore
delf $fname(c_path) status=ignore
detf $fname(al_path) status=ignore
detf $fname(bl_path) status=ignore
detf $fname(name_path) status=ignore

PROCEND make_qcu_phase_6

*DECK DECK=QCM$MAKE_QCU_PHASE_7 EXPAND=TRUE


PROC makqcu_phase_7, makqcu7 (
qcu: name = $required
base: name = $required
status )

crev ignore k=status
crev qi k=string v=$string($value(qcu))
crev bi k=string v=$string($value(base))
crev work k=string
crev msg k=string
crev count v=1
crev wev$working_catalog k=string s=xref

crev q_path  k=string v='.'//$job(user)//'.'//$strrep(bi)
crev qcu_path k=string v=':CSERV.CSERV.DEBUG_TABLES.'//$strrep(bi)//'_QCU'
crev temp  k=string v='.'//$job(user)//'.'//$strrep(qi)//'_SCR.$ASIS'
crev temp1 k=string v=$unique//'.$ASIS'
crev nl_path  k=string v='.'//$job(user)//'.'//$strrep(qi)//'_NL'
crev nam_path  k=string v='.'//$job(user)//'.'//$strrep(bi)//'.NAMES'
crev pl_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_PL'
crev na_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_NA'
crev cb_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_CB'

delf $fname(pl_path) status=ignore
delf $fname(na_path) status=ignore
delc $fname(cb_path) do=cac status=ignore

crev break k=string v='_'
crev temp k=string v=$unique//'.$asis'
crev link_path k=string

RESPF l=$fname(temp)
DISBF BF=$fname(qcu_path)
QUIT

crev counter
rewf $fname(temp) status=ignore
WHILE counter < 2 DO
 accl v=work i=$fname(temp) lc=count
 IF $substr(work,2,1) = ':' THEN
  counter = counter + 1
 IFEND
WHILEND

crev base_path k=string
crev name_path k=string
crev head_path k=string

link_path = work
count = $scan_string(break,work)
count = count -1
base_path = $substr(work,1,count)
name_path = base_path//'_names'
head_path = base_path//'_pl'

RESPF l=$fname(temp)
RESC c=$fname(link_path) ncn=$fname(cb_path) bf=$fname(qcu_path)
RESF f=$fname(name_path) nfn=$fname(na_path) bf=$fname(qcu_path)
RESF f=$fname(head_path) nfn=$fname(pl_path) bf=$fname(qcu_path)
QUIT



delcc $fname(q_path) status=ignore
delc $fname(q_path) status=ignore
delf $fname(temp) status=ignore
detf $fname(a_path) status=ignore


crev name k=string


"*************************************************************************
" This section restores the QCU Catalog from CSERV to the
" users catalog to prepare the new QCU base. The first section determines
" the name of the catalog in the CSERV.DEBUG_TABLES catalog.
"*************************************************************************
work = 'RESPF,l='//temp
work = work//'; DISBF bf='//qcu_path
work = work//'; QUIT'
incl work

detf $fname(temp) status=ignore
attf $fname(temp) status=ignore


"**************************************************************************
" Position to 2nd occurance of colon, this will be first catalog entry
"**************************************************************************
crev cc   v=0
WHILE CC <> 2 DO           "loop until 2nd occurance of :
accl v=work i=$fname(temp) lc=count
  IF $substr(work,2,1) = ':' THEN
    cc = cc+1
  IFEND
WHILEND

    putl ' Acquiring predecessor base from '
    putl '  '//qcu_path
    rewf $fname(temp)
    msg = 'RESPF l=$null;'
    msg = msg//'RESC bf='//qcu_path//',c='
    msg = msg//$substr(work,2,$strlen(work)-1)
    msg = msg//',ncn='//q_path
    msg = msg//';QUIT'
    incl msg

  detf $fname(q_path) status=ignore
  detf $fname(ic_path) status=ignore
  delf $fname(temp) status=ignore
  detf $fname(nl_path) status=ignore
  delf $fname(nl_path) status=ignore


"******************************************************************************
" Copy in the names list.
"******************************************************************************
  copf $fname(nam_path) $fname(nl_path)
  detf $fname(nl_path) status=ignore


PROCEND makqcu_phase_7
*DECK DECK=QCM$MAKE_QCU_PHASE_8 EXPAND=TRUE


PROC make_qcu_phase_8, makqcu8 (
error: boolean
status )

" at the present time just abort
putl ' '
putl ' Aborting QCU generation'
putl ' '

PROCEND make_qcu_phase_8

*DECK DECK=QCM$MAKE_QCU_PHASE_9 EXPAND=TRUE

PROC make_qcu_phase_9, makqcu9 (
qcu_ident, q: name = $required
status )


"******************************************************************************
"*******************************************************************************
crev count  v=1
crev work k=string
crev ignore k=status
crev qi k=string v=$string($value(qcu_ident))
crev wev$working_catalog k=string s=xref

" Special case 1.4.2 until product table mods are incorporated
IF $substr(qi,2,3) = '716' THEN
 EXIT_PROC
IFEND

crev sc_path k=string v='.'//$job(user)//'.'//$strrep(qi)//'_SC'
crev wv_path k=string v=wev$working_catalog//'.wef$feature_list'

detf $fname(sc_path) status=ignore
delf $fname(sc_path) status=ignore
attf $fname(wv_path) status=ignore

copf $fname(wv_path) $fname(sc_path) status=ignore


putl 'INCM SCW_7069' o=$fname(sc_path//'.$EOI')
putl 'INCM SCW_7078' o=$fname(sc_path//'.$EOI')



detf $fname(sc_path) status=ignore
detf $fname(wv_path) status=ignore


PROCEND make_qcu_phase_9
*DECK DECK=QCM$MANAGE_FIELD_CHANGES EXPAND=TRUE




?? RIGHT := 110 ??
?? NEWTITLE := 'MANAGE_FIELD_CHANGES: MANFC Utility Command.' ??
MODULE qcm$manage_field_changes;

{ PURPOSE:
{   This module contains the command interface to set up and control the
{   qcu field installation process.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc qct$installation_defaults
?? POP ??
*copyc clp$begin_utility
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc fst$file_reference

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    qcv$manfc_utility_name: [XDCL] clt$utility_name := 'MANAGE_FIELD_CHANGES';


?? FMT (FORMAT := ON) ??

?? TITLE := '[XDCL] qcp$manage_field_changes', EJECT ??

{ PURPOSE:
{   This command interface sets up the MANAGE_FIELD_CHANGES utility
{   session.
{
{ DESIGN:
{   This follows standard utility design.
{
{ NOTES:
{

  PROCEDURE [XDCL] qcp$manage_field_changes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);



{
{  PROCEDURE manfc_pdt (
{    status)

?? 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,
      recend,
    recend := [
    [1,
    [89, 2, 17, 9, 46, 41, 854],
    clc$command, 1, 1, 0, 0, 0, 0, 1, ''], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


{ table n=manfc_command_table t=command s=xdcl
{ command n=(qcp$establish_backup_catalog) p=qcp$establish_backup_catalog  ..
{        cm=proc a=hidden
{ command n=(display_correction, disc) p=qcp$display_correction cm=proc
{ command n=(display_scoreboard, dissb) p=qcp$display_scoreboard cm=proc
{ command n=(establish_bases) p=qcp$establish_bases a=hidden cm=proc
{ command n=(establish_qcu_environment) p=qcp$establish_qcu_environment    ..
{     cm=proc a=hidden
{ command n=(install_field_correction, insfc) p=qcp$install_correction     ..
{    cm=proc
{ command n=(withdraw_field_correction, witfc) p=qcp$withdraw_correction   ..
{      cm=proc
{ command n=(apply_correction) p=qcp$apply_correction a=hidden cm=xref
{ command n=(quit, qui) p=qcp$quit_manfc cm=xref
{ command n=(generate_correction_system, gencs)      ..
{   p=qcp$generate_qcu_deadstart_cat cm=proc
{ command n=(establish_correction_system, estcs) p=qcp$establish_qcu cm=proc
{ command n=(establish_deadstart_catalog)      ..
{   p=qcp$establish_deadstart_catalog a=hidden cm=proc
{ command n=(withdraw_deadstart_catalog) p=qcp$withdraw_deadstart_catalog  ..
{       a=hidden cm=proc
{ command n=(commit_correction_system, comcs) p=qcp$commit_system cm=proc
{ command n=(commit_base_system, combs) p=qcp$commit_base_system cm=proc   ..
{       a=hidden
{ command n=(generate_deadstart_tape, gendt) p=qcp$make_correction_ds_tape ..
{        cm=proc
{ command n=(withdraw_correction_system, witcs) p=qcp$withdraw_system cm=proc
{ command n=(build_score_header) p=qcp$build_score_header a=hidden cm=proc
{ command n=(modify_version) p=qcp$modify_version a=hidden cm=proc
{ command n=(get_correction_level) p=qcp$get_correction_level a=hidden     ..
{    cm=proc
{ command n=(copy_configuration) p=qcp$copy_configuration a=hidden cm=proc
{ command n=(link_generated_qcu) p=qcp$link_generated_qcu a=hidden cm=proc
{ command n=(combine_drivers) p=qcp$combine_drivers a=hidden cm=proc
{ command n=(list_catalog) p=qcp$list_catalog a=hidden cm=proc
{ command n=(move_ds_catalog) p=qcp$move_ds_catalog a=hidden cm=proc
{ command n=(get_block_and_record_type) p=get_block_and_record_type      ..
{   a=hidden cm=proc
{ command n=(qcp$back_ds_catalog) p=qcp$back_ds_catalog a=hidden cm=proc
{ command n=(reset_environment, rese) p=qcp$reset_environment cm=proc
{ command n=(search_link_map) p=search_link_map a=hidden cm=program
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  manfc_command_table: [XDCL, READ] ^clt$command_table :=
      ^manfc_command_table_entries,

  manfc_command_table_entries: [STATIC, READ] array [1 .. 41] of
      clt$command_table_entry := [
  {} ['APPLY_CORRECTION               ', clc$nominal_entry,
        clc$hidden_entry, 8, clc$automatically_log, clc$linked_call,
        ^qcp$apply_correction],
  {} ['BUILD_SCORE_HEADER             ', clc$nominal_entry,
        clc$hidden_entry, 18, clc$automatically_log, clc$program_call,
        'QCP$BUILD_SCORE_HEADER'],
  {} ['COMBINE_DRIVERS                ', clc$nominal_entry,
        clc$hidden_entry, 23, clc$automatically_log, clc$program_call,
        'QCP$COMBINE_DRIVERS'],
  {} ['COMBS                          ', clc$abbreviation_entry,
        clc$hidden_entry, 15, clc$automatically_log, clc$program_call,
        'QCP$COMMIT_BASE_SYSTEM'],
  {} ['COMCS                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 14, clc$automatically_log, clc$program_call,
        'QCP$COMMIT_SYSTEM'],
  {} ['COMMIT_BASE_SYSTEM             ', clc$nominal_entry,
        clc$hidden_entry, 15, clc$automatically_log, clc$program_call,
        'QCP$COMMIT_BASE_SYSTEM'],
  {} ['COMMIT_CORRECTION_SYSTEM       ', clc$nominal_entry,
        clc$normal_usage_entry, 14, clc$automatically_log, clc$program_call,
        'QCP$COMMIT_SYSTEM'],
  {} ['COPY_CONFIGURATION             ', clc$nominal_entry,
        clc$hidden_entry, 21, clc$automatically_log, clc$program_call,
        'QCP$COPY_CONFIGURATION'],
  {} ['DISC                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$program_call,
        'QCP$DISPLAY_CORRECTION'],
  {} ['DISPLAY_CORRECTION             ', clc$nominal_entry,
        clc$normal_usage_entry, 2, clc$automatically_log, clc$program_call,
        'QCP$DISPLAY_CORRECTION'],
  {} ['DISPLAY_SCOREBOARD             ', clc$nominal_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$program_call,
        'QCP$DISPLAY_SCOREBOARD'],
  {} ['DISSB                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 3, clc$automatically_log, clc$program_call,
        'QCP$DISPLAY_SCOREBOARD'],
  {} ['ESTABLISH_BASES                ', clc$nominal_entry,
        clc$hidden_entry, 4, clc$automatically_log, clc$program_call,
        'QCP$ESTABLISH_BASES'],
  {} ['ESTABLISH_CORRECTION_SYSTEM    ', clc$nominal_entry,
        clc$normal_usage_entry, 11, clc$automatically_log, clc$program_call,
        'QCP$ESTABLISH_QCU'],
  {} ['ESTABLISH_DEADSTART_CATALOG    ', clc$nominal_entry,
        clc$hidden_entry, 12, clc$automatically_log, clc$program_call,
        'QCP$ESTABLISH_DEADSTART_CATALOG'],
  {} ['ESTABLISH_QCU_ENVIRONMENT      ', clc$nominal_entry,
        clc$hidden_entry, 5, clc$automatically_log, clc$program_call,
        'QCP$ESTABLISH_QCU_ENVIRONMENT'],
  {} ['ESTCS                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 11, clc$automatically_log, clc$program_call,
        'QCP$ESTABLISH_QCU'],
  {} ['GENCS                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 10, clc$automatically_log, clc$program_call,
        'QCP$GENERATE_QCU_DEADSTART_CAT'],
  {} ['GENDT                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 16, clc$automatically_log, clc$program_call,
        'QCP$MAKE_CORRECTION_DS_TAPE'],
  {} ['GENERATE_CORRECTION_SYSTEM     ', clc$nominal_entry,
        clc$normal_usage_entry, 10, clc$automatically_log, clc$program_call,
        'QCP$GENERATE_QCU_DEADSTART_CAT'],
  {} ['GENERATE_DEADSTART_TAPE        ', clc$nominal_entry,
        clc$normal_usage_entry, 16, clc$automatically_log, clc$program_call,
        'QCP$MAKE_CORRECTION_DS_TAPE'],
  {} ['GET_BLOCK_AND_RECORD_TYPE      ', clc$nominal_entry,
        clc$hidden_entry, 26, clc$automatically_log, clc$program_call,
        'GET_BLOCK_AND_RECORD_TYPE'],
  {} ['GET_CORRECTION_LEVEL           ', clc$nominal_entry,
        clc$hidden_entry, 20, clc$automatically_log, clc$program_call,
        'QCP$GET_CORRECTION_LEVEL'],
  {} ['INSFC                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 6, clc$automatically_log, clc$program_call,
        'QCP$INSTALL_CORRECTION'],
  {} ['INSTALL_FIELD_CORRECTION       ', clc$nominal_entry,
        clc$normal_usage_entry, 6, clc$automatically_log, clc$program_call,
        'QCP$INSTALL_CORRECTION'],
  {} ['LINK_GENERATED_QCU             ', clc$nominal_entry,
        clc$hidden_entry, 22, clc$automatically_log, clc$program_call,
        'QCP$LINK_GENERATED_QCU'],
  {} ['LIST_CATALOG                   ', clc$nominal_entry,
        clc$hidden_entry, 24, clc$automatically_log, clc$program_call,
        'QCP$LIST_CATALOG'],
  {} ['MODIFY_VERSION                 ', clc$nominal_entry,
        clc$hidden_entry, 19, clc$automatically_log, clc$program_call,
        'QCP$MODIFY_VERSION'],
  {} ['MOVE_DS_CATALOG                ', clc$nominal_entry,
        clc$hidden_entry, 25, clc$automatically_log, clc$program_call,
        'QCP$MOVE_DS_CATALOG'],
  {} ['QCP$BACK_DS_CATALOG            ', clc$nominal_entry,
        clc$hidden_entry, 27, clc$automatically_log, clc$program_call,
        'QCP$BACK_DS_CATALOG'],
  {} ['QCP$ESTABLISH_BACKUP_CATALOG   ', clc$nominal_entry,
        clc$hidden_entry, 1, clc$automatically_log, clc$program_call,
        'QCP$ESTABLISH_BACKUP_CATALOG'],
  {} ['QUI                            ', clc$abbreviation_entry,
        clc$normal_usage_entry, 9, clc$automatically_log, clc$linked_call,
        ^qcp$quit_manfc],
  {} ['QUIT                           ', clc$nominal_entry,
        clc$normal_usage_entry, 9, clc$automatically_log, clc$linked_call,
        ^qcp$quit_manfc],
  {} ['RESE                           ', clc$abbreviation_entry,
        clc$normal_usage_entry, 28, clc$automatically_log, clc$program_call,
        'QCP$RESET_ENVIRONMENT'],
  {} ['RESET_ENVIRONMENT              ', clc$nominal_entry,
        clc$normal_usage_entry, 28, clc$automatically_log, clc$program_call,
        'QCP$RESET_ENVIRONMENT'],
  {} ['SEARCH_LINK_MAP                ', clc$nominal_entry,
        clc$hidden_entry, 29, clc$automatically_log, clc$program_call,
        'SEARCH_LINK_MAP'],
  {} ['WITCS                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 17, clc$automatically_log, clc$program_call,
        'QCP$WITHDRAW_SYSTEM'],
  {} ['WITFC                          ', clc$abbreviation_entry,
        clc$normal_usage_entry, 7, clc$automatically_log, clc$program_call,
        'QCP$WITHDRAW_CORRECTION'],
  {} ['WITHDRAW_CORRECTION_SYSTEM     ', clc$nominal_entry,
        clc$normal_usage_entry, 17, clc$automatically_log, clc$program_call,
        'QCP$WITHDRAW_SYSTEM'],
  {} ['WITHDRAW_DEADSTART_CATALOG     ', clc$nominal_entry,
        clc$hidden_entry, 13, clc$automatically_log, clc$program_call,
        'QCP$WITHDRAW_DEADSTART_CATALOG'],
  {} ['WITHDRAW_FIELD_CORRECTION      ', clc$nominal_entry,
        clc$normal_usage_entry, 7, clc$automatically_log, clc$program_call,
        'QCP$WITHDRAW_CORRECTION']];

  PROCEDURE [XREF] qcp$apply_correction
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] qcp$quit_manfc
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??


?? PUSH (LISTEXT := ON) ??

VAR
  manfc_function_table: [XDCL, READ] ^clt$function_processor_table := ^manfc_function_table_entries,

  manfc_function_table_entries: [STATIC, READ] array [1 .. 1] of clt$function_proc_table_entry := [
  {} ['$INSTALL_DRIVER                ', clc$nominal_entry, clc$hidden_entry, 1, clc$linked_call,
        ^qcp$functions]];

  PROCEDURE [XREF] qcp$functions
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? POP ??

    CONST
      prompt_size = 5,
      prompt_value = 'MANFC';

    VAR
      utility_attributes_p: ^clt$utility_attributes;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH utility_attributes_p: [1 .. 4];
    utility_attributes_p^ [1].key := clc$utility_command_search_mode;
    utility_attributes_p^ [1].command_search_mode := clc$global_command_search;
    utility_attributes_p^ [2].key := clc$utility_command_table;
    utility_attributes_p^ [2].command_table := manfc_command_table;
    utility_attributes_p^ [3].key := clc$utility_function_proc_table;
    utility_attributes_p^ [3].function_processor_table := manfc_function_table;
    utility_attributes_p^ [4].key := clc$utility_prompt;
    utility_attributes_p^ [4].prompt.size := prompt_size;
    utility_attributes_p^ [4].prompt.value := prompt_value;

    clp$begin_utility (qcv$manfc_utility_name, utility_attributes_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, prompt_value, qcv$manfc_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (qcv$manfc_utility_name, status);

  PROCEND qcp$manage_field_changes;
MODEND qcm$manage_field_changes;



*DECK DECK=QCM$MANAGE_FIELD_CHANGES_PD EXPAND=TRUE

create_program_description (manage_field_changes, manfc) ..
 sp=qcp$manage_field_changes, ..
l=$system.software_maintenance.raf$library
*DECK DECK=QCM$MANAGE_PSR_STATISTICS EXPAND=TRUE


?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Operating System : manage psr statistics' ??
MODULE qcm$manage_psr_statistics;

*copyc osp$set_status_abnormal
*copyc osv$mainframe_wired_heap
*copyc qct$psr_statistics
*copyc ost$status

{ Global variable declarations

  VAR
    qcv$psrs_p: [XDCL, #GATE] ^qct$psr_statistics := NIL;



?? TITLE := 'qcp$initialize_psr_statistics', EJECT ??

  PROCEDURE [XDCL] qcp$initialize_psr_statistics;

    VAR
      item_count: qct$item_count,
      index: integer,
      psr_entry: ^qct$psr_statistics_entry;

{ This routine is called at deadstart time to initialize the psr statistics


    ALLOCATE qcv$psrs_p IN osv$mainframe_wired_heap^;

    qcv$psrs_p^.item_count := 1;

    FOR index := 1 TO qcc$max_psr_entries DO
      qcv$psrs_p^.psr_entries [index].psr_ident := qcc$null_psr;
    FOREND;


  PROCEND qcp$initialize_psr_statistics;




?? TITLE := 'qcp$update_psr_statistics', EJECT ??

  PROCEDURE [XDCL, #GATE] qcp$update_psr_statistics
    (    psr_identifier: qct$psr_ident;
     VAR status: ost$status);

    VAR
      item_count: qct$item_count,
      psr_entry: ^qct$psr_statistics_entry;

    status.normal := TRUE;
    item_count := qcv$psrs_p^.item_count;
    qcv$psrs_p^.psr_entries [item_count].psr_ident := psr_identifier;
    qcv$psrs_p^.item_count := qcv$psrs_p^.item_count + 1;

  PROCEND qcp$update_psr_statistics;


?? TITLE := 'qcp$fetch_psr_statistics', EJECT ??

  PROCEDURE [XDCL, #GATE] qcp$fetch_psr_statistics
    (VAR psr_statistics: qct$psr_statistics;
     VAR psr_count: qct$item_count;
     VAR status: ost$status);

    VAR
      item_count: qct$item_count,
      psr_entry: ^qct$psr_statistics_entry,
      i: qct$item_count;

    status.normal := TRUE;
    item_count := qcv$psrs_p^.item_count;

    FOR i := 1 TO item_count DO
     psr_statistics.psr_entries[i].psr_ident :=  qcv$psrs_p^.psr_entries [i].psr_ident;
     psr_statistics.psr_entries[i].feature_ident :=  qcv$psrs_p^.psr_entries [i].feature_ident;
     psr_count := psr_count + 1;
    FOREND

  PROCEND qcp$fetch_psr_statistics;

MODEND qcm$manage_psr_statistics;
*DECK DECK=QCM$MODIFY_VERSION EXPAND=TRUE

PROC qcp$modify_version (
 correction_ident, ci: name = $required
 qcu_ident, qi: string = $required
 system_ident si: string = $required
 status )



crev ignore k=status
crev count
crev work1 k=string
crev work k=string

crev qev$ccu k=boolean s=xref
crev qev$correction_base k=string s=xref
crev ov_path k=string v=qev$correction_base//'.'
     ov_path = ov_path//$string($value(correction_ident))
     ov_path = ov_path//'.LINK_INPUT_FILES.OS_VERSION'
crev temp1 k=string v=$unique

attf $fname(ov_path) op=$asis
accl work i=$fname(ov_path) lc=count


IF qev$ccu THEN
 WHILE $substr(work,7,5) <> 'build' AND count <> 0 DO
   putl work o=$fname(temp1//'.$eoi')
   accl work i=$fname(ov_path) lc=count
 WHILEND
 putl work o=$fname(temp1//'.$eoi')
 bn = $substr(work,27,6)
 accl work i=$fname(ov_path) lc=count
 WHILE $substr(work,7,7) <> 'version'  AND count <> 0 DO
   accl work i=$fname(ov_path) lc=count
 WHILEND
 work1 = $substr(work,1,34)
 work1 = work1//bn//$substr(work,40,2)//''''
  putl work1 o=$fname(temp1//'.$eoi')
  putl '      level_id = '//$value(system_ident) o=$fname(temp1//'.$eoi')
  rewf $fname(temp1) status=ignore
  detf $fname(ov_path) status=ignore
  delf $fname(ov_path) status=ignore
  copf $fname(temp1) $fname(ov_path)
  detf $fname(ov_path) status=ignore
  EXIT_PROC
ELSE
 WHILE $substr(work,7,7) <> 'version'  AND count <> 0 DO
 putl work o=$fname(temp1//'.$eoi')
 accl work i=$fname(ov_path) lc=count
 WHILEND

 work2 = $substr(work,1,21)
 work2 = work2//$substr(work,25,$strlen(work)-24)
 count = $scan_string($value(qcu_ident),work2)

IF count <> 0 THEN
 work1 = $substr(work2,1,count)
 work1 = work1//$string($value(system_ident))
 work1 = work1//$substr(work,count+10,6)
 putl work1 o=$fname(temp1//'.$eoi')


putl '      level_id = '//$value(system_ident) o=$fname(temp1//'.$eoi')
rewf $fname(temp1) status=ignore
delf $fname(ov_path) status=ignore
copf $fname(temp1) $fname(ov_path)
IFEND

detf $fname(ov_path) status=ignore
IFEND

PROCEND qcp$modify_version

*DECK DECK=QCM$MOVE_DS_CATALOG EXPAND=TRUE
PROCEDURE qcp$move_ds_catalog (
  status)



  VAR
    id_path: file = $SYSTEM.qcu_maintenance.identification
    deadstart_catalog: string
    level: string
  VAREND
    $system.accept_line v=level i=id_path
    deadstart_catalog = '$SYSTEM.qcu_maintenance.'//level//'.deadstart_catalog'


*copyc dst$deadstart_record_lists


  VAR
    catalog_files_list: list 0 .. $max_list OF name
    catalog_path: string
    command_status: status
    current_file : name
    file_name: string
    files_list: list 0 .. $max_list OF file
    files_name_list: list 0 .. $max_list OF name
    index: integer
    local_status: status
    main_path: string
    previous_catalog_path: string
  VAREND

  main_path = $string(deadstart_catalog)
  files_list = ()
  files_name_list = ()

  "  Use the standard required files list to determine if all of the required files exist in the
  "  deadstart catalog.

  create_files_list: FOR index = 1 TO deadstart_file_count DO
    IF deadstart_file_list(index).site_catalog = 'CIP' THEN
      CYCLE create_files_list
    IFEND

    "  Ensure that the required file exists.  If so, add it to the deadstart files list.

    IF deadstart_file_list(index).site_catalog = ' ' THEN
      catalog_path = main_path
    ELSE
      catalog_path = main_path//'.'//deadstart_file_list(index).site_catalog
    IFEND

    file_name = catalog_path//'.'//deadstart_file_list(index).tape_name
    IF (NOT $file($fname(file_name), permanent)) AND deadstart_file_list(index).site_required THEN
      local_status = $status(FALSE, 'DS', dse$required_file_missing, file_name)
      EXIT PROCEDURE WITH local_status
    IFEND

    IF deadstart_file_list(index).tape_name <> 'PRODUCT_EPILOG' THEN

      "  Add the file to the files list and the files name list.

      IF $file($fname(file_name), permanent) THEN
        files_list = $add($fname(file_name), files_list)
        files_name_list = $add($name(deadstart_file_list(index).tape_name), files_name_list)
      IFEND
      previous_catalog_path = catalog_path

    ELSE

      "  Before adding the product epilog file, process any other files that may exist in the product files
      "  catalog.  Determine if there are any by getting the catalog contents and subtracting the file names
      "  that have already been processed.

      catalog_files_list = $catalog_contents($fname(previous_catalog_path), include_files)
      catalog_files_list = $difference(catalog_files_list, files_name_list)
      WHILE NOT $nil(catalog_files_list) DO
        current_file = $first(catalog_files_list)
        catalog_files_list = $rest(catalog_files_list)

        "  Ensure that the file name is less than 18 characters in length and add it to the files list.

        IF $file($fname(previous_catalog_path//'.'//$string(current_file)), opened) THEN
          IF $strlen($string(current_file)) < 18 THEN
            files_list = $add($fname(previous_catalog_path//'.'//$string(current_file)), files_list)
          ELSE
            local_status = $status(FALSE, 'DS', dse$file_name_too_long, previous_catalog_path//'.'//$string(current_file))
            EXIT PROCEDURE WITH local_status
          IFEND
        IFEND
      WHILEND

      "  Add the product epilog file to the files list.

      files_list = $add($fname(file_name), files_list)
    IFEND
  FOREND create_files_list

  "  Since elements are added to lists at the beginning, the deadstart files list must be be reversed to make
  "  it in the correct order.

  files_list = $reverse(files_list)


  include_command c='install_deadstart_file df=files_list status=local_status' status=command_status

  IF local_status.normal THEN
    put_line ' ' o=$response
    put_line l='       **  New system established  **'  o=$response
    put_line ' ' o=$response
  ELSE
    put_line l='     Failure attempting to establish correction system. ' o=$response
    put_line ' ' o=$response
  IFEND
    putl ' MANFC/' o=$response
  EXIT PROCEDURE WITH local_status WHEN NOT local_status.normal

PROCEND qcp$move_ds_catalog
*DECK DECK=QCM$OPEN_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'MANFC Utility: Module QCM$OPEN_FILE.' ??
MODULE qcm$open_file;

{ PURPOSE:
{   This module contains a procedures to open a file.
{
{ DESIGN:
{   The FILE is opened with the file attachment option and
{   create file definitions provided in the procedure parameters.
{
{ NOTES:
{   This procedure should be called from within a block structure
{   which has a condition handler.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*copyc fsp$open_file

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := 'qcp$open_segment_file [XDCL]', EJECT ??

{ PURPOSE:
{   This procedure opens a file.
{
{ DESIGN:
{   The FILE is opened with the attachment_option and
{        defined in the procedure parameters.
{
{ NOTES:
{   This procedure should be called from within a block structure
{   which has a condition handler.

  PROCEDURE [XDCL] qcp$open_file
    (    path_ref_p: ^fst$file_reference;
         access_level: amt$access_level;
         file_attachment: fst$file_access_option;
         create_file: boolean;
         attribute_override_p: ^array [1 .. 1] of fst$file_cycle_attribute;
     VAR file_id: amt$file_identifier;
     VAR file_opened: boolean;
     VAR status: ost$status);


    VAR
      attachment_option: array [1 .. 2] of fst$attachment_option;


    status.normal := TRUE;
    file_opened := FALSE;

    attachment_option [1].selector := fsc$access_and_share_modes;
    attachment_option [1].access_modes.selector := fsc$specific_access_modes;

    IF file_attachment = fsc$read THEN

      attachment_option [1].access_modes.value := $fst$file_access_options [fsc$read];
      attachment_option [2].create_file := FALSE;

    ELSEIF file_attachment = fsc$modify THEN

      attachment_option [1].access_modes.value := $fst$file_access_options
            [fsc$read, fsc$shorten, fsc$append, fsc$modify];
      IF create_file = TRUE THEN
        attachment_option [2].create_file := TRUE;
      ELSE
        attachment_option [2].create_file := FALSE;
      IFEND;

    IFEND;

    attachment_option [1].share_modes.selector := fsc$determine_from_access_modes;
    attachment_option [2].selector := fsc$create_file;

    file_opened := TRUE;
    fsp$open_file (path_ref_p^, access_level, ^attachment_option, NIL, NIL, NIL, attribute_override_p,
          file_id, status);
    IF NOT status.normal THEN
      file_opened := FALSE;
      RETURN;
    IFEND;

  PROCEND qcp$open_file;

MODEND qcm$open_file;

*DECK DECK=QCM$QCU_PRODUCT_TABLE EXPAND=TRUE

create_variable name=product_table_input kind=string value=$unique
collect_text output=$fname(product_table_input) until='///end product table///' substitution_mark='?'
*copyc qci$qcu_nosve_maintenance
///end product table///

include_file file=$fname(product_table_input)
delete_file file=$fname(product_table_input)
*DECK DECK=QCM$QUIT_FILRU EXPAND=TRUE


?? RIGHT := 110 ??
?? NEWTITLE := 'FILE REPAIR Utility: QUIT Subcommand.' ??
MODULE qcm$quit_filru;

{ PURPOSE:
{   This module contains the command interface to end an FILRU
{   utility session.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc clp$end_include
*copyc clp$evaluate_parameters
*copyc qcv$filru_utility_name

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] qcp$quit_filru;', EJECT ??

{ PURPOSE:
{   This command interface exits an FILRU utility session.
{
{ DESIGN:
{   The utility termination follows standard utility design.
{
{ NOTES:
{

  PROCEDURE [XDCL] qcp$quit_filru
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE qui_pdt (
{   status)


    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,
        recend,
      recend := [[1, [88, 5, 3, 7, 43, 49, 918], clc$command, 1, 1, 0, 0, 0, 0, 1, 'QUI_PDT'],
            [['STATUS                         ', clc$nominal_entry, 1]], [
{ PARAMETER 1
      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$status_type]]];


    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_include (qcv$filru_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND qcp$quit_filru;
MODEND qcm$quit_filru;
*DECK DECK=QCM$QUIT_MANFC EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'MANAGE_FIELD_CHANGES Utility: QUIT Subcommand.' ??
MODULE qcm$quit_manfc;

{ PURPOSE:
{   This module contains the command interface to end an MANFC
{   utility session.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc clp$end_include
*copyc clp$evaluate_parameters
*copyc qcv$manfc_utility_name

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] qcp$quit_manfc;', EJECT ??

{ PURPOSE:
{   This command interface exits an MANFC utility session.
{
{ DESIGN:
{   The utility termination follows standard utility design.
{
{ NOTES:
{

  PROCEDURE [XDCL] qcp$quit_manfc
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE qui_pdt (
{   status)


    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,
        recend,
      recend := [[1, [88, 5, 3, 7, 43, 49, 918], clc$command, 1, 1, 0, 0, 0, 0, 1, 'QUI_PDT'],
            [['STATUS                         ', clc$nominal_entry, 1]], [
{ PARAMETER 1
      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$status_type]]];


    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_include (qcv$manfc_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND qcp$quit_manfc;
MODEND qcm$quit_manfc;
*DECK DECK=QCM$RESET_ENVIRONMENT EXPAND=TRUE

PROC qcp$reset_environment

crev ignore k=status
crev fm_path k=string v=':$SYSTEM.$SYSTEM.FIELD_MAINTENANCE'
crev qc_path k=string v=':$SYSTEM.$SYSTEM.QCU_MAINTENANCE'

delete_catalog $fname(fm_path) cac  status = ignore
delete_catalog $fname(qc_path) cac status = ignore


PROCEND qcp$reset_environment
*DECK DECK=QCM$SHOW_ERRORS EXPAND=TRUE


PROC qcm$show_errors, show_errors (
  link_map_type, lmt: key boot os ei = os
  display_options, do: key errors e full f = errors
  product_name, pn: name = os
  build_level, bl: name
  feature_catalog, fc: file or key none = none
  feature_build_level, fbl: name = object
  working_catalog, wc: file or key none = none
  working_build_level, wbl: name = object
  status)



IF NOT $variable(wev$default_file_server defined) THEN
  VAR
    wev$default_file_server : (ENVIRONMENT) string
  VAREND
  check_default_file_server
IFEND
IF NOT $variable(wev$default_dev_base_family defined) THEN
  VAR
    wev$default_dev_base_family : (ENVIRONMENT) string
  VAREND
  set_environment_defaults
IFEND
VAR
  development_base : file = wev$development_base, $fname(wev$default_dev_base_family//'.INTVE')
  wev$development_base : (ENVIRONMENT) string = $string(development_base)
  server_development_base : file = wev$server_development_base, $fname($string(wev$default_file_server)//..
$trim($substr(wev$development_base, $scan_string('.', wev$development_base), $strlen(wev$development_base))))
  wev$server_development_base : (ENVIRONMENT) string = $string(server_development_base)
VAREND
IF $specified(product_name) THEN
  create_variable wev$product_name kind=string scope=xdcl ..
    value=$string($value(product_name))
ELSEIF $variable(wev$product_name,declared) = 'NONLOCAL' THEN
  create_variable wev$product_name kind=string scope=xref
ELSE
  create_variable wev$product_name kind=string scope=xdcl ..
    value=$string($value(product_name))
IFEND

IF $specified(build_level) THEN
  create_variable wev$build_level kind=string scope=xdcl ..
    value=$string($value(build_level))
ELSEIF $variable(wev$build_level,declared) = 'NONLOCAL' THEN
  create_variable wev$build_level kind=string scope=xref
ELSE
  create_variable wev$build_level kind=string scope=xdcl value='NONE'
IFEND

IF $specified(working_catalog) THEN
  create_variable wev$working_catalog kind=string scope=xdcl ..
    value=$string($value(working_catalog))
ELSEIF $variable(wev$working_catalog,declared) = 'NONLOCAL' THEN
  create_variable wev$working_catalog kind=string scope=xref
ELSE
  create_variable wev$working_catalog kind=string scope=xdcl ..
    value=$string($value(working_catalog))
IFEND

IF $specified(feature_catalog) THEN
  create_variable wev$feature_catalog kind=string scope=xdcl ..
    value=$string($value(feature_catalog))
ELSEIF $variable(wev$feature_catalog,declared) = 'NONLOCAL' THEN
  create_variable wev$feature_catalog kind=string scope=xref
ELSE
  create_variable wev$feature_catalog kind=string scope=xdcl ..
    value=$string($value(feature_catalog))
IFEND

IF $specified(working_build_level) THEN
  create_variable wev$working_build_level kind=string scope=xdcl ..
    value=$string($value(working_build_level))
ELSEIF $variable(wev$working_build_level,declared) = 'NONLOCAL' THEN
  create_variable wev$working_build_level kind=string scope=xref
ELSE
  create_variable wev$working_build_level kind=string scope=xdcl ..
    value=$string($value(working_build_level))
IFEND

IF $specified(feature_build_level) THEN
  create_variable wev$feature_build_level kind=string scope=xdcl ..
    value=$string($value(feature_build_level))
ELSEIF $variable(wev$feature_build_level,declared) = 'NONLOCAL' THEN
  create_variable wev$feature_build_level kind=string scope=xref
ELSE
  create_variable wev$feature_build_level kind=string scope=xdcl ..
    value=$string($value(feature_build_level))
IFEND


  create_variable (local_status, display_status, ignore_status) kind=status
  create_variable partial_errors kind=(string $max_name) value=$unique
  create_variable complete_errors kind=(string $max_name) value=$unique
  create_variable link_map_path kind=string


disle_proc: ..
  BLOCK

    IF $string($value(link_map_type)) = 'OS' THEN
      create_variable number_of_link_maps value=2
      create_variable link_map_name kind=string dimension=1..number_of_link_maps
      link_map_name(1) = 'SYSTEM_CORE_LINK_MAP'
      link_map_name(2) = 'JOB_TEMPLATE_LINK_MAP'
    ELSEIF $string($value(link_map_type)) = 'BOOT' THEN
      create_variable number_of_link_maps value=1
      create_variable link_map_name kind=string dimension=1..number_of_link_maps
      link_map_name(1) = 'BOOT_LINK_MAP'
    ELSE
      create_variable number_of_link_maps value=1
      create_variable link_map_name kind=string dimension=1..number_of_link_maps
      link_map_name(1) = 'C170_EI_LINK_MAP'
    IFEND

    search_catalog_limit = wev$server_development_base // '.' // wev$product_name // '.' // wev$build_level

    FOR i = 1 TO number_of_link_maps DO

    locate_map: ..
      BLOCK
      limit_search: ..
        BLOCK

          IF wev$working_catalog <> 'NONE' THEN
            catalog = wev$working_catalog // '.' // wev$working_build_level
            include_line 'display_catalog '//catalog//' do=p o=$null' status=display_status
            IF display_status.normal THEN
              link_map_path = catalog // '.' // link_map_name(i)
              EXIT locate_map WHEN ..
                    ($file($fname(link_map_path), assigned) AND $file($fname(link_map_path), size) > 0)
              EXIT limit_search WHEN $path($fname(link_map_path), catalog) = search_catalog_limit
              detach_file file=$fname(link_map_path) status=ignore_status
            IFEND
          IFEND

          IF wev$feature_catalog <> 'NONE' THEN
            catalog = wev$feature_catalog // '.' // wev$feature_build_level
            include_line 'display_catalog '//catalog//' o=$null' status=display_status
            IF display_status.normal THEN
              link_map_path = catalog // '.' // link_map_name(i)
              EXIT locate_map WHEN ..
                    ($file($fname(link_map_path), assigned) AND $file($fname(link_map_path), size) > 0)
              EXIT limit_search WHEN $path($fname(link_map_path), catalog) = search_catalog_limit
              detach_file file=$fname(link_map_path) status=ignore_status
            IFEND
          IFEND

          catalog = wev$server_development_base // '.' // wev$product_name // '.' // wev$build_level
          include_line 'display_catalog '//catalog//' o=$null' status=display_status
          EXIT limit_search WHEN NOT local_status.normal
          link_map_path = catalog // '.' // link_map_name(i)
          EXIT locate_map WHEN ..
                ($file($fname(link_map_path), assigned) AND $file($fname(link_map_path), size) > 0)

          detach_file file=$fname(link_map_path) status=ignore_status
        BLOCKEND limit_search
        put_line ' Link map '//link_map_name(i)//' not found -- DISPLAY_LINKER_ERRORS exiting.' o=output ..
              status=ignore_status
        EXIT disle_proc
      BLOCKEND locate_map


      search_link_map link_map=$fname(link_map_path) output=$fname(partial_errors) status=local_status
      EXIT disle_proc WHEN NOT local_status.normal

      IF $file($fname(partial_errors), size) <> 0 THEN
        put_line lines=' Linker errors found in '//link_map_path output=$fname(complete_errors//'.$eoi')
        copy_file input=$fname(partial_errors) output=$fname(complete_errors//'.$eoi')
        detach_file file=$fname(partial_errors) status=ignore_status
      IFEND

      search_catalog_limit = $path($fname(link_map_path), catalog)
    FOREND


    IF $file($fname(complete_errors), size) <> 0 THEN
      put_line ' WARNING-  Errors found while searching link maps.' o=$output status=ignore_status
      copy_file input=$fname(complete_errors) output=$errors
      detach_file file=$local.linker_errors status=ignore_status
      copy_file input=$fname(complete_errors) output=$local.linker_errors
      detach_file file=$fname(complete_errors) status=ignore_status
      put_line ' See file $local.linker_errors for a listing of the errors.' o=$output status=ignore_status
      local_status = $status(false, 'WE', wee$linker_errors)


    ELSEIF ..
          (($string($value(do)) = 'ERRORS') OR ($string($value(do)) = 'E') AND wev$working_catalog <> 'NONE')..
           THEN
      put_line '       No Errors.' o=$output status=ignore_status
      FOR i = 1 TO number_of_link_maps DO
        delete_file file=$fname(wev$working_catalog//'.'//wev$working_build_level//'.'//link_map_name(i)) ..
              status=ignore_status
      FOREND
    IFEND
  BLOCKEND disle_proc

  detach_file file=$fname(partial_errors) status=ignore_status
  detach_file file=$fname(complete_errors) status=ignore_status
  detach_file file=$fname(link_map_path) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND qcm$show_errors
*DECK DECK=QCM$VALIDATE_QCU EXPAND=TRUE
PROC qcm$validate_qcu (
qcu_ident, qi: name
status )

crev work k=string
crev count v=0
crev ignore k=status

crev qi k=string v=$string($value(qcu_ident))
crev path k=string v=':CSERV.CSERV.QCU'
crev temp k=string v=$unique
crev valid k=boolean v=FALSE


$value(status.normal) = TRUE
disc $fname(path) o=$fname(temp)
rewf $fname(temp) status=ignore

accl v=work i=$fname(temp) lc=count

WHILE count > 0 DO
  IF  $substr(work,2,8) = 'CATALOG:' THEN
    IF $substr(work,10,4) = $substr(qi,1,4) THEN
      " This is a valid QCU level
      valid = TRUE
    IFEND
  IFEND
 accl v=work i=$fname(temp) lc=count
WHILEND

delf $fname(path) status=ignore
delf $fname(temp) status=ignore


   IF NOT valid THEN
     $value(status.normal) = FALSE
   IFEND

PROCEND qcm$validate_qcu
*DECK DECK=QCM$VALIDATE_QCU_BASE EXPAND=TRUE

PROC qcm$validate_qcu_base, validate_qcu_base, valqcb (
qcu_ident, qi: name = $required
valid: VAR of boolean
status )

crev work k=string
crev count v=0
crev ignore k=status

crev qi k=string v=$string($value(qcu_ident))
crev path k=string v=':CSERV.CSERV.QCU'
crev temp k=string v=$unique//'.$asis'


$value(valid) = FALSE
disc $fname(path) o=$fname(temp)
rewf $fname(temp) status=ignore

accl v=work i=$fname(temp) lc=count

WHILE count > 0 DO
  IF  $substr(work,2,8) = 'CATALOG:' THEN
    IF $substr(work,11,4) = $substr(qi,1,4) THEN
      " This is a valid QCU level
      $value(valid) = TRUE
    IFEND
  IFEND
 accl v=work i=$fname(temp) lc=count
WHILEND

delf $fname(path) status=ignore
delf $fname(temp) status=ignore



PROCEND qcm$validate_qcu_base

*DECK DECK=QCM$WITHDRAW_CORRECTION EXPAND=TRUE

PROC qcp$withdraw_correction (
correction_identifier, ci: name 1 .. 7 = $required
output, o: file = $output
status )

crev ignore k=status
crev work k=string
crev count v=1
crev history k=boolean
crev last_base k=string
crev local_status k=status



IF $file($value(output) open_position) = '$BOI' THEN
   ofile = $string($value(output)) //'.$ASIS'
ELSE
   ofile = $string($value(output))
IFEND

crev qev$correction_base k=string s=xdcl
crev qev$installation_base k=string s=xdcl
crev qev$modifier_base k=string s=xdcl
crev qev$correction_identifier k=string s=xdcl



"**************************************************************************
" Setup default values
"**************************************************************************
qev$correction_base   =   ':$SYSTEM.$SYSTEM.FIELD_MAINTENANCE'
qev$target_base       =   ':$SYSTEM.$SYSTEM.QCU_MAINTENANCE'
qev$modifier_base     =   ':$SYSTEM.$SYSTEM.NOSVE_MAINTENANCE'
qev$correction        =   $string($value(correction_identifier))


crev tb_path k=string v=qev$target_base
crev tc_path k=string v=qev$target_base//'.LINK_INPUT_FILES'
crev cc_path k=string v=qev$correction_base//'.'//qev$correction
     cc_path = cc_path//'.LINK_INPUT_FILES'
crev mc_path k=string v=qev$modifier_base//'.LINK_INPUT_FILES'
crev bo_path k=string v=qev$correction_base
crev hi_path k=string v=qev$correction_base//'.HISTORY.$ASIS'
crev lb_path k=string v=qev$correction_base//'.LIBRARIES'
crev na_path k=string v=qev$correction_base//'.'//qev$correction//'.NAMES'
crev nh_path k=string v=$unique
crev id_path k=string v=qev$target_base//'.IDENTIFICATION'
crev ll_path k=string v=qev$correction_base//'.PATHS'
crev cp_path k=string v=qev$correction_base//'.LINK_INPUT_FILES'


crev temp1 k=string v=$unique//'.$asis'
crev temp2 k=string v=$unique//'.$asis'
crev temp3 k=string v=$unique

crev here k=boolean v=FALSE

crev ci k=string v=$string($value(correction_identifier))
crev available k=boolean v=FALSE

IF NOT $file($fname(cc_path),catalog) THEN
   putl ' ' o=$fname(ofile)
   putl '                    WARNING' o=$fname(ofile)
   putl '     The correction identifier specified does not describe' o=$fname(ofile//'.$eoi')
   putl '     a correction currently installed. Please review your' o=$fname(ofile//'.$eoi')
   putl '     request.' o=$fname(ofile//'.$eoi')
   putl ' '  o=$fname(ofile//'.$eoi')
   putl ' ' o=$fname(ofile//'.$eoi')
   EXIT_PROC
IFEND


IF NOT $file($fname(qev$modifier_base),catalog) THEN
 putl '                        WARNING' o=$fname(ofile//'.$eoi')
 putl '      Unable to generate a correction system due to absence' o=$fname(ofile//'.$eoi')
 putl '      of the '//qev$modifier_base//' catalog' o=$fname(ofile//'.$eoi')
 EXIT_PROC
IFEND

delc $fname(tb_path) do=cac status=ignore
crec $fname(tb_path) status=ignore
crec $fname(tc_path) status = ignore
detf $fname(hi_path) status=ignore

   crev system_base k=string
   crev previous k=string
   crev work1 k=string
   crev last k=string
   crev next_base k=string
   crev entries
IF $file($fname(hi_path),permanent) THEN
   attf $fname(hi_path) op=$asis
   accl work i=$fname(hi_path) lc=count
       last = $substr(work,43,6)
       system_base = $substr(work,43,6)
       next_base = $substr(work,43,6)
       previous = $substr(work,14,7)
    WHILE count > 0 DO
             last_base = $substr(work,14,7)
       IF $substr(work,3,7) = ci THEN
         next_base = last
         last_base = previous
         available = TRUE
       ELSE
         previous = $substr(work,14,7)
         last = $substr(work,3,7)
         work1 = $substr(work,1,25)
         work1 = work1//$substr(next_base,1,7)
         work1 = work1//$substr(work,33,47)
         putl work1 o=$fname(nh_path//'.$eoi')
         entries = entries + 1
       IFEND
     accl work i=$fname(hi_path) lc=count
    WHILEND

" If we are backing out a correction which is the first in the list
" and there are following corrections, use the identifier of the
" last one in the list.

      IF next_base = system_base THEN
         next_base = last
      IFEND
" save the identifier for later use
putl last_base o=$fname(id_path)


      IF entries = 0 THEN
         put_line '-'  o=$fname(ofile//'.$eoi')
         put_line '                      ADVISE'  o=$fname(ofile//'.$eoi')
         put_line '      Withdrawal of correction '//$strrep(ci)//' forces' o=$fname(ofile//'.$eoi')
         put_line '      the system back to the installed base level.'      o=$fname(ofile//'.$eoi')
         put_line ' '                                                       o=$fname(ofile//'.$eoi')
         put_line '      To properly reestablish the base system the  '     o=$fname(ofile//'.$eoi')
         put_line '      command WITHDRAW_CORRECTION_SYSTEM should be'      o=$fname(ofile//'.$eoi')
         put_line '      entered. This will install the last base system'   o=$fname(ofile//'.$eoi')
         put_line '      to the deadstart device. A subsequent deadstart'   o=$fname(ofile//'.$eoi')
         put_line '      will activate the base system.'                    o=$fname(ofile//'.$eoi')
         put_line ' '                                                       o=$fname(ofile//'.$eoi')
         put_line '      Another option is to install a new correction and' o=$fname(ofile//'.$eoi')
         put_line '      generate a new correction system.'                 o=$fname(ofile//'.$eoi')
         put_line ' '                                                       o=$fname(ofile//'.$eoi')
       delc $fname(tb_path) do=cac status=ignore
       EXIT_PROC
    IFEND


     rewf $fname(nh_path) status=ignore
     delf $fname(hi_path) status=ignore
     copf $fname(nh_path) $fname(hi_path)
     detf $fname(hi_path) status=ignore

   crev libs k=string d=1..10 v=''
   crev c1 v=1
   attf $fname(na_path) op=$asis
   accl work i=$fname(na_path) lc=count

    WHILE count > 0 DO
      libs(c1) = work
      c1 = c1 + 1
      accl work i=$fname(na_path) lc=count
    WHILEND

     attf $fname(lb_path) op=$asis
     accl work i=$fname(lb_path) lc=count

    WHILE count > 0 DO
        FOR i = 1 TO c1 DO
          IF libs(i) = work THEN
             here = TRUE
             libs(i) = ''
          IFEND
        FOREND
          IF NOT here THEN
           putl work o=$fname(temp3//'.$eoi')
          IFEND
          here = FALSE
         accl work i=$fname(lb_path) lc=count
     WHILEND

         rewf $fname(temp3) status=ignore
         detf $fname(lb_path) status=ignore
         delf $fname(lb_path) status=ignore
         copf $fname(temp3) $fname(lb_path)

ELSE
   putl ' '         o=$fname(ofile//'.$eoi')
   putl '                     WARNING' o=$fname(ofile//'.$eoi')
   putl '     There is no record of any modifications having been made' o=$fname(ofile//'.$eoi')
   putl '     to the current system. Please review your request.'      o=$fname(ofile//'.$eoi')
   putl ' '                                                o=$fname(ofile//'.$eoi')
   EXIT_PROC
IFEND

  IF NOT available THEN
   putl ' ' o=$fname(ofile//'.$eoi')
   putl '                     WARNING' o=$fname(ofile//'.$eoi')
   putl '     The correction identifier specified does not describe' o=$fname(ofile//'.$eoi')
   putl '     a correction currently installed. Please review your'  o=$fname(ofile//'.$eoi')
   putl '     request.'                                              o=$fname(ofile//'.$eoi')
   putl ' '                                                          o=$fname(ofile//'.$eoi')
  EXIT_PROC
  IFEND


putl ' '                                       o=$fname(ofile//'.$eoi')
putl '    Backing out Correction Level '//$strrep(ci)  o=$fname(ofile//'.$eoi')
putl ' '                                               o=$fname(ofile//'.$eoi')
putl '    Basing new Correction System on Level '//last_base  o=$fname(ofile//'.$eoi')
putl ' '                                                      o=$fname(ofile//'.$eoi')



" Modify correction base to reflect removal of named correction
" by deleting the associated libraries from the link files.

   crev temp5 k=string v=$unique
   crev dl_path k=string
   detf $fname(ll_path) status=ignore
   attf $fname(ll_path) op=$asis
    accl work i=$fname(ll_path) lc=count
     WHILE count > 0 DO
      IF $substr(work,31,7) = ci THEN
       dl_path = cp_path//'.'//$substr(work,1,28)
        delf $fname(dl_path)
      ELSE
       putl work o=$fname(temp5//'.$eoi')
      IFEND
       accl work i=$fname(ll_path) lc=count
     WHILEND
    rewf $fname(temp5)   status=ignore
    delf $fname(ll_path) status=ignore
    copf $fname(temp5) $fname(ll_path)


display_catalog $fname(cc_path) o=$fname(temp2)
rewf $fname(temp2) status=ignore
crev libnew k=string d=1..20 v=''
crev libnc v=1
accl v=work i=$fname(temp2//'.$asis') lc=count
WHILE count >0 DO
 IF $substr(work,5,5) = 'FILE:' THEN
   libnew(libnc) = $substr(work,11,$strlen(work))
   libnc = libnc + 1
 IFEND
 accl v=work i=$fname(temp2//'.$asis') lc=count
WHILEND

display_catalog $fname(mc_path) o=$fname(temp1)
rewf $fname(temp1) status=ignore
crev libold k=string d=1..20 v=''
crev liboc v=1
accl v=work i=$fname(temp1//'.$asis') lc=count
WHILE count >0 DO
 IF $substr(work,5,5) = 'FILE:' THEN
   libold(liboc) = $substr(work,11,$strlen(work))
   liboc = liboc + 1
 IFEND
 accl v=work i=$fname(temp1//'.$asis') lc=count
WHILEND

 crev bf_path k=string
 crev cf_path k=string
 crev tf_path k=string
 crev lf_path k=string
 crev repair  k=boolean


       FOR i = 1 TO liboc-1 DO
         IF libold(i) <> 'OS_VERSION' THEN
            lib = libold(i)
                repair = FALSE
              FOR j = 1 TO libnc DO
                IF libnew(j) = lib THEN
                   repair = TRUE
                   EXIT
                IFEND
              FOREND
          IFEND
            cf_path = cc_path//'.'//lib
            bf_path = mc_path//'.'//lib
            tf_path = tc_path//'.'//lib
            lf_path = cp_path//'.'//lib
          IF repair THEN

               IF $file($fname(lf_path),permanent) THEN
               putl '       Repairing Library '//lib
               copy_file $fname(lf_path) $fname(tf_path) status=local_status
                    IF NOT local_status.normal THEN
                     EXIT_PROC WITH local_status
                    IFEND
               ELSE
                putl '      Backing out Library '//lib
                copy_file $fname(bf_path) $fname(tf_path) status=local_status
                   IF NOT local_status.normal THEN
                      EXIT_PROC WITH local_status
                   IFEND
               IFEND
           ELSE
             copy_file $fname(bf_path) $fname(tf_path) status=local_status
               IF NOT local_status.normal THEN
                  EXIT_PROC WITH local_status
               IFEND
           IFEND
           FOREND

           crev nx_path k=string v=qev$correction_base//'.'//next_base
           nx_path = nx_path//'.link_input_files'
           copy_file $fname(nx_path//'.OS_VERSION') $fname(tc_path//'.OS_VERSION') status=local_status
               IF NOT local_status.normal THEN
                  EXIT_PROC WITH local_status
               IFEND

detf $fname(hi_path) status=ignore
detf $fname(na_path) status=ignore
detf $fname(lb_path) status=ignore
detf $fname(cp_path) status=ignore
detf $fname(ll_path) status=ignore

delc $fname(bo_path//'.'//ci) do=cac status=ignore


        putl ''                                               o=$fname(ofile//'.$eoi')
        putl '     End Installation of '//last_base//' Correction level' o=$fname(ofile//'.$eoi')
        putl ''                                               o=$fname(ofile//'.$eoi')

PROCEND qcp$withdraw_correction
*DECK DECK=QCM$WITHDRAW_DEADSTART_CATALOG EXPAND=TRUE
PROCEDURE qcp$withdraw_deadstart_catalog (
  status)

  VAR
    local_status: status
  VAREND




  WHEN any_fault DO
    put_line l=' Withdraw Correction System failed with:'
    put_line l=$string(osv$status)
    EXIT PROCEDURE WITH osv$status
  WHENEND
   qcp$back_ds_catalog  status=local_status

  EXIT PROCEDURE WITH local_status
PROCEND qcp$withdraw_deadstart_catalog

*DECK DECK=QCM$WITHDRAW_SYSTEM EXPAND=TRUE
PROCEDURE qcp$withdraw_system (
  status)

  VAR
    ignore: status
    local_status: status
    deadstart_catalog: string
    aux_catalog: string
    version_file: string
    qcu_file: string
    work: string = ''
  VAREND



  IF NOT $job(system) THEN
    putl ' '
    putl '                    STOP  '
    putl '    The command WITHDRAW_SYSTEM must be initiated'
    putl '    from a system job.'
    putl ' '
    EXIT_PROC
  IFEND

    deadstart_catalog = ':$SYSTEM.$SYSTEM.NOSVE_MAINTENANCE.deadstart_catalog'
    version_file = ':$SYSTEM.$SYSTEM.NOSVE_MAINTENANCE.LINK_INPUT_FILES.OS_VERSION'
    qcu_file = ':$SYSTEM.$SYSTEM.QCU_MAINTENANCE.IDENTIFICATION'
    aux_catalog = ':$SYSTEM.$SYSTEM.SITE_OS_MAINTENANCE.DEADSTART_COMMANDS'

  "  Create the global variables.
    delv csv$estqcu_ident status=ignore
    delv csv$estqcu_catalog_specified status=ignore
    delv csv$estqcu_existing_catalog status=ignore

    IF $file($fname(version_file),permanent) THEN
    $system.include_file $fname(version_file)
    ident = $string(level_id)
    ELSE
    ident = ''
    IFEND

    IF $file($fname(qcu_file),permanent) THEN
    $system.accept_line v=work i=$fname(qcu_file)
    IFEND


    putl ' '
    putl '                   ADVISE '
    putl '     Initiating backup to system level '//ident
    putl '                      Wait'
    putl ' '

  VAR
    csv$estqcu_catalog_specified: (JOB) boolean = TRUE
    csv$estqcu_existing_catalog: (JOB) file
    csv$estqcu_ident: (JOB) string
  VAREND

    csv$estqcu_existing_catalog = deadstart_catalog
    csv$estqcu_ident = work



  "  Execute a task to install the deadstart file.

  TASK tn=install_ds_catalog_to_disk
    VAR
      command_status: status
      ignore_status: status
      local_status: status
    VAREND

 MANAGE_FIELD_CHANGES
  put_line ' '
  put_line '     Withdrawing Correction System '//csv$estqcu_ident
  put_line '                 Please'
  put_line '     Wait on the completion message. '
  put_line ' '

   incc c='withdraw_deadstart_catalog status=local_status' ..
      status=command_status
      IF NOT command_status.normal THEN
        local_status = command_status
      IFEND
  QUIT

    IF NOT local_status.normal THEN
        putl ' '
        putl '                       STOP '
        putl '     Some of the material required to reinstate the'
        putl '     base system is missing. It will be necessary to '
        putl '     reestablish the system using the ESTABLISH_DISK_'
        putl '     BASED_SYSTEM subcommand of the MAIDS utility '
        putl '     followed by a COMMIT_NEW_SYSTEM subcommand.'
        putl '     Please refer to the description of the command'
        putl '     MAINTAIN_DEADSTART_SOFTWARE, page 5-15 of the'
        putl '     NOS/VE System Performance and Maintenance, Volume'
        putl '     2, Revision H for further details.'
        putl ' '
        putl '     The detailed status is ..'
        putl ' '

      disv  local_status
       putl ' '
       putl ' MANFC/'

    ELSE
       MANAGE_FIELD_CHANGES
          COMMIT_CORRECTION_SYSTEM
          QUIT
    IFEND

    delete_variable n=csv$estqcu_catalog_specified
    delete_variable n=csv$estqcu_existing_catalog
  TASKEND



 PROCEND qcp$withdraw_system



*DECK DECK=QCP$APPLY_OBJECT_CORRECTION EXPAND=FALSE
PROCEDURE [XREF] qcp$apply_object_correction
   (    base_file: fst$file_reference;
        correction_file: fst$file_reference;
        target_file: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??

*DECK DECK=QCP$COPY EXPAND=FALSE
PROCEDURE [XREF] qcp$copy (old_ol: ^SEQ (*);
   VAR new_ol: ^SEQ( *);
   VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=QCP$FETCH_PSR_STATISTICS EXPAND=FALSE


  PROCEDURE [XREF] qcp$fetch_psr_statistics
    (VAR psr_statistics: qct$psr_statistics;
     VAR psr_count: qct$item_count;
     VAR status: ost$status);

*copyc qct$psr_statistics
*copyc ost$status
*DECK DECK=QCP$INITIALIZE_PSR_STATISTICS EXPAND=FALSE

 PROCEDURE [XREF] qcp$initialize_psr_statistics;
*DECK DECK=QCP$OPEN_FILE EXPAND=FALSE


  PROCEDURE [XREF] qcp$open_file
    (    path_ref_p: ^fst$file_reference;
         access_level: amt$access_level;
         file_attachment: fst$file_access_option;
         create_file: boolean;
         attribute_override_p: ^array [1 .. 1] of fst$file_cycle_attribute;
     VAR file_id: {output} amt$file_identifier;
     VAR file_opened: {output} boolean;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc fsp$open_file
*copyc ost$status
?? POP ??



*DECK DECK=QCP$UPDATE_PSR_STATISTICS EXPAND=FALSE


  PROCEDURE [XREF] qcp$update_psr_statistics
    (    psr_identifier: qct$psr_ident;
     VAR status: ost$status);


*copyc qct$psr_statistics
*copyc ost$status
*DECK DECK=QCT$INSTALLATION_DEFAULTS EXPAND=FALSE

TYPE
  qct$installation_defaults = record
    correction_base: qct$path,
    correction_package: qct$path,
    installation_database: qct$path,
    installation_logs: qct$path,
    system_catalog: qct$path,
    ignore_storage_class: boolean,
    relax_ring_settings: boolean,
  recend;

*copyc qct$path

*DECK DECK=QCT$PATH EXPAND=FALSE

TYPE
 qct$path = record
    size: integer,
    path: fst$path,
  recend;

*copyc fst$path

*DECK DECK=QCT$PSR_STATISTICS EXPAND=FALSE

{ This common deck contains types for psr statistics }

CONST
  qcc$max_psr_entries = 255,
  qcc$null_psr = '       ',
  qcc$null_feature = '                               ';


TYPE
  qct$psr_statistics_entry = record
    psr_ident: qct$psr_ident,
    feature_ident: qct$feature_ident,
  recend,

 qct$psr_ident = string(7),
 qct$feature_ident = string(31),

 qct$psr_statistics = record
  item_count: qct$item_count,
  psr_entries: array [1 .. 255] of qct$psr_statistics_entry,
  recend,

 qct$item_count = integer;
*DECK DECK=QCV$FILRU_UTILITY_NAME EXPAND=FALSE

  VAR
    qcv$filru_utility_name: [XREF, READ] clt$utility_name;

?? PUSH (LISTEXT := ON) ??
*copyc clt$utility_name
?? POP ??
*DECK DECK=QCV$MANFC_UTILITY_NAME EXPAND=FALSE



  VAR
    qcv$manfc_utility_name: [XREF, READ] clt$utility_name;

?? PUSH (LISTEXT := ON) ??
*copyc clt$utility_name
?? POP ??
*DECK DECK=QCV$PSRS_P EXPAND=FALSE

VAR
 qcv$psrs_p: [XREF] ^qct$psr_statistics;
?? PUSH (LISTEXT := ON) ??
*copyc qct$psr_statistics
?? POP ??
*DECK DECK=QFH$ACQUIRE_MODIFIED_INPUT EXPAND=FALSE
{
{    The purpose of this request is to find the next available "modified"
{  input file with the requested destination_usage.
{
{        QFP$ACQUIRE_MODIFIED_INPUT (JOB_DESTINATION_USAGE,
{              INPUT_DESCRIPTOR, STATUS);
{
{ JOB_DESTINATION_USAGE: (input) This indicates the destination_usage that
{        the file in the input queue must have.
{
{ INPUT_DESCRIPTOR: (output) This contains the information needed to dispose
{        of an input file.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{        jme$input_queue_is_empty

*DECK DECK=QFH$ACQUIRE_MODIFIED_OUTPUT EXPAND=FALSE
{
{    The purpose of this request is to find the next available "modified"
{  output file with the requested destination_usage.
{
{        QFP$ACQUIRE_MODIFIED_OUTPUT (OUTPUT_DESTINATION_USAGE,
{              OUTPUT_DESCRIPTOR, STATUS);
{
{ OUTPUT_DESTINATION_USAGE: (input) This indicates the destination_usage that
{        the file in the output queue must have.
{
{ OUTPUT_DESCRIPTOR: (output) This contains the information needed to dispose
{        of an output file.
{
{ STATUS: (output) This is the status of the request.
{      IDENTIFIER:
{        'JM'
{      CONDITIONS:
{        jme$output_queue_is_empty

*DECK DECK=QFH$ACQUIRE_MODIFIED_QFILE EXPAND=FALSE
{
{    The purpose of this request is to find the next available "modified" queue
{ file with the requested application_name.
{
{       QFP$ACQUIRE_MODIFIED_QFILE (APPLICATION_NAME, SYSTEM_FILE_NAME,
{             STATUS);
{
{ APPLICATION_NAME: (input)  This indicates the application_name that the file
{       in the generic queue must have.
{
{ SYSTEM_FILE_NAME: (output)  This is the system supplied name of the acquired
{       file.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{        jme$generic_queue_is_empty
*DECK DECK=QFH$ACQUIRE_NEW_INPUT EXPAND=FALSE
{
{    The purpose of this request is to find the next available "new"
{  input file with the requested destination_usage.
{
{        QFP$ACQUIRE_NEW_INPUT (JOB_DESTINATION_USAGE,
{              INPUT_DESCRIPTOR, STATUS);
{
{ JOB_DESTINATION_USAGE: (input) This indicates the destination_usage that
{        the file in the input queue must have.
{
{ INPUT_DESCRIPTOR: (output) This contains the information needed to dispose
{        of an input file.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{        jme$input_queue_is_empty

*DECK DECK=QFH$ACQUIRE_NEW_OUTPUT EXPAND=FALSE
{
{    The purpose of this request is to find the next available "new" output
{  file with the requested destination_usage.
{
{        QFP$ACQUIRE_NEW_OUTPUT (OUTPUT_DESTINATION_USAGE, OUTPUT_DESCRIPTOR,
{              STATUS);
{
{ OUTPUT_DESTINATION_USAGE: (input) This indicates the destination_usage that
{        the file in the output queue must have.
{
{ OUTPUT_DESCRIPTOR: (output) This contains the information needed to dispose
{        of an output file.
{
{ STATUS: (output) This is the status of the request.
{      IDENTIFIER:
{        'JM'
{      CONDITIONS:
{        jme$output_queue_is_empty
*DECK DECK=QFH$ACQUIRE_NEW_QFILE EXPAND=FALSE
{
{    The purpose of this request is to find the next available "new" queue file
{ with the requested application_name.
{
{       QFP$ACQUIRE_NEW_QFILE (APPLICATION_NAME, SYSTEM_FILE_NAME, STATUS);
{
{ APPLICATION_NAME: (input)  This indicates the application_name that the file
{       in the generic queue must have.
{
{ SYSTEM_FILE_NAME: (output)  This is the system supplied name of the acquired
{       generic queue file.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{        jme$generic_queue_is_empty
*DECK DECK=QFH$ACTIVATE_DEFERRED_FAMILY EXPAND=FALSE
{    The purpose of this request is to remove jobs that are in a deferred
{ state because their login family (served family) is unavailable.  This
{ request is called on the client by the file server during activation.
{
{       QFP$ACTIVATE_DEFERRED_FAMILY (FAMILY_NAME);
{
{ FAMILY_NAME: (input)  This is the name of the family being activated.
{

*DECK DECK=QFH$ASSIGN_JOBS_TO_CLIENT EXPAND=FALSE
{
{    The purpose of this request is to assign a set of jobs from a server
{ mainframe to a client mainframe.  This request executes on the server
{ mainframe.
{
{       QFP$ASSIGN_JOBS_TO_CLIENT (CLIENT_MAINFRAME_ID, LEVELER_JOB_CLASS_DATA,
{             JOB_CLASS_PRIORITIES, INITIATION_REQUIRED_CATEGORIES,
{             INITIATION_EXCLUDED_CATEGORIES, ASSIGNED_JOB_LIST_P,
{             NUMBER_OF_JOBS_ASSIGNED, SERVER_JOB_PRIORITIES);
{
{ CLIENT_MAINFRAME_ID: (input)  This is the binary mainframe identifier of the
{       client mainframe.
{
{ LEVELER_JOB_CLASS_DATA: (input)  This is the job "need" information from the
{       client.  It indicates how many jobs a client mainframe requires.
{
{ JOB_CLASS_PRIORITIES: (input)  This is the job priority that must be met in
{       order for a job to be assigned to the client.
{
{ INITIATION_REQUIRED_CATEGORIES: (input)  This is a set of categories that are
{       required for assignment of jobs to the client.
{
{ INITIATION_EXCLUDED_CATEGORIES: (input)  This is a set of categories that are
{       not allowed for assignment of jobs to the client.
{
{ ASSIGNED_JOB_LIST_P: (output)  This is the list of jobs assigned to the
{       client mainframe.
{
{ NUMBER_OF_JOBS_ASSIGNED: (output)  This is the number of jobs that were
{       assigned to the client mainframe.
{
{ SERVER_JOB_PRIORITIES: (output)  This is the highest priority available job
{       for each job class.
*DECK DECK=QFH$ASSIGN_SERVER_JOBS EXPAND=FALSE
{
{    The purpose of this request is to place the jobs assigned by the server
{ mainframe into the client mainframe's known job list (KJL).
{
{       QFP$ASSIGN_SERVER_JOBS (SERVER_MAINFRAME_ID, ASSIGNED_JOB_LIST_P,
{             NUMBER_OF_JOBS_ASSIGNED, STATUS);
{
{ SERVER_MAINFRAME_ID: (input)  This is the binary mainframe identifier of the
{       server mainframe that assigned the jobs to the client.
{
{ ASSIGNED_JOB_LIST_P: (input)  This is the list of jobs that the server
{       mainframe assigned.  The list contains all the information required to
{       construct the KJL entry for each assigned job.
{
{ NUMBER_OF_JOBS_ASSIGNED: (output)  This is the number of jobs in the assigned
{       job list that were successfully placed in the client's KJL.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$maximum_jobs
*DECK DECK=QFH$ASSIGN_SYSTEM_SUPPLIED_NAME EXPAND=FALSE
{
{    The purpose of this request is to generate the "next" system supplied
{  name candidate to be assigned.  Consecutive calls are guaranteed to return
{  a "highter" result.  When the maximum system supplied name has been
{  generated the next system supplied name used will be "one" higher than
{  the system job's system supplied name.  We NEVER assign the system job's
{  system supplied name.
{
{        QFP$ASSIGN_SYSTEM_SUPPLIED_NAME (SYSTEM_SUPPLIED_NAME);
{
{ SYSTEM_SUPPLIED_NAME: (output) This is the generated system supplied name.
{
*DECK DECK=QFH$CATEGORIZE_JOB EXPAND=FALSE
{
{    The purpose of this request is to categorize a job and return a specific
{ set of values with which the job is to use when it executes.  The categories
{ to which a job is assigned can determine on which machines a job can execute,
{ and what its job class are.
{
{       QFP$CATEGORIZE_JOB (VALID_JOB_CLASSES, NUMBER_OF_VALID_JOB_CLASSES,
{             SYSTEM_LABEL, ASSIGNED_JOB_CLASS, STATUS);
{
{ VALID_JOB_CLASSES: (input)  This is an array that indicates the job classes
{       that the user is valid for.
{
{ NUMBER_OF_VALID_JOB_CLASSES: (input)  This is the number of job classes that
{       are in the array of valid job classes.
{
{ SYSTEM_LABEL: (input, output)  This is the job system label of the job to be
{       categorized.  It contains the job's limits, qualifiers, etc.  to be for
{       categorization.  If automatic job class selection is to take place the
{       job_class_name will be "automatic".  The assigned profile_id and the
{       categorized assigned to the job are recorded in this structure via this
{       request.
{
{ ASSIGNED_JOB_CLASS: (output)  This is the job class index of the job class to
{       which the job belongs.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$cannot_assign_to_job_class
{             jme$job_class_does_not_exist
{             jme$no_job_class_found_for_job
*DECK DECK=QFH$CHANGE_ATTRIBUTE_DEFAULTS EXPAND=FALSE
{
{    The purpose of this request is to change the system's default job
{ attributes.  The input to this request is assumed to be validated.
{
{       QFP$CHANGE_ATTRIBUTE_DEFAULTS (JOB_MODE, DEFAULT_ATTRIBUTE_CHANGES_P,
{             STATUS);
{
{ JOB_MODE: (input)  This indicates the job mode of the default attributes to
{       be changed.
{
{ DEFAULT_ATTRIBUTE_CHANGES_P: (input)  This represents the attributes to be
{       changed.
{
{ STATUS: (output) This is the status of the request.
*DECK DECK=QFH$CHANGE_INPUT_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to update fields of a Known Job List (KJL)
{ entry that may have changed and resubmit the job.
{
{       QFP$CHANGE_INPUT_ATTRIBUTES (SYSTEM_LABEL, JOB_CLASS, PRIVILEGED_JOB,
{             EARLIEST_CLOCK_TIME_TO_INITIATE, LATEST_CLOCK_TIME_TO_INITIATE,
{             CURRENT_CLOCK_TIME, VALID_MAINFRAME_SET, STATUS)
{
{ SYSTEM_LABEL: (input)  This is the record that contains the data necessary to
{       update an entry in the KJL.
{
{ JOB_CLASS: (input)  This is the job class of the job.
{
{ PRIVILEGED_JOB: (input)  Indicates whether or not the request originated from
{       privileged job.  If the requesting job is not privileged, the input
{       file's job submission time is request to "now".
{
{ EARLIST_CLOCK_TIME_TO_INITIATE: (input)  This is a microsecond clock value
{       that must be exceeded before the job can become a candidate for
{       initiation.
{
{ LATEST_CLOCK_TIME_TO_INITATE: (input)  This is a microsecond clock value that
{       signifies the "latest" microsecond clock value at which the job can
{       become a candidate for successful initiation.
{
{ CURRENT_CLOCK_TIME: (input)  This is the value of the microsecond clock at
{       the time the job was submitted.
{
{ VALID_MAINFRAME_SET: (input) This is the set of mainframes on which the job
{       can execute.
{
{ STATUS: (output) This is the record that contains the status of the request.
{       CONDITIONS:
{             jme$input_is_initiated
{             jme$name_not_found
{             jme$scheduling_profile_changed
{

*DECK DECK=QFH$CHANGE_OUTPUT_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is change certain output attribute data in the
{ Known_Output_List (KOL).
{
{       QFP$CHANGE_OUTPUT_ATTRIBUTES (SYSTEM_LABEL,
{             EARLIEST_CLOCK_TIME_TO_PRINT, LATEST_CLOCK_TIME_TO_PRINT,
{             PURGE_DELAY_CLOCK_TIME, CURRENT_CLOCK_TIME, REPRINT_DISPOSITION,
{             NOTIFY_APPLICATION, APPLICATION_GTID, DELETE_OUTPUT_FILE,
{             STATUS);
{
{ SYSTEM_LABEL: (input)  This is the output system label associated with output
{       file.
{
{ EARLIEST_CLOCK_TIME_TO_PRINT: (input)  This is the microsecond clock value at
{       which the file becomes a candidate for disposition.
{
{ LATEST_CLOCK_TIME_TO_PRINT: (input)  This is the microsecond clock value at
{       which the file expires and should be removed from the output queue.
{
{ PURGE_DELAY_CLOCK_TIME: (input)  This is the time increment in microseconds
{       for the file in the queue.  It represents how long the file should
{       remain in the queue after it has been printed.  Its true value is the
{       microsecond clock value at which the file will expire.
{
{ CURRENT_CLOCK_TIME: (input)  This is the current microsecond clock value.
{
{ REPRINT_DISPOSITION: (input)  This indicates if the file should be reprinted,
{       discarded or not changed.  This value only has an effect on printed
{       files.
{
{ NOTIFY_APPLICATION: (output)  This indicates if an output application,
{       identified by the APPLICATION_GTID, should be notified of the modified
{       output queue file.
{
{ APPLICATION_GTID: (output)  If the NOTIFY_APPLICATION parameter is true,
{       this parameter is the global task id of the output application
{       registered for the changed queue file.
{
{ DELETE_OUTPUT_FILE: (output)  This indicates if the file has been removed
{       from the KOL.  If it has, the output file should be deleted.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$name_not_found
*DECK DECK=QFH$CHANGE_QFILE_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is change certain attribute data for a file in
{ the Known_Qfile_List (KQL).
{
{       QFP$CHANGE_QFILE_ATTRIBUTES (SYSTEM_LABEL,
{             EARLIEST_CLOCK_TIME_TO_PROCESS, LATEST_CLOCK_TIME_TO_PROCESS,
{             PURGE_DELAY_CLOCK_TIME, CURRENT_CLOCK_TIME, RERUN_DISPOSITION,
{             DELETE_QUEUE_FILE, STATUS);
{
{ SYSTEM_LABEL: (input)  This is the system label associated with the queue
{       file.
{
{ EARLIEST_CLOCK_TIME_TO_PROCESS: (input)  This is the microsecond clock value
{       at which the file becomes a candidate for disposition.
{
{ LATEST_CLOCK_TIME_TO_PROCESS: (input)  This is the microsecond clock value at
{       which the file expires and should be removed from the queue.
{
{ PURGE_DELAY_CLOCK_TIME: (input)  This is the time increment in microseconds
{       for the file in the queue.  It represents how long the file should
{       remain in the queue after it has been processed.  Its true value is the
{       microsecond clock value at which the file will expire.
{
{ CURRENT_CLOCK_TIME: (input)  This is the current microsecond clock value.
{
{ RERUN_DISPOSITION: (input)  This indicates if the file should be rerun,
{       discarded, or not changed.  This value only has an effect on processed
{       files.
{
{ DELETE_QUEUE_FILE: (output)  This indicates if the file has been removed from
{       the KQL.  If it has, the file should be deleted.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$name_not_found
*DECK DECK=QFH$CHANGE_TERMINATE_JOB_ACTION EXPAND=FALSE
{    The purpose of this request is to change the action that a terminate job
{ request will take when a job is terminated.
{
{       QFP$CHANGE_TERMINATE_JOB_ACTION (TERMINATE_JOB_ACTION_SET);
{
{ TERMINATE_JOB_ACTION_SET: (input)  This is the set of terminate job actions
{       being requested.
*DECK DECK=QFH$CHECK_FOR_PROFILE_MISMATCH EXPAND=FALSE
{
{   The purpose of this request is to determine if the currently active
{ scheduling profile is the same as the version indicated on the request.
{
{        QFP$CHECK_FOR_PROFILE_MISMATCH (PROFILE_VERSION, PROFILE_MISMATCHED);
{
{ PROFILE_VERSION: (input) This is the version of the profile to check against.
{
{ PROFILE_MISMATCHED: (output) This indicates if the profile's are mismatched
{        or not.
{
*DECK DECK=QFH$CLEAR_SERVER_JOB_CLASSES EXPAND=FALSE
{
{    The purpose of this request is to "clear-up" any residue that may have
{ been left over by the job leveler task with respect to any server mainframe.
{ For example, the job classes are all "unblocked" by this request.
{
{    QFP$CLEAR_SERVER_JOB_CLASSES;
*DECK DECK=QFH$DEFER_DEACTIVATED_FAMILY EXPAND=FALSE
{    The purpose of this request is to move jobs that are in a queued state to
{ a deferred state because their login family (served family) is unavailable.
{ This request is called on the client by the file server during deactivation.
{
{       QFP$DEFER_DEACTIVATED_FAMILY (FAMILY_NAME);
{
{ FAMILY_NAME: (input)  This is the name of the family being deactivated.
{
*DECK DECK=QFH$DETERMINE_MAINFRAME_FITNESS EXPAND=FALSE
{
{    The purpose of this request is to determine which mainframes for which a
{ job "fits" the validation categories.
{
{       QFP$DETERMINE_MAINFRAME_FITNESS (JOB_CATEGORY_SET, LEVELED_JOB,
{             LOGIN_FAMILY, VALID_MAINFRAMES_SET, STATUS);
{
{ JOB_CATEGORY_SET: (input)  These are the job categories of the job being
{       tested.
{
{ LEVELED_JOB: (input)  This indicates if the job is a candidate for other
{       mainframes or if it is a candidate for the submitting mainframe only.
{
{ LOGIN_FAMILY: (input)  This is the login family of the job being tested.
{
{ VALID_MAINFRAMES_SET: (output)  This is the set of mainframes that the job is
{       valid for.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$no_mainframe_found_for_job
*DECK DECK=QFH$DETERMINE_NEEDED_PRIORITIES EXPAND=FALSE
{
{    The purpose of this request is to retrieve the job priorities that are
{ necessary for assignment to a job class for a job from a server mainframe.
{
{       QFP$DETERMINE_NEEDED_PRIORITIES (LEVELER_JOB_CLASS_DATA,
{             JOB_CLASS_PRIORITIES);
{
{ LEVELER_JOB_CLASS_DATA: (input)  This indicates the "number" of jobs the job
{       leveler task is requesting.
{
{ JOB_CLASS_PRIORITIES: (output)  This is the list of job class priorities.
*DECK DECK=QFH$DETERMINE_NEED_FOR_JOBS EXPAND=FALSE
{
{    The purpose of this request is to determine how many jobs of each job
{ class a client mainframe should ask a server mainframe for.
{
{       QFP$DETERMINE_NEED_FOR_JOBS (LEVELER_JOB_CLASS_DATA);
{
{ LEVELER_JOB_CLASS_DATA: (output)  This is the "need" of jobs for each job
{       class.
*DECK DECK=QFH$DISCARD_CLIENT_JOBS EXPAND=FALSE
{
{    The purpose of this request is to discard all uninitiated jobs assigned by
{ the server to the specified client mainframe.
{
{    QFP$DISCARD_CLIENT_JOBS (CLIENT_MAINFRAME_ID);
{
{ CLIENT_MAINFRAME_ID: (input)  This is the binary mainframe id of the client
{       mainframe.
*DECK DECK=QFH$DISCARD_JOB EXPAND=FALSE
{
{    The purpose of this request is to "mark" the calling jobs as being
{  terminated or entering job-end processing.
{
{        QFP$DISCARD_JOB;
*DECK DECK=QFH$DISCARD_JOB_OUTPUT EXPAND=FALSE
{
{    The purpose of this request is to set the value that indicates the fate
{  of an output file when it is printed.  This will set it to the specified
{  state.
{
{        QFP$DISCARD_JOB_OUTPUT (OUTPUT_DISPOSITION_KEY);
{
{ OUTPUT_DISPOSITION_KEY: (input) This indicates the selector to be used when
{        an output file is printed.
*DECK DECK=QFH$DISCARD_SERVER_JOBS EXPAND=FALSE
{
{    The purpose of this request is to discard all uninitiated jobs assigned to
{ the client by the specified server mainframe.
{
{    QFP$DISCARD_SERVER_JOBS( SERVER_MAINFRAME_ID);
{
{ SERVER_MAINFRAME_ID: (input)  This is the binary mainframe id of the server
{       mainframe.
*DECK DECK=QFH$EXPAND_KJL EXPAND=FALSE
{
{   The purpose of this request is to increase the initialized size of the Known
{ Job List.  If the Known Job List is at its maximum size this request acts as
{ a NO-OP.
{
{   CAUTION:  This request cannot be performed in a loop in ring one.  If
{             several entries must be added to the KJL this request must be
{             called from ring 3.  The reason for this is because pages
{             assigned in ring 1 do not get backing store until the ring is
{             exited.  So if too many new pages are added to the KJL, memory
{             may be exhausted and the system will crash or hang.
{
{        QFP$EXPAND_KJL;
*DECK DECK=QFH$FIND_JOB_CONNECTION_SWITCH EXPAND=FALSE
*DECK DECK=QFH$GET_INPUT_FILE_LOCATION EXPAND=FALSE
{
{    The purpose of this request is to obtain the input file location and
{  login family for a known job.
{
{        QFP$GET_INPUT_FILE_LOCATION (SYSTEM_JOB_NAME, LOCATION, FAMILY,
{              STATUS);
{
{ SYSTEM_JOB_NAME: (input) This is the system-supplied job name for the job
{        of interest.
{
{ LOCATION: (output) This is the job's input file location from the KJL.
{
{ FAMILY: (output) This is the job's login family from the KJL.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        jme$name_not_found
*DECK DECK=QFH$GET_INPUT_Q_FROM_UNASSIGNED EXPAND=FALSE
{
{   The purpose of this request is obtain a list of the input jobs in the
{ UNASSIGNED job class which have a job destination of VE.
{
{       QFP$GET_INPUT_Q_FROM_UNASSIGNED (SYSTEM_SUPPLIED_NAMES,
{         NUMBER_OF_JOBS_FOUND, STATUS)
{
{ SYSTEM_SUPPLIED_NAMES: (output)  This parameter specifies a result array in
{       which the system supplied names of the input jobs in the UNASSIGNED job
{       class are returned.  These jobs have a job destination of VE.
{
{ NUMBER_OF_JOBS_FOUND: (output)  This parameter specifies the number of input
{       jobs which met the criteria.  It may be greater than the number of jobs
{       for which information is returned if the size of the result array is
{       too small.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             none
{       IDENTIFIER: 'JM'
{
*DECK DECK=QFH$GET_JOB_COUNTS EXPAND=FALSE
{
{   The purpose of this request is to retrieve some count information
{ kept about jobs. The information includes such items as the number
{ of queued and initiated jobs and the number of jobs in each job class.
{
{        QFP$GET_JOB_COUNTS (JOB_COUNTS);
{
{ JOB_COUNTS: (output) This is a record that contains various counts of
{        general interest.
*DECK DECK=QFH$GET_JOB_INTERNAL_INFO EXPAND=FALSE
{
{    The purpose of this request is to obtain internal information about an
{  executing job via the system supplied name of the job.
{
{        QFP$GET_JOB_INTERNAL_INFO (SYSTEM_JOB_NAME, JOB_INTERNAL_INFO,
{              STATUS);
{
{ SYSTEM_JOB_NAME: (input) This parameter specifies the system job name
{        of the job.
{
{ JOB_INTERNAL_INFO: (output) This parameter specifies the job's internal
{        information.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        jme$name_not_found
*DECK DECK=QFH$GET_JOB_STATUS EXPAND=FALSE
{
{    The purpose of this request is to get various data about jobs.  Which jobs
{ to investigate is based upon what the caller uses (USER_ID and PRIVILEGE) and
{ any restrictions imposed by STATUS_OPTIONS.
{
{       QFP$GET_JOB_STATUS (USER_IDENTIFICATION, CALLER_SSN, PRIVILEGED_JOB,
{             VALID_FOR_SCHEDULING_DISPLAYS, STATUS_OPTIONS,
{             STATUS_RESULTS_KEYS_P, STATUS_RESULTS_SEQ_P,
{             NUMBER_OF_JOBS_FOUND, STATUS);
{
{ USER_IDENTIFICATION: (input)  This is the NOS/VE user identification.  This
{       is the job's owner or originator.
{
{ CALLER_SSN: (input)  This is the system job name of the job making the
{       request to status the job.
{
{ PRIVILEGED_JOB: (input)  This indicates that the job has privilege to see
{       "other" jobs and is not restricted to USER_IDENTIFICATION.
{
{ VALID_FOR_SCHEDULING_DISPLAYS: (input)  This parameter indicates if the calling
{       job has the scheduling_displays capability.
{
{ STATUS_OPTIONS: (input)  This is an array of variants which can designate
{       criteria a job must meet in order to have its data returned.
{
{ STATUS_RESULTS_KEYS_P: (input)  This is an array that contains the keys that
{       describe the information being requested.
{
{ STATUS_RESULTS_SEQ_P: (output)  This is a sequence that contains the values
{       associated with the specifications on the STATUS_RESULTS_KEYS_P
{       parameter.
{
{ NUMBER_OF_JOBS_FOUND: (output)  This designates the number of jobs that met
{       the criteria imposed by USER_ID, PRIVILEGE and STATUS_OPTIONS.
{
{ STATUS: (output) This is the record that contains the status of the request.
{       CONDITIONS:
{             none.
*DECK DECK=QFH$GET_OUTPUT_ATTRIBUTES EXPAND=FALSE
{
{    The purpose of this request is to retreive the names of output files that
{  meets a set of criteria.
{
{        QFP$GET_OUTPUT_ATTRIBUTES (USER_IDENTIFICATION, PRIVILEGED_JOB,
{          ATTRIBUTE_OPTIONS_P, OUTPUT_NAMES_P, NUMBER_OF_OUTPUTS_FOUND,
{          STATUS);
{
{ USER_IDENTIFICATION: (input) This is the family user pair of the calling job.
{
{ PRIVILEGED_JOB: (input) This indicates that the caller has special privilege.
{
{ ATTRIBUTE_OPTIONS_P: (input) This represents a "set" of criteria used to
{        determine the name(s) of the output files to be returned.
{
{ OUTPUT_NAMES_P: (output) This parameter contains a list of names of the
{        output files that meet the specified criteria.
{
{ NUMBER_OF_OUTPUTS_FOUND: (output) This indicates the number of output files
{        that meets the criteria.
{
{ STATUS: (output) This is the status of the request.
{      IDENTIFIER:
{        'JM'
{      CONDITIONS:
{        none.
*DECK DECK=QFH$GET_OUTPUT_COUNTS EXPAND=FALSE
{
{    The purpose of this request is to retrieve various counts related to
{  output files from the Known Output List (KOL);
{
{        QFP$GET_OUTPUT_COUNTS (OUTPUT_COUNTS, STATUS);
{
{ OUTPUT_COUNTS: (output) These are the requested output counts.
{
{ STATUS: (output) This is the status of the request.
{      IDENTIFIER:
{        'JM'
{      CONDITIONS:
{        none.
*DECK DECK=QFH$GET_OUTPUT_STATUS EXPAND=FALSE
{
{    The purpose of this request is to retrieve the status of output files that
{ match the specified criteria.  The status information returned is based on
{ the information requested.
{
{       QFP$GET_OUTPUT_STATUS (USER_IDENTIFICATION, PRIVILEGED_JOB,
{             STATUS_OPTIONS, STATUS_RESULTS_KEYS_P, WORK_AREA_P,
{             NUMBER_OF_OUTPUTS_FOUND, STATUS);
{
{ USER_IDENTIFICATION: (input)  This parameter indicates the user and family
{       name of the requestor.  The output files must have this user/family as
{       either the login or control user/family in order for the file's status
{       to be returned by this request.
{
{ PRIVILEGED_JOB: (input)  This parameter indicates if the requestor deserves
{       system privilege.  If true, the requestor has access to all files in
{       the output queue.
{
{ STATUS_OPTIONS: (input)  This parameter indicates a set of criteria that must
{       be met in order for a file to be returned by this request.
{
{ STATUS_RESULTS_KEYS_P: (input)  This is an array that contains the keys that
{       describe the information being requested.
{
{ WORK_AREA_P: (output)  This is the data area where the requested information
{       is to be placed.
{
{ NUMBER_OF_OUTPUTS_FOUND: (output)  This indicates the number of files that
{       the requestor has permission to access that match the specified
{       criteria.
{
{ STATUS: (output) This is the status of the request.
{        CONDITIONS:
{          none.
*DECK DECK=QFH$GET_PRINT_COUNTS EXPAND=FALSE
{
{    The purpose of this request is to retrieve some count information
{  kept about prints.
{
{        QFP$GET_PRINT_COUNTS (PRINT_COUNTS, STATUS);
{
{ PRINT_COUNTS: (output) This is a record that contains various counts of
{        general interest.
{
{ STATUS: (output) This is a record that contains the status of the request.
{

*DECK DECK=QFH$GET_PRINT_STATUS EXPAND=FALSE
{
{    The purpose of this request is to get various data about prints. Which
{  print to investigate is based upon what the caller uses (USER_ID and
{  PRIVILEGE) and any restrictions imposed by STATUS_OPTIONS.
{
{        QFP$GET_PRINT_STATUS (USER_IDENTIFICATION, PRIVILEGED_JOB,
{          STATUS_OPTIONS, STATUS_RESULTS, NUMBER_OF_PRINTS_FOUND, STATUS);
{
{ USER_IDENTIFICATION: (input) This is the NOS/VE user identification.  This
{        is the print's owner or originator.
{
{ PRIVILEGED_JOB: (input) This indicates that the job has privilege to see
{        "other" prints and is not restricted to USER_IDENTIFICATION.
{
{ STATUS_OPTIONS: (input) This is an array of varients which can designate
{        criteria a print must meet in order to have its data returned.
{
{ STATUS_RESULTS: (input-output) This is an array of varients which contains
{        the selection of which data are desired and the associated values.
{
{ NUMBER_OF_PRINTS_FOUND: (output) This designates the number of prints that met
{        the criteria imposed by USER_ID, PRIVILEGE and STATUS_OPTIONS.
{
{ STATUS: (output) This is the record that contains the status of the request.
{

*DECK DECK=QFH$GET_PROFILE_MAINFRAME_INDEX EXPAND=FALSE
{
{    The purpose of this request is to determine the mainframe index in the job
{ scheduling profile of a given mainframe.  If the mainframe is not in the
{ scheduling profile a value of zero is used.
{
{       QFP$GET_PROFILE_MAINFRAME_INDEX (BINARY_MAINFRAME_ID, MAINFRAME_INDEX);
{
{ BINARY_MAINFRAME_ID: (input)  This is the binary mainframe id to be searched
{       for.
{
{ MAINFRAME_INDEX: (output)  This is the mainframe index in the scheduling
{       profile.
{

*DECK DECK=QFH$GET_QFILE_STATUS EXPAND=FALSE
{
{    The purpose of this request is to retrieve the status of queue files that
{ match the specified criteria.  The status information returned is based on
{ the information requested.
{
{       QFP$GET_QFILE_STATUS (STATUS_OPTIONS_P, STATUS_RESULTS_KEYS_P,
{             STATUS_WORK_AREA_P, STATUS_RESULTS_P, NUMBER_OF_QFILES_FOUND);
{
{ STATUS_OPTIONS_P: (input)  This parameter indicates a set of criteria that
{       must be met in order for a file to be returned by this request.
{
{ STATUS_RESULTS_KEYS_P: (input)  This parameter indicates what pieces of
{       status information are requested.
{
{ STATUS_WORK_AREA_P: (output)  This is the work area in which the status
{       results are returned.
{
{ STATUS_RESULTS_P: (output)  The requested information is placed in this
{       structure.
{
{ NUMBER_OF_QFILES_FOUND: (output)  This indicates the number of files that
{       match the specified criteria.  If this value is larger than the size of
{       the work area, it means that the work area was too small and the
{       request should be retried with a larger work area.
{
*DECK DECK=QFH$GET_SERVER_JOBS EXPAND=FALSE
{
{    The purpose of this request is to retrieve the list of jobs assigned to
{ the client by the specified server mainframe.
{
{       QFP$GET_SERVER_JOBS (SERVER_MAINFRAME_ID, SERVER_JOB_LIST_P,
{             SERVER_JOB_COUNT);
{
{ SERVER_MAINFRAME_ID: (input)  This is the binary mainframe id of the server
{       mainframe.
{
{ SERVER_JOB_LIST_P: (output)  This is the list of jobs assigned by the server
{       to the client.
{
{ SERVER_JOB_COUNT: (output)  This is the number of elements in the
{       server_job_list that are valid.
*DECK DECK=QFH$JOB_REQUESTS_RESTART EXPAND=FALSE
{
{   The purpose of this request is to determine if a job has requested to be
{ restarted or not when it aborts.  It is a boolean function.
{
{        QFH$JOB_REQUESTS_RESTART ();
*DECK DECK=QFH$JOB_SELECTION_PRIORITY EXPAND=FALSE
{
{    The purpose of this request is to return the selection priority of a job
{ in the NOS/VE input queue.
{
{    QFP$JOB_SELECTION_PRIORITY(CURRENT_TIME, KJL_INDEX):  JOB_PRIORITY;
{
{ CURRENT_TIME: (input)  This is the current (base) free running clock value.
{
{ KJL_INDEX: (input)  This is the Known Job List (KJL) index of the job whose
{       priority is being calculated.
{
{ JOB_PRIORITY: (output)  This is the selection priority of the queued job.
*DECK DECK=QFH$LIST_JOBS_VIA_MODE EXPAND=FALSE
{
{    The purpose of this request is to obtain a list of system supplied names
{  for each executing job in the system via specified JOB_MODE.
{
{        QFP$LIST_JOBS_VIA_MODE (JOB_MODE, SYSTEM_JOB_NAMES,
{          NUMBER_OF_JOBS_RETURNED, STATUS);
{
{ JOB_MODE: (input) This parameter specifies the job_mode of jobs for which
{        system job names are to be returned.
{
{ SYSTEM_JOB_NAMES: (output) This parameter specifies the array into which
{        the list of system job names is to be placed.
{
{ NUMBER_OF_JOBS_RETURNED: (output) This parameter specifies the number of
{        system job names returned in the array.
{
{ STATUS: (output) This is the record containing the status of the request.
{      CONDITIONS:
{        none.
*DECK DECK=QFH$MOVE_INPUT_Q_TO_UNASSIGNED EXPAND=FALSE
{
{   The purpose of this request is to move the input queue for the given job
{ class to the UNASSIGNED job class.
{
{       QFP$MOVE_INPUT_Q_TO_UNASSIGNED (JOB_CLASS_INDEX, NUMBER_OF_JOBS_MOVED,
{         STATUS)
{
{ JOB_CLASS_INDEX: (input)  This parameter specifies the index of the job class
{       for the request.
{
{ NUMBER_OF_JOBS_MOVED: (output)  This parameter specifies the number of jobs
{       in the the input queue of the given job class which were moved to the
{       UNASSIGNED job class.  This parameter result is defined if the status
{       condition, jme$not_all_jobs_were_moved, is returned and indicates how
{       many were moved.
{
{ STATUS: (output)  This parameter specifies the request status.
{       CONDITIONS:
{             jme$not_all_jobs_were_moved
{       IDENTIFIER: 'JM'
{
*DECK DECK=QFH$PRINT_COMPLETED EXPAND=FALSE
{
{    The purpose of this request is to notify queued file management the
{  completion status of the disposition of a print.  The request also
{  returns information stating whether or not the print has been terminated
{  while disposition was in process.
{
{        QFP$PRINT_COMPLETED (PRINT_SYSTEM_ID, COMPLETED_SUCCESSFULLY,
{          PREVIOUSLY_TERMINATED, SYSTEM_SUPPLIED_NAME, STATUS);
{
{ PRINT_SYSTEM_ID: (input) This is what queued file management uses to
{        reference a print outside of queued files.
{
{ COMPLETED_SUCCESSFULLY: (input) Was the print disposed of successfully?
{
{ PREVIOUSLY_TERMINATED: (output) Was the print terminated while it was
{        acquired for disposition?
{
{ SYSTEM_SUPPLIED_NAME: (output) The system supplied name corresponding to
{        the print.
{
{ STATUS: (output) This is the record that contains the status of the request.
{
*DECK DECK=QFH$PRINT_FILE EXPAND=FALSE
{
{    The purpose of this request is to update the Known Output List (KOL) by
{ adding another candidate for disposition.
{
{       QFP$PRINT_FILE (SYSTEM_LABEL, EARLIEST_CLOCK_TIME_TO_PRINT,
{             LATEST_CLOCK_TIME_TO_PRINT, CURRENT_CLOCK_TIME, STATUS);
{
{ SYSTEM_LABEL: (input)  This is the system label for the output file.
{
{ EARLIEST_CLOCK_TIME_TO_PRINT: (input)  This is the microsecond clock value at
{       which the file becomes a candidate for disposition.
{
{ LATEST_CLOCK_TIME_TO_PRINT: (input)  This is the microsecond clock value at
{       which the file expires and should be removed from the output queue.
{
{ CURRENT_CLOCK_TIME: (input)  This is the current microsecond clock value.
{
{ STATUS: (output) This is the record that contains the status of the request.
{       CONDITIONS:
{             jme$maximum_output
*DECK DECK=QFH$PURGE_EXPIRED_FILE EXPAND=FALSE
{
{    The purpose of this request is to notify the appropriate processes that a
{ file has exceeded its expiration time in the output queue.  This request also
{ sets the time at which the next file will expire.
{
{       QFP$PURGE_EXPIRED_FILE (SYSTEM_FILE_NAME_TO_DELETE,
{             OUTPUT_DESTINATION_USAGE);
{
{ SYSTEM_FILE_NAME_TO_DELETE: (output)  This is the system file name of the
{       output file in the queue to delete.  If this string is empty, no file
{       should be deleted.
{
{ OUTPUT_DESTINATION_USAGE: (output)  This is the output destination usage of
{       the output file to be deleted.
*DECK DECK=QFH$PURGE_EXPIRED_QUEUE_FILE EXPAND=FALSE
{
{    The purpose of this request is to notify the appropriate processes that a
{ file has exceeded its expiration time in the generic queue.  This request
{ also sets the time at which the next file will expire.
{
{       QFP$PURGE_EXPIRED_QUEUE_FILE (SYSTEM_FILE_NAME_TO_DELETE);
{
{ SYSTEM_FILE_NAME_TO_DELETE: (output)  This is the system file name of the
{       file in the generic queue to delete.  If this string is empty, no file
{       should be deleted.
{
*DECK DECK=QFH$PURGE_PRINTED_FILE EXPAND=FALSE
{
{    The purpose of this request is to notify the appropriate processes that an
{ output file that has been previously disposed has exceeded its purge delay in
{ the output queue.  This request also sets the time at which the next file
{ will exceed its purge delay.
{
{       QFP$PURGE_PRINTED_FILE (SYSTEM_FILE_NAME_TO_DELETE,
{             OUTPUT_DESTINATION_USAGE);
{
{ SYSTEM_FILE_NAME_TO_DELETE: (output)  This is the system file name of the
{       output file in the queue to delete.  If this string is empty, no file
{       should be deleted.
{
{ OUTPUT_DESTINATION_USAGE: (output)  This is the output destination usage of
{       the output file to be deleted.
*DECK DECK=QFH$PURGE_PROCESSED_QUEUE_FILE EXPAND=FALSE
{
{    The purpose of this request is to notify the appropriate processes that a
{ queue file that has been previously disposed has exceeded its purge delay in
{ the generic queue.  This request also sets the time at which the next file
{ will exceed its purge delay.
{
{       QFP$PURGE_PROCESSED_QUEUE_FILE (SYSTEM_FILE_NAME_TO_DELETE);
{
{ SYSTEM_FILE_NAME_TO_DELETE: (output)  This is the system file name of the
{       file in the generic queue to delete.  If this string is empty, no file
{       should be deleted.
{
*DECK DECK=QFH$QUEUE_JOB_FOR_CON_SWITCH EXPAND=FALSE
*DECK DECK=QFH$READY_DEFERRED_FILE EXPAND=FALSE
{
{    The purpose of this request is to notify the appropriate processes that a
{ deferred output file is now available as a candidate for disposition.  This
{ request also sets the time at which the next deferred file becomes available.
{
{    QFP$READY_DEFERRED_FILE;
{
*DECK DECK=QFH$READY_DEFERRED_JOB EXPAND=FALSE
{
{    The purpose of this request is to notify the appropriate processes that
{  a deferred job is now available as a candidate for initiation.  This request
{  also sets the time at which the next deferred job becomes a candidate for
{  initiation.
{
{        QFP$READY_DEFERRED_JOB;
{
{ No Parameters
{
*DECK DECK=QFH$READY_DEFERRED_QUEUE_FILE EXPAND=FALSE
{
{    The purpose of this request is to notify the appropriate processes that a
{ deferred generic queue file is now available as a candidate for disposition.
{ This request also sets the time at which the next deferred file becomes
{ available.
{
{    QFP$READY_DEFERRED_QUEUE_FILE;
{
*DECK DECK=QFH$READY_JOB_LEVELER EXPAND=FALSE
{
{    The purpose of this request is to ready the job leveler task.  This
{ request is valid in rings one through three.
{
{        QFP$READY_JOB_LEVELER;
{
*DECK DECK=QFH$READ_JOB_SYSTEM_LABEL EXPAND=FALSE
{
{    The purpose of this request is to read the job's system label of the
{ specified file.
{
{       QFP$READ_JOB_SYSTEM_LABEL (FILE_REFERENCE, SYSTEM_LABEL, STATUS);
{
{ FILE_REFERENCE: (input)  This is the file whose label is to be read.
{
{ SYSTEM_LABEL: (output)  This is the image of the file's job system label.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{            jme$read_job_system_label
{            jme$sl_version_mismatch
*DECK DECK=QFH$READ_OUTPUT_SYSTEM_LABEL EXPAND=FALSE
{
{    The purpose of this request is to read the system label of the specified
{ output file.
{
{       QFP$READ_OUTPUT_SYSTEM_LABEL (FILE_REFERENCE, SYSTEM_LABEL, STATUS);
{
{ FILE_REFERENCE: (input)  This is the file who's label is to be read.
{
{ SYSTEM_LABEL: (output)  This is the image of the file's output system label.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{           jme$read_output_system_label
{           jme$sl_version_mismatch
*DECK DECK=QFH$READ_QFILE_SYSTEM_LABEL EXPAND=FALSE
{
{    The purpose of this request is to read the system label of the specified
{ generic queue file.
{
{       QFP$READ_QFILE_SYSTEM_LABEL (FILE_REFERENCE, SYSTEM_LABEL, STATUS);
{
{ FILE_REFERENCE: (input)  This is the file whose label is to be read.
{
{ SYSTEM_LABEL: (output)  This is the image of the file's system label.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{           jme$read_qfile_system_label
{           jme$sl_version_mismatch
*DECK DECK=QFH$REBUILD_EXECUTING_JOB EXPAND=FALSE
{
{    The purpose of this request is to enter a recovering job in the Known Job
{ List.  The information is gained from the job's environment when the system
{ was idled.
{
{       QFP$REBUILD_EXECUTING_JOB (CURRENT_CLOCK_TIME, SYSTEM_JOB_NAME,
{             JOB_CONTROL_BLOCK);
{
{ CURRENT_CLOCK_TIME: (input)  This is the clock time for job submission.
{
{ SYSTEM_JOB_NAME: (input)  This is the system supplied name of the job being
{       recovered.
{
{ JOB_CONTROL_BLOCK: (input)  This is the job's Job Control Block.
*DECK DECK=QFH$REBUILD_GENERIC_QUEUE EXPAND=FALSE
{
{    The purpose of this request is to alter the Known Qfile List (KQL) by
{ adding an entry that signifies the existence of a possible candidate for
{ disposition.  This information is regained from the file's system label
{ during a continuation deadstart of NOS/VE.
{
{       QFP$REBUILD_GENERIC_QUEUE (SYSTEM_LABEL,
{             EARLIEST_CLOCK_TIME_TO_PROCESS, LATEST_CLOCK_TIME_TO_PROCESS,
{             PURGE_DELAY_CLOCK_TIME, CURRENT_CLOCK_TIME, STATUS);
{
{ SYSTEM_LABEL: (input)  This is the system label for the file being recovered.
{
{ EARLIEST_CLOCK_TIME_TO_PROCESS: (input)  This is the microsecond clock value
{       at which the file will become a candidate for disposition.
{
{ LATEST_CLOCK_TIME_TO_PROCESS: (input)  This is the microsecond clock value at
{       which the file will expire and be deleted from the generic queue.
{
{ PURGE_DELAY_CLOCK_TIME: (input)  This is the microsecond clock value for the
{       time that a file that has been disposed should be deleted from the
{       generic queue.  If the file has not disposed this will be zero.
{
{ CURRENT_CLOCK_TIME: (input)  This is the current microsecond clock value.
{
{ STATUS: (output) This is the record that contains the status of the request.
{       CONDITIONS:
{             jme$maximum_generic_qfiles
*DECK DECK=QFH$REBUILD_INPUT_QUEUE EXPAND=FALSE
{
{    The purpose of this request is to alter the Known Job List (KJL) by adding
{ an entry that signifies the existence of a possible candidate for initiation.
{ This information is regained from the job's system label during a recovery
{ deadstart of NOS/VE.
{
{       QFP$REBUILD_INPUT_QUEUE (SYSTEM_LABEL, EARLIEST_CLOCK_TIME_TO_INITIATE,
{             LATEST_CLOCK_TIME_TO_INITIATE, CURRENT_CLOCK_TIME,
{             JOB_SUBMISSION_TIME, JOB_CLASS, INPUT_FILE_LOCATION,
{             LOGIN_FAMILY_AVAILABLE, STATUS);
{
{ SYSTEM_LABEL: (input)  This is the system label for the job being recovered.
{
{ EARLIEST_CLOCK_TIME_TO_INITIATE: (input)  This is the microsecond clock value
{       which needs to be exceeded in order for this job to become a candidate
{       for initiation.
{
{ LATEST_CLOCK_TIME_TO_INITIATE: (input)  This is the microsecond clock value
{       that signifies the latest time at which this job is a candidate for
{       successful initiation.
{
{ CURRENT_CLOCK_TIME: (input)  This is the value contained in the microsecond
{       clock at the time this job was recovered.
{
{ JOB_SUBMISSION_TIME: (input)  This is the recalculated microsecond clock
{       value that indicates the job's submission time.  This value may be
{       negative.
{
{ JOB_CLASS: (input)  This is the job class of the job being recovered.
{
{ INPUT_FILE_LOCATION: (input)  This indicates the physical location of the
{       job's input file.
{
{ LOGIN_FAMILY_AVAILABLE: (input)  This indicates if the job's login family is
{       available on-line or is on an available server mainframe.
{
{ STATUS: (output) This is the record that contains the status of the request.
{       CONDITIONS:
{             jme$maximum_jobs
*DECK DECK=QFH$REBUILD_OUTPUT_QUEUE EXPAND=FALSE
{
{    The purpose of this request is to alter the Known Output List (KOL) by
{ adding an entry that signifies the existence of a possible candidate for
{ disposition.  This information is regained from the file's system label
{ during a continuation deadstart of NOS/VE.
{
{       QFP$REBUILD_OUTPUT_QUEUE (SYSTEM_LABEL, EARLIEST_CLOCK_TIME_TO_PRINT,
{             LATEST_CLOCK_TIME_TO_PRINT, PURGE_DELAY_CLOCK_TIME,
{             CURRENT_CLOCK_TIME, STATUS);
{
{ SYSTEM_LABEL: (input)  This is the system label for the file being recovered.
{
{ EARLIEST_CLOCK_TIME_TO_PRINT: (input)  This is the microsecond clock value at
{       which the file will become a candidate for disposition.
{
{ LATEST_CLOCK_TIME_TO_PRINT: (input)  This is the microsecond clock value at
{       which the file will expire and be deleted from the output queue.
{
{ PURGE_DELAY_CLOCK_TIME: (input)  This is the microsecond clock value for the
{       time that a file that has been disposed should be deleted from the
{       output queue.  If the file has not disposed this will be zero.
{
{ CURRENT_CLOCK_TIME: (input)  This is the current microsecond clock value.
{
{ STATUS: (output) This is the record that contains the status of the request.
{       CONDITIONS:
{             jme$maximum_output
*DECK DECK=QFH$REGISTER_INPUT_APPLICATION EXPAND=FALSE
{
{    The purpose of this request is to register an application that is capable
{  of removing jobs from the NOS/VE input queue.  The essence of the
{  application being registered is placed in the application table in the
{  Known Job List (KJL).
{
{        QFP$REGISTER_INPUT_APPLICATION (APPLICATION_NAME, DESTINATION_USAGE,
{              PASSWORD, STATUS);
{
{ APPLICATION_NAME: (input) This is the name of the application requesting
{        access to the NOS/VE input queue.
{
{ DESTINATION_USAGE: (input) This is the destination_usage of the jobs that
{        the application is requesting access to.  It will only have
{        access to jobs with this destination_usage.
{
{ PASSWORD: (input) This is a password that is required by the application when
{        it attempts to open a job file in the input queue.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{        jme$application_table_is_full
{        jme$destination_usage_in_use
*DECK DECK=QFH$REGISTER_JOB_LEVELER EXPAND=FALSE
{
{    The purpose of this request is to register a client's job leveler task
{ with NOS/VE queue file management.
{
{    QFP$REGISTER_JOB_LEVELER;
*DECK DECK=QFH$REGISTER_OUTPUT_APPLICATION EXPAND=FALSE
{
{    The purpose of this request is to register an application that is capable
{  of removing files from the NOS/VE output queue.  The essence of the
{  application being registered is placed in the application table in the
{  Known Output List (KOL).
{
{        QFP$REGISTER_OUTPUT_APPLICATION (APPLICATION_NAME, DESTINATION_USAGE,
{              PASSWORD, STATUS);
{
{ APPLICATION_NAME: (input) This is the name of the application requesting
{        access to the NOS/VE output queue.
{
{ DESTINATION_USAGE: (input) This is the destination_usage of the output files
{        that the application is requesting access to.  It will only have
{        access to files with this destination_usage.
{
{ PASSWORD: (input) This is a password that is required by the application when
{        it attempts to open a file in the output queue.
{
{ STATUS: (output) This is the status of the request.
{      IDENTIFIER:
{        'JM'
{      CONDITIONS:
{        jme$application_table_is_full
{        jme$destination_usage_in_use
*DECK DECK=QFH$REGISTER_QFILE_APPLICATION EXPAND=FALSE
{
{    The purpose of this request is to register an application that is capable
{ of removing files from the NOS/VE generic queue.  The essence of the
{ application being registered is placed in the application table in the Known
{ Qfile List (KQL).
{
{       QFP$REGISTER_QFILE_APPLICATION (APPLICATION_NAME,
{             REGISTRATION_OPTIONS_P, PASSWORD, STATUS);
{
{ APPLICATION_NAME: (input)  This is the name of the application requesting
{       access to the NOS/VE generic queue.
{
{ REGISTRATION_OPTIONS_P: (input)  These options specify how the application
{       and the generic queue file manager work together.
{
{ PASSWORD: (input)  This is a password that is required by the application
{       when it attempts to open a file in the generic queue.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{        jme$application_table_is_full
{        jme$application_name_in_use
*DECK DECK=QFH$RELEASE_GENERIC_QUEUE_FILES EXPAND=FALSE
{
{    The purpose of this request is to retrieve the information necessary to
{ release the generic queue files for a particular application.  The files
{ returned in the release list should be deleted from the queue.
{
{       QFP$RELEASE_GENERIC_QUEUE_FILES (RELEASE_FILE_LIST,
{             RELEASE_FILE_COUNT);
{
{ RELEASE_FILE_LIST: (input, output)  This list identifies the queue files to
{       be released.
{
{ RELEASE_FILE_COUNT: (output)  This indicates the number of files that need to
{       be released.
{
{
*DECK DECK=QFH$RELEASE_INPUT_FILES EXPAND=FALSE
{
{    The purpose of this request is to retrieve the information necessary to
{  release the input files for a particular application.  The files returned
{  in the release list should be deleted from the input queue.
{
{        QFP$RELEASE_INPUT_FILES (RELEASE_FILE_LIST, RELEASE_FILE_COUNT);
{
{ RELEASE_FILE_LIST: (output) This list identifies the input files to be
{        released.
{
{ RELEASE_FILE_COUNT: (output) This indicates the number of files that need
{        to be released.

*DECK DECK=QFH$RELEASE_OUTPUT_FILES EXPAND=FALSE
{
{    The purpose of this request is to retrieve the information necessary to
{  release the output files for a particular application.  The files returned
{  in the release list should be deleted from the output queue.
{
{        QFP$RELEASE_OUTPUT_FILES (RELEASE_FILE_LIST, RELEASE_FILE_COUNT,
{              STATUS);
{
{ RELEASE_FILE_LIST: (input, output) This list identifies the output files to be
{        released.
{
{ RELEASE_FILE_COUNT: (output) This indicates the number of files that need
{        to be released.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{        none.

*DECK DECK=QFH$RELINK_KJL_APPLICATION EXPAND=FALSE
{
{    The purpose of this request is to relink a Known Job List (KJL) entry
{  from one application state thread to another.
{
{        QFP$RELINK_KJL_APPLICATION (KJL_INDEX, DESTINATION_APPLICATION_INDEX,
{              DESTINATION_STATE);
{
{ KJL_INDEX: (input) This is the index of the KJL entry to be relinked.
{
{ DESTINATION_APPLICATION_INDEX: (input) This is the index of the application
{        that owns the job.  The application table is part of the KJL.
{
{ DESTINATION_STATE: (input) This is the state the job is to be in with respect
{        to the application.
{
*DECK DECK=QFH$RELINK_KJL_CLIENT EXPAND=FALSE
{
{    The purpose of this request is to relink a job to a particular client
{ thread in the Known Job List (KJL).
{
{       QFP$RELINK_KJL_CLIENT (KJL_INDEX, DESTINATION_CLIENT_INDEX);
{
{ KJL_INDEX: (input)  This is the index of the KJL entry to be relinked.
{
{ DESTINATION_CLIENT_INDEX: (input)  This is the client mainframe to which this
{       job is to be relinked.
*DECK DECK=QFH$RELINK_KJL_ENTRY EXPAND=FALSE
{
{    The purpose of this request is to "rethread" an entry in the Known Job
{ List (KJL) to the specified destination thread.
{
{       QFP$RELINK_KJL_ENTRY (KJL_INDEX, DESTINATION_JOB_CLASS,
{             DESTINATION_ENTRY_KIND);
{
{ KJL_INDEX: (input)  This signifies which entry in the KJL to "rethread".
{
{ DESTINATION_JOB_CLASS: (input)  This signifies the job class in which which
{       the KJL entry should be placed.
{
{ DESTINATION_ENTRY_KIND: (input)  This signifies where the KJL entry is to be
{       placed.
{
*DECK DECK=QFH$RELINK_KJL_SERVER EXPAND=FALSE
{
{    The purpose of this request is to relink a job to a particular server
{ thread in the Known Job List (KJL).
{
{       QFP$RELINK_KJL_SERVER (KJL_INDEX, DESTINATION_SERVER_INDEX);
{
{ KJL_INDEX: (input)  This is the index of the KJL entry to be relinked.
{
{ DESTINATION_SERVER_INDEX: (input)  This is the server mainframe to which this
{       job is to be relinked.
*DECK DECK=QFH$REMOVE_JOB_FROM_KJL EXPAND=FALSE
{
{    The purpose of this request is to remove a specific job from the Known Job
{ List (KJL).
{
{       QFP$REMOVE_JOB_FROM_KJL (SYSTEM_JOB_NAME);
{
{ SYSTEM_JOB_NAME: (input)  This is the system job name of the job to be
{       removed from the KJL.
*DECK DECK=QFH$SERVER_JOB_BEGIN EXPAND=FALSE
{    The purpose of this request is to update the KJL entry of a job that is
{ executing on a mainframe other than the server.
{
{       QFP$SERVER_JOB_BEGIN (JOB_BEGIN_INFORMATION, JOB_TERMINATED,
{             LOGIN_FAMILY);
{
{ JOB_BEGIN_INFORMATION: (input)  This describes the job to the server
{       mainframe.
{
{ JOB_TERMINATED: (output)  This indicates if the job has been terminated.
{
{ LOGIN_FAMILY: (output)  This is the login family of the job.
*DECK DECK=QFH$SERVER_JOB_END EXPAND=FALSE
{
{    The purpose of this request is to perform the job end cleanup of a job
{ that is executing on a client mainframe.  Currently, this request simply
{ removes the job's Known Job List (KJL) entry from the server KJL.
{
{       QFP$SERVER_JOB_END (JOB_END_INFORMATION);
{
{ JOB_END_INFORMATION: (input)  This is the information required to perform the
{       job end cleanup on the server mainframe.
*DECK DECK=QFH$SET_FAMILY_UNAVAILABLE EXPAND=FALSE
{    The purpose of this request is to set the job's Known Job List flag for
{ the login family availability to FALSE.
{
{        QFP$SET_FAMILY_UNAVAILABLE;
*DECK DECK=QFH$SET_INPUT_COMPLETED EXPAND=FALSE
{
{    The purpose of this request is to indicate that the disposition of an
{ input file in the NOS/VE input queue has completed.  The result is registered
{ in the Known Job List and the appropriate action is taken based on whether
{ the file was disposed of successfully or not.
{
{       QFP$SET_INPUT_COMPLETED (INPUT_DESTINATION_USAGE, SYSTEM_JOB_NAME,
{             COMPLETED_SUCCESSFULLY, DELETE_INPUT_FILE, STATUS);
{
{ INPUT_DESTINATION_USAGE: (input)  This is the destination_usage of the input
{       file that has been disposed of.
{
{ SYSTEM_JOB_NAME: (input)  This is the system_job_name that was assigned to
{       the input file when it was placed in the NOS/VE input queue.
{
{ COMPLETED_SUCCESSFULLY: (input)  This indicates if the file was disposed of
{       successfully or not.
{
{ DELETE_INPUT_FILE: (output)  This indicates that the file has been removed
{       from the KJL and that it should be deleted from the input queue.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$application_not_permitted
{             jme$destination_usage_incorrect
{             jme$name_not_found
*DECK DECK=QFH$SET_INPUT_INITIATED EXPAND=FALSE
{
{    The purpose of this request is to mark the Known_Job_List (KJL) to
{  indicate that the indicated file is about to be "disposed of."
{
{        QFP$SET_INPUT_INITIATED (INPUT_DESTINATION_USAGE, SYSTEM_JOB_NAME,
{              STATUS);
{
{ INPUT_DESTINATION_USAGE: (input) This indicates what the destination_usage
{        of the input file is.
{
{ SYSTEM_JOB_NAME: (input) This is the name of the input file.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{        jme$name_not_found
{        jme$input_cannot_initiate
*DECK DECK=QFH$SET_INTERACTIVE_JRD_JAD EXPAND=FALSE
{    The purpose of this request is to set an interactive job's job abort and
{ job recovery disposition to the requested values.  The values at job startup
{ for interactive jobs are set to not recover the job.
{
{        QFP$SET_INTERACTIVE_JRD_JAD;
{
*DECK DECK=QFH$SET_JOB_ATTRIBUTES EXPAND=FALSE
{
{   The purpose of this request is to set the values of the ring one job
{ attribute structures.
{
{        QFP$SET_JOB_ATTRIBUTES (ATTRIBUTE_VALUE, STATUS);
{
{ ATTRIBUTE_VALUE: (input) This indicates the attribute to change and what
{        the new value should be.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{        none.
*DECK DECK=QFH$SET_JOB_CLASS_LIMITS EXPAND=FALSE
{
{    The purpose of this request is to select the limit of the maximum
{  number of initiated jobs in a particular set of job classes.
{
{        QFP$SET_JOB_CLASS_LIMITS (JOB_CLASS_SET, CLASS_LIMIT_VALUE);
{
{ JOB_CLASS_SET: (input) This is the set of job class whose values are to be altered.
{
{ CLASS_LIMIT_VALUE: (input) This is the limit imposed on the classes in JOB_CLASS_SET.
*DECK DECK=QFH$SET_JOB_RESTART EXPAND=FALSE
{
{   The purpose of this request is to make a job restart when it terminates.
{
{        QFP$SET_JOB_RESTART;
*DECK DECK=QFH$SET_LEVELER_READY EXPAND=FALSE
{
{    The purpose of this request is to set the job leveler readied flag to
{ indicate if the leveler should execute or not.
{
{       QFP$SET_LEVELER_READY (READY_LEVELER);
{
{ READY_LEVELER: (input)  This indicates if the leveler readied flag should be
{       TRUE or FALSE.
{
*DECK DECK=QFH$SET_OUTPUT_COMPLETED EXPAND=FALSE
{
{    The purpose of this request is to indicate that the disposition of an
{ output file in the NOS/VE output queue has completed.  The result is
{ registered in the Known Output List and the appropriate action is taken based
{ on whether the file was disposed of successfully or not.
{
{       QFP$SET_OUTPUT_COMPLETED (OUTPUT_DESTINATION_USAGE, SYSTEM_FILE_NAME,
{             COMPLETED_SUCCESSFULLY, PURGE_DELAY_CLOCK_TIME,
{             CURRENT_CLOCK_TIME, DELETE_OUTPUT_FILE, SYSTEM_JOB_NAME, STATUS);
{
{ OUTPUT_DESTINATION_USAGE: (input)  This is the destination_usage of the
{       output file that has been disposed of.
{
{ SYSTEM_FILE_NAME: (input)  This is the system_file_name that was assigned to
{       the output file when it was placed in the NOS/VE output queue.
{
{ COMPLETED_SUCCESSFULLY: (input)  This indicates if the file was disposed of
{       successfully or not.
{
{ PURGE_DELAY_CLOCK_TIME: (input)  This is the microsecond clock value at which
{       the file will expire from the output queue.
{
{ CURRENT_CLOCK_TIME: (input)  This is the current microsecond clock value.
{
{ DELETE_OUTPUT_FILE: (output)  This indicates whether or not the file should
{       be removed from the output queue or not.
{
{ SYSTEM_JOB_NAME: (output)  This is the system_job_name of the job that had
{       placed the file in the NOS/VE output queue.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$application_not_permitted
{             jme$destination_usage_incorrect
{             jme$name_not_found
*DECK DECK=QFH$SET_OUTPUT_INITIATED EXPAND=FALSE
{
{    The purpose of this request is to mark the Known_Output_List (KOL) to
{  indicate that the indicated file is about to be "disposed of."
{
{        QFP$SET_OUTPUT_INITIATED (OUTPUT_DESTINATION_USAGE, SYSTEM_FILE_NAME,
{              SYSTEM_JOB_NAME, STATUS);
{
{ OUTPUT_DESTINATION_USAGE: (input) This indicates what the destination_usage
{        of the output file is.
{
{ SYSTEM_FILE_NAME: (input) This is the name of the output file.
{
{ SYSTEM_JOB_NAME: (output) This is the system_job_name of the job that had
{        placed the file in the NOS/VE output queue.
{
{ STATUS: (output) This is the status of the request.
{      IDENTIFIER:
{        'JM'
{      CONDITIONS:
{        jme$name_not_found
{        jme$output_cannot_initiate
*DECK DECK=QFH$SET_QFILE_COMPLETED EXPAND=FALSE
{
{    The purpose of this request is to indicate that the disposition of a file
{ in the NOS/VE generic queue has completed.  The result is registered in the
{ Known Qfile List and the appropriate action is taken based on whether the
{ file was disposed of successfully or not.
{
{       QFP$SET_QFILE_COMPLETED (APPLICATION_NAME, SYSTEM_FILE_NAME,
{             COMPLETED_SUCCESSFULLY, PURGE_DELAY_CLOCK_TIME,
{             CURRENT_CLOCK_TIME, DELETE_QFILE, STATUS);
{
{ APPLICATION_NAME: (input)  This is the application_name of the queue file
{       that has been disposed of.
{
{ SYSTEM_FILE_NAME: (input)  This is the system_file_name that was assigned to
{       the file when it was placed in the NOS/VE generic queue.
{
{ COMPLETED_SUCCESSFULLY: (input)  This indicates if the file was disposed of
{       successfully or not.
{
{ PURGE_DELAY_CLOCK_TIME: (input)  This is the microsecond clock value at which
{       the file will expire from the generic queue.
{
{ CURRENT_CLOCK_TIME: (input)  This is the current microsecond clock value.
{
{ DELETE_QFILE: (output)  This indicates whether or not the file should be
{       removed from the generic queue or not.
{
{ STATUS: (output) This is the status of the request.
{       CONDITIONS:
{             jme$qfile_appl_not_permitted
{             jme$application_name_incorrect
{             jme$name_not_found
*DECK DECK=QFH$SET_QFILE_INITIATED EXPAND=FALSE
{
{    The purpose of this request is to mark the Known Qfile List (KQL) to
{ indicate that the indicated file is about to be "disposed of."
{
{       QFP$SET_QFILE_INITIATED (APPLICATION_NAME, SYSTEM_FILE_NAME, STATUS);
{
{ APPLICATION_NAME: (input)  This indicates what the application_name of the
{       queue file is.
{
{ SYSTEM_FILE_NAME: (input)  This is the name of the queue file.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{        jme$name_not_found
{        jme$qfile_cannot_initiate
*DECK DECK=QFH$SET_TERMINAL_NAME EXPAND=FALSE
{
{    The purpose of this procedure is to set the terminal name of the
{ requesting job to the specified terminal name.
{
{       QFP$SET_TERMINAL_NAME (TERMINAL_NAME);
{
{ TERMINAL_NAME: (input)  This parameter specifies the new terminal name to be
{       assigned to the requesting job.
{
*DECK DECK=QFH$SUBMIT_JOB EXPAND=FALSE
{
{    The purpose of this request is to alter the Known Job List (KJL) by adding
{ an entry that may be a candidate for initiation.
{
{       QFP$SUBMIT_JOB (SYSTEM_LABEL, JOB_CLASS,
{             EARLIEST_CLOCK_TIME_TO_INITIATE, LATEST_CLOCK_TIME_TO_INITIATE,
{             CURRENT_CLOCK_TIME, JOB_SUBMISSION_TIME,
{             IMMEDIATE_INITIATION_CANDIDATE, INPUT_FILE_LOCATION,
{             VALID_MAINFRAME_SET, STATUS)
{
{ SYSTEM_LABEL: (input)  This is the record that contains the data necessary to
{       create a new entry in the KJL.
{
{ JOB_CLASS: (input)  This is the job class of the job.
{
{ EARLIEST_CLOCK_TIME_TO_INITIATE: (input)  This is a microsecond clock value
{       that must be exceeded before the job can become a candidate for
{       initiation.
{
{ LATEST_CLOCK_TIME_TO_INITATE: (input)  This is a microsecond clock value that
{       signifies the "latest" microsecond clock value at which the job can
{       become a candidate for successful initiation.
{
{ CURRENT_CLOCK_TIME: (input)  This is the value of the microsecond clock at
{       the time the job was submitted.
{
{ JOB_SUBMISSION_TIME: (input)  This is the microsecond clock value of the time
{       at which the job was submitted.  This value may be negative.
{
{ IMMEDIATE_INITIATION_CANDIDATE: (input)  This is a flag that indicates if the
{       job is a candidate for immediate initiation.
{
{ INPUT_FILE_LOCATION: (input)  This indicates the physical location of the
{       job's input file.
{
{ VALID_MAINFRAME_SET: (input)  This is the set of mainframes on which the job
{       can execute.
{
{ STATUS: (output) This is the record that contains the status of the request.
{       CONDITIONS:
{             jme$maximum_jobs
{             jme$scheduling_profile_changed
*DECK DECK=QFH$SUBMIT_QFILE EXPAND=FALSE
{
{    The purpose of this request is to update the Known Qfile List (KQL) by
{ adding another candidate for disposition.
{
{       QFP$SUBMIT_QFILE (SYSTEM_LABEL, EARLIEST_CLOCK_TIME_TO_PROCESS,
{             LATEST_CLOCK_TIME_TO_PROCESS, CURRENT_CLOCK_TIME, STATUS);
{
{ SYSTEM_LABEL: (input)  This is the system label for the queue file.
{
{ EARLIEST_CLOCK_TIME_TO_PROCESS: (input)  This is the microsecond clock value
{       at which the file becomes a candidate for disposition.
{
{ LATEST_CLOCK_TIME_TO_PROCESS: (input)  This is the microsecond clock value at
{       which the file expires and should be removed from the generic queue.
{
{ CURRENT_CLOCK_TIME: (input)  This is the current microsecond clock value.
{
{ STATUS: (output) This is the record that contains the status of the request.
{       CONDITIONS:
{             jme$maximum_generic_qfiles
*DECK DECK=QFH$TERMINATE_ACQUIRED_INPUT EXPAND=FALSE
{
{    The purpose of this request is to find an input file that has been
{  terminated and return the file's name to the requestor.  This request
{  also discards any queued-file essence of the file in the KJL.
{
{        QFP$TERMINATE_ACQUIRED_INPUT (INPUT_DESTINATION_USAGE,
{              SYSTEM_JOB_NAME, DELETE_INPUT_FILE, STATUS);
{
{ INPUT_DESTINATION_USAGE: (input) This indicates what the destination_usage
{        of the file is that the requestor is interested in.
{
{ SYSTEM_JOB_NAME: (output) This is the file that has been terminated.
{
{ DELETE_INPUT_FILE: (output) This indicates if the entry was removed from
{        the Known_Job_List (KJL) - if so, the input file must be deleted.
{
{ STATUS: (output) This is the status of the request
{      IDENTIFIER:
{        'JM'
{      CONDITIONS:
{        jme$input_queue_is_empty
*DECK DECK=QFH$TERMINATE_ACQUIRED_OUTPUT EXPAND=FALSE
{
{    The purpose of this request is to find an output file that has been
{  terminated and return the file's name to the requestor.  This request
{  also discards any queued-file essence of the file in the KOL.
{
{        QFP$TERMINATE_ACQUIRED_OUTPUT (OUTPUT_DESTINATION_USAGE,
{              SYSTEM_FILE_NAME, SYSTEM_JOB_NAME, DELETE_OUTPUT_FILE, STATUS);
{
{ OUTPUT_DESTINATION_USAGE: (input) This indicates what the destination_usage
{        of the file is that the requestor is interested in.
{
{ SYSTEM_FILE_NAME: (output) This is the file that has been terminated.
{
{ SYSTEM_JOB_NAME: (output) This is the system_job_name of the job that placed
{        the file in the NOS/VE output queue.
{
{ DELETE_OUTPUT_FILE: (output) This indicates if the entry was removed from
{        the Known_Output_List (KOL) - if so, the output file must be deleted.
{
{ STATUS: (output) This is the status of the request
{      CONDITIONS:
{        jme$output_queue_is_empty
*DECK DECK=QFH$TERMINATE_ACQUIRED_QFILE EXPAND=FALSE
{
{    The purpose of this request is to find a generic queue file that has been
{ terminated and return the file's name to the requestor.  This request also
{ discards any queued-file essence of the file in the KQL.
{
{       QFP$TERMINATE_ACQUIRED_QFILE (APPLICATION_NAME, SYSTEM_FILE_NAME,
{             DELETE_QFILE, STATUS);
{
{ APPLICATION_NAME: (input)  This indicates the application_name of the file
{       that the requestor is interested in.
{
{ SYSTEM_FILE_NAME: (output)  This is the file that has been terminated.
{
{ DELETE_QFILE: (output)  This indicates if the entry was removed from the
{       Known Qfile List (KQL) - if so, the queue file must be deleted.
{
{ STATUS: (output) This is the status of the request
{      CONDITIONS:
{        jme$generic_queue_is_empty
*DECK DECK=QFH$TERMINATE_JOB EXPAND=FALSE
{
{    The purpose of this request is to terminate a job.
{
{       QFP$TERMINATE_JOB (SYSTEM_JOB_NAME, JOB_STATE_SET,
{             OUTPUT_DISPOSITION_KEY_KNOWN, OUTPUT_DISPOSITION_KEY,
{             OPERATOR_JOB, FAMILY_NAME, DELETE_INPUT_FILE,
{             INPUT_FILE_LOCATION, JOB_ASSIGNED_TO_CLIENT, CLIENT_MAINFRAME_ID,
{             STATUS);
{
{ SYSTEM_JOB_NAME: (input)  This is the system job name of the job being
{       terminated.
{
{ JOB_STATE_SET: (input)  This is a set containing the state the job must be in
{       to terminate.
{
{ OUTPUT_DISPOSITION_KEY_KNOWN: (input)  This indicates if the parameter
{       output_disposition_key is valid.
{
{ OUTPUT_DISPOSITION_KEY: (input)  This indicates if the job's output should be
{       discarded or not.
{
{ OPERATOR_JOB: (input)  Indicates whether or not the terminate job request
{       originated from an operator job (versus a user job).
{
{ FAMILY_NAME: (output)  This is the family name of the job that was
{       terminated.
{
{ DELETE_INPUT_FILE: (output)  This indicates whether or not the caller should
{       delete the job input file or not.
{
{ INPUT_FILE_LOCATION: (output)  This is the input queue in which the
{       terminated job was resident.
{
{ JOB_ASSIGNED_TO_CLIENT: (output)  This indicates if the job has been assigned
{       to a client mainframe.
{
{ CLIENT_MAINFRAME_ID: (output)  This indicates the job's client mainframe
{       identifier for a job that has been assigned to a client mainframe.
{       This parameter is only valid if the parameter job_assigned_to_client is
{       TRUE.
{
{ STATUS: (output) This is the record that contains the status of the request.
{       CONDITIONS:
{             jme$job_forced_out_of_memory
{             jme$job_has_a_hung_task
{             jme$name_not_found
*DECK DECK=QFH$TERMINATE_OUTPUT EXPAND=FALSE
{
{    The purpose of this request is discard an output file.
{
{       QFP$TERMINATE_OUTPUT (SYSTEM_FILE_NAME, OUTPUT_STATE_SET,
{             SYSTEM_JOB_NAME, OUTPUT_DESTINATION_USAGE, DELETE_OUTPUT_FILE,
{             STATUS);
{
{ SYSTEM_FILE_NAME: (input)  This is the name of the file to terminate.
{
{ OUTPUT_STATE_SET: (input)  This is a set containing the state the file must
{       be in to terminate.
{
{ SYSTEM_JOB_NAME: (output)  This is the system_job_name of the job that placed
{       the file in the NOS/VE output queue.
{
{ OUTPUT_DESTINATION_USAGE: (output)  This is the output destination usage of
{       file being deleted from the output queue.
{
{ DELETE_OUTPUT_FILE: (output)  This indicates whether or not the caller should
{       delete the file from the output queue.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        jme$name_not_found
{        jme$output_already_terminated
*DECK DECK=QFH$TERMINATE_QFILE EXPAND=FALSE
{
{    The purpose of this request is discard a generic queue file.
{
{       QFP$TERMINATE_QFILE (SYSTEM_FILE_NAME, QFILE_STATE_SET,
{             DELETE_QFILE, STATUS);
{
{ SYSTEM_FILE_NAME: (input)  This is the name of the file to terminate.
{
{ QFILE_STATE_SET: (input)  This is a set containing the state the file must be
{       in to terminate.
{
{ DELETE_QFILE: (output)  This indicates whether or not the caller should
{       delete the file from the queue.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITIONS:
{        jme$name_not_found
{        jme$qfile_already_terminated
*DECK DECK=QFH$UNASSIGN_CLIENT_JOBS EXPAND=FALSE
{
{    The purpose of this request is to "unassign" a list of jobs from a client
{ mainframe.
{
{       QFP$UNASSIGN_CLIENT_JOBS (CLIENT_MAINFRAME_ID, UNASSIGNED_JOB_LIST_P);
{
{ CLIENT_MAINFRAME_ID: (input)  This is the binary mainframe identifier of the
{       client mainframe.
{
{ UNASSIGNED_JOB_LIST_P: (input)  This is the list of jobs to unassign.
{
*DECK DECK=QFH$UNASSIGN_SERVER_JOBS EXPAND=FALSE
{
{    The purpose of this request is to remove jobs from the client's Known Job
{ List (KJL).
{
{       QFP$UNASSIGN_SERVER_JOBS (SERVER_MAINFRAME_ID, UNASSIGN_ALL_JOBS,
{             JOB_CLASS_PRIORITIES, UNASSIGNED_JOB_LIST_P,
{             NUMBER_OF_UNASSIGNED_JOBS);
{
{ SERVER_MAINFRAME_ID: (input)  This is the binary mainframe identifier of the
{       server mainframe.
{
{ UNASSIGN_ALL_JOBS: (input)  This indicates if all jobs should be unassigned
{       regardless of their priority.
{
{ JOB_CLASS_PRIORITIES: (input)  This is the priority of the jobs being
{       requested from the clients.
{
{ UNASSIGNED_JOB_LIST_P: (output)  This is the list of job removed from the
{       KJL.
{
{ NUMBER_OF_UNASSIGNED_JOB: (output)  This is the number of jobs that are in
{       the unassigned_job_list.
*DECK DECK=QFH$UPDATE_LAST_USED_SSN EXPAND=FALSE
{
{    The purpose of this request is to update the last system_supplied_name
{  that was assigned by NOS/VE.  The value is written to a recovery area in
{  the Recovery Deadstart File (RDF).
{
{        QFP$UPDATE_LAST_USED_SSN;
{
*DECK DECK=QFH$UPDATE_SERVER_PRIORITIES EXPAND=FALSE
{
{    The purpose of this request is to record the priority of the highest
{ priority job for each job class that is available on a server mainframe.
{
{       QFP$UPDATE_SERVER_PRIORITIES (HIGHEST_SERVER_PRIORITIES);
{
{ HIGHEST_SERVER_PRIORITIES: (input)  This is the highest priority job for each
{       job class that is available on a server mainframe.
*DECK DECK=QFH$VALIDATE_INPUT_FILE_ACCESS EXPAND=FALSE
{
{    The purpose of this request is to verify that the requesting task is
{  permitted to access the specified file in the input queue.
{
{        QFP$VALIDATE_INPUT_FILE_ACCESS (SYSTEM_JOB_NAME,
{              INPUT_DESTINATION_USAGE, QUEUE_FILE_PASSWORD,
{              FAMILY_NAME, STATUS);
{
{ SYSTEM_JOB_NAME: (input) This is the system_job_name of the file that
{        is being accessed.
{
{ INPUT_DESTINATION_USAGE: (input) This is the destination_usage of the
{        requesting application.  It must match the file's destination_usage.
{
{ QUEUE_FILE_PASSWORD: (input) This is the password assigned by queued files
{        when the application registered.
{
{ FAMILY_NAME: (output) This is the family name of the file in the input queue.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{
*DECK DECK=QFH$VALIDATE_OUTPUT_FILE_ACCESS EXPAND=FALSE
{
{    The purpose of this request is to verify that the requesting task is
{  permitted to access the specified file in the output queue.
{
{        QFP$VALIDATE_OUTPUT_FILE_ACCESS (SYSTEM_FILE_NAME,
{              OUTPUT_DESTINATION_USAGE, QUEUE_FILE_PASSWORD, STATUS);
{
{ SYSTEM_FILE_NAME: (input) This is the system_file_name of the file that
{        is being accessed.
{
{ OUTPUT_DESTINATION_USAGE: (input) This is the destination_usage of the
{        requesting application.  It must match the file's destination_usage.
{
{ QUEUE_FILE_PASSWORD: (input) This is the password assigned by queued files
{        when the application registered.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{        jme$application_not_permitted
{        jme$destination_usage_incorrect
{        jme$name_not_found
*DECK DECK=QFH$VALIDATE_QFILE_ACCESS EXPAND=FALSE
{
{    The purpose of this request is to verify that the requesting task is
{ permitted to access the specified file in the generic queue.
{
{       QFP$VALIDATE_QFILE_ACCESS (SYSTEM_FILE_NAME, APPLICATION_NAME,
{             QUEUE_FILE_PASSWORD, STATUS);
{
{ SYSTEM_FILE_NAME: (input)  This is the system_file_name of the file that is
{       being accessed.
{
{ APPLICATION_NAME: (input)  This is the application_name of the requesting
{       application.  It must match the file's application_name.
{
{ QUEUE_FILE_PASSWORD: (input)  This is the password assigned by queued files
{       when the application registered.
{
{ STATUS: (output) This is the status of the request.
{      CONDITIONS:
{        jme$qfile_appl_not_permitted
{        jme$application_name_incorrect
{        jme$name_not_found
*DECK DECK=QFH$VERIFY_CLIENT_ASSIGNED_JOBS EXPAND=FALSE
{
{    The purpose of this request is to verify that the jobs assigned to a
{ client mainframe match the list of jobs the server believes are assigned to
{ that client.
{
{       QFP$VERIFY_CLIENT_ASSIGNED_JOBS (CLIENT_MAINFRAME_ID,
{             SERVER_JOB_LIST_P, MISSING_JOB_LIST_P, MISSING_JOB_COUNT);
{
{ CLIENT_MAINFRAME_ID: (input)  This is the binary mainframe id of the client
{       mainframe.
{
{ SERVER_JOB_LIST_P: (input)  This is a list of jobs the server has assigned to
{       the client mainframe (from the client's perspective).
{
{ MISSING_JOB_LIST_P: (output)  This is a list of jobs that were initiated on
{       the client but have been lost.
{
{ MISSING_JOB_COUNT: (output)  This is the number of jobs in the
{       missing_job_list.
*DECK DECK=QFH$VERIFY_INACTIVE_SERVER EXPAND=FALSE
{
{    The purpose of this request is to verify that the indicated server
{ mainframe does not have any uninitiated jobs in the client's Known Job List.
{ In order for a server mainframe to go inactive, all jobs must be returned to
{ the server in an orderly manner.
{
{       QFP$VERIFY_INACTIVE_SERVER (SERVER_MAINFRAME_ID, SERVER_INACTIVE);
{
{ SERVER_MAINFRAME_ID: (input)  This is the binary mainframe id of the server
{       mainframe.
{
{ SERVER_INACTIVE: (output)  This indicates whether the server is legitimately
{       inactive.

*DECK DECK=QFH$WAIT_FOR_LEVELER_DEACTIVATE EXPAND=FALSE
{
{    The purpose of this request is to wait for the job leveler tasks on the
{ requesting and all client mainframes to return jobs to the requesting
{ mainframe.  This request will wait for up to the time requested for the
{ levelers to deactivate.  If this request does not complete in the requested
{ time, leveler_deactivated is returned as FALSE.
{
{       QFP$WAIT_FOR_LEVELER_DEACTIVATE (WAIT_TIME_SEC, LEVELER_DEACTIVATED);
{
{ WAIT_TIME_SEC: (input)  This is the time in seconds that the requestor is
{       willing to wait.
{
{ LEVELER_DEACTIVATED: (output)  This indicates if the leveler deactivated or
{       not.
{
*DECK DECK=QFH$WRITE_JOB_SYSTEM_LABEL EXPAND=FALSE
{
{    The purpose of this request is to write a job's system label information
{ to the system label of the file in NOS/VE's job input queue.
{
{       QFP$WRITE_JOB_SYSTEM_LABEL (FILE_REFERENCE, WRITE_LABEL, SYSTEM_LABEL,
{             STATUS);
{
{ FILE_REFERENCE: (input)  This is the name of the file whose label is to be
{       written.
{
{ WRITE_LABEL: (input)  This specifies whether or not the system label is to be
{       written.  (The initial generation of the system label has to occur
{       before the representative file is initially opened.  The initial open
{       will cause the generated system label to be written to the file's
{       system label.  Under this circumstance, when the file has not been
{       opened, the value of WRITE_LABEL should be FALSE.  For any updates or
{       additions to the system label WRITE_LABEL should be TRUE).
{
{ SYSTEM_LABEL: (input)  This is the system label information to be written.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITION:
{           jme$write_job_system_label
*DECK DECK=QFH$WRITE_OUTPUT_SYSTEM_LABEL EXPAND=FALSE
{
{    The purpose of this request is to write an output file's system label
{ information to the system label of the file in NOS/VE's job output queue.
{
{       QFP$WRITE_OUTPUT_SYSTEM_LABEL (FILE_REFERENCE, WRITE_LABEL,
{             SYSTEM_LABEL, STATUS);
{
{ FILE_REFERENCE: (input)  This is the name of the file whose label is to be
{       written.
{
{ WRITE_LABEL: (input)  This specifies whether or not the system label is to be
{       written.  (The initial generation of the system label has to occur
{       before the representative file is initially opened.  The initial open
{       will cause the generated system label to be written to the file's
{       system label.  Under this circumstance, when the file has not been
{       opened, the value of WRITE_LABEL should be FALSE.  For any updates or
{       additions to the system label WRITE_LABEL should be TRUE).
{
{ SYSTEM_LABEL: (input)  This is the system label information to be written.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITION:
{            jme$write_output_system_label
*DECK DECK=QFH$WRITE_PRINT_SYSTEM_LABEL EXPAND=FALSE

*DECK DECK=QFH$WRITE_QFILE_SYSTEM_LABEL EXPAND=FALSE
{
{    The purpose of this request is to write a generic queue file's system
{ label information to the system label of the file in NOS/VE's generic queue.
{
{       QFP$WRITE_QFILE_SYSTEM_LABEL (FILE_REFERENCE, WRITE_LABEL,
{             SYSTEM_LABEL, APPLICATION_ATTRIBUTES_SIZE, STATUS);
{
{ FILE_REFERENCE: (input)  This is the name of the file whose label is to be
{       written.
{
{ WRITE_LABEL: (input)  This specifies whether or not the system label is to be
{       written.  (The initial generation of the system label has to occur
{       before the representative file is initially opened.  The initial open
{       will cause the generated system label to be written to the file's
{       system label.  Under this circumstance, when the file has not been
{       opened, the value of WRITE_LABEL should be FALSE.  For any updates or
{       additions to the system label WRITE_LABEL should be TRUE).
{
{ SYSTEM_LABEL: (input)  This is the system label information to be written.
{
{ APPLICATION_ATTRIBUTES_SIZE: (input) This is the size of the application
{       attributes to be written.
{
{ STATUS: (output) This is the record that contains the status of the request.
{      CONDITION:
{            jme$write_qfile_system_label
*DECK DECK=QFHZKJL EXPAND=FALSE
{
{   The purpose of this procedure is to zero out the contents of the
{  specified Known_Job_List (KJL) entry.
{
{     ZERO_OUT_KJL_ENTRY ( KJL_ENTRY )
{
{  KJL_ENTRY: (input) This parameter specifies the ordinal of the KJL entry
{                     to zero out.
{
*DECK DECK=QFM$GENERIC_QUEUE_FILE_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management: Generic Queue File Internal Interfaces' ??
MODULE qfm$generic_queue_file_manager;

{ PURPOSE:
{   This module contains the Queue File Management system core interfaces for managing files in the
{ generic queue and the Known Qfile List (KQL).
{
{ DESIGN:
{   These procedures execute in ring one and can be called from ring 3.  These procedures access
{ the ring one table: the Known Qfile List (KQL).  It is contained in mainframe pageable.  A signature
{ lock is used in order to ensure synchronous access to the KQL.
{
{ GLOSSARY:
{   AN             Application Name
{   NAN            Next Application Name

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$generic_queue_full_message
*copyc jmc$job_management_id
*copyc jmc$maximum_qfile_count
*copyc jme$application_name_in_use
*copyc jme$application_name_incorrect
*copyc jme$generic_queue_is_empty
*copyc jme$maximum_generic_qfiles
*copyc jme$qfile_already_terminated
*copyc jme$qfile_appl_not_permitted
*copyc jme$qfile_cannot_initiate
*copyc jme$queued_file_conditions
*copyc jmt$clock_time
*copyc jmt$job_attributes
*copyc jmt$known_qfile_list
*copyc jmt$known_qfile_list_entry
*copyc jmt$kql_entry_kind
*copyc jmt$kql_entry_kind_set
*copyc jmt$kql_index
*copyc jmt$name
*copyc jmt$qfile_application_attrs
*copyc jmt$qfile_attribute_options
*copyc jmt$qfile_registration_options
*copyc jmt$qfile_state
*copyc jmt$qfile_state_set
*copyc jmt$qfile_status_count
*copyc jmt$qfile_status_options
*copyc jmt$qfile_status_results
*copyc jmt$qfile_system_label
*copyc jmt$queue_file_password
*copyc jmt$rerun_disposition
*copyc jmt$results_keys
*copyc jmt$system_supplied_name
*copyc jmt$system_supplied_name_list
*copyc jmt$work_area
*copyc oss$mainframe_pageable
*copyc oss$mainframe_paged_literal
*copyc ost$byte
*copyc ost$global_task_id
*copyc ost$halfword
*copyc ost$signature_lock
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*copyc dpp$put_critical_message
*copyc osp$clear_mainframe_sig_lock
*copyc osp$monitor_fault_to_status
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$test_sig_lock
*copyc pmp$get_executing_task_gtid
*copyc pmp$ready_task
*copyc pmp$zero_out_table
*copyc syp$continue_to_cause
*copyc syp$disestablish_cond_handler
*copyc syp$establish_condition_handler
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    jmv$qfile_recovery_option: [XDCL, #GATE, oss$mainframe_pageable] ost$byte := 0,
    jmv$purge_expired_qfile_time: [XDCL, #GATE, oss$mainframe_pageable] jmt$clock_time :=
          jmc$latest_clock_time,
    jmv$purge_processed_qfile_time: [XDCL, #GATE, oss$mainframe_pageable] jmt$clock_time :=
          jmc$latest_clock_time,
    jmv$ready_deferred_qfile_time: [XDCL, #GATE, oss$mainframe_pageable] jmt$clock_time :=
          jmc$latest_clock_time,
    jmv$known_qfile_list: [XDCL, #GATE, oss$mainframe_pageable] jmt$known_qfile_list,
    jmv$kql_p: [XDCL, #GATE, oss$mainframe_pageable] ^array [1 .. * ] of jmt$known_qfile_list_entry := NIL,
    qfv$current_kql_limit: [XDCL, #GATE, oss$mainframe_pageable] jmt$kql_index := 0,
    qfv$kql_lock: [XDCL, oss$mainframe_pageable] ost$signature_lock,
    convert_state_to_entry_kind: [STATIC, READ, oss$mainframe_paged_literal] array [jmt$qfile_state] of
          jmt$kql_entry_kind := [jmc$kql_deferred_entry, jmc$kql_queued_entry, jmc$kql_initiated_entry,
          jmc$kql_terminated_entry, jmc$kql_completed_entry],
    jmv$last_used_application_index: [XDCL, #GATE, oss$mainframe_pageable] jmt$qfile_application_index :=
          jmc$unassigned_qfile_index;

?? OLDTITLE ??
?? NEWTITLE := 'expand_kql', EJECT ??

{ PURPOSE:
{   The purpose of this request is to extend the initialized portion of the
{ Known Qfile List (KQL).  If the KQL is at its limit, this request does nothing.
{
{ CAUTION:  This request cannot be performed in a loop in ring one.  If
{           several entries must be added to the KQL this request must be
{           called from ring 3.  The reason for this is because pages
{           assigned in ring 1 do not get backing store until the ring is
{           exited.  So if too many new pages are added to the KQL, memory
{           may be exhausted and the system will crash or hang.

  PROCEDURE expand_kql;

    CONST
      expand_increment = 100;

    VAR
      kql_index: jmt$kql_index,
      new_kql_limit: jmt$kql_index;

    IF qfv$current_kql_limit < jmc$maximum_qfile_count THEN
      IF qfv$current_kql_limit + expand_increment > jmc$maximum_qfile_count THEN
        new_kql_limit := jmc$maximum_qfile_count;
      ELSE
        new_kql_limit := qfv$current_kql_limit + expand_increment;
      IFEND;
      FOR kql_index := qfv$current_kql_limit + 1 TO new_kql_limit - 1 DO
        jmv$kql_p^ [kql_index].forward_link := kql_index + 1;
        jmv$kql_p^ [kql_index].reverse_link := kql_index - 1;
        jmv$kql_p^ [kql_index].entry_kind := jmc$kql_unused_entry;
      FOREND;
      jmv$kql_p^ [new_kql_limit].forward_link := jmc$kql_undefined_index;
      jmv$kql_p^ [new_kql_limit].reverse_link := new_kql_limit - 1;
      jmv$kql_p^ [new_kql_limit].entry_kind := jmc$kql_unused_entry;

      jmv$known_qfile_list.state_data [jmc$kql_unused_entry].number_of_entries :=
            jmv$known_qfile_list.state_data [jmc$kql_unused_entry].number_of_entries + new_kql_limit -
            qfv$current_kql_limit;
      IF jmv$known_qfile_list.state_data [jmc$kql_unused_entry].first_entry = jmc$kql_undefined_index THEN
        jmv$known_qfile_list.state_data [jmc$kql_unused_entry].first_entry := qfv$current_kql_limit + 1;
        jmv$kql_p^ [qfv$current_kql_limit + 1].reverse_link := jmc$kql_undefined_index;
        jmv$known_qfile_list.state_data [jmc$kql_unused_entry].last_entry := new_kql_limit;

      ELSE
        jmv$kql_p^ [qfv$current_kql_limit + 1].reverse_link := jmv$known_qfile_list.
              state_data [jmc$kql_unused_entry].last_entry;
        jmv$kql_p^ [jmv$known_qfile_list.state_data [jmc$kql_unused_entry].last_entry].forward_link :=
              qfv$current_kql_limit + 1;
        jmv$known_qfile_list.state_data [jmc$kql_unused_entry].last_entry := new_kql_limit;
      IFEND;
      qfv$current_kql_limit := new_kql_limit;
    IFEND;

  PROCEND expand_kql;
?? OLDTITLE ??
?? NEWTITLE := 'find_application_name', EJECT ??

{ PURPOSE:
{   The purpose of this request is to find the specified application_name in the application table
{ and return with the application index.  If there is no application registered with this name
{ specified the value jmc$unassigned_qfile_index is returned.
{
{ DESIGN:
{   Starting with the index of the last application assigned, search backwards through the chain until
{ the application_name is found or there are no more applications to search.
{
{ NOTES:
{   The Known Qfile List (KQL) MUST be locked when this request is made.

  PROCEDURE find_application_name
    (    application_name: ost$name;
     VAR application_index: jmt$qfile_application_index);

    application_index := jmv$last_used_application_index;

    WHILE (jmv$known_qfile_list.application_table [application_index].application_name <>
          application_name) AND (application_index <> jmc$unassigned_qfile_index) DO
      application_index := application_index - 1;
    WHILEND;
  PROCEND find_application_name;
?? OLDTITLE ??
?? NEWTITLE := 'find_qfile_by_application', EJECT ??

{ PURPOSE:
{   The purpose of this request is to find a file assigned to a particular application by using its
{ system_file_name.
{
{ DESIGN:
{   Search the Known Qfile List (KQL) for the file that has been assigned to the application specified.
{ If the entry in the KQL is not found, return a kql_index of jmc$kql_undefined_index.
{
{ NOTES:
{   The KQL must be locked when this request is issued.

  PROCEDURE find_qfile_by_application
    (    system_file_name: jmt$system_supplied_name;
         application_index: jmt$qfile_application_index;
     VAR kql_index: jmt$kql_index);

    VAR
      application_state: jmt$kql_application_state;

  /search_for_the_specified_file/
    FOR application_state := SUCC (jmc$kql_application_unused) TO UPPERVALUE (application_state) DO
      kql_index := jmv$known_qfile_list.application_table [application_index].state_data [application_state].
            first_entry;
      WHILE kql_index <> jmc$kql_undefined_index DO
        IF jmv$kql_p^ [kql_index].system_file_name = system_file_name THEN
          EXIT /search_for_the_specified_file/;
        ELSE
          kql_index := jmv$kql_p^ [kql_index].application_forward_link;
        IFEND;
      WHILEND;
    FOREND /search_for_the_specified_file/;
  PROCEND find_qfile_by_application;
?? OLDTITLE ??
?? NEWTITLE := 'kql_search', EJECT ??

{ PURPOSE:
{   The purpose of this request is to search the Known Qfile List (KQL) for the specified system_file_name
{ and returns the file's kql_index.  A kql_index of jmc$kql_undefined_index is returned if the queue file
{ is not found.
{
{ NOTES:
{   The KQL must be locked when this request is issued.

  PROCEDURE kql_search
    (    system_file_name: jmt$system_supplied_name;
         entry_kind_set: jmt$kql_entry_kind_set;
     VAR kql_index: jmt$kql_index);

    VAR
      kql_entry_kind: jmt$kql_entry_kind;

    kql_index := jmc$kql_undefined_index;

  /kql_search_each_entry_kind/
    FOR kql_entry_kind := SUCC (LOWERVALUE (kql_entry_kind)) TO UPPERVALUE (kql_entry_kind) DO
      IF kql_entry_kind IN entry_kind_set THEN
        kql_index := jmv$known_qfile_list.state_data [kql_entry_kind].first_entry;

        WHILE kql_index <> jmc$kql_undefined_index DO
          IF (jmv$kql_p^ [kql_index].system_file_name = system_file_name) THEN
            EXIT /kql_search_each_entry_kind/;
          ELSE
            kql_index := jmv$kql_p^ [kql_index].forward_link;
          IFEND;
        WHILEND;
      IFEND;
    FOREND /kql_search_each_entry_kind/;

  PROCEND kql_search;
?? OLDTITLE ??
?? NEWTITLE := 'notify_qfile_application', EJECT ??

{ PURPOSE:
{   The purpose of this request is to ready a queue file application's control task.
{
{ NOTES:
{   The Known Qfile List (KQL) should be locked when this request is issued in order to ensure that
{ the global_task_id in the KQL's application table is valid.  If it isn't, the results will be to
{ cause a task to become ready before its scheduled time.  This is not generally a problem.
{ With this in mind, it is okay to make this request without the KQL locked, but it is preferred to
{ have the structure locked.

  PROCEDURE notify_qfile_application
    (    application_index: jmt$qfile_application_index);

    VAR
      ignore_status: ost$status;

    IF application_index <> jmc$unassigned_qfile_index THEN
      pmp$ready_task (jmv$known_qfile_list.application_table [application_index].global_task_id,
            ignore_status);
    IFEND;
  PROCEND notify_qfile_application;
?? OLDTITLE ??
?? NEWTITLE := 'relink_kql_application', EJECT ??

{ PURPOSE:
{   The purpose of this request is to relink a Known Qfile List (KQL) entry from one application state
{ thread to another.
{
{ DESIGN:
{   Upon entry to the procedure, the KQL entry contains the application_name and application_state that
{ defines the application thread that the entry belongs to.  The entry is removed from this thread and
{ added to the thread described by the application_name and destination_state supplied on the request.
{
{ NOTES:
{   The KQL must be locked when this request is issued.

  PROCEDURE relink_kql_application
    (    kql_index: jmt$kql_index;
         destination_application_index: jmt$qfile_application_index;
         destination_state: jmt$kql_application_state);

    VAR
      source_state: jmt$kql_application_state,
      source_application_index: jmt$qfile_application_index;

    find_application_name (jmv$kql_p^ [kql_index].application_name, source_application_index);
    source_state := jmv$kql_p^ [kql_index].application_state;

    CASE source_state OF
    = jmc$kql_application_unused =
      ;

    ELSE

{ Delete the entry from its application thread.

      IF jmv$kql_p^ [kql_index].application_reverse_link = jmc$kql_undefined_index THEN
        jmv$known_qfile_list.application_table [source_application_index].state_data [source_state].
              first_entry := jmv$kql_p^ [kql_index].application_forward_link;
      ELSE
        jmv$kql_p^ [jmv$kql_p^ [kql_index].application_reverse_link].
              application_forward_link := jmv$kql_p^ [kql_index].application_forward_link;
      IFEND;

      IF jmv$kql_p^ [kql_index].application_forward_link = jmc$kql_undefined_index THEN
        jmv$known_qfile_list.application_table [source_application_index].state_data [source_state].
              last_entry := jmv$kql_p^ [kql_index].application_reverse_link;
      ELSE
        jmv$kql_p^ [jmv$kql_p^ [kql_index].application_forward_link].
              application_reverse_link := jmv$kql_p^ [kql_index].application_reverse_link;
      IFEND;

{ Decrement the count for the application/state thread

      jmv$known_qfile_list.application_table [source_application_index].state_data [source_state].
            number_of_entries := jmv$known_qfile_list.application_table [source_application_index].
            state_data [source_state].number_of_entries - 1;
    CASEND;


    CASE destination_state OF

    = jmc$kql_application_unused =

{ Make the entry unused.

      jmv$kql_p^ [kql_index].application_reverse_link := jmc$kql_undefined_index;
      jmv$kql_p^ [kql_index].application_forward_link := jmc$kql_undefined_index;

    ELSE

{ Insert the entry at the end of the destination thread.

      IF jmv$known_qfile_list.application_table [destination_application_index].
            state_data [destination_state].last_entry = jmc$kql_undefined_index THEN
        jmv$kql_p^ [kql_index].application_reverse_link := jmc$kql_undefined_index;
        jmv$kql_p^ [kql_index].application_forward_link := jmc$kql_undefined_index;
        jmv$known_qfile_list.application_table [destination_application_index].state_data [destination_state].
              first_entry := kql_index;
        jmv$known_qfile_list.application_table [destination_application_index].state_data [destination_state].
              last_entry := kql_index;
      ELSE
        jmv$kql_p^ [kql_index].application_reverse_link := jmv$known_qfile_list.
              application_table [destination_application_index].state_data [destination_state].last_entry;
        jmv$kql_p^ [jmv$known_qfile_list.application_table [destination_application_index].
              state_data [destination_state].last_entry].application_forward_link := kql_index;
        jmv$kql_p^ [kql_index].application_forward_link := jmc$kql_undefined_index;
        jmv$known_qfile_list.application_table [destination_application_index].state_data [destination_state].
              last_entry := kql_index;
      IFEND;

{ Increment the count of the number of entries in the state

      jmv$known_qfile_list.application_table [destination_application_index].state_data [destination_state].
            number_of_entries := jmv$known_qfile_list.application_table [destination_application_index].
            state_data [destination_state].number_of_entries + 1;
    CASEND;

    jmv$kql_p^ [kql_index].application_state := destination_state;

  PROCEND relink_kql_application;
?? OLDTITLE ??
?? NEWTITLE := 'relink_kql_entry', EJECT ??

{ PURPOSE:
{   The purpose of this request is to relink a Known Qfile List (KQL) entry from one entry state chain to
{ another.
{
{ DESIGN:
{   The entry state in the KQL entry is used to determine the state thread that the entry is currently in.
{ The entry state chain is maintained as a doubly linked list so it can be searched backwards.
{
{ NOTES:
{   The KQL must be locked when this request is issued.

  PROCEDURE relink_kql_entry
    (    kql_index: jmt$kql_index;
         destination_entry_kind: jmt$kql_entry_kind);

    VAR
      source_entry_kind: jmt$kql_entry_kind,
      insertion_index: jmt$kql_index;

    source_entry_kind := jmv$kql_p^ [kql_index].entry_kind;

{ Delete the entry from its thread

    IF jmv$kql_p^ [kql_index].reverse_link = jmc$kql_undefined_index THEN
      jmv$known_qfile_list.state_data [source_entry_kind].first_entry := jmv$kql_p^ [kql_index].forward_link;
    ELSE
      jmv$kql_p^ [jmv$kql_p^ [kql_index].reverse_link].forward_link := jmv$kql_p^ [kql_index].forward_link;
    IFEND;

    IF jmv$kql_p^ [kql_index].forward_link = jmc$kql_undefined_index THEN
      jmv$known_qfile_list.state_data [source_entry_kind].last_entry := jmv$kql_p^ [kql_index].reverse_link;
    ELSE
      jmv$kql_p^ [jmv$kql_p^ [kql_index].forward_link].reverse_link := jmv$kql_p^ [kql_index].reverse_link;
    IFEND;

{ Decrement the count of the number of entries in the state

    jmv$known_qfile_list.state_data [source_entry_kind].number_of_entries := jmv$known_qfile_list.
          state_data [source_entry_kind].number_of_entries - 1;

{ Add the entry to the destination thread

    CASE destination_entry_kind OF

    = jmc$kql_unused_entry =

{ First, zero out the entry so "clag" doesn't show up

      pmp$zero_out_table (^jmv$kql_p^ [kql_index], #SIZE (jmv$kql_p^ [kql_index]));

{ Insert in the "unused" thread.  Trace backwards to find the next previous unused entry to insert after.

      insertion_index := kql_index - 1;
      WHILE (insertion_index <> jmc$kql_undefined_index) AND
            (jmv$kql_p^ [insertion_index].entry_kind <> jmc$kql_unused_entry) DO
        insertion_index := insertion_index - 1;
      WHILEND;
      IF insertion_index = jmc$kql_undefined_index THEN

{ Insert at the "head" of the unused thread

        jmv$kql_p^ [kql_index].reverse_link := jmc$kql_undefined_index;
        jmv$kql_p^ [kql_index].forward_link := jmv$known_qfile_list.state_data [jmc$kql_unused_entry].
              first_entry;
        jmv$known_qfile_list.state_data [jmc$kql_unused_entry].first_entry := kql_index;
        IF jmv$kql_p^ [kql_index].forward_link <> jmc$kql_undefined_index THEN
          jmv$kql_p^ [jmv$kql_p^ [kql_index].forward_link].reverse_link := kql_index;
        IFEND;
      ELSE

{ Insert in the unused thread.

        jmv$kql_p^ [kql_index].reverse_link := insertion_index;
        jmv$kql_p^ [kql_index].forward_link := jmv$kql_p^ [insertion_index].forward_link;
        jmv$kql_p^ [jmv$kql_p^ [kql_index].forward_link].reverse_link := kql_index;
        jmv$kql_p^ [insertion_index].forward_link := kql_index;
      IFEND;

    ELSE

{ Insert at the end of the destination thread.

      IF jmv$known_qfile_list.state_data [destination_entry_kind].last_entry = jmc$kql_undefined_index THEN
        jmv$kql_p^ [kql_index].reverse_link := jmc$kql_undefined_index;
        jmv$kql_p^ [kql_index].forward_link := jmc$kql_undefined_index;
        jmv$known_qfile_list.state_data [destination_entry_kind].first_entry := kql_index;
        jmv$known_qfile_list.state_data [destination_entry_kind].last_entry := kql_index;
      ELSE
        jmv$kql_p^ [kql_index].reverse_link := jmv$known_qfile_list.state_data [destination_entry_kind].
              last_entry;
        jmv$kql_p^ [jmv$known_qfile_list.state_data [destination_entry_kind].last_entry].forward_link :=
              kql_index;
        jmv$kql_p^ [kql_index].forward_link := jmc$kql_undefined_index;
        jmv$known_qfile_list.state_data [destination_entry_kind].last_entry := kql_index;
      IFEND;
    CASEND;

{ Increment the count for the destination thread.

    jmv$known_qfile_list.state_data [destination_entry_kind].number_of_entries :=
          jmv$known_qfile_list.state_data [destination_entry_kind].number_of_entries + 1;

    jmv$kql_p^ [kql_index].entry_kind := destination_entry_kind;

  PROCEND relink_kql_entry;
?? OLDTITLE ??
?? NEWTITLE := 'validate_application_access', EJECT ??

{ PURPOSE:
{    This request will validate that the executing task is the legitimate user of the application_name
{  specified.  The index into the application table for the specified application_name is returned.
{
{ NOTES:
{   The Known Qfile List (KQL) must be locked when this request is issued.

  PROCEDURE validate_application_access
    (    application_name: ost$name;
     VAR application_index: jmt$qfile_application_index;
     VAR status: ost$status);

    VAR
      global_task_id: ost$global_task_id;

    status.normal := TRUE;
    find_application_name (application_name, application_index);
    IF application_index = jmc$unassigned_qfile_index THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$application_name_incorrect, application_name,
            status);
    ELSE
      pmp$get_executing_task_gtid (global_task_id);
      IF global_task_id <> jmv$known_qfile_list.application_table [application_index].global_task_id THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$qfile_appl_not_permitted, application_name,
              status);
      IFEND;
    IFEND;
  PROCEND validate_application_access;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$acquire_modified_qfile', EJECT ??
*copy qfh$acquire_modified_qfile

{ DESIGN:
{ Lock the KQL.
{ Determine if the application is valid.
{ IF valid THEN
{   IF a modified entry exists, THEN
{     Get the system_file_name of the entry.
{     Link application (AN) as ACQUIRED
{   ELSE return abnormal status jme$generic_queue_is_empty
{   IFEND
{ IFEND
{ Unlock the KQL.

  PROCEDURE [XDCL, #GATE] qfp$acquire_modified_qfile
    (    application_name: ost$name;
     VAR system_file_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      application_index: jmt$qfile_application_index,
      kql_index: jmt$kql_index;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kql_lock);

    validate_application_access (application_name, application_index, status);
    IF status.normal THEN
      kql_index := jmv$known_qfile_list.application_table [application_index].
            state_data [jmc$kql_application_modified].first_entry;
      IF kql_index <> jmc$kql_undefined_index THEN
        system_file_name := jmv$kql_p^ [kql_index].system_file_name;
        relink_kql_application (kql_index, application_index, jmc$kql_application_acquired);
      ELSE
        osp$set_status_condition (jme$generic_queue_is_empty, status);
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kql_lock);

  PROCEND qfp$acquire_modified_qfile;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$acquire_new_qfile', EJECT ??
*copyc qfh$acquire_new_qfile

{ DESIGN:
{ Lock the KQL.
{ Determine if the application is valid.
{ IF valid THEN
{   IF a new entry exists, THEN
{     Get the system_file_name of the entry.
{     Link application (AN) as ACQUIRED
{   ELSE return abnormal status jme$generic_queue_is_empty
{   IFEND
{ IFEND
{ Unlock the KQL.

  PROCEDURE [XDCL, #GATE] qfp$acquire_new_qfile
    (    application_name: ost$name;
     VAR system_file_name: jmt$system_supplied_name;
     VAR status: ost$status);


    VAR
      application_index: jmt$qfile_application_index,
      kql_index: jmt$kql_index;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kql_lock);

    validate_application_access (application_name, application_index, status);
    IF status.normal THEN
      kql_index := jmv$known_qfile_list.application_table [application_index].
            state_data [jmc$kql_application_new].first_entry;
      IF kql_index <> jmc$kql_undefined_index THEN
        system_file_name := jmv$kql_p^ [kql_index].system_file_name;
        relink_kql_application (kql_index, application_index, jmc$kql_application_acquired);
      ELSE
        osp$set_status_condition (jme$generic_queue_is_empty, status);
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kql_lock);

  PROCEND qfp$acquire_new_qfile;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$change_qfile_attributes', EJECT ??
*copyc qfh$change_qfile_attributes

{ DESIGN:
{ Lock the KQL.
{ Find the requested entry in the KQL.
{ IF the entry exists, THEN
{   Reset application name.
{   IF KQL COMPLETED THEN
{     application_name := next_application_name
{     IF purge_delay < purge_processed_qfile_time THEN
{       purge_processed_qfile_time := purge_delay
{     IFEND
{   ELSE
{     IF deferred_file AND NOT (KQL application > NEW) THEN
{       IF earliest_run_time < ready_deferred_qfile_time THEN
{         ready_deferred_qfile_time := earliest_run_time
{       IFEND
{       Link application (NAN) as UNUSED
{       application_name := next_application_name
{       Link KQL as DEFERRED
{     ELSE
{       IF KQL application > NEW THEN
{         IF (application_name = next_application_name) AND NOT deferred_file THEN
{           Link application (AN) as MODIFIED
{         ELSE
{           Link application (AN) as TERMINATED
{         IFEND
{       ELSE
{         Link KQL as QUEUED
{         Link application (NAN) as NEW
{         application_name := next_application_name
{        IFEND
{        notify the correct application
{     IFEND
{     IF latest_run_time < purge_expired_qfile_time THEN
{       purge_expired_qfile_time := latest_run_time
{     IFEND
{   IFEND
{ ELSE return abnormal status  jme$name_not_found
{ Unlock the KQL.

{ NOTES:
{   Only deferred, queued or completed files can have their attributes changed.

  PROCEDURE [XDCL, #GATE] qfp$change_qfile_attributes
    (    system_label: jmt$qfile_system_label;
         earliest_clock_time_to_process: jmt$clock_time;
         latest_clock_time_to_process: jmt$clock_time;
         purge_delay_clock_time: jmt$clock_time;
         current_clock_time: jmt$clock_time;
         rerun_disposition: jmt$rerun_disposition;
     VAR delete_queue_file: boolean;
     VAR status: ost$status);


    VAR
      deferred_file: boolean,
      entry_kind: jmt$kql_entry_kind,
      kql_index: jmt$kql_index,
      qfile_application_index: jmt$qfile_application_index,
      time_deferred_file: boolean;

    status.normal := TRUE;
    delete_queue_file := FALSE;
    osp$set_mainframe_sig_lock (qfv$kql_lock);

  /find_entry_in_kql/
    FOR entry_kind := LOWERVALUE (entry_kind) TO UPPERVALUE (entry_kind) DO
      IF entry_kind IN $jmt$kql_entry_kind_set [jmc$kql_deferred_entry, jmc$kql_queued_entry,
            jmc$kql_completed_entry] THEN
        kql_index := jmv$known_qfile_list.state_data [entry_kind].first_entry;
        WHILE (kql_index <> jmc$kql_undefined_index) DO
          IF (jmv$kql_p^ [kql_index].system_file_name = system_label.system_file_name) THEN
            EXIT /find_entry_in_kql/;
          ELSE
            kql_index := jmv$kql_p^ [kql_index].forward_link;
          IFEND;
        WHILEND;
      IFEND;
    FOREND /find_entry_in_kql/;

    IF kql_index <> jmc$kql_undefined_index THEN
      time_deferred_file := current_clock_time < earliest_clock_time_to_process;
      deferred_file := time_deferred_file OR system_label.deferred_by_application;
      jmv$kql_p^ [kql_index].next_application_name := system_label.application_name;
      jmv$kql_p^ [kql_index].earliest_clock_time_to_process := earliest_clock_time_to_process;
      jmv$kql_p^ [kql_index].latest_clock_time_to_process := latest_clock_time_to_process;
      jmv$kql_p^ [kql_index].purge_delay := purge_delay_clock_time;
      jmv$kql_p^ [kql_index].deferred_by_application := system_label.deferred_by_application;

{ If the application state is not NEW, then the file has been acquired by the application
{ In this case, if the file is deferred or the application name has changed, mark
{ the file as terminated for the application.  When the application releases the file
{ it will be placed in the proper state.

      IF (jmv$kql_p^ [kql_index].entry_kind = jmc$kql_completed_entry) AND
            (rerun_disposition = jmc$rr_no_change) THEN
        jmv$kql_p^ [kql_index].application_name := jmv$kql_p^ [kql_index].next_application_name;
        IF purge_delay_clock_time < jmv$purge_processed_qfile_time THEN
          jmv$purge_processed_qfile_time := purge_delay_clock_time;
        IFEND;
      ELSEIF (jmv$kql_p^ [kql_index].entry_kind = jmc$kql_completed_entry) AND
            (rerun_disposition = jmc$rr_discard_file) THEN
        find_application_name (jmv$kql_p^ [kql_index].application_name, qfile_application_index);
        relink_kql_application (kql_index, qfile_application_index, jmc$kql_application_unused);
        relink_kql_entry (kql_index, jmc$kql_unused_entry);
        delete_queue_file := TRUE;
      ELSE

{ The file was not processed or it was processed and rerun was requested.

        IF deferred_file AND (jmv$kql_p^ [kql_index].application_state <= jmc$kql_application_new) THEN
          IF time_deferred_file AND (earliest_clock_time_to_process < jmv$ready_deferred_qfile_time) THEN
            jmv$ready_deferred_qfile_time := earliest_clock_time_to_process;
          IFEND;
          find_application_name (jmv$kql_p^ [kql_index].next_application_name, qfile_application_index);
          relink_kql_application (kql_index, qfile_application_index, jmc$kql_application_unused);
          jmv$kql_p^ [kql_index].application_name := jmv$kql_p^ [kql_index].next_application_name;
          relink_kql_entry (kql_index, jmc$kql_deferred_entry);
        ELSE
          IF jmv$kql_p^ [kql_index].application_state > jmc$kql_application_new THEN
            find_application_name (jmv$kql_p^ [kql_index].application_name, qfile_application_index);
            IF (NOT deferred_file) AND (jmv$kql_p^ [kql_index].application_name =
                  jmv$kql_p^ [kql_index].next_application_name) THEN
              relink_kql_application (kql_index, qfile_application_index, jmc$kql_application_modified);
            ELSE
              relink_kql_application (kql_index, qfile_application_index, jmc$kql_application_terminated);
            IFEND;
          ELSE
            find_application_name (jmv$kql_p^ [kql_index].next_application_name, qfile_application_index);
            relink_kql_application (kql_index, qfile_application_index, jmc$kql_application_new);
            jmv$kql_p^ [kql_index].application_name := jmv$kql_p^ [kql_index].next_application_name;
            relink_kql_entry (kql_index, jmc$kql_queued_entry);
          IFEND;
          notify_qfile_application (qfile_application_index);
        IFEND;
        IF latest_clock_time_to_process < jmv$purge_expired_qfile_time THEN
          jmv$purge_expired_qfile_time := latest_clock_time_to_process;
        IFEND;
      IFEND;
    ELSE
      osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_label.system_file_name,
            status);
    IFEND;

    osp$clear_mainframe_sig_lock (qfv$kql_lock);
  PROCEND qfp$change_qfile_attributes;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$get_qfile_status', EJECT ??
*copy qfh$get_qfile_status

{ DESIGN:
{ Lock the KQL.
{ FOR each state DO
{   WHILE untested entries in the state exist DO
{     test entry against search criteria (options)
{     IF match THEN
{       add entry data to the result list (if it fits)
{     IFEND
{   WHILEND
{ FOREND
{ Unlock the KQL.

  PROCEDURE [XDCL, #GATE] qfp$get_qfile_status
    (    status_options_p: ^jmt$qfile_status_options;
         status_results_keys_p: ^jmt$results_keys;
     VAR status_work_area_p: ^jmt$work_area;
     VAR status_results_p: ^jmt$qfile_status_results;
     VAR number_of_qfiles_found: jmt$qfile_status_count);

    VAR
      kql_entry_kind: jmt$kql_entry_kind,
      kql_index: jmt$kql_index,
      name_value_p: ^ost$name,
      option_index: integer,
      qfile_index: integer,
      qfile_state: jmt$qfile_state,
      qfile_state_p: ^jmt$qfile_state,
      qfile_state_set: jmt$qfile_state_set,
      qualified_entry_found: boolean,
      result_index: integer,
      system_file_name_p: ^jmt$system_supplied_name;

?? NEWTITLE := 'handle_core_condition', EJECT ??

    PROCEDURE handle_core_condition
      (    monitor_fault: ost$monitor_fault;
           minimum_save_area_p: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      VAR
        lock_status: ost$signature_lock_status;

      osp$test_sig_lock (qfv$kql_lock, lock_status);
      IF lock_status = osc$sls_locked_by_current_task THEN
        osp$clear_mainframe_sig_lock (qfv$kql_lock);
      IFEND;
      syp$continue_to_cause (monitor_fault, minimum_save_area_p, syc$condition_processed, continue);
      EXIT qfp$get_qfile_status;
    PROCEND handle_core_condition;
?? OLDTITLE ??
?? EJECT ??
    syp$establish_condition_handler (^handle_core_condition);
    number_of_qfiles_found := 0;

    qfile_state_set := -$jmt$qfile_state_set [];
    IF status_options_p <> NIL THEN
      FOR option_index := 1 TO UPPERBOUND (status_options_p^) DO
        IF status_options_p^ [option_index].key = jmc$qfile_state_set THEN
          qfile_state_set := status_options_p^ [option_index].qfile_state_set;
        IFEND;
      FOREND;
    IFEND;

    osp$set_mainframe_sig_lock (qfv$kql_lock);

  /search_each_entry_kind/
    FOR qfile_state := LOWERVALUE (qfile_state) TO UPPERVALUE (qfile_state) DO
      IF qfile_state IN qfile_state_set THEN
        kql_entry_kind := convert_state_to_entry_kind [qfile_state];
        kql_index := jmv$known_qfile_list.state_data [kql_entry_kind].first_entry;

      /search_each_entry/
        WHILE kql_index <> jmc$kql_undefined_index DO
          qualified_entry_found := TRUE;
          IF status_options_p <> NIL THEN

          /status_option_check/
            FOR option_index := 1 TO UPPERBOUND (status_options_p^) DO
              CASE status_options_p^ [option_index].key OF
              = jmc$application_name =
                IF status_options_p^ [option_index].application_name <>
                      jmv$kql_p^ [kql_index].application_name THEN
                  qualified_entry_found := FALSE;
                  EXIT /status_option_check/;
                IFEND;

              = jmc$null_attribute =
                ;

              = jmc$qfile_state_set =
                ;

              = jmc$system_supplied_name_list =
                IF status_options_p^ [option_index].system_supplied_name_list <> NIL THEN
                  qualified_entry_found := FALSE;

                /search_for_qfile_names/
                  FOR qfile_index := 1 TO UPPERBOUND (status_options_p^ [option_index].
                        system_supplied_name_list^) DO
                    IF status_options_p^ [option_index].system_supplied_name_list^ [qfile_index] =
                          jmv$kql_p^ [kql_index].system_file_name THEN
                      qualified_entry_found := TRUE;
                      EXIT /search_for_qfile_names/;
                    IFEND;
                  FOREND /search_for_qfile_names/;
                  IF NOT qualified_entry_found THEN
                    EXIT /status_option_check/;
                  IFEND;
                IFEND;
              ELSE
              CASEND;
            FOREND /status_option_check/;
          IFEND;

          IF qualified_entry_found THEN
            number_of_qfiles_found := number_of_qfiles_found + 1;
            IF (status_work_area_p <> NIL) AND (status_results_keys_p <> NIL) THEN

            /fill_in_each_result_field/
              FOR result_index := 1 TO UPPERBOUND (status_results_keys_p^) DO
                CASE status_results_keys_p^ [result_index] OF

                = jmc$application_name =
                  NEXT name_value_p IN status_work_area_p;
                  IF name_value_p = NIL THEN
                    EXIT /fill_in_each_result_field/;
                  IFEND;
                  name_value_p^ := jmv$kql_p^ [kql_index].application_name;

                = jmc$null_attribute =
                  ;

                = jmc$qfile_state =
                  NEXT qfile_state_p IN status_work_area_p;
                  IF qfile_state_p = NIL THEN
                    EXIT /fill_in_each_result_field/;
                  IFEND;
                  qfile_state_p^ := qfile_state;

                = jmc$system_file_name =
                  NEXT system_file_name_p IN status_work_area_p;
                  IF system_file_name_p = NIL THEN
                    EXIT /fill_in_each_result_field/;
                  IFEND;
                  system_file_name_p^ := jmv$kql_p^ [kql_index].system_file_name;

                ELSE
                CASEND;
              FOREND /fill_in_each_result_field/;
            IFEND;
          IFEND;

          kql_index := jmv$kql_p^ [kql_index].forward_link;
        WHILEND /search_each_entry/;
      IFEND;
    FOREND /search_each_entry_kind/;

    osp$clear_mainframe_sig_lock (qfv$kql_lock);
    syp$disestablish_cond_handler;

  PROCEND qfp$get_qfile_status;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$purge_expired_queue_file', EJECT ??
*copy qfh$purge_expired_queue_file

{ DESIGN:
{ Lock the KQL.
{ purge_expired_qfile_time := latest clock time
{ file found := false
{ FOR the KQL states of DEFERRED, QUEUED, and INITIATED DO
{   WHILE untested files in the state remain DO
{     IF latest_run_time < current_microsecond_clock THEN
{       IF KQL application > NEW THEN
{         IF KQL < INITIATED THEN
{          Link application (AN) as TERMINATED
{          Notify the correct application
{         IFEND
{         Link KQL as TERMINATED
{       ELSE
{         IF NOT file found THEN
{           file found := true
{           file to delete := system_file_name
{           Link application (AN) as UNUSED
{           Link KQL as UNUSED
{         ELSE
{           purge_expired_qfile_time := latest_run_time
{         IFEND
{       IFEND
{     ELSE
{       IF latest_run_time < purge_expired_qfile_time THEN
{         purge_expired_qfile_time := latest_run_time
{       IFEND
{     IFEND
{   WHILEND
{ FOREND
{ Unlock the KQL.

  PROCEDURE [XDCL, #GATE] qfp$purge_expired_queue_file
    (VAR system_file_name_to_delete: jmt$system_supplied_name);

    VAR
      current_clock_value: jmt$clock_time,
      entry_kind: jmt$kql_entry_kind,
      kql_index: jmt$kql_index,
      next_kql_index: jmt$kql_index,
      qfile_application_index: jmt$qfile_application_index;

    system_file_name_to_delete := '';
    current_clock_value := #FREE_RUNNING_CLOCK (0);
    osp$set_mainframe_sig_lock (qfv$kql_lock);

    jmv$purge_expired_qfile_time := jmc$latest_clock_time;

  /search_for_expired_files/
    FOR entry_kind := LOWERVALUE (entry_kind) TO UPPERVALUE (entry_kind) DO
      IF entry_kind IN $jmt$kql_entry_kind_set [jmc$kql_deferred_entry, jmc$kql_queued_entry,
            jmc$kql_initiated_entry] THEN
        kql_index := jmv$known_qfile_list.state_data [entry_kind].first_entry;
        WHILE kql_index <> jmc$kql_undefined_index DO
          next_kql_index := jmv$kql_p^ [kql_index].forward_link;
          IF jmv$kql_p^ [kql_index].latest_clock_time_to_process < current_clock_value THEN
            IF jmv$kql_p^ [kql_index].application_state > jmc$kql_application_new THEN
              IF entry_kind < jmc$kql_initiated_entry THEN
                find_application_name (jmv$kql_p^ [kql_index].application_name, qfile_application_index);
                relink_kql_application (kql_index, qfile_application_index, jmc$kql_application_terminated);
                notify_qfile_application (qfile_application_index);
              IFEND;
              relink_kql_entry (kql_index, jmc$kql_terminated_entry);
            ELSE
              IF system_file_name_to_delete = '' THEN
                system_file_name_to_delete := jmv$kql_p^ [kql_index].system_file_name;
                find_application_name (jmv$kql_p^ [kql_index].application_name, qfile_application_index);
                relink_kql_application (kql_index, qfile_application_index, jmc$kql_application_unused);
                relink_kql_entry (kql_index, jmc$kql_unused_entry);
              ELSE
                jmv$purge_expired_qfile_time := jmv$kql_p^ [kql_index].latest_clock_time_to_process;
                EXIT /search_for_expired_files/;
              IFEND;
            IFEND;
          ELSE
            IF jmv$kql_p^ [kql_index].latest_clock_time_to_process < jmv$purge_expired_qfile_time THEN
              jmv$purge_expired_qfile_time := jmv$kql_p^ [kql_index].latest_clock_time_to_process;
            IFEND;
          IFEND;
          kql_index := next_kql_index;
        WHILEND;
      IFEND;
    FOREND /search_for_expired_files/;
    osp$clear_mainframe_sig_lock (qfv$kql_lock);

  PROCEND qfp$purge_expired_queue_file;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$purge_processed_queue_file', EJECT ??
*copy qfh$purge_processed_queue_file

{ DESIGN:
{ Lock the KQL.
{ purge_processed_qfile_time := latest clock time
{ file found := false
{ WHILE untested files in the COMPLETED state remain DO
{   IF purge_delay < current_microsecond_clock THEN
{     IF NOT file found THEN
{       Link KQL as UNUSED
{       file found := true
{       file_to_delete := system_file_name
{     ELSE
{       purge_processed_qfile_time := purge_delay
{     IFEND
{   ELSE
{     IF purge_delay < purge_processed_qfile_time THEN
{       purge_processed_qfile_time := purge_delay
{     IFEND
{   IFEND
{ WHILEND
{ Unlock the KQL.

  PROCEDURE [XDCL, #GATE] qfp$purge_processed_queue_file
    (VAR system_file_name_to_delete: jmt$system_supplied_name);

    VAR
      current_clock_value: jmt$clock_time,
      kql_index: jmt$kql_index,
      next_kql_index: jmt$kql_index,
      qfile_application_index: jmt$qfile_application_index;

    system_file_name_to_delete := '';
    current_clock_value := #FREE_RUNNING_CLOCK (0);
    osp$set_mainframe_sig_lock (qfv$kql_lock);

    jmv$purge_processed_qfile_time := jmc$latest_clock_time;

    kql_index := jmv$known_qfile_list.state_data [jmc$kql_completed_entry].first_entry;

  /search_for_processed_files/
    WHILE kql_index <> jmc$kql_undefined_index DO
      next_kql_index := jmv$kql_p^ [kql_index].forward_link;
      IF jmv$kql_p^ [kql_index].purge_delay < current_clock_value THEN
        IF system_file_name_to_delete = '' THEN
          system_file_name_to_delete := jmv$kql_p^ [kql_index].system_file_name;
          relink_kql_entry (kql_index, jmc$kql_unused_entry);
        ELSE
          jmv$purge_processed_qfile_time := jmv$kql_p^ [kql_index].purge_delay;
          EXIT /search_for_processed_files/;
        IFEND;
      ELSE
        IF jmv$kql_p^ [kql_index].purge_delay < jmv$purge_processed_qfile_time THEN
          jmv$purge_processed_qfile_time := jmv$kql_p^ [kql_index].purge_delay;
        IFEND;
      IFEND;
      kql_index := next_kql_index;
    WHILEND /search_for_processed_files/;
    osp$clear_mainframe_sig_lock (qfv$kql_lock);

  PROCEND qfp$purge_processed_queue_file;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$ready_deferred_queue_file', EJECT ??
*copy qfh$ready_deferred_queue_file

{ DESIGN:
{ Lock the KQL.
{ ready_deferred_qfile_time := latest_clock_time
{ WHILE untested files in the DEFERRED state remain DO
{   IF NOT deferred_by_application THEN
{     IF earliest_run_time < current_microsecond_clock THEN
{       Link KQL as QUEUED
{       Link application (AN) as NEW
{       notify the correct application
{     ELSE
{       IF earliest_run_time < ready_deferred_qfile_time THEN
{         ready_deferred_qfile_time := earliest_run_time
{       IFEND
{     IFEND
{   IFEND
{ WHILEND
{ Unlock the KQL.

  PROCEDURE [XDCL, #GATE] qfp$ready_deferred_queue_file;


    VAR
      current_clock_time: jmt$clock_time,
      kql_index: jmt$kql_index,
      next_kql_index: jmt$kql_index,
      qfile_application_index: jmt$qfile_application_index;

    current_clock_time := #FREE_RUNNING_CLOCK (0);
    osp$set_mainframe_sig_lock (qfv$kql_lock);

    jmv$ready_deferred_qfile_time := jmc$latest_clock_time;
    kql_index := jmv$known_qfile_list.state_data [jmc$kql_deferred_entry].first_entry;
    WHILE kql_index <> jmc$kql_undefined_index DO
      next_kql_index := jmv$kql_p^ [kql_index].forward_link;
      IF NOT (jmv$kql_p^ [kql_index].deferred_by_application) THEN
        IF (jmv$kql_p^ [kql_index].earliest_clock_time_to_process <= current_clock_time) THEN
          relink_kql_entry (kql_index, jmc$kql_queued_entry);
          find_application_name (jmv$kql_p^ [kql_index].application_name, qfile_application_index);
          relink_kql_application (kql_index, qfile_application_index, jmc$kql_application_new);
          notify_qfile_application (qfile_application_index);
        ELSE
          IF jmv$kql_p^ [kql_index].earliest_clock_time_to_process < jmv$ready_deferred_qfile_time THEN
            jmv$ready_deferred_qfile_time := jmv$kql_p^ [kql_index].earliest_clock_time_to_process;
          IFEND;
        IFEND;
      IFEND;
      kql_index := next_kql_index;
    WHILEND;
    osp$clear_mainframe_sig_lock (qfv$kql_lock);

  PROCEND qfp$ready_deferred_queue_file;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$rebuild_generic_queue', EJECT ??
*copy qfh$rebuild_generic_queue

{ DESIGN:
{ Lock the KQL.
{ IF there is no room in the generic queue THEN
{   expand_kql
{ IFEND
{ IF there's still no room in the generic queue THEN
{   RETURN abnormal status
{ ELSE
{   find an available KQL entry and initialize it
{   IF the file has been processed THEN
{     IF purge_delay < purge_processed_qfile_time THEN
{       purge_processed_qfile_time := purge_delay
{     IFEND
{     Link KQL as COMPLETED
{   ELSE
{     IF deferred THEN
{       IF earliest_run_time < ready_deferred_qfile_time THEN
{         ready_deferred_qfile_time := earliest_run_time
{       IFEND
{       Link KQL as DEFERRED
{     ELSE
{       Link KQL as QUEUED
{       Link application (AN) as NEW
{     IFEND
{     IF latest_run_time < purge_expired_qfile_time THEN
{       purge_expired_qfile_time := latest_run_time
{     IFEND
{   IFEND
{ IFEND
{ Unlock the KQL.
{ NOTES:
{   This is only used during deadstart.  The queue recovery process knows how many files are
{ queued on a NOS/VE system and it will always make the KQL large enough to contain them.

  PROCEDURE [XDCL, #GATE] qfp$rebuild_generic_queue
    (    system_label: jmt$qfile_system_label;
         earliest_clock_time_to_process: jmt$clock_time;
         latest_clock_time_to_process: jmt$clock_time;
         purge_delay_clock_time: jmt$clock_time;
         current_clock_time: jmt$clock_time;
     VAR status: ost$status);


    VAR
      application_index: jmt$qfile_application_index,
      kql_index: jmt$kql_index,
      time_deferred_file: boolean;

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (qfv$kql_lock);

{ Make sure that the name is not already in the KQL.

    kql_search (system_label.system_file_name, -$jmt$kql_entry_kind_set [], kql_index);
    IF kql_index <> jmc$kql_undefined_index THEN
      osp$clear_mainframe_sig_lock (qfv$kql_lock);
      osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_name, system_label.system_file_name,
            status);
      RETURN;
    IFEND;

{ Make sure that there is room in the KQL.

    IF jmv$known_qfile_list.state_data [jmc$kql_unused_entry].first_entry = jmc$kql_undefined_index THEN
      expand_kql;
    IFEND;

    IF jmv$known_qfile_list.state_data [jmc$kql_unused_entry].first_entry = jmc$kql_undefined_index THEN
      osp$set_status_condition (jme$maximum_generic_qfiles, status);
    ELSE
      kql_index := jmv$known_qfile_list.state_data [jmc$kql_unused_entry].first_entry;

      jmv$kql_p^ [kql_index].system_file_name := system_label.system_file_name;
      jmv$kql_p^ [kql_index].earliest_clock_time_to_process := earliest_clock_time_to_process;
      jmv$kql_p^ [kql_index].latest_clock_time_to_process := latest_clock_time_to_process;
      jmv$kql_p^ [kql_index].purge_delay := purge_delay_clock_time;
      jmv$kql_p^ [kql_index].application_name := system_label.application_name;
      jmv$kql_p^ [kql_index].next_application_name := system_label.application_name;
      jmv$kql_p^ [kql_index].deferred_by_application := system_label.deferred_by_application;
      jmv$kql_p^ [kql_index].application_state := jmc$kql_application_unused;

{ Has the file been processed??

      IF system_label.disposition_time.specified THEN
        IF jmv$kql_p^ [kql_index].purge_delay < jmv$purge_processed_qfile_time THEN
          jmv$purge_processed_qfile_time := jmv$kql_p^ [kql_index].purge_delay;
        IFEND;
        relink_kql_entry (kql_index, jmc$kql_completed_entry);
      ELSE
        time_deferred_file := jmv$kql_p^ [kql_index].earliest_clock_time_to_process > current_clock_time;
        IF time_deferred_file OR jmv$kql_p^ [kql_index].deferred_by_application THEN
          IF time_deferred_file AND (jmv$kql_p^ [kql_index].earliest_clock_time_to_process <
                jmv$ready_deferred_qfile_time) THEN
            jmv$ready_deferred_qfile_time := jmv$kql_p^ [kql_index].earliest_clock_time_to_process;
          IFEND;
          relink_kql_entry (kql_index, jmc$kql_deferred_entry);
        ELSE
          find_application_name (jmv$kql_p^ [kql_index].application_name, application_index);

          relink_kql_entry (kql_index, jmc$kql_queued_entry);
          relink_kql_application (kql_index, application_index, jmc$kql_application_new);
        IFEND;
        IF jmv$kql_p^ [kql_index].latest_clock_time_to_process < jmv$purge_expired_qfile_time THEN
          jmv$purge_expired_qfile_time := jmv$kql_p^ [kql_index].latest_clock_time_to_process;
        IFEND;
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kql_lock);
  PROCEND qfp$rebuild_generic_queue;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$register_qfile_application', EJECT ??
*copy qfh$register_qfile_application

{ DESIGN:
{ Lock the KQL.
{ Search the application table for the application name, saving the first available index
{ IF application name found THEN
{   RETURN abnormal status jme$application_name_in_use
{ IFEND
{ IF no room in the table THEN
{   RETURN abnormal status jme$application_table_is_full
{ ELSE
{   Update the last_used_application_index
{   WHILE untested entries exist in the unassigned application DO
{     IF the entry's application_name = application name THEN
{       Link application (AN) as NEW
{     IFEND
{   WHILEND
{   Initialize the entry in the KQL application table
{ IFEND
{ Unlock the KQL.

  PROCEDURE [XDCL, #GATE] qfp$register_qfile_application
    (    application_name: ost$name;
         registration_options_p: ^jmt$qfile_registration_options;
         password: ost$name;
     VAR status: ost$status);


    VAR
      application_index: jmt$qfile_application_index,
      first_available_index: jmt$qfile_application_index,
      kql_index: jmt$kql_index,
      next_forward_link: jmt$kql_index,
      option_index: integer;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kql_lock);

    first_available_index := jmc$unassigned_qfile_index;

  /search_for_the_application/
    FOR application_index := 1 TO jmv$last_used_application_index DO
      IF jmv$known_qfile_list.application_table [application_index].application_name = osc$null_name THEN
        IF first_available_index = jmc$unassigned_qfile_index THEN
          first_available_index := application_index;
        IFEND;

      ELSE { does the application_name match ??
        IF jmv$known_qfile_list.application_table [application_index].application_name = application_name THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$application_name_in_use, application_name,
                status);
          EXIT /search_for_the_application/;
        IFEND;
      IFEND;
    FOREND /search_for_the_application/;

    IF status.normal THEN

{ The application_name is not already in the table.  Is there room in the table??

      IF first_available_index = jmc$unassigned_qfile_index THEN
        IF jmv$last_used_application_index = UPPERBOUND (jmv$known_qfile_list.application_table) THEN
          osp$set_status_condition (jme$application_table_is_full, status);
          osp$clear_mainframe_sig_lock (qfv$kql_lock);
          RETURN;
        ELSE
          first_available_index := jmv$last_used_application_index + 1;
          jmv$last_used_application_index := jmv$last_used_application_index + 1;
        IFEND;
      IFEND;

{ Move all queue files with this application_name from the unassigned thread to this application thread.

      kql_index := jmv$known_qfile_list.application_table [jmc$unassigned_qfile_index].
            state_data [jmc$kql_application_new].first_entry;
      WHILE kql_index <> jmc$kql_undefined_index DO
        next_forward_link := jmv$kql_p^ [kql_index].application_forward_link;
        IF jmv$kql_p^ [kql_index].application_name = application_name THEN
          relink_kql_application (kql_index, first_available_index, jmc$kql_application_new);
        IFEND;
        kql_index := next_forward_link;
      WHILEND;

{ Initialize the entry in the table.  All files must be relinked before the table is initialized otherwise
{ the relink procedure will get confused with the application names.

      jmv$known_qfile_list.application_table [first_available_index].application_name := application_name;
      jmv$known_qfile_list.application_table [first_available_index].queue_file_password := password;
      pmp$get_executing_task_gtid (jmv$known_qfile_list.application_table [first_available_index].
            global_task_id);
      IF registration_options_p <> NIL THEN
        FOR option_index := 1 TO UPPERBOUND (registration_options_p^) DO
          CASE registration_options_p^ [option_index].key OF
          = jmc$notify_on_terminate =
            jmv$known_qfile_list.application_table [first_available_index].registration_options.
                  notify_on_terminate := registration_options_p^ [option_index].notify_on_terminate;
          = jmc$null_attribute =
            ;
          ELSE
          CASEND;
        FOREND;
      IFEND;
    IFEND; { status.normal
    osp$clear_mainframe_sig_lock (qfv$kql_lock);

  PROCEND qfp$register_qfile_application;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$release_generic_queue_files', EJECT ??
*copy qfh$release_generic_queue_files

{ DESIGN:
{ Initialize release_file_count to 0.
{ Lock the KQL.
{ FOR each application in the application_table DO
{   IF executing GTID matches registered GTID THEN
{     FOR each application state DO
{       WHILE entries exist in state DO
{         IF KQL TERMINATED THEN
{           add to the release file list
{           Link application (AN) as UNUSED
{           Link KQL as UNUSED
{         ELSE
{           IF deferred THEN
{             IF earliest_run_time < ready_deferred_qfile_time THEN
{               ready_deferred_qfile_time := earliest_run_time
{             IFEND
{             Link application (NAN) as UNUSED
{             Link KQL as DEFERRED
{             application_name := next_application_name
{           ELSE
{             IF application_name has not changed THEN
{               target application is unassigned
{             ELSE
{               target application is next_application_name
{             IFEND
{             Link KQL as QUEUED
{             Link application (target) as NEW
{             application_name := next_application_name
{           IFEND
{         IFEND
{       WHILEND
{     FOREND
{     zero out the entry in the application table
{   IFEND
{ FOREND
{ Update the last_used_application_index
{ Unlock the KQL.

  PROCEDURE [XDCL, #GATE] qfp$release_generic_queue_files
    (    release_file_list: ^jmt$system_supplied_name_list;
     VAR release_file_count: jmt$qfile_count_range);


    VAR
      application_index: jmt$qfile_application_index,
      application_state: jmt$kql_application_state,
      current_clock_time: jmt$clock_time,
      global_task_id: ost$global_task_id,
      kql_index: jmt$kql_index,
      next_kql_index: jmt$kql_index,
      previously_terminated: boolean,
      relink_application_index: jmt$qfile_application_index,
      release_list_limit: jmt$qfile_count_range,
      time_deferred_file: boolean;

    pmp$get_executing_task_gtid (global_task_id);

    release_file_count := 0;
    IF release_file_list = NIL THEN
      release_list_limit := 0;
    ELSE
      release_list_limit := UPPERBOUND (release_file_list^);
    IFEND;

    osp$set_mainframe_sig_lock (qfv$kql_lock);

{ Check to see if this task has queue files registered.

  /search_all_applications/
    FOR application_index := 1 TO jmv$last_used_application_index DO
      IF jmv$known_qfile_list.application_table [application_index].global_task_id = global_task_id THEN

      /search_all_application_states/
        FOR application_state := SUCC (jmc$kql_application_unused) TO UPPERVALUE (application_state) DO
          kql_index := jmv$known_qfile_list.application_table [application_index].
                state_data [application_state].first_entry;

        /release_entries_in_state/
          WHILE kql_index <> jmc$kql_undefined_index DO

{ Save the index of the next KOL entry.  When the entry is relinked, the links on the current entry
{ will no longer link to the next entry that needs to be managed.

            next_kql_index := jmv$kql_p^ [kql_index].application_forward_link;
            previously_terminated := jmv$kql_p^ [kql_index].entry_kind = jmc$kql_terminated_entry;

{ If the file was terminated, add it to the release list so the caller knows to delete the file
{ and remove the file from the KQL.

            IF previously_terminated THEN
              release_file_count := release_file_count + 1;
              IF release_file_count <= release_list_limit THEN
                release_file_list^ [release_file_count] := jmv$kql_p^ [kql_index].system_file_name;
              IFEND;
              relink_kql_application (kql_index, application_index, jmc$kql_application_unused);
              relink_kql_entry (kql_index, jmc$kql_unused_entry);
            ELSE

              time_deferred_file := jmv$kql_p^ [kql_index].earliest_clock_time_to_process >
                    current_clock_time;
              IF time_deferred_file OR jmv$kql_p^ [kql_index].deferred_by_application THEN
                IF time_deferred_file AND (jmv$kql_p^ [kql_index].earliest_clock_time_to_process <
                      jmv$ready_deferred_qfile_time) THEN
                  jmv$ready_deferred_qfile_time := jmv$kql_p^ [kql_index].earliest_clock_time_to_process;
                IFEND;
                find_application_name (jmv$kql_p^ [kql_index].next_application_name,
                      relink_application_index);
                relink_kql_application (kql_index, relink_application_index, jmc$kql_application_unused);
                jmv$kql_p^ [kql_index].application_name := jmv$kql_p^ [kql_index].next_application_name;
                relink_kql_entry (kql_index, jmc$kql_deferred_entry);
              ELSE

{ If the file's application_name hasn't changed - relink it into the unassigned chain
{ If the application_name did change, then make it available to that application

                IF jmv$kql_p^ [kql_index].application_name = jmv$kql_p^ [kql_index].next_application_name THEN
                  relink_application_index := jmc$unassigned_qfile_index;
                ELSE
                  find_application_name (jmv$kql_p^ [kql_index].next_application_name,
                        relink_application_index);
                IFEND;
                relink_kql_entry (kql_index, jmc$kql_queued_entry);
                relink_kql_application (kql_index, relink_application_index, jmc$kql_application_new);
                jmv$kql_p^ [kql_index].application_name := jmv$kql_p^ [kql_index].next_application_name;
                notify_qfile_application (relink_application_index);
              IFEND;
            IFEND;

            kql_index := next_kql_index;
          WHILEND /release_entries_in_state/;
        FOREND /search_all_application_states/;

{ Zero out the entry in the application table.  The state_data has been zeroed by the relink procedures.

        jmv$known_qfile_list.application_table [application_index].application_name := osc$null_name;
        jmv$known_qfile_list.application_table [application_index].global_task_id.index := 0;
        jmv$known_qfile_list.application_table [application_index].global_task_id.seqno := 0;
        jmv$known_qfile_list.application_table [application_index].queue_file_password := osc$null_name;
        jmv$known_qfile_list.application_table [application_index].registration_options.notify_on_terminate :=
              FALSE;

{ Update the last_used_application_index.

        IF application_index = jmv$last_used_application_index THEN
          WHILE (jmv$known_qfile_list.application_table [jmv$last_used_application_index].application_name =
                osc$null_name) AND (jmv$last_used_application_index > jmc$unassigned_qfile_index) DO
            jmv$last_used_application_index := jmv$last_used_application_index - 1;
          WHILEND;
        IFEND;
      IFEND;
    FOREND /search_all_applications/;

    osp$clear_mainframe_sig_lock (qfv$kql_lock);

  PROCEND qfp$release_generic_queue_files;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$set_qfile_completed', EJECT ??
*copy qfh$set_qfile_completed

{ DESIGN:
{ Lock the KQL.
{ Validate the application
{ IF valid THEN
{   find the file in the KQL
{   IF found THEN
{     IF completed successfully or KQL TERMINATED THEN
{       IF KQL TERMINATED or (purge_delay < current_clock_time) THEN
{         Link application (AN) as UNUSED
{         Link KQL as UNUSED
{       ELSE
{         IF purge_delay < purge_processed_qfile_time THEN
{           purge_processed_qfile_time := purge_delay
{         IFEND
{         Link application (NAN) as UNUSED
{         application_name := next_application_name
{         Link KQL as COMPLETED
{       IFEND
{     ELSE
{       IF deferred THEN
{         IF earliest_run_time < ready_deferred_qfile_time THEN
{           ready_deferred_qfile_time := earliest_run_time
{         IFEND
{         Link application (NAN) as UNUSED
{         application_name := next_application_name
{         Link KQL as DEFERRED
{       ELSE
{         Link KQL as QUEUED
{         Link application (NAN) as NEW
{         application_name := next_application_name
{         notify the correct application
{       IFEND
{     IFEND
{   ELSE
{     RETURN abnormal status jme$qfile_appl_not_permitted
{   IFEND
{ IFEND
{ Unlock the KQL.

  PROCEDURE [XDCL, #GATE] qfp$set_qfile_completed
    (    application_name: ost$name;
         system_file_name: jmt$system_supplied_name;
         completed_successfully: boolean;
         purge_delay_clock_time: jmt$clock_time;
         current_clock_time: jmt$clock_time;
     VAR delete_qfile: boolean;
     VAR status: ost$status);


    VAR
      application_index: jmt$qfile_application_index,
      kql_index: jmt$kql_index,
      previously_terminated: boolean,
      time_deferred_file: boolean;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kql_lock);

    delete_qfile := FALSE;
    validate_application_access (application_name, application_index, status);
    IF status.normal THEN
      find_qfile_by_application (system_file_name, application_index, kql_index);

      IF kql_index <> jmc$kql_undefined_index THEN
        previously_terminated := jmv$kql_p^ [kql_index].entry_kind = jmc$kql_terminated_entry;
        IF completed_successfully OR previously_terminated THEN
          IF previously_terminated OR (purge_delay_clock_time < current_clock_time) THEN
            delete_qfile := TRUE;
            relink_kql_application (kql_index, application_index, jmc$kql_application_unused);
            relink_kql_entry (kql_index, jmc$kql_unused_entry);
          ELSE
            IF purge_delay_clock_time < jmv$purge_processed_qfile_time THEN
              jmv$purge_processed_qfile_time := purge_delay_clock_time;
            IFEND;
            jmv$kql_p^ [kql_index].purge_delay := purge_delay_clock_time;
            find_application_name (jmv$kql_p^ [kql_index].next_application_name, application_index);
            relink_kql_application (kql_index, application_index, jmc$kql_application_unused);
            jmv$kql_p^ [kql_index].application_name := jmv$kql_p^ [kql_index].next_application_name;
            relink_kql_entry (kql_index, jmc$kql_completed_entry);
          IFEND;
        ELSE
          find_application_name (jmv$kql_p^ [kql_index].next_application_name, application_index);
          time_deferred_file := jmv$kql_p^ [kql_index].earliest_clock_time_to_process > current_clock_time;
          IF time_deferred_file OR jmv$kql_p^ [kql_index].deferred_by_application THEN
            IF time_deferred_file AND (jmv$kql_p^ [kql_index].earliest_clock_time_to_process <
                  jmv$ready_deferred_qfile_time) THEN
              jmv$ready_deferred_qfile_time := jmv$kql_p^ [kql_index].earliest_clock_time_to_process;
            IFEND;
            relink_kql_application (kql_index, application_index, jmc$kql_application_unused);
            jmv$kql_p^ [kql_index].application_name := jmv$kql_p^ [kql_index].next_application_name;
            relink_kql_entry (kql_index, jmc$kql_deferred_entry);
          ELSE
            relink_kql_entry (kql_index, jmc$kql_queued_entry);
            relink_kql_application (kql_index, application_index, jmc$kql_application_new);
            jmv$kql_p^ [kql_index].application_name := jmv$kql_p^ [kql_index].next_application_name;
            notify_qfile_application (application_index);
          IFEND;
        IFEND;
      ELSE
        osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_file_name, status);
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kql_lock);

  PROCEND qfp$set_qfile_completed;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$set_qfile_initiated', EJECT ??
*copy qfh$set_qfile_initiated

{ DESIGN:
{ Lock the KQL.
{ Validate the application
{ IF valid THEN
{   find the file in the KQL
{   IF found THEN
{     IF application MODIFIED or TERMINATED THEN
{       Return abnormal status jme$qfile_cannot_initiate
{     ELSE
{       Link application (AN) as INITIATED
{       Link KQL as INITIATED
{     IFEND
{   ELSE
{     Return abnormal status jme$name_not_found
{   IFEND
{ IFEND
{ Unlock the KQL.

  PROCEDURE [XDCL, #GATE] qfp$set_qfile_initiated
    (    application_name: ost$name;
         system_file_name: jmt$system_supplied_name;
     VAR status: ost$status);


    VAR
      application_index: jmt$qfile_application_index,
      kql_index: jmt$kql_index;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kql_lock);

    validate_application_access (application_name, application_index, status);
    IF status.normal THEN

      find_qfile_by_application (system_file_name, application_index, kql_index);
      IF kql_index <> jmc$kql_undefined_index THEN

        IF (jmv$kql_p^ [kql_index].application_state = jmc$kql_application_modified) OR
              (jmv$kql_p^ [kql_index].application_state = jmc$kql_application_terminated) OR
              (jmv$kql_p^ [kql_index].entry_kind = jmc$kql_terminated_entry) THEN
          osp$set_status_condition (jme$qfile_cannot_initiate, status);
        ELSE

          relink_kql_application (kql_index, application_index, jmc$kql_application_processing);
          relink_kql_entry (kql_index, jmc$kql_initiated_entry);
        IFEND;
      ELSE
        osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_file_name, status);
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kql_lock);

  PROCEND qfp$set_qfile_initiated;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$submit_qfile', EJECT ??
*copy qfh$submit_qfile

{ DESIGN:
{ Lock the KQL.
{ IF KQL full THEN
{   expand_kql
{ IFEND
{ IF KQL still full THEN
{   put message in critical window
{ ELSE
{   find an available KQL entry and initialize it
{   IF deferred THEN
{     IF earliest_run_time < ready_deferred_qfile_time THEN
{       ready_deferred_qfile_time := earliest_run_time
{     IFEND
{     Link KQL DEFERRED
{   ELSE
{     Link KQL QUEUED
{     Link application (AN) NEW
{     Notify the correct application
{   IFEND
{   IF latest_run_time < purge_expired_qfile_time THEN
{     purge_expired_qfile_time := latest_run_time
{   IFEND
{ IFEND
{ Unlock the KQL.

  PROCEDURE [XDCL, #GATE] qfp$submit_qfile
    (    system_label: jmt$qfile_system_label;
         earliest_clock_time_to_process: jmt$clock_time;
         latest_clock_time_to_process: jmt$clock_time;
         current_clock_time: jmt$clock_time;
     VAR status: ost$status);


    VAR
      application_index: jmt$qfile_application_index,
      ignore_status_p: ^ost$status,
      kql_index: jmt$kql_index,
      time_deferred_file: boolean;

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (qfv$kql_lock);

{ Make sure that the name is not already in the KQL.

    kql_search (system_label.system_file_name, -$jmt$kql_entry_kind_set [], kql_index);
    IF kql_index <> jmc$kql_undefined_index THEN
      osp$clear_mainframe_sig_lock (qfv$kql_lock);
      osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_name, system_label.system_file_name,
            status);
      RETURN;
    IFEND;

    IF jmv$known_qfile_list.state_data [jmc$kql_unused_entry].first_entry = jmc$kql_undefined_index THEN
      expand_kql;
    IFEND;

{ Check for room in the Known Qfile List (KQL).  The distribution of entries in
{ the KQL is defined as follows:
{
{    #available = MAXIMUM - qfv$current_kql_limit + #initialized_unused_entries
{    #used_entries = MAXIMUM - #available = qfv$current_kql_limit - #initialized_unused_entries
{

    IF (qfv$current_kql_limit - jmv$known_qfile_list.state_data [jmc$kql_unused_entry].number_of_entries >=
          jmc$maximum_qfile_count) THEN
      osp$set_status_condition (jme$maximum_generic_qfiles, status);
      PUSH ignore_status_p;
      dpp$put_critical_message (jmc$generic_queue_full_message, ignore_status_p^);
    ELSE
      kql_index := jmv$known_qfile_list.state_data [jmc$kql_unused_entry].first_entry;

      jmv$kql_p^ [kql_index].system_file_name := system_label.system_file_name;
      jmv$kql_p^ [kql_index].earliest_clock_time_to_process := earliest_clock_time_to_process;
      jmv$kql_p^ [kql_index].latest_clock_time_to_process := latest_clock_time_to_process;
      jmv$kql_p^ [kql_index].purge_delay := jmc$earliest_clock_time;
      jmv$kql_p^ [kql_index].application_name := system_label.application_name;
      jmv$kql_p^ [kql_index].next_application_name := system_label.application_name;
      jmv$kql_p^ [kql_index].deferred_by_application := system_label.deferred_by_application;
      jmv$kql_p^ [kql_index].application_state := jmc$kql_application_unused;

      time_deferred_file := earliest_clock_time_to_process > current_clock_time;
      IF time_deferred_file OR jmv$kql_p^ [kql_index].deferred_by_application THEN
        IF time_deferred_file AND (earliest_clock_time_to_process < jmv$ready_deferred_qfile_time) THEN
          jmv$ready_deferred_qfile_time := earliest_clock_time_to_process;
        IFEND;
        relink_kql_entry (kql_index, jmc$kql_deferred_entry);
      ELSE
        find_application_name (jmv$kql_p^ [kql_index].application_name, application_index);
        relink_kql_entry (kql_index, jmc$kql_queued_entry);
        relink_kql_application (kql_index, application_index, jmc$kql_application_new);
        notify_qfile_application (application_index);
      IFEND;
      IF latest_clock_time_to_process < jmv$purge_expired_qfile_time THEN
        jmv$purge_expired_qfile_time := latest_clock_time_to_process;
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kql_lock);

  PROCEND qfp$submit_qfile;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$terminate_acquired_qfile', EJECT ??
*copy qfh$terminate_acquired_qfile

{ DESIGN:
{ Lock the KQL.
{ Validate the application
{ IF valid THEN
{   find the first terminated entry in the KQL
{   IF found THEN
{     IF KQL TERMINATED THEN
{       Link application (AN) as UNUSED
{       Link KQL as UNUSED
{     ELSE
{       IF deferred THEN
{         IF earliest_run_time < ready_deferred_qfile_time THEN
{           ready_deferred_qfile_time := earliest_run_time
{         IFEND
{         Link application (NAN) as UNUSED
{         application_name := next_application_name
{         Link KQL as DEFERRED
{       ELSE
{         Link application (NAN) as NEW
{         application_name := next_application_name
{         notify the correct application
{       IFEND
{     IFEND
{   ELSE
{     Return abnormal status jme$generic_queue_is_empty
{   IFEND
{ IFEND
{ Unlock the KQL.

  PROCEDURE [XDCL, #GATE] qfp$terminate_acquired_qfile
    (    application_name: ost$name;
     VAR system_file_name: jmt$system_supplied_name;
     VAR delete_qfile: boolean;
     VAR status: ost$status);


    VAR
      application_index: jmt$qfile_application_index,
      current_clock_time: jmt$clock_time,
      kql_index: jmt$kql_index,
      time_deferred_file: boolean;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kql_lock);

    validate_application_access (application_name, application_index, status);
    IF status.normal THEN

      kql_index := jmv$known_qfile_list.application_table [application_index].
            state_data [jmc$kql_application_terminated].first_entry;
      IF kql_index <> jmc$kql_undefined_index THEN
        system_file_name := jmv$kql_p^ [kql_index].system_file_name;
        IF jmv$kql_p^ [kql_index].entry_kind = jmc$kql_terminated_entry THEN
          delete_qfile := TRUE;
          relink_kql_application (kql_index, application_index, jmc$kql_application_unused);
          relink_kql_entry (kql_index, jmc$kql_unused_entry);
        ELSE
          delete_qfile := FALSE;
          find_application_name (jmv$kql_p^ [kql_index].next_application_name, application_index);
          current_clock_time := #FREE_RUNNING_CLOCK (0);
          time_deferred_file := jmv$kql_p^ [kql_index].earliest_clock_time_to_process > current_clock_time;
          IF time_deferred_file OR jmv$kql_p^ [kql_index].deferred_by_application THEN
            IF time_deferred_file AND (jmv$kql_p^ [kql_index].earliest_clock_time_to_process <
                  jmv$ready_deferred_qfile_time) THEN
              jmv$ready_deferred_qfile_time := jmv$kql_p^ [kql_index].earliest_clock_time_to_process;
            IFEND;
            relink_kql_application (kql_index, application_index, jmc$kql_application_unused);
            jmv$kql_p^ [kql_index].application_name := jmv$kql_p^ [kql_index].next_application_name;
            relink_kql_entry (kql_index, jmc$kql_deferred_entry);
          ELSE
            relink_kql_application (kql_index, application_index, jmc$kql_application_new);
            jmv$kql_p^ [kql_index].application_name := jmv$kql_p^ [kql_index].next_application_name;
            notify_qfile_application (application_index);
          IFEND;
        IFEND;

      ELSE
        osp$set_status_condition (jme$generic_queue_is_empty, status);
      IFEND;

    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kql_lock);

  PROCEND qfp$terminate_acquired_qfile;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$terminate_qfile', EJECT ??
*copy qfh$terminate_qfile

{ DESIGN:
{ Lock the KQL.
{ Find the file to be terminated in the KQL
{ Link KQL as TERMINATED
{ IF KQL application > NEW THEN
{   IF notify_on_terminate (registration option) OR KQL was initiated THEN
{     Link application (AN) as TERMINATED
{     notify the correct application
{   IFEND
{ ELSE
{   Link application as UNUSED
{   Link KQL as UNUSED
{ IFEND
{ Unlock the KQL.

  PROCEDURE [XDCL, #GATE] qfp$terminate_qfile
    (    system_file_name: jmt$system_supplied_name;
         qfile_state_set: jmt$qfile_state_set;
     VAR delete_qfile: boolean;
     VAR status: ost$status);


    VAR
      application_index: jmt$qfile_application_index,
      kql_index: jmt$kql_index,
      kql_entry_kind_set: jmt$kql_entry_kind_set,
      kql_entry_kind: jmt$kql_entry_kind,
      qfile_state: jmt$qfile_state,
      qfile_was_initiated: boolean;

    status.normal := TRUE;
    delete_qfile := FALSE;
    qfile_was_initiated := TRUE;

    kql_entry_kind_set := $jmt$kql_entry_kind_set [];
    FOR qfile_state := LOWERVALUE (qfile_state) TO UPPERVALUE (qfile_state) DO
      IF qfile_state IN qfile_state_set THEN
        kql_entry_kind := convert_state_to_entry_kind [qfile_state];
        kql_entry_kind_set := kql_entry_kind_set + $jmt$kql_entry_kind_set [kql_entry_kind];
      IFEND;
    FOREND;

    osp$set_mainframe_sig_lock (qfv$kql_lock);

    kql_search (system_file_name, kql_entry_kind_set, kql_index);
    IF kql_index = jmc$kql_undefined_index THEN
      osp$clear_mainframe_sig_lock (qfv$kql_lock);
      osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_file_name, status);
      RETURN;
    IFEND;

    IF jmv$kql_p^ [kql_index].entry_kind = jmc$kql_terminated_entry THEN
      osp$clear_mainframe_sig_lock (qfv$kql_lock);
      osp$set_status_abnormal (jmc$job_management_id, jme$qfile_already_terminated, system_file_name, status);
      RETURN;
    IFEND;

    IF (jmv$kql_p^ [kql_index].entry_kind = jmc$kql_deferred_entry) OR
          (jmv$kql_p^ [kql_index].entry_kind = jmc$kql_queued_entry) THEN
      qfile_was_initiated := FALSE;
    IFEND;
    relink_kql_entry (kql_index, jmc$kql_terminated_entry);
    find_application_name (jmv$kql_p^ [kql_index].application_name, application_index);
    IF jmv$kql_p^ [kql_index].application_state > jmc$kql_application_new THEN
      IF qfile_was_initiated OR jmv$known_qfile_list.application_table [application_index].
            registration_options.notify_on_terminate THEN
        relink_kql_application (kql_index, application_index, jmc$kql_application_terminated);
        notify_qfile_application (application_index);
      IFEND;
    ELSE
      delete_qfile := TRUE;
      relink_kql_application (kql_index, application_index, jmc$kql_application_unused);
      relink_kql_entry (kql_index, jmc$kql_unused_entry);
    IFEND;

    osp$clear_mainframe_sig_lock (qfv$kql_lock);

  PROCEND qfp$terminate_qfile;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$validate_qfile_access', EJECT ??
*copy qfh$validate_qfile_access

{ DESIGN:
{ Lock the KQL.
{ IF application_name is in application table THEN
{   IF passwords match THEN
{     find file in application's initiated thread
{       IF NOT found THEN
{         Return abnormal status jme$name_not_found
{       IFEND
{   ELSE
{     Return abnormal status jme$qfile_appl_not_permitted
{   IFEND
{ ELSE
{   Return abnormal status jme$application_name_incorrect
{ IFEND
{ Unlock the KQL.

  PROCEDURE [XDCL, #GATE] qfp$validate_qfile_access
    (    system_file_name: jmt$system_supplied_name;
         application_name: ost$name;
         queue_file_password: jmt$queue_file_password;
     VAR status: ost$status);


    VAR
      application_index: jmt$qfile_application_index,
      kql_index: jmt$kql_index;

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (qfv$kql_lock);
    find_application_name (application_name, application_index);
    IF application_index = jmc$unassigned_qfile_index THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$application_name_incorrect, application_name,
            status);
    ELSE

{ Do the passwords match??

      IF queue_file_password <> jmv$known_qfile_list.application_table [application_index].
            queue_file_password THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$qfile_appl_not_permitted, application_name,
              status);
      ELSE

{ Search for the file in the applications initiated thread - If it isn't there, don't permit access
{ to the file.

        kql_index := jmv$known_qfile_list.application_table [application_index].
              state_data [jmc$kql_application_processing].first_entry;
        WHILE (kql_index <> jmc$kql_undefined_index) AND (jmv$kql_p^ [kql_index].system_file_name <>
              system_file_name) DO
          kql_index := jmv$kql_p^ [kql_index].application_forward_link;
        WHILEND;
        IF (kql_index = jmc$kql_undefined_index) THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_file_name, status);
        IFEND;
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kql_lock);

  PROCEND qfp$validate_qfile_access;
?? OLDTITLE ??
MODEND qfm$generic_queue_file_manager;
*DECK DECK=QFM$JOB_CATEGORIZATION_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Job Management Job Categorization Interfaces' ??
MODULE qfm$job_categorization_manager;

{ PURPOSE:
{   This module contains the ring 1 Job Management job categorization
{   interfaces.  The interfaces are used to determine the categories
{   for a job and to assign a job to a particular job class.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dft$family_access
*copyc dft$family_table_client_entry
*copyc jmc$class_names
*copyc jmc$job_management_id
*copyc jme$job_categorization_errors
*copyc jmk$keypoints
*copyc jmt$job_class
*copyc jmt$job_class_list
*copyc jmt$job_system_label
*copyc jmt$maximum_mainframes
*copyc jmt$valid_mainframe_set
*copyc oss$mainframe_paged_literal
*copyc ost$name
*copyc ost$status
*copyc pmt$family_name_count
?? POP ??
*copyc osp$clear_mainframe_sig_lock
*copyc osp$decrement_locked_variable
*copyc osp$increment_locked_variable
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc jmv$job_category_data
*copyc jmv$job_class_table_p
*copyc jmv$job_scheduler_table
*copyc jmv$scheduler_tables_access
*copyc osv$family_table
?? OLDTITLE ??
?? NEWTITLE := 'categories_fit', EJECT ??

{ PURPOSE
{   This function determines if the job categories fit with the required and
{   excluded categories provided.  This has been made into an inline function
{   to make the algorithm more readable and to ensure that the test is done
{   the same each time.

  FUNCTION [INLINE] categories_fit
    (    job_categories: jmt$job_category_set;
         required_categories: jmt$job_category_set;
         excluded_categories: jmt$job_category_set): boolean;

    categories_fit := (job_categories * required_categories = required_categories) AND
          (job_categories * excluded_categories = $jmt$job_category_set []);
  FUNCEND categories_fit;
?? OLDTITLE ??
?? NEWTITLE := 'determine_categories', EJECT ??

  PROCEDURE determine_categories
    (VAR {input, output} system_label: jmt$job_system_label;
     VAR status: ost$status);

    VAR
      category_kind_sets: jmt$job_category_set_list,
      item_kind: jmt$job_category_item_kind,
      job_categories: jmt$job_category_set,
      qualifier_index: 1 .. jmc$maximum_job_qualifiers,
      next_item: jmt$job_category_reference,
      item: ^jmt$job_category_item,
      first_item: ^jmt$job_category_item,
      numbers: array [jmt$job_category_item_kind] of integer,
      names: array [jmt$job_category_item_kind] of ost$name;

    VAR
      job_mode: [STATIC, READ, oss$mainframe_paged_literal] array [jmt$job_mode] of
            ost$name := ['BATCH', REP 4 of 'INTERACTIVE'];

    status.normal := TRUE;
    IF jmv$job_category_data.item_list = NIL THEN
      system_label.job_category_set := $jmt$job_category_set [];
      RETURN;
    IFEND;

    numbers [jmc$ca_cpu_time_limit] := system_label.limit_information.cpu_time_limit_assigned;
    IF numbers [jmc$ca_cpu_time_limit] = jmc$unlimited_cpu_time_limit THEN
      numbers [jmc$ca_cpu_time_limit] := jmc$highest_cpu_time_limit + jmc$unlimited_offset;
    IFEND;
    numbers [jmc$ca_sru_time_limit] := system_label.limit_information.sru_limit_assigned;
    IF numbers [jmc$ca_sru_time_limit] = jmc$unlimited_sru_limit THEN
      numbers [jmc$ca_sru_time_limit] := jmc$highest_sru_limit + jmc$unlimited_offset;
    IFEND;
    numbers [jmc$ca_mag_tape_limit] := system_label.limit_information.magnetic_tape_limit_assigned;
    numbers [jmc$ca_working_set] := system_label.limit_information.maximum_working_set_assigned;

    names [jmc$ca_login_account] := system_label.login_account;
    names [jmc$ca_login_project] := system_label.login_project;
    names [jmc$ca_login_family] := system_label.login_user_identification.family;
    names [jmc$ca_login_user] := system_label.login_user_identification.user;
    names [jmc$ca_user_job_name] := system_label.user_job_name;

    names [jmc$ca_orig_application_name] := system_label.job_attributes.originating_application_name;

    names [jmc$ca_job_mode] := job_mode [system_label.job_mode];

    first_item := #LOC (jmv$job_category_data.item_list^);
    item := first_item;
    category_kind_sets := jmv$job_category_data.initial_set_values;

  /matching/
    REPEAT
      next_item := item^.next_item;
      item_kind := item^.kind;
      IF item_kind <= jmc$ca_working_set THEN
        IF numbers [item_kind] <= item^.number THEN
          category_kind_sets [item_kind] := category_kind_sets [item_kind] + item^.categories;
          next_item := item^.skip_item;
        IFEND;

      ELSEIF item_kind < jmc$ca_job_qualifier THEN
        IF names [item_kind] <= item^.name THEN
          IF names [item_kind] = item^.name THEN
            category_kind_sets [item_kind] := category_kind_sets [item_kind] + item^.categories;
          IFEND;
          next_item := item^.skip_item;
        IFEND;

      ELSEIF item_kind = jmc$ca_job_qualifier THEN

{ jme$job_qualifier_not_valid

      /qualifier/
        FOR qualifier_index := 1 TO jmc$maximum_job_qualifiers DO
          IF item^.name = system_label.job_attributes.job_qualifier_list [qualifier_index] THEN
            category_kind_sets [jmc$ca_job_qualifier] := category_kind_sets [jmc$ca_job_qualifier] +
                  item^.categories;
            EXIT /qualifier/
          IFEND;
        FOREND /qualifier/;

      ELSE {item_kind = jmc$ca_ca_or_conditions }
        EXIT /matching/;
      IFEND;

      item := #PTR (next_item, jmv$job_category_data.item_list^);
    UNTIL item = first_item;

    job_categories := category_kind_sets [jmc$ca_cpu_time_limit];
    FOR item_kind := jmc$ca_sru_time_limit TO jmc$ca_job_qualifier DO
      job_categories := job_categories * category_kind_sets [item_kind];
    FOREND;

    WHILE item <> first_item DO
      IF (job_categories * item^.members) <> $jmt$job_category_set [] THEN
        job_categories := job_categories + item^.categories;
      IFEND;
      item := #PTR (item^.next_item, jmv$job_category_data.item_list^);
    WHILEND;

    system_label.job_category_set := job_categories;

  PROCEND determine_categories;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$categorize_job', EJECT ??
*copy qfh$categorize_job

  PROCEDURE [XDCL, #GATE] qfp$categorize_job
    (    valid_job_classes: jmt$job_class_list;
         number_of_valid_job_classes: ost$non_negative_integers;
     VAR system_label { input, output } : jmt$job_system_label;
     VAR assigned_job_class: jmt$job_class;
     VAR status: ost$status);

    VAR
      job_categories: jmt$job_category_set;


    VAR
      i: integer,
      actual: integer,
      lock_error: boolean,
      job_class: jmt$job_class;

    status.normal := TRUE;

    #KEYPOINT (osk$entry, 0, jmk$categorize_job);

    osp$set_mainframe_sig_lock (jmv$scheduler_tables_access.lock);
    osp$increment_locked_variable (jmv$scheduler_tables_access.count, 0, actual);
    osp$clear_mainframe_sig_lock (jmv$scheduler_tables_access.lock);

    determine_categories (system_label, status);
    job_categories := system_label.job_category_set;

  /find_job_class/
    BEGIN
      IF system_label.assigned_job_class = jmc$automatic_class_name THEN

        job_class := jmv$job_class_table_p^ [jmc$unassigned_job_class].next_rank_class;
        WHILE job_class <> jmc$null_job_class DO
          IF categories_fit (job_categories, jmv$job_class_table_p^ [job_class].required_categories,
                jmv$job_class_table_p^ [job_class].excluded_categories) THEN
            FOR i := 1 TO number_of_valid_job_classes DO
              IF (valid_job_classes [i] = jmv$job_class_table_p^ [job_class].name) OR
                    (valid_job_classes [i] = jmc$all_class_name) THEN
                system_label.assigned_job_class := jmv$job_class_table_p^ [job_class].name;
                assigned_job_class := job_class;
                EXIT /find_job_class/;
              IFEND;
            FOREND;
          IFEND;
          job_class := jmv$job_class_table_p^ [job_class].next_rank_class;
        WHILEND;
        osp$set_status_condition (jme$no_job_class_found_for_job, status);

      ELSE {Job class is given explicitly}

        FOR job_class := 1 TO UPPERBOUND (jmv$job_class_table_p^) DO
          IF jmv$job_class_table_p^ [job_class].defined THEN
            IF jmv$job_class_table_p^ [job_class].name = system_label.assigned_job_class THEN
              IF categories_fit (job_categories, jmv$job_class_table_p^ [job_class].required_categories,
                    jmv$job_class_table_p^ [job_class].excluded_categories) THEN
                assigned_job_class := job_class;
              ELSE
                osp$set_status_abnormal (jmc$job_management_id, jme$cannot_assign_to_job_class,
                      system_label.assigned_job_class, status);
              IFEND;
              EXIT /find_job_class/;
            IFEND;
          IFEND;
        FOREND;
        osp$set_status_abnormal (jmc$job_management_id, jme$job_class_does_not_exist,
              system_label.assigned_job_class, status);
      IFEND;
    END /find_job_class/;

    osp$decrement_locked_variable (jmv$scheduler_tables_access.count, actual, actual, lock_error);

    #KEYPOINT (osk$exit, 0, jmk$categorize_job);

  PROCEND qfp$categorize_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$check_for_profile_mismatch', EJECT ??
*copyc qfh$check_for_profile_mismatch

  PROCEDURE [XDCL, #GATE] qfp$check_for_profile_mismatch
    (    profile_version: ost$name;
     VAR profile_mismatch: boolean);

    profile_mismatch := jmv$job_scheduler_table.profile_identification <> profile_version;

  PROCEND qfp$check_for_profile_mismatch;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$determine_mainframe_fitness', EJECT ??
*copy qfh$determine_mainframe_fitness

  PROCEDURE [XDCL, #GATE] qfp$determine_mainframe_fitness
    (    job_category_set: jmt$job_category_set;
         leveled_job: boolean;
         login_family: ost$name;
     VAR valid_mainframes_set: jmt$valid_mainframe_set;
     VAR status: ost$status);

    VAR
      actual: integer,
      family_access: dft$family_access,
      family_mainframe_list_p: ^dft$family_table_client_entry,
      family_table_index: pmt$family_name_count,
      fits_a_mainframe: boolean,
      lock_error: boolean,
      login_family_index: pmt$family_name_count,
      mainframe_index: jmt$maximum_mainframes;

    osp$set_mainframe_sig_lock (jmv$scheduler_tables_access.lock);
    osp$increment_locked_variable (jmv$scheduler_tables_access.count, 0, actual);
    osp$clear_mainframe_sig_lock (jmv$scheduler_tables_access.lock);

{ If the job is a leveled job it must fit the categories of one of the
{ mainframes in the scheduling profile.  If the job is NOT a leveled job
{ then its categories must match the mainframe on which the job is being
{ submitted.

{ NOTE: The first set of categories in the scheduler table represent the categories
{ of the executing mainframe.

    valid_mainframes_set := $jmt$valid_mainframe_set [1];
    fits_a_mainframe := FALSE;
    IF categories_fit (job_category_set, jmv$job_scheduler_table.validation_categories_p^ [1].required,
          jmv$job_scheduler_table.validation_categories_p^ [1].excluded) THEN
      fits_a_mainframe := TRUE;
    IFEND;
    IF leveled_job THEN
      login_family_index := 0;

    /search_for_family_index/
      FOR family_table_index := 1 TO UPPERBOUND (osv$family_table^) DO
        IF osv$family_table^ [family_table_index].family_name = login_family THEN
          login_family_index := family_table_index;
          EXIT /search_for_family_index/;
        IFEND;
      FOREND /search_for_family_index/;

      IF login_family_index = 0 THEN
        osp$system_error ('A family on the server is missing for categorization.', NIL);
      ELSE

      /fits_mainframe/
        FOR mainframe_index := 2 TO UPPERBOUND (jmv$job_scheduler_table.validation_categories_p^) DO
          family_mainframe_list_p := osv$family_table^ [login_family_index].p_client_access_list;
          family_access := osv$family_table^ [login_family_index].default_family_access;

        /search_for_mainframe/
          WHILE family_mainframe_list_p <> NIL DO
            IF family_mainframe_list_p^.client_binary_id = jmv$job_scheduler_table.
                  validation_categories_p^ [mainframe_index].binary_mainframe_id THEN
              family_access := family_mainframe_list_p^.family_access;
              EXIT /search_for_mainframe/;
            ELSE
              family_mainframe_list_p := family_mainframe_list_p^.p_next_client;
            IFEND;
          WHILEND /search_for_mainframe/;

          IF (dfc$job_leveling_access IN family_access) THEN
            valid_mainframes_set := valid_mainframes_set + $jmt$valid_mainframe_set [mainframe_index];
            fits_a_mainframe := fits_a_mainframe OR categories_fit
                  (job_category_set, jmv$job_scheduler_table.validation_categories_p^ [mainframe_index].
                  required, jmv$job_scheduler_table.validation_categories_p^ [mainframe_index].excluded);
          IFEND;
        FOREND /fits_mainframe/;
      IFEND;
    IFEND;

    osp$decrement_locked_variable (jmv$scheduler_tables_access.count, actual, actual, lock_error);

    IF NOT fits_a_mainframe THEN
      osp$set_status_condition (jme$no_mainframe_found_for_job, status);
    IFEND;
  PROCEND qfp$determine_mainframe_fitness;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] qfp$get_profile_mainframe_index', EJECT ??
*copy qfh$get_profile_mainframe_index

  PROCEDURE [XDCL] qfp$get_profile_mainframe_index
    (    binary_mainframe_id: pmt$binary_mainframe_id;
     VAR mainframe_index: jmt$maximum_mainframes);

    VAR
      profile_mainframe_index: jmt$maximum_mainframes;

    mainframe_index := 0;

  /search_for_mainframe/
    FOR profile_mainframe_index := 1 TO UPPERBOUND (jmv$job_scheduler_table.validation_categories_p^) DO
      IF binary_mainframe_id = jmv$job_scheduler_table.validation_categories_p^ [profile_mainframe_index].
            binary_mainframe_id THEN
        mainframe_index := profile_mainframe_index;
        EXIT /search_for_mainframe/;
      IFEND;
    FOREND /search_for_mainframe/;

  PROCEND qfp$get_profile_mainframe_index;
?? OLDTITLE ??
MODEND qfm$job_categorization_manager;
*DECK DECK=QFM$QUEUE_FILE_JOB_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE job management queued file job internal interfaces' ??
MODULE qfm$queue_file_job_manager;

{ PURPOSE:
{   This module contains the Queue File Management system core interfaces for managing files in the
{ input queue and the Known Job List (KJL).
{
{ DESIGN:
{   These procedures execute in ring one and can be called from ring 3.  These procedures access
{ the ring one table the Known Job List (KJL).  It is contained in mainframe pageable.  A signature
{ lock is used in order to ensure synchronous access to the KJL.

?? NEWTITLE := 'Global Declarations Referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dft$rpc_parameters
*copyc dme$tape_errors
*copyc jmc$class_names
*copyc jmc$input_queue_full_message
*copyc jmc$job_management_id
*copyc jmc$kjl_maximum_entries
*copyc jmc$maximum_job_count
*copyc jmc$status_message_text
*copyc jme$queued_file_conditions
*copyc jmt$clock_time
*copyc jmt$default_job_attributes
*copyc jmt$initiated_job_list_entry
*copyc jmt$input_application_index
*copyc jmt$input_descriptor
*copyc jmt$input_file_location
*copyc jmt$job_attributes
*copyc jmt$job_class_limits
*copyc jmt$job_class_set
*copyc jmt$job_control_block
*copyc jmt$job_counts
*copyc jmt$job_internal_information
*copyc jmt$job_mode_set
*copyc jmt$job_recovery_information
*copyc jmt$job_state
*copyc jmt$job_state_set
*copyc jmt$job_status_count
*copyc jmt$job_status_options
*copyc jmt$job_status_results
*copyc jmt$job_system_label
*copyc jmt$kjl_application_state_set
*copyc jmt$kjl_client_index
*copyc jmt$kjl_entry_kind
*copyc jmt$kjl_entry_kind_set
*copyc jmt$kjl_index
*copyc jmt$kjl_server_index
*copyc jmt$known_job_list
*copyc jmt$known_job_list_entry
*copyc jmt$known_job_list_extended
*copyc jmt$name
*copyc jmt$queue_file_password
*copyc jmt$release_input_file_list
*copyc jmt$results_keys
*copyc jmt$system_job_parameters
*copyc jmt$system_supplied_name
*copyc jmt$terminate_job_action
*copyc jmt$valid_mainframe_set
*copyc jmt$work_area
*copyc osc$timesharing
*copyc osd$integer_limits
*copyc oss$mainframe_pageable
*copyc oss$mainframe_paged_literal
*copyc ost$byte
*copyc ost$halfword
*copyc ost$signature_lock
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*copyc dpp$put_critical_message
*copyc iop$job_tape_mounts_active
*copyc jmp$determine_job_class_name
*copyc jmp$force_candidate_refresh
*copyc jmp$get_ijle_p
*copyc jmp$notify_job_scheduler_of_job
*copyc jmp$set_event_and_ready_sched
*copyc ofp$job_operator_menus_active
*copyc ofp$job_operator_msgs_active
*copyc osp$clear_mainframe_sig_lock
*copyc osp$monitor_fault_to_status
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$test_sig_lock
*copyc pmp$convert_binary_mainframe_id
*copyc pmp$convert_mainframe_to_binary
*copyc pmp$delay
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_mainframe_id
*copyc pmp$ready_task
*copyc pmp$set_system_flag
*copyc pmp$zero_out_table
*copyc qfp$check_for_profile_mismatch
*copyc syp$continue_to_cause
*copyc syp$disestablish_cond_handler
*copyc syp$establish_condition_handler
*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc jmv$job_class_table_p
*copyc jmv$job_counts
*copyc jmv$job_scheduler_table
*copyc jmv$maximum_job_class_in_use
*copyc jmv$null_date_time
*copyc jmv$refresh_job_candidates
*copyc jmv$sched_profile_is_loading
*copyc jmv$system_job_ssn
*copyc osv$mainframe_pageable_heap
?? TITLE := 'Global Variables Declared in this Module', EJECT ??

  CONST
    max_job_tape_mount_attempts = 30,
    one_second = 1000 {milliseconds},
    system_job_kjl_index = 1;

  VAR
    jmv$input_file_recovery_option: [XDCL, #GATE, oss$mainframe_pageable] ost$byte := 0,
    jmv$job_counts_lock: [XDCL, #GATE, oss$mainframe_pageable] ost$signature_lock,
    jmv$job_history_active: [XDCL, #GATE, oss$mainframe_pageable] boolean := FALSE,
    jmv$known_job_list: [XDCL, #GATE, oss$mainframe_pageable] jmt$known_job_list,
    jmv$kjl_p: [XDCL, #GATE, oss$mainframe_pageable] ^array [1 .. * ] of jmt$known_job_list_entry := NIL,
    jmv$kjlx_p: [XDCL, #GATE, oss$mainframe_pageable] ^array [1 .. * ] of jmt$known_job_list_extended := NIL,
    jmv$maximum_known_jobs: [XDCL, #GATE, oss$mainframe_pageable] ost$halfword := 250,
    jmv$time_to_ready_deferred_job: [XDCL, #GATE, oss$mainframe_pageable] jmt$clock_time :=
          jmc$latest_clock_time,
    qfv$kjl_lock: [XDCL, oss$mainframe_pageable] ost$signature_lock,
    qfv$current_kjl_limit: [XDCL, #GATE, oss$mainframe_pageable] jmt$kjl_index := 0,
    qfv$terminate_job_action_set: [XDCL, #GATE, oss$mainframe_pageable] jmt$terminate_job_action_set :=
          $jmt$terminate_job_action_set [jmc$tja_kill_disabled],
    null_binary_mainframe_id: [STATIC, READ, oss$mainframe_paged_literal] pmt$binary_mainframe_id := [0, 0],
    jmv$default_job_attributes: [XDCL, #GATE, oss$mainframe_pageable] jmt$default_job_attributes;

?? TITLE := 'convert_state_to_entry_kind', EJECT ??

{ PURPOSE:
{   The purpose of this request is to convert a job state to its Known Job List entry-kind
{ equivalent.

  PROCEDURE convert_state_to_entry_kind
    (    job_state: jmt$job_state;
     VAR kjl_entry_kind: jmt$kjl_entry_kind;
     VAR status: ost$status);

    CASE job_state OF
    = jmc$deferred_job =
      kjl_entry_kind := jmc$kjl_deferred_entry;

    = jmc$queued_job =
      kjl_entry_kind := jmc$kjl_queued_entry;

    = jmc$initiated_job =
      kjl_entry_kind := jmc$kjl_initiated_entry;

    = jmc$terminating_job =
      kjl_entry_kind := jmc$kjl_terminated_entry;

    = jmc$completed_job =
      kjl_entry_kind := jmc$kjl_completed_entry;

    ELSE
      osp$set_status_abnormal (jmc$job_management_id, jme$invalid_job_state, '', status);
    CASEND;
  PROCEND convert_state_to_entry_kind;
?? OLDTITLE ??
?? NEWTITLE := 'find_client_mainframe_id', EJECT ??

{ PURPOSE:
{   This request searches the Known Job List Client Table for the specified mainframe
{   identifier and adds it if it does not exist.
{
{ DESIGN:
{   If the mainframe identifier is found return the kjl client index.  If the mainframe
{   identifier is not found then assign a new kjl client index.  If the kjl client list
{   is full set the client_mainframe_id_in_kjl to FALSE.
{
{ NOTES:
{   The Known Job List (KJL) must be locked when this request is issued.

  PROCEDURE find_client_mainframe_id
    (    client_mainframe_id: pmt$binary_mainframe_id;
     VAR client_mainframe_id_in_kjl: boolean;
     VAR kjl_client_index: jmt$kjl_client_index);

    VAR
      local_kjl_client_index: jmt$kjl_client_index;

    client_mainframe_id_in_kjl := FALSE;

  /search_for_mainframe_id/
    FOR local_kjl_client_index := jmc$kjl_client_this_mainframe TO UPPERVALUE (jmt$kjl_client_index) DO
      IF jmv$known_job_list.client_data.state_data [local_kjl_client_index].mainframe_id =
            client_mainframe_id THEN
        client_mainframe_id_in_kjl := TRUE;
        kjl_client_index := local_kjl_client_index;
        EXIT /search_for_mainframe_id/;
      IFEND;
    FOREND /search_for_mainframe_id/;
    IF (NOT client_mainframe_id_in_kjl) THEN

    /search_for_empty_client_entry/
      FOR local_kjl_client_index := jmc$kjl_client_this_mainframe + 1 TO UPPERVALUE (jmt$kjl_client_index) DO
        IF jmv$known_job_list.client_data.state_data [local_kjl_client_index].mainframe_id =
              null_binary_mainframe_id THEN
          jmv$known_job_list.client_data.state_data [local_kjl_client_index].mainframe_id :=
                client_mainframe_id;
          client_mainframe_id_in_kjl := TRUE;
          kjl_client_index := local_kjl_client_index;
          EXIT /search_for_empty_client_entry/;
        IFEND;
      FOREND /search_for_empty_client_entry/;
    IFEND;
  PROCEND find_client_mainframe_id;
?? OLDTITLE ??
?? NEWTITLE := 'find_destination_usage', EJECT ??

{ PURPOSE:
{   The purpose of this request is to find the specified destination_usage in the application table
{ and return with the application index.  If there is no application registered for the destination_usage
{ specified the value jmc$unassigned_input_index is returned.
{
{ DESIGN:
{   Starting with the index of the last application, search backwards through the chain until
{ the destination_usage is found or there are no more applications to search.
{
{ NOTES:
{   The Known Job List (KJL) MUST be locked when this request is made.

  PROCEDURE find_destination_usage
    (    destination_usage: jmt$destination_usage;
     VAR application_index: jmt$input_application_index);

    IF (destination_usage = jmc$ve_usage) OR (destination_usage = jmc$ve_local_usage) THEN
      application_index := jmc$ve_input_application_index;
    ELSE

      application_index := UPPERBOUND (jmv$known_job_list.application_table);

      WHILE (jmv$known_job_list.application_table [application_index].destination_usage <>
            destination_usage) AND (application_index <> jmc$unassigned_input_index) DO
        application_index := application_index - 1;
      WHILEND;
    IFEND;
  PROCEND find_destination_usage;
?? TITLE := 'find_job_by_application', EJECT ??

{ PURPOSE:
{   The purpose of this request is to find a job assigned to a particular application by using its
{ system_job_name.
{
{ DESIGN:
{   Search the Known Job List (KJL) for the job that has been assigned to the application specified.
{ If the entry in the KJL is not found, return a kjl_index of jmc$kjl_undefined_index.
{
{ NOTES:
{   The KJL must be locked when this request is issued.

  PROCEDURE find_job_by_application
    (    system_job_name: jmt$system_supplied_name;
         application_index: jmt$input_application_index;
     VAR kjl_index: jmt$kjl_index);

    VAR
      application_state: jmt$kjl_application_state;

  /search_for_the_specified_file/
    FOR application_state := SUCC (jmc$kjl_application_unused) TO UPPERVALUE (application_state) DO
      kjl_index := jmv$known_job_list.application_table [application_index].state_data [application_state].
            first_entry;
      WHILE kjl_index <> jmc$kjl_undefined_index DO
        IF jmv$kjl_p^ [kjl_index].system_job_name = system_job_name THEN
          EXIT /search_for_the_specified_file/;
        ELSE
          kjl_index := jmv$kjl_p^ [kjl_index].application_forward_link;
        IFEND;
      WHILEND;
    FOREND /search_for_the_specified_file/;
  PROCEND find_job_by_application;
?? OLDTITLE ??
?? NEWTITLE := 'find_server_mainframe_id', EJECT ??

{ PURPOSE:
{   This request searches the Known Job List Server Table for the specified mainframe
{   identifier and adds it if it does not exist.
{
{ DESIGN:
{   If the mainframe identifier is found return the kjl server index.  If the mainframe
{   identifier is not found then assign a new kjl server index.
{
{ NOTES:
{   The Known Job List (KJL) must be locked when this request is issued.

  PROCEDURE find_server_mainframe_id
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR kjl_server_index: jmt$kjl_server_index);

    VAR
      first_available_server_index: jmt$kjl_server_index,
      local_kjl_server_index: jmt$kjl_server_index;

    first_available_server_index := jmc$kjl_server_this_mainframe;

  /search_for_mainframe_id/
    FOR local_kjl_server_index := jmc$kjl_server_this_mainframe TO UPPERVALUE (jmt$kjl_server_index) DO
      IF jmv$known_job_list.server_data.state_data [local_kjl_server_index].mainframe_id =
            server_mainframe_id THEN
        kjl_server_index := local_kjl_server_index;
        RETURN;
      ELSEIF (jmv$known_job_list.server_data.state_data [local_kjl_server_index].mainframe_id =
            null_binary_mainframe_id) AND (first_available_server_index = jmc$kjl_server_this_mainframe) THEN
        first_available_server_index := local_kjl_server_index;
      IFEND;
    FOREND /search_for_mainframe_id/;
    jmv$known_job_list.server_data.state_data [first_available_server_index].mainframe_id :=
          server_mainframe_id;
    kjl_server_index := first_available_server_index;
  PROCEND find_server_mainframe_id;
?? OLDTITLE ??
?? NEWTITLE := 'get_job_from_scheduler', EJECT ??

{ PURPOSE:
{   The purpose of this request is to force the job scheduler to un-acquire a job that has been acquired.
{
{ DESIGN:
{   Relink the KJL entry supplied to the application state supplied on the request.  Notify the
{ Scheduler that it needs to refresh the candidate queue.  Once the scheduler has run, it will return the
{ the job to the NEW application state.  This will permit the KJL to be locked and the entry should no
{ longer be acquired.
{
{ NOTES:
{   The KJL MUST be locked on entry to this request.  In addition, this request will always exit with the
{ KJL locked.

  PROCEDURE get_job_from_scheduler
    (    kjl_index: jmt$kjl_index;
         destination_application_state: jmt$kjl_application_state;
     VAR job_name_has_changed: boolean);

    TYPE
      kjl_application_state_set = set of jmt$kjl_application_state;

    VAR
      application_state_wait_set: kjl_application_state_set,
      ignore_status: ost$status,
      system_job_name: jmt$system_supplied_name;

    application_state_wait_set := $kjl_application_state_set
          [jmc$kjl_application_acquired, jmc$kjl_application_modified, jmc$kjl_application_terminated];
    system_job_name := jmv$kjl_p^ [kjl_index].system_job_name;

{*** Temporary test code...  If it works, keep it.

    IF ve_job (kjl_index) AND (jmv$kjl_p^ [kjl_index].application_state IN application_state_wait_set) AND
          (jmv$kjl_p^ [kjl_index].entry_kind = jmc$kjl_queued_entry) THEN
      jmp$force_candidate_refresh ({ flush_candidate_queue } TRUE);
    IFEND;
    job_name_has_changed := jmv$kjl_p^ [kjl_index].system_job_name <> system_job_name;
    RETURN;

{ If the job scheduler has the job we must wait for it to give it up.  For all other applications,
{ nothing is done.

    WHILE ve_job (kjl_index) AND (jmv$kjl_p^ [kjl_index].application_state IN application_state_wait_set) AND
          (jmv$kjl_p^ [kjl_index].entry_kind = jmc$kjl_queued_entry) DO
      qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index, destination_application_state);
      jmv$refresh_job_candidates := TRUE;
      notify_input_application (jmc$ve_input_application_index, kjl_index);
      osp$clear_mainframe_sig_lock (qfv$kjl_lock);

{ Because the job scheduler is attempting to initiate the job we must wait for it to return control.
{ The job scheduler will run when it can and recognize that it has work to do.

      WHILE (jmv$kjl_p^ [kjl_index].application_state = destination_application_state) AND
            (jmv$kjl_p^ [kjl_index].entry_kind = jmc$kjl_queued_entry) DO
        pmp$delay (100, ignore_status);
      WHILEND;
      osp$set_mainframe_sig_lock (qfv$kjl_lock);

    WHILEND;

{ Make sure that the job did not disappear since the KJL was unlocked.  If it did, present the caller with
{ an error to say that the job is gone.

    job_name_has_changed := jmv$kjl_p^ [kjl_index].system_job_name <> system_job_name;
  PROCEND get_job_from_scheduler;
?? OLDTITLE ??
?? NEWTITLE := 'notify_input_application', EJECT ??

{ PURPOSE:
{   The purpose of this request is to ready an input application's control task.
{
{ NOTES:
{   The Known Job List (KJL) should be locked when this request is issued in order to ensure that
{ the global_task_id in the KJL's application table is valid.  If it isn't, the result will be to
{ cause a task to become ready before its scheduled time.  This is not generally a problem.
{ With this in mind, it is okay to make this request without the KJL locked, but it is preferred to
{ have the structure locked.

  PROCEDURE notify_input_application
    (    application_index: jmt$input_application_index;
         kjl_index: jmt$kjl_index);

    VAR
      ignore_status: ost$status;

    IF application_index <> jmc$unassigned_input_index THEN
      IF application_index = jmc$ve_input_application_index THEN
        jmp$notify_job_scheduler_of_job (jmv$kjl_p^ [kjl_index].job_class, kjl_index);
      ELSE
        pmp$ready_task (jmv$known_job_list.application_table [application_index].global_task_id,
              ignore_status);
      IFEND;
    IFEND;
  PROCEND notify_input_application;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] ve_job', EJECT ??

{ PURPOSE:
{   This function indicates if the job is a NOS/VE job rather than a job destined for a remote system.

  FUNCTION [INLINE] ve_job
    (    kjl_index: jmt$kjl_index): boolean;

    ve_job := jmv$kjlx_p^ [kjl_index].input_file_location <> jmc$ifl_store_and_forward_queue;
  FUNCEND ve_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$activate_deferred_family', EJECT ??
*copy qfh$activate_deferred_family

{ NOTE:
{   This request is only meaningful for NOS/VE jobs that are destined for the job scheduler.

  PROCEDURE [XDCL, #GATE] qfp$activate_deferred_family
    (    family_name: ost$name);

    VAR
      current_clock_time: jmt$clock_time,
      deferred_job: boolean,
      kjl_index: jmt$kjl_index,
      next_kjl_index: jmt$kjl_index;

    current_clock_time := #FREE_RUNNING_CLOCK (0);
    osp$set_mainframe_sig_lock (qfv$kjl_lock);

{ Scan the deferred thread for jobs that are deferred because their login family is not available.
{ If the job is not deferred for any other reason, requeue the job and notify the scheduler.

    kjl_index := jmv$known_job_list.state_data [jmc$kjl_deferred_entry].first_entry;
    WHILE kjl_index <> jmc$kjl_undefined_index DO
      next_kjl_index := jmv$kjl_p^ [kjl_index].forward_link;
      IF ve_job (kjl_index) AND (jmv$kjlx_p^ [kjl_index].login_user_identification.family = family_name) THEN
        jmv$kjl_p^ [kjl_index].login_family_available := TRUE;
        deferred_job := (current_clock_time < jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate) OR
              jmv$kjl_p^ [kjl_index].job_deferred_by_operator OR jmv$kjl_p^ [kjl_index].job_deferred_by_user;

        IF NOT deferred_job THEN
          qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_queued_entry);
          qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index, jmc$kjl_application_new);
          notify_input_application (jmc$ve_input_application_index, kjl_index);
        IFEND;
      IFEND;
      kjl_index := next_kjl_index;
    WHILEND;

    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$activate_deferred_family;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$change_input_attributes', EJECT ??
*copy qfh$change_input_attributes

  PROCEDURE [XDCL, #GATE] qfp$change_input_attributes
    (    system_label: jmt$job_system_label;
         job_class: jmt$job_class;
         privileged_job: boolean;
         earliest_clock_time_to_initiate: jmt$clock_time;
         latest_clock_time_to_initiate: jmt$clock_time;
         current_clock_time: jmt$clock_time;
         valid_mainframe_set: jmt$valid_mainframe_set;
     VAR status: ost$status);

    VAR
      application_index: jmt$input_application_index,
      deferred_job: boolean,
      entry_kind: jmt$kjl_entry_kind,
      ignore_status: ost$status,
      job_name_has_changed: boolean,
      kjl_index: jmt$kjl_index,
      profile_mismatch: boolean,
      system_job_name: jmt$system_supplied_name,
      time_deferred_job: boolean;

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);

  /find_entry_in_kjl/
    FOR entry_kind := LOWERVALUE (entry_kind) TO UPPERVALUE (entry_kind) DO
      IF entry_kind IN $jmt$kjl_entry_kind_set [jmc$kjl_deferred_entry, jmc$kjl_queued_entry] THEN
        kjl_index := jmv$known_job_list.state_data [entry_kind].first_entry;
        WHILE kjl_index <> jmc$kjl_undefined_index DO
          IF (jmv$kjl_p^ [kjl_index].system_job_name = system_label.system_job_name) THEN
            EXIT /find_entry_in_kjl/;
          ELSE
            kjl_index := jmv$kjl_p^ [kjl_index].forward_link;
          IFEND;
        WHILEND;
      IFEND;
    FOREND /find_entry_in_kjl/;

{ If the entry was not in the KJL then something is wrong.

    IF kjl_index = jmc$kjl_undefined_index THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_label.system_job_name,
            status);
      osp$clear_mainframe_sig_lock (qfv$kjl_lock);
      RETURN;
    IFEND;

{ If the job is assigned to another mainframe its attributes cannot be changed.

    IF jmv$kjl_p^ [kjl_index].client_index > jmc$kjl_client_this_mainframe THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$input_is_initiated, system_label.system_job_name,
            status);
      osp$clear_mainframe_sig_lock (qfv$kjl_lock);
      RETURN;
    IFEND;

    find_destination_usage (jmv$kjl_p^ [kjl_index].destination_usage, application_index);
    system_job_name := jmv$kjl_p^ [kjl_index].system_job_name;

{ get the job from the job scheduler in case it has the job.

    get_job_from_scheduler (kjl_index, jmc$kjl_application_modified, job_name_has_changed);
    IF job_name_has_changed THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_job_name, status);
      osp$clear_mainframe_sig_lock (qfv$kjl_lock);
      RETURN;
    IFEND;

{ Check if the scheduling profile structure has changed since the job class was selected.

    qfp$check_for_profile_mismatch (system_label.active_profile_version, profile_mismatch);
    IF profile_mismatch OR jmv$sched_profile_is_loading THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$scheduling_profile_changed, '', status);
    ELSE

      jmv$kjl_p^ [kjl_index].user_job_name := system_label.user_job_name;
      IF NOT privileged_job THEN
        jmv$kjl_p^ [kjl_index].job_submission_time := current_clock_time;
      IFEND;
      jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate := earliest_clock_time_to_initiate;
      jmv$kjl_p^ [kjl_index].job_category_set := system_label.job_category_set;
      jmv$kjl_p^ [kjl_index].job_priority := 0;
      jmv$kjl_p^ [kjl_index].job_deferred_by_operator := system_label.job_deferred_by_operator;
      jmv$kjl_p^ [kjl_index].job_deferred_by_user := system_label.job_deferred_by_user;

      jmv$kjl_p^ [kjl_index].next_destination_usage := system_label.job_destination_usage;
      jmv$kjlx_p^ [kjl_index].latest_clock_time_to_initiate := latest_clock_time_to_initiate;

      jmv$kjlx_p^ [kjl_index].output_disposition_key := system_label.job_attributes.output_disposition_key;
      jmv$kjlx_p^ [kjl_index].valid_mainframe_set := valid_mainframe_set;

{ Is the job a deferred job??

      time_deferred_job := (current_clock_time < earliest_clock_time_to_initiate);
      deferred_job := time_deferred_job OR system_label.job_deferred_by_operator OR
            system_label.job_deferred_by_user OR (NOT jmv$kjl_p^ [kjl_index].login_family_available);
      IF deferred_job AND (jmv$kjl_p^ [kjl_index].application_state <= jmc$kjl_application_new) THEN
        IF time_deferred_job AND (earliest_clock_time_to_initiate < jmv$time_to_ready_deferred_job) THEN
          jmv$time_to_ready_deferred_job := earliest_clock_time_to_initiate;
        IFEND;
        qfp$relink_kjl_entry (kjl_index, job_class, jmc$kjl_deferred_entry);
        IF jmv$kjl_p^ [kjl_index].application_state = jmc$kjl_application_new THEN

{ The application index on this request is unimportant since the target is unused.

          qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_unused);
        IFEND;
        jmv$kjl_p^ [kjl_index].destination_usage := jmv$kjl_p^ [kjl_index].next_destination_usage;

      ELSE
        IF jmv$kjl_p^ [kjl_index].application_state > jmc$kjl_application_new THEN

{ If the destination has changed or the job is now deferred it must be taken away
{ from the application.  Note that since the job is acquired, it must be taken away
{ using the application protocol.  Therefore any state transitions, e.g. going to
{ deferred will take place when the application returns the job.

          IF (jmv$kjl_p^ [kjl_index].destination_usage = jmv$kjl_p^ [kjl_index].next_destination_usage) AND
                (NOT deferred_job) THEN
            qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_modified);
          ELSE
            qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_terminated);
          IFEND;
        ELSE
          qfp$relink_kjl_entry (kjl_index, job_class, jmc$kjl_queued_entry);
          find_destination_usage (jmv$kjl_p^ [kjl_index].next_destination_usage, application_index);
          qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_new);
          jmv$kjl_p^ [kjl_index].destination_usage := jmv$kjl_p^ [kjl_index].next_destination_usage;
        IFEND;
        notify_input_application (application_index, kjl_index);
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$change_input_attributes;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$defer_deactivated_family', EJECT ??
*copy qfh$defer_deactivated_family

{ NOTE:
{   This request is only meaningful for NOS/VE jobs that are destined for the job scheduler.
{   This request will not defer leveled jobs.

  PROCEDURE [XDCL, #GATE] qfp$defer_deactivated_family
    (    family_name: ost$name);

    VAR
      current_clock_time: jmt$clock_time,
      deferred_job: boolean,
      kjl_entry_kind: jmt$kjl_entry_kind,
      kjl_index: jmt$kjl_index,
      next_kjl_index: jmt$kjl_index;

    current_clock_time := #FREE_RUNNING_CLOCK (0);
    osp$set_mainframe_sig_lock (qfv$kjl_lock);

{ Take all jobs away from the job scheduler.

    jmp$force_candidate_refresh ({ flush_candidate_queue } TRUE);

{ Scan the deferred and queued threads for jobs that need to be deferred because their
{ login family is not available.  If the job belongs the another mainframe (a leveled job)
{ do not defer it.  Let the job leveler task deal with it.

    FOR kjl_entry_kind := LOWERVALUE (jmt$kjl_entry_kind) TO UPPERVALUE (jmt$kjl_entry_kind) DO
      IF kjl_entry_kind IN $jmt$kjl_entry_kind_set [jmc$kjl_deferred_entry, jmc$kjl_queued_entry] THEN
        kjl_index := jmv$known_job_list.state_data [kjl_entry_kind].first_entry;
        WHILE kjl_index <> jmc$kjl_undefined_index DO
          next_kjl_index := jmv$kjl_p^ [kjl_index].forward_link;
          IF ve_job (kjl_index) AND (jmv$kjlx_p^ [kjl_index].login_user_identification.family =
                family_name) AND (jmv$kjl_p^ [kjl_index].server_index = jmc$kjl_server_this_mainframe) THEN
            jmv$kjl_p^ [kjl_index].login_family_available := FALSE;
            IF kjl_entry_kind <> jmc$kjl_deferred_entry THEN
              qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_deferred_entry);
              qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index,
                    jmc$kjl_application_unused);
            IFEND;
          IFEND;
          kjl_index := next_kjl_index;
        WHILEND;
      IFEND
    FOREND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$defer_deactivated_family;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] qfp$relink_kjl_application', EJECT ??
*copy qfh$relink_kjl_application

{ DESIGN:
{   Upon entry to the procedure, the KJL entry contains the destination_usage and application_state that
{ defines the application thread that the entry belongs to.  The entry is removed from this thread and
{ added to the thread described by the application_index and destination_state supplied on the request.
{

  PROCEDURE [XDCL] qfp$relink_kjl_application
    (    kjl_index: jmt$kjl_index;
         destination_application_index: jmt$input_application_index;
         destination_state: jmt$kjl_application_state);

    VAR
      source_state: jmt$kjl_application_state,
      source_application_index: jmt$input_application_index;

    find_destination_usage (jmv$kjl_p^ [kjl_index].destination_usage, source_application_index);
    source_state := jmv$kjl_p^ [kjl_index].application_state;

    CASE source_state OF
    = jmc$kjl_application_unused =
      ;

    ELSE

{ Delete the entry from its application thread.

      IF jmv$kjl_p^ [kjl_index].application_reverse_link = jmc$kjl_undefined_index THEN
        jmv$known_job_list.application_table [source_application_index].state_data [source_state].
              first_entry := jmv$kjl_p^ [kjl_index].application_forward_link;
      ELSE
        jmv$kjl_p^ [jmv$kjl_p^ [kjl_index].application_reverse_link].
              application_forward_link := jmv$kjl_p^ [kjl_index].application_forward_link;
      IFEND;

      IF jmv$kjl_p^ [kjl_index].application_forward_link = jmc$kjl_undefined_index THEN
        jmv$known_job_list.application_table [source_application_index].state_data [source_state].
              last_entry := jmv$kjl_p^ [kjl_index].application_reverse_link;
      ELSE
        jmv$kjl_p^ [jmv$kjl_p^ [kjl_index].application_forward_link].
              application_reverse_link := jmv$kjl_p^ [kjl_index].application_reverse_link;
      IFEND;

{ Decrement the count for the application/state thread

      jmv$known_job_list.application_table [source_application_index].state_data [source_state].
            number_of_entries := jmv$known_job_list.application_table [source_application_index].
            state_data [source_state].number_of_entries - 1;
    CASEND;


    CASE destination_state OF

    = jmc$kjl_application_unused =

{ Make the entry unused.

      jmv$kjl_p^ [kjl_index].application_reverse_link := jmc$kjl_undefined_index;
      jmv$kjl_p^ [kjl_index].application_forward_link := jmc$kjl_undefined_index;

    ELSE

{ Insert the entry at the end of the destination thread.

      IF jmv$known_job_list.application_table [destination_application_index].state_data [destination_state].
            last_entry = jmc$kjl_undefined_index THEN
        jmv$kjl_p^ [kjl_index].application_reverse_link := jmc$kjl_undefined_index;
        jmv$kjl_p^ [kjl_index].application_forward_link := jmc$kjl_undefined_index;
        jmv$known_job_list.application_table [destination_application_index].state_data [destination_state].
              first_entry := kjl_index;
        jmv$known_job_list.application_table [destination_application_index].state_data [destination_state].
              last_entry := kjl_index;
      ELSE
        jmv$kjl_p^ [kjl_index].application_reverse_link := jmv$known_job_list.
              application_table [destination_application_index].state_data [destination_state].last_entry;
        jmv$kjl_p^ [jmv$known_job_list.application_table [destination_application_index].
              state_data [destination_state].last_entry].application_forward_link := kjl_index;
        jmv$kjl_p^ [kjl_index].application_forward_link := jmc$kjl_undefined_index;
        jmv$known_job_list.application_table [destination_application_index].state_data [destination_state].
              last_entry := kjl_index;
      IFEND;

{ Increment the count of the number of entries in the state

      jmv$known_job_list.application_table [destination_application_index].state_data [destination_state].
            number_of_entries := jmv$known_job_list.application_table [destination_application_index].
            state_data [destination_state].number_of_entries + 1;
    CASEND;

    jmv$kjl_p^ [kjl_index].application_state := destination_state;
  PROCEND qfp$relink_kjl_application;
?? TITLE := '[XDCL] qfp$relink_kjl_client', EJECT ??
*copy qfh$relink_kjl_client

  PROCEDURE [XDCL] qfp$relink_kjl_client
    (    kjl_index: jmt$kjl_index;
         destination_client_index: jmt$kjl_client_index);

    VAR
      source_client_index: jmt$kjl_client_index;

    source_client_index := jmv$kjl_p^ [kjl_index].client_index;

{ Remove the entry from the client "source" thread

    IF source_client_index <> jmc$kjl_client_undefined THEN
      IF jmv$kjl_p^ [kjl_index].client_reverse_link = jmc$kjl_undefined_index THEN
        jmv$known_job_list.client_data.state_data [source_client_index].first_entry :=
              jmv$kjl_p^ [kjl_index].client_forward_link;
      ELSE
        jmv$kjl_p^ [jmv$kjl_p^ [kjl_index].client_reverse_link].client_forward_link :=
              jmv$kjl_p^ [kjl_index].client_forward_link;
      IFEND;

      IF jmv$kjl_p^ [kjl_index].client_forward_link = jmc$kjl_undefined_index THEN
        jmv$known_job_list.client_data.state_data [source_client_index].last_entry :=
              jmv$kjl_p^ [kjl_index].client_reverse_link;
      ELSE
        jmv$kjl_p^ [jmv$kjl_p^ [kjl_index].client_forward_link].client_reverse_link :=
              jmv$kjl_p^ [kjl_index].client_reverse_link;
      IFEND;

{ Decrement the count for the client thread

      jmv$known_job_list.client_data.state_data [source_client_index].number_of_entries :=
            jmv$known_job_list.client_data.state_data [source_client_index].number_of_entries - 1;
    IFEND;

{ Add the entry to the destination client thread

    IF destination_client_index = jmc$kjl_client_undefined THEN
      jmv$kjl_p^ [kjl_index].client_reverse_link := jmc$kjl_undefined_index;
      jmv$kjl_p^ [kjl_index].client_forward_link := jmc$kjl_undefined_index;

    ELSE

{ Insert the entry at the end of the destination thread.

      IF jmv$known_job_list.client_data.state_data [destination_client_index].last_entry =
            jmc$kjl_undefined_index THEN
        jmv$kjl_p^ [kjl_index].client_reverse_link := jmc$kjl_undefined_index;
        jmv$kjl_p^ [kjl_index].client_forward_link := jmc$kjl_undefined_index;
        jmv$known_job_list.client_data.state_data [destination_client_index].first_entry := kjl_index;
        jmv$known_job_list.client_data.state_data [destination_client_index].last_entry := kjl_index;
      ELSE
        jmv$kjl_p^ [kjl_index].client_reverse_link := jmv$known_job_list.client_data.
              state_data [destination_client_index].last_entry;
        jmv$kjl_p^ [jmv$known_job_list.client_data.state_data [destination_client_index].last_entry].
              client_forward_link := kjl_index;
        jmv$kjl_p^ [kjl_index].client_forward_link := jmc$kjl_undefined_index;
        jmv$known_job_list.client_data.state_data [destination_client_index].last_entry := kjl_index;
      IFEND;

{ Increment the count of the number of entries for the client

      jmv$known_job_list.client_data.state_data [destination_client_index].number_of_entries :=
            jmv$known_job_list.client_data.state_data [destination_client_index].number_of_entries + 1;
    IFEND;

    jmv$kjl_p^ [kjl_index].client_index := destination_client_index;
  PROCEND qfp$relink_kjl_client;
?? TITLE := '[XDCL] qfp$relink_kjl_entry', EJECT ??
*copy qfh$relink_kjl_entry

{ DESIGN:
{   The entry state in the KJL entry is used to determine the state thread that the entry is currently in.
{   The entry state chain is maintained as a doubly linked list so it can be searched backwards.
{
{   The job class thread is ordered by job priority.  So whenever an entry is added to KJL it is placed
{   in the job class thread at the proper position.

  PROCEDURE [XDCL] qfp$relink_kjl_entry
    (    kjl_index: jmt$kjl_index;
         destination_job_class: jmt$job_class;
         destination_entry_kind: jmt$kjl_entry_kind);

    VAR
      bias_priority: integer,
      current_microsecond_clock: jmt$clock_time,
      insertion_index: jmt$kjl_index,
      job_priority: integer,
      source_job_class: jmt$job_class,
      source_entry_kind: jmt$kjl_entry_kind,
      ve_destined_job: boolean;

?? NEWTITLE := '[INLINE] job_selection_priority', EJECT ??

{ PURPOSE:
{   Calculate a jobs priority without restricting it to the jmt$job_priority
{   type range.

    FUNCTION [INLINE] job_selection_priority
      (    kjl_index: jmt$kjl_index): integer;

      IF kjl_index = jmc$kjl_undefined_index THEN
        job_selection_priority := 0;
      ELSEIF jmv$job_class_table_p^ [destination_job_class].initiation_age_interval <>
            jmc$unlimited_prio_age_interval THEN
        job_selection_priority := ((current_microsecond_clock - jmv$kjl_p^ [kjl_index].job_submission_time) *
              jmv$job_class_table_p^ [destination_job_class].selection_priority.increment DIV
              jmv$job_class_table_p^ [destination_job_class].initiation_age_interval) +
              jmv$kjl_p^ [kjl_index].priority_bias;
      ELSE
        job_selection_priority := jmv$kjl_p^ [kjl_index].priority_bias;
      IFEND;
    FUNCEND job_selection_priority;

?? OLDTITLE, EJECT ??

    osp$set_mainframe_sig_lock (jmv$job_counts_lock);

    ve_destined_job := ve_job (kjl_index);
    source_job_class := jmv$kjl_p^ [kjl_index].job_class;
    source_entry_kind := jmv$kjl_p^ [kjl_index].entry_kind;

{ Delete the entry from its thread

    IF jmv$kjl_p^ [kjl_index].reverse_link = jmc$kjl_undefined_index THEN
      jmv$known_job_list.state_data [source_entry_kind].first_entry := jmv$kjl_p^ [kjl_index].forward_link;
    ELSE
      jmv$kjl_p^ [jmv$kjl_p^ [kjl_index].reverse_link].forward_link := jmv$kjl_p^ [kjl_index].forward_link;
    IFEND;

    IF jmv$kjl_p^ [kjl_index].forward_link = jmc$kjl_undefined_index THEN
      jmv$known_job_list.state_data [source_entry_kind].last_entry := jmv$kjl_p^ [kjl_index].reverse_link;
    ELSE
      jmv$kjl_p^ [jmv$kjl_p^ [kjl_index].forward_link].reverse_link := jmv$kjl_p^ [kjl_index].reverse_link;
    IFEND;

{ Decrement the count of the number of entries in the state

    jmv$known_job_list.state_data [source_entry_kind].number_of_entries := jmv$known_job_list.
          state_data [source_entry_kind].number_of_entries - 1;

{ If the job is in the queued state it must be removed from the job class thread
{ and the counts must be updated.

    CASE source_entry_kind OF
    = jmc$kjl_queued_entry =

{ The job is only entered into the job class thread if it is a VE job.

      IF ve_destined_job THEN
        IF jmv$kjl_p^ [kjl_index].class_reverse_link = jmc$kjl_undefined_index THEN
          jmv$known_job_list.queued_class_entries [source_job_class].
                first_queued_class_entry := jmv$kjl_p^ [kjl_index].class_forward_link;
        ELSE
          jmv$kjl_p^ [jmv$kjl_p^ [kjl_index].class_reverse_link].class_forward_link :=
                jmv$kjl_p^ [kjl_index].class_forward_link;
        IFEND;

        IF jmv$kjl_p^ [kjl_index].class_forward_link = jmc$kjl_undefined_index THEN
          jmv$known_job_list.queued_class_entries [source_job_class].
                last_queued_class_entry := jmv$kjl_p^ [kjl_index].class_reverse_link;
        ELSE
          jmv$kjl_p^ [jmv$kjl_p^ [kjl_index].class_forward_link].class_reverse_link :=
                jmv$kjl_p^ [kjl_index].class_reverse_link;
        IFEND;
        jmv$kjl_p^ [kjl_index].class_forward_link := jmc$kjl_undefined_index;
        jmv$kjl_p^ [kjl_index].class_reverse_link := jmc$kjl_undefined_index;
        jmv$job_counts.job_class_counts [source_job_class].queued_jobs := jmv$job_counts.
              job_class_counts [source_job_class].queued_jobs - 1;
        jmv$job_counts.queued_jobs := jmv$job_counts.queued_jobs - 1;
      IFEND; { ve_destined_job

    ELSE
      ;
    CASEND;

{ Add the entry to the destination thread.

    CASE destination_entry_kind OF

    = jmc$kjl_unused_entry =

{ First, zero out the entry.

      pmp$zero_out_table (^jmv$kjl_p^ [kjl_index], #SIZE (jmv$kjl_p^ [kjl_index]));

{ Insert in the "unused" thread.  Trace backwards to find the next previous unused entry to insert after.

      insertion_index := kjl_index - 1;
      WHILE (insertion_index <> jmc$kjl_undefined_index) AND
            (jmv$kjl_p^ [insertion_index].entry_kind <> jmc$kjl_unused_entry) DO
        insertion_index := insertion_index - 1;
      WHILEND;
      IF insertion_index = jmc$kjl_undefined_index THEN

{ Insert at the "head" of the unused thread

        jmv$kjl_p^ [kjl_index].reverse_link := jmc$kjl_undefined_index;
        jmv$kjl_p^ [kjl_index].forward_link := jmv$known_job_list.state_data [jmc$kjl_unused_entry].
              first_entry;
        jmv$known_job_list.state_data [jmc$kjl_unused_entry].first_entry := kjl_index;
        IF jmv$kjl_p^ [kjl_index].forward_link <> jmc$kjl_undefined_index THEN
          jmv$kjl_p^ [jmv$kjl_p^ [kjl_index].forward_link].reverse_link := kjl_index;
        IFEND;
      ELSE

{ Insert in the unused thread.

        jmv$kjl_p^ [kjl_index].reverse_link := insertion_index;
        jmv$kjl_p^ [kjl_index].forward_link := jmv$kjl_p^ [insertion_index].forward_link;
        IF jmv$kjl_p^ [kjl_index].forward_link <> jmc$kjl_undefined_index THEN
          jmv$kjl_p^ [jmv$kjl_p^ [kjl_index].forward_link].reverse_link := kjl_index;
        IFEND;
        jmv$kjl_p^ [insertion_index].forward_link := kjl_index;
      IFEND;

    ELSE

{ Insert at the end of the destination thread.

      IF jmv$known_job_list.state_data [destination_entry_kind].last_entry = jmc$kjl_undefined_index THEN
        jmv$kjl_p^ [kjl_index].reverse_link := jmc$kjl_undefined_index;
        jmv$kjl_p^ [kjl_index].forward_link := jmc$kjl_undefined_index;
        jmv$known_job_list.state_data [destination_entry_kind].first_entry := kjl_index;
        jmv$known_job_list.state_data [destination_entry_kind].last_entry := kjl_index;
      ELSE
        jmv$kjl_p^ [kjl_index].reverse_link := jmv$known_job_list.state_data [destination_entry_kind].
              last_entry;
        jmv$kjl_p^ [jmv$known_job_list.state_data [destination_entry_kind].last_entry].forward_link :=
              kjl_index;
        jmv$kjl_p^ [kjl_index].forward_link := jmc$kjl_undefined_index;
        jmv$known_job_list.state_data [destination_entry_kind].last_entry := kjl_index;
      IFEND;
    CASEND;

{ Increment the count for the destination thread.

    jmv$known_job_list.state_data [destination_entry_kind].number_of_entries :=
          jmv$known_job_list.state_data [destination_entry_kind].number_of_entries + 1;

{ The entry must be inserted in the class thread and job counts must be updated.

    CASE destination_entry_kind OF
    = jmc$kjl_queued_entry =
      IF ve_destined_job THEN
        jmv$job_counts.queued_jobs := jmv$job_counts.queued_jobs + 1;
        jmv$job_counts.job_class_counts [destination_job_class].queued_jobs :=
              jmv$job_counts.job_class_counts [destination_job_class].queued_jobs + 1;

{ If the job is a ve job it needs to be placed in the job class thread at the appropriate
{ priority position.  It is assumed that the job being entered is lower priority than all
{ other jobs in the class so start searching for an insertion location at the end of the
{ job class thread.

        current_microsecond_clock := #FREE_RUNNING_CLOCK (0);
        jmv$kjl_p^ [kjl_index].priority_bias := 0;
        job_priority := job_selection_priority (kjl_index);
        insertion_index := jmv$known_job_list.queued_class_entries [destination_job_class].
              last_queued_class_entry;

{ If the job class defines a multiple job bias then check if any jobs were
{ submitted by this user within the bias limit.

        IF (insertion_index <> jmc$kjl_undefined_index) AND
              (jmv$job_class_table_p^ [destination_job_class].multiple_job_bias > 0) THEN
          bias_priority := job_priority + jmv$job_class_table_p^ [destination_job_class].multiple_job_bias;

{ Skip over any jobs submitted after this job was.

          WHILE (insertion_index <> jmc$kjl_undefined_index) AND
                (jmv$kjl_p^ [insertion_index].job_submission_time > jmv$kjl_p^ [kjl_index].
                job_submission_time) OR (jmv$kjlx_p^ [insertion_index].login_user_identification <>
                jmv$kjlx_p^ [kjl_index].login_user_identification) AND
                (job_priority > job_selection_priority (insertion_index)) DO
            insertion_index := jmv$kjl_p^ [insertion_index].class_reverse_link;
          WHILEND;

{ Now, scan backwards either until a job is found with a large enough priority
{ to be outside the multiple_job_bias range or a job of with the same user
{ identification is found.  If the second condition occurs, then we must apply
{ a bias to the new job so its priority is multiple_job_bias less then the job
{ just found.

          WHILE (insertion_index <> jmc$kjl_undefined_index) AND
                (bias_priority > job_selection_priority (insertion_index)) DO
            IF jmv$kjlx_p^ [insertion_index].login_user_identification =
                  jmv$kjlx_p^ [kjl_index].login_user_identification THEN
              jmv$kjl_p^ [kjl_index].priority_bias := job_selection_priority (insertion_index) -
                    bias_priority;
              job_priority := job_priority + jmv$kjl_p^ [kjl_index].priority_bias;
              insertion_index := jmc$kjl_undefined_index;
            ELSE
              insertion_index := jmv$kjl_p^ [insertion_index].class_reverse_link;
            IFEND;
          WHILEND;
          insertion_index := jmv$known_job_list.queued_class_entries [destination_job_class].
                last_queued_class_entry;
        IFEND;

{ Scan backwards until a job until a job of equal or greater priority is found.

        WHILE (insertion_index <> jmc$kjl_undefined_index) AND
              (job_priority > job_selection_priority (insertion_index)) DO
          insertion_index := jmv$kjl_p^ [insertion_index].class_reverse_link;
        WHILEND;

{ Skip jobs of equal priority that have a later submittion time.

        WHILE (insertion_index <> jmc$kjl_undefined_index) AND
              (job_priority = job_selection_priority (insertion_index)) AND
              (jmv$kjl_p^ [insertion_index].job_submission_time > jmv$kjl_p^ [kjl_index].
              job_submission_time) DO
          insertion_index := jmv$kjl_p^ [insertion_index].class_reverse_link;
        WHILEND;

        IF insertion_index = jmc$kjl_undefined_index THEN

{ Insert at the head of the job class thread.

          jmv$kjl_p^ [kjl_index].class_reverse_link := jmc$kjl_undefined_index;
          jmv$kjl_p^ [kjl_index].class_forward_link := jmv$known_job_list.
                queued_class_entries [destination_job_class].first_queued_class_entry;
          jmv$known_job_list.queued_class_entries [destination_job_class].first_queued_class_entry :=
                kjl_index;
          IF jmv$kjl_p^ [kjl_index].class_forward_link = jmc$kjl_undefined_index THEN
            jmv$known_job_list.queued_class_entries [destination_job_class].last_queued_class_entry :=
                  kjl_index;
          ELSE
            jmv$kjl_p^ [jmv$kjl_p^ [kjl_index].class_forward_link].class_reverse_link := kjl_index;
          IFEND;
        ELSE

{ Insert in the job class thread.

          jmv$kjl_p^ [kjl_index].class_forward_link := jmv$kjl_p^ [insertion_index].class_forward_link;
          jmv$kjl_p^ [kjl_index].class_reverse_link := insertion_index;
          IF jmv$kjl_p^ [kjl_index].class_forward_link = jmc$kjl_undefined_index THEN
            jmv$known_job_list.queued_class_entries [destination_job_class].last_queued_class_entry :=
                  kjl_index;
          ELSE
            jmv$kjl_p^ [jmv$kjl_p^ [kjl_index].class_forward_link].class_reverse_link := kjl_index;
          IFEND;
          jmv$kjl_p^ [insertion_index].class_forward_link := kjl_index;
        IFEND;
      IFEND;

    ELSE
      ;
    CASEND;

    jmv$kjl_p^ [kjl_index].entry_kind := destination_entry_kind;
    jmv$kjl_p^ [kjl_index].job_class := destination_job_class;
    osp$clear_mainframe_sig_lock (jmv$job_counts_lock);

  PROCEND qfp$relink_kjl_entry;
?? TITLE := '[XDCL, #GATE] qfp$relink_kjl_server', EJECT ??
*copy qfh$relink_kjl_server

  PROCEDURE [XDCL, #GATE] qfp$relink_kjl_server
    (    kjl_index: jmt$kjl_index;
         destination_server_index: jmt$kjl_server_index);

    VAR
      source_server_index: jmt$kjl_server_index;

    source_server_index := jmv$kjl_p^ [kjl_index].server_index;

{ Remove the entry from the server "source" thread

    IF source_server_index <> jmc$kjl_server_undefined THEN
      IF jmv$kjl_p^ [kjl_index].server_reverse_link = jmc$kjl_undefined_index THEN
        jmv$known_job_list.server_data.state_data [source_server_index].first_entry :=
              jmv$kjl_p^ [kjl_index].server_forward_link;
      ELSE
        jmv$kjl_p^ [jmv$kjl_p^ [kjl_index].server_reverse_link].server_forward_link :=
              jmv$kjl_p^ [kjl_index].server_forward_link;
      IFEND;

      IF jmv$kjl_p^ [kjl_index].server_forward_link = jmc$kjl_undefined_index THEN
        jmv$known_job_list.server_data.state_data [source_server_index].last_entry :=
              jmv$kjl_p^ [kjl_index].server_reverse_link;
      ELSE
        jmv$kjl_p^ [jmv$kjl_p^ [kjl_index].server_forward_link].server_reverse_link :=
              jmv$kjl_p^ [kjl_index].server_reverse_link;
      IFEND;

{ Decrement the count for the server thread

      jmv$known_job_list.server_data.state_data [source_server_index].number_of_entries :=
            jmv$known_job_list.server_data.state_data [source_server_index].number_of_entries - 1;
    IFEND;

{ Add the entry to the destination server thread

    IF destination_server_index = jmc$kjl_server_undefined THEN
      jmv$kjl_p^ [kjl_index].server_reverse_link := jmc$kjl_undefined_index;
      jmv$kjl_p^ [kjl_index].server_forward_link := jmc$kjl_undefined_index;

    ELSE

{ Insert the entry at the end of the destination thread.

      IF jmv$known_job_list.server_data.state_data [destination_server_index].last_entry =
            jmc$kjl_undefined_index THEN
        jmv$kjl_p^ [kjl_index].server_reverse_link := jmc$kjl_undefined_index;
        jmv$kjl_p^ [kjl_index].server_forward_link := jmc$kjl_undefined_index;
        jmv$known_job_list.server_data.state_data [destination_server_index].first_entry := kjl_index;
        jmv$known_job_list.server_data.state_data [destination_server_index].last_entry := kjl_index;
      ELSE
        jmv$kjl_p^ [kjl_index].server_reverse_link := jmv$known_job_list.server_data.
              state_data [destination_server_index].last_entry;
        jmv$kjl_p^ [jmv$known_job_list.server_data.state_data [destination_server_index].last_entry].
              server_forward_link := kjl_index;
        jmv$kjl_p^ [kjl_index].server_forward_link := jmc$kjl_undefined_index;
        jmv$known_job_list.server_data.state_data [destination_server_index].last_entry := kjl_index;
      IFEND;

{ Increment the count of the number of entries for the server

      jmv$known_job_list.server_data.state_data [destination_server_index].number_of_entries :=
            jmv$known_job_list.server_data.state_data [destination_server_index].number_of_entries + 1;
    IFEND;

    jmv$kjl_p^ [kjl_index].server_index := destination_server_index;
  PROCEND qfp$relink_kjl_server;
?? TITLE := 'validate_application_access', EJECT ??

{ PURPOSE:
{    This request will validate that the executing task is the legitimate user of the destination usage
{  specified.  The index into the application table for the specified destination_usage is returned.
{

  PROCEDURE validate_application_access
    (    destination_usage: jmt$destination_usage;
     VAR application_index: jmt$input_application_index;
     VAR status: ost$status);

    VAR
      global_task_id: ost$global_task_id;

    status.normal := TRUE;
    find_destination_usage (destination_usage, application_index);
    IF application_index = jmc$unassigned_input_index THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$destination_usage_incorrect, destination_usage,
            status);
    ELSE
      pmp$get_executing_task_gtid (global_task_id);
      IF global_task_id <> jmv$known_job_list.application_table [application_index].global_task_id THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$application_not_permitted, destination_usage,
              status);
      IFEND;
    IFEND;
  PROCEND validate_application_access;
?? TITLE := '[XDCL, #GATE] jmp$record_job_attributes', EJECT ??
*copy jmh$record_job_attributes

  PROCEDURE [XDCL, #GATE] jmp$record_job_attributes
    (    job_attributes_p: ^jmt$job_attributes;
         job_recovery_information_p: ^jmt$job_recovery_information;
     VAR status: ost$status);

    VAR
      kjl_index: jmt$kjl_index;


    PROCEDURE scch
      (    mf: ost$monitor_fault;
           ctc: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$clear_mainframe_sig_lock (qfv$kjl_lock);
      osp$monitor_fault_to_status (mf, ctc, status);
      EXIT jmp$record_job_attributes;
    PROCEND scch;

    status.normal := TRUE;
    kjl_index := jmv$jcb.job_id;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);
    syp$establish_condition_handler (^scch);
    jmv$kjlx_p^ [kjl_index].job_controller := job_attributes_p^.job_controller;
    jmv$kjlx_p^ [kjl_index].originating_ssn := job_attributes_p^.originating_ssn;
    jmv$kjlx_p^ [kjl_index].timesharing_job := (job_attributes_p^.originating_application_name =
          osc$timesharing);
    jmv$kjlx_p^ [kjl_index].output_disposition_key := job_attributes_p^.output_disposition_key;
    jmv$kjlx_p^ [kjl_index].job_initiation_time := job_attributes_p^.job_initiation_time;
    IF jmv$kjlx_p^ [kjl_index].job_mode <> jmc$batch THEN
      ALLOCATE jmv$kjlx_p^ [kjl_index].system_label_p IN osv$mainframe_pageable_heap^;
      jmv$kjlx_p^ [kjl_index].system_label_p^ := job_recovery_information_p^.job_system_label;
    ELSE
      jmv$kjlx_p^ [kjl_index].system_label_p := NIL;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND jmp$record_job_attributes;
?? TITLE := '[XDCL, #GATE] jmp$set_job_history_state', EJECT ??
*copy jmh$set_job_history_state

  PROCEDURE [XDCL, #GATE] jmp$set_job_history_state
    (    state: boolean);

    jmv$job_history_active := state;

  PROCEND jmp$set_job_history_state;
?? TITLE := '[XDCL, #GATE] jmp$set_job_mode', EJECT ??
*copy jmh$set_job_mode

  PROCEDURE [XDCL, #GATE] jmp$set_job_mode
    (    mode: jmt$job_mode;
     VAR status: ost$status);

    status.normal := TRUE;

    jmv$jcb.ijle_p^.job_mode := mode;
    jmv$kjlx_p^ [jmv$jcb.job_id].job_mode := mode;
    IF mode IN $jmt$job_mode_set [jmc$interactive_cmnd_disconnect, jmc$interactive_line_disconnect,
          jmc$interactive_sys_disconnect] THEN
      jmv$kjlx_p^ [jmv$jcb.job_id].terminal_name := osc$null_name;
    IFEND;
  PROCEND jmp$set_job_mode;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$acquire_modified_input', EJECT ??
*copy qfh$acquire_modified_input

  PROCEDURE [XDCL, #GATE] qfp$acquire_modified_input
    (    job_destination_usage: jmt$destination_usage;
     VAR input_descriptor: jmt$input_descriptor;
     VAR status: ost$status);

    VAR
      application_index: jmt$input_application_index,
      kjl_index: jmt$kjl_index;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    validate_application_access (job_destination_usage, application_index, status);
    IF status.normal THEN
      kjl_index := jmv$known_job_list.application_table [application_index].
            state_data [jmc$kjl_application_modified].first_entry;
      IF kjl_index <> jmc$kjl_undefined_index THEN
        input_descriptor.system_job_name := jmv$kjl_p^ [kjl_index].system_job_name;
        input_descriptor.user_job_name := jmv$kjl_p^ [kjl_index].user_job_name;
        qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_acquired);
      ELSE
        osp$set_status_abnormal (jmc$job_management_id, jme$input_queue_is_empty, '', status);
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$acquire_modified_input;
?? TITLE := '[XDCL, #GATE] qfp$acquire_new_input', EJECT ??
*copy qfh$acquire_new_input

  PROCEDURE [XDCL, #GATE] qfp$acquire_new_input
    (    job_destination_usage: jmt$destination_usage;
     VAR input_descriptor: jmt$input_descriptor;
     VAR status: ost$status);

    VAR
      application_index: jmt$input_application_index,
      kjl_index: jmt$kjl_index;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    validate_application_access (job_destination_usage, application_index, status);
    IF status.normal THEN
      kjl_index := jmv$known_job_list.application_table [application_index].
            state_data [jmc$kjl_application_new].first_entry;
      IF kjl_index <> jmc$kjl_undefined_index THEN
        input_descriptor.system_job_name := jmv$kjl_p^ [kjl_index].system_job_name;
        input_descriptor.user_job_name := jmv$kjl_p^ [kjl_index].user_job_name;
        qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_acquired);
      ELSE
        osp$set_status_abnormal (jmc$job_management_id, jme$input_queue_is_empty, '', status);
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$acquire_new_input;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$change_terminate_job_action', EJECT ??
*copy qfh$change_terminate_job_action

  PROCEDURE [XDCL, #GATE] qfp$change_terminate_job_action
    (    terminate_job_action_set: jmt$terminate_job_action_set);

    qfv$terminate_job_action_set := terminate_job_action_set;
  PROCEND qfp$change_terminate_job_action;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$discard_job', EJECT ??
*copy qfh$discard_job

  PROCEDURE [XDCL, #GATE] qfp$discard_job;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    qfp$relink_kjl_entry (jmv$jcb.job_id, jmv$kjl_p^ [jmv$jcb.job_id].job_class, jmc$kjl_terminated_entry);
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$discard_job;
?? TITLE := '[XDCL, #GATE] qfp$discard_job_output', EJECT ??
*copy qfh$discard_job_output

  PROCEDURE [XDCL, #GATE] qfp$discard_job_output
    (    output_disposition_key: jmt$output_disposition_keys);

    osp$set_mainframe_sig_lock (qfv$kjl_lock);
    jmv$kjlx_p^ [jmv$jcb.job_id].output_disposition_key := output_disposition_key;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$discard_job_output;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$expand_kjl', EJECT ??
*copy qfh$expand_kjl

{ NOTES:
{   The KJL must be locked when this request is issued.  The only exception to
{ this is during system recovery when access to the KJL is synchronous.

  PROCEDURE [XDCL, #GATE] qfp$expand_kjl;

    CONST
      expand_increment = 100;

    VAR
      kjl_index: jmt$kjl_index,
      new_kjl_limit: jmt$kjl_index;

    IF qfv$current_kjl_limit < jmc$kjl_maximum_entries THEN
      IF qfv$current_kjl_limit + expand_increment > jmc$kjl_maximum_entries THEN
        new_kjl_limit := jmc$kjl_maximum_entries;
      ELSE
        new_kjl_limit := qfv$current_kjl_limit + expand_increment;
      IFEND;
      FOR kjl_index := qfv$current_kjl_limit + 1 TO new_kjl_limit - 1 DO
        jmv$kjl_p^ [kjl_index].forward_link := kjl_index + 1;
        jmv$kjl_p^ [kjl_index].reverse_link := kjl_index - 1;
        jmv$kjl_p^ [kjl_index].entry_kind := jmc$kjl_unused_entry;
      FOREND;
      jmv$kjl_p^ [new_kjl_limit].forward_link := jmc$kjl_undefined_index;
      jmv$kjl_p^ [new_kjl_limit].reverse_link := new_kjl_limit - 1;
      jmv$kjl_p^ [new_kjl_limit].entry_kind := jmc$kjl_unused_entry;

      jmv$known_job_list.state_data [jmc$kjl_unused_entry].number_of_entries :=
            jmv$known_job_list.state_data [jmc$kjl_unused_entry].number_of_entries + new_kjl_limit -
            qfv$current_kjl_limit;
      IF jmv$known_job_list.state_data [jmc$kjl_unused_entry].first_entry = jmc$kjl_undefined_index THEN
        jmv$known_job_list.state_data [jmc$kjl_unused_entry].first_entry := qfv$current_kjl_limit + 1;
        jmv$kjl_p^ [qfv$current_kjl_limit + 1].reverse_link := jmc$kjl_undefined_index;
        jmv$known_job_list.state_data [jmc$kjl_unused_entry].last_entry := new_kjl_limit;

      ELSE
        jmv$kjl_p^ [qfv$current_kjl_limit + 1].reverse_link := jmv$known_job_list.
              state_data [jmc$kjl_unused_entry].last_entry;
        jmv$kjl_p^ [jmv$known_job_list.state_data [jmc$kjl_unused_entry].last_entry].forward_link :=
              qfv$current_kjl_limit + 1;
        jmv$known_job_list.state_data [jmc$kjl_unused_entry].last_entry := new_kjl_limit;
      IFEND;
      qfv$current_kjl_limit := new_kjl_limit;
    IFEND;
  PROCEND qfp$expand_kjl;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$get_input_file_location', EJECT ??
*copy qfh$get_input_file_location

{ DESIGN:
{   Use kjl_search to get the job's kjl_index.  Return the input file location
{ and login family from the kjl entry.

  PROCEDURE [XDCL, #GATE] qfp$get_input_file_location
    (    system_job_name: jmt$system_supplied_name;
     VAR location: jmt$input_file_location;
     VAR family: ost$family_name;
     VAR status: ost$status);

    VAR
      kjl_index: jmt$kjl_index;

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    kjl_search (system_job_name, -$jmt$kjl_entry_kind_set [], kjl_index);
    IF kjl_index = jmc$kjl_undefined_index THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_job_name, status);
    ELSE
      location := jmv$kjlx_p^ [kjl_index].input_file_location;
      family := jmv$kjlx_p^ [kjl_index].login_user_identification.family;
    IFEND;

    osp$clear_mainframe_sig_lock (qfv$kjl_lock);

  PROCEND qfp$get_input_file_location;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$get_input_q_from_unassigned', EJECT ??
*copy qfh$get_input_q_from_unassigned

  PROCEDURE [XDCL, #GATE] qfp$get_input_q_from_unassigned
    (VAR system_supplied_names: array [1 .. * ] of jmt$system_supplied_name;
     VAR number_of_jobs_found: integer;
     VAR status: ost$status);

    VAR
      kjl_index: jmt$kjl_index,
      result_size: integer;

    status.normal := TRUE;
    number_of_jobs_found := 0;
    result_size := UPPERBOUND (system_supplied_names);

    osp$set_mainframe_sig_lock (qfv$kjl_lock);

{ Scan the UNASSIGNED job class thread for input jobs.  Jobs in a class thread
{ have a destination_usage of VE.

    kjl_index := jmv$known_job_list.queued_class_entries [jmc$unassigned_job_class].first_queued_class_entry;
    WHILE kjl_index <> jmc$kjl_undefined_index DO
      number_of_jobs_found := number_of_jobs_found + 1;
      IF number_of_jobs_found <= result_size THEN
        system_supplied_names [number_of_jobs_found] := jmv$kjl_p^ [kjl_index].system_job_name;
      IFEND;
      kjl_index := jmv$kjl_p^ [kjl_index].class_forward_link;
    WHILEND;

{ Scan the deferred thread for input jobs in the UNASSIGNED job class which
{ are VE jobs.

    kjl_index := jmv$known_job_list.state_data [jmc$kjl_deferred_entry].first_entry;
    WHILE kjl_index <> jmc$kjl_undefined_index DO
      IF jmv$kjl_p^ [kjl_index].job_class = jmc$unassigned_job_class THEN
        IF ve_job (kjl_index) THEN
          number_of_jobs_found := number_of_jobs_found + 1;
          IF number_of_jobs_found <= result_size THEN
            system_supplied_names [number_of_jobs_found] := jmv$kjl_p^ [kjl_index].system_job_name;
          IFEND;
        IFEND;
      IFEND;
      kjl_index := jmv$kjl_p^ [kjl_index].forward_link;
    WHILEND;

    osp$clear_mainframe_sig_lock (qfv$kjl_lock);

  PROCEND qfp$get_input_q_from_unassigned;
?? TITLE := '[XDCL, #GATE] qfp$get_job_counts', EJECT ??
*copy qfh$get_job_counts

  PROCEDURE [XDCL, #GATE] qfp$get_job_counts
    (VAR job_counts: jmt$job_counts);

    osp$set_mainframe_sig_lock (jmv$job_counts_lock);
    job_counts := jmv$job_counts;
    osp$clear_mainframe_sig_lock (jmv$job_counts_lock);
  PROCEND qfp$get_job_counts;
?? TITLE := '[XDCL, #GATE] qfp$get_job_internal_info', EJECT ??
*copy qfh$get_job_internal_info

  PROCEDURE [XDCL, #GATE] qfp$get_job_internal_info
    (    system_job_name: jmt$system_supplied_name;
     VAR job_internal_info: jmt$job_internal_information;
     VAR status: ost$status);

    VAR
      entry_kind: jmt$kjl_entry_kind,
      kjl_index: jmt$kjl_index;

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    FOR entry_kind := SUCC (jmc$kjl_unused_entry) TO UPPERVALUE (entry_kind) DO
      IF entry_kind IN $jmt$kjl_entry_kind_set [jmc$kjl_initiated_entry, jmc$kjl_terminated_entry] THEN

        kjl_index := jmv$known_job_list.state_data [entry_kind].first_entry;

      /search_for_ssn/
        WHILE kjl_index <> jmc$kjl_undefined_index DO

          IF jmv$kjl_p^ [kjl_index].system_job_name = system_job_name THEN
            job_internal_info.jmtr_global_taskid := jmv$kjlx_p^ [kjl_index].job_monitor_global_task_id;
            job_internal_info.job_mode := jmv$kjlx_p^ [kjl_index].job_mode;
            job_internal_info.ijl_ordinal := jmv$kjl_p^ [kjl_index].initiated_job_list_ordinal;
            job_internal_info.timesharing_job := jmv$kjlx_p^ [kjl_index].timesharing_job;
            osp$clear_mainframe_sig_lock (qfv$kjl_lock);
            RETURN;
          IFEND;

          kjl_index := jmv$kjl_p^ [kjl_index].forward_link;
        WHILEND /search_for_ssn/;
      IFEND;
    FOREND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
    osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_job_name, status);
  PROCEND qfp$get_job_internal_info;
?? TITLE := '[XDCL, #GATE] qfp$get_job_status', EJECT ??
*copy qfh$get_job_status

  PROCEDURE [XDCL, #GATE] qfp$get_job_status
    (    user_identification: ost$user_identification;
         caller_ssn: jmt$system_supplied_name;
         privileged_job: boolean;
         valid_for_scheduling_displays: boolean;
         status_options: ^jmt$job_status_options;
         status_results_keys_p: ^jmt$results_keys;
     VAR status_results_seq_p: ^jmt$work_area;
     VAR number_of_jobs_found: jmt$job_status_count;
     VAR status: ost$status);

    VAR
      ijl_entry_p: ^jmt$initiated_job_list_entry,
      job_class_kjl_index: jmt$kjl_index,
      job_state: jmt$job_state,
      job_state_set: jmt$job_state_set,
      kjl_entry_kind: jmt$kjl_entry_kind,
      kjl_index: jmt$kjl_index,
      name_index: ost$positive_integers,
      option_index: ost$positive_integers,
      qualified_entry_found: boolean,
      result_index: ost$positive_integers,
      status_results_seq_full: boolean;

?? NEWTITLE := 'add_job_to_status_result_seq', EJECT ??

{ PURPOSE:
{   The purpose of this request is to add a job to the job status results
{   sequence supplied on the request.

    PROCEDURE add_job_to_status_results_seq
      (    status_results_keys_p: ^jmt$results_keys;
       VAR status_results_seq_p: ^jmt$work_area;
       VAR status_results_seq_full: boolean);

      VAR
        client_index: jmt$kjl_client_index,
        boolean_p: ^boolean,
        cpu_time_used_p: ^jmt$cpu_time_used,
        display_message_p: ^jmt$display_message,
        ignore_status: ost$status,
        input_file_location_p: ^jmt$input_file_location,
        internal_index_p: ^integer,
        job_class_position_p: ^jmt$job_count_range,
        job_initiation_time_p: ^jmt$date_time,
        job_mode_p: ^jmt$job_mode,
        job_state_p: ^jmt$job_state,
        job_tape_mount_attempts: integer,
        job_tape_mounts_active: boolean,
        local_status: ost$status,
        mainframe_id_p: ^pmt$mainframe_id,
        name_value_p: ^ost$name,
        operator_action_posted_p: ^boolean,
        page_faults_p: ^jmt$page_faults,
        system_job_name_p: ^jmt$system_supplied_name;


      IF status_results_keys_p <> NIL THEN

      /fill_in_each_status_result/
        FOR result_index := 1 TO UPPERBOUND (status_results_keys_p^) DO
          CASE status_results_keys_p^ [result_index] OF

          = jmc$client_mainframe_id =
            NEXT mainframe_id_p IN status_results_seq_p;
            IF mainframe_id_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;

{ The client index in the KJL will be jmc$kjl_client_undefined if the job is not
{ assigned to the job scheduler (or initiated).  If the job was assigned by a server
{ mainframe, then return this mainframe's identifier as the client mainframe id.

            client_index := jmv$kjl_p^ [kjl_index].client_index;
            IF jmv$kjl_p^ [kjl_index].server_index > jmc$kjl_server_this_mainframe THEN
              client_index := jmc$kjl_client_this_mainframe;
            IFEND;
            IF client_index > jmc$kjl_client_undefined THEN
              pmp$convert_binary_mainframe_id (jmv$known_job_list.client_data.state_data [client_index].
                    mainframe_id, mainframe_id_p^, { ignore } local_status);
            ELSE
              mainframe_id_p^ := '';
            IFEND;

          = jmc$control_family =
            NEXT name_value_p IN status_results_seq_p;
            IF name_value_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            name_value_p^ := jmv$kjlx_p^ [kjl_index].job_controller.family;

          = jmc$control_user =
            NEXT name_value_p IN status_results_seq_p;
            IF name_value_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            name_value_p^ := jmv$kjlx_p^ [kjl_index].job_controller.user;

          = jmc$cpu_time_used =
            NEXT cpu_time_used_p IN status_results_seq_p;
            IF cpu_time_used_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            IF (job_state IN $jmt$job_state_set [jmc$initiated_job, jmc$terminating_job]) AND
                  ve_job (kjl_index) THEN
              jmp$get_ijle_p (jmv$kjl_p^ [kjl_index].initiated_job_list_ordinal, ijl_entry_p);
              cpu_time_used_p^.job_mode_time := ijl_entry_p^.statistics.cp_time.time_spent_in_job_mode DIV
                    1000;
              cpu_time_used_p^.monitor_mode_time := ijl_entry_p^.statistics.cp_time.time_spent_in_mtr_mode DIV
                    1000;
            ELSE
              cpu_time_used_p^.job_mode_time := 0;
              cpu_time_used_p^.monitor_mode_time := 0;
            IFEND;

          = jmc$display_message =
            NEXT display_message_p IN status_results_seq_p;
            IF display_message_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            IF (job_state IN $jmt$job_state_set [jmc$initiated_job, jmc$terminating_job]) AND
                  ve_job (kjl_index) THEN
              jmp$get_ijle_p (jmv$kjl_p^ [kjl_index].initiated_job_list_ordinal, ijl_entry_p);
              display_message_p^.size := ijl_entry_p^.display_message.display_message.size;
              display_message_p^.value := ijl_entry_p^.display_message.display_message.text;

            ELSEIF jmv$kjl_p^ [kjl_index].entry_kind = jmc$kjl_deferred_entry THEN
              IF NOT jmv$kjl_p^ [kjl_index].login_family_available THEN
                display_message_p^.size := STRLENGTH (jmc$dm_login_family_unavailable);
                display_message_p^.value := jmc$dm_login_family_unavailable;
              ELSEIF jmv$kjl_p^ [kjl_index].job_deferred_by_operator THEN
                display_message_p^.size := STRLENGTH (jmc$dm_job_deferred_by_operator);
                display_message_p^.value := jmc$dm_job_deferred_by_operator;
              ELSEIF jmv$kjl_p^ [kjl_index].job_deferred_by_user THEN
                display_message_p^.size := STRLENGTH (jmc$dm_job_deferred_by_user);
                display_message_p^.value := jmc$dm_job_deferred_by_user;
              ELSE { IF jmv$kjl_p^ [kjl_index].earliest_run_time < current_clock_time THEN
                display_message_p^.size := STRLENGTH (jmc$dm_waiting_for_ert);
                display_message_p^.value := jmc$dm_waiting_for_ert;
              IFEND;
            ELSE
              display_message_p^.size := 0;
              display_message_p^.value := '';
            IFEND;

          = jmc$input_file_location =
            NEXT input_file_location_p IN status_results_seq_p;
            IF input_file_location_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            input_file_location_p^ := jmv$kjlx_p^ [kjl_index].input_file_location;

          = jmc$internal_index =
            NEXT internal_index_p IN status_results_seq_p;
            IF internal_index_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            internal_index_p^ := kjl_index;

          = jmc$job_class =
            NEXT name_value_p IN status_results_seq_p;
            IF name_value_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            IF ve_job (kjl_index) THEN
              jmp$determine_job_class_name (jmv$kjl_p^ [kjl_index].job_class, name_value_p^, local_status);
              IF NOT local_status.normal THEN
                name_value_p^ := jmc$unknown_class_name;
              IFEND;
            ELSE
              name_value_p^ := jmc$unknown_class_name;
            IFEND;

          = jmc$job_class_position =
            NEXT job_class_position_p IN status_results_seq_p;
            IF job_class_position_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            IF (job_state = jmc$queued_job) AND ve_job (kjl_index) AND valid_for_scheduling_displays THEN
              job_class_position_p^ := 1;
              job_class_kjl_index := jmv$known_job_list.queued_class_entries
                    [jmv$kjl_p^ [kjl_index].job_class].first_queued_class_entry;
              WHILE (job_class_kjl_index <> kjl_index) AND (job_class_kjl_index <> jmc$kjl_undefined_index) DO
                job_class_position_p^ := job_class_position_p^ +1;
                job_class_kjl_index := jmv$kjl_p^ [job_class_kjl_index].class_forward_link;
              WHILEND;
            ELSE
              job_class_position_p^ := 0;
            IFEND;

          = jmc$job_deferred_by_operator =
            NEXT boolean_p IN status_results_seq_p;
            IF boolean_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            boolean_p^ := jmv$kjl_p^ [kjl_index].job_deferred_by_operator;

          = jmc$job_deferred_by_user =
            NEXT boolean_p IN status_results_seq_p;
            IF boolean_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            boolean_p^ := jmv$kjl_p^ [kjl_index].job_deferred_by_user;

          = jmc$job_destination_usage =
            NEXT name_value_p IN status_results_seq_p;
            IF name_value_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            name_value_p^ := jmv$kjl_p^ [kjl_index].destination_usage;

          = jmc$job_initiation_time =
            NEXT job_initiation_time_p IN status_results_seq_p;
            IF job_initiation_time_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            IF (job_state IN $jmt$job_state_set [jmc$initiated_job, jmc$terminating_job]) AND
                  ve_job (kjl_index) THEN
              job_initiation_time_p^.date_time := jmv$kjlx_p^ [kjl_index].job_initiation_time;
              job_initiation_time_p^.specified := TRUE;
            ELSE
              job_initiation_time_p^.specified := FALSE;
            IFEND;

          = jmc$job_mode =
            NEXT job_mode_p IN status_results_seq_p;
            IF job_mode_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            job_mode_p^ := jmv$kjlx_p^ [kjl_index].job_mode;

          = jmc$job_state =
            NEXT job_state_p IN status_results_seq_p;
            IF job_state_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            job_state_p^ := job_state;

          = jmc$login_family =
            NEXT name_value_p IN status_results_seq_p;
            IF name_value_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            name_value_p^ := jmv$kjlx_p^ [kjl_index].login_user_identification.family;

          = jmc$login_user =
            NEXT name_value_p IN status_results_seq_p;
            IF name_value_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            name_value_p^ := jmv$kjlx_p^ [kjl_index].login_user_identification.user;

          = jmc$null_attribute =
            ;

          = jmc$operator_action_posted =
            NEXT operator_action_posted_p IN status_results_seq_p;
            IF operator_action_posted_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;

          /get_job_tape_mounts_active/
            FOR job_tape_mount_attempts := 1 TO max_job_tape_mount_attempts DO
              job_tape_mounts_active := FALSE;
              iop$job_tape_mounts_active (jmv$kjl_p^ [kjl_index].system_job_name, job_tape_mounts_active,
                    local_status);
              IF NOT local_status.normal AND (local_status.condition = dme$unable_to_lock_tape_table) THEN
                pmp$delay (one_second, ignore_status);
              ELSE
                EXIT /get_job_tape_mounts_active/;
              IFEND;
            FOREND;

            IF ((ofp$job_operator_msgs_active (jmv$kjl_p^ [kjl_index].system_job_name)) OR
                  (ofp$job_operator_menus_active (jmv$kjl_p^ [kjl_index].system_job_name)) OR
                  job_tape_mounts_active) THEN
              operator_action_posted_p^ := TRUE;
            ELSE
              operator_action_posted_p^ := FALSE;
            IFEND;

          = jmc$page_faults =
            NEXT page_faults_p IN status_results_seq_p;
            IF page_faults_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            IF (job_state IN $jmt$job_state_set [jmc$initiated_job, jmc$terminating_job]) AND
                  ve_job (kjl_index) THEN
              jmp$get_ijle_p (jmv$kjl_p^ [kjl_index].initiated_job_list_ordinal, ijl_entry_p);
              page_faults_p^.pages_reclaimed_from_memory := ijl_entry_p^.statistics.paging_statistics.
                    pages_reclaimed_from_queue;
              page_faults_p^.pages_read_from_disk := ijl_entry_p^.statistics.paging_statistics.page_in_count;
              page_faults_p^.new_pages_assigned := ijl_entry_p^.statistics.paging_statistics.
                    new_pages_assigned;
            ELSE
              page_faults_p^.pages_reclaimed_from_memory := 0;
              page_faults_p^.pages_read_from_disk := 0;
              page_faults_p^.new_pages_assigned := 0;
            IFEND;

          = jmc$server_mainframe_id =
            NEXT mainframe_id_p IN status_results_seq_p;
            IF mainframe_id_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            IF jmv$kjl_p^ [kjl_index].server_index > jmc$kjl_server_undefined THEN
              pmp$convert_binary_mainframe_id (jmv$known_job_list.server_data.
                    state_data [jmv$kjl_p^ [kjl_index].server_index].mainframe_id, mainframe_id_p^,
                    { ignore } local_status);
            ELSE
              pmp$get_mainframe_id (mainframe_id_p^, { ignore } local_status);
            IFEND;

          = jmc$system_job_name =
            NEXT system_job_name_p IN status_results_seq_p;
            IF system_job_name_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            system_job_name_p^ := jmv$kjl_p^ [kjl_index].system_job_name;

          = jmc$user_job_name =
            NEXT name_value_p IN status_results_seq_p;
            IF name_value_p = NIL THEN
              status_results_seq_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            name_value_p^ := jmv$kjl_p^ [kjl_index].user_job_name;

          ELSE
          CASEND;
        FOREND /fill_in_each_status_result/;
      IFEND;
    PROCEND add_job_to_status_results_seq;
?? OLDTITLE ??
?? NEWTITLE := 'handle_core_condition', EJECT ??

    PROCEDURE handle_core_condition
      (    monitor_fault: ost$monitor_fault;
           minimum_save_area_p: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      VAR
        lock_status: ost$signature_lock_status;

      osp$test_sig_lock (qfv$kjl_lock, lock_status);
      IF lock_status = osc$sls_locked_by_current_task THEN
        osp$clear_mainframe_sig_lock (qfv$kjl_lock);
      IFEND;
      syp$continue_to_cause (monitor_fault, minimum_save_area_p, syc$condition_processed, continue);
      osp$monitor_fault_to_status (monitor_fault, minimum_save_area_p, status);
      EXIT qfp$get_job_status;
    PROCEND handle_core_condition;
?? OLDTITLE ??
?? EJECT ??
    syp$establish_condition_handler (^handle_core_condition);
    status.normal := TRUE;
    number_of_jobs_found := 0;
    status_results_seq_full := status_results_seq_p = NIL;

    job_state_set := -$jmt$job_state_set [];
    IF status_options <> NIL THEN
      FOR option_index := 1 TO UPPERBOUND (status_options^) DO
        IF status_options^ [option_index].key = jmc$job_state_set THEN
          job_state_set := status_options^ [option_index].job_state_set;
        IFEND;
      FOREND;
    IFEND;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);

  /search_each_entry_kind/
    FOR job_state := LOWERVALUE (job_state) TO UPPERVALUE (job_state) DO

      IF job_state IN job_state_set THEN
        convert_state_to_entry_kind (job_state, kjl_entry_kind, status);
        IF NOT status.normal THEN
          EXIT /search_each_entry_kind/;
        IFEND;
        kjl_index := jmv$known_job_list.state_data [kjl_entry_kind].first_entry;

      /search_each_entry/
        WHILE kjl_index <> jmc$kjl_undefined_index DO
          IF (jmv$kjlx_p^ [kjl_index].login_user_identification = user_identification) OR
                (jmv$kjlx_p^ [kjl_index].job_controller = user_identification) OR privileged_job OR
                (jmv$kjlx_p^ [kjl_index].originating_ssn = caller_ssn) THEN

            qualified_entry_found := TRUE;
            IF status_options <> NIL THEN

            /status_option_check/
              FOR option_index := 1 TO UPPERBOUND (status_options^) DO
                CASE status_options^ [option_index].key OF

                = jmc$control_family =
                  IF status_options^ [option_index].control_family <>
                        jmv$kjlx_p^ [kjl_index].job_controller.family THEN
                    qualified_entry_found := FALSE;
                    EXIT /status_option_check/;
                  IFEND;

                = jmc$control_user =
                  IF status_options^ [option_index].control_user <>
                        jmv$kjlx_p^ [kjl_index].job_controller.user THEN
                    qualified_entry_found := FALSE;
                    EXIT /status_option_check/;
                  IFEND;

                = jmc$include_the_system_job =

{ The default is to include the status of the system job if the caller is privileged to see it.
{ The caller must specify this option if it does not want information about the system job.  Note
{ that if the default were not to include the system job, checking for the status options would
{ have to be done independently of the status options check.

                  IF NOT status_options^ [option_index].include_the_system_job THEN
                    IF jmv$kjl_p^ [kjl_index].system_job_name = jmv$system_job_ssn THEN
                      qualified_entry_found := FALSE;
                      EXIT /status_option_check/;
                    IFEND;
                  IFEND;

                = jmc$job_deferred_by_operator =
                  IF jmv$kjl_p^ [kjl_index].job_deferred_by_operator <>
                        status_options^ [option_index].job_deferred_by_operator THEN
                    qualified_entry_found := FALSE;
                    EXIT /status_option_check/;
                  IFEND;

                = jmc$job_deferred_by_user =
                  IF jmv$kjl_p^ [kjl_index].job_deferred_by_user <>
                        status_options^ [option_index].job_deferred_by_user THEN
                    qualified_entry_found := FALSE;
                    EXIT /status_option_check/;
                  IFEND;

                = jmc$job_mode_set =
                  IF NOT (jmv$kjlx_p^ [kjl_index].job_mode IN status_options^ [option_index].job_mode_set)
                        THEN
                    qualified_entry_found := FALSE;
                    EXIT /status_option_check/;
                  IFEND;

                = jmc$job_state_set =
                  ;

                = jmc$login_family =
                  IF status_options^ [option_index].login_family <>
                        jmv$kjlx_p^ [kjl_index].login_user_identification.family THEN
                    qualified_entry_found := FALSE;
                    EXIT /status_option_check/;
                  IFEND;

                = jmc$login_user =
                  IF status_options^ [option_index].login_user <>
                        jmv$kjlx_p^ [kjl_index].login_user_identification.user THEN
                    qualified_entry_found := FALSE;
                    EXIT /status_option_check/;
                  IFEND;

                = jmc$name_list =
                  IF status_options^ [option_index].name_list <> NIL THEN
                    qualified_entry_found := FALSE;

                  /search_for_name/
                    FOR name_index := 1 TO UPPERBOUND (status_options^ [option_index].name_list^) DO
                      CASE status_options^ [option_index].name_list^ [name_index].kind OF
                      = jmc$system_supplied_name =
                        IF status_options^ [option_index].name_list^ [name_index].system_supplied_name =
                              jmv$kjl_p^ [kjl_index].system_job_name THEN
                          qualified_entry_found := TRUE;
                          EXIT /search_for_name/;
                        IFEND;

                      = jmc$user_supplied_name =
                        IF status_options^ [option_index].name_list^ [name_index].user_supplied_name =
                              jmv$kjl_p^ [kjl_index].user_job_name THEN
                          qualified_entry_found := TRUE;
                          EXIT /search_for_name/;
                        IFEND;

                      ELSE
                        ; { Nothing
                      CASEND;
                    FOREND /search_for_name/;
                    IF NOT qualified_entry_found THEN
                      EXIT /status_option_check/;
                    IFEND;
                  IFEND;

                = jmc$null_attribute =
                  ;

                ELSE
                CASEND;
              FOREND /status_option_check/;
            IFEND;

{ Only return status of jobs that are on their client mainframe.  So if the job
{ is assigned to another client do not return the job's status.

            IF jmv$kjl_p^ [kjl_index].client_index > jmc$kjl_client_this_mainframe THEN
              qualified_entry_found := FALSE;
            IFEND;

            IF qualified_entry_found THEN
              IF (NOT status_results_seq_full) THEN
                add_job_to_status_results_seq (status_results_keys_p, status_results_seq_p,
                      status_results_seq_full);
              IFEND;
              number_of_jobs_found := number_of_jobs_found + 1;
            IFEND; { qualified_entry_found
          IFEND;

          kjl_index := jmv$kjl_p^ [kjl_index].forward_link;
        WHILEND /search_each_entry/;
      IFEND;
    FOREND /search_each_entry_kind/;

    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
    syp$disestablish_cond_handler;
  PROCEND qfp$get_job_status;
?? TITLE := 'kjl_search', EJECT ??

{ PURPOSE:
{   The purpose of this request is to search the Known Job List for the specified system job name.
{   and return the job's kjl_index.  The kjl_index of jmc$kjl_undefined_index is returned if the
{   job is not found.

  PROCEDURE kjl_search
    (    system_job_name: jmt$system_supplied_name;
         entry_kind_set: jmt$kjl_entry_kind_set;
     VAR kjl_index: jmt$kjl_index);

    VAR
      kjl_entry_kind: jmt$kjl_entry_kind;

    kjl_index := jmc$kjl_undefined_index;

  /kjl_search_each_entry_kind/
    FOR kjl_entry_kind := SUCC (LOWERVALUE (kjl_entry_kind)) TO UPPERVALUE (kjl_entry_kind) DO
      IF kjl_entry_kind IN entry_kind_set THEN
        kjl_index := jmv$known_job_list.state_data [kjl_entry_kind].first_entry;

        WHILE kjl_index <> jmc$kjl_undefined_index DO
          IF (jmv$kjl_p^ [kjl_index].system_job_name = system_job_name) THEN
            EXIT /kjl_search_each_entry_kind/;
          IFEND;
          kjl_index := jmv$kjl_p^ [kjl_index].forward_link;
        WHILEND;
      IFEND;
    FOREND /kjl_search_each_entry_kind/;
  PROCEND kjl_search;
?? TITLE := '[XDCL, #GATE] qfp$job_requests_restart: boolean', EJECT ??
*copy qfh$job_requests_restart

  FUNCTION [XDCL, #GATE] qfp$job_requests_restart: boolean;

    VAR
      ijl_entry_p: ^jmt$initiated_job_list_entry;

    jmp$get_ijle_p (jmv$kjl_p^ [jmv$jcb.job_id].initiated_job_list_ordinal, ijl_entry_p);
    qfp$job_requests_restart := ijl_entry_p^.queue_file_information.job_abort_disposition =
          jmc$restart_on_abort;
  FUNCEND qfp$job_requests_restart;
?? TITLE := '[XDCL, #GATE] qfp$list_jobs_via_mode', EJECT ??
*copy qfh$list_jobs_via_mode

  PROCEDURE [XDCL, #GATE] qfp$list_jobs_via_mode
    (    job_mode: jmt$job_mode;
     VAR system_job_names: array [1 .. * ] of jmt$system_supplied_name;
     VAR number_of_jobs_returned: integer;
     VAR status: ost$status);

    VAR
      kjl_index: jmt$kjl_index;

    status.normal := TRUE;
    number_of_jobs_returned := 0;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);
    kjl_index := jmv$known_job_list.state_data [jmc$kjl_initiated_entry].first_entry;

    WHILE kjl_index <> jmc$kjl_undefined_index DO
      IF jmv$kjlx_p^ [kjl_index].job_mode = job_mode THEN
        IF number_of_jobs_returned < UPPERBOUND (system_job_names) THEN
          number_of_jobs_returned := number_of_jobs_returned + 1;
          system_job_names [number_of_jobs_returned] := jmv$kjl_p^ [kjl_index].system_job_name;
        IFEND;
      IFEND;

      kjl_index := jmv$kjl_p^ [kjl_index].forward_link;
    WHILEND;

    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$list_jobs_via_mode;
?? TITLE := '[XDCL, #GATE] qfp$move_input_q_to_unassigned', EJECT ??
*copy qfh$move_input_q_to_unassigned

  PROCEDURE [XDCL, #GATE] qfp$move_input_q_to_unassigned
    (    job_class_index: jmt$job_class;
     VAR number_of_jobs_moved: jmt$job_count_range;
     VAR status: ost$status);

    VAR
      job_not_moved: boolean,
      kjl_index: jmt$kjl_index,
      next_kjl_index: jmt$kjl_index;

    status.normal := TRUE;
    number_of_jobs_moved := 0;
    job_not_moved := FALSE;

    IF (job_class_index = jmc$unassigned_job_class) THEN
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);

{ Scan the given job class thread for input jobs and move them to the UNASSIGNED
{ job class.

    kjl_index := jmv$known_job_list.queued_class_entries [job_class_index].first_queued_class_entry;
    WHILE kjl_index <> jmc$kjl_undefined_index DO
      next_kjl_index := jmv$kjl_p^ [kjl_index].class_forward_link;
      IF jmv$kjl_p^ [kjl_index].application_state = jmc$kjl_application_new THEN
        qfp$relink_kjl_entry (kjl_index, jmc$unassigned_job_class, jmc$kjl_queued_entry);
        number_of_jobs_moved := number_of_jobs_moved + 1;
      ELSE
        job_not_moved := TRUE;
      IFEND;
      kjl_index := next_kjl_index;
    WHILEND;

{ Scan the deferred thread for input jobs in the UNASSIGNED job class which
{ have are VE jobs.

    kjl_index := jmv$known_job_list.state_data [jmc$kjl_deferred_entry].first_entry;
    WHILE kjl_index <> jmc$kjl_undefined_index DO
      next_kjl_index := jmv$kjl_p^ [kjl_index].forward_link;
      IF jmv$kjl_p^ [kjl_index].job_class = job_class_index THEN
        IF ve_job (kjl_index) THEN
          jmv$kjl_p^ [kjl_index].job_class := jmc$unassigned_job_class;
          number_of_jobs_moved := number_of_jobs_moved + 1;
        IFEND;
      IFEND;
      kjl_index := next_kjl_index;
    WHILEND;

    osp$clear_mainframe_sig_lock (qfv$kjl_lock);

    IF job_not_moved THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$not_all_jobs_were_moved,
            jmv$job_class_table_p^ [job_class_index].name, status);
    IFEND;

  PROCEND qfp$move_input_q_to_unassigned;
?? TITLE := '[XDCL, #GATE] qfp$ready_deferred_job', EJECT ??
*copy qfh$ready_deferred_job

  PROCEDURE [XDCL, #GATE] qfp$ready_deferred_job;

    VAR
      application_index: jmt$input_application_index,
      current_clock_time: jmt$clock_time,
      kjl_index: jmt$kjl_index,
      next_kjl_index: jmt$kjl_index;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    kjl_index := jmv$known_job_list.state_data [jmc$kjl_deferred_entry].first_entry;
    jmv$time_to_ready_deferred_job := jmc$latest_clock_time;
    current_clock_time := #FREE_RUNNING_CLOCK (0);

    WHILE kjl_index <> jmc$kjl_undefined_index DO
      next_kjl_index := jmv$kjl_p^ [kjl_index].forward_link;
      IF (NOT (jmv$kjl_p^ [kjl_index].job_deferred_by_operator OR jmv$kjl_p^ [kjl_index].
            job_deferred_by_user)) AND jmv$kjl_p^ [kjl_index].login_family_available THEN
        IF jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate >= current_clock_time THEN
          IF jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate < jmv$time_to_ready_deferred_job THEN
            jmv$time_to_ready_deferred_job := jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate;
          IFEND;
        ELSE

{ This job has become a potential candidate for initiation.

          find_destination_usage (jmv$kjl_p^ [kjl_index].destination_usage, application_index);
          qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_queued_entry);
          qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_new);
          notify_input_application (application_index, kjl_index);
        IFEND;
      IFEND;
      kjl_index := next_kjl_index;
    WHILEND;

    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$ready_deferred_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$rebuild_executing_job', EJECT ??
*copy qfh$rebuild_executing_job

{ NOTES:
{   A recovered job uses the same kjl_index it had when it failed.
{   The KJL is expanded in SYM$JOB_RECOVERY_R3 before this request is issued.

  PROCEDURE [XDCL, #GATE] qfp$rebuild_executing_job
    (    current_clock_time: jmt$clock_time;
         system_job_name: jmt$system_supplied_name;
         job_control_block: jmt$job_control_block);

    VAR
      application_index: jmt$input_application_index,
      kjl_index: jmt$kjl_index,
      kjl_server_index: jmt$kjl_server_index;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    kjl_index := job_control_block.job_id;

    jmv$kjl_p^ [kjl_index].system_job_name := system_job_name;
    jmv$kjl_p^ [kjl_index].user_job_name := job_control_block.jobname;
    jmv$kjl_p^ [kjl_index].initiated_job_list_ordinal := job_control_block.ijl_ordinal;
    jmv$kjl_p^ [kjl_index].job_submission_time := current_clock_time;
    jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate := jmc$earliest_clock_time;
    jmv$kjl_p^ [kjl_index].job_class := job_control_block.ijle_p^.job_scheduler_data.job_class;

{ JSE: The job categories for a job must be updated for active job recovery - when they exist.

    jmv$kjl_p^ [kjl_index].job_category_set := $jmt$job_category_set [];
    jmv$kjl_p^ [kjl_index].job_priority := 0;
    jmv$kjl_p^ [kjl_index].job_deferred_by_operator := FALSE;
    jmv$kjl_p^ [kjl_index].job_deferred_by_user := FALSE;
    jmv$kjl_p^ [kjl_index].login_family_available := TRUE;
    jmv$kjl_p^ [kjl_index].destination_usage := jmc$ve_usage;
    jmv$kjl_p^ [kjl_index].next_destination_usage := jmc$ve_usage;
    jmv$kjl_p^ [kjl_index].application_state := jmc$kjl_application_unused;
    jmv$kjl_p^ [kjl_index].class_forward_link := jmc$kjl_undefined_index;
    jmv$kjl_p^ [kjl_index].class_reverse_link := jmc$kjl_undefined_index;
    jmv$kjl_p^ [kjl_index].client_index := jmc$kjl_client_undefined;
    jmv$kjl_p^ [kjl_index].client_forward_link := jmc$kjl_undefined_index;
    jmv$kjl_p^ [kjl_index].client_reverse_link := jmc$kjl_undefined_index;
    jmv$kjl_p^ [kjl_index].server_index := jmc$kjl_server_undefined;
    jmv$kjl_p^ [kjl_index].server_forward_link := jmc$kjl_undefined_index;
    jmv$kjl_p^ [kjl_index].server_reverse_link := jmc$kjl_undefined_index;
    jmv$kjl_p^ [kjl_index].server_kjl_index := kjl_index;
    jmv$kjlx_p^ [kjl_index].login_user_identification := job_control_block.user_id;

{ The job controller, originating ssn, output disposition key and timesharing job are initialized to their
{ correct values in jmp$record_job_attributes.

    jmv$kjlx_p^ [kjl_index].job_controller := job_control_block.user_id;
    jmv$kjlx_p^ [kjl_index].originating_ssn := system_job_name;
    jmv$kjlx_p^ [kjl_index].latest_clock_time_to_initiate := jmc$latest_clock_time;
    jmv$kjlx_p^ [kjl_index].job_mode := job_control_block.ijle_p^.job_mode;
    jmv$kjlx_p^ [kjl_index].job_monitor_global_task_id := job_control_block.job_monitor_id;
    jmv$kjlx_p^ [kjl_index].output_disposition_key := jmc$normal_output_disposition;
    jmv$kjlx_p^ [kjl_index].input_file_location := job_control_block.ijle_p^.queue_file_information.
          input_file_location;
    jmv$kjlx_p^ [kjl_index].valid_mainframe_set := $jmt$valid_mainframe_set [jmc$kjl_server_this_mainframe];
    jmv$kjlx_p^ [kjl_index].timesharing_job := FALSE;
    jmv$kjlx_p^ [kjl_index].restart_job := FALSE;
    jmv$kjlx_p^ [kjl_index].system_label_p := NIL;
    jmv$kjlx_p^ [kjl_index].terminal_name := '';

{ The attribute job_initiation_time is restored by jmp$record_job_attributes
{ The value being stored here is just in case recovery gets tied into knots and
{ the job can't terminate, that job status will return a valid job initiation time.

    jmv$kjlx_p^ [kjl_index].job_initiation_time := jmv$null_date_time;

    find_destination_usage (jmv$kjl_p^ [kjl_index].destination_usage, application_index);

{ Find the server mainframe index in the KJL.

    find_server_mainframe_id (job_control_block.server_mainframe_id, kjl_server_index);

    qfp$relink_kjl_server (kjl_index, kjl_server_index);
    qfp$relink_kjl_client (kjl_index, jmc$kjl_client_this_mainframe);
    qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_initiated_entry);
    qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_initiated);

{ Increment the job counts for initiated jobs.

    jmv$job_counts.initiated_jobs := jmv$job_counts.initiated_jobs + 1;
    jmv$job_counts.job_class_counts [jmv$kjl_p^ [kjl_index].job_class].initiated_jobs :=
          jmv$job_counts.job_class_counts [jmv$kjl_p^ [kjl_index].job_class].initiated_jobs + 1;
    IF jmv$kjlx_p^ [kjl_index].job_mode <> jmc$batch THEN
      jmv$job_counts.interactive_jobs := jmv$job_counts.interactive_jobs + 1;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$rebuild_executing_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$rebuild_input_queue', EJECT ??
*copy qfh$rebuild_input_queue

  PROCEDURE [XDCL, #GATE] qfp$rebuild_input_queue
    (    system_label: jmt$job_system_label;
         earliest_clock_time_to_initiate: jmt$clock_time;
         latest_clock_time_to_initiate: jmt$clock_time;
         current_clock_time: jmt$clock_time;
         job_submission_time: jmt$clock_time;
         job_class: jmt$job_class;
         input_file_location: jmt$input_file_location;
         login_family_available: boolean;
     VAR status: ost$status);

    VAR
      application_index: jmt$input_application_index,
      client_mainframe_id: pmt$binary_mainframe_id,
      client_mainframe_id_in_kjl: boolean,
      kjl_client_index: jmt$kjl_client_index,
      kjl_index: jmt$kjl_index,
      time_deferred_job: boolean;

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);

{ Search for a job with the same name in the KJL.

    kjl_search (system_label.system_job_name, -$jmt$kjl_entry_kind_set [], kjl_index);
    IF kjl_index <> jmc$kjl_undefined_index THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_name, system_label.system_job_name,
            status);
    ELSE

{ If the KJL is out of initialized entries it must be expanded.

      kjl_index := jmv$known_job_list.state_data [jmc$kjl_unused_entry].first_entry;
      IF kjl_index = jmc$kjl_undefined_index THEN
        qfp$expand_kjl;
        kjl_index := jmv$known_job_list.state_data [jmc$kjl_unused_entry].first_entry;
      IFEND;

      IF kjl_index = jmc$kjl_undefined_index THEN
        osp$set_status_condition (jme$maximum_jobs, status);

      ELSE
        jmv$kjl_p^ [kjl_index].system_job_name := system_label.system_job_name;
        jmv$kjl_p^ [kjl_index].user_job_name := system_label.user_job_name;
        jmv$kjl_p^ [kjl_index].initiated_job_list_ordinal.block_number := LOWERVALUE (jmt$ijl_block_number);
        jmv$kjl_p^ [kjl_index].initiated_job_list_ordinal.block_index := LOWERVALUE (jmt$ijl_block_index);
        jmv$kjl_p^ [kjl_index].job_submission_time := job_submission_time;
        jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate := earliest_clock_time_to_initiate;
        jmv$kjl_p^ [kjl_index].job_priority := 0;
        jmv$kjl_p^ [kjl_index].job_class := job_class;
        jmv$kjl_p^ [kjl_index].job_category_set := system_label.job_category_set;
        jmv$kjl_p^ [kjl_index].job_deferred_by_operator := system_label.job_deferred_by_operator;
        jmv$kjl_p^ [kjl_index].job_deferred_by_user := system_label.job_deferred_by_user;

{ Non-NOS/VE jobs cannot be deferred because their login family is not available.

        IF input_file_location <> jmc$ifl_store_and_forward_queue THEN
          jmv$kjl_p^ [kjl_index].login_family_available := login_family_available;
        ELSE
          jmv$kjl_p^ [kjl_index].login_family_available := TRUE;
        IFEND;
        jmv$kjl_p^ [kjl_index].destination_usage := system_label.job_destination_usage;
        jmv$kjl_p^ [kjl_index].next_destination_usage := system_label.job_destination_usage;
        jmv$kjl_p^ [kjl_index].application_state := jmc$kjl_application_unused;
        jmv$kjl_p^ [kjl_index].class_forward_link := jmc$kjl_undefined_index;
        jmv$kjl_p^ [kjl_index].class_reverse_link := jmc$kjl_undefined_index;
        jmv$kjl_p^ [kjl_index].client_index := jmc$kjl_client_undefined;
        jmv$kjl_p^ [kjl_index].client_forward_link := jmc$kjl_undefined_index;
        jmv$kjl_p^ [kjl_index].client_reverse_link := jmc$kjl_undefined_index;
        jmv$kjl_p^ [kjl_index].server_index := jmc$kjl_server_undefined;
        jmv$kjl_p^ [kjl_index].server_forward_link := jmc$kjl_undefined_index;
        jmv$kjl_p^ [kjl_index].server_reverse_link := jmc$kjl_undefined_index;
        jmv$kjl_p^ [kjl_index].server_kjl_index := kjl_index;

        jmv$kjlx_p^ [kjl_index].login_user_identification := system_label.login_user_identification;
        jmv$kjlx_p^ [kjl_index].job_controller := system_label.job_attributes.job_controller;
        jmv$kjlx_p^ [kjl_index].originating_ssn := system_label.job_attributes.originating_ssn;
        jmv$kjlx_p^ [kjl_index].latest_clock_time_to_initiate := latest_clock_time_to_initiate;
        jmv$kjlx_p^ [kjl_index].job_mode := system_label.job_mode;

{ The job monitor global task id is not set here - the job scheduler will set it when the job is initiated.

        jmv$kjlx_p^ [kjl_index].output_disposition_key := system_label.job_attributes.output_disposition_key;
        jmv$kjlx_p^ [kjl_index].input_file_location := input_file_location;
        jmv$kjlx_p^ [kjl_index].valid_mainframe_set := $jmt$valid_mainframe_set [];
        jmv$kjlx_p^ [kjl_index].timesharing_job := system_label.job_attributes.originating_application_name =
              osc$timesharing;
        jmv$kjlx_p^ [kjl_index].restart_job := TRUE;
        jmv$kjlx_p^ [kjl_index].system_label_p := NIL;
        jmv$kjlx_p^ [kjl_index].terminal_name := '';

{ Has the job been initiated on a client mainframe??

        IF system_label.job_initiation_location <> '' THEN

{ If the client does not fit in the KJL then the job cannot be recovered at this time.

          pmp$convert_mainframe_to_binary (system_label.job_initiation_location, client_mainframe_id, status);
          IF status.normal THEN
            find_client_mainframe_id (client_mainframe_id, client_mainframe_id_in_kjl, kjl_client_index);
            IF client_mainframe_id_in_kjl THEN
              qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_initiated_entry);
              qfp$relink_kjl_server (kjl_index, jmc$kjl_server_this_mainframe);
              qfp$relink_kjl_client (kjl_index, kjl_client_index);
            ELSE
              osp$set_status_condition (jme$maximum_jobs, status);
            IFEND;
          IFEND;
        ELSE

{ Is the job deferred?

          time_deferred_job := current_clock_time < earliest_clock_time_to_initiate;
          IF time_deferred_job OR system_label.job_deferred_by_operator OR
                system_label.job_deferred_by_user OR (NOT jmv$kjl_p^ [kjl_index].login_family_available) THEN
            IF time_deferred_job AND (earliest_clock_time_to_initiate < jmv$time_to_ready_deferred_job) THEN
              jmv$time_to_ready_deferred_job := earliest_clock_time_to_initiate;
            IFEND;
            qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_deferred_entry);
          ELSE
            qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_queued_entry);
            find_destination_usage (jmv$kjl_p^ [kjl_index].destination_usage, application_index);
            qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_new);
          IFEND;
          IF ve_job (kjl_index) THEN
            qfp$relink_kjl_server (kjl_index, jmc$kjl_server_this_mainframe);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$rebuild_input_queue;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$release_input_files', EJECT ??
*copy qfh$release_input_files

  PROCEDURE [XDCL, #GATE] qfp$release_input_files
    (    release_file_list: ^jmt$release_input_file_list;
     VAR release_file_count: jmt$job_count_range);

    VAR
      application_index: jmt$input_application_index,
      application_state: jmt$kjl_application_state,
      current_clock_time: jmt$clock_time,
      global_task_id: ost$global_task_id,
      job_class: jmt$job_class,
      kjl_index: jmt$kjl_index,
      next_kjl_index: jmt$kjl_index,
      previously_terminated: boolean,
      relink_application_index: jmt$input_application_index,
      release_list_limit: jmt$job_count_range,
      scheduler_has_a_job: boolean,
      time_deferred_job: boolean;

    pmp$get_executing_task_gtid (global_task_id);

    release_file_count := 0;
    IF release_file_list = NIL THEN
      release_list_limit := 0;
    ELSE
      release_list_limit := UPPERBOUND (release_file_list^);
    IFEND;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);

{ Check for the job leveler task.


    IF jmv$known_job_list.application_table [jmc$ve_input_application_index].global_task_id =
          global_task_id THEN
      jmp$force_candidate_refresh ({ flush_candidate_queue } TRUE);

{ Discard every queued job whose server is another mainframe.
{ Theoretically, there should be none.

      kjl_index := jmv$known_job_list.state_data [jmc$kjl_queued_entry].first_entry;
      WHILE kjl_index <> jmc$kjl_undefined_index DO
        next_kjl_index := jmv$kjl_p^ [kjl_index].forward_link;
        IF (jmv$kjl_p^ [kjl_index].server_index > jmc$kjl_server_this_mainframe) THEN
          qfp$relink_kjl_server (kjl_index, jmc$kjl_server_undefined);
          qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_unused_entry);
        IFEND;
        kjl_index := next_kjl_index;
      WHILEND;

      FOR job_class := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
        jmv$known_job_list.queued_class_entries [job_class].class_blocked_for_initiation := FALSE;
      FOREND;
      jmv$known_job_list.application_table [jmc$ve_input_application_index].global_task_id.index := 0;
      jmv$known_job_list.application_table [jmc$ve_input_application_index].global_task_id.seqno := 0;

      jmp$force_candidate_refresh ({ flush_candidate_queue } FALSE);
    IFEND;

{ Check to see if this task has input files registered.

  /search_all_applications/
    FOR application_index := jmc$ve_input_application_index + 1 TO
          UPPERBOUND (jmv$known_job_list.application_table) DO
      IF jmv$known_job_list.application_table [application_index].global_task_id = global_task_id THEN

      /search_all_application_states/
        FOR application_state := SUCC (jmc$kjl_application_unused) TO UPPERVALUE (application_state) DO
          kjl_index := jmv$known_job_list.application_table [application_index].
                state_data [application_state].first_entry;

        /release_entries_in_state/
          WHILE kjl_index <> jmc$kjl_undefined_index DO

{ Save the index of the next KJL entry.  When the entry is relinked, the links on the current entry
{ will no longer link to the next entry that needs to be managed.

            next_kjl_index := jmv$kjl_p^ [kjl_index].application_forward_link;
            previously_terminated := jmv$kjl_p^ [kjl_index].entry_kind = jmc$kjl_terminated_entry;

{ If the file was terminated, add it to the release list so the caller knows to delete the file
{ and remove the file from the KJL.

            IF previously_terminated THEN
              release_file_count := release_file_count + 1;
              IF release_file_count <= release_list_limit THEN
                release_file_list^ [release_file_count].system_job_name :=
                      jmv$kjl_p^ [kjl_index].system_job_name;
                release_file_list^ [release_file_count].input_file_location :=
                      jmv$kjlx_p^ [kjl_index].input_file_location;
                release_file_list^ [release_file_count].login_family :=
                      jmv$kjlx_p^ [kjl_index].login_user_identification.family;
              IFEND;
              qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_unused);
              qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_unused_entry);
            ELSE

              current_clock_time := #FREE_RUNNING_CLOCK (0);
              time_deferred_job := (current_clock_time < jmv$kjl_p^ [kjl_index].
                    earliest_clock_time_to_initiate);
              IF time_deferred_job OR jmv$kjl_p^ [kjl_index].job_deferred_by_operator OR
                    jmv$kjl_p^ [kjl_index].job_deferred_by_user THEN
                IF time_deferred_job AND (jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate <
                      jmv$time_to_ready_deferred_job) THEN
                  jmv$time_to_ready_deferred_job := jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate;
                IFEND;
                find_destination_usage (jmv$kjl_p^ [kjl_index].next_destination_usage,
                      relink_application_index);
                qfp$relink_kjl_application (kjl_index, relink_application_index, jmc$kjl_application_unused);
                jmv$kjl_p^ [kjl_index].destination_usage := jmv$kjl_p^ [kjl_index].next_destination_usage;
                qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_deferred_entry);
              ELSE

{ If the file's destination usage hasn't changed - relink it into the unassigned chain
{ If the destination_usage did change, then make it available to that application

                IF jmv$kjl_p^ [kjl_index].destination_usage = jmv$kjl_p^ [kjl_index].
                      next_destination_usage THEN
                  relink_application_index := jmc$unassigned_input_index;
                ELSE
                  find_destination_usage (jmv$kjl_p^ [kjl_index].next_destination_usage,
                        relink_application_index);
                IFEND;
                qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_queued_entry);
                qfp$relink_kjl_application (kjl_index, relink_application_index, jmc$kjl_application_new);
                jmv$kjl_p^ [kjl_index].destination_usage := jmv$kjl_p^ [kjl_index].next_destination_usage;
                notify_input_application (relink_application_index, kjl_index);
              IFEND;
            IFEND;

            kjl_index := next_kjl_index;
          WHILEND /release_entries_in_state/;
        FOREND /search_all_application_states/;

{ Zero out the entry in the application table

        jmv$known_job_list.application_table [application_index].application_name := osc$null_name;
        jmv$known_job_list.application_table [application_index].destination_usage := osc$null_name;
        jmv$known_job_list.application_table [application_index].global_task_id.index := 0;
        jmv$known_job_list.application_table [application_index].global_task_id.seqno := 0;
        jmv$known_job_list.application_table [application_index].queue_file_password := osc$null_name;

      IFEND;
    FOREND /search_all_applications/;

    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$release_input_files;
?? TITLE := '[XDCL, #GATE] qfp$register_input_application', EJECT ??
*copy qfh$register_input_application

  PROCEDURE [XDCL, #GATE] qfp$register_input_application
    (    application_name: ost$name;
         destination_usage: jmt$destination_usage;
         password: ost$name;
     VAR status: ost$status);

    VAR
      application_index: jmt$input_application_index,
      first_available_index: jmt$input_application_index,
      kjl_index: jmt$kjl_index,
      next_forward_link: jmt$kjl_index;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    first_available_index := jmc$unassigned_input_index;

  /search_for_the_application/
    FOR application_index := 1 TO UPPERBOUND (jmv$known_job_list.application_table) DO
      IF jmv$known_job_list.application_table [application_index].application_name = osc$null_name THEN
        IF first_available_index = jmc$unassigned_input_index THEN
          first_available_index := application_index;
        IFEND;

      ELSE { does the destination_usage match ??
        IF jmv$known_job_list.application_table [application_index].destination_usage = destination_usage THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$destination_usage_in_use, destination_usage,
                status);
          EXIT /search_for_the_application/;
        IFEND;
      IFEND;
    FOREND /search_for_the_application/;

    IF status.normal THEN

{ The destination_usage is not already in the table.  Is there room in the table??

      IF first_available_index = jmc$unassigned_input_index THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$application_table_is_full, '', status);
      ELSE

{ Move all input files with this destination_usage from the unassigned thread to this application thread.

        kjl_index := jmv$known_job_list.application_table [jmc$unassigned_input_index].
              state_data [jmc$kjl_application_new].first_entry;
        WHILE kjl_index <> jmc$kjl_undefined_index DO
          next_forward_link := jmv$kjl_p^ [kjl_index].application_forward_link;
          IF jmv$kjl_p^ [kjl_index].destination_usage = destination_usage THEN
            qfp$relink_kjl_application (kjl_index, first_available_index, jmc$kjl_application_new);
          IFEND;
          kjl_index := next_forward_link;
        WHILEND;

{ Initialize the entry in the table.  All files must be relinked before the table is initialized otherwise
{ the relink procedure will get confused with the destination usages.

        jmv$known_job_list.application_table [first_available_index].application_name := application_name;
        jmv$known_job_list.application_table [first_available_index].destination_usage := destination_usage;
        jmv$known_job_list.application_table [first_available_index].queue_file_password := password;
        pmp$get_executing_task_gtid (jmv$known_job_list.application_table [first_available_index].
              global_task_id);
      IFEND;
    IFEND; { status.normal
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$register_input_application;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$remove_job_from_kjl', EJECT ??
*copy qfh$remove_job_from_kjl

  PROCEDURE [XDCL, #GATE] qfp$remove_job_from_kjl
    (    system_job_name: jmt$system_supplied_name);

    VAR
      kjl_index: jmt$kjl_index;

    kjl_search (system_job_name, $jmt$kjl_entry_kind_set [jmc$kjl_terminated_entry], kjl_index);
    IF kjl_index <> jmc$kjl_undefined_index THEN
      qfp$relink_kjl_client (kjl_index, jmc$kjl_client_undefined);
      qfp$relink_kjl_server (kjl_index, jmc$kjl_server_undefined);
      qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index, jmc$kjl_application_unused);
      qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_unused_entry);
    IFEND;
  PROCEND qfp$remove_job_from_kjl;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$set_family_unavailable', EJECT ??
*copy qfh$set_family_unavailable

  PROCEDURE [XDCL, #GATE] qfp$set_family_unavailable;

    jmv$kjl_p^ [jmv$jcb.job_id].login_family_available := FALSE;
  PROCEND qfp$set_family_unavailable;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$set_input_completed', EJECT ??
*copy qfh$set_input_completed

  PROCEDURE [XDCL, #GATE] qfp$set_input_completed
    (    input_destination_usage: jmt$destination_usage;
         system_job_name: jmt$system_supplied_name;
         completed_successfully: boolean;
     VAR delete_input_file: boolean;
     VAR status: ost$status);

    VAR
      application_index: jmt$input_application_index,
      current_clock_time: jmt$clock_time,
      time_deferred_job: boolean,
      kjl_index: jmt$kjl_index;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    validate_application_access (input_destination_usage, application_index, status);
    IF status.normal THEN
      find_job_by_application (system_job_name, application_index, kjl_index);

      IF kjl_index <> jmc$kjl_undefined_index THEN
        delete_input_file := (jmv$kjl_p^ [kjl_index].entry_kind = jmc$kjl_terminated_entry) OR
              completed_successfully;
        IF delete_input_file THEN
          qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_unused);
          qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_unused_entry);
        ELSE
          current_clock_time := #FREE_RUNNING_CLOCK (0);
          time_deferred_job := jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate > current_clock_time;
          IF time_deferred_job OR jmv$kjl_p^ [kjl_index].job_deferred_by_operator OR
                jmv$kjl_p^ [kjl_index].job_deferred_by_user THEN
            IF time_deferred_job AND (jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate <
                  jmv$time_to_ready_deferred_job) THEN
              jmv$time_to_ready_deferred_job := jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate;
            IFEND;
            qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_unused);
            jmv$kjl_p^ [kjl_index].destination_usage := jmv$kjl_p^ [kjl_index].next_destination_usage;
            qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_deferred_entry);
          ELSE

            find_destination_usage (jmv$kjl_p^ [kjl_index].next_destination_usage, application_index);
            qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_queued_entry);
            qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_new);
            jmv$kjl_p^ [kjl_index].destination_usage := jmv$kjl_p^ [kjl_index].next_destination_usage;
            notify_input_application (application_index, kjl_index);
          IFEND;
        IFEND;
      ELSE
        osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_job_name, status);
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$set_input_completed;
?? TITLE := '[XDCL, #GATE] qfp$set_input_initiated', EJECT ??
*copy qfh$set_input_initiated

  PROCEDURE [XDCL, #GATE] qfp$set_input_initiated
    (    input_destination_usage: jmt$destination_usage;
         system_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      application_index: jmt$input_application_index,
      kjl_index: jmt$kjl_index;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    validate_application_access (input_destination_usage, application_index, status);
    IF status.normal THEN

      find_job_by_application (system_job_name, application_index, kjl_index);
      IF kjl_index <> jmc$kjl_undefined_index THEN
        IF (jmv$kjl_p^ [kjl_index].application_state = jmc$kjl_application_modified) OR
              (jmv$kjl_p^ [kjl_index].application_state = jmc$kjl_application_terminated) OR
              (jmv$kjl_p^ [kjl_index].entry_kind = jmc$kjl_terminated_entry) THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$input_cannot_initiate, '', status);
        ELSE

          qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_initiated);
          qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_initiated_entry);
        IFEND;
      ELSE
        osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_job_name, status);
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$set_input_initiated;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$set_interactive_jrd_jad', EJECT ??
*copy qfh$set_interactive_jrd_jad

  PROCEDURE [XDCL, #GATE] qfp$set_interactive_jrd_jad;

    IF jmv$jcb.ijle_p^.job_mode <> jmc$batch THEN
      jmv$jcb.ijle_p^.queue_file_information.job_abort_disposition :=
            jmv$kjlx_p^ [jmv$jcb.job_id].system_label_p^.job_abort_disposition;
      jmv$jcb.ijle_p^.queue_file_information.job_recovery_disposition :=
            jmv$kjlx_p^ [jmv$jcb.job_id].system_label_p^.job_recovery_disposition;
    IFEND;
  PROCEND qfp$set_interactive_jrd_jad;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$set_job_class_limits', EJECT ??
*copy qfh$set_job_class_limits

  PROCEDURE [XDCL, #GATE] qfp$set_job_class_limits
    (    job_class_set: jmt$job_class_set;
         class_limit_value: jmt$job_count_range);

    VAR
      job_class: jmt$job_class;

    FOR job_class := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
      IF job_class IN job_class_set THEN
        jmv$job_class_table_p^ [job_class].initiation_level.preferred := class_limit_value;
      IFEND;
    FOREND;
    jmv$refresh_job_candidates := TRUE;
    jmp$set_event_and_ready_sched (jmc$examine_input_queue);
  PROCEND qfp$set_job_class_limits;
?? TITLE := '[XDCL, #GATE] qfp$set_job_restart', EJECT ??
*copyc qfh$set_job_restart

  PROCEDURE [XDCL, #GATE] qfp$set_job_restart;

    jmv$kjlx_p^ [jmv$jcb.job_id].restart_job := TRUE;
  PROCEND qfp$set_job_restart;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$set_terminal_name', EJECT ??
*copy qfh$set_terminal_name

  PROCEDURE [XDCL, #GATE] qfp$set_terminal_name
    (    terminal_name: ift$terminal_name);

    jmv$kjlx_p^ [jmv$jcb.job_id].terminal_name := terminal_name;
  PROCEND qfp$set_terminal_name;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$submit_job', EJECT ??
*copy qfh$submit_job

  PROCEDURE [XDCL, #GATE] qfp$submit_job
    (    system_label: jmt$job_system_label;
         job_class: jmt$job_class;
         earliest_clock_time_to_initiate: jmt$clock_time;
         latest_clock_time_to_initiate: jmt$clock_time;
         current_clock_time: jmt$clock_time;
         job_submission_time: jmt$clock_time;
         immediate_initiation_candidate: boolean;
         input_file_location: jmt$input_file_location;
         valid_mainframe_set: jmt$valid_mainframe_set;
     VAR status: ost$status);

    VAR
      application_index: jmt$input_application_index,
      class_requirements_violated: boolean,
      ignore_status_p: ^ost$status,
      immediate_initiation_required: boolean,
      initiation_categories_violated: boolean,
      kjl_index: jmt$kjl_index,
      profile_mismatch: boolean,
      time_deferred_job: boolean;

    status.normal := TRUE;
    IF input_file_location <> jmc$ifl_store_and_forward_queue THEN
      immediate_initiation_required := (immediate_initiation_candidate OR
            jmv$job_class_table_p^ [job_class].immediate_initiation_candidate);
    ELSE

{ Remote jobs can never require immediate initiation.

      immediate_initiation_required := FALSE;
    IFEND;

    class_requirements_violated := FALSE;
    initiation_categories_violated := FALSE;
    IF immediate_initiation_required THEN

{ If the job requires immediate initiation and is deferred by operator request
{ then reject the request.

      IF system_label.job_deferred_by_operator THEN
        osp$set_status_condition (jme$maximum_jobs, status);
        RETURN;
      IFEND;

      class_requirements_violated := (NOT jmv$job_class_table_p^ [job_class].enable_class_initiation) OR
            ((jmv$job_counts.job_class_counts [job_class].queued_jobs + jmv$job_counts.
            job_class_counts [job_class].initiated_jobs) >= jmv$job_class_table_p^ [job_class].
            initiation_level.preferred);
      initiation_categories_violated := (system_label.job_category_set *
            jmv$job_scheduler_table.initiation_required_categories <>
            jmv$job_scheduler_table.initiation_required_categories) OR
            (system_label.job_category_set * jmv$job_scheduler_table.initiation_excluded_categories <>
            $jmt$job_category_set []);
    IFEND;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    IF jmv$known_job_list.state_data [jmc$kjl_unused_entry].first_entry = jmc$kjl_undefined_index THEN
      qfp$expand_kjl;
    IFEND;

{ Check for room in the Known Job List (KJL).  The distribution of entries in
{ the KJL is defined as follows:
{
{    #available = MAXIMUM - qfv$current_kjl_limit + #initialized_unused_entries
{    #used_entries = MAXIMUM - #available = qfv$current_kjl_limit - #initialized_unused_entries
{
{ If the #used_entries >= jmv$maxiumum_known_jobs (logical bound) then the job cannot be
{ placed in the KJL.

    IF (qfv$current_kjl_limit - jmv$known_job_list.state_data [jmc$kjl_unused_entry].number_of_entries >=
          jmv$maximum_known_jobs) THEN
      osp$set_status_condition (jme$maximum_jobs, status);
      PUSH ignore_status_p;
      dpp$put_critical_message (jmc$input_queue_full_message, ignore_status_p^);
    ELSE

{ If the job requires immediate initiation, it must not violate the class requirements or
{ initiation categories.

      IF immediate_initiation_required AND (class_requirements_violated OR initiation_categories_violated)
            THEN
        osp$set_status_condition (jme$maximum_jobs, status);
        qfp$check_for_profile_mismatch (system_label.active_profile_version, profile_mismatch);
        IF profile_mismatch OR jmv$sched_profile_is_loading THEN
          osp$set_status_condition (jme$scheduling_profile_changed, status);
        IFEND;
      ELSE
        kjl_search (system_label.system_job_name, -$jmt$kjl_entry_kind_set [], kjl_index);
        IF kjl_index <> jmc$kjl_undefined_index THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_name, system_label.system_job_name,
                status);
        ELSE

          kjl_index := jmv$known_job_list.state_data [jmc$kjl_unused_entry].first_entry;

          jmv$kjl_p^ [kjl_index].system_job_name := system_label.system_job_name;
          jmv$kjl_p^ [kjl_index].user_job_name := system_label.user_job_name;
          jmv$kjl_p^ [kjl_index].initiated_job_list_ordinal.block_number := LOWERVALUE (jmt$ijl_block_number);
          jmv$kjl_p^ [kjl_index].initiated_job_list_ordinal.block_index := LOWERVALUE (jmt$ijl_block_index);
          jmv$kjl_p^ [kjl_index].job_submission_time := job_submission_time;
          jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate := earliest_clock_time_to_initiate;
          jmv$kjl_p^ [kjl_index].job_class := job_class;
          jmv$kjl_p^ [kjl_index].job_category_set := system_label.job_category_set;
          jmv$kjl_p^ [kjl_index].job_priority := 0;
          jmv$kjl_p^ [kjl_index].job_deferred_by_operator := system_label.job_deferred_by_operator;
          jmv$kjl_p^ [kjl_index].job_deferred_by_user := system_label.job_deferred_by_user;
          jmv$kjl_p^ [kjl_index].priority_bias := 0;
          jmv$kjl_p^ [kjl_index].login_family_available := TRUE;
          jmv$kjl_p^ [kjl_index].destination_usage := system_label.job_destination_usage;
          jmv$kjl_p^ [kjl_index].next_destination_usage := system_label.job_destination_usage;
          jmv$kjl_p^ [kjl_index].application_state := jmc$kjl_application_unused;
          jmv$kjl_p^ [kjl_index].class_forward_link := jmc$kjl_undefined_index;
          jmv$kjl_p^ [kjl_index].class_reverse_link := jmc$kjl_undefined_index;
          jmv$kjl_p^ [kjl_index].client_index := jmc$kjl_client_undefined;
          jmv$kjl_p^ [kjl_index].client_forward_link := jmc$kjl_undefined_index;
          jmv$kjl_p^ [kjl_index].client_reverse_link := jmc$kjl_undefined_index;
          jmv$kjl_p^ [kjl_index].server_index := jmc$kjl_server_undefined;
          jmv$kjl_p^ [kjl_index].server_forward_link := jmc$kjl_undefined_index;
          jmv$kjl_p^ [kjl_index].server_reverse_link := jmc$kjl_undefined_index;
          jmv$kjl_p^ [kjl_index].server_kjl_index := kjl_index;

          jmv$kjlx_p^ [kjl_index].login_user_identification := system_label.login_user_identification;
          jmv$kjlx_p^ [kjl_index].job_controller := system_label.job_attributes.job_controller;
          jmv$kjlx_p^ [kjl_index].originating_ssn := system_label.job_attributes.originating_ssn;
          jmv$kjlx_p^ [kjl_index].latest_clock_time_to_initiate := latest_clock_time_to_initiate;
          jmv$kjlx_p^ [kjl_index].job_mode := system_label.job_mode;

{ The job monitor global task id is not set here - the job scheduler will set it when the job initiates.

          jmv$kjlx_p^ [kjl_index].output_disposition_key := system_label.job_attributes.
                output_disposition_key;
          jmv$kjlx_p^ [kjl_index].input_file_location := input_file_location;
          jmv$kjlx_p^ [kjl_index].valid_mainframe_set := valid_mainframe_set;
          jmv$kjlx_p^ [kjl_index].timesharing_job := system_label.job_attributes.
                originating_application_name = osc$timesharing;
          jmv$kjlx_p^ [kjl_index].restart_job := FALSE;
          jmv$kjlx_p^ [kjl_index].terminal_name := '';

{ Check if the scheduling profile structure has changed since the job class was selected.

          qfp$check_for_profile_mismatch (system_label.active_profile_version, profile_mismatch);
          IF profile_mismatch OR jmv$sched_profile_is_loading THEN
            osp$set_status_abnormal (jmc$job_management_id, jme$scheduling_profile_changed, '', status);
          ELSE

{ Save an interactive job's system label.

            IF system_label.job_mode = jmc$interactive_connected THEN
              ALLOCATE jmv$kjlx_p^ [kjl_index].system_label_p IN osv$mainframe_pageable_heap^;
              jmv$kjlx_p^ [kjl_index].system_label_p^ := system_label;
            ELSE
              jmv$kjlx_p^ [kjl_index].system_label_p := NIL;
            IFEND;

{ Is the job a deferred job??

            time_deferred_job := current_clock_time < earliest_clock_time_to_initiate;
            IF time_deferred_job OR system_label.job_deferred_by_operator OR
                  system_label.job_deferred_by_user THEN
              IF time_deferred_job AND (earliest_clock_time_to_initiate < jmv$time_to_ready_deferred_job) THEN
                jmv$time_to_ready_deferred_job := earliest_clock_time_to_initiate;
              IFEND;
              qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_deferred_entry);

            ELSE
              qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_queued_entry);
              find_destination_usage (jmv$kjl_p^ [kjl_index].destination_usage, application_index);
              qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_new);
              notify_input_application (application_index, kjl_index);
            IFEND;

            IF input_file_location <> jmc$ifl_store_and_forward_queue THEN
              qfp$relink_kjl_server (kjl_index, jmc$kjl_server_this_mainframe);
            IFEND;

          IFEND;
        IFEND;
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$submit_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$terminate_acquired_input', EJECT ??
*copy qfh$terminate_acquired_input

  PROCEDURE [XDCL, #GATE] qfp$terminate_acquired_input
    (    input_destination_usage: jmt$destination_usage;
     VAR system_job_name: jmt$system_supplied_name;
     VAR delete_input_file: boolean;
     VAR status: ost$status);

    VAR
      application_index: jmt$input_application_index,
      current_clock_time: jmt$clock_time,
      kjl_index: jmt$kjl_index,
      time_deferred_job: boolean;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    validate_application_access (input_destination_usage, application_index, status);
    IF status.normal THEN

      kjl_index := jmv$known_job_list.application_table [application_index].
            state_data [jmc$kjl_application_terminated].first_entry;
      IF kjl_index <> jmc$kjl_undefined_index THEN
        system_job_name := jmv$kjl_p^ [kjl_index].system_job_name;
        delete_input_file := jmv$kjl_p^ [kjl_index].entry_kind = jmc$kjl_terminated_entry;
        IF delete_input_file THEN
          qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_unused);
          qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_unused_entry);
        ELSE
          current_clock_time := #FREE_RUNNING_CLOCK (0);
          time_deferred_job := jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate > current_clock_time;
          IF time_deferred_job OR jmv$kjl_p^ [kjl_index].job_deferred_by_operator OR
                jmv$kjl_p^ [kjl_index].job_deferred_by_user THEN
            IF time_deferred_job AND (jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate <
                  jmv$time_to_ready_deferred_job) THEN
              jmv$time_to_ready_deferred_job := jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate;
            IFEND;
            qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_unused);
            jmv$kjl_p^ [kjl_index].destination_usage := jmv$kjl_p^ [kjl_index].next_destination_usage;
            qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_deferred_entry);
          ELSE
            find_destination_usage (jmv$kjl_p^ [kjl_index].next_destination_usage, application_index);
            qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_new);
            jmv$kjl_p^ [kjl_index].destination_usage := jmv$kjl_p^ [kjl_index].next_destination_usage;
            notify_input_application (application_index, kjl_index);
          IFEND;
        IFEND;

      ELSE
        osp$set_status_abnormal (jmc$job_management_id, jme$input_queue_is_empty, '', status);
      IFEND;

    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$terminate_acquired_input;
?? TITLE := '[XDCL, #GATE] qfp$terminate_job', EJECT ??
*copy qfh$terminate_job

  PROCEDURE [XDCL, #GATE] qfp$terminate_job
    (    system_job_name: jmt$system_supplied_name;
         job_state_set: jmt$job_state_set;
         output_disposition_key_known: boolean;
         output_disposition_key: jmt$output_disposition_keys;
         operator_job: boolean;
     VAR family_name: ost$name;
     VAR delete_input_file: boolean;
     VAR input_file_location: jmt$input_file_location;
     VAR job_assigned_to_client: boolean;
     VAR client_mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

    VAR
      application_index: jmt$input_application_index,
      ignore_status: ost$status,
      earliest_clock_time_to_initiate: jmt$clock_time,
      ijle_p: ^jmt$initiated_job_list_entry,
      job_executing: boolean,
      job_name_has_changed: boolean,
      kjl_index: jmt$kjl_index,
      kjl_entry_kind_set: jmt$kjl_entry_kind_set;

    status.normal := TRUE;
    ignore_status.normal := TRUE;
    job_executing := FALSE;

    kjl_entry_kind_set := $jmt$kjl_entry_kind_set [jmc$kjl_assigned_entry];
    IF jmc$deferred_job IN job_state_set THEN
      kjl_entry_kind_set := kjl_entry_kind_set + $jmt$kjl_entry_kind_set [jmc$kjl_deferred_entry];
    IFEND;
    IF jmc$queued_job IN job_state_set THEN
      kjl_entry_kind_set := kjl_entry_kind_set + $jmt$kjl_entry_kind_set [jmc$kjl_queued_entry];
    IFEND;
    IF jmc$initiated_job IN job_state_set THEN
      kjl_entry_kind_set := kjl_entry_kind_set + $jmt$kjl_entry_kind_set [jmc$kjl_initiated_entry];
    IFEND;
    IF jmc$terminating_job IN job_state_set THEN
      kjl_entry_kind_set := kjl_entry_kind_set + $jmt$kjl_entry_kind_set [jmc$kjl_terminated_entry];
    IFEND;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    kjl_search (system_job_name, kjl_entry_kind_set, kjl_index);
    IF kjl_index = jmc$kjl_undefined_index THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_job_name, status);
      osp$clear_mainframe_sig_lock (qfv$kjl_lock);
      RETURN;
    IFEND;

    get_job_from_scheduler (kjl_index, jmc$kjl_application_terminated, job_name_has_changed);
    IF job_name_has_changed THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_job_name, status);
      osp$clear_mainframe_sig_lock (qfv$kjl_lock);
      RETURN;
    IFEND;

    job_executing := (jmv$kjl_p^ [kjl_index].entry_kind IN $jmt$kjl_entry_kind_set
          [jmc$kjl_initiated_entry, jmc$kjl_terminated_entry]) AND ve_job (kjl_index);
    delete_input_file := jmv$kjl_p^ [kjl_index].entry_kind < jmc$kjl_initiated_entry;
    earliest_clock_time_to_initiate := jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate;
    find_destination_usage (jmv$kjl_p^ [kjl_index].destination_usage, application_index);
    family_name := jmv$kjlx_p^ [kjl_index].login_user_identification.family;
    input_file_location := jmv$kjlx_p^ [kjl_index].input_file_location;
    job_assigned_to_client := jmv$kjl_p^ [kjl_index].client_index > jmc$kjl_client_this_mainframe;
    IF job_assigned_to_client THEN
      pmp$convert_binary_mainframe_id (jmv$known_job_list.client_data.
            state_data [jmv$kjl_p^ [kjl_index].client_index].mainframe_id, client_mainframe_id,
            { ignore } status);
      status.normal := TRUE;
      qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_terminated_entry);
      osp$clear_mainframe_sig_lock (qfv$kjl_lock);

    ELSE { IF NOT job_assigned_to_client THEN
      IF job_executing THEN
        IF (jmc$tja_user_kill_enabled IN qfv$terminate_job_action_set) OR
              (operator_job AND (jmc$tja_operator_kill_enabled IN qfv$terminate_job_action_set)) THEN
          pmp$set_system_flag (jmc$kill_job_flag, jmv$kjlx_p^ [kjl_index].job_monitor_global_task_id, status);
        ELSE
          pmp$set_system_flag (jmc$terminate_job_flag, jmv$kjlx_p^ [kjl_index].job_monitor_global_task_id,
                status);
        IFEND;
        qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_terminated_entry);
        qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_terminated);
        jmp$get_ijle_p (jmv$kjl_p^ [kjl_index].initiated_job_list_ordinal, ijle_p);
        IF output_disposition_key_known THEN
          jmv$kjlx_p^ [kjl_index].output_disposition_key := output_disposition_key;
        IFEND;

{ If the job is in a state that it cannot terminate, notify the requestor.
{ NOTE: The system flag is still set so should the state of the job change, it
{       will be terminated.  The following should all be "Warning" errors.

        IF (ijle_p^.entry_status = jmc$ies_system_force_out) OR
              (ijle_p^.entry_status = jmc$ies_operator_force_out) THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$job_forced_out_of_memory, system_job_name,
                status);
        ELSEIF ijle_p^.entry_status = jmc$ies_job_damaged THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$job_damaged_during_recovery, system_job_name,
                status);
        ELSEIF ijle_p^.hung_task_in_job THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$job_has_a_hung_task, system_job_name, status);
        IFEND;
        osp$clear_mainframe_sig_lock (qfv$kjl_lock);

      ELSE { the job was not executing
        qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_terminated_entry);
        IF delete_input_file THEN
          find_destination_usage (jmv$kjl_p^ [kjl_index].destination_usage, application_index);
          IF jmv$kjl_p^ [kjl_index].application_state > jmc$kjl_application_new THEN
            delete_input_file := FALSE;
            qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_terminated);
            notify_input_application (application_index, kjl_index);
          ELSE
            IF ve_job (kjl_index) THEN
              qfp$relink_kjl_server (kjl_index, jmc$kjl_server_undefined);
            IFEND;
            qfp$relink_kjl_application (kjl_index, application_index, jmc$kjl_application_unused);
            qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_unused_entry);
          IFEND;
        IFEND;
        osp$clear_mainframe_sig_lock (qfv$kjl_lock);

{ This request may reset the time_to_ready_deferred_job

        IF earliest_clock_time_to_initiate = jmv$time_to_ready_deferred_job THEN
          qfp$ready_deferred_job;
        IFEND;
      IFEND;
    IFEND;
  PROCEND qfp$terminate_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$validate_input_file_access', EJECT ??
*copy qfh$validate_input_file_access

  PROCEDURE [XDCL, #GATE] qfp$validate_input_file_access
    (    system_job_name: jmt$system_supplied_name;
         input_destination_usage: jmt$destination_usage;
         queue_file_password: jmt$queue_file_password;
     VAR family_name: ost$name;
     VAR status: ost$status);

    VAR
      application_index: jmt$input_application_index,
      kjl_index: jmt$kjl_index;

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);
    find_destination_usage (input_destination_usage, application_index);
    IF application_index = jmc$unassigned_input_index THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$destination_usage_incorrect,
            input_destination_usage, status);
    ELSE

{ Do the passwords match??

      IF queue_file_password <> jmv$known_job_list.application_table [application_index].
            queue_file_password THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$application_not_permitted,
              input_destination_usage, status);
      ELSE

{ Search for the file in the applications initiated thread - If it isn't there, don't permit access
{ to the file.

        kjl_index := jmv$known_job_list.application_table [application_index].
              state_data [jmc$kjl_application_initiated].first_entry;
        WHILE (kjl_index <> jmc$kjl_undefined_index) AND (jmv$kjl_p^ [kjl_index].system_job_name <>
              system_job_name) DO
          kjl_index := jmv$kjl_p^ [kjl_index].application_forward_link;
        WHILEND;
        IF (kjl_index = jmc$kjl_undefined_index) THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_job_name, status);
        IFEND;
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$validate_input_file_access;
?? OLDTITLE ??
MODEND qfm$queue_file_job_manager;
*DECK DECK=QFM$QUEUE_FILE_LEVELER_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Job Leveler Management Ring 1' ??
MODULE qfm$queue_file_leveler_manager;

{ PURPOSE:
{   This module contains the interfaces responsible for the manipulation of the
{   Known Job List (KJL) for the job leveler task.
{
{ DESIGN:
{   The procedures in this module reference the Known Job List (KJL) and execute
{   in ring one.  The procedures in this module are callable from ring 3 and are
{   used solely for the purposes of leveling jobs across mainframes.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$input_queue_full_message
*copyc jmc$job_management_id
*copyc jme$queued_file_conditions
*copyc jmt$clock_time
*copyc jmt$jl_assigned_job_list
*copyc jmt$jl_job_class_data
*copyc jmt$jl_job_class_priorities
*copyc jmt$jl_missing_job_list
*copyc jmt$jl_server_job_end_info
*copyc jmt$jl_server_job_list
*copyc jmt$jl_server_job_priorities
*copyc jmt$jl_unassigned_job_list
*copyc jmt$job_category_set
*copyc jmt$job_count_range
*copyc osd$integer_limits
*copyc oss$mainframe_pageable
*copyc oss$mainframe_paged_literal
*copyc ost$status
*copyc pmt$binary_mainframe_id
?? POP ??
*copyc dpp$put_critical_message
*copyc jmp$force_candidate_refresh
*copyc jmp$notify_job_scheduler_of_job
*copyc osp$clear_mainframe_sig_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_condition
*copyc osp$system_error
*copyc pmp$delay
*copyc pmp$get_executing_task_gtid
*copyc qfp$expand_kjl
*copyc qfp$get_profile_mainframe_index
*copyc qfp$job_selection_priority
*copyc qfp$relink_kjl_application
*copyc qfp$relink_kjl_client
*copyc qfp$relink_kjl_entry
*copyc qfp$relink_kjl_server
*copyc jmv$candidate_queued_jobs
*copyc jmv$job_class_table_p
*copyc jmv$job_counts
*copyc jmv$job_scheduler_table
*copyc jmv$kjl_p
*copyc jmv$kjlx_p
*copyc jmv$known_job_list
*copyc jmv$leveler_profile_loading
*copyc jmv$maximum_job_class_in_use
*copyc jmv$maximum_known_jobs
*copyc jmv$maximum_profile_index
*copyc jmv$profile_index_to_job_class
*copyc qfv$current_kjl_limit
*copyc qfv$kjl_lock
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    null_binary_mainframe_id: [STATIC, READ, oss$mainframe_paged_literal] pmt$binary_mainframe_id := [0, 0],
    qfv$leveler_readied: [STATIC, XDCL, #GATE, oss$mainframe_pageable] boolean := FALSE;

?? OLDTITLE ??
?? NEWTITLE := 'determine_server_kjl_index', EJECT ??

{ PURPOSE:
{   This request will find the server KJL index for a job assigned to a client.
{
{ NOTES:
{   The Known Job List (KJL) must be locked when this request is issued.
{   A server_kjl_index of jmc$kjl_undefined_index will be returned if the
{   job was not found.

  PROCEDURE determine_server_kjl_index
    (    kjl_client_index: jmt$kjl_client_index;
         system_job_name: jmt$system_supplied_name;
         probable_server_kjl_index: jmt$kjl_index;
     VAR server_kjl_index: jmt$kjl_index);

    VAR
      kjl_index: jmt$kjl_index;

    IF (probable_server_kjl_index <> jmc$kjl_undefined_index) AND
          (probable_server_kjl_index <= UPPERBOUND (jmv$kjl_p^)) THEN
      IF jmv$kjl_p^ [probable_server_kjl_index].system_job_name = system_job_name THEN
        server_kjl_index := probable_server_kjl_index;
        RETURN;
      IFEND;
    IFEND;
    kjl_index := jmv$known_job_list.client_data.state_data [kjl_client_index].first_entry;
    WHILE (kjl_index <> jmc$kjl_undefined_index) AND (jmv$kjl_p^ [kjl_index].system_job_name <>
          system_job_name) DO
      kjl_index := jmv$kjl_p^ [kjl_index].client_forward_link;
    WHILEND;
    server_kjl_index := kjl_index;
  PROCEND determine_server_kjl_index;
?? OLDTITLE ??
?? NEWTITLE := 'find_client_mainframe_id', EJECT ??

{ PURPOSE:
{   This request searches the Known Job List Client Table for the specified mainframe
{   identifier.
{
{ DESIGN:
{   If the mainframe identifier is found return the kjl client index.  If the mainframe
{   identifier is not found then if add_if_not_found is true, add the indicated
{   mainframe identifier to the kjl client list and return the assigned kjl client
{   index.  If add_if_not_found is false or the client list is full set
{   client_mainframe_id_in_kjl to false.
{
{ NOTES:
{   The Known Job List (KJL) must be locked when this request is issued.

  PROCEDURE find_client_mainframe_id
    (    client_mainframe_id: pmt$binary_mainframe_id;
         add_if_not_found: boolean;
     VAR client_mainframe_id_in_kjl: boolean;
     VAR kjl_client_index: jmt$kjl_client_index);

    VAR
      local_kjl_client_index: jmt$kjl_client_index;

    client_mainframe_id_in_kjl := FALSE;

  /search_for_mainframe_id/
    FOR local_kjl_client_index := jmc$kjl_client_this_mainframe TO UPPERVALUE (jmt$kjl_client_index) DO
      IF jmv$known_job_list.client_data.state_data [local_kjl_client_index].mainframe_id =
            client_mainframe_id THEN
        client_mainframe_id_in_kjl := TRUE;
        kjl_client_index := local_kjl_client_index;
        EXIT /search_for_mainframe_id/;
      IFEND;
    FOREND /search_for_mainframe_id/;
    IF (NOT client_mainframe_id_in_kjl) AND add_if_not_found THEN

    /search_for_empty_client_entry/
      FOR local_kjl_client_index := jmc$kjl_client_this_mainframe + 1 TO UPPERVALUE (jmt$kjl_client_index) DO
        IF jmv$known_job_list.client_data.state_data [local_kjl_client_index].mainframe_id =
              null_binary_mainframe_id THEN
          jmv$known_job_list.client_data.state_data [local_kjl_client_index].mainframe_id :=
                client_mainframe_id;
          client_mainframe_id_in_kjl := TRUE;
          kjl_client_index := local_kjl_client_index;
          EXIT /search_for_empty_client_entry/;
        IFEND;
      FOREND /search_for_empty_client_entry/;
    IFEND;
  PROCEND find_client_mainframe_id;
?? OLDTITLE ??
?? NEWTITLE := 'find_server_mainframe_id', EJECT ??

{ PURPOSE:
{   This request searches the Known Job List Server Table for the specified mainframe
{   identifier.
{
{ DESIGN:
{   If the mainframe identifier is found return the kjl server index.  If the mainframe
{   identifier is not found then if add_if_not_found is true, add the indicated
{   mainframe identifier to the kjl server list and return the assign kjl server
{   index.  If add_if_not_found is false or the server list is full set
{   server_mainframe_id_in_kjl to false.
{
{ NOTES:
{   The Known Job List (KJL) must be locked when this request is issued.

  PROCEDURE find_server_mainframe_id
    (    server_mainframe_id: pmt$binary_mainframe_id;
         add_if_not_found: boolean;
     VAR server_mainframe_id_in_kjl: boolean;
     VAR kjl_server_index: jmt$kjl_server_index);

    VAR
      local_kjl_server_index: jmt$kjl_server_index;

    server_mainframe_id_in_kjl := FALSE;

  /search_for_mainframe_id/
    FOR local_kjl_server_index := jmc$kjl_server_this_mainframe TO UPPERVALUE (jmt$kjl_server_index) DO
      IF jmv$known_job_list.server_data.state_data [local_kjl_server_index].mainframe_id =
            server_mainframe_id THEN
        server_mainframe_id_in_kjl := TRUE;
        kjl_server_index := local_kjl_server_index;
        EXIT /search_for_mainframe_id/;
      IFEND;
    FOREND /search_for_mainframe_id/;
    IF (NOT server_mainframe_id_in_kjl) AND add_if_not_found THEN

    /search_for_empty_server_entry/
      FOR local_kjl_server_index := jmc$kjl_server_this_mainframe + 1 TO UPPERVALUE (jmt$kjl_server_index) DO
        IF jmv$known_job_list.server_data.state_data [local_kjl_server_index].mainframe_id =
              null_binary_mainframe_id THEN
          jmv$known_job_list.server_data.state_data [local_kjl_server_index].mainframe_id :=
                server_mainframe_id;
          server_mainframe_id_in_kjl := TRUE;
          kjl_server_index := local_kjl_server_index;
          EXIT /search_for_empty_server_entry/;
        IFEND;
      FOREND /search_for_empty_server_entry/;
    IFEND;
  PROCEND find_server_mainframe_id;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$assign_jobs_to_client', EJECT ??
*copy qfh$assign_jobs_to_client

  PROCEDURE [XDCL, #GATE] qfp$assign_jobs_to_client
    (    client_mainframe_id: pmt$binary_mainframe_id;
         leveler_job_class_data: jmt$jl_job_class_data;
         job_class_priorities: jmt$jl_job_class_priorities;
         initiation_required_categories: jmt$job_category_set;
         initiation_excluded_categories: jmt$job_category_set;
         assigned_job_list_p { output } : ^jmt$jl_assigned_job_list;
     VAR number_of_jobs_assigned: jmt$job_count_range;
     VAR server_job_priorities: jmt$jl_server_job_priorities);

    VAR
      assigned_job_list_size: jmt$job_count_range,
      client_in_kjl: boolean,
      current_clock_time: jmt$clock_time,
      eligible_job_categories: boolean,
      job_assignable_to_client: boolean,
      job_class: jmt$job_class,
      job_class_assigned_job_count: jmt$job_count_range,
      job_priority: jmt$job_priority,
      kjl_client_index: jmt$kjl_client_index,
      kjl_index: jmt$kjl_index,
      mainframe_index: jmt$maximum_mainframes,
      next_kjl_index: jmt$kjl_index,
      number_of_jobs_needed_for_class: ost$non_negative_integers,
      profile_job_class: jmt$job_class,
      required_job_priority: jmt$job_priority;

    number_of_jobs_assigned := 0;
    current_clock_time := #FREE_RUNNING_CLOCK (0);
    assigned_job_list_size := UPPERBOUND (assigned_job_list_p^);

    osp$set_mainframe_sig_lock (qfv$kjl_lock);
    find_client_mainframe_id (client_mainframe_id, { add_if_not_found } TRUE, client_in_kjl,
          kjl_client_index);
    IF client_in_kjl THEN

{ Determine the mainframe index of the client mainframe.  In order to request jobs
{ from the server, the client, by definition, must be in the active profile so a
{ valid mainframe is always returned.

      qfp$get_profile_mainframe_index (client_mainframe_id, mainframe_index);

      FOR profile_job_class := 1 TO jmv$maximum_profile_index DO
        job_class := jmv$profile_index_to_job_class [profile_job_class];
        server_job_priorities [profile_job_class] := 0;
        IF (job_class <= jmv$maximum_job_class_in_use) AND (job_class >= jmc$system_job_class) THEN
          number_of_jobs_needed_for_class := leveler_job_class_data [profile_job_class].termination_count +
                leveler_job_class_data [profile_job_class].room_in_class;
          IF number_of_jobs_needed_for_class > (UPPERVALUE (number_of_jobs_assigned) -
                number_of_jobs_assigned) THEN
            number_of_jobs_needed_for_class := UPPERVALUE (number_of_jobs_assigned) - number_of_jobs_assigned;
          IFEND;
          job_class_assigned_job_count := 0;
          kjl_index := jmv$known_job_list.queued_class_entries [job_class].first_queued_class_entry;

        /assign_jobs_to_client/
          WHILE kjl_index <> jmc$kjl_undefined_index DO

{ A job is assignable if and only if all the following are true:
{ o The job's categories fit the initiation required/excluded categories from the client.
{ o The client's mainframe index is in the valid_mainframe_set for the job.
{ o The job is not already assigned to a client.
{ o The job's server mainframe is the mainframe on which this request executes.
{ o The job does not have a Job_Destination_Usage of VE_LOCAL.
{ o The job has sufficient priority to be assigned to the client.
{ o The job is a batch job.

            next_kjl_index := jmv$kjl_p^ [kjl_index].class_forward_link;
            eligible_job_categories := ((initiation_required_categories *
                  jmv$kjl_p^ [kjl_index].job_category_set) = initiation_required_categories) AND
                  ((initiation_excluded_categories * jmv$kjl_p^ [kjl_index].job_category_set) =
                  $jmt$job_category_set []);

            job_assignable_to_client := eligible_job_categories AND
                  (mainframe_index IN jmv$kjlx_p^ [kjl_index].valid_mainframe_set) AND
                  (jmv$kjlx_p^ [kjl_index].job_mode = jmc$batch) AND
                  (jmv$kjl_p^ [kjl_index].client_index = jmc$kjl_client_undefined) AND
                  (jmv$kjl_p^ [kjl_index].destination_usage <> jmc$ve_local_usage) AND
                  (jmv$kjl_p^ [kjl_index].server_index = jmc$kjl_server_this_mainframe);

            IF job_assignable_to_client THEN
              job_priority := qfp$job_selection_priority (current_clock_time, kjl_index);
              IF (job_class_priorities [profile_job_class].job_priority +
                    jmv$job_scheduler_table.job_leveling_priority_bias +
                    jmv$job_class_table_p^ [job_class].job_leveling_priority_bias) < 0 THEN
                required_job_priority := 0;
              ELSEIF (job_class_priorities [profile_job_class].job_priority +
                    jmv$job_scheduler_table.job_leveling_priority_bias +
                    jmv$job_class_table_p^ [job_class].job_leveling_priority_bias) >
                    UPPERVALUE (jmt$job_priority) THEN
                required_job_priority := UPPERVALUE (jmt$job_priority);
              ELSE
                required_job_priority := (job_class_priorities [profile_job_class].job_priority +
                      jmv$job_scheduler_table.job_leveling_priority_bias +
                      jmv$job_class_table_p^ [job_class].job_leveling_priority_bias);
              IFEND;

{ Treat a full assigned job list the same as if the maximum number of jobs had been
{ assigned to the client for the job class.  If a profile is loading, only return the
{ priority of the highest assignable job.

              IF (job_class_assigned_job_count < number_of_jobs_needed_for_class) AND
                    (number_of_jobs_assigned < assigned_job_list_size) AND
                    ((job_priority > required_job_priority) OR ((job_priority = required_job_priority) AND
                    job_class_priorities [profile_job_class].based_on_selection_priority)) AND
                    (NOT jmv$leveler_profile_loading) THEN
                number_of_jobs_assigned := number_of_jobs_assigned + 1;
                job_class_assigned_job_count := job_class_assigned_job_count + 1;
                assigned_job_list_p^ [number_of_jobs_assigned].system_job_name :=
                      jmv$kjl_p^ [kjl_index].system_job_name;
                assigned_job_list_p^ [number_of_jobs_assigned].user_job_name :=
                      jmv$kjl_p^ [kjl_index].user_job_name;
                assigned_job_list_p^ [number_of_jobs_assigned].login_user_identification :=
                      jmv$kjlx_p^ [kjl_index].login_user_identification;
                assigned_job_list_p^ [number_of_jobs_assigned].control_user_identification :=
                      jmv$kjlx_p^ [kjl_index].job_controller;
                assigned_job_list_p^ [number_of_jobs_assigned].originating_ssn :=
                      jmv$kjlx_p^ [kjl_index].originating_ssn;

{ Save the job_submission_time and latest_clock_time as an increment of the number of
{ microseconds that must pass before the job has reached its latest_run_time.  This value
{ will be adjusted with the clock value of the client when the job is placed in the
{ KJL on the client mainframe.

                assigned_job_list_p^ [number_of_jobs_assigned].job_submission_time :=
                      jmv$kjl_p^ [kjl_index].job_submission_time - #FREE_RUNNING_CLOCK (0);
                assigned_job_list_p^ [number_of_jobs_assigned].latest_clock_time_to_initiate :=
                      jmv$kjlx_p^ [kjl_index].latest_clock_time_to_initiate - #FREE_RUNNING_CLOCK (0);

{ The job class value returned must be the profile job class index rather than the
{ memory (job class table) index.

                assigned_job_list_p^ [number_of_jobs_assigned].job_class := profile_job_class;
                assigned_job_list_p^ [number_of_jobs_assigned].job_category_set :=
                      jmv$kjl_p^ [kjl_index].job_category_set;
                assigned_job_list_p^ [number_of_jobs_assigned].output_disposition_key :=
                      jmv$kjlx_p^ [kjl_index].output_disposition_key;
                assigned_job_list_p^ [number_of_jobs_assigned].server_kjl_index := kjl_index;
                qfp$relink_kjl_client (kjl_index, kjl_client_index);
                qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index,
                      jmc$kjl_application_acquired);
                qfp$relink_kjl_entry (kjl_index, job_class, jmc$kjl_assigned_entry);

              ELSE
                server_job_priorities [job_class] := job_priority;
                EXIT /assign_jobs_to_client/;
              IFEND;
            IFEND;
            kjl_index := next_kjl_index;
          WHILEND /assign_jobs_to_client/;
        IFEND;
      FOREND;
    ELSE

{ The KJL client table is full.  No jobs can be assigned by this server to the requesting client.

      FOR job_class := LOWERVALUE (jmt$job_class) TO UPPERVALUE (jmt$job_class) DO
        server_job_priorities [job_class] := 0;
      FOREND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$assign_jobs_to_client;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$assign_server_jobs', EJECT ??
*copy qfh$assign_server_jobs

{
{ NOTES:
{   This request cannot be executing while a profile is loading.  Before a profile is loaded
{ the job leveler task must be in sync and is not capable of requesting jobs for assignment.

  PROCEDURE [XDCL, #GATE] qfp$assign_server_jobs
    (    server_mainframe_id: pmt$binary_mainframe_id;
         assigned_job_list_p: ^jmt$jl_assigned_job_list;
     VAR number_of_jobs_assigned: jmt$job_count_range;
     VAR status: ost$status);

    VAR
      ignore_status_p: ^ost$status,
      kjl_index: jmt$kjl_index,
      kjl_server_index: jmt$kjl_server_index,
      server_in_kjl: boolean;

    status.normal := TRUE;
    number_of_jobs_assigned := 0;
    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    find_server_mainframe_id (server_mainframe_id, { add_if_not_found } TRUE, server_in_kjl,
          kjl_server_index);

    IF assigned_job_list_p <> NIL THEN

    /assign_jobs_to_server/
      WHILE number_of_jobs_assigned < UPPERBOUND (assigned_job_list_p^) DO

        IF (jmv$known_job_list.state_data [jmc$kjl_unused_entry].first_entry = jmc$kjl_undefined_index) THEN
          qfp$expand_kjl;
        IFEND;

{ If the KJL is full, the server does not fit in the KJL or a profile is loading then
{ the jobs cannot be assigned.

        IF (qfv$current_kjl_limit - jmv$known_job_list.state_data [jmc$kjl_unused_entry].number_of_entries >=
              jmv$maximum_known_jobs) OR (NOT server_in_kjl) OR (jmv$leveler_profile_loading) THEN
          osp$set_status_condition (jme$maximum_jobs, status);
          PUSH ignore_status_p;
          dpp$put_critical_message (jmc$input_queue_full_message, ignore_status_p^);
          EXIT /assign_jobs_to_server/;
        ELSE
          number_of_jobs_assigned := number_of_jobs_assigned + 1;
          kjl_index := jmv$known_job_list.state_data [jmc$kjl_unused_entry].first_entry;

          jmv$kjl_p^ [kjl_index].system_job_name := assigned_job_list_p^ [number_of_jobs_assigned].
                system_job_name;
          jmv$kjl_p^ [kjl_index].user_job_name := assigned_job_list_p^ [number_of_jobs_assigned].
                user_job_name;
          jmv$kjl_p^ [kjl_index].initiated_job_list_ordinal.block_number := LOWERVALUE (jmt$ijl_block_number);
          jmv$kjl_p^ [kjl_index].initiated_job_list_ordinal.block_index := LOWERVALUE (jmt$ijl_block_index);
          jmv$kjl_p^ [kjl_index].job_submission_time := assigned_job_list_p^ [number_of_jobs_assigned].
                job_submission_time + #FREE_RUNNING_CLOCK (0);
          jmv$kjl_p^ [kjl_index].earliest_clock_time_to_initiate := jmc$earliest_clock_time;

{ The assigned job list contains the profile index for the job class - not the
{ memory (job class table) index.

          jmv$kjl_p^ [kjl_index].job_class := jmv$profile_index_to_job_class
                [assigned_job_list_p^ [number_of_jobs_assigned].job_class];
          jmv$kjl_p^ [kjl_index].job_category_set := assigned_job_list_p^ [number_of_jobs_assigned].
                job_category_set;
          jmv$kjl_p^ [kjl_index].job_priority := qfp$job_selection_priority
                (#FREE_RUNNING_CLOCK (0), kjl_index);
          jmv$kjl_p^ [kjl_index].job_deferred_by_operator := FALSE;
          jmv$kjl_p^ [kjl_index].job_deferred_by_user := FALSE;
          jmv$kjl_p^ [kjl_index].login_family_available := TRUE;
          jmv$kjl_p^ [kjl_index].destination_usage := jmc$ve_usage;
          jmv$kjl_p^ [kjl_index].next_destination_usage := jmc$ve_usage;
          jmv$kjl_p^ [kjl_index].application_state := jmc$kjl_application_unused;
          jmv$kjl_p^ [kjl_index].application_forward_link := jmc$kjl_undefined_index;
          jmv$kjl_p^ [kjl_index].application_reverse_link := jmc$kjl_undefined_index;
          jmv$kjl_p^ [kjl_index].class_forward_link := jmc$kjl_undefined_index;
          jmv$kjl_p^ [kjl_index].class_reverse_link := jmc$kjl_undefined_index;
          jmv$kjl_p^ [kjl_index].client_index := jmc$kjl_client_undefined;
          jmv$kjl_p^ [kjl_index].client_forward_link := jmc$kjl_undefined_index;
          jmv$kjl_p^ [kjl_index].client_reverse_link := jmc$kjl_undefined_index;
          jmv$kjl_p^ [kjl_index].server_index := jmc$kjl_server_undefined;
          jmv$kjl_p^ [kjl_index].server_forward_link := jmc$kjl_undefined_index;
          jmv$kjl_p^ [kjl_index].server_reverse_link := jmc$kjl_undefined_index;
          jmv$kjl_p^ [kjl_index].server_kjl_index := assigned_job_list_p^ [number_of_jobs_assigned].
                server_kjl_index;

          jmv$kjlx_p^ [kjl_index].login_user_identification :=
                assigned_job_list_p^ [number_of_jobs_assigned].login_user_identification;
          jmv$kjlx_p^ [kjl_index].job_controller := assigned_job_list_p^ [number_of_jobs_assigned].
                control_user_identification;
          jmv$kjlx_p^ [kjl_index].originating_ssn := assigned_job_list_p^ [number_of_jobs_assigned].
                originating_ssn;
          jmv$kjlx_p^ [kjl_index].latest_clock_time_to_initiate :=
                assigned_job_list_p^ [number_of_jobs_assigned].latest_clock_time_to_initiate +
                #FREE_RUNNING_CLOCK (0);
          IF jmv$kjlx_p^ [kjl_index].latest_clock_time_to_initiate < jmc$earliest_clock_time THEN
            jmv$kjlx_p^ [kjl_index].latest_clock_time_to_initiate := jmc$earliest_clock_time;
          IFEND;
          jmv$kjlx_p^ [kjl_index].job_mode := jmc$batch;

{ The job monitor global task id is not set here - the job scheduler will set it when the job initiates.

          jmv$kjlx_p^ [kjl_index].output_disposition_key := assigned_job_list_p^ [number_of_jobs_assigned].
                output_disposition_key;
          jmv$kjlx_p^ [kjl_index].input_file_location := jmc$ifl_login_family_queue;
          jmv$kjlx_p^ [kjl_index].valid_mainframe_set := $jmt$valid_mainframe_set
                [jmc$kjl_server_this_mainframe];
          jmv$kjlx_p^ [kjl_index].timesharing_job := FALSE;
          jmv$kjlx_p^ [kjl_index].restart_job := FALSE;
          jmv$kjlx_p^ [kjl_index].system_label_p := NIL;
          jmv$kjlx_p^ [kjl_index].terminal_name := '';

          qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_queued_entry);
          qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index, jmc$kjl_application_new);
          qfp$relink_kjl_server (kjl_index, kjl_server_index);
          jmp$notify_job_scheduler_of_job (jmv$kjl_p^ [kjl_index].job_class, kjl_index);
        IFEND;
      WHILEND /assign_jobs_to_server/;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$assign_server_jobs;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$clear_server_job_classes', EJECT ??
*copy qfh$clear_server_job_classes

  PROCEDURE [XDCL, #GATE] qfp$clear_server_job_classes;

    VAR
      job_class: jmt$job_class;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);
    FOR job_class := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
      jmv$known_job_list.queued_class_entries [job_class].termination_count := 0;
      jmv$known_job_list.queued_class_entries [job_class].number_of_jobs_needed := 0;
      jmv$known_job_list.queued_class_entries [job_class].server_mainframe_priority := 0;
      IF jmv$known_job_list.queued_class_entries [job_class].class_blocked_for_initiation THEN
        jmv$known_job_list.queued_class_entries [job_class].class_blocked_for_initiation := FALSE;
        jmp$notify_job_scheduler_of_job (job_class, jmc$kjl_undefined_index);
      IFEND;
    FOREND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$clear_server_job_classes;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$determine_needed_priorities', EJECT ??
*copy qfh$determine_needed_priorities

  PROCEDURE [XDCL, #GATE] qfp$determine_needed_priorities
    (    leveler_job_class_data: jmt$jl_job_class_data;
     VAR job_class_priorities: jmt$jl_job_class_priorities);

    VAR
      current_clock_time: jmt$clock_time,
      eligible_job_categories: boolean,
      job_class: jmt$job_class,
      kjl_index: jmt$kjl_index,
      number_of_jobs_needed: ost$non_negative_integers,
      profile_job_class: jmt$job_class;

    current_clock_time := #FREE_RUNNING_CLOCK (0);
    osp$set_mainframe_sig_lock (qfv$kjl_lock);
    FOR profile_job_class := 1 TO jmv$maximum_profile_index DO
      job_class := jmv$profile_index_to_job_class [profile_job_class];
      number_of_jobs_needed := leveler_job_class_data [profile_job_class].termination_count +
            leveler_job_class_data [profile_job_class].room_in_class;
      kjl_index := jmv$known_job_list.queued_class_entries [job_class].first_queued_class_entry;
      WHILE (kjl_index <> jmc$kjl_undefined_index) AND (number_of_jobs_needed > 0) DO
        eligible_job_categories := ((jmv$job_scheduler_table.initiation_required_categories *
              jmv$kjl_p^ [kjl_index].job_category_set) = jmv$job_scheduler_table.
              initiation_required_categories) AND ((jmv$job_scheduler_table.initiation_excluded_categories *
              jmv$kjl_p^ [kjl_index].job_category_set) = $jmt$job_category_set []);
        IF eligible_job_categories THEN
          number_of_jobs_needed := number_of_jobs_needed - 1;
          IF number_of_jobs_needed > 0 THEN
            kjl_index := jmv$kjl_p^ [kjl_index].class_forward_link;
          IFEND;
        ELSE
          kjl_index := jmv$kjl_p^ [kjl_index].class_forward_link;
        IFEND;
      WHILEND;
      IF kjl_index = jmc$kjl_undefined_index THEN
        job_class_priorities [profile_job_class].job_priority :=
              jmv$job_class_table_p^ [job_class].selection_priority.initial;
        job_class_priorities [profile_job_class].based_on_selection_priority := TRUE;
      ELSE
        job_class_priorities [profile_job_class].job_priority :=
              qfp$job_selection_priority (current_clock_time, kjl_index);
        job_class_priorities [profile_job_class].based_on_selection_priority := FALSE;
      IFEND;
      IF job_class_priorities [profile_job_class].job_priority <
            jmv$job_class_table_p^ [job_class].selection_priority.threshold THEN
        job_class_priorities [profile_job_class].job_priority :=
              jmv$job_class_table_p^ [job_class].selection_priority.threshold;
      IFEND;
    FOREND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$determine_needed_priorities;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$determine_need_for_jobs', EJECT ??
*copy qfh$determine_need_for_jobs

{ NOTE:
{   The KJL does not need to be locked during this request since no linkages
{ are changed and only one copy of the job leveler can be active at a time.

  PROCEDURE [XDCL, #GATE] qfp$determine_need_for_jobs
    (VAR leveler_job_class_data: jmt$jl_job_class_data);

    VAR
      job_class: jmt$job_class,
      number_of_jobs_needed: jmt$job_count_range,
      profile_job_class: jmt$job_class;

    FOR profile_job_class := 1 TO jmv$maximum_profile_index DO
      job_class := jmv$profile_index_to_job_class [profile_job_class];
      IF NOT jmv$job_class_table_p^ [job_class].enable_class_initiation THEN
        leveler_job_class_data [profile_job_class].room_in_class := 0;
        leveler_job_class_data [profile_job_class].class_maximum := 0;
        leveler_job_class_data [profile_job_class].termination_count := 0;
        number_of_jobs_needed := 0;
      ELSE
        leveler_job_class_data [profile_job_class].termination_count :=
              jmv$known_job_list.queued_class_entries [job_class].termination_count;
        leveler_job_class_data [profile_job_class].class_maximum :=
              jmv$job_class_table_p^ [job_class].initiation_level.preferred;
        IF (leveler_job_class_data [profile_job_class].class_maximum - jmv$job_counts.
              job_class_counts [job_class].initiated_jobs) < 0 THEN
          leveler_job_class_data [profile_job_class].room_in_class := 0;
        ELSE
          leveler_job_class_data [profile_job_class].room_in_class :=
                leveler_job_class_data [profile_job_class].class_maximum - jmv$job_counts.
                job_class_counts [job_class].initiated_jobs;
        IFEND;
        IF (leveler_job_class_data [profile_job_class].termination_count +
              leveler_job_class_data [profile_job_class].room_in_class) >
              UPPERVALUE (jmt$job_count_range) THEN
          number_of_jobs_needed := UPPERVALUE (jmt$job_count_range);
        ELSE
          number_of_jobs_needed := leveler_job_class_data [profile_job_class].termination_count +
                leveler_job_class_data [profile_job_class].room_in_class;
        IFEND;
      IFEND;
      jmv$known_job_list.queued_class_entries [job_class].number_of_jobs_needed := number_of_jobs_needed;
      jmv$known_job_list.queued_class_entries [job_class].termination_count := 0;
    FOREND;
  PROCEND qfp$determine_need_for_jobs;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$discard_client_jobs', EJECT ??
*copy qfh$discard_client_jobs

  PROCEDURE [XDCL, #GATE] qfp$discard_client_jobs
    (    client_mainframe_id: pmt$binary_mainframe_id);

    VAR
      client_in_kjl: boolean,
      kjl_index: jmt$kjl_index,
      kjl_client_index: jmt$kjl_client_index,
      next_kjl_index: jmt$kjl_index;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    find_client_mainframe_id (client_mainframe_id, { add_if_not_found } FALSE, client_in_kjl,
          kjl_client_index);
    IF client_in_kjl THEN
      kjl_index := jmv$known_job_list.client_data.state_data [kjl_client_index].first_entry;
      WHILE (kjl_index <> jmc$kjl_undefined_index) DO
        next_kjl_index := jmv$kjl_p^ [kjl_index].client_forward_link;
        IF (jmv$kjl_p^ [kjl_index].entry_kind = jmc$kjl_assigned_entry) THEN
          qfp$relink_kjl_client (kjl_index, jmc$kjl_client_undefined);
          qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index, jmc$kjl_application_new);
          qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_queued_entry);
        IFEND;
        kjl_index := next_kjl_index;
      WHILEND
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$discard_client_jobs;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$discard_server_jobs', EJECT ??
*copy qfh$discard_server_jobs

  PROCEDURE [XDCL, #GATE] qfp$discard_server_jobs
    (    server_mainframe_id: pmt$binary_mainframe_id);

    VAR
      job_class: jmt$job_class,
      kjl_index: jmt$kjl_index,
      kjl_server_index: jmt$kjl_server_index,
      next_kjl_index: jmt$kjl_index,
      scheduler_has_jobs: boolean,
      server_in_kjl: boolean;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    find_server_mainframe_id (server_mainframe_id, { add_if_not_found } FALSE, server_in_kjl,
          kjl_server_index);
    IF server_in_kjl THEN
      scheduler_has_jobs := FALSE;

{ Check to see if the job scheduler has any jobs for this server in the job
{ candidate queue.  If it doesn't don't bother the scheduler.  If the system
{ is in an idled state (an idle jobs request would do it) the scheduler may not
{ be willing to clean out the candidate queue.  The scheduler should never go
{ idle with jobs in the candidate queue.

    /search_candidate_queue_for_jobs/
      FOR job_class := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
        IF jmv$candidate_queued_jobs [job_class].candidate_available THEN
          IF (jmv$kjl_p^ [jmv$candidate_queued_jobs [job_class].kjl_index].server_index =
                kjl_server_index) THEN
            scheduler_has_jobs := TRUE;
            EXIT /search_candidate_queue_for_jobs/;
          IFEND;
        IFEND;
      FOREND /search_candidate_queue_for_jobs/;

      IF scheduler_has_jobs THEN
        jmp$force_candidate_refresh ({ flush_candidate_queue } TRUE);
      IFEND;

      kjl_index := jmv$known_job_list.server_data.state_data [kjl_server_index].first_entry;
      WHILE (kjl_index <> jmc$kjl_undefined_index) DO
        next_kjl_index := jmv$kjl_p^ [kjl_index].server_forward_link;
        IF (jmv$kjl_p^ [kjl_index].entry_kind = jmc$kjl_queued_entry) THEN
          qfp$relink_kjl_server (kjl_index, jmc$kjl_server_undefined);
          qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index, jmc$kjl_application_unused);
          qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_unused_entry);
        IFEND;
        kjl_index := next_kjl_index;
      WHILEND
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$discard_server_jobs;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$get_server_jobs', EJECT ??
*copy qfh$get_server_jobs

  PROCEDURE [XDCL, #GATE] qfp$get_server_jobs
    (    server_mainframe_id: pmt$binary_mainframe_id;
         server_job_list_p: { output } ^jmt$jl_server_job_list;
     VAR server_job_count: jmt$job_count_range);

    VAR
      kjl_index: jmt$kjl_index,
      kjl_server_index: jmt$kjl_server_index,
      server_in_kjl: boolean;

    server_job_count := 0;
    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    find_server_mainframe_id (server_mainframe_id, { add_if_not_found } FALSE, server_in_kjl,
          kjl_server_index);
    IF server_in_kjl THEN
      kjl_index := jmv$known_job_list.server_data.state_data [kjl_server_index].first_entry;
      WHILE (kjl_index <> jmc$kjl_undefined_index) DO
        server_job_count := server_job_count + 1;
        server_job_list_p^ [server_job_count].system_job_name := jmv$kjl_p^ [kjl_index].system_job_name;
        server_job_list_p^ [server_job_count].kjl_entry_kind := jmv$kjl_p^ [kjl_index].entry_kind;
        server_job_list_p^ [server_job_count].server_kjl_index := jmv$kjl_p^ [kjl_index].server_kjl_index;
        kjl_index := jmv$kjl_p^ [kjl_index].server_forward_link;
      WHILEND
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$get_server_jobs;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$register_job_leveler', EJECT ??
*copy qfh$register_job_leveler

  PROCEDURE [XDCL, #GATE] qfp$register_job_leveler;

    VAR
      job_class: jmt$job_class;

    pmp$get_executing_task_gtid (jmv$known_job_list.application_table [jmc$ve_input_application_index].
          global_task_id);
    FOR job_class := jmc$system_job_class TO jmv$maximum_job_class_in_use DO
      jmv$known_job_list.queued_class_entries [job_class].termination_count := 0;
    FOREND;
  PROCEND qfp$register_job_leveler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$server_job_begin', EJECT ??
*copy qfh$server_job_begin

  PROCEDURE [XDCL, #GATE] qfp$server_job_begin
    (    job_begin_information: jmt$jl_server_job_end_info;
     VAR job_terminated: boolean;
     VAR login_family: ost$name);

    VAR
      client_in_kjl: boolean,
      kjl_client_index: jmt$kjl_client_index,
      server_kjl_index: jmt$kjl_index,
      unassigned_job_index: ost$non_negative_integers;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);
    find_client_mainframe_id (job_begin_information.client_mainframe_id, { add_if_not_found } TRUE,
          client_in_kjl, kjl_client_index);
    IF client_in_kjl THEN
      determine_server_kjl_index (kjl_client_index, job_begin_information.system_job_name,
            job_begin_information.server_kjl_index, server_kjl_index);
      IF server_kjl_index <> jmc$kjl_undefined_index THEN
        job_terminated := jmv$kjl_p^ [server_kjl_index].entry_kind = jmc$kjl_terminated_entry;
        qfp$relink_kjl_entry (server_kjl_index, jmv$kjl_p^ [server_kjl_index].job_class,
              jmc$kjl_initiated_entry);
        login_family := jmv$kjlx_p^ [server_kjl_index].login_user_identification.family;
      ELSE

{ Trap code...
{       osp$system_error ('The server KJL lost a client job.', NIL);

        login_family := '';
      IFEND;
    ELSE

{ Trap code...
{     osp$system_error ('The server KJL lost a client mainframe.', NIL);

      login_family := '';
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$server_job_begin;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$server_job_end', EJECT ??
*copy qfh$server_job_end

  PROCEDURE [XDCL, #GATE] qfp$server_job_end
    (    job_end_information: jmt$jl_server_job_end_info);

    VAR
      client_in_kjl: boolean,
      kjl_client_index: jmt$kjl_client_index,
      server_kjl_index: jmt$kjl_index,
      unassigned_job_index: ost$non_negative_integers;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);
    find_client_mainframe_id (job_end_information.client_mainframe_id, { add_if_not_found } TRUE,
          client_in_kjl, kjl_client_index);
    IF client_in_kjl THEN
      determine_server_kjl_index (kjl_client_index, job_end_information.system_job_name,
            job_end_information.server_kjl_index, server_kjl_index);
      IF server_kjl_index <> jmc$kjl_undefined_index THEN
        IF job_end_information.job_requests_restart THEN

{ The job's KJL entry is already in the correct server and client thread.

          qfp$relink_kjl_application (server_kjl_index, jmc$ve_input_application_index,
                jmc$kjl_application_acquired);
          qfp$relink_kjl_entry (server_kjl_index, jmv$kjl_p^ [server_kjl_index].job_class,
                jmc$kjl_assigned_entry);
        ELSE
          qfp$relink_kjl_application (server_kjl_index, jmc$ve_input_application_index,
                jmc$kjl_application_unused);
          qfp$relink_kjl_client (server_kjl_index, jmc$kjl_client_undefined);
          qfp$relink_kjl_server (server_kjl_index, jmc$kjl_server_undefined);
          qfp$relink_kjl_entry (server_kjl_index, jmv$kjl_p^ [server_kjl_index].job_class,
                jmc$kjl_unused_entry);
        IFEND;
      ELSE

{ Trap code...
{       osp$system_error ('The server KJL lost a client job.', NIL);

      IFEND;
    ELSE

{ Trap code...
{     osp$system_error ('The server KJL lost a client mainframe.', NIL);

    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$server_job_end;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$set_leveler_ready', EJECT ??
*copy qfh$set_leveler_ready

  PROCEDURE [XDCL, #GATE] qfp$set_leveler_ready
    (    ready_leveler: boolean);

    qfv$leveler_readied := ready_leveler;
  PROCEND qfp$set_leveler_ready;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$unassign_client_jobs', EJECT ??
*copy qfh$unassign_client_jobs

  PROCEDURE [XDCL, #GATE] qfp$unassign_client_jobs
    (    client_mainframe_id: pmt$binary_mainframe_id;
         unassigned_job_list_p: ^jmt$jl_unassigned_job_list);

    VAR
      client_in_kjl: boolean,
      kjl_client_index: jmt$kjl_client_index,
      server_kjl_index: jmt$kjl_index,
      unassigned_job_index: ost$non_negative_integers;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);
    find_client_mainframe_id (client_mainframe_id, { add_if_not_found } TRUE, client_in_kjl,
          kjl_client_index);
    IF client_in_kjl AND (unassigned_job_list_p <> NIL) THEN
      FOR unassigned_job_index := 1 TO UPPERBOUND (unassigned_job_list_p^) DO
        determine_server_kjl_index (kjl_client_index, unassigned_job_list_p^ [unassigned_job_index].
              system_job_name, unassigned_job_list_p^ [unassigned_job_index].server_kjl_index,
              server_kjl_index);
        IF server_kjl_index <> jmc$kjl_undefined_index THEN
          qfp$relink_kjl_application (server_kjl_index, jmc$ve_input_application_index,
                jmc$kjl_application_new);
          qfp$relink_kjl_client (server_kjl_index, jmc$kjl_client_undefined);
          qfp$relink_kjl_entry (server_kjl_index, jmv$kjl_p^ [server_kjl_index].job_class,
                jmc$kjl_queued_entry);

        ELSE
          osp$system_error ('The server KJL lost a client job.', NIL);
        IFEND;
      FOREND;
    ELSE
      IF NOT client_in_kjl THEN
        osp$system_error ('The server KJL lost a client mainframe.', NIL);
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$unassign_client_jobs;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$unassign_server_jobs', EJECT ??
*copy qfh$unassign_server_jobs

  PROCEDURE [XDCL, #GATE] qfp$unassign_server_jobs
    (    server_mainframe_id: pmt$binary_mainframe_id;
         unassign_all_jobs: boolean;
         job_class_priorities: jmt$jl_job_class_priorities;
         unassigned_job_list_p { output } : ^jmt$jl_unassigned_job_list;
     VAR number_of_unassigned_jobs: jmt$job_count_range);

    VAR
      current_clock_time: jmt$clock_time,
      job_class: jmt$job_class,
      kjl_index: jmt$kjl_index,
      kjl_server_index: jmt$kjl_server_index,
      next_kjl_index: jmt$kjl_index,
      server_in_kjl: boolean;

    number_of_unassigned_jobs := 0;
    current_clock_time := #FREE_RUNNING_CLOCK (0);
    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    find_server_mainframe_id (server_mainframe_id, { add_if_not_found } FALSE, server_in_kjl,
          kjl_server_index);
    IF server_in_kjl THEN
      IF unassign_all_jobs THEN
        jmp$force_candidate_refresh ({ flush_candidate_queue } TRUE);
      IFEND;
      kjl_index := jmv$known_job_list.server_data.state_data [kjl_server_index].last_entry;
      WHILE (kjl_index <> jmc$kjl_undefined_index) AND (number_of_unassigned_jobs <
            UPPERBOUND (unassigned_job_list_p^)) DO
        next_kjl_index := jmv$kjl_p^ [kjl_index].server_reverse_link;
        IF (jmv$kjl_p^ [kjl_index].entry_kind = jmc$kjl_queued_entry) AND
              (jmv$kjl_p^ [kjl_index].application_state <= jmc$kjl_application_new) THEN
          job_class := jmv$kjl_p^ [kjl_index].job_class;
          jmv$kjl_p^ [kjl_index].job_priority := qfp$job_selection_priority (current_clock_time, kjl_index);
          IF unassign_all_jobs OR (jmv$known_job_list.queued_class_entries [job_class].number_of_jobs_needed =
                0) OR (jmv$kjl_p^ [kjl_index].job_priority < job_class_priorities
                [jmv$job_class_table_p^ [job_class].profile_index].job_priority) THEN
            number_of_unassigned_jobs := number_of_unassigned_jobs + 1;
            unassigned_job_list_p^ [number_of_unassigned_jobs].system_job_name :=
                  jmv$kjl_p^ [kjl_index].system_job_name;
            unassigned_job_list_p^ [number_of_unassigned_jobs].server_kjl_index :=
                  jmv$kjl_p^ [kjl_index].server_kjl_index;
            qfp$relink_kjl_server (kjl_index, jmc$kjl_server_undefined);
            qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index,
                  jmc$kjl_application_unused);
            qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_unused_entry);
          IFEND;
        IFEND;
        kjl_index := next_kjl_index;
      WHILEND
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$unassign_server_jobs;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$update_server_priorities', EJECT ??
*copy qfh$update_server_priorities

  PROCEDURE [XDCL, #GATE] qfp$update_server_priorities
    (    highest_server_priorities: jmt$jl_server_job_priorities);

    VAR
      job_class: jmt$job_class,
      profile_job_class: jmt$job_class;

    osp$set_mainframe_sig_lock (qfv$kjl_lock);
    FOR profile_job_class := 1 TO jmv$maximum_profile_index DO
      job_class := jmv$profile_index_to_job_class [profile_job_class];
      jmv$known_job_list.queued_class_entries [job_class].server_mainframe_priority :=
            highest_server_priorities [profile_job_class];
      IF jmv$known_job_list.queued_class_entries [job_class].class_blocked_for_initiation THEN
        jmp$notify_job_scheduler_of_job (job_class, jmc$kjl_undefined_index);
        jmv$known_job_list.queued_class_entries [job_class].class_blocked_for_initiation := FALSE;
      IFEND;
    FOREND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$update_server_priorities;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$verify_client_assigned_jobs', EJECT ??
*copy qfh$verify_client_assigned_jobs

  PROCEDURE [XDCL, #GATE] qfp$verify_client_assigned_jobs
    (    client_mainframe_id: pmt$binary_mainframe_id;
         server_job_list_p: ^jmt$jl_server_job_list;
         missing_job_list_p: { output } ^jmt$jl_missing_job_list;
     VAR missing_job_count: jmt$job_count_range);

    VAR
      client_in_kjl: boolean,
      job_in_server_list: boolean,
      kjl_index: jmt$kjl_index,
      kjl_client_index: jmt$kjl_client_index,
      maximum_server_job_index: jmt$job_count_range,
      next_kjl_index: jmt$kjl_index,
      server_job_list_index: jmt$job_count_range;

    missing_job_count := 0;
    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    find_client_mainframe_id (client_mainframe_id, { add_if_not_found } FALSE, client_in_kjl,
          kjl_client_index);
    IF client_in_kjl THEN
      IF server_job_list_p = NIL THEN
        maximum_server_job_index := 0;
      ELSE
        maximum_server_job_index := UPPERBOUND (server_job_list_p^);
      IFEND;

      kjl_index := jmv$known_job_list.client_data.state_data [kjl_client_index].first_entry;
      WHILE (kjl_index <> jmc$kjl_undefined_index) DO
        next_kjl_index := jmv$kjl_p^ [kjl_index].client_forward_link;

{ Find the job in the server job list.  If it is there, verify the job state.  If it is not
{ there, the job was lost and should be made available for initiation again if it was still
{ in the queued state.

        job_in_server_list := FALSE;

      /search_for_job_in_server_list/
        FOR server_job_list_index := 1 TO maximum_server_job_index DO
          IF jmv$kjl_p^ [kjl_index].system_job_name = server_job_list_p^ [server_job_list_index].
                system_job_name THEN
            job_in_server_list := TRUE;
            IF jmv$kjl_p^ [kjl_index].entry_kind <> server_job_list_p^ [server_job_list_index].
                  kjl_entry_kind THEN

{ This can happen if job begin hasn't updated the server yet.  This can also happen if
{ a job has been queued for restart due to job recovery on the client.
{ The state of the job on the client is the correct state so change the state of
{ the job on the server.

{ If the entry is queued, the job is "assigned" to the client.  If the entry is
{ initiated, don't change anything since the client will be updating the server
{ shortly to say that the job is initiated.

              IF server_job_list_p^ [server_job_list_index].kjl_entry_kind = jmc$kjl_queued_entry THEN
                qfp$relink_kjl_client (kjl_index, kjl_client_index);
                qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index,
                      jmc$kjl_application_acquired);
                qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_assigned_entry);
              IFEND;
            IFEND;
            EXIT /search_for_job_in_server_list/;
          IFEND;
        FOREND /search_for_job_in_server_list/;

        IF NOT job_in_server_list THEN

{ If the job was queued, make it available for initiation.  If the job initiated
{ then the job must be removed from the KJL.

          IF (jmv$kjl_p^ [kjl_index].entry_kind = jmc$kjl_queued_entry) THEN
            qfp$relink_kjl_client (kjl_index, jmc$kjl_client_undefined);
            qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index, jmc$kjl_application_new);
          ELSE
            IF missing_job_list_p <> NIL THEN
              IF missing_job_count < UPPERBOUND (missing_job_list_p^) THEN
                missing_job_count := missing_job_count + 1;
                missing_job_list_p^ [missing_job_count].system_job_name :=
                      jmv$kjl_p^ [kjl_index].system_job_name;
                missing_job_list_p^ [missing_job_count].login_family :=
                      jmv$kjlx_p^ [kjl_index].login_user_identification.family;
              IFEND;
            IFEND;
            qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index,
                  jmc$kjl_application_unused);
            qfp$relink_kjl_client (kjl_index, jmc$kjl_client_undefined);
            qfp$relink_kjl_server (kjl_index, jmc$kjl_server_undefined);
            qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_unused_entry);
          IFEND;
        IFEND;
        kjl_index := next_kjl_index;
      WHILEND
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$verify_client_assigned_jobs;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$verify_inactive_server', EJECT ??
*copyc qfh$verify_inactive_server

  PROCEDURE [XDCL, #GATE] qfp$verify_inactive_server
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR server_inactive: boolean);

    VAR
      kjl_index: jmt$kjl_index,
      kjl_server_index: jmt$kjl_server_index,
      next_kjl_index: jmt$kjl_index,
      server_in_kjl: boolean;

    server_inactive := TRUE;
    osp$set_mainframe_sig_lock (qfv$kjl_lock);

    find_server_mainframe_id (server_mainframe_id, { add_if_not_found } FALSE, server_in_kjl,
          kjl_server_index);
    IF server_in_kjl THEN
      kjl_index := jmv$known_job_list.server_data.state_data [kjl_server_index].first_entry;
      WHILE (kjl_index <> jmc$kjl_undefined_index) DO
        next_kjl_index := jmv$kjl_p^ [kjl_index].server_forward_link;
        IF (jmv$kjl_p^ [kjl_index].entry_kind = jmc$kjl_queued_entry) AND
              (jmv$kjl_p^ [kjl_index].application_state <= jmc$kjl_application_new) THEN
          server_inactive := FALSE;

          osp$system_error ('Inactive Server has uninitiated jobs on the Client.', NIL);

          qfp$relink_kjl_server (kjl_index, jmc$kjl_server_undefined);
          qfp$relink_kjl_application (kjl_index, jmc$ve_input_application_index, jmc$kjl_application_unused);
          qfp$relink_kjl_entry (kjl_index, jmv$kjl_p^ [kjl_index].job_class, jmc$kjl_unused_entry);
        IFEND;
        kjl_index := next_kjl_index;
      WHILEND
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);
  PROCEND qfp$verify_inactive_server;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$wait_for_leveler_deactivate', EJECT ??
*copy qfh$wait_for_leveler_deactivate

  PROCEDURE [XDCL, #GATE] qfp$wait_for_leveler_deactivate
    (    wait_time_sec: ost$non_negative_integers;
     VAR leveler_deactivated: boolean);

    CONST
      number_of_us_in_a_second = 1000000;

    VAR
      current_time: jmt$clock_time,
      end_time: jmt$clock_time,
      ignore_status: ost$status,
      kjl_server_index: jmt$kjl_server_index,
      kjl_index: jmt$kjl_index,
      queued_job_found: boolean,
      start_time: jmt$clock_time;

    start_time := #FREE_RUNNING_CLOCK (0);
    end_time := start_time + wait_time_sec * number_of_us_in_a_second;
    current_time := start_time;
    leveler_deactivated := FALSE;

{ Lock and unlock the KJL to ensure synchronization.  This ensures that no job levelers
{ are in the process of modifying the KJL.  Any additional requests for levelers to
{ modify the KJL are controlled by the variable jmv$leveler_profile_loading.

    osp$set_mainframe_sig_lock (qfv$kjl_lock);
    osp$clear_mainframe_sig_lock (qfv$kjl_lock);

{ Wait for other job levelers to return jobs to this mainframe.  Once no jobs are
{ assigned the request can continue.

    WHILE (current_time <= end_time) AND (jmv$known_job_list.state_data [jmc$kjl_assigned_entry].
          number_of_entries > 0) DO
      pmp$delay (1000, ignore_status);
      current_time := #FREE_RUNNING_CLOCK (0);
      #SPOIL (jmv$known_job_list.state_data);
    WHILEND;

{ Wait for the job leveler on this mainframe to return all jobs.  Go through each
{ server thread and verify that there are no longer any jobs assigned by that server.

    IF current_time <= end_time THEN

    /wait_for_client_levelers/
      REPEAT
        queued_job_found := FALSE;
        osp$set_mainframe_sig_lock (qfv$kjl_lock);

      /check_each_client_leveler/
        FOR kjl_server_index := jmc$kjl_server_this_mainframe + 1 TO UPPERVALUE (jmt$kjl_server_index) DO
          IF jmv$known_job_list.server_data.state_data [kjl_server_index].mainframe_id <>
                null_binary_mainframe_id THEN
            kjl_index := jmv$known_job_list.server_data.state_data [kjl_server_index].first_entry;

            WHILE kjl_index <> jmc$kjl_undefined_index DO
              IF jmv$kjl_p^ [kjl_index].entry_kind = jmc$kjl_queued_entry THEN
                queued_job_found := TRUE;
                EXIT /check_each_client_leveler/;
              ELSE
                kjl_index := jmv$kjl_p^ [kjl_index].server_forward_link;
              IFEND;
            WHILEND;
          IFEND;
        FOREND /check_each_client_leveler/;
        osp$clear_mainframe_sig_lock (qfv$kjl_lock);
        IF queued_job_found THEN
          pmp$delay (1000, ignore_status);
          current_time := #FREE_RUNNING_CLOCK (0);
        IFEND;
      UNTIL (current_time > end_time) OR (NOT queued_job_found);
      leveler_deactivated := NOT queued_job_found;
    IFEND;

  PROCEND qfp$wait_for_leveler_deactivate;
?? OLDTITLE ??
MODEND qfm$queue_file_leveler_manager;
*DECK DECK=QFM$QUEUE_FILE_OUTPUT_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Job Management: Queue File Output Internal Interfaces' ??
MODULE qfm$queue_file_output_manager;

{ PURPOSE:
{   This module contains the Queue File Management system core interfaces for managing files in the
{ output queue and the Known Output List (KOL).
{
{ DESIGN:
{   These procedures execute in ring one and can be called from ring 3.  These procedures access
{ the ring one table the Known Output List (KOL).  It is contained in mainframe pageable.  A signature
{ lock is used in order to ensure synchronous access to the KOL.

?? NEWTITLE := 'Global Declarations Referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$job_management_id
*copyc jmc$kol_maximum_entries
*copyc jmc$maximum_output_count
*copyc jmc$output_queue_full_message
*copyc jme$queued_file_conditions
*copyc jmt$clock_time
*copyc jmt$destination_usage
*copyc jmt$job_attributes
*copyc jmt$known_output_list
*copyc jmt$known_output_list_entry
*copyc jmt$kol_entry_kind
*copyc jmt$kol_entry_kind_set
*copyc jmt$kol_index
*copyc jmt$name
*copyc jmt$name_list
*copyc jmt$output_attribute_options
*copyc jmt$output_count_range
*copyc jmt$output_counts
*copyc jmt$output_descriptor
*copyc jmt$output_state
*copyc jmt$output_state_set
*copyc jmt$output_status_count
*copyc jmt$output_status_options
*copyc jmt$output_status_results
*copyc jmt$output_system_id
*copyc jmt$output_system_label
*copyc jmt$queue_file_password
*copyc jmt$release_output_file_list
*copyc jmt$reprint_disposition
*copyc jmt$results_keys
*copyc jmt$system_supplied_name
*copyc jmt$work_area
*copyc oss$mainframe_pageable
*copyc oss$mainframe_paged_literal
*copyc ost$byte
*copyc ost$global_task_id
*copyc ost$halfword
*copyc ost$signature_lock
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*copyc dpp$put_critical_message
*copyc osp$clear_mainframe_sig_lock
*copyc osp$monitor_fault_to_status
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$test_sig_lock
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_mainframe_id
*copyc pmp$ready_task
*copyc pmp$zero_out_table
*copyc syp$continue_to_cause
*copyc syp$disestablish_cond_handler
*copyc syp$establish_condition_handler
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    jmv$output_file_recovery_option: [XDCL, #GATE, oss$mainframe_pageable] ost$byte := 0,
    jmv$time_to_purge_expired_file: [XDCL, #GATE, oss$mainframe_pageable] jmt$clock_time :=
          jmc$latest_clock_time,
    jmv$time_to_purge_printed_file: [XDCL, #GATE, oss$mainframe_pageable] jmt$clock_time :=
          jmc$latest_clock_time,
    jmv$time_to_ready_deferred_file: [XDCL, #GATE, oss$mainframe_pageable] jmt$clock_time :=
          jmc$latest_clock_time,
    jmv$known_output_list: [XDCL, #GATE, oss$mainframe_pageable] jmt$known_output_list,
    jmv$kol_p: [XDCL, #GATE, oss$mainframe_pageable] ^array [1 .. * ] of jmt$known_output_list_entry := NIL,
    jmv$maximum_known_outputs: [XDCL, #GATE, oss$mainframe_pageable] ost$halfword := 150,
    qfv$current_kol_limit: [XDCL, #GATE, oss$mainframe_pageable] jmt$kol_index := 0,
    qfv$kol_lock: [XDCL, oss$mainframe_pageable] ost$signature_lock;

?? TITLE := 'convert_state_to_entry_kind', EJECT ??

{ PURPOSE:
{   The purpose of this request is to convert an output state to its Known Output List entry-kind
{ equivalent.

  PROCEDURE convert_state_to_entry_kind
    (    output_state: jmt$output_state;
     VAR kol_entry_kind: jmt$kol_entry_kind;
     VAR status: ost$status);

    status.normal := TRUE;
    CASE output_state OF
    = jmc$deferred_output =
      kol_entry_kind := jmc$kol_deferred_entry;

    = jmc$queued_output =
      kol_entry_kind := jmc$kol_queued_entry;

    = jmc$initiated_output =
      kol_entry_kind := jmc$kol_initiated_entry;

    = jmc$terminated_output =
      kol_entry_kind := jmc$kol_terminated_entry;

    = jmc$completed_output =
      kol_entry_kind := jmc$kol_completed_entry;
    ELSE
      osp$set_status_abnormal (jmc$job_management_id, jme$invalid_output_state, '', status);
    CASEND;
  PROCEND convert_state_to_entry_kind;
?? OLDTITLE ??
?? NEWTITLE := 'expand_kol', EJECT ??

{ PURPOSE:
{   The purpose of this request is to extend the initialized portion of the
{ Known Output List (KOL).  If the KOL is at its limit, this request does nothing.
{
{ CAUTION:  This request cannot be performed in a loop in ring one.  If
{           several entries must be added to the KOL this request must be
{           called from ring 3.  The reason for this is because pages
{           assigned in ring 1 do not get backing store until the ring is
{           exited.  So if too many new pages are added to the KOL, memory
{           may be exhausted and the system will crash or hang.

  PROCEDURE expand_kol;

    CONST
      expand_increment = 100;

    VAR
      kol_index: jmt$kol_index,
      new_kol_limit: jmt$kol_index;

    IF qfv$current_kol_limit < jmc$kol_maximum_entries THEN
      IF qfv$current_kol_limit + expand_increment > jmc$kol_maximum_entries THEN
        new_kol_limit := jmc$kol_maximum_entries;
      ELSE
        new_kol_limit := qfv$current_kol_limit + expand_increment;
      IFEND;
      FOR kol_index := qfv$current_kol_limit + 1 TO new_kol_limit - 1 DO
        jmv$kol_p^ [kol_index].forward_link := kol_index + 1;
        jmv$kol_p^ [kol_index].reverse_link := kol_index - 1;
        jmv$kol_p^ [kol_index].entry_kind := jmc$kol_unused_entry;
      FOREND;
      jmv$kol_p^ [new_kol_limit].forward_link := jmc$kol_undefined_index;
      jmv$kol_p^ [new_kol_limit].reverse_link := new_kol_limit - 1;
      jmv$kol_p^ [new_kol_limit].entry_kind := jmc$kol_unused_entry;

      jmv$known_output_list.state_data [jmc$kol_unused_entry].number_of_entries :=
            jmv$known_output_list.state_data [jmc$kol_unused_entry].number_of_entries + new_kol_limit -
            qfv$current_kol_limit;
      IF jmv$known_output_list.state_data [jmc$kol_unused_entry].first_entry = jmc$kol_undefined_index THEN
        jmv$known_output_list.state_data [jmc$kol_unused_entry].first_entry := qfv$current_kol_limit + 1;
        jmv$kol_p^ [qfv$current_kol_limit + 1].reverse_link := jmc$kol_undefined_index;
        jmv$known_output_list.state_data [jmc$kol_unused_entry].last_entry := new_kol_limit;

      ELSE
        jmv$kol_p^ [qfv$current_kol_limit + 1].reverse_link := jmv$known_output_list.
              state_data [jmc$kol_unused_entry].last_entry;
        jmv$kol_p^ [jmv$known_output_list.state_data [jmc$kol_unused_entry].last_entry].forward_link :=
              qfv$current_kol_limit + 1;
        jmv$known_output_list.state_data [jmc$kol_unused_entry].last_entry := new_kol_limit;
      IFEND;
      qfv$current_kol_limit := new_kol_limit;
    IFEND;
  PROCEND expand_kol;
?? OLDTITLE ??
?? NEWTITLE := 'find_destination_usage', EJECT ??

{ PURPOSE:
{   The purpose of this request is to find the specified destination_usage in the application table
{ and return with the application index.  If there is no application registered for the destination_usage
{ specified the value jmc$unassigned_output_index is returned.
{
{ DESIGN:
{   Starting with the index of the last application assigned, search backwards through the chain until
{ the destination_usage is found or there are no more applications to search.
{
{ NOTES:
{   The Known Output List (KOL) MUST be locked when this request is made.

  PROCEDURE find_destination_usage
    (    destination_usage: jmt$destination_usage;
     VAR application_index: jmt$output_application_index);

    application_index := UPPERBOUND (jmv$known_output_list.application_table);

    WHILE (jmv$known_output_list.application_table [application_index].destination_usage <>
          destination_usage) AND (application_index <> jmc$unassigned_output_index) DO
      application_index := application_index - 1;
    WHILEND;
  PROCEND find_destination_usage;
?? TITLE := 'find_output_file_by_application', EJECT ??

{ PURPOSE:
{   The purpose of this request is to find a file assigned to a particular application by using its
{ system_file_name.
{
{ DESIGN:
{   Search the Known Output List (KOL) for the file that has been assigned to the application specified.
{ If the entry in the KOL is not found, return a kol_index of jmc$kol_undefined_index.
{
{ NOTES:
{   The KOL must be locked when this request is issued.

  PROCEDURE find_output_file_by_application
    (    system_file_name: jmt$system_supplied_name;
         application_index: jmt$output_application_index;
     VAR kol_index: jmt$kol_index);

    VAR
      application_state: jmt$kol_application_state;

  /search_for_the_specified_file/
    FOR application_state := SUCC (jmc$kol_application_unused) TO UPPERVALUE (application_state) DO
      kol_index := jmv$known_output_list.application_table [application_index].state_data [application_state].
            first_entry;
      WHILE kol_index <> jmc$kol_undefined_index DO
        IF jmv$kol_p^ [kol_index].system_file_name = system_file_name THEN
          EXIT /search_for_the_specified_file/;
        ELSE
          kol_index := jmv$kol_p^ [kol_index].application_forward_link;
        IFEND;
      WHILEND;
    FOREND /search_for_the_specified_file/;
  PROCEND find_output_file_by_application;
?? OLDTITLE ??
?? NEWTITLE := 'kol_search', EJECT ??

{ PURPOSE:
{   The purpose of this request is to search the Known Output List (KOL) for the specified system_file_name
{ and returns the file's kol_index.  A kol_index of jmc$kol_undefined_index is returned if the output file
{ is not found.
{
{ NOTES:
{   The KOL must be locked when this request is issued.

  PROCEDURE kol_search
    (    system_file_name: jmt$system_supplied_name;
         entry_kind_set: jmt$kol_entry_kind_set;
     VAR kol_index: jmt$kol_index);

    VAR
      kol_entry_kind: jmt$kol_entry_kind;

    kol_index := jmc$kol_undefined_index;

  /kol_search_each_entry_kind/
    FOR kol_entry_kind := SUCC (LOWERVALUE (kol_entry_kind)) TO UPPERVALUE (kol_entry_kind) DO
      IF kol_entry_kind IN entry_kind_set THEN
        kol_index := jmv$known_output_list.state_data [kol_entry_kind].first_entry;

        WHILE kol_index <> jmc$kol_undefined_index DO
          IF (jmv$kol_p^ [kol_index].system_file_name = system_file_name) THEN
            EXIT /kol_search_each_entry_kind/;
          ELSE
            kol_index := jmv$kol_p^ [kol_index].forward_link;
          IFEND;
        WHILEND;
      IFEND;
    FOREND /kol_search_each_entry_kind/;
  PROCEND kol_search;
?? OLDTITLE ??
?? NEWTITLE := 'notify_output_application', EJECT ??

{ PURPOSE:
{   The purpose of this request is to ready an output application's control task.
{
{ NOTES:
{   The Known Output List (KOL) should be locked when this request is issued in order to ensure that
{ the global_task_id in the KOL's application table is valid.  If it isn't, the results will be to
{ cause a task to become ready before its scheduled time.  This is not generally a problem.
{ With this in mind, it is okay to make this request without the KOL locked, but it is preferred to
{ have the structure locked.

  PROCEDURE notify_output_application
    (    application_index: jmt$output_application_index);

    VAR
      ignore_status: ost$status;

    IF application_index <> jmc$unassigned_output_index THEN
      pmp$ready_task (jmv$known_output_list.application_table [application_index].global_task_id,
            ignore_status);
    IFEND;
  PROCEND notify_output_application;
?? TITLE := 'relink_kol_application', EJECT ??

{ PURPOSE:
{   The purpose of this request is to relink a Known Output List (KOL) entry from one application state
{ thread to another.
{
{ DESIGN:
{   Upon entry to the procedure, the KOL entry contains the destination_usage and application_state that
{ defines the application thread that the entry belongs to.  The entry is removed from this thread and
{ added to the thread described by the destination_usage and destination_state supplied on the request.
{
{ NOTES:
{   The KOL must be locked when this request is issued.

  PROCEDURE relink_kol_application
    (    kol_index: jmt$kol_index;
         destination_application_index: jmt$output_application_index;
         destination_state: jmt$kol_application_state);

    VAR
      source_state: jmt$kol_application_state,
      source_application_index: jmt$output_application_index;

    find_destination_usage (jmv$kol_p^ [kol_index].destination_usage, source_application_index);
    source_state := jmv$kol_p^ [kol_index].application_state;

    CASE source_state OF
    = jmc$kol_application_unused =
      ;

    ELSE

{ Delete the entry from its application thread.

      IF jmv$kol_p^ [kol_index].application_reverse_link = jmc$kol_undefined_index THEN
        jmv$known_output_list.application_table [source_application_index].state_data [source_state].
              first_entry := jmv$kol_p^ [kol_index].application_forward_link;
      ELSE
        jmv$kol_p^ [jmv$kol_p^ [kol_index].application_reverse_link].
              application_forward_link := jmv$kol_p^ [kol_index].application_forward_link;
      IFEND;

      IF jmv$kol_p^ [kol_index].application_forward_link = jmc$kol_undefined_index THEN
        jmv$known_output_list.application_table [source_application_index].state_data [source_state].
              last_entry := jmv$kol_p^ [kol_index].application_reverse_link;
      ELSE
        jmv$kol_p^ [jmv$kol_p^ [kol_index].application_forward_link].
              application_reverse_link := jmv$kol_p^ [kol_index].application_reverse_link;
      IFEND;

{ Decrement the count for the application/state thread

      jmv$known_output_list.application_table [source_application_index].state_data [source_state].
            number_of_entries := jmv$known_output_list.application_table [source_application_index].
            state_data [source_state].number_of_entries - 1;
    CASEND;


    CASE destination_state OF

    = jmc$kol_application_unused =

{ Make the entry unused.

      jmv$kol_p^ [kol_index].application_reverse_link := jmc$kol_undefined_index;
      jmv$kol_p^ [kol_index].application_forward_link := jmc$kol_undefined_index;

    ELSE

{ Insert the entry at the end of the destination thread.

      IF jmv$known_output_list.application_table [destination_application_index].
            state_data [destination_state].last_entry = jmc$kol_undefined_index THEN
        jmv$kol_p^ [kol_index].application_reverse_link := jmc$kol_undefined_index;
        jmv$kol_p^ [kol_index].application_forward_link := jmc$kol_undefined_index;
        jmv$known_output_list.application_table [destination_application_index].
              state_data [destination_state].first_entry := kol_index;
        jmv$known_output_list.application_table [destination_application_index].
              state_data [destination_state].last_entry := kol_index;
      ELSE
        jmv$kol_p^ [kol_index].application_reverse_link := jmv$known_output_list.
              application_table [destination_application_index].state_data [destination_state].last_entry;
        jmv$kol_p^ [jmv$known_output_list.application_table [destination_application_index].
              state_data [destination_state].last_entry].application_forward_link := kol_index;
        jmv$kol_p^ [kol_index].application_forward_link := jmc$kol_undefined_index;
        jmv$known_output_list.application_table [destination_application_index].
              state_data [destination_state].last_entry := kol_index;
      IFEND;

{ Increment the count of the number of entries in the state

      jmv$known_output_list.application_table [destination_application_index].state_data [destination_state].
            number_of_entries := jmv$known_output_list.application_table [destination_application_index].
            state_data [destination_state].number_of_entries + 1;
    CASEND;

    jmv$kol_p^ [kol_index].application_state := destination_state;

  PROCEND relink_kol_application;
?? TITLE := 'relink_kol_entry', EJECT ??

{ PURPOSE:
{   The purpose of this request is to relink a Known Output List (KOL) entry from one entry state chain to
{ another.
{
{ DESIGN:
{   The entry state in the KOL entry is used to determine the state thread that the entry is currently in.
{ The entry state chain is maintained as a doubly linked list so it can be searched backwards.
{
{ NOTES:
{   The KOL must be locked when this request is issued.

  PROCEDURE relink_kol_entry
    (    kol_index: jmt$kol_index;
         destination_entry_kind: jmt$kol_entry_kind);

    VAR
      source_entry_kind: jmt$kol_entry_kind,
      insertion_index: jmt$kol_index;

    source_entry_kind := jmv$kol_p^ [kol_index].entry_kind;

{ Delete the entry from its thread

    IF jmv$kol_p^ [kol_index].reverse_link = jmc$kol_undefined_index THEN
      jmv$known_output_list.state_data [source_entry_kind].first_entry := jmv$kol_p^ [kol_index].forward_link;
    ELSE
      jmv$kol_p^ [jmv$kol_p^ [kol_index].reverse_link].forward_link := jmv$kol_p^ [kol_index].forward_link;
    IFEND;

    IF jmv$kol_p^ [kol_index].forward_link = jmc$kol_undefined_index THEN
      jmv$known_output_list.state_data [source_entry_kind].last_entry := jmv$kol_p^ [kol_index].reverse_link;
    ELSE
      jmv$kol_p^ [jmv$kol_p^ [kol_index].forward_link].reverse_link := jmv$kol_p^ [kol_index].reverse_link;
    IFEND;

{ Decrement the count of the number of entries in the state

    jmv$known_output_list.state_data [source_entry_kind].number_of_entries :=
          jmv$known_output_list.state_data [source_entry_kind].number_of_entries - 1;

{ Add the entry to the destination thread

    CASE destination_entry_kind OF

    = jmc$kol_unused_entry =

{ First, zero out the entry so "clag" doesn't show up

      pmp$zero_out_table (^jmv$kol_p^ [kol_index], #SIZE (jmv$kol_p^ [kol_index]));

{ Insert in the "unused" thread.  Trace backwards to find the next previous unused entry to insert after.

      insertion_index := kol_index - 1;
      WHILE (insertion_index <> jmc$kol_undefined_index) AND
            (jmv$kol_p^ [insertion_index].entry_kind <> jmc$kol_unused_entry) DO
        insertion_index := insertion_index - 1;
      WHILEND;
      IF insertion_index = jmc$kol_undefined_index THEN

{ Insert at the "head" of the unused thread

        jmv$kol_p^ [kol_index].reverse_link := jmc$kol_undefined_index;
        jmv$kol_p^ [kol_index].forward_link := jmv$known_output_list.state_data [jmc$kol_unused_entry].
              first_entry;
        jmv$known_output_list.state_data [jmc$kol_unused_entry].first_entry := kol_index;
        IF jmv$kol_p^ [kol_index].forward_link <> jmc$kol_undefined_index THEN
          jmv$kol_p^ [jmv$kol_p^ [kol_index].forward_link].reverse_link := kol_index;
        IFEND;
      ELSE

{ Insert in the unused thread.

        jmv$kol_p^ [kol_index].reverse_link := insertion_index;
        jmv$kol_p^ [kol_index].forward_link := jmv$kol_p^ [insertion_index].forward_link;
        jmv$kol_p^ [jmv$kol_p^ [kol_index].forward_link].reverse_link := kol_index;
        jmv$kol_p^ [insertion_index].forward_link := kol_index;
      IFEND;

    ELSE

{ Insert at the end of the destination thread.

      IF jmv$known_output_list.state_data [destination_entry_kind].last_entry = jmc$kol_undefined_index THEN
        jmv$kol_p^ [kol_index].reverse_link := jmc$kol_undefined_index;
        jmv$kol_p^ [kol_index].forward_link := jmc$kol_undefined_index;
        jmv$known_output_list.state_data [destination_entry_kind].first_entry := kol_index;
        jmv$known_output_list.state_data [destination_entry_kind].last_entry := kol_index;
      ELSE
        jmv$kol_p^ [kol_index].reverse_link := jmv$known_output_list.state_data [destination_entry_kind].
              last_entry;
        jmv$kol_p^ [jmv$known_output_list.state_data [destination_entry_kind].last_entry].forward_link :=
              kol_index;
        jmv$kol_p^ [kol_index].forward_link := jmc$kol_undefined_index;
        jmv$known_output_list.state_data [destination_entry_kind].last_entry := kol_index;
      IFEND;
    CASEND;

{ Increment the count for the destination thread.

    jmv$known_output_list.state_data [destination_entry_kind].number_of_entries :=
          jmv$known_output_list.state_data [destination_entry_kind].number_of_entries + 1;

    jmv$kol_p^ [kol_index].entry_kind := destination_entry_kind;
  PROCEND relink_kol_entry;
?? TITLE := 'validate_application_access', EJECT ??

{ PURPOSE:
{    This request will validate that the executing task is the legitimate user of the destination usage
{  specified.  The index into the application table for the specified destination_usage is returned.
{
{ NOTES:
{   The Known Output List (KOL) must be locked when this request is issued.

  PROCEDURE validate_application_access
    (    destination_usage: jmt$destination_usage;
     VAR application_index: jmt$output_application_index;
     VAR status: ost$status);

    VAR
      global_task_id: ost$global_task_id;

    status.normal := TRUE;
    find_destination_usage (destination_usage, application_index);
    IF application_index = jmc$unassigned_output_index THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$destination_usage_incorrect, destination_usage,
            status);
    ELSE
      pmp$get_executing_task_gtid (global_task_id);
      IF global_task_id <> jmv$known_output_list.application_table [application_index].global_task_id THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$application_not_permitted, destination_usage,
              status);
      IFEND;
    IFEND;
  PROCEND validate_application_access;
?? TITLE := '[XDCL, #GATE] qfp$acquire_modified_output', EJECT ??
*copy qfh$acquire_modified_output

  PROCEDURE [XDCL, #GATE] qfp$acquire_modified_output
    (    output_destination_usage: jmt$destination_usage;
     VAR output_descriptor: jmt$output_descriptor;
     VAR status: ost$status);

    VAR
      application_index: jmt$output_application_index,
      kol_index: jmt$kol_index;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kol_lock);

    validate_application_access (output_destination_usage, application_index, status);
    IF status.normal THEN
      kol_index := jmv$known_output_list.application_table [application_index].
            state_data [jmc$kol_application_modified].first_entry;
      IF kol_index <> jmc$kol_undefined_index THEN
        output_descriptor.system_file_name := jmv$kol_p^ [kol_index].system_file_name;
        output_descriptor.user_file_name := jmv$kol_p^ [kol_index].user_file_name;
        relink_kol_application (kol_index, application_index, jmc$kol_application_acquired);
      ELSE
        osp$set_status_abnormal (jmc$job_management_id, jme$output_queue_is_empty, '', status);
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$acquire_modified_output;
?? TITLE := '[XDCL, #GATE] qfp$acquire_new_output', EJECT ??
*copyc qfh$acquire_new_output

  PROCEDURE [XDCL, #GATE] qfp$acquire_new_output
    (    output_destination_usage: jmt$destination_usage;
     VAR output_descriptor: jmt$output_descriptor;
     VAR status: ost$status);

    VAR
      application_index: jmt$output_application_index,
      kol_index: jmt$kol_index;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kol_lock);

    validate_application_access (output_destination_usage, application_index, status);
    IF status.normal THEN
      kol_index := jmv$known_output_list.application_table [application_index].
            state_data [jmc$kol_application_new].first_entry;
      IF kol_index <> jmc$kol_undefined_index THEN
        output_descriptor.system_file_name := jmv$kol_p^ [kol_index].system_file_name;
        output_descriptor.user_file_name := jmv$kol_p^ [kol_index].user_file_name;
        relink_kol_application (kol_index, application_index, jmc$kol_application_acquired);
      ELSE
        osp$set_status_abnormal (jmc$job_management_id, jme$output_queue_is_empty, '', status);
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$acquire_new_output;
?? TITLE := '[XDCL, #GATE] qfp$change_output_attributes', EJECT ??
*copyc qfh$change_output_attributes

{ NOTES:
{   Only deferred or queued output files can have their attributes changed.

  PROCEDURE [XDCL, #GATE] qfp$change_output_attributes
    (    system_label: jmt$output_system_label;
         earliest_clock_time_to_print: jmt$clock_time;
         latest_clock_time_to_print: jmt$clock_time;
         purge_delay_clock_time: jmt$clock_time;
         current_clock_time: jmt$clock_time;
         reprint_disposition: jmt$reprint_disposition;
     VAR notify_application: boolean;
     VAR application_gtid: ost$global_task_id;
     VAR delete_output_file: boolean;
     VAR status: ost$status);

    VAR
      deferred_file: boolean,
      entry_kind: jmt$kol_entry_kind,
      kol_index: jmt$kol_index,
      output_application_index: jmt$output_application_index,
      time_deferred_file: boolean;

    status.normal := TRUE;
    delete_output_file := FALSE;
    notify_application := FALSE;
    osp$set_mainframe_sig_lock (qfv$kol_lock);

  /find_entry_in_kol/
    FOR entry_kind := LOWERVALUE (entry_kind) TO UPPERVALUE (entry_kind) DO
      IF entry_kind IN $jmt$kol_entry_kind_set [jmc$kol_deferred_entry, jmc$kol_queued_entry,
            jmc$kol_completed_entry] THEN
        kol_index := jmv$known_output_list.state_data [entry_kind].first_entry;
        WHILE (kol_index <> jmc$kol_undefined_index) DO
          IF (jmv$kol_p^ [kol_index].system_file_name = system_label.system_file_name) THEN
            EXIT /find_entry_in_kol/;
          ELSE
            kol_index := jmv$kol_p^ [kol_index].forward_link;
          IFEND;
        WHILEND;
      IFEND;
    FOREND /find_entry_in_kol/;

    IF kol_index <> jmc$kol_undefined_index THEN
      time_deferred_file := current_clock_time < earliest_clock_time_to_print;
      deferred_file := time_deferred_file OR system_label.output_deferred_by_operator OR
            system_label.output_deferred_by_user;
      jmv$kol_p^ [kol_index].output_controller := system_label.output_controller;
      jmv$kol_p^ [kol_index].next_destination_usage := system_label.output_destination_usage;
      jmv$kol_p^ [kol_index].earliest_clock_time_to_print := earliest_clock_time_to_print;
      jmv$kol_p^ [kol_index].latest_clock_time_to_print := latest_clock_time_to_print;
      jmv$kol_p^ [kol_index].purge_delay := purge_delay_clock_time;
      jmv$kol_p^ [kol_index].output_deferred_by_operator := system_label.output_deferred_by_operator;
      jmv$kol_p^ [kol_index].output_deferred_by_user := system_label.output_deferred_by_user;

{ If the application state is not NEW, then the file has been acquired by the application
{ In this case, if the file is deferred or the destination usage has changed, mark
{ the file as terminated for the application.  When the application releases the file
{ it will be placed in the proper state.

      IF (jmv$kol_p^ [kol_index].entry_kind = jmc$kol_completed_entry) AND
            (reprint_disposition = jmc$rd_no_change) THEN
        jmv$kol_p^ [kol_index].destination_usage := jmv$kol_p^ [kol_index].next_destination_usage;
        IF purge_delay_clock_time < jmv$time_to_purge_printed_file THEN
          jmv$time_to_purge_printed_file := purge_delay_clock_time;
        IFEND;
      ELSEIF (jmv$kol_p^ [kol_index].entry_kind = jmc$kol_completed_entry) AND
            (reprint_disposition = jmc$rd_discard_file) THEN
        find_destination_usage (jmv$kol_p^ [kol_index].destination_usage, output_application_index);
        relink_kol_application (kol_index, output_application_index, jmc$kol_application_unused);
        relink_kol_entry (kol_index, jmc$kol_unused_entry);
        delete_output_file := TRUE;
      ELSE

{ The file has not printed or it has printed and reprint was requested.

        IF deferred_file AND (jmv$kol_p^ [kol_index].application_state <= jmc$kol_application_new) THEN
          IF time_deferred_file AND (earliest_clock_time_to_print < jmv$time_to_ready_deferred_file) THEN
            jmv$time_to_ready_deferred_file := earliest_clock_time_to_print;
          IFEND;
          find_destination_usage (jmv$kol_p^ [kol_index].next_destination_usage, output_application_index);
          relink_kol_application (kol_index, output_application_index, jmc$kol_application_unused);
          jmv$kol_p^ [kol_index].destination_usage := jmv$kol_p^ [kol_index].next_destination_usage;
          relink_kol_entry (kol_index, jmc$kol_deferred_entry);
        ELSE
          IF jmv$kol_p^ [kol_index].application_state > jmc$kol_application_new THEN
            find_destination_usage (jmv$kol_p^ [kol_index].destination_usage, output_application_index);
            IF (NOT deferred_file) AND (jmv$kol_p^ [kol_index].destination_usage =
                  jmv$kol_p^ [kol_index].next_destination_usage) THEN
              relink_kol_application (kol_index, output_application_index, jmc$kol_application_modified);
            ELSE
              relink_kol_application (kol_index, output_application_index, jmc$kol_application_terminated);
            IFEND;
          ELSE
            find_destination_usage (jmv$kol_p^ [kol_index].next_destination_usage, output_application_index);
            relink_kol_application (kol_index, output_application_index, jmc$kol_application_new);
            jmv$kol_p^ [kol_index].destination_usage := jmv$kol_p^ [kol_index].next_destination_usage;
            relink_kol_entry (kol_index, jmc$kol_queued_entry);
          IFEND;

{ At this point, the queue file is still attached.  Wait until the file is returned
{ (by the caller of this procedure) to notify the application so that when the application
{ tries to acquire the file, it will not have to wait.  This is done because of a potential
{ timing problem that occurs when change_output_attributes and another output queue file
{ command (such as change_output_attributes, or terminate_output) are executed
{ in a short timeframe.

          IF output_application_index <> jmc$unassigned_output_index THEN
            notify_application := TRUE;
            application_gtid := jmv$known_output_list.application_table [output_application_index].
                  global_task_id;
          IFEND;
        IFEND;
        IF latest_clock_time_to_print < jmv$time_to_purge_expired_file THEN
          jmv$time_to_purge_expired_file := latest_clock_time_to_print;
        IFEND;
      IFEND;
    ELSE
      osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_label.system_file_name,
            status);
    IFEND;

    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$change_output_attributes;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$get_application_name', EJECT ??

  PROCEDURE [XDCL, #GATE] qfp$get_application_name
    (    output_destination_usage: jmt$destination_usage;
     VAR application_name: ost$name);

    VAR
      application_index: jmt$output_application_index;

    application_name := osc$null_name;
    osp$set_mainframe_sig_lock (qfv$kol_lock);
    find_destination_usage (output_destination_usage, application_index);
    IF application_index <> jmc$unassigned_output_index THEN
      application_name := jmv$known_output_list.application_table [application_index].application_name;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$get_application_name;
?? TITLE := '[XDCL, #GATE] qfp$get_output_attributes', EJECT ??
*copy qfh$get_output_attributes

  PROCEDURE [XDCL, #GATE] qfp$get_output_attributes
    (    user_identification: ost$user_identification;
         privileged_job: boolean;
         attribute_options_p: ^jmt$output_attribute_options;
         output_names_p: ^jmt$name_list;
     VAR number_of_outputs_found: jmt$output_status_count;
     VAR status: ost$status);

    VAR
      option_index: integer,
      name_index: integer,
      names_size: integer,
      output_state: jmt$output_state,
      output_state_set: jmt$output_state_set,
      kol_entry_kind: jmt$kol_entry_kind,
      kol_index: jmt$kol_index,
      qualified_entry_found: boolean;

    status.normal := TRUE;
    number_of_outputs_found := 0;
    IF output_names_p <> NIL THEN
      names_size := UPPERBOUND (output_names_p^);
    ELSE
      names_size := 0;
    IFEND;

    output_state_set := -$jmt$output_state_set [];

    osp$set_mainframe_sig_lock (qfv$kol_lock);

  /search_each_entry_kind/
    FOR output_state := LOWERVALUE (jmt$output_state) TO UPPERVALUE (jmt$output_state) DO
      IF output_state IN output_state_set THEN
        convert_state_to_entry_kind (output_state, kol_entry_kind, status);
        IF NOT status.normal THEN
          EXIT /search_each_entry_kind/;
        IFEND;

        kol_index := jmv$known_output_list.state_data [kol_entry_kind].first_entry;

      /search_each_entry/
        WHILE kol_index <> jmc$kol_undefined_index DO
          IF (jmv$kol_p^ [kol_index].login_user_identification = user_identification) OR
                (jmv$kol_p^ [kol_index].output_controller = user_identification) OR privileged_job THEN

            qualified_entry_found := TRUE;
            IF attribute_options_p <> NIL THEN

            /attribute_option_check/
              FOR option_index := 1 TO UPPERBOUND (attribute_options_p^) DO
                CASE attribute_options_p^ [option_index].key OF

                = jmc$control_family =
                  IF attribute_options_p^ [option_index].control_family <>
                        jmv$kol_p^ [kol_index].output_controller.family THEN
                    qualified_entry_found := FALSE;
                    EXIT /attribute_option_check/;
                  IFEND;

                = jmc$control_user =
                  IF attribute_options_p^ [option_index].control_user <>
                        jmv$kol_p^ [kol_index].output_controller.user THEN
                    qualified_entry_found := FALSE;
                    EXIT /attribute_option_check/;
                  IFEND;

                = jmc$login_family =
                  IF attribute_options_p^ [option_index].login_family <>
                        jmv$kol_p^ [kol_index].login_user_identification.family THEN
                    qualified_entry_found := FALSE;
                    EXIT /attribute_option_check/;
                  IFEND;

                = jmc$login_user =
                  IF attribute_options_p^ [option_index].login_user <>
                        jmv$kol_p^ [kol_index].login_user_identification.user THEN
                    qualified_entry_found := FALSE;
                    EXIT /attribute_option_check/;
                  IFEND;

                = jmc$name_list =
                  IF attribute_options_p^ [option_index].name_list <> NIL THEN
                    qualified_entry_found := FALSE;

                  /search_for_name/
                    FOR name_index := 1 TO UPPERBOUND (attribute_options_p^ [option_index].name_list^) DO
                      CASE attribute_options_p^ [option_index].name_list^ [name_index].kind OF
                      = jmc$system_supplied_name =
                        IF attribute_options_p^ [option_index].name_list^ [name_index].system_supplied_name =
                              jmv$kol_p^ [kol_index].system_file_name THEN
                          qualified_entry_found := TRUE;
                          EXIT /search_for_name/;
                        IFEND;

                      = jmc$user_supplied_name =
                        IF attribute_options_p^ [option_index].name_list^ [name_index].user_supplied_name =
                              jmv$kol_p^ [kol_index].user_file_name THEN
                          qualified_entry_found := TRUE;
                          EXIT /search_for_name/;
                        IFEND;
                      CASEND;
                    FOREND /search_for_name/;

                    IF NOT qualified_entry_found THEN
                      EXIT /attribute_option_check/;
                    IFEND;
                  IFEND;

                = jmc$null_attribute =
                  ;

                ELSE
                  ;
                CASEND;
              FOREND /attribute_option_check/;
            IFEND;

            IF qualified_entry_found THEN
              number_of_outputs_found := number_of_outputs_found + 1;
              IF names_size >= number_of_outputs_found THEN
                output_names_p^ [number_of_outputs_found].kind := jmc$system_supplied_name;
                output_names_p^ [number_of_outputs_found].system_supplied_name :=
                      jmv$kol_p^ [kol_index].system_file_name;
              IFEND;
            IFEND;
          IFEND;

          kol_index := jmv$kol_p^ [kol_index].forward_link;
        WHILEND /search_each_entry/;
      IFEND;
    FOREND /search_each_entry_kind/;

    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$get_output_attributes;
?? TITLE := '[XDCL, #GATE] qfp$get_output_counts', EJECT ??
*copyc qfh$get_output_counts

  PROCEDURE [XDCL, #GATE] qfp$get_output_counts
    (VAR output_counts: jmt$output_counts;
     VAR status: ost$status);

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (qfv$kol_lock);

    output_counts.state_data [jmc$deferred_output] := jmv$known_output_list.
          state_data [jmc$kol_deferred_entry].number_of_entries;
    output_counts.state_data [jmc$queued_output] := jmv$known_output_list.state_data [jmc$kol_queued_entry].
          number_of_entries;
    output_counts.state_data [jmc$initiated_output] := jmv$known_output_list.
          state_data [jmc$kol_initiated_entry].number_of_entries;
    output_counts.state_data [jmc$terminated_output] := jmv$known_output_list.
          state_data [jmc$kol_terminated_entry].number_of_entries;
    output_counts.state_data [jmc$completed_output] := jmv$known_output_list.
          state_data [jmc$kol_completed_entry].number_of_entries;

    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$get_output_counts;
?? TITLE := '[XDCL, #GATE] qfp$get_output_status', EJECT ??
*copy qfh$get_output_status

  PROCEDURE [XDCL, #GATE] qfp$get_output_status
    (    user_identification: ost$user_identification;
         privileged_job: boolean;
         status_options: ^jmt$output_status_options;
         status_results_keys_p: ^jmt$results_keys;
     VAR work_area_p: ^jmt$work_area;
     VAR number_of_outputs_found: jmt$output_status_count;
     VAR status: ost$status);

    VAR
      option_index: integer,
      name_index: integer,
      result_index: integer,
      output_state: jmt$output_state,
      output_state_set: jmt$output_state_set,
      kol_entry_kind: jmt$kol_entry_kind,
      kol_index: jmt$kol_index,
      qualified_entry_found: boolean,
      work_area_full: boolean;

?? NEWTITLE := 'add_file_to_work_area', EJECT ??

{ PURPOSE:
{   The purpose of this request is to add a file to the output status results
{   sequence supplied on the request.

    PROCEDURE add_file_to_work_area
      (    status_results_keys_p: ^jmt$results_keys;
       VAR work_area_p: ^jmt$work_area;
       VAR work_area_full: boolean);

      VAR
        boolean_p: ^boolean,
        ignore_status: ost$status,
        output_state_p: ^jmt$output_state,
        mainframe_id_p: ^pmt$mainframe_id,
        name_value_p: ^ost$name,
        system_supplied_name_p: ^jmt$system_supplied_name;

      IF status_results_keys_p <> NIL THEN

      /fill_in_each_status_result/
        FOR result_index := 1 TO UPPERBOUND (status_results_keys_p^) DO
          CASE status_results_keys_p^ [result_index] OF
          = jmc$client_mainframe_id =
            NEXT mainframe_id_p IN work_area_p;
            IF mainframe_id_p = NIL THEN
              work_area_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            pmp$get_mainframe_id (mainframe_id_p^, ignore_status);

          = jmc$control_family =
            NEXT name_value_p IN work_area_p;
            IF name_value_p = NIL THEN
              work_area_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            name_value_p^ := jmv$kol_p^ [kol_index].output_controller.family;

          = jmc$control_user =
            NEXT name_value_p IN work_area_p;
            IF name_value_p = NIL THEN
              work_area_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            name_value_p^ := jmv$kol_p^ [kol_index].output_controller.user;

          = jmc$login_family =
            NEXT name_value_p IN work_area_p;
            IF name_value_p = NIL THEN
              work_area_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            name_value_p^ := jmv$kol_p^ [kol_index].login_user_identification.family;

          = jmc$login_user =
            NEXT name_value_p IN work_area_p;
            IF name_value_p = NIL THEN
              work_area_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            name_value_p^ := jmv$kol_p^ [kol_index].login_user_identification.user;

          = jmc$null_attribute =
            ;

          = jmc$output_deferred_by_operator =
            NEXT boolean_p IN work_area_p;
            IF boolean_p = NIL THEN
              work_area_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            boolean_p^ := jmv$kol_p^ [kol_index].output_deferred_by_operator;

          = jmc$output_deferred_by_user =
            NEXT boolean_p IN work_area_p;
            IF boolean_p = NIL THEN
              work_area_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            boolean_p^ := jmv$kol_p^ [kol_index].output_deferred_by_user;

          = jmc$output_destination_usage =
            NEXT name_value_p IN work_area_p;
            IF name_value_p = NIL THEN
              work_area_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            name_value_p^ := jmv$kol_p^ [kol_index].destination_usage;

          = jmc$output_state =
            NEXT output_state_p IN work_area_p;
            IF output_state_p = NIL THEN
              work_area_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            output_state_p^ := output_state;

          = jmc$system_file_name =
            NEXT system_supplied_name_p IN work_area_p;
            IF system_supplied_name_p = NIL THEN
              work_area_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            system_supplied_name_p^ := jmv$kol_p^ [kol_index].system_file_name;

          = jmc$system_job_name =
            NEXT system_supplied_name_p IN work_area_p;
            IF system_supplied_name_p = NIL THEN
              work_area_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            system_supplied_name_p^ := jmv$kol_p^ [kol_index].system_job_name;

          = jmc$user_file_name =
            NEXT name_value_p IN work_area_p;
            IF name_value_p = NIL THEN
              work_area_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            name_value_p^ := jmv$kol_p^ [kol_index].user_file_name;

          = jmc$user_job_name =
            NEXT name_value_p IN work_area_p;
            IF name_value_p = NIL THEN
              work_area_full := TRUE;
              EXIT /fill_in_each_status_result/;
            IFEND;
            name_value_p^ := jmv$kol_p^ [kol_index].user_job_name;

          ELSE
          CASEND;
        FOREND /fill_in_each_status_result/;
      IFEND;
    PROCEND add_file_to_work_area;
?? OLDTITLE ??
?? NEWTITLE := 'handle_core_condition', EJECT ??

    PROCEDURE handle_core_condition
      (    monitor_fault: ost$monitor_fault;
           minimum_save_area_p: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      VAR
        lock_status: ost$signature_lock_status;

      osp$test_sig_lock (qfv$kol_lock, lock_status);
      IF lock_status = osc$sls_locked_by_current_task THEN
        osp$clear_mainframe_sig_lock (qfv$kol_lock);
      IFEND;
      syp$continue_to_cause (monitor_fault, minimum_save_area_p, syc$condition_processed, continue);
      osp$monitor_fault_to_status (monitor_fault, minimum_save_area_p, status);
      EXIT qfp$get_output_status;
    PROCEND handle_core_condition;
?? OLDTITLE ??
?? EJECT ??
    syp$establish_condition_handler (^handle_core_condition);
    status.normal := TRUE;
    number_of_outputs_found := 0;
    work_area_full := work_area_p = NIL;

    output_state_set := -$jmt$output_state_set [];
    IF status_options <> NIL THEN
      FOR option_index := 1 TO UPPERBOUND (status_options^) DO
        IF status_options^ [option_index].key = jmc$output_state_set THEN
          output_state_set := status_options^ [option_index].output_state_set;
        IFEND;
      FOREND;
    IFEND;

    osp$set_mainframe_sig_lock (qfv$kol_lock);

  /search_each_entry_kind/
    FOR output_state := LOWERVALUE (output_state) TO UPPERVALUE (output_state) DO
      IF output_state IN output_state_set THEN
        convert_state_to_entry_kind (output_state, kol_entry_kind, status);
        IF NOT status.normal THEN
          EXIT /search_each_entry_kind/;
        IFEND;

        kol_index := jmv$known_output_list.state_data [kol_entry_kind].first_entry;

      /search_each_entry/
        WHILE kol_index <> jmc$kol_undefined_index DO
          IF (jmv$kol_p^ [kol_index].login_user_identification = user_identification) OR
                (jmv$kol_p^ [kol_index].output_controller = user_identification) OR privileged_job THEN

            qualified_entry_found := TRUE;
            IF status_options <> NIL THEN

            /status_option_check/
              FOR option_index := 1 TO UPPERBOUND (status_options^) DO
                CASE status_options^ [option_index].key OF
                = jmc$control_family =
                  IF status_options^ [option_index].control_family <> jmv$kol_p^ [kol_index].
                        output_controller.family THEN
                    qualified_entry_found := FALSE;
                    EXIT /status_option_check/;
                  IFEND;

                = jmc$control_user =
                  IF status_options^ [option_index].control_user <>
                        jmv$kol_p^ [kol_index].output_controller.user THEN
                    qualified_entry_found := FALSE;
                    EXIT /status_option_check/;
                  IFEND;

                = jmc$login_family =
                  IF status_options^ [option_index].login_family <>
                        jmv$kol_p^ [kol_index].login_user_identification.family THEN
                    qualified_entry_found := FALSE;
                    EXIT /status_option_check/;
                  IFEND;

                = jmc$login_user =
                  IF status_options^ [option_index].login_user <>
                        jmv$kol_p^ [kol_index].login_user_identification.user THEN
                    qualified_entry_found := FALSE;
                    EXIT /status_option_check/;
                  IFEND;

                = jmc$name_list =
                  IF status_options^ [option_index].name_list <> NIL THEN
                    qualified_entry_found := FALSE;

                  /search_for_name/
                    FOR name_index := 1 TO UPPERBOUND (status_options^ [option_index].name_list^) DO
                      CASE status_options^ [option_index].name_list^ [name_index].kind OF
                      = jmc$system_supplied_name =
                        IF status_options^ [option_index].name_list^ [name_index].system_supplied_name =
                              jmv$kol_p^ [kol_index].system_file_name THEN
                          qualified_entry_found := TRUE;
                          EXIT /search_for_name/;
                        IFEND;

                      = jmc$user_supplied_name =
                        IF status_options^ [option_index].name_list^ [name_index].user_supplied_name =
                              jmv$kol_p^ [kol_index].user_file_name THEN
                          qualified_entry_found := TRUE;
                          EXIT /search_for_name/;
                        IFEND;
                      CASEND;
                    FOREND /search_for_name/;

                    IF NOT qualified_entry_found THEN
                      EXIT /status_option_check/;
                    IFEND;
                  IFEND;

                = jmc$null_attribute =
                  ;

                = jmc$output_deferred_by_operator =
                  IF status_options^ [option_index].output_deferred_by_operator <>
                        jmv$kol_p^ [kol_index].output_deferred_by_operator THEN
                    qualified_entry_found := FALSE;
                    EXIT /status_option_check/;
                  IFEND;

                = jmc$output_deferred_by_user =
                  IF status_options^ [option_index].output_deferred_by_user <>
                        jmv$kol_p^ [kol_index].output_deferred_by_user THEN
                    qualified_entry_found := FALSE;
                    EXIT /status_option_check/;
                  IFEND;

                = jmc$output_destination_usage =
                  IF status_options^ [option_index].output_destination_usage <>
                        jmv$kol_p^ [kol_index].destination_usage THEN
                    qualified_entry_found := FALSE;
                    EXIT /status_option_check/;
                  IFEND;

                = jmc$output_state_set =
                  ;

                = jmc$system_job_name =
                  IF status_options^ [option_index].system_job_name <> jmv$kol_p^ [kol_index].
                        system_job_name THEN
                    qualified_entry_found := FALSE;
                    EXIT /status_option_check/;
                  IFEND;

                = jmc$user_job_name =
                  IF status_options^ [option_index].user_job_name <> jmv$kol_p^ [kol_index].user_job_name THEN
                    qualified_entry_found := FALSE;
                    EXIT /status_option_check/;
                  IFEND;

                ELSE
                CASEND;
              FOREND /status_option_check/;
            IFEND;

            IF qualified_entry_found THEN
              IF (NOT work_area_full) THEN
                add_file_to_work_area (status_results_keys_p, work_area_p, work_area_full);
              IFEND;
              number_of_outputs_found := number_of_outputs_found + 1;
            IFEND;
          IFEND;

          kol_index := jmv$kol_p^ [kol_index].forward_link;
        WHILEND /search_each_entry/;
      IFEND;
    FOREND /search_each_entry_kind/;

    osp$clear_mainframe_sig_lock (qfv$kol_lock);
    syp$disestablish_cond_handler;
  PROCEND qfp$get_output_status;
?? TITLE := '[XDCL, #GATE] qfp$purge_expired_file', EJECT ??
*copy qfh$purge_expired_file

  PROCEDURE [XDCL, #GATE] qfp$purge_expired_file
    (VAR system_file_name_to_delete: jmt$system_supplied_name;
     VAR output_destination_usage: jmt$destination_usage);

    VAR
      current_clock_value: jmt$clock_time,
      entry_kind: jmt$kol_entry_kind,
      kol_index: jmt$kol_index,
      next_kol_index: jmt$kol_index,
      output_application_index: jmt$output_application_index;

    system_file_name_to_delete := '';
    current_clock_value := #FREE_RUNNING_CLOCK (0);
    osp$set_mainframe_sig_lock (qfv$kol_lock);

    jmv$time_to_purge_expired_file := jmc$latest_clock_time;

  /search_for_expired_files/
    FOR entry_kind := LOWERVALUE (entry_kind) TO UPPERVALUE (entry_kind) DO
      IF entry_kind IN $jmt$kol_entry_kind_set [jmc$kol_deferred_entry, jmc$kol_queued_entry,
            jmc$kol_initiated_entry] THEN
        kol_index := jmv$known_output_list.state_data [entry_kind].first_entry;
        WHILE kol_index <> jmc$kol_undefined_index DO
          next_kol_index := jmv$kol_p^ [kol_index].forward_link;
          IF jmv$kol_p^ [kol_index].latest_clock_time_to_print < current_clock_value THEN
            IF jmv$kol_p^ [kol_index].application_state > jmc$kol_application_new THEN
              IF entry_kind < jmc$kol_initiated_entry THEN
                find_destination_usage (jmv$kol_p^ [kol_index].destination_usage, output_application_index);
                relink_kol_application (kol_index, output_application_index, jmc$kol_application_terminated);
                notify_output_application (output_application_index);
              IFEND;
              relink_kol_entry (kol_index, jmc$kol_terminated_entry);
            ELSE
              IF system_file_name_to_delete = '' THEN
                system_file_name_to_delete := jmv$kol_p^ [kol_index].system_file_name;
                output_destination_usage := jmv$kol_p^ [kol_index].destination_usage;
                find_destination_usage (output_destination_usage, output_application_index);
                relink_kol_application (kol_index, output_application_index, jmc$kol_application_unused);
                relink_kol_entry (kol_index, jmc$kol_unused_entry);
              ELSE
                jmv$time_to_purge_expired_file := jmv$kol_p^ [kol_index].latest_clock_time_to_print;
                EXIT /search_for_expired_files/;
              IFEND;
            IFEND;
          ELSE
            IF jmv$kol_p^ [kol_index].latest_clock_time_to_print < jmv$time_to_purge_expired_file THEN
              jmv$time_to_purge_expired_file := jmv$kol_p^ [kol_index].latest_clock_time_to_print;
            IFEND;
          IFEND;
          kol_index := next_kol_index;
        WHILEND;
      IFEND;
    FOREND /search_for_expired_files/;
    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$purge_expired_file;
?? TITLE := '[XDCL, #GATE] qfp$purge_printed_file', EJECT ??
*copy qfh$purge_printed_file

  PROCEDURE [XDCL, #GATE] qfp$purge_printed_file
    (VAR system_file_name_to_delete: jmt$system_supplied_name;
     VAR output_destination_usage: jmt$destination_usage);

    VAR
      current_clock_value: jmt$clock_time,
      kol_index: jmt$kol_index,
      next_kol_index: jmt$kol_index,
      output_application_index: jmt$output_application_index;

    system_file_name_to_delete := '';
    current_clock_value := #FREE_RUNNING_CLOCK (0);
    osp$set_mainframe_sig_lock (qfv$kol_lock);

    jmv$time_to_purge_printed_file := jmc$latest_clock_time;

    kol_index := jmv$known_output_list.state_data [jmc$kol_completed_entry].first_entry;

  /search_for_printed_files/
    WHILE kol_index <> jmc$kol_undefined_index DO
      next_kol_index := jmv$kol_p^ [kol_index].forward_link;
      IF jmv$kol_p^ [kol_index].purge_delay < current_clock_value THEN
        IF system_file_name_to_delete = '' THEN
          system_file_name_to_delete := jmv$kol_p^ [kol_index].system_file_name;
          output_destination_usage := jmv$kol_p^ [kol_index].destination_usage;
          relink_kol_entry (kol_index, jmc$kol_unused_entry);
        ELSE
          jmv$time_to_purge_printed_file := jmv$kol_p^ [kol_index].purge_delay;
          EXIT /search_for_printed_files/;
        IFEND;
      ELSE
        IF jmv$kol_p^ [kol_index].purge_delay < jmv$time_to_purge_printed_file THEN
          jmv$time_to_purge_printed_file := jmv$kol_p^ [kol_index].purge_delay;
        IFEND;
      IFEND;
      kol_index := next_kol_index;
    WHILEND /search_for_printed_files/;
    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$purge_printed_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$print_file', EJECT ??
*copy qfh$print_file

  PROCEDURE [XDCL, #GATE] qfp$print_file
    (    system_label: jmt$output_system_label;
         earliest_clock_time_to_print: jmt$clock_time;
         latest_clock_time_to_print: jmt$clock_time;
         current_clock_time: jmt$clock_time;
     VAR status: ost$status);

    VAR
      application_index: jmt$output_application_index,
      ignore_status_p: ^ost$status,
      kol_index: jmt$kol_index,
      time_deferred_file: boolean;

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (qfv$kol_lock);

{ Make sure that the name is not already in the KOL.

    kol_search (system_label.system_file_name, -$jmt$kol_entry_kind_set [], kol_index);
    IF kol_index <> jmc$kol_undefined_index THEN
      osp$clear_mainframe_sig_lock (qfv$kol_lock);
      osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_name, system_label.system_file_name,
            status);
      RETURN;
    IFEND;

    IF jmv$known_output_list.state_data [jmc$kol_unused_entry].first_entry = jmc$kol_undefined_index THEN
      expand_kol;
    IFEND;

{ Check for room in the Known Output List (KOL).  The distribution of entries in
{ the KOL is defined as follows:
{
{    #available = MAXIMUM - qfv$current_kol_limit + #initialized_unused_entries
{    #used_entries = MAXIMUM - #available = qfv$current_kol_limit - #initialized_unused_entries
{
{ If the #used_entries >= jmv$maxiumum_known_outputs (logical bound) then the file cannot be
{ placed in the KOL.

    IF (qfv$current_kol_limit - jmv$known_output_list.state_data [jmc$kol_unused_entry].number_of_entries >=
          jmv$maximum_known_outputs) THEN
      osp$set_status_condition (jme$maximum_output, status);
      PUSH ignore_status_p;
      dpp$put_critical_message (jmc$output_queue_full_message, ignore_status_p^);
    ELSE
      kol_index := jmv$known_output_list.state_data [jmc$kol_unused_entry].first_entry;

      jmv$kol_p^ [kol_index].system_file_name := system_label.system_file_name;
      jmv$kol_p^ [kol_index].user_file_name := system_label.user_file_name;
      jmv$kol_p^ [kol_index].login_user_identification := system_label.login_user_identification;
      jmv$kol_p^ [kol_index].output_controller := system_label.output_controller;
      jmv$kol_p^ [kol_index].output_submission_clock_time := #FREE_RUNNING_CLOCK (0);
      jmv$kol_p^ [kol_index].earliest_clock_time_to_print := earliest_clock_time_to_print;
      jmv$kol_p^ [kol_index].latest_clock_time_to_print := latest_clock_time_to_print;
      jmv$kol_p^ [kol_index].purge_delay := jmc$earliest_clock_time;
      jmv$kol_p^ [kol_index].destination_usage := system_label.output_destination_usage;
      jmv$kol_p^ [kol_index].next_destination_usage := system_label.output_destination_usage;
      jmv$kol_p^ [kol_index].output_deferred_by_operator := system_label.output_deferred_by_operator;
      jmv$kol_p^ [kol_index].output_deferred_by_user := system_label.output_deferred_by_user;
      jmv$kol_p^ [kol_index].system_job_name := system_label.system_job_name;
      jmv$kol_p^ [kol_index].user_job_name := system_label.user_job_name;
      jmv$kol_p^ [kol_index].application_state := jmc$kol_application_unused;

      time_deferred_file := earliest_clock_time_to_print > current_clock_time;
      IF time_deferred_file OR jmv$kol_p^ [kol_index].output_deferred_by_operator OR
            jmv$kol_p^ [kol_index].output_deferred_by_user THEN
        IF time_deferred_file AND (earliest_clock_time_to_print < jmv$time_to_ready_deferred_file) THEN
          jmv$time_to_ready_deferred_file := earliest_clock_time_to_print;
        IFEND;
        relink_kol_entry (kol_index, jmc$kol_deferred_entry);
      ELSE
        find_destination_usage (jmv$kol_p^ [kol_index].destination_usage, application_index);
        relink_kol_entry (kol_index, jmc$kol_queued_entry);
        relink_kol_application (kol_index, application_index, jmc$kol_application_new);
        notify_output_application (application_index);
      IFEND;
      IF latest_clock_time_to_print < jmv$time_to_purge_expired_file THEN
        jmv$time_to_purge_expired_file := latest_clock_time_to_print;
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$print_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$ready_deferred_file', EJECT ??
*copy qfh$ready_deferred_file

  PROCEDURE [XDCL, #GATE] qfp$ready_deferred_file;

    VAR
      current_clock_time: jmt$clock_time,
      kol_index: jmt$kol_index,
      next_kol_index: jmt$kol_index,
      output_application_index: jmt$output_application_index;

    current_clock_time := #FREE_RUNNING_CLOCK (0);
    osp$set_mainframe_sig_lock (qfv$kol_lock);

    jmv$time_to_ready_deferred_file := jmc$latest_clock_time;
    kol_index := jmv$known_output_list.state_data [jmc$kol_deferred_entry].first_entry;
    WHILE kol_index <> jmc$kol_undefined_index DO
      next_kol_index := jmv$kol_p^ [kol_index].forward_link;
      IF NOT (jmv$kol_p^ [kol_index].output_deferred_by_operator OR
            jmv$kol_p^ [kol_index].output_deferred_by_user) THEN
        IF (jmv$kol_p^ [kol_index].earliest_clock_time_to_print <= current_clock_time) THEN
          relink_kol_entry (kol_index, jmc$kol_queued_entry);
          find_destination_usage (jmv$kol_p^ [kol_index].destination_usage, output_application_index);
          relink_kol_application (kol_index, output_application_index, jmc$kol_application_new);
          notify_output_application (output_application_index);
        ELSE
          IF jmv$kol_p^ [kol_index].earliest_clock_time_to_print < jmv$time_to_ready_deferred_file THEN
            jmv$time_to_ready_deferred_file := jmv$kol_p^ [kol_index].earliest_clock_time_to_print;
          IFEND;
        IFEND;
      IFEND;
      kol_index := next_kol_index;
    WHILEND;
    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$ready_deferred_file;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] qfp$rebuild_output_queue', EJECT ??
*copy qfh$rebuild_output_queue

{ NOTES:
{   This is only used during deadstart.  The queue recovery process knows how many files that are
{ queued on a NOS/VE system and it will always make the Known Output List (KOL) large enough to
{ contain all of the files regardless of what the site requests.

  PROCEDURE [XDCL, #GATE] qfp$rebuild_output_queue
    (    system_label: jmt$output_system_label;
         earliest_clock_time_to_print: jmt$clock_time;
         latest_clock_time_to_print: jmt$clock_time;
         purge_delay_clock_time: jmt$clock_time;
         current_clock_time: jmt$clock_time;
     VAR status: ost$status);

    VAR
      application_index: jmt$output_application_index,
      kol_index: jmt$kol_index,
      time_deferred_file: boolean;

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (qfv$kol_lock);

{ Make sure that the name is not already in the KOL.

    kol_search (system_label.system_file_name, -$jmt$kol_entry_kind_set [], kol_index);
    IF kol_index <> jmc$kol_undefined_index THEN
      osp$clear_mainframe_sig_lock (qfv$kol_lock);
      osp$set_status_abnormal (jmc$job_management_id, jme$duplicate_name, system_label.system_file_name,
            status);
      RETURN;
    IFEND;

{ Make sure that there is room in the KOL.

    IF jmv$known_output_list.state_data [jmc$kol_unused_entry].first_entry = jmc$kol_undefined_index THEN
      expand_kol;
    IFEND;

    IF jmv$known_output_list.state_data [jmc$kol_unused_entry].first_entry = jmc$kol_undefined_index THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$maximum_output, '', status);
    ELSE
      kol_index := jmv$known_output_list.state_data [jmc$kol_unused_entry].first_entry;

      jmv$kol_p^ [kol_index].system_file_name := system_label.system_file_name;
      jmv$kol_p^ [kol_index].user_file_name := system_label.user_file_name;
      jmv$kol_p^ [kol_index].login_user_identification := system_label.login_user_identification;
      jmv$kol_p^ [kol_index].output_controller := system_label.output_controller;
      jmv$kol_p^ [kol_index].output_submission_clock_time := #FREE_RUNNING_CLOCK (0);
      jmv$kol_p^ [kol_index].earliest_clock_time_to_print := earliest_clock_time_to_print;
      jmv$kol_p^ [kol_index].latest_clock_time_to_print := latest_clock_time_to_print;
      jmv$kol_p^ [kol_index].purge_delay := purge_delay_clock_time;
      jmv$kol_p^ [kol_index].destination_usage := system_label.output_destination_usage;
      jmv$kol_p^ [kol_index].next_destination_usage := system_label.output_destination_usage;
      jmv$kol_p^ [kol_index].output_deferred_by_operator := system_label.output_deferred_by_operator;
      jmv$kol_p^ [kol_index].output_deferred_by_user := system_label.output_deferred_by_user;
      jmv$kol_p^ [kol_index].system_job_name := system_label.system_job_name;
      jmv$kol_p^ [kol_index].user_job_name := system_label.user_job_name;
      jmv$kol_p^ [kol_index].application_state := jmc$kol_application_unused;

{ Has the file been printed??

      IF system_label.output_disposition_time.specified THEN
        IF jmv$kol_p^ [kol_index].purge_delay < jmv$time_to_purge_printed_file THEN
          jmv$time_to_purge_printed_file := jmv$kol_p^ [kol_index].purge_delay;
        IFEND;
        relink_kol_entry (kol_index, jmc$kol_completed_entry);
      ELSE
        time_deferred_file := jmv$kol_p^ [kol_index].earliest_clock_time_to_print > current_clock_time;
        IF time_deferred_file OR jmv$kol_p^ [kol_index].output_deferred_by_operator OR
              jmv$kol_p^ [kol_index].output_deferred_by_user THEN
          IF time_deferred_file AND (jmv$kol_p^ [kol_index].earliest_clock_time_to_print <
                jmv$time_to_ready_deferred_file) THEN
            jmv$time_to_ready_deferred_file := jmv$kol_p^ [kol_index].earliest_clock_time_to_print;
          IFEND;
          relink_kol_entry (kol_index, jmc$kol_deferred_entry);
        ELSE
          find_destination_usage (jmv$kol_p^ [kol_index].destination_usage, application_index);

          relink_kol_entry (kol_index, jmc$kol_queued_entry);
          relink_kol_application (kol_index, application_index, jmc$kol_application_new);
        IFEND;
        IF jmv$kol_p^ [kol_index].latest_clock_time_to_print < jmv$time_to_purge_expired_file THEN
          jmv$time_to_purge_expired_file := jmv$kol_p^ [kol_index].latest_clock_time_to_print;
        IFEND;
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$rebuild_output_queue;
?? TITLE := '[XDCL, #GATE] qfp$release_output_files', EJECT ??
*copy qfh$release_output_files

{ NOTES:
{   Even if the release_file_list is NIL this procedure must still return all files to
{ NOS/VE queue file management.

  PROCEDURE [XDCL, #GATE] qfp$release_output_files
    (    release_file_list: ^jmt$release_output_file_list;
     VAR release_file_count: jmt$output_count_range);

    VAR
      application_index: jmt$output_application_index,
      application_state: jmt$kol_application_state,
      current_clock_time: jmt$clock_time,
      global_task_id: ost$global_task_id,
      kol_index: jmt$kol_index,
      next_kol_index: jmt$kol_index,
      previously_terminated: boolean,
      relink_application_index: jmt$output_application_index,
      release_list_limit: jmt$output_count_range,
      time_deferred_file: boolean;

    pmp$get_executing_task_gtid (global_task_id);

    release_file_count := 0;
    IF release_file_list = NIL THEN
      release_list_limit := 0;
    ELSE
      release_list_limit := UPPERBOUND (release_file_list^);
    IFEND;

    osp$set_mainframe_sig_lock (qfv$kol_lock);

{ Check to see if this task has output files registered.

  /search_all_applications/
    FOR application_index := 1 TO UPPERBOUND (jmv$known_output_list.application_table) DO
      IF jmv$known_output_list.application_table [application_index].global_task_id = global_task_id THEN

      /search_all_application_states/
        FOR application_state := SUCC (jmc$kol_application_unused) TO UPPERVALUE (application_state) DO
          kol_index := jmv$known_output_list.application_table [application_index].
                state_data [application_state].first_entry;

        /release_entries_in_state/
          WHILE kol_index <> jmc$kol_undefined_index DO

{ Save the index of the next KOL entry.  When the entry is relinked, the links on the current entry
{ will no longer link to the next entry that needs to be managed.

            next_kol_index := jmv$kol_p^ [kol_index].application_forward_link;
            previously_terminated := jmv$kol_p^ [kol_index].entry_kind = jmc$kol_terminated_entry;

{ If the file was terminated, add it to the release list so the caller knows to delete the file
{ and remove the file from the KOL.

            IF previously_terminated THEN
              release_file_count := release_file_count + 1;
              IF release_file_count <= release_list_limit THEN
                release_file_list^ [release_file_count].system_file_name :=
                      jmv$kol_p^ [kol_index].system_file_name;
                release_file_list^ [release_file_count].output_destination_usage :=
                      jmv$kol_p^ [kol_index].destination_usage;
              IFEND;
              relink_kol_application (kol_index, application_index, jmc$kol_application_unused);
              relink_kol_entry (kol_index, jmc$kol_unused_entry);
            ELSE

              time_deferred_file := jmv$kol_p^ [kol_index].earliest_clock_time_to_print > current_clock_time;
              IF time_deferred_file OR jmv$kol_p^ [kol_index].output_deferred_by_operator OR
                    jmv$kol_p^ [kol_index].output_deferred_by_user THEN
                IF time_deferred_file AND (jmv$kol_p^ [kol_index].earliest_clock_time_to_print <
                      jmv$time_to_ready_deferred_file) THEN
                  jmv$time_to_ready_deferred_file := jmv$kol_p^ [kol_index].earliest_clock_time_to_print;
                IFEND;
                find_destination_usage (jmv$kol_p^ [kol_index].next_destination_usage,
                      relink_application_index);
                relink_kol_application (kol_index, relink_application_index, jmc$kol_application_unused);
                jmv$kol_p^ [kol_index].destination_usage := jmv$kol_p^ [kol_index].next_destination_usage;
                relink_kol_entry (kol_index, jmc$kol_deferred_entry);
              ELSE

{ If the file's destination usage hasn't changed - relink it into the unassigned chain
{ If the destination_usage did change, then make it available to that application

                IF jmv$kol_p^ [kol_index].destination_usage = jmv$kol_p^ [kol_index].
                      next_destination_usage THEN
                  relink_application_index := jmc$unassigned_output_index;
                ELSE
                  find_destination_usage (jmv$kol_p^ [kol_index].next_destination_usage,
                        relink_application_index);
                IFEND;
                relink_kol_entry (kol_index, jmc$kol_queued_entry);
                relink_kol_application (kol_index, relink_application_index, jmc$kol_application_new);
                jmv$kol_p^ [kol_index].destination_usage := jmv$kol_p^ [kol_index].next_destination_usage;
                notify_output_application (relink_application_index);
              IFEND;
            IFEND;

            kol_index := next_kol_index;
          WHILEND /release_entries_in_state/;
        FOREND /search_all_application_states/;

{ Zero out the entry in the application table.  The state_data has be zeroed by the relink procedures.

        jmv$known_output_list.application_table [application_index].application_name := osc$null_name;
        jmv$known_output_list.application_table [application_index].destination_usage := osc$null_name;
        jmv$known_output_list.application_table [application_index].global_task_id.index := 0;
        jmv$known_output_list.application_table [application_index].global_task_id.seqno := 0;
        jmv$known_output_list.application_table [application_index].queue_file_password := osc$null_name;

      IFEND;
    FOREND /search_all_applications/;

    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$release_output_files;
?? TITLE := '[XDCL, #GATE] qfp$register_output_application', EJECT ??
*copy qfh$register_output_application

  PROCEDURE [XDCL, #GATE] qfp$register_output_application
    (    application_name: ost$name;
         destination_usage: jmt$destination_usage;
         password: ost$name;
     VAR status: ost$status);

    VAR
      application_index: jmt$output_application_index,
      first_available_index: jmt$output_application_index,
      kol_index: jmt$kol_index,
      next_forward_link: jmt$kol_index;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kol_lock);

    first_available_index := jmc$unassigned_output_index;

  /search_for_the_application/
    FOR application_index := 1 TO UPPERBOUND (jmv$known_output_list.application_table) DO
      IF jmv$known_output_list.application_table [application_index].application_name = osc$null_name THEN
        IF first_available_index = jmc$unassigned_output_index THEN
          first_available_index := application_index;
        IFEND;

      ELSE { does the destination_usage match ??
        IF jmv$known_output_list.application_table [application_index].destination_usage =
              destination_usage THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$destination_usage_in_use, destination_usage,
                status);
          EXIT /search_for_the_application/;
        IFEND;
      IFEND;
    FOREND /search_for_the_application/;

    IF status.normal THEN

{ The destination_usage is not already in the table.  Is there room in the table??

      IF first_available_index = jmc$unassigned_output_index THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$application_table_is_full, '', status);
      ELSE

{ Move all output files with this destination_usage from the unassigned thread to this application thread.

        kol_index := jmv$known_output_list.application_table [jmc$unassigned_output_index].
              state_data [jmc$kol_application_new].first_entry;
        WHILE kol_index <> jmc$kol_undefined_index DO
          next_forward_link := jmv$kol_p^ [kol_index].application_forward_link;
          IF jmv$kol_p^ [kol_index].destination_usage = destination_usage THEN
            relink_kol_application (kol_index, first_available_index, jmc$kol_application_new);
          IFEND;
          kol_index := next_forward_link;
        WHILEND;

{ Initialize the entry in the table.  All files must be relinked before the table is initialized otherwise
{ the relink procedure will get confused with the destination usages.

        jmv$known_output_list.application_table [first_available_index].application_name := application_name;
        jmv$known_output_list.application_table [first_available_index].destination_usage :=
              destination_usage;
        jmv$known_output_list.application_table [first_available_index].queue_file_password := password;
        pmp$get_executing_task_gtid (jmv$known_output_list.application_table [first_available_index].
              global_task_id);
      IFEND;
    IFEND; { status.normal
    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$register_output_application;
?? TITLE := '[XDCL, #GATE] qfp$set_output_completed', EJECT ??
*copy qfh$set_output_completed

  PROCEDURE [XDCL, #GATE] qfp$set_output_completed
    (    output_destination_usage: jmt$destination_usage;
         system_file_name: jmt$system_supplied_name;
         completed_successfully: boolean;
         purge_delay_clock_time: jmt$clock_time;
         current_clock_time: jmt$clock_time;
     VAR delete_output_file: boolean;
     VAR system_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      application_index: jmt$output_application_index,
      kol_index: jmt$kol_index,
      previously_terminated: boolean,
      time_deferred_file: boolean;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kol_lock);

    delete_output_file := FALSE;
    validate_application_access (output_destination_usage, application_index, status);
    IF status.normal THEN
      find_output_file_by_application (system_file_name, application_index, kol_index);

      IF kol_index <> jmc$kol_undefined_index THEN
        system_job_name := jmv$kol_p^ [kol_index].system_job_name;
        previously_terminated := jmv$kol_p^ [kol_index].entry_kind = jmc$kol_terminated_entry;
        IF completed_successfully OR previously_terminated THEN
          IF previously_terminated OR (purge_delay_clock_time < current_clock_time) THEN
            delete_output_file := TRUE;
            relink_kol_application (kol_index, application_index, jmc$kol_application_unused);
            relink_kol_entry (kol_index, jmc$kol_unused_entry);
          ELSE
            IF purge_delay_clock_time < jmv$time_to_purge_printed_file THEN
              jmv$time_to_purge_printed_file := purge_delay_clock_time;
            IFEND;
            jmv$kol_p^ [kol_index].purge_delay := purge_delay_clock_time;
            find_destination_usage (jmv$kol_p^ [kol_index].next_destination_usage, application_index);
            relink_kol_application (kol_index, application_index, jmc$kol_application_unused);
            jmv$kol_p^ [kol_index].destination_usage := jmv$kol_p^ [kol_index].next_destination_usage;
            relink_kol_entry (kol_index, jmc$kol_completed_entry);
          IFEND;
        ELSE
          find_destination_usage (jmv$kol_p^ [kol_index].next_destination_usage, application_index);
          time_deferred_file := jmv$kol_p^ [kol_index].earliest_clock_time_to_print > current_clock_time;
          IF time_deferred_file OR jmv$kol_p^ [kol_index].output_deferred_by_operator OR
                jmv$kol_p^ [kol_index].output_deferred_by_user THEN
            IF time_deferred_file AND (jmv$kol_p^ [kol_index].earliest_clock_time_to_print <
                  jmv$time_to_ready_deferred_file) THEN
              jmv$time_to_ready_deferred_file := jmv$kol_p^ [kol_index].earliest_clock_time_to_print;
            IFEND;
            relink_kol_application (kol_index, application_index, jmc$kol_application_unused);
            jmv$kol_p^ [kol_index].destination_usage := jmv$kol_p^ [kol_index].next_destination_usage;
            relink_kol_entry (kol_index, jmc$kol_deferred_entry);
          ELSE
            relink_kol_entry (kol_index, jmc$kol_queued_entry);
            relink_kol_application (kol_index, application_index, jmc$kol_application_new);
            jmv$kol_p^ [kol_index].destination_usage := jmv$kol_p^ [kol_index].next_destination_usage;
            notify_output_application (application_index);
          IFEND;
        IFEND;
      ELSE
        osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_file_name, status);
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$set_output_completed;
?? TITLE := '[XDCL, #GATE] qfp$set_output_initiated', EJECT ??
*copy qfh$set_output_initiated

  PROCEDURE [XDCL, #GATE] qfp$set_output_initiated
    (    output_destination_usage: jmt$destination_usage;
         system_file_name: jmt$system_supplied_name;
     VAR system_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

    VAR
      application_index: jmt$output_application_index,
      kol_index: jmt$kol_index;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kol_lock);

    validate_application_access (output_destination_usage, application_index, status);
    IF status.normal THEN

      find_output_file_by_application (system_file_name, application_index, kol_index);
      IF kol_index <> jmc$kol_undefined_index THEN
        system_job_name := jmv$kol_p^ [kol_index].system_job_name;

        IF (jmv$kol_p^ [kol_index].application_state = jmc$kol_application_modified) OR
              (jmv$kol_p^ [kol_index].application_state = jmc$kol_application_terminated) OR
              (jmv$kol_p^ [kol_index].entry_kind = jmc$kol_terminated_entry) THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$output_cannot_initiate, '', status);
        ELSE

          relink_kol_application (kol_index, application_index, jmc$kol_application_printing);
          relink_kol_entry (kol_index, jmc$kol_initiated_entry);
        IFEND;
      ELSE
        osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_file_name, status);
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$set_output_initiated;
?? TITLE := '    QFP$TERMINATE_ACQUIRED_OUTPUT', EJECT ??
*copy qfh$terminate_acquired_output

  PROCEDURE [XDCL, #GATE] qfp$terminate_acquired_output
    (    output_destination_usage: jmt$destination_usage;
     VAR system_file_name: jmt$system_supplied_name;
     VAR system_job_name: jmt$system_supplied_name;
     VAR delete_output_file: boolean;
     VAR status: ost$status);

    VAR
      application_index: jmt$output_application_index,
      current_clock_time: jmt$clock_time,
      kol_index: jmt$kol_index,
      time_deferred_file: boolean;

    status.normal := TRUE;
    osp$set_mainframe_sig_lock (qfv$kol_lock);

    validate_application_access (output_destination_usage, application_index, status);
    IF status.normal THEN

      kol_index := jmv$known_output_list.application_table [application_index].
            state_data [jmc$kol_application_terminated].first_entry;
      IF kol_index <> jmc$kol_undefined_index THEN
        system_file_name := jmv$kol_p^ [kol_index].system_file_name;
        system_job_name := jmv$kol_p^ [kol_index].system_job_name;
        IF jmv$kol_p^ [kol_index].entry_kind = jmc$kol_terminated_entry THEN
          delete_output_file := TRUE;
          relink_kol_application (kol_index, application_index, jmc$kol_application_unused);
          relink_kol_entry (kol_index, jmc$kol_unused_entry);
        ELSE
          delete_output_file := FALSE;
          find_destination_usage (jmv$kol_p^ [kol_index].next_destination_usage, application_index);
          current_clock_time := #FREE_RUNNING_CLOCK (0);
          time_deferred_file := jmv$kol_p^ [kol_index].earliest_clock_time_to_print > current_clock_time;
          IF time_deferred_file OR jmv$kol_p^ [kol_index].output_deferred_by_operator OR
                jmv$kol_p^ [kol_index].output_deferred_by_user THEN
            IF time_deferred_file AND (jmv$kol_p^ [kol_index].earliest_clock_time_to_print <
                  jmv$time_to_ready_deferred_file) THEN
              jmv$time_to_ready_deferred_file := jmv$kol_p^ [kol_index].earliest_clock_time_to_print;
            IFEND;
            relink_kol_application (kol_index, application_index, jmc$kol_application_unused);
            jmv$kol_p^ [kol_index].destination_usage := jmv$kol_p^ [kol_index].next_destination_usage;
            relink_kol_entry (kol_index, jmc$kol_deferred_entry);
          ELSE
            relink_kol_application (kol_index, application_index, jmc$kol_application_new);
            jmv$kol_p^ [kol_index].destination_usage := jmv$kol_p^ [kol_index].next_destination_usage;
            notify_output_application (application_index);
          IFEND;
        IFEND;

      ELSE
        osp$set_status_abnormal (jmc$job_management_id, jme$output_queue_is_empty, '', status);
      IFEND;

    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$terminate_acquired_output;
?? TITLE := '[XDCL, #GATE] qfp$terminate_output', EJECT ??
*copy qfh$terminate_output

  PROCEDURE [XDCL, #GATE] qfp$terminate_output
    (    system_file_name: jmt$system_supplied_name;
         output_state_set: jmt$output_state_set;
     VAR system_job_name: jmt$system_supplied_name;
     VAR output_destination_usage: jmt$destination_usage;
     VAR delete_output_file: boolean;
     VAR status: ost$status);

    VAR
      application_index: jmt$output_application_index,
      kol_index: jmt$kol_index,
      kol_entry_kind_set: jmt$kol_entry_kind_set,
      kol_entry_kind: jmt$kol_entry_kind,
      output_state: jmt$output_state;

    status.normal := TRUE;
    delete_output_file := FALSE;

    kol_entry_kind_set := $jmt$kol_entry_kind_set [];
    FOR output_state := LOWERVALUE (output_state) TO UPPERVALUE (output_state) DO
      IF output_state IN output_state_set THEN
        convert_state_to_entry_kind (output_state, kol_entry_kind, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        kol_entry_kind_set := kol_entry_kind_set + $jmt$kol_entry_kind_set [kol_entry_kind];
      IFEND;
    FOREND;

    osp$set_mainframe_sig_lock (qfv$kol_lock);

    kol_search (system_file_name, kol_entry_kind_set, kol_index);
    IF kol_index = jmc$kol_undefined_index THEN
      osp$clear_mainframe_sig_lock (qfv$kol_lock);
      osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_file_name, status);
      RETURN;
    IFEND;

    IF jmv$kol_p^ [kol_index].entry_kind = jmc$kol_terminated_entry THEN
      osp$clear_mainframe_sig_lock (qfv$kol_lock);
      osp$set_status_abnormal (jmc$job_management_id, jme$output_already_terminated, system_file_name,
            status);
      RETURN;
    IFEND;

    system_job_name := jmv$kol_p^ [kol_index].system_job_name;
    output_destination_usage := jmv$kol_p^ [kol_index].destination_usage;
    relink_kol_entry (kol_index, jmc$kol_terminated_entry);
    find_destination_usage (jmv$kol_p^ [kol_index].destination_usage, application_index);
    IF jmv$kol_p^ [kol_index].application_state > jmc$kol_application_new THEN
      IF jmv$kol_p^ [kol_index].entry_kind <> jmc$kol_initiated_entry THEN
        relink_kol_application (kol_index, application_index, jmc$kol_application_terminated);
        notify_output_application (application_index);
      IFEND;
    ELSE
      delete_output_file := TRUE;
      relink_kol_application (kol_index, application_index, jmc$kol_application_unused);
      relink_kol_entry (kol_index, jmc$kol_unused_entry);
    IFEND;

    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$terminate_output;
?? TITLE := '[XDCL, #GATE] qfp$validate_output_file_access', EJECT ??
*copy qfh$validate_output_file_access

  PROCEDURE [XDCL, #GATE] qfp$validate_output_file_access
    (    system_file_name: jmt$system_supplied_name;
         output_destination_usage: jmt$destination_usage;
         queue_file_password: jmt$queue_file_password;
     VAR status: ost$status);

    VAR
      application_index: jmt$output_application_index,
      kol_index: jmt$kol_index;

    status.normal := TRUE;

    osp$set_mainframe_sig_lock (qfv$kol_lock);
    find_destination_usage (output_destination_usage, application_index);
    IF application_index = jmc$unassigned_output_index THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$destination_usage_incorrect,
            output_destination_usage, status);
    ELSE

{ Do the passwords match??

      IF queue_file_password <> jmv$known_output_list.application_table [application_index].
            queue_file_password THEN
        osp$set_status_abnormal (jmc$job_management_id, jme$application_not_permitted,
              output_destination_usage, status);
      ELSE

{ Search for the file in the applications initiated thread - If it isn't there, don't permit access
{ to the file.

        kol_index := jmv$known_output_list.application_table [application_index].
              state_data [jmc$kol_application_printing].first_entry;
        WHILE (kol_index <> jmc$kol_undefined_index) AND (jmv$kol_p^ [kol_index].system_file_name <>
              system_file_name) DO
          kol_index := jmv$kol_p^ [kol_index].application_forward_link;
        WHILEND;
        IF (kol_index = jmc$kol_undefined_index) THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$name_not_found, system_file_name, status);
        IFEND;
      IFEND;
    IFEND;
    osp$clear_mainframe_sig_lock (qfv$kol_lock);
  PROCEND qfp$validate_output_file_access;
MODEND qfm$queue_file_output_manager;
*DECK DECK=QFM$SET_JOB_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Job Management Job Attribute Interfaces' ??
MODULE qfm$set_job_attributes;

{ PURPOSE:
{   This module contains the ring 1 Job Management attribute manipulation interfaces.  The interfaces are
{   used to give values to the system's default job attributes and a job's ring 1 attributes.

{ DESIGN:
{   The procedure qfp$set_job_attributes is used to alter the ring 1 attributes of a job.  Generally,
{ ring 1 job attributes are those attributes that must be referenced by another job or by monitor.
{
{   The procedure qfp$change_attribute_defaults is used to update the system's default job attribute
{ values.  The modified structure is in mainframe pageable.

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmt$attribute_keys
*copyc jmt$default_attribute_changes
*copyc jmt$dispatching_control_info
*copyc jmt$initiated_job_list_entry
*copyc jmt$job_attribute_changes
*copyc jmt$job_control_block
*copyc ost$signature_lock
*copyc ost$status
*copyc ost$wait
*copyc tmt$change_priority_origin
?? POP ??
*copyc jmp$change_dispatching_prior_r1
*copyc jmp$determine_dis_priority
*copyc jmp$get_ijle_p
*copyc jmv$default_job_attributes
*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc jmv$kjl_p
*copyc mmv$aging_algorithm
*copyc osp$clear_signature_lock
*copyc osp$set_signature_lock
*copyc oss$mainframe_pageable
?? TITLE := 'qfp$change_attribute_defaults', EJECT ??
*copy qfh$change_attribute_defaults

  PROCEDURE [XDCL, #GATE] qfp$change_attribute_defaults
    (    job_mode: jmt$job_mode;
         default_attribute_changes_p: ^jmt$default_attribute_changes;
     VAR status: ost$status);

    VAR
      job_qualifier_index: 1 .. jmc$maximum_job_qualifiers,
      option_index: integer,
      osv$change_attr_def_lock: [STATIC,oss$mainframe_pageable] ost$signature_lock := [0];

    status.normal := TRUE;

    IF default_attribute_changes_p <> NIL THEN

      osp$set_signature_lock (osv$change_attr_def_lock, osc$wait, status);

      FOR option_index := 1 TO UPPERBOUND (default_attribute_changes_p^) DO
        CASE default_attribute_changes_p^ [option_index].key OF
        = jmc$cpu_time_limit =
          jmv$default_job_attributes [job_mode].cpu_time_limit :=
                default_attribute_changes_p^ [option_index].cpu_time_limit;

        = jmc$job_abort_disposition =
          jmv$default_job_attributes [job_mode].job_abort_disposition :=
                default_attribute_changes_p^ [option_index].job_abort_disposition;

        = jmc$job_class =
          jmv$default_job_attributes [job_mode].job_class :=
                default_attribute_changes_p^ [option_index].job_class;

        = jmc$job_deferred_by_operator =
          jmv$default_job_attributes [job_mode].job_deferred_by_operator :=
                default_attribute_changes_p^ [option_index].job_deferred_by_operator;

        = jmc$job_destination_usage =
          jmv$default_job_attributes [job_mode].job_destination_usage :=
                default_attribute_changes_p^ [option_index].job_destination_usage;

        = jmc$job_qualifier_list =
          FOR job_qualifier_index := 1 TO jmc$maximum_job_qualifiers DO
            jmv$default_job_attributes [job_mode].job_qualifier_list [job_qualifier_index] :=
                  default_attribute_changes_p^ [option_index].job_qualifier_list^ [job_qualifier_index];
          FOREND;

        = jmc$job_recovery_disposition =
          jmv$default_job_attributes [job_mode].job_recovery_disposition :=
                default_attribute_changes_p^ [option_index].job_recovery_disposition;

        = jmc$login_family =
          jmv$default_job_attributes [job_mode].login_family :=
                default_attribute_changes_p^ [option_index].login_family;

        = jmc$magnetic_tape_limit =
          jmv$default_job_attributes [job_mode].magnetic_tape_limit :=
                default_attribute_changes_p^ [option_index].magnetic_tape_limit;

        = jmc$maximum_working_set =
          jmv$default_job_attributes [job_mode].maximum_working_set :=
                default_attribute_changes_p^ [option_index].maximum_working_set;

        = jmc$null_attribute =
          ;

        = jmc$output_class =
          jmv$default_job_attributes [job_mode].output_class :=
                default_attribute_changes_p^ [option_index].output_class;

        = jmc$output_deferred_by_operator =
          jmv$default_job_attributes [job_mode].output_deferred_by_operator :=
                default_attribute_changes_p^ [option_index].output_deferred_by_operator;

        = jmc$output_destination_usage =
          jmv$default_job_attributes [job_mode].output_destination_usage :=
                default_attribute_changes_p^ [option_index].output_destination_usage;

        = jmc$purge_delay =
          jmv$default_job_attributes [job_mode].purge_delay :=
                default_attribute_changes_p^ [option_index].purge_delay^;

        = jmc$site_information =
          jmv$default_job_attributes [job_mode].site_information :=
                default_attribute_changes_p^ [option_index].site_information^;

        = jmc$sru_limit =
          jmv$default_job_attributes [job_mode].sru_limit :=
                default_attribute_changes_p^ [option_index].sru_limit;

        = jmc$station =
          jmv$default_job_attributes [job_mode].station := default_attribute_changes_p^ [option_index].
                station;

        = jmc$vertical_print_density =
          jmv$default_job_attributes [job_mode].vertical_print_density :=
                default_attribute_changes_p^ [option_index].vertical_print_density;

        ELSE
          ;
        CASEND;
      FOREND;

      osp$clear_signature_lock (osv$change_attr_def_lock, status);

    IFEND;
  PROCEND qfp$change_attribute_defaults;
?? TITLE := 'qfp$set_job_attributes', EJECT ??
*copy qfh$set_job_attributes

  PROCEDURE [XDCL, #GATE] qfp$set_job_attributes
    (    attribute_value: jmt$job_attribute_change;
     VAR status: ost$status);

    VAR
      cptime: integer,
      dispatching_control_info: jmt$dispatching_control_info,
      ignore_status_p: ^ost$status,
      ijl_entry_p: ^jmt$initiated_job_list_entry;

    status.normal := TRUE;

    CASE attribute_value.key OF
    = jmc$cyclic_aging_interval =
      jmv$jcb.cyclic_aging_interval := attribute_value.cyclic_aging_interval;
      jmv$jcb.next_cyclic_aging_time := #FREE_RUNNING_CLOCK (0) + jmv$jcb.cyclic_aging_interval;

    = jmc$detached_job_wait_time =
      jmv$jcb.detached_job_wait_time := attribute_value.detached_job_wait_time;

    = jmc$dispatching_priority =
      PUSH ignore_status_p;
      jmp$determine_dis_priority (attribute_value.dispatching_priority,
            dispatching_control_info.dispatching_priority, ignore_status_p^);
      jmp$change_dispatching_prior_r1 (tmc$cpo_user, jmv$jcb.ijl_ordinal, jmv$jcb.system_name,
            dispatching_control_info, status);

    = jmc$job_abort_disposition =
      jmp$get_ijle_p (jmv$kjl_p^ [jmv$jcb.job_id].initiated_job_list_ordinal, ijl_entry_p);
      ijl_entry_p^.queue_file_information.job_abort_disposition := attribute_value.job_abort_disposition;

    = jmc$job_recovery_disposition =
      jmp$get_ijle_p (jmv$kjl_p^ [jmv$jcb.job_id].initiated_job_list_ordinal, ijl_entry_p);
      ijl_entry_p^.queue_file_information.job_recovery_disposition :=
            attribute_value.job_recovery_disposition;

    = jmc$maximum_working_set =
      jmv$jcb.max_working_set_size := attribute_value.maximum_working_set;

    = jmc$minimum_working_set =
      jmv$jcb.min_working_set_size := attribute_value.minimum_working_set;

    = jmc$page_aging_interval =
      jmv$jcb.page_aging_interval := attribute_value.page_aging_interval;
      jmp$get_ijle_p (jmv$kjl_p^ [jmv$jcb.job_id].initiated_job_list_ordinal, ijl_entry_p);
      IF mmv$aging_algorithm >= 4 THEN
        cptime := ijl_entry_p^.statistics.cp_time.time_spent_in_job_mode;
      ELSE
        cptime := ijl_entry_p^.statistics.cp_time.time_spent_in_job_mode +
              ijl_entry_p^.statistics.cp_time.time_spent_in_mtr_mode;
      IFEND;
      jmv$jcb.cptime_next_age_working_set := cptime + jmv$jcb.page_aging_interval;

    ELSE
      ;
    CASEND;
  PROCEND qfp$set_job_attributes;
MODEND qfm$set_job_attributes;
*DECK DECK=QFP$ACQUIRE_MODIFIED_INPUT EXPAND=FALSE

  PROCEDURE [XREF] qfp$acquire_modified_input
    (    job_destination_usage: jmt$destination_usage;
     VAR input_descriptor: jmt$input_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
*copyc jmt$input_descriptor
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=QFP$ACQUIRE_MODIFIED_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] qfp$acquire_modified_output
    (    output_destination_usage: jmt$destination_usage;
     VAR output_descriptor: jmt$output_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
*copyc jmt$output_descriptor
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=QFP$ACQUIRE_MODIFIED_QFILE EXPAND=FALSE

  PROCEDURE [XREF] qfp$acquire_modified_qfile
    (    application_name: ost$name;
     VAR system_file_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$generic_queue_is_empty
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=QFP$ACQUIRE_NEW_INPUT EXPAND=FALSE

  PROCEDURE [XREF] qfp$acquire_new_input
    (    job_destination_usage: jmt$destination_usage;
     VAR input_descriptor: jmt$input_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
*copyc jmt$input_descriptor
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=QFP$ACQUIRE_NEW_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] qfp$acquire_new_output
    (    output_destination_usage: jmt$destination_usage;
     VAR output_descriptor: jmt$output_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
*copyc jmt$output_descriptor
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=QFP$ACQUIRE_NEW_QFILE EXPAND=FALSE

  PROCEDURE [XREF] qfp$acquire_new_qfile
    (    application_name: ost$name;
     VAR system_file_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$generic_queue_is_empty
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=QFP$ACQUIRE_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] qfp$acquire_output (
        output_mechanism: jmt$output_mechanism;
    VAR output_descriptor: jmt$output_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$output_descriptor
*copyc jmt$output_mechanism
*copyc ost$status
?? POP ??
*DECK DECK=QFP$ACTIVATE_DEFERRED_FAMILY EXPAND=FALSE

  PROCEDURE [XREF] qfp$activate_deferred_family
    (    family_name: ost$name);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=QFP$ASSIGN_JOBS_TO_CLIENT EXPAND=FALSE

  PROCEDURE [XREF] qfp$assign_jobs_to_client
    (    client_mainframe_id: pmt$binary_mainframe_id;
         leveler_job_class_data: jmt$jl_job_class_data;
         job_class_priorities: jmt$jl_job_class_priorities;
         initiation_required_categories: jmt$job_category_set;
         initiation_excluded_categories: jmt$job_category_set;
         assigned_job_list_p { output } : ^jmt$jl_assigned_job_list;
     VAR number_of_jobs_assigned: jmt$job_count_range;
     VAR server_job_priorities: jmt$jl_server_job_priorities);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$jl_assigned_job_list
*copyc jmt$jl_job_class_data
*copyc jmt$jl_job_class_priorities
*copyc jmt$jl_server_job_priorities
*copyc jmt$job_category_set
*copyc jmt$job_count_range
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=QFP$ASSIGN_SERVER_JOBS EXPAND=FALSE

  PROCEDURE [XREF] qfp$assign_server_jobs
    (    server_mainframe_id: pmt$binary_mainframe_id;
         assigned_job_list_p: ^jmt$jl_assigned_job_list;
     VAR number_of_jobs_assigned: jmt$job_count_range;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$jl_assigned_job_list
*copyc jmt$job_count_range
*copyc pmt$binary_mainframe_id
*copyc ost$status
?? POP ??
*DECK DECK=QFP$ASSIGN_SYSTEM_SUPPLIED_NAME EXPAND=FALSE

  PROCEDURE [XREF] qfp$assign_system_supplied_name (
    VAR system_supplied_name: jmt$system_supplied_name);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
?? POP ??
*DECK DECK=QFP$CATEGORIZE_JOB EXPAND=FALSE

  PROCEDURE [XREF] qfp$categorize_job
    (    valid_job_classes: jmt$job_class_list;
         number_of_valid_job_classes: ost$non_negative_integers;
     VAR system_label { input, output } : jmt$job_system_label;
     VAR assigned_job_class: jmt$job_class;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
*copyc jme$job_categorization_errors
*copyc jmt$job_class
*copyc jmt$job_class_list
*copyc jmt$job_system_label
*copyc ost$status
?? POP ??
*DECK DECK=QFP$CHANGE_ATTRIBUTE_DEFAULTS EXPAND=FALSE

  PROCEDURE [XREF] qfp$change_attribute_defaults
    (    job_mode: jmt$job_mode;
         default_attribute_changes_p: ^jmt$default_attribute_changes;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$default_attribute_changes
*copyc jmt$job_mode
*copyc ost$status
?? POP ??
*DECK DECK=QFP$CHANGE_INPUT_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] qfp$change_input_attributes
    (    system_label: jmt$job_system_label;
         job_class: jmt$job_class;
         privileged_job: boolean;
         earliest_clock_time_to_initiate: jmt$clock_time;
         latest_clock_time_to_initiate: jmt$clock_time;
         current_microsecond_clock: jmt$clock_time;
         valid_mainframe_set: jmt$valid_mainframe_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$clock_time
*copyc jmt$job_class
*copyc jmt$job_system_label
*copyc jmt$valid_mainframe_set
*copyc ost$status
?? POP ??
*DECK DECK=QFP$CHANGE_OUTPUT_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] qfp$change_output_attributes
    (    system_label: jmt$output_system_label;
         earliest_clock_time_to_print: jmt$clock_time;
         latest_clock_time_to_print: jmt$clock_time;
         purge_delay_clock_time: jmt$clock_time;
         current_clock_time: jmt$clock_time;
         reprint_disposition: jmt$reprint_disposition;
     VAR notify_application: boolean;
     VAR application_gtid: ost$global_task_id;
     VAR delete_output_file: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$clock_time
*copyc jmt$output_system_label
*copyc jmt$reprint_disposition
*copyc ost$global_task_id
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=QFP$CHANGE_QFILE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] qfp$change_qfile_attributes
    (    system_label: jmt$qfile_system_label;
         earliest_clock_time_to_process: jmt$clock_time;
         latest_clock_time_to_process: jmt$clock_time;
         purge_delay_clock_time: jmt$clock_time;
         current_clock_time: jmt$clock_time;
         rerun_disposition: jmt$rerun_disposition;
     VAR delete_queue_file: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$name_not_found
*copyc jmt$clock_time
*copyc jmt$output_system_label
*copyc jmt$rerun_disposition
*copyc ost$status
?? POP ??
*DECK DECK=QFP$CHANGE_TERMINATE_JOB_ACTION EXPAND=FALSE

  PROCEDURE [XREF] qfp$change_terminate_job_action
    (    terminate_job_action_set: jmt$terminate_job_action_set);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$terminate_job_action
?? POP ??
*DECK DECK=QFP$CHECK_FOR_PROFILE_MISMATCH EXPAND=FALSE

  PROCEDURE [XREF] qfp$check_for_profile_mismatch
    (    profile_version: ost$name;
     VAR profile_mismatch: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=QFP$CLEAR_SERVER_JOB_CLASSES EXPAND=FALSE

  PROCEDURE [XREF] qfp$clear_server_job_classes;
*DECK DECK=QFP$DEFER_DEACTIVATED_FAMILY EXPAND=FALSE

  PROCEDURE [XREF] qfp$defer_deactivated_family
    (    family_name: ost$name);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=QFP$DETERMINE_MAINFRAME_FITNESS EXPAND=FALSE

  PROCEDURE [XREF] qfp$determine_mainframe_fitness
    (    job_category_set: jmt$job_category_set;
         leveled_job: boolean;
         login_family: ost$name;
     VAR valid_mainframes_set: jmt$valid_mainframe_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$job_categorization_errors
*copyc jmt$job_category_set
*copyc jmt$valid_mainframe_set
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=QFP$DETERMINE_NEEDED_PRIORITIES EXPAND=FALSE

  PROCEDURE [XREF] qfp$determine_needed_priorities
    (    leveler_job_class_data: jmt$jl_job_class_data;
     VAR job_class_priorities: jmt$jl_job_class_priorities);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$jl_job_class_data
*copyc jmt$jl_job_class_priorities
?? POP ??
*DECK DECK=QFP$DETERMINE_NEED_FOR_JOBS EXPAND=FALSE

  PROCEDURE [XREF] qfp$determine_need_for_jobs
    (VAR leveler_job_class_data: jmt$jl_job_class_data);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$jl_job_class_data
?? POP ??
*DECK DECK=QFP$DISCARD_CLIENT_JOBS EXPAND=FALSE

  PROCEDURE [XREF] qfp$discard_client_jobs
    (    client_mainframe_id: pmt$binary_mainframe_id);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
?? POP ??

*DECK DECK=QFP$DISCARD_JOB EXPAND=FALSE

  PROCEDURE [XREF] qfp$discard_job;
*DECK DECK=QFP$DISCARD_JOB_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] qfp$discard_job_output
    (    output_disposition_key: jmt$output_disposition_keys);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$output_disposition_keys
?? POP ??
*DECK DECK=QFP$DISCARD_SERVER_JOBS EXPAND=FALSE

  PROCEDURE [XREF] qfp$discard_server_jobs
    (    server_mainframe_id: pmt$binary_mainframe_id);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=QFP$EXPAND_KJL EXPAND=FALSE

  PROCEDURE [XREF] qfp$expand_kjl;

*DECK DECK=QFP$FIND_JOB_CONNECTION_SWITCH EXPAND=FALSE
*DECK DECK=QFP$GET_APPLICATION_NAME EXPAND=FALSE

  PROCEDURE [XREF] qfp$get_application_name
    (    output_destination_usage: jmt$destination_usage;
     VAR application_name: ost$name);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
*copyc ost$name
?? POP ??
*DECK DECK=QFP$GET_INPUT_FILE_LOCATION EXPAND=FALSE

  PROCEDURE [XREF] qfp$get_input_file_location
    (    system_job_name: jmt$system_supplied_name;
     VAR location: jmt$input_file_location;
     VAR family: ost$family_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$input_file_location
*copyc jmt$system_supplied_name
*copyc ost$status
*copyc ost$user_identification
?? POP ??
*DECK DECK=QFP$GET_INPUT_Q_FROM_UNASSIGNED EXPAND=FALSE

  PROCEDURE [XREF] qfp$get_input_q_from_unassigned
    (VAR system_supplied_names: array [1 .. * ] of jmt$system_supplied_name;
     VAR number_of_jobs_found: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=QFP$GET_JOB_COUNTS EXPAND=FALSE

  PROCEDURE [XREF] qfp$get_job_counts
    (VAR job_counts: jmt$job_counts);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_counts
?? POP ??
*DECK DECK=QFP$GET_JOB_INTERNAL_INFO EXPAND=FALSE

  PROCEDURE [XREF] qfp$get_job_internal_info
    (    system_job_name: jmt$system_supplied_name;
     VAR job_internal_info: jmt$job_internal_information;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc jmt$job_internal_information
*copyc ost$status
?? POP ??

*DECK DECK=QFP$GET_JOB_STATUS EXPAND=FALSE

  PROCEDURE [XREF] qfp$get_job_status
    (    user_identification: ost$user_identification;
         caller_ssn: jmt$system_supplied_name;
         privileged_job: boolean;
         valid_for_scheduling_displays: boolean;
         status_options: ^jmt$job_status_options;
         status_results_keys_p: ^jmt$results_keys;
     VAR work_area_p: ^jmt$work_area;
     VAR number_of_jobs_found: jmt$job_status_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_status_count
*copyc jmt$job_status_options
*copyc jmt$results_keys
*copyc jmt$system_supplied_name
*copyc jmt$work_area
*copyc ost$status
*copyc ost$user_identification
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=QFP$GET_OUTPUT_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] qfp$get_output_attributes
    (    user_identification: ost$user_identification;
         privileged_job: boolean;
         attribute_options_p: ^jmt$output_attribute_options;
         output_names_p: ^jmt$name_list;
     VAR number_of_outputs_found: jmt$output_status_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$name_list
*copyc jmt$output_attribute_options
*copyc jmt$output_status_count
*copyc ost$status
*copyc ost$user_identification
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=QFP$GET_OUTPUT_COUNTS EXPAND=FALSE

  PROCEDURE [XREF] qfp$get_output_counts
    (VAR output_counts: jmt$output_counts;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$output_counts
*copyc ost$status
?? POP ??
*DECK DECK=QFP$GET_OUTPUT_STATUS EXPAND=FALSE

  PROCEDURE [XREF] qfp$get_output_status
    (    user_identification: ost$user_identification;
         privileged_job: boolean;
         status_options: ^jmt$output_status_options;
         status_results_keys_p: ^jmt$results_keys;
     VAR work_area_p: ^jmt$work_area;
     VAR number_of_outputs_found: jmt$output_status_count;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$user_identification
*copyc jmt$output_status_options
*copyc jmt$output_status_results
*copyc jmt$output_status_count
*copyc jmt$results_keys
*copyc jmt$work_area
*copyc ost$status
?? POP ??
*DECK DECK=QFP$GET_PROFILE_MAINFRAME_INDEX EXPAND=FALSE

  PROCEDURE [XREF] qfp$get_profile_mainframe_index
    (    binary_mainframe_id: pmt$binary_mainframe_id;
     VAR mainframe_index: jmt$maximum_mainframes);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$maximum_mainframes
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=QFP$GET_QFILE_STATUS EXPAND=FALSE

  PROCEDURE [XREF] qfp$get_qfile_status
    (    status_options_p: ^jmt$qfile_status_options;
         status_results_keys_p: ^jmt$results_keys;
     VAR status_work_area_p: ^jmt$work_area;
     VAR status_results_p: ^jmt$qfile_status_results;
     VAR number_of_qfiles_found: jmt$qfile_status_count);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$qfile_status_options
*copyc jmt$qfile_status_results
*copyc jmt$qfile_status_count
*copyc jmt$results_keys
*copyc jmt$work_area
?? POP ??
*DECK DECK=QFP$GET_SERVER_JOBS EXPAND=FALSE

  PROCEDURE [XREF] qfp$get_server_jobs
    (    server_mainframe_id: pmt$binary_mainframe_id;
         server_job_list_p: { output } ^jmt$jl_server_job_list;
     VAR server_job_count: jmt$job_count_range);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$jl_server_job_list
*copyc jmt$job_count_range
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=QFP$JOB_REQUESTS_RESTART EXPAND=FALSE

  FUNCTION [XREF] qfp$job_requests_restart: boolean;
*DECK DECK=QFP$JOB_SELECTION_PRIORITY EXPAND=FALSE

  FUNCTION [INLINE] qfp$job_selection_priority
    (    current_time: jmt$clock_time;
         kjl_index: jmt$kjl_index): jmt$job_priority;

?? PUSH (LISTEXT := ON) ??

    VAR
      age_interval: integer,
      job_class: jmt$job_class,
      job_priority: integer;

    IF kjl_index = jmc$kjl_undefined_index THEN
      job_priority := 0;
    ELSE
      job_class := jmv$kjl_p^ [kjl_index].job_class;

      IF jmv$job_class_table_p^ [job_class].initiation_age_interval <>
            jmc$unlimited_prio_age_interval THEN
        age_interval := ((current_time - jmv$kjl_p^ [kjl_index].
              job_submission_time) DIV jmv$job_class_table_p^ [job_class].
              initiation_age_interval);
      ELSE
        age_interval := 0; { no aging
      IFEND;
      job_priority := age_interval * jmv$job_class_table_p^ [job_class].
            selection_priority.increment + jmv$job_class_table_p^ [job_class].
            selection_priority.initial + jmv$kjl_p^ [kjl_index].priority_bias;
      IF job_priority > UPPERVALUE (jmt$job_priority) THEN
        job_priority := UPPERVALUE (jmt$job_priority);
      ELSEIF job_priority < LOWERVALUE (jmt$job_priority) THEN
        job_priority := LOWERVALUE (jmt$job_priority);
      IFEND;
    IFEND;
    qfp$job_selection_priority := job_priority;
  FUNCEND qfp$job_selection_priority;

*copy qfh$job_selection_priority

*copyc jmt$job_class
*copyc jmt$job_priority
*copyc jmt$kjl_index
*copyc jmv$job_class_table_p
*copyc jmv$job_scheduler_table
*copyc jmv$kjl_p
?? POP ??
*DECK DECK=QFP$LIST_JOBS_VIA_MODE EXPAND=FALSE

  PROCEDURE [XREF] qfp$list_jobs_via_mode
    (    job_mode: jmt$job_mode;
     VAR system_job_names: array [1 .. * ] of jmt$system_supplied_name;
     VAR number_of_jobs_returned: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_mode
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=QFP$MOVE_INPUT_Q_TO_UNASSIGNED EXPAND=FALSE

  PROCEDURE [XREF] qfp$move_input_q_to_unassigned
    (    job_class_index: jmt$job_class;
     VAR number_of_jobs_moved: jmt$job_count_range;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
*copyc jmt$job_count_range
*copyc ost$status
?? POP ??
*DECK DECK=QFP$PRINT_FILE EXPAND=FALSE

  PROCEDURE [XREF] qfp$print_file (
        system_label: jmt$output_system_label;
        earliest_clock_time_to_print: jmt$clock_time;
        latest_clock_time_to_print: jmt$clock_time;
        current_clock_time: jmt$clock_time;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$clock_time
*copyc jmt$output_system_label
*copyc ost$status
?? POP ??
*DECK DECK=QFP$PURGE_EXPIRED_FILE EXPAND=FALSE

  PROCEDURE [XREF] qfp$purge_expired_file
    (VAR system_file_name_to_delete: jmt$system_supplied_name;
     VAR output_destination_usage: jmt$destination_usage);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
*copyc jmt$system_supplied_name
?? POP ??
*DECK DECK=QFP$PURGE_EXPIRED_QUEUE_FILE EXPAND=FALSE

  PROCEDURE [XREF] qfp$purge_expired_queue_file
    (VAR system_file_name_to_delete: jmt$system_supplied_name);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
?? POP ??
*DECK DECK=QFP$PURGE_PRINTED_FILE EXPAND=FALSE

  PROCEDURE [XREF] qfp$purge_printed_file
    (VAR system_file_name_to_delete: jmt$system_supplied_name;
     VAR output_destination_usage: jmt$destination_usage);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
*copyc jmt$system_supplied_name
?? POP ??
*DECK DECK=QFP$PURGE_PROCESSED_QUEUE_FILE EXPAND=FALSE

  PROCEDURE [XREF] qfp$purge_processed_queue_file
    (VAR system_file_name_to_delete: jmt$system_supplied_name);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
?? POP ??
*DECK DECK=QFP$QUEUE_JOB_FOR_CON_SWITCH EXPAND=FALSE
*DECK DECK=QFP$READY_DEFERRED_FILE EXPAND=FALSE

  PROCEDURE [XREF] qfp$ready_deferred_file;

*DECK DECK=QFP$READY_DEFERRED_JOB EXPAND=FALSE

  PROCEDURE [XREF] qfp$ready_deferred_job;

*DECK DECK=QFP$READY_DEFERRED_QUEUE_FILE EXPAND=FALSE

  PROCEDURE [XREF] qfp$ready_deferred_queue_file;

*DECK DECK=QFP$READY_JOB_LEVELER EXPAND=FALSE

  PROCEDURE [INLINE] qfp$ready_job_leveler;

?? PUSH (LISTEXT := ON) ??

    VAR
      ignore_status: ost$status;

    qfp$set_leveler_ready (TRUE);
    pmp$ready_task (jmv$known_job_list.application_table [
          jmc$ve_input_application_index].global_task_id, ignore_status);

  PROCEND qfp$ready_job_leveler;

*copy qfh$ready_job_leveler

*copyc ost$status
*copyc pmp$ready_task
*copyc qfp$set_leveler_ready
*copyc jmv$known_job_list
?? POP ??
*DECK DECK=QFP$READ_JOB_SYSTEM_LABEL EXPAND=FALSE

  PROCEDURE [XREF] qfp$read_job_system_label (
        file_reference: fst$file_reference;
    VAR system_label: jmt$job_system_label;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jmt$job_system_label
*copyc ost$status
?? POP ??
*DECK DECK=QFP$READ_OUTPUT_SYSTEM_LABEL EXPAND=FALSE

  PROCEDURE [XREF] qfp$read_output_system_label (
        file_reference: fst$file_reference;
    VAR system_label: jmt$output_system_label;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jmt$output_system_label
*copyc ost$status
?? POP ??
*DECK DECK=QFP$READ_QFILE_SYSTEM_LABEL EXPAND=FALSE

  PROCEDURE [XREF] qfp$read_qfile_system_label
    (    file_reference: fst$file_reference;
     VAR system_label: jmt$qfile_system_label;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jme$read_qfile_system_label
*copyc jme$sl_version_mismatch
*copyc jmt$qfile_system_label
*copyc ost$status
?? POP ??
*DECK DECK=QFP$REBUILD_EXECUTING_JOB EXPAND=FALSE

  PROCEDURE [XREF] qfp$rebuild_executing_job
    (    current_clock_time: jmt$clock_time;
         system_job_name: jmt$system_supplied_name;
         job_control_block: jmt$job_control_block);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$clock_time
*copyc jmt$system_supplied_name
*copyc jmt$job_control_block
?? POP ??
*DECK DECK=QFP$REBUILD_GENERIC_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] qfp$rebuild_generic_queue
    (    system_label: jmt$qfile_system_label;
         earliest_clock_time_to_process: jmt$clock_time;
         latest_clock_time_to_process: jmt$clock_time;
         purge_delay_clock_time: jmt$clock_time;
         current_clock_time: jmt$clock_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$maximum_generic_qfiles
*copyc jmt$clock_time
*copyc jmt$output_system_label
*copyc ost$status
?? POP ??
*DECK DECK=QFP$REBUILD_INPUT_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] qfp$rebuild_input_queue
    (    system_label: jmt$job_system_label;
         earliest_time_to_initiate: jmt$clock_time;
         latest_time_to_initiate: jmt$clock_time;
         current_clock_time: jmt$clock_time;
         job_submission_time: jmt$clock_time;
         job_class: jmt$job_class;
         input_file_location: jmt$input_file_location;
         login_family_available: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$clock_time
*copyc jmt$input_file_location
*copyc jmt$job_class
*copyc jmt$job_system_label
*copyc ost$status
?? POP ??
*DECK DECK=QFP$REBUILD_OUTPUT_QUEUE EXPAND=FALSE

  PROCEDURE [XREF] qfp$rebuild_output_queue (
        system_label: jmt$output_system_label;
        earliest_clock_time_to_print: jmt$clock_time;
        latest_clock_time_to_print: jmt$clock_time;
        purge_delay_clock_time: jmt$clock_time;
        current_clock_time: jmt$clock_time;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$clock_time
*copyc jmt$output_system_label
*copyc ost$status
?? POP ??
*DECK DECK=QFP$REGISTER_INPUT_APPLICATION EXPAND=FALSE

  PROCEDURE [XREF] qfp$register_input_application
    (    application_name: ost$name;
         destination_usage: jmt$destination_usage;
         password: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
*copyc ost$name
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=QFP$REGISTER_JOB_LEVELER EXPAND=FALSE

  PROCEDURE [XREF] qfp$register_job_leveler;
*DECK DECK=QFP$REGISTER_OUTPUT_APPLICATION EXPAND=FALSE

  PROCEDURE [XREF] qfp$register_output_application
    (    application_name: ost$name;
         destination_usage: jmt$destination_usage;
         password: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
*copyc ost$name
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=QFP$REGISTER_QFILE_APPLICATION EXPAND=FALSE

  PROCEDURE [XREF] qfp$register_qfile_application
    (    application_name: ost$name;
         registration_options_p: ^jmt$qfile_registration_options;
         password: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$application_name_in_use
*copyc jme$application_table_is_full
*copyc jmt$qfile_registration_options
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=QFP$RELEASE_GENERIC_QUEUE_FILES EXPAND=FALSE

  PROCEDURE [XREF] qfp$release_generic_queue_files
    (    release_file_list: ^jmt$system_supplied_name_list;
     VAR release_file_count: jmt$qfile_count_range);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$qfile_count_range
*copyc jmt$system_supplied_name_list
?? POP ??
*DECK DECK=QFP$RELEASE_INPUT_FILES EXPAND=FALSE

  PROCEDURE [XREF] qfp$release_input_files
    (    release_file_list: ^jmt$release_input_file_list;
     VAR release_file_count: jmt$job_count_range);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_count_range
*copyc jmt$release_input_file_list
?? POP ??
*DECK DECK=QFP$RELEASE_OUTPUT_FILES EXPAND=FALSE

  PROCEDURE [XREF] qfp$release_output_files
    (    release_file_list: ^jmt$release_output_file_list;
     VAR release_file_count: jmt$output_count_range);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$output_count_range
*copyc jmt$release_output_file_list
?? POP ??
*DECK DECK=QFP$RELINK_KJL_APPLICATION EXPAND=FALSE

  PROCEDURE [XREF] qfp$relink_kjl_application
    (    kjl_index: jmt$kjl_index;
         destination_application_index: jmt$input_application_index;
         destination_state: jmt$kjl_application_state);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$input_application_index
*copyc jmt$kjl_application_state
*copyc jmt$kjl_index
?? POP ??
*DECK DECK=QFP$RELINK_KJL_CLIENT EXPAND=FALSE

  PROCEDURE [XREF] qfp$relink_kjl_client
    (    kjl_index: jmt$kjl_index;
         destination_client_index: jmt$kjl_client_index);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$kjl_client_index
*copyc jmt$kjl_index
?? POP ??
*DECK DECK=QFP$RELINK_KJL_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] qfp$relink_kjl_entry (
        kjl_index: jmt$kjl_index;
        destination_job_class: jmt$job_class;
        destination_entry_kind: jmt$kjl_entry_kind);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
*copyc jmt$kjl_index
*copyc jmt$kjl_entry_kind
?? POP ??
*DECK DECK=QFP$RELINK_KJL_SERVER EXPAND=FALSE

  PROCEDURE [XREF] qfp$relink_kjl_server
    (    kjl_index: jmt$kjl_index;
         destination_server_index: jmt$kjl_server_index);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$kjl_server_index
*copyc jmt$kjl_index
?? POP ??
*DECK DECK=QFP$REMOVE_JOB_FROM_KJL EXPAND=FALSE

  PROCEDURE [XREF] qfp$remove_job_from_kjl
    (    system_job_name: jmt$system_supplied_name);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
?? POP ??
*DECK DECK=QFP$SERVER_JOB_BEGIN EXPAND=FALSE

  PROCEDURE [XREF] qfp$server_job_begin
    (    job_begin_information: jmt$jl_server_job_end_info;
     VAR job_terminated: boolean;
     VAR login_family: ost$name);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$jl_server_job_end_info
*copyc ost$name
?? POP ??
*DECK DECK=QFP$SERVER_JOB_END EXPAND=FALSE

  PROCEDURE [XREF] qfp$server_job_end
    (    job_end_information: jmt$jl_server_job_end_info);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$jl_server_job_end_info
?? POP ??
*DECK DECK=QFP$SET_AJL_STATUS EXPAND=FALSE

  PROCEDURE [XREF] qfp$set_ajl_status ( ajl_ord: jmt$ajl_ordinal;
    status_value: jmt$ajl_status;
    VAR status: ost$status);

??PUSH(LIST:=OFF{LISTEXT:=ON})??
*copyc JMT$AJL_ORDINAL
*copyc JMT$AJL_STATUS
*copyc OST$STATUS
??POP??
*DECK DECK=QFP$SET_FAMILY_UNAVAILABLE EXPAND=FALSE

  PROCEDURE [XREF] qfp$set_family_unavailable;
*DECK DECK=QFP$SET_INPUT_COMPLETED EXPAND=FALSE

  PROCEDURE [XREF] qfp$set_input_completed
    (    input_destination_usage: jmt$destination_usage;
         system_job_name: jmt$system_supplied_name;
         completed_successfully: boolean;
     VAR delete_input_file: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
*copyc jmt$system_supplied_name
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=QFP$SET_INPUT_INITIATED EXPAND=FALSE

  PROCEDURE [XREF] qfp$set_input_initiated
    (    input_destination_usage: jmt$destination_usage;
         system_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
*copyc jmt$system_supplied_name
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=QFP$SET_INTERACTIVE_JRD_JAD EXPAND=FALSE

  PROCEDURE [XREF] qfp$set_interactive_jrd_jad;

*DECK DECK=QFP$SET_JOB_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] qfp$set_job_attributes
    (    attribute_value: jmt$job_attribute_change;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_attribute_changes
*copyc ost$status
?? POP ??
*DECK DECK=QFP$SET_JOB_CLASS_LIMITS EXPAND=FALSE

  PROCEDURE [XREF] qfp$set_job_class_limits
    (    job_class_set: jmt$job_class_set;
         class_limit_value: jmt$job_count_range);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class_set
*copyc jmt$job_count_range
?? POP ??
*DECK DECK=QFP$SET_JOB_RESTART EXPAND=FALSE

  PROCEDURE [XREF] qfp$set_job_restart;
*DECK DECK=QFP$SET_LEVELER_READY EXPAND=FALSE

  PROCEDURE [XREF] qfp$set_leveler_ready
    (    ready_leveler: boolean);

*DECK DECK=QFP$SET_OUTPUT_COMPLETED EXPAND=FALSE

  PROCEDURE [XREF] qfp$set_output_completed
    (    output_destination_usage: jmt$destination_usage;
         system_file_name: jmt$system_supplied_name;
         completed_successfully: boolean;
         purge_delay_clock_time: jmt$clock_time;
         current_clock_time: jmt$clock_time;
     VAR delete_output_file: boolean;
     VAR system_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$clock_time
*copyc jmt$destination_usage
*copyc jmt$system_supplied_name
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=QFP$SET_OUTPUT_INITIATED EXPAND=FALSE

  PROCEDURE [XREF] qfp$set_output_initiated
    (    output_destination_usage: jmt$destination_usage;
         system_file_name: jmt$system_supplied_name;
     VAR system_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
*copyc jmt$system_supplied_name
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=QFP$SET_QFILE_COMPLETED EXPAND=FALSE

  PROCEDURE [XREF] qfp$set_qfile_completed
    (    application_name: ost$name;
         system_file_name: jmt$system_supplied_name;
         completed_successfully: boolean;
         purge_delay_clock_time: jmt$clock_time;
         current_clock_time: jmt$clock_time;
     VAR delete_qfile: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$application_name_incorrect
*copyc jme$name_not_found
*copyc jme$qfile_appl_not_permitted
*copyc jmt$clock_time
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=QFP$SET_QFILE_INITIATED EXPAND=FALSE

  PROCEDURE [XREF] qfp$set_qfile_initiated
    (    application_name: ost$name;
         system_file_name: jmt$system_supplied_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$name_not_found
*copyc jme$qfile_cannot_initiate
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=QFP$SET_TERMINAL_NAME EXPAND=FALSE
  PROCEDURE [XREF] qfp$set_terminal_name
    (    terminal_name: ift$terminal_name);

?? PUSH (LISTEXT := ON) ??
*copyc ift$terminal_name
?? POP ??
*DECK DECK=QFP$SUBMIT_JOB EXPAND=FALSE

  PROCEDURE [XREF] qfp$submit_job
    (    system_label: jmt$job_system_label;
         job_class: jmt$job_class;
         earliest_clock_time_to_initiate: jmt$clock_time;
         latest_clock_time_to_initiate: jmt$clock_time;
         current_clock_time: jmt$clock_time;
         job_submission_time: jmt$clock_time;
         immediate_initiation_candidate: boolean;
         input_file_location: jmt$input_file_location;
         valid_mainframe_set: jmt$valid_mainframe_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$clock_time
*copyc jmt$input_file_location
*copyc jmt$job_class
*copyc jmt$job_system_label
*copyc jmt$valid_mainframe_set
*copyc ost$status
?? POP ??
*DECK DECK=QFP$SUBMIT_QFILE EXPAND=FALSE

  PROCEDURE [XREF] qfp$submit_qfile
    (    system_label: jmt$qfile_system_label;
         earliest_clock_time_to_process: jmt$clock_time;
         latest_clock_time_to_process: jmt$clock_time;
         current_clock_time: jmt$clock_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$maximum_generic_qfiles
*copyc jmt$clock_time
*copyc jmt$qfile_system_label
*copyc ost$status
?? POP ??
*DECK DECK=QFP$TERMINATE_ACQUIRED_INPUT EXPAND=FALSE

  PROCEDURE [XREF] qfp$terminate_acquired_input
    (    input_destination_usage: jmt$destination_usage;
     VAR system_job_name: jmt$system_supplied_name;
     VAR delete_input_file: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
*copyc jmt$system_supplied_name
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=QFP$TERMINATE_ACQUIRED_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] qfp$terminate_acquired_output
    (    output_destination_usage: jmt$destination_usage;
     VAR system_file_name: jmt$system_supplied_name;
     VAR system_job_name: jmt$system_supplied_name;
     VAR delete_output_file: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
*copyc jmt$system_supplied_name
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=QFP$TERMINATE_ACQUIRED_QFILE EXPAND=FALSE

  PROCEDURE [XREF] qfp$terminate_acquired_qfile
    (    application_name: ost$name;
     VAR system_file_name: jmt$system_supplied_name;
     VAR delete_qfile: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$generic_queue_is_empty
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=QFP$TERMINATE_JOB EXPAND=FALSE

  PROCEDURE [XREF] qfp$terminate_job
    (    system_job_name: jmt$system_supplied_name;
         job_state_set: jmt$job_state_set;
         output_disposition_key_known: boolean;
         output_disposition_key: jmt$output_disposition_keys;
         operator_job: boolean;
     VAR family_name: ost$name;
     VAR delete_input_file: boolean;
     VAR input_file_location: jmt$input_file_location;
     VAR job_assigned_to_client: boolean;
     VAR client_mainframe_id: pmt$mainframe_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc jmt$input_file_location
*copyc jmt$job_state_set
*copyc jmt$output_disposition_keys
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
*copyc pmt$mainframe_id
?? POP ??
*DECK DECK=QFP$TERMINATE_OUTPUT EXPAND=FALSE

  PROCEDURE [XREF] qfp$terminate_output
    (    system_file_name: jmt$system_supplied_name;
         output_state_set: jmt$output_state_set;
     VAR system_job_name: jmt$system_supplied_name;
     VAR output_destination_usage: jmt$destination_usage;
     VAR delete_output_file: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
*copyc jmt$output_state_set
*copyc jmt$system_supplied_name
*copyc ost$status
*copyc jme$queued_file_conditions
?? POP ??
*DECK DECK=QFP$TERMINATE_QFILE EXPAND=FALSE

  PROCEDURE [XREF] qfp$terminate_qfile
    (    system_file_name: jmt$system_supplied_name;
         qfile_state_set: jmt$qfile_state_set;
     VAR delete_qfile: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$name_not_found
*copyc jme$qfile_already_terminated
*copyc jmt$qfile_state_set
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=QFP$UNASSIGN_CLIENT_JOBS EXPAND=FALSE

  PROCEDURE [XREF] qfp$unassign_client_jobs
    (    client_mainframe_id: pmt$binary_mainframe_id;
         unassigned_job_list_p: ^jmt$jl_unassigned_job_list);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$jl_unassigned_job_list
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=QFP$UNASSIGN_SERVER_JOBS EXPAND=FALSE

  PROCEDURE [XREF] qfp$unassign_server_jobs
    (    server_mainframe_id: pmt$binary_mainframe_id;
         unassign_all_jobs: boolean;
         job_class_priorities: jmt$jl_job_class_priorities;
         unassigned_job_list_p { output } : ^jmt$jl_unassigned_job_list;
     VAR number_of_jobs_unassigned: jmt$job_count_range);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$jl_job_class_priorities
*copyc jmt$jl_unassigned_job_list
*copyc jmt$job_count_range
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=QFP$UNLINK_AJL_KJL EXPAND=FALSE

  PROCEDURE [XREF] qfp$unlink_ajl_kjl ( ajl_ord: jmt$ajl_ordinal;
    VAR status: ost$status);

??PUSH(LIST:=OFF{LISTEXT:=ON})??
*copyc JMT$AJL_ORDINAL
*copyc OST$STATUS
??POP??
*DECK DECK=QFP$UNLINK_KJL_AJL EXPAND=FALSE

  PROCEDURE [XREF] qfp$unlink_kjl_ajl ( kjl_ord: jmt$kjl_ordinal;
    VAR status: ost$status);

??PUSH(LIST:=OFF{LISTEXT:=ON})??
*copyc JMT$KJL_ORDINAL
*copyc OST$STATUS
??POP??
*DECK DECK=QFP$UPDATE_LAST_USED_SSN EXPAND=FALSE

  PROCEDURE [XREF] qfp$update_last_used_ssn;
*DECK DECK=QFP$UPDATE_SERVER_PRIORITIES EXPAND=FALSE

  PROCEDURE [XREF] qfp$update_server_priorities
    (    highest_server_priorities: jmt$jl_server_job_priorities);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$jl_server_job_priorities
?? POP ??

*DECK DECK=QFP$VALIDATE_INPUT_FILE_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] qfp$validate_input_file_access
    (    system_job_name: jmt$system_supplied_name;
         input_destination_usage: jmt$destination_usage;
         queue_file_password: jmt$queue_file_password;
     VAR family_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
*copyc jmt$queue_file_password
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=QFP$VALIDATE_OUTPUT_FILE_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] qfp$validate_output_file_access
    (    system_file_name: jmt$system_supplied_name;
         output_destination_usage: jmt$destination_usage;
         queue_file_password: jmt$queue_file_password;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$destination_usage
*copyc jmt$queue_file_password
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=QFP$VALIDATE_QFILE_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] qfp$validate_qfile_access
    (    system_file_name: jmt$system_supplied_name;
         application_name: ost$name;
         queue_file_password: jmt$queue_file_password;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jme$application_name_incorrect
*copyc jme$name_not_found
*copyc jme$qfile_appl_not_permitted
*copyc jmt$queue_file_password
*copyc jmt$system_supplied_name
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=QFP$VERIFY_CLIENT_ASSIGNED_JOBS EXPAND=FALSE

  PROCEDURE [XREF] qfp$verify_client_assigned_jobs
    (    client_mainframe_id: pmt$binary_mainframe_id;
         server_job_list_p: ^jmt$jl_server_job_list;
         missing_job_list_p: { output } ^jmt$jl_missing_job_list;
     VAR missing_job_count: jmt$job_count_range);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$jl_missing_job_list
*copyc jmt$jl_server_job_list
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=QFP$VERIFY_INACTIVE_SERVER EXPAND=FALSE

  PROCEDURE [XREF] qfp$verify_inactive_server
    (    server_mainframe_id: pmt$binary_mainframe_id;
     VAR server_inactive: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc pmt$binary_mainframe_id
?? POP ??
*DECK DECK=QFP$WAIT_FOR_LEVELER_DEACTIVATE EXPAND=FALSE

  PROCEDURE [XREF] qfp$wait_for_leveler_deactivate
    (    wait_time_sec: ost$non_negative_integers;
     VAR leveler_deactivated: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc osd$integer_limits
?? POP ??
*DECK DECK=QFP$WRITE_JOB_SYSTEM_LABEL EXPAND=FALSE

  PROCEDURE [XREF] qfp$write_job_system_label (
        file_reference: fst$file_reference;
        write_label: boolean;
        system_label: jmt$job_system_label;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jmt$job_system_label
*copyc ost$status
?? POP ??
*DECK DECK=QFP$WRITE_OUTPUT_SYSTEM_LABEL EXPAND=FALSE

  PROCEDURE [XREF] qfp$write_output_system_label (
        file_reference: fst$file_reference;
        write_label: boolean;
        system_label: jmt$output_system_label;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jmt$output_system_label
*copyc ost$status
?? POP ??
*DECK DECK=QFP$WRITE_QFILE_SYSTEM_LABEL EXPAND=FALSE

  PROCEDURE [XREF] qfp$write_qfile_system_label
    (    file_reference: fst$file_reference;
         write_label: boolean;
         system_label: jmt$qfile_system_label;
         application_attributes_size: jmt$qsl_appl_attr_contents_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jme$write_qfile_system_label
*copyc jmt$qfile_system_label
*copyc ost$status
?? POP ??
*DECK DECK=QFV$CURRENT_KJL_LIMIT EXPAND=FALSE

  VAR
    qfv$current_kjl_limit: [XREF, oss$mainframe_pageable] jmt$kjl_index;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$kjl_index
*copyc oss$mainframe_pageable
?? POP ??
*DECK DECK=QFV$CURRENT_KOL_LIMIT EXPAND=FALSE

  VAR
    qfv$current_kol_limit: [XREF, oss$mainframe_pageable] jmt$kol_index;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$kol_index
*copyc oss$mainframe_pageable
?? POP ??
*DECK DECK=QFV$CURRENT_KQL_LIMIT EXPAND=FALSE

  VAR
    qfv$current_kql_limit: [XREF, oss$mainframe_pageable] jmt$kql_index;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$kql_index
*copyc oss$mainframe_pageable
?? POP ??
*DECK DECK=QFV$KJL_LOCK EXPAND=FALSE

  VAR
    qfv$kjl_lock: [XREF] ost$signature_lock;

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??
*DECK DECK=QFV$KOL_LOCK EXPAND=FALSE

  VAR
    qfv$kol_lock: [XREF] ost$signature_lock;

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??

*DECK DECK=QFV$KQL_LOCK EXPAND=FALSE

  VAR
    qfv$kql_lock: [XREF] ost$signature_lock;

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??
*DECK DECK=QFV$LEVELER_READIED EXPAND=FALSE

  VAR
    qfv$leveler_readied: [XREF, oss$mainframe_pageable, READ] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_pageable
?? POP ??
*DECK DECK=QFV$TERMINATE_JOB_ACTION_SET EXPAND=FALSE

  VAR
    qfv$terminate_job_action_set: [XREF] jmt$terminate_job_action_set;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$terminate_job_action
?? POP ??
*DECK DECK=QFXREF EXPAND=FALSE

*copyc QFP$SET_AJL_STATUS
*copyc QFP$UNLINK_AJL_KJL
*copyc QFP$UNLINK_KJL_AJL
*copyc QFP$KJL_RETHREAD

*copyc JMT$AJL_ORDINAL
*copyc JMT$AJL_STATUS
*copyc JMT$KJL_ORDINAL
*copyc JMT$KNOWN_JOB_LIST_ENTRY
*copyc OST$STATUS
*DECK DECK=RAC$COMMAND_LOG_NAME EXPAND=FALSE

  CONST
    rac$command_log_name = 'COMMAND_LOG';
*DECK DECK=RAC$CONTROL_FILE_NAME EXPAND=FALSE

  CONST
    rac$control_file_name = 'RAF$INSTALLATION_CONTROL_FILE';

*DECK DECK=RAC$CONTROL_JOB_IDENTIFIER EXPAND=FALSE

  CONST
    rac$control_job_identifier = 'CONTROL_JOB';
*DECK DECK=RAC$CORRECTION_CONSTANTS EXPAND=FALSE
  CONST
    rac$max_correction_p_elements = 0ffff(16),
    rac$max_psrs = 7fff(16);


*DECK DECK=RAC$ERROR_BASE EXPAND=FALSE

CONST
  rac$error_base = (($INTEGER ('R') * 100(16)) + $INTEGER ('A')) * 1000000(16);
  { Error range is 0 thru 3999.}

*DECK DECK=RAC$IDB_DIRECTORY_LEVEL EXPAND=FALSE

  CONST
    rac$idb_directory_level = 'TRP_ID0001';

*DECK DECK=RAC$IDB_DIRECTORY_NAME EXPAND=FALSE

  CONST
    rac$idb_directory_name = 'RAF$IDB_DIRECTORY';
*DECK DECK=RAC$INDENTATION_SIZE EXPAND=FALSE
*DECK DECK=RAC$INSS_PROCESSOR_VERSION EXPAND=FALSE

  CONST
    rac$inss_processor_version = 'INSS V1.00 1988293';

*DECK DECK=RAC$INSTALLATION_CYCLES EXPAND=FALSE

  { Constant declarations for the installation cycles. }

  CONST
    rac$loading_cycle = 1;

  CONST
    rac$loading_cycle_str = '1';

  CONST
    rac$max_active_cycle = pfc$maximum_cycle_number;

  CONST
    rac$staging_cycle = 2;

  CONST
    rac$staging_cycle_str = '2';


*copyc pfd$permanent_file_definitions
*DECK DECK=RAC$LINE_INDENT EXPAND=FALSE

CONST
  rac$line_indent = 24;


*DECK DECK=RAC$LOCAL_PRIMARY_TAPE EXPAND=FALSE

  CONST
    rac$local_primary_tape = '$LOCAL.RAF$PRIMARY_TAPE_';

{   The local file path is created by taking constant path }
{   value and appending the primary tape vsn for the tape. }
*DECK DECK=RAC$MAX_DECKS EXPAND=FALSE
  CONST
    rac$max_decks = 0ffff(16);

*DECK DECK=RAC$MAX_LINE EXPAND=FALSE

  CONST
    rac$max_line = 79;
*DECK DECK=RAC$MAX_LINE_SIZE EXPAND=FALSE

CONST
  rac$max_line_size = 72;


*DECK DECK=RAC$MAX_PATH_SIZE EXPAND=FALSE

CONST
  rac$max_path_size = 256;


*DECK DECK=RAC$MAX_PERMIT_OPTION_INDEX EXPAND=FALSE

CONST
  rac$max_permit_option_index = 10;

*DECK DECK=RAC$NOT_ASSIGNED EXPAND=FALSE

CONST
  rac$not_assigned = 0;
*DECK DECK=RAC$NOT_INSTALLED EXPAND=FALSE

CONST
  rac$not_installed = osc$null_name;

*copyc ost$name

*DECK DECK=RAC$ORDER_DATA_FILE_NAME EXPAND=FALSE

  CONST
    rac$order_data_file_name = 'RAF$ORDER_DATA                 ';
*DECK DECK=RAC$PACKING_LIST_LEVEL EXPAND=FALSE

  CONST
    rac$packing_list_level = 'TRP_PL0004';

*DECK DECK=RAC$PACKING_LIST_NAME EXPAND=FALSE

  CONST
    rac$packing_list_name = 'RAF$PACKING_LIST               ';
*DECK DECK=RAC$PACS_PROCESSOR_VERSION EXPAND=FALSE

  CONST
    rac$pacs_processor_version = 'PACS V1.01 1989166';
*DECK DECK=RAC$PROCESS_ID EXPAND=FALSE

CONST
  rac$process_id = 'RA';

*DECK DECK=RAC$SIF_FILE_NAME EXPAND=FALSE

  CONST
    rac$sif_file_name = 'RAF$SUBPRODUCT_INFORMATION_FILE';
*DECK DECK=RAC$SPECIAL_PRODUCT_DESIGNATORS EXPAND=FALSE

  {  These special designators can precede name values in the additional
  {  products field of a subproduct.  Each special designator is used for
  {  a different purpose according to the following list:
  {
  {     #   Specifies a group name.  A group name groups common subproducts.
  {         Although not advertised, it is possible to install a set of
  {         subproducts by specifying the group to which they all belong.
  {         Examples of current groups are CDCNET_SOFTWARE and IM_DM_PACKAGE.
  {
  {     $   Specifies a PSR identifier.
  {
  {     \   Used internally for various purposes.  Each name which this
  {         designator is associated with defines the purpose.  As an
  {         example, \IMMEDIATE indiciates that the subproduct must be
  {         installed in immediate mode, rather than deferred mode.
  {

  CONST
    rac$group_designator ='#',
    rac$psrid_designator = '$',
    rac$special_use_designator = '\';
*DECK DECK=RAC$STATUS_CONDITION EXPAND=FALSE
  CONST
    rac$status_condition = rac$error_base + 1000;

*copyc rac$error_base
*DECK DECK=RAC$STATUS_ID EXPAND=FALSE
  CONST
    rac$status_id = 'RA';

*DECK DECK=RAC$SUBPRODUCT_INFO_LEVEL EXPAND=FALSE

{ NOTE:
{   When incrementing this level (due to SIF structure changes) you must
{   also increment the packing list level.  This is because the SIF is part
{   of the packing list structure.  The packing list level is found in the
{   deck RAC$PACKING_LIST_LEVEL.
{

  CONST
    rac$subproduct_info_level = 'TRP_SI0004';

*DECK DECK=RAC$SUMMARY_FILE_LEVEL EXPAND=FALSE

  CONST
    rac$summary_file_level = 'TRP_PS0000';

*DECK DECK=RAC$SUMMARY_FILE_NAME EXPAND=FALSE

  CONST
    rac$summary_file_name = 'RAF$PROCESSING_SUMMARY_FILE';
*DECK DECK=RAC$TAPE_TYPES EXPAND=FALSE

  CONST
    rac$mt9$1600 = 'MT9$1600',
    rac$mt9$6250 = 'MT9$6250',
    rac$mt18$38000 = 'MT18$38000';

*DECK DECK=RAC$UNDEFINED_INST_PATH_ELEMENT EXPAND=FALSE

  CONST
    rac$undefined_inst_path_element = '$UNDEFINED';
*DECK DECK=RAC$UPGRADE_SYSTEM_VERSION EXPAND=FALSE

CONST
  rac$upgrade_system_version = ' UPGRADE_SOFTWARE_VERSION_04';

*DECK DECK=RAE$CONDITION_CODES EXPAND=FALSE
{ The condition codes have been subdivided into other
{ decks that are expanded into this deck.

*copyc rac$error_base

*copy rae$install_software_cc
*copy rae$package_software_cc
*copy rae$system_initiation_cc
*copy rae$prompt_and_message_cc
*copy rae$general_cc

*DECK DECK=RAE$ERROR_MESSAGES EXPAND=FALSE

*copyc rac$status_condition

  CONST
    rae$element_not_found = rac$status_condition + 10,
{E Element +P not found in correction package.}

    rae$element_not_entered = rac$status_condition + 20,
{F Element +P not entered into correction package.}

    rae$no_correction = rac$status_condition + 30,
{E No correction for element +P.}

    rae$user_info_unchanged = rac$status_condition + 40,
{I User information attribute for Element +P unchanged, no correction generated.}

    rae$correction_mismatch = rac$status_condition + 50,
{F Invalid correction for object_library +P.}

    rae$error_in_object_library = rac$status_condition + 60,
{F Object library +P generated with +P is invalid.}

    rae$no_correction_generated = rac$status_condition + 70,
{I Element +P has format +P, no correction generated.}

    rae$blank_user_info = rac$status_condition + 80,
{I User information attribute for file +P is blank, no correction generated.}

    rae$files_unchanged = rac$status_condition + 90,
{I Element +P unchanged, no correction generated.}

    rae$cor_package_not_generated = rac$status_condition + 100,
{W Exiting PACKAGE_CORRECTIONS utility without generating current correction package.}

    rae$no_current_correction = rac$status_condition + 110,
{E No current correction package.}

    rae$element_not_in_install_tble = rac$status_condition + 120,
{E Element +P not in the installation table.}

    rae$invalid_cp_version = rac$status_condition + 130,
{E Invalid Correction Package version on file +P.}

    rae$file_not_correction_package = rac$status_condition + 140,
{E File +P is not a Correction Package.}

    rae$no_correction_package = rac$status_condition + 150,
{E No corrections on current correction package.}

    rae$element_class_is_os = rac$status_condition + 160,
{E File +P is class OS, must specify element OS.}

    rae$open_file_list_full = rac$status_condition + 170,
{E Internal error - The open file list is full.}

    rae$generate_terminated = rac$status_condition + 180,
{E Command terminated - correction not generated.}

    rae$element_class_not_supported = rac$status_condition + 190,
{E Element +P is has class +P, correction not generated.}

    rae$element_format_is_prelinked = rac$status_condition + 200,
{E Element +P has format PRELINKED_OL, correction not generated.}

    rae$file_not_correct_format = rac$status_condition + 500,
{E File +P is not a +P.}

    rae$applier_already_exists = rac$status_condition + 510,
{E There already exists an applier on the correction package +P.}

    rae$applier_copied_to_lfn = rac$status_condition + 520,
{I The APPLIER found on correction package +P is being copied to $LOCAL.APPLIER.$EOI for examination.}

    rae$accessed_beyond_segment = rac$status_condition + 530,
{E Attempted access beyond segment in file +P.}

    rae$applier_not_present = rac$status_condition + 540;
{E There is no APPLIER on the correction package +P.}
*DECK DECK=RAE$GENERAL_CC EXPAND=FALSE
*copyc rac$error_base
?? NEWTITLE := 'RAE$GENERAL_CC  ------  2000 .. 3999', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    rac$min_general_cc = rac$error_base + 2000,

    rae$vsn_param_required = rac$min_general_cc + 5,
    {E One or both of the tape VSN parameters must be specified. }

    rae$unable_to_add_formatted_pp = rac$min_general_cc + 10,
    {E An error occurred while attempting to add formated PP +P1 to non_boot_drivers. }

    rae$not_all_files_processed = rac$min_general_cc + 15,
    {E Not all the formatted PPs were added to non_boot_drivers file +P1. }

    rae$must_initiate_from_system = rac$min_general_cc + 20,
    {E Job +P1 must be initated from a system job. }

    rae$profile_not_present = rac$min_general_cc + 25,
    {E The base profile must be created prior to running this command. }

    rae$invalid_site_class = rac$min_general_cc + 30,
    {W Site class +P1 in not valid for your system.  The remainder of the site classes will be processed. }

    rac$max_general_cc = rac$min_general_cc + 1999;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??

*DECK DECK=RAE$INSTALL_SOFTWARE_CC EXPAND=FALSE
*copyc rac$error_base
?? NEWTITLE := 'RAE$INSTALL_SOFTWARE_CC  ------  0 .. 799', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    rac$min_install_software_cc = rac$error_base,

    rae$no_parameters_specified = rac$min_install_software_cc + 5,
    {E No parameters were specified.}

    rae$loapl_params_specifying_err = rac$min_install_software_cc + 10,
    {E The DISK_FILE parameter cannot be specified when either of the tape VSN }
    {  parameters have been specified. }

    rae$disk_or_vsns_params_requird = rac$min_install_software_cc + 15,
    {E One or both of the tape VSN parameters or the DISK_FILE parameter must be specified.}

    rae$pl_loading_error_occurred = rac$min_install_software_cc + 20,
    {E An error occurred while attempting to load the packing list. }
    {  See $JOB_LOG for more information. }

    rae$pl_path_already_being_used = rac$min_install_software_cc + 25,
    {E The packing list destination +F1 is already being used as a file or catalog. }

    rae$pl_cannot_load_to_local_cat = rac$min_install_software_cc + 30,
    {E The packing list cannot be loaded into the $LOCAL catalog. }

    rae$access_error_verifying_pl = rac$min_install_software_cc + 35,
    {E The loaded file is an invalid packing list. }
    {  Accessed beyond end of segment error encountered. }

    rae$not_a_packing_list = rac$min_install_software_cc + 40,
    {E The +F1 does not contain a valid packing list. }

    rae$accessed_beyond_segment_eoi = rac$min_install_software_cc + 45,
    {E Accessed beyond end of the +P1 segment while nexting +P2. }

    rae$invalid_packing_list = rac$min_install_software_cc + 50,
    {E Accessed an invalid packing list file (+P1), in the Installation Database catalog, +F2. }

    rae$invalid_idb_directory = rac$min_install_software_cc + 55,
    {E Accessed an invalid IDB directory file (+P1), in the Installation Database catalog, +F2. }

    rae$invalid_summary_file = rac$min_install_software_cc + 60,
    {E Accessed an invalid processing summary file (+P1), in the Installation Identifier catalog, +F2. }

    rae$unexpected_eof_packing_list = rac$min_install_software_cc + 65,
    {E Unexpected end of file encountered accessing the packing list file (+P1), }
    {  in the Installation Database catalog, +F2. }

    rae$unexpected_eof_directory = rac$min_install_software_cc + 70,
    {E Unexpected end of file encountered accessing the IDB directory file (+P1), }
    {  in the Installation Database catalog, +F2. }

    rae$unexpected_eof_summary_file = rac$min_install_software_cc + 75,
    {E Unexpected end of file encountered accessing the processing summary file (+P1), }
    {  in the Installation Identifier catalog, +F2. }

    rae$incompatible_sequence_level = rac$min_install_software_cc + 80,
    {E Unable to read +P1 at level +P2. }

    rae$different_processor_version = rac$min_install_software_cc + 85,
    {I Processor version used to access +P1 is not the same as the processor version }
    {  used to create +P1. }

    rae$unknown_product_name = rac$min_install_software_cc + 90,
    {E Product +P1 is unknown to the packing list. }

    rae$specified_names_and_key_all = rac$min_install_software_cc + 95,
    {E When the keyword ALL is specified no other product names are allowed. }

    rae$validation_errors_occurred = rac$min_install_software_cc + 100,
    {E Validation errors occurred while processing the +P1 parameter. }
    {  See job log. }

    rae$install_path_not_defined = rac$min_install_software_cc + 105,
    {E The installation path for subproduct +P1 of licensed product +P2 is not defined. }
    {  Unable to install until defined using CHANGE_INSTALLATION_PATH subcommand. }

    rae$unable_to_reconcile_cycles = rac$min_install_software_cc + 110,
    {E Unable to reconcile cycle conflicts for file +F1. }

    rae$insufficient_min_ring = rac$min_install_software_cc + 115,
    {E User's minimum ring is insufficient for setting rings for file +F1. }

    rae$permits_do_not_agree = rac$min_install_software_cc + 120,
    {W Existing and desired public permits do not agree for file +F1. }
    {  Existing permit is left unchanged.                             }

    rae$unreadable_idb_directory = rac$min_install_software_cc + 125,
    {E The installation database file is not readable. }

    rae$subproducts_rejected = rac$min_install_software_cc + 130,
    {I +P1 of the subproducts for +P2 +P3 will not be installed.  See job log. }

    rae$subproduct_installed = rac$min_install_software_cc + 135,
    {I Subproduct +P1 of +P2 +P3 is currently installed at this level. }

    rae$no_software_to_install = rac$min_install_software_cc + 140,
    {I No software will be installed.  See job log for details. }

    rae$file_deletion_errors = rac$min_install_software_cc + 145,
    {E Errors encountered deleting previous file cycles. }

    rae$family_or_user_param_reqrd = rac$min_install_software_cc + 150,
    {E One or both of the FAMILY_NAME or the USER_NAME parameters must be specified. }

    rae$inst_path_not_definable = rac$min_install_software_cc + 155,
    {E The installation path for subproduct +P is not definable. }

    rae$sip_family_not_definable = rac$min_install_software_cc + 160,
    {E The family catalog of the installation path for subproduct +P is not definable. }

    rae$sip_user_not_definable = rac$min_install_software_cc + 165,
    {E The user catalog of the installation path for subproduct +P is not definable. }

    rae$no_path_changes_made = rac$min_install_software_cc + 170,
    {I No subproduct installation path changes were made for +P1 +P2. }
    {  None of the associated subproducts conformed to the specified change. }

    rae$correction_mismatch = rac$min_install_software_cc + 175,
    {E Invalid correction for object_library +P1. }

    rae$error_in_object_library = rac$min_install_software_cc + 180,
    {E Result of applying correction +F1 to object library +F2 produced an invalid library. }

    rae$cannot_install_correction = rac$min_install_software_cc + 185,
    {I The correction for subproduct +P1 of +P2 +P3 cannot be installed, }
    {  since the subproduct is not active or not known to the IDB Directory. }

    rae$correction_not_applicable = rac$min_install_software_cc + 190,
    {I The correction for subproduct +P1 of +P2 +P3 will not be installed, }
    {  because the release level of the subproduct in the IDB Directory    }
    {  does not match the level required for the correction. }

    rae$subproduct_already_deferred = rac$min_install_software_cc + 195,
    {I Subproduct +P1 of +P2 +P3 will not be re-installed, because it is }
    {  currently installed deferred. }

    rae$subproducts_failed_install = rac$min_install_software_cc + 200,
    {W One or more subproducts failed to install.  See job log. }

    rae$deferred_subproduct_cleared = rac$min_install_software_cc + 205,
    {W Subproduct +P1 (level +P2) of licensed product +P3 was previously }
    {  installed deferred, but has now been cleared due to current       }
    {  installation. }

    rae$directory_required_for_corr = rac$min_install_software_cc + 210,
    {E The IDB Directory (+F1) was not found.  It is required to install }
    {  corrections. }

    rae$incompatible_software = rac$min_install_software_cc + 215,
    {E There were no products of type +P1 found in the packing list +P2. }
    {  No software will be installed. }

    rae$no_deferred_subproducts = rac$min_install_software_cc + 220,
    {E No deferred subproducts found in IDB Directory, no action taken. }

    rae$subproduct_not_deferred = rac$min_install_software_cc + 225,
    {E Subproduct +P1 of licensed product +P2 is not currently deferred. }

    rae$subproduct_not_in_directory = rac$min_install_software_cc + 230,
    {E Subproduct +P1 is not in the IDB Directory. }

    rae$file_not_deferred = rac$min_install_software_cc + 235,
    {E File +F1 is not currently deferred. }

    rae$correction_validation_errs = rac$min_install_software_cc + 240,
    {E During validation of the correction base files and preparing for correction installation,}
    {  one or more files were missing.  See job_log for details.}

    rae$prev_version_corr_missing = rac$min_install_software_cc + 245,
    {I Previously corrected file +F1, which was to be used to avoid applying a correction to file +F2 of }
    {  subproduct +P2, is not present on the system.  The correction will applied.}

    rae$corr_base_cat_file_missing = rac$min_install_software_cc + 250,
    {E File +F1, required as the correction base for file +F2, is missing from the
    {  correction bases catalog for subproduct +P3.}

    rae$base_file_missing = rac$min_install_software_cc + 255,
    {I File +F1, which was to be corrected as part of subproduct +P2, is missing. }
    {  The correction to this subproduct will not be installed.}

    rae$previous_corr_packlist_gone = rac$min_install_software_cc + 260,
    {I Due to the above error, previous corrections for the subproducts referenced by the }
    {  inaccessible packing list cannot be used. }

    rae$previous_corr_packlist_bad  = rac$min_install_software_cc + 265,
    {I Unable to use previous corrections for subproduct +P1 because packing list }
    {  +P2 no longer contains the expected contents. }

    rae$prev_corr_checksum_mismatch = rac$min_install_software_cc + 270,
    {E The contents checksum of the previously corrected file +F1 did not match the expected value. }
    {  Try installing the correction again specifying this subproduct on the PRODUCT parameter.     }

    rae$corr_base_checksum_mismatch = rac$min_install_software_cc + 275,
    {E The contents checksum for correction base file +F1 did not match the expected value. }

    rae$directory_moved = rac$min_install_software_cc + 280,
    {I New directory created due to incompatibility with existing directory. }
    {  Directory saved in file +F1. }

    rae$subp_installed_as_corr_base = rac$min_install_software_cc + 285,
    {I Subproduct +P1 of +P2 +P3 will not be re-installed because it is }
    {  currently installed with corrections. }

    rae$no_products_found = rac$min_install_software_cc + 290,
    {I None of the products specified on the PRODUCT parameter were }
    {  found in the directory. }

    rae$product_not_in_directory = rac$min_install_software_cc + 295,
    {I Product +P1 specified on the PRODUCT parameter was not found }
    {  in the directory. }

    rae$linker_errors_occurred = rac$min_install_software_cc + 300,
    {E Linker errors occurred during execution of installer procedures }
    {  for subproduct NOSVE_MAINTENANCE - No deadstart tape created. }

    rae$cannot_delete_packing_list = rac$min_install_software_cc + 305,
    {E Cannot delete the packing list because it could not be found }
    {  in the installation catalog. }

    rae$pl_file_not_returned = rac$min_install_software_cc + 310,
    {E LOAD_PACKING_LIST failed due to the previous packing list file +P }
    { not being detached.  Detach this file before executing LOAD_PACKING_LIST.}

    rac$max_install_software_cc = rac$min_install_software_cc + 799;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??

*DECK DECK=RAE$MAINTAIN_DEADSTART_SW_CC EXPAND=FALSE
*copyc rac$error_base
?? NEWTITLE := 'RAE$MAINTAIN_DEADSTART_SW_CC  ------  900 .. 999', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    rac$min_maids_cc = rac$error_base + 900,

    rae$vsn_param_required = rac$min_maids_cc + 5,
    {E One or both of the tape VSN parameters must be specified. }

    rae$unable_to_add_formatted_pp = rac$min_maids_cc + 10,
    {E An error occurred while attempting to add formated PP +P1 to non_boot_drivers. }

    rae$not_all_files_processed = rac$min_maids_cc + 15,
    {E Not all the formatted PPs were added to non_boot_drivers file +P1. }

    rae$must_initiate_from_system = rac$min_maids_cc + 20,
    {E Job +P1 must be initated from a system job. }

    rae$profile_not_present = rac$min_maids_cc + 25,
    {E The base profile must be created prior to running this command. }

    rae$invalid_site_class = rac$min_maids_cc + 30,
    {W Site class +P1 is not valid for your system.  The remainder of the site classes will be processed. }

    rac$max_maids_cc = rac$min_maids_cc + 99;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??

*DECK DECK=RAE$PACKAGE_SOFTWARE_CC EXPAND=FALSE
*copyc rac$error_base
?? NEWTITLE := 'RAE$PACKAGE_SOFTWARE_CC  ------  800 .. 1599', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    rac$min_package_software_cc = rac$error_base + 800,

    rae$invalid_pacs_catalog = rac$min_package_software_cc + 5,
    {E The catalog +F1 is an invalid PACS catalog.}

    rae$param_required_for_corr = rac$min_package_software_cc + 10,
    {E Parameter +P1 is required when the subproduct TYPE is defined as a correction.}

    rae$cannot_use_local_catalog = rac$min_package_software_cc + 15,
    {E $LOCAL catalog cannot be used for +P1.}

    rae$invalid_installation_path = rac$min_package_software_cc + 20,
    {E Invalid installation path +F1.}

    rae$invalid_inst_path_with_opt = rac$min_package_software_cc + 25,
    {E Installation path +F2 does not conform to the installation path option of +P1.}

    rae$not_in_pacs_catalog = rac$min_package_software_cc + 30,
    {E +F1 must reside under the PACS catalog.}

    rae$no_permits_allowed = rac$min_package_software_cc + 35,
    {E No permits are allowed on +F1.}

    rae$no_private_permits_allowed = rac$min_package_software_cc + 40,
    {E No private permits allowed on +F1.}

    rae$warning_public_permits = rac$min_package_software_cc + 45,
    {W Public permits are defined for +F1.}

    rae$cycle_not_empty = rac$min_package_software_cc + 50,
    {E Cycle +P1 of file +F2 must be empty.}

    rae$loading_cycle_empty = rac$min_package_software_cc + 55,
    {E The loading cycle of file +F2 does not exist.}

    rae$loading_cycle_only = rac$min_package_software_cc + 60,
    {E Only Cycle +P1 of file +F2 is allowed.}


    rae$ring_value_too_low = rac$min_package_software_cc + 65,
    {E The ring values on file +F2 must not be lower than +P1.}

    rae$invalid_product_name = rac$min_package_software_cc + 70,
    {E +P1 is an invalid product name.}

    rae$invalid_installer_proc = rac$min_package_software_cc + 75,
    {E The command path +F1 references an invalid installer procedure.}

    rae$non_standard_master_catalog = rac$min_package_software_cc + 80,
    {W The master catalog +P1 is not the standard $SYSTEM or $UNDEFINED }
    {  definition for an installation path, but will be accepted. }

    rae$pacs_catalog_contains_sif = rac$min_package_software_cc + 85,
    {E The PACS catalog +F1 already contains a SUBPRODUCT INFORMATION FILE. }
    {  The file +P2 must be deleted before attempting to define the subproduct. }

    rae$bad_master_catalog_for_lib = rac$min_package_software_cc + 90,
    {E Library +F1 must have a master catalog of :$SYSTEM.$SYSTEM or +P2 }
    {  (which is the master catalog of the installation path). }

    rae$expecting_file = rac$min_package_software_cc + 95,
    {E Found catalog +F1;  expecting file. }

    rae$expecting_catalog = rac$min_package_software_cc + 100,
    {E Found file +F1;  expecting catalog. }

    rae$subproduct_not_defined = rac$min_package_software_cc + 105,
    {E The subproduct is not correctly defined.  See $ERRORS for errors. }

    rae$command_defsa_required = rac$min_package_software_cc + 110,
    {E The DEFINE_SUBPRODUCT_ATTRIBUTES command must complete successfully}
    {  before this command may be called. }

    rae$attribute_required = rac$min_package_software_cc + 115,
    {E +P1 required for file +F2. }

    rae$accessed_beyond_memory_seg = rac$min_package_software_cc + 120,
    {E Attempted access beyond segment in memory. }

    rae$inst_catalog_not_defined = rac$min_package_software_cc + 125,
    {E The INSTALLATION PATH CATALOG has not been defined. }

    rae$type_already_specified = rac$min_package_software_cc + 135,
    {E Subproduct +P1 of type +P2 already exists in this order.}

    rae$incorrect_value_for_corr_ch = rac$min_package_software_cc + 140,
    {E CORRECTION_CHOSEN cannot be set to TRUE for a subproduct  }
    {  of type RELEASE.}

    rae$file_is_not_a_sif = rac$min_package_software_cc + 145,
    {E +F1 is not a valid SUBPRODUCT INFORMATION FILE. }

    rae$version_level_mismatch = rac$min_package_software_cc + 150,
    {I This +P1 was created by a processor at a different level. }

    rae$sif_mismatch = rac$min_package_software_cc + 155,
    {E The specified +P1 does not agree with the SUBPRODUCT_INFORMATION_FILE. }

    rae$invalid_date_level = rac$min_package_software_cc + 160,
    {E +P1 is an invalid date level.}

    rae$invalid_format_for_file = rac$min_package_software_cc + 165,
    {E Invalid correction format for +P1.}

    rae$no_subproducts_ordered = rac$min_package_software_cc + 170,
    {E No subproducts have been ordered.}

    rae$tape_attributes_not_defined = rac$min_package_software_cc + 175,
    {E The DEFINE_TAPE_ATTRIBUTES command must complete successfully}
    {  before this command may be called. }

    rae$expecting_packing_list = rac$min_package_software_cc + 180,
    {E The packing list was expected to be the first item in the }
    {  order contents list.}

    rae$exceeded_max_size_disk_ordr = rac$min_package_software_cc + 185,
    {E The maximum file size for a disk order has been exceeded.}

    rae$parameter_disk_or_vsn_req = rac$min_package_software_cc + 190,
    {E Either DISK_FILE or EVSN must be specified.}

    rae$only_one_param_disk_or_vsn = rac$min_package_software_cc + 195,
    {E Both DISK_FILE and EVSN cannot be specified.}

    rae$medium_and_param_mismatch = rac$min_package_software_cc + 200,
    {E The order medium was defined as +P1, but parameter +P2 was specified.}

    rae$invalid_vsn_list = rac$min_package_software_cc + 205,
    {E The EVSN list contains an invalid entry or entries.}

    rae$order_medium_not_tape = rac$min_package_software_cc + 210,
    {E The order medium was not defined as TAPE.}

    rae$exceeded_max_tapes_allowed  = rac$min_package_software_cc + 215,
    {E The maximum number of tapes (+P1), has been exceeded.}

    rae$warn_pacs_catalog_empty = rac$min_package_software_cc + 220,
    {W The PACS CATALOG is an empty catalog.}

    rae$error_pacs_catalog_empty = rac$min_package_software_cc + 225,
    {E The PACS CATALOG is an empty catalog.}

    rae$unable_to_validate_lib_merg = rac$min_package_software_cc + 230,
    {W Unable to validate the library merge parameters at this time. }
    {  The parameters will be validated at the end of the DEFINE SUBPRODUCT }
    {  session. }

    rae$define_order_not_called = rac$min_package_software_cc + 235,
    {E The DEFINE_ORDER command must complete successfully before this command}
    {  may be called.}

    rae$logging_not_allowed = rac$min_package_software_cc + 240,
    {E Logging is not allowed for file +F1.}

    rae$file_missing_from_pacs = rac$min_package_software_cc + 245,
    {E File +F1 is missing from the PACS catalog.

    rae$catalog_missing_from_pacs = rac$min_package_software_cc + 250,
    {E Catalog +F1 is missing from the PACS catalog.

    rae$extra_file_in_pacs = rac$min_package_software_cc + 255,
    {E Extra file +F1 found in the PACS catalog.

    rae$extra_catalog_in_pacs = rac$min_package_software_cc + 260,
    {E Extra catalog +F1 found in the PACS catalog.

    rae$unable_to_compare_checksums = rac$min_package_software_cc + 265,
    {E Subproduct +P1 in PACS catalog +P2 cannot be verified because}
    {  the subproduct definition was created with file checksumming}
    {  disabled.}

    rae$attributes_checksum_changed = rac$min_package_software_cc + 270,
    {E The file attributes of +F1 have changed.}

    rae$contents_checksum_changed = rac$min_package_software_cc + 275,
    {E The file contents of +F1 have changed.}

    rae$mod_date_time_changed = rac$min_package_software_cc + 280,
    {E According to the last modification date and time, +F1 has changed.}

    rae$pacs_catalog_name_changed = rac$min_package_software_cc + 285,
    {E The PACS catalog is registered as +F1 in the SUBPRODUCT INFORMATION
    {  FILE.  This error condition may be cleared by running VERIFY_SUBPRODUCT}
    {  with the VERIFY_OPTION parameter set to the keyword }
    {  RECONCILE_EFFECTS_OF_RESTORE. }

    rae$pacs_does_not_verify = rac$min_package_software_cc + 290,
    {E The PACS catalog +F2 has changed since subproduct +P1 was defined.}

    rae$pacs_verify_successful = rac$min_package_software_cc + 295,
    {I Verification of PACS catalog +F1 completed successfully.}

    rae$pacs_catalog_moved = rac$min_package_software_cc + 300,
    {E Verification of subproduct +P1 indicates that the PACS}
    {  catalog has been moved from +P2 to +F3, but its contents}
    {  have not changed.  This error condition can be cleared by}
    {  executing VERIFY_SUBPRODUCT with the VERIFY_OPTION parameter}
    {  set to the keyword RECONCILE_EFFECTS_OF_RESTORE. }

    rae$pacs_files_restored = rac$min_package_software_cc + 305,
    {E Verification of subproduct +P1 indicates that the date}
    {  and time of last modification for some files in the PACS}
    {  catalog have changed, probably due to file restoration.}
    {  This error condition can be cleared by executing }
    {  VERIFY_SUBPRODUCT with the VERIFY_OPTION parameter set}
    {  to the keyword RECONCILE_EFFECTS_OF_RESTORE.}

    rae$command_wrid_required = rac$min_package_software_cc + 310,
    {W The subcommand WRITE_DEFINITION was not called successfully.}
    {  The previous CREATE_ORDER_DEFINITION subcommands have not}
    {  been saved.}

    rae$command_defo_required = rac$min_package_software_cc + 315,
    {E The DEFINE_ORDER command must be called successfully before }
    {  ADD_SUBPRODUCT may be called.}

    rae$file_never_opened = rac$min_package_software_cc + 320,
    {E File +F1 has never been opened.  Unopened files are not}
    {  allowed in the PACS catalog.}

    rae$tape_file_param_incorrect = rac$min_package_software_cc + 325,
    {E The TAPE_FILE parameter may not be specified on a DISK order.}

    rae$file_missing_from_order_cat = rac$min_package_software_cc + 330,
    {E File +P1 is missing from the order catalog.}

    rae$inst_proc_not_in_pacs_cat = rac$min_package_software_cc + 335,
    {W File +F1 is not a file in the PACS catalog.}

    rae$sif_version_changed = rac$min_package_software_cc + 340,
    {E File +F1 is incompatible with this version of the}
    { PACKAGE_SOFTWARE utility.}

    rae$disk_file_cannot_be_catalog = rac$min_package_software_cc + 345,
    {E The CATALOG +F1 was specified for the disk_file parameter.}
    {  Please specify a FILE for the disk_file parameter.}

    rae$genc_not_called = rac$min_package_software_cc + 350,
    {W GENERATE_CORRECTION has not been called successfully.}
    {  The previous DEFINE_CORRECTION command has been lost.}

    rae$wrong_order_for_creation = rac$min_package_software_cc + 355,
    {E The creation date for the base PACS catalog +P1 MUST be before the creation date of
    { the current PACS catalog +P2.}

    rae$unequal_element_count = rac$min_package_software_cc + 360,
    {E The base PACS catalog +P1 has a different number of elements than the current PACS catalog +P2.}

    rae$unmatched_elements = rac$min_package_software_cc + 365,
    {E The base level and current level PACS catalogs do NOT contain the same elements.}
    {+N0 First element paths to differ: +N0 +P1 from the base PACS catalog and }
    {+N0 +P2 from the current PACS catalog.}

    rae$attributes_checksum_differ = rac$min_package_software_cc + 370,
    {I The attributes checksum at the base level PACS catalog does NOT equal the attributes
    { checksum at the current level PACS catalog for file +P1.}

    rae$correction_format_warning = rac$min_package_software_cc + 375,
    {W File +P1 has a correction format of REPLACEMENT at the base level, but a}
    {  correction format of +P2 at the current level.  This is not allowed.  The new }
    {  correction format has automatically been changed to REPLACEMENT.}

    rae$correction_format_error = rac$min_package_software_cc + 380,
    {E The CORRECTION FORMAT of file +P1 cannot be changed from +P2 to +P3.)

    rae$unmatched_attribute = rac$min_package_software_cc + 385,
    {E The base and current level PACS catalogs must define the same +P1.}
    {  The base PACS catalog +P2 contains +P1 +P3, but current PACS catalog +P4 contains +P1 +P5.}

    rae$unmatched_dependencies = rac$min_package_software_cc + 390,
    {E PACS catalog +P1 contains different dependencies than PACS catalog +P2.}
    {+N0 Possible unmatched dependencies are: +N0 +P3 +N0 +P4}

    rae$no_contents_checksum = rac$min_package_software_cc + 395,
    {E PACS catalog +P1 was NOT created with checksums enabled.}

    rae$incorrect_name_parameter = rac$min_package_software_cc + 400,
    {E The NAME parameter was specified as +P1, but the subproduct name
    { registered in the +P2 PACS catalog +P3 is +P4.}

    rae$wrong_subproduct_type = rac$min_package_software_cc + 405,
    {E PACS catalog +P1 must be of type RELEASE.}

    rae$incorrect_previous_corr = rac$min_package_software_cc + 410,
    {E The previous correction was NOT created using CREATE SUBPRODUCT CORRECTION.  ALL previous corrections
    { must be created using CREATE SUBPRODUCT CORRECTION.}

    rae$different_base_catalog = rac$min_package_software_cc + 415,
    {E The previous correction was created from a different base level PACS catalog.}

    rae$defc_command_not_called = rac$min_package_software_cc + 420,
    {E The DEFINE CORRECTION command must complete successfully before +P1 is called.}

    rae$incorrect_inst_scheme = rac$min_package_software_cc + 425,
    {E The installation scheme cannot be changed from CYCLE BASED to VERSION BASED.}

    rae$unable_to_read_psr_line = rac$min_package_software_cc + 430,
    {E The PSR input file is unreadable.}

    rae$psr_entered_twice = rac$min_package_software_cc + 435,
    {W PSR +P1 was entered twice.}

    rae$duplicate_psr = rac$min_package_software_cc + 440,
    {W PSR +P1 is a duplicate of a psr entered at a previous level.}

    rae$no_corrections_generated = rac$min_package_software_cc + 445,
    {W No changes were found for the current level subproduct +P1. }
    {  Therefore no correction was generated.}

    rae$correction_format_changed = rac$min_package_software_cc + 450,
    {W CREATE_SUBPRODUCT_CORRECTION does not allow a file to be changed from}
    {  a base level of replacement to a current level of +P2.}
    {  The correction format for file +F1 has been set to replacement for the this correction.}

    rae$no_modules_on_library = rac$min_package_software_cc + 455,
    {E No modules on library +P1.}

    rae$identification_not_first = rac$min_package_software_cc + 460,
    {E Identification record not first in interpretive_element on library +P1.}

    rae$debug_tables_on_library = rac$min_package_software_cc + 465,
    {E Debug tables found on object library +P1.}

    rae$no_section_maps = rac$min_package_software_cc + 470,
    {E Bound module +P1 generated without section maps on library +P2.}

    rae$invalid_info_version = rac$min_package_software_cc + 475,
    {E Invalid information element version on library +P1.}

    rae$element_format_is_prelinked = rac$min_package_software_cc + 480,
    {E Element +P1 has format PRELINKED_OL, correction not generated.}

    rae$file_not_correct_format = rac$min_package_software_cc + 485,
    {E File +P1 is not a +P2.}

    rae$accessed_beyond_segment = rac$min_package_software_cc + 490,
    {E Attempted access beyond segment in file +P1.}

    rae$sif_identifier_changed = rac$min_package_software_cc + 495,
    {E The order for subproduct +P1 was created with a different subproduct information file.}
    { You must rerun CREATE_ORDER_DEFINITION before writing this order.}

    rae$corr_must_be_cycle_based = rac$min_package_software_cc + 500,
    {E When defining a subproduct correction with DEFINE_SUBPRODUCT, the}
    { INSTALLATION_SCHEME must be CYCLE_BASED.}

    rae$must_be_primary_subproduct = rac$min_package_software_cc + 505,
    {E Whenever the subproduct name and licensed product name match, the}
    { subproduct must also be a PRIMARY_SUBPRODUCT.}

    rae$psr_format_error = rac$min_package_software_cc + 510,
    {E A PSR name can contain only numerals and letters.  It must be +P1}
    { characters long and begin with a letter. +N0 PSR +P2 does not conform}
    { to these rules.}

    rae$incorrect_verify_option = rac$min_package_software_cc + 515,
    {E +P1 is an incorrect verify option.}

    rae$defcf_command_ignored = rac$min_package_software_cc + 520,
    {I The DEFINE_CORRECTION_FORMAT command is ignored when the }
    {  subproduct is defined as type correction.}
    {  All files are automatically set to a correction of REPLACEMENT.}

    rae$defpa_command_not_allowed = rac$min_package_software_cc + 525,
    {E The DEFINE_PSRS_ANSWERED command cannot be used when the}
    {  subproduct is defined as type release.}

    rae$levels_cannot_be_same = rac$min_package_software_cc + 530,
    {E The base subproduct level (+P1), cannot be equal to the current}
    {  subproduct level (+P2).}

    rae$defsa_command_not_allowed = rac$min_package_software_cc + 535,
    {E DEFINE_SUBPRODUCT_ATTRIBUTES cannot be run twice when }
    {  DEFINE_PSRS_ANSWERED has been called.}

    rae$defpa_already_called = rac$min_package_software_cc + 540,
    {E DEFINE_PSRS_ANSWERED cannot be run twice when}
    {  DEFINE_SUBPRODUCT_ATTRIBUTES has been called.}

    rae$matched_version_path_warn = rac$min_package_software_cc + 545,
    {W The base and current level PACS catalogs should not define the same Installation Path.}
    {  The installation scheme must be changed from VERSION_BASED to CYCLE_BASED}
    {  by the CHANGE_CORRECTION_ATTRIBUTE command for the GENERATE_CORRECTION command to complete}
    {  successfully.}

    rae$matched_version_path_error = rac$min_package_software_cc + 550,
    {E The base and current level PACS catalogs cannot define the same Installation Path.}
    {  The installation scheme must be changed from VERSION_BASED to CYCLE_BASED}
    {  by the CHANGE_CORRECTION_ATTRIBUTE command for the GENERATE_CORRECTION command to complete}
    {  successfully.}

    rae$levels_should_differ = rac$min_package_software_cc + 555,
    {W The level of subproduct +P1 is the same for the base and current level }
    { PACS catalogs.  Both are at level +P2.  The levels should be different }
    { in order to differeniate between levels at installation time.  Correction }
    { generation may continue if you wish to ignore this WARNING. }

    rae$pacs_catalog_already_exists = rac$min_package_software_cc + 560,
    {E Existing PACS catalog +F1 must be deleted before subproduct +P2 can be loaded. }

    rae$reatf_load_failure = rac$min_package_software_cc + 565,
    {W One or more subproducts failed loading, see job log.  The failed subproduct }
    {  PACS catalogs have not been cleaned up.  Processing will continue for those }
    {  subproducts that successfully loaded. }

    rae$sif_writing_error = rac$min_package_software_cc + 570,
    {E The following error occurred while attempting to write subproduct information }
    {  file +F1: }

    rae$pacs_catalogs_not_restored = rac$min_package_software_cc + 575,
    {W Errors occurred reading the subproducts into PACS catalogs. }

    rae$reatf_validation_errors = rac$min_package_software_cc + 580,
    {E Validation errors occurred while processing the +P1 parameter. }

    rae$unmatched_attribute_warning = rac$min_package_software_cc + 585,
    {W The base and current level PACS catalogs must define the same +P1.}
    {  The base PACS catalog +P2 contains +P1 +P3, but current PACS catalog +P4 contains +P1 +P5.}

    rae$invalid_with_cartridge_tape = rac$min_package_software_cc + 590,
    {E Parameter SIZES cannot be specified when tape type is MT18$38000. }

    rac$max_package_software_cc = rac$min_package_software_cc + 799;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??

*DECK DECK=RAE$PROMPT_AND_MESSAGE_CC EXPAND=FALSE
*copyc rac$error_base
?? NEWTITLE := 'RAE$PROMPT_AND_MESSAGE_CC ------  1800 .. 1999', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    rac$min_prompt_and_message_cc = rac$error_base + 1800,

    rae$press_next = rac$min_prompt_and_message_cc + 5,
    {I Press RETURN/NEXT when ready to continue.}

    rae$invalid_response = rac$min_prompt_and_message_cc + 10,
    {I Invalid response received.}

    rae$not_valid_selection = rac$min_prompt_and_message_cc + 15,
    {I +P1 is not a valid selection.}

    rae$no_help_for_menu_selection = rac$min_prompt_and_message_cc + 20,
    {I No help is available for the menu selection +P1.}

    rae$no_help_for_menu = rac$min_prompt_and_message_cc + 25,
    {I No help is available for the menu.}

    rae$confirmation_prompt = rac$min_prompt_and_message_cc + 30,
    {I Is the selection +P correct (YES or NO)?}

    rae$menu_definition_error = rac$min_prompt_and_message_cc + 35,
    {E The menu module +P is not properly defined.}

    rae$module_access_error = rac$min_prompt_and_message_cc + 40,
    {E The module +P could not be accessed.}

    rae$message_not_found = rac$min_prompt_and_message_cc + 45,
    {E The message +P could not be found.}

    rae$bad_value_specification = rac$min_prompt_and_message_cc + 50,
    {E Bad value declaration given, expecting a string for the value specification.}

    rae$bad_value_key = rac$min_prompt_and_message_cc + 55,
    {E Bad value declaration given, expecting a keyword for the value format key.}

    rae$no_help_for_value = rac$min_prompt_and_message_cc + 60,
    {I No help is available for value prompt.}

    rae$bad_value = rac$min_prompt_and_message_cc + 65,
    {I +P1 is not a valid value response.}

    rae$max_number_of_exceeded = rac$min_prompt_and_message_cc + 70,
    {E The maximum number of +P was exceeded.}

    rae$message_not_informative = rac$min_prompt_and_message_cc + 75,
    {E Status message for menu prompting not informative, see deck RAE$PROMPT_AND_MESSAGE_CC. }

    rac$max_prompt_and_message_cc = rac$min_prompt_and_message_cc + 199;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??

*DECK DECK=RAE$SYSTEM_INITIATION_CC EXPAND=FALSE
*copyc rac$error_base
?? NEWTITLE := 'RAE$SYSTEM_INITIATION_CC  ------  1600 .. 1799', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    rac$min_system_initiation_cc = rac$error_base + 1600,

    rae$errors_occurred_warning = rac$min_system_initiation_cc + 5,
    {W Errors occurred while executing +P1.}

    rae$activating_error = rac$min_system_initiation_cc + 10,
    {E The following occurred while activating +P1:}

    rae$establishing_error = rac$min_system_initiation_cc + 15,
    {E The following occurred while establishing +P1:}

    rae$executing_error = rac$min_system_initiation_cc + 20,
    {E The following occurred while executing +P1:}

    rae$installing_error = rac$min_system_initiation_cc + 25,
    {E The following occurred while installing +P1:}

    rae$starting_error = rac$min_system_initiation_cc + 30,
    {E The following occurred while starting +P1:}

    rae$testing_error = rac$min_system_initiation_cc + 35,
    {E The following occurred while testing +P1:}

    rae$verifying_error = rac$min_system_initiation_cc + 40,
    {E The following occurred while verifying +P1:}

    rae$missing_configuration = rac$min_system_initiation_cc + 45,
    {E The +P1 configuration is missing.}

    rae$no_namve_due_to_rhfam = rac$min_system_initiation_cc + 50,
    {E NAM/VE cannot be activated while RHFAM is defined.  Deactivate and delete RHFAM, and retry.}

    rae$no_namve_deactivate_rhfam = rac$min_system_initiation_cc + 55,
    {E NAM/VE cannot be deactivated while RHFAM is defined.  Deactivate and delete RHFAM, and retry.}

    rae$error_creating_aam_files = rac$min_system_initiation_cc + 60,
    {E The following occurred while creating the AAM files:}

    rae$error_installing_namve = rac$min_system_initiation_cc + 65,
    {E The following occurred while installing NAM/VE configuration file.}

    rae$activation_errors_warning = rac$min_system_initiation_cc + 70,
    {W Errors occurred while activating the system for +P1.}

    rae$one_vsn_parameter_required = rac$min_system_initiation_cc + 75,
    {E Either the external vsn or the recorded vsn must be specified.}

    rae$packing_list_param_required = rac$min_system_initiation_cc + 80,
    {E The packing list parameter must be specified.}

    rae$install_aborted_by_user = rac$min_system_initiation_cc + 85,
    {I The installation has been terminated at the user's request.  }
    {  The system will be activated for system console usage only.}

    rae$unable_to_process_required = rac$min_system_initiation_cc + 90,
    {E Unable to process required products tape after 3 attempts.}

    rae$illegal_command_call = rac$min_system_initiation_cc + 95,
    {E Command +P cannot be called +P.}

    rac$max_system_initiation_cc = rac$min_system_initiation_cc + 199;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??

*DECK DECK=RAE$UPGRADE_ERRORS EXPAND=FALSE
*copyc rac$error_base

CONST
  rae$bad_path_name = rac$error_base + 5,
  {E Bad path name +P found.}

  rae$used_file_name = rac$error_base + 10,
  {E File name +P already used.}

  rae$used_path_name = rac$error_base + 15,
  {I Path +P is used by another file in the INSTALLATION TABLE.}

  rae$unused_file_format = rac$error_base + 20,
  {E File format +P is an unused format.}

  rae$file_not_in_table = rac$error_base + 25,
  {E File +P is not in the INSTALLATION TABLE.}

  rae$invalid_170_file_format = rac$error_base + 30,
  {E File +P is an invalid 170 file format.}

  rae$unable_to_compare_files = rac$error_base + 35,
  {E Unable to compare 170 files, reason is +P.}

  rae$unused_file_class = rac$error_base + 40,
  {E File class +P is an unused class.}

  rae$unexpected_attribute_found = rac$error_base + 45,
  {E Attribute +P cannot be used in this instance.}

  rae$unused_attribute_name = rac$error_base + 50,
  {E Attribute +P is an unused name.}

  rae$invalid_ring_for_delete = rac$error_base + 55,
  {E User minimum ring is invalid for deletion of file +P.}

  rae$params_not_allowed_together = rac$error_base + 60,
  {E Parameters +P cannot be used at the same time.}

  rae$current_session_log_error = rac$error_base + 65,
  {E Error(s) encountered during the display of current session +P UPGRADE LOG.}

  rae$max_catalog_list_exceeded = rac$error_base + 70,
  {E Maximum number of alternate catalogs allowed in one upgrade session is exceeded.}

  rae$program_internal_error = rac$error_base + 75,
  {E Program internal error found.}

  rae$no_replacements_found = rac$error_base + 80,
  {E No replacements were found in the correction.}

  rae$invalid_os_installation = rac$error_base + 85,
  {E Element +P cannot be installed separately from other OS files.}

  rae$invalid_installation = rac$error_base + 90,
  {W Element +P cannot be installed by this command.}

  rae$unknown_or_empty_file = rac$error_base + 95,
  {E Element +P is either unknown or an empty file.}

  rae$illegal_file_move = rac$error_base + 100,
  {E Files in catalog +P cannot be moved by command MOVE_CATALOG.}

  rae$illegal_product_install = rac$error_base + 105,
  {E +P products cannot be installed by INSTALL_PRODUCT command.}

  rae$product_without_files = rac$error_base + 110,
  {E No files found for specified product +P.}

  rae$unallowed_alternate_catalog = rac$error_base + 115,
  {E Specified catalog +P is not an allowable alternate catalog.}

  rae$illegal_vsn = rac$error_base + 120,
  {E +P is an illegal VSN.}

  rae$unable_to_display_level = rac$error_base + 125,
  {E Level for +P cannot be displayed by command DISPLAY_LEVEL.}

  rae$illegal_page_size = rac$error_base + 130,
  {E Page size can only be one of the following values, +P.}

  rae$expecting_real_state_lib = rac$error_base + 135,
  {E Expecting REAL STATE LIBRARY found +P instead.}

  rae$parameter_ignored = rac$error_base + 140,
  {W No changes to +P, therefore, parameter +P was ignored.}

  rae$file_not_installation_table = rac$error_base + 145,
  {E File +P is not an INSTALLATION TABLE.}

  rae$improper_load_option = rac$error_base + 150,
  {E +P is an improper load option during a +P.}

  rae$cleanup_errors_encountered = rac$error_base + 155,
  {I Some job files may still be left on the 170 side.}

  rae$missing_nosbe_catalog_id = rac$error_base + 160,
  {E The NOS/BE catalog identifier was empty.}

  rae$missing_170_file = rac$error_base + 165,
  {E The required NOS/170 file(s) +P could not be found.}

  rae$illegal_installation_path = rac$error_base + 170,
  {E An illegal path name of +P was found for the installation path of element +P.}

  rae$unable_to_display_rings = rac$error_base + 175,
  {E Unable to display the ring attributes for the file +P.}

  rae$cannot_delete_last_entry = rac$error_base + 180,
  {E Installation table +P has 1 entry- DELETION CANNOT BE PERFORMED.}

  rae$no_files_to_process = rac$error_base + 185,
  {E No files to process for given +P.}

  rae$no_real_state_corrections = rac$error_base + 190,
  {E No corrections found for REAL STATE files in correction package +P.}

  rae$expecting_rep_or_dir = rac$error_base + 195,
  {I Expecting replacements or directives in real state correction - none found.}

  rae$not_running_with_nos = rac$error_base + 200,
  {E Command +P works only when the 170 side is running with NOS.}

  rae$invalid_table_version = rac$error_base + 205,
  {E Invalid installation table version on file +P.}

  rae$invalid_use_of_none = rac$error_base + 210,
  {E NONE cannot be specified with any other options.}

  rae$invalid_mode_selection = rac$error_base + 215,
  {E +P is an invalid +P selection.}

  rae$element_not_found_installed = rac$error_base + 220,
  {E Installed element +P was not found.}

  rae$clone_catalog_not_found = rac$error_base + 225,
  {I INSTALL_DEFERRED_FILES ignored, system CLONE catalog not found.}

  rae$improper_use_of_keyword = rac$error_base + 230,
  {E The keyword +P was improperly specified on parameter +P.}

  rae$bad_170_name = rac$error_base + 235,
  {E Bad 170 name +P found.}

  rae$incompatable_file_found = rac$error_base + 240,
  {E The file +P is not compatable with a system running +P.}

  rae$no_procedures_found = rac$error_base + 245,
  {I No procedures were found.}

  rae$attempt_to_delete_all = rac$error_base + 250,
  {E You attempted to delete all modules from +P.}

  rae$missing_required_file = rac$error_base + 255,
  {E Required file(s) +P is/are either unknown or empty.}

  rae$unexpected_tape_count = rac$error_base + 260,
  {E Parameter +P expecting +P tape vsn(s), found +P tape vsn(s).}

  rae$version_already_on_system = rac$error_base + 270,
  {E +P is already on the system:  No action taken.}

  rae$no_parameters_given = rac$error_base + 275,
  {E One of the parameters +P must be specified.}

  rae$bcu_restore_failed = rac$error_base + 280,
  {E Batch job to restore correction tape to file failed.}

  rae$time_limit_reached = rac$error_base + 285,
  {E Time limit reached: +P.}

  rae$using_default_ds_prolog = rac$error_base + 290,
  {W A site tailored +P was not found, using default version.}

  rae$unable_to_format_pp = rac$error_base + 295,
  {W The pp +P will not be added to the deadstart file:  Unable to format.}

  rae$unable_to_process_tape = rac$error_base + 300,
  {E Unable to process +P product tape.}

  rae$write_file_not_executed = rac$error_base + 305,
  {E WRITE_FILE was not executed.  Results left on $LOCAL.+P}

  rae$load_vkx_not_executed = rac$error_base + 310,
  {E LOAD_VKX was not executed.}

  rae$pp_already_processed = rac$error_base + 315,
  {E PP has already been processed.}

  rae$defaults_specified = rac$error_base + 320,
  {E Default values cannot be specified on parameter(s) +P.}

  rae$params_improperly_used = rac$error_base + 325,
  {E The parameter(s) +P improperly used.}

  rae$no_corrections_for_system = rac$error_base + 330,
  {W There are no corrections for this system.}

  rae$missing_product_file = rac$error_base + 335;
  {E The file +P is missing from the +P product tape.}

*copy rae$system_initiation_cc
*copy rae$prompt_and_message_cc
*copy rae$maintain_deadstart_sw_cc
*copy rae$error_messages
*DECK DECK=RAF$BD_JOB_TEMPLATE_223 EXPAND=FALSE
"
"  Directives for binding osf$job_template_223 library.  The unbound library
"  is on file 'unbound_library', file 'scratch_library' is used for an
"  intermediate result and 'bound_library' is where the bound library
"  is written.  These varibles must be defined in the procedure that
"  invokes these linker commands.
"
"  These directives are invoked by the 'bind_os_library' procedure.
"
"  It is important that AVM$CALCULATE_SRUS remains as the last module on the
"  bound library (for dump analysis reasons).

    add_module l=$fname(unbound_library)
" The following reorder module is to align the path table on a page
" boundary.  This reduces the amount of paging for other variables
" and improves response time on a memory bound system.
    reorder_module m=fmm$path_table_manager, p=before
    delete_module m=avm$calculate_srus
    delete_module m=pfm$compute_checksum
    generate_library l=$fname(scratch_library)

    create_module n=bound_job_template_223 c=$fname(scratch_library) include_binary_section_maps=TRUE
    add_module l=$fname(unbound_library) m=(pfm$compute_checksum avm$calculate_srus)
    change_module_attributes m=bound_job_template_223 retain=all

"  Put a status variable on the following generate_library l=so that any
"  warning-level linker errors will be able to pass back to bind_os_library the fact
"  that there were internal errors on this library.
    generate_library l=$fname(bound_library) status=bind_status
*DECK DECK=RAF$BD_JOB_TEMPLATE_236 EXPAND=FALSE


"
"  Directives for binding osf$job_template_236 library.  The unbound library
"  is on file 'unbound_library', file 'scratch_library' is used for an
"  intermediate result and 'bound_library' is where the bound library
"  is written.  These varibles must be defined in the procedure that
"  invokes these linker commands.
"
"  These directives are invoked by the 'bind_os_library' procedure.
"

    create_module n=bound_job_template_236 c=$fname(unbound_library) include_binary_section_maps=TRUE
    change_module_attributes m=bound_job_template_236 retain=all

"  Put a status variable on the following generate_library l=so that any
"  warning-level linker errors will be able to pass back to bind_os_library the fact
"  that there were internal errors on this library.
    generate_library l=$fname(bound_library) status=bind_status

*DECK DECK=RAF$BD_JOB_TEMPLATE_23D EXPAND=FALSE

"  Directives for binding osf$job_template_23d library.  The unbound library
"  is on file 'unbound_library', file 'scratch_library' is used for an
"  intermediate result and 'bound_library' is where the bound library
"  is written.  These variables must be defined in the procedure that
"  invokes these linker commands.
"
"  These directives are invoked by the 'bind_os_library' procedure.
"
"  It is important that the unbound modules within the bound library remain in
"  the order that they are currently in and remain as the last modules on the
"  bound library (for dump analysis reasons).

    add_module l=$fname(unbound_library)
    delete_module m=rmm$enforce_tape_security
    delete_module m=rmm$validate_tape_operations
    delete_module m=avm$encrypt_password
    delete_module m=avm$process_password_attributes
    delete_module m=avm$verify_validation_name
    generate_library l=$fname(scratch_library)

    create_module n=bound_job_template_23d c=$fname(scratch_library) include_binary_section_maps=TRUE
    add_module l=$fname(unbound_library) m=(rmm$enforce_tape_security rmm$validate_tape_operations ..
          avm$encrypt_password avm$process_password_attributes avm$verify_validation_name)
    change_module_attributes m=bound_job_template_23d retain=all

"  Put a status variable on the following generate_library command so that any
"  warning-level linker errors will be able to pass back to bind_os_library the fact
"  that there were internal errors on this library.

    generate_library l=$fname(bound_library) status=bind_status
*DECK DECK=RAF$BD_JOB_TEMPLATE_2DD EXPAND=FALSE
"
"  Directives for binding osf$job_template_2dd library.  The unbound library
"  is on file 'unbound_library', file 'scratch_library' is used for an
"  intermediate result and 'bound_library' is where the bound library
"  is written.  These varibles must be defined in the procedure that
"  invokes these linker commands.
"
"  These directives are invoked by the 'bind_os_library' procedure.
"

    add_module l=$fname(unbound_library)
    delete_module m=pmm$job_template_trap_handler
    delete_module m=pmm$preset_conversion_table
    delete_module m=pmm$tasking_helper_procedures
    generate_library l=$fname(scratch_library)

    add_module l=$fname(unbound_library) m=pmm$job_template_trap_handler
    add_module l=$fname(unbound_library) m=pmm$preset_conversion_table
    add_module l=$fname(unbound_library) m=pmm$tasking_helper_procedures
    create_module n=bound_job_template_2dd c=$fname(scratch_library) include_binary_section_maps=TRUE
    change_module_attributes m=bound_job_template_2dd retain=all

"  Put a status variable on the following generate_library l=so that any
"  warning-level linker errors will be able to pass back to bind_os_library the fact
"  that there were internal errors on this library.
    generate_library l=$fname(bound_library) status=bind_status
*DECK DECK=RAF$BD_MONITOR EXPAND=FALSE
"
"  Directives for binding osf$monitor library.  The unbound library
"  is on file 'unbound_library', file 'scratch_library' is used for an
"  intermediate result and 'bound_library' is where the bound library
"  is written.  These varibles must be defined in the procedure that
"  invokes these linker commands.
"
"  These directives are invoked by the 'bind_os_library' procedure.
"

    add_module l=$fname(unbound_library)
    delete_module m=mtm$monitor_interrupt_handler
    delete_module m=mmm$memory_manager_helper
    delete_module m=osm$intrinsics
    generate_library l=$fname(scratch_library)

    add_module l=$fname(unbound_library) m=mtm$monitor_interrupt_handler
    add_module l=$fname(unbound_library) m=mmm$memory_manager_helper
    add_module l=$fname(unbound_library) m=osm$intrinsics
    create_module n=bound_monitor c=$fname(scratch_library) include_binary_section_maps=TRUE
    change_module_attributes m=bound_monitor retain=all

"  Put a status variable on the following generate_library l=so that any
"  warning-level linker errors will be able to pass back to bind_os_library the fact
"  that there were internal errors on this library.
    generate_library l=$fname(bound_library) status=bind_status
*DECK DECK=RAF$BD_SYSTEM_CORE_113 EXPAND=FALSE
"
"  Directives for binding osf$system_core_113 library.  The unbound library
"  is on file 'unbound_library', file 'scratch_library' is used for an
"  intermediate result and 'bound_library' is where the bound library
"  is written.  These varibles must be defined in the procedure that
"  invokes these linker commands.
"
"  These directives are invoked by the 'bind_os_library' procedure.
"

    add_module l=$fname(unbound_library)
    delete_module m=sym$job_fixed_template
    delete_module m=sym$core_trap_handler
    delete_module m=sym$outward_caller
    generate_library l=$fname(scratch_library)

    add_module l=$fname(unbound_library) m=sym$job_fixed_template
    add_module l=$fname(unbound_library) m=sym$core_trap_handler
    add_module l=$fname(unbound_library) m=sym$outward_caller
    create_module n=bound_system_core_113 c=$fname(scratch_library) include_binary_section_maps=TRUE
    change_module_attributes m=bound_system_core_113 retain=all

"  Put a status variable on the following generate_library l=so that any
"  warning-level linker errors will be able to pass back to bind_os_library the fact
"  that there were internal errors on this library.
    generate_library l=$fname(bound_library) status=bind_status
*DECK DECK=RAF$BD_SYSTEM_CORE_133 EXPAND=FALSE
"
"  Directives for binding osf$system_core_133 library.  The unbound library
"  is on file 'unbound_library', file 'scratch_library' is used for an
"  intermediate result and 'bound_library' is where the bound library
"  is written.  These varibles must be defined in the procedure that
"  invokes these linker commands.
"
"  These directives are invoked by the 'bind_os_library' procedure.
"

    create_module n=bound_system_core_133 $fname(unbound_library) include_binary_section_maps=TRUE
    change_module_attributes m=bound_system_core_133 retain=all

"  Put a status variable on the following generate_library l=so that any
"  warning-level linker errors will be able to pass back to bind_os_library the fact
"  that there were internal errors on this library.
    generate_library l=$fname(bound_library) status=bind_status
*DECK DECK=RAF$BD_SYSTEM_CORE_13D EXPAND=FALSE
"
"  Directives for binding osf$system_core_13d library.  The unbound library
"  is on file 'unbound_library', file 'scratch_library' is used for an
"  intermediate result and 'bound_library' is where the bound library
"  is written.  These varibles must be defined in the procedure that
"  invokes these linker commands.
"
"  These directives are invoked by the 'bind_os_library' procedure.
"

    create_module n=bound_system_core_13d $fname(unbound_library) include_binary_section_maps=TRUE
    change_module_attributes m=bound_system_core_13d retain=all

"  Put a status variable on the following generate_library l=so that any
"  warning-level linker errors will be able to pass back to bind_os_library the fact
"  that there were internal errors on this library.
    generate_library l=$fname(bound_library) status=bind_status
*DECK DECK=RAF$BD_SYSTEM_CORE_1DD EXPAND=FALSE
"
"  Directives for binding osf$system_core_1dd library.  The unbound library
"  is on file 'unbound_library', file 'scratch_library' is used for an
"  intermediate result and 'bound_library' is where the bound library
"  is written.  These varibles must be defined in the procedure that
"  invokes these linker commands.
"
"  These directives are invoked by the 'bind_os_library' procedure.
"

    add_module l=$fname(unbound_library)
    delete_module m=osm$intrinsics
    generate_library l=$fname(scratch_library)
    add_module l=$fname(unbound_library) m=osm$intrinsics
    create_module n=bound_system_core_1dd c=$fname(scratch_library) include_binary_section_maps=TRUE
    change_module_attributes m=bound_system_core_1dd retain=all

"  Put a status variable on the following generate_library l=so that any
"  warning-level linker errors will be able to pass back to bind_os_library the fact
"  that there were internal errors on this library.
    generate_library l=$fname(bound_library) status=bind_status
*DECK DECK=RAF$BINDING_DIRECTIVES EXPAND=TRUE
"
"  This deck collects the binding directives for binding the OS onto specific files to be used by link_operating_system.
"  This deck should be expanded and then do an 'include_file' to create the various linker command files.
"  Create the variables that contain the name of the file for the binding directives for the various libraries.
"
"  NOTE: There is a very tight coupling between this deck and the procedure link_operating_system due to the
"  variables created by this deck.
"

create_variable bd_monitor k=string value='$local.'//$unique
create_variable bd_system_core_113 k=string value='$local.'//$unique
create_variable bd_system_core_133 k=string value='$local.'//$unique
create_variable bd_system_core_13d k=string value='$local.'//$unique
create_variable bd_system_core_1dd k=string value='$local.'//$unique
create_variable bd_job_template_223 k=string value='$local.'//$unique
create_variable bd_job_template_236 k=string value='$local.'//$unique
create_variable bd_job_template_23d k=string value='$local.'//$unique
create_variable bd_job_template_2dd k=string value='$local.'//$unique

COLLECT_TEXT o=$fname(bd_monitor) u='**END**' p=''
*copy raf$bd_monitor
**END**

COLLECT_TEXT o=$fname(bd_system_core_113) u='**END**' p=''
*copy raf$bd_system_core_113
**END**

COLLECT_TEXT o=$fname(bd_system_core_133) u='**END**' p=''
*copy raf$bd_system_core_133
**END**

COLLECT_TEXT o=$fname(bd_system_core_13d) u='**END**' p=''
*copy raf$bd_system_core_13d
**END**

COLLECT_TEXT o=$fname(bd_system_core_1dd) u='**END**' p=''
*copy raf$bd_system_core_1dd
**END**

COLLECT_TEXT o=$fname(bd_job_template_223) u='**END**' p=''
*copy raf$bd_job_template_223
**END**

COLLECT_TEXT o=$fname(bd_job_template_236) u='**END**' p=''
*copy raf$bd_job_template_236
**END**

COLLECT_TEXT o=$fname(bd_job_template_23d) u='**END**' p=''
*copy raf$bd_job_template_23d
**END**

COLLECT_TEXT o=$fname(bd_job_template_2dd) u='**END**' p=''
*copy raf$bd_job_template_2dd
**END**

*DECK DECK=RAF$BINDING_PROCEDURE EXPAND=TRUE
PROCEDURE bind_installation_tools (
  unbound_library, ul: file =
    $fname(wev$working_catalog//'.'//wev$working_build_level//'.maintenance.raf$library')
  bound_library, bl: file = $fname(wev$working_catalog//'.'//wev$working_build_level//'.bound_installation_tools')
  cybil_library, cl: file = $system.cybil.cyf$run_time_library
  map, m: file = $local.load_map
  status)

"$FORMAT=OFF
  VAR
    bound_inss   : file =  $fname($unique)
    bound_pacs   : file =  $fname($unique)
    ignore_status : status
    inss_delete_list : list 0..$max_list of string 0..$max_name
    master_delete_list : $type(inss_delete_list)
    pacs_delete_list : $type(inss_delete_list)
    scratch_file : file = $fname($unique)
    scratch_library : file =  $fname($unique)
  VAREND

"$FORMAT=ON

  CREATE_OBJECT_LIBRARY
    put_message 'Bind Install_Software...'
    add_module l=unbound_library m=ram$install_software
    satisfy_external_references l=(unbound_library)

"   Produce a LIST of modules which have been bound into INSS

    set_file_attributes f=scratch_file fc=legible pf=continuous
    display_new_library do=none o=scratch_file
    get_lines i=scratch_file v=inss_delete_list
    delete_file f=scratch_file status=ignore_status

    satisfy_external_references l=(cybil_library)
    generate_library l=scratch_library

"   Create the bound module for INSS.

    create_module n=ram$install_software c=scratch_library sp=rap$install_software ibsm=true o=map.$eoi
    change_module_attributes m=ram$install_software retain=(rap$install_software,..
         ocp$copy,ocp$normalize_binding_sec_value,ocp$apply_message_predictor,..
         ocp$build_code_sec_directory,..
         ocp$process_info_element,ocp$process_interp_element,..
         ocp$new_global_offset,ocp$process_module_dictionary,..
         ocp$process_ept_dictionary,ocp$process_command_dictionary,..
         ocp$process_function_dictionary,ocp$process_help_dictionary,..
         ocp$process_message_dictionary,..
         ocp$new_offset,ocp$build_first_intermediate_ol,..
         ocp$process_rel_records,ocp$process_section_maps,..
         ocp$process_epts,ocp$process_exts,..
         ocp$process_sections,ocp$apply_corrector,ocp$checksum,..
         ocp$apply_move_items)

    change_module_attributes m=ram$install_software omit_non_retained_entry_points=true
    change_module_attributes m=ram$install_software omit_library=cyf$run_time_library
    add_copyright ram$install_software
    generate_library l=bound_inss

    put_message 'Bind Package_Software...'
    add_module l=unbound_library m=ram$package_software
    satisfy_external_references l=(unbound_library)

"   Produce a LIST of modules which have been bound into PACS

    set_file_attributes f=scratch_file fc=legible pf=continuous
    display_new_library do=none o=scratch_file
    get_lines i=scratch_file v=pacs_delete_list
    delete_file f=scratch_file status=ignore_status

    satisfy_external_references l=(cybil_library)
    generate_library l=scratch_library

"   Create the bound module for PACS.

    create_module n=ram$package_software c=scratch_library sp=rap$package_software ibsm=true o=map.$eoi
    change_module_attributes m=ram$package_software not_retain=all
    change_module_attributes m=ram$package_software retain=rap$package_software ..
          omit_non_retained_entry_points=true
    change_module_attributes m=ram$package_software omit_library=cyf$run_time_library
    add_copyright ram$package_software
    generate_library l=bound_pacs

    put_message 'Pick up tag-along modules...'
    add_module unbound_library
    master_delete_list = $union(inss_delete_list, pacs_delete_list)
"$FORMAT=OFF
    delete_module m=$apply($select(master_delete_list, $size(x)>1), $program_name(x))
"$FORMAT=ON
    addm bound_inss
    addm bound_pacs
    generate_library bound_library
  QUIT

  delete_file f=scratch_library status=ignore_status
  delete_file f=bound_pacs status=ignore_status
  delete_file f=bound_inss status=ignore_status

PROCEND bind_installation_tools

*DECK DECK=RAF$BIND_BOOT_JOB EXPAND=FALSE
    detach_file file=$fname(scratch_library)
    add_module library=$fname(boot_job_ol)
    satisfy_external_references library=$fname(cybil_library)
    generate_library library=$fname(scratch_library)

    create_module name=bound_boot_job component=$fname(scratch_library) include_binary_section_maps=true
    change_module_attributes module=bound_boot_job omit=i#rel
    change_module_attributes module=bound_boot_job omit=i#store_bit
    change_module_attributes module=bound_boot_job omit=i#program_error
    change_module_attributes module=bound_boot_job omit=i#compare
    change_module_attributes module=bound_boot_job omit=i#compare_collated
    change_module_attributes module=bound_boot_job omit=i#build_adaptable_heap_pointer
    change_module_attributes module=bound_boot_job omit=i#build_adaptable_array_pointer
    change_module_attributes module=bound_boot_job omit=i#build_adaptable_array_ptr
    change_module_attributes module=bound_boot_job omit=i#current_sequence_position
    change_module_attributes module=bound_boot_job omit_library=cyf$run_time_library
    change_module_attributes module=bound_boot_job omit=MLP$ROUND_FLOATING_NUMBER status=ignore_status
    change_module_attributes module=bound_boot_job omit=MLP$SCALE_FLOATING_NUMBER status=ignore_status
    change_module_attributes module=bound_boot_job omit=MLP$OUTPUT_FLOATING_NUMBER status=ignore_status
    change_module_attributes module=bound_boot_job omit=MLV$DOUBLE_POWERS_OF_TEN status=ignore_status
    change_module_attributes module=bound_boot_job omit=CYP$STRINGREP status=ignore_status
    generate_library library=$fname(bound_boot_job_path)
*DECK DECK=RAF$BIND_BOOT_MONITOR EXPAND=FALSE
    add_module library=$fname(boot_monitor_ol)
    satisfy_external_references library=$fname(cybil_library)
    delete_module module=dsm$boot_interrupt_handler
    generate_library library=$fname(scratch_library)

    add_module library=$fname(boot_monitor_ol) module=dsm$boot_interrupt_handler
    create_module name=bound_boot_monitor component=$fname(scratch_library) ..
         include_binary_section_maps=true
    change_module_attributes module=bound_boot_monitor retain=iop$process_io_completions
    change_module_attributes module=bound_boot_monitor retain=dpp$process_scd_block
    change_module_attributes module=bound_boot_monitor retain=mtp$initiate_system_idle
    change_module_attributes module=bound_boot_monitor retain=mtp$monitor_system_status
    change_module_attributes module=bound_boot_monitor retain=mtp$process_170_mtr_requests
    change_module_attributes module=bound_boot_monitor retain=mtp$error_stop
    change_module_attributes module=bound_boot_monitor retain=i#real_memory_address
    change_module_attributes module=bound_boot_monitor retain=i#program_error
    change_module_attributes module=bound_boot_monitor omit=CYP$STRINGREP status=ignore_status
    change_module_attributes module=bound_boot_monitor omit=cyp$error
    change_module_attributes module=bound_boot_monitor omit_library=cyf$run_time_library
    generate_library library=$fname(bound_boot_monitor_path)
*DECK DECK=RAF$BOOT_DIRECTIVES EXPAND=TRUE
"
"  This deck collects the binding directives, linker commands and the build_real_memory commands to build the boot
"  memory image. This deck should be expanded and then do an 'include_file' to create the various command files.
"
"  NOTE: There is a very tight coupling between this deck and the procedure link_boot due to the
"  variables created by this deck.
"

create_variable bind_boot_job_commands    kind=(string, $max_name) value=$unique
create_variable bind_boot_mtr_commands    kind=(string, $max_name) value=$unique
create_variable boot_linker_commands      kind=(string, $max_name) value=$unique
create_variable boot_real_memory_commands kind=(string, $max_name) value=$unique

COLLECT_TEXT output=$fname(bind_boot_job_commands) u='**END**' p=''
*copy raf$bind_boot_job
**END**

COLLECT_TEXT output=$fname(bind_boot_mtr_commands) u='**END**' p=''
*copy raf$bind_boot_monitor
**END**

COLLECT_TEXT output=$fname(boot_linker_commands) u='**END**' p=''
*copy raf$boot_linker_commands
**END**

COLLECT_TEXT output=$fname(boot_real_memory_commands) u='**END**' p=''
*copy raf$boot_real_memory_commands
**END**

*DECK DECK=RAF$BOOT_FILE_DIRECTIVES EXPAND=FALSE
write_action_record number=0
load_pp_image input=$fname(dsmsmu)   pp_name=vpb
load_pp_image input=$fname(dsmssr)   pp_name=ssr
load_pp_image input=$fname(dsmres)   pp_name=res
load_pp_image input=$fname(dsk7154)  pp_name=d4
load_pp_image input=$fname(dsk55a)   pp_name=d5a
load_pp_image input=$fname(dsk55b)   pp_name=d5b
load_pp_image input=$fname(dsk55c7)  pp_name=d5c
load_pp_image input=$fname(dsk55c8)  pp_name=d5c2
load_pp_image input=$fname(isd)      pp_name=isd
load_pp_image input=$fname(tape)     pp_name=tape
load_pp_image input=$fname(netw)     pp_name=netw
load_pp_image input=$fname(vm5b)     pp_name=vm5b
write_action_record number=1
load_memory_image input=$fname(boot_memory_image) image_name=vcmb
write_action_record number=3
load_cip_module input=$fname(cipdft)
load_cip_module input=$fname(cipscd)
write_action_record number=4
load_deadstart_commands input=$fname(dcfile)
write_action_record number=5
display_record_list
write_deadstart_file o=$fname(result_boot_file)
*DECK DECK=RAF$BOOT_LINKER_COMMANDS EXPAND=FALSE
      set_link_options link_map=$fname(link_map) starting_procedure=mtp$begin ..
            linked_symbols=all

      set_link_options exchange_package_variable=mtv$monitor_exchange_package
      initialize_heap_pointer pointer=osv$mainframe_wired_heap segment_number=10

      add_object_file file=$fname(bound_boot_monitor_path) ring_brackets=(1 1 3)..
           global_local_key=(0 0) execute_privilege=global ..
           default_sections=((re_mtr r e) (rb_mtr r b) (re_mtr r) (rw_mtr r w))

      add_object_file file=$fname(bound_boot_job_path) ring_brackets=(1 1 3)..
           global_local_key=(0 0) execute_privilege=global ..
           default_sections=((re_mtr r e) (rb_mtr r b) (re_mtr r) (rw_mtr r w))

      s1 = 'oss$mainframe_pageable'
      s2 = 'oss$mainframe_wired_literal'
      s3 = 'oss$mainframe_paged_literal'
      s4 = 'oss$job_paged_literal'
      s5 = 'oss$nos_trap_handler'
      s6 = 'oss$job_fixed'
      s7 = 'oss$mainframe_wired'
      s8 = 'cys$run_time_space'
      s9 = 'readonly'
      s10 = 'oss$job_pageable'
      s11 = 'oss$mainframe_wired_cb'

      define_segment attributes=(gp, bi, cb, wt) ring_brackets=(1, 1, 1)..
          number=10 global_local_key=(0, 0) inhibit_binding_check=yes..
          section_names=(re_mtr  rb_mtr rw_mtr c180ei $name(s1) $name(s2) $name(s3)..
               $name(s4) $name(s5) $name(s6) $name(s7) $name(s8) $name(s9) $name(s10) $name(s11))

      generate_virtual_memory virtual_image=$fname(boot_vm) symbol_table=$fname(boot_st) ..
            debug_table=$fname(debug_table)
*DECK DECK=RAF$BOOT_REAL_MEMORY_COMMANDS EXPAND=FALSE
      set_build_options memory_map=$fname(link_map//'.$eoi') load_address=0 ..
            page_size=2048 building_environment_interface=yes ..
            bytes_loaded_address=(monitor osv$boot_load_size_in_bytes)

      load_monitor virtual_image=$fname(boot_vm) symbol_table=$fname(boot_st)
      display_memory memory=memory_map
      generate_real_memory real_memory_image=$fname(memory_image)
*DECK DECK=RAF$BUILD_REAL_MEMORY_COMMANDS EXPAND=TRUE
      IF $value(page_size) > $value(page_table_length) THEN
        loadadr=$value(page_size)
      ELSE
        loadadr=$value(page_table_length)
      IFEND
      set_build_options page_table_address=0 load_address=loadadr..
          load_offset=0 memory_map=$fname(map_file_string//..
'.$eoi') page_size=$value(page_size) page_table_length=$value(..
        page_table_length)
      set_build_options c170_memory_size=1000000(16) ssr_size=8000(16)
      set_build_options job_exchange_address=(job, jmv$jmtr_xcb) ..
        monitor_exchange_address=(monitor, mtv$monitor_exchange_package)
      set_build_options pp_address_array_address=(monitor, osv$spaa)
      load_monitor $fname(monitor_virtual_memory_string) symbol_table=$fname..
(monitor_symbols_string)
      load_job $fname(system_virtual_memory_string) symbol_table=$fname(..
        system_symbols_string)
      define_segment address_space=monitor segment_identifier=page_table ..
        segment_number=0 length=$value(page_table_length) attributes=(rd, wt..
        , cb) ring_brackets=(1, 1)
      define_segment address_space=monitor segment_identifier=c170_memory ..
        segment_number=3 active_segment_id=0ffff(16) length=0 attributes=(rd..
        , wt, gp) ring_brackets=(1, 15) real_address=800000(16)
      define_segment address_space=monitor segment_identifier=        ..
        system_status_record segment_number=4 active_segment_id=8000(16) ..
        length=0 attributes=(cb, gp, bi, wt) ring_brackets=(1, 15) ..
        real_address=810000(16)
      share_segment address_space=monitor segment_number=0 new_address_space..
                =job new_segment_number=0
      share_segment address_space=monitor segment_number=wired_segment ..
        new_address_space=job new_segment_number=wired_segment
        share_segment address_space=monitor segment_number=7 new_address_space..
          =job new_segment_number=7
      share_segment address_space=job segment_number=3 new_address_space..
        =        monitor new_segment_number=20
      change_segment address_space=monitor segment_number=5 ..
        active_segment_id        =8001(16)
      extend_segment address_space=monitor segment_number=wired_segment ..
        length=6c00(16)
      extend_segment address_space=job segment_number=pageable_segment ..
        length        =2000(16)
      extend_segment address_space=job segment_number=3 length=3000(16)
      display_memory memory=page_table
      display_memory memory=job_exchange_package
      display_memory memory=monitor_exchange_package
      display_memory memory=memory_map
      display_memory_address 561a0(16) length=200(16)
      display_memory_address 8000(16) length=200(16)
      display_memory_address 0 length=32767
      display_memory_address 10000(16) length=4000(16)
      generate_real_memory $fname(system_real_memory_string)
*DECK DECK=RAF$DEADSTART_FILE_DIRECTIVES EXPAND=FALSE
write_action_record number=0
load_pp_image input=$fname(dsk7154)  pp_name=d4
load_pp_image input=$fname(dsk55a)   pp_name=d5a
load_pp_image input=$fname(dsk55b)   pp_name=d5b
load_pp_image input=$fname(dsk55c7)  pp_name=d5c
load_pp_image input=$fname(dsk55c8)  pp_name=d5c2
load_pp_image input=$fname(isd)      pp_name=isd
load_pp_image input=$fname(d895)     pp_name=d895
load_pp_image input=$fname(hyd)      pp_name=hyd
load_pp_image input=$fname(tape)     pp_name=tape
load_pp_image input=$fname(netw)     pp_name=netw
load_pp_image input=$fname(vm5b)     pp_name=vm5b
write_action_record number=1
load_memory_image input=$fname(monitor_template) image_name=monitor
load_memory_image input=$fname(system_core_template) image_name=sycore
write_action_record number=4
load_deadstart_commands input=$fname(dcfile)
write_action_record number=5
load_memory_image input=$fname(virtual_memory_image)
write_action_record number=11
load_ascii_records input=$fname(sitecp) record_name=sitecp
load_hunk      input=$fname(sscript) record_name=sscript
  load_hunk_file input=$fname(builtin_library)
  load_hunk_file input=$fname(tasks_library)
quit write_records=true  " Exit load_hunk utility"
display_record_list
write_deadstart_file o=$fname(result_deadstart_file)
*DECK DECK=RAF$DESTINATION_LIBRARIES EXPAND=FALSE
type
  dest_record: record
    destination_name: name
    format: name
    entry_point_commands: list of name = $optional
  recend
typend

var
  rav$destination_files: list of dest_record
varend

rav$destination_files = (..
(fdf$library,                     object_library  (generate_open_shop_product_tape)) ..
(ocf$binding_procedure,           object_library  (build_ocu generate_open_shop_product_tape)) ..
(ocf$object_code_utilities,       object_library  (build_ocu, generate_open_shop_product_tape)) ..
(osf$audit_library                object_library  (generate_open_shop_product_tape)) ..
(osf$batch_device_support         object_library  (generate_open_shop_product_tape)) ..
(osf$batch_output_filters         object_library  (generate_open_shop_product_tape)) ..
(osf$batch_output_filters_source, text) ..
(osf$boot_job                     os_library      (link_operating_system, generate_ve_deadstart_tape)) ..
(osf$boot_monitor                 os_library      (link_operating_system, generate_ve_deadstart_tape)) ..
(osf$builtin_library              object_library  (link_operating_system, generate_ve_deadstart_tape)) ..
(osf$c170_ei                      object_library  (link_ei, generate_cip_tape_components, ..
                                                   build_s0_51_cip_tapes, build_s0_52_cip_tapes, ..
                                                   build_s1_cip_tapes, build_s2_cip_tapes, ..
                                                   build_s3_cip_tapes, build_s4_cip_tapes, ..
                                                   build_s5_cip_tapes, build_s5_962_cip_tapes)) ..
(osf$command_library              object_library  (generate_open_shop_product_tape)) ..
(osf$deadstart_library            object_library  (link_operating_system, generate_ve_deadstart_tape)) ..
(osf$development_dcfile           text            (generate_ve_deadstart_tape)) ..
(osf$dev_sys_init_epilog          text) ..
(osf$dump_analyzer                object_library) ..
(osf$dump_analyzer_procs          object_library) ..
(osf$default_exception_policies   text            (generate_open_shop_product_tape)) ..
(osf$ftm_library                  text) ..
(osf$job_activation_epilog        text            (generate_open_shop_product_tape)) ..
(osf$job_activation_prolog        text            (generate_open_shop_product_tape)) ..
(osf$job_leveler_task             object_library  (generate_open_shop_product_tape)) ..
(osf$job_template_223             os_library      (link_operating_system, generate_ve_deadstart_tape)) ..
(osf$job_template_236             os_library      (link_operating_system, generate_ve_deadstart_tape)) ..
(osf$job_template_23d             os_library      (link_operating_system, generate_ve_deadstart_tape)) ..
(osf$job_template_2dd             os_library      (link_operating_system, generate_ve_deadstart_tape)) ..
(osf$lcu_mf_subcmds               text            (generate_ve_deadstart_tape)) ..
(osf$manage_file_server           object_library  (generate_open_shop_product_tape)) ..
(osf$message_templates            object_library  (link_operating_system, generate_ve_deadstart_tape)) ..
(osf$mf_config_epilog             text) ..
(osf$monitor                      os_library      (link_operating_system, generate_ve_deadstart_tape)) ..
(osf$network_activation_epilog    text            (generate_open_shop_product_tape)) ..
(osf$network_activation_prolog    text            (generate_open_shop_product_tape)) ..
(osf$network_deactivation_epilog  text            (generate_open_shop_product_tape)) ..
(osf$network_deactivation_prolog  text            (generate_open_shop_product_tape)) ..
(osf$network_management           object_library  (build_namve, generate_open_shop_product_tape)) ..
(osf$nosbins                      text            (link_170, generate_nos_deadstart_tape)) ..
(osf$nvelib                       text            (link_170, generate_nos_deadstart_tape)) ..
(osf$nvebins                      text) ..
(osf$nveprol                      text) ..
(osf$nverels                      multi_record    (link_170, generate_nos_deadstart_tape)) ..
(osf$operator_command_library     object_library  (generate_open_shop_product_tape)) ..
(osf$operator_library_46d         object_library  (generate_open_shop_product_tape)) ..
(osf$physical_config              text) ..
(osf$product_epilog               text) ..
(osf$programs                     object_library  (generate_open_shop_product_tape)) ..
(osf$prolog_library               object_library  (generate_ve_deadstart_tape)) ..
(osf$released_dcfile              text) ..
(osf$rhfam_network_utilities      object_library  (generate_open_shop_product_tape)) ..
(osf$scd                          text) ..
(osf$site_command_library         object_library  (generate_open_shop_product_tape)) ..
(osf$sou_library                  object_library  (link_operating_system, generate_ve_deadstart_tape)) ..
(osf$system_core_113              os_library      (link_operating_system, generate_ve_deadstart_tape)) ..
(osf$system_core_133              os_library      (link_operating_system, generate_ve_deadstart_tape)) ..
(osf$system_core_13d              os_library      (link_operating_system, generate_ve_deadstart_tape)) ..
(osf$system_core_1dd              os_library      (link_operating_system, generate_ve_deadstart_tape)) ..
(osf$system_deadstart_prolog      text) ..
(osf$system_epilog                text) ..
(osf$system_initiation_epilog     text            (generate_open_shop_product_tape)) ..
(osf$system_initiation_prolog     text            (generate_open_shop_product_tape)) ..
(osf$system_library_46d           object_library  (generate_open_shop_product_tape)) ..
(osf$system_prolog                text) ..
(osf$system_termination_prolog    text            (generate_open_shop_product_tape)) ..
(osf$tasks                        object_library  (link_operating_system, generate_ve_deadstart_tape)) ..
(osf$unbound_pf_utilities         object_library  (link_operating_system, generate_ve_deadstart_tape)) ..
(osf$user_file_transfer           object_library  (generate_open_shop_product_tape)) ..
(qcf$base_product_table           text) ..
(qcf$qcu_product_table            text) ..
(raf$bind_network_management      object_library   (build_namve, generate_open_shop_product_tape)) ..
(raf$binding_procedure            object_library) ..
(raf$cs_tools                     object_library) ..
(raf$fortran_command_library      object_library) ..
(raf$integration_tools            object_library) ..
(raf$library                      object_library, (build_installation_tools, generate_open_shop_product_tape)) ..
(raf$maintenance_command_library, object_library) ..
(raf$maintenance_source_library,  text) ..
(raf$open_shop_di_configurations, object_library) ..
(raf$open_shop_terminal_procs     object_library) ..
(raf$open_shop_user_procs         object_library) ..
(raf$qcu_product_table            text) ..
(tuf$terminal_definitions         object_library, (generate_open_shop_product_tape)) ..
..
(osf$pp                           catalog) ..
(cip                              catalog) ..
..
(boot_debug_table                 text) ..
(boot_image                       text) ..
(boot_link_map                    text) ..
(bound_boot_job                   text) ..
(bound_boot_monitor               text) ..
(bound_installation_tools         text) ..
(bound_job_template_223           text) ..
(bound_job_template_236           text) ..
(bound_job_template_23d           text) ..
(bound_job_template_2dd           text) ..
(bound_monitor                    text) ..
(bound_system_core_113            text) ..
(bound_system_core_133            text) ..
(bound_system_core_13d            text) ..
(bound_system_core_1dd            text) ..
(builtin_library                  text) ..
(c170_ei_debug_table              text) ..
(c170_ei_link_map                 text) ..
(c170_ei_memory_image             text) ..
(c170_ei_memory_map               text) ..
(deadstart_library                text) ..
(installation_tools_map           text) ..
(job_image                        text) ..
(job_template_link_map            text) ..
(monitor_image                    text) ..
(non_boot_drivers                 text) ..
(nosbins                          text) ..
(nvelib                           text) ..
(ocu_bound_product                text) ..
(ocu_map                          text) ..
(operator_library                 text) ..
(sou_library                      text) ..
(system_core_debug_table          text) ..
(system_core_image                text) ..
(system_core_link_map             text) ..
(system_core_symbol_table         text) ..
(system_debug_table               text) ..
(version                          text))

var
  rav$destination_libraries : array 1..$size(rav$destination_files) of string = ..
        $array($apply(rav$destination_files, $string(x.destination_name)))
  rav$destination_format: array 1..$size(rav$destination_files) of string = ..
        $array($apply(rav$destination_files, $string(x.format)))
varend
*DECK DECK=RAF$FUF_INTERFACE_SC EXPAND=FALSE
INCLUDE_DECK D=AMP$CHANGE_FILE_ATTRIBUTES
INCLUDE_DECK D=BAP$FILE_COMMAND
INCLUDE_DECK D=CLI$COMPARE_DISPLAY_FILE_INPUT
INCLUDE_DECK D=CLP$IDENTIFY_LEXICAL_UNITS
INCLUDE_DECK D=CLP$MAKE_APPLICATION_CLT$VALUE
INCLUDE_DECK D=CLP$MAKE_APPLICATION_VALUE
INCLUDE_DECK D=CLP$MAKE_ARRAY_VALUE
INCLUDE_DECK D=CLP$MAKE_BOOLEAN_CLT$VALUE
INCLUDE_DECK D=CLP$MAKE_BOOLEAN_VALUE
INCLUDE_DECK D=CLP$MAKE_CHAR_VALUE
INCLUDE_DECK D=CLP$MAKE_CLT$BOOLEAN_VALUE
INCLUDE_DECK D=CLP$MAKE_CLT$INTEGER_VALUE
INCLUDE_DECK D=CLP$MAKE_CLT$NUMBER_VALUE
INCLUDE_DECK D=CLP$MAKE_CLT$REAL_VALUE
INCLUDE_DECK D=CLP$MAKE_CLT$VALUE
INCLUDE_DECK D=CLP$MAKE_COBOL_NAME_VALUE
INCLUDE_DECK D=CLP$MAKE_COMMAND_REF_VALUE
INCLUDE_DECK D=CLP$MAKE_DATA_NAME_VALUE
INCLUDE_DECK D=CLP$MAKE_DATE_TIME_VALUE
INCLUDE_DECK D=CLP$MAKE_DEFERRED_VALUE
INCLUDE_DECK D=CLP$MAKE_ENTRY_POINT_REF_VALUE
INCLUDE_DECK D=CLP$MAKE_FILE_CLT$VALUE
INCLUDE_DECK D=CLP$MAKE_FILE_VALUE
INCLUDE_DECK D=CLP$MAKE_INTEGER_CLT$VALUE
INCLUDE_DECK D=CLP$MAKE_INTEGER_VALUE
INCLUDE_DECK D=CLP$MAKE_KEYWORD_VALUE
INCLUDE_DECK D=CLP$MAKE_LIST_VALUE
INCLUDE_DECK D=CLP$MAKE_LOCK_VALUE
INCLUDE_DECK D=CLP$MAKE_NAME_CLT$VALUE
INCLUDE_DECK D=CLP$MAKE_NAME_VALUE
INCLUDE_DECK D=CLP$MAKE_NETWORK_TITLE_VALUE
INCLUDE_DECK D=CLP$MAKE_PROGRAM_NAME_VALUE
INCLUDE_DECK D=CLP$MAKE_RANGE_VALUE
INCLUDE_DECK D=CLP$MAKE_REAL_CLT$VALUE
INCLUDE_DECK D=CLP$MAKE_REAL_VALUE
INCLUDE_DECK D=CLP$MAKE_RECORD_VALUE
INCLUDE_DECK D=CLP$MAKE_SCU_LINE_ID_VALUE
INCLUDE_DECK D=CLP$MAKE_SIZED_STRING_VALUE
INCLUDE_DECK D=CLP$MAKE_STATISTIC_CODE_VALUE
INCLUDE_DECK D=CLP$MAKE_STATUS_CLT$VALUE
INCLUDE_DECK D=CLP$MAKE_STATUS_CODE_VALUE
INCLUDE_DECK D=CLP$MAKE_STATUS_VALUE
INCLUDE_DECK D=CLP$MAKE_STRING_PATTERN_VALUE
INCLUDE_DECK D=CLP$MAKE_STRING_VALUE
INCLUDE_DECK D=CLP$MAKE_TIME_INCREMENT_VALUE
INCLUDE_DECK D=CLP$MAKE_TIME_ZONE_VALUE
INCLUDE_DECK D=CLP$MAKE_TRIMMED_STRING_VALUE
INCLUDE_DECK D=CLP$MAKE_TYPE_SPEC_VALUE
INCLUDE_DECK D=CLP$MAKE_UNSPECIFIED_VALUE
INCLUDE_DECK D=CLP$MAKE_VALUE
INCLUDE_DECK D=CLT$LEXICAL_UNIT
INCLUDE_DECK D=CLT$LEXICAL_UNITS
INCLUDE_DECK D=CLV$NIL_DISPLAY_CONTROL
INCLUDE_DECK D=CLV$NON_DECIMAL_DIGIT
INCLUDE_DECK D=CLV$NON_ZERO_DIGIT
INCLUDE_DECK D=FSP$SUBSYSTEM_COPY_FILE
INCLUDE_DECK D=I#BUILD_ADAPTABLE_ARRAY_PTR
INCLUDE_DECK D=I#BUILD_ADAPTABLE_HEAP_POINTER
INCLUDE_DECK D=I#COMPARE
INCLUDE_DECK D=I#CURRENT_SEQUENCE_POSITION
INCLUDE_DECK D=I#PROGRAM_ERROR
INCLUDE_DECK D=I#PTR
INCLUDE_DECK D=I#REL
INCLUDE_DECK D=I#SYNC
INCLUDE_DECK D=I#TEST_ALTER_CONDITION_REG
INCLUDE_DECK D=I#TEST_SET_BIT
INCLUDE_DECK D=JMH$CONVERT_DATE_TIME_DIF_TO_US
INCLUDE_DECK D=JMP$CONVERT_DATE_TIME_DIF_TO_US
INCLUDE_DECK D=JMP$CONVERT_DATE_TIME_TO_CLOCK
INCLUDE_DECK D=JMT$CLOCK_TIME
INCLUDE_DECK D=MMH$FETCH_SEGMENT_ATTRIBUTES
INCLUDE_DECK D=MMP$FETCH_SEGMENT_ATTRIBUTES
INCLUDE_DECK D=NAP$PARSE_ACCOUNTING_DATA
INCLUDE_DECK D=NAT$ACCOUNTING_DATA_FIELDS
INCLUDE_DECK D=NAT$ACCOUNTING_DATA_KIND
INCLUDE_DECK D=NLP$NAME_MATCH
INCLUDE_DECK D=OFH$GET_DISPLAY_STATUS_MESSAGE
INCLUDE_DECK D=OFP$GET_DISPLAY_MESSAGE_HELPER
INCLUDE_DECK D=OFT$DISPLAY_MESSAGE
INCLUDE_DECK D=OSM$LOCK_MANAGER
INCLUDE_DECK D=OSP$ADD_TO_LOCKED_VARIABLE
INCLUDE_DECK D=OSP$CLEAR_LOCKED_VARIABLE
INCLUDE_DECK D=OSP$DECREMENT_LOCKED_VARIABLE
INCLUDE_DECK D=OSP$DISESTABLISH_COND_HANDLER
INCLUDE_DECK D=OSP$ESTABLISH_BLOCK_EXIT_HNDLR
INCLUDE_DECK D=OSP$FETCH_LOCKED_VARIABLE
INCLUDE_DECK D=OSP$GET_LOCKED_VARIABLE_VALUE
INCLUDE_DECK D=OSP$INCREMENT_LOCKED_VARIABLE
INCLUDE_DECK D=OSP$SET_LOCKED_VARIABLE
INCLUDE_DECK D=PME$SYSTEM_TIME_EXCEPTIONS
INCLUDE_DECK D=PMP$CAUSE_TASK_CONDITION
INCLUDE_DECK D=PMP$GET_DATE_TIME_AT_TIMESTAMP
INCLUDE_DECK D=PMT$USE_TIME_ZONE
*DECK DECK=RAF$I_S_LIBRARIES EXPAND=FALSE
" This list of libraaries has been replaced by a deck in PROCS with the name
" WET$I_S_LIBRARY_LIST
*DECK DECK=RAF$JOB_TEMPLATE_LINKER_COMNDS EXPAND=FALSE
      set_link_options link_map=$fname(map_file_string) starting_segment=26 ..
            linked_symbols=gate gate_ring_level=4 build_level=version_id ..
            create_only_predefined_segments=true cybil_parameter_checking=source

" Feature OBJECT_PARAMETER_VERIFICATION has eliminated the need to add
" delete_declaration_matching linker directives. See the increment plan
" ARH7931 for details.

      include_linked_symbols pointer=lov$task_services_entry_points section..
        =      oss$job_paged_literal
      initialize_heap_pointer pointer=osv$job_pageable_heap segment_number=4
      initialize_heap_pointer pointer=osv$task_private_heap segment_number=5
      initialize_heap_pointer pointer=osv$task_shared_heap segment_number=6
      add_object_file file=$fname(ol_job_template_223) ring_brackets=(2, 2, 3..
        ) global_local_key=(0, 0) execute_privilege=local default_sections=(..
        (re_223, r, e), (rb_xxx, r, b), (re_223, r), (oss$job_pageable, r, w))
      add_object_file file=$fname(ol_job_template_236) ring_brackets=(2, 3, ..
        6) global_local_key=(0, 0) execute_privilege=local default_sections=..
        ((re_23x, r, e), (rb_xxx, r, b), (re_23x, r), (oss$task_private, r, w..
        ))
      add_object_file file=$fname(ol_job_template_23d) ring_brackets=(2, 3, ..
        13) global_local_key=(0, 0) execute_privilege=local default_sections=..
        ((re_23x, r, e), (rb_xxx, r, b), (re_23x, r), (oss$task_private, r, w..
        ))
"addof file=job_template_266 rb=(2,6,6) glk=(0,0) ep=l ..."
"ds=((RE_26X,R,E),(RB_XXX,R,B),(RE_26X,R),(OSS$TASK_SHARED,R,W))"
      add_object_file file=$fname(ol_job_template_2dd) ring_brackets=(2, 13..
        , 13) global_local_key=(0, 0) execute_privilege=local ..
        default_sections=((re_2dd, r, e), (rb_xxx, r, b), (re_2dd, r), (..
        oss$task_shared, r, w))
      use_object_library l=$fname(ol_message_templates) rb=(2, 13, 13) ..
        glk=(0, 0) execute_privilege=local ..
        ds=((re_2dd, r, e), (rb_xxx, r, b), (re_2dd, r), (oss$task_shared, r, w))
      define_segment attributes=(rd, wt) ring_brackets=(2, 3, 3) number=4..
         section_name=(oss$job_pageable) global_local_key=(0, 0)
      define_segment attributes=(rd, wt) ring_brackets=(3, 13, 13) number=5 ..
        section_name=(oss$task_private) global_local_key=(0, 0)
      define_segment attributes=(rd, wt) ring_brackets=(3, 13, 13) number..
        =6 section_name=(oss$task_shared) global_local_key=(0, 0)
      define_segment attributes=(rd, lp) ring_brackets=(2, 2, 3) number=26 ..
        section_name=(re_223) global_local_key=(0, 0)
      define_segment attributes=(bi) ring_brackets=(2, 13, 13) number=27 ..
        section_name=(rb_xxx, binding) global_local_key=(0, 0)
      define_segment attributes=(rd, lp) ring_brackets=(2, 3, 13) number=28 ..
        section_name=(re_23x) global_local_key=(0, 0)
      define_segment attributes=(rd, lp) ring_brackets=(2, 13, 13) number=29..
         section_name=(re_2dd) global_local_key=(0, 0)
      define_segment attributes=(rd) ring_brackets=(2,13,13) number=11 ..
         global_local_key=(0,0) section_names=(..
         oss$mainframe_paged_literal,oss$job_paged_literal,cls$pdt, ..
         cls$pdt_names_and_defaults,cls$pdt_parameters,cls$adt, ..
          cls$adt_names_and_defaults, cls$declaration_section ..
         mlsreadl, cys$run_time_space)
      use_symbol_table $fname(system_symbols_string)
      set_symbol_table_id $fname(system_symbols_string)
      use_debug_table $fname(system_core_debug_table)
      include_debug_table pointer=osv$debug_table section=oss$job_paged_literal
      include_message_module module=osm$message_template_module ..
        pointer=osv$built_in_message_templates section=oss$job_paged_literal

" The pointers for the following message modules are defined in
" osm$message_module_pointers.

      include_message_module module=clm$sys_messages$us_english ..
        pointer=clv$system_messages_module section=oss$job_paged_literal
      include_message_module module=cmm$action_messages$us_english ..
        pointer=cmv$action_messages section=oss$job_paged_literal
      include_message_module module=fsm$wait_messages$us_english ..
        pointer=fsv$wait_messages section=oss$job_paged_literal
      include_message_module module=pfm$chacc_output$us_english ..
        pointer=pfv$chacc_output section=oss$job_paged_literal
      include_message_module module=pfm$movc_insuf_space$us_english ..
        pointer=pfv$movc_insuf_space section=oss$job_paged_literal
      include_message_module module=pfm$movc_no_space$us_english ..
        pointer=pfv$movc_no_space section=oss$job_paged_literal
      include_message_module module=pum$delete_all_files$us_english ..
        pointer=puv$delete_all_files_message section=oss$job_paged_literal
      include_message_module module=rmm$action_messages$us_english ..
        pointer=rmv$action_messages section=oss$job_paged_literal
      include_message_module module=rmm$crebuv_buv_menu$us_english ..
        pointer=rmv$crebuv_buv_menu section=oss$job_paged_literal
      include_message_module module=rmm$crebuv_le_menu$us_english ..
        pointer=rmv$crebuv_le_menu section=oss$job_paged_literal
      include_message_module module=rmm$crebuv_lu_menu$us_english ..
        pointer=rmv$crebuv_lu_menu section=oss$job_paged_literal
      include_message_module module=rmm$crebuv_urv_menu$us_english ..
        pointer=rmv$crebuv_urv_menu section=oss$job_paged_literal
      include_message_module module=rmm$crebuv_uv_menu$us_english ..
        pointer=rmv$crebuv_uv_menu section=oss$job_paged_literal
      include_message_module module=rmm$dedicated_maint$us_english ..
        pointer=rmv$dedicated_maintenance section=oss$job_paged_literal
      include_message_module module=rmm$extend_labeled$us_english ..
        pointer=rmv$extend_labeled_vol_list section=oss$job_paged_literal
      include_message_module module=rmm$extend_unlabeled$us_english ..
        pointer=rmv$extend_unlabeled_vol_list section=oss$job_paged_literal
      include_message_module module=rmm$generic_err_rec$us_english ..
        pointer=rmv$generic_error_recovery section=oss$job_paged_literal
      include_message_module module=rmm$incorrect_rvsn$us_english ..
        pointer=rmv$incorrect_recorded_vsn section=oss$job_paged_literal
      include_message_module module=rmm$initv_exp_menu$us_english ..
        pointer=rmv$initv_exp_menu section=oss$job_paged_literal
      include_message_module module=rmm$initv_re_menu$us_english ..
        pointer=rmv$initv_re_menu section=oss$job_paged_literal
      include_message_module module=rmm$initv_ul_menu$us_english ..
        pointer=rmv$initv_ul_menu section=oss$job_paged_literal
      include_message_module module=rmm$initv_unexp_menu$us_english ..
        pointer=rmv$initv_unexp_menu section=oss$job_paged_literal
      include_message_module module=rmm$job_status_msgs$us_english ..
        pointer=rmv$job_status_messages section=oss$job_paged_literal
      include_message_module module=rmm$loadpt_err_rec$us_english ..
        pointer=rmv$loadpoint_error_recovery section=oss$job_paged_literal
      include_message_module module=rmm$manual_maint$us_english ..
        pointer=rmv$manual_tape_maintenance section=oss$job_paged_literal
      include_message_module module=rmm$reserve_tape$us_english ..
        pointer=rmv$reserve_tape section=oss$job_paged_literal
      include_message_module module=rmm$robotic_monopoly$us_english ..
        pointer=rmv$robotic_element_monopoly section=oss$job_paged_literal
      include_message_module module=rmm$robotic_maint$us_english ..
        pointer=rmv$robotic_tape_maintenance section=oss$job_paged_literal
      include_message_module module=rmm$write_disabled$us_english ..
        pointer=rmv$robotic_write_disabled section=oss$job_paged_literal
      include_message_module module=rmm$vol_classify$us_english ..
        pointer=rmv$volume_classification section=oss$job_paged_literal
      include_message_module module=rmm$write_error_recy$us_english ..
        pointer=rmv$write_error_recovery section=oss$job_paged_literal
      include_message_module module=rmm$wrong_label_type$us_english ..
        pointer=rmv$wrong_label_type section=oss$job_paged_literal
      include_message_module module=rsm$extend_labeled$us_english ..
        pointer=rsv$extend_labeled_message section=oss$job_paged_literal
      include_message_module module=rsm$extend_unlabeled$us_english ..
        pointer=rsv$extend_unlabeled_message section=oss$job_paged_literal
      generate_virtual_memory $fname(jt_virtual_memory_string) ..
        debug_table=$fname(system_debug_table)

*DECK DECK=RAF$LINKER_DIRECTIVES EXPAND=TRUE
"
"  This deck collects the linker directives for linking the OS onto specific files to be used by link_operating_system.
"  This deck should be expanded and then do an 'include_file' to create the various linker command files.
"  Create the variables that contain the files names for the linker directives for the separate links.
"
"  NOTE: There is a very tight coupling between this deck and the procedure link_operating_system due to the
"  variables created by this deck.
"

create_variable monitor_linker_commands k=string value='$local.'//$unique
create_variable system_core_linker_commands k=string value='$local.'//$unique
create_variable build_real_memory_commands k=string value='$local.'//$unique
create_variable job_template_linker_commands k=string value='$local.'//$unique

COLLECT_TEXT o=$fname(monitor_linker_commands) u='**END**' p=''
*copy raf$monitor_linker_commands
**END**

COLLECT_TEXT o=$fname(system_core_linker_commands) u='**END**' p=''
*copy raf$system_core_linker_commands
**END**

COLLECT_TEXT o=$fname(build_real_memory_commands) u='**END**' p=''
*copy raf$build_real_memory_commands
**END**

COLLECT_TEXT o=$fname(job_template_linker_commands) u='**END**' p=''
*copy raf$job_template_linker_comnds
**END**
*DECK DECK=RAF$LINK_EI EXPAND=TRUE
create_variable ei_symbol_table kind=string value=$unique
create_variable ei_virtual_memory kind=string value=$unique
link_virtual_environment
  set_link_option ls=all sp=osp$prepare_os_environment ..
    lm=$fname(wev$working_catalog//'.'//wev$working_build_level//'.C170_EI_LINK_MAP')
  define_segment a=(bi wt gp) rb=(1 1 1) n=5 sn=c180ei ibc=yes
  define_segment a=(rd wt) rb=(1 1 1) n=4 sn=stackseg
  define_segment a=(rd wt) rb=(1 1 1) n=3 sn=osseg
  define_segment a=(rd wt) rb=(1 1 1) n=0 sn=pgtable
  use_object_library $fname(wev$working_catalog//'.'//wev$working_build_level..
//'.MAINTENANCE.OSF$C170_EI') rb=(1 1 1)
  generate_virtual_memory ..
    $fname(ei_virtual_memory) ..
    $fname(ei_symbol_table)
quit

build_real_memory
  set_build_options la=0 ps=2048 bei=yes bla=(monitor osv$ei_load_size_in_bytes) ..
    mm=$fname(wev$working_catalog//'.'//wev$working_build_level//'.C170_EI_MEMORY_MAP')
  load_monitor $fname(ei_virtual_memory)  $fname(ei_symbol_table)
  display_memory all
  generate_real_memory ..
    rmi=$fname(wev$working_catalog//'.'//wev$working_build_level//'.C170_EI_MEMORY_IMAGE')
quit
detach_file $fname(ei_symbol_table)
detach_file $fname(ei_virtual_memory)
*DECK DECK=RAF$LINK_EI_DIRECTIVES EXPAND=TRUE
collect_text $fname(ei_linker_commands) until='**END_COLLECT**'
  set_link_option linked_symbols=all starting_procedure=osp$prepare_os_environment ..
    link_map=$fname(link_map) link_map_options=all
  define_segment attributes=(bi wt gp) ring_brackets=(1 1 1) number=5 section_name=c180ei inhibit_binding_check=true
  define_segment attributes=(rd wt) ring_brackets=(1 1 1) number=4 section_name=stackseg
  define_segment attributes=(rd wt) ring_brackets=(1 1 1) number=3 section_name=osseg
  define_segment attributes=(rd wt) ring_brackets=(1 1 1) number=0 section_name=pgtable
  use_object_library library=$fname(c170_ei_ol) ring_brackets=(1 1 1)
  generate_virtual_memory virtual_image=$fname(ei_virtual_memory) symbol_table=$fname(ei_symbol_table) ..
        debug_table=$fname(debug_table)
**END_COLLECT**

collect_text $fname(ei_real_memory_commands) until='**END_COLLECT**'
  set_build_options load_address=0 page_size=2048 building_environment_interface=yes ..
       bytes_loaded_address=(monitor osv$ei_load_size_in_bytes) ..
       memory_map=$fname(memory_map)
  load_monitor virtual_image=$fname(ei_virtual_memory) symbol_table=$fname(ei_symbol_table)
  display_memory memory=all
  generate_real_memory real_memory_image=$fname(memory_image)
**END_COLLECT**
*DECK DECK=RAF$MONITOR_LINKER_COMMANDS EXPAND=FALSE
      set_link_options link_map=$fname(map_file_string) starting_segment=6 ..
            build_level=build_id exchange_package_variable=mtv$monitor_exchange_package ..
            create_only_predefined_segments=true cybil_parameter_checking=source
      initialize_build_level name=osv$build_level
      initialize_heap_pointer p=osv$mainframe_wired_cb_heap sn=12(16)
      initialize_heap_pointer p=osv$mainframe_wired_heap sn=wired_segment
      initialize_heap_pointer p=nav$network_wired_heap sn=7
      add_object_file file=$fname(ol_monitor) ring_brackets=(1, 1, 3) ..
        global_local_key=(0, 0) execute_privilege=global default_sections=((..
        re_mtr, r, e), (rb_mtr, r, b), (re_mtr, r), (rw_mtr, r, w))
      define_segment attributes=(rd, wt, cb) ring_brackets=(1, 3, 3) number..
        =        wired_segment section_names=(rw_mtr, oss$mainframe_wired, ..
        oss$mainframe_wired_literal) global_local_key=(0, 0)
      define_segment attributes=(rd, wt, cb) ring_brackets=(1, 3, 3) ..
        number=12(16) section_name=oss$mainframe_wired_cb global_local_key=(0, 0)
      define_segment attributes=(bi, wt, gp) ring_brackets=(1, 1, 1) number=5..
         section_name=(oss$nos_trap_handler) global_local_key=(0, 0) ..
        inhibit_binding_check=true
      define_segment attributes=(gp,bi) ring_brackets=(1,1,1) number=6 ..
        section_names=(re_mtr,rb_mtr) global_local_key=(0,0) ..
        inhibit_binding_check=true
      define_segment attributes=(rd,wt,cb) ring_brackets=(3,3,3) number=7 ..
      section_names=(oss$network_wired dfs$server_wired) global_local_key=(0,0)
      define_segment attributes=(et,rd,wt) ring_brackets=(1,1,1) number=8 ..
      section_names=(mts$monitor_stack) global_local_key=(0,0)
      define_segment attributes=(rd, wt, gp) ring_brackets=(1,1,1) number=9 ..
        section_names=(c180ei) global_local_key=(0,0)
      initialize_symbol_table_id jmv$system_core_id
      generate_virtual_memory $fname(monitor_virtual_memory_string) ..
        symbol_table=        $fname(monitor_symbols_string) ..
        debug_table= $fname(monitor_debug_table)
*DECK DECK=RAF$OS_LIBRARIES EXPAND=FALSE
"
"  Define varible rav$os_libraries which contains the names of the libraries that make up the boot, the monitor,
"  system core and job template of the NOS/VE operating system.
"

  create_variable rav$os_libraries k=(string, $max_name) d=11

  rav$os_libraries(1) = 'osf$boot_monitor'
  rav$os_libraries(2) = 'osf$boot_job'
  rav$os_libraries(3) = 'osf$monitor'
  rav$os_libraries(4) = 'osf$system_core_113'
  rav$os_libraries(5) = 'osf$system_core_133'
  rav$os_libraries(6) = 'osf$system_core_13d'
  rav$os_libraries(7) = 'osf$system_core_1dd'
  rav$os_libraries(8) = 'osf$job_template_223'
  rav$os_libraries(9) = 'osf$job_template_236'
  rav$os_libraries(10) = 'osf$job_template_23d'
  rav$os_libraries(11) = 'osf$job_template_2dd'

*DECK DECK=RAF$PROGRAM_INTERFACE_SC EXPAND=FALSE
INCLUDE_DECK D= AMC$CONDITION_CODE_LIMITS
INCLUDE_DECK D= AMC$MAXIMUM_BLOCK
INCLUDE_DECK D= AMC$MAXIMUM_KEYED_RECORD
INCLUDE_DECK D= AMC$MAX_FAP_LAYERS
INCLUDE_DECK D= AMC$MAX_KEY_POSITION
INCLUDE_DECK D= AMC$MAX_LINES_PER_INCH
INCLUDE_DECK D= AMC$MAX_USER_INFO
INCLUDE_DECK D= AMC$MAX_VOL_NUMBER
INCLUDE_DECK D= AMD$BLOCK_HEADERS
INCLUDE_DECK D= AMD$FILE_ATTRIBUTES
INCLUDE_DECK D= AMD$FILE_CONTENTS
INCLUDE_DECK D= AMD$FILE_PROCESSOR
INCLUDE_DECK D= AMD$FILE_STRUCTURE
INCLUDE_DECK D= AMD$INFORMATION
INCLUDE_DECK D= AMD$MAX_BLOCKS_PER_FILE
INCLUDE_DECK D= AMD$OPEN_DECLARATIONS
INCLUDE_DECK D= AMD$OPERATION_DECLARATIONS
INCLUDE_DECK D= AMD$PAGE_FORMAT_DECLARATIONS
INCLUDE_DECK D= AMD$SKIP_DECLARATIONS
INCLUDE_DECK D= AME$ACCESS_VALIDATION_ERRORS
INCLUDE_DECK D= AME$ALLOCATE_PROGRAM_ACTIONS
INCLUDE_DECK D= AME$ALLOCATE_VALIDATION_ERRORS
INCLUDE_DECK D= AME$ATTRIBUTE_VALIDATION_ERRORS
INCLUDE_DECK D= AME$CONDITION_CODES
INCLUDE_DECK D= AME$CONFLICTING_ACCESS_LEVEL
INCLUDE_DECK D= AME$COPY_VALIDATION_ERRORS
INCLUDE_DECK D= AME$DEVICE_CLASS_VALIDATION
INCLUDE_DECK D= AME$EVICT_PROGRAM_ACTIONS
INCLUDE_DECK D= AME$EVICT_VALIDATION_ERRORS
INCLUDE_DECK D= AME$FAP_PROGRAM_ACTIONS
INCLUDE_DECK D= AME$FAP_VALIDATION_ERRORS
INCLUDE_DECK D= AME$FILE_ORGANIZATION_ERRORS
INCLUDE_DECK D= AME$GET_PROGRAM_ACTIONS
INCLUDE_DECK D= AME$GET_VALIDATION_ERRORS
INCLUDE_DECK D= AME$IMPROPER_ACCESS_INFO_KEY
INCLUDE_DECK D= AME$IMPROPER_FILE_ID
INCLUDE_DECK D= AME$IMPROPER_RANDOM_ACCESS
INCLUDE_DECK D= AME$IMPROPER_WSL
INCLUDE_DECK D= AME$LABEL_VALIDATION_ERRORS
INCLUDE_DECK D= AME$LFN_PROGRAM_ACTIONS
INCLUDE_DECK D= AME$OPEN_VALIDATION_ERRORS
INCLUDE_DECK D= AME$PUT_PROGRAM_ACTIONS
INCLUDE_DECK D= AME$PUT_VALIDATION_ERRORS
INCLUDE_DECK D= AME$RENAME_PROGRAM_ACTIONS
INCLUDE_DECK D= AME$RING_VALIDATION_ERRORS
INCLUDE_DECK D= AME$SEGMENT_VALIDATION_ERRORS
INCLUDE_DECK D= AME$SKIP_PROGRAM_ACTIONS
INCLUDE_DECK D= AME$SKIP_VALIDATION_ERRORS
INCLUDE_DECK D= AME$STORE_PROGRAM_ACTIONS
INCLUDE_DECK D= AME$TAPE_PROGRAM_ACTIONS
INCLUDE_DECK D= AME$TERMINAL_VALIDATION_ERRORS
INCLUDE_DECK D= AME$UNIMPLEMENTED_REQUEST
INCLUDE_DECK D= AME$WRITE_EOP_VALIDATION_ERRORS
INCLUDE_DECK D= AME$WTMK_VALIDATION_ERRORS
INCLUDE_DECK D= AMH$ABORT_FILE_PARCEL
INCLUDE_DECK D= AMH$ACCESS_METHOD
INCLUDE_DECK D= AMH$ADD_TO_FILE_DESCRIPTION
INCLUDE_DECK D= AMH$BEGIN_FILE_PARCEL
INCLUDE_DECK D= AMH$CLOSE
INCLUDE_DECK D= AMH$CLOSE_VOLUME
INCLUDE_DECK D= AMH$COMMIT_FILE_PARCEL
INCLUDE_DECK D= AMH$COPY_FILE
INCLUDE_DECK D= AMH$FETCH
INCLUDE_DECK D= AMH$FETCH_ACCESS_INFORMATION
INCLUDE_DECK D= AMH$FETCH_FAP_POINTER
INCLUDE_DECK D= AMH$FILE
INCLUDE_DECK D= AMH$FLUSH
INCLUDE_DECK D= AMH$GET_DIRECT
INCLUDE_DECK D= AMH$GET_FILE_ATTRIBUTES
INCLUDE_DECK D= AMH$GET_NEXT
INCLUDE_DECK D= AMH$GET_PARTIAL
INCLUDE_DECK D= AMH$GET_SEGMENT_POINTER
INCLUDE_DECK D= AMH$LOCK_FILE
INCLUDE_DECK D= AMH$OPEN
INCLUDE_DECK D= AMH$PUT_DIRECT
INCLUDE_DECK D= AMH$PUT_NEXT
INCLUDE_DECK D= AMH$PUT_PARTIAL
INCLUDE_DECK D= AMH$REPLACE_PREVIOUS_RECORD
INCLUDE_DECK D= AMH$RETURN
INCLUDE_DECK D= AMH$REWIND
INCLUDE_DECK D= AMH$SEEK_DIRECT
INCLUDE_DECK D= AMH$SET_FILE_INSTANCE_ABNORMAL
INCLUDE_DECK D= AMH$SET_LOCAL_NAME_ABNORMAL
INCLUDE_DECK D= AMH$SET_SEGMENT_EOI
INCLUDE_DECK D= AMH$SET_SEGMENT_POSITION
INCLUDE_DECK D= AMH$SKIP
INCLUDE_DECK D= AMH$SKIP_TAPE_MARKS
INCLUDE_DECK D= AMH$STORE
INCLUDE_DECK D= AMH$STORE_FAP_POINTER
INCLUDE_DECK D= AMH$UNLOCK_FILE
INCLUDE_DECK D= AMH$VALIDATE_CALLER_PRIVILEGE
INCLUDE_DECK D= AMH$WRITE_END_PARTITION
INCLUDE_DECK D= AMH$WRITE_TAPE_MARK
INCLUDE_DECK D= AMP$ABANDON_KEY_DEFINITIONS
INCLUDE_DECK D= AMP$ABORT_FILE_PARCEL
INCLUDE_DECK D= AMP$ACCESS_METHOD
INCLUDE_DECK D= AMP$ADD_TO_FILE_DESCRIPTION
INCLUDE_DECK D= AMP$APPLY_KEY_DEFINITIONS
INCLUDE_DECK D= AMP$BEGIN_FILE_PARCEL
INCLUDE_DECK D= AMP$CLOSE
INCLUDE_DECK D= AMP$CLOSE_VOLUME
INCLUDE_DECK D= AMP$COMMIT_FILE_PARCEL
INCLUDE_DECK D= AMP$COPY_FILE
INCLUDE_DECK D= AMP$CREATE_KEY_DEFINITION
INCLUDE_DECK D= AMP$CREATE_NESTED_FILE
INCLUDE_DECK D= AMP$DELETE_KEY_DEFINITION
INCLUDE_DECK D= AMP$DELETE_NESTED_FILE
INCLUDE_DECK D= AMP$ERASE_TAPE_BLOCK
INCLUDE_DECK D= AMP$FETCH
INCLUDE_DECK D= AMP$FETCH_ACCESS_INFORMATION
INCLUDE_DECK D= AMP$FETCH_FAP_POINTER
INCLUDE_DECK D= AMP$FETCH_NESTED_FILE_ATTRIB
INCLUDE_DECK D= AMP$FILE
INCLUDE_DECK D= AMP$FIND_RECORD_SPACE
INCLUDE_DECK D= AMP$FLUSH
INCLUDE_DECK D= AMP$GET_DIRECT
INCLUDE_DECK D= AMP$GET_FILE_ATTRIBUTES
INCLUDE_DECK D= AMP$GET_KEY_DEFINITIONS
INCLUDE_DECK D= AMP$GET_LOCK_KEYED_RECORD
INCLUDE_DECK D= AMP$GET_LOCK_NEXT_KEYED_RECORD
INCLUDE_DECK D= AMP$GET_NESTED_FILE_DEFINITIONS
INCLUDE_DECK D= AMP$GET_NEXT
INCLUDE_DECK D= AMP$GET_NEXT_PRIMARY_KEY_LIST
INCLUDE_DECK D= AMP$GET_PARTIAL
INCLUDE_DECK D= AMP$GET_PRIMARY_KEY_COUNT
INCLUDE_DECK D= AMP$GET_SEGMENT_POINTER
INCLUDE_DECK D= AMP$GET_SPACE_USED_FOR_KEY
INCLUDE_DECK D= AMP$LOCK_FILE
INCLUDE_DECK D= AMP$LOCK_KEY
INCLUDE_DECK D= AMP$OPEN
INCLUDE_DECK D= AMP$PUT_DIRECT
INCLUDE_DECK D= AMP$PUT_NEXT
INCLUDE_DECK D= AMP$PUT_PARTIAL
INCLUDE_DECK D= AMP$REPLACE_PREVIOUS_RECORD
INCLUDE_DECK D= AMP$RETURN
INCLUDE_DECK D= AMP$REWIND
INCLUDE_DECK D= AMP$SEEK_DIRECT
INCLUDE_DECK D= AMP$SELECT_KEY
INCLUDE_DECK D= AMP$SELECT_NESTED_FILE
INCLUDE_DECK D= AMP$SET_FILE_INSTANCE_ABNORMAL
INCLUDE_DECK D= AMP$SET_LOCAL_NAME_ABNORMAL
INCLUDE_DECK D= AMP$SET_SEGMENT_EOI
INCLUDE_DECK D= AMP$SET_SEGMENT_POSITION
INCLUDE_DECK D= AMP$SKIP
INCLUDE_DECK D= AMP$SKIP_TAPE_MARKS
INCLUDE_DECK D= AMP$STORE
INCLUDE_DECK D= AMP$STORE_FAP_POINTER
INCLUDE_DECK D= AMP$UNLOCK_FILE
INCLUDE_DECK D= AMP$UNLOCK_KEY
INCLUDE_DECK D= AMP$VALIDATE_CALLER_PRIVILEGE
INCLUDE_DECK D= AMP$WRITE_END_PARTITION
INCLUDE_DECK D= AMP$WRITE_TAPE_MARK
INCLUDE_DECK D= AMT$ACCESS_INFO
INCLUDE_DECK D= AMT$ACCESS_INFORMATION
INCLUDE_DECK D= AMT$ACCESS_INFO_KEYS
INCLUDE_DECK D= AMT$ACCESS_LEVEL
INCLUDE_DECK D= AMT$ADD_TO_ATTRIBUTES
INCLUDE_DECK D= AMT$ALLOCATION_MODE
INCLUDE_DECK D= AMT$ATTRIBUTE_SOURCE
INCLUDE_DECK D= AMT$AVERAGE_RECORD_LENGTH
INCLUDE_DECK D= AMT$BASIC_KEY_DEFINITION
INCLUDE_DECK D= AMT$BEGIN_FILE_PARCEL
INCLUDE_DECK D= AMT$BLOCK_NUMBER
INCLUDE_DECK D= AMT$BLOCK_TYPE
INCLUDE_DECK D= AMT$BUFFER_AREA
INCLUDE_DECK D= AMT$BUFFER_LENGTH
INCLUDE_DECK D= AMT$CALL_BLOCK
INCLUDE_DECK D= AMT$CHECK_NOWAIT_REQUEST
INCLUDE_DECK D= AMT$COLLATE_TABLE
INCLUDE_DECK D= AMT$COLLATION_VALUE
INCLUDE_DECK D= AMT$COMMIT_FILE_PARCEL
INCLUDE_DECK D= AMT$COMMIT_PHASE
INCLUDE_DECK D= AMT$COMPRESSION_EFFECT
INCLUDE_DECK D= AMT$COMPRESSION_PROCEDURE
INCLUDE_DECK D= AMT$COMPRESSION_PROCEDURE_NAME
INCLUDE_DECK D= AMT$COPY_EXTENT
INCLUDE_DECK D= AMT$CREATE_KEY_DEFINITION
INCLUDE_DECK D= AMT$CREATE_NESTED_FILE
INCLUDE_DECK D= AMT$DATA_BLOCK_COUNT
INCLUDE_DECK D= AMT$DATA_PADDING
INCLUDE_DECK D= AMT$DELETE_KEY_DEFINITION
INCLUDE_DECK D= AMT$DELETE_NESTED_FILE
INCLUDE_DECK D= AMT$DUPLICATE_KEY_CONTROL
INCLUDE_DECK D= AMT$DUPLICATE_VALUE_INSERTED
INCLUDE_DECK D= AMT$DYNAMIC_HOME_BLOCK_SPACE
INCLUDE_DECK D= AMT$ENTRY_POINT_REFERENCE
INCLUDE_DECK D= AMT$ERASE_TAPE_BLOCK
INCLUDE_DECK D= AMT$ERROR_COUNT
INCLUDE_DECK D= AMT$ERROR_EXIT_PROCEDURE
INCLUDE_DECK D= AMT$ERROR_LIMIT
INCLUDE_DECK D= AMT$ESTIMATED_RECORD_COUNT
INCLUDE_DECK D= AMT$EVICT_MODE
INCLUDE_DECK D= AMT$FAP_DECLARATIONS
INCLUDE_DECK D= AMT$FAP_LAYER_NUMBER
INCLUDE_DECK D= AMT$FAP_OPERATION
INCLUDE_DECK D= AMT$FAP_POINTER
INCLUDE_DECK D= AMT$FETCH_ATTRIBUTES
INCLUDE_DECK D= AMT$FILE_ATTRIBUTES
INCLUDE_DECK D= AMT$FILE_ATTRIBUTE_KEYS
INCLUDE_DECK D= AMT$FILE_BYTE_ADDRESS
INCLUDE_DECK D= AMT$FILE_CONTENTS
INCLUDE_DECK D= AMT$FILE_IDENTIFIER
INCLUDE_DECK D= AMT$FILE_LABEL_TYPE
INCLUDE_DECK D= AMT$FILE_LENGTH
INCLUDE_DECK D= AMT$FILE_LIMIT
INCLUDE_DECK D= AMT$FILE_ORGANIZATION
INCLUDE_DECK D= AMT$FILE_PROCESSOR
INCLUDE_DECK D= AMT$FILE_POSITION
INCLUDE_DECK D= AMT$FILE_REFERENCE
INCLUDE_DECK D= AMT$FIND_RECORD_SPACE
INCLUDE_DECK D= AMT$FORCED_WRITE
INCLUDE_DECK D= AMT$GENERAL_COMMIT
INCLUDE_DECK D= AMT$GET_ATTRIBUTES
INCLUDE_DECK D= AMT$GET_KEY_DEFINITIONS
INCLUDE_DECK D= AMT$GET_LOCK_KEYED_RECORD
INCLUDE_DECK D= AMT$GET_LOCK_NEXT_KEYED_RECORD
INCLUDE_DECK D= AMT$GET_NESTED_FILE_DEFINITIONS
INCLUDE_DECK D= AMT$GET_NEXT_PRIMARY_KEY_LIST
INCLUDE_DECK D= AMT$GET_PRIMARY_KEY_COUNT
INCLUDE_DECK D= AMT$GET_SPACE_USED_FOR_KEY
INCLUDE_DECK D= AMT$GROUP_NAME
INCLUDE_DECK D= AMT$HASHING_PROCEDURE
INCLUDE_DECK D= AMT$HASHING_PROCEDURE_NAME
INCLUDE_DECK D= AMT$INDEX_LEVELS
INCLUDE_DECK D= AMT$INDEX_PADDING
INCLUDE_DECK D= AMT$INITIAL_HOME_BLOCK_COUNT
INCLUDE_DECK D= AMT$INTERNAL_CODE
INCLUDE_DECK D= AMT$KEY_COUNT_LIMIT
INCLUDE_DECK D= AMT$KEY_LENGTH
INCLUDE_DECK D= AMT$KEY_NAME
INCLUDE_DECK D= AMT$KEY_POSITION
INCLUDE_DECK D= AMT$KEY_RELATION
INCLUDE_DECK D= AMT$KEY_TYPE
INCLUDE_DECK D= AMT$KEYED_FILE_ATTRIBUTE
INCLUDE_DECK D= AMT$KEYED_FILE_ATTRIBUTES
INCLUDE_DECK D= AMT$KEYED_FILE_SEGMENT_INFO
INCLUDE_DECK D= AMT$LABEL_EXIT_PROCEDURE
INCLUDE_DECK D= AMT$LABEL_TYPE
INCLUDE_DECK D= AMT$LAST_ACCESS_OPERATION
INCLUDE_DECK D= AMT$LAST_OPERATION
INCLUDE_DECK D= AMT$LAST_OP_STATUS
INCLUDE_DECK D= AMT$LINE_NUMBER
INCLUDE_DECK D= AMT$LINE_NUMBER_LENGTH
INCLUDE_DECK D= AMT$LINE_NUMBER_LOCATION
INCLUDE_DECK D= AMT$LOADING_FACTOR
INCLUDE_DECK D= AMT$LOCAL_FILE_NAME
INCLUDE_DECK D= AMT$LOCK
INCLUDE_DECK D= AMT$LOCK_EXPIRATION_TIME
INCLUDE_DECK D= AMT$LOCK_FILE
INCLUDE_DECK D= AMT$LOCK_FILE_SCOPE
INCLUDE_DECK D= AMT$LOCK_INTENT
INCLUDE_DECK D= AMT$LOCK_KEY
INCLUDE_DECK D= AMT$LOGGING_OPTIONS
INCLUDE_DECK D= AMT$LOGGING_POSSIBILITIES
INCLUDE_DECK D= AMT$LOG_RESIDENCE
INCLUDE_DECK D= AMT$MAJOR_KEY_LENGTH
INCLUDE_DECK D= AMT$MAU_LENGTH
INCLUDE_DECK D= AMT$MAX_BLOCK_LENGTH
INCLUDE_DECK D= AMT$MAX_OPTIONAL_ATTRIBUTES
INCLUDE_DECK D= AMT$MAX_RECORD_LENGTH
INCLUDE_DECK D= AMT$MAX_REPEATING_GROUP_COUNT
INCLUDE_DECK D= AMT$MESSAGE_CONTROL
INCLUDE_DECK D= AMT$MIN_BLOCK_LENGTH
INCLUDE_DECK D= AMT$MIN_RECORD_LENGTH
INCLUDE_DECK D= AMT$NESTED_FILE_COUNT
INCLUDE_DECK D= AMT$NESTED_FILE_DEFINITION
INCLUDE_DECK D= AMT$NESTED_FILE_DEFINITIONS
INCLUDE_DECK D= AMT$NESTED_FILE_NAME
INCLUDE_DECK D= AMT$NOWAIT_VAR_PARAMETERS
INCLUDE_DECK D= AMT$OPEN_POSITION
INCLUDE_DECK D= AMT$OPEN_TAPE_VOLUME
INCLUDE_DECK D= AMT$OPTIONAL_KEY_ATTRIBUTE
INCLUDE_DECK D= AMT$OPTIONAL_KEY_ATTRIBUTES
INCLUDE_DECK D= AMT$PADDING_CHARACTER
INCLUDE_DECK D= AMT$PAGE_FORMAT
INCLUDE_DECK D= AMT$PAGE_LENGTH
INCLUDE_DECK D= AMT$PAGE_WIDTH
INCLUDE_DECK D= AMT$PATH_NAME
INCLUDE_DECK D= AMT$PHYSICAL_TRANSFER_COUNT
INCLUDE_DECK D= AMT$PHYSICAL_VOLUME_POSITION
INCLUDE_DECK D= AMT$PRESET_VALUE
INCLUDE_DECK D= AMT$PRIMARY_KEY
INCLUDE_DECK D= AMT$PUT_LOCALITY
INCLUDE_DECK D= AMT$READ_TAPE_LABELS
INCLUDE_DECK D= AMT$RECORDS_PER_BLOCK
INCLUDE_DECK D= AMT$RECORD_HEADER
INCLUDE_DECK D= AMT$RECORD_LIMIT
INCLUDE_DECK D= AMT$RECORD_TYPE
INCLUDE_DECK D= AMT$REPETITION_CONTROL
INCLUDE_DECK D= AMT$RESIDUAL_SKIP_COUNT
INCLUDE_DECK D= AMT$RING_ATTRIBUTES
INCLUDE_DECK D= AMT$SEGMENT_POINTER
INCLUDE_DECK D= AMT$SELECTED_KEY_NAME
INCLUDE_DECK D= AMT$SELECTED_NESTED_FILE
INCLUDE_DECK D= AMT$SELECT_KEY
INCLUDE_DECK D= AMT$SELECT_NESTED_FILE
INCLUDE_DECK D= AMT$SEPARATE_KEY_GROUPS
INCLUDE_DECK D= AMT$SKIP_COUNT
INCLUDE_DECK D= AMT$SKIP_DIRECTION
INCLUDE_DECK D= AMT$SKIP_OPTION
INCLUDE_DECK D= AMT$SKIP_UNIT
INCLUDE_DECK D= AMT$SPARSE_KEY_CONTROL_EFFECT
INCLUDE_DECK D= AMT$STATEMENT_IDENTIFIER
INCLUDE_DECK D= AMT$STATEMENT_ID_LENGTH
INCLUDE_DECK D= AMT$STATEMENT_ID_LOCATION
INCLUDE_DECK D= AMT$STORE_ATTRIBUTES
INCLUDE_DECK D= AMT$TAPE_ERROR_ACTION
INCLUDE_DECK D= AMT$TAPE_ERROR_OPTIONS
INCLUDE_DECK D= AMT$TAPE_FAILURE_ISOLATION
INCLUDE_DECK D= AMT$TAPE_FAILURE_MODE
INCLUDE_DECK D= AMT$TAPE_FAILURE_MODES
INCLUDE_DECK D= AMT$TAPE_MARK_COUNT
INCLUDE_DECK D= AMT$TERM_OPTION
INCLUDE_DECK D= AMT$TERMINATE_TAPE_VOLUME
INCLUDE_DECK D= AMT$TRANSFER_COUNT
INCLUDE_DECK D= AMT$UNLOCK_CONTROL
INCLUDE_DECK D= AMT$UNLOCK_KEY
INCLUDE_DECK D= AMT$UNUSED_BIT_COUNT
INCLUDE_DECK D= AMT$USER_DEFINED_ACCESS_REQUEST
INCLUDE_DECK D= AMT$USER_INFO
INCLUDE_DECK D= AMT$VERTICAL_PRINT_DENSITY
INCLUDE_DECK D= AMT$VOLUME_NUMBER
INCLUDE_DECK D= AMT$VOLUME_POSITION
INCLUDE_DECK D= AMT$WORKING_STORAGE_LENGTH
INCLUDE_DECK D= AMT$WRITE_TAPE_LABELS
INCLUDE_DECK D= AMV$NIL_FILE_IDENTIFIER
INCLUDE_DECK D= AVC$ACCOUNTING_STATISTICS
INCLUDE_DECK D= AVC$MAXIMUM_DESC_RECORD_COUNT
INCLUDE_DECK D= AVC$MAXIMUM_NAME_LIST_SIZE
INCLUDE_DECK D= AVC$MIN_ECC
INCLUDE_DECK D= AVC$SYSTEM_DEFINED_LIMIT_NAMES
INCLUDE_DECK D= AVC$VALIDATION_FIELD_NAMES
INCLUDE_DECK D= AVC$VALIDATION_RECORD_NAMES
INCLUDE_DECK D= AVE$ACCOUNT_PROJECT_MESSAGES
INCLUDE_DECK D= AVE$ADMIN_VALIDATIONS_ERRORS
INCLUDE_DECK D= AVE$CONDITION_CODES
INCLUDE_DECK D= AVE$CONSOLE_OPERATION_ONLY
INCLUDE_DECK D= AVE$DUPLICATE_SETSO_COMMAND
INCLUDE_DECK D= AVE$FAMILY_ERRORS
INCLUDE_DECK D= AVE$INITIALIZE_ERRORS
INCLUDE_DECK D= AVE$SCC_RANGE
INCLUDE_DECK D= AVE$TEMPLATE_FILE_DAMAGED
INCLUDE_DECK D= AVE$TEMPLATE_FILE_MGR_ERRORS
INCLUDE_DECK D= AVE$UNKNOWN_SECURITY_OPTION
INCLUDE_DECK D= AVE$VALIDATION_INTERFACE_ERRORS
INCLUDE_DECK D= AVH$GET_ACCOUNT_PROJECT_VALUE
INCLUDE_DECK D= AVH$GET_ACCUM_LIMIT_VALUE
INCLUDE_DECK D= AVH$GET_CAPABILITY
INCLUDE_DECK D= AVH$GET_DATE_TIME_VALUE
INCLUDE_DECK D= AVH$GET_FILE_VALUE
INCLUDE_DECK D= AVH$GET_INTEGER_VALUE
INCLUDE_DECK D= AVH$GET_JOB_CLASS_VALUE
INCLUDE_DECK D= AVH$GET_LABELED_NAMES_VALUE
INCLUDE_DECK D= AVH$GET_LIMIT_VALUE
INCLUDE_DECK D= AVH$GET_LOGIN_PASSWORD_VALUE
INCLUDE_DECK D= AVH$GET_NAME_VALUE
INCLUDE_DECK D= AVH$GET_REAL_VALUE
INCLUDE_DECK D= AVH$GET_STRING_VALUE
INCLUDE_DECK D= AVP$GET_ACCOUNT_PROJECT_VALUE
INCLUDE_DECK D= AVP$GET_ACCUM_LIMIT_VALUE
INCLUDE_DECK D= AVP$GET_CAPABILITY
INCLUDE_DECK D= AVP$GET_DATE_TIME_VALUE
INCLUDE_DECK D= AVP$GET_FILE_VALUE
INCLUDE_DECK D= AVP$GET_INTEGER_VALUE
INCLUDE_DECK D= AVP$GET_JOB_CLASS_VALUE
INCLUDE_DECK D= AVP$GET_LABELED_NAMES_VALUE
INCLUDE_DECK D= AVP$GET_LIMIT_VALUE
INCLUDE_DECK D= AVP$GET_LOGIN_PASSWORD_VALUE
INCLUDE_DECK D= AVP$GET_NAME_VALUE
INCLUDE_DECK D= AVP$GET_REAL_VALUE
INCLUDE_DECK D= AVP$GET_STRING_VALUE
INCLUDE_DECK D= AVT$ACCOUNT_NAME
INCLUDE_DECK D= AVT$DATE_TIME
INCLUDE_DECK D= AVT$JOB_LIMIT_INFORMATION
INCLUDE_DECK D= AVT$LABELED_NAMES
INCLUDE_DECK D= AVT$LABELED_NAMES_LIST
INCLUDE_DECK D= AVT$LIMIT_VALUE
INCLUDE_DECK D= AVT$LOGIN_PASSWORD
INCLUDE_DECK D= AVT$NAME_LIST
INCLUDE_DECK D= AVT$NAME_LIST_SIZE
INCLUDE_DECK D= AVT$NUMERIC_DISPLAY_FMT_KIND
INCLUDE_DECK D= AVT$NUMERIC_DISPLAY_FORMAT
INCLUDE_DECK D= AVT$PASSWORD
INCLUDE_DECK D= AVT$PROJECT_NAME
INCLUDE_DECK D= AVT$TOTAL_LIMIT_INFORMATION
INCLUDE_DECK D= AVT$VALIDATION_RECORD
INCLUDE_DECK D= CFC$ERROR_CODES_FORMATTER_RANGE
INCLUDE_DECK D= CFE$CYBIL_FORMAT_ERROR_CODES
INCLUDE_DECK D= CLC$DECLARATION_VERSION
INCLUDE_DECK D= CLC$ECC_RANGE
INCLUDE_DECK D= CLC$MAX_ARRAY_BOUND
INCLUDE_DECK D= CLC$MAX_COBOL_NAME_SIZE
INCLUDE_DECK D= CLC$MAX_COMMAND_LINE_SIZE
INCLUDE_DECK D= CLC$MAX_DATE_TIME_FORM_STRING
INCLUDE_DECK D= CLC$MAX_EXPRESSION_TEXT_SIZE
INCLUDE_DECK D= CLC$MAX_FIELDS
INCLUDE_DECK D= CLC$MAX_INTEGER
INCLUDE_DECK D= CLC$MAX_KEYWORDS
INCLUDE_DECK D= CLC$MAX_LIST_SIZE
INCLUDE_DECK D= CLC$MAX_PARAMETERS
INCLUDE_DECK D= CLC$MAX_PARAMETER_LIST_SIZE
INCLUDE_DECK D= CLC$MAX_PARAMETER_NAMES
INCLUDE_DECK D= CLC$MAX_PROC_NAMES
INCLUDE_DECK D= CLC$MAX_PROMPT_SIZE
INCLUDE_DECK D= CLC$MAX_PROMPT_STRING_SIZE
INCLUDE_DECK D= CLC$MAX_REAL_EXPONENT_DIGITS
INCLUDE_DECK D= CLC$MAX_REAL_NUMBER_DIGITS
INCLUDE_DECK D= CLC$MAX_REAL_NUMBER_SIZE
INCLUDE_DECK D= CLC$MAX_SCU_MODIFICATION_NAME
INCLUDE_DECK D= CLC$MAX_SCU_SEQUENCE_NUMBER
INCLUDE_DECK D= CLC$MAX_STRING_SIZE
INCLUDE_DECK D= CLC$MAX_TYPE_SPECIFICATION_SIZE
INCLUDE_DECK D= CLC$MAX_UNION_MEMBERS
INCLUDE_DECK D= CLC$MIN_ARRAY_BOUND
INCLUDE_DECK D= CLC$MIN_INTEGER
INCLUDE_DECK D= CLC$STANDARD_FILE_NAMES
INCLUDE_DECK D= CLD$APPLICATION_VALUE_SCANNER
INCLUDE_DECK D= CLD$PARAMETER_LIMITS
INCLUDE_DECK D= CLD$PARAMETER_LIST
INCLUDE_DECK D= CLD$PATH_DESCRIPTION
INCLUDE_DECK D= CLD$PROC_DECLARATION
INCLUDE_DECK D= CLD$VALUE
INCLUDE_DECK D= CLD$VARIABLE_REFERENCE
INCLUDE_DECK D= CLE$ALL_MUST_BE_USED_ALONE
INCLUDE_DECK D= CLE$AWAITING_TASK_TERMINATION
INCLUDE_DECK D= CLE$BAD_APPLICATION_TASK_LINK
INCLUDE_DECK D= CLE$BAD_CLT$VALUE
INCLUDE_DECK D= CLE$BAD_CLT$VARIABLE_VALUE
INCLUDE_DECK D= CLE$BAD_DATA_REP_OPTION
INCLUDE_DECK D= CLE$BAD_DATA_VALUE
INCLUDE_DECK D= CLE$BAD_DECLARATION_VERSION
INCLUDE_DECK D= CLE$BAD_INTERNAL_VALUE
INCLUDE_DECK D= CLE$BAD_KEYWORD_TYPE_SPEC
INCLUDE_DECK D= CLE$BAD_PARAMETER_LIST
INCLUDE_DECK D= CLE$BAD_PDT
INCLUDE_DECK D= CLE$BAD_PVT
INCLUDE_DECK D= CLE$BAD_STRING_PATTERN
INCLUDE_DECK D= CLE$BAD_TYPE_DESCRIPTION
INCLUDE_DECK D= CLE$BAD_TYPE_SPECIFICATION
INCLUDE_DECK D= CLE$BAD_UNSEEN_MAIL_ACTION
INCLUDE_DECK D= CLE$BAD_WILD_CARD_PATTERN
INCLUDE_DECK D= CLE$BLOCK_ACCESS_COUNT_ERROR
INCLUDE_DECK D= CLE$CANNOT_ACCESS_UNIT_ARRAY
INCLUDE_DECK D= CLE$COMMAND_CANCELLED
INCLUDE_DECK D= CLE$COMMAND_LINE_CANCELLED
INCLUDE_DECK D= CLE$COMMAND_TERMINATED
INCLUDE_DECK D= CLE$COMPARED_FILES_UNEQUAL_SIZE
INCLUDE_DECK D= CLE$COMPARE_ERRORS_DETECTED
INCLUDE_DECK D= CLE$CONFLICTING_OPTIONS_SPEC
INCLUDE_DECK D= CLE$DETACHED_JOBS
INCLUDE_DECK D= CLE$ECC_COMMAND_PROCESSING
INCLUDE_DECK D= CLE$ECC_COMPARE_COMMAND
INCLUDE_DECK D= CLE$ECC_CONNECTED_FILE
INCLUDE_DECK D= CLE$ECC_CONTROL_STATEMENT
INCLUDE_DECK D= CLE$ECC_CT_GENERATOR
INCLUDE_DECK D= CLE$ECC_DATE_TIME_FORMAT
INCLUDE_DECK D= CLE$ECC_EXPRESSION
INCLUDE_DECK D= CLE$ECC_EXPRESSION_RESULT
INCLUDE_DECK D= CLE$ECC_FILE_REFERENCE
INCLUDE_DECK D= CLE$ECC_FUNCTION_PROCESSING
INCLUDE_DECK D= CLE$ECC_LEXICAL
INCLUDE_DECK D= CLE$ECC_LINE_LENGTH
INCLUDE_DECK D= CLE$ECC_MESSAGES_AND_PROMPTS
INCLUDE_DECK D= CLE$ECC_MISCELLANEOUS
INCLUDE_DECK D= CLE$ECC_MT_GENERATOR
INCLUDE_DECK D= CLE$ECC_NAMED_TASK
INCLUDE_DECK D= CLE$ECC_PARAMETER_LIST
INCLUDE_DECK D= CLE$ECC_PARSING
INCLUDE_DECK D= CLE$ECC_PROC_DECLARATION
INCLUDE_DECK D= CLE$ECC_SCL_FORMATTER
INCLUDE_DECK D= CLE$ECC_UTILITIES
INCLUDE_DECK D= CLE$ECC_VARIABLE
INCLUDE_DECK D= CLE$EMPTY_FILE
INCLUDE_DECK D= CLE$ENCOUNTERED_EOI
INCLUDE_DECK D= CLE$EOI_IN_DECLARATION
INCLUDE_DECK D= CLE$EPILOG_FILE_MISSING
INCLUDE_DECK D= CLE$EXCEPTION_CONDITION_CODES
INCLUDE_DECK D= CLE$EXPECTING_PROC
INCLUDE_DECK D= CLE$FILE_NEVER_OPENED
INCLUDE_DECK D= CLE$FILE_REFERENCE_CONFLICT
INCLUDE_DECK D= CLE$FUNCTION_CANCELLED
INCLUDE_DECK D= CLE$IMPROPER_SUBSTITUTION_MARK
INCLUDE_DECK D= CLE$IMPROPER_USE_OF_SUBST_MARK
INCLUDE_DECK D= CLE$INCOMPATIBLE_PARAMS_GIVEN
INCLUDE_DECK D= CLE$INTERACTIVE_EOI_IGNORED
INCLUDE_DECK D= CLE$INTERACTIVE_EOP_IGNORED
INCLUDE_DECK D= CLE$LOGIN_PROLOG_FILE_MISSING
INCLUDE_DECK D= CLE$MULTIPLE_APPLIC_UNIT_ARRAYS
INCLUDE_DECK D= CLE$NEGATIVE_APPLICATION_UNITS
INCLUDE_DECK D= CLE$NO_CYC_EXPR_WITH_WILD_CARD
INCLUDE_DECK D= CLE$NO_MATCH_FOR_WILD_CARD_FILE
INCLUDE_DECK D= CLE$NO_MATCH_FOR_WILD_CARD_NAME
INCLUDE_DECK D= CLE$NONE_MUST_BE_USED_ALONE
INCLUDE_DECK D= CLE$NOT_LIST_LEGIBLE
INCLUDE_DECK D= CLE$NOT_SUPPORTED
INCLUDE_DECK D= CLE$NOT_YET_IMPLEMENTED
INCLUDE_DECK D= CLE$PARAMETERS_DISPLAYED
INCLUDE_DECK D= CLE$PARAM_DIALOG_NOT_PRIVILEGED
INCLUDE_DECK D= CLE$PASSWORD_EXPIRATION_WARNING
INCLUDE_DECK D= CLE$PDT_PROCESSOR_MISMATCH
INCLUDE_DECK D= CLE$REDUNDANCY_IN_SELECTIONS
INCLUDE_DECK D= CLE$STRING_TOO_LONG
INCLUDE_DECK D= CLE$STRING_TOO_SHORT
INCLUDE_DECK D= CLE$SYSTEM_PROLOG_NOT_ALLOWED
INCLUDE_DECK D= CLE$TABLE_OVERFLOW
INCLUDE_DECK D= CLE$TASK_ALREADY_COMPLETE
INCLUDE_DECK D= CLE$TASK_NAME_IN_USE
INCLUDE_DECK D= CLE$TASK_NOT_FOUND
INCLUDE_DECK D= CLE$TASK_TASKEND_RING_BELOW_MIN
INCLUDE_DECK D= CLE$TERMINATED_APPLICATION_TASK
INCLUDE_DECK D= CLE$UNABLE_TO_CALL_AV_SCANNER
INCLUDE_DECK D= CLE$UNABLE_TO_CALL_CHECK_PROC
INCLUDE_DECK D= CLE$UNABLE_TO_CALL_FUNCTION
INCLUDE_DECK D= CLE$UNABLE_TO_CALL_INPUT_PROC
INCLUDE_DECK D= CLE$UNABLE_TO_CALL_PARM_DLG_MGR
INCLUDE_DECK D= CLE$UNABLE_TO_CALL_UTIL_DLG_MGR
INCLUDE_DECK D= CLE$UNABLE_TO_ENTER_SCREEN_MODE
INCLUDE_DECK D= CLE$UNABLE_TO_FREE_BLOCK
INCLUDE_DECK D= CLE$UNABLE_TO_SET_CAI
INCLUDE_DECK D= CLE$UNABLE_TO_SET_MINWS
INCLUDE_DECK D= CLE$UNABLE_TO_SET_PAI
INCLUDE_DECK D= CLE$UNEXPECTED_CALL_TO
INCLUDE_DECK D= CLE$UNEXPECTED_VALUE_TYPE
INCLUDE_DECK D= CLE$UNKNOWN_VARIABLE
INCLUDE_DECK D= CLE$UNSEEN_MAIL_CONDITION
INCLUDE_DECK D= CLE$UP_CANT_FOLLOW_WILD_CARD
INCLUDE_DECK D= CLE$USER_ALREADY_LOGGED_IN
INCLUDE_DECK D= CLE$VALUE_COUNTS_UNEQUAL
INCLUDE_DECK D= CLE$VAR_ALREADY_CREATED
INCLUDE_DECK D= CLE$VAR_SUB_PARAMS_NOT_ALLOWED
INCLUDE_DECK D= CLE$WELCOME_BANNER
INCLUDE_DECK D= CLE$WORK_AREA_OVERFLOW
INCLUDE_DECK D= CLE$WILD_CARD_CANT_BE_FIRST
INCLUDE_DECK D= CLE$WILD_CARD_NOT_ALLOWED
INCLUDE_DECK D= CLH$APPEND_STATUS_STRING
INCLUDE_DECK D= CLH$APPEND_STATUS_TYPE
INCLUDE_DECK D= CLH$APPEND_STATUS_VALUE_TYPE
INCLUDE_DECK D= CLH$APPLICATION_VALUE_SCANNER
INCLUDE_DECK D= CLH$BEGIN_UTILITY
INCLUDE_DECK D= CLH$CHANGE_UNSEEN_MAIL_ACTION
INCLUDE_DECK D= CLH$CHANGE_UTILITY_ATTRIBUTES
INCLUDE_DECK D= CLH$CHANGE_VARIABLE
INCLUDE_DECK D= CLH$CLEAR_LOCK_VARIABLE
INCLUDE_DECK D= CLH$COLLECT_COMMANDS
INCLUDE_DECK D= CLH$COMMAND
INCLUDE_DECK D= CLH$COMMAND_PROCESSOR
INCLUDE_DECK D= CLH$CONVERT_DATA_TO_STRING
INCLUDE_DECK D= CLH$CONVERT_DATE_TIME_TO_STRING
INCLUDE_DECK D= CLH$CONVERT_INTEGER_TO_RJSTRING
INCLUDE_DECK D= CLH$CONVERT_INTEGER_TO_STRING
INCLUDE_DECK D= CLH$CONVERT_REAL_TO_STRING
INCLUDE_DECK D= CLH$CONVERT_STRING_TO_DATE_TIME
INCLUDE_DECK D= CLH$CONVERT_STRING_TO_FILE
INCLUDE_DECK D= CLH$CONVERT_STRING_TO_FILE_REF
INCLUDE_DECK D= CLH$CONVERT_STRING_TO_INTEGER
INCLUDE_DECK D= CLH$CONVERT_STRING_TO_NAME
INCLUDE_DECK D= CLH$CONVERT_STRING_TO_REAL
INCLUDE_DECK D= CLH$CONVERT_VALUE_TO_STRING
INCLUDE_DECK D= CLH$COUNT_LIST_ELEMENTS
INCLUDE_DECK D= CLH$CREATE_ENVIRONMENT_VARIABLE
INCLUDE_DECK D= CLH$CREATE_FILE_CONNECTION
INCLUDE_DECK D= CLH$CREATE_PROCEDURE_VARIABLE
INCLUDE_DECK D= CLH$CREATE_VARIABLE
INCLUDE_DECK D= CLH$DATA_REPRESENTATION_TEXT
INCLUDE_DECK D= CLH$DEFINE_APPLIC_UNIT_ARRAY
INCLUDE_DECK D= CLH$DELETE_FILE_CONNECTION
INCLUDE_DECK D= CLH$DELETE_VARIABLE
INCLUDE_DECK D= CLH$END_INCLUDE
INCLUDE_DECK D= CLH$END_SCAN_COMMAND_FILE
INCLUDE_DECK D= CLH$END_UTILITY
INCLUDE_DECK D= CLH$EVALUATE_EXPRESSION
INCLUDE_DECK D= CLH$EVALUATE_EXPRESSION_TO_STR
INCLUDE_DECK D= CLH$EVALUATE_PARAMETERS
INCLUDE_DECK D= CLH$EVALUATE_SUB_PARAMETERS
INCLUDE_DECK D= CLH$EVALUATE_TOKEN
INCLUDE_DECK D= CLH$EXECUTE_COMMAND
INCLUDE_DECK D= CLH$FUNCTION_PROCESSOR
INCLUDE_DECK D= CLH$GENERATE_PDT
INCLUDE_DECK D= CLH$GENERATE_TYPE_SPECIFICATION
INCLUDE_DECK D= CLH$GET_COMMAND_ORIGIN
INCLUDE_DECK D= CLH$GET_DATA_LINE
INCLUDE_DECK D= CLH$GET_DATE_STRING
INCLUDE_DECK D= CLH$GET_DATE_TIME_STRING
INCLUDE_DECK D= CLH$GET_DAY_NAME
INCLUDE_DECK D= CLH$GET_EXPECTED_TYPE
INCLUDE_DECK D= CLH$GET_LINE_FROM_COMMAND_FILE
INCLUDE_DECK D= CLH$GET_MONTH_NAME
INCLUDE_DECK D= CLH$GET_PARAMETER
INCLUDE_DECK D= CLH$GET_PARAMETER_LIST
INCLUDE_DECK D= CLH$GET_PARAMETER_LIST_TEXT
INCLUDE_DECK D= CLH$GET_PARAMETER_NUMBER
INCLUDE_DECK D= CLH$GET_PATH_DESCRIPTION
INCLUDE_DECK D= CLH$GET_REASON_FOR_CALL
INCLUDE_DECK D= CLH$GET_SET_COUNT
INCLUDE_DECK D= CLH$GET_SOURCE
INCLUDE_DECK D= CLH$GET_TASK_STATUS
INCLUDE_DECK D= CLH$GET_TIME_STRING
INCLUDE_DECK D= CLH$GET_TIME_ZONE_IDENTIFIER
INCLUDE_DECK D= CLH$GET_TYPE_INFORMATION
INCLUDE_DECK D= CLH$GET_UNSEEN_MAIL_ACTION
INCLUDE_DECK D= CLH$GET_UTILITY_ATTRIBUTES
INCLUDE_DECK D= CLH$GET_VALUE
INCLUDE_DECK D= CLH$GET_VALUE_COUNT
INCLUDE_DECK D= CLH$GET_VARIABLE
INCLUDE_DECK D= CLH$GET_VARIABLE_VALUE
INCLUDE_DECK D= CLH$GET_WORKING_CATALOG
INCLUDE_DECK D= CLH$INCLUDE_COMMAND
INCLUDE_DECK D= CLH$INCLUDE_FILE
INCLUDE_DECK D= CLH$INCLUDE_LINE
INCLUDE_DECK D= CLH$LOG_AND_OR_ECHO_COMMAND
INCLUDE_DECK D= CLH$PARAMETER_DESCRIPTOR_TABLE
INCLUDE_DECK D= CLH$POP_ENVIRONMENT
INCLUDE_DECK D= CLH$POP_PARAMETERS
INCLUDE_DECK D= CLH$POP_UTILITY
INCLUDE_DECK D= CLH$PUSH_ENVIRONMENT
INCLUDE_DECK D= CLH$PUSH_PARAMETERS
INCLUDE_DECK D= CLH$PUSH_UTILITY
INCLUDE_DECK D= CLH$READ_VARIABLE
INCLUDE_DECK D= CLH$SCAN_ARGUMENT_LIST
INCLUDE_DECK D= CLH$SCAN_COMMAND_FILE
INCLUDE_DECK D= CLH$SCAN_COMMAND_LINE
INCLUDE_DECK D= CLH$SCAN_EXPRESSION
INCLUDE_DECK D= CLH$SCAN_PARAMETER_LIST
INCLUDE_DECK D= CLH$SCAN_PROC_DECLARATION
INCLUDE_DECK D= CLH$SCAN_TOKEN
INCLUDE_DECK D= CLH$SET_LOCK_VARIABLE
INCLUDE_DECK D= CLH$SET_WORKING_CATALOG
INCLUDE_DECK D= CLH$SP_PATTERN_CONCAT_PATTERN
INCLUDE_DECK D= CLH$SP_PATTERN_CONCAT_STRING
INCLUDE_DECK D= CLH$SP_PATTERN_OR_PATTERN
INCLUDE_DECK D= CLH$SP_STRING_CONCAT_PATTERN
INCLUDE_DECK D= CLH$SP_STRING_LITERAL
INCLUDE_DECK D= CLH$SUBSTITUTE_DELIMITED_TEXT
INCLUDE_DECK D= CLH$TEST_PARAMETER
INCLUDE_DECK D= CLH$TEST_RANGE
INCLUDE_DECK D= CLH$TRIMMED_STRING_SIZE
INCLUDE_DECK D= CLH$UTILITY_INTERACTIVE_INCLUDE
INCLUDE_DECK D= CLH$UTILITY_LINE_PREPROCESSOR
INCLUDE_DECK D= CLH$VALUE_KIND_SPECIFIER
INCLUDE_DECK D= CLH$WRITE_VARIABLE
INCLUDE_DECK D= CLP$APPEND_STATUS_STRING
INCLUDE_DECK D= CLP$APPEND_STATUS_TYPE
INCLUDE_DECK D= CLP$APPEND_STATUS_VALUE_TYPE
INCLUDE_DECK D= CLP$BEGIN_UTILITY
INCLUDE_DECK D= CLP$CHANGE_UNSEEN_MAIL_ACTION
INCLUDE_DECK D= CLP$CHANGE_UTILITY_ATTRIBUTES
INCLUDE_DECK D= CLP$CHANGE_VARIABLE
INCLUDE_DECK D= CLP$COLLECT_COMMANDS
INCLUDE_DECK D= CLP$CONVERT_DATA_TO_STRING
INCLUDE_DECK D= CLP$CONVERT_DATE_TIME_TO_STRING
INCLUDE_DECK D= CLP$CONVERT_INTEGER_TO_RJSTRING
INCLUDE_DECK D= CLP$CONVERT_INTEGER_TO_STRING
INCLUDE_DECK D= CLP$CONVERT_REAL_TO_STRING
INCLUDE_DECK D= CLP$CONVERT_STRING_TO_DATE_TIME
INCLUDE_DECK D= CLP$CONVERT_STRING_TO_FILE
INCLUDE_DECK D= CLP$CONVERT_STRING_TO_FILE_REF
INCLUDE_DECK D= CLP$CONVERT_STRING_TO_INTEGER
INCLUDE_DECK D= CLP$CONVERT_STRING_TO_NAME
INCLUDE_DECK D= CLP$CONVERT_STRING_TO_REAL
INCLUDE_DECK D= CLP$CONVERT_VALUE_TO_STRING
INCLUDE_DECK D= CLP$COUNT_LIST_ELEMENTS
INCLUDE_DECK D= CLP$CREATE_ENVIRONMENT_VARIABLE
INCLUDE_DECK D= CLP$CREATE_FILE_CONNECTION
INCLUDE_DECK D= CLP$CREATE_PROCEDURE_VARIABLE
INCLUDE_DECK D= CLP$CREATE_VARIABLE
INCLUDE_DECK D= CLP$DATA_REPRESENTATION_TEXT
INCLUDE_DECK D= CLP$DEFINE_APPLIC_UNIT_ARRAY
INCLUDE_DECK D= CLP$DELETE_FILE_CONNECTION
INCLUDE_DECK D= CLP$DELETE_VARIABLE
INCLUDE_DECK D= CLP$END_INCLUDE
INCLUDE_DECK D= CLP$END_SCAN_COMMAND_FILE
INCLUDE_DECK D= CLP$END_UTILITY
INCLUDE_DECK D= CLP$EVALUATE_EXPRESSION
INCLUDE_DECK D= CLP$EVALUATE_EXPRESSION_TO_STR
INCLUDE_DECK D= CLP$EVALUATE_PARAMETERS
INCLUDE_DECK D= CLP$EVALUATE_SUB_PARAMETERS
INCLUDE_DECK D= CLP$EVALUATE_TOKEN
INCLUDE_DECK D= CLP$EXECUTE_COMMAND
INCLUDE_DECK D= CLP$GENERATE_PDT
INCLUDE_DECK D= CLP$GENERATE_TYPE_SPECIFICATION
INCLUDE_DECK D= CLP$GET_COMMAND_ORIGIN
INCLUDE_DECK D= CLP$GET_DATA_LINE
INCLUDE_DECK D= CLP$GET_DATE_STRING
INCLUDE_DECK D= CLP$GET_DATE_TIME_STRING
INCLUDE_DECK D= CLP$GET_DAY_NAME
INCLUDE_DECK D= CLP$GET_EXPECTED_TYPE
INCLUDE_DECK D= CLP$GET_LINE_FROM_COMMAND_FILE
INCLUDE_DECK D= CLP$GET_MONTH_NAME
INCLUDE_DECK D= CLP$GET_PARAMETER
INCLUDE_DECK D= CLP$GET_PARAMETER_LIST
INCLUDE_DECK D= CLP$GET_PARAMETER_LIST_TEXT
INCLUDE_DECK D= CLP$GET_PARAMETER_NUMBER
INCLUDE_DECK D= CLP$GET_PATH_DESCRIPTION
INCLUDE_DECK D= CLP$GET_REASON_FOR_CALL
INCLUDE_DECK D= CLP$GET_SET_COUNT
INCLUDE_DECK D= CLP$GET_SOURCE
INCLUDE_DECK D= CLP$GET_TASK_STATUS
INCLUDE_DECK D= CLP$GET_TIME_STRING
INCLUDE_DECK D= CLP$GET_TIME_ZONE_IDENTIFIER
INCLUDE_DECK D= CLP$GET_TYPE_INFORMATION
INCLUDE_DECK D= CLP$GET_UNSEEN_MAIL_ACTION
INCLUDE_DECK D= CLP$GET_UTILITY_ATTRIBUTES
INCLUDE_DECK D= CLP$GET_VALUE
INCLUDE_DECK D= CLP$GET_VALUE_COUNT
INCLUDE_DECK D= CLP$GET_VARIABLE
INCLUDE_DECK D= CLP$GET_VARIABLE_VALUE
INCLUDE_DECK D= CLP$GET_WORKING_CATALOG
INCLUDE_DECK D= CLP$INCLUDE_COMMAND
INCLUDE_DECK D= CLP$INCLUDE_FILE
INCLUDE_DECK D= CLP$INCLUDE_LINE
INCLUDE_DECK D= CLP$LOG_AND_OR_ECHO_COMMAND
INCLUDE_DECK D= CLP$POP_ENVIRONMENT
INCLUDE_DECK D= CLP$POP_PARAMETERS
INCLUDE_DECK D= CLP$POP_UTILITY
INCLUDE_DECK D= CLP$PUSH_ENVIRONMENT
INCLUDE_DECK D= CLP$PUSH_PARAMETERS
INCLUDE_DECK D= CLP$PUSH_UTILITY
INCLUDE_DECK D= CLP$READ_VARIABLE
INCLUDE_DECK D= CLP$SCAN_ARGUMENT_LIST
INCLUDE_DECK D= CLP$SCAN_COMMAND_FILE
INCLUDE_DECK D= CLP$SCAN_COMMAND_LINE
INCLUDE_DECK D= CLP$SCAN_EXPRESSION
INCLUDE_DECK D= CLP$SCAN_PARAMETER_LIST
INCLUDE_DECK D= CLP$SCAN_PROC_DECLARATION
INCLUDE_DECK D= CLP$SCAN_TOKEN
INCLUDE_DECK D= CLP$SET_WORKING_CATALOG
INCLUDE_DECK D= CLP$SP_PATTERN_CONCAT_PATTERN
INCLUDE_DECK D= CLP$SP_PATTERN_CONCAT_STRING
INCLUDE_DECK D= CLP$SP_PATTERN_OR_PATTERN
INCLUDE_DECK D= CLP$SP_STRING_CONCAT_PATTERN
INCLUDE_DECK D= CLP$SP_STRING_LITERAL
INCLUDE_DECK D= CLP$SUBSTITUTE_DELIMITED_TEXT
INCLUDE_DECK D= CLP$TEST_PARAMETER
INCLUDE_DECK D= CLP$TEST_RANGE
INCLUDE_DECK D= CLP$TRIMMED_STRING_SIZE
INCLUDE_DECK D= CLP$WRITE_VARIABLE
INCLUDE_DECK D= CLS$ADT_SECTIONS
INCLUDE_DECK D= CLS$DECLARATION_SECTION
INCLUDE_DECK D= CLS$PDT_SECTIONS
INCLUDE_DECK D= CLT$APPLICATION_TYPE_QUALIFIER
INCLUDE_DECK D= CLT$APPLICATION_UNIT_ARRAY
INCLUDE_DECK D= CLT$APPLICATION_UNIT_ARRAY_SIZE
INCLUDE_DECK D= CLT$APPLICATION_VALUE
INCLUDE_DECK D= CLT$APPLICATION_VALUE_AREA
INCLUDE_DECK D= CLT$APPLICATION_VALUE_NAME
INCLUDE_DECK D= CLT$APPLICATION_VALUE_TEXT
INCLUDE_DECK D= CLT$ARGUMENT_DESCRIPTOR_TABLE
INCLUDE_DECK D= CLT$ARGUMENT_VALUE_TABLE
INCLUDE_DECK D= CLT$ARRAY_BOUND
INCLUDE_DECK D= CLT$ARRAY_BOUNDS
INCLUDE_DECK D= CLT$ARRAY_TYPE_QUALIFIER
INCLUDE_DECK D= CLT$AV_EVALUATOR_CALL_METHOD
INCLUDE_DECK D= CLT$AV_EVALUATOR_NAME
INCLUDE_DECK D= CLT$BOOLEAN
INCLUDE_DECK D= CLT$CALL_METHOD
INCLUDE_DECK D= CLT$CHECK_PARAMETERS_PROCEDURE
INCLUDE_DECK D= CLT$COBOL_NAME
INCLUDE_DECK D= CLT$COBOL_NAME_REFERENCE
INCLUDE_DECK D= CLT$COBOL_NAME_SIZE
INCLUDE_DECK D= CLT$COMMAND
INCLUDE_DECK D= CLT$COMMAND_CALL_METHOD
INCLUDE_DECK D= CLT$COMMAND_LINE
INCLUDE_DECK D= CLT$COMMAND_LINE_INDEX
INCLUDE_DECK D= CLT$COMMAND_LINE_SIZE
INCLUDE_DECK D= CLT$COMMAND_LOG_OPTION
INCLUDE_DECK D= CLT$COMMAND_NAME
INCLUDE_DECK D= CLT$COMMAND_OR_FUNCTION
INCLUDE_DECK D= CLT$COMMAND_OR_FUNCTION_SCOPE
INCLUDE_DECK D= CLT$COMMAND_PROCESSOR
INCLUDE_DECK D= CLT$COMMAND_REFERENCE
INCLUDE_DECK D= CLT$COMMAND_REFERENCE_FORM
INCLUDE_DECK D= CLT$COMMAND_SEARCH_MODES
INCLUDE_DECK D= CLT$COMMAND_TABLE
INCLUDE_DECK D= CLT$COMMAND_TABLE_ENTRY
INCLUDE_DECK D= CLT$CYCLE_SELECTOR
INCLUDE_DECK D= CLT$DATA_ACCESS_MODE
INCLUDE_DECK D= CLT$DATA_KIND
INCLUDE_DECK D= CLT$DATA_KINDS
INCLUDE_DECK D= CLT$DATA_REPRESENTATION
INCLUDE_DECK D= CLT$DATA_REPRESENTATION_COUNT
INCLUDE_DECK D= CLT$DATA_REPRESENTATION_OPTION
INCLUDE_DECK D= CLT$DATA_VALUE
INCLUDE_DECK D= CLT$DATA_VALUE_KIND
INCLUDE_DECK D= CLT$DATE_AND_OR_TIME
INCLUDE_DECK D= CLT$DATE_OR_TIME
INCLUDE_DECK D= CLT$DATE_TIME
INCLUDE_DECK D= CLT$DATE_TIME_FORM_STRING
INCLUDE_DECK D= CLT$DATE_TIME_TENSE
INCLUDE_DECK D= CLT$DATE_TIME_TENSES
INCLUDE_DECK D= CLT$DATE_TIME_TYPE_QUALIFIER
INCLUDE_DECK D= CLT$DECLARATION_VERSION
INCLUDE_DECK D= CLT$ENVIRONMENT_OBJECT
INCLUDE_DECK D= CLT$ENVIRONMENT_VARIABLE_SCOPE
INCLUDE_DECK D= CLT$EXPRESSION_EVAL_METHOD
INCLUDE_DECK D= CLT$EXPRESSION_TEXT
INCLUDE_DECK D= CLT$EXPRESSION_TEXT_INDEX
INCLUDE_DECK D= CLT$EXPRESSION_TEXT_SIZE
INCLUDE_DECK D= CLT$FIELD_INFORMATION
INCLUDE_DECK D= CLT$FIELD_NAME
INCLUDE_DECK D= CLT$FIELD_NUMBER
INCLUDE_DECK D= CLT$FIELD_REQUIREMENT
INCLUDE_DECK D= CLT$FIELD_SPECIFICATION
INCLUDE_DECK D= CLT$FIELD_VALUE
INCLUDE_DECK D= CLT$FILE
INCLUDE_DECK D= CLT$FILE_REFERENCE
INCLUDE_DECK D= CLT$FUNCTION
INCLUDE_DECK D= CLT$FUNCTION_CALL_METHOD
INCLUDE_DECK D= CLT$FUNCTION_NAME
INCLUDE_DECK D= CLT$FUNCTION_PROCESSOR
INCLUDE_DECK D= CLT$FUNCTION_PROCESSOR_TABLE
INCLUDE_DECK D= CLT$FUNCTION_PROC_TABLE_ENTRY
INCLUDE_DECK D= CLT$FUNCTION_TABLE
INCLUDE_DECK D= CLT$FUNCTION_TABLE_ENTRY
INCLUDE_DECK D= CLT$INPUT_PROCEDURE
INCLUDE_DECK D= CLT$INTEGER
INCLUDE_DECK D= CLT$INTEGER_TYPE_QUALIFIER
INCLUDE_DECK D= CLT$KEYWORD
INCLUDE_DECK D= CLT$KEYWORD_REFERENCE
INCLUDE_DECK D= CLT$KEYWORD_SPECIFICATION
INCLUDE_DECK D= CLT$KEYWORD_SPECIFICATIONS
INCLUDE_DECK D= CLT$KEYWORD_TYPE_QUALIFIER
INCLUDE_DECK D= CLT$LEXICAL_KINDS
INCLUDE_DECK D= CLT$LEXICAL_TOKEN
INCLUDE_DECK D= CLT$LEXICAL_TOKEN_KIND
INCLUDE_DECK D= CLT$LIST_SIZE
INCLUDE_DECK D= CLT$LIST_TYPE_QUALIFIER
INCLUDE_DECK D= CLT$LIST_TYPE_QUALIFIER_V2
INCLUDE_DECK D= CLT$LOCK
INCLUDE_DECK D= CLT$LOCK_STATE
INCLUDE_DECK D= CLT$LONGREAL
INCLUDE_DECK D= CLT$LONGREAL_BREAKDOWN
INCLUDE_DECK D= CLT$LOW_OR_HIGH
INCLUDE_DECK D= CLT$NAME
INCLUDE_DECK D= CLT$NAMED_ENTRY_AVAILABILITY
INCLUDE_DECK D= CLT$NAMED_ENTRY_CLASS
INCLUDE_DECK D= CLT$NAMED_ENTRY_ORDINAL
INCLUDE_DECK D= CLT$NAME_TYPE_QUALIFIER
INCLUDE_DECK D= CLT$PARAMETER_CHECKING_LEVEL
INCLUDE_DECK D= CLT$PARAMETER_COUNT
INCLUDE_DECK D= CLT$PARAMETER_DESCRIPTION_TABLE
INCLUDE_DECK D= CLT$PARAMETER_DESCRIPTOR_TABLE
INCLUDE_DECK D= CLT$PARAMETER_LIST
INCLUDE_DECK D= CLT$PARAMETER_LIST_CONTENTS
INCLUDE_DECK D= CLT$PARAMETER_LIST_SIZE
INCLUDE_DECK D= CLT$PARAMETER_LIST_TEXT
INCLUDE_DECK D= CLT$PARAMETER_LIST_TEXT_INDEX
INCLUDE_DECK D= CLT$PARAMETER_LIST_TEXT_SIZE
INCLUDE_DECK D= CLT$PARAMETER_NAME
INCLUDE_DECK D= CLT$PARAMETER_NAME_COUNT
INCLUDE_DECK D= CLT$PARAMETER_NAME_INDEX
INCLUDE_DECK D= CLT$PARAMETER_NUMBER
INCLUDE_DECK D= CLT$PARAMETER_PASSING_METHOD
INCLUDE_DECK D= CLT$PARAMETER_REFERENCE
INCLUDE_DECK D= CLT$PARAMETER_REQUIREMENT
INCLUDE_DECK D= CLT$PARAMETER_SECURITY
INCLUDE_DECK D= CLT$PARAMETER_SPEC_METHOD
INCLUDE_DECK D= CLT$PARAMETER_SPEC_METHODS
INCLUDE_DECK D= CLT$PARAMETER_VALUE
INCLUDE_DECK D= CLT$PARAMETER_VALUE_TABLE
INCLUDE_DECK D= CLT$PATH_NAME
INCLUDE_DECK D= CLT$PDT_HEADER
INCLUDE_DECK D= CLT$PDT_PARAMETER
INCLUDE_DECK D= CLT$PDT_PARAMETERS
INCLUDE_DECK D= CLT$PDT_PARAMETER_NAME
INCLUDE_DECK D= CLT$PDT_PARAMETER_NAMES
INCLUDE_DECK D= CLT$PROCEDURE_VARIABLE_SCOPE
INCLUDE_DECK D= CLT$PROC_INPUT_PROCEDURE
INCLUDE_DECK D= CLT$PROC_INPUT_TYPE
INCLUDE_DECK D= CLT$PROC_NAMES
INCLUDE_DECK D= CLT$PROMPT
INCLUDE_DECK D= CLT$PROMPT_SIZE
INCLUDE_DECK D= CLT$PROMPT_STRING
INCLUDE_DECK D= CLT$RANGE_TYPE_QUALIFIER
INCLUDE_DECK D= CLT$REAL
INCLUDE_DECK D= CLT$REAL_BREAKDOWN
INCLUDE_DECK D= CLT$REAL_NUMBER_DIGIT_COUNT
INCLUDE_DECK D= CLT$REAL_TYPE_QUALIFIER
INCLUDE_DECK D= CLT$RECORD_TYPE_QUALIFIER
INCLUDE_DECK D= CLT$REQUIRED_OR_OPTIONAL
INCLUDE_DECK D= CLT$SCL_PROCEDURE
INCLUDE_DECK D= CLT$SCU_LINE_IDENTIFIER
INCLUDE_DECK D= CLT$SCU_MODIFICATION_NAME
INCLUDE_DECK D= CLT$SCU_SEQUENCE_NUMBER
INCLUDE_DECK D= CLT$SOURCE
INCLUDE_DECK D= CLT$SOURCE_KIND
INCLUDE_DECK D= CLT$STRING_INDEX
INCLUDE_DECK D= CLT$STRING_PATTERN
INCLUDE_DECK D= CLT$STRING_PATTERN_SIZE
INCLUDE_DECK D= CLT$STRING_SIZE
INCLUDE_DECK D= CLT$STRING_TYPE_QUALIFIER
INCLUDE_DECK D= CLT$STRING_VALUE
INCLUDE_DECK D= CLT$SYMBOLIC_PARAMETER
INCLUDE_DECK D= CLT$SYMBOLIC_PARAMETERS
INCLUDE_DECK D= CLT$TASK_NAME
INCLUDE_DECK D= CLT$TASK_NAME_REFERENCE
INCLUDE_DECK D= CLT$TOKEN
INCLUDE_DECK D= CLT$TOKEN_EVALUATION_OPTION
INCLUDE_DECK D= CLT$TOKEN_EVALUATION_OPTIONS
INCLUDE_DECK D= CLT$TYPE_INFORMATION
INCLUDE_DECK D= CLT$TYPE_KIND
INCLUDE_DECK D= CLT$TYPE_KINDS
INCLUDE_DECK D= CLT$TYPE_NAME
INCLUDE_DECK D= CLT$TYPE_NAME_REFERENCE
INCLUDE_DECK D= CLT$TYPE_SPECIFICATION
INCLUDE_DECK D= CLT$TYPE_SPECIFICATION_HEADER
INCLUDE_DECK D= CLT$TYPE_SPECIFICATION_SIZE
INCLUDE_DECK D= CLT$UNION_MEMBER_NUMBER
INCLUDE_DECK D= CLT$UNION_TYPE_INFORMATION
INCLUDE_DECK D= CLT$UNION_TYPE_QUALIFIER
INCLUDE_DECK D= CLT$UNSEEN_MAIL_ACTION
INCLUDE_DECK D= CLT$UTILITY_ATTRIBUTE
INCLUDE_DECK D= CLT$UTILITY_ATTRIBUTES
INCLUDE_DECK D= CLT$UTILITY_ATTRIBUTE_KEY
INCLUDE_DECK D= CLT$UTILITY_INTERACTIVE_INCLUDE
INCLUDE_DECK D= CLT$UTILITY_INTERACTIVE_IN_DESC
INCLUDE_DECK D= CLT$UTILITY_LINE_PREPROCESSOR
INCLUDE_DECK D= CLT$UTILITY_LINE_PREPROC_DESC
INCLUDE_DECK D= CLT$UTILITY_NAME
INCLUDE_DECK D= CLT$UTILITY_PROMPT
INCLUDE_DECK D= CLT$VALUE_KINDS
INCLUDE_DECK D= CLT$VALUE_KIND_SPECIFIER
INCLUDE_DECK D= CLT$VARIABLE_CLASS
INCLUDE_DECK D= CLT$VARIABLE_DECLARATION_SCOPE
INCLUDE_DECK D= CLT$VARIABLE_KINDS
INCLUDE_DECK D= CLT$VARIABLE_NAME
INCLUDE_DECK D= CLT$VARIABLE_NAME_REFERENCE
INCLUDE_DECK D= CLT$VARIABLE_REF_EXPRESSION
INCLUDE_DECK D= CLT$WHICH_PARAMETER
INCLUDE_DECK D= CLT$WORK_AREA
INCLUDE_DECK D= CMT$ELEMENT_STATE
INCLUDE_DECK D= CSC$MAX_CLASSES
INCLUDE_DECK D= CSC$MAX_ITEMS_PER_CLASS
INCLUDE_DECK D= CSC$MAX_MENU_ITEMS
INCLUDE_DECK D= CSC$NUMBER_OF_MENU_ROWS
INCLUDE_DECK D= CSM$ADM_31
INCLUDE_DECK D= CSM$ADM_31_PROTECTED
INCLUDE_DECK D= CSM$CDC721
INCLUDE_DECK D= CSM$CDC722
INCLUDE_DECK D= CSM$CDC722_30
INCLUDE_DECK D= CSM$CDC_721
INCLUDE_DECK D= CSM$CDC_722
INCLUDE_DECK D= CSM$CDC_722_30
INCLUDE_DECK D= CSM$CDC_910
INCLUDE_DECK D= CSM$DEC_VT100
INCLUDE_DECK D= CSM$DEC_VT100_GOLD
INCLUDE_DECK D= CSM$DEC_VT100_HOST_ECHO
INCLUDE_DECK D= CSM$DEC_VT220
INCLUDE_DECK D= CSM$DEC_VT220_OLD
INCLUDE_DECK D= CSM$HP_2392
INCLUDE_DECK D= CSM$HP_2645
INCLUDE_DECK D= CSM$IBM_3270
INCLUDE_DECK D= CSM$IBM_3270_2
INCLUDE_DECK D= CSM$IBM_3270_3
INCLUDE_DECK D= CSM$IBM_3270_4
INCLUDE_DECK D= CSM$IBM_3270_5
INCLUDE_DECK D= CSM$IBM_3270_FULL_WIDTH_INPUT
INCLUDE_DECK D= CSM$MAC_CONNECT_10
INCLUDE_DECK D= CSM$MAC_CONNECT_11
INCLUDE_DECK D= CSM$MAC_CONNECT_20
INCLUDE_DECK D= CSM$MAC_CONNECT_21
INCLUDE_DECK D= CSM$MAC_CONNECT_22
INCLUDE_DECK D= CSM$MAC_HOST_ECHO_21
INCLUDE_DECK D= CSM$MAC_HOST_ECHO_22
INCLUDE_DECK D= CSM$NCDX
INCLUDE_DECK D= CSM$NCDX_PL_24
INCLUDE_DECK D= CSM$NCDX_24_80
INCLUDE_DECK D= CSM$NCDX_43_80
INCLUDE_DECK D= CSM$OLD_CDC721
INCLUDE_DECK D= CSM$OLD_CDC722
INCLUDE_DECK D= CSM$OLD_CDC722_30
INCLUDE_DECK D= CSM$OLD_MAC_CONNECT_10
INCLUDE_DECK D= CSM$OLD_MAC_CONNECT_11
INCLUDE_DECK D= CSM$OLD_PC_CONNECT_10
INCLUDE_DECK D= CSM$OLD_PC_CONNECT_11
INCLUDE_DECK D= CSM$OLD_PC_CONNECT_12
INCLUDE_DECK D= CSM$OLD_VT100
INCLUDE_DECK D= CSM$OLD_Z19
INCLUDE_DECK D= CSM$OLD_Z29
INCLUDE_DECK D= CSM$PC_CONNECT_10
INCLUDE_DECK D= CSM$PC_CONNECT_11
INCLUDE_DECK D= CSM$PC_CONNECT_12
INCLUDE_DECK D= CSM$PC_CONNECT_13
INCLUDE_DECK D= CSM$PC_CONNECT_20
INCLUDE_DECK D= CSM$PC_CONNECT_20_42
INCLUDE_DECK D= CSM$PC_CONNECT_20_42_132
INCLUDE_DECK D= CSM$PC_HOST_ECHO_13
INCLUDE_DECK D= CSM$PC_HOST_ECHO_20
INCLUDE_DECK D= CSM$SAMPLE
INCLUDE_DECK D= CSM$SUN_160
INCLUDE_DECK D= CSM$SUN_4_43_80
INCLUDE_DECK D= CSM$TAB_132
INCLUDE_DECK D= CSM$TAB_132_EDIT
INCLUDE_DECK D= CSM$TEK_4109
INCLUDE_DECK D= CSM$TEK_4115
INCLUDE_DECK D= CSM$TEK_4125
INCLUDE_DECK D= CSM$TEKX_40_80
INCLUDE_DECK D= CSM$TV_950
INCLUDE_DECK D= CSM$TV_950_PROTECTED
INCLUDE_DECK D= CSM$TV_955
INCLUDE_DECK D= CSM$TV_955_PROTECTED
INCLUDE_DECK D= CSM$TV_970
INCLUDE_DECK D= CSM$TV_HALF_FULL_DUPLEX
INCLUDE_DECK D= CSM$VISTACOM_MAC_30
INCLUDE_DECK D= CSM$VISTA_MAC_HOST_ECHO_30
INCLUDE_DECK D= CSM$VT100
INCLUDE_DECK D= CSM$WYSE_60
INCLUDE_DECK D= CSM$WYSE_60_HOST_ECHO
INCLUDE_DECK D= CSM$WYSE_60_PROTECTED
INCLUDE_DECK D= CSM$Z19
INCLUDE_DECK D= CSM$Z29
INCLUDE_DECK D= CSM$ZEN_Z19
INCLUDE_DECK D= CSM$ZEN_Z29
INCLUDE_DECK D= CST$APPLICATION_FUNCTIONS
INCLUDE_DECK D= CST$CLASS_NAME
INCLUDE_DECK D= CST$KEY_TYPE
INCLUDE_DECK D= CST$MAX_CLASSES
INCLUDE_DECK D= CST$MENU_CLASS
INCLUDE_DECK D= CST$MENU_ITEM
INCLUDE_DECK D= CST$MENU_ITEM_NUMBER
INCLUDE_DECK D= CST$MENU_LIST
INCLUDE_DECK D= CST$NUMBER_OF_MENU_ROWS
INCLUDE_DECK D= CST$SCREEN_EVENTS
INCLUDE_DECK D= CST$STANDARD_FUNCTIONS
INCLUDE_DECK D= CYC$DEFAULT_HEAP_NAME
INCLUDE_DECK D= CYC$ERROR_CODES_CYBIL_RANGE
INCLUDE_DECK D= CYC$LOWERVALUE_INTEGER
INCLUDE_DECK D= CYC$MAX_STRING_SIZE
INCLUDE_DECK D= CYC$UPPERVALUE_INTEGER
INCLUDE_DECK D= CYD$BINARY_FILE
INCLUDE_DECK D= CYD$BINDING_KIND_DEFINITIONS
INCLUDE_DECK D= CYD$CYBIL_STRUCTURE_DEFINITIONS
INCLUDE_DECK D= CYD$DEBUG_SYMBOLS
INCLUDE_DECK D= CYD$DEBUG_SYMBOL_TABLE
INCLUDE_DECK D= CYD$DISPLAY_FILE
INCLUDE_DECK D= CYD$GLOBAL_PHASE_DEFINITIONS
INCLUDE_DECK D= CYD$MACHINE_DEFINITIONS
INCLUDE_DECK D= CYD$RECORD_FILE
INCLUDE_DECK D= CYD$RUN_TIME_ERROR_CONDITION
INCLUDE_DECK D= CYD$STRING
INCLUDE_DECK D= CYD$SYMBOL_TABLE_ENTRY_KINDS
INCLUDE_DECK D= CYD$TEXT_FILE
INCLUDE_DECK D= CYE$CYBIL_COMPILE_ERROR_CODES
INCLUDE_DECK D= CYE$ERROR_CODES_CYBIL
INCLUDE_DECK D= CYE$EXCEPTION_CONDITIONS
INCLUDE_DECK D= CYE$RUN_TIME_ERROR_CODES
INCLUDE_DECK D= CYH$BINARY_FILE_KEY
INCLUDE_DECK D= CYH$CLOSE_FILE
INCLUDE_DECK D= CYH$CURRENT_COLUMN
INCLUDE_DECK D= CYH$CURRENT_DISPLAY_LINE
INCLUDE_DECK D= CYH$CURRENT_FILE_POSITION
INCLUDE_DECK D= CYH$CURRENT_PAGE_NUMBER
INCLUDE_DECK D= CYH$DISPLAY_PAGE_EJECT
INCLUDE_DECK D= CYH$DISPLAY_PAGE_LENGTH
INCLUDE_DECK D= CYH$DISPLAY_STANDARD_TITLE
INCLUDE_DECK D= CYH$FILE_CONNECTED_TO_TERMINAL
INCLUDE_DECK D= CYH$FLUSH_LINE
INCLUDE_DECK D= CYH$GET_BINARY_FILE_POINTER
INCLUDE_DECK D= CYH$GET_FILE_IDENTIFIER
INCLUDE_DECK D= CYH$GET_KEYED_BINARY
INCLUDE_DECK D= CYH$GET_NEXT_BINARY
INCLUDE_DECK D= CYH$GET_NEXT_LINE
INCLUDE_DECK D= CYH$GET_NEXT_RECORD
INCLUDE_DECK D= CYH$GET_PARTIAL_LINE
INCLUDE_DECK D= CYH$GET_PARTIAL_RECORD
INCLUDE_DECK D= CYH$LENGTH_OF_FILE
INCLUDE_DECK D= CYH$OPEN_BINARY_FILE
INCLUDE_DECK D= CYH$OPEN_DISPLAY_FILE
INCLUDE_DECK D= CYH$OPEN_FILE
INCLUDE_DECK D= CYH$OPEN_RECORD_FILE
INCLUDE_DECK D= CYH$OPEN_TEXT_FILE
INCLUDE_DECK D= CYH$OPERATING_SYSTEM
INCLUDE_DECK D= CYH$PAGE_WIDTH
INCLUDE_DECK D= CYH$POSITION_BINARY_AT_KEY
INCLUDE_DECK D= CYH$POSITION_DISPLAY_PAGE
INCLUDE_DECK D= CYH$POSITION_FILE_AT_BEGINNING
INCLUDE_DECK D= CYH$POSITION_FILE_AT_END
INCLUDE_DECK D= CYH$POSITION_RECORD_FILE
INCLUDE_DECK D= CYH$PUT_KEYED_BINARY
INCLUDE_DECK D= CYH$PUT_NEXT_BINARY
INCLUDE_DECK D= CYH$PUT_NEXT_LINE
INCLUDE_DECK D= CYH$PUT_NEXT_RECORD
INCLUDE_DECK D= CYH$PUT_PARTIAL_LINE
INCLUDE_DECK D= CYH$PUT_PARTIAL_RECORD
INCLUDE_DECK D= CYH$SKIP_LINES
INCLUDE_DECK D= CYH$START_NEW_DISPLAY_PAGE
INCLUDE_DECK D= CYH$TAB_FILE
INCLUDE_DECK D= CYH$WRITE_END_OF_LINE
INCLUDE_DECK D= CYH$WRITE_END_OF_PARTITION
INCLUDE_DECK D= CYH$WRITE_END_OF_RECORD
INCLUDE_DECK D= CYP$BINARY_FILE_KEY
INCLUDE_DECK D= CYP$CLOSE_FILE
INCLUDE_DECK D= CYP$CURRENT_COLUMN
INCLUDE_DECK D= CYP$CURRENT_DISPLAY_LINE
INCLUDE_DECK D= CYP$CURRENT_FILE_POSITION
INCLUDE_DECK D= CYP$CURRENT_PAGE_NUMBER
INCLUDE_DECK D= CYP$DISPLAY_PAGE_EJECT
INCLUDE_DECK D= CYP$DISPLAY_PAGE_LENGTH
INCLUDE_DECK D= CYP$DISPLAY_STANDARD_TITLE
INCLUDE_DECK D= CYP$FILE_CONNECTED_TO_TERMINAL
INCLUDE_DECK D= CYP$FLUSH_LINE
INCLUDE_DECK D= CYP$GET_BINARY_FILE_POINTER
INCLUDE_DECK D= CYP$GET_FILE_IDENTIFIER
INCLUDE_DECK D= CYP$GET_FILE_REFERENCE
INCLUDE_DECK D= CYP$GET_KEYED_BINARY
INCLUDE_DECK D= CYP$GET_NEXT_BINARY
INCLUDE_DECK D= CYP$GET_NEXT_LINE
INCLUDE_DECK D= CYP$GET_NEXT_RECORD
INCLUDE_DECK D= CYP$GET_PARTIAL_LINE
INCLUDE_DECK D= CYP$GET_PARTIAL_RECORD
INCLUDE_DECK D= CYP$LENGTH_OF_FILE
INCLUDE_DECK D= CYP$OPEN_BINARY_FILE
INCLUDE_DECK D= CYP$OPEN_DISPLAY_FILE
INCLUDE_DECK D= CYP$OPEN_FILE
INCLUDE_DECK D= CYP$OPEN_RECORD_FILE
INCLUDE_DECK D= CYP$OPEN_TEXT_FILE
INCLUDE_DECK D= CYP$OPERATING_SYSTEM
INCLUDE_DECK D= CYP$PAGE_WIDTH
INCLUDE_DECK D= CYP$POSITION_BINARY_AT_KEY
INCLUDE_DECK D= CYP$POSITION_DISPLAY_PAGE
INCLUDE_DECK D= CYP$POSITION_FILE_AT_BEGINNING
INCLUDE_DECK D= CYP$POSITION_FILE_AT_END
INCLUDE_DECK D= CYP$POSITION_RECORD_FILE
INCLUDE_DECK D= CYP$PUT_KEYED_BINARY
INCLUDE_DECK D= CYP$PUT_NEXT_BINARY
INCLUDE_DECK D= CYP$PUT_NEXT_LINE
INCLUDE_DECK D= CYP$PUT_NEXT_RECORD
INCLUDE_DECK D= CYP$PUT_PARTIAL_LINE
INCLUDE_DECK D= CYP$PUT_PARTIAL_RECORD
INCLUDE_DECK D= CYP$SKIP_LINES
INCLUDE_DECK D= CYP$START_NEW_DISPLAY_PAGE
INCLUDE_DECK D= CYP$TAB_FILE
INCLUDE_DECK D= CYP$TRIMMED_STRING_SIZE
INCLUDE_DECK D= CYP$WRITE_END_OF_BLOCK
INCLUDE_DECK D= CYP$WRITE_END_OF_LINE
INCLUDE_DECK D= CYP$WRITE_END_OF_PARTITION
INCLUDE_DECK D= CYP$WRITE_END_OF_RECORD
INCLUDE_DECK D= CYT$CLOSE_FILE_DISPOSITION
INCLUDE_DECK D= CYT$CURRENT_FILE_POSITION
INCLUDE_DECK D= CYT$CYBIL_INPUT_OUTPUT
INCLUDE_DECK D= CYT$FILE
INCLUDE_DECK D= CYT$FILE_ACCESS
INCLUDE_DECK D= CYT$FILE_CHARACTER_SET
INCLUDE_DECK D= CYT$FILE_CONTENTS
INCLUDE_DECK D= CYT$FILE_CONTROL_BLOCK
INCLUDE_DECK D= CYT$FILE_EXISTENCE
INCLUDE_DECK D= CYT$FILE_KIND
INCLUDE_DECK D= CYT$FILE_NAME
INCLUDE_DECK D= CYT$FILE_PROCESSOR
INCLUDE_DECK D= CYT$FILE_SPECIFICATIONS
INCLUDE_DECK D= CYT$NEW_PAGE_PROCEDURE
INCLUDE_DECK D= CYT$OPEN_CLOSE_POSITION
INCLUDE_DECK D= CYT$PAGE_FORMAT
INCLUDE_DECK D= CYT$PAGE_LENGTH
INCLUDE_DECK D= CYT$PAGE_WIDTH
INCLUDE_DECK D= CYT$SKIP_DIRECTION
INCLUDE_DECK D= CYT$SKIP_UNIT
INCLUDE_DECK D= CYT$STRING_INDEX
INCLUDE_DECK D= CYT$STRING_SIZE
INCLUDE_DECK D= CYT$SYSTEM_TYPE
INCLUDE_DECK D= DBT$ENTRY_POINT_TABLE
INCLUDE_DECK D= DBT$MODULE_ADDRESS_TABLE_ITEM
INCLUDE_DECK D= DME$TAPE_ERRORS
INCLUDE_DECK D= DMT$ERROR_CONDITION_CODES
INCLUDE_DECK D= DPC$CONDITION_LIMITS
INCLUDE_DECK D= DPE$ERROR_CODES
INCLUDE_DECK D= FDC$DECIMAL_CURRENCY_SYMBOL
INCLUDE_DECK D= FDC$DOLLAR_CURRENCY_SYMBOL
INCLUDE_DECK D= FDC$MAXIMUM_COMMENTS
INCLUDE_DECK D= FDC$MAXIMUM_COMMENT_LENGTH
INCLUDE_DECK D= FDC$MAXIMUM_ERRORS
INCLUDE_DECK D= FDC$MAXIMUM_ERROR_LENGTH
INCLUDE_DECK D= FDC$MAXIMUM_EVENTS
INCLUDE_DECK D= FDC$MAXIMUM_FORM_ATTRIBUTES
INCLUDE_DECK D= FDC$MAXIMUM_FORM_IDENTIFIER
INCLUDE_DECK D= FDC$MAXIMUM_HELP_LENGTH
INCLUDE_DECK D= FDC$MAXIMUM_OBJECTS
INCLUDE_DECK D= FDC$MAXIMUM_PICTURE_LENGTH
INCLUDE_DECK D= FDC$MAXIMUM_OBJECT_ATTRIBUTES
INCLUDE_DECK D= FDC$MAXIMUM_OBJECT_DISPLAYS
INCLUDE_DECK D= FDC$MAXIMUM_OCCURRENCE
INCLUDE_DECK D= FDC$MAXIMUM_PUSHES
INCLUDE_DECK D= FDC$MAXIMUM_RECORD_LENGTH
INCLUDE_DECK D= FDC$MAXIMUM_TABLES
INCLUDE_DECK D= FDC$MAXIMUM_TABLE_VARIABLES
INCLUDE_DECK D= FDC$MAXIMUM_TEXT_LENGTH
INCLUDE_DECK D= FDC$MAXIMUM_VALID_RANGES
INCLUDE_DECK D= FDC$MAXIMUM_VALID_STRING
INCLUDE_DECK D= FDC$MAXIMUM_VALID_STRINGS
INCLUDE_DECK D= FDC$MAXIMUM_VARIABLES
INCLUDE_DECK D= FDC$MAXIMUM_VARIABLE_LENGTH
INCLUDE_DECK D= FDC$MAXIMUM_X_POSITION
INCLUDE_DECK D= FDC$MAXIMUM_Y_POSITION
INCLUDE_DECK D= FDC$MAX_CHARACTER_POSITION
INCLUDE_DECK D= FDC$MESSAGE_FORM_NAME
INCLUDE_DECK D= FDC$MESSAGE_VARIABLE_NAME
INCLUDE_DECK D= FDC$NEW_LINE_CHARACTER
INCLUDE_DECK D= FDC$POUND_CURRENCY_SYMBOL
INCLUDE_DECK D= FDC$SYSTEM_COORDINATE_SYSTEM
INCLUDE_DECK D= FDC$SYSTEM_CURRENCY_SIGN
INCLUDE_DECK D= FDC$SYSTEM_DECIMAL_POINT
INCLUDE_DECK D= FDC$SYSTEM_DESIGN_TABLE_NAME
INCLUDE_DECK D= FDC$SYSTEM_DESIGN_VARIABLE_NAME
INCLUDE_DECK D= FDC$SYSTEM_DISPLAY_NAME
INCLUDE_DECK D= FDC$SYSTEM_ERROR_MESSAGE
INCLUDE_DECK D= FDC$SYSTEM_EXPONENT_CHARACTER
INCLUDE_DECK D= FDC$SYSTEM_FORM_PROCESSOR
INCLUDE_DECK D= FDC$SYSTEM_HELP_MESSAGE
INCLUDE_DECK D= FDC$SYSTEM_INPUT_FORMAT
INCLUDE_DECK D= FDC$SYSTEM_IO_MODE
INCLUDE_DECK D= FDC$SYSTEM_OCCURRENCE
INCLUDE_DECK D= FDC$SYSTEM_OUTPUT_FORMAT
INCLUDE_DECK D= FDC$SYSTEM_PROGRAM_DATA_TYPE
INCLUDE_DECK D= FDC$SYSTEM_RECORD_TYPE
INCLUDE_DECK D= FDC$SYSTEM_THOUSANDS_SEPARATOR
INCLUDE_DECK D= FDC$SYSTEM_UNKNOWN_ENTRY
INCLUDE_DECK D= FDC$SYSTEM_USER_ENTRY
INCLUDE_DECK D= FDC$THOUSANDS_CURRENCY_SYMBOL
INCLUDE_DECK D= FDE$COBOL_STATUS
INCLUDE_DECK D= FDE$COBOL_VARIABLE_STATUS
INCLUDE_DECK D= FDE$CONDITION_IDENTIFIERS
INCLUDE_DECK D= FDE$FORTRAN_STATUS
INCLUDE_DECK D= FDE$FORTRAN_VARIABLE_STATUS
INCLUDE_DECK D= FDE$PASCAL_PROCEDURE_STATUS
INCLUDE_DECK D= FDH$ADD_FORM
INCLUDE_DECK D= FDH$CHANGE_FORM
INCLUDE_DECK D= FDH$CHANGE_FORM_RECORD
INCLUDE_DECK D= FDH$CHANGE_OBJECT
INCLUDE_DECK D= FDH$CHANGE_STORED_OBJECT
INCLUDE_DECK D= FDH$CHANGE_TABLE
INCLUDE_DECK D= FDH$CHANGE_TABLE_SIZE
INCLUDE_DECK D= FDH$CHANGE_VARIABLE
INCLUDE_DECK D= FDH$CLOSE_FORM
INCLUDE_DECK D= FDH$COMBINE_FORM
INCLUDE_DECK D= FDH$CONVERT_TO_PROGRAM_VARIABLE
INCLUDE_DECK D= FDH$CONVERT_TO_SCREEN_VARIABLE
INCLUDE_DECK D= FDH$COPY_AREA
INCLUDE_DECK D= FDH$COPY_FORM
INCLUDE_DECK D= FDH$CREATE_CONSTANT_TEXT
INCLUDE_DECK D= FDH$CREATE_DESIGN_FORM
INCLUDE_DECK D= FDH$CREATE_DESIGN_TEXT
INCLUDE_DECK D= FDH$CREATE_EVENT_FORM
INCLUDE_DECK D= FDH$CREATE_FORM
INCLUDE_DECK D= FDH$CREATE_MARK
INCLUDE_DECK D= FDH$CREATE_OBJECT
INCLUDE_DECK D= FDH$CREATE_STORED_OBJECT
INCLUDE_DECK D= FDH$CREATE_TABLE
INCLUDE_DECK D= FDH$CREATE_VARIABLE
INCLUDE_DECK D= FDH$DELETE_AREA
INCLUDE_DECK D= FDH$DELETE_FORM
INCLUDE_DECK D= FDH$DELETE_MARK
INCLUDE_DECK D= FDH$DELETE_OBJECT
INCLUDE_DECK D= FDH$DELETE_STORED_OBJECT
INCLUDE_DECK D= FDH$DELETE_TABLE
INCLUDE_DECK D= FDH$DELETE_VARIABLE
INCLUDE_DECK D= FDH$EDIT_FORM
INCLUDE_DECK D= FDH$END_FORM
INCLUDE_DECK D= FDH$FORTRAN_ALIASES
INCLUDE_DECK D= FDH$GET_FORM_ATTRIBUTES
INCLUDE_DECK D= FDH$GET_NEXT_CHANGED_VARIABLE
INCLUDE_DECK D= FDH$GET_FORM_NAMES
INCLUDE_DECK D= FDH$GET_NEXT_INPUT_ERROR
INCLUDE_DECK D= FDH$GET_NEXT_OUTPUT_ERROR
INCLUDE_DECK D= FDH$GET_FORM_OBJECTS
INCLUDE_DECK D= FDH$GET_INTEGER_VARIABLE
INCLUDE_DECK D= FDH$GET_NEXT_EVENT
INCLUDE_DECK D= FDH$GET_OBJECT_ATTRIBUTES
INCLUDE_DECK D= FDH$GET_REAL_VARIABLE
INCLUDE_DECK D= FDH$GET_RECORD
INCLUDE_DECK D= FDH$GET_RECORD_ATTRIBUTES
INCLUDE_DECK D= FDH$GET_STORED_OBJECT
INCLUDE_DECK D= FDH$GET_STRING_VARIABLE
INCLUDE_DECK D= FDH$GET_TABLE_ATTRIBUTES
INCLUDE_DECK D= FDH$GET_VARIABLE_ATTRIBUTES
INCLUDE_DECK D= FDH$MOVE_AREA
INCLUDE_DECK D= FDH$OPEN_FORM
INCLUDE_DECK D= FDH$PASCAL_PROCEDURES
INCLUDE_DECK D= FDH$POP_FORMS
INCLUDE_DECK D= FDH$POSITION_FORM
INCLUDE_DECK D= FDH$PUSH_FORMS
INCLUDE_DECK D= FDH$READ_FORMS
INCLUDE_DECK D= FDH$REPLACE_INTEGER_VARIABLE
INCLUDE_DECK D= FDH$REPLACE_REAL_VARIABLE
INCLUDE_DECK D= FDH$REPLACE_RECORD
INCLUDE_DECK D= FDH$REPLACE_STRING_VARIABLE
INCLUDE_DECK D= FDH$RESET_FORM
INCLUDE_DECK D= FDH$RESET_OBJECT_ATTRIBUTE
INCLUDE_DECK D= FDH$SET_CURSOR_POSITION
INCLUDE_DECK D= FDH$SET_LINE_MODE
INCLUDE_DECK D= FDH$SET_OBJECT_ATTRIBUTE
INCLUDE_DECK D= FDH$SHOW_FORMS
INCLUDE_DECK D= FDH$TAB_TO_NEXT_FIELD
INCLUDE_DECK D= FDH$WRITE_FORM_DEFINITION
INCLUDE_DECK D= FDH$WRITE_RECORD_DEFINITION
INCLUDE_DECK D= FDH$XADD_FORM
INCLUDE_DECK D= FDH$XCHANGE_TABLE_SIZE
INCLUDE_DECK D= FDH$XCLOSE_FORM
INCLUDE_DECK D= FDH$XGET_NEXT_CHANGED_VARIABLE
INCLUDE_DECK D= FDH$XCOMBINE_FORM
INCLUDE_DECK D= FDH$XGET_NEXT_INPUT_ERROR
INCLUDE_DECK D= FDH$XGET_NEXT_OUTPUT_ERROR
INCLUDE_DECK D= FDH$XDELETE_FORM
INCLUDE_DECK D= FDH$XGET_INTEGER_VARIABLE
INCLUDE_DECK D= FDH$XGET_NEXT_EVENT
INCLUDE_DECK D= FDH$XGET_REAL_VARIABLE
INCLUDE_DECK D= FDH$XGET_RECORD
INCLUDE_DECK D= FDH$XGET_STRING_VARIABLE
INCLUDE_DECK D= FDH$XOPEN_FORM
INCLUDE_DECK D= FDH$XPOP_FORMS
INCLUDE_DECK D= FDH$XPOSITION_FORM
INCLUDE_DECK D= FDH$XPUSH_FORMS
INCLUDE_DECK D= FDH$XREAD_FORMS
INCLUDE_DECK D= FDH$XREPLACE_INTEGER_VARIABLE
INCLUDE_DECK D= FDH$XREPLACE_REAL_VARIABLE
INCLUDE_DECK D= FDH$XREPLACE_RECORD
INCLUDE_DECK D= FDH$XREPLACE_STRING_VARIABLE
INCLUDE_DECK D= FDH$XRESET_FORM
INCLUDE_DECK D= FDH$XRESET_OBJECT_ATTRIBUTE
INCLUDE_DECK D= FDH$XSET_CURSOR_POSITION
INCLUDE_DECK D= FDH$XTAB_TO_NEXT_FIELD
INCLUDE_DECK D= FDP$TAB_TO_NEXT_FIELD
INCLUDE_DECK D= FDH$XSET_LINE_MODE
INCLUDE_DECK D= FDH$XSET_OBJECT_ATTRIBUTE
INCLUDE_DECK D= FDH$XSHOW_FORMS
INCLUDE_DECK D= FDP$ADD_FORM
INCLUDE_DECK D= FDP$CHANGE_FORM
INCLUDE_DECK D= FDP$CHANGE_FORM_RECORD
INCLUDE_DECK D= FDP$CHANGE_OBJECT
INCLUDE_DECK D= FDP$CHANGE_STORED_OBJECT
INCLUDE_DECK D= FDP$CHANGE_TABLE
INCLUDE_DECK D= FDP$CHANGE_TABLE_SIZE
INCLUDE_DECK D= FDP$CHANGE_VARIABLE
INCLUDE_DECK D= FDP$CLOSE_FORM
INCLUDE_DECK D= FDP$COMBINE_FORM
INCLUDE_DECK D= FDP$CONVERT_TO_PROGRAM_VARIABLE
INCLUDE_DECK D= FDP$CONVERT_TO_SCREEN_VARIABLE
INCLUDE_DECK D= FDP$COPY_AREA
INCLUDE_DECK D= FDP$COPY_FORM
INCLUDE_DECK D= FDP$CREATE_CONSTANT_TEXT
INCLUDE_DECK D= FDP$CREATE_DESIGN_FORM
INCLUDE_DECK D= FDP$CREATE_DESIGN_TEXT
INCLUDE_DECK D= FDP$CREATE_EVENT_FORM
INCLUDE_DECK D= FDP$CREATE_FORM
INCLUDE_DECK D= FDP$CREATE_MARK
INCLUDE_DECK D= FDP$CREATE_OBJECT
INCLUDE_DECK D= FDP$CREATE_STORED_OBJECT
INCLUDE_DECK D= FDP$CREATE_TABLE
INCLUDE_DECK D= FDP$CREATE_VARIABLE
INCLUDE_DECK D= FDP$DELETE_AREA
INCLUDE_DECK D= FDP$DELETE_FORM
INCLUDE_DECK D= FDP$DELETE_MARK
INCLUDE_DECK D= FDP$DELETE_OBJECT
INCLUDE_DECK D= FDP$DELETE_STORED_OBJECT
INCLUDE_DECK D= FDP$DELETE_TABLE
INCLUDE_DECK D= FDP$DELETE_VARIABLE
INCLUDE_DECK D= FDP$EDIT_FORM
INCLUDE_DECK D= FDP$END_FORM
INCLUDE_DECK D= FDP$FORTRAN_ALIASES
INCLUDE_DECK D= FDP$GET_FORM_ATTRIBUTES
INCLUDE_DECK D= FDP$GET_NEXT_CHANGED_VARIABLE
INCLUDE_DECK D= FDP$GET_FORM_NAMES
INCLUDE_DECK D= FDP$GET_NEXT_INPUT_ERROR
INCLUDE_DECK D= FDP$GET_NEXT_OUTPUT_ERROR
INCLUDE_DECK D= FDP$GET_FORM_OBJECTS
INCLUDE_DECK D= FDP$GET_INTEGER_VARIABLE
INCLUDE_DECK D= FDP$GET_NEXT_EVENT
INCLUDE_DECK D= FDP$GET_OBJECT_ATTRIBUTES
INCLUDE_DECK D= FDP$GET_REAL_VARIABLE
INCLUDE_DECK D= FDP$GET_RECORD
INCLUDE_DECK D= FDP$GET_RECORD_ATTRIBUTES
INCLUDE_DECK D= FDP$GET_STORED_OBJECT
INCLUDE_DECK D= FDP$GET_STRING_VARIABLE
INCLUDE_DECK D= FDP$GET_TABLE_ATTRIBUTES
INCLUDE_DECK D= FDP$GET_VARIABLE_ATTRIBUTES
INCLUDE_DECK D= FDP$MOVE_AREA
INCLUDE_DECK D= FDP$OPEN_FORM
INCLUDE_DECK D= FDP$PASCAL_PROCEDURES
INCLUDE_DECK D= FDP$POP_FORMS
INCLUDE_DECK D= FDP$POSITION_FORM
INCLUDE_DECK D= FDP$PUSH_FORMS
INCLUDE_DECK D= FDP$READ_FORMS
INCLUDE_DECK D= FDP$REPLACE_INTEGER_VARIABLE
INCLUDE_DECK D= FDP$REPLACE_REAL_VARIABLE
INCLUDE_DECK D= FDP$REPLACE_RECORD
INCLUDE_DECK D= FDP$REPLACE_STRING_VARIABLE
INCLUDE_DECK D= FDP$RESET_FORM
INCLUDE_DECK D= FDP$RESET_OBJECT_ATTRIBUTE
INCLUDE_DECK D= FDP$SET_CURSOR_POSITION
INCLUDE_DECK D= FDP$SET_LINE_MODE
INCLUDE_DECK D= FDP$SET_OBJECT_ATTRIBUTE
INCLUDE_DECK D= FDP$SHOW_FORMS
INCLUDE_DECK D= FDP$TAB_TO_NEXT_FIELD
INCLUDE_DECK D= FDP$WRITE_FORM_DEFINITION
INCLUDE_DECK D= FDP$WRITE_RECORD_DEFINITION
INCLUDE_DECK D= FDP$XADD_FORM
INCLUDE_DECK D= FDP$XGET_NEXT_CHANGED_VARIABLE
INCLUDE_DECK D= FDP$XCHANGE_TABLE_SIZE
INCLUDE_DECK D= FDP$XCLOSE_FORM
INCLUDE_DECK D= FDP$XGET_NEXT_INPUT_ERROR
INCLUDE_DECK D= FDP$XGET_NEXT_OUTPUT_ERROR
INCLUDE_DECK D= FDP$XCOMBINE_FORM
INCLUDE_DECK D= FDP$XDELETE_FORM
INCLUDE_DECK D= FDP$XGET_INTEGER_VARIABLE
INCLUDE_DECK D= FDP$XGET_NEXT_EVENT
INCLUDE_DECK D= FDP$XGET_REAL_VARIABLE
INCLUDE_DECK D= FDP$XGET_RECORD
INCLUDE_DECK D= FDP$XGET_STRING_VARIABLE
INCLUDE_DECK D= FDP$XOPEN_FORM
INCLUDE_DECK D= FDP$XPOP_FORMS
INCLUDE_DECK D= FDP$XPOSITION_FORM
INCLUDE_DECK D= FDP$XPUSH_FORMS
INCLUDE_DECK D= FDP$XREAD_FORMS
INCLUDE_DECK D= FDP$XREPLACE_INTEGER_VARIABLE
INCLUDE_DECK D= FDP$XREPLACE_REAL_VARIABLE
INCLUDE_DECK D= FDP$XREPLACE_RECORD
INCLUDE_DECK D= FDP$XREPLACE_STRING_VARIABLE
INCLUDE_DECK D= FDP$XRESET_FORM
INCLUDE_DECK D= FDP$XRESET_OBJECT_ATTRIBUTE
INCLUDE_DECK D= FDP$XSET_CURSOR_POSITION
INCLUDE_DECK D= FDP$XSET_LINE_MODE
INCLUDE_DECK D= FDP$XSET_OBJECT_ATTRIBUTE
INCLUDE_DECK D= FDP$XSHOW_FORMS
INCLUDE_DECK D= FDP$XTAB_TO_NEXT_FIELD
INCLUDE_DECK D= FDT$CHANGE_FORM_KEY
INCLUDE_DECK D= FDT$CHANGE_OBJECT_KEY
INCLUDE_DECK D= FDT$CHANGE_RECORD_KEY
INCLUDE_DECK D= FDT$CHANGE_TABLE_KEY
INCLUDE_DECK D= FDT$CHANGE_VARIABLE_KEY
INCLUDE_DECK D= FDT$CHARACTER_POSITION
INCLUDE_DECK D= FDT$COBOL_DISPLAY_CLAUSE
INCLUDE_DECK D= FDT$COBOL_PROGRAM_CLAUSE
INCLUDE_DECK D= FDT$COMMAND
INCLUDE_DECK D= FDT$COMMENT
INCLUDE_DECK D= FDT$COMMENT_DEFINITION
INCLUDE_DECK D= FDT$COMMENT_DEFINITIONS
INCLUDE_DECK D= FDT$COMMENT_LENGTH
INCLUDE_DECK D= FDT$COORDINATE_SYSTEM
INCLUDE_DECK D= FDT$DIGITS_IN_EXPONENT
INCLUDE_DECK D= FDT$DIGITS_RIGHT_DECIMAL
INCLUDE_DECK D= FDT$DISPLAY_ATTRIBUTE
INCLUDE_DECK D= FDT$DISPLAY_ATTRIBUTE_SET
INCLUDE_DECK D= FDT$ERROR_DEFINITION
INCLUDE_DECK D= FDT$ERROR_HEADER
INCLUDE_DECK D= FDT$ERROR_INPUT_CONVERSION
INCLUDE_DECK D= FDT$ERROR_INVALID_VALUE
INCLUDE_DECK D= FDT$ERROR_KEY
INCLUDE_DECK D= FDT$ERROR_MESSAGE
INCLUDE_DECK D= FDT$ERROR_MESSAGE_LENGTH
INCLUDE_DECK D= FDT$ERROR_NO_TABLE_OBJECT
INCLUDE_DECK D= FDT$ERROR_NO_TABLE_VARIABLE
INCLUDE_DECK D= FDT$ERROR_NO_VARIABLE_DEF
INCLUDE_DECK D= FDT$ERROR_NO_VARIABLE_OBJECT
INCLUDE_DECK D= FDT$ERROR_OUTPUT_CONVERSION
INCLUDE_DECK D= FDT$ERROR_UNEQUAL_TBL_OBJ_WIDTH
INCLUDE_DECK D= FDT$EVENT_ACTION
INCLUDE_DECK D= FDT$EVENT_COMMAND
INCLUDE_DECK D= FDT$EVENT_DEFINITION
INCLUDE_DECK D= FDT$EVENT_DEFINITIONS
INCLUDE_DECK D= FDT$EVENT_FORM_DEFINITION
INCLUDE_DECK D= FDT$EVENT_FORM_KEY
INCLUDE_DECK D= FDT$EVENT_LABEL
INCLUDE_DECK D= FDT$EVENT_LABEL_V1
INCLUDE_DECK D= FDT$EVENT_MENU
INCLUDE_DECK D= FDT$EVENT_POSITION
INCLUDE_DECK D= FDT$EVENT_POSITION_KEY
INCLUDE_DECK D= FDT$EVENT_TRIGGER
INCLUDE_DECK D= FDT$EXPONENT_OUTPUT_FORMAT
INCLUDE_DECK D= FDT$FLOAT_OUTPUT_FORMAT
INCLUDE_DECK D= FDT$FORM_AREA
INCLUDE_DECK D= FDT$FORM_AREA_KEY
INCLUDE_DECK D= FDT$FORM_ATTRIBUTE
INCLUDE_DECK D= FDT$FORM_ATTRIBUTES
INCLUDE_DECK D= FDT$FORM_DEFINITION_ERROR_KEY
INCLUDE_DECK D= FDT$FORM_IDENTIFIER
INCLUDE_DECK D= FDT$FORM_MODULE
INCLUDE_DECK D= FDT$FORM_NAME
INCLUDE_DECK D= FDT$FORM_NAMES
INCLUDE_DECK D= FDT$FORM_OBJECT
INCLUDE_DECK D= FDT$FORM_OBJECTS
INCLUDE_DECK D= FDT$FORM_PROCESSOR
INCLUDE_DECK D= FDT$GET_ERROR_DEFINITION
INCLUDE_DECK D= FDT$GET_ERROR_KEY
INCLUDE_DECK D= FDT$GET_FORM_ATTRIBUTE
INCLUDE_DECK D= FDT$GET_FORM_ATTRIBUTES
INCLUDE_DECK D= FDT$GET_FORM_KEY
INCLUDE_DECK D= FDT$GET_HELP_DEFINITION
INCLUDE_DECK D= FDT$GET_HELP_KEY
INCLUDE_DECK D= FDT$GET_OBJECT_ATTRIBUTE
INCLUDE_DECK D= FDT$GET_OBJECT_ATTRIBUTES
INCLUDE_DECK D= FDT$GET_OBJECT_DEFINITION
INCLUDE_DECK D= FDT$GET_OBJECT_KEY
INCLUDE_DECK D= FDT$GET_RECORD_ATTRIBUTE
INCLUDE_DECK D= FDT$GET_RECORD_ATTRIBUTES
INCLUDE_DECK D= FDT$GET_RECORD_KEY
INCLUDE_DECK D= FDT$GET_TABLE_ATTRIBUTE
INCLUDE_DECK D= FDT$GET_TABLE_ATTRIBUTES
INCLUDE_DECK D= FDT$GET_TABLE_KEY
INCLUDE_DECK D= FDT$GET_VALUE_STATUS
INCLUDE_DECK D= FDT$GET_VARIABLE_ATTRIBUTE
INCLUDE_DECK D= FDT$GET_VARIABLE_ATTRIBUTES
INCLUDE_DECK D= FDT$GET_VARIABLE_KEY
INCLUDE_DECK D= FDT$HEIGHT
INCLUDE_DECK D= FDT$HELP_DEFINITION
INCLUDE_DECK D= FDT$HELP_KEY
INCLUDE_DECK D= FDT$HELP_MESSAGE
INCLUDE_DECK D= FDT$HELP_MESSAGE_LENGTH
INCLUDE_DECK D= FDT$INPUT_CURRENCY_FORMAT
INCLUDE_DECK D= FDT$INPUT_FORMAT
INCLUDE_DECK D= FDT$INPUT_FORMAT_KEY
INCLUDE_DECK D= FDT$INTEGER_FIELD_WIDTH
INCLUDE_DECK D= FDT$INTEGER_OUTPUT_FORMAT
INCLUDE_DECK D= FDT$INVALID_DATA_CHARACTER
INCLUDE_DECK D= FDT$IO_MODE
INCLUDE_DECK D= FDT$MINIMUM_OUTPUT_DIGITS
INCLUDE_DECK D= FDT$NAME_SELECTION
INCLUDE_DECK D= FDT$NAME_SELECTIONS
INCLUDE_DECK D= FDT$NUMBER_COMMENTS
INCLUDE_DECK D= FDT$NUMBER_ERRORS
INCLUDE_DECK D= FDT$NUMBER_EVENTS
INCLUDE_DECK D= FDT$NUMBER_FORMS
INCLUDE_DECK D= FDT$NUMBER_NAMES
INCLUDE_DECK D= FDT$NUMBER_OBJECTS
INCLUDE_DECK D= FDT$NUMBER_OBJECT_DISPLAYS
INCLUDE_DECK D= FDT$NUMBER_RECORD_VARIABLES
INCLUDE_DECK D= FDT$NUMBER_TABLES
INCLUDE_DECK D= FDT$NUMBER_TABLE_VARIABLES
INCLUDE_DECK D= FDT$NUMBER_VALID_INTEGERS
INCLUDE_DECK D= FDT$NUMBER_VALID_REALS
INCLUDE_DECK D= FDT$NUMBER_VALID_STRINGS
INCLUDE_DECK D= FDT$NUMBER_VARIABLES
INCLUDE_DECK D= FDT$OBJECT_ATTRIBUTE
INCLUDE_DECK D= FDT$OBJECT_ATTRIBUTES
INCLUDE_DECK D= FDT$OBJECT_DEFINITION
INCLUDE_DECK D= FDT$OBJECT_DEFINITION_KEY
INCLUDE_DECK D= FDT$OBJECT_EVENT_POSITION
INCLUDE_DECK D= FDT$OCCURRENCE
INCLUDE_DECK D= FDT$OUTPUT_CURRENCY_FORMAT
INCLUDE_DECK D= FDT$OUTPUT_FORMAT
INCLUDE_DECK D= FDT$OUTPUT_FORMAT_KEY
INCLUDE_DECK D= FDT$PICTURE
INCLUDE_DECK D= FDT$PROGRAM_DATA_TYPE
INCLUDE_DECK D= FDT$PROGRAM_VARIABLE_LENGTH
INCLUDE_DECK D= FDT$PUSH_COUNT
INCLUDE_DECK D= FDT$PUT_VALUE_STATUS
INCLUDE_DECK D= FDT$REAL_FIELD_WIDTH
INCLUDE_DECK D= FDT$RECORD_ATTRIBUTE
INCLUDE_DECK D= FDT$RECORD_ATTRIBUTES
INCLUDE_DECK D= FDT$RECORD_DEFINITION_KEY
INCLUDE_DECK D= FDT$RECORD_LENGTH
INCLUDE_DECK D= FDT$RECORD_POSITION
INCLUDE_DECK D= FDT$RECORD_TYPE
INCLUDE_DECK D= FDT$SCREEN_VARIABLE_LENGTH
INCLUDE_DECK D= FDT$SIGN_TREATMENT
INCLUDE_DECK D= FDT$TABLE_AREA
INCLUDE_DECK D= FDT$TABLE_AREA_KEY
INCLUDE_DECK D= FDT$TABLE_ATTRIBUTE
INCLUDE_DECK D= FDT$TABLE_ATTRIBUTES
INCLUDE_DECK D= FDT$TABLE_INDEX
INCLUDE_DECK D= FDT$TABLE_SIZE
INCLUDE_DECK D= FDT$TERMINAL_USER_ENTRY
INCLUDE_DECK D= FDT$TEXT
INCLUDE_DECK D= FDT$TEXT_BOX_PROCESSING
INCLUDE_DECK D= FDT$TEXT_LENGTH
INCLUDE_DECK D= FDT$USAGE
INCLUDE_DECK D= FDT$VALID_STRING
INCLUDE_DECK D= FDT$VALID_STRINGS
INCLUDE_DECK D= FDT$VALID_STRING_DEFINITION
INCLUDE_DECK D= FDT$VALID_STRING_LENGTH
INCLUDE_DECK D= FDT$VARIABLE_ATTRIBUTE
INCLUDE_DECK D= FDT$VARIABLE_ATTRIBUTES
INCLUDE_DECK D= FDT$VARIABLE_INDEX
INCLUDE_DECK D= FDT$VARIABLE_LENGTH
INCLUDE_DECK D= FDT$VARIABLE_STATUS
INCLUDE_DECK D= FDT$VARIABLE_VALUE
INCLUDE_DECK D= FDT$VISIBLE_HEIGHT
INCLUDE_DECK D= FDT$VISIBLE_WIDTH
INCLUDE_DECK D= FDT$WIDTH
INCLUDE_DECK D= FDT$WORK_AREA_LENGTH
INCLUDE_DECK D= FDT$X_INCREMENT
INCLUDE_DECK D= FDT$X_POSITION
INCLUDE_DECK D= FDT$Y_INCREMENT
INCLUDE_DECK D= FDT$Y_POSITION
INCLUDE_DECK D= FSC$CONDITION_CODE_LIMITS
INCLUDE_DECK D= FSC$FILE_CONTENTS
INCLUDE_DECK D= FSC$FILE_PROCESSOR
INCLUDE_DECK D= FSC$FILE_SYSTEM_ID
INCLUDE_DECK D= FSC$LONGEST_WAIT_TIME
INCLUDE_DECK D= FSC$MAXIMUM_CYCLE_NUMBER
INCLUDE_DECK D= FSC$MAX_ATTACH_CHOICE
INCLUDE_DECK D= FSC$MAX_CYCLE_ATTRIBUTE
INCLUDE_DECK D= FSC$MAX_FILE_CHANGE
INCLUDE_DECK D= FSC$MAX_PATH_ELEMENTS
INCLUDE_DECK D= FSC$MAX_PATH_ELEMENT_SIZE
INCLUDE_DECK D= FSC$MAX_PATH_SIZE
INCLUDE_DECK D= FSC$MAX_TAPE_ATTACH_CHOICE
INCLUDE_DECK D= FSC$MAX_TAPE_LABELS
INCLUDE_DECK D= FSC$MAX_TAPE_LABEL_BLOCK_TYPE
INCLUDE_DECK D= FSC$MAX_TAPE_LABEL_LENGTH
INCLUDE_DECK D= FSC$MAX_TAPE_LABEL_LOC_METHOD
INCLUDE_DECK D= FSC$MAX_TAPE_SECURITY_OPERATION
INCLUDE_DECK D= FSC$MIN_TAPE_LABEL_LENGTH
INCLUDE_DECK D= FSC$VERSION_ONE_VE_IDENTIFIER
INCLUDE_DECK D= FSC$VERSION_TWO_VE_IDENTIFIER
INCLUDE_DECK D= FSD$ANSI_LABEL_IDENTIFIERS
INCLUDE_DECK D= FSD$ANSI_LABEL_IDENTIFIERS
INCLUDE_DECK D= FSE$ATTACH_VALIDATION_ERRORS
INCLUDE_DECK D= FSE$CLOSE_VALIDATION_ERRORS
INCLUDE_DECK D= FSE$CONDITION_CODES
INCLUDE_DECK D= FSE$COPY_VALIDATION_ERRORS
INCLUDE_DECK D= FSE$GET_INFO_VALIDATION_ERRORS
INCLUDE_DECK D= FSE$OPEN_VALIDATION_ERRORS
INCLUDE_DECK D= FSE$PATH_EXCEPTION_CONDITIONS
INCLUDE_DECK D= FSE$SYSTEM_CONDITIONS
INCLUDE_DECK D= FSH$ANALYZE_FILE_EXPIRATION
INCLUDE_DECK D= FSH$CHANGE_FILE
INCLUDE_DECK D= FSH$CLOSE_FILE
INCLUDE_DECK D= FSH$COPY_FILE
INCLUDE_DECK D= FSH$FILE_HEADER_LABELS
INCLUDE_DECK D= FSH$FILE_TRAILER_LABELS
INCLUDE_DECK D= FSH$GET_TAPE_LABEL_ATTRIBUTES
INCLUDE_DECK D= FSH$HEADER_LABELS
INCLUDE_DECK D= FSH$LOCATE_TAPE_LABEL
INCLUDE_DECK D= FSH$OPEN_FILE
INCLUDE_DECK D= FSH$TRAILER_LABELS
INCLUDE_DECK D= FSH$VERSION_ONE_TAPE_LABEL
INCLUDE_DECK D= FSH$VERSION_TWO_TAPE_LABEL
INCLUDE_DECK D= FSH$VE_WROTE_ANSI_FILE
INCLUDE_DECK D= FSH$VOLUME_HEADER_LABELS
INCLUDE_DECK D= FSH$VOLUME_TRAILER_LABELS
INCLUDE_DECK D= FSP$ANALYZE_FILE_EXPIRATION
INCLUDE_DECK D= FSP$CHANGE_FILE
INCLUDE_DECK D= FSP$CLOSE_FILE
INCLUDE_DECK D= FSP$COPY_FILE
INCLUDE_DECK D= FSP$FILE_HEADER_LABELS
INCLUDE_DECK D= FSP$FILE_TRAILER_LABELS
INCLUDE_DECK D= FSP$GET_TAPE_LABEL_ATTRIBUTES
INCLUDE_DECK D= FSP$HEADER_LABELS
INCLUDE_DECK D= FSP$LOCATE_TAPE_LABEL
INCLUDE_DECK D= FSP$OPEN_FILE
INCLUDE_DECK D= FSP$TRAILER_LABELS
INCLUDE_DECK D= FSP$VERSION_ONE_TAPE_LABEL
INCLUDE_DECK D= FSP$VERSION_TWO_TAPE_LABEL
INCLUDE_DECK D= FSP$VE_WROTE_ANSI_FILE
INCLUDE_DECK D= FSP$VOLUME_HEADER_LABELS
INCLUDE_DECK D= FSP$VOLUME_TRAILER_LABELS
INCLUDE_DECK D= FST$ACCESS_MODES
INCLUDE_DECK D= FST$ACCESS_MODE_CHOICES
INCLUDE_DECK D= FST$ANSI_EOF1_LABEL
INCLUDE_DECK D= FST$ANSI_EOF2_LABEL
INCLUDE_DECK D= FST$ANSI_EOFN_LABEL
INCLUDE_DECK D= FST$ANSI_EOV1_LABEL
INCLUDE_DECK D= FST$ANSI_EOV2_LABEL
INCLUDE_DECK D= FST$ANSI_EOVN_LABEL
INCLUDE_DECK D= FST$ANSI_HDR1_LABEL
INCLUDE_DECK D= FST$ANSI_HDR2_LABEL
INCLUDE_DECK D= FST$ANSI_HDRN_LABEL
INCLUDE_DECK D= FST$ANSI_LABEL_IDENTIFIER
INCLUDE_DECK D= FST$ANSI_LABEL_KIND
INCLUDE_DECK D= FST$ANSI_LABEL_KINDS
INCLUDE_DECK D= FST$ANSI_LABEL_NUMBER
INCLUDE_DECK D= FST$ANSI_UHLA_LABEL
INCLUDE_DECK D= FST$ANSI_UTLA_LABEL
INCLUDE_DECK D= FST$ANSI_UVLN_LABEL
INCLUDE_DECK D= FST$ANSI_VOL1_LABEL
INCLUDE_DECK D= FST$ANSI_VOLN_LABEL
INCLUDE_DECK D= FST$ATTACHMENT_OPTION
INCLUDE_DECK D= FST$ATTACHMENT_OPTIONS
INCLUDE_DECK D= FST$ATTACHMENT_SCOPE
INCLUDE_DECK D= FST$CYCLE_ATTRIBUTE_CHOICES
INCLUDE_DECK D= FST$CYCLE_DAMAGE_SYMPTOM
INCLUDE_DECK D= FST$CYCLE_DAMAGE_SYMPTOMS
INCLUDE_DECK D= FST$CYCLE_NUMBER
INCLUDE_DECK D= FST$CYCLE_REFERENCE
INCLUDE_DECK D= FST$CYCLE_SPECIFICATION
INCLUDE_DECK D= FST$DEVICE_CLASS
INCLUDE_DECK D= FST$DEVICE_CLASSES
INCLUDE_DECK D= FST$EXCEPTION_CONDITIONS
INCLUDE_DECK D= FST$FILE_ACCESS_CONDITION
INCLUDE_DECK D= FST$FILE_ACCESS_CONDITIONS
INCLUDE_DECK D= FST$FILE_ACCESS_OPTION
INCLUDE_DECK D= FST$FILE_ACCESS_OPTIONS
INCLUDE_DECK D= FST$FILE_ATTACHMENT_CHOICES
INCLUDE_DECK D= FST$FILE_CHANGE
INCLUDE_DECK D= FST$FILE_CHANGES
INCLUDE_DECK D= FST$FILE_CHANGE_CHOICES
INCLUDE_DECK D= FST$FILE_CYCLE_ATTRIBUTE
INCLUDE_DECK D= FST$FILE_CYCLE_ATTRIBUTES
INCLUDE_DECK D= FST$FILE_REFERENCE
INCLUDE_DECK D= FST$FILE_SERVER_OPTIONS
INCLUDE_DECK D= FST$LIBRARY_PRIVILEGE
INCLUDE_DECK D= FST$NUMBER_OF_PATH_ELEMENTS
INCLUDE_DECK D= FST$OPEN_POSITION
INCLUDE_DECK D= FST$PARSED_FILE_REFERENCE
INCLUDE_DECK D= FST$PATH
INCLUDE_DECK D= FST$PATH_ELEMENT_SIZE
INCLUDE_DECK D= FST$PATH_ELEMENT_SUBSTRING
INCLUDE_DECK D= FST$PATH_INDEX
INCLUDE_DECK D= FST$PATH_SIZE
INCLUDE_DECK D= FST$RESOLVED_FILE_REFERENCE
INCLUDE_DECK D= FST$RETENTION
INCLUDE_DECK D= FST$RETENTION_ATTRIBUTE_TYPE
INCLUDE_DECK D= FST$SHARE_MODES
INCLUDE_DECK D= FST$SHARE_MODE_CHOICES
INCLUDE_DECK D= FST$TAPE_ATTACH_INFO_SOURCE
INCLUDE_DECK D= FST$TAPE_ATTACHMENT
INCLUDE_DECK D= FST$TAPE_ATTACHMENT_CHOICES
INCLUDE_DECK D= FST$TAPE_ATTRIBUTE_SOURCE
INCLUDE_DECK D= FST$TAPE_BLOCK_LENGTH
INCLUDE_DECK D= FST$TAPE_FILE_SET_POSITION
INCLUDE_DECK D= FST$TAPE_FILE_SET_POS_CHOICES
INCLUDE_DECK D= FST$TAPE_LABEL_BLOCK_DESCRIPTOR
INCLUDE_DECK D= FST$TAPE_LABEL_BLOCK_TYPE
INCLUDE_DECK D= FST$TAPE_LABEL_COUNT
INCLUDE_DECK D= FST$TAPE_LABEL_IDENTIFIER
INCLUDE_DECK D= FST$TAPE_LABEL_LENGTH
INCLUDE_DECK D= FST$TAPE_LABEL_LOCATION_METHOD
INCLUDE_DECK D= FST$TAPE_LABEL_LOCATOR
INCLUDE_DECK D= FST$TAPE_LABEL_SEQUENCE_HEADER
INCLUDE_DECK D= FST$TAPE_VOLUME_INITIALIZATION
INCLUDE_DECK D= FST$TLA_RETURNED_ATTRIBUTES
INCLUDE_DECK D= FST$TRANSFER_SIZE
INCLUDE_DECK D= FST$USER_ATTRIBUTE_TYPE
INCLUDE_DECK D= FST$USER_DEFINED_ATTRIBUTE
INCLUDE_DECK D= FST$VOLUME_CONFIRMATION_OPTION
INCLUDE_DECK D= FST$VOLUME_CONFIRMATION_OPTIONS
INCLUDE_DECK D= FST$WAIT_FOR_ATTACHMENT
INCLUDE_DECK D= I#MOVE
INCLUDE_DECK D= I#REAL_MEMORY_ADDRESS
INCLUDE_DECK D= ICE$ERROR_CODES
INCLUDE_DECK D= IFC$TERMINAL_CONSTANTS
INCLUDE_DECK D= IFE$ERROR_CODES
INCLUDE_DECK D= IFE$INTERACTIVE_EXCEPTION_CODES
INCLUDE_DECK D= IFH$ADVANCE
INCLUDE_DECK D= IFH$CHANGE_TERMINAL_ATTRIBUTES
INCLUDE_DECK D= IFH$CHANGE_TERM_CONN_ATTRIBUTES
INCLUDE_DECK D= IFH$CHANGE_TERM_CONN_DEFAULTS
INCLUDE_DECK D= IFH$FETCH_TERMINAL
INCLUDE_DECK D= IFH$GET_TERMINAL_ATTRIBUTES
INCLUDE_DECK D= IFH$GET_TERM_CONN_ATTRIBUTES
INCLUDE_DECK D= IFH$GET_TERM_CONN_DEFAULTS
INCLUDE_DECK D= IFH$STORE_TERMINAL
INCLUDE_DECK D= IFH$SUPPRESS_CURSOR_POS_ECHOPLX
INCLUDE_DECK D= IFP$ADVANCE
INCLUDE_DECK D= IFP$CHANGE_TERMINAL_ATTRIBUTES
INCLUDE_DECK D= IFP$CHANGE_TERM_CONN_ATTRIBUTES
INCLUDE_DECK D= IFP$CHANGE_TERM_CONN_DEFAULTS
INCLUDE_DECK D= IFP$DISCONNECT
INCLUDE_DECK D= IFP$FETCH_TERM_CONN_ATTRIBUTES
INCLUDE_DECK D= IFP$GET_TERMINAL_ATTRIBUTES
INCLUDE_DECK D= IFP$GET_TERM_CONN_ATTRIBUTES
INCLUDE_DECK D= IFP$GET_TERM_CONN_DEFAULTS
INCLUDE_DECK D= IFP$STORE_TERM_CONN_ATTRIBUTES
INCLUDE_DECK D= IFP$SUPPRESS_CURSOR_POS_ECHOPLX
INCLUDE_DECK D= IFT$$ADVANCE_REPEAT_TYPES
INCLUDE_DECK D= IFT$CODE_SET_NAME
INCLUDE_DECK D= IFT$CONDITION_CODES
INCLUDE_DECK D= IFT$CONNECTION_ATTRIBUTES
INCLUDE_DECK D= IFT$CONNECTION_ATTRIBUTE_KEYS
INCLUDE_DECK D= IFT$CONNECTION_ATTRIBUTE_SOURCE
INCLUDE_DECK D= IFT$CONTROL_CODE_REPLACEMENT
INCLUDE_DECK D= IFT$FORMAT_EFFECTORS
INCLUDE_DECK D= IFT$FUNCTION_KEY_CLASS
INCLUDE_DECK D= IFT$GET_CONNECTION_ATTRIBUTES
INCLUDE_DECK D= IFT$GET_CONNECTION_ATTR_ERROR
INCLUDE_DECK D= IFT$TERMINAL_ATTRIBUTES
INCLUDE_DECK D= IFT$TERMINAL_ATTRIBUTE_KEYS
INCLUDE_DECK D= IFT$TERMINAL_ATTRIBUTE_TYPES
INCLUDE_DECK D= IFT$TERMINAL_CLASS
INCLUDE_DECK D= IFT$TERMINAL_CONNECTION_TYPES
INCLUDE_DECK D= IFT$TERMINAL_DEFINITIONS
INCLUDE_DECK D= IFT$TERMINAL_MODEL
INCLUDE_DECK D= IFT$TERMINAL_NAME
INCLUDE_DECK D= IFT$TITLE_FOR_ERROR_CODES
INCLUDE_DECK D= JMC$ATTRIBUTE_KEYWORD_OFFSETS
INCLUDE_DECK D= JMC$CONDITION_LIMITS2
INCLUDE_DECK D= JMC$JOB_MANAGEMENT_ID
INCLUDE_DECK D= JMC$MIN_ECC
INCLUDE_DECK D= JMD$JOB_RESOURCE_CONDITION
INCLUDE_DECK D= JMD$SRU_COUNT
INCLUDE_DECK D= JME$JOB_MONITOR_CONDITIONS
INCLUDE_DECK D= JME$QUEUED_FILE_CONDITIONS
INCLUDE_DECK D= JME$ABORT_BY_OPERATOR
INCLUDE_DECK D= JME$APPLICATION_NOT_PERMITTED
INCLUDE_DECK D= JME$APPLICATION_TABLE_IS_FULL
INCLUDE_DECK D= JME$BATCH_ACCESS_DENIED
INCLUDE_DECK D= JME$CANNOT_CHANGE_INTERACTIVE
INCLUDE_DECK D= JME$CANT_RECOVER_JOB
INCLUDE_DECK D= JME$CANT_USE_$NULL
INCLUDE_DECK D= JME$DESTINATION_USAGE_IN_USE
INCLUDE_DECK D= JME$DESTINATION_USAGE_INCORRECT
INCLUDE_DECK D= JME$DUPLICATE_ATTRIBUTE_KEY
INCLUDE_DECK D= JME$DUPLICATE_NAME
INCLUDE_DECK D= JME$ENTRY_NOT_FOUND
INCLUDE_DECK D= JME$FILE_NOT_FOUND
INCLUDE_DECK D= JME$ILLEGAL_SSN
INCLUDE_DECK D= JME$ILLEGAL_SYSTEM_JOB_COMMAND
INCLUDE_DECK D= JME$ILLEGAL_USN
INCLUDE_DECK D= JME$INCOMPATIBLE_NETWORK_ORIGIN
INCLUDE_DECK D= JME$INPUT_CANNOT_INITIATE
INCLUDE_DECK D= JME$INPUT_IS_INITIATED
INCLUDE_DECK D= JME$INPUT_QUEUE_IS_EMPTY
INCLUDE_DECK D= JME$INPUT_WAS_NOT_RECOVERED
INCLUDE_DECK D= JME$INPUT_WAS_RECOVERED
INCLUDE_DECK D= JME$INTERACTIVE_ACCESS_DENIED
INCLUDE_DECK D= JME$INTERACTIVE_JOB_DISCARDED
INCLUDE_DECK D= JME$INVALID_DATA_MODE
INCLUDE_DECK D= JME$INVALID_JOB_CLASS
INCLUDE_DECK D= JME$INVALID_JOB_STATE
INCLUDE_DECK D= JME$INVALID_KEYWORD
INCLUDE_DECK D= JME$INVALID_OUTPUT_STATE
INCLUDE_DECK D= JME$INVALID_PARAMETER
INCLUDE_DECK D= JME$INVALID_PARAMETER_VALUE
INCLUDE_DECK D= JME$INVALID_WORKING_SET_SIZE
INCLUDE_DECK D= JME$JOB_ALREADY_TERMINATED
INCLUDE_DECK D= JME$JOB_CANNOT_BE_TERMINATED
INCLUDE_DECK D= JME$JOB_DAMAGED_DURING_RECOVERY
INCLUDE_DECK D= JME$JOB_END_CALLED_UNEXPECTEDLY
INCLUDE_DECK D= JME$JOB_FORCED_OUT_OF_MEMORY
INCLUDE_DECK D= JME$JOB_HAS_A_HUNG_TASK
INCLUDE_DECK D= JME$JOB_INITIATED_TOO_LATE
INCLUDE_DECK D= JME$JOB_IS_IN_TERMINATION
INCLUDE_DECK D= JME$JOB_NOT_FOUND
INCLUDE_DECK D= JME$JOB_OWNER_ONLY
INCLUDE_DECK D= JME$JOB_RECOVERY_OR_ABORT_SET
INCLUDE_DECK D= JME$JOB_STATE_IS_NULL
INCLUDE_DECK D= JME$JOB_TERMINATED_VIA_COMMAND
INCLUDE_DECK D= JME$JOB_TERMINATING_NORMALLY
INCLUDE_DECK D= JME$JOB_WAS_NOT_RECOVERED
INCLUDE_DECK D= JME$JOB_WAS_RECOVERED
INCLUDE_DECK D= JME$LATEST_PRINT_TIME_EXPIRED
INCLUDE_DECK D= JME$LEVELER_NOT_RESPONDING
INCLUDE_DECK D= JME$LOGIN_ABORT_IN_PROLOG
INCLUDE_DECK D= JME$LOGIN_ERROR_IN_PROLOG
INCLUDE_DECK D= JME$MAXIMUM_JOBS
INCLUDE_DECK D= JME$MAXIMUM_OUTPUT
INCLUDE_DECK D= JME$MISSING_PARAMETER
INCLUDE_DECK D= JME$MUST_BE_OPERATOR
INCLUDE_DECK D= JME$MUST_BE_SYSTEM_JOB
INCLUDE_DECK D= JME$NAME_NOT_FOUND
INCLUDE_DECK D= JME$NO_JOBS_WERE_FOUND
INCLUDE_DECK D= JME$NO_OUTPUTS_WERE_FOUND
INCLUDE_DECK D= JME$NO_SPACE_FOR_FILE
INCLUDE_DECK D= JME$NO_USER_NAME_SPECIFIED
INCLUDE_DECK D= JME$NOT_ALL_JOBS_WERE_MOVED
INCLUDE_DECK D= JME$NOT_VALIDATED_FOR_COPOF
INCLUDE_DECK D= JME$OUTPUT_ALREADY_TERMINATED
INCLUDE_DECK D= JME$OUTPUT_CANNOT_INITIATE
INCLUDE_DECK D= JME$OUTPUT_IS_INITIATED
INCLUDE_DECK D= JME$OUTPUT_IS_TERMINATED
INCLUDE_DECK D= JME$OUTPUT_QUEUE_IS_EMPTY
INCLUDE_DECK D= JME$OUTPUT_STATE_IS_NULL
INCLUDE_DECK D= JME$OUTPUT_WAS_NOT_RECOVERED
INCLUDE_DECK D= JME$OUTPUT_WAS_RECOVERED
INCLUDE_DECK D= JME$PARAMETER_REQUIRED_WHEN
INCLUDE_DECK D= JME$PERMANENT_FILE_REQUIRED
INCLUDE_DECK D= JME$READ_JOB_SYSTEM_LABEL
INCLUDE_DECK D= JME$READ_OUTPUT_SYSTEM_LABEL
INCLUDE_DECK D= JME$RECOMPILATION_REQUIRED
INCLUDE_DECK D= JME$REQUIRES_OPERATOR_PRIVILEGE
INCLUDE_DECK D= JME$RESULT_ARRAY_TOO_SMALL
INCLUDE_DECK D= JME$SCHEDULING_PROFILE_CHANGED
INCLUDE_DECK D= JME$SELF_TERMINATING_JOB
INCLUDE_DECK D= JME$SERVED_FAMILY_UNAVAILABLE
INCLUDE_DECK D= JME$SL_VERSION_MISMATCH
INCLUDE_DECK D= JME$SPECIAL_PRIVILEGE_REQUIRED
INCLUDE_DECK D= JME$TASK_IS_IN_TERMINATION
INCLUDE_DECK D= JME$TEMP_ERR1
INCLUDE_DECK D= JME$TERMINAL_TIMEOUT_MESSAGE
INCLUDE_DECK D= JME$TRANSACTION_JOB_DISCONNECT
INCLUDE_DECK D= JME$TRIED_TO_SELF_DESTRUCT
INCLUDE_DECK D= JME$UNABLE_TO_RECOVER_CATALOG
INCLUDE_DECK D= JME$USER_REQUESTED_EXIT
INCLUDE_DECK D= JME$VALUE_OUT_OF_RANGE
INCLUDE_DECK D= JME$WRITE_JOB_SYSTEM_LABEL
INCLUDE_DECK D= JME$WRITE_OUTPUT_SYSTEM_LABEL
INCLUDE_DECK D= JMH$LOGOUT
INCLUDE_DECK D= JMH$SUBMIT_JOB
INCLUDE_DECK D= JMH$TERMINATE_JOB
INCLUDE_DECK D= JMP$LOGOUT
INCLUDE_DECK D= JMP$SUBMIT_JOB
INCLUDE_DECK D= JMP$TERMINATE_JOB
INCLUDE_DECK D= JMT$ATTRIBUTE_KEYS
INCLUDE_DECK D= JMT$CPU_TIME_LIMIT
INCLUDE_DECK D= JMT$DATA_DECLARATION
INCLUDE_DECK D= JMT$DATA_MODE
INCLUDE_DECK D= JMT$DATE_TIME
INCLUDE_DECK D= JMT$DESTINATION_USAGE
INCLUDE_DECK D= JMT$DISPOSITION_CODE
INCLUDE_DECK D= JMT$EXTERNAL_CHARACTERISTICS
INCLUDE_DECK D= JMT$FORMS_CODE
INCLUDE_DECK D= JMT$IMPLICIT_ROUTING_TEXT
INCLUDE_DECK D= JMT$JOB_ABORT_DISPOSITION
INCLUDE_DECK D= JMT$JOB_CLASS_NAME
INCLUDE_DECK D= JMT$JOB_INPUT_DEVICE
INCLUDE_DECK D= JMT$JOB_MODE
INCLUDE_DECK D= JMT$JOB_OUTPUT_DISPOSITION
INCLUDE_DECK D= JMT$JOB_PRIORITY_NAME
INCLUDE_DECK D= JMT$JOB_QUALIFIER_LIST
INCLUDE_DECK D= JMT$JOB_RECOVERY_DISPOSITION
INCLUDE_DECK D= JMT$JOB_STATE
INCLUDE_DECK D= JMT$JOB_STATE_SET
INCLUDE_DECK D= JMT$JOB_SUBMISSION_OPTIONS
INCLUDE_DECK D= JMT$JOB_TERMINATION_OPTIONS
INCLUDE_DECK D= JMT$MAGNETIC_TAPE_LIMIT
INCLUDE_DECK D= JMT$NAME
INCLUDE_DECK D= JMT$OUTPUT_COMMENT_BANNER
INCLUDE_DECK D= JMT$OUTPUT_COPY_COUNT
INCLUDE_DECK D= JMT$OUTPUT_DESTINATION
INCLUDE_DECK D= JMT$OUTPUT_DEVICE
INCLUDE_DECK D= JMT$OUTPUT_DISPOSITION
INCLUDE_DECK D= JMT$OUTPUT_DISPOSITION_KEYS
INCLUDE_DECK D= JMT$OUTPUT_ROUTING_BANNER
INCLUDE_DECK D= JMT$REMOTE_HOST_DIRECTIVE
INCLUDE_DECK D= JMT$SITE_INFORMATION
INCLUDE_DECK D= JMT$SOURCE_LOGICAL_ID
INCLUDE_DECK D= JMT$SRU_LIMIT
INCLUDE_DECK D= JMT$STATION
INCLUDE_DECK D= JMT$STATION_OPERATOR
INCLUDE_DECK D= JMT$STATION_USAGE
INCLUDE_DECK D= JMT$SYSTEM_JOB_PARAMETERS
INCLUDE_DECK D= JMT$SYSTEM_ROUTING_TEXT
INCLUDE_DECK D= JMT$SYSTEM_SUPPLIED_NAME
INCLUDE_DECK D= JMT$TIME_INCREMENT
INCLUDE_DECK D= JMT$USER_INFORMATION
INCLUDE_DECK D= JMT$USER_SUPPLIED_NAME
INCLUDE_DECK D= JMT$VERTICAL_PRINT_DENSITY
INCLUDE_DECK D= JMT$VFU_LOAD_PROCEDURE
INCLUDE_DECK D= JMT$WORKING_SET_SIZE
INCLUDE_DECK D= LGC$LOGGING_STATISTICS
INCLUDE_DECK D= LGC$MIN_ECC
INCLUDE_DECK D= LGE$MANPS_CONDITION_CODES
INCLUDE_DECK D= LLC$MIN_ECC
INCLUDE_DECK D= LLE$LOADER_STATUS_CONDITIONS
INCLUDE_DECK D= LLE$LOAD_MAP_DIAGNOSTICS
INCLUDE_DECK D= LLH$OBJECT_MODULE_DESCRIPTION
INCLUDE_DECK D= LLT$68000_ABSOLUTE
INCLUDE_DECK D= LLT$68000_ABSOLUTE_OBJECT_TEXT
INCLUDE_DECK D= LLT$68000_ADDRESS
INCLUDE_DECK D= LLT$ACTUAL_PARAMETERS
INCLUDE_DECK D= LLT$ADDRESS
INCLUDE_DECK D= LLT$ADDRESS_FORMULATION
INCLUDE_DECK D= LLT$ADDRESS_KIND
INCLUDE_DECK D= LLT$ADDRESS_TYPE
INCLUDE_DECK D= LLT$APPLICATION_IDENTIFIER
INCLUDE_DECK D= LLT$ARGUMENT_USAGE
INCLUDE_DECK D= LLT$BINDING_TEMPLATE
INCLUDE_DECK D= LLT$BINDING_TEMPLATE_KIND
INCLUDE_DECK D= LLT$BIT_STRING_INSERTION
INCLUDE_DECK D= LLT$COMMAND_DESCRIPTION
INCLUDE_DECK D= LLT$COMMAND_DICTIONARY
INCLUDE_DECK D= LLT$COMMAND_KIND
INCLUDE_DECK D= LLT$DEBUG_OBJECT_TEXT
INCLUDE_DECK D= LLT$DEBUG_SYMBOL_TABLE
INCLUDE_DECK D= LLT$DECLARATION_MATCHING_VALUE
INCLUDE_DECK D= LLT$DEFERRED_COMMON_BLOCKS
INCLUDE_DECK D= LLT$DEFERRED_ENTRY_POINTS
INCLUDE_DECK D= LLT$ENTRY_DEFINITION
INCLUDE_DECK D= LLT$ENTRY_POINT_ATTRIBUTES
INCLUDE_DECK D= LLT$ENTRY_POINT_DICTIONARY
INCLUDE_DECK D= LLT$EXTERNAL_LINKAGE
INCLUDE_DECK D= LLT$FORMAL_PARAMETERS
INCLUDE_DECK D= LLT$FORM_DEFINITION
INCLUDE_DECK D= LLT$FORTRAN_ARGUMENT_DESC
INCLUDE_DECK D= LLT$FORTRAN_ARGUMENT_KIND
INCLUDE_DECK D= LLT$FORTRAN_ARGUMENT_TYPE
INCLUDE_DECK D= LLT$FORTRAN_ARRAY_SIZE
INCLUDE_DECK D= LLT$FORTRAN_STRING_LENGTH
INCLUDE_DECK D= LLT$FUNCTION_DESCRIPTION
INCLUDE_DECK D= LLT$FUNCTION_DICTIONARY
INCLUDE_DECK D= LLT$HELP_MODULE_DICTIONARY
INCLUDE_DECK D= LLT$IDENTIFICATION
INCLUDE_DECK D= LLT$INFORMATION_ELEMENT
INCLUDE_DECK D= LLT$INTERNAL_ADDRESS_KIND
INCLUDE_DECK D= LLT$LIBRARIES
INCLUDE_DECK D= LLT$LIBRARY_DICTIONARY_POINTERS
INCLUDE_DECK D= LLT$LIBRARY_MEMBER_HEADER
INCLUDE_DECK D= LLT$LIBRARY_MODULE_KIND
INCLUDE_DECK D= LLT$LINE_ADDRESS_TABLE
INCLUDE_DECK D= LLT$LINE_ADDRESS_TABLE_SIZE
INCLUDE_DECK D= LLT$LOAD_MODULE
INCLUDE_DECK D= LLT$LOAD_MODULE_HEADER
INCLUDE_DECK D= LLT$MESSAGE_MODULE_DICTIONARY
INCLUDE_DECK D= LLT$MODULE_ATTRIBUTES
INCLUDE_DECK D= LLT$MODULE_DICTIONARY
INCLUDE_DECK D= LLT$MODULE_GENERATOR
INCLUDE_DECK D= LLT$MODULE_KIND
INCLUDE_DECK D= LLT$OBJECT_LIBRARY
INCLUDE_DECK D= LLT$OBJECT_LIBRARY_HEADER
INCLUDE_DECK D= LLT$OBJECT_MODULE
INCLUDE_DECK D= LLT$OBJECT_RECORD_KIND
INCLUDE_DECK D= LLT$OBJECT_TEXT_DESCRIPTOR
INCLUDE_DECK D= LLT$OBSOLETE_FORMAL_PARAMETERS
INCLUDE_DECK D= LLT$OBSOLETE_LINE_TABLE
INCLUDE_DECK D= LLT$OBSOLETE_SEGMENT_DEFINITION
INCLUDE_DECK D= LLT$OPTIMIZATION_LEVEL
INCLUDE_DECK D= LLT$PANEL_DICTIONARY
INCLUDE_DECK D= LLT$PPU_ABSOLUTE
INCLUDE_DECK D= LLT$PROGRAM_DESCRIPTION
INCLUDE_DECK D= LLT$RELOCATION
INCLUDE_DECK D= LLT$RELOCATION_CONTAINER
INCLUDE_DECK D= LLT$REPLICATION
INCLUDE_DECK D= LLT$SECTION_ACCESS_ATTRIBUTES
INCLUDE_DECK D= LLT$SECTION_ADDRESS
INCLUDE_DECK D= LLT$SECTION_DEFINITION
INCLUDE_DECK D= LLT$SECTION_KIND
INCLUDE_DECK D= LLT$SEGMENT_DEFINITION
INCLUDE_DECK D= LLT$SOURCE_LINE_NUMBER
INCLUDE_DECK D= LLT$SUPPLEMENTAL_DEBUG_TABLES
INCLUDE_DECK D= LLT$SYMBOL_TABLE
INCLUDE_DECK D= LLT$TEMPORARY_SYMBOL_TABLE
INCLUDE_DECK D= LLT$TEXT
INCLUDE_DECK D= LLT$TRANSFER_SYMBOL
INCLUDE_DECK D= MLT$EXPONENT_STYLE
INCLUDE_DECK D= MLT$SIGN_TREATMENT
INCLUDE_DECK D= MMD$SEGMENT_ACCESS_CONDITION
INCLUDE_DECK D= MME$CONDITION_CODES
INCLUDE_DECK D= MMH$ADVISE_IN
INCLUDE_DECK D= MMH$ADVISE_OUT
INCLUDE_DECK D= MMH$ADVISE_OUT_IN
INCLUDE_DECK D= MMH$CREATE_SCRATCH_SEGMENT
INCLUDE_DECK D= MMH$CREATE_USER_SEGMENT
INCLUDE_DECK D= MMH$DELETE_SCRATCH_SEGMENT
INCLUDE_DECK D= MMH$DELETE_USER_SEGMENT
INCLUDE_DECK D= MMH$FREE_PAGES
INCLUDE_DECK D= MMH$GET_SEGMENT_LENGTH
INCLUDE_DECK D= MMH$SET_ACCESS_SELECTIONS
INCLUDE_DECK D= MMH$WRITE_MODIFIED_PAGES
INCLUDE_DECK D= MMP$ADVISE_IN
INCLUDE_DECK D= MMP$ADVISE_OUT
INCLUDE_DECK D= MMP$ADVISE_OUT_IN
INCLUDE_DECK D= MMP$CREATE_SCRATCH_SEGMENT
INCLUDE_DECK D= MMP$CREATE_USER_SEGMENT
INCLUDE_DECK D= MMP$DELETE_SCRATCH_SEGMENT
INCLUDE_DECK D= MMP$DELETE_USER_SEGMENT
INCLUDE_DECK D= MMP$FREE_PAGES
INCLUDE_DECK D= MMP$GET_SEGMENT_LENGTH
INCLUDE_DECK D= MMP$SET_SEGMENT_LENGTH
INCLUDE_DECK D= MMP$SET_ACCESS_SELECTIONS
INCLUDE_DECK D= MMP$WRITE_MODIFIED_PAGES
INCLUDE_DECK D= MMT$ACCESS_SELECTIONS
INCLUDE_DECK D= MMT$USER_ATTRIBUTE_DESCRIPTOR
INCLUDE_DECK D= NAT$AWAIT_DATA_AVAILABLE
INCLUDE_DECK D= NAT$CHANGE_ATTRIBUTES
INCLUDE_DECK D= NAT$CLIENT_IDENTITY
INCLUDE_DECK D= NAT$CONNECTION_ATTRIBUTE_KIND
INCLUDE_DECK D= NAT$CONNECTION_STATE
INCLUDE_DECK D= NAT$DATA_FRAGMENTS
INCLUDE_DECK D= NAT$DATA_LENGTH
INCLUDE_DECK D= NAT$EOI_MESSAGE
INCLUDE_DECK D= NAT$GET_ATTRIBUTES
INCLUDE_DECK D= NAT$INTERNET_ADDRESS
INCLUDE_DECK D= NAT$INTERNET_SAP_IDENTIFIER
INCLUDE_DECK D= NAT$NETWORK_ADDRESS
INCLUDE_DECK D= NAT$NETWORK_ADDRESS_KIND
INCLUDE_DECK D= NAT$NETWORK_IDENTIFIER
INCLUDE_DECK D= NAT$OSI_ADDRESS_LENGTH
INCLUDE_DECK D= NAT$OSI_NETWORK_ADDRESS
INCLUDE_DECK D= NAT$OSI_PRESENTATION_ADDRESS
INCLUDE_DECK D= NAT$OSI_PRESENTATION_SELECTOR
INCLUDE_DECK D= NAT$OSI_SESSION_ADDRESS
INCLUDE_DECK D= NAT$OSI_SESSION_SELECTOR
INCLUDE_DECK D= NAT$OSI_TRANSPORT_ADDRESS
INCLUDE_DECK D= NAT$OSI_TRANSPORT_SAP_SELECTOR
INCLUDE_DECK D= NAT$PROTOCOL
INCLUDE_DECK D= NAT$SAP_IDENTIFIER
INCLUDE_DECK D= NAT$SE_INTERRUPT_DATA_LENGTH
INCLUDE_DECK D= NAT$SE_PEER_OPERATION
INCLUDE_DECK D= NAT$SE_PEER_OPERATION_KIND
INCLUDE_DECK D= NAT$SE_RECEIVE_DATA_REQ
INCLUDE_DECK D= NAT$SE_SEND_DATA_REQ
INCLUDE_DECK D= NAT$SE_SYNCHRONIZE_DATA_LENGTH
INCLUDE_DECK D= NAT$SE_SYNCHRONIZE_DIRECTION
INCLUDE_DECK D= NAT$SE_SYNCHRONIZE_REQ
INCLUDE_DECK D= NAT$SYSTEM_ADDRESS
INCLUDE_DECK D= NAT$SYSTEM_IDENTIFIER
INCLUDE_DECK D= NAT$TERMINATION_REASON
INCLUDE_DECK D= NAT$TITLE
INCLUDE_DECK D= NAT$WAIT_TIME
INCLUDE_DECK D= NFC$ABNORMAL_CONDITIONS
INCLUDE_DECK D= NFE$BATCH_TRANSFER_SERVICES
INCLUDE_DECK D= NFE$PTF_CONDITION_CODES
INCLUDE_DECK D= NFE$SOU_CONDITION_CODES
INCLUDE_DECK D= OFC$BASE_ERROR
INCLUDE_DECK D= OFC$CONDITION_LIMITS
INCLUDE_DECK D= OFC$MAX_DISPLAY_MESSAGE
INCLUDE_DECK D= OFC$MAX_MESSAGES_PER_JOB
INCLUDE_DECK D= OFC$OPERATOR_IDS
INCLUDE_DECK D= OFD$ERROR_TITLE
INCLUDE_DECK D= OFD$TYPE_DEFINITION
INCLUDE_DECK D= OFE$ERROR_CODES
INCLUDE_DECK D= OFH$CLEAR_OPERATOR_MESSAGE
INCLUDE_DECK D= OFH$DISPLAY_STATUS_MESSAGE
INCLUDE_DECK D= OFH$RECEIVE_FROM_OPERATOR
INCLUDE_DECK D= OFH$RECEIVE_OPERATOR_RESPONSE
INCLUDE_DECK D= OFH$SEND_OPERATOR_MESSAGE
INCLUDE_DECK D= OFH$SEND_TO_OPERATOR
INCLUDE_DECK D= OFP$CLEAR_OPERATOR_MESSAGE
INCLUDE_DECK D= OFP$DISPLAY_STATUS_MESSAGE
INCLUDE_DECK D= OFP$RECEIVE_FROM_OPERATOR
INCLUDE_DECK D= OFP$RECEIVE_OPERATOR_RESPONSE
INCLUDE_DECK D= OFP$SEND_FORMATTED_OPERATOR_MSG
INCLUDE_DECK D= OFP$SEND_OPERATOR_MESSAGE
INCLUDE_DECK D= OFP$SEND_TO_OPERATOR
INCLUDE_DECK D= OFT$FORMATTED_OPERATOR_MESSAGE
INCLUDE_DECK D= OFT$OPERATOR_CLASS
INCLUDE_DECK D= OFT$OPERATOR_MESSAGE
INCLUDE_DECK D= OFT$MENU_SELECTIONS
INCLUDE_DECK D= OSC$BASE_EXCEPTION
INCLUDE_DECK D= OSC$CYCLE_BUSY_COND
INCLUDE_DECK D= OSC$DATA_RESTORATION_COND
INCLUDE_DECK D= OSC$DATA_RETRIEVAL_REQ_COND
INCLUDE_DECK D= OSC$JOB_RECOVERY_CONDITION_NAME
INCLUDE_DECK D= OSC$MAXIMUM_PROCESSORS
INCLUDE_DECK D= OSC$MAXIMUM_PROCESSOR_NUMBER
INCLUDE_DECK D= OSC$MAX_CONDITION
INCLUDE_DECK D= OSC$MAX_STATUS_CONDITION_CODE
INCLUDE_DECK D= OSC$MAX_STATUS_CONDITION_NUMBER
INCLUDE_DECK D= OSC$MAX_STATUS_MESSAGE
INCLUDE_DECK D= OSC$MAX_STATUS_MESSAGE_LINE
INCLUDE_DECK D= OSC$MAX_STATUS_MESSAGE_LINES
INCLUDE_DECK D= OSC$MIN_STATUS_MESSAGE_LINE
INCLUDE_DECK D= OSC$MULTIPROCESSOR_CONSTANTS
INCLUDE_DECK D= OSC$PROCESSOR_DEFINED_REGISTERS
INCLUDE_DECK D= OSC$SPACE_UNAVAILABLE_CONDITION
INCLUDE_DECK D= OSC$STATUS_MESSAGE_HEIGHT
INCLUDE_DECK D= OSC$STATUS_MESSAGE_WIDTH
INCLUDE_DECK D= OSC$STATUS_PARAMETER_DELIMITER
INCLUDE_DECK D= OSC$UNSEEN_MAIL_CONDITION
INCLUDE_DECK D= OSC$VOLUME_UNAVAILABLE_COND
INCLUDE_DECK D= OSD$CODE_BASE_POINTER
INCLUDE_DECK D= OSD$CONDITIONS
INCLUDE_DECK D= OSD$DEFAULT_PRAGMATS
INCLUDE_DECK D= OSD$INTEGER_LIMITS
INCLUDE_DECK D= OSD$REGISTERS
INCLUDE_DECK D= OSD$UNIQUE_NAME
INCLUDE_DECK D= OSD$VIRTUAL_ADDRESS
INCLUDE_DECK D= OSD$WAIT
INCLUDE_DECK D= OSE$AWAIT_ACTIVITY_EXCEPTIONS
INCLUDE_DECK D= OSE$CONDITION_EXCEPTIONS
INCLUDE_DECK D= OSE$MESSAGE_GEN_EXCEPTIONS
INCLUDE_DECK D= OSH$APPEND_STATUS_FILE
INCLUDE_DECK D= OSH$APPEND_STATUS_INTEGER
INCLUDE_DECK D= OSH$APPEND_STATUS_PARAMETER
INCLUDE_DECK D= OSH$APPEND_STATUS_REAL
INCLUDE_DECK D= OSH$AWAIT_ACTIVITY_COMPLETION
INCLUDE_DECK D= OSH$CHANGE_INTERACTION_INFO
INCLUDE_DECK D= OSH$CHANGE_INTERACTION_STYLE
INCLUDE_DECK D= OSH$COMPRESS_FILE_REFERENCE
INCLUDE_DECK D= OSH$EXPAND_FILE_REFERENCE
INCLUDE_DECK D= OSH$FIND_APPLICATION_MENU
INCLUDE_DECK D= OSH$FIND_BRIEF_HELP_MESSAGE
INCLUDE_DECK D= OSH$FIND_FULL_HELP_MESSAGE
INCLUDE_DECK D= OSH$FIND_HELP_MODULE
INCLUDE_DECK D= OSH$FIND_PARAMETER_HELP_MESSAGE
INCLUDE_DECK D= OSH$FIND_PARAMETER_PROMPT
INCLUDE_DECK D= OSH$FIND_PARAM_ASSIST_PROMPT
INCLUDE_DECK D= OSH$FORMAT_HELP_MESSAGE
INCLUDE_DECK D= OSH$FORMAT_MESSAGE
INCLUDE_DECK D= OSH$GET_DIAGNOSTIC_SEVERITY
INCLUDE_DECK D= OSH$GET_INTERACTION_INFORMATION
INCLUDE_DECK D= OSH$GET_INTERACTION_STYLE
INCLUDE_DECK D= OSH$GET_MESSAGE_LEVEL
INCLUDE_DECK D= OSH$GET_NATURAL_LANGUAGE
INCLUDE_DECK D= OSH$GET_STATUS_CONDITION_CODE
INCLUDE_DECK D= OSH$GET_STATUS_CONDITION_NAME
INCLUDE_DECK D= OSH$GET_STATUS_CONDITION_STRING
INCLUDE_DECK D= OSH$GET_STATUS_MESSAGE_BY_CODE
INCLUDE_DECK D= OSH$GET_STATUS_SEVERITY
INCLUDE_DECK D= OSH$SET_MESSAGE_LEVEL
INCLUDE_DECK D= OSH$SET_NATURAL_LANGUAGE
INCLUDE_DECK D= OSH$SET_STATUS_ABNORMAL
INCLUDE_DECK D= OSH$SET_STATUS_FROM_CONDITION
INCLUDE_DECK D= OSH$STATUS_CONDITION_CODE
INCLUDE_DECK D= OSH$STATUS_CONDITION_NUMBER
INCLUDE_DECK D= OSH$UNPACK_STATUS_CONDITION
INCLUDE_DECK D= OSH$UNPACK_STATUS_IDENTIFIER
INCLUDE_DECK D= OSI$ASCII6_FOLDED
INCLUDE_DECK D= OSI$ASCII6_STRICT
INCLUDE_DECK D= OSI$COBOL6_FOLDED
INCLUDE_DECK D= OSI$COBOL6_STRICT
INCLUDE_DECK D= OSI$DISPLAY63_FOLDED
INCLUDE_DECK D= OSI$DISPLAY63_STRICT
INCLUDE_DECK D= OSI$DISPLAY64_FOLDED
INCLUDE_DECK D= OSI$DISPLAY64_STRICT
INCLUDE_DECK D= OSI$EBCDIC
INCLUDE_DECK D= OSI$EBCDIC6_FOLDED
INCLUDE_DECK D= OSI$EBCDIC6_STRICT
INCLUDE_DECK D= OSP$APPEND_STATUS_FILE
INCLUDE_DECK D= OSP$APPEND_STATUS_INTEGER
INCLUDE_DECK D= OSP$APPEND_STATUS_PARAMETER
INCLUDE_DECK D= OSP$APPEND_STATUS_REAL
INCLUDE_DECK D= OSP$AWAIT_ACTIVITY_COMPLETION
INCLUDE_DECK D= OSP$CHANGE_INTERACTION_INFO
INCLUDE_DECK D= OSP$CHANGE_INTERACTION_STYLE
INCLUDE_DECK D= OSP$COMPRESS_FILE_REFERENCE
INCLUDE_DECK D= OSP$EXPAND_FILE_REFERENCE
INCLUDE_DECK D= OSP$FIND_APPLICATION_MENU
INCLUDE_DECK D= OSP$FIND_BRIEF_HELP_MESSAGE
INCLUDE_DECK D= OSP$FIND_FULL_HELP_MESSAGE
INCLUDE_DECK D= OSP$FIND_HELP_MODULE
INCLUDE_DECK D= OSP$FIND_PARAMETER_HELP_MESSAGE
INCLUDE_DECK D= OSP$FIND_PARAMETER_PROMPT
INCLUDE_DECK D= OSP$FIND_PARAM_ASSIST_PROMPT
INCLUDE_DECK D= OSP$FORMAT_HELP_MESSAGE
INCLUDE_DECK D= OSP$FORMAT_MESSAGE
INCLUDE_DECK D= OSP$GET_DIAGNOSTIC_SEVERITY
INCLUDE_DECK D= OSP$GET_INTERACTION_INFORMATION
INCLUDE_DECK D= OSP$GET_INTERACTION_STYLE
INCLUDE_DECK D= OSP$GET_MESSAGE_LEVEL
INCLUDE_DECK D= OSP$GET_NATURAL_LANGUAGE
INCLUDE_DECK D= OSP$GET_STATUS_CONDITION_CODE
INCLUDE_DECK D= OSP$GET_STATUS_CONDITION_NAME
INCLUDE_DECK D= OSP$GET_STATUS_CONDITION_STRING
INCLUDE_DECK D= OSP$GET_STATUS_MESSAGE_BY_CODE
INCLUDE_DECK D= OSP$GET_STATUS_SEVERITY
INCLUDE_DECK D= OSP$SET_MESSAGE_LEVEL
INCLUDE_DECK D= OSP$SET_NATURAL_LANGUAGE
INCLUDE_DECK D= OSP$SET_STATUS_ABNORMAL
INCLUDE_DECK D= OSP$SET_STATUS_FROM_CONDITION
INCLUDE_DECK D= OSP$STATUS_CONDITION_CODE
INCLUDE_DECK D= OSP$STATUS_CONDITION_NUMBER
INCLUDE_DECK D= OSP$UNPACK_STATUS_CONDITION
INCLUDE_DECK D= OSP$UNPACK_STATUS_IDENTIFIER
INCLUDE_DECK D= OSS$JOB_PAGED_LITERAL
INCLUDE_DECK D= OST$170_OS_TYPE
INCLUDE_DECK D= OST$ACTIVITY_STATUS
INCLUDE_DECK D= OST$APPLICATION_MENU_NAME
INCLUDE_DECK D= OST$BINARY_UNIQUE_NAME
INCLUDE_DECK D= OST$BYTE
INCLUDE_DECK D= OST$CALLER_IDENTIFIER
INCLUDE_DECK D= OST$CLEAR_FILE_SPACE
INCLUDE_DECK D= OST$CONDITION_INFORMATION
INCLUDE_DECK D= OST$DATE
INCLUDE_DECK D= OST$DATE_TIME
INCLUDE_DECK D= OST$DAY_OF_WEEK
INCLUDE_DECK D= OST$DEBUG_CODE
INCLUDE_DECK D= OST$DEBUG_LIST
INCLUDE_DECK D= OST$DEBUG_MASK
INCLUDE_DECK D= OST$DEFAULT_DATE_FORMAT
INCLUDE_DECK D= OST$DEFAULT_TIME_FORMAT
INCLUDE_DECK D= OST$DIAGNOSTIC_SEVERITY
INCLUDE_DECK D= OST$EXCHANGE_PACKAGE
INCLUDE_DECK D= OST$FORMAT_MESSAGE_LEVEL
INCLUDE_DECK D= OST$FREE_RUNNING_CLOCK
INCLUDE_DECK D= OST$GLOBAL_TASK_ID
INCLUDE_DECK D= OST$HALFWORD
INCLUDE_DECK D= OST$HARDWARE_SUBRANGES
INCLUDE_DECK D= OST$HELP_MODULE
INCLUDE_DECK D= OST$INTERACTION_INFORMATION
INCLUDE_DECK D= OST$INTERACTION_INFO_ITEM
INCLUDE_DECK D= OST$INTERACTION_INFO_ITEM_KIND
INCLUDE_DECK D= OST$INTERACTION_STYLE
INCLUDE_DECK D= OST$KEYPOINT_CLASS
INCLUDE_DECK D= OST$MAX_STATUS_MESSAGE_LINE
INCLUDE_DECK D= OST$MESSAGE_MODULE_SEVERITY
INCLUDE_DECK D= OST$MESSAGE_PARAMETER
INCLUDE_DECK D= OST$MESSAGE_PARAMETERS
INCLUDE_DECK D= OST$MESSAGE_TEMPLATE
INCLUDE_DECK D= OST$MESSAGE_TEMPLATE_INDEX
INCLUDE_DECK D= OST$MESSAGE_TEMPLATE_KIND
INCLUDE_DECK D= OST$MESSAGE_TEMPLATE_MODULE
INCLUDE_DECK D= OST$MTM_CONDITION_CODE
INCLUDE_DECK D= OST$MTM_CONDITION_CODES
INCLUDE_DECK D= OST$MTM_CONDITION_NAME
INCLUDE_DECK D= OST$MTM_CONDITION_NAMES
INCLUDE_DECK D= OST$MTM_HEADER
INCLUDE_DECK D= OST$MTM_MENU_HEADER
INCLUDE_DECK D= OST$NAME
INCLUDE_DECK D= OST$NAME_REFERENCE
INCLUDE_DECK D= OST$NATURAL_LANGUAGE
INCLUDE_DECK D= OST$ONLINE_MANUAL_NAME
INCLUDE_DECK D= OST$PAGE_SIZE
INCLUDE_DECK D= OST$PARCEL
INCLUDE_DECK D= OST$PROCESSOR_ELEMENT_ID
INCLUDE_DECK D= OST$PROCESSOR_ELEMENT_NUMBER
INCLUDE_DECK D= OST$PROCESSOR_MODEL_NUMBER
INCLUDE_DECK D= OST$PROCESSOR_SERIAL_NUMBER
INCLUDE_DECK D= OST$SEGMENT_ACCESS_CONTROL
INCLUDE_DECK D= OST$SIGNATURE_LOCK_STATUS
INCLUDE_DECK D= OST$STACK_FRAME_SAVE_AREA
INCLUDE_DECK D= OST$STATUS
INCLUDE_DECK D= OST$STATUS_CONDITION
INCLUDE_DECK D= OST$STATUS_CONDITION_CODE
INCLUDE_DECK D= OST$STATUS_CONDITION_NAME
INCLUDE_DECK D= OST$STATUS_CONDITION_NUMBER
INCLUDE_DECK D= OST$STATUS_IDENTIFIER
INCLUDE_DECK D= OST$STATUS_MESSAGE
INCLUDE_DECK D= OST$STATUS_MESSAGE_LEVEL
INCLUDE_DECK D= OST$STATUS_MESSAGE_LINE
INCLUDE_DECK D= OST$STATUS_MESSAGE_LINE_COUNT
INCLUDE_DECK D= OST$STATUS_MESSAGE_LINE_SIZE
INCLUDE_DECK D= OST$STATUS_SEVERITY
INCLUDE_DECK D= OST$STRING
INCLUDE_DECK D= OST$TIME
INCLUDE_DECK D= OST$TIME_ZONE
INCLUDE_DECK D= OST$TRAP_ENABLE
INCLUDE_DECK D= OST$USER_IDENTIFICATION
INCLUDE_DECK D= OST$VIRTUAL_MACHINE_IDENTIFIER
INCLUDE_DECK D= OST$WAIT
INCLUDE_DECK D= OST$WAIT_FOR_LOCK
INCLUDE_DECK D= OST$WORD
INCLUDE_DECK D= OSV$ASCII6_FOLDED
INCLUDE_DECK D= OSV$ASCII6_STRICT
INCLUDE_DECK D= OSV$ASCII_TO_EBCDIC
INCLUDE_DECK D= OSV$COBOL6_FOLDED
INCLUDE_DECK D= OSV$COBOL6_STRICT
INCLUDE_DECK D= OSV$CONTROL_CODES_TO_QUEST_MARK
INCLUDE_DECK D= OSV$DISPLAY63_FOLDED
INCLUDE_DECK D= OSV$DISPLAY63_STRICT
INCLUDE_DECK D= OSV$DISPLAY64_FOLDED
INCLUDE_DECK D= OSV$DISPLAY64_STRICT
INCLUDE_DECK D= OSV$EBCDIC
INCLUDE_DECK D= OSV$EBCDIC6_FOLDED
INCLUDE_DECK D= OSV$EBCDIC6_STRICT
INCLUDE_DECK D= OSV$EBCDIC_TO_ASCII
INCLUDE_DECK D= OSV$LOWER_TO_UPPER
INCLUDE_DECK D= OSV$UPPER_TO_LOWER
INCLUDE_DECK D= PFC$MIN_ECC
INCLUDE_DECK D= PFC$NULL_SITE_ARCHIVE_OPTION
INCLUDE_DECK D= PFC$NULL_SITE_BACKUP_OPTION
INCLUDE_DECK D= PFC$NULL_SITE_RELEASE_OPTION
INCLUDE_DECK D= PFD$INFORMATION_SELECTIONS
INCLUDE_DECK D= PFD$PERMANENT_FILE_ATTRIBUTES
INCLUDE_DECK D= PFD$PERMANENT_FILE_DEFINITIONS
INCLUDE_DECK D= PFE$ERROR_CONDITION_CODES
INCLUDE_DECK D= PFE$SELECTION_ERRORS
INCLUDE_DECK D= PFH$ATTACH
INCLUDE_DECK D= PFH$CHANGE
INCLUDE_DECK D= PFH$COLLECT_FILE_INFORMATION
INCLUDE_DECK D= PFH$CONVERT_FS_PATH_TO_PF_PATH
INCLUDE_DECK D= PFH$CONVERT_STRING_TO_FS_PATH
INCLUDE_DECK D= PFH$DEFINE
INCLUDE_DECK D= PFH$DEFINE_CATALOG
INCLUDE_DECK D= PFH$DELETE_CATALOG_PERMIT
INCLUDE_DECK D= PFH$DELETE_PERMIT
INCLUDE_DECK D= PFH$GET_NEXT_FILE_SELECTION
INCLUDE_DECK D= PFH$PERMIT
INCLUDE_DECK D= PFH$PERMIT_CATALOG
INCLUDE_DECK D= PFH$PURGE
INCLUDE_DECK D= PFH$PURGE_CATALOG
INCLUDE_DECK D= PFH$PURGE_CATALOG_CONTENTS
INCLUDE_DECK D= PFH$RETURN_FILE_INFORMATION
INCLUDE_DECK D= PFP$ATTACH
INCLUDE_DECK D= PFP$CHANGE
INCLUDE_DECK D= PFP$COLLECT_FILE_INFORMATION
INCLUDE_DECK D= PFP$CONVERT_FS_PATH_TO_PF_PATH
INCLUDE_DECK D= PFP$CONVERT_STRING_TO_FS_PATH
INCLUDE_DECK D= PFP$DEFINE
INCLUDE_DECK D= PFP$DEFINE_CATALOG
INCLUDE_DECK D= PFP$DELETE_CATALOG_PERMIT
INCLUDE_DECK D= PFP$DELETE_PERMIT
INCLUDE_DECK D= PFP$GET_NEXT_FILE_SELECTION
INCLUDE_DECK D= PFP$PERMIT
INCLUDE_DECK D= PFP$PERMIT_CATALOG
INCLUDE_DECK D= PFP$PURGE
INCLUDE_DECK D= PFP$PURGE_CATALOG
INCLUDE_DECK D= PFP$PURGE_CATALOG_CONTENTS
INCLUDE_DECK D= PFP$RETURN_FILE_INFORMATION
INCLUDE_DECK D= PFT$DATA_RESIDENCE
INCLUDE_DECK D= PFT$RETRIEVE_OPTION
INCLUDE_DECK D= PFT$SHARED_QUEUE
INCLUDE_DECK D= PFT$SITE_ARCHIVE_OPTION
INCLUDE_DECK D= PFT$SITE_BACKUP_OPTION
INCLUDE_DECK D= PFT$SITE_RELEASE_OPTION
INCLUDE_DECK D= PMC$INTERNAL_BASE_EXCEPTION
INCLUDE_DECK D= PMC$MIN_ECC
INCLUDE_DECK D= PMC$PC_BASE_EXCEPTION
INCLUDE_DECK D= PMC$PROGRAM_MANAGEMENT_ID
INCLUDE_DECK D= PMD$DEBUG
INCLUDE_DECK D= PMD$LOCAL_QUEUES
INCLUDE_DECK D= PMD$LOG_ENTRIES
INCLUDE_DECK D= PMD$PPU_CHARACTERISTICS
INCLUDE_DECK D= PMD$SYSTEM_LOG_INTERFACE
INCLUDE_DECK D= PME$CONDITION_EXCEPTIONS
INCLUDE_DECK D= PME$DEBUG_EXCEPTIONS
INCLUDE_DECK D= PME$EXECUTION_EXCEPTIONS
INCLUDE_DECK D= PME$HUNG_RECIPIENT_TASK
INCLUDE_DECK D= PME$INSUFFICIENT_PRIVILEGE
INCLUDE_DECK D= PME$LOCAL_QUEUE_EXCEPTIONS
INCLUDE_DECK D= PME$LOGGING_EXCEPTIONS
INCLUDE_DECK D= PME$PROGRAM_SERVICES_EXCEPTIONS
INCLUDE_DECK D= PME$PROGRAM_STATE_EXCEPTIONS
INCLUDE_DECK D= PME$SYSTEM_EXCEPTIONS
INCLUDE_DECK D= PME$TARGET_RING_ERROR
INCLUDE_DECK D= PME$UNKNOWN_RECIPIENT_TASK
INCLUDE_DECK D= PMH$ABORT
INCLUDE_DECK D= PMH$AWAIT_TASK_TERMINATION
INCLUDE_DECK D= PMH$CAUSE_CONDITION
INCLUDE_DECK D= PMH$CHANGE_INHERITABLE_SEGMENTS
INCLUDE_DECK D= PMH$CLEAR_WAIT_INHIBITED
INCLUDE_DECK D= PMH$COMPUTE_DATE_TIME
INCLUDE_DECK D= PMH$COMPUTE_DATE_TIME_INCREMENT
INCLUDE_DECK D= PMH$COMPUTE_DAY_OF_WEEK
INCLUDE_DECK D= PMH$COMPUTE_LOCAL_DATE_TIME
INCLUDE_DECK D= PMH$COMPUTE_UNIVERSAL_DATE_TIME
INCLUDE_DECK D= PMH$CONNECT_QUEUE
INCLUDE_DECK D= PMH$CONTINUE_TO_CAUSE
INCLUDE_DECK D= PMH$CYCLE
INCLUDE_DECK D= PMH$DEFINE_QUEUE
INCLUDE_DECK D= PMH$DELAY
INCLUDE_DECK D= PMH$DISCONNECT_QUEUE
INCLUDE_DECK D= PMH$DISESTABLISH_COND_HANDLER
INCLUDE_DECK D= PMH$DISESTABLISH_END_HANDLER
INCLUDE_DECK D= PMH$DISESTAB_END_HNDLR_IN_RING
INCLUDE_DECK D= PMH$ENABLE_SYSTEM_CONDITIONS
INCLUDE_DECK D= PMH$ESTABLISH_CH_IN_BLOCK
INCLUDE_DECK D= PMH$ESTABLISH_CONDITION_HANDLER
INCLUDE_DECK D= PMH$ESTABLISH_END_HANDLER
INCLUDE_DECK D= PMH$ESTABLISH_END_HNDLR_IN_RING
INCLUDE_DECK D= PMH$EXECUTE
INCLUDE_DECK D= PMH$EXECUTE_PROCEDURE
INCLUDE_DECK D= PMH$EXECUTE_WITH_LESS_PRIVILEGE
INCLUDE_DECK D= PMH$EXIT
INCLUDE_DECK D= PMH$FORMAT_COMPACT_DATE
INCLUDE_DECK D= PMH$FORMAT_COMPACT_TIME
INCLUDE_DECK D= PMH$GENERATE_UNIQUE_NAME
INCLUDE_DECK D= PMH$GET_170_OS_TYPE
INCLUDE_DECK D= PMH$GET_ACCOUNT_PROJECT
INCLUDE_DECK D= PMH$GET_BINARY_CPU_ATTRIBUTES
INCLUDE_DECK D= PMH$GET_BINARY_MAINFRAME_ID
INCLUDE_DECK D= PMH$GET_BINARY_PROCESSOR_ID
INCLUDE_DECK D= PMH$GET_COMPACT_DATE_TIME
INCLUDE_DECK D= PMH$GET_CPU_ATTRIBUTES
INCLUDE_DECK D= PMH$GET_DATE
INCLUDE_DECK D= PMH$GET_DAY_OF_WEEK
INCLUDE_DECK D= PMH$GET_JOB_MODE
INCLUDE_DECK D= PMH$GET_JOB_NAMES
INCLUDE_DECK D= PMH$GET_JOB_TASK_STATISTICS
INCLUDE_DECK D= PMH$GET_LEGIBLE_DATE_TIME
INCLUDE_DECK D= PMH$GET_MAINFRAME_ATTRIBUTES
INCLUDE_DECK D= PMH$GET_MAINFRAME_ID
INCLUDE_DECK D= PMH$GET_MICROSECOND_CLOCK
INCLUDE_DECK D= PMH$GET_OS_VERSION
INCLUDE_DECK D= PMH$GET_PAGE_SIZE
INCLUDE_DECK D= PMH$GET_PARENT_CALLING_RING
INCLUDE_DECK D= PMH$GET_PARENT_TASK_ID
INCLUDE_DECK D= PMH$GET_PROCESSOR_ATTRIBUTES
INCLUDE_DECK D= PMH$GET_PROCESSOR_ID
INCLUDE_DECK D= PMH$GET_PROGRAM_DESCRIPTION
INCLUDE_DECK D= PMH$GET_PROGRAM_SIZE
INCLUDE_DECK D= PMH$GET_PROGRAM_SIZE_IN_BYTES
INCLUDE_DECK D= PMH$GET_QUEUE_LIMITS
INCLUDE_DECK D= PMH$GET_SRUS
INCLUDE_DECK D= PMH$GET_TASK_CP_TIME
INCLUDE_DECK D= PMH$GET_TASK_ID
INCLUDE_DECK D= PMH$GET_TIME
INCLUDE_DECK D= PMH$GET_TIME_ZONE
INCLUDE_DECK D= PMH$GET_UNIQUE_NAME
INCLUDE_DECK D= PMH$GET_UNIVERSAL_DATE_TIME
INCLUDE_DECK D= PMH$GET_USER_IDENTIFICATION
INCLUDE_DECK D= PMH$INHIBIT_SYSTEM_CONDITIONS
INCLUDE_DECK D= PMH$LOAD
INCLUDE_DECK D= PMH$LOAD_FROM_LIBRARY
INCLUDE_DECK D= PMH$LOG
INCLUDE_DECK D= PMH$LOG_ASCII
INCLUDE_DECK D= PMH$LONG_TERM_WAIT
INCLUDE_DECK D= PMH$MANAGE_SENSE_SWITCHES
INCLUDE_DECK D= PMH$PURGE_INSTRUCTION_STACK
INCLUDE_DECK D= PMH$READY_TASK
INCLUDE_DECK D= PMH$RECEIVE_FROM_QUEUE
INCLUDE_DECK D= PMH$REMOVE_ENTRY_POINT
INCLUDE_DECK D= PMH$REMOVE_QUEUE
INCLUDE_DECK D= PMH$RESERVE_STACK_SEGMENTS
INCLUDE_DECK D= PMH$SEND_TO_QUEUE
INCLUDE_DECK D= PMH$SET_PROCESS_INTERVAL_TIMER
INCLUDE_DECK D= PMH$STATUS_QUEUE
INCLUDE_DECK D= PMH$STATUS_QUEUES_DEFINED
INCLUDE_DECK D= PMH$TERMINATE
INCLUDE_DECK D= PMH$TEST_CONDITION_HANDLER
INCLUDE_DECK D= PMH$WAIT
INCLUDE_DECK D= PMP$ABORT
INCLUDE_DECK D= PMP$AWAIT_TASK_TERMINATION
INCLUDE_DECK D= PMP$CAUSE_CONDITION
INCLUDE_DECK D= PMP$CHANGE_INHERITABLE_SEGMENTS
INCLUDE_DECK D= PMP$CLEAR_WAIT_INHIBITED
INCLUDE_DECK D= PMP$COMPUTE_DATE_TIME
INCLUDE_DECK D= PMP$COMPUTE_DATE_TIME_INCREMENT
INCLUDE_DECK D= PMP$COMPUTE_DAY_OF_WEEK
INCLUDE_DECK D= PMP$COMPUTE_LOCAL_DATE_TIME
INCLUDE_DECK D= PMP$COMPUTE_UNIVERSAL_DATE_TIME
INCLUDE_DECK D= PMP$CONNECT_QUEUE
INCLUDE_DECK D= PMP$CONTINUE_TO_CAUSE
INCLUDE_DECK D= PMP$CYCLE
INCLUDE_DECK D= PMP$DEFINE_QUEUE
INCLUDE_DECK D= PMP$DELAY
INCLUDE_DECK D= PMP$DISCONNECT_QUEUE
INCLUDE_DECK D= PMP$DISESTABLISH_COND_HANDLER
INCLUDE_DECK D= PMP$DISESTABLISH_END_HANDLER
INCLUDE_DECK D= PMP$DISESTAB_END_HNDLR_IN_RING
INCLUDE_DECK D= PMP$ENABLE_SYSTEM_CONDITIONS
INCLUDE_DECK D= PMP$ESTABLISH_CH_IN_BLOCK
INCLUDE_DECK D= PMP$ESTABLISH_CONDITION_HANDLER
INCLUDE_DECK D= PMP$ESTABLISH_END_HANDLER
INCLUDE_DECK D= PMP$ESTABLISH_END_HNDLR_IN_RING
INCLUDE_DECK D= PMP$EXECUTE
INCLUDE_DECK D= PMP$EXECUTE_PROCEDURE
INCLUDE_DECK D= PMP$EXECUTE_WITH_LESS_PRIVILEGE
INCLUDE_DECK D= PMP$EXIT
INCLUDE_DECK D= PMP$FORMAT_COMPACT_DATE
INCLUDE_DECK D= PMP$FORMAT_COMPACT_TIME
INCLUDE_DECK D= PMP$GENERATE_UNIQUE_NAME
INCLUDE_DECK D= PMP$GET_170_OS_TYPE
INCLUDE_DECK D= PMP$GET_ACCOUNT_PROJECT
INCLUDE_DECK D= PMP$GET_BINARY_CPU_ATTRIBUTES
INCLUDE_DECK D= PMP$GET_BINARY_MAINFRAME_ID
INCLUDE_DECK D= PMP$GET_BINARY_PROCESSOR_ID
INCLUDE_DECK D= PMP$GET_COMPACT_DATE_TIME
INCLUDE_DECK D= PMP$GET_CPU_ATTRIBUTES
INCLUDE_DECK D= PMP$GET_DATE
INCLUDE_DECK D= PMP$GET_DAY_OF_WEEK
INCLUDE_DECK D= PMP$GET_JOB_MODE
INCLUDE_DECK D= PMP$GET_JOB_NAMES
INCLUDE_DECK D= PMP$GET_JOB_TASK_STATISTICS
INCLUDE_DECK D= PMP$GET_LEGIBLE_DATE_TIME
INCLUDE_DECK D= PMP$GET_MAINFRAME_ATTRIBUTES
INCLUDE_DECK D= PMP$GET_MAINFRAME_ID
INCLUDE_DECK D= PMP$GET_MICROSECOND_CLOCK
INCLUDE_DECK D= PMP$GET_OS_VERSION
INCLUDE_DECK D= PMP$GET_PAGE_SIZE
INCLUDE_DECK D= PMP$GET_PARENT_CALLING_RING
INCLUDE_DECK D= PMP$GET_PARENT_TASK_ID
INCLUDE_DECK D= PMP$GET_PROCESSOR_ATTRIBUTES
INCLUDE_DECK D= PMP$GET_PROCESSOR_ID
INCLUDE_DECK D= PMP$GET_PROGRAM_DESCRIPTION
INCLUDE_DECK D= PMP$GET_PROGRAM_SIZE
INCLUDE_DECK D= PMP$GET_PROGRAM_SIZE_IN_BYTES
INCLUDE_DECK D= PMP$GET_QUEUE_LIMITS
INCLUDE_DECK D= PMP$GET_SRUS
INCLUDE_DECK D= PMP$GET_TASK_CP_TIME
INCLUDE_DECK D= PMP$GET_TASK_ID
INCLUDE_DECK D= PMP$GET_TIME
INCLUDE_DECK D= PMP$GET_TIME_ZONE
INCLUDE_DECK D= PMP$GET_UNIQUE_NAME
INCLUDE_DECK D= PMP$GET_UNIVERSAL_DATE_TIME
INCLUDE_DECK D= PMP$GET_USER_IDENTIFICATION
INCLUDE_DECK D= PMP$INHIBIT_SYSTEM_CONDITIONS
INCLUDE_DECK D= PMP$LOAD
INCLUDE_DECK D= PMP$LOAD_FROM_LIBRARY
INCLUDE_DECK D= PMP$LOG
INCLUDE_DECK D= PMP$LOG_ASCII
INCLUDE_DECK D= PMP$LONG_TERM_WAIT
INCLUDE_DECK D= PMP$MANAGE_SENSE_SWITCHES
INCLUDE_DECK D= PMP$PURGE_INSTRUCTION_STACK
INCLUDE_DECK D= PMP$READY_TASK
INCLUDE_DECK D= PMP$RECEIVE_FROM_QUEUE
INCLUDE_DECK D= PMP$REMOVE_ENTRY_POINT
INCLUDE_DECK D= PMP$REMOVE_QUEUE
INCLUDE_DECK D= PMP$RESERVE_STACK_SEGMENTS
INCLUDE_DECK D= PMP$SEND_TO_QUEUE
INCLUDE_DECK D= PMP$SET_PROCESS_INTERVAL_TIMER
INCLUDE_DECK D= PMP$STATUS_QUEUE
INCLUDE_DECK D= PMP$STATUS_QUEUES_DEFINED
INCLUDE_DECK D= PMP$TERMINATE
INCLUDE_DECK D= PMP$TEST_CONDITION_HANDLER
INCLUDE_DECK D= PMP$WAIT
INCLUDE_DECK D= PMT$ASCII_LOGS
INCLUDE_DECK D= PMT$ASCII_LOGSET
INCLUDE_DECK D= PMT$BINARY_CPU_ATTRIBUTES
INCLUDE_DECK D= PMT$BINARY_LOGS
INCLUDE_DECK D= PMT$BINARY_LOGSET
INCLUDE_DECK D= PMT$BINARY_MAINFRAME_ID
INCLUDE_DECK D= PMT$CONDITION
INCLUDE_DECK D= PMT$CONDITION_HANDLER
INCLUDE_DECK D= PMT$CONDITION_IDENTIFIER
INCLUDE_DECK D= PMT$CONDITION_INFORMATION
INCLUDE_DECK D= PMT$CONDITION_NAME
INCLUDE_DECK D= PMT$CPU_ATTRIBUTES
INCLUDE_DECK D= PMT$DEBUG_MODE
INCLUDE_DECK D= PMT$END_HANDLER
INCLUDE_DECK D= PMT$ENTRY_POINT_REFERENCE
INCLUDE_DECK D= PMT$ESTABLISHED_HANDLER
INCLUDE_DECK D= PMT$GLOBAL_BINARY_LOGS
INCLUDE_DECK D= PMT$GLOBAL_BINARY_LOGSET
INCLUDE_DECK D= PMT$GLOBAL_LOGS
INCLUDE_DECK D= PMT$GLOBAL_LOGSET
INCLUDE_DECK D= PMT$INITIALIZATION_VALUE
INCLUDE_DECK D= PMT$JOB_LOG_ENTRY
INCLUDE_DECK D= PMT$JOB_TASK_STATISTICS
INCLUDE_DECK D= PMT$LOADED_ADDRESS
INCLUDE_DECK D= PMT$LOCAL_BINARY_LOGS
INCLUDE_DECK D= PMT$LOCAL_BINARY_LOGSET
INCLUDE_DECK D= PMT$LOG_MSG_ORIGIN
INCLUDE_DECK D= PMT$LOG_MSG_TEXT
INCLUDE_DECK D= PMT$LOGS
INCLUDE_DECK D= PMT$LOGSET
INCLUDE_DECK D= PMT$MAINFRAME_ATTRIBUTE
INCLUDE_DECK D= PMT$MAINFRAME_ATTRIBUTES
INCLUDE_DECK D= PMT$MAINFRAME_ATTRIBUTE_KEYS
INCLUDE_DECK D= PMT$MAINFRAME_ID
INCLUDE_DECK D= PMT$MAX_NUMBER_OF_TASKS
INCLUDE_DECK D= PMT$NUMBER_OF_PROCESSORS
INCLUDE_DECK D= PMT$OS_NAME
INCLUDE_DECK D= PMT$PIT_VALUE
INCLUDE_DECK D= PMT$PROCESSOR_ATTRIBUTES
INCLUDE_DECK D= PMT$PROCESSOR_MODEL_NUMBER
INCLUDE_DECK D= PMT$PROCESSOR_MODEL_TYPE
INCLUDE_DECK D= PMT$PROCESSOR_SERIAL_NUMBER
INCLUDE_DECK D= PMT$PROCESSOR_STATE
INCLUDE_DECK D= PMT$PROGRAM_DESCRIPTION
INCLUDE_DECK D= PMT$PROGRAM_NAME
INCLUDE_DECK D= PMT$PROGRAM_PARAMETERS
INCLUDE_DECK D= PMT$QUEUE_LIMITS
INCLUDE_DECK D= PMT$QUEUE_STATUS
INCLUDE_DECK D= PMT$SEGMENT_INHERITANCE_OPTIONS
INCLUDE_DECK D= PMT$SENSE_SWITCHES
INCLUDE_DECK D= PMT$STANDARD_SELECTION
INCLUDE_DECK D= PMT$SYSTEM_CONDITIONS
INCLUDE_DECK D= PMT$SYSTEM_LOG_ENTRY
INCLUDE_DECK D= PMT$TASK_CP_TIME
INCLUDE_DECK D= PMT$TASK_ID
INCLUDE_DECK D= PMT$TASK_STATUS
INCLUDE_DECK D= PMT$TIME_INCREMENT
INCLUDE_DECK D= PMT$USER_PROGRAM
INCLUDE_DECK D= PMT$VECTOR_CAPABILITY
INCLUDE_DECK D= PMT$VECTOR_DEGRADE_STATE
INCLUDE_DECK D= PMT$VECTOR_SIMULATION
INCLUDE_DECK D= RFC$CONDITION_CODE_RANGE
INCLUDE_DECK D= RFC$EXTERNAL_INTERFACE
INCLUDE_DECK D= RFC$PRODUCT_ID
INCLUDE_DECK D= RFE$CONDITION_CODES
INCLUDE_DECK D= RFP$ACCEPT_CONNECT_REQUEST
INCLUDE_DECK D= RFP$ACCEPT_SWITCH_OFFER
INCLUDE_DECK D= RFP$ACQUIRE_CONNECT_REQUEST
INCLUDE_DECK D= RFP$APPLICATION_SIGN_OFF
INCLUDE_DECK D= RFP$APPLICATION_SIGN_ON
INCLUDE_DECK D= RFP$AWAIT_RHFAM_EVENT
INCLUDE_DECK D= RFP$AWAIT_SERVER_RESPONSE
INCLUDE_DECK D= RFP$CANCEL_SWITCH_OFFER
INCLUDE_DECK D= RFP$CHANGE_ATTRIBUTES
INCLUDE_DECK D= RFP$FETCH
INCLUDE_DECK D= RFP$FIND_AVAILABLE_SERVICE
INCLUDE_DECK D= RFP$GET_ATTRIBUTES
INCLUDE_DECK D= RFP$OFFER_CONNECTION_SWITCH
INCLUDE_DECK D= RFP$RECEIVE_DATA
INCLUDE_DECK D= RFP$REJECT_CONNECT_REQUEST
INCLUDE_DECK D= RFP$REQUEST_CONNECTION
INCLUDE_DECK D= RFP$SEND_DATA
INCLUDE_DECK D= RFP$STORE
INCLUDE_DECK D= RFP$TERMINATE_ASYNC_ACTIVITY
INCLUDE_DECK D= RFP$TERMINATE_CONNECTION
INCLUDE_DECK D= RFT$EXTERNAL_INTERFACE
INCLUDE_DECK D= RFT$FILE_ATTRIBUTES
INCLUDE_DECK D= RFT$HOST_IDENTIFIER
INCLUDE_DECK D= RMC$CONDITION_CODE_LIMITS
INCLUDE_DECK D= RMC$DEFAULT_ALLOCATION_SIZE
INCLUDE_DECK D= RMC$EXTERNAL_VSN_SIZE
INCLUDE_DECK D= RMC$LIMIT_CONSTANTS
INCLUDE_DECK D= RMC$MASS_STORAGE_CLASS
INCLUDE_DECK D= RMC$MAX_ALLOCATION_SIZE
INCLUDE_DECK D= RMC$RECORDED_VSN_SIZE
INCLUDE_DECK D= RMC$UNSPECIFIED_ALLOCATION_SIZE
INCLUDE_DECK D= RMC$UNSPECIFIED_FILE_CLASS
INCLUDE_DECK D= RMC$UNSPECIFIED_FILE_SIZE
INCLUDE_DECK D= RMC$UNSPECIFIED_VSN
INCLUDE_DECK D= RMD$TAPE_DECLARATIONS
INCLUDE_DECK D= RMD$TYPE_DECLARATIONS
INCLUDE_DECK D= RMD$VOLUME_DECLARATIONS
INCLUDE_DECK D= RME$AVR_TAPE_ERRORS
INCLUDE_DECK D= RME$CLASS_VALIDATION_ERRORS
INCLUDE_DECK D= RME$CONDITION_CODES
INCLUDE_DECK D= RME$CREBLV_ERRORS
INCLUDE_DECK D= RME$MEDIA_LIBRARY_ERRORS
INCLUDE_DECK D= RME$REQUEST_COMMAND_EXCEPTIONS
INCLUDE_DECK D= RME$REQUEST_MASS_STORAGE
INCLUDE_DECK D= RME$REQUEST_TAPE
INCLUDE_DECK D= RME$REQUEST_TERMINAL
INCLUDE_DECK D= RME$ROBOTIC_INTERFACE_ERRORS
INCLUDE_DECK D= RMH$CLASSIFY_TAPE_VOLUME
INCLUDE_DECK D= RMH$COMPLETE_TAPE_ASSIGNMENT
INCLUDE_DECK D= RMH$COMPLETE_TAPE_REQUEST
INCLUDE_DECK D= RMH$FORMAT_VOL_CLASSIFICATION
INCLUDE_DECK D= RMH$GET_DEVICE_CLASS
INCLUDE_DECK D= RMH$REQUEST_MASS_STORAGE
INCLUDE_DECK D= RMH$REQUEST_NULL_DEVICE
INCLUDE_DECK D= RMH$REQUEST_TAPE
INCLUDE_DECK D= RMH$REQUEST_TERMINAL
INCLUDE_DECK D= RMH$VALIDATE_TAPE_ASSIGNMENT
INCLUDE_DECK D= RMH$VALIDATE_TAPE_REQUEST
INCLUDE_DECK D= RMH$VALIDATE_TAPE_VOLUME_INIT
INCLUDE_DECK D= RMP$CLASSIFY_TAPE_VOLUME
INCLUDE_DECK D= RMP$COMPLETE_TAPE_ASSIGNMENT
INCLUDE_DECK D= RMP$COMPLETE_TAPE_REQUEST
INCLUDE_DECK D= RMP$FORMAT_VOL_CLASSIFICATION
INCLUDE_DECK D= RMP$GET_DEVICE_CLASS
INCLUDE_DECK D= RMP$REQUEST_MASS_STORAGE
INCLUDE_DECK D= RMP$REQUEST_NULL_DEVICE
INCLUDE_DECK D= RMP$REQUEST_TAPE
INCLUDE_DECK D= RMP$REQUEST_TERMINAL
INCLUDE_DECK D= RMT$ALLOCATION_SIZE
INCLUDE_DECK D= RMT$DENSITY
INCLUDE_DECK D= RMT$DEVICE_CLASS
INCLUDE_DECK D= RMT$DEVICE_CLASSES
INCLUDE_DECK D= RMT$EXTERNAL_VSN
INCLUDE_DECK D= RMT$LABELED_TAPE_CLASSIFICATION
INCLUDE_DECK D= RMT$MASS_STORAGE_CLASS
INCLUDE_DECK D= RMT$RECORDED_VSN
INCLUDE_DECK D= RMT$RESTRICTED_ACCESS_REASON
INCLUDE_DECK D= RMT$TAPE_CLASS
INCLUDE_DECK D= RMT$TAPE_VOLUME_CLASSIFICATION
INCLUDE_DECK D= RMT$VOLUME_DESCRIPTOR
INCLUDE_DECK D= RMT$VOLUME_LABEL_TYPE
INCLUDE_DECK D= RMT$VOLUME_LIST
INCLUDE_DECK D= RMT$VOLUME_SECURITY_TYPE
INCLUDE_DECK D= RMT$WRITE_RING
INCLUDE_DECK D= SFC$CONDITION_CODE_LIMITS
INCLUDE_DECK D= SFC$MIN_ECC
INCLUDE_DECK D= SFC$UNLIMITED
INCLUDE_DECK D= SFD$TYPE_DECLARATIONS
INCLUDE_DECK D= SFE$AUDIT_CONTROL_LOCKED
INCLUDE_DECK D= SFE$AUDIT_NOT_INSTALLED
INCLUDE_DECK D= SFE$CALL_AGAIN_JOB_RECOVERED
INCLUDE_DECK D= SFE$CONDITION_CODES
INCLUDE_DECK D= SFE$COUNTER_ARRAY_SIZE_RANGE
INCLUDE_DECK D= SFE$DESCRIPTIVE_DATA_SIZE
INCLUDE_DECK D= SFE$HEAP_FULL
INCLUDE_DECK D= SFE$INCORRECT_STATISTIC_CODE
INCLUDE_DECK D= SFE$INSUFFICIENT_PRIVILEGE
INCLUDE_DECK D= SFE$INVALID_STATISTIC_NAME
INCLUDE_DECK D= SFE$LIMIT_CONDITION_CODES
INCLUDE_DECK D= SFE$ROUTING_CONTROL_LOCKED
INCLUDE_DECK D= SFE$SECURITY_AUDIT_NOT_ENABLED
INCLUDE_DECK D= SFE$STATISTIC_CONDITION_CODES
INCLUDE_DECK D= SFE$STATISTICS_NOT_AVAILABLE
INCLUDE_DECK D= SFE$TOO_MUCH_DATA_FOR_STATISTIC
INCLUDE_DECK D= SFE$UNKNOWN_AUDIT_OPERATION
INCLUDE_DECK D= SFE$UNKNOWN_AUDIT_SELECTOR
INCLUDE_DECK D= SFE$UNKNOWN_DISPLAY_COMMAND
INCLUDE_DECK D= SFE$UNKNOWN_LOG
INCLUDE_DECK D= SFE$UNKNOWN_ROUTING_CTL_ACCESS
INCLUDE_DECK D= SFE$WORK_AREA_FULL
INCLUDE_DECK D= SFH$CHANGE_JOB_WARNING_LIMIT
INCLUDE_DECK D= SFH$CONVERT_STAT_CODE_TO_NAME
INCLUDE_DECK D= SFH$CONVERT_STAT_NAME_TO_CODE
INCLUDE_DECK D= SFH$EMIT_STATISTIC
INCLUDE_DECK D= SFH$EMIT_SYSTEM_STATISTIC
INCLUDE_DECK D= SFH$GET_ALL_JOB_LIMITS
INCLUDE_DECK D= SFH$GET_JOB_LIMIT
INCLUDE_DECK D= SFH$GET_JOB_LIMIT_COUNT
INCLUDE_DECK D= SFH$GET_JOB_LIMIT_NAME
INCLUDE_DECK D= SFP$CHANGE_JOB_RESOURCE_LIMIT
INCLUDE_DECK D= SFP$CHANGE_JOB_WARNING_LIMIT
INCLUDE_DECK D= SFP$CONVERT_STAT_CODE_TO_NAME
INCLUDE_DECK D= SFP$CONVERT_STAT_NAME_TO_CODE
INCLUDE_DECK D= SFP$EMIT_STATISTIC
INCLUDE_DECK D= SFP$EMIT_SYSTEM_STATISTIC
INCLUDE_DECK D= SFP$GET_ALL_JOB_LIMITS
INCLUDE_DECK D= SFP$GET_JOB_LIMIT
INCLUDE_DECK D= SFP$GET_JOB_LIMIT_COUNT
INCLUDE_DECK D= SFP$GET_JOB_LIMIT_NAME
INCLUDE_DECK D= SFT$AUDIT_CONTROL
INCLUDE_DECK D= SFT$AUDIT_SELECTION_ENTRY
INCLUDE_DECK D= SFT$AUDIT_SELECTION_CRITERIA
INCLUDE_DECK D= SFT$AUDIT_SELECTOR
INCLUDE_DECK D= SFT$AUDITED_OPERATION
INCLUDE_DECK D= SFT$BINARY_LOGS
INCLUDE_DECK D= SFT$BINARY_LOGSET
INCLUDE_DECK D= SFT$CATALOG_OWNER
INCLUDE_DECK D= SFT$CATALOG_OWNER_SET
INCLUDE_DECK D= SFT$COMMAND_SOURCE
INCLUDE_DECK D= SFT$COMMAND_SOURCE_SET
INCLUDE_DECK D= SFT$COUNTER
INCLUDE_DECK D= SFT$COUNTERS
INCLUDE_DECK D= SFT$DESCRIPTIVE_DATA
INCLUDE_DECK D= SFT$ENFORCEMENT
INCLUDE_DECK D= SFT$LIMIT
INCLUDE_DECK D= SFT$LIMIT_UPDATE_KIND
INCLUDE_DECK D= SFT$LIMIT_UPDATE_STATISTIC
INCLUDE_DECK D= SFT$LIMIT_UPDATE_STATISTICS
INCLUDE_DECK D= SFT$OPERATION_RESULT
INCLUDE_DECK D= SFT$OPERATION_RESULT_SET
INCLUDE_DECK D= SFT$ROUTING_CONTROL
INCLUDE_DECK D= SFT$STATISTIC_CODE
INCLUDE_DECK D= SFT$STATISTIC_GROUP
INCLUDE_DECK D= SFT$STATISTIC_IDENTIFIER
INCLUDE_DECK D= SFT$STATISTIC_RECORD
INCLUDE_DECK D= TUC$CURSOR_NUMBER_OF_DIGITS
INCLUDE_DECK D= TUT$APPLICATION_NAME
INCLUDE_DECK D= TUT$APPL_STRING_CHAR
INCLUDE_DECK D= TUT$APPL_STRING_CHAR_STRING
INCLUDE_DECK D= TUT$APPL_STRING_POINTER
INCLUDE_DECK D= TUT$APPL_STRING_POINTER_ARRAY
INCLUDE_DECK D= TUT$CURSOR_ADDRESSING_BIAS
INCLUDE_DECK D= TUT$CURSOR_ADDRESSING_TYPE
INCLUDE_DECK D= TUT$CURSOR_BEHAVIOR
INCLUDE_DECK D= TUT$CURSOR_BEHAVIOR_ORDINAL
INCLUDE_DECK D= TUT$CURSOR_MOVEMENT
INCLUDE_DECK D= TUT$CURSOR_PARAMETERS
INCLUDE_DECK D= TUT$FIXED_TAB_POSITIONS
INCLUDE_DECK D= TUT$FLAGS
INCLUDE_DECK D= TUT$FLAG_ORDINALS
INCLUDE_DECK D= TUT$HEADER
INCLUDE_DECK D= TUT$INIT
INCLUDE_DECK D= TUT$INIT_ORDINALS
INCLUDE_DECK D= TUT$INIT_ORDINAL_ARRAY
INCLUDE_DECK D= TUT$INIT_TERMINAL_COMMAND
INCLUDE_DECK D= TUT$INPUT
INCLUDE_DECK D= TUT$INPUT_ARRAY
INCLUDE_DECK D= TUT$INPUT_CHARACTERS
INCLUDE_DECK D= TUT$INPUT_ORDINALS
INCLUDE_DECK D= TUT$KEY_NAME
INCLUDE_DECK D= TUT$KEY_NAME_ORDINALS
INCLUDE_DECK D= TUT$KEY_NAME_ORDINAL_ARRAY
INCLUDE_DECK D= TUT$MAPPING
INCLUDE_DECK D= TUT$MODEL_NAME
INCLUDE_DECK D= TUT$OUTPUT
INCLUDE_DECK D= TUT$OUTPUT_ORDINALS
INCLUDE_DECK D= TUT$OUTPUT_ORDINAL_ARRAY
INCLUDE_DECK D= TUT$SIZE
INCLUDE_DECK D= TUT$SIZE_TABLE
INCLUDE_DECK D= TUT$SUBTABLE_POINTERS
*DECK DECK=RAF$PROMPT_FOR_ANSWER EXPAND=FALSE
"  This deck contains commands that allow RAI$SYSTEM_DEADSTART_PROLOG
"  to interact with the operator during deadstart.
"  During recovery and normal deadstart, the PCU and LCU use an
"  exclusive command search to prevent accidental reference to
"  permanent files.  The INCLUDE_LINE command is not available in
"  the exclusive command search.  Because the OSF$BUILTIN_LIBRARY
"  is also not available during the time the system deadstart prolog
"  executes there is no way to have the following packaged in an
"  SCL proc.  Therefore the system deadstart prolog does a
"  COLLECT_TEXT to a file and then does an INCLUDE_FILE each time
"  an interaction is required with the operator.
"  An identical version of this code, packaged as an SCL proc, is in
"  deck RAI$PROMPT_FOR_ANSWER and resides in OSF$BUILTIN_LIBRARY.


" Avoid two blank lines if prompt is a null string"
  IF cmv$prompt <> '' THEN
    display_value ('  ', cmv$prompt)
  IFEND

answer_loop: ..
LOOP
  accept_line cmv$choice input prompt=' Enter yes or no: '
  cmv$choice = $translate(lower_to_upper, cmv$choice)
  IF (cmv$choice = 'Y' OR cmv$choice = 'YES') THEN
    cmv$intervene = true
    EXIT answer_loop
  ELSEIF (cmv$choice = 'N' OR cmv$choice = 'NO') THEN
    cmv$intervene = false
    EXIT answer_loop
  ELSE
    display_value ('  ', '** Error:  You must enter yes or no.', '  ** ')
  IFEND
LOOPEND answer_loop

*DECK DECK=RAF$SUBSYSTEM_INTERFACE_SC EXPAND=FALSE
INCLUDE_DECK D=AVH$GET_REMOVABLE_MEDIA_ACCESS
INCLUDE_DECK D=AVH$RING_MIN
INCLUDE_DECK D=AVH$RING_NOMINAL
INCLUDE_DECK D=AVP$CAPABILITY_ACTIVE
INCLUDE_DECK D=AVP$FAMILY_ADMINISTRATOR
INCLUDE_DECK D=AVP$GET_REMOVABLE_MEDIA_ACCESS
INCLUDE_DECK D=AVP$RING_MIN
INCLUDE_DECK D=AVP$RING_NOMINAL
INCLUDE_DECK D=AVP$REMOVABLE_MEDIA_ADMIN
INCLUDE_DECK D=AVP$REMOVABLE_MEDIA_OPERATOR
INCLUDE_DECK D=AVP$SECURITY_OPTION
INCLUDE_DECK D=AVP$SYSTEM_ADMINISTRATOR
INCLUDE_DECK D=AVT$CONDITIONAL_CAPABILITIES
INCLUDE_DECK D=AVT$SECURITY_OPTION_NAME
INCLUDE_DECK D=BAH$GET_OPEN_INFORMATION
INCLUDE_DECK D=BAP$GET_OPEN_INFORMATION
INCLUDE_DECK D=BAT$RECORD_HEADER_TYPE
INCLUDE_DECK D=BAT$RECORD_INFO
INCLUDE_DECK D=CAC$CONDITION_CODE_LIMITS
INCLUDE_DECK D=CAE$CARTRIDGE_MANAGER_ERRORS
INCLUDE_DECK D=CAE$COMMAND_VALIDATION_ERRORS
INCLUDE_DECK D=CAE$FAP_VALIDATION_ERRORS
INCLUDE_DECK D=CAE$FAP_PROGRAM_ACTIONS
INCLUDE_DECK D=CAE$SI_VALIDATION_ERRORS
INCLUDE_DECK D=CAE$SI_PROGRAM_ACTIONS
INCLUDE_DECK D=CAP$DELETE_CARTRIDGE_FILE
INCLUDE_DECK D=CAP$REQUEST_CARTRIDGE_STORAGE
INCLUDE_DECK D=CAP$REQUEST_CARTRIDGE_LIST
INCLUDE_DECK D=CAT$DATABASE_RECORD
INCLUDE_DECK D=CAT$ENTRY_SELECTOR
INCLUDE_DECK D=CAT$REQUEST_TYPES
INCLUDE_DECK D=CAT$Y_Z_LOCATION
INCLUDE_DECK D=CLC$PAGE_WIDTHS
INCLUDE_DECK D=CLH$ANALYZE_COMMAND
INCLUDE_DECK D=CLH$ADD_FILE_TO_COMMAND_LIST
INCLUDE_DECK D=CLH$BUILD_PATH_SUBTITLE
INCLUDE_DECK D=CLH$BUILD_PATTERN_FOR_WILD_CARD
INCLUDE_DECK D=CLH$BUILD_STANDARD_TITLE
INCLUDE_DECK D=CLH$CHANGE_PDT
INCLUDE_DECK D=CLH$CHANGE_TYPE_SPECIFICATION
INCLUDE_DECK D=CLH$CLOSE_DISPLAY
INCLUDE_DECK D=CLH$CONVERT_CHAR_TO_GRAPHIC
INCLUDE_DECK D=CLH$CONVERT_CYC_REF_TO_CYC_SEL
INCLUDE_DECK D=CLH$CONVERT_PDT
INCLUDE_DECK D=CLH$CONVERT_STRING_TO_FILE_PATH
INCLUDE_DECK D=CLH$DELETE_FILE_FROM_CMND_LIST
INCLUDE_DECK D=CLH$DERIVE_TYPE_SPEC_FROM_VALUE
INCLUDE_DECK D=CLH$DISCARD_ACCUMULATED_DISPLAY
INCLUDE_DECK D=CLH$EDIT_COMMAND_PARAMETER_LIST
INCLUDE_DECK D=CLH$FORMAT_VALUE
INCLUDE_DECK D=CLH$GET_COMMAND_NAME
INCLUDE_DECK D=CLH$GET_INCLUDE_ENDED
INCLUDE_DECK D=CLH$GET_LIST_OF_$LOCAL_FILES
INCLUDE_DECK D=CLH$GET_PATH_NAME
INCLUDE_DECK D=CLH$GET_PROCESSING_PHASE
INCLUDE_DECK D=CLH$GET_SYNCHRONOUS_WITH_PARENT
INCLUDE_DECK D=CLH$HORIZONTAL_TAB_DISPLAY
INCLUDE_DECK D=CLH$LOG_COMMENT
INCLUDE_DECK D=CLH$MATCH_STRING_PATTERN
INCLUDE_DECK D=CLH$NEW_DISPLAY_LINE
INCLUDE_DECK D=CLH$NEW_DISPLAY_PAGE
INCLUDE_DECK D=CLH$NEW_PAGE_PROCEDURE
INCLUDE_DECK D=CLH$NOTIFY_BEFORE_COMMAND_READ
INCLUDE_DECK D=CLH$OPEN_DISPLAY
INCLUDE_DECK D=CLH$OPEN_DISPLAY_FILE
INCLUDE_DECK D=CLH$OPEN_DISPLAY_REFERENCE
INCLUDE_DECK D=CLH$POP_INTERACTIVE_INPUT
INCLUDE_DECK D=CLH$PUSH_INTERACTIVE_INPUT
INCLUDE_DECK D=CLH$PUT_DATA_REPRESENTATION
INCLUDE_DECK D=CLH$PUT_DISPLAY
INCLUDE_DECK D=CLH$PUT_JOB_OUTPUT
INCLUDE_DECK D=CLH$PUT_PARTIAL_DISPLAY
INCLUDE_DECK D=CLH$PUT_PATH_REFERENCE_SUBTITLE
INCLUDE_DECK D=CLH$PUT_PATH_SUBTITLE
INCLUDE_DECK D=CLH$RESET_FOR_NEXT_DISPLAY_PAGE
INCLUDE_DECK D=CLH$RIGHT_JUSTIFY_STRING
INCLUDE_DECK D=CLH$SET_PRIMARY_TASK
INCLUDE_DECK D=CLH$UTILITY_DIALOG_MANAGER
INCLUDE_DECK D=CLH$VALIDATE_NAME
INCLUDE_DECK D=CLH$VERTICAL_TAB_DISPLAY
INCLUDE_DECK D=CLP$ADD_FILE_TO_COMMAND_LIST
INCLUDE_DECK D=CLP$ANALYZE_COMMAND
INCLUDE_DECK D=CLP$BUILD_PATH_SUBTITLE
INCLUDE_DECK D=CLP$BUILD_PATTERN_FOR_WILD_CARD
INCLUDE_DECK D=CLP$BUILD_STANDARD_TITLE
INCLUDE_DECK D=CLP$CHANGE_PDT
INCLUDE_DECK D=CLP$CHANGE_TYPE_SPECIFICATION
INCLUDE_DECK D=CLP$CLOSE_DISPLAY
INCLUDE_DECK D=CLP$CONVERT_CHAR_TO_GRAPHIC
INCLUDE_DECK D=CLP$CONVERT_CYC_REF_TO_CYC_SEL
INCLUDE_DECK D=CLP$CONVERT_PDT
INCLUDE_DECK D=CLP$CONVERT_STRING_TO_FILE_PATH
INCLUDE_DECK D=CLP$DELETE_FILE_FROM_CMND_LIST
INCLUDE_DECK D=CLP$DERIVE_TYPE_SPEC_FROM_VALUE
INCLUDE_DECK D=CLP$DISCARD_ACCUMULATED_DISPLAY
INCLUDE_DECK D=CLP$EDIT_COMMAND_PARAMETER_LIST
INCLUDE_DECK D=CLP$FIND_FORM
INCLUDE_DECK D=CLP$FIND_SCL_PROC_IN_LIBRARY
INCLUDE_DECK D=CLP$FORMAT_VALUE
INCLUDE_DECK D=CLP$GET_COMMAND_NAME
INCLUDE_DECK D=CLP$GET_INCLUDE_ENDED
INCLUDE_DECK D=CLP$GET_LIST_OF_$LOCAL_FILES
INCLUDE_DECK D=CLP$GET_NEXT_SCL_PROC_LINE
INCLUDE_DECK D=CLP$GET_PATH_NAME
INCLUDE_DECK D=CLP$GET_PROCESSING_PHASE
INCLUDE_DECK D=CLP$GET_SEMICOLON_AFTER_COMMAND
INCLUDE_DECK D=CLP$GET_SYNCHRONOUS_WITH_PARENT
INCLUDE_DECK D=CLP$HORIZONTAL_TAB_DISPLAY
INCLUDE_DECK D=CLP$LOG_COMMENT
INCLUDE_DECK D=CLP$MATCH_STRING_PATTERN
INCLUDE_DECK D=CLP$NEW_DISPLAY_LINE
INCLUDE_DECK D=CLP$NEW_DISPLAY_PAGE
INCLUDE_DECK D=CLP$NEW_PAGE_PROCEDURE
INCLUDE_DECK D=CLP$NOTIFY_BEFORE_COMMAND_READ
INCLUDE_DECK D=CLP$OPEN_DISPLAY
INCLUDE_DECK D=CLP$OPEN_DISPLAY_FILE
INCLUDE_DECK D=CLP$OPEN_DISPLAY_REFERENCE
INCLUDE_DECK D=CLP$POP_INTERACTIVE_INPUT
INCLUDE_DECK D=CLP$PUSH_INTERACTIVE_INPUT
INCLUDE_DECK D=CLP$PUT_DATA_REPRESENTATION
INCLUDE_DECK D=CLP$PUT_DISPLAY
INCLUDE_DECK D=CLP$PUT_JOB_OUTPUT
INCLUDE_DECK D=CLP$PUT_PARTIAL_DISPLAY
INCLUDE_DECK D=CLP$PUT_PATH_REFERENCE_SUBTITLE
INCLUDE_DECK D=CLP$PUT_PATH_SUBTITLE
INCLUDE_DECK D=CLP$RESET_FOR_NEXT_DISPLAY_PAGE
INCLUDE_DECK D=CLP$RIGHT_JUSTIFY_STRING
INCLUDE_DECK D=CLP$SET_PRIMARY_TASK
INCLUDE_DECK D=CLP$VALIDATE_NAME
INCLUDE_DECK D=CLP$VERTICAL_TAB_DISPLAY
INCLUDE_DECK D=CLT$BLOCK_HANDLE
INCLUDE_DECK D=CLT$COMMAND_LIST_ENTRY_FILE
INCLUDE_DECK D=CLT$COMMAND_LIST_ENTRY_FIL_KIND
INCLUDE_DECK D=CLT$DISPLAY_CONTROL
INCLUDE_DECK D=CLT$LEXICAL_UNIT_KIND
INCLUDE_DECK D=CLT$PARSED_PATH
INCLUDE_DECK D=CLT$PATH_DISPLAY_CHUNKS
INCLUDE_DECK D=CLT$PATH_HANDLE_KIND
INCLUDE_DECK D=CLT$PATH_KIND
INCLUDE_DECK D=CLT$PDT_CHANGE
INCLUDE_DECK D=CLT$PDT_CHANGES
INCLUDE_DECK D=CLT$PDT_CHANGE_KIND
INCLUDE_DECK D=CLT$PROCESSING_PHASE
INCLUDE_DECK D=CLT$STRING_PATTERN_ANCHOR_OPT
INCLUDE_DECK D=CLT$STRING_PATTERN_BUILD_OPTION
INCLUDE_DECK D=CLT$STRING_PATTERN_BUILD_OPTS
INCLUDE_DECK D=CLT$STRING_PATTERN_MATCH_INFO
INCLUDE_DECK D=CLT$STRING_PATTERN_MATCH_RESULT
INCLUDE_DECK D=CLT$STRING_PATTERN_SCAN_OPTION
INCLUDE_DECK D=CLT$TYPE_CHANGE
INCLUDE_DECK D=CLT$TYPE_CHANGES
INCLUDE_DECK D=CLT$TYPE_CHANGE_KIND
INCLUDE_DECK D=CLT$TYPE_DESCRIPTION
INCLUDE_DECK D=CLT$UNBUNDLED_PDT
INCLUDE_DECK D=CLT$UTILITY_DIALOG_INFO
INCLUDE_DECK D=CLT$UTILITY_DIALOG_MANAGER
INCLUDE_DECK D=CLT$WILD_CARD_PATTERN_TYPE
INCLUDE_DECK D=CLV$DISPLAY_VARIABLES
INCLUDE_DECK D=CLV$LETTER_CHAR
INCLUDE_DECK D=CLV$NIL_BLOCK_HANDLE
INCLUDE_DECK D=CLV$NIL_DISPLAY_CONTROL
INCLUDE_DECK D=CLV$NON_COBOL_NAME_CHAR
INCLUDE_DECK D=CLV$NON_LETTER_OR_DIGIT
INCLUDE_DECK D=CMC$CONDITION_LIMITS
INCLUDE_DECK D=CMC$MAX_COMMUNICATIONS_PORT
INCLUDE_DECK D=CME$LOGICAL_CONFIGURATION_MGR
INCLUDE_DECK D=CME$RESERVE_ELEMENT
INCLUDE_DECK D=CMH$CHANGE_ELEMENT_STATE
INCLUDE_DECK D=CMH$EXECUTE_PP_PROGRAM
INCLUDE_DECK D=CMH$GET_CHANNEL_DEFINITION
INCLUDE_DECK D=CMH$GET_ELEMENT_DEFINITION
INCLUDE_DECK D=CMH$GET_ELEMENT_INFORMATION
INCLUDE_DECK D=CMH$GET_ELEMENT_NAME
INCLUDE_DECK D=CMH$GET_ELEMENT_NAMES
INCLUDE_DECK D=CMH$GET_IOU_DEFINITION
INCLUDE_DECK D=CMH$GET_NUMBER_OF_ELEMENTS
INCLUDE_DECK D=CMH$GET_PP_DEFINITION
INCLUDE_DECK D=CMH$GET_PP_REGISTERS
INCLUDE_DECK D=CMH$IDLE_PP
INCLUDE_DECK D=CMH$MOUNT_STORAGE_MEDIUM
INCLUDE_DECK D=CMH$MULTIPLE_IOU_SYSTEM
INCLUDE_DECK D=CMH$RELEASE_ELEMENT
INCLUDE_DECK D=CMH$RESERVE_ELEMENT
INCLUDE_DECK D=CMH$RESUME_PP
INCLUDE_DECK D=CMP$CHANGE_ELEMENT_STATE
INCLUDE_DECK D=CMP$EXECUTE_PP_PROGRAM
INCLUDE_DECK D=CMP$GET_CHANNEL_DEFINITION
INCLUDE_DECK D=CMP$GET_ELEMENT_DEFINITION
INCLUDE_DECK D=CMP$GET_ELEMENT_INFORMATION
INCLUDE_DECK D=CMP$GET_ELEMENT_NAME
INCLUDE_DECK D=CMP$GET_ELEMENT_NAMES
INCLUDE_DECK D=CMP$GET_IOU_DEFINITION
INCLUDE_DECK D=CMP$GET_NUMBER_OF_ELEMENTS
INCLUDE_DECK D=CMP$GET_PP_DEFINITION
INCLUDE_DECK D=CMP$GET_PP_REGISTERS
INCLUDE_DECK D=CMP$IDLE_PP
INCLUDE_DECK D=CMP$MOUNT_STORAGE_MEDIUM
INCLUDE_DECK D=CMP$MULTIPLE_IOU_SYSTEM
INCLUDE_DECK D=CMP$RELEASE_ELEMENT
INCLUDE_DECK D=CMP$RESERVE_ELEMENT
INCLUDE_DECK D=CMP$RESUME_PP
INCLUDE_DECK D=CMT$CENTRAL_MEMORY_DEFINITION
INCLUDE_DECK D=CMT$CENTRAL_MEMORY_PORT_NUMBER
INCLUDE_DECK D=CMT$CHANNEL_ADAPTER_CONNECTION
INCLUDE_DECK D=CMT$CHANNEL_ADAPTER_DEFINITION
INCLUDE_DECK D=CMT$CHANNEL_DESCRIPTOR
INCLUDE_DECK D=CMT$CHANNEL_IDENTIFICATION
INCLUDE_DECK D=CMT$CHANNEL_ORDINAL
INCLUDE_DECK D=CMT$CHANNEL_PORT
INCLUDE_DECK D=CMT$CHANNEL_TYPE
INCLUDE_DECK D=CMT$CM_CONNECTIVITY
INCLUDE_DECK D=CMT$COMMUNICATIONS_CONNECTIVITY
INCLUDE_DECK D=CMT$COMMUNICATIONS_DEFINITION
INCLUDE_DECK D=CMT$COMMUNICATIONS_PORT_NUMBER
INCLUDE_DECK D=CMT$CONTROLLER_CONNECTIVITY
INCLUDE_DECK D=CMT$CONTROLLER_DEFINITION
INCLUDE_DECK D=CMT$CONTROLLER_PORT_NUMBER
INCLUDE_DECK D=CMT$CONTROLLER_PROTOCOL
INCLUDE_DECK D=CMT$CONTROL_PROTOCOL
INCLUDE_DECK D=CMT$CONTROL_PROTOCOL_KIND
INCLUDE_DECK D=CMT$CP_CONNECTIVITY
INCLUDE_DECK D=CMT$CP_DEFINITION
INCLUDE_DECK D=CMT$DATA_CHANNEL_CONNECTIVITY
INCLUDE_DECK D=CMT$DATA_CHANNEL_DEFINITION
INCLUDE_DECK D=CMT$DATA_PROTOCOL
INCLUDE_DECK D=CMT$DATA_STORAGE_PORT_NUMBER
INCLUDE_DECK D=CMT$DIAGNOSTIC_PATH
INCLUDE_DECK D=CMT$ELEMENT_CAPABILITY
INCLUDE_DECK D=CMT$ELEMENT_CONNECTION
INCLUDE_DECK D=CMT$ELEMENT_DEFINITION
INCLUDE_DECK D=CMT$ELEMENT_DESCRIPTOR
INCLUDE_DECK D=CMT$ELEMENT_INFORMATION
INCLUDE_DECK D=CMT$ELEMENT_INFO_ITEM
INCLUDE_DECK D=CMT$ELEMENT_INFO_ITEMS
INCLUDE_DECK D=CMT$ELEMENT_NAME
INCLUDE_DECK D=CMT$ELEMENT_RESERVATION
INCLUDE_DECK D=CMT$ELEMENT_SELECTOR
INCLUDE_DECK D=CMT$ELEMENT_STATUS
INCLUDE_DECK D=CMT$ELEMENT_TYPE
INCLUDE_DECK D=CMT$EQUIPMENT_IDENTIFICATION
INCLUDE_DECK D=CMT$EXTERNAL_CPU_CONNECTIVITY
INCLUDE_DECK D=CMT$EXTERNAL_CPU_DEFINITION
INCLUDE_DECK D=CMT$FUNCTION_SIZE
INCLUDE_DECK D=CMT$HARDWARE_ADDRESS
INCLUDE_DECK D=CMT$IOU_CONNECTIVITY
INCLUDE_DECK D=CMT$IOU_DEFINITION
INCLUDE_DECK D=CMT$JOB_OWNERSHIP
INCLUDE_DECK D=CMT$MAINFRAME_DEFINITION
INCLUDE_DECK D=CMT$MAINTENANCE_ACTIVITY
INCLUDE_DECK D=CMT$PEM_CONNECTIVITY
INCLUDE_DECK D=CMT$PEM_DEFINITION
INCLUDE_DECK D=CMT$PERIPHERAL_DESCRIPTOR
INCLUDE_DECK D=CMT$PHYSICAL_ADDRESS_PARTS
INCLUDE_DECK D=CMT$PHYSICAL_ADDRESS_SPECIFIER
INCLUDE_DECK D=CMT$PHYSICAL_DESCRIPTORS
INCLUDE_DECK D=CMT$PHYSICAL_EQUIPMENT_NUMBER
INCLUDE_DECK D=CMT$PHYSICAL_IDENTIFICATION
INCLUDE_DECK D=CMT$PHYSICAL_UNIT_NUMBER
INCLUDE_DECK D=CMT$PP_CONNECTIVITY
INCLUDE_DECK D=CMT$PP_DEFINITION
INCLUDE_DECK D=CMT$PP_DESCRIPTOR
INCLUDE_DECK D=CMT$PP_IDENTIFICATION
INCLUDE_DECK D=CMT$PP_MEMORY_LENGTH
INCLUDE_DECK D=CMT$PP_ORDINAL
INCLUDE_DECK D=CMT$PP_PROGRAM_DESCRIPTION
INCLUDE_DECK D=CMT$PP_REGISTERS
INCLUDE_DECK D=CMT$PP_RESERVATION
INCLUDE_DECK D=CMT$PP_RESERVATION_CHOICES
INCLUDE_DECK D=CMT$PP_VECTOR
INCLUDE_DECK D=CMT$PRODUCT_IDENTIFICATION
INCLUDE_DECK D=CMT$RADIAL_IF_PORT_NUMBER
INCLUDE_DECK D=CMT$RADIAL_INTERFACE
INCLUDE_DECK D=CMT$SENSOR_CHANNEL
INCLUDE_DECK D=CMT$SENSOR_CHANNEL_NUMBER
INCLUDE_DECK D=CMT$SENSOR_CONNECTION_NUMBER
INCLUDE_DECK D=CMT$SERIAL_NUMBER
INCLUDE_DECK D=CMT$STORAGE_DEVICE_CONNECTIVITY
INCLUDE_DECK D=CMT$STORAGE_DEVICE_DEFINITION
INCLUDE_DECK D=CMT$SYSTEM_ACTIVITY
INCLUDE_DECK D=CMT$UPLINE_CONNECTION
INCLUDE_DECK D= CSC$MAX_ATTRIBUTE
INCLUDE_DECK D= CSC$MAX_CHARACTER_POSITION
INCLUDE_DECK D= CSC$MAX_CONTROL
INCLUDE_DECK D= CSC$MAX_FIELD_NUMBER
INCLUDE_DECK D= CSC$MAX_GRAPHIC_ID
INCLUDE_DECK D= CSC$MAX_IMPLEMENTED_ATTRIBUTES
INCLUDE_DECK D= CSC$MAX_LINE_NUMBER
INCLUDE_DECK D= CSC$MAX_NAME
INCLUDE_DECK D= CSC$MAX_SCREEN_DIMENSIONS
INCLUDE_DECK D= CSC$MAX_STRING
INCLUDE_DECK D= CSC$MAX_TAB_POSITION
INCLUDE_DECK D= CSC$MAX_TAB_STOPS
INCLUDE_DECK D= CSC$MAX_TERMINAL_MODEL_NAME
INCLUDE_DECK D= CSC$MAX_TIMEOUT
INCLUDE_DECK D= CSC$MAX_VISIBLE_CHAR_POSITION
INCLUDE_DECK D= CSC$MAX_X_POSITION
INCLUDE_DECK D= CSC$MAX_Y_POSITION
INCLUDE_DECK D= CSC$MAX_MOUSE_EVENT
INCLUDE_DECK D= CSC$WORKSPACE_CONSTANTS
INCLUDE_DECK D= CSE$CONDITION_CODES
INCLUDE_DECK D= CSH$ACCEPT_INPUT
INCLUDE_DECK D= CSH$CHANGE_MENU_ITEM_STRINGS
INCLUDE_DECK D= CSH$CHANGE_PARTIAL_SCREEN
INCLUDE_DECK D= CSH$CHANGE_WORKSPACE_ATTRIBUTES
INCLUDE_DECK D= CSH$CHANGE_WORKSPACE_TEXT
INCLUDE_DECK D= CSH$CLEAR_WORKSPACE_AREA
INCLUDE_DECK D= CSH$CLOSE_WORKSTATION
INCLUDE_DECK D= CSH$DISPLAY_WORKSPACE
INCLUDE_DECK D= CSH$DRAW_LINES
INCLUDE_DECK D= CSH$GET_CHANGED_TEXT
INCLUDE_DECK D= CSH$GET_MENU_ITEM_STRING
INCLUDE_DECK D= CSH$GET_MENU_STRINGS
INCLUDE_DECK D= CSH$GET_WORKSPACE_TEXT
INCLUDE_DECK D= CSH$OPEN_WORKSTATION
INCLUDE_DECK D= CSH$SET_MENU_STRINGS
INCLUDE_DECK D= CSH$SET_WORKSPACE_CURSOR
INCLUDE_DECK D= CSP$ACCEPT_INPUT
INCLUDE_DECK D= CSP$ACKNOWLEDGE
INCLUDE_DECK D= CSP$ALLOCATE_FIELD
INCLUDE_DECK D= CSP$CHANGE_BACKGROUND_COLOR
INCLUDE_DECK D= CSP$CHANGE_CAPABILITY_LEVEL
INCLUDE_DECK D= CSP$CHANGE_CHANGED_TEXT_MODE
INCLUDE_DECK D= CSP$CHANGE_CURSOR_POSITION
INCLUDE_DECK D= CSP$CHANGE_DEVICE_DIMENSIONS
INCLUDE_DECK D= CSP$CHANGE_FIELD_ATTRIBUTES
INCLUDE_DECK D= CSP$CHANGE_FIELD_BOUNDARIES
INCLUDE_DECK D= CSP$CHANGE_FIELD_DIRECTION
INCLUDE_DECK D= CSP$CHANGE_FOREGROUND_COLOR
INCLUDE_DECK D= CSP$CHANGE_GRAPHIC_ATTRIBUTES
INCLUDE_DECK D= CSP$CHANGE_INPUT_TIMEOUT
INCLUDE_DECK D= CSP$CHANGE_INTERACTION_STYLE
INCLUDE_DECK D= CSP$CHANGE_IO_POSITION
INCLUDE_DECK D= CSP$CHANGE_LINE_COLOR
INCLUDE_DECK D= CSP$CHANGE_LINE_WIDTH
INCLUDE_DECK D= CSP$CHANGE_LOGICAL_HIGHLIGHTING
INCLUDE_DECK D= CSP$CHANGE_MENU_ITEM_STRINGS
INCLUDE_DECK D= CSP$CHANGE_MODEL_NAME
INCLUDE_DECK D= CSP$CHANGE_MULTIPLE_SCREENS
INCLUDE_DECK D= CSP$CHANGE_PAGE_ATTRIBUTES
INCLUDE_DECK D= CSP$CHANGE_PAGE_COLOR
INCLUDE_DECK D= CSP$CHANGE_PAGE_TABS
INCLUDE_DECK D= CSP$CHANGE_PARTIAL_SCREEN
INCLUDE_DECK D= CSP$CHANGE_PHYS_HIGHLIGHTING
INCLUDE_DECK D= CSP$CHANGE_SCREEN_IDENTIFIER
INCLUDE_DECK D= CSP$CHANGE_TEXT_ATTRIBUTES
INCLUDE_DECK D= CSP$CHANGE_WORKSPACE_ATTRIBUTES
INCLUDE_DECK D= CSP$CHANGE_WORKSPACE_TEXT
INCLUDE_DECK D= CSP$CLASSIFY_FIELD_EVENT
INCLUDE_DECK D= CSP$CLEAR_FIELD
INCLUDE_DECK D= CSP$CLEAR_PAGE
INCLUDE_DECK D= CSP$CLEAR_PAGE_TABS
INCLUDE_DECK D= CSP$CLEAR_SCREEN
INCLUDE_DECK D= CSP$CLEAR_WORKSPACE_AREA
INCLUDE_DECK D= CSP$CLOSE_WORKSTATION
INCLUDE_DECK D= CSP$CREATE_FIELD
INCLUDE_DECK D= CSP$DELETE_FIELD
INCLUDE_DECK D= CSP$DELETE_GRAPHIC
INCLUDE_DECK D= CSP$DISABLE_MENU_ITEM
INCLUDE_DECK D= CSP$DISPLAY_MENU
INCLUDE_DECK D= CSP$DISPLAY_WORKSPACE
INCLUDE_DECK D= CSP$DRAW_LINES
INCLUDE_DECK D= CSP$ENABLE_MENU_ITEM
INCLUDE_DECK D= CSP$FLUSH_EVENTS
INCLUDE_DECK D= CSP$GET_APPLICATION_PARAMETERS
INCLUDE_DECK D= CSP$GET_CHANGED_TEXT
INCLUDE_DECK D= CSP$GET_DEVICE_ATTRIBUTES
INCLUDE_DECK D= CSP$GET_DEVICE_CHARACTERISTICS
INCLUDE_DECK D= CSP$GET_DEVICE_DIMENSIONS
INCLUDE_DECK D= CSP$GET_DEV_REVERSE_ATTR
INCLUDE_DECK D= CSP$GET_EVENT
INCLUDE_DECK D= CSP$GET_EVENT_LABEL
INCLUDE_DECK D= CSP$GET_EVENT_MAPPING
INCLUDE_DECK D= CSP$GET_EVENT_NAME
INCLUDE_DECK D= CSP$GET_FIELD_ATTRIBUTES
INCLUDE_DECK D= CSP$GET_FIELD_DIRECTION
INCLUDE_DECK D= CSP$GET_IO_POSITION
INCLUDE_DECK D= CSP$GET_MENU_ITEM_STRING
INCLUDE_DECK D= CSP$GET_MENU_STRINGS
INCLUDE_DECK D= CSP$GET_NEXT_APPLICATION_PARAM
INCLUDE_DECK D= CSP$GET_PAGE_ATTRIBUTES
INCLUDE_DECK D= CSP$GET_SCREEN_IDENTIFIER
INCLUDE_DECK D= CSP$GET_TEXT
INCLUDE_DECK D= CSP$GET_WORKSPACE_TEXT
INCLUDE_DECK D= CSP$MARK
INCLUDE_DECK D= CSP$MARK_MENU_ITEM
INCLUDE_DECK D= CSP$OPEN_WORKSTATION
INCLUDE_DECK D= CSP$POLY_HV_LINE
INCLUDE_DECK D= CSP$POLY_INTERSECT
INCLUDE_DECK D= CSP$POP_PAGE
INCLUDE_DECK D= CSP$POSITION_CURSOR
INCLUDE_DECK D= CSP$POSITION_FIELD_DATA
INCLUDE_DECK D= CSP$PUSH_PAGE
INCLUDE_DECK D= CSP$PUT_TEXT
INCLUDE_DECK D= CSP$REPOSITION_FIELD
INCLUDE_DECK D= CSP$RESIZE_FIELD
INCLUDE_DECK D= CSP$SEND_LINE_INITIALIZATION
INCLUDE_DECK D= CSP$SEND_SCREEN_INITIALIZATION
INCLUDE_DECK D= CSP$SET_MENU
INCLUDE_DECK D= CSP$SET_MENU_STRINGS
INCLUDE_DECK D= CSP$SET_STANDARD_MENU
INCLUDE_DECK D= CSP$SET_WORKSPACE_CURSOR
INCLUDE_DECK D= CSP$SHIFT_FIELDS
INCLUDE_DECK D= CSP$SHIFT_LINES
INCLUDE_DECK D= CSP$TOGGLE_LABEL
INCLUDE_DECK D= CSP$UNMARK_MENU_ITEM
INCLUDE_DECK D= CSP$UPDATE_DEVICE
INCLUDE_DECK D= CST$APPLICATION_NAME
INCLUDE_DECK D= CST$AREA_CHANGES
INCLUDE_DECK D= CST$ATTRIBUTE
INCLUDE_DECK D= CST$ATTRIBUTE_LIMITS
INCLUDE_DECK D= CST$ATTRIBUTE_SET
INCLUDE_DECK D= CST$AUDIBLE_ACKNOWLEDGEMENT
INCLUDE_DECK D= CST$BOUNDARY_ATTRIBUTES
INCLUDE_DECK D= CST$BOUNDARY_PROCESSING
INCLUDE_DECK D= CST$CAPABILITY_LEVEL
INCLUDE_DECK D= CST$CHARACTER_POSITION
INCLUDE_DECK D= CST$CLIPPING
INCLUDE_DECK D= CST$COLOR_INDEX
INCLUDE_DECK D= CST$COLOR_SET
INCLUDE_DECK D= CST$COLOR_SUPPORT
INCLUDE_DECK D= CST$CONTROL
INCLUDE_DECK D= CST$DATA_STRING
INCLUDE_DECK D= CST$DATA_STRING_LENGTH
INCLUDE_DECK D= CST$DEVICE_ATTRIBUTE
INCLUDE_DECK D= CST$DEVICE_ATTRIBUTES
INCLUDE_DECK D= CST$DEVICE_ATTRIBUTE_KEYS
INCLUDE_DECK D= CST$DIRECTION_INDEX
INCLUDE_DECK D= CST$EVENT_IDENTIFIER
INCLUDE_DECK D= CST$EVENT_NAME_IDENTIFIER
INCLUDE_DECK D= CST$EVENT_TYPE
INCLUDE_DECK D= CST$FIELD_ATTRIBUTE
INCLUDE_DECK D= CST$FIELD_ATTRIBUTES
INCLUDE_DECK D= CST$FIELD_ATTRIBUTE_KEYS
INCLUDE_DECK D= CST$FIELD_EVENT_TYPE
INCLUDE_DECK D= CST$FIELD_EVENT_TYPES
INCLUDE_DECK D= CST$FIELD_JUSTIFICATION
INCLUDE_DECK D= CST$FIELD_NUMBER
INCLUDE_DECK D= CST$FIXED_TABS
INCLUDE_DECK D= CST$FIXED_TAB_POSITIONS
INCLUDE_DECK D= CST$GRAPHIC_IDENTIFIER
INCLUDE_DECK D= CST$HEIGHT
INCLUDE_DECK D= CST$INPUT_TIMEOUT
INCLUDE_DECK D= CST$INTERACTION_STYLE
INCLUDE_DECK D= CST$INTERSECTION_TYPE
INCLUDE_DECK D= CST$INTERSECTION_TYPES
INCLUDE_DECK D= CST$LINES_USED
INCLUDE_DECK D= CST$LINE_NUMBER
INCLUDE_DECK D= CST$LINE_WIDTH
INCLUDE_DECK D= CST$LOCATE_ACCURACY
INCLUDE_DECK D= CST$LOCATE_MARKING
INCLUDE_DECK D= CST$LOCATE_RESOLUTION
INCLUDE_DECK D= CST$LOCATE_X_ACCURACY
INCLUDE_DECK D= CST$LOCATE_Y_ACCURACY
INCLUDE_DECK D= CST$LOGICAL_HIGHLIGHTING
INCLUDE_DECK D= CST$LOGICAL_HIGHLIGHTING_STYLE
INCLUDE_DECK D= CST$MARKING_TYPE
INCLUDE_DECK D= CST$MENU_ITEM_STRING
INCLUDE_DECK D= CST$MENU_STRINGS
INCLUDE_DECK D= CST$MODEL_NAME
INCLUDE_DECK D= CST$MOUSE_EVENT
INCLUDE_DECK D= CST$NAME
INCLUDE_DECK D= CST$PAGE_ATTRIBUTE
INCLUDE_DECK D= CST$PAGE_ATTRIBUTES
INCLUDE_DECK D= CST$PAGE_ATTRIBUTE_KEYS
INCLUDE_DECK D= CST$PAGE_EVENT_STYLE
INCLUDE_DECK D= CST$PAGE_EVENT_TYPE
INCLUDE_DECK D= CST$PAGE_EVENT_TYPES
INCLUDE_DECK D= CST$PHYSICAL_HIGHLIGHTING
INCLUDE_DECK D= CST$PHYSICAL_HIGHLIGHTING_SET
INCLUDE_DECK D= CST$PHYSICAL_HIGHLIGHTING_STYLE
INCLUDE_DECK D= CST$PHYS_HIGHLIGHTING_STYLE
INCLUDE_DECK D= CST$PICKLOCATE_ACCURACY
INCLUDE_DECK D= CST$PICKLOCATE_X_POSITION
INCLUDE_DECK D= CST$PICKLOCATE_Y_POSITION
INCLUDE_DECK D= CST$PICK_ACCURACY
INCLUDE_DECK D= CST$PICK_CHARACTER_ACCURACY
INCLUDE_DECK D= CST$PICK_LINE_ACCURACY
INCLUDE_DECK D= CST$PICK_MARKING
INCLUDE_DECK D= CST$PICK_RESOLUTION
INCLUDE_DECK D= CST$SCREEN_DIMENSION
INCLUDE_DECK D= CST$SCREEN_DIMENSIONS
INCLUDE_DECK D= CST$SHIFT_FIELD_OFFSET
INCLUDE_DECK D= CST$SHIFT_LINE_OFFSET
INCLUDE_DECK D= CST$STRING
INCLUDE_DECK D= CST$TAB_POSITION
INCLUDE_DECK D= CST$TAB_POSITIONS
INCLUDE_DECK D= CST$TAB_STOPS
INCLUDE_DECK D= CST$TERMINAL_CHARACTERISTICS
INCLUDE_DECK D= CST$TEXT_CHANGE_DESCRIPTION
INCLUDE_DECK D= CST$VECTOR
INCLUDE_DECK D= CST$VISIBLE_CHARACTER_POSITION
INCLUDE_DECK D= CST$WIDTH
INCLUDE_DECK D= CST$WORKSPACE_TYPES
INCLUDE_DECK D= CST$XY_COORDINATE
INCLUDE_DECK D= CST$XY_COORDINATES
INCLUDE_DECK D= CST$X_POSITION
INCLUDE_DECK D= CST$Y_POSITION
INCLUDE_DECK D=CSV$VECTOR
INCLUDE_DECK D=DBH$BEGIN_DEBUG
INCLUDE_DECK D=DBH$DEBUG
INCLUDE_DECK D=DBH$END_DEBUG
INCLUDE_DECK D=DBH$ENTRY_POINT_TABLE_ADDRESS
INCLUDE_DECK D=DBH$MODULE_TABLE_ADDRESS
INCLUDE_DECK D=DBP$ENTRY_POINT_TABLE_ADDRESS
INCLUDE_DECK D=DBP$MODULE_TABLE_ADDRESS
INCLUDE_DECK D=DBT$BEGIN_DEBUG
INCLUDE_DECK D=DBT$DEBUG
INCLUDE_DECK D=DBT$END_DEBUG
INCLUDE_DECK D=DFC$CLIENT_PAUSE_BREAK
INCLUDE_DECK D=DFC$CLIENT_TERMINATE_BREAK
INCLUDE_DECK D=DFC$LOOPBACK_SERVER_MAINFRAME
INCLUDE_DECK D=DFE$CDCNET_ERRORS
INCLUDE_DECK D=DFE$DRIVER_TEST_ERRORS
INCLUDE_DECK D=DFE$ERROR_CONDITION_CODES
INCLUDE_DECK D=DFE$MM_RECOVERY_ERRORS
INCLUDE_DECK D=DFH$BEGIN_CH_REMOTE_PROC_CALL
INCLUDE_DECK D=DFH$BEGIN_REMOTE_PROCEDURE_CALL
INCLUDE_DECK D=DFH$CALL_REMOTE_PROCEDURE
INCLUDE_DECK D=DFH$END_CH_REMOTE_PROC_CALL
INCLUDE_DECK D=DFH$END_REMOTE_PROCEDURE_CALL
INCLUDE_DECK D=DFH$GET_APPLICATION_INFO
INCLUDE_DECK D=DFH$GET_FAMILY_LIST
INCLUDE_DECK D=DFH$GET_FAMILY_STATUS
INCLUDE_DECK D=DFH$GET_MAINFRAME_LIST
INCLUDE_DECK D=DFH$GET_MAINFRAME_STATUS
INCLUDE_DECK D=DFH$SEND_APPLICATION_RPC
INCLUDE_DECK D=DFP$BEGIN_CH_REMOTE_PROC_CALL
INCLUDE_DECK D=DFP$BEGIN_REMOTE_PROCEDURE_CALL
INCLUDE_DECK D=DFP$CALL_REMOTE_PROCEDURE
INCLUDE_DECK D=DFP$END_CH_REMOTE_PROC_CALL
INCLUDE_DECK D=DFP$END_REMOTE_PROCEDURE_CALL
INCLUDE_DECK D=DFP$GET_APPLICATION_INFO
INCLUDE_DECK D=DFP$GET_FAMILY_LIST
INCLUDE_DECK D=DFP$GET_FAMILY_STATUS
INCLUDE_DECK D=DFP$GET_MAINFRAME_LIST
INCLUDE_DECK D=DFP$GET_MAINFRAME_STATUS
INCLUDE_DECK D=DFP$SEND_APPLICATION_RPC
INCLUDE_DECK D=DFT$APPLICATION_SUPPORT_LIMITS
INCLUDE_DECK D=DFT$FAMILY_ACCESS
INCLUDE_DECK D=DFT$FAMILY_ACCESS_TYPE
INCLUDE_DECK D=DFT$FAMILY_INFO_LIST
INCLUDE_DECK D=DFT$FAMILY_INFO_RECORD
INCLUDE_DECK D=DFT$PARTNER_MAINFRAME_LIST
INCLUDE_DECK D=DFT$P_STATE_CHANGE_PROCEDURE
INCLUDE_DECK D=DFT$RPC_PARAMETERS
INCLUDE_DECK D=DFT$RPC_QUEUE_ENTRY_LOCATION
INCLUDE_DECK D=DFT$SERVED_FAMILY_TABLE_INDEX
INCLUDE_DECK D=DFT$SERVER_LOCATION
INCLUDE_DECK D=DFT$SERVER_LOCATION_SELECTOR
INCLUDE_DECK D=DFT$SERVER_STATE
INCLUDE_DECK D=DFV$CH_QUEUE_ENTRY_LOCATION
INCLUDE_DECK D=DSC$MAX_NUMBER_OF_IOUS
INCLUDE_DECK D=DST$CHANNEL_PROTOCOL_TYPE
INCLUDE_DECK D=DST$DFT_PP_REGISTERS
INCLUDE_DECK D=DST$IOU_MODEL_TYPES
INCLUDE_DECK D=DST$IOU_NUMBER
INCLUDE_DECK D=DST$IOU_RESOURCE
INCLUDE_DECK D=DST$PHYSICAL_RESOURCE_NUMBER
INCLUDE_DECK D=ESC$STATUS_CONDITION
INCLUDE_DECK D=ESC$STATUS_ID
INCLUDE_DECK D=ESE$ALLOCATION_FAILED
INCLUDE_DECK D=ESE$ALL_CHANGES_UNDONE
INCLUDE_DECK D=ESE$ALL_NOT_ALLOWED
INCLUDE_DECK D=ESE$ASCII_TO_BLANKS
INCLUDE_DECK D=ESE$BOX_NOT_IMPLEMENTED
INCLUDE_DECK D=ESE$CONDITION_CODES
INCLUDE_DECK D=ESE$COUNT_OF_LINES
INCLUDE_DECK D=ESE$CURRENT_OBJECT_NOT_A_DECK
INCLUDE_DECK D=ESE$DECK_CREATED_IMPLICITLY
INCLUDE_DECK D=ESE$DECK_CONTAINS_CONTROLS
INCLUDE_DECK D=ESE$DECK_INTERLOCKED
INCLUDE_DECK D=ESE$DECK_MOD_LIMIT_EXCEEDED
INCLUDE_DECK D=ESE$EDID_NOT_ALLOWED
INCLUDE_DECK D=ESE$EDITOR_ACTIVE_IN_TASK
INCLUDE_DECK D=ESE$EITHER_TEXT_OR_RS
INCLUDE_DECK D=ESE$ERRORS_PROCESSING_DECK
INCLUDE_DECK D=ESE$FILE_HAS_WRONG_ATTRIBUTE
INCLUDE_DECK D=ESE$FILE_TRUNCATED
INCLUDE_DECK D=ESE$FILE_WRITTEN_TO_UNIQUE
INCLUDE_DECK D=ESE$HISTORY_LIMIT_EXCEEDED
INCLUDE_DECK D=ESE$INTERNAL_ERROR
INCLUDE_DECK D=ESE$INVALID_RANGE_OF_COLUMNS
INCLUDE_DECK D=ESE$INVALID_SEQUENCE_NUMBER
INCLUDE_DECK D=ESE$L2_NOT_AFTER_L1
INCLUDE_DECK D=ESE$L2_NOT_FOUND_IN_SEARCH_BACK
INCLUDE_DECK D=ESE$LAST_DECK_ON_LIBRARY
INCLUDE_DECK D=ESE$LINES_FOUND
INCLUDE_DECK D=ESE$LINE_CONTAINS_CONTROLS
INCLUDE_DECK D=ESE$LINE_ID_MISSING_MOD_NAME
INCLUDE_DECK D=ESE$LINE_LENGTH_EXCEEDED
INCLUDE_DECK D=ESE$LINE_LIMIT_EXCEEDED
INCLUDE_DECK D=ESE$LINE_LONGER_WIDTH
INCLUDE_DECK D=ESE$LINE_NOT_ACTIVE
INCLUDE_DECK D=ESE$LINE_NOT_FOUND
INCLUDE_DECK D=ESE$LINE_NUMBER_OUT_OF_RANGE
INCLUDE_DECK D=ESE$LINE_TRUNCATED_MAPPING
INCLUDE_DECK D=ESE$MOD_NOT_STATE_ZERO
INCLUDE_DECK D=ESE$NEW_MODIFICATION_WARNING
INCLUDE_DECK D=ESE$NONE_NOT_ALLOWED
INCLUDE_DECK D=ESE$NO_ACTIVE_LINES
INCLUDE_DECK D=ESE$NO_DECKS_ON_LIBRARY
INCLUDE_DECK D=ESE$NO_DECK_ACTIVE
INCLUDE_DECK D=ESE$OBJECT_STACK_FULL
INCLUDE_DECK D=ESE$OCCURRENCES_FOUND
INCLUDE_DECK D=ESE$ONLY_ONE_OF
INCLUDE_DECK D=ESE$OPEN_OBJECT_LIMIT_EXCEEDED
INCLUDE_DECK D=ESE$SEQ_NUMBER_TOO_LARGE
INCLUDE_DECK D=ESE$SPACE_INVALID_IN_WORD
INCLUDE_DECK D=ESE$STRING_LONGER_WINDOW
INCLUDE_DECK D=ESE$TERMINAL_NOT_IDENTIFIED
INCLUDE_DECK D=ESE$TEXT_NOT_FOUND
INCLUDE_DECK D=ESE$TRANSACTION_LIMIT_EXCEEDED
INCLUDE_DECK D=ESE$UNEXPECTED_DATA_IN_LINE_ID
INCLUDE_DECK D=ESE$UNKNOWN_MOD_NAME
INCLUDE_DECK D=ESE$UNWRITABLE_OBJECT
INCLUDE_DECK D=ESE$WARNINGS_DURING_COMMAND
INCLUDE_DECK D=ESE$WARNINGS_DURING_DECK
INCLUDE_DECK D=ESE$WITH_FILE_UNTIL
INCLUDE_DECK D=ESE$WRITE_NOT_PERMITTED
INCLUDE_DECK D=FDC$COBOL_DIGITS_MAXIMUM
INCLUDE_DECK D=FDC$COBOL_ITEM_SIZE_MAXIMUM
INCLUDE_DECK D=FDC$COBOL_OPERATIONS_MAX
INCLUDE_DECK D=FDH$COMBINE_FORM_EVENTS
INCLUDE_DECK D=FDH$CONVERT_TO_PROGRAM_VALUE
INCLUDE_DECK D=FDH$CONVERT_TO_SCREEN_VALUE
INCLUDE_DECK D=FDH$CREATE_COBOL_DESCRIPTION
INCLUDE_DECK D=FDH$MOVE_COBOL_DATA
INCLUDE_DECK D=FDH$GET_SCREEN_VARIABLE
INCLUDE_DECK D=FDH$VALIDATE_VARIABLE
INCLUDE_DECK D=FDP$COMBINE_FORM_EVENTS
INCLUDE_DECK D=FDP$CONVERT_TO_PROGRAM_VALUE
INCLUDE_DECK D=FDP$CONVERT_TO_SCREEN_VALUE
INCLUDE_DECK D=FDP$CREATE_COBOL_DESCRIPTION
INCLUDE_DECK D=FDP$GET_SCREEN_VARIABLE
INCLUDE_DECK D=FDP$MOVE_COBOL_DATA
INCLUDE_DECK D=FDP$VALIDATE_VARIABLE
INCLUDE_DECK D=FDT$COBOL_CATEGORY
INCLUDE_DECK D=FDT$COBOL_CR_DB_MEANS
INCLUDE_DECK D=FDT$COBOL_DESCRIPTION
INCLUDE_DECK D=FDT$COBOL_PICTURE_SYMBOLS
INCLUDE_DECK D=FDT$COBOL_OPERATION
INCLUDE_DECK D=FDT$COBOL_USAGE
INCLUDE_DECK D=FMT$PATH_HANDLE_OFFSET_NIBBLES
INCLUDE_DECK D=FMT$PDE_ASSIGNMENT_COUNTER
INCLUDE_DECK D=FSC$MAX_USER_ATTRIB_SEQUENCE
INCLUDE_DECK D=FSC$MAX_TEMP_FILE_PATH_SIZE
INCLUDE_DECK D=FSE$VXVE_EXCEPTION_CONDITIONS
INCLUDE_DECK D=FSH$CHANGE_CYCLE_DAMAGE
INCLUDE_DECK D=FSH$CHANGE_CYCLE_DATE_TIME
INCLUDE_DECK D=FSH$CHANGE_SEGMENT_NUMBER
INCLUDE_DECK D=FSH$GET_OPEN_INFORMATION
INCLUDE_DECK D=FSH$VALIDATE_FILE_IDENTIFIER
INCLUDE_DECK D=FSP$CHANGE_CYCLE_DAMAGE
INCLUDE_DECK D=FSP$CHANGE_CYCLE_DATE_TIME
INCLUDE_DECK D=FSP$CHANGE_SEGMENT_NUMBER
INCLUDE_DECK D=FSP$GET_OPEN_INFORMATION
INCLUDE_DECK D=FSP$VALIDATE_FILE_IDENTIFIER
INCLUDE_DECK D=FST$APPLICATION_INFORMATION
INCLUDE_DECK D=FST$ATTACHMENT_ADMINISTRATION
INCLUDE_DECK D=FST$ATTACHMENT_COUNT
INCLUDE_DECK D=FST$ATTACHMENT_INFORMATION
INCLUDE_DECK D=FST$ATTACHMENT_USAGE
INCLUDE_DECK D=FST$ATTRIBUTE_OVERRIDE_INFO
INCLUDE_DECK D=FST$BACKUP_INFORMATION
INCLUDE_DECK D=FST$CATALOG_INFORMATION
INCLUDE_DECK D=FST$CONTROL_MODE
INCLUDE_DECK D=FST$CONTROL_MODES
INCLUDE_DECK D=FST$CYCLE_ATTRIBUTE_SOURCES
INCLUDE_DECK D=FST$CYCLE_ATTRIBUTE_VALUES
INCLUDE_DECK D=FST$CYCLE_LIMIT_ENFORCEMENT
INCLUDE_DECK D=FST$CYCLE_REGISTRATION_INFO
INCLUDE_DECK D=FST$CYCLE_RESIDENCE_INFORMATION
INCLUDE_DECK D=FST$DATE_TIME
INCLUDE_DECK D=FST$FILE_REGISTRATION_INFO
INCLUDE_DECK D=FST$MAGNETIC_TAPE_INFORMATION
INCLUDE_DECK D=FST$MASS_STORAGE_INFORMATION
INCLUDE_DECK D=FST$OPEN_ATTACHMENT_INFORMATION
INCLUDE_DECK D=FST$OPEN_COUNT
INCLUDE_DECK D=FST$OPEN_INSTANCE_INFORMATION
INCLUDE_DECK D=FST$PATH_HANDLE_NAME
INCLUDE_DECK D=FST$TAPE_SECURITY_CALL_BLOCK
INCLUDE_DECK D=FST$TAPE_SECURITY_OPERATION
INCLUDE_DECK D=FST$TEMPORARY_FILE_PATH
INCLUDE_DECK D=FST$TS_AUTHORIZE_ACCESS_METHOD
INCLUDE_DECK D=FST$TS_AUTHORIZE_FILE_ACCESS
INCLUDE_DECK D=FST$TS_AUTHORIZE_FILE_REUSE
INCLUDE_DECK D=FST$TS_AUTHORIZE_FILE_SET_MOUNT
INCLUDE_DECK D=FST$TS_AUTHORIZE_FILE_SET_REUSE
INCLUDE_DECK D=FST$TS_AUTHORIZE_SECTION_READ
INCLUDE_DECK D=FST$TS_AUTHORIZE_SECTION_WRITE
INCLUDE_DECK D=FST$TS_AUTHORIZE_VOLUME_REUSE
INCLUDE_DECK D=FST$TS_SECURE_HEADER_LABELS
INCLUDE_DECK D=FST$TS_SECURE_TRAILER_LABELS
INCLUDE_DECK D=FST$TS_VALIDATE_HEADER_LABELS
INCLUDE_DECK D=FST$TS_VALIDATE_TRAILER_LABELS
INCLUDE_DECK D=FST$USER_ATTRIBUTE_DESCRIPTOR
INCLUDE_DECK D=FST$USER_DEFINED_ATTRIBUTE_SIZE
INCLUDE_DECK D=I#BUILD_ADAPTABLE_SEQ_POINTER
INCLUDE_DECK D=I#COMPARE_COLLATED
INCLUDE_DECK D=I$REAL_MEMORY_ADDRESS
INCLUDE_DECK D=IFH$GET_NETWORK_IDENTIFIER
INCLUDE_DECK D=IFH$IMMEDIATE_ATTRIBUTE_FLUSH
INCLUDE_DECK D=IFH$SEND_INTERRUPT_CONDITION
INCLUDE_DECK D=IFH$VTP_CREATE_CDCNET_CONNECT
INCLUDE_DECK D=IFP$DISCARD_SUSPENDED_OUTPUT
INCLUDE_DECK D=IFP$FETCH_CONTEXT
INCLUDE_DECK D=IFP$GET_NETWORK_IDENTIFIER
INCLUDE_DECK D=IFP$IMMEDIATE_ATTRIBUTE_FLUSH
INCLUDE_DECK D=IFP$SEND_ATTRIBUTE_KLUDGE
INCLUDE_DECK D=IFP$SEND_INTERRUPT_CONDITION
INCLUDE_DECK D=IFP$START_PAUSE_UTILITY
INCLUDE_DECK D=IFP$STORE_CONTEXT
INCLUDE_DECK D=IFP$VTP_CREATE_CDCNET_CONNECT
INCLUDE_DECK D=IFT$FETCH_CONTEXT_ATTRIBUTE
INCLUDE_DECK D=IFT$FETCH_CONTEXT_ATTRIBUTES
INCLUDE_DECK D=IFT$FETCH_CONTEXT_KEYS
INCLUDE_DECK D=IFT$NETWORK_IDENTIFIER
INCLUDE_DECK D=IFT$STORE_CONTEXT_ATTRIBUTE
INCLUDE_DECK D=IFT$STORE_CONTEXT_ATTRIBUTES
INCLUDE_DECK D=IFT$STORE_CONTEXT_KEYS
INCLUDE_DECK D=IFT$TERMINAL_MODE
INCLUDE_DECK D=IPC$NETWORK_DATA_BASE_CONST
INCLUDE_DECK D=IPE$GENERAL_MESSAGES
INCLUDE_DECK D=IPE$IPAM_ADDRESSING_MESSAGES
INCLUDE_DECK D=IPE$IPAM_SOCKET_MESSAGES
INCLUDE_DECK D=IPP$ABORT_SOCKET
INCLUDE_DECK D=IPP$ACCEPT_SOCKET
INCLUDE_DECK D=IPP$ACCEPT_SOCKET_OFFER
INCLUDE_DECK D=IPP$BIND_SOCKET
INCLUDE_DECK D=IPP$CLOSE_SOCKET
INCLUDE_DECK D=IPP$CONNECT_SOCKET
INCLUDE_DECK D=IPP$FLUSH_SOCKET
INCLUDE_DECK D=IPP$GET_HOST_BY_ADDRESS
INCLUDE_DECK D=IPP$GET_HOST_BY_NAME
INCLUDE_DECK D=IPP$GET_HOST_NAME
INCLUDE_DECK D=IPP$GET_SERVICE_BY_NAME
INCLUDE_DECK D=IPP$GET_SOCKET
INCLUDE_DECK D=IPP$GET_SOCKET_DATA
INCLUDE_DECK D=IPP$GET_SOCKET_INFO
INCLUDE_DECK D=IPP$LISTEN_SOCKET
INCLUDE_DECK D=IPP$OFFER_SOCKET
INCLUDE_DECK D=IPP$READ_SOCKET
INCLUDE_DECK D=IPP$RECEIVE_FROM_SOCKET
INCLUDE_DECK D=IPP$SEND_TO_SOCKET
INCLUDE_DECK D=IPP$SET_SOCKET_OPTION
INCLUDE_DECK D=IPP$STATUS_SOCKET
INCLUDE_DECK D=IPP$WRITE_SOCKET
INCLUDE_DECK D=IPT$ALIAS_RECORD
INCLUDE_DECK D=IPT$CIRCUIT_TYPE
INCLUDE_DECK D=IPT$DATA_FRAGMENT
INCLUDE_DECK D=IPT$FOREIGN_SOCKET
INCLUDE_DECK D=IPT$HOST_ENTRY
INCLUDE_DECK D=IPT$IP_ADDRESS
INCLUDE_DECK D=IPT$LOCAL_SOCKET
INCLUDE_DECK D=IPT$NAME_RECORD
INCLUDE_DECK D=IPT$PORT_NUMBER
INCLUDE_DECK D=IPT$QUEUE_LIMIT
INCLUDE_DECK D=IPT$SERVICE_ENTRY
INCLUDE_DECK D=IPT$SOCKET_DATA
INCLUDE_DECK D=IPT$SOCKET_ID
INCLUDE_DECK D=IPT$SOCKET_INFORMATION
INCLUDE_DECK D=IPT$SOCKET_OPTION
INCLUDE_DECK D=IPT$SOCKET_OPTIONS
INCLUDE_DECK D=IPT$SOCKET_STATUS
INCLUDE_DECK D=IPT$TARGET_TYPE
INCLUDE_DECK D=JMC$KJL_MAXIMUM_ENTRIES
INCLUDE_DECK D=JMC$KOL_MAXIMUM_ENTRIES
INCLUDE_DECK D=JMC$MAXIMUM_CONSTANTS
INCLUDE_DECK D=JMC$MAXIMUM_JOB_COUNT
INCLUDE_DECK D=JMC$MAXIMUM_OUTPUT_COUNT
INCLUDE_DECK D=JMC$MAXIMUM_QFILE_COUNT
INCLUDE_DECK D=JMC$MAXIMUM_MAINFRAMES
INCLUDE_DECK D=JME$JOB_SCHEDULER_CONDITIONS
INCLUDE_DECK D=JME$ACCESS_ID_MISMATCH
INCLUDE_DECK D=JME$ANOTHER_UTILITY_IS_ACTIVE
INCLUDE_DECK D=JME$APPLICATION_NAME_IN_USE
INCLUDE_DECK D=JME$APPLICATION_NAME_INCORRECT
INCLUDE_DECK D=JME$APPLICATIONS_NOT_SORTED
INCLUDE_DECK D=JME$BAD_SWAP_FILE_DESCRIPTOR
INCLUDE_DECK D=JME$CANT_IDLE_JOB_TASKS
INCLUDE_DECK D=JME$CLASS_ABBREV_NOT_UNIQUE
INCLUDE_DECK D=JME$CLASS_INDEX_ALREADY_IN_USE
INCLUDE_DECK D=JME$CLASS_INDEX_CONFLICT
INCLUDE_DECK D=JME$CLASS_INDEX_NOT_DEFINED
INCLUDE_DECK D=JME$CLASS_OR_APPL_NOT_DEFINED
INCLUDE_DECK D=JME$CLASS_OR_APPL_NOT_UNIQUE
INCLUDE_DECK D=JME$CONDITION_ENCOUNTERED
INCLUDE_DECK D=JME$DELETE_CLASS_STILL_ACTIVE
INCLUDE_DECK D=JME$ERROR_IN_JOB_CLASS_RANKING
INCLUDE_DECK D=JME$EXCESS_CLASS_IN_SCHED_TABLE
INCLUDE_DECK D=JME$GENERIC_QUEUE_IS_EMPTY
INCLUDE_DECK D=JME$INVALID_DESTINATION
INCLUDE_DECK D=JME$INVALID_DISPATCH_PRIORITY
INCLUDE_DECK D=JME$INVALID_RHD
INCLUDE_DECK D=JME$INVALID_SCHEDULER_REQUEST
INCLUDE_DECK D=JME$JOB_CANT_BE_SWAPPED
INCLUDE_DECK D=JME$JOB_CLASS_NOT_DEFINED
INCLUDE_DECK D=JME$JOB_DEAD_CANNOT_SWAP
INCLUDE_DECK D=JME$JOB_HAS_NO_READY_TASKS
INCLUDE_DECK D=JME$JOB_IN_MEMORY_OR_SWAPIN
INCLUDE_DECK D=JME$JOB_IN_READY_TASK_STATE
INCLUDE_DECK D=JME$JOB_NOT_IN_SWAP_LIST
INCLUDE_DECK D=JME$JOB_STATUS_NON_SWAPPABLE
INCLUDE_DECK D=JME$LATEST_RUN_TIME_EXPIRED
INCLUDE_DECK D=JME$MAXIMUM_GENERIC_QFILES
INCLUDE_DECK D=JME$MUST_BE_SCHEDULING_ADMIN
INCLUDE_DECK D=JME$NO_DELETE_OF_DEFAULT_CLASS
INCLUDE_DECK D=JME$NO_ELEMENT_IN_SEQUENCE
INCLUDE_DECK D=JME$NO_FREE_AJL_ORDINALS
INCLUDE_DECK D=JME$NO_QFILES_WERE_FOUND
INCLUDE_DECK D=JME$NO_RANKING_OF_DEFAULT_CLASS
INCLUDE_DECK D=JME$NO_SPACE_IN_RUNTIME_STACK
INCLUDE_DECK D=JME$NO_SWAPPED_JOBS
INCLUDE_DECK D=JME$NO_UTILITY_IS_ACTIVE
INCLUDE_DECK D=JME$NON_EXISTENT_JOB
INCLUDE_DECK D=JME$PROFILE_CANNOT_BE_READ
INCLUDE_DECK D=JME$PROFILE_CYCLE2_LOST
INCLUDE_DECK D=JME$PROFILE_ID_MISMATCH
INCLUDE_DECK D=JME$PROFILE_NOT_INSTALLED
INCLUDE_DECK D=JME$PROFILE_TOO_LARGE
INCLUDE_DECK D=JME$QFILE_ALREADY_TERMINATED
INCLUDE_DECK D=JME$QFILE_APPL_NOT_PERMITTED
INCLUDE_DECK D=JME$QFILE_CANNOT_INITIATE
INCLUDE_DECK D=JME$QFILE_IS_INITIATED
INCLUDE_DECK D=JME$QFILE_IS_TERMINATED
INCLUDE_DECK D=JME$QFILE_STATE_IS_NULL
INCLUDE_DECK D=JME$QFILE_WAS_NOT_RECOVERED
INCLUDE_DECK D=JME$QFILE_WAS_RECOVERED
INCLUDE_DECK D=JME$READ_QFILE_SYSTEM_LABEL
INCLUDE_DECK D=JME$SERVICE_CLASS_NOT_DEFINED
INCLUDE_DECK D=JME$SWAP_BUFFER_FULL
INCLUDE_DECK D=JME$SWAPIN_WITH_MAXAJ_ZERO
INCLUDE_DECK D=JME$SWAPPING_NOT_ALLOWED
INCLUDE_DECK D=JME$SYSTEM_LABEL_INTERNAL_ERROR
INCLUDE_DECK D=JME$SYSTEM_NOT_IDLE
INCLUDE_DECK D=JME$TABLE_LENGTHS_FROM_PROFILE
INCLUDE_DECK D=JME$UNKNOWN_CLASS
INCLUDE_DECK D=JME$UNKNOWN_CLASS_KIND
INCLUDE_DECK D=JME$USE_ADMS_OR_MANAS_UTILITY
INCLUDE_DECK D=JME$USE_ADMS_UTILITY
INCLUDE_DECK D=JME$WORK_AREA_TOO_SMALL
INCLUDE_DECK D=JME$WRITE_QFILE_SYSTEM_LABEL
INCLUDE_DECK D=JME$WRONG_DISPLAY
INCLUDE_DECK D=JMH$ACQUIRE_CONNECTION
INCLUDE_DECK D=JMH$ACQUIRE_MODIFIED_INPUT
INCLUDE_DECK D=JMH$ACQUIRE_MODIFIED_OUTPUT
INCLUDE_DECK D=JMH$ACQUIRE_MODIFIED_QFILE
INCLUDE_DECK D=JMH$ACQUIRE_NEW_INPUT
INCLUDE_DECK D=JMH$ACQUIRE_NEW_OUTPUT
INCLUDE_DECK D=JMH$ACQUIRE_NEW_QFILE
INCLUDE_DECK D=JMH$CHANGE_JOB_ATTRIBUTES
INCLUDE_DECK D=JMH$CHANGE_OUTPUT_ATTRIBUTES
INCLUDE_DECK D=JMH$CHANGE_QFILE_ATTRIBUTES
INCLUDE_DECK D=JMH$CLOSE_INPUT_FILE
INCLUDE_DECK D=JMH$CLOSE_OUTPUT_FILE
INCLUDE_DECK D=JMH$CLOSE_QFILE
INCLUDE_DECK D=JMH$CLUSTER_GET_LEVELING_DATA
INCLUDE_DECK D=JMH$COPY_QFILE
INCLUDE_DECK D=JMH$DETERMINE_NAME_KIND
INCLUDE_DECK D=JMH$EMIT_COMMUNICATION_STAT
INCLUDE_DECK D=JMH$GET_ACTIVE_SCHEDULING_ATTR
INCLUDE_DECK D=JMH$GET_ATTRIBUTE_DEFAULTS
INCLUDE_DECK D=JMH$GET_JOB_ATTRIBUTES
INCLUDE_DECK D=JMH$GET_JOB_STATUS
INCLUDE_DECK D=JMH$GET_OUTPUT_COUNTS
INCLUDE_DECK D=JMH$GET_QFILE_ATTRIBUTES
INCLUDE_DECK D=JMH$GET_QFILE_STATUS
INCLUDE_DECK D=JMH$GET_RESULT_SIZE
INCLUDE_DECK D=JMH$JOB_EXISTS
INCLUDE_DECK D=JMH$MODIFIED_INPUT_EXISTS
INCLUDE_DECK D=JMH$MODIFIED_OUTPUT_EXISTS
INCLUDE_DECK D=JMH$MODIFIED_QFILE_EXISTS
INCLUDE_DECK D=JMH$NEW_INPUT_EXISTS
INCLUDE_DECK D=JMH$NEW_OUTPUT_EXISTS
INCLUDE_DECK D=JMH$NEW_QFILE_EXISTS
INCLUDE_DECK D=JMH$OPEN_INPUT_FILE
INCLUDE_DECK D=JMH$OPEN_OUTPUT_FILE
INCLUDE_DECK D=JMH$OPEN_QFILE
INCLUDE_DECK D=JMH$PRINT_FILE
INCLUDE_DECK D=JMH$REGISTER_INPUT_APPLICATION
INCLUDE_DECK D=JMH$REGISTER_OUTPUT_APPLICATION
INCLUDE_DECK D=JMH$REGISTER_QFILE_APPLICATION
INCLUDE_DECK D=JMH$RETURN_CONNECTION
INCLUDE_DECK D=JMH$SET_INPUT_COMPLETED
INCLUDE_DECK D=JMH$SET_INPUT_INITIATED
INCLUDE_DECK D=JMH$SET_INTERACTIVE_COND_STATE
INCLUDE_DECK D=JMH$SET_OUTPUT_COMPLETED
INCLUDE_DECK D=JMH$SET_OUTPUT_INITIATED
INCLUDE_DECK D=JMH$SET_QFILE_COMPLETED
INCLUDE_DECK D=JMH$SET_QFILE_INITIATED
INCLUDE_DECK D=JMH$SUBMIT_DETACHED_JOB
INCLUDE_DECK D=JMH$SUBMIT_QFILE
INCLUDE_DECK D=JMH$TERMINATED_INPUT_EXISTS
INCLUDE_DECK D=JMH$TERMINATED_OUTPUT_EXISTS
INCLUDE_DECK D=JMH$TERMINATED_QFILE_EXISTS
INCLUDE_DECK D=JMH$TERMINATE_ACQUIRED_INPUT
INCLUDE_DECK D=JMH$TERMINATE_ACQUIRED_OUTPUT
INCLUDE_DECK D=JMH$TERMINATE_ACQUIRED_QFILE
INCLUDE_DECK D=JMH$TERMINATE_OUTPUT
INCLUDE_DECK D=JMH$TERMINATE_QFILE
INCLUDE_DECK D=JMH$UPDATE_OUTPUT_STATUS
INCLUDE_DECK D=JMH$UPDATE_QFILE_STATUS
INCLUDE_DECK D=JMP$ACQUIRE_CONNECTION
INCLUDE_DECK D=JMP$ACQUIRE_MODIFIED_INPUT
INCLUDE_DECK D=JMP$ACQUIRE_MODIFIED_OUTPUT
INCLUDE_DECK D=JMP$ACQUIRE_MODIFIED_QFILE
INCLUDE_DECK D=JMP$ACQUIRE_NEW_INPUT
INCLUDE_DECK D=JMP$ACQUIRE_NEW_OUTPUT
INCLUDE_DECK D=JMP$ACQUIRE_NEW_QFILE
INCLUDE_DECK D=JMP$CHANGE_INPUT_ATTRIBUTES
INCLUDE_DECK D=JMP$CHANGE_JOB_ATTRIBUTES
INCLUDE_DECK D=JMP$CHANGE_OUTPUT_ATTRIBUTES
INCLUDE_DECK D=JMP$CHANGE_QFILE_ATTRIBUTES
INCLUDE_DECK D=JMP$CLOSE_INPUT_FILE
INCLUDE_DECK D=JMP$CLOSE_OUTPUT_FILE
INCLUDE_DECK D=JMP$CLOSE_QFILE
INCLUDE_DECK D=JMP$COPY_QFILE
INCLUDE_DECK D=JMP$CLUSTER_GET_LEVELING_DATA
INCLUDE_DECK D=JMP$DETERMINE_NAME_KIND
INCLUDE_DECK D=JMP$EMIT_COMMUNICATION_STAT
INCLUDE_DECK D=JMP$GET_ACTIVE_SCHEDULING_ATTR
INCLUDE_DECK D=JMP$GET_ATTRIBUTE_DEFAULTS
INCLUDE_DECK D=JMP$GET_INPUT_ATTRIBUTES
INCLUDE_DECK D=JMP$GET_JOB_ATTRIBUTES
INCLUDE_DECK D=JMP$GET_JOB_STATUS
INCLUDE_DECK D=JMP$GET_OUTPUT_ATTRIBUTES
INCLUDE_DECK D=JMP$GET_OUTPUT_COUNTS
INCLUDE_DECK D=JMP$GET_OUTPUT_STATUS
INCLUDE_DECK D=JMP$GET_QFILE_ATTRIBUTES
INCLUDE_DECK D=JMP$GET_QFILE_STATUS
INCLUDE_DECK D=JMP$GET_RESULT_SIZE
INCLUDE_DECK D=JMP$JOB_EXISTS
INCLUDE_DECK D=JMP$MODIFIED_INPUT_EXISTS
INCLUDE_DECK D=JMP$MODIFIED_OUTPUT_EXISTS
INCLUDE_DECK D=JMP$MODIFIED_QFILE_EXISTS
INCLUDE_DECK D=JMP$NEW_INPUT_EXISTS
INCLUDE_DECK D=JMP$NEW_OUTPUT_EXISTS
INCLUDE_DECK D=JMP$NEW_QFILE_EXISTS
INCLUDE_DECK D=JMP$OPEN_INPUT_FILE
INCLUDE_DECK D=JMP$OPEN_OUTPUT_FILE
INCLUDE_DECK D=JMP$OPEN_QFILE
INCLUDE_DECK D=JMP$PRINT_FILE
INCLUDE_DECK D=JMP$REGISTER_INPUT_APPLICATION
INCLUDE_DECK D=JMP$REGISTER_OUTPUT_APPLICATION
INCLUDE_DECK D=JMP$REGISTER_QFILE_APPLICATION
INCLUDE_DECK D=JMP$RETURN_CONNECTION
INCLUDE_DECK D=JMP$SET_INPUT_COMPLETED
INCLUDE_DECK D=JMP$SET_INPUT_INITIATED
INCLUDE_DECK D=JMP$SET_INTERACTIVE_COND_STATE
INCLUDE_DECK D=JMP$SET_OUTPUT_COMPLETED
INCLUDE_DECK D=JMP$SET_OUTPUT_INITIATED
INCLUDE_DECK D=JMP$SET_QFILE_COMPLETED
INCLUDE_DECK D=JMP$SET_QFILE_INITIATED
INCLUDE_DECK D=JMP$SUBMIT_DETACHED_JOB
INCLUDE_DECK D=JMP$SUBMIT_QFILE
INCLUDE_DECK D=JMP$TERMINATED_INPUT_EXISTS
INCLUDE_DECK D=JMP$TERMINATED_OUTPUT_EXISTS
INCLUDE_DECK D=JMP$TERMINATED_QFILE_EXISTS
INCLUDE_DECK D=JMP$TERMINATE_ACQUIRED_INPUT
INCLUDE_DECK D=JMP$TERMINATE_ACQUIRED_OUTPUT
INCLUDE_DECK D=JMP$TERMINATE_ACQUIRED_QFILE
INCLUDE_DECK D=JMP$TERMINATE_OUTPUT
INCLUDE_DECK D=JMP$TERMINATE_QFILE
INCLUDE_DECK D=JMP$UPDATE_OUTPUT_STATUS
INCLUDE_DECK D=JMP$UPDATE_QFILE_STATUS
INCLUDE_DECK D=JMT$AGING_INTERVAL
INCLUDE_DECK D=JMT$COMM_ACCT_STATISTIC_DATA
INCLUDE_DECK D=JMT$CPU_TIME_USED
INCLUDE_DECK D=JMT$DEFAULT_ATTRIBUTE_RESULTS
INCLUDE_DECK D=JMT$DETACHED_JOB_WAIT_TIME
INCLUDE_DECK D=JMT$DISPLAY_MESSAGE
INCLUDE_DECK D=JMT$FTP_STATISTIC_DATA
INCLUDE_DECK D=JMT$INPUT_ATTRIBUTE_CHANGES
INCLUDE_DECK D=JMT$INPUT_ATTRIBUTE_OPTIONS
INCLUDE_DECK D=JMT$INPUT_ATTRIBUTE_RESULTS
INCLUDE_DECK D=JMT$INPUT_DESCRIPTOR
INCLUDE_DECK D=JMT$INPUT_FILE_LOCATION
INCLUDE_DECK D=JMT$INPUT_FILE_STATISTIC_DATA
INCLUDE_DECK D=JMT$INTERACTIVE_JOB_INFO
INCLUDE_DECK D=JMT$JOB_ATTRIBUTE_CHANGES
INCLUDE_DECK D=JMT$JOB_ATTRIBUTE_RESULTS
INCLUDE_DECK D=JMT$JOB_CATEGORY
INCLUDE_DECK D=JMT$JOB_CATEGORY_LIST
INCLUDE_DECK D=JMT$JOB_CATEGORY_SET
INCLUDE_DECK D=JMT$JOB_COUNT_RANGE
INCLUDE_DECK D=JMT$JOB_INITIATION_LEVEL
INCLUDE_DECK D=JMT$JOB_MODE_SET
INCLUDE_DECK D=JMT$JOB_PRIORITY
INCLUDE_DECK D=JMT$JOB_PROCESSING_PHASE
INCLUDE_DECK D=JMT$JOB_SIZE
INCLUDE_DECK D=JMT$JOB_STATUS_COUNT
INCLUDE_DECK D=JMT$JOB_STATUS_OPTIONS
INCLUDE_DECK D=JMT$JOB_STATUS_RESULTS
INCLUDE_DECK D=JMT$JOB_STATUS_RESULTS_KEYS
INCLUDE_DECK D=JMT$MAINFRAME_LEVELING_DATA
INCLUDE_DECK D=JMT$MAINFRAMES_SEARCHED_LIST
INCLUDE_DECK D=JMT$MAXIMUM_ACTIVE_JOBS
INCLUDE_DECK D=JMT$MAXIMUM_INITIATED_JOBS
INCLUDE_DECK D=JMT$MAXIMUM_MAINFRAMES
INCLUDE_DECK D=JMT$NAME_LIST
INCLUDE_DECK D=JMT$OUTPUT_ATTRIBUTE_CHANGES
INCLUDE_DECK D=JMT$OUTPUT_ATTRIBUTE_OPTIONS
INCLUDE_DECK D=JMT$OUTPUT_ATTRIBUTE_RESULTS
INCLUDE_DECK D=JMT$OUTPUT_CLASS_NAME
INCLUDE_DECK D=JMT$OUTPUT_COUNTS
INCLUDE_DECK D=JMT$OUTPUT_COUNT_RANGE
INCLUDE_DECK D=JMT$OUTPUT_DESCRIPTOR
INCLUDE_DECK D=JMT$OUTPUT_DEVICE_TYPE
INCLUDE_DECK D=JMT$OUTPUT_FILE_POSITION
INCLUDE_DECK D=JMT$OUTPUT_FILE_SIZE
INCLUDE_DECK D=JMT$OUTPUT_FILE_STATISTIC_DATA
INCLUDE_DECK D=JMT$OUTPUT_PRIORITY
INCLUDE_DECK D=JMT$OUTPUT_QUEUE_RESIDENCY_DATA
INCLUDE_DECK D=JMT$OUTPUT_STATE
INCLUDE_DECK D=JMT$OUTPUT_STATE_SET
INCLUDE_DECK D=JMT$OUTPUT_STATUS_COUNT
INCLUDE_DECK D=JMT$OUTPUT_STATUS_OPTIONS
INCLUDE_DECK D=JMT$OUTPUT_STATUS_RESULTS
INCLUDE_DECK D=JMT$OUTPUT_STATUS_UPDATES
INCLUDE_DECK D=JMT$OUTPUT_SUBMISSION_OPTIONS
INCLUDE_DECK D=JMT$OUTPUT_TERMINATION_OPTIONS
INCLUDE_DECK D=JMT$PAGE_FAULTS
INCLUDE_DECK D=JMT$PRIVILEGE
INCLUDE_DECK D=JMT$PRINT_FILE_STATISTIC_DATA
INCLUDE_DECK D=JMT$PRIORITY_AGING_INTERVAL
INCLUDE_DECK D=JMT$PRIORITY_BIAS
INCLUDE_DECK D=JMT$PTF_STATISTIC_DATA
INCLUDE_DECK D=JMT$QFILE_APPLICATION_ATTRS
INCLUDE_DECK D=JMT$QFILE_ATTRIBUTE_CHANGES
INCLUDE_DECK D=JMT$QFILE_ATTRIBUTE_COUNT
INCLUDE_DECK D=JMT$QFILE_ATTRIBUTE_KEYS
INCLUDE_DECK D=JMT$QFILE_ATTRIBUTE_OPTIONS
INCLUDE_DECK D=JMT$QFILE_ATTRIBUTE_RESULTS
INCLUDE_DECK D=JMT$QFILE_REGISTRATION_OPTIONS
INCLUDE_DECK D=JMT$QFILE_STATE
INCLUDE_DECK D=JMT$QFILE_STATE_SET
INCLUDE_DECK D=JMT$QFILE_STATUS_COUNT
INCLUDE_DECK D=JMT$QFILE_STATUS_OPTIONS
INCLUDE_DECK D=JMT$QFILE_STATUS_RESULTS
INCLUDE_DECK D=JMT$QFILE_STATUS_UPDATES
INCLUDE_DECK D=JMT$QFILE_SUBMISSION_OPTIONS
INCLUDE_DECK D=JMT$QFILE_TERMINATION_OPTIONS
INCLUDE_DECK D=JMT$QTF_DEST_STATISTIC_DATA
INCLUDE_DECK D=JMT$QTF_DEST_STATISTIC_KIND
INCLUDE_DECK D=JMT$QTF_STATISTIC_DATA
INCLUDE_DECK D=JMT$QUEUE_FILE_PASSWORD
INCLUDE_DECK D=JMT$REPRINT_DISPOSITION
INCLUDE_DECK D=JMT$RERUN_DISPOSITION
INCLUDE_DECK D=JMT$RESULTS_KEYS
INCLUDE_DECK D=JMT$RPC_MAINFRAMES_PROCESSED
INCLUDE_DECK D=JMT$SCHEDULING_ATTR_RESULTS
INCLUDE_DECK D=JMT$SCHEDULING_ATTRIBUTE_KEYS
INCLUDE_DECK D=JMT$SCHEDULING_RESULTS_KEYS
INCLUDE_DECK D=JMT$SELECTION_PRIORITY
INCLUDE_DECK D=JMT$SERVICE_CLASS_NAME
INCLUDE_DECK D=JMT$SERVICE_DATA
INCLUDE_DECK D=JMT$SUBMIT_JOB_STATISTIC_DATA
INCLUDE_DECK D=JMT$SYSTEM_SUPPLIED_NAME_LIST
INCLUDE_DECK D=JMT$WORK_AREA
INCLUDE_DECK D=LLE$FIND_EP_DIAGNOSTICS
INCLUDE_DECK D=MMH$ASSIGN_PAGES
INCLUDE_DECK D=MMH$CHANGE_STACK_ATTRIBUTE
INCLUDE_DECK D=MMH$CHECK_IF_PAGES_IN_MEMORY
INCLUDE_DECK D=MMH$CHECK_IO_COMPLETIONS
INCLUDE_DECK D=MMH$CHECK_IO_STATUS
INCLUDE_DECK D=MMH$CONDITIONAL_FREE
INCLUDE_DECK D=MMH$CREATE_SEGMENT
INCLUDE_DECK D=MMH$CREATE_SHADOW_SEGMENT
INCLUDE_DECK D=MMH$DELETE_SEGMENT
INCLUDE_DECK D=MMH$FETCH_PVA_UNWRITTEN_PAGES
INCLUDE_DECK D=MMH$INITIATE_DEBUG_SHADOWING
INCLUDE_DECK D=MMH$INITIATE_SHADOWING
INCLUDE_DECK D=MMH$LOCK_PAGES
INCLUDE_DECK D=MMH$LOCK_SEGMENT
INCLUDE_DECK D=MMH$MOVE_PAGES
INCLUDE_DECK D=MMH$READ
INCLUDE_DECK D=MMH$RESERVE_SEGMENT_NUMBER
INCLUDE_DECK D=MMH$SET_SEGMENT_LENGTH
INCLUDE_DECK D=MMH$STORE_SEGMENT_ATTRIBUTES
INCLUDE_DECK D=MMH$TERMINATE_SHADOWING
INCLUDE_DECK D=MMH$UNLOCK_PAGES
INCLUDE_DECK D=MMH$UNLOCK_SEGMENT
INCLUDE_DECK D=MMH$VERIFY_ACCESS
INCLUDE_DECK D=MMH$WAIT_IO_COMPLETION
INCLUDE_DECK D=MMH$WRITE
INCLUDE_DECK D=MMP$ASSIGN_PAGES
INCLUDE_DECK D=MMP$CHANGE_STACK_ATTRIBUTE
INCLUDE_DECK D=MMP$CHECK_IF_PAGES_IN_MEMORY
INCLUDE_DECK D=MMP$CHECK_IO_COMPLETIONS
INCLUDE_DECK D=MMP$CHECK_IO_STATUS
INCLUDE_DECK D=MMP$CONDITIONAL_FREE
INCLUDE_DECK D=MMP$CREATE_SEGMENT
INCLUDE_DECK D=MMP$CREATE_SHADOW_SEGMENT
INCLUDE_DECK D=MMP$DELETE_SEGMENT
INCLUDE_DECK D=MMP$FETCH_PVA_UNWRITTEN_PAGES
INCLUDE_DECK D=MMP$INITIATE_DEBUG_SHADOWING
INCLUDE_DECK D=MMP$INITIATE_SHADOWING
INCLUDE_DECK D=MMP$LOCK_PAGES
INCLUDE_DECK D=MMP$LOCK_SEGMENT
INCLUDE_DECK D=MMP$MOVE_PAGES
INCLUDE_DECK D=MMP$PREALLOCATE_FILE_SPACE
INCLUDE_DECK D=MMP$READ
INCLUDE_DECK D=MMP$RESERVE_SEGMENT_NUMBER
INCLUDE_DECK D=MMP$STORE_SEGMENT_ATTRIBUTES
INCLUDE_DECK D=MMP$TERMINATE_SHADOWING
INCLUDE_DECK D=MMP$UNLOCK_PAGES
INCLUDE_DECK D=MMP$UNLOCK_SEGMENT
INCLUDE_DECK D=MMP$VERIFY_ACCESS
INCLUDE_DECK D=MMP$WAIT_IO_COMPLETION
INCLUDE_DECK D=MMP$WRITE
INCLUDE_DECK D=MMT$ATTRIBUTE_KEYWORD
INCLUDE_DECK D=MMT$IO_STATUS
INCLUDE_DECK D=MMT$LUS_DECLARATIONS
INCLUDE_DECK D=MMT$MODIFIED_BIT_OPTION
INCLUDE_DECK D=MMT$MOVE_PAGES_PAGE_COUNT
INCLUDE_DECK D=MMT$RMA_LIST
INCLUDE_DECK D=MMT$SEGMENT_INHERITANCE
INCLUDE_DECK D=MMT$SEGMENT_ORIGIN
INCLUDE_DECK D=MMT$VA_ACCESS_MODE
INCLUDE_DECK D=MSH$RELEASE_MAINTENANCE_ACCESS
INCLUDE_DECK D=MSH$REQUEST_MAINTENANCE_ACCESS
INCLUDE_DECK D=MSH$VALIDATE_MEDIA_ACCESS
INCLUDE_DECK D=MSP$RELEASE_MAINTENANCE_ACCESS
INCLUDE_DECK D=MSP$REQUEST_MAINTENANCE_ACCESS
INCLUDE_DECK D=MSP$VALIDATE_MEDIA_ACCESS
INCLUDE_DECK D=MST$ACCESS_TYPE
INCLUDE_DECK D=NAC$CONDITION_CODE_LIMITS
INCLUDE_DECK D=NAC$SE_MIN_FRAGMENT_SIZE
INCLUDE_DECK D=NAC$SK_MAX_HOST_NAME_SIZE
INCLUDE_DECK D=NAC$SK_MAX_PORT_NUMBER
INCLUDE_DECK D=NAC$SK_MAX_SOCKET_IDENTIFIER
INCLUDE_DECK D=NAE$APPLICATION_INTERFACES
INCLUDE_DECK D=NAE$APPLICATION_MANAGEMENT
INCLUDE_DECK D=NAE$CLIENT_VALIDATION_DIALOG
INCLUDE_DECK D=NAE$CONDITION_CODES
INCLUDE_DECK D=NAE$DIRECTORY_ME_CONDITIONS
INCLUDE_DECK D=NAE$FILE_ACCESS_ME_CONDITIONS
INCLUDE_DECK D=NAE$ICA_CONDITIONS
INCLUDE_DECK D=NAE$INITIALIZATION_INTERFACES
INCLUDE_DECK D=NAE$INITIALIZATION_ME
INCLUDE_DECK D=NAE$INTERNAL_INTERACTIVE_APPL
INCLUDE_DECK D=NAE$LOG_ME_CONDITIONS
INCLUDE_DECK D=NAE$MANAGE_NETWORK_APPLICATIONS
INCLUDE_DECK D=NAE$NAMVE_CONDITIONS
INCLUDE_DECK D=NAE$NETWORK_ACCESS_AGENT
INCLUDE_DECK D=NAE$NETWORK_CONFIGURATION
INCLUDE_DECK D=NAE$NETWORK_OPERATOR_UTILITY
INCLUDE_DECK D=NAE$OSI_INTERNAL_INTERFACES
INCLUDE_DECK D=NAE$SYSTEM_MGMT_ACCESS_AGENT
INCLUDE_DECK D=NAE$SK_SOCKET_LAYER
INCLUDE_DECK D=NAE$TCP_CONDITION_CODES
INCLUDE_DECK D=NAE$TCPIP_MGMT_CONDITION_CODES
INCLUDE_DECK D=NAH$ACCEPT_CONNECTION
INCLUDE_DECK D=NAH$ACCEPT_SWITCH_OFFER
INCLUDE_DECK D=NAH$ACQUIRE_CONNECTION
INCLUDE_DECK D=NAH$ADD_SERVER_TITLE
INCLUDE_DECK D=NAH$ATTACH_SERVER_APPLICATION
INCLUDE_DECK D=NAH$AWAIT_DATA_AVAILABLE
INCLUDE_DECK D=NAH$AWAIT_SERVER_RESPONSE
INCLUDE_DECK D=NAH$BEGIN_DIRECTORY_SEARCH
INCLUDE_DECK D=NAH$CANCEL_SWITCH_OFFER
INCLUDE_DECK D=NAH$CHANGE_ATTRIBUTES
INCLUDE_DECK D=NAH$DELETE_SERVER_TITLE
INCLUDE_DECK D=NAH$DETACH_SERVER_APPLICATION
INCLUDE_DECK D=NAH$END_DIRECTORY_SEARCH
INCLUDE_DECK D=NAH$FETCH_ATTRIBUTES
INCLUDE_DECK D=NAH$GET_ATTRIBUTES
INCLUDE_DECK D=NAH$GET_TITLE_TRANSLATION
INCLUDE_DECK D=NAH$OFFER_CONNECTION_SWITCH
INCLUDE_DECK D=NAH$REQUEST_CONNECTION
INCLUDE_DECK D=NAH$SE_GET_AVAILABLE_BYTE_COUNT
INCLUDE_DECK D=NAH$SE_INTERRUPT
INCLUDE_DECK D=NAH$SE_RECEIVE_DATA
INCLUDE_DECK D=NAH$SE_SEND_DATA
INCLUDE_DECK D=NAH$SE_SYNCHRONIZE
INCLUDE_DECK D=NAH$SE_SYNCHRONIZE_CONFIRM
INCLUDE_DECK D=NAH$STORE_ATTRIBUTES
INCLUDE_DECK D=NAH$SK_GET_SOCKET
INCLUDE_DECK D=NAH$SK_BIND_SOCKET
INCLUDE_DECK D=NAH$SK_CLOSE_SOCKET
INCLUDE_DECK D=NAH$SK_LISTEN_SOCKET
INCLUDE_DECK D=NAH$SK_ACCEPT_SOCKET
INCLUDE_DECK D=NAH$SK_CONNECT_SOCKET
INCLUDE_DECK D=NAH$SK_SET_SOCKET_OPTIONS
INCLUDE_DECK D=NAH$SK_GET_SOCKET_ATTRIBUTES
INCLUDE_DECK D=NAH$SK_GET_SOCKET_STATUS
INCLUDE_DECK D=NAH$SK_SEND_TO_SOCKET
INCLUDE_DECK D=NAH$SK_RECEIVE_FROM_SOCKET
INCLUDE_DECK D=NAH$SK_WRITE_SOCKET
INCLUDE_DECK D=NAH$SK_READ_SOCKET
INCLUDE_DECK D=NAH$SK_OFFER_SOCKET
INCLUDE_DECK D=NAH$SK_ACCEPT_SOCKET_OFFER
INCLUDE_DECK D=NAH$SK_AWAIT_SOCKET_EVENTS
INCLUDE_DECK D=NAH$SK_GET_HOST_NAME
INCLUDE_DECK D=NAH$SK_GET_LOCAL_ADDRESSES
INCLUDE_DECK D=NAP$ACCEPT_CONNECTION
INCLUDE_DECK D=NAP$ACCEPT_SWITCH_OFFER
INCLUDE_DECK D=NAP$ACQUIRE_CONNECTION
INCLUDE_DECK D=NAP$ADD_SERVER_TITLE
INCLUDE_DECK D=NAP$ATTACH_SERVER_APPLICATION
INCLUDE_DECK D=NAP$AWAIT_DATA_AVAILABLE
INCLUDE_DECK D=NAP$AWAIT_SERVER_RESPONSE
INCLUDE_DECK D=NAP$BEGIN_DIRECTORY_SEARCH
INCLUDE_DECK D=NAP$CANCEL_SWITCH_OFFER
INCLUDE_DECK D=NAP$CHANGE_ATTRIBUTES
INCLUDE_DECK D=NAP$DELETE_SERVER_TITLE
INCLUDE_DECK D=NAP$DETACH_SERVER_APPLICATION
INCLUDE_DECK D=NAP$END_DIRECTORY_SEARCH
INCLUDE_DECK D=NAP$FETCH_ATTRIBUTES
INCLUDE_DECK D=NAP$GET_ATTRIBUTES
INCLUDE_DECK D=NAP$GET_TITLE_TRANSLATION
INCLUDE_DECK D=NAP$OFFER_CONNECTION_SWITCH
INCLUDE_DECK D=NAP$REQUEST_CONNECTION
INCLUDE_DECK D=NAP$SE_GET_AVAILABLE_BYTE_COUNT
INCLUDE_DECK D=NAP$SE_INTERRUPT
INCLUDE_DECK D=NAP$SE_RECEIVE_DATA
INCLUDE_DECK D=NAP$SE_SEND_DATA
INCLUDE_DECK D=NAP$SE_SYNCHRONIZE
INCLUDE_DECK D=NAP$SE_SYNCHRONIZE_CONFIRM
INCLUDE_DECK D=NAP$SK_GET_SOCKET
INCLUDE_DECK D=NAP$SK_BIND_SOCKET
INCLUDE_DECK D=NAP$SK_CLOSE_SOCKET
INCLUDE_DECK D=NAP$SK_LISTEN_SOCKET
INCLUDE_DECK D=NAP$SK_ACCEPT_SOCKET
INCLUDE_DECK D=NAP$SK_CONNECT_SOCKET
INCLUDE_DECK D=NAP$SK_SET_SOCKET_OPTIONS
INCLUDE_DECK D=NAP$SK_GET_SOCKET_ATTRIBUTES
INCLUDE_DECK D=NAP$SK_GET_SOCKET_STATUS
INCLUDE_DECK D=NAP$SK_SEND_TO_SOCKET
INCLUDE_DECK D=NAP$SK_RECEIVE_FROM_SOCKET
INCLUDE_DECK D=NAP$SK_WRITE_SOCKET
INCLUDE_DECK D=NAP$SK_READ_SOCKET
INCLUDE_DECK D=NAP$SK_OFFER_SOCKET
INCLUDE_DECK D=NAP$SK_ACCEPT_SOCKET_OFFER
INCLUDE_DECK D=NAP$SK_AWAIT_SOCKET_EVENTS
INCLUDE_DECK D=NAP$SK_GET_HOST_NAME
INCLUDE_DECK D=NAP$SK_GET_LOCAL_ADDRESSES
INCLUDE_DECK D=NAP$STORE_ATTRIBUTES
INCLUDE_DECK D=NAT$APPLICATION_NAME
INCLUDE_DECK D=NAT$BCD_TIME
INCLUDE_DECK D=NAT$COMMUNITY_TITLE
INCLUDE_DECK D=NAT$CONNECTION_ID
INCLUDE_DECK D=NAT$CREATE_ATTRIBUTES
INCLUDE_DECK D=NAT$DIRECTORY_DATA
INCLUDE_DECK D=NAT$DIRECTORY_ENTRY_IDENTIFIER
INCLUDE_DECK D=NAT$DIRECTORY_INTERFACES
INCLUDE_DECK D=NAT$DIRECTORY_PRIORITY
INCLUDE_DECK D=NAT$DIRECTORY_SEARCH_IDENTIFIER
INCLUDE_DECK D=NAT$FILE_STATE
INCLUDE_DECK D=NAT$GLOBAL_FILE_INFORMATION
INCLUDE_DECK D=NAT$NUMBER_OF_CONNECTIONS
INCLUDE_DECK D=NAT$SK_COMPLETED_EVENT
INCLUDE_DECK D=NAT$SK_COMPLETED_EVENT_KIND
INCLUDE_DECK D=NAT$SK_COMPLETED_EVENTS
INCLUDE_DECK D=NAT$SK_HOST_NAME
INCLUDE_DECK D=NAT$SK_INTERFACE_MODE
INCLUDE_DECK D=NAT$SK_IP_ADDRESS
INCLUDE_DECK D=NAT$SK_LISTEN_QUEUE_LIMIT
INCLUDE_DECK D=NAT$SK_LOCAL_ADDRESS
INCLUDE_DECK D=NAT$SK_LOCAL_ADDRESSES
INCLUDE_DECK D=NAT$SK_PORT_NUMBER
INCLUDE_DECK D=NAT$SK_SOCKET_ADDRESS
INCLUDE_DECK D=NAT$SK_SOCKET_ATTRIBUTE
INCLUDE_DECK D=NAT$SK_SOCKET_ATTRIBUTES
INCLUDE_DECK D=NAT$SK_SOCKET_ATTRIBUTE_KIND
INCLUDE_DECK D=NAT$SK_SOCKET_ATTRIBUTES
INCLUDE_DECK D=NAT$SK_SOCKET_EVENT
INCLUDE_DECK D=NAT$SK_SOCKET_EVENT_KIND
INCLUDE_DECK D=NAT$SK_SOCKET_EVENTS
INCLUDE_DECK D=NAT$SK_SOCKET_IDENTIFIER
INCLUDE_DECK D=NAT$SK_SOCKET_OPTION
INCLUDE_DECK D=NAT$SK_SOCKET_OPTION_KIND
INCLUDE_DECK D=NAT$SK_SOCKET_OPTIONS
INCLUDE_DECK D=NAT$SK_SOCKET_STATUS
INCLUDE_DECK D=NAT$SK_SOCKET_TYPE
INCLUDE_DECK D=NAT$SK_SUPPORTED_PROTOCOL
INCLUDE_DECK D=NAT$SK_TRAFFIC_PATTERN
INCLUDE_DECK D=NAT$TITLE_ATTRIBUTES
INCLUDE_DECK D=NAT$TITLE_PATTERN
INCLUDE_DECK D=NAT$TRANSLATION_ATTRIBUTES
INCLUDE_DECK D=NAT$XT_INTERFACE
INCLUDE_DECK D=NFH$VERIFY_FAMILY
INCLUDE_DECK D=NFP$VERIFY_FAMILY
INCLUDE_DECK D=NLC$TA_SAP_RANGES
INCLUDE_DECK D=NLT$CL_REFERENCE_NUMBER
INCLUDE_DECK D=NLT$TA_SAP_SELECTOR
INCLUDE_DECK D=OCC$CONDITION_LIMITS
INCLUDE_DECK D=OCE$VE_LINKER_EXCEPTIONS
INCLUDE_DECK D=OCP$CLOSE_LINKER_DEBUG_TABLE
INCLUDE_DECK D=OCP$DEFINE_LINKER_DEBUG_TABLE
INCLUDE_DECK D=OCP$FIND_DEBUG_ADDRESS
INCLUDE_DECK D=OCP$FIND_DEBUG_ADDRESS_IN_CODE
INCLUDE_DECK D=OCP$FIND_DEBUG_ENTRY_POINT
INCLUDE_DECK D=OCP$FIND_DEBUG_MODULE_ITEM
INCLUDE_DECK D=OCP$GET_DEBUG_TABLE_HEADER
INCLUDE_DECK D=OCP$OPEN_LINKER_DEBUG_TABLE
INCLUDE_DECK D=OCP$OPEN_RUNNING_DEBUG_TABLE
INCLUDE_DECK D=OSC$SERVER_STATE_CHANGE
INCLUDE_DECK D=OSE$KEYPOINT_CONDITIONS
INCLUDE_DECK D=OSH$COLLECTION_FILE_INFO
INCLUDE_DECK D=OSH$DISESTABLISH_COND_HANDLER
INCLUDE_DECK D=OSH$ESTABLISH_BLOCK_EXIT_HNDLR
INCLUDE_DECK D=OSH$ESTABLISH_CONDITION_HANDLER
INCLUDE_DECK D=OSH$FETCH_COLLECTION_FILE_INFO
INCLUDE_DECK D=OSH$FETCH_SYSTEM_CONSTANT
INCLUDE_DECK D=OSH$FIND_HELP_MODULE_IN_LIBRARY
INCLUDE_DECK D=OSH$FIND_STATUS_MESSAGE_BY_CODE
INCLUDE_DECK D=OSH$FIND_STATUS_MESSAGE_BY_NAME
INCLUDE_DECK D=OSH$FORMAT_MULTI_PART_MESSAGE
INCLUDE_DECK D=OSH$GENERATE_ERROR_MESSAGE
INCLUDE_DECK D=OSH$GENERATE_LOG_MESSAGE
INCLUDE_DECK D=OSH$GENERATE_MESSAGE
INCLUDE_DECK D=OSH$GENERATE_OUTPUT_MESSAGE
INCLUDE_DECK D=OSH$I_AWAIT_ACTIVITY_COMPLETION
INCLUDE_DECK D=OSH$ISSUE_STRING_AS_KEYPOINT
INCLUDE_DECK D=OSH$GET_UNIVERSAL_TASK_ID
INCLUDE_DECK D=OSH$READY_UNIVERSAL_TASK
INCLUDE_DECK D=OSH$RELEASE_KEYPOINT_ENV
INCLUDE_DECK D=OSH$RESERVE_KEYPOINT_ENV
INCLUDE_DECK D=OSH$SET_STATUS_CONDITION
INCLUDE_DECK D=OSH$START_KEYPOINT_COLLECTION
INCLUDE_DECK D=OSH$STOP_KEYPOINT_COLLECTION
INCLUDE_DECK D=OSH$STORE_SYSTEM_CONSTANT
INCLUDE_DECK D=OSK$COMMON_KEYPOINT_DEFINITIONS
INCLUDE_DECK D=OSP$COLLECTION_FILE_INFO
INCLUDE_DECK D=OSP$DISESTABLISH_COND_HANDLER
INCLUDE_DECK D=OSP$ESTABLISH_BLOCK_EXIT_HNDLR
INCLUDE_DECK D=OSP$ESTABLISH_CONDITION_HANDLER
INCLUDE_DECK D=OSP$FETCH_COLLECTION_FILE_INFO
INCLUDE_DECK D=OSP$FETCH_SYSTEM_CONSTANT
INCLUDE_DECK D=OSP$FIND_HELP_MODULE_IN_LIBRARY
INCLUDE_DECK D=OSP$FIND_STATUS_MESSAGE_BY_CODE
INCLUDE_DECK D=OSP$FIND_STATUS_MESSAGE_BY_NAME
INCLUDE_DECK D=OSP$FLUSH_ALLOCATION_INFO
INCLUDE_DECK D=OSP$FORMAT_MULTI_PART_MESSAGE
INCLUDE_DECK D=OSP$GENERATE_ERROR_MESSAGE
INCLUDE_DECK D=OSP$GENERATE_LOG_MESSAGE
INCLUDE_DECK D=OSP$GENERATE_MESSAGE
INCLUDE_DECK D=OSP$GENERATE_OUTPUT_MESSAGE
INCLUDE_DECK D=OSP$GET_UNIVERSAL_TASK_ID
INCLUDE_DECK D=OSP$ISSUE_STRING_AS_KEYPOINT
INCLUDE_DECK D=OSP$I_AWAIT_ACTIVITY_COMPLETION
INCLUDE_DECK D=OSP$READY_UNIVERSAL_TASK
INCLUDE_DECK D=OSP$RELEASE_KEYPOINT_ENV
INCLUDE_DECK D=OSP$RESERVE_KEYPOINT_ENV
INCLUDE_DECK D=OSP$SET_STATUS_CONDITION
INCLUDE_DECK D=OSP$START_KEYPOINT_COLLECTION
INCLUDE_DECK D=OSP$STOP_KEYPOINT_COLLECTION
INCLUDE_DECK D=OSP$STORE_SYSTEM_CONSTANT
INCLUDE_DECK D=OSP$WAIT_ON_CONDITION
INCLUDE_DECK D=OSS$JOB_PAGEABLE
INCLUDE_DECK D=OST$AGING_INTERVAL
INCLUDE_DECK D=OST$CPU_DEFINITIONS
INCLUDE_DECK D=OST$GET_MESSAGE_PART
INCLUDE_DECK D=OST$HEAP
INCLUDE_DECK D=OST$I_WAIT
INCLUDE_DECK D=OST$KEYPOINT_ENVIRONMENT
INCLUDE_DECK D=OST$PHYSICAL_CHANNEL_NUMBER
INCLUDE_DECK D=OST$PHYSICAL_PP_NUMBER
INCLUDE_DECK D=OST$SIGNATURE_LOCK
INCLUDE_DECK D=OST$STATUS_MESSAGE_HEADER_KIND
INCLUDE_DECK D=OST$UNIVERSAL_TASK_ID
INCLUDE_DECK D=OSV$TASK_PRIVATE_HEAP
INCLUDE_DECK D=PFD$ARCHIVE_DEFINITIONS
INCLUDE_DECK D=PFD$CATALOG_INFO
INCLUDE_DECK D=PFD$CHARGE_ID
INCLUDE_DECK D=PFD$CYCLE_STATISTICS
INCLUDE_DECK D=PFD$PASSWORD_SELECTOR
INCLUDE_DECK D=PFE$EXTERNAL_ARCHIVE_CONDITIONS
INCLUDE_DECK D=PFE$INTERNAL_ERROR_CONDITIONS
INCLUDE_DECK D=PFH$DELETE_ALL_ARCHIVE_ENTRIES
INCLUDE_DECK D=PFH$DELETE_ARCHIVE_ENTRY
INCLUDE_DECK D=PFH$FIND_ARCHIVE_INFO
INCLUDE_DECK D=PFH$FIND_CATALOG_DESCRIPTION
INCLUDE_DECK D=PFH$FIND_CYCLE_ARRAY
INCLUDE_DECK D=PFH$FIND_CYCLE_ARRAY_EXTENDED
INCLUDE_DECK D=PFH$FIND_CYCLE_ARRAY_VERSION_2
INCLUDE_DECK D=PFH$FIND_CYCLE_DIRECTORY
INCLUDE_DECK D=PFH$FIND_CYCLE_ENTRY
INCLUDE_DECK D=PFH$FIND_CYCLE_ENTRY_VERSION_2
INCLUDE_DECK D=PFH$FIND_DIRECTORY_ARRAY
INCLUDE_DECK D=PFH$FIND_DIRECT_INFO_RECORD
INCLUDE_DECK D=PFH$FIND_FILE_DESCRIPTION
INCLUDE_DECK D=PFH$FIND_LOG_ARRAY
INCLUDE_DECK D=PFH$FIND_NEXT_ARCHIVE_ENTRY
INCLUDE_DECK D=PFH$FIND_NEXT_INFO_RECORD
INCLUDE_DECK D=PFH$FIND_PERMIT_ARRAY
INCLUDE_DECK D=PFH$GET_ITEM_INFO
INCLUDE_DECK D=PFH$GET_MULTI_ITEM_INFO
INCLUDE_DECK D=PFH$MARK_RELEASE_CANDIDATE
INCLUDE_DECK D=PFH$PUT_ARCHIVE_ENTRY
INCLUDE_DECK D=PFH$PUT_ARCHIVE_INFO
INCLUDE_DECK D=PFH$RELEASE_DATA
INCLUDE_DECK D=PFH$REPLACE_ARCHIVE_ENTRY
INCLUDE_DECK D=PFP$DELETE_ALL_ARCHIVE_ENTRIES
INCLUDE_DECK D=PFP$DELETE_ARCHIVE_ENTRY
INCLUDE_DECK D=PFP$FIND_ARCHIVE_INFO
INCLUDE_DECK D=PFP$FIND_CATALOG_DESCRIPTION
INCLUDE_DECK D=PFP$FIND_CYCLE_ARRAY
INCLUDE_DECK D=PFP$FIND_CYCLE_ARRAY_EXTENDED
INCLUDE_DECK D=PFP$FIND_CYCLE_ARRAY_VERSION_2
INCLUDE_DECK D=PFP$FIND_CYCLE_DIRECTORY
INCLUDE_DECK D=PFP$FIND_CYCLE_ENTRY
INCLUDE_DECK D=PFP$FIND_CYCLE_ENTRY_VERSION_2
INCLUDE_DECK D=PFP$FIND_DIRECTORY_ARRAY
INCLUDE_DECK D=PFP$FIND_DIRECT_INFO_RECORD
INCLUDE_DECK D=PFP$FIND_FILE_DESCRIPTION
INCLUDE_DECK D=PFP$FIND_LOG_ARRAY
INCLUDE_DECK D=PFP$FIND_NEXT_ARCHIVE_ENTRY
INCLUDE_DECK D=PFP$FIND_NEXT_INFO_RECORD
INCLUDE_DECK D=PFP$FIND_PERMIT_ARRAY
INCLUDE_DECK D=PFP$GET_ITEM_INFO
INCLUDE_DECK D=PFP$GET_MULTI_ITEM_INFO
INCLUDE_DECK D=PFP$MARK_RELEASE_CANDIDATE
INCLUDE_DECK D=PFP$PUT_ARCHIVE_ENTRY
INCLUDE_DECK D=PFP$PUT_ARCHIVE_INFO
INCLUDE_DECK D=PFP$RELEASE_DATA
INCLUDE_DECK D=PFP$REPLACE_ARCHIVE_ENTRY
INCLUDE_DECK D=PFT$SHARED_QUEUE_INFO
INCLUDE_DECK D=PMH$BEGIN_SUBSYSTEM_ACTIVITY
INCLUDE_DECK D=PMH$BROADCAST_UNSEEN_MAIL
INCLUDE_DECK D=PMH$CAUSE_INTER_JOB_CONDITION
INCLUDE_DECK D=PMH$CAUSE_INTRA_JOB_CONDITION
INCLUDE_DECK D=PMH$CHANGE_BINDING_TO_WRITE
INCLUDE_DECK D=PMH$CHANGE_DEFAULT_PROG_OPTIONS
INCLUDE_DECK D=PMH$CHANGE_JOB_LIBRARY_LIST
INCLUDE_DECK D=PMH$CHANGE_TRANSIENT_TO_BINDING
INCLUDE_DECK D=PMH$CHANGE_TRANSIENT_TO_EXECUTE
INCLUDE_DECK D=PMH$CHANGE_TRANSIENT_TO_WRITE
INCLUDE_DECK D=PMH$CLOSE_COMMON_BLOCK_FILE
INCLUDE_DECK D=PMH$CLOSE_OBJECT_LIBRARY
INCLUDE_DECK D=PMH$COMPUTE_TIME_DIF_IN_SECONDS
INCLUDE_DECK D=PMH$CREATE_ADA_HEAP
INCLUDE_DECK D=PMH$DEFINE_DEBUG_ENTRY
INCLUDE_DECK D=PMH$DESELECT_PROCESSOR
INCLUDE_DECK D=PMH$DISESTABLISH_SEGMENT_ACCESS
INCLUDE_DECK D=PMH$END_SUBSYSTEM_ACTIVITY
INCLUDE_DECK D=PMH$ESTABLISH_DEBUG_CFF
INCLUDE_DECK D=PMH$ESTABLISH_SEGMENT_ACCESS
INCLUDE_DECK D=PMH$EXPAND_SEGMENT
INCLUDE_DECK D=PMH$FIND_MODULE_IN_LIBRARY
INCLUDE_DECK D=PMH$GET_DEBUG_ABORT_FILE
INCLUDE_DECK D=PMH$GET_DEBUG_ENTRY
INCLUDE_DECK D=PMH$GET_DEBUG_ID
INCLUDE_DECK D=PMH$GET_DEBUG_INPUT_FILE
INCLUDE_DECK D=PMH$GET_DEBUG_OUTPUT_FILE
INCLUDE_DECK D=PMH$GET_EXECUTING_TASK_GTID_R6
INCLUDE_DECK D=PMH$GET_LIBRARY_DICTIONARIES
INCLUDE_DECK D=PMH$GET_OS_BUILD_LEVEL
INCLUDE_DECK D=PMH$INITIAL_DEBUG_MODE_ON
INCLUDE_DECK D=PMH$LOAD_ENTRY_POINT
INCLUDE_DECK D=PMH$MODIFY_DEBUG_ENTRY
INCLUDE_DECK D=PMH$OPEN_COMMON_BLOCK_FILE
INCLUDE_DECK D=PMH$OPEN_OBJECT_LIBRARY
INCLUDE_DECK D=PMH$POP_INHIBIT_TERMINATION
INCLUDE_DECK D=PMH$POP_TASK_DEBUG_MODE
INCLUDE_DECK D=PMH$PUSH_INHIBIT_TERMINATION
INCLUDE_DECK D=PMH$PUSH_TASK_DEBUG_MODE
INCLUDE_DECK D=PMH$READY_TASK_AND_WAIT
INCLUDE_DECK D=PMH$REINITIALIZE_MODULE
INCLUDE_DECK D=PMH$REMOVE_DEBUG_ENTRY
INCLUDE_DECK D=PMH$RESET_DEBUG_SCAN
INCLUDE_DECK D=PMH$RESTORE_PROGRAM_STATE
INCLUDE_DECK D=PMH$REVOKE_PROGRAM_TERMINATION
INCLUDE_DECK D=PMH$SAVE_PROGRAM_STATE
INCLUDE_DECK D=PMH$SELECT_PROCESSOR
INCLUDE_DECK D=PMH$SET_RELATIVE_PRIORITY
INCLUDE_DECK D=PMH$SET_TASK_DEBUG_MODE
INCLUDE_DECK D=PMH$TASK_DEBUG_MODE_ON
INCLUDE_DECK D=PMH$TASK_DEBUG_RING
INCLUDE_DECK D=PMH$TERMINATED_WHILE_INHIBITED
INCLUDE_DECK D=PMH$VALIDATE_PREVIOUS_SAVE_AREA
INCLUDE_DECK D=PMH$ZERO_OUT_TABLE
INCLUDE_DECK D=PMP$BEGIN_SUBSYSTEM_ACTIVITY
INCLUDE_DECK D=PMP$BROADCAST_UNSEEN_MAIL
INCLUDE_DECK D=PMP$CAUSE_INTER_JOB_CONDITION
INCLUDE_DECK D=PMP$CAUSE_INTRA_JOB_CONDITION
INCLUDE_DECK D=PMP$CHANGE_BINDING_TO_WRITE
INCLUDE_DECK D=PMP$CHANGE_DEFAULT_PROG_OPTIONS
INCLUDE_DECK D=PMP$CHANGE_JOB_LIBRARY_LIST
INCLUDE_DECK D=PMP$CHANGE_TRANSIENT_TO_BINDING
INCLUDE_DECK D=PMP$CHANGE_TRANSIENT_TO_EXECUTE
INCLUDE_DECK D=PMP$CHANGE_TRANSIENT_TO_WRITE
INCLUDE_DECK D=PMP$CLOSE_COMMON_BLOCK_FILE
INCLUDE_DECK D=PMP$CLOSE_OBJECT_LIBRARY
INCLUDE_DECK D=PMP$COMPUTE_TIME_DIF_IN_SECONDS
INCLUDE_DECK D=PMP$CREATE_ADA_HEAP
INCLUDE_DECK D=PMP$DEFINE_DEBUG_ENTRY
INCLUDE_DECK D=PMP$DESELECT_PROCESSOR
INCLUDE_DECK D=PMP$DISESTABLISH_SEGMENT_ACCESS
INCLUDE_DECK D=PMP$END_SUBSYSTEM_ACTIVITY
INCLUDE_DECK D=PMP$ESTABLISH_CH_OUTSIDE_BLOCK
INCLUDE_DECK D=PMP$ESTABLISH_DEBUG_CFF
INCLUDE_DECK D=PMP$ESTABLISH_SEGMENT_ACCESS
INCLUDE_DECK D=PMP$EXPAND_SEGMENT
INCLUDE_DECK D=PMP$FIND_MODULE_IN_LIBRARY
INCLUDE_DECK D=PMP$GET_DEBUG_ABORT_FILE
INCLUDE_DECK D=PMP$GET_DEBUG_ENTRY
INCLUDE_DECK D=PMP$GET_DEBUG_ID
INCLUDE_DECK D=PMP$GET_DEBUG_INPUT_FILE
INCLUDE_DECK D=PMP$GET_DEBUG_OUTPUT_FILE
INCLUDE_DECK D=PMP$GET_EXECUTING_TASK_GTID_R6
INCLUDE_DECK D=PMP$GET_LIBRARY_DICTIONARIES
INCLUDE_DECK D=PMP$GET_OS_BUILD_LEVEL
INCLUDE_DECK D=PMP$INITIAL_DEBUG_MODE_ON
INCLUDE_DECK D=PMP$LOAD_ENTRY_POINT
INCLUDE_DECK D=PMP$MODIFY_DEBUG_ENTRY
INCLUDE_DECK D=PMP$OPEN_COMMON_BLOCK_FILE
INCLUDE_DECK D=PMP$OPEN_OBJECT_LIBRARY
INCLUDE_DECK D=PMP$POP_INHIBIT_TERMINATION
INCLUDE_DECK D=PMP$POP_TASK_DEBUG_MODE
INCLUDE_DECK D=PMP$PUSH_INHIBIT_TERMINATION
INCLUDE_DECK D=PMP$PUSH_TASK_DEBUG_MODE
INCLUDE_DECK D=PMP$READY_TASK_AND_WAIT
INCLUDE_DECK D=PMP$REINITIALIZE_MODULE
INCLUDE_DECK D=PMP$REMOVE_DEBUG_ENTRY
INCLUDE_DECK D=PMP$RESET_DEBUG_SCAN
INCLUDE_DECK D=PMP$RESTORE_PROGRAM_STATE
INCLUDE_DECK D=PMP$REVOKE_PROGRAM_TERMINATION
INCLUDE_DECK D=PMP$SAVE_PROGRAM_STATE
INCLUDE_DECK D=PMP$SELECT_PROCESSOR
INCLUDE_DECK D=PMP$SET_RELATIVE_PRIORITY
INCLUDE_DECK D=PMP$SET_TASK_DEBUG_MODE
INCLUDE_DECK D=PMP$TASK_DEBUG_MODE_ON
INCLUDE_DECK D=PMP$TASK_DEBUG_RING
INCLUDE_DECK D=PMP$TERMINATED_WHILE_INHIBITED
INCLUDE_DECK D=PMP$VALIDATE_PREVIOUS_SAVE_AREA
INCLUDE_DECK D=PMP$ZERO_OUT_TABLE
INCLUDE_DECK D=PMT$ADAPTABLE_SEQUENCE
INCLUDE_DECK D=PMT$DEFAULT_PROG_OPTIONS_CHANGE
INCLUDE_DECK D=PMT$EXT_DEFAULT_COND_HANDLER
INCLUDE_DECK D=PMT$LINKER_DEBUG_TABLE_HEADER
INCLUDE_DECK D=PMT$OBJECT_LIBRARY_ADDRESS
INCLUDE_DECK D=PMT$OS_STACK_FRAME_WORD
INCLUDE_DECK D=PMT$SYS_DEFAULT_COND_HANDLER
INCLUDE_DECK D=RMC$LABELED_EXTERNAL_TAPES
INCLUDE_DECK D=RMC$UNLABELED_TAPES
INCLUDE_DECK D=RMC$VOL_CLASSIFICATION_MODULE
INCLUDE_DECK D=RMC$VOL_CLASSIFICATION_PROMPT
INCLUDE_DECK D=RMH$ENFORCE_TAPE_SECURITY
INCLUDE_DECK D=RMP$ENFORCE_TAPE_SECURITY
INCLUDE_DECK D=RMP$VALIDATE_TAPE_ASSIGNMENT
INCLUDE_DECK D=RMP$VALIDATE_TAPE_REQUEST
INCLUDE_DECK D=SCC$DATE_LENGTH
INCLUDE_DECK D=SCC$LIBRARY_FORMAT_VERSION_L
INCLUDE_DECK D=SCC$LINE_LENGTH
INCLUDE_DECK D=SCC$MAX_COPY_DEPTH
INCLUDE_DECK D=SCC$MAX_DECKS
INCLUDE_DECK D=SCC$MAX_DESCRIPTION_SIZE
INCLUDE_DECK D=SCC$MAX_FEATURES
INCLUDE_DECK D=SCC$MAX_GROUPS
INCLUDE_DECK D=SCC$MAX_LIBRARY_LIST_INDEX
INCLUDE_DECK D=SCC$MAX_LINES_PER_DECK
INCLUDE_DECK D=SCC$MAX_MODS
INCLUDE_DECK D=SCC$MAX_SEQ_NUMBER
INCLUDE_DECK D=SCC$MAX_STATE
INCLUDE_DECK D=SCC$MOD_NAME_LENGTH
INCLUDE_DECK D=SCC$NIL_ALTERNATE_BASE
INCLUDE_DECK D=SCC$NIL_BASE
INCLUDE_DECK D=SCC$NIL_COMPILE_FILE
INCLUDE_DECK D=SCC$NIL_DECK
INCLUDE_DECK D=SCC$NIL_DECK_ATTRIBUTES
INCLUDE_DECK D=SCC$NIL_ERRORS
INCLUDE_DECK D=SCC$NIL_EXPAND_ATTRIBUTES
INCLUDE_DECK D=SCC$NIL_FILE
INCLUDE_DECK D=SCC$NIL_INPUT
INCLUDE_DECK D=SCC$NIL_INPUT_SOURCE_MAP
INCLUDE_DECK D=SCC$NIL_LIBRARY_ATTRIBUTES
INCLUDE_DECK D=SCC$NIL_LIBRARY_LIST
INCLUDE_DECK D=SCC$NIL_LIST_FILE
INCLUDE_DECK D=SCC$NIL_MODIFICATION
INCLUDE_DECK D=SCC$NIL_MODIFICATION_ATTRIBUTES
INCLUDE_DECK D=SCC$NIL_OBJECT_LIST
INCLUDE_DECK D=SCC$NIL_OUTPUT
INCLUDE_DECK D=SCC$NIL_OUTPUT_SOURCE_MAP
INCLUDE_DECK D=SCC$NIL_PROLOG
INCLUDE_DECK D=SCC$NIL_RESULT
INCLUDE_DECK D=SCC$NIL_SELECTION_CRITERIA
INCLUDE_DECK D=SCC$NIL_SOURCE
INCLUDE_DECK D=SCC$NIL_SOURCE_LIBRARIES
INCLUDE_DECK D=SCC$SCU_NAME_LENGTH
INCLUDE_DECK D=SCC$SCU_VERSION_LENGTH
INCLUDE_DECK D=SCC$STATUS_CONDITION
INCLUDE_DECK D=SCC$STATUS_ID
INCLUDE_DECK D=SCC$TIME_LENGTH
INCLUDE_DECK D=SCE$ALLOCATION_FAILED
INCLUDE_DECK D=SCE$ALL_NOT_ALLOWED
INCLUDE_DECK D=SCE$ALL_USED_IN_LIST
INCLUDE_DECK D=SCE$ALL_USED_IN_RANGE
INCLUDE_DECK D=SCE$CANNOT_DELETE_CREATION_MOD
INCLUDE_DECK D=SCE$CHANGED_BASE_LIBRARY
INCLUDE_DECK D=SCE$COMBINE_REQUIRES_AUTHORITY
INCLUDE_DECK D=SCE$COMMAND_NOT_ALLOWED
INCLUDE_DECK D=SCE$COMMAND_REQUIRES_AUTHORITY
INCLUDE_DECK D=SCE$COM_ALLOCATION_FAILED
INCLUDE_DECK D=SCE$CONDITION_CODES
INCLUDE_DECK D=SCE$CREATION_MOD_EXCLUDED
INCLUDE_DECK D=SCE$CREATION_MOD_NOT_STATE_4
INCLUDE_DECK D=SCE$CRITERIA_ENTRY_PROHIBITED
INCLUDE_DECK D=SCE$CYCLE_SELECTOR_NOT_FOUND
INCLUDE_DECK D=SCE$DECK_ALREADY_EXISTS
INCLUDE_DECK D=SCE$DECK_EXTENSION_WARNING
INCLUDE_DECK D=SCE$DECK_INTERLOCKED
INCLUDE_DECK D=SCE$DECK_LIMIT_EXCEEDED
INCLUDE_DECK D=SCE$DECK_MOD_LIMIT_EXCEEDED
INCLUDE_DECK D=SCE$DECK_NOT_EXPANDABLE
INCLUDE_DECK D=SCE$DECK_NOT_EXTRACTED
INCLUDE_DECK D=SCE$DECK_NOT_ON_BASE
INCLUDE_DECK D=SCE$DECK_NOT_REFERENCED
INCLUDE_DECK D=SCE$DECK_ON_TWO_LIBRARIES
INCLUDE_DECK D=SCE$DELIMITER_IN_NEW_TEXT
INCLUDE_DECK D=SCE$DELIMITER_TERMINATES_LINE
INCLUDE_DECK D=SCE$DISPLAY_INFO_STACK_EXCEEDED
INCLUDE_DECK D=SCE$DUPLICATE_DECK_NAME
INCLUDE_DECK D=SCE$DUPLICATE_FEATURE_NAME
INCLUDE_DECK D=SCE$DUPLICATE_GROUP_NAME
INCLUDE_DECK D=SCE$DUPLICATE_LIBRARIES
INCLUDE_DECK D=SCE$DUPLICATE_MOD_NAME
INCLUDE_DECK D=SCE$ERRORS_CLOSING_LIBRARIES
INCLUDE_DECK D=SCE$ERRORS_CONVERTING_LIBRARY
INCLUDE_DECK D=SCE$ERRORS_MERGING_DIRECTORIES
INCLUDE_DECK D=SCE$ERRORS_MERGING_MOD_LISTS
INCLUDE_DECK D=SCE$ERRORS_PROCESSING_COMMAND
INCLUDE_DECK D=SCE$ERRORS_PROCESSING_CRITERIA
INCLUDE_DECK D=SCE$ERRORS_PROCESSING_DECK
INCLUDE_DECK D=SCE$ERRORS_PROCESSING_LINE
INCLUDE_DECK D=SCE$ERRORS_PROCESSING_NAME_LIST
INCLUDE_DECK D=SCE$ERRORS_PROCESSING_PARAM
INCLUDE_DECK D=SCE$EXPECTING_DECK_DIRECTIVE
INCLUDE_DECK D=SCE$FEATURE_ALREADY_EXISTS
INCLUDE_DECK D=SCE$FEATURE_LIMIT_EXCEEDED
INCLUDE_DECK D=SCE$FEATURE_NOT_DELETED
INCLUDE_DECK D=SCE$FEATURE_OR_MOD_REQUIRED
INCLUDE_DECK D=SCE$FILE_ALREADY_EXISTS
INCLUDE_DECK D=SCE$FILE_NAME_CONFLICT
INCLUDE_DECK D=SCE$FIRST_DECK_ON_LIBRARY
INCLUDE_DECK D=SCE$FIRST_MOD_ON_LIBRARY
INCLUDE_DECK D=SCE$FORMAT_VERSION_MISMATCH
INCLUDE_DECK D=SCE$GROUP_ALREADY_EXISTS
INCLUDE_DECK D=SCE$GROUP_LIMIT_EXCEEDED
INCLUDE_DECK D=SCE$GROUP_NOT_DELETED
INCLUDE_DECK D=SCE$HEADERS_DIFFER_ON_MOD
INCLUDE_DECK D=SCE$HISTORY_LIMIT_EXCEEDED
INCLUDE_DECK D=SCE$INFO_SEQUENCE_OVERFLOW
INCLUDE_DECK D=SCE$INTERLOCK_VIOLATION
INCLUDE_DECK D=SCE$INTERLOCK_VIOLATION_WARNING
INCLUDE_DECK D=SCE$INTERNAL_ERROR
INCLUDE_DECK D=SCE$INVALID_COPY_DIRECTIVE
INCLUDE_DECK D=SCE$INVALID_CREATE_INDEX
INCLUDE_DECK D=SCE$INVALID_DECK_ATTR_KEY
INCLUDE_DECK D=SCE$INVALID_DECK_NAME
INCLUDE_DECK D=SCE$INVALID_FEATURE_NAME
INCLUDE_DECK D=SCE$INVALID_GROUP_NAME
INCLUDE_DECK D=SCE$INVALID_HISTORY_MOD_INDEX
INCLUDE_DECK D=SCE$INVALID_KEYWORD_VALUE
INCLUDE_DECK D=SCE$INVALID_LIBRARY_ATTR_KEY
INCLUDE_DECK D=SCE$INVALID_LIBRARY_FILE
INCLUDE_DECK D=SCE$INVALID_MOD_ATTR_KEY
INCLUDE_DECK D=SCE$INVALID_MOD_NAME
INCLUDE_DECK D=SCE$INVALID_RANGE_OF_COLUMNS
INCLUDE_DECK D=SCE$INVALID_RANGE_OF_DECKS
INCLUDE_DECK D=SCE$INVALID_RANGE_OF_FEATURES
INCLUDE_DECK D=SCE$INVALID_RANGE_OF_GROUPS
INCLUDE_DECK D=SCE$INVALID_RANGE_OF_MODS
INCLUDE_DECK D=SCE$KEY_CHARACTER_MISMATCH
INCLUDE_DECK D=SCE$LAST_DECK_ON_LIBRARY
INCLUDE_DECK D=SCE$LAST_MOD_ON_LIBRARY
INCLUDE_DECK D=SCE$LIBRARY_EXTENSION_WARNING
INCLUDE_DECK D=SCE$LIBRARY_MOD_LIMIT_EXCEEDED
INCLUDE_DECK D=SCE$LIBRARY_USED
INCLUDE_DECK D=SCE$LINE_LENGTH_EXCEEDED
INCLUDE_DECK D=SCE$LINE_LIMIT_EXCEEDED
INCLUDE_DECK D=SCE$LINE_ORIGIN_NOT_GIVEN
INCLUDE_DECK D=SCE$LINE_TRUNCATED
INCLUDE_DECK D=SCE$MISSING_DECK_NAME
INCLUDE_DECK D=SCE$MISSING_DIRECTIVE
INCLUDE_DECK D=SCE$MOD_ALREADY_EXISTS
INCLUDE_DECK D=SCE$MOD_CREATION_DATE_MISMATCH
INCLUDE_DECK D=SCE$MOD_CREATION_TIME_MISMATCH
INCLUDE_DECK D=SCE$MOD_CREATION_TIME_WARNING
INCLUDE_DECK D=SCE$MOD_EXTENSION_WARNING
INCLUDE_DECK D=SCE$MOD_MAX_STATE
INCLUDE_DECK D=SCE$MOD_NOT_MAPPED_IN_DECK
INCLUDE_DECK D=SCE$MOD_NOT_STATE_4
INCLUDE_DECK D=SCE$MOD_NOT_STATE_ZERO
INCLUDE_DECK D=SCE$MULTIPLE_DECK_NAME_SOURCES
INCLUDE_DECK D=SCE$NONE_NOT_ALLOWED
INCLUDE_DECK D=SCE$NONE_USED_IN_LIST
INCLUDE_DECK D=SCE$NONE_USED_IN_RANGE
INCLUDE_DECK D=SCE$NOT_PERMITTED_TO_RESULT
INCLUDE_DECK D=SCE$NO_ALT_BASES_SPECIFIED
INCLUDE_DECK D=SCE$NO_CHANGES_SPECIFIED
INCLUDE_DECK D=SCE$NO_DECKS_DELETED
INCLUDE_DECK D=SCE$NO_DECKS_ON_LIBRARY
INCLUDE_DECK D=SCE$NO_DECKS_SELECTED
INCLUDE_DECK D=SCE$NO_DECK_NAME_SPECIFIED
INCLUDE_DECK D=SCE$NO_DECK_SPECIFIED
INCLUDE_DECK D=SCE$NO_FEATURES_DELETED
INCLUDE_DECK D=SCE$NO_GROUPS_DELETED
INCLUDE_DECK D=SCE$NO_MODIFICATION_SPECIFIED
INCLUDE_DECK D=SCE$NO_MODS_DELETED
INCLUDE_DECK D=SCE$NO_MODS_ON_LIBRARY
INCLUDE_DECK D=SCE$NO_OBJECTS_COMBINED
INCLUDE_DECK D=SCE$NO_REFERENCES_ON_LIBRARY
INCLUDE_DECK D=SCE$NO_SOURCE_SPECIFIED
INCLUDE_DECK D=SCE$OBJECT_REQUIRES_AUTHORITY
INCLUDE_DECK D=SCE$ORIGIN_TABLE_EMPTY
INCLUDE_DECK D=SCE$PARAMETER_CONFLICT
INCLUDE_DECK D=SCE$RECURSIVE_COPY
INCLUDE_DECK D=SCE$REGENERATE_SOURCE_ABORTED
INCLUDE_DECK D=SCE$RESULT_LIBRARY_IS_STALE
INCLUDE_DECK D=SCE$RESULT_LIBRARY_WRITTEN
INCLUDE_DECK D=SCE$SI_ATTRIBUTE_MISMATCH
INCLUDE_DECK D=SCE$SOURCE_NAMES_MISMATCH
INCLUDE_DECK D=SCE$TERMINATE_DURING_COPY
INCLUDE_DECK D=SCE$TEXT_ON_WORKING_LIBRARY
INCLUDE_DECK D=SCE$TEXT_SEQUENCE_OVERFLOW
INCLUDE_DECK D=SCE$TIME_STAMPS_DIFFER_FOR_DECK
INCLUDE_DECK D=SCE$TIME_STAMPS_DIFFER_FOR_FILE
INCLUDE_DECK D=SCE$TOO_MANY_ALTERNATE_BASES
INCLUDE_DECK D=SCE$TOO_MANY_BLOCK_LEVELS
INCLUDE_DECK D=SCE$TOO_MANY_CROSS_REFS
INCLUDE_DECK D=SCE$TOO_MANY_IF_LEVELS
INCLUDE_DECK D=SCE$TYPE_NOT_EXTRACTED
INCLUDE_DECK D=SCE$UNEXPECTED_DIRECTIVE
INCLUDE_DECK D=SCE$UNKNOWN_DECK_NAME
INCLUDE_DECK D=SCE$UNKNOWN_DECK_NAME_AT_LINE
INCLUDE_DECK D=SCE$UNKNOWN_FEATURE_NAME
INCLUDE_DECK D=SCE$UNKNOWN_GROUP_NAME
INCLUDE_DECK D=SCE$UNKNOWN_LIBRARY_NAME
INCLUDE_DECK D=SCE$UNKNOWN_MOD_NAME
INCLUDE_DECK D=SCE$WARNINGS_DURING_COMMAND
INCLUDE_DECK D=SCE$WARNINGS_DURING_DECK
INCLUDE_DECK D=SCE$WARNINGS_INCLUDE_INTERLOCK
INCLUDE_DECK D=SCE$WARNING_MERGING_DIRECTORIES
INCLUDE_DECK D=SCE$WARNING_MERGING_MOD_LISTS
INCLUDE_DECK D=SCE$WARNING_MOD_HEADERS_DIFFER
INCLUDE_DECK D=SCE$WARNING_UNKNOWN_DECK_NAME
INCLUDE_DECK D=SCH$ANALYZE_DECK_DEPENDENCIES
INCLUDE_DECK D=SCH$BEGIN_UTILITY
INCLUDE_DECK D=SCH$CHANGE_DECK_ATTRIBUTES
INCLUDE_DECK D=SCH$CHANGE_LIBRARY_ATTRIBUTES
INCLUDE_DECK D=SCH$CHANGE_MOD_ATTRIBUTES
INCLUDE_DECK D=SCH$COMBINE_LIBRARY
INCLUDE_DECK D=SCH$CREATE_DECK
INCLUDE_DECK D=SCH$CREATE_LIBRARY
INCLUDE_DECK D=SCH$CREATE_MODIFICATION
INCLUDE_DECK D=SCH$DELETE_DECK
INCLUDE_DECK D=SCH$DELETE_MODIFICATION
INCLUDE_DECK D=SCH$EDIT_DECK
INCLUDE_DECK D=SCH$EDIT_FILE
INCLUDE_DECK D=SCH$END
INCLUDE_DECK D=SCH$END_LIBRARY
INCLUDE_DECK D=SCH$END_UTILITY
INCLUDE_DECK D=SCH$EXPAND_DECK
INCLUDE_DECK D=SCH$EXPAND_FILE
INCLUDE_DECK D=SCH$EXTRACT_SOURCE_LIBRARY
INCLUDE_DECK D=SCH$FIND_DECK
INCLUDE_DECK D=SCH$FIND_MODIFICATION
INCLUDE_DECK D=SCH$GET_COMBINED_DECK_LIST
INCLUDE_DECK D=SCH$GET_COMBINED_FEATURE_LIST
INCLUDE_DECK D=SCH$GET_COMBINED_GROUP_LIST
INCLUDE_DECK D=SCH$GET_COMBINED_MOD_LIST
INCLUDE_DECK D=SCH$GET_DECK_ATTRIBUTES
INCLUDE_DECK D=SCH$GET_LIBRARIES
INCLUDE_DECK D=SCH$GET_LIBRARY_ATTRIBUTES
INCLUDE_DECK D=SCH$GET_LIST_OPTIONS
INCLUDE_DECK D=SCH$GET_MOD_ATTRIBUTES
INCLUDE_DECK D=SCH$LIBRARY_MODIFIED
INCLUDE_DECK D=SCH$LIST_SELECTED_DECKS
INCLUDE_DECK D=SCH$REGENERATE_SOURCE
INCLUDE_DECK D=SCH$SET_LIST_OPTIONS
INCLUDE_DECK D=SCH$SOURCE_CODE_UTILITY
INCLUDE_DECK D=SCH$UNPACK_OST$DATE_TIME
INCLUDE_DECK D=SCH$USE_LIBRARY
INCLUDE_DECK D=SCH$WRITE_LIBRARY
INCLUDE_DECK D=SCP$ANALYZE_DECK_DEPENDENCIES
INCLUDE_DECK D=SCP$BEGIN_UTILITY
INCLUDE_DECK D=SCP$CHANGE_DECK_ATTRIBUTES
INCLUDE_DECK D=SCP$CHANGE_LIBRARY_ATTRIBUTES
INCLUDE_DECK D=SCP$CHANGE_MOD_ATTRIBUTES
INCLUDE_DECK D=SCP$COMBINE_LIBRARY
INCLUDE_DECK D=SCP$CREATE_DECK
INCLUDE_DECK D=SCP$CREATE_LIBRARY
INCLUDE_DECK D=SCP$CREATE_MODIFICATION
INCLUDE_DECK D=SCP$DELETE_DECK
INCLUDE_DECK D=SCP$DELETE_MODIFICATION
INCLUDE_DECK D=SCP$EDIT_DECK
INCLUDE_DECK D=SCP$EDIT_FILE
INCLUDE_DECK D=SCP$END
INCLUDE_DECK D=SCP$END_LIBRARY
INCLUDE_DECK D=SCP$END_UTILITY
INCLUDE_DECK D=SCP$EXPAND_DECK
INCLUDE_DECK D=SCP$EXPAND_FILE
INCLUDE_DECK D=SCP$EXTRACT_LIBRARY_PROGRAM
INCLUDE_DECK D=SCP$EXTRACT_SOURCE_LIBRARY
INCLUDE_DECK D=SCP$FIND_DECK
INCLUDE_DECK D=SCP$FIND_MODIFICATION
INCLUDE_DECK D=SCP$GET_COMBINED_DECK_LIST
INCLUDE_DECK D=SCP$GET_COMBINED_FEATURE_LIST
INCLUDE_DECK D=SCP$GET_COMBINED_GROUP_LIST
INCLUDE_DECK D=SCP$GET_COMBINED_MOD_LIST
INCLUDE_DECK D=SCP$GET_DECK_ATTRIBUTES
INCLUDE_DECK D=SCP$GET_LIBRARIES
INCLUDE_DECK D=SCP$GET_LIBRARY_ATTRIBUTES
INCLUDE_DECK D=SCP$GET_LIST_OPTIONS
INCLUDE_DECK D=SCP$GET_MOD_ATTRIBUTES
INCLUDE_DECK D=SCP$LIBRARY_MODIFIED
INCLUDE_DECK D=SCP$LIST_SELECTED_DECKS
INCLUDE_DECK D=SCP$REGENERATE_SOURCE
INCLUDE_DECK D=SCP$SET_LIST_OPTIONS
INCLUDE_DECK D=SCP$SOURCE_CODE_UTILITY
INCLUDE_DECK D=SCP$UNPACK_OST$DATE_TIME
INCLUDE_DECK D=SCP$USE_LIBRARY
INCLUDE_DECK D=SCP$WRITE_LIBRARY
INCLUDE_DECK D=SCT$AUTHOR
INCLUDE_DECK D=SCT$DATE
INCLUDE_DECK D=SCT$DATE_TIME
INCLUDE_DECK D=SCT$DEBUG_AID
INCLUDE_DECK D=SCT$DEBUG_AIDS_SET
INCLUDE_DECK D=SCT$DECK_ANALYSIS_ENTRY
INCLUDE_DECK D=SCT$DECK_ATTRIBUTE
INCLUDE_DECK D=SCT$DECK_ATTRIBUTES
INCLUDE_DECK D=SCT$DECK_ATTRIBUTE_INDEX
INCLUDE_DECK D=SCT$DECK_ATTRIBUTE_KEY
INCLUDE_DECK D=SCT$DECK_GROUP_LIST
INCLUDE_DECK D=SCT$DECK_INDEX
INCLUDE_DECK D=SCT$DECK_INTERLOCK_DATA
INCLUDE_DECK D=SCT$DECK_LIST
INCLUDE_DECK D=SCT$DECK_MOD_ENTRY
INCLUDE_DECK D=SCT$DECK_MOD_LIST
INCLUDE_DECK D=SCT$DECK_PROCESSOR
INCLUDE_DECK D=SCT$DESCRIPTION
INCLUDE_DECK D=SCT$EXPAND_ATTRIBUTE
INCLUDE_DECK D=SCT$EXPAND_ATTRIBUTES
INCLUDE_DECK D=SCT$EXPAND_ATTRIBUTE_KEY
INCLUDE_DECK D=SCT$EXPAND_REQUIREMENT
INCLUDE_DECK D=SCT$FEATURE_INDEX
INCLUDE_DECK D=SCT$FEATURE_LIST
INCLUDE_DECK D=SCT$GENERATED_LINE_INFO
INCLUDE_DECK D=SCT$GROUP_LIST
INCLUDE_DECK D=SCT$INTERLOCK_NAME
INCLUDE_DECK D=SCT$LIBRARY_ATTRIBUTE
INCLUDE_DECK D=SCT$LIBRARY_ATTRIBUTES
INCLUDE_DECK D=SCT$LIBRARY_ATTRIBUTE_KEY
INCLUDE_DECK D=SCT$LIBRARY_GROUP_INDEX
INCLUDE_DECK D=SCT$LIBRARY_INDEX_NODE
INCLUDE_DECK D=SCT$LIBRARY_LISTS
INCLUDE_DECK D=SCT$LIBRARY_LIST_INDEX
INCLUDE_DECK D=SCT$LIBRARY_MOD_INDEX
INCLUDE_DECK D=SCT$LIBRARY_VERSION
INCLUDE_DECK D=SCT$LINE_DESCRIPTOR_INDEX
INCLUDE_DECK D=SCT$LINE_IDENTIFIER_DISPOSITION
INCLUDE_DECK D=SCT$LINE_LENGTH
INCLUDE_DECK D=SCT$MODIFICATION_ATTRIBUTE
INCLUDE_DECK D=SCT$MODIFICATION_ATTRIBUTES
INCLUDE_DECK D=SCT$MODIFICATION_LIST
INCLUDE_DECK D=SCT$MOD_ATTRIBUTE_INDEX
INCLUDE_DECK D=SCT$MOD_ATTRIBUTE_KEY
INCLUDE_DECK D=SCT$MOD_NAME
INCLUDE_DECK D=SCT$NAME
INCLUDE_DECK D=SCT$OBJECT_DESCRIPTION
INCLUDE_DECK D=SCT$OBJECT_FAILURE
INCLUDE_DECK D=SCT$OBJECT_KIND
INCLUDE_DECK D=SCT$OBJECT_LIST_ENTRY
INCLUDE_DECK D=SCT$OBJECT_NEAREST_RESIDENCE
INCLUDE_DECK D=SCT$OBJECT_RESIDENCE
INCLUDE_DECK D=SCT$REGENERATED_LINE_INFO
INCLUDE_DECK D=SCT$REGENERATED_SOURCE
INCLUDE_DECK D=SCT$SELECTED_DECKS
INCLUDE_DECK D=SCT$SELECTED_DECKS_FORMAT
INCLUDE_DECK D=SCT$SEQUENCE_NUMBER
INCLUDE_DECK D=SCT$SOURCE_INFO_SEQUENCE
INCLUDE_DECK D=SCT$SOURCE_TEXT_SEQUENCE
INCLUDE_DECK D=SCT$STATE
INCLUDE_DECK D=SCT$TIME
INCLUDE_DECK D=SCT$UTILITY_PROMPT
INCLUDE_DECK D=SFH$ACTIVATE_JOB_STATISTIC
INCLUDE_DECK D=SFH$ACTIVATE_SYSTEM_STATISTIC
INCLUDE_DECK D=SFH$DEACTIVATE_JOB_STATISTIC
INCLUDE_DECK D=SFH$DEACTIVATE_SYSTEM_STATISTIC
INCLUDE_DECK D=SFH$GET_ACTIVE_JOB_STATISTICS
INCLUDE_DECK D=SFH$GET_ACTIVE_SYSTEM_STATS
INCLUDE_DECK D=SFH$GET_LOG_NAME
INCLUDE_DECK D=SFP$ACTIVATE_JOB_STATISTIC
INCLUDE_DECK D=SFP$ACTIVATE_SYSTEM_STATISTIC
INCLUDE_DECK D=SFP$DEACTIVATE_JOB_STATISTIC
INCLUDE_DECK D=SFP$DEACTIVATE_SYSTEM_STATISTIC
INCLUDE_DECK D=SFP$GET_ACTIVE_JOB_STATISTICS
INCLUDE_DECK D=SFP$GET_ACTIVE_SYSTEM_STATS
INCLUDE_DECK D=SFP$GET_LOG_NAME
INCLUDE_DECK D=SYH$ADVISED_MOVE_BYTES
INCLUDE_DECK D=SYH$GET_SYSTEM_TASK_STATUS
INCLUDE_DECK D=SYH$WAIT_SYSTEM_RESUME
INCLUDE_DECK D=SYP$ADVISED_MOVE_BYTES
INCLUDE_DECK D=SYP$GET_SYSTEM_TASK_STATUS
INCLUDE_DECK D=SYP$WAIT_SYSTEM_RESUME
INCLUDE_DECK D=SYT$MONITOR_STATUS
INCLUDE_DECK D=SYT$PERF_KEYPOINTS_ENABLED
INCLUDE_DECK D=SYT$SYSTEM_TASK_STATUS
INCLUDE_DECK D=UOE$CREDC_CONDITION_CODES
INCLUDE_DECK D=UOH$CREATE_DEVICE_CONNECTION
INCLUDE_DECK D=UOP$CREATE_DEVICE_CONNECTION
*DECK DECK=RAF$SYSTEM_CORE_LINKER_COMMANDS EXPAND=FALSE
      set_link_options link_map=$fname(map_file_string//'.$eoi') ..
            starting_segment=13 build_level=version_id ..
            exchange_package_variable=jmv$jmtr_xcb ..
            create_only_predefined_segments=true ..
            cybil_parameter_checking=source

      initialize_build_level name=osv$os_defaults_os_name
      initialize_heap_pointer osv$mainframe_pageable_heap ..
        segment_number=pageable_segment
      initialize_heap_pointer osv$job_fixed_heap segment_number=3
      initialize_heap_pointer nav$network_paged_heap segment_number=21

      add_object_file $fname(ol_system_core_113) ring_brackets=(1, 1, 3) ..
        global_local_key=(0, 0) execute_privilege=local default_sections=(..
        (re_113, r, e), (rb_xxx, r, b), (re_113, r), (rw_113, r, w))
      add_object_file $fname(ol_system_core_133) ring_brackets=(1, 3, 3) ..
        global_local_key=(0, 0) execute_privilege=local default_sections=(..
        (re_13x, r, e), (rb_xxx, r, b), (re_13x, r), (rw_13x, r, w))
      add_object_file $fname(ol_system_core_13d) ring_brackets=(1, 3, 13) ..
        global_local_key=(0, 0) execute_privilege=local default_sections=(..
        (re_13x, r, e), (rb_xxx, r, b), (re_13x, r), (rw_13x, r, w))
      add_object_file $fname(ol_system_core_1dd) ring_brackets=(1, 13, 13) ..
        global_local_key=(0, 0) execute_privilege=local default_sections=(..
        (re_1dd, r, e), (rb_xxx, r, b), (re_1dd, r) (rw_1dd, r, w))

      " The following defines a segment common between mtr and job.
      " It is defined and mtr and is just reserved here (it is a dummy)
      define_segment attributes=(ex) ring_brackets=(1, 3, 3) ..
        number=12(16)
      define_segment attributes=(rd, wt) ring_brackets=(1, 3, 3) ..
        number=pageable_segment section_names=(rw_113,oss$mainframe_pageable,..
        oss$job_pageable) global_local_key=(0, 0)
      define_segment attributes=(rd, wt, cb) ring_brackets=(1, 3, 3) number=3 ..
        section_name=(oss$job_fixed) global_local_key=(0, 0)
      define_segment attributes=(bi) ring_brackets=(1,13,13) number=0e(16) ..
        section_names=(rb_xxx) global_local_key=(0,0)
      define_segment attributes=(rd, lp) ring_brackets=(1, 13, 13) number=20 ..
        section_names=(re_1dd, cys$run_time_space, readonly, ..
        oss$mainframe_paged_literal, r_1dd, re_1dd , rw_1dd ) global_local_key=(0,0)
      define_segment attributes=(rd, lp) ring_brackets=(1, 1, 3) number=13 ..
        section_name=(re_113) global_local_key=(0,0)
      define_segment attributes=(rd, lp) ring_brackets=(1, 3, 3) number=19 ..
        section_name=(re_13x) global_local_key=(0,0)
      define_segment attributes=(rd, wt) ring_brackets=(3, 3, 3) number=21 ..
        section_name=(oss$network_paged) global_local_key=(0,0)
      define_segment attributes=(rd wt et) ring_brackets=(1, 1, 1) number=0f(16) ..
        section_name=(jstack1) global_local_key=(0,0)
      define_segment attributes=(rd wt et) ring_brackets=(1, 1, 1) number=10(16) ..
        section_name=(jstack2) global_local_key=(0,0)
      define_segment attributes=(rd wt et) ring_brackets=(1, 1, 1) number=11(16) ..
        section_name=(jstack3) global_local_key=(0,0)
      define_segment attributes=(rd wt) ring_brackets=(1, 1, 1) number=16(16) ..
        section_name=(mls$mem_link) global_local_key=(0,0)
      define_segment attributes=(rd) ring_brackets=(13, 13, 13) number=17(16) ..
        section_name=(mlsreadl) global_local_key=(0,0)

      use_symbol_table $fname(monitor_symbols_string)
      set_symbol_table_id $fname(monitor_symbols_string)
      use_debug_table $fname(monitor_debug_table)
      generate_virtual_memory $fname(system_virtual_memory_string) ..
        symbol_table=$fname(system_symbols_string) ..
        debug_table=$fname(system_core_debug_table)
*DECK DECK=RAH$ADD_APPLIER EXPAND=FALSE
{}
{     The purpose of this request is to add an APPLIER to
{ the specified CORRECTION_PACKAGE.  If the CORRECTION_PACKAGE
{ already has an applier the specified APPLIER is not added.
{}
{        RAP$ADD_APPLIER (PARAMETER_LIST, STATUS)
{}
{ PARAMETER_LIST: (input) This parameter specifies a list of parameters for
{        the ADD_APPLIER subcommand.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$ADD_CORRECTION EXPAND=FALSE
{}
{   The purpose of this request is to add a correction package or
{ elements of a correction package that were previously built to the
{ current correction package.
{}
{      RAP$ADD_CORRECTION (PARAMETER_LIST, STATUS)
{}
{ PARAMETER_LIST: (input) This parameter specifies the list of parameters
{       given on the call from the utility.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$ADD_PSRS EXPAND=FALSE
{}
{   The purpose of this request is to add a list of psrs to corrections
{ in the correction package.  The list is on a file whose name is passed
{ to this processor by the user.
{}
{      RAP$ADD_PSRS (PARAMETER_LIST, STATUS)
{}
{ PARAMETER_LIST: (input) This parameter specifies the list of parameters
{       given on the call from the utility.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$ALLOWABLE_CATALOG EXPAND=FALSE
{}
{   The purpose of this request is to determine whether or not a user supplied
{ catalog can be used to install files to.  The specified catalog must not have been
{ defined before the current upgrade session and must be allowed to be created by
{ the utility.  When the user specifies a catalog and it is undefined the path name
{ is placed in a list  and the function returns true.  If on the other hand the catalog
{ turns out to be defined the list is checked to see if the catalog is allowable.
{}
{       RAP$ALLOWABLE_CATALOG (FUNCTION_NAME, ARGUMENT_LIST, VALUE, STATUS)
{}
{FUNCTION_NAME: (input) This parameter specifies the the function associated with
{       this procedure.
{}
{ARGUMENT_LIST: (input) This parameter specifies a sequence that holds the user
{       entered parameter values.
{}
{VALUE: (output) This parameter specifies the record where the function values
{       are stored.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$APPLY_CORRECTION EXPAND=FALSE
{}
{   The purpose of this request is to apply a single correction to
{ update an object library, source library, scl proc or NOS user library
{ and to set the user information attribute in the new file.
{}
{      RAP$APPLY_CORRECTION (PARAMETER_LIST, STATUS)
{}
{ PARAMETER_LIST: (input) This parameter specifies the list of paramters given
{       on the call to this procedure.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$ASSEMBLE_RELEASE_MATERIALS EXPAND=FALSE
""
"   The purpose of this command is to copy all files pointed to by    "
" the INSTALLATION TABLE into the INSTALLATION CATALOG. On completion "
" of the copy, the installation catalog is backed up to the (disk)    "
" file specified as a parameter.                                      "
""
"       rap$assemble_release_materials(installation_table,..          "
"         backup_file, status)                                        "
""
" installation_table, it : (input) This parameter specifies the path  "
"       to the installation table to be used. It is passed to the     "
"       set_installation_table command.                               "
""
" backup_file, bf : (input) This parameter specifies the path to the  "
"       final output backup file for the command.                     "
""
" status : (output) This parameter is the command return status.      "
""

*DECK DECK=RAH$ATTACH_INSTALLATION_TABLE EXPAND=FALSE
{}
{   The purpose of this request is to attach the installation table for opening.
{ This attach is for read only access.
{}
{       RAP$ATTACH_INSTALLATION_TABLE (TABLE_FILE, STATUS)
{}
{TABLE_FILE: (output) This parameter specifies the local file name by which
{       the installation table is known.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$BASE EXPAND=FALSE
{}
{   The purpose of this request is to return the value of the root catalog
{ that the system is running on.  This was determined by the $blitz parameter
{ when entering the utility.  The value is returned as a string.
{}
{       RAP$BASE (FUNCTION_NAME, ARGUMENT_LIST, VALUE, STATUS)
{}
{FUNCTION_NAME: (input) This parameter specifies the the function associated with
{       this procedure.
{}
{ARGUMENT_LIST: (input) This parameter specifies a sequence that holds the user
{       entered parameter values.
{}
{VALUE: (output) This parameter specifies the record where the function values
{       are stored.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$BIN_SEARCH EXPAND=FALSE
{}
{   The purpose of this request is to search an array of source library
{ deck names for a deck and to return the index in the array of that deck
{ if it is found.
{}
{      RAP$BIN_SEARCH (NAME, NEW_ARRAY, J, FOUND)
{}
{ NAME: (input) This parameter specifies the deck name to search for.
{}
{ NEW_ARRAY: (input) This parameter specifies an array containing deck names
{        from the new source library and an index which specifies a matching
{        deck name from the old source library.
{}
{ J: (input - output) This parameter specifies an index into the new array.
{        It specifies the lowerbound to begin searching in the array, and if
{        found, the location of the matching entry.
{}
{ FOUND: (output) This parameter specifies whether or not NAME is found in
{        NEW_ARRAY.
{}

*DECK DECK=RAH$BUILD_ELEMENT_LIST EXPAND=FALSE
{}
{   The purpose of this request is to build a list of elements from
{ the NAME parameter.  IF NAME specifies 'ALL' ELEMENT_LIST will contain
{ all the elements in the installation table.  IF NAME specifies 'OS'
{ all elements in the installation table that have class rac$os will be
{ added to ELEMENT_LIST.  IF NAME contains a single element that element
{ will be added to ELEMENT_LIST.  No element may appear more than once.
{}
{      RAP$BUILD_ELEMENT_LIST (TABLE, NAME, ELEMENT_LIST, LAST, STATUS)
{}
{ TABLE: (input) This parameter specifies a pointer to the installation table.
{}
{ NAME: (input) This parameter specifies which element(s) to add to the list.
{}
{ ELEMENT_LIST: (input - output) This parameter specifies a list of elements in
{       the installation table.
{}
{ LAST: (input - output) This parameter specifies where the last element is in
{       the list.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}
*DECK DECK=RAH$BUILD_INSTALLATION_TABLE EXPAND=FALSE
{}
{   The purpose of this request is to add a new file with it's installation
{ attributes to the installation table.  If it is an initialize request then
{ the table is overwritten and the file appears as the only entry.
{}
{       RAP$BUILD_INSTALLATION_TABLE (PARAMETER_LIST, STATUS)
{}
{PARAMETER_LIST: (input) This parameter specifies a sequence that holds the user
{       entered parameter values.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$BUILD_REPLACEMENT_SL EXPAND=FALSE
{}
{   The purpose of this request is to build a replacement source library
{ from the version of the source library supplied which will contain all the
{ decks that must be inserted or replaced.
{}
{      RAP$BUILD_REPLACEMENT_SL (SOURCE_FILE, DECKS_OK, REPLACE_SL, STATUS)
{}
{ SOURCE_FILE: (input) This parameter specifies a record that contains
{       file values for the source library.
{}
{ DECKS_OK: (input) This parameter specifies an array of decks names that are
{       unchanged between the old and new versions of the source libraries.
{}
{ REPLACE_SL: (input) This parameter specifies the name of the source library
{       that will contain decks to insert and replace.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$CATALOG_170_FILE EXPAND=FALSE

{   This procedure provides a catalog function for a CYBER 170 file which
{ is stored on NOS/VE. The file must have been moved to NOS/VE by the
{ GET_MULTI_RECORD_FILE utility. The list output produced is an emulation
{ of the output of the NOS GENCAT utility.
{}
{       PROCEDURE RAP$CATALOG_170_FILE(FILE,LIST,LIST_OPTION,USER_LIBRARY,STATUS)
{}
{ FILE: (input) This parameter passes the reference for the file to be cataloged.
{}
{ LIST: (output) This parameter passes the reference for the list output file
{       to be produced. If not supplied the parameter defaults to $LIST.
{}
{ LIST_OPTION: (input) This parameter specifies the type of list output to be
{       produced. The detailed description may be found in the documentation
{       with the NOS GENCAT command. If not supplied it defaults to LONG.
{}
{ USER_LIBRARY: (input) This parameter specifies whether user libraries found
{       are to be expanded (TRUE) or not (FALSE). If not supplied it defaults
{       to FALSE.
{}

*DECK DECK=RAH$CATALOG_FILES_LIST EXPAND=FALSE
{}
{   The purpose of this request is to return an array of file names under the
{ specified catalog.  The files listed are only those of the immediate catalog and
{ not from any subcatalogs found within the specified catalog.
{}
{       RAP$CATALOG_FILES_LIST (FUNCTION_NAME, ARGUMENT_LIST, VALUE, STATUS)
{}
{FUNCTION_NAME: (input) This parameter specifies the the function associated with
{       this procedure.
{}
{ARGUMENT_LIST: (input) This parameter specifies a sequence that holds the user
{       entered parameter values.
{}
{VALUE: (output) This parameter specifies the record where the function values
{       are stored.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$CHANGE_INSTALLATION_TABLE EXPAND=FALSE
{}
{   The purpose of this request is to change the specified attribute value
{ either in the header or in a specified table entry.  The attribute must
{ match up with that that the change takes place in.  For the header the
{ attributes are TITLE, BUILD_LEVEL, NUMBER_OF_FILES and TABLE_VIOLATION.
{ For a table entry they are NAME, KNOWN, PUBLIC, RING, FORMAT, CLASS, PATH
{ and INTVE_PATH.
{}
{       RAP$CHANGE_INSTALLATION_TABLE (PARAMETER_LIST, STATUS)
{}
{PARAMETER_LIST: (input) This parameter specifies a sequence that holds the user
{       entered parameter values.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$COMPARE_170_FILES EXPAND=FALSE

{   This proceure provides a simple command interface for the generate_170_modset
{ procedure. This interface may be used to run the procedure in standalone mode
{ or as an example of the call interface.
{
{       PROCEDURE RAP$COMPARE_170_FILES(INITIAL_FILE,UPDATED_FILE,REPLACEMENT_FILE,
{                                       DIRECTIVE_FILE,STATUS)
{}
{ INITIAL_FILE: (input) This parameter specifies the original file reference.
{}
{ UPDATED_FILE: (input) This parameter specifies the updated file reference.
{}
{ REPLACEMENT_FILE: (input) This parameter specifies the reference for the file
{       which will receive a copy of all the records which differ on the master
{       files.
{}
{ DIRECTIVE_FILE: (input) This parameter specifies the reference for the file
{       which will receive the LIBEDIT directives required for the 170 update run.
{}
{ STATUS: (output) Status return parameter.
{}

*DECK DECK=RAH$COMPARE_SL_DECKS EXPAND=FALSE
{}
{   The purpose of this request is to compare decks in the old and new
{ versions of the source libraries.  Deck headers are checked first, then
{ the deck contents.
{}
{      RAP$COMPARE_SL_DECKS (NAME, OLD_PATH, OLD_PATH_LENGTH, NEW_PATH,
{        NEW_PATH_LENGTH, DECKS_DONT_DIFFER, STATUS)
{}
{ NAME: (input) This parameter specifies the deck name being compared.
{}
{ OLD_PATH: (input) This parameter specifies the path name of the new
{       source library.
{}
{ OLD_PATH_LENGTH: (input) This parameter specifies the number of characters
{       in the old path name.
{}
{ NEW_PATH: (input) This parameter specifies the path name of the new
{       source library.
{}
{ NEW_PATH_LENGTH: (input) This parameter specifies the number of characters
{       in the path name.
{}
{ DECKS_DONT_DIFFER: (output) This parameter specifies whether the decks differ
{       or not.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$CONVERT_STATUS EXPAND=FALSE
{}
{     The purpose of this request is to convert from clt$status to ost$status.
{}
{        RAP$CONVERT_STATUS (CLV$STATUS, OSV$STATUS)
{}
{CLV$STATUS: (input) This parameter specifies the clt$status record.
{}
{OSV$STATUS: (ouput) This parameter specifies the ost$status record.
{}
*DECK DECK=RAH$COPY_FROM_JOB_LOG EXPAND=FALSE
{}
{   The purpose of this request is to copy a portion of the job log into an
{ output file specified by an identifier.  The portion copied is defined as the
{ current upgrade session's log and starts with call to utility command.
{}
{       RAP$COPY_FROM_JOB_LOG (OUTPUT_ID, STATUS)
{}
{OUTPUT_ID: (input) This parameter specifies the local file identifier that the
{       job log gets copied to.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$COPY_PARTITION EXPAND=FALSE
{}
{     The purpose of this request is to copy from the current file position
{ to the next end-of-partition marker or end-of-information.  Special
{ handling must be done during the first copy to the output file and when
{ copying from the first record of the input file.  This information is
{ supplied to copy_partition through the two booleans described below.
{     If errors are found the file positions are to be considered undefined.
{}
{        RAP$COPY_PARTITION (INPUT_FID, OUTPUT_FID, FILE_POSITION,
{                            STARTING_INPUT_RECORD, STARTING_OUTPUT_RECORD, STATUS)
{}
{INPUT_FID: (input) This parameter specifies the id of the input file.
{}
{OUTPUT_FID: (input) This parameter specifies the id of the output file.
{}
{FILE_POSITION: (input,output) This parameter specifies the file position
{        of the input file.
{}
{STARTING_INPUT_RECORD: (input) This parameter specifies if the input file
{        is opened to the first record for this call to copy_partition.
{}
{STARTING_OUTPUT_RECORD: (input) This parameter specifies whether this will
{        be the first record written to the output file.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$CORRECT_ISAM_FILE EXPAND=FALSE
{}
{     The purpose of this request is to apply a correction to an indexed
{ sequential file.
{}
{        RAP$CORRECT_ISAM_FILE (TARGET_FILE, CORRECTION, STATUS)
{}
{ TARGET_FILE: (input) This parameter specifies the name of the file that
{        will contain the corrected indexed sequential file.
{}
{ CORRECTION: (input - output) This parameter specifies the correction
{        to be applied.
{}
{ STATUS: (output) This parameter specifies any resulting error.
{}
*DECK DECK=RAH$CORRECT_SOURCE_LIBRARY EXPAND=FALSE
{}
{   The purpose of this request is to build an upgraded version of
{ a source library using the old version and the correction.
{}
{      RAP$CORRECT_SOURCE_LIBRARY (BASE_FILE, TARGET_FILE, CORRECTION, STATUS)
{}
{ BASE_FILE: (input) This parameter specifies the file that contains the old
{       version of the source library.
{}
{ TARGET_FILE: (input) This parameter specifies the file that will contain the
{       new version of the source library.
{}
{ CORRECTION: (input) This parameter specifies a sequence containing information
{       to enable updating the old source library to the new one.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$CORRECT_V_OR_U_RECORD_FILE EXPAND=FALSE
{}
{   The purpose of this request is to write a new version of either a variable
{ or undefined record file.  The CORRECTION contains a complete file replacement
{ that is written to the TARGET file.  The BASE file is interrogated and key
{ file attributes are passed on to the TARGET file.
{}
{      RAH$CORRECT_V_OR_U_RECORD_FILE (BASE, TARGET, CORRECTION, RECORD_TYPE, STATUS)
{}
{ BASE: (input) This parameter specifies the old version file that is interrogated
{       for key file attributes to be passed on to the new version file.
{}
{ TARGET: (input) This parameter specifies the file that the new version file is
{       written to.
{}
{ CORRECTION: (input) This parameter specifies the replacement sequence.
{}
{ RECORD_TYPE: (input) This parameter specifies the record type for the file.
{       (AMC$VARIABLE or AMC$UNDEFINED)
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$DELETE_TABLE_ENTRY EXPAND=FALSE
{}
{     The purpose of this request is to delete the specified file entry from the
{ given installation table.  The last entry in the table is copied over the entry
{ to be deleted and then the table is shorted by one entry.  Deletion from a
{ table with 1 entry is not allowed.
{}
{       RAP$DELETE_TABLE_ENTRY (PARAMETER_LIST, STATUS)
{}
{PARAMETER_LIST (input) This parameter specifies a sequence that holds the user
{       entered parameter values.
{}
{STATUS (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$DELPV EXPAND=FALSE
{}
{   The purpose of this request is to delete a previous version of a file.
{}
{       RAP$DELPV (PARAMETER_LIST, STATUS)
{}
{PARAMETER_LIST: (input) This parameter specifies the string that holds the
{       user supplied parameter values.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$DETERMINE_170_RECORD EXPAND=FALSE
{}
{   The purpose of this request is to analyse the initial portion of
{ a NOS logical record which is stored in a NOS/VE file, and return
{ the NOS record type and name. All NOS record types are recognised.
{   This routine is based upon the NOS routine SRT in COMCSRT.
{}
{       RAP$DETERMINE_170_RECORD(NOS_RECORD,RECORD_NAME,RECORD_TYPE)
{}
{NOS_RECORD: (input) This parameter provides the initial portion of
{       the NOS record for analysis.
{}
{RECORD_NAME: (output) This parameter returns the NOS record name.
{}
{RECORD_TYPE: (output) This parameter returns the NOS record type.
{}
*DECK DECK=RAH$DISPLAY_CORRECTIONS_COMMAND EXPAND=FALSE
{}
{      The purpose of this request is to display the correction package
{ specified to the output file given.
{}
{        RAP$DISPLAY_CORRECTIONS_COMMAND (PARAMETER_LIST, STATUS)
{}
{ PARAMETER_LIST: (input) This parameter specifies a list of parameters.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}


*DECK DECK=RAH$DISPLAY_CORRECTIONS_UPGS EXPAND=FALSE
{}
{      The purpose of this request is to display the correction package
{ specified to the output file given.
{
{ NOTE:  This is a copy of RAM$DISPLAY_CORRECTIONS_COMMAND with additional
{ code added to cause any OS or CDCNET class corrections to be displayed
{ by the class name.  This is intended for use in the  UPGRADE_SOFTWARE
{ utility until catalog support is implemented.  At that time the
{ program interface RAM$DISPLAY_CORRECTIONS_COMMAND will be used.
{}
{        RAP$DISPLAY_CORRECTIONS_UPGS (PARAMETER_LIST, STATUS)
{}
{ PARAMETER_LIST: (input) This parameter specifies a list of parameters.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}


*DECK DECK=RAH$DISPLAY_CURRENT_UPGRADE_LOG EXPAND=FALSE
{}
{   The purpose of this request is to display the current UPGRADE utility's session
{ log.  A unique session id is given to each UPGRADE SYSTEM utility call
{ and it is placed in the job log.  The session's log is the subset of the job
{ log from the session call to the end of the job log at time of this command call.
{}
{       RAP$DISPLAY_CURRENT_UPGRADE_LOG (PARAMETER_LIST, STATUS)
{}
{PARAMETER_LIST: (input) This parameter specifies a sequence that holds the user
{       entered parameter values.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$DISPLAY_FILE EXPAND=FALSE
{}
{   The purpose of this request is to display a file with page headers when
{ the file given as input is burstable.
{}
{       RAP$DISPLAY_FILE (PARAMETER_LIST, STATUS)
{}
{PARAMETER_LIST: (input) This parameter specifies a sequence that holds the user
{       entered parameter values.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$DISPLAY_HEADER EXPAND=FALSE
{}
{   The purpose of this request is to process the header attributes and version
{ from the installation table for display to an output file.
{}
{       RAP$DISPLAY_HEADER (VERSION, HEADER, DISPLAY_CONTROL, STATUS)
{}
{VERSION: (input) This parameter specifies the pointer to the version record.
{}
{HEADER: (input) This parameter specifies the pointer to the header in the
{       installation table.
{}
{DISPLAY_CONTROL: (input, output) This parameter specifies the record of control
{       variables for display.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$DISPLAY_INSTALLATION_TABLE EXPAND=FALSE
{}
{   The purpose of this request is to display the installation table.
{}
{       RAP$DISPLAY_INSTALLATION_TABLE (PARAMETER_LIST, STATUS)
{}
{PARAMETER_LIST: (input) This parameter specifieds a sequence that holds the
{       user entered parameter values.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$DISPLAY_MESSAGE_COMMAND EXPAND=FALSE
{
{    The purpose of this interface is to display a message that originated
{  from a message module to an output file.  In setting up messages to be
{  displayed from a message module, parameter prompt messages are used.
{  As many parameter prompt messages as are required can be placed into
{  the message module.  Modules can be setup according to subject or
{  processing phase.
{
{    SCL COMMAND INTERFACE:
{
{      rap$display_message (
{        message_module, mm     : name = $required
{        message_name, mn       : name = $required
{        message_parameters, mp : list 1..10 of string = $optional
{        margin, m              : integer 0..26 = $optional
{        to, t                  : file = $output
{        status                 : var of status = $optional
{        )
{
{    PARAMETERS:
{
{      MESSAGE_MODULE (MM)
{        Specifies the name of the help module that contains the
{        message template to be displayed.  This parameter is required.
{
{      MESSAGE_NAME (MN)
{        Specifies the name of the message in the module to be displayed.
{        This parameter is required.
{
{      MESSAGE_PARAMETERS (MP)
{        Optionally specifies the values to replace the parameters found
{        in the the message template to be displayed.  The
{        parameters in the templates are numbered for identification.
{        The first value in the MESSAGE_PARAMETERS list is associated with
{        the first parameter, the second value in the list is associated
{        with the second parameter, and so on.
{
{      MARGIN (M)
{        Optionally specifies the number of spaces to add to the beginning
{        of the message.  The default is to use a margin of 0.
{
{      TO (T)
{        Optionally specifies the file to where the message is displayed.
{        The default is $output.
{
{      STATUS
{        Optional status variable.
{        conditions:
{              rae$message_not_found
{              rae$module_access_error
{
*DECK DECK=RAH$DISPLAY_PATH EXPAND=FALSE
{}
{   The purpose of this request is to format a path name so that it will
{ fit on a rac$max_line_size for display purposes.
{}
{       RAP$DISPLAY_PATH (PATH, LINE, DISPLAY_CONTROL, STATUS)
{}
{PATH: (input) This parameter specifies the path name that is to be formated
{       and displayed.
{}
{LEAD_LINE: (input) This parameter specifies a string that holds a statement about
{       the path.  This statement will be included in the display.
{}
{DISPLAY_CONTROL: (input, output) This parameter specifies the record of control
{       variables for display.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$DISPLAY_PSRS EXPAND=FALSE
{}
{      The purpose of this request is to format and display the psrs
{ found in the PSR_LIST.  This request is called by RAM$DISPLAY_CORRECTION_
{ COMMAND.
{}
{        RAP$DISPLAY_PSRS (DISPLAY_CONTROL, PSR_LIST, NUMBER_OF_PSRS, STATUS)
{}
{ DISPLAY_CONTROL: (input, output) This parameter supplies the display
{        control variables values.
{}
{ PSR_LIST: (input) This parameter is a pointer to an array of psr
{        identifiers to be displayed.
{}
{ NUMBER_OF_PSRS: (input) This parameter specifies the number of psrs in
{        the psr list.
{}
{ STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$DISPLAY_TABLE_ENTRY EXPAND=FALSE
{}
{   The purpose of this request is to the specified table entry with all it's
{ attribute values to the output file specified.
{}
{       RAP$DISPLAY_TABLE_ENTRY (TABLE, TABLE_INDEX, DISPLAY_CONTROL, SUPPRESS_DISPLAY, STATUS)
{}
{TABLE: (output) This parameter specifies the pointer to the table in the
{       installation table.
{}
{TABLE_INDEX: (input) This parameter specifies the index for the entry into the
{       installation table.
{}
{DISPLAY_CONTROL: (input, output) This parameter specifies the record of control
{       variables for display.
{}
{SUPPRESS_DISPLAY: (input) This parameter specifies a boolean that determines if the
{       integration path should be displayed or not.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$EXTERNALIZE_ACCESS_MODE EXPAND=FALSE
{}
{     The purpose of this request is to convert the internal access mode set into
{ an scl variable for external use.
{}
{        RAP$EXTERNALIZE_ACCESS_MODE (ACCESS_MODE, VALUE, STATUS)
{}
{ACCESS_MODE: (input) This parameter specifies the internal value set for access
{        selections.
{}
{VALUE: (output) This parameter specifies the returned value of one of the above
{        two parameters.
{}
{STATUS: (output) This parameter specifies any resulting error.
{}

*DECK DECK=RAH$EXTERNALIZE_SHARE_MODE EXPAND=FALSE
{}
{     The purpose of this request is to convert the internal share mode set into
{ an scl variable for external use.
{}
{        RAP$EXTERNALIZE_SHARE_MODE (SHARE_MODE, VALUE, STATUS)
{}
{SHARE_MODE: (input) This parameter specifies the internal value set for share
{        selections.
{}
{VALUE: (output) This parameter specifies the returned value of one of the above
{        two parameters.
{}
{STATUS: (output) This parameter specifies any resulting error.
{}

*DECK DECK=RAH$EXTRACT_CORRECTION EXPAND=FALSE
{}
{   The purpose of this request is to extract a single correction from
{ the correction package.
{}
{      RAP$EXTRACT_CORRECTION (PARAMETER_LIST, STATUS)
{}
{ PARAMETER_LIST: (input) This parameter specifies a list of parameters.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$GENERATE_170_MODSET EXPAND=FALSE
{   This procedure compares two Cyber 170 files held in NOS/VE format
{ and generates a difference file and a LIBEDIT input directive file
{ which will enable LIBEDIT to transform the old file to the new file.
{ The difference file operates on a Cyber 170 logical record basis.
{   The files to be compared are subject to certain constraints as documented
{ here. The first constraints concern each file in isolation and are designed
{ to ensure that the generated LIBEDIT directives are meaningful.
{
{  1) The file is a simple multi-record file with no ulib or opld records.
{  2) The file is a multi-record file with a single trailing opld record.
{  3) The file is a single user library with a leading ulib record and a
{     trailing opld record of the same name.
{
{   In addition to these basic file structure constraints certain file
{ dependancy constraints are enforced between the two files. These constraints
{ are designed to enable the program to ensure that the comparasin will
{ yield meaningful results, and that the following LIBEDIT run will be able
{ to perform the required transformation.
{
{  1) If the old file is a user library file the new file must also be a
{     user library file of the same name.
{  2) If the old file is a multi-record file with a trailing opld record,
{     the new file must be of the same structure with the same name opld
{     record.
{}
{       PROCEDURE RAP$GENERATE_170_MODSET(OLD_LFN,OLD_NAME,NEW_LFN,NEW_NAME,LGO_LFN,
{                                         DIR_LFN,COMPARE_EQUAL,STATUS)
{}
{ OLD_LFN: (input) This parameter passes the file name for the old file.
{}
{ OLD_NAME: (input) This parameter passes the file path name for the old file.
{       This path name is used for error reporting if required.
{}
{ NEW_LFN: (input) This parameter passes the file name for the new file.
{}
{ NEW_NAME: (input) This parameter passes the file path name for the new file.
{       The path name is used for error reporting if required.
{}
{ LGO_LFN: (input) This parameter passes the file name for the differences file.
{}
{ DIR_LFN: (input) This parameter passes the file name for the LIBEDIT
{       directives file.
{}
{ COMPARE_EQUAL: (output) This is a boolean flag which returns the result of
{       the file compare.
{}
{ STATUS: (output) Status return parameter.
{}
*DECK DECK=RAH$GENERATE_CORRECTION EXPAND=FALSE
{}
{   The purpose of this request is to generate a correction package.
{ A correction package is built for each new element added.  The complete
{ package is then compressed and written to the file name given by the
{ user.
{}
{      RAP$GENERATE_CORRECTION (PARAMETER_LIST, STATUS)
{}
{ PARAMETER_LIST: (input) This parameter specifies the list of parameters
{       given on the call from the utility.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$GENERATE_ENTRY_LIST EXPAND=FALSE
{}
{   The purpose of this request is to generate a list of file names from the
{ installation_table that belong to either the specified class or product.
{ Class and product are specified by pointers to names, but only one
{ may be specified and the other must be set to nil.  This list is
{ returned as a array.
{}
{       RAP$GENERATE_ENTRY_LIST (CLASS, PRODUCT, TABLE, HEADER, VALUE, STATUS)
{}
{CLASS: (input) This parameter specifies the pointer to the class to be collected.
{}
{PRODUCT: (input) This parameter specifies the pointer to the product to be collected.
{}
{TABLE: (input) This parameter specifies the pointer to the table in the
{       installation table.
{}
{HEADER: (input) This parameter specifies the pointer to the header in the
{       installation table.
{}
{VALUE: (output) This parameter specifies the array that is returned.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$GENERATE_PRODUCT_TAPE EXPAND=FALSE
""
"   This procedure implements the generate_product_tape command. This  "
" command extracts the files comprising a single product from a master "
" backup file produced by assemble_release_materials and produces a    "
" (magnetic tape) backup file.                                         "
""
"       rap$generate_product_tape(                                     "
"         backup_file bf : file = $required                            "
"         product p : name = $required                                 "
"         external_vsn evsn : list of string 1..6 = $required          "
"         type t : key mt9$800 mt9$1600 mt9$6250 mt18$38000 = mt9$1600 "
"         status)             This parameter specifies a list of reel  "
"       names upon which the extracted product is to be written.       "
""backup_file bf : (input) This parameter specifies the master backup  "
" type t : (input) This parameter specifies the type of magnetic tape  "
"       which is to be created.                                        "
""product p : (input) This parameter specifies the name of the product "
"       to be extracted.                                               "
""
" external_vsn evsn : (input) This parameter specifies a list of reel  "
"       names for the magnetic tape file which is to contain the       "
"       extracted product.                                             "
""
" type t : (input) This parameter specifies the type of magnetic tape  "
"       file to be produced.                                           "
""
" status : (output) This parameter is the command return status.       "
""

*DECK DECK=RAH$GENERATE_SESSION_ID EXPAND=FALSE
{}
{   The purpose of this request is to generate a unique session id for this
{ particular utility call.  This id is then recorded in the job log to distinguish
{ between the various calls to the utility that may build up in the job log.
{}
{       RAP$GENERATE_SESSION_ID (SESSION_ID, STATUS)
{}
{SESSION_ID: (output) This parameter specifies the current sessions id value.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$GET_170_RECORD EXPAND=FALSE
{}
{     The purpose of this request is to do the boundary processing required to
{ access the start of a 170 record in a file. The 170 descriptor following a NOS/VE
{ end-of-partition is read and analysed and the resulting 170 file position
{ is returned in nos_fp.
{   The procedure assumes that the file is positioned at the beginning of a
{ NOS/VE partition containing a 170 record. If this is not the case an error
{ status will be returned.
{}
{        RAP$GET_170_RECORD (FID, FP, NOS_RECORD, NOS_FP, STATUS)
{}
{FID: (input) This parameter specifies the identifier of the 170 library.
{}
{FP: (input, output) This parameter specifies a pointer to the current file
{        position of the 170 library.
{}
{NOS_RECORD: (output) This parameter specifies the next record found on the library.
{}
{NOS_FP: (output) This parameter specifies a pointer to the next record's position.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$GET_ATTRIBUTE_VALUE EXPAND=FALSE
{}
{   The purpose of this request is to open the installation table and
{ retrieve the value for a specified attribute of a specified file entry.
{}
{       RAP$GET_ATTRIBUTE_VALUE (ATTRIBUTE, TABLE, INDEX, VALUE, STATUS)
{}
{ATTRIBUTE: (input) This parameter specifies the internal attribute name
{       for which the value is retrieved.
{}
{TABLE: (input) This parameter specifies the pointer to the table entries in the
{       installation table.
{}
{INDEX: (input) This parameter specifies the index into the table for the
{       specified file entry.
{}
{VALUE: (output) This parameter specifies the value returned.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$GET_CORRECTION_APPLIER EXPAND=FALSE
{}
{     The purpose of this request is to copy the APPLIER if present on
{ the CORRECTION_PACKAGE to the APPLIER file specified.  If there
{ is no APPLIER on the CORRECTION_PACKAGE bad status is returned.
{}
{        RAP$GET_CORRECTION_APPLIER (PARAMETER_LIST, STATUS);
{}
{ PARAMETER_LIST: (input) This parameter specifies the list of parameters
{        given on the call to this interface.
{}
{ STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$GET_CORRECTION_LIST EXPAND=FALSE
{}
{   The purpose of this request is to get a list of corrections from
{ the correction package.
{}
{      RAP$GET_CORRECTION_LIST (PARAMETER_LIST, STATUS)
{}
{ PARAMETER_LIST: (input) This parameter specifies a list of parameters.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$GET_CORRECTOR_ELEMENT EXPAND=FALSE
{}
{   The purpose of this request is to find an element in the installation
{ table.  The position in the table of elements in the corrector is returned.
{}
{      RAP$GET_CORRECTOR_ELEMENT (ELEMENT, K, STATUS)
{}
{ ELEMENT: (input) This parameter specifies the element to find in the current
{       correction package.
{}
{ K: (output) This parameter specifies the position in the table where the given
{       element was found.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$GET_DECKS EXPAND=FALSE
{}
{   The purpose of this request is to extract two decks, one from
{ the old version of the source library and one from the new one.
{}
{      RAP$GET_DECKS (NAME, OLD_PATH, OLD_PATH_LENGTH, NEW_PATH,
{        NEW_PATH_LENGTH, OLD_DECK, NEW_DECK, STATUS)
{}
{ NAME: (input) This parameter specifies the name of the deck to be
{       extracted.
{}
{ OLD_PATH: (input) This parameter specifies the path name of the old
{       source library.
{}
{ OLD_PATH_LENGTH: (input) This parameter specifies the number of
{       characters in the old path name.
{}
{ NEW_PATH: (input) This parameter specifies the path name of the new
{       source library.
{}
{ NEW_PATH_LENGTH: (input) This parameter specifies the number of
{       characters in the new path name.
{}
{ OLD_DECK: (output) This parameter specifies the file that contains
{       the source for the deck from the old source library.
{}
{ NEW_DECK: (output) This parameter specifies the file that contains
{       the source for the deck from the new source_library.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$GET_DECK_LIST EXPAND=FALSE
{}
{   The purpose of this request is to build a file containing all
{ deck names from a source library, one name per line.
{}
{      RAP$GET_DECK_LIST (PATH_NAME, PATH_NAME_SIZE, FILE_NAME, STATUS)
{}
{ PATH_NAME: (input) This parameter specifies the path name of a source
{       library.
{}
{ PATH_NAME_SIZE: (input) This parameter specifies the number of characters
{       in the path name.
{}
{ FILE_NAME: (input) This parameter specifies the file name that will
{       contain the deck names from the source library.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$GET_ELEMENTS_BY_CLASS EXPAND=FALSE
{}
{   The purpose of this request is to get a list of elements that have
{ a given class.  The installation table is searched and every element
{ with the given class is put in the list.
{}
{      RAP$GET_ELEMENTS_BY_CLASS (CLASS, ELEMENT_LIST, STATUS)
{}
{ CLASS: (input) This parameter specifies the class to which all
{       elements in the element list must belong.
{}
{ ELEMENT_LIST: (output) This parameter specifies a list of elements
{       belonging to the given class.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$GET_ELEMENTS_BY_PRODUCT EXPAND=FALSE
{}
{   The purpose of this request is to get a list of elements that have
{ a given product.  The installation table is searched and every element
{ with the given product is put in the list.
{}
{      RAP$GET_ELEMENTS_BY_PRODUCT (PRODUCT, ELEMENT_LIST, STATUS)
{}
{ PRODUCT: (input) This parameter specifies the product to which all
{       elements in the element list must belong.
{}
{ ELEMENT_LIST: (output) This parameter specifies a list of elements
{       belonging to the given product.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$GET_ELEMENT_NAME EXPAND=FALSE
{}
{    The purpose of this request is to return the element name that
{ corresponds to the given real state library.  The element name is used
{ as the name of the library when it is moved to the 170 side for processing.
{    Along with the element name  a boolean is returned distinguishing the
{ real state library as a user library or not.  This information is used in
{ further processing.
{}
{       RAP$GET_ELEMENT_NAME (BASE_FILE, ELEMENT, USER_LIBRARY, STATUS)
{}
{BASE_FILE: (input) This parameter specifies the real state library on
{       the 180 side.
{}
{ELEMENT: (output) This parameter specifies the element name of the real state
{       library.
{}
{USER_LIBRARY: (output) This parameter specifies a boolean declaring if the
{       library is a user_library or not.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$GET_FILE_NAMES EXPAND=FALSE
{}
{   The purpose of this request is to attach the specified OLD and
{ NEW files for processing.  Their names are added to the open file list
{ as being attached.
{}
{      RAP$GET_FILE_NAMES (ELEMENT, OLD_FILE, NEW_FILE, STATUS)
{}
{ ELEMENT: (input) This parameter specifies the element that will be
{        present in each system catalog that was specified upon entry to the
{        PACKAGE_CORRECTIONS utility.
{}
{ OLD_FILE: (output) This parameter specifies the old version of the
{        file to be updated.
{}
{ NEW_FILE: (output) This parameter specifies the new version of the
{        file to be updated.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$GET_TABLE_ENTRY_INDEX EXPAND=FALSE
{}
{   The purpose of this request is to locate the file entry in the installation
{ table and return the index of that location.
{}
{       RAP$GET_TABLE_ENTRY_INDEX (FILE, HEADER, TABLE, TABLE_INDEX, STATUS)
{}
{FILE: (input) This parameter specifies the file name for which the index
{       is found.
{}
{HEADER: (input) This parameter specifies the pointer to the header in the
{       installation table.
{}
{TABLE: (input) This parameter specifies the pointer to the table in the
{       installation table.
{}
{TABLE_INDEX: (output) This parameter specifies the index of the file into the
{       installation table.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$GO EXPAND=FALSE
{}
{    The purpose of this request is to terminate the current
{ INTERVENE_IN_DEADSTART utility session.
{}
{       RAP$GO (PARAMETER_LIST, STATUS)
{}
{PARAMETER_LIST: (input) This parameter specifies a sequence that holds
{       the user entered parameter values.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$INSERT_OR_REPLACE_CORRECTOR EXPAND=FALSE
{}
{   The purpose of this request is to make an entry in the current
{ correction package for an element correction just generated.  If the
{ element already has a correction in the package it is replaced, otherwise
{ it is inserted.
{}
{      RAP$INSERT_OR_REPLACE_CORRECTOR (ELEMENT, CORRECTOR, SIZE, USER_INFO)
{}
{ ELEMENT: (input) This parameter specifies the name of the element.
{}
{ CORRECTOR: (input) This parameter specifies the corrector for the file.
{}
{ SIZE: (input) This parameter specifies the size of the corrector.
{}
{ USER_INFO: (input) This parameter specifies the user information
{        attribute from the new version.
{}

*DECK DECK=RAH$INTERNALIZE_ACCESS_MODE EXPAND=FALSE
{}
{     The purpose of this request is to convert the external access mode keys into
{ an internal representation which will be compatiable with the installation table.
{}
{        RAP$INTERNALIZE_ACCESS_MODE (INTERNAL_VALUE_SET, STATUS)
{}
{INTERNAL_VALUE_SET: (output) This parameter specifies the resulting ordinal set.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$INTERNALIZE_ATTRIBUTE_NAME EXPAND=FALSE
{}
{   The purpose of this request is to internalize the attribute name given.
{ This request only works on entry attributes and not header attributes.
{}
{       RAP$INTERNALIZE_ATTRIBUTE_NAME (ATTRIBUTE, INTERNAL_NAME, STATUS)
{}
{ATTRIBUTE: (input) This parameter specifies the the attribute name which
{       is to be converted.
{}
{INTERNAL_NAME: (output) This parameter specifies the internal representation
{       of the attribute name.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$INTERNALIZE_FILE_CLASS EXPAND=FALSE
{}
{   The purpose of this request is to convert the external class name given
{ to it's internal representation.
{}
{       RAP$INTERNALIZE_FILE_CLASS (CLASS, INTERNAL_VALUE, STATUS)
{}
{CLASS: (input) This parameter specifies the class name that is to be
{       converted.
{}
{INTERNAL_VALUE: (output) This parameter specifies the internal representation
{       for the above class name.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$INTERNALIZE_FILE_FORMAT EXPAND=FALSE
{}
{   The purpose of this request is to convert the external format name given
{ to it's internal representation.
{}
{       RAP$INTERNALIZE_FILE_FORMAT (FORMAT, INTERNAL_VALUE, STATUS)
{}
{FORMAT: (input) This parameter specifies the format name that is to be
{       converted.
{}
{INTERNAL_VALUE: (output) This parameter specifies the internal representation
{       for the above format name.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$INTERNALIZE_SHARE_MODE EXPAND=FALSE
{}
{     The purpose of this request is to convert the external share mode keys into
{ an internal representation which will be compatiable with the installation table.
{}
{        RAP$INTERNALIZE_SHARE_MODE (INTERNAL_VALUE_SET, STATUS)
{}
{INTERNAL_VALUE_SET: (output) This parameter specifies the resulting ordinal set.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$INTERVENE_IN_DEADSTART EXPAND=FALSE
{}
{    The purpose of this request is to initialize the
{ INTERVENE_IN_DEADSTART utility environment.
{}
{       RAP$INTERVENE_IN_DEADSTART (STATUS)
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$ISOLATE_FILE_DIFFERENCES EXPAND=FALSE
{}
{   The purpose of this request is to build a replacement file
{ from the new file given.
{}
{      RAP$ISOLATE_FILE_DIFFERENCES (OLD_FILE_NAME, NEW_FILE_NAME, CORRECTOR,
{        SIZE, STATUS)
{}
{ OLD_FILE_NAME: (input) This parameter specifies the old file.
{}
{ NEW_FILE_NAME: (input) This parameter specifies the new file.
{}
{ CORRECTOR: (input) This parameter specifies a sequence containing the
{       correction.
{}
{ SIZE: (output) This parameter specifies the size of the correction.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$ISOLATE_ISAM_DIFFERENCES EXPAND=FALSE
{}
{     The purpose of this request is to build an indexed sequential file
{ correction.
{}
{        RAP$ISOLATE_ISAM_DIFFERENCES (OLD_FILE, NEW_FILE, CORRECTOR, SIZE, STATUS)
{}
{ OLD_FILE: (input) This parameter specifies the file name of the old indexed
{        sequential file.
{}
{ NEW_FILE: (input) This parameter specifies the file name of the new indexed
{        sequential file.
{}
{ CORRECTOR: (output) This parameter specifies an indexed sequential file
{        correction.
{}
{ SIZE: (output) This parameter specifies the size of the correction.
{}
{ STATUS: (output) This parameter specifies any resulting error.
{}
*DECK DECK=RAH$ISOLATE_SOURCE_CHANGES EXPAND=FALSE
{}
{   The purpose of this request is to build a source library correction.
{}
{      RAP$ISOLATE_SOURCE_CHANGES (OLD_FILE, NEW_FILE, CORRECTOR, SIZE, STATUS)
{}
{ OLD_FILE: (input) This parameter specifies the file values of the old source
{       library.
{}
{ NEW_FILE: (input) This parameter specifies the file values of the new source
{       library.
{}
{ CORRECTOR: (output) This parameter specifies a source library correction.
{}
{ SIZE: (output) This parameter specifies the the size of the correction.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$ISSUE_MESSAGE EXPAND=FALSE
{}
{   The purpose of this request is to format and issue an error message.
{}
{      RAP$ISSUE_MESSAGE (OUTPUT_FILE, MESSAGE_STATUS, STATUS)
{}
{ OUTPUT_FILE: (input) This parameter specifies the file to which the message
{       is written.
{}
{ MESSAGE_STATUS: (input) This parameter specifies the error message to be issued.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$LOCATE_TABLE_ENTRY_BY_PATH EXPAND=FALSE
{}
{   The purpose of this request is to locate an entry in the installation table
{ on the basis of it's path name alone.  The function returns the name of the
{ entry as a string, if the path supplied matched that entry's path, or an empty string
{ if no match is found.  The base of the paths from the table are converted to that
{ of the supplied path by using the catalog value that was also supplied.
{}
{       RAP$LOCATE_TABLE_ENTRY_BY_PATH (FUNCTION_NAME, ARGUMENT_LIST, VALUE, STATUS)
{}
{FUNCTION_NAME: (input) This parameter specifies the function associated with
{       this procedure.
{}
{ARGUMENT_LIST: (input) This parameter specifies a sequence that holds the user
{       entered parameter values.
{}
{VALUE: (output) This parameter specifies the record where the function values
{       are stored.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$MERGE_CORRECTORS EXPAND=FALSE
{}
{   The purpose of this request is to make an entry in the current
{ correction package for an elements correction.  If the element already
{ has a correction in the package it is replaced, otherwise it is inserted.
{}
{      RAP$MERGE_CORRECTORS (ADD_PACKAGE, J, ADD_ELEMENTS, STATUS)
{}
{ ADD_PACKAGE: (input) This parameter specifies a pointer to the correction
{        package being added.
{}
{ J: (input) This parameter specifies the element in the table being added.
{}
{ ADD_ELEMENTS: (input) This parameter specifies the table of elements from the
{        correction package being added.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$MOVE_CORRECTION EXPAND=FALSE
{}
{   The purpose of this request is to move the correction from the
{ correction package being added to the current correction package.
{}
{      RAP$MOVE_CORRECTION (ADD_PACKAGE, ORDINAL)
{}
{ ADD_PACKAGE: (input) This parameter specifies the correction package
{        being added.
{}
{ ORDINAL: (input) This parameter specifies the location in the current
{        correction package of the element being added.
{}

*DECK DECK=RAH$OPEN_INSTALLATION_TABLE EXPAND=FALSE
{}
{   The purpose of this request is to open the installation table and
{ initialize the pointers into the table.
{}
{       RAP$OPEN_INSTALLATION_TABLE (TABLE_FILE, TABLE_FILE_ID, TABLE, HEADER, STATUS)
{}
{TABLE_FILE: (input) This parameter specifies the local file name by which
{       the installation table is known for this open.
{}
{TABLE_FILE_ID: (output) This parameter specifies the identifier for the
{       installation table.
{}
{TABLE: (output) This parameter specifies the pointer to the table in the
{       installation table.
{}
{HEADER: (output) This parameter specifies the pointer to the header in the
{       installation table.
{}
{VERSION: (output) This parameter specifies the pointer to the version in the
{       installation table.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$PACKAGE_CORRECTIONS EXPAND=FALSE
{}
{   The purpose of this request is to enter the PACKAGE_CORRECTIONS
{ utility which builds a correction package.
{}
{      RAP$PACKAGE_CORRECTIONS (PARAMETER_LIST, STATUS)
{}
{ PARAMETER_LIST: (input) This parameter specifies a list of parameters for
{        the package corrections utility.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$PREPARE_ELEMENT_LIST EXPAND=FALSE
{}
{     The purpose of this request is to prepare a list of elements
{ that have changed since the previous BCU was generated.
{
{     The RAV$INSTALLATION_TABLE is used to generate a list of elements
{ to be compared.  The elements in the RAV$NEW_SYSTEM_CATALOG are compared
{ with the same elements from the PREVIOUS_SYSTEM_CATALOG (which defaults
{ to RAV$OLD_SYSTEM_CATALOG).
{
{     The method of comparing elements is taken from the COMPARE_FILE
{ scl command.  Most of the program interfaces called by COMPARE_FILE
{ are used here.
{
{     PREPARE_ELEMENT_LIST is a subcommand from the PACKAGE_CORRECTIONS
{ utility.  The variables RAV$NEW_SYSTEM_CATALOG, RAV$OLD_SYSTEM_CATALOG
{ and RAV$INSTALLATION_TABLE were created by the utility and are XREF'd
{ here.
{}
{        RAP$PREPARE_ELEMENT_LIST (PARAMETER_LIST, STATUS)
{}
{PARAMETER_LIST: (input) This parameter specifies a sequence that holds the
{        user entered parameter values.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$PREPARE_RELEASE_MATERIALS EXPAND=FALSE
{}
{     The purpose of this request is to set up the utility PREPARE
{ RELEASE MATERIALS.
{     The purpose of the utility is to collect all release system files
{ as specified in the INSTALLATION_TABLE into a catalog. This catalog
{ is refered to as the INSTALLATION_CATALOG. Once the catalog has
{ been created it is backed up onto a backup file. Release files are
{ checked for version id during the copy.
{     All pertainate output is placed on the file specified by the LIST
{ parameter.
{}
{        RAP$PREPARE_RELEASE_MATERIALS(PARAMETER_LIST,STATUS)
{}
{PARAMETER_LIST: (input) This is the SCL parameter list passed to the
{       utility command processor.
{}
{STATUS: (output) This is the utility return status.
{}

*DECK DECK=RAH$PRESS_NEXT_COMMAND EXPAND=FALSE
{
{    The purpose of this interface is to allow the user to acknowledge
{  previously issued statements before continuing.  This is accomplished by
{  forcing the user to press the NEXT (or RETURN) key, which creates a break
{  point in the process flow to allow the user to keep up with the data
{  being displayed.  RAP$PRESS_NEXT provides this capability.  When the user
{  is ready to continue they enter a carriage return and the process
{  continues.  The message template rae$press_next is associated with this
{  command.
{
{    SCL COMMAND INTERFACE:
{
{      rap$press_next ()
{

*DECK DECK=RAH$PREVIOUS_CLONE_ACCESS EXPAND=FALSE
{}
{   The purpose of this request is to return the value of rav$previous_clone_access.
{ This is to control the contents of the clone catalog used for defered installations.
{ Initially, rav$previous_clone_access is false and the catalog should be deleted before any
{ attempts are made to install a file there.  The variable is automatically set to true
{ upon any access of this function and any additional calls to this function returns true,
{ telling the caller not to delete catalog contents.
{}
{       RAP$PREVIOUS_CLONE_ACCESS (FUNCTION_NAME, ARGUMENT_LIST, VALUE, STATUS)
{}
{FUNCTION_NAME: (input) This parameter specifies the the function associated with
{       this procedure.
{}
{ARGUMENT_LIST: (input) This parameter specifies a sequence that holds the user
{       entered parameter values.
{}
{VALUE: (output) This parameter specifies the record where the function values
{       are stored.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$PROCESS_ENTRY_CHANGES EXPAND=FALSE
{}
{   The purpose of this request is to process the specified changes to a
{ specifed table entry.
{}
{       RAP$PROCESS_ENTRY_CHANGES (TABLE, TABLE_INDEX, STATUS)
{}
{TABLE: (input) This parameter specifies the pointer to the table in the
{       installation table.
{}
{TABLE_INDEX: (input) This parameter specifies the index into the table for the
{       entry that the attribute changes belong to.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$PROCESS_HEADER_CHANGES EXPAND=FALSE
{}
{   The purpose of this request is to process each specified attribute change
{ in the header.
{}
{       RAP$OPEN_INSTALLATION_TABLE (HEADER, STATUS)
{}
{HEADER: (input) This parameter specifies the pointer to the header in the
{       installation table.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$PRODUCT_FILES_LIST EXPAND=FALSE
{}
{   The purpose of this request is to return an array of all file names
{ from the installation table that belong to the specified product.
{}
{       RAP$PRODUCT_FILES_LIST (FUNCTION_NAME, ARGUMENT_LIST, VALUE, STATUS)
{}
{FUNCTION_NAME: (input) This parameter specifies the function associated with
{       this procedure.
{}
{ARGUMENT_LIST: (input) This parameter specifies a squence that holds the user
{       entered parameter values.
{}
{VALUE: (output) This parameter specifies the record where the function values
{       are stored.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$PRODUCT_VSN EXPAND=FALSE
{}
{   The purpose of this request is to determine the external vsn for the product
{ tape of the specified product.  The vsn is a 6 character string made up of a
{ 'W' followed by a 3 digit model number and finally a product identifier of 2 digits.
{}
{       RAP$PRODUCT_VSN (FUNCTION_NAME, ARGUMENT_LIST, VALUE, STATUS)
{}
{FUNCTION_NAME: (input) This parameter specifies the function associated with
{       this procedure.
{}
{ARGUMENT_LIST: (input) This parameter specifies a sequence that holds the user
{       entered parameter values.
{}
{VALUE: (output) This parameter specifies the record where the function values
{       are stored.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$PROMPT_FOR_VALUE_COMMAND EXPAND=FALSE
{
{    The purpose of this SCL command interface is for prompting for a value.
{  A prompt for value uses a parameter prompt message for the prompt, and a
{  parameter help message for the help.
{
{    SCL COMMAND INTERFACE:
{
{      rap$prompt_for_value (
{        prompt_module, pm        : name = $required
{        prompt_name, pn          : name = $required
{        prompting_parameters, pp : list 1..10 of string = $optional
{        prompting_options, po    : list of key allow_go, allow_null,
{                                 allow_quit, clear_screen = $optional
{        value_declaration, vd    : list 1..2 of string or key hex,
{                                 string, list = $required
{        value_returned, vr       : var of string = $required
{        status                   : var of status = $optional
{        )
{
{    PARAMETERS:
{
{      PROMPT_MODULE (PM)
{        Specifies the name of the help module that contains the prompt
{        (parameter prompt message) and the prompt help (parameter help
{        message).  This parameter is required.
{
{      PROMPT_NAME (PN)
{        Specifies the name used for the prompt and help messages found in
{        the help module.
{
{      PROMPTING_PARAMETERS (PP)
{        Optionally specifies the values to replace the parameters found
{        in the prompt and help message templates.  The parameters
{        are numbered for identification and the position of the value in
{        the list refers to the parameter it belongs to.
{
{      PROMPTING_OPTIONS (PO)
{        Optionally specifies the prompting options to allow.
{        The choices are:
{
{          allow_go
{
{            Allows the user to enter 'go' or 'g' in upper or lower case
{            for the prompt.  The value returned by the prompt interface
{            is '+GO'.
{
{          allow_null
{
{             Allows the user to enter a null string or carriage return
{             for the prompt.  The value returned by the prompt interface
{             is '+NULL'.
{
{          allow_quit
{
{            Allows the user to enter 'quit', 'qui', or 'q' in upper or
{            lower case for the prompt.  The value returned by the prompt
{            interface is '+QUIT'.
{
{          clear_screen
{
{            Causes the screen to be cleared before displaying the prompt.
{            If not used the prompt will be displayed following whatever
{            is on the screen.
{
{      VALUE_DECLARATION (VD)
{        Declares the kind of value the prompt is looking for.  This is
{        specified by a list of 2.
{
{        The first part of the list is any SCL parameter value declaration
{        allowed specified as a string.  This part is required.
{        Verification of the input entered is done using the SCL command
{        processor.  An SCL procedure is created with a parameter using
{        the value declaration specified in part 1.  The SCL procedure is
{        called passing in the value entered by the user and the status is
{        trapped.  When status returns normal the value is valid.
{
{        The second part is one of the following optional keys that allows
{        the user to simplify their input:
{
{          hex
{
{            When specified the user does not have to enter the radix
{            when entering the value.  The hex radix will be added by the
{            interface before the input line is verified.
{
{          string
{
{            When specified the user does not have to add quotes to the
{            string entered.  The interface will add the quotes for the
{            user before the input line is verified.
{
{          list
{
{            When specified the user does not have to add the opening and
{            closing parenthesis to the list.  This is automatically done
{            before the interface is verified.
{
{      VALUE_RETURNED (VR)
{        This is the value returned by the interface. It is either the
{        value as entered by the user or one of the keywords described in
{        the prompting  options.  This parameter is required.
{
{      STATUS
{        Optional status variable.
{        conditions:
{              rae$bad_value_key
{              rae$bad_value_specification
{              rae$message_not_found
{              rae$module_access_error
{
*DECK DECK=RAH$PROMPT_VIA_MENU_COMMAND EXPAND=FALSE
{
{    The purpose of this SCL command interface is for prompting via a menu.
{
{    SCL COMMAND INTERFACE:
{
{      rap$prompt_via_menu (
{        menu_module, mm       : name = $required
{        menu_selections, ms   : list 1..10 of name = $required
{        menu_parameters, mp   : list 1..50 of string = $optional
{        prompting_options, po : list of key allow_go, allow_null,
{                              allow_quit, clear_screen, confirm_selection
{                              = $optional
{        selection_chosen, sc  : var of string = $required
{        status                : var of status = $optional
{        )
{
{    PARAMETERS:
{
{      MENU_MODULE (MM)
{        Specifies the name of the help module that contains the menu
{        message templates.  This parameter is required.
{
{      MENU_SELECTIONS (MS)
{        Specifies the list of names coinciding with the menu sections.
{        These are the names used for the parameter prompt messages.  The
{        order of the list determines the order of the selections.  The
{        first name in the list is selection 1, second is selection 2, and
{        so on.  This parameter is required.
{
{      MENU_PARAMETERS (MP)
{        Optionally specifies the values to replace the parameters found
{        in the the message templates that make up the menu.  The
{        parameters in the templates are numbered for identification.  The
{        parameter numbered '1' is reserved for the selections (each
{        selection must begin with a '+P1').  The values for the
{        selections parameter are automatically supplied by the interface.
{        The first value in the MENU_PARAMETERS list is associated with
{        the second parameter, the second value in the list is associated
{        with the third parameter, and so on.
{
{      MENU_OPTIONS (MO)
{        Optionally specifies the menu options to allow.  The choices are:
{
{          allow_go
{
{            Allows the user to enter 'go' or 'g' in upper or lower case
{            for the menu.  The value returned by the menu interface
{            is '+GO'.
{
{          allow_null
{
{             Allows the user to enter a null string or carriage return
{             for the menu.  The value returned by the menu interface
{             is '+NULL'.
{
{          allow_quit
{
{            Allows the user to enter 'quit', 'qui', or 'q' in upper or
{            lower case for the menu.  The value returned by the menu
{            interface is '+QUIT'.
{
{          clear_screen
{
{            Causes the screen to be cleared before displaying the menu.
{            If not used the menu will be displayed following whatever
{            is on the screen.
{
{          confirm_selection
{
{            Causes the user to have to confirm whether or not they want
{            to use the input they entered.  If a parameter assist message
{            is found in the message module, it is used, otherwise a
{            "canned" message, 'Is the selection +P correct (YES or NO)?',
{            is used.
{
{      SELECTION_CHOSEN (SC)
{        This is the selection chosen by the user. It is either the name
{        of the selection as defined by the menu module or one of the
{        keywords described in the menu options.  This parameter is
{        required.
{
{      STATUS
{        Optional status variable.
{        Conditions:
{              rae$menu_definition_error
{              rae$module_access_error
{
*DECK DECK=RAH$PUT_FILE_ON_LIST EXPAND=FALSE
{}
{     The purpose of this procedure is to implement the put_file_on_list command.
{ This command places the specified file onto the list file for output.
{}
{        PUT_FILE_ON_LIST_PROCESSOR(PARAMETER_LIST, STATUS)
{}
{PARAMETER_LIST: (input) This is the scl parameter list passed into the command
{        processor.
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$PUT_ON_LIST EXPAND=FALSE
{}
{     The purpose of this procedure is to implement the put_on_list command.
{ This command places the specified lines onto the list file for output.
{}
{        PUT_ON_LIST_PROCESSOR(PARAMETER_LIST, STATUS)
{}
{PARAMETER_LIST: (input) This is the scl parameter list passed into the command
{        processor.
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$PUT_STATUS_ON_LIST EXPAND=FALSE
{}
{     The purpose of this procedure is to implement the put_status_on_list
{ command.  This command formats the specified status variable and places
{ the formated message onto the list file specified by the initial utility call.
{}
{        PUT_STATUS_ON_LIST_PROCESSOR(PARAMETER_LIST, STATUS)
{}
{PARAMETER_LIST: (input) This is the scl parameter list passed into the command
{        processor.
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$QUIT EXPAND=FALSE
{}
{   The purpose of this request is to terminate the current upgrade
{ system utility session.
{}
{       RAP$QUIT (PARAMETER_LIST, STATUS)
{}
{PARAMETER_LIST: (input) This parameter specifieds a sequence that holds the
{       user entered parameter values.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$QUIT_PACKAGE_CORRECTIONS EXPAND=FALSE
{}
{   The purpose of this request is to exit the PACKAGE_CORRECTIONS utility.
{}
{      RAP$QUIT_PACKAGE_CORRECTIONS (PARAMETER_LIST, STATUS)
{}
{ PARAMETER_LIST: (input) This parameter specifies a list of parameters for
{        the package corrections utility. There are none for this procedure.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$QUIT_PRERM EXPAND=FALSE
{}
{     The purpose os this procedure is to implement the quit command.
{ This command terminates the current PREPARE_RELEASE_MATERIALS utility session.
{}
{        QUIT_PROCESSOR(PARAMETER_LIST, STATUS)
{}
{PARAMETER_LIST: (input) This is the scl parameter list passed into the command
{        processor.
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$REMOVE_CORRECTION EXPAND=FALSE
{}
{   The purpose of this request is to remove an element from the
{ correction package.
{}
{      RAP$REMOVE_CORRECTION (PARAMETER_LIST, STATUS)
{}
{ PARAMETER_LIST: (input) This parameter specifies a list of parameters.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$REPL_BASE_CATALOG_OF_PATH EXPAND=FALSE
{}
{   The purpose of this request is to replace the existing base catalog
{ on a path with a supplied catalog.  The existing base is assumed to be made up of
{ of the family and user names.
{}
{       RAP$REPL_BASE_CATALOG_OF_PATH (PATH, CATALOG, STATUS)
{}
{PATH: (input, output) This parameter specifies the the path to be changed.
{}
{CATALOG: (input) This parameter specifies the catalog to replace the base
{       catalog with.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$SCAN_FILE EXPAND=FALSE
{}
{     The purpose of this request is to scan a 170 file and build a directory
{ of record name/type and partition number entries. The directory is a dynamic
{ single linked list.
{}
{        RAP$SCAN_FILE (FID, DIR, STATUS)
{}
{FID: (input) This parameter specifies the identifier for the 170 file.
{}
{DIR: (output) This parameter specifies the directory that was created.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}

*DECK DECK=RAH$SET_INSTALLATION_TABLE EXPAND=FALSE
{}
{   The purpose of this procedure is to implement the set_installation_table
{ command. This command sets up the variable rav$installation_table_path
{ for use by the instllation table accessing scl functions. In addition
{ the SCL variable rav$inst_table_path is set up for use by the SCL
{ implemented commands. This command is issued internal to SCL implemented
{ commands.
{}
{       SETIT_PROCESSOR( PARAMETER_LIST, STATUS)
{}
{PARAMETER_LIST: (input) This is the SCL parameter list passed to the
{       command processor.
{}
{STATUS: (output) This is the command return status.
{}

*DECK DECK=RAH$SET_TABLE_VIOLATION EXPAND=FALSE
{}
{   The purpose of this request is to set the table violation field in the
{ installation table header to TRUE.
{}
{       RAP$SET_TABLE_VIOLATION (TABLE_LFN, TABLE_PATH, STATUS)
{}
{TABLE_LFN: (input) This parameter specifies the local file name for the
{       installation table.
{}
{TABLE_PATH: (input) This parameter specifies the path name for the
{       installation table.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$SOFTWARE_MAINTENANCE_PATH EXPAND=FALSE
{}
{   The purpose of this request is to return the path names for important
{ files and catalogs used in the software maintenance process.  The paths
{ are returned as strings and the possible paths are those for the installation
{ table, the installation catalog, the clone catalog and the upgrade log.  These
{ are specified by the keywords TABLE, CATALOG, CLONE and LOG respectively.
{}
{       RAP$BASE (FUNCTION_NAME, ARGUMENT_LIST, VALUE, STATUS)
{}
{PARAMETER_LIST: (input) This parameter specifies a sequence that holds the user
{       entered parameter values.
{}
{FUNCTION_NAME: (input) This parameter specifies the function associated with
{       this procedure.
{}
{ARGUMENT_LIST: (input) This parameter specifies a sequence that holds the user
{       entered parameter values.
{}
{VALUE: (output) This parameter specifies the record where the function values
{       are stored.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$TABLE_ENTRY_ATTRIBUTE EXPAND=FALSE
{}
{   The purpose of this request is to return the value of the attribute
{ specified for the given file.  The valid attributes are 'KNOWN', 'RING',
{ 'PUBLIC', 'FORMAT', 'CLASS', 'PATH' and 'INTVE_PATH'.
{}
{       RAP$TABLE_ENTRY_ATTRIBUTE (FUNCTION_NAME, ARGUMENT_LIST, VALUE, STATUS)
{}
{FUNCTION_NAME: (input) This parameter specifies the function associated with
{       this procedure.
{}
{ARGUMENT_LIST: (input) This parameter specifies a sequence that holds the user
{       entered parameter values.
{}
{VALUE: (output) This parameter specifies the record where the function values
{       are stored.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$TABLE_ENTRY_LIST EXPAND=FALSE
{}
{   The purpose of this request is to return an array of all file names
{ from the installation table that belong to the specified class.  The
{ possible classes are 'OS', 'PF', 'NOS', and 'NONE'.  'NONE' means
{ that the given file belongs to none of the other classes, and if 'ALL'
{ is specified then all file names from the table appear in the list.
{}
{       RAP$TABLE_ENTRY_LIST (FUNCTION_NAME, ARGUMENT_LIST, VALUE, STATUS)
{}
{FUNCTION_NAME: (input) This parameter specifies the function associated with
{       this procedure.
{}
{ARGUMENT_LIST: (input) This parameter specifies a sequence that holds the user
{       entered parameter values.
{}
{VALUE: (output) This parameter specifies the record where the function values
{       are stored.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$TAILOR_RELEASE_MATERIALS EXPAND=FALSE
""
"   This procedure implements the tailor_release_materials command.    "
" The files comprising the standard NOS/VE system, plus he dual-state  "
" option specified plus and optional products specified, are extracted "
" from a master backup file generated by assemble_release_materials    "
" and written to a (magnetic tape) backup file.                        "
""
"       rap$tailor_release_materials(                                  "
"         backup_file bf : file = $required                            "
"         partner_system ps : key nos nos_be = $required               "
"         optional_product optional_products op : list of name or ..   "
"           key none = none                                            "
"         external_vsn evsn : list of string 1..6 = $required          "
"         type t : key mt9$800 mt9$1600 mt9$6250 mt18$38000 = mt9$1600 "
"         status)                                                      "
""
" backup_file bf : (input) This parameter specifies the master backup  "
"       to be used as input to tailor_release_materials.               "
""
" partner_system ps : (input) This parameter specifies the dual-state  "
"       partner system to be included with the tailored system.        "
""
" optional_product optional_products op : (input) This parameter       "
"       specifies a list of optional products to be included with the  "
"       tailored system.                                               "
""
" external_vsn evsn : (input) This parameter specifies a list of reel  "
"       names for the tapes which are to contain the tailored system.  "
""
" type t : (input) This parameter specifies the type of magnetic tape  "
"       to which the talored system is written.                        "
""
" status : (output) This parameter is the command return status.       "
""

*DECK DECK=RAH$TEST_FOR_ENTRY_CHANGES EXPAND=FALSE
{}
{   The purpose of this request is to test that none of the attributes associated
{ with the table entrys are specified.  If there are bad status is returned.
{}
{       RAP$TEST_FOR_ENTRY_CHANGES (STATUS)
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$TEST_FOR_HEADER_CHANGES EXPAND=FALSE
{}
{   The purpose of this request is to test that none of the attributes associated
{ with the table header are specified.  If there are then bad status is returned.
{}
{       RAP$TEST_FOR_HEADER_CHANGES (STATUS)
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$UPGRADE_SOFTWARE EXPAND=FALSE
{}
{    The purpose of this request is to initialize the UPGRADE_SOFTWARE utility
{ enviornment including the sub-commands and functions.
{}
{       RAP$UPGRADE_SOFTWARE (PARAMETER_LIST, STATUS)
{}
{PARAMETER_LIST: (input) This parameter specifies a sequence that holds the user
{       entered parameter values.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}

*DECK DECK=RAH$USER_MINIMUM_RING EXPAND=FALSE
{}
{     The purpose of this request is to return the user's minimum ring
{ value.
{}
{        RAP$USER_MINIMUM_RING (FUNCTION_NAME, ARGUMENT_LIST, VALUE, STATUS)
{}
{FUNCTION_NAME: (input) This parameter specifies the function associated with
{        this procedure.
{}
{ARGUMENT_LIST: (input) This parameter specifies a sequence that holds the user
{        entered parameter values.
{}
{VALUE: (output) This parameter specifies the record where the function values
{        are stored.
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAH$VERIFY_OBJECT_LIBRARY EXPAND=FALSE
{
{    The purpose of this request is to verify an object library.  Object
{ libraries are checked to make sure they were built with the proper OCU
{ version.  They must be compiled without debug tables and all bound modules
{ should have been bound with section maps.
{
{       RAP$VERIFY_OBJECT_LIBRARY (PARAMETER_LIST, STATUS)
{
{ PARAMETER_LIST: (input)  This parameter specifes all input parameters to the
{       procedure.
{
{ STATUS: (output) This parameter specifies normal or abnormal status.
{   CONDITIONS:
{     oce$e_invalid_library_version
{     oce$e_invalid_object_rec_kind
{     rae$debug_tables_on_library
{     rae$identification_not_first
{     rae$invalid_info_version
{     rae$no_modules_on_library
{     rae$no_section_maps
*DECK DECK=RAH$VERIFY_USER_INFO EXPAND=FALSE
{}
{   The purpose of this request is to verify that the user information
{ attribute (which contains the version) is different between the old
{ and new versions of the files.
{}
{      RAP$VERIFY_USER_INFO (OLD_FILE_NAME, NEW_FILE_NAME, USER_INFO_DIFFERS,
{        NEW_USER_INFO, STATUS)
{}
{ OLD_FILE_NAME: (input) This parameter specifies the old file name.
{}
{ NEW_FILE_NAME: (input) This parameter specifies the new file name.
{}
{ USER_INFO_DIFFERS: (output) This parameter specifies whether or not the user
{       information attributes differ.
{}
{ NEW_USER_INFO: (output) This parameter specifies the user information attribute
{       from the new file.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$WRITE_CORRECTION_PACKAGE EXPAND=FALSE
{}
{   The purpose of this request is to compress the correction package
{ and write it to the file specified by the user.
{}
{      RAP$WRITE_CORRECTION_PACKAGE (OUTPUT_FILE, STATUS)
{}
{ OUTPUT_FILE: (input) This parameter specifies the output file name where
{        the correction package will be written.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$WRITE_CP_TO_SCRATCH_FILE EXPAND=FALSE
{}
{   The purpose of this request is to write the current correction package
{ to a scratch_file.
{}
{      RAP$WRITE_CP_TO_SCRATCH_FILE (PARAMETER_LIST, STATUS)
{}
{ PARAMETER_LIST: (input) This parameter specifies the list of parameters.
{}
{ STATUS: (output) This parameter specifies normal or abnormal status.
{}

*DECK DECK=RAH$WRITE_TO_UPGRADE_LOG EXPAND=FALSE
{}
{   The purpose of this request is to copy the current session's log to
{ the UPGRADE LOG at end of information.
{}
{       RAP$WRITE_TO_UPGRADE_LOG (STATUS)
{}
{STATUS: (output) This parameter specifies any resulting errors.
{}
*DECK DECK=RAI$ARDEN_HILLS_CONFIGURATION EXPAND=FALSE
"  S T A R T  O F   R A I $ A R D E N _ H I L L S _ C O N F I G U R A T I O N "
"*****************************************************************************"
define_working_mainframe name=$system_0860_0302 "VIOLET"
"*****************************************************************************"
" 844/885 controller
define_element e=violet_7155_3 ei=$7155_12 sn=122 s=off ic=((ch20 0))
" 885 disk drives
define_element e=violet_885_10 ei=$885_12 sn=34300 s=off ..
                                                    pc=((violet_7155_3 40(8)))
define_element e=violet_885_11 ei=$885_12 sn=34300 s=off ..
                                                    pc=((violet_7155_3 41(8)))
" 844 disk drives
define_element e=violet_844_5 ei=$844_41 sn=46737 s=off pc=((violet_7155_3 4))

" XMD CONTROLLERS in cabinet # 158"
define_element e=violet_xmd_cm_2 ei=$fa7b5_a sn=526  s=off ic=((cch5a 2))
define_element e=violet_xmd_cm_3 ei=$fa7b5_a sn=591  s=off ic=((cch5a 3))
" XMD DISK DRIVES in cabinet # 158"
define_element e=violet_9853_0  ei=$9853_1  sn=1841  s=off pc=(..
                                      (violet_xmd_cm_2 0) (violet_xmd_cm_3 0))
define_element e=violet_9853_1  ei=$9853_1  sn=1840  s=off pc=(..
                                      (violet_xmd_cm_2 1) (violet_xmd_cm_3 1))
define_element e=violet_9853_2  ei=$9853_1  sn=1782  s=off pc=(..
                                      (violet_xmd_cm_2 2) (violet_xmd_cm_3 2))
define_element e=violet_9853_3  ei=$9853_1  sn=1838  s=off pc=(..
                                      (violet_xmd_cm_2 3) (violet_xmd_cm_3 3))

" XMD CONTROLLERS in cabinet # 183"
define_element e=violet_xmd_cm_4 ei=$fa7b5_a sn=1086  s=off ic=((cch4b 2))
define_element e=violet_xmd_cm_5 ei=$fa7b5_a sn=1089  s=off ic=((cch4b 3))
" XMD DISK DRIVES in cabinet # 183"
define_element e=violet_9853_4  ei=$9853_1  sn=2181  s=off pc=(..
                                      (violet_xmd_cm_4 4) (violet_xmd_cm_5 4))
define_element e=violet_9853_5  ei=$9853_1  sn=2182  s=off pc=(..
                                      (violet_xmd_cm_4 5) (violet_xmd_cm_5 5))
define_element e=violet_9853_6  ei=$9853_1  sn=2183  s=off pc=(..
                                      (violet_xmd_cm_4 6) (violet_xmd_cm_5 6))
define_element e=violet_9853_7  ei=$9853_1  sn=2184  s=off pc=(..
                                      (violet_xmd_cm_4 7) (violet_xmd_cm_5 7))
" XMD CONTROLLERS in cabinet # 468"
define_element e=violet_xmd_cm_6 ei=$fa7b5_a sn=2079  s=off ic=((cch4a 0))
define_element e=violet_xmd_cm_7 ei=$fa7b5_a sn=2089  s=off ic=((cch4a 1))
" XMD DISK DRIVES in cabinet # 468"
define_element e=violet_9853_00 ei=$9853_1  sn=5727  s=off pc=(..
                                      (violet_xmd_cm_6 0) (violet_xmd_cm_7 0))
define_element e=violet_9853_01 ei=$9853_1  sn=5721  s=off pc=(..
                                      (violet_xmd_cm_6 1) (violet_xmd_cm_7 1))
define_element e=violet_9853_02 ei=$9853_1  sn=5324  s=off pc=(..
                                      (violet_xmd_cm_6 2) (violet_xmd_cm_7 2))
define_element e=violet_9853_03 ei=$9853_1  sn=5326  s=off pc=(..
                                      (violet_xmd_cm_6 3) (violet_xmd_cm_7 3))
" HYDRA (887) Disks
define_element e=hyd0_violet   ei=$887_1 sn=122  s=off ic=((cch7a 0),(cch7b 0))
define_element e=hyd1_violet   ei=$887_1 sn=117  s=off ic=((cch7a 1),(cch7b 1))
define_element e=hyd2_violet   ei=$887_1 sn=170  s=off ic=((cch7a 2),(cch7b 2))
define_element e=hyd3_violet   ei=$887_1 sn=187  s=off ic=((cch7a 3),(cch7b 3))


" HPS/DAS controllers - cch3a - cch9b "
define_element e=vcm6_das ei=$5831_x sn=20 s=off ..
                                                      ic=((cch3a 6) (cch9b 6))
define_element e=vcm7_das ei=$5831_x sn=19 s=off ..
                                                      ic=((cch9b 7) (cch3a 7))
"HPS/DAS disk drives - cch3a - cch9b "
define_element e=vdas_0  ei=$5833_1  sn=163 s=off ..
                                               pc=((vcm6_das 0)  (vcm7_das 0))
define_element e=vdas_8  ei=$5833_1  sn=328 s=off ..
                                               pc=((vcm6_das 8)  (vcm7_das 8))
define_element e=vdas_16 ei=$5833_1  sn=477 s=off ..
                                              pc=((vcm6_das 16) (vcm7_das 16))
define_element e=vdas_24 ei=$5833_1  sn=587 s=off ..
                                              pc=((vcm6_das 24) (vcm7_das 24))
define_element e=vdas_1  ei=$5833_1  sn=281 s=off ..
                                               pc=((vcm6_das 1)  (vcm7_das 1))
define_element e=vdas_2  ei=$5833_1  sn=629 s=off ..
                                               pc=((vcm6_das 2)  (vcm7_das 2))
define_element e=vdas_9  ei=$5833_1  sn=256 s=off ..
                                               pc=((vcm6_das 9)  (vcm7_das 9))
define_element e=vdas_10 ei=$5833_1  sn=658 s=off ..
                                              pc=((vcm6_das 10) (vcm7_das 10))
define_element e=vdas_17 ei=$5833_1  sn=265 s=off ..
                                              pc=((vcm6_das 17) (vcm7_das 17))
define_element e=vdas_25 ei=$5833_1  sn=295 s=off ..
                                              pc=((vcm6_das 25) (vcm7_das 25))

" HPS/DAS controllers - cch9a - cch6a "
define_element e=vcm0_das ei=$5831_x sn=21 s=off ..
                                                      ic=((cch9a 0) (cch6a 0))
define_element e=vcm1_das ei=$5831_x sn=22 s=off ..
                                                      ic=((cch6a 1) (cch9a 1))
"HPS/DAS disk drives - cch9a - cch6a "
define_element e=vdas_000 ei=$5833_1 sn=3740 s=off ..
                                              pc=((vcm0_das 00) (vcm1_das 00))
define_element e=vdas_001 ei=$5833_1 sn=3377 s=off ..
                                              pc=((vcm0_das 01) (vcm1_das 01))
define_element e=vdas_002 ei=$5833_1 sn=153 s=off ..
                                              pc=((vcm0_das 02) (vcm1_das 02))
define_element e=vdas_003 ei=$5832_1 sn=458 s=off ..
                                              pc=((vcm0_das 03) (vcm1_das 03))
define_element e=vdas_008 ei=$5833_1 sn=3928 s=off ..
                                              pc=((vcm0_das 08) (vcm1_das 08))
define_element e=vdas_009 ei=$5833_1 sn=3350 s=off ..
                                              pc=((vcm0_das 09) (vcm1_das 09))
define_element e=vdas_00a ei=$5833_1 sn=621 s=off ..
                                              pc=((vcm0_das 10) (vcm1_das 10))
define_element e=vdas_00b ei=$5832_1 sn=435 s=off ..
                                              pc=((vcm0_das 11) (vcm1_das 11))
define_element e=vdas_010 ei=$5833_1 sn=4506 s=off ..
                                              pc=((vcm0_das 16) (vcm1_das 16))
define_element e=vdas_011 ei=$5833_1 sn=610 s=off ..
                                              pc=((vcm0_das 17) (vcm1_das 17))
define_element e=vdas_012 ei=$5833_1 sn=393 s=off ..
                                              pc=((vcm0_das 18) (vcm1_das 18))
define_element e=vdas_013 ei=$5833_1 sn=680 s=off ..
                                              pc=((vcm0_das 19) (vcm1_das 19))
define_element e=vdas_018 ei=$5833_1 sn=3356 s=off ..
                                              pc=((vcm0_das 24) (vcm1_das 24))
define_element e=vdas_019 ei=$5833_1 sn=512 s=off ..
                                              pc=((vcm0_das 25) (vcm1_das 25))
define_element e=vdas_01a ei=$5833_1 sn=530 s=off ..
                                              pc=((vcm0_das 26) (vcm1_das 26))
define_element e=vdas_01b ei=$5833_1 sn=790 s=off ..
                                              pc=((vcm0_das 27) (vcm1_das 27))

" TAPE controllers
define_element e=violet_7021_1 ei=$7021_31 sn=272 s=off ic=((ch27 0))
define_element e=violet_7021_2 ei=$7021_31 sn=355 s=off ic=((ch7  0))
" TAPE drives
define_element e=v50 ei=$679_7 sn=1457 s=off ..
                                        pc=((violet_7021_1 0) (violet_7021_2 0))
define_element e=v51 ei=$679_7 sn=2301 s=off ..
                                        pc=((violet_7021_1 1) (violet_7021_2 1))
define_element e=v52 ei=$679_7 sn=1903 s=off ..
                                        pc=((violet_7021_1 2) (violet_7021_2 2))
define_element e=v54 ei=$679_7 sn=2918 s=off ..
                                        pc=((violet_7021_1 4) (violet_7021_2 4))
define_element e=v55 ei=$679_7 sn=1131 s=off ..
                                        pc=((violet_7021_1 5) (violet_7021_2 5))
"
" CARTRIDGE TAPE CONTROLLERS FOR SILO
"
define_element e=violet_5680_3 ei=$5680_11 s=off sn=20905 ic=((ch17 0))
"
" CARTRIDGE TAPE DRIVES FOR SILO
"
" The next four element descriptions are normally used by GRAY
"
define_element e=ctd6 ei=$5682_12 s=off sn=301496 pc=((violet_5680_3 6))
define_element e=ctd7 ei=$5682_12 s=off sn=301497 pc=((violet_5680_3 7))
define_element e=cts0 ei=$5682_14 s=off sn=301460 pc=((violet_5680_3 0)) ..
    ai='sen=stkcontrol,acs=0,lsm=0,panel=1,unit=0'
define_element e=cts1 ei=$5682_14 s=off sn=301461 pc=((violet_5680_3 1)) ..
    ai='sen=stkcontrol,acs=0,lsm=0,panel=1,unit=1'
"
" The next two silo element descriptions are normally used by SYSTEM K
"
define_element e=cts2 ei=$5682_14 s=off sn=301462 pc=((violet_5680_3 2)) ..
    ai='sen=stkcontrol,acs=0,lsm=0,panel=1,unit=2'
define_element e=cts3 ei=$5682_14 s=off sn=301463 pc=((violet_5680_3 3)) ..
    ai='sen=stkcontrol,acs=0,lsm=0,panel=1,unit=3'
"
" DIs
define_element e=violet_DI_100092 ei=$2620_210 sn=146  s=off ic=((ch25 0))
define_element e=violet_DI_3000a0 ei=$2620_210 sn=260  s=off ic=((ch26 0))
define_element e=violet_DI_3000f0 ei=$2620_210 sn=340  s=off ic=((ch9  0))
define_element e=violet_DI_30044f ei=$2620_210 sn=1103 s=off ic=((ch19 0))
define_element e=violet_DI_10006E ei=$2620_210 sn=110  s=off ic=((ch1 0))   "NOS"
define_element e=violet_DI_10007D ei=$2620_210 sn=125  s=off ic=((ch2 0))   "NOS"
define_element e=violet_DI_30011A ei=$2620_210 sn=382  s=off ic=((ch3 0))   "NOS/VE"
define_element e=violet_DI_10007F ei=$2620_210 sn=127  s=off ic=((cch2 0))  "NOS/VE"
define_element e=violet_DI_100087 ei=$2620_210 sn=135  s=off ic=((ch11 0))  "NOS/VE"
define_element e=violet_DI_300116 ei=$2620_210 sn=378  s=off ic=((ch4 0))   "NOS/VE"
define_element e=violet_DI_300420 ei=$2620_210 sn=1056 s=off ic=((ch5 0))   "NOS/VE"
" NADs
define_element e=violet_nad_1 ei=$380_170 sn=538 s=off ic=((ch16 0))
" EXPRESS LINK
define_element e=xlink_violet     ei=$4000_01 sn=9910  s=off ic=((cch8a 0))
" STORENET
"
" 799X MASSTOR
"
define_element e=$7992_10_1_0 ei=$7992_10 s=off sn=9998 iou_program_name=cssd ..
      ic=((cch2 0)) vei=false
define_element e=drd_dum0 ei=$drd_1 s=off sn=996 pc=(($7992_10_1_0 16)) ..
                                                 vei=false
define_element e=sma_drd0 ei=$drd_1 s=off sn=998 pc=(($7992_10_1_0 0)) ..
                                                 vei=false
define_element e=sma_drd1 ei=$drd_1 s=off sn=997 pc=(($7992_10_1_0 1)) ..
                                                 vei=false
"*****************************************************************************"
define_working_mainframe name=$system_0860_0311 "GRAY"
"*****************************************************************************"
"XMD DISK CONTROL MODULES
 define_element e=gray_fa7b5_0 ei=$fa7b5_a s=off sn=1568 ic=((cch3b 0))
 define_element e=gray_fa7b5_1 ei=$fa7b5_a s=off sn=1574 ic=((cch3b 1))

"XMD DISK DRIVES in cabinet # 271"
 define_element e=gray_9853_28 ei=$9853_1 s=off sn=4584 ..
              pc=(( gray_fa7b5_0 0 ) ( gray_fa7b5_1 0 ))
 define_element e=gray_9853_29 ei=$9853_1 s=off sn=4579 ..
    pc=(( gray_fa7b5_0 1 ) ( gray_fa7b5_1 1 ))
 define_element e=gray_9853_30 ei=$9853_1 s=off sn=4594 ..
    pc=(( gray_fa7b5_1 2 ) ( gray_fa7b5_0 2 ))
 define_element e=gray_9853_31 ei=$9853_1 s=off sn=4583 ..
    pc=(( gray_fa7b5_1 3 ) ( gray_fa7b5_0 3 ))

" STANDALONE CARTRIDGE TAPE DRIVE AND CONTROLLER.
 define_element e=gray_5680_1 ei=$5680_11 s=off sn=201617 ic=((ch27 1))
 define_element e=gs67 ei=$5682_12 s=off sn=1499 pc=((gray_5680_1 7))

"679 TAPE DRIVE AND CONTROLLERS
 define_element e=gray_C32 ei=$7021_32 s=off sn=263 ipn=e2c7021 ic=((ch26 0))
 define_element e=gray_C13 ei=$7021_32 s=off sn=200 ipn=e2c7021 ic=((ch11 0))
 define_element e=G70 ei=$679_7 s=off sn=280 pc=((gray_c32 0) (gray_c13 0))
 define_element e=G71 ei=$679_7 s=off sn=1913 pc=((gray_c32 1) (gray_c13 1))
 define_element e=G72 ei=$679_7 s=off sn=2020 pc=((gray_c32 2) (gray_c13 2))
 define_element e=G73 ei=$679_7 s=off sn=2024 pc=((gray_c32 3) (gray_c13 3))
"DIs"
 define_element e=gray_DI_300119 ei=$2620_210 s=off sn=381 ic=((ch7 0))
 define_element e=cobray_DI_3013AD ei=$2620_210 s=off sn=5037 ic=((ch3 0) (cch5 0))
"NAD"
 define_element e=gray_NAD_1 ei=$380_170 s=off sn=489 ic=((ch16 0))
"STORNET"
 define_element e=stornet ei=$5380_100 s=off sn=61115 ic=((ch19 0) (ch6 0))

"*****************************************************************************"
define_working_mainframe name=$system_9303_0121 "PEWTER"
"define_working_mainframe name=$system_9301_0121 PEWTER                       "
"*****************************************************************************"
"XMD DISK CONTROL MODULES in cabinet # 271"
define_element e=pewter_xmd_cm_0 ei=$fa7b5_a sn=1437 s=off ic=((ch3 0))
define_element e=pewter_xmd_cm_1 ei=$fa7b5_a sn=1436 s=off ic=((ch3 1))
"XMD DISK DRIVES in cabinet # 271"
define_element e=pewter_9853_0 ei=$9853_1  sn=3662 s=off ..
                                    pc=((pewter_xmd_cm_0 0) (pewter_xmd_cm_1 0))
define_element e=pewter_9853_1 ei=$9853_1  sn=3668 s=off ..
                                    pc=((pewter_xmd_cm_0 1) (pewter_xmd_cm_1 1))
define_element e=pewter_9853_2 ei=$9853_1  sn=3664 s=off ..
                                    pc=((pewter_xmd_cm_0 2) (pewter_xmd_cm_1 2))
define_element e=pewter_9853_3 ei=$9853_1  sn=3663 s=off ..
                                    pc=((pewter_xmd_cm_0 3) (pewter_xmd_cm_1 3))
"XMD DISK CONTROL MODULES in cabinet # 468"
define_element e=block_cm_0 ei=$fa7b5_a sn=7437 s=off ic=((ch1 0))
define_element e=block_cm_1 ei=$fa7b5_a sn=7436 s=off ic=((ch1 1))
"XMD DISK DRIVES in cabinet # 468"
define_element e=block_0 ei=$9853_1  sn=7662 s=off ..
                                    pc=((block_cm_0 0) (block_cm_1 0))
define_element e=block_1 ei=$9853_1  sn=7668 s=off ..
                                    pc=((block_cm_0 1) (block_cm_1))
define_element e=block_2 ei=$9853_1  sn=7664 s=off ..
                                    pc=((block_cm_0 2) (block_cm_1 2))
define_element e=block_3 ei=$9853_1  sn=7663 s=off ..
                                    pc=((block_cm_0 3) (block_cm_1 3))
"ISD2 DISK CONTROL MODULES"
define_element e=pewter_cm_0   ei=$fa7b5_a sn=104   s=off ic=((ch1 0), (ch17 0))
define_element e=pewter_cm_1   ei=$fa7b5_a sn=127   s=off ic=((ch1 1), (ch17 1))
define_element e=pewter_cm_2   ei=$fa7b5_a sn=150   s=off ic=((ch1 2), (ch17 2))
define_element e=pewter_cm_3   ei=$fa7b5_a sn=168   s=off ic=((ch1 3), (ch17 3))
define_element e=pewter_cm_4   ei=$fa7b5_a sn=831   s=off ic=((ch1 4), (ch17 4))
define_element e=pewter_cm_5   ei=$fa7b5_a sn=759   s=off ic=((ch1 5), (ch17 5))
"ISD2 DISK DRIVES"
define_element e=pewter_9836_00 ei=$9836_1  sn=44597 s=off pc=((pewter_cm_0 0)..
                                                             , (pewter_cm_1 0))
define_element e=pewter_9836_01 ei=$9836_1  sn=46831 s=off pc=((pewter_cm_0 1)..
                                                             , (pewter_cm_1 1))
define_element e=pewter_9836_12 ei=$9836_1  sn=44599 s=off pc=((pewter_cm_0 2)..
                                                             , (pewter_cm_1 2))
define_element e=pewter_9836_13 ei=$9836_1  sn=44631 s=off pc=((pewter_cm_0 3)..
                                                             , (pewter_cm_1 3))
define_element e=pewter_9836_20 ei=$9836_1  sn=64054 s=off pc=((pewter_cm_2 0)..
                                                             , (pewter_cm_3 0))
define_element e=pewter_9836_21 ei=$9836_1  sn=64058 s=off pc=((pewter_cm_2 1)..
                                                             , (pewter_cm_3 1))
define_element e=pewter_9836_32 ei=$9836_1  sn=64057 s=off pc=((pewter_cm_2 2)..
                                                             , (pewter_cm_3 2))
define_element e=pewter_9836_33 ei=$9836_1  sn=62937 s=off pc=((pewter_cm_2 3)..
                                                             , (pewter_cm_3 3))
define_element e=pewter_9836_40 ei=$9836_1  sn=98375 s=off pc=((pewter_cm_4 0)..
                                                             , (pewter_cm_5 0))
define_element e=pewter_9836_41 ei=$9836_1  sn=88476 s=off pc=((pewter_cm_4 1)..
                                                             , (pewter_cm_5 1))
define_element e=pewter_9836_52 ei=$9836_1  sn=98362 s=off pc=((pewter_cm_4 2)..
                                                             , (pewter_cm_5 2))
define_element e=pewter_9836_53 ei=$9836_1  sn=98370 s=off pc=((pewter_cm_4 3)..
                                                             , (pewter_cm_5 3))
"TAPES"
define_element e=pewter_7221_1 ei=$7221_11 sn=132   s=off ic=((ch4 0))
define_element e=pew0          ei=$9639_1  sn=14708 s=off pc=((pewter_7221_1 0))
define_element e=pew1          ei=$9639_1  sn=14709 s=off pc=((pewter_7221_1 1))

define_element e=pewter_5698_0 ei=$5698_10  sn=1010 s=off ic=((ch21 0))
define_element e=pew2 ei=$698_30 sn=1506 s=off pc=((pewter_5698_0 0))
define_element e=pew3 ei=$698_30 sn=1505 s=off pc=((pewter_5698_0 1))
"ICAs"
define_element e=pewter_ica_16   ei=$2629_2  sn=123   s=off ic=((ch16 0))
define_element e=pewter_ica_0    ei=$2629_2  sn=124   s=off ic=((ch0 0))
define_element e=pewter_ica_test ei=$2629_2  sn=125   s=off ic=((ch20 0))
"NAD"
define_element e=pewter_nad_1    ei=$380_170 sn=384   s=off ic=((ch18 0))
"EXPRESS LINK"
define_element e=xlink19_pew      ei=$4000_01 sn=9905  s=off ic=((ch19 0))
define_element e=xlink5_pew     ei=$4000_01 sn=9919  s=off ic=((ch5 0))
"*****************************************************************************"
define_working_mainframe name=$system_9603_0102 "COBALT"
"*****************************************************************************"
define_element e=cobalt_7155_1 ei=$7155_1 sn=1127 s=off ..
                               ic=((ch3 0) (cch3 0 $system_9603_0102 iou1))
define_element e=cobalt_7155_2 ei=$7155_1 sn=1126 s=off ..
                               ic=((ch22 0) (cch4 0 $system_9603_0102 iou1))

define_element e=cobalt_885_0 ei=$885_12 sn=30597 s=off ..
                              pc=((cobalt_7155_1 40(8)), (cobalt_7155_2 40(8)))
define_element e=cobalt_885_1 ei=$885_12 sn=30597 s=off ..
                              pc=((cobalt_7155_1 41(8)), (cobalt_7155_2 41(8)))
define_element e=cobalt_885_2 ei=$885_12 sn=13042 s=off ..
                              pc=((cobalt_7155_1 42(8)), (cobalt_7155_2 42(8)))
define_element e=cobalt_885_3 ei=$885_12 sn=13042 s=off ..
                              pc=((cobalt_7155_1 43(8)), (cobalt_7155_2 43(8)))
define_element e=cobalt_885_4 ei=$885_12 sn=30036 s=off ..
                              pc=((cobalt_7155_2 44(8)), (cobalt_7155_1 44(8)))
define_element e=cobalt_885_5 ei=$885_12 sn=30036 s=off ..
                              pc=((cobalt_7155_2 45(8)), (cobalt_7155_1 45(8)))
define_element e=cobalt_885_6 ei=$885_12 sn=30563 s=off ..
                              pc=((cobalt_7155_2 46(8)), (cobalt_7155_1 46(8)))
define_element e=cobalt_885_7 ei=$885_12 sn=30563 s=off ..
                              pc=((cobalt_7155_2 47(8)), (cobalt_7155_1 47(8)))

define_element e=cobalt_844_0  ei=$844_41 sn=31902 s=off pc=((cobalt_7155_1 0))
define_element e=cobalt_844_1  ei=$844_41 sn=34820 s=off pc=((cobalt_7155_1 1))


define_element e=cobalt_fa7b5_1  ei=$fa7b5_a sn=1399 s=off ..
                                 ic=((cch21a 0 $system_9603_0102 iou1))
define_element e=cobalt_fa7b5_2  ei=$fa7b5_a sn=1366 s=off ..
                                 ic=((cch21a 1 $system_9603_0102 iou1))
define_element e=cobalt_fa7b5_5  ei=$fa7b5_a sn=1444 s=off ..
                                 ic=((cch22a 0 $system_9603_0102 iou1))
define_element e=cobalt_fa7b5_6  ei=$fa7b5_a sn=1445 s=off ..
                                 ic=((cch22a 1 $system_9603_0102 iou1))
define_element e=cobalt_fa7b5_7  ei=$fa7b5_a sn=1150 s=off ..
                                 ic=((cch20a 0 $system_9603_0102 iou1))
define_element e=cobalt_fa7b5_8  ei=$fa7b5_a sn=741  s=off ..
                                 ic=((cch20a 1 $system_9603_0102 iou1))
define_element e=cobalt_fa7b5_9  ei=$fa7b5_a sn=2741 s=off ..
                                 ic=((cch23a 0 $system_9603_0102 iou1))
define_element e=cobalt_fa7b5_10 ei=$fa7b5_a sn=2740 s=off ..
                                 ic=((cch23a 1 $system_9603_0102 iou1))
define_element e=cobalt_fa7b5_13 ei=$fa7b5_a sn=1568 s=off ..
                                 ic=((cch9a 0 $system_9603_0102 iou1))
define_element e=cobalt_fa7b5_14 ei=$fa7b5_a sn=1574 s=off ..
                                 ic=((cch9a 1 $system_9603_0102 iou1))
define_element e=cobalt_fa7b5_15 ei=$fa7b5_a sn=221  s=off ..
                                 ic=((cch6a 0 $system_9603_0102 iou1))
define_element e=cobalt_fa7b5_16 ei=$fa7b5_a sn=220  s=off ..
                                 ic=((cch6a 1 $system_9603_0102 iou1))
define_element e=cobalt_fa7b5_17 ei=$fa7b5_a sn=1364 s=off ic=((cch3a 0))
define_element e=cobalt_fa7b5_18 ei=$fa7b5_a sn=1365 s=off ic=((cch3a 1))
define_element e=cobalt_fa7b5_19 ei=$fa7b5_a sn=874  s=off ic=((cch4a 0))
define_element e=cobalt_fa7b5_20 ei=$fa7b5_a sn=875  s=off ic=((cch4a 1))

define_element e=cobalt_9853_1  ei=$9853_1  sn=3529 s=off ..
                                   pc=((cobalt_fa7b5_1 0) (cobalt_fa7b5_2 0))
define_element e=cobalt_9853_2  ei=$9853_1  sn=3530 s=off ..
                                   pc=((cobalt_fa7b5_1 1) (cobalt_fa7b5_2 1))
define_element e=cobalt_9853_3  ei=$9853_1  sn=3532 s=off ..
                                   pc=((cobalt_fa7b5_2 2) (cobalt_fa7b5_1 2))
define_element e=cobalt_9853_4  ei=$9853_1  sn=3534 s=off ..
                                   pc=((cobalt_fa7b5_2 3) (cobalt_fa7b5_1 3))
define_element e=cobalt_9853_9  ei=$9853_1  sn=2988 s=off ..
                                   pc=((cobalt_fa7b5_5 0) (cobalt_fa7b5_6 0))
define_element e=cobalt_9853_10 ei=$9853_1  sn=2989 s=off ..
                                   pc=((cobalt_fa7b5_5 1) (cobalt_fa7b5_6 1))
define_element e=cobalt_9853_11 ei=$9853_1  sn=3536 s=off ..
                                   pc=((cobalt_fa7b5_6 2) (cobalt_fa7b5_5 2))
define_element e=cobalt_9853_12 ei=$9853_1  sn=3524 s=off ..
                                   pc=((cobalt_fa7b5_6 3) (cobalt_fa7b5_5 3))
define_element e=cobalt_9853_13 ei=$9853_1  sn=1848 s=off ..
                                   pc=((cobalt_fa7b5_7 0) (cobalt_fa7b5_8 0))
define_element e=cobalt_9853_14 ei=$9853_1  sn=1850 s=off ..
                                   pc=((cobalt_fa7b5_7 1) (cobalt_fa7b5_8 1))
define_element e=cobalt_9853_15 ei=$9853_1  sn=2753 s=off ..
                                   pc=((cobalt_fa7b5_8 2) (cobalt_fa7b5_7 2))
define_element e=cobalt_9853_16 ei=$9853_1  sn=2552 s=off ..
                                   pc=((cobalt_fa7b5_8 3) (cobalt_fa7b5_7 3))
define_element e=cobalt_9853_17 ei=$9853_1  sn=2023 s=off ..
                                   pc=((cobalt_fa7b5_9 0) (cobalt_fa7b5_10 0))
define_element e=cobalt_9853_18 ei=$9853_1  sn=7122 s=off ..
                                   pc=((cobalt_fa7b5_9 1) (cobalt_fa7b5_10 1))
define_element e=cobalt_9853_19 ei=$9853_1  sn=6757 s=off ..
                                   pc=((cobalt_fa7b5_10 2) (cobalt_fa7b5_9 2))
define_element e=cobalt_9853_20 ei=$9853_1  sn=7103 s=off ..
                                   pc=((cobalt_fa7b5_10 3) (cobalt_fa7b5_9 3))
define_element e=cobalt_9853_25 ei=$9853_1  sn=4579 s=off ..
                                   pc=((cobalt_fa7b5_13 0) (cobalt_fa7b5_14 0))
define_element e=cobalt_9853_26 ei=$9853_1  sn=4584 s=off ..
                                   pc=((cobalt_fa7b5_13 1) (cobalt_fa7b5_14 1))
define_element e=cobalt_9853_27 ei=$9853_1  sn=4583 s=off ..
                                   pc=((cobalt_fa7b5_14 2) (cobalt_fa7b5_13 2))
define_element e=cobalt_9853_28 ei=$9853_1  sn=4594 s=off ..
                                   pc=((cobalt_fa7b5_14 3) (cobalt_fa7b5_13 3))
define_element e=cobalt_9853_29 ei=$9853_1  sn=306  s=off ..
                                   pc=((cobalt_fa7b5_15 0) (cobalt_fa7b5_16 0))
define_element e=cobalt_9853_30 ei=$9853_1  sn=307  s=off ..
                                   pc=((cobalt_fa7b5_15 1) (cobalt_fa7b5_16 1))
define_element e=cobalt_9853_31 ei=$9853_1  sn=308  s=off ..
                                   pc=((cobalt_fa7b5_16 2) (cobalt_fa7b5_15 2))
define_element e=cobalt_9853_32 ei=$9853_1  sn=309  s=off ..
                                   pc=((cobalt_fa7b5_16 3) (cobalt_fa7b5_15 3))
define_element e=cobalt_9853_33 ei=$9853_1  sn=2807 s=off ..
                                   pc=((cobalt_fa7b5_17 0) (cobalt_fa7b5_18 0))
define_element e=cobalt_9853_34 ei=$9853_1  sn=2805 s=off ..
                                   pc=((cobalt_fa7b5_17 1) (cobalt_fa7b5_18 1))
define_element e=cobalt_9853_35 ei=$9853_1  sn=2804 s=off ..
                                   pc=((cobalt_fa7b5_18 2) (cobalt_fa7b5_17 2))
define_element e=cobalt_9853_36 ei=$9853_1  sn=2767 s=off ..
                                   pc=((cobalt_fa7b5_18 3) (cobalt_fa7b5_17 3))
define_element e=cobalt_9853_37 ei=$9853_1  sn=1201 s=off ..
                                   pc=((cobalt_fa7b5_19 0) (cobalt_fa7b5_20 0))
define_element e=cobalt_9853_38 ei=$9853_1  sn=1202 s=off ..
                                   pc=((cobalt_fa7b5_19 1) (cobalt_fa7b5_20 1))
define_element e=cobalt_9853_39 ei=$9853_1  sn=1203 s=off ..
                                   pc=((cobalt_fa7b5_20 2) (cobalt_fa7b5_19 2))
define_element e=cobalt_9853_40 ei=$9853_1  sn=1204 s=off ..
                                   pc=((cobalt_fa7b5_20 3) (cobalt_fa7b5_19 3))

define_element e=cobalt_7021_1 ei=$7021_32  sn=583  s=off ic=((ch11 0))
define_element e=cobalt_7021_2 ei=$7021_32  sn=374  s=off ic=((ch27 0))

define_element e=c44 ei=$679_6 sn=692  s=off pc=((cobalt_7021_1 4) ..
                                                 (cobalt_7021_2 4))
define_element e=c45 ei=$679_6 sn=550  s=off pc=((cobalt_7021_1 5) ..
                                                 (cobalt_7021_2 5))
define_element e=c46 ei=$679_7 sn=3611 s=off pc=((cobalt_7021_2 6) ..
                                                 (cobalt_7021_1 6))
define_element e=c47 ei=$679_7 sn=3315 s=off pc=((cobalt_7021_2 7) ..
                                                 (cobalt_7021_1 7))

define_element e=cobalt_5698_2 ei=$5698_10  sn=283 s=off ic=((ch17 0))
define_element e=cobalt_5698_3 ei=$5698_10  sn=271 s=off ic=((ch21 0))

define_element e=c70 ei=$698_30 sn=1010  s=off pc=((cobalt_5698_2 0) ..
                                                   (cobalt_5698_3 0))
define_element e=c71 ei=$698_30 sn=1011  s=off pc=((cobalt_5698_2 1) ..
                                                   (cobalt_5698_3 1))
define_element e=c72 ei=$698_30 sn=1002  s=off pc=((cobalt_5698_2 2) ..
                                                   (cobalt_5698_3 2))
define_element e=c73 ei=$698_30 sn=1001  s=off pc=((cobalt_5698_2 3) ..
                                                   (cobalt_5698_3 3))
define_element e=c74 ei=$698_30 sn=1003  s=off pc=((cobalt_5698_3 4) ..
                                                   (cobalt_5698_2 4))
define_element e=c75 ei=$698_30 sn=1004  s=off pc=((cobalt_5698_3 5) ..
                                                   (cobalt_5698_2 5))
define_element e=c76 ei=$698_30 sn=1012  s=off pc=((cobalt_5698_3 6) ..
                                                   (cobalt_5698_2 6))
define_element e=c77 ei=$698_30 sn=1007  s=off pc=((cobalt_5698_3 7) ..
                                                   (cobalt_5698_2 7))

define_element e=cobalt_5698_0 ei=$5698_10  sn=1009 s=off ..
                                         ic=((cch19a 0 $system_9603_0102 iou1))
define_element e=cobalt_5698_1 ei=$5698_10  sn=1003 s=off ..
                                          ic=((cch2a 1 $system_9603_0102 iou1))

define_element e=c60 ei=$698_30 sn=1412  s=off pc=((cobalt_5698_0 0) ..
                                                   (cobalt_5698_1 0))
define_element e=c61 ei=$698_30 sn=1411  s=off pc=((cobalt_5698_0 1) ..
                                                   (cobalt_5698_1 1))
define_element e=c62 ei=$698_30 sn=1339  s=off pc=((cobalt_5698_0 2) ..
                                                   (cobalt_5698_1 2))
define_element e=c63 ei=$698_30 sn=1340  s=off pc=((cobalt_5698_0 3) ..
                                                   (cobalt_5698_1 3))
define_element e=c64 ei=$698_30 sn=1469  s=off pc=((cobalt_5698_0 4) ..
                                                   (cobalt_5698_1 4))
define_element e=c65 ei=$698_30 sn=1470  s=off pc=((cobalt_5698_0 5) ..
                                                   (cobalt_5698_1 5))

define_element e=cobalt_5680_1 ei=$5680_11 s=off sn=201617 ..
                                         ic=((cch25 0 $system_9603_0102 iou1))

define_element e=cs60 ei=$5682_12 s=off sn=10 pc=((cobalt_5680_1 0))
define_element e=cs61 ei=$5682_12 s=off sn=11 pc=((cobalt_5680_1 1))
define_element e=cs64 ei=$5682_12 s=off sn=14 pc=((cobalt_5680_1 4))
define_element e=cs65 ei=$5682_12 s=off sn=15 pc=((cobalt_5680_1 5))

define_element e=cobalt_DI_3000c2 ei=$2620_210 sn=294  s=off ic=((ch5  0))
define_element e=cobalt_DI_30070c ei=$2620_210 sn=1804 s=off ic=((ch23 0))
define_element e=cobalt_DI_300070 ei=$2620_210 sn=212  s=off ic=((ch2  0))

define_element e=cobalt_NAD_1 ei=$380_170 sn=358 s=off ic=((ch4 0))
"****************************************************************************"
define_working_mainframe name=$system_9603_0101 "COPPER"
"****************************************************************************"
define_element e=copper_887_0  ei=$887_1 s=off sn=166 ..
                                         ic=((cch17a 0 $system_9603_0101 iou0))
define_element e=copper_887_1  ei=$887_1 s=off sn=155 ..
                                         ic=((cch17a 1 $system_9603_0101 iou0))
define_element e=copper_887_2  ei=$887_1 s=off sn=180 ..
                                         ic=((cch23a 0 $system_9603_0101 iou0))
define_element e=copper_887_3  ei=$887_1 s=off sn=167 ..
                                         ic=((cch23a 1 $system_9603_0101 iou0))
define_element e=copper_887_4  ei=$887_1 s=off sn=472 ..
                                         ic=((cch17b 0 $system_9603_0101 iou0))
define_element e=copper_887_5  ei=$887_1 s=off sn=471 ..
                                         ic=((cch17b 1 $system_9603_0101 iou0))
define_element e=copper_887_6  ei=$887_1 s=off sn=448 ..
                                         ic=((cch23b 0 $system_9603_0101 iou0))
define_element e=copper_887_7  ei=$887_1 s=off sn=452 ..
                                         ic=((cch23b 1 $system_9603_0101 iou0))

define_element e=copper_7155_1 ei=$7155_14 s=off sn=1705 ic=((cch16 0))

define_element e=copper_fa7b5_0  ei=$fa7b5_a s=off sn=124 ..
                                     ic=((cch25a 0 $system_9603_0101 iou0))
define_element e=copper_fa7b5_1  ei=$fa7b5_a s=off sn=105 ..
                                     ic=((cch25a 1 $system_9603_0101 iou0))
define_element e=copper_fa7b5_2  ei=$fa7b5_a s=off sn=1363 ..
                                     ic=((cch8a 0 $system_9603_0101 iou0))
define_element e=copper_fa7b5_3  ei=$fa7b5_a s=off sn=1362 ..
                                     ic=((cch8a 1 $system_9603_0101 iou0))
define_element e=copper_fa7b5_4  ei=$fa7b5_a s=off sn=2365 ..
                                     ic=((cch18a 0 $system_9603_0101 iou0))
define_element e=copper_fa7b5_5  ei=$fa7b5_a s=off sn=2364 ..
                                     ic=((cch18a 1 $system_9603_0101 iou0))
define_element e=copper_fa7b5_6  ei=$fa7b5_a s=off sn=1291 ..
                                     ic=((cch22a 0 $system_9603_0101 iou0))
define_element e=copper_fa7b5_7  ei=$fa7b5_a s=off sn=1289 ..
                                     ic=((cch22a 1 $system_9603_0101 iou0))
define_element e=copper_fa7b5_8  ei=$fa7b5_a s=off sn=1091 ..
                                     ic=((cch21a 0 $system_9603_0101 iou0))
define_element e=copper_fa7b5_9  ei=$fa7b5_a s=off sn=1137 ..
                                     ic=((cch21a 1 $system_9603_0101 iou0))

define_element e=copper_885_0 ei=$885_12 s=off sn=20809 ..
                                               pc=((copper_7155_1 32))

define_element e=copper_9853_0  ei=$9853_1 s=off sn=149 ..
                                     pc=((copper_fa7b5_0 0) (copper_fa7b5_1 0))
define_element e=copper_9853_1  ei=$9853_1 s=off sn=150 ..
                                     pc=((copper_fa7b5_0 1) (copper_fa7b5_1 1))
define_element e=copper_9853_2  ei=$9853_1 s=off sn=141 ..
                                     pc=((copper_fa7b5_1 2) (copper_fa7b5_0 2))
define_element e=copper_9853_3  ei=$9853_1 s=off sn=154 ..
                                     pc=((copper_fa7b5_1 3) (copper_fa7b5_0 3))
define_element e=copper_9853_4  ei=$9853_1 s=off sn=2759 ..
                                     pc=((copper_fa7b5_2 0) (copper_fa7b5_3 0))
define_element e=copper_9853_5  ei=$9853_1 s=off sn=2763 ..
                                     pc=((copper_fa7b5_2 1) (copper_fa7b5_3 1))
define_element e=copper_9853_6  ei=$9853_1 s=off sn=2744 ..
                                     pc=((copper_fa7b5_3 2) (copper_fa7b5_2 2))
define_element e=copper_9853_7  ei=$9853_1 s=off sn=2764 ..
                                     pc=((copper_fa7b5_3 3) (copper_fa7b5_2 3))
define_element e=copper_9853_8  ei=$9853_1 s=off sn=5852 ..
                                     pc=((copper_fa7b5_4 0) (copper_fa7b5_5 0))
define_element e=copper_9853_9  ei=$9853_1 s=off sn=6353 ..
                                     pc=((copper_fa7b5_4 1) (copper_fa7b5_5 1))
define_element e=copper_9853_10 ei=$9853_1 s=off sn=6637 ..
                                     pc=((copper_fa7b5_5 2) (copper_fa7b5_4 2))
define_element e=copper_9853_11 ei=$9853_1 s=off sn=6627 ..
                                     pc=((copper_fa7b5_5 3) (copper_fa7b5_4 3))
define_element e=copper_9853_12 ei=$9853_1 s=off sn=2846 ..
                                     pc=((copper_fa7b5_6 0) (copper_fa7b5_7 0))
define_element e=copper_9853_13 ei=$9853_1 s=off sn=2737 ..
                                     pc=((copper_fa7b5_6 1) (copper_fa7b5_7 1))
define_element e=copper_9853_14 ei=$9853_1 s=off sn=2760 ..
                                     pc=((copper_fa7b5_7 2) (copper_fa7b5_6 2))
define_element e=copper_9853_15 ei=$9853_1 s=off sn=2758 ..
                                     pc=((copper_fa7b5_7 3) (copper_fa7b5_6 3))
define_element e=copper_9853_16 ei=$9853_1 s=off sn=2735 ..
                                     pc=((copper_fa7b5_8 0) (copper_fa7b5_9 0))
define_element e=copper_9853_17 ei=$9853_1 s=off sn=2755 ..
                                     pc=((copper_fa7b5_8 1) (copper_fa7b5_9 1))
define_element e=copper_9853_18 ei=$9853_1 s=off sn=2749 ..
                                     pc=((copper_fa7b5_9 2) (copper_fa7b5_8 2))
define_element e=copper_9853_19 ei=$9853_1 s=off sn=2754 ..
                                     pc=((copper_fa7b5_9 3) (copper_fa7b5_8 3))

define_element e=copper_5698_1 ei=$5698_10 s=off sn=1005 ..
                                           ic=((cch3a 0 $system_9603_0101 iou0))
define_element e=copper_5698_2 ei=$5698_10 s=off sn=1006 ..
                                           ic=((cch24a 0 $system_9603_0101 iou0))

define_element e=cop51 ei=$698_30 s=off sn=1344 ..
                                        pc=((copper_5698_1 1) (copper_5698_2 1))
define_element e=cop52 ei=$698_30 s=off sn=1343 ..
                                        pc=((copper_5698_1 2) (copper_5698_2 2))
define_element e=cop53 ei=$698_30 s=off sn=1345 ..
                                        pc=((copper_5698_1 3) (copper_5698_2 3))
define_element e=cop54 ei=$698_30 s=off sn=1346 ..
                                        pc=((copper_5698_1 4) (copper_5698_2 4))

define_element e=copper_nad_1 ei=$380_170 s=off sn=415 ..
                                          ic=((cch9a 0 $system_9603_0101 iou0))

define_element e=copper_di_3000aa ei=$2620_210 s=off sn=270 ..
                                           ic=((cch6 0 $system_9603_0101 iou0))
"*****************************************************************************"
"      C180-860 belonging to Engineering Services Training in room 2S109      "
define_working_mainframe name=$system_0860_0341 "EST_860"
"*****************************************************************************"
" 844/885 controller
define_element e=es1_7155_1 ei=$7155_12 sn=999999 s=off ic=((ch1 0),(ch2 0))
" 885 disk drives
define_element e=es1_885_42 ei=$885_12 sn=99999 s=off pc=((es1_7155_1 42(8)))
define_element e=es1_885_43 ei=$885_12 sn=99998 s=off pc=((es1_7155_1 43(8)))
" 844 disk drive
define_element e=es1_844_6 ei=$844_41 sn=99999 s=off pc=((es1_7155_1 6))
" 895 disk controller
define_element e=es1_7165_1  ei=$7165_22 sn=999999 s=off ic=((ch3 0))
" 895 disk drives
define_element e=es1_895_0    ei=$895_2 sn=9999 s=off pc=((es1_7165_1 0))
define_element e=es1_895_1    ei=$895_2 sn=9999 s=off pc=((es1_7165_1 1))
define_element e=es1_895_2    ei=$895_2 sn=9999 s=off pc=((es1_7165_1 2))
define_element e=es1_895_3    ei=$895_2 sn=9999 s=off pc=((es1_7165_1 3))
" 67x tape controller
define_element e=es1_7021 ei=$7021_31 sn=999 s=off ic=((ch11 0))
" 67x tape drives
define_element e=nt0 ei=$679_7 sn=9999 s=off pc=((es1_7021 0))
define_element e=nt1 ei=$679_7 sn=9998 s=off pc=((es1_7021 1))
" 698 tape controller (Hitachi)
define_element e=es1_698 ei=$698_10 s=off sn=9999 ic=((ch16 0))
" 698 tape drives (Hitachi)
define_element e=ht0 ei=$698_30 s=off sn=9999 pc=((es1_698 0))
define_element e=ht1 ei=$698_30 s=off sn=9998 pc=((es1_698 1))
" DI
define_element e=es1_DI_30032e ei=$2620_210 sn=999 s=off ic=((ch19 0))
" NAD
define_element e=es1_NAD_1 ei=$380_170 sn=9814 s=off ic=((ch17 0))
 "****************************************************************************"
 define_working_mainframe name=$system_9303_0114 "NAVY"
 "****************************************************************************"
 define_element e=cm_11_0        ei=$fa7b5_a  sn=178    s=off ic=((ch1 0))
"define_element e=cm_23_0        ei=$fa7b5_a  sn=227    s=off ic=((ch19 0))
 define_element e=cm_23_1        ei=$fa7b5_a  sn=226    s=off ic=((ch19 1))

 define_element e=disk_11_0      ei=$9836_1   sn=61325  s=off pc=((cm_11_0 0))
 define_element e=disk_11_1      ei=$9836_1   sn=61490  s=off pc=((cm_11_0 1))
 define_element e=disk_23_0      ei=$9836_1   sn=61112  s=off pc=((cm_23_1 0))
 define_element e=disk_23_1      ei=$9836_1   sn=49605  s=off pc=((cm_23_1 1))
 define_element e=disk_23_2      ei=$9836_1   sn=61111  s=off pc=((cm_23_1 2))
 define_element e=disk_23_3      ei=$9836_1   sn=61921  s=off pc=((cm_23_1 3))

 define_element e=tape_adapter_a ei=$7221_11  sn=118    s=off ic=((ch4 0))
 define_element e=tape_a1        ei=$9639_1   sn=14721  s=off pc=((tape_adapter_a 0))

 define_element e=ica_0          ei=$2629_2   sn=119    s=off ic=((ch0 0))

 define_element e=ivb_5       ei=$4000_01  sn=97 s=off  ic=((ch5  0))
"define_element e=ivb_21      ei=$4000_01  sn=98 s=off  ic=((ch17 0))
 define_element e=ivb_25      ei=$4000_01  sn=99 s=off  ic=((ch21 0))
"*****************************************************************************"
"  E N D    O F    R A I $ A R D E N _ H I L L S _ C O N F I G U R A T I O N  "
"*****************************************************************************"
*DECK DECK=RAI$CREATE_PROLOG_FILE EXPAND=TRUE
PROC create_prolog_file, crepf (
  prolog_name, pn : name = $name($mainframe(identifier))
  file, f         : key lcu_mainframe_subcommands, lms, ..
                        lcu_network_subcommands, lns, pcu_subcommands, ps, ..
                        keyend = $required
  until, u        : string = '**'
  status          : var of status = $optional
  )

  create_variable osv$configuration_prolog_name k=(string $max_name) ..
        scope=xref
  create_variable ignore_status k=status
  create_variable line kind=(string 256)
  create_variable count kind=integer
  create_variable file kind=(string 31)

  IF osv$configuration_prolog_name <> '' THEN
    target_catalog_name = $string($name(osv$configuration_prolog_name))
  ELSE
    target_catalog_name = $mainframe(identifier)
  IFEND


  IF target_catalog_name <> $string($value(prolog_name)) THEN
  ignore_text: ..
    REPEAT
      accept_line variable=line input=$command_of_caller line_count=count
    UNTIL count = 0 OR line = $value(until)
    prolog_file_name = '$null'
  ELSE
    create_variable cmv$prolog_path k=string scope=xref

    catalog_name = cmv$prolog_path // '.' // target_catalog_name
    create_catalog $fname(catalog_name) status=ignore_status

    IF $string($value(file)) = 'PS' THEN
      file = 'PCU_SUBCOMMANDS'
    ELSEIF $string($value(file)) = 'LMS' THEN
      file = 'LCU_MAINFRAME_SUBCOMMANDS'
    ELSEIF $string($value(file)) = 'LNS' THEN
      file = 'LCU_NETWORK_SUBCOMMANDS'
    ELSE
      file = $string($value(file))
    IFEND

    prolog_file_name = catalog_name // '.' // file

    display_value ' Installing configuration prolog file: '//..
target_catalog_name//'.'//file o=$output status=ignore_status

    IF file = 'LCU_MAINFRAME_SUBCOMMANDS' THEN
COLLECT_TEXT $fname(prolog_file_name) sm='~' until='end of proc'
PROC ~file~ (status)
    create_variable subcommand_status k=status
    WHEN any_fault interrupt DO
      display_value ('   The following error was detected in command: '//osv$command_name,   osv$status,..
'   Continuing prolog execution.') o=$output
      IF subcommand_status.normal then
        subcommand_status = osv$status
      IFEND
      CONTINUE
    WHENEND

end of proc
    ELSE
      delete_file $fname(prolog_file_name) status=ignore_status
    IFEND
    accept_line variable=line input=$command_of_caller line_count=count

  collect_text: ..
    WHILE count <> 0 AND line <> $value(until) DO
      put_line line output=$fname(prolog_file_name//'.$eoi')
      accept_line variable=line input=$command_of_caller line_count=count
    WHILEND collect_text
    IF file = 'LCU_MAINFRAME_SUBCOMMANDS' THEN
COLLECT_TEXT $fname(prolog_file_name//'.$eoi') sm='~' until='end of proc'
    exit_proc with subcommand_status
PROCEND ~file~
end of proc
    IFEND
    detach_file $fname(prolog_file_name) status=ignore_status

    IF $file($fname(catalog_name//'.pcu_subcommands'), assigned) AND $file(..
          $fname(catalog_name//'.lcu_mainframe_subcommands'), assigned) AND ..
          $file($fname(catalog_name//'.lcu_network_subcommands'), assigned) ..
          THEN
      EXIT_PROC WITH $status(false, 'CM', 9999, 'Prolog Found')
    IFEND
  IFEND

PROCEND create_prolog_file
*DECK DECK=RAI$CV2 EXPAND=FALSE
create_file_deck..
  name=X11_ASCIITEXTP_H..
  path=$system.cv2.USR.INCLUDE.X11.ASCIITEXTP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.ASCIITEXTP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_ASCIITEXT_H..
  path=$system.cv2.USR.INCLUDE.X11.ASCIITEXT_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.ASCIITEXT_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_ATOMS_H..
  path=$system.cv2.USR.INCLUDE.X11.ATOMS_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.ATOMS_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_BOXP_H..
  path=$system.cv2.USR.INCLUDE.X11.BOXP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.BOXP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_BOX_H..
  path=$system.cv2.USR.INCLUDE.X11.BOX_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.BOX_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_CARDINALS_H..
  path=$system.cv2.USR.INCLUDE.X11.CARDINALS_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.CARDINALS_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_CASCADEP_H..
  path=$system.cv2.USR.INCLUDE.X11.CASCADEP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.CASCADEP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_CASCADE_H..
  path=$system.cv2.USR.INCLUDE.X11.CASCADE_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.CASCADE_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_CLOCKP_H..
  path=$system.cv2.USR.INCLUDE.X11.CLOCKP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.CLOCKP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_CLOCK_H..
  path=$system.cv2.USR.INCLUDE.X11.CLOCK_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.CLOCK_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_COMMANDP_H..
  path=$system.cv2.USR.INCLUDE.X11.COMMANDP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.COMMANDP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_COMMAND_H..
  path=$system.cv2.USR.INCLUDE.X11.COMMAND_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.COMMAND_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_COMPOSITEP_H..
  path=$system.cv2.USR.INCLUDE.X11.COMPOSITEP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.COMPOSITEP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_COMPOSITE_H..
  path=$system.cv2.USR.INCLUDE.X11.COMPOSITE_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.COMPOSITE_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_CONSTRAINP_H..
  path=$system.cv2.USR.INCLUDE.X11.CONSTRAINP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.CONSTRAINP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_CONSTRAINT_H..
  path=$system.cv2.USR.INCLUDE.X11.CONSTRAINT_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.CONSTRAINT_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_CONVERT_H..
  path=$system.cv2.USR.INCLUDE.X11.CONVERT_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.CONVERT_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_COPYRIGHT_H..
  path=$system.cv2.USR.INCLUDE.X11.COPYRIGHT_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.COPYRIGHT_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_COREP_H..
  path=$system.cv2.USR.INCLUDE.X11.COREP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.COREP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_CORE_H..
  path=$system.cv2.USR.INCLUDE.X11.CORE_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.CORE_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_CURSORFONT_H..
  path=$system.cv2.USR.INCLUDE.X11.CURSORFONT_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.CURSORFONT_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_DECKEYSYM_H..
  path=$system.cv2.USR.INCLUDE.X11.DECKEYSYM_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.DECKEYSYM_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_DIALOGP_H..
  path=$system.cv2.USR.INCLUDE.X11.DIALOGP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.DIALOGP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_DIALOG_H..
  path=$system.cv2.USR.INCLUDE.X11.DIALOG_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.DIALOG_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_FORMP_H..
  path=$system.cv2.USR.INCLUDE.X11.FORMP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.FORMP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_FORM_H..
  path=$system.cv2.USR.INCLUDE.X11.FORM_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.FORM_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_GRIPP_H..
  path=$system.cv2.USR.INCLUDE.X11.GRIPP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.GRIPP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_GRIP_H..
  path=$system.cv2.USR.INCLUDE.X11.GRIP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.GRIP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_INTRINSICP_H..
  path=$system.cv2.USR.INCLUDE.X11.INTRINSICP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.INTRINSICP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_INTRINSIC_H..
  path=$system.cv2.USR.INCLUDE.X11.INTRINSIC_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.INTRINSIC_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_KEYSYMDEF_H..
  path=$system.cv2.USR.INCLUDE.X11.KEYSYMDEF_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.KEYSYMDEF_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_KEYSYM_H..
  path=$system.cv2.USR.INCLUDE.X11.KEYSYM_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.KEYSYM_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_LABELP_H..
  path=$system.cv2.USR.INCLUDE.X11.LABELP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.LABELP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_LABEL_H..
  path=$system.cv2.USR.INCLUDE.X11.LABEL_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.LABEL_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_LOADP_H..
  path=$system.cv2.USR.INCLUDE.X11.LOADP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.LOADP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_LOAD_H..
  path=$system.cv2.USR.INCLUDE.X11.LOAD_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.LOAD_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_LOGOP_H..
  path=$system.cv2.USR.INCLUDE.X11.LOGOP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.LOGOP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_LOGO_H..
  path=$system.cv2.USR.INCLUDE.X11.LOGO_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.LOGO_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_MAILBOXP_H..
  path=$system.cv2.USR.INCLUDE.X11.MAILBOXP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.MAILBOXP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_MAILBOX_H..
  path=$system.cv2.USR.INCLUDE.X11.MAILBOX_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.MAILBOX_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_MISC_H..
  path=$system.cv2.USR.INCLUDE.X11.MISC_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.MISC_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_NOSVE_MACROS_H..
  path=$system.cv2.USR.INCLUDE.X11.NOSVE_MACROS_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.NOSVE_MACROS_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_NOSVE_SIZES_H..
  path=$system.cv2.USR.INCLUDE.X11.NOSVE_SIZES_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.NOSVE_SIZES_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_QUARKS_H..
  path=$system.cv2.USR.INCLUDE.X11.QUARKS_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.QUARKS_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_RPC_NVE_H..
  path=$system.cv2.USR.INCLUDE.X11.RPC_NVE_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.RPC_NVE_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_SCROLLP_H..
  path=$system.cv2.USR.INCLUDE.X11.SCROLLP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.SCROLLP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_SCROLL_H..
  path=$system.cv2.USR.INCLUDE.X11.SCROLL_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.SCROLL_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_SHELLP_H..
  path=$system.cv2.USR.INCLUDE.X11.SHELLP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.SHELLP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_SHELL_H..
  path=$system.cv2.USR.INCLUDE.X11.SHELL_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.SHELL_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_SIMPLEP_H..
  path=$system.cv2.USR.INCLUDE.X11.SIMPLEP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.SIMPLEP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_SIMPLE_H..
  path=$system.cv2.USR.INCLUDE.X11.SIMPLE_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.SIMPLE_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_STRINGDEFS_H..
  path=$system.cv2.USR.INCLUDE.X11.STRINGDEFS_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.STRINGDEFS_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_TEXTP_H..
  path=$system.cv2.USR.INCLUDE.X11.TEXTP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.TEXTP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_TEXT_H..
  path=$system.cv2.USR.INCLUDE.X11.TEXT_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.TEXT_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_TIME_H..
  path=$system.cv2.USR.INCLUDE.X11.TIME_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.TIME_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_TM_H..
  path=$system.cv2.USR.INCLUDE.X11.TM_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.TM_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_VENDORP_H..
  path=$system.cv2.USR.INCLUDE.X11.VENDORP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.VENDORP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_VENDOR_H..
  path=$system.cv2.USR.INCLUDE.X11.VENDOR_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.VENDOR_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_VIEWPORTP_H..
  path=$system.cv2.USR.INCLUDE.X11.VIEWPORTP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.VIEWPORTP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_VIEWPORT_H..
  path=$system.cv2.USR.INCLUDE.X11.VIEWPORT_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.VIEWPORT_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_VPANEDP_H..
  path=$system.cv2.USR.INCLUDE.X11.VPANEDP_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.VPANEDP_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_VPANED_H..
  path=$system.cv2.USR.INCLUDE.X11.VPANED_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.VPANED_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_X10_H..
  path=$system.cv2.USR.INCLUDE.X11.X10_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.X10_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_XATOM_H..
  path=$system.cv2.USR.INCLUDE.X11.XATOM_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.XATOM_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_XLIB_H..
  path=$system.cv2.USR.INCLUDE.X11.XLIB_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.XLIB_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_XMD_H..
  path=$system.cv2.USR.INCLUDE.X11.XMD_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.XMD_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_XOS_H..
  path=$system.cv2.USR.INCLUDE.X11.XOS_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.XOS_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_XPROTOSTR_H..
  path=$system.cv2.USR.INCLUDE.X11.XPROTOSTR_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.XPROTOSTR_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_XPROTO_H..
  path=$system.cv2.USR.INCLUDE.X11.XPROTO_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.XPROTO_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_XRESOURCE_H..
  path=$system.cv2.USR.INCLUDE.X11.XRESOURCE_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.XRESOURCE_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_XUTIL_H..
  path=$system.cv2.USR.INCLUDE.X11.XUTIL_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.XUTIL_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_XWDFILE_H..
  path=$system.cv2.USR.INCLUDE.X11.XWDFILE_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.XWDFILE_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

create_file_deck..
  name=X11_X_H..
  path=$system.cv2.USR.INCLUDE.X11.X_H..
  subproduct=cv2..
  intve_path='!wev$server_development_base!.cv2.?wev$cv2_level?.USR.INCLUDE.X11.X_H' ..
  format=unknown..
  access_mode=(read execute)..
  share_mode=(read execute)..
  ring_attributes=(11,11,11)..
  storage_class=product

*DECK DECK=RAI$MAILVE_VERSION_2 EXPAND=FALSE

create_file_deck..
  name=mailve_v2_bound_product..
  path=$system.mailve_v2.bound_product..
  subproduct=mailve_version_2..
  additional_subproducts=(svl_product_tape)..
  intve_path='!wev$server_development_base!.mailve_v2.?wev$mailve_v2_level?.mailve_v2_bound_product'..
  format=object_library..
  access_mode=(READ EXECUTE)..
  share_mode=(READ EXECUTE)..
  ring_attributes=(4,4,13)..
  storage_class=product
*DECK DECK=RAI$PROLOG_COBALT_BYOPS_XMD_2X8 EXPAND=TRUE
PROCEDURE COBALT_BYOPS_XMD_2X8 (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
crefc $echo output
 delete_element_definition e=all r=(..
 cobalt_xmd_cm_2 ..
 cobalt_xmd_cm_3 ..
 violet_xmd_cm_2 ..
 violet_xmd_cm_3 ..
 violet_9853_0 ..
 violet_9853_1 ..
 violet_9853_2 ..
 violet_9853_3 ..
 cobalt_xmd_0 ..
 cobalt_xmd_1 ..
 cobalt_xmd_2 ..
 cobalt_xmd_3 ..
 cobalt_7021_2 ..
 c44 ..
 c45 ..
 c46 ..
 c47 ..
 cobalt_DI_3000c2)

 change_element_definition e=cobalt_xmd_cm_2 s=on  ic=((cch7b 2))
 change_element_definition e=cobalt_xmd_cm_3 s=on  ic=((cch7b 3))
 change_element_definition e=violet_xmd_cm_2 s=on  ic=((cch3b 2))
 change_element_definition e=violet_xmd_cm_3 s=on  ic=((cch3b 3))
 change_element_definition e=violet_9853_0   s=on  pc=((violet_xmd_cm_2 0))
                                                                    "XMD-68"
 change_element_definition e=violet_9853_1   s=on  pc=((violet_xmd_cm_2 1))
                                                                    "XMD-66"
 change_element_definition e=violet_9853_2   s=on  pc=((violet_xmd_cm_3 2))
                                                                    "XMD-63"
 change_element_definition e=violet_9853_3   s=on  pc=((violet_xmd_cm_3 3))
                                                                    "XMD-69"
 change_element_definition e=cobalt_xmd_0   s=on  pc=((cobalt_xmd_cm_2 0))
                                                                    "XMD-2181"
 change_element_definition e=cobalt_xmd_1   s=on  pc=((cobalt_xmd_cm_2 1))
                                                                    "XMD-2182"
 change_element_definition e=cobalt_xmd_2   s=on  pc=((cobalt_xmd_cm_3 2))
                                                                    "XMD-2183"
 change_element_definition e=cobalt_xmd_3   s=on  pc=((cobalt_xmd_cm_3 3))
                                                                    "XMD-2184"
 change_element_definition element=cobalt_7021_2 s=on               "CH33(8)"
 change_element_definition element=c44 s=on pc=((cobalt_7021_2 4))
 change_element_definition element=c45 s=on pc=((cobalt_7021_2 5))
 change_element_definition element=c46 s=on pc=((cobalt_7021_2 6))
 change_element_definition element=c47 s=on pc=((cobalt_7021_2 7))
 change_element_definition element=cobalt_DI_3000c2 state=on "DI294"
delfc $echo output
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
 display_value 'Initializing cobalt_xmd_1 as VSN001'
 initialize_ms_volume element=cobalt_xmd_1 recorded_vsn=VSN001
 display_value 'Initializing cobalt_xmd_2 as VSN002'
 initialize_ms_volume element=cobalt_xmd_2 recorded_vsn=VSN002
 display_value 'Initializing cobalt_xmd_3 as VSN003'
 initialize_ms_volume element=cobalt_xmd_3 recorded_vsn=VSN003
 display_value 'Initializing violet_9853_0 as VSN004'
 initialize_ms_volume element=violet_9853_0 recorded_vsn=VSN004
 display_value 'Initializing violet_9853_1 as VSN005'
 initialize_ms_volume element=violet_9853_1 recorded_vsn=VSN005
 display_value 'Initializing violet_9853_2 as VSN006'
 initialize_ms_volume element=violet_9853_2 recorded_vsn=VSN006
 display_value 'Initializing violet_9853_3 as VSN007'
 initialize_ms_volume element=violet_9853_3 recorded_vsn=VSN007
"ENTER CHAMSC HERE"
"CLASS X WILL CONTAIN SCU_BOUND_PRODUCT"
"CLASS Y WILL CONTAIN FORTRAN_BOUND_PRODUCT"
"CLASS Z WILL CONTAIN COBOL_BOUND_PRODUCT"
CHAMSC VSN000 DC=(X Y Z)
CHAMSC VSN001 DC=(X Y Z)
CHAMSC VSN002 DC=(Y Z)
CHAMSC VSN003 DC=(X Y Z)
CHAMSC VSN004 DC=(X Y)
CHAMSC VSN005 DC=(X Y Z)
CHAMSC VSN006 DC=(X Z)
CHAMSC VSN007 DC=(X Y Z)
 display_value 'Adding VSN001 to set'
 add_volume_to_set member_vsn=VSN001
 display_value 'Adding VSN002 to set'
 add_volume_to_set member_vsn=VSN002
 display_value 'Adding VSN003 to set'
 add_volume_to_set member_vsn=VSN003
 display_value 'Adding VSN004 to set'
 add_volume_to_set member_vsn=VSN004
 display_value 'Adding VSN005 to set'
 add_volume_to_set member_vsn=VSN005
 display_value 'Adding VSN006 to set'
 add_volume_to_set member_vsn=VSN006
 display_value 'Adding VSN007 to set'
 add_volume_to_set member_vsn=VSN007
end_prolog_file

COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
 define_network_connection connected_system=cobalt_DI_3000c2
 define_host_network n=102(10)
end_prolog_file

PROCEND COBALT_BYOPS_XMD_2X8
*DECK DECK=RAI$PROLOG_COBALT_CLOSED_SHOP EXPAND=FALSE
PROCEDURE COBALT_CLOSED_SHOP (
  status)

  COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
    EDIT_PHYSICAL_CONFIGURATION
      change_element_definition element=cobalt_887_1 state=on
      change_element_definition element=cobalt_887_2 state=on
      change_element_definition element=cobalt_887_3 state=on
      change_element_definition element=cobalt_887_4 state=on
      change_element_definition element=cobalt_fa7b5_1 state=on
      change_element_definition element=cobalt_fa7b5_2 state=on
      change_element_definition element=cobalt_fa7b5_5 state=on
      change_element_definition element=cobalt_fa7b5_6 state=on
      change_element_definition element=cobalt_fa7b5_7 state=on
      change_element_definition element=cobalt_fa7b5_8 state=on
      change_element_definition element=cobalt_fa7b5_9 state=on
      change_element_definition element=cobalt_fa7b5_10 state=on
      change_element_definition element=cobalt_fa7b5_13 state=on
      change_element_definition element=cobalt_fa7b5_14 state=on
      change_element_definition element=cobalt_fa7b5_15 state=on
      change_element_definition element=cobalt_fa7b5_16 state=on
      change_element_definition element=cobalt_fa7b5_17 state=on
      change_element_definition element=cobalt_fa7b5_18 state=on
      change_element_definition element=cobalt_fa7b5_19 state=on
      change_element_definition element=cobalt_fa7b5_20 state=on
      change_element_definition element=cobalt_9853_1 state=on
      change_element_definition element=cobalt_9853_2 state=on
      change_element_definition element=cobalt_9853_3 state=on
      change_element_definition element=cobalt_9853_4 state=on
      change_element_definition element=cobalt_9853_9 state=on
      change_element_definition element=cobalt_9853_10 state=on
      change_element_definition element=cobalt_9853_11 state=on
      change_element_definition element=cobalt_9853_12 state=on
      change_element_definition element=cobalt_9853_13 state=on
      change_element_definition element=cobalt_9853_14 state=on
      change_element_definition element=cobalt_9853_15 state=on
      change_element_definition element=cobalt_9853_16 state=on
      change_element_definition element=cobalt_9853_17 state=on
      change_element_definition element=cobalt_9853_18 state=on
      change_element_definition element=cobalt_9853_19 state=on
      change_element_definition element=cobalt_9853_20 state=on
      change_element_definition element=cobalt_9853_25 state=on
      change_element_definition element=cobalt_9853_26 state=on
      change_element_definition element=cobalt_9853_27 state=on
      change_element_definition element=cobalt_9853_28 state=on
      change_element_definition element=cobalt_9853_29 state=on
      change_element_definition element=cobalt_9853_30 state=on
      change_element_definition element=cobalt_9853_31 state=on
      change_element_definition element=cobalt_9853_32 state=on
      change_element_definition element=cobalt_9853_33 state=on
      change_element_definition element=cobalt_9853_34 state=on
      change_element_definition element=cobalt_9853_35 state=on
      change_element_definition element=cobalt_9853_36 state=on
      change_element_definition element=cobalt_9853_37 state=on
      change_element_definition element=cobalt_9853_38 state=on
      change_element_definition element=cobalt_9853_39 state=on
      change_element_definition element=cobalt_9853_40 state=on
      change_element_definition element=cobalt_5698_0 state=on
      change_element_definition element=cobalt_5698_1 state=on
      change_element_definition element=c60 state=on
      change_element_definition element=c61 state=on
      change_element_definition element=c62 state=on
      change_element_definition element=c63 state=on
      change_element_definition element=c64 state=on
      change_element_definition element=c65 state=on
      change_element_definition element=cobalt_5680_1 state=on
      change_element_definition element=cs60 state=on
      change_element_definition element=cs61 state=on
      change_element_definition element=cs64 state=on
      change_element_definition element=cs65 state=on
      change_element_definition element=cobalt_di_30070c state=on
      change_element_definition element=cobalt_di_300070 state=on
      change_element_definition element=cobray_di_3013ad state=on
      change_element_definition element=cobalt_NAD_1 state=on
      change_element_definition element=stornet state=on
    QUIT
end_prolog_file
  COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
    initialize_ms_volume element=cobalt_887_2 recorded_vsn=C87A01
    initialize_ms_volume element=cobalt_887_3 recorded_vsn=C87B00
    initialize_ms_volume element=cobalt_887_4 recorded_vsn=C87B01
    initialize_ms_volume element=cobalt_9853_1 recorded_vsn=C53C00
    initialize_ms_volume element=cobalt_9853_2 recorded_vsn=C53C01
    initialize_ms_volume element=cobalt_9853_3 recorded_vsn=C53C02
    initialize_ms_volume element=cobalt_9853_4 recorded_vsn=C53C03
    initialize_ms_volume element=cobalt_9853_9 recorded_vsn=C53D00
    initialize_ms_volume element=cobalt_9853_10 recorded_vsn=C53D01
    initialize_ms_volume element=cobalt_9853_11 recorded_vsn=C53D02
    initialize_ms_volume element=cobalt_9853_12 recorded_vsn=C53D03
    initialize_ms_volume element=cobalt_9853_13 recorded_vsn=C53F00
    initialize_ms_volume element=cobalt_9853_14 recorded_vsn=C53F01
    initialize_ms_volume element=cobalt_9853_15 recorded_vsn=C53F02
    initialize_ms_volume element=cobalt_9853_16 recorded_vsn=C53F03
    initialize_ms_volume element=cobalt_9853_17 recorded_vsn=C53K00
    initialize_ms_volume element=cobalt_9853_18 recorded_vsn=C53K01
    initialize_ms_volume element=cobalt_9853_19 recorded_vsn=C53K02
    initialize_ms_volume element=cobalt_9853_20 recorded_vsn=C53K03
    initialize_ms_volume element=cobalt_9853_25 recorded_vsn=C53G00
    initialize_ms_volume element=cobalt_9853_26 recorded_vsn=C53G01
    initialize_ms_volume element=cobalt_9853_27 recorded_vsn=C53G02
    initialize_ms_volume element=cobalt_9853_28 recorded_vsn=C53G03
    initialize_ms_volume element=cobalt_9853_29 recorded_vsn=C53H00
    initialize_ms_volume element=cobalt_9853_30 recorded_vsn=C53H01
    initialize_ms_volume element=cobalt_9853_31 recorded_vsn=C53H02
    initialize_ms_volume element=cobalt_9853_32 recorded_vsn=C53H03
    initialize_ms_volume element=cobalt_9853_33 recorded_vsn=C53I00
    initialize_ms_volume element=cobalt_9853_34 recorded_vsn=C53I01
    initialize_ms_volume element=cobalt_9853_35 recorded_vsn=C53I02
    initialize_ms_volume element=cobalt_9853_36 recorded_vsn=C53I03
    initialize_ms_volume element=cobalt_9853_37 recorded_vsn=C53J00
    initialize_ms_volume element=cobalt_9853_38 recorded_vsn=C53J01
    initialize_ms_volume element=cobalt_9853_39 recorded_vsn=C53J02
    initialize_ms_volume element=cobalt_9853_40 recorded_vsn=C53J03
    change_ms_class S87A00 dc=all ac=(a b   d e f g h i           o p q r s t u v w x y z)
    change_ms_class C87A01 dc=all ac=(a b c d e f g h i           o p   r s t u v w x y z)
    change_ms_class C87B00 dc=all ac=(a b   d e f g h i j   l m   o p   r s t u v w x y z)
    change_ms_class C87B01 dc=all ac=(a b   d e f g h i   k   m   o p   r s t u v w x y z)
    change_ms_class C53C00 dc=all ac=(a b   d e f g h i j k l m   o p   r s t u v w x y z)
    change_ms_class C53C01 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53C02 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53C03 dc=all ac=(a b   d e f g h i         n o p   r s t u v w x y z)
    change_ms_class C53D00 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53D01 dc=all ac=(a b   d e f g h i j k l     o p   r s t u v w x y z)
    change_ms_class C53D02 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53D03 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53F00 dc=all ac=(a b   d e f g h i j k l m   o p   r s t u v w x y z)
    change_ms_class C53F01 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53F02 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53F03 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53G00 dc=all ac=(a b   d e f g h i       m n o p   r s t u v w x y z)
    change_ms_class C53G01 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53G02 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53G03 dc=all ac=(a b   d e f g h i   k       o p   r s t u v w x y z)
    change_ms_class C53H00 dc=all ac=(a b   d e f g h i       m n o p   r s t u v w x y z)
    change_ms_class C53H01 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53H02 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53H03 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53I00 dc=all ac=(a b   d e f g h i       m n o p   r s t u v w x y z)
    change_ms_class C53I01 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53I02 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53I03 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53J00 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53J01 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53J02 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53J03 dc=all ac=(a b   d e f g h i     l m   o p   r s t u v w x y z)
    change_ms_class C53K00 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53K01 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53K02 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    change_ms_class C53K03 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
    add_volume_to_set member_vsn=C87A01 set_name=cobalt_system
    add_volume_to_set member_vsn=C87B00 set_name=cobalt_system
    add_volume_to_set member_vsn=C87B01 set_name=cobalt_system
    add_volume_to_set member_vsn=C53G03 set_name=cobalt_system
    create_set        master_vsn=C53C00 set_name=cobalt_integration
    add_volume_to_set member_vsn=C53C01 set_name=cobalt_integration
    add_volume_to_set member_vsn=C53D00 set_name=cobalt_integration
    add_volume_to_set member_vsn=C53K00 set_name=cobalt_integration
    add_volume_to_set member_vsn=C53K01 set_name=cobalt_integration
    add_volume_to_set member_vsn=C53K02 set_name=cobalt_integration
    add_volume_to_set member_vsn=C53K03 set_name=cobalt_integration
    create_set        master_vsn=C53F00 set_name=nveset
    add_volume_to_set member_vsn=C53F01 set_name=nveset
    add_volume_to_set member_vsn=C53F02 set_name=nveset
    add_volume_to_set member_vsn=C53F03 set_name=nveset
    create_set        master_vsn=C53D01 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53C02 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53C03 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53D02 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53D03 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53G00 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53G01 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53G02 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53G03 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53H00 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53H01 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53H02 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53H03 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53I00 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53I01 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53I02 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53I03 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53J00 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53J01 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53J02 set_name=cobalt_nveset
    add_volume_to_set member_vsn=C53J03 set_name=cobalt_nveset
end_prolog_file

  COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
end_prolog_file

PROCEND COBALT_CLOSED_SHOP
*DECK DECK=RAI$PROLOG_COBALT_XMD_1X4 EXPAND=FALSE
PROCEDURE COBALT_XMD_1X4 (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
 delete_element_definition e=all r=(..
 cobalt_xmd_cm_2 ..
 cobalt_xmd_cm_3 ..
 cobalt_xmd_0 ..
 cobalt_xmd_1 ..
 cobalt_xmd_2 ..
 cobalt_xmd_3 ..
 cobalt_7021_2 ..
 c44 ..
 c45 ..
 c46 ..
 c47 ..
 cobalt_DI_3000c2)

 change_element_definition e=cobalt_xmd_cm_2 s=on  ic=((cch7b 2))
 change_element_definition e=cobalt_xmd_cm_3 s=on  ic=((cch7b 3))
 change_element_definition e=cobalt_xmd_0    s=on  pc=((cobalt_xmd_cm_2 0))
                                                                    "XMD-2181"
 change_element_definition e=cobalt_xmd_1    s=on  pc=((cobalt_xmd_cm_2 1))
                                                                    "XMD-2182"
 change_element_definition e=cobalt_xmd_2    s=on  pc=((cobalt_xmd_cm_3 2))
                                                                    "XMD-2183"
 change_element_definition e=cobalt_xmd_3    s=on  pc=((cobalt_xmd_cm_3 3))
                                                                    "XMD-2184"
 change_element_definition element=cobalt_7021_2 s=on               "CH33(8)"
 change_element_definition element=c44 s=on pc=((cobalt_7021_2 4))
 change_element_definition element=c45 s=on pc=((cobalt_7021_2 5))
 change_element_definition element=c46 s=on pc=((cobalt_7021_2 6))
 change_element_definition element=c47 s=on pc=((cobalt_7021_2 7))
 change_element_definition element=cobalt_DI_3000c2 state=on "DI294"
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
 display_value 'Initializing cobalt_xmd_1 as VSN001'
 initialize_ms_volume element=cobalt_xmd_1 recorded_vsn=VSN001
 display_value 'Initializing cobalt_xmd_2 as VSN002'
 initialize_ms_volume element=cobalt_xmd_2 recorded_vsn=VSN002
 display_value 'Initializing cobalt_xmd_3 as VSN003'
 initialize_ms_volume element=cobalt_xmd_3 recorded_vsn=VSN003
"ENTER CHAMSC HERE"
"CLASS X WILL CONTAIN SCU_BOUND_PRODUCT"
"CLASS Y WILL CONTAIN FORTRAN_BOUND_PRODUCT"
"CLASS Z WILL CONTAIN COBOL_BOUND_PRODUCT"
CHAMSC VSN000 DC=(X Y Z)
CHAMSC VSN001 DC=(Y Z)
CHAMSC VSN002 DC=(X Y)
CHAMSC VSN003 DC=(X Z)
display_value 'Adding VSN001 to set'
add_volume_to_set member_vsn=VSN001
display_value 'Adding VSN002 to set'
add_volume_to_set member_vsn=VSN002
display_value 'Adding VSN003 to set'
add_volume_to_set member_vsn=VSN003
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_network_connection connected_system=cobalt_DI_3000c2
define_host_network n=102(10)
end_prolog_file

PROCEND COBALT_XMD_1X4
*DECK DECK=RAI$PROLOG_COPPER_CLOSED_SHOP EXPAND=TRUE
PROCEDURE COPPER_CLOSED_SHOP (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
" ENABLE DISK ELEMENTS NORMALLY USED BY NOS/VE"
change_element_definition element=copper_887_0 state=on
change_element_definition element=copper_887_1 state=on
change_element_definition element=copper_887_2 state=on
change_element_definition element=copper_887_3 state=on
change_element_definition element=copper_887_4 state=on
change_element_definition element=copper_887_5 state=on
change_element_definition element=copper_887_6 state=on
change_element_definition element=copper_887_7 state=on
change_element_definition element=copper_7155_1 state=on
change_element_definition element=copper_885_0 state=on
change_element_definition element=copper_fa7b5_0 state=on
change_element_definition element=copper_fa7b5_1 state=on
change_element_definition element=copper_fa7b5_2 state=on
change_element_definition element=copper_fa7b5_3 state=on
change_element_definition element=copper_fa7b5_4 state=on
change_element_definition element=copper_fa7b5_5 state=on
change_element_definition element=copper_fa7b5_6 state=on
change_element_definition element=copper_fa7b5_7 state=on
change_element_definition element=copper_fa7b5_8 state=on
change_element_definition element=copper_fa7b5_9 state=on
change_element_definition element=copper_9853_0 state=on
change_element_definition element=copper_9853_1 state=on
change_element_definition element=copper_9853_2 state=on
change_element_definition element=copper_9853_3 state=on
change_element_definition element=copper_9853_4 state=on
change_element_definition element=copper_9853_5 state=on
change_element_definition element=copper_9853_6 state=on
change_element_definition element=copper_9853_7 state=on
change_element_definition element=copper_9853_8 state=on
change_element_definition element=copper_9853_9 state=on
change_element_definition element=copper_9853_10 state=on
change_element_definition element=copper_9853_11 state=on
change_element_definition element=copper_9853_12 state=on
change_element_definition element=copper_9853_13 state=on
change_element_definition element=copper_9853_14 state=on
change_element_definition element=copper_9853_15 state=on
change_element_definition element=copper_9853_16 state=on
change_element_definition element=copper_9853_17 state=on
change_element_definition element=copper_9853_18 state=on
change_element_definition element=copper_9853_19 state=on
" ENABLE TAPE ELEMENTS NORMALLY USED BY NOS/VE
change_element_definition element=copper_5698_1 state=on
change_element_definition element=copper_5698_2 state=on
change_element_definition element=c51 state=on
change_element_definition element=c52 state=on
change_element_definition element=c53 state=on
change_element_definition element=c54 state=on
" ENABLE DI ELEMENTS NORMALLY USED BY NOS/VE
change_element_definition element=copper_DI_3000aa state=on
change_element_definition element=copper_NAD_1 state=on
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
initialize_ms_volume element=copper_887_1    recorded_vsn=c87a01
initialize_ms_volume element=copper_887_2    recorded_vsn=c87b00
initialize_ms_volume element=copper_887_3    recorded_vsn=c87b01
initialize_ms_volume element=copper_887_4    recorded_vsn=c87c00
initialize_ms_volume element=copper_887_5    recorded_vsn=c87c01
initialize_ms_volume element=copper_887_6    recorded_vsn=c87d00
initialize_ms_volume element=copper_887_7    recorded_vsn=c87d01
initialize_ms_volume element=copper_885_0    recorded_vsn=c85e32
initialize_ms_volume element=copper_9853_0   recorded_vsn=c53z00
initialize_ms_volume element=copper_9853_1   recorded_vsn=c53z01
initialize_ms_volume element=copper_9853_2   recorded_vsn=c53z02
initialize_ms_volume element=copper_9853_3   recorded_vsn=c53z03
initialize_ms_volume element=copper_9853_4   recorded_vsn=c53y00
initialize_ms_volume element=copper_9853_5   recorded_vsn=c53y01
initialize_ms_volume element=copper_9853_6   recorded_vsn=c53y02
initialize_ms_volume element=copper_9853_7   recorded_vsn=c53y03
initialize_ms_volume element=copper_9853_8   recorded_vsn=c53x00
initialize_ms_volume element=copper_9853_9   recorded_vsn=c53x01
initialize_ms_volume element=copper_9853_10  recorded_vsn=c53x02
initialize_ms_volume element=copper_9853_11  recorded_vsn=c53x03
initialize_ms_volume element=copper_9853_12  recorded_vsn=c53w00
initialize_ms_volume element=copper_9853_13  recorded_vsn=c53w01
initialize_ms_volume element=copper_9853_14  recorded_vsn=c53w02
initialize_ms_volume element=copper_9853_15  recorded_vsn=c53w03
initialize_ms_volume element=copper_9853_16  recorded_vsn=c53u00
initialize_ms_volume element=copper_9853_17  recorded_vsn=c53u01
initialize_ms_volume element=copper_9853_18  recorded_vsn=c53u02
initialize_ms_volume element=copper_9853_19  recorded_vsn=c53u03

change_ms_class recorded_vsn=s87a00 dc=all ac=(a b   d e f g h i           o p q r s t u v w x y z)
change_ms_class recorded_vsn=c87a01 dc=all ac=(a b   d e f g h i j   l     o p   r s t u v w x y z)
change_ms_class recorded_vsn=c87b00 dc=all ac=(a b c d e f g h i           o p   r s t u v w x y z)
change_ms_class recorded_vsn=c87b01 dc=all ac=(a b c d e f g h i           o p   r s t u v w x y z)
change_ms_class recorded_vsn=c87c00 dc=all ac=(a b   d e f g h i           o p   r s t u v w x y z)
change_ms_class recorded_vsn=c87c01 dc=all ac=(a b   d e f g h i           o p   r s t u v w x y z)
change_ms_class recorded_vsn=c87d00 dc=all ac=(a b   d e f g h i           o p   r s t u v w x y z)
change_ms_class recorded_vsn=c87d01 dc=all ac=(a b   d e f g h i           o p   r s t u v w x y z)
change_ms_class recorded_vsn=c85e32 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53z00 dc=all ac=(a b   d e f g h i   k       o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53z01 dc=all ac=(a b   d e f g h i   k       o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53z02 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53z03 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53y00 dc=all ac=(a b   d e f g h i         n o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53y01 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53y02 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53y03 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53x00 dc=all ac=(a b   d e f g h i       m n o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53x01 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53x02 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53x03 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53w00 dc=all ac=(a b   d e f g h i       m n o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53w01 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53w02 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53w03 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53u00 dc=all ac=(a b   d e f g h i       m n o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53u01 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53u02 dc=all ac=(a b   d e f g h i           o p   r s t u v w x y z)
change_ms_class recorded_vsn=c53u03 dc=all ac=(a b   d e f g h i           o p   r s t u v w x y z)

add_volume_to_set member_vsn=c87a01 set_name=nveset
add_volume_to_set member_vsn=c87b00 set_name=nveset
add_volume_to_set member_vsn=c87b01 set_name=nveset
add_volume_to_set member_vsn=c87c00 set_name=nveset
add_volume_to_set member_vsn=c87c01 set_name=nveset
add_volume_to_set member_vsn=c87d00 set_name=nveset
add_volume_to_set member_vsn=c87d01 set_name=nveset
add_volume_to_set member_vsn=c85e32 set_name=nveset
add_volume_to_set member_vsn=c53z00 set_name=nveset
add_volume_to_set member_vsn=c53z01 set_name=nveset
add_volume_to_set member_vsn=c53z02 set_name=nveset
add_volume_to_set member_vsn=c53z03 set_name=nveset
add_volume_to_set member_vsn=c53y00 set_name=nveset
add_volume_to_set member_vsn=c53y01 set_name=nveset
add_volume_to_set member_vsn=c53y02 set_name=nveset
add_volume_to_set member_vsn=c53y03 set_name=nveset
add_volume_to_set member_vsn=c53x00 set_name=nveset
add_volume_to_set member_vsn=c53x01 set_name=nveset
add_volume_to_set member_vsn=c53x02 set_name=nveset
add_volume_to_set member_vsn=c53x03 set_name=nveset
add_volume_to_set member_vsn=c53w00 set_name=nveset
add_volume_to_set member_vsn=c53w01 set_name=nveset
add_volume_to_set member_vsn=c53w02 set_name=nveset
add_volume_to_set member_vsn=c53w03 set_name=nveset
add_volume_to_set member_vsn=c53u00 set_name=nveset
add_volume_to_set member_vsn=c53u01 set_name=nveset
add_volume_to_set member_vsn=c53u02 set_name=nveset
add_volume_to_set member_vsn=c53u03 set_name=nveset
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
end_prolog_file

PROCEND COPPER_CLOSED_SHOP
*DECK DECK=RAI$PROLOG_EST_860_A EXPAND=TRUE
PROCEDURE est_860_a (
  status)

COLLECT_TEXT $local.pcu_subcommands until='END_PROLOG_FILE'
EDIT_PHYSICAL_CONFIGURATION
" 844/885 controller
change_element_definition e=es1_7155_1 s=on
" 885 disk drives
change_element_definition e=es1_885_42 s=on
change_element_definition e=es1_885_43 s=on
" 67x tape controller
change_element_definition e=es1_7021 s=on
" 67x tape drives
change_element_definition e=nt0 s=on
change_element_definition e=nt1 s=on
" 698 tape controller (Hitachi)
change_element_definition e=es1_698 s=on
" 698 tape drives (Hitachi)
change_element_definition e=ht0 s=on
change_element_definition e=ht1 s=on
" NAD
change_element_definition e=es1_NAD_1 s=on
" DI
change_element_definition e=es1_DI_30032e ei=$2620_210 s=on
quit
END_PROLOG_FILE
collect_text $local.lcu_mainframe_subcommands until='END_PROLOG_FILE'
 display_value 'Initializing ES1_885_43 as V88543'
 initialize_ms_volume element=es1_885_43 recorded_vsn=v88543
 display_value 'Adding V88543 to set'
 add_volume_to_set member_vsn=v88543
END_PROLOG_FILE
collect_text $local.lcu_network_subcommands until='END_PROLOG_FILE'
define_network_connection connected_system=es1_DI_30032e
define_host_network n=341(16)
END_PROLOG_FILE

PROCEND est_860_a
*DECK DECK=RAI$PROLOG_EST_860_B EXPAND=TRUE
PROCEDURE est_860_b (
  status)

COLLECT_TEXT $local.pcu_subcommands until='END_PROLOG_FILE'
EDIT_PHYSICAL_CONFIGURATION
" 895 disk controller
change_element_definition e=es1_7165_1 s=on
" 895 disk drives
change_element_definition e=es1_895_0 s=on
change_element_definition e=es1_895_1 s=on
change_element_definition e=es1_895_2 s=on
change_element_definition e=es1_895_3 s=on
" 67x tape controller
change_element_definition e=es1_7021 s=on
" 67x tape drives
change_element_definition e=nt0 s=on
change_element_definition e=nt1 s=on
" 698 tape controller (Hitachi)
change_element_definition e=es1_698 s=on
" 698 tape drives (Hitachi)
change_element_definition e=ht0 s=on
change_element_definition e=ht1 s=on
" NAD
change_element_definition e=es1_NAD_1 s=on
" DI
change_element_definition e=es1_DI_30032e ei=$2620_210 s=on
quit
END_PROLOG_FILE
collect_text $local.lcu_mainframe_subcommands until='END_PROLOG_FILE'
 display_value 'Initializing ES1_895_1 as V89501'
 initialize_ms_volume element=es1_895_1 recorded_vsn=v89501
 display_value 'Adding V89501 to set'
 add_volume_to_set member_vsn=v89501
 display_value 'Initializing ES1_895_2 as V89502'
 initialize_ms_volume element=es1_895_2 recorded_vsn=v89502
 display_value 'Adding V89502 to set'
 add_volume_to_set member_vsn=v89502
 display_value 'Initializing ES1_895_3 as V89503'
 initialize_ms_volume element=es1_895_3 recorded_vsn=v89503
 display_value 'Adding V89503 to set'
 add_volume_to_set member_vsn=v89503
END_PROLOG_FILE
collect_text $local.lcu_network_subcommands until='END_PROLOG_FILE'
define_network_connection connected_system=es1_DI_30032e
define_host_network n=341(16)
END_PROLOG_FILE

PROCEND est_860_b
*DECK DECK=RAI$PROLOG_GRAY_OPEN_USAGE EXPAND=FALSE
PROCEDURE gray_open_usage (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
 delete_element_definition e=all r=(..
  gray_fa7b5_0 ..
  gray_fa7b5_1 ..
  gray_9853_28 ..
  gray_9853_29 ..
  gray_9853_30 ..
  gray_9853_31 ..
  gray_c32 ..
  gray_c13 ..
  g70 ..
  g71 ..
  g72 ..
  g73 ..
  gray_di_300119 ..
  cobray_di_3013ad ..
  gray_5680_1 ..
  gs67 ..
  gray_nad_1 ..
  stornet)
change_element_definition gray_fa7b5_0 s=on ic=((cch3b 0))
change_element_definition gray_fa7b5_1 s=on ic=((cch3b 1))
change_element_definition gray_9853_28 s=on pc=((gray_fa7b5_0 0))
change_element_definition gray_9853_29 s=on pc=((gray_fa7b5_0 1))
change_element_definition gray_9853_30 s=on pc=((gray_fa7b5_1 2))
change_element_definition gray_9853_31 s=on pc=((gray_fa7b5_1 3))
change_element_definition gray_c32 s=on
change_element_definition g70 s=on
change_element_definition g71 s=on
change_element_definition g72 s=on
change_element_definition g73 s=on
change_element_definition gray_DI_300119 s=on
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
display_value 'Initializing gray_9853_29 as VSN001'
initialize_ms_volume element=gray_9853_29 recorded_vsn=VSN001
display_value 'Initializing gray_9853_30 as VSN002'
initialize_ms_volume element=gray_9853_30 recorded_vsn=VSN002
display_value 'Initializing gray_9853_31 as VSN003'
initialize_ms_volume element=gray_9853_31 recorded_vsn=VSN003
display_value 'Adding VSN001 to set'
add_volume_to_set member_vsn=VSN001
display_value 'Adding VSN002 to set'
add_volume_to_set member_vsn=VSN002
display_value 'Adding VSN003 to set'
add_volume_to_set member_vsn=VSN003
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_network_connection connected_system=gray_DI_300119
define_host_network n=311(10)
end_prolog_file
PROCEND gray_open_usage
*DECK DECK=RAI$PROLOG_MAUVE_OPEN_USAGE EXPAND=TRUE
PROCEDURE mauve_open_usage (
  status)

collect_text $local.pcu_subcommands until='END_PROLOG_FILE'
EDIT_PHYSICAL_CONFIGURATION
 delete_element_definition e=all r=(..
  m_7155_1510 ..
  fmd_44_27401 ..
  fmd_45_27401 ..
  mauve_7021_1 ..
  ma50 ..
  ma51 ..
  ma52 ..
  stornet ..
  mau_DI_100087 ..
  mau_DI_3000D6 ..
  mau_DI_3001B0 ..
  mau_DI_300420 ..
  mau_DI_10007F ..
  mau_DI_300116)

 change_element_definition e=m_7155_1510 s=on "CH0"
 change_element_definition e=fmd_44_27401 s=on
 change_element_definition e=fmd_45_27401 s=on
 change_element_definition e=mauve_7021_1 s=on "CH13(8)"
 change_element_definition e=ma50 s=on  pc=((mauve_7021_1 0))
 change_element_definition e=ma51 s=on  pc=((mauve_7021_1 1))
 change_element_definition e=ma52 s=off pc=((mauve_7021_1 2))
 change_element_definition e=stornet       s=on
 change_element_definition e=mau_di_300116 s=on "SN378"
quit
END_PROLOG_FILE
collect_text $local.lcu_mainframe_subcommands until='END_PROLOG_FILE'
display_value 'Initializing FMD_45_27401 as P88501'
initialize_ms_volume element=FMD_45_27401 recorded_vsn=P88501
display_value 'Adding P88501 to the set.'
add_volume_to_set member_vsn=P88501
END_PROLOG_FILE
collect_text $local.lcu_network_subcommands until='END_PROLOG_FILE'
define_network_connection connected_system=mau_di_300116
define_host_network n=104(16)
END_PROLOG_FILE

PROCEND mauve_open_usage
*DECK DECK=RAI$PROLOG_MAUVE_SHARED_LAB EXPAND=FALSE
PROCEDURE mauve_shared_lab (
  status)

collect_text $local.pcu_subcommands until='END_PROLOG_FILE'
EDIT_PHYSICAL_CONFIGURATION
 delete_element_definition e=all r=(..
  violet_xmd_cm_4 ..
  violet_xmd_cm_5 ..
  violet_9853_6 ..
  violet_9853_7 ..
  hyd0_violet ..
  hyd1_violet ..
  hyd2_violet ..
  hyd3_violet ..
  stornet ..
  violet_7021_1 ..
  violet_7021_2 ..
  v50 ..
  v51 ..
  v52 ..
  v55 ..
  violet_5680_3 ..
  ctd6 ..
  ctd7 ..
  cts0 ..
  cts1 ..
  cts2 ..
  cts3 ..
  violet_DI_100087 ..
  violet_DI_100092 ..
  violet_DI_10007f ..
  violet_DI_300116 ..
  violet_DI_300420 ..
  violet_DI_3000a0 ..
  violet_DI_3000f0)
  xlink_violet ..
 change_element_definition e=hyd0_violet s=off "CCH7a"
 change_element_definition e=hyd1_violet s=off "CCH7a"
 change_element_definition e=violet_xmd_cm_4 s=on "CCH8b"
 change_element_definition e=violet_xmd_cm_5 s=on "CCH8b"
 change_element_definition e=violet_9853_6   s=on "CCH8b"
 change_element_definition e=violet_9853_7   s=on "CCH8b"
 change_element_definition e=hyd2_violet s=on "CCH7a"
 change_element_definition e=hyd2_violet s=on "CCH7a"
 change_element_definition e=hyd2_violet s=on "CCH7a"
 change_element_definition e=hyd3_violet s=on "CCH7a"
 change_element_definition e=violet_7021_1 s=on "CH27(8)"
 "change_element_definition e=violet_7021_2 s=on
 change_element_definition e=v50 s=on  pc=((violet_7021_1 0))
 change_element_definition e=v51 s=on  pc=((violet_7021_1 1))
 change_element_definition e=v52 s=off pc=((violet_7021_1 2))
 change_element_definition e=v55 s=on  pc=((violet_7021_1 5))
 change_element_definition e=stornet       s=on
 change_element_definition e=xlink_violet     s=off "EXPRESS LINK to LIZZIE"
 change_element_definition e=violet_DI_100087 s=off "SN135"
 change_element_definition e=violet_DI_100092 s=off "SN146"
 change_element_definition e=violet_DI_10007f s=on  "SN127"
 change_element_definition e=violet_DI_300116 s=on  "SN378 VE DI"
 change_element_definition e=violet_DI_300420 s=on  "SN1056"
 change_element_definition e=violet_DI_3000a0 s=on  "SN260"
 change_element_definition e=violet_DI_3000f0 s=on  "SN340"
quit
END_PROLOG_FILE
collect_text $local.lcu_mainframe_subcommands until='END_PROLOG_FILE'
display_value 'Initializing violet_9853_7 as Sxmd07'
initialize_ms_volume element=violet_9853_7 recorded_vsn=sxmd07
display_value 'Initializing hyd2_violet as S88702'
initialize_ms_volume element=hyd2_violet recorded_vsn=S88702
display_value 'Initializing hyd3_violet as S88703'
initialize_ms_volume element=hyd3_violet recorded_vsn=S88703
display_value 'Adding Sxmd07 to the set.'
add_volume_to_set member_vsn=sxmd07
display_value 'Adding S88702 to the set.'
add_volume_to_set member_vsn=S88702
display_value 'Adding S88703 to the set.'
add_volume_to_set member_vsn=S88703
change_ms_class rv=sxmd06 dc=(c l m n)
change_ms_class rv=sxmd07 dc=(c q)
change_ms_class rv=s88702 dc=(c q)
change_ms_class rv=s88703 dc=all ac=(a c)
END_PROLOG_FILE
collect_text $local.lcu_network_subcommands until='END_PROLOG_FILE'
END_PROLOG_FILE

PROCEND mauve_shared_lab
*DECK DECK=RAI$PROLOG_MAUVE_SHORTLOOKS EXPAND=TRUE
PROCEDURE mauve_shortlooks (
  status)

collect_text $local.pcu_subcommands until='END_PROLOG_FILE'
EDIT_PHYSICAL_CONFIGURATION
 delete_element_definition e=all r=(..
  m_7155_1510 ..
  m_7155_2987 ..
  fmd_46_3641 ..
  fmd_47_3641 ..
  fmd_46_8377 ..
  fmd_46_8377 ..
  mauve_7021_1 ..
  ma50 ..
  ma51 ..
  ma52 ..
  mau_DI_100087 ..
  mau_DI_3000D6 ..
  mau_DI_3001B0 ..
  mau_DI_300420 ..
  mau_DI_10007F ..
  mau_DI_300116)

 change_element_definition e=m_7155_1510 s=on "CH0"
 change_element_definition e=m_7155_2987 s=on "CH21(8)"
 change_element_definition e=fmd_46_3641 s=on pc=((m_7155_1510 38))
 change_element_definition e=fmd_47_3641 s=on pc=((m_7155_1510 39))
 change_element_definition e=fmd_46_8377 s=on pc=((m_7155_2987 38))
 change_element_definition e=fmd_47_8377 s=on pc=((m_7155_2987 39))
 change_element_definition e=mauve_7021_1 s=on "CH13(8)"
 change_element_definition e=ma50 s=on  pc=((mauve_7021_1 0))
 change_element_definition e=ma51 s=on  pc=((mauve_7021_1 1))
 change_element_definition e=ma52 s=off pc=((mauve_7021_1 2))
 change_element_definition e=mau_di_300116 s=on "SN378"
quit
END_PROLOG_FILE
collect_text $local.lcu_mainframe_subcommands until='END_PROLOG_FILE'
display_value 'Initializing FMD_47_3641 as S88501'
initialize_ms_volume element=FMD_47_3641 recorded_vsn=S88501
display_value 'Initializing FMD_46_8377 as S88502'
initialize_ms_volume element=FMD_46_8377 recorded_vsn=S88502
display_value 'Initializing FMD_47_8377 as S88544'
initialize_ms_volume element=FMD_47_8377 recorded_vsn=S88503
display_value 'Adding S88501 to the set.'
add_volume_to_set member_vsn=S88501
display_value 'Adding S88502 to the set.'
add_volume_to_set member_vsn=S88502
display_value 'Adding S88503 to the set.'
add_volume_to_set member_vsn=S88503
END_PROLOG_FILE
collect_text $local.lcu_network_subcommands until='END_PROLOG_FILE'
END_PROLOG_FILE

PROCEND mauve_shortlooks
*DECK DECK=RAI$PROLOG_NAVY_ISD2_2X2 EXPAND=FALSE
PROCEDURE NAVY_ISD2_2X2 (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
crefc $echo output
 change_element_definition e=cm_11_0    s=on  "Disk channels 1(8)"
"change_element_definition e=cm_23_1    s=on" "Disk channels 23(8)"

 change_element_definition e=disk_11_0  s=on  "ISD2 - Unit 1"
"change_element_definition e=disk_23_0  s=on" "ISD2 - Unit 2"

 change_element_definition e=tape_adapter_a  s=on    "Tape channel 4"
 change_element_definition e=tape_a1         s=on    "Tape unit 0"

 change_element_definition e=ICA_0           s=on    "Ica channel 0"

 change_element_definition e=IVB_5           s=on    "IVB channel 5(8)"
 change_element_definition e=IVB_25          s=on    "IVB channel 25(8)"

delfc $echo output
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
"display_value 'Initializing disk_23_1 as DISK01'
"initialize_ms_volume element=disk_23_1 recorded_vsn=DISK01
"display_value 'adding DISK01 to set'
"add_volume_to_set member_vsn=disk01
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_host_network n=0a203(16)
define_network_connection connected_system=ica_0 system_identifier=400239(16)
define_network_connection connected_system=ivb_5
"define_network_connection connected_system=ivb_21
define_network_connection connected_system=ivb_25
define_tcpip_host 'navy.ahse.cdc.com'
end_prolog_file

PROCEND NAVY_ISD2_2X2

*DECK DECK=RAI$PROLOG_NAVY_ISD2_3X4 EXPAND=FALSE
PROCEDURE NAVY_ISD2_3X4 (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
crefc $echo output
 change_element_definition e=cm_11_0    s=on  "Disk channels 1(8)"
"change_element_definition e=cm_21_0    s=on  "Disk channels 25(8)"
 change_element_definition e=cm_21_1    s=on  "Disk channels 25(8)"

"change_element_definition e=disk_11_0  s=on  "ISD2 - Unit 0"
 change_element_definition e=disk_21_0  s=on  "ISD2 - Unit 0"
 change_element_definition e=disk_21_1  s=on  "ISD2 - Unit 1"
 change_element_definition e=disk_21_2  s=on  "ISD2 - Unit 2"

 change_element_definition e=tape_adapter_a  s=on    "Tape channel 4"
 change_element_definition e=tape_a1         s=on    "Tape unit 0"

 change_element_definition e=ICA_0           s=on    "Ica channel 0"

 change_element_definition e=IVB_5           s=on    "IVB channel 5(8)"
 change_element_definition e=IVB_21          s=on    "IVB channel 21(8)"
 change_element_definition e=IVB_25          s=on    "IVB channel 25(8)"

delfc $echo output
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
"display_value 'Initializing disk_21_0 as DISK01'
"initialize_ms_volume element=disk_21_0 recorded_vsn=DISK01
 display_value 'Initializing disk_21_1 as DISK02'
 initialize_ms_volume element=disk_21_1 recorded_vsn=DISK02
 display_value 'Initializing disk_21_2 as DISK03'
 initialize_ms_volume element=disk_21_2 recorded_vsn=DISK03
"display_value 'adding DISK01 to set'
"add_volume_to_set member_vsn=disk01
 display_value 'adding DISK02 to set'
 add_volume_to_set member_vsn=disk02
 display_value 'adding DISK03 to set'
 add_volume_to_set member_vsn=disk03
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_host_network n=0a203(16)
define_network_connection connected_system=ica_0 system_identifier=400239(16)
define_network_connection connected_system=ivb_5
define_network_connection connected_system=ivb_21
define_network_connection connected_system=ivb_25
define_tcpip_host 'navy.fastlink'
end_prolog_file

PROCEND NAVY_ISD2_3X4
*DECK DECK=RAI$PROLOG_ORANGE_FMD_2X2 EXPAND=FALSE

*DECK DECK=RAI$PROLOG_ORANGE_FMD_2X4_B EXPAND=FALSE
PROCEDURE ORANGE_FMD_2X4_B (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
crefc $echo output
 change_element_definition e=orange_7155_2 s=on "Disk Channel 26(8)"
 change_element_definition e=orange_7155_3 s=on "Disk Channel  6(8)"
 change_element_definition e=orange_885_4 s=on  "FMD Unit 44(8)"
 change_element_definition e=orange_885_5 s=on  "FMD Unit 45(8)"
 change_element_definition e=orange_885_6 s=on  "FMD Unit 46(8)"
 change_element_definition e=orange_885_7 s=on  "FMD Unit 47(8)"
 change_element_definition e=orange_7021_2 s=on "Tape Channel 32(8)"
 change_element_definition e=o50 s=on           "Tape Unit 0"
 change_element_definition e=o51 s=on           "Tape Unit 1"
 change_element_definition e=orange_DI_100093 s=on "DI 147"
delfc $echo output
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
 display_value 'Initializing orange_885_5 as VSN045'
 initialize_ms_volume element=orange_885_5 recorded_vsn=VSN045
 display_value 'Initializing orange_885_6 as VSN046'
 initialize_ms_volume element=orange_885_6 recorded_vsn=VSN046
 display_value 'Initializing orange_885_7 as VSN047'
 initialize_ms_volume element=orange_885_7 recorded_vsn=VSN047
 display_value 'Adding VSN045 to set'
 add_volume_to_set member_vsn=VSN045
 display_value 'Adding VSN046 to set'
 add_volume_to_set member_vsn=VSN046
 display_value 'Adding VSN047 to set'
 add_volume_to_set member_vsn=VSN047
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_channel_network n=002(16) cs=orange_DI_100093 rr=false
define_host_network n=002(10)
end_prolog_file

PROCEND ORANGE_FMD_2X4_B
*DECK DECK=RAI$PROLOG_PEWTER_CLOSED_SHOP EXPAND=FALSE
" DECK: RAI$PROLOG_PEWTER_CLOSED_SHOP
$local.create_prolog_file prolog_name=pewter_closed_shop ..
      file=pcu_subcommands
EDIT_PHYSICAL_CONFIGURATION
crefc $echo output
 change_element_definition e=pewter_cm_0 s=on
 change_element_definition e=pewter_cm_1 s=on
 change_element_definition e=pewter_9836_0 s=on  "ISD2 - Unit 00"
 change_element_definition e=pewter_9836_1 s=on  "ISD2 - Unit 01"
 change_element_definition e=pewter_9836_2 s=on  "ISD2 - Unit 12"
 change_element_definition e=pewter_9836_3 s=on  "ISD2 - Unit 13"
 change_element_definition e=pewter_7221_1  s=on  "Tape Channel 4"
 change_element_definition e=pew1  s=on           "Tape Unit 0"
 change_element_definition e=pew2  s=on           "Tape Unit 1"
 change_element_definition e=pewter_ICA_0   s=on  "ICA - CH00"
 change_element_definition e=pewter_ICA_16  s=on  "ICA - CH16"
delfc $echo output
QUIT
**
$local.create_prolog_file prolog_name=pewter_closed_shop ..
      file=lcu_mainframe_subcommands
 display_value 'Initializing pewter_9836_1 as v36a01'
 initialize_ms_volume element=pewter_9836_1 recorded_vsn=v36a01
 display_value 'Initializing pewter_9836_2 as v36a02'
 initialize_ms_volume element=pewter_9836_2 recorded_vsn=v36a02
 display_value 'Initializing pewter_9836_3 as v36a03'
 initialize_ms_volume element=pewter_9836_3 recorded_vsn=v36a03
 display_value 'Adding v36a01 to set'
 add_volume_to_set member_vsn=v36a01
 display_value 'Adding v36a02 to set'
 add_volume_to_set member_vsn=v36a02
 display_value 'Adding v36a03 to set'
 add_volume_to_set member_vsn=v36a03
**


*DECK DECK=RAI$PROLOG_PEWTER_ISD2_4X8 EXPAND=TRUE
PROCEDURE PEWTER_ISD2_4X8 (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
crefc $echo output
 change_element_definition e=pewter_cm_0 s=on  ic=((ch1 0))
 change_element_definition e=pewter_cm_1 s=on  ic=((ch17 1))
 change_element_definition e=pewter_cm_2 s=on  ic=((ch3 0))
 change_element_definition e=pewter_cm_3 s=on  ic=((ch19 1))
 change_element_definition e=pewter_9836_0 s=on  "ISD2 - Unit 00"
 change_element_definition e=pewter_9836_1 s=on  "ISD2 - Unit 01"
 change_element_definition e=pewter_9836_2 s=on  "ISD2 - Unit 12"
 change_element_definition e=pewter_9836_3 s=on  "ISD2 - Unit 13"
 change_element_definition e=pewter_9836_4 s=on  "ISD2 - Unit 00"
 change_element_definition e=pewter_9836_5 s=on  "ISD2 - Unit 01"
 change_element_definition e=pewter_9836_6 s=on  "ISD2 - Unit 12"
 change_element_definition e=pewter_9836_7 s=on  "ISD2 - Unit 13"
 change_element_definition e=pewter_7221_1  s=on  "Tape Channel 4"
 change_element_definition e=pew1  s=on           "Tape Unit 0"
 change_element_definition e=pew2  s=on           "Tape Unit 1"
 change_element_definition e=pewter_ICA_0   s=on  "ICA - CH00"
 change_element_definition e=pewter_ICA_16  s=on  "ICA - CH16"
delfc $echo output
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
 display_value 'Initializing pewter_9836_1 as v36a01'
 initialize_ms_volume element=pewter_9836_1 recorded_vsn=v36a01
 display_value 'Initializing pewter_9836_2 as v36a02'
 initialize_ms_volume element=pewter_9836_2 recorded_vsn=v36a02
 display_value 'Initializing pewter_9836_3 as v36a03'
 initialize_ms_volume element=pewter_9836_3 recorded_vsn=v36a03
 display_value 'Initializing pewter_9836_4 as v36a04'
 initialize_ms_volume element=pewter_9836_4 recorded_vsn=v36a04
 display_value 'Initializing pewter_9836_5 as v36a05'
 initialize_ms_volume element=pewter_9836_5 recorded_vsn=v36a05
 display_value 'Initializing pewter_9836_6 as v36a06'
 initialize_ms_volume element=pewter_9836_6 recorded_vsn=v36a06
 display_value 'Initializing pewter_9836_7 as v36a07'
 initialize_ms_volume element=pewter_9836_7 recorded_vsn=v36a07
 display_value 'Adding v36a01 to set'
 add_volume_to_set member_vsn=v36a01
 display_value 'Adding v36a02 to set'
 add_volume_to_set member_vsn=v36a02
 display_value 'Adding v36a03 to set'
 add_volume_to_set member_vsn=v36a03
 display_value 'Adding v36a04 to set'
 add_volume_to_set member_vsn=v36a04
 display_value 'Adding v36a05 to set'
 add_volume_to_set member_vsn=v36a05
 display_value 'Adding v36a06 to set'
 add_volume_to_set member_vsn=v36a06
 display_value 'Adding v36a07 to set'
 add_volume_to_set member_vsn=v36a07
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
end_prolog_file

PROCEND PEWTER_ISD2_4X8
*DECK DECK=RAI$PROLOG_PEWTER_OPEN_USAGE EXPAND=FALSE
PROCEDURE pewter_open_usage (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
 delete_element_definition e=all r=(..
 block_cm_0 ..
 block_cm_1 ..
 block_0 ..
 block_1 ..
 block_2 ..
 block_3 ..
 pewter_7221_1 ..
 pew0 ..
 pew1 ..
 pewter_5698_0 ..
 pew2 ..
 pew3 ..
 stornet ..
 pewter_ica_16 ..
 pewter_ica_0  ..
 pewter_ica_test ..
 pewter_nad_1 ..
 xlink5_pew ..
 xlink19_pew ..
)

change_element_definition e=block_cm_0     s=on ic=((ch1 0))
change_element_definition e=block_cm_1     s=on ic=((ch1 1))
change_element_definition e=block_0        s=on pc=((block_cm_0 0))
change_element_definition e=block_1        s=on pc=((block_cm_0 1))
change_element_definition e=block_2        s=on pc=((block_cm_1 2))
change_element_definition e=block_3        s=on pc=((block_cm_1 3))
change_element_definition e=pewter_7221_1  s=on
change_element_definition e=pew0           s=on
change_element_definition e=pew1           s=on
change_element_definition e=pewter_5698_0  s=on
change_element_definition e=pew2           s=on
change_element_definition e=pew3           s=on
change_element_definition e=stornet        s=on
change_element_definition e=pewter_ica_16  s=on
change_element_definition e=pewter_ica_0   s=on
change_element_definition e=pewter_ica_test s=on
change_element_definition e=pewter_nad_1   s=on
change_element_definition e=xlink19_pew    s=on
change_element_definition e=xlink5_pew     s=on
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
display_value 'Initializing BLOCK_1 as SXMD1'
initialize_ms_volume element=block_1 recorded_vsn=SXMD1
display_value 'Initializing BLOCK_2 as SXMD2'
initialize_ms_volume element=block_2 recorded_vsn=SXMD2
display_value 'Initializing BLOCK_3 as SXMD3'
initialize_ms_volume element=block_3 recorded_vsn=SXMD3
display_value 'Adding SXMD1 to set'
add_volume_to_set member_vsn=SXMD1
display_value 'Adding SXMD2 to set'
add_volume_to_set member_vsn=SXMD2
display_value 'Adding SXMD3 to set'
add_volume_to_set member_vsn=SXMD3
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_host_network n=767(10)
define_network_connection connected_system=pewter_ica_16 system_identifier=4fff20(16)
define_network_connection connected_system=pewter_ica_0 system_identifier=4fff21(16)
define_network_connection connected_system=xlink5_pew
define_network_connection connected_system=xlink19_pew
end_prolog_file

PROCEND pewter_open_usage


*DECK DECK=RAI$PROLOG_PEWTER_PERF_11 EXPAND=TRUE
PROCEDURE pewter_perf_11 (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
 change_connection_reference ..
   old_mainframe_name=$system_9303_0121 new_mainframe_name=$system_9301_0121

 delete_element_definition e=all r=(..
 pewter_cm_2 ..
 pewter_cm_3 ..
 pewter_cm_4 ..
 pewter_cm_5 ..
 pewter_9836_40 ..
 pewter_9836_41 ..
 pewter_9836_52 ..
 pewter_9836_53 ..
 pewter_9836_20 ..
 pewter_9836_21 ..
 pewter_9836_32 ..
 pewter_9836_33 ..
 pewter_7221_1 ..
 pew0 ..
 pew1 ..
 pewter_5698_0 ..
 pew2 ..
 pew3 ..
 pewter_ica_16 ..
 pewter_nad_1 ..
 xlink5_pew ..
 xlink19_pew ..
)

 change_element_definition e=pewter_cm_2    s=on ic=((ch17 2))
 change_element_definition e=pewter_cm_3    s=on ic=((ch17 3))
 change_element_definition e=pewter_cm_4    s=on ic=((ch1 4))
 change_element_definition e=pewter_cm_5    s=on ic=((ch1 5))
 change_element_definition e=pewter_9836_40 s=on pc=((pewter_cm_4 0))
 change_element_definition e=pewter_9836_41 s=on pc=((pewter_cm_4 1))
 change_element_definition e=pewter_9836_52 s=on pc=((pewter_cm_5 2))
 change_element_definition e=pewter_9836_53 s=on pc=((pewter_cm_5 3))
 change_element_definition e=pewter_9836_20 s=on pc=((pewter_cm_2 0))
 change_element_definition e=pewter_9836_21 s=on pc=((pewter_cm_2 1))
 change_element_definition e=pewter_9836_32 s=on pc=((pewter_cm_3 2))
 change_element_definition e=pewter_9836_33 s=on pc=((pewter_cm_3 3))
 change_element_definition e=pewter_5698_0  s=on
 change_element_definition e=pewter_7221_1  s=on
 change_element_definition e=pew0           s=on
 change_element_definition e=pew1           s=on
 change_element_definition e=pew2           s=on
 change_element_definition e=pew3           s=on
 change_element_definition e=pewter_ica_16  s=on
 change_element_definition e=pewter_nad_1   s=on
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
display_value 'Initializing PEWTER_9836_41 as S83641'
initialize_ms_volume element=pewter_9836_41 recorded_vsn=S83641
display_value 'Initializing PEWTER_9836_52 as S83652'
initialize_ms_volume element=pewter_9836_52 recorded_vsn=S83652
display_value 'Initializing PEWTER_9836_53 as S83653'
initialize_ms_volume element=pewter_9836_53 recorded_vsn=S83653
display_value 'Initializing PEWTER_9836_20 as S83620'
initialize_ms_volume element=pewter_9836_20 recorded_vsn=S83620
display_value 'Initializing PEWTER_9836_21 as S83621'
initialize_ms_volume element=pewter_9836_21 recorded_vsn=S83621
display_value 'Initializing PEWTER_9836_32 as S83652'
initialize_ms_volume element=pewter_9836_32 recorded_vsn=S83632
display_value 'Initializing PEWTER_9836_33 as S83653'
initialize_ms_volume element=pewter_9836_33 recorded_vsn=S83633
display_value 'Adding S83641 to set'
add_volume_to_set member_vsn=S83641
display_value 'Adding S83652 to set'
add_volume_to_set member_vsn=S83652
display_value 'Adding S83653 to set'
add_volume_to_set member_vsn=S83653
display_value 'Adding S83620 to set'
add_volume_to_set member_vsn=S83620
display_value 'Adding S83621 to set'
add_volume_to_set member_vsn=S83621
display_value 'Adding S83632 to set'
add_volume_to_set member_vsn=S83632
display_value 'Adding S83633 to set'
add_volume_to_set member_vsn=S83633
"ENTER CHAMSC HERE"
"CLASS X WILL CONTAIN SCU_BOUND_PRODUCT"
"CLASS Y WILL CONTAIN FORTRAN_BOUND_PRODUCT"
"CLASS Z WILL CONTAIN COBOL_BOUND_PRODUCT"
CHAMSC S83640 DC=(X Y Z)
CHAMSC S83641 DC=(X Y Z)
CHAMSC S83652 DC=(Y Z)
CHAMSC S83653 DC=(X Y Z)
CHAMSC S83620 DC=(X Y)
CHAMSC S83621 DC=(X Y Z)
CHAMSC S83632 DC=(X Z)
CHAMSC S83633 DC=(X Y Z)
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_host_network n=767(10)
define_network_connection connected_system=pewter_ica_16 system_identifier=4fff20(16)
define_network_connection connected_system=xlink5_pew
define_network_connection connected_system=xlink19_pew
end_prolog_file

PROCEND pewter_perf_11
*DECK DECK=RAI$PROLOG_PEWTER_PERF_1X4 EXPAND=TRUE
PROCEDURE pewter_perf_1X4 (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
 change_connection_reference ..
   old_mainframe_name=$system_9303_0121 new_mainframe_name=$system_9301_0121

 delete_element_definition e=all r=(..
 pewter_cm_4 ..
 pewter_cm_5 ..
 pewter_9836_40 ..
 pewter_9836_41 ..
 pewter_9836_52 ..
 pewter_9836_53 ..
 pewter_7221_1 ..
 pew0 ..
 pew1 ..
 pewter_5698_0 ..
 pew2 ..
 pew3 ..
 pewter_ica_16 ..
 pewter_nad_1 ..
 xlink5_pew ..
 xlink19_pew ..
)

 change_element_definition e=pewter_cm_4    s=on ic=((ch1 4))
 change_element_definition e=pewter_cm_5    s=on ic=((ch1 5))
 change_element_definition e=pewter_9836_40 s=on pc=((pewter_cm_4 0))
 change_element_definition e=pewter_9836_41 s=on pc=((pewter_cm_4 1))
 change_element_definition e=pewter_9836_52 s=on pc=((pewter_cm_5 2))
 change_element_definition e=pewter_9836_53 s=on pc=((pewter_cm_5 3))
 change_element_definition e=pewter_7221_1  s=on
 change_element_definition e=pew0           s=on
 change_element_definition e=pew1           s=on
 change_element_definition e=pew2           s=on
 change_element_definition e=pew3           s=on
 change_element_definition e=pewter_ica_16  s=on
 change_element_definition e=pewter_nad_1   s=on
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
display_value 'Initializing PEWTER_9836_41 as S83641'
initialize_ms_volume element=pewter_9836_41 recorded_vsn=S83641
display_value 'Initializing PEWTER_9836_52 as S83652'
initialize_ms_volume element=pewter_9836_52 recorded_vsn=S83652
display_value 'Initializing PEWTER_9836_53 as S83653'
initialize_ms_volume element=pewter_9836_53 recorded_vsn=S83653
display_value 'Adding S83641 to set'
add_volume_to_set member_vsn=S83641
display_value 'Adding S83652 to set'
add_volume_to_set member_vsn=S83652
display_value 'Adding S83653 to set'
add_volume_to_set member_vsn=S83653
"ENTER CHAMSC HERE"
"CLASS X WILL CONTAIN SCU_BOUND_PRODUCT"
"CLASS Y WILL CONTAIN FORTRAN_BOUND_PRODUCT"
"CLASS Z WILL CONTAIN COBOL_BOUND_PRODUCT"
CHAMSC S83640 DC=(X Y Z)
CHAMSC S83641 DC=(Y Z)
CHAMSC S83652 DC=(X Y)
CHAMSC S83653 DC=(X Z)
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_host_network n=767(10)
define_network_connection connected_system=pewter_ica_16 system_identifier=4fff20(16)
define_network_connection connected_system=xlink5_pew
define_network_connection connected_system=xlink19_pew
end_prolog_file

PROCEND pewter_perf_1X4
*DECK DECK=RAI$PROLOG_PEWTER_PERF_31 EXPAND=TRUE
PROCEDURE pewter_perf_31 (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
 delete_element_definition e=all r=(..
 pewter_cm_4 ..
 pewter_cm_5 ..
 pewter_9836_40 ..
 pewter_9836_41 ..
 pewter_9836_52 ..
 pewter_9836_53 ..
 pewter_7221_1 ..
 pew0 ..
 pew1 ..
 pewter_5698_0 ..
 pew2 ..
 pew3 ..
 pewter_ica_16 ..
 pewter_nad_1 ..
 xlink5_pew ..
 xlink19_pew ..
)

 change_element_definition e=pewter_cm_4    s=on ic=((ch1 4))
 change_element_definition e=pewter_cm_5    s=on ic=((ch1 5))
 change_element_definition e=pewter_9836_40 s=on pc=((pewter_cm_4 0))
 change_element_definition e=pewter_9836_41 s=on pc=((pewter_cm_4 1))
 change_element_definition e=pewter_9836_52 s=on pc=((pewter_cm_5 2))
 change_element_definition e=pewter_9836_53 s=on pc=((pewter_cm_5 3))
 change_element_definition e=pewter_7221_1  s=on
 change_element_definition e=pew0           s=on
 change_element_definition e=pew1           s=on
 change_element_definition e=pew2           s=on
 change_element_definition e=pew3           s=on
 change_element_definition e=pewter_ica_16  s=on
 change_element_definition e=pewter_nad_1   s=on
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
display_value 'Initializing PEWTER_9836_41 as S83641'
initialize_ms_volume element=pewter_9836_41 recorded_vsn=S83641
display_value 'Initializing PEWTER_9836_52 as S83652'
initialize_ms_volume element=pewter_9836_52 recorded_vsn=S83652
display_value 'Initializing PEWTER_9836_53 as S83653'
initialize_ms_volume element=pewter_9836_53 recorded_vsn=S83653
display_value 'Adding S83641 to set'
add_volume_to_set member_vsn=S83641
display_value 'Adding S83652 to set'
add_volume_to_set member_vsn=S83652
display_value 'Adding S83653 to set'
add_volume_to_set member_vsn=S83653
"ENTER CHAMSC HERE"
"CLASS X WILL CONTAIN SCU_BOUND_PRODUCT"
"CLASS Y WILL CONTAIN FORTRAN_BOUND_PRODUCT"
"CLASS Z WILL CONTAIN COBOL_BOUND_PRODUCT"
CHAMSC S83640 DC=(X Y Z)
CHAMSC S83641 DC=(Y Z)
CHAMSC S83652 DC=(X Y)
CHAMSC S83653 DC=(X Z)
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_host_network n=767(10)
define_network_connection connected_system=pewter_ica_16 system_identifier=4fff20(16)
define_network_connection connected_system=xlink5_pew
define_network_connection connected_system=xlink19_pew
end_prolog_file

PROCEND pewter_perf_31
*DECK DECK=RAI$PROLOG_PEWTER_SHARED_LAB EXPAND=FALSE
PROCEDURE pewter_shared_lab (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
 delete_element_definition e=all r=(..
 pewter_xmd_cm_0 ..
 pewter_xmd_cm_1 ..
 pewter_9853_0 ..
 pewter_9853_1 ..
 pewter_9853_2 ..
 pewter_9853_3 ..
 stornet ..
 pewter_7221_1 ..
 pew0 ..
 pew1 ..
 pewter_5698_0 ..
 pew2 ..
 pew3 ..
 pewter_ica_0 ..
 pewter_ica_16 ..
 pewter_ica_test ..
 xlink5_pew ..
 xlink19_pew ..
 pewter_nad_1 ..
)

 change_element_definition e=pewter_xmd_cm_0 s=on
 change_element_definition e=pewter_xmd_cm_1 s=on
 change_element_definition e=pewter_9853_0   s=on
 change_element_definition e=pewter_9853_1   s=on
 change_element_definition e=pewter_9853_2   s=on
 change_element_definition e=pewter_9853_3   s=on
 change_element_definition e=pewter_7221_1   s=on
 change_element_definition e=pew2            s=on
 change_element_definition e=pew3            s=on
 change_element_definition e=stornet       s=on
 change_element_definition e=xlink5_pew      s=off  "EXPRESS LINK"
 change_element_definition e=xlink19_pew     s=off  "EXPRESS LINK"
 change_element_definition e=pewter_ica_0    s=on
 change_element_definition e=pewter_ica_16   s=on
 change_element_definition e=pewter_ica_test s=on
 change_element_definition e=pewter_nad_1    s=on
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
display_value 'Initializing PEWTER_9853_1 as S98531'
initialize_ms_volume element=pewter_9853_1 recorded_vsn=s98531
display_value 'Initializing PEWTER_9853_2 as S98532'
initialize_ms_volume element=pewter_9853_2 recorded_vsn=s98532
display_value 'Initializing PEWTER_9853_3 as S98533'
initialize_ms_volume element=pewter_9853_3 recorded_vsn=s98533
display_value 'Adding S98531 to set'
add_volume_to_set member_vsn=s98531
display_value 'Adding S98532 to set'
add_volume_to_set member_vsn=s98532
display_value 'Adding S98533 to set'
add_volume_to_set member_vsn=s98533
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
"define_host_network n=767(10)
"define_network_connection connected_system=pewter_ica_16   system_identifier=4fff20(16)
"define_network_connection connected_system=pewter_ica_0    system_identifier=4fff21(16)
"define_network_connection connected_system=pewter_ica_test system_identifier=4fff22(16)
"define_network_connection connected_system=xlink5_pew
"define_network_connection connected_system=xlink19_pew
end_prolog_file

PROCEND pewter_shared_lab
*DECK DECK=RAI$PROLOG_PURPLE_9836_2X4 EXPAND=FALSE
PROCEDURE PURPLE_9836_2X4 (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
create_file_connection $echo output
delete_element_definition e=all r=( ..
 purple_fa7b5_0 purple_fa7b5_1 purple_9836_0 purple_9836_1 ..
 purple_9836_2 purple_9836_3 purple_7221_1 p50 p51)
"Begin CHAED commands"
change_element_definition s=on e = purple_fa7b5_0 ..
    IOU_CONNECTION = ((  CH1 0 $SYSTEM_9303_0101 IOU0 ))
change_element_definition s=on e = purple_fa7b5_1 ..
    IOU_CONNECTION = ((  CH17 1 $SYSTEM_9303_0101 IOU0 ))
change_element_definition s=on e = purple_9836_0   "CM0 UN0"
change_element_definition s=on e = purple_9836_1   "CM0 UN1"
change_element_definition s=on e = purple_9836_2   "CM1 UN2"
"change_element_definition s=on e = purple_9836_3   CM1 UN3"
change_element_definition s=on e = purple_7221_1   "CH 4"
change_element_definition s=on e = p50             "Tape Unit 0"
change_element_definition s=on e = p51             "Tape Unit 1"
change_element_definition s=on e = purple_ica_16   "CH16"
delete_file_connection $echo output
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
"Begin INIMSV and CHAMSC commands
display_value 'Initializing purple_9836_1 as disk01'
initialize_ms_volume e = purple_9836_1 recorded_vsn = disk01
display_value 'Initializing purple_9836_2 as disk02'
initialize_ms_volume e = purple_9836_2 recorded_vsn = disk02
"display_value 'Initializing purple_9836_3 as disk03'
"initialize_ms_volume e = purple_9836_3 recorded_vsn = disk03
display_value 'Adding disk01 to set'
add_volume_to_set member_vsn = disk01
display_value 'Adding disk02 to set'
add_volume_to_set member_vsn = disk02
"display_value 'Adding disk03 to set'
"add_volume_to_set member_vsn = disk03
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
"Begin network access commands
define_network_connection connected_system=purple_ica_16 ..
   system_identifier=400149(16)
define_host_network n=101(10)
end_prolog_file
PROCEND PURPLE_9836_2X4


*DECK DECK=RAI$PROLOG_RUST_ISD2_2X4 EXPAND=FALSE

*DECK DECK=RAI$PROLOG_SILVER_ISD1_4X8 EXPAND=FALSE

*DECK DECK=RAI$PROLOG_SN102_885_6X10 EXPAND=FALSE
" DECK: RAI$PROLOG_SN102_885_6X10
$local.create_prolog_file prolog_name=sn102_885_6x10 ..
       file=pcu_subcommands
EDIT_PHYSICAL_CONFIGURATION
crefc $echo output
 change_element_definition e=pink_7155_3 s=on "Disk Channel 03(8)"
 change_element_definition e=pink_7155_4 s=on "Disk Channel 04(8)"
 change_element_definition e=pink_7155_5 s=on "Disk Channel 21(8)"
 change_element_definition e=pink_7155_6 s=on "Disk Channel 22(8)"
 change_element_definition e=pink_7155_7 s=on "Disk Channel 23(8)"
 change_element_definition e=pink_7155_8 s=on "Disk Channel 24(8)"
 change_element_definition e=pink_885_b40 s=on "Unit 40(8)"
 change_element_definition e=pink_885_b41 s=on "Unit 41(8)"
 change_element_definition e=pink_885_b42 s=on "Unit 42(8)"
 change_element_definition e=pink_885_b43 s=on "Unit 43(8)"
 change_element_definition e=pink_885_c44 s=on "Unit 44(8)"
 change_element_definition e=pink_885_c45 s=on "Unit 45(8)"
 change_element_definition e=pink_885_c46 s=on "Unit 46(8)"
 change_element_definition e=pink_885_c47 s=on "Unit 47(8)"
 change_element_definition e=pink_885_d44 s=on "Unit 44(8)"
 change_element_definition e=pink_885_d45 s=on "Unit 45(8)"
 change_element_definition e=pink_7021_1  s=on ..
                                 ic=((ch27 0)) "Tape Channel 33(8)"
 change_element_definition e=pink_698_c1  s=on "H-Tape Channel 32(8)"
 change_element_definition e=p50          s=on "Tape Unit 0"
 change_element_definition e=p51          s=on "Tape Unit 1"
 change_element_definition e=p52          s=on "Tape Unit 2"
 change_element_definition e=p53          s=on "Tape Unit 3"
 change_element_definition e=p60          s=on "H-Tape Unit 0"
 change_element_definition e=p61          s=on "H-Tape Unit 1"
 change_element_definition e=p62          s=on "H-Tape Unit 2"
 change_element_definition e=p63          s=on "H-Tape Unit 3"
 change_element_definition e=pink_DI_3000a0 s=on "DI"
QUIT
**
$local.create_prolog_file prolog_name=sn102_885_6x10 ..
       file=lcu_mainframe_subcommands
 display_value ' Initializing pink_885_b40 as VSNB40 '
 initialize_ms_volume element=pink_885_b40 recorded_vsn=VSNB40
 display_value ' Initializing pink_885_b41 as VSNB41 '
 initialize_ms_volume element=pink_885_b41 recorded_vsn=VSNB41
 display_value ' Initializing pink_885_b42 as VSNB42 '
 initialize_ms_volume element=pink_885_b42 recorded_vsn=VSNB42
 display_value ' Initializing pink_885_b43 as VSNB43 '
 initialize_ms_volume element=pink_885_b43 recorded_vsn=VSNB43
 display_value ' Initializing pink_885_c45 as VSNC45 '
 initialize_ms_volume element=pink_885_c45 recorded_vsn=VSNC45
 display_value ' Initializing pink_885_c46 as VSNC46 '
 initialize_ms_volume element=pink_885_c46 recorded_vsn=VSNC46
 display_value ' Initializing pink_885_c47 as VSNC47 '
 initialize_ms_volume element=pink_885_c47 recorded_vsn=VSNC47
 display_value ' Initializing pink_885_d44 as VSND44 '
 initialize_ms_volume element=pink_885_d44 recorded_vsn=VSND44
 display_value ' Initializing pink_885_d45 as VSND45 '
 initialize_ms_volume element=pink_885_d45 recorded_vsn=VSND45
 display_value ' Adding VSNB40 to set '
 add_volume_to_set member_vsn=VSNB40
 display_value ' Adding VSNB41 to set '
 add_volume_to_set member_vsn=VSNB41
 display_value ' Adding VSNB42 to set '
 add_volume_to_set member_vsn=VSNB42
 display_value ' Adding VSNB43 to set '
 add_volume_to_set member_vsn=VSNB43
 display_value ' Adding VSNC45 to set '
 add_volume_to_set member_vsn=VSNC45
 display_value ' Adding VSNC46 to set '
 add_volume_to_set member_vsn=VSNC46
 display_value ' Adding VSNC47 to set '
 add_volume_to_set member_vsn=VSNC47
 display_value ' Adding VSND44 to set '
 add_volume_to_set member_vsn=VSND44
 display_value ' Adding VSND45 to set '
 add_volume_to_set member_vsn=VSND45
**
$local.create_prolog_file prolog_name=sn102_885_6x10 ..
       file=lcu_network_subcommands
define_channel_network n=102(16) cs=pink_DI_3000a0 rr=false
**
*DECK DECK=RAI$PROLOG_SN102_887_2X4 EXPAND=FALSE
PROCEDURE SN102_887_2X4 (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
crefc $echo output
 delete_element_definition e=all r=(pink_887_6 pink_887_7 ..
   pink_887_10 pink_887_11 pink_7021_1 pink_698_c1 p50 p51 p52 p53 p60 p61 ..
   p62 p63 pink_di_3000a0 pink_di_300070 pink_NAD_1 pink_NAD_2)
 change_element_definition e=pink_887_6 ic=((cch7a 0)) s=on   "HYDRA CCH7A UNIT0"
 change_element_definition e=pink_887_7 ic=((cch7a 1)) s=on   "HYDRA CCH7A UNIT1"
 change_element_definition e=pink_887_10 ic=((cch9a 4)) s=on   "HYDRA CCH9A UNIT4"
 change_element_definition e=pink_887_11 ic=((cch9a 5)) s=on   "HYDRA CCH9A UNIT5"
 change_element_definition e=pink_7021_1 s=on ..
                       ic=((cch6 0 $system_0990_0102 iou1))     "Tape Channel 6 IOU1"
 change_element_definition e=pink_698_c1 s=on "H-Tape Channel 20(8) IOU1"
 change_element_definition e=p50         s=on "679 Tape Unit 0"
 change_element_definition e=p51         s=on "679 Tape Unit 1"
 change_element_definition e=p52         s=on "679 Tape Unit 2"
 change_element_definition e=p53         s=on "679 Tape Unit 3"
 change_element_definition e=p60         s=on   "H-Tape Unit 0"
 change_element_definition e=p61         s=on   "H-Tape Unit 1"
 change_element_definition e=p62         s=on   "H-Tape Unit 2"
 change_element_definition e=p63         s=on   "H-Tape Unit 3"
 change_element_definition e=pink_DI_3000a0 s=on ic=((ch6 0)) "DI"
delfc $echo output
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
 display_value 'Initializing pink_887_7 as V88707'
 initialize_ms_volume element=pink_887_7 recorded_vsn=V88707
 display_value 'Initializing pink_887_10 as V88710'
 initialize_ms_volume element=pink_887_10 recorded_vsn=V88710
 display_value 'Initializing pink_887_11 as V88711'
 initialize_ms_volume element=pink_887_11 recorded_vsn=V88711
"ENTER CHAMSC HERE"
CHAMSC VSN7A0 DC=(X Y Z)
"CLASS X WILL CONTAIN SCU_BOUND_PRODUCT"
CHAMSC V88707 DC=(Y Z)
"CLASS Z WILL CONTAIN COBOL_BOUND_PRODUCT"
CHAMSC V88710 DC=(X Y)
"CLASS Y WILL CONTAIN FORTRAN_BOUND_PRODUCT"
CHAMSC V88711 DC=(X Z)
 display_value 'Adding V88707 to set'
 add_volume_to_set member_vsn=V88707
 display_value 'Adding V88710 to set'
 add_volume_to_set member_vsn=V88710
 display_value 'Adding V88711 to set'
 add_volume_to_set member_vsn=V88711
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_channel_network n=102(16) cs=pink_DI_3000a0 rr=false
define_host_network n=102(10)
end_prolog_file

PROCEND SN102_887_2X4
*DECK DECK=RAI$PROLOG_SN102_TEMP EXPAND=FALSE
" DECK: RAI$PROLOG_SN102_TEMP      "
$local.create_prolog_file prolog_name=sn102_clsh_temp file=pcu_subcommands
EDIT_PHYSICAL_CONFIGURATION
" ENABLE DISK ELEMENTS NORMALLY USED BY NOS/VE"
change_element_definition element=pink_7155_5 state=on    "Channel 17 [21(8)]               "
change_element_definition element=pink_7155_6 state=on    "Channel 18 [22(8)]               "
change_element_definition element=pink_7155_7 state=on    "Channel 19 [23(8)]               "
change_element_definition element=pink_7155_8 state=on    "Channel 20 [24(8)]               "
change_element_definition element=pink_7165_1 state=on ic=((ch21 1))  "Channel 21  EQ=1     "
change_element_definition element=pink_887_0 state=on     "s87e00--user/sys temp               "
change_element_definition element=pink_887_1 state=on     "v87e01--pf,user/sys temp            "
change_element_definition element=pink_887_2 state=on     "v87f00--pf,user/sys temp            "
change_element_definition element=pink_887_3 state=on     "v87f01--pf,user/sys temp            "
change_element_definition element=pink_887_4 state=on     "v87g00--pf,user/sys temp            "
change_element_definition element=pink_887_5 state=on     "v87g01--pf,user/sys temp            "
change_element_definition element=pink_895_0 state=on     "v95a00--pf,cat                      "
change_element_definition element=pink_895_1 state=on     "v95a01--pf                          "
change_element_definition element=pink_895_2 state=on     "v95a02--pf                          "
change_element_definition element=pink_895_3 state=on     "v95a03--pf                          "
change_element_definition element=pink_885_c40 state=on   "v85c40--pf,cat                   "
change_element_definition element=pink_885_c41 state=on   "v85c41--pf,user temp,sys temp    "
change_element_definition element=pink_885_c42 state=on   "v85c42--pf,user temp sys temp    "
change_element_definition element=pink_885_c43 state=on   "v85c43--pf,user temp sys temp    "
change_element_definition element=pink_885_d40 state=on   "v85d40--pf,cat                   "
change_element_definition element=pink_885_d41 state=on   "v85d41--pf,user temp,sys temp    "
change_element_definition element=pink_885_d42 state=on   "v85d42--pf,user temp,sys temp    "
change_element_definition element=pink_885_d43 state=on   "v85d43--pf,user temp,sys temp    "
change_element_definition element=pink_885_d44 state=on   "v85d44--pf,user temp,sys temp    "
change_element_definition element=pink_885_d45 state=on   "v85d45--pf,user temp,sys temp    "
" ENABLE TAPE ELEMENTS NORMALLY USED BY NOS/VE
change_element_definition element=pink_7021_1 state=on
change_element_definition element=p50 state=on
change_element_definition element=p51 state=on
change_element_definition element=p52 state=on
change_element_definition element=p53 state=on
change_element_definition element=p54 state=on
change_element_definition element=p55 state=on
change_element_definition element=p56 state=on
change_element_definition element=p57 state=on
change_element_definition element=pink_698_c1 state=on
change_element_definition element=p60 state=on
change_element_definition element=p61 state=on
change_element_definition element=p62 state=on
change_element_definition element=p63 state=on
" ENABLE DI ELEMENTS NORMALLY USED BY NOS/VE
change_element_definition element=pink_DI_300117 state=on  "DI - sn379"
change_element_definition element=pink_NAD_2 state=on
QUIT
**
$local.create_prolog_file prolog_name=sn102_clsh_temp ..
       file=lcu_mainframe_subcommands
initialize_ms_volume element=pink_887_0    recorded_vsn=v87e00
initialize_ms_volume element=pink_887_1    recorded_vsn=v87e01
initialize_ms_volume element=pink_887_2    recorded_vsn=v87f00
initialize_ms_volume element=pink_887_3    recorded_vsn=v87f01
initialize_ms_volume element=pink_887_4    recorded_vsn=v87g00
initialize_ms_volume element=pink_887_5    recorded_vsn=v87g01
initialize_ms_volume element=pink_895_0    recorded_vsn=v95a00
initialize_ms_volume element=pink_895_1    recorded_vsn=v95a01
initialize_ms_volume element=pink_895_2    recorded_vsn=v95a02
initialize_ms_volume element=pink_895_3    recorded_vsn=v95a03
initialize_ms_volume element=pink_885_c40  recorded_vsn=v85c40
initialize_ms_volume element=pink_885_c41  recorded_vsn=v85c41
initialize_ms_volume element=pink_885_c42  recorded_vsn=v85c42
initialize_ms_volume element=pink_885_c43  recorded_vsn=v85c43
initialize_ms_volume element=pink_885_d40  recorded_vsn=v85d40
initialize_ms_volume element=pink_885_d41  recorded_vsn=v85d41
initialize_ms_volume element=pink_885_d42  recorded_vsn=v85d42
initialize_ms_volume element=pink_885_d43  recorded_vsn=v85d43
initialize_ms_volume element=pink_885_d44  recorded_vsn=v85d44
initialize_ms_volume element=pink_885_d45  recorded_vsn=v85d45
change_ms_class recorded_vsn=V87e01 dc=(l c)
change_ms_class recorded_vsn=V87f00 dc=(l c)
change_ms_class recorded_vsn=V87f01 dc=(l c)
change_ms_class recorded_vsn=V87g00 dc=(l c)
change_ms_class recorded_vsn=V87g01 dc=(l c)
change_ms_class recorded_vsn=V95a00 dc=(b m n)
change_ms_class recorded_vsn=V95a01 dc=(b c l n)
change_ms_class recorded_vsn=V95a02 dc=(b c l n)
change_ms_class recorded_vsn=V95a03 dc=(b c l n)
change_ms_class recorded_vsn=V85c40 dc=(b c n)
change_ms_class recorded_vsn=V85c41 dc=(c l)
change_ms_class recorded_vsn=V85c42 dc=(c l)
change_ms_class recorded_vsn=V85c43 dc=(c l)
change_ms_class recorded_vsn=V85d40 dc=(b c n)
change_ms_class recorded_vsn=V85d41 dc=(c l)
change_ms_class recorded_vsn=V85d42 dc=(c l)
change_ms_class recorded_vsn=V85d43 dc=(c l)
change_ms_class recorded_vsn=V85d44 dc=(c l)
change_ms_class recorded_vsn=V85d45 dc=(c l)
add_volume_to_set member_vsn=v87e01
add_volume_to_set member_vsn=v87f00
add_volume_to_set member_vsn=v87f01
add_volume_to_set member_vsn=v87g00
add_volume_to_set member_vsn=v87g01
add_volume_to_set member_vsn=v95a00
add_volume_to_set member_vsn=v95a01
add_volume_to_set member_vsn=v95a02
add_volume_to_set member_vsn=v95a03
add_volume_to_set member_vsn=v85c40
add_volume_to_set member_vsn=v85c41
add_volume_to_set member_vsn=v85c42
add_volume_to_set member_vsn=v85c43
add_volume_to_set member_vsn=v85d40
add_volume_to_set member_vsn=v85d41
add_volume_to_set member_vsn=v85d42
add_volume_to_set member_vsn=v85d43
add_volume_to_set member_vsn=v85d44
add_volume_to_set member_vsn=v85d45
change_ms_class recorded_vsn=s87e00 dc=(l c m)
**
$local.create_prolog_file prolog_name=sn102_clsh_temp ..
       file=lcu_network_subcommands
define_channel_network network=0990102 connected_system=pink_DI_300117
**

*DECK DECK=RAI$PROLOG_SN109_CLOSED_SHOP EXPAND=FALSE
PROCEDURE SN109_CLOSED_SHOP (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
" enable disk elements normally used by NOS/VE
  change_element_definition element=gray_7165_1 state=on
  change_element_definition element=gray_fa7b5_1 state=on
  change_element_definition element=gray_fa7b5_2 state=on
  change_element_definition element=gray_fa7b5_3 state=on
  change_element_definition element=gray_fa7b5_4 state=on
  change_element_definition element=gray_fa7b5_5 state=on
  change_element_definition element=gray_fa7b5_6 state=on
  change_element_definition element=gray_fa7b5_7 state=on
  change_element_definition element=gray_fa7b5_8 state=on
  change_element_definition element=gray_fa7b5_9 state=on
  change_element_definition element=gray_fa7b5_10 state=on
  change_element_definition element=gray_7155_1 state=on
  change_element_definition element=gray_7155_2 state=on
  change_element_definition element=gray_7155_5 state=on
  change_element_definition element=gray_887_0  state=on
  change_element_definition element=gray_887_1  state=on
  change_element_definition element=gray_887_2  state=on
  change_element_definition element=gray_887_3  state=on
  change_element_definition gray_895_4 state=off
  change_element_definition gray_895_5 state=off
  change_element_definition gray_895_6 state=off
  change_element_definition gray_895_7 state=off
  change_element_definition element=gray_9853_0 state=on
  change_element_definition element=gray_9853_1 state=on
  change_element_definition element=gray_9853_2 state=on
  change_element_definition element=gray_9853_3 state=on
  change_element_definition element=gray_9853_4 state=on
  change_element_definition element=gray_9853_5 state=on
  change_element_definition element=gray_9853_6 state=on
  change_element_definition element=gray_9853_7 state=on
  change_element_definition element=gray_9853_8 state=on
  change_element_definition element=gray_9853_9 state=on
  change_element_definition element=gray_9853_10 state=on
  change_element_definition element=gray_9853_11 state=on
  change_element_definition element=gray_9853_12 state=on
  change_element_definition element=gray_9853_13 state=on
  change_element_definition element=gray_9853_14 state=on
  change_element_definition element=gray_9853_15 state=on
  change_element_definition element=gray_9853_16 state=on
  change_element_definition element=gray_9853_17 state=on
  change_element_definition element=gray_9853_18 state=on
  change_element_definition element=gray_9853_19 state=on
  change_element_definition element=gray_885_0 state=on
  change_element_definition element=gray_885_1 state=on
  change_element_definition element=gray_885_2 state=on
  change_element_definition element=gray_885_3 state=on
  change_element_definition element=gray_885_4 state=on
  change_element_definition element=gray_885_5 state=on
  change_element_definition element=gray_885_6 state=on
  change_element_definition element=gray_885_7 state=on
  change_element_definition element=gray_885_14 state=on
  change_element_definition element=gray_885_15 state=on
  change_element_definition element=gray_885_16 state=on
  change_element_definition element=gray_885_17 state=on
" enable tape elements normally used by NOS/VE
  change_element_definition e=gray_7021_1 state=on
  change_element_definition e=gray_7021_2 state=on
  change_element_definition e=g50 state=on
  change_element_definition e=g51 state=on
  change_element_definition e=g52 state=on
  change_element_definition e=g53 state=on
  change_element_definition e=g54 state=on
" enable network elements normally used by NOS/VE
  change_element_definition element=gray_DI_300119 state=on
  change_element_definition element=cobray_DI_3013ad state=on
  change_element_definition element=gray_NAD_1 state=on
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
initialize_ms_volume element=gray_887_1 recorded_vsn=G87A01
initialize_ms_volume element=gray_887_2 recorded_vsn=G87A02
initialize_ms_volume element=gray_887_3 recorded_vsn=G87A03
initialize_ms_volume element=gray_9853_0 recorded_vsn=G53C00
initialize_ms_volume element=gray_9853_1 recorded_vsn=G53C01
initialize_ms_volume element=gray_9853_2 recorded_vsn=G53C02
initialize_ms_volume element=gray_9853_3 recorded_vsn=G53C03
initialize_ms_volume element=gray_9853_4 recorded_vsn=G53D00
initialize_ms_volume element=gray_9853_5 recorded_vsn=G53D01
initialize_ms_volume element=gray_9853_6 recorded_vsn=G53D02
initialize_ms_volume element=gray_9853_7 recorded_vsn=G53D03
initialize_ms_volume element=gray_9853_8 recorded_vsn=G53E00
initialize_ms_volume element=gray_9853_9 recorded_vsn=G53E01
initialize_ms_volume element=gray_9853_10 recorded_vsn=G53E02
initialize_ms_volume element=gray_9853_11 recorded_vsn=G53E03
initialize_ms_volume element=gray_9853_12 recorded_vsn=G53F00
initialize_ms_volume element=gray_9853_13 recorded_vsn=G53F01
initialize_ms_volume element=gray_9853_14 recorded_vsn=G53F02
initialize_ms_volume element=gray_9853_15 recorded_vsn=G53F03
initialize_ms_volume element=gray_9853_16 recorded_vsn=G53K00
initialize_ms_volume element=gray_9853_17 recorded_vsn=G53K01
initialize_ms_volume element=gray_9853_18 recorded_vsn=G53K02
initialize_ms_volume element=gray_9853_19 recorded_vsn=G53K03
initialize_ms_volume element=gray_895_4 recorded_vsn=G95G04
initialize_ms_volume element=gray_895_5 recorded_vsn=G95G05
initialize_ms_volume element=gray_895_6 recorded_vsn=G95G06
initialize_ms_volume element=gray_895_7 recorded_vsn=G95G07
initialize_ms_volume element=gray_885_0 recorded_vsn=G85H32
initialize_ms_volume element=gray_885_1 recorded_vsn=G85H33
initialize_ms_volume element=gray_885_2 recorded_vsn=G85H34
initialize_ms_volume element=gray_885_3 recorded_vsn=G85H35
initialize_ms_volume element=gray_885_4 recorded_vsn=G85H36
initialize_ms_volume element=gray_885_5 recorded_vsn=G85H37
initialize_ms_volume element=gray_885_6 recorded_vsn=G85H38
initialize_ms_volume element=gray_885_7 recorded_vsn=G85H39
initialize_ms_volume element=gray_885_14 recorded_vsn=G85J36
initialize_ms_volume element=gray_885_15 recorded_vsn=G85J37
initialize_ms_volume element=gray_885_16 recorded_vsn=G85J38
initialize_ms_volume element=gray_885_17 recorded_vsn=G85J39
change_ms_class S87A00 dc=all ac=(a b   d e f g h i           o p q r s t u v w x y z)
change_ms_class G87A01 dc=all ac=(a b c d e f g h i           o p   r s t u v w x y z)
change_ms_class G87A02 dc=all ac=(a b   d e f g h i j   l     o p   r s t u v w x y z)
change_ms_class G87A03 dc=all ac=(a b   d e f g h i         n o p   r s t u v w x y z)
change_ms_class G53C00 dc=all ac=(a b   d e f g h i   k       o p   r s t u v w x y z)
change_ms_class G53C01 dc=all ac=(a b   d e f g h i   k   m n o p   r s t u v w x y z)
change_ms_class G53C02 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G53C03 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G53D00 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G53D01 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G53D02 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G53D03 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G53E00 dc=all ac=(a b   d e f g h i       m n o p   r s t u v w x y z)
change_ms_class G53E01 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G53E02 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G53E03 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G53F00 dc=all ac=(a b   d e f g h i       m n o p   r s t u v w x y z)
change_ms_class G53F01 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G53F02 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G53F03 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G95G04 dc=all ac=(a b   d e f g h i       m n o p   r s t u v w x y z)
change_ms_class G95G05 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G95G06 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G95G07 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G85H32 dc=all ac=(a b   d e f g h i j k l     o p   r s t u v w x y z)
change_ms_class G85H33 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G85H34 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G85H35 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G85H36 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G85H37 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G85H38 dc=all ac=(a b   d e f g h i j k l     o p   r s t u v w x y z)
change_ms_class G85H39 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G85J36 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G85J37 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G85J38 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G85J39 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G53K00 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G53K01 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G53K02 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class G53K03 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
add_volume_to_set member_vsn=G87A01 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G87A02 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G87A03 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G53C00 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G53C01 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G53C02 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G53C03 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G53D00 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G53E00 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G53E01 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G53E02 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G53E03 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G53F00 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G53F01 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G53F02 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G53F03 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G95G04 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G95G05 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G95G06 set_name=GRAY_NVESET
add_volume_to_set member_vsn=G95G07 set_name=GRAY_NVESET
create_set        master_vsn=G85H32 set_name=CSERV_DISKS
add_volume_to_set member_vsn=G85H33 set_name=CSERV_DISKS
add_volume_to_set member_vsn=G85H34 set_name=CSERV_DISKS
add_volume_to_set member_vsn=G85H35 set_name=CSERV_DISKS
add_volume_to_set member_vsn=G85H36 set_name=CSERV_DISKS
add_volume_to_set member_vsn=G85H37 set_name=CSERV_DISKS
create_set        master_vsn=G85H38 set_name=GRAY_INTEGRATION
add_volume_to_set member_vsn=G85H39 set_name=GRAY_INTEGRATION
add_volume_to_set member_vsn=G53D01 set_name=GRAY_INTEGRATION
add_volume_to_set member_vsn=G53D02 set_name=GRAY_INTEGRATION
add_volume_to_set member_vsn=G53D03 set_name=GRAY_INTEGRATION
add_volume_to_set member_vsn=G85I39 set_name=GRAY_INTEGRATION
add_volume_to_set member_vsn=G85J36 set_name=GRAY_INTEGRATION
add_volume_to_set member_vsn=G85J37 set_name=GRAY_INTEGRATION
add_volume_to_set member_vsn=G85J38 set_name=GRAY_INTEGRATION
add_volume_to_set member_vsn=G85J39 set_name=GRAY_INTEGRATION
add_volume_to_set member_vsn=G53K00 set_name=GRAY_INTEGRATION
add_volume_to_set member_vsn=G53K01 set_name=GRAY_INTEGRATION
add_volume_to_set member_vsn=G53K02 set_name=GRAY_INTEGRATION
add_volume_to_set member_vsn=G53K03 set_name=GRAY_INTEGRATION
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
end_prolog_file

PROCEND SN109_CLOSED_SHOP
*DECK DECK=RAI$PROLOG_SN109_FMD_2X4_A EXPAND=FALSE
PROCEDURE SN109_FMD_2X4_A (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
crefc $echo output
 change_element_definition e=orange_7155_1 s=on "Disk Channel 22(8)"
 change_element_definition e=orange_7155_4 s=on "Disk Channel 27(8)"
 change_element_definition e=orange_885_0 s=on  "FMD Unit 40(8)"
 change_element_definition e=orange_885_1 s=on  "FMD Unit 41(8)"
 change_element_definition e=orange_885_2 s=on  "FMD Unit 42(8)"
 change_element_definition e=orange_885_3 s=on  "FMD Unit 43(8)"
 change_element_definition e=green_7021_2 s=on  "Tape Channel 32(8)"
 change_element_definition e=g50 s=on           "Tape Unit 0"
 change_element_definition e=g51 s=on           "Tape Unit 1"
 change_element_definition e=green_DI_300119 s=on "DI 381"
delfc $echo output
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
 display_value 'Initializing orange_885_1 as VSN041'
 initialize_ms_volume element=orange_885_1 recorded_vsn=VSN041
 display_value 'Initializing orange_885_2 as VSN042'
 initialize_ms_volume element=orange_885_2 recorded_vsn=VSN042
 display_value 'Initializing orange_885_3 as VSN043'
 initialize_ms_volume element=orange_885_3 recorded_vsn=VSN043
 display_value 'Adding VSN041 to set'
 add_volume_to_set member_vsn=VSN041
 display_value 'Adding VSN042 to set'
 add_volume_to_set member_vsn=VSN042
 display_value 'Adding VSN043 to set'
 add_volume_to_set member_vsn=VSN043
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_channel_network n=109(16) cs=green_DI_300119 rr=false
define_host_network n=109(10)
end_prolog_file

PROCEND SN109_FMD_2X4_A
*DECK DECK=RAI$PROLOG_SN109_FMD_2X4_B EXPAND=FALSE
PROCEDURE SN109_FMD_2X4_B (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
crefc $echo output
 change_element_definition e=orange_7155_2 s=on "Disk Channel 26(8)"
 change_element_definition e=orange_7155_3 s=on "Disk Channel  6(8)"
 change_element_definition e=orange_885_4 s=on  "FMD Unit 44(8)"
 change_element_definition e=orange_885_5 s=on  "FMD Unit 45(8)"
 change_element_definition e=orange_885_6 s=on  "FMD Unit 46(8)"
 change_element_definition e=orange_885_7 s=on  "FMD Unit 47(8)"
 change_element_definition e=green_7021_2 s=on "Tape Channel 32(8)"
 change_element_definition e=g50 s=on           "Tape Unit 0"
 change_element_definition e=g51 s=on           "Tape Unit 1"
 change_element_definition e=green_DI_300119 s=on "DI 381"
delfc $echo output
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
 display_value 'Initializing orange_885_5 as VSN045'
 initialize_ms_volume element=orange_885_5 recorded_vsn=VSN045
 display_value 'Initializing orange_885_6 as VSN046'
 initialize_ms_volume element=orange_885_6 recorded_vsn=VSN046
 display_value 'Initializing orange_885_7 as VSN047'
 initialize_ms_volume element=orange_885_7 recorded_vsn=VSN047
 display_value 'Adding VSN045 to set'
 add_volume_to_set member_vsn=VSN045
 display_value 'Adding VSN046 to set'
 add_volume_to_set member_vsn=VSN046
 display_value 'Adding VSN047 to set'
 add_volume_to_set member_vsn=VSN047
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_channel_network n=109(16) cs=green_DI_300119 rr=false
define_host_network n=109(10)
end_prolog_file

PROCEND SN109_FMD_2X4_B
*DECK DECK=RAI$PROLOG_SN109_TEMP EXPAND=FALSE
" DECK NAME: RAI$PROLOG_SN109_TEMP         "
$local.create_prolog_file prolog_name=sn109_clsh_temp file=pcu_subcommands
EDIT_PHYSICAL_CONFIGURATION
" enable disk elements normally used by NOS/VE
  change_element_definition green_7165_1 state=on ic=((ch9 0))                "Channel pair A: 9 [11(8)] "
  add_element_definition green_7165_2 ei=$7165_22 sn=6289 s=on ic=((ch27 0))  "Channel pair A: 27 [33(8)] "
  change_element_definition green_895_0 state=on pc=((green_7165_1 0))        "S95A00--user/sys temp           "
  change_element_definition green_895_1 state=on pc=((green_7165_1 1))        "V95A01--pf,sys swap             "
  change_element_definition green_895_2 state=on pc=((green_7165_1 2))        "V95A02--pf,sys swap             "
  change_element_definition green_895_3 state=on pc=((green_7165_2 3))        "V95A03--pf,sys swap             "
  change_element_definition green_895_4 state=on pc=((green_7165_2 4))        "V95A04--pf,sys swap             "
  change_element_definition green_895_5 state=on pc=((green_7165_2 5))        "V95A05--pf,sys swap             "
  change_element_definition green_895_6 state=on pc=((green_7165_2 6))        "V95A06--pf,sys swap             "
  change_element_definition green_895_7 state=on pc=((green_7165_2 7))        "V95A07--pf,sys swap             "
  change_element_definition green_7155_2 state=on                             "Channel  4 [04(8)]              "
  change_element_definition green_7155_4 state=on                             "Channel 19 [23(8)]              "
  change_element_definition green_7155_6 state=on                             "Channel 21 [25(8)]              "
  change_element_definition green_885_1 state=on                              "V85B40--pf,sys/user temp        "
  change_element_definition green_885_2 state=on                              "V85B41--pf,sys/user temp,cat    "
  change_element_definition green_885_3 state=on                              "V85C42--pf,sys/user temp        "
  change_element_definition green_885_4 state=on                              "V85C43--pf,sys/user temp,cat    "
  change_element_definition green_885_5 state=on                              "V85D44--pf,sys/user temp        "
  change_element_definition green_885_6 state=on                              "V85D45--cat,pf,sys/user temp    "
" enable tape elements normally used by NOS/VE  
  change_element_definition e=green_7021_1 state=on ipn=e2c7021 "Channel 11 [13(8)], dual pp"
  change_element_definition e=green_7021_2 state=on ipn=e2c7021 "Channel 26 [32(8)], dual pp"
  change_element_definition e=g50 state=on
  change_element_definition e=g51 state=on
  change_element_definition e=g52 state=on
  change_element_definition e=g53 state=on
  change_element_definition e=g54 state=on
  change_element_definition e=g55 state=on
" enable DI elements normally used by NOS/VE  
  change_element_definition element= green_DI_300119 state=on     "DI sn381  "
  change_element_definition element= green_NAD_1 state=on
QUIT
**
$local.create_prolog_file prolog_name=sn109_clsh_temp ..
      file=lcu_mainframe_subcommands
initialize_ms_volume element=green_895_1 recorded_vsn=v95a01
initialize_ms_volume element=green_895_2 recorded_vsn=v95a02
initialize_ms_volume element=green_895_3 recorded_vsn=v95a03
initialize_ms_volume element=green_895_4 recorded_vsn=v95a04
initialize_ms_volume element=green_895_5 recorded_vsn=v95a05
initialize_ms_volume element=green_895_6 recorded_vsn=v95a06
initialize_ms_volume element=green_895_7 recorded_vsn=v95a07
initialize_ms_volume element=green_885_1 recorded_vsn=v85b40
initialize_ms_volume element=green_885_2 recorded_vsn=v85b41
initialize_ms_volume element=green_885_3 recorded_vsn=v85c42
initialize_ms_volume element=green_885_4 recorded_vsn=v85c43
initialize_ms_volume element=green_885_5 recorded_vsn=v85d44
initialize_ms_volume element=green_885_6 recorded_vsn=v85d45
chamsc V95a01 dc=l
chamsc V95a02 dc=l
chamsc V95a03 dc=l
chamsc V95a04 dc=l
chamsc V95a05 dc=l
chamsc V95a06 dc=l
chamsc V95a07 dc=l
chamsc V85b40 dc=(c l)
chamsc V85b41 dc=c
chamsc V85c42 dc=(c l)
chamsc V85c43 dc=c
chamsc V85d44 dc=(c l)
chamsc V85d45 dc=c
add_volume_to_set member_vsn=v95a01
add_volume_to_set member_vsn=v95a02
add_volume_to_set member_vsn=v95a03
add_volume_to_set member_vsn=v95a04
add_volume_to_set member_vsn=v95a05
add_volume_to_set member_vsn=v95a06
add_volume_to_set member_vsn=v95a07
add_volume_to_set member_vsn=v85b40
add_volume_to_set member_vsn=v85b41
add_volume_to_set member_vsn=v85c42
add_volume_to_set member_vsn=v85c43
add_volume_to_set member_vsn=v85d44
add_volume_to_set member_vsn=v85d45
chamsc s95a00 dc=(c l m n)
**
$local.create_prolog_file prolog_name=sn109_clsh_temp ..
      file=lcu_network_subcommands
define_channel_network network=0855109 connected_system=green_DI_300119
**
*DECK DECK=RAI$PROLOG_SN260_CLOSED_SHOP EXPAND=FALSE
PROCEDURE SN260_CLOSED_SHOP (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
  change_element_definition element=yellow_7165_1 state=on
  change_element_definition element=yellow_895_1 state=on
  change_element_definition element=yellow_895_2 state=on
  change_element_definition element=yellow_895_3 state=on
  change_element_definition element=yellow_895_4 state=on
  change_element_definition element=yellow_895_5 state=on
  change_element_definition element=yellow_895_6 state=on
  change_element_definition element=yellow_895_7 state=on
  change_element_definition element=yellow_895_8 state=on
  change_element_definition element=yellow_7155_1 state=on
  change_element_definition element=yellow_7155_2 state=on
  change_element_definition element=yellow_7155_3 state=on
  change_element_definition element=yellow_885_1 state=on
  change_element_definition element=yellow_885_2 state=on
  change_element_definition element=yellow_885_3 state=on
  change_element_definition element=yellow_885_4 state=on
  change_element_definition element=yellow_885_5 state=on
  change_element_definition element=yellow_885_6 state=on
  change_element_definition element=yellow_885_7 state=on
  change_element_definition element=yellow_885_8 state=on
  change_element_definition element=yellow_7021_1 state=on
  change_element_definition element=y50 state=on
  change_element_definition element=y51 state=on
  change_element_definition element=y52 state=on
  change_element_definition element=y53 state=on
  change_element_definition element=stornet260 state=on ..
                        ic=((ch2 0 $system_0855_0260 iou0), ..
                            (ch2 0 $system_9323_2001 iou0), ..
                            (ch7 0 $system_0855_0109 iou0), ..
                            (cch3 0 $system_0855_0109 iou0), ..
                            (cch5 0 $system_0855_0109 iou0), ..
                            (cch1 0 $system_0990_0102 iou0), ..
                            (cch5 0 $system_0990_0102 iou0))


  change_element_definition element=green_DI_300119 state=on
  change_element_definition element=yellow_NAD_2 state=on
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
initialize_ms_volume element=yellow_885_1 recorded_vsn=V85B40
initialize_ms_volume element=yellow_885_2 recorded_vsn=V85B41
initialize_ms_volume element=yellow_885_3 recorded_vsn=V85C42
initialize_ms_volume element=yellow_885_4 recorded_vsn=V85C43
initialize_ms_volume element=yellow_885_5 recorded_vsn=V85D44
initialize_ms_volume element=yellow_885_6 recorded_vsn=V85D45
initialize_ms_volume element=yellow_885_7 recorded_vsn=V85B46
initialize_ms_volume element=yellow_885_8 recorded_vsn=V85B47
initialize_ms_volume element=yellow_895_2 recorded_vsn=V95L17
initialize_ms_volume element=yellow_895_3 recorded_vsn=V95L18
initialize_ms_volume element=yellow_895_4 recorded_vsn=V95L19
initialize_ms_volume element=yellow_895_5 recorded_vsn=V95L20
initialize_ms_volume element=yellow_895_6 recorded_vsn=V95L21
initialize_ms_volume element=yellow_895_7 recorded_vsn=V95L22
initialize_ms_volume element=yellow_895_8 recorded_vsn=V95L23
change_ms_class V95L17 dc=all ac=(a b c d e f g h i           o p   r s t u v w x y z)
change_ms_class V95L18 dc=all ac=(a b   d e f g h i         n o p   r s t u v w x y z)
change_ms_class V95L19 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class V95L20 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class V95L21 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class V95L22 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class V95L23 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class V85B40 dc=all ac=(a b   d e f g h i   k       o p   r s t u v w x y z)
change_ms_class V85B41 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class V85C42 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class V85C43 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class V85D44 dc=all ac=(a b   d e f g h i       m   o p   r s t u v w x y z)
change_ms_class V85D45 dc=all ac=(a b   d e f g h i   k       o p   r s t u v w x y z)
change_ms_class V85B46 dc=all ac=(a b   d e f g h i j   l     o p   r s t u v w x y z)
change_ms_class V85B47 dc=all ac=(a b   d e f g h i         n o p   r s t u v w x y z)
add_volume_to_set member_vsn=V95L17
add_volume_to_set member_vsn=V95L18
add_volume_to_set member_vsn=V95L19
add_volume_to_set member_vsn=V95L20
add_volume_to_set member_vsn=V95L21
add_volume_to_set member_vsn=V95L22
add_volume_to_set member_vsn=V95L23
add_volume_to_set member_vsn=V85B40
add_volume_to_set member_vsn=V85B41
add_volume_to_set member_vsn=V85C42
add_volume_to_set member_vsn=V85C43
add_volume_to_set member_vsn=V85D44
add_volume_to_set member_vsn=V85D45
add_volume_to_set member_vsn=V85B46
add_volume_to_set member_vsn=V85B47
change_ms_class S95L16 dc=all ac=(a b   d e f g h i           o p q r s t u v w x y z)
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
end_prolog_file

PROCEND SN260_CLOSED_SHOP
*DECK DECK=RAI$PROLOG_SN302_DAS EXPAND=TRUE
PROCEDURE SN302_DAS (                                                                                                               
  status)                                                                                                                           
                                                                                                                                    
COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'                                                                         
EDIT_PHYSICAL_CONFIGURATION                                                                                                         
 delete_element_definition e=all r=(..                                                                                              
 vcm6_das   ..                                                                                                                      
 vcm7_das   ..                                                                                                                      
 vdas_0 ..                                                                                                                          
 vdas_8 ..                                                                                                                          
 vdas_16 ..                                                                                                                         
 vdas_24 ..                                                                                                                         
 violet_7021_1 ..                                                                                                                   
 v50 ..                                                                                                                             
 v51 ..                                                                                                                             
 v52 ..                                                                                                                             
 v55 ..                                                                                                                             
 stornet ..                                                                                                                         
 violet_DI_3000f0 ..                                                                                                                
 violet_DI_100092 ..                                                                                                                
 $7992_10_1_0 ..                                                                                                                    
 xlink_violet ..                                                                                                                    
 drd_dum0 ..                                                                                                                        
 sma_drd0 ..                                                                                                                        
 sma_drd1)                                                                                                                          
                                                                                                                                    
 change_element_definition e=vcm6_das  s=on                                                                                         
 change_element_definition e=vcm7_das  s=on                                                                                         
 change_element_definition e=vdas_0  s=on                                                                                           
 change_element_definition e=vdas_8  s=on                                                                                           
 change_element_definition e=vdas_16  s=on                                                                                          
 change_element_definition e=vdas_24  s=on                                                                                          
 change_element_definition e=violet_7021_1  s=on            "VE Tapes-CH33(8)"                                                      
 change_element_definition e=v50            s=on  pc=((violet_7021_1 0))                                                            
                                                                  "679 Unit 0"                                                      
 change_element_definition e=v51            s=on  pc=((violet_7021_1 1))                                                            
                                                                  "679 Unit 1"                                                      
 change_element_definition e=v52           s=off  pc=((violet_7021_1 2))                                                            
                                                                  "679 Unit 2"                                                      
 change_element_definition e=v55            s=on  pc=((violet_7021_1 5))                                                            
                                                                  "679 Unit 5"                                                      
 change_element_definition e=xlink_violet   s=off  "EXPRESS LINK to LIZZIE"                                                         
 change_element_definition e=stornet        s=on                                                                                    
 change_element_definition e=violet_DI_3000f0 s=on "DI 340"                                                                         
QUIT                                                                                                                                
end_prolog_file                                                                                                                     
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'                                                               
 display_value 'Initializing vdas_8 as VSN3A1'                                                                                      
 initialize_ms_volume element=vdas_8 recorded_vsn=VSN3A1                                                                            
 display_value 'Initializing vdas_16 as VSN3A2'                                                                                     
 initialize_ms_volume element=vdas_16 recorded_vsn=VSN3A2                                                                           
 display_value 'Initializing vdas_24 as VSN3A3'                                                                                     
 initialize_ms_volume element=vdas_24 recorded_vsn=VSN3A3                                                                           
"ENTER CHAMSC HERE"                                                                                                                 
"CLASS X WILL CONTAIN SCU_BOUND_PRODUCT"                                                                                            
"CLASS Y WILL CONTAIN FORTRAN_BOUND_PRODUCT"                                                                                        
"CLASS Z WILL CONTAIN COBOL_BOUND_PRODUCT"                                                                                          
CHAMSC VSN3A0 DC=(X Y Z)                                                                                                            
CHAMSC VSN3A1 DC=(Y Z)                                                                                                              
CHAMSC VSN3A2 DC=(Y Z)                                                                                                              
CHAMSC VSN3A3 DC=(Y Z)                                                                                                              
 display_value 'Adding VSN3A1 to set'                                                                                               
 add_volume_to_set member_vsn=VSN3A1                                                                                                
 display_value 'Adding VSN3A2 to set'                                                                                               
 add_volume_to_set member_vsn=VSN3A2                                                                                                
 display_value 'Adding VSN3A3 to set'                                                                                               
 add_volume_to_set member_vsn=VSN3A3                                                                                                
end_prolog_file                                                                                                                     
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'                                                                 
define_network_connection connected_system=violet_DI_3000f0                                                                         
define_host_network n=302(10)                                                                                                       
end_prolog_file                                                                                                                     
                                                                                                                                    
PROCEND SN302_DAS                                                                                                                   
                                                                                                                                    
*DECK DECK=RAI$PROLOG_SN302_FMD_2X4_A EXPAND=FALSE
*DECK DECK=RAI$PROLOG_SN302_FMD_2X4_PF EXPAND=FALSE
*DECK DECK=RAI$PROLOG_SN302_HYDRAS EXPAND=TRUE
PROCEDURE SN302_HYDRAS (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
 delete_element_definition e=all r=(..
 hyd0_violet ..
 hyd1_violet ..
 violet_7021_1 ..
 v50 ..
 v51 ..
 v52 ..
 v55 ..
 stornet ..
 violet_nad_1 ..
 violet_DI_3000f0 ..
 $7992_10_1_0 ..
 xlink_violet ..
 drd_dum0 ..
 sma_drd0 ..
 sma_drd1)

 change_element_definition e=hyd0_violet ic=((cch7a 0)) s=on
 change_element_definition e=hyd1_violet ic=((cch7a 1)) s=on
 change_element_definition e=violet_7021_1              s=on "VE Tapes(CH33(8)"
 change_element_definition e=v50 pc=((violet_7021_1 0)) s=on "679 Unit 0"
 change_element_definition e=v51 pc=((violet_7021_1 1)) s=on "679 Unit 1"
 change_element_definition e=v52 pc=((violet_7021_1 2)) s=off "679 Unit 2"
 change_element_definition e=v55 pc=((violet_7021_1 5)) s=on  "679 Unit 5"
 change_element_definition e=xlink_violet               s=off  "EXPRESS LINK to LIZZIE"
 change_element_definition e=stornet                    s=on
 change_element_definition e=violet_nad_1               s=on
 change_element_definition e=violet_DI_3000f0           s=on "DI 340"

QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
 display_value 'Initializing HYD1_VIOLET as VSN7A1'
 initialize_ms_volume element=hyd1_violet recorded_vsn=vsn7a1
 display_value 'Adding VSN7A1 to set'
 add_volume_to_set member_vsn=vsn7a1
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_network_connection connected_system=violet_DI_3000f0
define_host_network n=302(10)
end_prolog_file

PROCEND sn302_hydras
*DECK DECK=RAI$PROLOG_SN302_HYDRAS_PF EXPAND=TRUE
PROCEDURE SN302_HYDRAS_PF (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
 delete_element_definition e=all r=(..
 hyd6a0_violet ..
 hyd6a1_violet ..
 hyd6a2_violet ..
 hyd6a3_violet ..
 violet_7021_1 ..
 v50 ..
 v51 ..
 stornet ..
 violet_nad_1 ..
 violet_DI_3000f0)

 change_element_definition e=hyd6a0_violet    s=on
 change_element_definition e=hyd6a1_violet    s=on
 change_element_definition e=hyd6a2_violet    s=on
 change_element_definition e=hyd6a3_violet    s=on
 change_element_definition e=violet_7021_1    s=on  "VE Tapes(CH33(8)"
 change_element_definition e=v50 pc=((violet_7021_1 0)) s=on  "679 Unit 0"
 change_element_definition e=v51 pc=((violet_7021_1 1)) s=on  "679 Unit 1"
 change_element_definition e=stornet          s=on
 change_element_definition e=violet_nad_1     s=on
 change_element_definition e=violet_DI_3000f0 s=on "DI 340"

QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
 display_value 'Initializing HYD6A1_VIOLET as VSN6A1'
 initialize_ms_volume element=hyd6a1_violet recorded_vsn=vsn6a1
 display_value 'Initializing HYD6A2_VIOLET as VSN6A2'
 initialize_ms_volume element=hyd6a2_violet recorded_vsn=vsn6a2
 display_value 'Initializing HYD6A3_VIOLET as VSN6A3'
 initialize_ms_volume element=hyd6a3_violet recorded_vsn=vsn6a3
 display_value 'Adding VSN6A1 to set'
 add_volume_to_set member_vsn=vsn6a1
 display_value 'Adding VSN6A2 to set'
 add_volume_to_set member_vsn=vsn6a2
 display_value 'Adding VSN6A3 to set'
 add_volume_to_set member_vsn=vsn6a3
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_network_connection connected_system=violet_DI_3000f0
define_host_network n=302(10)
end_prolog_file

PROCEND sn302_hydras_pf
*DECK DECK=RAI$PROLOG_SN302_SABRE_2X8 EXPAND=TRUE
PROCEDURE SN302_SABRE_2X8(
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
 delete_element_definition e=all r=(..
 violet_5831_6 ..
 violet_5831_7 ..
 violet_5833_00 ..
 violet_5833_08 ..
 violet_5833_10 ..
 violet_5833_18 ..
 violet_5833_01 ..
 violet_5833_09 ..
 violet_5833_11 ..
 violet_5833_19 ..
 violet_7021_1 ..
 v50 ..
 v51 ..
 stornet ..
 violet_DI_100092)

 change_element_definition e=violet_5831_6    s=on  ic=((cch5b 6))
 change_element_definition e=violet_5831_7    s=on  ic=((cch9b 7))
 change_element_definition e=violet_5833_00   s=on  pc=((violet_5831_6 00))
 change_element_definition e=violet_5833_08   s=on  pc=((violet_5831_6 08))
 change_element_definition e=violet_5833_10   s=on  pc=((violet_5831_6 16))
 change_element_definition e=violet_5833_18   s=on  pc=((violet_5831_6 24))
 change_element_definition e=violet_5833_01   s=on  pc=((violet_5831_7 01))
 change_element_definition e=violet_5833_09   s=on  pc=((violet_5831_7 09))
 change_element_definition e=violet_5833_11   s=on  pc=((violet_5831_7 17))
 change_element_definition e=violet_5833_19   s=on  pc=((violet_5831_7 25))
 change_element_definition e=violet_7021_1    s=on
 change_element_definition e=v50              s=on  pc=((violet_7021_1 0))
 change_element_definition e=v51              s=on  pc=((violet_7021_1 1))
 change_element_definition e=stornet          s=on
 change_element_definition e=violet_DI_100092 s=on
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
 display_value 'Initializing violet_5833_08 as VSN001'
 initialize_ms_volume element=violet_5833_08 recorded_vsn=VSN001
 display_value 'Initializing violet_5833_10 as VSN002'
 initialize_ms_volume element=violet_5833_10 recorded_vsn=VSN002
 display_value 'Initializing violet_5833_18 as VSN003'
 initialize_ms_volume element=violet_5833_18 recorded_vsn=VSN003
 display_value 'Initializing violet_5833_01 as VSN004'
 initialize_ms_volume element=violet_5833_01 recorded_vsn=VSN004
 display_value 'Initializing violet_5833_09 as VSN005'
 initialize_ms_volume element=violet_5833_09 recorded_vsn=VSN005
 display_value 'Initializing violet_5833_11 as VSN006'
 initialize_ms_volume element=violet_5833_11 recorded_vsn=VSN006
 display_value 'Initializing violet_5833_19 as VSN007'
 initialize_ms_volume element=violet_5833_19 recorded_vsn=VSN007
"ENTER CHAMSC HERE"
"CLASS X WILL CONTAIN SCU_BOUND_PRODUCT"
"CLASS Y WILL CONTAIN FORTRAN_BOUND_PRODUCT"
"CLASS Z WILL CONTAIN COBOL_BOUND_PRODUCT"
CHAMSC VSN000 DC=(X Y Z)
CHAMSC VSN001 DC=(X Y Z)
CHAMSC VSN002 DC=(Y Z)
CHAMSC VSN003 DC=(X Y Z)
CHAMSC VSN004 DC=(X Y)
CHAMSC VSN005 DC=(X Y Z)
CHAMSC VSN006 DC=(X Z)
CHAMSC VSN007 DC=(X Y Z)
 display_value 'Adding VSN001 to set'
 add_volume_to_set member_vsn=VSN001
 display_value 'Adding VSN002 to set'
 add_volume_to_set member_vsn=VSN002
 display_value 'Adding VSN003 to set'
 add_volume_to_set member_vsn=VSN003
 display_value 'Adding VSN004 to set'
 add_volume_to_set member_vsn=VSN004
 display_value 'Adding VSN005 to set'
 add_volume_to_set member_vsn=VSN005
 display_value 'Adding VSN006 to set'
 add_volume_to_set member_vsn=VSN006
 display_value 'Adding VSN007 to set'
 add_volume_to_set member_vsn=VSN007
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_network_connection connected_system=violet_DI_100092
define_host_network n=302(10)
end_prolog_file

PROCEND SN302_SABRE_2X8
*DECK DECK=RAI$PROLOG_SN302_SABRE_HOTKEY EXPAND=TRUE
PROCEDURE SN302_SABRE_HOTKEY(
  status)

 COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
 EDIT_PHYSICAL_CONFIGURATION
  delete_element_definition e=all r=(..
  violet_5831_6 ..
  violet_5831_7 ..
  violet_5833_00 ..
  violet_5833_08 ..
  violet_5833_10 ..
  violet_5833_18 ..
  violet_5833_01 ..
  violet_5833_09 ..
  violet_5833_11 ..
  violet_5833_19 ..
  violet_7021_1 ..
  v50 ..
  v51 ..
  stornet ..
  violet_DI_100092 ..
  violet_DI_3000D3 ..
  violet_DI_3000F0)

  change_element_definition e=violet_5831_6    s=on  ic=((cch5b 6))
  change_element_definition e=violet_5831_7    s=on  ic=((cch9b 7))
  change_element_definition e=violet_5833_00   s=on  pc=((violet_5831_6 00))
  change_element_definition e=violet_5833_08   s=on  pc=((violet_5831_6 08))
  change_element_definition e=violet_5833_10   s=on  pc=((violet_5831_6 16))
  change_element_definition e=violet_5833_18   s=on  pc=((violet_5831_6 24))
  change_element_definition e=violet_5833_01   s=on  pc=((violet_5831_7 01))
  change_element_definition e=violet_5833_09   s=on  pc=((violet_5831_7 09))
  change_element_definition e=violet_5833_11   s=on  pc=((violet_5831_7 17))
  change_element_definition e=violet_5833_19   s=on  pc=((violet_5831_7 25))
  change_element_definition e=violet_7021_1    s=on
  change_element_definition e=v50              s=on  pc=((violet_7021_1 0))
  change_element_definition e=v51              s=on  pc=((violet_7021_1 1))
  change_element_definition e=stornet          s=on
  change_element_definition e=violet_DI_100092 s=on
  change_element_definition e=violet_DI_3000D3 s=on
  change_element_definition e=violet_DI_3000F0 s=on
 QUIT
end_prolog_file
 COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
  display_value 'Initializing violet_5833_08 as VSN001'
  initialize_ms_volume element=violet_5833_08 recorded_vsn=VSN001
  display_value 'Initializing violet_5833_10 as VSN002'
  initialize_ms_volume element=violet_5833_10 recorded_vsn=VSN002
  display_value 'Initializing violet_5833_18 as VSN003'
  initialize_ms_volume element=violet_5833_18 recorded_vsn=VSN003
  display_value 'Initializing violet_5833_01 as VSN004'
  initialize_ms_volume element=violet_5833_01 recorded_vsn=VSN004
  display_value 'Initializing violet_5833_09 as VSN005'
  initialize_ms_volume element=violet_5833_09 recorded_vsn=VSN005
  display_value 'Initializing violet_5833_11 as VSN006'
  initialize_ms_volume element=violet_5833_11 recorded_vsn=VSN006
  display_value 'Initializing violet_5833_19 as VSN007'
  initialize_ms_volume element=violet_5833_19 recorded_vsn=VSN007
 "ENTER CHAMSC HERE"
 "CLASS X WILL CONTAIN SCU_BOUND_PRODUCT"
 "CLASS Y WILL CONTAIN FORTRAN_BOUND_PRODUCT"
 "CLASS Z WILL CONTAIN COBOL_BOUND_PRODUCT"
 CHAMSC VSN000 DC=(X Y Z)
 CHAMSC VSN001 DC=(X Y Z)
 CHAMSC VSN002 DC=(Y Z)
 CHAMSC VSN003 DC=(X Y Z)
 CHAMSC VSN004 DC=(X Y)
 CHAMSC VSN005 DC=(X Y Z)
 CHAMSC VSN006 DC=(X Z)
 CHAMSC VSN007 DC=(X Y Z)
  display_value 'Adding VSN001 to set'
  add_volume_to_set member_vsn=VSN001
  display_value 'Adding VSN002 to set'
  add_volume_to_set member_vsn=VSN002
  display_value 'Adding VSN003 to set'
  add_volume_to_set member_vsn=VSN003
  display_value 'Adding VSN004 to set'
  add_volume_to_set member_vsn=VSN004
  display_value 'Adding VSN005 to set'
  add_volume_to_set member_vsn=VSN005
  display_value 'Adding VSN006 to set'
  add_volume_to_set member_vsn=VSN006
  display_value 'Adding VSN007 to set'
  add_volume_to_set member_vsn=VSN007
end_prolog_file
 COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
 define_network_connection connected_system=violet_DI_100092
 define_network_connection connected_system=violet_DI_3000D3
 define_network_connection connected_system=violet_DI_3000F0
 define_host_network n=302(10)
end_prolog_file

PROCEND SN302_SABRE_HOTKEY
*DECK DECK=RAI$PROLOG_SN302_XMD3_1X4 EXPAND=FALSE
PROCEDURE SN302_XMD3_1X4 (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
 delete_element_definition e=all r=(..
 violet_xmd_cm_2 ..
 violet_xmd_cm_3 ..
 violet_9853_0 ..
 violet_9853_1 ..
 violet_9853_2 ..
 violet_9853_3 ..
 violet_7021_1 ..
 v50 ..
 v51 ..
 v52 ..
 v55 ..
 stornet ..
 violet_DI_3000f0 ..
 violet_DI_100092 ..
 $7992_10_1_0 ..
 xlink_violet ..
 drd_dum0 ..
 sma_drd0 ..
 sma_drd1)

 change_element_definition e=violet_xmd_cm_2    s=on  ic=((cch5a 2))
 change_element_definition e=violet_xmd_cm_3    s=on  ic=((cch5a 3))
 change_element_definition e=violet_9853_0  s=on  pc=((violet_xmd_cm_2 0))
                                                                  "XMD-1841"
 change_element_definition e=violet_9853_1  s=on  pc=((violet_xmd_cm_2 1))
                                                                  "XMD-1840"
 change_element_definition e=violet_9853_2  s=on  pc=((violet_xmd_cm_3 2))
                                                                  "XMD-1782"
 change_element_definition e=violet_9853_3  s=on  pc=((violet_xmd_cm_3 3))
                                                                  "XMD-1838"
 change_element_definition e=violet_7021_1  s=on            "VE Tapes-CH33(8)"
 change_element_definition e=v50            s=on  pc=((violet_7021_1 0))
                                                                  "679 Unit 0"
 change_element_definition e=v51            s=on  pc=((violet_7021_1 1))
                                                                  "679 Unit 1"
 change_element_definition e=v52           s=off  pc=((violet_7021_1 2))
                                                                  "679 Unit 2"
 change_element_definition e=v55            s=on  pc=((violet_7021_1 5))
                                                                  "679 Unit 5"
 change_element_definition e=xlink_violet   s=off  "EXPRESS LINK to LIZZIE"
 change_element_definition e=stornet        s=on
 change_element_definition e=violet_DI_3000f0 s=on "DI 340"
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
 display_value 'Initializing violet_9853_1 as VSN001'
 initialize_ms_volume element=violet_9853_1 recorded_vsn=VSN001
 display_value 'Initializing violet_9853_2 as VSN002'
 initialize_ms_volume element=violet_9853_2 recorded_vsn=VSN002
 display_value 'Initializing violet_9853_3 as VSN003'
 initialize_ms_volume element=violet_9853_3 recorded_vsn=VSN003
"ENTER CHAMSC HERE"
"CLASS X WILL CONTAIN SCU_BOUND_PRODUCT"
"CLASS Y WILL CONTAIN FORTRAN_BOUND_PRODUCT"
"CLASS Z WILL CONTAIN COBOL_BOUND_PRODUCT"
CHAMSC VSN000 DC=(X Y Z)
CHAMSC VSN001 DC=(Y Z)
CHAMSC VSN002 DC=(X Y)
CHAMSC VSN003 DC=(X Z)
 display_value 'Adding VSN001 to set'
 add_volume_to_set member_vsn=VSN001
 display_value 'Adding VSN002 to set'
 add_volume_to_set member_vsn=VSN002
 display_value 'Adding VSN003 to set'
 add_volume_to_set member_vsn=VSN003
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_network_connection connected_system=violet_DI_3000f0
define_host_network n=302(10)
end_prolog_file

PROCEND SN302_XMD3_1X4
*DECK DECK=RAI$PROLOG_SN498_CLOSED_SHOP EXPAND=FALSE
PROCEDURE SN498_CLOSED_SHOP (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
edit_physical_configuration
change_element_definition  e=C_7155_104  state=on            " NIO0.CH16.C0.U32               "
change_element_definition  e=C_7155_103  state=on            " NIO0.CH17.C1.U33               "
change_element_definition  e=DU_885_27573_A  state=on        " V85A00
change_element_definition  e=DU_885_27573_B  state=on        " V85A01

change_element_definition  e=C_FA7B5_2000    state=on        " CIO0.CCH1A.C0.U0/U1            "
change_element_definition  e=C_FA7B5_2004    state=on        " CIO0.CCH1A.C1.U2/U3            "
change_element_definition  e=DU_9853_5294    state=on        " V53B00
change_element_definition  e=DU_9853_5303    state=on        " V53B01
change_element_definition  e=DU_9853_5292    state=on        " V53B02
change_element_definition  e=DU_9853_5298    state=on        " V53B03

change_element_definition  e=C_7021_645      state=on        "                                "
change_element_definition  e=C_7021_459      state=on        "                                "
change_element_definition  e=PL50            state=on        " TAPE UNITS                     "
change_element_definition  e=PL51            state=on        "                                "
change_element_definition  e=PL52            state=on        "                                "
change_element_definition  e=PL53            state=on        "                                "

change_element_definition  e=CE_2620_382     state=on        "  DI  ; NIO0.CH5.               "
change_element_definition  e=CE_2620_1540    state=on        "  DI  ; NIO0.CH7.               "
change_element_definition  e=CE_380_279      state=on        "  NAD ; NIO0.CH20.              "
change_element_definition  e=CE_7040_107     state=on        "  ESM ; NIO0.CH6.               "
quit
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
initialize_ms_volume     e=DU_885_27573_A   rvsn=V85A00
initialize_ms_volume     e=DU_885_27573_B   rvsn=V85A01
initialize_ms_volume     e=DU_9853_5303     rvsn=V53B01
initialize_ms_volume     e=DU_9853_5292     rvsn=V53B02
initialize_ms_volume     e=DU_9853_5298     rvsn=V53B03

change_ms_class       rvsn=S53B00             dc=(C J K L M N   )     " system device (class Q) "
change_ms_class       rvsn=V85A00             dc=(C   K   M N Q)      " system catalogs (class J/L) "
change_ms_class       rvsn=V85A01             dc=(C J K L M   Q)      " system temp (class N) "
change_ms_class       rvsn=V53B01             dc=(C J   L   N Q)      " system files (class K & M) "
change_ms_class       rvsn=V53B02             dc=(C J K L M   Q)      " system temp (class N) "
change_ms_class       rvsn=V53B03             dc=(  J K L M N Q)      " system swap device (class C) "

add_volume_to_set     memvsn=V85A00      set_name=PLUM_SYSTEM
add_volume_to_set     memvsn=V85A01      set_name=PLUM_SYSTEM
add_volume_to_set     memvsn=V53B01      set_name=PLUM_SYSTEM
add_volume_to_set     memvsn=V53B02      set_name=PLUM_SYSTEM
add_volume_to_set     memvsn=V53B03      set_name=PLUM_SYSTEM

end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
end_prolog_file

PROCEND SN498_CLOSED_SHOP
*DECK DECK=RAI$PROLOG_SN604_ISD2_1X2 EXPAND=FALSE
PROCEDURE SN604_ISD2_1X2 (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
crefc $echo output
 change_element_definition e=red_fa7b4_12 s=on  ic=((ch16 1))
                                                "Disk Channel 20(8)-CM1"
 change_element_definition e=red_836_12   s=on  "ISD2-Unit12"
 change_element_definition e=red_fa7b4_23 s=on  ic=((ch16 2))
                                                "Disk Channel 20(8)-CM2"
 change_element_definition e=red_836_23   s=on  "ISD2-Unit23"
 change_element_definition e=red_7021_2  s=on  "Tape Controller-CH23(8)"
 change_element_definition e=r50         s=on  "Tape Unit  0"
 change_element_definition e=r51         s=on  "Tape Unit  1"
 change_element_definition e=red_DI_10006b s=on "DI 107"
delfc $echo output
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
 display_value 'Initializing red_836_23 as VSN023'
 initialize_ms_volume element=red_836_23 recorded_vsn=VSN023
"ENTER CHAMSC HERE"
CHAMSC VSN012 DC=(X Y Z)
 display_value 'Adding VSN023 to set'
 add_volume_to_set member_vsn=VSN023
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_network_connection connected_system=red_DI_10006b
define_host_network n=604(10)
end_prolog_file

PROCEND SN604_ISD2_1X2
*DECK DECK=RAI$PROLOG_SN604_ISD2_2X4 EXPAND=FALSE
PROCEDURE SN604_ISD2_2X4 (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
crefc $echo output
 change_element_definition e=red_fa7b4_60 s=on  ic=((ch22 6))
                                                "Disk Channel 26(8)-CM6"
 change_element_definition e=red_fa7b4_71 s=on  ic=((ch22 7))
                                                "Disk Channel 26(8)-CM7"
 change_element_definition e=red_fa7b4_12 s=on  ic=((ch16 1))
                                                "Disk Channel 20(8)-CM1"
 change_element_definition e=red_fa7b4_23 s=on  ic=((ch16 2))
                                                "Disk Channel 20(8)-CM2"
 change_element_definition e=red_836_60   s=on  "ISD2-Unit60"
 change_element_definition e=red_836_71   s=on  "ISD2-Unit71"
 change_element_definition e=red_836_12   s=on  "ISD2-Unit12"
 change_element_definition e=red_836_23   s=on  "ISD2-Unit23"
 change_element_definition e=red_7021_2   s=on  "Tape Controller-CH23(8)"
 change_element_definition e=r50          s=on  "Tape Unit  0"
 change_element_definition e=r51          s=on  "Tape Unit  1"
 change_element_definition e=red_DI_10006b s=on "DI 107"
delfc $echo output
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
 display_value 'Initializing red_836_60 as VSN060'
 initialize_ms_volume element=red_836_60 recorded_vsn=VSN060
 display_value 'Initializing red_836_71 as VSN071'
 initialize_ms_volume element=red_836_71 recorded_vsn=VSN071
 display_value 'Initializing red_836_23 as VSN023'
 initialize_ms_volume element=red_836_23 recorded_vsn=VSN023
"ENTER CHAMSC HERE"
CHAMSC VSN012 DC=(X Y Z)
"CLASS X WILL CONTAIN SCU_BOUND_PRODUCT"
CHAMSC VSN060 DC=(Y Z)
"CLASS Z WILL CONTAIN COBOL_BOUND_PRODUCT"
CHAMSC VSN071 DC=(X Y)
"CLASS Y WILL CONTAIN FORTRAN_BOUND_PRODUCT"
CHAMSC VSN023 DC=(X Z)
 display_value 'Adding VSN060 to set'
 add_volume_to_set member_vsn=VSN060
 display_value 'Adding VSN071 to set'
 add_volume_to_set member_vsn=VSN071
 display_value 'Adding VSN023 to set'
 add_volume_to_set member_vsn=VSN023
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_network_connection connected_system=red_DI_10006b
define_host_network n=604(10)
end_prolog_file

PROCEND SN604_ISD2_2X4
*DECK DECK=RAI$PROLOG_SN604_ISD2_2X4_810 EXPAND=FALSE
PROCEDURE SN604_ISD2_2X4_810 (
  status)

COLLECT_TEXT $local.pcu_subcommands until='end_prolog_file'
EDIT_PHYSICAL_CONFIGURATION
crefc $echo output

 change_connection_reference ..
   old_mainframe_name=$system_0830_0604 new_mainframe_name=$system_0810_0604

 change_element_definition e=red_fa7b4_60 s=on  ic=((ch22 6))
                                                "Disk Channel 26(8)-CM6"
 change_element_definition e=red_fa7b4_71 s=on  ic=((ch22 7))
                                                "Disk Channel 26(8)-CM7"
 change_element_definition e=red_fa7b4_12 s=on  ic=((ch16 1))
                                                "Disk Channel 20(8)-CM1"
 change_element_definition e=red_fa7b4_23 s=on  ic=((ch16 2))
                                                "Disk Channel 20(8)-CM2"
 change_element_definition e=red_836_60   s=on  "ISD2-Unit60"
 change_element_definition e=red_836_71   s=on  "ISD2-Unit71"
 change_element_definition e=red_836_12   s=on  "ISD2-Unit12"
 change_element_definition e=red_836_23   s=on  "ISD2-Unit23"
 change_element_definition e=red_7021_2   s=on  "Tape Controller-CH23(8)"
 change_element_definition e=r50          s=on  "Tape Unit  0"
 change_element_definition e=r51          s=on  "Tape Unit  1"
 change_element_definition e=red_DI_10006b s=on "DI 107"
delfc $echo output
QUIT
end_prolog_file
COLLECT_TEXT $local.lcu_mainframe_subcommands until='end_prolog_file'
 display_value 'Initializing red_836_60 as VSN060'
 initialize_ms_volume element=red_836_60 recorded_vsn=VSN060
 display_value 'Initializing red_836_71 as VSN071'
 initialize_ms_volume element=red_836_71 recorded_vsn=VSN071
 display_value 'Initializing red_836_23 as VSN023'
 initialize_ms_volume element=red_836_23 recorded_vsn=VSN023
"ENTER CHAMSC HERE"
CHAMSC VSN012 DC=(X Y Z)
"CLASS X WILL CONTAIN SCU_BOUND_PRODUCT"
CHAMSC VSN060 DC=(Y Z)
"CLASS Z WILL CONTAIN COBOL_BOUND_PRODUCT"
CHAMSC VSN071 DC=(X Y)
"CLASS Y WILL CONTAIN FORTRAN_BOUND_PRODUCT"
CHAMSC VSN023 DC=(X Z)
 display_value 'Adding VSN060 to set'
 add_volume_to_set member_vsn=VSN060
 display_value 'Adding VSN071 to set'
 add_volume_to_set member_vsn=VSN071
 display_value 'Adding VSN023 to set'
 add_volume_to_set member_vsn=VSN023
end_prolog_file
COLLECT_TEXT $local.lcu_network_subcommands until='end_prolog_file'
define_network_connection connected_system=red_DI_10006b
define_host_network n=604(10)
end_prolog_file

PROCEND SN604_ISD2_2X4_810
*DECK DECK=RAI$PROLOG_SN631_FMD_1X2 EXPAND=FALSE

*DECK DECK=RAI$PROMPT_FOR_ANSWER EXPAND=TRUE
PROC prompt_for_answer (
  prompt, p: string = $required
  answer, a: VAR of boolean = $required)

" This procedure is similar to code in deck : RAF$PROMPT_FOR_ANSWER

  create_variable choice k=string

  display_value ('  ', $value(prompt))

answer_loop: ..
  LOOP
    accept_line choice input prompt='Enter yes or no: '
    choice = $translate(lower_to_upper, choice)
    IF (choice = 'Y' OR choice = 'YES') THEN
      $value(answer) = true
      EXIT answer_loop
    ELSEIF (choice = 'N' OR choice = 'NO') THEN
      $value(answer) = false
      EXIT answer_loop
    ELSE
      display_value '--ERROR--  You must enter yes or no.  Please try again.'
    IFEND
  LOOPEND answer_loop

PROCEND prompt_for_answer
*DECK DECK=RAI$REORDER_JOB_TEMPLATE_223 EXPAND=TRUE
IF $variable(reorder_status, declared) <> 'LOCAL' THEN
  create_variable reorder_status k=status
IFEND
reorder_module p=before status=reorder_status m=IIM$ST_UPDATE_ACTUAL_ATTRIBUTES
reorder_module p=before status=reorder_status m=PFM$R2_PUT_INFO
reorder_module p=before status=reorder_status m=STM$RING2_REMOVE_MEMBER
reorder_module p=before status=reorder_status m=STM$RING2_PURGE_SET
reorder_module p=before status=reorder_status m=STM$RING2_CREATE_SET
reorder_module p=before status=reorder_status m=STM$RING2_ADD_MEMBER
reorder_module p=before status=reorder_status m=STM$INITIALIZE_SETS
reorder_module p=before status=reorder_status m=STM$DISPLAY_VOLUME_INFO
reorder_module p=before status=reorder_status m=STM$DISPLAY_AST_INFO
reorder_module p=before status=reorder_status m=PFM$R2_DF_SERVER_REQUESTS
reorder_module p=before status=reorder_status m=PFM$R2_DF_CLIENT_REQUESTS
reorder_module p=before status=reorder_status m=PFM$COMPUTE_CHECKSUM
reorder_module p=before status=reorder_status m=MMM$SYSTEM_IMAGE_RECOVERY
reorder_module p=before status=reorder_status m=IOM$TAPE_QUEUE_MANAGER_RING2
reorder_module p=before status=reorder_status m=IIM$VT_VALIDATE_FILE_IDENTIFIER
reorder_module p=before status=reorder_status m=IIM$UPDATE_OPEN_DESC_ATTRIBUTES
reorder_module p=before status=reorder_status m=IIM$TERM_CHAR_UTILITIES
reorder_module p=before status=reorder_status m=IIM$ST_UPDATE_DEFAULT_ATRIBUTES
reorder_module p=before status=reorder_status m=IIM$ST_SEND_ATTRIBUTES_CHANGE
reorder_module p=before status=reorder_status m=IIM$ST_FETCH_ACCESS_INFORMATION
reorder_module p=before status=reorder_status m=IIM$ST_CHNG_TERMINAL_ATTRIBUTES
reorder_module p=before status=reorder_status m=IIM$ST_CHNGE_TERM_CONN_DEFAULTS
reorder_module p=before status=reorder_status m=IIM$STORE_TERMINAL
reorder_module p=before status=reorder_status m=IIM$STORE_CONTEXT
reorder_module p=before status=reorder_status m=IIM$SET_DEFAULT_ATTRIBUTES
reorder_module p=before status=reorder_status m=IIM$SEND_OUTPUT_MESSAGE
reorder_module p=before status=reorder_status m=IIM$SEND_ATTRIBUTES_CHANGE
reorder_module p=before status=reorder_status m=IIM$RESTORE_TERM_CONN_ATRIBUTES
reorder_module p=before status=reorder_status m=IIM$REQUEST_DEFAULT_ATTRIBUTES
reorder_module p=before status=reorder_status m=IIM$REPORT_UNHANDLED_SUPER_MSG
reorder_module p=before status=reorder_status m=IIM$REPORT_UNHANDLED_DATA_MSG
reorder_module p=before status=reorder_status m=IIM$REPORT_LOGICAL_ERROR
reorder_module p=before status=reorder_status m=IIM$QUEUE_MANAGEMENT_UTILITIES
reorder_module p=before status=reorder_status m=IIM$PUT
reorder_module p=before status=reorder_status m=IIM$OPEN
reorder_module p=before status=reorder_status m=IIM$MEMORY_LINK_ACCESS
reorder_module p=before status=reorder_status m=IIM$JOB_PAGEABLE_VARIABLES
reorder_module p=before status=reorder_status m=IIM$INTERRUPT_TIMESHARING_IO
reorder_module p=before status=reorder_status m=IIM$INIT_OPEN_DESC_ATTRIBUTES
reorder_module p=before status=reorder_status m=IIM$INITIALIZE_CONNECTION
reorder_module p=before status=reorder_status m=IIM$GET_TERM_CONN_DEFAULTS
reorder_module p=before status=reorder_status m=IIM$GET_TERM_CONN_ATTRIBUTES
reorder_module p=before status=reorder_status m=IIM$GET_TERMINAL_ATTRIBUTES
reorder_module p=before status=reorder_status m=IIM$FLUSH
reorder_module p=before status=reorder_status m=IIM$FETCH_TERMINAL
reorder_module p=before status=reorder_status m=IIM$FETCH_ACCESS_INFORMATION
reorder_module p=before status=reorder_status m=IIM$DPC64_TO_STRING
reorder_module p=before status=reorder_status m=IIM$CLOSE
reorder_module p=before status=reorder_status m=IIM$CHANGE_TERM_CONN_DEFAULTS
reorder_module p=before status=reorder_status m=IIM$CHANGE_TERM_CONN_ATTRIBUTES
reorder_module p=before status=reorder_status m=IIM$CHANGE_TERMINAL_CLASS
reorder_module p=before status=reorder_status m=IIM$CHANGE_TERMINAL_ATTRIBUTES
reorder_module p=before status=reorder_status m=IIM$BUILD_TERM_CHAR_VALUES
reorder_module p=before status=reorder_status m=IIM$BREAK_HANDLER
reorder_module p=before status=reorder_status m=IIM$BLOCK_MANAGEMENT_UTILITIES
reorder_module p=before status=reorder_status m=IIM$ASCII_170_TO_HEX
reorder_module p=before status=reorder_status m=IFM$JOB_CONTROL
reorder_module p=before status=reorder_status m=IFM$HANDLE_SIGNAL
reorder_module p=before status=reorder_status m=FMM$VERIFY_ATTRIBUTE_LIMITS
reorder_module p=before status=reorder_status m=FMM$TAPE_RESOURCE_MGMT
reorder_module p=before status=reorder_status m=FMM$TABLES
reorder_module p=before status=reorder_status m=FMM$STORE_FETCH_TAPE_LABEL_ATTR
reorder_module p=before status=reorder_status m=FMM$STORE_FETCH_TAPE_ATTACHMENT
reorder_module p=before status=reorder_status m=FMM$SL_REWIND_FILE_COMMAND
reorder_module p=before status=reorder_status m=FMM$PF_UTILITY_LABEL
reorder_module p=before status=reorder_status m=FMM$OBTAIN_ELEMENT_NAME
reorder_module p=before status=reorder_status m=FMM$JOB_RECOVERY
reorder_module p=before status=reorder_status m=DMM$RECOVER_VOLUME
reorder_module p=before status=reorder_status m=DMM$RECOVER_MAINFRAME
reorder_module p=before status=reorder_status m=DMM$RECOVER_FILE
reorder_module p=before status=reorder_status m=DMM$GET_SERVER_FMD
reorder_module p=before status=reorder_status m=DMM$DISPLAY_MASS_STORAGE
reorder_module p=before status=reorder_status m=DFM$WAIT_FOR_UNAVAILABLE_SERVER
reorder_module p=before status=reorder_status m=DFM$SET_SERVER_EOI
reorder_module p=before status=reorder_status m=CMM$VED_DISPLAY_CONF
reorder_module p=before status=reorder_status m=CMM$VED_DISPLAY
reorder_module p=before status=reorder_status m=BAM$TAPE_BLOCK_MANAGER_RING2
reorder_module p=before status=reorder_status m=FMM$GET_LAST_ANSI_FILE_ACCESS
reorder_module p=before status=reorder_status m=FMM$GET_NEXT_ANSI_FILE_POSITION
reorder_module p=before status=reorder_status m=FMM$GET_TAPE_LABEL_CMD_ATTRIB
reorder_module p=before status=reorder_status m=NLM$SK_SERVICE_ROUTINES_R2
reorder_module p=before status=reorder_status m=JMM$INITIALIZE_JOB_ENVIRONMENT
reorder_module p=before status=reorder_status m=IIM$SET_TERMINAL_NAME
reorder_module p=before status=reorder_status m=STM$SET_END_JOB
reorder_module p=before status=reorder_status m=RHM$LINK_USER_DESCRIPTOR_SAVED
reorder_module p=before status=reorder_status m=IIM$ST_GET_INPUT_OUTPUT_COUNTS
reorder_module p=before status=reorder_status m=IIM$ST_CLR_INPUT_OUTPUT_COUNTS
reorder_module p=before status=reorder_status m=DMM$CREATE_TAPE_FILE
reorder_module p=before status=reorder_status m=DFM$JOB_SERVER_MANAGER
reorder_module p=before status=reorder_status m=TMM$DISPOSE_OF_RING2_PREEMPTS
reorder_module p=before status=reorder_status m=DMM$RECONCILE_FMD
reorder_module p=before status=reorder_status m=JMM$SYSTEM_LABEL_ACCESS
reorder_module p=before status=reorder_status m=IOM$SUBSYSTEM_IO_R223
reorder_module p=before status=reorder_status m=IIM$SUPPRESS_CURSOR_POS_ECHOPLX
reorder_module p=before status=reorder_status m=JMM$SET_JOB_ATTRIBUTES
reorder_module p=before status=reorder_status m=STM$MODIFY_JOB_SET_TABLE
reorder_module p=before status=reorder_status m=JMM$SAVE_RECOVERY_INFORMATION
reorder_module p=before status=reorder_status m=IIM$ST_INITIALIZE_CONNECTION
reorder_module p=before status=reorder_status m=IIM$DIRECT_STORE_TRM_CONN_ATTS
reorder_module p=before status=reorder_status m=PFM$CATALOG_MAINTENANCE_MANAGER
reorder_module p=before status=reorder_status m=IIM$ST_GET_TERMINAL_ATTRIBUTES
reorder_module p=before status=reorder_status m=AVM$STORE_VALIDATION_INFO
reorder_module p=before status=reorder_status m=AVM$CALCULATE_SRUS
reorder_module p=before status=reorder_status m=IIM$CLEAR_JOB_LOCKS
reorder_module p=before status=reorder_status m=AVM$JOB_ACCOUNTING_KERNEL
reorder_module p=before status=reorder_status m=SFM$JOB_ROUTING_CONTROL_MANAGER
reorder_module p=before status=reorder_status m=IIM$FETCH_TERM_CONN_ATTRIBUTES
reorder_module p=before status=reorder_status m=IIM$DIRECT_FETCH_TRM_CONN_ATTS
reorder_module p=before status=reorder_status m=STM$READ_JOB_SET_TABLE
reorder_module p=before status=reorder_status m=IIM$VTT_IFT_CONVERSION_ROUTINES
reorder_module p=before status=reorder_status m=STM$PF_INTERFACES
reorder_module p=before status=reorder_status m=FMM$EXPAND_FILE_LABEL
reorder_module p=before status=reorder_status m=LOM$LINKAGE_GENERATION
reorder_module p=before status=reorder_status m=IIM$ST_OPEN
reorder_module p=before status=reorder_status m=IIM$ST_INIT_OPEN_DESC_ATRIBUTES
reorder_module p=before status=reorder_status m=FMM$GET_TERMINAL_ATTRIBUTES
reorder_module p=before status=reorder_status m=FMM$GET_OPEN_INFORMATION
reorder_module p=before status=reorder_status m=IIM$ST_CLOSE
reorder_module p=before status=reorder_status m=IIM$STORE_TERM_CONN_ATTRIBUTES
reorder_module p=before status=reorder_status m=FMM$SETFA_PROCESSING
reorder_module p=before status=reorder_status m=TMM$ALLOCATE_EXECUTION_RINGS
reorder_module p=before status=reorder_status m=NAM$FILE_CYCLE_MANAGER
reorder_module p=before status=reorder_status m=IIM$GET_PAGE_LENGTH_WIDTH
reorder_module p=before status=reorder_status m=PMM$MANAGE_CONDITION_STACKS_R2
reorder_module p=before status=reorder_status m=TMM$MANAGE_SIGNALS_AND_FLAGS
reorder_module p=before status=reorder_status m=IIM$ALLOCATE_OR_FREE_SPACE
reorder_module p=before status=reorder_status m=PMM$TASKING_SUPPORT_RING_2
reorder_module p=before status=reorder_status m=PFM$R2_GET_INFO
reorder_module p=before status=reorder_status m=SFM$JOB_LIMITS_MANAGER
reorder_module p=before status=reorder_status m=IIM$FETCH_CONTEXT
reorder_module p=before status=reorder_status m=IIM$XLATE_LOCAL_FILE_TO_SESSION
reorder_module p=before status=reorder_status m=FMM$FILE_LABEL_FUNCTIONS
reorder_module p=before status=reorder_status m=NAM$GT_APPLICATION_LAYER_R2
reorder_module p=before status=reorder_status m=PFM$OBJECT_LIST_MANAGER
reorder_module p=before status=reorder_status m=FMM$FILE_ATTRIBUTE_MANAGER
reorder_module p=before status=reorder_status m=PFM$ATTACHED_PF_TABLE
reorder_module p=before status=reorder_status m=LGM$LOCAL_LOG_MANAGER
reorder_module p=before status=reorder_status m=IIM$ST_FLUSH
reorder_module p=before status=reorder_status m=PFM$R2_GET_OBJECT_INFORMATION
reorder_module p=before status=reorder_status m=IIM$GET
reorder_module p=before status=reorder_status m=JMM$JOB_SCHEDULER_RING_2
reorder_module p=before status=reorder_status m=FMM$EVALUATE_PATH
reorder_module p=before status=reorder_status m=FMM$CYCLE_MANAGER
reorder_module p=before status=reorder_status m=IIM$ST_GET
reorder_module p=before status=reorder_status m=PFM$POINTER_CONVERSION_ROUTINES
reorder_module p=before status=reorder_status m=IIM$ST_PUT
reorder_module p=before status=reorder_status m=IIM$VTP_INTERFACE
reorder_module p=before status=reorder_status m=PFM$R2_REQUEST_PROCESSOR
reorder_module p=before status=reorder_status m=PFM$CATALOG_ACCESS_METHODS
reorder_module p=before status=reorder_status m=IIM$ST_SEND_OUTPUT_MESSAGE
reorder_module p=before status=reorder_status m=PFM$FILE_SYSTEM_INTERFACES
reorder_module p=before status=reorder_status m=IIM$SEARCH_CONNECTION_DESC
reorder_module p=before status=reorder_status m=FMM$PATH_TABLE_MANAGER
*DECK DECK=RAI$REORDER_JOB_TEMPLATE_236 EXPAND=TRUE
IF $variable(reorder_status, declared) <> 'LOCAL' THEN
  create_variable reorder_status k=status
IFEND
reorder_module p=before status=reorder_status m=NAM$MISCELLANEOUS_236
reorder_module p=before status=reorder_status m=NAM$EXTERNAL_CN_INTERFACE
reorder_module p=before status=reorder_status m=PMM$TASKING_SUPPORT_RING_6
reorder_module p=before status=reorder_status m=PMM$MULTI_TASK_CONDITIONS
reorder_module p=before status=reorder_status m=PMM$INHIBIT_TASK_TERMINATION
reorder_module p=before status=reorder_status m=OSM$UNIVERSAL_TASK_SUPPORT
reorder_module p=before status=reorder_status m=OSM$FLUSH_ALLOCATION_INFO
reorder_module p=before status=reorder_status m=NSM$OS_INTERFACES
reorder_module p=before status=reorder_status m=MMM$PREALLOCATE_FILE_SPACE
reorder_module p=before status=reorder_status m=JMM$GET_ENCRYPTED_PASSWORD
reorder_module p=before status=reorder_status m=IOM$SUBSYSTEM_IO_R236
reorder_module p=before status=reorder_status m=DXM$STORE_ONE_WORD_RESPONSE_PTR
reorder_module p=before status=reorder_status m=NLM$SK_SERVICE_ROUTINES_R3
reorder_module p=before status=reorder_status m=PMM$BROADCAST_UNSEEN_MAIL
reorder_module p=before status=reorder_status m=NLM$UDP_ACCESS_AGENT
reorder_module p=before status=reorder_status m=JMM$QUEUE_FILE_LEVELER_MANAGER
reorder_module p=before status=reorder_status m=CMM$MANAGE_ELEMENT_RESERVATION
reorder_module p=before status=reorder_status m=NAM$EXTERNAL_GT_INTERFACE
reorder_module p=before status=reorder_status m=NLM$TRANSPORT_ACCESS_AGENT
*DECK DECK=RAI$REORDER_JOB_TEMPLATE_23D EXPAND=TRUE
IF $variable(reorder_status, declared) <> 'LOCAL' THEN
  create_variable reorder_status k=status
IFEND
reorder_module p=before status=reorder_status m=LOM$ACTUAL_FORMAL_PARM_MATCHING
reorder_module p=before status=reorder_status m=BAM$VALIDATE_COMPATIBILITY
reorder_module p=before status=reorder_status m=BAM$US_BLK_VAR_READ_ONLY_FAP
reorder_module p=before status=reorder_status m=DMM$DISPLAY_DEVICE_FILES_R3
reorder_module p=before status=reorder_status m=DFM$LOG_ESM_DATA
reorder_module p=before status=reorder_status m=CMM$ACCESS_DEVICE_FILES
reorder_module p=before status=reorder_status m=DFM$DRIVER_TEST_UTILITY
reorder_module p=before status=reorder_status m=SYM$JOB_RECOVERY_R3
reorder_module p=before status=reorder_status m=RFM$NETWORK_DISPLAYS
reorder_module p=before status=reorder_status m=OSM$KEYPOINT_SUPPORT
reorder_module p=before status=reorder_status m=JMM$JOB_RECOVERY
reorder_module p=before status=reorder_status m=OFM$CONSOLE_DISPLAYS
reorder_module p=before status=reorder_status m=OSM$IDLE_RESUME_SYSTEM
reorder_module p=before status=reorder_status m=AVM$DUAL_STATE_PROMPT
reorder_module p=before status=reorder_status m=AVM$ACCOUNTING_INTERFACES
reorder_module p=before status=reorder_status m=DSM$LOG_SYSTEM_MESSAGES
reorder_module p=before status=reorder_status m=STM$USER_DISPLAY_INTERFACE
reorder_module p=before status=reorder_status m=STM$TRANSLATE_SET_NAMES
reorder_module p=before status=reorder_status m=STM$REMOVE_MEMBER
reorder_module p=before status=reorder_status m=STM$PURGE_SET
reorder_module p=before status=reorder_status m=STM$MISC_SERVICE_ROUTINES
reorder_module p=before status=reorder_status m=STM$CREATE_SET
reorder_module p=before status=reorder_status m=STM$CHANGE_ACCESS_TO_SET
reorder_module p=before status=reorder_status m=STM$ADD_MEMBER
reorder_module p=before status=reorder_status m=STM$ACTIVATE_SET
reorder_module p=before status=reorder_status m=SRM$FETCH_STORE_LABEL
reorder_module p=before status=reorder_status m=RMM$VALIDATE_TAPE_OPERATIONS
reorder_module p=before status=reorder_status m=RMM$COMPLETE_TAPE_OPERATIONS
reorder_module p=before status=reorder_status m=RHM$SET_STATUS_ABNORMAL
reorder_module p=before status=reorder_status m=RHM$PERMANENT_FILE_MEMORY_LINK
reorder_module p=before status=reorder_status m=RHM$GET_DISPLAY_LINK_ATTR_VALUE
reorder_module p=before status=reorder_status m=RHM$CHANGE_DUAL_STATE_ENVIRON
reorder_module p=before status=reorder_status m=RFM$SYSTEM_TASK
reorder_module p=before status=reorder_status m=RFM$PROCESS_PP_RESPONSE_FLAG
reorder_module p=before status=reorder_status m=RFM$NETWORK_FAP
reorder_module p=before status=reorder_status m=RFM$CONFIG_UTL_HELPER
reorder_module p=before status=reorder_status m=RFM$CHANGE_STATE_COMMANDS_R3
reorder_module p=before status=reorder_status m=RFM$APPLICATION_MANAGEMENT
reorder_module p=before status=reorder_status m=RAM$RETAIN_VERSION_ROUTINES
reorder_module p=before status=reorder_status m=RAM$LOAD_OPTIONS_ROUTINES
reorder_module p=before status=reorder_status m=PUM$MANAGE_BACKUP_LABEL_TYPE
reorder_module p=before status=reorder_status m=PMM$SET_SPY_IDENTIFIER
reorder_module p=before status=reorder_status m=PMM$PROCESS_INTERVAL_TIMER_MGR
reorder_module p=before status=reorder_status m=OSM$SIMULATE_DISK_FAULT
reorder_module p=before status=reorder_status m=OSM$RECOVERABLE_SYSTEM_ERROR
reorder_module p=before status=reorder_status m=OSM$JOB_TEMPLATE_MANAGEMENT
reorder_module p=before status=reorder_status m=OSM$JOB_RECOVERY_LOGGING
reorder_module p=before status=reorder_status m=OSM$CHARACTER_TRANSLATION_MGR
reorder_module p=before status=reorder_status m=OSM$CHANGE_OS_DEFAULTS_R3
reorder_module p=before status=reorder_status m=OSM$BROKEN_JOB_DUMP_TASK
reorder_module p=before status=reorder_status m=OFM$TASK_PRIVATE_DATA
reorder_module p=before status=reorder_status m=OFM$SYSTEM_OPERATOR_UTILITY_R3
reorder_module p=before status=reorder_status m=OFM$REPORT_STATUS_ERROR
reorder_module p=before status=reorder_status m=OFM$OPERATOR_ACTION_MENU
reorder_module p=before status=reorder_status m=OFM$GENERAL_STATISTICS_DISPLAY
reorder_module p=before status=reorder_status m=NLM$SYSTEM_MGMT_ACCESS_AGENT
reorder_module p=before status=reorder_status m=NFM$REMOTE_VALIDATION
reorder_module p=before status=reorder_status m=NAM$NETWORK_PROCEDURES
reorder_module p=before status=reorder_status m=NAM$NETWORK_CONFIGURATION
reorder_module p=before status=reorder_status m=NAM$MISCELLANEOUS
reorder_module p=before status=reorder_status m=NAM$MANAGE_NAM_ATTRIBUTES_R3
reorder_module p=before status=reorder_status m=NAM$INITIALIZE_NETWORKS_R3
reorder_module p=before status=reorder_status m=NAM$DEBUG_NETWORK_PP
reorder_module p=before status=reorder_status m=MSM$REQUEST_MAINTENANCE_ACCESS
reorder_module p=before status=reorder_status m=MMM$READ_WRITE_IO_RING_3
reorder_module p=before status=reorder_status m=MMM$MANAGE_MEMORY_HELPER_R3
reorder_module p=before status=reorder_status m=MLM$R3_INTERFACES
reorder_module p=before status=reorder_status m=MLM$INVOKE_MLI_HELPER
reorder_module p=before status=reorder_status m=LOM$CROSS_REFERENCE_MANAGEMENT
reorder_module p=before status=reorder_status m=LOM$ANALYZE_PROGRAM_DYNAMICS
reorder_module p=before status=reorder_status m=JMM$NAME_MANAGER
reorder_module p=before status=reorder_status m=JMM$LOAD_JOB_TEMPLATES_RING_3
reorder_module p=before status=reorder_status m=JMM$JOB_MGMT_MISC_SERVICES
reorder_module p=before status=reorder_status m=JMM$JOB_HISTORY_LOG_INTERFACES
reorder_module p=before status=reorder_status m=JMM$INITIAL_ENTRY_POINTS
reorder_module p=before status=reorder_status m=IOM$TAPE_SCANNER
reorder_module p=before status=reorder_status m=IOM$TAPE_COMMAND_PROCEDURES
reorder_module p=before status=reorder_status m=IOM$SWEEP_DISK_UNITS
reorder_module p=before status=reorder_status m=IOM$LOG_TAPE_DATA
reorder_module p=before status=reorder_status m=IIM$TASK_PRIVATE_VARIABLES
reorder_module p=before status=reorder_status m=IIM$ROUTE
reorder_module p=before status=reorder_status m=IFM$STORE_CONTEXT
reorder_module p=before status=reorder_status m=IFM$SEND_INTERRUPT_CONDITION
reorder_module p=before status=reorder_status m=IFM$SEND_ATTRIBUTE_KLUDGE
reorder_module p=before status=reorder_status m=IFM$PURGE_CONNECTION_IO
reorder_module p=before status=reorder_status m=IFM$IMMEDIATE_ATTRIBUTE_FLUSH
reorder_module p=before status=reorder_status m=IFM$GET_TERM_CONN_DEFAULTS
reorder_module p=before status=reorder_status m=IFM$GET_TERM_CONN_ATTRIBUTES
reorder_module p=before status=reorder_status m=IFM$FAP_CONTROL
reorder_module p=before status=reorder_status m=IFM$DISCONNECT_RECONNECT
reorder_module p=before status=reorder_status m=IFM$CHANGE_TERM_CONN_DEFAULTS
reorder_module p=before status=reorder_status m=IFM$CHANGE_TERM_CONN_ATTRIBUTES
reorder_module p=before status=reorder_status m=IFM$CHANGE_TERMINAL_ATTRIBUTES
reorder_module p=before status=reorder_status m=IFM$BEGIN_END_HANDLER
reorder_module p=before status=reorder_status m=ICM$WRITE_END_PARTITION
reorder_module p=before status=reorder_status m=ICM$TASK_PRIVATE_VARIABLES
reorder_module p=before status=reorder_status m=ICM$SET_STATUS_ABNORMAL
reorder_module p=before status=reorder_status m=ICM$REPORT_STATUS_ERROR
reorder_module p=before status=reorder_status m=ICM$PUT
reorder_module p=before status=reorder_status m=ICM$PARTNER_JOB_MLI_ACCESS
reorder_module p=before status=reorder_status m=ICM$PARTNER_JOB_EXEC_VIRTUAL
reorder_module p=before status=reorder_status m=ICM$OPEN
reorder_module p=before status=reorder_status m=ICM$JOB_INITIALIAZE
reorder_module p=before status=reorder_status m=ICM$GET
reorder_module p=before status=reorder_status m=ICM$FLUSH
reorder_module p=before status=reorder_status m=ICM$FETCH_ACCESS_INFO
reorder_module p=before status=reorder_status m=ICM$FAP_CONTROL
reorder_module p=before status=reorder_status m=ICM$CLOSE
reorder_module p=before status=reorder_status m=FMM$GET_INFO
reorder_module p=before status=reorder_status m=DSM$PROCESS_DEADSTART_FILES
reorder_module p=before status=reorder_status m=DSM$INSTALL_DEADSTART_FILE
reorder_module p=before status=reorder_status m=DMM$TAPE_DISPLAYS_23D
reorder_module p=before status=reorder_status m=DMM$RUN_ASYNCHRONOUS_TASKS
reorder_module p=before status=reorder_status m=DMM$DISPLAY_MASS_STORE_COMMAND
reorder_module p=before status=reorder_status m=DMM$DISPLAY_FILE_TABLES
reorder_module p=before status=reorder_status m=DMM$DEVICE_FLAW_MANAGEMENT
reorder_module p=before status=reorder_status m=DFM$VERIFY_CLIENT_JOBS
reorder_module p=before status=reorder_status m=DFM$TRIAL_COMMANDS
reorder_module p=before status=reorder_status m=DFM$TRANSFER_MMIO_DATA
reorder_module p=before status=reorder_status m=DFM$TIMEOUT_REQUESTS_TO_SERVER
reorder_module p=before status=reorder_status m=DFM$TEST_REMOTE_PROCEDURE_CALL
reorder_module p=before status=reorder_status m=DFM$TERM_REQUESTS_TO_SERVER
reorder_module p=before status=reorder_status m=DFM$TERM_PROCESSING_ON_SERVER
reorder_module p=before status=reorder_status m=DFM$RPC_SEGMENT_TRANSPORT
reorder_module p=before status=reorder_status m=DFM$RETURN_FAMILY_STATE
reorder_module p=before status=reorder_status m=DFM$RESET_MAINFRAME_TABLES
reorder_module p=before status=reorder_status m=DFM$RECOVER_REQUESTS_TO_SERVER
reorder_module p=before status=reorder_status m=DFM$QUEUE_INITIALIZATION
reorder_module p=before status=reorder_status m=DFM$QUEUE_ENTRY_CONTROL
reorder_module p=before status=reorder_status m=DFM$PRESERVED_FAMILY_MANAGER
reorder_module p=before status=reorder_status m=DFM$PP_MANAGEMENT_COMMANDS
reorder_module p=before status=reorder_status m=DFM$OPERATOR_DISPLAYS
reorder_module p=before status=reorder_status m=DFM$MOCK_DRIVER
reorder_module p=before status=reorder_status m=DFM$MANAGE_SERVER_CONNECTION
reorder_module p=before status=reorder_status m=DFM$MANAGE_CLIENT_CONNECTION
reorder_module p=before status=reorder_status m=DFM$IDLE_REQUESTS_TO_SERVER
reorder_module p=before status=reorder_status m=DFM$FILE_SERVER_PP_MGNT
reorder_module p=before status=reorder_status m=DFM$FAMILY_CLIENT_MANAGER
reorder_module p=before status=reorder_status m=DFM$ESM_DEFINITION_MANAGER
reorder_module p=before status=reorder_status m=DFM$DELETE_TABLES_OF_PARTNER
reorder_module p=before status=reorder_status m=DFM$CRACK_VALUES
reorder_module p=before status=reorder_status m=DFM$COMPUTE_CHECKSUM
reorder_module p=before status=reorder_status m=DFM$COMMON_ROUTINES
reorder_module p=before status=reorder_status m=DFM$CLONE_TASK_PROCESS
reorder_module p=before status=reorder_status m=DFM$CLIENT_MAINFRAME_MANAGER
reorder_module p=before status=reorder_status m=DFM$CLIENT_JOB_MANAGER
reorder_module p=before status=reorder_status m=CMM$LCU_FUNCTIONS
reorder_module p=before status=reorder_status m=CMM$JOB_TEMPLATE_DEADSTART
reorder_module p=before status=reorder_status m=CLM$SCL_OPTIONS_MANAGER
reorder_module p=before status=reorder_status m=CLM$NAMED_TASK_MANAGER
reorder_module p=before status=reorder_status m=CLM$LOG_COMMENT
reorder_module p=before status=reorder_status m=CLM$LOCAL_QUEUE_TABLE_MANAGER
reorder_module p=before status=reorder_status m=CLM$JOB_HISTORY_OPERATOR_CMDS
reorder_module p=before status=reorder_status m=CLM$ENVIRONMENT_OBJECT_MANAGER
reorder_module p=before status=reorder_status m=CLM$DAY_AND_MONTH_NAMES_MGR
reorder_module p=before status=reorder_status m=BAM$US_BLK_VARIABLE_REC_FAP
reorder_module p=before status=reorder_status m=BAM$TAPE_BLOCK_MANAGER_RING3
reorder_module p=before status=reorder_status m=BAM$TABLES
reorder_module p=before status=reorder_status m=BAM$STORE_FETCH_TAPE_LABEL_ATTR
reorder_module p=before status=reorder_status m=BAM$SL_REWIND_FILE_COMMAND
reorder_module p=before status=reorder_status m=BAM$REWIND
reorder_module p=before status=reorder_status m=BAM$PAD_RECORD
reorder_module p=before status=reorder_status m=BAM$LRT_US_UNDEF_TAPE_FAP
reorder_module p=before status=reorder_status m=BAM$LRT_US_FIXED_TAPE_FAP
reorder_module p=before status=reorder_status m=BAM$LRT_US_ANSI_S_TAPE_FAP
reorder_module p=before status=reorder_status m=BAM$LRT_US_ANSI_D_TAPE_FAP
reorder_module p=before status=reorder_status m=BAM$LRT_SS_VAR_TAPE_FAP
reorder_module p=before status=reorder_status m=BAM$LRT_SS_UNDEF_TAPE_FAP
reorder_module p=before status=reorder_status m=BAM$FORMAT_SEGMENT_CONDITION
reorder_module p=before status=reorder_status m=BAM$EXIT_FAP_ON_CONDITION
reorder_module p=before status=reorder_status m=BAM$EVALUATE_PATH
reorder_module p=before status=reorder_status m=BAM$DISPLAY_TABLES
reorder_module p=before status=reorder_status m=BAM$CHANGE_TAPE_BT_AND_RT
reorder_module p=before status=reorder_status m=BAM$2DD_STATIC_VARIABLE_HELPER
reorder_module p=before status=reorder_status m=AVM$PROCESS_PASSWORD_ATTRIBUTES
reorder_module p=before status=reorder_status m=AVM$INITIALIZE
reorder_module p=before status=reorder_status m=AVM$FAMILY_INTERFACES
reorder_module p=before status=reorder_status m=AVM$ENCRYPT
reorder_module p=before status=reorder_status m=AVM$SECURITY_INTERFACES
reorder_module p=before status=reorder_status m=AVM$VERIFY_VALIDATION_NAME
reorder_module p=before status=reorder_status m=BAM$GET_TAPE_LABEL_ATTRIBUTES
reorder_module p=before status=reorder_status m=BAM$SYSTEM_TAPE_LABEL_FAP
reorder_module p=before status=reorder_status m=CMM$PHYS_CONFIGURATION_UTL_23D
reorder_module p=before status=reorder_status m=DFM$APPLICATION_MANAGER_HELPERS
reorder_module p=before status=reorder_status m=DFM$CALL_REMOTE_PROCEDURE
reorder_module p=before status=reorder_status m=DFM$LOG_SDP_DATA
reorder_module p=before status=reorder_status m=DFM$LOG_SIDE_DOOR_PORT_STATUS
reorder_module p=before status=reorder_status m=DFM$MANAGE_APPLICATION_INFO
reorder_module p=before status=reorder_status m=DFM$MANAGE_IMAGE
reorder_module p=before status=reorder_status m=DFM$RECOVERY_CONTROL
reorder_module p=before status=reorder_status m=DFM$REQUEST_REMOTE_APP_INFO
reorder_module p=before status=reorder_status m=DFM$RPC_CLIENT_SEGMENT_TRANSPRT
reorder_module p=before status=reorder_status m=DFM$TEST_APP_SUP_R3
reorder_module p=before status=reorder_status m=DMM$INITIALIZE_TAPE_R3
reorder_module p=before status=reorder_status m=DUM$MOVE_BYTES
reorder_module p=before status=reorder_status m=JMM$JOB_MESSAGE_MANAGEMENT
reorder_module p=before status=reorder_status m=JMM$JOB_TO_JOB_COMMUNICATION
reorder_module p=before status=reorder_status m=JMM$OFFLINE_OUTPUT_SUPPORT
reorder_module p=before status=reorder_status m=LGM$INTERNAL_LOGGING_INTERFACES
reorder_module p=before status=reorder_status m=NLM$SK_TCP_SOCKET_LAYER
reorder_module p=before status=reorder_status m=NLM$TCPIP_MGMT_ACCESS_AGENT
reorder_module p=before status=reorder_status m=NLM$TCP_ACCESS_AGENT
reorder_module p=before status=reorder_status m=NLM$UDP_GLOBAL_SOCKET_MANAGER
reorder_module p=before status=reorder_status m=RMM$MEDIA_INTERFACES_23D
reorder_module p=before status=reorder_status m=RMM$VALIDATE_ANSI_LABELS
reorder_module p=before status=reorder_status m=NLM$SK_AWAIT_SOCKET_EVENTS
reorder_module p=before status=reorder_status m=NAM$INTRANET_LAYER_MGMT_R3
reorder_module p=before status=reorder_status m=OSM$MULTIPRO_INTERFACE_R3
reorder_module p=before status=reorder_status m=CMM$MISCELLANEOUS_INTERFACES
reorder_module p=before status=reorder_status m=CLM$UNSEEN_MAIL_ACTION_HANDLER
reorder_module p=before status=reorder_status m=JMM$JOB_SCHEDULER_RING_3
reorder_module p=before status=reorder_status m=BAM$MERGE_ATTRIBUTES
reorder_module p=before status=reorder_status m=OSM$SPI_SUPPORT
reorder_module p=before status=reorder_status m=RMM$REQUEST_NULL_DEVICE
reorder_module p=before status=reorder_status m=CLM$REQUEST_LOG_DEVICE
reorder_module p=before status=reorder_status m=AMM$STORE_FAP_POINTER
reorder_module p=before status=reorder_status m=BAM$R3_COMMAND_PROCESSOR
reorder_module p=before status=reorder_status m=RHM$GET_LINK_USER_DESCRIPTOR
reorder_module p=before status=reorder_status m=BAM$DELETE_DATA
reorder_module p=before status=reorder_status m=BAM$US_BLK_UNDEFINED_REC_FAP
reorder_module p=before status=reorder_status m=BAM$US_BLK_FIXED_REC_FAP
reorder_module p=before status=reorder_status m=BAM$SYS_BLK_FIXED_REC_FAP
reorder_module p=before status=reorder_status m=IOM$LOG_DISK_DATA
reorder_module p=before status=reorder_status m=NLM$LINK_ACCESS_AGENT
reorder_module p=before status=reorder_status m=DFM$SERVER_REMOTE_PROCEDUR_CALL
reorder_module p=before status=reorder_status m=NLM$AL_APPLICATION_DATA_SERVICE
reorder_module p=before status=reorder_status m=CLM$WHEN_CONDITION_MANAGER
reorder_module p=before status=reorder_status m=LOM$LIBRARY_ENTITY_LOCATOR
reorder_module p=before status=reorder_status m=NAM$NETWORK_EXTERNAL_INTERFACE
reorder_module p=before status=reorder_status m=BAM$V_TO_T_RECORD_CONVERSION
reorder_module p=before status=reorder_status m=DFM$CDCNET_DRIVER
reorder_module p=before status=reorder_status m=RHM$SAVE_LINK_USER_DESCRIPTION
reorder_module p=before status=reorder_status m=AVM$ENCRYPT_PASSWORD
reorder_module p=before status=reorder_status m=NLM$NETWORK_ACCESS_AGENT
reorder_module p=before status=reorder_status m=NAM$SK_SOCKET_LAYER
reorder_module p=before status=reorder_status m=NLM$TIMER_MONITOR
reorder_module p=before status=reorder_status m=BAM$CREATE_FILE
reorder_module p=before status=reorder_status m=BAM$BYTE_MOVE
reorder_module p=before status=reorder_status m=CLM$SYSTEM_PROLOG_COMMAND
reorder_module p=before status=reorder_status m=RMM$REQUEST_TERMINAL
reorder_module p=before status=reorder_status m=LOM$LOAD_MAP_GENERATION
reorder_module p=before status=reorder_status m=BAM$SYS_BLK_UNDEFINED_REC_FAP
reorder_module p=before status=reorder_status m=OSM$SET_MESSAGE_LEVEL
reorder_module p=before status=reorder_status m=OSM$JOB_TEMPLATE_INITIALIZATION
reorder_module p=before status=reorder_status m=IFM$SUPPRESS_CURSOR_POS_ECHOPLX
reorder_module p=before status=reorder_status m=RMM$VALIDATE_MASS_STORAGE_INFO
reorder_module p=before status=reorder_status m=TMM$MANAGE_MONITOR_FAULTS
reorder_module p=before status=reorder_status m=OSM$SYSTEM_TASK_MAINT_23D
reorder_module p=before status=reorder_status m=DFM$R3_MANAGE_FILE_SERVER
reorder_module p=before status=reorder_status m=JMM$LOGGING_INTERFACES
reorder_module p=before status=reorder_status m=OSM$NATURAL_LANGUAGE_MANAGER
reorder_module p=before status=reorder_status m=NLM$DIRECTORY_MANAGEMENT_ENTITY
reorder_module p=before status=reorder_status m=OFM$SCREEN_MANAGER
reorder_module p=before status=reorder_status m=NFM$VERIFY_FAMILY
reorder_module p=before status=reorder_status m=BAM$TRAILING_CHAR_DELIMITED_FAP
reorder_module p=before status=reorder_status m=CLM$WORKING_CATALOG_MANAGER
reorder_module p=before status=reorder_status m=IFM$GET_TERMINAL_ATTRIBUTES
reorder_module p=before status=reorder_status m=PMM$CHILD_TASK_MANAGEMENT
reorder_module p=before status=reorder_status m=NAM$INCREMENT_FILE_ACCESS_STATS
reorder_module p=before status=reorder_status m=RFM$EXTERNAL_INTERFACE
reorder_module p=before status=reorder_status m=NAM$APPLICATION_MANAGEMENT
reorder_module p=before status=reorder_status m=DFM$CLIENT_REMOTE_PROCEDUR_CALL
reorder_module p=before status=reorder_status m=LGM$LOGGING_INTERFACES
reorder_module p=before status=reorder_status m=OSM$SPI_DATA_COLLECTOR_R3
reorder_module p=before status=reorder_status m=PMM$MANAGE_LOCAL_QUEUES
reorder_module p=before status=reorder_status m=JMM$JOB_SCHEDULER_UTILITY_R3
reorder_module p=before status=reorder_status m=JMM$QUEUE_FILE_OUTPUT_MANAGER
reorder_module p=before status=reorder_status m=AMM$VALIDATE_CALLER_PRIVILEGE
reorder_module p=before status=reorder_status m=JMM$TIMESHARING_SIGNAL_HANDLER
reorder_module p=before status=reorder_status m=BAM$LOG_DEVICE
reorder_module p=before status=reorder_status m=PMM$DEFAULT_LOADER_PARAM_MGMT
reorder_module p=before status=reorder_status m=CLM$SYSTEM_FILE_IDENTIFIERS
reorder_module p=before status=reorder_status m=BAM$TASK_CLEANUP
reorder_module p=before status=reorder_status m=NLM$CC_TIMER_MONITOR
reorder_module p=before status=reorder_status m=JMM$JOB_ATTRIBUTE_MANAGER
reorder_module p=before status=reorder_status m=CMM$CONFIG_STATUS_INTERFACES
reorder_module p=before status=reorder_status m=OSM$INTERACTION_STYLE_HANDLERS
reorder_module p=before status=reorder_status m=NAM$APPLICATION_EVENT_PROCESSOR
reorder_module p=before status=reorder_status m=LOM$LOAD_FILE_PREPARATION
reorder_module p=before status=reorder_status m=TMM$DISPOSE_PREEMPTIVE_COMMO
reorder_module p=before status=reorder_status m=BAM$RETURN
reorder_module p=before status=reorder_status m=PMM$END_HANDLER_PROCESSING
reorder_module p=before status=reorder_status m=BAM$MERGE_OPEN_ATTRIBUTES
reorder_module p=before status=reorder_status m=TMM$DISPOSE_OF_RING3_PREEMPTS
reorder_module p=before status=reorder_status m=CLM$COMMAND_UTILITY_HELPER
reorder_module p=before status=reorder_status m=SFM$LIMIT_INTERFACES
reorder_module p=before status=reorder_status m=LOM$PROGRAM_LOAD_LIEUTENANTS
reorder_module p=before status=reorder_status m=BAM$GET_OPEN_INFORMATION
reorder_module p=before status=reorder_status m=JMM$QUEUE_FILE_JOB_MANAGER
reorder_module p=before status=reorder_status m=JMM$JOB_MONITOR
reorder_module p=before status=reorder_status m=LOM$LOADER_EXECUTIVE
reorder_module p=before status=reorder_status m=BAM$GET_DEFAULT_ATTRIBUTES
reorder_module p=before status=reorder_status m=LOM$DYNAMIC_TABLE_MANAGEMENT
reorder_module p=before status=reorder_status m=IFM$GET_PAGE_LENGTH_WIDTH
reorder_module p=before status=reorder_status m=OSM$EMIT_OS_STATISTICS
reorder_module p=before status=reorder_status m=PMM$TASK_INITIATION
reorder_module p=before status=reorder_status m=OSM$FETCH_STATISTICAL_DATA
reorder_module p=before status=reorder_status m=PMM$MANAGE_CONDITION_STACKS
reorder_module p=before status=reorder_status m=OFM$JOB_MESSAGE_ROUTINES
reorder_module p=before status=reorder_status m=PMM$DEBUG_INTERFACE_MGMT
reorder_module p=before status=reorder_status m=BAM$GET_$LOCAL_OBJECT_INFO
reorder_module p=before status=reorder_status m=BAM$STORE_ART_TABLE_POINTER
reorder_module p=before status=reorder_status m=BAM$SEGMENT_POINTER
reorder_module p=before status=reorder_status m=PMM$INTERFACE_TO_LOGGING
reorder_module p=before status=reorder_status m=OFM$SYSTEM_HEADER_DISPLAY
reorder_module p=before status=reorder_status m=OFM$BUILD_SYSTEM_LINE
reorder_module p=before status=reorder_status m=OFM$ASYNC_TASK_INTERFACES
reorder_module p=before status=reorder_status m=SFM$EMIT_AUDIT_STATISTIC
reorder_module p=before status=reorder_status m=IFM$FETCH_CONTEXT
reorder_module p=before status=reorder_status m=BAM$GET_DEVICE_CLASS
reorder_module p=before status=reorder_status m=CLM$COMMAND_STATS_RING_3
reorder_module p=before status=reorder_status m=BAM$NULL_DEVICE
reorder_module p=before status=reorder_status m=PFM$TASK_PRIVATE_DATA
reorder_module p=before status=reorder_status m=NAM$FETCH_STATISTICAL_DATA
reorder_module p=before status=reorder_status m=PFM$REPORT_UNEXPECTED_STATUS
reorder_module p=before status=reorder_status m=CMM$CONFIGURE_IN_JOB_TEMPLATE
reorder_module p=before status=reorder_status m=BAM$FILE_STRUCTURE_FUNCTIONS
reorder_module p=before status=reorder_status m=PMM$TASK_TERMINATION_RING_3
reorder_module p=before status=reorder_status m=OSM$AWAIT_ACTIVITY
reorder_module p=before status=reorder_status m=LOM$PROGRAM_SEGMENT_MANAGEMENT
reorder_module p=before status=reorder_status m=PMM$DEBUG_STACK_MANAGERS_13F
reorder_module p=before status=reorder_status m=NLM$CHANNEL_CONNECTION_MANAGER
reorder_module p=before status=reorder_status m=NAM$INTERNAL_CONNECTION_MGMT
reorder_module p=before status=reorder_status m=BAM$CLOSE
reorder_module p=before status=reorder_status m=NAM$CHANNELNET_RING3
reorder_module p=before status=reorder_status m=PMM$TASKING_SUPPORT_RING_3
reorder_module p=before status=reorder_status m=DFM$SERVED_FAMILY_MANAGER
reorder_module p=before status=reorder_status m=LOM$LIBRARY_LIST_MANAGEMENT
reorder_module p=before status=reorder_status m=CLM$CONNECTED_FILES_MANAGER
reorder_module p=before status=reorder_status m=BAM$CONTROL
reorder_module p=before status=reorder_status m=BAM$CONNECTED_FILE_DEV_SUPPORT
reorder_module p=before status=reorder_status m=BAM$MARK_FAP_LAYER_STATUS
reorder_module p=before status=reorder_status m=AVM$VALIDATION_INTERFACES
reorder_module p=before status=reorder_status m=CLM$VARIABLE_STORAGE_MANAGER
reorder_module p=before status=reorder_status m=NLM$SL_INTERNAL_INTERFACE
reorder_module p=before status=reorder_status m=LOM$LOAD_LIBRARY_MODULES
reorder_module p=before status=reorder_status m=PFM$PROGRAM_INTERFACE_PROCESSOR
reorder_module p=before status=reorder_status m=LOM$MODULE_LOADER
reorder_module p=before status=reorder_status m=BAM$PATH_ACCESS_MANAGER
reorder_module p=before status=reorder_status m=OSM$I_AWAIT_ACTIVITY
reorder_module p=before status=reorder_status m=IFM$ST_FAP_CONTROL
reorder_module p=before status=reorder_status m=CLM$INPUT_STACK_MANAGER
reorder_module p=before status=reorder_status m=NLM$CHANNEL_CONNECTION_ENTITY
reorder_module p=before status=reorder_status m=CLM$COMMAND_LIST_MANAGER
reorder_module p=before status=reorder_status m=LOM$TASK_SERVICES_DEF_MATCHING
reorder_module p=before status=reorder_status m=CLM$BLOCK_STACK_MANAGER
reorder_module p=before status=reorder_status m=NLM$CC_NETWORK_EVENT_MANAGER
reorder_module p=before status=reorder_status m=BAM$SYS_BLK_VARIABLE_REC_FAP
reorder_module p=before status=reorder_status m=CLM$WORK_AREA_MANAGER
reorder_module p=before status=reorder_status m=SFM$STATISTIC_INTERFACES
reorder_module p=before status=reorder_status m=NLM$CL_CONNECTION_MANAGER_R3
reorder_module p=before status=reorder_status m=NLM$BUFFER_MANAGER
reorder_module p=before status=reorder_status m=NAM$SE_EXTERNAL_INTERFACE
reorder_module p=before status=reorder_status m=AVM$TEMPLATE_FILE_MANAGER
reorder_module p=before status=reorder_status m=BAM$OPEN_FILE
reorder_module p=before status=reorder_status m=TMM$WAIT
reorder_module p=before status=reorder_status m=MMM$SEGMENT_MANAGER_JOB_TEMP
reorder_module p=before status=reorder_status m=OFM$DESIGNER_SCREENS_R3
reorder_module p=before status=reorder_status m=PMM$DEBUG_TABLE_BUILDER
reorder_module p=before status=reorder_status m=LOM$LINKAGE_NAME_TREE_MGMT
reorder_module p=before status=reorder_status m=LOM$ENTRY_EXTERNAL_MATCHING
*DECK DECK=RAI$REORDER_JOB_TEMPLATE_2DD EXPAND=TRUE
IF $variable(reorder_status, declared) <> 'LOCAL' THEN
  create_variable reorder_status k=status
IFEND
reorder_module p=before status=reorder_status m=OSM$SET_STATUS_FROM_CONDITION
reorder_module p=before status=reorder_status m=MMM$READ_WRITE_IO_RING_ANY
reorder_module p=before status=reorder_status m=PMM$PROGRAM_STATE_PROCESSOR
reorder_module p=before status=reorder_status m=CMM$LOGICAL_CONFIGURATION_MGR
reorder_module p=before status=reorder_status m=OFM$OPERATOR_MESSAGE_PROCEDURES
reorder_module p=before status=reorder_status m=JMM$HANDLE_CONDITIONS
reorder_module p=before status=reorder_status m=TMM$SYSTEM_REQ_FAULT_PROCESSOR
reorder_module p=before status=reorder_status m=TMM$DISPOSE_OF_MONITOR_FAULT
reorder_module p=before status=reorder_status m=TMM$BROKEN_TASK_FAULT_PROCESSOR
reorder_module p=before status=reorder_status m=SYM$SYSTEM_TASK_SERVICES
reorder_module p=before status=reorder_status m=SYM$MEMORY_LINK_DATA_CONVERSION
reorder_module p=before status=reorder_status m=SYM$JOB_RECOVERY_TEST
reorder_module p=before status=reorder_status m=RMM$REQUEST_MASS_STORAGE_CMD
reorder_module p=before status=reorder_status m=RHM$PERMANENT_FILE_GET_REPLACE
reorder_module p=before status=reorder_status m=RHM$CHANGE_LINK_ATTRIBUTES
reorder_module p=before status=reorder_status m=RAM$INTERVENE_IN_DEADSTART
reorder_module p=before status=reorder_status m=RAM$GO
reorder_module p=before status=reorder_status m=RAM$ESTABLISH_VARIABLES
reorder_module p=before status=reorder_status m=PMM$USER_TIME_REQUESTS
reorder_module p=before status=reorder_status m=PMM$TASKING_HELPER_PROCEDURES
reorder_module p=before status=reorder_status m=PMM$SYSTEM_TIME_COMPUTATION
reorder_module p=before status=reorder_status m=PMM$STATUS_QUEUES_DEFINED
reorder_module p=before status=reorder_status m=PMM$RECEIVE_FROM_QUEUE
reorder_module p=before status=reorder_status m=PMM$PRESET_CONVERSION_TABLE
reorder_module p=before status=reorder_status m=PMM$MPE_RECORD_CALL_AND_RETURN
reorder_module p=before status=reorder_status m=PMM$JOB_TEMPLATE_TRAP_HANDLER
reorder_module p=before status=reorder_status m=PMM$INTERCEPT_PROCEDURES
reorder_module p=before status=reorder_status m=PFM$CONVERT_STRING_TO_PF_PATH
reorder_module p=before status=reorder_status m=PFM$CHANGE_CATALOG_CONTENTS
reorder_module p=before status=reorder_status m=PFM$ARCHIVE_RETRIEVE_CONTROL
reorder_module p=before status=reorder_status m=OSM$WAIT_ON_CONDITION
reorder_module p=before status=reorder_status m=OSM$TRANSLATE_TABLES
reorder_module p=before status=reorder_status m=OSM$TRANSLATE_BYTES
reorder_module p=before status=reorder_status m=OSM$S_AND_D_SYS_ATTRS
reorder_module p=before status=reorder_status m=OSM$RUN_VIRTUAL_SYSTEM
reorder_module p=before status=reorder_status m=OSM$MISC_TEST_COMMANDS
reorder_module p=before status=reorder_status m=OSM$INTRINSICS
reorder_module p=before status=reorder_status m=OSM$INITIALIZE_VIRTUAL_SYSTEM
reorder_module p=before status=reorder_status m=OSM$DEFAULT_HANDLER_DESC
reorder_module p=before status=reorder_status m=OSM$COLLATE_TABLES
reorder_module p=before status=reorder_status m=OSM$CHANGE_OS_DEFAULTS
reorder_module p=before status=reorder_status m=OSM$APPEND_STATUS_REAL
reorder_module p=before status=reorder_status m=OFM$VEDISPLAY_COMMAND
reorder_module p=before status=reorder_status m=OFM$SYSTEM_OPERATOR_UTILITY_2DD
reorder_module p=before status=reorder_status m=NFM$REMOTE_VALIDATION_COMMANDS
reorder_module p=before status=reorder_status m=NAM$STORE_ATTRIBUTES
reorder_module p=before status=reorder_status m=NAM$SE_SYNCHRONIZE_CONFIRM
reorder_module p=before status=reorder_status m=NAM$SE_SYNCHRONIZE
reorder_module p=before status=reorder_status m=NAM$SE_INTERRUPT
reorder_module p=before status=reorder_status m=NAM$SE_GET_AVAILABLE_BYTE_COUNT
reorder_module p=before status=reorder_status m=NAM$FETCH_ATTRIBUTES
reorder_module p=before status=reorder_status m=MSM$MAINTENANCE_SERVICES_UTL
reorder_module p=before status=reorder_status m=MMM$SEGMENT_FAULT_HANDLER
reorder_module p=before status=reorder_status m=MLM$VITOI
reorder_module p=before status=reorder_status m=MLM$VITOD
reorder_module p=before status=reorder_status m=MLM$VDTOI
reorder_module p=before status=reorder_status m=MLM$VDTOD
reorder_module p=before status=reorder_status m=MLM$VDLOG_VDLOG10
reorder_module p=before status=reorder_status m=MLM$VDEXP
reorder_module p=before status=reorder_status m=MLM$OUTPUT_FLOATING_NUMBER
reorder_module p=before status=reorder_status m=MLM$INPUT_FLOATING_NUMBER
reorder_module p=before status=reorder_status m=MLM$DOUBLE_POWERS_OF_TEN
reorder_module p=before status=reorder_status m=MLM$CONVERT_INTEGER_TO_FLOAT
reorder_module p=before status=reorder_status m=MLM$CONVERT_FLOAT_TO_INTEGER
reorder_module p=before status=reorder_status m=MLM$COMPUTE_FLOATING_NUMBER
reorder_module p=before status=reorder_status m=MLM$COMPARE_FLOATING
reorder_module p=before status=reorder_status m=JMM$PROCESS_JOB_HISTORY
reorder_module p=before status=reorder_status m=JMM$OPERATOR_FACILITY_COMMANDS
reorder_module p=before status=reorder_status m=JMM$JOB_CLASS_COMMANDS
reorder_module p=before status=reorder_status m=IIM$TASK_SHARED_VARIABLES
reorder_module p=before status=reorder_status m=IIM$REPORT_STATUS_ERROR
reorder_module p=before status=reorder_status m=IIM$PAUSE_UTILITY
reorder_module p=before status=reorder_status m=IFM$INTERACTIVE_USER_FAP_SCREEN
reorder_module p=before status=reorder_status m=IFM$FETCH_TERM_CONN_ATTRIBUTES
reorder_module p=before status=reorder_status m=IFM$DEFAULT_CONDITION_HANDLER
reorder_module p=before status=reorder_status m=ICM$TASK_SHARED_VARIABLES
reorder_module p=before status=reorder_status m=FSM$TABLES
reorder_module p=before status=reorder_status m=CYM$STRINGREP
reorder_module p=before status=reorder_status m=CYM$ERROR_PROCESSOR
reorder_module p=before status=reorder_status m=CMM$TASK_SHARED_VARIABLES
reorder_module p=before status=reorder_status m=CLM$WRITE_TAPE_MARK_COMMAND
reorder_module p=before status=reorder_status m=CLM$UTILITY_COMMANDS
reorder_module p=before status=reorder_status m=CLM$TERMINATE_TAPE_ASSIGNMENT
reorder_module p=before status=reorder_status m=CLM$SYSTEM_TASK_MAINTENANCE
reorder_module p=before status=reorder_status m=CLM$SYSTEM_LOGGING_COMMANDS
reorder_module p=before status=reorder_status m=CLM$SYSTEM_FUNCTIONS_V0
reorder_module p=before status=reorder_status m=CLM$SYSTEM_FUNCTIONS
reorder_module p=before status=reorder_status m=CLM$SYSTEM_COMMANDS
reorder_module p=before status=reorder_status m=CLM$SUBSTITUTE_DELIMITED_TEXT
reorder_module p=before status=reorder_status m=CLM$SKIP_COMMAND
reorder_module p=before status=reorder_status m=CLM$SET_WORKING_CATAOG_COMMAND
reorder_module p=before status=reorder_status m=CLM$SET_SPY_IDENTIFIER
reorder_module p=before status=reorder_status m=CLM$SET_PRIMARY_TASK_COMMAND
reorder_module p=before status=reorder_status m=CLM$SET_MESSAGE_MODE_COMMAND
reorder_module p=before status=reorder_status m=CLM$SET_COMMAND_LIST
reorder_module p=before status=reorder_status m=CLM$SCAN_EXPRESSION
reorder_module p=before status=reorder_status m=CLM$RESOURCE_MANAGER_COMMANDS
reorder_module p=before status=reorder_status m=CLM$REMOTE_HOST_COMMANDS
reorder_module p=before status=reorder_status m=CLM$REASSIGN_DEVICE_COMMAND
reorder_module p=before status=reorder_status m=CLM$OPERATOR_COMMANDS
reorder_module p=before status=reorder_status m=CLM$LONGREAL_CONSTANTS
reorder_module p=before status=reorder_status m=CLM$LONGREAL_ARITHMETIC
reorder_module p=before status=reorder_status m=CLM$LOCAL_QUEUE_FAP
reorder_module p=before status=reorder_status m=CLM$JOB_MANAGEMENT_COMMANDS
reorder_module p=before status=reorder_status m=CLM$INTRINSIC_COMMANDS
reorder_module p=before status=reorder_status m=CLM$INTERACTIVE_COMMANDS
reorder_module p=before status=reorder_status m=CLM$HELP_SUBJECT_AVS
reorder_module p=before status=reorder_status m=CLM$HELP_MESSAGE_INTERFACES
reorder_module p=before status=reorder_status m=CLM$HELP_COMMAND
reorder_module p=before status=reorder_status m=CLM$GET_JOB_PARAMETERS
reorder_module p=before status=reorder_status m=CLM$EDIT_PARAMETER_LIST
reorder_module p=before status=reorder_status m=CLM$DISPLAY_JOB_HISTORY_COMMAND
reorder_module p=before status=reorder_status m=CLM$DEBUG_COMMANDS
reorder_module p=before status=reorder_status m=CLM$DATE_TIME_FUNCTIONS
reorder_module p=before status=reorder_status m=CLM$DATA_VALUE_COMPARE
reorder_module p=before status=reorder_status m=CLM$CONVERT_VALUE_TO_STRING
reorder_module p=before status=reorder_status m=CLM$CONVERT_REAL_TO_STRING
reorder_module p=before status=reorder_status m=CLM$CONVERT_CHAR_TO_GRAPHIC
reorder_module p=before status=reorder_status m=CLM$COMMENT_COMMAND
reorder_module p=before status=reorder_status m=CLM$COLLECT_TEXT_COMMAND
reorder_module p=before status=reorder_status m=CLM$CHANGE_NATURAL_LANGUAGE
reorder_module p=before status=reorder_status m=CLM$ASSIGN_DEVICE_COMMAND
reorder_module p=before status=reorder_status m=CLM$ACCEPT
reorder_module p=before status=reorder_status m=AVM$VALIDATION_COMMANDS
reorder_module p=before status=reorder_status m=AMM$WRITE_TAPE_MARK
reorder_module p=before status=reorder_status m=AMM$WRITE_END_PARTITION
reorder_module p=before status=reorder_status m=AMM$US_BLK_VAR_READ_ONLY_FAP
reorder_module p=before status=reorder_status m=AMM$UNLOCK_KEY
reorder_module p=before status=reorder_status m=AMM$UNLOCK_FILE
reorder_module p=before status=reorder_status m=AMM$TRACE_ROUTINES
reorder_module p=before status=reorder_status m=AMM$TABLES
reorder_module p=before status=reorder_status m=AMM$STORE
reorder_module p=before status=reorder_status m=AMM$START
reorder_module p=before status=reorder_status m=AMM$SKIP_TAPE_MARKS
reorder_module p=before status=reorder_status m=AMM$SKIP
reorder_module p=before status=reorder_status m=AMM$SET_LOCAL_NAME_ABNORMAL
reorder_module p=before status=reorder_status m=AMM$SET_FILE_INSTANCE_ABNORMAL
reorder_module p=before status=reorder_status m=AMM$SEPARATE_KEY_GROUPS
reorder_module p=before status=reorder_status m=AMM$SELECT_NESTED_FILE
reorder_module p=before status=reorder_status m=AMM$SELECT_KEY
reorder_module p=before status=reorder_status m=AMM$REPLACE_PREVIOUS_RECORD
reorder_module p=before status=reorder_status m=AMM$REPLACE_KEY
reorder_module p=before status=reorder_status m=AMM$PUT_LABEL
reorder_module p=before status=reorder_status m=AMM$PUT_KEY
reorder_module p=before status=reorder_status m=AMM$PUT_DIRECT
reorder_module p=before status=reorder_status m=AMM$PUTREP
reorder_module p=before status=reorder_status m=AMM$LOCK_KEY
reorder_module p=before status=reorder_status m=AMM$LOCK_FILE
reorder_module p=before status=reorder_status m=AMM$GET_SPACE_USED_FOR_KEY
reorder_module p=before status=reorder_status m=AMM$GET_PRIMARY_KEY_COUNT
reorder_module p=before status=reorder_status m=AMM$GET_PARTIAL
reorder_module p=before status=reorder_status m=AMM$GET_NEXT_PRIMARY_KEY_LIST
reorder_module p=before status=reorder_status m=AMM$GET_NEXT_KEY
reorder_module p=before status=reorder_status m=AMM$GET_NESTED_FILE_DEFINITIONS
reorder_module p=before status=reorder_status m=AMM$GET_LOCK_NEXT_KEYED_RECORD
reorder_module p=before status=reorder_status m=AMM$GET_LOCK_KEYED_RECORD
reorder_module p=before status=reorder_status m=AMM$GET_LABEL
reorder_module p=before status=reorder_status m=AMM$GET_KEY_DEFINITIONS
reorder_module p=before status=reorder_status m=AMM$GET_KEY
reorder_module p=before status=reorder_status m=AMM$GET_DIRECT
reorder_module p=before status=reorder_status m=AMM$FIND_RECORD_SPACE
reorder_module p=before status=reorder_status m=AMM$ERASE_TAPE_BLOCK
reorder_module p=before status=reorder_status m=AMM$DISPLAY_BAM_TABLES
reorder_module p=before status=reorder_status m=AMM$DELETE_NESTED_FILE
reorder_module p=before status=reorder_status m=AMM$DELETE_KEY_DEFINITION
reorder_module p=before status=reorder_status m=AMM$DELETE_KEY
reorder_module p=before status=reorder_status m=AMM$CREATE_NESTED_FILE
reorder_module p=before status=reorder_status m=AMM$CREATE_KEY_DEFINITION
reorder_module p=before status=reorder_status m=AMM$COMMIT_FILE_PARCEL
reorder_module p=before status=reorder_status m=AMM$CLOSE_VOLUME
reorder_module p=before status=reorder_status m=AMM$CHECK_RECORD
reorder_module p=before status=reorder_status m=AMM$CHECK_NOWAIT_REQUEST
reorder_module p=before status=reorder_status m=AMM$BEGIN_FILE_PARCEL
reorder_module p=before status=reorder_status m=AMM$APPLY_KEY_DEFINITIONS
reorder_module p=before status=reorder_status m=AMM$ALTERNATE_ENTRY_POINTS
reorder_module p=before status=reorder_status m=AMM$ADD_TO_FILE_DESCRIPTION
reorder_module p=before status=reorder_status m=AMM$ABORT_FILE_PARCEL
reorder_module p=before status=reorder_status m=AMM$ABANDON_KEY_DEFINITIONS
reorder_module p=before status=reorder_status m=AMM$FETCH_NESTED_FILE_ATTRIB
reorder_module p=before status=reorder_status m=AMM$FETCH_TAPE_LABEL_ATTRIBUTE
reorder_module p=before status=reorder_status m=AVM$MAKE_SCL_DATA_VALUES
reorder_module p=before status=reorder_status m=AVM$SECURITY_CMDS_AND_FUNCTIONS
reorder_module p=before status=reorder_status m=CLM$CHANGE_UNSEEN_MAIL_ACTION
reorder_module p=before status=reorder_status m=CLM$DEFAULT_UNSEEN_MAIL_HANDLER
reorder_module p=before status=reorder_status m=CMM$PCU_EDITOR_FUNCTIONS
reorder_module p=before status=reorder_status m=CMM$PHYS_CONFIGURATION_UTL_2DD
reorder_module p=before status=reorder_status m=DMM$INITIALIZE_TAPE_VOL
reorder_module p=before status=reorder_status m=FSM$CONVERT_FILE_CONTENTS
reorder_module p=before status=reorder_status m=FSM$DEFAULT_TAPE_LABEL_ATTRIB
reorder_module p=before status=reorder_status m=FSM$GET_TAPE_LABEL_ATTRIBUTES
reorder_module p=before status=reorder_status m=LGM$GET_NEXT_STATISTIC
reorder_module p=before status=reorder_status m=NFM$FILE_TRANSFER_FUNCTIONS
reorder_module p=before status=reorder_status m=NFM$SUBMIT_MULTI_RECORD_JOB
reorder_module p=before status=reorder_status m=OFM$DESIGNER_SCREENS
reorder_module p=before status=reorder_status m=PFM$PROCESS_STORAGE
reorder_module p=before status=reorder_status m=RAM$MENU_PROMPTING_INTERFACES
reorder_module p=before status=reorder_status m=RMM$MEDIA_INTERFACES_2DD
reorder_module p=before status=reorder_status m=SYM$INJECT_HARDWARE_FAULT
reorder_module p=before status=reorder_status m=SYM$CAUSE_HARDWARE_FAULTS
reorder_module p=before status=reorder_status m=NAM$SK_AWAIT_SOCKET_EVENTS
reorder_module p=before status=reorder_status m=OSM$SPI_DATA_COLLECTOR
reorder_module p=before status=reorder_status m=JMM$OPER_COMMAND_REQUESTS
reorder_module p=before status=reorder_status m=CLM$PUT_LINE_COMMAND
reorder_module p=before status=reorder_status m=CLM$LIST_FUNCTIONS
reorder_module p=before status=reorder_status m=CLM$SPI_COMMANDS
reorder_module p=before status=reorder_status m=CLM$CONVERT_STATUS
reorder_module p=before status=reorder_status m=PMM$DISPLAY_ACTIVE_TASKS
reorder_module p=before status=reorder_status m=AMM$REWIND
reorder_module p=before status=reorder_status m=CLM$REWIND_COMMAND
reorder_module p=before status=reorder_status m=CLM$PROCESS_WHEN_CONDITION
reorder_module p=before status=reorder_status m=CLM$CONNECTED_FILES_SCREENS
reorder_module p=before status=reorder_status m=CLM$PROCESS_PROC_PARAMETERS
reorder_module p=before status=reorder_status m=CLM$WILD_CARD_FILE_EXPANSION
reorder_module p=before status=reorder_status m=OSM$AWAIT_ACTIVITY_COMPLETE
reorder_module p=before status=reorder_status m=AMM$SEEK_DIRECT
reorder_module p=before status=reorder_status m=CLM$PARAMETER_ACCESS_FUNCTIONS
reorder_module p=before status=reorder_status m=AMM$FETCH_FAP_POINTER
reorder_module p=before status=reorder_status m=NAM$EXTERNAL_CONNECTION_MGMT
reorder_module p=before status=reorder_status m=CLM$COLLECT_COMMANDS
reorder_module p=before status=reorder_status m=AMM$FLUSH
reorder_module p=before status=reorder_status m=FSM$CREATE_FILE
reorder_module p=before status=reorder_status m=CLM$PROGRAM_EXECUTION_COMMANDS
reorder_module p=before status=reorder_status m=CLM$GENERATE_PDT_AND_TYPE
reorder_module p=before status=reorder_status m=CLM$DETERMINE_LINE_LAYOUT
reorder_module p=before status=reorder_status m=LGM$LOGGING_COMMANDS
reorder_module p=before status=reorder_status m=JMM$QUEUE_FILE_COMMANDS
reorder_module p=before status=reorder_status m=CLM$DISPLAY_CMND_OR_FUNC_INFO
reorder_module p=before status=reorder_status m=CLM$DISPLAY_COMMAND_LIST_ENTRY
reorder_module p=before status=reorder_status m=CLM$DISPLAY_TASK_STATUS_COMMAND
reorder_module p=before status=reorder_status m=CLM$DISPLAY_COMMAND_LIST
reorder_module p=before status=reorder_status m=SFM$LIMIT_COMMANDS_FUNCTIONS
reorder_module p=before status=reorder_status m=SFM$STATISTIC_COMMANDS
reorder_module p=before status=reorder_status m=RHM$DISPLAY_LINK_ATTRIBUTES
reorder_module p=before status=reorder_status m=PUM$BACKUP_LABEL_TYPE_COMMANDS
reorder_module p=before status=reorder_status m=OSM$CHANGE_INTERACT_STYLE_CMND
reorder_module p=before status=reorder_status m=NAM$MANAGE_NAM_ATTRIBUTES
reorder_module p=before status=reorder_status m=CLM$TAPE_VALIDATION_COMMANDS
reorder_module p=before status=reorder_status m=CLM$TAPE_LABEL_COMMANDS
reorder_module p=before status=reorder_status m=CLM$SET_DISP_MULTIPRO_OPTS_CMDS
reorder_module p=before status=reorder_status m=CLM$SCL_OPTIONS_COMMAND
reorder_module p=before status=reorder_status m=CLM$KEYPOINT_COMMANDS
reorder_module p=before status=reorder_status m=CLM$DUMP_FILE_COMMAND
reorder_module p=before status=reorder_status m=CLM$DISPLAY_WORKING_CATALOG
reorder_module p=before status=reorder_status m=CLM$DISPLAY_VAR_LIST_COMMAND
reorder_module p=before status=reorder_status m=CLM$DISPLAY_SYSTEM_TASK_DATA
reorder_module p=before status=reorder_status m=CLM$COMPARE_COMMAND
reorder_module p=before status=reorder_status m=AVM$FAMILY_COMMANDS
reorder_module p=before status=reorder_status m=CMM$PCU_EDITOR_COMMANDS
reorder_module p=before status=reorder_status m=CLM$INTERPRET_COMMANDS
reorder_module p=before status=reorder_status m=CLM$CONNECTED_FILE_COMMANDS
reorder_module p=before status=reorder_status m=OCM$OBJECT_MODULE_CONVERTER
reorder_module p=before status=reorder_status m=CLM$FILE_COMMAND
reorder_module p=before status=reorder_status m=CLM$FILE_FUNCTIONS
reorder_module p=before status=reorder_status m=CLM$DISPLAY_VALUE_COMMAND
reorder_module p=before status=reorder_status m=CLM$DISPLAY_COMMAND_ENV_COMMAND
reorder_module p=before status=reorder_status m=PMM$STACK_FRAME_POPPER
reorder_module p=before status=reorder_status m=CLM$SCAN_PROC_PDT_DECLARATION
reorder_module p=before status=reorder_status m=CLM$COPY_COMMAND
reorder_module p=before status=reorder_status m=CLM$SCAN_TOKEN
reorder_module p=before status=reorder_status m=CLM$MISCELLANEOUS_FUNCTIONS
reorder_module p=before status=reorder_status m=MMM$MANAGE_MEMORY
reorder_module p=before status=reorder_status m=PMM$PROGRAM_EXECUTION_COMMANDS
reorder_module p=before status=reorder_status m=CLM$RETURN_COMMAND
reorder_module p=before status=reorder_status m=CLM$SYSTEM_ACCESS_COMMANDS
reorder_module p=before status=reorder_status m=PMM$DEBUG_STACK_MANAGERS_1FF
reorder_module p=before status=reorder_status m=CLM$SCAN_PARAMETER_LIST
reorder_module p=before status=reorder_status m=AMM$SET_SEGMENT_EOI
reorder_module p=before status=reorder_status m=BAM$GET_PHN_VIA_FILE_ID
reorder_module p=before status=reorder_status m=CMM$LOGICAL_CONFIGURATION_UTIL
reorder_module p=before status=reorder_status m=CLM$DISPLAY_SYSTEM_DATA
reorder_module p=before status=reorder_status m=PMM$GET_JOB_TASK_STATISTICS
reorder_module p=before status=reorder_status m=PMM$TASKING_INTERFACES_RING_N
reorder_module p=before status=reorder_status m=FSM$SET_EVALUATED_FILE_ABNORMAL
reorder_module p=before status=reorder_status m=PFM$FIND_INFORMATION
reorder_module p=before status=reorder_status m=CLM$ACCESS_COMMAND_FILE
reorder_module p=before status=reorder_status m=AMM$PUT_PARTIAL
reorder_module p=before status=reorder_status m=NAM$PARSE_ACCOUNTING_DATA
reorder_module p=before status=reorder_status m=NFM$REMOTE_FILE_ACCESS
reorder_module p=before status=reorder_status m=AMM$SET_SEGMENT_POSITION
reorder_module p=before status=reorder_status m=AMM$FETCH_ACCESS_INFORMATION
reorder_module p=before status=reorder_status m=PMM$OUTWARD_CALL
reorder_module p=before status=reorder_status m=AMM$RETURN
reorder_module p=before status=reorder_status m=CLM$PROCESS_VALUE_QUALIFIERS
reorder_module p=before status=reorder_status m=PMM$TASK_TERMINATION
reorder_module p=before status=reorder_status m=CLM$CLT$VALUE_CONVERSION
reorder_module p=before status=reorder_status m=CLM$COMMAND_UTILITY_MANAGER
reorder_module p=before status=reorder_status m=OSM$APPEND_STATUS_FILE
reorder_module p=before status=reorder_status m=CLM$ACCESS_PARAMETERS
reorder_module p=before status=reorder_status m=CLM$OUTPUT_TO_SYSTEM_FILES
reorder_module p=before status=reorder_status m=CLM$DISPLAY_FILE_ATTB_COMMAND
reorder_module p=before status=reorder_status m=CLM$PERMANENT_FILE_COMMANDS
reorder_module p=before status=reorder_status m=PMM$DISPOSE_OF_TRAPS
reorder_module p=before status=reorder_status m=IFM$STORE_TERM_CONN_ATTRIBUTES
reorder_module p=before status=reorder_status m=CLM$TRANSLATE_PDT
reorder_module p=before status=reorder_status m=PFM$USER_RING_REQUEST_PROCESSOR
reorder_module p=before status=reorder_status m=FSM$COPY_FILE
reorder_module p=before status=reorder_status m=AMM$GET_SEGMENT_POINTER
reorder_module p=before status=reorder_status m=CLM$FUNCTION_MANAGER
reorder_module p=before status=reorder_status m=AMM$FETCH
reorder_module p=before status=reorder_status m=CLM$DATE_TIME_CONVERSION
reorder_module p=before status=reorder_status m=AMM$OPEN
reorder_module p=before status=reorder_status m=CLM$DATA_VALUE_CONVERSION
reorder_module p=before status=reorder_status m=CLM$PF_DISPLAY_COMMANDS
reorder_module p=before status=reorder_status m=AMM$ACCESS_METHOD
reorder_module p=before status=reorder_status m=RMM$RESOURCE_MANAGER
reorder_module p=before status=reorder_status m=CLM$PARSE_COMMAND
reorder_module p=before status=reorder_status m=CLM$STRING_PATTERN_HANDLERS
reorder_module p=before status=reorder_status m=FSM$CLOSE_FILE
reorder_module p=before status=reorder_status m=CLM$CONTROL_STATEMENTS
reorder_module p=before status=reorder_status m=FSM$VALIDATE_ATTACHMENTS
reorder_module p=before status=reorder_status m=FSM$OPEN_FILE
reorder_module p=before status=reorder_status m=BAM$LOADED_RING_CLEANUP
reorder_module p=before status=reorder_status m=NAM$SE_RECEIVE_DATA
reorder_module p=before status=reorder_status m=CLM$INCLUDE
reorder_module p=before status=reorder_status m=JMM$ATTRIBUTE_DISPLAY_FUNCTIONS
reorder_module p=before status=reorder_status m=OSM$I_AWAIT_ACTIVITY_COMPLETE
reorder_module p=before status=reorder_status m=NAM$AWAIT_DATA_AVAILABLE
reorder_module p=before status=reorder_status m=PMM$DISPOSE_OF_CONDITIONS
reorder_module p=before status=reorder_status m=NAM$SE_SEND_DATA
reorder_module p=before status=reorder_status m=FSM$VALIDATE_ATTRIBUTES
reorder_module p=before status=reorder_status m=CLM$FORMAT_VALUE
reorder_module p=before status=reorder_status m=AMM$FILE_STRUCTURE_FUNCTIONS
reorder_module p=before status=reorder_status m=PMM$OBJECT_CODE_UTILITIES
reorder_module p=before status=reorder_status m=BAM$CONNECTED_FILE_DEVICE
reorder_module p=before status=reorder_status m=FSM$EXPAND_FILE_LABEL
reorder_module p=before status=reorder_status m=AMM$GET_NEXT
reorder_module p=before status=reorder_status m=CLM$PROCESS_COMMANDS
reorder_module p=before status=reorder_status m=CLM$INPUT_PROCEDURES
reorder_module p=before status=reorder_status m=PMM$WAIT_SERVICES
reorder_module p=before status=reorder_status m=IFM$ST_INTERACTIVE_USR_FAP_SCRN
reorder_module p=before status=reorder_status m=CLM$VARIABLE_ACCESS_MANAGER
reorder_module p=before status=reorder_status m=NAM$NETWORK_FAP
reorder_module p=before status=reorder_status m=OSM$SYSTEM_MESSAGE_GENERATOR
reorder_module p=before status=reorder_status m=CLM$CONVERT_TO_STRING
reorder_module p=before status=reorder_status m=PMM$CONDITION_STACK_PROCESSOR
reorder_module p=before status=reorder_status m=CLM$DISPLAY_INTERFACES
reorder_module p=before status=reorder_status m=AMM$PUT_NEXT
reorder_module p=before status=reorder_status m=CLM$PROCESS_DATA_TYPES
reorder_module p=before status=reorder_status m=CLM$EVALUATE_PARAMETERS
reorder_module p=before status=reorder_status m=CLM$LEXICAL_PROCESSORS
reorder_module p=before status=reorder_status m=CLM$FILE_REFERENCE_MANAGER
reorder_module p=before status=reorder_status m=CLM$EVALUATE_EXPRESSION
*DECK DECK=RAI$REORDER_MONITOR EXPAND=TRUE
IF $variable(reorder_status, declared) <> 'LOCAL' THEN
  create_variable reorder_status k=status
IFEND
reorder_module p=before status=reorder_status m=MTM$MONITOR_INTERRUPT_HANDLER
reorder_module p=before status=reorder_status m=MMM$MEMORY_MANAGER_HELPER
reorder_module p=before status=reorder_status m=OSM$INTRINSICS
reorder_module p=before status=reorder_status m=JSM$SWAPPED_JOB_MANAGER
reorder_module p=before status=reorder_status m=SYM$MTR_INJECT_HARDWARE_FAULT
reorder_module p=before status=reorder_status m=RFM$REQUEST_PROCESSING_MTR
reorder_module p=before status=reorder_status m=OSM$PROCESS_ERROR_CONDITIONS
reorder_module p=before status=reorder_status m=MTM$PROCESS_DUE_ERRORS
reorder_module p=before status=reorder_status m=MTM$PROCESS_170_MTR_REQUESTS
reorder_module p=before status=reorder_status m=MTM$170_TRAP_HANDLER
reorder_module p=before status=reorder_status m=MMM$IO_REQUEST_PROCESSOR
reorder_module p=before status=reorder_status m=MMM$FILE_SERVER_PROCESSOR
reorder_module p=before status=reorder_status m=MMM$CACHE_MANAGEMENT_ROUTINES
reorder_module p=before status=reorder_status m=MLM$MEMORY_LINK_MONITOR_MODE
reorder_module p=before status=reorder_status m=IOM$TRANSLATE_BYTE_ADDRESS
reorder_module p=before status=reorder_status m=IOM$TAPE_QUEUE_MANAGER_MTR
reorder_module p=before status=reorder_status m=IOM$SUBSYSTEM_IO_MTR_PROCESSING
reorder_module p=before status=reorder_status m=IOM$STATUS_ROUTINES_MTR_MODE
reorder_module p=before status=reorder_status m=IOM$RESUME_ALL_PATHS
reorder_module p=before status=reorder_status m=IOM$RESUME
reorder_module p=before status=reorder_status m=IOM$REQUEST_PROCESSOR
reorder_module p=before status=reorder_status m=IOM$PROCESS_IDLE_RESPONSE
reorder_module p=before status=reorder_status m=IOM$IDLE_PATH
reorder_module p=before status=reorder_status m=IOM$IDLE_ALL_PATHS
reorder_module p=before status=reorder_status m=IOM$IDLE
reorder_module p=before status=reorder_status m=IOM$ENABLE_ALL_DISK_UNITS
reorder_module p=before status=reorder_status m=IOM$DOWN_DISK_UNIT
reorder_module p=before status=reorder_status m=IOM$CHECK_IDLE_PPS
reorder_module p=before status=reorder_status m=DSM$PROCESS_SYSTEM_MESSAGES
reorder_module p=before status=reorder_status m=DSM$MTR_MANAGE_SYSTEM_DS_STATUS
reorder_module p=before status=reorder_status m=DPM$SYSTEM_CONSOLE_MONITOR
reorder_module p=before status=reorder_status m=DPM$PROCESS_MONITOR_COMMAND
reorder_module p=before status=reorder_status m=DMM$VOLUME_UP_DOWN
reorder_module p=before status=reorder_status m=DMM$MONITOR_UTILITIES
reorder_module p=before status=reorder_status m=DFM$QUEUE_ENTRY_CONTROL
reorder_module p=before status=reorder_status m=DFM$PROCESS_SERVER_RESPONSE
reorder_module p=before status=reorder_status m=DFM$MTR_SERVED_FAMILY_MANAGER
reorder_module p=before status=reorder_status m=DFM$MONITOR_STUB
reorder_module p=before status=reorder_status m=DFM$MONITOR_PROCESS
reorder_module p=before status=reorder_status m=DFM$MONITOR_INFO_COLLECTION
reorder_module p=before status=reorder_status m=DFM$MANAGE_SEGMENT_STATE
reorder_module p=before status=reorder_status m=DFM$FILE_SERVER_PAGE_IO
reorder_module p=before status=reorder_status m=DFM$FILE_SERVER_ALLOCATION
reorder_module p=before status=reorder_status m=AVM$SECURITY_OPTIONS
reorder_module p=before status=reorder_status m=DFM$FETCH_PAGE_STATUS
reorder_module p=before status=reorder_status m=DMM$MTR_RECOVER_JOB_DM_TABLES
reorder_module p=before status=reorder_status m=DXM$PROCESS_ONE_WORD_RESPONSE
reorder_module p=before status=reorder_status m=SYM$CAUSE_HARDWARE_FAULTS
reorder_module p=before status=reorder_status m=IOM$QUEUE_PP_REQUEST
reorder_module p=before status=reorder_status m=CMM$MONITOR_ROUTINES
reorder_module p=before status=reorder_status m=DSM$MTR_MANAGE_SSR_ROUTINES
reorder_module p=before status=reorder_status m=DSM$MTR_ISSUE_DFT_REQUEST
reorder_module p=before status=reorder_status m=OSM$SPI_MONITOR_MODE
reorder_module p=before status=reorder_status m=OSM$MONITOR_KEYPOINT_SUPPORT
reorder_module p=before status=reorder_status m=DSM$DEADSTART_SERVICES_MONITOR
reorder_module p=before status=reorder_status m=IOM$DEVICE_IO
reorder_module p=before status=reorder_status m=SFM$MTR_STATS_FACILITY_REQUESTS
reorder_module p=before status=reorder_status m=MTM$SYSTEM_CONTROL
reorder_module p=before status=reorder_status m=MTM$PROCESSOR_CONFIGURATION_MGR
reorder_module p=before status=reorder_status m=IOM$CHECK_ACTIVE_PPS
reorder_module p=before status=reorder_status m=DMM$MTR_FRONT_ENDS
reorder_module p=before status=reorder_status m=TMM$MTR_FLAG_SIGNAL_FUNCTIONS
reorder_module p=before status=reorder_status m=TMM$MANAGE_SYSTEM_TASKS
reorder_module p=before status=reorder_status m=JMM$JOB_SCHEDULER_MONITOR_OR_R1
reorder_module p=before status=reorder_status m=MMM$MTR_USER_REQUEST_PROCESSOR
reorder_module p=before status=reorder_status m=JMM$AJL_MANAGER
reorder_module p=before status=reorder_status m=NAM$PROCESS_NETWORK_RESPONSE
reorder_module p=before status=reorder_status m=MMM$PFTI_MANAGER
reorder_module p=before status=reorder_status m=JMM$JOB_SCHEDULER_MONITOR_MODE
reorder_module p=before status=reorder_status m=DMM$FETCH_PAGE_STATUS
reorder_module p=before status=reorder_status m=DMM$ACCESS_ACTIVE_VOLUME_TABLE
reorder_module p=before status=reorder_status m=JSM$MONITOR_MODE_JOB_SWAPPER
reorder_module p=before status=reorder_status m=DMM$TRANSFER_UNIT_COMPLETED
reorder_module p=before status=reorder_status m=DMM$MONITOR_ALLOCATOR
reorder_module p=before status=reorder_status m=DMM$BUILD_DEVICE_ADDRESS
reorder_module p=before status=reorder_status m=IOM$PROCESS_IO_COMPLETIONS
reorder_module p=before status=reorder_status m=MMM$MONITOR_REQUEST_PROCESSOR
reorder_module p=before status=reorder_status m=MMM$ASID_PAGE_TABLE_MANAGER
reorder_module p=before status=reorder_status m=IOM$QUEUE_REQUEST
reorder_module p=before status=reorder_status m=TMM$DISPATCHER
reorder_module p=before status=reorder_status m=MMM$PAGE_FAULT_PROCESSOR
*DECK DECK=RAI$REORDER_SYSTEM_CORE_113 EXPAND=TRUE
IF $variable(reorder_status, declared) <> 'LOCAL' THEN
  create_variable reorder_status k=status
IFEND
reorder_module p=before status=reorder_status m=SYM$JOB_FIXED_TEMPLATE
reorder_module p=before status=reorder_status m=SYM$CORE_TRAP_HANDLER
reorder_module p=before status=reorder_status m=SYM$OUTWARD_CALLER
reorder_module p=before status=reorder_status m=SYM$DEBUG
reorder_module p=before status=reorder_status m=DMM$DEBUG_COMMAND_PROCESSING
reorder_module p=before status=reorder_status m=DMM$RECOVER_JOB_TEMP_FILE_SPACE
reorder_module p=before status=reorder_status m=RFM$REQUEST_PROCESSING_R1
reorder_module p=before status=reorder_status m=DSM$LOG_SYS_MSGS_HELPER
reorder_module p=before status=reorder_status m=OSM$SYSTEM_CONTROL_SERVICES_R1
reorder_module p=before status=reorder_status m=IOM$SUBSYSTEM_IO_R113
reorder_module p=before status=reorder_status m=TMM$GET_MONITOR_FAULT
reorder_module p=before status=reorder_status m=SYM$SYSTEM_CORE_COMMANDS
reorder_module p=before status=reorder_status m=SYM$DISPLAY_DEADSTART_MESSAGE
reorder_module p=before status=reorder_status m=SYM$DISPLAY_BAM_TABLES
reorder_module p=before status=reorder_status m=SYM$DEBUG1
reorder_module p=before status=reorder_status m=SYM$DEADSTART_INITIALIZATION
reorder_module p=before status=reorder_status m=SYM$DEADSTART_COMMAND_PROCESSOR
reorder_module p=before status=reorder_status m=SYM$DEADSTART
reorder_module p=before status=reorder_status m=SYM$CORE_COMMAND_UTILITIES
reorder_module p=before status=reorder_status m=SYM$ASCII_CONSOLE_INPUT_OUTPUT
reorder_module p=before status=reorder_status m=STM$MANAGE_IO_ON_VST
reorder_module p=before status=reorder_status m=STM$GET_SET_INFO
reorder_module p=before status=reorder_status m=SFM$SYS_ROUTING_CONTROL_MANAGER
reorder_module p=before status=reorder_status m=RHM$UPDATE_DUAL_STATE_ENVIRON
reorder_module p=before status=reorder_status m=QFM$QUEUE_FILE_LEVELER_MANAGER
reorder_module p=before status=reorder_status m=PMM$SYSTEM_TIME_DECLARATIONS
reorder_module p=before status=reorder_status m=PMM$PROGRAM_SERVICES_RING_1
reorder_module p=before status=reorder_status m=OSM$SIMULATE_DISK_FAULT_R1
reorder_module p=before status=reorder_status m=OSM$INITIALIZE_TABLES
reorder_module p=before status=reorder_status m=OSM$FAMILY_MANAGER
reorder_module p=before status=reorder_status m=OSM$DEFINE_CPU
reorder_module p=before status=reorder_status m=OSM$CPU_CONFIGURATION_MGR_R1
reorder_module p=before status=reorder_status m=OSM$CHANGE_OS_DEFAULTS_RING_1
reorder_module p=before status=reorder_status m=OSM$BROKEN_JOB_DUMP
reorder_module p=before status=reorder_status m=OCM$PROCESS_LINKER_DEBUG_TABLES
reorder_module p=before status=reorder_status m=NLM$CHANNEL_CONNECTION_RING1
reorder_module p=before status=reorder_status m=NAM$JOB_RECOVERY_RING1
reorder_module p=before status=reorder_status m=NAM$INTRANET_LAYER_MGMT_R1
reorder_module p=before status=reorder_status m=NAM$INITIALIZE_NETWORKS_R1
reorder_module p=before status=reorder_status m=MMM$READ_WRITE_IO_RING_1
reorder_module p=before status=reorder_status m=MMM$DEADSTART_INITIALIZATION
reorder_module p=before status=reorder_status m=MLM$INITIALIZE_MEMORY_LINK
reorder_module p=before status=reorder_status m=MLM$DEADSTART_INTERFACE
reorder_module p=before status=reorder_status m=MLM$C170_HELPER
reorder_module p=before status=reorder_status m=JMM$LOAD_SYSTEM_JOB_TEMPLATES
reorder_module p=before status=reorder_status m=JMM$JOB_SCHED_TABLE_INIT
reorder_module p=before status=reorder_status m=JMM$JOB_DEADSTART
reorder_module p=before status=reorder_status m=IOM$TAPE_QUEUE_MANAGER_RING1
reorder_module p=before status=reorder_status m=IOM$TAPE_BOOT_MANAGER
reorder_module p=before status=reorder_status m=IOM$SUBSYSTEM_IO_COMPLETION_TBL
reorder_module p=before status=reorder_status m=IOM$STATUS_ROUTINES_JOB_MODE
reorder_module p=before status=reorder_status m=IOM$QUEUE_IMAGE_REQUEST
reorder_module p=before status=reorder_status m=IOM$INITIALIZE_SECTORS
reorder_module p=before status=reorder_status m=IOM$DEBUG_COMMAND_PROCESSING
reorder_module p=before status=reorder_status m=IOM$ALLOCATE_USAGE_COUNTERS
reorder_module p=before status=reorder_status m=IOM$ALLOCATE_IMAGE_REQUESTS
reorder_module p=before status=reorder_status m=DSM$START_ALL_CPUS
reorder_module p=before status=reorder_status m=DSM$SAVE_SYSTEM_INFORMATION
reorder_module p=before status=reorder_status m=DSM$RECOVERY_SERVICES
reorder_module p=before status=reorder_status m=DSM$PROCESS_SYS_MSGS_HELPER
reorder_module p=before status=reorder_status m=DSM$PROCESS_170_REQUESTS
reorder_module p=before status=reorder_status m=DSM$MANAGE_SYSTEM_DS_STATUS
reorder_module p=before status=reorder_status m=DSM$DEADSTART_IO
reorder_module p=before status=reorder_status m=DSM$DEADSTART_FILE_MANAGEMENT
reorder_module p=before status=reorder_status m=DMM$VOLUME_ONLINE
reorder_module p=before status=reorder_status m=DMM$VOLUME_ATTRIBUTE_MANAGER
reorder_module p=before status=reorder_status m=DMM$VALIDATE_SFID_WITH_GFN
reorder_module p=before status=reorder_status m=DMM$SEARCH_VOLUME_DIRECTORY
reorder_module p=before status=reorder_status m=DMM$SAVE_RECONCILE_LIST
reorder_module p=before status=reorder_status m=DMM$INITIALIZE_VOLUME
reorder_module p=before status=reorder_status m=DMM$IDLE_SYSTEM
reorder_module p=before status=reorder_status m=DMM$GET_LOGICAL_UNIT_NUMBER
reorder_module p=before status=reorder_status m=DMM$GET_INITIALIZED_ADDRESSES
reorder_module p=before status=reorder_status m=DMM$GET_DEVICE_ATTRIBUTES
reorder_module p=before status=reorder_status m=DMM$FLAW_MANAGEMENT
reorder_module p=before status=reorder_status m=DMM$DF_SERVER_REQUESTS
reorder_module p=before status=reorder_status m=DMM$DF_CLIENT_REQUESTS
reorder_module p=before status=reorder_status m=DMM$DEVICE_MANAGER_SETUP
reorder_module p=before status=reorder_status m=DMM$ALLOCATE_AVT
reorder_module p=before status=reorder_status m=DMM$ACTIVATE_VOLUME
reorder_module p=before status=reorder_status m=DMM$ACCESS_VOLUME_DEVICE_FILES
reorder_module p=before status=reorder_status m=DFM$RECOVERY_SERVICES
reorder_module p=before status=reorder_status m=DFM$QUEUE_ENTRY_CONTROL
reorder_module p=before status=reorder_status m=DFM$MONITOR_STUB
reorder_module p=before status=reorder_status m=DFM$MANAGE_IJL_ACCESS_WORK
reorder_module p=before status=reorder_status m=CMM$TABLES_RING1
reorder_module p=before status=reorder_status m=CMM$PCU_RING1_HELPER
reorder_module p=before status=reorder_status m=CMM$ACQUIRE_SYSTEM_DEVICE
reorder_module p=before status=reorder_status m=BAM$TAPE_BLOCK_MANAGER_RING1
reorder_module p=before status=reorder_status m=DMM$TAPE_RESERVATION_113
reorder_module p=before status=reorder_status m=DSM$MANAGE_RDF_AND_IMAGE_FILE
reorder_module p=before status=reorder_status m=IOM$MEDIA_INTERFACES_113
reorder_module p=before status=reorder_status m=OSM$SYSTEM_TASK_MAINT_113
reorder_module p=before status=reorder_status m=OSM$MULTIPRO_INTERFACE_R1
reorder_module p=before status=reorder_status m=OSM$KEYPOINT_SUPPORT_R1
reorder_module p=before status=reorder_status m=DSM$MANAGE_PP_LIBRARY
reorder_module p=before status=reorder_status m=OSM$SPI_DATA_COLLECTOR_R1
reorder_module p=before status=reorder_status m=DSM$TEST_RESOURCE_REQUEST_CMDS
reorder_module p=before status=reorder_status m=CMM$MANAGE_170_RESOURCES
reorder_module p=before status=reorder_status m=CMM$MAINTENANCE_SERVICES_R1
reorder_module p=before status=reorder_status m=DSM$PROCESS_DFT_REQUESTS
reorder_module p=before status=reorder_status m=OSM$SPI_SUPPORT_R1
reorder_module p=before status=reorder_status m=CMM$MANAGE_CM_TABLES
reorder_module p=before status=reorder_status m=DSM$LOAD_PPU
reorder_module p=before status=reorder_status m=SYM$JOB_TEMPLATE_MANAGEMENT
reorder_module p=before status=reorder_status m=OSM$EMIT_OS_STATISTICS_R1
reorder_module p=before status=reorder_status m=CMM$MANAGE_INTERFACE_TABLES
reorder_module p=before status=reorder_status m=MMM$RING1_HELPER
reorder_module p=before status=reorder_status m=SYM$JOB_INITIALIZATION
reorder_module p=before status=reorder_status m=JMM$MANAGE_SYSTEM_SUPPLIED_NAME
reorder_module p=before status=reorder_status m=DSM$MANAGE_SSR_ROUTINES
reorder_module p=before status=reorder_status m=DMM$GET_FILE_INFO
reorder_module p=before status=reorder_status m=DMM$MAINFRAME_FILE_LIST_MANAGER
reorder_module p=before status=reorder_status m=JMM$INITIALIZE_JOB_TABLES
reorder_module p=before status=reorder_status m=DFM$CLIENT_REMOTE_CORE_CALL
reorder_module p=before status=reorder_status m=SYM$SYSTEM_CONSTANT_MANAGER
reorder_module p=before status=reorder_status m=DMM$DESTROY_PERMANENT_FILE
reorder_module p=before status=reorder_status m=DSM$DEADSTART_SERVICES
reorder_module p=before status=reorder_status m=QFM$SET_JOB_ATTRIBUTES
reorder_module p=before status=reorder_status m=QFM$JOB_CATEGORIZATION_MANAGER
reorder_module p=before status=reorder_status m=OSM$FETCH_STAT_DATA_R1_HELPER
reorder_module p=before status=reorder_status m=MLM$MEMORY_LINK_INTERFACE
reorder_module p=before status=reorder_status m=JSM$JOB_SWAPPER
reorder_module p=before status=reorder_status m=DMM$SPACE_MANAGER
reorder_module p=before status=reorder_status m=QFM$QUEUE_FILE_OUTPUT_MANAGER
reorder_module p=before status=reorder_status m=IOM$MASS_STORAGE_IO
reorder_module p=before status=reorder_status m=DMM$SEARCH_FOR_MS_LABEL
reorder_module p=before status=reorder_status m=STM$READ_AST_R1
reorder_module p=before status=reorder_status m=JMM$QUEUE_FILE_SCHED_INTERFACES
reorder_module p=before status=reorder_status m=TMM$RING1_HELPER
reorder_module p=before status=reorder_status m=SFM$FILE_SPACE_LIMITS_MANAGER
reorder_module p=before status=reorder_status m=STM$MODIFY_AST_R1
reorder_module p=before status=reorder_status m=DMM$ATTACH_FILE
reorder_module p=before status=reorder_status m=DMM$STORED_FMD_MANAGER
reorder_module p=before status=reorder_status m=QFM$QUEUE_FILE_JOB_MANAGER
reorder_module p=before status=reorder_status m=TMM$MANAGE_PREEMPTIVE_BUFFERS
reorder_module p=before status=reorder_status m=DMM$FILE_ACCESS_ROUTINES
reorder_module p=before status=reorder_status m=DMM$AVT_CLASS_COUNTS
reorder_module p=before status=reorder_status m=OFM$OPERATOR_ACTION_MENU_R1
reorder_module p=before status=reorder_status m=IOM$MANAGE_RVL_TUSL_STRUCTURES
reorder_module p=before status=reorder_status m=PMM$TASKING_SUPPORT_RING_1
reorder_module p=before status=reorder_status m=CMM$PHYSICAL_CONFIGURATION_MGR
reorder_module p=before status=reorder_status m=DMM$CREATE_NEW_FILE
reorder_module p=before status=reorder_status m=OFM$JOB_MESSAGE_PROCESSING
reorder_module p=before status=reorder_status m=JMM$JOB_SCHEDULER_RING_1
reorder_module p=before status=reorder_status m=PFM$CATALOG_ALARM_MANAGER
reorder_module p=before status=reorder_status m=SYM$JOB_RECOVERY_R1
reorder_module p=before status=reorder_status m=LGM$GLOBAL_LOG_MANAGER
reorder_module p=before status=reorder_status m=JMM$JOB_SCHEDULER_MONITOR_OR_R1
reorder_module p=before status=reorder_status m=JMM$JOB_SCHEDULER_UTILITY
reorder_module p=before status=reorder_status m=GFM$FILE_TABLE_MANAGER
reorder_module p=before status=reorder_status m=NAM$CHANNELNET_RING1
reorder_module p=before status=reorder_status m=DMM$JOB_ALLOCATOR
reorder_module p=before status=reorder_status m=DMM$FMD_MANAGER
reorder_module p=before status=reorder_status m=DMM$ACCESS_AVT_JOB_MODE
reorder_module p=before status=reorder_status m=DMM$ACCESS_ACTIVE_VOLUME_TABLE
reorder_module p=before status=reorder_status m=DMM$FILE_TABLE_MANAGER
reorder_module p=before status=reorder_status m=DPM$SYSTEM_CONSOLE_INTERFACE
reorder_module p=before status=reorder_status m=DMM$LOGGER
reorder_module p=before status=reorder_status m=NLM$CL_CONNECTION_MANAGER_R1
reorder_module p=before status=reorder_status m=SYM$SERVICE_ROUTINES_113
reorder_module p=before status=reorder_status m=MMM$SEGMENT_MANAGER_SYSTEM_CORE
*DECK DECK=RAI$REORDER_SYSTEM_CORE_133 EXPAND=TRUE
IF $variable(reorder_status, declared) <> 'LOCAL' THEN
  create_variable reorder_status k=status
IFEND
reorder_module p=before status=reorder_status m=SYM$SERVICE_ROUTINES_133
reorder_module p=before status=reorder_status m=STM$VOLUME_ACTIVE
reorder_module p=before status=reorder_status m=STM$READ_VST
reorder_module p=before status=reorder_status m=STM$MODIFY_VST
reorder_module p=before status=reorder_status m=STM$DISK_VOLUME_INACTIVE
reorder_module p=before status=reorder_status m=RFM$STATIC_DATA
reorder_module p=before status=reorder_status m=NLM$CL_CONNECTION_LAYER_TEMPLAT
reorder_module p=before status=reorder_status m=NLM$CC_GLOBAL_VARS
reorder_module p=before status=reorder_status m=NAM$STATIC_DATA
reorder_module p=before status=reorder_status m=NAM$NAMVE_STATIC_DATA
reorder_module p=before status=reorder_status m=NAM$GT_STATIC_DATA
reorder_module p=before status=reorder_status m=NAM$AM_STATIC_DATA
reorder_module p=before status=reorder_status m=LGM$COMMON_PROCESSORS
reorder_module p=before status=reorder_status m=NLM$SK_STATIC_DATA
reorder_module p=before status=reorder_status m=SFM$COMMON_PROCESSORS
reorder_module p=before status=reorder_status m=PMM$PROGRAM_CONTROL_SERVICES
reorder_module p=before status=reorder_status m=TMM$SYSTEM_TASK_MANAGER_R3
reorder_module p=before status=reorder_status m=OSM$LOCK_MANAGER
reorder_module p=before status=reorder_status m=OSM$HEAP_MANAGER
*DECK DECK=RAI$REORDER_SYSTEM_CORE_13D EXPAND=TRUE
IF $variable(reorder_status, declared) <> 'LOCAL' THEN
  create_variable reorder_status k=status
IFEND
reorder_module p=before status=reorder_status m=OSM$MISC_SERVICES_13D
reorder_module p=before status=reorder_status m=OSM$SYSTEM_CONTROL_SERVICES_R3
reorder_module p=before status=reorder_status m=OSM$PROCESSOR_MODEL_EQUATES
reorder_module p=before status=reorder_status m=MLM$HANDLE_SIGNAL
reorder_module p=before status=reorder_status m=MMM$SM_USER_INTERFACE
reorder_module p=before status=reorder_status m=CMM$CONFIGURATION_INTERFACE_13D
reorder_module p=before status=reorder_status m=PMM$PROGRAM_SERVICES
reorder_module p=before status=reorder_status m=JMM$PROGRAM_LEVEL_INTERFACES
reorder_module p=before status=reorder_status m=PMM$SYSTEM_TIME_REQUESTS
*DECK DECK=RAI$REORDER_SYSTEM_CORE_1DD EXPAND=TRUE
IF $variable(reorder_status, declared) <> 'LOCAL' THEN
  create_variable reorder_status k=status
IFEND
reorder_module p=before status=reorder_status m=OSM$SYSTEM_ERROR_PROCESSORS
reorder_module p=before status=reorder_status m=OSM$INTRINSICS
reorder_module p=before status=reorder_status m=MLM$OUTPUT_FLOATING_NUMBER
reorder_module p=before status=reorder_status m=MLM$DOUBLE_POWERS_OF_TEN
reorder_module p=before status=reorder_status m=CYM$STRINGREP
reorder_module p=before status=reorder_status m=CLM$CONVERT_CONSOLE_TO_ASCII
reorder_module p=before status=reorder_status m=PMM$RUNANYWHERE_PRG_SERVICES
reorder_module p=before status=reorder_status m=SYM$ADVISED_MOVE_BYTES
reorder_module p=before status=reorder_status m=PMM$GET_UNIQUE_NAME
reorder_module p=before status=reorder_status m=OSM$UNIQUE_NAME_MANAGEMENT
reorder_module p=before status=reorder_status m=SYM$MISC_SERVICES_1FF
reorder_module p=before status=reorder_status m=CLM$CONVERT_INTEGER_TO_STRING
reorder_module p=before status=reorder_status m=MMM$MEMORY_MGR_REQUEST_PROCS
reorder_module p=before status=reorder_status m=OSM$SET_STATUS_ABNORMAL
*DECK DECK=RAI$SYSTEM_DEADSTART_PROLOG EXPAND=TRUE

PROC system_deadstart_prolog, sysdp ()

  TASK ring=11

    create_variable cmv$ask_for_first_intervention k=boolean
    create_variable cmv$ask_for_second_intervention k=boolean
    create_variable cmv$choice k=string
    create_variable cmv$configuration_activated k=boolean scope=xref
    create_variable cmv$copy_status k=status
    create_variable cmv$device_file_copy_status k=status scope=xref
    create_variable cmv$include_status k=status
    create_variable cmv$installation k=(string $max_name) value='INSTALL'
    create_variable cmv$intervene k=boolean
    create_variable cmv$lcu_status k=status
    create_variable cmv$pcu_intervention_occurred k=boolean value=false
    create_variable cmv$pcu_status k=status
    create_variable cmv$prolog_installed k=status ..
          value=$status(false, 'CM', 9999, 'Prolog Found')
    create_variable cmv$prolog_path k=(string 256) ..
          value='$user.configuration_prologs' scope=job
    create_variable cmv$prompt k=(string 80) scope=xdcl
    create_variable cmv$sdp_ignore_status k=status
    create_variable cmv$status k=status
    create_variable osv$configuration_prolog_name k=(string $max_name) ..
          scope=xref
    create_variable osv$deadstart_phase k=(string $max_name) scope=xref
    create_variable osv$operator_intervention k=boolean scope=xref
    create_variable osv$reinitialize_system_device k=boolean scope=xref

    prolog_lfn = $unique

    cmf$prompt_for_answer = '$local.' // $unique

COLLECT_TEXT $fname(cmf$prompt_for_answer)
*copy raf$prompt_for_answer
**

COLLECT_TEXT $local.create_prolog_file
*copy rai$create_prolog_file
**

    WHEN any_fault interrupt DO
COLLECT_TEXT $output sm='?'

 The following error was detected in command: ?osv$command_name?
**
      display_value osv$status o=$output
      CONTINUE
    WHENEND

"
" BEGIN: System Deadstart Prolog
"

"---------------------------------------------------------------------------
"NOTE ON STYLE:

" It is not possible to have an SCL conditional statement span two SCL
"blocks."
" For example:
"    execute_task sp=lcu
"    IF TRUE THEN
"      quit
"    IFEND
"----------------------------------------------------------------------
    IF osv$deadstart_phase = cmv$installation THEN

"
"   EXECUTE INSTALLATION DEADSTART COMMANDS
"

      IF $file($local.installation_deadstart_commands, opened) THEN

        display_value ' Executing installation deadstart commands.' ..
              o=$output status=cmv$sdp_ignore_status

        include_file $local.installation_deadstart_commands ..
              status=cmv$include_status
        IF NOT cmv$include_status.normal THEN
COLLECT_TEXT $output
 The following error was detected when including the commands from
 the file: $local.installation_deadstart_commands:

**
          display_value cmv$include_status o=$output
          wait 4000 "delay so status may be read"
        IFEND
      IFEND

"
"   INSTALL CONFIGURATION PROLOG SUBCATALOG
"
      IF $file($local.prolog_file, opened) THEN

        create_catalog $fname(cmv$prolog_path) status=cmv$sdp_ignore_status

        include_file $local.prolog_file status=cmv$include_status
        IF NOT cmv$include_status.normal AND ..
              NOT ..
              (cmv$include_status.condition = cmv$prolog_installed.condition..
              ) THEN
COLLECT_TEXT $output
 The following error was detected when including the commands from
 the file: $local.prolog_file:

**
          display_value cmv$include_status o=$output
          wait 4000 "delay so status may be read"
        IFEND
      IFEND
      IF osv$configuration_prolog_name <> '' THEN
        cmv$pcu_prolog_name = cmv$prolog_path // '.' // ..
              osv$configuration_prolog_name // '.PCU_SUBCOMMANDS'
        cmv$lcu_prolog_name = cmv$prolog_path // '.' // ..
              osv$configuration_prolog_name // '.LCU_MAINFRAME_SUBCOMMANDS'
      ELSE "Use mainframe name as default prolog subcatalog"
        cmv$pcu_prolog_name = cmv$prolog_path // '.' // $mainframe(..
              identifier) // '.PCU_SUBCOMMANDS'
        cmv$lcu_prolog_name = cmv$prolog_path // '.' // $mainframe(..
              identifier) // '.LCU_MAINFRAME_SUBCOMMANDS'
      IFEND
    IFEND

"
" INSTALL and ACTIVATE the PHYSICAL CONFIGURATION."
"

"
" DETERMINE NEED FOR OPERATOR INTERVENTION
"
"     Installation Deadstart:
"        a. Unconfigured deadstart file, if desired.
"        b. Error in configuration prolog.
"     Continuation Deadstart:
"        a. The installed physical configuration
"           could not be copied from its device file.
"     Any Deadstart:
"        a. Operator intervention requested.
"
    cmv$intervene = false
    IF osv$deadstart_phase = cmv$installation THEN
      change_file_attribute $local.physical_configuration ra=(11, 11, 11) ..
            status=cmv$sdp_ignore_status
      IF $file($local.physical_configuration, opened) AND ..
            ($file($local.physical_configuration, size) = 0) THEN
        copy_file $local.cmf$default_configuration ..
              $local.physical_configuration status=cmv$sdp_ignore_status
COLLECT_TEXT $output

 This is an unconfigured, installation deadstart.
 If you answer 'NO' to the question below you will
 only have one disk and one tape storage device.

 Do you want to change the mainframe's physical configuration?
**
        cmv$prompt = ''
        include_file $fname(cmf$prompt_for_answer)
        IF cmv$intervene THEN
COLLECT_TEXT $output
 ENTERING THE PHYSICAL CONFIGURATION UTILITY ...

 The file $local.physical_configuration has been created for you.
 This file contains the DEFINE_ELEMENT subcommands for the system
 disk subsystem and the tape subsystem used for system installation.
 The element names and serial numbers of these peripherals have been
 invented by NOS/VE; please correct this information now.  The
 following commands are used to correct and install the physical
 configuration:

   EDIT_PHYSICAL_CONFIGURATION
     ADD_ELEMENT_DEFINITION    (for each new peripheral)
     CHANGE_ELEMENT_DEFINITION (to correct serial number)
     CHANGE_ELEMENT_NAME       (to correct element name)
   QUIT
   INSTALL_PHYSICAL_CONFIGURATION
   QUIT
**
        IFEND
      IFEND

      attach_file $fname(cmv$pcu_prolog_name) ..
            local_file_name=$name(prolog_lfn) status=cmv$status
      IF cmv$status.normal AND ($file($fname(prolog_lfn), size) > 0) THEN
        display_value ' Executing '//cmv$pcu_prolog_name o=$output ..
              status=cmv$sdp_ignore_status
        EXECUTE_TASK sp=physical_configuration_utility
          WHEN any_fault interrupt DO
COLLECT_TEXT $output sm='?'

 The following error was detected in command: ?osv$command_name?

**
            display_value osv$status o=$output
            CONTINUE
          WHENEND
          include_file $fname(prolog_lfn) status=cmv$include_status
        QUIT
        IF NOT cmv$include_status.normal THEN
COLLECT_TEXT $output sm='?'

 The following error was detected when executing the prolog file:

 ?cmv$pcu_prolog_name?.

**
          IF NOT cmv$intervene THEN
COLLECT_TEXT $output

 ENTERING THE PHYSICAL CONFIGURATION UTILITY ...

 Use these subcommands to correct and install the physical configuration:

   EDIT_PHYSICAL_CONFIGURATION
     CHANGE_ELEMENT_DEFINITION
   QUIT
   INSTALL_PHYSICAL_CONFIGURATION
   QUIT

 The following error was reported:

**
          IFEND
          display_value (cmv$include_status, ' ') o=$output
          cmv$intervene = true
        IFEND
      ELSE
        IF osv$configuration_prolog_name <> '' THEN
COLLECT_TEXT $output sm='?'

 Prolog file:
     ?cmv$pcu_prolog_name?
 is missing or empty.
**
        IFEND
      IFEND
      detach_file $fname(prolog_lfn) status=cmv$sdp_ignore_status
    ELSEIF (NOT cmv$device_file_copy_status.normal) THEN
      cmv$intervene = true
COLLECT_TEXT $output

 The installed physical configuration cannot be read without error from
 the system device.  You must either manually reinstall the physical
 configuration or you must redeadstart from a deadstart tape containing the
 desired physical configuration.  To do the latter you need to specify the
 following System Core command:

       USE_INSTALLED_CONFIGURATION false.

 It is assumed that you will manually reinstall the physical configuration;
 therefore, you will be entering the Physical Configuration Utility in a
 moment for this purpose.  However, if you have a deadstart tape matching the
 system you have installed, it may well be faster for you to use it as
 indicated above.
**

      wait 10000 "allow operator enough time to read the message"

COLLECT_TEXT $output

 ENTERING THE PHYSICAL CONFIGURATION UTILITY ...

**
    IFEND

    IF (NOT cmv$intervene) AND osv$operator_intervention THEN
COLLECT_TEXT $output

 Do you want to change the mainframe's physical configuration?
**
      cmv$prompt = ''
      include_file $fname(cmf$prompt_for_answer)
      IF cmv$intervene THEN
COLLECT_TEXT $output

 ENTERING THE PHYSICAL CONFIGURATION UTILITY ...

**
      IFEND
    IFEND

"
" ATTEMPT TO INSTALL THE PHYSICAL CONFIGURATION
"
    IF cmv$intervene THEN
      IF osv$deadstart_phase <> cmv$installation THEN
COLLECT_TEXT $output
 This is a continuation deadstart.
 YOU CANNOT REFERENCE PERMANENT FILES.
 YOU ARE RESTRICTED TO USING ONLY PCU SUBCOMMANDS

**
        IF cmv$device_file_copy_status.normal THEN
COLLECT_TEXT $output
 The most recently installed configuration has been copied to
 the file $local.physical_configuration for you.

**
        IFEND
      IFEND
      cmv$pcu_intervention_occurred = true
      EXECUTE_TASK sp=physical_configuration_utility
        WHEN any_fault interrupt DO
COLLECT_TEXT $output sm='?'

 The following error was detected in command: ?osv$command_name?

**
          display_value osv$status o=$output
          CONTINUE
        WHENEND

        include_file command prompt='PCU'
      "$QUIT
    IFEND
"
" ENSURE PHYSICAL CONFIGURATION IS INSTALLED
"
  pcu: ..
    WHILE NOT cmv$configuration_activated DO

      "Automatically install the physical configuration in case the operator"
      "did not ask for intervention or forgot to do it.                     "
      EXECUTE_TASK sp=physical_configuration_utility
        install_physical_configuration status=cmv$status
      QUIT
      IF NOT cmv$status.normal THEN
COLLECT_TEXT $output

 ENTERING THE PHYSICAL CONFIGURATION UTILITY ...

 Use these subcommands to correct and install the physical configuration:

   EDIT_PHYSICAL_CONFIGURATION
     CHANGE_ELEMENT_DEFINITION
   QUIT
   INSTALL_PHYSICAL_CONFIGURATION
   QUIT

 The following error was reported:

**
        display_value (cmv$status, ' ') o=$output

        EXECUTE_TASK sp=physical_configuration_utility
          WHEN any_fault interrupt DO
COLLECT_TEXT $output sm='?'

 The following error was detected in command: ?osv$command_name?

**
            display_value osv$status o=$output
            CONTINUE
          WHENEND
          cmv$pcu_intervention_occurred = true
          include_file command prompt='PCU'
        "$QUIT
      IFEND
    WHILEND pcu


"  BEGIN LCU INTERVENTION PROCESS
"
" Optional operator intervention allowed. Operator is asked if he/she desires
" intervention, if intervention is not forced and either the operator asked
" for operator pause or a PCU intervention occurred.
" IF installation deadstart THEN
"   IF recover system set in effect THEN
"       Suppress prolog execution
"       Activate all available system set members
"   ELSE
"       Execute the LCU_MAINFRAME_SUBCOMMANDS prolog file
"       Volumes are activated as each is initialized and added to a set
"       Operator intervention is forced if there is an error in the prolog
"       The LCU does not activate any volumes implicitly during this phase of
"         deadstart.
"   IFEND
" ELSE {continuation deadstart}
"   Allow first optional intervention before any volumes are activated.
"     This allows a window where existing set members may be reinitialized.
"   The QUIT from the first LCU execution during a continuation deadstart
"     will activate all available volumes in the system set.
"   If the operator requests intervention to initialize volumes, he/she will
"     be prompted again after all volumes are activated to determine whether
"     another intervention is desired.
"   Thus the operator will have zero, one, or two intervention opportunities;
"     The LCU will be executed at least once regardless of whether or not the
"     intervention is requested.
" IFEND

    cmv$intervene = false
    cmv$ask_for_first_intervention = (osv$operator_intervention OR ..
          cmv$pcu_intervention_occurred)
    cmv$ask_for_second_intervention = false

    IF osv$deadstart_phase = cmv$installation AND ..
          NOT osv$reinitialize_system_device THEN

      attach_file $fname(cmv$lcu_prolog_name) ..
            local_file_name=$name(prolog_lfn) status=cmv$status

      IF cmv$status.normal AND ($file($fname(prolog_lfn), size) > 0) THEN
        display_value ' Executing '//cmv$lcu_prolog_name o=$output ..
              status=cmv$sdp_ignore_status
        EXECUTE_TASK sp=logical_configuration_utility status=cmv$lcu_status
          include_line prolog_lfn//' status=cmv$include_status'
        QUIT
        IF NOT cmv$include_status.normal THEN
COLLECT_TEXT $output sm='?'

 The following error was detected when executing the prolog file:

 ?cmv$lcu_prolog_name?.

**
          display_value cmv$include_status o=$output
COLLECT_TEXT $output sm='?'

 You may now correct the problem(s) in the logical configuration
 OR enter QUIT.
**
          cmv$ask_for_first_intervention = false
          cmv$intervene = true
        IFEND "end of prolog execution"
      ELSEIF osv$configuration_prolog_name <> '' THEN
COLLECT_TEXT $output sm='?'

 Prolog file:
     ?cmv$lcu_prolog_name?
 is missing or empty.
**
      IFEND
      detach_file $fname(prolog_lfn) status=cmv$sdp_ignore_status

      IF cmv$ask_for_first_intervention THEN
COLLECT_TEXT $output

 Do you want to change the mainframe's logical configuration?
**
        cmv$prompt = ''
        include_file $fname(cmf$prompt_for_answer)
      IFEND

      IF cmv$intervene THEN
COLLECT_TEXT $output

 ENTERING THE LOGICAL CONFIGURATION UTILITY ...

**
        EXECUTE_TASK sp=logical_configuration_utility status=cmv$lcu_status
          WHEN any_fault interrupt DO
COLLECT_TEXT $output sm='?'

 The following error was detected in command: ?osv$command_name?

**
            display_value osv$status o=$output
            CONTINUE
          WHENEND
          include_file command prompt='LCU'
        "$quit
      IFEND
      WHILE NOT cmv$lcu_status.normal DO
COLLECT_TEXT $output

 ENTERING THE LOGICAL CONFIGURATION UTILITY ...

 The following error was reported by the Logical Configuration Utility;
 you must correct this problem now:

**
        display_value (cmv$lcu_status, ' ') o=$output

        EXECUTE_TASK sp=logical_configuration_utility status=cmv$lcu_status
          WHEN any_fault interrupt DO
COLLECT_TEXT $output sm='?'

 The following error was detected in command: ?osv$command_name?

**
            display_value osv$status o=$output
            CONTINUE
          WHENEND
          include_file command prompt='LCU'
        "$quit

      WHILEND

    ELSE "Continuation Deadstart or Reinitialization of the System Device"
      IF osv$reinitialize_system_device THEN
COLLECT_TEXT $output sm='?'

 Execution of the prolog:
     ?cmv$lcu_prolog_name?
 is suppressed because a system set recovery is in progress.

**
      IFEND

      IF cmv$ask_for_first_intervention THEN

COLLECT_TEXT $output

 Do you want to make any of the following kinds of changes to the
 mainframe's logical configuration?

   - Change the state of an element (CHANGE_ELEMENT_STATE)
   - Initialize a volume            (INITIALIZE_MS_VOLUME)
   - Add a volume to a set          (ADD_VOLUME_TO_SET)
   - Define a mass storage flaw     (DEFINE_MS_FLAW)

**
        cmv$prompt = ''
        include_file $fname(cmf$prompt_for_answer)

        cmv$ask_for_second_intervention = true

        IF cmv$intervene THEN
COLLECT_TEXT $output

 ENTERING THE LOGICAL CONFIGURATION UTILITY ...

 This is a continuation deadstart.
 YOU CANNOT REFERENCE PERMANENT FILES.
 YOU ARE RESTRICTED TO USING ONLY LCU SUBCOMMANDS.

 Only the mass storage classes of the System Device and any volume that
 you initialize or add to a set can be changed or displayed at this time.

**
          EXECUTE_TASK sp=logical_configuration_utility status=cmv$lcu_status
            WHEN any_fault interrupt DO
COLLECT_TEXT $output sm='?'

 The following error was detected in command: ?osv$command_name?

**
              display_value osv$status o=$output
              CONTINUE
            WHENEND
            include_file command prompt='LCU'
          "$quit
        IFEND "end of requested intervention"
      IFEND "end of first opportunity for manual intervention"

      IF NOT cmv$intervene OR NOT cmv$ask_for_first_intervention THEN
        " Ensure all available volumes are activated."
        EXECUTE_TASK sp=logical_configuration_utility status=cmv$lcu_status
        QUIT
      IFEND
      IF cmv$ask_for_second_intervention THEN
COLLECT_TEXT $output

 Do you want to make other changes to the mainframe's logical configuration?
**
        cmv$prompt = ''
        include_file $fname(cmf$prompt_for_answer)
        IF cmv$intervene THEN
COLLECT_TEXT $output

 ENTERING THE LOGICAL CONFIGURATION UTILITY ...

 This is a continuation deadstart.
 YOU CANNOT REFERENCE PERMANENT FILES.
 YOU ARE RESTRICTED TO USING ONLY LCU SUBCOMMANDS.

**
          EXECUTE_TASK sp=logical_configuration_utility status=cmv$lcu_status
            WHEN any_fault interrupt DO
COLLECT_TEXT $output sm='?'

 The following error was detected in command: ?osv$command_name?

**
              display_value osv$status o=$output
              CONTINUE
            WHENEND
            include_file command prompt='LCU'
          "$quit
        IFEND "end of second requested intervention"
      IFEND "end of second opportunity for LCU intervention"

    lcu: ..
      WHILE NOT cmv$lcu_status.normal DO
COLLECT_TEXT $output

 ENTERING THE LOGICAL CONFIGURATION UTILITY ...

 This is a continuation deadstart.
 YOU CANNOT REFERENCE PERMANENT FILES.
 YOU ARE RESTRICTED TO USING ONLY LCU SUBCOMMANDS.

 The following error was reported by the Logical Configuration Utility;
 you must correct this problem now:

**
        display_value (cmv$lcu_status, ' ') o=$output

        EXECUTE_TASK sp=logical_configuration_utility status=cmv$lcu_status
          WHEN any_fault interrupt DO
COLLECT_TEXT $output sm='?'

 The following error was detected in command: ?osv$command_name?

**
            display_value osv$status o=$output
            CONTINUE
          WHENEND
          include_file command prompt='LCU'
        "$quit

      WHILEND lcu
    IFEND "end of all operator intervention opportunities"


    IF osv$configuration_prolog_name = '' THEN
      osv$configuration_prolog_name = $mainframe(identifier)
    IFEND

    delete_file $fname(cmf$prompt_for_answer) status=cmv$sdp_ignore_status
    delete_file $local.cmf$default_configuration status=cmv$sdp_ignore_status
    delete_file $local.create_prolog_file status=cmv$sdp_ignore_status
    delete_file $local.installation_deadstart_commands ..
          status=cmv$sdp_ignore_status
    delete_file $local.physical_configuration status=cmv$sdp_ignore_status
    delete_file $local.prolog_file status=cmv$sdp_ignore_status
  TASKEND

PROCEND system_deadstart_prolog
*DECK DECK=RAI$TESTING_USER_PROLOG EXPAND=FALSE
set_command_list a=($system.osf$site_command_library, $system.scu.command_library) p=after
IF $file($user.prolog, assigned) THEN
  include_file $user.prolog
IFEND
*DECK DECK=RAI$VALIDATE_FAMILY EXPAND=FALSE
PROC validate_family, valf (
  family,           f : name = please_specify
  family_user_administrator, fua: name = please_specify
  password,        pw : name = please_specify
  validate_users,  vu : boolean = false
  user_validation, uv : file = $system.validate_testing_users
  display_values,  dv : boolean = false
  status)

  WHEN any_fault DO
    display_value ('-- Following error occurred in family validation --', osv$status, ..
'-- Enter Continue or Exit_Proc or commands --') output=$output
    include_file command prompt='validate_family error--'
  WHENEND

  create_variable dsv$status kind=status
  create_variable parameters kind=string dimension=4 value=' '
    parameters(1) = 'FAMILY_NAME'
    parameters(2) = 'ADMINISTRATOR_NAME'
    parameters(3) = 'PASSWORD'
    parameters(4) = 'YES_to_validate_users'

  family_name  = $string($value(family))
  administrator_name  = $string($value(family_user_administrator))
  password = $string($value(password))
  yes_to_validate_users=$strrep($value(validate_users))
  user_validation = $string($value(user_validation))
  display_parameters= $value(display_values)
  line=' '
WHILE display_parameters DO
  put_line '1' output=$output
COLLECT_TEXT $output   substitution_mark='&'
--------------------------------------------------
             VALIDATE_FAMILY

    FAMILY_NAME = &family_name&
    ADMINISTRATOR_NAME = &administrator_name&
    PASSWORD = &password&
    VALIDATE_USERS = &yes_to_validate_users&
    USER_VALIDATION = &user_validation&

--------------------------------------------------
**
  put_line (' ', ' ENTER  GO  TO VALIDATE THE ABOVE FAMILY,', ' ENTER  QUIT  TO TERMINATE VALIDATION, ') ..
        output=$output
  put_line (' ENTER  PROMPT  TO ASSIGN NEW VALUES,') output=$output
  accept_line variable=line input=input ..
        prompt='OR ENTER VARIABLE = ''STRING_VALUE'' (AS LISTED ABOVE) - '
  put_line ' ' output=$output
  line = $translate(lower_to_upper, line)
  IF line = 'GO' THEN
    display_parameters=false
    FOR i = 1 to 3 DO
      IF $name(parameters(i)) = 'PLEASE_SPECIFY' THEN
        display_parameters=true
        put_line ($STRREP(' --ERROR-- '//parameters(I)//' NOT SPECIFIED'), ' ') output=$output
        accept_line variable=line input=input prompt=$STRREP('ENTER '//PARAMETERS(I)//'  - ')
        line = $translate(lower_to_upper, line)
        $NAME(parameters(i)) = line
      IFEND
    FOREND
  ELSEIF line = 'QUIT' THEN
    EXIT_PROC
  ELSEIF line = 'PROMPT' THEN
    I=1
    display_parameters=false
    WHILE (I<5) AND (display_parameters=false) DO
      accept_line variable=line input=input ..
            prompt=$STRREP('ENTER '//PARAMETERS(I)//', PROMPT, OR CYCLE - ')
      line = $translate(lower_to_upper, line)
      IF line = 'CYCLE' THEN
        display_parameters=true
      ELSEIF line <> 'PROMPT' THEN
        $NAME(parameters(i)) = line
      IFEND
      I= I + 1
    WHILEND
    IF ($name(yes_to_validate_users)) AND (display_parameters=false) THEN
      REPEAT
        put_line ' VALIDATION FILE MUST BE A PERMANENT FILE: enter CYCLE to use default, ' o=$output
        accept_line variable=line input=input prompt='or enter desired USER_VALIDATION FILENAME - '
        line = $translate(lower_to_upper, line)
      UNTIL (line='CYCLE') OR ($FILE($FNAME(line),permanent))
      IF $file($fname(line), permanent) THEN
        detach_file $fname(line)
        user_validation = line
      IFEND
    IFEND
    display_parameters=true
  ELSEIF $scan_string('=', line) <> 0 THEN
    line = $translate(lower_to_upper, line)
    put_line ' INCLUDING COMMAND *'//line//'*' output=$output
    IF $scan_string('VALIDATE_USERS', line) <> 0 THEN
       yes_to_validate_users = $strrep(($scan_string('YES', LINE) <> 0))
    ELSE
       include_line line
    IFEND
  ELSE
    put_line ' IGNORING COMMAND *'//line//'*' output=$output
    WAIT T=1500
  IFEND
WHILEND "FOR DISPLAY_PARAMETERS = TRUE"

IF (NOT DISPLAY_PARAMETERS) AND ($SPECIFIED(FAMILY)) THEN
  validation_job = family_name// '_validation_job'
  create_family $name(family_name) family_user_administrator=$name(administrator_name)
  change_file_attributes $fname(user_validation) ring_attributes=(3 13 13) status=dsv$status
  detach_file $fname(user_validation) status=dsv$status
"Create the Validation Job to set up validations for the family."
  display_message to=job m='----  Submitting Validation Job for family '//family_name
  JOB sm='&'
    ADMINISTER_VALIDATIONS
      use_validation_file validation_file=$fname(':&family_name&.$SYSTEM.$VALIDATIONS')
      WHEN any_fault DO
        display_value ('The following error occurred in user validation, ..' osv$status) output=$response
        CONTINUE
      WHENEND
      CHANGE_USER &administrator_name&
        change_login_password new_password=&password&
        change_link_attribute_password value='&password&'
        change_user_prolog value='$system.testing_user_prolog'
        change_user_epilog value='$user.epilog'
        change_job_class delete=all add=(batch, maintenance, interactive, file_transfer) batch_default=batch ..
              interactive_default=interactive
        change_capability delete=all
        change_capability add=family_administration
        change_capability add=system_administration
        change_capability add=network_application_management
        change_capability add=network_operation
        change_capability add=station_operation
        change_capability add=timesharing
        change_capability add=explicit_remote_file
        change_capability add=implicit_remote_file
      END_CHANGE_USER
      attach_file &user_validation& lfn=validate_users wait=yes
      attach_file $system.validate_user
      validate_users family=&family_name&
    END_ADMINISTER_VALIDATIONS
    terminate_print name=output
  JOBEND
IFEND

PROCEND validate_family
*DECK DECK=RAI$VALIDATE_USER EXPAND=FALSE
PROC validate_user, valu (
  user, u                             : name = $required
  password, pw                        : name = $required
  project, p                          : list 2 of name = (account, project)
  user_prolog, up                     : string = '$system.testing_user_prolog'
  user_epilog, ue                     : string = '$user.epilog'
  job_classes, job_class, jc          : list of key batch, b, interactive, i, maintenance, m, ..
                                            file_transfer, ft = (b, i, file_transfer)
  minimum_ring, mr                    : integer 1..15 = 11
  nominal_ring, nr                    : integer 1..15 = 11
  explicit_remote_file, erf           : boolean = true
  hpa_ve_initiator, hvi               : boolean = true
  implicit_remote_file, irf           : boolean = true
  network_application_management, nam : boolean = true
  network_operation, no               : boolean = true
  station_operation, so               : boolean = true
  timesharing, t                      : boolean = true
  status                              : var of status = $optional
  )

  create_variable name=create_status kind=status

  CREATE_USER user=$value(user)
  create: ..
    BLOCK
      change_login_password new_password=$value(password) status=create_status
      EXIT create WHEN NOT create_status.normal
      change_link_attribute_password value=$string($value(password)) status=create_status
      EXIT create WHEN NOT create_status.normal
      change_default_account_project account=$value(project 1) project=$value(project 2) status=create_status
      EXIT create WHEN NOT create_status.normal
      change_user_prolog value=$value(user_prolog) status=create_status
      EXIT create WHEN NOT create_status.normal
      change_user_epilog value=$value(user_epilog) status=create_status
      EXIT create WHEN NOT create_status.normal
      change_job_class delete=all interactive_default=none batch_default=none status=create_status
      EXIT create WHEN NOT create_status.normal
      FOR i = 1 TO $set_count(job_classes) DO
        IF ($string($value(job_classes, i)) = 'BATCH') OR ..
              ($string($value(job_classes, i)) = 'B') THEN
          change_job_class add=batch batch_default=batch status=create_status
        ELSEIF ($string($value(job_classes, i)) = 'INTERACTIVE') OR ..
              ($string($value(job_classes, i)) = 'I') THEN
          change_job_class add=interactive interactive_default=interactive status=create_status
        ELSEIF ($string($value(job_classes, i)) = 'MAINTENANCE') OR ..
              ($string($value(job_classes, i)) = 'M') THEN
          change_job_class add=maintenance status=create_status
        ELSEIF ($string($value(job_classes, i)) = 'FILE_TRANSFER') OR ..
              ($string($value(job_classes, i)) = 'FT') THEN
          change_job_class add=file_transfer status=create_status
        IFEND
        EXIT create WHEN NOT create_status.normal
      FOREND
      change_ring_privilege minimum_ring=$value(minimum_ring) nominal_ring=$value(nominal_ring) ..
            status=create_status
      change_capability delete=all status=create_status
      EXIT create WHEN NOT create_status.normal
      IF $value(explicit_remote_file) THEN
        change_capability add=explicit_remote_file status=create_status
        EXIT create WHEN NOT create_status.normal
      IFEND
      IF $value(implicit_remote_file) THEN
        change_capability add=implicit_remote_file status=create_status
        EXIT create WHEN NOT create_status.normal
      IFEND
      IF $value(network_application_management) THEN
        change_capability add=network_application_management status=create_status
        EXIT create WHEN NOT create_status.normal
      IFEND
      IF $value(network_operation) THEN
        change_capability add=network_operation status=create_status
        EXIT create WHEN NOT create_status.normal
      IFEND
      IF $value(station_operation) THEN
        change_capability add=station_operation status=create_status
        EXIT create WHEN NOT create_status.normal
      IFEND
      IF $value(timesharing) THEN
        change_capability add=timesharing status=create_status
        EXIT create WHEN NOT create_status.normal
      IFEND
    BLOCKEND create
  END_CREATE_USER
  IF NOT create_status.normal THEN
    delete_user user=$value(user)
  IFEND
  EXIT_PROC WITH create_status

PROCEND validate_user
*DECK DECK=RAM$$FILE_LIST EXPAND=TRUE
    function  $file_list (
      input_file_list : any of key all, ..
                               keyend, ..
                               list of file, ..
                         anyend = $required)

    var
      output_file_list : list of file
    varend

   "construct output file list from input list

   if $generic_type(input_file_list) = 'list' then
     for each fl_file in input_file_list do

    "add contents of this catalog to the file list

    if $file(fl_file,catalog) then
      output_file_list = $join(output_file_list,$catalog_contents(fl_file ..
        if,p))

   "add this file to the file list
    else

      output_file_list = $join(output_file_list,fl_file)
    ifend
   forend

  "construct output file list from working catalog

   else
     output_file_list=$catalog_contents($working_catalog,if,p)
   ifend
disv output_file_list do=ds
  exit with output_file_list

  funcend $file_list
*DECK DECK=RAM$ACCEPT_NTF_MESSAGES EXPAND=TRUE
PROC accept_ntf_messages accnm (
  control_facility_name, cfn : name = $required
  output, o : file = $output
  task_name, tn : name = $optional
  status)

  if $specified(task_name) then
    task_name = $string($value(task_name))
  else
    task_name = $string($value(control_facility_name))
  ifend

  create_variable ntf_library k=string v='$system.network_transfer_facility.bound_product'
  create_variable scf_library k=string v='$system.batch_device_support.osf$batch_device_support'
  execute_task task_name=$name(task_name) ..
        starting_procedure=nfp$accept_ntf_messages ..
        libraries=($fname(ntf_library),$fname(scf_library)) ..
        parameters='CFN='//$string($value(cfn))//' O='//$string($value(o))

PROCEND accept_ntf_messages
*DECK DECK=RAM$ACCESS_DIRECTORY_FOR_READ EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$ACCESS_DIRECTORY_FOR_READ Interface.' ??
MODULE ram$access_directory_for_read;

{ PURPOSE:
{   This module contains the interface that opens the IDB Directory and
{   returns a record of pointers to the major components of the directory.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$install_software_cc
*copyc rac$idb_directory_name
*copyc fst$path
*copyc rat$idb_directory_pointers
*copyc rat$path
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
*copyc rap$establish_directory_ptrs
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$access_directory_for_read', EJECT ??

{ PURPOSE:
{   This interface opens the IDB Directory file and returns a record of
{   pointers to the caller.
{
{ DESIGN:
{   The path to the installation database catalog that contains the
{   directory is passed in.  The IDB Directory file is opened as a segment
{   access file for read only.  The directory's major components are
{   accessed and the file is verified as a directory.  The pointers to
{   the major components are returned in a record.
{
{   The calling sequence is responsible for closing the file.
{
{ NOTES:
{   The parameter INSTALLATION_DATABASE on the RAP$GET_DIRECTORY_POINTERS
{   is used only in error message templates.
{


  PROCEDURE [XDCL] rap$access_directory_for_read
    (    installation_database: rat$path;
     VAR directory_pointers: rat$idb_directory_pointers;
     VAR directory_fid: amt$file_identifier;
     VAR file_opened: boolean;
     VAR status: ost$status);


    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      directory: rat$path,
      ignore_status: ost$status,
      local_status: ost$status,
      segment_pointer: amt$segment_pointer;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to close the IDB directory
{   file when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (directory_fid, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_options [1].share_modes.selector := fsc$determine_from_access_modes;
    attachment_options [2].selector := fsc$create_file;
    attachment_options [2].create_file := FALSE;
    attachment_options [3].selector := fsc$wait_for_attachment;
    attachment_options [3].wait_for_attachment.wait := osc$wait;
    attachment_options [3].wait_for_attachment.wait_time := fsc$longest_wait_time;

{ Assemble the path to the IDB Directory using the installation database path
{ and the directory name.

    STRINGREP (directory.path, directory.size, installation_database.path (1, installation_database.size),
          '.', rac$idb_directory_name);

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      file_opened := TRUE;
      fsp$open_file (directory.path (1, directory.size), amc$segment, ^attachment_options, NIL, NIL, NIL, NIL,
            directory_fid, status);
      IF NOT status.normal THEN
        file_opened := FALSE;
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (directory_fid, amc$sequence_pointer, segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      directory_pointers.sequence_p := segment_pointer.sequence_pointer;

      rap$establish_directory_ptrs (installation_database, directory_pointers, status);

    END /main/;

    IF (file_opened) AND (NOT status.normal) THEN
      fsp$close_file (directory_fid, ignore_status);
      file_opened := FALSE;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$access_directory_for_read;

MODEND ram$access_directory_for_read;

*DECK DECK=RAM$ACCESS_DIRECTORY_FOR_WRITE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$ACCESS_DIRECTORY_FOR_WRITE Interface.' ??
MODULE ram$access_directory_for_write;

{ PURPOSE:
{   This module contains the interface that access the IDB Directory for
{   write.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$idb_directory_level
*copyc rac$idb_directory_name
*copyc rac$inss_processor_version
*copyc rae$install_software_cc
*copyc rat$idb_directory_pointers
*copyc rat$path
*copyc rat$sequence_descriptor_types
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc clp$include_line
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pmp$get_compact_date_time

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$access_directory_for_write', EJECT ??

{ PURPOSE:
{   This interface access the IDB Directory for write mode.  If the
{   directory file does not already exist it will be created and
{   initialized.  A segment pointer and the file identifier are returned,
{   along with a boolean that specifies file open.
{
{ DESIGN:
{   The initializing of the directory involves creating the sequence
{   descriptor and directory header.
{
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$access_directory_for_write
    (    installation_database: rat$path;
     VAR directory_segment_pointer: amt$segment_pointer;
     VAR directory_fid: amt$file_identifier;
     VAR directory_file_opened: boolean;
     VAR status: ost$status);


    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      command_line: string (800),
      command_length: integer,
      directory: rat$path,
      directory_pointers: rat$idb_directory_pointers,
      existing_file: boolean,
      ignore_attributes: array [1 .. 1] of amt$get_item,
      ignore_contains_data: boolean,
      ignore_status: ost$status,
      initialize_directory: boolean,
      length: integer,
      local_file: boolean,
      local_status: ost$status;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to close the IDB directory
{   when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (directory_fid, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options
          [fsc$read, fsc$shorten, fsc$append, fsc$modify];
    attachment_options [1].share_modes.selector := fsc$determine_from_access_modes;
    attachment_options [2].selector := fsc$create_file;
    attachment_options [2].create_file := TRUE;
    attachment_options [3].selector := fsc$wait_for_attachment;
    attachment_options [3].wait_for_attachment.wait := osc$wait;
    attachment_options [3].wait_for_attachment.wait_time := fsc$longest_wait_time;

    { Assemble the path to the IDB Directory using the installation database path and the directory name.

    STRINGREP (directory.path, directory.size, installation_database.path (1, installation_database.size),
          '.', rac$idb_directory_name);

    { If the IDB directory does not exist it will be created and initialized.

    ignore_attributes [1].key := amc$file_length;

    amp$get_file_attributes (directory.path (1, directory.size), ignore_attributes, local_file, existing_file,
          ignore_contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    initialize_directory := NOT (local_file OR existing_file);

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      directory_file_opened := TRUE;
      fsp$open_file (directory.path (1, directory.size), amc$segment, ^attachment_options, NIL, NIL, NIL, NIL,
            directory_fid, status);
      IF NOT status.normal THEN
        directory_file_opened := FALSE;
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (directory_fid, amc$sequence_pointer, directory_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF initialize_directory THEN
        directory_pointers.sequence_p := directory_segment_pointer.sequence_pointer;

        RESET directory_pointers.sequence_p;
        NEXT directory_pointers.sequence_descriptor_p IN directory_pointers.sequence_p;
        IF directory_pointers.sequence_descriptor_p = NIL THEN
          osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'IDB DIRECTORY', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'SEQUENCE DESCRIPTOR', status);
          EXIT /main/;
        IFEND;

        pmp$get_compact_date_time (directory_pointers.sequence_descriptor_p^.sequence_creation_date_time,
              status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        directory_pointers.sequence_descriptor_p^.processor_version := rac$inss_processor_version;
        directory_pointers.sequence_descriptor_p^.sequence_type := rac$idb_directory_sequence;
        directory_pointers.sequence_descriptor_p^.sequence_level := rac$idb_directory_level;

        NEXT directory_pointers.header_p IN directory_pointers.sequence_p;
        IF directory_pointers.header_p = NIL THEN
          osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'IDB DIRECTORY', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'HEADER', status);
          EXIT /main/;
        IFEND;

        directory_pointers.header_p^.deferred_count := 0;
        directory_pointers.header_p^.directory_size := 0;

        NEXT directory_pointers.directory_p: [1 .. 1] IN directory_pointers.sequence_p;
        IF directory_pointers.directory_p = NIL THEN
          osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'IDB directory', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'DIRECTORY', status);
          EXIT /main/;
        IFEND;

        directory_pointers.header_p^.directory_rel_p := #REL (directory_pointers.directory_p,
              directory_pointers.sequence_p^);

        directory_segment_pointer.sequence_pointer := directory_pointers.sequence_p;
        amp$set_segment_eoi (directory_fid, directory_segment_pointer, status);

      IFEND;

    END /main/;

    IF directory_file_opened AND (NOT status.normal) THEN
      fsp$close_file (directory_fid, ignore_status);
    IFEND;

    IF (NOT status.normal) AND initialize_directory THEN

      { Delete the IDB Directory file with ignore status.

      STRINGREP (command_line, command_length, '$system.delete_file f=', directory.path (1, directory.size));
      clp$include_line (command_line (1, command_length), TRUE, osc$null_name, ignore_status);

    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$access_directory_for_write;
MODEND ram$access_directory_for_write;
*DECK DECK=RAM$ACTIVATE_5744_APPLICATION EXPAND=TRUE
PROCEDURE activate_cartridge_library, actcl (
  job_class, jc: name = system
  job_termination_interval, jti: time_increment = 00:02:00
  client_create_timeout, cct: integer = 10
  client_send_timeout, cst: integer = 10
  server_select_timeout, sst: integer = 35
  debug_mode, dm: (HIDDEN) boolean = FALSE
  status)

  VAR
    application_job_name: name
    portmap_job_name: name = $name('PORTMAP'//$mainframe(id))
    selected_jobs: list 0..$max_list of name
    select_status: status
  VAREND

  IF ($job(lu) <> $name($system)) OR ($family <> :$system) THEN
    display_value '--ERROR-- ACTivate_Cartridge_Library must be invoked from the system job.'
    display_value '--ERROR-- ACTivate_Cartridge_Library must be invoked from the system job.' ..
          o=$job_log
    EXIT activate_cartridge_library
  IFEND

  application_job_name = $name('$5744_interface_'//$substring($mainframe(id),9,9))
  manage_jobs
    select_job ..
         login_family=$system login_user=$system name=application_job_name ..
         job_selection_list=selected_jobs status=select_status
    qui
  IF NOT select_status.normal THEN
    EXIT activate_cartridge_library with select_status
  IFEND

  IF $size(selected_jobs)=0 THEN
    manage_jobs
      select_job ..
           login_user=$system login_family=$system name=portmap_job_name job_state=initiated ..
           job_selection_list=selected_jobs
      qui
    IF NOT select_status.normal THEN
      EXIT activate_cartridge_library with select_status
    IFEND

    IF $size(selected_jobs)=0 THEN
        put_line ('  ', ..
          ' --ERROR-- Unable to activate $5744_interface_job: PORTMAP is not active.', ..
          ' Use the ACTIVATE_PORTMAP command to start PORTMAP.') ..
          o=$response

    ELSE
      JOB job_recovery_disposition=terminate ..
          output_disposition=$system.cartridge_system_5744.$5744_interface_job_log.$next ..
          substitution_mark='?' ..
          job_execution_ring=6 ..
          job_class=job_class ..
          job_name=application_job_name

"       tcv$clnt_create_timeout_seconds is a value in seconds for an RPC clntudp_create
"         to wait for a reply before declaring a timeout.
"       tcv$clnt_call_timeout_seconds is a value in seconds for an RPC clnt_call
"         to wait for a reply before declaring a timeout.
"       tcv$debug_mode enables logging of debug messages in $local.$5744_debug_file
"         if it set to TRUE
"       tcv$job_termination_interval allows this job to be terminated from the input queue
"         before it restarts itself after a previous termination.
"       tcv$srv_select_timeout_seconds is a value in seconds for a server to
"         timeout a network file if response from workstation does not arrive.

        VAR
          tcv$clnt_create_timeout_seconds: (job) integer=?$string(client_create_timeout)?
          tcv$clnt_call_timeout_seconds: (job) integer=?$string(client_send_timeout)?
          tcv$debug_mode: (job) boolean=?$string(debug_mode)?
          tcv$job_termination_interval: (job) time_increment=?$string(job_termination_interval)?
          tcv$srv_select_timeout_seconds: (job) integer=?$string(server_select_timeout)?
        VAREND

        VAR
          nfv$socket_status: (job) status
        VAREND

        set_working_catalog $system
        create_command_list_entry $system.cartridge_system_5744.server
        cartridge_library_interface ?$string(job_class)? ?$string(application_job_name)?
      JOBEND
    IFEND

  ELSE
    display_value '--ERROR-- $5744_interface_job is already executing!'
  IFEND
PROCEND activate_cartridge_library
*DECK DECK=RAM$ACTIVATE_DRJE EXPAND=TRUE
PROCEDURE activate_drje (
  control_facility_name, cfn: name = station_controller_1
  job_class, jc: name = batch
  notify_after_aborting, naa: boolean = TRUE
  print_listing_after_aborting, plaa: boolean = TRUE
  status)

" Define constants local to this activation procedure.

  "$FORMAT=OFF"
  VAR
    drje_product_catalog: (READ) file = $system.network_transfer_facility.dynamic_remote_job_entry
  VAREND

  VAR
    drje_abort_file: (READ) file = drje_product_catalog.abort_file
    drje_job_log: (READ) file = drje_product_catalog.drje_job_log
    drje_message_template_library: (READ) file = $system.osf$site_command_library
    drje_product_library: (READ) file = drje_product_catalog.drje_library
  VAREND
  "$FORMAT=ON"

" Declare variables local to this activation procedure.

  "$FORMAT=OFF"
  VAR
    local_status: status
  VAREND
  "$FORMAT=ON"

" Verify the procedure has been called by a system operator job.

  IF NOT $job_validation(system_operation) THEN
    EXIT procedure WITH $status(false, 'RA', 0, 'DRJE/VE can only be activated by a system operator.')
  IFEND

" Verify DRJE is installed.

  IF (NOT $first($file_attributes(drje_product_library, registered)).registered) THEN
    EXIT procedure WITH $status(false, 'RA', 0, 'The DRJE/VE product is not installed.')
  IFEND

" Check for the presence of an existing DRJE job.

  MANAGE_JOBS
    select_job name=$dynamic_remote_job_entry job_state=(deferred, queued, initiated) ..
          user_information='DRJE@'//control_facility_name status=local_status
    IF local_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        EXIT procedure WITH $status(false, 'NF', nfe$drje_already_active, control_facility_name)
      IFEND
    ELSE
      EXIT procedure WITH local_status
    IFEND
  QUIT

" Delete any existing cycles of the DRJE abort file.

  REPEAT
    delete_file file=drje_abort_file status=local_status
  UNTIL NOT local_status.normal

" Generate the DRJE abort file.

  TASK ring=11
COLLECT_TEXT output=drje_abort_file until='*** END_ABORT_COMMANDS ***' substitution_mark='?' ..
          status=local_status

  VAR
    dump_file: file
  VAREND

    dump_file = $fname('?drje_product_catalog?.drje_dump_'//$date('Y2M2D2')//'_'//$time('H24MMSS'))

    set_file_attributes file=dump_file fc=list pf=continuous

    put_line line='1***** ABORT DUMP OF DRJE' o=dump_file.$eoi
    put_line line='       '//$date(iso)//' '//$time(millisecond) o=dump_file.$eoi

    put_line line='       '//$job(os_version)//' - '//$default_family//' - CYBER '//..
$processor(model_number, 0)//' Serial '//$processor(serial_number, 0) o=dump_file.$eoi

    put_lines lines=('', ' ***** TRACEBACK:', '') o=dump_file.$eoi
    display_call count=all start=1 display_option=all_calls o=dump_file.$eoi
*** END_ABORT_COMMANDS ***
    IF NOT local_status.normal THEN
      IF local_status.condition = ame$file_not_known THEN

" The DRJE abort file commands could not be generated. Map the abnormal status value AME$FILE_NOT_KNOWN to
" PFE$UNKNOWN_PERMANENT_FILE to provide the caller with a more appropriate error message.

        local_status = $status(false, 'PF', pfe$unknown_permanent_file, $string(drje_abort_file))
      IFEND
      EXIT procedure WITH local_status
    IFEND
  TASKEND

" Submit DRJE job.

  JOB user_job_name=$dynamic_remote_job_entry job_abort_disposition=terminate job_class=job_class ..
        job_recovery_disposition=terminate output_disposition=drje_job_log substitution_mark='?' ..
        user_information='DRJE@'//control_facility_name

    "$FORMAT=OFF"
    VAR
      ignore_status: status
      local_status: status
      nfv$notify_after_aborting: (JOB) boolean = ?notify_after_aborting?
      nfv$print_listing_after_abort: (JOB) boolean = ?print_listing_after_aborting?
    VAREND
    "$FORMAT=ON"

    change_message_level il=full status=ignore_status
    change_working_catalog c=$local

" Capture the job output to the job's job log.

    create_file_connection sf=$output file=$job_log

" Add the CREATE_DEVICE_CONNECTION message templates to the command list.

    create_command_list_entry entry=?drje_message_template_library? placement=after status=local_status
    IF local_status.normal OR (local_status.condition = $status_code(cle$duplicate_command_list_ent)) THEN

" Execute DRJE program.

      "$FORMAT=OFF"
      execute_task parameters='cfn=?control_facility_name?' libraries=(?drje_message_template_library?, ..
            ?drje_product_library?) starting_procedure=nfp$dynamic_remote_job_entry load_map_options=all ..
            preset_value=zero termination_error_level=warning abort_file=?drje_abort_file? debug_mode=false ..
            arithmetic_overflow=true arithmetic_loss_of_significance=true divide_fault=true ..
            exponent_overflow=true exponent_underflow=true fp_indefinite=true fp_loss_of_significance=false ..
            invalid_bdp_data=true status=local_status
      "$FORMAT=ON"

    IFEND
    IF NOT local_status.normal THEN
      display_value v=' ****DRJE/VE aborted with the following status:'
      display_value v=local_status

      IF nfv$print_listing_after_abort THEN
        put_line l=' **************************************************************************' ..
              o=$local.drje_failure_report
        put_line l=' **************************************************************************' ..
              o=$local.drje_failure_report.$eoi
        put_line l=' *                                                                        *' ..
              o=$local.drje_failure_report.$eoi
        put_line l=' *   This job log reflects an abnormal termination of the DYNAMIC REMOTE  *' ..
              o=$local.drje_failure_report.$eoi
        put_line l=' *   JOB ENTRY application.  It should be examined by a site analyst.     *' ..
              o=$local.drje_failure_report.$eoi
        put_line l=' *                                                                        *' ..
              o=$local.drje_failure_report.$eoi
        put_line l=' **************************************************************************' ..
              o=$local.drje_failure_report.$eoi
        put_line l=' **************************************************************************' ..
              o=$local.drje_failure_report.$eoi

        display_log do=all o=$local.drje_failure_report.$eoi

        print_file file=$local.drje_failure_report
      IFEND

      IF nfv$notify_after_aborting THEN
        send_operator_message m='DRJE/VE job failed, See ?drje_job_log?' oc=system_operator
      IFEND
    IFEND
  JOBEND

PROCEND activate_drje
*DECK DECK=RAM$ACTIVATE_FILE_SERVER EXPAND=TRUE
PROC activate_file_server (
  destination_mainframe_is, dmi     : key client, server, loop = $required
  destination_mainframe_id, ..
  dmid                       : name 17 = $required
  number_of_monitor_queue_entries, nomqe : integer 0..126 = 50
  number_of_task_queue_entries, notqe    : integer 1..126 = 4
  number_of_pps, nopp        : key one, dual = dual
  dma                        : boolean = TRUE
  divisions_per_mainframe, ..
  dpm                        : integer 1..16 = 8
  timeout_interval, ti       : integer 1..255 = 10
  maximum_request_timeout_count, ..
  mrtc                       : integer 1..255 = 5
  maximum_retransmission_count, ..
  mrc                        : integer 1..255 = 5
  activate, a                : boolean = FALSE
  data_transfer_size, dts    : key #16K, #32K, #65K, #131K, #262K = #262K
  status                     : var of status = $optional
  )

 " This proc provides the information needed to define the file server
 " connections for the NOS/VE development closed shop mainframes.
 " All connecting mainframes must be defined prior to activating
 " the file server.  This proc is used to define one connection to another
 " mainframe.  The only parameters required are whether the destination
 " mainframe is a client of server, and the mainframe identifier of the
 " destination mainframe.  If this is to be run in 'LOOP' back mode, the
 " destination mainframe should be specified as $SYSTEM_0990_7777

  " ======= BASIC SETUP COMMANDS =========================================
  create_variable test_loopback k=string scope=xdcl
  crev ignore status
  incl 'ved file_server ' status=ignore

  " Determine Dma_available
  dma_value = $value(dma)

  " ===== DEFINE_STORNET_CONNECTION =====================================
  crev stornet_status status
  base_flag = 0
  base_address = 2097152
"  sdp=((ch7, $system_0855_0260, iou0))
  stornet_name = 'stornet260'
  disv ' Defining stornet connection ' o=$response
  define_stornet_connection element_name=$name(stornet_name) memory_size=4194304 memory_base=base_address ..
        flag_base=base_flag half_ecs_switch=no number_of_mainframes=6 ..
        divisions_per_mainframe=$value(divisions_per_mainframe) ..
        data_transfer_size= $value(data_transfer_size) ..
        status=stornet_status

  IF NOT stornet_status.normal THEN
    IF $condition_name(stornet_status.condition) = 'DFE$STORNET_ALREADY_DEFINED' THEN
      disv ' Stornet already defined - Continuing with defining client/server '  o=$response
    ELSE
       disv ' error in define_stornet_connection '    o=$response
       disv stornet_status     o=$response
       disv ' Continuing ------- '    o=$response
    IFEND
  IFEND


  " ==== DETERMINE DESTINATION MAINFRAME =======================
  destination_mainframe_name = $string($value(destination_mainframe_id))

  " Determine served family

  served_family = 'testing'
  IF ($string($value(destination_mainframe_is)) = 'SERVER') THEN
    IF destination_mainframe_name = '$SYSTEM_9323_2001' THEN
      served_family = 'tan'
    ELSEIF destination_mainframe_name = '$SYSTEM_0855_0260' THEN
      served_family = 'yellow'
    ELSEIF destination_mainframe_name = '$SYSTEM_0855_0109' THEN
      served_family = 'green'
    ELSEIF destination_mainframe_name = '$SYSTEM_0830_0631' THEN
      served_family = 'nvedev'
    ELSEIF destination_mainframe_name = '$SYSTEM_0990_0102' THEN
     served_family = 'nve'
    ELSEIF destination_mainframe_name = '$SYSTEM_9603_0102' THEN
     served_family = 'cobalt'
    IFEND
    disv ' Served family :'//served_family o=$response
  IFEND

  " ======== DETERMINE ID AND CHANNELS   =========================
  midn_0855_0260 = 1
  midn_9323_2001 = 2
  midn_0830_0631 = 3
  midn_0855_0109 = 4
  midn_0990_0102 = 5
  midn_9603_0102 = 6
  send_iou = 'IOU0'
  receive_iou = 'IOU0'
  IF $mainframe(id) = '$SYSTEM_0855_0260' THEN
    source_id_number = midn_0855_0260
    send_channel = 'CH2'
    receive_channel = 'CH2'
    accessed_family = 'yellow'
  ELSEIF $mainframe(id) = '$SYSTEM_9323_2001' THEN
    source_id_number = midn_9323_2001
    send_channel = 'CH2'
    receive_channel = send_channel
    accessed_family = 'tan'
  ELSEIF $mainframe(id) = '$SYSTEM_0830_0631' THEN
    source_id_number = midn_0830_0631
    send_channel = 'CH23'
    receive_channel = send_channel
    accessed_family = 'nvedev'
  ELSEIF $mainframe(id) = '$SYSTEM_0990_0102' THEN
    source_id_number = midn_0990_0102
    send_channel = 'CCH7'
    send_iou = 'IOU1'
    IF $STRING($value(number_of_pps)) = 'DUAL' THEN
      receive_channel = 'CCH1'
    ELSE " use one channel
      receive_channel = send_channel
    IFEND
    accessed_family = 'nve'
  ELSEIF $mainframe(id) = '$SYSTEM_0855_0109' THEN
    source_id_number = midn_0855_0109
    send_channel = 'CCH3'
    IF $STRING($value(number_of_pps)) = 'DUAL' THEN
      receive_channel = 'CCH5'
    ELSE " use one channel
      receive_channel = send_channel
    IFEND
    accessed_family = 'green'
  ELSEIF $mainframe(id) =  '$SYSTEM_9603_0102' THEN
    source_id_number = midn_9603_0102
    send_channel = 'CCH3'
    receive_channel = send_channel
    accessed_family = 'cobalt'
  IFEND

  IF destination_mainframe_name = '$SYSTEM_0855_0260' THEN
    destination_id_number = midn_0855_0260
  ELSEIF destination_mainframe_name = '$SYSTEM_9323_2001' THEN
    destination_id_number = midn_9323_2001
  ELSEIF destination_mainframe_name = '$SYSTEM_0830_0631' THEN
    destination_id_number = midn_0830_0631
  ELSEIF destination_mainframe_name = '$SYSTEM_0855_0109' THEN
    destination_id_number = midn_0855_0109
  ELSEIF destination_mainframe_name = '$SYSTEM_0990_0102' THEN
   destination_id_number = midn_0990_0102
  ELSEIF destination_mainframe_name = '$SYSTEM_9603_0102' THEN
   destination_id_number = midn_9603_0102
  IFEND

  IF $string($value(destination_mainframe_is)) = 'LOOP' THEN
    "NOTE: SERVER mainframe name is hard coded in the
    "cybil deck dfc$loopback_server_mainframe
    destination_mainframe_name = '$SYSTEM_0990_7777'
  IFEND


  " ======== DEFINE CLIENT OR SERVER AS NEEDED ==================
  IF ($string($value(destination_mainframe_is)) = 'SERVER') THEN
    disv ' Defining server '//destination_mainframe_name  o=$response
    define_server  ..
          server_mainframe_identifier= $name(destination_mainframe_name) ..
          client_id_number= source_id_number ..
          server_id_number= destination_id_number ..
          number_of_monitor_queue_entries= $value(nomqe) ..
          number_of_task_queue_entries= $value(notqe) ..
          connection_type= stornet ..
          element_name=$name(stornet_name) ..
          send_channel= ($name(send_channel), $name(send_iou)) ..
          receive_channel= ($name(receive_channel), $name(receive_iou)) ..
          dma_available= dma_value ..
          timeout_interval= $value(ti) ..
          maximum_request_timeout_count= $value(mrtc) ..
          maximum_retransmission_count= $value(mrc) ..
          users_wait_on_terminated= false

    IF $value(activate) THEN
      disv ' Activating server '//destination_mainframe_name  o=$response
      activate_server $name(destination_mainframe_name)
    IFEND
  IFEND

  IF ($string($value(destination_mainframe_is)) = 'CLIENT') THEN
    disv ' Defining client '//destination_mainframe_name o=$response
    define_client client_mainframe_identifier= $name(destination_mainframe_name) ..
          client_id_number= destination_id_number ..
          server_id_number= source_id_number ..
          number_of_monitor_queue_entries= $value(nomqe) ..
          number_of_task_queue_entries= $value(notqe) ..
          connection_type= stornet ..
          element_name=$name(stornet_name) ..
          send_channel= ($name(send_channel), $name(send_iou)) ..
          receive_channel= ($name(receive_channel), $name(receive_iou)) ..
          dma_available= dma_value
    IF $value(activate) THEN
      disv ' Activating client '//destination_mainframe_name o=$response
      activate_client $name(destination_mainframe_name)
    IFEND
  IFEND

  IF ($string($value(destination_mainframe_is)) = 'LOOP') THEN
    change_client_access client_mainframe_identifier=$name($mainframe(id)) ..
          family=$name(accessed_family) family_access=login
    disv ' Defining client '//$mainframe(id)  o=$response
    define_client client_mainframe_identifier= $name($mainframe(id)) ..
          client_id_number= source_id_number ..
          server_id_number= source_id_number ..
          number_of_monitor_queue_entries= $value(nomqe) ..
          number_of_task_queue_entries= $value(notqe) ..
          connection_type= stornet ..
          element_name=$name(stornet_name) ..
          send_channel= ($name(send_channel), $name(send_iou)) ..
          receive_channel= ($name(receive_channel), $name(receive_iou)) ..
          dma_available= dma_value

    disv ' Defining server '//destination_mainframe_name o=$response
    define_server family= ($name(served_family)) ..
          server_mainframe_identifier= $name(destination_mainframe_name) ..
          client_id_number= source_id_number ..
          server_id_number= source_id_number  ..
          number_of_monitor_queue_entries= $value(nomqe) ..
          number_of_task_queue_entries= $value(notqe) ..
          connection_type= stornet ..
          element_name=$name(stornet_name) ..
          send_channel= ($name(send_channel), $name(send_iou)) ..
          receive_channel= ($name(receive_channel), $name(receive_iou)) ..
          dma_available= dma_value ..
          timeout_interval= $value(ti) ..
          maximum_request_timeout_count= $value(mrtc) ..
          maximum_retransmission_count= $value(mrc) ..
          users_wait_on_terminated= false

    IF $value(activate) THEN
      disv ' Activating client '//$mainframe(id) o=$response
      activate_client $name($mainframe(id))

      disv ' Activating server '//destination_mainframe_name o=$response
      activate_server $name(destination_mainframe_name)
    IFEND

  IFEND

PROCEND activate_file_server

*DECK DECK=RAM$ACTIVATE_FTAM_RESPONDER EXPAND=TRUE
PROCEDURE activate_ftam_responder, actfr (
  title, t: any of
      string 1..255
      name
    anyend = $required
  supported_users, su: key
      (validated, v)
      (unknown, u)
      (anonymous, a)
    keyend = validated
  transport_selector, ts: integer 1..12335 = 1
  session_selector, ss: string 0..32 = $optional
  presentation_selector, ps: string 0..8 = $optional
  load_map, lm: file = $optional
  log_option, lo: (BY_NAME, ADVANCED) key
      (startup, s)
      (startup_and_execution, sae)
    hidden_key
      (expanded_startup_and_execution, expanded)
    keyend = startup
  maximum_connections, mc: integer 1..4095 = 60
  job_class, jc: name = batch
  virtual_character_sets, vcs: any of
      record
        g0: key
          (iso_646_irv, irv)
          (iso_646_usa, usa, iso_8859_1)
        keyend
        g1: key
          iso_8859_1, none
        keyend = $optional
      recend
      key
        unknown
      keyend
    anyend = (iso_646_irv, iso_8859_1)
  local_character_sets, lcs: (BY_NAME, HIDDEN) record
      g0: key
        (iso_646_irv, irv)
        (iso_646_usa, usa, iso_8859_1)
      keyend
      g1: key
        iso_8859_1, none
      keyend = $optional
    recend = (iso_646_irv, iso_8859_1)
  maximum_restart_attempts, maxra: (BY_NAME, ADVANCED) integer 0..65535 = 0
  notify_after_aborting, naa: (BY_NAME, ADVANCED) boolean = FALSE
  produce_incremental_job_log, pijl: (BY_NAME, ADVANCED) boolean = FALSE
  protocol_trace, pt: (BY_NAME, ADVANCED) boolean = FALSE
  status)

" Define constants local to this activation procedure.

  "$FORMAT=OFF"
  VAR
    ftam_message_template_library: (READ) file = $system.osf$command_library
    ftam_product_library: (READ) file = $system.ftam.bound_product
    generic_transport_library: (READ) file = $system.ftam.osf$gt_interface_library
    legal_hex_characters: (READ) string 22 = '0123456789abcdefABCDEF'
    osiam_binary_log_file: (READ) file = $system.ftam.osiam_binary_log
    responder_abort_file: (READ) file = $system.ftam.responder_abort_file
    responder_debug_mode: (READ) boolean = false
    responder_incremental_job_log: (READ) file = $system.ftam.responder_incremental_job_log
    responder_job_log: (READ) file = $system.ftam.responder_job_log
    responder_startup_commands: (READ) file = $system.ftam.responder_configuration
    responder_user_job_name: (READ) name = $name('FTAM'//$mainframe(id))
    transfer_block_size: (READ) integer 128 .. 102400 = 12288
  VAREND
  "$FORMAT=ON"

" Declare variables local to this activation procedure.

  "$FORMAT=OFF"
  VAR
    editing_directives: file
    ignore_status: status
    load_map_file_value: file
    local_status: status
    osiam_log_level: integer 0 .. 16
    osiam_trace: string $size('on') .. $size('off')
    processed_presentation_selector: string $size('C#') .. ($size('H') + 8 "maximum size for PS")
    processed_session_selector: string $size('C#') .. ($size('H') + 32 "maximum size for SS")
    responder_system_job_name: name
    temp_local_charsets: record
      g0: key
        (iso_646_irv, irv)
        (iso_646_usa, usa, iso_8859_1)
      keyend
      g1: key
        iso_8859_1, none
      keyend = $optional
    recend
    temp_virtual_charsets: any of
      record
        g0: key
          (iso_646_irv, irv)
          (iso_646_usa, usa, iso_8859_1)
        keyend
        g1: key
          iso_8859_1, none
        keyend = $optional
      recend
      key
        unknown
      keyend
    anyend
  VAREND
  "$FORMAT=ON"

" Initialize local variables.

  editing_directives = $unique($local)
  temp_local_charsets = (iso_646_irv, iso_8859_1)
  temp_virtual_charsets = (iso_646_irv, iso_8859_1)

" Verify the procedure has been called by a system operator job.

  IF NOT $job_validation(system_operation) THEN
    EXIT procedure WITH $status(false, 'RA', 0, 'FTAM/VE can only be activated by a system operator.')
  IFEND

" Verify the FTAM/VE product is installed.

  IF (NOT $first($file_attributes(ftam_product_library, registered)).registered) THEN
    EXIT procedure WITH $status(false, 'RA', 0, 'The FTAM/VE product is not installed.')
  IFEND

" Verify the FTAM/VE product has the correct ring attributes.

  IF (($first($file_attributes(ftam_product_library, ring_attributes)).ring_attributes.r1 <> 6) OR ($first(..
        $file_attributes(ftam_product_library, ring_attributes)).ring_attributes.r2 <> 13) OR ($first(..
        $file_attributes(ftam_product_library, ring_attributes)).ring_attributes.r3 <> 13)) THEN
    EXIT procedure WITH $status(false, 'RA', 0, 'The FTAM/VE product has improper ring attributes.')
  IFEND

" Check for the presence of an existing FTAM responder job.

  MANAGE_JOBS
    select_jobs name=responder_user_job_name job_state=(deferred, queued, initiated) status=local_status
    IF local_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        EXIT procedure WITH $status(false, 'RA', 0 ..
              'An identical FTAM job was found. FTAM will not be activated')
      IFEND
    ELSE
      EXIT procedure WITH local_status
    IFEND
  QUIT

" Verify the value specified for TRANSPORT_SELECTOR is within the ranges allowed.

  IF (transport_selector >= 1000) AND (transport_selector <= 3000) THEN
    EXIT procedure WITH $status(false, 'RA', 0, ..
          'The TRANSPORT_SELECTOR value must not be in the range of 1000 through 3000.')
  IFEND

" Verify the values specified for PRESENTATION_SELECTOR and SESSION_SELECTOR contain an appropriate number
" of hexidecmial digits.

  IF $specified(presentation_selector) THEN
    IF ($scan_not_any(legal_hex_characters, presentation_selector) <> 0) THEN
      EXIT procedure WITH $status(false, 'RA', 0, ..
            'Illegal hexidecimal digit found in PRESENTATION_SELECTOR value.')
    ELSEIF ($mod($strlen(presentation_selector), 2) <> 0) THEN
      EXIT procedure WITH $status(false, 'RA', 0, ..
            'The PRESENTATION_SELECTOR value must contain an even number of digits.')
    IFEND

    IF $specified(session_selector) THEN
      IF ($scan_not_any(legal_hex_characters, session_selector) <> 0) THEN
        EXIT procedure WITH $status(false, 'RA', 0, ..
              'Illegal hexidecimal digit found in SESSION_SELECTOR value.')
      ELSEIF ($mod($strlen(session_selector), 2) <> 0) THEN
        EXIT procedure WITH $status(false, 'RA', 0, ..
              'The SESSION_SELECTOR value must contain an even number of digits.')
      ELSE

" The values for PRESENTATION_SELECTOR and SESSION_SELECTOR are syntactically correct.

        IF presentation_selector = '' THEN
          processed_presentation_selector = 'C#'
        ELSE
          processed_presentation_selector = 'H'//presentation_selector
        IFEND

        IF session_selector = '' THEN
          processed_session_selector = 'C#'
        ELSE
          processed_session_selector = 'H'//session_selector
        IFEND

" Generate the editing directives neccessary to customize Presentation and Session selector values in
" the FTAM responder configuration file.

COLLECT_TEXT output=editing_directives until='*** END_EDITING_DIRECTIVES ***' substitution_mark='?' ..
              status=local_status
" Locate and modify the value used to define the Presentation Selector.

 locate_text text='define sap 16' number=1 lines=first..last
 replace_text text='H01' new_text='?processed_presentation_selector?' number=all line=current


" Modify the call to the ATTACH_SERVER command to include a PRESENTATION_SELECTOR parameter specification.

 locate_text text='attach_server' number=1 lines=first..last
 replace_text text='ts=' new_text=' ps=''''?presentation_selector?'''' ts=' number=1 line=current


" Locate and modify the value used to define the Session Selector.

 locate_text text='define sap 21' number=1 lines=first..last
 replace_text text='H01' new_text='?processed_session_selector?' number=all line=current


" Modify the call to the ATTACH_SERVER command to include a SESSION_SELECTOR parameter specification.

 locate_text text='attach_server' number=1 lines=first..last
 replace_text text='ts=' new_text=' ss=''''?session_selector?'''' ts=' line=current

 END "EDIT_FILE" write_file=TRUE
*** END_EDITING_DIRECTIVES ***
        IF NOT local_status.normal THEN

" The editing directives file could not be generated. Map the abnormal status value AME$FILE_NOT_KNOWN to
" PFE$UNKNOWN_PERMANENT_FILE to provide the caller with a more appropriate error message.

          IF local_status.condition = ame$file_not_known THEN
            local_status = $status(false, 'PF', pfe$unknown_permanent_file, $string(editing_directives))
          IFEND
          EXIT procedure WITH local_status
        IFEND

      IFEND

    ELSE " No value was provided for the SESSION_SELECTOR parameter.
      EXIT procedure WITH $status(false, 'RA', 0, ..
            'A SESSION_SELECTOR value is required when PRESENTATION_SELECTOR is specified.')
    IFEND

  ELSE " No value was provided for the PRESENTATION_SELECTOR parameter.

    IF $specified(session_selector) THEN
      EXIT procedure WITH $status(false, 'RA', 0, ..
            'A PRESENTATION_SELECTOR value is required when SESSION_SELECTOR is specified.')
    IFEND
  IFEND

" Assign the load map to a permanent file if requested.

  IF $specified(load_map) THEN
    load_map_file_value = load_map
  ELSE
    load_map_file_value = $null
  IFEND

" Determine the trace level to be used based on the LOG_OPTION parameter. The trace level information is
" recorded in the FTAM responder configuration file. Trace information is written to the OSIAM binary log.

  IF log_option = startup THEN
    osiam_log_level = 0
    osiam_trace = 'off'
  ELSEIF log_option = startup_and_execution THEN
    osiam_log_level = 8
    osiam_trace = 'on'
  ELSEIF log_option = expanded_startup_and_execution THEN
    osiam_log_level = 10
    osiam_trace = 'on'
  IFEND

" Generate the FTAM responder configuration file.

COLLECT_TEXT output=responder_startup_commands until='*** END_RESPONDER_STARTUP ***' substitution_mark='?' ..
        status=local_status

" Set the log level for the OSIAMC, Session, and Generic Transport modules.

 set_trace_options log_level=?osiam_log_level? operator_level=0 job_number=0 task_number=2 module_number=2
 set_trace_options log_level=?osiam_log_level? operator_level=0 job_number=0 task_number=2 module_number=12
 set_trace_options log_level=?osiam_log_level? operator_level=0 job_number=0 task_number=2 module_number=14


" Add suffix processing to the Presentation, Session, and Transport SAPs. Suffix processing must be added
" to the SAPs before their respective entities are started.

 send_command command='define sap 16 21 H01 70 53 28' job_number=0 task_number=2 module_number=2  "Presentation"
 send_command command='define sap 21 17 H01 53 50 8' job_number=0 task_number=2 module_number=2  "Session"
 send_command command='define sap 17 04 C17 50 00 7' job_number=0 task_number=2 module_number=2  "Low Interface"


" Activate the Transport interface. If specified, the values for the SESSION_SELECTOR and PRESENTATION_SELECTOR
" parameters will be added to the ATTACH_SERVER command after the responder configuration is generated.

 send_command command='attach_server s=osa$ftam_server ts=?transport_selector? ..
       mc=?maximum_connections? title=''?title?''' job_number=0 task_number=2 module_number=14

 send_command command='start_transport_interface block_size=?transfer_block_size?' ..
       job_number=0 task_number=2 module_number=14


" Configure the FTAM protocol machine functional unit options to include support for Limited File Management,
" Enhanced File Management, and Grouping.  Explicitly set each bit in flag group one and flag group zero to
" override any default flag values.

" Setting undocumented bit 8, the ninth bit in the flag, also sets bit 0..7 as a side effect.

 send_command command='vary entity 70 flag 1 0 off' job_number=0 task_number=2 module_number=2  "FADU locking"
 send_command command='vary entity 70 flag 1 1 off' job_number=0 task_number=2 module_number=2  "Recovery"
 send_command command='vary entity 70 flag 1 2 off' job_number=0 task_number=2 module_number=2  "Restart Data Transfer"
 send_command command='vary entity 70 flag 1 3 off' job_number=0 task_number=2 module_number=2  "Undocumented"
 send_command command='vary entity 70 flag 1 4 off' job_number=0 task_number=2 module_number=2  "Undocumented"
 send_command command='vary entity 70 flag 1 5 off' job_number=0 task_number=2 module_number=2  "Undocumented"
 send_command command='vary entity 70 flag 1 6 off' job_number=0 task_number=2 module_number=2  "Undocumented"
 send_command command='vary entity 70 flag 1 7 off' job_number=0 task_number=2 module_number=2  "Undocumented"

 send_command command='vary entity 70 flag 0 0 off' job_number=0 task_number=2 module_number=2  "Undocumented"
 send_command command='vary entity 70 flag 0 1 off' job_number=0 task_number=2 module_number=2  "Undocumented"
 send_command command='vary entity 70 flag 0 2 on' job_number=0 task_number=2 module_number=2  "Read"
 send_command command='vary entity 70 flag 0 3 on' job_number=0 task_number=2 module_number=2  "Write"
 send_command command='vary entity 70 flag 0 4 off' job_number=0 task_number=2 module_number=2  "File Access"
 send_command command='vary entity 70 flag 0 5 on' job_number=0 task_number=2 module_number=2  "Limited File Management"
 send_command command='vary entity 70 flag 0 6 on' job_number=0 task_number=2 module_number=2  "Enhanced File Management"
 send_command command='vary entity 70 flag 0 7 on' job_number=0 task_number=2 module_number=2  "Grouping"


" Configure the FTAM protocol machine to support the Transfer service class, the Management service class, and the
" Transfer & Management service class.  112(10) = 0111 0000(2)

 send_command command='vary entity 70 parm 1 112' job_number=0 task_number=2 module_number=2  "T, M, T&M"


" Set the undocumented FTAM parameters for Directory Services, and Management Services.

 send_command command='vary entity 70 parm 4 1' job_number=0 task_number=2 module_number=2  "Directory Services"
 send_command command='vary entity 70 parm 5 1' job_number=0 task_number=2 module_number=2  "Management Services"


" Enable FTAM state automata driver messages, and encode/decoder motor messages.  3(10) = 0000 0011(2)

 send_command command='vary entity 70 parm 6 3' job_number=0 task_number=2 module_number=2


" Configure the Session entity to support Session Version I and Session Version II.

 send_command command='vary entity 50 flag 0 1 on' job_number=0 task_number=2 module_number=2  "Session Version I"
 send_command command='vary entity 50 flag 0 0 on' job_number=0 task_number=2 module_number=2  "Session Version II"


" Configure all entities to generate trace information.

 send_command command='vary entity 80 trace 0 ?osiam_trace?' job_number=0 task_number=2 module_number=2  "High Interface"
 send_command command='vary entity 70 trace 0 ?osiam_trace?' job_number=0 task_number=2 module_number=2  "FTAM"
 send_command command='vary entity 53 trace 0 ?osiam_trace?' job_number=0 task_number=2 module_number=2  "Presentation"
 send_command command='vary entity 50 trace 0 ?osiam_trace?' job_number=0 task_number=2 module_number=2  "Session"
 send_command command='vary entity 00 trace 0 ?osiam_trace?' job_number=0 task_number=2 module_number=2  "Low Interface"


" Configure all SAPs to generate trace information.

 send_command command='vary sap 15 trace ?osiam_trace?' job_number=0 task_number=2 module_number=2  "FTAM to High Interface"
 send_command command='vary sap 16 trace ?osiam_trace?' job_number=0 task_number=2 module_number=2  "Presentation to FTAM"
 send_command command='vary sap 17 trace ?osiam_trace?' job_number=0 task_number=2 module_number=2  "Low Interface to Session"
 send_command command='vary sap 21 trace ?osiam_trace?' job_number=0 task_number=2 module_number=2  "Session to Presentation"


" DEBUG: Disable 'Automatic Object Identifier table management', and 'New Object Identifier management' support
" in the presentation layer.  See pages 18 and 19 of the Presentation Implementation Guide for details. Testing
" with FTAM/4000 appears to be more successful with New Oid Management disabled.

" Setting bit 8, the ninth bit in the flag, also sets bit 0..7 as a side effect.

 send_command command='vary entity 53 flag 0 8 off' job_number=0 task_number=2 module_number=2  "Automatic Oid Table Management"
 send_command command='vary entity 53 flag 0 2 off' job_number=0 task_number=2 module_number=2  "New Oid Management"


" DEBUG: Add additional debugging information to the log.

 send_command command='debug on' job_number=0 task_number=0 module_number=2
 send_command command='debug on' job_number=0 task_number=2 module_number=2


" Start OSIAM and FTAM processing.

 send_command command='start' job_number=0 task_number=0 module_number=2 "OSIAM"
 send_command command='start' job_number=0 task_number=2 module_number=2 "FTAM"

" DEBUG: Display the status of all SAPs, entities, and buffers.

 send_command command='show sap 1 255' job_number=0 task_number=2 module_number=2
 send_command command='show entity 80 all' job_number=0 task_number=2 module_number=2  "High Interface"
 send_command command='show entity 70 all' job_number=0 task_number=2 module_number=2  "FTAM"
 send_command command='show entity 53 all' job_number=0 task_number=2 module_number=2  "Presentation"
 send_command command='show entity 50 all' job_number=0 task_number=2 module_number=2  "Session"
 send_command command='show entity 00 all' job_number=0 task_number=2 module_number=2  "Low Interface"
 send_command command='show buf' job_number=0 task_number=2 module_number=2
*** END_RESPONDER_STARTUP ***
  IF NOT local_status.normal THEN

" The responder startup commands could not be generated.

    IF local_status.condition = ame$file_not_known THEN
      local_status = $status(false, 'PF', pfe$unknown_permanent_file, $string(responder_startup_commands))
    IFEND
    EXIT procedure WITH local_status
  IFEND

  IF $first($file_attributes(editing_directives, registered)).registered AND ..
        $first($file_attributes(editing_directives, size)).size <> 0 THEN

" Customize the responder configuration file using EDIT_FILE. A seperate task is created to bypass problems
" which could result if this procedure is called from within the EDIT_FILE utility.

    TASK
      $system.edit_file file=responder_startup_commands input=editing_directives output=$null prolog=$null
    TASKEND
  IFEND

" Define the values for LOCAL_CHARACTER_SETS and VIRTUAL_CHARACTER_SETS.

  IF NOT $field(local_character_sets, g1, initialized) THEN
    temp_local_charsets = (local_character_sets.g0, none)
  ELSE
    temp_local_charsets = local_character_sets
  IFEND

  IF ($generic_type(virtual_character_sets) = record) THEN
    IF NOT $field(virtual_character_sets, g1, initialized) THEN
      temp_virtual_charsets = (virtual_character_sets.g0, none)
    ELSE
      temp_virtual_charsets = virtual_character_sets
    IFEND
  ELSE
    temp_virtual_charsets = virtual_character_sets
  IFEND

" Delete any existing cycles of the responder abort file.

  REPEAT
    delete_file file=responder_abort_file status=local_status
  UNTIL NOT local_status.normal

" Generate the responder abort file.

  TASK ring=11
COLLECT_TEXT output=responder_abort_file until='*** END_ABORT_COMMANDS ***' substitution_mark='?' ..
          status=local_status

  VAR
    abort_commands_status: status
    binary_log_file: name
    date_time_stamp: string
    dump_file: file
  VAREND


  IF $job_status($job(system_job_name), job_state) = TERMINATED THEN

" The FTAM responder job has been terminated by the DEACTIVATE_FTAM_RESPONDER, TERMINATE_JOB, or
" TERMINATE_SYSTEM commands. Generate dump information in case the responder was terminated in order to
" resolve a FTAM/VE problem which did not cause the responder to abort. Any dump information which was
" generated at a previous job termination will have been deleted automatically when FTAM was activated.

    dump_file = $system.ftam.responder_dump_job_termination

    set_file_attributes file=dump_file fc=list pf=continuous
    put_line line='1***** TERMINATION DUMP OF FTAM' o=dump_file.$eoi

" Since a complete job log will be saved when job termination is complete, the incremental job log will be
" of no value. Attempt to delete the incremental job log if the user requested the log at activation.

    IF ?produce_incremental_job_log? THEN
      delete_file file=?responder_incremental_job_log? status="ignore" abort_commands_status
    IFEND

  ELSE " the job state is not equal to TERMINATED, the FTAM responder has aborted.

" Obtain the current date and time in order to produce distinct file names for the OSIAM binary log and
" for the output of the debugger commands contained in this abort file. Distinct names are used so the next
" abort will not overwrite the information.

    date_time_stamp = $date('Y2M2D2')//'_'//$time('H24MMSS')

    binary_log_file = $name('osiam_binary_log_'//date_time_stamp)

" Alter the name of the OSIAM binary log to contain the date time stamp for this abort.

    change_catalog_entry file=$system.ftam.osiam_binary_log new_file_name=binary_log_file ..
          status=abort_commands_status
    IF NOT abort_commands_status.normal THEN
      display_message message='**** Attempt to catpure OSIAM binary log failed with the following status:' ..
            to=job
      display_value value=$string(abort_commands_status) output=$local.$job_log.$eoi
    IFEND

    dump_file = $fname('$system.ftam.responder_dump_'//date_time_stamp)

" Generate the responder dump

    set_file_attributes file=dump_file fc=list pf=continuous
    put_line line='1***** ABORT DUMP OF FTAM' o=dump_file.$eoi

    display_message message=' ' to=job
    display_message message='**** Please write a PSR against FTAM/VE and provide' to=job
    display_message message='**** as supporting material a permanent file backup' t=job
    display_message message='**** of catalog $SYSTEM.FTAM.' t=job
    display_message message=' ' to=job
  IFEND

    put_line line='       '//$date(iso)//' '//$time(millisecond) o=dump_file.$eoi

    put_line line='       '//$job(os_version)//' - '//$default_family//' - CYBER '//..
$processor(model_number, 0)//' Serial '//$processor(serial_number, 0) o=dump_file.$eoi

    put_lines lines=('', ' ***** ENVIRONMENT:', '') output=dump_file.$eoi
    display_debugging_environment display_option=user_address output=dump_file.$eoi
    display_debug_task_status task_number=all output=dump_file.$eoi

    put_lines lines=('', ' ***** TRACEBACK:', '') output=dump_file.$eoi
    display_call count=all start=1 display_option=all_calls output=dump_file.$eoi

    put_lines lines=('', ' ***** BEGIN JOB LOG:', '') output=dump_file.$eoi
    display_log display_option=500 output=dump_file.$eoi
    put_lines lines=('', ' ***** END JOB LOG *****', '') output=dump_file.$eoi

    put_lines lines=('', ' ***** REGISTERS:', '') output=dump_file.$eoi
    display_register kind=all_program number=all type=hex output=dump_file.$eoi

    put_lines lines=('', ' ***** STACK FRAMES:', '') output=dump_file.$eoi
    display_stack_frame count=all start=1 display_option=all output=dump_file.$eoi

    put_lines lines=('', ' ***** STATIC SECTION:', '') output=dump_file.$eoi
    display_memory section=$static module=$name($current_module) byte_offset=0 byte_count=16 ..
          repeat_count=64 output=dump_file.$eoi

*** END_ABORT_COMMANDS ***
    IF NOT local_status.normal THEN

" The responder abort file commands could not be generated.

      IF local_status.condition = ame$file_not_known THEN
        local_status = $status(false, 'PF', pfe$unknown_permanent_file, $string(responder_abort_file))
      IFEND
      EXIT procedure WITH local_status
    IFEND
  TASKEND

  JOB user_job_name=responder_user_job_name job_abort_disposition=terminate job_class=job_class ..
        job_destination_usage=ve_local job_recovery_disposition=terminate ..
        output_disposition=responder_job_log substitution_mark='?' ..
        system_job_name=responder_system_job_name status=local_status

    "$FORMAT=OFF"
    VAR
      nfv$ftam_resp_local_charsets: (job) record
        g0: key
          (iso_646_irv, irv)
          (iso_646_usa, usa, iso_8859_1)
        keyend
        g1: key
          iso_8859_1, none
        keyend = $optional
      recend=?temp_local_charsets?
      nfv$ftam_resp_virtual_charsets: (job) any of
        record
          g0: key
            (iso_646_irv, irv)
            (iso_646_usa, usa, iso_8859_1)
          keyend
          g1: key
            iso_8859_1, none
          keyend = $optional
        recend
        key
          unknown
        keyend
      anyend=?temp_virtual_charsets?
    VAREND
    "$FORMAT=ON"

    "$FORMAT=OFF"
    VAR
      ignore_status: status
      local_status: status
      maximum_restart_attempts: integer = ?maximum_restart_attempts?
      nfv$ftam_supported_users: (JOB) string = '?supported_users?'
      nfv$notify_after_aborting: (JOB) boolean = ?notify_after_aborting?
      number_of_restarts: integer = 0
      produce_incremental_job_log: boolean = ?produce_incremental_job_log?
      protocol_trace: boolean = ?protocol_trace?
    VAREND
    "$FORMAT=ON"

    IF protocol_trace AND NOT $variable(nfv$ftam_performance_trace, defined) THEN
      VAR
        nfv$ftam_performance_trace: (JOB) string = 'DETAILED'
      VAREND
    IFEND

    IF produce_incremental_job_log THEN
      TASK task_name=update_incremental_job_log ring=11

" Wait thirty seconds for the responder tasks to become active, write the job log, and then write the job
" log every thirty minutes thereafter until the job state changes to TERMINATED.

        wait time=0-0-0.00:00:30.000
        REPEAT
          display_log do=all output=?responder_incremental_job_log?
          wait time=0-0-0.00:30:00.000
        UNTIL $job_status($job(system_job_name), job_state) = terminated
      TASKEND
    IFEND

    change_message_level il=full status=ignore_status
    change_working_catalog c=$system.ftam
    create_command_list_entry entries=(?ftam_product_library?, ?ftam_message_template_library?)

    delete_file file=$system.ftam.responder_dump_job_termination status=ignore_status

    set_program_attributes preset_value=zero

    SYSTEM_OPERATOR_UTILITY
      REPEAT
        IF number_of_restarts > 0 THEN
          display_message message=' ' to=job
          display_message message='***The responder has aborted with the following status:' to=job
          display_message message=$string(local_status) to=job
          display_message message='***Attempting restart #'//$string(number_of_restarts) to=(job, job_message)
          display_message message=' ' to=job

" A small (7 1/2 second) delay is forced before the next restart attempt. The delay will reduce the impact
" on the system should the responder continuously abort immediately after beginning execution.

          wait time=0-0-0.00:00:07.500
        IFEND

        execute_task parameters='cf=?responder_startup_commands? lf=?osiam_binary_log_file?' libraries=(? ..
              ftam_product_library?, ?generic_transport_library?) ..
              starting_procedure=nfp$configure_ftam_responder load_map=?load_map_file_value? ..
              load_map_options=all preset_value=zero termination_error_level=error ..
              abort_file=?responder_abort_file? debug_mode=?responder_debug_mode? status=local_status

        number_of_restarts = number_of_restarts + 1
      UNTIL (number_of_restarts > maximum_restart_attempts)
    END_SYSTEM_OPERATOR_UTILITY

    delete_command_list_entry entry=?ftam_product_library? status=ignore_status

    IF ($variable(nfv$notify_after_aborting, defined)) AND ..
          ($job_status($job(system_job_name), job_state) <> terminated) THEN
      IF nfv$notify_after_aborting THEN
        send_operator_message m='FTAM Responder job failed, see ?responder_job_log?' oc=system_operator
      IFEND
    IFEND

  JOBEND

  detach_file file=editing_directives status=ignore_status
  delete_file file=editing_directives status=ignore_status

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND activate_ftam_responder
*DECK DECK=RAM$ACTIVATE_FTPS EXPAND=TRUE
PROC activate_ftps (
  load_map, lm : file = $optional
  status       : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request activates FTPS.
*IFEND


  create_variable ignore_status k=status
  create_variable local_status k=status
  create_variable ftp_library k=string v='$system.tcp_ip.ftp_bound_product'


  IF NOT $file($fname(ftp_library) permanent) THEN
    put_line ('  ', ' --ERROR-- Unable to activate:  FTP is not installed.') o=$response
    EXIT_PROC
  IFEND

  IF $specified(load_map) THEN
    map_file = $string($value(load_map))
    options = 'all'
  ELSE
    map_file = '$null'
    options = 'none'
  IFEND

  remove_system_task name=ftp_server status=local_status
  IF NOT local_status.normal AND ($condition(local_status.condition) <> 'OSE$SYSTEM_TASK_NOT_DEFINED') THEN
    EXIT_PROC WITH local_status
  IFEND

  define_system_task name=ftp_server library=$fname(ftp_library) ..
        starting_procedure=ipp$ftp_server_initialization automatic_restart=false restart_after_idle=true ..
        deactivate_task_option=terminate idle_task_option=terminate load_map=$fname(map_file) ..
        load_map_options=$name(options) termination_error_level=error status=local_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

  activate_system_task task_name=ftp_server status=local_status

  EXIT_PROC WITH local_status

PROCEND activate_ftps

*DECK DECK=RAM$ACTIVATE_INETD EXPAND=TRUE
PROCEDURE activate_inetd (
  trace, trace_mode, tm, t : boolean = false
  trace_file, tf : file = $null
  job_class, jc : name = system
  epilog, e: file = $null
  dump_file, df: file = $null
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'
"
" Purpose:  Activate the Internet Daemon.
"
" Parameters:  trace, trace_mode, tm, t: If true, inetd generates trace messages
"              to the job log or to the trace_file, if specified
"
"              trace_file, tf: If specified, inetd trace messages are
"              logged to this file
"
"              job_class, jc: The job class under which the inetd job will run
"
"              epilog, e: If specified, the commands on this file will be executed
"              upon termination of inetd
*IFEND


  VAR
    application_job_name: name = $name('INTERNET_DMN'//$mainframe(id))
    inetd_bound_library: file = $system.tcp_ip.inetd_bound_product
    inetd_job_log: file = $system.tcp_ip.inetd_job_log
    inetd_job_name: name
    select_status: status
    starting_procedure_name: name = inp$inetd_initialization
    submit_status: status
    system_job_name: name
    task_parameters: string
  VAREND

  command_source = $source
  IF NOT $file(inetd_bound_library permanent) THEN
    put_line ' --ERROR-- Unable to activate:  INETD is not installed.'..
      o=$response
    EXIT procedure
  IFEND

  MANAGE_JOBS
    SELECT_JOB ..
      name=application_job_name job_state=(deferred, queued, initiated) ..
      status=select_status
    IF select_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        put_line ' The Internet Daemon is already active as job(s):' ..
          o=$response
        display_value jmv$selected_jobs o=$response
        EXIT procedure
      IFEND
    ELSE
      EXIT procedure WITH select_status
    IFEND
  QUIT

  task_parameters = 'trace=' // $strrep(trace)

  IF $specified(trace_file) THEN
    task_parameters = task_parameters // ' trace_file=' // $string(trace_file)
  IFEND

    JOB user_job_name=application_job_name ..
        job_recovery_disposition=terminate ..
        job_abort_disposition=terminate ..
        job_class=job_class ..
        output_disposition=inetd_job_log ..
        substitution_mark='?' ..
        system_job_name=inetd_job_name ..
        status=submit_status

      VAR
        osv$daemon_command: string = '?$string(command_source)?.activate_inetd '
        osv$daemon_name: name = INETD
        osv$daemon_status: status
        osv$daemon_parameters: string = '?$parameter_list?'
        abort_file_commands: file = $unique($local)
        ignore: status
      VAREND

      WHEN EXIT DO
        display_value osv$daemon_status o=$job_log
        IF ?$specified(trace_file)? THEN
          change_file_attributes ?trace_file? ring_attributes=($ring $ring $ring) status=ignore
        IFEND
        IF ?$specified(epilog)? THEN
          include_file ?epilog?
        IFEND
        delete_file abort_file_commands
      WHENEND

COLLECT_TEXT output=abort_file_commands until='** END OF ABORT COMMANDS **' substitution_mark='#'

        VAR
          dump_status: status
          dump_file: file
        VAREND

        dump_file = ?dump_file?

" The following commands will display the abort information
" through the use of the debugger.

      IF ?$specified(dump_file)? THEN
        set_file_attributes dump_file fc=list pf=continuous
        put_line '1***** ABORT DUMP OF INETD' o=dump_file.$eoi
        put_line '       '//$date(iso)//' '//$time(millisecond) o=dump_file.$eoi
        put_line $format_value('       +p - +p - CYBER +p Serial +p' ($job(os_version) $default_family ..
              $processor(model_number, 0) $processor(serial_number, 0))) o=dump_file.$eoi
        put_lines ('', ' ***** ENVIRONMENT:', '') output=dump_file.$eoi
        display_debugging_environment display_option=user_address output=dump_file.$eoi
        display_debug_task_status task_number=all output=dump_file.$eoi
        put_lines ('', ' ***** TRACEBACK:', '') output=dump_file.$eoi
        display_call count=all start=1 display_option=all_calls output=dump_file.$eoi
        put_lines ('', ' ***** JOB LOG:', '') output=dump_file.$eoi
        display_log display_option=200 output=dump_file.$eoi
        put_lines ('', ' ***** REGISTERS:', '') output=dump_file.$eoi
        display_register kind=all_program number=all type=hex output=dump_file.$eoi
        change_file_attributes dump_file ra=(?$ring? ?$ring? ?$ring?) status=dump_status
      ELSE
        display_call count=all start=1 display_option=all_calls output=$job_log
      IFEND

** END OF ABORT COMMANDS **

      set_program_attributes abort_file=abort_file_commands

      set_program_attributes preset_value=zero debug_mode=off
      system_operator_utility capability=system_administration

      TASK ring=6
        set_debug_ring $ring
        create_command_list_entry ?inetd_bound_library? status=osv$daemon_status
        execute_task l=(?inetd_bound_library? $system.tcp_ip.mnf$library) ..
           sp=?starting_procedure_name? p='?task_parameters?' status=osv$daemon_status
      TASKEND

      quit

    JOBEND

  IF submit_status.normal THEN
    put_line ' The Internet Daemon has been activated as job '//..
$string(inetd_job_name)//'.' o=$response
  ELSE
    put_line ' --ERROR-- Unable to submit job for Internet Daemon.' ..
      o=$response
  IFEND
  EXIT procedure WITH submit_status WHEN NOT submit_status.normal

PROCEND activate_inetd
*DECK DECK=RAM$ACTIVATE_IPC_APPLICATIONS EXPAND=TRUE
PROCEDURE activate_ipc_applications, actia (
  family, f: name = $null
  spool_catalog, sc: file = $optional
  cache_delay, cd: integer 0..3600 = 60
  debug, d: boolean = FALSE
  debug_options, do: any of
      key
        all, none
      keyend
      list of key
        (internal_errors, ie)
        (errno_errors, ee)
        (statistics, s)
        (ipam_errors, ipe)
        (nosve_file_errors, nfe)
        (unode_errors, ue)
        (mount_errors, me)
        (xdr_errors, xe)
      keyend
    anyend = none
  maximum_open_files, mof: integer 1..100 = 50
  nfs_maximum_working_set, nmws: any of
      key
        system_default, unlimited
      keyend
      integer 20..65000
    anyend = system_default
  tasks, t: integer 1..4 = 1
  block_size, bs: key
      (small, eight_k)
      (large, sixteen_k)
    keyend = small
  epilog, e: file = nfd$epilog, $system.tcp_ip.onc.epilog
  domain_name_resolver, dnr: boolean = FALSE
  served_family, sf, served_families:list of name
  status)

"   This procedure is on the OS source_library because it resides
"   on osf$builtin_library.  The ONC products are on the NFS source
"   library.  To minimize the number of times a mod is required
"   to both source libraries the activate procs call start procs
"   passing all the parameters required data.  The start procs reside on
"   onc.command_library which is under NFS code control.


  VAR
    nfd$epilog: (push) string = $string(epilog)
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  IF $SPECIFIED(served_family) THEN
    tcp_ip.onc.command_library.start_ipc_applications f=family sc=spool_catalog ..
          cd=cache_delay d=debug do=debug_options mof=maximum_open_files nmws=nfs_maximum_working_set t=tasks ..
          bs=block_size dn=domain_name_resolver sf=served_family
  ELSE
    tcp_ip.onc.command_library.start_ipc_applications f=family sc=spool_catalog ..
          cd=cache_delay d=debug do=debug_options mof=maximum_open_files nmws=nfs_maximum_working_set t=tasks ..
          bs=block_size dn=domain_name_resolver
  IFEND
PROCEND activate_ipc_applications
*DECK DECK=RAM$ACTIVATE_MAILVE EXPAND=TRUE
PROCEDURE activate_mailve (
  job_class, jc : name = $job_default(job_class, batch)
  load_map, lm : file = $optional
  log_options, lo: any of
      key
        all, none
      keyend
    anyend = none
  mail_catalog, mc: (BY_NAME) file = $null
  message_transfer_agent, mta: (BY_NAME, ADVANCED) any of
      string 1..12
      name 1..12
    anyend = mvd$default_mta, ' '
  status
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request initiates the MAILVE server application as a NOS/VE job.
*IFEND

  VAR
    active_mta: string = $trim($string(message_transfer_agent),,all)
    task_parameters: string = 'MTA_TYPE=SERVER'
  VAREND

  IF $size($trim(active_mta)) > 0 THEN
    task_parameters = task_parameters//' MTA='''''//active_mta//''''''
  ELSE
    active_mta = 'MAILVE'
  IFEND

  VAR
    application_job_name: name = $name('MTA_'//active_mta//$mainframe(id))
    ignore_status: status
    log_options_s: string
    mail_library: file = $system.mailve_v2.bound_product_ring_4
    mailve_job_log: file = $system.mailve_v2//$name(active_mta//'_job_log')
    mailve_statistics: file = $system.mailve_v2.mailve_statistics
    manna_status: status
    map_file: string
    options: string
    select_status: status
    starting_procedure_name: name = mvp$mta_server
    submit_status: status
    system_job_name: name
    system_tast_name: name
  VAREND

  IF (NOT $file(mail_library  permanent)) THEN
    put_line lines=('  ', ' --ERROR-- Unable to activate:  MAILVE is not installed.') ..
          o=$response
    EXIT_PROC
  IFEND

  MANAGE_JOBS
    SELECT_JOB ..
      name=application_job_name job_state=(deferred, queued, initiated) ..
      status=select_status
    IF select_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        put_line ' MAILVE is already active as job:' ..
          o=$response
        display_value jmv$selected_jobs o=$response
        EXIT procedure
      IFEND
    ELSE
      EXIT procedure WITH select_status
    IFEND
  QUIT

  IF $specified(load_map) THEN
    map_file = $string(load_map)
    options = 'all'
  ELSE
    map_file = '$null'
    options = 'none'
  IFEND

  log_options_s = 'log_options=' // $string(log_options)

  JOB user_job_name=application_job_name ..
      job_class=job_class ..
      job_recovery_disposition=terminate ..
      job_abort_disposition=terminate ..
      output_disposition=mailve_job_log ..
      substitution_mark='?' ..
      system_job_name=system_job_name ..
      status=submit_status

    SOU capability=(system_administration, system_operation)

      TASK r=4

        VAR
          mvv$maximum_external_hops: integer = 10
          mvv$maximum_external_loops: integer = 3
          mvv$maximum_internal_hops: integer = 10
          mvv$maximum_internal_loops: integer = 3
          mvv$custom_delivery_catalog: (environment) file= ?mail_catalog?
        VAREND

        execute_task library=?mail_library? ..
            starting_procedure=?starting_procedure_name? ..
            parameters='?task_parameters? ?log_options_s?' ..
            load_map=?map_file? ..
            load_map_options=?options?
      TASKEND

    QUIT
  JOBEND

  IF submit_status.normal THEN
    put_line ' MAILVE has been activated as job  '//..
$string(application_job_name)//' ('//$string(system_job_name)//').' ..
        o=$response
  ELSE
    put_line ' --ERROR-- Unable to submit job for MAILVE.' ..
      o=$response
  IFEND
  EXIT procedure WITH submit_status WHEN NOT submit_status.normal

PROCEND activate_mailve

*DECK DECK=RAM$ACTIVATE_MAIL_CLUSTER_SERVE EXPAND=TRUE
PROCEDURE activate_mail_cluster_server (
  job_class, jc: name = $job_default(job_class, batch)
  status)

  "$FORMAT=OFF"
  VAR
    application_job_name: name = $name('MAIL_DFS_SRVR'//$mainframe(id))
    ignore_status: status
    dfs_library: file = $system.applications.distributed_file_server.ver_1_0.dfs$site_command_library
    dfs_job_log: file = $system.mailve_v2.dfs_job_log
    manna_status: status
    select_status: status
    submit_status: status
    system_job_name: name
  VAREND
  "$FORMAT=ON"

  IF (NOT $file(dfs_library permanent)) THEN
    put_line lines=('  ', ..
          ' --ERROR-- Unable to activate:  Distributed File Server is not i..
nstalled.') o=$response
    EXIT_PROC
  IFEND

  MANAGE_JOBS
    select_job login_user=$system login_family=$system ..
          name=application_job_name job_state=(deferred, queued, initiated) ..
          status=select_status
    IF select_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        put_line ' MAILVE_CLUSTER_SERVER is already active as ..
              job:'           o=$response
        display_value jmv$selected_jobs o=$response
        EXIT PROCEDURE
      IFEND
    ELSE
      EXIT procedure WITH select_status
    IFEND
  QUIT

  JOB user_job_name=application_job_name job_class=job_class ..
        job_recovery_disposition=terminate job_abort_disposition=terminate ..
        output_disposition=dfs_job_log substitution_mark='?' ..
        system_job_name=system_job_name job_execution_ring=4 ..
        status=submit_status

    SYSTEM_OPERATOR_UTILITY capability=system_administration
      create_command_list_entry ?dfs_library?
      start_remote_access_server
    QUIT

  JOBEND

  IF submit_status.normal THEN
    put_line ' MAILVE_CLUSTER_SERVER has been activated as job  '//..
$string(application_job_name)//' ('//$string(system_job_name)//').' ..
          o=$response
  ELSE
    put_line ' --ERROR-- Unable to submit job for MAILVE_CLUSTER_SERVER.' ..
          o=$response
  IFEND
  EXIT procedure WITH submit_status WHEN NOT submit_status.normal

PROCEND activate_mail_cluster_server
*DECK DECK=RAM$ACTIVATE_MAIL_DELIVERY_AGEN EXPAND=TRUE
PROCEDURE activate_mail_delivery_agent, actmda (
  job_class, jc : name = $job_default(job_class, batch)
  mail_catalog, mc: file = $required
  log, l: file = $null
  message_transfer_agent, mta: (BY_NAME, ADVANCED) any of
      string 1..12
      name 1..12
    anyend = mvd$default_mta, ' '
  status
  )



"   This request initiates the MAILVE custom delivery procedure as a NOS/VE job.

  VAR
    active_mta: string = 'MAILVE'
    mta_parm: string = ''
    log_parm: string = 'log='//$string(log)
  VAREND

  IF $specified(message_transfer_agent) THEN
    mta_parm = ' MTA='''//$string(message_transfer_agent)//''''
    active_mta = $string(message_transfer_agent)
  IFEND

  VAR
    application_job_name: name = $name('MVE_CD_'//active_mta//$mainframe(id))
    mail_library: file = $system.mailve_v2.maintenance.command_library
    mailve_job_log: file = $system.mailve_v2//$name('MVE_CD_'//active_mta//'_job_log')
    select_status: status
    submit_status: status
    system_job_name: name
  VAREND

  IF (NOT $file(mail_library  permanent)) THEN
    put_line lines=('  ', ' --ERROR-- Unable to activate:  MAILVE is not installed.') ..
          o=$response
    EXIT_PROC
  IFEND

  MANAGE_JOBS
    SELECT_JOB login_user=$SYSTEM login_family=$SYSTEM ..
      name=application_job_name job_state=(deferred, queued, initiated) ..
      status=select_status
    IF select_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        put_line ' MAILVE Custom Delivery is already active as job:' ..
          o=$response
        display_value jmv$selected_jobs o=$response
        EXIT procedure
      IFEND
    ELSE
      EXIT procedure WITH select_status
    IFEND
  QUIT

  JOB user_job_name=application_job_name ..
      job_class=job_class ..
      job_recovery_disposition=terminate ..
      job_abort_disposition=terminate ..
      output_disposition=mailve_job_log ..
      substitution_mark='?' ..
      system_job_name=system_job_name ..
      status=submit_status

    SOU capability=(system_administration, system_operation)

      TASK r=4

        VAR
          mvv$custom_delivery_catalog: (environment) file = ?mail_catalog?
        VAREND

        ?mail_library?.process_mail_files mc=?mail_catalog? ?log_parm? ?mta_parm?
      TASKEND

    QUIT
  JOBEND

  IF submit_status.normal THEN
    put_line ' MAILVE Custom Delivery has been activated as job  '//..
$string(application_job_name)//' ('//$string(system_job_name)//').' ..
        o=$response
  ELSE
    put_line ' --ERROR-- Unable to submit job for MAILVE Custom Delivery.' ..
      o=$response
  IFEND
  EXIT procedure WITH submit_status WHEN NOT submit_status.normal

PROCEND activate_mail_delivery_agent

*DECK DECK=RAM$ACTIVATE_MAIL_GATEWAY EXPAND=TRUE
PROCEDURE activate_mail_gateway (
  job_class, jc                 : name = $job_default(job_class, batch)
  load_map, lm                  : file = $optional
  log_options, lo               : any of
                                    key
                                      all, none
                                    keyend
                                   anyend = none
  status
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request initiates the MAILVE_MG server application as a NOS/VE job.
*IFEND

  VAR
    application_job_name: name = $name('MAILVE_MG'//$mainframe(id))
    ignore_status: status
    log_options_s: string
    mail_library_4: file = $system.mailve_v2.bound_product_ring_4
    mail_library_d: file = $system.mailve_v2.bound_product_ring_d
    mailve_mg_job_log: file = $system.mailve_v2.mailve_mg_job_log
    manna_status: status
    map_file: string
    options: string
    select_status: status
    starting_procedure_name: name = mvp$mta_server
    submit_status: status
    system_job_name: name
    task_parameters: string = 'MTA_TYPE=GATEWAY'
  VAREND

  IF (NOT $file(mail_library_4  permanent)) OR  ..
        (NOT $file(mail_library_d  permanent)) THEN
    put_line lines=('  ', ' --ERROR-- Unable to activate:  MAILVE is not installed.') ..
          o=$response
    EXIT_PROC
  IFEND

  MANAGE_JOBS
    SELECT_JOB login_user=$SYSTEM login_family=$SYSTEM ..
      name=application_job_name job_state=(deferred, queued, initiated) ..
      status=select_status
    IF select_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        put_line ' MAILVE_MG is already active as job:' ..
          o=$response
        display_value jmv$selected_jobs o=$response
        EXIT procedure
      IFEND
    ELSE
      EXIT procedure WITH select_status
    IFEND
  QUIT

  IF $specified(load_map) THEN
    map_file = $string(load_map)
    options = 'all'
  ELSE
    map_file = '$null'
    options = 'none'
  IFEND

  log_options_s = 'log_options=' // $string(log_options)

  JOB user_job_name=application_job_name ..
      job_class=job_class ..
      job_recovery_disposition=terminate ..
      job_abort_disposition=terminate ..
      output_disposition=mailve_mg_job_log ..
      substitution_mark='?' ..
      system_job_name=system_job_name ..
      status=submit_status

    SOU capability=(system_administration, system_operation)

      TASK r=4
        execute_task library=(?mail_library_4?, ?mail_library_d?) ..
            starting_procedure=?starting_procedure_name? ..
            parameters='?task_parameters? ?log_options_s?' ..
            load_map=?map_file? ..
            load_map_options=?options?
      TASKEND

    QUIT
  JOBEND

  IF submit_status.normal THEN
    put_line ' MAILVE_MG has been activated as job  '//..
$string(application_job_name)//' ('//$string(system_job_name)//').' ..
        o=$response
  ELSE
    put_line ' --ERROR-- Unable to submit job for MAILVE_MG.' ..
      o=$response
  IFEND
  EXIT procedure WITH submit_status WHEN NOT submit_status.normal

PROCEND activate_mail_gateway
*DECK DECK=RAM$ACTIVATE_NETWORK_ARCHIVING EXPAND=TRUE
PROCEDURE activate_network_archiving, actna, actnr (
  configuration_file, cf: file = $system.etc.netarc_config
  debug, d: boolean = FALSE
  debug_options, do: list of key all, none, keyend = none
  status)

"   This procedure resides on osf$builtin_library.  The start procs which are
"   called by this procedure reside on $system.tcp_ip.netarc.command_library.
"   This procedure checks to see that Network_Archiving is installed before
"   the  start proc is called.

VAR
  command_status: status
  network_archiving_library: file = $system.tcp_ip.netarc.command_library
VAREND

  IF (NOT $file(network_archiving_library permanent)) THEN
    put_line ('  ', ..
        ' --ERROR-- Unable to activate:  Network Archiving is not installed.')..
 o=$response
    EXIT_PROC
  IFEND

network_archiving_library.start_Network_Archiving ..
    cf=configuration_file ..
    d=debug ..
    do=debug_options ..
    status=command_status
EXIT_PROC WITH command_status WHEN NOT command_status.normal

PROCEND activate_network_archiving
*DECK DECK=RAM$ACTIVATE_NFS EXPAND=TRUE
PROCEDURE activate_nfs, actnfs (
  cache_delay, cd: integer 0..3600 = 60
  debug_options, do: any of
      key
        all, none
      keyend
      list of key
        (internal_errors, ie)
        (errno_errors, ee)
        (statistics, s)
        (ipam_errors, ipe)
        (nosve_file_errors, nfe)
        (unode_errors, ue)
        (mount_errors, me)
        (xdr_errors, xe)
      keyend
    anyend = none
  maximum_open_files, mof: integer 1..100 = 50
  maximum_working_set, maxws, mws, nfs_maximum_working_set, nmws: any of
      key
        system_default, unlimited
      keyend
      integer 20..65000
    anyend = system_default
  tasks, t: integer 1..4 = 1
  debug, d: boolean = FALSE
  block_size, bs: key
      (small, eight_k)
      (large, sixteen_k)
    keyend = small
  epilog, e: file = nfd$epilog, $system.tcp_ip.onc.epilog
  domain_name_resolver, dnr: boolean = FALSE
  served_family, sf, served_families:list of name
  status)

"   This procedure is under NOS/VE code control because it resides
"   on osf$builtin_library.  The NFS products are under CDCNET
"   code control.  To minimize the number of times a mod is required
"   to both NOS/VE and CDCNET the activate procs call corresponding
"   start procs passing all the parameters.  The start procs reside on
"   onc.command_library which is under CDCNET code control.

  VAR
    nfd$epilog: (push) string = $string(epilog)
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  IF $SPECIFIED(served_family) THEN
    tcp_ip.onc.command_library.start_nfs cd=cache_delay d=debug do=debug_options ..
        mof=maximum_open_files nmws=nfs_maximum_working_set t=tasks bs=block_size ..
        dn=domain_name_resolver sf=served_family
  ELSE
    tcp_ip.onc.command_library.start_nfs cd=cache_delay d=debug do=debug_options ..
        mof=maximum_open_files nmws=nfs_maximum_working_set t=tasks bs=block_size ..
        dn=domain_name_resolver
  IFEND
PROCEND activate_nfs
*DECK DECK=RAM$ACTIVATE_NLM EXPAND=TRUE
PROCEDURE activate_nlm, actnlm (
  debug, d: boolean = FALSE
  statistics_time_increment, sti: any of
      key
        none
      keyend
      integer 1..480
    anyend = none
  epilog, e: file = nfd$epilog, $system.tcp_ip.onc.epilog
  status)

"   This procedure is under NOS/VE code control because it resides
"   on osf$builtin_library.  The NFS products are under CDCNET
"   code control.  To minimize the number of times a mod is required
"   to both NOS/VE and CDCNET the activate procs call corresponding
"   start procs passing all the parameters.  The start procs reside on
"   onc.command_library which is under CDCNET code control.

  VAR
    nfd$epilog: (push) string = $string(epilog)
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  tcp_ip.onc.command_library.start_nlm d=debug statistics_time_increment=statistics_time_increment

PROCEND activate_nlm
*DECK DECK=RAM$ACTIVATE_NQS EXPAND=TRUE
PROCEDURE activate_nqs (
  maximum_qfiles_per_task, maxqpt: integer 1..20 = 10
  maximum_transfers, maxt: integer 1..20 = 10
  retransmission_interval, ri: time_increment = 0:15:0
  load_map, lm: file = $optional
  dump_file, df: file = $optional
  job_class, jc: name = system
  notify_after_aborting, naa: boolean = false
  protocol_trace, pt: (BY_NAME, ADVANCED) boolean = false
  status)

  VAR
    title: string = 'Network Queueing System (NQS) for NOS/VE'
    ignore_status: status
    local_status: status
    nqs_library : file = $system.nqs.nqf$system_666
    dump_file_value: file = $null
    load_map_value: file = $null
  VAREND

  IF $specified(dump_file) THEN
    dump_file_value = dump_file
  IFEND

  IF $specified(load_map) THEN
    load_map_value = load_map
  IFEND

  IF NOT $file(nqs_library permanent) THEN
    EXIT procedure WITH $status(false 'AM' ame$file_not_known nqs_library 'NQS_ACTIVATION')
  IFEND

  MANAGE_JOBS
    select_job name=network_queueing_system_client job_state=(deferred, queued, initiated) ..
          user_information=title status=local_status
    EXIT procedure WITH local_status WHEN NOT local_status.normal
    IF $size(jmv$selected_jobs) > 0 THEN
      EXIT procedure WITH $status(false 'RA' 0 'An identical NQS job was found. NQS will not be activated')
    IFEND
  QUIT

  JOB jn=network_queueing_system_client job_abort_disposition=terminate job_class=job_class ..
        job_destination_usage=ve_local job_execution_ring=6 job_recovery_disposition=terminate ..
        output_disposition=$system.nqs.nqs_client_output substitution_mark='!' user_information=title ..
        status=local_status

    VAR
      ignore_status: status
      nqs_job_status: status
      abort_file_commands: file = $local.abort_file_commands
    VAREND

COLLECT_TEXT output=abort_file_commands until='** END OF ABORT COMMANDS **' substitution_mark='#'

    VAR
      dump_status: status
      dump_file: file = $fname('$system.nqs.nqs_dump_'//$date('Y2M2D2')//'_'//$time('H24MMSS'))
      notify_after_aborting: boolean = !notify_after_aborting!
    VAREND

    IF !$specified(dump_file)! THEN
      dump_file = !dump_file_value!
    IFEND

    display_message message=' ' to=job
    display_message message='**** Please write a PSR against NQS/VE and provide' to=job
    display_message message='**** as supporting material a permanent file backup' t=job
    display_message message='**** of catalog $SYSTEM.NQS.' t=job
    display_message message=' ' to=job

" The following commands will display the abort information
" through the use of the debugger.

    set_file_attributes dump_file fc=list pf=continuous
    put_line '1***** ABORT DUMP OF NQS' o=dump_file.$eoi
    put_line '       '//$date(iso)//' '//$time(millisecond) o=dump_file.$eoi
    put_line $format_value('       +p - +p - CYBER +p Serial +p' ($job(os_version) $default_family ..
          $processor(model_number, 0) $processor(serial_number, 0))) o=$dump_file.$eoi
    put_lines ('', ' ***** ENVIRONMENT:', '') output=dump_file.$eoi
    display_debugging_environment display_option=user_address output=dump_file.$eoi
    display_debug_task_status task_number=all output=dump_file.$eoi
    put_lines ('', ' ***** TRACEBACK:', '') output=dump_file.$eoi
    display_call count=all start=1 display_option=all_calls output=dump_file.$eoi
    put_lines ('', ' ***** JOB LOG:', '') output=dump_file.$eoi
    display_log display_option=200 output=dump_file.$eoi
    put_lines ('', ' ***** REGISTERS:', '') output=dump_file.$eoi
    display_register kind=all_program number=all type=hex output=dump_file.$eoi
    put_lines ('', ' ***** STACK FRAMES:', '') output=dump_file.$eoi
    display_stack_frame count=all start=1 display_option=all output=dump_file.$eoi
    put_lines ('', ' ***** STATIC SECTION:', '') output=dump_file.$eoi
    display_memory section=$static module=$name($current_module) byte_offset=0 byte_count=16 ..
          repeat_count=all output=dump_file.$eoi status=dump_status
    change_file_attributes dump_file ra=(!$ring! !$ring! !$ring!) status=dump_status

    IF notify_after_aborting THEN
      send_operator_message m='NQS job failed, see '//dump_file oc=system_operator
    IFEND
** END OF ABORT COMMANDS **

    IF !protocol_trace! THEN
      VAR
        ipv$debug_mode: (JOB) integer = 1
      VAREND
    IFEND

    change_message_level il=full status=ignore_status
    IF !$specified(load_map)! THEN
      set_program_attributes load_map=!load_map_value! load_map_options=all
    IFEND

    set_program_attributes abort_file=abort_file_commands preset_value=zero

    controller_parameters = 'maximum_qfiles_per_task=!maximum_qfiles_per_task! maximum_transfers=!maximum_transfers! ..
          retransmission_interval=!retransmission_interval! sender_library=!nqs_library! debug=!protocol_trace!'

    set_debug_ring $ring
    execute_task sp=nqp$_nqs_controller p=controller_parameters ..
          l=!nqs_library! status=nqs_job_status

    display_value nqs_job_status

  JOBEND

  EXIT procedure WITH local_status

PROCEND activate_nqs
*DECK DECK=RAM$ACTIVATE_PCNFSD EXPAND=TRUE
PROCEDURE activate_pcnfsd, activate_pcnfs, actpn (
  family, f: name = $required
  spool_catalog, sc: file = $optional
  debug, d: boolean = FALSE
  epilog, e: file = nfd$epilog, $system.tcp_ip.onc.epilog
  status)

"   This procedure is under NOS/VE code control because it resides
"   on osf$builtin_library.  The NFS products are under CDCNET
"   code control.  To minimize the number of times a mod is required
"   to both NOS/VE and CDCNET the activate procs call corresponding
"   start procs passing all the parameters.  The start procs reside on
"   onc.command_library which is under CDCNET code control.

  VAR
    nfd$epilog: (push) string = $string(epilog)
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  tcp_ip.onc.command_library.start_pcnfsd family=family spool_catalog=spool_catalog debug=debug

PROCEND activate_pcnfsd
*DECK DECK=RAM$ACTIVATE_PORTMAP EXPAND=TRUE
PROCEDURE activate_portmap, actp (
  debug, d: boolean = FALSE
  debug_options, do: any of
      key
        all, none
      keyend
      list of key
        (internal_errors, ie)
        (ipam_errors, ipe)
        (restart_portmap, rp)
      keyend
    anyend = none
  epilog, e: file = nfd$epilog, $system.tcp_ip.onc.epilog
  status)

"   This procedure is under NOS/VE code control because it resides
"   on osf$builtin_library.  The NFS products are under CDCNET
"   code control.  To minimize the number of times a mod is required
"   to both NOS/VE and CDCNET the activate procs call corresponding
"   start procs passing all the parameters.  The start procs reside on
"   onc.command_library which is under CDCNET code control.

  VAR
    nfd$epilog: (push) string = $string(epilog)
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  tcp_ip.onc.command_library.start_portmap debug=debug debug_options=debug_options

PROCEND activate_portmap
*DECK DECK=RAM$ACTIVATE_PRODUCTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$ACTIVATE_PRODUCTS Interface.' ??
MODULE ram$activate_products;

{ PURPOSE:
{   This module contains the interface that takes a subproduct or subproducts
{   from the staging cycle to the active state.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$installation_cycles
*copyc rae$install_software_cc
*copyc rat$installation_control_record
?? POP ??
*copyc osp$append_status_file
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pfp$change
*copyc rap$clear_installation
*copyc rap$convert_path_to_str
*copyc rap$get_cycle_data
*copyc rap$record_step_status
*copyc rap$record_subproduct_status
*copyc rap$sort_cycles

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$activate_products', EJECT ??

{ PURPOSE:
{   This interface takes a subproduct or subproducts from the staging
{   cycle to the active state.
{
{ DESIGN:
{   To activate a subproduct a cycle change is performed on the subproduct's
{   files from the staging cycle to the next active cycle.
{
{   The inability to activate any file belonging to a subproduct will cause
{   the entire subproduct to have failed the activate step.  The
{   installation processing record for that subproduct is set as such and
{   the subproduct will be cleared from the the system at the conclusion of
{   this step.
{
{   The failure of one subproduct will not jeopardize the remaining
{   subproducts.  Each subproduct will be processed independently.
{
{ NOTES:
{   The SUBPRODUCT_FAILED_PROCESSING boolean has been initialized outside of
{   this interface and should never be initialized here.

  PROCEDURE [XDCL] rap$activate_products
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR subproducts_failed_processing: boolean;
     VAR status: ost$status);


    VAR
      ignore_status: ost$status,
      local_status: ost$status,
      processing_record: rat$subp_processing_record,
      subproduct_index: rat$subproduct_count,
      task_status: ost$status;


    status.normal := TRUE;

    IF NOT (rac$activate_subproducts_step IN installation_control_record.processing_header_p^.step_set) THEN
      RETURN;
    IFEND;

    rap$record_step_status (rac$activate_subproducts_step, rac$step_started, installation_control_record,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /main/
    FOR subproduct_index := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^) DO
      processing_record := installation_control_record.subproduct_processing_records_p^ [subproduct_index];

      IF (installation_control_record.job_identifier = processing_record.job_identifier) AND
            (rac$activate_files_task IN processing_record.task_set) AND
            (processing_record.task_status <> rac$task_failed) THEN

        rap$record_subproduct_status (rac$activate_files_task, rac$task_started, subproduct_index,
              installation_control_record, ignore_status);

        activate_subproduct (processing_record.installation_catalog_p^,
              processing_record.subproduct_info_pointers.element_list_p,
              processing_record.subproduct_info_pointers.subproduct_info_seq_p, installation_control_record.
              scratch_seq_p, task_status);

        IF task_status.normal THEN
          rap$record_subproduct_status (rac$activate_files_task, rac$task_completed, subproduct_index,
                installation_control_record, ignore_status);
        ELSE
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], task_status, ignore_status);
          rap$record_subproduct_status (rac$activate_files_task, rac$task_failed, subproduct_index,
                installation_control_record, ignore_status);
          subproducts_failed_processing := TRUE;
        IFEND;

      IFEND;
    FOREND /main/;

    rap$clear_installation (installation_control_record, ignore_status);

    rap$record_step_status (rac$activate_subproducts_step, rac$step_completed, installation_control_record,
          local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

  PROCEND rap$activate_products;

?? TITLE := 'activate_file', EJECT ??

{ PURPOSE:
{   This procedure activates a file for a subproduct.
{
{ DESIGN:
{   Cycle data is retieved for the file.  The next active cycle is the
{   highest cycle + 1.  A standard change interface is called to change the
{   file currently in the staging cycle to the next active cycle.
{
{ NOTES:
{   The scratch sequence is used by RAP$GET_CYCLE_DATA as temporary storage
{   for cycles array.
{
{   The cycles array is sorted in decending order, so that makes the first
{   entry the highest.  Also you can assume that the highest cycle will not
{   be rac$max_active_cycle because of reconcile cycle conflicts step.
{
{   IMPORTANT - There is concern that the actual $next active cycle can
{   change between the initial pickup of the value and the changing of the
{   file cycles.
{

  PROCEDURE activate_file
    (    element_p: ^rat$element;
         file_path: pft$path;
     VAR scratch_seq_p {input} : ^SEQ ( * );
     VAR status: ost$status);


    VAR
      current_cycle: pft$cycle_selector,
      cycles_p: pft$p_cycle_array,
      new_cycle: array [1 .. 2] of pft$change_descriptor,
      next_active_cycle: 0 .. rac$max_active_cycle,
      password: pft$password;


    status.normal := TRUE;

    { Get the cycle number for the next active cycle.

    rap$get_cycle_data (file_path, scratch_seq_p, cycles_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$sort_cycles (cycles_p);

    next_active_cycle := cycles_p^ [1].cycle_number + 1;


    { Move the file from the staging cycle to the next active cycle.

    current_cycle.cycle_option := pfc$specific_cycle;
    current_cycle.cycle_number := rac$staging_cycle;
    new_cycle [1].change_type := pfc$cycle_number_change;
    new_cycle [1].cycle_number := next_active_cycle;
    new_cycle [2].change_type := pfc$charge_change;
    password := '';

    pfp$change (file_path, current_cycle, password, new_cycle, status);

  PROCEND activate_file;

?? TITLE := 'activate_subproduct', EJECT ??

{ PURPOSE:
{   This procedure activates the files belonging to a subproduct.
{
{ DESIGN:
{   Determining what files belong to the subproduct is accomplished by
{   traversing the element list for the subproduct.  The taverse is
{   performed using recursion and each call to ACTIVATE_SUBPRODUCT moves
{   processing down to the next catalog level.
{
{   Only active elements are processed.
{
{ NOTES:
{   The scratch sequence is used by a subsequent procedure as temporary
{   storage for file information.
{

  PROCEDURE activate_subproduct
    (    element_path: pft$path;
     VAR element_p {input} : ^rat$element;
     VAR subproduct_info_seq_p {input} : ^rat$subproduct_info_sequence;
     VAR scratch_seq_p {input} : ^SEQ ( * );
     VAR status: ost$status);


    VAR
      current_element_path_p: ^pft$path,
      first_element_down_p: ^rat$element,
      i: integer;


    status.normal := TRUE;

    { The element_path parameter is the path for the current catalog.  Create
    { a PF format path array that is 1 larger than the size of the element
    { path.  This array will be used to construct the PF paths for the files
    { and subcatalogs that reside in the current catalog.

    PUSH current_element_path_p: [1 .. UPPERBOUND (element_path) + 1];
    FOR i := 1 TO UPPERBOUND (element_path) DO
      current_element_path_p^ [i] := element_path [i];
    FOREND;

    { Process the files and subcatalogs at the current catalog level.

    WHILE element_p <> NIL DO

      current_element_path_p^ [UPPERBOUND (current_element_path_p^)] := element_p^.name;

      IF element_p^.active_element THEN

        IF element_p^.element_type = rac$file THEN

          activate_file (element_p, current_element_path_p^, scratch_seq_p, status);

        ELSEIF (element_p^.element_type = rac$catalog) AND (element_p^.element_count <> 0) THEN

          first_element_down_p := #PTR (element_p^.first_element_down_p, subproduct_info_seq_p^);

          activate_subproduct (current_element_path_p^, first_element_down_p, subproduct_info_seq_p,
                scratch_seq_p, status);

        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      element_p := #PTR (element_p^.next_element_across_p, subproduct_info_seq_p^);
    WHILEND;

  PROCEND activate_subproduct;
MODEND ram$activate_products;
*DECK DECK=RAM$ACTIVATE_PRODUCT_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: ACTIVATE_PRODUCT Subcommand.' ??
MODULE ram$activate_product_command;

{ PURPOSE:
{   This module contains the command interface that activates deferred
{   products.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$command_log_name
*copyc rac$control_job_identifier
*copyc rac$control_file_name
*copyc rac$not_installed
*copyc rae$install_software_cc
*copyc rat$idb_directory_pointers
*copyc rat$installation_control_record
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc clp$include_line
*copyc fsp$close_file
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pmp$get_compact_date_time
*copyc pmp$log_ascii
*copyc rap$access_directory_for_read
*copyc rap$assign_install_identifier
*copyc rap$display_job_log_to_cmd_log
*copyc rap$init_processing_seq_fr_file
*copyc rap$perform_installation_steps
*copyc rav$installation_defaults
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

{   The following types are used to define the activation lists.  The
{   activation lists organize the subproducts (to be activated) by the
{   installation control files (ICFs) originally used to defer them.  One
{   activation list is created for each ICF used.

{   An activation list consists of a header record that points to a linked
{   list of subproduct activation records.  Each record defines a subproduct
{   to be activated.
{
{   The activation lists are linked together through another field in the
{   header record.
{

  TYPE
    rat#activation_list_header = record
      installation_identifier: rat$installation_identifier,
      number_of_subproducts: rat$subproduct_count,
      first_subproduct_p: ^rat#subp_activation_record,
      last_subproduct_p: ^rat#subp_activation_record,
      next_activation_list_p: ^rat#activation_list_header,
    recend;

  TYPE
    rat#subp_activation_record = record
      name: rat$subproduct_name,
      processing_records_index: rat$subproduct_count,
      next_subproduct_p: ^rat#subp_activation_record
    recend;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$activate_product_command', EJECT ??

{ PURPOSE:
{   This command interface activates the specified licensed product(s)
{   and/or subproduct(s).
{
{ DESIGN:
{   Only subproducts installed deferred can be activated.  The complete
{   installation process is divided into the following major steps:
{
{     1.  RECONCILING CYCLE CONFLICTS
{     2.  LOADING THE SUBPRODUCTS
{     3.  CORRECTING THE SUBPRODUCTS
{     4.  STAGING THE SUBPRODUCTS
{     5.  ACTIVATING THE SUBPRODUCTS
{     6.  EXECUTING THE INSTALLER PROCEDURES
{     7.  UPDATING THE IDB DIRECTORY
{     8.  DELETING PREVIOUS CYCLES
{
{   A subproduct that is deferred has been through steps 1-4 and 7.  To
{   activate the deferred subproduct steps 5 through 8 are performed.
{
{   The IDB Directory is used to determine which subproducts are deferred
{   and therefore which subproducts can be activated.  The directory also
{   contains the installation identifier that is used to locate the
{   installation control file (ICF) used to install each deferred
{   subproduct.  The same ICF will be used to activate the subproduct that
{   was used to install the deferred subproduct.  It is possible for there
{   to be more than one ICF to activate all the deferred subproducts.
{
{   To prepare for activation, activation lists are assembled (see type
{   description above) .  The activation lists contain lists of subproducts
{   to be activated.  Each subproduct is grouped according to the ICF used
{   to install that subproduct as deferred.  The SUBPRODUCT parameter allows
{   the caller of this command to select a subset of the deferred
{   subproducts to activate.  This is validated against the directory.
{
{   An installation identifier is created and displayed for this
{   installation event.
{
{   The activation lists are then used to activate the requested subproducts
{   from one ICF at a time until all the involved ICFs have been processed.
{
{   The failure of one ICF (ICF missing for example) nor the failure of one
{   subproduct of an ICF will prevent other ICF's from being processed.
{
{   The job log will be written to a permanent command log file under the
{   installation identifier catalog.  The job log is first displayed to
{   $null to set a LAST displayed mark.  After processing, the job log is
{   displayed starting from the last displayed mark.
{
{   The directory is taken from the installation database as defined by the
{   installation defaults.
{
{ NOTES:
{   Batch processing is not supported for ACTIVATE_PRODUCT at 1.4.1.  The
{   following discussion should be kept in mind if it is ever to be
{   implemented.  In INSTALL_PRODUCT and INSTALL_CORRECTION, batch
{   processing involves performing the installation steps only.  If this
{   concept were used in ACTIVATE_PRODUCT, the ICFs would have to be
{   re-written, which means having multiple ICFs for a single installation
{   event.  An alternative would be to execute a call to
{   ACTIVATE_PRODUCTS_FROM_ICF from batch.
{

  PROCEDURE [XDCL] rap$activate_product_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE actp_pdt (
{   subproduct, subproducts, s: any of
{       key
{         all
{       keyend
{       list of name
{     anyend = $required
{   save_previous_cycles, spc: boolean = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 6] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] 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,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 28, 15, 9, 19, 68], clc$command, 6, 3, 1, 0, 0, 0, 3, 'ACTP_PDT'],
            [['S                              ', clc$abbreviation_entry, 1],
            ['SAVE_PREVIOUS_CYCLES           ', clc$nominal_entry, 2],
            ['SPC                            ', clc$abbreviation_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3],
            ['SUBPRODUCT                     ', clc$nominal_entry, 1],
            ['SUBPRODUCTS                    ', clc$alias_entry, 1]], [
{ PARAMETER 1
      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 85, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 3
      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ 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]]], 21, [[1, 0, clc$list_type],
            [5, 1, clc$max_list_size, FALSE], [[1, 0, clc$name_type], [1, osc$max_name_size]]]],
{ PARAMETER 2
      [[1, 0, clc$boolean_type]],
{ PARAMETER 3
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$subproduct = 1,
      p$save_previous_cycles = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      activation_lists_p: ^rat#activation_list_header,
      activation_lists_segment_ptr: amt$segment_pointer,
      current_activation_list_p: ^rat#activation_list_header,
      ignore_status: ost$status,
      installation_identifier: rat$installation_identifier,
      local_status: ost$status;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to return the scratch segment
{   used for the activation list and display the job log to the command log
{   file when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;


      IF activation_lists_segment_ptr.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (activation_lists_segment_ptr, ignore_status);
        activation_lists_segment_ptr.sequence_pointer := NIL;
      IFEND;

      rap$display_job_log_to_cmd_log (rav$installation_defaults.installation_logs, installation_identifier,
            ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    installation_identifier := osc$null_name;
    clp$include_line ('$system.display_log do=last o=$null', TRUE, osc$null_name, ignore_status);

    activation_lists_segment_ptr.kind := amc$sequence_pointer;
    activation_lists_segment_ptr.sequence_pointer := NIL;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      get_activation_lists (rav$installation_defaults.installation_database, pvt [p$subproduct].value,
            activation_lists_segment_ptr, activation_lists_p, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$assign_install_identifier (rac$activate_product, rav$installation_defaults.installation_logs,
            osc$null_name {packing list not used} , installation_identifier, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      current_activation_list_p := activation_lists_p;

      WHILE current_activation_list_p <> NIL DO

        activate_subproducts_from_icf (current_activation_list_p, installation_identifier,
              pvt [p$save_previous_cycles], status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        current_activation_list_p := current_activation_list_p^.next_activation_list_p;
      WHILEND;

    END /main/;

    IF activation_lists_segment_ptr.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (activation_lists_segment_ptr, local_status);
      activation_lists_segment_ptr.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    rap$display_job_log_to_cmd_log (rav$installation_defaults.installation_logs, installation_identifier,
          ignore_status);

    osp$disestablish_cond_handler;

  PROCEND rap$activate_product_command;

?? OLDTITLE ??
?? NEWTITLE := 'activate_subproducts_from_icf', EJECT ??

{ PURPOSE:
{   This procedure activates the subproducts from the activation list
{   associated with the specified installation control file (ICF).
{
{ DESIGN:
{   The installation control record is re-established for the execution of
{   the installation steps.  The installation control file contains a copy
{   of the processing sequence that was originally created for the deferred
{   installation.  The processing sequence is re-created from the
{   installation control file and the packing list is re-accessed if not
{   already contained in the processing sequence (at 1.4.1 the packing list
{   is always part of the processing sequence).  If the packing list is
{   accessed during re-creation of the installation control record it will
{   be closed by this procedure.
{
{   The saving of previous cycles is controlled by the value from the ICF
{   (set during the deferred installation) unless overridden by the
{   parameter on the ACTIVATE_PRODUCT command.
{
{   The global rav$installation_defaults are reset to the values from the
{   installation control file.  This will put the INSTALL_SOFTWARE
{   environment in agreement with the INSTALL_SOFTWARE environment
{   established when the subproducts were first installed deferred.
{
{   The subproducts to be activated are validated that their files are in
{   the staging cycle.
{
{   The subproduct task sets (in the processing sequence) are redefined.
{   Those not being activated are cleared.
{
{   The job identifier is re-established to guide the step processing.  The
{   job status record is also set up.  In this case a processing summary
{   file is not created, instead a local job status record used.
{
{   Once setup is complete the installation steps for the ICF are executed.
{
{ NOTES:
{   The installation defaults are set to those found in the ICF.  This will
{   allow activation to occur in an environment close to that used when the
{   subproducts were deferred.  These may vary from the values directly
{   associated with the current install software defaults.  The current
{   defaults are saved and then restored after activation for this ICF has
{   completed.
{
{   The job status record is established locally.  In other commands the job
{   status records are created as part of a processing summary file.
{
{   The distinction between a step and a task is that steps indicate
{   processing at the global level, where as, tasks relate to processing at
{   the subproduct level.
{
{   The scratch segment used for the processing sequence is created in
{   RAP$INIT_PROCESSING_SEQ_FR_FILE.
{

  PROCEDURE activate_subproducts_from_icf
    (    activation_list_p: ^rat#activation_list_header;
         installation_identifier: rat$installation_identifier;
         save_previous_cycles: clt$parameter_value;
     VAR status: ost$status);


    VAR
      ignore_status: ost$status,
      installation_control_file: rat$path,
      installation_control_record: rat$installation_control_record,
      local_status: ost$status,
      packing_list_fid: amt$file_identifier,
      packing_list_opened: boolean,
      processing_seq_segment_pointer: amt$segment_pointer,
      saved_installation_defaults: rat$installation_defaults;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to return the scratch segment
{   for the processing sequence and packing list file when an abort
{   condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;


      IF processing_seq_segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (processing_seq_segment_pointer, ignore_status);
        processing_seq_segment_pointer.sequence_pointer := NIL;
      IFEND;

      fsp$close_file (packing_list_fid, ignore_status);

      rav$installation_defaults := saved_installation_defaults;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    saved_installation_defaults := rav$installation_defaults;

    installation_control_record.job_identifier := rac$control_job_identifier;
    PUSH installation_control_record.job_status_record_p;

    processing_seq_segment_pointer.kind := amc$sequence_pointer;
    processing_seq_segment_pointer.sequence_pointer := NIL;
    packing_list_opened := FALSE;

    { Construct the installation control file path from the installation
    { identifier from the activation list header and default installation
    { logs catalog path.

    STRINGREP (installation_control_file.path, installation_control_file.size,
          rav$installation_defaults.installation_logs.path (1,
          rav$installation_defaults.installation_logs.size),
          '.', activation_list_p^.installation_identifier (1,
          clp$trimmed_string_size (activation_list_p^.installation_identifier)), '.', rac$control_file_name);

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      rap$init_processing_seq_fr_file (installation_control_file.path (1, installation_control_file.size),
            installation_control_record, processing_seq_segment_pointer, packing_list_fid,
            packing_list_opened, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      installation_control_record.processing_header_p^.installation_command := rac$activate_product;

      IF save_previous_cycles.specified THEN
        installation_control_record.processing_header_p^.save_previous_cycles :=
              save_previous_cycles.value^.boolean_value.value;
      IFEND;

      rav$installation_defaults := installation_control_record.processing_header_p^.installation_defaults;

      establish_task_set (activation_list_p, installation_control_record);

      establish_processing_cntrls (installation_identifier, activation_list_p, installation_control_record,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$perform_installation_steps (installation_control_record, status);

    END /main/;

    rav$installation_defaults := saved_installation_defaults;

    IF packing_list_opened THEN
      fsp$close_file (packing_list_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF processing_seq_segment_pointer.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (processing_seq_segment_pointer, local_status);
      processing_seq_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND activate_subproducts_from_icf;

?? OLDTITLE ??
?? NEWTITLE := 'add_to_activation_list', EJECT ??

{ PURPOSE:
{   This procedure adds the subproduct name to the activation list for the
{   ICF.  If the ICF does not yet have activation list, a new activation
{   list is started.
{
{ DESIGN:
{   The installation identifier is used to identifier one installation
{   control file from another.
{
{ NOTES:
{

  PROCEDURE add_to_activation_list
    (    subproduct_name: rat$subproduct_name;
         installation_identifier: rat$installation_identifier;
         processing_records_index: rat$subproduct_count;
     VAR activation_lists_segment_ptr {input, output} : amt$segment_pointer;
     VAR activation_lists_p: ^rat#activation_list_header;
     VAR status: ost$status);


    VAR
      current_activation_list_p: ^rat#activation_list_header,
      new_subproduct_activation_rec_p: ^rat#subp_activation_record;


    status.normal := TRUE;

    IF activation_lists_p = NIL THEN
      { No activation list has been initialized.  An activation list is initialized by
      { creating an activation list header for the installation control file used to
      { install the subproduct.

      NEXT current_activation_list_p IN activation_lists_segment_ptr.sequence_pointer;
      IF current_activation_list_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'ACTIVATION LIST', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'ACTIVATION LIST HEADER', status);
        RETURN;
      IFEND;

      activation_lists_p := current_activation_list_p;

      current_activation_list_p^.installation_identifier := installation_identifier;
      current_activation_list_p^.number_of_subproducts := 0;
      current_activation_list_p^.first_subproduct_p := NIL;
      current_activation_list_p^.last_subproduct_p := NIL;
      current_activation_list_p^.next_activation_list_p := NIL;

    ELSE {there is at least one existing activation list}
      { Locate the activation list for the installation control file used to
      { install the deferred subproduct.

      current_activation_list_p := activation_lists_p;
      WHILE (installation_identifier <> current_activation_list_p^.installation_identifier) AND
            (current_activation_list_p^.next_activation_list_p <> NIL) DO
        current_activation_list_p := current_activation_list_p^.next_activation_list_p;
      WHILEND;

      IF installation_identifier <> current_activation_list_p^.installation_identifier THEN
        { The installation control file used to install the subproduct does not have
        { an activation list.  A new activation list is initialized and linked to
        { the last activation list.

        NEXT current_activation_list_p^.next_activation_list_p IN
              activation_lists_segment_ptr.sequence_pointer;
        IF current_activation_list_p = NIL THEN
          osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'ACTIVATION LIST', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'ACTIVATION LIST HEADER', status);
          RETURN;
        IFEND;

        current_activation_list_p := current_activation_list_p^.next_activation_list_p;

        current_activation_list_p^.installation_identifier := installation_identifier;
        current_activation_list_p^.number_of_subproducts := 0;
        current_activation_list_p^.first_subproduct_p := NIL;
        current_activation_list_p^.last_subproduct_p := NIL;
        current_activation_list_p^.next_activation_list_p := NIL;

      IFEND;
    IFEND;

    { Add the subproduct name to end of the current activation list.

    NEXT new_subproduct_activation_rec_p IN activation_lists_segment_ptr.sequence_pointer;
    IF new_subproduct_activation_rec_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'ACTIVATION LIST', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'SUBPRODUCT ACTIVATION RECORD', status);
      RETURN;
    IFEND;

    IF current_activation_list_p^.first_subproduct_p = NIL THEN
      { This is the first name recorded.

      current_activation_list_p^.first_subproduct_p := new_subproduct_activation_rec_p;
    ELSE
      current_activation_list_p^.last_subproduct_p^.next_subproduct_p := new_subproduct_activation_rec_p;
    IFEND;

    current_activation_list_p^.number_of_subproducts := current_activation_list_p^.number_of_subproducts + 1;
    current_activation_list_p^.last_subproduct_p := new_subproduct_activation_rec_p;
    current_activation_list_p^.last_subproduct_p^.name := subproduct_name;
    current_activation_list_p^.last_subproduct_p^.processing_records_index := processing_records_index;
    current_activation_list_p^.last_subproduct_p^.next_subproduct_p := NIL;

  PROCEND add_to_activation_list;

?? OLDTITLE ??
?? NEWTITLE := 'establish_processing_cntrls', EJECT ??

{ PURPOSE:
{   This procedure establishes the job processing controls.
{
{ DESIGN:
{   This procedure prepares the job processing controls for product
{   activation.  The processing controls established here is on a smaller
{   scale then with a complete installation.  (Job processing records are not
{   required because there is no multi-job processing.  The medium
{   processing records are not needed because the loading has already
{   occurred.  And the job status record is created without using the
{   processing summary file.)
{
{   Display the installation identifier from the ICF to the job log.  This
{   was the identifier used to install the deferred subproducts from this
{   ICF.
{
{   Set the job identifier.
{
{   Set up the job processing status record.
{
{ NOTES:
{   This procedure is to provides symmetry with rap$install_product_command.
{

  PROCEDURE establish_processing_cntrls
    (    installation_identifier: rat$installation_identifier;
         activation_list_p: ^rat#activation_list_header;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      creation_date_time: ost$date_time,
      current_subproduct_p: ^rat#subp_activation_record,
      i: rat$subproduct_count,
      length: integer,
      line: string (osc$max_string_size);


    status.normal := TRUE;

    { Display installation identifier originally used to install the subproducts deferred to job log.

    STRINGREP (line, length, '  Activating subproducts previously deferred by installation ',
          installation_control_record.processing_header_p^.installation_identifier
          (1, clp$trimmed_string_size (installation_control_record.processing_header_p^.
          installation_identifier)), '.');

    pmp$log_ascii (line (1, length), $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_program, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Set the installation identifier field in the installation control record.
    { The installation identifier will also be used as the job identifier.

    installation_control_record.processing_header_p^.installation_identifier := installation_identifier;
    installation_control_record.job_identifier := installation_identifier;

    { Clear the existing processing records' job identifier.

    FOR i := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^) DO
      installation_control_record.subproduct_processing_records_p^ [i].job_identifier := osc$null_name;
    FOREND;

    { For each subproduct listed on the current ICF activation list, the
    { associated processing record's job identifier field is initialized to the
    { job identifier.

    current_subproduct_p := activation_list_p^.first_subproduct_p;
    WHILE current_subproduct_p <> NIL DO

      installation_control_record.subproduct_processing_records_p^
            [current_subproduct_p^.processing_records_index].job_identifier :=
            installation_control_record.job_identifier;

      current_subproduct_p := current_subproduct_p^.next_subproduct_p;
    WHILEND;

    { Set up the job status record.

    pmp$get_compact_date_time (creation_date_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    installation_control_record.job_status_record_p^.job_identifier :=
          installation_control_record.job_identifier;
    installation_control_record.job_status_record_p^.log_file_name := rac$command_log_name;
    installation_control_record.job_status_record_p^.date_time := creation_date_time;
    installation_control_record.job_status_record_p^.number_of_steps :=
          installation_control_record.processing_header_p^.number_of_steps;
    installation_control_record.job_status_record_p^.step_number := 0;
    installation_control_record.job_status_record_p^.step := rac$null_step;
    installation_control_record.job_status_record_p^.step_status := rac$step_started;
    installation_control_record.job_status_record_p^.initial_subproduct_count :=
          activation_list_p^.number_of_subproducts;
    installation_control_record.job_status_record_p^.started_subproduct_count := 0;
    installation_control_record.job_status_record_p^.completed_subproduct_count := 0;

  PROCEND establish_processing_cntrls;

?? OLDTITLE ??
?? NEWTITLE := 'establish_task_set', EJECT ??

{ PURPOSE:
{   This procedure establishes the set of activation tasks to be performed
{   on the selected products.  These tasks are recorded in the subproduct
{   processing record for those subproducts chosen to be activated.
{
{ DESIGN:
{   The subproduct tasks performed to activate are:  activate files, execute
{   installer proc, update directory and delete previous cycles (when save
{   previous cycles is true).
{
{ NOTES:
{   The usage of the processing record index is based on two asumptions.
{   First, that the packing list index (from which it originated) is
{   compatible, and second, the ICF cannot be replaced by the user.
{

  PROCEDURE establish_task_set
    (    activation_list_p: ^rat#activation_list_header;
         installation_control_record {input, output} : rat$installation_control_record);


    VAR
      activation_tasks: rat$task_selections,
      current_subproduct_p: ^rat#subp_activation_record,
      i: rat$subproduct_count;


    { Determine the installation step and task sets.

    IF installation_control_record.processing_header_p^.save_previous_cycles THEN
      installation_control_record.processing_header_p^.number_of_steps := 4;
      installation_control_record.processing_header_p^.step_set :=
            $rat$step_selections [rac$reconcile_subproducts_step, rac$activate_subproducts_step,
            rac$execute_installer_proc_step, rac$update_directory_step];
      activation_tasks := $rat$task_selections [rac$reconcile_file_cycles_task, rac$activate_files_task,
            rac$execute_installer_proc_task, rac$update_directory_task];
    ELSE {delete previous cycles}
      installation_control_record.processing_header_p^.number_of_steps := 5;
      installation_control_record.processing_header_p^.step_set :=
            $rat$step_selections [rac$reconcile_subproducts_step, rac$activate_subproducts_step,
            rac$execute_installer_proc_step, rac$update_directory_step, rac$delete_previous_cycles_step];
      activation_tasks := $rat$task_selections [rac$reconcile_file_cycles_task, rac$activate_files_task,
            rac$execute_installer_proc_task, rac$update_directory_task, rac$delete_previous_cycles_task];
    IFEND;

    { Clear the existing processing records' task sets.

    FOR i := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^) DO
      installation_control_record.subproduct_processing_records_p^ [i].task_set := $rat$task_selections [];
      installation_control_record.subproduct_processing_records_p^ [i].task_status := rac$task_started;
    FOREND;

    { For each subproduct listed on the current activation list, the
    { associated processing record's task set field is initialized to the
    { activation tasks.

    current_subproduct_p := activation_list_p^.first_subproduct_p;
    WHILE current_subproduct_p <> NIL DO

      installation_control_record.subproduct_processing_records_p^
            [current_subproduct_p^.processing_records_index].task_set := activation_tasks;
      installation_control_record.subproduct_processing_records_p^
            [current_subproduct_p^.processing_records_index].task_status := rac$task_started;

      current_subproduct_p := current_subproduct_p^.next_subproduct_p;
    WHILEND;

  PROCEND establish_task_set;

?? OLDTITLE ??
?? NEWTITLE := 'get_activation_lists', EJECT ??

{ PURPOSE:
{   This procedure validates the input subproduct list specified on
{   the activate product command call against the IDB Directory and returns
{   the activation lists.
{
{ DESIGN:
{   The IDB directory is opened for read access.  The directory determines
{   if the subproducts associated with the input list are deferred and able
{   to be activated.
{
{   The subproduct list is checked for keyword ALL.  Error is returned if
{   names are specified with keyword ALL.  The appropriate processing
{   procedure is then called.
{
{ NOTES:
{

  PROCEDURE get_activation_lists
    (    installation_database: rat$path;
         subproduct_list_p: ^clt$data_value;
     VAR activation_lists_segment_ptr {input, output} : amt$segment_pointer;
     VAR activation_lists_p: ^rat#activation_list_header;
     VAR status: ost$status);


    VAR
      current_p: ^clt$data_value,
      directory_fid: amt$file_identifier,
      directory_opened: boolean,
      directory_pointers: rat$idb_directory_pointers,
      ignore_status: ost$status,
      local_status: ost$status;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to close the IDB directory
{   when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (directory_fid, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    activation_lists_p := NIL;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      rap$access_directory_for_read (installation_database, directory_pointers, directory_fid,
            directory_opened, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF directory_pointers.header_p^.deferred_count = 0 THEN
        osp$set_status_abnormal ('RA', rae$no_deferred_subproducts, '', status);
        EXIT /main/;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, activation_lists_segment_ptr, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      RESET activation_lists_segment_ptr.sequence_pointer;

      { Process the product list based on whether its the keyword ALL or a list of names.

      IF subproduct_list_p^.kind = clc$keyword THEN

        process_product_list_all (directory_pointers, activation_lists_segment_ptr, activation_lists_p,
              status);

      ELSE {list of names specified}

        { Test that key ALL is not specified along with product names.

        current_p := subproduct_list_p;
        WHILE current_p <> NIL DO
          IF current_p^.element_value^.name_value = 'ALL' THEN
            osp$set_status_abnormal ('RA', rae$specified_names_and_key_all, '', status);
            RETURN;
          IFEND;
          current_p := current_p^.link;
        WHILEND;

        process_product_list_names (subproduct_list_p, directory_pointers, activation_lists_segment_ptr,
              activation_lists_p, status);

      IFEND;

    END /main/;

    IF directory_opened THEN
      fsp$close_file (directory_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND get_activation_lists;

?? OLDTITLE ??
?? NEWTITLE := 'process_product_list_all', EJECT ??

{ PURPOSE:
{   This procedure builds the activation lists for all deferred subproducts.
{
{ DESIGN:
{   This procedure loops though the directory and adds every deferred
{   subproduct to the activation list that corresponds to that subproduct's
{   ICF.
{
{ NOTES:
{

  PROCEDURE process_product_list_all
    (    directory_pointers: rat$idb_directory_pointers;
     VAR activation_lists_segment_ptr {input, output} : amt$segment_pointer;
     VAR activation_lists_p: ^rat#activation_list_header;
     VAR status: ost$status);


    VAR
      i: rat$subproduct_count;


    status.normal := TRUE;

    FOR i := 1 TO UPPERBOUND (directory_pointers.directory_p^) DO
      IF directory_pointers.directory_p^ [i].deferred_information.installation_identifier <>
            rac$not_installed THEN

        { The subproduct is deferred.

        add_to_activation_list (directory_pointers.directory_p^ [i].subproduct,
              directory_pointers.directory_p^ [i].deferred_information.installation_identifier,
              directory_pointers.directory_p^ [i].deferred_information.packing_list_index,
              activation_lists_segment_ptr, activation_lists_p, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND;

  PROCEND process_product_list_all;

?? OLDTITLE ??
?? NEWTITLE := 'process_product_list_names', EJECT ??

{ PURPOSE:
{   This procedure builds the activation lists for the deferred subproducts
{   specified from the subproduct list.
{
{ DESIGN:
{   This procedure loops though the subproduct list and attempts to locate
{   each product name in the directory.  If found and deferred, add
{   subproduct to the activation list that corresponds to it's ICF.  If not,
{   set validation error but continue processing.  A validation error causes
{   processing to stop.
{
{ NOTES:
{

  PROCEDURE process_product_list_names
    (    subproduct_list_p: ^clt$data_value;
         directory_pointers: rat$idb_directory_pointers;
     VAR activation_lists_segment_ptr {input, output} : amt$segment_pointer;
     VAR activation_lists_p: ^rat#activation_list_header;
     VAR status: ost$status);


    VAR
      current_subproduct_list_p: ^clt$data_value,
      i: rat$subproduct_count,
      ignore_status: ost$status,
      local_status: ost$status,
      subproduct_in_directory: boolean,
      validation_errors_occurred: boolean;


    status.normal := TRUE;
    validation_errors_occurred := FALSE;

    current_subproduct_list_p := subproduct_list_p;
    WHILE current_subproduct_list_p <> NIL DO
      subproduct_in_directory := FALSE;

      FOR i := 1 TO UPPERBOUND (directory_pointers.directory_p^) DO

        IF current_subproduct_list_p^.element_value^.name_value =
              directory_pointers.directory_p^ [i].subproduct THEN
          { Subroduct name matches subproduct name for subproduct in directory.

          IF directory_pointers.directory_p^ [i].deferred_information.installation_identifier <>
                rac$not_installed THEN
            { This subproduct is deferred.

            add_to_activation_list (directory_pointers.directory_p^ [i].subproduct,
                  directory_pointers.directory_p^ [i].deferred_information.installation_identifier,
                  directory_pointers.directory_p^ [i].deferred_information.packing_list_index,
                  activation_lists_segment_ptr, activation_lists_p, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          ELSE {subproduct is not deferred}
            osp$set_status_abnormal ('RA', rae$subproduct_not_deferred,
                  directory_pointers.directory_p^ [i].subproduct
                  (1, clp$trimmed_string_size (directory_pointers.directory_p^ [i].subproduct)),
                  local_status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  directory_pointers.directory_p^ [i].licensed_product
                  (1, clp$trimmed_string_size (directory_pointers.directory_p^ [i].licensed_product)),
                  local_status);
            osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
            validation_errors_occurred := TRUE;
          IFEND;

          subproduct_in_directory := TRUE;
        IFEND;
      FOREND;
      IF NOT subproduct_in_directory THEN
        osp$set_status_abnormal ('RA', rae$subproduct_not_in_directory,
              current_subproduct_list_p^.element_value^.name_value (1,
              clp$trimmed_string_size (current_subproduct_list_p^.element_value^.name_value)), local_status);
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
        validation_errors_occurred := TRUE;
      IFEND;
      current_subproduct_list_p := current_subproduct_list_p^.link;
    WHILEND;

    IF validation_errors_occurred THEN
      osp$set_status_abnormal ('RA', rae$validation_errors_occurred, 'SUBPRODUCT', status);
    IFEND;

  PROCEND process_product_list_names;
MODEND ram$activate_product_command;

*DECK DECK=RAM$ACTIVATE_RHFAM EXPAND=TRUE
PROC activate_rhfam (
  status : var of status = $optional
  )

  create_variable activate_rhfam_status kind=status
  create_variable ignore_status kind=status

  create_variable cr_requested kind=string

  create_variable rhfam_utility_installed kind=boolean value=false
  create_variable rhfam_microcode_installed kind=boolean value=false
  create_variable rhfam_configuration_installed kind=boolean value=false

  create_variable rhfam_configuration_file k=string v='$system.rhfam.configuration_cmd_file'
  create_variable rhfam_utility_file k=string v='$system.rhfam.osf$rhfam_network_utilities'
  create_variable rhfam_microcode k=string v='$system.rhfam.microcode.c180'

  rhfam_utility_installed = $file($fname(rhfam_utility_file), permanent)
  rhfam_microcode_installed = $file($fname(rhfam_microcode), permanent)
  IF (NOT rhfam_utility_installed) OR (NOT rhfam_microcode_installed) THEN
    put_line ('  ', ' --ERROR-- Product RHFAM is not installed.') o=$response
    accept_line cr_requested input p='Press NEXT:'
    EXIT_PROC
  IFEND

  rhfam_configuration_installed = $file($fname(rhfam_configuration_file), permanent)
  IF NOT rhfam_configuration_installed THEN
    put_line ('  ', ' --ERROR-- RHFAM network configuration is not installed.') o=$response
    accept_line cr_requested input p='Press NEXT:'
    EXIT_PROC
  IFEND
  MANAGE_RHFAM_NETWORK
    install_rhfam_config_bin
    quit

  delete_system_task rhfam status=ignore_status
  define_system_task name=rhfam sp=rfp$rhfam_event_processor automatic_restart=false ..
        idle_task_option=ignore restart_after_idle=false tel=warning lm=$null lmo=none dm=off ..
        status=activate_rhfam_status
  EXIT_PROC WITH activate_rhfam_status WHEN NOT activate_rhfam_status.normal

  activate_system_statistic statistic=(cm7200 cm7202) log=engineering_log ..
        status=activate_rhfam_status
  EXIT_PROC WITH activate_rhfam_status WHEN NOT activate_rhfam_status.normal


  activate_system_task task_name=rhfam status=activate_rhfam_status
  EXIT_PROC WITH activate_rhfam_status WHEN NOT activate_rhfam_status.normal

  put_line ' RHFAM activated' o=$response

PROCEND activate_rhfam

*DECK DECK=RAM$ACTIVATE_XTF EXPAND=TRUE
PROCEDURE activate_xtf (
  transfer_retry_delay, trd: integer 30..3600 = 600
  log_option, lo: key
      (startup, s)
      (startup_and_execution, sae)
      (rts_only, ro)
    keyend = startup
  enable_password_checking, epc: boolean = FALSE
  job_class, jc: name = $job_default(job_class, batch)
  unknown_mta_connections, umc: integer 0..10 = 0
  maximum_restart_attempts, maxra: (BY_NAME, ADVANCED) integer 0..65535 = 10
  notify_after_aborting, naa: (BY_NAME, ADVANCED) boolean = FALSE
  status)

" PURPOSE: This procedure activates the system job for the X.400 Transfer Facility.

" Define constants local to this activation procedure.

  "$FORMAT=OFF"
  VAR
    default_log_option_value: (READ) name = startup
    default_password_checking_value: (READ) boolean = false
    default_xfer_retry_delay_value: (READ) integer = 600
    osiam_binary_log: (READ) file = :$system.$system.xtf.osiam_binary_log
    xtf_active_configuration: (READ) file = :$system.$system.xtf.active_configuration
    xtf_base_configuration: (READ) file = :$system.$system.xtf.base_configuration
    xtf_job_output: (READ) file = $fname('$system.xtf.xtf_output_'//$mainframe(id))
    xtf_product_library: (READ) file = :$system.$system.xtf.bound_product
    xtf_starting_procedure: (READ) name = nfp$rts_mailve_main_task_entry
    xtf_user_job_name: (READ) name = $name('XTF'//$mainframe(id))
  VAREND
  "$FORMAT=ON"

" Declare variables local to this activation procedure.

  "$FORMAT=OFF"
  VAR
    editing_directives: file
    local_status: status
    replace_text_command: string
    task_parameter_list: string
    xtf_system_job_name: name
  VAREND
  "$FORMAT=ON"

  editing_directives = $unique($local)

" Verify the procedure has been called by a system operator job.

  IF NOT $job_validation(system_operation) THEN
    EXIT procedure WITH $status(false, 'RA', 0, 'XTF can only be activated by a system operator.')
  IFEND

" Verify the XTF bound product file is installed.

  IF (NOT $first($file_attributes(xtf_product_library, registered)).registered) THEN
    EXIT procedure WITH $status(false, 'RA', 0, 'The XTF product is not installed.')
  IFEND

" Verify the XTF bound product file has the correct ring attributes.

  IF (($first($file_attributes(xtf_product_library, ring_attributes)).ring_attributes.r1 <> 6) OR ($first(..
        $file_attributes(xtf_product_library, ring_attributes)).ring_attributes.r2 <> 6) OR ($first(..
        $file_attributes(xtf_product_library, ring_attributes)).ring_attributes.r3 <> 13)) THEN
    EXIT procedure WITH $status(false, 'RA', 0, 'The XTF product has improper ring attributes.')
  IFEND

" Verify that the XTF configuration file exists.

  IF (NOT $first($file_attributes(xtf_base_configuration, registered)).registered) THEN
    EXIT procedure WITH $status(false, 'RA', 0, $string(xtf_base_configuration)//' does not exist.')
  IFEND

" Check for the presence of an existing XTF job.

  MANAGE_JOBS
    select_jobs job_state=(deferred, queued, initiated) name=xtf_user_job_name status=local_status
    IF local_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        EXIT procedure WITH $status(false, 'RA', 0 ..
              'An identical XTF job was found. XTF will not be activated')
      IFEND
    ELSE
      EXIT procedure WITH local_status
    IFEND
  QUIT

" Create the active configuration file.

  TASK ring=4
    copy_file input=xtf_base_configuration output=xtf_active_configuration
    change_file_attribute file=xtf_active_configuration ring_attributes=(11, 11, 11)
  TASKEND

  IF $specified(log_option) AND (log_option <> default_log_option_value) THEN
    IF (log_option = rts_only) THEN

" Define the command to change the log level for the RTS User task, task 15 only.

      replace_text_command = ..
            'replace_text text=''log_level=0'' new_text=''log_level=8''  lines=current..last number=1'
    ELSE

" Define the command to change the log level for all tasks.

      replace_text_command = ..
            'replace_text text=''log_level=0'' new_text=''log_level=8''  lines=current..last number=all'
    IFEND

" Generate the editing directives to adjust the log option value in the active configuration file.

COLLECT_TEXT output=editing_directives until='///END_EDIT_DIRECTIVES\\\' substitution_mark='?'
  locate_text text='Logging options' lines=all number=2
  ?replace_text_command?

  locate_text text='debug off' lines=all number=1
  replace_text text='debug off' new_text='debug on' line=current
///END_EDIT_DIRECTIVES\\\
  IFEND

  IF $specified(transfer_retry_delay) AND (transfer_retry_delay <> default_xfer_retry_delay_value) THEN

" Generate the editing directives to adjust the transfer retry delay in the active configuration file.

COLLECT_TEXT output=editing_directives.$eoi until='///END_EDIT_DIRECTIVES\\\'
  locate_text text='transfer_retry_delay' lines=all number=1
  replace_text text=$string(default_xfer_retry_delay_value) new_text=$string(transfer_retry_delay) ..
        line=current
///END_EDIT_DIRECTIVES\\\
  IFEND

  IF $specified(enable_password_checking) AND enable_password_checking <> default_password_checking_value THEN

" Generate the editing directives to adjust the password checking value in the active configuration file.

COLLECT_TEXT output=editing_directives.$eoi until='///END_EDIT_DIRECTIVES\\\'
  locate_text text='enable_password_checking' lines=all number=1
  replace_text text='false' new_text='true' line=current
///END_EDIT_DIRECTIVES\\\
  IFEND

" Generate the editing directives to process the UNKNOWN_MTA_CONNECTIONS parameter, the commands which
" revise the base configuration commands for compatibility with OSIAM version 2.4B and above, and the
" commands which enable trace information generation for all SAPs and entities.

COLLECT_TEXT output=editing_directives.$eoi until='///END_EDIT_DIRECTIVES\\\' sm='?'
  VAR
    editing_directives_status: status
  VAREND

" Find the line in the active configuration which would proceed the UNKNOWN entry.

  position_cursor text='Remote MTA(s)' l=all

  position_cursor text='UNKNOWN' status=editing_directives_status
  IF editing_directives_status.normal THEN
    replace_line text='mcc=0 msc='..
          new_text='       mcc=0 msc=?unknown_mta_connections?  client_connection_idle_timeout=180'' ..'
  ELSEIF ?unknown_mta_connections? <> 0 THEN

" The UNKNOWN entry should be inserted at the end of remote MTA list; advance to the end of the list.

    position_cursor text='-----' number=2

    insert_lines placement=before until='///END_INSL_TEXT\\\'
 send_command 'define_mta mta_name=''UNKNOWN'' password='''' ..
        mcc=0 msc=?unknown_mta_connections? client_connection_idle_timeout=180' ..
        job_number=0 task_number=0 module_number=15
///END_INSL_TEXT\\\
  IFEND

" In OSIAM version 2.4B and beyond, session version 1 is selected via RTS entity flags. Disable the
" configuration file commands which alter the session entity directly as was required by previous OSIAM
" versions.

  replace_text text=' send_command ''vary entity 50 flag 0 0 off' ..
        new_text='"send_command ''vary entity 50 flag 0 0 off' ..
        lines=all status="ignore" editing_directives_status

  replace_text text=' send_command ''vary entity 50 flag 0 1 on' ..
        new_text='"send_command ''vary entity 50 flag 0 1 on' ..
        lines=all status="ignore" editing_directives_status

  locate_text text='Block_size' lines=all number=1

  insert_lines placement=before until='///END_INSL_TEXT\\\'

" Increase the number of connections in the session and RTS layers.

 send_command 'define entity 50 200 64 '  ..
       job_number=0 task_number=0 module_number=2

 send_command 'define entity 60 200 64 '  ..
       job_number=0 task_number=0 module_number=2

" Select session version 1 using RTS entity flags.

 send_command 'vary entity 60 flag 0 6 on' ..
       job_number=0 task_number=0 module_number=2

///END_INSL_TEXT\\\

" For OSIAM versions 2.4B and greater, the block size of 4K should be specified. Replace the configuration
" file commands which specify the 8K block size which was appropriate for previous OSIAM versions.

   replace_text text='vary entity 60 parm 3 8'  new_text='vary entity 60 parm 3 4' ..
       lines=all status="ignore" editing_directives_status

" For OSIAM versions 2.4B and greater, the offline configuration contains all necessary SAP definitions. Delete the
" configuration file commands which defined intermediate SAPS for previous OSIAM versions.

  locate_text text='define sap 20 17' lines=all number=1
  delete_text number=2

" Enable trace for all entities.

  locate_text text='debug' lines=all number=1
  insert_lines placement=before until='///END_INSL_TEXT\\\'
 send_command 'var sap 19 trace on'           job_number=0 task_number=0 module_number=2
 send_command 'var sap 20 trace on'           job_number=0 task_number=0 module_number=2
 send_command 'var sap 21 trace on'           job_number=0 task_number=0 module_number=2
 send_command 'var sap 17 trace on'           job_number=0 task_number=0 module_number=2
 send_command 'var ent 53 trace 0 on'         job_number=0 task_number=0 module_number=2
///END_INSL_TEXT\\\

///END_EDIT_DIRECTIVES\\\

  IF $first($file_attributes(editing_directives, size)).size > 0 THEN

" Customize the active configuration file using EDIT_FILE. A seperate task is created to bypass problems
" which could result if this procedure is called from within the EDIT_FILE utility.

    TASK
      $system.edit_file file=xtf_active_configuration input=editing_directives output=$null prolog=$null
    TASKEND
  IFEND

  delete_file file=editing_directives status="ignore" local_status

  task_parameter_list = 'command_file='//xtf_active_configuration
  task_parameter_list = task_parameter_list//' log_file='//osiam_binary_log
  task_parameter_list = task_parameter_list//' unknown_mta_connections='//unknown_mta_connections
  task_parameter_list = $quote(task_parameter_list)

  JOB user_job_name=xtf_user_job_name job_abort_disposition=terminate job_class=job_class ..
        job_recovery_disposition=terminate output_disposition=xtf_job_output substitution_mark='?' ..
        system_job_name=xtf_system_job_name status=local_status

    VAR
      abort_file: file = $unique($local)
      binary_log_file: name
      date_time_stamp: string
      local_status: status
      maximum_restart_attempts: integer = ?maximum_restart_attempts?
      number_of_restarts: integer = 0
      nfv$notify_after_aborting: boolean = ?notify_after_aborting?
      status_string_value: list of string
    VAREND

    WHEN exit DO
        change_file_attributes f=?osiam_binary_log? ra=(11, 11, 11) status="ignore" local_status
    WHENEND

    change_message_level il=full status="ignore" local_status
    change_working_catalog c=$system.xtf

    SYSTEM_OPERATOR_UTILITY
      TASK ring=6

        set_debug_ring ring=6
        put_line 'display_calls do=ac' output=abort_file
        set_program_attributes preset_value=zero abort_file=abort_file

        delete_file file=?osiam_binary_log? status="ignore" local_status

        REPEAT
          IF number_of_restarts > 0 THEN
            display_message message=' ' to=job
            display_message message='***The X.400 Transfer Facility has aborted with the following status:' ..
                  to=job

            status_string_value = $string(local_status)

            FOR EACH status_string_list_element IN status_string_value DO
              display_message message=status_string_list_element to=job
            FOREND

" Regardless of the value specified for the MAXIMUM_RESTART_ATTEMPTS parameter, capture no more than ten
" binary log files.

            IF (number_of_restarts <= 10) AND ?(log_option <> startup)? THEN

" Obtain the current date and time in order to produce a distinct file name for the OSIAM binary log. Distinct
" names are used so the next abort will not overwrite the information from the previous abort.

              date_time_stamp = $date('Y2M2D2')//'_'//$time('H24MMSS')

              IF $first($file_attributes(?osiam_binary_log?, registered)).registered THEN

" XTF/VE executed long enough to generate an OSIAM binary log. Alter the name of the OSIAM binary log to
" contain the date time stamp for this abort.

                binary_log_file = $name('osiam_binary_log_'//date_time_stamp)

                change_catalog_entry file=?osiam_binary_log? new_file_name=binary_log_file status=local_status
                IF local_status.normal THEN
                  change_file_attributes f=$fname($path(?osiam_binary_log?, catalog)//'.'//binary_log_file) ..
                        ra=(11, 11, 11) status="ignore" local_status
                ELSE
                  display_message ..
                        message='***Attempt to capture OSIAM binary log failed with the following status:' ..
                        to=job

                  status_string_value = $string(local_status)

                  FOR EACH status_string_list_element IN status_string_value DO
                    display_message message=status_string_list_element to=job
                  FOREND
                IFEND
              IFEND
            IFEND

            put_line line=' '
            put_line line='***Attempting restart #'//$string(number_of_restarts)

            display_message message='***Attempting restart #'//$string(number_of_restarts) to=(job, ..
                  job_message)
            display_message message=' ' to=job

            display_log o=?xtf_job_output? do=all
            change_file_attributes f=?xtf_job_output? ra=(11, 11, 11)


" A small (7 1/2 second) delay is forced before the next restart attempt. The delay will reduce the impact
" on the system should the X.400 transfer facility continuously abort immediately after beginning execution.

            wait time=0-0-0.00:00:07.500
          IFEND

          execute_task parameters=?task_parameter_list? library=?xtf_product_library? ..
                starting_procedure=?xtf_starting_procedure? load_map=$null load_map_options=none pv=zero ..
                abort_file=abort_file termination_error_level=error status=local_status

          number_of_restarts = number_of_restarts + 1

        UNTIL (number_of_restarts > maximum_restart_attempts)

      TASKEND
    END_SYSTEM_OPERATOR_UTILITY

    IF ($variable(nfv$notify_after_aborting, defined)) AND ..
          ($job_status($job(system_job_name), job_state) <> terminated) THEN
      IF nfv$notify_after_aborting THEN
        send_operator_message m='X.400 Transfer Facility failed, see ?xtf_job_output?' oc=system_operator
      IFEND
    IFEND
  JOBEND

  IF local_status.normal THEN
    put_line line=' XTF has been activated as job  '//..
$string(xtf_user_job_name)//' ('//$string(xtf_system_job_name)//').' o=$response
  ELSE
    EXIT procedure WITH local_status
  IFEND

PROCEND activate_xtf
*DECK DECK=RAM$ACTIVATE_YPBIND EXPAND=TRUE
PROCEDURE activate_ypbind, activate_yp_binding, actypbind, actyb (
  default_domain, dd: application = $null
  server_ip_address, sia: application = $null
  debug, d: boolean = FALSE
  epilog, e: file = nfd$epilog, $system.tcp_ip.onc.epilog
  status)

"   This procedure is on the OS source_library because it resides
"   on osf$builtin_library.  The ONC products are on the NFS source
"   library.  To minimize the number of times a mod is required
"   to both source libraries the activate procs call start procs
"   passing all the parameters required data.  The start procs reside on
"   onc.command_library which is under NFS code control.


  VAR
    nfd$epilog: (push) string = $string(epilog)
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  tcp_ip.onc.command_library.start_ypbind dd=default_domain sia=server_ip_address d=debug

PROCEND activate_ypbind
*DECK DECK=RAM$ACTIVATE_YPPASSWDD EXPAND=TRUE
PROCEDURE activate_yppasswdd, activate_yp_passwd_daemon, actypd (
  debug, d: boolean = FALSE
  epilog, e: file = nfd$epilog, $system.tcp_ip.onc.epilog
  status)

"   This procedure is on the OS source_library because it resides
"   on osf$builtin_library.  The ONC products are on the NFS source
"   library.  To minimize the number of times a mod is required
"   to both source libraries the activate procs call start procs
"   passing all the parameters required data.  The start procs reside on
"   onc.command_library which is under NFS code control.


  VAR
    nfd$epilog: (push) string = $string(epilog)
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  tcp_ip.onc.command_library.start_yppasswdd d=debug

PROCEND activate_yppasswdd
*DECK DECK=RAM$ACTIVATE_YPSERV EXPAND=TRUE
PROCEDURE activate_ypserv, activate_yp_server, actypserv, actys (
  debug, d: boolean = FALSE
  epilog, e: file = nfd$epilog, $system.tcp_ip.onc.epilog
  status)

"   This procedure is on the OS source_library because it resides
"   on osf$builtin_library.  The ONC products are on the NFS source
"   library.  To minimize the number of times a mod is required
"   to both source libraries the activate procs call start procs
"   passing all the parameters required data.  The start procs reside on
"   onc.command_library which is under NFS code control.


  VAR
    nfd$epilog: (push) string = $string(epilog)
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  tcp_ip.onc.command_library.start_ypserv d=debug

PROCEND activate_ypserv
*DECK DECK=RAM$ACTIVATE_YPUPDATED EXPAND=TRUE
PROCEDURE activate_ypupdated, activate_yp_update_daemon, actyud (
  debug, d: boolean = FALSE
  epilog, e: file = nfd$epilog, $system.tcp_ip.onc.epilog
  status)

"   This procedure is on the OS source_library because it resides
"   on osf$builtin_library.  The ONC products are on the NFS source
"   library.  To minimize the number of times a mod is required
"   to both source libraries the activate procs call start procs
"   passing all the parameters required data.  The start procs reside on
"   onc.command_library which is under NFS code control.


  VAR
    nfd$epilog: (push) string = $string(epilog)
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  tcp_ip.onc.command_library.start_ypupdated d=debug

PROCEND activate_ypupdated
*DECK DECK=RAM$ACTIVATE_YPXFRD EXPAND=TRUE
PROCEDURE activate_ypxfrd, activate_yp_transfer_daemon, actyxd (
  debug, d: boolean = FALSE
  epilog, e: file = nfd$epilog, $system.tcp_ip.onc.epilog
  status)

"   This procedure is on the OS source_library because it resides
"   on osf$builtin_library.  The ONC products are on the NFS source
"   library.  To minimize the number of times a mod is required
"   to both source libraries the activate procs call start procs
"   passing all the parameters required data.  The start procs reside on
"   onc.command_library which is under NFS code control.


  VAR
    nfd$epilog: (push) string = $string(epilog)
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  tcp_ip.onc.command_library.start_ypxfrd d=debug tcp_ip=tcp_ip

PROCEND activate_ypxfrd
*DECK DECK=RAM$ADD_APPLIER EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$add_applier;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc rac$status_id
*copyc rae$error_messages
*copyc rat$correction_package_header
*copyc rat$correction_package
*copyc rav$elements
*copyc rav$correction_package_header
*copyc rav$corp
*copyc amp$fetch_access_information
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc clp$scan_parameter_list
*copyc clp$get_path_description
*copyc clp$get_value
*copyc fsp$open_file
*copyc fsp$close_file
*copyc osp$set_status_abnormal
?? POP ??

*copyc rah$add_applier

  PROCEDURE [XDCL] rap$add_applier (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{  pdt adda_pdt (
{    correction_package, cp: file = $required
{    applier, a: file = $required
{    status)

?? PUSH (LISTEXT := ON) ??

    VAR
      adda_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^adda_pdt_names, ^adda_pdt_params];

    VAR
      adda_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
        clt$parameter_name_descriptor := [['CORRECTION_PACKAGE', 1], ['CP', 1], ['APPLIER', 2], ['A', 2], [
        'STATUS', 3]];

    VAR
      adda_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ CORRECTION_PACKAGE CP }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ APPLIER A }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      applier: amt$segment_pointer,
      applier_fid: amt$file_identifier,
      applier_file: ^SEQ ( * ),
      applier_lfn: amt$local_file_name,
      applier_path: clt$path_name,
      correction_package: amt$segment_pointer,
      cycle_sel: clt$cycle_selector,
      end_of_cp: ^SEQ ( * ),
      file_ref: clt$file_reference,
      ignore_status: ost$status,
      message_status: ost$status,
      offset: array [1 .. 1] of amt$access_info,
      open_p: clt$open_position,
      package_applier: ^SEQ ( * ),
      package_fid: amt$file_identifier,
      package_header: ^rat$correction_package_header,
      package_lfn: amt$local_file_name,
      package_path: clt$path_name,
      path: ^pft$path,
      path_container: clt$path_container,
      read_only_attachment: array [1 .. 2] of fst$attachment_option,
      value: clt$value,
      write_attachment: array [1 .. 2] of fst$attachment_option;


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, adda_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    {  Open the CORRECTION_PACKAGE   for write segment access. }

    clp$get_value ('CORRECTION_PACKAGE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    package_lfn := value.file.local_file_name;

    clp$get_path_description (value.file, file_ref, path_container, path, cycle_sel, open_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    package_path := file_ref.path_name (1, file_ref.path_name_size);

    write_attachment [1].selector := fsc$access_and_share_modes;
    write_attachment [1].access_modes.selector := fsc$specific_access_modes;
    write_attachment [1].access_modes.value := $fst$file_access_options [fsc$read, fsc$append,
          fsc$modify];
    write_attachment [1].share_modes.selector := fsc$determine_from_access_modes;
    write_attachment [2].selector := fsc$create_file;
    write_attachment [2].create_file := FALSE;

    fsp$open_file (package_lfn, amc$segment, ^write_attachment, NIL, NIL, NIL, NIL, package_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /add_applier_command/
    BEGIN


      {  Verify that the CORRECTION PACKAGE is a compatable version   }
      { and that an APPLIER is'nt already present.                    }

      amp$get_segment_pointer (package_fid, amc$sequence_pointer, correction_package, status);
      IF NOT status.normal THEN
        EXIT /add_applier_command/;
      IFEND;

      RESET correction_package.sequence_pointer;
      NEXT package_header IN correction_package.sequence_pointer;
      IF (package_header = NIL) OR (package_header^.identification <> rac$correction_package_id) THEN
        osp$set_status_abnormal (rac$status_id, rae$file_not_correction_package, package_path, status);
        EXIT /add_applier_command/;
      IFEND;

      IF package_header^.version <> rac$correction_package_version THEN
        osp$set_status_abnormal (rac$status_id, rae$invalid_cp_version, package_path, status);
        EXIT /add_applier_command/;
      IFEND;

      IF package_header^.size_of_applier > 0 THEN
        osp$set_status_abnormal (rac$status_id, rae$applier_already_exists, package_path, status);
        EXIT /add_applier_command/;
      IFEND;


      {  Open the APPLIER for read only segment access. }

      clp$get_value ('APPLIER', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /add_applier_command/;
      IFEND;
      applier_lfn := value.file.local_file_name;

      clp$get_path_description (value.file, file_ref, path_container, path, cycle_sel, open_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      applier_path := file_ref.path_name (1, file_ref.path_name_size);

      read_only_attachment [1].selector := fsc$access_and_share_modes;
      read_only_attachment [1].access_modes.selector := fsc$specific_access_modes;
      read_only_attachment [1].access_modes.value := $fst$file_access_options [fsc$read];
      read_only_attachment [1].share_modes.selector := fsc$determine_from_access_modes;
      read_only_attachment [2].selector := fsc$create_file;
      read_only_attachment [2].create_file := FALSE;

      fsp$open_file (applier_lfn, amc$segment, ^read_only_attachment, NIL, NIL, NIL, NIL, applier_fid,
            status);
      IF NOT status.normal THEN
        EXIT /add_applier_command/;
      IFEND;

      amp$get_segment_pointer (applier_fid, amc$sequence_pointer, applier, status);
      IF NOT status.normal THEN
        EXIT /add_applier_command/;
      IFEND;

      RESET applier.sequence_pointer;

      package_header^.size_of_applier := #SIZE (applier.sequence_pointer^);
      NEXT applier_file: [[REP package_header^.size_of_applier OF cell]] IN applier.sequence_pointer;
      IF applier_file = NIL THEN
        osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, applier_path, status);
        EXIT /add_applier_command/;
      IFEND;


      {  Append the APPLIER to the end of the CORRECTION_PACKAGE and }
      { set the applier pointer in the header.                       }

      offset [1].key := amc$eoi_byte_address;

      amp$fetch_access_information (package_fid, offset, status);
      IF NOT status.normal THEN
        EXIT /add_applier_command/;
      IFEND;

      RESET correction_package.sequence_pointer;
      NEXT end_of_cp: [[REP offset [1].eoi_byte_address OF cell]] IN correction_package.
            sequence_pointer;
      IF end_of_cp = NIL THEN
        osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, package_path, status);
        EXIT /add_applier_command/;
      IFEND;

      NEXT package_applier: [[REP package_header^.size_of_applier OF cell]] IN correction_package.
            sequence_pointer;
      IF package_applier = NIL THEN
        osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, package_path, status);
        EXIT /add_applier_command/;
      IFEND;

      package_applier^ := applier_file^;
      package_header^.applier := #REL (package_applier, correction_package.sequence_pointer^);

      amp$set_segment_eoi (package_fid, correction_package, status);
      IF NOT status.normal THEN
        EXIT /add_applier_command/;
      IFEND;

    END /add_applier_command/;

    IF status.normal THEN
      fsp$close_file (package_fid, status);
    ELSE
      fsp$close_file (package_fid, ignore_status);
    IFEND;

    IF status.normal THEN
      fsp$close_file (applier_fid, status);
    ELSE
      fsp$close_file (applier_fid, ignore_status);
    IFEND;

    IF NOT status.normal THEN
      RETURN;
    IFEND;


  PROCEND rap$add_applier;
MODEND ram$add_applier;
*DECK DECK=RAM$ADD_COPYRIGHT EXPAND=TRUE
PROCEDURE add_copyright, addcr(
  module, m: name = $required
  status)

"----------------------------------------------------------------------"

" ADD_COPYRIGHT
"
" PURPOSE:
"
"  Change the comment field on the module specified to read:
"  Copyright Control Data Systems Inc. yyyy
"
" PARAMETERS:
"
" Module: Name of the module to be changed.
"----------------------------------------------------------------------"
  change_module_attributes module=module comment='Copyright Control Data Systems Inc. '//$substr($date(iso), 1, 4)

PROCEND add_copyright
*DECK DECK=RAM$ADD_CORRECTION EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$add_correction;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc rac$status_id
*copyc rae$error_messages
*copyc rat$correction_package_header
*copyc rat$correction_package
*copyc rav$elements
*copyc rav$correction_package_header
*copyc rav$corp
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc clp$scan_parameter_list
*copyc clp$get_value
*copyc clp$get_set_count
*copyc clp$get_path_description
*copyc fsp$open_file
*copyc fsp$close_file
*copyc osp$set_status_abnormal
*copyc rap$issue_message
*copyc rap$merge_correctors
*copyc rap$move_correction
?? POP ??

{ pdt add_pdt (
{   correction_package, cp: file = $required
{   element, elements, e: list of name
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    add_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^add_pdt_names, ^add_pdt_params];

  VAR
    add_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of clt$parameter_name_descriptor
      := [['CORRECTION_PACKAGE', 1], ['CP', 1], ['ELEMENT', 2], ['ELEMENTS', 2], ['E', 2], ['STATUS', 3]];

  VAR
    add_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ CORRECTION_PACKAGE CP }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ ELEMENT ELEMENTS E }
    [[clc$optional], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
      osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

*copyc rah$add_correction

  PROCEDURE [XDCL] rap$add_correction (parameter_list: clt$parameter_list;
    VAR status: ost$status);

    VAR
      add_correction_elements: ^rat$correction_package,
      add_fid: amt$file_identifier,
      add_package: ^SEQ ( * ),
      add_package_applier: ^SEQ ( * ),
      add_package_header: ^rat$correction_package_header,
      add_package_lfn: amt$local_file_name,
      add_seg: amt$segment_pointer,
      applier: amt$segment_pointer,
      applier_fid: amt$file_identifier,
      applier_file: ^SEQ ( * ),
      applier_lfn: amt$local_file_name,
      attribute: array [1 .. 1] of fst$file_cycle_attribute,
      cp_path: clt$path_name,
      cycle_sel: clt$cycle_selector,
      element_list: ^array [1 .. * ] of ost$name,
      file_ref: clt$file_reference,
      found: boolean,
      hi: rat$element_index,
      i: rat$element_index,
      ignore_status: ost$status,
      j: rat$element_index,
      k: rat$element_index,
      l: rat$element_index,
      low: rat$element_index,
      message_status: ost$status,
      mid: rat$element_index,
      number: 0 .. clc$max_value_sets,
      open_p: clt$open_position,
      os_elements: ^array [1 .. * ] of ost$name,
      output_lfn: [STATIC, READ] amt$local_file_name := '$OUTPUT',
      path: ^pft$path,
      path_container: clt$path_container,
      read_only_attachment: array [1 .. 2] of fst$attachment_option,
      temp: integer,
      temp_elements: ^array [1 .. * ] of ost$name,
      value: clt$value,
      write_attachment: array [1 .. 3] of fst$attachment_option;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, add_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('CORRECTION_PACKAGE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    add_package_lfn := value.file.local_file_name;

    clp$get_path_description (value.file, file_ref, path_container, path, cycle_sel, open_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    cp_path := file_ref.path_name (1, file_ref.path_name_size);

    read_only_attachment [1].selector := fsc$access_and_share_modes;
    read_only_attachment [1].access_modes.selector := fsc$specific_access_modes;
    read_only_attachment [1].access_modes.value := $fst$file_access_options [fsc$read];
    read_only_attachment [1].share_modes.selector := fsc$determine_from_access_modes;
    read_only_attachment [2].selector := fsc$create_file;
    read_only_attachment [2].create_file := FALSE;

    fsp$open_file (add_package_lfn, amc$segment, ^read_only_attachment, NIL, NIL, NIL, NIL, add_fid,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (add_fid, amc$sequence_pointer, add_seg, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    add_package := add_seg.sequence_pointer;

    RESET add_package;
    NEXT add_package_header IN add_package;
    IF (add_package_header = NIL) OR (add_package_header^.identification <> rac$correction_package_id) THEN
      osp$set_status_abnormal (rac$status_id, rae$file_not_correction_package, cp_path, status);
      RETURN;
    IFEND;

    IF add_package_header^.version <> rac$correction_package_version THEN
      osp$set_status_abnormal (rac$status_id, rae$invalid_cp_version, cp_path, status);
      RETURN;
    IFEND;

    NEXT add_correction_elements: [1 .. add_package_header^.number_of_elements] IN add_package;
    IF add_correction_elements = NIL THEN
      osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, cp_path, status);
      RETURN;
    IFEND;

    clp$get_set_count ('ELEMENT', number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF number > 0 THEN
      k := 1;
      l := 1;
      ALLOCATE temp_elements: [1 .. number];
      FOR i := 1 TO number DO
        clp$get_value ('ELEMENT', i, 1, clc$low, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF (value.name.value = 'OS') AND (k = 1) THEN
          ALLOCATE os_elements: [1 .. add_package_header^.number_of_elements];
          FOR j := 1 TO add_package_header^.number_of_elements DO
            IF add_correction_elements^ [j].class = rac$os THEN
              os_elements^ [k] := add_correction_elements^ [j].name;
              k := k + 1;
            IFEND;
          FOREND;
        ELSEIF (value.name.value <> 'OS') THEN
          temp_elements^ [l] := value.name.value;
          l := l + 1;
        IFEND;
      FOREND;
      number := l - 1 + k - 1;
      PUSH element_list: [1 .. number];
      FOR i := 1 TO l - 1 DO
        element_list^ [i] := temp_elements^ [i];
      FOREND;
      j := 1;
      FOR i := l TO (k - 2 + l) DO
        element_list^ [i] := os_elements^ [j];
        j := j + 1;
      FOREND;
      FREE temp_elements;
      IF k > 1 THEN
        FREE os_elements;
      IFEND;
    IFEND;

    IF number = 0 THEN
      FOR j := 1 TO add_package_header^.number_of_elements DO
        rap$merge_correctors (add_package, j, add_correction_elements, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    ELSEIF number > 0 THEN

    /merge/
      FOR k := 1 TO number DO
        found := FALSE;
        hi := add_package_header^.number_of_elements;
        low := 1;
        WHILE (low <= hi) AND NOT found DO
          temp := low + hi;
          mid := temp DIV 2;
          IF element_list^ [k] = add_correction_elements^ [mid].name THEN
            found := TRUE;
          ELSEIF (element_list^ [k] < add_correction_elements^ [mid].name) THEN
            hi := mid - 1;
          ELSE
            low := mid + 1;
          IFEND;
        WHILEND;
        IF NOT found THEN
          osp$set_status_abnormal (rac$status_id, rae$element_not_found, element_list^ [k], message_status);
          rap$issue_message (output_lfn, message_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          CYCLE /merge/
        IFEND;
        rap$merge_correctors (add_package, mid, add_correction_elements, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND /merge/;
    IFEND;


    {  When an APPLIER is found on  the CORRECTION_PACKAGE you are   }
    { adding from, copy that APPLIER to $LOCAL.APPLIER.$EOI and put  }
    { out an informative message to the user.                        }

    IF add_package_header^.size_of_applier > 0 THEN

      osp$set_status_abnormal (rac$status_id, rae$applier_copied_to_lfn, cp_path, message_status);
      rap$issue_message (output_lfn, message_status, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      add_package_applier := #PTR (add_package_header^.applier, add_package^);
      RESET add_package TO add_package_applier;
      NEXT add_package_applier: [[REP add_package_header^.size_of_applier OF cell]] IN add_package;
      IF add_package_applier = NIL THEN
        osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, cp_path, status);
        RETURN;
      IFEND;

      applier_lfn := 'APPLIER                        ';

      write_attachment [1].selector := fsc$access_and_share_modes;
      write_attachment [1].access_modes.selector := fsc$specific_access_modes;
      write_attachment [1].access_modes.value := $fst$file_access_options [fsc$read, fsc$append, fsc$modify];
      write_attachment [1].share_modes.selector := fsc$determine_from_access_modes;
      write_attachment [2].selector := fsc$create_file;
      write_attachment [2].create_file := TRUE;
      write_attachment [3].selector := fsc$open_position;
      write_attachment [3].open_position := amc$open_at_eoi;

      attribute [1].selector := fsc$record_type;
      attribute [1].record_type := amc$variable;

      fsp$open_file (applier_lfn, amc$segment, ^write_attachment, ^attribute, NIL, NIL, NIL, applier_fid,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    /copy_applier_to_lfn/
      BEGIN

        amp$get_segment_pointer (applier_fid, amc$sequence_pointer, applier, status);
        IF NOT status.normal THEN
          EXIT /copy_applier_to_lfn/;
        IFEND;

        NEXT applier_file: [[REP add_package_header^.size_of_applier OF cell]] IN applier.sequence_pointer;
        IF applier_file = NIL THEN
          osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, applier_lfn, status);
          EXIT /copy_applier_to_lfn/;
        IFEND;

        applier_file^ := add_package_applier^;

        amp$set_segment_eoi (applier_fid, applier, status);
        IF NOT status.normal THEN
          EXIT /copy_applier_to_lfn/;
        IFEND;

      END /copy_applier_to_lfn/;

      IF status.normal THEN
        fsp$close_file (applier_fid, status);
      ELSE
        fsp$close_file (applier_fid, ignore_status);
      IFEND;
    IFEND;

    IF status.normal THEN
      fsp$close_file (add_fid, status);
    ELSE
      fsp$close_file (add_fid, ignore_status);
    IFEND;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$add_correction;
MODEND ram$add_correction;
*DECK DECK=RAM$ADD_DEVICE_INTERFACE EXPAND=TRUE
PROCEDURE  add_device_interface, adddi (
  type, t: key mdi, mti, ndi, tdi, ica_ii, keyend = $required
  procedure_name, pn: name = $required
  di_procedure_file, dpf: file
  ethernet_network_id, eni: string = $optional
  ve_interface_network_id, vini: string = $optional
  status)


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"     The purpose of this request is to create a CDCNET device
"configuration procedure using a template contained in
"$SYSTEM.CDCNET.SITE_CONTROLLED.CONFIGURATION.  This is to
"help the first time installer bring up a CDCNET device.
"
*IFEND


  WHEN any_fault DO
    detach_file $fname(configuration_file) status=ignore_status
    detach_file $value(di_procedure_file) status=ignore_status
    EXIT_PROC WITH osv$status
  WHENEND


    create_variable ignore_status k=status
    create_variable local_status k=status
    create_variable configuration_file k=string v='$system.cdcnet.site_controlled.configuration'
    create_variable configuration_proc k=string v='$local.'//$unique
    create_variable procedure_name k=string v=$string($value(procedure_name))

  "Pull out the skeleton procedure"

  $system.osf$command_library.create_object_library
    add_module l=$fname(configuration_file) m=$name($value(type)) status=local_status
    IF local_status.normal THEN
      generate_library l=$fname(configuration_proc) f=scl_proc
    ELSE
      put_line ' --ERROR-- Unable to access CDCNET device configuration procedures.' o=$response
    IFEND
  quit

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

  "Edit in the proper procedure name"

  old_proc = 'PROC ' // $translate(ltu, $string($value(type)))
  new_proc = 'PROC ' // procedure_name
  old_procend = 'PROCEND ' // $translate(ltu, $string($value(type)))
  new_procend = 'PROCEND ' // procedure_name

 $system.edit_file $fname(configuration_proc) o=$null
    replace_text old_proc new_proc uc=yes
    IF ($specified(di_procedure_file)) THEN
      locate_text t='define_line'
      read_file f=$value(di_procedure_file) p=b
    IFEND
    IF $specified(ethernet_network_id) AND (type = mdi) THEN
      old_network_id = 'network_id = 1000(10)'
      new_network_id = 'network_id = '//ethernet_network_id
      replace_text old_network_id  new_network_id
    ELSEIF $specified(ethernet_network_id) AND (type = ica_ii) THEN
      old_network_id = 'network_id = 2000(10)'
      new_network_id = 'network_id = '//ethernet_network_id
      replace_text old_network_id  new_network_id
    IFEND
    replace_text old_procend new_procend uc=yes
    IF $specified(ve_interface_network_id) THEN
      insert_line new_text='define_ve_interface network_id='//ve_interface_network_id//'' p=before il=last
    IFEND
  end

  "Write the updated configuration library"

  IF local_status.normal THEN
    $system.osf$command_library.create_object_library
      add_module l=$fname(configuration_file)
      combine_module l=$fname(configuration_proc) status=local_status
      IF local_status.normal THEN
        generate_library l=$fname(configuration_file//'.$next')
      ELSE
        put_line ' --ERROR--  Unable to add new CDCNET device configuration procedure to library.' o=$response
      IFEND
    quit

    "Clean up even if creol fails"
    detach_file ($fname(configuration_proc)) status=ignore_status
    detach_file $fname(configuration_file) status=ignore_status
    detach_file $value(di_procedure_file) status=ignore_status

    EXIT_PROC WITH local_status WHEN NOT local_status.normal

  ELSE
    put_line ' --ERROR--  Unable to access CDCNET device configuration procedures.' o=$response
    EXIT_PROC WITH local_status
  IFEND

  put_line ('  ', ' CDCNET configuration procedure '//procedure_name//' installed', '  ') o=$response

PROCEND add_device_interface
*DECK DECK=RAM$ADD_OSI_ADDRESS EXPAND=TRUE

create_program_description (ADD_OSI_ADDRESS, ADD_OSI_ADDRESSES, ADDOSIA) l='$system.osf$system_library'..
      sp=nap$add_osi_address lm=$null lmo=none tel=warning dm=off

*DECK DECK=RAM$ADD_PSRS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$add_psrs;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc rac$correction_constants
*copyc rac$status_id
*copyc rae$error_messages
*copyc rav$corp
*copyc rav$correction_package_header
*copyc rav$elements
*copyc rat$psr_info
*copyc rat$correction_package
*copyc clp$scan_parameter_list
*copyc clp$get_value
*copyc amp$open
*copyc amp$close
*copyc amp$get_next
*copyc osp$set_status_abnormal
*copyc rap$issue_message
*copyc rap$get_corrector_element
?? POP ??

{ pdt add_psrs_pdt (
{   psr_info, pi: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    add_psrs_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^add_psrs_pdt_names,
      ^add_psrs_pdt_params];

  VAR
    add_psrs_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['PSR_INFO', 1], ['PI', 1], ['STATUS', 2]];

  VAR
    add_psrs_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ PSR_INFO PI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

*copyc rah$add_psrs

  PROCEDURE [XDCL] rap$add_psrs (parameter_list: clt$parameter_list;
    VAR status: ost$status);

    VAR
      access_sel: amt$file_access_selections,
      byte_address: amt$file_byte_address,
      done: boolean,
      file_p: amt$file_position,
      found: boolean,
      i: rat$element_index,
      interchange: boolean,
      input_line: string (256),
      j: rat$element_index,
      k: rat$element_index,
      l: rat$element_index,
      m: rat$element_index,
      message_status: ost$status,
      number: rat$element_index,
      old_psr_info: ^array [1 .. * ] of rat$psr_ident,
      old_psrs: ^array [1 .. * ] of rat$psr_ident,
      ordinal: 0 .. 255,
      output_lfn: [STATIC] amt$local_file_name := '$OUTPUT',
      pass: rat$element_index,
      psr: ^array [1 .. * ] of rat$psr_ident,
      psr_fid: amt$file_identifier,
      psr_info: ^array [1 .. * ] of rat$psr_info,
      psr_info_length: rat$element_index,
      start: rat$element_index,
      temp: rat$psr_info,
      tran_count: amt$transfer_count,
      value: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, add_psrs_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('PSR_INFO', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH access_sel: [1 .. 1];
    access_sel^ [1].key := amc$access_mode;
    access_sel^ [1].access_mode := $pft$usage_selections [pfc$read];
    amp$open (value.file.local_file_name, amc$record, access_sel, psr_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    psr_info_length := 0;
    done := FALSE;
    PUSH psr_info: [1 .. rac$max_psrs];
    WHILE NOT done DO
      input_line := ' ';
      amp$get_next (psr_fid, ^input_line, #SIZE (input_line), tran_count, byte_address, file_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF file_p = amc$eoi THEN
        done := TRUE;
      IFEND;
      FOR i := 1 TO 39 DO
        IF ($INTEGER (input_line (i, 1)) >= 97) AND ($INTEGER (input_line (i, 1)) <= 122) THEN
          ordinal := $INTEGER (input_line (i, 1)) - 32;
          input_line (i, 1) := $CHAR (ordinal);
        IFEND;
      FOREND;
      psr_info_length := psr_info_length + 1;
      psr_info^ [psr_info_length].ident := input_line (1, 8);
      psr_info^ [psr_info_length].element := input_line (9, 31);
    WHILEND;

    psr_info_length := psr_info_length - 1;

    interchange := TRUE;
    pass := 1;
    WHILE (pass <= psr_info_length - 1) AND interchange DO
      interchange := FALSE;
      FOR j := 1 TO (psr_info_length - pass) DO
        IF (psr_info^ [j].element > psr_info^ [j + 1].element) OR ((psr_info^ [j].element = psr_info^ [j + 1].
              element) AND (psr_info^ [j].ident > psr_info^ [j + 1].ident)) THEN
          interchange := TRUE;
          temp := psr_info^ [j];
          psr_info^ [j] := psr_info^ [j + 1];
          psr_info^ [j + 1] := temp;
        IFEND;
      FOREND;
      pass := pass + 1;
    WHILEND;

    i := 1;
    j := 1;
    WHILE i <= psr_info_length DO
      WHILE (i < psr_info_length) AND (psr_info^ [i] = psr_info^ [i + 1]) DO
        i := i + 1;
      WHILEND;
      psr_info^ [j] := psr_info^ [i];
      j := j + 1;
      i := i + 1;
    WHILEND;
    psr_info_length := j - 1;

    k := 1;
    i := 1;
    start := 1;

  /add_psrs_found/
    REPEAT
      i := i + 1;
      WHILE (i <= psr_info_length) AND (psr_info^ [i].element = psr_info^ [i - 1].element) DO
        i := i + 1;
      WHILEND;
      number := i - start;
      IF psr_info^ [start].element = 'OS' THEN
        j := 1;
        found := FALSE;
        WHILE (j <= rav$correction_package_header^.number_of_elements) AND NOT found DO
          IF rav$elements^ [j].class = rac$os THEN
            k := j;
            found := TRUE;
          IFEND;
          j := j + 1;
        WHILEND;
        IF NOT found THEN
          osp$set_status_abnormal (rac$status_id, rae$element_not_found, psr_info^ [start].element, status);
        IFEND;
      ELSE
        rap$get_corrector_element (psr_info^ [start].element, k, status);
      IFEND;
      IF NOT status.normal THEN
        IF status.condition = rae$element_not_found THEN
          message_status := status;
          rap$issue_message (output_lfn, message_status, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          start := start + number;
          CYCLE /add_psrs_found/;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      NEXT psr: [1 .. number] IN rav$corp.sequence_pointer;
      FOR j := 1 TO number DO
        psr^ [j] := psr_info^ [start].ident;
        start := start + 1;
      FOREND;

      IF rav$elements^ [k].number_of_psrs > 0 THEN
        old_psr_info := #PTR (rav$elements^ [k].psr_info, rav$corp.sequence_pointer^);
        j := 1;
        WHILE j <= rav$elements^ [k].number_of_psrs DO
          m := 1;
          found := FALSE;
          WHILE (m <= number) AND NOT found DO
            IF psr^ [m] = old_psr_info^ [j] THEN
              found := TRUE;
              FOR l := j + 1 TO rav$elements^ [k].number_of_psrs DO
                old_psr_info^ [l - 1] := old_psr_info^ [l];
              FOREND;
              rav$elements^ [k].number_of_psrs := rav$elements^ [k].number_of_psrs - 1;
            ELSE
              m := m + 1;
            IFEND;
          WHILEND;
          IF NOT found THEN
            j := j + 1;
          IFEND;
        WHILEND;
        IF rav$elements^ [k].number_of_psrs > 0 THEN
          NEXT old_psrs: [1 .. rav$elements^ [k].number_of_psrs] IN rav$corp.sequence_pointer;
          FOR m := 1 TO rav$elements^ [k].number_of_psrs DO
            old_psrs^ [m] := old_psr_info^ [m];
          FOREND;
        IFEND;
      IFEND;

      rav$elements^ [k].psr_info := #REL (psr, rav$corp.sequence_pointer^);
      rav$elements^ [k].number_of_psrs := rav$elements^ [k].number_of_psrs + number;

    UNTIL start > psr_info_length;
    amp$close (psr_fid, status);

  PROCEND rap$add_psrs;
MODEND ram$add_psrs;
*DECK DECK=RAM$ADD_SUBPRODUCT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'CREATE_ORDER_DEFINITION Subutility:  ADD_SUBPRODUCT Subcommand.' ??
MODULE ram$add_subproduct;

{ PURPOSE:
{   This module contains the procedures that will add a subproduct to the order.
{
{ DESIGN:
{   The subproduct is checked to determine if it is a valid subproduct.
{   If it is a valid subproduct, a copy of the subproduct's SIF is added
{   to the current end of the packing list sequence in memory, and a
{   record for the subproduct is added to the order contents list.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{   If the following scenario occurs:
{
{   1.  The packing list and order contents list both validate.
{   2.  The SIF is copied to the packing list.
{   3.  Something aborts the job before the order contents record
{       is copied to the order contents list.
{   THEN these procedures will not remove the SIF from the packing list.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$not_assigned
*copyc rac$pacs_processor_version
*copyc rac$sif_file_name
*copyc rac$subproduct_info_level
*copyc cld$path_description
*copyc rae$package_software_cc
*copyc rat$order_contents_list
*copyc rat$packing_list_types
*copyc rat$sequence_descriptor_types
*copyc rat$subproduct_info_types
*copyc rat$subproduct_info_pointers
?? POP ??
*copyc amp$get_segment_pointer
*copyc clp$get_value
*copyc clp$scan_command_file
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc pmp$get_date
*copyc pmp$get_time
*copyc pmp$get_user_identification
*copyc rap$add_name_to_path_ref
*copyc rap$get_file_path_and_ref
*copyc rap$get_sif_pointers
*copyc rap$open_file
*copyc rav$creod_scratch_segment
*copyc rav$order_contents_list_p
*copyc rav$order_contents_count
*copyc rav$packing_list_header_p
*copyc rav$packing_list_seq_p
*copyc rav$subproduct_type

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$add_subproduct', EJECT ??

{ PURPOSE:
{   This procedure adds information to the packing list and the order
{   data file for a subproduct.
{
{ DESIGN:
{   This procedure validates the SIF file, validates the order contents
{   array, writes the SIF file to the end of the packing list and
{   writes the order contents record to the end of the order contents list.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$add_subproduct
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt adds_pdt (
{   pacs_catalog, pc      : file = $required
{   licensed_product, lp  : name = $optional
{   subproduct, s         : name = $optional
{   level, l              : name = $optional
{   type, t               : key release, correction = $optional
{   correction_chosen, cc : boolean = $optional
{   status                : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      adds_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^adds_pdt_names, ^adds_pdt_params];

    VAR
      adds_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 13] of
            clt$parameter_name_descriptor := [['PACS_CATALOG', 1], ['PC', 1], ['LICENSED_PRODUCT', 2],
            ['LP', 2], ['SUBPRODUCT', 3], ['S', 3], ['LEVEL', 4], ['L', 4], ['TYPE', 5], ['T', 5],
            ['CORRECTION_CHOSEN', 6], ['CC', 6], ['STATUS', 7]];

    VAR
      adds_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 7] of clt$parameter_descriptor := [

{ PACS_CATALOG PC }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ LICENSED_PRODUCT LP }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ SUBPRODUCT S }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ LEVEL L }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ TYPE T }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [^adds_pdt_kv5, clc$keyword_value]],

{ CORRECTION_CHOSEN CC }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      adds_pdt_kv5: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := ['RELEASE',
            'CORRECTION'];

?? POP ??

    VAR
      attributes_p: ^rat$subproduct_attributes,
      auto_install: boolean,
      file_opened: boolean,
      ignore_status: ost$status,
      local_status: ost$status,
      message_status: ost$status,
      mmt_seg_p: mmt$segment_pointer,
      order_contents: rat$order_contents,
      pacs_path_p: ^pft$path,
      pacs_ref_p: ^fst$file_reference,
      seg_p: amt$segment_pointer,
      subproduct_info_pointers: rat$subproduct_info_pointers,
      sif_file_id: amt$file_identifier,
      sif_file_ref_p: ^fst$file_reference,
      sif_pacs_ref_p: ^string ( * ),
      subproduct_seq_length: amt$file_length,
      subproduct_seq_p: rat$subproduct_info_p,
      write_definition_needed_flag_p: ^boolean;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the file has been opened, it will be closed before the
{   the procedure returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF file_opened THEN
        fsp$close_file (sif_file_id, ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    file_opened := FALSE;

    clp$scan_parameter_list (parameter_list, adds_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF rav$packing_list_header_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$command_defo_required, '', message_status);
      osp$generate_error_message (message_status, ignore_status);
      RETURN;
    IFEND;

    RESET rav$creod_scratch_segment.sequence_p TO rav$creod_scratch_segment.reset_p;
    rap$get_file_path_and_ref ('PACS_CATALOG', rav$creod_scratch_segment.sequence_p, pacs_path_p,
          pacs_ref_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$add_name_to_path_ref (pacs_ref_p, rac$sif_file_name, rav$creod_scratch_segment.sequence_p,
          sif_file_ref_p);

    rap$open_file (sif_file_ref_p, amc$segment, fsc$read, FALSE, NIL, sif_file_id, file_opened, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      amp$get_segment_pointer (sif_file_id, amc$sequence_pointer, seg_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      mmt_seg_p.seq_pointer := NIL;
      rap$get_sif_pointers (seg_p, mmt_seg_p, sif_file_ref_p, subproduct_info_pointers, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      attributes_p := subproduct_info_pointers.attributes_p;
      PUSH sif_pacs_ref_p: [attributes_p^.pacs_catalog_path.size];
      sif_pacs_ref_p^ := attributes_p^.pacs_catalog_path.path (1, attributes_p^.pacs_catalog_path.size);

      IF pacs_ref_p^ <> sif_pacs_ref_p^ THEN

          osp$set_status_abnormal ('RA', rae$pacs_catalog_name_changed, sif_pacs_ref_p^, message_status);
          osp$append_status_file (osc$status_parameter_delimiter, pacs_ref_p^, message_status);
          osp$append_status_file (osc$status_parameter_delimiter, pacs_ref_p^, message_status);
          osp$generate_error_message (message_status, ignore_status);
          RETURN;

       IFEND;

      validate_licensd_prod_parameter (subproduct_info_pointers.attributes_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      validate_subproduct_parameter (subproduct_info_pointers.attributes_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      validate_level_parameter (subproduct_info_pointers.attributes_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      validate_type_parameter (subproduct_info_pointers.attributes_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      validate_order_contents (subproduct_info_pointers.attributes_p, rav$order_contents_list_p, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      process_correction_chosen (subproduct_info_pointers.attributes_p, auto_install, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      add_sif_to_packing_list (subproduct_info_pointers.subproduct_info_seq_p, rav$packing_list_seq_p,
            subproduct_seq_length, subproduct_seq_p, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      initialize_order_contents_recd (subproduct_info_pointers.attributes_p, auto_install, pacs_ref_p^,
           subproduct_seq_length, subproduct_seq_p, order_contents);

      add_to_order_contents_list (order_contents, rav$creod_scratch_segment, rav$order_contents_list_p,
            rav$order_contents_count, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

    END /main/;

    fsp$close_file (sif_file_id, local_status);
    IF status.normal THEN
      status := local_status;
    IFEND;

    osp$disestablish_cond_handler;

    RESET rav$creod_scratch_segment.sequence_p;
    NEXT write_definition_needed_flag_p IN rav$creod_scratch_segment.sequence_p;
    write_definition_needed_flag_p^ := TRUE;

  PROCEND rap$add_subproduct;

?? TITLE := 'add_sif_to_packing_list', EJECT ??

{ PURPOSE:
{   This procedure adds the SIF to the end of the packing list.
{
{ DESIGN:
{   The size of the SIF is determined and that size is added to the
{   end of the packing list.  The contents of the SIF is stored in the
{   part of the packing list that has been added.
{
{ NOTES:
{
{

  PROCEDURE add_sif_to_packing_list
    (VAR subproduct_info_seq_p: ^rat$subproduct_info_sequence;
     VAR rav$packing_list_seq_p: ^rat$packing_list_sequence;
     VAR subproduct_seq_length: amt$file_length;
     VAR subproduct_seq_p: rat$subproduct_info_p;
     VAR status: ost$status);


    VAR
      seq_p: ^SEQ ( * ),
      sif_seq_p: ^rat$subproduct_info_sequence;


    status.normal := TRUE;

    subproduct_seq_length := #SIZE (subproduct_info_seq_p^);
    RESET subproduct_info_seq_p;
    NEXT sif_seq_p: [[REP subproduct_seq_length OF cell]] IN subproduct_info_seq_p;
    IF sif_seq_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    NEXT seq_p: [[REP subproduct_seq_length OF cell]] IN rav$packing_list_seq_p;
    IF seq_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;
    seq_p^ := sif_seq_p^;

    subproduct_seq_p := #REL (seq_p, rav$packing_list_seq_p^);

  PROCEND add_sif_to_packing_list;

?? TITLE := 'add_to_order_contents_list', EJECT ??

{ PURPOSE:
{   This procedure adds the order contents record to the end of the order contents
{   list.
{
{ DESIGN:
{   The order contents list is reset and then it is created with a size
{   one larger than the previous size.  The last element in the new array
{   is set equal to the order contents.
{
{ NOTES:
{   The scratch segment reset pointer must be reset to just beyond the new end
{   of the contents list.

  PROCEDURE add_to_order_contents_list
    (    order_contents: rat$order_contents;
     VAR rav$creod_scratch_seqment: rat$scratch_segment;
     VAR rav$order_contents_list_p: ^rat$order_contents_list;
     VAR rav$order_contents_count: rat$subproduct_count;
     VAR status: ost$status);


    status.normal := TRUE;

    rav$order_contents_count := rav$order_contents_count + 1;
    RESET rav$creod_scratch_segment.sequence_p TO rav$order_contents_list_p;
    NEXT rav$order_contents_list_p: [1 .. rav$order_contents_count] IN rav$creod_scratch_segment.sequence_p;
    IF rav$order_contents_list_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    rav$order_contents_list_p^ [rav$order_contents_count] := order_contents;

    NEXT rav$creod_scratch_segment.reset_p IN rav$creod_scratch_segment.sequence_p;
    IF rav$creod_scratch_segment.reset_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

  PROCEND add_to_order_contents_list;

?? TITLE := 'initialize_order_contents_recd', EJECT ??

{ PURPOSE:
{   This procedure sets the values of the order contents record.
{
{ DESIGN:
{   The fields in the order contents record are set from the values
{   in the attributes record, the pacs path, auto install and other
{   input parameters.
{
{ NOTES:
{
{

  PROCEDURE initialize_order_contents_recd
    (    attributes_p: ^rat$subproduct_attributes;
         auto_install: boolean;
         pacs_path: fst$file_reference;
         subproduct_seq_length: amt$file_length;
         subproduct_seq_p: rat$subproduct_info_p;
     VAR order_contents: rat$order_contents);


    order_contents.contents_type := subproduct;

    order_contents.size := attributes_p^.size;
    order_contents.licensed_product := attributes_p^.licensed_product;
    order_contents.level := attributes_p^.level;
    order_contents.name := attributes_p^.name;
    order_contents.subproduct_type := attributes_p^.subproduct_type;
    order_contents.sif_identifier := attributes_p^.sif_identifier;

    order_contents.auto_install := auto_install;

    order_contents.pacs_catalog.path (1, * ) := ' ';
    order_contents.pacs_catalog.size := clp$trimmed_string_size (pacs_path);
    order_contents.pacs_catalog.path := pacs_path (1, order_contents.pacs_catalog.size);

    order_contents.subproduct_seq_length := subproduct_seq_length;
    order_contents.subproduct_seq_p := subproduct_seq_p;

    order_contents.assignment_priority := $INTEGER (attributes_p^.subproduct_priority);
    order_contents.position_assigned := rac$not_assigned;

  PROCEND initialize_order_contents_recd;

?? TITLE := 'process_correction_chosen', EJECT ??

{ PURPOSE:
{   This procedure validates the value of CORRECTION_CHOSEN
{   and sets the correct value of AUTO_INSTALL.
{
{ DESIGN:
{   1.  If the subproduct was defined as type release:
{       A) A CORRECTION_CHOSEN parameter cannot be specified.
{       B) The value of AUTO_INSTALL defaults to the value in the
{          subproduct attributes AUTO_INSTALL field.
{
{   2.  If the subproduct was defined as type correction:
{       A) AUTO_INSTALL is set to the boolean equal to the CORRECTION_CHOSEN
{          parameter.
{       B) When CORRECTION_CHOSEN is not specified, the value of AUTO_INSTALL
{          defaults to TRUE.
{
{ NOTES:
{
{

  PROCEDURE process_correction_chosen
    (    attributes_p: ^rat$subproduct_attributes;
     VAR auto_install: boolean;
     VAR status: ost$status);


    VAR
      specified: boolean,
      value: clt$value;

    status.normal := TRUE;

    clp$test_parameter ('CORRECTION_CHOSEN', specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF attributes_p^.subproduct_type = rac$release THEN

      IF specified THEN
        osp$set_status_abnormal ('RA', rae$incorrect_value_for_corr_ch, '', status);
        RETURN;
      IFEND;
      auto_install := attributes_p^.auto_install;

    ELSE {rac$correction}

      IF specified THEN
        clp$get_value ('CORRECTION_CHOSEN', 1, 1, clc$low, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        auto_install := value.bool.value;
      ELSE
        auto_install := TRUE;
      IFEND;

    IFEND;

  PROCEND process_correction_chosen;


?? TITLE := 'validate_level_parameter', EJECT ??

{ PURPOSE:
{   Validate that the LEVEL parameter equals the LEVEL
{   as set in the subproduct attributes record.
{
{ DESIGN:
{   If the parameter has been specified, it is compared with the
{   field in the attributes record.  If the two are not equal
{   a bad status is returned.
{
{ NOTES:
{
{

  PROCEDURE validate_level_parameter
    (    attributes_p: ^rat$subproduct_attributes;
     VAR status: ost$status);


    VAR
      specified: boolean,
      value: clt$value;

    status.normal := TRUE;

    clp$test_parameter ('LEVEL', specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF specified THEN

      clp$get_value ('LEVEL', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF attributes_p^.level <> value.name.value THEN
        osp$set_status_abnormal ('RA', rae$sif_mismatch, 'LEVEL', status);
        RETURN;
      IFEND;

    IFEND;

  PROCEND validate_level_parameter;

?? TITLE := 'validate_licensd_prod_parameter', EJECT ??

{ PURPOSE:
{   Validate that the LICENSED PRODUCT parameter equals the LICENSED PRODUCT
{   as set in the subproduct attributes record.
{
{ DESIGN:
{   If the parameter has been specified, it is compared with the
{   field in the attributes record.  If the two are not equal
{   a bad status is returned.
{
{ NOTES:
{
{

  PROCEDURE validate_licensd_prod_parameter
    (    attributes_p: ^rat$subproduct_attributes;
     VAR status: ost$status);


    VAR
      specified: boolean,
      value: clt$value;

    status.normal := TRUE;

    clp$test_parameter ('LICENSED_PRODUCT', specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF specified THEN

      clp$get_value ('LICENSED_PRODUCT', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF attributes_p^.licensed_product <> value.name.value THEN
        osp$set_status_abnormal ('RA', rae$sif_mismatch, 'LICENSED PRODUCT', status);
        RETURN;
      IFEND;

    IFEND;

  PROCEND validate_licensd_prod_parameter;

?? TITLE := 'validate_order_contents', EJECT ??

{ PURPOSE:
{   This procedure determines if this subproduct can be added to the
{   order contents list.
{
{ DESIGN:
{   This procedure validates an entry to the order contents list by
{   checking the following:
{   1. If the order type on the ADD SUBPRODUCT command is correction,
{      the subproduct type in the SUBPRODUCT INFORMATION FILE cannot be release.
{   2. If the subproduct has been specified on a previous ADD SUBPRODUCT command,
{      it cannot be specifed as the as the same order type.
{
{ NOTES:
{
{

  PROCEDURE validate_order_contents
    (    attributes_p: ^rat$subproduct_attributes;
         order_contents_list_p: ^rat$order_contents_list;
     VAR status: ost$status);


    VAR
      i: rat$subproduct_count;

    status.normal := TRUE;

    FOR i := rac$first_subproduct_entry TO UPPERBOUND (order_contents_list_p^) DO

      IF order_contents_list_p^ [i].name = attributes_p^.name THEN
        IF (order_contents_list_p^ [i].subproduct_type = attributes_p^.subproduct_type) THEN
          osp$set_status_abnormal ('RA', rae$type_already_specified, attributes_p^.name , status);
          osp$append_status_parameter (osc$status_parameter_delimiter, rav$subproduct_type
               [attributes_p^.subproduct_type], status);
          RETURN;
        IFEND;
      IFEND;

    FOREND;

  PROCEND validate_order_contents;

?? TITLE := 'validate_subproduct_parameter', EJECT ??

{ PURPOSE:
{   Validate that the SUBPRODUCT parameter equals the name
{   as set in the subproduct attributes record.
{
{ DESIGN:
{   If the parameter has been specified, it is compared with the
{   field in the attributes record.  If the two are not equal
{   a bad status is returned.
{
{ NOTES:
{
{

  PROCEDURE validate_subproduct_parameter
    (    attributes_p: ^rat$subproduct_attributes;
     VAR status: ost$status);


    VAR
      value: clt$value,
      specified: boolean;

    status.normal := TRUE;

    clp$test_parameter ('SUBPRODUCT', specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF specified THEN

      clp$get_value ('SUBPRODUCT', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF attributes_p^.name <> value.name.value THEN
        osp$set_status_abnormal ('RA', rae$sif_mismatch, 'SUBPRODUCT', status);
        RETURN;
      IFEND;

    IFEND;

  PROCEND validate_subproduct_parameter;

?? TITLE := 'validate_type_parameter', EJECT ??

{ PURPOSE:
{   Validate that the TYPE parameter equals the subproduct_type
{   as set in the subproduct attributes record.
{
{ DESIGN:
{   If the parameter has been specified, it is compared with the subproduct_type
{   field in the attributes record.  If the two are not equal
{   a bad status is returned.
{
{ NOTES:
{
{

  PROCEDURE validate_type_parameter
    (    attributes_p: ^rat$subproduct_attributes;
     VAR status: ost$status);


    VAR
      value: clt$value,
      specified: boolean;

    status.normal := TRUE;

    clp$test_parameter ('TYPE', specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF specified THEN
      clp$get_value ('TYPE', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF ((attributes_p^.subproduct_type = rac$release) AND (value.name.value =
            'CORRECTION')) OR ((attributes_p^.subproduct_type = rac$correction) AND
            (value.name.value = 'RELEASE')) THEN
        osp$set_status_abnormal ('RA', rae$sif_mismatch, 'TYPE', status);
        RETURN;
      IFEND;

    IFEND;

  PROCEND validate_type_parameter;


MODEND ram$add_subproduct;
*DECK DECK=RAM$ADMINISTER_VALIDATIONS EXPAND=TRUE
create_program_description name=(administer_validations, administer_validation, admv) ..
      sp=avp$administer_validations l='$system.osf$system_library' tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$ALTER_FILE EXPAND=TRUE
MODULE ram$alter_file;

*copyc amp$get_next
*copyc amp$put_next
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file

  PROGRAM rap$alter_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ram$altf) alter_pdt (
{   alter_command, ac: string = $required
{   input, i: file = $required
{   output, o: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 5, 16, 17, 54, 19, 270],
    clc$command, 7, 4, 3, 0, 0, 0, 4, 'RAM$ALTF'], [
    ['AC                             ',clc$abbreviation_entry, 1],
    ['ALTER_COMMAND                  ',clc$nominal_entry, 1],
    ['I                              ',clc$abbreviation_entry, 2],
    ['INPUT                          ',clc$nominal_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$file_type]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$alter_command = 1,
    p$input = 2,
    p$output = 3,
    p$status = 4;

  VAR
    pvt: array [1 .. 4] of clt$parameter_value;

    TYPE
      work_files = (input_file, output_file);

    VAR
      alter_command: ost$string,
      file: work_files,
      file_identifier: array [work_files] of amt$file_identifier,
      ignore_byte_address: amt$file_byte_address,
      input_line: ost$string,
      local_status: ost$status,
      output_line: ost$string,
      position_of_file: amt$file_position,
      transfer_count: amt$transfer_count;

    PROCEDURE alter_line
      (    alter_command: ost$string,
           old_string: ost$string;
       VAR new_string: ost$string);

      VAR
        alter_command_char: char,
        alter_command_pos: 0 .. 256,
        old_string_pos: 0 .. 256,
        old_string_pos_prev: 0 .. 256;


      PROCEDURE [INLINE] get_char;

        alter_command_char := alter_command.value (old_string_pos);
        old_string_pos := old_string_pos + 1;
      PROCEND get_char;

      alter_command_pos := 1;
      old_string_pos := 1;
      IF old_string.size = 0 THEN
        new_string.value := ' ';
      ELSE
        new_string.value := old_string.value;
      IFEND;

    /process_alter_command/
      WHILE old_string_pos <= alter_command.size DO
        get_char;

        CASE alter_command_char OF
        = ' ' =
          alter_command_pos := alter_command_pos + 1;

        = '&' =
          new_string.value (alter_command_pos) := ' ';
          alter_command_pos := alter_command_pos + 1;

        = '#' =
          IF old_string_pos <= old_string.size THEN
            new_string.value (alter_command_pos, * ) :=
                  old_string.value (old_string_pos, * );
          IFEND;

        = '^' =
          old_string_pos_prev := old_string_pos - 1;
          get_char;
          WHILE alter_command_char <> '#' DO
            new_string.value (alter_command_pos) := alter_command_char;
            alter_command_pos := alter_command_pos + 1;
            get_char;
          WHILEND;
          IF old_string_pos_prev <= old_string.size THEN
            new_string.value (alter_command_pos, * ) :=
                  old_string.value (old_string_pos_prev, * );
          IFEND;
          alter_command_pos := alter_command_pos + old_string_pos -
                old_string_pos_prev;

        = '!' =
          EXIT /process_alter_command/;

        ELSE
          new_string.value (alter_command_pos) := alter_command_char;
          alter_command_pos := alter_command_pos + 1;
        CASEND;

      WHILEND /process_alter_command/;

      alter_command_pos := alter_command_pos - 1;
      IF (alter_command.size < old_string.size) AND
            (alter_command_char <> '!') THEN
        alter_command_pos := alter_command_pos + old_string.size -
              alter_command.size;
      IFEND;
{Trim trailing blanks.
      WHILE (alter_command_pos > 0) AND (new_string.value (alter_command_pos) =
            ' ') DO
        alter_command_pos := alter_command_pos - 1;
      WHILEND;

      new_string.size := alter_command_pos;
    PROCEND alter_line;

    PROCEDURE open_files
      (VAR local_status: ost$status);

      VAR
        file_attachment: array [1 .. 3] of fst$attachment_option;

      file_attachment [1].selector := fsc$access_and_share_modes;
      file_attachment [1].access_modes.selector := fsc$specific_access_modes;
      file_attachment [1].access_modes.value :=
            $fst$file_access_options [fsc$read];
      file_attachment [1].share_modes.selector := fsc$specific_share_modes;
      file_attachment [1].share_modes.value :=
            $fst$file_access_options [fsc$read, fsc$execute];
      file_attachment [2].selector := fsc$open_share_modes;
      file_attachment [2].open_share_modes :=
            $fst$file_access_options [fsc$read, fsc$execute];
      file_attachment [3].selector := fsc$create_file;
      file_attachment [3].create_file := FALSE;

      fsp$open_file (pvt [p$input].value^.file_value^, amc$record,
            ^file_attachment, NIL, NIL, NIL, NIL, file_identifier [input_file],
            local_status);
      IF NOT local_status.normal THEN
        RETURN;
      IFEND;

      file_attachment [1].selector := fsc$access_and_share_modes;
      file_attachment [1].access_modes.selector := fsc$specific_access_modes;
      file_attachment [1].access_modes.value :=
            $fst$file_access_options [fsc$append, fsc$shorten];
      file_attachment [1].share_modes.selector := fsc$specific_share_modes;
      file_attachment [1].share_modes.value := $fst$file_access_options [];
      file_attachment [2].selector := fsc$access_and_share_modes;
      file_attachment [2].access_modes.selector := fsc$specific_access_modes;
      file_attachment [2].access_modes.value :=
            $fst$file_access_options [fsc$append];
      file_attachment [2].share_modes.selector := fsc$specific_share_modes;
      file_attachment [2].share_modes.value := $fst$file_access_options [];
      file_attachment [3].selector := fsc$open_share_modes;
      file_attachment [3].open_share_modes := -$fst$file_access_options [];

      fsp$open_file (pvt [p$output].value^.file_value^, amc$record,
            ^file_attachment, NIL, NIL, NIL, NIL,
            file_identifier [output_file], local_status);
      IF NOT local_status.normal THEN
        fsp$close_file (file_identifier [input_file], local_status);
        RETURN;
      IFEND;
    PROCEND open_files;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    alter_command.value := pvt [p$alter_command].value^.string_value^;
    alter_command.size := clp$trimmed_string_size (alter_command.value);
    alter_command.value (alter_command.size + 1) := '#';

    open_files (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

  /process_input_file/
    WHILE TRUE DO

      input_line.value := ' ';
      amp$get_next (file_identifier [input_file], ^input_line.value,
            osc$max_string_size, transfer_count, ignore_byte_address,
            position_of_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF position_of_file = amc$eoi THEN
        EXIT /process_input_file/;
      IFEND;
      input_line.size := transfer_count;
      alter_line (alter_command, input_line, output_line);
      amp$put_next (file_identifier [output_file],
            ^output_line.value (1, output_line.size), output_line.size,
            ignore_byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    WHILEND /process_input_file/;

    FOR file := LOWERVALUE (file) TO UPPERVALUE (file) DO
      fsp$close_file (file_identifier [file], local_status);
      IF (NOT local_status.normal) AND status.normal THEN
        status := local_status;
      IFEND;
    FOREND;
  PROCEND rap$alter_file;
MODEND ram$alter_file;
*DECK DECK=RAM$ALTER_FILE_PD EXPAND=TRUE
create_program_description n=(alter_file altf) sp=rap$alter_file ..
      l=osf$current_library lm=$null lmo=none tel=error pv=zero ..
      af=$null dm=off
*DECK DECK=RAM$ALTER_MARKED_LINES EXPAND=TRUE
PROCEDURE (ram$altml) alter_marked_lines, altml (
  alter_command, ac: string = $optional
  status)

  "$FORMAT=OFF
  VAR
    scr1: file = $fname($unique)
    scr2: file = $fname($unique)
  VAREND
  "$FORMAT=ON"

  IF NOT ($mfc = $mlc AND $mfl = $mll) THEN
    IF NOT $specified(ac) THEN
      ac = $screen_input('Enter alter command?')
    IFEND
    write_file f=scr1 l=m
    alter_file ac=ac i=scr1 o=scr2
    read_file f=scr2 il=$mfl p=b
    delete_lines l=m
    delete_file f=(scr1 scr2)
  IFEND

PROCEND alter_marked_lines
*DECK DECK=RAM$ALTER_STRING EXPAND=TRUE
MODULE ram$alter_string;

*copyc clp$evaluate_parameters
*copyc clp$change_variable
*copyc clp$trimmed_string_size

  PROGRAM rap$alter_string
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ram$alts) alter_pdt (
{   alter_string_command, asc: string = $required
{   old_string, os: string = $required
{   new_string, ns: (VAR) string = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 16, 18, 5, 38, 887], clc$command, 7, 4, 3, 0, 0,
            1, 4, 'RAM$ALTS'], [['ALTER_STRING_COMMAND           ',
            clc$nominal_entry, 1], ['ASC                            ',
            clc$abbreviation_entry, 1], ['NEW_STRING                     ',
            clc$nominal_entry, 3], ['NS                             ',
            clc$abbreviation_entry, 3], ['OLD_STRING                     ',
            clc$nominal_entry, 2], ['OS                             ',
            clc$abbreviation_entry, 2], ['STATUS                         ',
            clc$nominal_entry, 4]], [
{ PARAMETER 1
      [1, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$required_parameter, 0, 0],
{ PARAMETER 2
      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$required_parameter, 0, 0],
{ PARAMETER 3
      [3, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_reference,
            clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$required_parameter, 0, 0],
{ PARAMETER 4
      [7, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 2
      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 3
      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 4
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$alter_string_command = 1,
      p$old_string = 2,
      p$new_string = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      alter_string: ost$string,
      alter_string_char: char,
      alter_string_index: integer,
      i: integer,
      new_string: ost$string,
      new_string_index: integer,
      new_string_value: ^clt$data_value,
      old_string: ost$string,
      old_string_index: integer;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    alter_string.value := pvt [p$alter_string_command].value^.string_value^;
    alter_string.size := clp$trimmed_string_size (alter_string.value);
    alter_string.value (alter_string.size + 1) := '#';

    old_string.value := pvt [p$old_string].value^.string_value^;
    old_string.size := clp$trimmed_string_size (old_string.value);

    new_string.value := '';
    new_string.size := 0;
    alter_string_index := 1;
    old_string_index := 1;
    new_string_index := 1;

  /process_alter_command/
    WHILE alter_string_index <= alter_string.size DO

      CASE alter_string.value (alter_string_index) OF

      = ' ' =
        IF old_string_index <= old_string.size THEN {Retain character.
          new_string.value (new_string_index) :=
                old_string.value (old_string_index);
        ELSE
          new_string.value (new_string_index) := ' ';
        IFEND;
        new_string_index := new_string_index + 1;
        old_string_index := old_string_index + 1;
        alter_string_index := alter_string_index + 1;

      = '#' = {Skip character from old_string.
        old_string_index := old_string_index + 1;
        alter_string_index := alter_string_index + 1;

      = '&' = {Replace old_string character with space.
        new_string.value (new_string_index) := ' ';
        new_string_index := new_string_index + 1;
        old_string_index := old_string_index + 1;
        alter_string_index := alter_string_index + 1;

      = '!' = {Truncate old_string.
        old_string_index := old_string.size + 1;
        EXIT /process_alter_command/;

      = '^' = {Insert characters from alter_string until # or end.
        alter_string_index := alter_string_index + 1;
        WHILE (alter_string.value (alter_string_index) <> '#') AND
              (alter_string_index <= alter_string.size) DO
          new_string.value (new_string_index) :=
                alter_string.value (alter_string_index);
          new_string_index := new_string_index + 1;
          alter_string_index := alter_string_index + 1;
        WHILEND;
        alter_string_index := alter_string_index + 1;

      ELSE {Copy from alter_string.
        new_string.value (new_string_index) :=
              alter_string.value (alter_string_index);
        new_string_index := new_string_index + 1;
        old_string_index := old_string_index + 1;
        alter_string_index := alter_string_index + 1;
      CASEND;

    WHILEND /process_alter_command/;

    FOR i := old_string_index TO old_string.size DO
      new_string.value (new_string_index) := old_string.value (i);
      new_string_index := new_string_index + 1;
    FOREND;
    new_string.size := new_string_index - 1;

    PUSH new_string_value;
    new_string_value^.kind := clc$string;
    PUSH new_string_value^.string_value: [new_string.size];
    new_string_value^.string_value^ := new_string.value (1, new_string.size);
    clp$change_variable (pvt [p$new_string].variable^, new_string_value,
          status);

  PROCEND rap$alter_string;
MODEND ram$alter_string;
*DECK DECK=RAM$ALTER_STRING_PD EXPAND=TRUE
create_program_description n=(alter_string alts) sp=rap$alter_string ..
      l=osf$current_library lm=$null lmo=none tel=error pv=zero ..
      af=$null dm=off
*DECK DECK=RAM$ALTER_WORD EXPAND=TRUE
PROCEDURE (ram$altw) alter_word, altw (
  status)

  "$FORMAT=OFF
  VAR
    replace_status: status
  VAREND
  "$FORMAT=ON"

  current_word = $current_word
  alter_command = $screen_input(current_word//' <-- Replacement value')
  replacement_string = ''
  alter_string asc=alter_command os=current_word ns=replacement_string
  IF $mark_first_line <> $mark_last_line THEN
    line_range = mark
  ELSE
    line_range = all
  IFEND

  replace_text t=current_word nt=replacement_string l=line_range w=on ..
        status=replace_status
  put_row t=$string(replace_status) r=$mr

PROCEND alter_word
*DECK DECK=RAM$ANALYZE_DEVICE_FILE EXPAND=TRUE
create_program_description name=(analyze_device_file, anadf) ..
      sp=dmp$analyze_device_file l=(osf$current_library) ..
      tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$ANALYZE_DUMP EXPAND=TRUE
create_program_description name=(analyze_dump, anad) ..
      sp=dup$analyze_dump_command l=('$system.software_maintenance.duf$library' osf$task_services_library) ..
      tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$ANALYZE_OBJECT_LIBRARY EXPAND=TRUE
create_program_description name=(analyze_object_library, anaol) sp=ocp$_analyze_object_library ..
      l=('$system.ocu.bound_product' osf$task_services_library) tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$ANALYZE_PROGRAM_DYNAMICS EXPAND=TRUE
PROCEDURE (osm$anapd) analyze_program_dynamics, anapd (
  target_text, tt: file = $required
  restructured_module, rm: file = $required
  file, files, f: list of file = $optional
  parameter, p: string = $optional
  library, libraries, l: list of file = $optional
  module, modules, m: list of program_name = $optional
  starting_procedure, sp: program_name = $optional
  restructured_module_name, rmn: program_name = $optional
  restructuring_commands, rc: file = $optional
  stack_size, ss: integer 1..2147483648 = 2000000
  status)

  MEASURE_PROGRAM_EXECUTION
    sp_parameter=' '
    IF $specified(starting_procedure) THEN
      sp_parameter=' starting_procedure=$string(starting_procedure)'
    IFEND
    m_parameter=' '
    IF $specified(modules) THEN
      m_parameter=' modules=$apply(modules $string(x))'
    IFEND

    include_command '    set_program_description target_text=target_text file=file library=library'//..
' stack_size=stack_size '//sp_parameter//m_parameter

    execute_instrumented_task parameter=parameter

    IF $specified(restructured_module_name) THEN
      create_restructured_module restructured_module=restructured_module ..
            restructured_module_name=$string(restructured_module_name) ..
            restructuring_commands=restructuring_commands
    ELSE
      create_restructured_module restructured_module=restructured_module ..
            restructuring_commands=restructuring_commands
    IFEND

  QUIT

PROCEND analyze_program_dynamics
*DECK DECK=RAM$ANALYZE_SYSTEM EXPAND=TRUE
create_program_description name=(analyze_system, anas) ..
      sp=dup$analyze_system l=('$system.software_maintenance.duf$library' osf$task_services_library) ..
      tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$APPEND_MARKED_LINES EXPAND=TRUE
PROCEDURE (ram$appml) append_marked_lines, appml (
  append_string, as: string 0..256 = $optional
  status)

  "$FORMAT=OFF
  VAR
    scr1: file = $fname($unique)
    scr2: file = $fname($unique)
  VAREND
  "$FORMAT=ON"

  IF NOT ($mfc = $mlc AND $mfl = $mll) THEN
    IF NOT $specified(as) THEN
      as = $screen_input('Enter string to append?')
    IFEND
    write_file f=scr1 l=m
    append_string_to_file as=as i=scr1 o=scr2
    read_file f=scr2 il=$mfl p=b
    delete_lines l=m
    detach_file f=scr1
    detach_file f=scr2
  IFEND

PROCEND append_marked_lines
*DECK DECK=RAM$APPEND_STRING_TO_FILE EXPAND=TRUE
MODULE ram$append_string_to_file;

*copyc amp$get_next
*copyc amp$put_next
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file

  PROGRAM rap$append_string_to_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE (ram$appstf) append_pdt (
{   append_string, as: string = $required
{   input, i: file = $required
{   output, o: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 5, 19, 18, 36, 15, 201],
    clc$command, 7, 4, 3, 0, 0, 0, 4, 'RAM$APPSTF'], [
    ['APPEND_STRING                  ',clc$nominal_entry, 1],
    ['AS                             ',clc$abbreviation_entry, 1],
    ['I                              ',clc$abbreviation_entry, 2],
    ['INPUT                          ',clc$nominal_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$file_type]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$append_string = 1,
    p$input = 2,
    p$output = 3,
    p$status = 4;

  VAR
    pvt: array [1 .. 4] of clt$parameter_value;

    TYPE
      work_files = (input_file, output_file);

    VAR
      append_string: ost$string,
      file: work_files,
      file_identifier: array [work_files] of amt$file_identifier,
      ignore_byte_address: amt$file_byte_address,
      input_line: ost$string,
      local_status: ost$status,
      output_line: ost$string,
      position_of_file: amt$file_position,
      transfer_count: amt$transfer_count;

    PROCEDURE open_files
      (VAR local_status: ost$status);

      VAR
        file_attachment: array [1 .. 3] of fst$attachment_option;


      file_attachment [1].selector := fsc$access_and_share_modes;
      file_attachment [1].access_modes.selector := fsc$specific_access_modes;
      file_attachment [1].access_modes.value :=
            $fst$file_access_options [fsc$read];
      file_attachment [1].share_modes.selector := fsc$specific_share_modes;
      file_attachment [1].share_modes.value :=
            $fst$file_access_options [fsc$read, fsc$execute];
      file_attachment [2].selector := fsc$open_share_modes;
      file_attachment [2].open_share_modes :=
            $fst$file_access_options [fsc$read, fsc$execute];
      file_attachment [3].selector := fsc$create_file;
      file_attachment [3].create_file := FALSE;

      fsp$open_file (pvt [p$input].value^.file_value^, amc$record,
            ^file_attachment, NIL, NIL, NIL, NIL, file_identifier [input_file],
            local_status);
      IF NOT local_status.normal THEN
        RETURN;
      IFEND;

      file_attachment [1].selector := fsc$access_and_share_modes;
      file_attachment [1].access_modes.selector := fsc$specific_access_modes;
      file_attachment [1].access_modes.value :=
            $fst$file_access_options [fsc$append, fsc$shorten];
      file_attachment [1].share_modes.selector := fsc$specific_share_modes;
      file_attachment [1].share_modes.value := $fst$file_access_options [];
      file_attachment [2].selector := fsc$access_and_share_modes;
      file_attachment [2].access_modes.selector := fsc$specific_access_modes;
      file_attachment [2].access_modes.value :=
            $fst$file_access_options [fsc$append];
      file_attachment [2].share_modes.selector := fsc$specific_share_modes;
      file_attachment [2].share_modes.value := $fst$file_access_options [];
      file_attachment [3].selector := fsc$open_share_modes;
      file_attachment [3].open_share_modes := -$fst$file_access_options [];

      fsp$open_file (pvt [p$output].value^.file_value^, amc$record,
            ^file_attachment, NIL, NIL, NIL, NIL,
            file_identifier [output_file], local_status);
      IF NOT local_status.normal THEN
        fsp$close_file (file_identifier [input_file], local_status);
        RETURN;
      IFEND;
    PROCEND open_files;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    append_string.value := pvt [p$append_string].value^.string_value^;
    append_string.size := clp$trimmed_string_size (append_string.value);

    open_files (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

  /process_input_file/
    WHILE TRUE DO

      amp$get_next (file_identifier [input_file], ^input_line.value,
            osc$max_string_size, transfer_count, ignore_byte_address,
            position_of_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF position_of_file = amc$eoi THEN
        EXIT /process_input_file/;
      IFEND;
      input_line.size := transfer_count;
      output_line.value (1, input_line.size) :=
            input_line.value (1, input_line.size);
      output_line.value (input_line.size + 1,
            append_string.size) := append_string.value;
      output_line.size := input_line.size + append_string.size;
      amp$put_next (file_identifier [output_file],
            ^output_line.value (1, output_line.size), output_line.size,
            ignore_byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    WHILEND /process_input_file/;

    FOR file := LOWERVALUE (file) TO UPPERVALUE (file) DO
      fsp$close_file (file_identifier [file], local_status);
      IF (NOT local_status.normal) AND status.normal THEN
        status := local_status;
      IFEND;
    FOREND;
  PROCEND rap$append_string_to_file;
MODEND ram$append_string_to_file;
*DECK DECK=RAM$APPEND_STRING_TO_FILE_PD EXPAND=TRUE
create_program_description n=(append_string_to_file, appstf) ..
      sp=rap$append_string_to_file l=osf$current_library lm=$null ..
      lmo=none tel=error pv=zero af=$null dm=off
*DECK DECK=RAM$APPLY_ALL_CORRECTIONS EXPAND=TRUE
PROC rap$apply_all_corrections (
  correction_package, cp: file
  new_ve_deadstart_tape, nvdt: list 1..2 of string 1..6 or ..
        key MT9$800 MT9$1600 MT9$6250 MT18$38000
  apply_option, ao: key all new = new
  file_installation_options, fio: key defer_file_installation dfi ..
        immediate_installation ii = defer_file_installation
  retain_previous_versions, retain_previous_version, rpv: boolean = true
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    The purpose of this request is to install an entire set of
"corrections on a system.  And if so needed generate a new
"deadstart file.
"    This command functions with an empty installation catalog by
"reloading the corresponding product files for the corrections to
"be applied.  The corrections are sorted and applied by product.
"After all the corrections for a specific product have been
"installed the installation catalog contents are deleted.
"   Products that are not currently installed are not corrected.
*IFEND


  create_variable applier k=string v='$LOCAL.'//$unique
  create_variable correction_package k=string v='$USER.'//$unique
  create_variable ignore_status k=status
  create_variable local_status k=status
  create_variable os_changes k=integer
  create_variable standard_processing k=boolean v=on
  create_variable tape_count k=integer


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    Verify the input the NEW_VE_DEADSTART_TAPE parameter if
"specified.  Only 1 tape vsn can be given on the
"NEW_VE_DEADSTART_TAPE parameter.
*IFEND


  IF $specified(new_ve_deadstart_tape) THEN
    include_line ..
    'rap$interpret_tape_values '//$parameter(new_ve_deadstart_tape)//' tc=tape_count' status=local_status
    IF local_status.normal AND (tape_count <> 1) THEN
      message = 'NEW_VE_DEADSTART_TAPE'//$char(31)//'only 1'//$char(31)//$strrep(tape_count)
      local_status = $status(FALSE, 'RA', rae$unexpected_tape_count, message)
    IFEND
    EXIT_PROC WITH local_status WHEN NOT local_status.normal
  IFEND


  correction_package = $string($value(correction_package))


apply_corrections: ..
  BLOCK


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    Determine if the correction package has an APPLIER.  If so
"processing is turned over to the APPLIER.  The APPLIER can turn
"off standard processing.
*IFEND


    rap$get_correction_applier cp=$fname(correction_package) a=$fname(applier) status=local_status
    IF local_status.normal THEN
      include_file $fname(applier) status=local_status
    ELSEIF $condition(local_status.condition) = 'RAE$APPLIER_NOT_PRESENT' THEN
      local_status.normal = TRUE
    IFEND
    EXIT apply_corrections WHEN NOT local_status.normal


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    When standard processing, apply all corrections and generate a
"new nosve deadstart file if there where any corrections to the os
"files.
*IFEND


    IF standard_processing THEN

      command_line = 'rap$process_all_corrections cp=$fname(correction_package)'
      IF $specified(new_ve_deadstart_tape) THEN
        command_line = command_line//' nvdt='//$parameter(new_ve_deadstart_tape)
      IFEND
      command_line = command_line//' ao=$value(apply_option)'
      command_line = command_line//' fio=$value(file_installation_options)'
      command_line = command_line//' rpv=$value(retain_previous_versions)'

      include_command command_line status=local_status
      EXIT apply_corrections WHEN NOT local_status.normal
    IFEND

  BLOCKEND apply_corrections

  IF $file($value(correction_package), permanent) THEN
    detach_file $value(correction_package) status=ignore_status
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$apply_all_corrections

*DECK DECK=RAM$APPLY_ALL_CORRECTIONS_CMD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: APPLY_ALL_CORRECTIONS Subcommand.' ??
MODULE ram$apply_all_corrections_cmd;

{ PURPOSE:
{   This module contains the command interface that installs all the
{   corrections defined by the packing list and generates a new deadstart
{   catalog or tape when required.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$control_job_identifier
*copyc rac$idb_directory_name
*copyc rac$special_product_designators
*copyc rac$tape_types
*copyc rae$install_software_cc
*copyc rat$installation_control_record
*copyc rat$subproduct_info_pointers
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$put_next
*copyc clp$evaluate_parameters
*copyc clp$include_line
*copyc clp$put_job_command_response
*copyc clp$trimmed_string_size
*copyc clp$include_line
*copyc fsp$close_file
*copyc fsp$open_file
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc rap$convert_path_to_str
*copyc rap$display_job_log_to_cmd_log
*copyc rap$establish_processing_cntrls
*copyc rap$init_processing_seq
*copyc rap$perform_installation_steps
*copyc rap$submit_batch_jobs
*copyc rap$validate_for_installation
*copyc rav$installation_defaults
*copyc rav$subproduct_type
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$apply_all_corrections_cmd', EJECT ??

{ PURPOSE:
{   This command interface installs all the corrections described by the
{   packing list.  A new deadstart catalog or tape is generated when a
{   correction to the subproduct associated with the deadstart components is
{   encountered.
{
{ DESIGN:
{   This interface can be viewed as combining the INSTALL_PRODUCT and
{   GENERATE_VE_DEADSTART_CATALOG commands into one.
{   See the documentation for ...
{
{ NOTES:
{   The scratch segment is used for the processing sequence and is created
{   in RAP$INIT_PROCESSING_SEQ.
{

  PROCEDURE [XDCL] rap$apply_all_corrections_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{       PROCEDURE appac_pdt (
{         packing_list, pl: name 1..16 = $required
{         new_ve_deadstart_tape, nvdt: record
{             external_vsn: any of
{                 string 1..6
{                 name 1..6
{               anyend = $required
{             recorded_vsn: any of
{                 string 1..6
{                 name 1..6
{               anyend = $optional
{             type: key
{                 mt9$1600, mt9$6250, mt18$38000
{               keyend = $optional
{             unload_deadstart_tape: boolean = $optional
{           recend = $optional
{         configuration_files_catalog, cfc: file = $system.site_os_maintenance.deadstart_commands
{         force_reinstall, fr: boolean = false
{         installation_option, io: key
{             (immediate, i) (deferred, d)
{           keyend = deferred
{         save_previous_cycles, spc: boolean = false
{         execute_in_job_of_caller, eijoc: (BY_NAME, HIDDEN) boolean = false
{         status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 15] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: 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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: 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$string_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 3] of clt$keyword_specification,
        recend,
        field_spec_4: clt$field_specification,
        element_type_spec_4: record
          header: clt$type_specification_header,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (46),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (8),
      recend,
      type6: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type7: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [94, 12, 21, 0, 29, 46, 845],
    clc$command, 15, 8, 1, 0, 1, 0, 8, ''], [
    ['CFC                            ',clc$abbreviation_entry, 3],
    ['CONFIGURATION_FILES_CATALOG    ',clc$nominal_entry, 3],
    ['EIJOC                          ',clc$abbreviation_entry, 7],
    ['EXECUTE_IN_JOB_OF_CALLER       ',clc$nominal_entry, 7],
    ['FORCE_REINSTALL                ',clc$nominal_entry, 4],
    ['FR                             ',clc$abbreviation_entry, 4],
    ['INSTALLATION_OPTION            ',clc$nominal_entry, 5],
    ['IO                             ',clc$abbreviation_entry, 5],
    ['NEW_VE_DEADSTART_TAPE          ',clc$nominal_entry, 2],
    ['NVDT                           ',clc$abbreviation_entry, 2],
    ['PACKING_LIST                   ',clc$nominal_entry, 1],
    ['PL                             ',clc$abbreviation_entry, 1],
    ['SAVE_PREVIOUS_CYCLES           ',clc$nominal_entry, 6],
    ['SPC                            ',clc$abbreviation_entry, 6],
    ['STATUS                         ',clc$nominal_entry, 8]],
    [
{ PARAMETER 1
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 338,
  clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 46],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 6
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 7
    [4, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 8
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, 16]],
{ PARAMETER 2
    [[1, 0, clc$record_type], [4],
    ['EXTERNAL_VSN                   ', clc$required_field, 33], [[1, 0, clc$union_type], [[
      clc$name_type, clc$string_type],
      TRUE, 2],
      8, [[1, 0, clc$string_type], [1, 6, FALSE]],
      5, [[1, 0, clc$name_type], [1, 6]]
      ],
    ['RECORDED_VSN                   ', clc$optional_field, 33], [[1, 0, clc$union_type], [[
      clc$name_type, clc$string_type],
      TRUE, 2],
      8, [[1, 0, clc$string_type], [1, 6, FALSE]],
      5, [[1, 0, clc$name_type], [1, 6]]
      ],
    ['TYPE                           ', clc$optional_field, 118], [[1, 0, clc$keyword_type], [3], [
      ['MT18$38000                     ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['MT9$1600                       ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['MT9$6250                       ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    ['UNLOAD_DEADSTART_TAPE          ', clc$optional_field, 3], [[1, 0, clc$boolean_type]]
    ],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$system.site_os_maintenance.deadstart_commands'],
{ PARAMETER 4
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [4], [
    ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['DEFERRED                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['IMMEDIATE                      ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'deferred'],
{ PARAMETER 6
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 7
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$packing_list = 1,
      p$new_ve_deadstart_tape = 2,
      p$configuration_files_catalog = 3,
      p$force_reinstall = 4,
      p$installation_option = 5,
      p$save_previous_cycles = 6,
      p$execute_in_job_of_caller = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    VAR
      ignore_status: ost$status,
      install_proc_info_file: rat$path,
      installation_control_record: rat$installation_control_record,
      installation_tasks: rat$task_selections,
      local_status: ost$status,
      packing_list_fid: amt$file_identifier,
      packing_list_opened: boolean,
      processing_segment_pointer: amt$segment_pointer,
      product_list: clt$data_value;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to return the processing
{   segment and packing list file when an abort condition arises.
{
{   When the processing segment pointer is not NIL, attempt to display the
{   job log to the command log.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;


      IF processing_segment_pointer.sequence_pointer <> NIL THEN
        rap$display_job_log_to_cmd_log (installation_control_record.processing_header_p^.
              installation_defaults.installation_logs, installation_control_record.processing_header_p^.
              installation_identifier, ignore_status);
        mmp$delete_scratch_segment (processing_segment_pointer, ignore_status);
        processing_segment_pointer.sequence_pointer := NIL;
      IFEND;

      fsp$close_file (packing_list_fid, ignore_status);

      IF install_proc_info_file.size <> 0 THEN
        purge_install_proc_info_file (install_proc_info_file.path (1, install_proc_info_file.size),
              ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    check_directory_presence (rav$installation_defaults.installation_database, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_line ('$system.display_log do=last o=$null', TRUE, osc$null_name, ignore_status);

    install_proc_info_file.size := 0;

    product_list.kind := clc$keyword;
    product_list.keyword_value := 'ALL';

    installation_control_record.job_identifier := rac$control_job_identifier;
    installation_control_record.job_status_record_p := NIL;

    processing_segment_pointer.kind := amc$sequence_pointer;
    processing_segment_pointer.sequence_pointer := NIL;
    packing_list_opened := FALSE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      rap$init_processing_seq (pvt [p$packing_list].value^.name_value,
            pvt [p$save_previous_cycles].value^.boolean_value.value, rac$install_correction, rac$correction,
            rav$installation_defaults, installation_control_record, processing_segment_pointer,
            packing_list_fid, packing_list_opened, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      {  Get the task set pertaining to the installation option parameter.

      get_task_set (pvt [p$installation_option].value^.keyword_value,
            installation_control_record.processing_header_p, installation_tasks);

      rap$validate_for_installation (^product_list, NIL {ignore excluded product list} ,
            pvt[p$force_reinstall].value^.boolean_value.value, installation_tasks,
            installation_control_record, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      {  If this is a deferred installation, search for those subproducts
      {  corrections that are forced to be installed immediate based on
      {  information in the additional products field.

      IF pvt [p$installation_option].value^.keyword_value = 'DEFERRED' THEN
        force_some_products_immediate (installation_control_record, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
      IFEND;

      rap$establish_processing_cntrls (FALSE {multiple job processing} ,
            pvt [p$execute_in_job_of_caller].value^.boolean_value.value, installation_control_record, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      setup_nosve_maint_install_proc (pvt [p$installation_option].value^.keyword_value,
            pvt [p$new_ve_deadstart_tape], pvt [p$configuration_files_catalog].value^.file_value,
            installation_control_record, install_proc_info_file, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF pvt [p$execute_in_job_of_caller].value^.boolean_value.value THEN

        rap$perform_installation_steps (installation_control_record, status);

      ELSE {execute in batch}

        rap$submit_batch_jobs (installation_control_record, status);

      IFEND;

    END /main/;

    IF (NOT status.normal) AND (install_proc_info_file.size <> 0) THEN
      purge_install_proc_info_file (install_proc_info_file.path (1, install_proc_info_file.size),
            ignore_status);
    IFEND;

    IF packing_list_opened THEN
      fsp$close_file (packing_list_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF processing_segment_pointer.sequence_pointer <> NIL THEN
      rap$display_job_log_to_cmd_log (installation_control_record.processing_header_p^.installation_defaults.
            installation_logs, installation_control_record.processing_header_p^.installation_identifier,
            ignore_status);
      mmp$delete_scratch_segment (processing_segment_pointer, local_status);
      processing_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$apply_all_corrections_cmd;

?? OLDTITLE ??
?? NEWTITLE := 'check_directory_presence', EJECT ??

{ PURPOSE:
{   This procedure checks for the presence fo the IDB Directory as defined
{   by the installation database path.  Bad status is returned when not
{   found.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE check_directory_presence
    (    installation_database: rat$path;
     VAR status: ost$status);


    VAR
      directory: rat$path,
      existing_file: boolean,
      ignore_attributes: array [1 .. 1] of amt$get_item,
      ignore_contains_data: boolean,
      local_file: boolean;


    status.normal := TRUE;
    ignore_attributes [1].key := amc$file_length;

    STRINGREP (directory.path, directory.size, rav$installation_defaults.installation_database.
          path (1, rav$installation_defaults.installation_database.size), '.', rac$idb_directory_name);

    amp$get_file_attributes (directory.path (1, directory.size), ignore_attributes, local_file, existing_file,
          ignore_contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (NOT local_file) AND (NOT existing_file) THEN
      osp$set_status_abnormal ('RA', rae$directory_required_for_corr, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, directory.path (1, directory.size), status);
      RETURN;
    IFEND;

  PROCEND check_directory_presence;

?? OLDTITLE ??
?? NEWTITLE := 'force_some_products_immediate', EJECT ??

{ PURPOSE:
{   This procedure searches for subproducts with the special additional
{   product IMMEDIATE and sets them to be installed immediate instead
{   of whatever the installer specified on the installation option
{   parameter.
{
{
{ DESIGN:
{   The special name IMMEDIATE is established in the additional
{   products field of the SIF for some product corrections.  These
{   corrections are searched for in the installation control record
{   and their task sets are specifically set  to reflect immediate
{   installation.
{
{
{ NOTES:
{   The special name IMMEDIATE is preceeded by the special use
{   designator.
{

  PROCEDURE force_some_products_immediate
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      install_immediate: ost$name,
      immediate_installation_tasks: rat$task_selections,
      j: 0 .. rac$max_additional_products,
      subproduct_index: rat$subproduct_count,
      subproduct_pointers: rat$subproduct_info_pointers;


    status.normal := TRUE;

    get_task_set ('IMMEDIATE                      ', installation_control_record.processing_header_p,
          immediate_installation_tasks);
    install_immediate (1, *) := rac$special_use_designator;
    install_immediate (clp$trimmed_string_size (rac$special_use_designator) + 1, * ) :=
          'IMMEDIATE                      ';

  /force/
    FOR subproduct_index := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^) DO

      IF rac$load_files_task IN
             installation_control_record.subproduct_processing_records_p^[subproduct_index].task_set THEN
        { Process only those subproducts that were set to be installed deferred in the first place.

        subproduct_pointers := installation_control_record.subproduct_processing_records_p^
              [subproduct_index].subproduct_info_pointers;

      /immediate_check/
        FOR j := 1 TO UPPERBOUND (subproduct_pointers.attributes_p^.additional_products) DO

          IF subproduct_pointers.attributes_p^.additional_products [j] = install_immediate THEN

            {  Set this subproduct to install immediate.
            installation_control_record.subproduct_processing_records_p^ [subproduct_index].task_set :=
                  immediate_installation_tasks;
            EXIT /immediate_check/;
          IFEND;

        FOREND /immediate_check/;
      IFEND;

    FOREND /force/;

  PROCEND force_some_products_immediate;

?? OLDTITLE ??
?? NEWTITLE := 'get_task_set', EJECT ??

{ PURPOSE:
{   This procedure returns the set of tasks to be performed on the selected
{   products.  The step set and number of steps are registered in the
{   processing header record.
{
{ DESIGN:
{   For the installation of corrections all tasks are performed except the
{   deletion of previous cycles when save_previous_cycles is true.  In
{   addition, if the installation option is deferred, the tasks to
{   activate the files, execute installer procedures and delete previous
{   cycles are removed.
{
{   Currently the number of steps to be performed relates directly to the
{   number of tasks.  That is why the number of steps is computed by
{   subtracting the number of tasks removed from processing.
{
{ NOTES:
{

  PROCEDURE get_task_set
    (    installation_option: ost$name;
         processing_header_p {input, output} : ^rat$processing_header;
     VAR installation_tasks: rat$task_selections);


{ Determine the installation step and task sets.  The '-' means to take the complement.

    IF installation_option = 'DEFERRED' THEN
      processing_header_p^.step_set := -$rat$step_selections
            [rac$activate_subproducts_step, rac$execute_installer_proc_step, rac$delete_previous_cycles_step];
      processing_header_p^.number_of_steps := rac$max_number_of_steps - 3;
      installation_tasks := -$rat$task_selections [rac$activate_files_task, rac$execute_installer_proc_task,
            rac$delete_previous_cycles_task];
    ELSE {installation option is immedidate}
      IF processing_header_p^.save_previous_cycles THEN
        processing_header_p^.step_set := -$rat$step_selections [rac$delete_previous_cycles_step];
        processing_header_p^.number_of_steps := rac$max_number_of_steps - 1;
        installation_tasks := -$rat$task_selections [rac$delete_previous_cycles_task];
      ELSE {delete previous cycles}
        processing_header_p^.step_set := -$rat$step_selections [];
        processing_header_p^.number_of_steps := rac$max_number_of_steps;
        installation_tasks := -$rat$task_selections [];
      IFEND;
    IFEND;

  PROCEND get_task_set;

?? OLDTITLE ??
?? NEWTITLE := 'purge_install_proc_info_file', EJECT ??

{ PURPOSE:
{   This procedure purges the file used to build the special delete job file.
{
{ DESIGN:
{   The only reason this is a separate procedure is because it is called in
{   two places.
{
{ NOTES:
{

  PROCEDURE purge_install_proc_info_file
    (    info_file: fst$file_reference;
     VAR status: ost$status);


    VAR
      command_line: string (800),
      command_line_length: integer;


    status.normal := TRUE;

    STRINGREP (command_line, command_line_length, '$system.delete_file f=', info_file);

    clp$include_line (command_line (1, command_line_length), TRUE, osc$null_name, status);

  PROCEND purge_install_proc_info_file;

?? OLDTITLE ??
?? NEWTITLE := 'setup_nosve_maint_install_proc', EJECT ??

{ PURPOSE:
{   This procedure, when the nosve maintenance subproduct is being corrected,
{   will setup the necessary installer procedure input file.
{
{
{ DESIGN:
{
{
{ NOTES:
{   When a correction is generated by the DEFINE_SUBPRODUCT utility,
{   RAC$CORRECT_FILES_TASK is removed from the task set by
{   RAP$VALIDATE_FOR_CORRECTION.  Therefore, RAC$LOAD_FILES_TASK is used in
{   the IF test.
{

  PROCEDURE setup_nosve_maint_install_proc
    (    installation_option: ost$name;
         new_ve_deadstart_tape: clt$parameter_value;
         configuration_files_catalog_p: ^fst$file_reference;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR install_proc_info_file: rat$path;
     VAR status: ost$status);


    VAR
      installation_tasks: rat$task_selections,
      subproduct_index: rat$subproduct_count;


    status.normal := TRUE;

  /setup/
    FOR subproduct_index := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^) DO

      IF (installation_control_record.subproduct_processing_records_p^ [subproduct_index].
            subproduct_info_pointers.attributes_p^.name = 'NOSVE_MAINTENANCE') AND
            (rac$load_files_task IN installation_control_record.
            subproduct_processing_records_p^ [subproduct_index].task_set) THEN
        { The nosve maintenance subproduct is being corrected.  (See note above.)

        { Display message that a deadstart tape or catalog will be created.

        IF new_ve_deadstart_tape.specified THEN
          clp$put_job_command_response (
                '0A deadstart tape will be generated due to corrections to NOSVE MAINTENANCE.',
                status);
        ELSE { write catalog }
          clp$put_job_command_response (
                '0A deadstart catalog will be generated due to corrections to NOSVE MAINTENANCE.',
                status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        { Create nosve maintenance installer procedure's input file.

        write_install_proc_info_file (new_ve_deadstart_tape, configuration_files_catalog_p,
              installation_control_record.processing_header_p^.installation_identifier,
              installation_control_record.subproduct_processing_records_p^ [subproduct_index].
              installation_catalog_p, install_proc_info_file, status);

        EXIT /setup/;

      IFEND;
    FOREND /setup/;

  PROCEND setup_nosve_maint_install_proc;

?? OLDTITLE ??
?? NEWTITLE := 'write_install_proc_info_file', EJECT ??

{ PURPOSE:
{   This procedure adds a file to the special delete job.  The delete job is
{   required for files that were open during the execution of the delete
{   previous cycles step and therefore could not be deleted.
{
{ DESIGN:
{   The special delete job is collected in a file.  If the file is not yet
{   opened, the file is opened and initialized.  In any case the required
{   SCL delete commands are added.
{
{   The user job name for the special delete job will be the job identifier
{   with the command abbreviation replaced by 'DELF'.
{
{ NOTES:
{

  PROCEDURE write_install_proc_info_file
    (    new_ve_deadstart_tape: clt$parameter_value;
         configuration_files_catalog_p: ^fst$file_reference;
         installation_identifier: rat$installation_identifier;
         installation_catalog_p: ^pft$path;
     VAR install_proc_info_file: rat$path;
     VAR status: ost$status);


    CONST
      external_vsn_field_index = 1,
      recorded_vsn_field_index = 2,
      type_field_index = 3,
      udv_field_index = 4;

    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      evsn_string: string(6),
      evsn_value_p: ^clt$string_value,
      ignore_byte_address: amt$file_byte_address,
      ignore_status: ost$status,
      info_file_fid: amt$file_identifier,
      info_file_opened: boolean,
      installation_catalog: rat$path,
      local_status: ost$status,
      rvsn_string: string(6),
      rvsn_value_p: ^clt$string_value,
      type_value: clt$keyword;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to close the installer
{   proc's input file when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (info_file_fid, ignore_status);

      purge_install_proc_info_file (install_proc_info_file.path (1, install_proc_info_file.size),
            ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

?? NEWTITLE := 'write_line', EJECT ??

{ PURPOSE:
{   This procedure writes a line to to a file.
{
{ DESIGN:
{   If the pointer to the optional string variable is not NIL, it is added
{   to the initial string along with the closing string.
{
{   The line once constructed is written to eoi of the file.
{
{ NOTES:
{   Status is checked at the beginning of this procedure to determine if the
{   command should be completed.  This was done to limit the status check to
{   one place rather than after each call to this procedure in the main
{   procedure.
{

    PROCEDURE write_line
      (    initial_string: string ( * );
           string_p: ^string ( * );
           closing_string: string ( * ));

      VAR
        length: integer,
        output_line: string (osc$max_string_size);


      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF string_p <> NIL THEN
        STRINGREP (output_line, length, initial_string, string_p^, closing_string);
      ELSE
        STRINGREP (output_line, length, initial_string, closing_string);
      IFEND;

      amp$put_next (info_file_fid, ^output_line, length, ignore_byte_address, status);

    PROCEND write_line;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    info_file_opened := FALSE;

    { Assemble the path to the installer proc's info file.

    rap$convert_path_to_str (installation_catalog_p^, installation_catalog);
    STRINGREP (install_proc_info_file.path, install_proc_info_file.size, installation_catalog.
          path (1, installation_catalog.size), '.RAF$APPAC_DEADSTART_INFO');

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      { Open the info file that will be used by nosve maintenance installer proc.

      attachment_options [1].selector := fsc$access_and_share_modes;
      attachment_options [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options [1].access_modes.value := $fst$file_access_options
            [fsc$read, fsc$shorten, fsc$append, fsc$modify];
      attachment_options [1].share_modes.selector := fsc$specific_share_modes;
      attachment_options [1].share_modes.value := $fst$file_access_options [];
      attachment_options [2].selector := fsc$create_file;
      attachment_options [2].create_file := TRUE;
      attachment_options [3].selector := fsc$wait_for_attachment;
      attachment_options [3].wait_for_attachment.wait := osc$wait;
      attachment_options [3].wait_for_attachment.wait_time := fsc$longest_wait_time;

      info_file_opened := TRUE;
      fsp$open_file (install_proc_info_file.path (1, install_proc_info_file.size), amc$record,
            ^attachment_options, NIL, NIL, NIL, NIL, info_file_fid, status);
      IF NOT status.normal THEN
        info_file_opened := FALSE;
        EXIT /main/;
      IFEND;

      evsn_string := ' ';
      rvsn_string := ' ';

      IF new_ve_deadstart_tape.specified THEN
        IF new_ve_deadstart_tape.value^.field_values^ [external_vsn_field_index].value^.kind = clc$string THEN
          evsn_value_p := new_ve_deadstart_tape.value^.field_values^ [external_vsn_field_index].value^.
               string_value;
        ELSE
          evsn_string := new_ve_deadstart_tape.value^.field_values^ [external_vsn_field_index].
                value^.name_value(1,clp$trimmed_string_size(new_ve_deadstart_tape.
                value^.field_values^ [external_vsn_field_index].value^.name_value));
          evsn_value_p := ^evsn_string;
        IFEND;
        IF new_ve_deadstart_tape.value^.field_values^ [recorded_vsn_field_index].value <> NIL THEN
          IF new_ve_deadstart_tape.value^.field_values^ [recorded_vsn_field_index].value^.kind
                           = clc$string THEN
            rvsn_value_p := new_ve_deadstart_tape.value^.field_values^ [recorded_vsn_field_index].value^.
                string_value;
          ELSE
            rvsn_string := new_ve_deadstart_tape.value^.field_values^ [recorded_vsn_field_index].
                value^.name_value(1,clp$trimmed_string_size(new_ve_deadstart_tape.
                value^.field_values^ [recorded_vsn_field_index].value^.name_value));
            rvsn_value_p := ^rvsn_string;
          IFEND;
        ELSE { use default }
          rvsn_value_p := evsn_value_p;
        IFEND;

        IF new_ve_deadstart_tape.value^.field_values^ [type_field_index].value <> NIL THEN
          type_value := new_ve_deadstart_tape.value^.field_values^ [type_field_index].value^.keyword_value;
        ELSE { use default }
          type_value := rac$mt9$6250;
        IFEND;

        write_line ('VAR', NIL, '');
        write_line ('  rav#appac_deadstart_medium: name = tape', NIL, '');
        write_line ('  rav#appac_evsn: string 1..6 = ''', evsn_value_p, '''');
        write_line ('  rav#appac_rvsn: string 1..6 = ''', rvsn_value_p, '''');
        write_line ('  rav#appac_type: name = ', ^type_value, '');
        IF ((new_ve_deadstart_tape.value^.field_values^ [udv_field_index].value = NIL) OR
            (new_ve_deadstart_tape.value^.field_values^ [udv_field_index].value^.boolean_value.value)) THEN
          write_line ('  rav#appac_udv: boolean = TRUE', NIL, '');
        ELSE
          write_line ('  rav#appac_udv: boolean = FALSE', NIL, '');
        IFEND;
        write_line ('  rav#appac_cfc_catalog: file = ', configuration_files_catalog_p, '');
        write_line ('  rav#appac_installation_id: name = ', ^installation_identifier, '');
        write_line ('VAREND', NIL, '');

      ELSE { write deadstart catalog }

        write_line ('VAR', NIL, '');
        write_line ('  rav#appac_deadstart_medium: name = disk', NIL, '');
        write_line ('  rav#appac_cfc_catalog: file = ', configuration_files_catalog_p, '');
        write_line ('  rav#appac_installation_id: name = ', ^installation_identifier, '');
        write_line ('VAREND', NIL, '');

      IFEND;

    END /main/;

    IF info_file_opened THEN
      fsp$close_file (info_file_fid, local_status);
      IF NOT status.normal THEN
        purge_install_proc_info_file (install_proc_info_file.path (1, install_proc_info_file.size),
              ignore_status);
      ELSEIF NOT local_status.normal THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND write_install_proc_info_file;
MODEND ram$apply_all_corrections_cmd;
*DECK DECK=RAM$APPLY_OBJECT_CORRECTION_CMD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE utility: APPLY_OBJECT_CORRECTION subcommand.' ??
MODULE ram$apply_object_correction_cmd;

{ PURPOSE:
{   This module contains the interface that interprets the SCL parameters
{   and passes them into the CYBIL interface OCM$APPLY_OBJECT_CORRECTION.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
?? POP ??
*copyc clp$evaluate_parameters
*copyc ocp$apply_object_correction

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$apply_object_correction_cmd', EJECT ??

{ PURPOSE:
{   This interface interprets the SCL parameters and to make a call to the
{   CYBIL interface OCM$APPLY_OBJECT_CORRECTION.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$apply_object_correction_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE appocc_pdt (
{   base_file, bf: file = $required
{   correction_file, cf: file = $required
{   target_file, tf: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 10, 6, 9, 54, 52, 58],
    clc$command, 7, 4, 3, 0, 0, 0, 4, 'APPOCC_PDT'], [
    ['BASE_FILE                      ',clc$nominal_entry, 1],
    ['BF                             ',clc$abbreviation_entry, 1],
    ['CF                             ',clc$abbreviation_entry, 2],
    ['CORRECTION_FILE                ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['TARGET_FILE                    ',clc$nominal_entry, 3],
    ['TF                             ',clc$abbreviation_entry, 3]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$file_type]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$base_file = 1,
    p$correction_file = 2,
    p$target_file = 3,
    p$status = 4;

  VAR
    pvt: array [1 .. 4] of clt$parameter_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ocp$apply_object_correction (pvt [p$base_file].value^.file_value^,
          pvt [p$correction_file].value^.file_value^, pvt [p$target_file].value^.file_value^,
          status);

  PROCEND rap$apply_object_correction_cmd;
MODEND ram$apply_object_correction_cmd;
*DECK DECK=RAM$ARDEN_HILLS_CONFIGURATION EXPAND=TRUE
*copy rai$arden_hills_configuration
*DECK DECK=RAM$ARDEN_HILLS_PROLOGS EXPAND=TRUE
*copy rai$prolog_cobalt_byops_xmd_2x8
"*copy rai$prolog_cobalt_closed_shop
"*copy rai$prolog_cobalt_xmd_1x4
"*copy rai$prolog_copper_closed_shop
*copyc rai$prolog_gray_open_usage
*copy rai$prolog_mauve_open_usage
*copy rai$prolog_mauve_shared_lab
*copy rai$prolog_mauve_shortlooks
*copy rai$prolog_navy_isd2_2x2
*copy rai$prolog_navy_isd2_3x4
*copy rai$prolog_pewter_open_usage
*copy rai$prolog_pewter_perf_1X4
*copy rai$prolog_pewter_perf_11
*copy rai$prolog_pewter_perf_31
*copy rai$prolog_pewter_shared_lab
"*copy rai$prolog_purple_9836_2x4
"*copy rai$prolog_sn109_closed_shop
*copy rai$prolog_sn302_das
*copy rai$prolog_sn302_hydras
*copy rai$prolog_sn302_hydras_pf
*copy rai$prolog_sn302_xmd3_1x4
*copy rai$prolog_sn302_sabre_2x8
*copy rai$prolog_sn302_sabre_hotkey
*copy rai$prolog_sn604_isd2_1x2
*copy rai$prolog_sn604_isd2_2x4
*copy rai$prolog_sn604_isd2_2x4_810
*copy rai$prolog_est_860_a
*copy rai$prolog_est_860_b
*DECK DECK=RAM$ASSEMBLE_INSTALLATION_PATH EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$ASSEMBLE_INSTALLATION_PATH Interface.' ??
MODULE ram$assemble_installation_path;
{ PURPOSE:
{   This module contains the interface to assemble an installation path
{   for a subproduct.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fst$number_of_path_elements
*copyc ost$status
*copyc rae$install_software_cc
*copyc rat$subproduct_info_types
*copyc rat$subproduct_install_paths
?? POP ??
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc rap$convert_path_to_pf_format
*copyc rap$convert_path_to_str

?? OLDTITLE, NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE, NEWTITLE := '[XDCL] rap$assemble_installation_path', EJECT ??

{ PURPOSE:
{   This procedure assembles the specified path from the path container for
{   a subproduct and the supplied system catalog and returns a pointer
{   to the path in PF format.  The path is stored in the supplied sequence.
{
{ DESIGN:
{   The desired path is taken from the appropriate path containner of the
{   subproduct.   If a non-empty system catalog path is supplied, the family
{   user catalogs of the path are replaced with the overriding system catalog.
{   The system catalog path is in string format and must first be
{   converted to PF format for processing here.
{
{   The assembled path is stored in PF format in the supplied sequence.
{
{   The system catalog is typlically the value of the current system_catalog
{   installation default.
{ NOTES:
{   The conversion back and forth between PF and FS path formats is a mess,
{   but it is neccessary until the PF interfaces are converted to accept FS
{   path formats.  The conversion code could be consolidated into common
{   interfaces when the SIF path container is converted to FS format.
{
{   The space to create the path is NEXT'd onto the end of the supplied
{   sequence.  The current sequence position is assumed to be at EOI.
{

  PROCEDURE [XDCL] rap$assemble_installation_path
    (    system_catalog: rat$path;
         subproduct_info_pointers: rat$subproduct_info_pointers;
         path_selection: rat$subproduct_install_paths;
     VAR assembled_path_p: ^pft$path;
     VAR sequence_p: ^SEQ( * );
     VAR status: ost$status);


    CONST
      family_user_catalogs = 2; { The number of elements that makeup the family and user catalogs. }

    VAR
      assembled_path_length: fst$number_of_path_elements,
      i: fst$number_of_path_elements,
      path_index: rat$path_container_length,
      path_length: fst$number_of_path_elements,
      system_catalog_length: fst$number_of_path_elements,
      system_catalog_p: ^pft$path;


    status.normal := TRUE;

    IF path_selection = rac$installation_path THEN
      path_index := subproduct_info_pointers.attributes_p^.
            installation_path.path_container_index;
      path_length := subproduct_info_pointers.attributes_p^.
            installation_path.path_length;
    ELSE {rac$installer_procedure}
      path_index := subproduct_info_pointers.attributes_p^.
            installer_procedure.path_container_index;
      path_length := subproduct_info_pointers.attributes_p^.
            installer_procedure.path_length;
    IFEND;

    IF system_catalog.size = 0 THEN

      { The installation path is used as the installation catalog.

      NEXT assembled_path_p: [1 .. path_length] IN sequence_p;
      IF assembled_path_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'WORKING SEQUENCE', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'INSTALLATION CATALOG', status);
        RETURN;
      IFEND;

      FOR i := 1 TO UPPERBOUND (assembled_path_p^) DO
        assembled_path_p^ [i] := subproduct_info_pointers.
              path_container_p^ [path_index];
        path_index := path_index + 1;
      FOREND;

    ELSE {the system catalog replaces the family and user catalogs of the installation path}

      { Convert the system catalog path, which is in FS format to PF format.

      rap$convert_path_to_pf_format( system_catalog, system_catalog_p, sequence_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      system_catalog_length := upperbound( system_catalog_p^ );

      { Add the installation path elements (minus the family and user catalogs) to the end
      { of the system catalog elements.

      assembled_path_length := path_length - family_user_catalogs + system_catalog_length;
      RESET sequence_p TO system_catalog_p;
      NEXT assembled_path_p: [1 .. assembled_path_length] IN sequence_p;
      IF assembled_path_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'WORKING SEQUENCE', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'INSTALLATION CATALOG', status);
        RETURN;
      IFEND;

      path_index := path_index + family_user_catalogs;
      FOR i := (system_catalog_length + 1) TO UPPERBOUND (assembled_path_p^) DO
        assembled_path_p^ [i] := subproduct_info_pointers.
              path_container_p^ [path_index];
        path_index := path_index + 1;
      FOREND;

    IFEND;

  PROCEND rap$assemble_installation_path;

?? OLDTITLE ??
MODEND ram$assemble_installation_path;
*DECK DECK=RAM$ASSEMBLE_RELEASE_MATERIALS EXPAND=TRUE
*DECK DECK=RAM$ASSIGN_INSTALL_IDENTIFIER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$ASSIGN_INSTALL_IDENTIFIER Interface.' ??
MODULE ram$assign_install_identifier;

{ PURPOSE:
{   This module contains the interface and procedure that assigns the
{   installation identifier.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$install_software_cc
*copyc rat$installation_control_record
?? POP ??
*copyc clp$put_job_command_response
*copyc clp$trimmed_string_size
*copyc pfp$convert_fs_path_to_pf_path
*copyc pfp$convert_string_to_fs_path
*copyc pfp$define_catalog
*copyc pmp$get_compact_date_time
*copyc clp$convert_date_time_to_string
*copyc rav$installation_command_abbrv
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$assign_install_identifier', EJECT ??

{ PURPOSE:
{   This interface creates the installation identifier catalog and returns
{   the installation identifier for the installation event.
{
{ DESIGN:
{   The procedure first makes sure the Installation Logs catalog exits.
{   This is done by attempting to create each subcatalog along the the path
{   while ignoring status.  The interface called to create subcatalogs
{   requires the path format be converted from FS to PF format.  In an
{   attempt to simplify the dividing of the path into subcatalogs, the PF
{   path array containing the entire path is created in a sequence.  This
{   will protect the values of the entire PF path array while subsets of
{   the array are used to create the subcatalogs in order of occurance.  In
{   this way assignment to the PF path array is only done once.
{
{   Once the Installation Logs catalog is believed to exist the installation
{   identifier catalog is created under it.  An installation identifier is
{   assigned for this installation event.  The installation identifier is
{   used as the name of the installation identifier catalog.
{
{   The identifier is created using the format:  command abbreviation // '_'
{   // user referenece // '_' // suffix.  The user reference is determined
{   by the value of the packing list name.  When the packing list name is
{   the null name, the current date is used (format:  Y4_M2_D2).  Otherwise,
{   the packing list name passed in is taken as the user reference.
{
{   Determining what suffix to use is done by trial and error.  The suffix
{   starts as 'A' through 'Z', then 'AA' through 'AZ' up to 'ZZ'.  A suffix
{   is generated and appended to the installation identifer, then the
{   installation identifier catalog's creation is attempted.  A status
{   condition is returned when the identifier is already being used.  The
{   process is continued until a unused identifier is formed and the
{   catalog is successfully created or some other status condition is
{   encountered.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$assign_install_identifier
    (    installation_command: rat$installation_commands;
         installation_logs: rat$path;
         packing_list_name: ost$name;
     VAR installation_identifier: rat$installation_identifier;
     VAR status: ost$status);


    CONST
      first_subcatalog = 1,
      family_user_catalogs = 2; { The first 2 path elements are the family and user catalogs. }


    VAR
      defined: boolean,
      fs_path: string (fsc$max_path_size),
      identifier_length: integer,
      ignore_cycle_reference: fst$cycle_reference,
      ignore_cycle_selector: clt$cycle_selector,
      ignore_open_position: fst$open_position,
      ignore_status: ost$status,
      length: integer,
      line: string (osc$max_string_size),
      number_of_path_elements: fst$number_of_path_elements,
      number_of_subcatalogs: fst$number_of_path_elements,
      path_p: ^pft$path,
      path_sequence_p: ^SEQ ( * ),
      subcatalogs: integer,
      suffix: string (2),
      user_reference: ost$string;


    status.normal := TRUE;

    { Determine the number of subcatalogs in the installation logs catalog
    { path.

    pfp$convert_string_to_fs_path (installation_logs.path (1, installation_logs.size), fs_path,
          number_of_path_elements, ignore_cycle_reference, ignore_open_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Convert the installation logs catalog path, which is in file reference
    { format to PF format.  Create a sequence to contain the path plus
    { additional entry for the installation identifier.

    PUSH path_sequence_p: [[REP ((number_of_path_elements + 1) * #SIZE (pft$name)) OF cell]];
    RESET path_sequence_p;
    NEXT path_p: [1 .. number_of_path_elements] IN path_sequence_p;
    pfp$convert_fs_path_to_pf_path (fs_path, path_p, ignore_cycle_reference, ignore_cycle_selector, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Attempt to create each subcatalog in the installation logs catalog path
    { while ignoring status.

    number_of_subcatalogs := number_of_path_elements - family_user_catalogs;

    FOR subcatalogs := first_subcatalog TO number_of_subcatalogs DO

      RESET path_sequence_p;
      NEXT path_p: [1 .. family_user_catalogs + subcatalogs] IN path_sequence_p;

      pfp$define_catalog (path_p^, ignore_status);

    FOREND;

    { Determine the installation identifier.

    get_user_reference (packing_list_name, user_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET path_sequence_p;
    NEXT path_p: [1 .. number_of_path_elements + 1] IN path_sequence_p;

    defined := FALSE;
    suffix := '';

    REPEAT

      get_identifier_suffix (suffix);

      STRINGREP (installation_identifier, identifier_length,
            rav$installation_command_abbrv [installation_command],
            '_', user_reference.value (1, user_reference.size),
            '_', suffix (1, clp$trimmed_string_size (suffix)));

      path_p^ [number_of_path_elements + 1] (1, * ) := installation_identifier (1, identifier_length);

      pfp$define_catalog (path_p^, status);
      IF NOT status.normal THEN
        IF (status.condition = pfe$name_already_subcatalog) OR
              (status.condition = pfe$name_already_permanent_file) THEN
          status.normal := TRUE;
        ELSE
          RETURN;
        IFEND;
      ELSE
        defined := TRUE;
      IFEND;

    UNTIL defined;

    { Display the installation identifier to $RESPONSE.

    STRINGREP (line, length, '0The installation identifier assigned to this job is ',
          installation_identifier (1, identifier_length), '.');
    clp$put_job_command_response (line (1, length), status);

  PROCEND rap$assign_install_identifier;

?? OLDTITLE ??
?? NEWTITLE := 'get_identifier_suffix', EJECT ??

{ PURPOSE:
{   This procedure returns the next installation identifier suffix.
{
{ DESIGN:
{   The previous suffix is passed in and incremented to create the next
{   suffix.  The suffix is assummed to be initialized to the null string on
{   the first call.  The suffix starts as 'A' through 'Z', then 'AA' through
{   'AZ' up to 'ZZ'.
{
{ NOTES:
{

  PROCEDURE get_identifier_suffix
    (VAR suffix {input, output} : string (2));


    VAR
      char_1: string (1),
      char_2: string (1);


    char_1 := suffix (1, 1);
    char_2 := suffix (2, 1);

    IF char_1 = '' THEN

      char_1 := 'A';

    ELSEIF char_2 = '' THEN

      IF char_1 = 'Z' THEN
        char_1 := 'A';
        char_2 := 'A';
      ELSE
        char_1 := $CHAR ($INTEGER (char_1) + 1);
      IFEND;

    ELSE {both characters are being used}

      IF char_2 = 'Z' THEN
        char_2 := 'A';
        IF char_1 = 'Z' THEN
          char_1 := 'A';
        ELSE
          char_1 := $CHAR ($INTEGER (char_1) + 1);
        IFEND;
      ELSE
        char_2 := $CHAR ($INTEGER (char_2) + 1);
      IFEND;

    IFEND;

    suffix (1, 1) := char_1;
    suffix (2, 1) := char_2;

  PROCEND get_identifier_suffix;

?? OLDTITLE ??
?? NEWTITLE := 'get_user_reference', EJECT ??

{ PURPOSE:
{   This procedure returns the user reference.
{
{ DESIGN:
{   The user reference is determined by the value of the packing list name.
{   When the packing list name is the null name, the current date is used
{   (format:  Y4_M2_D2).  Otherwise, the packing list name passed in is
{   taken as the user reference.
{
{ NOTES:
{

  PROCEDURE get_user_reference
    (    packing_list_name: ost$name;
     VAR user_reference: ost$string;
     VAR status: ost$status);


    VAR
      date_time: clt$date_time;


    status.normal := TRUE;

    IF packing_list_name = osc$null_name THEN

      pmp$get_compact_date_time (date_time.value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      date_time.date_specified := TRUE;
      date_time.time_specified := TRUE;

      clp$convert_date_time_to_string (date_time, 'Y4 M2 D2', user_reference, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      { Convert the user reference to a name by replacing the blank delimiters with underscores.
      { The size field is not affected.

      user_reference.value (5, 1) := '_';
      user_reference.value (8, 1) := '_';

    ELSE {packing list name is used}

      user_reference.size := clp$trimmed_string_size (packing_list_name);
      user_reference.value (1, * ) := packing_list_name;
    IFEND;

  PROCEND get_user_reference;
MODEND ram$assign_install_identifier;
*DECK DECK=RAM$BACKUP_PERMANENT_FILES_DS EXPAND=TRUE
create_program_description name=(backup_permanent_files, backup_permanent_file, bacpf) ..
      sp=pup$backup_permanent_file l=(osf$current_library osf$task_services_library) ..
      tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$BACKUP_PERMANENT_FILES_SYS EXPAND=TRUE
create_program_description name=(backup_permanent_files, backup_permanent_file, bacpf) ..
      sp=pup$backup_permanent_file l=('$system.osf$builtin_library' osf$task_services_library) ..
      tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$BIND_NETWORK_MANAGEMENT EXPAND=TRUE
PROC bind_network_management, binnm (
  unbound_component, uc: file = $system.nosve.maintenance.osf$network_management
  cybil_library, cl: file = $system.cybil.cyf$run_time_library
  bound_network_op_commands, bnoc: file = $user.network.operator.bound_product_46d   "osf$system_library_46d"
  bound_network_operator, bno: file = $user.network.operator.bound_product           "osf$system_library"
  bound_network_administrator, bna: file = $user.network.administrator.bound_product "osf$system_library"
  bound_network_management, bnm: file = $user.network.management.bound_product       "osf$operator_library_46d"
  map, m: file = $user.network.maintenance.map
  status)

  create_variable ignore_status kind=status
  create_variable instr_file_string kind=(string $max_name) value=$unique
  create_variable netou_file_string kind=(string $max_name) value=$unique
  create_variable netoc_file_string kind=(string $max_name) value=$unique
  create_variable manna_file_string kind=(string $max_name) value=$unique
  create_variable clock_file_string kind=(string $max_name) value=$unique
  create_variable restricted_unbound_component kind=(string $max_name) value=$unique
  create_variable log_file_string kind=(string $max_name) value=$unique
  create_variable file_access_file_string kind=string value='$local.'//$unique
  create_variable initialization_file_string kind=string value='$local.'//$unique
  create_variable temp_lfn_string kind=string
  create_variable temp_map_string kind=string value='$local.'//$unique
  create_variable maint_catalog_path kind=string value=$path($value(map), catalog)
  create_variable next_segment kind=integer


  set_file_attributes $fname(temp_map_string) op=$eoi
  create_catalog c=$user.network status=ignore_status
  create_catalog c=$user.network.operator status=ignore_status
  create_catalog c=$user.network.administrator status=ignore_status
  create_catalog c=$user.network.management status=ignore_status
  create_catalog c=$user.network.maintenance status=ignore_status

  CREATE_OBJECT_LIBRARY

    add_modules library=$value(unbound_component)
    delete_module m=nam$network_alarm_processor
    delete_module m=nam$send_command
    generate_library $fname(restricted_unbound_component)

    add_modules library=$fname(restricted_unbound_component) m=(nam$network_operator_utility)
    satisfy_external_references library=$fname(restricted_unbound_component)
    satisfy_external_references library=$value(cybil_library)
    generate_library $fname(netou_file_string)

    add_modules library=$value(unbound_component) m=(nam$network_alarm_processor nam$send_command)
    satisfy_external_references library=$value(unbound_component)
    satisfy_external_references library=$value(cybil_library)
    generate_library $fname(netoc_file_string)

    add_modules library=$value(unbound_component) m=(nam$manage_network_applications)
    satisfy_external_references library=$value(unbound_component)
    satisfy_external_references library=$value(cybil_library)
    generate_library $fname(manna_file_string)

    add_modules library=$value(unbound_component) m=(nam$clock_me)
    satisfy_external_references library=$value(unbound_component)
    satisfy_external_references library=$value(cybil_library)
    generate_library $fname(clock_file_string)

    add_modules library=$value(unbound_component) m=(nam$file_access_me)
    satisfy_external_references library=$value(unbound_component)
    satisfy_external_references library=$value(cybil_library)
    generate_library $fname(file_access_file_string)

    add_modules library=$value(unbound_component) m=(nam$independent_init_manager)
    satisfy_external_references library=$value(unbound_component)
    satisfy_external_references library=$value(cybil_library)
    generate_library $fname(initialization_file_string)

    add_modules library=$value(unbound_component) m=(nam$log_me)
    satisfy_external_references library=$value(unbound_component)
    satisfy_external_references library=$value(cybil_library)
    generate_library $fname(log_file_string)

    add_modules library=$value(unbound_component) m=(nam$install_tcpip_static_routes)
    satisfy_external_references library=$value(unbound_component)
    satisfy_external_references library=$value(cybil_library)
    generate_library $fname(instr_file_string)

    create_module name=nam$bound_network_operator..
          component=$fname(netou_file_string) sp=nap$send_network_commands..
          output=$fname(temp_map_string) ibsm=true
    change_module_attributes module=nam$bound_network_operator ..
          omit_library=cyf$run_time_library
    change_module_attributes module=nam$bound_network_operator ..
          not_gate=(cyp$allocate, cyp$free, cyp$stringrep)
    change_module_attributes module=nam$bound_network_operator ..
          retain=(nap$process_activate_alarms, nap$process_alarm_output)
    change_module_attributes module=nam$bound_network_operator onrep=on
    add_copyright nam$bound_network_operator
    generate_library l=$fname(netou_file_string)

    create_module name=nam$bound_network_op_commands ..
          component=$fname(netoc_file_string) output=$fname(temp_map_string) ibsm=true
    change_module_attributes module=nam$bound_network_op_commands ..
          omit_library=cyf$run_time_library
    change_module_attributes module=nam$bound_network_op_commands ..
          not_gate=(cyp$allocate, cyp$free)
    change_module_attributes module=nam$bound_network_op_commands ..
          retain=(nap$activate_network_alarms, nap$deactivate_network_alarms ..
          nap$receive_network_alarm, nap$send_command, nap$receive_command_response ..
          nap$end_command_processing nap$terminate_command)
    change_module_attributes module=nam$bound_network_op_commands onrep=on
    add_copyright nam$bound_network_op_commands
    generate_library l=$fname(netoc_file_string)

    create_module name=nam$bound_network_administrator ..
          component=$fname(manna_file_string) sp=nap$manage_network_applications..
          output=$fname(temp_map_string) ibsm=true
    change_module_attributes module=nam$bound_network_administrator ..
          omit_library=cyf$run_time_library
    change_module_attributes module=nam$bound_network_administrator ..
          not_gate=(cyp$allocate, cyp$free, cyp$stringrep)
    change_module_attributes module=nam$bound_network_administrator onrep=on
    add_copyright nam$bound_network_administrator
    generate_library l=$fname(manna_file_string)

    create_module name=nam$bound_tcpip_installer ..
          component=$fname(instr_file_string) sp=nap$install_tcpip_static_routes..
          output=$fname(temp_map_string) ibsm=true
    change_module_attributes module=nam$bound_tcpip_installer ..
          omit_library=cyf$run_time_library
    change_module_attributes module=nam$bound_tcpip_installer ..
          not_gate=(cyp$allocate, cyp$free, cyp$stringrep)
    change_module_attributes module=nam$bound_tcpip_installer onrep=on
    add_copyright nam$bound_tcpip_installer
    generate_library l=$fname(instr_file_string)

    create_linked_module n=nam$bound_network_operator ..
          c=(($fname(netou_file_string),nam$bound_network_operator)) rb=(4,13,13) ..
          dt=$fname(maint_catalog_path//'.netou_debug_tables') nas=next_segment  ..
          o=$fname(temp_map_string) isn=on
    generate_library $value(bound_network_operator)

    create_linked_module n=nam$bound_network_op_commands ..
          c=(($fname(netoc_file_string),nam$bound_network_op_commands)) rb=(4,6,13) ..
          dt=$fname(maint_catalog_path//'.netoc_debug_tables') ..
          nas=next_segment ss=next_segment o=$fname(temp_map_string) isn=on
    generate_library $value(bound_network_op_commands)

    create_linked_module n=nam$bound_network_administrator ..
          c=(($fname(manna_file_string),nam$bound_network_administrator)) rb=(4,13,13) ..
          dt=$fname(maint_catalog_path//'.manna_debug_tables') ..
          o=$fname(temp_map_string) isn=on

    create_linked_module n=nam$bound_tcpip_installer ..
          c=(($fname(instr_file_string),nam$bound_tcpip_installer)) rb=(4,13,13) ..
          dt=$fname(maint_catalog_path//'.instr_debug_tables') ..
          o=$fname(temp_map_string) isn=on
    generate_library $value(bound_network_administrator)

    create_module name=nam$bound_clock_manager..
          component=$fname(clock_file_string) sp=nap$clock_me..
          gate=nap$clock_me output=$fname(temp_map_string) ibsm=true
    change_module_attributes module=nam$bound_clock_manager..
          omit_library=cyf$run_time_library
    change_module_attributes module=nam$bound_clock_manager..
          not_gate=(cyp$allocate, cyp$free, cyp$stringrep)
    change_module_attributes module=nam$bound_clock_manager onrep=on
    add_copyright nam$bound_clock_manager
    generate_library l=$fname(clock_file_string)

    create_module name=nam$bound_initialization_mgr..
          component=$fname(initialization_file_string) sp=nap$independent_init_manager..
          gate=nap$independent_init_manager output=$fname(temp_map_string) ibsm=true
    change_module_attributes module=nam$bound_initialization_mgr..
          omit_library=cyf$run_time_library
    change_module_attributes module=nam$bound_initialization_mgr..
          not_gate=(cyp$allocate, cyp$free, cyp$stringrep)
    change_module_attributes module=nam$bound_initialization_mgr onrep=on
    add_copyright nam$bound_initialization_mgr
    generate_library l=$fname(initialization_file_string)

    create_module name=nam$bound_file_access_manager..
          component=$fname(file_access_file_string) sp=nap$file_access_me..
          gate=nap$file_access_me output=$fname(temp_map_string) ibsm=true
    change_module_attributes module=nam$bound_file_access_manager..
          omit_library=cyf$run_time_library
    change_module_attributes module=nam$bound_file_access_manager..
          not_gate=(cyp$allocate, cyp$free)
    change_module_attributes module=nam$bound_file_access_manager onrep=on
    add_copyright nam$bound_file_access_manager
    generate_library l=$fname(file_access_file_string)

    create_module name=nam$bound_log_manager..
          component=$fname(log_file_string) sp=nap$log_me..
          gate=nap$log_me output=$fname(temp_map_string) ibsm=true
    change_module_attributes module=nam$bound_log_manager..
          omit_library=cyf$run_time_library
    change_module_attributes module=nam$bound_log_manager..
          not_gate=(cyp$allocate, cyp$free)
    change_module_attributes module=nam$bound_log_manager onrep=on
    add_copyright nam$bound_log_manager
    generate_library l=$fname(log_file_string)

    create_linked_module n=nam$bound_clock_manager ..
          c=(($fname(clock_file_string),nam$bound_clock_manager)) rb=(4,6,13) ..
          dt=$fname(maint_catalog_path//'.clock_debug_tables') ..
          o=$fname(temp_map_string) isn=on

    create_linked_module n=nam$bound_file_access_manager ..
          c=(($fname(file_access_file_string),nam$bound_file_access_manager)) rb=(4,6,13) ..
          dt=$fname(maint_catalog_path//'.file_access_debug_tables') ..
          o=$fname(temp_map_string) isn=on

    create_linked_module n=nam$bound_log_manager ..
          c=(($fname(log_file_string),nam$bound_log_manager)) rb=(4,6,13) ..
          dt=$fname(maint_catalog_path//'.log_debug_tables') ..
          o=$fname(temp_map_string) isn=on

    create_linked_module n=nam$bound_initialization_mgr..
          c=(($fname(initialization_file_string),nam$bound_initialization_mgr)) rb=(4,6,13) ..
          dt=$fname(maint_catalog_path//'.initialization_debug_tables') ..
          o=$fname(temp_map_string) isn=on

    generate_library $value(bound_network_management)

  QUIT

  display_object_library $value(bound_network_operator) display_options=all ..
        output=$fname(temp_map_string)
  display_object_library $value(bound_network_op_commands) display_options=all ..
        output=$fname(temp_map_string)
  display_object_library $value(bound_network_administrator) display_options=all ..
        output=$fname(temp_map_string)
  display_object_library $value(bound_network_management) display_options=all ..
        output=$fname(temp_map_string)
  set_file_attributes $fname(temp_map_string) op=$boi
  copy_file $fname(temp_map_string) $value(map)
  detach_file $fname(temp_map_string)

  delete_file netoc_file_string status=ignore_status
  delete_file netou_file_string status=ignore_status
  delete_file manna_file_string status=ignore_status
  delete_file clock_file_string status=ignore_status
  delete_file restricted_unbound_component status=ignore_status
  delete_file log_file_string status=ignore_status
  delete_file instr_file_string status=ignore_status

  delete_catalog $user.network.operator status=ignore_status
  delete_catalog $user.network.administrator status=ignore_status
  delete_catalog $user.network.management status=ignore_status
  delete_catalog $user.network.maintenance status=ignore_status
  delete_catalog $user.network status=ignore_status

PROCEND bind_network_management
*DECK DECK=RAM$BIN_SEARCH EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE ram$bin_search;
?? PUSH (LISTEXT := ON) ??
*copyc rat$match_decks
?? POP ??

*copyc rah$bin_search

  PROCEDURE [XDCL] rap$bin_search (name: ost$name;
        new_array: ^rat$match_decks;
    VAR j: rat$deck_index;
    VAR found: boolean);

    VAR
      temp: integer,
      hi: rat$deck_index,
      low: rat$deck_index,
      mid: rat$deck_index;

    found := FALSE;
    hi := UPPERBOUND (new_array^);
    low := j;
    WHILE (low <= hi) AND NOT found DO
      temp := low + hi;
      mid := temp DIV 2;
      IF name = new_array^ [mid].name THEN
        found := TRUE;
      ELSEIF name > new_array^ [mid].name THEN
        low := mid + 1;
      ELSE
        hi := mid - 1;
      IFEND;
    WHILEND;
    IF found THEN
      j := mid;
    IFEND;
  PROCEND rap$bin_search;
MODEND ram$bin_search;
*DECK DECK=RAM$BOOT_UPGRADE_SOFTWARE EXPAND=TRUE
PROC boot_upgrade_software (
  status : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"     The purpose of this procedure is to setup the environment for the UPGRADE SOFTWARE utility
"to execute and install the BASE_1 tape.  This procedure is called by INSTALL_REQUIRED_FILES.
*IFEND


  create_variable ignore_status kind=status
  create_variable local_status kind=status


boot_block: ..
  BLOCK

    detach_file $local.raf$library status=ignore_status
    copy_file $system.software_maintenance.installation_catalog.raf$library $local.raf$library ..
          status=local_status
    EXIT boot_block WHEN NOT local_status.normal

    detach_file $local.cyf$run_time_library status=ignore_status
    copy_file $system.software_maintenance.installation_catalog.cyf$run_time_library ..
          $local.cyf$run_time_library status=local_status
    EXIT boot_block WHEN NOT local_status.normal

    detach_file $local.smf$library status=ignore_status
    copy_file $system.software_maintenance.installation_catalog.smf$library $local.smf$library ..
          status=local_status
    EXIT boot_block WHEN NOT local_status.normal

    detach_file $local.aaf$44d_library status=ignore_status
    copy_file $system.software_maintenance.installation_catalog.aaf$44d_library $local.aaf$44d_library ..
          status=local_status
    EXIT boot_block WHEN NOT local_status.normal

    detach_file $local.aaf$4dd_library status=ignore_status
    copy_file $system.software_maintenance.installation_catalog.aaf$4dd_library $local.aaf$4dd_library ..
          status=local_status
    EXIT boot_block WHEN NOT local_status.normal

    detach_file $local.mlf$library status=ignore_status
    copy_file $system.software_maintenance.installation_catalog.mlf$library $local.mlf$library ..
          status=local_status
    EXIT boot_block WHEN NOT local_status.normal

    copy_file $system.software_maintenance.installation_catalog.installation_table ..
          $system.software_maintenance.installation_table status=local_status
    EXIT boot_block WHEN NOT local_status.normal

    change_file_attributes $local.aaf$44d_library ring_attributes=(4 4 13)
    change_file_attributes $local.aaf$4dd_library ring_attributes=(4 13 13)
    change_file_attributes $local.mlf$library ring_attributes=(4 13 13)

  BLOCKEND boot_block

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND boot_upgrade_software
*DECK DECK=RAM$BUILD_ELEMENT_LIST EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$build_element_list;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc rac$status_id
*copyc rav$class_types
*copyc rae$error_messages
*copyc rat$installation_table
*copyc rat$correction_package
*copyc rat$element_descriptor
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
?? POP ??

*copyc rah$build_element_list

  PROCEDURE [XDCL] rap$build_element_list (table: ^rat$installation_table;
        name: ost$name;
    VAR element_list: ^array [1 .. * ] OF rat$element_descriptor;
    VAR last: rat$element_index;
    VAR status: ost$status);

    VAR
      found: boolean,
      found_in_table: boolean,
      i: rat$element_index,
      j: rat$element_index;

    status.normal := TRUE;

    IF name = 'ALL' THEN
      j := 1;
      FOR i := 1 TO UPPERBOUND (table^) DO
        IF (table^ [i].class <> rac$os_support) AND (table^ [i].class <> rac$none) AND (table^ [i].format <>
              rac$unused_format) AND (table^ [i].format <> rac$online_manual) AND (table^ [i].format <>
              rac$symbol_table) AND (table^ [i].format <> rac$real_state_library) AND (table^ [i].format <>
              rac$deadstart_tape_modules) AND (table^ [i].format <> rac$installation_table) THEN
          element_list^ [j].name := table^ [i].mnemonic_name;
          element_list^ [j].format := table^ [i].format;
          element_list^ [j].class := table^ [i].class;
          j := j + 1;
        IFEND;
      FOREND;
      last := j - 1;
    ELSEIF name = 'OS' THEN
      FOR i := 1 TO UPPERBOUND (table^) DO
        IF (table^ [i].class = rac$os) THEN
          j := 1;
          found := FALSE;
          WHILE (j <= last) AND NOT found DO
            IF element_list^ [j].name = table^ [i].mnemonic_name THEN
              found := TRUE;
            IFEND;
            j := j + 1;
          WHILEND;
          IF NOT found THEN
            last := last + 1;
            element_list^ [last].name := table^ [i].mnemonic_name;
            element_list^ [last].format := table^ [i].format;
            element_list^ [last].class := table^ [i].class;
          IFEND;
        IFEND;
      FOREND;
    ELSE
      j := 1;
      found := FALSE;
      WHILE (j <= last) AND NOT found DO
        IF element_list^ [j].name = name THEN
          found := TRUE;
        IFEND;
        j := j + 1;
      WHILEND;
      IF NOT found THEN
        found_in_table := FALSE;

      /get_one_element/
        FOR i := 1 TO UPPERBOUND (table^) DO
          IF table^ [i].mnemonic_name = name THEN
            IF (table^ [i].class = rac$os_support) OR (table^ [i].class = rac$none) THEN
              osp$set_status_abnormal (rac$status_id, rae$element_class_not_supported, name, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, rav$class_types [table^ [i].class],
                    status);
              RETURN;
            IFEND;

            last := last + 1;
            element_list^ [last].name := table^ [i].mnemonic_name;
            element_list^ [last].format := table^ [i].format;
            element_list^ [last].class := table^ [i].class;
            found_in_table := TRUE;
            EXIT /get_one_element/
          IFEND;
        FOREND /get_one_element/;
        IF NOT found_in_table THEN
          osp$set_status_abnormal (rac$status_id, rae$element_not_in_install_tble, name, status);
          RETURN;
        IFEND;
      IFEND;
    IFEND;
  PROCEND rap$build_element_list;
MODEND ram$build_element_list;
*DECK DECK=RAM$BUILD_REAL_MEMORY EXPAND=TRUE
create_program_description name=(build_real_memory, buirm) sp=ocp$build_real_memory ss=3000000 ..
      l=('$system.ocu.bound_product' osf$task_services_library) tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$BUILD_REPLACEMENT_SL EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE ram$build_replacement_sl;
?? PUSH (LISTEXT := ON) ??
*copyc clt$file_reference
*copyc pfd$permanent_file_definitions
*copyc rat$file_values
*copyc rat$match_decks
*copyc rat$open_file_list
*copyc rat$write_scl_commands
*copyc amp$close
*copyc amp$open
*copyc amp$put_next
*copyc amp$return
*copyc clp$scan_command_line
*copyc pfp$delete_permit
*copyc pfp$permit
*copyc pmp$get_unique_name
*copyc pmp$get_user_identification
?? POP ??

*copyc rah$build_replacement_sl

  PROCEDURE [XDCL] rap$build_replacement_sl (source_file: rat$file_values;
        decks_ok: ^array [1 .. * ] OF ost$name;
        replace_sl: ost$name;
    VAR status: ost$status);

    VAR
      application_info: pft$application_info,
      ba: amt$file_byte_address,
      command: ^array [1 .. * ] of rat$write_scl_commands,
      command_fid: amt$file_identifier,
      command_file: ost$name,
      found: boolean,
      group: pft$group,
      i: rat$deck_index,
      identification: ost$user_identification,
      ignore_status: ost$status,
      j: rat$deck_index,
      k: integer,
      permit_selections: pft$permit_selections,
      permit_status: ost$status,
      rav$open_file_list: [STATIC, XREF] rat$open_file_list,
      share_requirements: pft$share_requirements,
      size: integer,
      text: string (osc$max_string_size);

    pmp$get_unique_name (command_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (command_file, amc$record, NIL, command_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF decks_ok = NIL THEN
      PUSH command: [1 .. 3];
    ELSE
      PUSH command: [1 .. UPPERBOUND (decks_ok^) + 3];
    IFEND;

    STRINGREP (command^ [1].command, command^ [1].size, ' scu');
    STRINGREP (command^ [2].command, command^ [2].size, ' use_library b=',
          source_file.ref.path_name (1, source_file.ref.path_name_size), ' r=', replace_sl);
    j := 3;
    IF decks_ok <> NIL THEN
      FOR i := 1 TO UPPERBOUND (decks_ok^) DO
        STRINGREP (command^ [j].command, command^ [j].size, '   delete_deck ', decks_ok^ [i]);
        j := j + 1;
      FOREND;
    IFEND;
    STRINGREP (command^ [j].command, command^ [j].size, ' quit wl=true');

    FOR i := 1 TO j DO
      amp$put_next (command_fid, ^command^ [i].command, command^ [i].size, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    amp$close (command_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


{    In order to successfully run SCU a permit must be built giving the user all authority }
{  on access mode and an application information value of 'I4'.                            }
{    The permit is deleted as soon as possible.  The source library used is from the       }
{  installation catalog and so the assumption that a permit does'nt already exist can      }
{  be made. }


    pmp$get_user_identification (identification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    group.group_type := pfc$user;
    group.user_description.family := identification.family;
    group.user_description.user := identification.user;

    application_info := 'I4';
    permit_selections := $pft$permit_selections [pfc$read, pfc$shorten, pfc$append, pfc$modify,
          pfc$execute, pfc$cycle, pfc$control];
    share_requirements := $pft$share_requirements [];

    pfp$permit (source_file.path^, group, permit_selections, share_requirements,
          application_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$return (source_file.lfn, ignore_status);
    k := 1;
    found := FALSE;
    WHILE (k <= UPPERBOUND (rav$open_file_list)) AND NOT found DO
      IF rav$open_file_list [k].name = source_file.lfn THEN
        rav$open_file_list [k].attached := FALSE;
        found := TRUE;
      IFEND;
      k := k + 1;
    WHILEND;

    STRINGREP (text, size, ' include_file f=', command_file);
    clp$scan_command_line (text (1, size), status);
    pfp$delete_permit (source_file.path^, group, permit_status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT permit_status.normal THEN
      status := permit_status;
      RETURN;
    IFEND;

    amp$return (command_file, ignore_status);

  PROCEND rap$build_replacement_sl;
MODEND ram$build_replacement_sl;
*DECK DECK=RAM$CHANGE_CORRECTION_ATTRIB EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'CREATE_SUBPRODUCT_CORRECTION subutility: CHANGE_CORRECTION_ATTRIBUTE command.' ??
MODULE ram$change_correction_attrib;

{ PURPOSE:
{   This module contains the procedures to change certain subproduct
{   attributes of the subproduct correction and to add a list of PSRs.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$package_software_cc
*copyc rat$subproduct_info_types
?? POP ??
*copyc clp$evaluate_parameters
*copyc osp$set_status_abnormal
*copyc rap$process_psrs_entered
*copyc rap$validate_installation_paths
*copyc rav$correction_process_record

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$change_correction_attrib', EJECT ??

{ PURPOSE:
{   This procedure changes certain attributes of the subproduct
{   correction and/or adds a list of PSRs to the subproduct info
{   sequence in memory.
{
{ DESIGN:
{   This procedure changes the values of the specified attributes in the
{   subproduct information file.  The values replace the values set by the
{   DEFINE_CORRECTION command.  If the installation scheme of the base level
{   is cycle based, it may not be changed to version based.  This procedure
{   is also used to process a list of PSRS answered and add all new PSRs (no
{   duplicates) to the correction definition.  The DEFINE_CORRECTION command
{   must be called before this command.
{
{ NOTES:
{   All PSR names are expected to begin with a letter.  The name may only have
{   letters and numerals.

  PROCEDURE [XDCL] rap$change_correction_attrib
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE chaca_pdt (
{   auto_install, ai: boolean = $optional
{   description, d: string 1..50 = $optional
{   development_group, dg: string 1..31 = $optional
{   hidden, h: boolean = $optional
{   installation_scheme, is: key
{       cycle_based, version_based
{     keyend = $optional
{   psrs_answered, pa: any of
{                        list of name rac$psr_name_length..rac$psr_name_length
{                        file
{                      anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 13] of clt$pdt_parameter_name,
        parameters: array [1 .. 7] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
        type5: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 2] of clt$keyword_specification,
        recend,
        type6: 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$list_type_qualifier,
            element_type_spec: record
              header: clt$type_specification_header,
              qualifier: clt$name_type_qualifier,
            recend,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
          recend,
        recend,
        type7: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 4, 21, 49, 39, 504], clc$command, 13, 7, 0, 0, 0, 0, 7, 'CHACA_PDT'],
            [['AI                             ', clc$abbreviation_entry, 1],
            ['AUTO_INSTALL                   ', clc$nominal_entry, 1],
            ['D                              ', clc$abbreviation_entry, 2],
            ['DESCRIPTION                    ', clc$nominal_entry, 2],
            ['DEVELOPMENT_GROUP              ', clc$nominal_entry, 3],
            ['DG                             ', clc$abbreviation_entry, 3],
            ['H                              ', clc$abbreviation_entry, 4],
            ['HIDDEN                         ', clc$nominal_entry, 4],
            ['INSTALLATION_SCHEME            ', clc$nominal_entry, 5],
            ['IS                             ', clc$abbreviation_entry, 5],
            ['PA                             ', clc$abbreviation_entry, 6],
            ['PSRS_ANSWERED                  ', clc$nominal_entry, 6],
            ['STATUS                         ', clc$nominal_entry, 7]], [
{ PARAMETER 1
      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 2
      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 3
      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 4
      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 5
      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 81, clc$optional_parameter, 0, 0],
{ PARAMETER 6
      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 44, clc$optional_parameter, 0, 0],
{ PARAMETER 7
      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$boolean_type]],
{ PARAMETER 2
      [[1, 0, clc$string_type], [1, 50, FALSE]],
{ PARAMETER 3
      [[1, 0, clc$string_type], [1, 31, FALSE]],
{ PARAMETER 4
      [[1, 0, clc$boolean_type]],
{ PARAMETER 5
      [[1, 0, clc$keyword_type], [2], [['CYCLE_BASED                    ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['VERSION_BASED                  ', clc$nominal_entry,
            clc$normal_usage_entry, 2]]],
{ PARAMETER 6
      [[1, 0, clc$union_type], [[clc$file_type, clc$list_type], FALSE, 2], 21,
            [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$name_type], [rac$psr_name_length, rac$psr_name_length]]], 3, [[1, 0, clc$file_type]]],
{ PARAMETER 7
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$auto_install = 1,
      p$description = 2,
      p$development_group = 3,
      p$hidden = 4,
      p$installation_scheme = 5,
      p$psrs_answered = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

    VAR
      old_psr_list_p: ^rat$psrs_answered,
      attributes: rat$subproduct_attributes;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT rav$correction_process_record.correction_in_progress THEN
      osp$set_status_abnormal ('RA', rae$defc_command_not_called, 'CHANGE_CORRECTION_ATTRIBUTES', status);
      RETURN;
    IFEND;

    attributes := rav$correction_process_record.new_subproduct_info_pointers.attributes_p^;

    IF rav$correction_process_record.previous_correction_sif.file_opened THEN
      old_psr_list_p := rav$correction_process_record.previous_correction_sif.subproduct_info_pointers.
            psrs_answered_p;
    ELSE
      old_psr_list_p := NIL;
    IFEND;

    IF pvt [p$auto_install].specified THEN
      attributes.auto_install := pvt [p$auto_install].value^.boolean_value.value;
    IFEND;

    IF pvt [p$description].specified THEN
      attributes.description := pvt [p$description].value^.string_value^;
    IFEND;

    IF pvt [p$development_group].specified THEN
      attributes.development_group := pvt [p$development_group].value^.string_value^;
    IFEND;

    IF pvt [p$hidden].specified THEN
      attributes.hidden := pvt [p$hidden].value^.boolean_value.value;
    IFEND;

    IF pvt [p$installation_scheme].specified THEN

      IF pvt [p$installation_scheme].value^.keyword_value = 'VERSION_BASED' THEN

        IF (rav$correction_process_record.base_level_sif.subproduct_info_pointers.attributes_p^.
              installation_scheme = rac$cycle_based) THEN
          osp$set_status_abnormal ('RA', rae$incorrect_inst_scheme, '', status);
          RETURN;
        ELSE
          attributes.installation_scheme := rac$version_based;
        IFEND;

      ELSE {pvt [p$installation_scheme].value^.keyword_value = CYCLE_BASED}

        rap$validate_installation_paths (rav$correction_process_record.base_level_sif.
              subproduct_info_pointers.attributes_p^, rav$correction_process_record.base_level_sif.
              subproduct_info_pointers.path_container_p^, rav$correction_process_record.current_level_sif.
              subproduct_info_pointers.attributes_p^, rav$correction_process_record.current_level_sif.
              subproduct_info_pointers.path_container_p^, rac$cycle_based, TRUE {set_status_to_error},
              status);

        IF NOT status.normal THEN
          RETURN;
        IFEND;

        attributes.installation_scheme := rac$cycle_based;

      IFEND;

    IFEND;

    IF pvt [p$auto_install].specified THEN
      attributes.auto_install := pvt [p$auto_install].value^.boolean_value.value;
    IFEND;

    IF pvt [p$psrs_answered].specified THEN
      rap$process_psrs_entered (pvt [p$psrs_answered].value^,
            rav$correction_process_record.new_subproduct_info_pointers,
            rav$correction_process_record.previous_correction_sif, status);
    IFEND;

    IF status.normal THEN
      rav$correction_process_record.new_subproduct_info_pointers.attributes_p^ := attributes;
    IFEND;

  PROCEND rap$change_correction_attrib;

MODEND ram$change_correction_attrib;

*DECK DECK=RAM$CHANGE_INSTALLATION_DEFAULT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: CHANGE_INSTALLATION_DEFAULTS Subcommand.' ??
MODULE ram$change_installation_default;

{ PURPOSE:
{   This module contains the command interface and procedures to change the
{   installation defaults.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$install_software_cc
*copyc rae$package_software_cc
*copyc rat$path
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc osp$set_status_abnormal
*copyc rav$installation_defaults

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$change_installation_default', EJECT ??

{ PURPOSE:
{   This command interface allows the user to change the installation
{   defaults used by the Install_Software Utility.
{
{ DESIGN:
{   Changing installation defaults revolves around changing the catalogs to
{   which various installation pieces are placed or expected to reside.
{   The default values for these catalogs are in the software
{   maintenance catalog under $system.
{
{   For each pdt parameter associated with this interface there is a path
{   field in the installation defaults variable that stores the current
{   path value.  When a parameter is specified the new value will replace
{   the current value of the associated path field.
{
{   In addition to changing the software matenance catalogs directly, there
{   are three hidden features for the benefit of INSS testing.
{
{   The first feature allows for testing to occur under any user catalog,
{   and still retain the basic catalog structures used by INSTALL_SOFTWARE.
{   By using the SYSTEM_CATALOG parameter, the family and user catalogs of
{   the software_maintenance catalogs are replaced with the catalog path
{   specified.  When an software_maintenance catalog parameter is specified
{   along with the SYSTEM_CATALOG parameter the family and user catalogs of
{   that software_maintenance catalog will not be replaced.  The complete
{   path specified by the software_maintenance catalog parameter will be
{   used instead.
{
{   The second hidden feature allows for storage class to be ignored.  This
{   is specified by IGNORE_STORAGE_CLASS parameter.  When set to TRUE all
{   products will be installed to the PRODUCT storage class which is avaiable
{   to all users.
{
{   The third hidden feature (provided for testing) is to relax ring
{   setting.  This allows the tester to install real products within their
{   own user environment regardless of minimum ring privileges.  Any ring
{   values (declared in the packing list for a file) that are below the
{   user's minimum ring will be set at the user's minimum ring value.  This
{   is specified with the RELAX_RING_SETTINGS parameter.
{
{   The only validation that occurs is checking for $LOCAL as the catalog
{   input.  It is assumed the path designates a catalog and not a file.
{
{   There is no verification that the caller has permission to create
{   catalogs and cycles in the specified catalogs.  It is left to be
{   discovered when the action to create catalogs or cycles occurs.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$change_installation_default
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE chaid_pdt (
{     installation_database, idb, id: file = $optional
{     installation_logs, il: file = $optional
{     correction_bases, cb: (BY_NAME, HIDDEN) file = $optional
{     correction_packages, cp: (BY_NAME, HIDDEN) file = $optional
{     ignore_storage_class,isc : (BY_NAME, HIDDEN) boolean = $optional
{     relax_ring_settings,rrs : (BY_NAME, HIDDEN) boolean = $optional
{     system_catalog,sc : (BY_NAME, HIDDEN) file = $optional
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 16] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [93, 8, 12, 11, 23, 14, 639],
    clc$command, 16, 8, 0, 0, 5, 0, 8, ''], [
    ['CB                             ',clc$abbreviation_entry, 3],
    ['CORRECTION_BASES               ',clc$nominal_entry, 3],
    ['CORRECTION_PACKAGES            ',clc$nominal_entry, 4],
    ['CP                             ',clc$abbreviation_entry, 4],
    ['ID                             ',clc$abbreviation_entry, 1],
    ['IDB                            ',clc$alias_entry, 1],
    ['IGNORE_STORAGE_CLASS           ',clc$nominal_entry, 5],
    ['IL                             ',clc$abbreviation_entry, 2],
    ['INSTALLATION_DATABASE          ',clc$nominal_entry, 1],
    ['INSTALLATION_LOGS              ',clc$nominal_entry, 2],
    ['ISC                            ',clc$abbreviation_entry, 5],
    ['RELAX_RING_SETTINGS            ',clc$nominal_entry, 6],
    ['RRS                            ',clc$abbreviation_entry, 6],
    ['SC                             ',clc$abbreviation_entry, 7],
    ['STATUS                         ',clc$nominal_entry, 8],
    ['SYSTEM_CATALOG                 ',clc$nominal_entry, 7]],
    [
{ PARAMETER 1
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [2, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [3, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [7, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [12, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [16, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$file_type]],
{ PARAMETER 4
    [[1, 0, clc$file_type]],
{ PARAMETER 5
    [[1, 0, clc$boolean_type]],
{ PARAMETER 6
    [[1, 0, clc$boolean_type]],
{ PARAMETER 7
    [[1, 0, clc$file_type]],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$installation_database = 1,
      p$installation_logs = 2,
      p$correction_bases = 3,
      p$correction_packages = 4,
      p$ignore_storage_class = 5,
      p$relax_ring_settings = 6,
      p$system_catalog = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    validate_parameters (pvt [p$correction_bases], pvt [p$correction_packages], pvt [p$installation_database],
          pvt [p$installation_logs], pvt [p$ignore_storage_class], pvt [p$relax_ring_settings],
          pvt [p$system_catalog], status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$correction_bases].specified THEN
      rav$installation_defaults.correction_bases.size := clp$trimmed_string_size
            (pvt [p$correction_bases].value^.file_value^);
      rav$installation_defaults.correction_bases.path := pvt [p$correction_bases].value^.file_value^;
    ELSEIF pvt [p$system_catalog].specified THEN
      replace_system_catalog (pvt [p$system_catalog].value^.file_value^,
            rav$installation_defaults.correction_bases);
    IFEND;

    IF pvt [p$correction_packages].specified THEN
      rav$installation_defaults.correction_packages.size :=
            clp$trimmed_string_size (pvt [p$correction_packages].value^.file_value^);
      rav$installation_defaults.correction_packages.path := pvt [p$correction_packages].value^.file_value^;
    ELSEIF pvt [p$system_catalog].specified THEN
      replace_system_catalog (pvt [p$system_catalog].value^.file_value^,
            rav$installation_defaults.correction_packages);
    IFEND;

    IF pvt [p$installation_database].specified THEN
      rav$installation_defaults.installation_database.size :=
            clp$trimmed_string_size (pvt [p$installation_database].value^.file_value^);
      rav$installation_defaults.installation_database.path := pvt [p$installation_database].value^.
            file_value^;
    ELSEIF pvt [p$system_catalog].specified THEN
      replace_system_catalog (pvt [p$system_catalog].value^.file_value^,
            rav$installation_defaults.installation_database);
    IFEND;

    IF pvt [p$installation_logs].specified THEN
      rav$installation_defaults.installation_logs.size := clp$trimmed_string_size
            (pvt [p$installation_logs].value^.file_value^);
      rav$installation_defaults.installation_logs.path := pvt [p$installation_logs].value^.file_value^;
    ELSEIF pvt [p$system_catalog].specified THEN
      replace_system_catalog (pvt [p$system_catalog].value^.file_value^,
            rav$installation_defaults.installation_logs);
    IFEND;

    IF pvt [p$ignore_storage_class].specified THEN
      rav$installation_defaults.ignore_storage_class := pvt [p$ignore_storage_class].value^.boolean_value.
            value;
    IFEND;

    IF pvt [p$relax_ring_settings].specified THEN
      rav$installation_defaults.relax_ring_settings := pvt [p$relax_ring_settings].value^.boolean_value.value;
    IFEND;

    IF pvt [p$system_catalog].specified THEN
      rav$installation_defaults.system_catalog.size := clp$trimmed_string_size
            (pvt [p$system_catalog].value^.file_value^);
      rav$installation_defaults.system_catalog.path := pvt [p$system_catalog].value^.file_value^;
    IFEND;

  PROCEND rap$change_installation_default;

?? TITLE := 'replace_system_catalog', EJECT ??

{ PURPOSE:
{   This procedure replaces the family and user catalogs of a path with the
{   supplied system catalog path.
{
{ DESIGN:
{   The assumptions being made are:  The path contains a family and user
{   catalog, and if only one delimiter ('.') is found the whole path is the
{   master catalog.
{
{ NOTES:
{   This will probably be developed into an interface used in applying the
{   system catalog to the subproduct installation paths.
{

  PROCEDURE replace_system_catalog
    (    system_catalog: fst$file_reference;
     VAR path {input, output} : rat$path);


    CONST
      catalog_delimiter = '.',
      family_user_catalogs = 2;


    VAR
      index: integer,
      number_of_catalogs_found: integer,
      temp_path: rat$path;


    index := 1;
    number_of_catalogs_found := 0;
    temp_path := path;

    WHILE (index <= temp_path.size) AND (number_of_catalogs_found <> family_user_catalogs) DO
      IF temp_path.path (index, 1) = catalog_delimiter THEN
        number_of_catalogs_found := number_of_catalogs_found + 1;
      IFEND;
      index := index + 1;
    WHILEND;

    path.path (1, * ) := '';

    IF index > temp_path.size THEN
      STRINGREP (path.path, path.size, system_catalog);
    ELSE
      STRINGREP (path.path, path.size, system_catalog, temp_path.
            path ((index - 1), (temp_path.size - index + 2)));
    IFEND;

  PROCEND replace_system_catalog;

?? TITLE := 'validate_parameters', EJECT ??

{ PURPOSE:
{   This procedure validates the command interfaces parameters within
{   the context of INSTALL_SOFTWARE.
{
{ DESIGN:
{   The input parameters are check so that at least one of the parameters
{   is specified and that any specified catalog paths cannot be to the
{   $LOCAL catalog.
{
{   Validation errors are returned in the status.  Returns on first
{   error encountered.
{
{ NOTES:
{

  PROCEDURE validate_parameters
    (    correction_bases: clt$parameter_value;
         correction_packages: clt$parameter_value;
         installation_database: clt$parameter_value;
         installation_logs: clt$parameter_value;
         ignore_storage_class: clt$parameter_value;
         relax_ring_settings: clt$parameter_value;
         system_catalog: clt$parameter_value;
     VAR status: ost$status);


    VAR
      local_catalog: [STATIC] rat$path := [7, ':$LOCAL'];

    IF (correction_bases.specified) AND (correction_bases.value^.file_value^ (1,
          local_catalog.size) = local_catalog.path) THEN
      osp$set_status_abnormal ('RA', rae$cannot_use_local_catalog, 'CORRECTION_BASES', status);
      RETURN;
    IFEND;

    IF (correction_packages.specified) AND (correction_packages.value^.file_value^ (1,
          local_catalog.size) = local_catalog.path) THEN
      osp$set_status_abnormal ('RA', rae$cannot_use_local_catalog, 'CORRECTION_PACKAGES', status);
      RETURN;
    IFEND;

    IF (installation_database.specified) AND (installation_database.value^.
          file_value^ (1, local_catalog.size) = local_catalog.path) THEN
      osp$set_status_abnormal ('RA', rae$cannot_use_local_catalog, 'INSTALLATION_DATABASE', status);
      RETURN;
    IFEND;

    IF (installation_logs.specified) AND (installation_logs.value^.file_value^ (1,
          local_catalog.size) = local_catalog.path) THEN
      osp$set_status_abnormal ('RA', rae$cannot_use_local_catalog, 'INSTALLATION_LOGS', status);
      RETURN;
    IFEND;

    IF (system_catalog.specified) AND (system_catalog.value^.file_value^ (1,
          local_catalog.size) = local_catalog.path) THEN
      osp$set_status_abnormal ('RA', rae$cannot_use_local_catalog, 'SYSTEM_CATALOG', status);
      RETURN;
    IFEND;

  PROCEND validate_parameters;

MODEND ram$change_installation_default;
*DECK DECK=RAM$CHANGE_INSTALLATION_PATH EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: CHANGE_INSTALLATION_PATH Subcommand.' ??
MODULE ram$change_installation_path;

{ PURPOSE:
{   This module contains the interface that allows the user to
{   define a product's installation path.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$packing_list_level
*copyc rac$pacs_processor_version
*copyc rac$special_product_designators
*copyc rae$install_software_cc
*copyc rat$processing_types
?? POP ??
*copyc amp$fetch_access_information
*copyc amp$get_segment_pointer
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc rav$installation_defaults
*copyc rav$product_reference
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    subproduct_pointers_array = array [ * ] of rat$subproduct_info_pointers;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$change_installation_path', EJECT ??

{ PURPOSE:
{   This interface allows users to define the family and/or user
{   name portion of a product's installation path, when the
{   path is declared as user definable.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$change_installation_path
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE chaip_pdt (
{   packing_list, pl: name = $required
{   product, p: name = $required
{   family_name, fn: name = $optional
{   user_name, un: name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 9, 21, 9, 34, 28, 765],
    clc$command, 9, 5, 2, 0, 0, 0, 5, 'CHAIP_PDT'], [
    ['FAMILY_NAME                    ',clc$nominal_entry, 3],
    ['FN                             ',clc$abbreviation_entry, 3],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PACKING_LIST                   ',clc$nominal_entry, 1],
    ['PL                             ',clc$abbreviation_entry, 1],
    ['PRODUCT                        ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['UN                             ',clc$abbreviation_entry, 4],
    ['USER_NAME                      ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 4
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$packing_list = 1,
    p$product = 2,
    p$family_name = 3,
    p$user_name = 4,
    p$status = 5;

  VAR
    pvt: array [1 .. 5] of clt$parameter_value;


    VAR
      file_opened: boolean,
      ignore_status: ost$status,
      local_status: ost$status,
      packing_list_fid: amt$file_identifier,
      packing_list_pointers: rat$packing_list_pointers,
      packing_list_segment_pointer: amt$segment_pointer,
      scratch_segment_pointer: amt$segment_pointer,
      sequence_length: integer,
      subproduct_pointers_p: ^subproduct_pointers_array;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to close the scratch
{   sequence and packing list when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF scratch_segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (scratch_segment_pointer, ignore_status);
        scratch_segment_pointer.sequence_pointer := NIL;
      IFEND;

      fsp$close_file (packing_list_fid, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (NOT pvt [p$family_name].specified) AND (NOT pvt [p$user_name].specified) THEN
      osp$set_status_abnormal ('RA', rae$family_or_user_param_reqrd, '', status);
      RETURN;
    IFEND;

    scratch_segment_pointer.kind := amc$sequence_pointer;
    scratch_segment_pointer.sequence_pointer := NIL;
    file_opened := FALSE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, scratch_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      open_packing_list_write_access (pvt [p$packing_list].value^.name_value,
            rav$installation_defaults.installation_database, scratch_segment_pointer, packing_list_fid,
            file_opened, packing_list_segment_pointer, sequence_length, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      establish_packing_list_pointers (pvt [p$packing_list].value^.name_value,
            rav$installation_defaults.installation_database, scratch_segment_pointer, packing_list_pointers,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      PUSH subproduct_pointers_p: [1 .. packing_list_pointers.header_p^.subproduct_count];

      establish_subproduct_pointers (pvt [p$packing_list].value^.name_value,
            rav$installation_defaults.installation_database, packing_list_pointers, subproduct_pointers_p,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      process_change_request (pvt [p$product].value^.name_value, pvt [p$family_name], pvt [p$user_name],
            subproduct_pointers_p, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      write_packing_list_file (pvt [p$packing_list].value^.name_value,
            rav$installation_defaults.installation_database, sequence_length, scratch_segment_pointer,
            packing_list_segment_pointer, status);

    END /main/;

    IF file_opened THEN
      fsp$close_file (packing_list_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF scratch_segment_pointer.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (scratch_segment_pointer, local_status);
      scratch_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$change_installation_path;

?? OLDTITLE ??
?? NEWTITLE := 'change_path', EJECT ??

{ PURPOSE:
{   This procedure ...
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE change_path
    (    family_name: clt$parameter_value;
         user_name: clt$parameter_value;
         subproduct_pointers {output} : rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      family_catalog_index: rat$path_container_index,
      user_catalog_index: rat$path_container_index;


    status.normal := TRUE;

    IF subproduct_pointers.attributes_p^.installation_path_option = rac$not_definable THEN

      osp$set_status_abnormal ('RA', rae$inst_path_not_definable, subproduct_pointers.attributes_p^.name,
            status);

    ELSEIF (subproduct_pointers.attributes_p^.installation_path_option = rac$definable_user_name) AND
          family_name.specified THEN

      osp$set_status_abnormal ('RA', rae$sip_family_not_definable, subproduct_pointers.attributes_p^.name,
            status);

    ELSEIF (subproduct_pointers.attributes_p^.installation_path_option = rac$definable_family_name) AND
          user_name.specified THEN

      osp$set_status_abnormal ('RA', rae$sip_user_not_definable, subproduct_pointers.attributes_p^.name,
            status);

    ELSE {the change is valid}

      family_catalog_index := subproduct_pointers.attributes_p^.installation_path.path_container_index;

      IF family_name.specified THEN
        subproduct_pointers.path_container_p^ [family_catalog_index] := family_name.value^.name_value;
      IFEND;

      IF user_name.specified THEN
        user_catalog_index := family_catalog_index + 1;
        subproduct_pointers.path_container_p^ [user_catalog_index] := user_name.value^.name_value;
      IFEND;

    IFEND;

  PROCEND change_path;

?? OLDTITLE ??
?? NEWTITLE := 'establish_packing_list_pointers', EJECT ??

{ PURPOSE:
{   This procedure establishes the pointers to the major data structures
{   in the packing list.
{
{ DESIGN:
{
{   Validation errors are returned in the status variable.
{
{ NOTES:
{

  PROCEDURE establish_packing_list_pointers
    (    packing_list_name: ost$name;
         installation_database: rat$path;
         scratch_segment_pointer: amt$segment_pointer;
     VAR packing_list_pointers: rat$packing_list_pointers;
     VAR status: ost$status);


    VAR
      ignore_status: ost$status,
      local_status: ost$status;


    status.normal := TRUE;

    packing_list_pointers.sequence_p := scratch_segment_pointer.sequence_pointer;

    RESET packing_list_pointers.sequence_p;
    NEXT packing_list_pointers.sequence_descriptor_p IN packing_list_pointers.sequence_p;
    IF packing_list_pointers.sequence_descriptor_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$unexpected_eof_packing_list, packing_list_name, status);
      osp$append_status_file (osc$status_parameter_delimiter, installation_database.
            path (1, installation_database.size), status);
      RETURN;
    IFEND;

    IF packing_list_pointers.sequence_descriptor_p^.sequence_type <> rac$packing_list_sequence THEN
      osp$set_status_abnormal ('RA', rae$invalid_packing_list, packing_list_name, status);
      osp$append_status_file (osc$status_parameter_delimiter, installation_database.
            path (1, installation_database.size), status);
      RETURN;
    IFEND;

    IF packing_list_pointers.sequence_descriptor_p^.sequence_level <> rac$packing_list_level THEN
      osp$set_status_abnormal ('RA', rae$incompatible_sequence_level, 'PACKING LIST', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            packing_list_pointers.sequence_descriptor_p^.sequence_level, status);
      RETURN;
    IFEND;

    IF packing_list_pointers.sequence_descriptor_p^.processor_version <> rac$pacs_processor_version THEN
      osp$set_status_abnormal ('RA', rae$different_processor_version, 'PACKING LIST', local_status);
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
    IFEND;

    NEXT packing_list_pointers.header_p IN packing_list_pointers.sequence_p;
    IF packing_list_pointers.header_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$unexpected_eof_packing_list, packing_list_name, status);
      osp$append_status_file (osc$status_parameter_delimiter, installation_database.
            path (1, installation_database.size), status);
      RETURN;
    IFEND;

    packing_list_pointers.order_medium := packing_list_pointers.header_p^.order_medium;

    IF packing_list_pointers.order_medium = rac$tape THEN

      packing_list_pointers.tape_subproduct_indexer_p := #PTR (packing_list_pointers.header_p^.
            tape_subproduct_indexer_p, packing_list_pointers.sequence_p^);

      packing_list_pointers.tape_vsns_p := #PTR (packing_list_pointers.header_p^.tape_vsns_p,
            packing_list_pointers.sequence_p^);

    ELSE { order medium = rac$disk }

      packing_list_pointers.disk_subproduct_indexer_p := #PTR (packing_list_pointers.header_p^.
            disk_subproduct_indexer_p, packing_list_pointers.sequence_p^);

    IFEND;

  PROCEND establish_packing_list_pointers;

?? OLDTITLE ??
?? NEWTITLE := 'establish_subproduct_pointers', EJECT ??

{ PURPOSE:
{   This procedure establishes the pointers to the major data structures
{   of each subproduct info sequence within the packing list.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE establish_subproduct_pointers
    (    packing_list_name: ost$name;
         installation_database: rat$path;
     VAR packing_list_pointers {input} : rat$packing_list_pointers;
     VAR subproduct_pointers_p: ^subproduct_pointers_array;
     VAR status: ost$status);


    VAR
      i: rat$subproduct_count,
      subproduct_pointers: rat$subproduct_info_pointers,
      subproduct_seq_length: amt$file_length,
      subproduct_seq_p: ^cell;


    status.normal := TRUE;

    FOR i := 1 TO packing_list_pointers.header_p^.subproduct_count DO

{ Locate the start of the subproduct info within the packing list.

      IF packing_list_pointers.order_medium = rac$tape THEN
        subproduct_seq_length := packing_list_pointers.tape_subproduct_indexer_p^ [i].subproduct_seq_length;
        subproduct_seq_p := #PTR (packing_list_pointers.tape_subproduct_indexer_p^ [i].subproduct_seq_p,
              packing_list_pointers.sequence_p^);
      ELSE {order medium = rac$disk}
        subproduct_seq_length := packing_list_pointers.disk_subproduct_indexer_p^ [i].subproduct_seq_length;
        subproduct_seq_p := #PTR (packing_list_pointers.disk_subproduct_indexer_p^ [i].subproduct_seq_p,
              packing_list_pointers.sequence_p^);
      IFEND;

      RESET packing_list_pointers.sequence_p TO subproduct_seq_p;

{ Establish the subproduct info as an accessable sequence.

      NEXT subproduct_pointers.subproduct_info_seq_p: [[REP subproduct_seq_length OF cell]] IN
            packing_list_pointers.sequence_p;
      IF subproduct_pointers.subproduct_info_seq_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$unexpected_eof_packing_list, packing_list_name, status);
        osp$append_status_file (osc$status_parameter_delimiter, installation_database.
              path (1, installation_database.size), status);
        RETURN;
      IFEND;

      RESET packing_list_pointers.sequence_p TO subproduct_seq_p;

{ Establish pointers to the major conponents in the subproduct info sequence.

      NEXT subproduct_pointers.sequence_descriptor_p IN packing_list_pointers.sequence_p;
      IF subproduct_pointers.sequence_descriptor_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$unexpected_eof_packing_list, packing_list_name, status);
        osp$append_status_file (osc$status_parameter_delimiter, installation_database.
              path (1, installation_database.size), status);
        RETURN;
      IFEND;

      NEXT subproduct_pointers.info_header_p IN packing_list_pointers.sequence_p;
      IF subproduct_pointers.info_header_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$unexpected_eof_packing_list, packing_list_name, status);
        osp$append_status_file (osc$status_parameter_delimiter, installation_database.
              path (1, installation_database.size), status);
        RETURN;
      IFEND;

      subproduct_pointers.attributes_p := #PTR (subproduct_pointers.info_header_p^.attributes_p,
            subproduct_pointers.subproduct_info_seq_p^);

      subproduct_pointers.path_container_p := #PTR (subproduct_pointers.info_header_p^.path_container_p,
            subproduct_pointers.subproduct_info_seq_p^);

{ Assign the values for the subproduct info pointers just created to the installation control record.

      subproduct_pointers_p^ [i] := subproduct_pointers;

    FOREND;

  PROCEND establish_subproduct_pointers;

?? OLDTITLE ??
?? NEWTITLE := 'open_packing_list_write_access', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to open the packing_list for updating.
{
{ DESIGN:
{   This procedure opens the packing list file in write (modify) mode.  The
{   contents of the packing_list file is copied to a memory scratch
{   sequence where the changes are made.  When all changes are successfully
{   completed the packing list contents from memory is then copied back
{   over the packing list file.
{
{ NOTES:
{

  PROCEDURE open_packing_list_write_access
    (    packing_list_name: ost$name;
         installation_database: rat$path;
     VAR scratch_segment_pointer: amt$segment_pointer;
     VAR packing_list_fid: amt$file_identifier;
     VAR file_opened: boolean;
     VAR packing_list_segment_pointer: amt$segment_pointer;
     VAR sequence_length: integer;
     VAR status: ost$status);


    VAR
      access_information: array [1 .. 1] of amt$access_info,
      attachment_options: array [1 .. 2] of fst$attachment_option,
      file_seq_contents_p: ^SEQ ( * ),
      ignore_status: ost$status,
      memory_seq_contents_p: ^SEQ ( * ),
      packing_list: rat$path;


    status.normal := TRUE;

{ Assemble the path to the packing list using the installation database path and the packing list name.

    STRINGREP (packing_list.path, packing_list.size, rav$installation_defaults.installation_database.
          path (1, rav$installation_defaults.installation_database.size),
          '.', packing_list_name (1, clp$trimmed_string_size (packing_list_name)));

  /main/
    BEGIN

      attachment_options [1].selector := fsc$access_and_share_modes;
      attachment_options [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options [1].access_modes.value := $fst$file_access_options [fsc$read, fsc$modify];
      attachment_options [1].share_modes.selector := fsc$specific_share_modes;
      attachment_options [1].share_modes.value := $fst$file_access_options [];
      attachment_options [2].selector := fsc$create_file;
      attachment_options [2].create_file := TRUE;

      file_opened := TRUE;
      fsp$open_file (packing_list.path (1, packing_list.size), amc$segment, ^attachment_options, NIL, NIL,
            NIL, NIL, packing_list_fid, status);
      IF NOT status.normal THEN
        file_opened := FALSE;
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (packing_list_fid, amc$sequence_pointer, packing_list_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

{ Copy the packing_list into the scratch memory segment.

      access_information [1].key := amc$eoi_byte_address;
      amp$fetch_access_information (packing_list_fid, access_information, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      sequence_length := access_information [1].eoi_byte_address;

      RESET packing_list_segment_pointer.sequence_pointer;
      NEXT file_seq_contents_p: [[REP sequence_length OF cell]] IN
            packing_list_segment_pointer.sequence_pointer;
      IF file_seq_contents_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$unexpected_eof_packing_list,
              packing_list_name (1, clp$trimmed_string_size (packing_list_name)), status);
        osp$append_status_file (osc$status_parameter_delimiter, installation_database.
              path (1, installation_database.size), status);
        EXIT /main/;
      IFEND;

      RESET scratch_segment_pointer.sequence_pointer;
      NEXT memory_seq_contents_p: [[REP sequence_length OF cell]] IN scratch_segment_pointer.sequence_pointer;
      IF memory_seq_contents_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'packing list', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'MEMORY SEQUENCE', status);
        EXIT /main/;
      IFEND;

      memory_seq_contents_p^ := file_seq_contents_p^;

    END /main/;

    IF file_opened AND (NOT status.normal) THEN
      fsp$close_file (packing_list_fid, ignore_status);
    IFEND;

  PROCEND open_packing_list_write_access;

?? OLDTITLE ??
?? NEWTITLE := 'process_change_request', EJECT ??

{ PURPOSE:
{   This procedure ...
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE process_change_request
    (    product_name: ost$name;
         family_name: clt$parameter_value;
         user_name: clt$parameter_value;
     VAR subproduct_pointers_p {input} : ^subproduct_pointers_array;
     VAR status: ost$status);


    VAR
      group_name: ost$name,
      i: rat$subproduct_count,
      j: 0 .. rac$max_additional_products,
      local_status: ost$status,
      changes_made: boolean,
      product_reference: rat$product_references,
      subproduct_attributes_p: ^rat$subproduct_attributes;


    status.normal := TRUE;
    changes_made := FALSE;
    product_reference := rac$not_referenced;

    FOR i := 1 TO UPPERBOUND (subproduct_pointers_p^) DO
      subproduct_attributes_p := subproduct_pointers_p^ [i].attributes_p;

      IF product_name = subproduct_attributes_p^.licensed_product THEN

        product_reference := rac$licensed_product;
        change_path (family_name, user_name, subproduct_pointers_p^ [i], local_status);
        IF local_status.normal THEN
          changes_made := TRUE;
        IFEND;
      ELSEIF product_name = subproduct_attributes_p^.name THEN

        product_reference := rac$subproduct;
        change_path (family_name, user_name, subproduct_pointers_p^ [i], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSE {check for group name}

        group_name (1, * ) := rac$group_designator;
        group_name (clp$trimmed_string_size (rac$group_designator) + 1, * ) :=
              product_name (1, clp$trimmed_string_size (product_name));

      /group/
        FOR j := 1 TO UPPERBOUND (subproduct_attributes_p^.additional_products) DO
          IF group_name = subproduct_attributes_p^.additional_products [j] THEN
            product_reference := rac$group;
            change_path (family_name, user_name, subproduct_pointers_p^ [i], local_status);
            IF local_status.normal THEN
              changes_made := TRUE;
            IFEND;
            EXIT /group/;
          IFEND;
        FOREND /group/;

      IFEND;
    FOREND;

    IF product_reference = rac$not_referenced THEN
      osp$set_status_abnormal ('RA', rae$unknown_product_name,
            product_name (1, clp$trimmed_string_size (product_name)), status);
    ELSEIF (product_reference <> rac$subproduct) AND (NOT changes_made) THEN
      osp$set_status_abnormal ('RA', rae$no_path_changes_made, rav$product_reference [product_reference],
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            product_name (1, clp$trimmed_string_size (product_name)), status);
    IFEND;

  PROCEND process_change_request;

?? OLDTITLE ??
?? NEWTITLE := 'write_packing_list_file', EJECT ??

{ PURPOSE:
{   This procedure copies the modified packing list from memory into the
{   packing list file.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE write_packing_list_file
    (    packing_list_name: ost$name;
         installation_database: rat$path;
         sequence_length: integer;
     VAR scratch_segment_pointer {input} : amt$segment_pointer;
     VAR packing_list_segment_pointer: amt$segment_pointer;
     VAR status: ost$status);


    VAR
      file_seq_contents_p: ^rat$packing_list_sequence,
      memory_seq_contents_p: ^rat$packing_list_sequence;


    status.normal := TRUE;

{ Copy the packing_list from the scratch memory segment to the packing list file.

    RESET scratch_segment_pointer.sequence_pointer;
    NEXT memory_seq_contents_p: [[REP sequence_length OF cell]] IN scratch_segment_pointer.sequence_pointer;
    IF memory_seq_contents_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'packing list', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'MEMORY SEQUENCE', status);
      RETURN;
    IFEND;

    RESET packing_list_segment_pointer.sequence_pointer;
    NEXT file_seq_contents_p: [[REP sequence_length OF cell]] IN
          packing_list_segment_pointer.sequence_pointer;
    IF file_seq_contents_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$unexpected_eof_packing_list,
            packing_list_name (1, clp$trimmed_string_size (packing_list_name)), status);
      osp$append_status_file (osc$status_parameter_delimiter, installation_database.
            path (1, installation_database.size), status);
      RETURN;
    IFEND;

    file_seq_contents_p^ := memory_seq_contents_p^;

  PROCEND write_packing_list_file;
MODEND ram$change_installation_path;
*DECK DECK=RAM$CHANGE_TERMINAL_ENVIRONMENT EXPAND=TRUE
PROC change_terminal_environment chate (
  configuration_file_access, cfa: key on off = $required
  family_name, fn: name = $required
  user_name, un: name = $required
  status)


    create_variable ignore_status k=status

  WHEN any_fault DO
    display_value osv$status output=$response
  WHENEND


  IF NOT $job(system) THEN
    text = 'CHANGE_TERMINAL_ENVIRONMENT'//$char(31)//'except from the console'
    EXIT_PROC WITH $status(FALSE, 'RA', rae$illegal_command_call, text)
  IFEND


  IF $string($value(configuration_file_access)) = 'ON' THEN
    create_file_permit $system.mainframe.configuration g=user ..
          fn=$value(family_name) u=$value(user_name) am=READ
    create_catalog $system.site_os_maintenance status=ignore_status
    create_catalog $system.site_os_maintenance.deadstart_commands status=ignore_status
    create_catalog_permit $system.site_os_maintenance g=user ..
          fn=$value(family_name) u=$value(user_name) am=(READ SHORTEN APPEND EXECUTE CYCLE)
    create_file_permit $system.software_maintenance.raf$library g=user ..
          fn=$value(family_name) u=$value(user_name) am=(READ EXECUTE)
    create_catalog_permit $system.nosve_maintenance.deadstart_commands g=user ..
          fn=$value(family_name) u=$value(user_name) am=(READ EXECUTE)
  ELSE
    delete_file_permit $system.mainframe.configuration g=user ..
          fn=$value(family_name) u=$value(user_name)
    delete_catalog_permit $system.site_os_maintenance g=user ..
          fn=$value(family_name) u=$value(user_name)
    delete_file_permit $system.software_maintenance.raf$library g=user ..
          fn=$value(family_name) u=$value(user_name)
    delete_catalog_permit $system.nosve_maintenance.deadstart_commands g=user ..
          fn=$value(family_name) u=$value(user_name)
  IFEND


PROCEND change_terminal_environment

*DECK DECK=RAM$CHECKSUM_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$CHECKSUM_FILE Interface.' ??
MODULE ram$checksum_file;

{ PURPOSE:
{   This module contains the interface to checksum a file.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{   The file is opened, checksummed, and closed.  The checksum is returned
{   to the caller.
{
{ NOTES:
{
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
?? POP ??
*copyc amp$get_segment_pointer
*copyc fsp$close_file
*copyc ocp$checksum
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc rap$open_file
?? OLDTITLE, NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
?? OLDTITLE, NEWTITLE := '[XDCL] rap$checksum_file', EJECT ??

{ PURPOSE:
{   This procedure returns a checksum for the specified file.
{
{ DESIGN:
{   The file is opened, checksummed, and closed.  The checksum is returned
{   to the caller.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$checksum_file
    (    file: fst$file_reference;
     VAR checksum: integer;
     VAR status: ost$status);

    VAR
      file_contents_p: ^SEQ ( * ),
      file_fid: amt$file_identifier,
      file_open: boolean,
      file_segment_pointer: amt$segment_pointer,
      local_status: ost$status;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the block
{   structure.
{
{ DESIGN:
{   If the file has been opened, it will be closed before the the procedure
{   returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF file_open THEN
        fsp$close_file (file_fid, ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;

    file_open := FALSE;
    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      rap$open_file (^file, amc$segment, fsc$read, FALSE, NIL, file_fid, file_open, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (file_fid, amc$sequence_pointer, file_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      file_contents_p := file_segment_pointer.sequence_pointer;

      RESET file_contents_p;

      checksum := ocp$checksum( file_contents_p );

    END /main/;

    IF file_open THEN
      fsp$close_file (file_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$checksum_file;
MODEND ram$checksum_file;
*DECK DECK=RAM$CHECKSUM_FILE_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: CHECKSUM_FILE Subcommand.' ??
MODULE ram$checksum_file_command;

{ PURPOSE:
{   This module contains the command interface that checksums a file.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
?? POP ??
*copyc clp$convert_integer_to_string
*copyc clp$change_variable
*copyc clp$evaluate_parameters
*copyc clp$include_line
*copyc rap$checksum_file
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$checksum_file_command', EJECT ??

{ PURPOSE:
{   This command interface returns the checksum for the specified file.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$checksum_file_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE chef_pdt (
{   file, f: file = $required
{   checksum, c: (var) integer = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 5, 23, 20, 19, 210], clc$command, 5, 3, 1, 0, 0, 1, 3, 'CHEF_PDT'],
            [['C                              ', clc$abbreviation_entry, 2],
            ['CHECKSUM                       ', clc$nominal_entry, 2],
            ['F                              ', clc$abbreviation_entry, 1],
            ['FILE                           ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 3]], [
{ PARAMETER 1
      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],
{ PARAMETER 3
      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$file_type]],
{ PARAMETER 2
      [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
{ PARAMETER 3
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$file = 1,
      p$checksum = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      checksum: integer,
      checksum_str: ost$string,
      line: string (osc$max_string_size),
      length: integer,
      value: ^clt$data_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$checksum_file (pvt [p$file].value^.file_value^, checksum, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$checksum].specified THEN

      { Write SCL checksum variable.

      PUSH value;

      value^.kind := clc$integer;
      value^.integer_value.value := checksum;
      value^.integer_value.radix := 10;
      value^.integer_value.radix_specified := FALSE;

      clp$change_variable (pvt [p$checksum].variable^, value, status);

    ELSE { not specified }

      { Display checksum value.

      clp$convert_integer_to_string (checksum, 10, FALSE, checksum_str, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (line, length, '$system.put_line ''   Checksum: ', checksum_str.value (1, checksum_str.size),
         ', File: ', pvt [p$file].value^.file_value^, ''' o=$response');

      clp$include_line (line (1, length), TRUE, osc$null_name, status);

    IFEND;

  PROCEND rap$checksum_file_command;
MODEND ram$checksum_file_command;
*DECK DECK=RAM$CHOOSE_ICA_TYPE EXPAND=TRUE
PROCEDURE choose_ica_type (
  ica_type: (VAR) string = $optional
  )

" This procedure prompts the user for the type of ICA to define
" as part of the network configuration. The user may choose to
" define an OSI mode ICA-II under option #1, or may choose option
" #2 to define an ICA-I or a native mode ICA-II.

"$ format = off
  VAR
    choice: string
  VAREND

"$ format = on


main_loop: ..
  LOOP

"$ format = off
    put_line (..
        '1Choose ICA type'..
        '01. Define Network Connection (ICA-II running in OSI mode)'..
        ' 2. Define Network Access (ICA-I or ICA-II running in native mode)'..
        '0Enter a menu selection, QUIT, ?: ')
"$ format = on

    choice = ' '
    accept_line choice input p=''

    IF choice = '1' THEN
      ica_type = 'DEFINE_NETWORK_CONNECTION'
      EXIT main_loop
    ELSEIF choice = '2' THEN
      ica_type = 'DEFINE_NETWORK_ACCESS'
      EXIT main_loop
    ELSEIF ($translate(lower_to_upper, choice) = 'QUIT') OR ($translate(lower_to_upper, choice) = 'QUI') THEN
      ica_type = ' '
      EXIT main_loop
    ELSEIF choice = '?' OR ($translate(lower_to_upper, choice) = 'HELP') THEN

"$ format = off
      put_line (..
            '0This menu prompts you to choose the type of ICA on your mainframe ' ..
            ' and in the case of an ICA-II, the mode in which the ICA-II will run. '..
            '01.  Select number 1 if your mainframe is connected to the network '..
            '     via an ICA-II which you want to run in OSI mode. It is recommended '..
            '     that all ICA-II''s be defined to run in OSI mode. Note that '..
            '     an OSI mode ICA-II will also support XNS traffic. '..
            '02.  Select number 2 if your mainframe is connected to the network ' ..
            '     via  an ICA-I, or an ICA-II which you want to run in native '..
            '     mode (i.e., ICA-I emulation mode). '..
            '0Enter QUIT to return to the main menu without choosing a network ' ..
            '   type. '..
            '  ')
"$ format = on

      accept_line choice input p='Press NEXT: '
    IFEND
  LOOPEND main_loop

PROCEND choose_ica_type
*DECK DECK=RAM$CLEAR_INSTALLATION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$CLEAR_INSTALLATION Interface.' ??
MODULE ram$clear_installation;

{ PURPOSE:
{   This module contains the interface and procedures ...
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$clear_installation', EJECT ??

{ PURPOSE:
{   This interface ...
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$clear_installation
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    status.normal := TRUE;

  PROCEND rap$clear_installation;
MODEND ram$clear_installation;
*DECK DECK=RAM$COLTEXT EXPAND=TRUE
.PROC,COLTEXT*I,
LFN "- Local File Name"                = (*F),
PFN "- Permanent File Name"            = (*N=,*F),
UN "- User Name of permanent file"     = (*N=,*F),
L "- Library receiving collected file" = (*N=#FILE,*F),
V "- Verify conversion (YES or NO)"    = (*N=NO,YES,NO),
.
.HELP
 The COLTEXT procedure COLlects a file, converts it to a TEXT record,
 verifies the conversion (optional), and replaces the record to a library.
 Requires CATALOG binaries with GENCAT entry point.

 Parameter   Default   Description
   Name       Value

   lfn                 local file name by which the file is accessed
  [pfn]       lfn      permanent file name of the stored file
  [un]                 user name in which file resides
  [l]                  library file to which record is replaced
  [v]         no       verify the file conversion process

.HELP,LFN
 The LFN parameter selects the name by which the file is accessed.
.HELP,PFN
 The PFN parameter selects the name by which the file is stored.
 The default is the value specified for the LFN parameter.
.HELP,UN
 The UN parameter specifies the User Name location of the file.
 The default value is the User Name in which this procedure executes.
.HELP,L
 The L parameter names a library to which TEXT records are replaced.
 The default value is the file containing this procedure.
.HELP,V
 The V parameter value selects verification of the conversion process
 from a FILE to a TEXT record. YES or NO values can be selected.
 The default value is NO. (Verification requires the EXTRACT binaries.)
.ENDHELP
.IFE,$PFN$.EQ.$$,SETPFN.
  $REVERT,EX.COLTEXT,LFN,LFN,UN,L,V.
.ENDIF,SETPFN.
.IFE,($PFN$.EQ.$L$),ERROR.
  $REVERT. CANNOT COLLECT PFN ONTO ITSELF
.ELSE,ERROR.
  GETFILE,LFN,PFN,UN,READ.
  $IFE,FILE(LFN,.NOT.AS),NOTFOUND.
    $REVERT. FILE PFN NOT FOUND
  $ENDIF,NOTFOUND.
  $NOTE,YYYYCOL,NR.+PFN
  $REWIND,LFN.
  $COPYEI,LFN,YYYYCOL.
  $PACK,YYYYCOL.
  .IFE,$V$.EQ.$YES$,VERIFY.
    CRELIB,YYYYCOL,#L=YYYYLIB.
    EXPTEXT,T=LFN,#L=YYYYLIB,G=YYYYSCR.
    $VERIFY,YYYYSCR,LFN,A,R.
    $UNLOAD,YYYYCOL.
    GETLIB,ALL,#L=YYYYLIB,G=YYYYCOL.
    $PURGE,YYYYLIB/NA.
  .ENDIF,VERIFY.
  REPLIB,YYYYCOL,#L=L.
  $UNLOAD,YYYYLIB,YYYYSCR,YYYYCOL.
.ENDIF,ERROR.
$SKIP,NOERROR.
  $EXIT.
  $UNLOAD,YYYYLIB,YYYYSCR,YYYYCOL.
  $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    $EXIT. COLTEXT *TERMINATED*
  $ENDIF,TERMINATED.
  $REVERT,ABORT. COLLECT LFN --> L FAILED
$ENDIF,NOERROR.
.IFE,FILE(LFN,.NOT.AS),FILEPRM.
  .IFE,$UN$.EQ.$$,NOUSERNAME.
    $PURGE,PFN/NA.
  .ENDIF,NOUSERNAME.
.ENDIF,FILEPRM.
$UNLOAD,LFN.
$REVERT. COLLECTED LFN --> L
/EOR
*DECK DECK=RAM$COMPARE_170_FILES EXPAND=TRUE
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Release Maintenance' ??
MODULE ram$compare_170_files;
*copyc rah$compare_170_files
*copyc clp$get_path_description
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc pmp$exit
*copyc rap$generate_170_modset
?? EJECT ??
?? NEWTITLE := '  [XDCL] rap$compare_170_files' ??

  PROCEDURE [XDCL, #GATE] rap$compare_170_files (plist: clt$parameter_list;
    VAR status: ost$status);

{ PDT com7f (
{     initial_file,if : file = $required
{     updated_file,uf : file = $required
{     replacement_file,rf : file = lgo
{     directive_file,df : file = dir
{     status)

?? PUSH (LISTEXT := ON) ??

    VAR
      com7f: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^com7f_names, ^com7f_params];

    VAR
      com7f_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 9] of
        clt$parameter_name_descriptor := [['INITIAL_FILE', 1], ['IF', 1], [
        'UPDATED_FILE', 2], ['UF', 2], ['REPLACEMENT_FILE', 3], ['RF', 3], [
        'DIRECTIVE_FILE', 4], ['DF', 4], ['STATUS', 5]];

    VAR
      com7f_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of
        clt$parameter_descriptor := [

{ INITIAL_FILE IF }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$file_value]],

{ UPDATED_FILE UF }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$file_value]],

{ REPLACEMENT_FILE RF }
      [[clc$optional_with_default, ^com7f_dv3], 1, 1, 1, 1,
        clc$value_range_not_allowed, [NIL, clc$file_value]],

{ DIRECTIVE_FILE DF }
      [[clc$optional_with_default, ^com7f_dv4], 1, 1, 1, 1,
        clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      com7f_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (3) :=
        'lgo';

    VAR
      com7f_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (3) :=
        'dir';

?? POP ??

    VAR
      rav$status: ost$status,
      temp_value: clt$value,
      temp_file: clt$file,
      temp_reference: clt$file_reference,
      temp_path_container: clt$path_container,
      temp_path: ^pft$path,
      temp_cycle: clt$cycle_selector,
      temp_position: clt$open_position,

      if_lfn: amt$local_file_name,
      if_name: clt$path_name,
      uf_lfn: amt$local_file_name,
      uf_name: clt$path_name,
      rf_lfn: amt$local_file_name,
      df_lfn: amt$local_file_name,
      compare_flag: boolean;

{ scan parameter list for validity }

    clp$scan_parameter_list (plist, com7f, rav$status);
    IF NOT rav$status.normal THEN
      status := rav$status;
      pmp$exit (status);
    IFEND;

{ get initial_file parameter values }

    clp$get_value ('initial_file', 1, 1, clc$low, temp_value, rav$status);
    IF NOT rav$status.normal THEN
      status := rav$status;
      pmp$exit (status);
    IFEND;

    if_lfn := temp_value.file.local_file_name;
    temp_file.local_file_name := temp_value.file.local_file_name;

    clp$get_path_description (temp_file, temp_reference, temp_path_container,
          temp_path, temp_cycle, temp_position, rav$status);
    IF NOT rav$status.normal THEN
      status := rav$status;
      pmp$exit (status);
    IFEND;

    if_name := temp_reference.path_name;

{ get updated_file parameter values }

    clp$get_value ('updated_file', 1, 1, clc$low, temp_value, rav$status);
    IF NOT rav$status.normal THEN
      status := rav$status;
      pmp$exit (status);
    IFEND;

    uf_lfn := temp_value.file.local_file_name;
    temp_file.local_file_name := temp_value.file.local_file_name;


    clp$get_path_description (temp_file, temp_reference, temp_path_container,
          temp_path, temp_cycle, temp_position, rav$status);
    IF NOT rav$status.normal THEN
      status := rav$status;
      pmp$exit (status);
    IFEND;

    uf_name := temp_reference.path_name;

{ get replacement_file parameter value }

    clp$get_value ('replacement_file', 1, 1, clc$low, temp_value, rav$status);
    IF NOT rav$status.normal THEN
      status := rav$status;
      pmp$exit (status);
    IFEND;

    rf_lfn := temp_value.file.local_file_name;

{ get directive_file parameter values }

    clp$get_value ('directive_file', 1, 1, clc$low, temp_value, rav$status);
    IF NOT rav$status.normal THEN
      status := rav$status;
      pmp$exit (status);
    IFEND;

    df_lfn := temp_value.file.local_file_name;

{ comapre the files }

    rap$generate_170_modset (if_lfn, if_name, uf_lfn, uf_name, rf_lfn, df_lfn,
          compare_flag, rav$status);
    IF NOT rav$status.normal THEN
      status := rav$status;
    ELSE
      status.normal := TRUE;
    IFEND;

    pmp$exit (status);

  PROCEND rap$compare_170_files;

MODEND ram$compare_170_files;
*DECK DECK=RAM$COMPARE_LABELED_VOLUMES EXPAND=TRUE
PROCEDURE (ram$comlv) compare_labeled_volumes, comlv (
  volume_one, vo: record
      recorded_vsn: any of
        name 1..6
        string 1..6
      anyend
      external_vsn: any of
        name 1..6
        string 1..6
      anyend = $optional
    recend = $required
  volume_two, vt: record
      recorded_vsn: any of
        name 1..6
        string 1..6
      anyend
      external_vsn: any of
        name 1..6
        string 1..6
      anyend = $optional
    recend = $required
  compare_options, compare_option, co: (BY_NAME) list of key
      all
      (compare_data, cd)
      (compare_labels, cl)
    keyend = compare_data
  ending_sequence_number, esn: (BY_NAME) integer 1..9999 = 9999
  error_limit, el: (BY_NAME) integer 0..4398046511103 = 0
  file_accessibility, fa: (BY_NAME, SECURE) any of
      key
        none
      keyend
      name 1..1
      string 1
    anyend = $optional
  owner_identifier, oi: (BY_NAME, SECURE) any of
      key
        none
      keyend
      name 1..14
      string 1..14
    anyend = $optional
  starting_sequence_number, ssn: (BY_NAME) integer 1..9999 = 1
  volume_accessibility, va: (BY_NAME, SECURE) any of
      key
        none
      keyend
      name 1..1
      string 1
    anyend = $optional
  volume_one_density, vod: (BY_NAME) key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = osd$reqmt_default_density, mt9$1600
  volume_two_density, vtd: (BY_NAME) key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = $optional
  status)

  TYPE
    vol_descriptor = record
    recorded_vsn: any of
    name 1..6
    string 1..6
    anyend
    external_vsn: any of
    name 1..6
    string 1..6
    anyend
    recend
  TYPEND


  VAR
    compare_data: boolean = false
    compare_labels: boolean = false
    ignore_status: status
    first_file: file = $unique($local)
    local_status: status
    parameter_names: list of key mt9$800, mt9$1600, mt9$6250, mt18$38000 keyend=
        (mt9$800, mt9$1600, mt9$6250, mt18$38000)
    parameter_values: list of integer 0..2147483647 = (0 0 0 0)
    second_file: file = $unique($local)
    temp: file = $unique($local)
    vol_one: vol_descriptor
    vol_two: vol_descriptor
  VAREND

  WHEN any_fault exit terminate DO
    delete_file first_file status=ignore_status
    delete_file second_file status=ignore_status
    delete_file temp status=ignore_status
    release_resource mt9$800=all mt9$1600=all mt9$6250=all mt18$38000=all ..
          status=ignore_status
    EXIT compare_labeled_volumes WITH osv$status
  WHENEND

  FOR EACH option IN compare_options DO
    IF option = all THEN
      compare_data = true
      compare_labels = true
    ELSEIF option = compare_data THEN
      compare_data = true
    ELSEIF option = compare_labels THEN
      compare_labels = true
    IFEND
  FOREND

  vol_one.recorded_vsn = volume_one.recorded_vsn
  IF $field(volume_one external_vsn specified) THEN
    vol_one.external_vsn = volume_one.external_vsn
  ELSE
    vol_one.external_vsn = vol_one.recorded_vsn
  IFEND

  vol_two.recorded_vsn = volume_two.recorded_vsn
  IF $field(volume_two external_vsn specified) THEN
    vol_two.external_vsn = volume_two.external_vsn
  ELSE
    vol_two.external_vsn = vol_two.recorded_vsn
  IFEND

  request_magnetic_tape first_file density=volume_one_density ..
        recorded_vsn=vol_one.recorded_vsn external_vsn=vol_one.external_vsn ..
        ring=no

  IF $specified(volume_two_density) THEN
    request_magnetic_tape second_file density=volume_two_density ..
          recorded_vsn=vol_two.recorded_vsn ..
          external_vsn=vol_two.external_vsn ring=no
    local_volume_two_density = volume_two_density
  ELSE
    request_magnetic_tape second_file density=volume_one_density ..
          recorded_vsn=vol_two.recorded_vsn ..
          external_vsn=vol_two.external_vsn ring=no
    local_volume_two_density = volume_one_density
  IFEND

  FOR i = 1 TO $size(parameter_names) DO
    IF volume_one_density = parameter_names(i) THEN
      parameter_values(i) = parameter_values(i) + 1
    IFEND
    IF local_volume_two_density = parameter_names(i) THEN
      parameter_values(i) = parameter_values(i) + 1
    IFEND
  FOREND

  reserve_resource mt9$800=parameter_values(1) mt9$1600=parameter_values(2) ..
        mt9$6250=parameter_values(3) mt18$38000=parameter_values(4)

  change_tape_label_attributes first_file file_set_position=next_file ..
        file_accessibility=file_accessibility ..
        owner_identifier=owner_identifier ..
        volume_accessibility=volume_accessibility rewrite_labels=false
  change_tape_label_attributes second_file file_set_position=next_file ..
        file_accessibility=file_accessibility ..
        owner_identifier=owner_identifier ..
        volume_accessibility=volume_accessibility rewrite_labels=false
  rewrite_labels = false
  FOR i = starting_sequence_number TO ending_sequence_number DO
    compare_file file=first_file with=second_file error_limit=error_limit output=temp ..
          status=local_status
    IF NOT compare_data THEN
      IF (NOT local_status.normal) AND ..
            (local_status.condition = cle$compare_errors_detected) THEN
        local_status.normal: = true
      IFEND
    IFEND
    IF local_status.normal THEN
      IF compare_labels THEN
        first_file_labels = $tape_label_attributes(first_file last_accessed ..
              header_labels trailer_labels)
        second_file_labels = $tape_label_attributes(second_file last_accessed ..
              header_labels trailer_labels)
        IF first_file_labels = second_file_labels THEN
          local_status.normal = true
        ELSE
          local_status = $status(false, 'US', 9999, ' Labels do not compare')
        IFEND
        delete_variable (first_file_labels second_file_labels)
      IFEND
    IFEND
    IF NOT local_status.normal THEN
      IF (i > 1) AND (local_status.condition = ame$file_not_in_volume_set) ..
            THEN
        EXIT_PROC
      ELSE
        EXIT_PROC WITH local_status
      IFEND
    IFEND
  FOREND

PROCEND compare_labeled_volumes
*DECK DECK=RAM$COMPARE_LEGIBLE_FILES EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Tools : Compare Legible Files' ??
MODULE ram$compare_legible_files;

{ PURPOSE:
{   Compares two legible files.  If the files are identical then the program
{   returns a normal status.  If the files are not the same, it generates a
{   list of the old file with inserted and deleted lines shown.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$compare_errors_detected
*copyc cyd$run_time_error_condition
*copyc oce$ve_linker_exceptions
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$get_next
*copyc amp$get_partial
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc fsp$close_file
*copyc fsp$open_file
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pmp$continue_to_cause
*copyc pmp$generate_unique_name
*copyc clv$display_variables
*copyc clp$new_page_procedure
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module.', EJECT ??

  CONST
    product_id = 'RA';

  CONST
    max_line_length = 255,
    max_lines_per_deck = 100000,
    max_line_number = max_lines_per_deck,
    line_length = 200,
    source_id_length = 6 + 1;

  TYPE
    file_line_count = 0 .. max_line_number,
    two_files_line_count = 0 .. max_line_number * 2,
    text_line = string ( * <= max_line_length),

    line_descriptor = record
      link: two_files_line_count,
      where: file_line_count,
      symbol: two_files_line_count,
      trimmed_spaces: 0 .. max_line_length,
      text_p: ^text_line,
    recend;

  CONST
    in_symbol_table = 0;

  VAR
    lines_in_new_file: [STATIC] file_line_count := 0,
    lines_in_old_file: [STATIC] file_line_count := 0,
    line_text_p: ^SEQ ( * ),
    new_lines_p: ^array [0 .. * ] of line_descriptor,
    old_lines_p: ^array [0 .. * ] of line_descriptor;

  VAR
    wild_char: record
      specified: boolean,
      value: char,
    recend;

?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle', EJECT ??

{ PURPOSE:
{   Dummy routine for the display procedures to call when they wish to
{   display a subtitle.

  PROCEDURE put_subtitle
    (VAR display_control: clt$display_control;
     VAR status: ost$status);

  PROCEND put_subtitle;
?? OLDTITLE ??
?? NEWTITLE := 'find_common_unique_source_lines', EJECT ??

{ PURPOSE:
{   Find lines appearing exactly in the old and new files the same number of
{   times and 10 or less times in a file.

  PROCEDURE find_common_unique_source_lines
    (    affected_lines: two_files_line_count;
     VAR old_lines: array [0 .. * ] of line_descriptor;
     VAR new_lines: array [0 .. * ] of line_descriptor);

    VAR
      matching_line_count: -max_line_number .. max_line_number,
      new_index: file_line_count,
      old_index: file_line_count,
      one_percent: file_line_count,
      saved_new_index: file_line_count,
      saved_old_index: file_line_count,
      symbol: two_files_line_count,
      symbol_text_p: ^text_line;


    IF affected_lines = 0 THEN
      RETURN;
    IFEND;

    one_percent := affected_lines DIV 100;
    IF one_percent < 5 THEN
      one_percent := 5;
    IFEND;
    symbol := 2;

    old_index := old_lines [0].link;
    new_index := new_lines [0].link;
    WHILE (old_index <> 0) AND (new_index <> 0) DO
      symbol := symbol + 1;
      IF old_lines [old_index].text_p^ < new_lines [new_index].text_p^ THEN
        old_lines [old_index].where := in_symbol_table;
        old_lines [old_index].symbol := symbol;
        old_index := old_lines [old_index].link;

      ELSEIF new_lines [new_index].text_p^ < old_lines [old_index].text_p^ THEN
        new_lines [new_index].where := in_symbol_table;
        new_lines [new_index].symbol := symbol;
        new_index := new_lines [new_index].link;

      ELSE { One or more lines from both files match
        saved_old_index := old_index;
        saved_new_index := new_index;
        symbol_text_p := old_lines [old_index].text_p;
        matching_line_count := 0;
        REPEAT
          old_lines [old_index].where := in_symbol_table;
          old_lines [old_index].symbol := symbol;
          old_index := old_lines [old_index].link;
          matching_line_count := matching_line_count + 1;
        UNTIL (old_index = 0) OR (old_lines [old_index].text_p^ <>
              symbol_text_p^);

        IF matching_line_count > one_percent THEN
          matching_line_count := 0;
        IFEND;

        REPEAT
          new_lines [new_index].where := in_symbol_table;
          new_lines [new_index].symbol := symbol;
          new_index := new_lines [new_index].link;
          matching_line_count := matching_line_count - 1;
        UNTIL (new_index = 0) OR (new_lines [new_index].text_p^ <>
              symbol_text_p^);

        IF matching_line_count = 0 THEN
          REPEAT
            old_lines [saved_old_index].where := saved_new_index;
            new_lines [saved_new_index].where := saved_old_index;
            saved_old_index := old_lines [saved_old_index].link;
            saved_new_index := new_lines [saved_new_index].link;
          UNTIL saved_old_index = old_index;
        IFEND;

      IFEND;
    WHILEND;

    symbol := symbol + 1;
    WHILE old_index <> 0 DO
      old_lines [old_index].where := in_symbol_table;
      old_lines [old_index].symbol := symbol;
      old_index := old_lines [old_index].link;
    WHILEND;

    WHILE new_index <> 0 DO
      new_lines [new_index].where := in_symbol_table;
      new_lines [new_index].symbol := symbol;
      new_index := new_lines [new_index].link;
    WHILEND;

  PROCEND find_common_unique_source_lines;
?? OLDTITLE ??
?? NEWTITLE := 'isolate_area_of_difference', EJECT ??

{ PURPOSE:
{   This procedure determines what portion of the file is different (if any).
{   This is done looking for the first mismatch scaning both forward and
{   backwards.  The wild char (if specified) is taken into account when doing
{   the match.  The wild char will match any character in that position.

  PROCEDURE isolate_area_of_difference
    (    lines_in_old_file: file_line_count;
         lines_in_new_file: file_line_count;
     VAR old_lines: array [0 .. * ] of line_descriptor;
     VAR new_lines: array [0 .. * ] of line_descriptor;
     VAR matching_lines_in_front: file_line_count;
     VAR matching_lines_at_end: file_line_count;
     VAR files_are_different: boolean);

?? NEWTITLE := '[INLINE] lines_match', EJECT ??

{ PURPOSE:
{   Check two lines for equality taking into account any wild characters.

    FUNCTION [INLINE] lines_match
      (    old_text_p: ^text_line;
           new_text_p: ^text_line): boolean;

      IF old_text_p^ = new_text_p^ THEN
        lines_match := TRUE;
      ELSEIF wild_char.specified AND match_with_wild_char
            (old_text_p, new_text_p) THEN
        lines_match := TRUE;
      ELSE
        lines_match := FALSE;
      IFEND;

    FUNCEND lines_match;
?? OLDTITLE, EJECT ??

    VAR
      line_index: file_line_count,
      smallest_line_count: file_line_count;

    IF lines_in_new_file < lines_in_old_file THEN
      smallest_line_count := lines_in_new_file;
      files_are_different := TRUE;
    ELSE
      smallest_line_count := lines_in_old_file;
      files_are_different := (lines_in_new_file > lines_in_old_file);
    IFEND;
    matching_lines_in_front := smallest_line_count;
    matching_lines_at_end := smallest_line_count;

  /find_first_mismatch/
    FOR line_index := 1 TO smallest_line_count DO
      IF NOT lines_match (old_lines [line_index].
            text_p, new_lines [line_index].text_p) THEN
        matching_lines_in_front := line_index - 1;
        files_are_different := TRUE;
        EXIT /find_first_mismatch/;
      IFEND;
      old_lines [line_index].where := line_index;
      old_lines [line_index].symbol := 0;
      new_lines [line_index].where := line_index;
      new_lines [line_index].symbol := 0;
    FOREND /find_first_mismatch/;

    IF NOT files_are_different THEN
      RETURN;
    IFEND;

    matching_lines_at_end := smallest_line_count - matching_lines_in_front;
    FOR line_index := 0 TO matching_lines_at_end - 1 DO
      IF NOT lines_match (old_lines [lines_in_old_file - line_index].text_p,
            new_lines [lines_in_new_file - line_index].text_p) THEN
        matching_lines_at_end := line_index;
        RETURN;
      IFEND;
      old_lines [lines_in_old_file - line_index].where :=
            lines_in_new_file - line_index;
      old_lines [lines_in_old_file - line_index].symbol := 0;
      new_lines [lines_in_new_file - line_index].where :=
            lines_in_old_file - line_index;
      new_lines [lines_in_new_file - line_index].symbol := 0;
    FOREND;
  PROCEND isolate_area_of_difference;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] is_same_symbol', EJECT ??

{ PURPOSE:
{   Check if two lines refer to the same symbol taking into account the wild
{   character if any.

  FUNCTION [INLINE] is_same_symbol
    (    old_line: line_descriptor;
         new_line: line_descriptor): boolean;

    IF new_line.symbol = old_line.symbol THEN
      is_same_symbol := TRUE;
    ELSEIF wild_char.specified AND match_with_wild_char
          (old_line.text_p, new_line.text_p) THEN
      is_same_symbol := TRUE;
    ELSE
      is_same_symbol := FALSE;
    IFEND;
  FUNCEND is_same_symbol;
?? NEWTITLE := 'match_with_wild_char', EJECT ??

{ PURPOSE:
{   Check two lines for equality taking into account any wild characters.

  FUNCTION match_with_wild_char
    (    old_text_p: ^text_line;
         new_text_p: ^text_line): boolean;

    VAR
      smallest_line: 1 .. line_length,
      char_index: 1 .. line_length;

    match_with_wild_char := FALSE;

    smallest_line := STRLENGTH (new_text_p^);
    IF smallest_line > STRLENGTH (old_text_p^) THEN
      smallest_line := STRLENGTH (old_text_p^);
    IFEND;

    FOR char_index := 1 TO smallest_line DO
      IF (old_text_p^ (char_index) <> new_text_p^ (char_index)) AND
            (old_text_p^ (char_index) <> wild_char.value) THEN
        RETURN;
      IFEND;
    FOREND;

    IF smallest_line < STRLENGTH (new_text_p^) THEN
      IF new_text_p^ (smallest_line + 1, * ) <> ' ' THEN
        RETURN;
      IFEND;
    IFEND;

    FOR char_index := smallest_line + 1 TO STRLENGTH (old_text_p^) DO
      IF (old_text_p^ (char_index) <> ' ') AND
            (old_text_p^ (char_index) <> wild_char.value) THEN
        RETURN;
      IFEND;
    FOREND;
    match_with_wild_char := TRUE;

  FUNCEND match_with_wild_char;
?? OLDTITLE ??
?? NEWTITLE := 'produce_comparison_file', EJECT ??

{ PURPOSE:
{   This procedure displays the differences between the two files to a list
{   file.  The output consists of lines from the old file surrounding the
{   changed lines with the deleted lines marked by a 'D' in column 1 of the
{   listing and the inserted lines marked by a 'I' in column 1 of the listing.
{
{   The number of lines displayed surrounding the changed lines is controlled
{   by the bracket size parameter.  If there is a gap in the lines displayed
{   from the old file, the message 'Starting at line nn of old file' is put
{   on the list file.

  PROCEDURE produce_comparison_file
    (    comparison_file_name: fst$file_reference;
         bracket_size: file_line_count;
         first_line: file_line_count;
         last_old_line: file_line_count;
         last_new_line: file_line_count;
     VAR status: ost$status);

    TYPE
      file_line_index = 0 .. max_line_number + 1;

    VAR
      bracket_index: file_line_index,
      bracket_lines_remaining: file_line_index,
      browse_index: file_line_index,
      first_delete_line: file_line_index,
      first_insert_line: file_line_index,
      new_file_index: file_line_index,
      new_where: file_line_index,
      old_file_index: file_line_index,
      old_where: file_line_index;

    VAR
      display_control: clt$display_control,
      output_open: boolean;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up by closing the display file in the event that
{   the display procedure is aborted.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      handler_status.normal := TRUE;
      IF condition.selector = pmc$block_exit_processing THEN
        clp$close_display (display_control, ignore_status);
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE ??
?? NEWTITLE := 'put_line', EJECT ??

{ PURPOSE:
{   Writes the specified line to the listing file with a two character id.
{   This id should be '  ' for an unchanged line from the old file, 'D ' for
{   a deleted line from the old file, or 'I ' for an inserted line from the
{   new file.

    PROCEDURE put_line
      (    line: line_descriptor;
           id: string (2));

      VAR
        hold_line: string (max_line_length),
        hold_line_length: 0 .. max_line_length;

      hold_line := id;
      hold_line (line.trimmed_spaces + 2, * ) := line.text_p^;
      hold_line_length := line.trimmed_spaces + STRLENGTH (line.text_p^) + 2 -
            1;
      clp$put_display (display_control, hold_line (1, hold_line_length),
            clc$no_trim, status);
      IF NOT status.normal THEN
        EXIT produce_comparison_file;
      IFEND;
    PROCEND put_line;
?? OLDTITLE ??
?? NEWTITLE := 'Show_Bracket', EJECT ??

{ PURPOSE:
{   This procedure displays the lines needed for the display bracket.  It
{   displays a message specifying that lines were skipped if necessary and
{   then displays the desired lines in front of the changed portion of the
{   old file.

    PROCEDURE show_bracket;

      VAR
        header_line: string (40),
        i: integer;

      IF (bracket_index + bracket_size + bracket_lines_remaining) <
            first_delete_line THEN

        FOR bracket_index := bracket_index TO bracket_index +
              bracket_lines_remaining - 1 DO
          put_line (old_lines_p^ [bracket_index], '  ');
        FOREND;
        bracket_index := first_delete_line - bracket_size;
        STRINGREP (header_line, i, 'Starting at line', bracket_index,
              ' of old file.');
        clp$put_display (display_control, header_line (1, i), clc$no_trim,
              status);
        IF NOT status.normal THEN
          EXIT produce_comparison_file;
        IFEND;
      IFEND;

      FOR bracket_index := bracket_index TO first_delete_line - 1 DO
        put_line (old_lines_p^ [bracket_index], '  ');
      FOREND;
      bracket_lines_remaining := bracket_size;

    PROCEND show_bracket;
?? OLDTITLE, EJECT ??

    VAR
      ring_attributes: amt$ring_attributes;

    status.normal := TRUE;

    clv$command_name := 'Compare_Legible_Files';
    clv$titles_built := FALSE;

    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    clp$open_display_reference (comparison_file_name, ^clp$new_page_procedure,
          fsc$list, ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

    old_file_index := first_line;
    new_file_index := first_line;
    bracket_index := 1;
    bracket_lines_remaining := 0;

    WHILE (old_file_index <= last_old_line) AND
          (new_file_index <= last_new_line) DO
      old_file_index := old_file_index + 1;
      new_file_index := new_file_index + 1;
      old_where := old_lines_p^ [old_file_index].where;
      new_where := new_lines_p^ [new_file_index].where;

      IF old_where <> new_file_index THEN
        first_insert_line := new_file_index;
        first_delete_line := old_file_index;

        WHILE old_where < new_file_index DO
          old_file_index := old_file_index + 1;
          old_where := old_lines_p^ [old_file_index].where;
        WHILEND;

        WHILE new_where < old_file_index DO
          new_file_index := new_file_index + 1;
          new_where := new_lines_p^ [new_file_index].where;
        WHILEND;

        IF old_where <> new_file_index THEN
          IF (old_where - new_file_index) < (new_where - old_file_index) THEN
            new_file_index := old_where;
          ELSE
            old_file_index := new_where;
          IFEND;
        IFEND;

        WHILE (first_delete_line < old_file_index) AND
              (first_insert_line < new_file_index) AND
              is_same_symbol (old_lines_p^ [first_delete_line],
              new_lines_p^ [first_insert_line]) DO
          first_delete_line := first_delete_line + 1;
          first_insert_line := first_insert_line + 1;
        WHILEND;

        IF (first_delete_line < old_file_index) OR
              (first_insert_line < new_file_index) THEN
          show_bracket;
          FOR first_delete_line := first_delete_line TO old_file_index - 1 DO
            put_line (old_lines_p^ [first_delete_line], 'D ');
          FOREND;

          FOR first_insert_line := first_insert_line TO new_file_index - 1 DO
            put_line (new_lines_p^ [first_insert_line], 'I ');
          FOREND;
          bracket_index := old_file_index;
        IFEND;
      IFEND;

    WHILEND;

    WHILE (bracket_lines_remaining > 0) AND
          (old_file_index < lines_in_old_file) DO
      put_line (old_lines_p^ [old_file_index], '  ');
      bracket_lines_remaining := bracket_lines_remaining - 1;
      old_file_index := old_file_index + 1;
    WHILEND;

    osp$disestablish_cond_handler;

    clp$close_display (display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND produce_comparison_file;
?? OLDTITLE ??
?? NEWTITLE := 'propogate_commonality', EJECT ??

{ PURPOSE:
{   Scan backward from lines believed to match checking for additional matching
{   lines.

  PROCEDURE propogate_commonality
    (    first_line: file_line_count;
         last_line: file_line_count;
     VAR old_lines: array [0 .. * ] of line_descriptor;
     VAR new_lines: array [0 .. * ] of line_descriptor);

    VAR
      new_index: file_line_count,
      old_index: file_line_count,
      previous_matched: boolean;

{   Scan backward from each matching line looking for further consecutive
{   matching lines and recording them as such.

    FOR new_index := last_line + 1 DOWNTO first_line DO
      IF new_lines [new_index].where > in_symbol_table THEN
        previous_matched := TRUE;
        old_index := new_lines [new_index].where - 1;
      ELSEIF previous_matched AND (old_lines [old_index].where =
            in_symbol_table) AND is_same_symbol
            (old_lines [old_index], new_lines [new_index]) THEN
        new_lines [new_index].where := old_index;
        old_lines [old_index].where := new_index;
        old_index := old_index - 1;
      ELSE
        previous_matched := FALSE;
      IFEND;
    FOREND;

  PROCEND propogate_commonality;
?? OLDTITLE ??
?? NEWTITLE := 'read_source_files', EJECT ??

{ PURPOSE:
{   This routine reads a file into the line descriptor array.  Leading spaces
{   may be optionally skipped.  Any line identifiers are skipped and only the
{   actual text of the line is kept for comparison purposes.

  PROCEDURE read_source_files
    (    source_file_name: fst$file_reference;
         ignore_leading_spaces: boolean;
     VAR descriptor_seq: ^SEQ ( * );
     VAR lines: ^array [0 .. * ] of line_descriptor;
     VAR line_count: file_line_count;
     VAR status: ost$status);

    CONST
      max_line_size = max_line_length + amc$max_statement_id_length;

    VAR
      access_selections: [STATIC, READ] array [1 .. 1] of
            fst$attachment_option := [[fsc$access_and_share_modes,
            [fsc$specific_access_modes, [fsc$read]],
            [fsc$specific_share_modes, [fsc$read, fsc$execute]]]],
      descriptors_in_segment: integer,
      file_exists: boolean,
      file_previously_opened: boolean,
      contains_data: boolean,
      file_attributes: ^array [1 .. 1] of amt$get_item,
      file_position: amt$file_position,
      first_char_index: 1 .. max_line_length,
      ignored_byte_address: amt$file_byte_address,
      identifier_position: (no_identifier, before, after),
      line: ^SEQ ( * ),
      line_identifier: ^string ( * <= amc$max_statement_id_length),
      line_text: ^text_line,
      line_desc: line_descriptor,
      line_length: amt$transfer_count,
      lines_p: ^array [0 .. * ] of line_descriptor,
      minimum_line_size: amt$max_record_length,
      record_length: amt$max_record_length,
      source_file_id: amt$file_identifier;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up by closing the source file in the event that
{   the procedure aborts with the source file open.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF condition.selector = pmc$block_exit_processing THEN
        fsp$close_file (source_file_id, ignore_status);
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE ??

    VAR
      validation_attributes: array [1 .. 5] of fst$file_cycle_attribute;

    status.normal := TRUE;
    descriptors_in_segment := (#SIZE (descriptor_seq^) DIV
          #SIZE (line_descriptor)) DIV 2;
    NEXT lines_p: [0 .. descriptors_in_segment] IN descriptor_seq;
    IF lines_p = NIL THEN
      osp$set_status_abnormal (product_id, oce$e_storage_allocation_failed,
            'lines_p', status);
      RETURN;
    IFEND;

{ Read source file and product line descriptors

    PUSH file_attributes;
    file_attributes^ [1].key := amc$statement_identifier;
    amp$get_file_attributes (source_file_name, file_attributes^, file_exists,
          file_previously_opened, contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH line: [[REP max_line_size OF char]];
    RESET line;
    IF file_attributes^ [1].source <> amc$undefined_attribute THEN
      IF file_attributes^ [1].statement_identifier.location = 1 THEN
        identifier_position := before;
        minimum_line_size := file_attributes^ [1].statement_identifier.length;
        NEXT line_identifier: [minimum_line_size] IN line;
        NEXT line_text: [max_line_length] IN line;
      ELSE
        identifier_position := after;
        NEXT line_text: [file_attributes^ [1].statement_identifier.location -
              1] IN line;
        NEXT line_identifier: [file_attributes^ [1].statement_identifier.
              length] IN line;
        minimum_line_size := STRLENGTH (line_text^) +
              STRLENGTH (line_identifier^);
      IFEND;
    ELSE
      identifier_position := no_identifier;
      NEXT line_text: [max_line_length] IN line;
    IFEND;

    validation_attributes [1].selector := fsc$record_type;
    validation_attributes [1].record_type := amc$variable;
    validation_attributes [2].selector := fsc$record_type;
    validation_attributes [2].record_type := amc$ansi_fixed;
    validation_attributes [3].selector := fsc$record_type;
    validation_attributes [3].record_type := amc$ansi_spanned;
    validation_attributes [4].selector := fsc$record_type;
    validation_attributes [4].record_type := amc$ansi_variable;
    validation_attributes [5].selector := fsc$record_type;
    validation_attributes [5].record_type := amc$trailing_char_delimited;

    fsp$open_file (source_file_name, amc$record, ^access_selections,
          {default_creation_attributes=} NIL,
          {mandated_creation_attributes=} NIL, ^validation_attributes,
          {attribute_override=} NIL, source_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

    line_count := 0;
    amp$get_next (source_file_id, line, max_line_size, line_length,
          ignored_byte_address, file_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    WHILE (file_position = amc$eor) DO

{ Isolate text from line to be compared.

      IF identifier_position > no_identifier THEN
        IF identifier_position = before THEN
          IF line_length < minimum_line_size THEN
            line_length := 0;
          ELSE
            line_length := line_length - minimum_line_size;
          IFEND;
        ELSEIF line_length > STRLENGTH (line_text^) THEN
          line_length := STRLENGTH (line_text^);
        IFEND;
      ELSEIF line_length > max_line_length THEN
        line_length := max_line_length;
      IFEND;

      IF line_length <= 0 THEN
        line_length := 1;
        line_text^ (1) := ' ';
      IFEND;

      WHILE (line_length > 1) AND (line_text^ (line_length) = ' ') DO
        line_length := line_length - 1;
      WHILEND;
      first_char_index := 1;
      IF ignore_leading_spaces THEN
        WHILE (first_char_index < line_length) AND
              (line_text^ (first_char_index) = ' ') DO
          first_char_index := first_char_index + 1;
        WHILEND;
      IFEND;

{ Build line descriptor

      line_desc.trimmed_spaces := first_char_index;
      NEXT line_desc.text_p: [line_length - first_char_index + 1] IN
            line_text_p;
      IF line_desc.text_p = NIL THEN
        osp$set_status_abnormal (product_id, oce$e_storage_allocation_failed,
              'space for SOURCE file text', status);
        RETURN;
      IFEND;
      line_desc.text_p^ := line_text^ (first_char_index,
            line_length - first_char_index + 1);
      line_count := line_count + 1;
      IF line_count > descriptors_in_segment THEN
        osp$set_status_abnormal (product_id, oce$e_storage_allocation_failed,
              'space to process SOURCE file', status);
        RETURN;
      IFEND;
      lines_p^ [line_count] := line_desc;

      amp$get_next (source_file_id, line, max_line_size, line_length,
            ignored_byte_address, file_position, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    WHILEND;

    osp$disestablish_cond_handler;

    fsp$close_file (source_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET descriptor_seq TO lines_p;
    NEXT lines: [0 .. line_count + 1] IN descriptor_seq;

  PROCEND read_source_files;
?? OLDTITLE ??
?? NEWTITLE := 'merge_sort', EJECT ??

{ PURPOSE:
{   This routine sorts the line descriptor array using a merge sort.  A merge
{   sort is used because it is reasonably fast, performs no worse than a
{   guarenteed O(N*Ln(N)), and is stable.  Stability is important since
{   identical lines from the old and new files must remain in the order they
{   were found in the old and new files.
{
{ NOTES:
{   This algorithm uses Ln(N) space to keep indicies to previously sorted
{   lists.  A tradeoff could be made for this space by changing the routine
{   to make Ln(N) passes across the array and building the sublists in the
{   same way the lists are built in the first part of this routine.

  PROCEDURE merge_sort
    (    first_line: file_line_count;
         last_line: file_line_count;
     VAR lines: array [0 .. * ] of line_descriptor);

    VAR
      d: file_line_count,
      index: file_line_count,
      lista: file_line_count,
      listb: file_line_count,
      listr: file_line_count,
      pass_count: file_line_count,
      stack: ^array [1 .. * ] of file_line_count,
      stack_index: file_line_count;

    IF first_line > last_line THEN
      RETURN;
    IFEND;

    index := 1;
    stack_index := 1;
    WHILE index < (last_line - first_line) DO
      index := index * 2;
      stack_index := stack_index + 1;
    WHILEND;
    PUSH stack: [1 .. stack_index];

    stack_index := 0;
    pass_count := 0;
    lines [0].link := first_line;
    index := first_line;

  /scan_list/
    WHILE index <= last_line DO

      listr := 0;
      REPEAT
        lines [listr].link := index;
        listr := index;
        index := index + 1;
        IF index > last_line THEN
          lines [listr].link := 0;
          EXIT /scan_list/;
        IFEND;
      UNTIL lines [index].text_p^ < lines [listr].text_p^;
      lines [listr].link := 0;

      pass_count := pass_count + 1;
      d := pass_count;
      WHILE (d MOD 2) = 0 DO
        lista := stack^ [stack_index];
        stack_index := stack_index - 1;
        listb := lines [0].link;
        listr := 0;
        WHILE (listb > 0) AND (lista > 0) DO
          IF lines [listb].text_p^ < lines [lista].text_p^ THEN
            lines [listr].link := listb;
            listr := listb;
            listb := lines [listb].link;
          ELSE
            lines [listr].link := lista;
            listr := lista;
            lista := lines [lista].link;
          IFEND;
        WHILEND;

        IF listb > 0 THEN
          lines [listr].link := listb;
        ELSE
          lines [listr].link := lista;
        IFEND;
        d := d DIV 2;
      WHILEND;

      stack_index := stack_index + 1;
      stack^ [stack_index] := lines [0].link;

    WHILEND /scan_list/;

    WHILE stack_index > 0 DO
      lista := stack^ [stack_index];
      stack_index := stack_index - 1;
      listb := lines [0].link;
      listr := 0;
      WHILE (listb > 0) AND (lista > 0) DO
        IF lines [listb].text_p^ < lines [lista].text_p^ THEN
          lines [listr].link := listb;
          listr := listb;
          listb := lines [listb].link;
        ELSE
          lines [listr].link := lista;
          listr := lista;
          lista := lines [lista].link;
        IFEND;
      WHILEND;

      IF listb > 0 THEN
        lines [listr].link := listb;
      ELSE
        lines [listr].link := lista;
      IFEND;
    WHILEND;

  PROCEND merge_sort;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$_compare_legible_files', EJECT ??

  PROCEDURE [XDCL] rap$_compare_legible_files
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (OSM$COMLF) compare_legible_files, comlf (
{   old_source, os: file = $required
{   new_source, ns: file = $required
{   list, l: file = output
{   bracket_size, bs: any of
{       key infinite keyend
{       integer 1..max_line_number
{     anyend = 10
{   leading_spaces_significant, lss: boolean = TRUE
{   wild_character, wild_char, wc: string 1..1 = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 14] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (6),
      recend,
      type4: 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$integer_type_qualifier,
        recend,
        default_value: string (2),
      recend,
      type5: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 17, 10, 51, 26, 184],
    clc$command, 14, 7, 2, 0, 0, 0, 7, 'OSM$COMLF'], [
    ['BRACKET_SIZE                   ',clc$nominal_entry, 4],
    ['BS                             ',clc$abbreviation_entry, 4],
    ['L                              ',clc$abbreviation_entry, 3],
    ['LEADING_SPACES_SIGNIFICANT     ',clc$nominal_entry, 5],
    ['LIST                           ',clc$nominal_entry, 3],
    ['LSS                            ',clc$abbreviation_entry, 5],
    ['NEW_SOURCE                     ',clc$nominal_entry, 2],
    ['NS                             ',clc$abbreviation_entry, 2],
    ['OLD_SOURCE                     ',clc$nominal_entry, 1],
    ['OS                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 7],
    ['WC                             ',clc$abbreviation_entry, 6],
    ['WILD_CHAR                      ',clc$alias_entry, 6],
    ['WILD_CHARACTER                 ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 6],
{ PARAMETER 4
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 84, clc$optional_default_parameter, 0, 2],
{ PARAMETER 5
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 4],
{ PARAMETER 6
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    'output'],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$integer_type,
    clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['INFINITE                       ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    20, [[1, 0, clc$integer_type], [1, max_line_number, 10]]
    ,
    '10'],
{ PARAMETER 5
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 6
    [[1, 0, clc$string_type], [1, 1, FALSE]],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$old_source = 1,
      p$new_source = 2,
      p$list = 3,
      p$bracket_size = 4,
      p$leading_spaces_significant = 5,
      p$wild_character = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

    VAR
      bracket_size: file_line_count,
      descriptor_segment_pointer: amt$segment_pointer,
      files_are_different: boolean,
      i: integer,
      j: integer,
      ignore_leading_spaces: boolean,
      line_text_segment_pointer: amt$segment_pointer,
      local_status: ost$status,
      matching_lines_at_end: file_line_count,
      matching_lines_in_front: file_line_count;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ignore_leading_spaces := NOT pvt [p$leading_spaces_significant].value^.
          boolean_value.value;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random,
          descriptor_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET descriptor_segment_pointer.sequence_pointer;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random,
          line_text_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    line_text_p := line_text_segment_pointer.sequence_pointer;
    RESET line_text_p;

  /main/
    BEGIN

      read_source_files (pvt [p$old_source].value^.file_value^,
            ignore_leading_spaces, descriptor_segment_pointer.sequence_pointer,
            old_lines_p, lines_in_old_file, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      read_source_files (pvt [p$new_source].value^.file_value^,
            ignore_leading_spaces, descriptor_segment_pointer.sequence_pointer,
            new_lines_p, lines_in_new_file, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      wild_char.specified := pvt [p$wild_character].specified;
      IF wild_char.specified THEN
        wild_char.value := pvt [p$wild_character].value^.string_value^ (1);
      IFEND;

{ Initialize line tables.

      new_lines_p^ [0].where := 0;
      new_lines_p^ [0].symbol := 1;
      new_lines_p^ [lines_in_new_file + 1].where := lines_in_old_file + 1;
      new_lines_p^ [lines_in_new_file + 1].symbol := 2;
      old_lines_p^ [0].where := 0;
      old_lines_p^ [0].symbol := 1;
      old_lines_p^ [lines_in_old_file + 1].where := lines_in_new_file + 1;
      old_lines_p^ [lines_in_old_file + 1].symbol := 2;

      isolate_area_of_difference (lines_in_old_file, lines_in_new_file,
            old_lines_p^, new_lines_p^, matching_lines_in_front,
            matching_lines_at_end, files_are_different);
      IF NOT files_are_different THEN
        EXIT /main/;
      IFEND;

      merge_sort (matching_lines_in_front + 1,
            lines_in_new_file - matching_lines_at_end, new_lines_p^);
      merge_sort (matching_lines_in_front + 1,
            lines_in_old_file - matching_lines_at_end, old_lines_p^);

{ PASS 3 OF ALGORITHM

      find_common_unique_source_lines (lines_in_old_file + lines_in_new_file -
            2 * matching_lines_in_front - 2 * matching_lines_at_end,
            old_lines_p^, new_lines_p^);

{ PASS 4 OF ALGORITHM

      propogate_commonality (matching_lines_in_front + 1,
            lines_in_new_file - matching_lines_at_end, old_lines_p^,
            new_lines_p^);

{ PASS 6 OF ALGORITHM

      IF pvt [p$bracket_size].value^.kind = clc$keyword THEN
        bracket_size := max_line_number;
      ELSE
        bracket_size := pvt [p$bracket_size].value^.integer_value.value;
      IFEND;
      produce_comparison_file (pvt [p$list].value^.file_value^, bracket_size,
            matching_lines_in_front, lines_in_old_file - matching_lines_at_end,
            lines_in_new_file - matching_lines_at_end, status);

      osp$set_status_abnormal (product_id, cle$compare_errors_detected,
            'Files had', status);

    END /main/;

    local_status.normal := TRUE;
    mmp$delete_scratch_segment (descriptor_segment_pointer, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
      local_status.normal := TRUE;
    IFEND;

    mmp$delete_scratch_segment (line_text_segment_pointer, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
      local_status.normal := TRUE;
    IFEND;

  PROCEND rap$_compare_legible_files;
?? OLDTITLE ??
MODEND ram$compare_legible_files;
*DECK DECK=RAM$COMPARE_LEGIBLE_FILES_PD EXPAND=TRUE

  create_program_description (compare_legible_files comlf) ..
     sp=rap$_compare_legible_files l=osf$current_library dm=no lm=$null ..
     lmo=none
*DECK DECK=RAM$COMPARE_OBJECT_LIBRARY EXPAND=TRUE
create_program_description name=(compare_object_library, comol) sp=ocp$compare_object_library ..
      l=('$system.ocu.bound_product' osf$task_services_library) tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$COMPARE_SL_DECKS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE ram$compare_sl_decks;
?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc clt$path_name
*copyc rat$write_scl_commands
*copyc rat$corrector_size
*copyc amp$close
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$put_next
*copyc amp$return
*copyc pmp$get_unique_name
*copyc clp$scan_command_line
*copyc clp$create_variable
*copyc clp$read_variable
*copyc clp$delete_variable
*copyc rap$get_decks
?? POP ??

*copyc rah$compare_sl_decks

  PROCEDURE [XDCL] rap$compare_sl_decks (name: ost$name;
        old_path: clt$path_name;
        old_path_length: 1 .. clc$max_path_name_size;
        new_path: clt$path_name;
        new_path_length: 1 .. clc$max_path_name_size;
    VAR decks_match: boolean;
    VAR status: ost$status);

    CONST
      number_of_commands = 77;

    VAR
      access_selections: amt$file_access_selections,
      ba: amt$file_byte_address,
      command: array [1 .. number_of_commands] of rat$write_scl_commands,
      command_fid: amt$file_identifier,
      command_file: ost$name,
      dhd_scl_var_name: string (31),
      i: 0 .. number_of_commands + 1,
      ignore_status: ost$status,
      j: rat$corrector_size,
      new_array: ^array [1 .. * ] of 0 .. 0ff(16),
      new_deck: ost$name,
      new_fid: amt$file_identifier,
      new_size: integer,
      new_source_deck: amt$segment_pointer,
      old_array: ^array [1 .. * ] of 0 .. 0ff(16),
      old_deck: ost$name,
      old_fid: amt$file_identifier,
      old_size: integer,
      old_source_deck: amt$segment_pointer,
      scope: clt$variable_scope,
      scope_xref: clt$variable_scope,
      size: integer,
      text: string (osc$max_string_size),
      var_ref: clt$variable_reference;

    pmp$get_unique_name (command_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (command_file, amc$record, NIL, command_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    decks_match := TRUE;

    STRINGREP (command [1].command, command [1].size, ' deck_headers_differ = false');
    STRINGREP (command [2].command, command [2].size, ' scu');
    STRINGREP (command [3].command, command [3].size, ' use_library b=', old_path (1, old_path_length));
    STRINGREP (command [4].command, command [4].size, '   old_a = $deck_header(', name, ',a)');
    STRINGREP (command [5].command, command [5].size, '   old_dd = $deck_header(', name, ',dd)');
    STRINGREP (command [6].command, command [6].size, '   old_p = $deck_header(', name, ',p)');
    STRINGREP (command [7].command, command [7].size, '   old_g = $deck_header(', name, ',g)');
    STRINGREP (command [8].command, command [8].size, '   old_c = $deck_header(', name, ',c)');
    STRINGREP (command [9].command, command [9].size, '   old_tc = $deck_header(', name, ',tc)');
    STRINGREP (command [10].command, command [10].size, '   old_w = $deck_header(', name, ',w)');
    STRINGREP (command [11].command, command [11].size, '   old_li = $deck_header(', name, ',li)');
    STRINGREP (command [12].command, command [12].size, '   old_e = $deck_header(', name, ',e)');
    STRINGREP (command [13].command, command [13].size, '   old_m = $deck_header(', name, ',m)');
    STRINGREP (command [14].command, command [14].size, '   old_alc = $deck_header(', name, ',alc)');
    STRINGREP (command [15].command, command [15].size, '   scu');
    STRINGREP (command [16].command, command [16].size, '   use_library b=', new_path (1, new_path_length));
    STRINGREP (command [17].command, command [17].size, '     new_a = $deck_header(', name, ',a)');
    STRINGREP (command [18].command, command [18].size, '     new_dd = $deck_header(', name, ',dd)');
    STRINGREP (command [19].command, command [19].size, '     new_p = $deck_header(', name, ',p)');
    STRINGREP (command [20].command, command [20].size, '     new_g = $deck_header(', name, ',g)');
    STRINGREP (command [21].command, command [21].size, '     new_c = $deck_header(', name, ',c)');
    STRINGREP (command [22].command, command [22].size, '     new_tc = $deck_header(', name, ',tc)');
    STRINGREP (command [23].command, command [23].size, '     new_w = $deck_header(', name, ',w)');
    STRINGREP (command [24].command, command [24].size, '     new_li = $deck_header(', name, ',li)');
    STRINGREP (command [25].command, command [25].size, '     new_e = $deck_header(', name, ',e)');
    STRINGREP (command [26].command, command [26].size, '     new_m = $deck_header(', name, ',m)');
    STRINGREP (command [27].command, command [27].size, '     new_alc = $deck_header(', name, ',alc)');
    STRINGREP (command [28].command, command [28].size, '     check_match: BLOCK');
    STRINGREP (command [29].command, command [29].size, '       deck_headers_differ = (old_a <> new_a)');
    STRINGREP (command [30].command, command [30].size, '       EXIT WHEN deck_headers_differ');
    STRINGREP (command [31].command, command [31].size, '       old_upper = $variable(old_dd,upper_bound)');
    STRINGREP (command [32].command, command [32].size, '       new_upper = $variable(new_dd,upper_bound)');
    STRINGREP (command [33].command, command [33].size,
      '       deck_headers_differ = (old_upper <> new_upper)');
    STRINGREP (command [34].command, command [34].size, '       EXIT WHEN deck_headers_differ');
    STRINGREP (command [35].command, command [35].size, '       FOR i = 1 to old_upper DO');
    STRINGREP (command [36].command, command [36].size,
      '         deck_headers_differ = (old_dd(i) <> new_dd(i))');
    STRINGREP (command [37].command, command [37].size, '         EXIT check_match WHEN deck_headers_differ');
    STRINGREP (command [38].command, command [38].size, '       FOREND');
    STRINGREP (command [39].command, command [39].size, '       deck_headers_differ = (old_p <> new_p)');
    STRINGREP (command [40].command, command [40].size, '       EXIT WHEN deck_headers_differ');
    STRINGREP (command [41].command, command [41].size, '       old_upper = $variable(old_g,upper_bound)');
    STRINGREP (command [42].command, command [42].size, '       new_upper = $variable(new_g,upper_bound)');
    STRINGREP (command [43].command, command [43].size,
      '       deck_headers_differ = (old_upper <> new_upper)');
    STRINGREP (command [44].command, command [44].size, '       EXIT WHEN deck_headers_differ');
    STRINGREP (command [45].command, command [45].size, '       FOR i = 1 to old_upper DO');
    STRINGREP (command [46].command, command [46].size,
      '         deck_headers_differ = (old_g(i) <> new_g(i))');
    STRINGREP (command [47].command, command [47].size, '         EXIT check_match WHEN deck_headers_differ');
    STRINGREP (command [48].command, command [48].size, '       FOREND');
    STRINGREP (command [49].command, command [49].size, '       deck_headers_differ = (old_c <> new_c)');
    STRINGREP (command [50].command, command [50].size, '       EXIT WHEN deck_headers_differ');
    STRINGREP (command [51].command, command [51].size, '       old_upper = $variable(old_tc,upper_bound)');
    STRINGREP (command [52].command, command [52].size, '       new_upper = $variable(new_tc,upper_bound)');
    STRINGREP (command [53].command, command [53].size,
      '       deck_headers_differ = (old_upper <> new_upper)');
    STRINGREP (command [54].command, command [54].size, '       EXIT WHEN deck_headers_differ');
    STRINGREP (command [55].command, command [55].size, '       FOR i = 1 to old_upper DO');
    STRINGREP (command [56].command, command [56].size,
      '         deck_headers_differ = (old_tc(i) <> new_tc(i))');
    STRINGREP (command [57].command, command [57].size, '         EXIT check_match WHEN deck_headers_differ');
    STRINGREP (command [58].command, command [58].size, '       FOREND');
    STRINGREP (command [59].command, command [59].size, '       deck_headers_differ = (old_w <> new_w)');
    STRINGREP (command [60].command, command [60].size, '       EXIT WHEN deck_headers_differ');
    STRINGREP (command [61].command, command [61].size, '       deck_headers_differ = (old_li <> new_li)');
    STRINGREP (command [62].command, command [62].size, '       EXIT WHEN deck_headers_differ');
    STRINGREP (command [63].command, command [63].size, '       deck_headers_differ = (old_e <> new_e)');
    STRINGREP (command [64].command, command [64].size, '       EXIT WHEN deck_headers_differ');
    STRINGREP (command [65].command, command [65].size, '       old_upper = $variable(old_m,upper_bound)');
    STRINGREP (command [66].command, command [66].size, '       new_upper = $variable(new_m,upper_bound)');
    STRINGREP (command [67].command, command [67].size,
      '       deck_headers_differ = (old_upper <> new_upper)');
    STRINGREP (command [68].command, command [68].size, '       EXIT WHEN deck_headers_differ');
    STRINGREP (command [69].command, command [69].size, '       FOR i = 1 to old_upper DO');
    STRINGREP (command [70].command, command [70].size,
      '         deck_headers_differ = (old_m(i) <> new_m(i))');
    STRINGREP (command [71].command, command [71].size, '         EXIT check_match WHEN deck_headers_differ');
    STRINGREP (command [72].command, command [72].size, '       FOREND');
    STRINGREP (command [73].command, command [73].size, '       deck_headers_differ = (old_alc <> new_alc)');
    STRINGREP (command [74].command, command [74].size, '       EXIT WHEN deck_headers_differ');
    STRINGREP (command [75].command, command [75].size, '     BLOCKEND check_match');
    STRINGREP (command [76].command, command [76].size, '   quit no');
    STRINGREP (command [77].command, command [77].size, ' quit no');

    FOR i := 1 TO number_of_commands DO
      amp$put_next (command_fid, ^command [i].command, command [i].size, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    dhd_scl_var_name := 'DECK_HEADERS_DIFFER';
    scope.kind := clc$job_variable;
    scope_xref.kind := clc$xref_variable;

    clp$create_variable (dhd_scl_var_name, clc$boolean_value, 0, 0, 0, scope_xref, var_ref, status);
    IF status.normal THEN
      clp$delete_variable (dhd_scl_var_name, status);
      IF NOT status.normal AND (status.condition <> cle$unknown_variable) THEN
        RETURN;
      IFEND;

      clp$create_variable (dhd_scl_var_name, clc$boolean_value, 0, 0, 0, scope, var_ref, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    amp$close (command_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (text, size, ' include_file f=', command_file);
    clp$scan_command_line (text (1, size), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$return (command_file, ignore_status);

    clp$read_variable (dhd_scl_var_name, var_ref, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF var_ref.value.boolean_value^ [1].value THEN
      decks_match := FALSE;
      RETURN;
    IFEND;

    clp$delete_variable (dhd_scl_var_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_unique_name (old_deck, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_unique_name (new_deck, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$get_decks (name, old_path, old_path_length, new_path, new_path_length, old_deck, new_deck,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH access_selections: [1 .. 1];
    access_selections^ [1].key := amc$access_mode;
    access_selections^ [1].access_mode := $pft$usage_selections [pfc$read];

    amp$open (old_deck, amc$segment, access_selections, old_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (new_deck, amc$segment, access_selections, new_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (old_fid, amc$sequence_pointer, old_source_deck, status);
    IF NOT status.normal THEN
      IF status.condition = ame$read_of_empty_segment THEN
        old_size := 0;
      ELSE
        RETURN;
      IFEND;
    ELSE
      old_size := #SIZE (old_source_deck.sequence_pointer^);
    IFEND;

    amp$get_segment_pointer (new_fid, amc$sequence_pointer, new_source_deck, status);
    IF NOT status.normal THEN
      IF status.condition = ame$read_of_empty_segment THEN
        new_size := 0;
      ELSE
        RETURN;
      IFEND;
    ELSE
      new_size := #SIZE (new_source_deck.sequence_pointer^);
    IFEND;

    IF old_size <> new_size THEN
      decks_match := FALSE;

      amp$close (old_fid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$close (new_fid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (text, size, ' delete_file ', old_deck);
      clp$scan_command_line (text (1, size), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (text, size, ' delete_file ', new_deck);
      clp$scan_command_line (text (1, size), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      RETURN;
    IFEND;

    IF old_size > 0 THEN
      NEXT old_array: [1 .. old_size] IN old_source_deck.sequence_pointer;
      NEXT new_array: [1 .. new_size] IN new_source_deck.sequence_pointer;
    IFEND;

  /search_for_difference/
    FOR j := 1 TO old_size DO
      IF old_array^ [j] <> new_array^ [j] THEN
        decks_match := FALSE;
        EXIT /search_for_difference/
      IFEND;
    FOREND /search_for_difference/;

    amp$close (old_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$close (new_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (text, size, ' delete_file ', old_deck);
    clp$scan_command_line (text (1, size), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (text, size, ' delete_file ', new_deck);
    clp$scan_command_line (text (1, size), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$compare_sl_decks;
MODEND ram$compare_sl_decks;
*DECK DECK=RAM$COMPARE_UNLABELED_VOLUMES EXPAND=TRUE
PROCEDURE (ram$comuv) compare_unlabeled_volumes, comuv (
  volume_one, vo: any of
      name 1..6
      string 1..6
    anyend = $required
  volume_two, vt: any of
      name 1..6
      string 1..6
    anyend = $required
  error_limit, el: (BY_NAME) integer 0..4398046511103 = 0
  volume_one_density, vod: (BY_NAME) key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = osd$reqmt_default_density, mt9$1600
  volume_two_density, vtd: (BY_NAME) key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = $optional
  status)

  VAR
    consecutive_tapemarks_read: integer 0..3
    first_file: file = $unique($local)
    first_temp: file = $unique($local)
    ignore_status: status
    local_status: status
    parameter_names: list of key mt9$800, mt9$1600, mt9$6250, mt18$38000 keyend=
        (mt9$800, mt9$1600, mt9$6250, mt18$38000)
    parameter_values: list of integer 0..2147483647 = (0 0 0 0)
    second_file: file = $unique($local)
    second_temp: file = $unique($local)
    temp_list: file = $unique($local)
  VAREND

  WHEN any_fault exit terminate DO
    delete_file first_file status= ignore_status
    delete_file second_file status= ignore_status
    delete_file first_temp status= ignore_status
    delete_file second_temp status= ignore_status
    delete_file temp_list status= ignore_status
    release_resource mt9$800=all mt9$1600=all mt9$6250=all mt18$38000=all ..
          status=ignore_status
    EXIT compare_unlabeled_volumes WITH osv$status
  WHENEND

  request_magnetic_tape first_file density=volume_one_density ..
        external_vsn=volume_one ring=no
  IF $specified(volume_two_density) THEN
    request_magnetic_tape second_file density=volume_two_density ..
          external_vsn=volume_two ring=no
    local_volume_two_density = volume_two_density
  ELSE
    request_magnetic_tape second_file density=volume_one_density ..
          external_vsn=volume_two ring=no
    local_volume_two_density = volume_one_density
  IFEND
  set_file_attributes first_file block_type=user_specified ..
        file_label_type=unlabeled record_type=undefined

  set_file_attributes second_file block_type=user_specified ..
        file_label_type=unlabeled record_type=undefined

  FOR i = 1 TO $size(parameter_names) DO
    IF volume_one_density = parameter_names(i) THEN
      parameter_values(i) = parameter_values(i) + 1
    IFEND
    IF local_volume_two_density = parameter_names(i) THEN
      parameter_values(i) = parameter_values(i) + 1
    IFEND
  FOREND

  reserve_resource mt9$800=parameter_values(1) mt9$1600=parameter_values(2) ..
        mt9$6250=parameter_values(3) mt18$38000=parameter_values(4)

  consecutive_tapemarks_read = 0
  i = 0

  REPEAT
    copy_file input=first_file.$asis output=first_temp status=local_status
    IF local_status.normal THEN
      copy_file input=second_file.$asis output=second_temp status=local_status
      IF local_status.normal THEN
        compare_file file=first_temp with=second_temp ..
              error_limit= error_limit output=temp_list status=local_status
      IFEND
      i = i+1
    IFEND
    IF (NOT local_status.normal) AND ..
          (local_status.condition = ame$input_after_eoi) THEN
      consecutive_tapemarks_read = consecutive_tapemarks_read + 1
      IF consecutive_tapemarks_read < 3 THEN
        local_status.normal = true
      IFEND
    IFEND
  UNTIL NOT local_status.normal

  IF (i > 1) AND (NOT local_status.normal) AND ..
        (local_status.condition = ame$input_after_eoi) THEN
    EXIT_PROC
  ELSE
    EXIT_PROC WITH local_status
  IFEND

PROCEND compare_unlabeled_volumes
*DECK DECK=RAM$COMPCCL EXPAND=TRUE
.PROC,COMPCCL*I,
I "- source input file name"             = (*F),
L "- listing output file name"           = (*F),
B "- binary output library name"         = (*F),
LO "- listing options"                   = (S,NONE,*N=S),
UN "- NOS/BE perm file ID"               = (*F,*N=),
.
.HELP
 The COMPCCL procedure COMPiles a CCL procedure into a user library.
 This procedure is used as the Cyber 170 half of a NOS/VE CCL
 procedure builder.

 Parameter   Default   Description
   Name       Value

   I          none     Source input file name
   L          none     Listing output file name
   B          none     Binary output library name
   LO          S       Listing options (S=source,NONE)
   UN                  User name in which file resides

.HELP,I
 The I parameter specifies the input source file. This file may be
 local or permanent.
.HELP,L
 The L parameter specifies the output listing file name. This file
 will be permanent.
.HELP,B
 The B parameter specifies the binary output library. The binary
 modules will be added to or replaced in this library as required.
.HELP,LO
 The LO parameter specifies the listing options. If not supplied
 a listing will be produced.
.HELP,UN
 The UN parameter specifies a permanent file ID on NOS/BE systems. This
 parameter must not be specified on NOS.
.ENDHELP
.IF,SYS.EQ.NOSB,CHECKUN.
  REQUEST,YYYYYDF,PF.
  REQUEST,L,PF.
  .IF,$UN$.EQ.$$,BADUN.
    NOTE(OUTPUT); THE #UN PARAMETER MUST BE SPECIFIED.
    REVERT,ABORT.
  .ENDIF,BADUN.
.ELSE,CHECKUN.
  .IF,$UN$.NE.$$,BADUN2.
    REVERT,ABORT. THE #UN PARAMETER MUST NOT BE SPECIFIED
  .ENDIF,BADUN2.
.ENDIF,CHECKUN.
GETFILE(I,I,UN,READ,YES)
SKIP(SOURCEOK)
  EXIT.
  .IF,SYS.EQ.NOS.NOEXIT.
  DAYFILE(#L=YYYYYDF,FR=COMPCCL,OP=M)
  REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
  .IF,SYS.EQ.NOS.ONEXIT.
  UNLOAD(YYYYYDF)
  NOTE(OUTPUT,NR); NO SOURCE FILE FOUND
  REVERT(ABORT) NO SOURCE FILE FOUND
ENDIF(SOURCEOK)
REPLIB(I,B,PROC,UN)
SKIP(REPOK)
  EXIT.
  .IF,SYS.EQ.NOS.NOEXIT.
  DAYFILE(#L=YYYYYDF,FR=COMPCCL,OP=M)
  REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
  .IF,SYS.EQ.NOS.ONEXIT.
  UNLOAD(YYYYYDF,I)
  NOTE(OUTPUT,NR); LIBRARY REPLACE FAILED
  REVERT(ABORT) LIBRARY REPLACE FAILED
ENDIF(REPOK)
.IFE($LO$.EQ.$S$,LIST)
  GETFILE(I,I,UN,READ,YES)
  .IFE,SYS.EQ.NOS.UNLOAD(L)
  COPYSBF(I,L)
.ELSE(LIST)
  NOTE(L)/ LISTING SUPPRESSION REQUESTED
.ENDIF(LIST)
REPFILE(L,L,PRIVATE,READ,,UN)
SKIP(REPFILEOK)
  EXIT.
  .IF,SYS.EQ.NOS.NOEXIT.
  DAYFILE(#L=YYYYYDF,FR=COMPCCL,OP=M)
  REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
  .IF,SYS.EQ.NOS.ONEXIT.
  UNLOAD(YYYYYDF,L,I)
  NOTE(OUTPUT,NR); LISTING PHASE FAILED
  REVERT(ABORT) LISTING PHASE FAILED
ENDIF(REPFILEOK)
UNLOAD(I,L)
.IF,SYS.EQ.NOS.NOEXIT.
DAYFILE(#L=YYYYYDF,FR=COMPCCL,OP=M)
REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
.IF,SYS.EQ.NOS.ONEXIT.
UNLOAD(YYYYYDF)
REVERT. COMPILE I --> B SUCCESSFUL
/EOR
*DECK DECK=RAM$COMPCPS EXPAND=TRUE
.PROC,COMPCPS*I,
I "- source input file name"         = (*F),
L "- listing output file name"       = (*F),
B "- binary output library name"     = (*F),
LO "- listing options"               = (*S14(ABCDEFGLMNRSTX),*N=0),
UN "- NOS/BE perm file ID"           = (*F,*N=),
.
.HELP
 The COMPCPS procedure assembles a COMPASS source program and
 places the output binaries into a specified library. This procedure
 is used as the Cyber 170 half of a NOS/VE COMPASS "cross assembler".

 Parameter   Default   Description
   Name       Value

   I          none     Source input file to be assembled
   L          none     Listing output file to be produced
   B          none     Binary library to receive output
   LO          0       Listing options as per COMPASS assembler
   UN                  User name

.HELP,I
 The I parameter specifies the input source file. This file may be
 local or permanent.
.HELP,L
 The L parameter specifies the output listing file. This file will
 be permanent.
.HELP,B
 The B parameter specifies the binary output library. The output
 binary modules will be added to this library, or replaced in this
 library as appropriate.
.HELP,LO
 The LO parameter specifies the listing options. If not supplied
 then default COMPASS options will be used.
.HELP,UN
 The UN parameter specifies a permanent file ID on NOS/BE systems. This
 parameter must not be specified on NOS.
.ENDHELP
.IF,SYS.EQ.NOSB,CHECKUN.
  REQUEST,YYYYYDF,PF.
  REQUEST,L,PF.
  .IF,$UN$.EQ.$$,BADUN.
    NOTE(OUTPUT); THE #UN PARAMETER MUST BE SPECIFIED.
    REVERT,ABORT.
  .ENDIF,BADUN.
.ELSE,CHECKUN.
  .IF,$UN$.NE.$$,BADUN2.
    REVERT,ABORT. NO #UN PARAMETER ON NOS
  .ENDIF,BADUN2.
.ENDIF,CHECKUN.
.IFE(FILE(OPL,.NOT.AS),GETOPL)
  .IF,SYS.EQ.NOS,NOSSYS.
    GETFILE(OPL,OPL,LIBRARY,READ)
  .ELSE,NOSSYS.
    GETFILE,OPL,OPL,UN,READ.
  .ENDIF,NOSSYS.
  IFE(FILE(OPL,.NOT.AS),NOOPL)
    .IF,SYS.EQ.NOS.NOEXIT.
    DAYFILE(#L=YYYYYDF,FR=COMPCPS,OP=M)
    REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
    .IF,SYS.EQ.NOS.ONEXIT.
    UNLOAD(YYYYYDF)
    NOTE(OUTPUT); OPL NOT FOUND.
    REVERT(ABORT) OPL NOT FOUND
  ENDIF,NOOPL.
.ENDIF(GETOPL)
.IF,SYS.EQ.NOS,NOSTXTS.
  .IFE(FILE(NOSTEXT,.NOT.AS),GETNOST)
  COMTEXT(NOSTEXT,NOSTEXT)
  .ENDIF(GETNOST)
  .IFE(FILE(PSSTEXT,.NOT.AS),GETPSST)
  COMTEXT(PSSTEXT,PSSTEXT)
  .ENDIF(GETPSST)
  .IFE(FILE(SSYTEXT,.NOT.AS),GETSSYT)
  COMTEXT(SSYTEXT,SSYTEXT)
  .ENDIF(GETSSYT)
  .IFE(FILE(CETEXT,.NOT.AS),GETCET)
  COMTEXT(CETEXT,CETEXT)
  .ENDIF(GETCET)
.ENDIF,NOSTXTS.
GETFILE(YCMP,I,UN,READ,NO)
IFE(FILE(YCMP,.NOT.AS),NOSOURCE)
  .IF,SYS.EQ.NOS.NOEXIT.
  DAYFILE(#L=YYYYYDF,FR=COMPCPS,OP=M)
  REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
  .IF,SYS.EQ.NOS.ONEXIT.
  .IFE(FILE(NOSTEXT,.NOT.AS),RETNOST1)
    UNLOAD(NOSTEXT)
  .ENDIF(RETNOST1)
  .IFE(FILE(PSSTEXT,.NOT.AS),RETPSST1)
    UNLOAD(PSSTEXT)
  .ENDIF(RETPSST1)
  .IFE(FILE(SSYTEXT,.NOT.AS),RETSSYT1)
    UNLOAD(SSYTEXT)
  .ENDIF(RETSSYT1)
  .IFE(FILE(OPL,.NOT.AS),RETOPL1)
    UNLOAD(OPL)
  .ENDIF(RETOPL1)
  UNLOAD(YYYYYDF)
  NOTE(OUTPUT,NR); INPUT SOURCE NOT FOUND
  REVERT(ABORT) INPUT SOURCE NOT FOUND
ENDIF(NOSOURCE)
.IF,SYS.EQ.NOS,NOSASM.
  COMPASS(#I=YCMP,#L=L,#B=LGO,#LO=LO,X=OPL,A,G=NOSTEXT,G=PSSTEXT,G=SSYTEXT,
    G=CETEXT)
.ELSE,NOSASM.
  COMPASS(#I=YCMP,#L=L,#B=LGO,#LO=LO,X=OPL,A,S=CPUTEXT,S=PPTEXT,S=SSYTEXT,
    S=IOTEXT)
.ENDIF,NOSASM.
SKIP(ASSEMOK)
  EXIT(S)
  .IF,SYS.EQ.NOS.NOEXIT.
  REPFILE(L,L,PRIVATE,READ,,UN)
  DAYFILE(#L=YYYYYDF,FR=COMPCPS,OP=M)
  REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
  .IF,SYS.EQ.NOS.ONEXIT.
  .IFE(FILE(NOSTEXT,.NOT.AS),RETNOST2)
    UNLOAD(NOSTEXT)
  .ENDIF(RETNOST2)
  .IFE(FILE(PSSTEXT,.NOT.AS),RETPSST2)
    UNLOAD(PSSTEXT)
  .ENDIF(RETPSST2)
  .IFE(FILE(SSYTEXT,.NOT.AS),RETSSYT2)
    UNLOAD(SSYTEXT)
  .ENDIF(RETSSYT2)
  .IFE(FILE(OPL,.NOT.AS),RETOPL2)
    UNLOAD(OPL)
  .ENDIF(RETOPL2)
  UNLOAD(YYYYYDF,YCMP,LGO,L)
  NOTE(OUTPUT,NR); ASSEMBLY ERRORS
  REVERT(ABORT) ASSEMBLY ERRORS
ENDIF(ASSEMOK)
REPFILE(L,L,PRIVATE,READ,,UN)
SKIP(REPFILEOK)
  EXIT(S)
  .IF,SYS.EQ.NOS.NOEXIT.
  DAYFILE(#L=YYYYYDF,FR=COMPCPS,OP=M)
  REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
  .IF,SYS.EQ.NOS.ONEXIT.
  .IFE(FILE(NOSTEXT,.NOT.AS),RETNOST3)
    UNLOAD(NOSTEXT)
  .ENDIF(RETNOST3)
  .IFE(FILE(PSSTEXT,.NOT.AS),RETPSST3)
    UNLOAD(PSSTEXT)
  .ENDIF(RETPSST3)
  .IFE(FILE(SSYTEXT,.NOT.AS),RETSSYT3)
    UNLOAD(SSYTEXT)
  .ENDIF(RETSSYT3)
  .IFE(FILE(OPL,.NOT.AS),RETOPL3)
    UNLOAD(OPL)
  .ENDIF(RETOPL3)
  UNLOAD(YYYYYDF,YCMP,LGO,L,B)
  NOTE(OUTPUT,NR); LISTING REPLACE FAILED
  REVERT(ABORT) LISTING REPLACE FAILED
ENDIF(REPFILEOK)
REPLIB(LGO,B,,UN)
SKIP(REPLIBOK)
  EXIT(S)
  .IF,SYS.EQ.NOS.NOEXIT.
  DAYFILE(#L=YYYYYDF,FR=COMPCPS,OP=M)
  REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
  .IF,SYS.EQ.NOS.ONEXIT.
  .IFE(FILE(NOSTEXT,.NOT.AS),RETNOST4)
    UNLOAD(NOSTEXT)
  .ENDIF(RETNOST4)
  .IFE(FILE(PSSTEXT,.NOT.AS),RETPSST4)
    UNLOAD(PSSTEXT)
  .ENDIF(RETPSST4)
  .IFE(FILE(SSYTEXT,.NOT.AS),RETSSYT4)
    UNLOAD(SSYTEXT)
  .ENDIF(RETSSYT4)
  .IFE(FILE(OPL,.NOT.AS),RETOPL4)
    UNLOAD(OPL)
  .ENDIF(RETOPL4)
  UNLOAD(YYYYYDF,YCMP,LGO,L,B)
  NOTE(OUTPUT,NR); LIBRARY UPDATE FAILED
  REVERT(ABORT) LIBRARY UPDATE FAILED
ENDIF(REPLIBOK)
.IF,SYS.EQ.NOS.NOEXIT.
DAYFILE(#L=YYYYYDF,FR=COMPCPS,OP=M)
REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
.IF,SYS.EQ.NOS.ONEXIT.
.IFE(FILE(NOSTEXT,.NOT.AS),RETNOST5)
  UNLOAD(NOSTEXT)
.ENDIF(RETNOST5)
.IFE(FILE(PSSTEXT,.NOT.AS),RETPSST5)
  UNLOAD(PSSTEXT)
.ENDIF(RETPSST5)
.IFE(FILE(SSYTEXT,.NOT.AS),RETSSYT5)
  UNLOAD(SSYTEXT)
.ENDIF(RETSSYT5)
.IFE(FILE(OPL,.NOT.AS),RETOPL5)
  UNLOAD(OPL)
.ENDIF(RETOPL5)
UNLOAD(YYYYYDF,YCMP,LGO,L,B)
REVERT. ASSEMBLED I --> B
/EOR
*DECK DECK=RAM$COMPCYB EXPAND=TRUE
.PROC,COMPCYB*I,
I "- source input file name"         = (*F),
L "- listing output file name"       = (*F),
B "- binary output library name"     = (*F),
LO "- listing options"               = (*S6(AFORSWX),*N=SX),
UN "- NOS/BE perm file id"           = (*F,*N=),
.
.HELP
 The COMPCYB procedure compiles a CYBIL_CC source program and
 places the output binaries into a specified library. This procedure
 is used as the Cyber 170 half of a NOS/VE CYBIL_CC "cross compiler".

 Parameter   Default   Description
   Name       Value

   I          none     Source input file to be assembled
   L          none     Listing output file to be produced
   B          none     Binary library to receive output
   LO          SX      Listing options as per CYBILC assembler
   UN                  perm file id

.HELP,I
 The I parameter specifies the input source file. This file may be
 local or permanent.
.HELP,L
 The L parameter specifies the output listing file. This file will
 be permanent.
.HELP,B
 The B parameter specifies the binary output library. The output
 binary modules will be added to this library, or replaced in this
 library as appropriate.
.HELP,LO
 The LO parameter specifies the listing options. If not supplied
 then source listing only will be used.
.HELP,UN
 The UN parameter specifies a permanent file ID on NOS/BE systems. This
 parameter must not be specified on NOS.
.ENDHELP
.IF,SYS.EQ.NOSB,CHECKUN.
  REQUEST,YYYYYDF,PF.
  REQUEST,L,PF.
  .IF,$UN$.EQ.$$,BADUN.
    NOTE(OUTPUT); THE #UN PARAMETER MUST BE SPECIFIED.
    REVERT,ABORT.
  .ENDIF,BADUN.
.ELSE,CHECKUN.
  .IF,$UN$.NE.$$,BADUN2.
    REVERT,ABORT. NO #UN PARAMETER ON NOS
  .ENDIF,BADUN2.
.ENDIF,CHECKUN.
GETFILE(YCMP,I,UN,READ,NO)
IFE(FILE(YCMP,.NOT.AS),NOSOURCE)
  .IF,SYS.EQ.NOS.NOEXIT.
  DAYFILE(#L=YYYYYDF,FR=COMPCYB,OP=M)
  REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
  .IF,SYS.EQ.NOS.ONEXIT.
  UNLOAD(YYYYYDF)
  NOTE(OUTPUT,NR); THE #UN PARAMETER MUST BE SPECIFIED.
  REVERT(ABORT) INPUT SOURCE NOT FOUND
ENDIF(NOSOURCE)
.IF,SYS.EQ.NOS,NOSSYS.
  SES.CYBIL,#I=YCMP,#L=L,#B=LGO,#LO=LO.
.ELSE,NOSSYS.
  GETFILE,CYBIL,CYBIL,CYBIL,READ,YES.
  GETFILE,CYBCLIB,CYBCLIB,CYBIL,READ,YES.
CYBIL,#I=YCMP,#L=L,#B=LGO,#LO=LO.
.ENDIF,NOSSYS.
SKIP(ASSEMOK)
  EXIT(S)
  .IF,SYS.EQ.NOS.NOEXIT.
  REPFILE(L,L,PRIVATE,READ,,UN)
  DAYFILE(#L=YYYYYDF,FR=COMPCYB,OP=M)
  REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
  .IF,SYS.EQ.NOS.ONEXIT.
  UNLOAD(CYBIL,CYBCLIB)
  UNLOAD(YYYYYDF,YCMP,LGO,L)
  NOTE(OUTPUT,NR); COMPILATION ERRORS
  REVERT(ABORT) COMPILATION ERRORS
ENDIF(ASSEMOK)
REPFILE(L,L,PRIVATE,READ,,UN)
SKIP(REPFILEOK)
  EXIT(S)
  .IF,SYS.EQ.NOS.NOEXIT.
  DAYFILE(#L=YYYYYDF,FR=COMPCYB,OP=M)
  REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
  .IF,SYS.EQ.NOS.ONEXIT.
  UNLOAD(CYBIL,CYBCLIB)
  UNLOAD(YYYYYDF,YCMP,LGO,L,B)
  NOTE(OUTPUT,NR); LISTING REPLACE FAILED
  REVERT(ABORT) LISTING REPLACE FAILED
ENDIF(REPFILEOK)
REPLIB(LGO,B,,UN)
SKIP(REPLIBOK)
  EXIT(S)
  .IF,SYS.EQ.NOS.NOEXIT.
  DAYFILE(#L=YYYYYDF,FR=COMPCYB,OP=M)
  REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
  .IF,SYS.EQ.NOS.ONEXIT.
  UNLOAD(CYBIL,CYBCLIB)
  UNLOAD(YYYYYDF,YCMP,LGO,L,B)
  NOTE(OUTPUT,NR); LIBRARY UPDATE FAILED
  REVERT(ABORT) LIBRARY UPDATE FAILED
ENDIF(REPLIBOK)
.IF,SYS.EQ.NOS.NOEXIT.
DAYFILE(#L=YYYYYDF,FR=COMPCYB,OP=M)
REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
.IF,SYS.EQ.NOS.ONEXIT.
UNLOAD(CYBIL,CYBCLIB)
UNLOAD(YYYYYDF,YCMP,LGO,L,B)
REVERT. COMPILED I --> B
/EOR
*DECK DECK=RAM$COMPILE_GET_LEVELING_DATA EXPAND=TRUE
PROCEDURE compile_get_leveling_data, comgld (
  list, l: file = $list
  alternate_catalog, ac: file = $optional
  status)


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"The purpose of this request is to compile the JMM$SELECT_INTERACTIVE_JOB_DEST
"source deck (found on the source library under the SITE_OS_MAINTENANCE catalog)
"and place the resulting binary onto OSF$BOUND_JOB_TEMPLATE_23D (also under the
"SITE_OS_MAINTENANCE catalog).  The presence of the library
"OSF$BOUND_JOB_TEMPLATE_23D under the SITE_OS_MAINTENANCE catalog causes the
"load module JMM$SELECT_INTERACTIVE_JOB_DEST to be automatically merged onto
"the released OSF$BOUND_JOB_TEMPLATE_23D upon the next execution of
"MAKE_VE_DEADSTART_FILE.
"
"If the OS files have been installed to an alternate catalog this should be
"specified by the ALTERNATE_CATALOG parameter.
*IFEND


  VAR
    binary_output: file = $unique($local)
    compile_source: file = $unique($local)
    ignore_status: status
    local_status: status
    osf$bound_job_template_23d: file = $system.site_os_maintenance.osf$bound_job_template_23d
    osf$program_interface: file = $system.cybil.osf$program_interface
    osf$subsystem_interface: file = $system.cybil.osf$subsystem_interface
  VAREND

  SOURCE_CODE_UTILITY
    IF $specified(alternate_catalog) THEN
      use_library b=alternate_catalog.source_library r=$null
    ELSE
      use_library b=$system.site_os_maintenance.source_library r=$null
    IFEND

    expand_deck d=jmm$mainframe_get_leveling_data c=compile_source ab=(osf$program_interface ..
          osf$subsystem_interface)
  QUIT

  cybil i=compile_source b=binary_output l=list opt=high rc=none da=none

  CREATE_OBJECT_LIBRARY
    file_attrib = $file_attributes(osf$bound_job_template_23d (registered, size))
    IF file_attrib(1).registered AND (file_attrib(1).size > 0) THEN
      add_modules l=osf$bound_job_template_23d
    IFEND
    combine_module l=binary_output
    generate_library l=osf$bound_job_template_23d
    put_line ' Compiled to '//osf$bound_job_template_23d.$high o=$response
  QUIT

  detach_file binary_output status=ignore_status
  detach_file compile_source status=ignore_status

  EXIT_PROC WITH local_status

PROCEND compile_get_leveling_data
*DECK DECK=RAM$COMPILE_PASSWORD_CHANGE EXPAND=TRUE
PROC compile_password_change, compc (
  list, l               : file = $list
  alternate_catalog, ac : file = $optional
  status                : var of status = $optional
  )


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"The purpose of this request is to compile the AVM$PROCESS_PASSWORD_ATTRIBUTES source deck
"(found on the source library under the SITE_OS_MAINTENANCE catalog) and place
"the resulting binary onto OSF$BOUND_JOB_TEMPLATE_23D (also under the
"SITE_OS_MAINTENANCE catalog).  The presence of the library
"OSF$BOUND_JOB_TEMPLATE_23D under the SITE_OS_MAINTENANCE catalog causes the
"load module AVM$PROCESS_PASSWORD_ATTRIBUTES to be automatically merged onto the released
"OSF$BOUND_JOB_TEMPLATE_23D upon the next execution of MAKE_VE_DEADSTART_FILE.
"
"If the OS files have been installed to an alternate catalog this should be
"specified by the ALTERNATE_CATALOG parameter.
*IFEND


  create_variable bound_job_template_23d k=string v='$system.site_os_maintenance.osf$bound_job_template_23d'
  create_variable maintenance_source_library k=string v='$system.site_os_maintenance.source_library'
  create_variable binary_output k=string v='$local.'//$unique
  create_variable compile_file k=string v='$local.'//$unique
  create_variable compile_source k=string v='$local.'//$unique
  create_variable ignore_status k=status
  create_variable local_status k=status
  create_variable osf$program_interface k=string v='$system.cybil.osf$program_interface'


  IF $specified(alternate_catalog) THEN
    bound_job_template_23d = $string($value(alternate_catalog)) // ..
          '.site_os_maintenance.osf$bound_job_template_23d'
    maintenance_source_library = $string($value(alternate_catalog)) // '.site_os_maintenance.source_library'
  IFEND

COLLECT_TEXT o=$fname(compile_file) until='END_COLLECT'
  source_code_utility
    use_library b=$fname(maintenance_source_library) r=$null
    expand_deck d=avm$process_password_attributes c=$fname(compile_source) ab=$fname(osf$program_interface)
  quit

  cybil i=$fname(compile_source) b=$fname(binary_output) l=$value(list) opt=high rc=none da=none

  create_object_library
    IF $file($fname(bound_job_template_23d) assigned) AND ($file($fname(bound_job_template_23d) size) > 0) THEN
      add_modules l=$fname(bound_job_template_23d)
    IFEND
    combine_module l=$fname(binary_output)
    generate_library l=$fname(bound_job_template_23d//'.$next')
    put_line ' Compiled to '//$string($fname(bound_job_template_23d//'.$high')) o=$response
  quit
END_COLLECT

  include_file $fname(compile_file) status=local_status

  detach_file $fname(bound_job_template_23d) status=ignore_status
  detach_file $fname(maintenance_source_library) status=ignore_status
  detach_file $fname(binary_output) status=ignore_status
  detach_file $fname(compile_file) status=ignore_status
  detach_file $fname(compile_source) status=ignore_status
  detach_file $fname(osf$program_interface) status=ignore_status

  EXIT_PROC WITH local_status

PROCEND compile_password_change
*DECK DECK=RAM$COMPILE_PASSWORD_ENCRYPTION EXPAND=TRUE
PROC compile_password_encryption, compe (
  list, l               : file = $list
  alternate_catalog, ac : file = $optional
  status                : var of status = $optional
  )


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"The purpose of this request is to compile the AVM$ENCRYPT_PASSWORD source deck
"(found on the source library under the SITE_OS_MAINTENANCE catalog) and place
"the resulting binary onto OSF$BOUND_JOB_TEMPLATE_23d (also under the
"SITE_OS_MAINTENANCE catalog).  The presence of the library
"OSF$BOUND_JOB_TEMPLATE_23d under the SITE_OS_MAINTENANCE catalog causes the
"load module AVM$ENCRYPT_PASSWORD to be automatically merged onto the released
"OSF$BOUND_JOB_TEMPLATE_23d upon the next execution of MAKE_VE_DEADSTART_FILE.
"
"If the OS files have been installed to an alternate catalog this should be
"specified by the ALTERNATE_CATALOG parameter.
*IFEND


  create_variable bound_job_template_23d k=string v='$system.site_os_maintenance.osf$bound_job_template_23d'
  create_variable maintenance_source_library k=string v='$system.site_os_maintenance.source_library'
  create_variable binary_output k=string v='$local.'//$unique
  create_variable compile_file k=string v='$local.'//$unique
  create_variable compile_source k=string v='$local.'//$unique
  create_variable ignore_status k=status
  create_variable local_status k=status
  create_variable osf$program_interface k=string v='$system.cybil.osf$program_interface'


  IF $specified(alternate_catalog) THEN
    bound_job_template_23d = $string($value(alternate_catalog)) // ..
          '.site_os_maintenance.osf$bound_job_template_23d'
    maintenance_source_library = $string($value(alternate_catalog)) // '.site_os_maintenance.source_library'
  IFEND

COLLECT_TEXT o=$fname(compile_file) until='END_COLLECT'
  source_code_utility
    use_library b=$fname(maintenance_source_library) r=$null
    expand_deck d=avm$encrypt_password c=$fname(compile_source) ab=$fname(osf$program_interface)
  quit

  cybil i=$fname(compile_source) b=$fname(binary_output) l=$value(list) opt=high rc=none da=none

  create_object_library
    IF $file($fname(bound_job_template_23d) assigned) AND ($file($fname(bound_job_template_23d) size) > 0) THEN
      add_modules l=$fname(bound_job_template_23d)
    IFEND
    combine_module l=$fname(binary_output)
    generate_library l=$fname(bound_job_template_23d//'.$next')
    put_line ' Compiled to '//$string($fname(bound_job_template_23d//'.$high')) o=$response
  quit
END_COLLECT

  include_file $fname(compile_file) status=local_status

  detach_file $fname(bound_job_template_23d) status=ignore_status
  detach_file $fname(maintenance_source_library) status=ignore_status
  detach_file $fname(binary_output) status=ignore_status
  detach_file $fname(compile_file) status=ignore_status
  detach_file $fname(compile_source) status=ignore_status
  detach_file $fname(osf$program_interface) status=ignore_status

  EXIT_PROC WITH local_status

PROCEND compile_password_encryption
*DECK DECK=RAM$COMPILE_PF_MAINT_PROCS EXPAND=TRUE
PROC compile_pf_maint_procs, compfmp (
  list, l           : file = $list
  alternate_catalog, ac : file = $optional
  status : var of status = $optional
  )

" The purpose of this procedure is to compile the PF maintenance procedures
" found on the source library under the SITE_OS_MAINTENANCE catalog and
" place the resulting binary onto OSF$SOU_LIBRARY which is also in
" the SITE_OS_MAINTENANCE catalog.  The presence of the library
" OSF$SOU_LIBRARY in the SITE_OS_MAINTENANCE catalog will be merged
" merged onto the released OSF$SOU_LIBRARY automatically upon the next
" execution of MAKE_VE_DEADSTART_FILE.
"
" If the OS files have been installed to an alternate catalog this should be
" specified by the ALTERNATE_CATALOG parameter.

  create_variable (local_status ignore_status) kind=status
  create_variable source_library kind=string value='$system.site_os_maintenance.source_library'
  create_variable object_library kind=string value='$system.site_os_maintenance.osf$sou_library'
  create_variable temp_file kind=(string $max_name) value=$unique


  IF $specified(alternate_catalog) THEN
    source_library = $string($value(alternate_catalog)) // '.site_os_maintenance.source_library'
    object_library = $string($value(alternate_catalog)) // '.site_os_maintenance.osf$sou_library'
  IFEND

compile_block: ..
  BLOCK
    SOURCE_CODE_UTILITY
      use_library base=$fname(source_library) result=$null
      expand_deck compile=$fname(temp_file) deck=(..
          pup$create_aged_file_backup ..
          pup$create_catalog_backup ..
          pup$create_full_backup ..
          pup$create_partial_backup ..
          pup$delete_expired_files ..
          pup$display_all_files ..
          pup$label_tape_volumes ..
          pup$restore_cataloged_files ..
          pup$restore_unreconciled_files ..
          pup$restore_unreconciled_cats) status=local_status
    QUIT
    EXIT compile_block WHEN NOT local_status.normal

    CREATE_OBJECT_LIBRARY
    ocu_block: ..
      BLOCK
        add_module library=$fname(object_library) status=ignore_status
        combine_module library=$fname(temp_file) status=local_status
        EXIT ocu_block WHEN NOT local_status.normal
        generate_library library=$fname(object_library) status=local_status
        EXIT ocu_block WHEN NOT local_status.normal
      BLOCKEND ocu_block
    QUIT
  BLOCKEND compile_block

  IF $file($fname(temp_file), assigned) THEN
    copy_file input=$fname(temp_file) output=$value(list) status=local_status
    detach_file file=$fname(temp_file) status=ignore_status
  IFEND

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND compile_pf_maint_procs
*DECK DECK=RAM$COMPILE_SELECT_JOB_DEST EXPAND=TRUE
PROCEDURE compile_select_job_dest, comsjd (
  list, l: file = $list
  alternate_catalog, ac: file = $optional
  status)


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"The purpose of this request is to compile the JMM$SELECT_INTERACTIVE_JOB_DEST
"source deck (found on the source library under the SITE_OS_MAINTENANCE catalog)
"and place the resulting binary onto OSF$BOUND_JOB_TEMPLATE_23D (also under the
"SITE_OS_MAINTENANCE catalog).  The presence of the library
"OSF$BOUND_JOB_TEMPLATE_23D under the SITE_OS_MAINTENANCE catalog causes the
"load module JMM$SELECT_INTERACTIVE_JOB_DEST to be automatically merged onto
"the released OSF$BOUND_JOB_TEMPLATE_23D upon the next execution of
"MAKE_VE_DEADSTART_FILE.
"
"If the OS files have been installed to an alternate catalog this should be
"specified by the ALTERNATE_CATALOG parameter.
*IFEND


  VAR
    binary_output: file = $unique($local)
    compile_source: file = $unique($local)
    ignore_status: status
    local_status: status
    osf$bound_job_template_23d: file = $system.site_os_maintenance.osf$bound_job_template_23d
    osf$program_interface: file = $system.cybil.osf$program_interface
    osf$subsystem_interface: file = $system.cybil.osf$subsystem_interface
  VAREND

  SOURCE_CODE_UTILITY
    IF $specified(alternate_catalog) THEN
      use_library b=alternate_catalog.source_library r=$null
    ELSE
      use_library b=$system.site_os_maintenance.source_library r=$null
    IFEND

    expand_deck d=jmm$select_interactive_job_dest c=compile_source ab=(osf$program_interface ..
          osf$subsystem_interface)
  QUIT

  cybil i=compile_source b=binary_output l=list opt=high rc=none da=none

  CREATE_OBJECT_LIBRARY
    file_attrib = $file_attributes(osf$bound_job_template_23d (registered, size))
    IF file_attrib(1).registered AND (file_attrib(1).size > 0) THEN
      add_modules l=osf$bound_job_template_23d
    IFEND
    combine_module l=binary_output
    generate_library l=osf$bound_job_template_23d
    put_line ' Compiled to '//osf$bound_job_template_23d.$high o=$response
  QUIT

  detach_file binary_output status=ignore_status
  detach_file compile_source status=ignore_status

  EXIT_PROC WITH local_status

PROCEND compile_select_job_dest
*DECK DECK=RAM$COMPILE_SITE_TAPE_HOOKS EXPAND=TRUE
PROCEDURE compile_site_tape_hooks, comsth (
  list, l: file = $list
  alternate_catalog, ac: file = $optional
  status)

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

" The purpose of this procedure is to compile the RMM$VALIDATE_TAPE_OPERATIONS and
" RMM$ENFORCE_TAPE_SECURITY source decks (found on the source library under
" the SITE_OS_MAINTENANCE catalog) and place the resulting binary onto
" OSF$BOUND_JOB_TEMPLATE_23D (also under the SITE_OS_MAINTENANCE catalog).
" The presence of the library OSF$BOUND_JOB_TEMPLATE_23D under the
" SITE_OS_MAINTENANCE catalog causes the load modules
" to be automatically merged onto the released OSF$BOUND_JOB_TEMPLATE_23D
" library upon the next execution of MAKE_VE_DEADSTART_FILE.
"
" If the OS files have been installed to an alternate catalog this should be
" specified by the ALTERNATE_CATALOG parameter.
*IFEND


  VAR
    binary_output: file = $unique($local)
    compile_source: file = $unique($local)
    ignore_status: status
    local_status: status
    osf$bound_job_template_23d: file = $system.site_os_maintenance.osf$bound_job_template_23d
    osf$program_interface: file = $system.cybil.osf$program_interface
    osf$subsystem_interface: file = $system.cybil.osf$subsystem_interface
  VAREND

  SOURCE_CODE_UTILITY
    IF $specified(alternate_catalog) THEN
      use_library b=alternate_catalog.source_library r=$null
    ELSE
      use_library b=$system.site_os_maintenance.source_library r=$null
    IFEND

    expand_deck d=(rmm$enforce_tape_security rmm$validate_tape_operations) ..
          c=compile_source ab=(osf$program_interface osf$subsystem_interface)
  QUIT

  cybil i=compile_source b=binary_output l=list opt=high rc=none da=none

  CREATE_OBJECT_LIBRARY
    file_attrib = $file_attributes(osf$bound_job_template_23d (registered, ..
          size))
    IF file_attrib(1).registered AND (file_attrib(1).size > 0) THEN
      add_modules l=osf$bound_job_template_23d
    IFEND
    combine_module l=binary_output
    generate_library l=osf$bound_job_template_23d
    put_line ' Compiled to '//osf$bound_job_template_23d.$high o=$response
  QUIT

  delete_file binary_output status=ignore_status
  delete_file compile_source status=ignore_status

  EXIT_PROC WITH local_status

PROCEND compile_site_tape_hooks
*DECK DECK=RAM$COMPILE_SRUS_ALGORITHM EXPAND=TRUE
PROC compile_srus_algorithm, comsa (
  list, l               : file = $list
  alternate_catalog, ac : file = $optional
  status                : var of status = $optional
  )


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"The purpose of this request is to compile the AVM$CALCULATE_SRUS source deck
"(found on the source library under the SITE_OS_MAINTENANCE catalog) and place
"the resulting binary onto OSF$BOUND_JOB_TEMPLATE_223 (also under the
"SITE_OS_MAINTENANCE catalog).  The presence of the library
"OSF$BOUND_JOB_TEMPLATE_223 under the SITE_OS_MAINTENANCE catalog causes the
"load module AVM$CALCULATE_SRUS to be automatically merged onto the released
"OSF$BOUND_JOB_TEMPLATE_223 upon the next execution of MAKE_VE_DEADSTART_FILE.
"
"If the OS files have been installed to an alternate catalog this should be
"specified by the ALTERNATE_CATALOG parameter.
*IFEND


  create_variable bound_job_template_223 k=string v='$system.site_os_maintenance.osf$bound_job_template_223'
  create_variable maintenance_source_library k=string v='$system.site_os_maintenance.source_library'
  create_variable binary_output k=string v='$local.'//$unique
  create_variable compile_file k=string v='$local.'//$unique
  create_variable compile_source k=string v='$local.'//$unique
  create_variable ignore_status k=status
  create_variable local_status k=status
  create_variable osf$program_interface k=string v='$system.cybil.osf$program_interface'


  IF $specified(alternate_catalog) THEN
    bound_job_template_223 = $string($value(alternate_catalog)) // ..
          '.site_os_maintenance.osf$bound_job_template_223'
    maintenance_source_library = $string($value(alternate_catalog)) // '.site_os_maintenance.source_library'
  IFEND

COLLECT_TEXT o=$fname(compile_file) until='END_COLLECT'
  source_code_utility
    use_library b=$fname(maintenance_source_library) r=$null
    expand_deck d=avm$calculate_srus c=$fname(compile_source) ab=$fname(osf$program_interface)
  quit

  cybil i=$fname(compile_source) b=$fname(binary_output) l=$value(list) opt=high rc=none da=none

  create_object_library
    IF $file($fname(bound_job_template_223) assigned) AND ($file($fname(bound_job_template_223) size) > 0) THEN
      add_modules l=$fname(bound_job_template_223)
    IFEND
    combine_module l=$fname(binary_output)
    generate_library l=$fname(bound_job_template_223//'.$next')
    put_line ' Compiled to '//$string($fname(bound_job_template_223//'.$high')) o=$response
  quit
END_COLLECT

  include_file $fname(compile_file) status=local_status

  detach_file $fname(bound_job_template_223) status=ignore_status
  detach_file $fname(maintenance_source_library) status=ignore_status
  detach_file $fname(binary_output) status=ignore_status
  detach_file $fname(compile_file) status=ignore_status
  detach_file $fname(compile_source) status=ignore_status
  detach_file $fname(osf$program_interface) status=ignore_status

  EXIT_PROC WITH local_status

PROCEND compile_srus_algorithm
*DECK DECK=RAM$COMPILE_VERIFY_VAL_NAME EXPAND=TRUE
PROC compile_verify_validation_name, comvvn (
  list, l               : file = $list
  alternate_catalog, ac : file = $optional
  status                : var of status = $optional
  )


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"The purpose of this request is to compile the AVM$VERIFY_VALIDATION_NAME source deck
"(found on the source library under the SITE_OS_MAINTENANCE catalog) and place
"the resulting binary onto OSF$BOUND_JOB_TEMPLATE_23D (also under the
"SITE_OS_MAINTENANCE catalog).  The presence of the library
"OSF$BOUND_JOB_TEMPLATE_23D under the SITE_OS_MAINTENANCE catalog causes the
"load module AVM$VERIFY_VALIDATION_NAME to be automatically merged onto the released
"OSF$BOUND_JOB_TEMPLATE_23D upon the next execution of MAKE_VE_DEADSTART_FILE.
"
"If the OS files have been installed to an alternate catalog this should be
"specified by the ALTERNATE_CATALOG parameter.
*IFEND


  create_variable bound_job_template_23d k=string v='$system.site_os_maintenance.osf$bound_job_template_23d'
  create_variable maintenance_source_library k=string v='$system.site_os_maintenance.source_library'
  create_variable binary_output k=string v='$local.'//$unique
  create_variable compile_file k=string v='$local.'//$unique
  create_variable compile_source k=string v='$local.'//$unique
  create_variable ignore_status k=status
  create_variable local_status k=status
  create_variable osf$program_interface k=string v='$system.cybil.osf$program_interface'
  create_variable osf$subsystem_interface k=string v='$system.cybil.osf$subsystem_interface'


  IF $specified(alternate_catalog) THEN
    bound_job_template_23d = $string($value(alternate_catalog)) // ..
          '.site_os_maintenance.osf$bound_job_template_23d'
    maintenance_source_library = $string($value(alternate_catalog)) // '.site_os_maintenance.source_library'
  IFEND

COLLECT_TEXT o=$fname(compile_file) until='END_COLLECT'
  source_code_utility
    use_library b=$fname(maintenance_source_library) r=$null
    expand_deck d=avm$verify_validation_name c=$fname(compile_source) ab=($fname(osf$program_interface) ..
          $fname(osf$subsystem_interface))
  quit

  cybil i=$fname(compile_source) b=$fname(binary_output) l=$value(list) opt=high rc=none da=none

  create_object_library
    IF $file($fname(bound_job_template_23d) assigned) AND ($file($fname(bound_job_template_23d) size) > 0) THEN
      add_modules l=$fname(bound_job_template_23d)
    IFEND
    combine_module l=$fname(binary_output)
    generate_library l=$fname(bound_job_template_23d//'.$next')
    put_line ' Compiled to '//$string($fname(bound_job_template_23d//'.$high')) o=$response
  quit
END_COLLECT

  include_file $fname(compile_file) status=local_status

  detach_file $fname(bound_job_template_23d) status=ignore_status
  detach_file $fname(maintenance_source_library) status=ignore_status
  detach_file $fname(binary_output) status=ignore_status
  detach_file $fname(compile_file) status=ignore_status
  detach_file $fname(compile_source) status=ignore_status
  detach_file $fname(osf$program_interface) status=ignore_status

  EXIT_PROC WITH local_status

PROCEND compile_verify_validation_name
*DECK DECK=RAM$COMPSYM EXPAND=TRUE
.PROC,COMPSYM*I,
I "- source input file name"         = (*F),
L "- listing output file name"       = (*F),
B "- binary output library name"     = (*F),
LO "- listing options"               = (*S4(LORX),*N=L),
UN "- NOS/BE perm file ID"           = (*F,*N=),
.
.HELP
 The COMPSYM procedure compiles a SYMPL source program and
 places the output binaries into a specified library. This procedure
 is used as the Cyber 170 half of a NOS/VE SYMPL "cross compiler".

 Parameter   Default   Description
   Name       Value

   I          none     Source input file to be assembled
   L          none     Listing output file to be produced
   B          none     Binary library to receive output
   LO          L       Listing options as per SYMPL compiler
   UN                  perm file ID

.HELP,I
 The I parameter specifies the input source file. This file may be
 local or permanent.
.HELP,L
 The L parameter specifies the output listing file. This file will
 be permanent.
.HELP,B
 The B parameter specifies the binary output library. The output
 binary modules will be added to this library, or replaced in this
 library as appropriate.
.HELP,LO
 The LO parameter specifies the listing options. If not supplied
 then source listing only will be used.
.HELP,UN.
 The UN parameter specifies a permanent file ID on NOS/BE systems. This
 parameter must not be specified on NOS.
.ENDHELP
.IF,SYS.EQ.NOSB,CHECKUN.
  REQUEST,YYYYYDF,PF.
  REQUEST,L,PF.
  .IF,$UN$.EQ.$$,BADUN.
    NOTE(OUTPUT); THE #UN PARAMETER MUST BE SPECIFIED.
    REVERT,ABORT.
  .ENDIF,BADUN.
.ELSE,CHECKUN.
  .IF,$UN$.NE.$$,BADUN2.
    REVERT,ABORT. NO #UN PARAMETER ON NOS
  .ENDIF,BADUN2.
.ENDIF,CHECKUN.
GETFILE(YCMP,I,UN,READ,NO)
IFE(FILE(YCMP,.NOT.AS),NOSOURCE)
  .IF,SYS.EQ.NOS.NOEXIT.
  DAYFILE(#L=YYYYYDF,FR=COMPSYM,OP=M)
  REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
  .IF,SYS.EQ.NOS.ONEXIT.
  UNLOAD(YYYYYDF)
  NOTE(OUTPUT,NR); INPUT SOURCE NOT FOUND
  REVERT(ABORT) INPUT SOURCE NOT FOUND
ENDIF(NOSOURCE)
SYMPL(#I=YCMP,LO=L,#B=LGO,ET=T)
SKIP(COMPOK)
  EXIT(S)
  .IF,SYS.EQ.NOS.NOEXIT.
  REPFILE(L,L,PRIVATE,READ,,UN)
  DAYFILE(#L=YYYYYDF,FR=COMPSYM,OP=M)
  REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
  .IF,SYS.EQ.NOS.ONEXIT.
  UNLOAD(YYYYYDF,YCMP,LGO,L)
  NOTE(OUTPUT,NR); COMPILATION ERRORS
  REVERT(ABORT) COMPILATION ERRORS
ENDIF(COMPOK)
REPFILE(L,L,PRIVATE,READ,,UN)
SKIP(REPFILEOK)
  EXIT(S)
  .IF,SYS.EQ.NOS.NOEXIT.
  DAYFILE(#L=YYYYYDF,FR=COMPSYM,OP=M)
  REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
  .IF,SYS.EQ.NOS.ONEXIT.
  UNLOAD(YYYYYDF,YCMP,LGO,L,B)
  NOTE(OUTPUT,NR); LISTING REPLACE FAILED
  REVERT(ABORT) LISTING REPLACE FAILED
ENDIF(REPFILEOK)
REPLIB(LGO,B,,UN)
SKIP(REPLIBOK)
  EXIT(S)
  .IF,SYS.EQ.NOS.NOEXIT.
  DAYFILE(#L=YYYYYDF,FR=COMPSYM,OP=M)
  REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
  .IF,SYS.EQ.NOS.ONEXIT.
  UNLOAD(YYYYYDF,YCMP,LGO,L,B)
  NOTE(OUTPUT,NR); LIBRARY UPDATE FAILED
  REVERT(ABORT) LIBRARY UPDATE FAILED
ENDIF(REPLIBOK)
IF,SYS.EQ.NOS.NOEXIT.
DAYFILE(#L=YYYYYDF,FR=COMPSYM,OP=M)
REPFILE(YYYYYDF,YYYYYDF,PRIVATE,READ,,UN)
.IF,SYS.EQ.NOS.ONEXIT.
UNLOAD(YYYYYDF,YCMP,LGO,L,B)
REVERT. COMPILED I --> B
/EOR
*DECK DECK=RAM$COMTEXT EXPAND=TRUE
.PROC,COMTEXT*I,
LFN " - local file name (name of text)"      = (*F),
PFN " - permanent file name"                 = (*F,*N=),
UN  " - user name for permanent file"        = (*F,*N=),
.
.HELP
The COMTEXT procedure gets system texts for NOS assemblies and
compilations. If a local file of the text name exists, that is
used.  If no local file is found, a permanent file is accessed
of the specified user name. If the text is still not found, it
is extracted from the running system.

PARAMETER   DEFAULT   DESCRIPTION
  NAME       VALUE

  LFN        none     The name of the system text or local file.
  PFN        lfn      The name of the permanent file.
  UN         null     The user name for the permanent file.

This procedure is effectively null for NOS/BE because compila-
tions and assemblies for NOS/BE use the system texts only.

.HELP,LFN
The lfn parameter selects the system text (or local file) name.
.HELP,PFN
The pfn parameter specifies the permanent file name to get the
system text from. If not supplied it defaults to lfn.
.HELP,UN
The un parameter specifies the NOS user name to look on for
the file given in pfn.
.ENDHELP
.IF,SYS.EQ.NOSB.REVERT.
GETFILE(LFN,PFN,UN,READ,NO)
$IFE(FILE(LFN,.NOT.AS),GETSYSTEM)
  $COMMON(SYSTEM)
  $GTR(SYSTEM,LFN)OVL/LFN
  $UNLOAD(SYSTEM)
$ENDIF(GETSYSTEM)
$SETFS(LFN/FS=NAD)
$REVERT. TEXT LFN --> LFN
$EXIT.
$REVERT(ABORT) TEXT LFN NOT FOUND
/EOR
*DECK DECK=RAM$CONVERT_64_TO_32 EXPAND=TRUE
create_program_description name=(convert_64_to_32, con6t3) sp=ocp$convert_64_to_32_bits ..
      l=($system.ocu.bound_product, osf$task_services_library) tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$CONVERT_BASE EXPAND=TRUE
PROC convert_base, conb (
  value, v: string = $required
  length, l: integer = $required
  base, b: integer 8 .. 16 = 10
  result, r: var of string
  status)

  blanks = '                    '
  zeros = '0000000000000000'
  int = $integer($value(value))
  convert_variable = $strrep(int, $value(base))

  IF convert_variable = '-1' THEN
    $value(result) = $substr(blanks, 1, $value(length))
    EXIT_PROC
  ELSEIF $substr(convert_variable,1 ,1) <> '-' THEN
    IF $strlen(convert_variable) < $value(length) THEN
      IF $value(base) = 16 THEN
        $value(result) = $substr(zeros, 1, $value(length)-$strlen(convert_variable)) // convert_variable
        EXIT_PROC
      ELSE
        $value(result) = $substr(blanks, 1, $value(length)-$strlen(convert_variable)) // convert_variable
        EXIT_PROC
      IFEND
    ELSE
      $value(result) = convert_variable
      EXIT_PROC
    IFEND
  ELSEIF $value(base) = 16 "must complement negative number in hexadecimal only"
    int = int + 4000000000000000(16)
    int = int + 4000000000000000(16)
    convert_variable = $strrep(int, 16)
    IF $strlen(convert_variable) < 16 THEN
      convert_variable = $substr(zeros, 1, 16-$strlen(convert_variable)) // convert_variable
      EXIT_PROC
    IFEND
    tst = $substr(convert_variable, 1, 1)
    IF tst = '0' THEN
      $value(result) = '8' // $substr(convert_variable, 2, 15)
    ELSEIF tst = '1' THEN
      $value(result) = '9' // $substr(convert_variable, 2, 15)
    ELSEIF tst = '2' THEN
      $value(result) = 'A' // $substr(convert_variable, 2, 15)
    ELSEIF tst = '3' THEN
      $value(result) = 'B' // $substr(convert_variable, 2, 15)
    ELSEIF tst = '4' THEN
      $value(result) = 'C' // $substr(convert_variable, 2, 15)
    ELSEIF tst = '5' THEN
      $value(result) = 'D' // $substr(convert_variable, 2, 15)
    ELSEIF tst = '6' THEN
      $value(result) = 'E' // $substr(convert_variable, 2, 15)
    ELSEIF tst = '7' THEN
      $value(result) = 'F' // $substr(convert_variable, 2, 15)
    ELSE
      IF $strlen(convert_variable) < $value(length) THEN
        $value(result) = $substr(blanks, 1, $value(length)-$strlen(convert_variable)) // convert_variable
        EXIT_PROC
      ELSE
        $value(result) = convert_variable
        EXIT_PROC
      IFEND
    IFEND
  IFEND

PROCEND convert_base

*DECK DECK=RAM$CONVERT_CI_TO_II EXPAND=TRUE
create_program_description name=(convert_ci_to_ii, concti) sp=citoii l=osf$task_services_library tel=warning ..
      lmo=none lm=$null dm=off
*DECK DECK=RAM$CONVERT_DSSL_TO_TEXT EXPAND=TRUE
PROC convert_dssl_to_text, condtt(
  dual_state_source_library, dssl: file = $required
  text_file, tf: file = dssl_text
  target_operating_system, tos: key nos nosbe = nos
  status)

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"The purpose of this procedure is to convert the NOS/VE dual state source library into
"a nos multi-file text file. (There are three files on the multi-file.)
*IFEND

IF $specified(target_operating_system) THEN
  create_variable wev$target_operating_system kind=string scope=xdcl ..
        value=$string($value(target_operating_system))
ELSEIF $variable(wev$target_operating_system, declared) = 'NONLOCAL' THEN
  create_variable wev$target_operating_system kind=string scope=xref
ELSE
  create_variable wev$target_operating_system kind=string scope=xdcl ..
        value=$string($value(target_operating_system))
IFEND


  create_variable local_status k=status
  create_variable ignore_status k=status

  create_variable n=errors_file k=string v=$unique
  create_variable internal_text_file k=string v=$unique
  create_variable scratch_library k=string v=$unique

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"Create a nos deck header.
*IFEND

  put_line '/DECK,DUAL' o=$fname(internal_text_file//'.$boi')
  put_line '/WIDTH 255,0' o=$fname(internal_text_file//'.$eoi')

  SCU
  condtt_proc: ..
    BLOCK
      use_library $value(dual_state_source_library) r=$null status=local_status
      EXIT condtt_proc WHEN NOT local_status.normal

      set_list_options errors=$fname(errors_file)

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"The first entry in the multi-file file contains all of the ccl procedures which
"are to go onto nvelib.  Each procedure is separated by an EOR mark which
"is contained on the end of the deck.
*IFEND

      EXPAND_DECK d=none $fname(internal_text_file//'.$eoi') sc=$command status=local_status
        include_group (osf$nvelib ccl_procedures) all
        exclude_group deleted_decks status=ignore_status
      END
      EXIT condtt_proc WHEN NOT local_status.normal
      put_line '/WEOR,15' o=$fname(internal_text_file//'.$eoi')

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"The second entry in the multi-file file contains the compass and sympl modules which
"are to go onto nvelib (each language group is separated by an end-of-record mark; but
"there are no marks between individual modules); and the ccl procs which go onto nosbins.
"(There are end-of-record marks between each ccl proc module.)
*IFEND


      EXPAND_DECK d=none $fname(internal_text_file//'.$eoi') sc=$command status=local_status
        include_group (osf$nvelib cp_compass) all
        exclude_group deleted_decks status=ignore_status
      END
      EXIT condtt_proc WHEN NOT local_status.normal
      put_line '/WEOR,0' o=$fname(internal_text_file//'.$eoi')

      EXPAND_DECK d=none $fname(internal_text_file//'.$eoi') sc=$command status=local_status
        include_group (osf$nvelib sympl) all
        exclude_group deleted_decks status=ignore_status
      END
      EXIT condtt_proc WHEN NOT local_status.normal
      put_line '/WEOR,0' o=$fname(internal_text_file//'.$eoi')

      EXPAND_DECK d=none $fname(internal_text_file//'.$eoi') sc=$command status=local_status
        include_group (osf$nosbins ccl_procedures) all
        exclude_group deleted_decks status=ignore_status
      END
      EXIT condtt_proc WHEN NOT local_status.normal
      put_line '/WEOR,15' o=$fname(internal_text_file//'.$eoi')


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"The last entry on the multi-file file contains the compass modules which go onto
"nosbins, the compass and cybil modules which go onto nverels, the sympl modules
"(for FASLAVE) which go onto nverels and the FASLAVE compass modules.  Each language
"group is separated from the others by an end-of-record mark.  (The FASLAVE modules
"get special treatment because they require additional NOS interfaces when linking.
*IFEND

      EXPAND_DECK d=none $fname(internal_text_file//'.$eoi') sc=$command status=local_status
        include_group (osf$nosbins cp_compass) all
        exclude_group deleted_decks status=ignore_status
      END
      EXIT condtt_proc WHEN NOT local_status.normal
      put_line '/WEOR,0' o=$fname(internal_text_file//'.$eoi')

      EXPAND_DECK d=none $fname(internal_text_file//'.$eoi') sc=$command status=local_status
        include_group (osf$nverels cp_compass) all
        exclude_group deleted_decks status=ignore_status
      END
      EXIT condtt_proc WHEN NOT local_status.normal
      put_line '/WEOR,0' o=$fname(internal_text_file//'.$eoi')

      EXPAND_DECK d=none $fname(internal_text_file//'.$eoi') sc=$command status=local_status
        include_group (osf$nverels cybil_cc) all
        exclude_group deleted_decks status=ignore_status
      END
      EXIT condtt_proc WHEN NOT local_status.normal
      put_line '/WEOR,0' o=$fname(internal_text_file//'.$eoi')

      EXPAND_DECK d=none $fname(internal_text_file//'.$eoi') sc=$command status=local_status
        include_group sympl_modules
        exclude_group deleted_decks status=ignore_status
      END
      EXIT condtt_proc WHEN NOT local_status.normal
      put_line '/WEOR,0' o=$fname(internal_text_file//'.$eoi')

      EXPAND_DECK d=none $fname(internal_text_file//'.$eoi') sc=$command status=local_status
        include_group  compass_modules
        exclude_group deleted_decks status=ignore_status
      END
      EXIT condtt_proc WHEN NOT local_status.normal
      IF wev$target_operating_system='NOSBE' THEN
        put_line '/WEOR,0' o=$fname(internal_text_file//'.$eoi')

        EXPAND_DECK d=none $fname(internal_text_file//'.$eoi') sc=$command status=local_status
          include_group  fortran_cc
          exclude_group deleted_decks status=ignore_status
        END
        EXIT condtt_proc WHEN NOT local_status.normal
      IFEND
      put_line '/WEOR,15' o=$fname(internal_text_file//'.$eoi')

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"Change the /EOR seperators contained on the end of all ccl_procedures into /WEOR's
"which are needed for nos.
*IFEND

      EDIT_FILE $fname(internal_text_file) i=$command o=$null p=$null status=local_status
        replace_text '/EOR' '/WEOR,0' n=a l=a status=ignore_status
      end
    BLOCKEND condtt_proc
    include_line 'END false' status=ignore_status
"$COMMAND=END FORMAT=TRUE


  detach_file $fname(scratch_library) status=ignore_status
  IF local_status.normal THEN
    copy_file $fname(internal_text_file) $value(text_file) status=local_status
  ELSE
    copy_file f=$fname(errors_file) o=$response status=ignore_status
  IFEND
  detach_file $fname(internal_text_file) status=ignore_status
  detach_file $fname(errors_file) status=ignore_status
  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND convert_dssl_to_text
*DECK DECK=RAM$CONVERT_JOB_RECORD_TO_STRS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$CONVERT_JOB_RECORD_TO_STRS Interface.' ??
MODULE ram$convert_job_record_to_strs;

{ PURPOSE:
{   This module contains the interface to convert the job status record's
{   fields into strings for displaying.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rat$installation_control_record
*copyc rat$job_status_record_strs
?? POP ??
*copyc clp$convert_integer_to_string
*copyc clp$trimmed_string_size
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc rav$step_status
*copyc rav$step_title
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$convert_job_record_to_strs', EJECT ??

{ PURPOSE:
{   This interface converts the job status record's fields into strings for
{   displaying.  The converted string values are return in a record.
{
{ DESIGN:
{   A record with corresponding field names (but of type ost$string) is
{   used to hold the converted values from the job status record.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$convert_job_record_to_strs
    (    job_status_record: rat$job_status_record;
     VAR job_status_strings: rat$job_status_record_strs;
     VAR status: ost$status);


    VAR
      date: ost$date,
      time: ost$time;


    status.normal := TRUE;

    job_status_strings.job_identifier.size := clp$trimmed_string_size (job_status_record.job_identifier);
    job_status_strings.job_identifier.value := job_status_record.job_identifier;

    job_status_strings.log_file_name.size := clp$trimmed_string_size (job_status_record.log_file_name);
    job_status_strings.log_file_name.value := job_status_record.log_file_name;

    pmp$format_compact_date (job_status_record.date_time, osc$iso_date, date, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    job_status_strings.date.size := clp$trimmed_string_size (date.iso);
    job_status_strings.date.value := date.iso;

    pmp$format_compact_time (job_status_record.date_time, osc$millisecond_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    job_status_strings.time.size := clp$trimmed_string_size (time.millisecond);
    job_status_strings.time.value := time.millisecond;

    clp$convert_integer_to_string (job_status_record.number_of_steps, 10, FALSE,
          job_status_strings.number_of_steps, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (job_status_record.step_number, 10, FALSE,
          job_status_strings.step_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    job_status_strings.step.size := clp$trimmed_string_size (rav$step_title [job_status_record.step]);
    job_status_strings.step.value := rav$step_title [job_status_record.step];

    job_status_strings.step_status.size := clp$trimmed_string_size
          (rav$step_status [job_status_record.step_status]);
    job_status_strings.step_status.value := rav$step_status [job_status_record.step_status];

    clp$convert_integer_to_string (job_status_record.initial_subproduct_count, 10, FALSE,
          job_status_strings.initial_subproduct_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (job_status_record.started_subproduct_count, 10, FALSE,
          job_status_strings.started_subproduct_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (job_status_record.completed_subproduct_count, 10, FALSE,
          job_status_strings.completed_subproduct_count, status);

  PROCEND rap$convert_job_record_to_strs;
MODEND ram$convert_job_record_to_strs;
*DECK DECK=RAM$CONVERT_NETWORK_CONFIG_FILE EXPAND=TRUE
PROCEDURE convert_network_configuration (
  source_file, sf: file =  $system.network.configuration
  destination_file, df: file = $system.network.configuration.$next
  host_name, hn: string = $optional
  forward_search_range, fsr: integer = 4
  status)

  UTILITY convert_network_configuration
    command (define_channel_network, defcn) nap$define_channel_network
    command (define_host_network, defhn) nap$define_host_network
    command (define_network_connection, defnc) nap$define_network_connection
    command (define_network_access, defna) nap$define_network_access
    command (define_tcpip_host, defth) nap$define_tcpip_host
    command (quit, qui, end) nap$quit
    tablend

    "$FORMAT=OFF"
    VAR
      invalid_count : (utility) integer = 0
      invalid_list : (utility) array 1 .. 20  of string
      local_status : (utility)  status
      tcpip_host_defined : (utility) boolean = FALSE
      temp_file : (utility) file =  $unique($local)
    VAREND
    "$FORMAT=ON"

    WHEN exit DO
      delete_file temp_file status=local_status
      detach_file source_file status=local_status
    WHENEND

    attach_file file=source_file status=local_status
    IF NOT local_status.normal THEN
      EXIT procedure WITH local_status
    IFEND

    rewind_file file=source_file status=local_status
    IF NOT local_status.normal THEN
      EXIT procedure WITH local_status
    IFEND

    put_line ' Converting '//$string(source_file)//' to new format...' o=$response

    include_file source_file u=convert_network_configuration status=local_status
    IF NOT local_status.normal THEN
      EXIT procedure WITH local_status
    IFEND

    IF (NOT tcpip_host_defined) AND $specified(host_name) THEN
      put_line line=(' define_tcpip_host host_name='''//host_name//''' forward_search_range='//forward_search_range) ..
        o=temp_file.$eoi
    IFEND

    put_line ' Conversion complete.' o=$response

    IF invalid_count <> 0 THEN
      put_line ' Some network configuration commands could not be converted.'  o=$response
      put_line ' See the list at the end of the '//$string(destination_file)//' file' o=$response
      put_line ' for more details.'  o=$response

      put_line ' "' o=temp_file.$eoi
      put_line ' "   With the 1.5.1 NOS/VE release, ICA-I''s and ICA-II''s (running' o=temp_file.$eoi
      put_line ' "   in native mode) are not allowed.  If you wish to use  ICA-II''s in' o=temp_file.$eoi
      put_line ' "   OSI mode, they must be converted by hand. ' o=temp_file.$eoi
      put_line ' "' o=temp_file.$eoi
      put_line ' "   The following definitions must be converted by hand if they are to be used:' ..
            o=temp_file.$eoi

      FOR index = 1 TO invalid_count DO
        put_line ' "  '//invalid_list(index) o=temp_file.$eoi status=local_status
        IF NOT local_status.normal THEN
          EXIT procedure WITH local_status
        IFEND
      FOREND
    IFEND

    copf temp_file destination_file status=local_status
    IF NOT local_status.normal THEN
      EXIT procedure WITH local_status
    IFEND

    delete_file temp_file status=local_status
    detach_file source_file status=local_status

    include_command 'NAP$QUIT' ee=false

  UTILITYEND

PROCEND convert_network_configuration


PROCEDURE (HIDDEN) nap$define_channel_network (
  network, n: integer 1..0FFFFFFFF(16) = $required
  connected_system, cs: name = $required
  relays_restricted, rr: boolean = FALSE
  )

  put_line ' define_network_connection connected_system='//connected_system o=temp_file.$eoi

PROCEND nap$define_channel_network


PROCEDURE (HIDDEN) nap$define_host_network (
  network, n: integer 1..0FFFF(16) = $required
  )

  put_line ' define_host_network network=0'//$strrep(network, 16)//'(16)'    o=temp_file.$eoi

PROCEND nap$define_host_network


PROCEDURE (HIDDEN) nap$define_network_access (
  network, n: integer 1..0FFFF(16) = $required
  access, a: list of name = $required
  relays_restricted, rr: boolean = FALSE
  )

  invalid_count = invalid_count + 1
  invalid_list(invalid_count) = 'define_network_access network='//..
$strrep(network, 16)//'(16)  access='//access//' relays_restricted='//relays_restricted

PROCEND nap$define_network_access


PROCEDURE (HIDDEN) nap$define_network_connection (
  network, n: integer 1..0FFFF(16) = $optional
  connected_system, cs: name = $required
  system_identifier, si: integer 400101(16)..4FFFFF(16) = $optional
  )

  IF $specified(system_identifier) THEN
    put_line ' define_network_connection connected_system='//connected_system//' system_identifier='//..
$strrep(system_identifier, 16)//'(16)'  o=temp_file.$eoi
  ELSE
    put_line ' define_network_connection connected_system='//connected_system o=temp_file.$eoi
  IFEND

PROCEND nap$define_network_connection

PROCEDURE (HIDDEN) nap$define_tcpip_host (
  host_name, hn: string  = $required
  forward_search_range, fsr: integer = 4
  )

  put_line line=(' define_tcpip_host host_name='''//host_name//''' forward_search_range='//forward_search_range) ..
    o=temp_file.$eoi
  tcpip_host_defined = TRUE

PROCEND nap$define_tcpip_host

PROCEDURE (HIDDEN) nap$quit

  EXIT convert_network_configuration

PROCEND nap$quit

*DECK DECK=RAM$CONVERT_OBJECT_FILE EXPAND=TRUE
PROC convert_object_file, conof (
  to, t: file = $required
  from, f: name
  user, u: name
  status)

  create_variable check kind=status
  create_variable ignore kind=status
  create_variable scratch kind=string value=$unique
  create_variable from_file kind=string

  set_file_attributes $value(to) file_contents=object file_structure=data record_type=undefined

  IF $specified(from) THEN
    from_file = $string($value(from))
  ELSE
    from_file = $path($value(to) last)
  IFEND

  IF $specified(user) THEN
    get_file to=$fname(scratch) from=$name(from_file) data_conversion=b60 user=$value(user)
  ELSE
    get_file to=$fname(scratch) from=$name(from_file) data_conversion=b60
  IFEND

  convert_ci_to_ii $fname(scratch) $value(to) status=check

  detach_file $fname(scratch) status=ignore
  EXIT_PROC WITH check

PROCEND convert_object_file
*DECK DECK=RAM$CONVERT_PATH_TO_PF_FORMAT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'Module for RAP$CONVERT_PATH_TO_PF_FORMAT procedure.' ??
MODULE ram$convert_path_to_pf_format;

{ PURPOSE:
{   This compiled module contains the interface and procedure that
{   converts a catalog path to PF format.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$install_software_cc
*copyc rat$installation_control_record
?? POP ??
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pfp$convert_fs_path_to_pf_path
*copyc pfp$convert_string_to_fs_path


?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$convert_path_to_pf_format', EJECT ??

{ PURPOSE:
{   This procedure converts a catalog path string to PF format.
{
{ DESIGN:
{   Existing routines are called which convert from string to FS format,
{   and from FS format to PF format.  This routine simply combines these
{   steps into one process.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$convert_path_to_pf_format
    (    catalog_path: rat$path;
     VAR pf_destination_p: ^pft$path;
     VAR processing_seq_p: ^rat$processing_sequence;
     VAR status: ost$status);


    VAR
      fs_path: string (fsc$max_path_size),
      ignore_cycle_reference: fst$cycle_reference,
      ignore_cycle_selector: clt$cycle_selector,
      ignore_open_position: fst$open_position,
      number_of_elements: fst$number_of_path_elements;


    status.normal := TRUE;

    pfp$convert_string_to_fs_path (catalog_path.path (1, catalog_path.size), fs_path,
          number_of_elements, ignore_cycle_reference, ignore_open_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT pf_destination_p: [1 .. number_of_elements] IN processing_seq_p;
    IF pf_destination_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'PROCESSING SEQUENCE', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'PF CONVERSION PROCESS', status);
      RETURN;
    IFEND;

    pfp$convert_fs_path_to_pf_path (fs_path, pf_destination_p, ignore_cycle_reference, ignore_cycle_selector,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$convert_path_to_pf_format;

MODEND ram$convert_path_to_pf_format;

*DECK DECK=RAM$CONVERT_STATUS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$convert_status;

*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc cld$variable_reference
*copyc ost$status

?? POP ??

*copyc rah$convert_status
*copyc osp$status_condition_code

  PROCEDURE [XDCL, #GATE] rap$convert_status (clv$status: clt$status;
    VAR osv$status: ost$status);

    VAR
      identifier: ost$status_identifier;

    osv$status.normal := clv$status.normal.value;
    IF NOT osv$status.normal THEN
      IF (1 <= clv$status.identifier.size) AND (clv$status.identifier.size <= STRLENGTH
            (ost$status_identifier)) THEN
        identifier := clv$status.identifier.value (1, clv$status.identifier.size);
      ELSE
        identifier := '??';
      IFEND;
      osv$status.condition := osp$status_condition_code (identifier, clv$status.condition.
            value MOD (UPPERVALUE (osv$status.condition) + 1));
      osv$status.text := clv$status.text;
    IFEND;

  PROCEND rap$convert_status;
MODEND ram$convert_status
*DECK DECK=RAM$CONVERT_TO_OCTAL_BYTES EXPAND=TRUE
PROC convert_to_octal_bytes, convert_to_octal_byte, contb (
  input, i: string = $required
  result, r: var of string = $required
  status)

  crev blanks k=string v='            '
  crev hex_value k=(string,16)
  crev temp k=(string, 8)
  crev zeros k=string v='0000000000000000'

  hex_value = $strrep($integer($value(input)), 16)
  $value(result) = ''
  IF hex_value = '-1' THEN
    $value(result) = blanks
  ELSE
    IF $strlen(hex_value) < 16 THEN
      hex_value = $substr(zeros, 1, 16-$strlen(hex_value)) // hex_value
    IFEND
    FOR i = 0 TO 3 DO

" truncate hex to 3 characters preceded by a 0 to ensure proper form of hex num"
" leaving 12 bits for interpretation"
      temp = $strrep($integer('0'//$substr(hex_value, (4*i+2), 3)//'(16)'), 8)
      IF $strlen(temp) < 4 THEN
        $value(result) = $value(result) // $substr(blanks, 1, 4-$strlen(temp))..
               // temp
      ELSE "$strlen(temp) =  4 -- guaranteed by previous truncation above"
        $value(result) = $value(result) // temp
      IFEND
    FOREND
  IFEND
PROCEND convert_to_octal_bytes

*DECK DECK=RAM$COPY_PARTITION EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$copy_partition;

*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc amp$get_next
*copyc amp$put_next
*copyc amp$write_end_partition
*copyc rat$170_record_definitions

?? POP ??

*copyc rah$copy_partition

  PROCEDURE [XDCL, #GATE] rap$copy_partition (input_fid: amt$file_identifier;
        output_fid: amt$file_identifier;
    VAR file_position: amt$file_position;
        starting_input_record: boolean;
        starting_output_record: boolean;
    VAR status: ost$status);


    VAR
      ba: amt$file_byte_address,
      partition_descriptor: [STATIC] integer := rac$eor_170,
      tc: amt$transfer_count,
      temp_rec: rat$record_170;


    IF NOT starting_output_record THEN
      { This is not the 1st record on the output file. }
      amp$write_end_partition (output_fid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF starting_input_record THEN
        { A partition descriptor must be added. }
        amp$put_next (output_fid, ^partition_descriptor, #SIZE (partition_descriptor), ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    ELSEIF NOT starting_input_record THEN
      { Since this is the 1st record on the output file the partition descriptor must be removed. }
      amp$get_next (input_fid, ^temp_rec.buffer, #SIZE (temp_rec.buffer), tc, ba, file_position, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Continue copying record to output file. }

    IF (file_position <> amc$eop) AND (file_position <> amc$eoi) THEN
      amp$get_next (input_fid, ^temp_rec.buffer, #SIZE (temp_rec.buffer), tc, ba, file_position, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    WHILE (file_position <> amc$eop) AND (file_position <> amc$eoi) DO

      amp$put_next (output_fid, ^temp_rec.buffer, tc, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$get_next (input_fid, ^temp_rec.buffer, #SIZE (temp_rec.buffer), tc, ba, file_position, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    WHILEND;

  PROCEND rap$copy_partition;
MODEND ram$copy_partition
*DECK DECK=RAM$CORRECT_PRODUCTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$CORRECT_PRODUCTS Interface.' ??
MODULE ram$correct_products;

{ PURPOSE:
{   This module contains the interface and procedures that correct
{   a subproduct or subproducts during installation.
{
{ DESIGN:
{   Refer to design for validate for correction for a description of the
{   correction process.
{
{   The compiled module resides in RAF$LIBRARY.
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$installation_cycles
*copyc rae$install_software_cc
*copyc fst$number_of_path_elements
*copyc ost$caller_identifier
*copyc rat$element_paths
*copyc rat$installation_control_record
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$return
*copyc avp$ring_min
*copyc clp$convert_integer_to_string
*copyc clp$include_line
*copyc fsp$copy_file
*copyc ocp$apply_object_correction
*copyc osp$append_status_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pfp$change
*copyc pfp$define_catalog
*copyc pfp$find_directory_array
*copyc pfp$find_direct_info_record
*copyc pfp$find_next_info_record
*copyc pfp$find_permit_array
*copyc pfp$get_item_info
*copyc pfp$permit
*copyc pfp$permit_catalog
*copyc pfp$purge
*copyc pmp$get_unique_name
*copyc rap$checksum_file
*copyc rap$clear_installation
*copyc rap$convert_path_to_str
*copyc rap$get_cycle_data
*copyc rap$get_majority_file_class
*copyc rap$record_step_status
*copyc rap$record_subproduct_status
*copyc rmp$request_mass_storage
?? OLDTITLE, NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
?? OLDTITLE, NEWTITLE := '[XDCL] rap$correct_products', EJECT ??

{ PURPOSE:
{   This interface controls the step to apply subproduct corrections.
{
{ DESIGN:
{   The correct products step corrects all subproducts required for the
{   installation.  This occurs between the loading and staging steps.
{
{   This step follows standard step design.
{
{   The subproduct correction process is driven by the element list for
{   the correction.  The element list is processed by the standard
{   element list traversal algorithm.  The processing that occurs for
{   each element is based on the correction_directives, whether the
{   element is active or inactive and the installation_scheme for the
{   subproduct.
{
{   The corrections or replacement files were placed in the loading cycle
{   prior to executing this step.  When a correction has format of object
{   library, then the correction base is required to apply the
{   correction.  The base is located using the correction directives.
{   The corrected file is written to the staging cycle.  Since the
{   staging process expects files in the loading cycle only, the
{   correction is deleted and the corrected file is copied back to the
{   loading cycle.  When files are corrected by file replacement, no
{   correction base file is needed.
{
{   To improve the performance of the correction process, files are not
{   corrected if a previously corrected version of the file is available
{   on the system.  (This can be overridden by the user).  When a
{   previous correction is used, the processing needed is based on each
{   subproduct's correction installation scheme.  For cycle corrections,
{   it is only necessary to delete the correction file from the loading
{   cycle.  For version based, the correction file must be deleted and
{   the previously corrected file copied into the loading cycle so it can
{   be staged and activated later.
{
{   One twist of version based corrections, is that any file/catalog
{   which is not corrected for a subproduct, must have the released
{   version of the file brought forward into the new version catalog.
{
{   The inability to correct any file belonging to a subproduct will cause
{   the entire subproduct to fail the correction step.  The installation
{   processing record for that subproduct is set as such and the subproduct
{   will be cleared from the system at the conclusion of this step.
{
{   The failure of one subproduct does not jeopardize the remaining
{   subproducts.  Each subproduct is processed independently.
{
{   For certain portions of the correction process, it may be necessary
{   process files which are not readable at this job's current execution
{   ring.  To solve this, the file is copied to a $LOCAL.$UNIQUE file
{   for processing.  To ensure this file is returned in an abort situtation,
{   the file name is assigned once for the entire step and the file is
{   is returned by this step's abort handler.
{
{ NOTES:
{   The SUBPRODUCT_FAILED_PROCESSING boolean has been initialized outside of
{   this interface and should never be initialized here.
{

  PROCEDURE [XDCL] rap$correct_products
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR subproducts_failed_processing: boolean;
     VAR status: ost$status);

    VAR
      subproduct_index: rat$subproduct_count,
      ignore_keyword: ost$name,
      ignore_status: ost$status,
      local_status: ost$status,
      majority_file_class: rmt$mass_storage_class,
      processing_record: rat$subp_processing_record,
      scratch_file: rat$path,
      subproduct_paths: rat$element_paths,
      task_status: ost$status,
      unique_name: ost$name;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to return the temporary file
{   used by this interface in an abort situation.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF scratch_file.size <> 0 THEN
        amp$return (scratch_file.path (1, scratch_file.size), ignore_status);
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    IF NOT (rac$correct_subproducts_step IN installation_control_record.processing_header_p^.step_set) THEN
      RETURN;
    IFEND;

    rap$record_step_status (rac$correct_subproducts_step, rac$step_started, installation_control_record,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_unique_name (unique_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (scratch_file.path, scratch_file.size, ':$LOCAL.', unique_name);

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      FOR subproduct_index := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^)
            DO
        processing_record := installation_control_record.subproduct_processing_records_p^
              [subproduct_index];

        IF (installation_control_record.job_identifier = processing_record.job_identifier) AND
              (rac$correct_files_task IN processing_record.task_set) AND
              (processing_record.task_status <> rac$task_failed) THEN

          rap$record_subproduct_status (rac$correct_files_task, rac$task_started, subproduct_index,
                installation_control_record, ignore_status);

          rap$get_majority_file_class (subproduct_index, installation_control_record, ignore_keyword,
                majority_file_class, status);
          IF NOT status.normal THEN
            EXIT /main/;
          IFEND;

          task_status.normal := TRUE;

          establish_subproduct_paths (processing_record, installation_control_record.processing_seq_p,
                subproduct_paths);

          correct_subproduct (processing_record.subproduct_info_pointers.element_list_p, subproduct_paths,
                scratch_file, processing_record.subproduct_info_pointers.attributes_p^.installation_scheme,
                majority_file_class, installation_control_record.processing_header_p^.installation_defaults.
                ignore_storage_class, processing_record.subproduct_info_pointers.subproduct_info_seq_p,
                task_status);

          IF task_status.normal THEN
            rap$record_subproduct_status (rac$correct_files_task, rac$task_completed, subproduct_index,
                  installation_control_record, ignore_status);
          ELSE
            osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], task_status, ignore_status);
            rap$record_subproduct_status (rac$correct_files_task, rac$task_failed, subproduct_index,
                  installation_control_record, ignore_status);
            subproducts_failed_processing := TRUE;
          IFEND;

        IFEND;
      FOREND;

    END /main/;

    rap$clear_installation (installation_control_record, ignore_status);

    amp$return (scratch_file.path (1, scratch_file.size), ignore_status);

    osp$disestablish_cond_handler;

    rap$record_step_status (rac$correct_subproducts_step, rac$step_completed, installation_control_record,
          local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

  PROCEND rap$correct_products;

?? OLDTITLE, NEWTITLE := 'apply_object_correction', EJECT ??

{ PURPOSE:
{   This procedure applies a correction to an object library
{   and places the corrected file in the loading cycle on a device of the
{   majority storage class.
{
{ DESIGN:
{   The first requirement is to prepare the correction base file.  This
{   involves getting the path to where the file resides and possibly updating
{   the correction bases catalog.
{
{   Since the loading cycle is already occupied by the files' correction, the
{   corrected file must be written temporarily to the staging cycle.  The
{   loading cycle is then deleted, and the corrected file is put in the loading
{   cycle in the majority storage class that was used for the subproduct load.
{
{ NOTES:
{   When moving the corrected file from the staging cycle to the loading cycle,
{   it must be copied since we do not know what storage class the correction
{   was created on.

  PROCEDURE apply_object_correction
    (    element_p: ^rat$element;
         element_paths: rat$element_paths;
         scratch_file: rat$path;
         majority_file_class: rmt$mass_storage_class;
         installation_scheme: rat$installation_scheme;
         ignore_storage_class: boolean;
     VAR status: ost$status);


    VAR
      base_file: rat$path,
      corrected_file: rat$path,
      correction_base_catalog_updated: boolean,
      cycle_selector: pft$cycle_selector,
      ignore_status: ost$status,
      password: pft$password,
      patch_file: rat$path,
      staging_cycle: array [1 .. 1] of pft$change_descriptor;


    status.normal := TRUE;

    password := ' ';
    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := rac$loading_cycle;

    prepare_correction_base_file (element_p, installation_scheme,
          element_paths [rac$correction_base_cat_path]^, element_paths [rac$base_level_path]^, scratch_file,
          base_file, correction_base_catalog_updated, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$convert_path_to_str (element_paths [rac$installation_catalog_path]^, patch_file);
    STRINGREP (corrected_file.path, corrected_file.size, patch_file.path (1, patch_file.size), '.',
          rac$staging_cycle_str);
    STRINGREP (patch_file.path, patch_file.size, patch_file.path (1, patch_file.size),
          '.', rac$loading_cycle_str);

    ocp$apply_object_correction (base_file.path (1, base_file.size),
          patch_file.path (1, patch_file.size), corrected_file.path (1, corrected_file.size),
          status);
    IF NOT status.normal THEN
      IF (status.condition = rae$corr_base_checksum_mismatch) THEN
        IF (correction_base_catalog_updated) THEN
          { Get rid of bad file in the correction bases catalog.
          cycle_selector.cycle_option := pfc$lowest_cycle;
          pfp$purge (element_paths [rac$correction_base_cat_path]^, cycle_selector, password, ignore_status);
        IFEND;
        IF base_file.path (1, base_file.size) = scratch_file.path (1, scratch_file.size) THEN
          { The scratch file was used as the base, reformat message to show actual path.  This occurs
          { only for version based corrections where the base file is not readable at the current ring.
          osp$set_status_abnormal ('RA', rae$corr_base_checksum_mismatch, '', status);
          osp$append_status_file (osc$status_parameter_delimiter, base_file.path(1, base_file.size),
                status);
        IFEND;
      IFEND;
      RETURN;
    IFEND;

    IF base_file.path (1, base_file.size) =
          scratch_file.path (1, scratch_file.size) THEN
      amp$return (scratch_file.path (1, scratch_file.size), ignore_status);
    IFEND;

    { Purge the correction in the loading cycle.

    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := rac$loading_cycle;
    pfp$purge (element_paths [rac$installation_catalog_path]^, cycle_selector, password, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Move the file from the staging cycle to the loading cycle with the correct storage class.
    { The patch file is in the loading cycle.

    copy_file (corrected_file, patch_file, majority_file_class, ignore_storage_class, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Purge the original corrected file from the staging cycle.

    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := rac$staging_cycle;
    pfp$purge (element_paths [rac$installation_catalog_path]^, cycle_selector, password, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND apply_object_correction;

?? OLDTITLE, NEWTITLE := 'copy_file_at_any_ring', EJECT ??

{ PURPOSE:
{   This procedure copies a file to another file, tasking down if
{   user's nominal ring is not in the read bracket of base file.
{   The target file is given ring attributes of the user's nominal ring.
{
{ DESIGN:
{   Since the ring attributes of the base file may prevent it from from
{   being read at this job's current execution ring, we may have to task
{   down to perform the copy.  If this is needed, some SCL commands are
{   "included" which will task down, copy the file, and change its ring
{   attributes to match the current job's nominal ring.
{
{ NOTES:
{   The code in this procedure which gets ring information could/should
{   be put into a procedure which receives a file path and returns
{   parameters indicating the user's current ring, and the read ring for
{   the file.  This would elimimate duplicate code in this routine
{   and GET_PATH_TO_READ_FILE.
{

  PROCEDURE copy_file_at_any_ring
    (    base_file_read_ring: ost$valid_ring;
         base_file: rat$path;
         target_file: rat$path;
     VAR status: ost$status);


    VAR
      base_file_read_ring_str: ost$string,
      caller_id: ost$caller_identifier,
      command_line: string (2500),           {3*512 per path plus extra}
      command_line_length: integer,
      executing_ring_str: ost$string;


    status.normal := TRUE;

    clp$convert_integer_to_string (base_file_read_ring, 10, FALSE, base_file_read_ring_str, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    #CALLER_ID (caller_id);
    clp$convert_integer_to_string (caller_id.ring, 10, FALSE, executing_ring_str, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Collect the SCL commands required to task down and copy the base file to the target file.

?? FMT (FORMAT := OFF) ??
    STRINGREP (command_line, command_line_length,
          'task r=', base_file_read_ring_str.value (1, base_file_read_ring_str.size), '; ',
          '  $system.copy_file i=', base_file.path (1, base_file.size),
                   ' o=', target_file.path (1, target_file.size), '; ',
          '  $system.change_file_attributes f=', target_file.path (1, target_file.size),
                   ' ra=', executing_ring_str.value (1, executing_ring_str.size), '; ',
          'taskend');
?? FMT (FORMAT := ON) ??

    clp$include_line (command_line (1, command_line_length), TRUE, osc$null_name, status);

  PROCEND copy_file_at_any_ring;

?? OLDTITLE, NEWTITLE := 'copy_file', EJECT ??

{ PURPOSE:
{   This procedure copies a permanent file to another permanent file
{   placing the file on the requested storage class.
{
{ DESIGN:
{   Copy the base file to the target file, using the mass storage class
{   parameters when determining what device to write the target file.
{   Call another procedure to perform the file copy.  It will
{   take ring attributes into consideration.
{
{ NOTES:
{   If there was a way to know if the desired storage class was
{   also the default, this code would not need to
{   do request_mass_storage every time.
{

  PROCEDURE copy_file
    (    base_file: rat$path;
         target_file: rat$path;
         storage_class: rmt$mass_storage_class;
         ignore_storage_class: boolean;
     VAR status: ost$status);


    VAR
      base_file_read_ring: ost$valid_ring,
      readable_at_executing_ring: boolean,
      return_status: ost$status;


    status.normal := TRUE;

    rmp$request_mass_storage (target_file.path (1, target_file.size), rmc$unspecified_allocation_size,
          rmc$unspecified_file_size, storage_class, rmc$unspecified_vsn, TRUE, status);
    IF (NOT status.normal) AND (NOT ignore_storage_class) THEN
      RETURN;
    IFEND;

    get_file_read_ring (base_file, readable_at_executing_ring, base_file_read_ring, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF readable_at_executing_ring THEN
      fsp$copy_file (base_file.path (1, base_file.size), target_file.path (1, target_file.size),
            NIL, NIL, NIL, status);
    ELSE
      copy_file_at_any_ring (base_file_read_ring, base_file, target_file, status);
    IFEND;
    { Don't return until amp$return is performed.

    amp$return (target_file.path (1, target_file.size), return_status);
    IF (status.normal) AND (NOT return_status.normal) AND (NOT ignore_storage_class) THEN
      status := return_status;
    IFEND;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND copy_file;

?? OLDTITLE, NEWTITLE := 'correct_file', EJECT ??

{ PURPOSE:
{   This procedure corrects a file if it needs to be corrected.
{
{ DESIGN:
{   This procedure uses the correction_directives for the file and
{   installation_scheme for the subproduct to determine how to correct
{   the file.
{
{   1) If using a previous correction then call a procedure to delete
{      the correction from the loading cycle.  If the installation scheme
{      is version based, copy the previously corrected file from the
{      active level catalog to the loading cycle.  Verify the checksum of
{      the file.
{
{   2) If using a released file (only occurs for version based corrections),
{      copy the file from the base level catalog.  No validation takes place.
{
{   3) If correcting the file, call a procedure to pply the correction
{      and write the corrected file to the staging cycle, delete the
{      correction in the loading cycle and do a change_catalog_entry to
{      put the corrected file in the loading cycle.  If the base was
{      located in the base level catalog and the correction installation
{      scheme is cycle based, copy the correction base file to the
{      correction_base catalog.
{
{   4) If a file is being replaced, no processing is necessary.
{
{   All files which are left in the loading cycle will be in the
{   majority storage class in order for them to be processed
{   properly during staging.
{
{ NOTES:
{   The subcatalog the files will be written into has been created by
{   correct_subproduct.

  PROCEDURE correct_file
    (    element_p: ^rat$element;
         element_paths: rat$element_paths;
         scratch_file: rat$path;
         installation_scheme: rat$installation_scheme;
         majority_file_class: rmt$mass_storage_class;
         ignore_storage_class: boolean;
     VAR status: ost$status);

    VAR
      file: rat$path,
      release_file: rat$path;

    status.normal := TRUE;

    IF rac$use_previous_correction IN element_p^.correction_directives THEN

      process_previous_correction (element_p, element_paths [rac$installation_catalog_path]^,
            element_paths [rac$active_level_path]^, scratch_file, installation_scheme, majority_file_class,
            ignore_storage_class, status);

    ELSEIF rac$use_release_file IN element_p^.correction_directives THEN

      { True when moving forward uncorrected file in version based subproduct.
      rap$convert_path_to_str (element_paths [rac$base_level_path]^, release_file);
      rap$convert_path_to_str (element_paths [rac$installation_catalog_path]^, file);
      STRINGREP( file.path, file.size, file.path(1, file.size), '.', rac$loading_cycle_str);
      copy_file (release_file, file, majority_file_class, ignore_storage_class, status);

    ELSEIF (rac$use_base_level_catalog IN element_p^.correction_directives) OR
          (rac$use_correction_base_catalog IN element_p^.correction_directives) THEN

      IF element_p^.correction_format = rac$object_library THEN
        apply_object_correction (element_p, element_paths, scratch_file, majority_file_class,
              installation_scheme, ignore_storage_class, status);
      ELSEIF element_p^.correction_format = rac$source_library THEN
        { Do nothing.  Source libraries currently corrected by file replacement.
      ELSE { element_p^.correction_format = rac$replacement }
        { Do nothing.
      IFEND;

    IFEND;

  PROCEND correct_file;

?? OLDTITLE, NEWTITLE := 'correct_subproduct', EJECT ??

{ PURPOSE:
{   This procedure corrects the files belonging to a subproduct.
{
{ DESIGN:
{   Traverse the element list using the standard element list traversal
{   algorithm.
{
{   First, update the array of paths (by making a new array) to represent
{   the current catalog.  Then, process each file and subcatalog in the
{   current catalog.  For a version based correction, attempt to create each
{   subcatalog found since it may not have been created during the loading
{   step when corrections were restored.
{
{ NOTES:
{   This procedure does not distinguish between active and inactive elements
{   as is the case in all other steps.
{

  PROCEDURE correct_subproduct
    (    element_p: ^rat$element;
         element_paths: rat$element_paths;
         scratch_file: rat$path;
         installation_scheme: rat$installation_scheme;
         majority_file_class: rmt$mass_storage_class;
         ignore_storage_class: boolean;
         subproduct_info_seq_p: ^rat$subproduct_info_sequence;
     VAR status: ost$status);


    VAR
      current_element_p: ^rat$element,
      current_element_paths: rat$element_paths,
      first_element_down_p: ^rat$element,
      i: integer,
      ignore_status: ost$status,
      path_index: rat$installation_paths;

    status.normal := TRUE;

    { Create a new array of PF paths which contains path's one larger than
    { each of the path arrays in ELEMENT_PATHS and initialize each path.
    { This array will be used to construct the PF
    { paths for the files and subcatalogs that reside in the current catalog.

    FOR path_index := LOWERBOUND (element_paths) TO UPPERBOUND (element_paths) DO
      IF element_paths [path_index] <> NIL THEN
        PUSH current_element_paths [path_index]: [1 .. UPPERBOUND (element_paths [path_index]^) + 1];
        FOR i := 1 TO UPPERBOUND (element_paths [path_index]^) DO
          current_element_paths [path_index]^ [i] := element_paths [path_index]^ [i];
        FOREND;
      ELSE
        current_element_paths [path_index] := NIL;
      IFEND;
    FOREND;

    { Process the files and subcatalogs at the current catalog level.

    current_element_p := element_p;

    WHILE current_element_p <> NIL DO

      { Add current element name to end of each path.

      FOR path_index := LOWERBOUND (current_element_paths) TO UPPERBOUND (current_element_paths) DO
        IF current_element_paths [path_index] <> NIL THEN
          current_element_paths [path_index]^ [UPPERBOUND (current_element_paths [path_index]^)] :=
                current_element_p^.name;
        IFEND;
      FOREND;

      IF current_element_p^.element_type = rac$file THEN

        correct_file (current_element_p, current_element_paths, scratch_file, installation_scheme,
              majority_file_class, ignore_storage_class, status);

      ELSE {current_element_p^.element_type = rac$catalog}

        IF installation_scheme = rac$version_based THEN
          pfp$define_catalog (current_element_paths [rac$installation_catalog_path]^, ignore_status);
        IFEND;

        IF current_element_p^.element_count <> 0 THEN
          first_element_down_p := #PTR (current_element_p^.first_element_down_p, subproduct_info_seq_p^);

          correct_subproduct (first_element_down_p, current_element_paths, scratch_file, installation_scheme,
                majority_file_class, ignore_storage_class, subproduct_info_seq_p, status);
        IFEND;

      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      current_element_p := #PTR (current_element_p^.next_element_across_p, subproduct_info_seq_p^);
    WHILEND;

  PROCEND correct_subproduct;

?? OLDTITLE, NEWTITLE := 'create_correction_base_cat_path', EJECT ??

{ PURPOSE:
{   This procedure creates all the subcatalogs necessary to write a file into
{   the correction bases catalog.
{
{ DESIGN:
{   The parameter to this procedure is the file which will be written into the
{   catalog.  This procedure will create all the subcatalogs necessary to
{   copy the file.
{
{ NOTES:
{   This code is a derivative 'prepare_loading_destination' in the LOAD_PRODUCTS
{   step of INSTALL_SOFTWARE.  Perhaps these could be consolidated.
{

  PROCEDURE create_correction_base_cat_path
    (    file_path: pft$path;
     VAR status: ost$status);


    CONST
      file_name = 1, {The number of elements that file name portion of the full path occupies. }
      first_subcatalog = 1,
      family_user_catalogs = 2; { The number of elements that makeup the family and user catalogs. }

    VAR
      destination_path_p: ^pft$path,
      ignore_status: ost$status,
      number_of_subcatalogs: fst$number_of_path_elements,
      path_sequence_p: ^SEQ ( * ),
      subcatalogs: integer;


    status.normal := TRUE;

    PUSH path_sequence_p: [[REP #SIZE (file_path) OF cell]];
    RESET path_sequence_p;
    NEXT destination_path_p: [1 .. UPPERBOUND (file_path)] IN path_sequence_p;
    destination_path_p^ := file_path;

    number_of_subcatalogs := UPPERBOUND (destination_path_p^) - family_user_catalogs - file_name;

    FOR subcatalogs := first_subcatalog TO number_of_subcatalogs DO

      RESET path_sequence_p;
      NEXT destination_path_p: [1 .. family_user_catalogs + subcatalogs] IN path_sequence_p;

      pfp$define_catalog (destination_path_p^, ignore_status);

    FOREND;

  PROCEND create_correction_base_cat_path;

?? OLDTITLE, NEWTITLE := 'establish_subproduct_paths', EJECT ??

{ PURPOSE:
{   Establishes absolute pointers to the path's for this subproduct.
{ DESIGN:

  PROCEDURE establish_subproduct_paths
    (    processing_record: rat$subp_processing_record;
         processing_seq_p: ^rat$processing_sequence;
     VAR subproduct_paths: rat$element_paths);


    subproduct_paths [rac$installation_catalog_path] := #PTR (processing_record.installation_catalog_rel_p,
          processing_seq_p^);
    subproduct_paths [rac$correction_base_cat_path] := #PTR (processing_record.correction_base_catalog_rel_p,
          processing_seq_p^);
    subproduct_paths [rac$base_level_path] := #PTR (processing_record.base_level_catalog_rel_p,
          processing_seq_p^);
    IF processing_record.active_level_catalog_rel_p <> NIL THEN
      subproduct_paths [rac$active_level_path] := #PTR (processing_record.active_level_catalog_rel_p,
            processing_seq_p^);
    ELSE
      subproduct_paths [rac$active_level_path] := NIL;
    IFEND;

  PROCEND establish_subproduct_paths;

?? OLDTITLE, NEWTITLE := 'get_path_to_read_file', EJECT ??

{ PURPOSE:
{   This procedure returns a path at which a file can be read.  If necessary
{   the file will be copied to a scratch file with ring attribute set
{   at the currently executing ring.
{
{ DESIGN:

  PROCEDURE get_path_to_read_file
    (    desired_file: rat$path;
         scratch_file: rat$path;
     VAR readable_file: rat$path;
     VAR status: ost$status);


    VAR
      file_read_ring: ost$valid_ring,
      readable_at_executing_ring: boolean;


    status.normal := TRUE;

    get_file_read_ring (desired_file, readable_at_executing_ring, file_read_ring, status);

    IF readable_at_executing_ring THEN
      readable_file := desired_file;
    ELSE
      readable_file := scratch_file;
      copy_file_at_any_ring (file_read_ring, desired_file, readable_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND get_path_to_read_file;

?? OLDTITLE, NEWTITLE := 'get_file_read_ring', EJECT ??

{ PURPOSE:
{   This procedure determines whether or not a file is readable at the ring
{   currently executing in.  A boolean and the value of the read ring are
{   returned.
{
{ DESIGN:
{

  PROCEDURE get_file_read_ring
    (    file: rat$path;
     VAR readable_at_executing_ring: boolean;
     VAR file_read_ring: ost$valid_ring;
     VAR status: ost$status);


    VAR
      caller_id: ost$caller_identifier,
      file_attribute: array [1 .. 1] of amt$get_item,
      ignore_existing_file: boolean,
      ignore_contains_data: boolean,
      ignore_local_file: boolean;


    status.normal := TRUE;
    file_attribute [1].key := amc$ring_attributes;

    amp$get_file_attributes (file.path (1, file.size), file_attribute, ignore_local_file,
          ignore_existing_file, ignore_contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    #CALLER_ID (caller_id);

    readable_at_executing_ring := (caller_id.ring <= file_attribute [1].ring_attributes.r2);

    file_read_ring := file_attribute [1].ring_attributes.r2;

  PROCEND get_file_read_ring;

?? OLDTITLE, NEWTITLE := 'prepare_correction_base_file', EJECT ??

{ PURPOSE:
{   This procedure prepares the file to be used as the basis for a
{   correction, ie.  place it in the correction base catalog if needed,
{   or copy it to a local file which can be read in the job's current
{   execution ring.  It returns the path to the file which will be used
{   as the correction base.
{
{ DESIGN:
{   If we must get the base file from the base level catalog then copy
{   it to the correction base catalog.  Put the file on a class M device
{   to conserve system critical file space.
{
{   If the base file need not be copied to the correction base catalog (which
{   is the case for version based corrections), and the file is not readable in
{   the job's current ring, copy the file to a $local.$unique file.
{
{ NOTES:
{   When the file is copied to the $local catalog, it is the applier's
{   responsibility to return the file. The file will also be returned by this
{   step's abort handler.
{

  PROCEDURE prepare_correction_base_file
    (    element_p: ^rat$element;
         installation_scheme: rat$installation_scheme;
         correction_base_catalog_file: pft$path;
         base_level_file: pft$path;
         scratch_file: rat$path;
     VAR base_file: rat$path;
     VAR correction_base_catalog_updated: boolean;
     VAR status: ost$status);

    VAR
      actual_checksum: rat$checksum,
      base_file_string: rat$path,
      file_path_to_display: rat$path;

    status.normal := TRUE;

    correction_base_catalog_updated := FALSE;

    IF rac$use_correction_base_catalog IN element_p^.correction_directives THEN

      rap$convert_path_to_str (correction_base_catalog_file, base_file);

    ELSE {rac$use_base_level_catalog IN element_p^.correction_directives}

      IF installation_scheme = rac$cycle_based THEN

        { A copy of the base file will be placed in the correction base catalog
        { for future corrections.

        create_correction_base_cat_path (correction_base_catalog_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        rap$convert_path_to_str (correction_base_catalog_file, base_file);
        rap$convert_path_to_str (base_level_file, base_file_string);
        copy_file (base_file_string, base_file, rmc$msc_product_files,
              TRUE { ignore storage class errors } , status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        correction_base_catalog_updated := TRUE;

      ELSE { installation scheme = rac$version_based }

        { Guarentee the base file is readable at executing ring.  This
        { may require moving the file to a local copy.

        rap$convert_path_to_str (base_level_file, base_file_string);
        get_path_to_read_file (base_file_string, scratch_file, base_file, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

  PROCEND prepare_correction_base_file;

?? OLDTITLE, NEWTITLE := 'process_previous_correction', EJECT ??

{ PURPOSE:
{   Validate that that the previous correction file does in fact have the
{   correct contents, copy this file to the loading cycle for a version
{   based correction and get rid of the correction file which was loaded.
{
{ DESIGN:
{   Delete the correction from the loading cycle.
{
{   For a version based correction, call a procedure to copy the previously
{   corrected file to the loading cycle.
{
{   For a cycle based correction, call a procedure to "compute" a path to
{   read the previously corrected file.  (If the file is not readable
{   (due to rings) where it is, it is copied to a local scratch file, the
{   path where the file can be read is returned by the procedure.)
{
{   Checksum the file.  If it doesn't match, delete the file from the loading
{   cycle if it had been copied there and return bad status.
{
{ NOTES:
{

  PROCEDURE process_previous_correction
    (    element_p: ^rat$element;
         file_path: pft$path;
         previously_corrected_path: pft$path;
         scratch_file: rat$path;
         installation_scheme: rat$installation_scheme;
         majority_file_class: rmt$mass_storage_class;
         ignore_storage_class: boolean;
     VAR status: ost$status);

    VAR
      actual_checksum: integer,
      cycle_selector: pft$cycle_selector,
      file_to_checksum: rat$path,
      ignore_status: ost$status,
      password: pft$password,
      previously_corrected_file: rat$path;

    status.normal := TRUE;

    password := ' ';
    cycle_selector.cycle_option := pfc$specific_cycle;
    cycle_selector.cycle_number := rac$loading_cycle;

    { Get rid of correction in the loading cycle.

    pfp$purge (file_path, cycle_selector, password, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$convert_path_to_str (previously_corrected_path, previously_corrected_file);

    IF installation_scheme = rac$version_based THEN
      rap$convert_path_to_str (file_path, file_to_checksum);
      STRINGREP(file_to_checksum.path, file_to_checksum.size, file_to_checksum.path(1, file_to_checksum.size),
            '.', rac$loading_cycle_str );
      copy_file (previously_corrected_file, file_to_checksum, majority_file_class,
            ignore_storage_class, status);
    ELSE { cycle based }
      get_path_to_read_file (previously_corrected_file, scratch_file, file_to_checksum, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$checksum_file (file_to_checksum.path (1, file_to_checksum.size), actual_checksum, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF file_to_checksum.path (1, file_to_checksum.size) = scratch_file.path (1, scratch_file.size) THEN
      amp$return (scratch_file.path (1, scratch_file.size), ignore_status);
    IFEND;

    IF actual_checksum <> element_p^.pre_genc_contents_checksum THEN
      IF installation_scheme = rac$version_based THEN
        { File was copied into the loading cycle, delete it.
        pfp$purge (file_path, cycle_selector, password, ignore_status);
      IFEND;
      { Set status abnormal, subproduct must be installed with override.
      osp$set_status_abnormal ('RA', rae$prev_corr_checksum_mismatch, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, previously_corrected_file.path
            (1, previously_corrected_file.size), status);
      RETURN;
    IFEND;

  PROCEND process_previous_correction;

MODEND ram$correct_products;
*DECK DECK=RAM$CORRECT_SOURCE_LIBRARY EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE ram$correct_source_library;
?? PUSH (LISTEXT := ON) ??
*copyc rac$status_id
*copyc rae$error_messages
*copyc rat$deck_index
*copyc rat$write_scl_commands
*copyc rat$source_lib_correction_hdr
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc amp$return
*copyc clp$get_path_description
*copyc clp$scan_command_line
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$set_status_abnormal
*copyc pfp$permit
*copyc pfp$delete_permit
*copyc pmp$get_unique_name
*copyc pmp$get_user_identification
?? POP ??

*copyc rah$correct_source_library

  PROCEDURE [XDCL] rap$correct_source_library (base_file: clt$file;
        target_file: clt$file;
        p_correction: ^SEQ ( * );
    VAR status: ost$status);

    VAR
      application_info: pft$application_info,
      attribute: array [1 .. 1] of fst$file_cycle_attribute,
      ba: amt$file_byte_address,
      base_container: clt$path_container,
      base_file_ref: clt$file_reference,
      base_path: ^pft$path,
      command: ^array [1 .. * ] of rat$write_scl_commands,
      command_fid: amt$file_identifier,
      command_file: ost$name,
      correction: ^SEQ ( * ),
      correction_header: ^rat$source_lib_correction_hdr,
      cycle_sel: clt$cycle_selector,
      delete_decks: ^array [1 .. * ] of ost$name,
      group: pft$group,
      i: rat$deck_index,
      identification: ost$user_identification,
      ignore_status: ost$status,
      insert_decks: ^array [1 .. * ] of ost$name,
      j: rat$deck_index,
      number_of_commands: rat$deck_index,
      open_p: clt$open_position,
      permit_selections: pft$permit_selections,
      permit_status: ost$status,
      replace: amt$segment_pointer,
      replacement: ^SEQ ( * ),
      repl_fid: amt$file_identifier,
      repl_sl: ost$name,
      share_requirements: pft$share_requirements,
      size: integer,
      sl_replacement: ^SEQ ( * ),
      target_container: clt$path_container,
      target_file_ref: clt$file_reference,
      target_path: ^pft$path,
      text: string (osc$max_string_size),
      write_attachment: array [1 .. 2] of fst$attachment_option;

    correction := p_correction;

    pmp$get_unique_name (command_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    write_attachment [1].selector := fsc$access_and_share_modes;
    write_attachment [1].access_modes.selector := fsc$specific_access_modes;
    write_attachment [1].access_modes.value := $fst$file_access_options [fsc$read, fsc$shorten, fsc$append,
          fsc$modify];
    write_attachment [1].share_modes.selector := fsc$determine_from_access_modes;
    write_attachment [2].selector := fsc$create_file;
    write_attachment [2].create_file := TRUE;

    fsp$open_file (command_file, amc$record, ^write_attachment, NIL, NIL, NIL, NIL, command_fid,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_path_description (base_file, base_file_ref, base_container, base_path, cycle_sel, open_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_path_description (target_file, target_file_ref, target_container, target_path, cycle_sel, open_p,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT correction_header IN correction;
    IF correction_header = NIL THEN
      osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, 'CORRECTION FILE', status);
      RETURN;
    IFEND;
    number_of_commands := correction_header^.decks_to_delete + correction_header^.decks_to_insert + 7;
    PUSH command: [1 .. number_of_commands];
    STRINGREP (command^ [1].command, command^ [1].size, ' scu');
    STRINGREP (command^ [2].command, command^ [2].size, ' use_library b=', base_file_ref.path_name (1,
          base_file_ref.path_name_size), ' r=', target_file_ref.path_name (1, target_file_ref.
          path_name_size));
    j := 3;
    IF correction_header^.decks_to_delete > 0 THEN
      NEXT delete_decks: [1 .. correction_header^.decks_to_delete] IN correction;
      IF delete_decks = NIL THEN
        osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, 'CORRECTION FILE', status);
        RETURN;
      IFEND;
      FOR i := 1 TO correction_header^.decks_to_delete DO
        STRINGREP (command^ [j].command, command^ [j].size, '   delete_deck ', delete_decks^ [i]);
        j := j + 1;
      FOREND;
    IFEND;

    IF correction_header^.decks_to_insert > 0 THEN
      NEXT insert_decks: [1 .. correction_header^.decks_to_insert] IN correction;
      IF insert_decks = NIL THEN
        osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, 'CORRECTION FILE', status);
        RETURN;
      IFEND;
      FOR i := 1 TO correction_header^.decks_to_insert DO
        STRINGREP (command^ [j].command, command^ [j].size, '   create_deck d=', insert_decks^ [i],
          ' m=dummmy');
        j := j + 1;
      FOREND;
    IFEND;

    IF correction_header^.size_of_replacement > 0 THEN
      NEXT replacement: [[REP correction_header^.size_of_replacement OF cell]] IN correction;
      IF replacement = NIL THEN
        osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, 'CORRECTION FILE', status);
        RETURN;
      IFEND;

      pmp$get_unique_name (repl_sl, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      attribute [1].selector := fsc$file_contents_and_processor;
      attribute [1].file_contents := fsc$legible_library;
      attribute [1].file_processor := fsc$scu;

      fsp$open_file (repl_sl, amc$segment, ^write_attachment, ^attribute, NIL, NIL, NIL, repl_fid,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$get_segment_pointer (repl_fid, amc$sequence_pointer, replace, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      NEXT sl_replacement: [[REP correction_header^.size_of_replacement OF cell]] IN replace.sequence_pointer;
      IF sl_replacement = NIL THEN
        osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, repl_sl, status);
        RETURN;
      IFEND;

      sl_replacement^ := replacement^;

      fsp$close_file (repl_fid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (command^ [j].command, command^ [j].size, '   replace_libraries ', repl_sl);
      j := j + 1;
    IFEND;
    STRINGREP (command^ [j].command, command^ [j].size, ' quit yes');


    number_of_commands := j;
    FOR i := 1 TO number_of_commands DO
      amp$put_next (command_fid, ^command^ [i].command, command^ [i].size, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    fsp$close_file (command_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


{    In order to successfully run SCU a permit must be built giving the user all authority }
{  on access mode and an application information value of 'I4'.                            }
{    The permit is deleted as soon as possible.  The source library used is from the       }
{  installation catalog and so the assumption that a permit does'nt already exist can      }
{  be made. }


    pmp$get_user_identification (identification, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    group.group_type := pfc$user;
    group.user_description.family := identification.family;
    group.user_description.user := identification.user;

    application_info := 'I4';
    permit_selections := $pft$permit_selections [pfc$read, pfc$shorten, pfc$append, pfc$modify, pfc$execute,
          pfc$cycle, pfc$control];
    share_requirements := $pft$share_requirements [];

    pfp$permit (base_path^, group, permit_selections, share_requirements, application_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (text, size, ' include_file f=', command_file);
    clp$scan_command_line (text (1, size), status);
    pfp$delete_permit (base_path^, group, permit_status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT permit_status.normal THEN
      status := permit_status;
      RETURN;
    IFEND;

    amp$return (command_file, ignore_status);
    amp$return (repl_sl, ignore_status);

  PROCEND rap$correct_source_library;
MODEND ram$correct_source_library;
*DECK DECK=RAM$CREATE_CDCNET_CONFIG_PROCS EXPAND=TRUE
PROCEDURE create_cdcnet_config_procs (
)

" This procedure allows the user to create the initial configuration
" for a CDCNET device.

  "$FORMAT=OFF
  VAR
    choice: string
    cr_requested: string
    local_status: status
  VAREND
  "$FORMAT=ON"

" Menu data variables. "

  "$FORMAT=OFF
  VAR
    device_type: string = ''
    di_procedure_file: string = '$local.'//$unique
    ethernet_id: string = ''
    system_id: string = ''
    ve_interface_network_id: string = ''
  VAREND
  "$FORMAT=ON

main_loop: ..
  LOOP

"$ format=off
    put_line (..
     '1Create Configuration Procedures for CDCNET Devices (MDI, MTI, TDI, ' ..
     '    and ICA-II)'..
     '01. Type of CDCNET device ............... '//device_type..
     ' 2. CDCNET device System Identifier ..... '//system_id)
    IF (device_type = 'MDI') OR (device_type = 'ICA_II') THEN
      put_line (..
        ' 3. Ethernet Network Identifier ......... '//ethernet_id..
        ' 4. VE Interface Network Identifier ..... '//ve_interface_network_id)
    ELSEIF (device_type = 'MTI') THEN
      put_line (..
        ' 3. Define an Async Terminal '..
        ' 4. Define an Async Printer   '..
        ' 5. VE Interface Network Identifier ..... '//ve_interface_network_id)
    ELSEIF (device_type = 'TDI') THEN
      put_line (..
        ' 3. Define an Async Terminal '..
        ' 4. Define an Async Printer   ')
    IFEND
    put_line (..
     '0Enter a menu selection, QUIT, GO, or ?:'..
    )
"$ format=on
    choice=''
    accept_line choice input p=''

    IF choice = '1' THEN

      prompt_for_device_type device_type

    ELSEIF choice = '2' THEN

      IF device_type <> '' THEN
        IF device_type = 'ICA_II' THEN
          prompt_for_system_id ica2 system_id
        ELSE
          prompt_for_system_id di system_id
        IFEND
      ELSE
        accept_line cr_requested input p='CDCNET device type selection needed, press NEXT: '
      IFEND
    ELSEIF choice = '3' THEN
      IF (device_type = 'MTI') OR (device_type = 'TDI') THEN
        configure_lines dpf=di_procedure_file lt=async_terminal
      ELSEIF (device_type = 'MDI') OR (device_type = 'ICA_II') THEN
        prompt_for_network_id ethernet ethernet_id
      ELSE
        put_line '  '
        accept_line cr_requested input p='Invalid selection, press NEXT: '
      IFEND

    ELSEIF choice = '4' THEN

      IF (device_type = 'MTI') OR (device_type = 'TDI') THEN
        configure_lines dpf=di_procedure_file lt=async_printer
      ELSEIF (device_type = 'MDI') OR (device_type = 'ICA_II') THEN
        prompt_for_network_id ve ve_interface_network_id
      ELSE
        put_line '  '
        accept_line cr_requested input p='Invalid selection, press NEXT: '
      IFEND

    ELSEIF choice = '5' THEN

      IF (device_type = 'MTI') THEN
        prompt_for_network_id ve ve_interface_network_id
      ELSE
        put_line '  '
        accept_line cr_requested input p='Invalid selection, press NEXT: '
      IFEND

    ELSEIF ($translate(lower_to_upper, choice)= 'QUIT') OR ($translate(lower_to_upper, choice)= 'QUI') THEN

      EXIT main_loop

    ELSEIF (choice = '?') OR ($translate(lower_to_upper, choice)= 'HELP') THEN

"$ format=off
      put_line (..
        '0With this menu you create the initial configuration for a CDCNET'..
        ' Mainframe Device Interface (MDI), Mainframe Terminal Interface (MTI),'..
        ' Terminal Device Interface (TDI), or Integrated Communications' ..
        ' Adapter (ICA-II).  You must select the type of CDCNET device' ..
        ' and supply its system identifier. '..
        ' Each device type is described more completely in the help '..
        ' for menu selection 1.'..
        )
      IF (device_type = 'MTI') OR (device_type = 'TDI') THEN
        put_line (..
          '0Select number 3 if you would like to define another ASYNC terminal' ..
          ' on a TDI or MTI.  LIM 0 PORT 0 is already defined in the default' ..
          ' configuration.  The selection of a TUP is optional.' ..
          '0Select number 4 if you would like to define an ASYNC printer on a' ..
          ' TDI or MTI.' ..
          )
        IF device_type = 'MTI' THEN
          put_line (..
          '0Select number 5 to specify the network identifier of the VE interface' ..
          ' used to route messages to the host through this MTI.  The selection' ..
          ' of a VE interface network identifier is required if more than one device' ..
          ' (i.e., MDI, MTI, or EXPRESSLink) was defined during network configuration.'..
          )
        IFEND
      ELSEIF device_type = 'ICA_II' THEN
        put_line (..
          '0Select number 3 to specify the network identifier of the ethernet' ..
          ' to which the ICA-II is connected.' ..
          '0Select number 4 to specify the network identifier of the VE interface' ..
          ' used to route messages to the host through this ICA-II.  The selection' ..
          ' of a VE interface network identifier is required if more than one device' ..
          ' (i.e., ICA_II or EXPRESSLink) was defined during network configuration.'..
          )
      ELSEIF device_type = 'MDI' THEN
        put_line (..
          '0Select number 3 to specify the network identifier of the ethernet' ..
          ' to which the MDI is connected.' ..
          '0Select number 4 to specify the network identifier of the VE interface' ..
          ' used to route messages to the host through this MDI.  The selection' ..
          ' of a VE interface network identifier is required if more than one device' ..
          ' (i.e., MDI, MTI, or EXPRESSLink) was defined during network configuration.'..
          )
      IFEND
      put_line (..
        '0Enter a menu selection to set the device type or system identifier.'..
        ' Enter GO or press NEXT to create the configuration procedure.'..
        ' Enter QUIT to return to the main menu.'..
        '  ')
"$ format=on
      accept_line cr_requested input p='Press NEXT: '

    ELSEIF (choice = ' ') OR ($translate(lower_to_upper, choice)= 'GO') THEN

      IF device_type = '' THEN
        put_line '  '
        accept_line cr_requested input p='CDCNET device type needed, press NEXT: '
      ELSE
        IF system_id = '' THEN
          put_line '   '
          accept_line cr_requested input p='CDCNET device System Identifier needed, press NEXT: '
        ELSE
          IF (device_type = 'MDI') OR (device_type = 'ICA_II') THEN
            IF (ethernet_id <> '') AND (ve_interface_network_id <> '') THEN
              include_line ..
                    'add_device_interface t='//device_type//' pn=SYSTEM_'//system_id//' eni=ethernet_id ..
                    vini=ve_interface_network_id status=local_status'
            ELSEIF ethernet_id <> '' THEN
              include_line ..
                    'add_device_interface t='//device_type//' pn=SYSTEM_'//system_id//' eni=ethernet_id ..
                    status=local_status'
            ELSEIF ve_interface_network_id <> '' THEN
              include_line ..
                    'add_device_interface t='//device_type//' pn=SYSTEM_'//system_id//'..
                    vini=ve_interface_network_id status=local_status'
            ELSE
              include_line ..
                    'add_device_interface t='//device_type//' pn=SYSTEM_'//system_id//' status=local_status'
            IFEND
          ELSEIF (device_type = 'MTI') THEN
            IF $file($fname(di_procedure_file), opened) THEN
              IF ve_interface_network_id <> '' THEN
                include_line ..
                      'add_device_interface t='//device_type//' pn=SYSTEM_'//system_id//'..
                      dpf='//di_procedure_file//' vini=ve_interface_network_id status=local_status'
              ELSE
                include_line 'add_device_interface t='//device_type//' pn=SYSTEM_'//system_id//'..
                     dpf='//di_procedure_file//' status=local_status'
              IFEND
            ELSE
              IF ve_interface_network_id <> '' THEN
                include_line ..
                      'add_device_interface t='//device_type//' pn=SYSTEM_'//system_id//' ..
                      vini=ve_interface_network_id status=local_status'
              ELSE
                include_line ..
                      'add_device_interface t='//device_type//' pn=SYSTEM_'//system_id//' status=local_status'
              IFEND
            IFEND
          ELSE"IF (device_type = 'TDI') THEN
            IF $file($fname(di_procedure_file), opened) THEN
              include_line 'add_device_interface t='//device_type//' pn=SYSTEM_'//system_id//'..
                   dpf='//di_procedure_file//' status=local_status'
            ELSE
              include_line ..
                    'add_device_interface t='//device_type//' pn=SYSTEM_'//system_id//' status=local_status'
            IFEND
          IFEND

          IF local_status.normal THEN
            accept_line cr_requested input p='Press NEXT: '
            EXIT main_loop
          ELSE
            display_value local_status
            put_line '  '
            accept_line cr_requested input p='Press NEXT: '
          IFEND
        IFEND
      IFEND
    ELSE

      put_line '  '
      accept_line cr_requested input p='Invalid selection, press NEXT: '

    IFEND
  LOOPEND main_loop

PROCEND create_cdcnet_config_procs
*DECK DECK=RAM$CREATE_ELEMENT_LIST EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'DEFINE_SUBPRODUCT Utility: Module RAM$CREATE_ELEMENT_LIST.' ??
MODULE ram$create_element_list;

{ PURPOSE:
{   This module contains the procedures to write information
{   about each item in a catalog to an element_list.  Items in a catalog
{   can be validated for allowable ring attributes, file_permits,
{   and cycle numbers.
{
{ DESIGN:
{   Permanent file procedures are used to create a sequence containing
{   information about all the items of a catalog.  Only the information that
{   is needed for installation is moved to another sequence called
{   the element_list.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{
{


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$package_software_cc
*copyc pmt$condition
*copyc ost$status
*copyc rat$path
*copyc rat$subproduct_info_pointers
*copyc rat$subproduct_info_p
*copyc rat$subproduct_info_types
*copyc rat$validation_selections
?? POP ??
*copyc amp$fetch
*copyc amp$fetch_access_information
*copyc amp$get_segment_pointer
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc mmp$create_segment
*copyc mmp$delete_segment
*copyc ocp$checksum
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pfp$find_direct_info_record
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$find_file_description
*copyc pfp$get_item_info
*copyc pfp$get_multi_item_info
*copyc osp$generate_error_message
*copyc rap$add_name_to_path_ref
*copyc rap$get_file_information
*copyc rap$test_cycles
*copyc rap$test_permits

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    subproduct_info_seq_p: ^rat$subproduct_info_sequence;

?? TITLE := '[XDCL] rap$create_element_list', EJECT ??


{ PURPOSE:
{   This procedure will create the element list for the PACS catalog.
{
{ DESIGN:
{   This procedure creates the permanent file sequence pointer, and calls
{   get_catalog_information to continue processing the element_list.
{   Then the subproduct_info_pointers are updated with their new values.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$create_element_list
    (    catalog_ref_p: ^fst$file_reference;
         catalog_path: pft$path;
         validation_selections: rat$validation_selections;
         checksum_contents: boolean;
     VAR validation_errors: {output} boolean;
     VAR subproduct_info_pointers: {input, output} rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      element: rat$element,
      local_status: ost$status,
      pf_info_seq_p: pft$p_info,
      pf_segment_pointer: mmt$segment_pointer,
      product_file_size: integer,
      subproduct_element_count: rat$subproduct_element_count,
      subproduct_size: integer;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the segment has been created, it will be deleted before the
{   the procedure returns.
{
{ NOTES:
{
{
    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF pf_segment_pointer.seq_pointer <> NIL THEN
        mmp$delete_segment (pf_segment_pointer, 1, ignore_status);
        pf_segment_pointer.seq_pointer := NIL;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    product_file_size := 0;
    subproduct_element_count := 0;
    subproduct_size := 0;
    validation_errors := FALSE;

    subproduct_info_seq_p := subproduct_info_pointers.subproduct_info_seq_p;
    RESET subproduct_info_seq_p TO subproduct_info_pointers.element_list_p;

    pf_segment_pointer.kind := mmc$sequence_pointer;
    pf_segment_pointer.seq_pointer := NIL;

    mmp$create_segment (NIL, mmc$sequence_pointer, 1, pf_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN
      pf_info_seq_p := pf_segment_pointer.seq_pointer;
      RESET pf_info_seq_p;

      get_catalog_information (catalog_ref_p, catalog_path, pf_info_seq_p, validation_selections, TRUE,
            checksum_contents, validation_errors, element, product_file_size, subproduct_size,
            subproduct_element_count, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      subproduct_info_pointers.attributes_p^.product_file_size := product_file_size;
      subproduct_info_pointers.attributes_p^.user_permanent_file_size := 0;
      subproduct_info_pointers.attributes_p^.service_critical_file_size := 0;
      subproduct_info_pointers.attributes_p^.size := subproduct_size;
      subproduct_info_pointers.attributes_p^.first_level_element_count := element.element_count;
      { Subtract 1 from the subproduct element count so that the PACS catalog is not included.}
      subproduct_info_pointers.attributes_p^.subproduct_element_count := subproduct_element_count - 1;
      subproduct_info_pointers.subproduct_info_seq_p := subproduct_info_seq_p;

    END /main/;

    osp$disestablish_cond_handler;

    IF pf_segment_pointer.seq_pointer <> NIL THEN
      mmp$delete_segment (pf_segment_pointer, 1, local_status);
      pf_segment_pointer.seq_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

  PROCEND rap$create_element_list;

?? TITLE := 'get_catalog_information', EJECT ??

{ PURPOSE:
{   This procedure gathers all the information about a catalog and puts
{   the information in the element list.
{
{ DESIGN:
{   This procedure gathers information about a catalog using
{   the permanent file procedures.  PFP$GET_ITEM_INFO only
{   returns information about the catalog.  This is used to check
{   the catalog permits.  PFP$GET_MULTI_ITEM_INFO returns information
{   about all the files and catalogs one level down from the input catalog.
{   The directory_p^ conatains an array of records.  Each record contains
{   the name of one element, its type (file or catalog) and the offset into
{   the permanent file sequence where more information about the element
{   can be found.
{
{ NOTES:
{   This procedure is the only place where the subproduct sequence
{   is NEXTed and updated with information from the file and catalog elements.
{   Before each pfp call, pf_info_item_seq_p is set to the beginning of
{   information about the catalog being referenced at this level.
{   The subproduct size is a close estimation of the size of the
{   backup file of this catalog.

  PROCEDURE get_catalog_information
    (    catalog_ref_p: ^fst$file_reference;
         catalog_path: pft$path;
         pf_info_seq_p: pft$p_info;
         validation_selections: rat$validation_selections;
         first_call: boolean;
         checksum_contents: boolean;
     VAR validation_errors: boolean;
     VAR element: rat$element;
     VAR product_file_size {input} : integer;
     VAR subproduct_size {input} : integer;
     VAR subproduct_element_count {input} : rat$subproduct_element_count;
     VAR status: ost$status);


    VAR
      current_product_file_size: integer,
      current_subproduct_size: integer,
      directory_p: pft$p_directory_array,
      element_p: ^rat$element,
      element_returned: rat$element,
      file_path: rat$path,
      group: pft$group,
      i: pft$array_index,
      info_record_p: pft$p_info_record,
      local_status: ost$status,
      old_element_p: ^rat$element,
      path_p: ^pft$path,
      pf_info_item_seq_p: pft$p_info;


    status.normal := TRUE;
    group.group_type := pfc$public;

    element.name := catalog_path [UPPERBOUND (catalog_path)];
    element.permit.defined := FALSE;
    element.permit.permit_selections := $pft$permit_selections [];
    element.permit.share_requirements := $pft$share_requirements [];
    element.permit.application_info := '';
    element.active_element := TRUE;
    element.next_element_across_p := NIL;
    element.element_type := rac$catalog;
    element.element_count := 0;
    element.first_element_down_p := NIL;
    current_product_file_size := product_file_size;
    subproduct_element_count := subproduct_element_count + 1;

    pf_info_item_seq_p := pf_info_seq_p;

    pfp$get_item_info (catalog_path, group, $pft$catalog_info_selections
          [pfc$catalog_directory, pfc$catalog_permits, pfc$indirect_catalog_permits],
          $pft$file_info_selections [], pf_info_item_seq_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pf_info_item_seq_p := pf_info_seq_p;
    pfp$find_next_info_record (pf_info_item_seq_p, info_record_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$find_directory_array (info_record_p, directory_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$test_permits (validation_selections, catalog_ref_p, info_record_p, directory_p^ [1].info_offset,
          validation_errors, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pf_info_item_seq_p := pf_info_seq_p;
    pfp$get_multi_item_info (catalog_path, group, $pft$catalog_info_selections
          [pfc$catalog_directory, pfc$catalog_permits, pfc$indirect_catalog_permits],
          $pft$file_info_selections [pfc$file_directory, pfc$file_permits, pfc$file_description,
          pfc$file_cycles, pfc$cycle_label_descriptor], pf_info_item_seq_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pf_info_item_seq_p := pf_info_seq_p;
    pfp$find_next_info_record (pf_info_item_seq_p, info_record_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_subproduct_size := subproduct_size + ((info_record_p^.body_size *
            ((UPPERBOUND (catalog_path) DIV 2) * UPPERBOUND (catalog_path) + 91)) DIV 10);

    pfp$find_directory_array (info_record_p, directory_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF directory_p = NIL THEN  {EMPTY CATALOG}
      RETURN;
    IFEND;
    element.element_count := UPPERBOUND (directory_p^);

    PUSH path_p: [1 .. UPPERBOUND (catalog_path) + 1];
    FOR i := 1 TO UPPERBOUND (catalog_path) DO
      path_p^ [i] := catalog_path [i];
    FOREND;


    FOR i := 1 TO UPPERBOUND (directory_p^) DO
      path_p^ [UPPERBOUND (path_p^)] := directory_p^ [i].name;

      STRINGREP (file_path.path, file_path.size, catalog_ref_p^, '.', directory_p^ [i].name (1,
            clp$trimmed_string_size (directory_p^ [i].name)));

      NEXT element_p IN subproduct_info_seq_p;
      IF element_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
        RETURN;
      IFEND;

      IF (i = 1) AND (NOT first_call) THEN
        element.first_element_down_p := #REL (element_p, subproduct_info_seq_p^);
      IFEND;

      IF directory_p^ [i].name_type = pfc$file_name THEN

        rap$get_file_information (^file_path.path (1, file_path.size), path_p^, info_record_p,
              directory_p^ [i].info_offset, validation_selections, checksum_contents, validation_errors,
              element_returned, status);

        current_product_file_size := current_product_file_size + element_returned.size;
        current_subproduct_size := current_subproduct_size + element_returned.size;
        subproduct_element_count := subproduct_element_count + 1;

      ELSE {pfc$catalog_name}

        get_catalog_information (^file_path.path (1, file_path.size), path_p^, pf_info_item_seq_p,
              validation_selections, FALSE {SIF present}, checksum_contents, validation_errors,
              element_returned, current_product_file_size, current_subproduct_size,
              subproduct_element_count, status);

      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      element_p^ := element_returned;

      IF i > 1 THEN
        old_element_p^.next_element_across_p := #REL (element_p, subproduct_info_seq_p^);
      IFEND;

      old_element_p := element_p;

    FOREND;

    product_file_size := current_product_file_size;
    subproduct_size := current_subproduct_size;

  PROCEND get_catalog_information;

MODEND ram$create_element_list;





*DECK DECK=RAM$CREATE_KEY_DEFINITIONS EXPAND=TRUE
MODULE ram$create_key_definitions;
?? RIGHT := 110 ??
?? PUSH (LISTEXT := ON) ??
*copyc amp$close
*copyc amp$get_segment_pointer
*copyc amp$get_next
*copyc amp$open
*copyc amp$put_next
*copyc amp$set_segment_eoi

*copyc clp$end_scan_command_file
*copyc clp$get_value
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$scan_command_file
*copyc clp$scan_parameter_list
*copyc clp$test_parameter

*copyc ifp$store_term_conn_attributes

*copyc osp$set_status_abnormal

*copyc osv$lower_to_upper

*copyc pmp$manage_sense_switches
?? POP ??

  CONST
    next_key = 18;

  TYPE
    key_def = record
      definition: string (64),
      def_length: 0 .. 64,
      carriage_return,
      half_duplex,
      hex_input,
      defined: boolean,
      label: string (7),
    recend,
    key_set = record
      include_screen_edit: boolean,
      mk,
      ck: 0 .. 45,
      defs: array [1 .. 45] of key_def,
      include_screen_scroll: boolean,
      fk,
      bk: 0 .. 45,
    recend,
    out_def_rec = packed record
      prefix: string (8),
      define: string (132),
    recend;

  VAR
    backward_key,
    copy_key,
    forward_key,
    mark_key : 0 .. 45 := 0,
    on,
    off,
    current: pmt$sense_switches,
    version_conflict,
    version_4 : boolean,

    address: amt$file_byte_address,
    command_file: amt$local_file_name := clc$current_command_input,
    def_in: ^key_set,
    def_out: out_def_rec,
    place : integer,
    fid: amt$file_identifier,
    file_in: amt$local_file_name,
    file_out: amt$local_file_name := clc$standard_output,
    seg_ptr: amt$segment_pointer,
    tfid: amt$file_identifier,
    vkx_utility_name: string (31) := 'DEFINE_VKX_KEYS                ',
    vkx_prompt_string: string (3) := 'DVK';
?? NEWTITLE := '******  output_def_prolog  ******', EJECT ??
  PROCEDURE output_def_prolog (VAR status: ost$status);

{  This procedure does the following :
{   Clear all host loaded codes - 1e,2e
{   Disable keyboard            - 1e,12,4d
{   Normal numeric keypad       - 1e,12,6c
{   Disable CR delimiter        - 1e,12,5a

    VAR
      i: integer,
      prolog_str: string (14),
      prolog_table: [STATIC] array [1 .. 14] of 0 .. 0ff(16) := [ 1e(16), 2e(16), 1e(16), 2e(16),
                  1e(16), 12(16), 4d(16), 1e(16), 12(16), 6c(16), 1e(16), 12(16), 5a(16), 0d(16)];


    FOR i := 1 TO 14 DO
      prolog_str (i) := $CHAR (prolog_table [i]);
    FOREND;
    amp$put_next (tfid, #LOC (prolog_str), #SIZE (prolog_str), address, status);

  PROCEND output_def_prolog;
?? OLDTITLE ??
?? NEWTITLE := '******  load_controlware_programs  ******', EJECT ??
  PROCEDURE load_controlware_programs (VAR status: ost$status);

    VAR
      i: integer, { cd 42 }
      routine_str: string (291),

{  The values placed in the following variables are obtained by assembling
{  the deck VKM$VIKING_CONTROLWARE.
{
{  The values are listed with the load address followed by the binary for
{  the routine.

      push_routine_table: [STATIC] array [1 .. 25] of 0 .. 0ff(16) := [0d0(16), 000(16),
        011(16), 041(16), 0D0(16), 001(16), 0F3(16), 000(16), 021(16), 0E0(16), 0D7(16), 0ED(16), 0B0(16),
        03A(16), 047(16), 0E0(16), 032(16), 034(16), 0D1(16), 03A(16), 0B9(16), 0E0(16), 032(16), 035(16),
        0D1(16)],
      term_setup_table: [STATIC] array [1 .. 20] of 0 .. 0ff(16) := [0d0(16), 017(16),
        0AF(16), 032(16), 0B9(16), 0E0(16), 001(16), 0F2(16), 000(16), 021(16), 0E0(16), 0D7(16), 011(16),
        0E1(16), 0D7(16), 036(16), 030(16), 0ED(16), 0B0(16), 0C9(16)],
      pop_routine_table: [STATIC] array [1 .. 26] of 0 .. 0ff(16) := [0D0(16), 029(16),
        021(16), 041(16), 0D0(16), 001(16), 0F3(16), 000(16), 011(16), 0E0(16), 0D7(16), 0ED(16), 0B0(16),
        03A(16), 034(16), 0D1(16), 032(16), 047(16), 0E0(16), 03A(16), 035(16), 0D1(16), 032(16), 0B9(16),
        0E0(16), 0C9(16)],
      mark_routine_table: [STATIC] array [1 .. 120] of 0 .. 0ff(16) := [0d1(16), 038(16),
        0CD(16), 04D(16), 0D1(16), 03A(16), 0B5(16), 0E0(16), 0A7(16), 020(16), 045(16), 03A(16), 0E6(16),
        0E0(16), 0A7(16), 028(16), 019(16), 03E(16), 0FF(16), 032(16), 032(16), 0D2(16), 0C9(16), 0CD(16),
        02D(16), 0D2(16), 0F8(16), 0CD(16), 019(16), 0D2(16), 03D(16), 032(16), 032(16), 0D2(16), 023(16),
        0CB(16), 096(16), 023(16), 015(16), 020(16), 0F9(16), 0C9(16), 0CD(16), 02D(16), 0D2(16), 0F2(16),
        068(16), 0D1(16), 03E(16), 01D(16), 047(16), 0CD(16), 019(16), 0D2(16), 0AF(16), 023(16), 0CB(16),
        06E(16), 028(16), 003(16), 0CB(16), 0D6(16), 03C(16), 023(16), 015(16), 020(16), 0F4(16), 0A7(16),
        020(16), 005(16), 005(16), 078(16), 0F2(16), 069(16), 0D1(16), 078(16), 032(16), 032(16), 0D2(16),
        0C9(16), 0CD(16), 02D(16), 0D2(16), 0F2(16), 08E(16), 0D1(16), 03E(16), 01D(16), 047(16), 032(16),
        032(16), 0D2(16), 0F8(16), 0CD(16), 019(16), 0D2(16), 0CD(16), 023(16), 0D2(16), 02B(16), 0BE(16),
        020(16), 008(16), 02B(16), 015(16), 020(16), 0F8(16), 078(16), 03D(16), 018(16), 0E9(16), 023(16),
        0CB(16), 0D6(16), 02B(16), 02B(16), 015(16), 020(16), 0F9(16), 0C9(16)],
      copy_routine_table: [STATIC] array [1 .. 97] of 0 .. 0ff(16) := [0d1(16), 0ae(16),
        03A(16), 0E6(16), 0E0(16), 0A7(16), 020(16), 039(16), 03A(16), 0B5(16), 0E0(16), 0A7(16), 020(16),
        03D(16), 0CD(16), 02D(16), 0D2(16), 0F8(16), 0CD(16), 019(16), 0D2(16), 023(16), 0CB(16), 056(16),
        020(16), 007(16), 023(16), 015(16), 020(16), 0F7(16), 0C3(16), 047(16), 0D1(16), 0CB(16), 096(16),
        02B(16), 046(16), 0D5(16), 03A(16), 0A9(16), 0E0(16), 0F5(16), 0F6(16), 020(16), 032(16), 0A9(16),
        0E0(16), 0C5(16), 0CD(16), 039(16), 000(16), 0C1(16), 0F1(16), 032(16), 0A9(16), 0E0(16), 0CD(16),
        087(16), 000(16), 0D1(16), 015(16), 0CA(16), 047(16), 0D1(16), 0C9(16), 0CD(16), 0BA(16), 0D1(16),
        0CD(16), 02D(16), 0D2(16), 0F2(16), 0ED(16), 0D1(16), 0C9(16), 0CD(16), 02D(16), 0D2(16), 0F8(16),
        0CD(16), 019(16), 0D2(16), 023(16), 0CB(16), 056(16), 028(16), 003(16), 0CB(16), 096(16), 0C9(16),
        023(16), 015(16), 0CA(16), 047(16), 0D1(16), 018(16), 0F1(16)],
      next_routine_table: [STATIC] array [1 .. 40] of 0 .. 0ff(16) := [0d2(16), 00d(16),
        0CD(16), 04D(16), 0D1(16), 006(16), 00D(16), 0CD(16), 087(16), 000(16), 0CD(16), 039(16), 000(16),
        0C9(16), 06F(16), 026(16), 0E0(16), 0CD(16), 03F(16), 000(16), 0EB(16), 016(16), 084(16), 0C9(16),
        0D5(16), 011(16), 007(16), 001(16), 0ED(16), 05A(16), 0D1(16), 03E(16), 020(16), 0C9(16), 03A(16),
        032(16), 0D2(16), 0A7(16), 0C9(16), 0FF(16)],
      scroll_routine_table: [STATIC] array [1 .. 143] of 0 .. 0ff(16) := [0D2(16), 035(16),
        03E(16), 01C(16), 0CD(16), 054(16), 0D3(16), 03E(16), 062(16), 011(16), 000(16), 040(16), 021(16),
        0F2(16), 040(16), 001(16), 008(16), 001(16), 0EB(16), 073(16), 023(16), 072(16), 023(16), 0EB(16),
        0ED(16), 04A(16), 03D(16), 020(16), 0F5(16), 011(16), 0F3(16), 040(16), 021(16), 0F2(16), 040(16),
        001(16), 008(16), 064(16), 036(16), 020(16), 0ED(16), 0B0(16), 021(16), 000(16), 0E0(16), 0CD(16),
        03F(16), 000(16), 021(16), 051(16), 0D3(16), 07B(16), 0BE(16), 028(16), 012(16), 0EB(16), 022(16),
        051(16), 0D3(16), 0CD(16), 088(16), 0D2(16), 02A(16), 051(16), 0D3(16), 011(16), 054(16), 0D3(16),
        001(16), 008(16), 001(16), 0ED(16), 0B0(16), 0CD(16), 0A5(16), 000(16), 03A(16), 0D6(16), 0D8(16),
        0A7(16), 020(16), 0D8(16), 0C3(16), 033(16), 000(16), 03A(16), 053(16), 0D3(16), 0FE(16), 061(16),
        028(16), 00B(16), 0CD(16), 0B2(16), 0D2(16), 03A(16), 053(16), 0D3(16), 03C(16), 032(16), 053(16),
        0D3(16), 0C9(16), 021(16), 000(16), 040(16), 054(16), 05D(16), 04E(16), 023(16), 046(16), 0C5(16),
        023(16), 001(16), 0C2(16), 000(16), 0ED(16), 0B0(16), 0E1(16), 07D(16), 012(16), 013(16), 07C(16),
        012(16), 0EB(16), 018(16), 007(16), 007(16), 06F(16), 026(16), 040(16), 05E(16), 023(16), 056(16),
        021(16), 054(16), 0D3(16), 001(16), 008(16), 001(16), 0ED(16), 0B0(16), 0C9(16)],
      fwd_routine_table: [STATIC] array [1 .. 70] of 0 .. 0ff(16) := [ 0D2(16), 0C2(16),
        03A(16), 053(16), 0D3(16), 0FE(16), 061(16), 0C8(16), 03C(16), 007(16), 06F(16), 026(16), 040(16),
        05E(16), 023(16), 056(16), 0D5(16), 021(16), 000(16), 0E0(16), 0CD(16), 03F(16), 000(16), 0EB(16),
        011(16), 054(16), 0D3(16), 001(16), 008(16), 001(16), 0ED(16), 0B0(16), 0CD(16), 081(16), 000(16),
        021(16), 01D(16), 0E0(16), 0CD(16), 03F(16), 000(16), 0E1(16), 0E5(16), 001(16), 008(16), 001(16),
        0ED(16), 0B0(16), 0D1(16), 0CD(16), 0B9(16), 0D2(16), 021(16), 000(16), 0E0(16), 0CD(16), 03F(16),
        000(16), 0EB(16), 022(16), 051(16), 0D3(16), 03A(16), 053(16), 0D3(16), 03C(16), 032(16), 053(16),
        0D3(16), 0C9(16)],
      bkw_routine_table: [STATIC] array [1 .. 80] of 0 .. 0ff(16) := [ 0D3(16), 006(16),
        03A(16), 053(16), 0D3(16), 0A7(16), 0CA(16), 033(16), 000(16), 007(16), 06F(16), 026(16), 040(16),
        05E(16), 023(16), 056(16), 0D5(16), 021(16), 01D(16), 0E0(16), 0CD(16), 03F(16), 000(16), 0EB(16),
        011(16), 054(16), 0D3(16), 001(16), 008(16), 001(16), 0ED(16), 0B0(16), 03A(16), 0BF(16), 0E0(16),
        0F5(16), 03E(16), 002(16), 032(16), 0BF(16), 0E0(16), 0CD(16), 081(16), 000(16), 0F1(16), 032(16),
        0BF(16), 0E0(16), 021(16), 000(16), 0E0(16), 0CD(16), 03F(16), 000(16), 0EB(16), 022(16), 051(16),
        0D3(16), 0EB(16), 0E1(16), 0E5(16), 001(16), 008(16), 001(16), 0ED(16), 0B0(16), 0D1(16), 03A(16),
        053(16), 0D3(16), 03D(16), 032(16), 053(16), 0D3(16), 0C3(16), 0B9(16), 0D2(16), 010(16), 0E1(16),
        000(16)],
      CFR_routine_table: [STATIC] array [1 .. 56] of 0 .. 0ff(16) := [ 0D3(16), 054(16),
        0D3(16), 070(16), 03A(16), 000(16), 0AF(16), 0FE(16), 0C3(16), 020(16), 01E(16), 021(16), 084(16),
        0B3(16), 022(16), 0DD(16), 0D1(16), 022(16), 016(16), 0D2(16), 021(16), 0C8(16), 0BC(16), 022(16),
        0E5(16), 0D1(16), 022(16), 013(16), 0D2(16), 021(16), 0D8(16), 0BA(16), 022(16), 07D(16), 0D2(16),
        021(16), 080(16), 0D3(16), 0C3(16), 063(16), 000(16), 021(16), 085(16), 0D3(16), 018(16), 0F8(16),
        01E(16), 012(16), 065(16), 032(16), 0FF(16), 01E(16), 012(16), 065(16), 031(16), 0FF(16)];

    routine_str (1) := $CHAR (1e(16));
    routine_str (2) := $CHAR (09(16));
    routine_str (3) := $CHAR (7f(16)); { controlware definition }
    routine_str (4) := '2';
    IF def_in^.include_screen_scroll THEN
      FOR i := 1 TO 56 DO
        routine_str (2 * i + 3) := $CHAR (CFR_routine_table [i] DIV 10(16) + 20(16));
        routine_str (2 * i + 4) := $CHAR (CFR_routine_table [i] MOD 10(16) + 60(16));
      FOREND;
      routine_str (117) := $CHAR (0d(16));
      amp$put_next (tfid, #LOC (routine_str), 117, address, status);
      FOR i := 1 TO 143 DO
        routine_str (2 * i + 3) := $CHAR (scroll_routine_table [i] DIV 10(16) + 20(16));
        routine_str (2 * i + 4) := $CHAR (scroll_routine_table [i] MOD 10(16) + 60(16));
      FOREND;
      routine_str (291) := $CHAR (0d(16));
      amp$put_next (tfid, #LOC (routine_str), 291, address, status);
      turn_on_light(3,1, status);

      routine_str (3) := $CHAR (def_in^.fk + 30(16));
      FOR i := 1 TO 70 DO
        routine_str (2 * i + 3) := $CHAR (fwd_routine_table [i] DIV 10(16) + 20(16));
        routine_str (2 * i + 4) := $CHAR (fwd_routine_table [i] MOD 10(16) + 60(16));
      FOREND;
      routine_str (145) := $CHAR (0d(16));
      amp$put_next (tfid, #LOC (routine_str), 145, address, status);
      turn_on_light(2,3, status);

      routine_str (3) := $CHAR (def_in^.bk + 30(16));
      FOR i := 1 TO 80 DO
        routine_str (2 * i + 3) := $CHAR (bkw_routine_table [i] DIV 10(16) + 20(16));
        routine_str (2 * i + 4) := $CHAR (bkw_routine_table [i] MOD 10(16) + 60(16));
      FOREND;
      routine_str (165) := $CHAR (0d(16));
      amp$put_next (tfid, #LOC (routine_str), 165, address, status);
      turn_on_light(1,2, status);
    IFEND;

    IF def_in^.include_screen_edit THEN
      routine_str (3) := $CHAR (def_in^.mk + 30(16));
      FOR i := 1 TO 120 DO
        routine_str (2 * i + 3) := $CHAR (mark_routine_table [i] DIV 10(16) + 20(16));
        routine_str (2 * i + 4) := $CHAR (mark_routine_table [i] MOD 10(16) + 60(16));
      FOREND;
      routine_str (245) := $CHAR (0d(16));
      amp$put_next (tfid, #LOC (routine_str), 245, address, status);
      turn_on_light(3,1, status);

      routine_str (3) := $CHAR (def_in^.ck + 30(16));
      FOR i := 1 TO 97 DO
        routine_str (2 * i + 3) := $CHAR (copy_routine_table [i] DIV 10(16) + 20(16));
        routine_str (2 * i + 4) := $CHAR (copy_routine_table [i] MOD 10(16) + 60(16));
      FOREND;
      routine_str (199) := $CHAR (0d(16));
      amp$put_next (tfid, #LOC (routine_str), 199, address, status);
      turn_on_light(2,3, status);

      routine_str (3) := $CHAR (next_key + 30(16));
      FOR i := 1 TO 40 DO
        routine_str (2 * i + 3) := $CHAR (next_routine_table [i] DIV 10(16) + 20(16));
        routine_str (2 * i + 4) := $CHAR (next_routine_table [i] MOD 10(16) + 60(16));
      FOREND;
      routine_str (85) := $CHAR (0d(16));
      amp$put_next (tfid, #LOC (routine_str), 85, address, status);
      turn_on_light(1,2, status);
    IFEND;

    routine_str (3) := 'p';
    FOR i := 1 TO 25 DO
      routine_str (2 * i + 3) := $CHAR (push_routine_table [i] DIV 10(16) + 20(16));
      routine_str (2 * i + 4) := $CHAR (push_routine_table [i] MOD 10(16) + 60(16));
    FOREND;
    routine_str (55) := $CHAR (0d(16));
    amp$put_next (tfid, #LOC (routine_str), 55, address, status);
    turn_on_light(3,1, status);

    routine_str (3) := 'r';
    FOR i := 1 TO 20 DO
      routine_str (2 * i + 3) := $CHAR (term_setup_table [i] DIV 10(16) + 20(16));
      routine_str (2 * i + 4) := $CHAR (term_setup_table [i] MOD 10(16) + 60(16));
    FOREND;
    routine_str (45) := $CHAR (0d(16));
    amp$put_next (tfid, #LOC (routine_str), 45, address, status);
    turn_on_light(2,3, status);

    routine_str (3) := 'q';
    FOR i := 1 TO 26 DO
      routine_str (2 * i + 3) := $CHAR (pop_routine_table [i] DIV 10(16) + 20(16));
      routine_str (2 * i + 4) := $CHAR (pop_routine_table [i] MOD 10(16) + 60(16));
    FOREND;
    routine_str (57) := $CHAR (0d(16));
    amp$put_next (tfid, #LOC (routine_str), 57, address, status);
    turn_on_light(1,2, status);

  PROCEND load_controlware_programs;
?? OLDTITLE ??
?? NEWTITLE := '******  turn on light  ******', EJECT ??
  PROCEDURE turn_on_light (on_light, off_light : 0 .. 3; VAR status : ost$status);

    VAR
      light_string : string(8);

    light_string(1) := $char(1e(16));
    light_string(2) := $char(12(16));
    light_string(3) := 'e';
    light_string(4) := $char(on_light + 30(16));
    light_string(5) := $char(1e(16));
    light_string(6) := $char(12(16));
    light_string(7) := 'f';
    light_string(8) := $char(off_light + 30(16));
    amp$put_next (tfid, #LOC (light_string), #SIZE (light_string), address, status);

  PROCEND turn_on_light;
?? OLDTITLE ??
?? NEWTITLE := '******  activate controlware  ******', EJECT ??
  PROCEDURE activate_controlware (VAR status: ost$status);

    VAR
      routine_str: string (4);


    turn_on_light(1,1, status);

    routine_str (1) := $CHAR (1e(16));
    routine_str (2) := $CHAR (12(16));
    routine_str (4) := $CHAR (0d(16));

{ enable keyboard }
    routine_str (3) := 'N';
    amp$put_next (tfid, #LOC (routine_str), 4, address, status);

{ activate monitor function for scrolling }
    routine_str (3) := $CHAR (7f(16));
    amp$put_next (tfid, #LOC (routine_str), 4, address, status);


  PROCEND activate_controlware;
?? OLDTITLE ??
?? NEWTITLE := '******  convert_normal_def  ******', EJECT ??
  PROCEDURE convert_normal_def (key: 1 .. 45);

    VAR
      pos: 1 .. 64;


    pos := 1;
    place := 1;
    REPEAT
      def_out.define (place) := $CHAR ($INTEGER (def_in^.defs [key].definition (pos)) DIV 10(16) + 20(16));
      def_out.define (place + 1) := $CHAR ($INTEGER (def_in^.defs [key].definition (pos)) MOD 10(16) +
            60(16));
      place := place + 2;
      pos := pos + 1;
    UNTIL def_in^.defs [key].def_length < pos;

    IF def_in^.defs [key].carriage_return THEN
      def_out.define (place) := ' ';
      def_out.define (place + 1) := 'm';
      place := place + 2;
    IFEND;

  PROCEND convert_normal_def;
?? OLDTITLE ??
?? NEWTITLE := '******  convert_hex_def  ******', EJECT ??
  PROCEDURE convert_hex_def (key: 1 .. 45);

    VAR
      pos: 1 .. 64;


    pos := 1;
    place := 1;
    WHILE def_in^.defs [key].def_length >= pos DO
      IF (def_in^.defs [key].definition (pos) >= '0') AND (def_in^.defs [key].definition (pos) <= '9') THEN
        def_out.define (place) := $CHAR ($INTEGER (def_in^.defs [key].definition (pos)) - 10(16));
      ELSEIF (def_in^.defs [key].definition (pos) >= 'A') AND (def_in^.defs [key].definition (pos) <= 'F')
            THEN
        def_out.define (place) := $CHAR ($INTEGER (def_in^.defs [key].definition (pos)) - 17(16));
      ELSE
        RETURN
      IFEND;
      pos := pos + 1;
      place := place + 1;
      IF (def_in^.defs [key].definition (pos) >= '0') AND (def_in^.defs [key].definition (pos) <= '9') THEN
        def_out.define (place) := $CHAR ($INTEGER (def_in^.defs [key].definition (pos)) + 30(16));
      ELSEIF (def_in^.defs [key].definition (pos) >= 'A') AND (def_in^.defs [key].definition (pos) <= 'F')
            THEN
        def_out.define (place) := $CHAR ($INTEGER (def_in^.defs [key].definition (pos)) + 29(16));
      ELSE
        RETURN
      IFEND;
      pos := pos + 1;
      place := place + 1;
    WHILEND;

  PROCEND convert_hex_def;
?? OLDTITLE ??
?? NEWTITLE := '******  test_revision_number  ******', EJECT ??
  PROCEDURE test_revision_number (VAR status : ost$status);

    VAR
      bytes : amt$transfer_count,
      cfid: amt$file_identifier,
      position : amt$file_position,
      model_report : string(42),
      prompt_string : array [1..1] of ift$connection_attribute,
      model_report_request : string(4);


    amp$open (clc$job_input, amc$record, NIL, cfid, status);
    model_report_request  :=', C0';
    model_report_request (2) := CHR (1e(16));
    prompt_string[1].key := ifc$prompt_string;
    prompt_string[1].prompt_string.size := 4;
    prompt_string[1].prompt_string.value := model_report_request;
    ifp$store_term_conn_attributes (cfid, prompt_string, status);
    amp$get_next (cfid, #LOC (model_report), #SIZE (model_report), bytes, address, position, status);
    IF bytes < 40 THEN
      osp$set_status_abnormal ('VK', 0, 'Terminal does not respond as a 721', status);
      RETURN
    IFEND;

    version_4 := model_report (41) = '4';

  PROCEND test_revision_number;
?? OLDTITLE ??
?? NEWTITLE := '******  rap$load_keys  ******', EJECT ??
  PROCEDURE [XDCL, #GATE] rap$load_keys (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT load_keys_pdt (
{   input, i : file = $local.key_definitions
{   status)

?? PUSH (LISTEXT := ON) ??
    VAR
      load_keys_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^load_keys_pdt_names,
        ^load_keys_pdt_params];
    VAR
      load_keys_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['INPUT', 1], ['I', 1], ['STATUS', 2]];
    VAR
      load_keys_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [
{ INPUT I }
      [[clc$optional_with_default, ^load_keys_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$file_value]],
{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];
    VAR
      load_keys_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (22) := '$local.key_definitions';
?? POP ??

    VAR
      byte_count: [STATIC] 2 .. 0fff(16) := 2,
      key: 1 .. 45,
      transparent : array [1..3] of ift$connection_attribute,
      acc_sel: amt$file_access_selections,
      parameter: clt$value;


    status.normal := TRUE;
    on := $pmt$sense_switches [];
    off := $pmt$sense_switches [];
    pmp$manage_sense_switches (on, off, current, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    IF NOT (2 IN current) THEN
      clp$scan_parameter_list (parameter_list, load_keys_pdt, status);
      IF NOT status.normal THEN
        RETURN
      IFEND;
      clp$get_value ('INPUT', 1, 1, clc$low, parameter, status);
      IF NOT status.normal THEN
        RETURN
      IFEND;
      file_in := parameter.file.local_file_name;
    IFEND;

    PUSH acc_sel: [1 .. 1];
    acc_sel^ [1].key := amc$access_mode;
    acc_sel^ [1].access_mode := $pft$usage_selections [pfc$shorten, pfc$append, pfc$read];
    amp$open (file_in, amc$segment, acc_sel, fid, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    amp$get_segment_pointer (fid, amc$sequence_pointer, seg_ptr, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    RESET seg_ptr.sequence_pointer;
    NEXT def_in IN seg_ptr.sequence_pointer;

    amp$open (file_out, amc$record, acc_sel, tfid, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    transparent[1].key := ifc$input_editing_mode;
    transparent[1].input_editing_mode := ifc$trans_edit;
    transparent[2].key := ifc$trans_character_mode;
    transparent[2].trans_character_mode := ifc$trans_char_forward;
    transparent[3].key := ifc$trans_length_mode;
    transparent[3].trans_length_mode := ifc$no_trans_len;
    ifp$store_term_conn_attributes (tfid, transparent, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    test_revision_number (status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    output_def_prolog (status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    load_controlware_programs (status); { activates at completion }
    IF NOT status.normal THEN
      RETURN
    IFEND;

    turn_on_light(1,3, status);
    def_out.prefix (1) := $CHAR (1e(16));
    def_out.prefix (2) := $CHAR (09(16));
    def_out.prefix (5) := ',';
    version_conflict := FALSE;
    FOR key := 1 TO 45 DO
      IF def_in^.defs [key].defined THEN
        def_out.prefix (3) := $CHAR (key + 30(16));
        IF def_in^.defs [key].half_duplex AND version_4 THEN
          def_out.prefix (4) := '4';
        ELSE
          def_out.prefix (4) := '1';
          IF def_in^.defs [key].half_duplex AND NOT(version_4) THEN
            version_conflict := TRUE;
          IFEND;
        IFEND;
        def_out.prefix (6) := $CHAR (byte_count DIV 100(16) + 60(16));
        def_out.prefix (7) := $CHAR ((byte_count DIV 10(16)) MOD 10(16) + 20(16));
        def_out.prefix (8) := $CHAR (byte_count MOD 10(16) + 60(16));
        IF NOT (def_in^.defs [key].hex_input) THEN
          convert_normal_def (key);
        ELSE
          convert_hex_def (key);
        IFEND;
        def_out.define (place) := '/';
        def_out.define (place + 1) := 'o';
        byte_count := byte_count + place DIV 2 + 1;
        def_out.define (place + 2) := $CHAR (0d(16));
        amp$put_next (tfid, #LOC (def_out), place + 10, address, status);
        IF NOT status.normal THEN
          RETURN
        IFEND;
      IFEND;
    FOREND;

    activate_controlware (status);
    transparent[1].input_editing_mode := ifc$normal_edit;
    transparent[2].trans_character_mode := ifc$trans_char_fwd_terminate;
    ifp$store_term_conn_attributes (tfid, transparent, status);
    amp$close (tfid, status);
    amp$close (fid, status);

    IF version_conflict THEN;
      osp$set_status_abnormal ('VK', 0, 'All definitions in FULL_DUPLEX', status);
    IFEND;

  PROCEND rap$load_keys;
?? OLDTITLE ??
?? NEWTITLE := '******  rap$display_keys  ******', EJECT ??
  PROCEDURE [XDCL, #GATE] rap$display_keys (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT display_keys_pdt (
{   input, i : file = $local.key_definitions
{   status)

?? PUSH (LISTEXT := ON) ??
    VAR
      display_keys_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^display_keys_pdt_names,
        ^display_keys_pdt_params];
    VAR
      display_keys_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['INPUT', 1], ['I', 1], ['STATUS', 2]];
    VAR
      display_keys_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor
        := [
{ INPUT I }
      [[clc$optional_with_default, ^display_keys_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$file_value]],
{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];
    VAR
      display_keys_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (22) :=
        '$local.key_definitions';
?? POP ??

    VAR
      key: 1 .. 45,
      out_str: string (24),
      len: integer,
      acc_sel: amt$file_access_selections,
      parameter: clt$value,
      key_id: [STATIC] array [1 .. 45] of string (5) := ['F1   ', 'F2   ', 'F3   ', 'F4   ', 'F5   ', 'F6   ',
        'F7   ', 'F8   ', 'F9   ', 'F10  ', 'F11  ', 'F12  ', 'F13  ', 'F14  ', 'F15  ', 'RTAB ', 'LTAB ',
        'NEXT ', 'DOWN ', 'UP   ', 'FWD  ', 'BKW  ', 'HELP ', 'ERASE', 'EDIT ', 'BACK ', 'LAB  ', 'DATA ',
        'STOP ', 'INSRT', 'DLETE', 'CLEAR', 'PRINT', 'PAD 1', 'PAD 2', 'PAD 3', 'PAD 4', 'PAD 5', 'PAD 6',
        'PAD 7', 'PAD 8', 'PAD 9', 'PAD 0', 'PAD ,', 'PAD .'];


    status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, display_keys_pdt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$get_value ('INPUT', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    file_in := parameter.file.local_file_name;
    PUSH acc_sel: [1 .. 1];
    acc_sel^ [1].key := amc$access_mode;
    acc_sel^ [1].access_mode := $pft$usage_selections [pfc$shorten, pfc$append, pfc$read];

    amp$open (file_in, amc$segment, acc_sel, fid, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    amp$get_segment_pointer (fid, amc$sequence_pointer, seg_ptr, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    amp$open (file_out, amc$record, acc_sel, tfid, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    RESET seg_ptr.sequence_pointer;
    NEXT def_in IN seg_ptr.sequence_pointer;
    FOR key := 1 TO 17 DO
      STRINGREP (out_str, len, ',', key: 3, ' ', key_id [key], ' ', $CHAR (6), $CHAR (1e(16)), 'D',
                 def_in^.defs [key].label, $CHAR (15(16)), $CHAR (1e(16)), 'E');
      IF (key MOD 4) = 1 THEN
        out_str (1) := ' ';
      IFEND;
      IF out_str (15) = $CHAR (0) THEN
        out_str (15, 7) := '       ';
      IFEND;
      amp$put_next (tfid, #LOC (out_str), #SIZE (out_str), address, status);
    FOREND;

    FOR key := 19 TO 45 DO
      STRINGREP (out_str, len, ',', key: 3, ' ', key_id [key], ' ', $CHAR (6), $CHAR (1e(16)), 'D',
                 def_in^.defs [key].label, $CHAR (15(16)), $CHAR (1e(16)), 'E');
      IF ((key - 1) MOD 4) = 1 THEN
        out_str (1) := ' ';
      IFEND;
      IF out_str (15) = $CHAR (0) THEN
        out_str (15, 7) := '       ';
      IFEND;
      amp$put_next (tfid, #LOC (out_str), #SIZE (out_str), address, status);
    FOREND;

    amp$close (tfid, status);
    amp$close (fid, status);

  PROCEND rap$display_keys;
?? OLDTITLE ??
?? NEWTITLE := '******  define_vkx_keys  ******', EJECT ??
  PROCEDURE define_vkx_keys (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT define_vkx_keys_pdt (
{   key_number, k : integer 1 .. 45 = $required
{   definition, d : string 0..63
{   carriage_return, cr : boolean = false
{   half_duplex, hd : boolean = false
{   hex_input, h : boolean = false
{   label, l : string
{   status)

?? PUSH (LISTEXT := ON) ??
    VAR
      define_vkx_keys_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^define_vkx_keys_pdt_names, ^define_vkx_keys_pdt_params];
    VAR
      define_vkx_keys_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 13] of
        clt$parameter_name_descriptor := [['KEY_NUMBER', 1], ['K', 1], ['DEFINITION', 2], ['D', 2], [
        'CARRIAGE_RETURN', 3], ['CR', 3], ['HALF_DUPLEX', 4], ['HD', 4], ['HEX_INPUT', 5], ['H', 5], ['LABEL',
        6], ['L', 6], ['STATUS', 7]];
    VAR
      define_vkx_keys_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 7] of
        clt$parameter_descriptor := [
{ KEY_NUMBER K }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 1, 45]],
{ DEFINITION D }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, 63]],
{ CARRIAGE_RETURN CR }
      [[clc$optional_with_default, ^define_vkx_keys_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$boolean_value]],
{ HALF_DUPLEX HD }
      [[clc$optional_with_default, ^define_vkx_keys_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$boolean_value]],
{ HEX_INPUT H }
      [[clc$optional_with_default, ^define_vkx_keys_pdt_dv5], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$boolean_value]],
{ LABEL L }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0,
        osc$max_string_size]],
{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];
    VAR
      define_vkx_keys_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';
    VAR
      define_vkx_keys_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';
    VAR
      define_vkx_keys_pdt_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';
?? POP ??

    VAR
      key: 1 .. 45,
      key_definition: [STATIC] key_def := ['', 0, FALSE, FALSE, FALSE, TRUE, ''],
      specified: boolean,
      parameter: clt$value,
      acc_sel: amt$file_access_selections;


    status.normal := TRUE;
    PUSH acc_sel: [1 .. 1];
    acc_sel^ [1].key := amc$access_mode;
    acc_sel^ [1].access_mode := $pft$usage_selections [pfc$shorten, pfc$append, pfc$read];

    amp$open (file_in, amc$segment, acc_sel, fid, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    amp$get_segment_pointer (fid, amc$sequence_pointer, seg_ptr, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    RESET seg_ptr.sequence_pointer;
    NEXT def_in IN seg_ptr.sequence_pointer;

    clp$scan_parameter_list (parameter_list, define_vkx_keys_pdt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$get_value ('KEY_NUMBER', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    key := parameter.int.value;
    IF (key = next_key) THEN
      osp$set_status_abnormal ('VK', 0, 'You can not define the next key', status);
      RETURN
    ELSEIF (key = def_in^.mk) OR (key = def_in^.ck) THEN
      osp$set_status_abnormal ('VK', 1, 'This key used by the screen_edit routine', status);
      RETURN
    ELSEIF (key = def_in^.fk) OR (key = def_in^.bk) THEN
      osp$set_status_abnormal ('VK', 2, 'This key used by the screen_scrolling routine', status);
      RETURN
    IFEND;

    clp$get_value ('DEFINITION', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    key_definition.definition := parameter.str.value;
    key_definition.def_length := parameter.str.size;
    IF key_definition.def_length = 0 THEN
      key_definition.defined := FALSE;
    ELSE
      key_definition.defined := TRUE;
    IFEND;

    clp$get_value ('CARRIAGE_RETURN', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    key_definition.carriage_return := parameter.bool.value;

    clp$get_value ('HALF_DUPLEX', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    key_definition.half_duplex := parameter.bool.value;

    clp$get_value ('HEX_INPUT', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    key_definition.hex_input := parameter.bool.value;
    IF key_definition.hex_input THEN
      #translate (osv$lower_to_upper, key_definition.definition, key_definition.definition);
    IFEND;

    clp$test_parameter ('LABEL', specified, status);
    IF specified THEN
      clp$get_value ('LABEL', 1, 1, clc$low, parameter, status);
      IF NOT status.normal THEN
        RETURN
      IFEND;
      key_definition.label := parameter.str.value;
    ELSE
      #translate (osv$lower_to_upper, key_definition.definition, key_definition.label);
    IFEND;

    def_in^.defs [key] := key_definition;

    amp$set_segment_eoi (fid, seg_ptr, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    amp$close (fid, status);

  PROCEND define_vkx_keys;
?? OLDTITLE ??
?? NEWTITLE := '******  include_screen_edit ******', EJECT ??
  PROCEDURE include_screen_edit (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{   PDT inc_screen_edit_pdt (
{    mark_key, mk : integer 1..45 =14
{    copy_key, ck : integer 1..45 =15
{    on : boolean = true
{    status)

?? PUSH (LISTEXT := ON) ??
    VAR
      inc_screen_edit_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^inc_screen_edit_pdt_names, ^inc_screen_edit_pdt_params];
    VAR
      inc_screen_edit_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
        clt$parameter_name_descriptor := [['MARK_KEY', 1], ['MK', 1], ['COPY_KEY', 2], ['CK', 2], ['ON', 3],
        ['STATUS', 4]];
    VAR
      inc_screen_edit_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
        clt$parameter_descriptor := [
{ MARK_KEY MK }
      [[clc$optional_with_default, ^inc_screen_edit_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$integer_value, 1, 45]],
{ COPY_KEY CK }
      [[clc$optional_with_default, ^inc_screen_edit_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$integer_value, 1, 45]],
{ ON }
      [[clc$optional_with_default, ^inc_screen_edit_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$boolean_value]],
{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];
    VAR
      inc_screen_edit_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := '15';
    VAR
      inc_screen_edit_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := '14';
    VAR
      inc_screen_edit_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';
?? POP ??

    VAR
      option_on: boolean,
      acc_sel: amt$file_access_selections,
      parameter: clt$value;


    status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, inc_screen_edit_pdt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$get_value ('MARK_KEY', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    IF next_key = parameter.int.value THEN
      osp$set_status_abnormal ('VK', 0, 'You can not define the next key', status);
      RETURN
    IFEND;
    mark_key := parameter.int.value;

    clp$get_value ('COPY_KEY', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    IF next_key = parameter.int.value THEN
      osp$set_status_abnormal ('VK', 0, 'You can not define the next key', status);
      RETURN
    IFEND;
    copy_key := parameter.int.value;

    clp$get_value ('ON', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    option_on := parameter.bool.value;

    PUSH acc_sel: [1 .. 1];
    acc_sel^ [1].key := amc$access_mode;
    acc_sel^ [1].access_mode := $pft$usage_selections [pfc$shorten, pfc$append, pfc$read];

    amp$open (file_in, amc$segment, acc_sel, fid, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    amp$get_segment_pointer (fid, amc$sequence_pointer, seg_ptr, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    RESET seg_ptr.sequence_pointer;
    NEXT def_in IN seg_ptr.sequence_pointer;
    IF (mark_key = def_in^.fk) OR (mark_key = def_in^.bk) THEN
      osp$set_status_abnormal ('VK', 2, 'This key used by the screen_scrolling routine', status);
      RETURN
    ELSEIF (copy_key = def_in^.fk) OR (copy_key = def_in^.bk) THEN
      osp$set_status_abnormal ('VK', 2, 'This key used by the screen_scrolling routine', status);
      RETURN
    IFEND;

    def_in^.include_screen_edit := option_on;
    IF def_in^.mk <> 0 THEN
      def_in^.defs [def_in^.mk].label := '       ';
      def_in^.defs [def_in^.ck].label := '       ';
    IFEND;
    IF option_on THEN
      def_in^.defs [mark_key].defined := FALSE;
      def_in^.defs [copy_key].defined := FALSE;
      def_in^.defs [mark_key].label := ' MARK  ';
      def_in^.defs [copy_key].label := ' COPY  ';
      def_in^.mk := mark_key;
      def_in^.ck := copy_key;
    ELSE
      def_in^.mk := 0;
      def_in^.ck := 0;
    IFEND;

    amp$set_segment_eoi (fid, seg_ptr, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    amp$close (fid, status);

  PROCEND include_screen_edit;
?? OLDTITLE ??
?? NEWTITLE := '******  include_screen_scroll ******', EJECT ??
  PROCEDURE include_screen_scroll (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{   PDT inc_screen_scroll_pdt (
{    forward_key, fk : integer 1..45 =35
{    backward_key, bk : integer 1..45 =41
{    on : boolean = true
{    status)

?? PUSH (LISTEXT := ON) ??
    VAR
      inc_screen_scroll_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^inc_screen_scroll_pdt_names, ^inc_screen_scroll_pdt_params];
    VAR
      inc_screen_scroll_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
        clt$parameter_name_descriptor := [['BACKWARD_KEY', 1], ['BK', 1], ['FORWARD_KEY', 2], ['FK', 2], [
        'ON', 3], ['STATUS', 4]];
    VAR
      inc_screen_scroll_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
        clt$parameter_descriptor := [
{ BACKWARD_KEY BK }
      [[clc$optional_with_default, ^inc_screen_scroll_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$integer_value, 1, 45]],
{ FORWARD_KEY FK }
      [[clc$optional_with_default, ^inc_screen_scroll_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$integer_value, 1, 45]],
{ ON }
      [[clc$optional_with_default, ^inc_screen_scroll_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$boolean_value]],
{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];
    VAR
      inc_screen_scroll_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := '35';
    VAR
      inc_screen_scroll_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := '41';
    VAR
      inc_screen_scroll_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';
?? POP ??

    VAR
      option_on: boolean,
      acc_sel: amt$file_access_selections,
      parameter: clt$value;


    status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, inc_screen_scroll_pdt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$get_value ('BACKWARD_KEY', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    IF next_key = parameter.int.value THEN
      osp$set_status_abnormal ('VK', 0, 'You can not define the next key', status);
      RETURN
    IFEND;
    backward_key := parameter.int.value;

    clp$get_value ('FORWARD_KEY', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    IF next_key = parameter.int.value THEN
      osp$set_status_abnormal ('VK', 0, 'You can not define the next key', status);
      RETURN
    IFEND;
    forward_key := parameter.int.value;

    clp$get_value ('ON', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    option_on := parameter.bool.value;

    PUSH acc_sel: [1 .. 1];
    acc_sel^ [1].key := amc$access_mode;
    acc_sel^ [1].access_mode := $pft$usage_selections [pfc$shorten, pfc$append, pfc$read];

    amp$open (file_in, amc$segment, acc_sel, fid, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    amp$get_segment_pointer (fid, amc$sequence_pointer, seg_ptr, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    RESET seg_ptr.sequence_pointer;
    NEXT def_in IN seg_ptr.sequence_pointer;
    IF (backward_key = def_in^.mk) OR (backward_key = def_in^.ck) THEN
      osp$set_status_abnormal ('VK', 1, 'This key used by the screen_edit routine', status);
      RETURN
    ELSEIF (forward_key = def_in^.mk) OR (forward_key = def_in^.ck) THEN
      osp$set_status_abnormal ('VK', 1, 'This key used by the screen_edit routine', status);
      RETURN
    IFEND;

    def_in^.include_screen_scroll := option_on;
    IF def_in^.fk <> 0 THEN
      def_in^.defs [def_in^.fk].label := '       ';
      def_in^.defs [def_in^.bk].label := '       ';
    IFEND;
    IF option_on THEN
      def_in^.defs [forward_key].defined := FALSE;
      def_in^.defs [backward_key].defined := FALSE;
      def_in^.defs [forward_key].label := 'FORWARD';
      def_in^.defs [backward_key].label := 'BCKWARD';
      def_in^.fk := forward_key;
      def_in^.bk := backward_key;
    ELSE
      def_in^.fk := 0;
      def_in^.bk := 0;
    IFEND;

    amp$set_segment_eoi (fid, seg_ptr, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    amp$close (fid, status);

  PROCEND include_screen_scroll;
?? OLDTITLE ??
?? NEWTITLE := '******  quit  ******', EJECT ??
  PROCEDURE quit (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT quit_pdt (
{   load, l : boolean = true
{   status)

?? PUSH (LISTEXT := ON) ??
    VAR
      quit_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^quit_pdt_names, ^quit_pdt_params];
    VAR
      quit_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['LOAD', 1], ['L', 1], ['STATUS', 2]];
    VAR
      quit_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [
{ LOAD L }
      [[clc$optional_with_default, ^quit_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$boolean_value]],
{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];
    VAR
      quit_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';
?? POP ??

    VAR
      parameter: clt$value;


    status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, quit_pdt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$get_value ('LOAD', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    IF parameter.bool.value THEN
      on := $pmt$sense_switches [2];
      off := $pmt$sense_switches [];
      pmp$manage_sense_switches (on, off, current, status);
      IF NOT status.normal THEN
        RETURN
      IFEND;
      rap$load_keys (parameter_list, status);
    IFEND;

    on := $pmt$sense_switches [];
    off := $pmt$sense_switches [1,2];
    pmp$manage_sense_switches (on, off, current, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$end_scan_command_file (vkx_utility_name, status);

  PROCEND quit;
?? OLDTITLE ??
?? NEWTITLE := '******  rap$edit_keys  ******', EJECT ??
  PROCEDURE [XDCL, #GATE] rap$edit_keys (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT edit_keys_pdt (
{   input, i : file = $local.key_definitions
{   status)

?? PUSH (LISTEXT := ON) ??
    VAR
      edit_keys_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^edit_keys_pdt_names,
        ^edit_keys_pdt_params];
    VAR
      edit_keys_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
        clt$parameter_name_descriptor := [['INPUT', 1], ['I', 1], ['STATUS', 2]];
    VAR
      edit_keys_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [
{ INPUT I }
      [[clc$optional_with_default, ^edit_keys_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$file_value]],
{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];
    VAR
      edit_keys_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (22) := '$local.key_definitions';
?? POP ??

    VAR
      parameter: clt$value;


{ table edit_keys_command_list
{  command (define_vkx_keys, defvk      , defk), define_vkx_keys
{  command (include_screen_edit, incse  , ince), include_screen_edit
{  command (include_screen_scroll, incss, incs), include_screen_scroll
{  command (load_keys, loak                   ), rap$load_keys
{  command (quit, qui, end              , e   ), quit

?? PUSH (LISTEXT := ON) ??
VAR
  edit_keys_command_list: [STATIC, READ] ^clt$command_table := ^edit_keys_command_list_entries,

  edit_keys_command_list_entries: [STATIC, READ] array [1 .. 15] of  clt$command_table_entry := [
  {} ['DEFINE_VKX_KEYS                ', clc$nominal_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^define_vkx_keys],
  {} ['DEFK                           ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^define_vkx_keys],
  {} ['DEFVK                          ', clc$alias_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^define_vkx_keys],
  {} ['E                              ', clc$abbreviation_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^quit],
  {} ['END                            ', clc$alias_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^quit],
  {} ['INCE                           ', clc$abbreviation_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^include_screen_edit],
  {} ['INCLUDE_SCREEN_EDIT            ', clc$nominal_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^include_screen_edit],
  {} ['INCLUDE_SCREEN_SCROLL          ', clc$nominal_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^include_screen_scroll],
  {} ['INCS                           ', clc$abbreviation_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^include_screen_scroll],
  {} ['INCSE                          ', clc$alias_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^include_screen_edit],
  {} ['INCSS                          ', clc$alias_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^include_screen_scroll],
  {} ['LOAD_KEYS                      ', clc$nominal_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^rap$load_keys],
  {} ['LOAK                           ', clc$abbreviation_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^rap$load_keys],
  {} ['QUI                            ', clc$alias_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^quit],
  {} ['QUIT                           ', clc$nominal_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^quit]];
?? POP ??

    status.normal := TRUE;
    on := $pmt$sense_switches [1];
    off := $pmt$sense_switches [2];
    pmp$manage_sense_switches (on, off, current, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$scan_parameter_list (parameter_list, edit_keys_pdt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$get_value ('INPUT', 1, 1, clc$low, parameter, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    file_in := parameter.file.local_file_name;

    clp$push_utility (vkx_utility_name, clc$global_command_search, edit_keys_command_list, NIL, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$scan_command_file (command_file, vkx_utility_name, vkx_prompt_string, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    clp$pop_utility (status);

  PROCEND rap$edit_keys;
?? OLDTITLE ??
MODEND ram$create_key_definitions;
*DECK DECK=RAM$CREATE_KEY_DEFS_PROG_DESC EXPAND=TRUE
create_program_description name=(edit_keys edit_key edik) ..
    starting_procedure=rap$edit_keys ..
    libraries=($system.osf$site_command_library osf$task_services_library) ..
    load_map=$null ..
    load_map_options=none ..
    debug_mode=off

create_program_description name=(load_keys load_key loak) ..
    starting_procedure=rap$load_keys ..
    libraries=($system.osf$site_command_library osf$task_services_library) ..
    load_map=$null ..
    load_map_options=none ..
    debug_mode=off

create_program_description name=(display_keys display_key disk) ..
    starting_procedure=rap$display_keys ..
    libraries=($system.osf$site_command_library osf$task_services_library) ..
    load_map=$null ..
    load_map_options=none ..
    debug_mode=off
*DECK DECK=RAM$CREATE_OBJECT_LIBRARY EXPAND=TRUE
create_program_description name=(create_object_library, creol, ocu) ..
      starting_procedure=ocp$_create_object_library libraries=('$system.ocu.bound_product' ..
      osf$task_services_library) termination_error_level=warning load_map_options=none ..
      load_map=$null debug_mode=off
*DECK DECK=RAM$CREATE_ORDER_DEFINITION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: CREATE_ORDER_DEFINITION Subutility.' ??
MODULE ram$create_order_definition;

{ PURPOSE:
{   This module contains the command to establish the CREATE_ORDER_DEFINITION
{   subutility environment.
{
{ DESIGN:
{   The command table and two memory sequences for processing
{   order definitions are created.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$pacs_processor_version
*copyc rac$sif_file_name
*copyc rac$subproduct_info_level
*copyc cld$path_description
*copyc rae$package_software_cc
*copyc rat$order_contents_list
*copyc rat$packing_list_types
*copyc rat$scratch_segment
*copyc rat$sequence_descriptor_types
*copyc rat$subproduct_info_types
*copyc rat$tape_information
?? POP ??
*copyc clp$get_value
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$scan_command_file
*copyc clp$scan_parameter_list
*copyc mmp$create_scratch_segment
*copyc mmp$create_segment
*copyc mmp$delete_scratch_segment
*copyc mmp$delete_segment
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pmp$get_date
*copyc pmp$get_time
*copyc rap$add_name_to_path_ref
*copyc rap$get_file_path_and_ref

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    rav$creod_scratch_segment: [XDCL] rat$scratch_segment;

  VAR
    rav$creod_utility_name: [XDCL] ost$name := 'CREATE_ORDER_DEFINITION';

  VAR
    rav$order_contents_count: [XDCL] rat$subproduct_count;

  VAR
    rav$order_contents_list_p: [XDCL] ^rat$order_contents_list;

  VAR
    rav$packing_list_header_p: [XDCL] ^rat$packing_list_header;

  VAR
    rav$packing_list_seq_p: [XDCL] ^rat$packing_list_sequence;

  VAR
    rav$tape_information: [XDCL] rat$tape_information;

?? TITLE := '[XDCL] rap$create_order_definition', EJECT ??

{ PURPOSE:
{   This procedure opens the utility and creates a scratch sequence and
{   the packing list sequence.
{
{ DESIGN:
{   The utility is opened and the two sequences are created.
{
{
{
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$create_order_definition
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt creod_pdt (
{   status            : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    creod_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^creod_pdt_names, ^creod_pdt_params
      ];

  VAR
    creod_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
      clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    creod_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

{ table n=creod_command_table t=command s=xdcl
{ command n=(add_subproduct, adds) p=rap$add_subproduct cm=xref
{ command n=(define_order, defo) p=rap$define_order cm=xref
{ command n=(define_tape_attributes, define_tape_attribute, defta) p=rap$define_tape_attributes cm=xref
{ command n=(determine_number_of_tapes, detnot) p=rap$determine_number_of_tapes cm=xref
{ command n=(write_definition, wrid) p=rap$write_definition cm=xref
{ command n=(quit, qui) p=rap$quit_creod cm=xref
{ tablend

?? PUSH (LISTEXT := ON) ??
VAR
  creod_command_table: [XDCL, READ] ^clt$command_table := ^creod_command_table_entries,

  creod_command_table_entries: [STATIC, READ] array [1 .. 16] of  clt$command_table_entry := [
  {} ['ADDS                           ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rap$add_subproduct],
  {} ['ADD_SUBPRODUCT                 ', clc$nominal_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rap$add_subproduct],
  {} ['ADD_SUBPRODUCTS                ', clc$alias_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rap$add_subproduct],
  {} ['DEFINE_ORDER                   ', clc$nominal_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rap$define_order],
  {} ['DEFINE_ORDERS                  ', clc$alias_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rap$define_order],
  {} ['DEFINE_TAPE_ATTRIBUTE          ', clc$alias_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$define_tape_attributes],
  {} ['DEFINE_TAPE_ATTRIBUTES         ', clc$nominal_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$define_tape_attributes],
  {} ['DEFO                           ', clc$abbreviation_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rap$define_order],
  {} ['DEFTA                          ', clc$abbreviation_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$define_tape_attributes],
  {} ['DETERMINE_NUMBER_OF_TAPES      ', clc$nominal_entry, clc$hidden_entry, 5,
        clc$automatically_log, clc$linked_call, ^rap$determine_number_of_tapes],
  {} ['DETNOT                         ', clc$abbreviation_entry, clc$hidden_entry, 5,
        clc$automatically_log, clc$linked_call, ^rap$determine_number_of_tapes],
  {} ['QUI                            ', clc$abbreviation_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^rap$quit_creod],
  {} ['QUIT                           ', clc$nominal_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^rap$quit_creod],
  {} ['WRID                           ', clc$abbreviation_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^rap$write_definition],
  {} ['WRITE_DEFINITION               ', clc$nominal_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^rap$write_definition],
  {} ['WRITE_DEFINITIONS              ', clc$alias_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^rap$write_definition]];

  PROCEDURE [XREF] rap$add_subproduct (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$define_order (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$define_tape_attributes (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$quit_creod (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$write_definition (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$determine_number_of_tapes (parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? POP ??


    VAR
      info_segment_pointer: mmt$segment_pointer,
      local_status: ost$status,
      scratch_segment_pointer: amt$segment_pointer,
      write_definition_needed_flag_p: ^BOOLEAN;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF info_segment_pointer.seq_pointer <> NIL THEN
        mmp$delete_segment (info_segment_pointer, 1, ignore_status);
        info_segment_pointer.seq_pointer := NIL;
      IFEND;

      IF scratch_segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (scratch_segment_pointer, ignore_status);
        scratch_segment_pointer.sequence_pointer := NIL;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    rav$order_contents_count := 0;
    rav$order_contents_list_p := NIL;
    rav$packing_list_header_p := NIL;
    rav$packing_list_seq_p := NIL;
    rav$tape_information.tape_type := 'UNKNOWN';

    clp$scan_parameter_list (parameter_list, creod_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    info_segment_pointer.kind := mmc$sequence_pointer;
    info_segment_pointer.seq_pointer := NIL;
    scratch_segment_pointer.kind := amc$sequence_pointer;
    scratch_segment_pointer.sequence_pointer := NIL;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      mmp$create_segment (NIL, mmc$sequence_pointer, 1, info_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      rav$packing_list_seq_p := info_segment_pointer.seq_pointer;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, scratch_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      rav$creod_scratch_segment.sequence_p := scratch_segment_pointer.sequence_pointer;
      RESET rav$creod_scratch_segment.sequence_p;

      NEXT write_definition_needed_flag_p IN rav$creod_scratch_segment.sequence_p;
      write_definition_needed_flag_p^ := FALSE;
      NEXT rav$creod_scratch_segment.reset_p IN rav$creod_scratch_segment.sequence_p;

      clp$push_utility (rav$creod_utility_name, clc$global_command_search, creod_command_table, NIL, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$scan_command_file (clc$current_command_input, rav$creod_utility_name, 'CREOD', status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$pop_utility (status);

    END /main/;

    osp$disestablish_cond_handler;

    IF info_segment_pointer.seq_pointer <> NIL THEN
      mmp$delete_segment (info_segment_pointer, 1, local_status);
      info_segment_pointer.seq_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF scratch_segment_pointer.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (scratch_segment_pointer, local_status);
      scratch_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

  PROCEND rap$create_order_definition;

MODEND ram$create_order_definition;
*DECK DECK=RAM$CREATE_PROGRAM_PROFILE EXPAND=TRUE
PROCEDURE (osm$crepp) create_program_profile, crepp (
  target_text, tt: file = $required
  file, files, f: list of file = $optional
  parameter, p: string = $optional
  library, libraries, l: list of file = $optional
  module, modules, m: list of program_name = $optional
  starting_procedure, sp: program_name = $optional
  profile_order, po: key
      (module_program_unit, mpu)
      (program_unit, pu)
      (time, t)
    keyend = $optional
  program_unit_class, puc: key
      all, local, remote
    keyend = $optional
  number, n: any of
      key
        all
      keyend
      integer 0..4294967295
    anyend = $optional
  output, o: file = output
  stack_size, ss: integer 1..2147483648 = 2000000
  status)

  MEASURE_PROGRAM_EXECUTION

    sp_parameter=' '
    IF $specified(starting_procedure) THEN
      sp_parameter=' starting_procedure=$string(starting_procedure)'
    IFEND
    m_parameter=' '
    IF $specified(modules) THEN
      m_parameter=' modules=$apply(modules $string(x))'
    IFEND

    include_command '    set_program_description target_text=target_text file=file library=library'//..
' stack_size=stack_size '//m_parameter//sp_parameter

    execute_instrumented_task parameter=parameter

    display_program_profile profile_order=profile_order program_unit_class=program_unit_class number=number ..
          output=output

  QUIT

PROCEND create_program_profile
*DECK DECK=RAM$CREATE_SCL_VARIABLES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: Interfaces for the Creation of SCL Variables.' ??
MODULE ram$create_scl_variables;

{ PURPOSE:
{   This module contains the interfaces to create SCL variables.
{   Currently only status variables can be created.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
?? POP ??
*copyc clp$create_procedure_variable

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??


?? TITLE := '[XDCL] rap$create_scl_status_variable', EJECT ??

{ PURPOSE:
{   This procedure ..
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$create_scl_status_variable
    (    name: clt$variable_name_reference;
     VAR status: ost$status);


{ type
{   type_status: status
{ typend

?? PUSH (LISTEXT := ON) ??

    VAR
      type_specification: [STATIC, READ, cls$declaration_section] record
        header: clt$type_specification_header,
        name: string (11),
      recend := [[1, 11, clc$status_type], 'TYPE_STATUS'];

?? POP ??

    status.normal := TRUE;

    clp$create_procedure_variable (name, clc$local_scope, clc$read_write, clc$immediate_evaluation,
          #SEQ(type_specification), NIL, status);

  PROCEND rap$create_scl_status_variable;

MODEND ram$create_scl_variables;
*DECK DECK=RAM$CREATE_SUBPRODUCT_CORR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: CREATE_SUBPRODUCT_CORRECTION Subutility.' ??
MODULE ram$create_subproduct_corr;

{ PURPOSE:
{   This module contains the command to establish the CREATE_SUBPRODUCT_CORRECTION
{   subutility environment.
{
{ DESIGN:
{   This module sets up the environment for the CREATE_SUBPRODUCT_CORRECTION
{   utility.
{
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rat$correction_process_record
?? POP ??
*copyc clp$begin_utility
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc mmp$create_segment
*copyc mmp$delete_segment
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
*copyc rap$reset_correction_environ

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    rav$correction_process_record: [XDCL] rat$correction_process_record;

  VAR
    rav$cresc_utility_name: [XDCL] ost$name := 'CREATE_SUBPRODUCT_CORRECTION';

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$create_subproduct_corr', EJECT ??

{ PURPOSE:
{   This procedure opens the utility.
{
{ DESIGN:
{   This procedure creates and initializes the correction process record.
{   The correction process record is used by the
{   CREATE_SUBPRODUCT_CORRECTION utility to communicate information among
{   the various utility subcommands.
{
{   A memory sequence is created.  This sequence will have subproduct
{   correction information written to it by the other utility subcommands.
{   When a correction has been generated, the memory sequence will be
{   written to a permanent file.
{
{   The utility session is opened.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$create_subproduct_corr
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE cresc_pdt (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 7, 12, 12, 46, 9, 596], clc$command, 1, 1, 0, 0, 0, 0, 1, 'CRESC_PDT'],
            [['STATUS                         ', clc$nominal_entry, 1]], [
{ PARAMETER 1
      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


{ table n=cresc_command_table t=command s=xdcl
{ command n=(change_correction_attributes, chaca) p=rap$change_correction_attrib cm=xref
{ command n=(define_correction, defc) p=rap$define_correction cm=xref
{ command n=(display_correction_attributes, disca) p=rap$display_correction_attrib cm=xref
{ command n=(generate_correction, genc) p=rap$generate_correction_pacs cm=xref
{ command n=(quit, qui) p=rap$quit_cresc cm=xref
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  cresc_command_table: [XDCL, READ] ^clt$command_table := ^cresc_command_table_entries,

  cresc_command_table_entries: [STATIC, READ] array [1 .. 10] of clt$command_table_entry := [
  {} ['CHACA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^rap$change_correction_attrib],
  {} ['CHANGE_CORRECTION_ATTRIBUTES   ', clc$nominal_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^rap$change_correction_attrib],
  {} ['DEFC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^rap$define_correction],
  {} ['DEFINE_CORRECTION              ', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^rap$define_correction],
  {} ['DISCA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$display_correction_attrib],
  {} ['DISPLAY_CORRECTION_ATTRIBUTES  ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$display_correction_attrib],
  {} ['GENC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^rap$generate_correction_pacs],
  {} ['GENERATE_CORRECTION            ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^rap$generate_correction_pacs],
  {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^rap$quit_cresc],
  {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^rap$quit_cresc]];

  PROCEDURE [XREF] rap$change_correction_attrib
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$define_correction
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$display_correction_attrib
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$generate_correction_pacs
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$quit_cresc
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??


    CONST
      prompt_size = 5,
      prompt_value = 'CRESC';

    VAR
      local_status: ost$status,
      memory_segment_pointer: mmt$segment_pointer,
      utility_attributes_p: ^clt$utility_attributes;

?? OLDTITLE ??
?? NEWTITLE := 'abort_handler', EJECT ??
{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the files or memory segments are open, they will be closed before the
{   the procedure returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF memory_segment_pointer.seq_pointer <> NIL THEN
        mmp$delete_segment (memory_segment_pointer, 1, ignore_status);
      IFEND;

      rap$reset_correction_environ (rav$correction_process_record, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      { Create the segment that will contain the memory sequence.

      mmp$create_segment (NIL, mmc$sequence_pointer, 1, memory_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      { Initialize the correction process record.

      rav$correction_process_record.new_subproduct_info_pointers.subproduct_info_seq_p :=
            memory_segment_pointer.seq_pointer;
      rav$correction_process_record.correction_in_progress := FALSE;
      rav$correction_process_record.base_level_sif.file_opened := FALSE;
      rav$correction_process_record.current_level_sif.file_opened := FALSE;
      rav$correction_process_record.previous_correction_sif.file_opened := FALSE;

      PUSH utility_attributes_p: [1 .. 3];
      utility_attributes_p^ [1].key := clc$utility_command_search_mode;
      utility_attributes_p^ [1].command_search_mode := clc$global_command_search;
      utility_attributes_p^ [2].key := clc$utility_command_table;
      utility_attributes_p^ [2].command_table := cresc_command_table;
      utility_attributes_p^ [3].key := clc$utility_prompt;
      utility_attributes_p^ [3].prompt.size := prompt_size;
      utility_attributes_p^ [3].prompt.value := prompt_value;

      clp$begin_utility (rav$cresc_utility_name, utility_attributes_p^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$include_file (clc$current_command_input, prompt_value, rav$cresc_utility_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$end_utility (rav$cresc_utility_name, status);

    END /main/;

    IF memory_segment_pointer.seq_pointer <> NIL THEN
      mmp$delete_segment (memory_segment_pointer, 1, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$create_subproduct_corr;

MODEND ram$create_subproduct_corr;
*DECK DECK=RAM$CRECOM EXPAND=TRUE
.PROC,CRECOM*I,
R "- Record name receiving comment"    = (*F),
T "- Type of record receiving comment" = (ABS,CAP,OVL,PP,PPU,REL),
C "- dollar delimited Comment string"  = (*A,
                              *N=$COPYRIGHT CONTROL DATA SYSTEMS INC. 1984$),
L "- Library file name"                = (*N=#FILE,*F),
.
.HELP
 The CRECOM procedure CREates COMments on library file records.

 Parameter   Default   Description
   Name       Value

   r                   record to which comment is added
   t                   type of record receiving comment
  [c]       See HELP   dollar sign delimited comment string
  [l]                  library file containing the record

.HELP,R
 The R parameter names the records to which comments are added.
.HELP,T
 The T parameter selects the type of record being modified.
.HELP,C
 The C parameter value specifies a 1-40 character comment string.
 The default value is COPYRIGHT CONTROL DATA SYSTEMS INC. 1984.
.HELP,L
 The L parameter names the library to which the record is written.
 The default value is the file containing this procedure.
.ENDHELP
GETFILE,L,L,A=YES.
$LIBEDIT,P=L,N=L,B=0,#L=YYYYERR,LO=EM,I=YYYYCOM,U=L.
$SKIP,NOERROR.
  $EXIT.
  $REWIND,YYYYERR.
  $COPYEI,YYYYERR,OUTPUT.
  $UNLOAD,YYYYCOM,YYYYERR,ZZZZZG2.
  $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    $EXIT. CRECOM *TERMINATED*
  $ENDIF,TERMINATED.
  $REVERT,ABORT. CREATE COMMENT R --> L FAILED
$ENDIF,NOERROR.
$UNLOAD,YYYYERR,YYYYCOM,ZZZZZG2.
$IFE,.NOT.((FILE(L,PM)).AND.(FILE(L,WR))),REWRITE.
  REPFILE,L,L,DEFINE=YES.
$ENDIF,REWRITE.
.IFE,FILE(L,.NOT.AS),FILEPRM.
  $UNLOAD,L.
.ELSE,FILEPRM.
  $LIBRARY,L/D.
  $LIBRARY,L/A.
.ENDIF,FILEPRM.
$REVERT. COMMENT ADDED TO T/R --> L
.DATA,YYYYCOM
*COMMENT T/R C
/EOR
*DECK DECK=RAM$CREFILE EXPAND=TRUE
.PROC,CREFILE*I,
LFN "- Local File Name"                = (*F),
PFN "- Permanent File Name"            = (*N=,*F),
CT "- Catalog Type"                    = (*N=S,P,S,PU,SPRIV,PUBLIC,PR,PRIVATE),
M "- Mode of file access"              = (*N=R,E=E,R=R,EXECUTE=E,READ=R),
DEFINE "- YES causes DIRECT file made" = (*N=NO,YES,NO),
.
.HELP
 The CREFILE procedure saves local files as either INDIRECT or
 DIRECT access permanent files depending upon validation limits.
 This procedure CREates INDIRECT FILEs when possible to conserve disk
 space. The procedure aborts if the permanent file already exists.

 Parameter   Default   Description
   Name       Value

   lfn                 local file name by which the file is accessed
  [pfn]       lfn      permanent file name of the stored file
  [ct]         s       file catalog type, which limits access
  [m]          r       access mode of the file
  [define]     no      YES value causes DIRECT access file creation

.HELP,LFN
 The LFN parameter selects the name by which the file is accessed.
.HELP,PFN
 The PFN parameter selects the name by which the file is stored.
 The default is the value specified for the LFN parameter.
.HELP,CT
 The CT parameter specifies the file permissions of the created file.
 Options are:  S | SPRIV        - for semiprivate files (default value)
               PU | PUBLIC      - for public files
               P | PR | PRIVATE - for private files
.HELP,M
 The M parameter selects the Mode of access for the file.
 Options are:  R | READ     - for read access (default value)
               E | EXECUTE  - for execute access
.HELP,DEFINE
 The DEFINE parameter forces creation of a DIRECT access file.
 Options are: NO   - create an INDIRECT access file (default value)
              YES  - create a DIRECT access file

.ENDHELP
$REWIND,LFN.
.IFE,$PFN$.EQ.$$,NOPFN.
  $REVERT,EX.CREFILE,LFN,LFN,CT,M,DEFINE.
.ENDIF,NOPFN.
.IFE,(($DEFINE$.EQ.$NO$).AND.(FILE(LFN,AS))),FILEIND.
  $SAVE,LFN=PFN/#CT=CT,#M=M.
  $GET,YYYYCRE=PFN/NA.
.ENDIF,FILEIND.
$IFE,.NOT.FILE(YYYYCRE,AS),INDFAIL.
  .IFE,FILE(LFN,AS),FILELOC.
    $#DEFINE,YYYYCRE=PFN/#CT=CT,#M=M.
    $COPYEI,LFN,YYYYCRE.
    $REWIND,LFN.
    $UNLOAD,YYYYCRE.
    $REVERT. FILE LFN CREATED --> PFN(*D)
  .ELSE,FILELOC.
    .IFE,OT.EQ.TXO,TERMINAL.
      $NOTE,OUTPUT,NR.+ LOCAL FILE LFN DOES NOT EXIST.
      $NOTE,OUTPUT,NR.+ ENTER DATA FOR LOCAL FILE YOU WISH TO CREATE,
      $NOTE,OUTPUT,NR.+ TERMINATE INPUT WITH CARRIAGE RETURN.
      $COPYBF,,LFN.
      $REVERT,EX.CREFILE,LFN,PFN,CT,M,DEFINE.
    .ELSE,TERMINAL.
      $REVERT,ABORT. LOCAL FILE LFN DOES NOT EXIST
    .ENDIF,TERMINAL.
  .ENDIF,FILELOC.
  $EXIT. DEFINE OF FILE FAILED
  $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    $EXIT. CREFILE *TERMINATED*
  $ENDIF,TERMINATED.
  $REVERT,ABORT. FILE PFN ALREADY EXISTS
$ELSE,INDFAIL.
  $VERIFY,YYYYCRE,LFN,N,L=0,A,R.
  $UNLOAD,YYYYCRE.
  $REVERT. FILE LFN CREATED --> PFN(*I)
  $EXIT. FILE NOT SAVED CORRECTLY
  $UNLOAD,YYYYCRE.
  $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    $EXIT. CREFILE *TERMINATED*
  $ENDIF,TERMINATED.
  $REVERT,ABORT. FILE PFN ALREADY EXISTS
$ENDIF,INDFAIL.
/EOR
*DECK DECK=RAM$CRELIB EXPAND=TRUE
.PROC,CRELIB*I,
LFN "- Local File Name of NOS records" = (*F),
PFN "- Permanent File Name of NOS file"= (*N=,*F),
UN "- User Name of NOS file"           = (*N=,*F),
L "- file to which Library is written" = (*N=,*F),
N "- Name of library"                  = (*N=,*F),
I "- LIBEDIT input directive file"     = (*N=0,*F),
.
.HELP
 The CRELIB procedure CREates a user LIBrary file from NOS records.
 Requires CATALOG binaries with GENCAT entry point.

 Parameter   Default   Description
   Name       Value

   lfn                 local file name containing NOS records
  [pfn]       lfn      permanent file name of the stored file
  [un]                 user name in which file resides
  [l]         lfn      file to which the library is written
  [n]          l       name stored in library directory
  [i]          0       file containing LIBEDIT directives

.HELP,LFN
 The LFN parameter selects the name by which the NOS file is accessed.
.HELP,PFN
 The PFN parameter selects the name by which the NOS file is stored.
 The default is the value specified for the LFN parameter.
.HELP,UN
 The UN parameter specifies the User Name location of the file.
 The default value is the User Name in which this procedure executes.
.HELP,L
 The L parameter names a file to which the library is written.
 The default is the value specified for the LFN parameter.
.HELP,N
 The N parameter specifies a name saved in the library directory.
 The default is the value specified for the L parameter.
.HELP,I
 The I parameter names a file containing LIBEDIT directives.
 The default is to not use LIBEDIT directives.
.ENDHELP
.IFE,$N$.EQ.$$,SETLIBNAME.
  .IFE,$L$.EQ.$$,USEPFN.
    .IFE,$PFN$.EQ.$$,SETPFN.
      $REVERT,EX.CRELIB,LFN,LFN,UN,LFN,LFN,I.
    .ELSE,SETPFN.
      $REVERT,EX.CRELIB,LFN,PFN,UN,PFN,PFN,I.
    .ENDIF,SETPFN.
  .ELSE,USEPFN.
    .IFE,$PFN$.EQ.$$,SETPFN.
      $REVERT,EX.CRELIB,LFN,LFN,UN,L,L,I.
    .ELSE,SETPFN.
      $REVERT,EX.CRELIB,LFN,PFN,UN,L,L,I.
    .ENDIF,SETPFN.
  .ENDIF,USEPFN.
.ENDIF,SETLIBNAME.
.IFE,$I$.NE.$0$,DIRECTIVES.
  GETFILE,I,I,,READ,A=YES.
.ENDIF,DIRECTIVES.
GETFILE,LFN,PFN,UN,,A=YES.
.IFE,$I$.NE.$0$,DIRECTIVES.
  $LIBEDIT,B=LFN,#N=LFN,P=0,#L=YYYYERR,LO=E,#I=I,U=L,D,NI.
  $REWIND,YYYYERR.
  $COPYEI,YYYYERR,OUTPUT.
.ELSE,DIRECTIVES.
  UPDVER,DATE+,TIME+,LFN,L,CREATE.
  $LIBEDIT,B=DISVER,#N=LFN,P=LFN,#L=YYYYERR,LO=EM,#I=I,U=L.
.ENDIF,DIRECTIVES.
$UNLOAD,ZZZZZG2,DISVER,YYYYERR,YYYYCRE.
$SKIP,NOERROR.
  $EXIT.
  $REWIND,LFN,YYYYERR.
  $COPYEI,YYYYERR,OUTPUT.
  $UNLOAD,ZZZZZG2,DISVER,YYYYERR,YYYYCRE.
  $REVERT,ABORT. CREATE L <-- PFN FAILED
$ENDIF,NOERROR.
$IFE,.NOT.((FILE(LFN,PM)).AND.(FILE(LFN,WR))),REWRITE.
  REPFILE,LFN,L,DEFINE=YES.
$ENDIF,REWRITE.
.IFE,$LFN$.NE.$L$,RETURNLFN.
  $UNLOAD,LFN.
.ENDIF,RETURNLFN.
.IFE,(($PFN$.NE.$L$).AND.($PFN$.NE.$$)),PURGEPFN.
  $PURGE,PFN/NA.
.ENDIF,PURGEPFN.
$REVERT. CREATED L <-- LFN (#I=I)
/EOR
*DECK DECK=RAM$CREOPL EXPAND=TRUE
.PROC,CREOPL*I,
A "- NOS/BE pl1a"                      = (*N=PL1A,*F),
B "- NOS/BE pl1b"                      = (*N=PL1B,*F),
T "- COMPASS pl2"                      = (*N=PL2,*F),
UN "- NOS/BE perm file ID"             = (*N=,*F),
.
.HELP
 The CREOPL procedure CREates an update format OPL cotaining common decks
 from NOS/BE released pl1a, pl1b and COMPASS pl2. It is used in compiling
 NOS/VE real-state COMPASS source.

 Parameter   Default   Description
   Name       Value

  [a]         pl1a     NOS/BE pl1a
  [b]         pl1b     NOS/BE pl1b
  [l]         pl2      COMPASS pl2
   un                  NOS/BE permanent file ID

.HELP,A
 The A parameter specifies the file containing NOS/BE pl1a.
.HELP,B
 The B parameter specifies the file containing NOS/BE pl1b.
.HELP,T
 The T parameter specifies the file containing COMPASS pl2.
.HELP,UN
 The UN parameter specifies a permanent file ID used to reference the input
 files (if they are not already local) and catalog file OPL.
.ENDHELP
.IF,SYS.EQ.NOS.REVERT. NOS/BE PROC ONLY
GETFILE,A,A,UN,#A=YES.
GETFILE,B,B,UN,#A=YES.
GETFILE,T,T,UN,#A=YES.
UPDATE,Q,P=A,I=UPDR1,R,S=TEXTSA,C=0,L=0.
UPDATE,Q,P=B,I=UPDR2,R,S=TEXTSB,C=0,L=0.
UPDATE,Q,P=T,I=UPDR3,R,S=TEXTS2,C=0,L=0.
REQUEST,OPL,PF.
REWIND,TEXTSA,TEXTSB,TEXTS2,UPDR5.
UPDATE,N=OPL,I=UPDR4,C=0,L=0.
REPFILE,OPL,OPL,#UN=UN.
RETURN,TEXTSA,TEXTSB,TEXTS2.
RETURN,A,B,T,OPL,UPDR1,UPDR2,UPDR3,UPDR4,UPDR5.
EXIT.
RETURN,TEXTSA,TEXTSB,TEXTS2.
RETURN,A,B,T,OPL,UPDR1,UPDR2,UPDR3,UPDR4,UPDR5.
.DATA,UPDR1
*C COMSDST,COMPMRM,COMPMRA,COMSMCR,SSYS
.DATA,UPDR2
*C PFCOM,COMCMAC
.DATA,UPDR3
*C COMCCDD,COMCCIO,COMCSYS
.DATA,UPDR4
*READ TEXTSA
*READ TEXTSB
*READ TEXTS2
*READ UPDR5
.DATA,UPDR5
*COMDECK COMCWTW
          CTEXT  COMCWTW - WRITE WORDS FROM WORKING BUFFER.
 WTW      SPACE  4
          IF     -DEF,QUAL$,1
          QUAL   COMCWTW
          BASE   D
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992.
 WTW      SPACE  4
***       WTW - WRITE WORDS FROM WORKING BUFFER.
*         D. #A. CAHLANDER.   70/11/29.
*         R. E. TATE.        73/11/04.
 WTW      SPACE 4
***       WTW - INTERNAL NOTICE
*               THIS COMMON DECK HAS BEEN COPIED FROM THE NOS OPL AND PUT
*         INTO THE NOS/VE DECK RAM$CREOPL.  THIS COMMON DECK IS NEEDED
*         BY NOS/BE TO ASSEMBLE THE DUAL STATE ROUTINES.  IF THE NOS
*         COMMON DECK CHANGES THEN THE NOS/VE DECK RAM$CREOPL SHOULD
*         BE UPDATED WITH THE NEW VERSION OF COMCWTW, AND THIS NOTICE
*         SHOULD BE INCLUDED WITH THAT UPDATE.
 WTW      SPACE  4
***              WTW TRANSFERS DATA FROM #A WORKING BUFFER TO #A CIO
*         BUFFER.  THIS DECK ALSO CONTAINS DCB=, AND WTX=.
*         IF THE BUFFER BECOMES SUFFICIENTLY FULL TO REQUIRE WRITING,
*         THE THRESHOLD CONDITION TO ISSUE WRITE FUNCTIONS
*         IS BUFFER HALF FULL FOR BUFFERS LARGER
*         THAN 511 DECIMAL WORDS, AND BUFFER TOTALLY
*         FULL FOR SMALLER BUFFERS.  IF THE SYMBOL
*         WTX$ IS DEFINED, THEN THE THRESHOLD IS
*         BUFFER FULL FOR ALL BUFFER SIZES.
*         WTW WILL PERFORM #A *WRITE* FUNCTION UNLESS THE SYMBOL *WRIF$*
*         IS DEFINED. IN THIS CASE, THE CIO FUNCTION THAT IS IN THE FET
*         WILL BE REISSUED.  #A *WRITEW* REQUEST MAY READ DATA FROM
*         BEYOND THE END OF THE WORKING BUFFER, THUS CAUSING AN ABORT
*         IF THE LAST WORD ADDRESS OF THE BUFFER IS WITHIN 4 WORDS OF
*         FL.
*
*         WHEN CALLING CIO= FROM THIS ROUTINE B6 AND B7
*         MUST CONTAIN WORKING STORAGE BUFFER ADDRESS,
*         AND NUMBER OF WORDS TO TRANSFER RESPECTIVELY
*         AS ERROR PROCESSING ROUTINES DEPEND UPON
*         THESE REGISTERS.
*
*         ENTRY  (X2) = ADDRESS OF FET FOR FILE.
*                (B6) = FWA WORKING BUFFER.
*                (B7) = WORD COUNT OF WORKING BUFFER.
*                IF (B7) = 0, NO TRANSFER WILL BE PERFORMED.
*
*         EXIT   (X2) = ADDRESS OF FET FOR FILE.
*                (B6) = ADDRESS OF NEXT WORD TO BE TRANSFERRED FROM
*                       WORKING BUFFER.
*                (B7) = 0 IF TRANSFER COMPLETE.
*                     = REMAINING WORD COUNT IF *CIO=* WAS CALLED TO
*                       WRITE DATA AND RETURNED AN ERROR STATUS.
*                (X7) = ERROR STATUS IF (B7) .NE. 0.
*
*         USES   X - 1, 2, 3, 4, 6, 7.
*                B - 1, 2, 3, 4, 5, 6, 7.
*                #A - 1, 2, 3, 4, 6, 7.
*
*         CALLS  CIO=.


 WTW18    SX6    B3+B4       ADVANCE IN
          SB3    B3+B4
          SB6    B6+B4
          SB7    B7-B4
          NE     B3,B5,WTW19 IF IN " LIMIT
          SA1    X2+B1       IN = FIRST
          SX6    X1
 WTW19    SA6    X2+2        UPDATE IN
          NZ     B7,WTW1     IF NOT END OF TRANSFER

 WTW=     PS                 ENTRY/EXIT
 WTW1     SA1    X2+3        (B4) = OUT
          SA3    X2+2        (B3) = IN
          IF     -DEF,B1=1,1
          SB1    1
          SA4    A1+B1       (B5) = LIMIT
          ZR     B7,WTW=     IF WORKING BUFFER EMPTY
          SB4    X1
          SA1    X2+B1       (B2) = FIRST
          SB3    X3
          SB5    X4
          SB2    X1
          SA1    B6          READ FIRST WORD
          NE     B2,B4,WTW2  IF OUT " FIRST
          SB4    B5
 WTW2     LT     B3,B4,WTW3  IF NO END AROUND
          SB4    B5+1
 WTW3     SB4    B4-B1       CALCULATE FREE DATA SPACE
          SB4    B4-B3       (B4) = TRANSFER LENGTH
          ZR     B4,WTW13    IF NO ROOM
          BX7    X1
          LE     B4,B7,WTW4  IF NOT ENOUGH ROOM
          SB4    B7

*         INITIALIZE REGISTERS FOR TRANSFER.

 WTWA     BSS    0
 WTW4     SA3    WTWC        PRESET CMU CODE AND VOID STACK
          RJ     WTW16
*         SA1    A1+B1       (NO CMU)
*         SX4    B4-B1       (NO CMU)
*         MX6    -3          (NO CMU)
*         SA7    B3          (NO CMU)
*
*         GT     B4,B1,WTW14  IF MORE THAN 1 WORD  (CMU)
*         BX4    X4-X4       (CMU)
*         SA7    B3          (CMU)

 WTW5     BX3    -X6*X4      NUMBER OF ODD WORDS
          AX4    3           NUMBER OF BLOCKS
          ZR     X3,WTW7     IF NO ODD WORDS

*         TRANSFER UP TO 7 WORDS.

 WTW6     SX3    X3-1
          BX7    X1
          SA1    A1+B1
          SA7    A7+B1
          NZ     X3,WTW6     LOOP

*         PRE-READ REGISTERS.

 WTW7     ZR     X4,WTW18    IF NO BLOCKS
          SB5    X2          (B5) = FET ADDRESS
          SA2    A1+B1
          SB2    B1+B1       (B2) = 2
          SA3    A2+B1
          SB3    X4          (B3) = BLOCK COUNT
          SA4    A3+B1

*         TRANSFER 8 WORD BLOCKS.

 WTW8     BX6    X1
          LX7    X2
          SA1    A3+B2
          SA2    A4+B2
          SA6    A7+B1
          SB3    B3-B1
          SA7    A6+B1
          BX6    X3
          LX7    X4
          SA3    A1+B2
          SA4    A2+B2
          SA6    A6+B2
          SA7    A7+B2
          BX6    X1
          LX7    X2
          SA1    A3+B2
          SA2    A4+B2
          SA6    A6+B2
          SA7    A7+B2
          BX6    X3
          LX7    X4
          SA3    A1+B2
          SA4    A2+B2
          SA6    A6+B2
          SA7    A7+B2
          NZ     B3,WTW8     LOOP

*         WRITE EXIT.

          SA3    B5+B2       READ IN
          SA1    A3+B2       (B5) = LIMIT
          SX2    B5
          SB5    X1
          SA4    X2          CHECK BUFFER STATUS
 WTW9     SB6    B6+B4
          SB7    B7-B4
          SB3    X3+B4       ADVANCE IN
          SX6    X3+B4
          LX4    59-0
          SA3    X2+B1       READ FIRST
          NE     B3,B5,WTW10 IF IN " LIMIT
          SX6    X3+         IN = FIRST
 WTX$     IF     DEF,WTX$
 WTW10    EQ     WTW19       CLEAN UP AND RETURN
 WTX$     ELSE

*         TRY TO BUFFER AHEAD.

 WTW10    PL     X4,WTW19    IF BUFFER BUSY
          SA1    X2+3        READ OUT
          SA6    X2+2        STORE IN
          SB2    X3          (LIMIT-FIRST)
          IX6    X1-X6       (OUT-IN)
          SX7    B5-B2
          LX3    X6,B1       2*(OUT-IN)
          AX6    60          SIGN OF (OUT-IN)
          BX4    X6-X7       INVERT BUFFER IF IN \ OUT
          IX6    X4-X3       BUFFER SIZE - 2*(OUT-IN)
          NG     X6,WTW12    IF BUFFER THRESHOLD NOT REACHED
          AX7    9
          ZR     X7,WTW12    IF BUFFER NOT BIG ENOUGH TO WRITE AHEAD
 WTX$     ENDIF
 WRIF$    IF     DEF,WRIF$
 WTW11    SA1    X2          RE-ISSUE CURRENT WRITE FUNCTION
          SX6    774B
          BX7    X6*X1
          RJ     =XCIO=
 WRIF$    ELSE   1
 WTW11    WRITE  X2
          NZ     X7,WTW=     IF ERROR IN LAST *CIO* REQUEST
 WTW12    NZ     B7,WTW1     IF NOT DONE
          JP     WTW=        RETURN

*         DUMP CIRCULAR BUFFER.

 WTW13    SA1    X2          CHECK BUFFER STATUS
          LX1    59-0
          NG     X1,WTW11    IF NOT BUSY
          ZR     X1,WTW11    IF BLANK FET
          JP     WTW1        CONTINUE WRITE

*         MOVE DATA WITH CMU.

 WTW14    SX4    B4-819
          PL     X4,WTW15    IF TOO BIG FOR CMU
          SX4    B4          10 * WORDS = CHARACTERS
          LX6    X4,B1
          BX1    X0          SAVE X0
          LX4    3
          IX6    X4+X6
          SX7    B6          SET SOURCE ADDRESS
          SX4    B3          SET DESTINATION ADDRESS
          LX7    30
          BX4    X4+X7
          MX7    -4
          BX3    X7*X6       EXTRACT UPPER PORTION
          BX6    -X7*X6      EXTRACT LOWER PORTION
          LX3    48-4
          BX4    X4+X3
          LX6    26
          BX6    X4+X6
          AX3    51
          SA6    WTWC        STORE DESCRIPTOR WORD
          IM     WTWC        MOVE DATA
          BX0    X1          RESTORE X0
          ZR     X3,WTW18    IF NO WRITE EXIT
          SA4    X2
          SX3    B3          RESET IN
          JP     WTW9

 WTWB     BSS    0
 WTW15    SA1    A1+B1       MOVE DATA WITHOUT CMU
          SX4    B4-B1
          MX6    -3
          SA7    B3
          JP     WTW5

*         CMU PRESET CODE.
*         WWTC IS READ UP AND THEN RETURN JUMPED TO IN ORDER TO VOID
*         STACK.  WWTC IS ALSO USED AS THE CMU DESCRIPTOR WORD

 WTWC     GT     B4,B1,WTW14 IF MORE THAN 1 WORD TO MOVE  (CMU)
          BX4    X4-X4
          SA7    B3
 WTW16    EQU    WTWC        USED TO VOID STACK

*         PRESET FOR CMU CODE.

          SA4    CMUR        CHECK IF CMU AVAIALABLE
          SB4    WTWA
          NG     X4,WTW17    IF CMU
          SA3    WTWB
 WTW17    BX6    X3
          SA6    B4
          JP     WTW1

 WTX      SPACE  4
**        WTX - WRITE EXIT.
*         IF BUFFER IS BUSY, RETURN.
*         OTHERWISE, WORD COUNT OF BUFFER IS CHECKED, AND #A WRITE
*         FUNCTION IS REQUESTED IF NECESSARY.
*
*         ENTRY  (A2) = ADDRESS OF IN.
*                (A3) = ADDRESS OF FIRST.
*                (A4) = RETURN ADDRESS.
*                (B3) = IN+1.
*                (B4) = OUT.
*                (B5) = LIMIT.
*                (X2) = IN
*
*         EXIT   TO RETURN ADDRESS.
*
*         CALLS  NONE.


 WTX=     SA1    A3-B1       CHECK BUFFER STATUS
          SX6    X2          STORE IN
          LX1    59
          SA6    A2
 WTX$     IF     -DEF,WTX$
          PL     X1,WTX1     IF BUFFER BUSY

*         IF BUFFER IS NOT BUSY, CHECK SIZE OF BUFFER.
*         ISSUE WRITE IF THRESHOLD IS REACHED.

          SA1    A2+B1       REREAD OUT
          SA3    A3          FIRST
          SB4    X1
          SX6    B4-B3       (OUT-IN+1)
          SB2    X3          (LIMIT-FIRST)
          LX3    X6,B1       2*(OUT-IN+1)
          SX7    B5-B2
          AX6    60          SIGN OF (OUT-IN+1)
          BX4    X6-X7       INVERT BUFFER IF IN+1 \ OUT
          IX6    X4-X3       BUFFER SIZE - 2*(OUT-IN+1)
          NG     X6,WTX1     IF BUFFER THRESHOLD NOT REACHED
          AX7    9
          ZR     X7,WTX1     IF BUFFER NOT BIG ENOUGH TO WRITE AHEAD
 WRIF$    IF     DEF,WRIF$
          SA1    A3-B1       RE-ISSUE CURRENT WRITE FUNCTION
          SX6    774B
          BX7    X6*X1
          SX2    A1          SET FET ADDRESS
          RJ     =XCIO=
 WRIF$    ELSE   1
          WRITE  A3-B1

 WTX$     ENDIF
 WTX1     SB2    A4          SET RETURN ADDRESS
          SX2    A3-B1       RESET (X2)
          JP     B2          RETURN
 DCB      SPACE  4
**        DCB - DUMP CIRCULAR BUFFER.
*         IF BUFFER IS BUSY, RETURN.
*         IF BUFFER IS NOT BUSY, REQUEST WRITE FUNCTION AND RETURN.
*
*         ENTRY  (A2) = ADDRESS OF IN.
*                (A3) = ADDRESS OF FIRST.
*                (A4) = RETURN ADDRESS.
*                (B2) = FET STATUS READ PRIOR TO READ OF OUT.
*                (X2) = IN.
*
*         EXIT   TO RETURN ADDRESS - 1.
*                (X2) = FET ADDRESS.


 DCB=     SX1    B2          CHECK BUFFER STATUS
          SX6    X2          STORE IN
          LX1    59
          SA6    A2
          NG     X1,DCB1     IF NOT BUSY
          ZR     X1,DCB1     IF BLANK FET
          SX2    A3-B1       RESET FET ADDRESS
          SB2    A4-B1       CONTINUE WRITE
          JP     B2
 WRIF$    IF     DEF,WRIF$
 DCB1     SA1    A3-B1       RE-ISSUE CURRENT WRITE FUNCTION
          SX6    774B
          BX7    X6*X1
          SX2    A1          SET FET ADDRESS
          RJ     =XCIO=
 WRIF$    ELSE   1
 DCB1     WRITE  A3-B1
          SB2    A4-B1       CONTINUE WRITE
          JP     B2
          SPACE  4
          BASE   *
 QUAL$    IF     -DEF,QUAL$
          QUAL   *
 WTW=     EQU    /COMCWTW/WTW=
 WTX=     EQU    /COMCWTW/WTX=
 DCB=     EQU    /COMCWTW/DCB=
 QUAL$    ENDIF
          ENDX
/EOR
*DECK DECK=RAM$CYBIL EXPAND=TRUE

create_program_description name=cybil library=('$system.cybil.bound_product' osf$task_services_library) ..
      starting_procedure=cybilii load_map=$local.$null load_map_options=none ..
      tel=error pv=zero af=$null di=$null do=$null dm=off

*DECK DECK=RAM$DB56LST EXPAND=TRUE
VALIDUS
file170 = 'VALIDUS'
path170 = '&USER&,&AREA&,&SYS&'
packing = 'A6'
file180 = 'scrach_validus'
path180 = '$local'
get_deadstart_file to=$name(file180) data_conversion=$name(packing)
display_value ' make VALIDUS a local file '
.EOR
DDSPROC
file170 = 'DDSPROC'
path170 = '&USER&,&AREA&,&SYS&'
packing = 'A6'
file180 = 'ds'
path180 = '$user'
" save ds"
create_system_file f=$fname(path180//'.'//file180) lfn=$name(file180) ..
    fc=legible fs=data p=yes
get_deadstart_file to=$name(file180) data_conversion=$name(packing)
detach_file $name(file180) status=lpf_ignore_status
change_file_attributes f=$fname(path180//'.'//file180) ..
    ring_attributes=(3,11,11)
display_value ' saved DS procedure '
.EOR
OSLIB
file170 = 'OSLIB'
path170 = '&USER&,&AREA&,&SYS&'
packing = 'B56'
"Define variable to record system file loading status"
create_variable DSV$LOADED_B56_SYSTEM_FILES kind=boolean scope=job value=no
create_system_file f=$user.osf$operator_library lfn=osf$operator_library ..
  fc=object fs=library public=no
get_deadstart_file to=osf$operator_library data_conversion=$name(packing)
display_value ' loaded OSLIB to osf$operator_library '
    TASK osf$operator_library
    TASKEND
.EOR
SYSLIB
file170 = 'SYSLIB'
path170 = '&USER&,&AREA&,&SYS&'
packing = 'B56'
create_system_file f=$user.osf$system_library lfn=osf$system_library ..
   fc=object fs=library public=yes
get_deadstart_file to=osf$system_library data_conversion=$name(packing)
display_value ' loaded SYSLIB to osf$system_library '
    TASK osf$system_library
    TASKEND
.EOR
CYBIILB
file170 = 'CYBIILB'
path170 = '&USER&,&AREA&,&SYS&'
packing = 'B56'
create_system_file f=$user.cyf$run_time_library lfn=cyf$run_time_library ..
     fc=object fs=library public=yes
get_deadstart_file to=cyf$run_time_library data_conversion=$name(packing)
display_value ' loaded CYBIILB to cyf$run_time_library '
    TASK cyf$run_time_library
    TASKEND
.EOR
SOPCLIB
file170 = 'SOPCLIB'
path170 = '&USER&,&AREA&,&SYS&'
packing = 'B56'
create_system_file f=$user.osf$operator_command_library ..
     lfn=osf$operator_command_library fc=object fs=library public=no
get_deadstart_file to=osf$operator_command_library dc=$name(packing)
display_value ' loaded SOPCLIB to osf$operator_command_library '
    TASK osf$operator_command_library
    TASKEND
.EOR
SYSCLIB
file170 = 'SYSCLIB'
path170 = '&USER&,&AREA&,&SYS&'
packing = 'B56'
"Record that system files are loaded"
DSV$LOADED_B56_SYSTEM_FILES = yes
create_system_file f=$user.osf$command_library lfn=osf$command_library ..
    fc=object fs=library public=yes
get_deadstart_file to=osf$command_library data_conversion=$name(packing)
display_value ' loaded SYSCLIB to osf$command_library '
    TASK osf$command_library
    TASKEND
"Record that system files are loaded"
DSV$LOADED_B56_SYSTEM_FILES = yes
*DECK DECK=RAM$DB60LST EXPAND=TRUE
XLJOSL
file170 = 'XLJOSL'
path170 = '&USER&,&AREA&,&SYS&'
packing = 'B60'
"Define variable to record system file loading status"
create_variable DSV$LOADED_B60_SYSTEM_FILES kind=boolean scope=job value=no
" library file, leave it local on 'sysci' file for conversion to ii"
detach_file (sysci sysii) status=lpf_ignore_status
get_deadstart_file to=sysci data_conversion=$name(packing)
display_value '  convert XLJOSL to sysii '
  TASK ocf$object_file
    execute_task parameter='sysci,sysii' starting_procedure=citoii
    detach_file sysci
  TASKEND
.EOR
XLJLIB
file170 = 'XLJLIB'
path170 = '&USER&,&AREA&,&SYS&'
packing = 'B60'
detach_file (libci libii) status=lpf_ignore_status
get_deadstart_file to=libci data_conversion=$name(packing)
display_value ' convert XLJLIB to libii '
  TASK cyf$run_time_library
    execute_task parameter='libci,libii' starting_procedure=citoii
    detach_file libci
  TASKEND
.EOR
XLJOCM
file170 = 'XLJOCM'
pat170 = '&USER&,&AREA&,&SYS&'
packing = 'B60'
"leave file local on 'ocmci'"
detach_file (ocmci ocmii) status=lpf_ignore_status
get_deadstart_file to=ocmci data_conversion=$name(packing)
display_value ' convert XLJOCM to ocmii '
  TASK osf$system_library
    execute_task parameter='ocmci,ocmii' starting_procedure=citoii
    detach_file ocmci
  TASKEND
.EOR
CYBHOBJ
file170 = 'CYBHOBJ'
path170 = '&USER&,&AREA&,&SYS&'
packing = 'B60'
" library file, leave it local on 'cybci' file for conversion to ii"
detach_file (cybci cybii) status=lpf_ignore_status
get_deadstart_file to=cybci data_conversion=$name(packing)
display_value ' convert CYBHOBJ to cybii '
  TASK osf$operator_library
    execute_task parameter='cybci,cybii' starting_procedure=citoii
    detach_file cybci
  TASKEND
.EOR
VALIDUS
file170 = 'VALIDUS'
path170 = '&USER&,&AREA&,&SYS&'
packing = 'A6'
file180 = 'scrach_validus'
path180 = '$local'
display_value ' make VALIDUS a local file '
get_deadstart_file to=$name(file180) data_conversion=$name(packing)
.EOR
DDSPROC
file170 = 'DDSPROC'
path170 = '&USER&,&AREA&,&SYS&'
packing = 'A6'
file180 = 'ds'
path180 = '$user'
" save ds"
create_system_file f=$fname(path180//'.'//file180) lfn=$name(file180) ..
    fc=legible fs=data p=yes
display_value ' save DS procedure '
get_deadstart_file to=$name(file180) data_conversion=$name(packing)
detach_file $name(file180) status=lpf_ignore_status
change_file_attributes f=$fname(path180//'.'//file180) ..
    ring_attributes=(3,11,11)
"Record that system files are loaded"
DSV$LOADED_B60_SYSTEM_FILES = yes
display_value ' await outstanding task completions '
  wait task_names=(ocf$object_file, cyf$run_time_library)
  wait task_names=(osf$system_library, osf$operator_library)
  cause $task_status(osf$object_file)
  cause $task_status(cyf$run_time_library)
  cause $task_status(osf$system_library)
  cause $task_status(osf$operator_library)
*DECK DECK=RAM$DEACTIVATE_5744_APPLICATION EXPAND=TRUE
PROCEDURE deactivate_cartridge_library, deacl (
  status)

  "$FORMAT=OFF"
  VAR
    job_name: name
    selected_jobs: list 0..$max_list of name
  VAREND
  "$FORMAT=ON"

  job_name = $name('$5744_interface_'//$substring($mainframe(id),9,9))
  manage_jobs
    select_job ..
      login_family=$system login_user=$system name=job_name job_selection_list=selected_jobs
    qui
  IF $size(selected_jobs)=0 THEN
    display_value '--ERROR-- $5744_interface job is UNKNOWN'
  ELSE
    terminate_job job_name=job_name
  IFEND

PROCEND deactivate_cartridge_library
*DECK DECK=RAM$DEACTIVATE_DRJE EXPAND=TRUE
PROCEDURE deactivate_drje (
  control_facility_name, cfn: name = station_controller_1
  status)

  VAR
    local_status: status
  VAREND

  MANAGE_JOBS
    select_job login_family=$system login_user=$system name=$dynamic_remote_job_entry ..
          user_information='DRJE@'//control_facility_name status=local_status
    IF local_status.normal AND ($size(jmv$selected_jobs) > 0) THEN
      terminate_job names=jmv$selected_jobs status=local_status
    ELSE
      local_status = $status(false, 'NF', nfe$drje_not_active, control_facility_name)
    IFEND
  QUIT

  EXIT procedure WITH local_status

PROCEND deactivate_drje
*DECK DECK=RAM$DEACTIVATE_FTAM_RESPONDER EXPAND=TRUE
PROCEDURE deactivate_ftam_responder, deafr (
  status)

  "$FORMAT=OFF"
  VAR
    responder_user_job_name: name = $name('FTAM'//$mainframe(id))
    local_status: status
  VAREND
  "$FORMAT=ON"

  IF NOT $job_validation(system_operation) THEN
    EXIT procedure WITH $status(false, 'RA', 0, 'FTAM/VE can only be deactivated by a system operator.')
  IFEND

  MANAGE_JOBS
    select_jobs name=responder_user_job_name job_state=all status=local_status
    IF local_status.normal AND ($size(jmv$selected_jobs) > 0) THEN
      terminate_job names=jmv$selected_jobs status=local_status
    ELSE
      local_status = $status(false, 'JM', jme$job_not_found, responder_user_job_name)
    IFEND
  QUIT

  EXIT procedure WITH local_status

PROCEND deactivate_ftam_responder
*DECK DECK=RAM$DEACTIVATE_FTPS EXPAND=TRUE
PROC deactivate_ftps (
  status       : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request deactivates FTPS system task.
*IFEND


  create_variable local_status k=status


  deactivate_system_task task_name=ftp_server status=local_status
  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND deactivate_ftps

*DECK DECK=RAM$DEACTIVATE_INETD EXPAND=TRUE
PROCEDURE deactivate_inetd (
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" Purpose:  Deactivate the Internet Daemon.
*IFEND

  VAR
    application_job_name: name = $name('INTERNET_DMN'//$mainframe(id))
    select_status: status
    terminate_status: status
  VAREND

  MANAGE_JOBS
    SELECT_JOB ..
      name=application_job_name job_state=all status=select_status
    IF select_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        WHILE $size(jmv$selected_jobs) > 0 DO
          terminate_job job_name=$first(jmv$selected_jobs) ..
            status=terminate_status
          IF terminate_status.normal THEN
            put_line ' Internet Daemon '//$string($first(jmv$selected_jobs))//..
' terminated.' o=$response
          ELSE
            display_value $status_message(terminate_status, 80) o=$response
          IFEND
          jmv$selected_jobs =$rest(jmv$selected_jobs)
        WHILEND
      ELSE
        put_line ' The Internet Daemon is not active.' o=$response
      IFEND
    ELSE
      EXIT procedure WITH select_status
    IFEND
  QUIT

PROCEND deactivate_inetd
*DECK DECK=RAM$DEACTIVATE_MAILVE EXPAND=TRUE
PROCEDURE deactivate_mailve (
  message_transfer_agent, mta: (BY_NAME, ADVANCED) any of
      string 1..12
      name 1..12
    anyend = mvd$default_mta, ' '
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request terminates the MAILVE server job.
*IFEND

  VAR
    active_mta: string = $string(message_transfer_agent)
  VAREND

  IF $size($trim(active_mta)) = 0 THEN
    active_mta = 'MAILVE'
  IFEND

  VAR
    application_job_name: name = $name('MTA_'//active_mta//$mainframe(id))
    select_status: status
    terminate_status: status
  VAREND

  MANAGE_JOBS
    SELECT_JOB ..
      name=application_job_name job_state=all status=select_status
    IF select_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        WHILE $size(jmv$selected_jobs) > 0 DO
          terminate_job job_name=$first(jmv$selected_jobs) ..
            status=terminate_status
          IF terminate_status.normal THEN
            put_line ' MAILVE '//$string($first(jmv$selected_jobs))//..
' terminated.' o=$response
          ELSE
            display_value $status_message(terminate_status, 80) o=$response
          IFEND
          jmv$selected_jobs=$rest(jmv$selected_jobs)
        WHILEND
      ELSE
        put_line ' MAILVE is not active.' o=$response
      IFEND
    ELSE
      EXIT procedure WITH select_status
    IFEND
  QUIT

PROCEND deactivate_mailve
*DECK DECK=RAM$DEACTIVATE_MAIL_CLUSTER_SER EXPAND=TRUE
PROCEDURE deactivate_mail_cluster_server (
  status)

  "$FORMAT=OFF"
  VAR
    application_job_name: name = $name('MAIL_DFS_SRVR'//$mainframe(id))
    select_status: status
    terminate_status: status
  VAREND
  "$FORMAT=ON"

  MANAGE_JOBS
    select_job login_user=$system login_family=$system ..
          name=application_job_name job_state=all status=select_status
    IF select_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        WHILE $size(jmv$selected_jobs) > 0 DO
          terminate_job job_name=$first(jmv$selected_jobs) ..
                status=terminate_status
          IF terminate_status.normal THEN
            put_line ' MAILVE '//..
$string($first(jmv$selected_jobs))//' terminated.' o=$response
          ELSE
            display_value $status_message(terminate_status, 80) o=$response
          IFEND
          jmv$selected_jobs = $rest(jmv$selected_jobs)
        WHILEND
      ELSE
        put_line ' MAILVE_CLUSTER_SERVER is not active.' o=$response
      IFEND
    ELSE
      EXIT procedure WITH select_status
    IFEND
  QUIT

PROCEND deactivate_mail_cluster_server
*DECK DECK=RAM$DEACTIVATE_MAIL_DELIVERY_AG EXPAND=TRUE
PROCEDURE deactivate_mail_delivery_agent, deamda (
  message_transfer_agent, mta: (BY_NAME, ADVANCED) any of
      string 1..12
      name 1..12
    anyend = mvd$default_mta, ' '
  status)


"   This request terminates the MAILVE Custom Delivery job.

  VAR
    active_mta: string = $string(message_transfer_agent)
  VAREND

  IF $size($trim(active_mta)) = 0 THEN
    active_mta = 'MAILVE'
  IFEND

  VAR
    application_job_name: name = $name('MVE_CD_'//active_mta//$mainframe(id))
    select_status: status
    terminate_status: status
  VAREND

  MANAGE_JOBS
    SELECT_JOB login_user=$SYSTEM login_family=$SYSTEM ..
      name=application_job_name job_state=all status=select_status
    IF select_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        WHILE $size(jmv$selected_jobs) > 0 DO
          terminate_job job_name=$first(jmv$selected_jobs) ..
            status=terminate_status
          IF terminate_status.normal THEN
            put_line ' MAILVE Custom Delivery '//$string($first(jmv$selected_jobs))//..
' terminated.' o=$response
          ELSE
            display_value $status_message(terminate_status, 80) o=$response
          IFEND
          jmv$selected_jobs=$rest(jmv$selected_jobs)
        WHILEND
      ELSE
        put_line ' MAILVE Custom Delivery Job is not active.' o=$response
      IFEND
    ELSE
      EXIT procedure WITH select_status
    IFEND
  QUIT

PROCEND deactivate_mail_delivery_agent

*DECK DECK=RAM$DEACTIVATE_MAIL_GATEWAY EXPAND=TRUE
PROCEDURE deactivate_mail_gateway (
  status
  )

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request terminates the MAILVE_MG server job.
*IFEND

  VAR
    application_job_name: name = $name('MAILVE_MG'//$mainframe(id))
    select_status: status
    terminate_status: status
  VAREND

  MANAGE_JOBS
    SELECT_JOB login_user=$SYSTEM login_family=$SYSTEM ..
      name=application_job_name job_state=all status=select_status
    IF select_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        WHILE $size(jmv$selected_jobs) > 0 DO
          terminate_job job_name=$first(jmv$selected_jobs) ..
            status=terminate_status
          IF terminate_status.normal THEN
            put_line ' MAILVE_MG '//$string($first(jmv$selected_jobs))//..
' terminated.' o=$response
          ELSE
            display_value $status_message(terminate_status, 80) o=$response
          IFEND
          jmv$selected_jobs=$rest(jmv$selected_jobs)
        WHILEND
      ELSE
        put_line ' MAILVE_MG is not active.' o=$response
      IFEND
    ELSE
      EXIT procedure WITH select_status
    IFEND
  QUIT

PROCEND deactivate_mail_gateway
*DECK DECK=RAM$DEACTIVATE_NFS EXPAND=TRUE
PROCEDURE deactivate_nfs, deanfs (
  status)

"   This procedure is on the OS source_library  because it resides
"   on osf$builtin_library.  The ONC products are on the NFS source
"   library.  To minimize the number of times a mod is required
"   to both source libraries the deactivate procs call deactivate_onc
"   passing all the parameters required data.  The deactivate_onc resides on
"   onc.command_library which is under NFS code control.

  VAR
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  tcp_ip.onc.command_library.deactivate_onc class='network_file_system' application_name='NFS'

PROCEND deactivate_nfs
*DECK DECK=RAM$DEACTIVATE_NLM EXPAND=TRUE
PROCEDURE deactivate_nlm, deanlm (
  status)

"   This procedure is under NOS/VE code control because it resides
"   on osf$builtin_library.  The NLM products are under CDCNET
"   code control.  To minimize the number of times a mod is required
"   to both NOS/VE and CDCNET the deactivate procs call deactivate_onc
"   passing all the parameters required data.  The deactivate_onc resides on
"   onc.command_library which is under CDCNET code control.

  VAR
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  tcp_ip.onc.command_library.deactivate_onc class='portmap_pcnfs' application_name='LOCKD'
  tcp_ip.onc.command_library.deactivate_onc class='portmap_pcnfs' application_name='STATD'

PROCEND deactivate_nlm
*DECK DECK=RAM$DEACTIVATE_NQS EXPAND=TRUE
PROCEDURE deactivate_nqs (
  status)


  VAR
    local_status: status
  VAREND

  MANAGE_JOBS
    select_job name=network_queueing_system_client job_state=(deferred, queued, initiated) ..
          user_information='Network Queueing System (NQS) for NOS/VE' status=local_status
    IF local_status.normal AND ($size(jmv$selected_jobs) > 0) THEN
      terminate_job names=jmv$selected_jobs status=local_status
    ELSE
      local_status = $status(false 'JM' jme$job_not_found 'NQS')
    IFEND
  QUIT

  EXIT_PROC WITH local_status

PROCEND deactivate_nqs
*DECK DECK=RAM$DEACTIVATE_PCNFSD EXPAND=TRUE
PROCEDURE deactivate_pcnfsd, deactivate_pcnfs, deapn (
  status)

"   This procedure is under NOS/VE code control because it resides
"   on osf$builtin_library.  The NFS products are under CDCNET
"   code control.  To minimize the number of times a mod is required
"   to both NOS/VE and CDCNET the deactivate procs call deactivate_onc
"   passing all the parameters required data.  The deactivate_onc resides on
"   onc.command_library which is under CDCNET code control.

  VAR
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  tcp_ip.onc.command_library.deactivate_onc class='portmap_pcnfs' application_name='PCNFS'

PROCEND deactivate_pcnfsd
*DECK DECK=RAM$DEACTIVATE_PORTMAP EXPAND=TRUE
PROCEDURE deactivate_portmap, deap (
  status)

"   This procedure is under NOS/VE code control because it resides
"   on osf$builtin_library.  The NFS products are under CDCNET
"   code control.  To minimize the number of times a mod is required
"   to both NOS/VE and CDCNET the deactivate procs call deactivate_onc
"   passing all the parameters required data.  The deactivate_onc resides on
"   onc.command_library which is under CDCNET code control.

  VAR
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  tcp_ip.onc.command_library.deactivate_onc class='portmap_pcnfs' application_name='PORTMAP'

PROCEND deactivate_portmap





*DECK DECK=RAM$DEACTIVATE_XTF EXPAND=TRUE
PROCEDURE deactivate_xtf (
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request terminates the XTF job.

*IFEND

  "$FORMAT=OFF"
  VAR
    application_job_name: name = $name('XTF'//$mainframe(id))
    local_status: status
    selected_job: name
  VAREND
  "$FORMAT=ON"

  MANAGE_JOBS
    select_jobs name=application_job_name job_state=all status=local_status
    IF local_status.normal AND ($size(jmv$selected_jobs) > 0) THEN
      FOR EACH selected_job in jmv$selected_jobs DO
        terminate_job name=selected_job status=local_status
        IF local_status.normal THEN
          put_line line=' XTF '//$string(selected_job)//' terminated.' o=$response
        ELSE
          put_line line=' XTF '//$string(selected_job//' could not be terminated.' o=$response
        IFEND
      FOREND
    ELSE
      local_status = $status(false, 'JM', jme$job_not_found, application_job_name)
      put_line ' XTF is not active.' o=$response
    IFEND
  QUIT

  EXIT procedure WITH local_status

PROCEND deactivate_xtf
*DECK DECK=RAM$DEACTIVATE_YPBIND EXPAND=TRUE
PROCEDURE deactivate_ypbind, deactivate_yp_binding, deaypbind, deayb (
  status)

"   This procedure is on the OS source_library  because it resides
"   on osf$builtin_library.  The ONC products are on the NFS source
"   library.  To minimize the number of times a mod is required
"   to both source libraries the deactivate procs call deactivate_onc
"   passing all the parameters required data.  The deactivate_onc resides on
"   onc.command_library which is under NFS code control.

  VAR
    ignore_status: status
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  delete_file :$system.$system.etc.yp.yp_default_domain status=ignore_status
  tcp_ip.onc.command_library.deactivate_onc class='network_file_system' application_name='YPBIND'

PROCEND deactivate_ypbind
*DECK DECK=RAM$DEACTIVATE_YPPASSWDD EXPAND=TRUE
PROCEDURE deactivate_yppasswdd, deactivate_yp_passwd_daemon, deaypd (
  status)

"   This procedure is on the OS source_library  because it resides
"   on osf$builtin_library.  The ONC products are on the NFS source
"   library.  To minimize the number of times a mod is required
"   to both source libraries the deactivate procs call deactivate_onc
"   passing all the parameters required data.  The deactivate_onc resides on
"   onc.command_library which is under NFS code control.

  VAR
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  tcp_ip.onc.command_library.deactivate_onc class='network_file_system' application_name='YPPASSWDD'

PROCEND deactivate_yppasswdd
*DECK DECK=RAM$DEACTIVATE_YPSERV EXPAND=TRUE
PROCEDURE deactivate_ypserv, deactivate_yp_server, deays (
  status)

"   This procedure is on the OS source_library  because it resides
"   on osf$builtin_library.  The ONC products are on the NFS source
"   library.  To minimize the number of times a mod is required
"   to both source libraries the deactivate procs call deactivate_onc
"   passing all the parameters required data.  The deactivate_onc resides on
"   onc.command_library which is under NFS code control.

  VAR
    ignore_status: status
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  delete_file :$system.$system.etc.yp.yp_default_domain status=ignore_status
  tcp_ip.onc.command_library.deactivate_onc class='network_file_system' application_name='YPSERV'

PROCEND deactivate_ypserv
*DECK DECK=RAM$DEACTIVATE_YPUPDATED EXPAND=TRUE
PROCEDURE deactivate_ypupdated, deactivate_yp_update_daemon, deayud (
  status)

"   This procedure is on the OS source_library  because it resides
"   on osf$builtin_library.  The ONC products are on the NFS source
"   library.  To minimize the number of times a mod is required
"   to both source libraries the deactivate procs call deactivate_onc
"   passing all the parameters required data.  The deactivate_onc resides on
"   onc.command_library which is under NFS code control.

  VAR
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  tcp_ip.onc.command_library.deactivate_onc class='network_file_system' application_name='YPUPDATED'

PROCEND deactivate_ypupdated
*DECK DECK=RAM$DEACTIVATE_YPXFRD EXPAND=TRUE
PROCEDURE deactivate_ypxfrd, deactivate_yp_transfer_daemon, deayxd (
  status)

"   This procedure is on the OS source_library  because it resides
"   on osf$builtin_library.  The ONC products are on the NFS source
"   library.  To minimize the number of times a mod is required
"   to both source libraries the deactivate procs call deactivate_onc
"   passing all the parameters required data.  The deactivate_onc resides on
"   onc.command_library which is under NFS code control.

  VAR
    tcp_ip: file = nfd$tcp_ip, $system.tcp_ip
  VAREND

  tcp_ip.onc.command_library.deactivate_onc class='network_file_system' application_name='YPXFRD'

PROCEND deactivate_ypxfrd
*DECK DECK=RAM$DEACTIVAT_NETWORK_ARCHIVING EXPAND=TRUE
PROCEDURE deactivate_network_archiving, deana, deanr (
  configuration_file, cf: file = $system.etc.netarc_config
  status)

"   This procedure resides on osf$builtin_library.  The deactivate procs call
"   the deactivate_netarc_server proc which is on the
"   $system.tcp_ip.netarc.command_library.  The deactivate_network_archiving
"   procedure checks to see if network archiving is installed before calling
"   the terminate proc.

VAR
  command_status: status
  network_archiving_library: file = $system.tcp_ip.netarc.command_library
VAREND

IF (NOT $file(network_archiving_library permanent)) THEN
  put_line ('  ', ..
  ' --ERROR-- Unable to deactivate:  Network Archiving is not installed.') ..
      o=$response
  EXIT_PROC
IFEND

network_archiving_library.deactivate_netarc_server ..
  configuration_file=configuration_file ..
  status=command_status
EXIT_PROC WITH command_status WHEN NOT command_status.normal

PROCEND deactivate_network_archiving
*DECK DECK=RAM$DEFERRED_ACTIVATION_MENU EXPAND=TRUE
CREATE_MESSAGE_MODULE deferred_activation$us_english


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This deck contains the command calls to create a menu message module
"   that is used by the procedure RAP$GET_ACTIVATION_OPTION.  The
"   messages are formatted for the RAP$PROMPT_VIA_MENU interface.
"
" DESIGN:
"   The function of a message module is to provide help for a user executing
"   commands interactively.  Therefore the kinds of messages found in a
"   message module reflect that purpose.  In setting up menus using message
"   module technology the message kinds are given new meanings.
"
"     The menu title is created as the brief help message.
"     The menu help is created as the full help message.
"     The menu selections are created as parameter prompt messages.
"     The menu selection help (optional) is created as a parameter help message.
"     The menu selection confirmation (optional) is created as a parameter
"     assist message.
"     The menu prompt is created as a parameter prompt message.
"
" NOTES:
*IFEND


CREATE_BRIEF_HELP_MESSAGE
+X2+N0Your system activation choices are:+N+X2
**

CREATE_FULL_HELP_MESSAGE
+X2+N0You have completed installing files that were deferred (that is, not
 installed) at a previous BCU installation.+X2You may now
 activate the system for production or for system console usage only.
 Processing will be complete when you see the message:
+N+X2
+N2----- SYSTEM ACTIVATION COMPLETE -----
+N+X2
+N0This message will be followed by the NOS/VE slash (/) prompt at which time
 you may enter commands.
+N+X2
+N0To get help for a particular selection, enter the number of the selection,
 followed by a question mark.
 For example, to get help for selection 1, you would enter:
+N+X2
+N2 1?
+N+X2
**

CREATE_PARAMETER_PROMPT_MESSAGE n=production_usage
+X2+P1.+X2Activate the system for production.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=console_usage_only
+X2+P1.+X2Activate the system for system console usage only.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=prompt
+X2+N0Enter selection or ? for HELP.
**

CREATE_PARAMETER_HELP_MESSAGE n=production_usage
+X2+N0This selection causes the system to be activated for general
 use.+X2If the network is configured and has been enabled (by the
 NETWORK_ACTIVATION system attribute), all of the tasks and applications
 associated with it will also be activated.+X2In a dual-state mainframe, the
 tasks used to communicate with the 170 partner system will be activated.
 +X2Activating the system for production makes the mainframe available to
 users.
+N+X2
**

CREATE_PARAMETER_HELP_MESSAGE n=console_usage_only
+N0This selection causes the system to be activated for system console
 usage only.+X2This means that the mainframe will not be
 available to users other than the system console operator.+X2One reason
 to do this might be to restore permanent files on a disk device that has
 just been put online.+X2To subsequently activate the system for
 production, enter the command  ACTIVATE_PRODUCTION_ENVIRONMENT (ACTPE).
+N+X2
**

END_MESSAGE_MODULE
*DECK DECK=RAM$DEFERRED_SUBPRODUCTS_FUNC EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: $DEFERRED_SUBPRODUCTS Function.' ??
MODULE ram$deferred_subproducts_func;

{ PURPOSE:
{   This module contains the SCL interface that determines if there are
{   any deferred subproducts in the IDB directory.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$work_area_overflow
*copyc clt$work_area
*copyc clt$data_value
*copyc ost$status
*copyc pmt$condition
*copyc rac$idb_directory_name
*copyc rae$install_software_cc
*copyc rat$idb_directory_types
?? POP ??
*copyc amp$get_segment_pointer
*copyc clp$evaluate_parameters
*copyc clp$make_boolean_value
*copyc fsp$close_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc rap$access_directory_for_read
*copyc rav$installation_defaults

?? OLDTITLE, NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
?? OLDTITLE, NEWTITLE := '[XDCL] rap$deferred_subproducts_func', EJECT ??

{ PURPOSE:
{   This interface checks the IDB directory and returns a boolean indicating
{   if there are any deferred subproducts in the directory.
{
{ DESIGN:
{   This procedure is set up as a standard SCL function.
{
{   Access the directory, whose location is determined via the current
{   installation defaults.  Once accessed, return the current value
{   of the field in the directory header which indicates if deferred
{   subproducts are contained in the directory.
{ NOTES:
{   The boolean in the header is assumed to be accurate, it is not checked
{   against each subproduct record in the directory.

  PROCEDURE [XDCL] rap$deferred_subproducts_func
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);


{ FUNCTION $deferred_products()

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [88, 8, 11, 16, 46, 5, 116],
    clc$function, 0, 0, 0, 0, 0, 0, 0, '$DEFERRED_PRODUCTS']];

?? POP ??

    VAR
      directory_pointers: rat$idb_directory_pointers,
      local_status: ost$status,
      idb_fid: amt$file_identifier,
      idb_opened: boolean;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the directory has been openned, it is closed before the
{   the procedure returns.
{
    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF idb_opened THEN
        fsp$close_file (idb_fid, ignore_status)
      IFEND

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    idb_opened := FALSE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL,
        {No PVT} NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      rap$access_directory_for_read (rav$installation_defaults.installation_database, directory_pointers,
            idb_fid, idb_opened, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      clp$make_boolean_value ((directory_pointers.header_p^.deferred_count > 0), clc$true_false_boolean,
            work_area, result);
      IF result = NIL THEN
        osp$set_status_abnormal ('CL', cle$work_area_overflow, '$deferred_subroducts', status);
        RETURN;
      IFEND;

    END /main/;

    IF idb_opened THEN
      fsp$close_file (idb_fid, local_status);
    IFEND;

    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$deferred_subproducts_func;
MODEND ram$deferred_subproducts_func;
*DECK DECK=RAM$DEFINE_5744_APPLICATION EXPAND=TRUE
PROCEDURE rap$define_5744_interface (
  gateway, g: boolean = false
  maximum_connections, mc: integer = 100
  status)

  "$FORMAT=OFF"
  VAR
    command_file     : file =$unique($local)
    ignore_status    : status
    local_status     : status
  VAREND
  "$FORMAT=ON"

  IF NOT gateway THEN
    collect_text command_file until='    collect_end'
      $system.osf$command_library.manage_network_applications
        define_tcpip_application application=osa$5744_interface_dgram ..
              protocol=datagram_socket
          change_maximum_sockets ms=maximum_connections
        quit
        activate_tcpip_application application=osa$5744_interface_dgram
      quit
    collect_end
  ELSE
    put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1'
    collect_text command_file until='    collect_end'
      $system.osf$command_library.manage_network_applications
        define_client client=osa$5744_interface_gateway protocol=cdna_session
          change_maximum_connections mc=maximum_connections
          change_client_validation sp=true
        end_define_client
        activate_client client=osa$5744_interface_gateway
      quit
    collect_end
  IFEND

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  IF local_status.normal THEN
    IF gateway THEN
      put_line ' OSA$5744_INTERFACE_GATEWAY application is defined' o=$response
    ELSE
      put_line ' OSA$5744_INTERFACE_DGRAM application is defined' o=$response
    IFEND
  IFEND

  EXIT PROCEDURE WITH local_status WHEN NOT local_status.normal

PROCEND rap$define_5744_interface

*DECK DECK=RAM$DEFINE_BTF EXPAND=TRUE
PROC rap$define_btf (
  status)


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"   This request defines BTF.
*IFEND


    create_variable command_file k=string v='$local.'//$unique
    create_variable ignore_status k=status
    create_variable local_status k=status


  collect_text $fname(command_file) until='  collect_end'
    $system.osf$command_library.manage_network_applications
      define_client client=osa$batch_transfer_client protocol=cdna_session
        change_connection_priority cp=2
        change_maximum_connections mc=20
        change_client_validation sp=true
      end_define_client
      activate_client client=osa$batch_transfer_client
    quit
  collect_end

  include_file $fname(command_file) status=local_status
  detach_file $fname(command_file) status=ignore_status

  IF local_status.normal THEN
    put_line ' BTF application is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$define_btf
*DECK DECK=RAM$DEFINE_BTFS EXPAND=TRUE
PROC rap$define_btfs (
  family_names, family_name, fn: list of name 1..26 = $required
  status)


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"   This request defines BTFS.
*IFEND


    create_variable command_file k=string v='$local.'//$unique
    create_variable ignore_status k=status
    create_variable local_status k=status


  collect_text $fname(command_file) until='  collect_end' sm='?'
    $system.osf$command_library.manage_network_applications
      define_server server=osa$batch_transfer_server protocol=cdna_session nam_initiated=false
        change_connection_priority cp=2
        change_accept_connection ac=false
        change_maximum_connections mc=40
        change_server_validation sp=false
        add_client_address si=cdcnet ai=all
        FOR i = 1 TO $set_count(family_names) DO
          include_line 'add_titles btfs$'//$string($value(family_name i))
        FOREND
      end_define_server
      activate_server server=osa$batch_transfer_server
    quit
  collect_end

  include_file $fname(command_file) status=local_status
  detach_file $fname(command_file) status=ignore_status

  IF local_status.normal THEN
    put_line ' BTFS application is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$define_btfs
*DECK DECK=RAM$DEFINE_CATALOG_PERMIT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'DEFINE_SUBPRODUCT Subutility: DEFINE_CATALOG_PERMIT Subcommand.' ??
MODULE ram$define_catalog_permit;

{ PURPOSE:
{   This module defines a public permit for a catalog in the
{   current subproduct.
{
{ DESIGN:
{   This module is the driver for the DEFINE_CATALOG_PERMIT
{   in the DEFINE_SUBPRODUCTS utility.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc rap$define_permit

?? TITLE := '[XDCL] rap$define_catalog_permit', EJECT ??

{ PURPOSE:
{   This procedure defines a public permit for a catalog in the
{   current subproduct.
{
{ DESIGN:
{   This procedure is only the command interface.  RAM$DEFINE_PERMITS
{   is where the actual work is completed.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$define_catalog_permit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt defcp_pdt (
{   catalog, c                     : file or key installation_path_catalog = $required
{   access_modes, access_mode, am  : list of key none, read, execute, append, modify, shorten, write, ..
{                                    all, cycle, control = $required
{   share_modes, share_mode, sm    : list of key none, read, execute, append, modify, shorten, write, ..
{                                    all = $optional
{   application_information, ai    : string 0..31 = $optional
{   status                         : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    defcp_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^defcp_pdt_names, ^defcp_pdt_params
      ];

  VAR
    defcp_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 11] of
      clt$parameter_name_descriptor := [['CATALOG', 1], ['C', 1], ['ACCESS_MODES', 2], ['ACCESS_MODE', 2], [
      'AM', 2], ['SHARE_MODES', 3], ['SHARE_MODE', 3], ['SM', 3], ['APPLICATION_INFORMATION', 4], ['AI', 4], [
      'STATUS', 5]];

  VAR
    defcp_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of clt$parameter_descriptor := [

{ CATALOG C }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^defcp_pdt_kv1, clc$file_value]],

{ ACCESS_MODES ACCESS_MODE AM }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [^defcp_pdt_kv2,
      clc$keyword_value]],

{ SHARE_MODES SHARE_MODE SM }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [^defcp_pdt_kv3,
      clc$keyword_value]],

{ APPLICATION_INFORMATION AI }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, 31]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    defcp_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := [
      'INSTALLATION_PATH_CATALOG'];

  VAR
    defcp_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 10] of ost$name := ['NONE','READ',
      'EXECUTE','APPEND','MODIFY','SHORTEN','WRITE','ALL','CYCLE','CONTROL'];

  VAR
    defcp_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 8] of ost$name := ['NONE','READ',
      'EXECUTE','APPEND','MODIFY','SHORTEN','WRITE','ALL'];

?? POP ??

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, defcp_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$define_permit ('CATALOG', status);

  PROCEND rap$define_catalog_permit;

MODEND ram$define_catalog_permit;
*DECK DECK=RAM$DEFINE_CHANNEL_NETWORK EXPAND=TRUE
PROC define_channel_network (
  physical_data_array  : array of string = $optional
  host_network         : string = $required
  network_ids          : array of string = $optional
  system_ids           : array of string = $required
  relays               : array of string = $optional
  physical_entries     : integer = $optional
  lcu_entries          : var of integer = $optional
  status               : var of status = $optional
  )

" Make local copies of the procedure parameters.

  physical_data = $value(physical_data_array)
  host_network_id = $value(host_network)
  network_id_array = $value(network_ids)
  system_id_array = $value(system_ids)
  rr_array = $value(relays)
  number_physical_entries = $value(physical_entries)
  number_lcu_entries = $value(lcu_entries)

  create_variable (choice cr_requested) k=string
  create_variable conversion_status k=status
  create_variable i k=integer
  create_variable successful boolean

main_loop: ..
  LOOP

    put_line ('1Define Channel Network'..
          '0Choose channel network to define or modify:' ..
          '0                                        Channel Serial   Relays   Network' ..
          '         Element Name                     Number Number Restricted Identifier'..
          '  ')
    FOR di_number = 1 TO number_physical_entries DO
      text = physical_data(di_number) // '     ' // $substr(rr_array(di_number), 1, 7) //..
            network_id_array(di_number)
      put_line text
    FOREND

    put_line ('0Enter a menu selection, QUIT, GO, or ?: ')

    choice = ''
    accept_line choice input p=''

    IF (choice = '?') OR ($translate(lower_to_upper, choice) = 'HELP') THEN

      put_line (..
            '0This menu prompts you to define the network configuration of your '..
            ' mainframe. The network configuration consists of channel networks'..
            ' which are connections between a CYBER channel and a CDCNET DI.  The'..
            ' channel networks for this mainframe are displayed as menu selections.'..
            '0Enter a menu selection to set the parameters for a channel network.'..
            ' Enter GO or press NEXT to install the network configuration'..
            '   you have defined.'..
            ' Enter QUIT to return to the main menu without installing the'..
            '   configuration.  Any network configuration parameters you have set'..
            '   will be lost.'..
            '  ')
      accept_line cr_requested input p='Press NEXT: '

    ELSEIF ($translate(lower_to_upper, choice) = 'QUIT') OR ($translate(lower_to_upper, choice) = 'QUI') THEN

      EXIT main_loop

    ELSEIF (choice  = ' ') OR ($translate(lower_to_upper, choice) = 'GO') THEN

      install_network_config_file TRUE host_network_id network_id_array system_id_array rr_array physical_data ..
          number_physical_entries number_lcu_entries success=successful
      IF successful THEN
        $value(network_ids) = network_id_array
        $value(relays) = rr_array
        $value(lcu_entries) = number_lcu_entries
        EXIT main_loop
      IFEND

    ELSE
      include_line 'i = $integer(choice)' status=conversion_status
      IF conversion_status.normal THEN
        IF (i >= 1) AND (i <= number_physical_entries) THEN
          prompt_for_channel_network physical_data(i) host_network_id number_physical_entries rr_array(i) network_id_array(i) ..
               number_lcu_entries
          CYCLE main_loop
        IFEND
      IFEND
      put_line '  '
      accept_line cr_requested input p='Invalid selection, press NEXT: '
    IFEND

  LOOPEND main_loop

PROCEND define_channel_network
*DECK DECK=RAM$DEFINE_CORRECTION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'CREATE_SUBPRODUCT_CORRECTION subutility: DEFINE_CORRECTION command.' ??
MODULE ram$define_correction;

{ PURPOSE:
{   This module contains the command interface to begin the definition of a
{   subproduct correction.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$pacs_processor_version
*copyc rac$sif_file_name
*copyc rac$subproduct_info_level
*copyc rae$install_software_cc
*copyc rae$package_software_cc
*copyc rat$path
*copyc rat$subproduct_info_types
*copyc rat$subproduct_verify_options
*copyc rat$validation_selections
?? POP ??
*copyc amp$get_segment_pointer
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc pfp$convert_fs_path_to_pf_path
*copyc pfp$convert_string_to_fs_path
*copyc pmp$get_compact_date_time
*copyc pmp$get_unique_name
*copyc rap$convert_path_to_str
*copyc rap$get_sif_pointers
*copyc rap$locate_element
*copyc rap$open_file
*copyc rap$reset_correction_environ
*copyc rap$validate_installation_paths
*copyc rap$verify_subproduct
*copyc rav$correction_process_record

?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

{   The compare_element_record contains information about a specific element
{   in the element list.  The compare_element_array contains information
{   about all elements in the element list.  Two compare_element_arrays that
{   have been sorted by path_name can be used to test the element lists for
{   equality.

{

  TYPE
    compare_element_record = record
      path_name: rat$path,
      attributes_checksum: rat$checksum,
      correction_format: rat$correction_format,
    recend;

  TYPE
    compare_element_array_p = ^array [ * ] of compare_element_record;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$define_correction', EJECT ??

{ PURPOSE:
{   This procedure begins the definition of a subproduct correction
{   by specifying the name of the subproduct and the PACS catalogs
{   which will be used as the basis for the correction.
{
{ DESIGN:
{   1) This procedure opens the subproduct information file for the base
{   level pacs catalog, current level pacs catalog, and the previous level
{   pacs catalog (if specified).
{
{   2) The new subproduct info sequence is initialized with the values from
{   the current subproduct info sequence.
{
{   3) The subproducts are verified.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$define_correction
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE defc_pdt (
{   name, n: name = $required
{   base_level_catalog, blc: file = $required
{   current_level_catalog, clc: file = $required
{   previous_correction_catalog, pcc: file = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 9] of clt$pdt_parameter_name,
        parameters: array [1 .. 5] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
        type5: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 7, 14, 13, 53, 54, 53], clc$command, 9, 5, 3, 0, 0, 0, 5, 'DEFC_PDT'],
            [['BASE_LEVEL_CATALOG             ', clc$nominal_entry, 2],
            ['BLC                            ', clc$abbreviation_entry, 2],
            ['CLC                            ', clc$abbreviation_entry, 3],
            ['CURRENT_LEVEL_CATALOG          ', clc$nominal_entry, 3],
            ['N                              ', clc$abbreviation_entry, 1],
            ['NAME                           ', clc$nominal_entry, 1],
            ['PCC                            ', clc$abbreviation_entry, 4],
            ['PREVIOUS_CORRECTION_CATALOG    ', clc$nominal_entry, 4],
            ['STATUS                         ', clc$nominal_entry, 5]], [
{ PARAMETER 1
      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 3
      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 4
      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 5
      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
      [[1, 0, clc$file_type]],
{ PARAMETER 3
      [[1, 0, clc$file_type]],
{ PARAMETER 4
      [[1, 0, clc$file_type]],
{ PARAMETER 5
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$name = 1,
      p$base_level_catalog = 2,
      p$current_level_catalog = 3,
      p$previous_correction_catalog = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      ignore_status: ost$status,
      local_status: ost$status;

?? OLDTITLE ??
?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If an abort situation occurs, all open files are closed.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      rap$reset_correction_environ (rav$correction_process_record, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF rav$correction_process_record.correction_in_progress THEN
      osp$set_status_abnormal ('RA', rae$genc_not_called, '', local_status);
      osp$generate_error_message (local_status, ignore_status);
    IFEND;

    { Reset the correction process record to its initial values.
    rap$reset_correction_environ (rav$correction_process_record, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      { Open the Subproduct Information Files.
      open_subproduct_info_file (pvt [p$base_level_catalog].value^,
            rav$correction_process_record.base_level_sif, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      open_subproduct_info_file (pvt [p$current_level_catalog].value^,
            rav$correction_process_record.current_level_sif, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF pvt [p$previous_correction_catalog].specified THEN
        open_subproduct_info_file (pvt [p$previous_correction_catalog].value^,
              rav$correction_process_record.previous_correction_sif, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
      IFEND;

      initialize_subproduct_info_seq (rav$correction_process_record.base_level_sif.subproduct_info_pointers,
            rav$correction_process_record.current_level_sif.subproduct_info_pointers,
            rav$correction_process_record.previous_correction_sif,
            rav$correction_process_record.new_subproduct_info_pointers, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      validate_subproducts (pvt [p$name].value^.name_value,
            rav$correction_process_record.base_level_sif.subproduct_info_pointers,
            rav$correction_process_record.current_level_sif.subproduct_info_pointers,
            rav$correction_process_record.previous_correction_sif,
            rav$correction_process_record.new_subproduct_info_pointers, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

    END /main/;

    IF NOT status.normal THEN
      rap$reset_correction_environ (rav$correction_process_record, ignore_status);
    ELSE;
      rav$correction_process_record.correction_in_progress := TRUE;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$define_correction;

?? OLDTITLE ??
?? NEWTITLE := 'change_correction_format_to_rep', EJECT ??

{ PURPOSE:
{   This procedure changes the correction format of an element to replacement.
{
{ DESIGN:
{   The element is located and the correction format is changed to replacement.
{
{ NOTES:
{

  PROCEDURE change_correction_format_to_rep
    (    path_name: rat$path;
         element_list_p: ^rat$element;
     VAR subproduct_info_seq_p: ^rat$subproduct_info_sequence;
     VAR status: ost$status);

    VAR
      element_found: boolean,
      element_p: ^rat$element,
      element_path_p: ^pft$path,
      fs_path: fst$path,
      ignore_cycle_reference: fst$cycle_reference,
      ignore_cycle_selector: clt$cycle_selector,
      ignore_open_position: fst$open_position,
      number_of_path_elements: fst$number_of_path_elements;

    status.normal := TRUE;
    element_p := element_list_p;

    pfp$convert_string_to_fs_path (path_name.path (1, path_name.size), fs_path, number_of_path_elements,
          ignore_cycle_reference, ignore_open_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH element_path_p: [1 .. number_of_path_elements];
    pfp$convert_fs_path_to_pf_path (fs_path, element_path_p, ignore_cycle_reference, ignore_cycle_selector,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$locate_element (element_path_p, number_of_path_elements, subproduct_info_seq_p, element_p,
          element_found);
    element_p^.correction_format := rac$replacement;

  PROCEND change_correction_format_to_rep;

?? OLDTITLE ??
?? NEWTITLE := 'convert_container_to_path_str', EJECT ??

{ PURPOSE:
{   This procedure converts a group of path containers into a file path string.
{
{ DESIGN:
{   The path_containers are converted into a pft$path and then into a rat$path
{   using another procedure.
{
{ NOTES:
{

  PROCEDURE convert_container_to_path_str
    (    path_container: rat$path_container;
         path_container_index: rat$path_container_indexer;
     VAR path_str: rat$path);

    VAR
      j: rat$path_container_index,
      pf_path_p: ^pft$path;

    IF path_container_index.path_length = 0 THEN
      path_str.path := 'NONE';
      path_str.size := 4;
    ELSE
      PUSH pf_path_p: [1 .. path_container_index.path_length];

      FOR j := 1 TO (path_container_index.path_length) DO
        pf_path_p^ [j] := path_container [j + path_container_index.path_container_index - 1];
      FOREND;

      rap$convert_path_to_str (pf_path_p^, path_str);
    IFEND;

  PROCEND convert_container_to_path_str;

?? OLDTITLE ??
?? NEWTITLE := 'initialize_subproduct_info_seq', EJECT ??

{ PURPOSE:
{   This procedure initializes the subproduct info sequence in memory.
{
{ DESIGN:
{   This procedure:
{   1) Copies the current subproduct info sequence to the new subproduct
{   info sequence in memory.
{   2) Resets the new subproduct info sequence in memory.
{   3) Nexts on the sequence descriptor record and initializes its fields.
{   4) Nexts on the header record.
{   5) Locates the attributes record.  Set the installation scheme from the
{   previous correction attributes (if specified), else from the base level
{   attributes.
{   6) Nexts on the path containers from the base level sif.
{   7) Updates the new_subproduct_info_pointers field of the correction process
{   record.
{
{ NOTES:
{

  PROCEDURE initialize_subproduct_info_seq
    (    base_subproduct_info_ptrs: rat$subproduct_info_pointers;
         current_subproduct_info_ptrs: rat$subproduct_info_pointers;
         previous_correction_sif: rat$correction_process_sif_info;
     VAR new_subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);

    VAR
      attributes_p: ^rat$subproduct_attributes,
      info_header_p: ^rat$subproduct_info_header,
      local_status: ost$status,
      new_subproduct_info_seq_p: ^rat$subproduct_info_sequence,
      path_container_p: ^rat$path_container,
      sequence_descriptor_p: ^rat$sequence_descriptor,
      subproduct_info_seq_size: rat$subproduct_size;

    status.normal := TRUE;

    subproduct_info_seq_size := #SIZE (current_subproduct_info_ptrs.subproduct_info_seq_p^);

    NEXT new_subproduct_info_seq_p: [[REP subproduct_info_seq_size OF cell]] IN
          new_subproduct_info_pointers.subproduct_info_seq_p;
    IF new_subproduct_info_seq_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'NEW SUBPRODUCT_INFO_SEQUENCE', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'initial creation', status);
      RETURN;
    IFEND;

    new_subproduct_info_seq_p^ := current_subproduct_info_ptrs.subproduct_info_seq_p^;

    RESET new_subproduct_info_seq_p;
    NEXT sequence_descriptor_p IN new_subproduct_info_seq_p;
    IF sequence_descriptor_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'NEW SUBPRODUCT_INFO_SEQUENCE', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sequence_descriptor', status);
      RETURN;
    IFEND;

    { Initialize the values for the sequence descriptor record.

    pmp$get_compact_date_time (sequence_descriptor_p^.sequence_creation_date_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    sequence_descriptor_p^.processor_version := rac$pacs_processor_version;
    sequence_descriptor_p^.sequence_level := rac$subproduct_info_level;
    sequence_descriptor_p^.sequence_type := rac$subproduct_info_sequence;

    NEXT info_header_p IN new_subproduct_info_seq_p;
    IF info_header_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'NEW SUBPRODUCT_INFO_SEQUENCE', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'info header', status);
      RETURN;
    IFEND;

    attributes_p := #PTR (info_header_p^.attributes_p, new_subproduct_info_seq_p^);

    { Change the value of the subproduct type to correction.
    attributes_p^.subproduct_type := rac$correction;

    { Initialize the value of the correction base_level.
    attributes_p^.correction_base_level := base_subproduct_info_ptrs.attributes_p^.level;

    { Initialize the service_critical_file_size, the product_file_size and the subproduct size
    { in the attributes record.

    attributes_p^.service_critical_file_size := 0;
    attributes_p^.user_permanent_file_size := 0;
    attributes_p^.product_file_size := 0;
    attributes_p^.size := 0;

    { Set the value of the installation scheme from the previous correction
    { (if specified), else from the base level attributes.

    IF previous_correction_sif.file_opened THEN
      attributes_p^.installation_scheme := previous_correction_sif.subproduct_info_pointers.attributes_p^.
            installation_scheme;
    ELSE
      attributes_p^.installation_scheme := base_subproduct_info_ptrs.attributes_p^.installation_scheme;
    IFEND;

    { Set the value of the correction_base_sif_identifier for this correction.
    attributes_p^.correction_base_sif_identifier := base_subproduct_info_ptrs.attributes_p^.sif_identifier;

    { Set the value of the unique sif_identifier for this correction.

    pmp$get_unique_name (attributes_p^.sif_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Initialize the fields of the correction process record new subproduct
    { info pointers.

    new_subproduct_info_pointers.sequence_descriptor_p := sequence_descriptor_p;
    new_subproduct_info_pointers.info_header_p := info_header_p;
    new_subproduct_info_pointers.attributes_p := attributes_p;
    new_subproduct_info_pointers.element_list_p := #PTR (info_header_p^.element_list_p,
          new_subproduct_info_seq_p^);
    new_subproduct_info_pointers.path_container_p := #PTR (info_header_p^.path_container_p,
          new_subproduct_info_seq_p^);
    new_subproduct_info_pointers.psrs_answered_p := #PTR (info_header_p^.psrs_answered_p,
          new_subproduct_info_seq_p^);

  PROCEND initialize_subproduct_info_seq;

?? OLDTITLE ??
?? NEWTITLE := 'open_subproduct_info_file', EJECT ??

{ PURPOSE:
{   This procedure opens a subproduct information file and records
{   information about the file in the correction processing record.
{
{ DESIGN:
{   This procedure opens the subproduct information file.  The file
{   identifier, the file opened boolean, and subproduct info pointers are
{   recorded in the correction processing record.
{
{ NOTES:
{

  PROCEDURE open_subproduct_info_file
    (    pacs_catalog: clt$data_value;
     VAR sif_info: rat$correction_process_sif_info;
     VAR status: ost$status);

    VAR
      subproduct_information_file: rat$path,
      ignore_segment_pointer: mmt$segment_pointer,
      segment_p: amt$segment_pointer;

    status.normal := TRUE;
    ignore_segment_pointer.seq_pointer := NIL;

    STRINGREP (subproduct_information_file.path, subproduct_information_file.size, pacs_catalog.file_value^,
          '.', rac$sif_file_name);

    rap$open_file (^subproduct_information_file.path (1, subproduct_information_file.size), amc$segment,
          fsc$read, FALSE, NIL, sif_info.fid, sif_info.file_opened, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (sif_info.fid, amc$sequence_pointer, segment_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$get_sif_pointers (segment_p, ignore_segment_pointer, pacs_catalog.file_value,
          sif_info.subproduct_info_pointers, status);

  PROCEND open_subproduct_info_file;

?? OLDTITLE ??
?? NEWTITLE := 'sort_path_array', EJECT ??

{ PURPOSE:
{   This procedure sorts the array of element paths.
{
{ DESIGN:
{   This procedure uses a shell sort.
{
{ NOTES:
{

  PROCEDURE sort_path_array
    (    path_array_p: compare_element_array_p);

    VAR
      current: integer,
      gap: integer,
      start: integer,
      swap: compare_element_record;


    gap := UPPERBOUND (path_array_p^);
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := LOWERBOUND (path_array_p^) TO UPPERBOUND (path_array_p^) - gap DO
        current := start;
        WHILE (current > 0) AND (path_array_p^ [current].path_name.
              path (1, path_array_p^ [current].path_name.size) < path_array_p^ [current + gap].
              path_name.path (1, path_array_p^ [current + gap].path_name.size)) DO
          swap := path_array_p^ [current];
          path_array_p^ [current] := path_array_p^ [current + gap];
          path_array_p^ [current + gap] := swap;
          current := current - gap;
        WHILEND;
      FOREND;
    WHILEND;

  PROCEND sort_path_array;

?? OLDTITLE ??
?? NEWTITLE := 'validate_attributes_checksums', EJECT ??

{ PURPOSE:
{   This procedure compares the element attributes checksum of the base and
{   current subproduct information files.
{
{ DESIGN:
{   The attributes checksums are entered and compared.  If a difference is
{   found between the checksums an information message is displayed.
{
{ NOTES:
{

  PROCEDURE validate_attributes_checksums
    (    base_attributes_checksum: rat$checksum;
         current_attributes_checksum: rat$checksum;
         current_path_name: rat$path);

    VAR
      ignore_status: ost$status,
      local_status: ost$status;


    IF base_attributes_checksum <> current_attributes_checksum THEN

      osp$set_status_abnormal ('RA', rae$attributes_checksum_differ, current_path_name.
            path (1, current_path_name.size), local_status);
      osp$generate_error_message (local_status, ignore_status);

    IFEND;

  PROCEND validate_attributes_checksums;

?? OLDTITLE ??
?? NEWTITLE := 'validate_contents_cksums_exist', EJECT ??

{ PURPOSE:
{   This procedure verifies that the files in the PACS catalogs were
{   checksumed during the creation of their subproduct information files.
{
{ DESIGN:
{   1) The calculate_contents_checksum attribute is checked in the
{   base and current level subproduct information files.
{
{ NOTES:
{

  PROCEDURE validate_contents_cksums_exist
    (    base_attributes: rat$subproduct_attributes;
         current_attributes: rat$subproduct_attributes;
     VAR status: ost$status);

    status.normal := TRUE;

    IF NOT base_attributes.calculate_contents_checksum THEN
      osp$set_status_abnormal ('RA', rae$no_contents_checksum, base_attributes.pacs_catalog_path.
            path (1, base_attributes.pacs_catalog_path.size), status);

    ELSEIF NOT current_attributes.calculate_contents_checksum THEN
      osp$set_status_abnormal ('RA', rae$no_contents_checksum, current_attributes.pacs_catalog_path.
            path (1, current_attributes.pacs_catalog_path.size), status);
    IFEND;

  PROCEND validate_contents_cksums_exist;

?? OLDTITLE ??
?? NEWTITLE := 'validate_correction_formats', EJECT ??

{ PURPOSE:
{   This procedure compares the element correction formats of the base and
{   current subproduct information files.
{
{ DESIGN:
{   The correction formats are entered and compared.  If a difference is
{   found between the correction formats, then if:
{   1) the current correction format is replacement, that's OK.
{   2) the base correction format is repelacement and the current is not
{   replacement, set the new to replacement and issue an informative message.
{   3) the current is source and the base is object or vice versa.
{   Set an error condition.
{
{ NOTES:
{

  PROCEDURE validate_correction_formats
    (    base_correction_format: rat$correction_format;
         base_path_name: rat$path;
         base_pacs_catalog_path: rat$path;
         current_correction_format: rat$correction_format;
         current_path_name: rat$path;
         current_pacs_catalog_path: rat$path;
     VAR new_subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);

    VAR
      base_file_path: rat$path,
      current_file_path: rat$path,
      ignore_status: ost$status,
      local_status: ost$status;

*copy rav$correction_format

    status.normal := TRUE;

    IF base_correction_format <> current_correction_format THEN

      STRINGREP (base_file_path.path, base_file_path.size, base_pacs_catalog_path.
            path (1, base_pacs_catalog_path.size), '.', base_path_name.path (1, base_path_name.size));
      STRINGREP (current_file_path.path, current_file_path.size, current_pacs_catalog_path.
            path (1, current_pacs_catalog_path.size), '.', current_path_name.
            path (1, current_path_name.size));


      IF current_correction_format = rac$replacement THEN
        {Everythings OK.
      ELSEIF base_correction_format = rac$replacement THEN
        change_correction_format_to_rep (current_path_name, new_subproduct_info_pointers.element_list_p,
              new_subproduct_info_pointers.subproduct_info_seq_p, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        osp$set_status_abnormal ('RA', rae$correction_format_warning, base_path_name.
              path (1, base_path_name.size), local_status);
        osp$generate_error_message (local_status, ignore_status);

      ELSE {Changing from SOURCE LIBRARY to OBJECT LIBRARY or vice versa.}
        osp$set_status_abnormal ('RA', rae$correction_format_error, base_path_name.
              path (1, base_path_name.size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              rav$correction_format [base_correction_format], status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              rav$correction_format [current_correction_format], status);
      IFEND;

    IFEND;

  PROCEND validate_correction_formats;

?? OLDTITLE ??
?? NEWTITLE := 'validate_creation_dates', EJECT ??

{ PURPOSE:
{   This procedure compares the creation date of two subproduct
{   information files to ensure the proper order of creation (first before last).
{
{ DESIGN:
{   The date_level fields in the attributes records are compared.  The first
{   subproduct information file must have an earlier date than the last
{   subproduct information file.
{
{ NOTES:
{

  PROCEDURE validate_creation_dates
    (    base_date_level: rat$subproduct_date_level;
         base_pacs_catalog_path: rat$path;
         current_date_level: rat$subproduct_date_level;
         current_pacs_catalog_path: rat$path;
     VAR status: ost$status);

    status.normal := TRUE;

    IF base_date_level > current_date_level THEN
      osp$set_status_abnormal ('RA', rae$wrong_order_for_creation, base_pacs_catalog_path.
            path (1, base_pacs_catalog_path.size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, current_pacs_catalog_path.
            path (1, current_pacs_catalog_path.size), status);
    IFEND;

  PROCEND validate_creation_dates;

?? OLDTITLE ??
?? NEWTITLE := 'validate_element_lists', EJECT ??

{ PURPOSE:
{   This procedure compares two element lists to verify that they have the
{   same set of elements and that certain fields of the element records are
{   compatible.
{
{ DESIGN:
{   1) The number of elements in each element list is compared.
{   2) Two arrays are created.
{   3) The file paths (minus the PACS catalog), the attributes checksum, and
{   the correction format of all elements in each element list are written
{   to an array.
{   4) The arrays are sorted.
{   5) The arrays are compared to be sure they have the same elements.  If
{   the elements are files, their attributes checksums and correction
{   formats are compared.  If the attributes checksums are different an
{   informative message is displayed.  The correction format can change from
{   source library or object library to replacement, but not the other way.
{   If the base level element is of type replacement and the current level
{   is of another type, the procedure will automatically change the new
{   element to type replacement.  An error will be displayed if the the base
{   is of type source library and the current is of type object library or
{   vice versa.
{
{ NOTES:
{   The correction format and attributes checksum fields are meaningless for
{   catalogs.  They are initialized to dummy variables.

  PROCEDURE validate_element_lists
    (    base_subproduct_info_ptrs: rat$subproduct_info_pointers;
         current_subproduct_info_ptrs: rat$subproduct_info_pointers;
     VAR new_subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);

    VAR
      base_attributes: rat$subproduct_attributes,
      base_element_count: rat$element_count,
      base_path_array_p: compare_element_array_p,
      base_seq_p: ^SEQ ( * ),
      catalog_path: rat$path,
      current_attributes: rat$subproduct_attributes,
      current_element_count: rat$element_count,
      current_path_array_p: compare_element_array_p,
      current_seq_p: ^SEQ ( * ),
      i: rat$element_count;


    status.normal := TRUE;
    catalog_path.path := ' ';
    catalog_path.size := 1;

    base_attributes := base_subproduct_info_ptrs.attributes_p^;
    current_attributes := current_subproduct_info_ptrs.attributes_p^;

    base_element_count := base_attributes.subproduct_element_count;
    current_element_count := current_attributes.subproduct_element_count;

    IF base_element_count <> current_element_count THEN
      osp$set_status_abnormal ('RA', rae$unequal_element_count, base_attributes.pacs_catalog_path.
            path (1, base_attributes.pacs_catalog_path.size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, current_attributes.pacs_catalog_path.
            path (1, current_attributes.pacs_catalog_path.size), status);
      RETURN;
    IFEND;

    PUSH base_seq_p: [[REP base_element_count * #SIZE (compare_element_record) OF cell]];
    RESET base_seq_p;

    write_element_names_to_seq (catalog_path, base_subproduct_info_ptrs.subproduct_info_seq_p,
          base_subproduct_info_ptrs.element_list_p, base_seq_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET base_seq_p;
    NEXT base_path_array_p: [1 .. base_element_count] IN base_seq_p;
    IF base_path_array_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'LOCAL BASE_PATH_ARRAY SEQUENCE',
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'initial creation', status);
      RETURN;
    IFEND;

    PUSH current_seq_p: [[REP current_element_count * #SIZE (compare_element_record) OF cell]];
    RESET current_seq_p;

    write_element_names_to_seq (catalog_path, current_subproduct_info_ptrs.subproduct_info_seq_p,
          current_subproduct_info_ptrs.element_list_p, current_seq_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET current_seq_p;
    NEXT current_path_array_p: [1 .. current_element_count] IN current_seq_p;
    IF current_path_array_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'LOCAL CURRENT_PATH_ARRAY SEQUENCE',
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'initial creation', status);
      RETURN;
    IFEND;

    sort_path_array (base_path_array_p);
    sort_path_array (current_path_array_p);

    FOR i := 1 TO base_element_count DO

      validate_path_names (base_path_array_p^ [i].path_name, base_attributes.pacs_catalog_path,
            current_path_array_p^ [i].path_name, current_attributes.pacs_catalog_path, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      validate_attributes_checksums (base_path_array_p^ [i].attributes_checksum,
            current_path_array_p^ [i].attributes_checksum, current_path_array_p^ [i].path_name);

      validate_correction_formats (base_path_array_p^ [i].correction_format, base_path_array_p^ [i].path_name,
            base_attributes.pacs_catalog_path, current_path_array_p^ [i].correction_format,
            current_path_array_p^ [i].path_name, current_attributes.pacs_catalog_path,
            new_subproduct_info_pointers, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    FOREND;

  PROCEND validate_element_lists;

?? OLDTITLE ??
?? NEWTITLE := 'validate_installer_procedures', EJECT ??

{ PURPOSE:
{   This procedure compares the installer procedures of the base
{   and current subproducts.
{
{ DESIGN:
{   The installer procedures are entered and compared.  If a difference is
{   found between the paths an error status is set.
{
{ NOTES:
{

  PROCEDURE validate_installer_procedures
    (    base_installer_proc: rat$path_container_indexer;
         base_pacs_catalog_path: rat$path;
         base_path_container: rat$path_container;
         current_installer_proc: rat$path_container_indexer;
         current_pacs_catalog_path: rat$path;
         current_path_container: rat$path_container;
         current_installation_scheme : rat$installation_scheme;
     VAR status: ost$status);

    VAR
      base_installer_proc_str: rat$path,
      current_installer_proc_str: rat$path,
      ignore_status: ost$status,
      local_status: ost$status;

    status.normal := TRUE;

    convert_container_to_path_str (base_path_container, base_installer_proc, base_installer_proc_str);

    convert_container_to_path_str (current_path_container, current_installer_proc,
          current_installer_proc_str);

    IF base_installer_proc_str.path (1, base_installer_proc_str.size) <>
          current_installer_proc_str.path (1, current_installer_proc_str.size) THEN
      IF current_installation_scheme = rac$version_based THEN
        osp$set_status_abnormal ('RA', rae$unmatched_attribute_warning,
              'Installer Procedure',local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              base_pacs_catalog_path.path (1, base_pacs_catalog_path.size),
             local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              base_installer_proc_str.path (1, base_installer_proc_str.size),
             local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              current_pacs_catalog_path.path (1, current_pacs_catalog_path.size),
             local_status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              current_installer_proc_str.path (1,
              current_installer_proc_str.size),local_status);
        osp$generate_error_message (local_status, ignore_status);
      ELSE
        osp$set_status_abnormal ('RA', rae$unmatched_attribute,
              'Installer Procedure', status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              base_pacs_catalog_path.path (1, base_pacs_catalog_path.size),
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              base_installer_proc_str.path (1, base_installer_proc_str.size),
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              current_pacs_catalog_path.path (1, current_pacs_catalog_path.size),
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              current_installer_proc_str.path (1,
              current_installer_proc_str.size), status);
      IFEND

    IFEND;

  PROCEND validate_installer_procedures;

?? OLDTITLE ??
?? NEWTITLE := 'validate_inst_path_option', EJECT ??

{ PURPOSE:
{   This procedure compares the installation path options of the base
{   and current subproducts.
{
{ DESIGN:
{   The installation path options are entered and compared.  If a difference is
{   found between the options an error status is set.
{
{ NOTES:
{

  PROCEDURE validate_inst_path_option
    (    base_inst_path_option: rat$installation_path_option;
         base_pacs_catalog_path: rat$path;
         current_inst_path_option: rat$installation_path_option;
         current_pacs_catalog_path: rat$path;
     VAR status: ost$status);

*copy rav$installation_path_option

    status.normal := TRUE;

    IF base_inst_path_option <> current_inst_path_option THEN
      osp$set_status_abnormal ('RA', rae$unmatched_attribute, 'Installation Path Option', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, base_pacs_catalog_path.
            path (1, base_pacs_catalog_path.size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            rav$installation_path_option [base_inst_path_option], status);
      osp$append_status_parameter (osc$status_parameter_delimiter, current_pacs_catalog_path.
            path (1, current_pacs_catalog_path.size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            rav$installation_path_option [current_inst_path_option], status);
    IFEND;

  PROCEND validate_inst_path_option;

?? OLDTITLE ??
?? NEWTITLE := 'validate_licensed_product', EJECT ??

{ PURPOSE:
{   This procedure compares the licensed product names of the base
{   and current subproducts.
{
{ DESIGN:
{   The licensed product names are entered and compared.  If a difference is
{   found between the names an error status is set.
{
{ NOTES:
{

  PROCEDURE validate_licensed_product
    (    base_licensed_product: rat$licensed_product;
         base_pacs_catalog_path: rat$path;
         current_licensed_product: rat$licensed_product;
         current_pacs_catalog_path: rat$path;
     VAR status: ost$status);

    status.normal := TRUE;


    IF base_licensed_product <> current_licensed_product THEN
      osp$set_status_abnormal ('RA', rae$unmatched_attribute, 'Licensed Product', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, base_pacs_catalog_path.
            path (1, base_pacs_catalog_path.size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, base_licensed_product, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, current_pacs_catalog_path.
            path (1, current_pacs_catalog_path.size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, current_licensed_product, status);
    IFEND;

  PROCEND validate_licensed_product;

?? OLDTITLE ??
?? NEWTITLE := 'validate_path_names', EJECT ??

{ PURPOSE:
{   This procedure compares the element path names of the base
{   and current subproduct information files.
{
{ DESIGN:
{   The path names are entered and compared.  If a difference is found between
{   the paths an error status is set.
{
{ NOTES:
{

  PROCEDURE validate_path_names
    (    base_path_name: rat$path;
         base_pacs_catalog_path: rat$path;
         current_path_name: rat$path;
         current_pacs_catalog_path: rat$path;
     VAR status: ost$status);

    VAR
      base_file_path: rat$path,
      current_file_path: rat$path;

    status.normal := TRUE;

    IF base_path_name.path (1, base_path_name.size) <> current_path_name.path (1, current_path_name.size) THEN

      STRINGREP (base_file_path.path, base_file_path.size, base_pacs_catalog_path.
            path (1, base_pacs_catalog_path.size), '.', base_path_name.path (1, base_path_name.size));
      STRINGREP (current_file_path.path, current_file_path.size, current_pacs_catalog_path.
            path (1, current_pacs_catalog_path.size), '.', current_path_name.
            path (1, current_path_name.size));

      osp$set_status_abnormal ('RA', rae$unmatched_elements, base_file_path.path (1, base_file_path.size),
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, current_file_path.
            path (1, current_file_path.size), status);
    IFEND;

  PROCEND validate_path_names;

?? OLDTITLE ??
?? NEWTITLE := 'validate_primary_subproduct', EJECT ??

{ PURPOSE:
{   This procedure compares the primary subproduct attributes of the base
{   and current subproducts.
{
{ DESIGN:
{   The primary subproduct attributes are entered and compared.  If a
{   difference is found between the attributes an error status is set.
{
{ NOTES:
{

  PROCEDURE validate_primary_subproduct
    (    base_primary_subproduct: rat$primary_subproduct;
         base_pacs_catalog_path: rat$path;
         current_primary_subproduct: rat$primary_subproduct;
         current_pacs_catalog_path: rat$path;
     VAR status: ost$status);

    VAR
      base_primary_string: string (5),
      current_primary_string: string (5);

    status.normal := TRUE;

    IF base_primary_subproduct <> current_primary_subproduct THEN

      IF base_primary_subproduct = TRUE THEN
        base_primary_string := 'TRUE ';
        current_primary_string := 'FALSE';
      ELSE
        base_primary_string := 'FALSE';
        current_primary_string := 'TRUE ';
      IFEND;

      osp$set_status_abnormal ('RA', rae$unmatched_attribute, 'Primary Subproduct', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, base_pacs_catalog_path.
            path (1, base_pacs_catalog_path.size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, base_primary_string, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, current_pacs_catalog_path.
            path (1, current_pacs_catalog_path.size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, current_primary_string, status);

    IFEND;

  PROCEND validate_primary_subproduct;

?? OLDTITLE ??
?? NEWTITLE := 'validate_subproduct_attributes', EJECT ??

{ PURPOSE:
{   This procedure verifies that specific attributes in two subproduct
{   information files are the same.
{
{ DESIGN:
{   The following subproduct attributes must match exactly between the
{   specified PACS catalogs:  licensed_product, primary_subproduct,
{   dependencies, subproduct_installation_path, installer_procedure and the
{   installation_path_option.
{
{ NOTES:
{

  PROCEDURE validate_subproduct_attributes
    (    base_attributes: rat$subproduct_attributes;
         current_attributes: rat$subproduct_attributes;
         base_path_container: rat$path_container;
         current_path_container: rat$path_container;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      local_status: ost$status;

    status.normal := TRUE;

    validate_licensed_product (base_attributes.licensed_product, base_attributes.pacs_catalog_path,
          current_attributes.licensed_product, current_attributes.pacs_catalog_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    validate_primary_subproduct (base_attributes.primary, base_attributes.pacs_catalog_path,
          current_attributes.primary, current_attributes.pacs_catalog_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    validate_subprod_dependencies (base_attributes.dependencies, base_attributes.pacs_catalog_path,
          current_attributes.dependencies, current_attributes.pacs_catalog_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$validate_installation_paths (base_attributes, base_path_container, current_attributes,
          current_path_container, base_attributes.installation_scheme, FALSE {set_status_to_error}, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    validate_installer_procedures (base_attributes.installer_procedure, base_attributes.pacs_catalog_path,
          base_path_container, current_attributes.installer_procedure, current_attributes.pacs_catalog_path,
          current_path_container, current_attributes.installation_scheme, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    validate_inst_path_option (base_attributes.installation_path_option, base_attributes.pacs_catalog_path,
          current_attributes.installation_path_option, current_attributes.pacs_catalog_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND validate_subproduct_attributes;

?? OLDTITLE ??
?? NEWTITLE := 'validate_subprod_dependencies', EJECT ??

{ PURPOSE:
{   This procedure compares the subproduct dependencies of the base
{   and current subproducts.
{
{ DESIGN:
{   The arrays of subproduct dependencies are entered and compared.  If a
{   difference is found between the dependencies an error status is set.
{
{ NOTES:
{

  PROCEDURE validate_subprod_dependencies
    (    base_subproduct_dependencies: rat$subproduct_dependencies;
         base_pacs_catalog_path: rat$path;
         current_subproduct_dependencies: rat$subproduct_dependencies;
         current_pacs_catalog_path: rat$path;
     VAR status: ost$status);

    VAR
      i: 1 .. rac$max_dependencies;

    status.normal := TRUE;


    FOR i := 1 TO rac$max_dependencies DO

      IF base_subproduct_dependencies [i] <> current_subproduct_dependencies [i] THEN
        osp$set_status_abnormal ('RA', rae$unmatched_dependencies, base_pacs_catalog_path.
              path (1, base_pacs_catalog_path.size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, current_pacs_catalog_path.
              path (1, current_pacs_catalog_path.size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, base_subproduct_dependencies [i],
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, current_subproduct_dependencies [i],
              status);
        RETURN;
      IFEND;

    FOREND;

  PROCEND validate_subprod_dependencies;

?? OLDTITLE ??
?? NEWTITLE := 'validate_subproduct_names', EJECT ??

{ PURPOSE:
{   This procedure verifies that the NAME parameter entered
{   is the same as the name stored in the attributes record of
{   subproduct information files.
{
{ DESIGN:
{   1) The NAME parameter is verified against the name in the attributes
{   record of the subproduct information files of the base level and current
{   level pacs catalogs.
{
{
{ NOTES:
{

  PROCEDURE validate_subproduct_names
    (    subproduct_name: ost$name;
         base_attributes: rat$subproduct_attributes;
         current_attributes: rat$subproduct_attributes;
     VAR status: ost$status);

    status.normal := TRUE;

    IF base_attributes.name <> subproduct_name THEN
      osp$set_status_abnormal ('RA', rae$incorrect_name_parameter, subproduct_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'Base', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, base_attributes.pacs_catalog_path.
            path (1, base_attributes.pacs_catalog_path.size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, base_attributes.name, status);
    ELSEIF current_attributes.name <> subproduct_name THEN
      osp$set_status_abnormal ('RA', rae$incorrect_name_parameter, subproduct_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'Current', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, current_attributes.pacs_catalog_path.
            path (1, current_attributes.pacs_catalog_path.size), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, current_attributes.name, status);

    IFEND;

  PROCEND validate_subproduct_names;

?? OLDTITLE ??
?? NEWTITLE := 'validate_subproducts', EJECT ??

{ PURPOSE:
{   This procedure verifies that the subproduct information
{   files agree with their PACS catalogs and with each other.
{
{ DESIGN:
{   1) If the previous correction catalog was specified, validate that it
{   was created with the same base PACS catalog as is specified on this command.
{
{   2) The NAME parameter is verified against the name in the subproduct
{   attributes record of the subproduct information file of the base and
{   current pacs catalogs.
{
{   3) Verify that the creation date of the current level subproduct info
{   file is after the creation date of the base subproduct info file.
{
{   4) Verify that the base and current PACS catalogs were created with
{   checksums enabled.
{
{   5) The base and current level catalogs are verified to be of type
{   release.
{
{   6) The following subproduct attributes must match exactly between the
{   base and current PACS catalogs:  subproduct name, licensed product name,
{   primary subproduct attribute, subproduct dependencies, installer
{   procedure, subproduct installation path and the installation path
{   option.
{
{   7) All PACS catalogs are verified to be valid PACS catalogs.
{
{ NOTES:
{

  PROCEDURE validate_subproducts
    (    subproduct_name: ost$name;
         base_subproduct_info_ptrs: rat$subproduct_info_pointers;
         current_subproduct_info_ptrs: rat$subproduct_info_pointers;
         previous_correction_sif: rat$correction_process_sif_info;
     VAR new_subproduct_info_ptrs: rat$subproduct_info_pointers;
     VAR status: ost$status);

    VAR
      base_attributes: rat$subproduct_attributes,
      current_attributes: rat$subproduct_attributes,
      ignore_status: ost$status,
      local_status: ost$status,
      validation_selections: rat$validation_selections,
      verify_errors: rat$subproduct_verify_errors,
      verify_options: rat$subproduct_verify_options;

    status.normal := TRUE;
    base_attributes := base_subproduct_info_ptrs.attributes_p^;
    current_attributes := current_subproduct_info_ptrs.attributes_p^;
    verify_errors := $rat$subproduct_verify_errors [];

    IF previous_correction_sif.file_opened THEN

      { Verify that the same base level catalog is being used to create this correction as was
      { used in the previous correction.
      IF previous_correction_sif.subproduct_info_pointers.attributes_p^.correction_base_sif_identifier <>
            base_attributes.sif_identifier THEN
        IF previous_correction_sif.subproduct_info_pointers.attributes_p^.correction_base_sif_identifier =
              '' THEN
          osp$set_status_abnormal ('RA', rae$incorrect_previous_corr, '', status);
        ELSE
          osp$set_status_abnormal ('RA', rae$different_base_catalog, '', status);
        IFEND;
        RETURN;

      IFEND;

    IFEND;

    { Verify the NAME parameter for the base and current level PACS catalog.
    validate_subproduct_names (subproduct_name, base_attributes, current_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Verify that the level parameter for the base and current level PACS catalog is different.
    IF base_attributes.level = current_attributes.level THEN
      osp$set_status_abnormal ('RA', rae$levels_should_differ, subproduct_name, local_status);
      osp$append_status_parameter (osc$status_parameter_delimiter, current_attributes.level, local_status);
      osp$generate_error_message (local_status, ignore_status);
    IFEND;

    { Verify that the creation dates are in the proper order.
    validate_creation_dates (base_attributes.date_level, base_attributes.pacs_catalog_path,
          current_attributes.date_level, current_attributes.pacs_catalog_path, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Verify that contents checksums have been calculated for the base and current PACS catalog.
    validate_contents_cksums_exist (base_attributes, current_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Verify that the base and current PACS catalogs are of the correct TYPE.
    validate_types (base_attributes, current_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Verify that the attributes of the base level subproduct information file are the same
    { as the attributes of the current level subproduct information file.
    validate_subproduct_attributes (base_attributes, current_attributes,
          base_subproduct_info_ptrs.path_container_p^, current_subproduct_info_ptrs.path_container_p^,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    { Verify that the base level catalog contains the same set of elements as
    { the current level catalog.
    validate_element_lists (base_subproduct_info_ptrs, current_subproduct_info_ptrs, new_subproduct_info_ptrs,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Verify each of the specified PACS catalogs against their subproduct
    { information files.
    validation_selections := $rat$validation_selections [rac$loading_cycle_only, rac$no_rings_below_11,
          rac$no_permits];
    verify_options := $rat$subproduct_verify_options [rac$test_mod_date_time, rac$stop_on_first_error];

    rap$verify_subproduct (^base_attributes.pacs_catalog_path.
          path (1, base_attributes.pacs_catalog_path.size), validation_selections, TRUE {SIF_PRESENT} ,
          verify_options, verify_errors, rav$correction_process_record.base_level_sif.
          subproduct_info_pointers, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$verify_subproduct (^current_attributes.pacs_catalog_path.
          path (1, current_attributes.pacs_catalog_path.size), validation_selections, TRUE {SIF_PRESENT} ,
          verify_options, verify_errors, rav$correction_process_record.current_level_sif.
          subproduct_info_pointers, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF rav$correction_process_record.previous_correction_sif.file_opened THEN
      rap$verify_subproduct (^previous_correction_sif.subproduct_info_pointers.attributes_p^.
            pacs_catalog_path.path (1, previous_correction_sif.subproduct_info_pointers.attributes_p^.
            pacs_catalog_path.size), validation_selections, TRUE {SIF_PRESENT} , verify_options,
            verify_errors, rav$correction_process_record.previous_correction_sif.subproduct_info_pointers,
            status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND validate_subproducts;

?? OLDTITLE ??
?? NEWTITLE := 'validate_types', EJECT ??

{ PURPOSE:
{   This procedure verifies that the base and current level PACS catalogs were created
{   with the correct TYPE.
{
{ DESIGN:
{   1) The subproduct type in the attributes record of each subproduct
{   information file is verified to be of the correct type.
{   The base and current level PACS catalogs must be of type release.
{
{ NOTES:
{

  PROCEDURE validate_types
    (    base_attributes: rat$subproduct_attributes;
         current_attributes: rat$subproduct_attributes;
     VAR status: ost$status);

    status.normal := TRUE;

    IF base_attributes.subproduct_type <> rac$release THEN
      osp$set_status_abnormal ('RA', rae$wrong_subproduct_type, base_attributes.pacs_catalog_path.
            path (1, base_attributes.pacs_catalog_path.size), status);
    ELSEIF current_attributes.subproduct_type <> rac$release THEN
      osp$set_status_abnormal ('RA', rae$wrong_subproduct_type, current_attributes.pacs_catalog_path.
            path (1, current_attributes.pacs_catalog_path.size), status);
    IFEND;

  PROCEND validate_types;

?? OLDTITLE ??
?? NEWTITLE := 'write_element_names_to_seq', EJECT ??

{ PURPOSE:
{   This procedure writes the path of each file or catalog
{   in the element list to the sequence.
{
{ DESIGN:
{   First the element name is concatenated with the name of its upper level
{   catalog and written to the sequence.  If the element is a catalog this
{   procedure is called recursively.  If the element is a file, the next
{   element across is set equal to the element and processed.
{
{ NOTES:
{

  PROCEDURE write_element_names_to_seq
    (    catalog_path: rat$path;
         subproduct_info_seq_p: ^rat$subproduct_info_sequence;
         element_p: ^rat$element;
     VAR seq_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      next_element_down_p: ^rat$element,
      compare_element_record_p: ^compare_element_record,
      working_element_p: ^rat$element;

    status.normal := TRUE;
    working_element_p := element_p;

    WHILE working_element_p <> NIL DO

      NEXT compare_element_record_p IN seq_p;
      IF compare_element_record_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'LOCAL COMPARE_ELEMENT SEQUENCE',
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'initial creation', status);
        RETURN;
      IFEND;

      IF catalog_path.path (1, catalog_path.size) = ' ' THEN

        STRINGREP (compare_element_record_p^.path_name.path, compare_element_record_p^.path_name.size,
              working_element_p^.name (1, clp$trimmed_string_size (working_element_p^.name)));
      ELSE

        STRINGREP (compare_element_record_p^.path_name.path, compare_element_record_p^.path_name.size,
              catalog_path.path (1, catalog_path.size), '.', working_element_p^.
              name (1, clp$trimmed_string_size (working_element_p^.name)));

      IFEND;

      IF working_element_p^.element_type = rac$catalog THEN

        {   When the element is a catalog, the attributes_checksum and correction format have
        {   no meaning.  These fields are initialized so that when two catalogs are compared
        {   only the path name will actually matter.
        compare_element_record_p^.correction_format := rac$replacement;
        compare_element_record_p^.attributes_checksum := 0;

        next_element_down_p := #PTR (working_element_p^.first_element_down_p, subproduct_info_seq_p^);
        IF next_element_down_p <> NIL THEN

          write_element_names_to_seq (compare_element_record_p^.path_name, subproduct_info_seq_p,
                next_element_down_p, seq_p, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        IFEND;

      ELSE {rac$file}

        compare_element_record_p^.correction_format := working_element_p^.correction_format;
        compare_element_record_p^.attributes_checksum := working_element_p^.attributes_checksum;

      IFEND;

      working_element_p := #PTR (working_element_p^.next_element_across_p, subproduct_info_seq_p^);

    WHILEND;

  PROCEND write_element_names_to_seq;

MODEND ram$define_correction;
*DECK DECK=RAM$DEFINE_CORRECTION_FORMAT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'DEFINE_SUBPRODUCT Subutility: DEFINE_CORRECTION_FORMAT Subcommand.' ??
MODULE ram$define_correction_format;

{ PURPOSE:
{   This module defines each or all of the correction_format fields in the element_list.
{
{ DESIGN:
{   The element list is searched for the correct file.  Then the
{   correction format field is updated.  If ALL elements are selected,
{   all files in the element list are updated.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc cld$path_description
*copyc fst$file_reference
*copyc ost$status
*copyc rae$package_software_cc
*copyc rat$subproduct_info_p
*copyc rat$subproduct_info_types
?? POP ??
*copyc clp$scan_parameter_list
*copyc clp$trimmed_string_size
*copyc clp$get_value
*copyc osp$append_status_file
*copyc osp$set_status_abnormal
*copyc osp$generate_error_message
*copyc rap$get_file_path_and_ref
*copyc rap$locate_element
*copyc rav$correction_format
*copyc rav$subproduct_info_pointers
*copyc rav$pacs_catalog_p
*copyc rav$pacs_catalog_ref_p
*copyc rav$defs_scratch_segment

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

{ PURPOSE:
{   This command interface sets the correction_format field for a
{   file or all files in the current subproduct.
{
{ DESIGN:
{   The file is validated as part of the current subproduct.
{   The file is located in the element_list and its correction_format
{   is updated.  If ALL elements are selected, all files in the
{   element list are updated.
{
{ NOTES:
{
{

?? TITLE := '[XDCL] rap$define_correction_format', EJECT ??

  PROCEDURE [XDCL] rap$define_correction_format
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt defcf_pdt (
{   file, files, f        : file or key all = all
{   correction_format, cf : key object_library, source_library, ..
{                           replacement = $required
{   status                : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    defcf_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^defcf_pdt_names, ^defcf_pdt_params
      ];

  VAR
    defcf_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
      clt$parameter_name_descriptor := [['FILE', 1], ['FILES', 1], ['F', 1], ['CORRECTION_FORMAT', 2], ['CF',
      2], ['STATUS', 3]];

  VAR
    defcf_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ FILE FILES F }
    [[clc$optional_with_default, ^defcf_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [^defcf_pdt_kv1,
      clc$file_value]],

{ CORRECTION_FORMAT CF }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^defcf_pdt_kv2, clc$keyword_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    defcf_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['ALL'];

  VAR
    defcf_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of ost$name := ['OBJECT_LIBRARY',
      'SOURCE_LIBRARY','REPLACEMENT'];

  VAR
    defcf_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

?? POP ??

    VAR
      attributes_p: ^rat$subproduct_attributes,
      correction_format: rat$correction_format,
      correction_format_ordinal: rat$correction_format,
      element_found: boolean,
      element_p: ^rat$element,
      path_index: 0 .. fsc$max_path_size,
      path_p: ^pft$path,
      path_ref_p: ^fst$file_reference,
      subproduct_info_seq_p: ^rat$subproduct_info_sequence,
      value: clt$value;


    status.normal := TRUE;
    attributes_p := rav$subproduct_info_pointers.attributes_p;
    element_p := rav$subproduct_info_pointers.element_list_p;
    subproduct_info_seq_p := rav$subproduct_info_pointers.subproduct_info_seq_p;

    clp$scan_parameter_list (parameter_list, defcf_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF attributes_p^.first_level_element_count = 0 THEN
      osp$set_status_abnormal ('RA', rae$error_pacs_catalog_empty, '', status);
      RETURN;
    IFEND;

    clp$get_value ('CORRECTION_FORMAT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /initialize_value/
    FOR correction_format_ordinal := LOWERVALUE (rat$correction_format)
          TO UPPERVALUE (rat$correction_format) DO
      IF rav$correction_format [correction_format_ordinal] = value.name.value (1, value.name.size) THEN
        correction_format := correction_format_ordinal;
        EXIT /initialize_value/;
      IFEND;
    FOREND /initialize_value/;

    IF attributes_p^.subproduct_type = rac$correction THEN
      osp$set_status_abnormal ('RA', rae$defcf_command_ignored, '', status);
      RETURN;
    IFEND;

    clp$get_value ('FILE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.kind = clc$file_value THEN

      RESET rav$defs_scratch_segment.sequence_p TO rav$defs_scratch_segment.reset_p;

      rap$get_file_path_and_ref ('FILE', rav$defs_scratch_segment.sequence_p, path_p, path_ref_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (#SIZE (path_ref_p^) < #SIZE (rav$pacs_catalog_ref_p^)) OR
            (rav$pacs_catalog_ref_p^ <> path_ref_p^ (1, #SIZE (rav$pacs_catalog_ref_p^))) THEN
        osp$set_status_abnormal ('RA', rae$not_in_pacs_catalog, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, path_ref_p^, status);
        RETURN;
      IFEND;

      path_index := UPPERBOUND (rav$pacs_catalog_p^) + 1;

      rap$locate_element (path_p, path_index, subproduct_info_seq_p, element_p, element_found);

      IF NOT element_found THEN
        osp$set_status_abnormal ('RA', rae$not_in_pacs_catalog, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, path_ref_p^, status);
        RETURN;
      IFEND;

      IF element_p^.element_type = rac$file THEN
        rap$add_correction_format (correction_format, 1, element_p, subproduct_info_seq_p);
      ELSE
        osp$set_status_abnormal ('RA', rae$expecting_file, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, path_ref_p^, status);
        RETURN;
      IFEND;

    ELSE {ALL}
      rap$add_correction_format (correction_format, attributes_p^.first_level_element_count, element_p,
            subproduct_info_seq_p);
    IFEND;

  PROCEND rap$define_correction_format;

?? TITLE := ' [XDCL] rap$add_correction_format', EJECT ??

{ PURPOSE:
{   This procedure sets the correction_format field for a file
{   or all files in the element_list.
{
{ DESIGN:
{   This procedure is given an element pointer and the number of elements in that
{   element.  If the element is of type FILE, then only that one element will be updated.
{   If the element is of type CATALOG, all files in the catalog will be updated as well
{   as all files in all of the subcatalogs.
{   Before a file's correction format is set to object library or source library,
{   the elements file content and structure must equal the requested correction format.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$add_correction_format
    (    correction_format: rat$correction_format;
         element_count: rat$element_count;
     VAR element_p: ^rat$element;
     VAR subproduct_info_seq_p: ^rat$subproduct_info_sequence);


    VAR
      file_name: string (osc$max_name_size),
      first_element_down_p: ^rat$element,
      i: rat$path_container_index,
      ignore_status: ost$status,
      length: integer,
      message_status: ost$status,
      next_element_count: rat$element_count;


    FOR i := 1 TO element_count DO
      IF element_p^.element_type = rac$file THEN
        IF (correction_format = element_p^.file_contents_and_structure) OR
              (correction_format = rac$replacement) THEN
          element_p^.correction_format := correction_format;
        ELSE
          length := clp$trimmed_string_size (element_p^.name);
          osp$set_status_abnormal ('RA', rae$invalid_format_for_file, element_p^.name (1, length),
                message_status);
          osp$generate_error_message (message_status, ignore_status);
        IFEND;

      ELSEIF (element_p^.element_type = rac$catalog) AND (element_p^.element_count <> 0) THEN
        next_element_count := element_p^.element_count;
        first_element_down_p := #PTR (element_p^.first_element_down_p, subproduct_info_seq_p^);
        rap$add_correction_format (correction_format, next_element_count, first_element_down_p,
              subproduct_info_seq_p);
      IFEND;

      IF i < element_count THEN
        element_p := #PTR (element_p^.next_element_across_p, subproduct_info_seq_p^);
      IFEND;
    FOREND;

  PROCEND rap$add_correction_format;

MODEND ram$define_correction_format;
*DECK DECK=RAM$DEFINE_C_SOCKET EXPAND=TRUE
PROCEDURE rap$define_c_socket (
  maximum_connections, mc: integer = 100
  gateway,g: boolean = false
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request defines the nam application name for c_socket client
"    applications.
"
*IFEND

  "$FORMAT=OFF"
  VAR
    command_file     : file =$unique($local)
    define_commands  : file =$unique($local)
    ignore_status    : status
    local_status     : status
  VAREND
  "$FORMAT=ON"

  IF NOT gateway THEN
    collect_text command_file until='    collect_end'
      $system.osf$command_library.manage_network_applications
        display_tcpip_attributes application=osa$c_socket_stream o=$null status=local_status
        IF NOT local_status.normal AND (local_status.condition = nae$unknown_application) THEN
          collect_text define_commands until='          define_end'
            define_tcpip_application application=osa$c_socket_stream protocol=stream_socket
              change_maximum_sockets maximum_sockets=maximum_connections
            quit
            activate_tcpip_application application=osa$c_socket_stream
          define_end
        IFEND
        display_tcpip_attributes application=osa$c_socket_dgram o=$null status=local_status
        IF NOT local_status.normal AND (local_status.condition = nae$unknown_application) THEN
          collect_text define_commands.$eoi until='          define_end'
            define_tcpip_application application=osa$c_socket_dgram protocol=datagram_socket
              change_maximum_sockets maximum_sockets=maximum_connections
            quit
            activate_tcpip_application application=osa$c_socket_dgram
          define_end
        IFEND
        include_file define_commands status=local_status
      quit
    collect_end
  ELSE
    put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1' o=$response
    collect_text command_file until='    collect_end'
      $system.osf$command_library.manage_network_applications
        define_client client=osa$c_socket protocol=cdna_session
          change_maximum_connections mc=maximum_connections
          change_client_validation sp=true
        end_define_client
        activate_client client=osa$c_socket
      quit
    collect_end
  IFEND

  include_file command_file status=local_status
  delete_file command_file status=ignore_status
  delete_file define_commands status=ignore_status

  IF local_status.normal THEN
    put_line ' C_SOCKET applications are defined' o=$response
  IFEND

  EXIT PROCEDURE WITH local_status WHEN NOT local_status.normal

PROCEND rap$define_c_socket

*DECK DECK=RAM$DEFINE_DESKTOP_ENVIRONMENT EXPAND=TRUE
PROC rap$define_desktop_environment (
  status : var of status = $optional
  )

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"   This request defines the desktop environment.
*IFEND

  create_variable command_file k=string v='$local.'//$unique
  create_variable ignore_status k=status
  create_variable local_status k=status

  COLLECT_TEXT $fname(command_file) until='  collect_end'
    $system.manage_network_applications
      define_client client=desktop_ve protocol=cdna_virtual_terminal
      end_define_client
      activate_client client=desktop_ve
    quit
  collect_end

  include_file $fname(command_file) status=local_status
  detach_file $fname(command_file) status=ignore_status

  IF local_status.normal THEN
    put_line ' The desktop environment is defined.' o=$response
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$define_desktop_environment
*DECK DECK=RAM$DEFINE_DRJE EXPAND=TRUE
PROC rap$define_drje (
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request defines DRJE.
*IFEND


    create_variable command_file k=string v='$local.'//$unique
    create_variable ignore_status k=status
    create_variable local_status k=status


  collect_text $fname(command_file) until='  collect_end'
    $system.osf$command_library.manage_network_applications
      define_client client=osa$drje_device_outcall protocol=cdna_virtual_terminal
        change_application_identifier application_identifier=variable
        change_maximum_connections maximum_connections=300
        change_connection_priority connection_priority=4
        change_client_validation capability=ntf_operation ring=13 ..
            system_privilege=FALSE
      end_define_client save_definition=TRUE
      activate_client osa$drje_device_outcall
    quit
  collect_end

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  IF local_status.normal THEN
    put_line ' DRJE application is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$define_drje
*DECK DECK=RAM$DEFINE_FILE_PERMIT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'DEFINE_SUBPRODUCT Subutility: DEFINE_FILE_PERMIT Subcommand.' ??
MODULE ram$define_file_permit;

{ PURPOSE:
{   This module defines a public permit for a file or all files in the
{   current subproduct.
{
{ DESIGN:
{   This module is the driver for the DEFINE_FILE_PERMIT
{   in the DEFINE_SUBPRODUCTS utility.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc clp$scan_parameter_list
*copyc clp$get_value
*copyc rap$define_permit

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

{ PURPOSE:
{   This procedure defines a public permit for a file or all files in the
{   current subproduct.
{
{ DESIGN:
{   This procedure is only the command interface.  RAM$DEFINE_PERMITS
{   is where the actual work is completed.
{
{ NOTES:
{
{


?? TITLE := '[XDCL] rap$define_file_permit', EJECT ??

  PROCEDURE [XDCL] rap$define_file_permit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt deffp_pdt (
{   file, files, f                 : file or key all = all
{   access_modes, access_mode, am  : list of key none, read, execute, append, modify, shorten, write, ..
{                                    all, cycle, control = $required
{   share_modes, share_mode, sm    : list of key none, read, execute, append, modify, shorten, write, ..
{                                    all = $optional
{   application_information, ai    : string 0..31 = $optional
{   status                         : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    deffp_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^deffp_pdt_names, ^deffp_pdt_params
      ];

  VAR
    deffp_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 12] of
      clt$parameter_name_descriptor := [['FILE', 1], ['FILES', 1], ['F', 1], ['ACCESS_MODES', 2], [
      'ACCESS_MODE', 2], ['AM', 2], ['SHARE_MODES', 3], ['SHARE_MODE', 3], ['SM', 3], [
      'APPLICATION_INFORMATION', 4], ['AI', 4], ['STATUS', 5]];

  VAR
    deffp_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of clt$parameter_descriptor := [

{ FILE FILES F }
    [[clc$optional_with_default, ^deffp_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [^deffp_pdt_kv1,
      clc$file_value]],

{ ACCESS_MODES ACCESS_MODE AM }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [^deffp_pdt_kv2,
      clc$keyword_value]],

{ SHARE_MODES SHARE_MODE SM }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [^deffp_pdt_kv3,
      clc$keyword_value]],

{ APPLICATION_INFORMATION AI }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, 31]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    deffp_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['ALL'];

  VAR
    deffp_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 10] of ost$name := ['NONE','READ',
      'EXECUTE','APPEND','MODIFY','SHORTEN','WRITE','ALL','CYCLE','CONTROL'];

  VAR
    deffp_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 8] of ost$name := ['NONE','READ',
      'EXECUTE','APPEND','MODIFY','SHORTEN','WRITE','ALL'];

  VAR
    deffp_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

?? POP ??

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, deffp_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$define_permit ('FILE', status);

  PROCEND rap$define_file_permit;

MODEND ram$define_file_permit;
*DECK DECK=RAM$DEFINE_FTAM_INITIATOR_ADDR EXPAND=TRUE
PROCEDURE define_ftam_initiator_address (
  transport_selector, ts: integer 1..12335 = 1
  session_selector, ss: string 0..32 = $optional
  presentation_selector, ps: string 0..8 = $optional
  status)


" Define constants local to this definition procedure.
  "$FORMAT=OFF"
  VAR
    legal_hex_characters: (READ) string 22 = '0123456789abcdefABCDEF'
    current_initiator_configuration: (READ) file = $system.ftam.initiator_configuration
  VAREND
  "$FORMAT=ON"

" Declare variables local to this definition procedure.

  "$FORMAT=OFF"
  VAR
    default_presentation_selector: string = '01'
    default_session_selector: string = '01'
    editing_directives: file
    ignore_status: status
    local_status: status
    presentation_selector_text: string 1..80
    session_selector_text: string 1..80
    new_initiator_configuration: file
  VAREND
  "$FORMAT=ON"

" Initialize local variables.

  editing_directives = $unique($local)
  new_initiator_configuration = $unique($local)

" Verify the procedure has been called by a system operator job.

  IF NOT $job(system) THEN
    EXIT procedure WITH $status(false, 'RA', 0, ..
          'DEFINE_FTAM_INITIATOR_ADDRESS can only be executed by a system operator.')
  IFEND

" Verify the initiator configuration file is present.

  IF (NOT $first($file_attributes(current_initiator_configuration, registered)).registered) THEN
    EXIT procedure WITH $status(false, 'RA', 0, ..
          'The file '//$string(current_initiator_configuration)//' was not found.')
  IFEND

" Verify the value specified for TRANSPORT_SELECTOR is within the ranges allowed.

  IF (transport_selector >= 1000) AND (transport_selector <= 3000) THEN
    EXIT procedure WITH $status(false, 'RA', 0, ..
          'The TRANSPORT_SELECTOR value must not be in the range of 1000 through 3000.')
  IFEND

" Verify the values specified for PRESENTATION_SELECTOR and SESSION_SELECTOR contain an appropriate number
" of hexidecmial digits.

  IF $specified(presentation_selector) THEN
    IF ($scan_not_any(legal_hex_characters, presentation_selector) <> 0) THEN
      EXIT procedure WITH $status(false, 'RA', 0, ..
            'Illegal hexidecimal digit found in PRESENTATION_SELECTOR value.')
    ELSEIF ($mod($strlen(presentation_selector), 2) <> 0) THEN
      EXIT procedure WITH $status(false, 'RA', 0, ..
            'The PRESENTATION_SELECTOR value must contain an even number of digits.')
    IFEND

    IF $specified(session_selector) THEN
      IF ($scan_not_any(legal_hex_characters, session_selector) <> 0) THEN
        EXIT procedure WITH $status(false, 'RA', 0, ..
              'Illegal hexidecimal digit found in SESSION_SELECTOR value.')
      ELSEIF ($mod($strlen(session_selector), 2) <> 0) THEN
        EXIT procedure WITH $status(false, 'RA', 0, ..
              'The SESSION_SELECTOR value must contain an even number of digits.')
      ELSE

" The values for PRESENTATION_SELECTOR and SESSION_SELECTOR are syntactically correct.

        IF presentation_selector = '' THEN
          presentation_selector_text = 'define sap 30 16 C# '
        ELSE
          presentation_selector_text = 'define sap 30 16 H'//presentation_selector//' '
        IFEND

        IF session_selector = '' THEN
          session_selector_text = 'define sap 16 17 C# '
        ELSE
          session_selector_text = 'define sap 16 17 H'//session_selector//' '
        IFEND

" Generate the editing directives neccessary to customize presentation and session selector values in
" the FTAM initiator configuration file.

COLLECT_TEXT output=editing_directives until='*** END_EDITING_DIRECTIVES ***' substitution_mark='?' ..
              status=local_status

" Locate and change the presentation selector for the C code.

        locate_text text='define sap 30' number=1 lines=first..last
        start = $current_column

        locate_text text='70 70' number=1 lines=first..last
        end = ($current_column - 1)

        replace_text text=$substring($line_text, start, (end - start + 1)) ..
              new_text='?presentation_selector_text?' ..
              line=current columns=start..end

"  Locate and change the presentation selector for the Transport Interface code.

        locate_text text='osa$ftam_client' number=1 lines=first..last
        start = $current_column

        locate_text text=' ts=' number=1 lines=first..last
        end = ($current_column - 1)

        replace_text text=$substring($line_text, start, (end - start + 1)) ..
              new_text='osa$ftam_client ps=''''?presentation_selector?''''' ..
              line=current columns=start..end

" Locate and change the session selector for C code.

        locate_text text='define sap 16' number=1 lines=first..last
        start = $current_column

        locate_text text='70 50' number=1 lines=first..last
        end = ($current_column - 1)

        replace_text text=$substring($line_text, start, (end - start + 1)) ..
              new_text='?session_selector_text?' line=current columns=start..end

"  Locate and change the session selector for the Transport Interface code.

        locate_text text='osa$ftam_client' number=1 lines=first..last
        start = $current_column

        locate_text text=' ps=' number=1 lines=first..last
        end = ($current_column - 1)

        replace_text text=$substring($line_text, start, (end - start + 1)) ..
              new_text='osa$ftam_client ss=''''?session_selector?''''' ..
              line=current columns=start..end

*** END_EDITING_DIRECTIVES ***
        IF NOT local_status.normal THEN

" The editing directives file could not be generated. Map the abnormal status value AME$FILE_NOT_KNOWN to
" PFE$UNKNOWN_PERMANENT_FILE to provide the caller with a more appropriate error message.

          IF local_status.condition = ame$file_not_known THEN
            local_status = $status(false, 'PF', pfe$unknown_permanent_file, $string(editing_directives))
          IFEND
          EXIT procedure WITH local_status
        IFEND

      IFEND
    ELSE " No value was provided for the SESSION_SELECTOR parameter.
      EXIT procedure WITH $status(false, 'RA', 0, ..
            'A SESSION_SELECTOR value is required when PRESENTATION_SELECTOR is specified.')
    IFEND
  ELSE " No value was provided for the PRESENTATION_SELECTOR parameter.

    IF $specified(session_selector) THEN
      EXIT procedure WITH $status(false, 'RA', 0, ..
            'A PRESENTATION_SELECTOR value is required when SESSION_SELECTOR is specified.')
    IFEND

" Generate the editing directives neccessary to set presentation and session selector values in
" the FTAM initiator configuration file to their default values.

COLLECT_TEXT output=editing_directives until='*** END_EDITING_DIRECTIVES ***' substitution_mark='?' ..
          status=local_status

"  Locate and change the presentation selector for the C code to the default value.

        locate_text text='define sap 30' number=1 lines=first..last
        start = $current_column

        locate_text text='70 70' number=1 lines=first..last
        end = ($current_column - 1)

        replace_text text=$substring($line_text, start, (end - start + 1)) ..
              new_text='define sap 30 16 H?default_presentation_selector? ' ..
              line=current columns=start..end

"  Locate and delete the presentation selector for the Transport Interface code if it exists.

        locate_text text='osa$ftam_client' number=1 lines=first..last
        start = $current_column

        locate_text text=' ts=' number=1 lines=first..last
        end = ($current_column - 1)

        replace_text text=$substring($line_text, start, (end - start + 1)) ..
              new_text='osa$ftam_client ' line=current columns=start..end

"  Locate and change the session selector for C code to the default value.

        locate_text text='define sap 16' number=1 lines=first..last
        start = $current_column

        locate_text text='70 50' number=1 lines=first..last
        end = ($current_column - 1)

        replace_text text=$substring($line_text, start, (end - start + 1)) ..
              new_text='define sap 16 17 H?default_session_selector? ' ..
              line=current columns=start..end

*** END_EDITING_DIRECTIVES ***
    IF NOT local_status.normal THEN

" The editing directives file could not be generated.

      IF local_status.condition = ame$file_not_known THEN
        local_status = $status(false, 'PF', pfe$unknown_permanent_file, $string(editing_directives))
      IFEND
      EXIT procedure WITH local_status
    IFEND
  IFEND


" Make a local startup command file.

  copy_file input=current_initiator_configuration output=new_initiator_configuration

" Generate the editing directives neccessary to customize the transport selector value in the FTAM
" initiator configuration file.

COLLECT_TEXT output=editing_directives.$eoi until='*** END_EDITING_DIRECTIVES ***' substitution_mark='?' ..
        status=local_status

        locate_text text='ts=' number=1 lines=first..last
        start = $current_column

        locate_text text=' mc=' number=1 lines=first..last
        end = ($current_column - 1)

        replace_text text=$substring($line_text, start, (end - start + 1)) ..
              new_text='ts=?transport_selector?' line=current columns=start..end

*** END_EDITING_DIRECTIVES ***
  IF NOT local_status.normal THEN

" The editing directives file could not be generated.

    IF local_status.condition = ame$file_not_known THEN
      local_status = $status(false, 'PF', pfe$unknown_permanent_file, $string(editing_directives))
    IFEND
    EXIT procedure WITH local_status
  IFEND

  IF $first($file_attributes(editing_directives, registered)).registered AND ..
        $first($file_attributes(editing_directives, size)).size <> 0 THEN
COLLECT_TEXT output=editing_directives.$eoi until='*** END_EDITING_DIRECTIVES ***' status=local_status
        QUIT
*** END_EDITING_DIRECTIVES ***
    IF NOT local_status.normal THEN

" The editing directives file could not be generated.

      IF local_status.condition = ame$file_not_known THEN
        local_status = $status(false, 'PF', pfe$unknown_permanent_file, $string(editing_directives))
      IFEND
      EXIT procedure WITH local_status
    IFEND

" Customize the initiator configuration file using EDIT_FILE. A seperate task is created to bypass problems
" which could result if this procedure is called from within the EDIT_FILE utility. FORMAT_SCL_PROCEDURE will
" generate an error indicating that no end-of-utility statement was found. Inhibit formatting.

    TASK
      "$FORMAT=OFF"
      $system.EDIT_FILE file=new_initiator_configuration input=editing_directives output=$null prolog=$null
      "$FORMAT=ON"
    TASKEND

    copy_file input=new_initiator_configuration output=current_initiator_configuration.$next

    TASK ring=6
      change_file_attributes file=current_initiator_configuration ring_attributes=(6, 13, 13)
    TASKEND
  IFEND

  detach_file file=new_initiator_configuration status=ignore_status
  delete_file file=new_initiator_configuration status=ignore_status

  detach_file file=editing_directives status=ignore_status
  delete_file file=editing_directives status=ignore_status

PROCEND define_ftam_initiator_address
*DECK DECK=RAM$DEFINE_FTP EXPAND=TRUE
PROCEDURE rap$define_ftp (
  protocol, p: key (stream_socket, ss), (cdna_session, cs), keyend = stream_socket
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request defines the FTP client application.
"
*IFEND

  VAR
    command_file: file = $unique($local)
    ignore_status: status
    local_status: status
  VAREND

  IF protocol = stream_socket THEN
    collect_text command_file until='    collect_end' sm='?'
      $system.osf$command_library.manage_network_applications
        define_tcpip_application application=osa$ftp_client protocol=?protocol?
          change_maximum_sockets maximum_sockets=40
        quit
        activate_tcpip_application application=osa$ftp_client
      quit
    collect_end
  ELSE
    put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1' o=$response
    collect_text command_file until='    collect_end' sm='?'
      $system.osf$command_library.manage_network_applications
        define_client client=osa$ftp_client protocol=?protocol?
          change_maximum_connections maximum_connections=40
        quit
        activate_client client=osa$ftp_client
      quit
    collect_end
  IFEND

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  IF local_status.normal THEN
    put_line ' FTP client is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND rap$define_ftp

*DECK DECK=RAM$DEFINE_FTPS EXPAND=TRUE
PROCEDURE rap$define_ftps (
  protocol, p: key (stream_socket, ss), (cdna_session, cs), keyend = stream_socket
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request defines the FTP server.
"
*IFEND


  VAR
    command_file: file = $unique($local)
    ignore_status: status
    local_status: status
  VAREND

  IF protocol = stream_socket THEN
    collect_text command_file until='    collect_end' sm='?'
      $system.osf$command_library.manage_network_applications
        define_tcpip_application application=osa$ftp_server protocol=?protocol?
          change_maximum_sockets maximum_sockets=40
          change_tcpip_validation system_privilege=true
        quit
        activate_tcpip_application application=osa$ftp_server
      quit
    collect_end
  ELSE
    put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1' o=$response
    collect_text command_file until='    collect_end' sm='?'
      $system.osf$command_library.manage_network_applications
        define_client client=osa$ftp_server protocol=?protocol?
          change_maximum_connections maximum_connections=40
          change_client_validation system_privilege=true
        quit
        activate_client client=osa$ftp_server
      quit
    collect_end
  IFEND

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  IF local_status.normal THEN
    put_line ' FTP server is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND rap$define_ftps

*DECK DECK=RAM$DEFINE_ICA EXPAND=TRUE
PROC define_ica (
  physical_data_array : array of string = $optional
  host_network        : string = $optional
  network_ids         : array of string = $optional
  system_ids          : array of string = $optional
  relays              : array of string = $optional
  ica_index1          : array of integer = $optional
  ica_index2          : array of integer = $optional
  physical_entries    : integer = $optional
  lcu_entries         : var of integer = $optional
  status              : var of status = $optional
  )

" Make local copies of the procedure parameters.

  physical_data = $value(physical_data_array)
  host_network_id = $value(host_network)
  network_id_array = $value(network_ids)
  system_id_array = $value(system_ids)
  rr_array = $value(relays)
  ica_element1_index = $value(ica_index1)
  ica_element2_index = $value(ica_index2)
  number_physical_entries = $value(physical_entries)
  number_lcu_entries = $value(lcu_entries)

  create_variable (choice cr_requested) k=string
  create_variable choice_to_lcu_map k=integer d=9 v=0
  create_variable (i j max_choice number_used) k=integer
  create_variable conversion_status k=status
  create_variable ica2_in_use k=boolean
  create_variable lcu_index k=integer
  create_variable network_access_count k=integer
  create_variable successful k=boolean

check_if_ica_available: ..
  BLOCK
    FOR i = 1 TO number_physical_entries DO
      IF ($substr(physical_data(i), 5, 4) = 'ICA2') THEN
        ica2_in_use = FALSE
        FOR j = 1 TO number_lcu_entries DO
          IF ((ica_element1_index(j) = i) OR (ica_element2_index(j) = i)) AND ..
             ((network_id_array(j) <> ' ') AND (system_id_array(j) <> ' ')) THEN
            ica2_in_use = TRUE
          IFEND
        FOREND
        IF NOT ica2_in_use THEN
          EXIT check_if_ica_available
        IFEND
      ELSE
        EXIT check_if_ica_available
      IFEND
    FOREND
    put_line ( '0No ICA''s available for network access definition.' ..
               ' All ICA-II''s have been defined in OSI mode.')
    accept_line cr_requested input p='Press NEXT: '
    EXIT_PROC
  BLOCKEND check_if_ica_available

main_loop: ..
  LOOP

    network_access_count = 0
    FOR i = 1 to number_lcu_entries DO
      IF (network_id_array(i) <> ' ') AND (system_id_array(i) = ' ') THEN
        network_access_count = network_access_count + 1
      IFEND
    FOREND
    IF network_access_count = 0 THEN

      lcu_index = number_lcu_entries + 1
      prompt_for_network_access physical_data host_network_id number_physical_entries ica_element1_index ..
            ica_element2_index network_id_array(lcu_index) rr_array(lcu_index) ica_element1_index(lcu_index) ..
            ica_element2_index(lcu_index) number_lcu_entries
      IF ica_element1_index(lcu_index) = 0 THEN
        EXIT main_loop
      IFEND

    ELSE

      put_line (..
            '1Define Network Accesses'..
            '0   Network          Relays                                   Channel Serial ' ..
            '    Identifier     Restricted Element Name                     Number Number '..
            '  ')
      number_used = 0
      max_choice = 0
      FOR i = 1 TO number_lcu_entries DO
        number_used = number_used + 1
        IF system_id_array(i) = ' ' THEN
          max_choice = max_choice + 1
          choice_to_lcu_map(max_choice) = i
          put_line ' '//$strrep(max_choice)//'. '//$substr(network_id_array(i), 1, 15, ' ')//$substr(' ', 1, ..
                6-$strlen(rr_array(i)))//rr_array(i)//'    '//$substr(..
                physical_data(ica_element1_index(i)), 9, 50)
          IF ica_element2_index(i) <> 0 THEN
            number_used = number_used + 1
            put_line $substr(' ', 1, 29)//$substr(physical_data(ica_element2_index(i)), 9, 50)
          IFEND
        IFEND
      FOREND
      IF (number_used < number_physical_entries) THEN
        max_choice = max_choice + 1
        choice_to_lcu_map(max_choice) = number_lcu_entries + 1
        put_line (' '//$strrep(max_choice)//'. Define another network access.')
      IFEND
      put_line '0Enter a menu selection, QUIT, GO, or ?: '
      choice = ''
      accept_line choice input p=''
      IF (choice = '?') OR ($translate(lower_to_upper, choice) = 'HELP') THEN

        put_line (..
          '0This menu prompts you to define the network configuration of your '..
          ' mainframe.  The network configuration defines how the mainframe '..
          ' accesses one or more ethernet networks, ie. which 2629_1 or $2629_2 '..
          ' Integrated Communications Adapters (ICA) connect to which ethernets. '..
          ' The menu selections above show the current network accesses defined. '..
          ' If more than one ICA connects to the same ethernet, the secondary '..
          ' one is displayed on a separate line. '..
          '0Enter a menu selection to modify the parameters for a network access '..
          '   or define an additional network access (if that option is displayed).'..
          ' Enter GO or press NEXT to install the network configuration you have'..
          '   defined.'..
          ' Enter QUIT to return to the main menu without installing the '..
          '   configuration.  Any network configuration parameters you have set'..
          '   will be lost. '..
          '  ')
        accept_line cr_requested input p='Press NEXT: '

      ELSEIF ($translate(lower_to_upper, choice) = 'QUIT') OR ($translate(lower_to_upper, choice) = 'QUI') ..
            THEN

        EXIT main_loop

      ELSEIF (choice = ' ') OR ($translate(lower_to_upper, choice) = 'GO') THEN

        install_network_config_file FALSE host_network_id network_id_array system_id_array rr_array ..
            physical_data number_physical_entries number_lcu_entries ica_element1_index ..
            ica_element2_index successful
        IF successful THEN
          $value(network_ids) = network_id_array
          $value(relays) = rr_array
          $value(ica_index1) = ica_element1_index
          $value(ica_index2) = ica_element2_index
          $value(lcu_entries) = number_lcu_entries
          EXIT main_loop
        IFEND

      ELSE

        include_line 'i = $integer(choice)' status=conversion_status
        IF conversion_status.normal THEN
          IF (i >= 1) AND (i <= max_choice) THEN
            prompt_for_network_access physical_data host_network_id number_physical_entries ica_element1_index ..
                  ica_element2_index network_id_array(choice_to_lcu_map(i)) rr_array(choice_to_lcu_map(i)) ..
                  ica_element1_index(choice_to_lcu_map(i)) ica_element2_index(choice_to_lcu_map(i)) ..
                  number_lcu_entries
            CYCLE main_loop
          IFEND
        IFEND
        put_line '  '
        accept_line cr_requested input p='Invalid selection, press NEXT: '

      IFEND

    IFEND

  LOOPEND main_loop

PROCEND define_ica
*DECK DECK=RAM$DEFINE_ICA_NETWORK EXPAND=TRUE
PROCEDURE define_ica_network (
  physical_data_array: (VAR) array of string = $optional
  host_network: string = $optional
  network_ids: (VAR) array of string = $optional
  system_ids: (VAR) array of string = $optional
  relays: (VAR) array of string = $optional
  ica_index1: (VAR) array of integer = $optional
  ica_index2: (VAR) array of integer = $optional
  physical_entries: integer = $optional
  lcu_entries: (VAR) integer = $optional
  status)

" Make local copies of the procedure parameters.

  physical_data = physical_data_array
  host_network_id = host_network
  network_id_array = network_ids
  system_id_array = system_ids
  rr_array = relays
  ica_element1_index = ica_index1
  ica_element2_index = ica_index2
  number_physical_entries = physical_entries
  number_lcu_entries = lcu_entries

  "$FORMAT=OFF
  VAR
    choice: string
    cr_requested: string
    ica_type: string
  VAREND
  "$FORMAT=ON"

main_loop: ..
  LOOP

    choose_ica_type ica_type
    IF ica_type = ' ' THEN
      EXIT main_loop
    ELSEIF ica_type = 'DEFINE_NETWORK_CONNECTION' THEN
      define_network_connection physical_data host_network network_id_array system_id_array rr_array ..
            ica_element1_index ica_element2_index number_physical_entries number_lcu_entries

    ELSEIF ica_type = 'DEFINE_NETWORK_ACCESS' THEN
      define_ica physical_data host_network network_id_array system_id_array rr_array ica_element1_index ..
            ica_element2_index number_physical_entries number_lcu_entries
    IFEND

  LOOPEND main_loop

  physical_data_array = physical_data
  network_ids = network_id_array
  system_ids = system_id_array
  relays = rr_array
  ica_index1 = ica_element1_index
  ica_index2 = ica_element2_index
  physical_entries = number_physical_entries
  lcu_entries = number_lcu_entries

PROCEND define_ica_network
*DECK DECK=RAM$DEFINE_IM_DM_FAMILY EXPAND=TRUE
*DECK DECK=RAM$DEFINE_IPC_APPLICATIONS EXPAND=TRUE
PROCEDURE rap$define_ipc_applications (
  maximum_connections, mc: integer = 100
  gateway,g: boolean = false
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request defines the nam application name for IPC server
"    applications.
"
*IFEND

  "$FORMAT=OFF"
  VAR
    command_file     : file =$unique($local)
    define_commands  : file =$unique($local)
    ignore_status    : status
    local_status     : status
  VAREND
  "$FORMAT=ON"

  IF NOT gateway THEN
    collect_text command_file until='    collect_end'
      $system.osf$command_library.manage_network_applications
        display_tcpip_attributes application=osa$ipc_appl_stream o=$null status=local_status
        IF NOT local_status.normal AND (local_status.condition = nae$unknown_application) THEN
          collect_text define_commands until='          define_end'
            define_tcpip_application application=osa$ipc_appl_stream protocol=stream_socket
              change_maximum_sockets maximum_sockets=maximum_connections
            quit
            activate_tcpip_application application=osa$ipc_appl_stream
          define_end
        IFEND
        display_tcpip_attributes application=osa$ipc_appl_dgram o=$null status=local_status
        IF NOT local_status.normal AND (local_status.condition = nae$unknown_application) THEN
          collect_text define_commands.$eoi until='          define_end'
            define_tcpip_application application=osa$ipc_appl_dgram protocol=datagram_socket
              change_maximum_sockets maximum_sockets=maximum_connections
            quit
            activate_tcpip_application application=osa$ipc_appl_dgram
          define_end
        IFEND
        include_file define_commands status=local_status
      quit
    collect_end
  ELSE
    put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1' o=$response
    collect_text command_file until='    collect_end'
      $system.osf$command_library.manage_network_applications
        define_client client=osa$ipc_applications protocol=cdna_session
          change_maximum_connections mc=maximum_connections
          change_client_validation sp=true
        end_define_client
        activate_client client=osa$ipc_applications
      quit
    collect_end
  IFEND

  include_file command_file status=local_status
  delete_file command_file status=ignore_status
  delete_file define_commands status=ignore_status

  IF local_status.normal THEN
    put_line ' IPC applications are defined' o=$response
  IFEND

  EXIT PROCEDURE WITH local_status WHEN NOT local_status.normal

PROCEND rap$define_ipc_applications
*DECK DECK=RAM$DEFINE_LIBRARY_MERGE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'DEFINE_SUBPRODUCT Subutility: DEFINE_LIBRARY_MERGE Subcommand.' ??
MODULE ram$define_library_merge;

{ PURPOSE:
{   This module updates all fields necessary to define a library merge.
{
{ DESIGN:
{   The element list is searched for the correct file.  Then
{   all fields necessary to define a library merge are updated.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$package_software_cc
?? POP ??
*copyc clp$convert_file_ref_to_string
*copyc clp$get_fs_path_elements
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc clp$trimmed_string_size
*copyc fsp$convert_fs_structure_to_pf
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc rap$get_file_path_and_ref
*copyc rap$locate_element
*copyc rav$subproduct_info_pointers
*copyc rav$pacs_catalog_p
*copyc rav$pacs_catalog_ref_p
*copyc rav$defs_scratch_segment

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??


?? TITLE := '[XDCL] rap$define_library_merge', EJECT ??

{ PURPOSE:
{   This command interface sets the library_merge fields for a
{   file in the current subproduct.
{
{ DESIGN:
{   The library is validated as a legal file path.  If the installation
{   path has not been set in the attributes record, the file path cannot
{   totally validated at this time.  A warning message is outputed if
{   the library is not part of :$SYSTEM.$SYSTEM.
{   The file is validated as part of the current subproduct.
{   The file is located in the element_list and validated as type FILE.
{   All of the necessary fields are updated.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$define_library_merge
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt deflm_pdt (
{   file, f    : file = $required
{   library, l : file = $required
{   status     : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      deflm_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^deflm_pdt_names, ^deflm_pdt_params];

    VAR
      deflm_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
            clt$parameter_name_descriptor := [['FILE', 1], ['F', 1], ['LIBRARY', 2], ['L', 2], ['STATUS', 3]];

    VAR
      deflm_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ FILE F }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ LIBRARY L }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      attributes_p: ^rat$subproduct_attributes,
      element_found: boolean,
      element_p: ^rat$element,
      file_path_index: integer,
      file_path_p: ^pft$path,
      file_path_ref_p: ^fst$file_reference,
      ignore_status: ost$status,
      installation_path_index: rat$path_container_index,
      library_path_p: ^pft$path,
      library_path_ref_p: ^fst$file_reference,
      length: integer,
      master_catalog: string (osc$max_name_size * 2 + 2),
      path_container_p: ^rat$path_container,
      subproduct_info_seq_p: ^rat$subproduct_info_sequence,
      value: clt$value;


    status.normal := TRUE;
    attributes_p := rav$subproduct_info_pointers.attributes_p;
    element_p := rav$subproduct_info_pointers.element_list_p;
    subproduct_info_seq_p := rav$subproduct_info_pointers.subproduct_info_seq_p;
    path_container_p := rav$subproduct_info_pointers.path_container_p;

    IF attributes_p^.first_level_element_count = 0 THEN
      osp$set_status_abnormal ('RA', rae$error_pacs_catalog_empty, '', status);
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, deflm_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET rav$defs_scratch_segment.sequence_p TO rav$defs_scratch_segment.reset_p;

    rap$get_file_path_and_ref ('LIBRARY', rav$defs_scratch_segment.sequence_p, library_path_p,
          library_path_ref_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF library_path_p^ [1] = '$LOCAL' THEN
      osp$set_status_abnormal ('RA', rae$cannot_use_local_catalog, 'the LIBRARY parameter', status);
      RETURN;
    IFEND;

    installation_path_index := attributes_p^.installation_path.path_container_index;

    IF installation_path_index = 0 THEN

      IF NOT ((library_path_p^ [1] = '$SYSTEM') AND (library_path_p^ [2] = '$SYSTEM')) THEN
        osp$set_status_abnormal ('RA', rae$unable_to_validate_lib_merg, '', status);
        osp$generate_error_message (status, ignore_status);
      IFEND;

    ELSE

      IF NOT (((library_path_p^ [1] = '$SYSTEM') AND (library_path_p^ [2] = '$SYSTEM')) OR
              ((library_path_p^ [1] = path_container_p^ [installation_path_index]) AND
            (library_path_p^ [2] = path_container_p^ [installation_path_index + 1]))) THEN

        STRINGREP (master_catalog, length, ':', path_container_p^ [installation_path_index] (1,
              clp$trimmed_string_size (path_container_p^ [installation_path_index])), '.',
              path_container_p^ [installation_path_index + 1]
              (1, clp$trimmed_string_size (path_container_p^ [installation_path_index + 1])));
        osp$set_status_abnormal ('RA', rae$bad_master_catalog_for_lib, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, library_path_ref_p^, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, master_catalog (1, length), status);
        RETURN;

      IFEND;

    IFEND;

    rap$get_file_path_and_ref ('FILE', rav$defs_scratch_segment.sequence_p, file_path_p, file_path_ref_p,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (#SIZE (file_path_ref_p^) < #SIZE (rav$pacs_catalog_ref_p^)) OR
          (rav$pacs_catalog_ref_p^ <> file_path_ref_p^ (1, #SIZE (rav$pacs_catalog_ref_p^))) THEN
      osp$set_status_abnormal ('RA', rae$not_in_pacs_catalog, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, file_path_ref_p^, status);
      RETURN;
    IFEND;

    file_path_index := UPPERBOUND (rav$pacs_catalog_p^) + 1;

    rap$locate_element (file_path_p, file_path_index, subproduct_info_seq_p, element_p, element_found);

    IF NOT element_found THEN
      osp$set_status_abnormal ('RA', rae$not_in_pacs_catalog, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, file_path_ref_p^, status);
      RETURN;
    IFEND;

    IF element_p^.element_type = rac$catalog THEN
      osp$set_status_abnormal ('RA', rae$expecting_file, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, file_path_ref_p^, status);
      RETURN;
    IFEND;

    add_library_path_to_container (library_path_p^, element_p, rav$subproduct_info_pointers, status);

  PROCEND rap$define_library_merge;

?? TITLE := 'add_library_path_to_container', EJECT ??

{ PURPOSE:
{   This procedure sets:
{        the library_merge.path_container_index to the next available path container.
{        the library_merge.path_length to the file length of the element.
{        For example $SYSTEM.A.B.DDD.E has a length of 5.
{        the info_header_p.path_container_length to total length of all containers used.
{        the path_container_p^s are filled with the names of the library merge file.  In the example above
{        path_container_p^ [i] = $SYSTEM
{        path_container_p^ [i + 1] = A
{        path_container_p^ [i + 2] = B
{        path_container_p^ [i + 3] = DDD
{        path_container_p^ [i + 4] = E
{
{ DESIGN:
{   If the element already contains a library_merge.path_container_index check to see if the
{   new path is of the same length as the old path.  If they are the same length put the new path in the
{   same containers that the old path used.
{
{   Else set the library_merge.path_container_index to the next available index number.
{   The info_header_p^.path_container_index contains the value of the last used path container.
{   Set the value of the library_merge.path_length to the uppervalue of the array that contains the path.
{   See example above to understand how the length of a path is determined.
{   The info_header.path_container_length is updated to point to the last used path container.
{   If the path container has not been created, it is created with a size large enough to hold this path.
{   Else the path_containers size is set to the size indicated in info_header.path_container_length.
{   Then the path_containers are filled with the path.
{
{ NOTES:
{
  PROCEDURE add_library_path_to_container
    (    library_path: pft$path;
         element_p: ^rat$element;
     VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);

    VAR
      i: rat$path_container_index,
      index: rat$path_container_index,
      info_header_p: ^rat$subproduct_info_header,
      path_container_p: ^rat$path_container,
      subproduct_info_seq_p: ^rat$subproduct_info_sequence;


    status.normal := TRUE;
    info_header_p := subproduct_info_pointers.info_header_p;
    subproduct_info_seq_p := subproduct_info_pointers.subproduct_info_seq_p;
    path_container_p := subproduct_info_pointers.path_container_p;

    IF (element_p^.library_merge.path_container_index <> 0) AND
          (element_p^.library_merge.path_length = UPPERBOUND (library_path)) THEN

      index := element_p^.library_merge.path_container_index;
      FOR i := 1 TO UPPERBOUND (library_path) DO
        path_container_p^ [index] := library_path [i];
        index := index + 1;
      FOREND;

    ELSE
      element_p^.library_merge.path_container_index := info_header_p^.path_container_length + 1;
      element_p^.library_merge.path_length := UPPERBOUND (library_path);
      info_header_p^.path_container_length := info_header_p^.path_container_length +
            UPPERBOUND (library_path);

      IF path_container_p = NIL THEN
        NEXT path_container_p: [1 .. info_header_p^.path_container_length] IN subproduct_info_seq_p;
        info_header_p^.path_container_p := #REL (path_container_p, subproduct_info_seq_p^);
      ELSE
        RESET subproduct_info_seq_p TO path_container_p;
        NEXT path_container_p: [1 .. info_header_p^.path_container_length] IN subproduct_info_seq_p;
      IFEND;

      index := element_p^.library_merge.path_container_index;
      FOR i := 1 TO UPPERBOUND (library_path) DO
        path_container_p^ [index] := library_path [i];
        index := index + 1;
      FOREND;

      subproduct_info_pointers.subproduct_info_seq_p := subproduct_info_seq_p;
      subproduct_info_pointers.path_container_p := path_container_p;
    IFEND;

  PROCEND add_library_path_to_container;

MODEND ram$define_library_merge;
*DECK DECK=RAM$DEFINE_LPD EXPAND=TRUE
PROCEDURE rap$define_lpd (
  protocol, p: key (stream_socket, ss), (cdna_session, cs), keyend = stream_socket
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request defines the LPD client.
"
*IFEND

  VAR
    command_file: string = '$local.'//$unique
    ignore_status: status
    local_status: status
  VAREND

  IF protocol = stream_socket THEN
    collect_text $fname(command_file) until='    collect_end'
      $system.osf$command_library.manage_network_applications
        define_tcpip_application application=osa$lpd_client protocol=stream_socket
          change_maximum_sockets maximum_sockets=100
        quit
        activate_tcpip_application application=osa$lpd_client
      quit
    collect_end
  ELSE
    put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1' o=$response
    collect_text $fname(command_file) until='    collect_end'
      $system.osf$command_library.manage_network_applications
        define_client client=osa$lpd_client protocol=cdna_session
          change_maximum_connections mc=100
        quit
        activate_client client=osa$lpd_client
      quit
    collect_end
  IFEND

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  IF local_status.normal THEN
    put_line ' LPD client is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND rap$define_lpd

*DECK DECK=RAM$DEFINE_LPDS EXPAND=TRUE
PROCEDURE rap$define_lpds (
  protocol, p: key (stream_socket, ss), (cdna_session, cs), keyend = stream_socket
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request defines the LPD server.
"
*IFEND

  VAR
    command_file: string = '$local.'//$unique
    ignore_status: status
    local_status: status
  VAREND

  IF protocol = stream_socket THEN
    collect_text $fname(command_file) until='    collect_end'
      $system.osf$command_library.manage_network_applications
        define_tcpip_application application=osa$lpd_server protocol=stream_socket
          change_maximum_sockets maximum_sockets=100
          change_tcpip_validation system_privilege=true
        quit
        activate_tcpip_application application=osa$lpd_server
      quit
    collect_end
  ELSE
    put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1' o=$response
    collect_text $fname(command_file) until='    collect_end'
      $system.osf$command_library.manage_network_applications
        define_client client=osa$lpd_server protocol=cdna_session
          change_maximum_connections mc=100
        end_define_client
        activate_client client=osa$lpd_server
      quit
    collect_end
  IFEND

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  IF local_status.normal THEN
    put_line ' LPD server is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND rap$define_lpds

*DECK DECK=RAM$DEFINE_NAME_RESOLVER EXPAND=TRUE
PROCEDURE rap$define_name_resolver (
  domain_name, dn: application = $required
  name_servers, ns: list of application = $required
  resolver_configuration_file, rcf: file = $system.tcp_ip.resolver_configuration
  tcp_solution, ts: key (gateway_di, gdi), (tcp_device, td), keyend = td
  status)

  VAR
    command_file: string = '$local.'//$unique
    dot_count: integer
    ignore_status: status
    index: integer
    ipa_part: integer
    local_status: status
    ns_string: string
  VAREND

  local_status.normal = TRUE
  FOR each entry in name_servers
    index = 0
    dot_count = 0
    ns_string = $string(entry)//'.'

    WHILE index < $size(ns_string) AND dot_count < 4
      ipa_part = 0
      index = index + 1
      dot_count = dot_count + 1
      WHILE $evaluate($substring($string(ns_string),index,1),integer,check).normal
        ipa_part = (ipa_part * 10) + $integer($substring($string(ns_string),index,1))
        index = index + 1
      WHILEND
      IF ipa_part = 0 OR ipa_part > 255 OR $substring($string(ns_string),index,1) <> '.'
        index = $size(ns_string) + 1
      IFEND
    WHILEND

    IF index <> $size(ns_string) OR dot_count <> 4
      $system.put_line ' Invalid IP address format for name_server specified: '//$string(entry) o=$response
      local_status.normal = FALSE
    IFEND
  FOREND

  IF NOT local_status.normal
    local_status.condition = ipe$ipam_invalid_ip_address
    EXIT PROC WITH local_status
  IFEND

  IF tcp_solution = tcp_device THEN
    $system.collect_text $fname(command_file) until='    collect_end'
      $system.osf$command_library.manage_network_applications
        define_tcpip_application application=osa$udp_domain_name_resolver ..
             protocol=datagram_socket
          change_maximum_sockets ms=100
        end_define_tcpip_application
        activate_tcpip_application application=osa$udp_domain_name_resolver
        define_tcpip_application application=osa$tcp_domain_name_resolver ..
             protocol=stream_socket
          change_maximum_sockets ms=100
        end_define_tcpip_application
        activate_tcpip_application application=osa$tcp_domain_name_resolver
      quit
    collect_end
  ELSE
    $system.put_line ' WARNING - TCP/IP Gateway support terminated at release level 1.7.1' o=$response
    $system.collect_text $fname(command_file) until='    collect_end'
      $system.osf$command_library.manage_network_applications
        define_client client=osa$udp_domain_name_resolver protocol=cdna_session
          change_maximum_connections mc=100
        end_define_client
        activate_client client=osa$udp_domain_name_resolver
        define_client client=osa$tcp_domain_name_resolver protocol=cdna_session
          change_maximum_connections mc=100
        end_define_client
        activate_client client=osa$tcp_domain_name_resolver
      quit
    collect_end
  IFEND

  $system.put_line 'domain '//$string(domain_name) o=resolver_configuration_file.$next
  FOR each entry in name_servers
    $system.put_line 'nameserver '//$string(entry) o=resolver_configuration_file.$eoi
  FOREND
  $system.create_file_permit file=resolver_configuration_file group=public

  $system.include_file $fname(command_file) status=local_status
  $system.delete_file $fname(command_file) status=ignore_status

  IF local_status.normal THEN
    $system.put_line ' IPAM Domain Name Resolver is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND rap$define_name_resolver
*DECK DECK=RAM$DEFINE_NETWORK EXPAND=TRUE
PROCEDURE  define_network, define_networks, defn (
  )

  IF NOT $job(operator) THEN
    text = 'DEFINE_NETWORK'//$char(31)//'except from the console'
    EXIT_PROC WITH $status(FALSE, 'RA', rae$illegal_command_call, text)
  IFEND

  create_variable choice k=string
  create_variable cr_requested k=string
  create_variable local_status k=status
  create_variable ignore_status k=status

  create_variable physical_data k=string d=0..9
  create_variable system_id_array k=string d=0..9 v=' '
  create_variable defined_array k=string d=0..9 v=' '
  create_variable host_network_id k=string v=' '
  create_variable permanent_config_file k=string v='$system.network.configuration'

main_loop: ..
  LOOP
"$ format=off
    put_line (..
     '1Define Network'..
     '01. Define the network configuration'..
     ' 2. Define the CDCNET configuration'..
     ' 3. Activate the network'..
     ' 4. Define the Timesharing application'..
     '0Enter a menu selection, QUIT, or ?: '..
    )
"$ format=on
    choice = ''
    accept_line choice input p=''

    IF choice = '1' THEN

      define_network_config host_network_id physical_data system_id_array defined_array

    ELSEIF choice = '2' THEN

      create_cdcnet_config_procs

    ELSEIF choice = '3' THEN

      IF $file($fname(permanent_config_file), permanent) THEN
        detach_file $fname(permanent_config_file) status=ignore_status
        activate_network status=local_status
        IF local_status.normal THEN
          put_line '  '
          accept_line cr_requested input p='Press NEXT: '
        ELSE
          display_value local_status
          put_line '  '
          accept_line cr_requested input p='Press NEXT: '
        IFEND
      ELSE
        put_line ('0Network configuration must be installed before the network can be activated.' '  ')
        accept_line cr_requested input p='Press NEXT: '
      IFEND

    ELSEIF choice = '4' THEN

      define_timesharing

    ELSEIF ($translate(lower_to_upper, choice) = 'QUIT') OR ($translate(lower_to_upper, choice) = 'QUI') THEN

      EXIT main_loop

    ELSEIF (choice = '?') OR ($translate(lower_to_upper, choice) = 'HELP') THEN

      define_network_help

    ELSEIF choice = ' ' THEN

      " Do nothing if the user types-ahead."

    ELSE

      accept_line cr_requested input p='Invalid selection, press NEXT: '

    IFEND

  LOOPEND main_loop

PROCEND define_network
*DECK DECK=RAM$DEFINE_NETWORK_CONFIG EXPAND=TRUE
PROCEDURE define_network_config (
  host_network            : (var) string = $required
  physical_data_array     : (var) array of string = $required
  system_ids              : (var) array of string = $required
  def_array               : (var) array of string = $required
  status)

" Make local copies of the procedure parameters.

  physical_data = physical_data_array
  system_id_array = system_ids
  host_network_id = host_network
  defined_array = def_array

  VAR
    choice: string
    conversion_status: status
    cr_requested: string
    forward_search: string='4(10)'
    host_name: string=' '
    number_physical_entries: integer
    successful: boolean
    termination_desired: boolean
  VAREND

  IF $namve_active THEN
    prompt_for_active_network termination_desired
    EXIT_PROC WITH $status(TRUE) WHEN termination_desired
  IFEND

  get_physical_information physical_data number_physical_entries

  IF number_physical_entries = 0 THEN
    put_line (' Network device definitions must exist in order ' ..
              ' to define a network configuration'..
              '0 ')
    accept_line cr_requested input p='Press NEXT: '
    EXIT_PROC WITH $status(true)
  IFEND

main_loop: ..
  LOOP
"$ format=off
    put_line (..
     '1Define the Network Configuration'..
     '01. Define the Network Connections'..
     ' 2. Define the TCP/IP Host'..
     '0Enter a menu selection, GO, QUIT, or ?: '..
    )
"$ format=on
    choice = ''
    accept_line choice input p=''

    IF choice = '1' THEN

      prompt_for_host_network host_network_id
      IF host_network_id = ' ' THEN
        EXIT_PROC
      IFEND

      define_network_connection  physical_data host_network_id system_id_array number_physical_entries defined_array

    ELSEIF choice = '2' THEN

      define_tcpip_host host_name=host_name forward_search_range=forward_search
      IF host_name = ' ' THEN
        forward_search='4(10)'
      IFEND

    ELSEIF (choice = '?') OR ($translate(lower_to_upper, choice) = 'HELP') THEN

"$ format = off
      put_line (..
       ' Enter GO or press NEXT to install the network configuration you have defined.' ..
       '    If you defined more than one device (i.e., MDI, ICA_II, or EXPRESSLink),'..
       '    you must define a VE interface network identifier for each MDI or ICA_II'..
       '    before activating NAM/VE.  (Use: main menu selection 2. Define the CDCNET'..
       '    configuration and subordinates to define VE interface network identifiers.)'..
       ' Enter QUIT to return to the main menu without installing the' ..
       '   configuration.  Any network configuration parameters you have set' ..
              '   will be lost.' ..
              '  ')
"$ format = on
        accept_line cr_requested input p='Press NEXT: '

      ELSEIF ($translate(lower_to_upper, choice) = 'QUIT') OR ($translate(lower_to_upper, choice) = 'QUI') ..
            THEN

        EXIT_PROC

      ELSEIF (choice = ' ') OR ($translate(lower_to_upper, choice) = 'GO') THEN

        install_network_config_file  host_network_id  system_id_array  ..
              physical_data number_physical_entries defined_array host_name ..
              forward_search successful
        IF successful THEN
          EXIT main_loop
        IFEND

      ELSE
        put_line '  '
        accept_line cr_requested input p='Invalid selection, press NEXT: '
      IFEND

    LOOPEND main_loop

  physical_data_array = physical_data
  system_ids = system_id_array
  host_network = host_network_id
  def_array = defined_array

PROCEND define_network_config
*DECK DECK=RAM$DEFINE_NETWORK_CONNECTION EXPAND=TRUE
PROCEDURE define_network_connection (
  physical_data_array: (var) array of string = $required
  host_network_id: string = $required
  system_ids: (var) array of string = $required
  number_physical_entries: integer = $required
  def_array: (var) array of string = $required
  status)


" This procedure prompts the user to add/delete network devices to/from
" the network configuration.  All available network devices that can be added/deleted
" are displayed as options.  By selecting an option, the user may add or
" delete that particular device to/from the network configuration.
" When adding an ICA-II to the network configuration, the user is prompted to
" enter in a 6 digit (hex) system identifier number.

" Make local copies of parameters.

  physical_data = physical_data_array
  system_id_array = system_ids
  defined_array = def_array

"$ format = off
  VAR
    choice: string
    conversion_status: status
    cr_requested: string
    selection: integer
    successful: boolean
  VAREND
"$ format = on


  main_loop: ..
    LOOP

 "$ format= off
    put_line ('1Define a Network Connection' ..
          '0Choose network connection to add or delete:' ..
          '0                                                             (ICA-II ONLY)' ..
          '   Add to the   Type of                                           System  ' ..
          '    Network?    Device   Connected System/Element Name        Identification', ' ')
"$ format= on

      FOR i = 1 TO number_physical_entries DO
        put_line (' '//$strrep(i)//'.  '//$substring(defined_array(i),1,12,' ')//$substring(physical_data(i),5,5)//..
'   '//$substring(physical_data(i),11,31)//'        '//$substring(system_id_array(i),1,13))
      FOREND

      put_line ('0Enter a menu selection, QUIT, GO, or ?: ')
      choice = ''

      accept_line choice input p=''

      IF (choice = '?') OR ($translate(lower_to_upper, choice) = 'HELP') THEN

"$ format = off
        put_line ('0This menu prompts you to add/delete network devices to/from ' ..
              ' your network configuration.  The network configuration defines which ' ..
              ' network devices your mainframe is to recognize on the network.' ..
              '0Enter a menu selection to add/delete it to/from the network configuration.' ..
              ' Enter GO or press NEXT to save the network configuration you have defined.' ..
              ' Enter QUIT to return to the define network menu without saving the' ..
              '   configuration.  Any network configuration parameters you have set' ..
              '   will be lost.' ..
              '  ')
"$ format = on
        accept_line cr_requested input p='Press NEXT: '

      ELSEIF ($translate(lower_to_upper, choice) = 'QUIT') OR ($translate(lower_to_upper, choice) = 'QUI') ..
            THEN

        EXIT main_loop

      ELSEIF (choice = ' ') OR ($translate(lower_to_upper, choice) = 'GO') THEN

        physical_data_array = physical_data
        system_ids = system_id_array
        def_array = defined_array
        EXIT main_loop

      ELSE
        include_line 'selection = $integer(choice)' status=conversion_status
        IF conversion_status.normal THEN
          IF (selection >= 1) AND (selection <= number_physical_entries) THEN
            prompt_for_add_element physical_data(selection) system_id_array(selection) defined_array(selection)
            CYCLE main_loop
          IFEND
        IFEND
        put_line '  '
        accept_line cr_requested input p='Invalid selection, press NEXT: '
      IFEND

    LOOPEND main_loop

PROCEND define_network_connection
*DECK DECK=RAM$DEFINE_NETWORK_HELP EXPAND=TRUE
PROCEDURE define_network_help (
  status:  (var) status = $optional
)

  create_variable cr_requested k=string
"$ format=off
  put_line (..
    '1The DEFINE_NETWORK menu prompts you to do two things:'..
    '0o  Define the initial network configuration and CDCNET hardware (menu'..
    '    selections 1 through 3).'..
    ' o  Define the Timesharing titles used to create terminal connections to'..
    '    NOS/VE (menu selection 4).'..
    '0For a first time installation of the network, you should perform all four'..
    ' steps, in order.  '..
    '0The menu selections are:'..
    '01. Define the logical characteristics for the network connections between '..
    '    the mainframe and network hardware, and define the mainframe network ' ..
    '    identifier. These definitions allow the mainframe to access the CDCNET ' ..
    '    concatenated network (catenet).  This option reads your mainframe''s ' ..
    '    physical configuration to determine the network connections.  If the ' ..
    '    network is already activated when you execute option 1, any network ' ..
    '    configuration changes will not take effect until after the next system ' ..
    '    deadstart.'..
    '  ')
  accept_line cr_requested input prompt='Press NEXT: '
  put_line (..
    '12. Define the system identifiers of all CDCNET Device Interfaces (DIs) '..
    '    and ICA-II''s connected to the mainframe.  You must define all DIs ' ..
    '    connected by ethernet cable as well as those directly attached to ' ..
    '    a mainframe channel. This process creates configuration files for each'..
    '    DI or ICA-II so that you may login to the system on an interactive ' ..
    '    terminal. The interactive terminal may be connected on any LIM and PORT, if '..
    '    it is defined using the menu, or you can use the default terminal ' ..
    '    connected to LIM 0 PORT 0 on any MTI or TDI.'..
    ' 3. Once the network configuration has been defined via menu option 1, select'..
    '    this option to activate the tasks required for network operation.'..
    '    Once the network is activated, the CDCNET DIs or ICA-II''s will ' ..
    '    be loaded with the configurations defined in menu selection 2.'..
    ' 4. Define the title or titles of the Timesharing application. A Timesharing'..
    '    title is the name users must enter on the CDCNET CREATE_CONNECTION command'..
    '    to connect their terminal with NOS/VE.  You must re-define any titles '..
    '    that you want to keep.'..
    '  ')
  accept_line cr_requested input prompt='Press NEXT: '
  put_line (..
    '1For a first time installation of NOS/VE in which you are defining the'..
    ' configuration for the first time, you should perform menu options '..
    ' 1 through 4 in order.'..
    '0At the prompt for the DEFINE_NETWORK command, you may:'..
    '0o  Enter the desired menu selection,'..
    ' o  Enter QUIT to terminate the DEFINE_NETWORK command.'..
    '  ')
  accept_line cr_requested input prompt='Press NEXT: '

PROCEND define_network_help
*DECK DECK=RAM$DEFINE_NQS EXPAND=TRUE
PROCEDURE rap$define_nqs (
  maximum_connections, mc: integer = 40
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request defines the nam application name for the nqs server
"    application.
"
*IFEND

  VAR
    command_file     : file =$unique($local)
    ignore_status    : status
    local_status     : status
  VAREND

COLLECT_TEXT command_file until='COLLECT_END'
  $system.osf$command_library.manage_network_applications
    define_tcpip_application application=osa$nqs_server protocol=stream_socket
      change_maximum_sockets maximum_sockets=maximum_connections
      change_tcpip_validation ring=6
    quit
    activate_tcpip_application application=osa$nqs_server
  quit
COLLECT_END

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  IF local_status.normal THEN
    put_line ' NQS server application is defined' o=$response
  IFEND

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$define_nqs

*DECK DECK=RAM$DEFINE_NTF EXPAND=TRUE
PROC rap$define_ntf (
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request defines NTF.
*IFEND


    create_variable command_file k=string v='$local.'//$unique
    create_variable ignore_status k=status
    create_variable local_status k=status


  collect_text $fname(command_file) until='  collect_end'
    $system.osf$command_library.manage_network_applications
      define_client client=osa$network_transfer_fac_client protocol=cdna_session
        change_connection_priority connection_priority=5
        change_maximum_connections mc=20
        change_client_validation sp=true
        change_application_identifier ai=2004
      end_define_client
      activate_client client=osa$network_transfer_fac_client
    quit
  collect_end

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  IF local_status.normal THEN
    put_line ' NTF application is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$define_ntf
*DECK DECK=RAM$DEFINE_OPENTF EXPAND=TRUE
PROC rap$define_opentf (
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request defines OPENTF.
*IFEND


    create_variable command_file k=string v='$local.'//$unique
    create_variable ignore_status k=status
    create_variable local_status k=status


  collect_text $fname(command_file) until='  collect_end'
    $system.osf$command_library.manage_network_applications
      define_client client=osa$ntf_operator protocol=cdna_session
        change_connection_priority connection_priority=5
        change_maximum_connections mc=20
        change_application_identifier ai=2005
      end_define_client
      activate_client client=osa$ntf_operator
    quit
  collect_end

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  IF local_status.normal THEN
    put_line ' OPENTF application is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$define_opentf
*DECK DECK=RAM$DEFINE_OPES EXPAND=TRUE
PROC rap$define_opes (
  status)


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"   This request defines OPES.
*IFEND


    create_variable command_file k=string v='$local.'//$unique
    create_variable ignore_status k=status
    create_variable local_status k=status


  collect_text $fname(command_file) until='  collect_end'
    $system.osf$command_library.manage_network_applications
      define_client client=osa$station_operator protocol=cdna_session
        change_connection_priority connection_priority=5
        change_maximum_connections mc=20
        change_application_identifier ai=2003
      end_define_client
      activate_client client=osa$station_operator
    quit
  collect_end

  include_file $fname(command_file) status=local_status
  detach_file $fname(command_file) status=ignore_status

  IF local_status.normal THEN
    put_line ' OPES application is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$define_opes
*DECK DECK=RAM$DEFINE_ORDER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'CREATE_ORDER_DEFINITION Subutility: DEFINE_ORDER Subcommand.' ??
MODULE ram$define_order;

{ PURPOSE:
{   This module contains procedures to initiate a new order definition.
{
{ DESIGN:
{   The scratch sequence and packing list sequences are reset.
{   The sequence descriptor and packing list header are added to the
{   packing list sequence and their fields are initialized.
{   The order contents list is added to the scratch sequence and initialized
{   with one entry for the packing list.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$packing_list_level
*copyc rac$packing_list_name
*copyc rac$pacs_processor_version
*copyc rac$sif_file_name
*copyc rac$subproduct_info_level
*copyc cld$path_description
*copyc rae$package_software_cc
*copyc rat$order_contents_list
*copyc rat$packing_list_types
*copyc rat$sequence_descriptor_types
*copyc rat$subproduct_info_types
?? POP ??
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc pmp$get_compact_date_time
*copyc rav$creod_scratch_segment
*copyc rav$order_contents_count
*copyc rav$order_contents_list_p
*copyc rav$packing_list_header_p
*copyc rav$packing_list_seq_p

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??


?? TITLE := '[XDCL] rap$define_order', EJECT ??

{ PURPOSE:
{   This procedure initiates a new order definition.
{
{ DESIGN:
{   The scratch sequence and packing list sequences are reset.
{   The sequence descriptor and packing list header are added to the
{   packing list sequence and their fields are initialized.
{   The order contents list is added to the scratch sequence and initialized
{   with one entry for the packing list.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$define_order
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt defo_pdt (
{   identifier, i     : name = $required
{   medium, m         : key tape, disk = tape
{   type, t           : key release, correction = release
{   status            : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    defo_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^defo_pdt_names, ^defo_pdt_params];

  VAR
    defo_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
      clt$parameter_name_descriptor := [['IDENTIFIER', 1], ['I', 1], ['MEDIUM', 2], ['M', 2], ['TYPE', 3], [
      'T', 3], ['STATUS', 4]];

  VAR
    defo_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor := [

{ IDENTIFIER I }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ MEDIUM M }
    [[clc$optional_with_default, ^defo_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [^defo_pdt_kv2,
      clc$keyword_value]],

{ TYPE T }
    [[clc$optional_with_default, ^defo_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [^defo_pdt_kv3,
      clc$keyword_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    defo_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := ['TAPE','DISK'];

  VAR
    defo_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := ['RELEASE',
      'CORRECTION'];

  VAR
    defo_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'tape';

  VAR
    defo_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := 'release';

?? POP ??

    VAR
      ignore_status: ost$status,
      message_status: ost$status,
      write_definition_needed_flag_p: ^boolean;


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, defo_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET rav$creod_scratch_segment.sequence_p;
    NEXT write_definition_needed_flag_p IN rav$creod_scratch_segment.sequence_p;
    IF write_definition_needed_flag_p^ = TRUE THEN
      osp$set_status_abnormal ('RA', rae$command_wrid_required, '', message_status);
      osp$generate_error_message (message_status, ignore_status);
    ELSE
      write_definition_needed_flag_p^ := TRUE;
    IFEND;

    initialize_packing_list_seq (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    initialize_order_contents_list (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$define_order;

?? TITLE := 'initialize_order_contents_list', EJECT ??

{ PURPOSE:
{   This procedure sets the initial values for the order contents
{   list in the scratch sequence.
{
{ DESIGN:
{   The order contents list is added to the scratch sequence and
{   its fields are initialized.
{
{ NOTES:
{
{

  PROCEDURE initialize_order_contents_list
    (VAR status: ost$status);

    status.normal := TRUE;

    NEXT rav$order_contents_list_p: [1 .. 1] IN rav$creod_scratch_segment.sequence_p;
    rav$order_contents_count := 1;

    rav$order_contents_list_p^ [1].assignment_priority := $INTEGER (rac$packing_list);
    rav$order_contents_list_p^ [1].size := 0;
    rav$order_contents_list_p^ [1].position_assigned := 0;
    rav$order_contents_list_p^ [1].name := rac$packing_list_name;
    rav$order_contents_list_p^ [1].contents_type := packing_list;

    NEXT rav$creod_scratch_segment.reset_p IN rav$creod_scratch_segment.sequence_p;

  PROCEND initialize_order_contents_list;

?? TITLE := 'initialize_packing_list_seq', EJECT ??

{ PURPOSE:
{   This procedure sets the initial values for the sequence descriptor
{   and packing list header in the packing list sequence.
{
{ DESIGN:
{   The sequence descriptor and packing list header are added to the
{   packing list sequence and their fields are initialized.
{
{ NOTES:
{
{

  PROCEDURE initialize_packing_list_seq
    (VAR status: ost$status);


    VAR
      length: integer,
      order_type: ost$name,
      sequence_descriptor_p: ^rat$sequence_descriptor,
      specified: boolean,
      value: clt$value;

    status.normal := TRUE;
    RESET rav$packing_list_seq_p;

    NEXT sequence_descriptor_p IN rav$packing_list_seq_p;
    IF sequence_descriptor_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    pmp$get_compact_date_time( sequence_descriptor_p^.sequence_creation_date_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sequence_descriptor_p^.processor_version := rac$pacs_processor_version;
    sequence_descriptor_p^.sequence_level := rac$packing_list_level;
    sequence_descriptor_p^.sequence_type := rac$packing_list_sequence;

    NEXT rav$packing_list_header_p IN rav$packing_list_seq_p;
    IF rav$packing_list_header_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    clp$get_value ('IDENTIFIER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    rav$packing_list_header_p^.order_identifier := value.name.value (1, value.name.size);

    clp$get_value ('MEDIUM', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.name.value (1, value.name.size) = 'TAPE' THEN
      rav$packing_list_header_p^.order_medium := rac$tape;
    ELSEIF value.name.value (1, value.name.size) = 'DISK' THEN
      rav$packing_list_header_p^.order_medium := rac$disk;
    IFEND;

    clp$get_value ('TYPE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    order_type := value.name.value (1, value.name.size);

    IF order_type = 'RELEASE' THEN
      rav$packing_list_header_p^.order_type := rac$release;
    ELSE { order_type = 'CORRECTION' }
      rav$packing_list_header_p^.order_type := rac$correction;
    IFEND;

  PROCEND initialize_packing_list_seq;

MODEND ram$define_order;
*DECK DECK=RAM$DEFINE_PERMIT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'DEFINE_SUBPRODUCT Subutility: Module RAM$DEFINE_PERMIT.' ??
MODULE ram$define_permit;

{ PURPOSE:
{   This module sets the permit field for an element or all elements in the
{   element list.
{
{ DESIGN:
{   The element list is searched for the correct file or catalog.  Then
{   the permit field is updated.  If ALL elements are selected,
{   all files in the element list are updated.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc cld$path_description
*copyc fst$file_reference
*copyc ost$status
*copyc rae$package_software_cc
*copyc rat$subproduct_info_p
*copyc rat$subproduct_info_types
*copyc rat$validation_selections
?? POP ??
*copyc clp$convert_file_ref_to_string
*copyc clp$get_fs_path_elements
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc clp$trimmed_string_size
*copyc fsp$convert_fs_structure_to_pf
*copyc osp$append_status_file
*copyc osp$set_status_abnormal
*copyc rap$locate_element
*copyc rap$get_file_path_and_ref
*copyc rav$subproduct_info_pointers
*copyc rav$pacs_catalog_p
*copyc rav$pacs_catalog_ref_p
*copyc rav$defs_scratch_segment
*copy rav$permit_names

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$define_permit', EJECT ??

{ PURPOSE:
{   This procedure sets each or all of the permit fields in the element_list.
{
{ DESIGN:
{   The permit, share_mode and application information are determined
{   from the input parameters on DEFINE_CATALOG_PERMIT or DEFINE_FILE_PERMIT.
{   If only one file or catalog is being updated, validate that it is
{   an element of the current subproduct.  Then locate the element in the
{   element list and update the permit field.
{   If all files are selected, update the permit for all elements in the
{   element list.
{   If INSTALLATION_PATH_CATALOG is selected, validate the existence of
{   the installation path and update the value of the permit.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$define_permit
    (    element_type: string ( * <= osc$max_string_size);
     VAR status: ost$status);

    VAR
      ai_specified: boolean,
      application_info: pft$application_info,
      attributes_p: ^rat$subproduct_attributes,
      element_p: ^rat$element,
      element_found: boolean,
      ignore_permit: pft$permit_selections,
      ignore_share: pft$share_requirements,
      path_index: 0 .. fsc$max_path_size,
      path_p: ^pft$path,
      path_ref_p: ^fst$file_reference,
      permit: pft$permit_selections,
      share_specified: boolean,
      share: pft$share_requirements,
      subproduct_info_seq_p: ^rat$subproduct_info_sequence,
      value: clt$value;


    status.normal := TRUE;
    subproduct_info_seq_p := rav$subproduct_info_pointers.subproduct_info_seq_p;
    attributes_p := rav$subproduct_info_pointers.attributes_p;
    element_p := rav$subproduct_info_pointers.element_list_p;

    process_access_or_share ('ACCESS_MODE', select_permit, ignore_share, permit, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$test_parameter ('SHARE_MODE', share_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF share_specified THEN
      process_access_or_share ('SHARE_MODE', select_share, share, ignore_permit, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      share := $pft$share_requirements [];
    IFEND;

    clp$test_parameter ('APPLICATION_INFORMATION', ai_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF ai_specified THEN
      clp$get_value ('APPLICATION_INFORMATION', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      application_info := value.str.value (1, value.str.size);
    ELSE {application information not specified}
      application_info := '';
    IFEND;

    clp$get_value (element_type, 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.kind = clc$file_value THEN

      RESET rav$defs_scratch_segment.sequence_p TO rav$defs_scratch_segment.reset_p;

      rap$get_file_path_and_ref (element_type, rav$defs_scratch_segment.sequence_p, path_p, path_ref_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF rav$pacs_catalog_ref_p^ = path_ref_p^ THEN

        attributes_p^.catalog_permit.defined := TRUE;
        attributes_p^.catalog_permit.permit_selections := permit;
        attributes_p^.catalog_permit.share_requirements := share;
        attributes_p^.catalog_permit.application_info := application_info;

      ELSE

        IF attributes_p^.first_level_element_count = 0 THEN
          osp$set_status_abnormal ('RA', rae$error_pacs_catalog_empty, '', status);
          RETURN;
        IFEND;

        IF (#SIZE (rav$pacs_catalog_ref_p^) > #SIZE (path_ref_p^)) OR
              (rav$pacs_catalog_ref_p^ <> path_ref_p^ (1, #SIZE (rav$pacs_catalog_ref_p^))) THEN
          osp$set_status_abnormal ('RA', rae$not_in_pacs_catalog, '', status);
          osp$append_status_file (osc$status_parameter_delimiter, path_ref_p^, status);
          RETURN;
        IFEND;


        path_index := UPPERBOUND (rav$pacs_catalog_p^) + 1;

        rap$locate_element (path_p, path_index, subproduct_info_seq_p, element_p, element_found);

        IF NOT element_found THEN
          osp$set_status_abnormal ('RA', rae$not_in_pacs_catalog, '', status);
          osp$append_status_file (osc$status_parameter_delimiter, path_ref_p^, status);
          RETURN;
        IFEND;

        IF ((element_p^.element_type = rac$catalog) AND (element_type <> 'CATALOG')) THEN
          osp$set_status_abnormal ('RA', rae$expecting_file, '', status);
          osp$append_status_file (osc$status_parameter_delimiter, path_ref_p^, status);
          RETURN;
        IFEND;

        IF ((element_p^.element_type = rac$file) AND (element_type <> 'FILE')) THEN
          osp$set_status_abnormal ('RA', rae$expecting_catalog, '', status);
          osp$append_status_file (osc$status_parameter_delimiter, path_ref_p^, status);
          RETURN;
        IFEND;

        element_p^.permit.defined := TRUE;
        element_p^.permit.permit_selections := permit;
        element_p^.permit.share_requirements := share;
        element_p^.permit.application_info := application_info;

      IFEND;

    ELSEIF value.name.value = 'ALL' THEN

      IF attributes_p^.first_level_element_count = 0 THEN
        osp$set_status_abnormal ('RA', rae$error_pacs_catalog_empty, '', status);
        RETURN;
      IFEND;

      add_file_permit (permit, share, application_info, attributes_p^.first_level_element_count, element_p,
            subproduct_info_seq_p);

    ELSEIF value.name.value = 'INSTALLATION_PATH_CATALOG' THEN

      attributes_p^.catalog_permit.defined := TRUE;
      attributes_p^.catalog_permit.permit_selections := permit;
      attributes_p^.catalog_permit.share_requirements := share;
      attributes_p^.catalog_permit.application_info := application_info;

    IFEND;

  PROCEND rap$define_permit;

?? TITLE := 'add_file_permit', EJECT ??

{ PURPOSE:
{   This procedure sets the permit on an element or all elements
{   in the element list.
{
{ DESIGN:
{   This procedure is given an element pointer and the number of next level elements in that
{   element.  If the element is of type FILE, then only that one element will be updated.
{   If the element is of type CATALOG, all files in the catalog and lower level subcatalogs
{   will be updated.
{
{ NOTES:
{
{

  PROCEDURE add_file_permit
    (    permit: pft$permit_selections;
         share: pft$share_requirements;
         application_info: pft$application_info;
         element_count: rat$element_count;
         element_p: ^rat$element;
     VAR subproduct_info_seq_p: ^rat$subproduct_info_sequence);


    VAR
      current_element_p: ^rat$element,
      i: rat$path_container_index,
      first_element_down_p: ^rat$element,
      next_element_count: rat$element_count;


    current_element_p := element_p;

    FOR i := 1 TO element_count DO
      IF current_element_p^.element_type = rac$file THEN
        current_element_p^.permit.defined := TRUE;
        current_element_p^.permit.permit_selections := permit;
        current_element_p^.permit.share_requirements := share;
        current_element_p^.permit.application_info := application_info;
      ELSEIF (current_element_p^.element_type = rac$catalog) AND (current_element_p^.element_count <> 0) THEN
        next_element_count := current_element_p^.element_count;
        first_element_down_p := #PTR (current_element_p^.first_element_down_p, subproduct_info_seq_p^);
        add_file_permit (permit, share, application_info, next_element_count, first_element_down_p,
              subproduct_info_seq_p);
      IFEND;

      IF i < element_count THEN
        current_element_p := #PTR (current_element_p^.next_element_across_p, subproduct_info_seq_p^);
      IFEND;
    FOREND;

  PROCEND add_file_permit;

?? TITLE := 'process_access_or_share', EJECT ??

{ PURPOSE:
{   This procedure sets the correct values for the access_mode and  share_mode
{   given the input parameters.
{
{ DESIGN:
{   This procedure translates the value of ALL or WRITE into
{   the correct set of access modes.
{
{ NOTES:
{
{

  PROCEDURE process_access_or_share
    (    param_name: string ( * );
         selection_kind: (select_share, select_permit);
     VAR share_requirements: pft$share_requirements;
     VAR permit_selections: pft$permit_selections;
     VAR status: ost$status);

    VAR
      i: 1 .. clc$max_value_sets,
      j: pft$permit_options,
      permit_option: pft$permit_selections,
      share_option: pft$share_requirements,
      value_set_count: 0 .. clc$max_value_sets,
      value: clt$value;


    permit_selections := $pft$permit_selections [];
    share_requirements := $pft$share_requirements [];

    clp$get_set_count (param_name, value_set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO value_set_count DO
      clp$get_value (param_name, i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF value.name.value = 'ALL' THEN
        IF (value_set_count <> 1) AND (selection_kind <> select_permit) THEN
          osp$set_status_abnormal ('CL', cle$all_must_be_used_alone, param_name, status);
          RETURN;
        IFEND;

        IF selection_kind = select_permit THEN
          permit_option := -$pft$permit_selections [pfc$control, pfc$cycle];
        ELSEIF selection_kind = select_share THEN
          share_option := -$pft$share_requirements [];
        IFEND;

      ELSEIF value.name.value = 'NONE' THEN
        IF value_set_count <> 1 THEN
          osp$set_status_abnormal ('CL', cle$none_must_be_used_alone, param_name, status);
        IFEND;
        RETURN;

      ELSEIF value.name.value = 'WRITE' THEN
        IF selection_kind = select_permit THEN
          permit_option := $pft$permit_selections [pfc$append, pfc$modify, pfc$shorten];
        ELSEIF selection_kind = select_share THEN
          share_option := $pft$share_requirements [pfc$append, pfc$modify, pfc$shorten];
        IFEND;

      ELSE

      /initialize_value/
        FOR j := LOWERBOUND (rav$permit_names) TO UPPERBOUND (rav$permit_names) DO

          IF rav$permit_names [j] = value.name.value THEN

            IF selection_kind = select_permit THEN
              permit_option := $pft$permit_selections [j];
            ELSEIF selection_kind = select_share THEN
              share_option := $pft$share_requirements [j];
            IFEND;

          IFEND;

        FOREND /initialize_value/;

      IFEND;

      IF selection_kind = select_permit THEN
        IF permit_option <= permit_selections THEN
          osp$set_status_abnormal ('CL', cle$redundancy_in_selections, param_name, status);
          RETURN;
        IFEND;
        permit_selections := permit_selections + permit_option;

      ELSEIF selection_kind = select_share THEN

        IF share_option <= share_requirements THEN
          osp$set_status_abnormal ('CL', cle$redundancy_in_selections, param_name, status);
          RETURN;
        IFEND;
        share_requirements := share_requirements + share_option;

      IFEND;

    FOREND;

  PROCEND process_access_or_share;

MODEND ram$define_permit;
*DECK DECK=RAM$DEFINE_PSRS_ANSWERED EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'DEFINE_SUBPRODUCT Subutility: DEFINE_PSRS_ANSWERED command.' ??
MODULE ram$define_psrs_answered;

{ PURPOSE:
{   This module contains the procedure that defines the PSRS answered.
{
{ DESIGN:
{
{   The compiled module resides in RAF$LIBRARY.
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$package_software_cc
*copyc ost$status
*copyc rat$correction_process_record
*copyc rat$subproduct_info_types
?? POP ??
*copyc clp$evaluate_parameters
*copyc osp$set_status_abnormal
*copyc rap$process_psrs_entered
*copyc rav$subproduct_info_pointers

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$define_psrs_answered', EJECT ??

  PROCEDURE [XDCL] rap$define_psrs_answered
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE defpa_pdt (
{   psrs_answered, pa: any of
{                        list of name rac$psr_name_length..rac$psr_name_length
{                        file
{                      anyend = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 10, 4, 21, 46, 41, 829],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'DEFPA_PDT'], [
    ['PA                             ',clc$abbreviation_entry, 1],
    ['PSRS_ANSWERED                  ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 44, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$file_type, clc$list_type],
    FALSE, 2],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [rac$psr_name_length, rac$psr_name_length]]
      ],
    3, [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$psrs_answered = 1,
    p$status = 2;

  VAR
    pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      ignore_previous_sif: rat$correction_process_sif_info;

    status.normal := TRUE;
    ignore_previous_sif.file_opened := FALSE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (rav$subproduct_info_pointers.psrs_answered_p <> NIL) AND
      (rav$subproduct_info_pointers.path_container_p <> NIL) THEN
      osp$set_status_abnormal ('RA', rae$defpa_command_not_allowed, '', status);
      RETURN;
    IFEND;

    IF rav$subproduct_info_pointers.attributes_p^.subproduct_type = rac$correction THEN
      rap$process_psrs_entered (pvt [p$psrs_answered].value^, rav$subproduct_info_pointers,
            ignore_previous_sif, status);
    ELSE
      osp$set_status_abnormal ('RA', rae$defpa_already_called, '', status);
    IFEND;

  PROCEND rap$define_psrs_answered;

MODEND ram$define_psrs_answered;
*DECK DECK=RAM$DEFINE_PTF EXPAND=TRUE
PROC rap$define_ptf (
  family_names, family_name, fn: list of name 1..26 = $required
  status)


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"    This request defines the PTF and PTFS applications.
"
"    The prefix 'PTFS$' is required on all family names and is
"automatically added so that the user does'nt have to add it.
*IFEND


    create_variable command_file k=string v='$local.'//$unique
    create_variable ignore_status k=status
    create_variable local_status k=status
    create_variable title k=(string $max_name)


  collect_text $fname(command_file) until='  collect_end'
    $system.osf$command_library.manage_network_applications
      define_client client=osa$file_transfer_client protocol=cdna_session
        change_connection_priority cp=4
        change_maximum_connections mc=40
        change_client_validation sp=true
        change_application_identifier ai=2001
      end_define_client
      activate_client client=osa$file_transfer_client

      define_server server=osa$file_transfer_server protocol=cdna_session ..
           nam_initiated=false
        change_connection_priority cp=4
        change_maximum_connections mc=40
        change_server_validation sp=true
        change_accept_connection ac=false
        add_client_address si=nosve ai=2001
        add_client_address si=cdcnet ai=all

        FOR i =  1 TO $set_count(family_names) DO
          include_line 'add_titles ptfs$'//$string($value(family_name, i))
        FOREND

      end_define_server
      activate_server server=osa$file_transfer_server
    quit
  collect_end

  include_file $fname(command_file) status=local_status
  detach_file $fname(command_file) status=ignore_status

  IF local_status.normal THEN
    put_line ' PTF application is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$define_ptf

*DECK DECK=RAM$DEFINE_PTF_FOR_RHFAM EXPAND=TRUE
PROC define_ptf_for_rhfam (
  client_maximum_connections, cmc : integer 1..255 = 10
  server_maximum_connections, smc : integer 1..255 = 10
  status                          : var of status = $optional
  )

  create_variable define_ptf_status kind=status
  create_variable ignore_status kind=status

  create_variable cr_requested kind=string

  create_variable rhfam_utility_installed kind=boolean value=false
  create_variable rhfam_microcode_installed kind=boolean value=false

  create_variable command_file k=string v='$local.'//$unique
  create_variable rhfam_utility_file k=string v='$system.rhfam.osf$rhfam_network_utilities'
  create_variable rhfam_microcode k=string v='$system.rhfam.microcode.c180'

  rhfam_utility_installed = $file($fname(rhfam_utility_file), permanent)
  rhfam_microcode_installed = $file($fname(rhfam_microcode), permanent)
  IF (NOT rhfam_utility_installed) OR (NOT rhfam_microcode_installed) THEN
    put_line ('  ', ' --ERROR-- Product RHFAM is not installed.') o=$response
    accept_line cr_requested input p='Press NEXT:'
    EXIT_PROC
  IFEND

COLLECT_TEXT $fname(command_file) until='END_MANAGE_RHFAM_NETWORK'
  MANAGE_RHFAM_NETWORK
    define_rhfam_client client=ptf maximum_connections=$value(client_maximum_connections)
    activate_rhfam_client client=ptf
    define_rhfam_server server=ptfs rhfam_initiated=FALSE ..
      maximum_connections=$value(server_maximum_connections) accept_connection=FALSE ..
      rhfam_validates_connection_lid=TRUE
    activate_rhfam_server server=ptfs
    quit
END_MANAGE_RHFAM_NETWORK

  include_file $fname(command_file) status=define_ptf_status
  detach_file $fname(command_file) status=ignore_status
  EXIT_PROC WITH define_ptf_status WHEN NOT define_ptf_status.normal

  put_line ' PTF/PTFS defined for RHFAM' o=$response

PROCEND define_ptf_for_rhfam

*DECK DECK=RAM$DEFINE_QTF EXPAND=TRUE
PROC rap$define_qtf (
  status : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request defines and activates the NAM/VE QTF client application.
"   This definition is retained across deadstarts.
*IFEND


  create_variable command_file kind=string value='$local.'//$unique
  create_variable ignore_status kind=status
  create_variable local_status kind=status


COLLECT_TEXT output=$fname(command_file) until='COLLECT_END'
    $system.osf$command_library.manage_network_applications
      define_client client=osa$queue_transfer_client protocol=cdna_session
        change_connection_priority connection_priority=4
        change_maximum_connections maximum_connections=40
        change_client_validation system_privilege=true
        change_application_identifier application_identifier=2006
      end_define_client
      activate_client client=osa$queue_transfer_client
    quit
COLLECT_END

  include_file file=$fname(command_file) status=local_status
  delete_file file=$fname(command_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

  put_line line=' QTF client application defined for NAM/VE' output=$response

PROCEND rap$define_qtf
*DECK DECK=RAM$DEFINE_QTFS EXPAND=TRUE
PROC rap$define_qtfs (
  family_names, family_name, ..
  fn                         : list of name 1..26 = $required
  status                     : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request defines and activates the NAM/VE QTF server application.
"   This definition is retained across deadstarts.
*IFEND


  create_variable command_file kind=string value='$local.'//$unique
  create_variable ignore_status kind=status
  create_variable local_status kind=status
  create_variable title kind=(string $max_name)


COLLECT_TEXT $fname(command_file) until='COLLECT_END'
    $system.osf$command_library.manage_network_applications
      define_server server=osa$queue_transfer_server protocol=cdna_session ..
           nam_initiated=false
        change_connection_priority connection_priority=4
        change_maximum_connections maximum_connections=40
        change_server_validation system_privilege=true
        change_accept_connection accept_connection=false
        add_client_address system_identifier=nosve application_identifier=2006
        add_client_address system_identifier=cdcnet application_identifier=all

        FOR i =  1 TO $set_count(family_names) DO
          include_line statement_list='add_titles qtfs$'//$string($value(family_name, i))//' broadcast_registration=true'
        FOREND

      end_define_server
      activate_server server=osa$queue_transfer_server
    quit
COLLECT_END

  include_file file=$fname(command_file) status=local_status
  delete_file file=$fname(command_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

  put_line line=' QTF server application defined for NAM/VE' output=$response

PROCEND rap$define_qtfs
*DECK DECK=RAM$DEFINE_QTFS_FOR_RHFAM EXPAND=TRUE
PROC define_qtfs_for_rhfam (
  maximum_connections, mc : integer 1..255 = 10
  status                  : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request defines and activates the RHFAM/VE QTF server application.
"   This definitions is NOT retained across deadstarts.
*IFEND


  create_variable command_file kind=string value='$local.'//$unique
  create_variable cr_requested kind=string
  create_variable define_qtfs_status kind=status
  create_variable ignore_status kind=status
  create_variable rhfam_utility_installed kind=boolean value=false
  create_variable rhfam_microcode kind=string value='$system.rhfam.microcode.c180'
  create_variable rhfam_microcode_installed kind=boolean value=false
  create_variable rhfam_utility_file kind=string ..
        value='$system.rhfam.osf$rhfam_network_utilities'

  rhfam_utility_installed = $file($fname(rhfam_utility_file), permanent)
  rhfam_microcode_installed = $file($fname(rhfam_microcode), permanent)
  IF (NOT rhfam_utility_installed) OR (NOT rhfam_microcode_installed) THEN
    put_line lines=('  ', ' --ERROR-- Product RHFAM/VE is not installed.') o=$response
    accept_line variable=cr_requested input=input prompt='Press NEXT:'
    EXIT_PROC
  IFEND

COLLECT_TEXT output=$fname(command_file) until='COLLECT_END'
  MANAGE_RHFAM_NETWORK
    define_rhfam_server server=qtfs rhfam_initiated=FALSE ..
      maximum_connections=$value(maximum_connections) accept_connection=FALSE ..
      rhfam_validates_connection_lid=FALSE
    activate_rhfam_server server=qtfs
    quit
COLLECT_END

  include_file file=$fname(command_file) status=define_qtfs_status
  delete_file file=$fname(command_file) status=ignore_status
  EXIT_PROC WITH define_qtfs_status WHEN NOT define_qtfs_status.normal

  put_line line=' QTF server application defined for RHFAM/VE' output=$response

PROCEND define_qtfs_for_rhfam
*DECK DECK=RAM$DEFINE_QTF_FOR_RHFAM EXPAND=TRUE
PROC define_qtf_for_rhfam (
  maximum_connections, mc : integer 1..255 = 10
  status                  : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request defines and activates the RHFAM/VE QTF client application.
"   This definition is NOT retained across deadstarts.
*IFEND


  create_variable command_file kind=string value='$local.'//$unique
  create_variable cr_requested kind=string
  create_variable define_qtf_status kind=status
  create_variable ignore_status kind=status
  create_variable rhfam_microcode kind=string value='$system.rhfam.microcode.c180'
  create_variable rhfam_microcode_installed kind=boolean value=false
  create_variable rhfam_utility_installed kind=boolean value=false
  create_variable rhfam_utility_file kind=string ..
        value='$system.rhfam.osf$rhfam_network_utilities'

  rhfam_utility_installed = $file($fname(rhfam_utility_file), permanent)
  rhfam_microcode_installed = $file($fname(rhfam_microcode), permanent)
  IF (NOT rhfam_utility_installed) OR (NOT rhfam_microcode_installed) THEN
    put_line lines=('  ', ' --ERROR-- Product RHFAM/VE is not installed.') output=$response
    accept_line variable=cr_requested input=input prompt='Press NEXT:'
    EXIT_PROC
  IFEND

COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  MANAGE_RHFAM_NETWORK
    define_rhfam_client client=qtf maximum_connections=$value(maximum_connections)
    activate_rhfam_client client=qtf
    quit
COLLECT_END

  include_file file=$fname(command_file) status=define_qtf_status
  delete_file file=$fname(command_file) status=ignore_status
  EXIT_PROC WITH define_qtf_status WHEN NOT define_qtf_status.normal

  put_line line=' QTF client application defined for RHFAM/VE' output=$response

PROCEND define_qtf_for_rhfam
*DECK DECK=RAM$DEFINE_RELEASE_LEVEL EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'Tailored Release Process:  Define Release Level command' ??
MODULE ram$define_release_level;

{ PURPOSE:
{   This module contains the procedure that defines the release level.
{
{ DESIGN:
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$scan_parameter_list
?? POP ??

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL, #GATE] rap$define_release_level', EJECT ??

  PROCEDURE [XDCL, #GATE] rap$define_release_level
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt defrl_pdt (
{   release_level, rl : $required
{   status            : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    defrl_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^defrl_pdt_names, ^defrl_pdt_params
      ];

  VAR
    defrl_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['RELEASE_LEVEL', 1], ['RL', 1], ['STATUS', 2]];

  VAR
    defrl_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ RELEASE_LEVEL RL }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$application_value, '$REQUIRED',  [
      clc$unspecified_av_scanner]]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    status.normal := TRUE;

    clp$scan_parameter_list ( parameter_list, defrl_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$define_release_level;
MODEND ram$define_release_level;
*DECK DECK=RAM$DEFINE_REXEC EXPAND=TRUE
PROCEDURE rap$define_rexec (
  protocol, p: key (stream_socket, ss), (cdna_session, cs), keyend = stream_socket
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request defines the REXEC client.
"
*IFEND

  VAR
    command_file: file = $unique($local)
    ignore_status: status
    local_status: status
  VAREND

  IF protocol = stream_socket THEN
    collect_text command_file until='    collect_end' sm='?'
      $system.osf$command_library.manage_network_applications
        define_tcpip_application application=osa$rexec_client protocol=?protocol?
          change_maximum_sockets maximum_sockets=200
        quit
        activate_tcpip_application application=osa$rexec_client
      quit
    collect_end
  ELSE
    put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1' o=$response
    collect_text command_file until='    collect_end' sm='?'
      $system.osf$command_library.manage_network_applications
        define_client client=osa$rexec_client protocol=?protocol?
          change_maximum_connections maximum_connections=200
        quit
        activate_client client=osa$rexec_client
      quit
    collect_end
  IFEND

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  IF local_status.normal THEN
    put_line ' REXEC client is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND rap$define_rexec

*DECK DECK=RAM$DEFINE_REXECS EXPAND=TRUE
PROCEDURE rap$define_rexecs (
  protocol, p: key (stream_socket, ss), (cdna_session, cs), keyend = stream_socket
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request defines the REXEC server.
"
*IFEND

  VAR
    command_file: file = $unique($local)
    ignore_status: status
    local_status: status
  VAREND

  IF protocol = stream_socket THEN
    collect_text command_file until='    collect_end' sm='?'
      $system.osf$command_library.manage_network_applications
        define_tcpip_application application=osa$rexec_server protocol=?protocol?
          change_maximum_sockets maximum_sockets=200
        quit
        activate_tcpip_application application=osa$rexec_server
      quit
    collect_end
  ELSE
    put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1' o=$response
    collect_text command_file until='    collect_end' sm='?'
      $system.osf$command_library.manage_network_applications
        define_client client=osa$rexec_server protocol=?protocol?
          change_maximum_connections maximum_connections=200
        quit
        activate_client client=osa$rexec_server
      quit
    collect_end
  IFEND

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  IF local_status.normal THEN
    put_line ' REXEC server is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND rap$define_rexecs

*DECK DECK=RAM$DEFINE_RING_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'DEFINE_SUBPRODUCT Subutility: DEFINE_RING_ATTRIBUTES subcommand.' ??
MODULE ram$define_ring_attributes;

{ PURPOSE:
{   This module sets each or all of the ring_attributes fields in the element_list.
{
{ DESIGN:
{   The element list is searched for the correct file.  Then
{   the ring_attributes field is updated.  If ALL elements are selected,
{   all files in the element list are updated.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$package_software_cc
?? POP ??
*copyc clp$convert_file_ref_to_string
*copyc clp$get_fs_path_elements
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc clp$trimmed_string_size
*copyc fsp$convert_fs_structure_to_pf
*copyc osp$append_status_file
*copyc osp$set_status_abnormal
*copyc rap$get_file_path_and_ref
*copyc rap$locate_element
*copyc rav$subproduct_info_pointers
*copyc rav$pacs_catalog_p
*copyc rav$pacs_catalog_ref_p
*copyc rav$defs_scratch_segment

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$define_ring_attribute', EJECT ??

{ PURPOSE:
{   This command interface sets the ring attributes field for a
{   file or all files in the current subproduct.
{
{ DESIGN:
{   The file is validated as part of the current subproduct.
{   The file is located in the element_list and its ring attributes
{   are updated.  If ALL elements are selected, all files in the
{   element list are updated.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$define_ring_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt defra_pdt (
{   file, files, f      : file or key all = all
{   ring_attributes, ra : list 3 of integer 1..15 = $required
{   status              : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    defra_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^defra_pdt_names, ^defra_pdt_params
      ];

  VAR
    defra_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
      clt$parameter_name_descriptor := [['FILE', 1], ['FILES', 1], ['F', 1], ['RING_ATTRIBUTES', 2], ['RA', 2]
      , ['STATUS', 3]];

  VAR
    defra_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ FILE FILES F }
    [[clc$optional_with_default, ^defra_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [^defra_pdt_kv1,
      clc$file_value]],

{ RING_ATTRIBUTES RA }
    [[clc$required], 3, 3, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 1, 15]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    defra_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['ALL'];

  VAR
    defra_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'all';

?? POP ??

    VAR
      attributes_p: ^rat$subproduct_attributes,
      element_found: boolean,
      element_p: ^rat$element,
      file_path_index: integer,
      file_path_p: ^pft$path,
      file_path_ref_p: ^fst$file_reference,
      length: integer,
      ring_attributes: rat$ring_attributes,
      subproduct_info_seq_p: ^rat$subproduct_info_sequence,
      value: clt$value;


    status.normal := TRUE;
    attributes_p := rav$subproduct_info_pointers.attributes_p;
    element_p := rav$subproduct_info_pointers.element_list_p;
    subproduct_info_seq_p := rav$subproduct_info_pointers.subproduct_info_seq_p;

    IF attributes_p^.first_level_element_count = 0 THEN
      osp$set_status_abnormal ('RA', rae$error_pacs_catalog_empty, '', status);
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, defra_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('RING_ATTRIBUTES', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    ring_attributes.r1 := value.int.value;

    clp$get_value ('RING_ATTRIBUTES', 2, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    ring_attributes.r2 := value.int.value;

    clp$get_value ('RING_ATTRIBUTES', 3, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    ring_attributes.r3 := value.int.value;

    clp$get_value ('FILE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.kind = clc$file_value THEN

      RESET rav$defs_scratch_segment.sequence_p TO rav$defs_scratch_segment.reset_p;

      rap$get_file_path_and_ref ('FILE', rav$defs_scratch_segment.sequence_p, file_path_p, file_path_ref_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (#SIZE (file_path_ref_p^) < #SIZE (rav$pacs_catalog_ref_p^)) OR
            (rav$pacs_catalog_ref_p^ <> file_path_ref_p^ (1, #SIZE (rav$pacs_catalog_ref_p^))) THEN
        osp$set_status_abnormal ('RA', rae$not_in_pacs_catalog, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, file_path_ref_p^, status);
        RETURN;
      IFEND;

      file_path_index := UPPERBOUND (rav$pacs_catalog_p^) + 1;

      rap$locate_element (file_path_p, file_path_index, subproduct_info_seq_p, element_p, element_found);

      IF NOT element_found THEN
        osp$set_status_abnormal ('RA', rae$not_in_pacs_catalog, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, file_path_ref_p^, status);
        RETURN;
      IFEND;

      IF element_p^.element_type = rac$file THEN
        add_ring_attributes (ring_attributes, 1, element_p, subproduct_info_seq_p);
      ELSE
        osp$set_status_abnormal ('RA', rae$expecting_file, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, file_path_ref_p^, status);
        RETURN;
      IFEND;

    ELSE { value.kind = clc$name_value  ( key ALL ) }

      add_ring_attributes (ring_attributes, attributes_p^.first_level_element_count, element_p,
            subproduct_info_seq_p);
    IFEND;


  PROCEND rap$define_ring_attributes;

?? TITLE := 'add_ring_attributes', EJECT ??

{ PURPOSE:
{   This procedure sets the ring_attributes field for a file or
{   all files in the element list.
{
{ DESIGN:
{   This procedure is given an element pointer and the number of elements in that
{   element.  If the element is of type FILE, then only that one element will be updated.
{   If the element is of type CATALOG, all files in the catalog will be updated as well
{   as all files in all of the subcatalogs.
{
{ NOTES:
{

  PROCEDURE add_ring_attributes
    (    ring_attributes: rat$ring_attributes;
         element_count: rat$element_count;
     VAR element_p: ^rat$element;
     VAR subproduct_info_seq_p: ^rat$subproduct_info_sequence);


    VAR
      i: rat$path_container_index,
      next_element_count: rat$element_count,
      first_element_down_p: ^rat$element;


    FOR i := 1 TO element_count DO
      IF element_p^.element_type = rac$file THEN
        element_p^.ring_attributes := ring_attributes;
      ELSEIF (element_p^.element_type = rac$catalog) AND (element_p^.element_count <> 0) THEN
        next_element_count := element_p^.element_count;
        first_element_down_p := #PTR (element_p^.first_element_down_p, subproduct_info_seq_p^);
        add_ring_attributes (ring_attributes, next_element_count, first_element_down_p,
              subproduct_info_seq_p);
      IFEND;

      IF i < element_count THEN
        element_p := #PTR (element_p^.next_element_across_p, subproduct_info_seq_p^);
      IFEND;
    FOREND;

  PROCEND add_ring_attributes;

MODEND ram$define_ring_attributes;
*DECK DECK=RAM$DEFINE_SCF EXPAND=TRUE
PROC rap$define_scf (
  status)


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"   This request defines SCF.
*IFEND


    create_variable command_file k=string v='$local.'//$unique
    create_variable ignore_status k=status
    create_variable local_status k=status


  collect_text $fname(command_file) until='  collect_end'
    $system.osf$command_library.manage_network_applications
      define_client client=osa$status_control_fac_client protocol=cdna_session
        change_connection_priority connection_priority=5
        change_maximum_connections mc=20
        change_client_validation sp=true
        change_application_identifier ai=2002
      end_define_client
      activate_client client=osa$status_control_fac_client
    quit
  collect_end

  include_file $fname(command_file) status=local_status
  detach_file $fname(command_file) status=ignore_status

  IF local_status.normal THEN
    put_line ' SCF application is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$define_scf
*DECK DECK=RAM$DEFINE_SCFS EXPAND=TRUE
PROC rap$define_scfs (
  application_name, an: name
  status)


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"   This request defines SCFS.
*IFEND


    create_variable command_file k=string v='$local.'//$unique
    create_variable ignore_status k=status
    create_variable local_status k=status


  application_name = 'osa$status_control_fac_server'

  IF $specified(application_name) THEN
    application_name = $string($value(application_name))
    IF (application_name = 'OSA$STATUS_CONTROL_FAC_SERVER') OR ..
          (application_name = 'STATION_CONTROLLER_1') OR ..
          (application_name = 'SCF_SERVER') THEN
      EXIT_PROC WITH $status(false, 'RA', rae$defaults_specified, 'APPLICATION_NAME')
    IFEND
  IFEND

  collect_text $fname(command_file) until='  collect_end' sm='?'
    $system.osf$command_library.manage_network_applications
      define_server server=?application_name? protocol=cdna_session nam_initiated=false
        change_connection_priority connection_priority=5
        change_maximum_connections mc=100
        change_accept_connection ac=false
        change_server_validation sp=true
        add_server_managed_titles tp='SCF[AS]$*'
        add_client_address si=nosve ai=2002
        add_client_address si=nosve ai=2003
        add_client_address si=nosve ai=2004
        add_client_address si=nosve ai=2005
        add_client_address si=cdcnet ai=all
      end_define_server
      activate_server server=?application_name?
    quit
  collect_end

  include_file $fname(command_file) status=local_status
  detach_file $fname(command_file) status=ignore_status

  IF local_status.normal THEN
    put_line ' SCFS application is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$define_scfs
*DECK DECK=RAM$DEFINE_STORAGE_CLASS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'DEFINE_SUBPRODUCT Subutility: DEFINE_STORAGE_CLASS subcommand.' ??
MODULE ram$define_storage_class;

{ PURPOSE:
{   This module defines each or all of the storage_class fields in the element_list.
{
{ DESIGN:
{   The element list is searched for the correct file using locate_element.  Then
{   the correction_format field is updated.  If ALL elements are selected,
{   all files in the element list are updated.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc cld$path_description
*copyc fst$file_reference
*copyc ost$status
*copyc rae$package_software_cc
*copyc rat$subproduct_info_p
*copyc rat$subproduct_info_types
?? POP ??
*copyc clp$scan_parameter_list
*copyc clp$get_value
*copyc osp$append_status_file
*copyc osp$set_status_abnormal
*copyc rap$get_file_path_and_ref
*copyc rap$locate_element
*copyc rav$subproduct_info_pointers
*copyc rav$pacs_catalog_p
*copyc rav$pacs_catalog_ref_p
*copyc rav$defs_scratch_segment

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$define_storage_class', EJECT ??

{ PURPOSE:
{   This command interface sets the storage_class field for a
{   file or all files in the current subproduct.
{
{ DESIGN:
{   The file is validated as part of the current subproduct.
{   The file is located in the element_list and its storage class
{   is updated.  If ALL elements are selected, all files in the
{   element list are updated.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$define_storage_class
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  pdt defsc_pdt (
{    file, files, f    : file or key all = all
{    storage_class, sc : key service_critical_product, product, user_permanen..
{ t_files = $required
{    status            : var of status = $optional
{    )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    defsc_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
  ^defsc_pdt_names, ^defsc_pdt_params];

  VAR
    defsc_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6]
  of clt$parameter_name_descriptor := [['FILE', 1], ['FILES', 1], ['F', 1], [
  'STORAGE_CLASS', 2], ['SC', 2], ['STATUS', 3]];

  VAR
    defsc_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
  clt$parameter_descriptor := [

{ FILE FILES F }
    [[clc$optional_with_default, ^defsc_pdt_dv1], 1, 1, 1, 1,
  clc$value_range_not_allowed, [^defsc_pdt_kv1, clc$file_value]],

{ STORAGE_CLASS SC }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^defsc_pdt_kv2,
  clc$keyword_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

  VAR
    defsc_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1
  ] of ost$name := ['ALL'];

  VAR
    defsc_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3
  ] of ost$name := ['SERVICE_CRITICAL_PRODUCT','PRODUCT','USER_PERMANENT_FILES'
  ];

  VAR
    defsc_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) :=
      'all';

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      attributes_p: ^rat$subproduct_attributes,
      element_found: boolean,
      element_p: ^rat$element,
      path_index: integer,
      path_p: ^pft$path,
      path_ref_p: ^fst$file_reference,
      storage_class: rmt$mass_storage_class,
      subproduct_info_seq_p: ^rat$subproduct_info_sequence,
      value: clt$value;

    status.normal := TRUE;
    attributes_p := rav$subproduct_info_pointers.attributes_p;
    element_p := rav$subproduct_info_pointers.element_list_p;
    subproduct_info_seq_p := rav$subproduct_info_pointers.subproduct_info_seq_p;

    IF attributes_p^.first_level_element_count = 0 THEN
      osp$set_status_abnormal ('RA', rae$error_pacs_catalog_empty, '', status);
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, defsc_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('STORAGE_CLASS', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.name.value (1, value.name.size) = 'PRODUCT' THEN
      storage_class := rmc$msc_product_files;
    ELSEIF value.name.value (1, value.name.size) = 'USER_PERMANENT_FILES' THEN
      storage_class := rmc$msc_user_permanent_files;
    ELSE {service critical product}
      storage_class := rmc$msc_system_permanent_files;
    IFEND;

    clp$get_value ('FILE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.kind = clc$file_value THEN

      RESET rav$defs_scratch_segment.sequence_p TO rav$defs_scratch_segment.reset_p;

      rap$get_file_path_and_ref ('FILE', rav$defs_scratch_segment.sequence_p, path_p, path_ref_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (#SIZE (path_ref_p^) < #SIZE (rav$pacs_catalog_ref_p^)) OR
            (rav$pacs_catalog_ref_p^ <> path_ref_p^ (1, #SIZE (rav$pacs_catalog_ref_p^))) THEN
        osp$set_status_abnormal ('RA', rae$not_in_pacs_catalog, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, path_ref_p^, status);
        RETURN;
      IFEND;

      path_index := UPPERBOUND (rav$pacs_catalog_p^) + 1;

      rap$locate_element (path_p, path_index, subproduct_info_seq_p, element_p, element_found);

      IF NOT element_found THEN
        osp$set_status_abnormal ('RA', rae$not_in_pacs_catalog, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, path_ref_p^, status);
        RETURN;
      IFEND;

      IF element_p^.element_type = rac$file THEN
        add_storage_class (storage_class, 1, element_p, attributes_p, subproduct_info_seq_p);
      ELSE
        osp$set_status_abnormal ('RA', rae$expecting_file, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, path_ref_p^, status);
        RETURN;
      IFEND;

    ELSE {ALL}

      add_storage_class (storage_class, attributes_p^.first_level_element_count, element_p,
            attributes_p, subproduct_info_seq_p);
    IFEND;

  PROCEND rap$define_storage_class;

?? TITLE := 'add_storage_class', EJECT ??

{ PURPOSE:
{   This procedure sets the storage_class field for a file
{   or all files in the element_list.
{
{ DESIGN:
{   This procedure is given an element pointer and the number of elements in that
{   element.  If the element is of type FILE, then only that one element will be updated.
{   If the element is of type CATALOG, all files in the catalog will be updated as well
{   as all files in all of the subcatalogs.
{
{ NOTES:
{

  PROCEDURE add_storage_class
    (    storage_class: rmt$mass_storage_class;
         element_count: rat$element_count;
     VAR element_p: {input/output} ^rat$element;
     VAR attributes_p: {input/output} ^rat$subproduct_attributes;
     VAR subproduct_info_seq_p: {input/output} ^rat$subproduct_info_sequence);


    VAR
      i: rat$path_container_index,
      next_element_count: rat$element_count,
      first_element_down_p: ^rat$element;


    FOR i := 1 TO element_count DO

      IF element_p^.element_type = rac$file THEN

        IF element_p^.storage_class <> storage_class THEN

          IF storage_class = rmc$msc_product_files THEN
            attributes_p^.product_file_size := attributes_p^.product_file_size + element_p^.size;
            IF (attributes_p^.service_critical_file_size - element_p^.size) > 0 THEN
              attributes_p^.service_critical_file_size := attributes_p^.service_critical_file_size -
                    element_p^.size;
            ELSE
              attributes_p^.service_critical_file_size := 0;
            IFEND;
            IF (attributes_p^.user_permanent_file_size - element_p^.size) > 0 THEN
              attributes_p^.user_permanent_file_size := attributes_p^.user_permanent_file_size -
                    element_p^.size;
            ELSE
              attributes_p^.user_permanent_file_size := 0;
            IFEND;
          ELSEIF storage_class = rmc$msc_user_permanent_files THEN
            attributes_p^.user_permanent_file_size := attributes_p^.user_permanent_file_size +
                  element_p^.size;
            IF (attributes_p^.service_critical_file_size - element_p^.size) > 0 THEN
              attributes_p^.service_critical_file_size := attributes_p^.service_critical_file_size -
                    element_p^.size;
            ELSE
              attributes_p^.service_critical_file_size := 0;
            IFEND;
            IF (attributes_p^.product_file_size - element_p^.size) > 0 THEN
              attributes_p^.product_file_size := attributes_p^.product_file_size - element_p^.size;
            ELSE
              attributes_p^.product_file_size := 0;
            IFEND;
          ELSE
            IF (attributes_p^.product_file_size - element_p^.size) > 0 THEN
              attributes_p^.product_file_size := attributes_p^.product_file_size - element_p^.size;
            ELSE
              attributes_p^.product_file_size := 0;
            IFEND;
            IF (attributes_p^.user_permanent_file_size - element_p^.size) > 0 THEN
              attributes_p^.user_permanent_file_size := attributes_p^.user_permanent_file_size -
                    element_p^.size;
            ELSE
              attributes_p^.user_permanent_file_size := 0;
            IFEND;
            attributes_p^.service_critical_file_size := attributes_p^.service_critical_file_size +
                  element_p^.size;
          IFEND;

        IFEND;

        element_p^.storage_class := storage_class;

      ELSEIF (element_p^.element_type = rac$catalog) AND (element_p^.element_count <> 0) THEN
        next_element_count := element_p^.element_count;
        first_element_down_p := #PTR (element_p^.first_element_down_p, subproduct_info_seq_p^);
        add_storage_class (storage_class, next_element_count, first_element_down_p, attributes_p,
              subproduct_info_seq_p);
      IFEND;

      IF i < element_count THEN
        element_p := #PTR (element_p^.next_element_across_p, subproduct_info_seq_p^);
      IFEND;
    FOREND;

  PROCEND add_storage_class;

MODEND ram$define_storage_class;
*DECK DECK=RAM$DEFINE_SUBPRODUCT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: DEFINE_SUBPRODUCT Subutility Command.' ??
MODULE ram$define_subproduct;

{ PURPOSE:
{   This module invokes the DEFINE_SUBPRODUCT utility.
{
{ DESIGN:
{   This module creates a sequence in memory and sets pointers to
{   the sequence for the info header, subproduct attributes and the element list.
{   Then the info header, subproduct attributes and element list are initialized
{   to their default values.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$pacs_processor_version
*copyc rac$sif_file_name
*copyc rac$subproduct_info_level
*copyc cld$path_description
*copyc rae$package_software_cc
*copyc rat$subproduct_info_pointers
*copyc rat$scratch_segment
*copyc rat$sequence_descriptor_types
*copyc rat$subproduct_info_types
?? POP ??
*copyc amp$get_file_attributes
*copyc clp$get_value
*copyc clp$include_line
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$scan_command_file
*copyc clp$scan_parameter_list
*copyc fsp$close_file
*copyc fsp$open_file
*copyc mmp$create_scratch_segment
*copyc mmp$create_segment
*copyc mmp$delete_scratch_segment
*copyc mmp$delete_segment
*copyc osp$append_status_parameter
*copyc osp$append_status_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pfp$purge
*copyc pmp$get_compact_date_time
*copyc rap$add_correction_format
*copyc rap$add_name_to_path_ref
*copyc rap$create_element_list
*copyc osp$generate_error_message
*copyc rap$get_file_path_and_ref

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    rav$defs_utility_name: [XDCL] ost$name := 'DEFINE_SUBPRODUCT';

  VAR
    rav$pacs_catalog_p: [XDCL] ^pft$path;

  VAR
    rav$pacs_catalog_ref_p: [XDCL] ^fst$file_reference;

  VAR
    rav$subproduct_info_pointers: [XDCL] rat$subproduct_info_pointers;

  VAR
    rav$defs_scratch_segment: [XDCL] rat$scratch_segment;

?? TITLE := '[XDCL] rap$define_subproduct', EJECT ??

{ PURPOSE:
{   This procedure creates a sequence in memory and sets pointers to
{   the sequence for the info header, subproduct attributes and the element list.
{   Then the info header, subprodcut attributes and element list are initialized
{   to their default values.
{
{ DESIGN:
{   The PACS catalog is tested for the existence of a SIF file.  This procedure
{   will abort with an error message if one exists.
{   Then the SIF is initialized with values from the PACS catalog.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$define_subproduct
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt defs_pdt (
{   name, n              : name = $required
{   pacs_catalog, pc     : file = $required
{   type, t              : key release, correction = $required
{   disable_checksums ..
{   disable_checksum, dc :boolean = false
{   status               : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    defs_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^defs_pdt_names, ^defs_pdt_params];

  VAR
    defs_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 10] of
      clt$parameter_name_descriptor := [['NAME', 1], ['N', 1], ['PACS_CATALOG', 2], ['PC', 2], ['TYPE', 3], [
      'T', 3], ['DISABLE_CHECKSUMS', 4], ['DISABLE_CHECKSUM', 4], ['DC', 4], ['STATUS', 5]];

  VAR
    defs_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of clt$parameter_descriptor := [

{ NAME N }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ PACS_CATALOG PC }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ TYPE T }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^defs_pdt_kv3, clc$keyword_value]],

{ DISABLE_CHECKSUMS DISABLE_CHECKSUM DC }
    [[clc$optional_with_default, ^defs_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$boolean_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    defs_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := ['RELEASE',
      'CORRECTION'];

  VAR
    defs_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';

?? POP ??

{ table n=defs_command_table t=command s=xdcl
{ command n=(define_catalog_permit, define_catalog_permits, defcp) p=rap$define_catalog_permit cm=xref
{ command n=(define_correction_format, define_correction_formats, defcf) p=rap$define_correction_format    ..
{                               cm=xref
{ command n=(define_file_permit, define_file_permits, deffp) p=rap$define_file_permit cm=xref
{ command n=(define_library_merge, deflm) p=rap$define_library_merge cm=xref a=hidden
{ command n=(define_psrs_answered, define_psr_answered, defpa) p=rap$define_psrs_answered cm=xref
{ command n=(define_ring_attributes, define_ring_attribute, defra) p=rap$define_ring_attributes cm=xref
{ command n=(define_storage_class, define_storage_classes, defsc) p=rap$define_storage_class cm=xref
{ command n=(define_subproduct_attributes, defsa) p=rap$define_subproduct_attrib cm=xref
{ command n=(display_subproduct, diss) p=rap$display_subproduct cm=xref
{ command n=(quit, qui) p=rap$quit_defs cm=xref
{ tablend

?? PUSH (LISTEXT := ON) ??
VAR
  defs_command_table: [XDCL, READ] ^clt$command_table := ^defs_command_table_entries,

  defs_command_table_entries: [STATIC, READ] array [1 .. 26] of  clt$command_table_entry := [
  {} ['DEFCF                          ', clc$abbreviation_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rap$define_correction_format],
  {} ['DEFCP                          ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rap$define_catalog_permit],
  {} ['DEFFP                          ', clc$abbreviation_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$define_file_permit],
  {} ['DEFINE_CATALOG_PERMIT          ', clc$nominal_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rap$define_catalog_permit],
  {} ['DEFINE_CATALOG_PERMITS         ', clc$alias_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rap$define_catalog_permit],
  {} ['DEFINE_CORRECTION_FORMAT       ', clc$nominal_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rap$define_correction_format],
  {} ['DEFINE_CORRECTION_FORMATS      ', clc$alias_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rap$define_correction_format],
  {} ['DEFINE_FILE_PERMIT             ', clc$nominal_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$define_file_permit],
  {} ['DEFINE_FILE_PERMITS            ', clc$alias_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$define_file_permit],
  {} ['DEFINE_LIBRARY_MERGE           ', clc$nominal_entry, clc$hidden_entry, 4, clc$automatically_log,
         clc$linked_call, ^rap$define_library_merge],
  {} ['DEFINE_PSRS_ANSWERED           ', clc$nominal_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^rap$define_psrs_answered],
  {} ['DEFINE_PSR_ANSWERED            ', clc$alias_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^rap$define_psrs_answered],
  {} ['DEFINE_RING_ATTRIBUTE          ', clc$alias_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^rap$define_ring_attributes],
  {} ['DEFINE_RING_ATTRIBUTES         ', clc$nominal_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^rap$define_ring_attributes],
  {} ['DEFINE_STORAGE_CLASS           ', clc$nominal_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^rap$define_storage_class],
  {} ['DEFINE_STORAGE_CLASSES         ', clc$alias_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^rap$define_storage_class],
  {} ['DEFINE_SUBPRODUCT_ATTRIBUTES   ', clc$nominal_entry, clc$advertised_entry, 8,
        clc$automatically_log, clc$linked_call, ^rap$define_subproduct_attrib],
  {} ['DEFLM                          ', clc$abbreviation_entry, clc$hidden_entry, 4,
        clc$automatically_log, clc$linked_call, ^rap$define_library_merge],
  {} ['DEFPA                          ', clc$abbreviation_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^rap$define_psrs_answered],
  {} ['DEFRA                          ', clc$abbreviation_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^rap$define_ring_attributes],
  {} ['DEFSA                          ', clc$abbreviation_entry, clc$advertised_entry, 8,
        clc$automatically_log, clc$linked_call, ^rap$define_subproduct_attrib],
  {} ['DEFSC                          ', clc$abbreviation_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^rap$define_storage_class],
  {} ['DISPLAY_SUBPRODUCT             ', clc$nominal_entry, clc$advertised_entry, 9,
        clc$automatically_log, clc$linked_call, ^rap$display_subproduct],
  {} ['DISS                           ', clc$abbreviation_entry, clc$advertised_entry, 9,
        clc$automatically_log, clc$linked_call, ^rap$display_subproduct],
  {} ['QUI                            ', clc$abbreviation_entry, clc$advertised_entry, 10,
        clc$automatically_log, clc$linked_call, ^rap$quit_defs],
  {} ['QUIT                           ', clc$nominal_entry, clc$advertised_entry, 10,
        clc$automatically_log, clc$linked_call, ^rap$quit_defs]];

  PROCEDURE [XREF] rap$define_catalog_permit (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$define_correction_format (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$define_file_permit (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$define_library_merge (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$define_psrs_answered (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$define_ring_attributes (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$define_storage_class (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$define_subproduct_attrib (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$display_subproduct (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$quit_defs (parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? POP ??


    VAR
      info_segment_pointer: mmt$segment_pointer,
      first_element_p: ^rat$element,
      local_status: ost$status,
      scratch_segment_pointer: amt$segment_pointer,
      sif_present: boolean;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF info_segment_pointer.seq_pointer <> NIL THEN
        mmp$delete_segment (info_segment_pointer, 1, ignore_status);
        info_segment_pointer.seq_pointer := NIL;
      IFEND;

      IF scratch_segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (scratch_segment_pointer, ignore_status);
        scratch_segment_pointer.sequence_pointer := NIL;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, defs_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    info_segment_pointer.kind := mmc$sequence_pointer;
    info_segment_pointer.seq_pointer := NIL;
    scratch_segment_pointer.kind := amc$sequence_pointer;
    scratch_segment_pointer.sequence_pointer := NIL;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      mmp$create_segment (NIL, mmc$sequence_pointer, 1, info_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, scratch_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      rav$defs_scratch_segment.sequence_p := scratch_segment_pointer.sequence_pointer;
      RESET rav$defs_scratch_segment.sequence_p;

      rap$get_file_path_and_ref ('PACS_CATALOG', rav$defs_scratch_segment.sequence_p, rav$pacs_catalog_p,
            rav$pacs_catalog_ref_p, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF rav$pacs_catalog_p^ [1] = '$LOCAL' THEN
        osp$set_status_abnormal ('RA', rae$cannot_use_local_catalog, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, 'PACS CATALOG', status);
        RETURN;
      IFEND;

      NEXT rav$defs_scratch_segment.reset_p IN rav$defs_scratch_segment.sequence_p;

      test_pacs_catalog_for_sif (rav$pacs_catalog_ref_p, rav$pacs_catalog_p, sif_present, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF sif_present THEN
        osp$set_status_abnormal ('RA', rae$pacs_catalog_contains_sif, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, rav$pacs_catalog_ref_p^, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, rac$sif_file_name, status);
        EXIT /main/;
      IFEND;

      initialize_info_sequence (rav$pacs_catalog_ref_p, rav$pacs_catalog_p, info_segment_pointer,
            rav$subproduct_info_pointers, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF rav$subproduct_info_pointers.attributes_p^.subproduct_type = rac$correction THEN
        first_element_p := rav$subproduct_info_pointers.element_list_p;
        rap$add_correction_format (rac$replacement, rav$subproduct_info_pointers.attributes_p^.
              first_level_element_count, first_element_p, rav$subproduct_info_pointers.subproduct_info_seq_p);
      IFEND;

      clp$push_utility (rav$defs_utility_name, clc$global_command_search, defs_command_table, NIL, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      clp$scan_command_file (clc$current_command_input, rav$defs_utility_name, 'DEFS', status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      clp$pop_utility (status);

    END /main/;

    IF info_segment_pointer.seq_pointer <> NIL THEN
      mmp$delete_segment (info_segment_pointer, 1, local_status);
      info_segment_pointer.seq_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF scratch_segment_pointer.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (scratch_segment_pointer, local_status);
      scratch_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$define_subproduct;

?? TITLE := 'initialize_info_sequence', EJECT ??

{ PURPOSE:
{   This procedure sets the initial values in the subproduct
{   attributes record and element list.
{
{ DESIGN:
{   This procedure sets the name and type fields in the
{   subproduct attributes record and calls a procedure to
{   create the element list.
{
{ NOTES:
{
{

  PROCEDURE initialize_info_sequence
    (    pacs_catalog_ref_p: ^fst$file_reference;
         pacs_catalog_path_p: ^pft$path;
     VAR info_segment_pointer: mmt$segment_pointer;
     VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      attributes_p: ^rat$subproduct_attributes,
      checksum_files: boolean,
      ignore_status: ost$status,
      message_status: ost$status,
      subproduct_type: ost$name,
      validation_errors: boolean,
      validation_selections: rat$validation_selections,
      value: clt$value;


    status.normal := TRUE;

    initialize_sequence_records (info_segment_pointer, subproduct_info_pointers, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    attributes_p := subproduct_info_pointers.attributes_p;

    clp$get_value ('NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    attributes_p^.name := value.name.value (1, value.name.size);

    clp$get_value ('TYPE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    subproduct_type := value.name.value (1, value.name.size);

    IF subproduct_type = 'RELEASE' THEN
      attributes_p^.subproduct_type := rac$release;
    ELSE { subproduct_type = 'CORRECTION' }
      attributes_p^.subproduct_type := rac$correction;
    IFEND;

    validation_selections := $rat$validation_selections [rac$loading_cycle_only, rac$no_rings_below_11,
          rac$no_permits];

    clp$get_value ('DISABLE_CHECKSUMS', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    attributes_p^.calculate_contents_checksum := NOT value.bool.value;
    attributes_p^.pacs_catalog_path.path := '';
    attributes_p^.pacs_catalog_path.path := pacs_catalog_ref_p^;
    attributes_p^.pacs_catalog_path.size := #SIZE (pacs_catalog_ref_p^);

    rap$create_element_list (pacs_catalog_ref_p, pacs_catalog_path_p^, validation_selections,
           FALSE, validation_errors, subproduct_info_pointers, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF validation_errors THEN
      osp$set_status_abnormal ('RA', rae$invalid_pacs_catalog, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, pacs_catalog_ref_p^, status);
      RETURN;
    IFEND;

    IF subproduct_info_pointers.attributes_p^.first_level_element_count = 0 THEN
      osp$set_status_abnormal ('RA', rae$warn_pacs_catalog_empty, '', message_status);
      osp$generate_error_message (message_status, ignore_status);
      RETURN;
    IFEND;


  PROCEND initialize_info_sequence;

?? TITLE := 'test_pacs_catalog_for_sif', EJECT ??

{ PURPOSE:
{   This procedure determines if the SIF file already exists.
{
{ DESIGN:
{   AMP$GET_FILE_ATTRIBUTES is used to determine if the SIF file exists.
{
{ NOTES:
{
{

  PROCEDURE test_pacs_catalog_for_sif
    (    pacs_catalog_ref_p: ^fst$file_reference;
         pacs_catalog_p: ^pft$path;
     VAR sif_present: boolean;
     VAR status: ost$status);

    VAR
      cycle_selector: pft$cycle_selector,
      existing_file: boolean,
      i: pft$array_index,
      ignore_attributes: array [1 .. 1] of amt$get_item,
      ignore_contains_data: boolean,
      local_file: boolean,
      local_status: ost$status,
      password: pft$password,
      sif_fid: amt$file_identifier,
      sif_path_p: ^pft$path,
      sif_reference_p: ^fst$file_reference,
      write_attachment: array [1 .. 2] of fst$attachment_option;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status,
        local_status: ost$status,
        sif_path_p: ^pft$path;

      fsp$close_file (sif_fid, local_status);
      IF local_status.normal THEN
        PUSH sif_path_p: [1 .. UPPERBOUND (pacs_catalog_p^) + 1];
        FOR i := 1 TO UPPERBOUND (pacs_catalog_p^) DO
          sif_path_p^ [i] := pacs_catalog_p^ [i];
        FOREND;
        sif_path_p^ [UPPERBOUND (sif_path_p^)] := rac$sif_file_name;
        pfp$purge (sif_path_p^, cycle_selector, password, ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    password := ' ';
    cycle_selector.cycle_option := pfc$lowest_cycle;

    rap$add_name_to_path_ref (pacs_catalog_ref_p, rac$sif_file_name, rav$defs_scratch_segment.sequence_p,
          sif_reference_p);

    ignore_attributes [1].key := amc$file_length;

    amp$get_file_attributes (sif_reference_p^, ignore_attributes, local_file, existing_file,
          ignore_contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sif_present := (local_file OR existing_file);

  IF NOT sif_present THEN

    write_attachment [1].selector := fsc$access_and_share_modes;
    write_attachment [1].access_modes.selector := fsc$specific_access_modes;
    write_attachment [1].access_modes.value := $fst$file_access_options
          [fsc$read, fsc$shorten, fsc$append, fsc$modify];
    write_attachment [1].share_modes.selector := fsc$determine_from_access_modes;
    write_attachment [2].selector := fsc$create_file;
    write_attachment [2].create_file := TRUE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /open_file/
    BEGIN
      fsp$open_file (sif_reference_p^, amc$segment, ^write_attachment, NIL, NIL, NIL, NIL, sif_fid, status);
      IF NOT status.normal THEN
        EXIT /open_file/;
      IFEND;
    END /open_file/;

    fsp$close_file (sif_fid, local_status);
    IF local_status.normal THEN
      PUSH sif_path_p: [1 .. UPPERBOUND (pacs_catalog_p^) + 1];
      FOR i := 1 TO UPPERBOUND (pacs_catalog_p^) DO
        sif_path_p^ [i] := pacs_catalog_p^ [i];
      FOREND;
      sif_path_p^ [UPPERBOUND (sif_path_p^)] := rac$sif_file_name;
      pfp$purge (sif_path_p^, cycle_selector, password, local_status);
    IFEND;

    osp$disestablish_cond_handler;

  IFEND;

  PROCEND test_pacs_catalog_for_sif;

?? TITLE := 'initialize_sequence_records', EJECT ??

{ PURPOSE:
{   This procedure creates the sequence_descriptor_p, the info_header_p,
{   subproduct_attributes_p and the element_list_p and sets all of their
{   initial values.
{
{ DESIGN:
{   The sequence_descriptor_p, info_header_p, subproduct_attributes_p and
{   element_list_p are NEXT'd on subproduct_info_seq_p.  The values of the
{   relative pointers to the attributes_p and the element_list_p are saved
{   in the info_header record.
{   The value of the subproduct_info_pointers is initialized.
{
{ NOTES:
{
{

  PROCEDURE initialize_sequence_records
    (VAR info_segment_pointer: mmt$segment_pointer;
     VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      element_list_p: ^rat$element,
      i: 1 .. rac$max_additional_products,
      info_header_p: ^rat$subproduct_info_header,
      length: integer,
      sequence_descriptor_p: ^rat$sequence_descriptor,
      subproduct_attributes_p: ^rat$subproduct_attributes,
      subproduct_info_seq_p: ^rat$subproduct_info_sequence;


    status.normal := TRUE;

    subproduct_info_seq_p := info_segment_pointer.seq_pointer;
    RESET subproduct_info_seq_p;

    NEXT sequence_descriptor_p IN subproduct_info_seq_p;
    IF sequence_descriptor_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    NEXT info_header_p IN subproduct_info_seq_p;
    IF info_header_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    NEXT subproduct_attributes_p IN subproduct_info_seq_p;
    IF subproduct_attributes_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    NEXT element_list_p IN subproduct_info_seq_p;
    IF element_list_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    pmp$get_compact_date_time (sequence_descriptor_p^.sequence_creation_date_time, status );
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sequence_descriptor_p^.processor_version := rac$pacs_processor_version;
    sequence_descriptor_p^.sequence_level := rac$subproduct_info_level;
    sequence_descriptor_p^.sequence_type := rac$subproduct_info_sequence;

    info_header_p^.attributes_p := #REL (subproduct_attributes_p, subproduct_info_seq_p^);
    info_header_p^.element_list_p := #REL (element_list_p, subproduct_info_seq_p^);
    info_header_p^.path_container_length := 0;
    info_header_p^.path_container_p := NIL;
    info_header_p^.psrs_answered_count := 0;
    info_header_p^.psrs_answered_p := NIL;

    subproduct_attributes_p^.licensed_product := '';

    subproduct_info_pointers.sequence_descriptor_p := sequence_descriptor_p;
    subproduct_info_pointers.subproduct_info_seq_p := subproduct_info_seq_p;
    subproduct_info_pointers.info_header_p := info_header_p;
    subproduct_info_pointers.attributes_p := subproduct_attributes_p;
    subproduct_info_pointers.element_list_p := element_list_p;
    subproduct_info_pointers.path_container_p := NIL;
    subproduct_info_pointers.psrs_answered_p := NIL;

  PROCEND initialize_sequence_records;

MODEND ram$define_subproduct;
*DECK DECK=RAM$DEFINE_SUBPRODUCT_ATTRIB EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'DEFINE_SUBPRODUCT Subutility: DEFINE_SUBPRODUCT_ATTRIBUTES Subcommand.' ??
MODULE ram$define_subproduct_attrib;

{ PURPOSE:
{   This module contains the procedures that define and validate the
{   subproduct attributes.
{
{ DESIGN:
{   The procedures in this module process the parameters on DEFINE_SUBPRODUCT_ATTRIBUTES
{   to create a completed subproduct_attriubtes record.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$subproduct_info_level
*copyc rae$package_software_cc
*copyc rat$sequence_descriptor_types
*copyc rat$subproduct_info_types
?? POP ??
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_string_to_integer
*copyc clp$get_fs_path_elements
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$include_command
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc clp$trimmed_string_size
*copyc fsp$convert_fs_structure_to_pf
*copyc osp$append_status_file
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc osp$generate_error_message
*copyc pmp$get_unique_name
*copyc rap$get_file_path_and_ref
*copyc rav$subproduct_info_pointers
*copyc rav$pacs_catalog_p
*copyc rav$defs_scratch_segment
*copyc rav$installation_path_option
*copyc rav$installation_scheme

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$define_subproduct_attrib', EJECT ??

{ PURPOSE:
{   This procedure updates the values in the subproduct attributes record.
{
{ DESIGN:
{   The subproduct attributes record is initialize then each of the parameters
{   is processed.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$define_subproduct_attrib
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt defsa_pdt (
{   description, d                       : string 1..50 = $required
{   installation_scheme, is              : key cycle_based, catalog_based, version_based = $required
{   level, l                             : name = $required
{   licensed_product, lp                 : name = $required
{   subproduct_installation_path, sip    : file = $required
{   additional_products, ..
{   additional_product, ap               : list 1..5 of name or key none = none
{   auto_install, ai                     : boolean = true
{   correction_base_level, cbl           : name = $optional
{   date_level, dl                       : string 7 = $date(ordinal)
{   development_group, dg                : string 1..31 = $optional
{   hidden, h                            : boolean = false
{   installation_path_option, ipo        : key definable_master_catalog, definable_family_name, ..
{                                              definable_user_name, not_definable = not_definable
{   installer_procedure, ip              : file or key none = none
{   primary_subproduct, ps               : boolean = false
{   product_dependencies, ..
{   product_dependency, pd               : list 1..5 of name or key none = none
{   stamp_files, sf                      : boolean = false
{   internal_level                       : name = $optional
{   subproduct_priority                  : key installation_tools, high, low, medium = low
{   status                               : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    defsa_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^defsa_pdt_names, ^defsa_pdt_params
  ];

  VAR
    defsa_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 37] of
  clt$parameter_name_descriptor := [['DESCRIPTION', 1], ['D', 1], ['INSTALLATION_SCHEME', 2], ['IS', 2], [
  'LEVEL', 3], ['L', 3], ['LICENSED_PRODUCT', 4], ['LP', 4], ['SUBPRODUCT_INSTALLATION_PATH', 5], ['SIP', 5],
  ['ADDITIONAL_PRODUCTS', 6], ['ADDITIONAL_PRODUCT', 6], ['AP', 6], ['AUTO_INSTALL', 7], ['AI', 7], [
  'CORRECTION_BASE_LEVEL', 8], ['CBL', 8], ['DATE_LEVEL', 9], ['DL', 9], ['DEVELOPMENT_GROUP', 10], ['DG', 10]
  , ['HIDDEN', 11], ['H', 11], ['INSTALLATION_PATH_OPTION', 12], ['IPO', 12], ['INSTALLER_PROCEDURE', 13], [
  'IP', 13], ['PRIMARY_SUBPRODUCT', 14], ['PS', 14], ['PRODUCT_DEPENDENCIES', 15], ['PRODUCT_DEPENDENCY', 15]
  , ['PD', 15], ['STAMP_FILES', 16], ['SF', 16], ['INTERNAL_LEVEL', 17], ['SUBPRODUCT_PRIORITY', 18], [
  'STATUS', 19]];

  VAR
    defsa_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 19] of clt$parameter_descriptor := [

{ DESCRIPTION D }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 1, 50]],

{ INSTALLATION_SCHEME IS }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^defsa_pdt_kv2, clc$keyword_value]],

{ LEVEL L }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ LICENSED_PRODUCT LP }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ SUBPRODUCT_INSTALLATION_PATH SIP }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ ADDITIONAL_PRODUCTS ADDITIONAL_PRODUCT AP }
    [[clc$optional_with_default, ^defsa_pdt_dv6], 1, 5, 1, 1, clc$value_range_not_allowed, [^defsa_pdt_kv6,
  clc$name_value, 1, osc$max_name_size]],

{ AUTO_INSTALL AI }
    [[clc$optional_with_default, ^defsa_pdt_dv7], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ CORRECTION_BASE_LEVEL CBL }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ DATE_LEVEL DL }
    [[clc$optional_with_default, ^defsa_pdt_dv9], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$string_value, 7, 7]],

{ DEVELOPMENT_GROUP DG }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 1, 31]],

{ HIDDEN H }
    [[clc$optional_with_default, ^defsa_pdt_dv11], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ INSTALLATION_PATH_OPTION IPO }
    [[clc$optional_with_default, ^defsa_pdt_dv12], 1, 1, 1, 1, clc$value_range_not_allowed, [^defsa_pdt_kv12,
  clc$keyword_value]],

{ INSTALLER_PROCEDURE IP }
    [[clc$optional_with_default, ^defsa_pdt_dv13], 1, 1, 1, 1, clc$value_range_not_allowed, [^defsa_pdt_kv13,
  clc$file_value]],

{ PRIMARY_SUBPRODUCT PS }
    [[clc$optional_with_default, ^defsa_pdt_dv14], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ PRODUCT_DEPENDENCIES PRODUCT_DEPENDENCY PD }
    [[clc$optional_with_default, ^defsa_pdt_dv15], 1, 5, 1, 1, clc$value_range_not_allowed, [^defsa_pdt_kv15,
  clc$name_value, 1, osc$max_name_size]],

{ STAMP_FILES SF }
    [[clc$optional_with_default, ^defsa_pdt_dv16], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$boolean_value]],

{ INTERNAL_LEVEL }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ SUBPRODUCT_PRIORITY }
    [[clc$optional_with_default, ^defsa_pdt_dv18], 1, 1, 1, 1, clc$value_range_not_allowed, [^defsa_pdt_kv18,
  clc$keyword_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
  clc$array_not_allowed, clc$status_value]]];

  VAR
    defsa_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of ost$name := ['CYCLE_BASED',
  'CATALOG_BASED','VERSION_BASED'];

  VAR
    defsa_pdt_kv6: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['NONE'];

  VAR
    defsa_pdt_kv12: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := [
  'DEFINABLE_MASTER_CATALOG','DEFINABLE_FAMILY_NAME','DEFINABLE_USER_NAME','NOT_DEFINABLE'];

  VAR
    defsa_pdt_kv13: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['NONE'];

  VAR
    defsa_pdt_kv15: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['NONE'];

  VAR
    defsa_pdt_kv18: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := [
  'INSTALLATION_TOOLS','HIGH','LOW','MEDIUM'];

  VAR
    defsa_pdt_dv6: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'none';

  VAR
    defsa_pdt_dv7: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'true';

  VAR
    defsa_pdt_dv9: [STATIC, READ, cls$pdt_names_and_defaults] string (14) := '$date(ordinal)';

  VAR
    defsa_pdt_dv11: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';

  VAR
    defsa_pdt_dv12: [STATIC, READ, cls$pdt_names_and_defaults] string (13) := 'not_definable';

  VAR
    defsa_pdt_dv13: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'none';

  VAR
    defsa_pdt_dv14: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';

  VAR
    defsa_pdt_dv15: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'none';

  VAR
    defsa_pdt_dv16: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';

  VAR
    defsa_pdt_dv18: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'low';

?? POP ??

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, defsa_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (rav$subproduct_info_pointers.psrs_answered_p <> NIL) AND
      (rav$subproduct_info_pointers.path_container_p <> NIL) THEN
      osp$set_status_abnormal ('RA', rae$defsa_command_not_allowed, '', status);
      RETURN;
    IFEND;

    clear_subproduct_attributes (rav$subproduct_info_pointers);

    process_attributes (rav$subproduct_info_pointers, status);
    IF NOT status.normal THEN
      clear_subproduct_attributes (rav$subproduct_info_pointers);
      RETURN;
    IFEND;

  PROCEND rap$define_subproduct_attrib;

?? TITLE := 'clear_subproduct_attributes', EJECT ??

{ PURPOSE:
{   This procedure initializes the subproduct attributes.
{
{ DESIGN:
{   Each of the attributes is set to a null or default value.
{
{ NOTES:
{
{
  PROCEDURE clear_subproduct_attributes
    (VAR subproduct_info_pointers: rat$subproduct_info_pointers);


    VAR
      attributes_p: ^rat$subproduct_attributes,
      i: 0 .. rac$max_additional_products;


    attributes_p := subproduct_info_pointers.attributes_p;

    FOR i := 1 TO rac$max_additional_products DO
      attributes_p^.additional_products [i] := '';
    FOREND;

    FOR i := 1 TO rac$max_additional_products DO
      attributes_p^.dependencies [i] := '';
    FOREND;

    attributes_p^.auto_install := FALSE;
    attributes_p^.correction_base_level := '';
    attributes_p^.date_level := '';
    attributes_p^.description := '';
    attributes_p^.development_group := '';
    attributes_p^.files_stamped := FALSE;
    attributes_p^.hidden := FALSE;
    attributes_p^.internal_level := '';
    attributes_p^.level := '';
    attributes_p^.licensed_product := '';
    attributes_p^.installation_path_option := rac$not_definable;
    attributes_p^.installation_scheme := rac$cycle_based;
    attributes_p^.primary := FALSE;
    attributes_p^.correction_base_sif_identifier := '';
    attributes_p^.sif_identifier := '';
    attributes_p^.subproduct_priority := rac$low;

  PROCEND clear_subproduct_attributes;

?? TITLE := 'process_additional_products', EJECT ??

{ PURPOSE:
{   This procedure puts the names of the additional products
{   into the attributes.additional_products array.
{
{ DESIGN:
{   The number of additional products is determined and these names are
{   put into the additional_products field of the subproduct attributes record.
{
{ NOTES:
{
{

  PROCEDURE process_additional_products
    (VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      attributes_p: ^rat$subproduct_attributes,
      i: 0 .. clc$max_value_sets,
      set_count: 0 .. clc$max_value_sets,
      value: clt$value;


    status.normal := TRUE;
    attributes_p := subproduct_info_pointers.attributes_p;

    clp$get_set_count ('ADDITIONAL_PRODUCTS', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO set_count DO
      clp$get_value ('ADDITIONAL_PRODUCTS', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF value.name.value <> 'NONE' THEN
        attributes_p^.additional_products [i] := value.name.value;
      ELSEIF i > 1 THEN
        osp$set_status_abnormal ('RA', rae$invalid_product_name, 'NONE', status);
        RETURN;
      IFEND;
    FOREND;

    sort_additional_products (attributes_p^.additional_products);

  PROCEND process_additional_products;

?? TITLE := 'process_attributes', EJECT ??

{ PURPOSE:
{   Each of the subproduct attributes is entered in the
{   attributes record.
{
{ DESIGN:
{   The attributes are processed in the same order as they are listed in the
{   attributes record.  Most of the fields are order independent, but
{   INSTALLATION_PATH_OPTION must be processed before INSTALLATION_PATH must be
{   processed before INSTALLER_PROCEDURE and LICENSED_PRODUCT must be
{   processed before PRIMARY_SUBPRODUCT.
{ NOTES:
{
{

  PROCEDURE process_attributes
    (VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);

    VAR
      attributes_p: ^rat$subproduct_attributes,
      installation_path_option: ost$name,
      development_group_specified: boolean,
      sif_identifier: ost$name,
      test_integer: integer,
      value: clt$value;


    status.normal := TRUE;
    attributes_p := subproduct_info_pointers.attributes_p;

    clp$get_value ('LEVEL', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    attributes_p^.level := value.name.value;

    process_date_level (subproduct_info_pointers, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_internal_level (subproduct_info_pointers, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_subproduct_priority (subproduct_info_pointers, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_correction_base_level (subproduct_info_pointers, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DESCRIPTION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    attributes_p^.description := value.str.value (1, value.str.size);

    clp$get_value ('LICENSED_PRODUCT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    attributes_p^.licensed_product := value.name.value;

    process_additional_products (subproduct_info_pointers, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_primary_subproduct( subproduct_info_pointers, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_product_dependencies (subproduct_info_pointers, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('HIDDEN', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    attributes_p^.hidden := value.bool.value;

    clp$get_value ('AUTO_INSTALL', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    attributes_p^.auto_install := value.bool.value;

    process_installation_scheme (subproduct_info_pointers, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_installation_path_opt (subproduct_info_pointers, installation_path_option, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_installation_path (installation_path_option, subproduct_info_pointers, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    process_installer_procedure (rav$pacs_catalog_p^, subproduct_info_pointers, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$test_parameter ('DEVELOPMENT_GROUP', development_group_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF development_group_specified THEN
      clp$get_value ('DEVELOPMENT_GROUP', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #TRANSLATE (osv$lower_to_upper, value.str.value, attributes_p^.development_group);
    IFEND;

    pmp$get_unique_name (sif_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    attributes_p^.sif_identifier := sif_identifier;

  PROCEND process_attributes;

?? TITLE := 'process_correction_base_level', EJECT ??

{ PURPOSE:
{   This procedure sets the correction_base_level for subproduct attributes.
{
{ DESIGN:
{   Since this is an optional parameter, the procedure first determines if
{   the parameter has been specified.  If specified the correction_base_level is
{   set.  The correction_base_level must be specified if the subproduct_type
{   is rac$correction.  An error message occurs if the subproduct_type is
{   rac$correction and the correction_base_level is NOT set.
{
{ NOTES:
{
{

  PROCEDURE process_correction_base_level
    (VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      attributes_p: ^rat$subproduct_attributes,
      parameter_specified: boolean,
      value: clt$value;


    status.normal := TRUE;
    attributes_p := subproduct_info_pointers.attributes_p;

    clp$test_parameter ('CORRECTION_BASE_LEVEL', parameter_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter_specified THEN

      clp$get_value ('CORRECTION_BASE_LEVEL', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      attributes_p^.correction_base_level := value.name.value;

    ELSEIF attributes_p^.subproduct_type = rac$correction THEN

      osp$set_status_abnormal ('RA', rae$param_required_for_corr, 'CORRECTION_BASE_LEVEL', status);
      RETURN;

    IFEND;

  PROCEND process_correction_base_level;

?? TITLE := 'process_date_level', EJECT ??

{ PURPOSE:
{   This procedure process the date_level entered.
{
{ DESIGN:
{   The first four characters of the string must be and integer greater than
{   minimun year.  The last three digits of the string must be an integer
{   between 1 and the number of days in a year.
{
{ NOTES:
{
{

  PROCEDURE process_date_level
    (VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR

      attributes_p: ^rat$subproduct_attributes,
      days_in_year: [STATIC] integer := 366,
      year: [STATIC] integer := 1988,
      test_integer: clt$integer,
      value: clt$value;

    status.normal := TRUE;
    attributes_p := subproduct_info_pointers.attributes_p;

    clp$get_value ('DATE_LEVEL', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_string_to_integer (value.str.value (1, 4), test_integer, status);
    IF (NOT status.normal) OR (test_integer.value < year) THEN
      osp$set_status_abnormal ('RA', rae$invalid_date_level, value.str.value, status);
      RETURN;
    IFEND;

    clp$convert_string_to_integer (value.str.value (5, 3), test_integer, status);
    IF (NOT status.normal) OR (1 > test_integer.value) OR (test_integer.value > days_in_year) THEN
      osp$set_status_abnormal ('RA', rae$invalid_date_level, value.str.value, status);
      RETURN;
    IFEND;

    attributes_p^.date_level := value.str.value;

  PROCEND process_date_level;

?? TITLE := 'process_installation_path', EJECT ??

{ PURPOSE:
{   This procedure sets:
{        the installation_path.path_container_index to the next available path container.
{        the installation_path.path_length to the file length of the element.
{        For example, $SYSTEM.A.B.DDD.E has a length of 5.
{        the info_header_p.path_container_length to total length of all containers used.
{        the path_container_p^s are filled with the names of the installation path.  In the example above
{        path_container_p^ [i] = $SYSTEM
{        path_container_p^ [i + 1] = A
{        path_container_p^ [i + 2] = B
{        path_container_p^ [i + 3] = DDD
{        path_container_p^ [i + 4] = E
{
{ DESIGN:
{   The INSTALLATION_PATH cannot be $LOCAL.
{   The INSTALLATION_PATH can only have $UNDEFINED in the first or second containers.
{   The path_option attribute is validated against the first two path containers.
{   If the INSTALLATION_PATH contains a path_container_index greater than 0, it
{   has been previously defined.  If the new path is the same length as the old path,
{   the new path can use the old path's containers.
{
{   Else set the path_container_index to the next available index number.
{   The info_header_p^.path_container_index contains the value of the last used path container.
{   Set the value of the path_length to the uppervalue of the array that contains the path.
{   See example above to understand how the length of a path is determined.
{   The info_header.path_container_length is updated to point to the last used path container.
{   If the path container has not been created, it is created with a size large enough to hold this path.
{   Else the path_containers size is set to the size indicated in info_header.path_container_length.
{   Then the path_containers are filled with the path.
{
{ NOTES:
{
{

  PROCEDURE process_installation_path
    (    installation_path_option: ost$name;
     VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      attributes_p: ^rat$subproduct_attributes,
      i: rat$path_container_index,
      ignore_status: ost$status,
      index: rat$path_container_index,
      info_header_p: ^rat$subproduct_info_header,
      installation_path_p: ^pft$path,
      installation_path_ref_p: ^fst$file_reference,
      length: integer,
      local_status: ost$status,
      master_catalog: string (osc$max_name_size * 2 + 2),
      path_container_p: ^rat$path_container,
      path_option: rat$installation_path_option,
      subproduct_info_seq_p: ^rat$subproduct_info_sequence,
      value: clt$value;


    status.normal := TRUE;
    attributes_p := subproduct_info_pointers.attributes_p;
    info_header_p := subproduct_info_pointers.info_header_p;
    subproduct_info_seq_p := subproduct_info_pointers.subproduct_info_seq_p;
    path_container_p := subproduct_info_pointers.path_container_p;

    clp$get_value ('SUBPRODUCT_INSTALLATION_PATH', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET rav$defs_scratch_segment.sequence_p TO rav$defs_scratch_segment.reset_p;

    rap$get_file_path_and_ref ('SUBPRODUCT_INSTALLATION_PATH', rav$defs_scratch_segment.sequence_p,
          installation_path_p, installation_path_ref_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF installation_path_p^ [1] = '$LOCAL' THEN
      osp$set_status_abnormal ('RA', rae$cannot_use_local_catalog, 'INSTALLATION_PATH', status);
      RETURN;
    IFEND;

    FOR i := 3 TO UPPERBOUND (installation_path_p^) DO
      IF installation_path_p^ [i] = '$UNDEFINED' THEN
        osp$set_status_abnormal ('RA', rae$invalid_installation_path, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, installation_path_ref_p^, status);
        RETURN;
      IFEND;
    FOREND;

    path_option := attributes_p^.installation_path_option;
    IF ((installation_path_p^ [1] = '$UNDEFINED') AND ((path_option = rac$definable_user_name) OR
          (path_option = rac$not_definable))) OR ((installation_path_p^ [2] = '$UNDEFINED') AND
          ((path_option = rac$definable_family_name) OR (path_option = rac$not_definable))) THEN
      osp$set_status_abnormal ('RA', rae$invalid_inst_path_with_opt, installation_path_option, status);
      osp$append_status_file (osc$status_parameter_delimiter, installation_path_ref_p^, status);
      RETURN;
    IFEND;

    IF (installation_path_p^ [1] <> '$SYSTEM') AND (installation_path_p^ [1] <> '$UNDEFINED') AND
          (installation_path_p^ [2] <> '$SYSTEM') AND (installation_path_p^ [2] <> '$UNDEFINED') THEN
      STRINGREP (master_catalog, length, ':', installation_path_p^
            [1] (1, clp$trimmed_string_size (installation_path_p^ [1])), '.', installation_path_p^ [2]
            (1, clp$trimmed_string_size (installation_path_p^ [2])));
      osp$set_status_abnormal ('RA', rae$non_standard_master_catalog, master_catalog (1, length),
            local_status);
      osp$generate_error_message (local_status, ignore_status);
    IFEND;

    IF (attributes_p^.installation_path.path_container_index <> 0) AND
          (attributes_p^.installation_path.path_length = UPPERBOUND (installation_path_p^)) THEN
      index := attributes_p^.installation_path.path_container_index;
      FOR i := LOWERBOUND (installation_path_p^) TO UPPERBOUND (installation_path_p^) DO
        path_container_p^ [index] := installation_path_p^ [i];
        index := index + 1;
      FOREND;
    ELSE
      attributes_p^.installation_path.path_container_index := info_header_p^.path_container_length + 1;
      attributes_p^.installation_path.path_length := UPPERBOUND (installation_path_p^);
      info_header_p^.path_container_length := info_header_p^.path_container_length +
            attributes_p^.installation_path.path_length;

      IF path_container_p = NIL THEN
        NEXT path_container_p: [1 .. info_header_p^.path_container_length] IN subproduct_info_seq_p;
        path_container_p^ := installation_path_p^;
      ELSE
        RESET subproduct_info_seq_p TO path_container_p;
        NEXT path_container_p: [1 .. info_header_p^.path_container_length] IN subproduct_info_seq_p;

        index := attributes_p^.installation_path.path_container_index;
        FOR i := LOWERBOUND (installation_path_p^) TO UPPERBOUND (installation_path_p^) DO
          path_container_p^ [index] := installation_path_p^ [i];
          index := index + 1;
        FOREND;
      IFEND;

      subproduct_info_pointers.info_header_p^.path_container_p := #REL (path_container_p,
            subproduct_info_seq_p^);
      subproduct_info_pointers.subproduct_info_seq_p := subproduct_info_seq_p;
      subproduct_info_pointers.path_container_p := path_container_p;
    IFEND;

  PROCEND process_installation_path;

?? TITLE := 'process_installation_path_opt', EJECT ??

{ PURPOSE:
{   This procedure updates the value of the installation_path_option in
{   the subproduct_attributes record.
{
{ DESIGN:
{   The value entered is translated to a constant and the constant value
{   is entered in the attributes.installation_path_option field.
{
{ NOTES:
{
{

  PROCEDURE process_installation_path_opt
    (VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR installation_path_option: ost$name;
     VAR status: ost$status);


    VAR
      attributes_p: ^rat$subproduct_attributes,
      i: rat$installation_path_option,
      value: clt$value;


    status.normal := TRUE;
    attributes_p := subproduct_info_pointers.attributes_p;

    clp$get_value ('INSTALLATION_PATH_OPTION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    installation_path_option := value.name.value;

  /initialize_value/
    FOR i := LOWERBOUND (rav$installation_path_option) TO UPPERBOUND (rav$installation_path_option) DO
      IF rav$installation_path_option [i] = value.name.value (1, value.name.size) THEN
        attributes_p^.installation_path_option := i;
        EXIT /initialize_value/;
      IFEND;
    FOREND /initialize_value/;

  PROCEND process_installation_path_opt;

?? TITLE := 'process_installer_procedure', EJECT ??

{ PURPOSE:
{   This procedure sets:
{        the installler_procedure.path_container_index to the next available path container.
{        the installler_procedure.path_length to the file length of the element.
{        For example, $SYSTEM.A.B.DDD.E, has a length of 5.
{        the info_header_p.path_container_length to total length of all containers used.
{        the path_container_p^s are filled with the names of the installation path.  In the example above
{        path_container_p^ [i] = $SYSTEM
{        path_container_p^ [i + 1] = A
{        path_container_p^ [i + 2] = B
{        path_container_p^ [i + 3] = DDD
{        path_container_p^ [i + 4] = E
{
{ DESIGN:
{   If the INSTALLER_PROCEDURE is part of the PACS catalog, it is validated as
{   an existing file containing a procedure.
{   If the INSTALLER_PROCEDURE is not part of the PACS catalog, a warning
{   message is displayed.
{   If the INSTALLER_PROCEDURE already contains a path_container_index, validate that the
{   new path is of the same length as the old path.  If they are the same length, put the new path in the
{   same containers that the old path used.
{
{   Else set the path_container_index to the next available index number.
{   The info_header_p^.path_container_index contains the value of the last used path container.
{   Set the value of the path_length to the uppervalue of the array that contains the path.
{   See example above to understand how the length of a path is determined.
{   The info_header.path_container_length is updated to point to the last used path container.
{   If the path container has not been created, it is created with a size large enough to hold this path.
{   Else the path_containers size is set to the size indicated in info_header.path_container_length.
{   Then the path_containers are filled with the path.
{
{
{ NOTES:
{
{

  PROCEDURE process_installer_procedure
    (    pacs_catalog: pft$path;
     VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      attributes_p: ^rat$subproduct_attributes,
      command_line: string (fsc$max_path_size + osc$max_name_size),
      i: rat$path_container_index,
      ignore_status: ost$status,
      index: rat$path_container_index,
      info_header_p: ^rat$subproduct_info_header,
      installer_procedure_p: ^pft$path,
      installer_procedure_ref_p: ^fst$file_reference,
      inst_proc_in_pacs_catalog: boolean,
      length: integer,
      local_status: ost$status,
      message_status: ost$status,
      path_length: integer,
      path_container_p: ^rat$path_container,
      subproduct_info_seq_p: ^rat$subproduct_info_sequence,
      value: clt$value;


    status.normal := TRUE;
    attributes_p := subproduct_info_pointers.attributes_p;
    info_header_p := subproduct_info_pointers.info_header_p;
    inst_proc_in_pacs_catalog := TRUE;
    subproduct_info_seq_p := subproduct_info_pointers.subproduct_info_seq_p;
    path_container_p := subproduct_info_pointers.path_container_p;

    clp$get_value ('INSTALLER_PROCEDURE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.kind = clc$name_value THEN { key none }

      attributes_p^.installer_procedure.path_container_index := 0;
      attributes_p^.installer_procedure.path_length := 0;

    ELSE { value.kind = clc$file_value }

      RESET rav$defs_scratch_segment.sequence_p TO rav$defs_scratch_segment.reset_p;

      rap$get_file_path_and_ref ('INSTALLER_PROCEDURE', rav$defs_scratch_segment.sequence_p,
            installer_procedure_p, installer_procedure_ref_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      /check_path/ FOR i := 1 TO UPPERBOUND (pacs_catalog) DO
        IF installer_procedure_p^ [i] <> pacs_catalog [i] THEN
          osp$set_status_abnormal ('RA', rae$inst_proc_not_in_pacs_cat, '', message_status);
          osp$append_status_file (osc$status_parameter_delimiter, installer_procedure_ref_p^, message_status);
          osp$generate_error_message (message_status, ignore_status);
          inst_proc_in_pacs_catalog := FALSE;
          EXIT /check_path/;
        IFEND;
      FOREND /check_path/;

      IF inst_proc_in_pacs_catalog THEN

        STRINGREP (command_line, length, 'display_command_information o=$null c=',
              installer_procedure_ref_p^);
        clp$include_command (command_line (1, length), FALSE, local_status);
        IF NOT local_status.normal THEN
          osp$set_status_abnormal ('RA', rae$invalid_installer_proc, '', status);
          osp$append_status_file (osc$status_parameter_delimiter, installer_procedure_ref_p^, status);
          RETURN;
        IFEND;

      IFEND;

      path_length := UPPERBOUND (installer_procedure_p^);

      IF (attributes_p^.installer_procedure.path_container_index <> 0) AND
            (attributes_p^.installer_procedure.path_length = path_length) THEN

        index := attributes_p^.installer_procedure.path_container_index;
        FOR i := 1 TO UPPERBOUND (installer_procedure_p^) DO
          path_container_p^ [index] := installer_procedure_p^ [i];
          index := index + 1;
        FOREND;

      ELSE
        attributes_p^.installer_procedure.path_container_index := info_header_p^.path_container_length + 1;
        attributes_p^.installer_procedure.path_length := path_length;
        info_header_p^.path_container_length := info_header_p^.path_container_length + path_length;

        IF path_container_p = NIL THEN
          NEXT path_container_p: [1 .. info_header_p^.path_container_length] IN subproduct_info_seq_p;
        ELSE
          RESET subproduct_info_seq_p TO path_container_p;
          NEXT path_container_p: [1 .. info_header_p^.path_container_length] IN subproduct_info_seq_p;
        IFEND;

        index := attributes_p^.installer_procedure.path_container_index;
        FOR i := 1 TO UPPERBOUND (installer_procedure_p^) DO
          path_container_p^ [index] := installer_procedure_p^ [i];
          index := index + 1;
        FOREND;

        subproduct_info_pointers.info_header_p^.path_container_p := #REL (path_container_p,
              subproduct_info_seq_p^);
        subproduct_info_pointers.subproduct_info_seq_p := subproduct_info_seq_p;
        subproduct_info_pointers.path_container_p := path_container_p;
      IFEND;
    IFEND;

  PROCEND process_installer_procedure;

?? TITLE := 'process_installation_scheme', EJECT ??

{ PURPOSE:
{   This procedure updates the value of the installation_scheme in
{   the subproduct_attributes record.
{
{ DESIGN:
{   Validate if the subproduct is a correction, that the installation scheme
{   is cycle_based.  Define subproduct can't create version based corrections.
{   The value entered is translated to a constant and the constant value
{   is entered in the attributes.installation_scheme field.
{
{ NOTES:
{
{

  PROCEDURE process_installation_scheme
    (VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      attributes_p: ^rat$subproduct_attributes,
      i: rat$installation_scheme,
      value: clt$value;


    status.normal := TRUE;
    attributes_p := subproduct_info_pointers.attributes_p;

    clp$get_value ('INSTALLATION_SCHEME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /initialize_value/
    FOR i := LOWERBOUND (rav$installation_scheme) TO UPPERBOUND (rav$installation_scheme) DO
      IF rav$installation_scheme [i] = value.name.value (1, value.name.size) THEN
        attributes_p^.installation_scheme := i;
        EXIT /initialize_value/;
      IFEND;
    FOREND /initialize_value/;

  IF (attributes_p^.installation_scheme = rac$version_based) AND
     (attributes_p^.subproduct_type = rac$correction) THEN
    osp$set_status_abnormal('RA', rae$corr_must_be_cycle_based, '', status);
    RETURN;
  IFEND;

  PROCEND process_installation_scheme;

?? TITLE := 'process_internal_level', EJECT ??

{ PURPOSE:
{   This procedure updates the value of the internal_level in
{   the subproduct_attributes record.
{
{ DESIGN:
{   If this optional value is specified, the attributes.internal_level
{   field is set to its value.
{
{ NOTES:
{
{

  PROCEDURE process_internal_level
    (VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      attributes_p: ^rat$subproduct_attributes,
      parameter_specified: boolean,
      value: clt$value;


    status.normal := TRUE;
    attributes_p := subproduct_info_pointers.attributes_p;

    clp$test_parameter ('INTERNAL_LEVEL', parameter_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter_specified THEN
      clp$get_value ('INTERNAL_LEVEL', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      attributes_p^.internal_level := value.name.value;
    IFEND;

  PROCEND process_internal_level;

?? TITLE := 'process_primary_subproduct', EJECT ??

{ PURPOSE:
{   This procedure validates the primary_subproduct parameter against
{   the subproduct name and licensed product name and if valid, updates
{   the subproduct attributues.
{
{ DESIGN:
{   If the licensed product name matches the subproduct name, then this
{   must also be the primary subproduct.  This restriction is made because
{   of how INSTALL_SOFTWARE processes subproducts/licensed products when
{   their names are equal.  This restriction will reduce the chance that
{   when subproduct name and licensed product name are equal, that the
{   licensed product contains more than one subproduct.
{
{   If the licensed product name and subproduct name do not match,
{   there are no restrictions on the primary subproduct parameter.
{ NOTES:
{
{

  PROCEDURE process_primary_subproduct
    (VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      attributes_p: ^rat$subproduct_attributes,
      value: clt$value;


    status.normal := TRUE;
    attributes_p := subproduct_info_pointers.attributes_p;

    clp$get_value ('PRIMARY_SUBPRODUCT', 1, 1, clc$low, value, status);

    IF (attributes_p^.name = attributes_p^.licensed_product) THEN
      IF value.bool.value THEN
        attributes_p^.primary := value.bool.value;
      ELSE
        osp$set_status_abnormal ('RA', rae$must_be_primary_subproduct, '', status);
        RETURN;
      IFEND;
    ELSE
      attributes_p^.primary := value.bool.value;
    IFEND;
  PROCEND process_primary_subproduct;


?? TITLE := 'process_product_dependencies', EJECT ??

{ PURPOSE:
{   This procedure puts the names of the product dependencies
{   into the attributes.dependencies array.
{
{ DESIGN:
{   The number of product dependencies is determined and these names are
{   put into the dependencies field of the subproduct attributes record.
{
{ NOTES:
{
{

  PROCEDURE process_product_dependencies
    (VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      attributes_p: ^rat$subproduct_attributes,
      i: 0 .. clc$max_value_sets,
      set_count: 0 .. clc$max_value_sets,
      value: clt$value;


    status.normal := TRUE;
    attributes_p := subproduct_info_pointers.attributes_p;

    clp$get_set_count ('PRODUCT_DEPENDENCIES', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO set_count DO
      clp$get_value ('PRODUCT_DEPENDENCIES', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF value.name.value <> 'NONE' THEN
        attributes_p^.dependencies [i] := value.name.value;
      ELSEIF i > 1 THEN
        osp$set_status_abnormal ('RA', rae$invalid_product_name, 'NONE', status);
        RETURN;
      IFEND;
    FOREND;

    sort_dependencies (attributes_p^.dependencies);

  PROCEND process_product_dependencies;

?? TITLE := 'process_subproduct_priority', EJECT ??

{ PURPOSE:
{   This procedure updates the value of the subproduct_priority in
{   the subproduct_attributes record.
{
{ DESIGN:
{   If this optional value is specified, the attributes.subproduct_priority
{   field is set to its value.
{
{ NOTES:
{
{

  PROCEDURE process_subproduct_priority
    (VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      attributes_p: ^rat$subproduct_attributes,
      parameter_specified: boolean,
      subproduct_priority: ost$name,
      value: clt$value;


    status.normal := TRUE;
    attributes_p := subproduct_info_pointers.attributes_p;

    clp$test_parameter ('SUBPRODUCT_PRIORITY', parameter_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter_specified THEN
      clp$get_value ('SUBPRODUCT_PRIORITY', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      #TRANSLATE (osv$lower_to_upper, value.name.value, subproduct_priority);

      IF subproduct_priority = 'LOW' THEN
        attributes_p^.subproduct_priority := rac$low;

      ELSEIF subproduct_priority = 'MEDIUM' THEN
        attributes_p^.subproduct_priority := rac$medium;

      ELSEIF subproduct_priority = 'HIGH' THEN
        attributes_p^.subproduct_priority := rac$high;

      ELSEIF subproduct_priority = 'INSTALLATION_TOOLS' THEN
        attributes_p^.subproduct_priority := rac$installation_tools;
      IFEND;

    IFEND;

  PROCEND process_subproduct_priority;

?? OLDTITLE ??
?? NEWTITLE := 'sort_additional_products', EJECT ??

{ PURPOSE:
{   This procedure sorts the array of additional products.
{
{ DESIGN:
{   This procedure uses a shell sort.
{
{ NOTES:
{

  PROCEDURE sort_additional_products
    (VAR additional_products: rat$additional_products);

    VAR
      current: integer,
      gap: integer,
      start: integer,
      swap: ost$name;


    gap := UPPERBOUND (additional_products);
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := LOWERBOUND (additional_products) TO UPPERBOUND (additional_products) - gap DO
        current := start;
        WHILE (current > 0) AND (additional_products [current] > additional_products [current + gap])
              AND (additional_products [current] <> '') AND (additional_products [current + gap] <> '') DO

          swap := additional_products [current];
          additional_products [current] := additional_products [current + gap];
          additional_products [current + gap] := swap;
          current := current - gap;

        WHILEND;
      FOREND;
    WHILEND;

  PROCEND sort_additional_products;

?? OLDTITLE ??
?? NEWTITLE := 'sort_dependencies', EJECT ??

{ PURPOSE:
{   This procedure sorts the array of dependencies.
{
{ DESIGN:
{   This procedure uses a shell sort.
{
{ NOTES:
{

  PROCEDURE sort_dependencies
    (VAR dependencies: rat$subproduct_dependencies);

    VAR
      current: integer,
      gap: integer,
      start: integer,
      swap: ost$name;


    gap := UPPERBOUND (dependencies);
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := LOWERBOUND (dependencies) TO UPPERBOUND (dependencies) - gap DO
        current := start;
        WHILE (current > 0) AND (dependencies [current] > dependencies [current + gap])
              AND (dependencies [current] <> '') AND (dependencies [current + gap] <> '') DO

          swap := dependencies [current];
          dependencies [current] := dependencies [current + gap];
          dependencies [current + gap] := swap;
          current := current - gap;

        WHILEND;
      FOREND;
    WHILEND;

  PROCEND sort_dependencies;

MODEND ram$define_subproduct_attrib;

*DECK DECK=RAM$DEFINE_TAPE_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'CREATE_ORDER_DEFINITION Subutility: DEFINE_TAPE_ATTRIBUTES Subcommand.' ??
MODULE ram$define_tape_attributes;

{ PURPOSE:
{   This module contains the procedures to set the tape attributes.
{
{ DESIGN:
{   A record was saved in the scratch segment for the tape attributes
{   information.  This module fills in the fields of that record.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$tape_types
*copyc rae$package_software_cc
?? POP ??
*copyc clp$convert_string_to_integer
*copyc clp$get_set_count
*copyc clp$evaluate_parameters
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc rav$packing_list_header_p
*copyc rav$tape_information

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$define_tape_attributes', EJECT ??

{ PURPOSE:
{   This procedure sets the tape attributes.
{
{ DESIGN:
{   A record was saved in the scratch segment for the tape attributes
{   information.  This module fills in the fields of that record.
{
{ NOTES:
{   The SIZES parameter defaults to 2400, when mt9$1600 or mt9$6250 are
{   specified.  An error is returned if the SIZES parameter is specified
{   along with mt18$38000.  The size assigned for mt18$38000 is 540.
{

  PROCEDURE [XDCL] rap$define_tape_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{     PROCEDURE defta_pdt (
{       vsn_seed, vs: any of
{           string 1..6
{           name 1..6
{         anyend = $required
{       type, t: key
{           mt9$1600, mt9$6250, mt18$38000
{         keyend = mt9$6250
{       sizes, size, s: list of key
{           t3600, t2400, t1200, t600, t200
{         keyend = $optional
{       percent_usable, pu: (hidden) integer 1..100 = 98
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
        default_value: string (8),
      recend,
      type3: 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 .. 5] of clt$keyword_specification,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (2),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [93, 6, 11, 14, 56, 53, 298],
    clc$command, 10, 5, 1, 0, 1, 0, 5, ''], [
    ['PERCENT_USABLE                 ',clc$nominal_entry, 4],
    ['PU                             ',clc$abbreviation_entry, 4],
    ['S                              ',clc$abbreviation_entry, 3],
    ['SIZE                           ',clc$alias_entry, 3],
    ['SIZES                          ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['T                              ',clc$abbreviation_entry, 2],
    ['TYPE                           ',clc$nominal_entry, 2],
    ['VS                             ',clc$abbreviation_entry, 1],
    ['VSN_SEED                       ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 118, clc$optional_default_parameter, 0, 8],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 208, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [1, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 2],
{ PARAMETER 5
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [1, 6, FALSE]],
    5, [[1, 0, clc$name_type], [1, 6]]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [3], [
    ['MT18$38000                     ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['MT9$1600                       ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['MT9$6250                       ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ,
    'mt9$6250'],
{ PARAMETER 3
    [[1, 0, clc$list_type], [192, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$keyword_type], [5], [
      ['T1200                          ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
      ['T200                           ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
      ['T2400                          ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['T3600                          ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
      ['T600                           ', clc$nominal_entry,
  clc$normal_usage_entry, 4]]
      ]
    ],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [1, 100, 10],
    '98'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$vsn_seed = 1,
      p$type = 2,
      p$sizes = 3,
      p$percent_usable = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      i: 0 .. rac$max_tape_sizes,
      size: clt$integer,
      sizes_p: ^clt$data_value,
      tape_sizes: rat$tape_sizes;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF rav$packing_list_header_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$define_order_not_called, '', status);
      RETURN;
    IFEND;

    IF rav$packing_list_header_p^.order_medium <> rac$tape THEN
      osp$set_status_abnormal ('RA', rae$order_medium_not_tape, '', status);
      RETURN;
    IFEND;

    IF (pvt [p$type].value^.name_value = rac$mt18$38000) AND (pvt [p$sizes].specified) THEN
      osp$set_status_abnormal ('RA', rae$invalid_with_cartridge_tape, '', status);
      RETURN;
    IFEND;

    IF pvt[p$vsn_seed].value^.kind = clc$string THEN
      #TRANSLATE (osv$lower_to_upper, pvt [p$vsn_seed].value^.string_value^, rav$tape_information.vsn_seed);
    ELSE  { name value }
      rav$tape_information.vsn_seed := pvt [p$vsn_seed].value^.name_value;
    IFEND;

    rav$tape_information.tape_type := pvt [p$type].value^.name_value;
    rav$tape_information.percent_usable := pvt [p$percent_usable].value^.integer_value.value;

    { Set the tape class and density in the packing list header record.

    IF rav$tape_information.tape_type = rac$mt9$6250 THEN
      rav$packing_list_header_p^.tape_class := rmc$mt9;
      rav$packing_list_header_p^.tape_density := rmc$6250;
    ELSEIF rav$tape_information.tape_type = rac$mt9$1600 THEN
      rav$packing_list_header_p^.tape_class := rmc$mt9;
      rav$packing_list_header_p^.tape_density := rmc$1600;
    ELSE { rav$tape_information.tape_type = rac$mt18$38000 }
      rav$packing_list_header_p^.tape_class := rmc$mt18;
      rav$packing_list_header_p^.tape_density := rmc$38000;
    IFEND;

    { Register the available tape sizes with the tape information.

    FOR i := 1 TO rac$max_tape_sizes DO
      tape_sizes [i].feet := 0;
      tape_sizes [i].usable_bytes := 0;
    FOREND;

    IF rav$tape_information.tape_type = rac$mt18$38000 THEN
      tape_sizes [1].feet := 540;

    ELSE { tape_type = rac$mt9$1600 OR rac$mt9$6250 }
      IF NOT pvt [p$sizes].specified THEN
        tape_sizes [1].feet := 2400;  {use the default}
      ELSE {sizes parameter specified}

        sizes_p := pvt [p$sizes].value;
        i := 0;

        WHILE sizes_p <> NIL DO
          i := i + 1;

          clp$convert_string_to_integer (sizes_p^.element_value^.name_value (2, * ), size, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          tape_sizes [i].feet := size.value;
          sizes_p := sizes_p^.link;
        WHILEND;

        sort_tape_sizes (tape_sizes);
      IFEND;
    IFEND;

    rav$tape_information.sizes := tape_sizes;

  PROCEND rap$define_tape_attributes;

?? TITLE := 'sort_tape_sizes', EJECT ??

{ PURPOSE:
{   This procedure sorts the tape_sizes in descending order
{   and deletes duplicate entries.
{
{ DESIGN:
{   This procedure uses a shell sort technique.
{
{ NOTES:
{
{

  PROCEDURE sort_tape_sizes
    (VAR tape_sizes: rat$tape_sizes);

    VAR
      current: integer,
      gap: integer,
      start: integer,
      swap: integer;


    gap := UPPERBOUND (tape_sizes);
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := LOWERBOUND (tape_sizes) TO UPPERBOUND (tape_sizes) - gap DO
        current := start;
        WHILE (current > 0) AND (tape_sizes [current].feet < tape_sizes [current + gap].feet) DO
          swap := tape_sizes [current].feet;
          tape_sizes [current].feet := tape_sizes [current + gap].feet;
          tape_sizes [current + gap].feet := swap;
          current := current - gap;
        WHILEND;
      FOREND;
    WHILEND;

  /delete_duplicates/
    FOR start := LOWERBOUND (tape_sizes) TO UPPERBOUND (tape_sizes) - 1 DO
      IF tape_sizes [start + 1].feet = 0 THEN
        EXIT /delete_duplicates/;
      ELSEIF tape_sizes [start].feet = tape_sizes [start + 1].feet THEN
        tape_sizes [start + 1].feet := 0;
        sort_tape_sizes (tape_sizes);
      IFEND;
    FOREND /delete_duplicates/;

  PROCEND sort_tape_sizes;

MODEND ram$define_tape_attributes;
*DECK DECK=RAM$DEFINE_TCPIP_HOST EXPAND=TRUE
PROCEDURE define_tcpip_host (
  host_name: (var) string = $required
  forward_search_range: (var) string = $required)


" This procedure prompts the user to define the TCP/IP host.

"$ format = off
  VAR
    choice: string
    conversion_status: status
    cr_requested: string
    local_forward_search_range: string
    local_host_name: string
    selection: integer
    successful: boolean
  VAREND
"$ format = on

  local_forward_search_range = forward_search_range
  local_host_name = host_name

  main_loop: ..
    LOOP

 "$ format= off
    put_line ('1Define the TCP/IP host' ..
          '01. Define the TCP/IP Host Name.........................'//local_host_name ..
          ' 2. Define the TCP/IP Forward Search Range..............'//local_forward_search_range ..
          '0Enter a menu selection, QUIT, GO, or ?: ')
"$ format= on
      choice = ''

      accept_line choice input p=''

      IF choice = '1' THEN

        prompt_for_tcpip_host_name host_name=local_host_name

      ELSEIF choice = '2' THEN

        prompt_for_forward_search forward_search_range=local_forward_search_range

      ELSEIF (choice = '?') OR ($translate(lower_to_upper, choice) = 'HELP') THEN

"$ format = off
        put_line ('0This menu prompts you to define the TCP/IP host.' ..
              '0Enter a menu selection to define the TCP/IP Host Name or the TCP/IP' ..
              ' Forward Search Range. ' ..
              ' The Host Name (also known as the domain name) is a' ..
              ' string of 255 characters or less.  The domain name may be subdivided into ' ..
              ' domain labels.  Domain labels may be up to 63 characters in length. ' ..
              ' Domain labels are separated with periods.  Domain labels must begin ' ..
              ' with a letter (a..z or A..Z) and may be followed with 0 to 62 more ' ..
              ' letters, digits (0..9), hyphens (-), or underscores (_) with the exception ' ..
              ' of the last character which must be either a letter or a digit. ' ..
              ' For example, arh.cdc.q---_5 is a valid host name. ' ..
              ' The default value for the forward search range is 4. ' ..
              ' Enter GO or press NEXT to save the defined TCP/IP Host Name and/or the TCP/IP' ..
              ' Forward Search Range. ' ..
              ' Enter QUIT to return to the Define Network menu without defining the' ..
              '   TCP/IP Host.' ..
              '  ')
"$ format = on
        accept_line cr_requested input p='Press NEXT: '

      ELSEIF ($translate(lower_to_upper, choice) = 'QUIT') OR ($translate(lower_to_upper, choice) = 'QUI') ..
            THEN

        host_name = ' '
        EXIT_PROC

      ELSEIF (choice = ' ') OR ($translate(lower_to_upper, choice) = 'GO') THEN

        host_name = local_host_name
        forward_search_range = local_forward_search_range
        EXIT_PROC

      ELSE
        accept_line cr_requested input p='Invalid selection, press NEXT: '
      IFEND

    LOOPEND main_loop

PROCEND define_tcpip_host
*DECK DECK=RAM$DEFINE_TFTP EXPAND=TRUE
PROCEDURE rap$define_tftp (
  protocol, p: key
      (cdna_session, cs)
      (datagram_socket, ds)
    keyend = datagram_socket
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request defines the TFTP client application.
"
*IFEND

  VAR
    command_file: file = $unique($local)
    ignore_status: status
    local_status: status
  VAREND

  IF protocol = cdna_session THEN
    put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1' o=$response
    COLLECT_TEXT command_file until='    COLLECT_END'
      $system.osf$command_library.MANAGE_NETWORK_APPLICATIONS
        define_client client=osa$tftp_client protocol=cdna_session
          change_maximum_connections maximum_connections=40
        QUIT
        activate_client client=osa$tftp_client
      QUIT
    COLLECT_END
  ELSE
    COLLECT_TEXT command_file until='    COLLECT_END'
      $system.osf$command_library.MANAGE_NETWORK_APPLICATIONS
        define_tcpip_application application=osa$tftp_client protocol=datagram_socket
          change_maximum_sockets maximum_sockets=40
        QUIT
        activate_tcpip_application application=osa$tftp_client
      QUIT
    COLLECT_END
  IFEND

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  IF local_status.normal THEN
    put_line ' TFTP client is defined' o=$response
  ELSE
    EXIT_PROC WITH local_status
  IFEND

PROCEND rap$define_tftp
*DECK DECK=RAM$DEFINE_TFTPS EXPAND=TRUE
PROCEDURE rap$define_tftps (
  protocol, p: key
      (cdna_session, cs)
      (datagram_socket, ds)
    keyend = datagram_socket
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request defines the TFTP server.
"
*IFEND

  VAR
    command_file: file = $unique($local)
    ignore_status: status
    local_status: status
  VAREND

  IF protocol = cdna_session THEN
    put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1' o=$response
    COLLECT_TEXT command_file until='    COLLECT_END'
      $system.osf$command_library.MANAGE_NETWORK_APPLICATIONS
        define_client client=osa$tftp_server protocol=cdna_session
          change_maximum_connections maximum_connections=40
          change_client_validation system_privilege=true
        QUIT
        activate_client client=osa$tftp_server
      QUIT
    COLLECT_END
  ELSE
    COLLECT_TEXT command_file until='    COLLECT_END'
      $system.osf$command_library.MANAGE_NETWORK_APPLICATIONS
        define_tcpip_application application=osa$tftp_server protocol=datagram_socket
          change_maximum_sockets maximum_sockets=40
          change_tcpip_validation system_privilege=true
        QUIT
        activate_tcpip_application application=osa$tftp_server
      QUIT
    COLLECT_END
  IFEND

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  IF local_status.normal THEN
    put_line ' TFTP server is defined' o=$response
  ELSE
    EXIT_PROC WITH local_status
  IFEND

PROCEND rap$define_tftps
*DECK DECK=RAM$DEFINE_TIMESHARING EXPAND=TRUE
PROCEDURE define_timesharing  (
  status: (var) status = $optional
)

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"    This request defines the timesharing application.
"DEFINE_TIMESHARING is called by the DEFINE_NETWORK command.  The
"PROMPT_FOR_TIMESHARING_TITLES procedure call allows the site to
"define multiple titles.  PROMPT_FOR_TIMESHARING_TITLES calls
"PROCESS_TIMESHARING_TITLES which inturn calls the ADD_TITLES
"subcommand to actually set the title values.
*IFEND


    create_variable changes_accepted k=boolean
    create_variable defs_file k=string v='$local.'//$unique
    create_variable display_status k=status
    create_variable i k=integer
    create_variable ignore_status k=status
    create_variable last_line k=integer
    create_variable local_status k=status
    create_variable manna_file k=string v='$local.'//$unique
    create_variable max_titles k=integer v=25
    create_variable prompted k=string
    create_variable sub_utility_file k=string v='$local.'//$unique
    create_variable titles k=string d=max_titles v=''
    create_variable title_count k=integer v=0
    create_variable title_file k=string v='$local.'//$unique
    create_variable yes_response k=boolean


  collect_text o=$fname(manna_file) until='  end_collect'
    $system.osf$command_library.manage_network_applications
    manna_block: ..
      BLOCK
        display_server_attributes server=osa$timesharing o=$null status=display_status
        IF display_status.normal THEN
          collect_text o=$fname(sub_utility_file) until='          end_sub_utility_file'
          chas_block: ..
            BLOCK
              put_line ('1The Timesharing application is already defined.' ..
                        ' The following title(s) are from the current definition' ..
                        ' of Timesharing.')
              display_server_attributes server=osa$timesharing a=titles o=title_list
              $system.edit_file title_list o=$null
                position_cursor line=last
                last_line = $current_line
                position_cursor line=first
                position_cursor t='Titles:'
                title_count = last_line - $current_line + 1
                delete_lines lines=first..($current_line-1)
                write_file file=$output l=current..last
                replace_text 'Titles:' '' line=current
                replace_text ' ' '' lines=all
                position_cursor line=first
                IF $current_word <> 'None' THEN
                  FOR i = 1 TO title_count DO
                    titles(i) = $current_word
                    IF i <> title_count THEN
                      position_forwards
                    IFEND
                  FOREND
                IFEND
              end
              $system.osf$builtin_library.prompt_for_answer ..
                   'Do you want to add or delete Timesharing application titles?' yes_response
              IF NOT yes_response THEN
                EXIT chas_block
              IFEND
              change_server server=osa$timesharing
                $system.osf$builtin_library.prompt_for_timesharing_titles titles changes_accepted
                IF changes_accepted THEN
                  put_line 'end_change_server yes' o=$fname(defs_file)
                ELSE
                  put_line 'end_change_server no' o=$fname(defs_file)
                IFEND
              include_file $fname(defs_file)
            BLOCKEND chas_block
          end_sub_utility_file

        ELSE " Timesharing not defined.
          collect_text o=$fname(sub_utility_file) until='          end_sub_utility_file'
            define_server osa$timesharing protocol=cdna_virtual_terminal nam_initiated=true
              $system.osf$builtin_library.prompt_for_timesharing_titles titles changes_accepted
              IF changes_accepted THEN
                collect_text o=$fname(defs_file) until='                **'
                  change_maximum_connections maximum_connections=500
                  change_connection_priority connection_priority=6
                  change_client_validation capability=timesharing
                  change_server_validation capability=none ring=3 system_privilege=false
                  change_server_job $null validation_source=client maximum_connections=1
                  end_define_server
                **
              ELSE
                put_line 'end_define_server sd=false' o=$fname(defs_file)
              IFEND
            include_file $fname(defs_file)
            IF changes_accepted THEN
              activate_server osa$timesharing
              put_line ('0Timesharing application is defined.', '  ') o=$response
            IFEND
          end_sub_utility_file
        IFEND
        include_file $fname(sub_utility_file)
      BLOCKEND manna_block
    quit
  end_collect

  include_file $fname(manna_file) status=local_status
  detach_file $fname(manna_file) status=ignore_status
  detach_file $fname(title_file) status=ignore_status
  detach_file $fname(defs_file) status=ignore_status
  detach_file $fname(sub_utility_file) status=ignore_status

  IF NOT local_status.normal THEN
    put_line ('0Definition/modification of Timesharing application failed.', ..
              ' '//$strrep(local_status),'  ') o=$response
  IFEND

  accept_line prompted input p='Press NEXT:'

PROCEND define_timesharing
*DECK DECK=RAM$DELETE_5744_APPLICATION EXPAND=TRUE
PROCEDURE rap$delete_5744_interface (
  terminate_active_connections, tac : boolean = false
  status)

  "$FORMAT=OFF"
  VAR
    command_file     : file =$unique($local)
    ignore_status    : status
    local_status     : status
    delete_status    : status
  VAREND
  "$FORMAT=ON"

  COLLECT_TEXT command_file until='  COLLECT_END'
    $system.osf$command_library.manage_network_applications

      deactivate_tcpip_application application=osa$5744_interface_dgram ..
            tas=$value(terminate_active_connections) ..
            status=delete_status
      IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
        delete_tcpip_application application=osa$5744_interface_dgram status=delete_status
        IF delete_status.normal
          put_line ' OSA$5744_INTERFACE_DGRAM application is deleted' o=$response
          delete_status.normal = true
        IFEND
      IFEND

        deactivate_client client=osa$5744_interface_gateway ..
              tac=$value(terminate_active_connections) ..
              status=delete_status
        IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
          delete_client client=osa$5744_interface_gateway status=delete_status
          IF delete_status.normal THEN
            put_line ' OSA$5744_INTERFACE_GATEWAY application is deleted' o=$response
            delete_status.normal = true
          IFEND
        IFEND

    quit
  COLLECT_END

  include_file command_file status=local_status
  delete_file command_file  status=ignore_status

  IF NOT delete_status.normal AND ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
    put_line ' OSA$5744_INTERFACE application is unknown' o=$response
    delete_status.normal = true
  IFEND

  EXIT PROCEDURE WITH local_status WHEN NOT local_status.normal
  EXIT PROCEDURE WITH delete_status WHEN NOT delete_status.normal

PROCEND rap$delete_5744_interface

*DECK DECK=RAM$DELETE_BTF EXPAND=TRUE
PROC rap$delete_btf (
  terminate_active_connections, tac : boolean = false
  status                            : var of status = $optional
  )


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"   This request deletes BTF.
*IFEND


  create_variable command_file k=string v='$local.'//$unique
  create_variable delete_status k=status
  create_variable ignore_status k=status
  create_variable local_status k=status


COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  $system.osf$command_library.manage_network_applications
    deactivate_client client=osa$batch_transfer_client tac=$value(terminate_active_connections) ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$batch_transfer_client status=delete_status
    IFEND

    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status.normal = true
    IFEND
  quit
COLLECT_END

  include_file $fname(command_file) status=local_status
  detach_file $fname(command_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal

PROCEND rap$delete_btf
*DECK DECK=RAM$DELETE_BTFS EXPAND=TRUE
PROC rap$delete_btfs (
  terminate_active_connections, tac : boolean = false
  status                            : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request deletes the BTFS applications.
*IFEND


  create_variable command_file k=string v='$local.'//$unique
  create_variable delete_status k=status
  create_variable ignore_status k=status
  create_variable local_status k=status


COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_server server=osa$batch_transfer_server tac=$value(terminate_active_connections) ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_server server=osa$batch_transfer_server status=delete_status
    IFEND
    IF NOT delete_status.normal AND ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status.normal = true
    IFEND

  quit
COLLECT_END

  include_file $fname(command_file) status=local_status
  detach_file $fname(command_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal


PROCEND rap$delete_btfs
*DECK DECK=RAM$DELETE_CATALOG_CONTENTS EXPAND=TRUE
PROC delete_catalog_contents, delcc (
  catalog, c : file = $required
  status     : var of status = $optional
  )

  $system.delete_catalog catalog=$value(catalog) delete_option=contents_only

PROCEND delete_catalog_contents
*DECK DECK=RAM$DELETE_C_SOCKET EXPAND=TRUE
PROCEDURE rap$delete_c_socket (
  terminate_active_connections, tac : boolean = false
  status)

  "$FORMAT=OFF"
  VAR
    command_file     : file =$unique($local)
    delete_status    : status
    ignore_status    : status
  VAREND
  "$FORMAT=ON"

  COLLECT_TEXT command_file until='  COLLECT_END'
    $system.osf$command_library.manage_network_applications

      deactivate_tcpip_application application=osa$c_socket_stream tas=terminate_active_connections ..
            status=delete_status
      IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
        delete_tcpip_application application=osa$c_socket_stream status=delete_status
      IFEND

      IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
        delete_status.normal = true
      IFEND

    quit
  COLLECT_END

  $system.include_file command_file

  EXIT PROCEDURE WITH delete_status WHEN NOT delete_status.normal

  COLLECT_TEXT command_file until='  COLLECT_END'
    $system.osf$command_library.manage_network_applications

      deactivate_tcpip_application application=osa$c_socket_dgram tas=terminate_active_connections ..
            status=delete_status
      IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
        delete_tcpip_application application=osa$c_socket_dgram status=delete_status
      IFEND

      IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
        delete_status.normal = true
      IFEND

    quit
  COLLECT_END

  $system.include_file command_file

  EXIT PROCEDURE WITH delete_status WHEN NOT delete_status.normal

  COLLECT_TEXT command_file until='  COLLECT_END'
    $system.osf$command_library.manage_network_applications

      deactivate_client client=osa$c_socket ..
          tac=$value(terminate_active_connections) ..
          status=delete_status
      IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
        delete_client client=osa$c_socket status=delete_status
      IFEND

      IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
        delete_status.normal = true
      IFEND

    quit
  COLLECT_END

  $system.include_file command_file
  delete_file command_file status=ignore_status

  EXIT PROCEDURE WITH delete_status WHEN NOT delete_status.normal


PROCEND rap$delete_c_socket

*DECK DECK=RAM$DELETE_DESKTOP_ENVIRONMENT EXPAND=TRUE
PROC rap$delete_desktop_environment (
  terminate_active_connections, tac : boolean = false
  status                            : var of status = $optional
  )

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"   This request deletes the desktop environment.
*IFEND

  create_variable command_file k=string v='$local.'//$unique
  create_variable delete_status k=status
  create_variable ignore_status k=status
  create_variable local_status k=status


  COLLECT_TEXT $fname(command_file) until='  collect_end'
    $system.manage_network_applications

      deactivate_client client=desktop_ve tac=$value(terminate_active_connections) ..
            status=delete_status
      IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
        delete_client client=desktop_ve status=delete_status
      IFEND

      IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
        delete_status.normal = true
      IFEND

    quit
  collect_end

  include_file $fname(command_file) status=local_status
  detach_file $fname(command_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal

PROCEND rap$delete_desktop_environment
*DECK DECK=RAM$DELETE_DRJE EXPAND=TRUE
PROC rap$delete_drje (
  terminate_active_connections, tac : boolean = false
  status                            : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request deletes DRJE.
*IFEND


  create_variable command_file k=string v='$local.'//$unique
  create_variable delete_status k=status
  create_variable ignore_status k=status
  create_variable local_status k=status


COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$drje_device_outcall tac=$value(terminate_active_connections) ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$drje_device_outcall status=delete_status
    IFEND

    IF (NOT delete_status.normal) AND ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status.normal = true
    IFEND

  quit
COLLECT_END

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal

PROCEND rap$delete_drje
*DECK DECK=RAM$DELETE_EXTRA_CYCLES EXPAND=TRUE
PROCEDURE (ram$delec) delete_extra_cycles, delec (
  catalog, c: file = $working_catalog
  retain, r: integer 0..999 = 1
  depth, d: any of
      key
        all
      keyend
      integer 1..$max_integer
    anyend = 2
  delete_empty_subcatalogs, delete_empty_subcatalog, des: boolean = false
  exclude_catalog, exclude_catalogs, ec: (BY_NAME, ADVANCED) list 0..$max_list of string = (' $')
  exclude_file, exclude_files, ef: (BY_NAME, ADVANCED) list 0..$max_list of string = (' $')
  include_catalog, ic: (BY_NAME, ADVANCED) list 0..$max_list of string = ()
  include_file, if: (BY_NAME, ADVANCED) list 0..$max_list of string = ()
  status)

" PURPOSE:
"   Delete the extra cycles from a catalog.
" DESIGN:
"   Delete all files meeting the criteria selected by parameter values. String values for INCLUDE or EXCLUDE
"   parameters are processed as substrings of the file or catalog names, allowing similarly named files or
"   catalogs to be selected or excluded. The depth parameter limits the number of subcatalogs processed.
" NOTES:
"   String values for INCLUDE or EXCLUDE parameters are processed as substrings of the file/catalog name.
"   A leading or trailing blank constrains the substring match to the beginning or end of a file name.

  VAR
    cycles : list of file
    delete_status : status
    files : list 0..$max_list of file = ()
    subcatalogs : list 0..$max_list of file = ()
  VAREND

" Either select all files in the catalog, or iteratively select those files whose names contain the specified
" include_file strings. Use the $union function to accumulate the list of non-duplicated file names.
  IF $nil(include_file) THEN
    files=$catalog_contents(catalog, include_files, paths)
  ELSE
    FOR EACH included_file IN include_file DO
      files=$union(files, $select($catalog_contents(catalog, include_files, paths), ..
            $scan_string($translate(ltu, included_file), ' '//$path(x, last)//' ')<>0))
    FOREND
  IFEND

" Exclude those files whose names do not contain the exclude_file strings.
  FOR EACH excluded_file IN exclude_file DO
    files=$select(files, $scan_string($translate(ltu, excluded_file), ' '//$path(x, last)//' ')=0)
  FOREND

" Remove the extra cycles of every file name in the list of files.
  FOR EACH filename IN files DO
    cycles=$reverse($file_cycles(filename, paths))
    FOR low_cycle = 1 TO ($size(cycles) - retain) DO
      delete_file file=cycles(low_cycle) status=delete_status
      IF delete_status.normal THEN
        put_line line='   DELETED FILE    '//cycles(low_cycle) output=$response
      IFEND
    FOREND
  FOREND

" Exit this procedure if the appropriate subcatalog level, otherwise decrement the depth counter and recurse.
  IF $generic_type(depth)= integer THEN
    EXIT_PROC WHEN depth <= 2
    depth=depth - 1
  IFEND

" Either select all subcatalogs, or iteratively select the subcatalogs whose names contain the specified
" include_catalog strings. Use the $union function to accumulate the list of non-duplicated catalog names.
  IF $nil(include_catalog) THEN
    subcatalogs=$catalog_contents(catalog, include_catalogs, paths)
  ELSE
    FOR EACH included_catalog IN include_catalog DO
      subcatalogs=$union(subcatalogs, $select($catalog_contents(catalog, include_catalogs, paths), ..
            $scan_string($translate(ltu, included_catalog), ' '//$path(x, last)//' ')<>0))
    FOREND
  IFEND

" Exclude those subcatalogs whose names do not contain the exclude_catalog strings.
  FOR EACH excluded_catalog IN exclude_catalog DO
    subcatalogs=$select(subcatalogs, ..
          $scan_string($translate(ltu, excluded_catalog), ' '//$path(x, last)//' ')=0)
  FOREND

" Recurse to process the files in each subcatalog.
  FOR EACH subcatalog IN subcatalogs DO
    $source.delete_extra_cycles catalog=subcatalog retain=retain depth=depth ec=exclude_catalog ..
          ef=exclude_file ic=include_catalog if=include_file des=delete_empty_subcatalogs
  FOREND

" Delete empty subcatalogs when directed to do so, otherwise exit the procedure.
  EXIT_PROC WHEN NOT delete_empty_subcatalogs
  delete_catalog catalog status=delete_status
  IF delete_status.normal THEN
    put_line line='   DELETED CATALOG '//catalog output=$response
  IFEND

PROCEND delete_extra_cycles
*DECK DECK=RAM$DELETE_EXTRA_FILE_CYCLES EXPAND=TRUE
PROCEDURE (ram$delefc) delete_extra_file_cycles, delefc (
  file, files, f: list of file = $required
  retain, r: integer 0..999 = 1
  status)

" PURPOSE:
"   Delete extra cycles of a file.
" DESIGN:
"   Delete all extra cycles of a file which so that only the RETAINed number remain.
" NOTES:
"   Reverse the list returned by $file_cycles to arrange the paths in low to high cycle number order.

  VAR
    cycles : list of file
    delete_status : status
  VAREND

  FOR EACH filename IN files DO " process the list of file names "
    cycles=$reverse($file_cycles(filename, paths))
    FOR low_cycle = 1 TO ($size(cycles) - retain) DO
      $system.delete_file cycles(low_cycle) status=delete_status
      IF delete_status.normal THEN
        put_line ('   DELETED FILE    '//cycles(low_cycle)) output=$response
      IFEND
    FOREND
  FOREND

PROCEND delete_extra_file_cycles
*DECK DECK=RAM$DELETE_FTP EXPAND=TRUE
PROCEDURE rap$delete_ftp (
  terminate_active_connections, tac : boolean = false
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request deletes the FTP client.
*IFEND


  VAR
    command_file: file = $unique($local)
    delete_status: status
    ignore_status: status
    local_status: status
  VAREND

COLLECT_TEXT command_file until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$ftp_client tac=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$ftp_client status=delete_status
    IFEND

    deactivate_tcpip_application application=osa$ftp_client tas=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$ftp_client status=delete_status
    IFEND

  quit
COLLECT_END

  include_file command_file status=local_status
  delete_file command_file status=ignore_status


PROCEND rap$delete_ftp

*DECK DECK=RAM$DELETE_FTPS EXPAND=TRUE
PROCEDURE rap$delete_ftps (
  terminate_active_connections, tac : boolean = false
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request deletes the FTP server.
*IFEND

  VAR
    command_file: file = $unique($local)
    delete_status: status
    ignore_status: status
    local_status: status
  VAREND

COLLECT_TEXT command_file until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$ftp_server tac=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$ftp_server status=delete_status
    IFEND

    deactivate_tcpip_application application=osa$ftp_server tas=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$ftp_server status=delete_status
    IFEND

  quit
COLLECT_END

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

PROCEND rap$delete_ftps

*DECK DECK=RAM$DELETE_IPC_APPLICATIONS EXPAND=TRUE
PROCEDURE  rap$delete_ipc_applications (
  terminate_active_connections, tac : boolean = false
  status)

  "$FORMAT=OFF"
  VAR
    command_file     : file =$unique($local)
    delete_status    : status
    ignore_status    : status
  VAREND
  "$FORMAT=ON"

  COLLECT_TEXT command_file until='  COLLECT_END'
    $system.osf$command_library.manage_network_applications

      deactivate_tcpip_application application=osa$ipc_appl_stream tas=terminate_active_connections ..
            status=delete_status
      IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
        delete_tcpip_application application=osa$ipc_appl_stream status=delete_status
      IFEND

      IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
        delete_status.normal = true
      IFEND

    quit
  COLLECT_END

  $system.include_file command_file

  EXIT PROCEDURE WITH delete_status WHEN NOT delete_status.normal

  COLLECT_TEXT command_file until='  COLLECT_END'
    $system.osf$command_library.manage_network_applications

      deactivate_tcpip_application application=osa$ipc_appl_dgram tas=terminate_active_connections ..
            status=delete_status
      IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
        delete_tcpip_application application=osa$ipc_appl_dgram status=delete_status
      IFEND

      IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
        delete_status.normal = true
      IFEND

    quit
  COLLECT_END

  $system.include_file command_file

  EXIT PROCEDURE WITH delete_status WHEN NOT delete_status.normal


COLLECT_TEXT command_file until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$ipc_applications tac=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$ipc_applications status=delete_status
    IFEND

    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status.normal = true
    IFEND

  quit
COLLECT_END

  $system.include_file command_file
  delete_file command_file status=ignore_status

  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal


PROCEND rap$delete_ipc_applications

*DECK DECK=RAM$DELETE_LPD EXPAND=TRUE
PROCEDURE rap$delete_lpd (
  terminate_active_connections, tac : boolean = false
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request deletes the LPD client.
*IFEND

  VAR
    command_file: string = '$local.'//$unique
    delete_status: status
    ignore_status: status
    local_status: status
  VAREND

COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$lpd_client tac=$value(terminate_active_connections) ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$lpd_client status=delete_status
    IFEND

    deactivate_tcpip_application application=osa$lpd_client tas=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$lpd_client status=delete_status
    IFEND

    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status.normal = true
    IFEND

  quit
COLLECT_END

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal

PROCEND rap$delete_lpd

*DECK DECK=RAM$DELETE_LPDS EXPAND=TRUE
PROCEDURE rap$delete_lpds (
  terminate_active_connections, tac : boolean = false
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request deletes the LPD server.
*IFEND

  VAR
    command_file: string = '$local.'//$unique
    delete_status: status
    ignore_status: status
    local_status: status
  VAREND

COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$lpd_server tac=$value(terminate_active_connections) ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$lpd_server status=delete_status
    IFEND

    deactivate_tcpip_application application=osa$lpd_server tas=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$lpd_server status=delete_status
    IFEND

    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status.normal = true
    IFEND

  quit
COLLECT_END

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal


PROCEND rap$delete_lpds

*DECK DECK=RAM$DELETE_NAME_RESOLVER EXPAND=TRUE
PROCEDURE rap$delete_name_resolver (
  terminate_active_connections, tac : boolean = false
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request deletes the IPAM Domain Name Resolver.
*IFEND

  VAR
    command_file: string = '$local.'//$unique
    ignore_status: status
    local_status: status
    tcp_delete_status: status
    udp_delete_status: status
  VAREND

COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$udp_domain_name_resolver ..
          tac=terminate_active_connections status=udp_delete_status
    IF udp_delete_status.normal OR ..
      ($condition(udp_delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$udp_domain_name_resolver status=udp_delete_status
    IFEND

    IF udp_delete_status.normal OR ..
      ($condition(udp_delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      udp_delete_status.normal = true
    IFEND

    deactivate_client client=osa$tcp_domain_name_resolver ..
          tac=terminate_active_connections status=tcp_delete_status
    IF tcp_delete_status.normal OR ..
      ($condition(tcp_delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$tcp_domain_name_resolver status=tcp_delete_status
    IFEND

    IF tcp_delete_status.normal OR ..
      ($condition(tcp_delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      tcp_delete_status.normal = true
    IFEND

    deactivate_tcpip_application application=osa$udp_domain_name_resolver ..
          tas=terminate_active_connections status=udp_delete_status
    IF udp_delete_status.normal OR ..
      ($condition(udp_delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$udp_domain_name_resolver status=udp_delete_status
    IFEND

    IF udp_delete_status.normal OR ..
      ($condition(udp_delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      udp_delete_status.normal = true
    IFEND

    deactivate_tcpip_application application=osa$tcp_domain_name_resolver ..
          tas=$value(terminate_active_connections) ..
          status=tcp_delete_status
    IF tcp_delete_status.normal OR ..
      ($condition(tcp_delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$tcp_domain_name_resolver status=tcp_delete_status
    IFEND

    IF tcp_delete_status.normal OR ..
      ($condition(tcp_delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      tcp_delete_status.normal = true
    IFEND

  quit
COLLECT_END

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH udp_delete_status WHEN NOT udp_delete_status.normal
  EXIT_PROC WITH tcp_delete_status WHEN NOT tcp_delete_status.normal

PROCEND rap$delete_name_resolver

*DECK DECK=RAM$DELETE_NQS EXPAND=TRUE
PROCEDURE rap$delete_nqs (
  terminate_active_connections, tac: boolean = false
  status)

  VAR
    delete_status    : status
  VAREND

  $system.osf$command_library.manage_network_applications

    deactivate_tcpip_application application=osa$nqs_server tas=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR (delete_status.condition = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$nqs_server status=delete_status
    IFEND

    IF delete_status.normal OR (delete_status.condition = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status.normal = true
    IFEND

  QUIT

  EXIT procedure WITH delete_status

PROCEND rap$delete_nqs
*DECK DECK=RAM$DELETE_NTF EXPAND=TRUE
PROC rap$delete_ntf (
  terminate_active_connections, tac : boolean = false
  status                            : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request deletes NTF.
*IFEND


  create_variable command_file k=string v='$local.'//$unique
  create_variable delete_status k=status
  create_variable ignore_status k=status
  create_variable local_status k=status


COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$network_transfer_fac_client tac=$value(terminate_active_connections) ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$network_transfer_fac_client status=delete_status
    IFEND

    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status.normal = true
    IFEND

  quit
COLLECT_END

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal

PROCEND rap$delete_ntf
*DECK DECK=RAM$DELETE_OPENTF EXPAND=TRUE
PROC rap$delete_opentf (
  terminate_active_connections, tac : boolean = false
  status                            : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request deletes OPENTF.
*IFEND


  create_variable command_file k=string v='$local.'//$unique
  create_variable delete_status k=status
  create_variable ignore_status k=status
  create_variable local_status k=status


COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  $system.osf$command_library.manage_network_applications
    deactivate_client client=osa$ntf_operator tac=$value(terminate_active_connections) ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$ntf_operator status=delete_status
    IFEND

    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status.normal = true
    IFEND
  quit
COLLECT_END

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal

PROCEND rap$delete_opentf
*DECK DECK=RAM$DELETE_OPES EXPAND=TRUE
PROC rap$delete_opes (
  terminate_active_connections, tac : boolean = false
  status                            : var of status = $optional
  )


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"   This request deletes OPES.
*IFEND


  create_variable command_file k=string v='$local.'//$unique
  create_variable delete_status k=status
  create_variable ignore_status k=status
  create_variable local_status k=status


COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  $system.osf$command_library.manage_network_applications
    deactivate_client client=osa$station_operator tac=$value(terminate_active_connections) ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$station_operator status=delete_status
    IFEND

    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status.normal = true
    IFEND
  quit
COLLECT_END

  include_file $fname(command_file) status=local_status
  detach_file $fname(command_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal

PROCEND rap$delete_opes
*DECK DECK=RAM$DELETE_OSI_ADDRESS EXPAND=TRUE

create_program_description (DELETE_OSI_ADDRESS, DELETE_OSI_ADDRESSES, DELOSIA) l='$system.osf$system_library'..
      sp=nap$delete_osi_address lm=$null lmo=none tel=warning dm=off
*DECK DECK=RAM$DELETE_PACKING_LIST EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: DELETE_PACKING_LIST Subcommand.' ??
MODULE ram$delete_packing_list;

{ PURPOSE:
{   This module contains the INSTALL_SOFTWARE command interface to delete the
{   packing list under the installation database catalog.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc osp$set_status_abnormal
*copyc pfp$convert_fs_path_to_pf_path
*copyc pfp$convert_string_to_fs_path
*copyc pfp$purge
*copyc rae$install_software_cc
*copyc rav$installation_defaults

?? TITLE := '[XDCL] rap$delete_packing_list', EJECT ??

{ PURPOSE:
{   This is the command interface that deletes the packing list from
{   the installation database.
{
{ DESIGN:
{   The destination path to be deleted is assembled by taking the current value
{   for the installation database catalog and appending the name specified
{   for the packing list by the caller.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$delete_packing_list
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PROCEDURE delete_packing_list, delpl (
{    packing_list, packing_lists, pl: list 0..clc$max_list_size of name = $required
{    status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [92, 6, 10, 8, 36, 59, 420],
    clc$command, 4, 2, 1, 0, 0, 0, 2, ''], [
    ['PACKING_LIST                   ',clc$nominal_entry, 1],
    ['PACKING_LISTS                  ',clc$alias_entry, 1],
    ['PL                             ',clc$abbreviation_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 0, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$packing_list = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      length: integer,
      local_status: ost$status,
      packing_list: ^clt$data_value,
      packing_list_path: fst$path;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    packing_list := pvt [p$packing_list].value;

    REPEAT
      STRINGREP (packing_list_path, length, rav$installation_defaults.installation_database.
            path (1, rav$installation_defaults.installation_database.size), '.',
            packing_list^.element_value^.
            name_value (1, clp$trimmed_string_size (packing_list^.element_value^.name_value)));

      delete_packing_list (packing_list_path(1, length), local_status);
      IF NOT local_status.normal THEN
        status := local_status;
      IFEND;
      packing_list := packing_list^.link;
    UNTIL packing_list = NIL;

  PROCEND rap$delete_packing_list;

?? TITLE := 'delete_packing_list', EJECT ??

{ PURPOSE:
{   This procedure deletes the packing list from the database catalog.
{
{ DESIGN:
{   The file path is converted from file reference to PF file format so
{   that PFP$PURGE can be called to delete the file.
{
{ NOTES:

  PROCEDURE delete_packing_list
    (    file_path: fst$file_reference;
     VAR status: ost$status);

    VAR
      cycle_selector: pft$cycle_selector,
      fs_path: string (fsc$max_path_size),
      ignore_cycle_reference: fst$cycle_reference,
      ignore_cycle_selector: clt$cycle_selector,
      ignore_open_position: fst$open_position,
      number_of_path_elements: fst$number_of_path_elements,
      password: pft$password,
      path_p: ^pft$path;

    status.normal := TRUE;
    password := '';
    cycle_selector.cycle_option := pfc$lowest_cycle;

{  Convert the file path, which is in file reference format to PF format. }

    pfp$convert_string_to_fs_path (file_path, fs_path, number_of_path_elements, ignore_cycle_reference,
          ignore_open_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH path_p: [1 .. number_of_path_elements];
    pfp$convert_fs_path_to_pf_path (fs_path, path_p, ignore_cycle_reference, ignore_cycle_selector, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  Delete the file. }

    pfp$purge (path_p^, cycle_selector, password, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal ('RA', rae$cannot_delete_packing_list, '', status);
    IFEND;

  PROCEND delete_packing_list;

MODEND ram$delete_packing_list;
*DECK DECK=RAM$DELETE_PREVIOUS_CYCLES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$DELETE_PREVIOUS_CYCLES Interface.' ??
MODULE ram$delete_previous_cycles;

{ PURPOSE:
{   This module contains the interface and procedures that delete previous
{   cycles of the installed products.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$installation_cycles
*copyc rae$install_software_cc
*copyc rat$installation_control_record
*copyc rat$string
?? POP ??
*copyc amp$put_next
*copyc avp$ring_min
*copyc clp$convert_integer_to_string
*copyc clp$delete_variable
*copyc clp$get_variable
*copyc clp$include_file
*copyc clp$include_line
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc jmp$system_job
*copyc osp$append_status_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pmp$get_unique_name
*copyc rap$clear_installation
*copyc rap$create_scl_status_variable
*copyc rap$convert_path_to_str
*copyc rap$get_cycle_data
*copyc rap$record_step_status
*copyc rap$record_subproduct_status
*copyc rap$sort_cycles

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    delete_status_variable = 'RAV$DELETE_STATUS';

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$delete_previous_cycles', EJECT ??

{ PURPOSE:
{   This interface deletes previous cycles of the installed products.
{
{ DESIGN:
{   1.  When SAVE_PREVIOUS_CYCLES is specified false and a subproduct
{       installs completely (that is, through step 7), the lower file
{       cycles of that subproduct are deleted.
{
{      (It should be made clear that SAVE_PREVIOUS_CYCLES is not talking
{       about versions.  That it has no affect on version based
{       subproducts or, that when a subproduct changes file names or
{       paths from one version to the next, the previous files are not
{       found and therefore not removed.)
{
{   2.  An attempt is made to delete all lower file cycles belonging to a
{       subproduct.  When a file cycle cannot be deleted because it is
{       currently opened, the file cycle is added to a special delete job.
{
{   3.  The special delete job will be processed outside the INSS
{       environment.  Results are not recorded in the process summary file.
{       The processing of each file cycle in the delete job is as follows:
{
{       a.  Close the file cycle by: Removing file cycle from the command
{           list, if on command list.  Removing file cycle from the
{           library list, if on library list.  Detaching file cycle, if
{           attached.
{
{       b.  Delete the file cycle.
{
{       c.  Reattach the file cycle in the same way it was found.
{           (This will be implimented in the future.)
{
{   The failure of one subproduct will not jeopardize the remaining
{   subproducts.  Each subproduct is processed independently.
{
{ NOTES:
{   The deletion of extra file cycles works best if done in a batch job.
{   This is generally the case because of the nature of processing.  This
{   is not the case when the interactive mode is used.  However, this mode
{   is only used during deadstart when the execution of system jobs is
{   already restricted.
{
{   The SUBPRODUCT_FAILED_PROCESSING boolean has been initialized outside of
{   this interface and should never be re-initialized here.
{

  PROCEDURE [XDCL] rap$delete_previous_cycles
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR subproduct_failed_processing: boolean;
     VAR status: ost$status);


    VAR
      delete_job_file: ost$name,
      delete_job_fid: amt$file_identifier,
      errors_encountered: boolean,
      delete_job_file_opened: boolean,
      ignore_status: ost$status,
      local_status: ost$status,
      log_file: rat$path,
      processing_record: rat$subp_processing_record,
      subproduct_index: rat$subproduct_count,
      user_min_ring_str: ost$string;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to close the temporary
{   delete job file when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (delete_job_fid, ignore_status);

      purge_special_delete_job_file (delete_job_file (1, clp$trimmed_string_size (delete_job_file)),
            ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    delete_job_file_opened := FALSE;

    IF NOT (rac$delete_previous_cycles_step IN installation_control_record.processing_header_p^.step_set) THEN
      RETURN;
    IFEND;

    rap$record_step_status (rac$delete_previous_cycles_step, rac$step_started, installation_control_record,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      get_delete_variables (installation_control_record, user_min_ring_str, delete_job_file, log_file,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      { Create an SCL status variable to be used by the delete file command.

      rap$create_scl_status_variable (delete_status_variable, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      FOR subproduct_index := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^)
            DO
        processing_record := installation_control_record.subproduct_processing_records_p^
              [subproduct_index];

        IF (installation_control_record.job_identifier = processing_record.job_identifier) AND
              (rac$delete_previous_cycles_task IN processing_record.task_set) AND
              (processing_record.task_status <> rac$task_failed) THEN

          rap$record_subproduct_status (rac$delete_previous_cycles_task, rac$task_started, subproduct_index,
                installation_control_record, ignore_status);

          errors_encountered := FALSE;

          delete_previous_subp_cycles (processing_record.installation_catalog_p^, user_min_ring_str,
                log_file.path (1, log_file.size), installation_control_record.job_identifier, delete_job_file
                (1, clp$trimmed_string_size (delete_job_file)), delete_job_file_opened, delete_job_fid,
                processing_record.subproduct_info_pointers.element_list_p,
                processing_record.subproduct_info_pointers.subproduct_info_seq_p,
                installation_control_record.scratch_seq_p, errors_encountered);

          IF NOT errors_encountered THEN
            rap$record_subproduct_status (rac$delete_previous_cycles_task, rac$task_completed,
                  subproduct_index, installation_control_record, ignore_status);
          ELSE
            rap$record_subproduct_status (rac$delete_previous_cycles_task, rac$task_failed,
                  subproduct_index, installation_control_record, ignore_status);
            subproduct_failed_processing := TRUE;
          IFEND;

        IFEND;
      FOREND;

      IF delete_job_file_opened THEN
        submit_special_delete_job (delete_job_file (1, clp$trimmed_string_size (delete_job_file)),
              delete_job_fid, delete_job_file_opened, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
      IFEND;

      clp$delete_variable (delete_status_variable, ignore_status);

    END /main/;

    IF delete_job_file_opened THEN
      fsp$close_file (delete_job_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;

      purge_special_delete_job_file (delete_job_file (1, clp$trimmed_string_size (delete_job_file)),
            ignore_status);
    IFEND;

    osp$disestablish_cond_handler;

    rap$clear_installation (installation_control_record, ignore_status);

    rap$record_step_status (rac$delete_previous_cycles_step, rac$step_completed, installation_control_record,
          local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

  PROCEND rap$delete_previous_cycles;

?? OLDTITLE ??
?? NEWTITLE := 'add_file_to_delete_job', EJECT ??

{ PURPOSE:
{   This procedure adds a file to the special delete job.  The delete job is
{   required for files that were open during the execution of the delete
{   previous cycles step and therefore could not be deleted.
{
{ DESIGN:
{   The special delete job is collected in a file.  If the file is not yet
{   opened, the file is opened and initialized.  In any case the required
{   SCL delete commands are added.
{
{   The user job name for the special delete job will be the job identifier
{   with the command abbreviation replaced by 'DELF'.
{
{ NOTES:
{

  PROCEDURE add_file_to_delete_job
    (    file_cycle_path: fst$file_reference;
         user_min_ring_str: ost$string;
         log_file: fst$file_reference;
         job_identifier: rat$job_identifier;
         delete_job_file: fst$file_reference;
     VAR delete_job_file_opened {input, output} : boolean;
     VAR delete_job_fid {input, output} : amt$file_identifier;
     VAR status: ost$status);


    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      ignore_byte_address: amt$file_byte_address,
      line: string (2000),
      line_length: integer,
      user_job_name: ost$name;


    status.normal := TRUE;

    IF NOT delete_job_file_opened THEN

      { Open the delete job file that will be used for building a special delete job.

      attachment_options [1].selector := fsc$access_and_share_modes;
      attachment_options [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options [1].access_modes.value := $fst$file_access_options
            [fsc$read, fsc$shorten, fsc$append, fsc$modify];
      attachment_options [1].share_modes.selector := fsc$specific_share_modes;
      attachment_options [1].share_modes.value := $fst$file_access_options [];
      attachment_options [2].selector := fsc$create_file;
      attachment_options [2].create_file := TRUE;
      attachment_options [3].selector := fsc$wait_for_attachment;
      attachment_options [3].wait_for_attachment.wait := osc$wait;
      attachment_options [3].wait_for_attachment.wait_time := fsc$longest_wait_time;

      delete_job_file_opened := TRUE;
      fsp$open_file (delete_job_file, amc$record, ^attachment_options, NIL, NIL, NIL, NIL, delete_job_fid,
            status);
      IF NOT status.normal THEN
        delete_job_file_opened := FALSE;
        RETURN;
      IFEND;

      { Assemble the SCL commands that will initialize the delete job's processing.

      user_job_name := job_identifier;
      user_job_name (1, 4) := 'DELF';

      IF jmp$system_job () THEN

         { When the job is submitted from the system console, the system operator utility
         { must be entered in order to task to the minimum ring.  From the system console
         { the minimum ring is 3.  The only way to task to ring 3 is from inside the system
         { operator utility.
         {
         { The version of SOU that resides on the deadstart tape is invoked
         { rather than the $SYSTEM (osf$command_library) version.  This avoids
         { problems that may occur if the $SYSTEM version is obsolete.

?? FMT (FORMAT := OFF) ??
      STRINGREP (line, line_length,
           'JOB ujn=', user_job_name (1, clp$trimmed_string_size (user_job_name)),
           '      odi=', log_file (1, clp$trimmed_string_size (log_file)), ' jc=system; ',
           '  $system.osf$sou_library.system_operator_utility c=system_administration; ',
           '  TASK r=', user_min_ring_str.value (1, user_min_ring_str.size), '; ',
           '    VAR; ',
           '      delete_status: status; ',
           '      ignore_status: status; ',
           '    VAREND');
?? FMT (FORMAT := ON) ??

      ELSE { Job is not a system job. }

         { SYSTEM_OPERATOR_UTILITY is entered taking default capabilities.  The
         { current job could be a batch job that was originally submitted from the
         { console.  In that case tasking to ring 3 is still required.
         { ** This code needs to be updated.

?? FMT (FORMAT := OFF) ??
      STRINGREP (line, line_length,
           'JOB ujn=', user_job_name (1, clp$trimmed_string_size (user_job_name)),
           '      odi=', log_file (1, clp$trimmed_string_size (log_file)), '; ',
           '  $system.osf$sou_library.system_operator_utility; ',
           '  TASK r=', user_min_ring_str.value (1, user_min_ring_str.size), '; ',
           '    VAR; ',
           '      delete_status: status; ',
           '      ignore_status: status; ',
           '    VAREND');
?? FMT (FORMAT := ON) ??

      IFEND;

      amp$put_next (delete_job_fid, ^line, line_length, ignore_byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    IFEND;

    { Add lines to delete the file to the end of the job file.

?? FMT (FORMAT := OFF) ??
    STRINGREP (line, line_length,
          '$system.delete_command_list_entry e=',
                 file_cycle_path (1, clp$trimmed_string_size (file_cycle_path)), ' status=ignore_status; ',
          '$system.set_program_attributes dl=',
                 file_cycle_path (1, clp$trimmed_string_size (file_cycle_path)), ' status=ignore_status; ',
          '$system.delete_file f=',
                 file_cycle_path (1, clp$trimmed_string_size (file_cycle_path)), ' status=delete_status; ',
          'IF NOT delete_status.normal THEN; ',
          '   display_value delete_status o=$job_log; ',
          'IFEND');
?? FMT (FORMAT := ON) ??

    amp$put_next (delete_job_fid, ^line, line_length, ignore_byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND add_file_to_delete_job;

?? OLDTITLE ??
?? NEWTITLE := 'delete_previous_file_cycles', EJECT ??

{ PURPOSE:
{   This procedure deletes the low cycles of a file.
{
{ DESIGN:
{   An array of cycles for the file is obtained.  The cycles array is sorted
{   in decending order, so that makes the first entry the highest.
{
{   Deletion of a file requires that the delete command be executed at a
{   ring equal to or lower than ring 1 for the file.  To simplify processing
{   the procedure tasks down to the minimum ring of the user.
{
{   If a file cycle fails to delete because it is open it is added to the
{   special delete job.  Otherwise, the error is noted and processing
{   continues.
{
{ NOTES:
{   The scratch sequence is defined to be for temporary storage.
{   DELETE_PREVIOUS_FILE_CYCLES calls both RAP$GET_CYCLE_DATA and
{   GET_DELETE_STATUS, which inturn use the scratch sequence to store data.
{   To prevent GET_DELETE_STATUS from overwriting the cycle data a reset is
{   not performed here.  A reset is performed by RAP$GET_CYCLE_DATA.
{

  PROCEDURE delete_previous_file_cycles
    (    file_path: pft$path;
         user_min_ring_str: ost$string;
         log_file: fst$file_reference;
         job_identifier: rat$job_identifier;
         delete_job_file: fst$file_reference;
     VAR delete_job_file_opened {input, output} : boolean;
     VAR delete_job_fid {input, output} : amt$file_identifier;
     VAR scratch_seq_p {input} : ^SEQ ( * );
     VAR status: ost$status);


    VAR
      command_line: string (800),
      command_line_length: integer,
      cycle_number_str: ost$string,
      cycle_selector: pft$cycle_selector,
      cycles_p: pft$p_cycle_array,
      delete_status: ost$status,
      file_cycle_path: fst$path,
      file_ref: rat$path,
      i: integer,
      ignore_status: ost$status,
      local_status: ost$status,
      password: pft$password;


    status.normal := TRUE;
    local_status.normal := TRUE;

    rap$get_cycle_data (file_path, scratch_seq_p, cycles_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$sort_cycles (cycles_p);

    rap$convert_path_to_str (file_path, file_ref);
    file_cycle_path (1, * ) := file_ref.path (1, file_ref.size);
    file_cycle_path (file_ref.size + 1, * ) := '.';

    FOR i := 2 TO UPPERBOUND (cycles_p^) DO

      { Add the cycle number to the file path.

      clp$convert_integer_to_string (cycles_p^ [i].cycle_number, 10, FALSE, cycle_number_str, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      file_cycle_path (file_ref.size + 2, * ) := cycle_number_str.value (1, cycle_number_str.size);

      { Collect the SCL commands required to task down and delete the file cycle.

?? FMT (FORMAT := OFF) ??
    STRINGREP (command_line, command_line_length,
          delete_status_variable, '.normal = TRUE; ',
          'task r=', user_min_ring_str.value (1, user_min_ring_str.size), '; ',
          '  $system.delete_file f=', file_cycle_path (1, clp$trimmed_string_size (file_cycle_path)),
                   ' status=', delete_status_variable, '; ',
          'taskend');
?? FMT (FORMAT := ON) ??

      clp$include_line (command_line (1, command_line_length), TRUE, osc$null_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      get_delete_status (delete_status_variable, scratch_seq_p, delete_status);
      IF NOT delete_status.normal THEN
        IF delete_status.condition = ame$file_not_closed THEN
          add_file_to_delete_job (file_cycle_path, user_min_ring_str, log_file, job_identifier,
                delete_job_file, delete_job_file_opened, delete_job_fid, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], delete_status, ignore_status);
          osp$set_status_abnormal ('RA', rae$file_deletion_errors, '', status);
        IFEND;
      IFEND;

    FOREND;

  PROCEND delete_previous_file_cycles;

?? OLDTITLE ??
?? NEWTITLE := 'delete_previous_subp_cycles', EJECT ??

{ PURPOSE:
{   This procedure deletes the lower file cycles belonging to the files for
{   a subproduct.
{
{ DESIGN:
{   Determining what files belong to the subproduct is accomplished by
{   traversing the element list for the subproduct.  The traverse is
{   performed using recursion and each call to DELETE_PREVIOUS_SUBP_CYCLES
{   moves processing down to the next catalog level.
{
{   Both active and inactive elements are processed.
{
{ NOTES:
{   The scratch sequence is used by a subsequent procedure as temporary
{   storage for file information.
{

  PROCEDURE delete_previous_subp_cycles
    (    element_path: pft$path;
         user_min_ring_str: ost$string;
         log_file: fst$file_reference;
         job_identifier: rat$job_identifier;
         delete_job_file: fst$file_reference;
     VAR delete_job_file_opened {input, output} : boolean;
     VAR delete_job_fid {input, output} : amt$file_identifier;
     VAR element_p {input} : ^rat$element;
     VAR subproduct_info_seq_p {input} : ^rat$subproduct_info_sequence;
     VAR scratch_seq_p {input} : ^SEQ ( * );
     VAR errors_encountered: boolean);


    VAR
      current_element_path_p: ^pft$path,
      first_element_down_p: ^rat$element,
      i: integer,
      ignore_status: ost$status,
      local_status: ost$status;


    { The element_path parameter is the path for the current catalog.  Create
    { a PF format path array that is 1 larger than the size of the element
    { path.  This array will be used to construct the PF paths for the files
    { and subcatalogs that reside in the current catalog.

    PUSH current_element_path_p: [1 .. UPPERBOUND (element_path) + 1];
    FOR i := 1 TO UPPERBOUND (element_path) DO
      current_element_path_p^ [i] := element_path [i];
    FOREND;

    { Process the files and subcatalogs at the current catalog level.

    WHILE element_p <> NIL DO

      current_element_path_p^ [UPPERBOUND (current_element_path_p^)] := element_p^.name;

      IF element_p^.element_type = rac$file THEN

        delete_previous_file_cycles (current_element_path_p^, user_min_ring_str, log_file, job_identifier,
              delete_job_file, delete_job_file_opened, delete_job_fid, scratch_seq_p, local_status);
        IF NOT local_status.normal THEN
          IF local_status.condition <> rae$file_deletion_errors THEN
            osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
          IFEND;
          errors_encountered := TRUE;
        IFEND;

      ELSEIF (element_p^.element_type = rac$catalog) AND (element_p^.element_count <> 0) THEN

        first_element_down_p := #PTR (element_p^.first_element_down_p, subproduct_info_seq_p^);

        delete_previous_subp_cycles (current_element_path_p^, user_min_ring_str, log_file, job_identifier,
              delete_job_file, delete_job_file_opened, delete_job_fid, first_element_down_p,
              subproduct_info_seq_p, scratch_seq_p, errors_encountered);

      IFEND;

      element_p := #PTR (element_p^.next_element_across_p, subproduct_info_seq_p^);
    WHILEND;

  PROCEND delete_previous_subp_cycles;

?? OLDTITLE ??
?? NEWTITLE := 'get_delete_status', EJECT ??

{ PURPOSE:
{   This procedure returns the delete status variable.
{
{ DESIGN:
{
{ NOTES:
{   The scratch sequence is defined to be for temporary storage.
{   DELETE_PREVIOUS_FILE_CYCLES calls both RAP$GET_CYCLE_DATA and
{   GET_DELETE_STATUS, which inturn use the scratch sequence to store data.
{   To prevent GET_DELETE_STATUS from overwriting the cycle data a reset is
{   not performed here.  A reset is performed by RAP$GET_CYCLE_DATA.
{

  PROCEDURE get_delete_status
    (    delete_status_var_name: clt$variable_ref_expression;
     VAR scratch_seq_p: ^SEQ ( * );
     VAR delete_status: ost$status);


    VAR
      access_mode: clt$data_access_mode,
      class: clt$variable_class,
      evaluation_method: clt$expression_eval_method,
      delete_status_p: ^clt$data_value,
      type_specification_p: ^clt$type_specification;


    delete_status.normal := TRUE;

    clp$get_variable (delete_status_var_name, scratch_seq_p, class, access_mode, evaluation_method,
          type_specification_p, delete_status_p, delete_status);
    IF NOT delete_status.normal THEN
      RETURN;
    IFEND;

    delete_status := delete_status_p^.status_value^;

  PROCEND get_delete_status;

?? OLDTITLE ??
?? NEWTITLE := 'get_delete_variables', EJECT ??

{ PURPOSE:
{   This procedure adds contains code for general setup of the delete process.
{
{ DESIGN:
{   The path to the job log is assembled.  The user's minimum ring is
{   obtained, as well as, a unique name for the special delete job file.
{
{ NOTES:
{

  PROCEDURE get_delete_variables
    (    installation_control_record: rat$installation_control_record;
     VAR user_min_ring_str: ost$string;
     VAR delete_job_file: ost$name;
     VAR log_file: rat$path;
     VAR status: ost$status);


    VAR
      installation_identifier: ost$name,
      installation_logs: rat$path,
      log_file_name: ost$name,
      user_minimum_ring: ost$ring;


    status.normal := TRUE;

    { Assemble the path to the job log file found under the installation identifier catalog.

    IF installation_control_record.job_status_record_p <> NIL THEN
      log_file_name := installation_control_record.job_status_record_p^.log_file_name;
    ELSE
      log_file_name := 'JOB_LOG';
    IFEND;

    installation_logs := installation_control_record.processing_header_p^.installation_defaults.
          installation_logs;
    installation_identifier := installation_control_record.processing_header_p^.installation_identifier;

    STRINGREP (log_file.path, log_file.size, installation_logs.path (1, installation_logs.size), '.',
          installation_identifier (1, clp$trimmed_string_size (installation_identifier)),
          '.', log_file_name (1, clp$trimmed_string_size (log_file_name)), '.$eoi');

    { Get the user's minimum ring for tasking purposes.

    user_minimum_ring := avp$ring_min ();
    clp$convert_integer_to_string (user_minimum_ring, 10, FALSE, user_min_ring_str, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Create a unique file name to be used for a special delete job if required.

    pmp$get_unique_name (delete_job_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND get_delete_variables;

?? OLDTITLE ??
?? NEWTITLE := 'purge_special_delete_job_file', EJECT ??

{ PURPOSE:
{   This procedure purges the file used to build the special delete job file.
{
{ DESIGN:
{   The only reason this is a separate procedure is because it is called in
{   two places.
{
{ NOTES:
{

  PROCEDURE purge_special_delete_job_file
    (    delete_job_file: fst$file_reference;
     VAR status: ost$status);


    VAR
      command_line: string (800),
      command_line_length: integer;


    status.normal := TRUE;

    STRINGREP (command_line, command_line_length, '$system.delete_file f=', delete_job_file);

    clp$include_line (command_line (1, command_line_length), TRUE, osc$null_name, status);

  PROCEND purge_special_delete_job_file;

?? OLDTITLE ??
?? NEWTITLE := 'submit_special_delete_job', EJECT ??

{ PURPOSE:
{   This procedure submits the special delete job.
{
{ DESIGN:
{   If the job is submitted from the system console, a 'QUIT' is added to the
{   delete job file to quit out of the system operator utility.  A 'JOBEND'
{   is also added to the delete job file.  The file is closed and submitted.
{   After the job is submitted the file is deleted.
{
{ NOTES:
{

  PROCEDURE submit_special_delete_job
    (    delete_job_file: fst$file_reference;
         delete_job_fid: amt$file_identifier;
     VAR delete_job_file_opened: boolean;
     VAR status: ost$status);


    VAR
      ignore_byte_address: amt$file_byte_address,
      ignore_status: ost$status,
      line: rat$string;


    status.normal := TRUE;

    { Assemble the SCL commands to complete the special cased deletion job.

    IF jmp$system_job () THEN

         { If the job was submitted from the system console, the system operator
         { utility was entered.  A QUIT is added to the job to exit the system
         { operator utility.

?? FMT (FORMAT := OFF) ??
      STRINGREP (line.value, line.length,
           '  TASKEND; ',
           '  QUIT; ',
           'JOBEND');
?? FMT (FORMAT := ON) ??

    ELSE  { Job is not a system job. }

         { SYSTEM_OPERATOR_UTILITY was entered.  A QUIT is needed
         { here as well.  ** This code needs to be updated.

?? FMT (FORMAT := OFF) ??
      STRINGREP (line.value, line.length,
           '  TASKEND; ',
           '  QUIT; ',
           'JOBEND');
?? FMT (FORMAT := ON) ??

    IFEND;

    amp$put_next (delete_job_fid, ^line.value, line.length, ignore_byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$close_file (delete_job_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    delete_job_file_opened := FALSE;

    clp$include_file (delete_job_file, '', osc$null_name, status);

    purge_special_delete_job_file (delete_job_file, ignore_status);

  PROCEND submit_special_delete_job;
MODEND ram$delete_previous_cycles;
*DECK DECK=RAM$DELETE_PROCEDURE EXPAND=TRUE
PROCEDURE (ram$delp) delete_procedure, delete_procedures, delp (
  procedure, procedures, p: list of any of
      name
      integer radix 16
      string
    anyend = $required
  from, f: file = $working_catalog.command_library
  status)

" PURPOSE:
"   Delete the specified modules from a library or object file.
" DESIGN:
"   Scan every module name on the library for the specified value. Write the resulting output, and update
"   the command list when appropriate.
" NOTES:
"   $WORKING_CATALOG.COMMAND_LIBRARY is overwritten when the working catalog is :$LOCAL. An integer
"   procedure value is hexadecimal, convenient for processing CDCNET configuration procedures.
"   A leading or trailing blank constrains the substring match to the beginning or end of a module name.

  VAR
    command_list_altered : status
    delete_status : status
    format : name = library
    library_list : file=$unique(:$local)
    modules_on_file : list 0..$max_list of string = ()
    modules_to_delete : list 0..$max_list of string = ()
    next_cycle : file = from
    specified_name : string 1..31
  VAREND

  IF $file(from, permanent) THEN " create absolute path to cycle $next
    next_cycle=from//$file(from//$next, cycle_number)
  IFEND

  IF ($file(from, fs)= 'DATA') AND ($file(from, fc)= 'LEGIBLE') THEN
    format=scl_proc
  IFEND

  CREATE_OBJECT_LIBRARY
    add_modules library=from
    set_file_attributes file=library_list page_format=continuous file_contents=legible
    display_new_library display_option=none output=library_list alphabetical_order=true
    get_line variable=modules_on_file input=library_list
    delete_file file=library_list
    FOR EACH procedure_specified IN procedures DO ..
          " accumulate (using $union) a list of non-duplicated module names
      IF $generic_type(procedure_specified)= integer THEN " a CDCNET configuration procedure reference
        specified_name=$integer_string(procedure_specified, 16)
      ELSE " a substring of the procedure name was specified
        specified_name=$translate(lower_to_upper, $string(procedure_specified))
      IFEND
      modules_to_delete=$union(modules_to_delete, ..
            $select(modules_on_file, $scan_string(specified_name, ' '//x//' ')>0))
    FOREND
    IF $nil(modules_to_delete) THEN " assign appropriate delete_module status
      delete_modules modules=$apply(procedures, $range_of($program_name(x))) status=delete_status
      IF delete_status.normal THEN " probably specified ALL, should have done delete_file
        generate_library library=next_cycle format=format status=delete_status
      IFEND
    ELSE " generate the resulting library or object file
      put_line line=' Deleting procedures from     '//next_cycle output=$response
      delete_modules modules=$apply(modules_to_delete, $range_of($program_name(x))) status=delete_status
      IF delete_status.normal THEN " account for the modules deleted
        put_lines lines=$apply(modules_to_delete, ' DELETED '//x) output=$response
      IFEND
      delete_command_list_entry entry=from status=command_list_altered
      IF command_list_altered.normal THEN " command list needs updating when processing is complete
        put_line line=' Deleted command list entry   '//from output=$response
      IFEND
      generate_library library=next_cycle format=format status=delete_status
      IF delete_status.normal THEN " summarize action performed
        put_line line=' Deleted '//$justify($integer_string($size(modules_to_delete)), 4, right)//..
' procedures from '//next_cycle output=$response
      IFEND
      IF command_list_altered.normal THEN " update the command list
        IF delete_status.normal THEN " add the new command library
          create_command_list_entry entry=next_cycle
          put_line line=' Created command list entry   '//next_cycle output=$response
        ELSE " restore the old command library
          create_command_list_entry entry=from
          put_line line=' Restored command list entry  '//from output=$response
        IFEND
      IFEND
    IFEND
  QUIT

  EXIT_PROC WITH delete_status

PROCEND delete_procedure
*DECK DECK=RAM$DELETE_PTF EXPAND=TRUE
PROC rap$delete_ptf (
  terminate_active_connections, tac : boolean = false
  status                            : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request deletes the PTF and PTFS applications.
*IFEND


  create_variable command_file k=string v='$local.'//$unique
  create_variable delete_status k=status
  create_variable ignore_status k=status
  create_variable local_status k=status


COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$file_transfer_client tac=$value(terminate_active_connections) ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$file_transfer_client status=delete_status
    IFEND

    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      deactivate_server server=osa$file_transfer_server tac=$value(terminate_active_connections) ..
            status=delete_status
      IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
        delete_server server=osa$file_transfer_server status=delete_status
      IFEND
      IF NOT delete_status.normal AND ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
        delete_status.normal = true
      IFEND
    IFEND

  quit
COLLECT_END

  include_file $fname(command_file) status=local_status
  detach_file $fname(command_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal


PROCEND rap$delete_ptf

*DECK DECK=RAM$DELETE_PTF_FOR_RHFAM EXPAND=TRUE
PROCEDURE delete_ptf_for_rhfam (
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request deactivates and deletes the RHFAM/VE PTF client and
"   server applications.
*IFEND


  VAR
    command_file: file=$unique($local)
    delete_ptf_status: status
    delete_ptfs_status: status
    ignore_status: status
    local_status: status
  VAREND

COLLECT_TEXT output=command_file until='COLLECT_END'
  MANAGE_RHFAM_NETWORK
    deactivate_rhfam_client client=ptf status=delete_ptf_status
    IF delete_ptf_status.normal OR ($condition(delete_ptf_status.condition) = ..
          'RFE$APPL_ALREADY_INACTIVE') THEN
      delete_rhfam_client client=ptf status=delete_ptf_status
    IFEND
  quit
COLLECT_END

  include_file file=command_file status=local_status
  delete_file file=command_file status=ignore_status
  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_ptf_status WHEN NOT delete_ptf_status.normal

  put_line line=' PTF client application deleted for RHFAM/VE' output=$response

COLLECT_TEXT output=command_file until='COLLECT_END'
  MANAGE_RHFAM_NETWORK
    deactivate_rhfam_server server=ptfs status=delete_ptfs_status
    IF delete_ptfs_status.normal OR ($condition(delete_ptfs_status.condition) ..
          = 'RFE$APPL_ALREADY_INACTIVE') THEN
      delete_rhfam_server server=ptfs status=delete_ptfs_status
    IFEND
  quit
COLLECT_END

  include_file file=command_file status=local_status
  delete_file file=command_file status=ignore_status
  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_ptfs_status WHEN NOT delete_ptfs_status.normal

  put_line line=' PTF server application deleted for RHFAM/VE' output=$response

PROCEND delete_ptf_for_rhfam
*DECK DECK=RAM$DELETE_QTF EXPAND=TRUE
PROC rap$delete_qtf (
  terminate_active_connections, ..
  tac                        : boolean = false
  status                     : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request deactivates and deletes the NAM/VE QTF client application.
"   NOTE:  Before issuing this request, the application should be deactivated
"          via DEACTIVATE_QTF
*IFEND


  create_variable command_file kind=string value='$local.'//$unique
  create_variable delete_status kind=status
  create_variable ignore_status kind=status
  create_variable local_status kind=status


COLLECT_TEXT output=$fname(command_file) until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$queue_transfer_client ..
          terminate_active_connections=$value(terminate_active_connections) ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$queue_transfer_client status=delete_status
    IFEND
  quit
COLLECT_END

  include_file file=$fname(command_file) status=local_status
  delete_file file=$fname(command_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal

  put_line line=' QTF client application deleted for NAM/VE' output=$response

PROCEND rap$delete_qtf
*DECK DECK=RAM$DELETE_QTFS EXPAND=TRUE
PROC rap$delete_qtfs (
  terminate_active_connections, ..
  tac                        : boolean = false
  status                     : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request deactivates and deletes the NAM/VE QTF client application.
"   NOTE:  Before issuing this request, the application should be deactivated
"          via DEACTIVATE_QTFS
*IFEND


  create_variable command_file kind=string value='$local.'//$unique
  create_variable delete_status kind=status
  create_variable ignore_status kind=status
  create_variable local_status kind=status


COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_server server=osa$queue_transfer_server ..
          terminate_active_connections=$value(terminate_active_connections) ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_server server=osa$queue_transfer_server status=delete_status
    IFEND

  quit
COLLECT_END

  include_file file=$fname(command_file) status=local_status
  delete_file file=$fname(command_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal

  put_line line=' QTF server application deleted for NAM/VE' output=$response

PROCEND rap$delete_qtfs
*DECK DECK=RAM$DELETE_QTFS_FOR_RHFAM EXPAND=TRUE
PROC delete_qtfs_for_rhfam (
  status : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request deactivates and deletes the RHFAM/VE QTF server application.
*IFEND


  create_variable command_file kind=string value='$local.'//$unique
  create_variable delete_qtfs_status kind=status
  create_variable ignore_status kind=status
  create_variable local_status kind=status

COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  MANAGE_RHFAM_NETWORK
    deactivate_rhfam_server server=qtfs status=delete_qtfs_status
    IF delete_qtfs_status.normal OR ($condition(delete_qtfs_status.condition) ..
          = 'RFE$APPL_ALREADY_INACTIVE') THEN
      delete_rhfam_server server=qtfs status=delete_qtfs_status
    IFEND
    quit
COLLECT_END

  include_file file=$fname(command_file) status=local_status
  delete_file file=$fname(command_file) status=ignore_status
  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_qtfs_status WHEN NOT delete_qtfs_status.normal

  put_line line=' QTF server application deleted for RHFAM/VE' output=$response

PROCEND delete_qtfs_for_rhfam
*DECK DECK=RAM$DELETE_QTF_FOR_RHFAM EXPAND=TRUE
PROC delete_qtf_for_rhfam (
  status : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request deactivates and deletes the RHFAM/VE QTF client application.
*IFEND


  create_variable command_file kind=string value='$local.'//$unique
  create_variable delete_qtf_status kind=status
  create_variable ignore_status kind=status
  create_variable local_status kind=status

COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  MANAGE_RHFAM_NETWORK
    deactivate_rhfam_client client=qtf status=delete_qtf_status
    IF delete_qtf_status.normal OR ($condition(delete_qtf_status.condition) = ..
          'RFE$APPL_ALREADY_INACTIVE') THEN
      delete_rhfam_client client=qtf status=delete_qtf_status
    IFEND
    quit
COLLECT_END

  include_file file=$fname(command_file) status=local_status
  delete_file file=$fname(command_file) status=ignore_status
  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_qtf_status WHEN NOT delete_qtf_status.normal

  put_line line=' QTF client application deleted for RHFAM/VE' output=$response

PROCEND delete_qtf_for_rhfam
*DECK DECK=RAM$DELETE_REXEC EXPAND=TRUE
PROCEDURE rap$delete_rexec (
  terminate_active_connections, tac : boolean = false
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request deletes the REXEC client.
*IFEND

  VAR
    command_file: file = $unique($local)
    delete_status: status
    ignore_status: status
    local_status: status
  VAREND

COLLECT_TEXT command_file until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$rexec_client tac=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$rexec_client status=delete_status
    IFEND

    deactivate_tcpip_application application=osa$rexec_client tas=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$rexec_client status=delete_status
    IFEND

  quit
COLLECT_END

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

PROCEND rap$delete_rexec

*DECK DECK=RAM$DELETE_REXECS EXPAND=TRUE
PROCEDURE rap$delete_rexecs (
  terminate_active_connections, tac : boolean = false
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request deletes the REXEC server.
*IFEND

  VAR
    command_file: file = $unique($local)
    delete_status: status
    ignore_status: status
    local_status: status
  VAREND

COLLECT_TEXT command_file until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$rexec_server tac=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$rexec_server status=delete_status
    IFEND

    deactivate_tcpip_application application=osa$rexec_server tas=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$rexec_server status=delete_status
    IFEND

  quit
COLLECT_END

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

PROCEND rap$delete_rexecs

*DECK DECK=RAM$DELETE_SCF EXPAND=TRUE
PROC rap$delete_scf (
  terminate_active_connections, tac : boolean = false
  status                            : var of status = $optional
  )


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"   This request deletes SCF.
*IFEND


  create_variable command_file k=string v='$local.'//$unique
  create_variable delete_status k=status
  create_variable ignore_status k=status
  create_variable local_status k=status


COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$status_control_fac_client tac=$value(terminate_active_connections) ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$status_control_fac_client status=delete_status
    IFEND

    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status.normal = true
    IFEND

  quit
COLLECT_END

  include_file $fname(command_file) status=local_status
  detach_file $fname(command_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal

PROCEND rap$delete_scf
*DECK DECK=RAM$DELETE_SCFS EXPAND=TRUE
PROC rap$delete_scfs (
  application_name, an              : name = $optional
  terminate_active_connections, tac : boolean = false
  status                            : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request deletes SCFS.
*IFEND


  create_variable command_file k=string v='$local.'//$unique
  create_variable delete_status k=status
  create_variable ignore_status k=status
  create_variable local_status k=status


  application_name = 'osa$status_control_fac_server'

  IF $specified(application_name) THEN
    application_name = $string($value(application_name))
  IFEND

COLLECT_TEXT $fname(command_file) until='COLLECT_END' sm='?'
  $system.osf$command_library.manage_network_applications

    deactivate_server server=?application_name? tac=$value(terminate_active_connections) ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_server server=?application_name? status=delete_status
    IFEND
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status.normal = true
    IFEND

  quit
COLLECT_END

  include_file $fname(command_file) status=local_status
  detach_file $fname(command_file) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal


PROCEND rap$delete_scfs
*DECK DECK=RAM$DELETE_SYSTEM_FILE EXPAND=TRUE
PROC delete_system_file, delete_system_files, delsf (
  files, file, f: list of file = $required
  status)

  create_variable (delete_status internal_status) kind=status
  ring_attributes_list = ':$LOCAL.' // $unique

  FOR i = 1 TO $set_count(files) DO
    file_path = $path($value(files, i), catalog) // '.' // $path($value(files, i), last)
    IF $path($fname(file_path), catalog) = ':$LOCAL' THEN
      cycle = ''
    ELSE
      cycle = '.' // $strrep($file($fname(file_path//'.$low'), cycle_number))
      detach_file $fname(file_path//'.$low') status=internal_status
    IFEND
    display_ring_attributes $fname(file_path//cycle) output=$fname(ring_attributes_list)
    rewind_file $fname(ring_attributes_list)
    include_file $fname(ring_attributes_list)
    detach_file $fname(ring_attributes_list)
    IF ring1 < $ring THEN
      IF ring1 > $ring THEN "write from current ring"
        ring1 = $ring
      IFEND
      IF ring2 < $ring THEN "read/execute from current ring"
        ring2 = $ring
      IFEND
      IF ring3 < $ring THEN "call from current ring"
        ring3 = $ring
      IFEND
COLLECT_TEXT output=delete_file_task.$boi until='**' status=delete_status
      TASK ring=ring1 status=delete_status
        IF delete_status.normal = true THEN
          delete_file $fname(file_path//cycle) status=delete_status
        IFEND
      TASKEND
**
      change_file_attributes delete_file_task ring_attributes=(ring1, ring2, ring3) status=internal_status
      include_file delete_file_task.$boi status=internal_status
      detach_file delete_file_task
    ELSE
      delete_file $fname(file_path//cycle) status=delete_status
    IFEND
    IF delete_status.normal = true THEN
      put_line ' Deleted file '//file_path//cycle output=$response
    ELSEIF $condition(delete_status.condition) = 'PFE$USAGE_NOT_PERMITTED' THEN
      put_line ' You are not permitted to delete file '//file_path//cycle output=$response
    ELSEIF $condition(delete_status.condition) = 'CLE$TASK_TASKEND_RING_BELOW_MIN' THEN
      put_line ' You cannot run at ring '//$strrep(ring1)//' to delete file '//file_path//cycle ..
            output=$response
    ELSE
      display_value delete_status output=$response
    IFEND
  FOREND

PROCEND delete_system_file
*DECK DECK=RAM$DELETE_TFTP EXPAND=TRUE
PROCEDURE rap$delete_tftp (
  terminate_active_connections, tac: boolean = false
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request deletes the TFTP client.
"
*IFEND

  VAR
    command_file: file = $unique($local)
    delete_status: status
    ignore_status: status
    local_status: status
  VAREND

COLLECT_TEXT command_file until='COLLECT_END'
  $system.osf$command_library.MANAGE_NETWORK_APPLICATIONS
    deactivate_client client=osa$tftp_client tac=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$tftp_client status=ignore_status
    IFEND

    deactivate_tcpip_application application=osa$tftp_client tas=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$tftp_client status=ignore_status
    IFEND
  QUIT
COLLECT_END

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

PROCEND rap$delete_tftp
*DECK DECK=RAM$DELETE_TFTPS EXPAND=TRUE
PROCEDURE rap$delete_tftps (
  terminate_active_connections, tac: boolean = false
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request deletes the TFTP server.
"
*IFEND

  VAR
    command_file: file = $unique($local)
    delete_status: status
    ignore_status: status
    local_status: status
  VAREND

COLLECT_TEXT command_file until='COLLECT_END'
  $system.osf$command_library.MANAGE_NETWORK_APPLICATIONS
    deactivate_client client=osa$tftp_server tac=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$tftp_server status=ignore_status
    IFEND

    deactivate_tcpip_application application=osa$tftp_server tas=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$tftp_server status=ignore_status
    IFEND
  QUIT
COLLECT_END

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

PROCEND rap$delete_tftps
*DECK DECK=RAM$DELLIB EXPAND=TRUE
.PROC,DELLIB*I,
R "- Record name (or ALL or *)"        = (ALL=*,*,*F),
T "- Type of record to delete"         = (ABS,CAP,OPL,OPLC,OPLD,OVL,
                                           PP,PPU,PROC,REL,TEXT,ULIB),
L "- Library file name"                = (*N=#FILE,*F),
.
.HELP
 The DELLIB procedure DELetes records from a LIBrary file.
 Requires CATALOG binaries with GENCAT entry point.

 Parameter   Default   Description
   Name       Value

   r                   record to delete (or ALL, or *)
   t                   type of record to delete
  [l]                  library file from which record is deleted

.HELP,R
 The R parameter names the records to delete from a library.
.HELP,T
 The T parameter selects the type of record to delete.
.HELP,L
 The L parameter names the file from which records are deleted.
 The default value is the file containing this procedure.
.ENDHELP
GETFILE,L,L,A=YES.
$GTR,L,YYYDEL2,,,,NA.T/R
$IFE,FILE(YYYDEL2,AS),GOTSOME.
  .IFE,$R$.NE.$*$,RECNAMED.
    $RENAME,R=YYYDEL2.
    UPDVER,DATE+,TIME+,R,L,DELETE.
    $UNLOAD,R.
  .ELSE,RECNAMED.
    $RENAME,T=YYYDEL2.
    UPDVER,DATE+,TIME+,T,L,DELETE.
    $UNLOAD,T.
  .ENDIF,RECNAMED.
  $NOTE(YYYDEL1,NR)+*D T/R
  $PACK(YYYDEL1)
  $REWIND,DISVER.
  $LIBEDIT,P=L,N=L,B=DISVER,#L=YYYYERR,LO=EM,I=YYYDEL1,U=L.
$ELSE,GOTSOME.
  .IFE,FILE(L,.NOT.AS),FILEPRM.
    $UNLOAD,L.
  .ENDIF,FILEPRM.
  .IFE,$R$.NE.$*$,RECNAMED.
    $REVERT,ABORT. T R NOT ON L
  .ELSE,RECNAMED.
    $REVERT,ABORT. NO T RECORDS ON L
  .ENDIF,RECNAMED.
$ENDIF,GOTSOME.
$SKIP,NOERROR.
  $EXIT.
  $REWIND,YYYYERR.
  $COPYEI,YYYYERR,OUTPUT.
  $UNLOAD,YYYDEL2,YYYYERR,ZZZZZG1,ZZZZZG2.
  $UNLOAD,YYYDEL1,YYYSCR2,DISVER.
  .IFE,FILE(L,.NOT.AS),FILEPRM.
    $UNLOAD,L.
  .ENDIF,FILEPRM.
  $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    $EXIT. DELLIB *TERMINATED*
  $ENDIF,TERMINATED.
  $REVERT,ABORT. DELETE L T/R FAILED
$ENDIF,NOERROR.
$UNLOAD,YYYDEL2,YYYYERR,ZZZZZG2.
$UNLOAD,YYYDEL1,YYYSCR2,DISVER.
$IFE,.NOT.((FILE(L,PM)).AND.(FILE(L,WR))),REWRITE.
  REPFILE,L,L,DEFINE=YES.
$ENDIF,REWRITE.
.IFE,FILE(L,.NOT.AS),FILEPRM.
  $UNLOAD,L.
.ELSE,FILEPRM.
  $LIBRARY,L/D.
  $LIBRARY,L/A.
.ENDIF,FILEPRM.
.IFE,$R$.NE.$*$,NOTALL.
  $REVERT. DELETED T R --> L
.ELSE,NOTALL.
  $REVERT. DELETED ALL T --> L
.ENDIF,NOTALL.
/EOR
*DECK DECK=RAM$DELPROC EXPAND=TRUE
.PROC,DELPROC*I,
P "- Procedure name (or ALL or *)"     = (ALL=*,*,*F),
L "- Library file name"                = (*N=#FILE,*F),
.
.HELP
 The DELPROC procedure DELetes PROCedures from a library file.
 Requires CATALOG binaries with GENCAT entry point.

 Parameter   Default   Description
   Name       Value

   p                   procedure to delete (or ALL, or *)
  [l]                  library file from which procedure is deleted

.HELP,P
 The P parameter names the procedure to delete from a library.
.HELP,L
 The L parameter names the file from which procedures are deleted.
 The default value is the file containing this procedure.
.ENDHELP
$REVERT,EX.DELLIB,P,PROC,L.
/EOR
*DECK DECK=RAM$DELTEXT EXPAND=TRUE
.PROC,DELTEXT*I,
T "- Text record name (or ALL or *)"   = (ALL=*,*,*F),
L "- Library file name"                = (*N=#FILE,*F),
.
.HELP
 The DELTEXT procedure DELetes TEXT records from a library file.
 Requires CATALOG binaries with GENCAT entry point.

 Parameter   Default   Description
   Name       Value

   t                   TEXT record to delete (or ALL, or *)
  [l]                  library file from which TEXT record is deleted

.HELP,T
 The T parameter names the TEXT record to delete from a library.
.HELP,L
 The L parameter names the file from which TEXT records are deleted.
 The default value is the file containing this procedure.
.ENDHELP
$REVERT,EX.DELLIB,T,TEXT,L.
/EOR
*DECK DECK=RAM$DETACH_UNIQUE_FILES EXPAND=TRUE
PROCEDURE (ram$detuf) detach_unique_files, detuf (
  catalog, c: file = :$local
  status)

" PURPOSE:
"   Detach uniquely named files.
" DESIGN:
"   Delete temporary files and detach permanent files, the origin of unique file names can be important.
" NOTES:
"   Use CYCLE statement to quickly skip those file names which do not fit the unique name pattern.

  VAR
    detach_status : status
    file_string : string 1..31
    files : list 0..$max_list of file = $catalog_contents(catalog, include_files, paths)
  VAREND

" Process every file name in the catalog for unique name patterns. Multiple cycles are not checked.
  FOR EACH file IN files DO
    file_string=$path(file, last)
    CYCLE WHEN $size(file_string)< 31
    CYCLE WHEN file_string(1, 1) <> '$'
    CYCLE WHEN file_string(11, 1) <> 'S' OR file_string(16, 1) <> 'D' OR file_string(25, 1) <> 'T'
    IF $file(file, permanent) THEN
      $system.detach_file file status=detach_status
      IF detach_status.normal THEN
        put_line ('   DETACHED FILE '//file) output=$response
      IFEND
    ELSE
      $system.delete_file file status=detach_status
      IF detach_status.normal THEN
        put_line ('   DELETED FILE  '//file) output=$response
      IFEND
    IFEND
  FOREND

PROCEND detach_unique_files
*DECK DECK=RAM$DETERMINE_NUMBER_OF_TAPES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'CREATE_ORDER_DEFINITION Subutility: DETERMINE_TAPE_NUMBER Subcommand.' ??
MODULE ram$determine_number_of_tapes;

{ PURPOSE:
{   This module contains the procedures that determine the number of tapes that
{   will be required to write the given pacs catalog.
{
{ DESIGN:
{   The algorithm is the same as that used in WRITE_DEFINITION for determining
{   the number of tapes.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$not_assigned
*copyc rac$order_data_file_name
*copyc rac$packing_list_name
*copyc rac$sif_file_name
*copyc rac$tape_types
*copyc rae$package_software_cc
*copyc amt$file_byte_address
*copyc ost$string
*copyc rat$string
*copyc rat$tape
?? POP ??
*copyc i#current_sequence_position
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc amp$set_segment_eoi
*copyc clp$change_variable
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pfp$define_catalog
*copyc pmp$get_date
*copyc pmp$get_unique_name
*copyc rap$add_name_to_path_ref
*copyc rap$get_file_path_and_ref
*copyc smp$begin_sort_specification
*copyc smp$end_specification
*copyc smp$from_memory_area
*copyc smp$key
*copyc smp$to_memory_area
*copyc rap$open_file
*copyc rav$creod_scratch_segment
*copyc rav$order_contents_count
*copyc rav$order_contents_list_p
*copyc rav$packing_list_header_p
*copyc rav$packing_list_seq_p
*copyc rav$subproduct_type
*copyc rav$tape_information

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    bytes_per_foot_mt9$1600 = 14975,
    bytes_per_foot_mt9$6250 = 49527,
    bytes_per_foot_mt18$38000 = 412962,
    bytes_per_tape_gap_mt9$1600 = (75 * bytes_per_foot_mt9$1600) DIV 100, {9 inch gap}
    bytes_per_tape_gap_mt9$6260 = (75 * bytes_per_foot_mt9$6250) DIV 100,

{9 inch gap

    bytes_per_tape_gap_mt18$38000 = (bytes_per_foot_mt18$38000) DIV 12;

{1 inch gap


?? TITLE := '[XDCL] rap$determine_number_of_tapes', EJECT ??

{ PURPOSE:
{   This is a hidden interface to determine the number of tapes that will be
{   required for the given subproduct list.
{
{ DESIGN:
{   This is the main driver.
{
{   It follows the same process as used by WRITE DEFINITION, except it stops
{   after it has determined the number of tapes.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$determine_number_of_tapes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{  procedure wrid_pdt (
{    number_of_tapes, not: (VAR) integer = $required
{    status: status = $optional
{    )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 4, 19, 16, 35, 40, 485],
    clc$command, 3, 2, 1, 0, 0, 1, 0, ''], [
    ['NOT                            ',clc$abbreviation_entry, 1],
    ['NUMBER_OF_TAPES                ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$optional_parameter, 0
  , 0]],
{ PARAMETER 1
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$number_of_tapes = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      disk_subproduct_indexer_p: ^rat$disk_subproduct_indexer,
      order_catalog_p: ^pft$path,
      order_catalog_ref_p: ^fst$file_reference,
      tape_list_p: ^rat$primary_tape,
      number_of_tapes: clt$variable_reference,
      temp_order_contents_list_p: ^rat$order_contents_list,
      value: clt$data_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF rav$order_contents_count < rac$first_subproduct_entry THEN
      osp$set_status_abnormal ('RA', rae$no_subproducts_ordered, '', status);
      RETURN;
    IFEND;

    IF (rav$packing_list_header_p^.order_medium = rac$tape) AND
          (rav$tape_information.tape_type = 'UNKNOWN') THEN
      osp$set_status_abnormal ('RA', rae$tape_attributes_not_defined, '', status);
      RETURN;
    IFEND;

    RESET rav$creod_scratch_segment.sequence_p TO rav$creod_scratch_segment.reset_p;

    estimate_tape_packing_list_size (rav$packing_list_seq_p, rav$tape_information, rav$order_contents_count,
          rav$order_contents_list_p);

    temp_order_contents_list_p := rav$order_contents_list_p;

    sort_order_contents ('PRIORITY_AND_SIZE', rav$order_contents_count, temp_order_contents_list_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    assign_order_contents_to_tape (rav$tape_information, temp_order_contents_list_p, tape_list_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    value.kind := clc$integer;
    value.integer_value.value := rav$tape_information.number_of_tapes;

    clp$change_variable (pvt [p$number_of_tapes].variable^, ^value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET rav$creod_scratch_segment.sequence_p;

  PROCEND rap$determine_number_of_tapes;


?? TITLE := 'assign_order_contents_to_tape', EJECT ??

{ PURPOSE:
{   This procedure assigns the ordered subproducts and packing list to the
{   required tapes.  The order contents list is returned with the position
{   assigned for each subproduct set.  Also a list of tapes is returned.
{
{ DESIGN:
{   The subproduct tape assignment algorithm uses a best fit approach.
{   The order contents list has previously been sorted by priority and
{   size in decending order.  Looping through the contents list the
{   contents items are added to a tape until it is full or all contents
{   items have been assigned.  Additional tapes are added as required.
{
{     Assumptions and Requirements
{
{     1.  Minimize the number of tapes needed.  The ideal or theoretical
{         number of tapes is the number of tapes required when the
{         subproducts are backed up together as one multi-volume set.
{
{     2.  In general, tapes will be independent backups that can be
{         accessed asynchronously.  The only exception is when a subproduct
{         is too large to fit on a single tape.  Then the tape will become
{         multi-volume, with the additional tape volumes containing only
{         the subproduct in question.
{
{     3.  A subproduct will only be allowed to span across tapes when the
{         subproduct is larger than one tape.
{
{     4.  Files larger than one tape are not an issue since subproducts
{         will be allowed to be larger than one tape.
{
{     5.  When dealing with a subproduct larger than one tape the following
{         rules apply:
{
{           A tape can only be assigned one subproduct belonging to the
{           "too large" category.  A tape assigned a subproduct of this type
{           then is designated as the 1st tape of a multi-volume set.
{           (This means a separate multi-volume set will be defined for
{           each subproduct of type "too large".)
{
{           The subproduct is assigned to as many additional tape volumes
{           as the subproduct can completely fill.  Once the amount left
{           to be assigned is less than a single tape the remainder is
{           assigned to the 1st tape of the multi-volume set.
{
{           The subproduct causing the need for multi-volumes is the only
{           subproduct that can be assigned to the additional tapes of the
{           multi-volume set.
{
{           Additional subproducts are assigned to the 1st tape until the
{           tape is "completed".
{
{           The subproduct of type "too large" must be the last subproduct
{           backed up to the 1st tape of the multi-volume set.  This is
{           accomplished by setting the assigned field (of the "too large"
{           subproduct's contents record) to -1.  Once all the other
{           subproducts have had a chance to be assigned to the tape, the
{           assigned field will be set to the next available value.
{
{     6.  The largest tape size defined will be used in the tape
{         assignment algorithm.  Adjustments to smaller tape sizes (if
{         allowed) will be made after the assignments have been made.  When
{         adjusting a multi-volume tape place the smallest tape as the last
{         tape in the volume.
{
{ NOTES:
{   The tape sizes are assumed to be sorted from largest to smallest.
{   The first tape size is used during the assignment.
{

  PROCEDURE assign_order_contents_to_tape
    (VAR tape_info: rat$tape_information;
     VAR contents_list_p: ^rat$order_contents_list;
     VAR tape_list_p: ^rat$primary_tape;
     VAR status: ost$status);


    CONST
      assigned_last_to_tape = -1;

    VAR
      additional_volume_p: ^rat$additional_volume,
      contents_assigned: integer,
      contents_index: integer,
      bytes_per_tape_gap: integer,
      contents_item_tape_size: integer,
      free_bytes: integer,
      i: integer,
      j: integer,
      max_bytes_per_tape: integer,
      multi_volume: boolean,
      tape_p: ^rat$primary_tape,
      tape_vsn: string (6);


    status.normal := TRUE;

    initialize_tape_assignment (contents_list_p, tape_info, tape_list_p, tape_vsn, max_bytes_per_tape,
          bytes_per_tape_gap);

    contents_assigned := 0;

    WHILE contents_assigned < UPPERBOUND (contents_list_p^) DO

{ One interation will complete the assignment to one tape.

      tape_info.number_of_tapes := tape_info.number_of_tapes + 1;

      free_bytes := max_bytes_per_tape;
      multi_volume := FALSE;

{
{   Search the contents list to find subproducts that have not been
{   assigned to a tape.
{

      FOR i := 1 TO UPPERBOUND (contents_list_p^) DO

        IF contents_list_p^ [i].position_assigned = rac$not_assigned THEN

          contents_item_tape_size := contents_list_p^ [i].size + bytes_per_tape_gap;

{
{   If the size of the subproduct is smaller than the number of bytes
{   left on the tape,
{   assign the subproduct to the tape.
{

          IF contents_item_tape_size <= free_bytes THEN

            contents_assigned := contents_assigned + 1;

{
{   Indicate the position that the subproduct will have on the tape
{   by setting
{   the position assigned to the number of contents that have been
{   assigned.
{

            contents_list_p^ [i].position_assigned := contents_assigned;
            free_bytes := free_bytes - contents_item_tape_size;

          ELSEIF (multi_volume = FALSE) AND (contents_item_tape_size > max_bytes_per_tape) THEN

{
{   Determine if part of the multi volume subproduct can be assigned
{   to the present tape vsn.
{

            IF (contents_item_tape_size MOD max_bytes_per_tape) <= free_bytes THEN

              multi_volume := TRUE;
              contents_list_p^ [i].position_assigned := assigned_last_to_tape;
              free_bytes := free_bytes - (contents_item_tape_size MOD max_bytes_per_tape);
              contents_index := i;

              FOR j := 1 TO (contents_item_tape_size DIV max_bytes_per_tape) DO
                tape_info.number_of_tapes := tape_info.number_of_tapes + 1;
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              FOREND;

            IFEND;

          IFEND;

        IFEND;

      FOREND;

      IF multi_volume = TRUE THEN
        contents_assigned := contents_assigned + 1;
        contents_list_p^ [contents_index].position_assigned := contents_assigned;
      IFEND;

    WHILEND;

  PROCEND assign_order_contents_to_tape;

?? TITLE := 'estimate_tape_packing_list_size', EJECT ??

{ PURPOSE:
{   This procedure estimates the size required for the packing list when the
{   order medium is defined as tape.
{
{ DESIGN:
{   The packing list currently contains the sequence_descriptor,
{   packing_list_header, and the SIF's for all the subproducts ordered.  The
{   sizes for the tape_subproduct_indexer and tape_vsns are estimated and
{   added to the current packing list size.  The estimation for the
{   tape_subproduct_indexer is based on the number of subproducts ordered *
{   the size of the index record.  The estimation for the tape_vsns is based
{   on the size of the tape vsn record * a general guess factor for the
{   number of tapes at the specified tape density.  (The general guess is
{   assuming an order of 400 mega bytes and 2400 foot tapes for 9 track and
{   540 foot tapes for 18 track.)
{
{ NOTES:
{   Contents count includes the packing list.  This is not adjusted when
{   computing the packing_list size.  It is felt that this provides a small
{   cushion for error in the size estimation.
{

  PROCEDURE estimate_tape_packing_list_size
    (    packing_list_seq_p: ^rat$packing_list_sequence;
         tape_info: rat$tape_information;
         contents_count: rat$subproduct_count;
     VAR contents_list_p: ^rat$order_contents_list);


    CONST
      tape_factor_mt9$1600 = 12,
      tape_factor_mt9$6250 = 4,
      tape_factor_mt18$38000 = 2;

    VAR
      subproduct_indexer_size: integer;


    IF tape_info.tape_type = rac$mt9$6250 THEN
      subproduct_indexer_size := (#SIZE (rat$tape_subproduct_index) * contents_count) +
            (#SIZE (rat$tape_vsn) * tape_factor_mt9$6250);
    ELSEIF tape_info.tape_type = rac$mt9$1600 THEN
      subproduct_indexer_size := (#SIZE (rat$tape_subproduct_index) * contents_count) +
            (#SIZE (rat$tape_vsn) * tape_factor_mt9$1600);
    ELSE {tape_type = rac$mt18$38000}
      subproduct_indexer_size := (#SIZE (rat$tape_subproduct_index) * contents_count) +
            (#SIZE (rat$tape_vsn) * tape_factor_mt18$38000);
    IFEND;

    contents_list_p^ [rac$packing_list_entry].size := i#current_sequence_position (packing_list_seq_p) +
          subproduct_indexer_size;

  PROCEND estimate_tape_packing_list_size;

?? TITLE := 'initialize_tape_assignment', EJECT ??

{ PURPOSE:
{   This procedure initializes the variables required by the tape
{   assignment algorithm.
{
{ DESIGN:
{   The usable length in bytes for each tape size is calculated.
{   This is determined by the percent usable value and the tape
{   density.  The usable bytes for the largest tape size becomes the
{   maximum bytes allowed.
{
{   The theoretical number of tapes is calculated for statistical
{   comparision (by others) with the actual tapes required.
{   This value is the number of tapes required when the
{   subproducts are backed up together as one multi-volume set.
{   This is calculated by adding up all the sizes of the order contents
{   and adding the size of a tape file gap for each content item (since
{   each content item will be a discrete backup file on the tape).
{   This is then divided by the maximum bytes for the largest tape.
{   One tape is added to this value to account for a reminder lost
{   using integer division.  Example:
{                            Total bytes in all subproducts = 9,000,000
{                            Total bytes per tape = 2,000,000
{                            9,000,000 DIV 2,000,000 = 4
{                            But 4 tapes will only hold 8,000,000 bytes
{                            So the number of tapes must be 4 + 1 = 5.
{ NOTES:
{   The first tape size on list is the largest.
{
{

  PROCEDURE initialize_tape_assignment
    (    contents_list_p: ^rat$order_contents_list;
     VAR tape_info: rat$tape_information;
     VAR tape_list_p: ^rat$primary_tape;
     VAR tape_vsn: string (6);
     VAR max_bytes_per_tape: integer;
     VAR bytes_per_tape_gap: integer);


    VAR
      i: integer,
      number_of_tapes_theoretical: integer,
      total_bytes: integer,
      usable_feet: integer;


    FOR i := 1 TO UPPERBOUND (tape_info.sizes) DO

      IF tape_info.sizes [i].feet <> 0 THEN
        usable_feet := (tape_info.sizes [i].feet * tape_info.percent_usable) DIV 100;

        IF tape_info.tape_type = rac$mt9$6250 THEN
          tape_info.sizes [i].usable_bytes := usable_feet * bytes_per_foot_mt9$6250;
        ELSEIF tape_info.tape_type = rac$mt9$1600 THEN
          tape_info.sizes [i].usable_bytes := usable_feet * bytes_per_foot_mt9$1600;
        ELSE { tape type = rac$mt18$38000 }
          tape_info.sizes [i].usable_bytes := usable_feet * bytes_per_foot_mt18$38000;
        IFEND;

      IFEND;

    FOREND;

    max_bytes_per_tape := tape_info.sizes [1].usable_bytes;

    IF tape_info.tape_type = rac$mt9$6250 THEN
      bytes_per_tape_gap := bytes_per_tape_gap_mt9$6260;
    ELSEIF tape_info.tape_type = rac$mt9$1600 THEN
      bytes_per_tape_gap := bytes_per_tape_gap_mt9$1600;
    ELSE { tape type = rac$mt18$38000 }
      bytes_per_tape_gap := bytes_per_tape_gap_mt18$38000;
    IFEND;

    total_bytes := 0;
    FOR i := 1 TO UPPERBOUND (contents_list_p^) DO
      total_bytes := total_bytes + contents_list_p^ [i].size + bytes_per_tape_gap;
    FOREND;

    number_of_tapes_theoretical := total_bytes DIV max_bytes_per_tape + 1;

    tape_info.number_of_tapes := 0;
    tape_info.number_of_primary_tapes := 0;
    tape_info.number_of_multi_vol_sets := 0;
    tape_info.number_of_tapes_theoretical := number_of_tapes_theoretical;

    tape_list_p := NIL;
    tape_vsn := '';

  PROCEND initialize_tape_assignment;

?? TITLE := 'sort_order_contents', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to sort the order contents list by
{   the specified keys (fields).
{
{ DESIGN:
{   The sorting is performed by the standard NOS/VE Sort/Merge interfaces.
{   The sort_key parameter defines the type of sort that is performed.
{   The supported sorts are:
{
{     1. Sort by priority and size fields.  This sort is done prior to
{        the assignment of the contents list to tape.  The tape assignment
{        algorithm requires the contents list to be sorted in this way.
{
{     2. Sort by position assigned.  Once the contents has been assigned
{        this sort puts the contents list into the correct assignment order
{        for writing the order data file and packing list's
{        tape subproduct_indexer.
{
{   The contents list is rewritten to a new location within the scratch
{   segment.  The pointer to the contents list is reset to point to the
{   new (sorted) contents list.
{
{ NOTES:
{   The result_array is used by the sorting interfaces to return status
{   information about the sort.  At this time, this information is being
{   ignored.
{

  PROCEDURE sort_order_contents
    (    sort_key: string ( * <= osc$max_name_size);
         contents_count: rat$subproduct_count;
     VAR contents_list_p: ^rat$order_contents_list;
     VAR status: ost$status);


    VAR
      new_contents_list_p: ^rat$order_contents_list,
      order_catalog_p: ^pft$path,
      result_array: smt$info_array;


    status.normal := TRUE;
    result_array [1] := 0; {Number of result elements returned in this array.}

    NEXT new_contents_list_p: [1 .. contents_count] IN rav$creod_scratch_segment.sequence_p;
    IF new_contents_list_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    smp$begin_sort_specification (result_array, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    smp$from_memory_area (#LOC (contents_list_p^), 'FIXED', #SIZE (rat$order_contents), contents_count,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    smp$to_memory_area (#LOC (new_contents_list_p^), 'FIXED', #SIZE (rat$order_contents), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF sort_key = 'PRIORITY_AND_SIZE' THEN

      smp$key (1, #SIZE (rat$subproduct_priority), 'INTEGER', 'D', status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      smp$key ((1 + #SIZE (rat$subproduct_priority)), #SIZE (rat$subproduct_size), 'INTEGER', 'D', status);

    ELSE { sort_key = 'POSITION_ASSIGNED' }

      smp$key ((1 + #SIZE (rat$subproduct_priority) + #SIZE (rat$subproduct_size)),
            #SIZE (rat$position_assigned), 'INTEGER', 'A', status);

    IFEND;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    smp$end_specification (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    contents_list_p := new_contents_list_p;

  PROCEND sort_order_contents;

MODEND ram$determine_number_of_tapes;
*DECK DECK=RAM$DEVELOPMENT_DCFILE EXPAND=TRUE
*copy ram$released_dcfile
DCF02
"--------------------------------------------------------------------------"
"  DEADSTART COMMAND FILE FOR C960-102  S/N 102. OWNED BY NOS/VE CLOSED    "
"           SHOP SUPPORT TO BE USED FOR NORMAL CLOSED SHOP USAGE           "
"--------------------------------------------------------------------------"
"     On NOS:  DOWN,CH33 and/or DOWN,CH13 for the VE tape drives.          "
"          NOS/VE system device is S87A00 (Unit 0 on CCH8A)                "
"--------------------------------------------------------------------------"
USE_CONFIGURATION_PROLOG COBALT_CLOSED_SHOP
SET_SYSTEM_ATTRIBUTE JOB_RECOVERY_OPTION 0
SET_SYSTEM_ATTRIBUTE MAXIMUM_SEGMENT_LENGTH 300000000
SET_SYSTEM_ATTRIBUTE MAXIMUM_KNOWN_JOBS 500
SET_SYSTEM_ATTRIBUTE MAXIMUM_OUTPUT_FILES 300
SET_SYSTEM_ATTRIBUTE MAXIMUM_JOB_CLASSES 150
SET_SYSTEM_ATTRIBUTE MAXIMUM_SERVICE_CLASSES 20
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_SYSTEM_ATTRIBUTE DEBUG_JOB_RECOVERY 1
SET_SYSTEM_ATTRIBUTE ENABLE_PM_DEBUG_LOGGING 1
SET_SYSTEM_ATTRIBUTE ENABLE_QUEUE_FILE_ACCESS 1
SET_SYSTEM_ATTRIBUTE SPECIAL_TRAP 1
SET_SYSTEM_ATTRIBUTE USER_TEMPLATES 1
SET_SECURITY_OPTION SECURITY_AUDIT ON
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
"**********************  E N D   O F   D C F 0 2   ************************"
DCF03
"UNUSED"
DCF04
"--------------------------------------------------------------------------"
"  DEADSTART COMMAND FILE FOR C180-963  S/N 101. OWNED BY NOS/VE CLOSED    "
"           SHOP SUPPORT TO BE USED FOR NORMAL CLOSED SHOP USAGE           "
"--------------------------------------------------------------------------"
"           NOS/VE system device is S87A00 (unit 0 on CH17A                "
"--------------------------------------------------------------------------"
USE_CONFIGURATION_PROLOG COPPER_CLOSED_SHOP
SETSA JOB_RECOVERY_OPTION 0
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SETSA MAXIMUM_SEGMENT_LENGTH 300000000
SET_SYSTEM_ATTRIBUTE MAXIMUM_JOB_CLASSES 150
SET_SYSTEM_ATTRIBUTE MAXIMUM_OUTPUT_FILES 300
SET_SYSTEM_ATTRIBUTE MAXIMUM_SERVICE_CLASSES 20
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_SYSTEM_ATTRIBUTE DEBUG_JOB_RECOVERY 1
SET_SYSTEM_ATTRIBUTE ENABLE_PM_DEBUG_LOGGING 1
SET_SYSTEM_ATTRIBUTE SPECIAL_TRAP 1
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
"**********************  E N D   O F   D C F 0 4   ************************"
DCF05
"UNUSED"
DCF06
"--------------------------------------------------------------------------"
"  DEADSTART COMMAND FILE FOR C180-990  S/N 102. OWNED BY NOS/VE CLOSED    "
"           SHOP SUPPORT TO BE USED FOR NORMAL CLOSED SHOP USAGE           "
"--------------------------------------------------------------------------"
"               On NOS:  DOWN,CH31 for the NOS/VE TAPE drives              "
"--------------------------------------------------------------------------"
USE_CONFIGURATION_PROLOG SN102_CLOSED_SHOP
SET_SYSTEM_ATTRIBUTE JOB_RECOVERY_OPTION 0
SET_SYSTEM_ATTRIBUTE MAXIMUM_SEGMENT_LENGTH 300000000
SET_SYSTEM_ATTRIBUTE MAXIMUM_KNOWN_JOBS 500
SET_SYSTEM_ATTRIBUTE MAXIMUM_JOB_CLASSES 150
SET_SYSTEM_ATTRIBUTE MAXIMUM_SERVICE_CLASSES 20
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_SYSTEM_ATTRIBUTE DEBUG_JOB_RECOVERY 1
SET_SYSTEM_ATTRIBUTE ENABLE_PM_DEBUG_LOGGING 1
SET_SYSTEM_ATTRIBUTE ENABLE_QUEUE_FILE_ACCESS 1
SET_SYSTEM_ATTRIBUTE SPECIAL_TRAP 1
SET_SYSTEM_ATTRIBUTE USER_TEMPLATES 1
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
"**********************  E N D   O F   D C F 0 6   ************************"
DCF07
"--------------------------------------------------------------------------"
"  DEADSTART COMMAND FILE FOR CYBER 960 S/N 254. OWNED BY NOS/VE CLOSED    "
"           SHOP SUPPORT TO BE USED FOR NORMAL CLOSED SHOP USAGE           "
"--------------------------------------------------------------------------"
" USECP SN254_CLOSED_SHOP / CCH0A EQ0 - UN 0 = SYSTEM DISK - INITDD S53C00 "
"--------------------------------------------------------------------------"
USE_CONFIGURATION_PROLOG SN254_CLOSED_SHOP
SET_SYSTEM_ATTRIBUTE JOB_RECOVERY_OPTION 0
SET_SYSTEM_ATTRIBUTE MAXIMUM_SEGMENT_LENGTH 300000000
SET_SYSTEM_ATTRIBUTE MAXIMUM_OUTPUT_FILES 300
SET_SYSTEM_ATTRIBUTE MAXIMUM_KNOWN_JOBS 500
SET_SYSTEM_ATTRIBUTE MAXIMUM_JOB_CLASSES 150
SET_SYSTEM_ATTRIBUTE MAXIMUM_SERVICE_CLASSES 20
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_SYSTEM_ATTRIBUTE NAMVE_DEBUG_MODE 1
SET_SYSTEM_ATTRIBUTE DEBUG_JOB_RECOVERY 1
SET_SYSTEM_ATTRIBUTE ENABLE_PM_DEBUG_LOGGING 1
SET_SYSTEM_ATTRIBUTE USER_TEMPLATES 1
SET_SYSTEM_ATTRIBUTE ENABLE_QUEUE_FILE_ACCESS 1
SET_SECURITY_OPTION SECURITY_AUDIT ON
"**********************  E N D   O F   D C F 0 7   ************************"
DCF10
"--------------------------------------------------------------------------"
"  DEADSTART COMMAND FILE FOR C180-990  S/N 102. OWNED BY NOS/VE SYSTEM    "
"  EVALUATION TO BE USED FOR BYOPS TESTING AND HANDS-ON / SHORT SHOT USAGE "
"--------------------------------------------------------------------------"
" USECP SN102_885_2X4  / CH03 - EQ0 - UN32 = SYSTEM DISK - INITDD VSNB40   "
"  (Uses 885 chan pair B (ch03 and ch04 - units 32,33,34,35)               "
" USECP SN102_887_2x2  / CCH7A- EQ0 - UN0  = SYSTEM DISK - INITDD VSN7A0   "
" USECP SN102_887_2X4  / CCH7A- EQ0 - UN0  = SYSTEM DISK - INITDD VSN7A0   "
"--------------------------------------------------------------------------"
SET_SYSTEM_ATTRIBUTE DEVELOPMENT_DEADSTART 1
SET_SYSTEM_ATTRIBUTE NETWORK_ACTIVATION 0
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
USE_CONFIGURATION_PROLOG SN102_885_2X4
SET_INSTALLATION_TAPE PRODUCTS 'VEPT01' 'VEPT01'
"**********************  E N D   O F   D C F 1 0   ************************"
DCF11
"---------------------------------------------------------------------------"
"   DEADSTART COMMAND FILE FOR C190-960  S/N 102. OWNED BY NOS/VE SYSTEM    "
"         EVALUATION TO BE USED FOR BYOPS TESTING AND HANDS-ON              "
"* You CANNOT use the cobalt_byops_xmd_2x8 prolog if VIOLET or PEWTER is   *"
"* using Open Shop XMD devices.  You MUST check with the user on PEWTER    *"
"* and VIOLET to ensure your use of XMDs does not conflict with theirs.    *"
" USECP COBALT_BYOPS_XMD_2X8 / CCH7B / CCH7B-EQ2-UN0    (INISD,VSN000)      "
" USECP COBALT_XMD_1X4       / CCH7B / CCH7B-EQ2-UN0    (INISD,VSN000)      "
"---------------------------------------------------------------------------"
SET_SYSTEM_ATTRIBUTE DEVELOPMENT_DEADSTART 1
SET_SYSTEM_ATTRIBUTE NETWORK_ACTIVATION 0
SET_SYSTEM_ATTRIBUTE UNLOAD_DEADSTART_TAPE 0
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_INSTALLATION_TAPE PRODUCTS 'VEPT01' 'VEPT01'
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
USE_CONFIGURATION_PROLOG COBALT_XMD_1X4
"***********************  E N D   O F   D C F 1 1   ************************"
DCF12
"UNUSED"
DCF13
"--------------------------------------------------------------------------"
"  DEADSTART COMMAND FILE FOR C180-830  S/N 649. OWNED BY NOS/VE CLOSED    "
"           SHOP SUPPORT TO BE USED FOR NORMAL CLOSED SHOP USAGE           "
"--------------------------------------------------------------------------"
" USECP SN649_CLOSED_SHOP / CH6 - EQ0 - UN0  = SYSTEM DISK - INITDD s36B00 "
"--------------------------------------------------------------------------"
USE_CONFIGURATION_PROLOG TOTO_CLOSED_SHOP
SET_SYSTEM_ATTRIBUTE JOB_RECOVERY_OPTION 0
SET_SYSTEM_ATTRIBUTE MAXIMUM_SEGMENT_LENGTH 300000000
SET_SYSTEM_ATTRIBUTE MAXIMUM_KNOWN_JOBS 500
SET_SYSTEM_ATTRIBUTE MAXIMUM_OUTPUT_FILES 300
SET_SYSTEM_ATTRIBUTE MAXIMUM_JOB_CLASSES 150
SET_SYSTEM_ATTRIBUTE MAXIMUM_SERVICE_CLASSES 20
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_SYSTEM_ATTRIBUTE NAMVE_DEBUG_MODE 1
SET_SYSTEM_ATTRIBUTE DEBUG_JOB_RECOVERY 1
SET_SYSTEM_ATTRIBUTE ENABLE_PM_DEBUG_LOGGING 1
SET_SYSTEM_ATTRIBUTE ENABLE_QUEUE_FILE_ACCESS 1
SET_SECURITY_OPTION OPTION=SECURITY_AUDIT VALUE=ON
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
"**********************  E N D   O F   D C F 1 3   ************************"
DCF14
"UNUSED"
DCF15
"UNUSED"
DCF16
"UNUSED"
DCF17
"RESERVED FOR NOS/VE SYSTEM EVALUATION"
DCF20
"UNUSED"
DCF21
"RESERVED FOR NOS/VE SYSTEM EVALUATION"
DCF22
"RESERVED FOR NOS/VE SYSTEM EVALUATION"
DCF23
"---------------------------------------------------------------------------"
"   DEADSTART COMMAND FILE FOR C180-830  S/N 649.                           "
"---------------------------------------------------------------------------"
"---------------------------------------------------------------------------"
" USECP SILVER_ISD1_2X4     / CH0 & 16      /CH0 / EQ0 /UN0 =DS DISK-VSN000 "
" USECP SILVER_ISD1_4X8     / CH0,06,16,& 22/CH0 / EQ0 /UN0 =DS DISK-VSN000 "
"---------------------------------------------------------------------------"
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
USECP SILVER_ISD1_4x8
"***********************  E N D   O F   D C F 2 3   ************************"
DCF24
"UNUSED"
DCF25
"UNUSED"
DCF26
"UNUSED"
DCF27
"UNUSED"
DCF30
"UNUSED"
DCF31
"RESERVED FOR NOS/VE SYSTEM EVALUATION"
"---------------------------------------------------------------------------"
"   DEADSTART COMMAND FILE FOR C180-860  S/N 341. OWNED BY NOS/VE SYSTEM    "
"   EVALUATION TO BE USED FOR HANDS-ON / SHORT SHOT USAGE ON THE ES MACHINE."
" USECP EST_860_A    | CH1 AND 2 | FMD (885) UNITS 42/43 | (INISD,V88542)   "
" USECP EST_860_B    | CH3       | 895'S UNITS 0-3       | (INISD,V89500)   "
"---------------------------------------------------------------------------"
SET_SYSTEM_ATTRIBUTE DEVELOPMENT_DEADSTART 1
SET_SYSTEM_ATTRIBUTE NETWORK_ACTIVATION 0
SET_SYSTEM_ATTRIBUTE UNLOAD_DEADSTART_TAPE 0
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_INSTALLATION_TAPE PRODUCTS 'VEPT01' 'VEPT01'
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
USE_CONFIGURATION_PROLOG EST_860_A
"***********************  E N D   O F   D C F 3 1   ************************"
DCF32
"RESERVED FOR NOS/VE SYSTEM EVALUATION"
"---------------------------------------------------------------------------"
"   DEADSTART COMMAND FILE FOR C180-860  S/N 311. OWNED BY NOS/VE SYSTEM    "
"   DEVELOPERS TO BE USED FOR HANDS ON USAGE                                "
"***             On NOS:  DOWN,CH32(8) for TAPE UNITS 70, 71, 72, & 73.  ***"
" USECP GRAY_OPEN_USAGE                   CCH3B  -  UN00  (INISD,VSN000)    "
"---------------------------------------------------------------------------"
SET_SYSTEM_ATTRIBUTE DEVELOPMENT_DEADSTART 1
SET_SYSTEM_ATTRIBUTE NETWORK_ACTIVATION 0
SET_SYSTEM_ATTRIBUTE UNLOAD_DEADSTART_TAPE 0
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_INSTALLATION_TAPE PRODUCTS 'VEPT01' 'VEPT01'
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
USE_CONFIGURATION_PROLOG GRAY_OPEN_USAGE
"***  SETIT PRODUCT 'rvsn'                                               ***"
"***********************  E N D   O F   D C F 3 2   ************************"
DCF33
"RESERVED FOR SN302 - NOS/VE SYSTEM EVALUATION"
DCF34
"RESERVED FOR NOS/VE SYSTEM EVALUATION"
"---------------------------------------------------------------------------"
"   DEADSTART COMMAND FILE FOR C180-830  S/N 604. OWNED BY NOS/VE SYSTEM    "
"   EVALUATION TO BE USED FOR BYOPS TESTING AND HANDS-ON / SHORT SHOT USAGE "
"---------------------------------------------------------------------------"
"        On NOS:  DOWN,CH23 for TAPE UNITS 50&51                            "
"---------------------------------------------------------------------------"
" USECP SN604_ISD2_2X4   /CH16&22 /CH16-EQ1-UN2 (INISD VSN012)              "
" USECP SN604_ISD2_1X2   /CH16    /CH16-EQ1-UN2 (INISD VSN012)              "
"---------------------------------------------------------------------------"
SET_SYSTEM_ATTRIBUTE DEVELOPMENT_DEADSTART 1
SET_SYSTEM_ATTRIBUTE NETWORK_ACTIVATION 0
SET_SYSTEM_ATTRIBUTE UNLOAD_DEADSTART_TAPE 0
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
USECP SN604_ISD2_2X4
SET_INSTALLATION_TAPE PRODUCTS 'VEPT01' 'VEPT01'
"***********************  E N D   O F   D C F 3 4   ************************"
DCF35
"RESERVED FOR NOS/VE SYSTEM EVALUATION"
"---------------------------------------------------------------------------"
"   DEADSTART COMMAND FILE FOR C180-810  S/N 604. OWNED BY NOS/VE SYSTEM    "
"   EVALUATION TO BE USED FOR BYOPS TESTING AND HANDS-ON / SHORT SHOT USAGE "
"---------------------------------------------------------------------------"
"        On NOS:  DOWN,CH32 - TAPE                                          "
"---------------------------------------------------------------------------"
" USECP SN604_ISD2_2X4_810  / CH16&22       / CH16/EQ1 /UN2 =DS DISK-VSN012 "
"---------------------------------------------------------------------------"
SET_SYSTEM_ATTRIBUTE DEVELOPMENT_DEADSTART 1
SET_SYSTEM_ATTRIBUTE NETWORK_ACTIVATION 0
SET_SYSTEM_ATTRIBUTE UNLOAD_DEADSTART_TAPE 0
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
USECP SN604_ISD2_2X4_810
SET_INSTALLATION_TAPE PRODUCTS 'VEPT01' 'VEPT01'
"***********************  E N D   O F   D C F 3 5   ************************"
DCF36
"RESERVED FOR NOS/VE SYSTEM EVALUATION"
"---------------------------------------------------------------------------"
"   DEADSTART COMMAND FILE FOR C180-830  S/N 604. OWNED BY NOS/VE SYSTEM    "
"   EVALUATION TO BE USED FOR BYOPS TESTING AND HANDS-ON / SHORT SHOT USAGE "
"---------------------------------------------------------------------------"
"   *********************************************************************** "
"   *  DCFILE FOR THE PERMANENT FILE BASE.                                * "
"   *  D O  N O T  E N T E R  T H E  I N I S D   C O M M A N D!!!!        * "
"   *              *************************************                  * "
"   *  AT SYSTEM CORE COMMAND PROMPT --- ENTER   A U T O   ONLY!!!!       * "
"   *  AT SYSTEM CORE COMMAND PROMPT --- ENTER   A U T O   ONLY!!!!       * "
"   *  AT SYSTEM CORE COMMAND PROMPT --- ENTER   A U T O   ONLY!!!!       * "
"   *********************************************************************** "
SET_SYSTEM_ATTRIBUTE DEVELOPMENT_DEADSTART 1
SET_SYSTEM_ATTRIBUTE NETWORK_ACTIVATION 1
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_SYSTEM_ATTRIBUTE UNLOAD_DEADSTART_TAPE 0
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
USECP SN604_FMD_1X2
SET_INSTALLATION_TAPE PRODUCTS 'VEPT01' 'VEPT01'
"***********************  E N D   O F   D C F 3 6   ************************"
DCF37
"UNUSED"
DCF40
"UNUSED"
DCF41
"UNUSED"
DCF42
"UNUSED"
DCF43
"UNUSED"
DCF44
"UNUSED"
DCF45
"RESERVED FOR NOS/VE SYSTEM EVALUATION"
"--------------------------------------------------------------------------"
"  DEADSTART COMMAND FILE FOR C180-930  S/N 121. OWNED BY OPEN SHOP LAB    "
"  SUPPORT ANALYST TO BE USED FOR PERFORMANCE RUNS BY SYSTEM EVALUATION    "
"--------------------------------------------------------------------------"
" USECP PEWTER_PERF_1X4  / CH1   /   CH1-EQ4-UN0      (INISD,S83640)       "
" USECP PEWTER_PERF_11   / CH1   /   CH1-EQ4-UN0      (INISD,S83640)       "
" USECP PEWTER_PERF_31   / CH1   /   CH1-EQ4-UN0      (INISD,S83640)       "
"--------------------------------------------------------------------------"
SET_SYSTEM_ATTRIBUTE DEVELOPMENT_DEADSTART 1
SET_SYSTEM_ATTRIBUTE NETWORK_ACTIVATION 0
SET_SYSTEM_ATTRIBUTE UNLOAD_DEADSTART_TAPE 0
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
SET_INSTALLATION_TAPE PRODUCTS 'VEPT01' 'VEPT01'
USE_CONFIGURATION_PROLOG PEWTER_PERF_11
"**********************  E N D   O F   D C F 4 5   ************************"
DCF46
"RESERVED FOR NOS/VE SYSTEM EVALUATION"
"--------------------------------------------------------------------------"
"  DEADSTART COMMAND FILE FOR C190-930  S/N 121. OWNED BY OPEN SHOP LAB    "
"  SUPPORT ANALYST TO BE USED FOR NORMAL SHARED USAGE CLOSED SHOP          "
"--------------------------------------------------------------------------"
" USECP PEWTER_SHARED_LAB  / CH3        / CH3-EQ0-UN0 (INISD,S98530)       "
"--------------------------------------------------------------------------"
SET_SECURITY_OPTION SECURITY_AUDIT ON
SET_SYSTEM_ATTRIBUTE CATALOG_NAME_SECURITY 0
SET_SYSTEM_ATTRIBUTE DEBUG_JOB_RECOVERY 1
SET_SYSTEM_ATTRIBUTE DISABLE_NETWORK_RELAYS 1
SET_SYSTEM_ATTRIBUTE MAXIMUM_JOB_CLASSES 20
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_SYSTEM_ATTRIBUTE UNLOAD_DEADSTART_TAPE 0
SET_SYSTEM_ATTRIBUTE USER_TEMPLATES 1
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
USE_CONFIGURATION_PROLOG PEWTER_SHARED_LAB
"**********************  E N D   O F   D C F 4 6   ************************"
DCF47
"RESERVED FOR NOS/VE SYSTEM EVALUATION"
"--------------------------------------------------------------------------"
"  DEADSTART COMMAND FILE FOR C180-930  S/N 121. OWNED BY OPEN SHOP LAB    "
"  SUPPORT ANALYST TO BE USED FOR HANDS ON AND BLOCK TIME USAGE            "
"--------------------------------------------------------------------------"
" USECP PEWTER_OPEN_USAGE  / CH1 / CH1-EQ0-UN0      (INISD,SXMD0)  "
"--------------------------------------------------------------------------"
SET_SYSTEM_ATTRIBUTE DEVELOPMENT_DEADSTART 1
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_SYSTEM_ATTRIBUTE UNLOAD_DEADSTART_TAPE 0
SET_INSTALLATION_TAPE PRODUCTS 'VEPT01' 'VEPT01'
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
USE_CONFIGURATION_PROLOG PEWTER_OPEN_USAGE
"**********************  E N D   O F   D C F 4 7   ************************"
DCF50
"UNUSED"
DCF51
"UNUSED"
DCF52
"RESERVED FOR NOS/VE SYSTEM EVALUATION"
DCF53
"UNUSED"
DCF54
"UNUSED"
DCF55
"UNUSED"
DCF56
"UNUSED"
DCF57
"UNUSED"
DCF60
"UNUSED"
DCF61
"--------------------------------------------------------------------------"
"  DEADSTART COMMAND FILE FOR C180_930 SN 114. OWNED BY ADNOPS.            "
"  TO BE USED FOR NORMAL CLOSED SHOP USAGE, OR BLOCK TIME USAGE.           "
"--------------------------------------------------------------------------"
" USECP NAVY_ISD2_3X4   NORMAL CLOSED SHOP USAGE.                          "
" USECP NAVY_ISD2_2X2   BLOCK TIME USAGE.                                  "
"--------------------------------------------------------------------------"
SET_SYSTEM_ATTRIBUTE DEVELOPMENT_DEADSTART 1
SET_SYSTEM_ATTRIBUTE NETWORK_ACTIVATION 1
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
USECP NAVY_ISD2_3X4   NORMAL CLOSED SHOP USAGE.                          "
SET_INSTALLATION_TAPE PRODUCTS 'VEPT01' 'VEPT01'
"***  SETIT PRODUCT 'rvsn'                                              ***"
DCF62
"--------------------------------------------------------------------------"
"  DEADSTART COMMAND FILE FOR C180_930 SN 114. OWNED BY FASTLINK PROJECT   "
"  TO BE USED FOR CLOSED SHOP ON THE ALTERNATE DISK SET.                   "
"--------------------------------------------------------------------------"
" USECP NAVY_ISD2_2X2   CLOSED SHOP USAGE.                                  "
"--------------------------------------------------------------------------"
SET_SYSTEM_ATTRIBUTE DEVELOPMENT_DEADSTART 1
SET_SYSTEM_ATTRIBUTE NETWORK_ACTIVATION 1
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_TIME_ZONE -6 0 False
USECP NAVY_ISD2_2X2   CLOSED SHOP USAGE.                                  "
SET_INSTALLATION_TAPE PRODUCTS 'VEPT01' 'VEPT01'
"***  SETIT PRODUCT 'rvsn'                                              ***"
"************************ E N D  O F  D C F 6 2 ***************************"
DCF63
"UNUSED"
DCF64
"UNUSED"
DCF65
"UNUSED"
DCF66
"UNUSED"
DCF67
"UNUSED"
DCF70
"UNUSED"
DCF71
"RESERVED FOR NOS/VE SYSTEM EVALUATION"
"--------------------------------------------------------------------------"
" DEADSTART COMMAND FILE FOR C180-835 S/N 104.  OWNED BY CDCNET EVALUATION "
"         TO BE USED FOR CDCNET SHORTLOOKS AND OTHER CDCNET TESTING        "
"--------------------------------------------------------------------------"
"      USECP MAUVE_SHORTLOOKS / CH0 units46&47 & CH21 units46&47           "
"      INISD S88500                                                        "
"--------------------------------------------------------------------------"
SET_SECURITY_OPTION SECURITY_AUDIT ON
SET_SYSTEM_ATTRIBUTE DEBUG_JOB_RECOVERY 1
SET_SYSTEM_ATTRIBUTE DISABLE_NETWORK_RELAYS 1
SET_SYSTEM_ATTRIBUTE MAXIMUM_JOB_CLASSES 20
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_SYSTEM_ATTRIBUTE UNLOAD_DEADSTART_TAPE 0
SET_SYSTEM_ATTRIBUTE USER_TEMPLATES 1
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
USE_CONFIGURATION_PROLOG MAUVE_SHORTLOOKS
"**********************  E N D   O F   D C F 7 1   ************************"
DCF72
"RESERVED FOR NOS/VE SYSTEM EVALUATION"
"--------------------------------------------------------------------------"
"  DEADSTART COMMAND FILE FOR C180-860  S/N 302. OWNED BY CDCNET LAB       "
"               SUPPORT TO BE USED FOR NORMAL SHARED LAB USAGE             "
"--------------------------------------------------------------------------"
"       USECP MAUVE_SHARED_LAB / CH8b CM2 units 6 - 7 (9853/XMD)           "
"                              / CH7a     units 2 - 3 (887/HYDRA)          "
"       INISD S88700                                                       "
"--------------------------------------------------------------------------"
SET_SECURITY_OPTION SECURITY_AUDIT ON
SET_SYSTEM_ATTRIBUTE CATALOG_NAME_SECURITY 0
SET_SYSTEM_ATTRIBUTE DEBUG_JOB_RECOVERY 1
SET_SYSTEM_ATTRIBUTE DISABLE_NETWORK_RELAYS 1
SET_SYSTEM_ATTRIBUTE MAXIMUM_JOB_CLASSES 20
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_SYSTEM_ATTRIBUTE UNLOAD_DEADSTART_TAPE 0
SET_SYSTEM_ATTRIBUTE USER_TEMPLATES 1
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
USE_CONFIGURATION_PROLOG MAUVE_SHARED_LAB
"**********************  E N D   O F   D C F 7 2   ************************"
DCF73
"RESERVED FOR NOS/VE SYSTEM EVALUATION"
"--------------------------------------------------------------------------"
"  DEADSTART COMMAND FILE FOR C180-835  S/N 104. OWNED BY CDCNET LAB       "
"                  SUPPORT TO BE USED FOR HANDS-ON TIME                    "
"--------------------------------------------------------------------------"
"      USECP MAUVE_OPEN_USAGE / CH0 units 44 & 45                          "
"      INISD S88500                                                        "
"--------------------------------------------------------------------------"
SET_SYSTEM_ATTRIBUTE DEVELOPMENT_DEADSTART 1
SET_SYSTEM_ATTRIBUTE NETWORK_ACTIVATION 0
SET_SYSTEM_ATTRIBUTE NOSVE_INTERNAL_OPERATIONS 1
SET_SYSTEM_ATTRIBUTE UNLOAD_DEADSTART_TAPE 0
SET_TIME_ZONE -6 0 FALSE  "Set TRUE if Daylight Savings Time/FALSE Otherwise
SET_INSTALLATION_TAPE PRODUCTS 'VEPT01' 'VEPT01'
USE_CONFIGURATION_PROLOG MAUVE_OPEN_USAGE
"**********************  E N D   O F   D C F 7 3   ************************"
DCF74
"UNUSED"
DCF75
"UNUSED"
DCF76
"UNUSED"
DCF77
"UNUSED"
"****************** E  N  D    O  F    D  C  F  I  L  E *******************"
*DECK DECK=RAM$DEV_SYS_INIT_EPILOG EXPAND=TRUE

" This is DEVELOPMENT'S VERSION of the SYSTEM_INITIATION_EPILOG file.
" It is stored in the catalog
" $SYSTEM.PROLOGS_AND_EPILOGS.  The commands in this file are executed every
" time the system is initiated.
"
" Execution of this file occurs inside a procedure with a WHEN handler so
" that every command in this file will be attempted, regardless of errors.
" In addition you have the status variables IGNORE_STATUS and LOCAL_STATUS
" available to you.

    create_variable osv$deadstart_phase kind=(string $max_name) s=xref
    create_variable rav$development_deadstart kind=boolean s=xref
    create_variable st_string kind=string

  IF rav$development_deadstart THEN
    change_job_attribute_defaults login_family=NVE

"   Terminate the HPA periodic job.

    job jn=terj_hpa odi=dso
      VAR
        ign_stat: status
      VAREND
      terminate_job jn=HPA_VE$MONITOR_JOB odi=dso status=ign_stat
      terminate_job jn=HPA_VE$PERIODIC_JOB odi=dso status=ign_stat
    jobend
    IF (osv$deadstart_phase = 'INSTALL') THEN

"     Create file_transfer job and service classes and activate the profile.

      administer_scheduling
        administer_service_class
          create_class class_name=file_transfer default_values=batch
          change_attribute class_name=file_transfer maximum_active_jobs=40
        quit
        administer_job_class
          create_class class_name=file_transfer default_values=batch
          change_attribute class_name=file_transfer ..
                immediate_initiation_candidate=true
          change_attribute class_name=file_transfer initiation_level=40
          change_attribute class_name=file_transfer ..
                initial_service_class=file_transfer
        quit
      quit save_change=true
      manage_active_scheduling
        activate_profile profile=$system.scheduling_profile ..
              enable_job_reclassification=true
      quit save_change=true

      IF (NOT $file($user.testing_user_prolog, assigned)) THEN
        COLLECT_TEXT o=$user.testing_user_prolog until='        **END_OF_PROLOG**'
         create_command_list_entry e=($system.osf$site_command_library, $system.scu.command_library) p=after
         IF $file($user.prolog, assigned) THEN
           include_file f=$user.prolog
         IFEND
        **END_OF_PROLOG**
        detach_file f=$user.testing_user_prolog status=ignore_status
        create_file_permit f=$system.testing_user_prolog g=public am=all sm=none
        change_file_attributes f=$system.testing_user_prolog ra=(3 13 13)
      IFEND
      st_string = $SUBSTR($PROCESSOR(MODEL_NUMBER),1,3)
      FOR I = 1 TO (3-$STRLEN($PROCESSOR(SERIAL,0))) DO
        st_string = st_string//'0'
      FOREND
      st_string = st_string//$processor(serial,0)
      validate_development_users family=nve family_user_administrator=eval ..
        password=evalx dv=true
      validate_development_users family=$name('v'//st_string) family_user_administrator=eval ..
        password=evalx dv=false
      validate_development_users family=$name('testve'//st_string) family_user_administrator=eval ..
        password=evalpw dv=false
      validate_development_users family=testing family_user_administrator=eval  ..
        password=evalpw dv=false
    IFEND
    create_command_list_entry e=$system.osf$site_command_library
  IFEND
*DECK DECK=RAM$DISFP$US_ENGLISH EXPAND=TRUE
create_message_module name=help_disfp$us_english natural_language=us_english
    create_brief_help_message           collect_template_until='**'
   display the file permissions of a list of files.
**
create_full_help_message    collect_template_until='**'
  procedure display_file_permit+n+n5displays the file permissions of a list of
    files.+x2The only parameter,+nfile, may be either a ..
    list of catalogs and files or the keyword all (which+nrefers to all
    files in the working catalog).
**
create_parameter_assist_message  name=file collect_template_until='**'
 file must be either a list of catalogs and files or the keyword all.
**
create_parameter_HELP_MESSAGE  NAME=FILE COLLECT_TEMPLATE_UNTIL='**'
  PARAMETER FILE:+X2OPTIONAL LIST OF CATALOGS AND FILES TO BE WHOSE FILE+N17
  PERMISSIONS ARE TO BE DISPLAYED.+X2MAY ALSO BE THE +N17KEYWORD ALL.+X2
  DEFAULT IS THE WORKING CATALOG.
**
END_MESSAGE_MODULE CREATE_MODULE=YES
*DECK DECK=RAM$DISLIB EXPAND=TRUE
.PROC,DISLIB*I,
R "- Record name (or ALL or *)"        = (*N=*,ALL=*,*,*F),
T "- Type of record"                   = (*N=,ABS,CAP,OPL,OPLC,OPLD,OVL,
                                               PP,PPU,PROC,REL,TEXT,ULIB),
L "- Library file name"                = (*N=#FILE,*F),
UN "- User Name containing library"    = (*N=,*F),
O "- Output file name"                 = (*N=OUTPUT,*F),
DO "- Display Option"                  = (*N=S,BRIEF=S,B=S,FULL=F,F,D),
.
.HELP
 The DISLIB procedure DISplays the record content of a LIBrary file.
 Requires CATALOG binaries with GENCAT entry point.

 Parameter   Default   Description
   Name       Value

  [r]                  record name to display (or ALL or *)
  [t]                  type of records being displayed
  [l]                  library file to display
  [un]                 user name in which library resides
  [o]        OUTPUT    file to which library content is displayed
  [do]         b       display option for library display

.HELP,R
 The R parameter names the record to display from a library file.
 By default all records are displayed.
.HELP,T
 The T parameter specifies the record type displayed from a library.
 The default is to display all record types.
.HELP,L
 The L parameter names the file from which record names are displayed.
 The default value is the file containing this procedure.
.HELP,UN
 The UN parameter specifies the User Name location of the file.
 The default value is the User Name in which this procedure executes.
.HELP,O
 The O parameter names a file to which library content is displayed.
 The default value is OUTPUT.
.HELP,DO
 The DO parameter specifies the display option to use.
 Options are:  B | BRIEF  - for brief display (default value)
          or   F | FULL   - full display
          or   D  - for directive display (LIBEDIT directives)
.ENDHELP
.IFE,FILE(L,.NOT.AS),NOTLOCAL.
  GETFILE,L,L,UN,READ,A=YES.
.ENDIF,NOTLOCAL.
.IFE,($R$.EQ.$*$).AND.($T$.EQ.$$),LISTALL.
  .IFE,$DO$.EQ.$F$,FULLOPT.
    $ITEMIZE,L,#L=O,PW=136,N,E,U.
  .ELSE,FULLOPT.
    /GENCAT,L,#R,N,U,LO=DO,#L=O.
  .ENDIF,FULLOPT.
.ELSE,LISTALL.
  .IFE,$T$.NE.$$,LISTTYPE.
    GETLIB,R,L,UN,YYY_T,T.
  .ELSE,LISTTYPE.
    GETLIB,R,L,UN,YYY_T.
  .ENDIF,LISTTYPE.
  $IFE,FILE(YYY_T,.NOT.AS),NO_T.
    .IFE,$T$.NE.$$,TYPENAMED.
      $REVERT. NO T RECORDS ON L
    .ELSE,TYPENAMED.
      $REVERT. RECORD R NOT ON L
    .ENDIF,TYPENAMED.
  $ENDIF,NO_T.
  .IFE,$DO$.EQ.$F$,FULLOPT.
    $ITEMIZE,YYY_T,#L=O,PW=136,N,E,U.
  .ELSE,FULLOPT.
    /GENCAT,YYY_T,#R,N,U,LO=DO,#L=O.
  .ENDIF,FULLOPT.
  $UNLOAD,YYY_T.
.ENDIF,LISTALL.
$SKIP,NOERROR.
  $EXIT.
  $UNLOAD,YYY_T.
  $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    $EXIT. DISLIB *TERMINATED*
  $ENDIF,TERMINATED.
  $REVERT,ABORT. DISPLAY OF L FAILED
$ENDIF,NOERROR.
.IFE,FILE(L,.NOT.AS),FILEPRM.
  $UNLOAD,L.
.ENDIF,FILEPRM.
$REVERT. DISPLAY OF L --> O
/EOR
*DECK DECK=RAM$DISPLAY_BINARY_LOG EXPAND=TRUE
create_program_description name=(display_binary_log disbl) sp=lgp$display_binary_log ..
      l=('$system.osf$system_library' osf$task_services_library) tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$DISPLAY_CATALOG_CONTENT EXPAND=TRUE
PROCEDURE (ram$discc) display_catalog_content, discc, display_file_sizes, disfs (
  catalog, c: file = $working_catalog
  output, o: file = $output
  depth, d: any of
      key
        all
      keyend
      integer 1..$max_integer
    anyend = 2
  display_option, do: key
      (cycles, cycle, c)
      (descriptor, d)
      (files, f)
      (log, l)
      (permits, permit, p)
      (subcatalogs, s)
    keyend = cycles
  exclude_catalog, exclude_catalogs, ec: (BY_NAME, ADVANCED) list 0..$max_list of string = ()
  exclude_file, exclude_files, ef: (BY_NAME, ADVANCED) list 0..$max_list of string = ()
  include_catalog, include_catalogs, ic: (BY_NAME, ADVANCED) list 0..$max_list of string = ()
  include_file, include_files, if: (BY_NAME, ADVANCED) list 0..$max_list of string = ()
  prefix_string, ps: (BY_NAME, ADVANCED) string = ''
  suffix_string, ss: (BY_NAME, ADVANCED) string = ''
  status)

" PURPOSE:
"   Display the content/structure of a catalog.
" DESIGN:
"   Display all files meeting the criteria selected by parameter values. String values for INCLUDE or EXCLUDE
"   parameters are processed as substrings of the file or catalog names, allowing similarly named files or
"   catalogs to be selected or excluded.  Display option parameter values select the type of information to be
"   displayed for each file and/or catalog.  The depth parameter limits the number of subcatalogs displayed,
"   and to what depth this procedure recurses.  The prefix and suffix strings can be used to form command or
"   procedure calls for subsequent include_file processing.

  VAR
    attributes : file = $unique(:$local)
    attributes_list : list 0..$max_list of string
    delete_status : status
    files : list 0..$max_list of file = ()
    ignore : status
    last_path : string 1..31 = ' '
    line : string
    subcatalogs : list 0..$max_list of file = ()
  VAREND

  WHEN exit DO
    delete_file file=attributes status=ignore
  WHENEND

  IF $nil(include_file) THEN " select the list of all files "
    files=$catalog_contents(catalog, include_files, paths)
  ELSE " accumulate a list of files with the include_file strings present "
    FOR EACH included_file IN include_file DO
      files=$union(files, $select($catalog_contents(catalog, include_files, paths), ..
            $scan_string($translate(ltu, included_file), ' '//$path(x, last)//' ')<>0))
    FOREND
  IFEND
  FOR EACH excluded_file IN exclude_file DO " select only those files missing the exclude_file string "
    files=$select(files, $scan_string($translate(ltu, excluded_file), ' '//$path(x, last)//' ')=0)
  FOREND

  set_file_attributes file=attributes page_format=continuous file_contents=legible
  IF $file(output, assigned) THEN " format display for output file page width
    display_file_attributes file=output output=attributes.$boi do=page_width
    get_lines variable=line input=attributes.$boi
    delete_file file=attributes
    set_file_attributes file=attributes page_format=continuous file_contents=legible ..
          page_width=$integer(line($scan_string(':', line)+1, all))
  IFEND

  IF (display_option = cycles) AND (depth = 1) THEN
    $system.display_catalog catalog=catalog output=attributes.$boi do=content depth=1
    get_lines variable=line input=attributes.$boi
    put_line line=' CATALOG: '//$path(catalog, catalog)//'.'//$justify($path(catalog, last), 31, left)//..
line($scan_string(' ', line), all) output=output.$eoi
  ELSEIF display_option = permits THEN
    $system.display_catalog catalog=catalog output=attributes.$boi do=display_option
    get_lines variable=attributes_list input=attributes.$boi
    put_line line=(' ', ' CATALOG: '//catalog) output=output.$eoi
    put_line line=$apply(attributes_list, '    '//x) output=output.$eoi
  ELSEIF (display_option <> files) AND (display_option <> subcatalogs) THEN
    put_line line=(' ', ' CATALOG: '//catalog) output=output.$eoi
  IFEND

  IF $generic_type(depth)= 'INTEGER' THEN " decrement depth counter, to limit recursion"
    EXIT_PROC WHEN depth = 1
    depth=depth - 1
  IFEND

  IF display_option <> subcatalogs THEN
    FOR EACH filename IN files DO " process the list of file names "
      IF display_option = files THEN
        put_line line=$apply($file_cycles(filename, paths), ' '//ps//' '//$string(x)//' '//ss) output=output.$eoi
      ELSEIF display_option = cycles THEN
        $system.display_catalog_entry file=filename output=attributes.$boi do=cycles depth=2 status=ignore
        IF NOT ignore.normal THEN
          put_line line=$path(filename, last)//' '//$file(filename, size)//' bytes' output=attributes.$boi
        IFEND
        get_lines variable=attributes_list input=attributes.$boi
        FOR EACH attribute IN attributes_list DO
          blank=$scan_string(' ', attribute)
          bytes=$scan_string('bytes', attribute)
          IF bytes = 0 THEN
            put_line line='          '//attribute(1, blank)//' '//attribute(blank, all) output=output.$eoi
          ELSEIF attribute(1, blank) = '--' THEN
            aligned=$justify(attribute(blank, bytes-blank), 43, right)
            put_line line='          '//attribute(1, blank)//aligned//attribute(bytes, all) output=output.$eoi
          ELSE
            numbers=$scan_any('0123456789', attribute(blank, bytes-blank)) + blank - 1
            aligned=$justify(attribute(numbers, bytes-numbers), 15, right)
            put_line line='    FILE: '//$justify(attribute(1, blank), 31, left)//aligned//..
attribute(bytes, all) output=output.$eoi
          IFEND
          EXIT WHEN depth <= 2
        FOREND
      ELSE
        CYCLE WHEN last_path = $path(filename, last)
        IF $string(catalog)= ':$LOCAL' THEN
          put_line line=('    FILE: '//$path(filename, last)) output=output.$eoi
        ELSE
          put_line line=('    FILE: '//filename) output=output.$eoi
        IFEND
        $system.display_catalog_entry file=filename output=attributes.$boi do=display_option
        get_lines variable=attributes_list input=attributes.$boi
        put_line line=$apply(attributes_list, '    '//x) output=output.$eoi
        last_path=$path(filename, last)
      IFEND
    FOREND
  IFEND

  IF $nil(include_catalog) THEN " select the list of all catalogs "
    subcatalogs=$catalog_contents(catalog, include_catalogs, paths)
  ELSE " accumulate a list of catalogs with the include_catalog strings present "
    FOR EACH included IN include_catalog DO
      subcatalogs=$union(subcatalogs, $select($catalog_contents(catalog, include_catalogs, paths), ..
            $scan_string($translate(ltu, included), ' '//$path(x, last)//' ')<>0))
    FOREND
  IFEND

  FOR EACH excluded IN exclude_catalog DO " select catalogs missing the exclude_catalog string "
    subcatalogs=$select(subcatalogs, $scan_string($translate(ltu, excluded), ' '//$path(x, last)//' ')=0)
  FOREND

  IF display_option = 'SUBCATALOGS' THEN
    put_line line=$apply(subcatalogs, ' '//ps//' '//$string(x)//' '//ss) output=output.$eoi
    EXIT_PROC WHEN depth = 1
  IFEND

  FOR EACH subcatalog IN subcatalogs DO " recurse to process each subcatalog "
    IF (display_option = cycles) AND (depth = 1) THEN
      $system.display_catalog subcatalog output=attributes.$boi do=content depth=1
      get_lines variable=line input=attributes.$boi
      blank=$scan_string(' ', line)
      bytes=$scan_string('bytes', line)
      put_line line='  ' output=output.$eoi
      IF bytes = 0 THEN
        put_line line=' CATALOG: '//$path(subcatalog, catalog)//'.'//$justify($path(subcatalog, last), 31, ..
              left)//line(blank, all) output=output.$eoi
      ELSE
        aligned=$justify(line(blank, bytes-blank), 15, right)
        put_line line=' CATALOG: '//$path(subcatalog, catalog)//'.'//$justify($path(subcatalog, last), 31, ..
              left)//aligned//line(bytes, all) output=output.$eoi
      IFEND
    ELSE
      $source.display_catalog_content catalog=subcatalog o=output d=depth do=display_option ef=exclude_file ..
            ec=exclude_catalog ic=include_catalog if=include_file ps=prefix_string ss=suffix_string
    IFEND
  FOREND

PROCEND display_catalog_content
*DECK DECK=RAM$DISPLAY_CATALOG_FILE_ATTRIB EXPAND=TRUE
PROCEDURE (ram$discfa) display_catalog_file_attribute, display_catalog_file_attributes, discfa (
  catalog, c: file = $working_catalog
  output, o: file = $output
  display_option, do: list of name = (ai fc fo fp fs rt ra size ui)
  depth, d: any of
      key
        all
      keyend
      integer 1..$max_integer
    anyend = 2
  exclude_catalog, exclude_catalogs, ec: (BY_NAME, ADVANCED) list 0..$max_list of string = (' $')
  exclude_file, exclude_files, ef: (BY_NAME, ADVANCED) list 0..$max_list of string = (' $')
  include_catalog, ic: (BY_NAME, ADVANCED) list 0..$max_list of string = ()
  include_file, if: (BY_NAME, ADVANCED) list 0..$max_list of string = ()
  status)

" PURPOSE:
"   Display the attributes of files in a catalog.
" DESIGN:
"   Display all files meeting the criteria selected by parameter values. String values for INCLUDE or EXCLUDE
"   parameters are processed as substrings of the file or catalog names, allowing similarly named files or
"   catalogs to be selected or excluded. Display option parameter values select the type of information to be
"   displayed for each file. The depth parameter limits the number of subcatalogs displayed.

  VAR
    attributes_list : list 0..$max_list of string
    delete_status : status
    file_attributes : file = $unique(:$local)
    files : list 0..$max_list of file = ()
    subcatalogs : list 0..$max_list of file = ()
  VAREND

  IF $nil(include_file) THEN " select the list of all files "
    files=$catalog_contents(catalog, include_files, paths)
  ELSE " accumulate a list of files with the include_file strings present "
    FOR EACH included_file IN include_file DO
      files=$union(files, $select($catalog_contents(catalog, include_files, paths), ..
            $scan_string($translate(ltu, included_file), ' '//$path(x, last)//' ')<>0))
    FOREND
  IFEND

  FOR EACH excluded_file IN exclude_file DO " select only those files missing the exclude_file string "
    files=$select(files, $scan_string($translate(ltu, excluded_file), ' '//$path(x, last)//' ')=0)
  FOREND

  set_file_attributes file_attributes page_format=continuous file_contents=legible
  put_line (' ', ' CATALOG: '//catalog) output=output.$eoi

  FOR EACH filename IN files DO " process the list of file names "
    FOR EACH cycle IN $file_cycles(filename, paths) DO
      IF $string(catalog)= ':$LOCAL' THEN
        put_line ('    FILE: '//$path(cycle, last)) output=output.$eoi
      ELSE
        put_line ('    FILE: '//cycle) output=output.$eoi
      IFEND
      $system.display_file_attributes cycle output=file_attributes.$boi do=$apply(display_option, x)
      get_lines variable=attributes_list input=file_attributes.$boi
      put_line $apply(attributes_list, '          '//x) output=output.$eoi
    FOREND
  FOREND

  delete_file file_attributes

  IF $generic_type(depth)= 'INTEGER' THEN " decrement depth counter, to limit recursion"
    EXIT_PROC WHEN depth <= 2
    depth=depth - 1
  IFEND

  IF $nil(include_catalog) THEN " select the list of all catalogs "
    subcatalogs=$catalog_contents(catalog, include_catalogs, paths)
  ELSE " accumulate a list of catalogs with the include_catalog strings present "
    FOR EACH included_catalog IN include_catalog DO
      subcatalogs=$union(subcatalogs, $select($catalog_contents(catalog, include_catalogs, paths), ..
            $scan_string($translate(ltu, included_catalog), ' '//$path(x, last)//' ')<>0))
    FOREND
  IFEND

  FOR EACH excluded_catalog IN exclude_catalog DO " select catalogs missing the exclude_catalog string "
    subcatalogs=$select(subcatalogs, ..
          $scan_string($translate(ltu, excluded_catalog), ' '//$path(x, last)//' ')=0)
  FOREND

  FOR EACH subcatalog IN subcatalogs DO " recurse to process each subcatalog "
    $source.discfa catalog=subcatalog o=output d=depth do=display_option ec=exclude_catalog ef=exclude_file ..
          ic=include_catalog if=include_file
  FOREND

PROCEND display_catalog_file_attribute
*DECK DECK=RAM$DISPLAY_COMMAND_NAMES EXPAND=TRUE
PROCEDURE (ram$discn) display_command_names, discn, display_command_name (
  status)

  "$FORMAT=OFF
  VAR
    choice:string = ''
    command_line:string = ''
    discle_out: file =$fname($unique)
    ign_status: status
    lines: array 1 .. 24-2-3-1 of string
    matched_commands: file =$fname($unique)
    menu_out: file =$fname($unique)
    number_of_lines: integer = 0
    search_string: string = ''
  VAREND
  "$FORMAT=ON"

  WHEN any_fault OR exit DO
    delete_file f=(discle_out menu_out matched_commands) status=ign_status
  WHENEND

  set_file_attributes f=discle_out pw=45 pf=continuous fc=legible
  display_command_list_entry e=all do=(commands names functions) ..
        o=discle_out
  accept_line v=search_string i=input ..
        p='Enter wild card search string - '
  exit_proc when search_string = ' '
  IF $scan_any('*[', search_string) = 0 THEN
    search_string = '*' // $translate(utl, search_string) // '*'
  IFEND
  find_string ss=search_string i=discle_out o=matched_commands

  rewind_file f=matched_commands

  LOOP
    accept_line v=lines i=matched_commands.$asis lc=number_of_lines
    EXIT WHEN number_of_lines = 0
COLLECT_TEXT o=menu_out
Commands that match are:

**
    FOR i = 1 TO number_of_lines DO
COLLECT_TEXT o=menu_out.$eoi sm='?'
?$substr('  ',1,2-$strlen($strrep(i)))//i?. ?lines(i)?
**
    FOREND
COLLECT_TEXT o=menu_out.$eoi

Choose the item for which you want information or press RETURN to
continue.
**
    copy_file i=menu_out o=$output
    accept_line v=choice i=input p=''
    IF choice <> '' THEN
      command_line = $substring(..
'display_command_information  display_function_information ', ..
            $integer(lines($integer(choice))(1)='$')*29+1, 29) // ..
            lines($integer(choice)) // ' do=all '
      EXIT
    IFEND
  LOOPEND

  include_command c=command_line

  delete_file f=(discle_out menu_out matched_commands) status=ign_status

PROCEND display_command_names
*DECK DECK=RAM$DISPLAY_CORRECTIONS_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$display_corrections_command;

*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc rac$max_line_size
*copyc rac$status_id
*copyc rae$error_messages
*copyc clt$path_display_chunks
*copyc rat$correction_package_header
*copyc rat$correction_package
*copyc rat$single_correction_header
*copyc amp$get_segment_pointer
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$get_path_description
*copyc clp$get_value
*copyc clp$new_display_line
*copyc clp$open_display
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc clp$scan_parameter_list
*copyc fsp$open_file
*copyc fsp$close_file
*copyc osp$set_status_abnormal
*copyc osv$control_codes_to_quest_mark
*copyc rav$class_types
?? POP ??

*copyc rah$display_corrections_command

  PROCEDURE [XDCL, #GATE] rap$display_corrections_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{   pdt discp_pdt (
{     correction_package, cp: file = $required
{     output, o: file = $output
{     status)

?? PUSH (LISTEXT := ON) ??

    VAR
      discp_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^discp_pdt_names,
        ^discp_pdt_params];

    VAR
      discp_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
        clt$parameter_name_descriptor := [['CORRECTION_PACKAGE', 1], ['CP', 1], ['OUTPUT', 2], ['O', 2], [
        'STATUS', 3]];

    VAR
      discp_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ CORRECTION_PACKAGE CP }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ OUTPUT O }
      [[clc$optional_with_default, ^discp_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
        clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

    VAR
      discp_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$output';

?? POP ??

?? TITLE := 'display corrections command', EJECT ??

    VAR
      bcu: amt$segment_pointer,
      bcu_header: ^rat$correction_package_header,
      cd: boolean,
      correction: ^SEQ ( * ),
      correction_list: ^rat$correction_package,
      correction_location: ^SEQ ( * ),
      correction_package: amt$local_file_name,
      correction_package_fid: amt$file_identifier,
      correction_package_path: clt$path_name,
      cs: clt$cycle_selector,
      display_control: clt$display_control,
      display_line: ^string ( * ),
      file_reference: clt$file_reference,
      i: rat$element_index,
      ignore_status: ost$status,
      length: integer,
      lf: boolean,
      line: string (rac$max_line_size),
      ofn: boolean,
      op: clt$open_position,
      output: clt$file,
      p: ^pft$path,
      pc: clt$path_container,
      psr_list: ^array [1 .. *] of rat$psr_ident,
      read_only_attachment: array [1 .. 2] of fst$attachment_option,
      value: clt$value;

{   The following VAR declarations are used by clp$new_page_procedure.
{   Because the procedure is maintained by others its listing is supressed.
*copy clv$display_variables
?? PUSH (LISTEXT := ON) ??
*copyc clp$new_page_procedure
?? TITLE := '  display corrections command' ??

    PROCEDURE [INLINE] put_subtitle (display_control: clt$display_control;
      VAR status: ost$status);

      {   DISPLAY_CORRECTIONS_COMMAND uses no subtitles, this
      { is merely a dummy routine used to keep the module
      { consistent with those that do  produce subtitles.

    PROCEND put_subtitle;
?? POP ??

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, discp_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /display_correction_package/
    BEGIN

      clp$get_value ('CORRECTION_PACKAGE', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /display_correction_package/;
      IFEND;
      correction_package := value.file.local_file_name;

      clp$get_path_description (value.file, file_reference, pc, p, cs, op, status);
      IF NOT status.normal THEN
        EXIT /display_correction_package/;
      IFEND;
      correction_package_path := file_reference.path_name (1, file_reference.path_name_size);

      read_only_attachment [1].selector := fsc$access_and_share_modes;
      read_only_attachment [1].access_modes.selector := fsc$specific_access_modes;
      read_only_attachment [1].access_modes.value := $fst$file_access_options [fsc$read];
      read_only_attachment [1].share_modes.selector := fsc$determine_from_access_modes;
      read_only_attachment [2].selector := fsc$create_file;
      read_only_attachment [2].create_file := FALSE;

      fsp$open_file (correction_package, amc$segment, ^read_only_attachment, NIL, NIL, NIL, NIL,
            correction_package_fid, status);
      IF NOT status.normal THEN
        EXIT /display_correction_package/;
      IFEND;

      amp$get_segment_pointer (correction_package_fid, amc$sequence_pointer, bcu, status);
      IF NOT status.normal THEN
        EXIT /display_correction_package/;
      IFEND;

      RESET bcu.sequence_pointer;
      NEXT bcu_header IN bcu.sequence_pointer;

      IF (bcu_header = NIL) OR (bcu_header^.identification <> rac$correction_package_id) THEN
        osp$set_status_abnormal (rac$status_id, rae$file_not_correction_package, correction_package_path,
              status);
        EXIT /display_correction_package/;
      IFEND;
      IF bcu_header^.version <> rac$correction_package_version THEN
        osp$set_status_abnormal (rac$status_id, rae$invalid_cp_version, correction_package_path, status);
        EXIT /display_correction_package/;
      IFEND;


      clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /display_correction_package/;
      IFEND;
      output := value.file;

      clp$open_display (output, ^clp$new_page_procedure, display_control, status);
      IF NOT status.normal THEN
        EXIT /display_correction_package/;
      IFEND;

      clv$titles_built := FALSE;
      clv$command_name := 'display_correction_package';

      PUSH display_line: [display_control.page_width];


      NEXT correction_list: [1 .. bcu_header^.number_of_elements] IN bcu.sequence_pointer;
      IF correction_list = NIL THEN
        osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, correction_package_path,
              status);
        EXIT /display_correction_package/;
      IFEND;

      FOR i := 1 TO bcu_header^ .number_of_elements DO

        length := 1;
        display_line^ := ' ';
        clp$put_display (display_control, display_line^ (1, length), clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display_correction_package/;
        IFEND;

        STRINGREP (line, length, ' ELEMENT: ', correction_list^ [i].name);
        #translate (osv$control_codes_to_quest_mark, line (1, length), display_line^ (1, length));
        clp$put_display (display_control, display_line^ (1, length), clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display_correction_package/;
        IFEND;

        STRINGREP (line, length, ' VERSION: ', correction_list^ [i].user_info);
        #translate (osv$control_codes_to_quest_mark, line (1, length), display_line^ (1, length));
        clp$put_display (display_control, display_line^ (1, length), clc$trim, status);
        IF NOT status.normal THEN
          EXIT /display_correction_package/;
        IFEND;

        IF correction_list^ [i].number_of_psrs > 0 THEN
          psr_list := #PTR (correction_list^ [i].psr_info, bcu.sequence_pointer^);
          RESET bcu.sequence_pointer TO psr_list;
          NEXT psr_list: [1 .. correction_list^ [i].number_of_psrs] IN bcu.sequence_pointer;
          IF psr_list = NIL THEN
            osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, correction_package_path,
                  status);
            EXIT /display_correction_package/;
          IFEND;

          rap$display_psrs (display_control, psr_list, correction_list^ [i].number_of_psrs, status);
          IF NOT status.normal THEN
            EXIT /display_correction_package/;
          IFEND;
        IFEND;

      FOREND;

    END /display_correction_package/;


    IF status.normal THEN
      fsp$close_file (correction_package_fid, status);
    ELSE
      fsp$close_file (correction_package_fid, ignore_status);
    IFEND;

    IF status.normal THEN
      clp$close_display (display_control, status);
    ELSE
      clp$close_display (display_control, ignore_status);
    IFEND;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$display_corrections_command;

?? TITLE := 'display psrs', EJECT ??
*copyc rah$display_psrs

  PROCEDURE rap$display_psrs (VAR display_control: clt$display_control;
        psr_list: ^array [1 .. * ] OF rat$psr_ident;
        number_of_psrs: rat$psr_index;
    VAR status: ost$status);


    VAR
      display_line: ^string ( * ),
      i: rat$psr_index,
      marker: integer,
      length: 1 .. rac$max_line_size,
      line: string (rac$max_line_size),
      psr_ident_length: integer;


    status.normal := TRUE;

    PUSH display_line: [display_control.page_width];
    display_line^ := ' ';

    psr_ident_length := #SIZE (psr_list^ [1]);
    line (1, * ) := ' PSR''S: ';
    length := 8;
    marker := 9;

    FOR i := 1 TO number_of_psrs DO
      line (marker, * ) := psr_list^ [i];
      length := length + psr_ident_length;
      marker := marker + psr_ident_length;
      IF (i = number_of_psrs) OR (length + psr_ident_length > rac$max_line_size) THEN
        #translate (osv$control_codes_to_quest_mark, line (1, length), display_line^ (1, length));
        clp$put_display (display_control, display_line^ (1, length), clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{   initialize the line values for the next line. }
        line (1, * ) := ' PSR''S: ';
        length := 8;
        marker := 9;
      IFEND;
    FOREND;

  PROCEND rap$display_psrs;

  MODEND ram$display_corrections_command

*DECK DECK=RAM$DISPLAY_CORRECTION_ATTRIB EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'CREATE_SUBPRODUCT_CORRECTION subutility: DISPLAY_CORRECTION_ATTRIB command.' ??
MODULE ram$display_correction_attrib;

{ PURPOSE:
{   This module contains the procedures to display the attributes of the
{   correction being created by CREATE SUBPRODUCT CORRECTION.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$condition
*copyc rae$package_software_cc
?? POP ??
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_real
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$convert_real_to_string
*copyc clp$evaluate_parameters
*copyc clp$get_path_name
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$right_justify_string
*copyc clp$trimmed_string_size
*copyc clv$display_variables
*copyc clv$nil_display_control
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc rap$convert_path_to_str
*copyc rap$display_psrs_answered
*copyc rap$write_strings
*copyc rav$correction_process_record

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    max_line_size = 80;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$display_correction_attrib', EJECT ??

{ PURPOSE:
{   This procedure displays the attributes of the correction being created
{   by CREATE SUBPRODUCT CORRECTION.
{
{ DESIGN:
{   This procedure uses the standard clp$display commands to display the
{   attributes to the output file.  It is patterned after ram$display_sif.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$display_correction_attrib
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE disca_pdt (
{   display_hidden_values: (hidden) boolean = FALSE
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 4] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          default_value: string (5),
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 8, 8, 13, 38, 55, 580], clc$command, 4, 3, 0, 0, 1, 0, 3, 'DISCA_PDT'],
            [['DISPLAY_HIDDEN_VALUES          ', clc$nominal_entry, 1],
            ['O                              ', clc$abbreviation_entry, 2],
            ['OUTPUT                         ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3]], [
{ PARAMETER 1
      [1, clc$hidden_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_default_parameter, 0, 5],
{ PARAMETER 2
      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$boolean_type], 'FALSE'],
{ PARAMETER 2
      [[1, 0, clc$file_type], '$output'],
{ PARAMETER 3
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$display_hidden_values = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      display_opened: boolean,
      display_option: ost$name,
      display_status: ost$status,
      length: integer,
      local_status: ost$status;

?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

      rap$write_strings ('DISPLAY CORRECTION ATTRIBUTES', '', FALSE, 0, display_control, display_status);

    PROCEND put_subtitle;
?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the files have been opened, they will be closed before the
{   the procedure returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND abort_handler;
?? PUSH (LISTEXT := ON) ??
*copyc clp$new_page_procedure
?? POP ??
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    display_status.normal := TRUE;
    display_opened := FALSE;
    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    clv$titles_built := FALSE;
    clv$command_name := 'display_correction_attributes';

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT rav$correction_process_record.correction_in_progress THEN
      osp$set_status_abnormal ('RA', rae$defc_command_not_called, 'DISPLAY_CORRECTION_ATTRIBUTES', status);
      RETURN;
    IFEND;

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);

    osp$establish_block_exit_hndlr (^abort_handler);

    display_opened := TRUE;
    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          default_ring_attributes, display_control, status);
    IF NOT status.normal THEN
      display_opened := FALSE;
      RETURN;
    IFEND;

  /main/
    BEGIN
      display_catalogs_and_levels (rav$correction_process_record, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_correction_attributes (rav$correction_process_record.new_subproduct_info_pointers,
            pvt [p$display_hidden_values].value^.boolean_value.value, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF rav$correction_process_record.new_subproduct_info_pointers.psrs_answered_p <> NIL THEN
        rap$write_strings ('', '', FALSE, 0, display_control, display_status);
        rap$write_strings (' This CREATE_SUBPRODUCT_CORRECTION Session', '', FALSE, 0,
              display_control, display_status);
        rap$display_psrs_answered (rav$correction_process_record.new_subproduct_info_pointers.psrs_answered_p,
              display_control, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF rav$correction_process_record.previous_correction_sif.file_opened THEN
        rap$write_strings ('', '', FALSE, 0, display_control, display_status);
        rap$write_strings (' The Previous Correction ', '', FALSE, 0, display_control,
              display_status);
        rap$display_psrs_answered (rav$correction_process_record.previous_correction_sif.
              subproduct_info_pointers.psrs_answered_p, display_control, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

    END /main/;

    IF display_opened THEN
      clp$close_display (display_control, display_status);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$display_correction_attrib;

?? OLDTITLE ??
?? NEWTITLE := 'display_catalogs_and_levels', EJECT ??

{ PURPOSE:
{   This procedure displays the catalogs and their levels.
{
{ DESIGN:
{
{ NOTES:
{
{

  PROCEDURE display_catalogs_and_levels
    (    rav$correction_process_record: rat$correction_process_record;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      base_subproduct_info_pointers: rat$subproduct_info_pointers,
      current_subproduct_info_ptrs: rat$subproduct_info_pointers,
      display_status: ost$status,
      previous_correction_pointers: rat$subproduct_info_pointers;

    status.normal := TRUE;
    display_status.normal := TRUE;
    base_subproduct_info_pointers := rav$correction_process_record.base_level_sif.subproduct_info_pointers;
    current_subproduct_info_ptrs := rav$correction_process_record.current_level_sif.subproduct_info_pointers;

    rap$write_strings (' Base Level PACS Catalog: ', base_subproduct_info_pointers.attributes_p^.
          pacs_catalog_path.path (1, base_subproduct_info_pointers.attributes_p^.pacs_catalog_path.size),
          FALSE, 0, display_control, display_status);

    rap$write_strings (' Base Level: ', base_subproduct_info_pointers.attributes_p^.level, FALSE, 0,
          display_control, display_status);
    rap$write_strings ('', '', FALSE, 0, display_control, display_status);

    rap$write_strings (' Current Level PACS Catalog: ', current_subproduct_info_ptrs.attributes_p^.
          pacs_catalog_path.path (1, current_subproduct_info_ptrs.attributes_p^.pacs_catalog_path.size),
          FALSE, 0, display_control, display_status);

    rap$write_strings (' Current Level: ', current_subproduct_info_ptrs.attributes_p^.level, FALSE, 0,
          display_control, display_status);
    rap$write_strings ('', '', FALSE, 0, display_control, display_status);

    IF rav$correction_process_record.previous_correction_sif.file_opened THEN
      previous_correction_pointers := rav$correction_process_record.previous_correction_sif.
            subproduct_info_pointers;
      rap$write_strings (' Previous Correction PACS Catalog: ',
            previous_correction_pointers.attributes_p^.pacs_catalog_path.
            path (1, previous_correction_pointers.attributes_p^.pacs_catalog_path.size), FALSE, 0,
            display_control, display_status);

      rap$write_strings (' Previous Correction Level: ', previous_correction_pointers.attributes_p^.level,
            FALSE, 0, display_control, display_status);
      rap$write_strings ('', '', FALSE, 0, display_control, display_status);
    IFEND;

    IF NOT display_status.normal THEN
      status := display_status;
    IFEND;

  PROCEND display_catalogs_and_levels;

?? OLDTITLE ??
?? NEWTITLE := 'display_correction_attributes', EJECT ??

{ PURPOSE:
{   This procedure displays the subproduct attributes.
{
{ DESIGN:
{   Each of the fields is read from the attributes record and displayed to
{   the output file.
{
{ NOTES:
{
{

  PROCEDURE display_correction_attributes
    (    subproduct_info_pointers: rat$subproduct_info_pointers;
         display_hidden_values: boolean;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      attributes: rat$subproduct_attributes,
      display_status: ost$status,
      i: pft$array_index,
      installation_path: rat$path,
      installation_path_p: ^rat$path_container,
      installer_path: rat$path,
      installer_path_p: ^rat$path_container,
      package_software_ref_p: ^fst$file_reference,
      path_ref_p: ^fst$file_reference,
      path_container_index: rat$path_container_index,
      path_container_p: ^rat$path_container,
      sequence_descriptor: rat$sequence_descriptor;

*copy rav$installation_path_option
*copy rav$installation_scheme
*copy rav$subproduct_priority
*copy rav$subproduct_type

    status.normal := TRUE;
    display_status.normal := TRUE;
    attributes := subproduct_info_pointers.attributes_p^;
    path_container_p := subproduct_info_pointers.path_container_p;
    sequence_descriptor := subproduct_info_pointers.sequence_descriptor_p^;

    rap$write_strings ('', '', FALSE, 0, display_control, display_status);

    rap$write_strings (' Attributes of Subproduct ', attributes.name, FALSE, 0, display_control,
          display_status);

    rap$write_strings ('', '', FALSE, 0, display_control, display_status);

    rap$write_strings (' Additional Products:        ', '', TRUE, 0, display_control, display_status);

    IF attributes.additional_products [1] = '' THEN
      rap$write_strings ('NONE', '', FALSE, 0, display_control, display_status);

    ELSE

      FOR i := 1 TO rac$max_additional_products DO

        IF attributes.additional_products [i] <> '' THEN

          IF i = 1 THEN
            rap$write_strings ('', attributes.additional_products [i], FALSE, 0, display_control,
                  display_status);
          ELSE
            rap$write_strings ('                             ', attributes.additional_products [i], FALSE,
                  0, display_control, display_status);
          IFEND;

        IFEND;

      FOREND;

    IFEND;

    rap$write_strings (' Description:                ', attributes.description, FALSE, 0, display_control,
          display_status);

    rap$write_strings (' Development Group:          ', attributes.development_group, FALSE, 0,
          display_control, display_status);

    rap$write_strings (' Installation Scheme:        ', rav$installation_scheme
          [attributes.installation_scheme], FALSE, 0, display_control, display_status);

    PUSH installer_path_p: [1 .. attributes.installer_procedure.path_length];
    FOR i := 1 TO attributes.installer_procedure.path_length  DO
      path_container_index := i + attributes.installer_procedure.path_container_index - 1;
      installer_path_p^ [i] := path_container_p^ [path_container_index];
    FOREND;

    rap$convert_path_to_str (installer_path_p^, installer_path);

    IF attributes.installer_procedure.path_length <> 0 THEN
      rap$write_strings (' Installer Procedure:        ', installer_path.path (1, installer_path.size),
            FALSE, 0, display_control, display_status);
    ELSE
      rap$write_strings (' Installer Procedure:        ', 'NONE', FALSE, 0, display_control, display_status);
    IFEND;

    rap$write_strings (' Level:                      ', attributes.level, FALSE, 0, display_control,
          display_status);

    rap$write_strings (' Licensed Product:           ', attributes.licensed_product, FALSE, 0,
          display_control, display_status);

    rap$write_strings (' Dependencies:               ', '', TRUE, 0, display_control, display_status);

    IF attributes.dependencies [1] = '' THEN
      rap$write_strings ('NONE', '', FALSE, 0, display_control, display_status);

    ELSE

      FOR i := 1 TO rac$max_dependencies DO

        IF attributes.dependencies [i] <> '' THEN

          IF i = 1 THEN
            rap$write_strings (attributes.dependencies [i], '', FALSE, 0, display_control, display_status);
          ELSE
            rap$write_strings ('                             ', attributes.dependencies [i], FALSE, 0,
                  display_control, display_status);
          IFEND;

        IFEND;

      FOREND;

    IFEND;

    PUSH installation_path_p: [1 .. attributes.installation_path.path_length];
    FOR i := attributes.installation_path.path_container_index TO
          (attributes.installation_path.path_container_index +
          attributes.installation_path.path_length - 1) DO
      installation_path_p^ [i] := path_container_p^ [i];
    FOREND;

    rap$convert_path_to_str (installation_path_p^, installation_path);

    rap$write_strings (' Installation Path:          ', installation_path.path (1, installation_path.size),
          FALSE, 0, display_control, display_status);

    rap$write_strings (' PACS Catalog Path:          ', attributes.pacs_catalog_path.
          path (1, attributes.pacs_catalog_path.size), FALSE, 0, display_control,
          display_status);

    rap$write_strings (' Subproduct Type:            ', rav$subproduct_type [attributes.subproduct_type],
          FALSE, 0, display_control, display_status);

    IF attributes.auto_install = TRUE THEN
      rap$write_strings (' Auto Install:               TRUE', '', FALSE, 0, display_control, display_status);
    ELSE
      rap$write_strings (' Auto Install:               FALSE', '', FALSE, 0, display_control, display_status);
    IFEND;

    rap$write_strings (' Date Level:                 ', attributes.date_level, FALSE, 0, display_control,
          display_status);

    IF attributes.hidden = TRUE THEN
      rap$write_strings (' Hidden:                     TRUE', '', FALSE, 0, display_control, display_status);
    ELSE
      rap$write_strings (' Hidden:                     FALSE', '', FALSE, 0, display_control, display_status);
    IFEND;

    rap$write_strings (' Installation Path Option:   ', rav$installation_path_option
          [attributes.installation_path_option], FALSE, 0, display_control, display_status);

    IF attributes.primary = TRUE THEN
      rap$write_strings (' Primary Subproduct:         TRUE', '', FALSE, 0, display_control, display_status);
    ELSE
      rap$write_strings (' Primary Subproduct:         FALSE', '', FALSE, 0, display_control, display_status);
    IFEND;

    IF attributes.files_stamped = TRUE THEN
      rap$write_strings (' Files Stamped:              TRUE', '', FALSE, 0, display_control, display_status);
    ELSE
      rap$write_strings (' Files Stamped:              FALSE', '', FALSE, 0, display_control, display_status);
    IFEND;

    rap$write_strings (' Correction Base Level:      ', attributes.correction_base_level, FALSE, 0,
          display_control, display_status);

    rap$write_strings (' SIF Identifier:             ', attributes.sif_identifier, FALSE, 0,
          display_control, display_status);

    IF display_hidden_values THEN

      rap$write_strings (' Internal Level:             ', attributes.internal_level, FALSE, 0,
            display_control, display_status);

      rap$write_strings (' Subproduct Priority:        ', rav$subproduct_priority
            [attributes.subproduct_priority], FALSE, 0, display_control, display_status);

    IFEND;

  PROCEND display_correction_attributes;

?? OLDTITLE ??
?? NEWTITLE := 'write_string_and_integer', EJECT ??

{ PURPOSE:
{   This procedure writes a string and a integer to the output display.
{
{ DESIGN:
{   The string and the integer are combined into one string and a procedure
{   writes them to output.
{
{ NOTES:
{
{

  PROCEDURE write_string_and_integer
    (    string_a: string ( * );
         integer_a: integer;
         continue_line: boolean;
     VAR display_control: clt$display_control;
     VAR display_status: ost$status);

    VAR
      ignore_status: ost$status,
      line_a: string (2 * fsc$max_path_size),
      line_b: string (2 * fsc$max_path_size),
      line_size_a: integer,
      line_size_b: integer;

    IF NOT display_status.normal THEN
      RETURN;
    IFEND;

    line_a := '';
    STRINGREP (line_a, line_size_a, integer_a);

    line_b := '';
    STRINGREP (line_b, line_size_b, string_a, line_a (2, line_size_a - 1));

    IF continue_line THEN
      clp$put_partial_display (display_control, line_b (1, line_size_b), clc$no_trim, amc$continue,
            ignore_status);
    ELSE
      clp$put_partial_display (display_control, line_b (1, line_size_b), clc$no_trim, amc$terminate,
            ignore_status);
    IFEND;

  PROCEND write_string_and_integer;

MODEND ram$display_correction_attrib;
*DECK DECK=RAM$DISPLAY_CORRECTION_PACKAGE EXPAND=TRUE
  PROC rap$display_correction_package (
    correction_package, cp: file
    output, o: file = $output
    status)

    create_variable local_status k=status
    create_variable ignore_status k=status

    choose_display: BLOCK

      IF $specified(correction_package) THEN
        rap$display_corrections_command cp=$value(correction_package) o=$value(output) status=local_status
      ELSE
        unique_scratch_file = $unique
        rap$write_cp_to_scratch_file o=$fname(unique_scratch_file) status=local_status
        EXIT choose_display WHEN NOT local_status.normal
        rap$display_corrections_command cp=$fname(unique_scratch_file) o=$value(output) status=local_status
        delete_file f=$fname(unique_scratch_file) status=ignore_status
      IFEND

    BLOCKEND choose_display

    EXIT_PROC with local_status
  PROCEND rap$display_correction_package
*DECK DECK=RAM$DISPLAY_DAY EXPAND=TRUE
PROCEDURE display_day, disd (
  month, m: any of
      key
        january, jan, february, feb, march, mar, april, apr, may, june, jun, july, jul, august, aug, september
        sep, october, oct, november, nov, december, dec
      keyend
      integer 1..12
    anyend = $integer($substring($date(iso), 6, 2))
  day, d: integer 1..31 = $integer($substring($date(iso), 9, 2))
  year, y: integer 1..$max_integer = $integer($substring($date(iso), 1, 4))
  output, o: file = $output
  status)

" PURPOSE:
"   Display the day of the week for any given date.
" DESIGN:
"   Compute the day of the week using Julian and Gregorian calanders as neccessary.

"$format=no
  VAR
    days: array 1 .. 7 of string 0 .. 9
    months: array 1 .. 12 of string 0 .. 9
    max_days: array 1 .. 12 of integer
    offset: array 1 .. 12 of integer
    output_line: array 1 .. 2 of string
  VAREND

  months(1)='January'        ;  max_days(1)=31   ;  offset(1)=0
  months(2)='February'       ;  max_days(2)=28   ;  offset(2)=3
  months(3)='March'          ;  max_days(3)=31   ;  offset(3)=3
  months(4)='April'          ;  max_days(4)=30   ;  offset(4)=6
  months(5)='May'            ;  max_days(5)=31   ;  offset(5)=1
  months(6)='June'           ;  max_days(6)=30   ;  offset(6)=4
  months(7)='July'           ;  max_days(7)=31   ;  offset(7)=6
  months(8)='August'         ;  max_days(8)=31   ;  offset(8)=2
  months(9)='September'      ;  max_days(9)=30   ;  offset(9)=5
  months(10)='October'       ;  max_days(10)=31  ;  offset(10)=0
  months(11)='November'      ;  max_days(11)=30  ;  offset(11)=3
  months(12)='December'      ;  max_days(12)=31  ;  offset(12)=5

  days(1)='Friday'
  days(2)='Saturday'
  days(3)='Sunday'
  days(4)='Monday'
  days(5)='Tuesday'
  days(6)='Wednesday'
  days(7)='Thursday'
"$format=yes

  IF $generic_type(month)= key THEN
    test_month=$substring($string(month), 1, 3)
    FOR month = 1 TO 12 DO
      EXIT WHEN test_month = $substring($string($name(months(month))), 1, 3)
    FOREND
  IFEND

  yyyymmdd=year * 10000 + month * 100 + day
  today_yyyymmdd=$integer($substring($date(iso), 1, 4))* 10000 + $integer($substring($date(iso), 6, 2))* 100..
         + $integer($substring($date(iso), 9, 2))
  the_day=months(month) // ' ' // $strrep(day)// ', ' // $strrep(year)
  IF yyyymmdd < today_yyyymmdd THEN
    header=the_day // ' fell on a '
  ELSEIF yyyymmdd = today_yyyymmdd THEN
    header='Today is '
  ELSE
    header=the_day // ' will fall on a '
  IFEND

  IF yyyymmdd <= 17520902 THEN " date for Julian calendar "
    leap_year=$integer($mod(year, 4)=0)
    day_index=$mod((year+(year+3)/4+day+leap_year*$integer(month>=3)+offset(month))+5, 7) + 1
    IF day > (max_days(month) + leap_year * $integer(month=2)) THEN
      output_line(1)=the_day // ' is not a possible date.'
    ELSE
      output_line(1)=header // days(day_index) // ' - Julian (old) calendar.'
    IFEND
  IFEND

  IF (15821015 <= yyyymmdd) AND (yyyymmdd <> 17000229) THEN " date for Gregorian calendar "
    year=$mod(year, 400)
    leap_year=$integer(((year=0) OR ($mod(year, 4)=0) AND ($mod(year, 100)<>0)))
    day_index=$mod((year+(year+3)/4-(year-1)/100+day+leap_year*$integer(month>=3)+offset(month)), 7) + 1
    IF day > (max_days(month) + leap_year * $integer(month=2)) THEN
      output_line(1)=the_day // ' is not a possible date.'
    ELSEIF yyyymmdd <= 17520902 THEN
      output_line(2)=$substring('', 1, $size(header))// days(day_index) // ' - Gregorian (current) calendar.'
    ELSE
      output_line(1)=header // days(day_index) // '.'
    IFEND
  IFEND

  display_value output_line output=output

PROCEND display_day
*DECK DECK=RAM$DISPLAY_DEVICE_FILE EXPAND=TRUE
create_program_description name=(display_device_file, disdf) ..
      sp=display_device_file l=(osf$current_library) ..
      tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$DISPLAY_FILE_PERMITS EXPAND=TRUE
     procedure (help_disfp) display_file_permit, display_file_permits, disfp (
      file, files, f : any of key all, ..
                              keyend, ..
                              list of file, ..
                       anyend = $working_catalog
     status)
    var
      disfp_file          : file
      disfp_file_list     : list of file = $file_list(file)
      disfp_message       : string
    varend
     " display each file's permissions

    for each disfp_file in disfp_file_list do
     if $file(disfp_file,assigned) then
       display_value v='file permissions for '//$string(disfp_file)
       display_catalog_entry f=disfp_file do=p

    "this file does not exist

     else
       disfp_message=$string(disfp_file)//' does not exist.'
       display_message m=disfp_message
       display_value   v=disfp_message
     ifend
    forend

    procend display_file_permit
*DECK DECK=RAM$DISPLAY_FILE_SET_ATTRIBUTES EXPAND=TRUE
PROCEDURE (ram$disfsa) display_file_set_attributes, disfsa (
  file, f: file = $required
  display_options, display_option, do: any of
      key
        all
      keyend
      list of key
        (block_count, bc)
        (block_type, bt)
        (buffer_offset, bo)
        (character_conversion, cc)
        (character_set, cs)
        (creation_date, cd)
        (expiration_date, ed)
        (file_identifier, fi)
        (file_sequence_number, fsn)
        (file_set_identifier, fsi)
        (file_set_position, fsp)
        (generation_number, gn)
        (generation_version_number, gvn)
        (header_labels, hl)
        (maximum_block_length, maxbl)
        (maximum_record_length, maxrl)
        (padding_character, pc)
        (record_type, rt)
        (rewrite_labels, rl)
        (trailer_labels, tl)
      advanced_key
        (file_accessibility, file_accessibility_code, fa, fac)
        (file_section_number, fsen)
        (implementation_identifier, ii)
        (label_standard_version, lsv)
        (owner_identifier, oi)
        (removable_media_group, rmg)
        (volume_accessibility, va)
      keyend
    anyend = osd$distla_display_options, (header_labels trailer_labels)
  output, o: file = $output
  ending_sequence_number, esn: (BY_NAME) integer 1..9999 = 9999
  starting_sequence_number, ssn: (BY_NAME) integer 1..9999 = 1
  status)

  VAR
    display_list: list of any = ()
    displayable_exit_conditions: list of name =(ame$blank_volume_read ame$tape_end_of_volume_list)
    ignore_status: status
    local_status: status
    normal_exit_conditions: list of name =(ame$file_not_in_volume_set ..
    ame$spec_fsn_out_of_seq )
  VAREND

  WHEN any_fault, terminate DO
    EXIT display_file_set_attributes WITH osv$status
  WHENEND

  set_file_attributes output file_contents=list pf=burstable
  change_tape_label_attributes file record_type=u block_type=user_specified

for_loop: ..
  FOR i = starting_sequence_number TO ending_sequence_number DO
    change_tape_label_attributes file file_set_position=( ..
          file_sequence_position i)
    copy_file input=file output=$null status=local_status
    IF local_status.normal THEN
      display_list = $add(..
            $tape_label_attributes(file last_accessed display_options) ..
            display_list)
    ELSE
      FOR EACH condition IN normal_exit_conditions DO
        IF condition = $status_code_name(local_status.condition) THEN
          "Status expected and no additional ANSI files found"
          local_status.normal = true
          EXIT for_loop
        IFEND
      FOREND

      FOR EACH condition IN displayable_exit_conditions DO
        IF condition = $status_code_name(local_status.condition) THEN
          "Status unexpected; it is returned along with the ANSI file
          "attributes"
          display_list = $add(..
                $tape_label_attributes(file last_accessed display_options) ..
                display_list)
          EXIT for_loop
        IFEND
      FOREND

      EXIT for_loop

    IFEND
  FOREND for_loop
  IF NOT $nil(display_list) THEN
    put_line ('1 Display_file_set_attributes for file '//file, '0') ..
          output=output
    display_value $reverse(display_list) output=output.$eoi ..
          display_option=labeled_elements status=ignore_status
  IFEND
  EXIT_PROC WITH local_status

PROCEND display_file_set_attributes
*DECK DECK=RAM$DISPLAY_HPA_DISK_DETAIL EXPAND=TRUE
PROC display_hpa_disk_detail, dishdd (
  input, i: file = $local.$engineering_log
  output, o: file = $output
  status)

  "       Proc Display_HPA_disk_detail converts error information for disks from
  "       the binary Engineering_Log to a format reminiscient of the 170
  "       HPA detail reports (without any analysis).
  "       parameters are as follows:
  "            Input or i = name of file containing engineering_log
  "            Output or o = name of file to receive output

  time_study = false

  IF time_study THEN
    display_job_data output=$null "            preset job data statistics"
  IFEND

  create_variable convert_variable kind=string value=''
  create_variable statistic_counter k=integer v=0
  create_variable ofile k=string v=$unique
  create_variable ofile5 k=string v=$unique
  create_variable (date, code, line) k=string v=''
  create_variable det_line k=string v='' dimension=1..10
  create_variable ext_line k=string v='' d=1..5
  create_variable disk_detail k=string v='' dimension=0..40
  create_variable output_line k=string v='' d=0..11
  create_variable column_pointer k=integer v=97
  create_variable line_pointer k=integer v=5
  create_variable blanks k=string v='                      ' "pad for line10"
  create_variable out_name k=string v=''

  "                          call DISPLAY_BINARY_LOG utility

  display_binary_log i=$value(input) o=$value(output)
  define_group disk1 CM4102
  define_group disk2 CM4100
  define_group disk3 CM4101
  define_group disk4 CM4103
  define_group disk5 CM4104
  generate_group_file disk1 $fname(ofile)
  generate_group_file disk4 $fname(ofile)
  generate_group_file disk3 $fname(ofile)
  generate_group_file disk2 $fname(ofile)
  generate_group_file disk5 $fname(ofile5)
  QUIT

"         build output file name for line by line output"

  out_name = $path($value(output), catalog) // '.' // ..
        $path($value(output), last) // '.'

  IF $file($value(output), permanent) THEN
    out_name = out_name // $strrep($file($value(output), cycle_number)) // ..
          '.$asis'
  ELSE
    out_name = out_name // '$asis'
  IFEND

  lines_read = 0
  accept_line line $fname(ofile//'.$boi') line_count=lines_read

  output_line(3) = 'FCN TY E UN  CYL TK SC STAT    1    2    3    4    5    6..
    7    8    9   10'
  output_line(4) = '---------------------------------------------------------..
-------------------'

  PUSH_COMMANDS
  WHILE lines_read > 0 DO

    IF $substr(line, 2, 2) = 'CM' THEN "     find first line of statistic"

      "         check for change in DATE or statistic CODE type --- need new header"
      IF date <> $substr(line, 13, 7) OR code <> $substr(line, 2, 11) THEN
        date = $substr(line, 13, 7)
        code = $substr(line, 2, 11)

        IF code = 'CM4102' OR code = 'CM4103' THEN
          output_line(2) = ..
                '                       POLL                DETAIL STATUS'
        ELSE
          output_line(2) = ..
                '                       GEN                 DETAIL STATUS'
        IFEND

        output_line(0) = ' ' // code // '      ' // date

        FOR i = 0 TO 4 DO
          put_line ' '//output_line(i) $fname(out_name)
        FOREND
      IFEND

      number_of_counters = $integer($substr(line, 63, 2))

      "             Check for correct NUMBER_OF_COUNTERS"
      IF number_of_counters <> 39 AND number_of_counters <> 60 THEN
        accept_line line $fname(ofile//'.$asis') line_count=lines_read
        CYCLE "                           cycle WHILE loop for next CM code"
      IFEND

      output_line(5) = ' ' // ..
            $substr(line, 21, 8) "    get TIME of error statistic"

      accept_line det_line $fname(ofile//'.$asis') ..
            line_count=lines_read " 10 lines of stat"

      convert_base $substr(det_line(1), 59, 2) 2, 8, ..
            convert_variable "   Equipment_Number to 2 char octal string"
      output_line(6) = convert_variable
      convert_base $substr(det_line(1), 78, 3) 3, 8, ..
            convert_variable "    Unit_Number conversion"
      output_line(6) = output_line(6) // convert_variable

      convert_base $substr(det_line(2), 38, 3) 3, 10, ..
            convert_variable "    Op_Code conversion"
      output_line(8) = '  OPCD= ' // convert_variable
      convert_base $substr(det_line(2), 19, 2) 3, 10, ..
            convert_variable "  Equipment_Type to 3 char decimal string"
      output_line(6) = convert_variable // output_line(6)

      convert_base $substr(det_line(3), 17, 4) 4, 10, ..
            convert_variable " Command_Retry conversion"
      output_line(8) = output_line(8) // ' REQUEST RTY= ' // convert_variable
      IF code = 'CM4102' OR code = 'CM4103' THEN
        convert_base $substr(det_line(3), 37, 4) 5, 8, ..
              convert_variable "      Diag code conversion"
        output_line(8) = output_line(8) // '  DIAG CODE=' // convert_variable
        IF convert_variable <> '     ' THEN
          output_line(8) = output_line(8) // '(8)'
        IFEND
      ELSE
        convert_base $substr(det_line(3), 37, 4) 4, 10, ..
              convert_variable "      Sector_Retry conversion"
        output_line(8) = output_line(8) // ' SECTOR RTY= ' // convert_variable
      IFEND
      convert_base $substr(det_line(3), 57, 4) 5, 8, ..
            convert_variable "      Initial_Cylinder conversion"
      output_line(6) = output_line(6) // convert_variable
      convert_base $substr(det_line(3), 78, 3) 3, 8, ..
            convert_variable "    Initial_Track conversion"
      output_line(6) = output_line(6) // convert_variable
      convert_base $substr(det_line(4), 18, 3) 3, 8, ..
            convert_variable "    Initial_Sector conversion"
      output_line(6) = output_line(6) // convert_variable

      convert_base $substr(det_line(4), 37, 4) 5, 8, ..
            convert_variable "      Error_Cylinder conversion"
      output_line(7) = '  ERROR POS ' // convert_variable
      convert_base $substr(det_line(4), 58, 3) 3, 8, ..
            convert_variable "    Error_Track conversion"
      output_line(7) = output_line(7) // convert_variable
      convert_base $substr(det_line(4), 78, 3) 3, 8, ..
            convert_variable "    Error_Sector conversion"
      output_line(7) = output_line(7) // convert_variable // '     '

      convert_base $substr(det_line(5), 16, 5) 5, 10, ..
            convert_variable "      Residual_Count conversion"
      output_line(8) = output_line(8) // ' RESIDUAL CNT= ' // convert_variable
      convert_base $substr(det_line(5), 38, 3) 4, 8, ..
            convert_variable "    Failing_Function conversion"
      output_line(6) = convert_variable // output_line(6)
      IF code = 'CM4102' OR code = 'CM4103' THEN
        convert_base $substr(det_line(5), 57, 5) 4, 16, ..
              convert_variable "     Poll_Status conversion"
        convert_variable = ' ' // convert_variable
      ELSE
        convert_base $substr(det_line(5), 57, 4) 5, 8, ..
              convert_variable "      General_Status conversion"
      IFEND
      output_line(6) = output_line(6) // convert_variable

      column_pointer = 77
      line_pointer = 5

      FOR i = 1 TO 20 DO "                 convert detail status here"
        IF column_pointer = 97 THEN
          column_pointer = 17
          line_pointer = line_pointer + 1
        IFEND

        convert_variable = $strrep(..
              $integer($substr(det_line(line_pointer), column_pointer, 4)), 8)

        IF convert_variable = '-1' THEN
          disk_detail(i) = '    '
        ELSEIF $strlen(convert_variable) < 4 THEN
          disk_detail(i) = ..
                $substr(blanks, 1, 4-$strlen(convert_variable)) // ..
                convert_variable
        ELSE
          disk_detail(i) = convert_variable
        IFEND
        column_pointer = column_pointer + 20
      FOREND

      FOR i = 1 TO 10 DO
        output_line(6) = output_line(6) // '/' // disk_detail(i)
        output_line(7) = output_line(7) // '/' // disk_detail(i + 10)
      FOREND

      IF number_of_counters = 60 THEN "   Final_Status formatting"
        IF code = 'CM4102' OR code = 'CM4103' THEN
          convert_base $substr(det_line(line_pointer), 77, 5) 4, 16, ..
                convert_variable " Poll_Status conversion"
          convert_variable = ' ' // convert_variable
        ELSE
          convert_base $substr(det_line(line_pointer), 77, 4) 5, 8, ..
                convert_variable " General_Status conversion"
        IFEND
        output_line(9) = '  FINAL STAT UNREC ERR ' // convert_variable
        accept_line ext_line $fname(ofile//'.$asis') ..
              line_count=lines_read "5 lines of extended status"
        line_pointer = 1
        column_pointer = 17
        output_line(10) = blanks // ..
              '      ' "         initialize OUTPUT_LINE(10)

        FOR i = 21 TO 40 DO
          IF column_pointer = 97 THEN
            column_pointer = 17
            line_pointer = line_pointer + 1
          IFEND

          convert_variable = $strrep(..
                $integer($substr(ext_line(line_pointer), column_pointer, 4)),..
                 8)

          IF convert_variable = '-1' THEN
            disk_detail(i) = '    '
          ELSEIF $strlen(convert_variable) < 4 THEN
            disk_detail(i) = ..
                  $substr(blanks, 1, 4-$strlen(convert_variable)) // ..
                  convert_variable
          ELSE
            disk_detail(i) = convert_variable
          IFEND
          column_pointer = column_pointer + 20
        FOREND

        FOR i = 21 TO 30 DO
          output_line(9) = output_line(9) // '/' // disk_detail(i)
          output_line(10) = output_line(10) // '/' // disk_detail(i + 10)
        FOREND
      IFEND

      accept_line line $fname(ofile//'.$asis') ..
            line_count=lines_read "ANALYSIS line of stat"
      output_line(5) = output_line(5) // line

      statistic_counter = statistic_counter + 1

      put_line output_line(5) $fname(out_name)
      put_line output_line(6) $fname(out_name)
      put_line output_line(7) $fname(out_name)

      IF number_of_counters = 60 THEN
        put_line output_line(9) ..
              $fname(out_name) "  output Final_Status lines, if present"
        put_line output_line(10) $fname(out_name)
      IFEND

      put_line output_line(8) $fname(out_name)
      put_line output_line(11) $fname(out_name)
    IFEND

    accept_line line $fname(ofile//'.$asis') ..
          line_count=lines_read "try next line"

  WHILEND

  IF statistic_counter = 0 THEN
    put_line ' SPECIFIED LOG CONTAINS NO ISD/844/885 DISK ERRORS ' output=$fname(out_name)
  ELSE
    put_line ' END OF ISD/844/885 DISK ERRORS ' output=$fname(out_name)
  IFEND

  IF time_study THEN
    display_value ' ' output=$fname(out_name)
    put_line '  THE NUMBER OF STATISTICS IS  '//$strrep(statistic_counter) ..
          output=$fname(out_name)
    disjd display_format=incremental output=$fname(out_name)
  IFEND
  detach_file $fname(ofile)

"  process 895 (33800) error entries
  lines_read = 0
  accept_line line $fname(ofile5//'.$boi') line_count=lines_read

  output_line(2) = '       SD/                GEN  CYB  895DI           '//..
        '   SENSE BYTES'
  output_line(3) = 'FCN TY HSC UN  CYL TK SC  STAT STAT STAT    0  1  2  3  4..
  5  6  7  8  9 10 11'
  output_line(4) = '---------------------------------------------------------..
---------------------'

  WHILE lines_read > 0 DO

    IF $substr(line, 2, 2) = 'CM' THEN "     find first line of statistic"

      "         check for change in DATE or statistic CODE type --- need new header"
      IF date <> $substr(line, 13, 7) OR code <> $substr(line, 2, 11) THEN
        date = $substr(line, 13, 7)
        code = $substr(line, 2, 11)

        output_line(0) = ' ' // code // '      ' // date

        FOR i = 0 TO 4 DO
          put_line ' '//output_line(i) $fname(out_name)
        FOREND
      IFEND

      number_of_counters = $integer($substr(line, 63, 2))

      "             Check for correct NUMBER_OF_COUNTERS"
      IF number_of_counters <> 40 AND number_of_counters <> 46 AND number_of_counters <> 60 THEN
        accept_line line $fname(ofile5//'.$asis') line_count=lines_read
        CYCLE "                           cycle WHILE loop for next CM code"
      IFEND

      output_line(5) = ' ' // ..
            $substr(line, 19, 8) "    get TIME of error statistic"

      accept_line det_line $fname(ofile5//'.$asis') ..
            line_count=lines_read " 10 lines of stat"

      convert_base $substr(det_line(1), 59, 2) 4, 8, ..
            convert_variable "   SD/HSC Number to 3 char ##octal## string"
      output_line(6) = convert_variable
      convert_base $substr(det_line(1), 78, 3) 3, 8, ..
            convert_variable "    Unit_Number conversion"
      output_line(6) = output_line(6) // convert_variable

      convert_base $substr(det_line(2), 38, 3) 3, 10, ..
            convert_variable "    Op_Code conversion"
      output_line(8) = '  OPCD= ' // convert_variable
      convert_base $substr(det_line(2), 19, 2) 3, 10, ..
            convert_variable "  Equipment_Type to 3 char decimal string"
      output_line(6) = convert_variable // output_line(6)

      convert_base $substr(det_line(3), 17, 4) 4, 10, ..
            convert_variable " Command_Retry conversion"
      output_line(8) = output_line(8) // ' REQUEST RTY= ' // convert_variable
      convert_base $substr(det_line(3), 37, 4) 5, 8, ..
            convert_variable "      Diag code conversion"
      output_line(8) = output_line(8) // '  DIAG CODE=' // convert_variable
      IF convert_variable <> '     ' THEN
        output_line(8) = output_line(8) // '(8)'
      IFEND
      convert_base $substr(det_line(3), 57, 4) 5, 8, ..
            convert_variable "      Initial_Cylinder conversion"
      output_line(6) = output_line(6) // convert_variable
      convert_base $substr(det_line(3), 78, 3) 3, 8, ..
            convert_variable "    Initial_Track conversion"
      output_line(6) = output_line(6) // convert_variable
      convert_base $substr(det_line(4), 18, 3) 3, 8, ..
            convert_variable "    Initial_Sector conversion"
      output_line(6) = output_line(6) // convert_variable

      convert_base $substr(det_line(4), 37, 4) 5, 8, ..
            convert_variable "      Error_Cylinder conversion"
      output_line(7) = '  ERROR POS   ' // convert_variable
      convert_base $substr(det_line(4), 58, 3) 3, 8, ..
            convert_variable "    Error_Track conversion"
      output_line(7) = output_line(7) // convert_variable
      convert_base $substr(det_line(4), 78, 3) 3, 8, ..
            convert_variable "    Error_Sector conversion"
      output_line(7) = output_line(7) // convert_variable

      convert_base $substr(det_line(5), 16, 5) 5, 10, ..
            convert_variable "      Residual_Count conversion"
      output_line(8) = output_line(8) // ' RESIDUAL CNT= ' // convert_variable
      convert_base $substr(det_line(5), 38, 3) 4, 8, ..
            convert_variable "    Failing_Function conversion"
      output_line(6) = convert_variable // output_line(6)
      convert_base $substr(det_line(5), 57, 4) 6, 8, ..
            convert_variable "      General_Status conversion"
      output_line(6) = output_line(6) // convert_variable
      convert_base $substr(det_line(10), 17, 4) 4, 8, ..
            convert_variable "      Cyber status conversion"
      output_line(6) = output_line(6) // '/' //convert_variable
      convert_base $substr(det_line(10), 37, 4) 4, 8, ..
            convert_variable "      895 DI Status conversion"
      output_line(6) = output_line(6) // '/' // convert_variable // '  '
      convert_base $substr(det_line(10), 57, 4) 4, 8, ..
            convert_variable "      ccc status conversion"
      output_line(7) = output_line(7) // ' CCC=' //convert_variable
      convert_base $substr(det_line(9), 77, 4) 4, 8, ..
            convert_variable "      cw conversion"
      output_line(7) = output_line(7) // ' CW=' // convert_variable // ' '

      sense_byte_status = ''
      column_pointer = 77
      line_pointer = 5

      FOR i = 1 TO 16 DO "                 convert sense byte status here"
        IF column_pointer = 97 THEN
          column_pointer = 17
          line_pointer = line_pointer + 1
        IFEND

        convert_variable = $strrep(..
              $integer($substr(det_line(line_pointer), column_pointer, 4)), 16)

        IF convert_variable = '-1' THEN
          convert_variable = '   '
        ELSEIF $strlen(convert_variable) = 4 AND ..
              $substr(convert_variable, 1, 1) = '0' THEN
          convert_variable = $substr(convert_variable, 2, 3)
        ELSEIF $strlen(convert_variable) = 2 THEN
          convert_variable = '0' // convert_variable
        ELSEIF $strlen(convert_variable) = 1 THEN
          convert_variable = '00' // convert_variable
        IFEND
        sense_byte_status = sense_byte_status // convert_variable
        column_pointer = column_pointer + 20
      FOREND

      FOR i = 1 TO 12 DO
        output_line(6) = output_line(6) // '/' // $substr(sense_byte_status,..
              ((2 * i) - 1), 2)
        output_line(7) = output_line(7) // '/' // $substr(sense_byte_status,..
              ((2 * (i + 12)) - 1), 2)
      FOREND

      IF number_of_counters = 60 THEN "   Final_Status formatting"
        convert_base $substr(det_line(10), 77, 4) 5, 8, ..
              convert_variable " General_Status conversion"
        output_line(9) = '  FINAL STAT UNREC ERR    ' // convert_variable
        accept_line ext_line $fname(ofile5//'.$asis') ..
              line_count=lines_read "5 lines of extended status"
      convert_base $substr(ext_line(5), 37, 4) 4, 8, ..
            convert_variable "      Cyber status conversion"
      output_line(9) = output_line(9) // '/' //convert_variable
      convert_base $substr(ext_line(5), 57, 4) 4, 8, ..
            convert_variable "      895 DI Status conversion"
      output_line(9) = output_line(9) // '/' // convert_variable // '  '
      convert_base $substr(ext_line(5), 77, 4) 4, 8, ..
            convert_variable "      ccc status conversion"
      output_line(10) = blanks // ..
            '  ' "         initialize OUTPUT_LINE(10) "
      output_line(10) = output_line(10) // '  CCC=' //convert_variable
      convert_base $substr(ext_line(5), 17, 4) 4, 8, ..
            convert_variable "      cw conversion"
      output_line(10) = output_line(10) // ' CW=' // convert_variable // ' '

        line_pointer = 1
        column_pointer = 17
        sense_byte_status = ''

        FOR i = 1 TO 16 DO "                 convert sense byte status here"
          IF column_pointer = 97 THEN
            column_pointer = 17
            line_pointer = line_pointer + 1
          IFEND

          convert_variable = $strrep(..
                $integer($substr(ext_line(line_pointer), column_pointer, 4)),..
                 16)

          IF convert_variable = '-1' THEN
            convert_variable = '   '
          ELSEIF $strlen(convert_variable) = 4 AND ..
                $substr(convert_variable, 1, 1) = '0' THEN
            convert_variable = $substr(convert_variable, 2, 3)
          ELSEIF $strlen(convert_variable) = 2 THEN
            convert_variable = '0' // convert_variable
          ELSEIF $strlen(convert_variable) = 1 THEN
            convert_variable = '00' // convert_variable
          IFEND
          sense_byte_status = sense_byte_status // convert_variable
          column_pointer = column_pointer + 20
        FOREND

        FOR i = 1 TO 12 DO
          output_line(9) = output_line(9) // '/' // $substr(sense_byte_status,..
                ((2 * i) - 1), 2)
          output_line(10) = output_line(10) // '/' // ..
                $substr(sense_byte_status, ((2 * (i + 12)) - 1), 2)
        FOREND
      IFEND

      accept_line line $fname(ofile5//'.$asis') ..
            line_count=lines_read "ANALYSIS line of stat"
      output_line(5) = output_line(5) // line

      statistic_counter = statistic_counter + 1

      put_line output_line(5) $fname(out_name)
      put_line output_line(6) $fname(out_name)
      put_line output_line(7) $fname(out_name)

      IF number_of_counters = 60 THEN
        put_line output_line(9) ..
              $fname(out_name) "  output Final_Status lines, if present"
        put_line output_line(10) $fname(out_name)
      IFEND

      put_line output_line(8) $fname(out_name)
      put_line output_line(11) $fname(out_name)
    IFEND

    accept_line line $fname(ofile5//'.$asis') ..
          line_count=lines_read "try next line"

  WHILEND

  IF statistic_counter = 0 THEN
    put_line ' SPECIFIED LOG CONTAINS NO 895/33800 DISK ERRORS ' output=$fname(out_name)
  ELSE
    put_line ' END OF 895/33800 DISK ERRORS ' output=$fname(out_name)
  IFEND

  IF time_study THEN
    display_value ' ' output=$fname(out_name)
    put_line '  THE NUMBER OF STATISTICS IS  '//$strrep(statistic_counter) ..
          output=$fname(out_name)
    disjd display_format=incremental output=$fname(out_name)
  IFEND
  detach_file $fname(ofile5)

PROCEND display_hpa_disk_detail

*DECK DECK=RAM$DISPLAY_HPA_SUMMARY EXPAND=TRUE
PROC display_hpa_summary, dishs (
  input, i: file = $local.$engineering_log
  output, o: file = $output
  status)

"          PROC display_hpa_summary displays a summary of the errors reported
"            in the system Engineering_Log (binary).  This summary is an
"            edited version of the output produced by the utility DISBL.
"
"            parameters are as follows:
"              input or i   = name of a file containing an engineering log.
"              output or o = name of file to recieve the output
"
  create_variable (input_line, output_line) k=string
  create_variable local_status k=status
  create_variable in_file k=string v=$unique
  create_variable test k=string "variable to hold parameter evaluation"

"           create line for display_binary_log call here"

  IF $job(mode) = 'INTERACTIVE' THEN
    out_file = '$local.'//$unique
    put_line 'display_binary_log i='//$string($value(input))//' o='//out_file ..
          o=$fname(in_file//'.$boi')
  ELSE
    put_line 'disbl i='//$string($value(input))//' o='//$string($value(output))..
           o=$fname(in_file//'.$boi')
  IFEND

COLLECT_TEXT $fname(in_file//'.$eoi')
  defg all_errors
  disdd all_errors
  QUIT
**

  include_file $fname(in_file)

  IF $job(mode) = 'INTERACTIVE' THEN

"         build output file name for line by line output"

    output_attached_by_proc = FALSE
    setfa $value(output) fc=list
    put_line '' o=$value(output)
    out_name = $path($value(output), catalog) // '.' // ..
          $path($value(output), last) // '.'
    IF $file($value(output), permanent) THEN
      out_name = out_name // $strrep($file($value(output), cycle_number)) // ..
            '.$asis'
      IF NOT $file($value(output), attached) THEN
        attach_file $value(output) am=all sm=none
        output_attached_by_proc = TRUE
      IFEND
    ELSE
      out_name = out_name // '$asis'
    IFEND

    lines_read = 0
    accept_line input_line $fname(out_file//'.$boi') line_count=lines_read
    WHILE lines_read > 0 DO
      output_line = $substr(input_line, 1, 71)
      IF output_line = '0 ***  There is no elements for this group' THEN
        output_line = ..
              '0 ***  SELECTED LOG CONTAINS NO ERROR STATISTICS OF THIS TYPE'
      IFEND

      put_line output_line $fname(out_name) status=local_status
      accept_line input_line $fname(out_file//'.$asis') line_count=lines_read
    WHILEND
    detach_file $fname(out_file) status=local_status
  IFEND

  detach_file $fname(in_file) status=local_status
  IF output_attached_by_proc THEN
    detach_file $value(output)
  IFEND

PROCEND display_hpa_summary
*DECK DECK=RAM$DISPLAY_HPA_TAPE_DETAIL EXPAND=TRUE
PROC display_hpa_tape_detail, dishtd (
  input, i: file = $local.$engineering_log
  output, o: file = $output
  status)

  "       Proc Display_hpa_tape_detail converts error information for tapes from
  "       the binary Engineering_Log to a format reminiscient of the 170
  "       HPA detail reports (without any analysis).
  "       parameters are as follows:
  "            Input or i = name of file containing previously terminated
  "                         engineering_log.  Default is current log.
  "            Output or o =name of file to receive the listing of errors.

  time_study = false

  IF time_study THEN
    display_job_data output=$null "            preset job data statistics"
  IFEND

  create_variable convert_variable kind=string value=''
  create_variable blanks k=string v='                    '
  create_variable byte_status k=(string, 2) d=0..34 v=''
  create_variable out_file_2 k=string v=$unique
  create_variable out_file_4 k=string v=$unique
  create_variable out_name k=string v=''
  create_variable statistic_counter k=integer v=0
  create_variable (date, code, line) k=string v=''
  create_variable stat_count k=integer
  create_variable stat_line k=string v='' d=1..17
  create_variable tape_status k=string v='' dimension=1..16
  create_variable output_line k=string v='' d=0..13
  create_variable column_pointer k=integer v=97
  create_variable line_pointer k=integer v=1
  create_variable hardware_function k=string v='    '
  create_variable local_status k=status
  create_variable unrec_failure k=boolean

  display_binary_log i=$value(input) o=$value(output)
  " define_group tape0 CM351000
  define_group tape2 CM5100
  define_group tape4 CM5101
  generate_group_file tape2 $fname(out_file_2)
  generate_group_file tape4 $fname(out_file_4)
  " generate_group_file tape0 $fname(out_file_2)
  QUIT

"         build output file name for line by line output"

  out_name = $path($value(output), catalog) // '.' // ..
        $path($value(output), last) // '.'

  IF $file($value(output), permanent) THEN
    out_name = out_name // $strrep($file($value(output), cycle_number)) // ..
          '.$asis'
  ELSE
    out_name = out_name // '$asis'
  IFEND

  lines_read = 0
  accept_line line $fname(out_file_2//'.$boi') line_count=lines_read

  output_line(2) = '                                             STATUS'
  output_line(3) = ' OPCD TYP PP CH EQ  UN RTY  DEN  FCN   GS1  GS2  DS3  DS4'
  output_line(3) = output_line(3) // '  DS5  DS6  DS7  DS8 '
  output_line(4) = ' -------------------------------------------------------'
  output_line(4) = output_line(4) // '---------------------'

  PUSH_COMMANDS
  WHILE lines_read > 0 DO

    IF $substr(line, 2, 2) = 'CM' THEN "     find first line of statistic"

      "         check for change in DATE or statistic CODE type --- need new header"
      IF date <> $substr(line, 13, 7) OR code <> $substr(line, 2, 11) THEN
        date = $substr(line, 13, 7)
        code = $substr(line, 2, 11)
        output_line(0) = '  ' // code // '      ' // date

        FOR i = 0 TO 4 DO
          put_line output_line(i) output=$fname(out_name)
        FOREND

      IFEND

      number_of_counters = $integer($substr(line, 63, 2))
      IF number_of_counters <> 62 THEN "     check for sufficient counters"
        accept_line line $fname(out_file_2//'.$asis') line_count=lines_read
        CYCLE "                           cycle WHILE loop for next CM code"
      IFEND

      output_line(5) = $substr(line, 19, 8) "      get TIME of error statistic"
      output_line(5) = $substr(line, 21, 8) "      get TIME of error statistic"

      "  input all status here"
      accept_line stat_line $fname(out_file_2//'.$asis') line_count=lines_read
      output_line(5) = output_line(5) // stat_line(17)

      column_pointer = $scan_string('*UF*', stat_line(17))
      unrec_failure = (column_pointer <> 0)

      convert_base $substr(stat_line(1), 18, 3) 3, 8 ..
            convert_variable "     PPU_Number to 3 char octal string"
      output_line(6) = convert_variable
      convert_base $substr(stat_line(1), 38, 3) 3, 8, ..
            convert_variable "    Channel_Number conversion"
      output_line(6) = output_line(6) // convert_variable
      convert_base $substr(stat_line(1), 59, 2) 3, 8 ..
            convert_variable "  Equipment_Number to 3 char octal string"
      output_line(6) = output_line(6) // convert_variable
      convert_base $substr(stat_line(1), 78, 3) 4, 8, ..
            convert_variable "   Unit_Number conversion"
      output_line(6) = output_line(6) // convert_variable

      convert_base $substr(stat_line(2), 17, 4) 4, 10, ..
            convert_variable "    Equipment_Type to 4 char decimal string"
      output_line(6) = convert_variable // output_line(6)
      convert_base $substr(stat_line(2), 37, 4) 4, 10, ..
            convert_variable "     Op_Code conversion"
      output_line(6) = convert_variable // output_line(6)

      convert_base $substr(stat_line(5), 37, 4) 4, 10, ..
            convert_variable "   Retry conversion"
      output_line(6) = output_line(6) // convert_variable

      convert_base $substr(stat_line(4), 13, 8) 8, 10, ..
            convert_variable "      Current_Block_Count conversion"
      output_line(8) = ' BLK CNTS: CUR= ' // convert_variable
      convert_base $substr(stat_line(3), 33, 8) 8, 10, ..
            convert_variable "    Blocks_Read conversion"
      output_line(8) = output_line(8) // ' READ= ' // convert_variable
      convert_base $substr(stat_line(3), 13, 8) 8, 10, ..
            convert_variable "    Blocks_Written conversion"
      output_line(8) = output_line(8) // ' WRITTEN= ' // convert_variable
      convert_base $substr(stat_line(4), 33, 8) 8, 10, ..
            convert_variable "    Absolute file/tape mark from load point"
      output_line(8) = output_line(8) // ' FILE MKS= ' // convert_variable

      convert_base $substr(stat_line(4), 49, 12) 12, 8, ..
            convert_variable "                Format_Request conversion"
      output_line(7) = ' FORMAT= ' // convert_variable
      convert_base $substr(stat_line(5), 19, 2) 2, 8, ..
            convert_variable "                Recovery type performed"
      output_line(7) = output_line(7) // ' RCV TYP= ' // convert_variable // ..
            '   '
      convert_base $substr(stat_line(4), 77, 4) 5, 10, ..
            convert_variable "                    Density conversion"
      output_line(6) = output_line(6) // convert_variable
      convert_base $substr(stat_line(5), 57, 4) 5, 8, ..
            convert_variable "               Hardware Function Conversion"
      output_line(6) = output_line(6) // convert_variable // ' '

      "         Convert all status in following loop"
      stat_count = 1
      column_pointer = 61
      line_pointer = 5
      FOR i = 1 TO 4 DO
        IF column_pointer = 81 THEN
          column_pointer = 1
          line_pointer = line_pointer + 1
        IFEND

        convert_to_octal_bytes ..
              $substr(stat_line(line_pointer), column_pointer, 20), ..
              convert_variable, status=local_status
        FOR j = 0 TO 3 DO
          tape_status(stat_count) = $substr(convert_variable, (4*j+1), 4)
          stat_count = stat_count + 1
        FOREND
        column_pointer = column_pointer + 20
      FOREND

      FOR i = 1 TO 8 DO
        output_line(6) = output_line(6) // '/' // tape_status(i)
        output_line(7) = output_line(7) // '/' // tape_status(i + 8)
      FOREND

      IF unrec_failure THEN
        stat_count = 1
        column_pointer = 1
        line_pointer = 8
        FOR i = 1 TO 4 DO
          convert_to_octal_bytes ..
                $substr(stat_line(line_pointer), column_pointer, 20), ..
                convert_variable, status=local_status
          FOR j = 0 TO 3 DO
            tape_status(stat_count) = $substr(convert_variable, (4*j+1), 4)
            stat_count = stat_count + 1
          FOREND
          column_pointer = column_pointer + 20
        FOREND
        output_line(10) = '              Final status for an   '
        output_line(11) = '              unrecovered failure   '

        FOR i = 1 TO 8 DO
          output_line(10) = output_line(10) // '/' // tape_status(i)
          output_line(11) = output_line(11) // '/' // tape_status(i + 8)
        FOREND

      IFEND

      statistic_counter = statistic_counter + 1

      FOR k = 5 TO 9 DO
        put_line ' '//output_line(k) $fname(out_name)
        IF (k = 7) AND unrec_failure THEN
          put_line ' '//output_line(10) $fname(out_name)
          put_line ' '//output_line(11) $fname(out_name)
        IFEND
      FOREND

    IFEND

    line = ''
    accept_line line $fname(out_file_2//'.$asis') ..
          line_count=lines_read "try next line"

  WHILEND

  IF statistic_counter = 0 THEN
    put_line '  THERE ARE NO ATS TAPE ERRORS IN THE DESIGNATED LOG ' ..
          output=$fname(out_name)
  ELSE
    put_line '  END OF ATS TAPE ERRORS  ' output=$fname(out_name)
  IFEND

  IF time_study THEN
    put_line ' ' output=$fname(out_name)
    put_line '  THE NUMBER OF STATISTICS IS  '//$strrep(statistic_counter) ..
          output=$fname(out_name)
    display_job_data display_format=incremental output=$fname(out_name)
  IFEND

"ISMT error formatting here"

  statistic_counter = 0
  lines_read = 0
  accept_line line $fname(out_file_4//'.$boi') line_count=lines_read

  output_line(2) = '                                             STATUS'
  output_line(3) = ' OPCD TYP PP CH EQ  UN RTY DEN  FCN    GS1  GS2  DS3     '
  output_line(3) = output_line(3) // '  SENSE BYTES        '
  output_line(4) = ' --------------------------------------------------------'
  output_line(4) = output_line(4) // '---------------------'

  WHILE lines_read > 0 DO

    IF $substr(line, 2, 2) = 'CM' THEN "     find first line of statistic"

      "         check for change in DATE or statistic CODE type --- need new header"
      IF date <> $substr(line, 13, 7) OR code <> $substr(line, 2, 11) THEN
        date = $substr(line, 13, 7)
        code = $substr(line, 2, 11)
        output_line(0) = '  ' // code // '      ' // date

        FOR i = 0 TO 4 DO
          put_line output_line(i) output=$fname(out_name)
        FOREND

      IFEND

      number_of_counters = $integer($substr(line, 63, 2))
      IF number_of_counters <> 62 THEN "     check for sufficient counters"
        accept_line line $fname(out_file_4//'.$asis') line_count=lines_read
        CYCLE "                           cycle WHILE loop for next CM code"
      IFEND

      output_line(5) = $substr(line, 19, 8) "      get TIME of error statistic"
      output_line(5) = $substr(line, 21, 8) "      get TIME of error statistic"

      accept_line stat_line $fname(out_file_4//'.$asis') ..
            line_count=lines_read "  all stat"
      output_line(5) = output_line(5) // stat_line(17)

      unrec_failure = $integer($substr(stat_line(2), 56, 5)) > 0

      convert_base $substr(stat_line(1), 18, 3) 3, 8 ..
            convert_variable "     PPU_Number to 3 char octal string"
      output_line(6) = convert_variable
      convert_base $substr(stat_line(1), 38, 3) 3, 8, ..
            convert_variable "    Channel_Number conversion"
      output_line(6) = output_line(6) // convert_variable
      convert_base $substr(stat_line(1), 59, 2) 3, 8 ..
            convert_variable "  Equipment_Number to 3 char octal string"
      output_line(6) = output_line(6) // convert_variable
      convert_base $substr(stat_line(1), 78, 3) 4, 8, ..
            convert_variable "   Unit_Number conversion"
      output_line(6) = output_line(6) // convert_variable

      convert_base $substr(stat_line(2), 17, 4) 4, 10, ..
            convert_variable "    Equipment_Type to 4 char decimal string"
      output_line(6) = convert_variable // output_line(6)
      convert_base $substr(stat_line(2), 37, 4) 4, 10, ..
            convert_variable "     Op_Code conversion"
      output_line(6) = convert_variable // output_line(6)

      convert_base $substr(stat_line(5), 37, 4) 4, 10, ..
            convert_variable "   Retry conversion"
      output_line(6) = output_line(6) // convert_variable

      convert_base $substr(stat_line(4), 13, 8) 8, 10, ..
            convert_variable "      Current_Block_Count conversion"
      output_line(9) = ' BLK CNTS: CUR= ' // convert_variable
      convert_base $substr(stat_line(3), 33, 8) 8, 10, ..
            convert_variable "    Blocks_Read conversion"
      output_line(9) = output_line(9) // ' READ= ' // convert_variable
      convert_base $substr(stat_line(3), 13, 8) 8, 10, ..
            convert_variable "    Blocks_Written conversion"
      output_line(9) = output_line(9) // ' WRITTEN= ' // convert_variable
      convert_base $substr(stat_line(4), 33, 8) 8, 10, ..
            convert_variable "    Absolute file/tape mark from load point"
      output_line(9) = output_line(9) // ' FILE MKS= ' // convert_variable

      convert_base $substr(stat_line(4), 49, 12) 12, 8, ..
            convert_variable "    Format_Request conversion"
      output_line(7) = ' FORMAT= ' // convert_variable
      convert_base $substr(stat_line(5), 19, 2) 2, 8, ..
            convert_variable "                Recovery type performed"
      output_line(7) = output_line(7) // ' RCV TYP= ' // convert_variable // ..
            '   '
      convert_base $substr(stat_line(4), 77, 4) 5, 10, ..
            convert_variable "                    Density conversion"
      output_line(6) = output_line(6) // convert_variable
      convert_base $substr(stat_line(5), 57, 4) 5, 8, ..
            convert_variable "               Hardware Function Conversion"
      output_line(6) = output_line(6) // convert_variable // ' '

      output_line(8) = '                                    '
      output_line(10) = ' '

      "         Convert all 12-bit status in following loop"
      convert_to_octal_bytes $substr(stat_line(5), 61, 20), convert_variable, ..
            status=local_status
      tape_status(1) = $substr(convert_variable, 1, 4)
      tape_status(2) = $substr(convert_variable, 5, 4)
      tape_status(3) = $substr(convert_variable, 9, 4)

      output_line(6) = output_line(6) // '/' // tape_status(1) // '/' // ..
            tape_status(2) // '/' // tape_status(3) // '   '

      recovered_70_code = ($substr(tape_status(3), 3, 2) = '70')

      IF recovered_70_code Then
"  get word 10 of status to obtain adapter error code"
        convert_to_octal_bytes $substr(stat_line(6), 21, 20), convert_variable,..
               status=local_status
        output_line(7) = output_line(7) // ' ADPT ERR CODE (DS WORD 10)= '..
               // $substr(convert_variable, 5, 4) // '(8)'
      ELSE
        stat_count = 0
        line_pointer = 6
        column_pointer = 61
        FOR i = 1 TO 5 DO
          IF column_pointer = 81 THEN
            column_pointer = 1
            line_pointer = line_pointer + 1
          IFEND

          convert_base $substr(stat_line(line_pointer), column_pointer, 20), 16..
                , 16, convert_variable, status=local_status
          FOR j = 0 TO 7 DO
            byte_status(stat_count) = $substr(convert_variable, (2*j+1), 2)
            stat_count = stat_count + 1
            EXIT WHEN (stat_count = 35)
          FOREND
          column_pointer = column_pointer + 20
        FOREND

        output_line(8) = '                                    '
        FOR i = 0 TO 7 DO
          output_line(6) = output_line(6) // '/' // byte_status(i)
        FOREND
        FOR i = 8 TO 20 DO
          output_line(7) = output_line(7) // '/' // byte_status(i)
          output_line(8) = output_line(8) // '/' // byte_status(i + 14)
        FOREND
        output_line(7) = output_line(7) // '/' // byte_status(21)
      IFEND

      IF unrec_failure THEN
        output_line(11) = '              Final status for an   '
        output_line(12) = '              unrecovered failure   '
        output_line(13) = '                                    '

        convert_to_octal_bytes $substr(stat_line(8), 1, 20), convert_variable, ..
              status=local_status
        tape_status(1) = $substr(convert_variable, 1, 4)
        tape_status(2) = $substr(convert_variable, 5, 4)
        tape_status(3) = $substr(convert_variable, 9, 4)
        output_line(11) = output_line(11) // '/' // tape_status(1) // '/' // ..
              tape_status(2) // '/' // tape_status(3) // '   '

        unrecovered_70_code = ($substr(tape_status(3), 3, 2) = '70')

        IF unrecovered_70_code Then
"  get word 10 of status to get sub_error code"
          convert_to_octal_bytes $substr(stat_line(8), 41, 20), ..
                convert_variable, status=local_status
          output_line(12) = output_line(12) // ' ADPT ERR CODE (DS WORD 10)= '..
                 // $substr(convert_variable, 5, 4) // '(8)'
        ELSE
          stat_count = 0
          line_pointer = 9
          column_pointer = 1
          FOR i = 1 TO 5 DO
            IF column_pointer = 81 THEN
              column_pointer = 1
              line_pointer = line_pointer + 1
            IFEND

            convert_base $substr(stat_line(line_pointer), column_pointer, 20), ..
                  16, 16, convert_variable, status=local_status
            FOR j = 0 TO 7 DO
              byte_status(stat_count) = $substr(convert_variable, (2*j+1), 2)
              stat_count = stat_count + 1
              EXIT WHEN (stat_count = 35)
            FOREND
            column_pointer = column_pointer + 20
          FOREND

          FOR i = 0 TO 7 DO
            output_line(11) = output_line(11) // '/' // byte_status(i)
          FOREND
          FOR i = 8 TO 20 DO
            output_line(12) = output_line(12) // '/' // byte_status(i)
            output_line(13) = output_line(13) // '/' // byte_status(i + 14)
          FOREND
          output_line(12) = output_line(12) // '/' // byte_status(21)
        IFEND
      IFEND

      statistic_counter = statistic_counter + 1

      put_line ' '//output_line(5) $fname(out_name)
      put_line ' '//output_line(6) $fname(out_name)
      put_line ' '//output_line(7) $fname(out_name)
      IF NOT recovered_70_code THEN
        put_line ' '//output_line(8) $fname(out_name)
      IFEND
      IF unrec_failure THEN
        put_line ' '//output_line(11) $fname(out_name)
        put_line ' '//output_line(12) $fname(out_name)
        IF NOT unrecovered_70_code THEN
          put_line ' '//output_line(13) $fname(out_name)
        IFEND
      IFEND
      put_line ' '//output_line(9) $fname(out_name)
      put_line ' '//output_line(10) $fname(out_name)
    IFEND
    line = ''
    accept_line line $fname(out_file_4//'.$asis') ..
          line_count=lines_read "try next line"

  WHILEND

  IF statistic_counter = 0 THEN
    put_line '  THERE ARE NO ISMT TAPE ERRORS IN THE DESIGNATED LOG ' ..
          output=$fname(out_name)
  ELSE
    put_line '  END OF ISMT TAPE ERRORS  ' output=$fname(out_name)
  IFEND

  IF time_study THEN
    put_line ' ' output=$fname(out_name)
    put_line '  THE NUMBER OF STATISTICS IS  '//$strrep(statistic_counter) ..
          output=$fname(out_name)
    display_job_data display_format=incremental output=$fname(out_name)
  IFEND

  detach_file $fname(out_file_2)
  detach_file $fname(out_file_4)

PROCEND display_hpa_tape_detail
*DECK DECK=RAM$DISPLAY_INSTALLED_SOFTWARE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: DISPLAY_INSTALLED_SOFTWARE Subcommand.' ??
MODULE ram$display_installed_software;

{ PURPOSE:
{   This module contains the interface that displays information about
{   the currently active and/or deferred software.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc pmt$condition
*copyc rac$idb_directory_name
*copyc rac$not_installed
*copyc rac$packing_list_level
*copyc rae$install_software_cc
*copyc rat$idb_directory_types
?? POP ??
*copyc amp$get_segment_pointer
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_real
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$convert_real_to_string
*copyc clp$evaluate_parameters
*copyc clp$get_path_name
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$right_justify_string
*copyc clp$trimmed_string_size
*copyc clv$display_variables
*copyc clv$nil_display_control
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_message
*copyc osp$set_status_abnormal
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc rap$access_directory_for_read
*copyc rav$installation_defaults

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  { The following TYPE is used to contain the list of products specified
  { on the PRODUCT parameter of the DISPLAY_INSTALLED_SOFTWARE subcommand.
  { It is used during processing to allow the display of directory information
  { for the specified product(s).
  {
  { The record contains two fields.  The name field contains the product
  { name as specified by the user.  This name can either be a subproduct
  { or licensed product name.  Group names are not supported.  The boolean
  { is used during processing to indicate whether the product specified is
  { known to the directory, either as a subproduct or licensed product.

  TYPE
    rat#product_processing_type = record
      product_name: ost$name,
      known_to_directory: boolean,
    recend;

?? TITLE := '[XDCL] rap$display_installed_software', EJECT ??

{ PURPOSE:
{   This interface displays information about the currently active
{   and/or deferred products and subproducts using information in
{   the installation database directory.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$display_installed_software
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE disis_pdt (
{   product, products, p: any of
{       key
{         all
{       keyend
{       list of name
{     anyend = $optional
{   display_option, do: key
{       (brief, b)
{       (full, f)
{     keyend = brief
{   output, o: file = $output
{   display_hidden_values, dhv: (BY_NAME, HIDDEN) boolean = false
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 17, 14, 3, 37, 915],
    clc$command, 10, 5, 0, 0, 1, 0, 5, ''], [
    ['DHV                            ',clc$abbreviation_entry, 4],
    ['DISPLAY_HIDDEN_VALUES          ',clc$nominal_entry, 4],
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['P                              ',clc$abbreviation_entry, 1],
    ['PRODUCT                        ',clc$nominal_entry, 1],
    ['PRODUCTS                       ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [2, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ 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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [4], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['BRIEF                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['FULL                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'brief'],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$product = 1,
      p$display_option = 2,
      p$output = 3,
      p$display_hidden_values = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;



    VAR
      default_ring_attributes: amt$ring_attributes,
      directory_pointers: rat$idb_directory_pointers,
      display_control: clt$display_control,
      display_opened: boolean,
      display_status: ost$status,
      length: integer,
      local_status: ost$status,
      idb_fid: amt$file_identifier,
      idb_opened: boolean;

?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

{ Add subtitles here, if needed. }

    PROCEND put_subtitle;
?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the files have been opened, they will be closed before the
{   the procedure returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

      IF idb_opened THEN
        fsp$close_file (idb_fid, ignore_status)
      IFEND

    PROCEND abort_handler;
*copyc clp$new_page_procedure
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    display_opened := FALSE;
    idb_opened := FALSE;
    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    clv$titles_built := FALSE;
    clv$command_name := 'display_installed_software';

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);

    osp$establish_block_exit_hndlr (^abort_handler);

    display_opened := TRUE;
    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          default_ring_attributes, display_control, status);
    IF NOT status.normal THEN
      display_opened := FALSE;
      RETURN;
    IFEND;

  /main/
    BEGIN

      rap$access_directory_for_read (rav$installation_defaults.installation_database, directory_pointers,
            idb_fid, idb_opened, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      display_idb_information (directory_pointers.directory_p, pvt [p$product].value,
            pvt [p$display_option].value^.name_value, pvt [p$display_hidden_values].
            value^.boolean_value.value, display_control, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;


    END /main/;

    IF display_opened THEN
      clp$close_display (display_control, display_status);
    IFEND;

    IF idb_opened THEN
      fsp$close_file (idb_fid, local_status);
    IFEND;

    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    ELSEIF status.normal AND (NOT display_status.normal) THEN
      status := display_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$display_installed_software;
?? TITLE := 'analyze_product_list', EJECT ??

{ PURPOSE:
{   This procedure analyzes the optional product list and returns
{   a boolean indicating whether or not the keyword  ALL was
{   specified, or a list of products was specified.  Also returned
{   is a processing array of records containing information about
{   each product specified on the product parameter.
{
{ DESIGN:
{   If the keyword ALL is specified, or the name ALL is used along with
{   a list of product names, the return boolean parameter is set FALSE to
{   indicate that ALL was specified.  A TRUE value signifies that a list
{   of products was specified.
{
{ NOTES:
{   If the user specified a list of names, including the keyword ALL, this
{   procedure returns an abnormal status and sets the boolean to FALSE.
{
{   The test for whether or not the product parameter was specified was done
{   in the calling procedure.
{
{   For ease of coding and in order to incorporate an additional field for
{   each product specified, the product list specified by the user is transferred
{   into an array.  This array is used later in processing instead of the input
{   list because of the need to indicate whether or not a given product is
{   known to the directory.  This knowledge is stored in the array.
{

  PROCEDURE analyze_product_list
    (    product_input_p: ^clt$data_value;
     VAR product_processing_p: ^array [ * ] of rat#product_processing_type;
     VAR user_specified_product_list: boolean;
     VAR status: ost$status);


    VAR
      current_p: ^clt$data_value,
      i: rat$subproduct_count,
      subproduct_in_directory: boolean;


    user_specified_product_list := TRUE;

    { Process the product list based on whether its the keyword ALL or a list of names.

    IF product_input_p^.kind = clc$keyword THEN

      user_specified_product_list := FALSE;

    ELSE {list of names specified}

      current_p := product_input_p;
      i := 0;
      WHILE current_p <> NIL DO

        { Test that key ALL is not specified along with product names.

        IF current_p^.element_value^.name_value = 'ALL' THEN
          osp$set_status_abnormal ('RA', rae$specified_names_and_key_all, '', status);
          user_specified_product_list := FALSE;
          RETURN;
        IFEND;

        { Transfer list of names to array of names to be returned.

        i := i + 1;
        product_processing_p^ [i].product_name := current_p^.element_value^.name_value;
        product_processing_p^ [i].known_to_directory := FALSE;
        current_p := current_p^.link;

      WHILEND;

    IFEND;

  PROCEND analyze_product_list;
?? TITLE := 'display_information_record', EJECT ??

{ PURPOSE:
{   This procedure displays information about the subproducts
{   that have been installed on a mainframe.
{
{ DESIGN:
{   Information from the installation data base is displayed.
{
{ NOTES:
{
{

  PROCEDURE display_information_record
    (    information_record: rat$information_record;
         display_option: ost$name;
         display_hidden_values: boolean;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      date: ost$date,
      display_status: ost$status,
      time: ost$time;


    status.normal := TRUE;
    display_status.normal := TRUE;

    write_strings ('    Level:                    ', information_record.subproduct_level, FALSE,
          display_control, display_status);

    IF (display_hidden_values) AND (information_record.internal_level <> osc$null_name) THEN
      write_strings ('    Internal Level:           ', information_record.internal_level, FALSE,
            display_control, display_status);
    IFEND;

    pmp$format_compact_date (information_record.date_installed, osc$iso_date, date, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$format_compact_time (information_record.date_installed, osc$hms_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    write_strings ('    Install Date/Time:        ', date.iso, TRUE, display_control, display_status);
    write_strings (' ', time.hms, FALSE, display_control, display_status);

    IF (display_option = 'FULL') THEN

      write_strings ('    Packing List:             ', information_record.packing_list, FALSE,
            display_control, display_status);
      write_strings ('    Installation Id:          ', information_record.installation_identifier, FALSE,
            display_control, display_status);

    IFEND;

    IF display_hidden_values THEN
      write_strings ('    SIF Identifier:           ', information_record.sif_identifier, FALSE,
            display_control, display_status);
    IFEND;

    IF status.normal AND (NOT display_status.normal) THEN
      status := display_status;
    IFEND;

  PROCEND display_information_record;

?? TITLE := 'display_idb_information', EJECT ??

{ PURPOSE:
{   This procedure displays information about the subproducts
{   that have been installed on a mainframe.
{
{ DESIGN:
{   Information from the installation data base is displayed.  If the product
{   parameter was specified on the call, information about only the specified
{   list of subproducts and/or licensed products will be displayed.
{
{ NOTES:
{   This code assumes that if the active directory indicates not installed
{   that the subproduct (deferred and correction base) are not installed and
{   thus issues a message to that effect.  This will have to be dealt with
{   in BCU processing.

  PROCEDURE display_idb_information
    (    directory_p: ^rat$directory;
         product_input_p: ^clt$data_value;
         display_option: ost$name;
         display_hidden_values: boolean;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

?? TITLE := 'size_of_list_parameter', EJECT ??

    FUNCTION size_of_list_parameter
      (    product_input_p: ^clt$data_value): rat$subproduct_count;

      VAR
        current_p: ^clt$data_value,
        size: rat$subproduct_count;

      { This fuction determines the number of elements in a list parameter.
      { Since a list parameter can also assume another type (eg. keyword), it
      { is important to check that the type is list before proceeding.  If the
      { parameter is a not a list type, return with a zero value.

      size := 0;

      IF product_input_p^.kind <> clc$list THEN
        size_of_list_parameter := 0;
        RETURN;
      IFEND;

      current_p := product_input_p;
      WHILE current_p <> NIL DO
        size := size + 1;
        current_p := current_p^.link;
      WHILEND;

      size_of_list_parameter := size;

    FUNCEND size_of_list_parameter;

?? OLDTITLE, EJECT ??


    VAR
      bottom_margin: amt$page_length,
      display_status: ost$status,
      i: rat$subproduct_count,
      ignore_status: ost$status,
      last_licensed_product: rat$licensed_product,
      local_status: ost$status,
      product_in_user_list: boolean,
      product_processing_p: ^array [ * ] of rat#product_processing_type,
      subproducts_displayed: boolean,
      user_specified_product_list: boolean;

    status.normal := TRUE;
    bottom_margin := 9;

    display_status.normal := TRUE;
    last_licensed_product := '';
    subproducts_displayed:= FALSE;

    {  If the product parameter was specified, create memory for product processing
    {  array, and search the optional product list for the keyword ALL or ALL specified
    {  as a name.  If ALL is specified, return FALSE in user_specified_product_list,
    {  else, return a TRUE indicating that a specified list of names should
    {  be displayed by this procedure.  Also, return an array of product names
    {  specified by user on the product parameter.

    IF product_input_p <> NIL THEN
      PUSH product_processing_p: [1 .. size_of_list_parameter (product_input_p)];
      analyze_product_list (product_input_p, product_processing_p, user_specified_product_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      user_specified_product_list := FALSE;
    IFEND;

  /display/
    FOR i := 1 TO UPPERBOUND (directory_p^) DO

      IF user_specified_product_list THEN

        { Find and display those products specified by user in product parameter.

        find_product_in_user_list (directory_p^ [i], product_processing_p, product_in_user_list, status);
        IF NOT product_in_user_list THEN
          CYCLE /display/; { Current directory subproduct not in user product list. }
        IFEND;

      IFEND;

      { If processing drops through to here, it means that either all subproducts are
      { are being processed, or that a subproduct in the list was found in the directory
      { and will now be displayed.

      subproducts_displayed := TRUE;

      IF display_control.line_number > display_control.page_length - bottom_margin THEN
        display_control.line_number := display_control.page_length;
      IFEND;

      IF directory_p^ [i].licensed_product <> last_licensed_product THEN

        last_licensed_product := directory_p^ [i].licensed_product;
        write_strings ('', '', FALSE, display_control, display_status);
        write_strings ('Licensed Product ', directory_p^ [i].
              licensed_product (1, clp$trimmed_string_size (directory_p^ [i].licensed_product)),
              TRUE, display_control, display_status);
        write_strings (':', '', FALSE, display_control, display_status);

      IFEND;

      write_strings ('', '', FALSE, display_control, display_status);

      write_strings ('  Subproduct ', directory_p^ [i].subproduct
            (1, clp$trimmed_string_size (directory_p^ [i].subproduct)), TRUE, display_control,
            display_status);
      write_strings (' Information:', '', FALSE, display_control, display_status);
      write_strings ('', '', FALSE, display_control, display_status);

      IF (display_option = 'FULL') THEN
        write_strings ('    Description: ', directory_p^ [i].description, FALSE, display_control,
              display_status);
        write_strings ('', '', FALSE, display_control, display_status);
      IFEND;

      IF directory_p^ [i].subproduct_corrupted = TRUE THEN
        write_strings ('    *** ACTIVE LEVEL WAS CORRUPTED BY A FAILED INSTALLATION ATTEMPT.', '',
              FALSE, display_control, display_status);
        write_strings ('    *** SEE LOGS FROM INSTALLATION IDENTIFIER ',
              directory_p^ [i].active_information.installation_identifier (1,
              clp$trimmed_string_size (directory_p^ [i].active_information.installation_identifier)),
              TRUE, display_control, display_status);
        write_strings ('.', '', FALSE, display_control, display_status);
      IFEND;

      IF directory_p^ [i].active_information.installation_identifier <> rac$not_installed THEN
        write_strings ('    Type:                     ACTIVE', '', FALSE, display_control, display_status);
        display_information_record (directory_p^ [i].active_information, display_option,
              display_hidden_values, display_control, status);
      ELSE
        write_strings ('    {Currently not installed}', '', FALSE, display_control, display_status);
      IFEND;
      IF directory_p^ [i].deferred_information.installation_identifier <> rac$not_installed THEN
        write_strings ('    Type:                     DEFERRED', '', FALSE, display_control, display_status);
        display_information_record (directory_p^ [i].deferred_information, display_option,
              display_hidden_values, display_control, status);
      IFEND;

      { Only show corrective base information if it is 1) present and 2) different from the active level.

      IF (directory_p^ [i].corrective_base_information.installation_identifier <> rac$not_installed) AND
            (directory_p^ [i].corrective_base_information.subproduct_level <>
            directory_p^ [i].active_information.subproduct_level) THEN
        write_strings ('    Type:                     CORRECTION BASE', '', FALSE, display_control,
              display_status);
        display_information_record (directory_p^ [i].corrective_base_information, display_option,
              display_hidden_values, display_control, status);
      IFEND;

    FOREND /display/;

    IF user_specified_product_list THEN

      write_strings ('', '', FALSE, display_control, display_status);

      IF NOT subproducts_displayed THEN
        osp$set_status_abnormal ('RA', rae$no_products_found, '', local_status);
        osp$generate_message (local_status, ignore_status);

      ELSE { one or more subproducts were displayed. }

        { If the user specified the product list parameter, display an error message for any
        { product that was not known to the directory, and therefore was not displayed.

        FOR i := 1 to UPPERBOUND (product_processing_p^) DO
          IF NOT product_processing_p^ [i].known_to_directory THEN
            osp$set_status_abnormal ('RA', rae$product_not_in_directory,
                 product_processing_p^ [i].product_name, local_status);
            osp$generate_message (local_status, ignore_status);
          IFEND;
        FOREND;

      IFEND;

    IFEND;

    IF status.normal AND (NOT display_status.normal) THEN
      status := display_status;
    IFEND;

  PROCEND display_idb_information;
?? TITLE := 'find_product_in_user_list', EJECT ??

{ PURPOSE:
{   This procedure returns a boolean value indicating whether a
{   subproduct is present in the product list specified by the user.
{   A flag is set in the product processing array indicating that
{   the product is known to the directory.
{
{ DESIGN:
{   A linear search is performed on the list of product names specified
{   by the user for either the licensed product or subproduct name from
{   the directory record.
{
{ NOTES:
{   Since the product list is expected to be very small (ie. < 25 products),
{   a linear search is performed.
{
{   The search to determine if a product is known to the directory is done
{   only on the subproduct and licensed product names.  The group name is
{   not supported, since group information is not stored in the directory.
{

  PROCEDURE find_product_in_user_list
    (    directory_record: rat$directory_record;
     VAR product_processing_p: ^array [ * ] of rat#product_processing_type;
     VAR product_in_user_list: boolean;
     VAR status: ost$status);

    VAR
      i: rat$subproduct_count;

    product_in_user_list := FALSE;
    FOR i := 1 to UPPERBOUND (product_processing_p^) DO

      IF (product_processing_p^ [i].product_name = directory_record.subproduct) OR
         (product_processing_p^ [i].product_name = directory_record.licensed_product) THEN
        product_in_user_list := TRUE;
        product_processing_p^ [i].known_to_directory := TRUE;
        RETURN;
      IFEND;

    FOREND;

PROCEND find_product_in_user_list;
?? TITLE := 'write_string_and_integer', EJECT ??

{ PURPOSE:
{   This procedure writes a string and a integer to the output display.
{
{ DESIGN:
{   The string and the integer are combined into one string and a procedure
{   writes them to output.
{
{ NOTES:
{
{

  PROCEDURE write_string_and_integer
    (    string_a: string ( * );
         integer_a: integer;
         continue_line: boolean;
     VAR display_control: clt$display_control;
     VAR display_status: ost$status);

    VAR
      ignore_status: ost$status,
      line_a: string (2 * fsc$max_path_size),
      line_b: string (2 * fsc$max_path_size),
      line_size_a: integer,
      line_size_b: integer;

    IF NOT display_status.normal THEN
      RETURN;
    IFEND;

    line_a := '';
    STRINGREP (line_a, line_size_a, integer_a);

    line_b := '';
    STRINGREP (line_b, line_size_b, string_a, line_a (2, line_size_a - 1));

    IF continue_line THEN
      clp$put_partial_display (display_control, line_b (1, line_size_b), clc$no_trim, amc$continue,
            ignore_status);
    ELSE
      clp$put_partial_display (display_control, line_b (1, line_size_b), clc$no_trim, amc$terminate,
            ignore_status);
    IFEND;

  PROCEND write_string_and_integer;
?? TITLE := 'write_strings', EJECT ??

{ PURPOSE:
{   This procedure writes two strings to the output display.
{
{ DESIGN:
{   The two strings are combined into one string and a procedure
{   writes them to output.
{
{ NOTES:
{
{

  PROCEDURE write_strings
    (    string_a: string ( * );
         string_b: string ( * );
         continue_line: boolean;
     VAR display_control: clt$display_control;
     VAR display_status: ost$status);


    VAR
      ignore_status: ost$status,
      line: string (osc$max_string_size),
      line_size: integer;


    IF NOT display_status.normal THEN
      RETURN;
    IFEND;

    line := '';
    STRINGREP (line, line_size, string_a, string_b);

    IF continue_line THEN
      clp$put_partial_display (display_control, line (1, line_size), clc$no_trim, amc$continue,
            ignore_status);
    ELSE
      clp$put_partial_display (display_control, line (1, line_size), clc$no_trim, amc$terminate,
            ignore_status);
    IFEND;

  PROCEND write_strings;

MODEND ram$display_installed_software;
*DECK DECK=RAM$DISPLAY_JOB_LOG_TO_CMD_LOG EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$DISPLAY_JOB_LOG_TO_CMD_LOG Interface.' ??
MODULE ram$display_job_log_to_cmd_log;

{ PURPOSE:
{   This module contains the interface that displays the job log to the
{   installation command log.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$command_log_name
*copyc rat$installation_identifier
*copyc rat$path
?? POP ??
*copyc clp$include_line
*copyc clp$trimmed_string_size
*copyc rap$set_file_retention
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$display_job_log_to_cmd_log', EJECT ??

{ PURPOSE:
{   This interface creates a permanent copy of the job log by displaying the
{   job log to the command log associated with an installation event.
{
{ DESIGN:
{   This interface takes the installation logs path and installation
{   identifier passed in to determine the path to the command log.  When the
{   installation identifier has been defined it is assumed that the
{   installation identifier catalog that will contain the command log has
{   been created.  Otherwise, the interface returns without any further
{   processing.
{
{   The job log is displayed into the command log file using an SCL command.
{   Therefore a command line is built and included.
{
{   A retention period of 7 days is placed on the log file.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$display_job_log_to_cmd_log
    (    installation_logs: rat$path;
         installation_identifier: rat$installation_identifier;
     VAR status: ost$status);


    CONST
      retention_period = 7;

    VAR
      command_line: string (osc$max_string_size),
      command_line_length: integer,
      log_file: rat$path;


    status.normal := TRUE;

    IF installation_identifier = osc$null_name THEN
      RETURN;
    IFEND;

    { Assemble the path to the command log file under the installation identifier catalog.

    STRINGREP (log_file.path, log_file.size, installation_logs.path (1, installation_logs.size), '.',
          installation_identifier (1, clp$trimmed_string_size (installation_identifier)), '.',
          rac$command_log_name);

    { Build the SCL command line and perform the command.

    STRINGREP (command_line, command_line_length, '$system.display_log do=last o=', log_file.
          path (1, log_file.size));

    clp$include_line (command_line (1, command_line_length), TRUE, osc$null_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Set retention date on the log file just created.

    rap$set_file_retention (log_file.path (1, log_file.size), retention_period, status);

  PROCEND rap$display_job_log_to_cmd_log;
MODEND ram$display_job_log_to_cmd_log;
*DECK DECK=RAM$DISPLAY_OBJECT_LIBRARY EXPAND=TRUE
create_program_description name=(display_object_library, disol) ..
      sp=ocp$_display_object_library l=('$system.ocu.bound_product' osf$task_services_library) tel=warning ..
      lmo=none lm=$null dm=off
*DECK DECK=RAM$DISPLAY_OBJECT_TEXT EXPAND=TRUE
create_program_description name=(display_object_text, disot) sp=ocp$list_object_file ..
      l=('$system.ocu.bound_product', osf$task_services_library) tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$DISPLAY_OSI_ADDRESS EXPAND=TRUE

create_program_description (DISPLAY_OSI_ADDRESS, DISPLAY_OSI_ADDRESSES, DISOSIA) l='$system.osf$system_library'..
      sp=nap$display_osi_address lm=$null lmo=none tel=warning dm=off
*DECK DECK=RAM$DISPLAY_PACKING_LIST EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: DISPLAY_PACKING_LIST Interface.' ??
MODULE ram$display_packing_list;

{ PURPOSE:
{   This module contains the procedures that display the contents of
{   a packing list.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$condition
*copyc rac$max_line
*copyc rac$packing_list_level
*copyc rac$special_product_designators
*copyc rae$install_software_cc
*copyc rat$subproduct_info_pointers
*copyc rat$sequence_descriptor_types
*copyc rat$subproduct_info_p
*copyc rat$subproduct_info_types
?? POP ??
*copyc amp$get_segment_pointer
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_real
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$convert_real_to_string
*copyc clp$get_path_name
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc clp$right_justify_string
*copyc clp$trimmed_string_size
*copyc clv$display_variables
*copyc clv$nil_display_control
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc rap$display_psrs_answered
*copyc rap$write_strings
*copyc rav$installation_path_option
*copyc rav$order_medium
*copyc rav$subproduct_type

  TYPE
    group_sort_list_p = ^array [ * ] of group_sort_record;

  TYPE
    group_sort_record = record
      case 1 .. 2 of
      = 1 =
        group: ost$name,
        subproduct_name: rat$subproduct_name,
      = 2 =
        sort_data: string (2 * osc$max_name_size)
      casend,
    recend;

  TYPE
    subproduct_sort_list_p = ^array [ * ] of subproduct_sort_record;

  TYPE
    subproduct_sort_record = record
      path_container_p: ^rat$path_container,
      psrs_answered_p: ^rat$psrs_answered,
      licensed_product_size: rat$subproduct_size,
      attributes_p: ^rat$subproduct_attributes,
      case 1 .. 2 of
      = 1 =
        licensed_product: rat$licensed_product,
        name: rat$subproduct_name,
      = 2 =
        sort_data: string (2 * osc$max_name_size)
      casend,
    recend;


?? TITLE := '[XDCL] rap$display_packing_list', EJECT ??

{ PURPOSE:
{   This procedure displays information about the contents of a
{   packing list file.
{
{ DESIGN:
{   A packing list file is opened and information from the SIFs in the
{   packing list are displayed to the output file.
{
{ NOTES:

  PROCEDURE [XDCL] rap$display_packing_list
    (    packing_list_path_p: ^fst$file_reference;
         subtitle_p: ^string(*);
         idb_title_path_p: ^fst$file_reference;
         display_option: ost$name;
         output_file_path_p: ^fst$file_reference;
     VAR status: ost$status);

    VAR
      default_ring_attributes: amt$ring_attributes,
      display_control: clt$display_control,
      display_opened: boolean,
      display_status: ost$status,
      local_status: ost$status,
      packing_list_fid: amt$file_identifier,
      packing_list_opened: boolean,
      packing_list_seq_p: ^rat$packing_list_sequence;

?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

      rap$write_strings ('Contents of packing list: ', subtitle_p^, FALSE, 0,
            display_control, display_status);

    PROCEND put_subtitle;
?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the files have been opened, they will be closed before the
{   the procedure returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

      IF packing_list_opened THEN
        fsp$close_file (packing_list_fid, ignore_status)
      IFEND

    PROCEND abort_handler;
*copyc clp$new_page_procedure
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    display_status.normal := TRUE;
    display_opened := FALSE;
    packing_list_opened := FALSE;
    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    clv$titles_built := FALSE;
    clv$command_name := 'display_packing_list';

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);

    osp$establish_block_exit_hndlr (^abort_handler);

    display_opened := TRUE;
    clp$open_display_reference (output_file_path_p^, ^clp$new_page_procedure, fsc$list,
          default_ring_attributes, display_control, status);
    IF NOT status.normal THEN
      display_opened := FALSE;
      RETURN;
    IFEND;

  /main/
    BEGIN

      open_packing_list (packing_list_path_p^, packing_list_seq_p, packing_list_opened,
            packing_list_fid, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;


      display_header (idb_title_path_p, packing_list_seq_p, display_control, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      display_product_information (display_option, packing_list_seq_p,
            display_control, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

    END /main/;

    IF display_opened THEN
      clp$close_display (display_control, display_status);
    IFEND;

    IF packing_list_opened THEN
      fsp$close_file (packing_list_fid, local_status);
    IFEND;

    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    ELSEIF status.normal AND (NOT display_status.normal) THEN
      status := display_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$display_packing_list;

?? TITLE := 'calculate_licensed_product_size', EJECT ??

{ PURPOSE:
{   This procedure calculates the size of each of the licensed
{   products.
{
{ DESIGN:
{   The size of all subproducts under a licensed product are added
{   to calculate the size of the licensed_product.
{
{ NOTES:
{   Subproducts that are of type CORRECTION are not included in the total.
{   Subproducts that are AUTO_INSTALL = FALSE are not included in the total.
{

  PROCEDURE calculate_licensed_product_size
    (    subproduct_list_p: subproduct_sort_list_p);


    VAR
      i: rat$subproduct_count,
      last_licensed_product: rat$licensed_product,
      last_subproduct_index: rat$subproduct_count,
      licensed_product_size: rat$subproduct_size;


    last_licensed_product := '';
    last_subproduct_index := 0;
    licensed_product_size := 0;

    FOR i := 1 TO UPPERBOUND (subproduct_list_p^) DO

      IF subproduct_list_p^ [i].licensed_product <> last_licensed_product THEN

        IF last_subproduct_index <> 0 THEN
          subproduct_list_p^ [last_subproduct_index].licensed_product_size := licensed_product_size;
          licensed_product_size := 0;
        IFEND;

        IF (subproduct_list_p^ [i].attributes_p^.auto_install) AND
              (subproduct_list_p^ [i].attributes_p^.subproduct_type <> rac$correction) THEN
          licensed_product_size := subproduct_list_p^ [i].attributes_p^.size;
        IFEND;

        last_licensed_product := subproduct_list_p^ [i].licensed_product;
        last_subproduct_index := i;

      ELSE

        IF (subproduct_list_p^ [i].attributes_p^.auto_install) AND
              (NOT subproduct_list_p^ [i].attributes_p^.hidden) THEN
          licensed_product_size := licensed_product_size + subproduct_list_p^ [i].attributes_p^.size;
        IFEND;

      IFEND;

    FOREND;

    subproduct_list_p^ [last_subproduct_index].licensed_product_size := licensed_product_size;

  PROCEND calculate_licensed_product_size;

?? TITLE := 'convert_bytes_to_megabytes', EJECT ??

{ PURPOSE:
{   This procedure converts the size of a subproduct from bytes
{   to megabytes and returns the value in a string for display
{   purposes.
{
{ DESIGN:
{   The bytes are converted to megabytes by dividing the bytes by
{   one million.  Then the megabytes are put into a string.
{
{ NOTES:
{
{

  PROCEDURE convert_bytes_to_megabytes
    (    bytes: rat$subproduct_size;
     VAR mbytes_string: string (osc$max_string_size);
     VAR mbytes_length: integer);


    VAR
      decimal_places: integer,
      largest_decimal_place: integer,
      length: integer,
      real_subproduct_size: real,
      temp_string: string (osc$max_string_size);

    decimal_places := 2;
    largest_decimal_place := 6;
    mbytes_string := '';

    real_subproduct_size := $REAL (bytes) / 1000000.0;

    STRINGREP (temp_string, length, real_subproduct_size);
    STRINGREP (mbytes_string, mbytes_length, real_subproduct_size: length: decimal_places);
    mbytes_string (1, largest_decimal_place) := mbytes_string (mbytes_length - largest_decimal_place + 1, * );
    mbytes_length := largest_decimal_place;

  PROCEND convert_bytes_to_megabytes;
?? TITLE := 'display_groups', EJECT ??

{ PURPOSE:
{   This procedure displays information that is stored in
{   the packing list sequence descriptor and packing list header.
{
{ DESIGN:
{   Information from the attributes record of the subproduct information
{   file is sorted and displayed to the display file.
{   The first array is large enough to hold all of the entries.
{   The second array is created for the sort.  It only contains the entries
{   that have a # sign as their first character.  The second array is created
{   for the sort.  Otherwise all of the blank entries would come first in the
{   sort.
{
{ NOTES:
{
{

  PROCEDURE display_groups
    (    subproduct_list_p: subproduct_sort_list_p;
     VAR display_control: clt$display_control;
     VAR status: ost$status);



    VAR
      display_status: ost$status,
      first_subproduct_in_group: boolean,
      group_index: 0 .. (rac$max_additional_products * rac$max_number_of_subproducts),
      group_p: group_sort_list_p,
      i: rat$subproduct_count,
      index: 0 .. (rac$max_additional_products * rac$max_number_of_subproducts),
      j: 0 .. (rac$max_additional_products * rac$max_number_of_subproducts),
      limited_group_p: group_sort_list_p,
      last_group: ost$name,
      subproduct_count: rat$subproduct_count;

    status.normal := TRUE;
    display_status.normal := TRUE;
    last_group := '';
    subproduct_count := UPPERBOUND (subproduct_list_p^);

    PUSH group_p: [1 .. rac$max_additional_products * subproduct_count];
    index := 0;
    group_index := 0;

    FOR i := 1 TO subproduct_count DO

      FOR j := 1 TO rac$max_additional_products DO

        index := index + 1;
        group_p^ [index].group := '';
        group_p^ [index].subproduct_name := '';

        IF subproduct_list_p^ [i].attributes_p^.additional_products [j] (1, 1) = rac$group_designator THEN
          group_index := group_index + 1;
          group_p^ [group_index].group := subproduct_list_p^ [i].attributes_p^.additional_products [j];
          group_p^ [group_index].subproduct_name := subproduct_list_p^ [i].name;
        IFEND;

      FOREND;

    FOREND;

    IF group_index > 0 THEN

      PUSH limited_group_p: [1 .. group_index];
      FOR j := 1 TO group_index DO
        limited_group_p^ [j] := group_p^ [j];
      FOREND;

      sort_groups (limited_group_p);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      FOR j := 1 TO group_index DO

        IF last_group <> limited_group_p^ [j].group THEN

          IF display_control.line_number > display_control.page_length - 4 THEN
            display_control.line_number := display_control.page_length;
          IFEND;

          IF j <> 1 THEN
            rap$write_strings (')', '', FALSE, 0, display_control, display_status);
          IFEND;

          rap$write_strings ('', '', FALSE, 0, display_control, display_status);
          rap$write_strings ('Group Name: ',
                limited_group_p^ [j].group(2,clp$trimmed_string_size(limited_group_p^[j].group)-1),
                FALSE, 0, display_control, display_status);
          rap$write_strings ('Member Subproducts: (', '', TRUE, 0, display_control, display_status);
          first_subproduct_in_group := TRUE;
          last_group := limited_group_p^ [j].group;

        IFEND;

        IF first_subproduct_in_group THEN
          rap$write_strings ('', limited_group_p^ [j].subproduct_name
                (1, clp$trimmed_string_size (limited_group_p^ [j].subproduct_name)), TRUE, 0,
                display_control, display_status);
          first_subproduct_in_group := FALSE;
        ELSE
          rap$write_strings (' ', limited_group_p^ [j].subproduct_name
                (1, clp$trimmed_string_size (limited_group_p^ [j].subproduct_name)), TRUE, 0, display_control,
                display_status);
        IFEND;

      FOREND;

      rap$write_strings (')', '', FALSE, 0, display_control, display_status);

    IFEND;

    IF status.normal AND (NOT display_status.normal) THEN
      status := display_status;
    IFEND;

  PROCEND display_groups;
?? TITLE := 'display_header', EJECT ??

{ PURPOSE:
{   This procedure displays the groups and the subproducts in
{   each group.
{
{ DESIGN:
{   Information from the packing list sequence descriptor
{   and packing list sequence header are displayed to the output file.
{
{ NOTES:
{
{

  PROCEDURE display_header
   (     idb_title_path_p: ^fst$file_reference;
     VAR packing_list_seq_p: ^rat$packing_list_sequence;
     VAR display_control: clt$display_control;
     VAR status: ost$status);


    VAR
      additional_tape_vsn_p: ^rat$tape_vsn,
      additional_volume_p: rat$additional_volume_p,
      date: ost$date,
      display_status: ost$status,
      i: rat$tape_count,
      packing_list_header_p: ^rat$packing_list_header,
      sequence_descriptor_p: ^rat$sequence_descriptor,
      tape_list_p: ^rat$tape_vsns,
      time: ost$time;

    status.normal := TRUE;
    display_status.normal := TRUE;

    RESET packing_list_seq_p;
    NEXT sequence_descriptor_p IN packing_list_seq_p;
    NEXT packing_list_header_p IN packing_list_seq_p;

    IF idb_title_path_p <> NIL THEN
      rap$write_strings ('IDB Catalog:       ', idb_title_path_p^ , FALSE, 20, display_control,
            display_status);
    IFEND;
    rap$write_strings ('Order Identifier:  ', packing_list_header_p^.order_identifier, FALSE, 0,
          display_control, display_status);
    rap$write_strings ('Order Type:        ', rav$subproduct_type [packing_list_header_p^.order_type], FALSE,
          0, display_control, display_status);

    pmp$format_compact_date (sequence_descriptor_p^.sequence_creation_date_time, osc$iso_date, date, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$format_compact_time (sequence_descriptor_p^.sequence_creation_date_time, osc$hms_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$write_strings ('Order Creation:    ', date.iso , TRUE, 0,
          display_control, display_status);
    rap$write_strings (' ', time.hms, FALSE, 0, display_control, display_status);

    rap$write_strings ('Order Medium:      ', rav$order_medium [packing_list_header_p^.order_medium], FALSE,
          0, display_control, display_status);

    IF packing_list_header_p^.order_medium = rac$disk THEN

      rap$write_strings ('File Location:     ', packing_list_header_p^.
            disk_path (1, clp$trimmed_string_size (packing_list_header_p^.disk_path)), FALSE, 0,
            display_control, display_status);

    ELSEIF packing_list_header_p^.order_medium = rac$tape THEN

      tape_list_p := #PTR (packing_list_header_p^.tape_vsns_p, packing_list_seq_p^);
      display_vsns (tape_list_p^, packing_list_seq_p, display_control, status)

    IFEND;

    IF status.normal AND (NOT display_status.normal) THEN
      status := display_status;
    IFEND;

  PROCEND display_header;

?? TITLE := 'display_installation_path', EJECT ??

{ PURPOSE:
{   This procedure displays the installation path options that have
{   been defined and also those that must be defined.
{
{ DESIGN:
{   The installation path option in the attributes record is
{   translated into informative messages for the user.
{
{ NOTES:
{
{


  PROCEDURE display_installation_path
    (    subproduct_record: subproduct_sort_record;
     VAR display_control: clt$display_control;
     VAR status: ost$status);


    VAR
      display_status: ost$status,
      i: rat$path_container_length,
      index: 0 .. osc$max_string_size,
      length: integer,
      installation_path_index: rat$path_container_index,
      installation_path_string: string (osc$max_string_size),
      path_indent: 0 .. rac$max_line,
      path_string: string (osc$max_string_size);

    status.normal := TRUE;
    display_status.normal := TRUE;
    installation_path_string := ':';
    index := 2;
    path_indent := 11;


    installation_path_index := subproduct_record.attributes_p^.installation_path.path_container_index;

    FOR i := 1 TO subproduct_record.attributes_p^.installation_path.path_length DO
      path_string := '';
      STRINGREP (path_string, length, subproduct_record.path_container_p^ [installation_path_index] (1,
            clp$trimmed_string_size (subproduct_record.path_container_p^ [installation_path_index])), '.');
      installation_path_string (index, length) := path_string (1, length);
      installation_path_index := installation_path_index + 1;
      index := index + length;
    FOREND;
    index := index - 2;    {Remove trailing period '.'}

    rap$write_strings ('    Path: ', installation_path_string (1, index), FALSE, path_indent, display_control,
          display_status);

    installation_path_index := subproduct_record.attributes_p^.installation_path.path_container_index;

    IF (subproduct_record.attributes_p^.installation_path_option = rac$definable_master_catalog) OR
          (subproduct_record.attributes_p^.installation_path_option = rac$definable_family_name) THEN

      IF subproduct_record.path_container_p^ [installation_path_index] = '$UNDEFINED' THEN
        rap$write_strings ('    The Family Name MUST be defined prior to installation.', '', FALSE, 0,
              display_control, display_status);
      ELSE
        rap$write_strings ('    The Family Name is site changeable. ', '', FALSE, 0, display_control,
              display_status);
      IFEND;

    IFEND;

    IF (subproduct_record.attributes_p^.installation_path_option = rac$definable_master_catalog) OR
          (subproduct_record.attributes_p^.installation_path_option = rac$definable_user_name) THEN

      IF subproduct_record.path_container_p^ [installation_path_index + 1] = '$UNDEFINED' THEN
        rap$write_strings ('    The User Name MUST be defined prior to installation.', '', FALSE, 0,
              display_control, display_status);
      ELSE
        rap$write_strings ('    The User Name is site changeable. ', '', FALSE, 0, display_control,
              display_status);
      IFEND;

    IFEND;

    IF status.normal AND (NOT display_status.normal) THEN
      status := display_status;
    IFEND;

  PROCEND display_installation_path;

?? TITLE := 'display_product_brief', EJECT ??

{ PURPOSE:
{   This procedure displays information about the subproducts
{   when the display option = BRIEF and the order type is RELEASE.
{
{ DESIGN:
{   Information from the attributes record of the subproduct information
{   file is displayed to the display file.
{
{ NOTES:
{
{

  PROCEDURE display_product_brief
    (    subproduct_list_p: subproduct_sort_list_p;
         order_type: rat$subproduct_type;
         display_option: ost$name;
     VAR display_control: clt$display_control;
     VAR status: ost$status);


    VAR
      display_status: ost$status,
      i: rat$subproduct_count,
      j: rat$subproduct_count,
      last_licensed_product: rat$licensed_product,
      length: integer,
      licensed_product_size: rat$subproduct_size,
      mbytes_length: integer,
      mbytes_string: string (osc$max_string_size),
      primary_index: rat$subproduct_count,
      primary_subproduct: boolean;

    status.normal := TRUE;
    display_status.normal := TRUE;
    last_licensed_product := '';
    mbytes_string := '';


    rap$write_strings ('', '', FALSE, 0, display_control, display_status);

    IF order_type = rac$release THEN
      rap$write_strings ('Licensed Product Name           Level                         Size (Megabytes)', '',
            FALSE, 0, display_control, display_status);
      rap$write_strings ('', '', FALSE, 0, display_control, display_status);
    IFEND;

    FOR i := 1 TO UPPERBOUND (subproduct_list_p^) DO

      IF display_control.line_number > display_control.page_length - 9 THEN
        display_control.line_number := display_control.page_length;
      IFEND;

      IF last_licensed_product <> subproduct_list_p^ [i].licensed_product THEN
        last_licensed_product := subproduct_list_p^ [i].licensed_product;

        find_primary_subproduct (subproduct_list_p, i, primary_index, primary_subproduct);

        IF order_type = rac$release THEN
          rap$write_strings ('', subproduct_list_p^ [i].attributes_p^.licensed_product, TRUE, 0,
                display_control, display_status);

          IF primary_subproduct THEN
            rap$write_strings (' ', subproduct_list_p^ [primary_index].attributes_p^.level, TRUE, 0,
                  display_control, display_status);
          ELSE
            rap$write_strings (' ', '{No level available}           ', TRUE, 0, display_control,
                  display_status);
          IFEND;

{ The size of the licensed product is stored in the first subproduct of that licensed product.}
          convert_bytes_to_megabytes (subproduct_list_p^ [i].licensed_product_size, mbytes_string,
                mbytes_length);
          rap$write_strings (mbytes_string (1, mbytes_length), '', FALSE, 0, display_control, display_status);

        ELSE
          rap$write_strings ('Licensed Product ', subproduct_list_p^ [i].attributes_p^.licensed_product,
                FALSE, 0, display_control, display_status);
        IFEND;

      IFEND;

{Only display the subproduct information if one of these conditions occurs.}
      IF (order_type = rac$correction) OR (NOT subproduct_list_p^ [i].attributes_p^.auto_install) OR
            (subproduct_list_p^ [i].attributes_p^.installation_path_option <> rac$not_definable) OR
            ((subproduct_list_p^ [i].attributes_p^.subproduct_type = rac$correction) AND
            (order_type = rac$release)) THEN

        display_subproduct (subproduct_list_p^ [i], order_type, display_option, display_control,
              display_status);

        IF order_type = rac$release THEN

          IF i < UPPERBOUND (subproduct_list_p^) THEN

          /write_header/
            FOR j := i TO UPPERBOUND (subproduct_list_p^) DO

              IF subproduct_list_p^ [j].licensed_product <> last_licensed_product THEN
                rap$write_strings (
                      'Licensed Product Name          Level                         Size (Megabytes)'
                      , '', FALSE, 0, display_control, display_status);
                rap$write_strings (
                      'Licensed Product Name          Level                         Size (Megabytes)', '',
                        FALSE, 0, display_control, display_status);
                rap$write_strings ('', '', FALSE, 0, display_control, display_status);
              IFEND;

              EXIT /write_header/;

            FOREND /write_header/;

          IFEND;

        IFEND;

      IFEND;

    FOREND;

    IF status.normal AND (NOT display_status.normal) THEN
      status := display_status;
    IFEND;

  PROCEND display_product_brief;

?? TITLE := 'display_product_full', EJECT ??

{ PURPOSE:
{   This procedure displays information about the subproducts
{   when the display option = FULL and the order type is RELEASE.
{
{ DESIGN:
{   Information from the attributes record of the subproduct information
{   file is displayed to the display file.
{
{ NOTES:
{
{

  PROCEDURE display_product_full
    (    subproduct_list_p: subproduct_sort_list_p;
         order_type: rat$subproduct_type;
         display_option: ost$name;
     VAR display_control: clt$display_control;
     VAR status: ost$status);


    VAR
      auto_install: string (osc$max_name_size),
      display_status: ost$status,
      i: rat$subproduct_count,
      indent: string (osc$max_string_size),
      last_licensed_product: rat$licensed_product,
      licensed_product_size: rat$subproduct_size,
      mbytes_length: integer,
      mbytes_string: string (osc$max_string_size),
      primary_index: rat$subproduct_count,
      primary_subproduct: boolean;

    status.normal := TRUE;
    display_status.normal := TRUE;
    indent := '';
    last_licensed_product := '';
    mbytes_string := '';

    FOR i := 1 TO UPPERBOUND (subproduct_list_p^) DO
      IF display_control.line_number > display_control.page_length - 9 THEN
        display_control.line_number := display_control.page_length;
      IFEND;

      IF subproduct_list_p^ [i].licensed_product <> last_licensed_product THEN
        find_primary_subproduct (subproduct_list_p, i, primary_index, primary_subproduct);

        convert_bytes_to_megabytes (subproduct_list_p^ [i].licensed_product_size, mbytes_string,
              mbytes_length);
        last_licensed_product := subproduct_list_p^ [i].licensed_product;
        rap$write_strings ('', '', FALSE, 0, display_control, display_status);
        rap$write_strings ('Licensed Product ', subproduct_list_p^ [i].licensed_product, TRUE, 0,
              display_control, display_status);

        rap$write_strings ('        Size: ', mbytes_string (1, mbytes_length), TRUE, 0, display_control,
              display_status);
        rap$write_strings (' Megabytes', '', FALSE, 0, display_control, display_status);

        IF primary_subproduct THEN
          rap$write_strings ('    Level: ', subproduct_list_p^ [primary_index].attributes_p^.level, FALSE, 0,
                display_control, display_status);
        ELSE
          rap$write_strings ('    Level: ', '{No level available}', FALSE, 0, display_control,
                display_status);
        IFEND;

      IFEND;


      display_subproduct (subproduct_list_p^ [i], order_type, display_option, display_control,
            display_status);

    FOREND;

    IF order_type = rac$release THEN
      display_groups (subproduct_list_p, display_control, status);
      rap$write_strings ('', '', FALSE, 0, display_control, display_status);
    IFEND;

    IF status.normal AND (NOT display_status.normal) THEN
      status := display_status;
    IFEND;

  PROCEND display_product_full;

?? TITLE := 'display_product_information', EJECT ??

{ PURPOSE:
{   This procedure builds the sorted information array and calls
{   another procedure to display the information.
{
{ DESIGN:
{   Specific information from each SIF in the packing list is put
{   into an array and that array is sorted.  Then the information
{   in the array is displayed by another procedure.
{
{ NOTES:
{
{

  PROCEDURE display_product_information
    (    display_option: ost$name;
     VAR packing_list_seq_p: ^rat$packing_list_sequence;
     VAR display_control: clt$display_control;
     VAR status: ost$status);


    VAR
      attributes_p: ^rat$subproduct_attributes,
      disk_subproducts_p: ^rat$disk_subproduct_indexer,
      i: rat$subproduct_count,
      packing_list_header_p: ^rat$packing_list_header,
      seq_p: ^cell,
      sequence_descriptor_p: ^rat$sequence_descriptor,
      sif_info_header_p: ^rat$subproduct_info_header,
      sif_sequence_descriptor_p: ^rat$sequence_descriptor,
      subproduct_count: rat$subproduct_count,
      subproduct_list_p: subproduct_sort_list_p,
      subproduct_seq_p: ^rat$subproduct_info_sequence,
      tape_subproducts_p: ^rat$tape_subproduct_indexer;

    status.normal := TRUE;

    RESET packing_list_seq_p;
    NEXT sequence_descriptor_p IN packing_list_seq_p;
    NEXT packing_list_header_p IN packing_list_seq_p;

    IF packing_list_header_p^.order_medium = rac$disk THEN
      disk_subproducts_p := #PTR (packing_list_header_p^.disk_subproduct_indexer_p, packing_list_seq_p^);
    ELSEIF packing_list_header_p^.order_medium = rac$tape THEN
      tape_subproducts_p := #PTR (packing_list_header_p^.tape_subproduct_indexer_p, packing_list_seq_p^);
    IFEND;

    subproduct_count := packing_list_header_p^.subproduct_count;
    PUSH subproduct_list_p: [1 .. subproduct_count];

    FOR i := 1 TO subproduct_count DO

      IF packing_list_header_p^.order_medium = rac$disk THEN
        seq_p := #PTR (disk_subproducts_p^ [i].subproduct_seq_p, packing_list_seq_p^);
        RESET packing_list_seq_p TO seq_p;
        NEXT subproduct_seq_p: [[REP disk_subproducts_p^ [i].subproduct_seq_length OF cell]] IN
              packing_list_seq_p;
      ELSEIF packing_list_header_p^.order_medium = rac$tape THEN
        seq_p := #PTR (tape_subproducts_p^ [i].subproduct_seq_p, packing_list_seq_p^);
        RESET packing_list_seq_p TO seq_p;
        NEXT subproduct_seq_p: [[REP tape_subproducts_p^ [i].subproduct_seq_length OF cell]] IN
              packing_list_seq_p;
      IFEND;

      RESET subproduct_seq_p;
      NEXT sif_sequence_descriptor_p IN subproduct_seq_p;
      NEXT sif_info_header_p IN subproduct_seq_p;
      attributes_p := #PTR (sif_info_header_p^.attributes_p, subproduct_seq_p^);

{Enter the needed information in the information array.}
      subproduct_list_p^ [i].licensed_product := attributes_p^.licensed_product;
      subproduct_list_p^ [i].name := attributes_p^.name;
      subproduct_list_p^ [i].licensed_product_size := 0;
      subproduct_list_p^ [i].attributes_p := attributes_p;
      subproduct_list_p^ [i].path_container_p := #PTR (sif_info_header_p^.path_container_p,
            subproduct_seq_p^);
      subproduct_list_p^ [i].psrs_answered_p := #PTR (sif_info_header_p^.psrs_answered_p,
            subproduct_seq_p^);

    FOREND;

    sort_subproduct_info (subproduct_list_p);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    calculate_licensed_product_size (subproduct_list_p);

    IF (display_option = 'FULL') OR (display_option = 'F') THEN
      display_product_full (subproduct_list_p, packing_list_header_p^.order_type, display_option,
            display_control, status);
    ELSE
      display_product_brief (subproduct_list_p, packing_list_header_p^.order_type, display_option,
            display_control, status);
    IFEND;

  PROCEND display_product_information;

?? TITLE := 'display_subproduct', EJECT ??

{ PURPOSE:
{   This procedure displays information about a subproduct.
{
{ DESIGN:
{   Information from the attributes record of the subproduct information
{   file is displayed to the display file.
{
{ NOTES:
{
{

  PROCEDURE display_subproduct
    (    subproduct_record: subproduct_sort_record;
         order_type: rat$subproduct_type;
         display_option: ost$name;
     VAR display_control: clt$display_control;
     VAR status: ost$status);


    VAR
      auto_install: string (osc$max_name_size),
      display_status: ost$status,
      i: rat$subproduct_count,
      mbytes_length: integer,
      mbytes_string: string (osc$max_string_size);


    status.normal := TRUE;
    display_status.normal := TRUE;

    rap$write_strings ('', '', FALSE, 0, display_control, display_status);

    rap$write_strings ('  Subproduct ', subproduct_record.name
          (1, clp$trimmed_string_size (subproduct_record.name)), TRUE, 0, display_control, display_status);

    IF order_type = rac$release THEN
      rap$write_strings (' (', rav$subproduct_type [subproduct_record.attributes_p^.subproduct_type]
            (1, clp$trimmed_string_size (rav$subproduct_type [subproduct_record.attributes_p^.
            subproduct_type])), TRUE, 0, display_control, display_status);
      rap$write_strings (') ', '', TRUE, 0, display_control, display_status);
    IFEND;

    IF subproduct_record.attributes_p^.auto_install = TRUE THEN
      auto_install := 'YES'
    ELSE
      auto_install := 'NO'
    IFEND;
    rap$write_strings (' Auto Install: ', auto_install, FALSE, 0, display_control, display_status);

    IF display_option = 'FULL' THEN
      rap$write_strings ('    Description: ', subproduct_record.attributes_p^.description, FALSE, 0,
            display_control, display_status);
    IFEND;

    rap$write_strings ('    Level: ', subproduct_record.attributes_p^.level, TRUE, 0, display_control,
          display_status);

    convert_bytes_to_megabytes (subproduct_record.attributes_p^.size, mbytes_string, mbytes_length);
    rap$write_strings ('              Size: ', mbytes_string (1, mbytes_length), TRUE, 0, display_control,
          display_status);
    rap$write_strings (' Megabytes', '', FALSE, 0, display_control, display_status);

    IF subproduct_record.attributes_p^.subproduct_type = rac$correction THEN
      rap$write_strings ('    Corrects Level: ', subproduct_record.attributes_p^.correction_base_level, FALSE,
            0, display_control, display_status);
    IFEND;

    IF (display_option = 'FULL') OR (subproduct_record.attributes_p^.installation_path_option <>
          rac$not_definable) THEN

      display_installation_path (subproduct_record, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF subproduct_record.attributes_p^.subproduct_type = rac$correction THEN
      rap$display_psrs_answered (subproduct_record.psrs_answered_p, display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF status.normal AND (NOT display_status.normal) THEN
      status := display_status;
    IFEND;

  PROCEND display_subproduct;
?? TITLE := 'display_vsns', EJECT ??

{ PURPOSE:
{   This procedure displays the external vsns and recorded vsns
{   from a packing list.
{
{ DESIGN:
{   Information from the packing list sequence is displayed to the output file.
{
{ NOTES:
{
{

  PROCEDURE display_vsns
    (    tape_list: rat$tape_vsns;
         packing_list_seq_p: ^rat$packing_list_sequence;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      additional_tape_vsn_p: ^rat$tape_vsn,
      additional_volume_p: rat$additional_volume_p,
      display_status: ost$status,
      i: rat$tape_count,
      index: integer,
      length: integer,
      tape_vsn_indent: integer,
      tape_list_p: ^rat$tape_vsns,
      tape_string: string (osc$max_string_size),
      tape_vsn_string: string (osc$max_string_size);

    status.normal := TRUE;
    display_status.normal := TRUE;
    tape_vsn_indent := 19;

    index := 1;
    tape_vsn_string := '';
    FOR i := 1 TO UPPERBOUND (tape_list) DO

      tape_string := '';
      IF i = 1 THEN
        STRINGREP (tape_string, length, '''', tape_list [i].
              external_vsn (1, clp$trimmed_string_size (tape_list [i].external_vsn)), '''');
      ELSE
        STRINGREP (tape_string, length, ', ''', tape_list [i].
              external_vsn (1, clp$trimmed_string_size (tape_list [i].external_vsn)), '''');
      IFEND;
      tape_vsn_string (index, length) := tape_string (1, length);
      index := index + length;

      additional_volume_p := tape_list [i].additional_volume_p;

      WHILE additional_volume_p <> NIL DO

        additional_tape_vsn_p := #PTR (additional_volume_p, packing_list_seq_p^);

        tape_string := '';
        STRINGREP (tape_string, length, ', ''', additional_tape_vsn_p^.
              external_vsn (1, clp$trimmed_string_size (additional_tape_vsn_p^.external_vsn)), '''');
        tape_vsn_string (index, length) := tape_string (1, length);
        index := index + length;

        additional_volume_p := additional_tape_vsn_p^.additional_volume_p;

      WHILEND;
    FOREND;

    rap$write_strings ('External VSNs:     ', tape_vsn_string (1, index), FALSE, tape_vsn_indent,
          display_control, display_status);

    index := 1;
    tape_vsn_string := '';
    FOR i := 1 TO UPPERBOUND (tape_list) DO

      tape_string := '';
      IF i = 1 THEN
        STRINGREP (tape_string, length, '''', tape_list [i].
              recorded_vsn (1, clp$trimmed_string_size (tape_list [i].recorded_vsn)), '''');
      ELSE
        STRINGREP (tape_string, length, ', ''', tape_list [i].
              recorded_vsn (1, clp$trimmed_string_size (tape_list [i].recorded_vsn)), '''');
      IFEND;
      tape_vsn_string (index, length) := tape_string (1, length);
      index := index + length;

      additional_volume_p := tape_list [i].additional_volume_p;

      WHILE additional_volume_p <> NIL DO

        additional_tape_vsn_p := #PTR (additional_volume_p, packing_list_seq_p^);

        tape_string := '';
        STRINGREP (tape_string, length, ', ''', additional_tape_vsn_p^.
              recorded_vsn (1, clp$trimmed_string_size (additional_tape_vsn_p^.recorded_vsn)), '''');
        tape_vsn_string (index, length) := tape_string (1, length);
        index := index + length;

        additional_volume_p := additional_tape_vsn_p^.additional_volume_p;

      WHILEND;
    FOREND;

    rap$write_strings ('Recorded VSNs:     ', tape_vsn_string (1, index), FALSE, tape_vsn_indent,
          display_control, display_status);

    IF status.normal AND (NOT display_status.normal) THEN
      status := display_status;
    IFEND;

  PROCEND display_vsns;

?? TITLE := 'find_primary_subproduct', EJECT ??

{ PURPOSE:
{   This procedure finds the primary subproduct of a licensed
{   product.
{
{ DESIGN:
{   Information from the information array is checked until the
{   primary subproduct is found.  If there is no primary subproduct,
{   a boolean is set to false.
{
{ NOTES:
{
{

  PROCEDURE find_primary_subproduct
    (    subproduct_list_p: subproduct_sort_list_p;
         index: rat$subproduct_count;
     VAR primary_index: rat$subproduct_count;
     VAR primary_subproduct: boolean);

    VAR
      last_licensed_product: rat$licensed_product;

    last_licensed_product := subproduct_list_p^ [index].licensed_product;
    primary_index := index;
    primary_subproduct := FALSE;

  /find_primary/
    WHILE NOT primary_subproduct DO

      IF (subproduct_list_p^ [primary_index].licensed_product = last_licensed_product) AND
            (subproduct_list_p^ [primary_index].attributes_p^.primary) THEN

        primary_subproduct := TRUE;

      ELSEIF subproduct_list_p^ [primary_index].licensed_product <> last_licensed_product THEN

        EXIT /find_primary/;

      ELSE

        IF primary_index < UPPERBOUND (subproduct_list_p^) THEN
          primary_index := primary_index + 1;
        ELSE
          EXIT /find_primary/;
        IFEND;

      IFEND;

    WHILEND /find_primary/;

  PROCEND find_primary_subproduct;

?? TITLE := 'open_packing_list', EJECT ??

{ PURPOSE:
{   This procedure opens a file and validates that it is a packing
{   list.
{
{ DESIGN:
{   The file is opened and the sequence descriptor is tested to see
{   if the file is a packing list.
{
{ NOTES:
{
{

  PROCEDURE open_packing_list
    (    packing_list_path: fst$file_reference;
     VAR packing_list_seq_p: ^rat$packing_list_sequence;
     VAR packing_list_opened: boolean;
     VAR packing_list_fid: amt$file_identifier;
     VAR status: ost$status);


    VAR
      attachment_option: array [1 .. 2] of fst$attachment_option,
      packing_list_header_p: ^rat$packing_list_header,
      seg_p: amt$segment_pointer,
      sequence_descriptor_p: ^rat$sequence_descriptor;

    status.normal := TRUE;

    attachment_option [1].selector := fsc$access_and_share_modes;
    attachment_option [1].access_modes.selector := fsc$specific_access_modes;
    attachment_option [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_option [1].share_modes.selector := fsc$determine_from_access_modes;
    attachment_option [2].selector := fsc$create_file;
    attachment_option [2].create_file := FALSE;

    packing_list_opened := TRUE;
    fsp$open_file (packing_list_path, amc$segment, ^attachment_option, NIL, NIL, NIL, NIL, packing_list_fid,
          status);
    IF NOT status.normal THEN
      packing_list_opened := FALSE;
      RETURN;
    IFEND;

    amp$get_segment_pointer (packing_list_fid, amc$sequence_pointer, seg_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    packing_list_seq_p := seg_p.sequence_pointer;
    NEXT sequence_descriptor_p IN packing_list_seq_p;

    IF (sequence_descriptor_p = NIL) OR (sequence_descriptor_p^.sequence_type <> rac$packing_list_sequence)
          THEN
      osp$set_status_abnormal ('RA', rae$not_a_packing_list, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, packing_list_path, status);
      RETURN;
    IFEND;

    IF sequence_descriptor_p^.sequence_level <> rac$packing_list_level THEN
      osp$set_status_abnormal ('RA', rae$incompatible_sequence_level, 'PACKING LIST', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, sequence_descriptor_p^.sequence_level,
            status);
      RETURN;
    IFEND;

  PROCEND open_packing_list;
?? TITLE := 'sort_groups', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to sort the group_list
{   by group by subproduct name.
{
{ DESIGN:
{   The sorting is performed by a shell sort.
{
{
{ NOTES:
{

  PROCEDURE sort_groups
    (    group_p: group_sort_list_p);

    VAR
      current: integer,
      gap: integer,
      start: integer,
      swap: group_sort_record;


    gap := UPPERBOUND (group_p^);

    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;

      FOR start := LOWERBOUND (group_p^) TO UPPERBOUND (group_p^) - gap DO
        current := start;

        WHILE (current > 0) AND (group_p^ [current].sort_data > group_p^ [current + gap].sort_data) DO
          swap := group_p^ [current];
          group_p^ [current] := group_p^ [current + gap];
          group_p^ [current + gap] := swap;
          current := current - gap;
        WHILEND;

      FOREND;

    WHILEND;

  PROCEND sort_groups;

?? TITLE := 'sort_subproduct_info', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to sort the subproduct_info_list
{   by licensed product and by subproduct name.
{
{ DESIGN:
{   The procedure uses a shell sort.
{
{ NOTES:
{

  PROCEDURE sort_subproduct_info
    (    subproduct_list_p: subproduct_sort_list_p);

    VAR
      current: integer,
      gap: integer,
      start: integer,
      swap: subproduct_sort_record;


    gap := UPPERBOUND (subproduct_list_p^);

    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;

      FOR start := LOWERBOUND (subproduct_list_p^) TO UPPERBOUND (subproduct_list_p^) - gap DO
        current := start;

        WHILE (current > 0) AND (subproduct_list_p^ [current].
              sort_data > subproduct_list_p^ [current + gap].sort_data) DO
          swap := subproduct_list_p^ [current];
          subproduct_list_p^ [current] := subproduct_list_p^ [current + gap];
          subproduct_list_p^ [current + gap] := swap;
          current := current - gap;
        WHILEND;

      FOREND;

    WHILEND;

  PROCEND sort_subproduct_info;

MODEND ram$display_packing_list;





*DECK DECK=RAM$DISPLAY_PACKING_LIST_INSS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: DISPLAY_PACKING_LIST Subcommand.' ??
MODULE ram$display_packing_list_inss;

{ PURPOSE:
{   This module contains the command interface for the INSTALL_SOFTWARE
{   subcommand DISPLAY_PACKING_LIST.
{
{ DESIGN:
{   The code which displays the packing list resides in the module
{   RAM$DISPLAY_PACKING_LIST.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*copyc clp$evaluate_parameters
*copyc rap$display_packing_list
*copyc rav$installation_defaults
?? OLDTITLE, NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
?? OLDTITLE, NEWTITLE := '[XDCL] rap$display_packing_list_inss', EJECT ??

{ PURPOSE:
{   This procedure displays information about a packing list in the
{   Installation Data Base.
{
{ DESIGN:
{   Combine the packing list name from the command parameters with
{   the current location of the installation database catalog to build
{   a path to the packing list file.  Invoke the interface to display
{   the contents of a packing list.
{ NOTES:

  PROCEDURE [XDCL] rap$display_packing_list_inss
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE displ_pdt (
{   packing_list, pl: name 1..16 = $required
{   display_option, do: key
{       (brief, b), (full, f)
{     keyend = brief
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
          default_value: string (5),
        recend,
        type3: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 14, 14, 54, 12, 149], clc$command, 7, 4, 1, 0, 0, 0, 4, 'DISPL_PDT'],
            [['DISPLAY_OPTION                 ', clc$nominal_entry, 2],
            ['DO                             ', clc$abbreviation_entry, 2],
            ['O                              ', clc$abbreviation_entry, 3],
            ['OUTPUT                         ', clc$nominal_entry, 3],
            ['PACKING_LIST                   ', clc$nominal_entry, 1],
            ['PL                             ', clc$abbreviation_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 4]], [
{ PARAMETER 1
      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$name_type], [1, 16]],
{ PARAMETER 2
      [[1, 0, clc$keyword_type], [4], [['B                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['BRIEF                          ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['F                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FULL                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]], 'brief'],
{ PARAMETER 3
      [[1, 0, clc$file_type], '$output'],
{ PARAMETER 4
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$packing_list = 1,
      p$display_option = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      packing_list_path: fst$path,
      path_length: integer;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (packing_list_path, path_length, rav$installation_defaults.installation_database.
          path (1, rav$installation_defaults.installation_database.size), '.', pvt [p$packing_list].
          value^.name_value);

    rap$display_packing_list (^packing_list_path (1, path_length),
          ^pvt[p$packing_list].value^.name_value {subtitle is packing list name},
          ^rav$installation_defaults.installation_database.path
          (1, rav$installation_defaults.installation_database.size), pvt [p$display_option].
          value^.name_value, pvt [p$output].value^.file_value, status);

  PROCEND rap$display_packing_list_inss;
?? OLDTITLE ??

MODEND ram$display_packing_list_inss;
*DECK DECK=RAM$DISPLAY_PACKING_LIST_PACS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: DISPLAY_PACKING_LIST Subcommand.' ??
MODULE ram$display_packing_list_pacs;

{ PURPOSE:
{   This module contains the command interface for the PACKAGE_SOFTWARE
{   subcommand DISPLAY_PACKING_LIST.
{
{ DESIGN:
{   The code which displays the packing list resides in the module
{   RAM$DISPLAY_PACKING_LIST.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*copyc clp$evaluate_parameters
*copyc rap$display_packing_list
?? OLDTITLE, NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
?? OLDTITLE, NEWTITLE := '[XDCL] rap$display_packing_list_pacs', EJECT ??

{ PURPOSE:
{   This procedure displays information about a packing list file.
{
{ DESIGN:
{   Combine the packing list name from the command parameters with
{   the current location of the installation database catalog to build
{   a path to the packing list file.  Invoke the interface to display
{   the contents of a packing list.
{ NOTES:

  PROCEDURE [XDCL] rap$display_packing_list_pacs
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE displ_pdt (
{   packing_list, pl: file = $required
{   display_option, do: key
{       (brief, b), (full, f)
{     keyend = brief
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
          default_value: string (5),
        recend,
        type3: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 9, 14, 15, 0, 37, 484], clc$command, 7, 4, 1, 0, 0, 0, 4, 'DISPL_PDT'],
            [['DISPLAY_OPTION                 ', clc$nominal_entry, 2],
            ['DO                             ', clc$abbreviation_entry, 2],
            ['O                              ', clc$abbreviation_entry, 3],
            ['OUTPUT                         ', clc$nominal_entry, 3],
            ['PACKING_LIST                   ', clc$nominal_entry, 1],
            ['PL                             ', clc$abbreviation_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 4]], [
{ PARAMETER 1
      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$file_type]],
{ PARAMETER 2
      [[1, 0, clc$keyword_type], [4], [['B                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['BRIEF                          ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['F                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FULL                           ', clc$nominal_entry,
            clc$normal_usage_entry, 2]], 'brief'],
{ PARAMETER 3
      [[1, 0, clc$file_type], '$output'],
{ PARAMETER 4
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$packing_list = 1,
      p$display_option = 2,
      p$output = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$display_packing_list (pvt [p$packing_list].value^.file_value,
          pvt[p$packing_list].value^.file_value {subtitle},
          NIL {No IDB catalog path to display},
          pvt [p$display_option].value^.name_value, pvt [p$output].value^.file_value,
          status);

  PROCEND rap$display_packing_list_pacs;
?? OLDTITLE ??

MODEND ram$display_packing_list_pacs;
*DECK DECK=RAM$DISPLAY_PREVIOUS_COMMANDS EXPAND=TRUE
*copy osd$default_pragmats
?? TITLE := 'RAM$DISPLAY_PREVIOUS_COMMANDS' ??
MODULE ram$display_previous_commands;

*copyc amp$get_next
*copyc amp$put_next
*copyc amp$put_partial
*copyc amp$rewind
*copyc amp$return
*copyc clp$get_value
*copyc clc$standard_file_names
*copyc clp$scan_command_line
*copyc clp$scan_parameter_list
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file


  CONST
    rac$max_previous_commands = 0ffff(16);

  TYPE
    rat$previous_commands = 0..rac$max_previous_commands,
    circular_queue = ^queue_element,
    queue_element = record
      data: ost$string,
      forward: circular_queue,
      backward: circular_queue,
    recend;


  PROCEDURE create_circular_queue (number_of_nodes: rat$previous_commands;
    VAR head: circular_queue);

    VAR
      node: circular_queue,
      front: circular_queue,
      cnt: rat$previous_commands;

    ALLOCATE node;
    node^.data.value := ' ';
    node^.forward := NIL;
    node^.backward := NIL;

    front := node;
    head := node;

    FOR cnt := 2 TO number_of_nodes DO
      ALLOCATE node;
      node^.data.value := ' ';
      node^.forward := NIL;
      node^.backward := front;
      front^.forward := node;
      front := node;
    FOREND;

    head^.backward := front;
    front^.forward := head;

  PROCEND create_circular_queue;

  PROCEDURE generate_command_queue (number_of_commands: rat$previous_commands;
    VAR command_queue: circular_queue;
    VAR status: ost$status);

    VAR
      head: circular_queue,
      job_log_fid: amt$file_identifier,
      file_pos: amt$file_position,
      tran_cnt: amt$transfer_count,
      byte_adr: amt$file_byte_address,
      input_line: ost$string,
      previous_command: ost$string,
      attachment_option: array [1 .. 1] of fst$attachment_option,
      command_counter: rat$previous_commands;


    create_circular_queue (number_of_commands + 1, command_queue);
    head := command_queue;

    attachment_option [1].selector := fsc$access_and_share_modes;
    attachment_option [1].access_modes.selector := fsc$specific_access_modes;
    attachment_option [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_option [1].share_modes.selector := fsc$specific_share_modes;
    attachment_option [1].share_modes.value := $fst$file_access_options [];

    fsp$open_file (clc$job_log, amc$record, ^attachment_option, NIL, NIL, NIL, NIL, job_log_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$rewind (job_log_fid, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_next (job_log_fid, ^input_line, #SIZE (input_line), tran_cnt, byte_adr, file_pos, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    previous_command.value (1) := ' ';
    command_counter := 0;
    WHILE file_pos <> amc$eoi DO
      IF input_line.value (12, 2) = 'CI' THEN
        previous_command.value (2, * ) := input_line.value (15, * );
        previous_command.size := tran_cnt - 15;

        IF previous_command.size > 1 THEN
          command_counter := command_counter + 1;
          command_queue := command_queue^.forward;
          command_queue^.data := previous_command;
        IFEND
      IFEND;

      input_line.value :=
        '                                                                                      ';
      amp$get_next (job_log_fid, ^input_line, #SIZE (input_line), tran_cnt, byte_adr, file_pos, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    WHILEND;

    fsp$close_file (job_log_fid, status);

    IF command_counter <= number_of_commands THEN
      command_queue^.forward := head^.forward;
      head^.forward^.backward := command_queue;
    IFEND;

{ remove last command entered  (i.e. dispc) }
    command_queue^.forward^.backward := command_queue^.backward;
    command_queue^.backward^.forward := command_queue^.forward;
    command_queue := command_queue^.forward;
  PROCEND generate_command_queue;

?? NEWTITLE := 'RAP$DISPLAY_PREVIOUS_COMMANDS', EJECT ??
  PROCEDURE [XDCL, #GATE] rap$display_previous_commands (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ PDT  display_prev_cmd_pdt (
{   number_of_commands, noc, n: INTEGER 1..0ffff(16) = 24
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    display_prev_cmd_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^display_prev_cmd_pdt_names, ^display_prev_cmd_pdt_params];

  VAR
    display_prev_cmd_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
      clt$parameter_name_descriptor := [['NUMBER_OF_COMMANDS', 1], ['NOC', 1], ['N', 1], ['OUTPUT', 2], ['O',
      2], ['STATUS', 3]];

  VAR
    display_prev_cmd_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
      clt$parameter_descriptor := [

{ NUMBER_OF_COMMANDS NOC N }
    [[clc$optional_with_default, ^display_prev_cmd_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 1, 0ffff(16)]],

{ OUTPUT O }
    [[clc$optional_with_default, ^display_prev_cmd_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    display_prev_cmd_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := '24';

  VAR
    display_prev_cmd_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$output';

?? POP ??

    VAR
      command_queue: circular_queue,
      head: circular_queue,
      byte_adr: amt$file_byte_address,
      display_lfn: amt$local_file_name,
      display_fid: amt$file_identifier,
      number_of_commands: rat$previous_commands,
      tran_cnt: amt$transfer_count,
      value: clt$value;


    clp$scan_parameter_list (parameter_list, display_prev_cmd_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('NUMBER_OF_COMMANDS', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    number_of_commands := value.int.value;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$open_file (value.file.local_file_name, amc$record, nil, NIL, NIL, NIL, NIL, display_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    generate_command_queue (number_of_commands, command_queue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    head := command_queue;
    REPEAT
      amp$put_next (display_fid, ^command_queue^.data.value, command_queue^.data.size, byte_adr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      command_queue := command_queue^.forward;
    UNTIL command_queue = head;

    fsp$close_file (display_fid, status);

  PROCEND rap$display_previous_commands;

?? OLDTITLE, NEWTITLE := 'RAP$MODIFY_PREVIOUS_COMMANDS', EJECT ??
  PROCEDURE [XDCL, #GATE] rap$modify_previous_commands (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{ PDT modify_pc_pdt (
{   commands_back, cb: integer 1..100 = 1
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    modify_pc_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^modify_pc_pdt_names,
      ^modify_pc_pdt_params];

  VAR
    modify_pc_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['COMMANDS_BACK', 1], ['CB', 1], ['STATUS', 2]];

  VAR
    modify_pc_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ COMMANDS_BACK CB }
    [[clc$optional_with_default, ^modify_pc_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 1, 100]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    modify_pc_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '1';

?? POP ??

    VAR
      command_queue: circular_queue,
      head: circular_queue,
      byte_adr: amt$file_byte_address,
      display_lfn: [STATIC] amt$local_file_name := '$OUTPUT',
      display_fid: amt$file_identifier,
      edit_line: ost$string,
      queue_size: rat$previous_commands,
      tran_cnt: amt$transfer_count,
      value: clt$value;


    PROCEDURE modify_line (VAR old: ost$string;
      VAR status: ost$status);

      VAR
        changes: ost$string,
        chng_cnt: 0 .. 256,
        difference: - 256 .. 256,
        max_length: 0 .. 256,
        new: ost$string,
        new_cnt: 0 .. 256,
        old_cnt: 0 .. 256,
        display_line: string (256),
        input_fid: amt$file_identifier,
        input_lfn: [STATIC] amt$local_file_name := '$INPUT',
        prompt: [STATIC] string (3) := ' ==',
        file_pos: amt$file_position,
        tran_cnt: amt$transfer_count;


      fsp$open_file (input_lfn, amc$record, NIL, NIL, NIL, NIL, NIL, input_fid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      display_line (1, 5) := ' ==> ';
      display_line (6, * ) := old.value (1, old.size);
      amp$put_next (display_fid, ^display_line, old.size + 5, byte_adr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$put_partial (display_fid, ^prompt, #SIZE (prompt), byte_adr, amc$start, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$get_next (input_fid, ^changes.value, #SIZE (changes.value),
            tran_cnt, byte_adr, file_pos, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fsp$close_file (input_fid, status);

      changes.size := tran_cnt;

      IF old.size < changes.size THEN
        max_length := changes.size;
      ELSE
        IF changes.size = 0 THEN
          RETURN;
        ELSE
          max_length := old.size;
        IFEND;
      IFEND;

      difference := 0;
      old_cnt := 1;
      new_cnt := 1;

      /process_line/
      WHILE old_cnt <= max_length DO
        IF old_cnt > changes.size THEN
          WHILE old_cnt <= old.size DO
            new.value (new_cnt) := old.value (old_cnt);
            old_cnt := old_cnt + 1;
            new_cnt := old_cnt - difference;
          WHILEND;
          EXIT /process_line/;
        IFEND;

        CASE changes.value (old_cnt) OF
        = '&' =
          new.value (new_cnt) := ' ';

        = ' ' =
          IF old_cnt <= old.size THEN
            new.value (new_cnt) := old.value (old_cnt);
          ELSE
            new.value (new_cnt) := ' ';
          IFEND;

        = '#' =
          difference := difference + 1;

        = '^' =
          chng_cnt := old_cnt + 1;
          WHILE (changes.value (chng_cnt) <> '#') AND (chng_cnt <= changes.size) DO
            new.value (new_cnt) := changes.value (chng_cnt);
            chng_cnt := chng_cnt + 1;
            difference := difference - 1;
            new_cnt := old_cnt - difference;
          WHILEND;

          WHILE old_cnt < chng_cnt DO
            new.value (new_cnt) := old.value (old_cnt);
            old_cnt := old_cnt + 1;
            new_cnt := old_cnt - difference;
          WHILEND;
          new.value (new_cnt) := old.value (old_cnt);

        ELSE
          new.value (new_cnt) := changes.value (old_cnt);
        CASEND;

        old_cnt := old_cnt + 1;
        new_cnt := old_cnt - difference;

      WHILEND /process_line/;

      new.size := new_cnt;
      new.value(2,*) := new.value(1,*);
      new.value(1) := ' ';
      old := new;

      amp$put_next (display_fid, ^old.value (1, old.size), old.size, byte_adr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    PROCEND modify_line;

    clp$scan_parameter_list (parameter_list, modify_pc_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('COMMANDS_BACK', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    queue_size := value.int.value;


    fsp$open_file (display_lfn, amc$record, NIL, NIL, NIL, NIL, NIL, display_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    generate_command_queue (queue_size, command_queue, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    edit_line.value := command_queue^.data.value(2,*);
    edit_line.size := command_queue^.data.size - 1;

    modify_line (edit_line, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_command_line (edit_line.value (1, edit_line.size), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$close_file (display_fid, status);

  PROCEND rap$modify_previous_commands;
MODEND ram$display_previous_commands;
*DECK DECK=RAM$DISPLAY_PROCEDURE EXPAND=TRUE
PROCEDURE (ram$disp) display_procedure, display_procedures, disp (
  procedure, procedures, p: list of any of
      integer radix 16
      name
      string
    anyend = all
  from, f: file = $working_catalog.command_library
  output, o: file = $output
  display_option, do: key
      (date_time, dt, d)
      (name, names, n)
      (content, c)
      (scu_deck, sd, s)
    keyend = date_time
  prefix_string, ps: string = ''
  suffix_string, ss: string = ''
  status)

" PURPOSE:
"   Display the specified modules from a libaray or object file.
" DESIGN:
"   Scan every module name on the library for the specified value. Write the selected modules to the
"   output file in a format selected by the display_options parameter.
" NOTES:
"   An integer procedure value is hexadecimal, convenient when processing CDCNET configuration procedures.
"   The SCU_DECK display_option produces source for the SOURCE_CODE_UTILITY create_deck command. The NAMES
"   and SCU_DECK display options allow you to prefix or suffix each procedure name with strings of your
"   choice. Creation dates are suppressed for object files.

  VAR
    display_status : status
    format : name = scl_proc
    library_list : file = $unique(:$local)
    modules_on_file : list 0..$max_list of string = ()
    modules_to_display : list 0..$max_list of string = ()
    specified_name : string 1..31
    temp_output : file = $unique(:$local)
  VAREND

  IF ($file(from, fs)= 'LIBRARY') AND ($file(from, fc)= 'OBJECT') THEN
    format=library
  IFEND

  set_file_attributes file=library_list page_format=continuous file_contents=legible
  IF (display_option = date_time) AND (format = library) THEN
    display_object_library display_option=date_time library=from output=library_list alphabetical_order=true
  ELSE
    display_object_library display_option=none library=from output=library_list alphabetical_order=true
  IFEND

  get_line variable=modules_on_file input=library_list
  delete_file file=library_list

  FOR EACH procedure_specified IN procedures DO " select a list of modules to display
    IF $generic_type(procedure_specified)= integer THEN " a CDCNET configuration procedure reference
      specified_name=$integer_string(procedure_specified, 16)
    ELSE " a substring of the procedure name was specified
      specified_name=$string(procedure_specified)
    IFEND
    IF specified_name = 'ALL' THEN " display all modules
      modules_to_display=$union(modules_to_display, $select(modules_on_file, $size(x)>0))
    ELSE " display specified modules
      modules_to_display=$union(modules_to_display, ..
            $select(modules_on_file, $scan_string(specified_name, ' '//$substring(x, 1, 32))>0))
    IFEND
  FOREND

  IF $nil(modules_to_display) THEN " assign appropriate display_library status
    display_object_library modules=$apply(procedures, $range_of($program_name(x))) library=from ..
          status=display_status
  ELSE
    put_line line=' Displaying procedures from     '//from output=$response
    IF display_option = date_time THEN
      put_line $apply(modules_to_display, ' '//x) output=temp_output.$eoi
    ELSEIF display_option = names THEN
      put_line $apply(modules_to_display, ' '//prefix_string//x//suffix_string) output=temp_output.$eoi
    ELSE
      FOR EACH selected_module IN modules_to_display DO
        IF display_option = scu_deck THEN
          deck_name=prefix_string // selected_module // suffix_string
          IF $size(deck_name)> 31 THEN
            deck_name=deck_name(1, 31)
            put_line ' ***** WARNING ***** - DECK NAME TRUNCATED TO '//deck_name output=$response
          IFEND
          put_line '*DECK DECK='//deck_name output=temp_output.$eoi
        IFEND
        CREATE_OBJECT_LIBRARY
          add_module module=selected_module library=from
          generate_library library=temp_output.$eoi format=scl_proc status=display_status
        QUIT
      FOREND
    IFEND
    copy_file temp_output output.$eoi
    delete_file temp_output
    put_line line=' Displayed '//$justify($integer_string($size(modules_to_display)), 4, right)//..
' procedures from '//from output=$response
  IFEND

  EXIT_PROC WITH display_status

PROCEND display_procedure
*DECK DECK=RAM$DISPLAY_PROCESSING_SUMMARY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: DISPLAY_PROCESSING_SUMMARY Subcommand.' ??
MODULE ram$display_processing_summary;

{ PURPOSE:
{   This module contains the interface that displays the processing summary
{   information for an installation.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$condition
*copyc rac$idb_directory_name
*copyc rac$not_installed
*copyc rac$packing_list_level
*copyc rae$install_software_cc
*copyc rat$idb_directory_types
*copyc rat$processing_summary_types
?? POP ??
*copyc amp$get_next
*copyc amp$get_segment_pointer
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_real
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$convert_real_to_string
*copyc clp$evaluate_parameters
*copyc clp$get_path_name
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$right_justify_string
*copyc clp$trimmed_string_size
*copyc clv$display_variables
*copyc clv$nil_display_control
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osv$upper_to_lower
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc rap$access_directory_for_read
*copyc rap$open_file
*copyc rav$installation_defaults
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
{ This array contains the rav$step_title array translated to the
{ format (upper/lower case) found in the job log.
 TYPE
   translated_step_title_array = array[rat$steps] of string(34);
 VAR
   translated_step_title: translated_step_title_array;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$display_processing_summary', EJECT ??

{ PURPOSE:
{   This interface displays a summary of the current status or
{   final status of an installation initiated by INSTALL_PRODUCT,
{   RAP$ACTIVATE_PRODUCT or INSTALL_CORRECTION.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$display_processing_summary
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE displ_pdt (
{   job_log_file, jlf: file = $required
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 8, 7, 20, 58, 13, 293],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'DISPL_PDT'], [
    ['JLF                            ',clc$abbreviation_entry, 1],
    ['JOB_LOG_FILE                   ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$job_log_file = 1,
    p$output = 2,
    p$status = 3;

  VAR
    pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      default_ring_attributes: amt$ring_attributes,
      directory_pointers: rat$idb_directory_pointers,
      display_control: clt$display_control,
      display_opened: boolean,
      display_status: ost$status,
      length: integer,
      local_status: ost$status,
      log_file_fid : amt$file_identifier,
      log_file_opened: boolean;

?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

{ Add subtitles here, if needed. }

    PROCEND put_subtitle;
?? OLDTITLE ??
?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the files have been opened, they will be closed before the
{   the procedure returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

      IF log_file_opened THEN
        fsp$close_file (log_file_fid, ignore_status)
      IFEND

    PROCEND abort_handler;
*copyc clp$new_page_procedure
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    display_opened := FALSE;
    log_file_opened := FALSE;
    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    clv$titles_built := FALSE;
    clv$command_name := 'display_processing_summary';

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    initialize_scan_variables( translated_step_title);

    default_ring_attributes.r1 := #RING (^default_ring_attributes);
    default_ring_attributes.r2 := #RING (^default_ring_attributes);
    default_ring_attributes.r3 := #RING (^default_ring_attributes);

    osp$establish_block_exit_hndlr (^abort_handler);

    display_opened := TRUE;
    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
          default_ring_attributes, display_control, status);
    IF NOT status.normal THEN
      display_opened := FALSE;
      RETURN;
    IFEND;

  /main/
    BEGIN

      open_installation_log_file( pvt[p$job_log_file].value^.file_value,
         log_file_fid, log_file_opened, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      display_log_file_information (log_file_fid, display_control, status );
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

    END /main/;

    IF display_opened THEN
      clp$close_display (display_control, display_status);
    IFEND;

    IF log_file_opened THEN
      fsp$close_file (log_file_fid, local_status);
    IFEND;

    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    ELSEIF status.normal AND (NOT display_status.normal) THEN
      status := display_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$display_processing_summary;

  procedure initialize_scan_variables
    (VAR translated_step_title : translated_step_title_array);

*copyc rav$step_title
   var
    step_index : rat$steps;

   for step_index := lowerbound(rav$step_title) to upperbound(rav$step_title) do
      translated_step_title[step_index](1) := rav$step_title[step_index](1);
      #translate(osv$upper_to_lower, rav$step_title[step_index](2, *),
         translated_step_title[step_index]( 2, * ) );
   forend;
  procend initialize_scan_variables;
?? OLDTITLE ??
?? NEWTITLE := 'display_information_record', EJECT ??

{ PURPOSE:
{   This procedure displays information about the subproducts
{   that have been installed on a mainframe.
{
{ DESIGN:
{   Information from the installation data base is displayed.
{
{ NOTES:
{
{

  PROCEDURE display_information_record
    (    information_record: rat$information_record;
         display_option: ost$name;
         display_hidden_values: boolean;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      date: ost$date,
      display_status: ost$status,
      time: ost$time;


    status.normal := TRUE;
    display_status.normal := TRUE;

    write_strings ('    Level:                    ', information_record.subproduct_level, FALSE,
          display_control, display_status);

    IF (display_hidden_values) AND (information_record.internal_level <> osc$null_name) THEN
      write_strings ('    Internal Level:           ', information_record.internal_level, FALSE,
            display_control, display_status);
    IFEND;

    pmp$format_compact_date (information_record.date_installed, osc$iso_date, date, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$format_compact_time (information_record.date_installed, osc$hms_time, time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    write_strings ('    Install Date/Time:        ', date.iso, TRUE, display_control, display_status);
    write_strings (' ', time.hms, FALSE, display_control, display_status);

    IF (display_option = 'F') OR (display_option = 'FULL') THEN

      write_strings ('    Packing List:             ', information_record.packing_list, FALSE,
            display_control, display_status);
      write_strings ('    Installation Id:          ', information_record.installation_identifier, FALSE,
            display_control, display_status);

    IFEND;

    IF status.normal AND (NOT display_status.normal) THEN
      status := display_status;
    IFEND;

  PROCEND display_information_record;

?? OLDTITLE ??
?? NEWTITLE := 'display_idb_information', EJECT ??

{ PURPOSE:
{   This procedure displays information about the subproducts
{   that have been installed on a mainframe.
{
{ DESIGN:
{   Information from the installation data base is displayed.
{
{ NOTES:
{   This code assumes that if the active directory indicates not installed
{   that the subproduct (deferred and correction base) are not installed and
{   thus issues a message to that effect.  This will have to be dealt with
{   in BCU processing.

  PROCEDURE display_idb_information
    (    directory_p: ^rat$directory;
         display_option: ost$name;
         display_hidden_values: boolean;
     VAR display_control: clt$display_control;
     VAR status: ost$status);


    VAR
      display_status: ost$status,
      i: rat$subproduct_count,
      last_licensed_product: rat$licensed_product;

    status.normal := TRUE;

    display_status.normal := TRUE;
    last_licensed_product := '';

    FOR i := 1 TO UPPERBOUND (directory_p^) DO

      IF display_control.line_number > display_control.page_length - 9 THEN
        display_control.line_number := display_control.page_length;
      IFEND;

      IF directory_p^ [i].licensed_product <> last_licensed_product THEN

        last_licensed_product := directory_p^ [i].licensed_product;
        write_strings ('', '', FALSE, display_control, display_status);
        write_strings ('Licensed Product ', directory_p^ [i].
              licensed_product (1, clp$trimmed_string_size (directory_p^ [i].licensed_product)),
              TRUE, display_control, display_status);
        write_strings (':', '', FALSE, display_control, display_status);

      IFEND;

      write_strings ('', '', FALSE, display_control, display_status);

      write_strings ('  Subproduct ', directory_p^ [i].subproduct
            (1, clp$trimmed_string_size (directory_p^ [i].subproduct)), TRUE, display_control,
            display_status);
      write_strings (' Information:', '', FALSE, display_control, display_status);
      write_strings ('', '', FALSE, display_control, display_status);

      IF (display_option = 'F') OR (display_option = 'FULL') THEN
        write_strings ('    Description: ', directory_p^ [i].description, FALSE, display_control,
              display_status);
        write_strings ('', '', FALSE, display_control, display_status);
      IFEND;

      IF directory_p^ [i].active_information.installation_identifier <> rac$not_installed THEN
        write_strings ('    Type:                     ACTIVE', '', FALSE, display_control, display_status);
        display_information_record (directory_p^ [i].active_information, display_option,
              display_hidden_values, display_control, status);
      ELSE
        write_strings ('    {Currently not installed}', '', FALSE, display_control, display_status);
      IFEND;
      IF directory_p^ [i].deferred_information.installation_identifier <> rac$not_installed THEN
        write_strings ('    Type:                     DEFERRED', '', FALSE, display_control, display_status);
        display_information_record (directory_p^ [i].deferred_information, display_option,
              display_hidden_values, display_control, status);
      IFEND;

      { Only show corrective base information if it is 1) present and 2) different from the active level}

      IF (directory_p^ [i].corrective_base_information.installation_identifier <> rac$not_installed) AND
            (directory_p^ [i].corrective_base_information.subproduct_level <>
            directory_p^ [i].active_information.subproduct_level) THEN
        write_strings ('    Type:                     CORRECTION BASE', '', FALSE, display_control,
              display_status);
        display_information_record (directory_p^ [i].corrective_base_information, display_option,
              display_hidden_values, display_control, status);
      IFEND;

    FOREND;

    IF status.normal AND (NOT display_status.normal) THEN
      status := display_status;
    IFEND;

  PROCEND display_idb_information;

?? OLDTITLE ??
?? NEWTITLE := 'display_log_file_information', EJECT ??

{ PURPOSE:
{   This procedure displays information from an individual job log file.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE display_log_file_information
    (    file_identifier: amt$file_identifier;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      file_position: amt$file_position,
      ignore_byte_address: amt$file_byte_address,
      input_line: string (133),
      transfer_count: amt$transfer_count;

    status.normal := true;
    file_position := amc$boi;
    amp$get_next (file_identifier, ^input_line, #SIZE (input_line), transfer_count, ignore_byte_address,
          file_position, status);

    WHILE (file_position <> amc$eoi) AND (status.normal) DO

      if line_is_time_stamped( input_line(1, transfer_count) ) then
         if line_contains_step_data( input_line(1, transfer_count) ) then

      clp$put_partial_display( display_control, input_line( 1, transfer_count ),
         clc$no_trim, amc$terminate, status);

         ifend;
      ifend;
      if status.normal then
        amp$get_next (file_identifier, ^input_line, #SIZE (input_line), transfer_count, ignore_byte_address,
              file_position, status);
      ifend;

    WHILEND;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_log_file_information;

  FUNCTION line_contains_step_data
    (    input_line: string ( * )): boolean;

    VAR
      step_title_length: integer,
      step_index: rat$steps;

    line_contains_step_data := FALSE;
    IF STRLENGTH (input_line) >= (17 + 1 + 34) THEN

    /check_for_step_title/
      FOR step_index := LOWERBOUND (translated_step_title) TO UPPERBOUND (translated_step_title) DO
        step_title_length := clp$trimmed_string_size (translated_step_title [step_index]);
        IF STRLENGTH (input_line) >= (17 + 1 + step_title_length) THEN
          IF input_line (19, step_title_length ) = translated_step_title [step_index] (1,
                step_title_length) THEN
            line_contains_step_data := TRUE;
            EXIT /check_for_step_title/;
          IFEND;
        IFEND;
      FOREND /check_for_step_title/;

    IFEND;

  FUNCEND line_contains_step_data;

    FUNCTION line_is_time_stamped
      (    input_line: string ( * )): boolean;


      line_is_time_stamped := FALSE;
      IF STRLENGTH (input_line) >= 17 THEN
        IF (input_line (4) = ':') AND (input_line (7) = ':') AND (input_line (10) = '.') AND
              (input_line (14) = '.') AND (input_line (17) = '.') THEN
          line_is_time_stamped := TRUE;
        IFEND;
      IFEND;

    FUNCEND line_is_time_stamped;
?? OLDTITLE ??
?? NEWTITLE := 'open_installation_log_file', EJECT ??

{ PURPOSE:
{   This procedure opens an installation job_log file.
{
{ DESIGN:
{
{ NOTES:
{   Update to take an installation id, plus installation_logs_file default, plus actual file name
{
  PROCEDURE open_installation_log_file
    (    installation_identifier : ^fst$file_reference;
     VAR file_identifier: amt$file_identifier;
     VAR file_opened: boolean;
     VAR status: ost$status);

    rap$open_file( installation_identifier,  amc$record, fsc$read, {create_file=}false,
         {attach override=}NIL,
         file_identifier, file_opened, status);

  PROCEND open_installation_log_file;

?? OLDTITLE ??
?? NEWTITLE := 'write_string_and_integer', EJECT ??

{ PURPOSE:
{   This procedure writes a string and a integer to the output display.
{
{ DESIGN:
{   The string and the integer are combined into one string and a procedure
{   writes them to output.
{
{ NOTES:
{
{

  PROCEDURE write_string_and_integer
    (    string_a: string ( * );
         integer_a: integer;
         continue_line: boolean;
     VAR display_control: clt$display_control;
     VAR display_status: ost$status);

    VAR
      ignore_status: ost$status,
      line_a: string (2 * fsc$max_path_size),
      line_b: string (2 * fsc$max_path_size),
      line_size_a: integer,
      line_size_b: integer;

    IF NOT display_status.normal THEN
      RETURN;
    IFEND;

    line_a := '';
    STRINGREP (line_a, line_size_a, integer_a);

    line_b := '';
    STRINGREP (line_b, line_size_b, string_a, line_a (2, line_size_a - 1));

    IF continue_line THEN
      clp$put_partial_display (display_control, line_b (1, line_size_b), clc$no_trim, amc$continue,
            ignore_status);
    ELSE
      clp$put_partial_display (display_control, line_b (1, line_size_b), clc$no_trim, amc$terminate,
            ignore_status);
    IFEND;

  PROCEND write_string_and_integer;
?? OLDTITLE ??
?? NEWTITLE := 'write_strings', EJECT ??

{ PURPOSE:
{   This procedure writes two strings to the output display.
{
{ DESIGN:
{   The two strings are combined into one string and a procedure
{   writes them to output.
{
{ NOTES:
{
{

  PROCEDURE write_strings
    (    string_a: string ( * );
         string_b: string ( * );
         continue_line: boolean;
     VAR display_control: clt$display_control;
     VAR display_status: ost$status);


    VAR
      ignore_status: ost$status,
      line: string (osc$max_string_size),
      line_size: integer;


    IF NOT display_status.normal THEN
      RETURN;
    IFEND;

    line := '';
    STRINGREP (line, line_size, string_a, string_b);

    IF continue_line THEN
      clp$put_partial_display (display_control, line (1, line_size), clc$no_trim, amc$continue,
            ignore_status);
    ELSE
      clp$put_partial_display (display_control, line (1, line_size), clc$no_trim, amc$terminate,
            ignore_status);
    IFEND;

  PROCEND write_strings;

MODEND ram$display_processing_summary;
*DECK DECK=RAM$DISPLAY_PROCESS_SUMMARY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: DISPLAY_PACKING_LIST Subcommand.' ??
MODULE ram$display_process_summary;

{ PURPOSE:
{   This module contains the interface that displays the contents of
{   the packing list.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
?? POP ??
*copyc clp$evaluate_parameters

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$display_process_summary', EJECT ??

{ PURPOSE:
{   This interface displays a summary of the current status or
{   final status of an installation initiated by INSTALL_PRODUCT,
{   RAP$ACTIVATE_PRODUCT or INSTALL_CORRECTION.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$display_process_summary
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE displ_pdt (
{   installation_identifier, ii: name = $required
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 5, 3, 10, 33, 8, 76],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'DISPL_PDT'], [
    ['II                             ',clc$abbreviation_entry, 1],
    ['INSTALLATION_IDENTIFIER        ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$installation_identifier = 1,
    p$output = 2,
    p$status = 3;

  VAR
    pvt: array [1 .. 3] of clt$parameter_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ(pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$display_process_summary;
MODEND ram$display_process_summary;
*DECK DECK=RAM$DISPLAY_PSRS_ANSWERED EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'RAP$DISPLAY_PSRS_ANSWEREDS procedure.' ??
MODULE ram$display_psrs_answered;

{ PURPOSE:
{   This module contains the procedures to display an array of psrs.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$max_line
*copyc clt$display_control
*copyc ost$status
*copyc rat$subproduct_info_types
?? POP ??
*copyc rap$write_strings

?? TITLE := '[XDCL] rap$display_psrs_answered', EJECT ??

{ PURPOSE:
{   This procedure displays the PSRs that are answered by a
{   correction.
{
{ DESIGN:
{   The procedure loops through an array of PSRs displaying each
{   psr.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$display_psrs_answered
    (    psrs_answered_p: ^rat$psrs_answered;
     VAR display_control: clt$display_control;
     VAR status: ost$status);


    VAR
      display_status: ost$status,
      indent: 0 .. rac$max_line,
      i: rat$psrs_answered_count;

    status.normal := TRUE;
    display_status.normal := TRUE;
    indent := 19;

    IF psrs_answered_p <> NIL THEN

      rap$write_strings ('    Answers PSRs: (', '', TRUE, 0, display_control, display_status);

      FOR i := 1 TO UPPERBOUND (psrs_answered_p^) DO

        IF i = 1 THEN
          rap$write_strings ('', psrs_answered_p^ [i], TRUE, indent, display_control,
                display_status);
        ELSE
          rap$write_strings (' ', psrs_answered_p^ [i], TRUE, indent, display_control,
                display_status);
        IFEND;

      FOREND;

      rap$write_strings (')', '', FALSE, 0, display_control, display_status);

    IFEND;

    IF status.normal AND (NOT display_status.normal) THEN
      status := display_status;
    IFEND;

  PROCEND rap$display_psrs_answered;

  MODEND ram$display_psrs_answered;
*DECK DECK=RAM$DISPLAY_SCFS_LOG EXPAND=TRUE
create_program_description display_scfs_log ..
      l=osf$current_library ..
      sp=nfp$display_scfs_log lm=$null lmo=none tel=warning

*DECK DECK=RAM$DISPLAY_SIF EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: Module RAM$DISPLAY_SIF.' ??
MODULE ram$display_sif;

{ PURPOSE:
{   This module contains the procedures to display the information in the SIF
{   sequence.
{
{ DESIGN:
{   The subproduct attributes, the element list or both may be displayed.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pmt$condition
*copyc rae$package_software_cc
*copyc rat$subproduct_info_pointers
*copyc rat$sequence_descriptor_types
*copyc rat$subproduct_info_p
*copyc rat$subproduct_info_types
*copyc rat$upper_level_permit
?? POP ??
*copyc clp$build_path_subtitle
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$get_path_name
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$open_display
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$right_justify_string
*copyc clp$scan_parameter_list
*copyc clp$trimmed_string_size
*copyc clv$display_variables
*copyc clv$nil_display_control
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osv$upper_to_lower
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc rap$add_name_to_path_ref
*copyc rap$display_psrs_answered

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    installation_path_ref_p: ^fst$file_reference,
    pacs_catalog_ref_p: ^fst$file_reference,
    scratch_seq_p: ^SEQ ( * );

?? TITLE := 'rap$display_sif [XDCL]', EJECT ??

{ PURPOSE:
{   This procedure determines which parts of the SIF are to be
{   displayed and calls the appropriate procedure.
{
{ DESIGN:
{   The SIF is NEXT'd to read the info_header_p.  Within the info_header_p
{   are pointers to the subproduct attributes record and the beginning
{   of the element list.
{   The value of the installation path is determined.
{   Then the subproduct_attributes, element_list or both are displayed.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$display_sif
    (    subproduct_info_ptrs: rat$subproduct_info_pointers;
         catalog_ref_p: ^fst$file_reference;
     VAR scratch_sequence_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      display_control: clt$display_control,
      display_hidden_values: boolean,
      display_opened: boolean,
      element_p: ^rat$element,
      file_ref_p: ^fst$file_reference,
      i: 0 .. clc$max_value_sets,
      input_file_id: amt$file_identifier,
      local_file_for_subtitle: clt$file,
      local_status: ost$status,
      ref_created: boolean,
      upper_level_permit: rat$upper_level_permit,
      value: clt$value,
      value_set_count: 0 .. clc$max_value_sets;

?? TITLE := 'put_subtitle', EJECT ??

    PROCEDURE [INLINE] put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

{     add subtitles here if needed}

    PROCEND put_subtitle;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the file has been opened, it will be closed before the
{   the procedure returns.
{
{ NOTES:
{
{
    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF display_opened THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND abort_handler;
*copy clp$new_page_procedure
*copy clp$put_path_subtitle
?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    display_opened := FALSE;
    pacs_catalog_ref_p := catalog_ref_p;
    scratch_seq_p := scratch_sequence_p;

    element_p := #PTR (subproduct_info_ptrs.info_header_p^.element_list_p,
          subproduct_info_ptrs.subproduct_info_seq_p^);

    translate_path_container_to_ref (subproduct_info_ptrs.attributes_p^.installation_path,
          subproduct_info_ptrs, installation_path_ref_p, scratch_seq_p, ref_created);

    display_control := clv$nil_display_control;
    clv$titles_built := FALSE;
    clv$command_name := 'display_subproduct_information';

    clp$get_value ('DISPLAY_HIDDEN_VALUES', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display_hidden_values := value.bool.value;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    osp$establish_block_exit_hndlr (^abort_handler);

    display_opened := TRUE;
    clp$open_display (value.file, ^clp$new_page_procedure, display_control, status);
    IF NOT status.normal THEN
      display_opened := FALSE;
      RETURN;
    IFEND;

  /main/
    BEGIN

      clp$get_set_count ('DISPLAY_OPTION', value_set_count, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      FOR i := 1 TO value_set_count DO
        clp$get_value ('DISPLAY_OPTION', i, 1, clc$low, value, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        IF (value.name.value (1, value.name.size) = 'SUBPRODUCT_ATTRIBUTES') OR
              (value.name.value (1, value.name.size) = 'SA') OR
              (value.name.value (1, value.name.size) = 'ALL') OR (value.name.value (1, value.name.size) =
              'A') THEN
          display_attributes_info (subproduct_info_ptrs, display_hidden_values, display_control, status);
          IF NOT status.normal THEN
            EXIT /main/;
          IFEND;

          IF subproduct_info_ptrs.psrs_answered_p <> NIL THEN

            write_strings ('', '', FALSE, display_control);
            write_strings (' This SUBPRODUCT_CORRECTION ', '', FALSE, display_control);

            rap$display_psrs_answered (subproduct_info_ptrs.psrs_answered_p, display_control, status);
            IF NOT status.normal THEN
              EXIT /main/;
            IFEND;

          IFEND;

        IFEND;

        IF (value.name.value (1, value.name.size) = 'ELEMENT_LIST') OR
              (value.name.value (1, value.name.size) = 'EL') OR
              (value.name.value (1, value.name.size) = 'ALL') OR (value.name.value (1, value.name.size) =
              'A') THEN

          file_ref_p := NIL;
          display_inst_catalog_info (file_ref_p, subproduct_info_ptrs, display_control, upper_level_permit,
                status);
          IF NOT status.normal THEN
            EXIT /main/;
          IFEND;

          file_ref_p := NIL;
          display_elements (file_ref_p, subproduct_info_ptrs, element_p,
                upper_level_permit, display_control, status);
          IF NOT status.normal THEN
            EXIT /main/;
          IFEND;
        IFEND;
      FOREND;

    END /main/;

    IF display_opened THEN
      clp$close_display (display_control, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$display_sif;

?? TITLE := 'display_attributes_info', EJECT ??

{ PURPOSE:
{   This procedure displays all of the subproduct attributes.
{
{ DESIGN:
{   If the licensed_product field has not been defined, none of the
{   other fields are displayed.
{   Each of the fields is read from the attributes record and displayed to
{   the output file.
{
{ NOTES:
{
{

  PROCEDURE display_attributes_info
    (    subproduct_seq_p: rat$subproduct_info_pointers;
         display_hidden_values: boolean;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      attributes_p: ^rat$subproduct_attributes,
      i: pft$array_index,
      package_software_ref_p: ^fst$file_reference,
      path_ref_p: ^fst$file_reference,
      path_container_p: ^rat$path_container,
      ref_created: boolean,
      sequence_descriptor_p: ^rat$sequence_descriptor;

*copy rav$installation_path_option
*copy rav$installation_scheme
*copy rav$subproduct_priority
*copy rav$subproduct_type

    status.normal := TRUE;
    attributes_p := subproduct_seq_p.attributes_p;
    path_container_p := subproduct_seq_p.path_container_p;
    sequence_descriptor_p := subproduct_seq_p.sequence_descriptor_p;

    write_strings ('', '', FALSE, display_control);

    write_strings (' Attributes of subproduct ', attributes_p^.name, FALSE, display_control);

    write_strings ('', '', FALSE, display_control);

    IF attributes_p^.licensed_product = '' THEN
      write_strings (' {Subproduct attributes not defined.}', '', FALSE, display_control);
      RETURN;
    IFEND;

    write_strings (' Additional Products:        ', '', TRUE, display_control);

    IF attributes_p^.additional_products [1] = '' THEN
      write_strings ('NONE', '', FALSE, display_control);

    ELSE

      FOR i := 1 TO rac$max_additional_products DO

        IF attributes_p^.additional_products [i] <> '' THEN

          IF i = 1 THEN
            write_strings ('', attributes_p^.additional_products [i], FALSE, display_control);
          ELSE
            write_strings ('                             ', attributes_p^.additional_products [i], FALSE,
                  display_control);
          IFEND;

        IFEND;

      FOREND;

    IFEND;

    write_strings (' Description:                ', attributes_p^.description, FALSE, display_control);

    write_strings (' Development Group:          ', attributes_p^.development_group, FALSE, display_control);

    write_strings (' Installation Scheme:        ', rav$installation_scheme
          [attributes_p^.installation_scheme], FALSE, display_control);

    translate_path_container_to_ref (attributes_p^.installer_procedure, subproduct_seq_p, path_ref_p,
          scratch_seq_p, ref_created);

    IF ref_created THEN
      write_strings (' Installer Procedure:        :', path_ref_p^, FALSE, display_control);
    ELSE
      write_strings (' Installer Procedure:        ', 'NONE', FALSE, display_control);
    IFEND;

    write_strings (' Level:                      ', attributes_p^.level, FALSE, display_control);

    write_strings (' Licensed Product:           ', attributes_p^.licensed_product, FALSE, display_control);

    write_strings (' Dependencies:               ', '', TRUE, display_control);

    IF attributes_p^.dependencies [1] = '' THEN
      write_strings ('NONE', '', FALSE, display_control);

    ELSE

      FOR i := 1 TO rac$max_dependencies DO

        IF attributes_p^.dependencies [i] <> '' THEN

          IF i = 1 THEN
            write_strings (attributes_p^.dependencies [i], '', FALSE, display_control);
          ELSE
            write_strings ('                             ', attributes_p^.dependencies [i], FALSE,
                  display_control);
          IFEND;

        IFEND;

      FOREND;

    IFEND;

    write_strings (' Installation Path:          :', installation_path_ref_p^, FALSE, display_control);

    write_strings (' PACS Catalog Path:          ', attributes_p^.pacs_catalog_path.path (1,
          attributes_p^.pacs_catalog_path.size), FALSE, display_control);

    write_strings (' Subproduct Type:            ', rav$subproduct_type [attributes_p^.subproduct_type],
            FALSE, display_control);

    IF attributes_p^.auto_install = TRUE THEN
      write_strings (' Auto Install:               TRUE', '', FALSE, display_control);
    ELSE
      write_strings (' Auto Install:               FALSE', '', FALSE, display_control);
    IFEND;

    write_strings (' Date Level:                 ', attributes_p^.date_level, FALSE, display_control);

    IF attributes_p^.hidden = TRUE THEN
      write_strings (' Hidden:                     TRUE', '', FALSE, display_control);
    ELSE
      write_strings (' Hidden:                     FALSE', '', FALSE, display_control);
    IFEND;

    write_strings (' Installation Path Option:   ', rav$installation_path_option
          [attributes_p^.installation_path_option], FALSE, display_control);

    IF attributes_p^.primary = TRUE THEN
      write_strings (' Primary Subproduct:         TRUE', '', FALSE, display_control);
    ELSE
      write_strings (' Primary Subproduct:         FALSE', '', FALSE, display_control);
    IFEND;

    IF attributes_p^.files_stamped = TRUE THEN
      write_strings (' Files Stamped:              TRUE', '', FALSE, display_control);
    ELSE
      write_strings (' Files Stamped:              FALSE', '', FALSE, display_control);
    IFEND;

    write_strings (' Correction Base Level:      ', attributes_p^.correction_base_level, FALSE,
          display_control);

    write_strings (' Sizes:', '', FALSE, display_control);

    write_string_and_integer ('    Product Class Files:     ', attributes_p^.product_file_size, FALSE,
            display_control);

    write_string_and_integer ('    Service Critical Files:  ', attributes_p^.service_critical_file_size,
            FALSE, display_control);

    write_string_and_integer ('    User Permanent Files:    ', attributes_p^.user_permanent_file_size,
            FALSE, display_control);

    write_string_and_integer ('    Subproduct Backup:       ', attributes_p^.size, FALSE, display_control);

    write_strings (' SIF Identifier:             ', attributes_p^.sif_identifier, FALSE, display_control);

    IF attributes_p^.correction_base_sif_identifier <> '' THEN
      write_strings (' CRESC Base SIF Identifier:  ', attributes_p^.correction_base_sif_identifier, FALSE,
            display_control);
    IFEND;

    IF display_hidden_values THEN

      write_strings (' Internal Level:             ', attributes_p^.internal_level, FALSE, display_control);

      write_strings (' Subproduct Priority:        ', rav$subproduct_priority
            [attributes_p^.subproduct_priority], FALSE, display_control);

    IFEND;

  PROCEND display_attributes_info;

?? TITLE := 'display_catalog_element', EJECT ??

{ PURPOSE:
{   This procedure displays the information about a catalog that is
{   stored in the element list.
{
{ DESIGN:
{   The PACS catalog path is displayed when available.
{   If the installation catalog path is displayed when available.
{   If the catalog has a permit defined, the permit and catalog name
{   The catalog permits are display by calling another procedure.
{   are passed back to the calling procedure.
{
{ NOTES:
{
{

  PROCEDURE display_catalog_element
    (    element_p: ^rat$element;
         path_ref_p: ^fst$file_reference;
         upper_level_permit: rat$upper_level_permit;
         subproduct_seq_p: rat$subproduct_info_pointers;
     VAR catalog_permit: rat$upper_level_permit;
     VAR display_control: clt$display_control;
     VAR status: ost$status);


    status.normal := TRUE;

    write_strings ('', '', FALSE, display_control);

    IF pacs_catalog_ref_p <> NIL THEN
      write_strings (pacs_catalog_ref_p^, '.', TRUE, display_control);
      write_strings (path_ref_p^, '', FALSE, display_control);
    IFEND;

    IF installation_path_ref_p <> NIL THEN
      write_strings (':', installation_path_ref_p^, TRUE, display_control);
      write_strings ('.', path_ref_p^, FALSE, display_control);
    IFEND;

    write_strings ('', '', FALSE, display_control);

    write_string_and_integer ('  Type: CATALOG   Element Count: ', element_p^.element_count, FALSE,
          display_control);

    display_permit (element_p^.permit, upper_level_permit, subproduct_seq_p, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    catalog_permit.permit := element_p^.permit;

    IF element_p^.permit.defined = TRUE THEN
      catalog_permit.catalog := path_ref_p^;
      catalog_permit.size := clp$trimmed_string_size (path_ref_p^);
    IFEND;

  PROCEND display_catalog_element;

?? TITLE := 'display_elements', EJECT ??

{ PURPOSE:
{   This procedure determines if the element is a catalog or a file and
{   calls the appropriate procedure to display that type.
{
{ DESIGN:
{   For the number of elements in the catalog, if the element is a file,
{   the file is displayed.  If the element is a catalog, the catalog is displayed
{   and then DISPLAY_ELEMENTS calls itself with the parameters for the new catalog.
{   The next_element_across_p points to the next element in the same catalog.
{   The first_element_down_p points to the first element in the new catalog.
{
{ NOTES:
{
{

  PROCEDURE display_elements
    (    path_ref_p: ^fst$file_reference;
         subproduct_seq_p: rat$subproduct_info_pointers;
     VAR element_p: ^rat$element;
     VAR upper_level_permit: rat$upper_level_permit;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      i: pft$array_index,
      new_path_ref_p: ^fst$file_reference,
      first_element_down_p: ^rat$element,
      path_p: ^pft$path,
      catalog_permit: rat$upper_level_permit;

    status.normal := TRUE;

    WHILE element_p <> NIL DO

      IF element_p^.active_element THEN

        rap$add_name_to_path_ref (path_ref_p, element_p^.name, scratch_seq_p, new_path_ref_p);
        IF element_p^.element_type = rac$file THEN
          display_file_element (element_p, new_path_ref_p, subproduct_seq_p, upper_level_permit,
                display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        ELSE

          display_catalog_element (element_p, new_path_ref_p, upper_level_permit, subproduct_seq_p,
               catalog_permit, display_control, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          first_element_down_p := #PTR (element_p^.first_element_down_p,
                subproduct_seq_p.subproduct_info_seq_p^);

          IF catalog_permit.permit.defined = TRUE THEN
            display_elements (new_path_ref_p, subproduct_seq_p, first_element_down_p,
                  catalog_permit, display_control, status);
          ELSE
            display_elements (new_path_ref_p, subproduct_seq_p, first_element_down_p,
                  upper_level_permit, display_control, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;

        IFEND;

      IFEND;

      IF element_p^.next_element_across_p <> NIL THEN
        element_p := #PTR (element_p^.next_element_across_p, subproduct_seq_p.subproduct_info_seq_p^);
      ELSE
        element_p := NIL;
      IFEND;

    WHILEND;

  PROCEND display_elements;

?? TITLE := 'display_file_element', EJECT ??

{ PURPOSE:
{   This procedure displays information about a file in the element list.
{
{ DESIGN:
{   The PACS catalog path is displayed when available.
{   If the installation catalog path is displayed when available.
{   Each of the fields in the element list are displayed.
{   The permits are display by calling another procedure.
{
{ NOTES:
{
{

  PROCEDURE display_file_element
    (    element_p: ^rat$element;
         path_ref_p: ^fst$file_reference;
         subproduct_seq_p: rat$subproduct_info_pointers;
     VAR upper_level_permit: rat$upper_level_permit;
     VAR display_control: clt$display_control;
     VAR status: ost$status);


    VAR
      attributes_p: ^rat$subproduct_attributes,
      date: ost$date,
      i: pft$array_index,
      merge_path_ref_p: ^fst$file_reference,
      path_container_p: ^rat$path_container,
      ref_created: boolean,
      time: ost$time;

*copy rav$correction_format

    status.normal := TRUE;
    attributes_p := subproduct_seq_p.attributes_p;
    path_container_p := subproduct_seq_p.path_container_p;


    write_strings ('', '', FALSE, display_control);

    IF pacs_catalog_ref_p <> NIL THEN
      write_strings (pacs_catalog_ref_p^, '.', TRUE, display_control);
      write_strings (path_ref_p^, '', FALSE, display_control);
    IFEND;

    IF installation_path_ref_p <> NIL THEN
      write_strings (':', installation_path_ref_p^, TRUE, display_control);
      write_strings ('.', path_ref_p^, FALSE, display_control);
    IFEND;

    write_strings ('', '', FALSE, display_control);

    write_strings ('  Type: FILE:', '', TRUE, display_control);

    write_string_and_integer ('   Size: ', element_p^.size, TRUE, display_control);

    IF element_p^.ring_attributes.r1 = 0 THEN

      write_strings ('   Rings: ', '{none defined}', FALSE, display_control);

    ELSE

      write_string_and_integer ('   Rings: (', element_p^.ring_attributes.r1, TRUE, display_control);
      write_string_and_integer (' ', element_p^.ring_attributes.r2, TRUE, display_control);
      write_string_and_integer (' ', element_p^.ring_attributes.r3, TRUE, display_control);
      write_strings (')', '', FALSE, display_control);

    IFEND;

    write_string_and_integer ('  Contents Checksum: ', element_p^.contents_checksum, TRUE, display_control);

    write_string_and_integer ('  Attributes Checksum: ', element_p^.attributes_checksum, FALSE,
          display_control);

    IF element_p^.correction_base_contents_cksum <> 0 THEN

      write_string_and_integer ('  Correction Base Contents Checksum: ',
            element_p^.correction_base_contents_cksum, FALSE, display_control);

      write_string_and_integer ('  PRE_GENC Contents Checksum: ', element_p^.pre_genc_contents_checksum,
            FALSE, display_control);
    IFEND;

    IF element_p^.storage_class = rmc$msc_system_permanent_files THEN
      write_strings ('  Class: SERVICE_CRITICAL_PRODUCT', '', TRUE, display_control);
    ELSEIF element_p^.storage_class = rmc$msc_product_files THEN
      write_strings ('  Class: PRODUCT', '', TRUE, display_control);
    ELSEIF element_p^.storage_class = rmc$msc_user_permanent_files THEN
      write_strings ('  Class: USER_PERMANENT_FILES', '', TRUE, display_control);
    IFEND;

    write_strings ('   Format: ', rav$correction_format [element_p^.correction_format], FALSE,
          display_control);

    pmp$format_compact_date (element_p^.modification_date_time, osc$iso_date, date, status);
    pmp$format_compact_time (element_p^.modification_date_time, osc$millisecond_time, time, status);

    write_strings ('  Last Modification: ', date.iso, TRUE, display_control);

    write_strings (' ', time.millisecond, FALSE, display_control);

    display_permit (element_p^.permit, upper_level_permit, subproduct_seq_p, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    translate_path_container_to_ref (element_p^.library_merge, subproduct_seq_p, merge_path_ref_p,
          scratch_seq_p, ref_created);

    IF ref_created THEN
      write_strings ('  Merge with: :', merge_path_ref_p^, FALSE, display_control);
    ELSE
      write_strings ('  Merge with: ', '{None defined}', FALSE, display_control);
    IFEND;

  PROCEND display_file_element;


?? TITLE := 'display_inst_catalog_info', EJECT ??

{ PURPOSE:
{   This procedure displays information about the installation catalog
{   that is stored in the subproduct attributes record.
{
{ DESIGN:
{   The PACS catalog path is displayed if available.
{   Then the installation catalog path is displayed if available.
{   The catalog permits are display by calling another procedure.
{
{ NOTES:
{
{

  PROCEDURE display_inst_catalog_info
    (    file_ref_p: ^fst$file_reference;
         subproduct_seq_p: rat$subproduct_info_pointers;
     VAR display_control: clt$display_control;
     VAR upper_level_permit: rat$upper_level_permit;
     VAR status: ost$status);


    VAR
      attributes_p: ^rat$subproduct_attributes;


    status.normal := TRUE;
    attributes_p := subproduct_seq_p.attributes_p;

    write_strings ('', '', FALSE, display_control);

    write_strings (' Element list of subproduct ', subproduct_seq_p.attributes_p^.name, FALSE,
          display_control);

    write_strings ('', '', FALSE, display_control);

    IF pacs_catalog_ref_p <> NIL THEN
      write_strings (pacs_catalog_ref_p^, '', FALSE, display_control);
    IFEND;


    IF installation_path_ref_p <> NIL THEN
      write_strings (':', installation_path_ref_p^, FALSE, display_control);
    IFEND;

    write_strings ('', '', FALSE, display_control);

    write_string_and_integer ('  Type: CATALOG   Element Count: ', attributes_p^.first_level_element_count,
          FALSE, display_control);
    upper_level_permit.permit.defined := FALSE;

    display_permit (attributes_p^.catalog_permit, upper_level_permit, subproduct_seq_p, display_control,
           status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    upper_level_permit.catalog := '';
    upper_level_permit.size := 0;
    upper_level_permit.permit := attributes_p^.catalog_permit;

    write_strings ('', '', FALSE, display_control);

  PROCEND display_inst_catalog_info;

?? TITLE := 'display_permit', EJECT ??

{ PURPOSE:
{   This procedure displays the permits of a catalog or file.
{
{ DESIGN:
{   An element's permit and upper_level_permit are passed to this procedure.
{   If an element has permits defined, they are displayed.  If no permits
{   are defined for this element, upper_level_permits will be displayed if they exist.
{
{ NOTES:
{
{

  PROCEDURE display_permit
    (    element_permit: rat$permit;
         upper_level_permit: rat$upper_level_permit;
         subproduct_seq_p: rat$subproduct_info_pointers;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      attributes_p: ^rat$subproduct_attributes,
      counter: integer,
      i: pft$array_index,
      path_container_p: ^rat$path_container,
      permit: rat$permit,
      permit_options: pft$permit_options;

*copy rav$permit_names

    status.normal := TRUE;
    attributes_p := subproduct_seq_p.attributes_p;
    path_container_p := subproduct_seq_p.path_container_p;

    write_strings ('  Permit: ', '', TRUE, display_control);

    IF (element_permit.defined = FALSE) AND (upper_level_permit.permit.defined = FALSE) THEN
      write_strings ('NO PERMITS', '', FALSE, display_control);
      RETURN;
    IFEND;

    IF (element_permit.defined = FALSE) AND (upper_level_permit.permit.defined = TRUE) THEN
      permit := upper_level_permit.permit;
    ELSE
      permit := element_permit;
    IFEND;

    IF permit.permit_selections = $pft$permit_selections [] THEN

      write_strings ('  am=(NONE)  ', '', FALSE, display_control);

    ELSE

      counter := 0;

      FOR permit_options := LOWERVALUE (pft$permit_options) TO UPPERVALUE (pft$permit_options) DO

        IF permit_options IN permit.permit_selections THEN
          counter := counter + 1;

          IF counter = 1 THEN
            write_strings ('  am=(', rav$permit_names [permit_options] (1,
                clp$trimmed_string_size (rav$permit_names [permit_options])), TRUE, display_control);
          ELSE;
          write_strings (' ', rav$permit_names [permit_options] (1,
                clp$trimmed_string_size (rav$permit_names [permit_options])), TRUE, display_control);
          IFEND;

        IFEND;

      FOREND;

      write_strings (')  ', '', TRUE, display_control);

    IFEND;

    IF permit.share_requirements = $pft$share_requirements [] THEN

      write_strings ('  sm=(NONE)  ', '', FALSE, display_control);

    ELSE

      counter := 0;
      FOR permit_options := LOWERVALUE (pft$permit_options) TO UPPERVALUE (pft$permit_options) DO

        IF permit_options IN permit.share_requirements THEN

          counter := counter + 1;

          IF counter = 1 THEN
            write_strings ('  sm=(', rav$permit_names [permit_options] (1,
                clp$trimmed_string_size (rav$permit_names [permit_options])), TRUE, display_control);
          ELSE;
          write_strings (' ', rav$permit_names [permit_options] (1,
                clp$trimmed_string_size (rav$permit_names [permit_options])), TRUE, display_control);
          IFEND;

        IFEND;

      FOREND;

      write_strings (')  ', '', TRUE, display_control);

    IFEND;

    write_strings ('  ai=''', permit.application_info (1, clp$trimmed_string_size (permit.application_info)),
          TRUE, display_control);
    write_strings ('''', '', FALSE, display_control);

    IF (element_permit.defined = FALSE) AND (upper_level_permit.permit.defined = TRUE) THEN

      IF installation_path_ref_p <> NIL THEN

        write_strings ('  {Defined by catalog :', installation_path_ref_p^, TRUE, display_control);

      ELSEIF pacs_catalog_ref_p <> NIL THEN

        write_strings ('  {Defined by catalog :', pacs_catalog_ref_p^, TRUE, display_control);

      IFEND;

      IF upper_level_permit.size = 0 THEN

        write_strings ('}', '', FALSE, display_control);

      ELSE

        write_strings ('.', upper_level_permit.catalog (1,
              clp$trimmed_string_size (upper_level_permit.catalog)), TRUE, display_control);
        write_strings ('}', '', FALSE, display_control);

      IFEND;

    IFEND;

  PROCEND display_permit;

?? TITLE := 'translate_path_container_to_ref', EJECT ??

{ PURPOSE:
{   This procedure takes a set of path containers and converts
{   them into a file reference.
{
{ DESIGN:
{   rap$add_name_to_path_ref is used to build the file_reference
{   from the path containers.
{
{ NOTES:
{
{

  PROCEDURE translate_path_container_to_ref
    (    path_container_index: rat$path_container_indexer;
         subproduct_seq_p: rat$subproduct_info_pointers;
     VAR ref_p: ^fst$file_reference;
     VAR sequence_p: ^SEQ ( * );
     VAR ref_created: boolean);

    VAR
      file_ref_p: ^fst$file_reference,
      first_path_index: pft$array_index,
      i: pft$array_index,
      last_path_index: pft$array_index,
      new_file_ref_p: ^fst$file_reference,
      path_container_p: ^rat$path_container;


    path_container_p := subproduct_seq_p.path_container_p;
    ref_created := FALSE;

    IF path_container_index.path_length = 0 THEN
      ref_p := NIL;
      RETURN;
    IFEND;

    first_path_index := path_container_index.path_container_index;
    last_path_index := path_container_index.path_container_index + path_container_index.path_length - 1;

    file_ref_p := NIL;

    FOR i := first_path_index TO last_path_index DO
      rap$add_name_to_path_ref (file_ref_p, path_container_p^ [i], sequence_p, new_file_ref_p);
      PUSH file_ref_p: [#SIZE (new_file_ref_p^)];
      file_ref_p^ := new_file_ref_p^;
    FOREND;

    NEXT ref_p: [#SIZE (file_ref_p^)] IN sequence_p;
    ref_p^ (1, * ) := file_ref_p^;
    ref_created := TRUE;

  PROCEND translate_path_container_to_ref;

?? TITLE := 'write_strings', EJECT ??

{ PURPOSE:
{   This procedure writes two strings to the output display.
{
{ DESIGN:
{   The two strings are combined into one string and a procedure
{   writes them to output.
{
{ NOTES:
{
{

  PROCEDURE write_strings
    (    string_a: string ( * );
         string_b: string ( * );
         continue_line: boolean;
     VAR display_control: clt$display_control);


    VAR
      ignore_status: ost$status,
      line: string (2 * fsc$max_path_size),
      line_size: integer;


    line := '';
    STRINGREP (line, line_size, string_a, string_b);

    IF continue_line THEN
      clp$put_partial_display (display_control, line (1, line_size), clc$no_trim, amc$continue,
            ignore_status);
    ELSE
      clp$put_partial_display (display_control, line (1, line_size), clc$no_trim, amc$terminate,
            ignore_status);
    IFEND;

  PROCEND write_strings;

?? TITLE := 'write_string_and_integer', EJECT ??

{ PURPOSE:
{   This procedure writes a string and a integer to the output display.
{
{ DESIGN:
{   The string and the integer are combined into one string and a procedure
{   writes them to output.
{
{ NOTES:
{
{

  PROCEDURE write_string_and_integer
    (    string_a: string ( * );
         integer_a: integer;
         continue_line: boolean;
     VAR display_control: clt$display_control);


    VAR
      ignore_status: ost$status,
      line_a: string (2 * fsc$max_path_size),
      line_b: string (2 * fsc$max_path_size),
      line_size_a: integer,
      line_size_b: integer;


    line_a := '';
    STRINGREP (line_a, line_size_a, integer_a);

    line_b := '';
    STRINGREP (line_b, line_size_b, string_a, line_a (2, line_size_a - 1));

    IF continue_line THEN
      clp$put_partial_display (display_control, line_b (1, line_size_b), clc$no_trim, amc$continue,
            ignore_status);
    ELSE
      clp$put_partial_display (display_control, line_b (1, line_size_b), clc$no_trim, amc$terminate,
            ignore_status);
    IFEND;

  PROCEND write_string_and_integer;

MODEND ram$display_sif;
*DECK DECK=RAM$DISPLAY_STATION EXPAND=TRUE
create_program_description (display_station, diss) l='$system.batch_device_support.osf$batch_device_support' ..
   sp=nfp$display_station dm=off
*DECK DECK=RAM$DISPLAY_SUBPRODUCT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'DEFINE_SUBPRODUCT Subutility: DISPLAY_SUBPRODUCT Subcommand.' ??
MODULE ram$display_subproduct;

{ PURPOSE:
{   This module displays the information for the subproduct that is
{   currently being defined.
{
{ DESIGN:
{   This module is an interface to the user inside DEFINE_SUBPRODUCT
{   and to the main display sequence module.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$subproduct_info_types
?? POP ??
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc rap$display_sif
*copyc rav$defs_scratch_segment
*copyc rav$pacs_catalog_ref_p
*copyc rav$subproduct_info_pointers

?? TITLE := 'rap$display_subproduct', EJECT ??

{ PURPOSE:
{   This procedure displays the information for the subproduct that is
{   currently being defined.
{
{ DESIGN:
{   The SIF sequence in memory is passed to the main display sequence procedure.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$display_subproduct
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt display_subproduct (
{   display_options, display_option, do : list of key subproduct_attributes, sa, element_list, el, all, a = ..
{                                         subproduct_attributes
{   display_hidden_values               : boolean = false
{   output, o                           : file = $output
{   status                              : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    display_subproduct: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^display_subproduct_names,
      ^display_subproduct_params];

  VAR
    display_subproduct_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
      clt$parameter_name_descriptor := [['DISPLAY_OPTIONS', 1], ['DISPLAY_OPTION', 1], ['DO', 1], [
      'DISPLAY_HIDDEN_VALUES', 2], ['OUTPUT', 3], ['O', 3], ['STATUS', 4]];

  VAR
    display_subproduct_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor
      := [

{ DISPLAY_OPTIONS DISPLAY_OPTION DO }
    [[clc$optional_with_default, ^display_subproduct_dv1], 1, clc$max_value_sets,1, 1,
      clc$value_range_not_allowed, [^display_subproduct_kv1, clc$keyword_value]],

{ DISPLAY_HIDDEN_VALUES }
    [[clc$optional_with_default, ^display_subproduct_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$boolean_value]],

{ OUTPUT O }
    [[clc$optional_with_default, ^display_subproduct_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    display_subproduct_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of ost$name := [
      'SUBPRODUCT_ATTRIBUTES','SA','ELEMENT_LIST','EL','ALL','A'];

  VAR
    display_subproduct_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (21) := 'subproduct_attributes';

  VAR
    display_subproduct_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';

  VAR
    display_subproduct_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$output';

?? POP ??


    clp$scan_parameter_list (parameter_list, display_subproduct, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$display_sif (rav$subproduct_info_pointers, rav$pacs_catalog_ref_p,
          rav$defs_scratch_segment.sequence_p, status);

  PROCEND rap$display_subproduct;

MODEND ram$display_subproduct;
*DECK DECK=RAM$DISPLAY_SUBPRODUCT_INFO EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: DISPLAY_SUBPRODUCT_INFORMATION Subcommand.' ??
MODULE ram$display_subproduct_info;

{
{ PURPOSE:
{   This command interface displays the information on a SIF file.
{
{ DESIGN:
{   This module is an interface to the user inside PACKAGE_SOFTWARE
{   and to the main display sequence module.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{
{

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$sif_file_name
*copyc rae$package_software_cc
*copyc amt$segment_pointer
*copyc ost$status
*copyc pmt$condition
*copyc rat$subproduct_info_pointers
?? POP ??
*copyc amp$get_segment_pointer
*copyc clp$get_path_name
*copyc clp$scan_parameter_list
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc rap$add_name_to_path_ref
*copyc rap$display_sif
*copyc rap$get_file_path_and_ref
*copyc rap$get_sif_pointers
*copyc rap$open_file
*copyc rav$pacs_scratch_segment

?? TITLE := '[XDCL] rap$display_subproduct_info', EJECT ??

{ PURPOSE:
{   This procedure displays the information from a specified SIF file.
{
{ DESIGN:
{   The SIF file is opened and passed to the main display sequence procedure.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$display_subproduct_info
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt display_subproduct_info (
{   pacs_catalog, pc                    : file = $required
{   display_options, display_option, do : list of key subproduct_attributes, sa, element_list, el, all, a ..
{                                         = subproduct_attributes
{   display_hidden_values               : boolean = false
{   output, o                           : file = $output
{   status                              : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      display_subproduct_info: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^display_subproduct_info_names, ^display_subproduct_info_params];

    VAR
      display_subproduct_info_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 9] of
            clt$parameter_name_descriptor := [['PACS_CATALOG', 1], ['PC', 1], ['DISPLAY_OPTIONS', 2],
            ['DISPLAY_OPTION', 2], ['DO', 2], ['DISPLAY_HIDDEN_VALUES', 3], ['OUTPUT', 4], ['O', 4],
            ['STATUS', 5]];

    VAR
      display_subproduct_info_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of
            clt$parameter_descriptor := [

{ PACS_CATALOG PC }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ DISPLAY_OPTIONS DISPLAY_OPTION DO }
      [[clc$optional_with_default, ^display_subproduct_info_dv2], 1, clc$max_value_sets, 1, 1,
            clc$value_range_not_allowed, [^display_subproduct_info_kv2, clc$keyword_value]],

{ DISPLAY_HIDDEN_VALUES }
      [[clc$optional_with_default, ^display_subproduct_info_dv3], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$boolean_value]],

{ OUTPUT O }
      [[clc$optional_with_default, ^display_subproduct_info_dv4], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      display_subproduct_info_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
            ost$name := ['SUBPRODUCT_ATTRIBUTES', 'SA', 'ELEMENT_LIST', 'EL', 'ALL', 'A'];

    VAR
      display_subproduct_info_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (21) :=
            'subproduct_attrib' CAT 'utes';

    VAR
      display_subproduct_info_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'false';

    VAR
      display_subproduct_info_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$output';

?? POP ??


    VAR
      file_id: amt$file_identifier,
      file_opened: boolean,
      ignore_status: ost$status,
      mmt_seg_p: mmt$segment_pointer,
      new_path_ref_p: ^fst$file_reference,
      path_p: ^pft$path,
      path_ref_p: ^fst$file_reference,
      read_only_attachment: array [1 .. 2] of fst$attachment_option,
      seg_p: amt$segment_pointer,
      subproduct_seq_p: rat$subproduct_info_pointers;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the file has been opened, it will be closed before the
{   the procedure returns.
{
{ NOTES:
{
{
    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF file_opened THEN
        fsp$close_file (file_id, ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    file_opened := FALSE;

    clp$scan_parameter_list (parameter_list, display_subproduct_info, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$get_file_path_and_ref ('PACS_CATALOG', rav$pacs_scratch_segment.sequence_p, path_p, path_ref_p,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$add_name_to_path_ref (path_ref_p, rac$sif_file_name, rav$pacs_scratch_segment.sequence_p,
          new_path_ref_p);

    rap$open_file (new_path_ref_p, amc$segment, fsc$read, FALSE, NIL, file_id, file_opened, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      amp$get_segment_pointer (file_id, amc$sequence_pointer, seg_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      mmt_seg_p.seq_pointer := NIL;
      rap$get_sif_pointers (seg_p, mmt_seg_p, new_path_ref_p, subproduct_seq_p, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$display_sif (subproduct_seq_p, NIL, rav$pacs_scratch_segment.sequence_p, status);

    END /main/;

    fsp$close_file (file_id, ignore_status);
    osp$disestablish_cond_handler;

  PROCEND rap$display_subproduct_info;

MODEND ram$display_subproduct_info;
*DECK DECK=RAM$DISPLAY_SUMMARY_ERRORS EXPAND=TRUE
PROC display_summary_errors (
  listing, l : file = $required
  output, o  : file = $output
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"     The purpose of this procedure is to display the summary status errors from a
"RESTORE_PERMANENT_FILES listing.  This procedure is called by INSTALL_REQUIRED_FILES.
"The LISTING file is assumed to be a $LOCAL file.
*IFEND


  create_variable number_of_lines kind=integer value=100

  create_variable append_count kind=integer value=2
  create_variable append_line kind=boolean value=false
  create_variable ignore_status kind=status
  create_variable lines kind=string dimension=number_of_lines
  create_variable lines_returned kind=integer value=0


  rewind_file $value(listing) status=ignore_status

  REPEAT

    accept_line v=lines $fname($string($value(listing))//'.$asis') lc=lines_returned

    FOR i = 1 TO lines_returned DO

      append_line = (append_line AND (lines(i) <> '') AND (append_count < 2))

      IF $scan_string('--ERROR' lines(i)) <> 0 THEN
        put_line lines(i) o=$fname($string($value(output))//'.$eoi')
        append_line = true
        append_count = 0

      ELSE
        IF append_line THEN
          put_line lines(i) o=$fname($string($value(output))//'.$eoi')
          append_count = append_count + 1
        IFEND
      IFEND

    FOREND

  UNTIL lines_returned < number_of_lines

  put_line ('  ',' --WARNING-- Above errors occurred during tape load.' ..
        ' The load errors encountered may be due to a bad tape device.') ..
        o=$fname($string($value(output))//'.$eoi')


PROCEND display_summary_errors
*DECK DECK=RAM$DISPLAY_SYSTEM_TASKS_STATUS EXPAND=TRUE
PROC display_system_tasks_status, display_system_task_status, dissts (
  output, o: file = $output
  status)

  display_task_status dump_broken_job output=$value(output)
  display_task_status rhoutput output=$value(output)
  display_task_status rhinput output=$value(output)
  display_task_status ifexec output=$value(output)
  display_task_status scl output=$value(output)
  display_task_status operator_display_manager output=$value(output)

PROCEND display_system_tasks_status
*DECK DECK=RAM$DISPLAY_TCPIP_STATIC_ROUTES EXPAND=TRUE
create_program_description name=(display_tcpip_static_routes, display_tcpip_static_route, distsr) ..
      l='$system.osf$system_library' sp=nap$display_tcpip_static_routes tel=warning lmo=none lm=$null dm=off

*DECK DECK=RAM$DISPLAY_TERMINAL_MODEL_PROC EXPAND=TRUE
PROCEDURE (tum$distm) display_terminal_model, display_terminal_models, ..
distm (
  terminal_model, tm: any of
      key
        all
      keyend
      string
      name
    anyend = $terminal_model
  output, o: file = $output
  display_option, display_options, do: key
      (name, names, n)
      (help, h)
    keyend = $optional
  library, l: file = $system.tdu.terminal_definitions
  status)

  "$FORMAT=OFF"
  VAR
    ign_status: status
    one_line_summary: boolean = false
    output_line: list of string
    prefix_string: string = ' '
    scratch: file = $unique(:$local)
    terminal_names: list 0..$max_list of string
  VAREND
  "$FORMAT=ON"

" Display HELP if requested or unspecified and one terminal model.

  IF ((NOT $specified(display_option)) AND (terminal_model <> 'ALL') AND ..
        (terminal_model <> '')) THEN
    IF ($job(mode) = 'INTERACTIVE') AND ..
          ($strrep($path(output last)) = '$OUTPUT') THEN
      prefix_string = ' HELP for '
    ELSE
      prefix_string = '1HELP for '
    IFEND
  ELSEIF ($specified(display_option)) AND (display_option = help) THEN
    IF ($job(mode) = 'INTERACTIVE') AND ..
          ($strrep($path(output last)) = '$OUTPUT') THEN
      prefix_string = ' HELP for '
    ELSE
      prefix_string = '1HELP for '
    IFEND
  IFEND

  PUSH command_list
  create_command_list_entry e=library status=ign_status

  IF (terminal_model = 'ALL') OR (terminal_model = '') THEN
    set_file_attributes f=scratch fc=legible pf=continuous
    display_object_library l=library do=none ao=yes o=scratch
    get_lines i=scratch v=terminal_names
    delete_file f=scratch
    terminal_names = $select(terminal_names (($size(x)>4) and (x(1 4)=..
'CSM$')))
  ELSE
    terminal_names = 'CSM$'//terminal_model
  IFEND

  IF prefix_string = ' ' THEN
    one_line_summary = true
  IFEND

  FOR EACH terminal IN terminal_names DO
    output_line = prefix_string//terminal(5 all)
    IF one_line_summary THEN
      IF $condition_code($name('CSE$'//terminal(5 all)))<> 0 THEN
        terminal_help = $status_message(..
              $status(false 'CS' $name('CSE$'//terminal(5 all))) 80 brief)
        output_line = $justify(output_line(1) 31 left) //..
$trim(terminal_help(1)(3 all) ' ' l)
        IF terminal_help(2)<>' ' THEN
          second_line = $trim(terminal_help(2) ' ' l)
          output_line = $join(output_line ..
                $justify(second_line $size(second_line)+31 right))
        IFEND
      ELSE
        output_line = $justify(output_line(1) 31 left) //..
'No documentation for terminal model'
      IFEND
    IFEND
    put_line l=output_line o=output.$eoi
    IF prefix_string <> ' ' THEN
      IF $condition_code($name('CSE$'//terminal(5 all)))<> 0 THEN
        put_lines l=$status_message(..
              $status(false 'CS' $name('CSE$'//terminal(5 all))) 80 brief) ..
              o=output.$eoi
      ELSE
        put_lines ..
              l=' No documentation for terminal model '//terminal(5 all) ..
              o=output.$eoi
      IFEND
    IFEND
  FOREND

PROCEND display_terminal_model
*DECK DECK=RAM$DISPLAY_TIME EXPAND=TRUE
PROCEDURE (ram$dist) display_time, dist (
  output, o: file = $output
  status)

" PURPOSE:
"   Converts the current time into word format and displays it to a file.
" DESIGN:
"   The displayed time is accurate to within five minutes.

  VAR
    hour_name: array 1 .. 12 of string
    sector_name: array 1 .. 12 of string
    time: string = $justify($time(ampm), 8, right)
    hour: integer = $integer(time(1, 2))
    minute: integer = $integer(time(4, 2))
    hour_string: (DEFER) string = hour_name(1 + $mod(hour+$integer(32<minute), 12))
    sector_string: (DEFER) string = sector_name(1 + $mod(minute/5+$integer($mod(minute, 5)>2), 12))
    the_time: string
  VAREND

  hour_name(1)='twelve'
  hour_name(2)='one'
  hour_name(3)='two'
  hour_name(4)='three'
  hour_name(5)='four'
  hour_name(6)='five'
  hour_name(7)='six'
  hour_name(8)='seven'
  hour_name(9)='eight'
  hour_name(10)='nine'
  hour_name(11)='ten'
  hour_name(12)='eleven'

  sector_name(1)='o''clock'
  sector_name(2)='five'
  sector_name(3)='ten'
  sector_name(4)='quarter'
  sector_name(5)='twenty'
  sector_name(6)='twenty-five'
  sector_name(7)='half'
  sector_name(8)='twenty-five'
  sector_name(9)='twenty'
  sector_name(10)='quarter'
  sector_name(11)='ten'
  sector_name(12)='five'

  IF sector_string = 'o''clock' THEN
    the_time=$char(bel)// hour_string // ' o''clock, and all''s well'
  ELSEIF minute > 32 THEN
    the_time = sector_string // ' to ' // hour_string
  ELSE
    the_time = sector_string // ' past ' // hour_string
  IFEND

  put_line line=' '//the_time output=output

PROCEND display_time
*DECK DECK=RAM$DISPLAY_USER_VALIDATION EXPAND=TRUE
PROCEDURE (ram$disuv) display_user_validation, disuv (
  output, o: file = $output
  status)

  ADMINISTER_VALIDATIONS
    display_user output= output
  END_ADMINISTER_VALIDATIONS

PROCEND display_user_validation
*DECK DECK=RAM$DISPLAY_VOL_CLASSIFICATION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := '  NOS/VE Display Volume Classification.' ??
MODULE ram$display_vol_classification;

{ PURPOSE:
{   This module contains the command processor for displaying a volume's
{   classification.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$label_validation_errors
*copyc fst$tape_label_block_descriptor
*copyc fst$tape_label_sequence_header
?? POP ??
*copyc clp$convert_string_to_file
*copyc clp$close_display
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc clp$new_display_line
*copyc clp$open_display
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc fsp$get_tape_label_attributes
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc rmp$disvc_r3_helper
*copyc rmp$format_vol_classification

*copyc amv$nil_file_identifier
*copyc clv$nil_display_control

?? NEWTITLE := 'rap$display_vol_classification', EJECT ??

  PROCEDURE [XDCL, #GATE] rap$display_vol_classification
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ram$disvc) display_volume_classification, disvc (
{   file, f: file = $required
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 6, 28, 1, 31, 24, 416],
    clc$command, 5, 3, 1, 0, 0, 0, 3, 'RAM$DISVC'], [
    ['F                              ',clc$abbreviation_entry, 1],
    ['FILE                           ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

?? NEWTITLE := '  abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF file_id <> amv$nil_file_identifier THEN
        fsp$close_file (file_id, ignore_status);
      IFEND;

      IF display_control.file_id <> amv$nil_file_identifier THEN
        clp$close_display (display_control, ignore_status);
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE ??
?? NEWTITLE := '  construct_message_line_array', EJECT ??

    PROCEDURE construct_message_line_array
      (    formatted_message: ost$status_message;
       VAR line_array: array [1 .. * ] of ^string ( * <= osc$status_message_width));

      VAR
        line_count_p: ^ost$status_message_line_count,
        line_number: ost$status_message_line_count,
        line_size_p: ^ost$status_message_line_size,
        message_p: ^ost$status_message;

      message_p := ^formatted_message;
      RESET message_p;

      NEXT line_count_p IN message_p;
      IF line_count_p <> NIL THEN
        FOR line_number := 1 TO line_count_p^ DO
          NEXT line_size_p IN message_p;
          NEXT line_array [line_number]: [line_size_p^] IN message_p;
        FOREND;
      IFEND;

    PROCEND construct_message_line_array;
?? OLDTITLE ??
?? NEWTITLE := '  get_line_count', EJECT ??

    PROCEDURE get_line_count
      (    formatted_message: ost$status_message;
       VAR line_count: ost$status_message_line_count);

      VAR
        line_count_p: ^ost$status_message_line_count,
        message_p: ^ost$status_message;

      message_p := ^formatted_message;
      RESET message_p;

      NEXT line_count_p IN message_p;
      IF line_count_p <> NIL THEN
        line_count := line_count_p^;
      ELSE
        line_count := 0;
      IFEND;
    PROCEND get_line_count;
?? OLDTITLE ??
?? NEWTITLE := '  new_page_procedure', EJECT ??

    PROCEDURE new_page_procedure
      (VAR display_control: clt$display_control;
           new_page_number: integer;
       VAR status: ost$status);

      clp$reset_for_next_display_page (display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_display (display_control, 'Display_volume_classification ', clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$new_display_line (display_control, 1, status);

    PROCEND new_page_procedure;
?? OLDTITLE, EJECT ??

    CONST
      aasm = 1,
      adc = 2,
      fsp = 3;

    VAR
      attachment_options: array [aasm .. fsp] of fst$attachment_option,
      display_control: clt$display_control,
      evaluated_file_reference: fst$evaluated_file_reference,
      file_id: amt$file_identifier,
      formatted_classification: ost$status_message,
      formatted_message: ^array [1 .. * ] of ^string ( * <= osc$status_message_width),
      i: ost$status_message_line_count,
      line: ost$status_message_line_count,
      line_count: ost$status_message_line_count,
      local_status: ost$status,
      output_file: clt$file,
      volume_classification: rmt$tape_volume_classification;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    attachment_options [aasm].selector := fsc$access_and_share_modes;
    attachment_options [aasm].access_modes.selector := fsc$specific_access_modes;
    attachment_options [aasm].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_options [aasm].share_modes.selector := fsc$determine_from_access_modes;
    attachment_options [adc].selector := fsc$allowed_device_classes;
    attachment_options [adc].allowed_device_classes := $fst$device_classes [fsc$magnetic_tape_device];
    attachment_options [fsp].selector := fsc$tape_attachment;
    attachment_options [fsp].tape_attachment.selector := fsc$tape_file_set_position;
    attachment_options [fsp].tape_attachment.tape_file_set_position.position := fsc$tape_beginning_of_set;

    file_id := amv$nil_file_identifier;
    display_control := clv$nil_display_control;
    #SPOIL (display_control);
    osp$establish_block_exit_hndlr (^abort_handler);

  /classify_volume/
    BEGIN
      clp$evaluate_file_reference (pvt [p$file].value^.file_value^, $clt$file_ref_parsing_options [],
            {resolve_cycle_number} FALSE, evaluated_file_reference, status);

      IF status.normal THEN
        fsp$open_file (pvt [p$file].value^.file_value^, amc$record, ^attachment_options, NIL, NIL, NIL, NIL,
              file_id, local_status);
        IF local_status.normal THEN
          fsp$close_file (file_id, status);
          IF NOT status.normal THEN
            EXIT /classify_volume/;
          IFEND;
        ELSE
          CASE local_status.condition OF
          = ame$excessive_tape_labels, ame$invalid_tape_label, ame$unexpected_tapemark,
            ame$unexpected_tape_label, ame$tape_label_read_error, ame$ansi_file_unexpired, ame$unknown_volume,
            ame$volume_access_restricted, ame$improper_security_change, ame$insufficient_volume_access,
            ame$unlabeled_privilege_needed, ame$rma_privilege_required, ame$label_not_in_sequence,
            ame$blank_volume_read =
            ;
          ELSE
            status := local_status;
            EXIT /classify_volume/;
          CASEND;
        IFEND;

        rmp$disvc_r3_helper (evaluated_file_reference, volume_classification, status);

        IF status.normal THEN
          clp$convert_string_to_file (pvt [p$output].value^.file_value^, output_file, status);
          IF NOT status.normal THEN
            EXIT /classify_volume/;
          IFEND;

          clp$open_display (output_file, ^new_page_procedure, display_control, status);
          IF NOT status.normal THEN
            EXIT /classify_volume/;
          IFEND;

          rmp$format_vol_classification (display_control.page_width, volume_classification,
                formatted_classification, status);

          IF status.normal THEN

            get_line_count (formatted_classification, line_count);

            IF line_count > 0 THEN
              push formatted_message: [1 .. line_count];
              construct_message_line_array (formatted_classification, formatted_message^);

            /non_blank_line/
              FOR i := line_count DOWNTO 1 DO
                IF formatted_message^ [i]^ <> ' ' THEN
                  EXIT /non_blank_line/;
                IFEND;
              FOREND /non_blank_line/;

              FOR line := 1 TO i DO
                clp$put_display (display_control, formatted_message^ [line]^, clc$trim, status);
              FOREND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    END /classify_volume/;

    IF display_control.file_id <> amv$nil_file_identifier THEN
      clp$close_display (display_control, local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND rap$display_vol_classification;
MODEND ram$display_vol_classification;
*DECK DECK=RAM$DISPLAY_WORKING_CATALOG EXPAND=TRUE
PROC display_working_catalog, diswc (
  output, o : file = $output
  status    : var of status = $optional
  )

  display_value v=$catalog o=$value(o)

PROCEND display_working_catalog
*DECK DECK=RAM$DISPROC EXPAND=TRUE
.PROC,DISPROC*I,
P "- Procedure name (or ALL or *)"     = (*N=*,ALL=*,*,*F),
L "- Library file name"                = (*N=#FILE,*F),
UN "- User Name containing library"    = (*N=,*F),
O "- Output file name"                 = (*N=OUTPUT,*F),
DO "- Display option"                  = (*N=BRIEF,B=BRIEF,BRIEF,F=FULL,FULL,D),
.
.HELP
 The DISPROC procedure DISplays PROCedure record names contained on
 a library file. Requires CATALOG binaries with GENCAT entry point.

 Parameter   Default   Description
   Name       Value

  [p]                  procedure name to display (or ALL or *)
  [l]                  library file to display
  [un]                 user name in which library resides
  [o]        OUTPUT    file to which library content is displayed
  [do]         b       display option for library display

.HELP,P
 The P parameter names the procedure to display from a library file.
 By default all procedures are displayed.
.HELP,L
 The L parameter names a file from which procedure record names are
 displayed. The default value is the file containing this procedure.
.HELP,UN
 The UN parameter specifies the User Name location of the file.
 The default value is the User Name in which this procedure executes.
.HELP,O
 The O parameter names a file to which library content is displayed.
 The default value is OUTPUT.
.HELP,DO
 The DO parameter specifies the display option to use.
 Options are:  B | BRIEF  - for brief display (default value)
          or   F | FULL   - full display
          or   D  - for directive display (LIBEDIT directives)
.ENDHELP
$REVERT,EX.DISLIB,P,PROC,L,UN,O,DO.
/EOR
*DECK DECK=RAM$DISTEXT EXPAND=TRUE
.PROC,DISTEXT*I,
T "- Text record name (or ALL or *)"   = (*N=*,ALL=*,*,*F),
L "- Library file name"                = (*N=#FILE,*F),
UN "- User Name containing library"    = (*N=,*F),
O "- Output file name"                 = (*N=OUTPUT,*F),
DO "- Display option"                  = (*N=BRIEF,BREIF,B=BRIEF,FULL,F=FULL,D),
.
.HELP
 The DISTEXT procedure DISplays the names of TEXT records contained
 on a library file. Requires CATALOG binaries with GENCAT entry point.

 Parameter   Default   Description
   Name       Value

  [t]                  TEXT record name to display (or ALL or *)
  [l]                  library file to display
  [un]                 user name in which library resides
  [o]        OUTPUT    file to which library content is displayed
  [do]         b       display option for library display

.HELP,T
 The T parameter names the TEXT record to display from a library file.
 By default all TEXT records are displayed.
.HELP,L
 The L parameter names a file from which TEXT record names are
 displayed. The default value is the file containing this procedure.
.HELP,UN
 The UN parameter specifies the User Name location of the file.
 The default value is the User Name in which this procedure executes.
.HELP,O
 The O parameter names a file to which library content is displayed.
 The default value is OUTPUT.
.HELP,DO
 The DO parameter specifies the display option to use.
 Options are:  B | BRIEF  - for brief display (default value)
          or   F | FULL   - full display
          or   D  - for directive display (LIBEDIT directives)
.ENDHELP
$REVERT,EX.DISLIB,T,TEXT,L,UN,O,DO.
/EOR
*DECK DECK=RAM$DUPLICATE_LABELED_VOLUME EXPAND=TRUE
PROCEDURE (ram$duplv) duplicate_labeled_volume, duplv (
  input_volume, iv: record
      recorded_vsn: any of
        name 1..6
        string 1..6
      anyend
      external_vsn: any of
        name 1..6
        string 1..6
      anyend = $optional
    recend = $required
  output_volume, ov: record
      recorded_vsn: any of
        name 1..6
        string 1..6
      anyend
      external_vsn: any of
        name 1..6
        string 1..6
      anyend = $optional
    recend = $required
  expiration_date, ed: (BY_NAME) any of
    key
      $unspecified
      (expired, e)
    keyend
    date
    time_increment
  anyend = $optional
  file_accessibility, fa: (BY_NAME, SECURE) any of
      key
        none
      keyend
      name 1..1
      string 1
    anyend = $optional
  file_set_identifier, fsi: (BY_NAME) any of
      name 1..6
      string 1..6
    anyend = $optional
  input_density, id: (BY_NAME) key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = osd$reqmt_default_density, mt9$1600
  output_density, od: (BY_NAME) key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = $optional
  owner_identifier, oi: (BY_NAME, SECURE) any of
      key
        none
      keyend
      name 1..14
      string 1..14
    anyend = $optional
  removable_media_group, rmg: (BY_NAME, SECURE) any of
      name 1..13
    anyend = $optional
  volume_accessibility, va: (BY_NAME, SECURE) any of
      key
        none
      keyend
      name 1..1
      string 1
    anyend = $optional
  status)

  TYPE
    vol_descriptor = record
    recorded_vsn: any of
    name 1..6
    string 1..6
    anyend
    external_vsn: any of
    name 1..6
    string 1..6
    anyend
    recend
  TYPEND

  VAR
    ignore_status: status
    input: file = $unique($local)
    in_vol: vol_descriptor
    local_status: status
    output: file = $unique($local)
    out_vol: vol_descriptor
    parameter_names: list of key mt9$800, mt9$1600, mt9$6250, mt18$38000 keyend=
    (mt9$800, mt9$1600, mt9$6250, mt18$38000)
    parameter_values: list of integer 0..2147483647 = (0 0 0 0)
    temp: file = $unique($local)
  VAREND

  WHEN any_fault exit terminate DO
    delete_file input status= ignore_status
    delete_file output status= ignore_status
    delete_file temp status= ignore_status
    release_resource mt9$800=all mt9$1600=all mt9$6250=all mt18$38000=all ..
          status=ignore_status
    EXIT duplicate_labeled_volume WITH osv$status
  WHENEND

  in_vol.recorded_vsn = input_volume.recorded_vsn
  IF $field(input_volume external_vsn specified) THEN
    in_vol.external_vsn = input_volume.external_vsn
  ELSE
    in_vol.external_vsn = in_vol.recorded_vsn
  IFEND

  out_vol.recorded_vsn = output_volume.recorded_vsn
  IF $field(output_volume external_vsn specified) THEN
    out_vol.external_vsn = output_volume.external_vsn
  ELSE
    out_vol.external_vsn = out_vol.recorded_vsn
  IFEND

  request_magnetic_tape input density=input_density ..
        recorded_vsn=in_vol.recorded_vsn external_vsn=in_vol.external_vsn ..
        ring=no

  IF $specified(output_density) THEN
    request_magnetic_tape output density=output_density ..
          recorded_vsn=out_vol.recorded_vsn ..
          external_vsn=out_vol.external_vsn ring=yes
    local_output_density = output_density
  ELSE
    request_magnetic_tape output density=input_density ..
          recorded_vsn=out_vol.recorded_vsn ..
          external_vsn=out_vol.external_vsn ring=yes
    local_output_density = input_density
  IFEND

  FOR i = 1 TO $size(parameter_names) DO
    IF input_density = parameter_names(i) THEN
      parameter_values(i) = parameter_values(i) + 1
    IFEND
    IF local_output_density = parameter_names(i) THEN
      parameter_values(i) = parameter_values(i) + 1
    IFEND
  FOREND

  reserve_resource mt9$800=parameter_values(1) mt9$1600=parameter_values(2) ..
        mt9$6250=parameter_values(3) mt18$38000=parameter_values(4)

  change_tape_label_attributes input file_set_position=next_file ..
        file_accessibility= file_accessibility ..
        owner_identifier= owner_identifier ..
        volume_accessibility= volume_accessibility rewrite_labels= false

  change_tape_label_attributes output file_set_position=next_file ..
        expiration_date=expiration_date ..
        file_accessibility=file_accessibility ..
        file_set_identifier=file_set_identifier ..
        owner_identifier=owner_identifier ..
        removable_media_group=removable_media_group ..
        volume_accessibility=volume_accessibility rewrite_labels=true

  FOR i = 1 TO 9999 DO
    copy_file input temp status=local_status
    IF local_status.normal THEN
      input_attrib = $tape_label_attributes(input last_accessed block_type, ..
            character_conversion, character_set, creation_date, ..
            expiration_date, file_identifier, file_set_identifier, ..
            generation_number, generation_version_number, ..
            maximum_block_length, maximum_record_length, padding_character, ..
            record_type)

      change_tape_label_attributes output ..
            block_type=input_attrib.block_type ..
            character_conversion= input_attrib.character_conversion ..
            character_set= input_attrib.character_set ..
            creation_date= input_attrib.creation_date ..
            file_identifier= input_attrib.file_identifier ..
            generation_number= input_attrib.generation_number ..
            generation_version_number= input_attrib.generation_version_number ..
            maximum_block_length= input_attrib.maximum_block_length ..
            maximum_record_length= input_attrib.maximum_record_length ..
            padding_character= input_attrib.padding_character ..
            record_type= input_attrib.record_type

      IF NOT $specified(file_set_identifier) THEN
        change_tape_label_attributes output ..
              file_set_identifier= input_attrib.file_set_identifier
      IFEND

      IF NOT $specified(expiration_date) THEN
        change_tape_label_attributes output ..
              expiration_date= input_attrib.expiration_date
      IFEND

      copy_file temp output
      delete_file temp
      delete_variable input_attrib
    ELSE
      IF i > 1 THEN
        EXIT_PROC
      ELSE
        EXIT_PROC WITH local_status
      IFEND
    IFEND
  FOREND

PROCEND duplicate_labeled_volume
*DECK DECK=RAM$DUPLICATE_UNLABELED_VOLUME EXPAND=TRUE
PROCEDURE (ram$dupuv) duplicate_unlabeled_volume, dupuv (
  input_volume, iv: any of
      string 1..6
      name 1..6
    anyend = $required
  output_volume, ov: any of
      string 1..6
      name 1..6
    anyend = $required
  input_density, id: (BY_NAME) key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = osd$reqmt_default_density, mt9$1600
  output_density, od: (BY_NAME) key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = $optional
  status)

  VAR
    consecutive_tapemarks_read: integer 0..3
    ignore_status: status
    input: file = $unique($local)
    local_status: status
    output: file = $unique($local)
    parameter_names: list of key mt9$800, mt9$1600, mt9$6250, mt18$38000 keyend=
    (mt9$800, mt9$1600, mt9$6250, mt18$38000)
    parameter_values: list of integer 0..2147483647 = (0 0 0 0)
  VAREND

  WHEN any_fault exit terminate DO
    delete_file input status= ignore_status
    delete_file output status= ignore_status
    release_resource mt9$800=all mt9$1600=all mt9$6250=all mt18$38000=all ..
          status=ignore_status
    EXIT duplicate_unlabeled_volume WITH osv$status
  WHENEND

  request_magnetic_tape input density=input_density ..
        external_vsn=input_volume ring=no
  set_file_attributes input block_type=user_specified ..
        file_label_type=unlabeled record_type=undefined

  IF $specified(output_density) THEN
    request_magnetic_tape output density=output_density ..
          external_vsn=output_volume ring=yes
    local_output_density = output_density
  ELSE
    request_magnetic_tape output density=input_density ..
          external_vsn=output_volume ring=yes
    local_output_density = input_density
  IFEND

  set_file_attributes output block_type=user_specified ..
        file_label_type=unlabeled record_type=undefined

  FOR i = 1 TO $size(parameter_names) DO
    IF input_density = parameter_names(i) THEN
      parameter_values(i) = parameter_values(i) + 1
    IFEND
    IF local_output_density = parameter_names(i) THEN
      parameter_values(i) = parameter_values(i) + 1
    IFEND
  FOREND

  reserve_resource mt9$800=parameter_values(1) mt9$1600=parameter_values(2) ..
        mt9$6250=parameter_values(3) mt18$38000=parameter_values(4)

  consecutive_tapemarks_read = 0
  i = 0

  REPEAT
    IF i = 0 THEN
      copy_file input.$asis output.$boi status=local_status
    ELSE
      copy_file input.$asis output.$asis status=local_status
    IFEND
    IF local_status.normal THEN
      i = i+1
      consecutive_tapemarks_read = 1
      write_tape_mark output.$asis
    ELSEIF local_status.condition = ame$input_after_eoi THEN
      consecutive_tapemarks_read = consecutive_tapemarks_read + 1
      IF consecutive_tapemarks_read < 3 THEN
        write_tape_mark output.$asis status=local_status
      IFEND
    IFEND
  UNTIL NOT local_status.normal

  IF i > 1 THEN
    EXIT_PROC
  ELSE
    EXIT_PROC WITH local_status
  IFEND

PROCEND duplicate_unlabeled_volume
*DECK DECK=RAM$EDICAT EXPAND=TRUE
.PROC,EDICAT*I,
N "- Name of CATALOG entry point"      = (*N=GENCAT,*F)
.
.HELP
 The EDICAT procedure EDIts the entry point name of the CATALOG
 binaries to make it different than the standard NOS entry point.

 Parameter   Default   Description
   Name       Value

  [n]        gencat    entry point name for CATALOG binary

.HELP,N
 The N parameter names the entry point to be used for the CATALOG
 binaries. The default value is GENCAT. You must change the GENCAT
 name in the DISLIB procedure if you change this entry point.

.ENDHELP
$NOTE,OUTPUT,NR.+ CHANGING CATALOG ENTRY POINT TO N
GETLIB,CATALOG,T=ABS,G=TAPE1.
$CATALOG,TAPE1,R.
FTN5,I,L=0,GO.
$RENAME,N=TAPE1.
$CATALOG,N,R.
$UNLOAD,LGO,COMPILE.
REPLIB,N.
$SKIP,NOERROR.
  $EXIT.
  $UNLOAD,CATALOG.
  $REVERT,ABORT. ENTRY POINT NOT CHANGED
$ENDIF,NOERROR.
$REVERT. N --> NVELIB
.DATA,COMPILE
      PROGRAM BINEDT
      INTEGER RECRD(3000),ORD,RECLEN
      BUFFER IN (1,1) (RECRD(1),RECRD(3000))
      ORD=O"20"+1
      RECRD(ORD)=L"N".OR.(RECRD(ORD).AND.O"777777")
      IF (UNIT(1))3,5,5
3     CONTINUE
      REWIND 1
      RECLEN=LENGTH(1)
      BUFFER OUT(1,1) (RECRD(1),RECRD(RECLEN))
5     CONTINUE
      STOP
      END
/EOR
*DECK DECK=RAM$ESTABLISH_DIRECTORY_PTRS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$ESTABLISH_DIRECTORY_PTRS Interface.' ??
MODULE ram$establish_directory_ptrs;

{ PURPOSE:
{   This module contains the interface and procedures that establishes
{   the directory pointers within a directory sequence.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$install_software_cc
*copyc rac$idb_directory_level
*copyc rac$idb_directory_name
*copyc rac$inss_processor_version
*copyc rat$idb_directory_pointers
*copyc rat$installation_control_record
*copyc rat$path
*copyc rat$sequence_descriptor_types
?? POP ??
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pmp$get_legible_date_time
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$establish_directory_ptrs', EJECT ??

{ PURPOSE:
{   This interface establishes the pointers to the directory
{   components.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$establish_directory_ptrs
    (    installation_database: rat$path;
     VAR directory_pointers {input} : rat$idb_directory_pointers;
     VAR status: ost$status);


    VAR
      ignore_status: ost$status,
      local_status: ost$status;


    status.normal := TRUE;

    RESET directory_pointers.sequence_p;
    NEXT directory_pointers.sequence_descriptor_p IN directory_pointers.sequence_p;
    IF directory_pointers.sequence_descriptor_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$unexpected_eof_directory, rac$idb_directory_name, status);
      osp$append_status_file (osc$status_parameter_delimiter, installation_database.
            path (1, installation_database.size), status);
      RETURN;
    IFEND;

    IF directory_pointers.sequence_descriptor_p^.sequence_type <> rac$idb_directory_sequence THEN
      osp$set_status_abnormal ('RA', rae$invalid_idb_directory, rac$idb_directory_name, status);
      osp$append_status_file (osc$status_parameter_delimiter, installation_database.
            path (1, installation_database.size), status);
      RETURN;
    IFEND;

    IF directory_pointers.sequence_descriptor_p^.sequence_level <> rac$idb_directory_level THEN
      osp$set_status_abnormal ('RA', rae$incompatible_sequence_level, 'IDB directory', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            directory_pointers.sequence_descriptor_p^.sequence_level, status);
      RETURN;
    IFEND;

    IF directory_pointers.sequence_descriptor_p^.processor_version <> rac$inss_processor_version THEN
      osp$set_status_abnormal ('RA', rae$different_processor_version, 'IDB directory', local_status);
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
    IFEND;

    NEXT directory_pointers.header_p IN directory_pointers.sequence_p;
    IF directory_pointers.header_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$unexpected_eof_directory, rac$idb_directory_name, status);
      osp$append_status_file (osc$status_parameter_delimiter, installation_database.
            path (1, installation_database.size), status);
      RETURN;
    IFEND;


    IF directory_pointers.header_p^.directory_size = 0 THEN
      { This is required to establish the directory records pointer.
      directory_pointers.directory_p := #PTR (directory_pointers.header_p^.directory_rel_p,
            directory_pointers.sequence_p^);
    ELSE
      { This is required to move the current sequence position to directory EOI.}
      NEXT directory_pointers.directory_p: [1..directory_pointers.header_p^.directory_size] IN
            directory_pointers.sequence_p;
      IF directory_pointers.header_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$unexpected_eof_directory, rac$idb_directory_name, status);
        osp$append_status_file (osc$status_parameter_delimiter, installation_database.
              path (1, installation_database.size), status);
        RETURN;
      IFEND;
    IFEND;

  PROCEND rap$establish_directory_ptrs;

MODEND ram$establish_directory_ptrs;
*DECK DECK=RAM$ESTABLISH_ICR_PACKLIST_PTRS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$ESTABLISH_ICR_PACKLIST_PTRS interface.' ??
MODULE ram$establish_icr_packlist_ptrs;

{ PURPOSE:
{   This module contains the interface that establishes the installation
{   control record's packing list pointers.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$install_software_cc
*copyc rac$control_job_identifier
*copyc rac$packing_list_level
*copyc rac$pacs_processor_version
*copyc rat$installation_control_record
*copyc rat$packing_list_sequence
*copyc rat$sequence_descriptor_types
?? POP ??
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$establish_icr_packlist_ptrs', EJECT ??

{ PURPOSE:
{   This interface establishes the pointers to the major data structures in
{   the packing list.  The pointers are registered in the installation
{   control record passed in.
{
{ DESIGN:
{   The packing list file was previously opened and a pointer to the packing
{   list sequence has albready been established (in the installation contol
{   record).  Using this pointer the major structures of a packing list are
{   established.  At this time the packing list is validated as a packing
{   list and to be at a compatable level to the processor reading it.
{
{   Validation errors are returned in the status variable.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$establish_icr_packlist_ptrs
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      ignore_status: ost$status,
      installation_database: rat$path,
      local_status: ost$status;


    status.normal := TRUE;
    installation_database := installation_control_record.processing_header_p^.installation_defaults.
          installation_database;

    RESET installation_control_record.packing_list_pointers.sequence_p;
    NEXT installation_control_record.packing_list_pointers.sequence_descriptor_p IN
          installation_control_record.packing_list_pointers.sequence_p;
    IF installation_control_record.packing_list_pointers.sequence_descriptor_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$unexpected_eof_packing_list,
            installation_control_record.processing_header_p^.packing_list_name, status);
      osp$append_status_file (osc$status_parameter_delimiter, installation_database.
            path (1, installation_database.size), status);
      RETURN;
    IFEND;

    IF installation_control_record.packing_list_pointers.sequence_descriptor_p^.sequence_type <>
          rac$packing_list_sequence THEN
      osp$set_status_abnormal ('RA', rae$invalid_packing_list,
            installation_control_record.processing_header_p^.packing_list_name, status);
      osp$append_status_file (osc$status_parameter_delimiter, installation_database.
            path (1, installation_database.size), status);
      RETURN;
    IFEND;

    IF installation_control_record.packing_list_pointers.sequence_descriptor_p^.sequence_level <>
          rac$packing_list_level THEN
      osp$set_status_abnormal ('RA', rae$incompatible_sequence_level, 'PACKING LIST', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            installation_control_record.packing_list_pointers.sequence_descriptor_p^.sequence_level, status);
      RETURN;
    IFEND;

    IF installation_control_record.packing_list_pointers.sequence_descriptor_p^.processor_version <>
          rac$pacs_processor_version THEN
      osp$set_status_abnormal ('RA', rae$different_processor_version, 'PACKING LIST', local_status);
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
    IFEND;

    NEXT installation_control_record.packing_list_pointers.header_p IN
          installation_control_record.packing_list_pointers.sequence_p;
    IF installation_control_record.packing_list_pointers.header_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$unexpected_eof_packing_list,
            installation_control_record.processing_header_p^.packing_list_name, status);
      osp$append_status_file (osc$status_parameter_delimiter, installation_database.
            path (1, installation_database.size), status);
      RETURN;
    IFEND;

    installation_control_record.packing_list_pointers.order_medium :=
          installation_control_record.packing_list_pointers.header_p^.order_medium;

    IF installation_control_record.packing_list_pointers.order_medium = rac$tape THEN

      installation_control_record.packing_list_pointers.tape_subproduct_indexer_p :=
            #PTR (installation_control_record.packing_list_pointers.header_p^.tape_subproduct_indexer_p,
            installation_control_record.packing_list_pointers.sequence_p^);

      installation_control_record.packing_list_pointers.tape_vsns_p :=
            #PTR (installation_control_record.packing_list_pointers.header_p^.tape_vsns_p,
            installation_control_record.packing_list_pointers.sequence_p^);

    ELSE { order medium = rac$disk }

      installation_control_record.packing_list_pointers.disk_subproduct_indexer_p :=
            #PTR (installation_control_record.packing_list_pointers.header_p^.disk_subproduct_indexer_p,
            installation_control_record.packing_list_pointers.sequence_p^);

    IFEND;

  PROCEND rap$establish_icr_packlist_ptrs;

MODEND ram$establish_icr_packlist_ptrs;
*DECK DECK=RAM$ESTABLISH_ICR_SUBP_PTRS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$ESTABLISH_ICR_SUBP_PTRS Interface.' ??
MODULE ram$establish_icr_subp_ptrs;

{ PURPOSE:
{   This module contains the interface that establishes the installation
{   control record's subproduct pointers.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$install_software_cc
*copyc rac$control_job_identifier
*copyc rac$packing_list_level
*copyc rac$pacs_processor_version
*copyc rat$installation_control_record
*copyc rat$packing_list_sequence
*copyc rat$sequence_descriptor_types
?? POP ??
*copyc osp$append_status_file
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$establish_icr_subp_ptrs', EJECT ??

{ PURPOSE:
{   This interface establishes the pointers to the major data structures of
{   each subproduct info sequence within the packing list.  The pointers are
{   registered in the installation control record.
{
{ DESIGN:
{   The installation control record contains an array of subproduct
{   processing records.  Each subproduct processing record contains a record
{   for real pointers to that subproduct's major information data structures
{   within the packing list.  The subproduct information inside the packing
{   list must be established as its own sequence since all the relative
{   pointers found in the subproduct information data structures are
{   relative to the subproduct information as a sequence.
{
{   The pointer to the subproduct's installation catalog is estabished from
{   the relative pointer stored in the installation control record.  In some
{   instances the installation catalog has not yet been assigned, but the
{   relative pointer has been initialized to NIL.  This means the real
{   pointer is NIL as well.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$establish_icr_subp_ptrs
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      i: rat$subproduct_count,
      installation_database: rat$path,
      packing_list_seq_p: ^rat$packing_list_sequence,
      subproduct_pointers: rat$subproduct_info_pointers,
      subproduct_seq_length: amt$file_length,
      subproduct_seq_p: ^cell;


    status.normal := TRUE;
    installation_database := installation_control_record.processing_header_p^.installation_defaults.
          installation_database;
    packing_list_seq_p := installation_control_record.packing_list_pointers.sequence_p;

    FOR i := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^) DO

      IF (installation_control_record.job_identifier = rac$control_job_identifier) OR
            (installation_control_record.job_identifier = installation_control_record.
            subproduct_processing_records_p^ [i].job_identifier) THEN

        { Locate the start of the subproduct info within the packing list.

        IF installation_control_record.packing_list_pointers.order_medium = rac$tape THEN
          subproduct_seq_length := installation_control_record.packing_list_pointers.
                tape_subproduct_indexer_p^ [i].subproduct_seq_length;
          subproduct_seq_p := #PTR (installation_control_record.packing_list_pointers.
                tape_subproduct_indexer_p^ [i].subproduct_seq_p, packing_list_seq_p^);
        ELSE {order medium = rac$disk}
          subproduct_seq_length := installation_control_record.packing_list_pointers.
                disk_subproduct_indexer_p^ [i].subproduct_seq_length;
          subproduct_seq_p := #PTR (installation_control_record.packing_list_pointers.
                disk_subproduct_indexer_p^ [i].subproduct_seq_p, packing_list_seq_p^);
        IFEND;

        RESET packing_list_seq_p TO subproduct_seq_p;

        { Establish the subproduct info as an accessable sequence.

        NEXT subproduct_pointers.subproduct_info_seq_p: [[REP subproduct_seq_length OF cell]] IN
              packing_list_seq_p;
        IF subproduct_pointers.subproduct_info_seq_p = NIL THEN
          osp$set_status_abnormal ('RA', rae$unexpected_eof_packing_list,
                installation_control_record.processing_header_p^.packing_list_name, status);
          osp$append_status_file (osc$status_parameter_delimiter, installation_database.
                path (1, installation_database.size), status);
          RETURN;
        IFEND;

        RESET packing_list_seq_p TO subproduct_seq_p;

        { Establish pointers to the major components in the subproduct info sequence.
        { (See notes section above for maintenance tip.)

        NEXT subproduct_pointers.sequence_descriptor_p IN packing_list_seq_p;
        IF subproduct_pointers.sequence_descriptor_p = NIL THEN
          osp$set_status_abnormal ('RA', rae$unexpected_eof_packing_list,
                installation_control_record.processing_header_p^.packing_list_name, status);
          osp$append_status_file (osc$status_parameter_delimiter, installation_database.
                path (1, installation_database.size), status);
          RETURN;
        IFEND;

        NEXT subproduct_pointers.info_header_p IN packing_list_seq_p;
        IF subproduct_pointers.info_header_p = NIL THEN
          osp$set_status_abnormal ('RA', rae$unexpected_eof_packing_list,
                installation_control_record.processing_header_p^.packing_list_name, status);
          osp$append_status_file (osc$status_parameter_delimiter, installation_database.
                path (1, installation_database.size), status);
          RETURN;
        IFEND;

        subproduct_pointers.attributes_p := #PTR (subproduct_pointers.info_header_p^.attributes_p,
              subproduct_pointers.subproduct_info_seq_p^);

        subproduct_pointers.element_list_p := #PTR (subproduct_pointers.info_header_p^.element_list_p,
              subproduct_pointers.subproduct_info_seq_p^);

        subproduct_pointers.path_container_p := #PTR (subproduct_pointers.info_header_p^.path_container_p,
              subproduct_pointers.subproduct_info_seq_p^);

        subproduct_pointers.psrs_answered_p := #PTR (subproduct_pointers.info_header_p^.psrs_answered_p,
              subproduct_pointers.subproduct_info_seq_p^);

        { Assign the values for the subproduct info pointers just created to the installation control record.

        installation_control_record.subproduct_processing_records_p^ [i].subproduct_info_pointers :=
              subproduct_pointers;

        { Establish the pointer to the subproduct's installation catalog.

        installation_control_record.subproduct_processing_records_p^ [i].
              installation_catalog_p := #PTR (installation_control_record.
              subproduct_processing_records_p^ [i].installation_catalog_rel_p,
              installation_control_record.processing_seq_p^);

      IFEND;
    FOREND;

  PROCEND rap$establish_icr_subp_ptrs;

MODEND ram$establish_icr_subp_ptrs;
*DECK DECK=RAM$ESTABLISH_PROCESSING_CNTRLS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$ESTABLISH_PROCESSING_CNTRLS Interface.' ??
MODULE ram$establish_processing_cntrls;

{ PURPOSE:
{   This module contains the interface and procedures that establish
{   processing controls.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$command_log_name
*copyc rac$inss_processor_version
*copyc rac$summary_file_level
*copyc rac$summary_file_name
*copyc rae$install_software_cc
*copyc rat$installation_control_record
*copyc rat$processing_summary_types
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pmp$get_compact_date_time
*copyc rap$assign_install_identifier
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    job_record = record
      identifier: rat$job_identifier,
      log_file_name: ost$name,
      subproduct_count: rat$subproduct_count,
    recend,

    rat#job_list = record
      length: rat$job_count,
      records_p: ^array [ * ] of job_record,
    recend;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$establish_processing_cntrls', EJECT ??

{ PURPOSE:
{   This interface establishes the controls required for processing an
{   installation event.
{
{ DESIGN:
{   An installation identifier is assigned to the installation event and the
{   installation identifier catalog is created.  The number of jobs required
{   for processing are calculated and job identifiers and log file names are
{   assigned.  The processing summary file and the job processing records
{   are established base on the number of jobs required.
{
{   The distinction between a job status record (found in the processing
{   summary file) and a job processing record is that the job status record
{   is used to register current processing status for the job and the job
{   processing record is used in setting up the job to be executed.
{
{   The job list is a temporary variable to collect information needed in
{   creating the processing summary file and the job processing records.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$establish_processing_cntrls
    (    multiple_job_processing: boolean;
         execute_in_job_of_caller: boolean;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);

    VAR
      job_list: rat#job_list;


    status.normal := TRUE;

    rap$assign_install_identifier (installation_control_record.processing_header_p^.installation_command,
          installation_control_record.processing_header_p^.installation_defaults.installation_logs,
          installation_control_record.processing_header_p^.packing_list_name,
          installation_control_record.processing_header_p^.installation_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    job_list.length := 0;
    PUSH job_list.records_p: [1 .. UPPERBOUND (installation_control_record.medium_processing_records_p^)];

    assign_job_identifiers (multiple_job_processing, execute_in_job_of_caller, installation_control_record,
          job_list, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_processing_summary_file (job_list, installation_control_record, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    establish_job_processing_recds (job_list, installation_control_record, status);

  PROCEND rap$establish_processing_cntrls;

?? OLDTITLE ??
?? NEWTITLE := 'assign_job_identifiers', EJECT ??

{ PURPOSE:
{   This procedure determines the number of jobs required to perform the
{   installation event and creates job identifiers for each job.
{
{ DESIGN:
{   The job identifier was orignally set as a null name in all of the medium
{   and subproduct processing records.
{
{   Only tape orders can be processed using multiple jobs, a job per tape.
{   When multiple jobs are being defined, the log file is named by taking
{   the string 'JOB_LOG_VSN_' and appending the vsn for the tape associated
{   with the job.
{
{   When a single job is being defined and processing is to take place in
{   job of caller, the log file will be the command log.  Otherwise, when
{   not in job of caller the string 'JOB_LOG' is used.
{
{ NOTES:
{   The current job's identifier is updated to the assigned job identifier
{   when single job processing is true.  Under current design it will be
{   the job to carry on the rest of the processing.
{

  PROCEDURE assign_job_identifiers
    (    multiple_job_processing: boolean;
         execute_in_job_of_caller: boolean;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR job_list {input, output} : rat#job_list;
     VAR status: ost$status);


    VAR
      installation_identifier: rat$installation_identifier,
      job_identifier: rat$job_identifier,
      length: integer,
      log_file_name: ost$name,
      medium_index: rat$tape_count,
      subproduct_index: rat$subproduct_count,
      vsn: rmt$external_vsn;


    status.normal := TRUE;
    installation_identifier := installation_control_record.processing_header_p^.installation_identifier;

    IF NOT multiple_job_processing OR (installation_control_record.packing_list_pointers.order_medium =
          rac$disk) THEN

      { There will only be one job.  For tape orders the one job will load from all the tapes with
      { subproducts to install.

      job_identifier := installation_identifier;

      job_list.length := 1;
      job_list.records_p^ [job_list.length].identifier := job_identifier;
      IF execute_in_job_of_caller THEN
        job_list.records_p^ [job_list.length].log_file_name := rac$command_log_name;
      ELSE {batch processing}
        job_list.records_p^ [job_list.length].log_file_name := 'JOB_LOG';
      IFEND;

      job_list.records_p^ [job_list.length].subproduct_count := 0;

      FOR medium_index := 1 TO UPPERBOUND (installation_control_record.medium_processing_records_p^) DO
        IF installation_control_record.medium_processing_records_p^ [medium_index].subproduct_count > 0 THEN
          installation_control_record.medium_processing_records_p^ [medium_index].job_identifier :=
                job_identifier;

          job_list.records_p^ [job_list.length].subproduct_count :=
                job_list.records_p^ [job_list.length].subproduct_count +
                installation_control_record.medium_processing_records_p^ [medium_index].subproduct_count;

        IFEND;
      FOREND;

      installation_control_record.job_identifier := job_identifier;

    ELSE { medium is tape and multiple job processing allowed}

      { There will be one job for each tape with subproducts to install.

      FOR medium_index := 1 TO UPPERBOUND (installation_control_record.medium_processing_records_p^) DO
        IF installation_control_record.medium_processing_records_p^ [medium_index].subproduct_count > 0 THEN
          STRINGREP (job_identifier, length, installation_identifier
                (1, clp$trimmed_string_size (installation_identifier)), '_',
                installation_control_record.packing_list_pointers.tape_vsns_p^ [medium_index].external_vsn);
          installation_control_record.medium_processing_records_p^ [medium_index].job_identifier :=
                job_identifier (1, length);

          vsn := installation_control_record.packing_list_pointers.tape_vsns_p^ [medium_index].external_vsn;
          STRINGREP (log_file_name, length, 'JOB_LOG_VSN_', vsn (1, clp$trimmed_string_size (vsn)));

          job_list.length := job_list.length + 1; {length initialized to 0 when created}
          job_list.records_p^ [job_list.length].identifier := installation_control_record.
                medium_processing_records_p^ [medium_index].job_identifier;
          job_list.records_p^ [job_list.length].log_file_name := log_file_name (1, length);
          job_list.records_p^ [job_list.length].subproduct_count :=
                installation_control_record.medium_processing_records_p^ [medium_index].subproduct_count;

        IFEND;
      FOREND;

    IFEND;

    { Set the job identifier field in the subproduct processing records to the identifier
    { for the job responsible for each subproduct to be installed.

    FOR subproduct_index := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^) DO
      IF installation_control_record.subproduct_processing_records_p^ [subproduct_index].task_set <>
            $rat$task_selections [] THEN
        IF installation_control_record.packing_list_pointers.order_medium = rac$tape THEN
          medium_index := installation_control_record.packing_list_pointers.
                tape_subproduct_indexer_p^ [subproduct_index].primary_tape_vsn;
        ELSE {order medium = rac$disk}
          medium_index := 1;
        IFEND;

        installation_control_record.subproduct_processing_records_p^ [subproduct_index].job_identifier :=
              installation_control_record.medium_processing_records_p^ [medium_index].job_identifier;

      IFEND;
    FOREND;

  PROCEND assign_job_identifiers;

?? OLDTITLE ??
?? NEWTITLE := 'create_processing_summary_file', EJECT ??

{ PURPOSE:
{   This procedure creates the processing summary file for the current
{   installation event.
{
{ DESIGN:
{   The processing summary file is created under the installation
{   identifier catalog.  It is opened as a segment access file.  After
{   opening the processing summary file a sequence descriptor, a header and
{   an array of job status records are created and initialized in the
{   sequence.
{
{   There is one job status record for each job required to process the
{   installation event.  The job list that was passed in defines the number
{   of jobs required and contains additional job data that is copied into
{   the job status records
{
{ NOTES:
{

  PROCEDURE create_processing_summary_file
    (    job_list: rat#job_list;
         installation_control_record: rat$installation_control_record;
     VAR status: ost$status);


    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      creation_date_time: ost$date_time,
      file_opened: boolean,
      i: rat$job_count,
      ignore_status: ost$status,
      job_status_records_p: ^rat$job_status_records,
      length: integer,
      local_status: ost$status,
      sequence_descriptor_p: ^rat$sequence_descriptor,
      summary_file_fid: amt$file_identifier,
      summary_file_header_p: ^rat$processing_summary_header,
      summary_file_path: fst$path,
      summary_file_segment_p: amt$segment_pointer;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to close the processing
{   summary file when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (summary_file_fid, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options
          [fsc$read, fsc$shorten, fsc$append, fsc$modify];
    attachment_options [1].share_modes.selector := fsc$determine_from_access_modes;
    attachment_options [2].selector := fsc$create_file;
    attachment_options [2].create_file := TRUE;
    attachment_options [3].selector := fsc$wait_for_attachment;
    attachment_options [3].wait_for_attachment.wait := osc$wait;
    attachment_options [3].wait_for_attachment.wait_time := fsc$longest_wait_time;

{ Assemble the path to the processing summary file using the installation logs path,
{ the installation identifier and the processing summary file name.

    STRINGREP (summary_file_path, length, installation_control_record.processing_header_p^.
          installation_defaults.installation_logs.path (1, installation_control_record.processing_header_p^.
          installation_defaults.installation_logs.size), '.',
          installation_control_record.processing_header_p^.installation_identifier
          (1, clp$trimmed_string_size (installation_control_record.processing_header_p^.
          installation_identifier)), '.', rac$summary_file_name);


    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      file_opened := TRUE;
      fsp$open_file (summary_file_path (1, length), amc$segment, ^attachment_options, NIL, NIL, NIL, NIL,
            summary_file_fid, status);
      IF NOT status.normal THEN
        file_opened := FALSE;
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (summary_file_fid, amc$sequence_pointer, summary_file_segment_p, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      RESET summary_file_segment_p.sequence_pointer;
      NEXT sequence_descriptor_p IN summary_file_segment_p.sequence_pointer;
      IF sequence_descriptor_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'PROCESSING SUMMARY FILE', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'SEQUENCE DESCRIPTOR', status);
        EXIT /main/;
      IFEND;

      pmp$get_compact_date_time (creation_date_time, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      sequence_descriptor_p^.processor_version := rac$inss_processor_version;
      sequence_descriptor_p^.sequence_creation_date_time := creation_date_time;
      sequence_descriptor_p^.sequence_type := rac$processing_summary_sequence;
      sequence_descriptor_p^.sequence_level := rac$summary_file_level;

      NEXT summary_file_header_p IN summary_file_segment_p.sequence_pointer;
      IF summary_file_header_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'PROCESSING SUMMARY FILE', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'HEADER', status);
        EXIT /main/;
      IFEND;

      NEXT job_status_records_p: [1 .. job_list.length] IN summary_file_segment_p.sequence_pointer;
      IF job_status_records_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'PROCESSING SUMMARY FILE', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'JOB STATUS RECORDS', status);
        EXIT /main/;
      IFEND;

      summary_file_header_p^.job_count := job_list.length;
      summary_file_header_p^.job_status_records_rel_p := #REL (job_status_records_p,
            summary_file_segment_p.sequence_pointer^);

      FOR i := 1 TO job_list.length DO
        job_status_records_p^ [i].job_identifier := job_list.records_p^ [i].identifier;
        job_status_records_p^ [i].log_file_name := job_list.records_p^ [i].log_file_name;
        job_status_records_p^ [i].date_time := creation_date_time;
        job_status_records_p^ [i].number_of_steps := installation_control_record.processing_header_p^.
              number_of_steps;
        job_status_records_p^ [i].step_number := 0;
        job_status_records_p^ [i].step := rac$null_step;
        job_status_records_p^ [i].step_status := rac$step_started;
        job_status_records_p^ [i].initial_subproduct_count := job_list.records_p^ [i].subproduct_count;
        job_status_records_p^ [i].started_subproduct_count := 0;
        job_status_records_p^ [i].completed_subproduct_count := 0;
      FOREND;

      amp$set_segment_eoi (summary_file_fid, summary_file_segment_p, status);

    END /main/;

    IF file_opened THEN
      fsp$close_file (summary_file_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND create_processing_summary_file;

?? OLDTITLE ??
?? NEWTITLE := 'establish_job_processing_recds', EJECT ??

{ PURPOSE:
{   This procedure establishes the job processing records in the processing
{   sequence.
{
{ DESIGN:
{   There is one job processing record for each job required to process the
{   installation event.  The job list that was passed in defines the number
{   of jobs required and contains additional job data that is copied into
{   the job processing records.
{
{ NOTES:
{

  PROCEDURE establish_job_processing_recds
    (    job_list: rat#job_list;
     VAR installation_control_record: rat$installation_control_record;
     VAR status: ost$status);


    VAR
      i: rat$job_count;


    status.normal := TRUE;

    NEXT installation_control_record.job_processing_records_p: [1 .. job_list.length] IN
          installation_control_record.processing_seq_p;
    IF installation_control_record.job_processing_records_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'PROCESSING SEQUENCE', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'JOB PROCESSING RECORDS', status);
      RETURN;
    IFEND;

    installation_control_record.processing_header_p^.job_processing_rec_rel_p :=
          #REL (installation_control_record.job_processing_records_p,
          installation_control_record.processing_seq_p^);

    FOR i := 1 TO job_list.length DO
      installation_control_record.job_processing_records_p^ [i].job_identifier :=
            job_list.records_p^ [i].identifier;
      installation_control_record.job_processing_records_p^ [i].log_file_name :=
            job_list.records_p^ [i].log_file_name;
    FOREND;

  PROCEND establish_job_processing_recds;
MODEND ram$establish_processing_cntrls;
*DECK DECK=RAM$ESTABLISH_VARIABLES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Establish Variables: Routine to Establish System Initialization Variables' ??
MODULE ram$establish_variables;

{ PURPOSE:
{   This module contains the procedure to establish the control variables
{   needed for system initialization.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc rat$installation_tape_values
?? POP ??
*copyc clp$include_line
*copyc rap$get_development_ds_value
*copyc rap$get_inst_tape_values
*copyc rap$get_jobs_recovered_value
*copyc rap$get_network_activate_value
*copyc rap$get_system_activation_value

?? TITLE := '[XDCL] rap$establish_variables', EJECT ??

  PROCEDURE [XDCL] rap$establish_variables
    (VAR status: ost$status);

    VAR
      command_line: string (1000),
      development_deadstart_value: boolean,
      installation_tape_values: rat$installation_tape_values,
      jobs_recovered_value: boolean,
      length: integer,
      network_activation_value: boolean,
      system_activation_value: boolean;


    status.normal := TRUE;

    rap$get_development_ds_value (development_deadstart_value);
    rap$get_inst_tape_values (installation_tape_values);
    rap$get_jobs_recovered_value (jobs_recovered_value);
    rap$get_network_activate_value (network_activation_value);
    rap$get_system_activation_value (system_activation_value);

?? FMT (FORMAT := OFF) ??
    STRINGREP (command_line, length,
          ' VAR;',
          '   dsv$gotcmds3commands: (JOB) boolean = no;',
          '   dsv$systembase: (JOB) string;',
          '   dsv$user: (JOB) string;',
          '   dsv$userpassword: (JOB) string;',
          '   rav$development_deadstart: (JOB) boolean = ', development_deadstart_value, ';',
          '   rav$installation_tape_values: (JOB) record ',
          '     packing_list: name = $optional;',
          '     evsn: string 0..', rmc$external_vsn_size, ';',
          '     rvsn: string 0..', rmc$recorded_vsn_size, ';',
          '     tape_type: name = $optional;',
          '   recend = (', installation_tape_values.packing_list,
                        ', ''', installation_tape_values.evsn, '''',
                        ', ''', installation_tape_values.rvsn, ''', ',
                        installation_tape_values.tape_type, ');',
          '   rav$jobs_recovered: (JOB) boolean = ', jobs_recovered_value, ';',
          '   rav$network_activation: (JOB) boolean = ', network_activation_value, ';',
          '   rav$system_activation: (JOB) boolean = ', system_activation_value, ';',
          ' VAREND;');
?? FMT (FORMAT := ON) ??

    clp$include_line (command_line (1, length), TRUE, osc$null_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$establish_variables;

MODEND ram$establish_variables;
*DECK DECK=RAM$EXECUTE_INSTALLER_PROCS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$EXECUTE_INSTALLER_PROCS Interface.' ??
MODULE ram$execute_installer_procs;

{ PURPOSE:
{   This module contains the interface and procedures which perform the
{   execute installer procedures step of the installation process.
{
{ DESIGN:
{   This steps follows the same general design as the other major
{   installation steps.  This step will use the task list to determine if
{   any subproducts have an installer procedure to execute.  If one is
{   found, it will invoke the EXECUTE_INSTALLER_PROCEDURE (hidden)
{   subcommand of INSTALL_SOFTWARE.  The installer procedure will be
{   executed while inside the EXECUTE_INSTALLER_PROCEDURE subutility.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$installation_cycles
*copyc rae$install_software_cc
*copyc rat$installation_control_record
?? POP ??
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
*copyc pfp$convert_fs_path_to_pf_path
*copyc pfp$convert_string_to_fs_path
*copyc rap$clear_installation
*copyc rap$execute_installer_procs_utl
*copyc rap$record_step_status
*copyc rap$record_subproduct_status
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$execute_installer_procs', EJECT ??

{ PURPOSE:
{   This interface performs the 'execute installer procedure' step of the
{   installation process.
{
{ DESIGN:
{   This procedure follows the same design as the other major steps of the
{   installation process.
{
{   For each subproduct in the task list that is assigned to this job and
{   which has not failed, determine if it has an installer procedure.  If it
{   does, pass information about the subproduct and the current installation
{   over to the EXECUTE_INSTALLER_PROCEDURE subutility of INSTALL_SOFTWARE.
{   That subutility will execute the installer procedure and return the
{   status.  The failure of one subproduct will not jeopardize the remaining
{   subproducts, each subproduct will be processed independently.
{
{ NOTES:
{   The SUBPRODUCT_FAILED_PROCESSING boolean has been initialized outside of
{   this interface and should never be re-initialized here.
{

  PROCEDURE [XDCL] rap$execute_installer_procs
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR subproduct_failed_processing: boolean;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      local_status: ost$status,
      processing_record: rat$subp_processing_record,
      subproduct_index: rat$subproduct_count,
      task_status: ost$status;


    status.normal := TRUE;

    IF NOT (rac$execute_installer_proc_step IN installation_control_record.processing_header_p^.step_set) THEN
      RETURN;
    IFEND;

    rap$record_step_status (rac$execute_installer_proc_step, rac$step_started, installation_control_record,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /main/
    FOR subproduct_index := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^)
          DO
      processing_record := installation_control_record.subproduct_processing_records_p^ [subproduct_index];

      IF (installation_control_record.job_identifier = processing_record.job_identifier) AND
            (rac$execute_installer_proc_task IN processing_record.task_set) AND
            (processing_record.task_status <> rac$task_failed) THEN

        rap$record_subproduct_status (rac$execute_installer_proc_task, rac$task_started, subproduct_index,
              installation_control_record, ignore_status);

        task_status.normal := TRUE;

        IF processing_record.subproduct_info_pointers.attributes_p^.installer_procedure.
              path_container_index <> 0 THEN
          rap$execute_installer_procs_utl (processing_record, TRUE {subproduct_data_available},
                installation_control_record, task_status);
        IFEND;

        IF task_status.normal THEN
          rap$record_subproduct_status (rac$execute_installer_proc_task, rac$task_completed,
                subproduct_index, installation_control_record, ignore_status);
        ELSE
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], task_status, ignore_status);
          rap$record_subproduct_status (rac$execute_installer_proc_task, rac$task_failed, subproduct_index,
                installation_control_record, ignore_status);
          subproduct_failed_processing := TRUE;
        IFEND;

      IFEND;
    FOREND /main/;

    rap$clear_installation (installation_control_record, ignore_status);

    rap$record_step_status (rac$execute_installer_proc_step, rac$step_completed, installation_control_record,
          local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

  PROCEND rap$execute_installer_procs;

MODEND ram$execute_installer_procs;
*DECK DECK=RAM$EXECUTE_INSTALLER_PROCS_CMD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE UTILITY: EXECUTE_INSTALLER_PROCEDURE Subutility Command.' ??
MODULE ram$execute_installer_procs_cmd;

{ PURPOSE:
{   This module contains the command interface to the
{   EXECUTE_INSTALLER_PROCEDURE subutility of INSTALL_SOFTWARE.
{ DESIGN:
{   Since the EXECUTE_INSTALLER_PROCEDURE utility must be accessible from
{   SCL (this interface) and during the installation process from CYBIL,
{   this module only contains the command interface portion of the utility.
{   The actual utility can be found in RAM$EXECUTE_INSTALLER_PROCS_UTL.
{ NOTES:
{   In the future, this command should have parameters to allow
{   specification of the installation environment to use.  This will allow
{   better simulation of the environment which exists when the
{   EXECUTE_INSTALLER_PROCEDURE utility is invoked from cybil.  Likely
{   parameters are:  PACKING_LIST, SUBPRODUCT_NAME, INSTALLATION_COMMAND
{   (PRODUCT or CORRECTION), SAVE_PREVIOUS_CYCLES.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rat$installation_control_record
*copyc rat$installation_defaults
*copyc rae$install_software_cc
*copyc rat$processing_types
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc rap$execute_installer_procs_utl
*copyc rap$initialize_processing_seq
*copyc rav$installation_defaults
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$execute_installer_procs_cmd', EJECT ??
{ PURPOSE:
{   Contains the actual command interface to the EXECUTE_INSTALLER_PROCEDURE
{   subutility of INSTALL_SOFTWARE.
{ DESIGN:
{   Uses standard SCL command interface design.  Creates data structures to
{   pass to the EXECUTE_INSTALLER_PROCEDURE utility.  All data is dummy
{   except for the instalation defaults which are correct.  Since the
{   EXECUTE_INSTALLER_PROCEDURE utility expects to be passed a pointer to a
{   scratch sequence, one is created here.
{ NOTES:
{   The dummy data passed in is expected by the EXECUTE_INSTALLER_PROCEDURES
{   utility.  Any changes in the data initialization must be cross checked
{   with the code in the utility.

  PROCEDURE [XDCL] rap$execute_installer_procs_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE exeip_pdt (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 6, 21, 8, 32, 21, 105], clc$command, 1, 1, 0, 0, 0, 0, 1, 'EXEIP_PDT'],
            [['STATUS                         ', clc$nominal_entry, 1]], [
{ PARAMETER 1
      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      installation_control_record: rat$installation_control_record,
      local_status: ost$status,
      empty_subp_processing_record: rat$subp_processing_record,
      scratch_segment_pointer: amt$segment_pointer;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to return the scratch
{   segment when an abort condition arises.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF scratch_segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (scratch_segment_pointer, ignore_status);
        scratch_segment_pointer.sequence_pointer := NIL;
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    scratch_segment_pointer.kind := amc$sequence_pointer;
    scratch_segment_pointer.sequence_pointer := NIL;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, scratch_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      installation_control_record.scratch_seq_p := scratch_segment_pointer.sequence_pointer;
      RESET installation_control_record.scratch_seq_p;

      PUSH installation_control_record.processing_header_p;
      installation_control_record.processing_header_p^.installation_identifier := osc$null_name;
      installation_control_record.processing_header_p^.packing_list_name := osc$null_name;
      installation_control_record.processing_header_p^.installation_defaults := rav$installation_defaults;
      installation_control_record.processing_header_p^.medium_processing_rec_rel_p := NIL;
      installation_control_record.processing_header_p^.subproduct_processing_rec_rel_p := NIL;
      installation_control_record.processing_header_p^.step_set :=
            $rat$step_selections [rac$delete_previous_cycles_step];

      rap$execute_installer_procs_utl (empty_subp_processing_record,
            FALSE {subproduct_data_available}, installation_control_record, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

    END /main/;

    osp$disestablish_cond_handler;

    IF scratch_segment_pointer.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (scratch_segment_pointer, local_status);
      scratch_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

  PROCEND rap$execute_installer_procs_cmd;
?? OLDTITLE ??
MODEND ram$execute_installer_procs_cmd;
*DECK DECK=RAM$EXECUTE_INSTALLER_PROCS_UTL EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE UTILITY: EXECUTE_INSTALLER_PROCEDURE Subutility Interface.' ??
MODULE ram$execute_installer_procs_utl;

{ PURPOSE:
{   This module contains the EXECUTE_INSTALLER_PROCEDURE subutility of
{   INSTALL_SOFTWARE.  The procedures in this module create an environment
{   in order to execute installer procedures.  The utility will execute an
{   installer procedure when called during installation or can be used by a
{   developer to test an installer procedure.
{ DESIGN:
{   This module follows standard utility design with the exception that
{   command interface for the utility resides in the module
{   RAM$EXECUTE_INSTALLER_PROCS_CMD.
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$type_kind
*copyc clt$variable_name_reference
*copyc fst$number_of_path_elements
*copyc rae$install_software_cc
*copyc rat$installation_control_record
*copyc rat$installation_defaults
*copyc rat$processing_types
*copyc rat$subproduct_info_pointers
?? POP ??
*copyc clp$begin_utility
*copyc clp$create_procedure_variable
*copyc clp$create_environment_variable
*copyc clp$delete_variable
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$get_variable_value
*copyc clp$include_file
*copyc clp$include_line
*copyc clp$trimmed_string_size
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc rap$assemble_installation_path
*copyc rap$convert_path_to_str
*copyc rav$subproduct_type

?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    rav$exeip_utility_name: [XDCL] clt$utility_name := 'EXECUTE_INSTALLER_PROCEDURE';

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$execute_installer_procs_utl', EJECT ??

{ PURPOSE:
{   This procedure sets up the EXECUTE_INSTALLER_PROCEDURE utility
{   session.
{
{ DESIGN:
{   This follows standard utility design.  Enter the utility.  Then create
{   the SCL variables and types which are to be available during the utility
{   session.  (For a description of the variable and type creation process,
{   refer to procedure CREATE_SUBPRODUCT_INFO_VAR.  The scratch sequence
{   provided by the caller of this interface is used for creating the
{   variables.  If an installer procedure was passed in by the caller,
{   execute it using INCLUDE_LINE.  If none was given, perform an
{   INCLUDE_FILE.  This will allow execution of installer procedures in a
{   test mode.  At the completion of the INCLUDE_FILE or INCLUDE_COMMAND,
{   terminate the utility.
{ NOTES:
{   It is not necessary to clean up the VARs and TYPEs created on an error
{   or at the end of the utility will be cleaned up by SCL when the utility
{   terminates.

  PROCEDURE [XDCL] rap$execute_installer_procs_utl
    (    subp_processing_record: rat$subp_processing_record;
         subproduct_data_available: boolean;
     VAR installation_control_record: rat$installation_control_record;
     VAR status: ost$status);


{ table n=exeip_command_table t=command s=xdcl
{ command n=(install_file, insf) p=rap$install_file cm=procedure
{ command n=(update_library, updl) p=rap$update_library cm=procedure
{ command n=(rap$get_catalog_file_names) p=rap$get_catalog_file_names cm=procedure a=hidden
{ command n=(rap$get_file_ring_attributes) p=rap$get_file_ring_attributes cm=procedure a=hidden
{ command n=(rap$remove_elements_from_path) p=rap$remove_elements_from_path cm=procedure a=hidden
{ command n=(quit, qui) p=rap$quit_exeip cm=xref
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  exeip_command_table: [XDCL, READ] ^clt$command_table := ^exeip_command_table_entries,

  exeip_command_table_entries: [STATIC, READ] array [1 .. 9] of clt$command_table_entry := [
  {} ['INSF                           ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$proc_call, 'RAP$INSTALL_FILE'],
  {} ['INSTALL_FILE                   ', clc$nominal_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$proc_call, 'RAP$INSTALL_FILE'],
  {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^rap$quit_exeip],
  {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^rap$quit_exeip],
  {} ['RAP$GET_CATALOG_FILE_NAMES     ', clc$nominal_entry, clc$hidden_entry, 3, clc$automatically_log,
         clc$proc_call, 'RAP$GET_CATALOG_FILE_NAMES'],
  {} ['RAP$GET_FILE_RING_ATTRIBUTES   ', clc$nominal_entry, clc$hidden_entry, 4, clc$automatically_log,
         clc$proc_call, 'RAP$GET_FILE_RING_ATTRIBUTES'],
  {} ['RAP$REMOVE_ELEMENTS_FROM_PATH  ', clc$nominal_entry, clc$hidden_entry, 5, clc$automatically_log,
         clc$proc_call, 'RAP$REMOVE_ELEMENTS_FROM_PATH'],
  {} ['UPDATE_LIBRARY                 ', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$proc_call, 'RAP$UPDATE_LIBRARY'],
  {} ['UPDL                           ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$proc_call, 'RAP$UPDATE_LIBRARY']];

  PROCEDURE [XREF] rap$quit_exeip
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??


    CONST
      prompt_size = 5,
      prompt_value = 'EXEIP';

    VAR
      installer_procedure: rat$path,
      installer_pf_path_p: ^pft$path,
      linker_errors_found: ^clt$data_value,
      local_status: ost$status,
      scratch_sequence_p: ^SEQ ( * ),
      utility_attributes_p: ^clt$utility_attributes;


    status.normal := TRUE;

    PUSH utility_attributes_p: [1 .. 3];
    utility_attributes_p^ [1].key := clc$utility_command_search_mode;
    utility_attributes_p^ [1].command_search_mode := clc$global_command_search;
    utility_attributes_p^ [2].key := clc$utility_command_table;
    utility_attributes_p^ [2].command_table := exeip_command_table;
    utility_attributes_p^ [3].key := clc$utility_prompt;
    utility_attributes_p^ [3].prompt.size := prompt_size;
    utility_attributes_p^ [3].prompt.value := prompt_value;

    clp$begin_utility (rav$exeip_utility_name, utility_attributes_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    scratch_sequence_p := installation_control_record.scratch_seq_p;
    RESET scratch_sequence_p;

  /main/
    BEGIN

      IF subproduct_data_available = TRUE THEN

        rap$assemble_installation_path (installation_control_record.processing_header_p^.
              installation_defaults.system_catalog, subp_processing_record.subproduct_info_pointers,
              rac$installer_procedure, installer_pf_path_p, installation_control_record.scratch_seq_p,
              status);

        IF NOT status.normal THEN
          RETURN;
        IFEND;

        rap$convert_path_to_str (installer_pf_path_p^, installer_procedure);

      IFEND;

      create_subproduct_info_var (subp_processing_record, subproduct_data_available,
            installer_procedure, installation_control_record. processing_seq_p, scratch_sequence_p,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      create_installation_deflts_var (installation_control_record.processing_header_p^.installation_defaults,
            scratch_sequence_p, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      create_installation_envirn_var (installation_control_record.processing_header_p, scratch_sequence_p,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF subproduct_data_available = TRUE THEN
        clp$include_line (installer_procedure.path (1, installer_procedure.size), TRUE,
              osc$null_name, status);
      ELSE
        clp$include_file (clc$current_command_input, prompt_value, rav$exeip_utility_name, status);
      IFEND;

      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF installer_procedure.path(1,installer_procedure.size) =
           ':$SYSTEM.$SYSTEM.SOFTWARE_MAINTENANCE.RAF$LIBRARY.INSTALL_NOSVE_MAINTENANCE' THEN
        clp$get_variable_value ('RAV$LINKER_ERRORS_FOUND', linker_errors_found, local_status);
        IF NOT local_status.normal THEN
          EXIT /main/;
        IFEND;

        IF linker_errors_found <> NIL THEN
          IF linker_errors_found^.boolean_value.value THEN
            osp$set_status_abnormal ('RA', rae$linker_errors_occurred, ' ', status);
          IFEND;
        IFEND;

{ If we get here, delete the variable and ignore the status.

        clp$delete_variable ('RAV$LINKER_ERRORS_FOUND', local_status);
      IFEND;

    END /main/;

    clp$end_utility (rav$exeip_utility_name, local_status);

    IF (status.normal) AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

  PROCEND rap$execute_installer_procs_utl;
?? OLDTITLE ??
?? NEWTITLE := 'create_subproduct_info_var', EJECT ??
{ PURPOSE:
{   This procedure creates the SCL variable and type which make the
{   attributes of the subproduct being installed available to the user.
{ DESIGN:
{   The process used to create the type declaration and var declaration
{   follows the guidelines the guidelines described in the SCL ERS.  Since
{   the variable created is a user defined type the process is somewhat more
{   complicated than if the variable were a standard NAME, or STRING type
{   variable.  The code is also complicated because the variables must be
{   initialized differently depending upon whether the utility was entered
{   from the command interface or from CYBIL during installation.  From the
{   command interface, there is no data available to initialize the variable
{   (except for the installation defaults variable).  From the CYBIL
{   interface, information about the current subproduct being installed is
{   passed into the utility.
{
{   The processed used to create each variable and type is as follows:
{
{   1.  Create the SCL type.  This type will be available to the user while
{       in the utility.  See procedure CREATE_SCL_TYPE for details about how the
{       type is created.
{
{   2.  In order to initialize the variable, a structure of type
{       clt$data_value must be created.  This structure is created in the
{       scratch sequence.  The number of fields in the variable determine how
{       big the structure will be.
{
{   3.  Initialize each field of the record.  If a value is available for a
{       field (was passed into the procedure), a value is assigned.  Otherwise
{       the field value is set to NIL.  Setting the field value to NIL causes
{       the field of the record to be DEFINED, but not INITIALIZED.  (DEFINED
{       and INITIALIZED are actual SCL terms in this case.  See the $FIELD
{       function.)
{
{       Although it would make this procedure shorter to initialize the fields
{       of the variable in a separate subroutine, the initialization was kept
{       here to keep the declaration of the record structure as close as
{       possible to the initialization of the fields.  This, it was thought,
{       would simplify maintenance.
{
{   4.  Create the SCL variable.  The variable will have scope XDCL so it
{       will be accessible to the user inside their installer procedure.
{       The type specification used to create the SCL type in step 1 is the
{       same one used to create the SCL variable.
{ NOTES:
{   If the subproduct_info_pointers.attributes_p is NIL, then it is assumed
{   that all the pointers for the subproduct are NIL.  This occurs when the
{   utility was invoked from the the command interface rather than the CYBIL
{   interface.

  PROCEDURE create_subproduct_info_var
    (    subp_processing_record: rat$subp_processing_record;
         subproduct_data_available: boolean;
         installer_procedure: rat$path;
         processing_seq_p: ^rat$processing_sequence;
     VAR scratch_sequence_p: ^SEQ ( * );
     VAR status: ost$status);

{ The value for the NUMBER_OF_RECORD_FIELDS constant and the actual number of
{ fields in the rav$subproduct_information record MUST match.

    CONST
      number_of_record_fields = 11;

{ TYPE
{   rav$subproduct_information: record
{     active_level_path:         file =$optional
{     actual_installation_path:  file =$optional
{     base_level_path:           file =$optional
{     correction_base_level:     name =$optional
{     correction_base_path:      file =$optional
{     defined_installation_path: file =$optional
{     installer_procedure:       file =$optional
{     internal_level:            name =$optional
{     level:                     name =$optional
{     subproduct_name:           name =$optional
{     subproduct_type:           name =$optional
{   recend
{ TYPEND

?? PUSH (LISTEXT := ON) ??

  VAR
    type_specification : [STATIC, READ, cls$declaration_section] record
      header: clt$type_specification_header,
      name: string (26),
      qualifier: clt$record_type_qualifier,
      field_spec_1: clt$field_specification,
      element_type_spec_1: record
        header: clt$type_specification_header,
      recend,
      field_spec_2: clt$field_specification,
      element_type_spec_2: record
        header: clt$type_specification_header,
      recend,
      field_spec_3: clt$field_specification,
      element_type_spec_3: record
        header: clt$type_specification_header,
      recend,
      field_spec_4: clt$field_specification,
      element_type_spec_4: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      field_spec_5: clt$field_specification,
      element_type_spec_5: record
        header: clt$type_specification_header,
      recend,
      field_spec_6: clt$field_specification,
      element_type_spec_6: record
        header: clt$type_specification_header,
      recend,
      field_spec_7: clt$field_specification,
      element_type_spec_7: record
        header: clt$type_specification_header,
      recend,
      field_spec_8: clt$field_specification,
      element_type_spec_8: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      field_spec_9: clt$field_specification,
      element_type_spec_9: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      field_spec_10: clt$field_specification,
      element_type_spec_10: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      field_spec_11: clt$field_specification,
      element_type_spec_11: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
    recend := [
      [1, 26, clc$record_type], 'RAV$SUBPRODUCT_INFORMATION', [11],
      ['ACTIVE_LEVEL_PATH              ', clc$optional_field, 3], [[1, 0, clc$file_type]],
      ['ACTUAL_INSTALLATION_PATH       ', clc$optional_field, 3], [[1, 0, clc$file_type]],
      ['BASE_LEVEL_PATH                ', clc$optional_field, 3], [[1, 0, clc$file_type]],
      ['CORRECTION_BASE_LEVEL          ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['CORRECTION_BASE_PATH           ', clc$optional_field, 3], [[1, 0, clc$file_type]],
      ['DEFINED_INSTALLATION_PATH      ', clc$optional_field, 3], [[1, 0, clc$file_type]],
      ['INSTALLER_PROCEDURE            ', clc$optional_field, 3], [[1, 0, clc$file_type]],
      ['INTERNAL_LEVEL                 ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['LEVEL                          ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['SUBPRODUCT_NAME                ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['SUBPRODUCT_TYPE                ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]]
      ];

?? POP ??

    VAR
      active_level_catalog_pf_path_p: ^pft$path,
      attributes_p: ^rat$subproduct_attributes,
      base_level_catalog_pf_path_p: ^pft$path,
      converted_path_p: ^rat$path,
      corr_base_catalog_pf_path_p: ^pft$path,
      initial_value_p: ^clt$data_value,
      installation_path_p: ^pft$path,
      installation_path_index: rat$path_container_length,
      path_element: fst$number_of_path_elements;

    status.normal := TRUE;
    IF subproduct_data_available THEN
      attributes_p := subp_processing_record.subproduct_info_pointers.attributes_p;
    IFEND;

    create_scl_type ('rat$subproduct_information', #SEQ (type_specification), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_memory_for_initial_value (number_of_record_fields, initial_value_p, scratch_sequence_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Initialize the fields of the record.

    initial_value_p^.kind := clc$record;

    initial_value_p^.field_values^ [1].name := 'ACTIVE_LEVEL_PATH';
    IF subproduct_data_available AND (subp_processing_record.active_level_catalog_rel_p <> NIL) THEN
      PUSH converted_path_p;
      active_level_catalog_pf_path_p :=  #PTR (subp_processing_record.active_level_catalog_rel_p,
            processing_seq_p^);
      rap$convert_path_to_str (active_level_catalog_pf_path_p^, converted_path_p^);
      initial_value_p^.field_values^ [1].value^.kind := clc$file;
      initial_value_p^.field_values^ [1].value^.file_value :=
           ^converted_path_p^.path (1, converted_path_p^.size);
    ELSE
      initial_value_p^.field_values^ [1].value := NIL;
    IFEND;

    initial_value_p^.field_values^ [2].name := 'ACTUAL_INSTALLATION_PATH';
    IF subproduct_data_available THEN
      PUSH converted_path_p;
      rap$convert_path_to_str (subp_processing_record.installation_catalog_p^, converted_path_p^);
      initial_value_p^.field_values^ [2].value^.kind := clc$file;
      initial_value_p^.field_values^ [2].value^.file_value :=
           ^converted_path_p^.path (1, converted_path_p^.size);
    ELSE
      initial_value_p^.field_values^ [2].value := NIL;
    IFEND;

    initial_value_p^.field_values^ [3].name := 'BASE_LEVEL_PATH';
    IF subproduct_data_available AND (subp_processing_record.base_level_catalog_rel_p <> NIL) THEN
      PUSH converted_path_p;
      base_level_catalog_pf_path_p :=  #PTR (subp_processing_record.base_level_catalog_rel_p,
            processing_seq_p^);
      rap$convert_path_to_str (base_level_catalog_pf_path_p^, converted_path_p^);
      initial_value_p^.field_values^ [3].value^.kind := clc$file;
      initial_value_p^.field_values^ [3].value^.file_value :=
           ^converted_path_p^.path (1, converted_path_p^.size);
    ELSE
      initial_value_p^.field_values^ [3].value := NIL;
    IFEND;

    initial_value_p^.field_values^ [4].name := 'CORRECTION_BASE_LEVEL';
    IF (subproduct_data_available) AND (attributes_p^.correction_base_level <> osc$null_name) THEN
      initial_value_p^.field_values^ [4].value^.kind := clc$name;
      initial_value_p^.field_values^ [4].value^.name_value := attributes_p^.correction_base_level;
    ELSE
      initial_value_p^.field_values^ [4].value := NIL;
    IFEND;

    initial_value_p^.field_values^ [5].name := 'CORRECTION_BASE_PATH';
    IF subproduct_data_available AND (subp_processing_record.correction_base_catalog_rel_p <> NIL) THEN
      PUSH converted_path_p;
      corr_base_catalog_pf_path_p :=  #PTR (subp_processing_record.correction_base_catalog_rel_p,
            processing_seq_p^);
      rap$convert_path_to_str (corr_base_catalog_pf_path_p^, converted_path_p^);
      initial_value_p^.field_values^ [5].value^.kind := clc$file;
      initial_value_p^.field_values^ [5].value^.file_value :=
           ^converted_path_p^.path (1, converted_path_p^.size);
    ELSE
      initial_value_p^.field_values^ [5].value := NIL;
    IFEND;

    initial_value_p^.field_values^ [6].name := 'DEFINED_INSTALLATION_PATH';
    IF subproduct_data_available THEN
      installation_path_index := attributes_p^.installation_path.path_container_index;
      PUSH installation_path_p: [1 .. attributes_p^.installation_path.path_length];
      FOR path_element := 1 TO UPPERBOUND (installation_path_p^) DO
        installation_path_p^ [path_element] := subp_processing_record.subproduct_info_pointers.
              path_container_p^ [installation_path_index];
        installation_path_index := installation_path_index + 1;
      FOREND;
      PUSH converted_path_p;
      rap$convert_path_to_str (installation_path_p^, converted_path_p^);
      initial_value_p^.field_values^ [6].value^.kind := clc$file;
      initial_value_p^.field_values^ [6].value^.file_value :=
         ^converted_path_p^.path (1, converted_path_p^.size);
    ELSE
      initial_value_p^.field_values^ [6].value := NIL;
    IFEND;

    initial_value_p^.field_values^ [7].name := 'INSTALLER_PROCEDURE';
    IF subproduct_data_available THEN
      initial_value_p^.field_values^ [7].value^.kind := clc$file;
      initial_value_p^.field_values^ [7].value^.file_value :=
         ^installer_procedure.path (1, installer_procedure.size);
    ELSE
      initial_value_p^.field_values^ [7].value := NIL;
    IFEND;

    initial_value_p^.field_values^ [8].name := 'INTERNAL_LEVEL';
    IF (subproduct_data_available) AND (attributes_p^.internal_level <> osc$null_name) THEN
      initial_value_p^.field_values^ [8].value^.kind := clc$name;
      initial_value_p^.field_values^ [8].value^.name_value := attributes_p^.internal_level;
    ELSE
      initial_value_p^.field_values^ [8].value := NIL;
    IFEND;

    initial_value_p^.field_values^ [9].name := 'LEVEL';
    IF subproduct_data_available THEN
      initial_value_p^.field_values^ [9].value^.kind := clc$name;
      initial_value_p^.field_values^ [9].value^.name_value := attributes_p^.level;
    ELSE
      initial_value_p^.field_values^ [9].value := NIL;
    IFEND;

    initial_value_p^.field_values^ [10].name := 'SUBPRODUCT_NAME';
    IF subproduct_data_available THEN
      initial_value_p^.field_values^ [10].value^.kind := clc$name;
      initial_value_p^.field_values^ [10].value^.name_value := attributes_p^.name;
    ELSE
      initial_value_p^.field_values^ [10].value := NIL;
    IFEND;

    initial_value_p^.field_values^ [11].name := 'SUBPRODUCT_TYPE';
    IF subproduct_data_available THEN
      initial_value_p^.field_values^ [11].value^.kind := clc$name;
      initial_value_p^.field_values^ [11].value^.name_value :=
            rav$subproduct_type [attributes_p^.subproduct_type];
    ELSE
      initial_value_p^.field_values^ [11].value := NIL;
    IFEND;

    clp$create_procedure_variable ('RAV$SUBPRODUCT_INFORMATION', clc$xdcl_scope, clc$read_write,
          clc$immediate_evaluation, #SEQ (type_specification), initial_value_p, status);

  PROCEND create_subproduct_info_var;

?? OLDTITLE ??
?? NEWTITLE := 'create_installation_deflts_var', EJECT ??

{ PURPOSE:
{   This procedure creates the SCL variable and type which make the current
{   INSTALL_SOFTWARE utility session installation defaults available to the
{   user.
{ DESIGN:
{   For a description of the SCL variable and type creation process, refer to the
{   documentation of procedure CREATE_SUBPRODUCT_INFO_VAR.
{ NOTES:
{   Unlike the other variables created, all the field values are always
{   available.

  PROCEDURE create_installation_deflts_var
    (    installation_defaults: rat$installation_defaults;
     VAR scratch_sequence_p: ^SEQ ( * );
     VAR status: ost$status);

{ The value for the NUMBER_OF_RECORD_FIELDS constant and the actual number of
{ fields in the rav$installation_defaults record MUST match.

    CONST
      number_of_record_fields = 6;

{ TYPE
{   rav$installation_defaults:  record
{     correction_bases      : file
{     ignore_storage_class  : boolean
{     installation_database : file
{     installation_logs     : file
{     relax_ring_settings   : boolean
{     system_catalog        : file = $optional
{   recend
{ TYPEND

?? PUSH (LISTEXT := ON) ??

    VAR
      type_specification: [STATIC, READ, cls$declaration_section] record
        header: clt$type_specification_header,
        name: string (25),
        qualifier: clt$record_type_qualifier,
        field_spec_1: clt$field_specification,
        element_type_spec_1: record
          header: clt$type_specification_header,
        recend,
        field_spec_2: clt$field_specification,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
        field_spec_3: clt$field_specification,
        element_type_spec_3: record
          header: clt$type_specification_header,
        recend,
        field_spec_4: clt$field_specification,
        element_type_spec_4: record
          header: clt$type_specification_header,
        recend,
        field_spec_5: clt$field_specification,
        element_type_spec_5: record
          header: clt$type_specification_header,
        recend,
        field_spec_6: clt$field_specification,
        element_type_spec_6: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, 25, clc$record_type], 'RAV$INSTALLATION_DEFAULTS', [6],
            ['CORRECTION_BASES               ', clc$required_field, 3], [[1, 0, clc$file_type]],
            ['IGNORE_STORAGE_CLASS           ', clc$required_field, 3], [[1, 0, clc$boolean_type]],
            ['INSTALLATION_DATABASE          ', clc$required_field, 3], [[1, 0, clc$file_type]],
            ['INSTALLATION_LOGS              ', clc$required_field, 3], [[1, 0, clc$file_type]],
            ['RELAX_RING_SETTINGS            ', clc$required_field, 3], [[1, 0, clc$boolean_type]],
            ['SYSTEM_CATALOG                 ', clc$optional_field, 3], [[1, 0, clc$file_type]]];

?? POP ??

    VAR
      initial_value_p: ^clt$data_value;

    status.normal := TRUE;

    create_scl_type ('rat$installation_defaults', #SEQ (type_specification), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_memory_for_initial_value (number_of_record_fields, initial_value_p, scratch_sequence_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Initialize the fields of the record.

    initial_value_p^.kind := clc$record;

    initial_value_p^.field_values^ [1].name := 'CORRECTION_BASES';
    initial_value_p^.field_values^ [1].value^.kind := clc$file;
    initial_value_p^.field_values^ [1].value^.file_value := ^installation_defaults.correction_bases.
          path (1, installation_defaults.correction_bases.size);

    initial_value_p^.field_values^ [2].name := 'IGNORE_STORAGE_CLASS';
    initial_value_p^.field_values^ [2].value^.kind := clc$boolean;
    initial_value_p^.field_values^ [2].value^.boolean_value.value :=
          installation_defaults.ignore_storage_class;
    initial_value_p^.field_values^ [2].value^.boolean_value.kind := clc$yes_no_boolean;

    initial_value_p^.field_values^ [3].name := 'INSTALLATION_DATABASE';
    initial_value_p^.field_values^ [3].value^.kind := clc$file;
    initial_value_p^.field_values^ [3].value^.file_value :=
          ^installation_defaults.installation_database.path (1,
          installation_defaults.installation_database.size);

    initial_value_p^.field_values^ [4].name := 'INSTALLATION_LOGS';
    initial_value_p^.field_values^ [4].value^.kind := clc$file;
    initial_value_p^.field_values^ [4].value^.file_value := ^installation_defaults.installation_logs.
          path (1, installation_defaults.installation_logs.size);

    initial_value_p^.field_values^ [5].name := 'RELAX_RING_SETTINGS';
    initial_value_p^.field_values^ [5].value^.kind := clc$boolean;
    initial_value_p^.field_values^ [5].value^.boolean_value.value :=
          installation_defaults.relax_ring_settings;
    initial_value_p^.field_values^ [5].value^.boolean_value.kind := clc$yes_no_boolean;

    initial_value_p^.field_values^ [6].name := 'SYSTEM_CATALOG';
    IF installation_defaults.system_catalog.path <> osc$null_name THEN
      initial_value_p^.field_values^ [6].value^.kind := clc$file;
      initial_value_p^.field_values^ [6].value^.file_value := ^installation_defaults.system_catalog.
            path (1, installation_defaults.system_catalog.size);
    ELSE
      initial_value_p^.field_values^ [6].value := NIL;
    IFEND;

    clp$create_procedure_variable ('RAV$INSTALLATION_DEFAULTS', clc$xdcl_scope, clc$read_write,
          clc$immediate_evaluation, #SEQ (type_specification), initial_value_p, status);

  PROCEND create_installation_deflts_var;

?? OLDTITLE ??
?? NEWTITLE := 'create_installation_envirn_var', EJECT ??

{ PURPOSE:
{   This procedure creates the SCL variable and type which make the current
{   installation environment available to the user.  Installation environment
{   refers to the parameters assigned by the user for the installation currently
{   taking place.
{ DESIGN:
{   For a description of the SCL variable and type creation process, refer to the
{   documentation of procedure CREATE_SUBPRODUCT_INFO_VAR.
{ NOTES:
{   If the installation_identifier is null, then it is assumed that no other
{   installation environment information is available.  This occurs when the
{   utility was invoked from the the command interface rather than the CYBIL
{   interface.

  PROCEDURE create_installation_envirn_var
    (    processing_header_p: ^rat$processing_header;
     VAR scratch_sequence_p: ^SEQ ( * );
     VAR status: ost$status);

{ The value for the NUMBER_OF_RECORD_FIELDS constant and the actual number of
{ fields in the rav$installation_defaults record MUST match.

    CONST
      number_of_record_fields = 3;

{ TYPE
{   rav$installation_environment: record
{     installation_identifier:    name    =$optional
{     packing_list:               name    =$optional
{     save_previous_cycles:       boolean =$optional
{   recend
{ TYPEND

?? PUSH (LISTEXT := ON) ??

  VAR
    type_specification : [STATIC, READ, cls$declaration_section] record
      header: clt$type_specification_header,
      name: string (28),
      qualifier: clt$record_type_qualifier,
      field_spec_1: clt$field_specification,
      element_type_spec_1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      field_spec_2: clt$field_specification,
      element_type_spec_2: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      field_spec_3: clt$field_specification,
      element_type_spec_3: record
        header: clt$type_specification_header,
      recend,
    recend := [
      [1, 28, clc$record_type], 'RAV$INSTALLATION_ENVIRONMENT', [3],
      ['INSTALLATION_IDENTIFIER        ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['PACKING_LIST                   ', clc$optional_field, 5], [[1, 0, clc$name_type], [1,
  osc$max_name_size]],
      ['SAVE_PREVIOUS_CYCLES           ', clc$optional_field, 3], [[1, 0, clc$boolean_type]]
      ];

?? POP ??

    VAR
      initialize_fields: boolean,
      initial_value_p: ^clt$data_value;

    status.normal := TRUE;

    create_scl_type ('rat$installation_environment', #SEQ (type_specification), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_memory_for_initial_value (number_of_record_fields, initial_value_p, scratch_sequence_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Initialize the fields of the record.

    IF processing_header_p^.installation_identifier = osc$null_name THEN
      initialize_fields := FALSE;
    ELSE
      initialize_fields := TRUE;
    IFEND;

    initial_value_p^.kind := clc$record;

    initial_value_p^.field_values^ [1].name := 'INSTALLATION_IDENTIFIER';
    IF initialize_fields THEN
      initial_value_p^.field_values^ [1].value^.kind := clc$name;
      initial_value_p^.field_values^ [1].value^.name_value := processing_header_p^.installation_identifier;
    ELSE
      initial_value_p^.field_values^ [1].value := NIL;
    IFEND;

    initial_value_p^.field_values^ [2].name := 'PACKING_LIST';
    IF initialize_fields THEN
      initial_value_p^.field_values^ [2].value^.kind := clc$name;
      initial_value_p^.field_values^ [2].value^.name_value := processing_header_p^.packing_list_name;
    ELSE
      initial_value_p^.field_values^ [2].value := NIL;
    IFEND;

    initial_value_p^.field_values^ [3].name := 'SAVE_PREVIOUS_CYCLES';
    IF initialize_fields THEN
      initial_value_p^.field_values^ [3].value^.kind := clc$boolean;
      initial_value_p^.field_values^ [3].value^.boolean_value.value :=
            NOT (rac$delete_previous_cycles_step IN processing_header_p^.step_set);
      initial_value_p^.field_values^ [3].value^.boolean_value.kind := clc$yes_no_boolean;
    ELSE
      initial_value_p^.field_values^ [3].value := NIL;
    IFEND;

    clp$create_procedure_variable ('RAV$INSTALLATION_ENVIRONMENT', clc$xdcl_scope, clc$read_write,
          clc$immediate_evaluation, #SEQ (type_specification), initial_value_p, status);

  PROCEND create_installation_envirn_var;
?? OLDTITLE ??
?? NEWTITLE := 'create_scl_type', EJECT ??
{ PURPOSE:
{   This procedure creates an SCL user defined type based up the type
{   specification supplied on the interface parameters.
{ DESIGN:
{   In order to create an SCL type, the SCL interface to create an
{   environment variable is used.  The parameters on the interface indicate
{   that you want to create a variable of type TYPE, ie.  a "type
{   specification type".  The structure for the type being created is
{   specified as the initial value for the variable.  The initial value is a
{   CLC$TYPE_SPECIFICATION (produced by GENPDT), rather than a typical
{   value, like CLC$RECORD, or CLC$NAME.
{
{   The standard method for creating an SCL user defined type would be to
{   use GENPDT with a type declaration as can be seen in this procedure.
{   (See the sample definition for a type named RAT$SUBPRODUCT_INFORMATION
{   below).  GENPDT will produce a CYBIL variable declaration named
{   TYPE_SPECIFICATION with all the fields initialized according to the PDT
{   supplied to it.  This is also the process used to give the type being
{   created an initial value.  A PDT was created and run through GENPDT.
{   Since GENPDT always produces a variable named TYPE_SPECIFICATION, the
{   type specification to create the type and the one to give the type
{   structure cannot both reside in the same routine.  So, this routine
{   CREATE_SCL_TYPE, was created to perform the type creation.
{
{   In the code, is an example type_specification as created by GENPDT which
{   has been commented out.  Below it, is a hard coded type specification
{   variable which is initialized appropriately for whatever parameters are
{   passed to this interface (CREATE_SCL_TYPE).
{ NOTES:

  PROCEDURE create_scl_type
    (    type_name: clt$variable_name_reference;
         type_specification: ^clt$type_specification;
     VAR status: ost$status);

{ This section of commented out code shows the required input to GENPDT
{ to declare a user defined type and the resulting GENPDT output.  Note
{ that this code is not actually used in this routine. It is shown to
{ to provide reference for the code which which does declare the type.
{
{ TYPE
{   rat$subproduct_information: type
{ TYPEND
{
{ VAR
{   type_specification : [STATIC, READ, cls$declaration_section] record
{     header: clt$type_specification_header,
{     name: string (26),
{   recend := [
{     [1, 26, clc$type_specification_type], 'RAT$SUBPRODUCT_INFORMATION'];

{ The variable TYPE_SPECIFICATION_INFO is a generic version of what
{ is created by GENPDT as shown above.

    VAR
      type_specification_info: record
        header: clt$type_specification_header,
        name: ost$name,
      recend,
      initial_value: clt$data_value;

    status.normal := TRUE;

{ This code initializes TYPE_SPECIFICATION_INFO based upon the parameters
{ to this routine.  The intent is to initialize the values the same way as
{ GENPDT does in the record initialization shown above.

    type_specification_info.header.version := 1; {clc$declaration_version}
    type_specification_info.header.name_size := clp$trimmed_string_size (type_name);
    type_specification_info.header.kind := clc$type_specification_type;
    type_specification_info.name := type_name;

    initial_value.kind := clc$type_specification;
    initial_value.type_specification_value := type_specification;

    clp$create_environment_variable (type_name, clc$utility_scope, clc$read_only,
          clc$immediate_evaluation, #SEQ (type_specification_info), ^initial_value, status);

  PROCEND create_scl_type;
?? OLDTITLE ??
?? NEWTITLE := 'get_memory_for_initial_value', EJECT ??

{ PURPOSE:
{   This interface creates a CLT$DATA_VALUE record structure in the sequence
{   provided in order to initialize a SCL record variable.
{ DESIGN:
{   RESET the scratch sequence provided.  NEXT in the fields which make up
{   an initial value for an SCL record variable.  (For a record value, there
{   are three parts:  1) the base clt$data_value type, 2) a pointer to an
{   array describing each field in the record, and 3) a pointer to a record
{   to contain the value of each field.
{ NOTES:
{

  PROCEDURE get_memory_for_initial_value
    (    field_count: integer;
     VAR initial_value_p: ^clt$data_value;
     VAR scratch_sequence_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      field_counter: integer;

    RESET scratch_sequence_p;

    NEXT initial_value_p IN scratch_sequence_p;
    IF initial_value_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'EXECUTE_INSTALLER_PROCEDURE SEQUENCE',
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'initial variable values', status);
      RETURN;
    IFEND;

    NEXT initial_value_p^.field_values: [1 .. field_count] IN scratch_sequence_p;
    IF initial_value_p^.field_values = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'EXECUTE_INSTALLER_PROCEDURE SEQUENCE',
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'initial variable values', status);
      RETURN;
    IFEND;

    FOR field_counter := 1 TO field_count DO
      NEXT initial_value_p^.field_values^ [field_counter].value IN scratch_sequence_p;
      IF initial_value_p^.field_values^ [field_counter].value = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi,
              'EXECUTE_INSTALLER_PROCEDURE SEQUENCE', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'initial variable values', status);
        RETURN;
      IFEND;
    FOREND;

  PROCEND get_memory_for_initial_value;

?? OLDTITLE ??

MODEND ram$execute_installer_procs_utl;

*DECK DECK=RAM$EXPLAIN_MESSAGE EXPAND=TRUE
PROCEDURE (hum$expm) explain_message, expm (
  condition, c: status_code = $optional
  identifier, id, i: string (2) = $optional
  status: (VAR, BY_NAME) status
  clv$previous_status: (BY_NAME, HIDDEN) status = $previous_status
  )

  VAR
    condition_id_line: string
  VAREND

  IF $specified(condition) THEN
    IF ($status_code(condition) < 1000000(16)) AND $specified(identifier) THEN
      condition_name = $condition_name(condition, identifier)
    ELSE
      condition_name = $string($status_code_name(condition))
    IFEND
    explain manual = $system.manuals.messages subject=condition_name $child=help
  ELSEIF clv$previous_status.normal THEN
    explain manual=$system.manuals.nos_ve $child=help
  ELSE
    "Create the following status variable in case the specified message does not exist,
    "in which case EXPLAIN xref's clv$command_previous_status.
    VAR
      clv$command_previous_status: (XDCL) status = clv$previous_status
    VAREND
    explain manual=$system.manuals.messages subject=$condition(clv$previous_status.condition) $child=help
  IFEND

PROCEND explain_message
*DECK DECK=RAM$EXPTEXT EXPAND=TRUE
.PROC,EXPTEXT*I,
T "- Text record to expand"            = (*F),
L "- Library file name"                = (*N=#FILE,*F),
UN "- User Name of library file"       = (*N=,*F),
G "- Group file for expanded TEXT"     = (*N=,*F),
.
.HELP
 The EXPTEXT procedure EXPands TEXT records from a library to a local
 file, and deletes the record identifier. Requires the EXTRACT binaries.

 Parameter   Default   Description
   Name       Value

   t                   name of TEXT record to expand
  [l]                  library file containing the TEXT record
  [un]                 user name in which library resides
  [g]                  local file for extracted TEXT

.HELP,T
 The T parameter selects the name of the library TEXT record.
.HELP,L
 The L parameter names the file containing the TEXT record.
 The default value is the file containing this procedure.
.HELP,UN
 The UN parameter specifies the User Name location of the file.
 The default value is the User Name in which this procedure executes.
.HELP,G
 The G parameter names the file to which expanded TEXT is written.
 The default is the value specified for the T parameter.
.ENDHELP
.IFE,$G$.EQ.$$,NOLFN.
  REVERT,EX.EXPTEXT,T,L,UN,T.
.ENDIF,NOLFN.
IFE,FILE(G,AS),GOTG.
  .IFE,SYS=NOS,NOSSYS1.
    GTR(G,YYYYEXP,D,,,NA)TEXT/T
    IFE,FILE(YYYYEXP,AS),STRIPNAME.
      UNLOAD,G.
      EXTRACT,G=T/#L=YYYYEXP,#T=TXT,A.
      UNLOAD,YYYYEXP.
      REWIND,G.
    ENDIF,STRIPNAME.
  .ENDIF,NOSSYS1.
  REVERT. LOCAL FILE G FOUND
ELSE,GOTG.
  GETFILE,G,G,UN,READ.
  IFE,FILE(G,AS),GOTGPF.
    NOTE,OUTPUT,NR.+ PERMANENT FILE G FOUND, #UN=UN.
    .IFE,SYS=NOS,NOSSYS2.
      GTR(G,YYYYEXP,D,,,NA)TEXT/T
      IFE,FILE(YYYYEXP,AS),STRIPNAME.
        UNLOAD,G.
        EXTRACT,G=T/#L=YYYYEXP,#T=TXT,A.
        UNLOAD,YYYYEXP.
        REWIND,G.
      ENDIF,STRIPNAME.
    .ENDIF,NOSSYS2.
    REVERT. PERMANENT FILE G FOUND
  ENDIF,GOTGPF.
ENDIF,GOTG.
.IFE,FILE(L,.NOT.AS),NOTLOCAL.
  GETFILE,L,L,UN,READ,A=YES.
.ENDIF,NOTLOCAL.
GTR(L,YYYYEXP,D)TEXT/T
EXTRACT,G=T/#L=YYYYEXP,#T=TXT,A.
UNLOAD,YYYYEXP.
REWIND,G.
.IFE,FILE(L,.NOT.AS),FILEPRM.
  UNLOAD,L.
.ENDIF,FILEPRM.
SKIP,NOERROR.
  EXIT.
  .IFE,SYS=NOS,NOSSYS.
  $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    $EXIT. EXPTEXT *TERMINATED*
  $ENDIF,TERMINATED.
  .ENDIF,NOSSYS.
  REVERT,ABORT. TEXT T NOT FOUND
ENDIF,NOERROR.
REVERT. TEXT T FROM L --> G
/EOR
*DECK DECK=RAM$EXTERNALIZE_ACCESS_MODE EXPAND=TRUE

?? RIGHT := 110 ??
MODULE ram$externalize_access_mode;

*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc clp$create_variable
*copyc clp$read_variable
*copyc clp$write_variable
*copyc pmp$get_unique_name
*copyc rap$line_length
*copyc i#move
*copyc cld$value
*copyc pfd$permanent_file_definitions
*copyc rac$max_permit_option_index
*copyc rat$table_entry_name
*copyc rav$access_keys

?? POP ??

*copyc rah$externalize_access_mode

  PROCEDURE [XDCL, #GATE] rap$externalize_access_mode (access_mode: pft$permit_selections;
    VAR value: clt$value;
    VAR status: ost$status);

    VAR
      empty_set: [STATIC] pft$permit_selections := [],
      i: pft$permit_options,
      number_in_list: 0 .. rac$max_permit_option_index,
      selection_list: array [1 .. rac$max_permit_option_index] of rat$table_entry_name,
      string_value: ^array [1 .. * ] of cell,
      unique_name: ost$name,
      variable: clt$variable_reference,
      variable_scope: [STATIC, READ] clt$variable_scope := [clc$local_variable];


    status.normal := TRUE;

    IF access_mode = empty_set THEN
      number_in_list := 1;
      selection_list [number_in_list].value := 'NONE';
      selection_list [number_in_list].size := 4;
    ELSE
      number_in_list := 0;
      FOR i := LOWERBOUND (rav$access_keys) TO UPPERBOUND (rav$access_keys) DO
        IF i IN access_mode THEN
          number_in_list := number_in_list + 1;
          selection_list [number_in_list].value := rav$access_keys [i];
          selection_list [number_in_list].size := rap$line_length (rav$access_keys [i]);
        IFEND;
      FOREND;
    IFEND;


    pmp$get_unique_name (unique_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    unique_name (1) := '#';

    clp$create_variable (unique_name, clc$string_value, osc$max_name_size, 1, number_in_list,
          variable_scope, variable, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    value.descriptor := 'VARIABLE';
    value.kind := clc$variable_reference;
    value.var_ref := variable;

    PUSH string_value: [1 .. (#SIZE (rat$table_entry_name) * number_in_list)];
    i#move (^selection_list, string_value, (#SIZE (rat$table_entry_name) * number_in_list));
    variable.value.string_value := string_value;

    clp$write_variable (unique_name, variable.value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$read_variable (unique_name, value.var_ref, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$externalize_access_mode;
MODEND ram$externalize_access_mode
*DECK DECK=RAM$EXTERNALIZE_SHARE_MODE EXPAND=TRUE

?? RIGHT := 110 ??
MODULE ram$externalize_share_mode;

*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc clp$create_variable
*copyc clp$read_variable
*copyc clp$write_variable
*copyc pmp$get_unique_name
*copyc rap$line_length
*copyc i#move
*copyc cld$value
*copyc pfd$permanent_file_attributes
*copyc rac$max_permit_option_index
*copyc rat$table_entry_name
*copyc rav$share_keys

?? POP ??

*copyc rah$externalize_share_mode

  PROCEDURE [XDCL, #GATE] rap$externalize_share_mode (share_mode: pft$share_selections;
    VAR value: clt$value;
    VAR status: ost$status);

    VAR
      empty_set: [STATIC] pft$share_selections := [],
      i: pft$permit_options,
      number_in_list: 0 .. rac$max_permit_option_index,
      selection_list: array [1 .. rac$max_permit_option_index] of rat$table_entry_name,
      string_value: ^array [1 .. * ] of cell,
      unique_name: ost$name,
      variable: clt$variable_reference,
      variable_scope: [STATIC, READ] clt$variable_scope := [clc$local_variable];


    status.normal := TRUE;

    IF share_mode = empty_set THEN
      number_in_list := 1;
      selection_list [number_in_list].value := 'NONE';
      selection_list [number_in_list].size := 4;
    ELSE
      number_in_list := 0;
      FOR i := LOWERBOUND (rav$share_keys) TO UPPERBOUND (rav$share_keys) DO
        IF i IN share_mode THEN
          number_in_list := number_in_list + 1;
          selection_list [number_in_list].value := rav$share_keys [i];
          selection_list [number_in_list].size := rap$line_length (rav$share_keys [i]);
        IFEND;
      FOREND;
    IFEND;


    pmp$get_unique_name (unique_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    unique_name (1) := '#';

    clp$create_variable (unique_name, clc$string_value, osc$max_name_size, 1, number_in_list,
          variable_scope, variable, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    value.descriptor := 'VARIABLE';
    value.kind := clc$variable_reference;
    value.var_ref := variable;

    PUSH string_value: [1 .. (#SIZE (rat$table_entry_name) * number_in_list)];
    i#move (^selection_list, string_value, (#SIZE (rat$table_entry_name) * number_in_list));
    variable.value.string_value := string_value;

    clp$write_variable (unique_name, variable.value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$read_variable (unique_name, value.var_ref, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$externalize_share_mode;
MODEND ram$externalize_share_mode
*DECK DECK=RAM$EXTRACT EXPAND=TRUE
          IDENT  EXTRACT
          TITLE  RAM$EXTRACT - HEADER MODULE FOR PROGRAM EXTRACT
          SPACE  4
          ENTRY  EXTRACT,RFL=,SDM=
          ENTRY  SW=MMSZ,SW=MMIN,SW=STSS
          SPACE  4
SW=MMSZ   EQU    6000B       INITIAL FREE MEMORY SIZE
SW=MMIN   EQU    1000B       MINIMAL FIELD LENGTH INCREMENT
SW=STSS   EQU    1700B       DEFAULT STACK SEGMENT SIZE
          SPACE  4
EXTRACT   EQ     =XSW=MAIN
          USE    //
          BSS    SW=MMSZ
RFL=      BSS    0
SDM=      EQU    0
          SPACE  4
          END
*DECK DECK=RAM$EXTRACT_RECORDS_FROM_LIB EXPAND=TRUE
?? right := 110, fmt (keyw := lower, ident := lower) ??
?? push(list := on) ??

module extract_records_from_library alias 'mextrac';

{ Author : John Farr -- May 4, 1979. }

{}
{    EXTRACT is a program that enables easy retrieval of records
{ from permanent file (or local) libraries.
{
{    Although the program  is  designed  primarily  for  use  in
{ procedure files, it can be very useful on its own.
{
{    EXTRACT is  similar in function to the NOS "GTR" statement.
{ It differs from "GTR" in the following ways:
{
{    o  EXTRACT insists that the library to be  searched  has  a
{       directory  (this  can  be  built  using  the NOS utility
{       "LIBEDIT").
{
{    o  The record type parameter for EXTRACT, if given, applies
{       to  all  records to be extracted, and if not given, only
{       the names of the records are  used  when  searching  the
{       library.
{
{    o  Each extracted record is copied to its own local file by
{       EXTRACT, rather than all to the same file.
{
{    o  EXTRACT does not insist that the library to be  searched
{       be  local  to the job when it's called, but will ACQUIRE
{       the library from a permanent file catalog.
{
{
{    The control statement format is:
{
{
{           EXTRACT(lfn1=rn1,lfn2=rn2,.../op1,op2,...)
{
{ lfni   Is the local file name given to the  record  once  it's
{        extracted   (lfni  is  REWOUND  before  and  after  the
{        extraction takes place).
{
{ rni    Is the name of the record to be extracted (if  omitted,
{        it is assumed to be the same as lfni).
{
{ opi    These parameters   specify  options  that  control  the
{        extraction process :
{
{        A            Specifies that if a record is  not  found,
{                     the program should abort.
{
{        NA           Is the   opposite   of   A   (and  is  the
{                     default).
{
{        T=rt         Specifies the record type  (if  given,  it
{                     applies to all records being extracted; if
{                     omitted, only the record  names  are  used
{                     when searching the library).
{
{        L=libname    Specifies the  name  of  the library to be
{                     searched  for  the  records  (if  omitted,
{                     "PROCLIB" is assumed).
{
{        LFN=liblfn   Specifies the  local  file  name  for  the
{                     library (if omitted,  the  "libname"  from
{                     the  L  paraeter is used).  Note that this
{                     is the name used  to  make  the  "is  file
{                     local?" test when ACQUIRing the library.
{
{        UN=un        Specifies the  user  name of the permanent
{                     file catalog to be searched for  "libname"
{                     if it's not already local (if omitted, the
{                     current user is assumed).
{
{        PW=pw        Specifies the  library's  permanent   file
{                     password.
{
{        PN=pn        Specifies the   library's  permanent  file
{                     packname.
{
{
{    Valid record type  designators  are  documented  under  the
{ description  of  the  "CATALOG"  control  statement in the NOS
{ Reference Manual.
{
{    In addition to  these  standard  types,  there's  one  more
{ "type"  processed  by  EXTRACT,  which is designated by "TXT".
{ This "type" is  used  to  denote  "TEXT"  records  that,  when
{ extracted,  are  to  have their first line (which contains the
{ record's  name)  "stripped  off".   This  is  useful  if,  for
{ example,  one  has  records  containing  directives  for a NOS
{ utility, in which case the name of such a  record  is  in  all
{ likelihood an illegal directive to the utility program.
{
{
{    EXTRACT will abort under any of the following conditions:
{
{    o  format or argument error(s) on the control statement
{
{    o  the specified library could not be AQUIREd
{
{    o  the library  file  does not have a directory as the last
{       record before end-of-information
{
{    Note, however, that EXTRACT won't abort if it does not find
{ any  of  the  requested  records  (only an informative dayfile
{ message is issued), unless the Abort parameter  was  coded  on
{ the call.
{
{    If  the  library file was not local to the job when EXTRACT
{ was called,  it  will  be  RETURNed  when  EXTRACT  terminates
{ normally;  but,  if  the  library file was local, EXTRACT will
{ REWIND it prior to normal termination.
{}

  ?? eject ??
*copyc pxiotyp
*copyc bizopen
*copyc bizclos
*copyc bizget
*copyc bizput
*copyc fzwords
*copyc fzmark
*copyc pxziobs

*copyc zuttpfd
*copyc zn7pcio
*copyc zn7pwnb

*copyc zuttdcn
*copyc zutcdcn
*copyc zn7tsrt
*copyc zn7tjca
*copyc zn7prdr
*copyc zutpaqr
*copyc zutpdcg
*copyc zutpdci
*copyc zutpdcp
*copyc zutpdns
*copyc zutpmsg
*copyc zutpabt
*copyc zn7pmsg

  ?? eject ??

  program extract;

    const
      any_type = - 2,
      txt_type = - 1;

    var
      jca alias 'sw=ra0': [xref] n7t$job_communication_area,
      ccdr_src_ptr: cell,
      ccdr_dest_ptr: cell,
      ccdr_ch: 0 .. 3f(16),
      arg_keys: [static] array[0 .. 7] of utt$dc_name := [utc$dc_a, utc$dc_na, utc$dc_t, utc$dc_lfn, utc$dc_l,
        utc$dc_un, utc$dc_pw, utc$dc_pn],
      lib_args: [static] array[3 .. 7] of string (7) := ['  ', 'PROCLIB', '  ', '  ', '  '],
      key_index: 0 .. 7,
      record_type_table: [static, read] array[0 .. 13] of record
        name: utt$dc_name,
        code: txt_type .. n7c$proc,
      recend := [[utc$dc_txt, txt_type], [utc$dc_text, n7c$text], [utc$dc_pp, n7c$pp], [utc$dc_cos, n7c$cos],
        [utc$dc_rel, n7c$rel], [utc$dc_ovl, n7c$ovl], [utc$dc_ulib, n7c$ulib], [utc$dc_opl, n7c$opl],
        [utc$dc_oplc, n7c$oplc], [utc$dc_opld, n7c$opld], [utc$dc_abs, n7c$abs], [utc$dc_ppu, n7c$ppu],
        [utc$dc_cap, n7c$cap], [utc$dc_proc, n7c$proc]],
      record_type_index: 0 .. 13,
      requested_record_type: [static] any_type .. n7c$proc := any_type,
      actual_record_type: n7c$text .. n7c$proc,
      lfn_rn_table: array[1 .. 50] of record
        lfn: utt$dc_name,
        rn: utt$dc_name,
      recend,
      num_records: [static] 0 .. 50 := 0,
      record_index: 1 .. 50,
      record_file: file,
      lib_file: file,
      record_lfn: string (7),
      ignore_length: 0 .. 7,
      skip_text_record_name: cell,
      copy_buffer: array[0 .. 400(16)] of cell,
      words_read: integer,
      f_mark: file_mark,
      record_not_found: [static] boolean := false,
      sep_codes: [static, read] string (64) :=
        ',,=/(+-~;~~~~~~,~~~~~~~~~~~~~~~~~~~~~+-*/(~$=~,,#[]%"_!&''?<>@\^;',
      arg: utt$dc_name,
      sep: char,
      arg_index: [static] integer := 0,
      arg_count: integer,
      abort_when_record_not_found: [static] boolean := false,
      acquire_response: utt$acquire_response_codes,
      directory_index: integer,
      directory_ptr: ^n7t$opld_directory,
      lib_file_desc_ptr: ^utt$pascalx_file_descriptor;

    const
      format_error = '- FORMAT ERROR';

    var
      not_found_message: [static] string (30) := '- CAN''T FIND RECORD - ',
      missing_directory_message: [static] string (39) := '- MISSING OR BAD DIRECTORY ON - ';



    procedure next_arg;

      arg_index := arg_index + 1;
      if arg_index <= arg_count then
        arg := jca.argr[arg_index].arg;
        sep := sep_codes (jca.argr[arg_index].sep + 1);
      ifend;
      if (arg_index > arg_count) or (arg = 0) then
        utp$issue_dayfile_message (format_error);
        utp$abort;
      ifend;

    procend next_arg;



    var
      ccdr_dest_ptr_int_ptr: ^integer,
      ccdr_src_ptr_int_ptr: ^integer;

    arg_count := jca.actr;
    if (arg_count > 0) and (jca.argr[jca.actr].sep = 0) then
    /suppress_password/
      begin
        utp$create_dc_string_ptr (#loc (jca.ccdr), 0, ccdr_src_ptr);
        repeat
          utp$get_next_dc_char (ccdr_src_ptr, ccdr_ch);
          if ccdr_ch = 0 then
            exit /suppress_password/;
          ifend;
        until ccdr_ch = 28(16) {/} ;
      /find_password/
        while true do
          utp$get_next_dc_char (ccdr_src_ptr, ccdr_ch);
          if ccdr_ch = 0 then
            exit /suppress_password/;
          ifend;
          if ccdr_ch <> 10(16) {P} then
            cycle /find_password/;
          ifend;
          ccdr_dest_ptr := ccdr_src_ptr;
          utp$get_next_dc_char (ccdr_src_ptr, ccdr_ch);
          if ccdr_ch = 0 then
            exit /suppress_password/;
          ifend;
          if ccdr_ch <> 17(16) {W} then
            ccdr_src_ptr := ccdr_dest_ptr;
            cycle /find_password/;
          ifend;
          utp$get_next_dc_char (ccdr_src_ptr, ccdr_ch);
          if ccdr_ch = 0 then
            exit /suppress_password/;
          ifend;
          if ccdr_ch = 2c(16) {=} then
            exit /find_password/;
          ifend;
          ccdr_src_ptr := ccdr_dest_ptr;
        whilend /find_password/;
        ccdr_dest_ptr := ccdr_src_ptr;
        repeat
          utp$get_next_dc_char (ccdr_src_ptr, ccdr_ch);
        until (ccdr_ch >= 25(16)) and (ccdr_ch <> 27(16));
        repeat
          utp$insert_next_dc_char (ccdr_dest_ptr, ccdr_ch);
          utp$get_next_dc_char (ccdr_src_ptr, ccdr_ch);
        until ccdr_ch = 0;
        ccdr_dest_ptr_int_ptr := #loc (ccdr_dest_ptr);
        ccdr_src_ptr_int_ptr := #loc (ccdr_src_ptr);
        while ccdr_dest_ptr_int_ptr^ <> ccdr_src_ptr_int_ptr^ do
          utp$insert_next_dc_char (ccdr_dest_ptr, 0);
        whilend;
      end /suppress_password/;
      n7p$issue_dayfile_message (#loc (jca.ccdr), 3);
    else
      if arg_count = 0 then
        n7p$issue_dayfile_message (#loc (jca.ccdr), 3);
      ifend;
    ifend;

    repeat
      num_records := num_records + 1;
      next_arg;
      lfn_rn_table[num_records].lfn := arg;
      if sep = '=' then
        next_arg;
      ifend;
      lfn_rn_table[num_records].rn := arg;
      if sep = '=' then
        utp$issue_dayfile_message (format_error);
        utp$abort;
      ifend;
    until (sep = '/') or (arg_index = arg_count);

  /advance_arg/
    while arg_index < arg_count do
      next_arg;
      for key_index := 0 to 7 do
        if arg_keys[key_index] = arg then
          if ((key_index <= 1) and (sep = '=')) or ((key_index > 1) and (sep <> '=')) then
            utp$issue_dayfile_message (format_error);
            utp$abort;
          ifend;
          if key_index > 1 then
            next_arg;
            if sep = '=' then
              utp$issue_dayfile_message (format_error);
              utp$abort;
            ifend;
          ifend;
          case key_index of
          =0 .. 1=
            arg_keys[0] := 0;
            arg_keys[1] := 0;
            abort_when_record_not_found := key_index = 0;
          =2=
            arg_keys[2] := 0;
            for record_type_index := 0 to 13 do
              if record_type_table[record_type_index].name = arg then
                requested_record_type := record_type_table[record_type_index].code;
                if requested_record_type <> txt_type then
                  actual_record_type := requested_record_type;
                else
                  actual_record_type := n7c$text;
                ifend;
                cycle /advance_arg/;
              ifend;
            forend;
            utp$issue_dayfile_message ('- INVALID RECORD TYPE');
            utp$abort;
          =3 .. 7=
            arg_keys[key_index] := 0;
            utp$convert_dc_name_to_string (arg, lib_args[key_index], ignore_length);
          casend;
          cycle /advance_arg/;
        ifend;
      forend;
      utp$issue_dayfile_message ('- ARGUMENT ERROR');
      utp$abort;
    whilend /advance_arg/;

    if lib_args[3] = '       ' then
      lib_args[3] := lib_args[4];
    ifend;
    utp$acquire_file (lib_args[3], lib_args[4], lib_args[5], lib_args[6], lib_args[7], n7c$pfm_m_read,
      utc$acquire_anywhere, acquire_response);
    if acquire_response = utc$acquire_error then
      utp$abort;
    else
      if acquire_response = utc$acquire_not_found then
        not_found_message (14, 10) := 'LIBRARY - ';
        not_found_message (24, 7) := lib_args[4];
        utp$issue_dayfile_message (not_found_message);
        utp$abort;
      ifend;
    ifend;

    px#iobs := 401(16);
    bi#open (lib_file, lib_args[3], old#, input#, asis#);
    lib_file_desc_ptr := #loc (lib_file^);
    lib_file_desc_ptr^.fet.random := true;
    lib_file_desc_ptr^.fet.extension_length := 2;
    n7p$get_opld_directory (lib_file, directory_ptr);
    if directory_ptr = nil then
      if acquire_response = utc$acquire_was_local then
        bi#close (lib_file, first#);
      else
        bi#close (lib_file, return#);
      ifend;
      missing_directory_message (33, 7) := lib_args[4];
      utp$issue_dayfile_message (missing_directory_message);
      utp$abort;
    ifend;

  /next_record/
    for record_index := 1 to num_records do
      for directory_index := lowerbound (directory_ptr^) to upperbound (directory_ptr^) do
        if (lfn_rn_table[record_index].rn = directory_ptr^[directory_index].record_name) and
          ((requested_record_type = any_type) or (actual_record_type = directory_ptr^[directory_index].
            record_type)) then
          n7p$wait_not_busy (#loc (lib_file_desc_ptr^.fet));
          lib_file_desc_ptr^.control.initial_read := true;
          lib_file_desc_ptr^.fet.rr := directory_ptr^[directory_index].random_address;
          if requested_record_type = txt_type then
            bi#get (lib_file, #loc (skip_text_record_name), 1);
          ifend;
          utp$convert_dc_name_to_string (lfn_rn_table[record_index].lfn, record_lfn, ignore_length);
          bi#open (record_file, record_lfn, old#, output#, first#);
          repeat
            bi#get (lib_file, #loc (copy_buffer), #size (copy_buffer));
            f#words (lib_file, words_read);
            if words_read > 0 then
              bi#put (record_file, #loc (copy_buffer), words_read);
            ifend;
            f#mark (lib_file, f_mark);
          until f_mark <> data#;
          bi#close (record_file, first#);
          cycle /next_record/;
        ifend;
      forend;
      record_not_found := true;
      utp$convert_dc_name_to_string (lfn_rn_table[record_index].rn, not_found_message (23, 7), ignore_length);
      utp$issue_dayfile_message (not_found_message);
      if abort_when_record_not_found then
        exit /next_record/;
      ifend;
    forend /next_record/;

    if acquire_response = utc$acquire_was_local then
      bi#close (lib_file, first#);
    else
      bi#close (lib_file, return#);
    ifend;
    if abort_when_record_not_found and record_not_found then
      utp$abort;
    ifend;

  procend extract;

  ?? eject ??
{ The following procedure replaces the "standard" program initializer
{ contained in the run-time library.  Unlike the standard version this
{ one does not open file OUTPUT (or any other file for that matter)
{ for two reasons: 1. doing so may be an anomaly if the program is
{ to acquire file OUTPUT; and 2. any errors detected by the reprieve
{ processor will now show up only in the dayfile.
{ The same procedure names as those in the run-time library are used
{ so that correlation is made easier.


  procedure [xdcl] crunrma alias 'sw=mama';

*copyc pxiotyp

    procedure [xref] rpvinit alias 'sw=erri' (fileptr: ^file;
      procptr: ^procedure);

    rpvinit (nil, nil);

  procend crunrma;

modend extract_records_from_library;
*DECK DECK=RAM$FIND_STRING_COMMAND EXPAND=TRUE
MODULE ram$find_string_command;

*copyc amp$get_next
*copyc amp$put_next
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc nlp$name_match

  PROGRAM rap$find_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ram$fins) find_pdt (
{   search_string, ss: string = $required
{   input, i: file = $required
{   output, o: file = $required
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 6] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 5, 16, 18, 2, 15, 546], clc$command, 6, 3, 3, 0, 0,
            0, 0, 'RAM$FINS'], [['I                              ',
            clc$abbreviation_entry, 2], ['INPUT                          ',
            clc$nominal_entry, 2], ['O                              ',
            clc$abbreviation_entry, 3], ['OUTPUT                         ',
            clc$nominal_entry, 3], ['SEARCH_STRING                  ',
            clc$nominal_entry, 1], ['SS                             ',
            clc$abbreviation_entry, 1]], [
{ PARAMETER 1
      [5, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 8,
            clc$required_parameter, 0, 0],
{ PARAMETER 2
      [2, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$required_parameter, 0, 0],
{ PARAMETER 3
      [4, clc$normal_usage_entry, clc$non_secure_parameter,
            $clt$parameter_spec_methods [clc$specify_by_name,
            clc$specify_positionally], clc$pass_by_value,
            clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$required_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],
{ PARAMETER 2
      [[1, 0, clc$file_type]],
{ PARAMETER 3
      [[1, 0, clc$file_type]]];

?? POP ??

    CONST
      p$search_string = 1,
      p$input = 2,
      p$output = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    TYPE
      work_files = (input_file, output_file);

    VAR
      file: work_files,
      file_identifier: array [work_files] of amt$file_identifier,
      ignore_byte_address: amt$file_byte_address,
      input_line: string (255),
      local_status: ost$status,
      output_line: ost$string,
      position_of_file: amt$file_position,
      search_string: ^nat$title_pattern,
      transfer_count: amt$transfer_count;

    PROCEDURE open_files
      (VAR local_status: ost$status);

      VAR
        file_attachment: array [1 .. 3] of fst$attachment_option;

      file_attachment [1].selector := fsc$access_and_share_modes;
      file_attachment [1].access_modes.selector := fsc$specific_access_modes;
      file_attachment [1].access_modes.value :=
            $fst$file_access_options [fsc$read];
      file_attachment [1].share_modes.selector := fsc$specific_share_modes;
      file_attachment [1].share_modes.value :=
            $fst$file_access_options [fsc$read, fsc$execute];
      file_attachment [2].selector := fsc$open_share_modes;
      file_attachment [2].open_share_modes :=
            $fst$file_access_options [fsc$read, fsc$execute];
      file_attachment [3].selector := fsc$create_file;
      file_attachment [3].create_file := FALSE;

      fsp$open_file (pvt [p$input].value^.file_value^, amc$record,
            ^file_attachment, NIL, NIL, NIL, NIL, file_identifier [input_file],
            local_status);
      IF NOT local_status.normal THEN
        RETURN;
      IFEND;

      file_attachment [1].selector := fsc$access_and_share_modes;
      file_attachment [1].access_modes.selector := fsc$specific_access_modes;
      file_attachment [1].access_modes.value :=
            $fst$file_access_options [fsc$append, fsc$shorten];
      file_attachment [1].share_modes.selector := fsc$specific_share_modes;
      file_attachment [1].share_modes.value := $fst$file_access_options [];
      file_attachment [2].selector := fsc$access_and_share_modes;
      file_attachment [2].access_modes.selector := fsc$specific_access_modes;
      file_attachment [2].access_modes.value :=
            $fst$file_access_options [fsc$append];
      file_attachment [2].share_modes.selector := fsc$specific_share_modes;
      file_attachment [2].share_modes.value := $fst$file_access_options [];
      file_attachment [3].selector := fsc$open_share_modes;
      file_attachment [3].open_share_modes := -$fst$file_access_options [];

      fsp$open_file (pvt [p$output].value^.file_value^, amc$record,
            ^file_attachment, NIL, NIL, NIL, NIL,
            file_identifier [output_file], local_status);
      IF NOT local_status.normal THEN
        fsp$close_file (file_identifier [input_file], local_status);
        RETURN;
      IFEND;
    PROCEND open_files;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH search_string: [clp$trimmed_string_size
          (pvt [p$search_string].value^.string_value^)];
    search_string^ := pvt [p$search_string].value^.string_value^;
    open_files (local_status);
    IF NOT local_status.normal THEN
      status := local_status;
      RETURN;
    IFEND;

  /process_input_file/
    WHILE TRUE DO
      amp$get_next (file_identifier [input_file], ^input_line,
            osc$max_string_size, transfer_count, ignore_byte_address,
            position_of_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF position_of_file = amc$eoi THEN
        EXIT /process_input_file/;
      IFEND;
      IF nlp$name_match (search_string^, input_line (1, transfer_count)) THEN
        amp$put_next (file_identifier [output_file], ^input_line
              (1, transfer_count), transfer_count, ignore_byte_address,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    WHILEND /process_input_file/;

    FOR file := LOWERVALUE (file) TO UPPERVALUE (file) DO
      fsp$close_file (file_identifier [file], local_status);
      IF (NOT local_status.normal) AND status.normal THEN
        status := local_status;
      IFEND;
    FOREND;

  PROCEND rap$find_command;
MODEND ram$find_string_command;
*DECK DECK=RAM$FIND_STRING_COMMAND_PD EXPAND=TRUE
create_program_description n=(find_string fins) sp=rap$find_command ..
      l=osf$current_library lm=$null lmo=none tel=error pv=zero ..
      af=$null dm=off
*DECK DECK=RAM$FORMAT_SCL_PROC EXPAND=TRUE
create_program_description name=(format_scl_procedure format_scl_procedures ..
                                 format_scl_proc format_scl_procs forsclp forsp) ..
      sp=clp$format_scl_proc l=('$system.osf$system_library' osf$task_services_library) ..
      tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$GENCAT EXPAND=TRUE
          IDENT  GENCAT,FETS
          TITLE  RAM$GENCAT
          ABS
          ENTRY  GENCAT
          ENTRY  RFL=
          ENTRY  SSM=
          SST
          SYSCOM B1          DEFINE (B1) = 1
          TITLE  CATALOG - CATALOG FILE.
*COMMENT  CATALOG FILE.
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992.
          SPACE  4
***       CATALOG - CATALOG FILES.
*         G. R. MANSFIELD.  70/12/20.
*         J. B. FARR.       79/05/03.  -  ADD *LO* ARGUMENT
          SPACE  4
***              CATALOG LISTS PERTINENT INFORMATION ABOUT EACH RECORD
*         OF A BINARY MEDIUM.
*
*         THIS INFORMATION INCLUDES -
*
*         1)  THE RECORD NUMBER COUNTING FROM THE BEGINNING OF THE FILE.
*         2)  THE NAME FROM THE FIRST WORD OF THE RECORD OR THE SECOND
*                WORD OF THE  *77*  TABLE IF IT IS PRESENT.
*         3)  THE RECORD TYPE.
*         4)  LENGTH OF THE PARTICULAR RECORD ( EXCLUDING THE  *77*
*                TABLE ).
*         5)  CHECKSUM OF THE RECORD, EXCLUDING *77* TABLE, IF PRESENT.
*         6)  CONTENTS OF THE  *77*  TABLE, IF ANY.
*         7)  OTHER PERTINENT INFORMATION, ACCORDING TO RECORD TYPE.
*
*
*         THE FOLLOWING RECORD TYPES ARE RECOGNIZED.
*
*         TYPE   DESCRIPTION
*
*         TEXT   UNIDENTIFIED AS ANY OTHER TYPE.
*         PP     6000, CYBER 72/73/74, CYBER 170 PP PROGRAM.
*         COS    CHIPPEWA FORMAT CENTRAL PROGRAM.
*         REL    RELOCATABLE CENTRAL PROGRAM.
*         OVL    ABSOLUTE OVERLAY PROGRAM, NO ENTRY POINTS DEFINED.
*         ULIB   USER LIBRARY TYPE RECORD.
*         OPL    MODIFY PROGRAM LIBRARY DECK RECORD.
*         OPLC   MODIFY PROGRAM LIBRARY COMMON DECK RECORD.
*         OPLD   MODIFY PROGRAM LIBRARY DIRECTORY.
*         ABS    ABSOULTE OVERLAY PROGRAM, WITH ENTRY POINTS DEFINED.
*         PPU    7600, CYBER 76 TYPE PPU PROGRAM.
*         CAP    FAST DYNAMIC LOAD CAPSULE.
*         PROC   PROCEDURE TYPE RECORD.
*
*
*         A RECORD OF *REL* FORMAT WILL HAVE THE ENTRY POINTS LISTED.
*
*         A RECORD OF *TEXT* FORMAT WILL BE LISTED IF THE NAME
*                OF THE RECORD BEGINS WITH *CMRDECK*, *IPRDECK*
*                *LIBDECK*, *CMRDC*, *IPRDC*, OR *LIBDC*.
*                IF *OVERLAY*, THE FIRST LINE ONLY IS LISTED.
*
*         A RECORD OF *OPL* OR *OPLC* FORMAT WILL HAVE THE MODIFIERS
*                AND THEIR  *YANK*  STATUS LISTED.  IF SELECTED THE
*                CHARACTER SET OF THE INDIVIDUAL OPL/OPLC WILL BE
*                LISTED IMMEDIATELY FOLLOWING THE RECORD TYPE.
*
*         A RECORD OF *ULIB* FORMAT WILL SUPPRESS LISTING OF FOLLOWING
*                RECORDS IN *REL* FORMAT UNLESS -U- OPTION IS USED.
          SPACE  4
***       CONTROL CARD CALL.
*
*
*         GENCAT(FNAME,P1,P2,...,PN)
*
*         FNAME  NAME OF FILE TO BE CATALOGED.
*
*         *PN*  ONE OF THE FOLLOWING -
*
*         N      CATALOG TO EOI.
*         N=0    CATALOG TO EMPTY FILE.
*         N=X    CATALOG  *X*  FILES.
*
*         L=LFN  LIST OUTPUT ON FILE  *LFN*.
*
*         U      SELECT DETAILED USER LIBRARY LIST.
*
*         D      DESELECT DETAILED LIST, NORMALLY SELECTED FOR
*                *TXOT*  JOBS.
*
*         R      REWIND  *FNAME*  FILE BEFORE AND AFTER CATALOG.
*
*         CS     DE-SELECT CHARACTER SET LIST FOR OPL/OPLC RECORDS.
*
*         LO=N   PRODUCE OUTPUT AS DESCRIBED ABOVE
*         LO=S   PRODUCE OUTPUT CONTAINING ONLY RECORD
*                NAME AND TYPE (4 PER LINE)
*         LO=D   PRODUCE OUTPUT CONSISTING OF 1 LINE PER
*                NON-EMPTY RECORD IN THE FORM OF A LIBEDIT *BEFORE*
*                DIRECTIVE SUCH THAT THE RECORDS CAN BE SORTED
*                ACCORDING TO RECORD TYPE AND NAME
*
*
*         ASSUMED OPTIONS -
*
*         OPT    VALUE
*
*         FNAME  FILE.
*         N      1.
*         L      OUTPUT.
*         U      *NOT SELECTED*.
*         D      *NOT SELECTED*.
*         R      *NOT SELECTED*.
*         CS     *SELECTED*.
*         LO     N
          SPACE  4,10
***       DAYFILE MESSAGES.
*
*
*         *FL TOO SHORT FOR CATALOG.* = NOT ENOUGH FIELD LENGTH WAS
*                ALLOWED.  (AT LEAST 6200 REQUIRED.)
*
*         *ERROR IN ARGUMENTS.* = ARGUMENT WAS NOT AS SPECIFIED ABOVE.
*
*         *ILLEGAL FILE COUNT.* = FILE COUNT WAS NOT NUMERIC.
*
*         *FILE NAME CONFLICT.* = LIST FILE NAME AND CATALOG FILE
*                NAME WERE THE SAME.
          SPACE  4
****      ASSEMBLY CONSTANTS.


 FBUFL    EQU    4011B       FILE BUFFER LENGTH
 OBUFL    EQU    2001B       OUTPUT BUFFER LENGTH
****
          SPACE  4,10
**        SPECIAL ENTRY POINT.


 SSM=     EQU    0           SUPPRESS DUMPS OF FIELD LENGTH
 OPL      XTEXT  COMCMAC
 OPL      XTEXT  COMSSRT
 READW    SPACE  4
**        READW - REDEFINE READ WORDS MACRO TO USE CONTROL WORDS.


          PURGMAC READW

 READW    MACRO F,S,N
          R=     B6,S
          R=     B7,N
          R=     X2,F
          RJ     RDA
          ENDM
          SPACE  4
          TITLE  STORAGE ASSIGNMENT.
**        FETS.


          ORG    110B
 FETS     BSS    0

 O        BSS    0
 OUTPUT   FILEC  OBUF,OBUFL,FET=7,EPR

          CON    0           WORDS REMAINING IN BLOCK (F)
          CON    0           EOR FLAG
 F        BSS    0
 FILE     FILEB  FBUF,FBUFL,FET=7
          SPACE  4
*         COMMON DATA.


 RW       CON    0           REWIND FLAG
 CW       CON    0           CONTROL WORD FLAG (1 = CONTROL WORDS)
 FC       CON    0L1         FILE COUNT
 EF       CON    0           EMPTY FILE FLAG
 NSFF     CON    0           NONSTANDARD FILE FLAG
 RN       CON    0           RECORD NUMBER
 FN       CON    1           FILE NUMBER
 CS       CON    0           CHECKSUM
 RL       CON    0           RECORD LENGTH
          CON    0           ZERO RECORD SUBTOTAL
          CON    0           FILE LENGTH
 NM       CON    0           RECORD NAME
 TY       CON    0           RECORD TYPE
 UL       CON    0,0         USER LIBRARY LIST FLAG
 LN       CON    1           LIBRARY NUMBER

*         LIST DATA.

 SL       CON    0           SHORT LIST FLAG
 LC       CON    LINP+4      LINE COUNT
 PN       CON    1           PAGE NUMBER
 CSM      CON    1           OPL CHARACTER SET LIST FLAG
 TF       CON    0           TERMINAL FLAG
 LO       CON    0           LIST OPTION DESIGNATOR - -1 (LO=D)
*                                                   -  0 (LO=N)
*                                                   -  1 (LO=S)

 TITL     DATA   1H1
          DATA   10HCATALOG OF
          DATA   1H
          DATA   4AFILE
          DATA   5A1
          DATA   10H
 TITLA    DATA   10H
 DATE     DATA   1H
 TIME     DATA   1H
          DATA   4APAGE
 PAGE     DATA   8L
 TITLL    EQU    *-TITL


 SBTL     DATA   6AREC
          DATA   4HNAME
          DATA   5HTYPE
          DATA   8ALENGTH
          DATA   7ACKSUM
          DATA   7ADATE
 SBTLA    DATA   8ACOMMENTS
          DATA   0
          DATA   2L
 SBTLL    EQU    *-SBTL
          TITLE  MAIN PROGRAM.
 GENCAT   SPACE  4
**        GENCAT - MAIN PROGRAM.


 GENCAT   SB1    1           (B1) = 1
          RJ     PRS         PRESET PROGRAM
          SA1    RW
          ZR     X1,CAT0.1   IF NO REWIND
          REWIND F

 CAT0.1   SA1    CW
          ZR     X1,CAT1.1   IF NOT CONTROL WORDS
          MX6    1           SET FIRST READ FLAG
          SA6    F-2
          READCW F,17B
          JP     CAT1.2

 CAT1     SA1    CW
          NZ     X1,CAT1.2   IF CONTROL WORDS
 CAT1.1   READ   F
 CAT1.2   BSS    0
          SA1    RN          ADVANCE RECORD NUMBER
          SX6    X1+B1
          MX7    0           CLEAR LENGTH
          SA6    A1
          SA7    RL
          SA7    CS          CLEAR CHECKSUM
          RJ     RDR         READ RECORD
          SA4    RL          ADVANCE SUBTOTAL
          NZ     X4,CAT0     IF NON-ZERO RECORD
          NG     X1,CAT3     IF EOF
 CAT0     SA2    A4+B1
          SA3    A2+B1       ADVANCE FILE TOTAL
          IX6    X2+X4
          SA6    A2
          IX7    X3+X4
          SA7    A3
          SA1    UL+1
          ZR     X1,CAT2     IF NOT USER LIBRARY
          SA2    TY          CHECK TYPE
          SB2    X2-10B
          NZ     B2,CAT1     IF NOT *OPLD*
          BX6    X6-X6       CLEAR USER LIBRARY
          SA6    A1
          EQ     CAT1


 CAT2     RJ     LRS         LIST RECORD STATUS
          SA1    LO          CHECK LIST OPTION
          NZ     X1,CAT1     IF LO=S OR LO=D
          SA1    TY          PROCESS OTHER LIST
          MX7    0           CLEAR EOF FLAG
          SB7    X1
          SA7    EF
          JP     CATB+B7

 CAT3     SX1    X1+B1
          BX5    -X1         PROCESS END OF FILE
          RJ     EOF
          SA1    FC          CHECK FILE COUNT
          NZ     X1,CAT4     IF NOT EMPTY FILE REQUEST
          SA2    EF          CHECK EOF
          NZ     X2,CAT5     IF EMPTY FILE
          SX6    X2+B1       SET EOF FLAG
          SA6    A2
          JP     CAT0.1

 CAT4     SX2    1           DECREMENT FILE COUNT
          IX6    X1-X2
          SA6    A1
          NZ     X5,CAT5     IF EOI
          NZ     X6,CAT0.1   IF MORE FILES REQUESTED

 CAT5     BSS    0           PAGE NUMBER CHECK DELETED
 CAT6     WRITER O
          SA1    RW
          ZR     X1,CAT7     IF NO REWIND
          REWIND F
 CAT7     MESSAGE (=C* GENCAT COMPLETE.*)
          ENDRUN

 CATA     DATA   10HCATALOGING
          DATA   0

 CATB     BSS    0
          LOC    0
          EQ     TXT         TEXT
          EQ     CAT1        PP
          EQ     CAT1        COS
          EQ     REL         REL
          EQ     CAT1        OVL
          EQ     ULB         ULIB
          EQ     OPL         OPL
          EQ     OPL         OPLC
          EQ     CAT1        OPLD
          EQ     ABS         ABS
          EQ     CAT1        PPU
          EQ     TXT         UNDEFINED RECORD TYPE
          EQ     TXT         UNDEFINED RECORD TYPE
          EQ     TXT         UNDEFINED RECORD TYPE
          EQ     CAP         CAP
          EQ     TXT         UNDEFINED RECORD TYPE
          EQ     TXT         PROC
          LOC    *O
 EOF      SPACE  4
**        EOF - PROCESS END OF FILE.


 EOF      PS                 ENTRY/EXIT
          SA1    LO          CHECK LIST OPTION
          NZ     X1,EOF3     IF LO=S OR LO=D
          SA2    NSFF        CHECK FOR NONSTANDARD FILE
          ZR     X2,EOF0     IF NOT NONSTANDARD FILE
          BX6    X6-X6
          SX1    EOFB        LIST *EOR MISSING* MESSAGE
          SA6    A2
          RJ     WOF
 EOF0     SX1    =C*  *      LIST BLANK LINE
          RJ     WOF
          ZR     X5,EOF1     IF EOF
          SA1    =10H
          BX6    X1
          EQ     EOF2

 EOF1     SA1    RN          CONVERT RECORD NUMBER
          RJ     CDD
 EOF2     LX6    18
          SA6    SBUF
          SA1    X5+EOFA
          SA2    =6ASUM =
          BX6    X1
          LX7    X2
          SA6    A6+B1
          SA7    A6+B1
          SA1    RL+2        CONVERT TOTAL LENGTH
          RJ     COD
          LX6    12
          MX7    0
          SA6    A7+B1
          SA7    A6+B1
          SX1    SBUF
          RJ     WOF
          SA1    FN          ADVANCE FILE NUMBER
          SX6    LINP        FORCE EJECT
          SX7    X1+B1
          SA6    LC
          SA7    A1
          SX1    X1+B1       CONVERT NUMBER
          RJ     CDD
          LX6    5*6
          SX7    B0          CLEAR LENGTHS
          SA6    TITL+4
          SA7    RL+1
          SA7    A7+B1
          SX6    B1          RESET LIBRARY NUMBER
          SA7    RN          CLEAR RECORD NUMBER
          SA6    LN
          EQ     EOF         RETURN

*         HANDLE EOF/EOI FOR LO=S OR LO=D

 EOF3     BSS    0
          NG     X1,EOF4     IF LO=D
          SA1    NEXTRS
          ZR     X1,EOF4     IF NO LINE TO COMPLETE
          WRITES O,RSBUF,X1  WRITE SHORT LINE
          MX6    0           RESET TO START OF LINE
          SA6    NEXTRS

 EOF4     BSS    0           CLEAR LENGTHS, REC NUM, AND LINE NUM
          MX7    0
          SA7    RL
          SA7    A7+B1
          SX6    B1
          SA7    RN
          SA6    LN
          EQ     EOF         RETURN


 EOFA     DATA   10H* EOF *
          DATA   10H* EOI *

 EOFB     DATA   C+          *EOR MISSING*+
 LRS      SPACE  4
**        LRS - LIST RECORD STATUS.
*
*         ENTRY  (BUF) = FIRST BLOCK OF RECORD.
*                (NM) = RECORD NAME.
*                (TY) = RECORD TYPE.
*                (RN) = RECORD NUMBER.
*                (RL) = RECORD LENGTH.
*                (CS) = CHECK SUM.
*                (LN) = LIBRARY NUMBER.
*
*         EXIT   (LN) = (LN)+1 IF ZERO LENGTH RECORD ENCOUNTERED.
*
*         USES   ALL REGISTERS.
*
*         CALLS  CDD, COD, SFN, WOF.


 LRS      PS                 ENTRY/EXIT
          SA5    LO          CHECK LIST OPTION
          NZ     X5,LRS15    IF LO=S OR LO=D

*         LIST RECORD STATUS   ( LO = N )

          SA1    RN          CONVERT RECORD NUMBER
          RJ     CDD
          LX6    18
          SA6    SBUF
          SA1    RL          CHECK RECORD LENGTH
          NZ     X1,LRS1     IF NOT ZERO RECORD

*         PROCESS ZERO LENGTH RECORD.

          SA1    =4H(00)     ENTER ZERO RECORD
          SA2    =6ASUM =
          BX6    X1
          LX7    X2
          SA6    A6+B1
          SA7    A6+B1
          SA1    RL+1        ENTER SUBTOTAL
          RJ     COD
          LX6    12
          SA6    A7+B1
          MX7    0           CLEAR SUBTOTAL
          SA7    A1
          SA2    =9ALIBRARY =
          SA1    LN          INCREMENT LIBRARY NUMBER
          BX6    X2
          SX7    X1+B1
          SA6    A6+B1
          SA7    A1
          RJ     CDD         DISPLAY LIBRARY NUMBER
          LX6    6
          SA6    A6+B1
          BX7    X7-X7       TERMINATE LINE
          SA7    A6+B1
          SX1    SBUF
          RJ     WOF
          SX1    =C*  *
          RJ     WOF
          EQ     LRS         RETURN

 LRS1     SA1    NM          SPACE FILL NAME
          RJ     SFN
          SA6    A6+B1
          SA1    TY          SET TYPE
          SB7    X1
          SA2    LRSA+X1
          BX6    X2
          SA6    A6+B1
          SA1    RL          CONVERT LENGTH
          RJ     COD
          LX6    12
          SA6    A6+B1

*         PROCESS CHECKSUM.

          SA2    CS          FOLD CHECKSUM
          MX3    -12
          BX1    -X3*X2
          AX2    12
          BX6    -X3*X2
          IX1    X1+X6
          AX2    12
          BX6    -X3*X2
          IX1    X1+X6
          AX2    12
          BX6    -X3*X2
          IX1    X1+X6
          AX2    12
          BX6    -X3*X2
          IX1    X1+X6
          IX7    X1+X3
          BX4    -X3*X7
          SX1    X4+10000B
          RJ     COD
          SX2    1R -1R1
          LX2    24
          IX6    X6+X2
          LX6    12
          SA6    A6+B1

*         COPY 7700 TABLE.

          SA1    BUF
          RJ     CPT
          BX7    X7-X7       TRUNCATE COMMENT FIELD
          SA7    SBUF+14B
          JP     B7+LRSB     PROCESS TYPE

 LRS4     SA1    SL          CHECK SHORT LIST FLAG
          ZR     X1,LRS5     IF NOT SET
          SX6    B0          TERMINATE LIST
          SA6    SBUF+6
 LRS5     SX1    SBUF
          RJ     WOF
          EQ     LRS         RETURN


*         PROCESS  *OPL*  AND  *OPLC*  RECORDS.

 LRS5.4   SA1    CSM         CHARACTER SET LIST MODE FLAG
          SA2    B7+LRSA     SET RECORD TYPE
          SA4    =5R         PRESET LIST
          ZR     X1,LRS5.5   IF NO CHARACTER SET LIST SET
          SA3    BUF+16B     CHECK OPL/OPLC CHARACTER SET
          MX7    -12
          BX3    -X7*X3      LOWER 12 BITS OF WORD 14 OF HEADER
          SA4    =5R(64)     PRESET FOR 64 CHARACTER SET
          SB3    X3-64B      CHECK PL CHARACTER SET
          ZR     B3,LRS5.5   IF 64 CHARACTER SET RECORD
          SA4    =5R(63)     SET 63 CHARACTER SET
 LRS5.5   BX6    X2+X4
          SA6    SBUF+2      SET IN OUTPUT LINE
*         EQ     LRS6

 LRS6     SA1    LC          CHECK LINE COUNT
          SX7    X1-LINP+6
          NG     X7,LRS4     IF NOT ROOM FOR 2 LINES
          SX6    LINP        FORCE EJECT
          SA6    A1
          EQ     LRS4

*         PROCESS PP LOAD ADDRESS.

 LRS7     SA2    BUF+B3      FIRST WORD OF PROGRAM
          SX3    10000B
          AX2    24          SET LOAD ADDRESS
          SX4    X2
          SA5    LRSA+B7
          ZR     X4,LRS8     IF LOCATION FREE
          SX4    X4+5
 LRS8     IX1    X4+X3       CONVERT LOAD ADDRESS
          MX0    -24
          RJ     COD
          BX3    -X0*X6      MERGE WITH TYPE
          LX3    12
          BX6    X5+X3
          SA6    SBUF+2
          EQ     LRS4        LIST LINE

*         PROCESS OVERLAY LEVEL NUMBERS.

 LRS9     SA2    BUF+B3      EXTRACT LEVEL NUMBERS FROM 5000 TABLE
          LX2    24
          MX0    -12
          SX1    X2+10000B   CONVERT LEVEL NUMBERS
          RJ     COD
          SA1    LRSA+B7     MERGE LEVEL AND TYPE
          BX2    -X0*X6
          LX2    6
          IX1    X1+X2
          AX6    12
          BX2    -X0*X6
          LX2    24
          IX6    X1+X2
          SA6    SBUF+2
          EQ     LRS4        LIST LINE

*         PROCESS PPU NUMBER.

 LRS11    SA2    BUF+B3      FIRST WORD OF PROGRAM
          LX2    24
          SB6    X2-100B
          SA5    LRSA+B7
          NG     B6,LRS12    IF PPU *77
          SA5    LRSC
 LRS12    SX1    X2+10000B   CONVERT PPU NUMBER
          RJ     COD
          LX6    6
          PL     B6,LRS13    IF PPU > 77
          LX6    12
 LRS13    IX6    X6+X5
          SA6    SBUF+2
          EQ     LRS4        LIST LINE

*         PROCESS USER LIBRARY.

 LRS14    SA1    UL
          ZR     X1,LRS4     IF NO USER LIBRARY LIST
          SX6    LINP        FORCE EJECT
          SA6    LC
          EQ     LRS4        LIST LINE

 LRSA     BSS    0
          LOC    0
          CON    10HTEXT
          VFD    24/4LPP (,24/0,12/2L)
          CON    10HCOS
          CON    10HREL
          VFD    24/4LOVL ,12/0,6/1L,,12/0,6/1L
          CON    10HULIB
          CON    5LOPL
          CON    5LOPLC
          CON    10HOPLD
          CON    10HABS
          CON    8HPPU (  )-8A100
          CON    10H
          CON    10H
          CON    10H
          CON    10HCAP
          CON    10H
          CON    10HPROC
          LOC    *O

 LRSB     BSS    0
          LOC    0
          EQ     LRS4        TEXT
          EQ     LRS7        PP
          EQ     LRS4        COS
          EQ     LRS6        REL
          EQ     LRS9        OVL
          EQ     LRS14       ULIB
          EQ     LRS5.4      OPL
          EQ     LRS5.4      OPLC
          EQ     LRS4        OPLD
          EQ     LRS6        ABS
          EQ     LRS11       PPU
          EQ     LRS4        UNDEFINED RECORD TYPE
          EQ     LRS4        UNDEFINED RECORD TYPE
          EQ     LRS4        UNDEFINED RECORD TYPE
          EQ     LRS6        CAP
          EQ     LRS4        UNDEFINED RECORD TYPE
          EQ     LRS4        PROC
          LOC    *O

 LRSC     CON    10HPPU (    )-6A1

*         CONSTANTS AND DATA FOR LIST OPTIONS S AND D

 RSPLIN   EQU    4             RECORD STATUSES PER LINE
 RSLEN    EQU    18            RECORD STATUS LENGTH
 RSBUFL   EQU    RSPLIN*RSLEN  RECORD STATUS BUFFER LENGTH

 NEXTRS   CON    0           INDEX IN RSBUF FOR NEXT RECORD STATUS
 RSBUF    BSS    0           RECORD STATUS BUFFER (LINE)
          DUP    RSBUFL,1    SPACE FILL BUFFER
          CON    1R

 RTT      BSS    0           RECORD TYPE TABLE
          LOC    0
          CON    4LTEXT
          CON    4LPP
          CON    4LCOS
          CON    4LREL
          CON    4LOVL
          CON    4LULIB
          CON    4LOPL
          CON    4LOPLC
          CON    4LOPLD
          CON    4LABS
          CON    4LPPU
          CON    4L
          CON    4L
          CON    4L
          CON    4LCAP
          CON    4L
          CON    4LPROC
          LOC    *O

 RTDT     BSS    0           RECORD TYPE DIRECTIVE TABLE
          LOC    0
          DIS    ,.*B *,TEXT/RECNAME   A.
          DIS    ,.*B   *,PP/          H.
          DIS    ,.*B  *,COS/          I.
          DIS    ,.*B  *,REL/          D.
          DIS    ,.*B  *,OVL/          E.
          DATA   0,0,0
          DIS    ,.*B  *,OPL/          C.
          DIS    ,.*B *,OPLC/          B.
          DATA   0,0,0
          DIS    ,.*B  *,ABS/          F.
          DIS    ,.*B  *,PPU/          G.
          DATA   0,0,0
          DATA   0,0,0
          DATA   0,0,0
          DIS    ,.*B  *,CAP/          J.
          DATA   0,0,0
          DIS    ,.*B *,PROC/          K.
          LOC    *O


 LRS15    BSS    0           PROCESS SPECIAL LIST OPTION
          SA1    RL
          ZR     X1,LRS      RETURN IF ZERO-LENGTH RECORD
          NG     X5,LRS16    IF LO=D

*         LIST RECORD STATUS  ( LO = S )

          SA1    NM          DOT FILL NAME (ALSO INSERT LEADING SPACE)
          SX2    1R
          BX1    X1+X2
          SB2    -6
          MX0    -6
          SX2    1R.

 LRS15A   BSS    0
          LX1    -6
          SB2    B2+6
          BX3    -X0*X1
          NZ     X3,LRS15B   IF FOUND LAST CHAR IN NAME
          BX1    X1+X2
          EQ     LRS15A

 LRS15B   BSS    0
          LX1    B2
          SA2    NEXTRS      COPY NAME INTO BUFFER
          SB2    X2+RSBUF
          SB3    B2+9

 LRS15C   BSS    0
          LX1    6
          BX6    -X0*X1
          SA6    B2
          SB2    B2+B1
          LE     B2,B3,LRS15C

          SA1    TY          COPY RECORD TYPE TO BUFFER
          SA1    X1+RTT
          SB3    B3+4

 LRS15D   BSS    0
          LX1    6
          BX6    -X0*X1
          SA6    B2
          SB2    B2+B1
          LE     B2,B3,LRS15D

          SA1    NEXTRS      ADVANCE BUFFER INDEX
          SX6    X1+RSLEN
          SB2    X6-RSBUFL
          NZ     B2,LRS15E   IF LINE NOT COMPLETE
          MX6    0           RESET BUFFER INDEX
          SA6    A1
          WRITES O,RSBUF,RSBUFL
          EQ     LRS         RETURN

 LRS15E   BSS    0
          SA6    A1
          EQ     LRS         RETURN

*         LIST RECORD STATUS   ( LO = D )

 LRS16    BSS    0
          SA2    TY          CHECK RECORD TYPE
          SX4    X2
          LX3    X4,B1
          IX4    X4+X3
          SA2    X4+RTDT     FIND RECORD TYPE DIRECTIVE
          ZR     X2,LRS      RETURN IF RECORD TYPE TO BE IGNORED
          SA1    NM          INSERT NAME INTO DIRECTIVE
          RJ     SFN         SPACE FILL NAME
          SA6    A2+B1
          WRITEC O,A2
          EQ     LRS         RETURN
 ABS      SPACE  4
**        ABS - PROCESS ABS ENTRY POINTS.


 ABS      SA1    BUF         CHECK FIRST WORD
          LX1    18
          MX2    -12
          SX6    X1-770000B
          NZ     X6,CAT1     RETURN IF NO 7700 TABLE
          LX1    6           SKIP 7700 TABLE
          SB2    X1+B1
          SA1    A1+B2
          LX1    12
          BX3    -X2*X1
          SX6    X3-5100B
          LX1    -12
          SB7    B1+         SET INDEX TO ENTRY POINTS
          ZR     X6,ABS1     IF 5100 TABLE
          SX6    X3-5300B
          BX1    -X1
          ZR     X6,ABS1     IF 5300 TABLE
          BX1    -X1
          SX6    X3-5400B
          SB7    8
          NZ     X6,CAT1     IF NOT 5400 TABLE
 ABS1     SX0    X1          SET ENTRY COUNT
          ZR     X0,CAT1     IF NO ENTRIES
          SA5    A1+B7       FIRST ENTRY POINT NAME
          SA2    =1H         CLEAR SCRATCH BUFFER
          BX6    X2
          MX7    0
          SA6    SBUF
          SA7    SBUF+3
 ABS2     MX2    42          SPACE FILL NAME
          BX1    X2*X5
          RJ     SFN
          LX6    -6
          BX1    -X2*X5
          SA6    SBUF+1
          RJ     COD         CONVERT ENTRY POINT ADDRESS
          LX6    18
          SA6    SBUF+2
          SX1    SBUF        LIST ENTRY
          RJ     WOF
          SA5    A5+B1       NEXT ENTRY
          SX0    X0-1
          NZ     X0,ABS2     IF NOT END OF ENTRIES
          EQ     CAT1        RETURN
 CAP      SPACE  4,5
**        CAP - PROCESS CAPSULE GROUP NAMES.


 CAP      SA1    BUF         CHECK FIRST WORD
          LX1    18
          MX2    -12
          SX6    X1-770000B
          NZ     X6,CAT1     IF NO 7700 TABLE
          LX1    6           SKIP 7700 TABLE
          SB2    X1+2
          MX0    42
          SA1    A1+B2
          BX1    X0*X1
          RJ     SFN         SPACE FILL NAME
          LX6    -6
          SA6    CAPA+1
          SX1    CAPA        LIST GROUP NAME
          RJ     WOF
          EQ     CAT1        RETURN

 CAPA     DIS    2,
          DATA   C* (GROUP NAME)*
 OPL      SPACE  4
**        OPL - PROCESS OPL LIST.


 OPL      SA1    BUF         CHECK FIRST WORD
          LX1    18
          SB2    X1-770000B
          NZ     B2,CAT1     RETURN IF NO 7700 TABLE
          LX1    6           SKIP 7700 TABLE
          SB2    X1+B1
          SA1    A1+B2
          SX5    X1
          ZR     X5,CAT1     RETURN IF NO MODIFIERS
          SA3    TF          CHECK FOR TERMINAL
          SB7    B0          LINE LENGTH FOR NON - TERMINAL
          ZR     X3,OPL0     IF NOT TERMINAL FILE
          SB7    -6          CHANGE LINE LENGTH FOR TERMINAL FILE
 OPL0     SA2    =1H         CLEAR SCRATCH BUFFER
          SA0    A1+B1       FIRST MODIFIER
          BX6    X2
          SA6    SBUF
          MX0    42
 OPL1     SB6    -12
          ZR     X5,OPL5     IF END OF MODIFIERS
 OPL2     ZR     X5,OPL4     IF END OF TABLE
          SA4    A0          SPACE FILL NAME
          BX1    X0*X4
          RJ     SFN
          LX4    59-16       CHECK YANK BIT
          SA0    A0+B1
          PL     X4,OPL3     IF NOT SET
          SA1    OPLA        ADD ()
          IX6    X6+X1
 OPL3     LX6    -6          STORE NAME
          SA6    SBUF+13+B6
          SB6    B6+B1
          SX5    X5-1        ADVANCE TABLE
          NE     B6,B7,OPL2  LOOP TO END OF LINE
          MX6    0           LIST LINE
          SA6    A6+B1
          SX1    SBUF
          SX2    B0
          RJ     WOF
          EQ     OPL1        LOOP


 OPL4     MX6    0           LIST PARTIAL LINE
          SA6    A6+B1
          SX1    SBUF
          SX2    B0
          RJ     WOF
 OPL5     SA1    LC          CHECK LINE COUNT
          SX7    X1-LINP
          PL     X7,CAT1     IF BOTTOM OF PAGE REACHED
          SX1    =2L
          SX2    B0
          RJ     WOF
          EQ     CAT1        RETURN

 OPLA     VFD    60/3A) (-1H
 RDA      SPACE  4
**        RDA - READ DATA.
*         PROCESSES CALLS TO READ WORDS (RDW=).
*         DEBLOCKS DATA IF CONTROL WORD READS.

*         ENTRY/EXIT CONDITIONS ARE IDENTICAL WITH THOSE FOR COMCRDW.


 RDA5     SX6    B5-B7       UPDATE WORDS REMAINING
          SA6    A1

 RDA6     RJ     RDW=        READ WORDS

 RDA      PS                 ENTRY/EXIT
          SA1    CW          CHECK IF CONTROL WORDS LEGAL
          ZR     X1,RDA6     IF CONTROL WORD READS NOT LEGAL
          SA0    B6
 RDA1     SA1    X2-2        GET NUMBER OF WORDS BEFORE CONTROL WORD
          SB5    X1+
          PL     X1,RDA2     IF NOT FIRST READ
          SX7    B7+         SET WORDS NEEDED
          SA7    RDAA
          JP     RDA4

 RDA2     GE     B5,B7,RDA5  IF ENOUGH DATA TO FILL BUFFER
          SA3    X2-1        CHECK EOR FLAG
          PL     X3,RDA3     IF NOT EOR ON FILE
          MX6    1           SET NEW READ FLAG
          SB7    B5+B1       SET WORDS TO READ
          SA6    A3
          SA6    A1
          RJ     RDW=        READ WORDS
          SA1    B6-B1       CHECK CONTROL WORD
          AX1    48
          SX6    X1-17B
          MX1    -1
          SB6    B6-B1       BACK UP LAST WORD ADDRESS
          ZR     X6,RDA      IF *EOF* CONTROL WORD
          SX1    B6          SET *EOR* INDICATION
          JP     RDA         RETURN

 RDA3     SX6    B7-B5       SAVE ADDITIONAL WORDS NEEDED
          SA6    RDAA
          SB7    B5+B1       SET WORDS TO TRANSFER
          RJ     RDW=        READ WORDS
          SB7    A0-B6
          ZR     B7,RDA      IF EOR, RETURN
          SB6    B6-1        BACK UP OVER LAST CONTROL WORD
 RDA4     SB7    B1          READ CONTROL WORD
          RJ     RDW=
          NG     X1,RDA      IF EOF/EOI
          SB6    B6-B1       BACK UP WORKING BUFFER
          SA1    B6          CONTROL WORD
          SX7    5
          SX4    X1+4        ROUND UP
          AX1    36          EXTRACT BLOCK SIZE
          SX3    X1
          IX7    X4/X7       WORDS IN BLOCK
          IX6    X7-X3       SAVE EOR FLAG
          SA7    X2-2        STORE WORD COUNT
          SA6    X2-1        EOR FLAG
          SA1    RDAA        RESET WORDS NEEDED
          SB7    X1
          JP     RDA1        LOOP

 RDAA     CON    0
 RDR      SPACE  4
**        RDR - READ RECORD.
*
*         EXIT   (X1) = -1 IF EOF.
*                (RL) = RECORD LENGTH.
*                (CS) = CHECK SUM.
*                (TY) = RECORD TYPE.
*                (NM) = RECORD NAME.
*                (NSFF) .NE. 0, IF NONSTANDARD RECORD ENCOUNTERED
*                     (DATA WITH NO EOR).
*
*         USES   A - 1, 2, 3, 4, 6, 7.
*                B - 2, 3, 4.
*                X - 1, 2, 3, 4, 6, 7.
*
*         CALLS  SRT.
*
*         MACROS MESSAGE, READW.


 RDR      PS                 ENTRY/EXIT
          READW  F,BUF,BUFL
          BX6    X1          SAVE STATUS
          SA6    RDRA
          SB2    B6-BUF
          SX1    B6          LWA+1 OF DATA FOR SRT CALL
          NZ     B2,RDR0     IF DATA TRANSFERRED
          PL     X6,RDR0     IF NOT EOF/EOI
          SX1    BUF
 RDR0     SX2    BUF
          RJ     SRT
          SA6    TY          SET TYPE
          SA7    NM          SET NAME
          LX7    -6          ENTER NAME N MESSAGE
          SA7    RDRB+1
          MESSAGE A7-B1,1    ISSUE CONSOLE MESSAGE
          SA1    RDRA
          SB2    BUFL
          SB3    BUF
          ZR     X1,RDR1     IF NOT EOR/EOF
          SB2    B6-BUF
          ZR     B2,RDR      RETURN IF ZERO LENGTH RECORD
          PL     X1,RDR1     IF NOT NONSTANDARD RECORD
          SX6    B1+         SET NONSTANDARD FILE FLAG
          SA6    NSFF
 RDR1     SA2    TY          EXCLUDE RECORD TYPES WITHOUT 7700 TABLE
          SX2    X2
          ZR     X2,RDR2     IF RECORD TYPE *TEXT*
          SX2    X2-2
          ZR     X2,RDR2     IF RECORD TYPE *COS*
          SA2    B3          CHECK FIRST WORD
          LX2    18
          SX6    X2-770000B
          NZ     X6,RDR2     IF NO 7700 TABLE
          LX2    6           SKIP 7700 TABLE
          SB4    X2+B1
          SB3    B3+B4
          SB2    B2-B4
          LE     B2,RDR      IF 77 TABLE ONLY OR ERROR IN LENGTH

 RDR2     SA2    RL          ADVANCE RECORD LENGTH
          SA3    CS          ADVANCE CHECKSUM
          SX7    B2
          SA4    B3
          BX6    X3
          IX7    X2+X7
 RDR3     BX6    X6-X4
          SB2    B2-B1
          SA4    A4+B1
          LX6    1
          NZ     B2,RDR3
          SA6    A3
          SA7    A2
          NZ     X1,RDR      RETURN IF EOR/EOF
          READW  F,SBUF,SBUFL
          SB2    SBUFL
          SB3    SBUF
          ZR     X1,RDR2     IF NOT EOR/EOF
          SB2    B6-SBUF
          PL     X1,RDR4     IF NOT NONSTANDARD RECORD
          SX6    B1+         SET NONSTANDARD FILE FLAG
          SA6    NSFF
 RDR4     NZ     B2,RDR2     IF NOT EMPTY BUFFER
          EQ     RDR         RETURN

 RDRA     DATA   0

 RDRB     DATA   10HCATALOGING
          DATA   0
 REL      SPACE  4
**        REL - PROCESS RELOCATABLE LIST.


 REL      SA1    BUF         CHECK FIRST WORD
          LX1    18
          SB2    X1-770000B
          NZ     B2,CAT1     RETURN IF NO 7700 TABLE
          LX1    6           SKIP 7700 TABLE
          SB2    X1+B1
          SA1    A1+B2
          LX1    12
          SB2    X1-7000B
          NZ     B2,REL1     IF NOT 7000 TABLE
          LX1    12          SKIP 7000 TABLE
          SB2    X1+B1
          SA1    A1+B2
          LX1    12
 REL1     SB2    X1-3400B
          NZ     B2,CAT1     RETURN IF NO 3400 TABLE
          LX1    12          SKIP 3400 TABLE
          SB2    X1+B1
          SA1    A1+B2
          LX1    12
          SB2    X1-3600B
          NZ     B2,CAT1     RETURN IF NO 3600 TABLE
          LX1    12
          SX0    X1-1
          SA5    A1+B1       FIRST ENTRY POINT
          SA2    =1H         CLEAR SCRATCH BUFFER
          BX6    X2
          MX7    0
          SA6    SBUF
          SA7    SBUF+2
 REL2     BX1    X5          SPACE FILL NAME
          RJ     SFN
          LX6    -6
          SA6    SBUF+1
          SX1    SBUF        LIST ENTRY POINT
          RJ     WOF
          SA5    A5+2        NEXT ENTRY POINT
          SX0    X0-2
          PL     X0,REL2     LOOP FOR ALL ENTRY POINTS
          EQ     CAT1        RETURN
 TXT      SPACE  4
**        TXT - PROCESS TEXT LIST.


 TXT      SA1    NM          READ NAME
          SA2    TXTA        SET TABLE
          MX4    1
          SB2    X2
          MX0    42
          BX6    X0*X2
 TXT1     AX3    X4,B2       SET MASK
          BX7    X1-X6
          BX6    X3*X7
          SA2    A2+B1
          ZR     X6,TXT2     IF MATCH ON NAME
          ZR     X2,CAT1     IF END OF TABLE
          SB2    X2
          BX6    X0*X2
          EQ     TXT1        LOOP


 TXT2     SA0    BUF
          SX6    A2-TXTA-6-1 SET *OVERLAY* FLAG
          SA6    TXTB
          SA1    =1H
          BX6    X1
          SB2    B0
          SA6    SBUF
          MX0    -12
          SA6    A6+B1
          SA5    RL
          SX7    X5-BUFL
          MI     X7,TXT3     IF LESS THAN FULL BUFFER OF TEXT
          SX5    BUFL        RESET LENGTH OF RECORD
 TXT3     SX5    X5-1
          NG     X5,TXT4     IF END OF COPY
          SA1    A0          MOVE WORD
          LX6    X1
          SA6    SBUF+2+B2
          SA0    A0+B1
          BX7    -X0*X1
          SB2    B2+B1
          NZ     X7,TXT3     LOOP TO END OF LINE
          SX1    SBUF        LIST LINE
          RJ     WOF
          SA2    TXTB
          ZR     X2,CAT1     IF *OVERLAY* RECORD
          SB2    B0
          EQ     TXT3        LOOP

 TXT4     SX1    =C*  *
          RJ     WOF
          EQ     CAT1        RETURN

 TXTA     BSS    0
          CON    5LCMRDC+29
          CON    7LCMRDECK+41
          CON    5LIPRDC+29
          CON    7LIPRDECK+41
          CON    5LLIBDC+29
          CON    7LLIBDECK+41
          CON    7LOVERLAY+41
          CON    5LDDSDC+29
          CON    7LDDSDECK+41
          CON    0

 TXTB     CON    0
 ULB      SPACE  4
**        ULB - PROCESS USER LIBRARY.


 ULB      SA1    UL
          NZ     X1,CAT1     IF USER LIBRARY LIST REQUESTED
          SX6    B1          SET NO LIST
          SA6    A1+B1
          EQ     CAT1        RETURN
          TITLE  SUBROUTINES.
 WOF      SPACE  4
**        WOF - WRITE LINE TO OUTPUT.
*
*         ENTRY  (X1) = FWA LINE.
*                (X2) = WORD COUNT.
*
*         USES ALL REGISTERS EXCEPT A0, X0, A5, X5.


 WOF      PS                 ENTRY/EXIT
          SA3    LC          ADVANCE LINE COUNT
          SX6    X3+B1
          SA6    A3
          SX7    X6-LINP+4
          NG     X7,WOF1     IF BOTTOM OF PAGE NOT REACHED
          BX6    X1          SAVE REQUEST
          SA6    WOFA
          SA1    PN          ADVANCE PAGE NUMBER
          SX6    B0          RESET LINE COUNT
          SX7    X1+B1
          SA6    A3
          SA7    A1
          RJ     CDD         CONVERT PAGE NUMBER
          MX1    48
          LX6    18          STORE PAGE NUMBER
          BX6    X1*X6
          SA6    PAGE
          WRITEC O,TITL
          WRITEC X2,SBTL
          WRITEC X2,(=C*  *)
          SA1    WOFA        RESTORE REQUEST
 WOF1     WRITEC O,X1
          SA1    SL          CHECK LIST FLAG
          ZR     X1,WOF      RETURN IF NOT SHORT LIST
          MX6    0           CLEAR LINE COUNT
          SA6    LC
          EQ     WOF         RETURN

 WOFA     CON    0
          SPACE  4
*         COMMON DECKS.


 OPL      XTEXT  COMCCDD
 OPL      XTEXT  COMCCOD
 OPL      XTEXT  COMCCPT
 OPL      XTEXT  COMCSFN
 OPL      XTEXT  COMCSRT
 OPL      XTEXT  COMCRDW
 OPL      XTEXT  COMCWTC
 OPL      XTEXT  COMCWTS
 OPL      XTEXT  COMCWTW
 OPL      XTEXT  COMCCIO
 OPL      XTEXT  COMCSYS
 BUFFERS  SPACE  4
**        BUFFERS.


          USE    //
          SEG
 BUFL     EQU    1000B       WORKING BUFFER
 SBUFL    EQU    100B        SCRATCH BUFFER

 BUF      BSS    BUFL
 SBUF     BSS    SBUFL
 FBUF     BSS    FBUFL
 OBUF     BSS    OBUFL
 RFL=     BSS    0
 PRS      SPACE  4
**        PRS - PRESET PROGRAM.


          ORG    BUF
 PRS      PS                 ENTRY/EXIT
          SB1    1
          DATE   DATE
          CLOCK  TIME
          SA1    ACTR        CHECK ARGUMENT COUNT
          SB4    X1
          MX0    42
          ZR     B4,PRS2     IF NO ARGUMENTS
          SA4    ARGR        SET FILE NAME
          BX6    X0*X4
          ZR     X6,PRS1     IF FILE NAME BLANK
          SX2    3
          IX6    X6+X2
          SA6    F
 PRS1     SB4    B4-B1
          ZR     B4,PRS2     IF END OF ARGUMENTS
          SA4    A4+B1       PROCESS SPECIAL ARGUMENTS
          SB5    PRSA
          RJ     ARG
          NZ     X1,PRS4     IF ARGUMENT ERROR

          SA4    PRSH        CHECK LIST OPTION ARGUMENT
          SA3    PRSLO

 PRS1A    BSS    0
          BX5    X3-X4
          BX6    X0*X5
          ZR     X6,PRS1B    IF OPTION FOUND
          SA3    A3+B1
          ZR     X3,PRS4     IF END OF TABLE
          EQ     PRS1A

 PRS1B    BSS    0           SET LIST OPTION CODE
          SX7    X3
          SA7    LO

 PRS2     SA5    FC          CHECK FILE COUNT
          ZR     X5,PRS3     IF NO CONVERSION REQUIRED
          SB7    B1
          RJ     DXB
          SA6    FC
          NZ     X4,PRS4     IF CONVERSION ERROR
 PRS3     SA1    F           ENTER FILE NAME IN TITLE
          SA2    PRSG        SET POINTER TO OUTPUT BUFFER
          MX0    42
          BX1    X0*X1
          LX6    X2
          BX7    X7-X7
          SA6    B1+B1
          SA7    A6+B1
          RJ     SFN
          LX6    -6
          SA6    TITL+2
          SA1    O           CHECK FILE NAMES
          SA2    F
          BX6    X1-X2
          BX7    X0*X6
          ZR     X7,PRS5     IF SAME NAME
          SX2    O           CHECK IF TERMINAL FILE
          RJ     STF
          NZ     X6,PRS3.1   IF NOT TERMINAL FILE
          SX6    B1          SET SHORT LIST FLAG
          SA6    SL
          SA6    TF          SET TERMINAL FLAG
          SA2    =1H         DELETE EJECT
          BX7    X7-X7
          BX6    X2
          SA7    TITLA
          SA7    SBTLA
          SA6    TITL
 PRS3.1   OPEN   F,READNR,R  CHECK IF CONTROL WORDS MAY BE USED
          SA1    F+1
          RJ     CDT         CHECK DEVICE TYPE
          ZR     X7,PRS      IF CONTROL WORDS NOT ALLOWABLE
          SX7    1           SET CONTROL WORDS LEGAL
          SA7    CW          SET CONTROL WORD FLAG
          EQ     PRS         RETURN

 PRS4     MESSAGE PRSB
          ABORT

 PRS5     MESSAGE PRSC
          ABORT

 PRSA     BSS    0
 L        ARG    O,O         OUTPUT FILE NAME
 N        ARG    PRSD,FC     NUMBER OF FILE TO CATALOG
 U        ARG    -*,UL       LIST  *ULIB*  OPTION
 D        ARG    PRSF,SL     DE-SELECT DETAILED LIST OPTION
 R        ARG    -*,RW       REWIND BEFORE AND AFTER
 CS       ARG    -=0,CSM     LIST CHARACTER SET FOR *OPL* AND *OPLC*
 LO       ARG    PRSH,PRSH   LIST OPTION
          ARG

 PRSB     DATA   C* CATALOG ARGUMENT ERROR.*
 PRSC     DATA   C* CATALOG FILE NAME CONFLICT.*

 PRSD     CON    0L999999
 PRSF     CON    0L0

 PRSG     CON    0LOUTPUT+O

 PRSH     CON    0LN

 PRSLO    VFD    42/0LN,18/0
          VFD    42/0LS,18/1
          VFD    42/0LD,18/-1
          CON    0
 CDT      SPACE  4
**        CDT - CHECK DEVICE TYPE.
*
*         ENTRY  (X1) = (FET+1).
*
*         EXIT   (X7)= 0 IF CONTROL WORD READ/WRITE NOT SUPPORTED ON
*                 DEVICE.
*
*         USES   B - NONE.
*                A - 2.
*                X - 0,1,2,6,7.
*
*         CALLS  NONE.


 CDT2     LX1    12          CHECK *TT*
          BX6    -X0*X1
          SX7    X6-2RTT

 CDT      PS                 ENTRY/EXIT
          MX0    -12
          PL     X1,CDT2     IF ALLOCATABLE
          LX1    12
          SA2    CDTA        SEARCH DEVICE TABLE
          SX7    0           ASSUME NO FIND
 CDT1     ZR     X2,CDT      RETURN - IF NOT FOUND
          BX6    X1-X2
          AX2    12
          BX6    X2*X6
          SA2    A2+B1
          NZ     X6,CDT1     IF NOT MATCH
          SX7    1           INDICATE CONTROL WORD POSSIBLE
          JP     CDT         RETURN

 CDTA     VFD    36/,12/7703B,12/4002B
          VFD    36/,12/7703B,12/4102B
          VFD    36/,12/7777B,12/2RMT+4000B
          VFD    36/,12/7777B,12/2RNT+4000B
          CON    0
          SPACE  4
*         COMMON DECKS.


 OPL      XTEXT  COMCARG
 OPL      XTEXT  COMCDXB
 OPL      XTEXT  COMCLFM
 OPL      XTEXT  COMCSTF
          SPACE  4
          END
*DECK DECK=RAM$GENERATE_COMMAND_TABLE EXPAND=TRUE
create_program_description name=(generate_command_table, genct) sp=clp$generate_command_table ..
      l=('$system.osf$system_library' osf$task_services_library) tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$GENERATE_CORRECTION_PACS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'CREATE_SUBPRODUCT_CORRECTION Utility: GENERATE_CORRECTION Subcommand.' ??
MODULE ram$generate_correction_pacs;

{ PURPOSE:
{   This module contains the interface and procedures to generate
{   a subproduct correction.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{   There are two kinds of correction installation schemes currently
{   supported, cycle based and version based.  The following describes how
{   the element list is generated to support these schemes.  The difference
{   between ACTIVE and INACTIVE elements, and the differences between FULL
{   and COMPRESSED element lists is also described.
{
{   The element list provides information about the files and subcatalogs
{   that make up a subproduct.  Usually there is a one to one correlation
{   between the elements in the element list and the files and catalogs in
{   its PACS catalog.  The exception is a version based subproduct
{   correction.  In a version based subproduct correction, element
{   information for the full subproduct, not just those files being
{   corrected, must be kept in the element list.  That is because with
{   version based, the whole subproduct must be must be recreated under the
{   new version catalog.  With cycle based, the files that are not corrected
{   will still be accessable and do not require any recreation.
{
{   To create an element list that can contain element information for the
{   full subproduct and still have an exact understanding of what is in the
{   PACS catalog, elements within the element list are set as active or
{   inactive.  An active element has a corresponding file or catalog in the
{   PACS catalog for that element.  An inactive element is not a member of
{   the PACS catalog.
{
{   Any procedure can determine if a file or catalog should be in the PACS
{   catalog by checking the ACTIVE/INACTIVE attribute.
{
{   The element list for both the version based and cycle based corrections
{   are prepared the same way.  First the element list from the current
{   level is copied into memory (this represents the full element list for
{   the subproduct).  As changes are isolated and corrections generated,
{   element information is updated.  Those elements not required to support
{   a correction are set to inactive.
{
{   When all file corrections have been generated into the PACS catalog, the
{   element list is either kept as full (when version based) or compressed
{   (for cycle based).  Compressing the element list removes all the
{   elements that are inactive.  This is allowed because the information for
{   the rest of the subproduct's files/catalogs is not required to install
{   the correction.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
*copyc rac$sif_file_name
*copyc rae$install_software_cc
*copyc rae$package_software_cc
*copyc rat$path
*copyc rat$validation_selections
?? POP ??
*copyc amp$return
*copyc clp$change_variable
*copyc clp$create_procedure_variable
*copyc clp$delete_variable
*copyc clp$evaluate_parameters
*copyc clp$get_variable
*copyc clp$include_command
*copyc clp$include_line
*copyc clp$trimmed_string_size
*copyc fsp$copy_file
*copyc i#current_sequence_position
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc pfp$convert_fs_path_to_pf_path
*copyc pfp$convert_string_to_fs_path
*copyc pfp$define_catalog
*copyc pmp$get_unique_name
*copyc rap$convert_path_to_str
*copyc rap$create_element_list
*copyc rap$generate_object_correction
*copyc rap$locate_element
*copyc rap$reset_correction_environ
*copyc rap$sort_psrs
*copyc rap$validate_installation_paths
*copyc rap$verify_subproduct
*copyc rap$write_file_from_memory
*copyc rap$write_subproduct_info_file
*copyc rav$correction_process_record

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

{ NOTES:
{   The following constant and type declarations are used by the compare
{   object libraries procedure.  The variable type_specification is
{   suppressed from a compiled listing and is the result of GENPDT on the
{   scl_compare_var_type declaration.
{

  CONST
    scl_compare_variable = 'RAV$COMPARE_OUTPUT_LINE';

{ TYPE
{   scl_compare_var_type: string
{ TYPEND

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    type_specification : [STATIC, READ, cls$declaration_section] record
      header: clt$type_specification_header,
      name: string (20),
      qualifier: clt$string_type_qualifier,
    recend := [
      [1, 20, clc$string_type], 'SCL_COMPARE_VAR_TYPE', [0, clc$max_string_size, FALSE]];

?? FMT (FORMAT := ON) ??
?? POP ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$generate_correction_pacs', EJECT ??

{ PURPOSE:
{   This interface is used to generate a correction to the base level PACS
{   catalog specified on the DEFINE_CORRECTION subcommand.  The correction
{   will make the files the same as those in the current level PACS catalog
{   also specified on the DEFINE_CORRECTION command.
{
{ DESIGN:
{   A DEFINE_CORRECTION command must have preceded this subcommand.
{   DEFINE_CORRECTION sets up the correction process record used here to
{   control processing.  It also initializes the subproduct info sequence
{   for the new PACS catalog (the correction) with a copy of the subproduct
{   info sequence from the current level catalog.
{
{   The steps involved in generating the correction for a subproduct
{   are as follows:
{
{   1.  Create the catalog that will contain the PACS catalog for the
{       correction.  The catalog path was specified by the PACS_CATALOG
{       parameter.  If not validated to create the catalog return with
{       error, but leave the environment intact.  (The root PACS catalog
{       must not exist prior to calling this interface.)
{
{   2.  Isolate all subproduct changes.  Corrections are generated for all
{       files which have changed and for which no previous correction is
{       available.  Corrections are carried forward from the previous correction
{       catalog if a file changes and the previous correction will correct the
{       file.  Generated corrections and those brought forward are placed in the
{       new PACS catalog.  The element list from the new subproduct info
{       sequence is used to drive the correction generation.
{
{       The element information for the corrected files will be taken from
{       the current level SIF when the correction was generated from the
{       current level and from the previous correction SIF when the
{       correction was carried forward.
{
{       If no changes are found the processing will continue with step 5,
{       and a warning message will be returned.
{
{   3.  Add the PSRs answered to the new subproduct info sequence found
{       in memory.  This means merging the PSRs answered from a previous
{       correction (when present) with the current PSRs answered already
{       on the new subproduct info sequence (when present).
{
{   4.  Write the new subproduct info sequence from memory to the permanent
{       file SIF in the new PACS catalog.  This is to include compressing
{       the element list when the correction installation scheme is cycle
{       based (see discussion on the element list in the module design
{       section).
{
{   5.  Close all the SIFs used in creating the new PACS catalog.
{       Set a flag to indicate that the correction has been generated and that no
{       correction is currently being processed.  When an error or abort
{       situation is encountered, delete the new PACS catalog and contents.
{
{ NOTES:
{   An element path is that portion of a file or catalog path that can be
{   constructed using the element list.  To create a complete file or catalog
{   path, the PACS catalog path must be added to the front of the
{   element path for that file or catalog.  The element path is processed
{   using PF path format, because it is the most efficient when it comes to
{   locating the same element in multiple element lists.  The procedure
{   isolate_subproduct_changes requires the PF path container for the
{   element path to be initialized to an array of one.
{

  PROCEDURE [XDCL] rap$generate_correction_pacs
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);



{ PROCEDURE genc_pdt (
{ pacs_catalog, pc : file = $required
{ status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 8, 18, 8, 56, 21, 467], clc$command, 3, 2, 1, 0, 0, 0, 2, 'GENC_PDT'],
            [['PACS_CATALOG                   ', clc$nominal_entry, 1],
            ['PC                             ', clc$abbreviation_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 2]], [
{ PARAMETER 1
      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$file_type]],
{ PARAMETER 2
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$pacs_catalog = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    VAR
      corrections_generated: boolean,
      element_path_p: ^pft$path,
      fs_path: fst$path,
      ignore_corr_carried_forward: boolean,
      ignore_cycle_reference: fst$cycle_reference,
      ignore_cycle_selector: clt$cycle_selector,
      ignore_open_position: fst$open_position,
      ignore_status: ost$status,
      local_status: ost$status,
      new_pacs_catalog_path_p: ^pft$path,
      new_sif: rat$path,
      new_subproduct_info_ptrs: rat$subproduct_info_pointers,
      active_element_count: rat$element_count,
      number_of_path_elements: fst$number_of_path_elements,
      pacs_length: integer,
      sif_length: integer,
      validation_selections: rat$validation_selections,
      verify_errors: rat$subproduct_verify_errors,
      verify_options: rat$subproduct_verify_options;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to delete the new PACS catalog
{   when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      delete_new_pacs_catalog (pvt [p$pacs_catalog].value^.file_value^, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT rav$correction_process_record.correction_in_progress THEN
      osp$set_status_abnormal ('RA', rae$defc_command_not_called, 'GENERATE_CORRECTION', status);
      RETURN;
    IFEND;

    new_subproduct_info_ptrs := rav$correction_process_record.new_subproduct_info_pointers;

    rap$validate_installation_paths (rav$correction_process_record.base_level_sif.
          subproduct_info_pointers.attributes_p^, rav$correction_process_record.base_level_sif.
          subproduct_info_pointers.path_container_p^, rav$correction_process_record.current_level_sif.
          subproduct_info_pointers.attributes_p^, rav$correction_process_record.current_level_sif.
          subproduct_info_pointers.path_container_p^, new_subproduct_info_ptrs.attributes_p^.
          installation_scheme, TRUE {set_status_to_error}, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    {Convert the PACS_CATALOG parameter value into rat$path format and store it in the new
    {subproduct info sequence attributes record.

    pacs_length := clp$trimmed_string_size (pvt [p$pacs_catalog].value^.file_value^);
    new_subproduct_info_ptrs.attributes_p^.pacs_catalog_path.path := '';
    new_subproduct_info_ptrs.attributes_p^.pacs_catalog_path.path (1,
          pacs_length) := pvt [p$pacs_catalog].value^.file_value^;
    new_subproduct_info_ptrs.attributes_p^.pacs_catalog_path.size := pacs_length;

    pfp$convert_string_to_fs_path (pvt [p$pacs_catalog].value^.file_value^, fs_path, number_of_path_elements,
          ignore_cycle_reference, ignore_open_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH new_pacs_catalog_path_p: [1 .. number_of_path_elements];
    pfp$convert_fs_path_to_pf_path (fs_path, new_pacs_catalog_path_p, ignore_cycle_reference,
          ignore_cycle_selector, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$define_catalog (new_pacs_catalog_path_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      { Create an SCL boolean variable to be used when comparing object libraries.
      { The variable type_specification is defined in the global declarations section.

      clp$create_procedure_variable (scl_compare_variable, clc$local_scope, clc$read_write,
            clc$immediate_evaluation, #SEQ (type_specification), NIL, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      { Initialize element path container to one element.

      PUSH element_path_p: [1 .. 1];

      isolate_subproduct_changes (element_path_p, new_pacs_catalog_path_p,
            new_subproduct_info_ptrs.element_list_p, rav$correction_process_record, active_element_count,
            corrections_generated, ignore_corr_carried_forward, status);
      clp$delete_variable (scl_compare_variable, ignore_status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      new_subproduct_info_ptrs.attributes_p^.first_level_element_count := active_element_count;

      IF NOT corrections_generated THEN
        osp$set_status_abnormal ('RA', rae$no_corrections_generated,
              rav$correction_process_record.current_level_sif.subproduct_info_pointers.attributes_p^.name,
              status);
        EXIT /main/;
      IFEND;

      { After the new PACS catalog (containing the corrections) has been generated,
      { the subproduct information sequence is completed and the subproduct information file
      { is written from the memory sequence.

      {If a previous correction was specified and it contains a PSRs answered list.
      IF rav$correction_process_record.previous_correction_sif.file_opened AND
            (rav$correction_process_record.previous_correction_sif.subproduct_info_pointers.
            psrs_answered_p <> NIL) THEN

        add_psrs_answered_to_seq (rav$correction_process_record.previous_correction_sif.
              subproduct_info_pointers.psrs_answered_p, new_subproduct_info_ptrs.info_header_p,
              new_subproduct_info_ptrs.psrs_answered_p, new_subproduct_info_ptrs.subproduct_info_seq_p,
              status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
      IFEND;

      IF new_subproduct_info_ptrs.attributes_p^.installation_scheme = rac$cycle_based THEN

        write_compressed_sif (element_path_p, new_subproduct_info_ptrs, status);

      ELSE {installation scheme is version based}

        { Call verify_subproduct to set the attributes_checksum, modification_date_time, product_size,
        { and subproduct_size fields.

        verify_errors := $rat$subproduct_verify_errors [];
        validation_selections := $rat$validation_selections [];
        verify_options := $rat$subproduct_verify_options [rac$reconcile_mod_date_time, rac$calculate_size,
              rac$get_attributes_checksum];

        rap$verify_subproduct (pvt [p$pacs_catalog].value^.file_value, validation_selections, FALSE
              {sif_present} , verify_options, verify_errors, new_subproduct_info_ptrs, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        STRINGREP (new_sif.path, new_sif.size, pvt [p$pacs_catalog].value^.file_value^, '.',
              rac$sif_file_name);

        rap$write_file_from_memory (new_sif.path (1, new_sif.size),
              i#current_sequence_position (new_subproduct_info_ptrs.subproduct_info_seq_p),
              new_subproduct_info_ptrs.subproduct_info_seq_p, status);


      IFEND;

    END /main/;

    IF NOT status.normal THEN
      delete_new_pacs_catalog (pvt [p$pacs_catalog].value^.file_value^, ignore_status);
    IFEND;

    {Close all the SIFs used in creating the new PACS catalog
    {and reset all booleans in the correction process record to FALSE.

    rap$reset_correction_environ (rav$correction_process_record, local_status);

    osp$disestablish_cond_handler;

    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

  PROCEND rap$generate_correction_pacs;

?? OLDTITLE ??
?? NEWTITLE := 'construct_full_path', EJECT ??

{ PURPOSE:
{   This procedure constructs a files full path by putting the PACS catalog
{   together with the rest of the file path.
{
{ DESIGN:
{   This procedure combines the PACS catalog path in rat$path format with
{   the rest of the element path which is in pft$path format.  The returned
{   full path is in rat$path format.
{
{ NOTES:
{

  PROCEDURE construct_full_path
    (    pacs_catalog: rat$path;
         element_path_p: ^pft$path;
     VAR full_path: rat$path);


    VAR
      file_path: rat$path;

    rap$convert_path_to_str (element_path_p^, file_path);

    { rap$convert_path_to_str returns with the first character as a ':' .
    { Therefore the STRINGREP only uses from character 2 to the end of the file path.

    STRINGREP (full_path.path, full_path.size, pacs_catalog.path (1, pacs_catalog.size),
          '.', file_path.path (2, file_path.size - 1));

  PROCEND construct_full_path;

?? OLDTITLE ??
?? NEWTITLE := 'delete_new_pacs_catalog', EJECT ??

{ PURPOSE:
{   This procedure deletes the new PACS catalog and all of its contents.
{
{ DESIGN:
{   This procedure uses the SCL delete_catalog command to delete the
{   new PACS catalog and its contents.
{
{ NOTES:
{

  PROCEDURE delete_new_pacs_catalog
    (    pacs_catalog_ref: fst$file_reference;
     VAR status: ost$status);


    VAR
      command_line: string (osc$max_string_size),
      command_line_length: integer,
      enable_echoing: boolean;

    status.normal := TRUE;
    enable_echoing := FALSE;

    STRINGREP (command_line, command_line_length, 'DELETE_CATALOG CATALOG = ', pacs_catalog_ref,
          ' DELETE_OPTION = CATALOG_AND_CONTENTS');

    clp$include_command (command_line (1, command_line_length), enable_echoing, status);

  PROCEND delete_new_pacs_catalog;

?? OLDTITLE ??
?? NEWTITLE := 'add_psrs_answered_to_seq', EJECT ??

{ PURPOSE:
{   This procedure merges the PSRs answered by this correction with the
{   psrs answered during a previous correction.
{
{ DESIGN:
{   This procedure is called only if a previous correction exists.
{
{   The PSRs answered by this correction are merged with the PSRs
{   answered by the previous correction, sorted, and written to the
{   new subproduct info sequence.
{
{   The relative pointer to the PSRs answered section and the PSRs answered
{   count must be set in the subproduct info header.
{
{ NOTES:
{

  PROCEDURE add_psrs_answered_to_seq
    (    previous_psrs_answered_p: ^rat$psrs_answered;
         new_info_header_p: ^rat$subproduct_info_header;
     VAR new_psrs_answered_p: ^rat$psrs_answered;
     VAR new_subproduct_info_seq_p: ^rat$subproduct_info_sequence;
     VAR status: ost$status);

    VAR
      previous_psrs_p: ^rat$psrs_answered;

    status.normal := TRUE;

    NEXT previous_psrs_p: [1 .. UPPERBOUND (previous_psrs_answered_p^)] IN new_subproduct_info_seq_p;
    IF previous_psrs_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'NEW SUBPRODUCT_INFO_SEQUENCE', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'initial creation', status);
      RETURN;
    IFEND;
    previous_psrs_p^ := previous_psrs_answered_p^;

    IF new_psrs_answered_p <> NIL THEN
      RESET new_subproduct_info_seq_p TO new_psrs_answered_p;
      NEXT new_psrs_answered_p: [1 .. UPPERBOUND (new_psrs_answered_p^) +
            UPPERBOUND (previous_psrs_answered_p^)] IN new_subproduct_info_seq_p;
    ELSE
      RESET new_subproduct_info_seq_p TO previous_psrs_p;
      NEXT new_psrs_answered_p: [1 .. UPPERBOUND (previous_psrs_answered_p^)] IN new_subproduct_info_seq_p;
    IFEND;

    rap$sort_psrs (new_psrs_answered_p^);
    new_info_header_p^.psrs_answered_p := #REL (new_psrs_answered_p, new_subproduct_info_seq_p^);

  PROCEND add_psrs_answered_to_seq;

?? TITLE := 'compare_object_libraries', EJECT ??

{ PURPOSE:
{   This procedure compares two object libraries and returns the result in a
{   boolean.  The comparison is done so that the time/date stamps within the
{   libraries are ignored.  This prevents a correction from being generated
{   for a library that has been recompiled without any actual modifications.
{
{ DESIGN:
{   The compare is performed using COMPARE_OBJECT_LIBRARY (COMOL) which is only
{   callable through command language.  To accomplish this, the SCL commands
{   must be collected and executed by including the lines.
{
{   COMOL places the results of the compare into an output file.  The file
{   contents must then be interpreted.  When two libraries compare, the
{   compare output file will contain only 1 line and the line will have the
{   same string value as that assigned to the compare_line constant below.
{
{   The 1st line of the compare output file is retrieved to the CYBIL side.
{   The value of the line is compared with the value of a line from a
{   successful compare.
{
{ NOTES:
{   The SCL_COMPARE_VARIABLE is a global string constant that is used
{   as the name of the scl compare variable.
{
{   The SCL commands that are assembled by STRINGREP into the command
{   line have been arranged for readability.  Formating has been turned
{   off to protect these lines from the formater.
{

  PROCEDURE compare_object_libraries
    (    library: rat$path;
         with_library: rat$path;
     VAR libraries_compare: boolean;
     VAR status: ost$status);


    CONST
      compare_line = '-Number of compare errors: 0';

    VAR
      access_mode: clt$data_access_mode,
      class: clt$variable_class,
      command_line: string (1000),
      command_line_length: integer,
      compare_output: rat$path,
      evaluation_method: clt$expression_eval_method,
      ignore_status: ost$status,
      scl_compare_value_p: ^clt$data_value,
      scratch_seq_p: ^SEQ ( * ),
      type_specification_p: ^clt$type_specification,
      unique_file_name: ost$name;


    status.normal := TRUE;

    { Establish the size of the scratch sequence used to store the SCL compare variable value.
    { The variable type_specification is defined in the global declaration section.

    PUSH scratch_seq_p: [[REP #SIZE (clt$data_value) + #SIZE (type_specification) of cell]];

    { Build a unique file path to be used by the SCL compare command to put the compare results.

    pmp$get_unique_name (unique_file_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (compare_output.path, compare_output.size, ':$LOCAL.',
          unique_file_name (1, clp$trimmed_string_size (unique_file_name)));

    { Collect the SCL commands required to compare the libraries.

?? FMT (FORMAT := OFF) ??
    STRINGREP (command_line, command_line_length,
          ' $system.set_file_attributes f=', compare_output.path (1, compare_output.size),
          '       page_format=continuous;',
          ' $system.compare_object_library f=', library.path (1, library.size),
          '       w=', with_library.path (1, with_library.size),
          '       o=', compare_output.path (1, compare_output.size), ';',
          ' $system.get_line v=', scl_compare_variable,
          '       i=', compare_output.path (1, compare_output.size));
?? FMT (FORMAT := ON) ??

    { Execute the SCL commands and retrieve the first compare output line.

    clp$include_line (command_line (1, command_line_length), TRUE, osc$null_name, status);
    amp$return (compare_output.path (1, compare_output.size), ignore_status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_variable (scl_compare_variable, scratch_seq_p, class, access_mode, evaluation_method,
          type_specification_p, scl_compare_value_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { The value of the first compare output line is compared with the value of a line from a
    { successful compare.  If they are equal the libraries compare.

    libraries_compare := (scl_compare_value_p^.string_value^ = compare_line);

  PROCEND compare_object_libraries;

?? OLDTITLE ??
?? NEWTITLE := 'copy_element_info', EJECT ??

{ PURPOSE:
{   This procedure copies certain element information from one element
{   record to another element record.
{
{ DESIGN:
{   The following element information is copied from the first variable to
{   the second variable when the element is a file.
{
{          base_contents_checksum          pre_genc_contents_checksum
{          correction_format                     ring_attributes
{          library_merge                         storage_class
{          permit
{
{   When the element is a catalog, only the permit information is copied.
{
{   The fields that are element list dependent (ie.  the relative pointers
{   between element records) are already correct.  The processing attributes
{   are set to active in isolate subproduct changes.
{
{ NOTES:
{

  PROCEDURE copy_element_info
    (    from_element_p: ^rat$element;
         to_element_p {output} : ^rat$element);


    IF from_element_p^.element_type = rac$file THEN

      to_element_p^.correction_base_contents_cksum := from_element_p^.correction_base_contents_cksum;
      to_element_p^.correction_format := from_element_p^.correction_format;
      to_element_p^.library_merge := from_element_p^.library_merge;
      to_element_p^.permit := from_element_p^.permit;
      to_element_p^.pre_genc_contents_checksum := from_element_p^.pre_genc_contents_checksum;
      to_element_p^.ring_attributes := from_element_p^.ring_attributes;
      to_element_p^.storage_class := from_element_p^.storage_class;

    ELSE {rac$catalog}

      to_element_p^.permit := from_element_p^.permit;

    IFEND;

  PROCEND copy_element_info;

?? OLDTITLE ??
?? NEWTITLE := 'create_pacs_subcatalogs', EJECT ??

{ PURPOSE:
{   This procedure creates the necessary subcatalogs within the PACS
{   catalog so that correction files may be created in the subcatalog.
{
{ DESIGN:
{   This procedure attempts to create all subcatalogs below the PACS catalog
{   leading to the file.
{
{ NOTES:
{

  PROCEDURE create_pacs_subcatalogs
    (    new_pacs_catalog_path_p: ^pft$path;
         element_path_p: ^pft$path);

    VAR
      full_catalog_path_p: ^pft$path,
      i: fst$number_of_path_elements,
      ignore_status: ost$status,
      j: fst$number_of_path_elements,
      new_subcatalog_p: ^pft$path,
      number_of_subcatalogs: fst$number_of_path_elements,
      path_sequence_p: ^SEQ ( * ),
      subcatalogs: integer;


    j := 1;
    PUSH full_catalog_path_p: [1 .. UPPERBOUND (new_pacs_catalog_path_p^) + UPPERBOUND (element_path_p^)];

    FOR i := 1 TO UPPERBOUND (new_pacs_catalog_path_p^) DO
      full_catalog_path_p^ [j] := new_pacs_catalog_path_p^ [i];
      j := j + 1;
    FOREND;

    FOR i := 1 TO UPPERBOUND (element_path_p^) DO
      full_catalog_path_p^ [j] := element_path_p^ [i];
      j := j + 1;
    FOREND;

    PUSH path_sequence_p: [[REP #SIZE (full_catalog_path_p^) OF cell]];
    RESET path_sequence_p;
    NEXT new_subcatalog_p: [1 .. UPPERBOUND (full_catalog_path_p^)] IN path_sequence_p;
    new_subcatalog_p^ := full_catalog_path_p^;

    number_of_subcatalogs := UPPERBOUND (full_catalog_path_p^) - UPPERBOUND (new_pacs_catalog_path_p^) - 1;
    {Subtract 1 for the file name} ;

    FOR subcatalogs := 1 TO number_of_subcatalogs DO

      RESET path_sequence_p;
      NEXT new_subcatalog_p: [1 .. UPPERBOUND (new_pacs_catalog_path_p^) + subcatalogs] IN path_sequence_p;

      pfp$define_catalog (new_subcatalog_p^, ignore_status);

    FOREND;

  PROCEND create_pacs_subcatalogs;

?? OLDTITLE ??
?? NEWTITLE := 'generate_file_correction', EJECT ??

{ PURPOSE:
{   This procedure generates a correction for the file.
{
{ DESIGN:
{   The correction formats currently being supported are REPLACEMENT,
{   SOURCE LIBRARY and OBJECT LIBRARY.  Files that are neither source
{   library nor object library must use the replacement format.
{
{   When the correction format is REPLACEMENT the current level file is
{   taken as the correction.  The current level file is copied directly
{   into the new PACS catalog for the correction.  No correction is
{   actually generated.
{
{   When the format is OBJECT LIBRARY or SOURCE LIBRARY the correction is
{   generated by comparing the current level file to the base level file.
{   The resulting correction is written to a file under the new PACS catalog.
{
{   When an error is returned while attempting to generate a correction of
{   format object library or source library, the correction format is
{   automatically changed to replacement and the current level file is
{   copied directly into the new PACS catalog.  A warning message is
{   displayed along with the error that occured.
{
{   The destination location in the new PACS catalog for the
{   file is identical to its location in the current level PACS catalog.
{
{ NOTES:
{   An element path is that portion of a file or catalog path that is
{   represented by the element list.  To create a complete file or catalog
{   path, the PACS catalog path must be appended to the front of the
{   element path for that file or catalog.  The paths are converted to FST$PATH
{   format.
{

  PROCEDURE generate_file_correction
    (    element_path_p: ^pft$path;
         new_pacs_catalog_path_p: ^pft$path;
         base_pacs_catalog: rat$path;
         current_pacs_catalog: rat$path;
         new_pacs_catalog: rat$path;
         base_checksum: rat$checksum;
         current_checksum: rat$checksum;
         element_p {input/output} : ^rat$element;
     VAR status: ost$status);


    VAR
      base_file: rat$path,
      current_file: rat$path,
      ignore_status: ost$status,
      local_status: ost$status,
      new_file: rat$path;


*copy rav$correction_format

    status.normal := TRUE;
    local_status.normal := TRUE;
    base_file.path := '';
    current_file.path := '';
    new_file.path := '';

    { Assemble the base file, current file and new file paths.

    construct_full_path (base_pacs_catalog, element_path_p, base_file);
    construct_full_path (current_pacs_catalog, element_path_p, current_file);
    construct_full_path (new_pacs_catalog, element_path_p, new_file);

    { Create any non-existing subcatalogs along new file path.
    create_pacs_subcatalogs (new_pacs_catalog_path_p, element_path_p);


    IF element_p^.correction_format = rac$object_library THEN

      rap$generate_object_correction (base_file.path (1, base_file.size),
            current_file.path (1, current_file.size), new_file.path (1, new_file.size),
            FALSE {calculate_checksums}, base_checksum, current_checksum, element_p, local_status);

    ELSE {rac$replacement or rac$source_library}

      { Copy the file from current level PACS catalog to the new PACS catalog.

      fsp$copy_file (current_file.path (1, current_file.size), new_file.path (1, new_file.size),
            NIL, NIL, NIL, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    IFEND;

    IF NOT local_status.normal THEN

      { Handle correction as file replacement.
      { Display a warning message.  Then change the correction format in element to replacement.

      osp$set_status_abnormal ('RA', rae$correction_format_changed, new_file.path (1, new_file.size),
            local_status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            rav$correction_format [element_p^.correction_format], local_status);
      osp$generate_error_message (local_status, ignore_status);

      element_p^.correction_format := rac$replacement;

      { Copy the file from current level PACS catalog to the new PACS catalog.

      fsp$copy_file (current_file.path (1, current_file.size), new_file.path (1, new_file.size),
            NIL, NIL, NIL, status);

    IFEND;

  PROCEND generate_file_correction;

?? OLDTITLE ??
?? NEWTITLE := 'isolate_file_changes', EJECT ??

{ PURPOSE:
{   This procedure determines if a file has changed and causes a correction
{   to be generated or copied forward as appropriate.
{
{ DESIGN:
{   When a previous correction exists for the file, changes are discovered
{   by comparing the file's current level contents_checksum against the
{   previous correction's pre_genc_contents_checksum.  Pre_genc refers to
{   the file used against the base in generating the correction.
{
{   When the file is an object library and the previous correction is of type
{   replacement (ie.  it is a complete object library, not a patch), the
{   file undergoes an additional byte comparison that ignores the date/time
{   stamps.  This prevents a correction from being generated for a file that
{   has been recompiled without any actual modifications.
{
{   When a previous correction does not exist for the file, changes are
{   discovered by comparing the file's current level contents checksum
{   against the file's base level contents checksum.
{
{   The checksums were generated during subproduct definition and are
{   stored in the respective SIFs.
{
{   When differences are found a correction will be generated based on the
{   correction format.
{
{   When a previous correction exists for a file and the file has not
{   changed since that level, the correction is carried forward into the
{   new PACS catalog.
{
{ NOTES:
{   It is assumed that the element lists were originally generated with
{   checksums and that the element lists of the base level and current level
{   contain the same elements.  Also assumed is that the element list of the
{   previous correction is a subset of the current level element list.
{   This was checked by RAP$DEFINE_CORRECTION.
{

  PROCEDURE isolate_file_changes
    (    element_path_p: ^pft$path;
         new_pacs_catalog_path_p: ^pft$path;
         correction_process_record {input/output} : rat$correction_process_record;
         element_p {input/output} : ^rat$element;
     VAR new_correction_generated: boolean;
     VAR previous_correction_used: boolean;
     VAR status: ost$status);


    VAR
      base_subproduct_info_ptrs: rat$subproduct_info_pointers,
      current_file_path: rat$path,
      current_subproduct_info_ptrs: rat$subproduct_info_pointers,
      libraries_compare: boolean,
      new_file_path: rat$path,
      new_subproduct_info_ptrs: rat$subproduct_info_pointers,
      prev_correction_element_p: ^rat$element,
      previous_correction_file: rat$path,
      previous_element_p: ^rat$element,
      previous_element_found: boolean,
      previous_file_path: rat$path,
      previous_subproduct_info_ptrs: rat$subproduct_info_pointers;


    status.normal := TRUE;
    new_correction_generated := FALSE;
    previous_correction_used := FALSE;
    base_subproduct_info_ptrs := correction_process_record.base_level_sif.subproduct_info_pointers;
    current_subproduct_info_ptrs := correction_process_record.current_level_sif.subproduct_info_pointers;
    new_subproduct_info_ptrs := correction_process_record.new_subproduct_info_pointers;

    IF correction_process_record.previous_correction_sif.file_opened THEN
      previous_subproduct_info_ptrs := correction_process_record.previous_correction_sif.
            subproduct_info_pointers;

      previous_element_p := previous_subproduct_info_ptrs.element_list_p;
      rap$locate_element (element_path_p, 1 {path_index} , previous_subproduct_info_ptrs.
            subproduct_info_seq_p, previous_element_p, previous_element_found);

      IF previous_element_found AND previous_element_p^.active_element THEN

        construct_full_path (previous_subproduct_info_ptrs.attributes_p^.pacs_catalog_path, element_path_p,
              previous_file_path);
        construct_full_path (new_subproduct_info_ptrs.attributes_p^.pacs_catalog_path, element_path_p,
              new_file_path);

        { Compare the contents checksums from the current level file against the
        {  previous correction's pre-GENC contents checksum.

        IF element_p^.contents_checksum = previous_element_p^.pre_genc_contents_checksum THEN

          { File has not changed since the previous correction.
          { Move the file from the previous correction to the new PACS catalog.

          use_previous_correction (element_path_p, new_pacs_catalog_path_p, new_file_path,
                previous_file_path, previous_element_p, element_p, previous_correction_used, status);

        ELSE  { Contents checksums do not match }

          IF (element_p^.file_contents_and_structure = rac$object_library) AND
                (previous_element_p^.correction_format = rac$replacement) THEN

            { The previous correction is a complete object library.
            { Compare files ignoring time/date stamps.

            construct_full_path (current_subproduct_info_ptrs.attributes_p^.pacs_catalog_path,
                  element_path_p, current_file_path);

            compare_object_libraries (current_file_path, previous_file_path, libraries_compare, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF libraries_compare THEN

              { File has not changed since the previous correction.
              { Move the file from the previous correction to the new PACS catalog.

              use_previous_correction (element_path_p, new_pacs_catalog_path_p, new_file_path,
                    previous_file_path, previous_element_p, element_p, previous_correction_used, status);

            ELSE { libraries do not compare }

              isolate_file_changes_using_base (element_path_p, new_pacs_catalog_path_p,
                    current_subproduct_info_ptrs, new_subproduct_info_ptrs, element_p,
                    new_correction_generated, base_subproduct_info_ptrs, status);

            IFEND;
          ELSE { not an object library or previous correction is a patch and cannot be compared }

            isolate_file_changes_using_base (element_path_p, new_pacs_catalog_path_p,
                  current_subproduct_info_ptrs, new_subproduct_info_ptrs, element_p, new_correction_generated,
                  base_subproduct_info_ptrs, status);

          IFEND;
        IFEND;

      ELSE {previous correction does not exist}

        isolate_file_changes_using_base (element_path_p, new_pacs_catalog_path_p,
              current_subproduct_info_ptrs, new_subproduct_info_ptrs, element_p, new_correction_generated,
              base_subproduct_info_ptrs, status);

      IFEND;

    ELSE {previous correction not used}

      isolate_file_changes_using_base (element_path_p, new_pacs_catalog_path_p, current_subproduct_info_ptrs,
            new_subproduct_info_ptrs, element_p, new_correction_generated, base_subproduct_info_ptrs, status);

    IFEND;

  PROCEND isolate_file_changes;

?? OLDTITLE ??
?? NEWTITLE := 'isolate_file_changes_using_base', EJECT ??

{ PURPOSE:
{   This procedure isolates any file changes between the current level file
{   and the base level file.  When differences are found a file correction
{   is generated.
{
{ DESIGN:
{   Compare the file's current level contents checksum against the file's
{   base level contents checksum.
{
{   When the format is object library, the file undergoes an additional byte
{   comparison that ignores the date/time stamp.  This prevents a correction
{   from being generated for a file that has been recompiled without any
{   actual modifications.
{
{   If the checksums differ and (as required) the object library compare
{   indicates changes, a correction will be generated.
{
{ NOTES:
{   The element information for the corrected file is taken from the current
{   level SIF.  (Since the current level is already in the new subproduct
{   info sequence only the base and pre-GENC checksum fields must be filled in.)
{
{   It is assumed that the element lists were originally generated with
{   checksums.  This was checked by RAP$DEFINE_CORRECTION.
{

  PROCEDURE isolate_file_changes_using_base
    (    element_path_p: ^pft$path;
         new_pacs_catalog_path_p: ^pft$path;
         current_subproduct_info_ptrs: rat$subproduct_info_pointers;
         new_subproduct_info_ptrs: rat$subproduct_info_pointers;
         element_p {input/output} : ^rat$element;
     VAR new_correction_generated: boolean;
     VAR base_subproduct_info_ptrs: rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      base_element_found: boolean,
      base_element_p: ^rat$element,
      base_file_path: rat$path,
      current_file_path: rat$path,
      libraries_compare: boolean;


    status.normal := TRUE;
    base_element_p := base_subproduct_info_ptrs.element_list_p;

    rap$locate_element (element_path_p, 1 {path_index} , base_subproduct_info_ptrs.subproduct_info_seq_p,
          base_element_p, base_element_found);

    { Compare the contents checksums from the current level file against the base level file.

    IF element_p^.contents_checksum <> base_element_p^.contents_checksum THEN

      IF element_p^.file_contents_and_structure = rac$object_library THEN

        { Compare the object libraries ignoring time/date stamps.

        construct_full_path (base_subproduct_info_ptrs.attributes_p^.pacs_catalog_path, element_path_p,
              base_file_path);
        construct_full_path (current_subproduct_info_ptrs.attributes_p^.pacs_catalog_path,
              element_path_p, current_file_path);

        compare_object_libraries (current_file_path, base_file_path, libraries_compare, status);
        IF (NOT status.normal) OR libraries_compare THEN
          RETURN;
        IFEND;
      IFEND;

      new_correction_generated := TRUE;

      { Set file's base and pre-GENC contents checksums.

      element_p^.correction_base_contents_cksum := base_element_p^.contents_checksum;
      element_p^.pre_genc_contents_checksum := element_p^.contents_checksum;

      { Generate file correction between the base level and the current level.

      generate_file_correction (element_path_p, new_pacs_catalog_path_p,
            base_subproduct_info_ptrs.attributes_p^.pacs_catalog_path,
            current_subproduct_info_ptrs.attributes_p^.pacs_catalog_path,
            new_subproduct_info_ptrs.attributes_p^.pacs_catalog_path, base_element_p^.contents_checksum,
            element_p^.contents_checksum, element_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      { Increment the product_file_size or the service_critical_file_size in the attributes record.

      IF element_p^.storage_class = rmc$msc_system_permanent_files THEN
        new_subproduct_info_ptrs.attributes_p^.service_critical_file_size :=
              new_subproduct_info_ptrs.attributes_p^.service_critical_file_size + element_p^.size;
      ELSEIF element_p^.storage_class = rmc$msc_user_permanent_files THEN
        new_subproduct_info_ptrs.attributes_p^.user_permanent_file_size :=
              new_subproduct_info_ptrs.attributes_p^.user_permanent_file_size + element_p^.size;
      ELSE
        new_subproduct_info_ptrs.attributes_p^.product_file_size :=
              new_subproduct_info_ptrs.attributes_p^.product_file_size + element_p^.size;
      IFEND;

    IFEND;

  PROCEND isolate_file_changes_using_base;

?? OLDTITLE ??
?? NEWTITLE := 'isolate_subproduct_changes', EJECT ??

{ PURPOSE:
{   The purpose of this interface is to locate all the changes for the
{   subproduct and produce a new PACS catalog containing newly generated
{   corrections or corrections brought forward from a previous correction.
{   During this process the element list is updated.
{
{ DESIGN:
{   This procedure traverses the element list from the new subproduct info
{   sequence (which is a copy of the the current level subproduct SIF).  For
{   every file belonging to the subproduct, changes are discovered by
{   comparing the checksum of the current level of the file against the previous correction
{   (when found) or the base level of the file (when the previous correction
{   is not found).  Those files with changes will have corrections generated
{   based on the correction format.  A boolean is returned flagging whether
{   or not corrections have been generated or corrections were brought
{   forward.
{
{   Determining what files belong to the subproduct is accomplished by
{   traversing the element list for the subproduct.  The traverse is
{   performed using recursion and each call to ISOLATE_SUBPRODUCT_CHANGES
{   moves processing down to the next catalog level.
{
{   If no new correction was generated or no previous correction was brought
{   forward while processing an element, that element is set as inactive.
{   The elements were originally set to active when the element list was
{   first created.  Once the element list is processed those elements still
{   active will reflect how the new PACS catalog looks.  (See the discussion
{   on element lists in the module design section.)
{
{   The actual isolation of any file changes and generation of the
{   correction if changes found is done by another procedure.
{
{ NOTES:
{   An element path is that portion of a file or catalog path that is
{   represented by the element list.  To create a complete file or catalog
{   path, the PACS catalog path must be appended to the front of the
{   element path for that file or catalog.  The element path is processed
{   using PF path format, because it is the most efficient when it comes to
{   locating the same element in multiple element lists.  The procedure
{   isolate_subproduct_changes requires the PF path container for the
{   element path to be initialized to an array of one on the first call.
{

  PROCEDURE isolate_subproduct_changes
    (    element_path_p: ^pft$path;
         new_pacs_catalog_path_p: ^pft$path;
         element_p {input} : ^rat$element;
         correction_process_record {input/output} : rat$correction_process_record;
     VAR active_element_count: rat$element_count;
     VAR corrections_generated: boolean;
     VAR corrections_carried_forward: boolean;
     VAR status: ost$status);


    VAR
      working_element_p: ^rat$element,
      first_element_down_p: ^rat$element,
      i: fst$number_of_path_elements,
      new_correction_generated: boolean,
      next_element_path_p: ^pft$path,
      next_level_active_element_count: rat$element_count,
      previous_correction_used: boolean;


    status.normal := TRUE;
    corrections_generated := FALSE;
    corrections_carried_forward := FALSE;
    working_element_p := element_p;
    active_element_count := 0;

{ Process the files and subcatalogs at the current catalog level.

    WHILE working_element_p <> NIL DO

      element_path_p^ [UPPERBOUND (element_path_p^)] := working_element_p^.name;

      IF working_element_p^.element_type = rac$file THEN

        isolate_file_changes (element_path_p, new_pacs_catalog_path_p, correction_process_record,
              working_element_p, new_correction_generated, previous_correction_used, status);

      ELSE {rac$catalog}

        IF working_element_p^.element_count = 0 THEN

          new_correction_generated := FALSE;
          previous_correction_used := FALSE;

        ELSE

          { Create a PF format path array that is 1 larger than the size of the
          { element path.  This array will be used to construct the PF paths for
          { the files and subcatalogs that reside in the next level catalog in the
          { element list.

          PUSH next_element_path_p: [1 .. UPPERBOUND (element_path_p^) + 1];
          FOR i := 1 TO UPPERBOUND (element_path_p^) DO
            next_element_path_p^ [i] := element_path_p^ [i];
          FOREND;

          { Process the next level catalog.

          first_element_down_p := #PTR (working_element_p^.first_element_down_p,
                correction_process_record.new_subproduct_info_pointers.subproduct_info_seq_p^);

          isolate_subproduct_changes (next_element_path_p, new_pacs_catalog_path_p, first_element_down_p,
                correction_process_record, next_level_active_element_count, new_correction_generated,
                previous_correction_used, status);

        IFEND;

      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT (new_correction_generated OR previous_correction_used) THEN

        { The new PACS catalog doesn't contain this element, so element is defined as inactive
        { in the element list.

        working_element_p^.active_element := FALSE;
      ELSE
        active_element_count := active_element_count + 1;
      IFEND;

      corrections_generated := (corrections_generated OR new_correction_generated);
      corrections_carried_forward := (corrections_carried_forward OR previous_correction_used);

      working_element_p := #PTR (working_element_p^.next_element_across_p,
            correction_process_record.new_subproduct_info_pointers.subproduct_info_seq_p^);
    WHILEND;

  PROCEND isolate_subproduct_changes;

?? OLDTITLE ??
?? NEWTITLE := 'update_element_info', EJECT ??

{ PURPOSE:
{   This procedure traverses the compressed element list.  For every file in
{   the compressed element list, the element is located in the corresponding
{   new element list.  The non-directly dependent element information is
{   copied from the new element to the compressed element.
{
{ DESIGN:
{   Determining what files belong to the subproduct is accomplished by
{   traversing the element list for the subproduct.  The traverse is
{   performed using recursion and each call to UPDATE_ELEMENT_INFO
{   moves processing down to the next catalog level.
{
{ NOTES:
{

  PROCEDURE update_element_info
    (    element_path_p: ^pft$path;
         compressed_element_p {input/output} : ^rat$element;
         compressed_subproduct_info_ptrs {input/output} : rat$subproduct_info_pointers;
     VAR new_subproduct_info_ptrs: rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      working_compressed_element_p: ^rat$element,
      element_found: boolean,
      first_element_down_p: ^rat$element,
      i: fst$number_of_path_elements,
      new_element_p: ^rat$element,
      next_element_path_p: ^pft$path;


    status.normal := TRUE;
    working_compressed_element_p := compressed_element_p;

{ Process the files and subcatalogs at the current catalog level.

    WHILE working_compressed_element_p <> NIL DO

      element_path_p^ [UPPERBOUND (element_path_p^)] := working_compressed_element_p^.name;

      { Locate element info in new subproduct info sequence element list.

      new_element_p := new_subproduct_info_ptrs.element_list_p;
      rap$locate_element (element_path_p, 1 {path index} , new_subproduct_info_ptrs.subproduct_info_seq_p,
            new_element_p, element_found);

      { Copy the element info from the new element to the compressed element.
      copy_element_info (new_element_p, working_compressed_element_p);

      IF working_compressed_element_p^.element_type = rac$catalog THEN

        { Create a PF format path array that is 1 larger than the size of the
        { element path.  This array will be used to construct the PF paths for
        { the files and subcatalogs that reside in the next level catalog in the
        { element list.

        PUSH next_element_path_p: [1 .. UPPERBOUND (element_path_p^) + 1];
        FOR i := 1 TO UPPERBOUND (element_path_p^) DO
          next_element_path_p^ [i] := element_path_p^ [i];
        FOREND;

        { Process the next level catalog.

        first_element_down_p := #PTR (working_compressed_element_p^.first_element_down_p,
              compressed_subproduct_info_ptrs.subproduct_info_seq_p^);

        update_element_info (next_element_path_p, first_element_down_p, compressed_subproduct_info_ptrs,
              new_subproduct_info_ptrs, status);

      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      working_compressed_element_p := #PTR (working_compressed_element_p^.next_element_across_p,
            compressed_subproduct_info_ptrs.subproduct_info_seq_p^);
    WHILEND;

  PROCEND update_element_info;

?? OLDTITLE ??
?? NEWTITLE := 'use_previous_correction', EJECT ??

{ PURPOSE:
{   This procedure moves the file from the previous correction to the new
{   PACS catalog.
{
{ DESIGN:
{   Non-existing catalogs are created along the way.
{
{ NOTES:
{

  PROCEDURE use_previous_correction
    (    element_path_p: ^pft$path;
         new_pacs_catalog_path_p: ^pft$path;
         new_file_path: rat$path;
         previous_file_path: rat$path;
         previous_element_p : ^rat$element;
         element_p {output} : ^rat$element;
     VAR previous_correction_used: boolean;
     VAR status: ost$status);


    status.normal := TRUE;

    create_pacs_subcatalogs (new_pacs_catalog_path_p, element_path_p);

    fsp$copy_file (previous_file_path.path (1, previous_file_path.size),
          new_file_path.path (1, new_file_path.size), NIL, NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    element_p^.pre_genc_contents_checksum := previous_element_p^.pre_genc_contents_checksum;
    element_p^.correction_base_contents_cksum := previous_element_p^.correction_base_contents_cksum;

    previous_correction_used := TRUE;

  PROCEND use_previous_correction;

?? OLDTITLE ??
?? NEWTITLE := 'write_compressed_sif', EJECT ??

{ PURPOSE:
{   This procedure compresses a new subproduct info sequence in memory and
{   writes it into the subproduct information file under the PACS catalog.
{   The compression removes inactive elements from the element list.
{
{ DESIGN:
{   A scratch sequence is created to hold a compressed subproduct
{   information sequence.  The element list section is created in the
{   compressed version of the subproduct info sequence by calling the same
{   interface that created the element list for DEFINE_SUBPRODUCT.
{
{   The relative pointer to the element list must be set in the subproduct
{   info header.
{
{   Certain element information stored in the new subproduct information
{   sequence is moved to the element list in the compressed subproduct
{   information sequence.
{
{ NOTES:
{

  PROCEDURE write_compressed_sif
    (    element_path_p: ^pft$path;
     VAR new_subproduct_info_ptrs {input} : rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      attributes_p: ^rat$subproduct_attributes,
      compressed_element_list_p: ^rat$element,
      compressed_subproduct_info_ptrs: rat$subproduct_info_pointers,
      fs_path: fst$path,
      ignore_cycle_reference: fst$cycle_reference,
      ignore_cycle_selector: clt$cycle_selector,
      ignore_open_position: fst$open_position,
      info_header_p: ^rat$subproduct_info_header,
      local_status: ost$status,
      number_of_path_elements: fst$number_of_path_elements,
      pacs_catalog_path: rat$path,
      pacs_catalog_path_p: ^pft$path,
      path_container_p: ^rat$path_container,
      psrs_answered_p: ^rat$psrs_answered,
      scratch_segment_pointer: amt$segment_pointer,
      sequence_descriptor_p: ^rat$sequence_descriptor,
      validation_errors: boolean,
      validation_selections: rat$validation_selections;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to return the memory
{   scratch segment (used to contain the compressed subproduct info
{   sequence) when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF scratch_segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (scratch_segment_pointer, ignore_status);
        scratch_segment_pointer.sequence_pointer := NIL;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    scratch_segment_pointer.kind := amc$sequence_pointer;
    scratch_segment_pointer.sequence_pointer := NIL;
    pacs_catalog_path := new_subproduct_info_ptrs.attributes_p^.pacs_catalog_path;
    validation_errors := FALSE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, scratch_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      compressed_subproduct_info_ptrs.subproduct_info_seq_p := scratch_segment_pointer.sequence_pointer;
      RESET compressed_subproduct_info_ptrs.subproduct_info_seq_p;

      { Copy the sequence descriptor, subproduct header and subproduct attributes from the new to
      { the compressed sequence.  Establish the compressed subproduct info pointers.

      NEXT sequence_descriptor_p IN compressed_subproduct_info_ptrs.subproduct_info_seq_p;
      sequence_descriptor_p^ := new_subproduct_info_ptrs.sequence_descriptor_p^;
      compressed_subproduct_info_ptrs.sequence_descriptor_p := sequence_descriptor_p;

      NEXT info_header_p IN compressed_subproduct_info_ptrs.subproduct_info_seq_p;
      info_header_p^ := new_subproduct_info_ptrs.info_header_p^;
      compressed_subproduct_info_ptrs.info_header_p := info_header_p;

      NEXT attributes_p IN compressed_subproduct_info_ptrs.subproduct_info_seq_p;
      attributes_p^ := new_subproduct_info_ptrs.attributes_p^;
      compressed_subproduct_info_ptrs.attributes_p := attributes_p;

      NEXT compressed_element_list_p IN compressed_subproduct_info_ptrs.subproduct_info_seq_p;
      compressed_subproduct_info_ptrs.element_list_p := compressed_element_list_p;

      pfp$convert_string_to_fs_path (pacs_catalog_path.path (1, pacs_catalog_path.size), fs_path,
            number_of_path_elements, ignore_cycle_reference, ignore_open_position, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      PUSH pacs_catalog_path_p: [1 .. number_of_path_elements];
      pfp$convert_fs_path_to_pf_path (fs_path, pacs_catalog_path_p, ignore_cycle_reference,
            ignore_cycle_selector, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      validation_selections := $rat$validation_selections [rac$loading_cycle_only, rac$no_rings_below_11,
            rac$no_permits];

      rap$create_element_list (^pacs_catalog_path.path (1, pacs_catalog_path.size), pacs_catalog_path_p^,
            validation_selections, TRUE {checksum_files} , validation_errors, compressed_subproduct_info_ptrs,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      { The relative pointers in the info header for the attributes and the element list have not changed.
      { They do not need to be recalculated.

      { Copy the path container and the PSRs answered section from the new to
      { the compressed sequence (after the element list).

      NEXT path_container_p: [1 .. UPPERBOUND (new_subproduct_info_ptrs.path_container_p^)] IN
            compressed_subproduct_info_ptrs.subproduct_info_seq_p;
      path_container_p^ := new_subproduct_info_ptrs.path_container_p^;
      info_header_p^.path_container_p := #REL (path_container_p,
            compressed_subproduct_info_ptrs.subproduct_info_seq_p^);

      IF new_subproduct_info_ptrs.psrs_answered_p <> NIL THEN
        NEXT psrs_answered_p: [1 .. UPPERBOUND (new_subproduct_info_ptrs.psrs_answered_p^)] IN
              compressed_subproduct_info_ptrs.subproduct_info_seq_p;
        psrs_answered_p^ := new_subproduct_info_ptrs.psrs_answered_p^;
        info_header_p^.psrs_answered_p := #REL (psrs_answered_p,
              compressed_subproduct_info_ptrs.subproduct_info_seq_p^);
      IFEND;

      { Update the element information in the compressed element list using the new element list.

      update_element_info (element_path_p, compressed_element_list_p, compressed_subproduct_info_ptrs,
            new_subproduct_info_ptrs, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$write_subproduct_info_file (pacs_catalog_path, compressed_subproduct_info_ptrs, status);

    END /main/;

    IF scratch_segment_pointer.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (scratch_segment_pointer, local_status);
      scratch_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND write_compressed_sif;

MODEND ram$generate_correction_pacs;
*DECK DECK=RAM$GENERATE_DEFCN EXPAND=TRUE
PROC generate_defcn (
  network            : string = $optional
  rr                 : string = $optional
  physical_data      : string = $optional
  configuration_file : file = $optional
  status             : var of status = $optional
  )

  put_line ('define_channel_network network='//$value(network)//' relays_restricted='//$value(rr)//' ..' ..
'  connected_system='//$trim($substr($value(physical_data), 10, 31))) o=$value(configuration_file)

PROCEND generate_defcn
*DECK DECK=RAM$GENERATE_DEFHN EXPAND=TRUE
PROCEDURE generate_defhn (
  host_network: string = $optional
  configuration_file: file = $optional
  status: (var) status = $optional
  )

  put_line ('define_host_network network='//host_network) o=configuration_file

PROCEND generate_defhn
*DECK DECK=RAM$GENERATE_DEFINE_TCPIP_HOST EXPAND=TRUE
PROCEDURE generate_define_tcpip_host (
  host_name: string = $required
  forward_search_range: string = $required
  configuration_file: file = $required)

  put_line line=('define_tcpip_host host_name='''//host_name//''' forward_search_range='//forward_search_range) ..
             o=configuration_file

PROCEND generate_define_tcpip_host
*DECK DECK=RAM$GENERATE_DEFNA EXPAND=TRUE
PROC generate_defna (
  network            : string = $optional
  rr                 : string = $optional
  physical_data1     : string = $optional
  physical_data2     : string = $optional
  configuration_file : file = $optional
  status             : var of status = $optional
  )

  put_line ('define_network_access network='//$value(network)//' relays_restricted='//$value(rr)//' ..' ..
'  access=('//$trim($substr($value(physical_data1), 10, 31))//' '//$trim($substr($value(physical_data2), 10, 31))//')') ..
        o=$value(configuration_file)

PROCEND generate_defna
*DECK DECK=RAM$GENERATE_DEFNC EXPAND=TRUE
PROCEDURE generate_defnc (
  physical_data: string = $optional
  system_id: string = $optional
  configuration_file: file = $optional
  status)

  IF $substr(physical_data,5,4)='ICA2' THEN
    put_line 'define_network_connection  connected_system='//$trim($substring(physical_data, 11, 31))//..
'   system_identifier='//$substring(system_id, 7, 6)//'(16)' o=configuration_file
  ELSE
    put_line 'define_network_connection  connected_system='//$trim($substring(physical_data, 11, 31)) ..
              o=configuration_file
  IFEND

PROCEND generate_defnc
*DECK DECK=RAM$GENERATE_LCN_ERROR_REPORT EXPAND=TRUE
PROCEDURE generate_lcn_error_report (
  local_nad_name : name = $required
  status
)
JOB SM='!'

  crecle $system.hardware_maintenance.hpa.command_library
  print_hpa_index ..
     $system.hardware_maintenance.hpa.data.hpf$maint_action_log_database
  element_name !$string($value(local_nad_name))!
  end

  print_hpa_reports ..
     $system.hardware_maintenance.hpa.data.hpf$maint_action_log_database
  element_name !$string($value(local_nad_name))!
  end
JOBEND
PROCEND generate_lcn_error_report
*DECK DECK=RAM$GENERATE_MESSAGE_TEMPLATE EXPAND=TRUE
create_program_description name=(generate_message_template, generate_message_templates, genmt) ..
      sp=clp$generate_message_template l=('$system.osf$system_library' osf$task_services_library) ..
      tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$GENERATE_OBJECT_CORRECTION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'CREATE_SUBPRODUCT_CORRECTION Utility: RAP$GENERATE_OBJECT_CORRECTION Procedure.' ??
MODULE ram$generate_object_correction;

{ PURPOSE:
{   This module contains the procedures to generate a correction
{   for an object library.
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rat$subproduct_info_types
?? POP ??
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc ocp$checksum
*copyc ocp$generate_object_correction
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc rap$write_file_from_memory
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$generate_object_correction', EJECT ??

{ PURPOSE:
{   This procedure generates a correction for an object library.
{
{ DESIGN:
{
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$generate_object_correction
    (    base_file: fst$file_reference;
         current_file: fst$file_reference;
         new_file: fst$file_reference;
         calculate_checksums: boolean;
         base_checksum: rat$checksum;
         current_checksum: rat$checksum;
         element_p {input/output} : ^rat$element;
     VAR status: ost$status);

    VAR
      checksum_seq_p: ^ SEQ ( * ),
      corrector_size: oct$corrector_size,
      local_status: ost$status,
      scratch_segment_pointer: amt$segment_pointer,
      scratch_sequence_p: ^SEQ ( * );

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF scratch_segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (scratch_segment_pointer, ignore_status);
        scratch_segment_pointer.sequence_pointer := NIL;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    scratch_segment_pointer.kind := amc$sequence_pointer;
    scratch_segment_pointer.sequence_pointer := NIL;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, scratch_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      scratch_sequence_p := scratch_segment_pointer.sequence_pointer;
      RESET scratch_sequence_p;

      ocp$generate_object_correction (base_file, current_file, calculate_checksums, base_checksum,
            current_checksum, scratch_sequence_p, corrector_size, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      element_p^.size := corrector_size;

      { Calculate the contents checksum of the object correction.}
      RESET scratch_sequence_p;
      NEXT checksum_seq_p: [[REP corrector_size OF cell]] IN scratch_sequence_p;
      element_p^.contents_checksum := ocp$checksum (checksum_seq_p);

      { Write the sequence in memory to the new file.}
      rap$write_file_from_memory (new_file, corrector_size, scratch_sequence_p, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

    END /main/;

    IF scratch_segment_pointer.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (scratch_segment_pointer, local_status);
      scratch_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$generate_object_correction;

MODEND ram$generate_object_correction;
*DECK DECK=RAM$GENERATE_OBJECT_CORR_CMD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'GENERATE_OBJECT_CORRECTION command.' ??
MODULE ram$generate_object_corr_cmd;

{ PURPOSE:
{   This module contains the procedure to interpret the SCL parameters
{   and to make a call to the CYBIL interface RAP$GENERATE_OBJECT_CORRECTION.
{
{ DESIGN:
{   This module interprets the SCL parameters and makes a call to
{   the CYBIL interface RAP$GENERATE_OBJECT_CORRECTION.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$subproduct_info_types
?? POP ??
*copyc clp$evaluate_parameters
*copyc rap$generate_object_correction

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$generate_object_corr_cmd', EJECT ??

{ PURPOSE:
{   This procedure contains the procedure to interpret the SCL parameters
{   and to make a call to the CYBIL interface RAP$GENERATE_OBJECT_CORRECTION.
{
{ DESIGN:
{   This procedure interprets the SCL parameters and makes a call to
{   the CYBIL interface RAP$GENERATE_OBJECT_CORRECTION.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$generate_object_corr_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE genocc_pdt (
{   base_file, bf: file = $required
{   current_file, cf: file = $required
{   object_correction_file, ocf: file = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 10, 4, 10, 52, 30, 294],
    clc$command, 7, 4, 3, 0, 0, 0, 4, 'GENOCC_PDT'], [
    ['BASE_FILE                      ',clc$nominal_entry, 1],
    ['BF                             ',clc$abbreviation_entry, 1],
    ['CF                             ',clc$abbreviation_entry, 2],
    ['CURRENT_FILE                   ',clc$nominal_entry, 2],
    ['OBJECT_CORRECTION_FILE         ',clc$nominal_entry, 3],
    ['OCF                            ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$file_type]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$base_file = 1,
    p$current_file = 2,
    p$object_correction_file = 3,
    p$status = 4;

  VAR
    pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      base_checksum: rat$checksum,
      current_checksum: rat$checksum,
      element: rat$element;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$generate_object_correction (pvt [p$base_file].value^.file_value^,
          pvt [p$current_file].value^.file_value^, pvt [p$object_correction_file].value^.file_value^, TRUE
          {calculate_checksums}, base_checksum, current_checksum, ^element, status);

  PROCEND rap$generate_object_corr_cmd;

MODEND ram$generate_object_corr_cmd;
*DECK DECK=RAM$GENERATE_PDT EXPAND=TRUE
create_program_description name=(generate_pdt genpdt) sp=clp$_generate_pdt ..
      l=('$system.osf$system_library' osf$task_services_library) tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$GENERATE_PRODUCT_TAPE EXPAND=TRUE
*DECK DECK=RAM$GENJT EXPAND=TRUE
.PROC,GENJT*I,
VSN "Volume Serial Number of DS tape"  = (*N=,
                                     *S6(ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789)),
D "tape Density (GE,PE,HD,HY)"         = (*N=PE,GE,PE,HD,HY),
PT "Production Template file name"     = (*N=PROJT,*F)
.
.HELP
 The GENJT procedure GENerates NOS/VE Job Template file
 from the deadstart file created by the GENNVE procedure.
 Requires the DSMDSTG binaries.

 Parameter   Default   Description
   Name       Value

  [vsn]                 deadstart tape volume serial number
  [d]           pe      deadstart tape density (ge,pe,hd,hy)
  [pt]         projt    production job template file name

.HELP,VSN
 The VSN parameter specifies the deadstart tape volume serial number.
 The default is to attach a permanent file named TPXXXK.
.HELP,D
 The D parameter specifies the deadstart tape density.
 The default density is PE.
.HELP,PT
 The PT parameter names the permanent file to which the Production
 NOS/VE Job Template is written. The default value is PROJT.
.ENDHELP
GETNVE(TPXXXK,TPXXXK,,,VSN,D)
$GTR(TPXXXK,JT)PJBTMPL
$NOTE(INFILE)/RESTORE,PT,PJBTMPL/END
DSMDSTG(INFILE,JT,LIST)
REPFILE,PT,PT,DEFINE=YES.
$UNLOAD(JT,PT,LIST,INFILE,TPXXXK)
$SKIP,NOERROR.
  $EXIT.
  $UNLOAD,LIST,TPXXXK,INFILE,JT,PT.
  $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    $EXIT. GENJT *TERMINATED*
  $ENDIF,TERMINATED.
  $REVERT,ABORT. TEMPLATE GENERATION ERROR
$ENDIF,NOERROR.
$REVERT. TEMPLATE --> PT
/EOR
*DECK DECK=RAM$GENNBE EXPAND=TRUE
.PROC,GENNBE*I,
UN "Installation user name"            = (*N=,*F),
ULIB "Flag User Library install"       = (*K=1,*N=0),
BL "File of system routines"           = (*N=NBEBINS,*F),
NL "File of NVE subsystem routines"    = (*N=NVELIBB,*F),
PID "ID of user libraries"             = (*N=CCT,*F),
UP "PP user library"                   = (*N=USERPP,*F),
US "NUCLEUS user library"              = (*N=USERNUC,*F),
UO "SYSOVL user library"               = (*N=USEROV,*F),
UV "NVELIB user library"               = (*N=USERNVE,*F),
.
.HELP
 The GENNBE procedure installs the NOS/VE 170 state release files
 onto the running NOS/BE system, or onto user libraries used to
 prepare NOS/BE deadstart tapes.

 Parameter   Default   Description
   Name       Value

  [un]                 User name used as ID to access release files
  [bl]        nbebins  File containing system routines
  [nl]        nvelib   File containing NVE subsystem routines
  [ulib]      ulib     keyword denoting user library installation
  [pid]       cct      id used to access user libraries
  [up]        userpp   pp user library
  [us]        usernuc  nucleus user library
  [uo]        userov   sysovl user library
  [uv]        usernve  nvelib user library

.HELP,UN
 The UN parameter specifies the User Name under which the NOS/VE system
 is being installed. Used as a permanent file ID to access the release files.
.HELP,ULIB
 The ULIB parameter specifies that the release files are to be installed
 on to user libraries instead of the running system.
.HELP,BL
 The BL parameter specifies the name of the file of system programs being
 installed in the NOS/BE NUCLEUS and PP libraries.
.HELP,NL
 The NL parameter specifies the name of the file of programs used to create
 the NVELIB system library.
.HELP,PID
 The PID parameter specifies the permanent file id of the user libraries.
.HELP,UP
 The UP parameter specifies the name of the user library containing the
 NOS/BE pp programs.
.HELP,US
 The US parameter specifies the name of the user library containing the
 NOS/BE NUCLEUS programs.
.HELP,UO
 The UO parameter specifies the name of the user library containing the
 NOS/BE SYSOVL programs.
.HELP,UV
 The UV parameter specifies the name of the user library containing the
 NVELIB programs.
.ENDHELP
*IF ($string($name(wev$target_operating_system))='NOSBE')
GETFILE,BL,BL,UN,READ,A=YES.
GETFILE,NL,NL,UN,READ,A=YES.
.IFE,ULIB,USERL.
  GETFILE,UP,UP,PID,W,A=YES.
  GETFILE,US,US,PID,W,A=YES.
  GETFILE,UO,UO,PID,W,A=YES.
  GETFILE,UV,UV,PID,W,A=YES.
  SKIP,NOULIB.
    EXIT,U.
    REVERT,ABORT. USER LIBRARY MISSING
  ENDIF,NOULIB.
.ENDIF,USERL.
GTR,BL,NBEPPS.PP/*     SDA
GTR,BL,NBEABS.ABS/*    RHAQEP-FASLAVE
GTR,NL,NVEABS.ABS/*    DSMDST-EXTRACT
GTR,NL,SYMRELS.REL/*   IC7MMLI-WREPLNK
GTR,NL,PROCS.PROC/*    ACCFILE-TRM180
EDITLIB(SYSTEM,ERROR=3,I=DIR)
REVERT. NOS/VE C170 MODULES INSTALLED
EXIT.
REVERT,ABORT. GENNBE EDITLIB FAILED.
.DATA,DIR.
.IFE,ULIB,USERD.
LIBRARY(UP,OLD)
REPLACE(SDA,NBEPPS)
FINISH.
LIBRARY(US,OLD)
REPLACE(SETVE,PROCS)
REPLACE(NVE,PROCS)
REPLACE(RUNIRHF,PROCS)
REPLACE(VEIAF,PROCS)
REPLACE(RHAQEP,NBEABS)
REPLACE(RHAPFP,NBEABS)
REPLACE(FASLAVE,NBEABS)
FINISH.
LIBRARY(UO,OLD)
REPLACE(IIAPAS,NBEABS)
FINISH.
LIBRARY(UV,OLD)
REWIND(PROCS)
REPLACE(*,PROCS)
DELETE(SETVE)
DELETE(NVE)
DELETE(RUNIRHF)
DELETE(VEIAF)
DELETE(IC7MMLI)
DELETE(RUNJOBS)
REPLACE(*,SYMRELS)
REPLACE(*,NVEABS)
FINISH.
.ELSE,USERD.
READY(SYSTEM)
REPLACE(SDA,NBEPPS)
LIBRARY(NUCLEUS,OLD)
REPLACE(SETVE,PROCS,AL=7777)
REPLACE(NVE,PROCS,AL=7777)
REPLACE(RUNIRHF,PROCS,AL=1)
REPLACE(VEIAF,PROCS,AL=1)
REPLACE(RHAQEP,NBEABS,AL=1)
REPLACE(RHAPFP,NBEABS,AL=1)
REPLACE(FASLAVE,NBEABS,AL=1)
FINISH.
LIBRARY(SYSOVL,OLD)
REPLACE(IIAPAS,NBEABS,AL=1)
FINISH.
REWIND(PROCS)
LIBRARY(NVELIB,OLD)
REPLACE(*,PROCS,AL=1)
DELETE(SETVE)
DELETE(NVE)
DELETE(RUNIRHF)
DELETE(VEIAF)
DELETE(RUNJOBS)
DELETE(IC7MMLI)
REPLACE(*,SYMRELS,AL=0)
REPLACE(GTR,NVEABS,AL=1,FL=25000,FLO=1)
REPLACE(EXTRACT,NVEABS,AL=1,FL=30000)
REPLACE(NOTE,NVEABS,AL=1,FL=13300)
REPLACE(NVEPFU,NVEABS,AL=1,FL=15600)
REPLACE(DSMDST,NVEABS,AL=1)
REPLACE(DSMRUN,NVEABS,AL=1)
REPLACE(DSMTRM,NVEABS,AL=1)
REPLACE(COPYS,NVEABS,AL=1)
FINISH.
COMPLETE.
.ENDIF,USERD.
ENDRUN.
*ELSE
COMMENT. THIS PROCEDURE IS FOR NOS/BE ONLY.
*IFEND
/EOR
*DECK DECK=RAM$GENNOS EXPAND=TRUE
.PROC,GENNOS*I,
VSN "- Volume Serial Number of DS tape"= (*N=,
                                     *S6(ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789)),
D "tape Density (GE,PE,HD,HY)"         = (*N=PE,GE,PE,HD,HY),
B "- file of replacement records"      = (*N=0,*F),
I "- LIBEDIT directive Input file"     = (*N=,*F),
O "- LIBEDIT Output file"              = (*N=OUTPUT,*F),
LO "- LIBEDIT List Options"            = (*N=EM,*S4(CEMN),F),
.
.HELP
 The GENNOS procedure GENerates a NOS deadstart tape using the local
 file SYSTEM from the GETNOS procedure. The library NVELIB, the
 content of the NOSBINS library, the SETVE procedure from NVELIB, and
 the content of the file specified by the B parameter are
 added/replaced to the new deadstart tape.

 Parameter   Default   Description
   Name       Value

  [vsn]                 deadstart tape volume serial number
  [d]           pe      deadstart tape density (ge,pe,hd,hy)
  [b]           0       file containing replacement records for the
                        new deadstart file (CMRDECKs, IPRDECKs, etc.)
  [i]                   file containing LIBEDIT directives
  [o]         output    file receiving LIBEDIT output
  [lo]          EM      LIBEDIT list options

.HELP,VSN
 The VSN parameter specifies the deadstart tape volume serial number.
.HELP,D
 The D parameter specifies the deadstart tape density.
 The default density is PE.
.HELP,B
 The B parameter names the file containing user supplied
 replacements. The default assumes no user supplied file exists.
.HELP,I
 The I parameter specifies a file of LIBEDIT directives to direct
 insertion/deletion of NOS deadstart file records. The default assumes
 no user supplied file exists.
.HELP,O
 The O parameter specifies the file to which LIBEDIT output is written.
 The default value is OUTPUT.
.HELP,LO
 The LO parameter specifies the LIBEDIT list options used.
 The default value is EM (errors, and modifications).
.ENDHELP
SETASL,*.
SETJSL,*.
SETTL,*.
.IFE,FILE(SYSTEM,.NOT.AS),QUIT.
  $NOTE,OUTPUT,NR.+ **  OLD NOS SYSTEM FILE NOT FOUND,
  $NOTE,OUTPUT,NR.+ **  RERUNNING GETNOS PROCEDURE.
  GETNOS.
.ENDIF,QUIT.
.IFE,$B$.NE.$0$,GETB.
  GETFILE,B,B,,READ,A=YES.
  $UNLOAD,YYYYGRP.
  $COPY,B,YYYYGRP,TC=#I,PO=M. * REMOVE ANY EXTRANEOUS *EOF* FILE MARKS
  $RENAME,B=YYYYGRP.
.ENDIF,GETB.
$NOTE,OUTPUT,NR.+ **  EXTRACTING RECORDS FROM NOSBINS.
GETLIB,ALL,L=NOSBINS,G=YYYYGRP.
$RENAME,NOSBINS=YYYYGRP.
GETFILE,NVELIB,NVELIB,,READ,A=YES.
$UNLOAD,YYYYDIR.
$GTR,NVELIB,YYYYDIR,U,,,NA.ULIB/NVELIB
$IFE,.NOT.FILE(YYYYDIR,AS),CHANGENAME.
  $NOTE,OUTPUT,NR.+ ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
  $NOTE,OUTPUT,NR.+ **    WARNING ... WARNING ... WARNING     **
  $NOTE,OUTPUT,NR.+ **  FILE NVELIB HAS WRONG DIRECTORY NAME, **
  $NOTE,OUTPUT,NR.+ **  CHANGING DIRECTORY NAME TO NVELIB.    **
  $NOTE,OUTPUT,NR.+ ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
  $LIBEDIT,P=NVELIB,N=YYYYDIR,#B=0,L=0,#I=0,U=NVELIB.
  $UNLOAD,ZZZZZG2.
  $RENAME,NVELIB=YYYYDIR.
  $LIBRARY,NVELIB/D.
  $LIBRARY,NVELIB/A.
$ENDIF,CHANGENAME.
$NOTE(YYYYDIR,NR)+*FILE NOSBINS
$NOTE(YYYYDIR,NR)+*REWIND NOSBINS
$NOTE(YYYYDIR,NR)+*#B *,ABS/*
$NOTE(YYYYDIR,NR)+*#B *,PP/*
$NOTE(YYYYDIR,NR)+*#B *,PROC/*
$NOTE(YYYYDIR,NR)+*FILE NVELIB
$NOTE(YYYYDIR,NR)+*REWIND NVELIB
$NOTE(YYYYDIR,NR)+*#B *,ULIB/NVELIB
.IFE,$I$.NE.$$,GETI.
  GETFILE,I,I,,READ,A=YES.
  $NOTE(YYYYDIR,NR)+*FILE B
  $NOTE(YYYYDIR,NR)+*REWIND B
  $NOTE(YYYYDIR,NR)+*TYPE TEXT
  $COPYEI,I,YYYYDIR.
  .IFE,.NOT.FILE(I,AS),RETURNI.
    $UNLOAD,I.
  .ENDIF,RETURNI.
.ENDIF,GETI.
$PACK(YYYYDIR)
$NOTE,OUTPUT,NR.+ **  GENERATING NEW NOS DEADSTART FILE.
$UNLOAD,YYYYERR.
$LIBEDIT,P=SYSTEM,L=YYYYERR,#B=B,N=YYYYNOS,#I=YYYYDIR,#LO=LO.
$REWIND,YYYYERR.
$COPY,YYYYERR,O.
$UNLOAD,YYYYERR.
.IFE,$B$.NE.$0$,USERBIN.
  .IFE,.NOT.FILE(B,AS),RETURNB.
    $UNLOAD,B.
  .ENDIF,RETURNB.
.ENDIF,USERBIN.
$SKIP,NOERROR.
  $EXIT.
  $REWIND,YYYYERR.
  $COPY,YYYYERR,O.
  $UNLOAD,YYYYDIR,YYYYERR.
  $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    $EXIT. GENNOS *TERMINATED*
  $ENDIF,TERMINATED.
  $REVERT,ABORT. DEADSTART FILE GENERATION ERROR
$ENDIF,NOERROR.
.IFE,$VSN$.EQ.$$,WRITEFILE.
  $UNLOAD,SYSTEM.
  $ATTACH,SYSTEM/NA.
  $IFE,FILE(SYSTEM,AS),CHANGENAME.
    $PURGE,OLDSYS/NA.
    $CHANGE,OLDSYS=SYSTEM.
    $NOTE,OUTPUT,NR.+ **  EXISTING FILE "SYSTEM" NOW "OLDSYS".
    $UNLOAD,SYSTEM.
  $ENDIF,CHANGENAME.
  $PURGE,SYSTEM/NA.
  $DEFINE,SYSTEM/CT=S.
  $REWIND,YYYYNOS.
  $COPYEI,YYYYNOS,SYSTEM.
  $UNLOAD,YYYYNOS,SYSTEM.
  $SKIP,NOERROR.
    $NOTE,OUTPUT,NR.+ **  ERROR IN WRITING DEADSTART FILE TO "SYSTEM".
    $UNLOAD,NOSBINS,YYYYDIR,YYYYNOS,SYSTEM.
    $REVERT,ABORT. ERROR IN WRITING TO DEADSTART FILE.
.ELSE,WRITEFILE.
  $SET,R1=0.
  $WHILE,(FILE(YYYYNOS,AS).AND.(R1.LT.3)),WRITETAPE.
    $UNLOAD,SYSTEM.
    $NOTE,OUTPUT,NR.+ **  REQUESTING NEW DEADSTART TAPE AS ...
    $NOTE,OUTPUT,NR.+ **  $LABEL,SYSTEM,#D=D,PO=W,LB=KU,F=#I,#VSN=VSN.
    $LABEL,SYSTEM,#D=D,PO=W,LB=KU,F=#I,#VSN=VSN.
    $REWIND,YYYYNOS.
    $NOTE,OUTPUT,NR.+ **  COPYING NOS DEADSTART FILE TO TAPE.
    $COPYEI,YYYYNOS,SYSTEM.
    $UNLOAD,NOSBINS,YYYYDIR,YYYYNOS,SYSTEM.
    $SKIP,NOERROR.
      $EXIT. TAPE ERROR .....................................
      $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
        $UNLOAD,YYYYDIR,SYSTEM.
        $RENAME,NEWNOS=YYYYNOS.
        $NOTE,OUTPUT,NR.+ **  DEADSTART FILE PLACED ON FILE "NEWNOS".
        $EXIT. GENNOS *TERMINATED*
      $ENDIF,TERMINATED.
      $IFE,R1=2,GIVEUP.
        $UNLOAD,YYYYDIR,SYSTEM.
        $RENAME,NEWNOS=YYYYNOS.
        $NOTE,OUTPUT,NR.+ **  DEADSTART FILE PLACED ON FILE "NEWNOS".
        $REVERT,ABORT. TOO MANY TAPE ERRORS
      $ELSE,GIVEUP.
        $NOTE,OUTPUT,NR.+ **  TAPE ERROR ENCOUNTERED ... ATTEMPTING REWRITE.
        $SET,R1=R1+1.
      $ENDIF,NOERROR.
    $ENDW,WRITETAPE.
.ENDIF,WRITEFILE.
$ENDIF,NOERROR.
$REVERT. NOS DEADSTART FILE WRITTEN
/EOR
*DECK DECK=RAM$GENNVE EXPAND=TRUE
.PROC,GENNVE*I,
VSN "Volume Serial Number of DS tape"  = (*N=,
                           *S6(ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789)),
D "tape Density (GE,PE,HD,HY)"         = (*N=PE,GE,PE,HD,HY),
L "Library containing NOS/VE binaries" = (*N=NVEBINS,*F),
CF "Command File for deadstart builder"= (*N=LOADDIR,*F),
SC "SCript name for NOS/VE binaries"   = (*N=SSCRIPT,*F),
UN "User Name for file access"         = (*N=,*F),
.
.HELP
 The GENNVE procedure GENerates a NOS/VE deadstart file from
 configured components contained on the NVELIB user library and/or
 files named the same as binaries contained on the library named
 by the L parameter value.

 Parameter   Default   Description
   Name       Value

  [vsn]                 deadstart tape volume serial number
  [d]           pe      deadstart tape density (ge,pe,hd,hy)
  [l]         nvebins   library containing NOS/VE binaries
  [cf]        loaddir   command file for deadstart tape builder
  [sc](*)     db56lst   script name for NOS/VE binaries
  [un]                  permanent file id (NOS/BE systems only)

.HELP,VSN
 The VSN parameter specifies the deadstart tape volume serial number.
 The default is to create a permanent file named NEWTPXK.
.HELP,D
 The D parameter specifies the deadstart tape density.
 The default density is PE.
.HELP,L
 The L parameter specifies the library containing NOS/VE binaries.
 The default value is NVEBINS.
.HELP,CF
 The CF parameter names the file containing deadstart tape builder
 directives. The default is LOADDIR.
.HELP,SC
 The SC parameter names a script associated with the type of NOS/VE
 binaries used to construct the deadstart file.
 The default is SSCRIPT.
.HELP,UN
 The UN parameter is used as a permanent file ID on NOS/BE systems. It
 should not be specified on NOS systems.
.ENDHELP
.IFE,SYS=NOS,NOSSYS1.
  $SETASL,*.
  $SETJSL,*.
  $SETTL,*.
.ENDIF,NOSSYS1.
SET,R1=0.
.IFE,FILE(L,.NOT.AS),GETL.
  GETFILE,L,L,UN,READ,A=YES.
.ENDIF,GETL.
.*
.* GET THE DEADSTART TAPE DIRECTIVES AND SCRIPTS TO DETERMINE TAPE CONTENT.
.*
.IFE,FILE(CF,.NOT.AS),GETCF.
  GETFILE,CF,CF,UN,READ,A=YES.
.ENDIF,GETCF.
GETFILE,SC,SC,UN,READ,A=YES.
.*
.* GET THE NOS/VE CORE AND TEMPLATE FILES
.*
EXPTEXT,PSYXX,L,UN,G=PSYXX.
EXPTEXT,PJBXXYY,L,UN,G=PJBXXYY.
.*
.* GET THE NOS/VE $SYSTEM FILES
.*
EXPTEXT,BLTNLIB,L,UN,G=BLTNLIB.
EXPTEXT,TASKLIB,L,UN,G=TASKLIB.
.*
.* GET THE NOS/VE PP BINARIES
.*
EXPTEXT,DSMSMU,L,UN,G=DSMSMU.
EXPTEXT,CTMSCD,L,UN,G=CTMSCD.
EXPTEXT,DSMRES,L,UN,G=DSMRES.
EXPTEXT,DSK7154,L,UN,G=DSK7154.
EXPTEXT,DSK55A,L,UN,G=DSK55A.
EXPTEXT,DSK55B,L,UN,G=DSK55B.
EXPTEXT,DSK55C7,L,UN,G=DSK55C7.
EXPTEXT,DSK55C8,L,UN,G=DSK55C8.
EXPTEXT,ISD,L,UN,G=ISD.
EXPTEXT,TAPE,L,UN,G=TAPE.
EXPTEXT,DSMSMA,L,UN,G=DSMSMA.
EXPTEXT,NETW,L,UN,G=NETW.
EXPTEXT,VM5B,L,UN,G=VM5B.
.*
.* GET THE SYSTEM CORE COMMAND FILE
.*
GETFILE,DCFILE,DCFILE,UN,READ.
.*
.* ACQUIRE THE CONFIGURATION PROLOG
.*
GETFILE,SITECP,SITECP,UN,READ.
.*
.* ASSURE THAT SYSTEM CORE AND JOB TEMPLATE ARE PROPERLY FORMATTED.
.*
RETURN,NEWPSC,NEWDESC,NEWPJT.
.IFE,($VSN$.EQ.$$),NOVSN.
  .IFE,SYS=NOS,NOSSYS2.
    $PURGE,NEWTPXK/NA.
    $DEFINE,NVETAPE=NEWTPXK/CT=S.
  .ELSE,NOSSYS2.
    REQUEST,NVETAPE,SN,PF.
  .ENDIF,NOSSYS2.
.ENDIF,NOVSN.
.*
.* BEGIN NOS/VE DEADSTART FILE GENERATION
.*
DSMDSTG(CF)
IFE,(FILE(NVETAPE,AS)),ADDTERM.
  DSMDSTG(TERMEND)
  .IFE,($VSN$.EQ.$$).AND.(SYS.EQ.NOSB),NBESYS1.
    REPFILE,NVETAPE,NEWTPXK,,,,UN.
  .ENDIF,NBESYS1.
ELSE,ADDTERM.
  SET,R1=1. ERROR IN GENERATION - ERROR FLAG SET
ENDIF,ADDTERM.
SKIP,NOERROR.
  EXIT.
  DAYFILE.
  ROUTE,OUTPUT,DC=PR.
  SET,R1=1. GENERATION ABORT - ERROR FLAG SET
ENDIF,NOERROR.
UNLOAD,PSYXX,PJBXXYY,PSYXLDR.
UNLOAD,DSK7154,DSK55A,DSK55B,DSK55C7,DSK55C8,ISD.
UNLOAD,DSMSMU,CTMSCD,DSMSMA,DSMRES,TAPE,VM5B.
UNLOAD,DCFILE,PROLOGS,TEMPDTA.
UNLOAD,TERM,EMPTY,TERMEND,LOADDIR,SSCRIPT,ZZZZCF1,ZZZZCF2.
UNLOAD,BLTNLIB.
UNLOAD,TASKLIB.
IFE,R1=1,ERROR.
  .IFE,($VSN$.EQ.$$).AND.(SYS.EQ.NOS),CLEANUP.
    $PURGE,NEWTPXK/NA.
  .ENDIF,CLEANUP.
  .IFE,SYS=NOS,NOSSYS3.
    $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
      $EXIT. GENNVE *TERMINATED*
    $ENDIF,TERMINATED.
  .ENDIF,NOSSYS3.
  REVERT,ABORT. GENERATION ERRORS
ELSE,ERROR.
  .IFE,($VSN$.NE.$$),WRITEVSN.
    WHILE,(FILE(NVETAPE,AS).AND.(R1.LT.3)),WRITETAPE.
      UNLOAD,TAPE.
      REWIND,NVETAPE.
      .IFE,SYS=NOS,NOSSYS4.
        $LABEL,TAPE,#D=D,F=I,LB=KU,PO=W,#VSN=VSN.
        $COPYEI,NVETAPE,TAPE.
        $WRITEF(TAPE)
      .ELSE,NOSSYS4.
        REQUEST,TAPE,D,RING,#VSN=VSN.
        COPYBF,NVETAPE,TAPE.
      .ENDIF,NOSSYS4.
      UNLOAD,TAPE,NVETAPE.
      SKIP,NOERROR.
        EXIT. TAPE ERROR ....................................
        .IFE,SYS=NOS,NOSSYS5.
          $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
            $EXIT. GENNVE *TERMINATED*
          $ENDIF,TERMINATED.
        .ENDIF,NOSSYS5.
        IFE,R1=2,GIVEUP.
          REVERT,ABORT. TOO MANY TAPE ERRORS
        ELSE,GIVEUP.
          NOTE,OUTPUT,NR.+ TAPE ERROR ENCOUNTERED ... ATTEMPTING REWRITE
          SET,R1=R1+1.
        ENDIF,GIVEUP.
      ENDIF,NOERROR.
    ENDW,WRITETAPE.
  .ELSE,WRITEVSN.
    UNLOAD,NVETAPE.
  .ENDIF,WRITEVSN.
  REVERT. DEADSTART TAPE GENERATED
ENDIF,ERROR.
.DATA,TERM
THIS IS THE TERMINATION RECORD FILE.
.DATA,EMPTY
THIS IS EMPTY FILE
.DATA,TERMEND
LOADFILE,TERM,TERMINATOR
ENDTAPE
LOADEND
.DATA,LOADDIR
WRITEAR,0
LOADPP,DSMSMU,SMU
LOADPP,CTMSCD,SCD
LOADPP,DSMRES,RES
LOADPP,DSK7154,D4
LOADPP,DSK55A,D5A
LOADPP,DSK55B,D5B
LOADPP,DSK55C7,D5C
LOADPP,DSK55C8,D5C2
LOADPP,ISD,ISD
LOADPP,TAPE,TAPE
LOADPP,NETW,NETW
LOADPP,VM5B,VM5B
WRITEAR,1
LOADCRE,PSYXX
WRITEAR,3
LOADSSR,DSMSMA
WRITEAR,4
LOADDCF,DCFILE
WRITEAR,5
LOADTPL,PJBXXYY
WRITEAR,11
LOADFILE,SITECP,ASCII180
LOADFILE,SSCRIPT,DESCRIPTOR,NAME170=SSCRIPT
LOADFILE,BLTNLIB,B56,NAME170=BLTNLIB
LOADFILE,TASKLIB,B56,NAME170=TASKLIB
LOADFILE,TERM,TERMINATOR
LOADEND
.DATA,SSCRIPT
FILE180 = 'OSF$BUILTIN#_LIBRARY'
PACKING = 'B56'
CREATE#_VARIABLE RAV$IGNORE#_STATUS K=STATUS
DETACH#_FILE $NAME(FILE180) STATUS=RAV$IGNORE#_STATUS
REPEAT
TASK RING=3
DELETE#_FILE $FNAME('$USER.'//FILE180) STATUS=RAV$IGNORE#_STATUS
TASKEND
UNTIL NOT RAV$IGNORE#_STATUS.NORMAL
CREATE#_FILE $FNAME('$USER.'//FILE180) $NAME(FILE180) LOG=FALSE RETENTION=999
CREATE#_FILE#_PERMIT $FNAME('$USER.'//FILE180) GROUP=PUBLIC
SET#_FILE#_ATTRIBUTES $FNAME('$USER.'//FILE180) FC=OBJECT FS=LIBRARY RT=UNDEFINED
DISPLAY#_VALUE ' LOADING '//FILE180//', CONVERSION='//PACKING
LOAD#_FILE LFN=$NAME(FILE180) FS=$NAME(PACKING)
DETACH#_FILE $NAME(FILE180) STATUS=RAV$IGNORE#_STATUS
CHANGE#_FILE#_ATTRIBUTES $FNAME('$USER.'//FILE180) RING#_ATTRIBUTES=(3 13 13)
DETACH#_FILE $FNAME('$USER.'//FILE180) STATUS=RAV$IGNORE#_STATUS
.EOR
FILE_180 = 'OSF$OPERATOR#_LIBRARY'
PACKING = 'B56'
DETACH#_FILE $NAME(FILE180) STATUS=RAV$IGNORE#_STATUS
REPEAT
TASK RING=3
DELETE#_FILE $FNAME('$USER.'//FILE180) STATUS=RAV$IGNORE#_STATUS
TASKEND
UNTIL NOT RAV$IGNORE#_STATUS.NORMAL
CREATE#_FILE $FNAME('$USER.'//FILE180) $NAME(FILE180) LOG=FALSE RETENTION=999
SET#_FILE#_ATTRIBUTES $FNAME('$USER.'//FILE180) FC=OBJECT FS=LIBRARY RT=UNDEFINED
DISPLAY#_VALUE 'LOADING '//FILE180//', CONVERSION='//PACKING
LOAD#_FILE LFN=$NAME(FILE180) FS=$NAME(PACKING)
CHANGE#_FILE#_ATTRIBUTES $FNAME('$USER.'//FILE180) RING#_ATTRIBUTES=(3 13 13)
DETACH#_FILE $FNAME('$USER.'//FILE180) STATUS=RAV$IGNORE#_STATUS
/EOR
*DECK DECK=RAM$GENREL EXPAND=TRUE
.PROC,GENREL*I,
PRC " - name of file containing restore procedure" = (*F,LIBRARY,*N=LIBRARY),
LIB " - name of file containing NVELIB"            = (*F,*N=NVELIB),
NVE " - name of file containing NOS/VE DS file"    = (*F,*N=TPXXXK),
DSP " - name of file containing Dual State code"   = (*F,*N=NOSBINS),
NVR " - name of file containing relocatables"      = (*F,*N=NVERELS),
SCP " - name of file containing prologs"           = (*F,*N=SITECP),
DCF " - name of file containing DCF decks"         = (*F,*N=DCFILE),
NVP " - name of file containing NVEPROL"           = (*F,*N=NVEPROL),
CRL " - name of file containing NOS CYBIL RTL"     = (*F,*N=CYBCLIB),
UN  " - name of user catalog containing files"     = (*F,*N=),
VSN "Volume Serial Number of tape"                 = (*N=,
                                     *S6(ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789)),
D   " - tape density"                              = (HD,PE,GE,*N=PE),
V   " - verify files on tape"                      = (YES,NO,*N=NO,*K=YES),
F   " - format of tape"                            = (*N=I,SI,I),
.
.HELP
 The GENREL procedure GENerates a new RELease tape containing updated
 Dual State binary routines.

 Parameter   Default   Description
   Name       Value

   PRC       LIBRARY   Location of RESTORE procedure. Either file name
                       or keyword LIBRARY. The keyword LIBRARY means
                       extract the procedure from the LIB file.
   LIB       NVELIB    Name of NVELIB file containing procedures etc.
   NVE       TPXXXK    Name of NOS/VE system binaries file.
   DSP       NOSBINS   Name of Dual State (Real State) binaries file.
   NVR       NVERELS   Name of Dual State (Real State) relocatables file.
   SCP       SITECP    Name of file containing configuration prolog and
                       other files.
   DCF       DCFILE    Name of file containing sets of system core commands.
   NVP       NVEPROL   Name of file containing NVEPROL.
   CRL       CYBCLIB   Name of file containing NOS CYBIL run time library.
   UN        null      Name of user catalog containing files.
   D         PE        Density of tape to write.
   V         no,yes    Verify files on tape flag.
   F         I         Format of release tape

.HELP,PRC
 The PRC parameter specifies the location of the RESTORE procedure. This
 may be a file or the keyword LIBRARY to indicate that the procedure
 should be extracted from the LIB file.
.HELP,LIB
 The LIB parameter specifies the file containing the NVELIB routines.
.HELP,NVE
 The NVE parameter specifies the file containing the NOS/VE deadstart file.
.HELP,DSP
 The DSP parameter specifies the file containing the Dual State routines.
.HELP,NVR
 The NVR parameter specifies the file containing the Dual State relocatables.
.HELP,SCP
 The SCP parameter specifies the file containing the prolog files.
.HELP,DCF
 The DCF parameter specifies the file containing the DCF decks.
.HELP,NVP
 The NVP parameter specifies the file containing NVEPROL.
.HELP,CRL
 The CRL parameter specifies the file containing the CYBIL run time library.
.HELP,UN
 The UN parameter specifies the user catalog containing the files.
.HELP,F
 The F parameter specifies the format of the release tape.
.ENDHELP
GETFILE(YYYLIB,LIB,UN,READ,YES)
GETFILE(YYYNVE,NVE,UN,READ,YES)
GETFILE(YYYDSP,DSP,UN,READ,YES)
GETFILE(YYYNVR,NVR,UN,READ,YES)
GETFILE(YYYSCP,SCP,UN,READ,YES)
GETFILE(YYYDCF,DCF,UN,READ,YES)
GETFILE(YYYNVP,NVP,UN,READ,YES)
GETFILE(YYYCRL,CRL,UN,READ,YES)
.IFE($PRC$.EQ.$LIBRARY$,GTRLIB)
  $GTR(YYYLIB,YYYPRC)PROC/RESTORE
.ELSE(GTRLIB)
  GETFILE(YYYPRC,PRC,UN,READ,YES)
.ENDIF(GTRLIB)
$REWIND(YYYPRC,YYYLIB,YYYNVE,YYYDSP,YYYHNT)
$UNLOAD(TAPE)
$LABEL(TAPE,#D=D,#F=F,LB=KU,PO=W,#VSN=VSN)
$COPYBF(YYYPRC,TAPE)
$COPYBF(YYYLIB,TAPE)
$COPYBF(YYYDSP,TAPE)
$COPYBF(YYYNVP,TAPE)
$COPYBF(YYYNVE,TAPE)
$COPYBF(YYYSCP,TAPE)
$COPYBF(YYYDCF,TAPE)
$COPYBF(YYYNVR,TAPE)
$COPYBF(YYYCRL,TAPE)
.IFE($V$.EQ.$YES$,VERIFYTAPE)
  $REWIND(TAPE,YYYPRC,YYYLIB,YYYNVE,YYYDSP)
  $REWIND(YYYNVP,YYYSCP,YYYDCF,YYYNVR,YYYCRL)
  $VERIFY(TAPE,YYYPRC,N=1,A)
  $VERIFY(TAPE,YYYLIB,N=1,A)
  $VERIFY(TAPE,YYYDSP,N=1,A)
  $VERIFY(TAPE,YYYNVP,N=1,A)
  $VERIFY(TAPE,YYYNVE,N=1,A)
  $VERIFY(TAPE,YYYSCP,N=1,A)
  $VERIFY(TAPE,YYYDCF,N=1,A)
  $VERIFY(TAPE,YYYNVR,N=1,A)
  $VERIFY(TAPE,YYYCRL,N=1,A)
.ENDIF(VERIFYTAPE)
$UNLOAD(TAPE,YYYPRC,YYYLIB,YYYNVE,YYYDSP)
$UNLOAD(YYYNVP,YYYSCP,YYYDCF,YYYNVR,YYYCRL)
$REVERT.  RELEASE TAPE BUILT SUCCESSFULLY
$EXIT.
$REVERT(ABORT) TAPE BUILD FAILED CHECK DAYFILE
/EOR
*DECK DECK=RAM$GETFILE EXPAND=TRUE
.PROC,GETFILE*I,
LFN "- Local File Name"                = (*F),
PFN "- Permanent File Name"            = (*N=,*F),
UN "- User Name of permanent file"     = (*N=,*F),
M "- Mode of file access"              = (*N=W,W=W,R=R,WRITE=W,READ=R),
A "- Abort if file is NOT FOUND"       = (*N=NO,YES,NO),
.
.HELP
 The GETFILE procedure GETs either INDIRECT or DIRECT access FILEs.

 Parameter   Default   Description
   Name       Value

   lfn                 local file name by which the file is accessed
  [pfn]       lfn      permanent file name of the stored file
  [un]                 user name in which file resides
  [m]          w       access mode of the file
  [a]          no      abort if the file is NOT FOUND

.HELP,LFN
 The LFN parameter selects the name by which the file is accessed.
.HELP,PFN
 The PFN parameter selects the name by which the file was stored.
 The default is the value specified for the LFN parameter.
.HELP,UN
 The UN parameter specifies the User Name location of the file. On NOS,
 the default value is the User Name in which this procedure executes.
 On NOS/BE, the UN parameter specifies a permanent file ID and must be
 supplied.
.HELP,M
 The M parameter selects the Mode of access for the file.
 Options are:  W | WRITE  - for write access (default value)
               R | READ   - for read access
.HELP,A
 The A parameter value selects whether to Abort if the file is NOT FOUND.
 Options are:  NO   - do not abort if file is NOT FOUND (default value)
               YES  - abort if file is NOT FOUND
.ENDHELP
.IFE,$PFN$.EQ.$$,NAMEPFN.
  REVERT,EX.GETFILE,LFN,LFN,UN,M,A.
.ENDIF,NAMEPFN.
.IFE,FILE(LFN,WR),WRITEFILE.
  REWIND,LFN.
  REVERT. FILE LFN ALREADY LOCAL
.ENDIF,WRITEFILE.
.IFE,SYS=NOS,NOSSYS.
  .IFE,FILE(LFN,PM),FILEPRM.
    .IFE,FILE(LFN,RD),COPYLOCAL.
      $REWIND,LFN.
      .IFE,$M$.EQ.$W$,MAKECOPY.
        $COPYEI,LFN,YYYYTMP.
        $RENAME,LFN=YYYYTMP.
        $REWIND,LFN.
      .ENDIF,MAKECOPY.
    .ELSE,COPYLOCAL.
      $REVERT,ABORT. CANNOT COPY FILE LFN
    .ENDIF,COPYLOCAL.
  .ELSE,FILEPRM.
    $GET,LFN=PFN/#UN=UN,NA.
    $IFE,FILE(LFN,AS),FILEIND.
      $REVERT. PFN(INDIRECT) --> LFN
    $ENDIF,FILEIND.
    $ATTACH,LFN=PFN/#UN=UN,#M=M,NA.
    $IFE,FILE(LFN,AS),FILEDIR.
      $IFE,FILE(LFN,WR),WRITEFILE.
        $REWIND,LFN.
        $REVERT. PFN(DIRECT) --> LFN
      $ELSE,WRITEFILE.
        $IFE,FILE(LFN,RD),COPYLOCAL.
          .IFE,$M$.EQ.$W$,MAKECOPY.
            $COPYEI,LFN,YYYYTMP.
            $RENAME,LFN=YYYYTMP.
          .ENDIF,MAKECOPY.
          $REWIND,LFN.
        $ELSE,COPYLOCAL.
          $REVERT,ABORT. CANNOT COPY FILE LFN
        $ENDIF,COPYLOCAL.
      $ENDIF,WRITEFILE.
    $ELSE,FILEDIR.
      .IFE,$M$.EQ.$W$,GETCOPY.
        $REVERT,EX.GETFILE,LFN,PFN,UN,READ,A.
      .ENDIF,GETCOPY.
      .IFE,$A$.NE.$NO$,ABORT.
        $REVERT,ABORT. FILE PFN NOT FOUND
      .ELSE,ABORT.
        $REVERT. FILE PFN NOT FOUND
      .ENDIF,ABORT.
    $ENDIF,FILEDIR.
  .ENDIF,FILEPRM.
  $REVERT. PFN(DIRECT) --> LFN
EXIT.
IFE(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
  EXIT. GETFILE *TERMINATED*
ELSE,TERMINATED.
  REVERT,ABORT. GETFILE FAILED
ENDIF,TERMINATED.
.ELSE,NOSSYS.
  .IFE,$UN$.EQ.$$,NOUSER.
    NOTE(OUTPUT,NR)+ NO USERNAME WITH GETFILE
    REVERT,ABORT. NO USERNAME WITH GETFILE
  .ELSE,NOUSER.
    .IFE,OT.EQ.TXO.DFLIST,OFF.
    .IFE,$M$.EQ.$W$,WRITEPERM.
      RETURN,LFN.
      ATTACH,LFN,PFN,ID=UN.
    .ELSE,WRITEPERM.
      .IFE,FILE(LFN,AS),READPERM.
        .IFE,OT.EQ.TXO.DFLIST,ON.
        REVERT. LFN ALREADY ATTACHED (READ-ONLY)
      .ELSE,READPERM.
        ATTACH,LFN,PFN,ID=UN,MR=1.
      .ENDIF,READPERM.
    .ENDIF,WRITEPERM.
      .IFE,OT.EQ.TXO.DFLIST,ON.
      REVERT. ATTACHED #LFN=LFN #PFN=PFN ID=UN
  .ENDIF,NOUSER.
    EXIT(U)
    .IFE,OT.EQ.TXO.DFLIST,ON.
  .IFE,$A$.NE.$NO$,ABORT.
    NOTE(OUTPUT,NR)+ FILE PFN NOT FOUND
    REVERT,ABORT. FILE PFN NOT FOUND
  .ELSE,ABORT.
    DISCONT,OUTPUT.
    BKSP(OUTPUT)
    SET(EF=0)
    REVERT. FILE PFN NOT FOUND
  .ENDIF,ABORT.
EXIT.
  .IFE,OT.EQ.TXO.DFLIST,ON.
  REVERT,ABORT. GETFILE FAILED
.ENDIF,NOSSYS.
/EOR
*DECK DECK=RAM$GETLIB EXPAND=TRUE
.PROC,GETLIB*I,
R "- Record name (or ALL or *)"        = (ALL=$*$,$*$,*F),
L "- Library file name"                = (*N=#FILE,*F),
UN "- User Name of library file"       = (*N=,*F),
G "- Group file receiving record(s)"   = (*N=,*F),
T "- Type of record(s) being extracted"= (*N=,ABS,CAP,OPL,OPLC,OPLD,OVL,
                                               PP,PPU,PROC,REL,TEXT,ULIB),
E "- Exclude record(s) of this type"   = (*N=,ABS,CAP,OPL,OPLC,OPLD,OVL,
                                               PP,PPU,PROC,REL,TEXT,ULIB),
.
.HELP
 The GETLIB procedure GETs records from a LIBrary file by their type.

 Parameter   Default   Description
   Name       Value

   r                   record name to extract (or ALL or *)
  [l]                  library file containing the record(s)
  [un]                 user name in which library resides
  [g]                  local file to which record(s) are written
  [t]                  type of record(s) being extracted
  [e]                  type of record(s) to exclude when R=ALL

.HELP,R
 The R parameter names the record to extract from a library file.
.HELP,L
 The L parameter names the file containing a library of records.
 The default value is the file containing this procedure.
.HELP,UN
 The UN parameter specifies the User Name location of the file.
 The default value is the User Name in which this procedure executes.
 On NOS/BE, The UN parameter specifies the permanent file ID of the file.
.HELP,G
 The G parameter names a local file to which record(s) are written.
 The default value is GROUP if ALL is specified for the R parameter,
 otherwise the R parameter value is the default.
.HELP,T
 The T parameter specifies the record type extracted from a library.
 The default is to extract all record types.
.HELP,E
 The E parameter names an excluded record type when R=ALL.
 By default all types specified by the T parameter are included.
 This parameter is ignored on NOS/BE.
.ENDHELP
.IFE,$G$.EQ.$L$,ERROR.
  REVERT,ABORT. CANNOT GET G --> L
.ENDIF,ERROR.
.IFE,(($G$.EQ.$$).AND.($R$.EQ.$*$)),ALLGROUP.
  REVERT,EX.GETLIB,R,L,UN,GROUP,T,E.
.ENDIF,ALLGROUP.
.IFE,(($G$.EQ.$$).AND.($R$.NE.$*$)),NOTALL.
  REVERT,EX.GETLIB,R,L,UN,R,T,E.
.ENDIF,NOTALL.
.IFE,FILE(L,.NOT.AS),NOTLOCAL.
  GETFILE,L,L,UN,READ,A=YES.
.ENDIF,NOTLOCAL.
.IFE,$R$.NE.$*$,NOTALL.
  IFE,FILE(G,AS),GOTG.
    REVERT. LOCAL FILE G FOUND
  ELSE,GOTG.
    GETFILE,G,G,UN,READ.
    IFE,FILE(G,AS),GOTGPF.
      NOTE,OUTPUT,NR.+ PERMANENT FILE G FOUND, #UN=UN.
      REVERT. PERMANENT FILE G FOUND
    ENDIF,GOTGPF.
  ENDIF,GOTG.
.ENDIF,NOTALL.
.IFE,(($R$.EQ.$*$).AND.($T$.EQ.$$)),ALLREC.
.*
.* RECORDS = ALL, RECORD TYPE NOT SPECIFIED
.*
  UNLOAD,G.
  .IFE,SYS=NOS,NOSSYS.
    .IFE,$E$.NE.$$,EXCLUDE.
      $NOTE(YYYGETD)+*IGNORE E/*
      $PACK(YYYGETD)
    .ENDIF,EXCLUDE.
    $GTR(L,G)ULIB/*
    $IFE,(FILE(G,AS).AND.($E$.NE.$ULIB$)),GETULIB.
      $LIBEDIT,P=0,N=YYYGETL,B=G,#L=0,I=YYYGETD.
      $RENAME,G=YYYGETL.
    $ELSE,GETULIB.
      $LIBEDIT,P=0,N=G,B=L,#L=0,I=YYYGETD.
    $ENDIF,GETULIB.
    $UNLOAD,YYYGETD.
  .ELSE,NOSSYS.
    COPYBF(L,G)
  .ENDIF,NOSSYS.
.ELSE,ALLREC.
  .IFE,(($T$.NE.$$).AND.($R$.EQ.$*$)),ALLTYPE.
.*
.* RECORDS = ALL, TYPE WAS SPECIFIED
.*
    UNLOAD,G.
    .IFE,$T$.NE.$ULIB$,NOTULIB.
      GTR(L,G)T/*
    .ELSE,NOTULIB.
      GTR(L,G,U)ULIB/*
    .ENDIF,NOTULIB.
    IFE,FILE(G,.NOT.AS),NOTFOUND.
 REVERT,ABORT. NO T RECORDS ON L, #UN=UN.
    ENDIF,NOTFOUND.
  .ELSE,ALLTYPE.
    .IFE,$T$.NE.$$,USERTYPE.
.*
.* RECORD NAME SPECIFIED, TYPE WAS SPECIFIED
.*
      .IFE,$T$.NE.$ULIB$,NOTULIB.
        GTR(L,G)T/R
      .ELSE,NOTULIB.
        GTR(L,G,U)ULIB/R
      .ENDIF,NOTULIB.
    .ELSE,USERTYPE.
.*
.* RECORD NAME SPECIFIED, RECORD TYPE NOT SPECIFIED
.*
      GTR(L,G,,,,NA)ABS/R
      GTR(L,G,,,,NA)CAP/R
      GTR(L,G,,,,NA)OPL/R
      GTR(L,G,,,,NA)OPLC/R
      GTR(L,G,,,,NA)OPLD/R
      GTR(L,G,,,,NA)OVL/R
      GTR(L,G,,,,NA)PP/R
      GTR(L,G,,,,NA)PPU/R
      GTR(L,G,,,,NA)PROC/R
      GTR(L,G,,,,NA)REL/R
      GTR(L,G,,,,NA)TEXT/R
      GTR(L,G,U,,,NA)ULIB/R
      IFE,FILE(G,.NOT.AS),NOTFOUND.
REVERT,ABORT. RECORD R NOT ON L, #UN=UN.
      ENDIF,NOTFOUND.
    .ENDIF,USERTYPE.
  .ENDIF,ALLTYPE.
.ENDIF,ALLREC.
.IFE,FILE(L,.NOT.AS),FILEPRM.
  UNLOAD,L.
.ENDIF,FILEPRM.
SKIP,NOERROR.
  EXIT.
  UNLOAD,YYYGETL,YYYGETD.
  .IFE,FILE(L,.NOT.AS),FILEPRM.
    UNLOAD,L.
  .ENDIF,FILEPRM.
REVERT,ABORT. T R NOT ON L, #UN=UN.
ENDIF,NOERROR.
.IFE,$R$.EQ.$*$,ALLREC.
  REVERT. ALL L T --> G
.ELSE,ALLREC.
  REVERT. L T R --> G
.ENDIF,ALLREC.
/EOR
*DECK DECK=RAM$GETNOS EXPAND=TRUE
.PROC,GETNOS*I,
VSN "- Volume Serial Number of DS tape"= (*N=,
                                     *S6(ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789)),
D "tape Density (HY,HD,PE,GE)"         = (*N=PE,GE,PE,HD,HY),
.
.HELP
 The GETNOS procedure GETs the NOS deadstart file as a local file
 named SYSTEM for the GENNOS procedure.

 Parameter   Default   Description
   Name       Value

  [vsn] COMMON,SYSTEM  volume serial number of NOS deadstart tape
  [d]          pe      tape density (pe,ge,hd,hy)

.HELP,VSN
 The VSN parameter specifies the volume serial number of the NOS
 deadstart tape. By default the command COMMON,SYSTEM is executed.
.HELP,D
 The D parameter specifies the NOS deadstart tape density.
 The default density is PE.
.ENDHELP
$UNLOAD,SYSTEM.
.IFE,($VSN$.EQ.$$),RQDSTAPE.  * ISSUE COMMON,SYSTEM. COMMAND
  $COMMON,SYSTEM.
  $NOTE(OUTPUT,NR)+ **  "COMMON,SYSTEM." COMMAND WAS SUCCESSFUL
.ELSE,RQDSTAPE. * GET DEADSTART FILE FROM TAPE
  $LABEL,SYSTEM,#D=D,F=I,LB=KU,PO=R,#VSN=VSN.
.ENDIF,RQDSTAPE.
$SETFS,SYSTEM/FS=NAD.
$REWIND,SYSTEM.
$SKIP,NOERROR.
  $EXIT.
  $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    $EXIT. GETNOS *TERMINATED*
  $ENDIF,TERMINATED.
  .IFE,OT.EQ.TXO,TERMINAL.
    .IFE,$VSN$.EQ.$$,NOTAPE.
      $NOTE,OUTPUT,NR.+ **  "COMMON,SYSTEM." COMMAND WAS UNSUCCESSFUL
    .ELSE,NOTAPE.
      $NOTE,OUTPUT,NR.+ **  TAPE REQUEST WAS UNSUCCESSFUL
    .ENDIF,NOTAPE.
    $NOTE,OUTPUT,NR.+ **  RERUNNING GETNOS IN HELP MODE.
    $REVERT,EX.GETNOS?.
  .ELSE,TERMINAL.
    $REVERT,ABORT. ERROR WHILE RUNNING GETNOS.
  .ENDIF,TERMINAL.
$ENDIF,NOERROR.
$REVERT.   END GETNOS.
/EOR
*DECK DECK=RAM$GETPROC EXPAND=TRUE
.PROC,GETPROC*I,
P "- Procedure name (or ALL or *)"     = (ALL=$*$,$*$,*F),
L "- Library file name"                = (*N=#FILE,*F),
UN "- User Name of library file"       = (*N=,*F),
G "- Group file receiving procedure(s)"= (*N=,*F),
.
.HELP
 The GETPROC procedure GETs PROCedures from a library file.

 Parameter   Default   Description
   Name       Value

   p                   procedure name to extract (or ALL or *)
  [l]                  library file containing the procedure(s)
  [un]                 user name in which library resides
  [g]                  local file to which procedure(s) are written

.HELP,P
 The P parameter names the procedure to extract from a library file.
.HELP,L
 The L parameter names the file containing a library of procedure(s).
 The default value is the file containing this procedure.
.HELP,UN
 The UN parameter specifies the User Name location of the file.
 The default value is the User Name in which this procedure executes.
 On NOS/BE, the UN parameter is the permanent file ID of the file.
.HELP,G
 The G parameter names a local file to which procedure(s) are written.
.ENDHELP
.IFE,$G$.EQ.$L$,ERROR.
  REVERT,ABORT. CANNOT GET G --> L
.ENDIF,ERROR.
.IFE,(($P$.EQ.$*$).AND.($G$.EQ.$$)),NAMEGROUP.
  REVERT,EX.GETLIB,P,L,UN,GROUP,T=PROC.
.ELSE,NAMEGROUP.
  .IFE,$G$.EQ.$$,NOGROUP.
    REVERT,EX.GETLIB,P,L,UN,P,T=PROC.
  .ELSE,NOGROUP.
    REVERT,EX.GETLIB,P,L,UN,G,T=PROC.
  .ENDIF,NOGROUP.
.ENDIF,NAMEGROUP.
/EOR
*DECK DECK=RAM$GETTEXT EXPAND=TRUE
.PROC,GETTEXT*I,
T "- Text record name (or ALL or *)"   = (ALL=*,*,*F),
L "- Library file name"                = (*N=#FILE,*F),
UN "- User Name of library file"       = (*N=,*F),
G "- Group file receiving TEXT records"= (*N=,*F),
.
.HELP
 The GETTEXT procedure GETs TEXT records from a library file.

 Parameter   Default   Description
   Name       Value

   t                   TEXT record name to extract (or ALL or *)
  [l]                  library file containing the TEXT record
  [un]                 user name in which library resides
  [g]                  local file to which TEXT records are written

.HELP,T
 The T parameter names the TEXT record to extract from a library file.
.HELP,L
 The L parameter names the file containing a library of TEXT records.
 The default value is the file containing this procedure.
.HELP,UN
 The UN parameter specifies the User Name location of the file.
 The default value is the User Name in which this procedure executes.
.HELP,G
 The G parameter names a local file to which TEXT records are written.
.ENDHELP
.IFE,$G$.EQ.$L$,ERROR.
  $REVERT,ABORT. CANNOT GET G --> L
.ENDIF,ERROR.
.IFE,(($T$.EQ.$*$).AND.($G$.EQ.$$)),NAMEGROUP.
  $REVERT,EX.GETLIB,T,L,UN,GROUP,#T=TEXT.
.ELSE,NAMEGROUP.
  .IFE,$G$.EQ.$$,NOGROUP.
    $REVERT,EX.GETLIB,T,L,UN,T,#T=TEXT.
  .ELSE,NOGROUP.
    $REVERT,EX.GETLIB,T,L,UN,G,#T=TEXT.
  .ENDIF,NOGROUP.
.ENDIF,NAMEGROUP.
/EOR
*DECK DECK=RAM$GET_CORRECTOR_ELEMENT EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$get_corrector_element;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc rac$status_id
*copyc rae$error_messages
*copyc rav$correction_package_header
*copyc rav$elements
*copyc ost$name
*copyc rat$correction_package
*copyc osp$set_status_abnormal
?? POP ??

*copyc rah$get_corrector_element

  PROCEDURE [XDCL] rap$get_corrector_element (element: ost$name;
    VAR k: rat$element_index;
    VAR status: ost$status);

    VAR
      temp: integer,
      found: boolean,
      hi: rat$element_index,
      low: rat$element_index,
      mid: rat$element_index;

    status.normal := TRUE;

    k := 0;
    found := FALSE;
    hi := rav$correction_package_header^.number_of_elements;
    low := 1;
    WHILE (low <= hi) AND NOT found DO
      temp := low + hi;
      mid := temp DIV 2;
      IF rav$elements^ [mid].name = element THEN
        found := TRUE;
      ELSEIF rav$elements^ [mid].name > element THEN
        hi := mid - 1;
      ELSE
        low := mid + 1;
      IFEND;
    WHILEND;
    IF found THEN
      k := mid;
    ELSE
      osp$set_status_abnormal (rac$status_id, rae$element_not_found, element, status);
      RETURN;
    IFEND;
  PROCEND rap$get_corrector_element;
MODEND ram$get_corrector_element;
*DECK DECK=RAM$GET_CYCLE_DATA EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$GET_CYCLE_DATA Interface.' ??
MODULE ram$get_cycle_data;

{ PURPOSE:
{   This module contains the interface that returns cycle data for
{   any file.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
?? POP ??
*copyc pfp$find_cycle_array
*copyc pfp$find_direct_info_record
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_item_info

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??


?? TITLE := '[XDCL] rap$get_cycle_data', EJECT ??

{ PURPOSE:
{   This interface gets the cycle data for any file.
{
{ DESIGN:
{
{ NOTES:
{   When the file path describes a catalog the condition
{   PFE$NAME_NOT_PERMANENT_FILE will be returned by PFP$GET_ITEM_INFO.
{

  PROCEDURE [XDCL] rap$get_cycle_data
    (    file_path: pft$path;
     VAR info_p {input} : pft$p_info;
     VAR cycles_p : pft$p_cycle_array;
     VAR status: ost$status);


    VAR
      directory_p: pft$p_directory_array,
      group: pft$group,
      info_record_p: pft$p_info_record;


    status.normal := TRUE;

    group.group_type := pfc$member;
    group.member_description.family := osc$null_name;
    group.member_description.account := osc$null_name;
    group.member_description.project := osc$null_name;
    group.member_description.user := osc$null_name;

    RESET info_p;

    pfp$get_item_info (file_path, group, $pft$catalog_info_selections [],
          $pft$file_info_selections [pfc$file_directory, pfc$file_description, pfc$file_cycles], info_p,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET info_p;

    pfp$find_next_info_record (info_p, info_record_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$find_directory_array (info_record_p, directory_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$find_direct_info_record (^info_record_p^.body, directory_p^ [1].info_offset, info_record_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$find_cycle_array (info_record_p, cycles_p, status);

  PROCEND rap$get_cycle_data;
MODEND ram$get_cycle_data;
*DECK DECK=RAM$GET_CYCLE_INFORMATION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: Module RAM$GET_CYCLE_INFORMATION.' ??
MODULE ram$get_cycle_information;

{ PURPOSE:
{   This module contains the procedure to get the attributes checksum.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$package_software_cc
*copyc ost$status
*copyc pft$checksum
*copyc rat$subproduct_info_types
?? POP ??
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc pfp$convert_fs_path_to_pf_path
*copyc pfp$convert_string_to_fs_path
*copyc pfp$get_item_info
*copyc pfp$find_cycle_array
*copyc pfp$find_cycle_array_extended
*copyc pfp$find_cycle_directory
*copyc pfp$find_cycle_label
*copyc pfp$find_directory_array
*copyc pfp$find_direct_info_record
*copyc pfp$find_next_info_record
*copyc rap$convert_path_to_pf_format

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$get_cycle_information', EJECT ??

{ PURPOSE:
{   This procedure gets the attributes checksum of a file.
{
{ DESIGN:
{   The PF procedures are used to find the attributes
{   checksum.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$get_cycle_information
    (    file: fst$file_reference;
     VAR attributes_checksum: integer;
     VAR modification_date_time: ost$date_time;
     VAR status: ost$status);

    VAR
      cycle_directory_p: pft$p_cycle_directory_array,
      cycle_label_seq_p: ^SEQ ( * ),
      cycle_label_checksum_p: ^pft$checksum,
      cycle_label_p: pft$p_info_record,
      cycles_p: pft$p_cycle_array,
      cycle_record_extended_p: pft$p_info_record,
      cycle_record_p: pft$p_info_record,
      directory_p: pft$p_directory_array,
      fs_path: string (fsc$max_path_size),
      group: pft$group,
      ignore_cycle_reference: fst$cycle_reference,
      ignore_cycle_selector: clt$cycle_selector,
      ignore_open_position: fst$open_position,
      ignore_status: ost$status,
      info_record_p: pft$p_info_record,
      local_status: ost$status,
      message_status: ost$status,
      number_of_elements: fst$number_of_path_elements,
      pf_path_p: ^pft$path,
      scratch_segment_pointer: amt$segment_pointer,
      scratch_seq_p: ^SEQ ( * );

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF scratch_segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (scratch_segment_pointer, ignore_status);
        scratch_segment_pointer.sequence_pointer := NIL;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    group.group_type := pfc$public;
    scratch_segment_pointer.kind := amc$sequence_pointer;
    scratch_segment_pointer.sequence_pointer := NIL;

  /main/
    BEGIN

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, scratch_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      scratch_seq_p := scratch_segment_pointer.sequence_pointer;

      pfp$convert_string_to_fs_path (file, fs_path, number_of_elements, ignore_cycle_reference,
            ignore_open_position, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      PUSH pf_path_p: [1 .. number_of_elements];
      pfp$convert_fs_path_to_pf_path (fs_path, pf_path_p, ignore_cycle_reference, ignore_cycle_selector,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      RESET scratch_seq_p;
      pfp$get_item_info (pf_path_p^, group, $pft$catalog_info_selections [],
            $pft$file_info_selections [pfc$cycle_label_descriptor, pfc$file_cycles], scratch_seq_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      RESET scratch_seq_p;
      pfp$find_next_info_record (scratch_seq_p, info_record_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pfp$find_directory_array (info_record_p, directory_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pfp$find_direct_info_record (^info_record_p^.body, directory_p^ [1].info_offset, cycle_record_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pfp$find_cycle_array_extended (cycle_record_p, cycle_record_extended_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pfp$find_cycle_directory (cycle_record_extended_p, cycle_directory_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pfp$find_direct_info_record (^cycle_record_extended_p^.body,
            cycle_directory_p^ [UPPERBOUND (cycle_directory_p^)].info_offset, cycle_label_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pfp$find_cycle_label (cycle_label_p, cycle_label_seq_p, local_status);
      IF local_status.normal THEN
        RESET cycle_label_seq_p;
        NEXT cycle_label_checksum_p IN cycle_label_seq_p;
        attributes_checksum := cycle_label_checksum_p^;
      ELSE
        osp$set_status_abnormal ('RA', rae$file_never_opened, '', message_status);
        osp$append_status_file (osc$status_parameter_delimiter, file, message_status);
        osp$generate_error_message (message_status, ignore_status);
      IFEND;

      pfp$find_cycle_array (cycle_record_p, cycles_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      modification_date_time := cycles_p^ [1].cycle_statistics.modification_date_time;

    END /main/;

    IF scratch_segment_pointer.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (scratch_segment_pointer, local_status);
      scratch_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$get_cycle_information;

MODEND ram$get_cycle_information;
*DECK DECK=RAM$GET_DECKS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE ram$get_decks;
?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc clt$path_name
*copyc clp$scan_command_line
?? POP ??

*copyc rah$get_decks

  PROCEDURE [XDCL] rap$get_decks (name: ost$name;
        old_path: clt$path_name;
        old_path_length: 1 .. clc$max_path_name_size;
        new_path: clt$path_name;
        new_path_length: 1 .. clc$max_path_name_size;
        old_deck: ost$name;
        new_deck: ost$name;
    VAR status: ost$status);

    VAR
      command: string (osc$max_string_size),
      size: integer;

    STRINGREP (command, size, ' scu_extd b=', old_path (1, old_path_length), ' d=', name, ' s=', old_deck);
    clp$scan_command_line (command (1, size), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (command, size, ' scu_extd b=', new_path (1, new_path_length), ' d=', name, ' s=', new_deck);
    clp$scan_command_line (command (1, size), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
  PROCEND rap$get_decks;
MODEND ram$get_decks;
*DECK DECK=RAM$GET_DECK_LIST EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE ram$get_deck_list;
?? PUSH (LISTEXT := ON) ??
*copyc rat$write_scl_commands
*copyc amp$open
*copyc amp$close
*copyc amp$put_next
*copyc amp$return
*copyc pmp$get_unique_name
*copyc clp$scan_command_line
?? POP ??

*copyc rah$get_deck_list

  PROCEDURE [XDCL] rap$get_deck_list (path_name: string (osc$max_string_size);
        path_name_size: 1 .. osc$max_string_size;
        file_name: ost$name;
    VAR status: ost$status);

    CONST
      number_of_commands = 7;

    VAR
      ba: amt$file_byte_address,
      command: array [1 .. number_of_commands] of rat$write_scl_commands,
      command_fid: amt$file_identifier,
      command_file: ost$name,
      i: 1 .. number_of_commands + 1,
      ignore_status: ost$status,
      size: integer,
      text: string (osc$max_string_size);

    pmp$get_unique_name (command_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (command_file, amc$record, NIL, command_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (command [1].command, command [1].size, ' scu');
    STRINGREP (command [2].command, command [2].size, ' use_library b= ', path_name (1, path_name_size));
    STRINGREP (command [3].command, command [3].size, '   deck_list = $deck_list');
    STRINGREP (command [4].command, command [4].size, '   FOR i = 1 to $variable(deck_list,upper_bound) DO');
    STRINGREP (command [5].command, command [5].size, '     put_line l=deck_list(i) o=', file_name,
      '.$eoi');
    STRINGREP (command [6].command, command [6].size, '   FOREND');
    STRINGREP (command [7].command, command [7].size, ' quit wl=false');

    FOR i := 1 TO number_of_commands DO
      amp$put_next (command_fid, ^command [i].command, command [i].size, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    amp$close (command_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (text, size, ' include_file f=', command_file);
    clp$scan_command_line (text (1, size), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$return (command_file, ignore_status);

  PROCEND rap$get_deck_list;
MODEND ram$get_deck_list;
*DECK DECK=RAM$GET_ELEMENTS_BY_CLASS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$get_elements_by_class;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc rat$table_version
*copyc rat$header_record
*copyc rat$installation_table
*copyc rat$correction_package
*copyc rav$installation_table
*copyc amp$open
*copyc amp$get_segment_pointer
*copyc amp$close
?? POP ??

*copyc rah$get_elements_by_class

  PROCEDURE [XDCL] rap$get_elements_by_class (class: rat$file_class;
    VAR element_list: ^array [1 .. * ] OF ost$name;
    VAR status: ost$status);

    VAR
      access_sel: amt$file_access_selections,
      i: rat$element_index,
      install_header: ^rat$header_record,
      install_table: amt$segment_pointer,
      it_fid: amt$file_identifier,
      j: rat$element_index,
      table: ^rat$installation_table,
      temp_elements: ^array [1 .. * ] of ost$name,
      version: ^rat$table_version;

    status.normal := TRUE;

    PUSH access_sel: [1 .. 1];
    access_sel^ [1].key := amc$access_mode;
    access_sel^ [1].access_mode := $pft$usage_selections [pfc$read];
    amp$open (rav$installation_table, amc$segment, access_sel, it_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (it_fid, amc$sequence_pointer, install_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET install_table.sequence_pointer;
    NEXT version IN install_table.sequence_pointer;
    NEXT install_header IN install_table.sequence_pointer;
    NEXT table: [1 .. install_header^.number_of_files] IN install_table.sequence_pointer;
    j := 1;
    ALLOCATE temp_elements: [1 .. install_header^.number_of_files];
    FOR i := 1 TO install_header^.number_of_files DO
      IF table^ [i].class = class THEN
        temp_elements^ [j] := table^ [i].mnemonic_name;
        j := j + 1;
      IFEND;
    FOREND;

    IF (j - 1) <> 0 THEN
      ALLOCATE element_list: [1 .. j - 1];
      FOR i := 1 TO j - 1 DO
        element_list^ [i] := temp_elements^ [i];
      FOREND;
    ELSE
      element_list := NIL;
    IFEND;
    FREE temp_elements;
    amp$close (it_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
  PROCEND rap$get_elements_by_class;
MODEND ram$get_elements_by_class;
*DECK DECK=RAM$GET_ELEMENTS_BY_PRODUCT EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$get_elements_by_product;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc rat$table_version
*copyc rat$header_record
*copyc rat$installation_table
*copyc rat$correction_package
*copyc rav$installation_table
*copyc amp$open
*copyc amp$get_segment_pointer
*copyc amp$close
?? POP ??

*copyc rah$get_elements_by_product

  PROCEDURE [XDCL] rap$get_elements_by_product (product: ost$name;
    VAR element_list: ^array [1 .. * ] OF ost$name;
    VAR status: ost$status);

    VAR
      access_sel: amt$file_access_selections,
      i: rat$element_index,
      install_header: ^rat$header_record,
      install_table: amt$segment_pointer,
      it_fid: amt$file_identifier,
      j: rat$element_index,
      table: ^rat$installation_table,
      temp_elements: ^array [1 .. * ] of ost$name,
      version: ^rat$table_version;

    PUSH access_sel: [1 .. 2];
    access_sel^ [1].key := amc$access_mode;
    access_sel^ [1].access_mode := $pft$usage_selections [pfc$read];
    access_sel^ [2].key := amc$open_position;
    access_sel^ [2].open_position := amc$open_at_boi;
    amp$open (rav$installation_table, amc$segment, access_sel, it_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (it_fid, amc$sequence_pointer, install_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET install_table.sequence_pointer;
    NEXT version IN install_table.sequence_pointer;
    NEXT install_header IN install_table.sequence_pointer;
    NEXT table: [1 .. install_header^.number_of_files] IN install_table.sequence_pointer;
    j := 1;
    ALLOCATE temp_elements: [1 .. install_header^.number_of_files];
    FOR i := 1 TO install_header^.number_of_files DO
      IF table^ [i].product = product THEN
        temp_elements^ [j] := table^ [i].mnemonic_name;
        j := j + 1;
      IFEND;
    FOREND;

    IF (j - 1) <> 0 THEN
      ALLOCATE element_list: [1 .. j - 1];
      FOR i := 1 TO j - 1 DO
        element_list^ [i] := temp_elements^ [i];
      FOREND;
    ELSE
      element_list := NIL;
    IFEND;
    FREE temp_elements;
    amp$close (it_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
  PROCEND rap$get_elements_by_product;
MODEND ram$get_elements_by_product;
*DECK DECK=RAM$GET_FILE_INFORMATION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: Module RAM$GET_FILE_INFORMATION.' ??
MODULE ram$get_file_information;

{ PURPOSE:
{   This module validates a file and determines
{   its size and checksum.
{
{ DESIGN:
{   Each file is checked for correct permits, cycles, and ring attributes
{   Then the files size and checksum are determined.
{
{ NOTES:
{
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$package_software_cc
*copyc pmt$condition
*copyc ost$status
*copyc rat$subproduct_info_pointers
*copyc rat$subproduct_info_p
*copyc rat$subproduct_info_types
*copyc rat$validation_selections
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$get_file_attributes
*copyc fsp$close_file
*copyc ocp$checksum
*copyc osp$append_status_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osp$generate_error_message
*copyc pfp$find_direct_info_record
*copyc pfp$find_file_description
*copyc rap$open_file
*copyc rap$test_cycles
*copyc rap$test_permits

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := 'get_file_information', EJECT ??

{ PURPOSE:
{   This procedure validates a file and determines
{   its size and checksum.
{
{ DESIGN:
{   Each file is checked for correct permits, cycles, and ring attributes
{   Then the files size and checksum are determined.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$get_file_information
    (    file_ref_p: ^fst$file_reference;
         file_path: pft$path;
         pf_info_record_p: pft$p_info_record;
         info_offset: pft$info_offset;
         validation_selections: rat$validation_selections;
         checksum_contents: boolean;
     VAR validation_errors: {output} boolean;
     VAR element: {output} rat$element;
     VAR status: ost$status);


    VAR
      attributes_checksum: integer,
      attribute_override: array [1 .. 1] of fst$file_cycle_attribute,
      checksum_info_p: pft$p_info,
      cycles_p: pft$p_cycle_array,
      file_attributes: array [1 .. 4] of amt$get_item,
      file_id: amt$file_identifier,
      file_opened: boolean,
      file_seg_p: amt$segment_pointer,
      ignore_contains_data: boolean,
      ignore_existing_file: boolean,
      ignore_local_file: boolean,
      ignore_status: ost$status,
      info_record_p: pft$p_info_record,
      message_status: ost$status;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the file has been opened, it will be closed before the
{   the procedure returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF file_opened THEN
        fsp$close_file (file_id, ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    file_opened := FALSE;

    element.name := file_path [UPPERBOUND (file_path)];
    element.permit.defined := FALSE;
    element.permit.permit_selections := $pft$permit_selections [];
    element.permit.share_requirements := $pft$share_requirements [];
    element.permit.application_info := '';
    element.active_element := TRUE;
    element.next_element_across_p := NIL;
    element.element_type := rac$file;
    element.attributes_checksum := 0;
    element.contents_checksum := 0;
    element.correction_base_contents_cksum := 0;
    element.pre_genc_contents_checksum := 0;
    element.correction_directives := $rat$correction_directives[];
    element.correction_format := rac$replacement;
    element.file_contents_and_structure := rac$replacement;
    element.library_merge.path_container_index := 0;
    element.library_merge.path_length := 0;
    element.ring_attributes.r1 := osc$invalid_ring;
    element.ring_attributes.r2 := osc$invalid_ring;
    element.ring_attributes.r3 := osc$invalid_ring;
    element.storage_class := rmc$msc_product_files;
    element.size := 0;

    rap$test_permits (validation_selections, file_ref_p, pf_info_record_p, info_offset, validation_errors,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$test_cycles (validation_selections, file_ref_p, pf_info_record_p, info_offset, cycles_p,
          validation_errors, attributes_checksum, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    element.modification_date_time := cycles_p^ [1].cycle_statistics.modification_date_time;
    element.attributes_checksum := attributes_checksum;

    test_logging (file_ref_p, pf_info_record_p, info_offset, validation_errors, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_attributes [1].key := amc$file_length;
    file_attributes [2].key := amc$ring_attributes;
    file_attributes [3].key := amc$file_contents;
    file_attributes [4].key := amc$file_structure;

    amp$get_file_attributes (file_ref_p^, file_attributes, ignore_local_file, ignore_existing_file,
          ignore_contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    element.size := file_attributes [1].file_length;

    IF rac$no_rings_below_11 IN validation_selections THEN
      IF (file_attributes [2].ring_attributes.r1 < 11) OR (file_attributes [2].ring_attributes.r2 < 11) OR
            (file_attributes [2].ring_attributes.r3 < 11) THEN
        osp$set_status_abnormal ('RA', rae$ring_value_too_low, '(11, 11, 11)', message_status);
        osp$append_status_file (osc$status_parameter_delimiter, file_ref_p^, message_status);
        osp$generate_error_message (message_status, ignore_status);
        validation_errors := TRUE;
      IFEND;
    IFEND;

    IF file_attributes [4].file_structure = amc$library THEN
      IF file_attributes [3].file_contents = amc$object THEN
        element.file_contents_and_structure := rac$object_library;
        element.correction_format := rac$object_library;
      ELSEIF file_attributes [3].file_contents = amc$legible THEN
        element.file_contents_and_structure := rac$source_library;
        element.correction_format := rac$source_library;
      IFEND;
    IFEND;

    IF (checksum_contents = TRUE) AND (element.size <> 0) THEN

      attribute_override [1].selector := fsc$file_organization;
      attribute_override [1].file_organization := amc$sequential;

      rap$open_file (file_ref_p, amc$segment, fsc$read, FALSE, ^attribute_override, file_id, file_opened,
            status);
      IF NOT status.normal THEN
        validation_errors := TRUE;
        RETURN;
      IFEND;

      osp$establish_block_exit_hndlr (^abort_handler);

    /main/
      BEGIN

        amp$get_segment_pointer (file_id, amc$sequence_pointer, file_seg_p, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        RESET file_seg_p.sequence_pointer;
        checksum_info_p := file_seg_p.sequence_pointer;
        element.contents_checksum := ocp$checksum (checksum_info_p);

      END /main/;

      fsp$close_file (file_id, ignore_status);
      osp$disestablish_cond_handler;

    IFEND;

  PROCEND rap$get_file_information;

?? TITLE := 'test_logging', EJECT ??

{ PURPOSE:
{   This procedure validates that a file does not have
{   logging turned on.
{
{ DESIGN:
{   The PF utilities are used to see if logging has been
{   turned on for cycle 1 of a specific file.
{
{ NOTES:
{
{
  PROCEDURE test_logging
    (    element_ref_p: ^fst$file_reference;
         info_record_p: pft$p_info_record;
         info_offset: pft$info_offset;
     VAR validation_errors: boolean;
     VAR status: ost$status);


    VAR
      file_description_p: pft$p_file_description,
      file_info_record_p: pft$p_info_record,
      ignore_status: ost$status,
      message_status: ost$status;

    pfp$find_direct_info_record (^info_record_p^.body, info_offset, file_info_record_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$find_file_description (file_info_record_p, file_description_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF file_description_p^.logging_selection = pfc$log THEN
     osp$set_status_abnormal ('RA', rae$logging_not_allowed, '', message_status);
     osp$append_status_file (osc$status_parameter_delimiter, element_ref_p^, message_status);
     osp$generate_error_message (message_status, ignore_status);
     validation_errors := TRUE;
   IFEND;

  PROCEND test_logging;

MODEND ram$get_file_information;
*DECK DECK=RAM$GET_FILE_NAMES EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$get_file_names;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc rat$file_values
*copyc rat$open_file_list
*copyc rae$error_messages
*copyc osp$set_status_abnormal
*copyc pfp$attach
?? POP ??

*copyc rah$get_file_names

  PROCEDURE [XDCL] rap$get_file_names (element: ost$name;
        old_file: rat$file_values;
        new_file: rat$file_values;
    VAR status: ost$status);

    VAR
      cycle_sel: pft$cycle_selector,
      found: boolean,
      j: integer,
      password: pft$password,
      rav$open_file_list: [STATIC, XREF] rat$open_file_list,
      share: pft$share_selections,
      usage: pft$usage_selections;


    status.normal := TRUE;

    cycle_sel.cycle_option := pfc$highest_cycle;
    password := osc$null_name;
    usage := $pft$usage_selections [pfc$read];
    share := $pft$share_selections [pfc$read, pfc$execute];

    pfp$attach (old_file.lfn, old_file.path^, cycle_sel, password, usage, share, pfc$no_wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    found := FALSE;
    j := 1;
    WHILE (j <= UPPERBOUND (rav$open_file_list)) AND NOT found DO
      IF rav$open_file_list [j].name = old_file.lfn THEN
        rav$open_file_list [j].attached := TRUE;
        found := TRUE;
      IFEND;
      j := j + 1;
    WHILEND;

    IF NOT found THEN
      j := 1;
      WHILE (j <= UPPERBOUND (rav$open_file_list)) AND NOT found DO
        IF rav$open_file_list [j].name = osc$null_name THEN
          rav$open_file_list [j].name := old_file.lfn;
          rav$open_file_list [j].attached := TRUE;
          found := TRUE;
        IFEND;
        j := j + 1;
      WHILEND;
    IFEND;

    IF NOT found THEN
      osp$set_status_abnormal ('RA', rae$open_file_list_full, '', status);
      RETURN;
    IFEND;


    pfp$attach (new_file.lfn, new_file.path^, cycle_sel, password, usage, share, pfc$no_wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    found := FALSE;
    j := 1;
    WHILE (j <= UPPERBOUND (rav$open_file_list)) AND NOT found DO
      IF rav$open_file_list [j].name = new_file.lfn THEN
        rav$open_file_list [j].attached := TRUE;
        found := TRUE;
      IFEND;
      j := j + 1;
    WHILEND;

    IF NOT found THEN
      j := 1;
      WHILE (j <= UPPERBOUND (rav$open_file_list)) AND NOT found DO
        IF rav$open_file_list [j].name = osc$null_name THEN
          rav$open_file_list [j].name := new_file.lfn;
          rav$open_file_list [j].attached := TRUE;
          found := TRUE;
        IFEND;
        j := j + 1;
      WHILEND;
    IFEND;

    IF NOT found THEN
      osp$set_status_abnormal ('RA', rae$open_file_list_full, '', status);
      RETURN;
    IFEND;

  PROCEND rap$get_file_names;
MODEND ram$get_file_names;
*DECK DECK=RAM$GET_MULTIREC_FILE EXPAND=TRUE
PROCEDURE (osm$getmrf) get_multi_record_file, getmrf (
  nos_ve_file, nvf: file = $required
  nos_file, nf: name 7 = $required
  status)

  "$FORMAT=OFF
  VAR
    lsts: status
  VAREND
  "$FORMAT=ON"
  detach_file $local.nos_tape_ic_file status=lsts
  detach_file $local.nos_xfer status=lsts

  IF $job(c170_os_type) = 'NOS' THEN
    "$FORMAT=OFF
    VAR
      sv: array 1 .. 13 of string
    VAREND
    "$FORMAT=ON"
    sv(1) = 'jobc.'
    sv(2) = 'common(system)'
    sv(3) = 'gtr(system,nvelib,u)ulib/nvelib'
    sv(4) = 'library(nvelib/a)'
    sv(5) = 'settl,*.'
    sv(6) = 'setasl,*.'
    sv(7) = 'setjsl,*.'
    sv(8) = 'return,tape.'
    sv(9) = 'getfile(tape,' // $string(nos_file) // ',,read,yes)'
    sv(10) = 'xpfua.'
    sv(11) = 'exit.'
    sv(12) = 'dayfile,day.'
    sv(13) = 'replace,day.'

  ELSE
    "$FORMAT=OFF
    VAR
      sv: array 1 .. 8 of string
    VAREND
    "$FORMAT=ON"
    catalog_id = $nosbe_catalog_id
    sv(1) = 'JOBC,T0.'
    sv(2) = 'LIBRARY(NVELIB)'
    sv(3) = 'GETFILE(TAPE,' // $string(nos_file) // ',' // catalog_id // ',READ,YES)'
    sv(4) = 'XPFUA.'
    sv(5) = 'EXIT.'
    sv(6) = 'REQUEST(DAY,PF)'
    sv(7) = 'DAYFILE,DAY.'
    sv(8) = 'CATALOG(DAY,ID=' // catalog_id // ')'
  IFEND

  set_file_attributes $local.nos_tape_ic_file ui='sv'
  request_link $local.nos_tape_ic_file
  set_file_attributes $local.nos_xfer fap=rap$nos_file_read
  execute_task sp=rap$getmrf l=$system.osf$system_library p=$string(nos_ve_file) lmo=none
  detach_file ($local.nos_tape_ic_file, $local.nos_xfer) status=lsts

PROCEND get_multi_record_file
*DECK DECK=RAM$GET_OBJECT_FILE EXPAND=TRUE
PROC get_object_file, getof (
  to, t: file = $required
  from, f: name
  user, u: name
  status)

  create_variable from_file kind=string

  set_file_attributes $value(to) file_contents=object file_structure=data record_type=undefined

  IF $specified(from) THEN
    from_file = $string($value(from))
  ELSE
    from_file = $path($value(to) last)
  IFEND

  IF $specified(user) THEN
    get_file to=$value(to) from=$name(from_file) data_conversion=b56 user=$value(user)
  ELSE
    get_file to=$value(to) from=$name(from_file) data_conversion=b56
  IFEND

PROCEND get_object_file
*DECK DECK=RAM$GET_OBJECT_LIBRARY EXPAND=TRUE
PROC get_object_library, getol (
  to, t: file = $required
  from, f: name
  user, u: name
  status)

  create_variable from_file kind=string

  set_file_attributes $value(to) file_contents=object file_structure=library record_type=undefined

  IF $specified(from) THEN
    from_file = $string($value(from))
  ELSE
    from_file = $path($value(to) last)
  IFEND

  IF $specified(user) THEN
    get_file to=$value(to) from=$name(from_file) data_conversion=b56 user=$value(user)
  ELSE
    get_file to=$value(to) from=$name(from_file) data_conversion=b56
  IFEND

PROCEND get_object_library
*DECK DECK=RAM$GET_PHYSICAL_INFORMATION EXPAND=TRUE
PROCEDURE  get_physical_information (
  physical_array  : (var) array of string = $required
  number_found    : (var) integer = $required
  status          : (var) status = $optional
  )

  VAR
    channel_column              : integer;
    channel_column_offset       : integer;
    channel_connections_length  : integer = 20;
    channel_found               : boolean = false;
    channel_name                : string;
    channel_name_column         : integer;
    count                       : integer;
    device_class                : string;
    element_column              : integer;
    element_id                  : string;
    element_name                : string;
    element_number              : integer = 0;
    element_off_set             : integer = 9;
    ignore_status               : status;
    lcu_line                    : string;
    lcu_output_file             : string = '$local.'//$unique;
    local_status                : status;
    serial_number               : string;
    serial_number_blanks        : string = '      ';
    type_of_device              : string;
  VAREND

  set_file_attributes file = lcu_output_file page_format = continuous

  execute_task sp=logical_configuration_utility

    display_mainframe_configuration e=$channel_adapter do=pc o=$fname(lcu_output_file) status=ignore_status
    display_mainframe_configuration e=$communications_element do=pc o=$fname(lcu_output_file//'.$eoi') status=ignore_status
    rewind_file file = $fname(lcu_output_file)

    REPEAT

      accept_line variable = lcu_line input = $fname(lcu_output_file//'.$asis') line_count=count
      element_column = $scan_string('ELEMENT:', lcu_line)

      IF (element_column > 0) THEN
        element_name_column = element_column + element_off_set
        element_name = $substring(lcu_line, element_name_column, 31)
        device_class = $string($element($name(element_name),DEVICE_CLASS))

        IF device_class ='NETWORK_DEVICE' THEN
           element_id = $string($element($name(element_name),element_identification))

           IF $substring(element_id,2,6) = '$2620_' THEN
             type_of_device = 'MTI  '
           ELSEIF $substring(element_id,2,6) = '$2621_' THEN
             type_of_device = 'MDI  '
           ELSEIF $substring(element_id,2,7) = '$2629_2' THEN
             type_of_device = 'ICA2 '
           ELSEIF $substring(element_id,2,6) = '$4000_' THEN
             type_of_device = '4000 '
           ELSE
             CYCLE
           IFEND

           number_found = number_found + 1
           EXIT_PROC WITH $status(false, 'RA', 0, 'too many elements') WHEN number_found > $upper_bound(physical_array)

           serial_number = $string($element($name(element_name),serial_number))
           serial_number_length = $strlen(serial_number)
           serial_number_length = 6 - serial_number_length
           serial_number = $substr(serial_number_blanks, 1, serial_number_length) // serial_number

           channel_found = false

           REPEAT

             accept_line variable = lcu_line input = $fname(lcu_output_file//'.$asis') line_count=count
             channel_column = $scan_string('CHANNEL CONNECTIONS:', lcu_line)

             IF (channel_column > 0) THEN
               channel_column_offset = channel_column + channel_connections_length
               channel_name_column = $scan_string('CH', $substr(lcu_line, channel_column_offset, ..
                   ($strlen(lcu_line)-channel_column_offset))) + channel_column_offset - 1
               IF channel_name_column = 0 THEN
                 put_line ' Unable to find Channel number.'
                 QUIT
                 EXIT_PROC with $status(false, 'RA', 0, ' Unable to find channel number.')
               IFEND
               channel_name = $substr(lcu_line, channel_name_column, 5)
               channel_found = true
             IFEND

           UNTIL channel_found = true


           physical_array(number_found) = ' ' // $strrep(number_found) // '. ' // type_of_device // ' ' // ..
                element_name // '  ' // channel_name // '  ' // serial_number
         IFEND

      IFEND

    UNTIL count = 0

  QUIT

  delete_file file=$fname(lcu_output_file) status=ignore_status

PROCEND get_physical_information
*DECK DECK=RAM$GET_PREVIOUS_STATUS EXPAND=TRUE
PROC get_previous_status, getps (
  to: var of status = osv$status
  status: status = $previous_status)

  $value(to) = $value(status)

PROCEND get_previous_status
*DECK DECK=RAM$GET_PROCEDURE EXPAND=TRUE
PROCEDURE (ram$getp) get_procedure, get_procedures, getp (
  procedure, procedures, p: list of any of
      integer radix 16
      name
      string
    anyend = all
  from, f: file = $working_catalog.command_library
  to: file = :$local.procedures
  status)

" PURPOSE:
"   Extract the specified modules from a library or object file.
" DESIGN:
"   Scan every module name on the library for the specified value. Merge the selected modules onto the
"   output file, and update the command list when appropriate.
" NOTES:
"   $WORKING_CATALOG.COMMAND_LIBRARY is overwritten when the catalog is :$LOCAL, otherwise cycle $NEXT
"   is created. An integer procedure value is hexadecimal, convenient when processing CDCNET configuration
"   procedures. A chronological library order is maintained for audit purposes. A leading or trailing blank
"   constrains the substring match to the beginning or end of a module name.

  VAR
    command_list_altered : status
    format : name = scl_proc
    get_status : status
    library_list : file = $unique(:$local)
    modules_on_file : list 0..$max_list of string = ()
    modules_to_get : list 0..$max_list of string = ()
    next_cycle : file = to
    specified_name : string 1..31
  VAREND

  IF $file(to, permanent) THEN " create absolute path to cycle $next
    next_cycle=to//$file(to//$next, cycle_number)
  IFEND

  IF ($file(to, fs)= 'LIBRARY') AND ($file(to, fc)= 'OBJECT') THEN
    format=library
  IFEND

  CREATE_OBJECT_LIBRARY
    add_modules library=to status=get_status
    set_file_attributes file=library_list page_format=continuous file_contents=legible
    display_object_library library=from display_option=date_time output=library_list ..
          alphabetical_order=true status=get_status
    IF get_status.normal THEN
      PUSH file_connections " Suppress error messages from attempted update operations.
      delete_file_connection standard_file=$errors file=output
      delete_file_connection standard_file=$errors file=$job_log
      get_line variable=modules_on_file input=library_list
      delete_file file=library_list
      FOR EACH procedure_specified IN procedures DO " select a list of modules to get
        IF $generic_type(procedure_specified)= integer THEN " a CDCNET configuration procedure reference
          specified_name=$integer_string(procedure_specified, 16)
        ELSE " a substring of the procedure name was specified
          specified_name=$string(procedure_specified)
        IFEND
        IF (specified_name = 'ALL') AND (format = scl_proc) THEN " select all SCL procedures
          modules_to_get=$union(modules_to_get, $select(modules_on_file, $scan_string('procedure', x)>0))
        ELSEIF specified_name = 'ALL' THEN " select all modules regardless of type
          modules_to_get=$union(modules_to_get, $select(modules_on_file, $size(x)>0))
        ELSEIF format = scl_proc THEN " select specified SCL procedures
          modules_to_get=$union(modules_to_get, $select(modules_on_file, ($scan_string('procedure', x)>0 AND..
 $scan_string(specified_name, ' '//$substring(x, 1, 32))>0)))
        ELSE " select specified modules regardless of type
          modules_to_get=$union(modules_to_get, ..
                $select(modules_on_file, $scan_string(specified_name, ' '//$substring(x, 1, 32))>0))
        IFEND
      FOREND
      IF $nil(modules_to_get) THEN " assign appropriate add_module status
        add_modules library=from modules=$apply(procedures, $range_of($program_name(x))) status=get_status
        IF get_status.normal THEN
          generate_library library=next_cycle format=format status=get_status
        IFEND
      ELSE " generate the resulting library or object file
        put_line line=' Combining procedures to     '//next_cycle output=$response
        FOR EACH selected_module IN modules_to_get DO
          add_module library=from module=selected_module(1, 31) status=get_status
          IF get_status.normal THEN " account for the module added
            put_line line=' ADDED    '//$trim(selected_module(1, 31)) output=$response
          ELSE
            delete_module module=selected_module(1, 31) status=get_status
            add_module library=from module=selected_module(1, 31) status=get_status
            IF get_status.normal THEN " account for the modules replaced
              put_line line=' REPLACED '//$trim(selected_module(1, 31)) output=$response
            IFEND
          IFEND
        FOREND
        delete_command_list_entry entry=to status=command_list_altered
        IF command_list_altered.normal THEN
          put_line line=' Deleted command list entry  '//to output=$response
        IFEND
        generate_library library=next_cycle format=format status=get_status
        IF get_status.normal THEN " summarize action performed
          put_line line=' Combined '//$justify($integer_string($size(modules_to_get)), 4, right)//..
' procedures to '//$string(next_cycle)//' from '//from output=$response
        IFEND
        IF command_list_altered.normal THEN " update the command list
          IF get_status.normal THEN " add the new command library
            create_command_list_entry entry=next_cycle
            put_line line=' Created command list entry  '//next_cycle output=$response
          ELSE " restore the old command library
            create_command_list_entry entry=to
            put_line line=' Restored command list entry '//to output=$response
          IFEND
        IFEND
      IFEND
    IFEND
  QUIT

  EXIT_PROC WITH get_status

PROCEND get_procedure
*DECK DECK=RAM$GET_SIF_POINTERS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: Module RAM$GET_SIF_POINTERS.' ??
MODULE ram$get_sif_pointers;

{ PURPOSE:
{   This module contains a procedures to get the SIF pointers.
{
{ DESIGN:
{   A SIF is passed into this procedure and a record containing the pointers
{   to the sequence descriptor, info header, attributes, and the element list
{   is passed back to the calling routine.
{
{ NOTES:
{
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$segment_pointer
*copyc mmt$attribute_keyword
*copyc ost$status
*copyc rac$subproduct_info_level
*copyc rae$package_software_cc
*copyc rat$subproduct_info_pointers
*copyc rat$sequence_descriptor_types
*copyc rat$subproduct_info_p
*copyc rat$subproduct_info_types
?? POP ??
*copyc amp$get_segment_pointer
*copyc osp$append_status_file
*copyc osp$set_status_abnormal

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := 'rap$get_sif_pointers [XDCL]', EJECT ??

{ PURPOSE:
{   This procedure gets the SIF sequence pointers.
{
{ DESIGN:
{   A SIF is passed into this procedure and a record containing the pointers
{   to the sequence descriptor, info header, attributes, and the element list
{   is passed back to the calling routine.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$get_sif_pointers
    (    amt_seg_p: amt$segment_pointer;
         mmt_seg_p: mmt$segment_pointer;
         path_ref_p: ^fst$file_reference;
     VAR subproduct_info_pointers: {output} rat$subproduct_info_pointers;
     VAR status: ost$status);


    IF amt_seg_p.sequence_pointer <> NIL THEN
      subproduct_info_pointers.subproduct_info_seq_p := amt_seg_p.sequence_pointer;
    ELSEIF mmt_seg_p.seq_pointer <> NIL THEN
      subproduct_info_pointers.subproduct_info_seq_p := mmt_seg_p.seq_pointer;
    IFEND;

    RESET subproduct_info_pointers.subproduct_info_seq_p;
    NEXT subproduct_info_pointers.sequence_descriptor_p IN subproduct_info_pointers.subproduct_info_seq_p;

    IF (subproduct_info_pointers.sequence_descriptor_p = NIL) OR
          (subproduct_info_pointers.sequence_descriptor_p^.sequence_type <> rac$subproduct_info_sequence) THEN
      osp$set_status_abnormal ('RA', rae$file_is_not_a_sif, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, path_ref_p^, status);
      RETURN;
    IFEND;

    IF subproduct_info_pointers.sequence_descriptor_p^.sequence_level <> rac$subproduct_info_level THEN
      osp$set_status_abnormal ('RA', rae$sif_version_changed, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, path_ref_p^, status);
      RETURN;
    IFEND;

    NEXT subproduct_info_pointers.info_header_p IN subproduct_info_pointers.subproduct_info_seq_p;
    IF subproduct_info_pointers.info_header_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    subproduct_info_pointers.element_list_p := #PTR (subproduct_info_pointers.info_header_p^.element_list_p,
          subproduct_info_pointers.subproduct_info_seq_p^);

    subproduct_info_pointers.attributes_p := #PTR (subproduct_info_pointers.info_header_p^.attributes_p,
          subproduct_info_pointers.subproduct_info_seq_p^);

    subproduct_info_pointers.path_container_p := #PTR (subproduct_info_pointers.info_header_p^.
          path_container_p, subproduct_info_pointers.subproduct_info_seq_p^);

    subproduct_info_pointers.psrs_answered_p := #PTR (subproduct_info_pointers.info_header_p^.
          psrs_answered_p, subproduct_info_pointers.subproduct_info_seq_p^);

  PROCEND rap$get_sif_pointers;

MODEND ram$get_sif_pointers;
*DECK DECK=RAM$GET_SOURCE_LIBRARY EXPAND=TRUE
PROC get_source_library, getsl (
  to, t: file = $required
  from, f: name
  user, u: name
  status)

  create_variable from_file kind=string

  set_file_attributes $value(to) fc=legible fp=scu fs=library rt=undefined

  IF $specified(from) THEN
    from_file = $string($value(from))
  ELSE
    from_file = $path($value(to) last)
  IFEND

  IF $specified(user) THEN
    get_file to=$value(to) from=$name(from_file) data_conversion=b56 user=$value(user)
  ELSE
    get_file to=$value(to) from=$name(from_file) data_conversion=b56
  IFEND

PROCEND get_source_library
*DECK DECK=RAM$GO EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$go;

*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc clp$end_scan_command_file
*copyc cld$parameter_list
*copyc rav$intervene_in_deadstart_name

?? POP ??

*copyc rah$go

  PROCEDURE [XDCL, #GATE] rap$go (parameter_list: clt$parameter_list;
    VAR status: ost$status);

    clp$end_scan_command_file (rav$intervene_in_deadstart_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$go;
MODEND ram$go
*DECK DECK=RAM$INFORM_USERS EXPAND=TRUE
PROCEDURE (ram$infu) inform_users, infu (
  message, m: string 0..132 = $optional
  service_name, sn: (BY_NAME, ADVANCED) list 1..15 of name = $optional
  system, systems, s: (BY_NAME, ADVANCED) list of name = $optional
  title_pattern, tp: (BY_NAME, ADVANCED) string = '*T*'
  status)

" PURPOSE:
"   Send messages to NAM/VE terminal users using the CDCNET write_terminal_message command.
" DESIGN:
"   Accept an infinite number of message lines from any properly validated network_operator, and dispatch
"   lines in blocks of 0..132 characters by 1..15 lines, or blocks smaller than maximum CDCNET command length.
" NOTES:
"   Restrict distribution to those terminals with an active connection to the service names provided by this
"   mainframe, and those Device Interface (DI) boxes having the title_pattern as part of their system name.
"   Specify service_name=all to send messages to all terminals with an active CDCNET connection.

  VAR
    build_and_send_message: file = $unique(:$local)
    cdcnet_maximum: integer = 256
    cdcnet_command: string 1..cdcnet_maximum = 'writm'
    ignore: status
    line: string = 'QUIT'
    lines_per_command: integer = 15
    message_acknowledged: integer = 33296
    message_id: string = $char(bel)//'OPERATOR: '//$job(user)//', '//$processor(model)//'/'//$processor(serial_number, 0)
    message_text: string
    services_list: file = $unique(:$local)
    service_names: list 0..$max_list of string
  VAREND

" Delete the file created by this procedure whenever the procedure exits.
  WHEN exit DO
    delete_file file=build_and_send_message
  WHENEND

" Determine which service name connections must be active for the terminal message to be delivered.
  IF $specified(service_name) THEN
    service_names=$apply(service_name, $string(x))
  ELSE
    set_file_attributes file=services_list page_format=continuous file_contents=legible
    MANAGE_NETWORK_APPLICATIONS " Display service names registered by this mainframe.
      display_server_attributes server=osa$timesharing display_option=titles output=services_list
    QUIT
    get_lines variable=service_names input=services_list
    delete_file file=services_list
    service_names=$apply($rest(service_names), x(35, all))
  IFEND

" Construct the write_terminal_message service_name parameter, provided ALL was not specified.
  IF $nil($select(service_names, x='ALL')) THEN
    cdcnet_command=cdcnet_command // ' sn=('
    FOR EACH service IN service_names DO
      cdcnet_command=cdcnet_command // service // ' '
    FOREND
    cdcnet_command=cdcnet_command // ')'
  IFEND

" Save common message generation code, so that it need not be duplicated.
COLLECT_TEXT output=build_and_send_message until='**'
  REPEAT
    message_text=$quote(message_id)
    IF $specified(message) THEN
      message_text=message_text // ' ' // $quote(message)
    ELSE
      FOR message_line = 2 TO lines_per_command DO " Accept message text from input.
        get_line variable=line input=input prompt='infu? '
        EXIT WHEN (line = '') OR (line = 'QUIT') OR (line = 'QUI') OR (line = 'quit') OR (line = 'qui') OR (line = '**')
        IF $size(cdcnet_command//' m=('//message_text//' '//$quote(line)//')')>= cdcnet_maximum THEN
          put_line line=' --ERROR-- Last line too long, please reenter.' output=$response
          EXIT " End message text acceptance for the current message block
        IFEND
        message_text=message_text // ' ' // $quote(line)
      FOREND
    IFEND
    IF message_text <> $quote(message_id) THEN " At least one message line was entered.
      IF NOT $specified(system) THEN " Locate all DI system names to process the message command.
        system=$apply($select($matching_names(title_pattern), x<>''), $name(x))
        EXIT_PROC WHEN $nil(system) with $status(false, 'NA', nae$unknown_title_pattern, $quote(title_pattern))
      IFEND
      display_values values=(cdcnet_command//' m=('//message_text//')', system) output=$job_log
      send_command command=cdcnet_command//' m=('//message_text//')' system=system output=$job_log status=ignore
      FOR EACH tdi IN system DO " Check whether message was delivered by each system sent the message command.
        IF $response_identifier(tdi)= message_acknowledged THEN
          put_line line=' Message received by '//tdi output=$response
        IFEND
      FOREND
    IFEND
  UNTIL (line = '') OR (line = 'QUIT') OR (line = 'QUI') OR (line = 'quit') OR (line = 'qui') OR (line = '**')
**

" Enter operator utility to send the message command if the utility is NOT currently active.
  IF $utility(name)= network_command_utility THEN
    include_file build_and_send_message
  ELSE
    NETWORK_OPERATOR_UTILITY prolog=$null
      include_file build_and_send_message
    QUIT
  IFEND

PROCEND inform_users
*DECK DECK=RAM$INIDD_ACTIVATION_MENU EXPAND=TRUE
CREATE_MESSAGE_MODULE inidd_activation$us_english


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This deck contains the command calls to create a menu message module
"   that is used by the procedure RAP$GET_ACTIVATION_OPTION.  The
"   messages are formatted for the RAP$PROMPT_VIA_MENU interface.
"
" DESIGN:
"   The function of a message module is to provide help for a user executing
"   commands interactively.  Therefore the kinds of messages found in a
"   message module reflect that purpose.  In setting up menus using message
"   module technology the message kinds are given new meanings.
"
"     The menu title is created as the brief help message.
"     The menu help is created as the full help message.
"     The menu selections are created as parameter prompt messages.
"     The menu selection help (optional) is created as a parameter help message.
"     The menu selection confirmation (optional) is created as a parameter
"     assist message.
"     The menu prompt is created as a parameter prompt message.
"
" NOTES:
*IFEND


CREATE_BRIEF_HELP_MESSAGE
+X2+N0Your system activation choices are:+N+X2
**

CREATE_FULL_HELP_MESSAGE
+X2+N0You have completed the installation of the Installation Tape.+X2You may now
 activate the system in order to continue with the installation or activate it
 for system console usage only.+X2Processing will be complete when you see the
 message:
+N+X2
+N2----- SYSTEM ACTIVATION COMPLETE -----
+N+X2
+N0This message will be followed by the NOS/VE slash (/) prompt at which time
 you may enter commands.
+N+X2
+N0To get help for a particular selection, enter the number of the selection,
 followed by a question mark.
 For example, to get help for selection 1, you would enter:
+N+X2
+N2 1?
+N+X2
**

CREATE_PARAMETER_PROMPT_MESSAGE n=production_usage
+X2+P1.+X2Activate the system to continue with the installation.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=console_usage_only
+X2+P1.+X2Activate the system for system console usage only.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=prompt
+X2+N0Enter selection or ? for HELP.
**

CREATE_PARAMETER_HELP_MESSAGE n=production_usage
+X2+N0This selection causes the system to be activated so that you
 may continue with the installation.+X2The tasks and processes
 necessary for installation will be activated.+X2Since only the
 Installation Tape has been loaded, general system functionality
 is still limited.
+N+X2
**

CREATE_PARAMETER_HELP_MESSAGE n=console_usage_only
+N0This selection causes the system to be activated for system console
 usage only.+X2To subsequently activate the system to continue
 with the installation, enter the command
 ACTIVATE_PRODUCTION_ENVIRONMENT (ACTPE).
+N+X2
**

END_MESSAGE_MODULE
*DECK DECK=RAM$INITIATION_MENU EXPAND=TRUE
CREATE_MESSAGE_MODULE initiation_menu$us_english


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This deck contains the command calls to create a menu message module
"   that is used by the procedure RAP$GET_INITIATION_OPTION.  The
"   messages are formatted for the RAP$PROMPT_VIA_MENU interface.
"
" DESIGN:
"   The function of a message module is to provide help for a user executing
"   commands interactively.  Therefore the kinds of messages found in a
"   message module reflect that purpose.  In setting up menus using message
"   module technology the message kinds are given new meanings.
"
"     The menu title is created as the brief help message.
"     The menu help is created as the full help message.
"     The menu selections are created as parameter prompt messages.
"     The menu selection help (optional) is created as a parameter help message.
"     The menu selection confirmation (optional) is created as a parameter
"     assist message.
"     The menu prompt is created as a parameter prompt message.
"
" NOTES:
*IFEND


CREATE_BRIEF_HELP_MESSAGE
+X2+N0Choose one of the following selections:+N+X2
**

CREATE_FULL_HELP_MESSAGE
+X2+N0Because you entered the INITIALIZE_SYSTEM_DEVICE (INISD) command in the
 system core command window, all NOS/VE permanent files have been erased
 from your disks.  You may now choose to install new software (selection 1)
 or activate the system for system console usage only (selection 2).
 Choose selection 2 to reload permanent files from tape backups.
+N+X2+N0To get help for a particular selection, enter the number of the selection,
 followed by a question mark.
 For example, to get help for selection 1, you would enter:
+N+X2+N2 1?+N+X2
**

CREATE_PARAMETER_PROMPT_MESSAGE n=install_installation_tape
+X2+P1.+X2Install the Installation Tape.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=console_usage_only
+X2+P1.+X2Activate the system for system console usage only.
+N7(Choose this selection if you need to restore permanent files.)
**

CREATE_PARAMETER_PROMPT_MESSAGE n=prompt
+X2+N0Enter selection or ? for HELP.
**

CREATE_PARAMETER_HELP_MESSAGE n=console_usage_only
+N0This selection causes the system to be activated for system console
 usage only.+X2Processing will be complete when you see the message:
+N+X2
+N2----- SYSTEM ACTIVATION COMPLETE -----
+N+X2
+N0This message will be followed by the NOS/VE slash (/) prompt at which time
 you may enter commands.+X2Typically, you will use the RESTORE_CATALOGED_FILES
 command to begin restoring your permanent files from a set of backup
 tapes.+X2To subsequently activate the system for
 production, enter the command
 ACTIVATE_PRODUCTION_ENVIRONMENT (ACTPE).
+N+X2
**

CREATE_PARAMETER_HELP_MESSAGE n=install_installation_tape
+X2+N0This selection causes the Installation Tape to be
 installed.+X2Mount the tape onto a configured tape unit.+X2(If you are
 using an unconfigured NOS/VE deadstart tape, you will have to unload
 the deadstart tape before you can mount the Installation
 Tape.)+X2Once installation of the tape is complete, you will be given the
 choice of activating the system for production or for system console usage only.
+N+X2
**

END_MESSAGE_MODULE

*DECK DECK=RAM$INITIATION_MESSAGES EXPAND=TRUE
CREATE_MESSAGE_MODULE initiation_messages$us_english


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This deck contains the command calls to create the system initiation
"   messages module that is used by the DISPLAY_MESSAGE interface.
"
" DESIGN:
"   The function of a message module is to provide help for a user executing
"   commands interactively.  Therefore the kinds of messages found in a
"   message module reflect that purpose.  In setting up messages to display
"   using message module technology the parameter prompt messages are used
"   as the displaying messages.
*IFEND


CREATE_PARAMETER_PROMPT_MESSAGE n=initiating_system
+N0Beginning system initiation +K...+K
**

CREATE_PARAMETER_PROMPT_MESSAGE n=system_initiation_complete
System initiation complete.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=system_activation_complete
+N0---- SYSTEM ACTIVATION COMPLETE ----+N+X2
**

CREATE_PARAMETER_PROMPT_MESSAGE n=activating_dual_state_tasks
+N0Activating dual state tasks +K...+K
**

CREATE_PARAMETER_PROMPT_MESSAGE n=dual_state_tasks_activated
Dual state tasks activated.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=activating_namve
+N0Activating NAM/VE +K...+K
**

CREATE_PARAMETER_PROMPT_MESSAGE n=namve_activated
NAM/VE activated.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=activating_network
+N0Activating the network +K...+K
**

CREATE_PARAMETER_PROMPT_MESSAGE n=network_activated
Network activated.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=deactivating_namve
+N0Deactivating NAM/VE +K...+K
**

CREATE_PARAMETER_PROMPT_MESSAGE n=namve_deactivated
NAM/VE deactivated.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=deactivating_network
+N0Deactivating the network +K...+K
**

CREATE_PARAMETER_PROMPT_MESSAGE n=network_deactivated
Network deactivated.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=activating_for_production
+N0Activating the system for production +K...+K
**

CREATE_PARAMETER_PROMPT_MESSAGE n=production_activated
System activated for production.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=console_only_activated
+N0System activated for system console usage ONLY.+X2The system is NOT
 available to users.+N+X2
**

CREATE_PARAMETER_PROMPT_MESSAGE n=activating_job_environment
+N0Activating job environment +K...+K
**

CREATE_PARAMETER_PROMPT_MESSAGE n=job_environment_activated
Job environment activated.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=executing_initiation_commands
+N0Executing +P1 +K...+K
**

CREATE_PARAMETER_PROMPT_MESSAGE n=initiation_commands_executed
+P1 executed.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=installing_deferred_products
+N0Installing deferred products +K...+K
**

CREATE_PARAMETER_PROMPT_MESSAGE n=deferred_products_installed
Deferred products installed.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=installing_installation_tape
+N0Installing Installation Tape +K...+K
**

CREATE_PARAMETER_PROMPT_MESSAGE n=installation_tape_installed
Installation Tape installed.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=continuing_without_action
+N+X2+N0Continuing with system initiation +K...+K
+N2No system installation will be performed.
+N2The system will be activated for system console usage only.
+N+X2
**

CREATE_PARAMETER_PROMPT_MESSAGE n=activation_option_set
+N+X2+N0The system activation option is set to +P.+N+X2
**

CREATE_PARAMETER_PROMPT_MESSAGE n=installation_option_set
+N+X2+N0The system installation option is set to +P.+N+X2
**

CREATE_PARAMETER_PROMPT_MESSAGE n=user_aborts_tape_request
+N+X2+N0The request for the installation tape (or initial load from the tape)
 was terminated at the user's request.+X2When prompted, please verify the
 tape installation parameters and mount the correct tape.+X2To
 terminate the installation, enter QUIT at the prompt and the system
 will be activated for system console usage only.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=incorrect_installation_tape
+N+X2+N0This is not the correct tape.+X2One of the following occurred:
+N1 1. The incorrect installation tape was assigned.+X2The first
+N5installation tape must be assigned.
+N1 2. This tape is not an installation tape.
+N0When prompted, please verify the tape installation parameters
 and mount the correct tape.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=no_setit_command
+N+X2+N0During system core command processing, no SET_INSTALLATION_TAPE
 command was entered.+X2You will be presented with a menu to supply the
 packing list name and VSN(s) of the installation tape.+X2If you do
 not wish to install the installation tape, you may enter QUIT at
 the menu prompt.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=packing_list_name_already_used
+N+X2+N0The packing list name selected (+P1) is already being used.+X2Please
 enter a new value.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=requesting_installation_tape
+N0Requesting installation tape with EVSN='+P1' RVSN='+P2'
 and TYPE=+P3 +K...+K
**

CREATE_PARAMETER_PROMPT_MESSAGE n=unable_to_restore_from_tape
+N+X2+N0The permanent file restore from the installation tape failed.+X2This
 may have been caused by one of the following:
+N1 1. A dirty tape drive.
+N1 2. A faulty tape drive.
+N1 3. A faulty tape.
+N1 4. The wrong tape.
+N1 5. Some other problem.
+N0When prompted, please verify the tape installation
 parameters and mount the correct tape. To terminate the installation,
 enter QUIT at the prompt and the system will be activated for system console
 usage only.
**


END_MESSAGE_MODULE
*DECK DECK=RAM$INIT_PROCESSING_SEQ EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$INIT_PROCESSING_SEQ Interface.' ??
MODULE ram$init_processing_seq;

{ PURPOSE:
{   This module contains the interface and procedure that initializes the
{   processing sequence and acesses the packing list.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$control_file_name
*copyc rae$install_software_cc
*copyc rat$installation_control_record
*copyc rat$installation_defaults
?? POP ??
*copyc fsp$close_file
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc rap$establish_icr_packlist_ptrs
*copyc rap$establish_icr_subp_ptrs
*copyc rap$open_packing_list_using_icr
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$init_processing_seq', EJECT ??

{ PURPOSE:
{   This interface creates and initializes the processing sequence and
{   accesses the packing list that are used by the installation control
{   record.  The processing sequence holds records that describe how the
{   processing will be done.  In some cases it will also contain a
{   modifiable copy of the packing list.
{
{ DESIGN:
{   A memory scratch segment is created to contain the processing sequence.
{   (The deletion of the segment is the responsibility of the caller.)
{
{   The packing list is accessed and the major data pointers are
{   established.  When installing corrections or updates, the packing list
{   must be modifiable.  This means that a copy of the packing list is
{   placed at the end of the processing sequence.  The pointers are
{   established to the copy and the original packing list is closed.
{
{   The medium and subproduct processing records are established when the
{   packing list is accessed.  The number of subproducts and medium type
{   determine how the records are created.  The job processing record is
{   created when the processing controls are established.
{
{ NOTES:
{   At 1.4.1 only corrections (which must be installed using the
{   INSTALL_CORRECTION command) are supported.  In the future, updates will
{   be supported, at which time the test for when a modifiable packing
{   list is needed will have to be changed.
{

  PROCEDURE [XDCL] rap$init_processing_seq
    (    packing_list_name: ost$name;
         save_previous_cycles: boolean;
         installation_command: rat$installation_commands;
         command_compatible_type: rat$subproduct_type;
         installation_defaults: rat$installation_defaults;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR processing_segment_pointer: amt$segment_pointer;
     VAR packing_list_fid: amt$file_identifier;
     VAR packing_list_opened: boolean;
     VAR status: ost$status);


    VAR
      ignore_status: ost$status,
      local_status: ost$status;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to return the scratch
{   segment when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;


      IF processing_segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (processing_segment_pointer, ignore_status);
        processing_segment_pointer.sequence_pointer := NIL;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    processing_segment_pointer.kind := amc$sequence_pointer;
    processing_segment_pointer.sequence_pointer := NIL;

    packing_list_opened := FALSE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      initialize_seq_and_header (packing_list_name, save_previous_cycles, installation_command,
            command_compatible_type, installation_defaults, installation_control_record,
            processing_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$open_packing_list_using_icr (installation_control_record, packing_list_fid, packing_list_opened,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF installation_command = rac$install_correction THEN

        { A modifiable copy of the packing list is placed at the end of the processing
        { sequence.  The packing list file is then closed.

        write_packing_list_to_seq (installation_control_record, status);
        IF packing_list_opened THEN
          fsp$close_file (packing_list_fid, local_status);
          packing_list_opened := FALSE;
          IF (NOT status.normal) AND (NOT local_status.normal) THEN
            status := local_status;
          IFEND;
          IF NOT status.normal THEN
            EXIT /main/;
          IFEND;
        IFEND;

      IFEND;

      rap$establish_icr_packlist_ptrs (installation_control_record, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      establish_processing_records (installation_control_record, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$establish_icr_subp_ptrs (installation_control_record, status);

    END /main/;

    IF (NOT status.normal) AND (processing_segment_pointer.sequence_pointer <> NIL) THEN
      mmp$delete_scratch_segment (processing_segment_pointer, ignore_status);
      processing_segment_pointer.sequence_pointer := NIL;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$init_processing_seq;

?? OLDTITLE ??
?? NEWTITLE := 'establish_processing_records', EJECT ??

{ PURPOSE:
{   This procedure establishes the medium and subproduct processing records
{   (which are part of the processing sequence).
{
{ DESIGN:
{   The medium and subproduct processing records provide extended processing
{   information to the information already contained in the packing list.
{   There is a one to one mapping between the subproduct processing records
{   and the subproduct indexer found on the packing list.  Likewise, there
{   is a a one to one mapping between the medium processing records and the
{   tape vsn list (when the order medium is tape).  For non-tape orders the
{   medium processing record is of length one.
{
{ NOTES:
{   Not all of the subproduct processing record fields are set.  The subproduct
{   information pointers are set by rap$establish_icr_subp_ptrs.
{

  PROCEDURE establish_processing_records
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      i: rat$subproduct_count,
      medium_record_count: rat$tape_count;


    status.normal := TRUE;

{ Establish the medium processing records.

    IF installation_control_record.packing_list_pointers.order_medium = rac$tape THEN
      medium_record_count := installation_control_record.packing_list_pointers.header_p^.primary_tape_count;
    ELSE {order medium = rac$disk}
      medium_record_count := 1;
    IFEND;

    NEXT installation_control_record.medium_processing_records_p: [1 .. medium_record_count] IN
          installation_control_record.processing_seq_p;
    IF installation_control_record.medium_processing_records_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'PROCESSING SEQUENCE', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'JOB PROCESSING RECORDS', status);
      RETURN;
    IFEND;

    installation_control_record.processing_header_p^.medium_processing_rec_rel_p :=
          #REL (installation_control_record.medium_processing_records_p,
          installation_control_record.processing_seq_p^);

    { Initialize the fields of the medium processing records.

    FOR i := 1 TO UPPERBOUND (installation_control_record.medium_processing_records_p^) DO
      installation_control_record.medium_processing_records_p^ [i].job_identifier := osc$null_name;
      installation_control_record.medium_processing_records_p^ [i].subproduct_count := 0;
    FOREND;

{ Establish the subproduct processing records.

    NEXT installation_control_record.subproduct_processing_records_p:
          [1 .. installation_control_record.packing_list_pointers.header_p^.subproduct_count] IN
          installation_control_record.processing_seq_p;
    IF installation_control_record.subproduct_processing_records_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'PROCESSING SEQUENCE', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'SUBPRODUCT PROCESSING RECORDS', status);
      RETURN;
    IFEND;

    installation_control_record.processing_header_p^.subproduct_processing_rec_rel_p :=
          #REL (installation_control_record.subproduct_processing_records_p,
          installation_control_record.processing_seq_p^);

    { Initialize the fields of the subproduct processing records.

    FOR i := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^) DO
      installation_control_record.subproduct_processing_records_p^ [i].job_identifier := osc$null_name;
      installation_control_record.subproduct_processing_records_p^ [i].product_reference :=
            rac$not_referenced;
      installation_control_record.subproduct_processing_records_p^ [i].task_set := $rat$task_selections [];
      installation_control_record.subproduct_processing_records_p^ [i].task := rac$null_task;
      installation_control_record.subproduct_processing_records_p^ [i].task_status := rac$task_started;
      installation_control_record.subproduct_processing_records_p^ [i].installation_catalog_p := NIL;
      installation_control_record.subproduct_processing_records_p^ [i].installation_catalog_rel_p := NIL;
      installation_control_record.subproduct_processing_records_p^ [i].active_level_catalog_rel_p := NIL;
      installation_control_record.subproduct_processing_records_p^ [i].base_level_catalog_rel_p := NIL;
      installation_control_record.subproduct_processing_records_p^ [i].correction_base_catalog_rel_p := NIL;
    FOREND;

  PROCEND establish_processing_records;

?? OLDTITLE ??
?? NEWTITLE := 'initialize_seq_and_header', EJECT ??

{ PURPOSE:
{   This procedure creates and initializes the processing sequence and header.
{
{ DESIGN:
{   The fields in the header record are set.  The PACKING_LIST_NAME,
{   SAVE_PREVIOUS_CYCLES and INSTALLATION_DEFAULTS values were passed in.
{
{ NOTES:
{

  PROCEDURE initialize_seq_and_header
    (    packing_list_name: ost$name;
         save_previous_cycles: boolean;
         installation_command: rat$installation_commands;
         command_compatible_type: rat$subproduct_type;
         installation_defaults: rat$installation_defaults;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR processing_segment_pointer: amt$segment_pointer;
     VAR status: ost$status);



    status.normal := TRUE;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, processing_segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    installation_control_record.processing_seq_p := processing_segment_pointer.sequence_pointer;

    RESET installation_control_record.processing_seq_p;

    NEXT installation_control_record.processing_header_p IN installation_control_record.processing_seq_p;
    IF installation_control_record.processing_header_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'PROCESSING SEQUENCE', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'HEADER', status);
      RETURN;
    IFEND;

    { Initialize the procesing header values.

    installation_control_record.processing_header_p^.installation_identifier := osc$null_name;
    installation_control_record.processing_header_p^.installation_command := installation_command;
    installation_control_record.processing_header_p^.command_compatible_type := command_compatible_type;
    installation_control_record.processing_header_p^.installation_defaults := installation_defaults;
    installation_control_record.processing_header_p^.packing_list_name := packing_list_name;
    installation_control_record.processing_header_p^.packing_list_seq_rel_p := NIL;
    installation_control_record.processing_header_p^.packing_list_seq_size := 0;
    installation_control_record.processing_header_p^.job_processing_rec_rel_p := NIL;
    installation_control_record.processing_header_p^.medium_processing_rec_rel_p := NIL;
    installation_control_record.processing_header_p^.subproduct_processing_rec_rel_p := NIL;
    installation_control_record.processing_header_p^.number_of_steps := 0;
    installation_control_record.processing_header_p^.step_set := $rat$step_selections [];
    installation_control_record.processing_header_p^.save_previous_cycles := save_previous_cycles;

  PROCEND initialize_seq_and_header;

?? OLDTITLE ??
?? NEWTITLE := 'write_packing_list_to_seq', EJECT ??

{ PURPOSE:
{   This procedure writes the contents of the packing list file to
{   EOI of the processing sequence in memory.
{
{ DESIGN:
{   The file is opened as segment access and a file contents pointer is
{   established.  A sequence contents file is created for the same size and
{   the file contents are assigned to the memory processing sequence
{   contents (using assignment of deferred pointers).
{
{ NOTES:
{

  PROCEDURE write_packing_list_to_seq
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      local_status: ost$status,
      packing_list_contents_p: ^SEQ ( * ),
      packing_list_length: integer,
      packing_list_seq_p: ^rat$packing_list_sequence;


    status.normal := TRUE;
    packing_list_seq_p := installation_control_record.packing_list_pointers.sequence_p;

    { Establish the pointer to the control file contents.

    packing_list_length := #SIZE (packing_list_seq_p^);

    RESET packing_list_seq_p;
    NEXT packing_list_contents_p: [[REP packing_list_length OF cell]] IN packing_list_seq_p;
    IF packing_list_contents_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'PACKING LIST', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'CONTENTS', status);
      RETURN;
    IFEND;

    { Establish the pointer to create the packing list sequence at EOI of the processing sequence.

    NEXT installation_control_record.packing_list_pointers.sequence_p: [[REP packing_list_length OF cell]] IN
          installation_control_record.processing_seq_p;
    IF installation_control_record.packing_list_pointers.sequence_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'PROCESSING SEQUENCE', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'CONTENTS', status);
      RETURN;
    IFEND;

    { Assign the contents of the packing list file to the contents of the packing list sequence
    { found in the processing sequence.

    installation_control_record.packing_list_pointers.sequence_p^ := packing_list_contents_p^;

    { Establish the relative pointer and size to the packing list.

    installation_control_record.processing_header_p^.packing_list_seq_rel_p :=
          #REL (installation_control_record.packing_list_pointers.sequence_p,
          installation_control_record.processing_seq_p^);
    installation_control_record.processing_header_p^.packing_list_seq_size := packing_list_length;

  PROCEND write_packing_list_to_seq;

MODEND ram$init_processing_seq;
*DECK DECK=RAM$INIT_PROCESSING_SEQ_FR_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$INIT_PROCESSING_SEQ_FR_FILE Interface.' ??
MODULE ram$init_processing_seq_fr_file;

{ PURPOSE:
{   This module contains the interface and procedures that initializes the
{   processing sequence from a installation control file.  This is to
{   include accessing the packing list when not already contained in the
{   installation control file.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$control_file_name
*copyc rae$install_software_cc
*copyc rat$installation_control_record
*copyc rat$installation_defaults
?? POP ??
*copyc amp$get_segment_pointer
*copyc fsp$close_file
*copyc fsp$open_file
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc rap$establish_icr_packlist_ptrs
*copyc rap$establish_icr_subp_ptrs
*copyc rap$open_packing_list_using_icr
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$init_processing_seq_fr_fileuence', EJECT ??

{ PURPOSE:
{   This interface creates and initializes the processing sequence that is
{   used by the installation control record from the installation control
{   file.  The processing sequence holds records that describe how the
{   processing will be done.  The packing list is also accessed when not
{   part of the installation control file.
{
{ DESIGN:
{   A memory scratch segment is created to contain the processing sequence.
{   (The calling interface is expected to delete the scratch segment.)
{
{   The installation control file is copied into the just created processing
{   sequence (The installation control file is a copy of the original
{   processing sequence that was created just before the batch jobs were
{   submitted.)
{
{   After the copy is made the processing header is re-established.  The
{   relative pointers to the processing records are converted to real
{   pointers in the installation control record.  All major pointers are
{   reestablshed.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$init_processing_seq_fr_file
    (    installation_control_file: fst$file_reference;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR processing_segment_pointer: amt$segment_pointer;
     VAR packing_list_fid: amt$file_identifier;
     VAR packing_list_opened: boolean;
     VAR status: ost$status);


    VAR
      ignore_status: ost$status,
      processing_seq_eoi_p: ^cell;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to return the scratch
{   segment when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;


      IF processing_segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (processing_segment_pointer, ignore_status);
        processing_segment_pointer.sequence_pointer := NIL;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    processing_segment_pointer.kind := amc$sequence_pointer;
    processing_segment_pointer.sequence_pointer := NIL;

    packing_list_opened := FALSE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN


      init_processing_seq_and_header (installation_control_file, installation_control_record,
            processing_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF installation_control_record.processing_header_p^.packing_list_seq_rel_p = NIL THEN

        rap$open_packing_list_using_icr (installation_control_record, packing_list_fid,
              packing_list_opened, status);

      ELSE {Packing list is already in processing sequence}

        installation_control_record.packing_list_pointers.sequence_p :=
              #PTR (installation_control_record.processing_header_p^.packing_list_seq_rel_p,
              installation_control_record.processing_seq_p^);

      IFEND;

      { Establish packing list pointers.

      rap$establish_icr_packlist_ptrs (installation_control_record, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      { Re-establish the pointers to the processing records.  These are fields in the
      { installation control record.

      installation_control_record.job_processing_records_p :=
            #PTR (installation_control_record.processing_header_p^.job_processing_rec_rel_p,
            installation_control_record.processing_seq_p^);

      installation_control_record.medium_processing_records_p :=
            #PTR (installation_control_record.processing_header_p^.medium_processing_rec_rel_p,
            installation_control_record.processing_seq_p^);

      installation_control_record.subproduct_processing_records_p :=
            #PTR (installation_control_record.processing_header_p^.subproduct_processing_rec_rel_p,
            installation_control_record.processing_seq_p^);

      rap$establish_icr_subp_ptrs (installation_control_record, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

    END /main/;

    IF (NOT status.normal) AND (processing_segment_pointer.sequence_pointer <> NIL) THEN
      mmp$delete_scratch_segment (processing_segment_pointer, ignore_status);
      processing_segment_pointer.sequence_pointer := NIL;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$init_processing_seq_fr_file;

?? OLDTITLE ??
?? NEWTITLE := 'init_processing_seq_and_header', EJECT ??

{ PURPOSE:
{   This procedure writes the contents of the installation control file to
{   the processing sequence in memory.
{
{ DESIGN:
{   The file is opened as segment access and a file contents pointer is
{   established.  A sequence contents file is created for the same size and
{   the file contents are assigned to the memory processing sequence
{   contents (using assignment of deferred pointers).
{
{ NOTES:
{

  PROCEDURE init_processing_seq_and_header
    (    installation_control_file: fst$file_reference;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR processing_segment_pointer: amt$segment_pointer;
     VAR status: ost$status);


    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      control_file_contents_p: ^SEQ ( * ),
      control_file_fid: amt$file_identifier,
      control_file_length: integer,
      control_file_opened: boolean,
      control_file_segment_pointer: amt$segment_pointer,
      local_status: ost$status,
      processing_seq_contents_p: ^SEQ ( * );


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to return the installation
{   control file when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;


      fsp$close_file (control_file_fid, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    control_file_opened := FALSE;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_options [1].share_modes.selector := fsc$determine_from_access_modes;
    attachment_options [2].selector := fsc$create_file;
    attachment_options [2].create_file := FALSE;
    attachment_options [3].selector := fsc$wait_for_attachment;
    attachment_options [3].wait_for_attachment.wait := osc$wait;
    attachment_options [3].wait_for_attachment.wait_time := fsc$longest_wait_time;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, processing_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      installation_control_record.processing_seq_p := processing_segment_pointer.sequence_pointer;

      control_file_opened := TRUE;
      fsp$open_file (installation_control_file, amc$segment, ^attachment_options, NIL, NIL, NIL, NIL,
            control_file_fid, status);
      IF NOT status.normal THEN
        control_file_opened := FALSE;
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (control_file_fid, amc$sequence_pointer, control_file_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      { Establish the pointer to the control file contents.

      control_file_length := #SIZE (control_file_segment_pointer.sequence_pointer^);

      RESET control_file_segment_pointer.sequence_pointer;
      NEXT control_file_contents_p: [[REP control_file_length OF cell]] IN
            control_file_segment_pointer.sequence_pointer;
      IF control_file_contents_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, rac$control_file_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'CONTENTS', status);
        EXIT /main/;
      IFEND;

      { Establish the pointer to the processing sequence contents for the same length.

      RESET installation_control_record.processing_seq_p;
      NEXT processing_seq_contents_p: [[REP control_file_length OF cell]] IN
            installation_control_record.processing_seq_p;
      IF processing_seq_contents_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'PROCESSING SEQUENCE', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'CONTENTS', status);
        EXIT /main/;
      IFEND;

      { Assign the contents of the control file to the contents of the processing sequence.

      processing_seq_contents_p^ := control_file_contents_p^;

      { Establish the pointer to the processing header.

      RESET installation_control_record.processing_seq_p;

      NEXT installation_control_record.processing_header_p IN installation_control_record.processing_seq_p;
      IF installation_control_record.processing_header_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'PROCESSING SEQUENCE', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'HEADER', status);
        EXIT /main/;
      IFEND;

    END /main/;

    IF control_file_opened THEN
      fsp$close_file (control_file_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND init_processing_seq_and_header;
MODEND ram$init_processing_seq_fr_file;
*DECK DECK=RAM$INSDF EXPAND=TRUE
.PROC,INSDF*I,
VSN "Volume Serial Number of DS tape"  = (*N=,
                                     *S6(ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789)),
D "tape Density (GE,PE,HD,HY)"         = (*N=PE,GE,PE,HD,HY),
B "Base user" =(*N,*F),
.
.HELP
 The INSDF procedure INStalls a shortened version of the NOS/VE
 Deadstart File for Continuation and Recovery deadstarts.

 Parameter   Default   Description
   Name       Value

  [vsn]                 deadstart tape volume serial number
  [d]           pe      deadstart tape density (ge,pe,hd,hy)
  [b]                   base user

.HELP,VSN
 The VSN parameter specifies the deadstart tape volume serial number.
 The default is to attach a permanent file named TPXXXK.
.HELP,D
 The D parameter specifies the deadstart tape density.
 The default density is PE.
.HELP,B
  The B parameter specifies the base user number used to obtain the
  deadstart tape if not found on the default user number.
  The default is no base user.
.ENDHELP
GETNVE(TPXXXK,TPXXXK,,B,VSN,D)
DSMDSTG(NVEDIR,,LIST)
REWIND(TPXXXK,NVETAPE)
COPYBR,TPXXXK,NEWTAPE.    * DEADSTART PP
GTR,TPXXXK,NEWTAPE.MARK00-DCFILE
SKIPEI,NEWTAPE.
COPY,NVETAPE,NEWTAPE.
REPFILE,NEWTAPE,TPXXXK,DEFINE=YES.
$UNLOAD(NVETAPE,TPXXXK,NEWTAPE,LIST,NVEDIR,EMPTY)
$SKIP,NOERROR.
  $EXIT.
  $UNLOAD(NVETAPE,TPXXXK,NEWTAPE,LIST,NVEDIR,EMPTY)
  $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    $EXIT. INSDF *TERMINATED*
  $ENDIF,TERMINATED.
  $REVERT,ABORT. DEADSTART FILE NOT INSTALLED
$ENDIF,NOERROR.
$REVERT. DEADSTART FILE --> TPXXXK
.DATA,NVEDIR.
WRITEAR,10
LOADFILE,EMPTY,ASCII180,NAME170=NULL
LOADFILE,EMPTY,ASCII180,NAME170=PROLOGS
LOADFILE,EMPTY,TERMINATOR,NAME170=TERM
ENDTAPE
LOADEND
.DATA,EMPTY
EMPTYFILE
AN ALMOST EMPTY FILE
/EOR
*DECK DECK=RAM$INSERT_OR_REPLACE_CORRECTOR EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$insert_or_replace_corrector;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc rav$elements
*copyc rav$corp
*copyc rav$correction_package_header
*copyc amd$file_attributes
*copyc rat$element_descriptor
*copyc oct$corrector
*copyc rat$correction_package
*copyc i#move
?? POP ??

*copyc rah$insert_or_replace_corrector

  PROCEDURE [XDCL] rap$insert_or_replace_corrector (element: rat$element_descriptor;
        corrector: ^SEQ ( * );
        size: oct$corrector_size;
        user_info: amt$user_info);

    VAR
      temp: integer,
      correction: ^SEQ ( * ),
      found: boolean,
      hi: rat$element_index,
      i: rat$element_index,
      low: rat$element_index,
      mid: rat$element_index;

    hi := rav$correction_package_header^.number_of_elements;
    found := FALSE;
    low := 1;
    WHILE (low <= hi) AND NOT found DO
      temp := low + hi;
      mid := temp DIV 2;
      IF element.name = rav$elements^ [mid].name THEN
        found := TRUE;
      ELSEIF element.name < rav$elements^ [mid].name THEN
        hi := mid - 1;
      ELSE
        low := mid + 1;
      IFEND;
    WHILEND;
    IF found THEN
      NEXT correction: [[REP size OF cell]] IN rav$corp.sequence_pointer;
      rav$elements^ [mid].size := size;
      rav$elements^ [mid].user_info := user_info;
      rav$elements^ [mid].format := element.format;
      rav$elements^ [mid].class := element.class;
      rav$elements^ [mid].correction_package := #REL (correction, rav$corp.sequence_pointer^);
      rav$elements^ [mid].number_of_psrs := 0;
    ELSE
      i := rav$correction_package_header^.number_of_elements;
      WHILE (i >= 1) AND NOT found DO
        IF element.name < rav$elements^ [i].name THEN
          rav$elements^ [i + 1] := rav$elements^ [i];
          i := i - 1;
        ELSE
          found := TRUE;
        IFEND;
      WHILEND;
      NEXT correction: [[REP size OF cell]] IN rav$corp.sequence_pointer;
      rav$elements^ [i + 1].name := element.name;
      rav$elements^ [i + 1].size := size;
      rav$elements^ [i + 1].user_info := user_info;
      rav$elements^ [i + 1].number_of_psrs := 0;
      rav$elements^ [i + 1].format := element.format;
      rav$elements^ [i + 1].class := element.class;
      rav$elements^ [i + 1].correction_package := #REL (correction, rav$corp.sequence_pointer^);
      rav$correction_package_header^.number_of_elements := rav$correction_package_header^.number_of_elements +
            1;
    IFEND;
    i#move (corrector, correction, size);
  PROCEND rap$insert_or_replace_corrector;
MODEND ram$insert_or_replace_corrector;
*DECK DECK=RAM$INSTALL_CDCNET_CONFIG EXPAND=TRUE
PROCEDURE install_cdcnet_configuration inscc (
  status)


    create_variable choice k=string
    create_variable local_status k=status
    create_variable yes_response k=boolean



  put_line ('  ',' In order to use the configuration terminal, you must define', ..
                 ' the CDCNET Device Interface''s which connect that terminal', ..
                 ' to the host.') o=$output


define_single_di: ..
  LOOP

    put_line ('  ',' Select the type of Device Interface (DI)', ..
                   '   1) Mainframe Terminal Interface (MTI)', ..
                   '   2) Mainframe Device Interface   (MDI)', ..
                   '   3) Terminal Device Interface    (TDI)')

  type_loop: ..
    LOOP
      accept_line choice input prompt='Enter the number of your choice: '
      include_line 'selection = $integer(choice)' status=local_status
      IF NOT local_status.normal THEN
        put_line '   Invalid selection, please re-enter.'
        CYCLE type_loop
      IFEND

      IF selection = 1 THEN
        di_type = 'MTI'
      ELSEIF selection = 2 THEN
        di_type = 'MDI'
      ELSEIF selection = 3 THEN
        di_type = 'TDI'
      ELSE
        put_line ' Invalid selection, please re-enter.'
        CYCLE type_loop
      IFEND

      $system.osf$builtin_library.prompt_for_answer ..
            'Is the selection of '//di_type//' correct?' yes_response
      EXIT type_loop WHEN yes_response
    LOOPEND type_loop

    put_line ('  ',' Enter the last six digits of the 12 hexadecimal digit DI system', ..
                   ' identifier.  For example, if the system identifier is 08002510007C, enter', ..
                   ' the value 10007C.  You should not include the (16) radix.')

  system_id_loop: ..
    LOOP
      accept_line choice input prompt='Enter the last six hexadecimal digits: '
      system_identifier = $translate(lower_to_upper, choice)
      length = $strlen(choice)
      IF length < 6 THEN
        system_identifier = $substr('000000', 1, 6-length) // system_identifier
      ELSEIF length > 6 THEN
        put_line ' You may only enter six hexadecimal digits. Please re-enter.'
        CYCLE system_id_loop
      IFEND

      include_line 'system_id = $integer(''0''//system_identifier//''(16)'')' status=local_status
      IF NOT local_status.normal THEN
        put_line ' Invalid digits given. Please re-enter.'
        CYCLE system_id_loop
      IFEND

      $system.osf$builtin_library.prompt_for_answer ..
            'Are the six hexadecimal digits '//system_identifier//' correct?' yes_response
      EXIT system_id_loop WHEN yes_response
    LOOPEND system_id_loop

    procedure_name = 'SYSTEM_080025' // system_identifier

    $system.osf$builtin_library.add_device_interface t=$name(di_type) ..
          pn=$name(procedure_name) status=local_status
    IF NOT local_status.normal THEN
      put_line ' '//$strrep(local_status)
    IFEND

    $system.osf$builtin_library.prompt_for_answer ..
          'Do you need to define another Device Interface (DI)?' yes_response
    EXIT define_single_di WHEN NOT yes_response
  LOOPEND define_single_di

  EXIT_PROC WITH local_status

PROCEND install_cdcnet_configuration
*DECK DECK=RAM$INSTALL_CORRECTION_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: INSTALL_CORRECTION Subcommand.' ??
MODULE ram$install_correction_command;

{ PURPOSE:
{   This module contains the command interface that installs a correction.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$control_job_identifier
*copyc rac$idb_directory_name
*copyc rae$install_software_cc
*copyc rat$installation_control_record
?? POP ??
*copyc amp$get_file_attributes
*copyc clp$evaluate_parameters
*copyc clp$include_line
*copyc clp$trimmed_string_size
*copyc clp$include_line
*copyc fsp$close_file
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc rap$display_job_log_to_cmd_log
*copyc rap$establish_processing_cntrls
*copyc rap$init_processing_seq
*copyc rap$perform_installation_steps
*copyc rap$submit_batch_jobs
*copyc rap$validate_for_installation
*copyc rav$installation_defaults
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$install_correction_command', EJECT ??

{ PURPOSE:
{   This command interface installs the specified product(s), subproduct(s)
{   or group(s).
{
{ DESIGN:
{   The installation process is divided into the following major steps:
{
{     1.  RECONCILING CYCLE CONFLICTS
{     2.  LOADING THE SUBPRODUCTS
{     3.  CORRECTING THE SUBPRODUCTS
{     4.  STAGING THE SUBPRODUCTS
{     5.  ACTIVATING THE SUBPRODUCTS
{     6.  EXECUTING THE INSTALLER PROCEDURES
{     7.  UPDATING THE IDB DIRECTORY
{     8.  DELETING PREVIOUS CYCLES
{
{   For the installation of corrections all steps are performed except the
{   deletion of previous cycles when previous cycles are to be saved.  In
{   addition, if the installation option is deferred, the steps to activate
{   the subproducts, execute installer procedures and delete previous cycles
{   are deferred.  The deferred steps are performed at a future deadstart.
{
{   The actual execution of the installation steps may cross job boundaries
{   depending on the circumstances.  By default processing is in batch.
{   This will free up the caller job (typically the console) for other
{   work.
{
{   Asynchronous processing is not available for installing corrections
{   as it is for installing products.  This is due to dependency concerns.
{
{   A hidden option is provided to force processing to remain in the job of
{   the caller.  This option is not advertised and solely for the maintenance
{   and checkout of this command interface.
{
{   The processing of any installation request is controlled by an
{   installation control record.  The installation control record contains
{   or has access to all pertainent information (including direct access to
{   information in the packing list).  The installation control record is
{   used to keep track of which TASKS are to be performed against which
{   subproducts.
{
{     NOTE:  The distinction between a step and a task is that steps
{     indicate processing at the global level, where as, tasks relate to
{     processing at the subproduct level.
{
{   The processing information is stored in segment accessed files (since
{   it must be accessable by other batch jobs).  Besides the packing list
{   (which defines the contents of the order and gives basic order
{   information), an installation control file is created to provide job
{   processing information, and a processing summary file is established to
{   provide job status feedback to the user.  The job logs from the batch
{   jobs (or current job) are (is) also written to permanent log files.
{
{   The installation control file is copied to memory by the batch job for
{   step/task processing.  The contents of the installation control file
{   were originally set up in memory and written to file only when batch
{   processing is performed.  While in memory it is referred to as the
{   processing sequence.
{
{   The installation control record contains pointers to the packing list,
{   the processing sequence and the job status record (in the processing
{   summary file).  It is only available to the job in which it was
{   created, and therefore must be recreated by the processing job.
{
{   The job log will be written to a permanent command log file under the
{   installation identifier catalog.  The job log is first displayed to
{   $null to set a LAST displayed mark.  After processing, the job log is
{   displayed starting from the last displayed mark.
{
{   The initial setup prior to performing the installation steps is:
{
{     1.  Flesh out the installation control record.  This includes the
{         creation of the processing sequence in memory (based on order
{         medium type and subproduct count).  The packing list is accessed
{         and a modifiable copy is placed into the processing sequence.
{         The major data pointers are established to the copy in the
{         processing sequence.
{
{     2.  Access the IDB directory and validate the product list.
{         Assign the tasks to be performed on the associated subproducts.
{
{     3.  Assign an installation identifier, job identifiers and log file
{         name.  Establish the processing summary file.
{
{     When batch processing is performed:
{
{     4.  Write the installation control file by copying the processing
{         sequence.  Submit the batch job.
{
{ NOTES:
{   The scratch segment is used for the processing sequence and is created
{   in RAP$INIT_PROCESSING_SEQ.
{

  PROCEDURE [XDCL] rap$install_correction_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE insc_pdt (
{   packing_list, pl: name 1..16 = $required
{   product, products, p: any of
{       key
{         all
{       keyend
{       list of name
{     anyend = $required
{   exclude_product, exclude_products, ep: list of name = $optional
{   force_reinstall, fr: boolean = false
{   installation_option, io: key
{       (immediate, i)
{       (deferred, d)
{     keyend = deferred
{   save_previous_cycles, spc: boolean = false
{   execute_in_job_of_caller, eijoc: (BY_NAME, HIDDEN) boolean = false
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 17] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (8),
      recend,
      type6: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type7: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 14, 11, 4, 45, 40],
    clc$command, 17, 8, 2, 0, 1, 0, 8, ''], [
    ['EIJOC                          ',clc$abbreviation_entry, 7],
    ['EP                             ',clc$abbreviation_entry, 3],
    ['EXCLUDE_PRODUCT                ',clc$nominal_entry, 3],
    ['EXCLUDE_PRODUCTS               ',clc$alias_entry, 3],
    ['EXECUTE_IN_JOB_OF_CALLER       ',clc$nominal_entry, 7],
    ['FORCE_REINSTALL                ',clc$nominal_entry, 4],
    ['FR                             ',clc$abbreviation_entry, 4],
    ['INSTALLATION_OPTION            ',clc$nominal_entry, 5],
    ['IO                             ',clc$abbreviation_entry, 5],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PACKING_LIST                   ',clc$nominal_entry, 1],
    ['PL                             ',clc$abbreviation_entry, 1],
    ['PRODUCT                        ',clc$nominal_entry, 2],
    ['PRODUCTS                       ',clc$alias_entry, 2],
    ['SAVE_PREVIOUS_CYCLES           ',clc$nominal_entry, 6],
    ['SPC                            ',clc$abbreviation_entry, 6],
    ['STATUS                         ',clc$nominal_entry, 8]],
    [
{ PARAMETER 1
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 5
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 8],
{ PARAMETER 6
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 7
    [5, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 8
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, 16]],
{ PARAMETER 2
    [[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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 4
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 5
    [[1, 0, clc$keyword_type], [4], [
    ['D                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['DEFERRED                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['I                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['IMMEDIATE                      ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ,
    'deferred'],
{ PARAMETER 6
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 7
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$packing_list = 1,
      p$product = 2,
      p$exclude_product = 3,
      p$force_reinstall = 4,
      p$installation_option = 5,
      p$save_previous_cycles = 6,
      p$execute_in_job_of_caller = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;


    VAR
      ignore_status: ost$status,
      installation_control_record: rat$installation_control_record,
      installation_tasks: rat$task_selections,
      local_status: ost$status,
      packing_list_fid: amt$file_identifier,
      packing_list_opened: boolean,
      processing_segment_pointer: amt$segment_pointer;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to return the processing
{   segment and packing list file when an abort condition arises.
{
{   When the processing segment pointer is not NIL, attempt to display the
{   job log to the command log.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;


      IF processing_segment_pointer.sequence_pointer <> NIL THEN
        rap$display_job_log_to_cmd_log (installation_control_record.processing_header_p^.
              installation_defaults.installation_logs, installation_control_record.processing_header_p^.
              installation_identifier, ignore_status);
        mmp$delete_scratch_segment (processing_segment_pointer, ignore_status);
        processing_segment_pointer.sequence_pointer := NIL;
      IFEND;

      fsp$close_file (packing_list_fid, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    check_directory_presence (rav$installation_defaults.installation_database, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_line ('$system.display_log do=last o=$null', TRUE, osc$null_name, ignore_status);

    installation_control_record.job_identifier := rac$control_job_identifier;
    installation_control_record.job_status_record_p := NIL;

    processing_segment_pointer.kind := amc$sequence_pointer;
    processing_segment_pointer.sequence_pointer := NIL;
    packing_list_opened := FALSE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      rap$init_processing_seq (pvt [p$packing_list].value^.name_value,
            pvt [p$save_previous_cycles].value^.boolean_value.value, rac$install_correction, rac$correction,
            rav$installation_defaults, installation_control_record, processing_segment_pointer,
            packing_list_fid, packing_list_opened, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      get_task_set (pvt [p$installation_option].value^.keyword_value, installation_control_record.
            processing_header_p, installation_tasks);

      rap$validate_for_installation (pvt [p$product].value, pvt [p$exclude_product].value,
            pvt [p$force_reinstall].value^.boolean_value.value, installation_tasks,
            installation_control_record, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$establish_processing_cntrls (FALSE {multiple job processing} ,
            pvt [p$execute_in_job_of_caller].value^.boolean_value.value, installation_control_record, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF pvt [p$execute_in_job_of_caller].value^.boolean_value.value THEN

        rap$perform_installation_steps (installation_control_record, status);

      ELSE {execute in batch}

        rap$submit_batch_jobs (installation_control_record, status);

      IFEND;

    END /main/;

    IF packing_list_opened THEN
      fsp$close_file (packing_list_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF processing_segment_pointer.sequence_pointer <> NIL THEN
      rap$display_job_log_to_cmd_log (installation_control_record.processing_header_p^.installation_defaults.
            installation_logs, installation_control_record.processing_header_p^.installation_identifier,
            ignore_status);
      mmp$delete_scratch_segment (processing_segment_pointer, local_status);
      processing_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$install_correction_command;

?? OLDTITLE ??
?? NEWTITLE := 'check_directory_presence', EJECT ??

{ PURPOSE:
{   This procedure checks for the presence fo the IDB Directory as defined
{   by the installation database path.  Bad status is returned when not
{   found.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE check_directory_presence
    (    installation_database: rat$path;
     VAR status: ost$status);


    VAR
      directory: rat$path,
      existing_file: boolean,
      ignore_attributes: array [1 .. 1] of amt$get_item,
      ignore_contains_data: boolean,
      local_file: boolean;


    status.normal := TRUE;
    ignore_attributes [1].key := amc$file_length;

    STRINGREP (directory.path, directory.size, rav$installation_defaults.installation_database.
          path (1, rav$installation_defaults.installation_database.size), '.', rac$idb_directory_name);

    amp$get_file_attributes (directory.path (1, directory.size), ignore_attributes, local_file, existing_file,
          ignore_contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (NOT local_file) AND (NOT existing_file) THEN
      osp$set_status_abnormal ('RA', rae$directory_required_for_corr, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, directory.path (1, directory.size), status);
      RETURN;
    IFEND;

  PROCEND check_directory_presence;

?? OLDTITLE ??
?? NEWTITLE := 'get_task_set', EJECT ??

{ PURPOSE:
{   This procedure returns the set of tasks to be performed on the selected
{   products.  The step set and number of steps are registered in the
{   processing header record.
{
{ DESIGN:
{   For the installation of corrections all tasks are performed except the
{   deletion of previous cycles when save_previous_cycles is true.  In
{   addition, if the installation option is deferred, the tasks to
{   activate the files, execute installer procedures and delete previous
{   cycles are removed.
{
{   Currently the number of steps to be performed relates directly to the
{   number of tasks.  That is why the number of steps is computed by
{   subtracting the number of tasks removed from processing.
{
{ NOTES:
{

  PROCEDURE get_task_set
    (    installation_option: ost$name;
         processing_header_p {input, output} : ^rat$processing_header;
     VAR installation_tasks: rat$task_selections);


{ Determine the installation step and task sets.  The '-' means to take the complement.

    IF installation_option = 'DEFERRED' THEN
      processing_header_p^.step_set := -$rat$step_selections [rac$activate_subproducts_step,
            rac$execute_installer_proc_step, rac$delete_previous_cycles_step];
      processing_header_p^.number_of_steps := rac$max_number_of_steps - 3;
      installation_tasks := - $rat$task_selections [rac$activate_files_task,
            rac$execute_installer_proc_task, rac$delete_previous_cycles_task];
    ELSE  {installation option is immedidate}
      IF processing_header_p^.save_previous_cycles THEN
        processing_header_p^.step_set := -$rat$step_selections [rac$delete_previous_cycles_step];
        processing_header_p^.number_of_steps := rac$max_number_of_steps - 1;
        installation_tasks := -$rat$task_selections [rac$delete_previous_cycles_task];
      ELSE {delete previous cycles}
        processing_header_p^.step_set := -$rat$step_selections [];
        processing_header_p^.number_of_steps := rac$max_number_of_steps;
        installation_tasks := -$rat$task_selections [];
      IFEND;
    IFEND;

  PROCEND get_task_set;
MODEND ram$install_correction_command;
*DECK DECK=RAM$INSTALL_FORTRAN_VERSION_1 EXPAND=TRUE
*DECK DECK=RAM$INSTALL_FORTRAN_VERSION_2 EXPAND=TRUE
*DECK DECK=RAM$INSTALL_NETWORK_CONFIG_FILE EXPAND=TRUE
PROCEDURE install_network_config_file (
  host_network            : string = $required
  system_id_array         : array of string = $required
  physical_data_array     : array of string = $required
  number_physical_entries : integer = $required
  defined_array           : array of string = $required
  host_name               : string = $required
  forward_search_range    : string = $required
  success                 : (var) boolean = $required
  status)

  VAR
    configuration_file: file =$local.defn
    count: integer
    cr_requested: string
    ignore: status
    local_status: status
  VAREND

  detach_file configuration_file status=ignore

  generate_defhn host_network configuration_file.$eoi
  count = 0
  FOR i = 1 TO number_physical_entries DO
    IF defined_array(i) = 'YES' THEN
      generate_defnc physical_data_array(i) system_id_array(i) ..
              configuration_file.$eoi
      count = count + 1
    IFEND
  FOREND

  IF count = 0 THEN
    put_line ('0No network configuration commands have been created.','  ')
    accept_line cr_requested input p='Press NEXT: '
    EXIT_PROC WITH $status(TRUE)
  IFEND

  IF host_name <> ' ' THEN
    generate_define_tcpip_host host_name=host_name forward_search_range=forward_search_range ..
       configuration_file=configuration_file.$eoi
  IFEND

  execute_task sp=logical_configuration_utility
    install_network_configuration i=configuration_file status=local_status
  quit

  detach_file configuration_file status=ignore

  IF local_status.normal THEN
    put_line ('0Network configuration installed.' '  ')
    accept_line cr_requested input p='Press NEXT: '
    success = TRUE
  ELSE
    display_value local_status
    put_line ('0Network configuration NOT installed.' '  ')
    accept_line cr_requested input p='Press NEXT: '
    success = FALSE
  IFEND

PROCEND install_network_config_file
*DECK DECK=RAM$INSTALL_PRODUCT_CMD_INSS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: INSTALL_PRODUCT Subcommand.' ??
MODULE ram$install_product_cmd_inss;

{ PURPOSE:
{   This module contains the command interface that installs a product.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$control_job_identifier
*copyc rat$installation_control_record
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$include_line
*copyc clp$trimmed_string_size
*copyc clp$include_line
*copyc fsp$close_file
*copyc mmp$delete_scratch_segment
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc rap$display_job_log_to_cmd_log
*copyc rap$establish_processing_cntrls
*copyc rap$init_processing_seq
*copyc rap$perform_installation_steps
*copyc rap$set_file_retention
*copyc rap$submit_batch_jobs
*copyc rap$validate_for_installation
*copyc rav$installation_defaults
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$install_product_cmd_inss', EJECT ??

{ PURPOSE:
{   This command interface installs the specified product(s), subproduct(s)
{   or group(s).
{
{ DESIGN:
{   The installation process is divided into the following major steps:
{
{     1.  RECONCILING CYCLE CONFLICTS
{     2.  LOADING THE SUBPRODUCTS
{     3.  CORRECTING THE SUBPRODUCTS
{     4.  STAGING THE SUBPRODUCTS
{     5.  ACTIVATING THE SUBPRODUCTS
{     6.  EXECUTING THE INSTALLER PROCEDURES
{     7.  UPDATING THE IDB DIRECTORY
{     8.  DELETING PREVIOUS CYCLES
{
{   When installing products using this interface, step 3 (correcting the
{   subproducts) is not performed.  Also step 8 (deleting previous cycles)
{   is optionally controlled by parameter.
{
{   The actual execution of the installation steps may cross job boundaries
{   depending on the circumstances.  By default processing is in batch.
{   This will free up the caller job (typically the console) for other
{   work.
{
{   To provide asynchronous processing more than one batch job may be used.
{   Additional processing jobs are assigned based on the number of primary
{   tapes containing subproducts to be installed (when a tape order).  Each
{   processing job is responsible for installing the subproducts that are
{   contained on their respective primary tapes.  For non-tape orders only
{   one job will be used.
{
{   A hidden option is provided to force processing to remain in the job of
{   the caller.  This also causes processing to remain serial.  This option
{   is used by the deadstart process in order to provide direct
{   communication to the operator.
{
{   The processing of any installation request is controlled by an
{   installation control record.  The installation control record contains
{   or has access to all pertainent information (including direct access to
{   information in the packing list).  The installation control record is
{   used to keep track of which TASKS are to be performed against which
{   subproducts.
{
{     NOTE:  The distinction between a step and a task is that steps
{     indicate processing at the global level, where as, tasks relate to
{     processing at the subproduct level.
{
{   The processing information is stored in segment accessed files (since
{   it must be accessable by other batch jobs).  Besides the packing list
{   (which defines the contents of the order and gives basic order
{   information), an installation control file is created to provide job
{   processing information, and a processing summary file is established to
{   provide job status feedback to the user.  The job logs from the batch
{   jobs (or current job) are (is) also written to permanent log files.
{
{   The installation control file is copied to memory by the batch jobs for
{   step/task processing.  The contents of the installation control file
{   were originally set up in memory and written to file only when batch
{   processing is performed.  While in memory it is referred to as the
{   processing sequence.
{
{   The installation control record contains pointers to the packing list,
{   the processing sequence and the job status record (in the processing
{   summary file).  It is only available to the job in which it was
{   created, and therefore must be recreated by each processing job.
{
{   The job log will be written to a permanent command log file under the
{   installation identifier catalog.  The job log is first displayed to
{   $null to set a LAST displayed mark.  After processing, the job log is
{   displayed starting from the last displayed mark.
{
{   The initial setup prior to performing the installation steps is:
{
{     1.  Flesh out the installation control record.  This includes the
{         creation of the processing sequence in memory (based on order
{         medium type and subproduct count).  The packing list is accessed
{         and the major data pointers are established.
{
{     2.  Attempt to access the IDB directory and validate the product list.
{         Assign the tasks to be performed on the associated subproducts.
{
{     3.  Assign an installation identifier, job identifiers and log file
{         names.  Establish the processing summary file.
{
{     When batch processing is performed:
{
{     4.  Write the installation control file by copying the processing
{         sequence.  Submit the batch jobs.
{
{
{ NOTES:
{   The scratch segment is used for the processing sequence and is created
{   in RAP$INIT_PROCESSING_SEQ.
{

  PROCEDURE [XDCL] rap$install_product_cmd_inss
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);
{ PROCEDURE insp_pdt (
{   packing_list, pl: name 1..16 = $required
{   product, products, p: any of
{       key
{         all
{       keyend
{       list of name
{     anyend = $required
{   exclude_product, exclude_products, ep: list of name = $optional
{   force_reinstall, fr: boolean = false
{   save_previous_cycles, spc: boolean = false
{   execute_in_job_of_caller, eijoc: (BY_NAME, HIDDEN) boolean = false
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 15] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type5: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type6: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 8, 14, 11, 7, 39, 948],
    clc$command, 15, 7, 2, 0, 1, 0, 7, ''], [
    ['EIJOC                          ',clc$abbreviation_entry, 6],
    ['EP                             ',clc$abbreviation_entry, 3],
    ['EXCLUDE_PRODUCT                ',clc$nominal_entry, 3],
    ['EXCLUDE_PRODUCTS               ',clc$alias_entry, 3],
    ['EXECUTE_IN_JOB_OF_CALLER       ',clc$nominal_entry, 6],
    ['FORCE_REINSTALL                ',clc$nominal_entry, 4],
    ['FR                             ',clc$abbreviation_entry, 4],
    ['P                              ',clc$abbreviation_entry, 2],
    ['PACKING_LIST                   ',clc$nominal_entry, 1],
    ['PL                             ',clc$abbreviation_entry, 1],
    ['PRODUCT                        ',clc$nominal_entry, 2],
    ['PRODUCTS                       ',clc$alias_entry, 2],
    ['SAVE_PREVIOUS_CYCLES           ',clc$nominal_entry, 5],
    ['SPC                            ',clc$abbreviation_entry, 5],
    ['STATUS                         ',clc$nominal_entry, 7]],
    [
{ PARAMETER 1
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 5
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 6
    [5, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 7
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, 16]],
{ PARAMETER 2
    [[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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 4
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 5
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 6
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$packing_list = 1,
      p$product = 2,
      p$exclude_product = 3,
      p$force_reinstall = 4,
      p$save_previous_cycles = 5,
      p$execute_in_job_of_caller = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;




    VAR
      ignore_status: ost$status,
      installation_control_record: rat$installation_control_record,
      installation_tasks: rat$task_selections,
      local_status: ost$status,
      multiple_job_processing: boolean,
      packing_list_fid: amt$file_identifier,
      packing_list_opened: boolean,
      processing_segment_pointer: amt$segment_pointer;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to return the processing
{   segment and packing list file when an abort condition arises.
{
{   When the processing segment pointer is not NIL, attempt to display the
{   job log to the command log.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;


      IF processing_segment_pointer.sequence_pointer <> NIL THEN
        rap$display_job_log_to_cmd_log (installation_control_record.processing_header_p^.
              installation_defaults.installation_logs, installation_control_record.processing_header_p^.
              installation_identifier, ignore_status);
        mmp$delete_scratch_segment (processing_segment_pointer, ignore_status);
        processing_segment_pointer.sequence_pointer := NIL;
      IFEND;

      fsp$close_file (packing_list_fid, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_line ('$system.display_log do=last o=$null', TRUE, osc$null_name, ignore_status);

    installation_control_record.job_identifier := rac$control_job_identifier;
    installation_control_record.job_status_record_p := NIL;

    multiple_job_processing := (NOT pvt [p$execute_in_job_of_caller].value^.boolean_value.value);

    processing_segment_pointer.kind := amc$sequence_pointer;
    processing_segment_pointer.sequence_pointer := NIL;
    packing_list_opened := FALSE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      rap$init_processing_seq (pvt [p$packing_list].value^.name_value,
            pvt [p$save_previous_cycles].value^.boolean_value.value, rac$install_product, rac$release,
            rav$installation_defaults, installation_control_record, processing_segment_pointer,
            packing_list_fid, packing_list_opened, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      get_task_set (installation_control_record.processing_header_p, installation_tasks);

      rap$validate_for_installation (pvt [p$product].value, pvt [p$exclude_product].value,
            pvt [p$force_reinstall].value^.boolean_value.value, installation_tasks,
            installation_control_record, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$establish_processing_cntrls (multiple_job_processing,
            pvt [p$execute_in_job_of_caller].value^.boolean_value.value, installation_control_record, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF pvt [p$execute_in_job_of_caller].value^.boolean_value.value THEN

        rap$perform_installation_steps (installation_control_record, status);

      ELSE {execute in batch}

        rap$submit_batch_jobs (installation_control_record, status);

      IFEND;

    END /main/;

    IF packing_list_opened THEN
      fsp$close_file (packing_list_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF processing_segment_pointer.sequence_pointer <> NIL THEN
      rap$display_job_log_to_cmd_log (installation_control_record.processing_header_p^.installation_defaults.
            installation_logs, installation_control_record.processing_header_p^.installation_identifier,
            ignore_status);
      mmp$delete_scratch_segment (processing_segment_pointer, local_status);
      processing_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$install_product_cmd_inss;

?? OLDTITLE ??
?? NEWTITLE := 'get_task_set', EJECT ??

{ PURPOSE:
{   This procedure returns the set of tasks to be performed on the selected
{   products.  The step set and step count are also established within the
{   processing header.
{
{ DESIGN:
{   For the installation of products all tasks are performed except the task
{   to correct files (always excluded) and the task to deletion of previous
{   cycles (when save_previous_cycles is true).
{
{   Currently the number of steps to be performed relates directly to the
{   number of tasks.  That is why the number of steps is computed by
{   subtracting the number of tasks removed from processing.
{
{ NOTES:
{

  PROCEDURE get_task_set
    (    processing_header_p {input, output} : ^rat$processing_header;
     VAR installation_tasks: rat$task_selections);


    { Determine the installation task and step sets.  The '-' means to take the complement.

    IF processing_header_p^.save_previous_cycles THEN
      processing_header_p^.number_of_steps := rac$max_number_of_steps - 2;
      processing_header_p^.step_set := -$rat$step_selections [rac$correct_subproducts_step,
            rac$delete_previous_cycles_step];
      installation_tasks := -$rat$task_selections [rac$correct_files_task, rac$delete_previous_cycles_task];
    ELSE {delete previous cycles}
      processing_header_p^.number_of_steps := rac$max_number_of_steps - 1;
      processing_header_p^.step_set := -$rat$step_selections [rac$correct_subproducts_step];
      installation_tasks := -$rat$task_selections [rac$correct_files_task];
    IFEND;

  PROCEND get_task_set;
MODEND ram$install_product_cmd_inss;
*DECK DECK=RAM$INSTALL_SOFTWARE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE UTILITY: INSTALL_SOFTWARE Utility Command.' ??
MODULE ram$install_software;

{ PURPOSE:
{   This module contains the command interface to set up and control the
{   software installation process.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rat$installation_defaults
?? POP ??
*copyc clp$begin_utility
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    rav$inss_utility_name: [XDCL] clt$utility_name := 'INSTALL_SOFTWARE';

?? FMT (FORMAT := OFF) ??

  VAR
    rav$installation_defaults: [XDCL] rat$installation_defaults := [
          {correction_bases}      [54, ':$SYSTEM.$SYSTEM.SOFTWARE_MAINTENANCE.CORRECTION_BASES'],
          {correction_packages}   [57, ':$SYSTEM.$SYSTEM.SOFTWARE_MAINTENANCE.CORRECTION_PACKAGES'],
          {installation_database} [59, ':$SYSTEM.$SYSTEM.SOFTWARE_MAINTENANCE.INSTALLATION_DATABASE'],
          {installation_logs}     [55, ':$SYSTEM.$SYSTEM.SOFTWARE_MAINTENANCE.INSTALLATION_LOGS'],
          {system_catalog}        [0, ''],
          {ignore_storage_class}  FALSE,
          {relax_ring_settings}   FALSE];

?? FMT (FORMAT := ON) ??

?? TITLE := '[XDCL] rap$install_software', EJECT ??

{ PURPOSE:
{   This command interface sets up the INSTALL_SOFTWARE utility
{   session.
{
{ DESIGN:
{   This follows standard utility design.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$install_software
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE inss_pdt (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 5, 2, 14, 51, 41, 64], clc$command, 1, 1, 0, 0, 0, 0, 1, 'INSS_PDT'],
            [['STATUS                         ', clc$nominal_entry, 1]], [
{ PARAMETER 1
      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

{ table n=inss_command_table t=command s=xdcl
{ command n=(activate_product, activate_products, actp) p=rap$activate_product_command cm=xref a=hidden
{ command n=(apply_all_corrections, appac)  p=rap$apply_all_corrections_cmd cm=xref
{ command n=(change_installation_defaults, change_installation_default, chaid)                            ..
{               p=rap$change_installation_default cm=xref
{ command n=(change_installation_path, chaip) p=rap$change_installation_path cm=xref
{ command n=(delete_packing_list, delpl) p=rap$delete_packing_list cm=xref
{ command n=(display_installed_software, disis) p=rap$display_installed_software cm=xref
{ command n=(display_packing_list, displ) p=rap$display_packing_list_inss cm=xref
{ command n=(display_processing_summary, disps) p=rap$display_process_summary cm=xref a=hidden
{ command n=(execute_installer_procedure, exeip) p=rap$execute_installer_procs_cmd cm=xref a=hidden
{ command n=(install_correction, install_corrections, insc) p=rap$install_correction_command cm=xref
{ command n=(install_product, install_products, insp) p=rap$install_product_cmd_inss cm=xref
{ command n=(load_packing_list, loapl) p=rap$load_packing_list_inss_cmd cm=xref
{ command n=(quit, qui) p=rap$quit_inss cm=xref
{ command n=(rap$perform_installation) p=rap$perform_installation cm=xref a=hidden
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  inss_command_table: [XDCL, READ] ^clt$command_table := ^inss_command_table_entries,

  inss_command_table_entries: [STATIC, READ] array [1 .. 31] of clt$command_table_entry := [
  {} ['ACTIVATE_PRODUCT               ', clc$nominal_entry, clc$hidden_entry, 1,
        clc$automatically_log, clc$linked_call, ^rap$activate_product_command],
  {} ['ACTIVATE_PRODUCTS              ', clc$alias_entry, clc$hidden_entry, 1, clc$automatically_log,
        clc$linked_call, ^rap$activate_product_command],
  {} ['ACTP                           ', clc$abbreviation_entry, clc$hidden_entry, 1,
        clc$automatically_log, clc$linked_call, ^rap$activate_product_command],
  {} ['APPAC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^rap$apply_all_corrections_cmd],
  {} ['APPLY_ALL_CORRECTIONS          ', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^rap$apply_all_corrections_cmd],
  {} ['CHAID                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$change_installation_default],
  {} ['CHAIP                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^rap$change_installation_path],
  {} ['CHANGE_INSTALLATION_DEFAULT    ', clc$alias_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$change_installation_default],
  {} ['CHANGE_INSTALLATION_DEFAULTS   ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$change_installation_default],
  {} ['CHANGE_INSTALLATION_PATH       ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^rap$change_installation_path],
  {} ['DELETE_PACKING_LIST            ', clc$nominal_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^rap$delete_packing_list],
  {} ['DELPL                          ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^rap$delete_packing_list],
  {} ['DISIS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^rap$display_installed_software],
  {} ['DISPL                          ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^rap$display_packing_list_inss],
  {} ['DISPLAY_INSTALLED_SOFTWARE     ', clc$nominal_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^rap$display_installed_software],
  {} ['DISPLAY_PACKING_LIST           ', clc$nominal_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^rap$display_packing_list_inss],
  {} ['DISPLAY_PROCESSING_SUMMARY     ', clc$nominal_entry, clc$hidden_entry, 8,
        clc$automatically_log, clc$linked_call, ^rap$display_process_summary],
  {} ['DISPS                          ', clc$abbreviation_entry, clc$hidden_entry, 8,
        clc$automatically_log, clc$linked_call, ^rap$display_process_summary],
  {} ['EXECUTE_INSTALLER_PROCEDURE    ', clc$nominal_entry, clc$hidden_entry, 9,
        clc$automatically_log, clc$linked_call, ^rap$execute_installer_procs_cmd],
  {} ['EXEIP                          ', clc$abbreviation_entry, clc$hidden_entry, 9,
        clc$automatically_log, clc$linked_call, ^rap$execute_installer_procs_cmd],
  {} ['INSC                           ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^rap$install_correction_command],
  {} ['INSP                           ', clc$abbreviation_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^rap$install_product_cmd_inss],
  {} ['INSTALL_CORRECTION             ', clc$nominal_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^rap$install_correction_command],
  {} ['INSTALL_CORRECTIONS            ', clc$alias_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^rap$install_correction_command],
  {} ['INSTALL_PRODUCT                ', clc$nominal_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^rap$install_product_cmd_inss],
  {} ['INSTALL_PRODUCTS               ', clc$alias_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^rap$install_product_cmd_inss],
  {} ['LOAD_PACKING_LIST              ', clc$nominal_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^rap$load_packing_list_inss_cmd],
  {} ['LOAPL                          ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^rap$load_packing_list_inss_cmd],
  {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^rap$quit_inss],
  {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^rap$quit_inss],
  {} ['RAP$PERFORM_INSTALLATION       ', clc$nominal_entry, clc$hidden_entry, 14,
        clc$automatically_log, clc$linked_call, ^rap$perform_installation]];

  PROCEDURE [XREF] rap$activate_product_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$apply_all_corrections_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$change_installation_default
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$change_installation_path
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$delete_packing_list
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$display_installed_software
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$display_packing_list_inss
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$display_process_summary
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$execute_installer_procs_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$install_correction_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$install_product_cmd_inss
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$load_packing_list_inss_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$perform_installation
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$quit_inss
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??

{ table inss_function_table t=function s=xdcl
{ function n=$deferred_subproducts p=rap$deferred_subproducts_func cm=xref a=hidden
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  inss_function_table: [XDCL, READ] ^clt$function_processor_table := ^inss_function_table_entries,

  inss_function_table_entries: [STATIC, READ] array [1 .. 1] of clt$function_proc_table_entry := [
  {} ['$DEFERRED_SUBPRODUCTS          ', clc$nominal_entry, clc$hidden_entry, 1, clc$linked_call,
        ^rap$deferred_subproducts_func]];

  PROCEDURE [XREF] rap$deferred_subproducts_func
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? POP ??

    CONST
      prompt_size = 4,
      prompt_value = 'INSS';

    VAR
      utility_attributes_p: ^clt$utility_attributes;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH utility_attributes_p: [1 .. 4];
    utility_attributes_p^ [1].key := clc$utility_command_search_mode;
    utility_attributes_p^ [1].command_search_mode := clc$global_command_search;
    utility_attributes_p^ [2].key := clc$utility_command_table;
    utility_attributes_p^ [2].command_table := inss_command_table;
    utility_attributes_p^ [3].key := clc$utility_function_proc_table;
    utility_attributes_p^ [3].function_processor_table := inss_function_table;
    utility_attributes_p^ [4].key := clc$utility_prompt;
    utility_attributes_p^ [4].prompt.size := prompt_size;
    utility_attributes_p^ [4].prompt.value := prompt_value;

    clp$begin_utility (rav$inss_utility_name, utility_attributes_p^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, prompt_value, rav$inss_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (rav$inss_utility_name, status);

  PROCEND rap$install_software;
MODEND ram$install_software;
*DECK DECK=RAM$INSTALL_SOFTWARE_PD EXPAND=TRUE
create_program_description (install_software, inss) ..
 sp=rap$install_software l=$system.software_maintenance.raf$library
*DECK DECK=RAM$INSTALL_TCPIP_ROUTING EXPAND=TRUE
create_program_description (INSTALL_TCPIP_ROUTING, INSTR) l='$system.osf$system_library'..
      sp=nap$install_tcpip_routing lm=$null lmo=none tel=warning dm=off

*DECK DECK=RAM$INSTALL_TCPIP_STATIC_ROUTES EXPAND=TRUE
create_program_description (INSTALL_TCPIP_STATIC_ROUTES, INSTALL_TCPIP_STATIC_ROUTE, INSTSR) ..
      l='$system.osf$system_library' sp=nap$install_tcpip_static_routes lm=$null lmo=none tel=warning dm=off

*DECK DECK=RAM$INST_TAPE_MENU$US_ENGLISH EXPAND=TRUE
CREATE_MESSAGE_MODULE install_tape_menu$us_english

CREATE_brief_help_message
+X2+N0This display shows your current installation parameters, you may
 change them, enter GO to accept them, or enter QUIT if
 you do not wish to proceed with the installation.
+N+X2
**

CREATE_FULL_HELP_MESSAGE
+N0This menu asks you for information necessary to install an installation
 tape.  You must:
+N1 a. Identify the tape by supplying VSN and type information,
+N1 b. Supply the name to use for the packing list from the tape,
+N1 c. Indicate if you want to keep old copies of the software which is
+N5being installed.
+N0To get general help for a particular selection, enter the number
 of the selection, followed by a question mark.
 For example, to get help for selection 1, you would enter:
+N+X2
+N2 1?
+N+X2
+N0Detailed help for each item is available at the prompt for each item.
+N+X2
**

CREATE_PARAMETER_PROMPT_MESSAGE n=packing_list
+X2+P1.+X2Name to assign the packing list ........... +P2
**

CREATE_PARAMETER_PROMPT_MESSAGE n=external_vsn
+X2+P1.+X2External VSN of the installation tape .....'+P3'
**

CREATE_PARAMETER_PROMPT_MESSAGE n=recorded_vsn
+X2+P1.+X2Recorded VSN of the installation tape .....'+P4'
**

CREATE_PARAMETER_PROMPT_MESSAGE n=tape_type
+X2+P1.+X2Type of the installation tape ............. +P5
**

CREATE_PARAMETER_PROMPT_MESSAGE n=save_previous_cycles
+X2+P1.+X2Save previous file cycles ................. +P6
**

CREATE_PARAMETER_PROMPT_MESSAGE n=prompt
+X2+N0Enter a menu selection, GO, QUIT, or ? for HELP.
**

CREATE_PARAMETER_HELP_MESSAGE n=packing_list
+X2+N0The installation tape contains a packing list which describes
 the contents of each tape in your order.+X2This prompt asks for a name
 to assign the packing list when it is loaded from the installation tape
 and stored on disk.+X2The packing list is stored in the installation
 data base catalog managed by the INSTALL_SOFTWARE utility.
+N+X2
**

CREATE_PARAMETER_HELP_MESSAGE n=external_vsn
+X2+N0The external VSN, along with the recorded VSN, are used to request
 the installation tape.+X2Tapes manufactured
 by Software Manufacturing and Distribution (SMD) show the external
 VSN in the media number field of the tape sticker.+X2The installation tape
 will contain the identifier 'FULL/PACKING LIST' in the name field of the
 tape sticker.
+N+X2
**

CREATE_PARAMETER_HELP_MESSAGE n=recorded_vsn
+X2+N0The recorded VSN, along with the external VSN are used to request
 the installation tape.+X2Tapes manufactured
 by Software Manufacturing and Distribution (SMD) use the same
 same external and recorded VSN's.+X2The recorded VSN is often referred
 to as an internal VSN.
+N+X2
**
CREATE_PARAMETER_HELP_MESSAGE n=tape_type
+X2+N0The tape type signifies the the density and the device class for the
 installation tape.+X2Tapes manufactured
 by Software Manufacturing and Distribution (SMD) show the density
 in the density field of the tape sticker.+X2The installation tape
 will contain the identifier 'FULL/PACKING LIST' in the name field of the
 tape sticker.+X2If the density is listed as 1600 bpi or 6250 bpi,
 the device class is 9 track and the tape type would be designated as
 MT9$1600 or MT9$6250, respectively.+X2If the density is listed as 38000
 bpi, the device class is 18 track and the tape type would be designated
 as MT18$38000.  The default is MT9$6250.
+N+X2
**

CREATE_PARAMETER_HELP_MESSAGE n=save_previous_cycles
+X2+N0You may choose to save the previous cycles of
 files that are being installed or have them deleted.+X2Having the files
 deleted will conserve approximately 40 million bytes of disk space on
 your system.
+N0If you are installing your NOS/VE system for the first time, this
 option has no effect on your system's file space.
+N+X2
**

CREATE_PARAMETER_PROMPT_MESSAGE n=packing_list_prompt
Enter the name to assign the packing list or ? for help.
**

CREATE_PARAMETER_HELP_MESSAGE n=packing_list_prompt
+X2+N0The packing list name must have from 1 to 16 characters
 and be a valid SCL name, ie. start with a letter.+X2A typical value for the
 packing list name is the NOS/VE release level.+X2Note that
 the name supplied must not already be in use in the installation
 data base catalog where the packing list will be stored, unless
 prior to upgrading, you loaded the packing list to installed the
 PRE_INSTALL_SW product.+X2In that case, you may use the same packing
 list name again.+X2(This will be checked for you.)
+N+X2
**

CREATE_PARAMETER_PROMPT_MESSAGE n=external_vsn_prompt
Enter the external VSN of the installation tape or ? for help.
**

CREATE_PARAMETER_HELP_MESSAGE n=external_vsn_prompt
+X2+N0The external VSN must have from 1 to 6 characters and be
 a valid NOS/VE tape VSN.+X2Put single quotes around your entry.
+X2Tapes manufactured
 by Software Manufacturing and Distribution (SMD) show the
 VSN in the media number field of the tape sticker.
+N+X2
**

CREATE_PARAMETER_PROMPT_MESSAGE n=recorded_vsn_prompt
Enter the recorded VSN of the installation tape or ? for help.
**

CREATE_PARAMETER_HELP_MESSAGE n=recorded_vsn_prompt
+X2+N0The recorded VSN must have from 1 to 6 characters and be
 a valid NOS/VE tape VSN.+X2Put single quotes around your entry.
+X2Tapes manufactured
 by Software Manufacturing and Distribution (SMD) use the same recorded
 and external VSN's.+X2The recorded VSN is often referred to as an
 internal VSN.
+N+X2
**

CREATE_PARAMETER_PROMPT_MESSAGE n=tape_type_prompt
Select type:
+N0+X3a.+X2MT9$1600
+N0+X3b.+X2MT9$6250
+N0+X3c.+X2MT18$38000
+N0Enter selection or ? for help.
**

CREATE_PARAMETER_HELP_MESSAGE n=tape_type_prompt
+X2+N0When selecting the tape type, you may enter either the selection
 identifier (a, b, c) or the tape type designator (mt9$1600, mt9$6250,
 mt18$38000).
+N+N0Tapes manufactured
 by Software Manufacturing and Distribution (SMD) show the density
 in the density field of the tape sticker.+X2The installation tape
 will contain the identifier 'FULL/PACKING LIST' in the name field of the
 tape sticker.+X2If the density is listed as 1600 bpi or 6250 bpi,
 the device class is 9 track and the tape type would be designated as
 MT9$1600 or MT9$6250, respectively.+X2If the density is listed as 38000
 bpi, the device class is 18 track and the tape type would be designated
 as MT18$38000.  The default is MT9$6250.
+N+X2
**

CREATE_PARAMETER_PROMPT_MESSAGE n=save_previous_cycles_prompt
Do you want to save previous file cycles of the software?+N0Enter True,
 False, or ? for help.
**

create_parameter_help_message  n=save_previous_cycles_prompt
+X2+N0If you would like to save the previous cycles of
 files that are being installed, enter TRUE.+X2If you would like the
 installation to delete the previous cycles, enter FALSE.+X2By
 entering FALSE, the installation will conserve
 disk space by deleting all but the HIGH cycle of the files being
 installed.
+N+X2
**
END_MESSAGE_MODULE
*DECK DECK=RAM$INTERACTIVE_EXECUTIVE EXPAND=TRUE
PROC interactive_executive, ifexec (status)

  VAR
    attempts: integer = 0
    ignore_status: status
    proc_status: status
  VAREND
  define_system_task name=ifexec sp=ifexec automatic_restart=TRUE ..
        deactivate_task_option=terminate idle_task_option=ignore restart_after_idle=TRUE ..
        spy_identifier=50 l=($system.osf$operator_library osf$task_services_library) ..
        tel=warning lm=$null lmo=none status=proc_status
  IF NOT proc_status.normal THEN
    IF $condition(proc_status.condition) <> 'OSE$SYSTEM_TASK_ALREADY_DEFINED' THEN
      EXIT_PROC WITH proc_status
    IFEND
  IFEND
  deactivate_system_task task_name=ifexec status=ignore_status

  put_line ' KLUDGE to prevent amp$copy from failing' o=$local.console

  REPEAT
    activate_system_task task_name=ifexec status=proc_status
    IF NOT proc_status.normal THEN
      IF $condition(proc_status.condition) = 'OSE$SYSTEM_TASK_STILL_RUNNING' THEN

" Wait for 5 seconds and recheck the status. Do this for up to 2 minutes,
" to allow the task to deactivate before attempting to activate it.

        attempts = attempts + 1
        wait 5000
      ELSE
        EXIT_PROC with proc_status
      IFEND
    IFEND
  UNTIL (proc_status.normal) OR (attempts > 24)
  EXIT_PROC with proc_status

PROCEND interactive_executive
*DECK DECK=RAM$INTERVENE_IN_DEADSTART EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$intervene_in_deadstart;

*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$put_job_output
*copyc clp$scan_command_file
*copyc oss$job_paged_literal

?? POP ??

*copyc rah$intervene_in_deadstart

  VAR
    rav$intervene_in_deadstart_name: [XDCL, READ, oss$job_paged_literal] ost$name := 'INTERVENE_IN_DEADSTART';

  PROCEDURE [XDCL, #GATE] rap$intervene_in_deadstart
    (VAR status: ost$status);

    VAR
      i: 1 .. 4,
      lines: [STATIC, READ, oss$job_paged_literal] array [1 .. 4] of string (79) :=
            ['                                                                    ',
            ' At this point in the deadstart process you are given the           ',
            ' opportunity to intervene by entering any of the available commands.',
            ' Enter GO to continue.                                              '];

{ table intervene_commands s=xdcl
{ command (go) p=rap$go cm=xref

?? PUSH (LISTEXT := ON) ??

    VAR
      intervene_commands: [XDCL, READ, oss$job_paged_literal] ^clt$command_table :=
            ^intervene_commands_entries,

      intervene_commands_entries: [STATIC, READ, oss$job_paged_literal] array [1 .. 1] of
            clt$command_table_entry := [
            {} ['GO                             ', clc$nominal_entry, clc$advertised_entry, 1,
            clc$automatically_log, clc$linked_call, ^rap$go]];

    PROCEDURE [XREF] rap$go
      (    parameter_list: clt$parameter_list;
       VAR status: ost$status);

?? POP ??

    FOR i := 1 TO 4 DO
      clp$put_job_output (lines [i], status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    clp$push_utility (rav$intervene_in_deadstart_name, clc$global_command_search, intervene_commands, NIL,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_command_file (clc$job_command_input, rav$intervene_in_deadstart_name, 'int', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$pop_utility (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$intervene_in_deadstart;
MODEND ram$intervene_in_deadstart
*DECK DECK=RAM$ISOLATE_FILE_DIFFERENCES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE ram$isolate_file_differences;
?? PUSH (LISTEXT := ON) ??
*copyc rae$error_messages
*copyc oct$fill_sequence
*copyc rat$open_file_list
*copyc rat$correction_package
*copyc amp$open
*copyc amp$get_segment_pointer
*copyc amp$close
*copyc osp$set_status_abnormal
?? POP ??

*copyc rah$isolate_file_differences

  PROCEDURE [XDCL] rap$isolate_file_differences (old_file_name: amt$local_file_name;
        new_file_name: amt$local_file_name;
    VAR corrector: ^SEQ ( * );
    VAR size: rat$corrector_size;
    VAR status: ost$status);

    VAR
      access_sel: amt$file_access_selections,
      correction: ^SEQ ( * ),
      i: integer,
      found: boolean,
      match: boolean,
      new_fid: amt$file_identifier,
      new_proc: amt$segment_pointer,
      new_proc_fill: ^oct$fill_sequence,
      new_size: integer,
      old_fid: amt$file_identifier,
      old_proc: amt$segment_pointer,
      old_proc_fill: ^oct$fill_sequence,
      old_size: integer,
      rav$open_file_list: [STATIC, XREF] rat$open_file_list;

    status.normal := TRUE;

    PUSH access_sel: [1 .. 1];
    access_sel^ [1].key := amc$access_mode;
    access_sel^ [1].access_mode := $pft$usage_selections [pfc$read];

    amp$open (old_file_name, amc$segment, access_sel, old_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    found := FALSE;
    i := 1;
    WHILE (i <= UPPERBOUND (rav$open_file_list)) AND NOT found DO
      IF rav$open_file_list [i].name = old_file_name THEN
        rav$open_file_list [i].identifier := old_fid;
        rav$open_file_list [i].opened := TRUE;
        found := TRUE;
      IFEND;
      i := i + 1;
    WHILEND;

    IF NOT found THEN
      i := 1;
      WHILE (i <= UPPERBOUND (rav$open_file_list)) AND NOT found DO
        IF rav$open_file_list [i].name = osc$null_name THEN
          rav$open_file_list [i].name := old_file_name;
          rav$open_file_list [i].identifier := old_fid;
          rav$open_file_list [i].opened := TRUE;
          found := TRUE;
        IFEND;
        i := i + 1;
      WHILEND;
    IFEND;
    IF NOT found THEN
      osp$set_status_abnormal ('RA', rae$open_file_list_full, '', status);
      RETURN;
    IFEND;

    amp$get_segment_pointer (old_fid, amc$sequence_pointer, old_proc, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (new_file_name, amc$segment, access_sel, new_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    found := FALSE;
    i := 1;
    WHILE (i <= UPPERBOUND (rav$open_file_list)) AND NOT found DO
      IF rav$open_file_list [i].name = new_file_name THEN
        rav$open_file_list [i].identifier := new_fid;
        rav$open_file_list [i].opened := TRUE;
        found := TRUE;
      IFEND;
      i := i + 1;
    WHILEND;

    IF NOT found THEN
      i := 1;
      WHILE (i <= UPPERBOUND (rav$open_file_list)) AND NOT found DO
        IF rav$open_file_list [i].name = osc$null_name THEN
          rav$open_file_list [i].name := new_file_name;
          rav$open_file_list [i].identifier := new_fid;
          rav$open_file_list [i].opened := TRUE;
          found := TRUE;
        IFEND;
        i := i + 1;
      WHILEND;
    IFEND;
    IF NOT found THEN
      osp$set_status_abnormal ('RA', rae$open_file_list_full, '', status);
      RETURN;
    IFEND;

    amp$get_segment_pointer (new_fid, amc$sequence_pointer, new_proc, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    old_size := #SIZE (old_proc.sequence_pointer^);
    new_size := #SIZE (new_proc.sequence_pointer^);

    match := FALSE;

    IF old_size = new_size THEN
      RESET old_proc.sequence_pointer;
      RESET new_proc.sequence_pointer;
      NEXT old_proc_fill: [1 .. old_size] IN old_proc.sequence_pointer;
      NEXT new_proc_fill: [1 .. new_size] IN new_proc.sequence_pointer;
      match := TRUE;

    /compare_procs/
      FOR i := 1 TO old_size DO
        IF (old_proc_fill^ [i] <> new_proc_fill^ [i]) THEN
          match := FALSE;
          EXIT /compare_procs/
        IFEND;
      FOREND /compare_procs/;
    IFEND;

    IF match THEN
      size := 0;
    ELSE
      RESET corrector;
      NEXT correction: [[REP new_size OF cell]] IN corrector;
      correction^ := new_proc.sequence_pointer^;
      size := new_size;
    IFEND;

    amp$close (old_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    found := FALSE;
    i := 1;
    WHILE (i <= UPPERBOUND (rav$open_file_list)) AND NOT found DO
      IF rav$open_file_list [i].name = old_file_name THEN
        rav$open_file_list [i].opened := FALSE;
        found := TRUE;
      IFEND;
      i := i + 1;
    WHILEND;

    amp$close (new_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    found := FALSE;
    i := 1;
    WHILE (i <= UPPERBOUND (rav$open_file_list)) AND NOT found DO
      IF rav$open_file_list [i].name = new_file_name THEN
        rav$open_file_list [i].opened := FALSE;
        found := TRUE;
      IFEND;
      i := i + 1;
    WHILEND;
  PROCEND rap$isolate_file_differences;
MODEND ram$isolate_file_differences;
*DECK DECK=RAM$ISOLATE_ISAM_DIFFERENCES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE ram$isolate_isam_differences;
?? PUSH (LISTEXT := ON) ??
*copyc clt$path_name
*copyc rat$correction_package
*copyc rat$write_scl_commands
*copyc amp$close
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$put_next
*copyc amp$return
*copyc clp$scan_command_line
*copyc pmp$get_unique_name
*copyc rap$line_length

?? POP ??

*copyc rah$isolate_isam_differences

  PROCEDURE [XDCL] rap$isolate_isam_differences (old_file: clt$path_name;
        new_file: clt$path_name;
    VAR corrector: ^SEQ ( * );
    VAR size: rat$corrector_size;
    VAR status: ost$status);

    CONST
      number_of_commands = 11;

    VAR
      access_sel: amt$file_access_selections,
      ba: amt$file_byte_address,
      command: array [1 .. number_of_commands] of rat$write_scl_commands,
      command_fid: amt$file_identifier,
      command_file: ost$name,
      correction: ^SEQ ( * ),
      i: 1 .. number_of_commands + 1,
      ignore_status: ost$status,
      length: integer,
      new_length: integer,
      old_length: integer,
      temp_correction_fid: amt$file_identifier,
      temp_correction_file: ost$name,
      temp_correction: amt$segment_pointer,
      text: string (osc$max_string_size);



    status.normal := TRUE;

    pmp$get_unique_name (temp_correction_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_unique_name (command_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (command_file, amc$record, NIL, command_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    old_length := rap$line_length (old_file);
    new_length := rap$line_length (new_file);

    STRINGREP (command [1].command, command [1].size,
      ' IF $variable(compare_status, declared) <> ''LOCAL'' THEN');
    STRINGREP (command [2].command, command [2].size, '   create_variable compare_status k=status');
    STRINGREP (command [3].command, command [3].size, ' IFEND');
    STRINGREP (command [4].command, command [4].size, ' old_file = ''', old_file (1, old_length), '''');
    STRINGREP (command [5].command, command [5].size, ' new_file = ''', new_file (1, new_length), '''');
    STRINGREP (command [6].command, command [6].size, ' compare_file f=$fname(old_file)',
      ' w=$fname(new_file) o=$null status=compare_status');
    STRINGREP (command [7].command, command [7].size, ' IF NOT compare_status.normal THEN');
    STRINGREP (command [8].command, command [8].size, '   backup_permanent_file bf=', temp_correction_file,
          ' l=$null');
    STRINGREP (command [9].command, command [9].size, '   backup_file f=$fname(new_file)');
    STRINGREP (command [10].command, command [10].size, '   quit');
    STRINGREP (command [11].command, command [11].size, ' IFEND');

    FOR i := 1 TO number_of_commands DO
      amp$put_next (command_fid, ^command [i].command, command [i].size, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    amp$close (command_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (text, length, ' include_file f=', command_file);
    clp$scan_command_line (text (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$return (command_file, ignore_status);

    PUSH access_sel: [1 .. 2];
    access_sel^ [1].key := amc$access_mode;
    access_sel^ [1].access_mode := $pft$usage_selections [pfc$read];
    access_sel^ [2].key := amc$return_option;
    access_sel^ [2].return_option := amc$return_at_close;

    amp$open (temp_correction_file, amc$segment, access_sel, temp_correction_fid, status);
    IF NOT status.normal THEN
      IF status.condition = ame$new_file_requires_append THEN
        { No correction generated files compared. }
        size := 0;
        status.normal := TRUE;
      IFEND;
      RETURN;
    IFEND;

    amp$get_segment_pointer (temp_correction_fid, amc$sequence_pointer, temp_correction, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    size := #SIZE (temp_correction.sequence_pointer^);

    IF size <> 0 THEN
      RESET temp_correction.sequence_pointer;
      RESET corrector;
      NEXT correction: [[REP size OF cell]] IN corrector;
      correction^ := temp_correction.sequence_pointer^;
    IFEND;

    amp$close (temp_correction_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$isolate_isam_differences;
MODEND ram$isolate_isam_differences;
*DECK DECK=RAM$ISOLATE_SOURCE_CHANGES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE ram$isolate_source_changes;
?? PUSH (LISTEXT := ON) ??
*copyc rae$error_messages
*copyc rat$match_decks
*copyc rat$source_lib_correction_hdr
*copyc rat$open_file_list
*copyc amp$open
*copyc amp$get_next
*copyc amp$get_segment_pointer
*copyc amp$close
*copyc i#move
*copyc ocp$checksum
*copyc osp$set_status_abnormal
*copyc pmp$get_unique_name
*copyc rap$bin_search
*copyc rap$build_replacement_sl
*copyc rap$compare_sl_decks
*copyc rap$get_deck_list
?? POP ??

*copyc rah$isolate_source_changes

  PROCEDURE [XDCL] rap$isolate_source_changes (old_file: rat$file_values;
        new_file: rat$file_values;
    VAR corrector: ^SEQ ( * );
    VAR size: rat$corrector_size;
    VAR status: ost$status);

    VAR
      access_sel1: amt$file_access_selections,
      access_sel2: amt$file_access_selections,
      ba: amt$file_byte_address,
      correction_header: ^rat$source_lib_correction_hdr,
      d_decks: ^array [1 .. * ] of ost$name,
      decks_dont_differ: boolean,
      decks_ok: ^array [1 .. * ] of ost$name,
      delete_decks: ^array [1 .. * ] of ost$name,
      file_p: amt$file_position,
      file_ref: clt$file_reference,
      found: boolean,
      i: rat$deck_index,
      i_decks: ^array [1 .. * ] of ost$name,
      insert_decks: ^array [1 .. * ] of ost$name,
      j: rat$deck_index,
      k: rat$deck_index,
      l: integer,
      new_array: ^rat$match_decks,
      new_checksum: integer,
      new_fid: amt$file_identifier,
      new_name: ost$name,
      new_seg: amt$segment_pointer,
      old_array: ^rat$match_decks,
      old_checksum: integer,
      old_fid: amt$file_identifier,
      old_file_ref: clt$file_reference,
      old_name: ost$name,
      old_seg: amt$segment_pointer,
      rav$open_file_list: [STATIC, XREF] rat$open_file_list,
      repl_fid: amt$file_identifier,
      repl_sl: amt$segment_pointer,
      replacement: ^SEQ ( * ),
      replace_sl: ost$name,
      size_wsa: integer,
      temp: ost$name,
      temp_array: ^array [1 .. * ] of ost$name,
      transfer_count: amt$transfer_count;


    status.normal := TRUE;

    PUSH access_sel1: [1 .. 1];
    access_sel1^ [1].key := amc$access_mode;
    access_sel1^ [1].access_mode := $pft$usage_selections [pfc$read];

    amp$open (old_file.lfn, amc$segment, access_sel1, old_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    found := FALSE;
    l := 1;
    WHILE (l <= UPPERBOUND (rav$open_file_list)) AND NOT found DO
      IF rav$open_file_list [l].name = old_file.lfn THEN
        rav$open_file_list [l].identifier := old_fid;
        rav$open_file_list [l].opened := TRUE;
        found := TRUE;
      IFEND;
      l := l + 1;
    WHILEND;

    IF NOT found THEN
      l := 1;
      WHILE (l <= UPPERBOUND (rav$open_file_list)) AND NOT found DO
        IF rav$open_file_list [l].name = osc$null_name THEN
          rav$open_file_list [l].name := old_file.lfn;
          rav$open_file_list [l].identifier := old_fid;
          rav$open_file_list [l].opened := TRUE;
          found := TRUE;
        IFEND;
        l := l + 1;
      WHILEND;
    IFEND;
    IF NOT found THEN
      osp$set_status_abnormal ('RA', rae$open_file_list_full, '', status);
      RETURN;
    IFEND;

    amp$open (new_file.lfn, amc$segment, access_sel1, new_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    found := FALSE;
    l := 1;
    WHILE (l <= UPPERBOUND (rav$open_file_list)) AND NOT found DO
      IF rav$open_file_list [l].name = new_file.lfn THEN
        rav$open_file_list [l].identifier := new_fid;
        rav$open_file_list [l].opened := TRUE;
        found := TRUE;
      IFEND;
      l := l + 1;
    WHILEND;

    IF NOT found THEN
      l := 1;
      WHILE (l <= UPPERBOUND (rav$open_file_list)) AND NOT found DO
        IF rav$open_file_list [l].name = osc$null_name THEN
          rav$open_file_list [l].name := new_file.lfn;
          rav$open_file_list [l].identifier := new_fid;
          rav$open_file_list [l].opened := TRUE;
          found := TRUE;
        IFEND;
        l := l + 1;
      WHILEND;
    IFEND;
    IF NOT found THEN
      osp$set_status_abnormal ('RA', rae$open_file_list_full, '', status);
      RETURN;
    IFEND;

    amp$get_segment_pointer (old_fid, amc$sequence_pointer, old_seg, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (new_fid, amc$sequence_pointer, new_seg, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    old_checksum := ocp$checksum (old_seg.sequence_pointer);
    new_checksum := ocp$checksum (new_seg.sequence_pointer);

    amp$close (old_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    found := FALSE;
    l := 1;
    WHILE (l <= UPPERBOUND (rav$open_file_list)) AND NOT found DO
      IF rav$open_file_list [l].name = old_file.lfn THEN
        rav$open_file_list [l].opened := FALSE;
        found := TRUE;
      IFEND;
      l := l + 1;
    WHILEND;

    amp$close (new_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    found := FALSE;
    l := 1;
    WHILE (l <= UPPERBOUND (rav$open_file_list)) AND NOT found DO
      IF rav$open_file_list [l].name = new_file.lfn THEN
        rav$open_file_list [l].opened := FALSE;
        found := TRUE;
      IFEND;
      l := l + 1;
    WHILEND;

    IF old_checksum = new_checksum THEN
      size := 0;
      RETURN;
    IFEND;


    pmp$get_unique_name (old_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$get_deck_list (old_file.ref.path_name, old_file.ref.path_name_size, old_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    pmp$get_unique_name (new_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$get_deck_list (new_file.ref.path_name, new_file.ref.path_name_size, new_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH access_sel1: [1 .. 1];
    access_sel1^ [1].key := amc$access_mode;
    access_sel1^ [1].access_mode := $pft$usage_selections [pfc$read];

    amp$open (old_name, amc$record, access_sel1, old_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$open (new_name, amc$record, access_sel1, new_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE temp_array: [1 .. 0fff(16)];
    size_wsa := #SIZE (temp);

    amp$get_next (old_fid, ^temp, size_wsa, transfer_count, ba, file_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    temp_array^ [1] := temp (1, transfer_count);

    i := 2;
    WHILE file_p <> amc$eoi DO
      amp$get_next (old_fid, ^temp, size_wsa, transfer_count, ba, file_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      temp_array^ [i] := temp (1, transfer_count);
      i := i + 1;
    WHILEND;
    IF (i - 2) < 1 THEN
      old_array := NIL;
    ELSE
      PUSH old_array: [1 .. (i - 2)];
    IFEND;
    FOR j := 1 TO i - 2 DO
      old_array^ [j].name := temp_array^ [j];
      old_array^ [j].index := 0;
    FOREND;
    amp$get_next (new_fid, ^temp, size_wsa, transfer_count, ba, file_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    temp_array^ [1] := temp (1, transfer_count);

    i := 2;
    WHILE file_p <> amc$eoi DO
      amp$get_next (new_fid, ^temp, size_wsa, transfer_count, ba, file_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      temp_array^ [i] := temp (1, transfer_count);
      i := i + 1;
    WHILEND;
    IF (i - 2) < 1 THEN
      new_array := NIL;
    ELSE
      PUSH new_array: [1 .. (i - 2)];
    IFEND;
    FOR j := 1 TO i - 2 DO
      new_array^ [j].name := temp_array^ [j];
      new_array^ [j].index := 0;
    FOREND;
    FREE temp_array;
    amp$close (old_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$close (new_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (old_array <> NIL) AND (new_array <> NIL) THEN
      i := 1;
      j := 1;
      WHILE (i <=  UPPERBOUND (old_array^)) AND (j <= UPPERBOUND (new_array^)) DO
        IF old_array^ [i].name = new_array^ [j].name THEN
          old_array^ [i].index := j;
          new_array^ [j].index := i;
          i := i + 1;
          j := j + 1;
        ELSE
          rap$bin_search (old_array^ [i].name, new_array, j, found);
          IF found THEN
            old_array^ [i].index := j;
            new_array^ [j].index := i;
            j := j + 1;
          IFEND;
          i := i + 1;
        IFEND;
      WHILEND;
    IFEND;

    RESET corrector;
    NEXT correction_header IN corrector;
    j := 1;
    IF old_array = NIL THEN
      delete_decks := NIL
    ELSE
      ALLOCATE delete_decks: [1 .. UPPERBOUND (old_array^)];
      FOR i := 1 TO UPPERBOUND (old_array^) DO
        IF old_array^ [i].index = 0 THEN
          delete_decks^ [j] := old_array^ [i].name;
          j := j + 1;
        IFEND;
      FOREND;
    IFEND;

    correction_header^.decks_to_delete := j - 1;

    d_decks := NIL;
    IF correction_header^.decks_to_delete > 0 THEN
      NEXT d_decks: [1 .. correction_header^.decks_to_delete] IN corrector;
      FOR i := 1 TO correction_header^.decks_to_delete DO
        d_decks^ [i] := delete_decks^ [i];
      FOREND;
    IFEND;
    IF delete_decks <> NIL THEN
      FREE delete_decks;
    IFEND;

    j := 1;
    k := 1;
    IF new_array = NIL THEN
      insert_decks := NIL;
      temp_array := NIL;
    ELSE
      ALLOCATE insert_decks: [1 .. UPPERBOUND (new_array^)];
      ALLOCATE temp_array: [1 .. UPPERBOUND (new_array^)];
      FOR i := 1 TO UPPERBOUND (new_array^) DO
        IF new_array^ [i].index = 0 THEN
          insert_decks^ [j] := new_array^ [i].name;
          j := j + 1;
        ELSE
          rap$compare_sl_decks (new_array^ [i].name, old_file.ref.path_name, old_file.ref.path_name_size,
                new_file.ref.path_name, new_file.ref.path_name_size, decks_dont_differ, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF decks_dont_differ THEN
            temp_array^ [k] := new_array^ [i].name;
            k := k + 1;
          IFEND;
        IFEND;
      FOREND;
    IFEND;

    correction_header^.decks_to_insert := j - 1;

    IF (k - 1) > 0 THEN
      PUSH decks_ok: [1 .. k - 1];
    ELSE
      decks_ok := NIL;
    IFEND;

    FOR i := 1 TO k - 1 DO
      decks_ok^ [i] := temp_array^ [i];
    FOREND;
    IF temp_array <> NIL THEN
      FREE temp_array;
    IFEND;

    i_decks := NIL;
    IF correction_header^.decks_to_insert > 0 THEN
      NEXT i_decks: [1 .. correction_header^.decks_to_insert] IN corrector;
      FOR i := 1 TO correction_header^.decks_to_insert DO
        i_decks^ [i] := insert_decks^ [i];
      FOREND;
    IFEND;
    IF insert_decks <> NIL THEN
      FREE insert_decks;
    IFEND;

    IF (decks_ok <> NIL) AND (new_array <> NIL) AND (old_array <> NIL) THEN
      IF (UPPERBOUND (new_array^) = UPPERBOUND (old_array^)) AND (UPPERBOUND (decks_ok^) = UPPERBOUND
            (new_array^)) THEN
        size := 0;
        RETURN;
      IFEND;
    IFEND;

    IF (new_array = NIL) AND (old_array = NIL) THEN
      size := 0;
      RETURN;
    IFEND;

    pmp$get_unique_name (replace_sl, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$build_replacement_sl (new_file, decks_ok, replace_sl, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH access_sel2: [1 .. 2];
    access_sel2^ [1].key := amc$access_mode;
    access_sel2^ [1].access_mode := $pft$usage_selections [pfc$read];
    access_sel2^ [2].key := amc$return_option;
    access_sel2^ [2].return_option := amc$return_at_close;

    amp$open (replace_sl, amc$segment, access_sel2, repl_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (repl_fid, amc$sequence_pointer, repl_sl, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    size := #SIZE (repl_sl.sequence_pointer^);
    correction_header^.size_of_replacement := size;
    NEXT replacement: [[REP size OF cell]] IN corrector;
    i#move (repl_sl.sequence_pointer, replacement, size);

    size := size + #SIZE (correction_header^);

    IF i_decks <> NIL THEN
      size := size + #SIZE (i_decks^);
    IFEND;

    IF d_decks <> NIL THEN
      size := size + #SIZE (d_decks^);
    IFEND;

    amp$close (repl_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$isolate_source_changes;
MODEND ram$isolate_source_changes;
*DECK DECK=RAM$ISSUE_MESSAGE EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE ram$issue_message;
?? PUSH (LISTEXT := ON) ??
*copyc amp$open
*copyc amp$close
*copyc amp$put_next
*copyc osp$format_message
?? POP ??

*copyc rah$issue_message

  PROCEDURE [XDCL] rap$issue_message (output_file: amt$local_file_name;
    VAR message_status: ost$status;
    VAR status: ost$status);

    VAR
      byte_address: amt$file_byte_address,
      j: ost$status_message_line_count,
      message: ost$status_message,
      message_sequence: ^ost$status_message,
      msg_line_count: ^ost$status_message_line_count,
      msg_line_size: ^ost$status_message_line_size,
      msg_line_text: ^string ( * ),
      output_file_id: amt$file_identifier;

    amp$open (output_file, amc$record, NIL, output_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$format_message (message_status, osc$full_message_level, osc$max_status_message_line, message, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    message_sequence := ^message;
    RESET message_sequence;
    NEXT msg_line_count IN message_sequence;

    FOR j := 1 TO msg_line_count^ DO
      NEXT msg_line_size IN message_sequence;
      NEXT msg_line_text: [msg_line_size^] IN message_sequence;
      amp$put_next (output_file_id, msg_line_text, msg_line_size^, byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;
    amp$close (output_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
  PROCEND rap$issue_message;
MODEND ram$issue_message;
*DECK DECK=RAM$JOBS_RECOVERED_PROMPTS EXPAND=TRUE
CREATE_MESSAGE_MODULE jobs_recov_prompts$us_english


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This deck contains the command calls to create a prompt message module
"   that is used by RAP$GET_JOBS_RECOVERED_OPTION. Modules are formatted for
"   use by the RAP$PROMPT_FOR_VALUE and DISPLAY_MESSAGE interfaces.
"
" DESIGN:
"   The function of a message module is to provide help for a user executing
"   commands interactively.  Therefore the kinds of messages found in a
"   message module reflect that purpose.  In setting up value prompts using
"   message module technology the message kinds are given new meanings.
"
"     The value prompts are created as parameter prompt messages.  The value
"     prompts help (optional) is created as a parameter help message.
"
" NOTES:
"   Things to do when SIU is implemented:
"     All occurrences of 'BASE_1 tape' should be replaced by 'Installation Tape'.
*IFEND

CREATE_PARAMETER_PROMPT_MESSAGE n=activate_system
+X2+N+X2+N0Your system has recovered some jobs.+X2Because of this, installation
 options (to install a BASE_1 tape or install deferred files) are NOT allowed.
+N+X2+N+X2+N0Do you want to activate the system?+X2(Enter YES, NO, or ?)
**

CREATE_PARAMETER_HELP_MESSAGE n=activate_system
+X2+N0No installation options are allowed in order to prevent system software from
 being changed while jobs are running.+X2Your options are:
+N+X2+N0Enter:
+N+X2+N2YES+X4to activate the system for general use.
+N2NO+X5to enter operator command mode or if you intended to install
+N9software.
+N+X2+N0If you answer YES or Y, the system will be activated for general use.
+N+X2+N0If you answer NO or N, the system will be placed in operator command mode.+X2To
 install software, respond with NO and perform either step below:
+N+X2+N1 1. Terminate the recovered jobs and perform another deadstart.
+N1 2. Re-deadstart the system with operator intervention.  Set the
+N5JOB_RECOVERY_OPTION system attribute to 3 to prevent recovery of the
+N5jobs.
+N+X2+N
**

END_MESSAGE_MODULE
*DECK DECK=RAM$JOBS_REC_ACTIVATION_MENU EXPAND=TRUE
CREATE_MESSAGE_MODULE jobs_rec_activation$us_english


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This deck contains the command calls to create a prompt message module
"   that is used by RAP$GET_ACTIVATION_OPTION. Modules are formatted for
"   use by the RAP$PROMPT_VIA_MENU.
"
" DESIGN:
"   The function of a message module is to provide help for a user executing
"   commands interactively.  Therefore the kinds of messages found in a
"   message module reflect that purpose.  In setting up menus using message
"   module technology the message kinds are given new meanings.
"
"     The menu title is created as the brief help message.
"     The menu help is created as the full help message.
"     The menu selections are created as parameter prompt messages.
"     The menu selection help (optional) is created as a parameter help message.
"     The menu selection confirmation (optional) is created as a parameter
"     assist message.
"     The menu prompt is created as a parameter prompt message.
"
" NOTES:
"
*IFEND

CREATE_BRIEF_HELP_MESSAGE
+X2+N0The system has recovered some jobs which have started to execute.+X2To
 prevent running mixed levels of software, no installation options are allowed.
+N+X2
+N0Your system activation choices are:+N+X2
**

CREATE_FULL_HELP_MESSAGE
+X2+N0You are not allowed to install a new Installation Tape or deferred
 products.+X2This is done to prevent system software from being changed while
 the recovered jobs are executing.+X2You may now activate the system for
 production or for system console usage.+X2 (The latter choice will not
 make the system available to users.)+X2Processing will be complete when
 you see the message:
+N+X2
+N2----- SYSTEM ACTIVATION COMPLETE -----
+N+X2
+N0This message will be followed by the NOS/VE slash (/) prompt at which time
 you may enter commands.
+N+X2
+N0To get help for a particular selection, enter the number of the selection,
 followed by a question mark.
 For example, to get help for selection 1, you would enter:
+N+X2
+N2 1?
+N+X2
+N
**

CREATE_PARAMETER_PROMPT_MESSAGE n=production_usage
+X2+P1.+X2Activate the system for production.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=console_usage_only
+X2+P1.+X2Activate the system for system console usage.
+N+X7NOTE: Recovered jobs will continue to execute.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=prompt
+X2+N0Enter selection or ? for HELP.
**

CREATE_PARAMETER_HELP_MESSAGE n=production_usage
+X2+N0This selection causes the system to be activated for general
 use.+X2If the network is configured and has been enabled (by the
 NETWORK_ACTIVATION system attribute), all of the tasks and applications
 associated with it will also be activated.+X2In a dual-state mainframe, the
 tasks used to communicate with the 170 partner system will be
 activated.+X2Activating the system for production makes the mainframe
 available to users.
+N+X2
**

CREATE_PARAMETER_HELP_MESSAGE n=console_usage_only
+N0This selection causes the system to be activated for system console
 usage.+X2This means that the mainframe will not be
 available to users other than the system console operator.+X2Note however,
 that the recovered jobs will be allowed to execute.
+N0+X2
+N0If you intended to install software, choose this option.  After system
 activation is complete, perform either step below:
+N+X2
+N1 1. Terminate the recovered jobs and perform another deadstart.
+N1 2. Re-deadstart the system with operator intervention.  Set the
+N5JOB_RECOVERY_OPTION system attribute to 3 to prevent recovery of the
+N5jobs.
+N+X2
**

END_MESSAGE_MODULE
*DECK DECK=RAM$JOB_ACTIVATION_EPILOG EXPAND=TRUE

" This is the JOB_ACTIVATION_EPILOG file.  It is stored in the catalog
" $SYSTEM.PROLOGS_AND_EPILOGS.  The commands in this file are executed every
" time the system is activated for production.
"
" Execution of this file occurs inside a procedure with a WHEN handler so
" that every command in this file will be attempted, regardless of errors.
" In addition you have the status variables IGNORE_STATUS and LOCAL_STATUS
" available to you.
"
" This file contains no commands when it is released.
*DECK DECK=RAM$JOB_ACTIVATION_PROLOG EXPAND=TRUE

" This is the JOB_ACTIVATION_PROLOG file.  It is stored in the catalog
" $SYSTEM.PROLOGS_AND_EPILOGS.  The commands in this file are executed every
" time the system is activated for production.
"
" Execution of this file occurs inside a procedure with a WHEN handler so
" that every command in this file will be attempted, regardless of errors.
" In addition you have the status variables IGNORE_STATUS and LOCAL_STATUS
" available to you.
"
" This file contains no commands when it is released.
*DECK DECK=RAM$LINDSMR EXPAND=TRUE
.PROC,LINDSMR*I,
M "- Module name (or ALL or *)"        = (*N=*,ALL=*,*,DSMRUN),
*IF ($string($name(wev$target_operating_system))='NOSBE')
B "- Binary input file name"           = (*N=NVERELB,*F),
L "- Library name for linked output"   = (*N=NBEBINS,*F),
*ELSE
B "- Binary input file name"           = (*N=NVERELS,*F),
L "- Library name for linked output"   = (*N=NOSBINS,*F),
*IFEND
MAP "- MAP file name"                  = (*N=LINKMAP,*F),
UN "- NOS/BE perm file ID"             = (*N=,*F),
.
.HELP
 The LINDSMR procedure links the NOS 170 absolute binary DSMRUN to run dual
 state. Requires libraries CYBCLIB and NETIO.

 Parameter   Default   Description
   Name       Value

  [m]         all      Module name being linked (or ALL or *)
*IF ($string($name(wev$target_operating_system))='NOSBE')
  [b]        nverelb   Binary input file containing the relocatable binaries
  [l]        nbebins   Library name to which the linked module is written
*ELSE
  [b]        nverels   Binary input file containing the relocatable binaries
  [l]        nosbins   Library name to which the linked module is written
*IFEND
  [map]      linkmap   File name to which the linkmap is written

.HELP,M
 The M parameter selects the module name to be linked. Either DSMRUN or ALL
 may be selected. The default value is ALL 170 Interactive Facility modules.
.HELP,B
 The B parameter names the binary file containing the relocatable binaries.
*IF ($string($name(wev$target_operating_system))='NOSBE')
 The default value is NVERELB.
*ELSE
 The default value is NVERELS.
*IFEND
.HELP,L
 The L parameter specifies the library file to which the linked module
*IF ($string($name(wev$target_operating_system))='NOSBE')
 is written. The default value is NBEBINS.
*ELSE
 is written. The default value is NOSBINS.
*IFEND
.HELP,MAP
 The MAP parameter names the file to which the linkmap is written.
 The default value is LINKMAP.
.HELP,UN
 The UN parameter specifies a permanent file ID on NOS/BE systems. This
 parameter must not be specified on NOS.
.ENDHELP
.IF,SYS.EQ.NOSB,CHECKUN.
  .IF,$UN$.EQ.$$,BADUN.
    NOTE(OUTPUT); THE #UN PARAMETER MUST BE SPECIFIED.
    REVERT,ABORT.
  .ENDIF,BADUN.
.ELSE,CHECKUN.
  .IF,$UN$.NE.$$,BADUN2.
    REVERT,ABORT. THE #UN PARAMETER MUST NOT BE SPECIFIED
  .ENDIF,BADUN2.
.ENDIF,CHECKUN.
.IFE,FILE(B,.NOT.AS),GET_B.
  GETFILE,B,B,UN,READ,A=YES.
.ENDIF,GET_B.
.IF,SYS.EQ.NOS,NOSSYS.
  $GTR(B,YYYYREL)REL/*
  $UNLOAD,B.
  $LIBEDIT,P=0,N=B,I=0,#B=YYYYREL,#L=0,U=B,NX=1.
  $UNLOAD,YYYYREL.
.ENDIF,NOSSYS.
.IFE,FILE(CYBCLIB,.NOT.AS),GETCYBCLIB.
  GETFILE,CYBCLIB,CYBCLIB,UN,A=YES.
.ENDIF,GETCYBCLIB.
.IFE,(($M$.EQ.$DSMRUN$).OR.($M$.EQ.$*$)),GETDSMRUN.
  NOTE(OUTPUT,NR)+ LINKING DSMRUN
  .IFE,SYS.EQ.NOS,NOSRUN.
    $LDSET(#MAP=SBEX/MAP,LIB=B/CYBCLIB/NETIO,PRESET=ZERO)
  .ELSE,NOSRUN.
    LDSET(#MAP=SBEX/MAP,LIB=CYBCLIB,PRESET=ZERO)
  .ENDIF,NOSRUN.
  SLOAD(B,DSMRUN)
  SLOAD(B,DSADCAL) (MUST BE BELOW 10000B)
  SLOAD(B,MLMSMI,ICM$$$$PAR,MLP$$$$MLI,RHMJEP,RHMQRF,DSMORFV,TESTNBE)
  SLOAD(B,DSACYIF,MLMASM,RHAQAC,RHAQRM,RHMLGM,RHASDTS)
  .IFE,SYS.EQ.NOS,NOSSSJ.
    $NOGO,YYYYABS,DSMRUN,$SSJ=$.
  .ELSE,NOSSSJ.
    NOGO,YYYYABS.
  .ENDIF,NOSSSJ.
  REPLIB,YYYYABS,L,,UN.
  NOTE(OUTPUT,NR)+ MODULE DSMRUN --> L
.ENDIF,GETDSMRUN.
SKIP,NOERROR.
  EXIT.
  UNLOAD,YYYYREL,YYYYABS.
  .IFE,FILE(B,.NOT.AS),RET_B.
    UNLOAD,B.
  .ENDIF,RET_B.
  .IFE,FILE(CYBCLIB,.NOT.AS),RETCYBCLIB.
    UNLOAD,CYBCLIB.
  .ENDIF,RETCYBCLIB.
  .IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    EXIT. LINDSMR PROCEDURE *TERMINATED*
  .ENDIF,TERMINATED.
  REVERT,ABORT. LINDSMR PROCEDURE FAILED
ENDIF,NOERROR.
.IFE,FILE(B,.NOT.AS),RET_B.
  UNLOAD,B.
.ENDIF,RET_B.
.IFE,FILE(CYBCLIB,.NOT.AS),RETCYBCLIB.
  UNLOAD,CYBCLIB.
.ENDIF,RETCYBCLIB.
.IFE,$M$.EQ.$*$,LINKALL.
  REVERT. LINKED 170 IAF --> L
.ELSE,LINKALL.
  REVERT. LINKED M --> L
.ENDIF,LINKALL.
/EOR

*DECK DECK=RAM$LINDST EXPAND=TRUE
.PROC,LINDST*I,
*IF ($string($name(wev$target_operating_system))='NOSBE')
M "- Module name (or ALL or *)"        = (*N=*,ALL=*,*,DSMDST,DSMTRM,
                                          DSMDSTG,DSMNBCS),
B "- Binary input file name"           = (*N=NVERELB,*F),
L "- Library name for linked output"   = (*N=NVELIBB,*F),
*ELSE
M "- Module name (or ALL or *)"        = (*N=*,ALL=*,*,DSMDST,DSMTRM,
                                          DSMDSTG),
B "- Binary input file name"           = (*N=NVERELS,*F),
L "- Library name for linked output"   = (*N=NVELIB,*F),
*IFEND
MAP "- MAP file name"                  = (*N=LINKMAP,*F),
UN "- NOS/BE perm file ID"             = (*F,*N=),
.
.HELP
 The LINDST procedure LINks the NVE subsystem and NOS/VE deadstart tape
 builder. Requires library CYBCLIB.

 Parameter   Default   Description
   Name       Value

  [m]          all     Module name being linked (or ALL or *)
*IF ($string($name(wev$target_operating_system))='NOSBE')
  [b]        nverelb   Binary input file containing the relocatable binaries
  [l]        nvelibb   Library name to which the linked module is written
*ELSE
  [b]        nverels   Binary input file containing the relocatable binaries
  [l]        nvelib    Library name to which the linked module is written
*IFEND
  [map]      linkmap   File name to which the linkmap is written
  [un]                 User name

.HELP,M
 The M parameter selects the module name to be linked. Either DSMDST,
 DSMTRM, DSMDSTG, or ALL may be selected. The default value is ALL NOS/VE
 deadstart modules.
.HELP,B
 The B parameter names the binary file containing the relocatable binaries.
*IF ($string($name(wev$target_operating_system))='NOSBE')
 The default value is NVERELB.
*ELSE
 The default value is NVERELS.
*IFEND
.HELP,L
 The L parameter specifies the library file to which the linked module
*IF ($string($name(wev$target_operating_system))='NOSBE')
 is written. The default value is NVELIBB.
*ELSE
 is written. The default value is NVELIB.
*IFEND
.HELP,MAP
 The MAP parameter names the file to which the linkmap is written.
 The default value is LINKMAP.
.HELP,UN
 The UN parameter specifies a permanent file ID on NOS/BE systems. This
 parameter must not be specified on NOS.
.ENDHELP
.IF,SYS.EQ.NOSB,CHECKUN.
  .IF,$UN$.EQ.$$,BADUN.
    NOTE(OUTPUT); THE #UN PARAMETER MUST BE SPECIFIED.
    REVERT,ABORT.
  .ENDIF,BADUN.
.ELSE,CHECKUN.
  .IF,$UN$.NE.$$,BADUN2.
    REVERT,ABORT. THE #UN PARAMETER MUST NOT BE SPECIFIED
  .ENDIF,BADUN2.
.ENDIF,CHECKUN.
.IFE,FILE(B,.NOT.AS),GET_B.
  GETFILE,B,B,UN,READ,A=YES.
.ENDIF,GET_B.
.IF,SYS.EQ.NOS,NOSSYS.
  $GTR(B,YYYYREL)REL/*
  $UNLOAD,B.
  $LIBEDIT,P=0,N=B,I=0,#B=YYYYREL,#L=0,U=B,NX=1.
  $UNLOAD,YYYYREL.
.ENDIF,NOSSYS.
.IFE,FILE(CYBCLIB,.NOT.AS),GETCYBCLIB.
  GETFILE,CYBCLIB,CYBCLIB,UN.
.ENDIF,GETCYBCLIB.
.IFE,(($M$.EQ.$DSMDST$).OR.($M$.EQ.$*$)),GETDSMDST.
  NOTE(OUTPUT,NR)+ LINKING DSMDST
  .IFE,SYS.EQ.NOS,NOSDST.
    $LDSET(#MAP=SBEX/MAP,LIB=B/CYBCLIB,PRESET=ZERO)
  .ELSE,NOSDST.
    LDSET(#MAP=SBEX/MAP,LIB=CYBCLIB,PRESET=ZERO)
  .ENDIF,NOSDST.
  SLOAD(B,DSMDST)
  SLOAD(B,DSADCAL)  (MUST BE BELOW 10000B)
  SLOAD(B,DSMDNV,DSMORFV)
  SLOAD(B,DSACYIF)
  .IFE,SYS.EQ.NOSB.SLOAD(B,MLMASM)
  NOGO,YYYYABS.
  REPLIB,YYYYABS,L,,UN.
  NOTE(OUTPUT,NR)+ MODULE DSMDST --> L
.ENDIF,GETDSMDST.
.IFE,(($M$.EQ.$DSMTRM$).OR.($M$.EQ.$*$)),GETDSMTRM.
  NOTE(OUTPUT,NR)+ LINKING DSMTRM
  .IFE,SYS.EQ.NOS,NOSTRM.
    $LDSET(#MAP=SBEX/MAP,LIB=B/CYBCLIB,PRESET=ZERO)
  .ELSE,NOSTRM.
    LDSET(#MAP=SBEX/MAP,LIB=CYBCLIB,PRESET=ZERO)
  .ENDIF,NOSTRM.
  SLOAD(B,DSMTRM)
  SLOAD(B,DSADCAL)  (MUST BE BELOW 10000B)
  SLOAD(B,DSMTNVE)
  SLOAD(B,DSACYIF)
  .IFE,SYS.EQ.NOSB.SLOAD(B,MLMASM)
  NOGO,YYYYABS.
  REPLIB,YYYYABS,L,,UN.
  NOTE(OUTPUT,NR)+ MODULE DSMTRM --> L
.ENDIF,GETDSMTRM.
*IF ($string($name(wev$target_operating_system))='NOSBE')
.IFE,(($M$.EQ.$DSMNBCS$).OR.($M$.EQ.$*$)),GETDSMNBCS.
  NOTE(OUTPUT,NR)+ LINKING DSMNBCS
  .IFE,SYS.EQ.NOS,NOSNBCS.
    $LDSET(#MAP=SBEX/MAP,LIB=B,PRESET=ZERO)
  .ELSE,NOSNBCS.
    LDSET(#MAP=SBEX/MAP,PRESET=ZERO)
  .ENDIF,NOSNBCS.
  SLOAD(B,DSMNBCS)
  SLOAD(B,COPYS)
  NOGO,YYYYABS.
  REPLIB,YYYYABS,L,,UN.
  NOTE(OUTPUT,NR)+ MODULE DSMNBCS --> L
  UNLOAD,YYYYREL.
.ENDIF,GETDSMNBCS.
*IFEND
SKIP,NOERROR.
  EXIT.
  UNLOAD,YYYYREL,YYYYABS.
  .IFE,FILE(B,.NOT.AS),RET_B.
    UNLOAD,B.
  .ENDIF,RET_B.
  .IFE,FILE(CYBCLIB,.NOT.AS),RETCYBCLIB.
    UNLOAD,CYBCLIB.
  .ENDIF,RETCYBCLIB.
  .IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    EXIT. LINDST PROCEDURE *TERMINATED*
  .ENDIF,TERMINATED.
  REVERT,ABORT. LINDST PROCEDURE FAILED
ENDIF,NOERROR.
  .IFE,FILE(B,.NOT.AS),RET_B.
    UNLOAD,B.
  .ENDIF,RET_B.
  .IFE,FILE(CYBCLIB,.NOT.AS),RETCYBCLIB.
    UNLOAD,CYBCLIB.
  .ENDIF,RETCYBCLIB.
.IFE,$M$.EQ.$*$,LINKALL.
  REVERT. LINKED 170 DST --> L
.ELSE,LINKALL.
  REVERT. LINKED M --> L
.ENDIF,LINKALL.
/EOR
*DECK DECK=RAM$LINFMU EXPAND=TRUE
.PROC,LINFMU*I,
M "- Module name (or ALL or *)"        = (*N=*,ALL=*,*,FMSLAVE),
*IF ($string($name(wev$target_operating_system))='NOSBE')
B "- Binary input file name"           = (*N=NVERELB,*F),
L "- Library name for linked output"   = (*N=NBEBINS,*F),
*ELSE
B "- Binary input file name"           = (*N=NVERELS,*F),
L "- Library name for linked output"   = (*N=NOSBINS,*F),
*IFEND
MAP "- MAP file name"                  = (*N=LINKMAP,*F),
UN "- NOS/BE perm file ID"             = (*N=,*F),
.
.HELP
 The LINFMU procedure LINks the NOS 170 portion of the NOS/VE File Management
 Utility. Requires libraries NVELIB, SYMLIB, BAMLIB, SRVLIB (on NOS only), and
 SYSLIB.

 Parameter   Default   Description
   Name       Value

  [m]         all      Module name being linked (or ALL or *)
*IF ($string($name(wev$target_operating_system))='NOSBE')
  [b]        nverelb   Binary input file containing the relocatable binaries
  [l]        nbebins   Library name to which the linked module is written
*ELSE
  [b]        nverels   Binary input file containing the relocatable binaries
  [l]        nosbins   Library name to which the linked module is written
*IFEND
  [map]      linkmap   File name to which the linkmap is written

.HELP,M
 The M parameter selects the module name to be linked. Either FMSLAVE or ALL
 may be selected. The default value is ALL 170 File Management Utility modules.
.HELP,B
 The B parameter names the binary file containing the relocatable binaries.
*IF ($string($name(wev$target_operating_system))='NOSBE')
 The default value is NVERELB.
*ELSE
 The default value is NVERELS.
*IFEND
.HELP,L
 The L parameter specifies the library file to which the linked module
*IF ($string($name(wev$target_operating_system))='NOSBE')
 is written. The default value is NBEBINS.
*ELSE
 is written. The default value is NOSBINS.
*IFEND
.HELP,MAP
 The MAP parameter names the file to which the linkmap is written.
 The default value is LINKMAP.
.HELP,UN
 The UN parameter specifies a permanent file ID on NOS/BE systems. This
 parameter must not be specified on NOS.
.ENDHELP
.IF,SYS.EQ.NOSB,CHECKUN.
  .IF,$UN$.EQ.$$,BADUN.
    NOTE(OUTPUT); THE #UN PARAMETER MUST BE SPECIFIED.
    REVERT,ABORT.
  .ENDIF,BADUN.
.ELSE,CHECKUN.
  .IF,$UN$.NE.$$,BADUN2.
    REVERT,ABORT. THE #UN PARAMETER MUST NOT BE SPECIFIED
  .ENDIF,BADUN2.
.ENDIF,CHECKUN.
.IFE,FILE(B,.NOT.AS),GET_B.
  GETFILE,B,B,UN,READ,A=YES.
.ENDIF,GET_B.
.IF,SYS.EQ.NOS,NOSSYS.
  $GTR(B,YYYYREL)REL/*
  $UNLOAD,B.
  $LIBEDIT,P=0,N=B,I=0,#B=YYYYREL,#L=0,U=B,NX=1.
  $UNLOAD,YYYYREL.
.ENDIF,NOSSYS.
.IFE,FILE(NVELIB,.NOT.AS),GETNVELIB.
  GETFILE,NVELIB,NVELIB,UN.
.ENDIF,GETNVELIB.
.IFE,FILE(SYMLIB,.NOT.AS),GETSYMLIB.
  GETFILE,SYMLIB,SYMLIB,UN.
.ENDIF,GETSYMLIB.
.IFE,FILE(BAMLIB,.NOT.AS),GETBAMLIB.
  GETFILE,BAMLIB,BAMLIB,UN.
.ENDIF,GETBAMLIB.
.IFE,FILE(SRVLIB,.NOT.AS),GETSRVLIB.
  GETFILE,SRVLIB,SRVLIB,UN.
.ENDIF,GETSRVLIB.
.IFE,FILE(SYSLIB,.NOT.AS),GETSYSLIB.
  GETFILE,SYSLIB,SYSLIB,UN.
.ENDIF,GETSYSLIB.
.IFE,(($M$.EQ.$FMSLAVE$).OR.($M$.EQ.$*$)),GETFMSLAVE.
  NOTE(OUTPUT,NR)+ LINKING FMSLAVE
  LDSET(#MAP=SBEX/MAP)
  .IFE,SYS.EQ.NOS,NOSSLAVE.
    $LDSET(LIB=B/NVELIB/SYMLIB/BAMLIB/SRVLIB/SYSLIB,PRESET=ZERO)
    $SLOAD(B,FASLAVE,GETTXT)
  .ELSE,NOSSLAVE.
    LDSET(LIB=NVELIB/SYMLIB/BAMLIB/SYSLIB,PRESET=ZERO)
    SLOAD(B,FASLAVE)
    SLOAD(B,FA$$$$ACQF,FA$$$$GDEV,FA$$$$GFAT,GETTXT)
  .ENDIF,NOSSLAVE.
  NOGO,YYYYABS.
  REPLIB,YYYYABS,L,,UN.
  NOTE(OUTPUT,NR)+ MODULE SLAVE --> L
.ENDIF,GETFMSLAVE.
SKIP,NOERROR.
  EXIT.
  UNLOAD,YYYYREL,YYYYABS.
  .IFE,FILE(B,.NOT.AS),RET_B.
    UNLOAD,B.
  .ENDIF,RET_B.
  .IFE,FILE(NVELIB,.NOT.AS),RETNVELIB.
    UNLOAD,NVELIB.
  .ENDIF,RETNVELIB.
  .IFE,FILE(SYMLIB,.NOT.AS),RETSYMLIB.
    UNLOAD,SYMLIB.
  .ENDIF,RETSYMLIB.
  .IFE,FILE(BAMLIB,.NOT.AS),RETBAMLIB.
    UNLOAD,BAMLIB.
  .ENDIF,RETBAMLIB.
  .IFE,FILE(SRVLIB,.NOT.AS),RETSRVLIB.
    UNLOAD,SRVLIB.
  .ENDIF,RETSRVLIB.
  .IFE,FILE(SYSLIB,.NOT.AS),RETSYSLIB.
    UNLOAD,SYSLIB.
  .ENDIF,RETSYSLIB.
  .IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    EXIT. LINFMU PROCEDURE *TERMINATED*
  .ENDIF,TERMINATED.
  REVERT,ABORT. LINFMU PROCEDURE FAILED
ENDIF,NOERROR.
.IFE,FILE(B,.NOT.AS),RET_B.
  UNLOAD,B.
.ENDIF,RET_B.
.IFE,FILE(NVELIB,.NOT.AS),RETNVELIB.
  UNLOAD,NVELIB.
.ENDIF,RETNVELIB.
.IFE,FILE(SYMLIB,.NOT.AS),RETSYMLIB.
  UNLOAD,SYMLIB.
.ENDIF,RETSYMLIB.
.IFE,FILE(BAMLIB,.NOT.AS),RETBAMLIB.
  UNLOAD,BAMLIB.
.ENDIF,RETBAMLIB.
.IFE,FILE(SRVLIB,.NOT.AS),RETSRVLIB.
  UNLOAD,SRVLIB.
.ENDIF,RETSRVLIB.
.IFE,FILE(SYSLIB,.NOT.AS),RETSYSLIB.
  UNLOAD,SYSLIB.
.ENDIF,RETSYSLIB.
.IFE,$M$.EQ.$*$,LINKALL.
  REVERT. LINKED FMU 170 --> L
.ELSE,LINKALL.
  REVERT. LINKED M --> L
.ENDIF,LINKALL.
/EOR
*DECK DECK=RAM$LINIAF EXPAND=TRUE
.PROC,LINIAF*I,
M "- Module name (or ALL or *)"        = (*N=*,ALL=*,*,IIAPAS),
*IF ($string($name(wev$target_operating_system))='NOSBE')
B "- Binary input file name"           = (*N=NVERELB,*F),
L "- Library name for linked output"   = (*N=NBEBINS,*F),
*ELSE
B "- Binary input file name"           = (*N=NVERELS,*F),
L "- Library name for linked output"   = (*N=NOSBINS,*F),
*IFEND
MAP "- MAP file name"                  = (*N=LINKMAP,*F),
UN "- NOS/BE perm file ID"             = (*N=,*F),
.
.HELP
 The LINIAF procedure LINks the NOS 170 portion of the NOS/VE Interactive
 Facility. Requires libraries CYBCLIB and NETIO.

 Parameter   Default   Description
   Name       Value

  [m]         all      Module name being linked (or ALL or *)
*IF ($string($name(wev$target_operating_system))='NOSBE')
  [b]        nverelb   Binary input file containing the relocatable binaries
  [l]        nbebins   Library name to which the linked module is written
*ELSE
  [b]        nverels   Binary input file containing the relocatable binaries
  [l]        nosbins   Library name to which the linked module is written
*IFEND
  [map]      linkmap   File name to which the linkmap is written

.HELP,M
 The M parameter selects the module name to be linked. Either IIAPAS or ALL
 may be selected. The default value is ALL 170 Interactive Facility modules.
.HELP,B
 The B parameter names the binary file containing the relocatable binaries.
*IF ($string($name(wev$target_operating_system))='NOSBE')
 The default value is NVERELB.
*ELSE
 The default value is NVERELS.
*IFEND
.HELP,L
 The L parameter specifies the library file to which the linked module
*IF ($string($name(wev$target_operating_system))='NOSBE')
 is written. The default value is NBEBINS.
*ELSE
 is written. The default value is NOSBINS.
*IFEND
.HELP,MAP
 The MAP parameter names the file to which the linkmap is written.
 The default value is LINKMAP.
.HELP,UN
 The UN parameter specifies a permanent file ID on NOS/BE systems. This
 parameter must not be specified on NOS.
.ENDHELP
.IF,SYS.EQ.NOSB,CHECKUN.
  .IF,$UN$.EQ.$$,BADUN.
    NOTE(OUTPUT); THE #UN PARAMETER MUST BE SPECIFIED.
    REVERT,ABORT.
  .ENDIF,BADUN.
.ELSE,CHECKUN.
  .IF,$UN$.NE.$$,BADUN2.
    REVERT,ABORT. THE #UN PARAMETER MUST NOT BE SPECIFIED
  .ENDIF,BADUN2.
.ENDIF,CHECKUN.
.IFE,FILE(B,.NOT.AS),GET_B.
  GETFILE,B,B,UN,READ,A=YES.
.ENDIF,GET_B.
.IF,SYS.EQ.NOS,NOSSYS.
  $GTR(B,YYYYREL)REL/*
  $UNLOAD,B.
  $LIBEDIT,P=0,N=B,I=0,#B=YYYYREL,#L=0,U=B,NX=1.
  $UNLOAD,YYYYREL.
  .IFE,FILE(NETIO,.NOT.AS),GETNETIO.
    GETFILE,NETIO,NETIO,UN.
  .ENDIF,GETNETIO.
.ENDIF,NOSSYS.
.IFE,FILE(CYBCLIB,.NOT.AS),GETCYBCLIB.
  GETFILE,CYBCLIB,CYBCLIB,UN,A=YES.
.ENDIF,GETCYBCLIB.
.IFE,(($M$.EQ.$IIAPAS$).OR.($M$.EQ.$*$)),GETIIAPAS.
  NOTE(OUTPUT,NR)+ LINKING IIAPAS
  .IFE,SYS.EQ.NOS,NOSIAF.
    $LDSET(#MAP=SBEX/MAP,LIB=B/CYBCLIB/NETIO,PRESET=ZERO)
  .ELSE,NOSIAF.
    LDSET(#MAP=SBEX/MAP,LIB=CYBCLIB,PRESET=ZERO)
  .ENDIF,NOSIAF.
  SLOAD(B,IIAPAS)
  .IFE,SYS.EQ.NOS,NOSIAF2.
    $SLOAD(B,IIMNAM,CYBMLI,IIM$$$$NAM,TESTNBE)
  .ELSE,NOSIAF2.
    SLOAD(B,CYBMLI,IIM$$$$NAM,TESTNBE,DSACYIF,MUJHELP)
  .ENDIF,NOSIAF2.
  NOGO,YYYYABS,VEIAF.
  REPLIB,YYYYABS,L,,UN.
  NOTE(OUTPUT,NR)+ MODULE IIAPAS --> L
.ENDIF,GETIIAPAS.
SKIP,NOERROR.
  EXIT.
  UNLOAD,YYYYREL,YYYYABS.
  .IFE,FILE(B,.NOT.AS),RET_B.
    UNLOAD,B.
  .ENDIF,RET_B.
  .IFE,FILE(CYBCLIB,.NOT.AS),RETCYBCLIB.
    UNLOAD,CYBCLIB.
  .ENDIF,RETCYBCLIB.
  .IFE,FILE(NETIO,.NOT.AS),RETNETIO.
    UNLOAD,NETIO.
  .ENDIF,RETNETIO.
  .IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    EXIT. LINIAF PROCEDURE *TERMINATED*
  .ENDIF,TERMINATED.
  REVERT,ABORT. LINIAF PROCEDURE FAILED
ENDIF,NOERROR.
.IFE,FILE(B,.NOT.AS),RET_B.
  UNLOAD,B.
.ENDIF,RET_B.
.IFE,FILE(CYBCLIB,.NOT.AS),RETCYBCLIB.
  UNLOAD,CYBCLIB.
.ENDIF,RETCYBCLIB.
.IFE,FILE(NETIO,.NOT.AS),RETNETIO.
  UNLOAD,NETIO.
.ENDIF,RETNETIO.
.IFE,$M$.EQ.$*$,LINKALL.
  REVERT. LINKED 170 IAF --> L
.ELSE,LINKALL.
  REVERT. LINKED M --> L
.ENDIF,LINKALL.
/EOR
*DECK DECK=RAM$LINK_VIRTUAL_ENVIRIONMENT EXPAND=TRUE
create_program_description name=(link_virtual_environment, linve) sp=ocp$_link_virtual_environment l=(..
      '$system.ocu.bound_product' osf$task_services_library) tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$LINNOS EXPAND=TRUE
.PROC,LINNOS*I,
*IF ($string($name(wev$target_operating_system))='NOSBE')
M "- Module name (or ALL or *)"        = (*N=*,ALL=*,*,DSMDST,DSMRUN,DSMTRM,
                                          DSMDSTG,DSMNBCS,IIAPAS,RHMPFP,RHAQEP,
                                          FMSLAVE),
B "- Binary input file name"           = (*N=NVERELB,*F),
*ELSE
M "- Module name (or ALL or *)"        = (*N=*,ALL=*,*,DSMDST,DSMRUN,DSMTRM,
                                          DSMDSTG,IIAPAS,RHMPFP,RHAQEP,
                                          FMSLAVE),
B "- Binary input file name"           = (*N=NVERELS,*F),
*IFEND
L "- Library name for linked output"   = (*N=,*F),
MAP "- MAP file name"                  = (*N=LINKMAP,*F),
UN "- NOS/BE perm file ID"             = (*N=,*F),
.
.HELP
 The LINNOS procedure LINks the NVE subsystem, the NOS/VE deadstart tape
 builder, the Interactive Facility, the Remote Host Facility, and the
 File Management Utility modules which execute on behalf of NOS/VE.
 This procedure calls LINDST, LINFMU, LINIAF, LINDSMR and/or LINRHF as appropriate.

 Parameter   Default   Description
   Name       Value

  [m]          all     Module name being linked (or ALL or *)
*IF ($string($name(wev$target_operating_system))='NOSBE')
  [b]        nverelb   Binary input file containing the relocatable binaries
*ELSE
  [b]        nverels   Binary input file containing the relocatable binaries
*IFEND
  [l]                  Library name to which the linked module is written
  [map]      linkmap   File name to which the linkmap is written

.HELP,M
 The M parameter selects the module name to be linked. Either DSMDST, DSMRUN,
 DSMTRM, DSMDSTG, DSMNBCS, IIAPAS, RHMPFP, RHAQEP, FMSLAVE, or ALL may
 be selected.  The default value is ALL 170 NOS/VE modules.
.HELP,B
 The B parameter names the binary file containing the relocatable binaries.
*IF ($string($name(wev$target_operating_system))='NOSBE')
 The default value is NVERELB.
*ELSE
 The default value is NVERELS.
*IFEND
.HELP,L
 The L parameter specifies the library file to which the linked module
 is written. The default value is module dependent.
.HELP,MAP
 The MAP parameter names the file to which the linkmap is written.
 The default value is LINKMAP.
.HELP,UN
 The UN parameter specifies a permanent file ID on NOS/BE systems. This
 parameter must not be specified on NOS.
.ENDHELP
.IF,SYS.EQ.NOSB,CHECKUN.
  .IF,$UN$.EQ.$$,BADUN.
    NOTE(OUTPUT); THE #UN PARAMETER MUST BE SPECIFIED.
    REVERT,ABORT.
  .ENDIF,BADUN.
.ELSE,CHECKUN.
  .IF,$UN$.NE.$$,BADUN2.
    REVERT,ABORT. THE #UN PARAMETER MUST NOT BE SPECIFIED
  .ENDIF,BADUN2.
.ENDIF,CHECKUN.
.IFE,FILE(B,.NOT.AS),GET_B.
  GETFILE,B,B,UN,READ,A=YES.
.ENDIF,GET_B.
.IFE,FILE(CYBCLIB,.NOT.AS),GETCYBCLIB.
  GETFILE,CYBCLIB,CYBCLIB,UN.
.ENDIF,GETCYBCLIB.
.IFE,(($M$.EQ.$DSMDST$).OR.($M$.EQ.$DSMDSTG$)
  .OR.($M$.EQ.$DSMTRM$)
  .OR.($M$.EQ.$DSMNBCS$).OR.($M$.EQ.$*$)),LINKDST.
  LINDST,M,B,L,MAP,UN.
.ENDIF,LINKDST.
.IFE,(($M$.EQ.$DSMRUN$).OR.($M$.EQ.$*$)),LINKDSM.
  LINDSMR,M,B,L,MAP,UN.
.ENDIF,LINKDSM.
.IFE,(($M$.EQ.$IIAPAS$).OR.($M$.EQ.$*$)),LINKIAF.
  LINIAF,M,B,L,MAP,UN.
.ENDIF,LINKIAF.
.IFE,(($M$.EQ.$RHMPFP$).OR.($M$.EQ.$RHAQEP$)
  .OR.($M$.EQ.$*$)),LINKRHF.
  LINRHF,M,B,L,MAP,UN.
.ENDIF,LINKRHF.
.IFE,(($M$.EQ.$FMSLAVE$).OR.($M$.EQ.$*$)),LINKFMU.
  LINFMU,M,B,L,MAP,UN.
.ENDIF,LINKFMU.
SKIP,NOERROR.
  EXIT.
  .IFE,FILE(B,.NOT.AS),RET_B.
    UNLOAD,B.
  .ENDIF,RET_B.
  .IFE,FILE(CYBCLIB,.NOT.AS),RETCYBCLIB.
    UNLOAD,CYBCLIB.
  .ENDIF,RETCYBCLIB.
  .IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    EXIT. LINNOS PROCEDURE *TERMINATED*
  .ENDIF,TERMINATED.
  REVERT,ABORT. LINNOS PROCEDURE FAILED
ENDIF,NOERROR.
  .IFE,FILE(B,.NOT.AS),RET_B.
    UNLOAD,B.
  .ENDIF,RET_B.
  .IFE,FILE(CYBCLIB,.NOT.AS),RETCYBCLIB.
    UNLOAD,CYBCLIB.
  .ENDIF,RETCYBCLIB.
.IFE,$M$.EQ.$*$,LINKALL.
  REVERT. ALL MODULES LINKED
.ELSE,LINKALL.
  REVERT. MODULE M LINKED
.ENDIF,LINKALL.
/EOR
*DECK DECK=RAM$LINRHF EXPAND=TRUE
.PROC,LINRHF*I,
M "- Module name (or ALL or *)"        = (*N=*,ALL=*,*,RHAQEP,RHMPFP),
*IF ($string($name(wev$target_operating_system))='NOSBE')
B "- Binary input file name"           = (*N=NVERELB,*F),
L "- Library name for linked output"   = (*N=NBEBINS,*F),
*ELSE
B "- Binary input file name"           = (*N=NVERELS,*F),
L "- Library name for linked output"   = (*N=NOSBINS,*F),
*IFEND
MAP "- MAP file name"                  = (*N=LINKMAP,*F),
UN "- NOS/BE perm file ID"             = (*N=,*F),
.
.HELP
 The LINRHF procedure LINks the NOS 170 portion of the NOS/VE Remote Host
 Facility. Requires library CYBCLIB.

 Parameter   Default   Description
   Name       Value

  [m]          all     Module name being linked (or ALL or *)
*IF ($string($name(wev$target_operating_system))='NOSBE')
  [b]        nverelb   Binary input file containing the relocatable binaries
  [l]        nbebins   Library name to which the linked module is written
*ELSE
  [b]        nverels   Binary input file containing the relocatable binaries
  [l]        nosbins   Library name to which the linked module is written
*IFEND
  [map]      linkmap   File name to which the linkmap is written

.HELP,M
 The M parameter selects the module name to be linked. Either RHMPFP, RHAQEP,
 or ALL may be selected. The default is ALL 170 Remote Host modules.
.HELP,B
 The B parameter names the binary file containing the relocatable binaries.
*IF ($string($name(wev$target_operating_system))='NOSBE')
 The default value is NVERELB.
*ELSE
 The default value is NVERELS.
*IFEND
.HELP,L
 The L parameter specifies the library file to which the linked module
*IF ($string($name(wev$target_operating_system))='NOSBE')
 is written. The default value is NBEBINS.
*ELSE
 is written. The default value is NOSBINS.
*IFEND
.HELP,MAP
 The MAP parameter names the file to which the linkmap is written.
 The default value is LINKMAP.
.HELP,UN
 The UN parameter specifies a permanent file ID on NOS/BE systems. This
 parameter must not be specified on NOS.
.ENDHELP
.IF,SYS.EQ.NOSB,CHECKUN.
  .IF,$UN$.EQ.$$,BADUN.
    NOTE(OUTPUT); THE #UN PARAMETER MUST BE SPECIFIED.
    REVERT,ABORT.
  .ENDIF,BADUN.
.ELSE,CHECKUN.
  .IF,$UN$.NE.$$,BADUN2.
    REVERT,ABORT. NO UN PARAMETER ON NOS
  .ENDIF,BADUN2.
.ENDIF,CHECKUN.
.IFE,FILE(B,.NOT.AS),GET_B.
  GETFILE,B,B,UN,READ,A=YES.
.ENDIF,GET_B.
.IF,SYS.EQ.NOS,NOSSYS.
  $GTR(B,YYYYREL)REL/*
  $UNLOAD,B.
  $LIBEDIT,P=0,N=B,I=0,#B=YYYYREL,#L=0,U=B,NX=1.
  $UNLOAD,YYYYREL.
.ENDIF,NOSSYS.
.IFE,FILE(CYBCLIB,.NOT.AS),GETCYBCLIB.
  GETFILE,CYBCLIB,CYBCLIB,UN.
.ENDIF,GETCYBCLIB.
.IFE,(($M$.EQ.$RHMPFP$).OR.($M$.EQ.$*$)),GETRHMPFP.
  NOTE(OUTPUT,NR)+ LINKING RHMPFP
  .IFE,SYS.EQ.NOS,NOSRHP.
    $LDSET(#MAP=SBEX/MAP,LIB=B/CYBCLIB,PRESET=ZERO)
  .ELSE,NOSRHP.
    LDSET(#MAP=SBEX/MAP,LIB=CYBCLIB,PRESET=ZERO)
  .ENDIF,NOSRHP.
  SLOAD(B,RHAPFP)
  SLOAD(B,RHMPFP,RHM7ML,CYBMLI)
  SLOAD(B,TESTNBE,DSACYIF,RHACPM,RHMLIO,RHMLGM,RHMPMC,RHMWIT,RHABEIO)
*IF ($string($name(wev$target_operating_system))='NOSBE')
  NOGO,YYYYABS,RHPPFP.
*ELSE
  $NOGO,YYYYABS,RHPPFP,$SSJ=$.
*IFEND
  REPLIB,YYYYABS,L,,UN.
  NOTE(OUTPUT,NR)+ MODULE RHMPFP --> L
.ENDIF,GETRHMPFP.
.IFE,(($M$.EQ.$RHAQEP$).OR.($M$.EQ.$*$)),GETRHAQEP.
  NOTE(OUTPUT,NR)+ LINKING RHMQEP
  .IFE,SYS.EQ.NOS,NOSQEP.
    $LDSET(#MAP=SBEX/MAP,LIB=B/CYBCLIB,PRESET=ZERO)
  .ELSE,NOSQEP.
    LDSET(#MAP=SBEX/MAP,LIB=CYBCLIB,PRESET=ZERO)
  .ENDIF,NOSQEP.
  SLOAD(B,RHAQEP)
  SLOAD(B,RHMQEP,CYBMLI,RHM7ML)
  SLOAD(B,RHMMLI,RHMQFR,RHMRTF,RHMQFT)
  SLOAD(B,TESTNBE,DSACYIF,RHAQAC,RHQXFER,RHMQFA,RHMCLS)
  SLOAD(B,RHMLGM,RHMOPN,RHMQRF,RHMWIT,RHAQFM,RHAQRM)
*IF ($string($name(wev$target_operating_system))='NOSBE')
  NOGO,YYYYABS,RHPQEP.
*ELSE
  $NOGO,YYYYABS,RHPQEP,$SSJ=$.
*IFEND
  REPLIB,YYYYABS,L,,UN.
  NOTE(OUTPUT,NR)+ MODULE RHMQEP --> L
.ENDIF,GETRHAQEP.
SKIP,NOERROR.
  EXIT.
  UNLOAD,YYYYREL,YYYYABS.
  .IFE,FILE(B,.NOT.AS),RET_B.
    UNLOAD,B.
  .ENDIF,RET_B.
  .IFE,FILE(CYBCLIB,.NOT.AS),RETCYBCLIB.
    UNLOAD,CYBCLIB.
  .ENDIF,RETCYBCLIB.
  .IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    EXIT. LINRHF PROCEDURE *TERMINATED*
  .ENDIF,TERMINATED.
  REVERT,ABORT. LINRHF PROCEDURE FAILED
ENDIF,NOERROR.
.IFE,FILE(B,.NOT.AS),RET_B.
  UNLOAD,B.
.ENDIF,RET_B.
.IFE,FILE(CYBCLIB,.NOT.AS),RETCYBCLIB.
  UNLOAD,CYBCLIB.
.ENDIF,RETCYBCLIB.
.IFE,$M$.EQ.$*$,LINKALL.
  REVERT. LINKED 170 RHF --> L
.ELSE,LINKALL.
  REVERT. LINKED M --> L
.ENDIF,LINKALL.
/EOR
*DECK DECK=RAM$LINUTIL EXPAND=TRUE
.PROC,LINUTIL*I,
M "- Module name (or ALL or *)"          = (*N=*,ALL=*,*,EXTRACT),
*IF ($string($name(wev$target_operating_system))='NOSBE')
B "- Binary input file name"             = (*N=NVERELB,*F),
L "- Library name for linked output"     = (*N=NVELIBB,*F),
*ELSE
B "- Binary input file name"             = (*N=NVERELS,*F),
L "- Library name for linked output"     = (*N=NVELIB,*F),
*IFEND
MAP "- MAP file name"                    = (*N=LINKMAP,*F),
UN "- NOS/BE perm file ID"               = (*N=,*F),
.
.HELP
 The LINUTIL procedure links the dual state utility routines.
 Requires library CYBCLIB.

 Parameter   Default   Description
   Name       Value

  [m]          all     Module name being linked (or ALL or *).
*IF ($string($name(wev$target_operating_system))='NOSBE')
  [b]        nverelb   Binary relocatable input file name.
  [l]        nvelibb   Library name to which the linked module is written.
*ELSE
  [b]        nverels   Binary relocatable input file name.
  [l]        nvelib    Library name to which the linked module is written.
*IFEND
  [map]      linkmap   File name to which the linkmap is written.
  [un]                 Permanent file ID for NOS/BE version.

.HELP,M
 The M parameter selects the module name to be linked. Either EXTRACT or
 ALL may be specified. The default is ALL utility routines.
.HELP,B
 The B parameter specifies the binary file containing the relocatable
*IF ($string($name(wev$target_operating_system))='NOSBE')
 binaries.  The default value is NVERELB.
*ELSE
 binaries. The default value is NVERELS.
*IFEND
.HELP,L
 The L parameter specifies the library file to which the linked module is
*IF ($string($name(wev$target_operating_system))='NOSBE')
 written.  The default value is NVELIBB.
*ELSE
 written. The default value is NVELIB.
*IFEND
.HELP,MAP
 The MAP parameter specifies the file to which the link map is written.
 The default value is LINKMAP.
.HELP,UN
 The UN parameter specifies a permanent file ID on NOS/BE systems. This
 parameter must not be specified on NOS.
.ENDHELP
.IF,SYS.EQ.NOSB,CHECKUN.
  .IF,$UN$.EQ.$$,BADUN.
    NOTE(OUTPUT); THE #UN PARAMETER MUST BE SPECIFIED.
    REVERT,ABORT.
  .ENDIF,BADUN.
.ELSE,CHECKUN.
  .IF,$UN$.NE.$$,BADUN2.
    REVERT,ABORT. THE #UN PARAMETER MUST NOT BE SPECIFIED
  .ENDIF,BADUN2.
.ENDIF,CHECKUN.
.IFE(FILE(B,.NOT.AS),GETB)
  GETFILE(B,B,UN,READ,YES)
  SKIP(BINOK)
    EXIT.
    REVERT(ABORT) LINK FAILED - NO FILE B
  ENDIF(BINOK)
.ENDIF(GETB)
.IF,SYS.EQ.NOS,NOSSYS.
  $GTR(B,YYYYREL)REL/*
  $UNLOAD(B)
  $LIBEDIT(P=0,N=B,I=0,#B=YYYYREL,#L=0,U=B,NX=1)
  $UNLOAD(YYYYREL)
.ENDIF,NOSSYS.
.IFE(FILE(CYBCLIB,.NOT.AS),GETCYBCLIB)
  GETFILE(CYBCLIB,CYBCLIB,UN,READ)
  IFE(FILE(CYBCLIB,.NOT.AS),NOLIB)
    UNLOAD(B)
    REVERT(ABORT) LINK FAILED NO CYBCLIB
  ENDIF(NOLIB)
.ENDIF(GETCYBCLIB)
.IFE((($M$.EQ.$EXTRACT$).OR.($M$.EQ.$*$)),EXTRACT)
  NOTE(OUTPUT,NR)+ LINKING EXTRACT
  .IFE,SYS.EQ.NOS,NOSEXT.
    $LDSET(#MAP=SBEX/MAP,LIB=B/CYBCLIB,PRESET=ZERO)
  .ELSE,NOSEXT.
    LDSET(#MAP=SBEX/MAP,LIB=CYBCLIB,PRESET=ZERO)
  .ENDIF,NOSEXT
  SLOAD(B,EXTRACT,MEXTRAC)
  NOGO(YYYYABS,EXTRACT,$RFL=$,$SDM=$)
  REPLIB(YYYYABS,L,,UN)
  SKIP(EXTRACTOK)
    EXIT.
    UNLOAD(CYBCLIB,B,L)
    REVERT(ABORT) LINK FAILED B --> L SEE MAP
  ENDIF(EXTRACTOK)
.ENDIF(EXTRACT)
.IFE(FILE(B,.NOT.AS),RETB)
  UNLOAD(B)
.ENDIF(RETB)
.IFE(FILE(CYBCLIB,.NOT.AS),RETCYBCLIB)
  UNLOAD(CYBCLIB)
.ENDIF(RETCYBCLIB)
.IFE($M$.EQ.$*$,LINKALL)
  REVERT. LINKED UTILITIES --> L
.ELSE(LINKALL)
  REVERT. LINKED M --> L
.ENDIF(LINKALL)
/EOR
*DECK DECK=RAM$LISHELP EXPAND=TRUE
.PROC,LISHELP*I,
P "- Procedure name (or ALL or *)"     = (ALL=*,*,*F),
L "- Library file name"                = (*N=#FILE,*F),
UN "- User Name containing library"    = (*N=,*F),
O "- Output file name"                 = (*N=OUTPUT,*F),
LO "- List Option"                     = (*N=L,FULL=L,F=L,BRIEF=S,B=S,
                                               TXTCODE=T,T),
.
.HELP
 The LISHELP procedure LISts HELP documentation from a procedure.
 Requires XEDIT binaries installed on NOS system.

 Parameter   Default   Description
   Name       Value

   p                   procedure name to list (or ALL or *)
  [l]                  library file containing the procedure(s)
  [un]                 user name in which library resides
  [o]        OUTPUT    local file to which output is listed
  [lo]         f       list option for help documentation
.HELP,P
 The P parameter selects the procedure name to list.
.HELP,L
 The L parameter names the file containing a library of procedures.
 The default value is the file containing this procedure.
.HELP,UN
 The UN parameter specifies the User Name location of the file.
 The default value is the User Name in which this procedure executes.
.HELP,O
 The O parameter names a local file to which procedure(s) are listed.
 The default value is OUTPUT.
.HELP,LO
 The LO parameter selects the list option used.
 Options are : B | BRIEF  - for brief output (procedure help only)
               F | FULL  - for full output (includes parameter help)
 The default value is FULL.
.ENDHELP
GETPROC,P,L,UN,G=YYYYGRP.
BEGIN,UPDATIM,UPDATIM,DATE+,TIME+.
$UNLOAD,UPDATIM.
$REWIND,YYYYED1,YYYYED2,YYYSCR3.
XEDIT,YYYYGRP,I=YYYYED1,#L=0,AS.
XEDIT,YYYSCR1,I=YYYYED2,#L=0,AS.
$SKIPEI,YYYSCR3.
$COPYEI,YYYSCR1,YYYSCR3.
$PACK,YYYSCR3.
  $COPYEI,YYYSCR3,O.
$UNLOAD,YYYYGRP,YYYYED1,YYYYED2,YYYSCR1,YYYSCR2,YYYSCR3.
$SKIP,NOERROR.
  $EXIT.
  $UNLOAD,YYYYGRP,YYYYED1,YYYYED2,YYYSCR1,YYYSCR2,YYYSCR3.
  $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    $EXIT. LISHELP *TERMINATED*
  $ENDIF,TERMINATED.
  $REVERT,ABORT. LIST OF L FAILED
$ENDIF,NOERROR.
$REVERT. LIST HELP --> O
.DATA,YYYYED1
WM,1,6
Y$LW/.PROC,/$LW/.PROC,/0$CW/.PROC,/\ THE /$+A$ CCL PROCEDURE$B$-
C/*I,/ INTERACTIVE/*
C/*I/ INTERACTIVE/*
C/*M,/ MENU/*
C/*M/ MENU /*
Y$LW/\ THE/$LW/\ THE/0$COPYD,YYYSCR1$LW/HELP/$LW/HELP/0$/COPYD,YYYSCR1,/ENDH/$-
END
.DATA,YYYYED2
WM,1,1
CW// /*
WM,1,3
.IFE,$LO$.NE.$T$,NO_TXTCODE.
CW/ \ /- ** /*
.ELSE,NO_TXTCODE.
CW/ \ /\ 3 /*
.ENDIF,NO_TXTCODE.
.IFE,$LO$.EQ.$S$,BRIEFOPT.
Y$XL/.HELP/$XL/.HELP/0$COPYD,YYYSCR2,/.ENDH/$-
.ELSE,BRIEFOPT.
Y$XL/.ENDHELP/$XL/.ENDHELP/0$D$+IB$ $-
Y$XL/.HELP/$XL/.HELP/0$D$+IB$ $-
.ENDIF,BRIEFOPT.
END
.DATA,UPDATIM
.PROC,UPDATIM,DATEVAL,TIMEVAL.
$REVERT,NOLIST.
#.DATA,YYYSCR3
.IFE,$LO$.NE.$T$,NO_TXTCODE.
1 COPYRIGHT CONTROL DATA SYSTEMS INC 1992
  NOS/VE 1.0   - NOS USER LIBRARY MAINTENANCE PROCEDURES

.IFE,$P$.EQ.$*$,ALLPROCS.
  .IFE,$LO$.EQ.$S$,BRIEF.
-BRIEF HELP LISTING OF ALL L PROCEDURES - UN DATE: DATEVAL TIME: TIMEVAL
  .ELSE,BRIEF.
-FULL HELP LISTING OF ALL L PROCEDURES - UN DATE: DATEVAL TIME: TIMEVAL
  .ENDIF,BRIEF.
.ELSE,ALLPROCS.
  .IFE,$LO$.EQ.$S$,BRIEF.
-BRIEF HELP LISTING OF L PROCEDURE P - UN DATE: DATEVAL TIME: TIMEVAL
  .ELSE,BRIEF.
-FULL HELP LISTING OF L PROCEDURE P - UN DATE: DATEVAL TIME: TIMEVAL
  .ENDIF,BRIEF.
.ENDIF,ALLPROCS.

.ELSE,NO_TXTCODE.
\\FORMAT,03,75
\MARGIN03
\LENGTH75
\AUTOSEC
\TABLCON
\ASIS
\ 1 FILE L HELP DOCUMENTATION, DATE: DATEVAL TIME: TIMEVAL
.ENDIF,NO_TXTCODE.
/EOR
*DECK DECK=RAM$LISPROC EXPAND=TRUE
.PROC,LISPROC*I,
P "- Procedure name (or ALL or *)"     = (ALL=*,*,*F),
L "- Library file name"                = (*N=#FILE,*F),
UN "- User Name containing library"    = (*N=,*F),
O "- Output file name"                 = (*N=OUTPUT,*F),
.
.HELP
 The LISPROC procedure LISts PROCedures from a library file.
 Requires CATALOG binaries with GENCAT entry point.

 Parameter   Default   Description
   Name       Value

   p                   procedure name to list (or ALL or *)
  [l]                  library file containing the procedure(s)
  [un]                 user name in which library resides
  [o]        OUTPUT    local file to which output is listed

.HELP,P
 The P parameter selects the procedure name to list.
.HELP,L
 The L parameter names the file containing a library of procedures.
 The default value is the file containing this procedure.
.HELP,UN
 The UN parameter specifies the User Name location of the file.
 The default value is the User Name in which this procedure executes.
.HELP,O
 The O parameter names a local file to which procedures are listed.
 The default value is OUTPUT.
.ENDHELP
GETPROC,P,L,UN,G=YYYYGRP.
$NOTE,YYYYCAT,NR.+1  PROCEDURES LISTED FROM LIBRARY L - UN+ +
DISLIB,ALL,,YYYYGRP,UN,YYYYCAT,DO=BRIEF.
$PACK,YYYYCAT.
$COPYBR,YYYYCAT,YYYYTMP.
GENLSTF(YYYYGRP,YYYYTMP,,CS612,CS612)
DISLIB,ALL,,L,UN,YYYYTMP,DO=FULL.
$PACK,YYYYTMP,O.
$UNLOAD,YYYYTMP,YYYYCAT,YYYYGRP.
$SKIP,NOERROR.
  $EXIT.
  $UNLOAD,YYYYTMP,YYYYCAT,YYYYGRP.
  $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    $EXIT. LISPROC *TERMINATED*
  $ENDIF,TERMINATED.
  $REVERT,ABORT. LIST OF L FAILED
$ENDIF,NOERROR.
.IFE,$P$.EQ.$*$,LISTALL.
  $REVERT. ALL L PROCEDURES --> O
.ELSE,LISTALL.
  $REVERT. PROC P FROM L --> O
.ENDIF,LISTALL.
/EOR
*DECK DECK=RAM$LISTEXT EXPAND=TRUE
.PROC,LISTEXT*I,
T "- Text record name (or ALL or *)"   = (ALL=*,*,*F),
L "- Library file name"                = (*N=#FILE,*F),
UN "- User Name containing library"    = (*N=,*F),
O "- Output file name"                 = (*N=OUTPUT,*F),
.
.HELP
 The LISTEXT procedure LISts TEXT records from a library file.
 Requires CATALOG binaries with GENCAT entry point.

 Parameter   Default   Description
   Name       Value

   t                   TEXT record name to list (or ALL or *)
  [l]                  library file containing the TEXT record
  [un]                 user name in which library resides
  [o]        OUTPUT    local file to which output is listed

.HELP,T
 The T parameter selects the TEXT record name to list.
.HELP,L
 The L parameter names the file containing a library of TEXT records.
 The default value is the file containing this procedure.
.HELP,UN
 The UN parameter specifies the User Name location of the file.
 The default value is the User Name in which this procedure executes.
.HELP,O
 The O parameter names a local file to which TEXT records are listed.
 The default value is OUTPUT.
.ENDHELP
GETTEXT,T,L,UN,G=YYYYGRP.
$NOTE,YYYYCAT,NR.+1  TEXT RECORDS LISTED FROM LIBRARY L - UN+ +
DISLIB,ALL,,YYYYGRP,UN,YYYYCAT,DO=BRIEF.
$PACK,YYYYCAT.
$COPYBR,YYYYCAT,YYYYTMP.
GENLSTF(YYYYGRP,YYYYTMP,,CS612,CS612)
DISLIB,ALL,,L,UN,YYYYTMP,DO=FULL.
$PACK,YYYYTMP,O.
$UNLOAD,YYYYTMP,YYYYCAT,YYYYGRP.
$SKIP,NOERROR.
  $EXIT.
  $UNLOAD,YYYYTMP,YYYYCAT,YYYYGRP.
  $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    $EXIT. LISTEXT *TERMINATED*
  $ENDIF,TERMINATED.
  $REVERT,ABORT. LIST OF L FAILED
$ENDIF,NOERROR.
.IFE,$T$.EQ.$*$,LISTALL.
  $REVERT. ALL L TEXT --> O
.ELSE,LISTALL.
  $REVERT. TEXT T FROM L --> O
.ENDIF,LISTALL.
/EOR
*DECK DECK=RAM$LIST_COMMAND_INFORMATION EXPAND=TRUE
PROCEDURE (ram$lisci) list_command_information, lisci (
  entry, entries, e: list of any of
      key
        all
        (control_statements, control_statement, cs)
        (first, f)
        $system
      keyend
      name
      file
    anyend = first
  output, o: file = $output
  display_options, display_option, do: list of key
      all
      (all_names, all_name, an)
      (source, s)
      (brief_help, bh)
      (full_help, fh)
      (compact_parameter_descriptions, compact_parameter_description, cpd)
      (parameter_descriptions, parameter_description, pd)
      (parameter_help, ph)
      (advanced_usage, au)
    keyend = osd$disci_display_options, (compact_parameter_descriptions, advanced_usage)
  list_options, list_option, lo: list of key
      all
      (commands_only, co)
      (functions_only, fo)
    keyend = all
  page_width, pw: (BY_NAME, ADVANCED) integer 60..132 = 80
  page_length, pl: (BY_NAME, ADVANCED) integer 16..6000 = 60
  index_when_pages_equal, iwpe: (BY_NAME, ADVANCED) integer 1..$max_integer = 4
  status)

" PURPOSE:
"   List all command and function names and parameters from one or several command list entries.
" DESIGN:
"   Use display_command_list_entry to produce a list of command and function names. Read this list of command
"   and function names, and execute the display_command_information or display_function_information command
"   to produce a list of parameter descriptions.
" NOTES:
"   Excessive pagination is avoided while retaining parameter descriptions on the same page on which they
"   started. An index is produced only when the index_when_pages_equal value is exceeded. Both the
"   primary output and index are forced to an even number of pages for two-sided listing purposes.

"$format=no
  VAR
    all_commands: file = $unique(:$local)
    commands_found: boolean
    command_list: list 0 .. page_length/4 of string = ()
    command_list_entry: string
    command_names: list 0 .. $max_list of string
    disci_path: string = ''
    entry_is_a_file: boolean
    functions_found: boolean
    ignore: status
    index: file = $unique(:$local)
    instant: file = $unique(:$local)
    lines_written: integer = page_length
    page_number: integer = 1
    parameter_list: list 0 .. $max_list of string
    parameters: file = $unique(:$local)
    previous_command: string
    sorted_index: file = $unique(:$local)
    title: string = $justify('1'//$processor(model, 0)//'/'//$processor(serial, 0)//'  '//$job(os_version)//..
'  '//$date(iso)//'  '//$time(hms), page_width-10, left)
  VAREND
"$format=yes

" Delete all procedure created files upon procedure termination.
  WHEN exit DO
    $system.delete_file file=all_commands status=ignore
    $system.delete_file file=instant status=ignore
    $system.delete_file file=index status=ignore
    $system.delete_file file=parameters status=ignore
    $system.delete_file file=sorted_index status=ignore
  WHENEND

" Establish file connections and file attributes for temporary files.
  PUSH file_connections
  $system.create_file_connection standard_file=$errors file=parameters
  $system.set_file_attributes file=parameters page_format=continuous open_position=$asis pw=page_width-4
  $system.set_file_attributes file=instant file_content=list page_format=continuous pw=page_width
  $system.set_file_attributes file=all_commands file_content=legible page_format=continuous pw=$max_string

  IF list_option = commands_only THEN
    display_command_list_entry entry=entry display_option=(commands all_names) output=all_commands
  ELSEIF list_option = functions_only THEN
    display_command_list_entry entry=entry display_option=(functions all_names) output=all_commands
  ELSE
    display_command_list_entry entry=entry display_option=list_option output=all_commands
  IFEND

  get_lines variable=command_names input=all_commands

" Process each command and function name in the specified command list entries
  FOR EACH command_name IN $select(command_names, x<>' ') DO
    CYCLE WHEN $substring(command_name, 1, 2) = '--'
    IF $substring(command_name, 1, 5) = 'ENTRY' THEN
" Found the beginning of a command list entry, prepare to process the entry contents.
      CYCLE WHEN command_list_entry = command_name(7, all)
      command_list_entry = command_name(7, all)
      put_line line=' Processing entry: '//command_list_entry output=$response
      commands_found = no
      functions_found = no
      lines_written = page_length
      entry_is_a_file = no
      include_command 'entry_is_a_file = $file($fname(command_list_entry), assigned)' status=ignore
      IF entry_is_a_file THEN
        disci_path = command_list_entry // '.'
      ELSEIF $scan_string('$system', command_name)<> 0 THEN
        disci_path = '$system.'
      ELSE
        disci_path = ''
      IFEND
      CYCLE WHEN $size(command_list)> page_length/4
      command_list = $add($justify(command_list_entry, page_width-10, left)//'Page '//page_number, ..
            command_list)
      CYCLE
    ELSEIF $substring(command_name, 1, 8) = 'Commands' THEN
" Found the beginning of a list of command names and aliases.
      commands_found = yes
      functions_found = no
      lines_written = page_length
      CYCLE
    ELSEIF $substring(command_name, 1, 9) = 'Functions' THEN
" Found the beginning of a list of parameter names and aliases.
      commands_found = no
      functions_found = yes
      lines_written = page_length
      CYCLE
    ELSEIF $substring(command_name, 1, 16) = 'Control Commands' THEN
" Found the beginning of the list of SCL control commands.
      command_list_entry = ' '//command_name
      put_line line=' Processing commands from entry: '//command_list_entry output=$response
      commands_found = yes
      functions_found = no
      lines_written = page_length
      disci_path = ''
      CYCLE WHEN $size(command_list)> page_length/4
      command_list = $add($justify(command_list_entry, page_width-10, left)//'Page '//page_number, ..
            command_list)
      CYCLE
    ELSEIF $substring(command_name, 1, 25) = 'System Supplied Functions' THEN
" Found the beginning of the list of SYSTEM functions.
      command_list_entry = ' '//command_name
      put_line line=' Processing functions from entry: '//command_list_entry output=$response
      commands_found = no
      functions_found = yes
      lines_written = page_length
      CYCLE WHEN $size(command_list)> page_length/4
      command_list = $add($justify(command_list_entry, page_width-10, left)//'Page '//page_number, ..
            command_list)
      CYCLE
    IFEND
    CYCLE WHEN NOT (commands_found OR functions_found)
" Display parameter information and/or loader errors (via $ERRORS connection) to the parameters file.
    put_line line=' ' output=parameters.$boi
    $system.rewind_file file=parameters
    IF functions_found THEN
      put_line line='     -- FUNCTION -- '//$trim($substring(command_name, 1, 31)) output=$response
      display_function_information $name($substring(command_name, 1, 31)) display_option=display_option ..
            output=parameters status=ignore
    ELSE
      put_line line='     -- COMMAND  -- '//$trim($substring(command_name, 1, 31)) output=$response
      include_command command='display_command_information '//disci_path//..
$substring(command_name, 1, 31)//' display_option=display_option output=parameters status=ignore'
    IFEND
    IF NOT ignore.normal THEN
      display_value ignore output=parameters
    IFEND
    $system.change_file_attributes file=parameters ring_attributes=($ring $ring $ring) "Needed within EDIPC
    $system.rewind_file file=parameters
    get_lines variable=parameter_list input=parameters
" Remove unwanted lines from beginning of parameter_list
    FOR EACH parameter IN parameter_list DO
      IF (parameter = ' ') OR ($scan_string('Parameters:', parameter)<> 0) THEN
        parameter_list = $rest(parameter_list)
      ELSE
        EXIT
      IFEND
    FOREND
" Check whether to continue on the current page.
    IF (lines_written > page_length-6) AND ($size(parameter_list)> 4) THEN "start a new page"
      lines_written = page_length
    IFEND
    IF (lines_written >= page_length) THEN " start command display on new page"
      put_lines lines=(title//'Page '//page_number, ' ENTRY: '//command_list_entry, ' ') output=instant.$eoi
      lines_written = 3
      page_number = page_number + 1
    IFEND
" Write the command/function and alias names first, followed by the parameter information.
    display_value value=command_name//' ' output=instant.$eoi
    lines_written = lines_written + $size(' '//command_name//' ')/page_width + 1
    put_line line=command_name output=index.$eoi
    FOR EACH parameter IN parameter_list DO
      IF $mod(lines_written, (page_length)) = 0 THEN " start parameter display on new page"
        put_lines lines=(title//'Page '//page_number, ' ENTRY: '//command_list_entry, ' ') output=instant.$eoi
        lines_written = 3
        page_number = page_number + 1
      IFEND
      display_value value='  '//parameter output=instant.$eoi
      lines_written = lines_written + $size('   '//parameter)/page_width + 1
    FOREND
" If room remains on current page, insert a blank line to separate this command from the next one.
    IF (page_length - lines_written)> 2 THEN
      put_line line=' ' output=instant.$eoi
      lines_written = lines_written + 1
    ELSE
      lines_written = page_length
    IFEND
  FOREND

" Write the existing information to the output file.
  $system.copy_file input=instant output=output status=ignore
  IF $mod(page_number, 2) = 0 THEN
    put_line line='1' output=output.$eoi "Blank line for two-page"
  IFEND

" When enough pages of information have been created, produce an index. Exit the procedure otherwise.
  EXIT_PROC WHEN page_number < index_when_pages_equal
  put_line line=' Generating command index' output=$response

" Split the alias names onto lines separate from the primary command name.
  TASK " Start new task to guarantee only one editor session per current task
    $system.edit_file file=index output=$null prolog=$null
    "$command=EDIT_FILE
      REPEAT
        IF $size($line_text)> 32 THEN
          break_text line=current column=33
          position_forward number=1
          replace_text text=' ' new_text='' number=all line=current status=ignore
          position_cursor column=1 line=current
          REPEAT
            position_cursor text=',' line=current number=1 status=ignore
            IF ignore.normal THEN
              break_text line=current column=current
              position_forward number=1
              replace_text text=',' new_text='' number=1 line=current
            IFEND
          UNTIL NOT ignore.normal
        IFEND
        position_forward number=1 status=ignore
      UNTIL NOT ignore.normal
    QUIT write_file=yes
  TASKEND

" Find the page number on which every command/function name or alias is referenced.
  TASK
    $system.edit_file file=instant output=$null prolog=$null
    "$command=EDIT_FILE
      get_line variable=command_names input=index
      $system.delete_file file=index status=ignore
      FOR EACH command_name IN command_names DO
        position_cursor text=command_name number=1 line=current..last status=ignore
        IF ignore.normal THEN
          position_cursor text=title direction=backward number=1 status=ignore
          put_line line=$justify($justify(command_name//' ', page_width-28, left, '.'), page_width-24, ..
                right)//$substring($line_text, page_width-10, 10) output=index.$eoi
        IFEND
      FOREND
    QUIT write_file=no
  TASKEND

  put_line line=' Sorting index by command name' output=$response
  $system.sort from=index to=sorted_index key=1..60 list=$null error=$null
  put_line line=' Writing command index' output=$response
  command_list = $reverse(command_list)

" Add page numbers to the index.
  TASK
    $system.edit_file file=sorted_index output=$null prolog=$null
    "$command=EDIT_FILE
      lines_written = page_length
      page_number = 1
      REPEAT
        IF lines_written >= page_length THEN
          put_lines lines=(title//'Index '//page_number, ' ') output=output.$eoi
          put_line line=$apply(command_list, x) output=output.$eoi
          put_line line=' ' output=output.$eoi
          lines_written = $size(command_list) + 3
          page_number = page_number + 1
        IFEND
        IF previous_command = $substring($line_text, 6, 31) THEN
          put_line line=$line_text//' <== Duplicate' output=output.$eoi
        ELSE
          put_line line=$line_text output=output.$eoi
        IFEND
        previous_command = $substring($line_text, 6, 31)
        lines_written = lines_written + 1
        position_forward number=1 status=ignore
      UNTIL NOT ignore.normal
    QUIT write_file=no
  TASKEND

  IF $mod(page_number, 2) = 0 THEN
    put_line line='1' output=output.$eoi "Blank line for two-page"
  IFEND

PROCEND list_command_information
*DECK DECK=RAM$LIST_LEGIBLE_FILES EXPAND=TRUE
PROCEDURE list_legible_file, list_legible_files, lislf (
  file, files, f: any of
      key
        all
      keyend
      list 1..$max_list of file
    anyend = all
  output, o: file = $output
  include_line_numbers, iln: boolean = FALSE
  page_length, pl: (BY_NAME, ADVANCED) integer 1..6000 = 60
  status)

  " PURPOSE:
  "   List the specified legible files.
  " DESIGN:
  "   Print the specified files with the text broken up into pages with page
  "   headers and page numbers.
  "   An option to print line numbers is provided.
  "   Based on procedure LIST_PROCEDURE_CONTENT in $system.osf$site_command_library.

  VAR
    blank_line: string = ' '
    date_time: string = $date(iso)//'  '//$time
    file_being_listed: file = $unique(:$local)
    file_created_time: string = ' '
    file_modified_time: string = ' '
    files_list: list 0..$max_list of file = ()
    header: integer = 3
    ignore: status
    line_number: integer = 0
    lines_to_print: integer = 0
    listed_file_contents: list 0..$max_list of string
    number_of_files: integer = 0
    number_of_lines_per_page: integer = page_length - header
    legible_file_output: file = $unique(:$local)
    page_number: integer = 0
    title_line1: string = ' '
    title_line2: string = ' '
    total_lines: integer = 0
  VAREND

  WHEN exit DO
    detach_file file=legible_file_output status=ignore
  WHENEND

"Set necessary file attributes

  set_file_attributes file=legible_file_output file_content=list open_position=$asis

"Determine the file(s) to be listed.

  IF $generic_type(file) = 'KEY' THEN "list all files
    IF $string($working_catalog) = ':$LOCAL' THEN
      put_line line=(' ', '  The requested operation cannot be performed for files in $LOCAL catalog') ..
            output=$response
      EXIT PROCEDURE
    IFEND
    files_list = $wild_card_files(*)
  ELSE
    files_list = $parameter_value(file)
  IFEND

  FOR EACH file_being_listed IN files_list DO
    IF $path(file_being_listed, catalog) = ':$LOCAL' THEN
      put_line line=(' ', '  The requested operation cannot be performed for files in $LOCAL catalog') ..
            output=$response
      CYCLE
    ELSEIF $file_attributes(file_being_listed, object_type)(1).object_type = catalog THEN
      put_line line= (' ', $string(file_being_listed)//' not processed because it is a catalog') ..
            output=$response
      CYCLE
    ELSEIF $file_attributes(file_being_listed, file_contents)(1).file_contents <> legible_data THEN
      put_line line= (' ', $string(file_being_listed)//' not processed because it is not a legible file') ..
            output=$response
      CYCLE
    IFEND

    put_line line=(' Processing file '//$string(file_being_listed)//'...') output=$response

    file_created_time = $string($file_attributes(file_being_listed, creation_date_time)(1).creation_date_time)
    file_modified_time = $string(..
          $file_attributes(file_being_listed, last_modification_date_time)(1).last_modification_date_time)

    line_number = 0
    lines_to_print = 0

"  read the whole file

    get_lines variable=listed_file_contents input=file_being_listed.$asis line_count=lines_to_print
    WHILE line_number < lines_to_print DO
      IF ($mod(line_number, number_of_lines_per_page) = 0) THEN
        page_number = page_number + 1
        title_line1 = '1 LIST OF '//..
$justify($string(file_being_listed), 85, left)//'  '//date_time//'  PAGE '//$justify($string(page_number), 5..
, left)
        title_line2 = '          Created: '//file_created_time//'  Last Modified:'//file_modified_time
        put_lines lines=(title_line1, title_line2, blank_line) output=legible_file_output
      IFEND
      line_number = line_number + 1

      IF include_line_numbers THEN
        put_line line=' '//..
$justify($string(line_number), 5, right)//' '//$justify(listed_file_contents(line_number), 125, left) ..
              output=legible_file_output
      ELSE
        put_line line='  '//listed_file_contents(line_number) output=legible_file_output
      IFEND
    WHILEND

    number_of_files = number_of_files + 1
    total_lines = total_lines + lines_to_print
  FOREND " loop to next file in list of files being processed "

"Display final status.

  IF page_number = 0 THEN " no legible files"
    put_line line=(' ', '  No legible files in the file list') output=$response
  ELSE
    put_line line=(' ', '  Listed '//page_number//' pages containing '//total_lines//' lines and '//..
number_of_files//' files to '//$string(output)) output=$response
  IFEND

  rewind_file file=legible_file_output
  copy_file input=legible_file_output output=output status=status
  detach_file file=legible_file_output status=ignore

PROCEND list_legible_file
*DECK DECK=RAM$LIST_PROCEDURE_CONTENT EXPAND=TRUE
PROCEDURE (ram$lispc) list_procedure_content, list_procedure_contents, lispc (
  procedure, procedures, p: any of
      key
        all
      keyend
      list 1..$max_list of any of
        integer radix 16
        name
        string
      anyend
    anyend = all
  from, f, library, l: file = $working_catalog.command_library
  output, o: file = $output
  page_length, pl: (BY_NAME, ADVANCED) integer 1..6000 = 60
  status)

" PURPOSE:
"   List the specified modules from a libaray or object file.
" DESIGN:
"   Scan every module name on the library for each specified value. Write the selected modules to the
"   output file in alphabetical order.
" NOTES:
"   An integer procedure value is hexadecimal, convenient when processing CDCNET configuration procedures.
"   Creation dates are suppressed for object files.

"$format=no
  VAR
    blank_line:          string = ' '
    current_library:     file= from//$file(from, cycle_number)
    current_module:      name
    creation:            string = ' '
    first_page:          integer = 0
    ignore:              status
    index:               file = $unique(:$local)
    index_page:          integer = 0
    lines_in_procedure:  integer = 0
    lines_to_print:      integer = 0
    list_of_all_modules: file= $unique(:$local)
    list_status:         status
    modules_on_file:     list 0..$max_list of string = ()
    modules_to_display:  list 0..$max_list of string = ()
    number_of_pages:     integer = 0
    number_of_procedures: integer = 0
    out:                 file= $unique(:$local)
    page_length_used:    integer = page_length-3
    page_number:         integer = 0
    pages:               string
    procfile:            file= $unique(:$local)
    procedure_content:   array 1..page_length_used of string
    specified_name:      string 1..31
    system_information:  string = $justify($string($processor(model, 0)//'/'//$processor(serial, 0)//..
'  '//$job(os_version)//'     '//$date(iso)//'  '//$time), 72, center)
    total_lines:         integer = 0
    index_entry: (DEFER) string = '  '//$justify($string(number_of_procedures),4, right)//$trim(module)//..
$justify(pages, 110-$size($string($trim(module))), left, '.')//' PAGE '//$justify($string(first_page), 4, right, ' ')
    index_line1: (DEFER) string = '1 TABLE OF CONTENTS                             '//system_information//..
'INDEX '//$justify($string(index_page), 5, left)
    index_line2: (DEFER) string = '        LIBRARY: '//$string(current_library)
    title_line1: (DEFER) string = '1 SOURCE LIST OF '//$justify($translate(upper_to_lower,$string(current_module)), 31, left)//..
system_information//'PAGE '//$justify($string(page_number), 5, left)
    title_line2: (DEFER) string = '        LIBRARY: '//$string(current_library)//creation
  VAREND
"$format=yes

  WHEN exit DO
    delete_file index status=ignore
    delete_file list_of_all_modules status=ignore
    delete_file out status=ignore
    delete_file procfile status=ignore
  WHENEND

"Set necessary file attributes
  set_file_attributes file=index file_content=list open_position=$eoi
  set_file_attributes file=list_of_all_modules page_format=untitled open_position=$boi
  set_file_attributes file=out file_content=list open_position=$asis
  set_file_attributes file=procfile page_format=continuous open_position=$asis file_content=legible

"Get a list of all of the modules on the command_library.
  display_object_library library=from display_option=date_time alphabetical_order=yes ..
        output=list_of_all_modules
  get_line variable=modules_on_file input=list_of_all_modules
  delete_file file=list_of_all_modules

"Determine which modules are to be displayed.
  IF $generic_type(procedure)= 'KEY' THEN "display all procedures
    modules_to_display=$select(modules_on_file, $size(x)>0)
  ELSE "select the modules to display
    FOR EACH procedure_specified IN procedures DO
      IF $generic_type(procedure_specified)= integer THEN "CDCNET config proc
        specified_name=$integer_string(procedure_specified, 16)
      ELSE "a substring of the procedure name was specified
        specified_name=$string(procedure_specified)
      IFEND
      modules_to_display=$union(modules_to_display, ..
            $select(modules_on_file, $scan_string(specified_name, $substring(x, 1, 31))>0))
    FOREND
  IFEND

  PUSH file_connections
  create_file_connection $response index

"Display the appropriate information based module type.
  CREATE_OBJECT_LIBRARY
    FOR EACH module IN modules_to_display DO
      number_of_procedures=number_of_procedures + 1
      current_module=$name(module(2, 31))
      add_module library=current_library module=current_module
      rewind_file file=procfile
      IF $scan_string('procedure', module)<> 0 THEN
        generate_library library=procfile format=scl_proc
      ELSE
        display_new_library module=current_module display_option=all output=procfile
        delete_module module=current_module
        IF $scan_string('program description', module)<> 0 THEN
          display_command_information from//current_module output=procfile status=ignore
        IFEND
      IFEND

"Format the output.
      IF $file(current_library, fs)= 'LIBRARY' THEN
        creation='     PROCEDURE CREATED: '//module(58, all)
      ELSE
        creation=' '
      IFEND
      lines_in_procedure=0
      first_page=page_number+1
      rewind_file file=procfile
      get_lines variable=procedure_content input=procfile line_count=lines_to_print
      WHILE lines_to_print > 0 DO
        page_number=page_number + 1
        put_lines (title_line1, title_line2, blank_line) o=out
        FOR line= 1 TO lines_to_print DO
          put_line line='  '//procedure_content(line) output=out
        FOREND
        lines_in_procedure=lines_in_procedure+line
        get_lines variable=procedure_content input=procfile line_count=lines_to_print
      WHILEND

"Make an entry in the index.
      IF $mod(number_of_procedures, page_length_used)= 1 THEN
        index_page=index_page+1
        put_lines (index_line1, index_line2, blank_line) o=$response
      IFEND
      number_of_pages=(page_number - first_page) + 1
      pages=', '//$justify($integer_string(lines_in_procedure), 5, right)//' lines '
      IF number_of_pages > 1 THEN
        pages=pages//'on '//number_of_pages//' pages '
      IFEND
      put_line line=index_entry output=$response
      total_lines=total_lines + lines_in_procedure
    FOREND
  QUIT

"Display final status.
  IF page_number = 0 THEN " set value of list_status to 'file missing', 'not object library', etc.
    display_object_library library=current_cycle module=current_module status=list_status
  ELSE
    put_line line=(' ', '  Listed '//page_number//' pages containing '//total_lines//' lines and '//..
number_of_procedures//' procedures to '//$string(output)) output=$response
    rewind_file out
    copy_file out index status=ignore
    copy_file index.$boi output status=ignore
  IFEND

  EXIT_PROC WITH list_status

PROCEND list_procedure_content
*DECK DECK=RAM$LOAD_OPTIONS_ROUTINES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Load Options Routines:  Routines to Access System Initialization Control Values' ??
MODULE ram$load_options_routines;

{ PURPOSE:
{   This module contains the procedures that allow the accessing of the system initialization control
{   values from a higher ring.
{
{ NOTES:
{   These procedures compile to OSF$JOB_TEMPLATE_23D.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$task_shared
*copyc ost$name
*copyc ost$status
?? POP ??
*copyc rav$development_deadstart
*copyc rav$installation_tape_values
*copyc rav$network_activation
*copyc rav$system_activation
*copyc syv$recovering_job_count
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    rav$console_task_restarted: [XDCL, #GATE, oss$task_shared] boolean := FALSE;

?? TITLE := '[XDCL, #GATE] rap$get_console_task_status', EJECT ??

{ PURPOSE:
{   The purpose of this request is to return the value of whether or not the Console Interaction task been
{   restarted.  On the initial call to this interface the value returned will be FALSE.  Every subsequent
{   call will return the value as TRUE.

  PROCEDURE [XDCL, #GATE] rap$get_console_task_status
    (VAR task_restarted: boolean);

    task_restarted := rav$console_task_restarted;
    rav$console_task_restarted := TRUE;

  PROCEND rap$get_console_task_status;

?? TITLE := '[XDCL, #GATE] rap$get_development_ds_value', EJECT ??

{ PURPOSE:
{   The purpose of this request is to return the value of whether or not this is a development deadstart.
{   This value was set at system core time.

  PROCEDURE [XDCL, #GATE] rap$get_development_ds_value
    (VAR development_deadstart: boolean);

    development_deadstart := rav$development_deadstart;

  PROCEND rap$get_development_ds_value;

?? TITLE := '[XDCL, #GATE] rap$get_inst_tape_values', EJECT ??

{ PURPOSE:
{   The purpose of this request is to return the values set by the
{   SET_INSTALLATION_TAPE command.
{
{ DESIGN:
{   The SET_INSTALLATION_TAPE command is entered at system core time.
{   This procedure retrieves the SET_INSTALLATION_TAPE values.  Since
{   system core runs at a privileged rings, this procedure must also run
{   at the those rings.
{
{   NOTES:
{

  PROCEDURE [XDCL, #GATE] rap$get_inst_tape_values
    (VAR installation_tape_values: rat$installation_tape_values);

    installation_tape_values := rav$installation_tape_values;

  PROCEND rap$get_inst_tape_values;

?? TITLE := '[XDCL, #GATE] rap$get_jobs_recovered_value', EJECT ??

{ PURPOSE:
{   The purpose of this request is to return the value of whether or not there are jobs to be recovered.

  PROCEDURE [XDCL, #GATE] rap$get_jobs_recovered_value
    (VAR jobs_recovered: boolean);

    IF syv$recovering_job_count <> 0 THEN
      jobs_recovered := TRUE;
    ELSE
      jobs_recovered := FALSE;
    IFEND;

  PROCEND rap$get_jobs_recovered_value;

?? TITLE := '[XDCL, #GATE] rap$get_network_activate_value', EJECT ??

{ PURPOSE:
{   The purpose of this request is to return the value of whether or not the network is to be
{   automatically activated.  This value was set at system core time.

  PROCEDURE [XDCL, #GATE] rap$get_network_activate_value
    (VAR network_activation: boolean);

    network_activation := rav$network_activation;

  PROCEND rap$get_network_activate_value;

?? TITLE := '[XDCL, #GATE] rap$get_system_activation_value', EJECT ??

{ PURPOSE:
{   The purpose of this request is to return the value of whether or not the system should be
{   automatically activated.  This value was set at system core time.

  PROCEDURE [XDCL, #GATE] rap$get_system_activation_value
    (VAR system_activation: boolean);

    system_activation := rav$system_activation;

  PROCEND rap$get_system_activation_value;

MODEND ram$load_options_routines;
*DECK DECK=RAM$LOAD_PACKING_LIST EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$LOAD_PACKING_LIST Interface.' ??
MODULE ram$load_packing_list;

{ PURPOSE:
{   This module contains the interface and procedures that load the packing
{   list from an order.
{
{ DESIGN:
{   The interface is expected to be called by INSTALL_SOFTWARE and
{   PACKAGE_SOFTWARE command interfaces to perform the actual loading work.
{
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dme$tape_errors
*copyc rac$local_primary_tape
*copyc rac$packing_list_level
*copyc rac$tape_types
*copyc rae$install_software_cc
*copyc clt$parameter_value
*copyc fst$file_reference
*copyc rat$path
*copyc rat$packing_list_sequence
*copyc rat$sequence_descriptor_types
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc clp$include_line
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$convert_fs_structure_to_pf
*copyc fsp$detach_file
*copyc pfp$convert_string_to_fs_path
*copyc pfp$convert_fs_path_to_pf_path
*copyc pfp$define_catalog
*copyc pfp$purge
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc rap$open_file
*copyc rap$record_disk_path

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$load_packing_list', EJECT ??

{ PURPOSE:
{   This interface loads the packing list from a tailored product tape or
{   tailored disk file to the loading destination.
{
{ DESIGN:
{   This interface is called by the INSTALL_SOFTWARE and PACKAGE_SOFTWARE
{   LOAD_PACKING_LIST command interfaces.  It controls the process of
{   loading the packing list.  The disk and tape parameter value records
{   are passed through by the calling commmand interface.  The calling
{   command interface did not validate these parameters and expects the
{   validation to be done by this interface.
{
{   The destination path is analyized and any non-existing subcatalogs are
{   created prior to the loading.
{
{   Loading the packing list from tape is somewhat different than loading
{   from disk.  The appropriate loading interface is called to perform the
{   the actual loading based on which set of parameters was specified.
{
{   After loading a disk order packing list, the path to the disk file
{   just loaded from is recorded in the packing list.  This provides
{   an automated way of finding the products during installation (as long
{   as the disk file is not moved).
{
{ NOTES:
{   In the future a block exit handler will be provided to cleanup any file
{   that was loaded into the destination path prior to an abort condition.
{   Conceptually, this should be placed in the LOAD_PACKING_LIST_FROM_TAPE
{   and LOAD_PACKING_LIST_FROM_DISK directly.  But since this is a
{   duplication of code it is suggested that it be placed in this interface
{   around the calls to the disk or tape loading procedures.  The abort
{   procedure should make a call to the DELETE_FILE procedure (found in
{   this module) passing in the LOADING_DESTINATION file reference.
{

  PROCEDURE [XDCL] rap$load_packing_list
    (    external_vsn: clt$parameter_value;
         recorded_vsn: clt$parameter_value;
         tape_type: clt$parameter_value;
         disk_file: clt$parameter_value;
         loading_destination: fst$file_reference;
         unload_volume: boolean;
         removable_media_group: clt$parameter_value;
     VAR status: ost$status);


    status.normal := TRUE;

    validate_parameters (external_vsn, recorded_vsn, tape_type, disk_file, loading_destination, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    prepare_loading_destination (loading_destination, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (external_vsn.specified OR recorded_vsn.specified) THEN

      load_packing_list_from_tape (external_vsn, recorded_vsn, tape_type,
             loading_destination, unload_volume, removable_media_group, status);

    ELSE {disk_file specified}

      load_packing_list_from_disk (disk_file.value^.file_value^, loading_destination, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      rap$record_disk_path (disk_file.value^.file_value^, loading_destination, status);

    IFEND;

  PROCEND rap$load_packing_list;

?? TITLE := 'delete_file', EJECT ??

{ PURPOSE:
{   This procedure deletes the low cycle of the file specified.
{
{ DESIGN:
{   The file path is converted from file reference to PF file format so
{   that PFP$PURGE can be called to delete the file.
{
{ NOTES:
{   DJD is providing a replacement for CLP$EVALUATE_FILE_REFERENCE.
{
{   This may be worthwhile expanding.
{

  PROCEDURE delete_file
    (    file_path: fst$file_reference;
     VAR status: ost$status);


    VAR
      cycle_selector: pft$cycle_selector,
      fs_path: string (fsc$max_path_size),
      ignore_cycle_reference: fst$cycle_reference,
      ignore_cycle_selector: clt$cycle_selector,
      ignore_open_position: fst$open_position,
      ignore_status: ost$status,
      number_of_path_elements: fst$number_of_path_elements,
      password: pft$password,
      path_p: ^pft$path;


    status.normal := TRUE;
    password := '';
    cycle_selector.cycle_option := pfc$lowest_cycle;

{  Convert the file path, which is in file reference format to PF format. }

    pfp$convert_string_to_fs_path (file_path, fs_path, number_of_path_elements, ignore_cycle_reference,
          ignore_open_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH path_p: [1 .. number_of_path_elements];
    pfp$convert_fs_path_to_pf_path (fs_path, path_p, ignore_cycle_reference, ignore_cycle_selector, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  Delete the file. }

    pfp$purge (path_p^, cycle_selector, password, status);

  PROCEND delete_file;

?? TITLE := 'load_packing_list_from_disk', EJECT ??

{ PURPOSE:
{   This procedure loads the packing list from a tailored disk file to the
{   loading destination.
{
{ DESIGN:
{   The packing list is expected to be the first file found on the disk
{   file and is blindly loaded off.  Loading is performed using
{   RESTORE_PERMANENT_FILES utility which is only callable through command
{   language.  To accomplish this, the SCL commands must be collected and
{   executed by including the lines.  After the file is successfully
{   loaded, it is verified to be a packing list by checking the sequence
{   descriptor.  When any error occurs cleanup is attempted by deleting the
{   loading destination as a file with ignore status.
{
{   Information about the load will show up in the job log.
{
{   The local procedure called to delete the file deletes only the low
{   cycle.  But in the current usage deleting the low cycle is the same as
{   deleting the file since there is only one cycle.
{
{ NOTES:
{   The SCL commands that are assembled by STRINGREP into the command
{   line have been arranged for readability.  Formating has been turned
{   off to protect these lines from the formater.
{
{   Generally the RESTORE_PERMANENT_FILES subcommands use a warning status
{   to return status with.  This is not picked up by the CLP$INCLUDE_LINE
{   (unless it happens to be the last command).  Because of this, a status
{   must be placed directly on the restore command (which is a bit of
{   work).  However, because RESTORE_FILE returns error level error
{   messages instead, the use of a restore status is not required for
{   loading the packing list here as it is in other INSS situations.
{

  PROCEDURE load_packing_list_from_disk
    (    disk_file: fst$file_reference;
         loading_destination: fst$file_reference;
     VAR status: ost$status);

    VAR
      command_line: string (1000),
      command_line_length: integer,
      ignore_status: ost$status,
      local_status: ost$status;

    status.normal := TRUE;

{  Collect the SCL commands required to load the packing list from tape. }

?? FMT (FORMAT := OFF) ??
    STRINGREP (command_line, command_line_length,
          '$system.osf$builtin_library.restore_permanent_file l=$job_log; ',
          '  restore_file f=$fname($backup_file(', disk_file, ', identifier)) bf=', disk_file,
                   ' nfn=', loading_destination,  '; ',
          'quit');
?? FMT (FORMAT := ON) ??

{  Execute the SCL loading commands and verify that the loaded file is a packing list. }

    clp$include_line (command_line (1, command_line_length), TRUE, osc$null_name, local_status);
    IF local_status.normal THEN
      verify_as_packing_list (loading_destination, status);
    ELSE
      osp$generate_error_message (local_status, ignore_status);
      osp$set_status_abnormal ('RA', rae$pl_loading_error_occurred, '', status);
    IFEND;

    IF NOT status.normal THEN
      delete_file (loading_destination, ignore_status);
    IFEND;

  PROCEND load_packing_list_from_disk;

?? TITLE := 'load_packing_list_from_tape', EJECT ??

{ PURPOSE:
{   This procedure loads the packing list from a tailored product tape to
{   the loading destination.
{
{ DESIGN:
{   The packing list is expected to be the first file found on the disk
{   file and is blindly loaded off.  Loading is performed using
{   RESTORE_PERMANENT_FILES utility which is only callable through command
{   language.  To accomplish this, the SCL commands must be collected and
{   executed by including the lines.  After the file is successfully
{   loaded, it is verified to be a packing list by checking the sequence
{   descriptor.  When any error occurs cleanup is attempted by deleting the
{   loading destination as a file with ignore status.
{
{   Information about the load will show up in the job log.
{
{   The naming the of the local file associated with the tape is rigidly
{   controlled to allow for tapes to be left mounted through a series of
{   command calls.  The local file path is created by taking constant path
{   value and appending the primary tape vsn for the tape.  If specified
{   the RVSN is used, otherwise the EVSN is taken (see notes).  When the tape
{   file is detected as existing upon setting up to load, the tape file
{   will not be returned after loading has completed.  Otherwise it will be
{   returned.
{
{   The DELETE_FILE procedure called to delete the file deletes only the low
{   cycle.  But in the current usage deleting the low cycle is the same as
{   deleting the file since there is only one cycle.
{
{ NOTES:
{   The SCL commands that are assembled by STRINGREP into the command
{   line have been arranged for readability.  Formating has been turned
{   off to protect these lines from the formater.
{
{   Generally the RESTORE_PERMANENT_FILES subcommands use a warning status
{   to return status with.  This is not picked up by the CLP$INCLUDE_LINE
{   (unless it happens to be the last command).  Because of this, a status
{   must be placed directly on the restore command (which is a bit of
{   work).  However, because RESTORE_FILE returns error level error
{   messages instead, the use of a restore status is not required for
{   loading the packing list here as it is in other INSS situations.
{
{   The other interfaces that work off the tape file name use the RVSN
{   as the vsn appended to the tape name.
{
{   The tape file identifier could be checked first before attempting
{   to load packing list.  But it probably isn't worth it since there
{   is no way of reading it until the tape is attached.
{

  PROCEDURE load_packing_list_from_tape
    (    external_vsn: clt$parameter_value;
         recorded_vsn: clt$parameter_value;
         tape_type: clt$parameter_value;
         loading_destination: fst$file_reference;
         unload_volume: boolean;
         removable_media_group: clt$parameter_value;
     VAR status: ost$status);


    VAR
      command_line: string (1000),
      command_line_length: integer,
      detachment_options: ^fst$detachment_options,
      existing_file: boolean,
      ignore_attributes: array [1 .. 1] of amt$get_item,
      ignore_contains_data: boolean,
      ignore_status: ost$status,
      local_file: boolean,
      local_status: ost$status,
      local_evsn : string (6),
      local_rvsn : string (6),
      removable_media_group_name: ost$name,
      return_tape_file: boolean,
      tape_file: rat$path,
      tape_type_value: string (10),
      vsns_line: string (osc$max_string_size),
      vsns_line_length: integer;

    status.normal := TRUE;

    IF tape_type.specified THEN
      tape_type_value := tape_type.value^.keyword_value;
    ELSE { use default }
      tape_type_value := rac$mt9$6250;
    IFEND;

{  Create the local tape file name and determine if it is currently attached.
{  When the local tape file is already attached the tape will not be returned.

    local_rvsn := ' ';
    local_evsn := ' ';

    IF recorded_vsn.specified THEN
      IF recorded_vsn.value^.kind = clc$string THEN
         local_rvsn := recorded_vsn.value^.string_value^;
      ELSE { name value }
         local_rvsn := recorded_vsn.value^.name_value;
      IFEND;
    IFEND;
    IF external_vsn.specified THEN
      IF external_vsn.value^.kind = clc$string THEN
         local_evsn := external_vsn.value^.string_value^;
      ELSE { name value }
         local_evsn := external_vsn.value^.name_value;
      IFEND;
    IFEND;

    IF recorded_vsn.specified THEN
      STRINGREP (tape_file.path, tape_file.size, rac$local_primary_tape,
            local_rvsn(1,clp$trimmed_string_size(local_rvsn)),'.1');
    ELSE { external_vsn specified }
      STRINGREP (tape_file.path, tape_file.size, rac$local_primary_tape,
            local_evsn(1,clp$trimmed_string_size(local_evsn)),'.1');
    IFEND;

    ignore_attributes [1].key := amc$file_length;
    amp$get_file_attributes (tape_file.path (1, tape_file.size), ignore_attributes, local_file, existing_file,
          ignore_contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    return_tape_file := NOT (local_file OR existing_file);

{  Create the vsns parameter string.

    IF external_vsn.specified AND recorded_vsn.specified THEN
      STRINGREP (vsns_line, vsns_line_length, ' evsn=''', local_evsn, ''' rvsn=''', local_rvsn, '''');
    ELSEIF external_vsn.specified THEN
      STRINGREP (vsns_line, vsns_line_length, ' evsn=''', local_evsn, '''');
    ELSE {recorded_vsn specified}
      STRINGREP (vsns_line, vsns_line_length, ' rvsn=''', local_rvsn, '''');
    IFEND;

    IF removable_media_group.value^.kind = clc$name THEN
      removable_media_group_name := removable_media_group.value^.name_value;
    ELSE { keyword = NONE }
      removable_media_group_name := 'NONE';
    IFEND;

{  Collect the SCL commands required to load the packing list from tape.

?? FMT (FORMAT := OFF) ??
    STRINGREP (command_line, command_line_length,
          '$system.request_magnetic_tape f=', tape_file.path (1, tape_file.size),
                 vsns_line (1, vsns_line_length), ' t=', tape_type_value,
                 ' rmg=', removable_media_group_name, '; ',
          '$system.osf$builtin_library.restore_permanent_file l=$job_log; ',
          '  restore_file f=$fname($backup_file(', tape_file.path (1, tape_file.size),
                   ', identifier)) bf=', tape_file.path (1, tape_file.size),
                   ' nfn=', loading_destination, '; ',
          'quit');
?? FMT (FORMAT := ON) ??

{  Execute the SCL loading commands and verify that the loaded file is a packing list.

    clp$include_line (command_line (1, command_line_length), TRUE, osc$null_name, local_status);
    IF return_tape_file THEN
      IF unload_volume THEN
        detachment_options := NIL;
      ELSE
        PUSH detachment_options: [1 .. 1];
        detachment_options^ [1].selector := fsc$do_unload_volume;
        detachment_options^ [1].unload_volume := FALSE;
      IFEND;
      fsp$detach_file (tape_file.path (1, tape_file.size), detachment_options,
            ignore_status);
    IFEND;

    IF local_status.normal THEN
      verify_as_packing_list (loading_destination, status);
    ELSE
      IF local_status.condition = dme$tape_not_assigned THEN
        osp$set_status_abnormal ('RA', rae$pl_file_not_returned,
             tape_file.path(1, tape_file.size), local_status);
      IFEND;
      osp$generate_error_message (local_status, ignore_status);
      osp$set_status_abnormal ('RA', rae$pl_loading_error_occurred, '', status);
    IFEND;

    IF NOT status.normal THEN
      delete_file (loading_destination, ignore_status);
    IFEND;

  PROCEND load_packing_list_from_tape;

?? TITLE := 'prepare_loading_destination', EJECT ??

{ PURPOSE:
{   This procedure makes sure the subcatalogs along the destination path
{   are created (if they don't already exist).
{
{ DESIGN:
{   The procedure blindly attempts to create each subcatalog along the
{   path.  The interface to create subcatalogs requires the path format be
{   converted from file reference to PF format, so that is done first.  In
{   an attempt to simplify the dividing of the path into subcatalogs, the
{   PF path array containing the entire path is created in a sequence.
{   This will protect the values of the entire PF path array while subsets
{   of the array are used to create the subcatalogs in order of occurance.
{   In this way assignment to the PF path array is only done once.
{
{ NOTES:
{   This interface could be expanded to be used in creating the subproduct
{   installation paths when the path container is converted to file
{   references.
{

  PROCEDURE prepare_loading_destination
    (    destination_path: fst$file_reference;
     VAR status: ost$status);


    CONST
      file = 1, { The file is the last element of the path. }
      first_subcatalog = 1,
      master_catalog = 2; { The first 2 elements of a path are the master catalog. }


    VAR
      fs_path: string (fsc$max_path_size),
      ignore_cycle_reference: fst$cycle_reference,
      ignore_cycle_selector: clt$cycle_selector,
      ignore_open_position: fst$open_position,
      ignore_status: ost$status,
      number_of_path_elements: fst$number_of_path_elements,
      number_of_subcatalogs: integer,
      path_p: ^pft$path,
      path_sequence_p: ^SEQ ( * ),
      subcatalogs: integer;


    status.normal := TRUE;

{  Determine the number of subcatalogs in the destination path. }

    pfp$convert_string_to_fs_path (destination_path, fs_path, number_of_path_elements, ignore_cycle_reference,
          ignore_open_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    number_of_subcatalogs := number_of_path_elements - master_catalog - file;

    IF number_of_subcatalogs > 0 THEN

{  Convert the destination path, which is in file reference format to PF format. }

      PUSH path_sequence_p: [[REP (number_of_path_elements * #SIZE (pft$name)) OF cell]];
      RESET path_sequence_p;
      NEXT path_p: [1 .. number_of_path_elements] IN path_sequence_p;
      pfp$convert_fs_path_to_pf_path (fs_path, path_p, ignore_cycle_reference, ignore_cycle_selector, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{  Attempt to create each subcatalog in the path while ignoring status. }

      FOR subcatalogs := first_subcatalog TO number_of_subcatalogs DO

        RESET path_sequence_p;
        NEXT path_p: [1 .. master_catalog + subcatalogs] IN path_sequence_p;

        pfp$define_catalog (path_p^, ignore_status);

      FOREND;
    IFEND;

  PROCEND prepare_loading_destination;

?? TITLE := 'validate_parameters', EJECT ??

{ PURPOSE:
{   This procedure validates the parameters passed into the calling
{   interface.
{
{ DESIGN:
{   The disk and tape parameters are verified that at least one of them has
{   been specified and that they have not been used together.  The
{   destination path is checked to be non-local and that no file or catalog
{   currently exist using that path.
{
{   Validation errors are returned in the status variable.
{
{ NOTES:
{   Currently, we are not testing that the destination path references an
{   existing catalog.  AMP$GET_FILE_ATTRIBUTES (sometime around 1.4.1) will
{   be modified to support this test.  At that time the test will be
{   implemented.  Until that happens the test will go undone.  There should
{   not be any consequences from not testing other than the the error
{   message may not be as nice as it could.  RESTORE_PERMANENT_FILES
{   utility will trap the condition and the subsequent attempt to cleanup
{   an erroneously loaded file will do nothing since the object being
{   deleted would be a catalog and not a file.
{

  PROCEDURE validate_parameters
    (    external_vsn: clt$parameter_value;
         recorded_vsn: clt$parameter_value;
         tape_type: clt$parameter_value;
         disk_file: clt$parameter_value;
         destination_path: fst$file_reference;
     VAR status: ost$status);


    VAR
      existing_file: boolean,
      ignore_attributes: array [1 .. 1] of amt$get_item,
      ignore_contains_data: boolean,
      local_file: boolean;


    status.normal := TRUE;

{  Validate the disk and tape parameters. }

    IF (NOT external_vsn.specified) AND (NOT recorded_vsn.specified) AND (NOT disk_file.specified) THEN
      osp$set_status_abnormal ('RA', rae$disk_or_vsns_params_requird, '', status);
      RETURN;
    IFEND;

    IF (external_vsn.specified OR recorded_vsn.specified OR tape_type.specified)
          AND disk_file.specified THEN
      osp$set_status_abnormal ('RA', rae$loapl_params_specifying_err, '', status);
      RETURN;
    IFEND;

{  Test that the destination path is not under $LOCAL. }

    IF destination_path (1, 8) = ':$LOCAL.' THEN
      osp$set_status_abnormal ('RA', rae$pl_cannot_load_to_local_cat, '', status);
      RETURN;
    IFEND;

{  Test that the destination path does not already define a file or catalog (see note). }

    ignore_attributes [1].key := amc$file_length;

    amp$get_file_attributes (destination_path, ignore_attributes, local_file, existing_file,
          ignore_contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF local_file OR existing_file THEN
      osp$set_status_abnormal ('RA', rae$pl_path_already_being_used, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, destination_path, status);
      RETURN;
    IFEND;

  PROCEND validate_parameters;

?? TITLE := 'verify_as_packing_list', EJECT ??

{ PURPOSE:
{   This procedure verifies that the file that was loaded is actually a
{   packing list.
{
{ DESIGN:
{   The file is opened as a segment access and a sequence descriptor record
{   is NEXT'd onto the open file.  The sequence type field in the
{   descriptor is read.  The file is not a packing list if the descriptor
{   cannot be NEXT'd on, or the suquence type field is not defined for a
{   packing list.
{
{   Validation errors are returned in the status variable.
{
{ NOTES:
{

  PROCEDURE verify_as_packing_list
    (    packing_list_file_ref: fst$file_reference;
     VAR status: ost$status);


    VAR
      file_opened: boolean,
      local_status: ost$status,
      packing_list_fid: amt$file_identifier,
      packing_list_seq_p: ^rat$packing_list_sequence,
      segment_p: amt$segment_pointer,
      sequence_descriptor_p: ^rat$sequence_descriptor;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   An attempt is made to close the packing list file with ignore status.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (packing_list_fid, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      rap$open_file (^packing_list_file_ref, amc$segment, fsc$read, FALSE, NIL, packing_list_fid, file_opened,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (packing_list_fid, amc$sequence_pointer, segment_p, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      packing_list_seq_p := segment_p.sequence_pointer;

      RESET packing_list_seq_p;
      NEXT sequence_descriptor_p IN packing_list_seq_p;
      IF sequence_descriptor_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$access_error_verifying_pl, '', status);
        EXIT /main/;
      IFEND;

      IF sequence_descriptor_p^.sequence_type <> rac$packing_list_sequence THEN
        osp$set_status_abnormal ('RA', rae$not_a_packing_list, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, packing_list_file_ref, status);
        EXIT /main/;
      IFEND;

      IF sequence_descriptor_p^.sequence_level <> rac$packing_list_level THEN
        osp$set_status_abnormal ('RA', rae$incompatible_sequence_level, 'PACKING LIST', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, sequence_descriptor_p^.sequence_level,
              status);
      IFEND;

    END /main/;

    IF file_opened THEN
      fsp$close_file (packing_list_fid, local_status);
      IF status.normal THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND verify_as_packing_list;

MODEND ram$load_packing_list;
*DECK DECK=RAM$LOAD_PACKING_LIST_INSS_CMD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: LOAD_PACKING_LIST Subcommand.' ??
MODULE ram$load_packing_list_inss_cmd;

{ PURPOSE:
{   This module contains the INSTALL_SOFTWARE command interface to load the
{   packing list under the installation database catalog.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc rap$load_packing_list
*copyc rav$installation_defaults

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$load_packing_list_inss_cmd', EJECT ??

{ PURPOSE:
{   This is the command interface that loads the packing list from a
{   tailored product tape or tailored disk file into the installation
{   database.
{
{ DESIGN:
{   The LOAD_PACKING_LIST command has two versions.  This is the one used
{   by INSTALL_SOFTWARE and there is another used by PACKAGE_SOFTWARE.  The
{   only distinction between the two versions is how the loading
{   destination path is specified.  Otherwise, the actually loading
{   operation is exactly the same.  Because of this fact, this interface
{   constructs the destination path and then calls a shared interface
{   that does the actual parameter validation and loading.
{
{   The loading destination path is assembled by taking the current value
{   for the installation database catalog and appending the name specified
{   for the packing list by the caller.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$load_packing_list_inss_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE loapl_pdt (
{     packing_list, pl: name 1..16 = $required
{     external_vsn, evsn: any of
{         string 1..6
{         name 1..6
{       anyend = $optional
{     recorded_vsn, rvsn: any of
{         string 1..6
{         name 1..6
{       anyend = $optional
{     type, t: key mt9$1600, mt9$6250, mt18$38000 keyend = $optional
{     disk_file, df: file = $optional
{     unload_volume, uv: boolean = true
{     removable_media_group, rmg: (BY_NAME, ADVANCED) any of
{         key
{           none
{         keyend
{         name
{       anyend = osd$reqmt_removable_media_group, none
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 15] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type3: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
      type6: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type7: 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$name_type_qualifier,
        recend,
        default_name: string (31),
        default_value: string (4),
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [96, 8, 23, 15, 14, 52, 913],
    clc$command, 15, 8, 1, 1, 0, 0, 8, ''], [
    ['DF                             ',clc$abbreviation_entry, 5],
    ['DISK_FILE                      ',clc$nominal_entry, 5],
    ['EVSN                           ',clc$abbreviation_entry, 2],
    ['EXTERNAL_VSN                   ',clc$nominal_entry, 2],
    ['PACKING_LIST                   ',clc$nominal_entry, 1],
    ['PL                             ',clc$abbreviation_entry, 1],
    ['RECORDED_VSN                   ',clc$nominal_entry, 3],
    ['REMOVABLE_MEDIA_GROUP          ',clc$nominal_entry, 7],
    ['RMG                            ',clc$abbreviation_entry, 7],
    ['RVSN                           ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 8],
    ['T                              ',clc$abbreviation_entry, 4],
    ['TYPE                           ',clc$nominal_entry, 4],
    ['UNLOAD_VOLUME                  ',clc$nominal_entry, 6],
    ['UV                             ',clc$abbreviation_entry, 6]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 118, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 4],
{ PARAMETER 7
    [8, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_default_parameter, 31, 4],
{ PARAMETER 8
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, 16]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [1, 6, FALSE]],
    5, [[1, 0, clc$name_type], [1, 6]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [1, 6, FALSE]],
    5, [[1, 0, clc$name_type], [1, 6]]
    ],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [3], [
    ['MT18$38000                     ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['MT9$1600                       ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['MT9$6250                       ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 5
    [[1, 0, clc$file_type]],
{ PARAMETER 6
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'OSD$REQMT_REMOVABLE_MEDIA_GROUP',
    'none'],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$packing_list = 1,
      p$external_vsn = 2,
      p$recorded_vsn = 3,
      p$type = 4,
      p$disk_file = 5,
      p$unload_volume = 6,
      p$removable_media_group = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    VAR
      length: integer,
      loading_destination: fst$path;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (loading_destination, length, rav$installation_defaults.installation_database.
          path (1, rav$installation_defaults.installation_database.size), '.', pvt [p$packing_list].
          value^.name_value (1, clp$trimmed_string_size (pvt [p$packing_list].value^.name_value)));

    rap$load_packing_list (pvt [p$external_vsn], pvt [p$recorded_vsn], pvt [p$type],
          pvt [p$disk_file], loading_destination (1, length),
          pvt [p$unload_volume].value^.boolean_value.value,
          pvt [p$removable_media_group], status);

  PROCEND rap$load_packing_list_inss_cmd;
MODEND ram$load_packing_list_inss_cmd;
*DECK DECK=RAM$LOAD_PACKING_LIST_PACS_CMD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: LOAD_PACKING_LIST Subcommand.' ??
MODULE ram$load_packing_list_pacs_cmd;

{ PURPOSE:
{   This module contains the PACKAGE_SOFTWARE command interface to load the
{   packing list under the installation database catalog.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc rap$load_packing_list
*copyc rav$installation_defaults

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$load_packing_list_pacs_cmd', EJECT ??

{ PURPOSE:
{   This is the command interface that loads the packing list from a
{   tailored product tape or tailored disk file into the installation
{   database.
{
{ DESIGN:
{   The LOAD_PACKING_LIST command has two versions.  This is the one used
{   by PACKAGE_SOFTWARE and there is another used by INSTALL_SOFTWARE.  The
{   only distinction between the two versions is how the loading
{   destination path is specified.  Otherwise, the actually loading
{   operation is exactly the same.  Because of this fact, this interface
{   constructs the destination path and then calls a shared interface
{   that does the actual parameter validation and loading.
{
{   The loading destination path is assembled by taking the current value
{   for the installation database catalog and appending the name specified
{   for the packing list by the caller.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$load_packing_list_pacs_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE loapl_pdt (
{     packing_list, pl: file = $required
{     external_vsn, evsn: any of
{         string 1..6
{         name 1..6
{       anyend = $optional
{     recorded_vsn, rvsn: any of
{         string 1..6
{         name 1..6
{       anyend = $optional
{     type, t: key mt9$1600, mt9$6250, mt18$38000 keyend = $optional
{     disk_file, df: file = $optional
{     unload_volume, uv: boolean = true
{     removable_media_group, rmg: (BY_NAME, ADVANCED) any of
{         key
{           none
{         keyend
{         name
{       anyend = osd$reqmt_removable_media_group, none
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 15] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type3: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 3] of clt$keyword_specification,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
      type6: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type7: 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$name_type_qualifier,
        recend,
        default_name: string (31),
        default_value: string (4),
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [96, 12, 30, 10, 29, 15, 207],
    clc$command, 15, 8, 1, 1, 0, 0, 8, ''], [
    ['DF                             ',clc$abbreviation_entry, 5],
    ['DISK_FILE                      ',clc$nominal_entry, 5],
    ['EVSN                           ',clc$abbreviation_entry, 2],
    ['EXTERNAL_VSN                   ',clc$nominal_entry, 2],
    ['PACKING_LIST                   ',clc$nominal_entry, 1],
    ['PL                             ',clc$abbreviation_entry, 1],
    ['RECORDED_VSN                   ',clc$nominal_entry, 3],
    ['REMOVABLE_MEDIA_GROUP          ',clc$nominal_entry, 7],
    ['RMG                            ',clc$abbreviation_entry, 7],
    ['RVSN                           ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 8],
    ['T                              ',clc$abbreviation_entry, 4],
    ['TYPE                           ',clc$nominal_entry, 4],
    ['UNLOAD_VOLUME                  ',clc$nominal_entry, 6],
    ['UV                             ',clc$abbreviation_entry, 6]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 118, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 4],
{ PARAMETER 7
    [8, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 69, clc$optional_default_parameter, 31, 4],
{ PARAMETER 8
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [1, 6, FALSE]],
    5, [[1, 0, clc$name_type], [1, 6]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [1, 6, FALSE]],
    5, [[1, 0, clc$name_type], [1, 6]]
    ],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [3], [
    ['MT18$38000                     ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['MT9$1600                       ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
    ['MT9$6250                       ', clc$nominal_entry,
  clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 5
    [[1, 0, clc$file_type]],
{ PARAMETER 6
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$keyword_type,
    clc$name_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NONE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ,
    'OSD$REQMT_REMOVABLE_MEDIA_GROUP',
    'none'],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$packing_list = 1,
      p$external_vsn = 2,
      p$recorded_vsn = 3,
      p$type = 4,
      p$disk_file = 5,
      p$unload_volume = 6,
      p$removable_media_group = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    VAR
      length: integer,
      loading_destination: fst$path;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$load_packing_list (pvt [p$external_vsn], pvt [p$recorded_vsn], pvt [p$type],
          pvt [p$disk_file], pvt [p$packing_list].value^.file_value^,
          pvt [p$unload_volume].value^.boolean_value.value,
          pvt [p$removable_media_group], status);

  PROCEND rap$load_packing_list_pacs_cmd;

MODEND ram$load_packing_list_pacs_cmd;

*DECK DECK=RAM$LOAD_PRODUCTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$LOAD_PRODUCTS Interface.' ??
MODULE ram$load_products;

{ PURPOSE:
{   This module contains the interface and procedures to load
{   the products from the order medium into their destinations.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$local_primary_tape
*copyc rae$install_software_cc
*copyc rme$request_command_exceptions
*copyc rat$installation_control_record
?? POP ??
*copyc amp$return
*copyc clp$delete_variable
*copyc clp$convert_integer_to_string
*copyc clp$get_variable
*copyc clp$include_line
*copyc clp$trimmed_string_size
*copyc osp$generate_error_message
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pfp$convert_fs_path_to_pf_path
*copyc pfp$convert_string_to_fs_path
*copyc pfp$define_catalog
*copyc pmp$get_unique_name
*copyc rap$clear_installation
*copyc rap$convert_path_to_str
*copyc rap$create_scl_status_variable
*copyc rap$get_majority_file_class
*copyc rap$record_step_status
*copyc rap$record_subproduct_status
*copyc rmp$request_tape


?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    restore_status_variable = 'RAV$RESTORE_STATUS';

?? TITLE := '[XDCL] rap$load_products', EJECT ??

{ PURPOSE:
{   This interface peforms the load products step.
{
{ DESIGN:
{
{ NOTES:
{   If a step start is recorded then a step completion should also be
{   recorded.  The same thing applies to subproduct task information.
{
{   Status handling:
{
{   Generally, all bad status is recorded to the job log and not returned.
{   The idea is that as long as the installation process remains in control
{   it will continue to install everything it possibly can (on a subproduct
{   basis).  This puts a great deal of importance on being able to record
{   to the job log.  Therefore bad status is returned when recording the
{   step status information (which is the first indication of not being
{   able to record to the job log).
{
{   Status is ignored when recording task status.  This should never fail
{   as long as we can write to $job_log and other routines have already
{   verified this.
{
{   Currently the only bad status being returned to this interface are
{   requesting tape errors or restoring disk backup catalog.  This causes
{   the rest of the processing steps to be skipped.  It is believed that
{   there is no reason to continue with the other steps since nothing was
{   loaded.
{
{   The SUBPRODUCTS_FAILED_PROCESSING boolean has been initialized outside
{   of this interface and should never be re-initialized here.
{

  PROCEDURE [XDCL] rap$load_products
    (VAR called_from_package_software: boolean;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR subproducts_failed_processing: boolean;
     VAR status: ost$status);


    VAR
      ignore_status: ost$status,
      local_status: ost$status;


    status.normal := TRUE;

    IF NOT (rac$load_subproducts_step IN installation_control_record.processing_header_p^.step_set) THEN
      RETURN;
    IFEND;

    rap$record_step_status (rac$load_subproducts_step, rac$step_started, installation_control_record, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /main/
    BEGIN

      { Create an SCL status variable to be used by the loading procedures.

      rap$create_scl_status_variable (restore_status_variable, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF installation_control_record.packing_list_pointers.order_medium = rac$tape THEN

        load_products_from_tape (called_from_package_software, installation_control_record,
              subproducts_failed_processing, status);

      ELSE {order medium = rac$disk}

        load_products_from_disk (called_from_package_software, installation_control_record,
              subproducts_failed_processing, status);

      IFEND;

      rap$clear_installation (installation_control_record, ignore_status);

      clp$delete_variable (restore_status_variable, ignore_status);

    END /main/;

    rap$record_step_status (rac$load_subproducts_step, rac$step_completed, installation_control_record,
          local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

  PROCEND rap$load_products;

?? TITLE := 'delete_disk_file_catalog', EJECT ??

{ PURPOSE:
{   This procedure deletes the disk file catalog and contents.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE delete_disk_file_catalog
    (    disk_file_catalog: rat$path;
     VAR status: ost$status);


    VAR
      command_line: string (1000),
      command_line_length: integer;


    status.normal := TRUE;

    { Collect the SCL command required to delete disk backup catalog from the disk file.

?? FMT (FORMAT := OFF) ??
    STRINGREP (command_line, command_line_length,
          '$system.delete_catalog c=', disk_file_catalog.path (1, disk_file_catalog.size),
                 ' do=catalog_and_contents');
?? FMT (FORMAT := ON) ??

    { Execute the SCL command to delete catalog and contents.

    clp$include_line (command_line (1, command_line_length), TRUE, osc$null_name, status);

  PROCEND delete_disk_file_catalog;

?? TITLE := 'get_restore_status', EJECT ??

{ PURPOSE:
{   This interface returns the SCL status variable used in restoring the
{   products.
{
{ DESIGN:
{   The restore status variable's name is passed in along with a scratch
{   sequence to hold the status variable.  The retrieval of the SCL status
{   variable follows standard cybil procedure.
{
{ NOTES:
{   The scratch sequence is defined to be for temporary storage and can
{   therefore be reset at anytime.
{

  PROCEDURE get_restore_status
    (    restore_status_var_name: clt$variable_ref_expression;
     VAR scratch_seq_p {output} : ^SEQ ( * );
     VAR restore_status: ost$status);


    VAR
      access_mode: clt$data_access_mode,
      class: clt$variable_class,
      evaluation_method: clt$expression_eval_method,
      restore_status_p: ^clt$data_value,
      type_specification_p: ^clt$type_specification;


    restore_status.normal := TRUE;

    RESET scratch_seq_p;

    clp$get_variable (restore_status_var_name, scratch_seq_p, class, access_mode, evaluation_method,
          type_specification_p, restore_status_p, restore_status);
    IF NOT restore_status.normal THEN
      RETURN;
    IFEND;

    restore_status := restore_status_p^.status_value^;

  PROCEND get_restore_status;

?? TITLE := 'load_products_from_disk', EJECT ??

{ PURPOSE:
{   This procedure loads the products from disk.
{
{ DESIGN:
{   It is assumed only one job is processing the entire disk order.
{
{ NOTES:
{

  PROCEDURE load_products_from_disk
    (VAR called_from_package_software: boolean;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR subproducts_failed_processing: boolean;
     VAR status: ost$status);


    VAR
      disk_file_catalog: rat$path,
      ignore_status: ost$status,
      local_status: ost$status,
      subproduct_index: rat$subproduct_count,
      task_status: ost$status;


    status.normal := TRUE;

    restore_disk_file_catalog (called_from_package_software, installation_control_record,
           disk_file_catalog, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR subproduct_index := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^) DO

      IF (installation_control_record.job_identifier = installation_control_record.
            subproduct_processing_records_p^ [subproduct_index].job_identifier) AND
            (rac$load_files_task IN installation_control_record.
            subproduct_processing_records_p^ [subproduct_index].task_set) AND
            (installation_control_record.subproduct_processing_records_p^ [subproduct_index].task_status <>
            rac$task_failed) THEN

        rap$record_subproduct_status (rac$load_files_task, rac$task_started, subproduct_index,
              installation_control_record, ignore_status);

        load_subproduct_from_disk (called_from_package_software, disk_file_catalog, subproduct_index,
              installation_control_record, task_status);

        IF task_status.normal THEN
          rap$record_subproduct_status (rac$load_files_task, rac$task_completed, subproduct_index,
                installation_control_record, ignore_status);
        ELSE
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], task_status, ignore_status);
          rap$record_subproduct_status (rac$load_files_task, rac$task_failed, subproduct_index,
                installation_control_record, ignore_status);
          subproducts_failed_processing := TRUE;
        IFEND;

      IFEND;
    FOREND;

    delete_disk_file_catalog (disk_file_catalog, local_status);
    IF NOT local_status.normal THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], ignore_status, ignore_status);
    IFEND;

  PROCEND load_products_from_disk;

?? TITLE := 'load_products_from_tape', EJECT ??

{ PURPOSE:
{   This procedure loads the products from tape.
{
{ DESIGN:
{   Processing loops through the medium processing record.  Each tape
{   assigned to this job is handled separately.
{
{   If a tape has been previously mounted, it will be left attached unless
{   more than one tape will be requested.  This allows for a tape to be left
{   mounted through a series of command calls, which is important during the
{   deadstart process.
{
{ NOTES:
{

  PROCEDURE load_products_from_tape
    (VAR called_from_package_software: boolean;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR subproducts_failed_processing: boolean;
     VAR status: ost$status);


    VAR
      ignore_status: ost$status,
      local_status: ost$status,
      number_of_tapes_to_assign: rat$tape_count,
      subproduct_index: rat$subproduct_count,
      tape_already_assigned: boolean,
      tape_file: rat$path,
      tape_index: rat$tape_count,
      task_status: ost$status;


    status.normal := TRUE;

    { Determine the number of tapes to be assigned by this job.

    number_of_tapes_to_assign := 0;
    FOR tape_index := 1 TO UPPERBOUND (installation_control_record.medium_processing_records_p^) DO
      IF installation_control_record.job_identifier = installation_control_record.
            medium_processing_records_p^ [tape_index].job_identifier THEN
        number_of_tapes_to_assign := number_of_tapes_to_assign + 1;
      IFEND;
    FOREND;

    { Load the subproducts from each tape assigned to this job.

    FOR tape_index := 1 TO UPPERBOUND (installation_control_record.medium_processing_records_p^) DO

      IF installation_control_record.job_identifier = installation_control_record.
            medium_processing_records_p^ [tape_index].job_identifier THEN

        request_tape (installation_control_record.packing_list_pointers, tape_index, tape_file,
              tape_already_assigned, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        FOR subproduct_index := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^)
              DO

          IF (installation_control_record.job_identifier = installation_control_record.
                subproduct_processing_records_p^ [subproduct_index].job_identifier) AND
                (tape_index = installation_control_record.packing_list_pointers.
                tape_subproduct_indexer_p^ [subproduct_index].primary_tape_vsn) AND
                (rac$load_files_task IN installation_control_record.
                subproduct_processing_records_p^ [subproduct_index].task_set) AND
                (installation_control_record.subproduct_processing_records_p^ [subproduct_index].
                task_status <> rac$task_failed) THEN

            rap$record_subproduct_status (rac$load_files_task, rac$task_started, subproduct_index,
                  installation_control_record, ignore_status);

            load_subproduct_from_tape (called_from_package_software, tape_file, subproduct_index,
                  installation_control_record, task_status);

            IF task_status.normal THEN
              rap$record_subproduct_status (rac$load_files_task, rac$task_completed, subproduct_index,
                    installation_control_record, ignore_status);
            ELSE
              osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], task_status, ignore_status);
              rap$record_subproduct_status (rac$load_files_task, rac$task_failed, subproduct_index,
                    installation_control_record, ignore_status);
              subproducts_failed_processing := TRUE;
            IFEND;

          IFEND;
        FOREND;

        { If a tape has been previously mounted, it will be left attached unless
        { more than one tape will be requested.  This allows for a tape to be left

        IF (number_of_tapes_to_assign > 1) OR (NOT tape_already_assigned) THEN
          amp$return (tape_file.path (1, tape_file.size), local_status);
          IF NOT local_status.normal THEN
            osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
          IFEND;
        IFEND;

      IFEND;
    FOREND;

  PROCEND load_products_from_tape;

?? TITLE := 'load_subproduct_from_disk', EJECT ??

{ PURPOSE:
{   This procedure loads the packing list from tailored disk file to the
{   loading destination.
{
{ DESIGN:
{   Loading is performed using RESTORE_PERMANENT_FILES utility which is only
{   callable through command language.  To accomplish this, the SCL commands
{   must be collected and executed by including the lines.
{
{   Information about the load will show up in the job log.
{
{ NOTES:
{   The RESTORE_EXISTING_CATALOG subcommand uses a warning status
{   to return status with.  This is not picked up by the CLP$INCLUDE_LINE
{   (unless it happens to be the last command).  Because of this, a status
{   must be placed directly on the restore command.
{
{   The RESTORE_STATUS_VARIABLE is a global string constant that is used
{   as the name of the restore status variable.
{
{   The SCL commands that are assembled by STRINGREP into the command
{   line have been arranged for readability.  Formating has been turned
{   off to protect these lines from formatting.
{

  PROCEDURE load_subproduct_from_disk
    (    called_from_package_software: boolean;
         disk_file_catalog: rat$path;
         subproduct_index: rat$subproduct_count;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      command_line: string (1000),
      command_line_length: integer,
      file_class: ost$name,
      ignore_file_class_char: rmt$mass_storage_class,
      ignore_status: ost$status,
      loading_destination: rat$path,
      pacs_catalog: rat$path,
      restore_status: ost$status,
      subproduct_backup_file: rat$path;


    status.normal := TRUE;

    prepare_loading_destination (installation_control_record.
          subproduct_processing_records_p^ [subproduct_index], loading_destination, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pacs_catalog := installation_control_record.subproduct_processing_records_p^ [subproduct_index].
          subproduct_info_pointers.attributes_p^.pacs_catalog_path;

    rap$get_majority_file_class (subproduct_index, installation_control_record, file_class,
          ignore_file_class_char, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (subproduct_backup_file.path, subproduct_backup_file.size, disk_file_catalog.
          path (1, disk_file_catalog.size), '.', installation_control_record.packing_list_pointers.
          disk_subproduct_indexer_p^ [subproduct_index].backup_file
          (1, clp$trimmed_string_size (installation_control_record.packing_list_pointers.
          disk_subproduct_indexer_p^ [subproduct_index].backup_file)));

    { Collect the SCL commands required to load the subproduct from disk.

?? FMT (FORMAT := OFF) ??
    IF called_from_package_software THEN
      STRINGREP (command_line, command_line_length,
          restore_status_variable, '.normal = TRUE; ',
          '$system.osf$builtin_library.restore_permanent_files l=$job_log; ',
          '  restore_existing_catalog c=', pacs_catalog.path (1, pacs_catalog.size),
                   ' bf=', subproduct_backup_file.path (1, subproduct_backup_file.size),
                   ' ncn=', loading_destination.path (1, loading_destination.size),
                   ' status=', restore_status_variable, '; ',
          'quit');
    ELSE
      STRINGREP (command_line, command_line_length,
          restore_status_variable, '.normal = TRUE; ',
          '$system.osf$builtin_library.restore_permanent_files l=$job_log; ',
          '  set_restore_options fc=', file_class (1, clp$trimmed_string_size (file_class)), '; ',
          '  restore_existing_catalog c=', pacs_catalog.path (1, pacs_catalog.size),
                   ' bf=', subproduct_backup_file.path (1, subproduct_backup_file.size),
                   ' ncn=', loading_destination.path (1, loading_destination.size),
                   ' status=', restore_status_variable, '; ',
          'quit');
    IFEND;
?? FMT (FORMAT := ON) ??

    { Execute the SCL loading commands and verify that the loaded file is a packing list.

    clp$include_line (command_line (1, command_line_length), TRUE, osc$null_name, status);

    get_restore_status (restore_status_variable, installation_control_record.scratch_seq_p, restore_status);
    IF NOT restore_status.normal THEN
      IF status.normal THEN
        status := restore_status;
      ELSE
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], restore_status, ignore_status);
      IFEND;
    IFEND;

    { Delete the subproduct backup file to keep disk space usage to a minimum.

    STRINGREP (command_line, command_line_length, '$system.delete_file f=', subproduct_backup_file.path
          (1, subproduct_backup_file.size));

    clp$include_line (command_line (1, command_line_length), TRUE, osc$null_name, ignore_status);

  PROCEND load_subproduct_from_disk;

?? TITLE := 'load_subproduct_from_tape', EJECT ??

{ PURPOSE:
{   This interface loads the subproduct from a tailored product tape to the
{   loading destination.
{
{ DESIGN:
{   Loading is performed using RESTORE_PERMANENT_FILES utility which is only
{   callable through command language.  To accomplish this, the SCL commands
{   must be collected and executed by including the lines.
{
{   Information about the load will show up in the job log.
{
{ NOTES:
{   The RESTORE_EXISTING_CATALOG subcommand uses a warning status
{   to return status with.  This is not picked up by the CLP$INCLUDE_LINE
{   (unless it happens to be the last command).  Because of this, a status
{   must be placed directly on the restore command.
{
{   The RESTORE_STATUS_VARIABLE is a global string constant that is used
{   as the name of the restore status variable.
{
{   The SCL commands that are assembled by STRINGREP into the command
{   line have been arranged for readability.  Formating has been turned
{   off to protect these lines from the formater.
{
{   The tape file identifier could be checked first before attempting
{   to load packing list.
{

  PROCEDURE load_subproduct_from_tape
    (    called_from_package_software: boolean;
         tape_file: rat$path;
         subproduct_index: rat$subproduct_count;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      command_line: string (1000),
      command_line_length: integer,
      file_class: ost$name,
      file_sequence_number: ost$string,
      ignore_file_class_char: rmt$mass_storage_class,
      ignore_status: ost$status,
      loading_destination: rat$path,
      pacs_catalog: rat$path,
      restore_status: ost$status;


    status.normal := TRUE;

    prepare_loading_destination (installation_control_record.
          subproduct_processing_records_p^ [subproduct_index], loading_destination, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pacs_catalog := installation_control_record.subproduct_processing_records_p^ [subproduct_index].
          subproduct_info_pointers.attributes_p^.pacs_catalog_path;

    rap$get_majority_file_class (subproduct_index, installation_control_record, file_class,
          ignore_file_class_char, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_integer_to_string (installation_control_record.packing_list_pointers.
          tape_subproduct_indexer_p^ [subproduct_index].tape_file_sequence_number, 10, FALSE,
          file_sequence_number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    { Collect the SCL commands required to load the subproduct from tape.

?? FMT (FORMAT := OFF) ??
    IF called_from_package_software THEN
      STRINGREP (command_line, command_line_length,
          restore_status_variable, '.normal = TRUE; ',
          '$system.osf$builtin_library.restore_permanent_files l=$job_log; ',
          '  change_tape_label_attributes f=', tape_file.path (1, tape_file.size),
                   ' fsp=fsp fsn=', file_sequence_number.value (1, file_sequence_number.size), '; ',
          '  restore_existing_catalog c=', pacs_catalog.path (1, pacs_catalog.size),
                   ' bf=', tape_file.path (1, tape_file.size),
                   ' ncn=', loading_destination.path (1, loading_destination.size),
                   ' status=', restore_status_variable, '; ',
          'quit');
    ELSE
      STRINGREP (command_line, command_line_length,
          restore_status_variable, '.normal = TRUE; ',
          '$system.osf$builtin_library.restore_permanent_files l=$job_log; ',
          '  set_restore_options fc=', file_class (1, clp$trimmed_string_size (file_class)), '; ',
          '  change_tape_label_attributes f=', tape_file.path (1, tape_file.size),
                   ' fsp=fsp fsn=', file_sequence_number.value (1, file_sequence_number.size), '; ',
          '  restore_existing_catalog c=', pacs_catalog.path (1, pacs_catalog.size),
                   ' bf=', tape_file.path (1, tape_file.size),
                   ' ncn=', loading_destination.path (1, loading_destination.size),
                   ' status=', restore_status_variable, '; ',
          'quit');
    IFEND;
?? FMT (FORMAT := ON) ??

    { Execute the SCL loading commands and verify that the loaded file is a packing list.

    clp$include_line (command_line (1, command_line_length), TRUE, osc$null_name, status);

    get_restore_status (restore_status_variable, installation_control_record.scratch_seq_p, restore_status);
    IF NOT restore_status.normal THEN
      IF status.normal THEN
        status := restore_status;
      ELSE
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], restore_status, ignore_status);
      IFEND;
    IFEND;

  PROCEND load_subproduct_from_tape;

?? TITLE := 'prepare_loading_destination', EJECT ??

{ PURPOSE:
{   This procedure prepares the loading destination for a subproduct.  That
{   is, after determining loading destination path, it makes sure that all
{   subcatalogs in the path are created.  The loading destination path is
{   returned in string format for use by the loading procedures.
{
{ DESIGN:
{   The loading destination for a subproduct is refered to as the
{   installation catalog.  The path value for the installation catalog was
{   assigned during the initiation setup and stored in the processing record
{   of the subproduct
{
{   All the subcatalogs along the loading destination path are created if
{   they don't already exist.  The loading destination path must be in PF
{   format for the interface that attempts to create the subcatalogs, but
{   must be convert to FS path format to be used by the loading procedures.
{
{ NOTES:
{   The conversion back and forth between PF and FS path formats is a mess,
{   but it is neccessary until the PF interfaces are converted to accept FS
{   path formats.  The conversion code could be consolidated into common
{   interfaces when the SIF path container is converted to FS format.
{

  PROCEDURE prepare_loading_destination
    (    processing_record: rat$subp_processing_record;
     VAR loading_destination: rat$path;
     VAR status: ost$status);


    CONST
      first_subcatalog = 1,
      family_user_catalogs = 2; { The number of elements that makeup the family and user catalogs. }

    VAR
      destination_path_p: ^pft$path,
      ignore_status: ost$status,
      number_of_subcatalogs: fst$number_of_path_elements,
      path_sequence_p: ^SEQ ( * ),
      subcatalogs: integer;


    status.normal := TRUE;

    PUSH path_sequence_p: [[REP #SIZE (processing_record.installation_catalog_p^) OF cell]];
    RESET path_sequence_p;
    NEXT destination_path_p: [1 .. UPPERBOUND (processing_record.installation_catalog_p^)] IN path_sequence_p;
    destination_path_p^ := processing_record.installation_catalog_p^;

    rap$convert_path_to_str (destination_path_p^, loading_destination);

    number_of_subcatalogs := UPPERBOUND (destination_path_p^) - family_user_catalogs;

    FOR subcatalogs := first_subcatalog TO number_of_subcatalogs DO

      RESET path_sequence_p;
      NEXT destination_path_p: [1 .. family_user_catalogs + subcatalogs] IN path_sequence_p;

      pfp$define_catalog (destination_path_p^, ignore_status);

    FOREND;

  PROCEND prepare_loading_destination;

?? TITLE := 'restore_disk_file_catalog', EJECT ??

{ PURPOSE:
{   This procedure restores the catalog on the disk file that contains the
{   backups of all the subproducts shipped with the order.
{
{ DESIGN:
{   Loading is performed using RESTORE_PERMANENT_FILES utility which is only
{   callable through command language.  To accomplish this, the SCL commands
{   must be collected and executed by including the lines.
{
{   Information about the load will show up in the job log.
{
{ NOTES:
{   The RESTORE_CATALOG subcommand uses a warning status to return status
{   with.  This is not picked up by the CLP$INCLUDE_LINE (unless it happens
{   to be the last command).  Because of this, a status must be placed
{   directly on the restore command.
{
{   The RESTORE_STATUS_VARIABLE is a global string constant that is used
{   as the name of the restore status variable.
{
{   The SCL commands that are assembled by STRINGREP into the command
{   line have been arranged for readability.  Formating has been turned
{   off to protect these lines from formatting.
{

  PROCEDURE restore_disk_file_catalog
    (    called_from_package_software: boolean;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR disk_file_catalog: rat$path;
     VAR status: ost$status);


    VAR
      command_line: string (1000),
      command_line_length: integer,
      disk_backup_catalog: rat$path,
      disk_file: rat$path,
      ignore_status: ost$status,
      restore_status: ost$status,
      unique_catalog_name: ost$name;


    status.normal := TRUE;

    disk_file.path := installation_control_record.packing_list_pointers.header_p^.disk_path;
    disk_file.size := clp$trimmed_string_size (disk_file.path);

    disk_backup_catalog.path := installation_control_record.packing_list_pointers.header_p^.
          disk_backup_catalog;
    disk_backup_catalog.size := clp$trimmed_string_size (disk_backup_catalog.path);

    pmp$get_unique_name (unique_catalog_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (disk_file_catalog.path, disk_file_catalog.size, ':$USER.',
          unique_catalog_name (1, clp$trimmed_string_size (unique_catalog_name)));


    { Collect the SCL commands required to restore disk backup catalog from the disk file.

?? FMT (FORMAT := OFF) ??
    IF called_from_package_software THEN
      STRINGREP (command_line, command_line_length,
          restore_status_variable, '.normal = TRUE; ',
          '$system.osf$builtin_library.restore_permanent_files l=$job_log; ',
          '  restore_catalog c=', disk_backup_catalog.path (1, disk_backup_catalog.size),
                   ' bf=', disk_file.path (1, disk_file.size),
                   ' ncn=', disk_file_catalog.path (1, disk_file_catalog.size),
                   ' status=', restore_status_variable, '; ',
          'quit');
    ELSE
      STRINGREP (command_line, command_line_length,
          restore_status_variable, '.normal = TRUE; ',
          '$system.osf$builtin_library.restore_permanent_files l=$job_log; ',
          '  set_restore_options fc=product; ',
          '  restore_catalog c=', disk_backup_catalog.path (1, disk_backup_catalog.size),
                   ' bf=', disk_file.path (1, disk_file.size),
                   ' ncn=', disk_file_catalog.path (1, disk_file_catalog.size),
                   ' status=', restore_status_variable, '; ',
          'quit');
    IFEND;
?? FMT (FORMAT := ON) ??

    { Execute the SCL loading commands and verify that the loaded file is a packing list.

    clp$include_line (command_line (1, command_line_length), TRUE, osc$null_name, status);

    get_restore_status (restore_status_variable, installation_control_record.scratch_seq_p, restore_status);
    IF NOT restore_status.normal THEN
      IF status.normal THEN
        status := restore_status;
      ELSE
        osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], restore_status, ignore_status);
      IFEND;
    IFEND;

  PROCEND restore_disk_file_catalog;

?? TITLE := 'request_tape', EJECT ??

{ PURPOSE:
{   This procedure makes the tape request after determining the tape file
{   usage.
{
{ DESIGN:
{   The naming the of the local file associated with the tape is rigidly
{   controlled to allow for tapes to be left mounted through a series of
{   command calls.  The local file path is created by taking constant path
{   value and appending the primary tape vsn for the tape.  When the tape
{   is detected as being assigned a boolean to that effect is returned.
{
{ NOTES:
{   With the support of cartridge tape, tape class and density had to be
{   added to the packing list.  For compatibility, the processor version
{   field of the packing list's sequence descriptor is used to indicate
{   which packing lists contain tape class and density and which do not.  If
{   the packing list was generated with an earlier processor the default
{   values are used.
{
{   Prior to processor version 'PACS V1.01 1989166' the tape class and
{   density were not on the packing list.  Since the utilities only read
{   tapes, and the density could be determined from the tape itself, this was
{   acceptable.  A default density of 1600 was chosen since all tape drives
{   at that time could support this density.  Selection of 6250, for
{   example, would make it impossible for sites with non-6250 drives to read
{   tailored release tapes.  Tape class was assumed to be 9 track.
{
{   In the overall process scheme, the SETIT command and the associated
{   menus use a default of 6250.  That is density the majority of the orders
{   should be written at.  This should not be confused with the default used
{   here, which was done for the reason stated above.
{
{   Also, tape class and density taken together define tape type.  In most
{   of the other TRP interfaces tape type is referenced.
{
{   *** If the packing list's tape vsns were stored in rmt$volume_list
{   records there would not have to be any reformating.
{

  PROCEDURE request_tape
    (    packing_list_pointers: rat$packing_list_pointers;
         tape_index: rat$tape_count;
     VAR tape_file: rat$path;
     VAR tape_already_assigned: boolean;
     VAR status: ost$status);


    VAR
      i: rat$tape_count,
      ignore_status: ost$status,
      local_status: ost$status,
      next_vol_p: ^rat$tape_vsn,
      number_of_volumes: rat$tape_count,
      tape_class: rmt$tape_class,
      tape_density: rmt$density,
      vsn_list_p: ^rmt$volume_list;


    status.normal := TRUE;
    tape_already_assigned := FALSE;

    STRINGREP (tape_file.path, tape_file.size, rac$local_primary_tape, packing_list_pointers.
          tape_vsns_p^ [tape_index].recorded_vsn (1, clp$trimmed_string_size
          (packing_list_pointers.tape_vsns_p^ [tape_index].recorded_vsn)), '.1');

    { Get the values for the tape class and density.  Starting at processor version
    { 'PACS V1.01 1989166' the tape class and density are added to the packing list.

    IF packing_list_pointers.sequence_descriptor_p^.processor_version < 'PACS V1.01 1989166' THEN
      { Use defaults, tape class and density not on packing list. }
      tape_class := rmc$mt9;
      tape_density := rmc$1600;
    ELSE { packing list contains tape class and density }
      tape_class := packing_list_pointers.header_p^.tape_class;
      tape_density := packing_list_pointers.header_p^.tape_density;
    IFEND;

    { Create the vsn list by taking the linked list of additional volumes associated with
    { the current tape and converting it into an array.

    next_vol_p := #PTR (packing_list_pointers.tape_vsns_p^ [tape_index].additional_volume_p,
          packing_list_pointers.sequence_p^);
    number_of_volumes := 1;
    WHILE next_vol_p <> NIL DO
      number_of_volumes := number_of_volumes + 1;
      next_vol_p := #PTR (next_vol_p^.additional_volume_p, packing_list_pointers.sequence_p^);
    WHILEND;

    PUSH vsn_list_p: [1 .. number_of_volumes];
    next_vol_p := ^packing_list_pointers.tape_vsns_p^ [tape_index];
    FOR i := 1 TO number_of_volumes DO
      vsn_list_p^ [i].external_vsn := next_vol_p^.external_vsn;
      vsn_list_p^ [i].recorded_vsn := next_vol_p^.recorded_vsn;
      next_vol_p := #PTR (next_vol_p^.additional_volume_p, packing_list_pointers.sequence_p^);
    FOREND;

{  Make the tape request.

    rmp$request_tape (tape_file.path (1, tape_file.size), tape_class, tape_density,
          rmc$no_write_ring, vsn_list_p^, status);
    IF (NOT status.normal) AND (status.condition = rme$redundant_device_assignment) THEN
      status.normal := TRUE;
      tape_already_assigned := TRUE;
    IFEND;

  PROCEND request_tape;

MODEND ram$load_products;
*DECK DECK=RAM$LOCATE_DIRECTORY_RECORD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$LOCATE_DIRECTORY_RECORD Interface.' ??
MODULE ram$locate_directory_record;

{ PURPOSE:
{   This module contains the interface that locates a record for a
{   subproduct in the IDB directory.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rat$idb_directory_pointers
?? POP ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$locate_directory_record', EJECT ??

{ PURPOSE:
{   This interface searches the IDB Directory for a subproduct's directory
{   record.  A pointer to the record is returned when found.  A NIL pointer
{   is returned when not found.
{
{ DESIGN:
{   The directory is maintained sorted by a sort key which is made up of the
{   licensed product and subproduct name fields.  This procedure performs a
{   binary search for the sort key in the directory.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$locate_directory_record
    (    subproduct_name: rat$subproduct_name;
         licensed_product: rat$licensed_product;
         directory_pointers: rat$idb_directory_pointers;
     VAR directory_record_p: ^rat$directory_record);


    VAR
      temp: integer,
      lower: rat$directory_size,
      mid: rat$directory_size,
      sort_key: rat$directory_sort_key,
      upper: rat$directory_size;


    directory_record_p := NIL;
    lower := 1;
    upper := directory_pointers.header_p^.directory_size;

    { Construct the sort key which is licensed product concatenated with subproduct name without removing
    { the blanks between.

    sort_key (1, * ) := licensed_product;
    sort_key (#SIZE (licensed_product) + 1, * ) := subproduct_name;

  /locate_in_directory/
    WHILE lower <= upper DO
      temp := lower + upper;
      mid := temp DIV 2;
      IF sort_key > directory_pointers.directory_p^ [mid].sort_key THEN
        lower := mid + 1;
      ELSEIF sort_key < directory_pointers.directory_p^ [mid].sort_key THEN
        upper := mid - 1;
      ELSE {directory entry for subproduct exits}
        directory_record_p := ^directory_pointers.directory_p^ [mid];
        EXIT /locate_in_directory/;
      IFEND;
    WHILEND /locate_in_directory/;

  PROCEND rap$locate_directory_record;
MODEND ram$locate_directory_record;
*DECK DECK=RAM$LOG_TERMINATED_TASK EXPAND=TRUE
PROC log_terminated_task, logtt (
  task_name, tn: name = $required
  to, t: key job, system = job
  status)

  create_variable scratch kind=string value=$unique
  create_variable line kind=string

  display_message to=$value(to) m=' $!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$!$'
  display_message to=$value(to) m=' $!$!$     '//$string($value(task_name))//' terminated with'

  set_file_attributes $fname(scratch) fc=legible fs=data pf=continuous pw=$max_string
  display_value $task_status($value(task_name)) output=$fname(scratch)
  accept_line line input=$fname(scratch)
  detach_file $fname(scratch)
  display_message to=$value(to) m=line
  display_message to=$value(to) m=' $!$!$-------------------------------------------------------$!$!$'

PROCEND log_terminated_task
*DECK DECK=RAM$MANAGE_NETWORK_APPLICATIONS EXPAND=TRUE
create_program_description (MANAGE_NETWORK_APPLICATIONS, MANAGE_NETWORK_APPLICATION, MANNA) l='$system.osf$system_library'..
      sp=nap$manage_network_applications lm=$null lmo=none tel=warning dm=off

*DECK DECK=RAM$MANAGE_PHYSICAL_CONFIGURATI EXPAND=TRUE
create_program_description name=(physical_configuration_utility, pcu) dm=off sp=physical_configuration_utility ..
      l=osf$task_services_library tel=error load_map=$null
*DECK DECK=RAM$MANAGE_REMOTE_FILES EXPAND=TRUE
create_program_description (manage_remote_file,manage_remote_files, ..
manrf,mflink) l='$SYSTEM.PTF_QTF.OSF$USER_FILE_TRANSFER' ..
SP=nfp$manage_remote_files dm=off
*DECK DECK=RAM$MANAGE_RHFAM_NETWORK EXPAND=TRUE
create_program_description name=(manage_rhfam_network, manrn) dm=off sp=rfp$manage_rhfam_network ..
l=('$system.rhfam.osf$rhfam_network_utilities', osf$task_services_library) tel=error ..
load_map=$null
*DECK DECK=RAM$MANAGE_STORE_FORWARD_NETWRK EXPAND=TRUE
create_program_description name=(manage_store_forward_network, mansfn) dm=off ..
  tel=error lm=$null lmo=none sp=nfp$manage_store_forward_netwrk ..
  l='$system.ptf_qtf.osf$user_file_transfer'
*DECK DECK=RAM$MEASURE_PROGRAM_EXECUTION EXPAND=TRUE
create_program_description name=(measure_program_execution meape) sp=pmp$measure_program_execution ..
      l=('$system.ocu.bound_product' osf$task_services_library) tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$MENU_PROMPTING_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Prompting Interfaces: Routines used for prompting' ??
MODULE ram$menu_prompting_interfaces;

{ PURPOSE:
{   This module contains interfaces to prompt for user responses.
{
{ DESIGN:
{   The interfaces utilize message templates and message help modules to provide the text for the
{   prompting.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
*copyc rac$max_line
*copyc rac$process_id
*copyc rae$prompt_and_message_cc
*copyc rat$message_parameters
*copyc rat$prompting_options
*copyc rat$value_declaration
*copyc rat$value_returned
*copyc rmc$initv_menu_names
?? POP ??
*copyc amp$get_next
*copyc amp$put_next
*copyc amp$return
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_integer
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$include_command
*copyc clp$scan_parameter_list
*copyc clp$trimmed_string_size
*copyc clp$write_variable
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$find_brief_help_message
*copyc osp$find_full_help_message
*copyc osp$find_help_module
*copyc osp$find_param_assist_prompt
*copyc osp$find_parameter_help_message
*copyc osp$find_parameter_prompt
*copyc osp$format_help_message
*copyc osp$format_message
*copyc osp$get_status_severity
*copyc osp$set_status_abnormal
*copyc pmp$get_unique_name
*copyc clv$non_space
*copyc osv$lower_to_upper
*copyc oss$task_shared

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    rac$max_number_of_selections = 10,
    rac$selection_key_size = 2;

  TYPE
    rat$io_identifiers = record
      input_open: boolean,
      input: amt$file_identifier,
      output_open: boolean,
      output: amt$file_identifier,
    recend,
    rat$menu = record
      module_name: pmt$program_name,
      module_ptr: ^ost$help_module,
      parameters: ^ost$message_parameters,
      title_container: ost$status_message,
      prompt_container: ost$status_message,
      selections: rat$menu_selections,
    recend,
    rat$menu_selection = record
      name: clt$parameter_name,
      container: ost$status_message,
    recend,
    rat$menu_selections = ^array [1 .. * ] of rat$menu_selection,
    rat$number_of_selections = 0 .. rac$max_number_of_selections,
    rat$prompt = record
      module_name: pmt$program_name,
      module_ptr: ^ost$help_module,
      name: clt$parameter_name,
      parameters: ^ost$message_parameters,
      container: ost$status_message,
    recend,
    rat$write_scl_procedure = record
      size: integer,
      value: string (osc$max_string_size),
    recend;

?? TITLE := '[XDCL, #GATE] rap$press_next_command', EJECT ??

*copy rah$press_next_command

  PROCEDURE [XDCL, #GATE] rap$press_next_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt press_next_pdt ()

?? PUSH (LISTEXT := ON) ??

    VAR
      press_next_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??

    VAR
      close_status: ost$status,
      io_identifiers: rat$io_identifiers;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   The purpose of this request is to close the input and output files on an unexpected abort.
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status;


      IF io_identifiers.input_open THEN
        fsp$close_file (io_identifiers.input, ignore_status);
        io_identifiers.input_open := FALSE;
      IFEND;

      IF io_identifiers.output_open THEN
        fsp$close_file (io_identifiers.output, ignore_status);
        io_identifiers.output_open := FALSE;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    io_identifiers.input_open := FALSE;
    io_identifiers.output_open := FALSE;

    clp$scan_parameter_list (parameter_list, press_next_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

  /press_next/
    BEGIN

      open_input_output (io_identifiers, status);
      IF NOT status.normal THEN
        EXIT /press_next/;
      IFEND;

      press_next_to_continue (io_identifiers, status);

    END /press_next/;

    close_input_output (io_identifiers, close_status);
    IF status.normal AND (NOT close_status.normal) THEN
      status := close_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$press_next_command;

?? TITLE := '[XDCL, #GATE] rap$prompt_for_value', EJECT ??

{ PURPOSE:
{   The purpose of this interface is to prompt for a value.
{
{ DESIGN:
{

  PROCEDURE [XDCL, #GATE] rap$prompt_for_value
    (    prompt_module: pmt$program_name;
         prompt_name: clt$parameter_name;
         prompt_parameters: rat$message_parameters;
         prompting_options: rat$prompting_options;
         value_declaration: rat$value_declaration;
     VAR value_returned: rat$value_returned;
     VAR status: ost$status);


    VAR
      index: rat$number_of_message_params,
      number_of_parameters: rat$number_of_message_params,
      prompt: rat$prompt;


    status.normal := TRUE;

    prompt.module_name := prompt_module;
    prompt.name := prompt_name;

    IF prompt_parameters = NIL THEN
      prompt.parameters := NIL;
    ELSE
      IF UPPERBOUND (prompt_parameters^) > rac$max_message_parameters THEN
        osp$set_status_abnormal (rac$process_id, rae$max_number_of_exceeded, 'prompt parameters', status);
        RETURN;
      IFEND;
      number_of_parameters := UPPERBOUND (prompt_parameters^);

      PUSH prompt.parameters: [1 .. number_of_parameters];
      FOR index := 1 TO number_of_parameters DO
        PUSH prompt.parameters^ [index]: [clp$trimmed_string_size (prompt_parameters^ [index])];
        prompt.parameters^ [index]^ := prompt_parameters^ [index]
              (1, clp$trimmed_string_size (prompt_parameters^ [index]));
      FOREND;
    IFEND;

{ At some point a test will be added here to determine if line or screen mode prompting should be done.
{ The appropriate interface will then be called.  Currently only line mode is avaiable.

    prompt_for_value_line_mode (value_declaration, prompting_options, prompt, value_returned, status);

  PROCEND rap$prompt_for_value;

?? TITLE := '[XDCL, #GATE] rap$prompt_for_value_command', EJECT ??

*copy rah$prompt_for_value_command

  PROCEDURE [XDCL, #GATE] rap$prompt_for_value_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt prompt_for_value_pdt (
{   prompt_module, pm     : name = $required
{   prompt_name, pn       : name = $required
{   prompt_parameters, pp : list 1..10 of string = $optional
{   prompting_options, po : list of key allow_go, allow_null, allow_quit, clear_screen = $optional
{   value_declaration, vd : list 1..2 of string or key hex, string, list = $required
{   value_returned, vr    : var of string = $requried
{   status                : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      prompt_for_value_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^prompt_for_value_pdt_names, ^prompt_for_value_pdt_params];

    VAR
      prompt_for_value_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 13] of
            clt$parameter_name_descriptor := [['PROMPT_MODULE', 1], ['PM', 1], ['PROMPT_NAME', 2], ['PN', 2],
            ['PROMPT_PARAMETERS', 3], ['PP', 3], ['PROMPTING_OPTIONS', 4], ['PO', 4],
            ['VALUE_DECLARATION', 5], ['VD', 5], ['VALUE_RETURNED', 6], ['VR', 6], ['STATUS', 7]];

    VAR
      prompt_for_value_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 7] of
            clt$parameter_descriptor := [

{ PROMPT_MODULE PM }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ PROMPT_NAME PN }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ PROMPT_PARAMETERS PP }
      [[clc$optional], 1, 10, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$string_value, 0, osc$max_string_size]],

{ PROMPTING_OPTIONS PO }
      [[clc$optional], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed,
            [^prompt_for_value_pdt_kv4, clc$keyword_value]],

{ VALUE_DECLARATION VD }
      [[clc$required], 1, 2, 1, 1, clc$value_range_not_allowed,
            [^prompt_for_value_pdt_kv5, clc$string_value, 0, osc$max_string_size]],

{ VALUE_RETURNED VR }
      [[clc$optional_with_default, ^prompt_for_value_pdt_dv6], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$string_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      prompt_for_value_pdt_kv4: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of
            ost$name := ['ALLOW_GO', 'ALLOW_NULL', 'ALLOW_QUIT', 'CLEAR_SCREEN'];

    VAR
      prompt_for_value_pdt_kv5: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            ost$name := ['HEX', 'STRING', 'LIST'];

    VAR
      prompt_for_value_pdt_dv6: [STATIC, READ, cls$pdt_names_and_defaults] string (9) := '$requried';

?? POP ??

    VAR
      index: 0 .. clc$max_value_sets,
      number_of_parameters: 0 .. clc$max_value_sets,
      prompt: rat$prompt,
      prompting_options: rat$prompting_options,
      returned: clt$variable_reference,
      val_returned_1: ost$string,
      val_returned_2: array [1 .. osc$max_string_size + 2] of cell,
      value: clt$value,
      value_declaration: rat$value_declaration,
      value_returned: rat$value_returned;


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, prompt_for_value_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('prompt_module', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    prompt.module_name := value.name.value;

    clp$get_value ('prompt_name', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    prompt.name := value.name.value;

    clp$get_set_count ('prompt_parameters', number_of_parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    prompt.parameters := NIL;
    IF number_of_parameters > 0 THEN
      PUSH prompt.parameters: [1 .. number_of_parameters];
      FOR index := 1 TO number_of_parameters DO
        clp$get_value ('prompt_parameters', index, 1, clc$low, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        PUSH prompt.parameters^ [index]: [value.str.size];
        prompt.parameters^ [index]^ := value.str.value;
      FOREND;
    IFEND;

    get_prompting_options (prompting_options, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_value_declaration (value_declaration, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ At some point a test will be added here to determine if line or screen mode prompting should be done.
{ The appropriate interface will then be called.  Currently only line mode is avaiable.

    prompt_for_value_line_mode (value_declaration, prompting_options, prompt, value_returned, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Return the value entered by the user to the caller.

    clp$get_value ('value_returned', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    returned := value.var_ref;

    val_returned_1.size := #SIZE (value_returned);
    val_returned_1.value := value_returned;
    #UNCHECKED_CONVERSION (val_returned_1, val_returned_2);
    returned.value.string_value := ^val_returned_2;
    clp$write_variable (returned.reference.value (1, returned.reference.size), returned.value, status);

  PROCEND rap$prompt_for_value_command;

?? TITLE := '[XDCL, #GATE] rap$prompt_via_menu', EJECT ??

{ PURPOSE:
{   The purpose of this interface is to prompt via a menu.
{
{ DESIGN:
{

  PROCEDURE [XDCL, #GATE] rap$prompt_via_menu
    (    menu_module: pmt$program_name;
         menu_selections: array [ * ] of ost$name;
         menu_parameters: rat$message_parameters;
         prompting_options: rat$prompting_options;
     VAR selection_chosen: ost$name;
     VAR status: ost$status);


    VAR
      index: rat$number_of_message_params,
      menu: rat$menu,
      number_of_parameters: rat$number_of_message_params,
      number_of_selections: rat$number_of_selections;

    status.normal := TRUE;

    menu.module_name := menu_module;

    IF UPPERBOUND (menu_selections) > rac$max_number_of_selections THEN
      osp$set_status_abnormal (rac$process_id, rae$max_number_of_exceeded, 'menu selections', status);
      RETURN;
    IFEND;
    number_of_selections := UPPERBOUND (menu_selections);

    PUSH menu.selections: [1 .. number_of_selections];
    FOR index := 1 TO number_of_selections DO
      menu.selections^ [index].name := menu_selections [index];
    FOREND;

{ The first menu parameter is reserved for the selection keys.  This is put on the parameter list
{ automatically.  Any additional parameters that the caller of this interface has provided are then
{ added.

    number_of_parameters := 0;
    IF menu_parameters <> NIL THEN
      IF UPPERBOUND (menu_parameters^) > rac$max_message_parameters - 1 THEN
        osp$set_status_abnormal (rac$process_id, rae$max_number_of_exceeded, 'menu parameters', status);
        RETURN;
      IFEND;
      number_of_parameters := UPPERBOUND (menu_parameters^);
    IFEND;

    PUSH menu.parameters: [1 .. number_of_parameters + 1];
    PUSH menu.parameters^ [1]: [rac$selection_key_size];
    FOR index := 1 TO number_of_parameters DO
      PUSH menu.parameters^ [index + 1]: [clp$trimmed_string_size (menu_parameters^ [index])];
      menu.parameters^ [index + 1]^ := menu_parameters^ [index]
            (1, clp$trimmed_string_size (menu_parameters^ [index]));
    FOREND;

{ At some point a test will be added here to determine if line or screen mode prompting should be done.
{ The appropriate interface will then be called.  Currently only line mode is avaiable.

    prompt_via_menu_line_mode (prompting_options, menu, selection_chosen, status);

  PROCEND rap$prompt_via_menu;

?? TITLE := '[XDCL, #GATE] rap$prompt_via_menu_command', EJECT ??

*copy rah$prompt_via_menu_command
{
{ DESIGN:
{    A menu is defined as having a title, the selections (or choices), and a
{  prompt.  The title defines the purpose of the menu.  The title can be from
{  a couple word statement to a paragraph of information.  The selections is
{  a list (numbered from 1 to n, where n <= 10).  The prompt demands the user
{  to take action.  The actions available are requesting general help on the
{  menu (entering '?'), requesting help on a specific selection (enter
{  selection number followed by a '?') or selecting one of the choices (enter
{  the selection number).  After the choice is verified the name that
{  corresponds to the selection is returned to the calling interface.
{
{    A menu has all of the formating flexibility that the help messages have.
{  Parameter inputs can be used to create menus that contain data supplied by
{  the user or from another source.
{
{    The function of a message module is to provide help for a user executing
{  commands interactively.  Therefore the kinds of messages found in a
{  message module reflect that purpose.  In setting up menus using message
{  module technology the message kinds are interpreted for menus.
{
{    a.  The menu title is created as the brief help message.
{    b.  The menu help is created as the full help message.
{    c.  The menu selections are created as parameter prompt messages.
{    d.  The menu selection help (optional) is created as a parameter help
{        message.
{    e.  the menu selection confirmation (optional) is created as a
{        parameter assist message.
{    f.  The menu prompt is created as a parameter prompt message and
{        given the special name 'prompt'.
{
{    Because of the menu definition there can only be one menu defined by
{  one help module.
{
{ NOTES:
{   The first menu parameter is reserved for the selection key.  Any additional
{   parameter inputs are added after this.

  PROCEDURE [XDCL, #GATE] rap$prompt_via_menu_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt prompt_via_menu_pdt (
{   menu_module, mm       : name = $required
{   menu_selections, ms   : list 1..10 of name = $required
{   menu_parameters, mp   : list 1..50 of string = $optional
{   prompting_options, po : list of key allow_go, allow_null, allow_quit, clear_screen, confirm_selection ..
{                         = $optional
{   selection_chosen, sc  : var of string = $required
{   status                : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      prompt_via_menu_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^prompt_via_menu_pdt_names, ^prompt_via_menu_pdt_params];

    VAR
      prompt_via_menu_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 11] of
            clt$parameter_name_descriptor := [['MENU_MODULE', 1], ['MM', 1], ['MENU_SELECTIONS', 2],
            ['MS', 2], ['MENU_PARAMETERS', 3], ['MP', 3], ['PROMPTING_OPTIONS', 4], ['PO', 4],
            ['SELECTION_CHOSEN', 5], ['SC', 5], ['STATUS', 6]];

    VAR
      prompt_via_menu_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 6] of
            clt$parameter_descriptor := [

{ MENU_MODULE MM }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ MENU_SELECTIONS MS }
      [[clc$required], 1, 10, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ MENU_PARAMETERS MP }
      [[clc$optional], 1, 50, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$string_value, 0, osc$max_string_size]],

{ PROMPTING_OPTIONS PO }
      [[clc$optional], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed,
            [^prompt_via_menu_pdt_kv4, clc$keyword_value]],

{ SELECTION_CHOSEN SC }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$string_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

    VAR
      prompt_via_menu_pdt_kv4: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
            ost$name := ['ALLOW_GO', 'ALLOW_NULL', 'ALLOW_QUIT', 'CLEAR_SCREEN', 'CONFIRM_SELECTION'];

?? POP ??

    VAR
      index: 0 .. clc$max_value_sets,
      menu: rat$menu,
      number_of_parameters: 0 .. clc$max_value_sets,
      number_of_selections: 0 .. clc$max_value_sets,
      prompting_options: rat$prompting_options,
      selection: clt$variable_reference,
      selection_chosen: ost$name,
      selection_val_1: ost$string,
      selection_val_2: array [1 .. osc$max_string_size + 2] of cell,
      value: clt$value;


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, prompt_via_menu_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('menu_module', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    menu.module_name := value.name.value;

    clp$get_set_count ('menu_selections', number_of_selections, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH menu.selections: [1 .. number_of_selections];
    FOR index := 1 TO number_of_selections DO
      clp$get_value ('menu_selections', index, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      menu.selections^ [index].name := value.name.value;
    FOREND;

    clp$get_set_count ('menu_parameters', number_of_parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH menu.parameters: [1 .. number_of_parameters + 1];
    PUSH menu.parameters^ [1]: [rac$selection_key_size];
    IF number_of_parameters > 0 THEN
      FOR index := 1 TO number_of_parameters DO
        clp$get_value ('menu_parameters', index, 1, clc$low, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        PUSH menu.parameters^ [index + 1]: [value.str.size];
        menu.parameters^ [index + 1]^ := value.str.value;
      FOREND;
    IFEND;

    get_prompting_options (prompting_options, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ At some point a test will be added here to determine if line or screen mode prompting should be done.
{ The appropriate interface will then be called.  Currently only line mode is avaiable.

    prompt_via_menu_line_mode (prompting_options, menu, selection_chosen, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Return the menu selection value chosen to the caller.

    clp$get_value ('selection_chosen', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    selection := value.var_ref;

    selection_val_1.size := #SIZE (selection_chosen);
    selection_val_1.value := selection_chosen;
    #UNCHECKED_CONVERSION (selection_val_1, selection_val_2);
    selection.value.string_value := ^selection_val_2;
    clp$write_variable (selection.reference.value (1, selection.reference.size), selection.value, status);

  PROCEND rap$prompt_via_menu_command;

?? TITLE := 'close_input_output', EJECT ??

{ PURPOSE:
{   The purpose of this request is to close the input and output files.
{
{ DESIGN:
{

  PROCEDURE close_input_output
    (VAR io_identifiers: rat$io_identifiers;
     VAR status: ost$status);

    VAR
      close_status: ost$status;

    status.normal := TRUE;

    fsp$close_file (io_identifiers.input, status);
    IF status.normal THEN
      io_identifiers.input_open := FALSE;
    IFEND;

    fsp$close_file (io_identifiers.output, close_status);
    IF close_status.normal THEN
      io_identifiers.output_open := FALSE;
    ELSEIF status.normal THEN
      status := close_status;
    IFEND;

  PROCEND close_input_output;

?? TITLE := 'confirm_selection', EJECT ??

{ PURPOSE:
{   The purpose of this request is to prompt for a confirmation of the selection chosen.
{
{ DESIGN:
{

  PROCEDURE confirm_selection
    (    module_ptr: ^ost$help_module;
         selection_name: ost$name;
         selection_key: string ( * <= osc$max_string_size);
         io_identifiers: rat$io_identifiers;
     VAR confirmed: boolean;
     VAR status: ost$status);

    VAR
      ignore_byte_address: amt$file_byte_address,
      ignore_file_position: amt$file_position,
      ignore_result: boolean,
      ignore_status: ost$status,
      line_length: integer,
      line_start: integer,
      message_container: ost$status_message,
      message_template: ^ost$message_template,
      response_line: string (osc$max_string_size),
      transfer_count: amt$transfer_count,
      translated_response: string (osc$max_string_size),
      valid_response: boolean;


    status.normal := TRUE;

    osp$find_param_assist_prompt (module_ptr, selection_name, message_template, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF message_template <> NIL THEN
      osp$format_help_message (message_template, NIL, rac$max_line, message_container, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      issue_message (message_container, io_identifiers.output, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    valid_response := FALSE;

    REPEAT

      issue_status_message (rae$confirmation_prompt, selection_key, io_identifiers.output, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      response_line := '';
      amp$get_next (io_identifiers.input, ^response_line, #SIZE (response_line), transfer_count,
            ignore_byte_address, ignore_file_position, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (transfer_count = 0) OR (response_line = '') THEN
        issue_status_message (rae$invalid_response, '', io_identifiers.output, status);
        press_next_to_continue (io_identifiers, ignore_status);
      ELSE
        #SCAN (clv$non_space, response_line, line_start, ignore_result);
        line_length := clp$trimmed_string_size (response_line) - line_start + 1;
        #TRANSLATE (osv$lower_to_upper, response_line (line_start, line_length), translated_response);
        IF (translated_response = 'YES') OR (translated_response = 'Y') THEN
          confirmed := TRUE;
          valid_response := TRUE;
        ELSEIF (translated_response = 'NO') OR (translated_response = 'N') THEN
          confirmed := FALSE;
          valid_response := TRUE;
        ELSE
          issue_status_message (rae$invalid_response, '', io_identifiers.output, status);
          press_next_to_continue (io_identifiers, ignore_status);
        IFEND;
      IFEND;

    UNTIL valid_response;

  PROCEND confirm_selection;

?? TITLE := 'display_menu_help', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display the requested menu help when it exists.
{
{ DESIGN:
{

  PROCEDURE display_menu_help
    (    menu: rat$menu;
         selection_chosen: ost$name;
         io_identifiers: rat$io_identifiers;
     VAR status: ost$status);

    VAR
      help_container: ost$status_message,
      help_template: ^ost$message_template,
      ignore_status: ost$status;


    status.normal := TRUE;

    IF selection_chosen = '' THEN
      osp$find_full_help_message (menu.module_ptr, help_template, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF help_template = NIL THEN
        issue_status_message (rae$no_help_for_menu, '', io_identifiers.output, status);
        press_next_to_continue (io_identifiers, ignore_status);
        RETURN;
      IFEND;

    ELSE
      osp$find_parameter_help_message (menu.module_ptr, selection_chosen, help_template, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF help_template = NIL THEN
        issue_status_message (rae$no_help_for_menu_selection, selection_chosen, io_identifiers.output,
              status);
        press_next_to_continue (io_identifiers, ignore_status);
        RETURN;
      IFEND;
    IFEND;

    osp$format_help_message (help_template, menu.parameters, rac$max_line, help_container, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    issue_message (help_container, io_identifiers.output, status);
    press_next_to_continue (io_identifiers, ignore_status);

  PROCEND display_menu_help;

?? TITLE := 'display_value_help', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display the help for the requested value when it exists.
{
{ DESIGN:
{

  PROCEDURE display_value_help
    (    prompt: rat$prompt;
         io_identifiers: rat$io_identifiers;
     VAR status: ost$status);

    VAR
      help_container: ost$status_message,
      help_template: ^ost$message_template,
      ignore_status: ost$status;


    status.normal := TRUE;

    osp$find_parameter_help_message (prompt.module_ptr, prompt.name, help_template, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF help_template = NIL THEN
      issue_status_message (rae$no_help_for_value, '', io_identifiers.output, status);
      press_next_to_continue (io_identifiers, ignore_status);
      RETURN;
    IFEND;

    osp$format_help_message (help_template, prompt.parameters, rac$max_line, help_container, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    issue_message (help_container, io_identifiers.output, status);
    press_next_to_continue (io_identifiers, ignore_status);

  PROCEND display_value_help;

?? TITLE := 'get_menu_response', EJECT ??

{ PURPOSE:
{   The purpose of this request is to get the user response for the menu issued.
{
{ DESIGN:
{

  PROCEDURE get_menu_response
    (    menu: rat$menu;
         prompting_options: rat$prompting_options;
         io_identifiers: rat$io_identifiers;
     VAR selection_chosen: ost$name;
     VAR help_requested: boolean;
     VAR status: ost$status);

    VAR
      confirmed: boolean,
      ignore_status: ost$status,
      key_chosen: clt$integer,
      length: integer,
      processed: boolean,
      response: string (osc$max_string_size);


    status.normal := TRUE;
    help_requested := FALSE;
    selection_chosen := '';

    get_response (prompting_options, io_identifiers, response, length, processed, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF processed THEN
      selection_chosen := response (1, length);

    ELSE
      IF response (length) = '?' THEN
        help_requested := TRUE;
        length := length - 1;
      IFEND;

      IF length <> 0 THEN
        clp$convert_string_to_integer (response (1, length), key_chosen, status);
        IF status.normal AND (key_chosen.value > 0) AND (key_chosen.value <= UPPERBOUND (menu.selections^))
              THEN
          selection_chosen := menu.selections^ [key_chosen.value].name;
          IF (rac$confirm_selection IN prompting_options) AND (NOT help_requested) THEN
            confirm_selection (menu.module_ptr, selection_chosen, response (1, length), io_identifiers,
                  confirmed, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            IF NOT confirmed THEN
              selection_chosen := '+INVALID_RESPONSE';
            IFEND;
          IFEND;
        ELSE
          help_requested := FALSE;
          selection_chosen := '+INVALID_RESPONSE';
          issue_status_message (rae$not_valid_selection, response (1, length), io_identifiers.output, status);
          press_next_to_continue (io_identifiers, ignore_status);
          RETURN;
        IFEND;
      IFEND;
    IFEND;

  PROCEND get_menu_response;

?? TITLE := 'get_prompting_options', EJECT ??

{ PURPOSE:
{   The purpose of this request is to get the prompting options from the parameter list.
{
{ DESIGN:
{   The SCL parameter for prompting options is a list of keys.  These are optional.


  PROCEDURE get_prompting_options
    (VAR prompting_options: rat$prompting_options;
     VAR status: ost$status);

    VAR
      index: 0 .. clc$max_value_sets,
      number_in_option_set: 0 .. clc$max_value_sets,
      option: ost$name,
      value: clt$value;


    status.normal := TRUE;

    prompting_options := $rat$prompting_options [];

    clp$get_set_count ('prompting_options', number_in_option_set, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR index := 1 TO number_in_option_set DO
      clp$get_value ('prompting_options', index, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      option := value.name.value;

      IF option = 'ALLOW_GO' THEN
        prompting_options := prompting_options + $rat$prompting_options [rac$allow_go];
      ELSEIF option = 'ALLOW_NULL' THEN
        prompting_options := prompting_options + $rat$prompting_options [rac$allow_null];
      ELSEIF option = 'ALLOW_QUIT' THEN
        prompting_options := prompting_options + $rat$prompting_options [rac$allow_quit];
      ELSEIF option = 'CLEAR_SCREEN' THEN
        prompting_options := prompting_options + $rat$prompting_options [rac$clear_screen];
      ELSEIF option = 'CONFIRM_SELECTION' THEN { only with prompt_via_menu }
        prompting_options := prompting_options + $rat$prompting_options [rac$confirm_selection];
      IFEND;

    FOREND;

  PROCEND get_prompting_options;

?? TITLE := 'get_response', EJECT ??

{ PURPOSE:
{   The purpose of this request is to get the user response.
{
{ DESIGN:
{

  PROCEDURE get_response
    (    prompting_options: rat$prompting_options;
         io_identifiers: rat$io_identifiers;
     VAR response: string (osc$max_string_size);
     VAR length: integer;
     VAR processed: boolean;
     VAR status: ost$status);

    VAR
      ignore_byte_address: amt$file_byte_address,
      ignore_file_position: amt$file_position,
      ignore_result: boolean,
      ignore_status: ost$status,
      line_length: integer,
      line_start: integer,
      response_line: string (osc$max_string_size),
      transfer_count: amt$transfer_count,
      translated_response: string (osc$max_string_size);


    status.normal := TRUE;
    processed := TRUE;
    response_line := '';

    amp$get_next (io_identifiers.input, ^response_line, #SIZE (response_line), transfer_count,
          ignore_byte_address, ignore_file_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (transfer_count = 0) OR (response_line = '') THEN
      IF rac$allow_null IN prompting_options THEN
        response := '+NULL';
      ELSE
        response := '+INVALID_RESPONSE';
        issue_status_message (rae$invalid_response, '', io_identifiers.output, status);
        press_next_to_continue (io_identifiers, ignore_status);
      IFEND;

    ELSE

      #SCAN (clv$non_space, response_line, line_start, ignore_result);
      line_length := clp$trimmed_string_size (response_line) - line_start + 1;

      #TRANSLATE (osv$lower_to_upper, response_line (line_start, line_length), translated_response);
      IF (rac$allow_go IN prompting_options) AND ((translated_response = 'GO') OR (translated_response = 'G'))
            THEN
        response := '+GO';
      ELSEIF (rac$allow_quit IN prompting_options) AND ((translated_response = 'QUIT') OR
            (translated_response = 'QUI') OR (translated_response = 'Q')) THEN
        response := '+QUIT';
      ELSE
        response := response_line (line_start, line_length);
        processed := FALSE;
      IFEND;
    IFEND;

    length := clp$trimmed_string_size (response);

  PROCEND get_response;

?? TITLE := 'get_value_declaration', EJECT ??

{ PURPOSE:
{   The purpose of this request is to get the value declaration from the parameter list.
{
{ DESIGN:
{   The SCL parameter for value declaration is a list of string or key.  The value declaration is made
{   up of two parts.  The first part is the value specification which must be a string.  This is required.
{   The second part is a processing key.  This is optional.

  PROCEDURE get_value_declaration
    (VAR value_declaration: rat$value_declaration;
     VAR status: ost$status);

    VAR
      declaration_set_count: 0 .. clc$max_value_sets,
      value: clt$value;


    status.normal := TRUE;

    clp$get_value ('value_declaration', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.kind <> clc$string_value THEN
      osp$set_status_abnormal (rac$process_id, rae$bad_value_specification, '', status);
      RETURN;
    IFEND;

    value_declaration.specification := value.str.value;
    value_declaration.key := rac$undeclared;

    clp$get_set_count ('value_declaration', declaration_set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF declaration_set_count = 2 THEN
      clp$get_value ('value_declaration', 2, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF value.kind <> clc$name_value THEN
        osp$set_status_abnormal (rac$process_id, rae$bad_value_key, '', status);
        RETURN;
      IFEND;

      IF value.name.value = 'HEX' THEN
        value_declaration.key := rac$hex;
      ELSEIF value.name.value = 'LIST' THEN
        value_declaration.key := rac$list;
      ELSEIF value.name.value = 'STRING' THEN
        value_declaration.key := rac$string;
      IFEND;
    IFEND;

  PROCEND get_value_declaration;

?? TITLE := 'get_value_response', EJECT ??

{ PURPOSE:
{   The purpose of this request is to get the user response to the prompt issued.
{
{ DESIGN:
{

  PROCEDURE get_value_response
    (    value_declaration: rat$value_declaration;
         validation_procedure: ost$name;
         prompting_options: rat$prompting_options;
         io_identifiers: rat$io_identifiers;
     VAR value_returned: rat$value_returned;
     VAR help_requested: boolean;
     VAR status: ost$status);

    VAR
      command: string (osc$max_string_size),
      ignore_status: ost$status,
      length: integer,
      processed: boolean,
      response: string (osc$max_string_size),
      size: integer,
      validation_status: ost$status,
      value_length: integer,
      value_string: string (osc$max_string_size);


    status.normal := TRUE;
    help_requested := FALSE;
    value_returned := '';

    get_response (prompting_options, io_identifiers, response, length, processed, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF processed THEN
      value_returned := response (1, length);

    ELSEIF response = '?' THEN
      help_requested := TRUE;

    ELSE
      CASE value_declaration.key OF
      = rac$hex =
        STRINGREP (value_string, value_length, '0', response (1, length), '(16)');
      = rac$list =
        STRINGREP (value_string, value_length, '(', response (1, length), ')');
      = rac$string =
        STRINGREP (value_string, value_length, '''', response (1, length), '''');
      ELSE
        STRINGREP (value_string, value_length, response (1, length));
      CASEND;

      STRINGREP (command, size, validation_procedure, ' value=', value_string (1, value_length));
      clp$include_command (command (1, size), TRUE, validation_status);
      IF NOT validation_status.normal THEN
        value_returned := '+INVALID_RESPONSE';
        issue_status_message (rae$bad_value, response (1, length), io_identifiers.output, status);
        press_next_to_continue (io_identifiers, ignore_status);
        RETURN;
      IFEND;

      value_returned := response (1, length);

    IFEND;

  PROCEND get_value_response;

?? TITLE := 'initialize_menu_prompt', EJECT ??

{ PURPOSE:
{   The purpose of this request is to initialize the menu containers for displaying the menu prompt.
{
{ DESIGN:
{

  PROCEDURE initialize_menu_prompt
    (VAR menu: rat$menu;
     VAR status: ost$status);

    VAR
      i: rat$number_of_selections,
      ignore_identifier: ost$status_identifier,
      ignore_natural_language: ost$natural_language,
      ignore_online_manual_name: ost$online_manual_name,
      menu_prompt: ost$status,
      prompt_name: [STATIC] ost$name := 'PROMPT                         ',
      prompt_template: ^ost$message_template,
      selection_key: ^string ( * ),
      selection_template: ^ost$message_template,
      title_template: ^ost$message_template;


    status.normal := TRUE;

    osp$find_help_module (menu.module_name, menu.module_ptr, ignore_online_manual_name,
          ignore_natural_language, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$find_brief_help_message (menu.module_ptr, title_template, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF title_template = NIL THEN
      osp$set_status_abnormal (rac$process_id, rae$menu_definition_error, menu.module_name, status);
      RETURN;
    IFEND;

    osp$format_help_message (title_template, menu.parameters, rac$max_line, menu.title_container, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH selection_key: [rac$selection_key_size];

    FOR i := 1 TO UPPERBOUND (menu.selections^) DO

      clp$convert_integer_to_rjstring (i, 10, FALSE, ' ', selection_key^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      menu.parameters^ [1]^ := selection_key^;

      osp$find_parameter_prompt (menu.module_ptr, menu.selections^ [i].name, selection_template, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF selection_template = NIL THEN
        osp$set_status_abnormal (rac$process_id, rae$menu_definition_error, menu.module_name, status);
        RETURN;
      IFEND;

      osp$format_help_message (selection_template, menu.parameters, rac$max_line,
            menu.selections^ [i].container, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    FOREND;

{ Initialize the menu's prompt section.

    osp$find_parameter_prompt (menu.module_ptr, prompt_name, prompt_template, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF prompt_template = NIL THEN
      osp$set_status_abnormal (rac$process_id, rae$menu_definition_error, menu.module_name, status);
      RETURN;
    IFEND;

    osp$format_help_message (prompt_template, menu.parameters, rac$max_line, menu.prompt_container, status);

  PROCEND initialize_menu_prompt;

?? TITLE := 'initialize_validation_procedure', EJECT ??

{ PURPOSE:
{   The purpose of this request is to set up the SCL procedure that validates the value input.
{
{ DESIGN:
{

  PROCEDURE initialize_validation_procedure
    (    value_declaration: rat$value_declaration;
     VAR validation_procedure: ost$name;
     VAR status: ost$status);

    CONST
      number_of_procedure_lines = 4;

    VAR
      specification_size: integer,
      ignore_byte_address: amt$file_byte_address,
      procedure_lines: array [1 .. number_of_procedure_lines] of rat$write_scl_procedure,
      procedure_fid: amt$file_identifier,
      i: 1 .. number_of_procedure_lines + 1,
      write_attachment: array [1 .. 2] of fst$attachment_option;


    specification_size := clp$trimmed_string_size (value_declaration.specification);

    STRINGREP (procedure_lines [1].value, procedure_lines [1].size, ' PROC validate_value (');
    STRINGREP (procedure_lines [2].value, procedure_lines [2].size, '   value : ',
          value_declaration.specification (1, specification_size));
    STRINGREP (procedure_lines [3].value, procedure_lines [3].size, '   )');
    STRINGREP (procedure_lines [4].value, procedure_lines [4].size, ' PROCEND validate_value');

    write_attachment [1].selector := fsc$access_and_share_modes;
    write_attachment [1].access_modes.selector := fsc$specific_access_modes;
    write_attachment [1].access_modes.value := $fst$file_access_options
          [fsc$read, fsc$shorten, fsc$modify, fsc$append];
    write_attachment [1].share_modes.selector := fsc$determine_from_access_modes;
    write_attachment [2].selector := fsc$create_file;
    write_attachment [2].create_file := TRUE;

    pmp$get_unique_name (validation_procedure, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$open_file (validation_procedure, amc$record, ^write_attachment, NIL, NIL, NIL, NIL, procedure_fid,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO number_of_procedure_lines DO
      amp$put_next (procedure_fid, ^procedure_lines [i].value, procedure_lines [i].size, ignore_byte_address,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    fsp$close_file (procedure_fid, status);

  PROCEND initialize_validation_procedure;

?? TITLE := 'initialize_value_prompt', EJECT ??

{ PURPOSE:
{   The purpose of this request is to initialize the prompt container for displaying the prompt.
{
{ DESIGN:
{

  PROCEDURE initialize_value_prompt
    (VAR prompt: rat$prompt;
     VAR status: ost$status);

    VAR
      ignore_natural_language: ost$natural_language,
      ignore_online_manual_name: ost$online_manual_name,
      prompt_template: ^ost$message_template;


    status.normal := TRUE;

    osp$find_help_module (prompt.module_name, prompt.module_ptr, ignore_online_manual_name,
          ignore_natural_language, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF prompt.module_ptr = NIL THEN
      osp$set_status_abnormal (rac$process_id, rae$module_access_error, prompt.module_name, status);
      RETURN;
    IFEND;

    osp$find_parameter_prompt (prompt.module_ptr, prompt.name, prompt_template, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF prompt_template = NIL THEN
      osp$set_status_abnormal (rac$process_id, rae$message_not_found, prompt.name, status);
      RETURN;
    IFEND;

    osp$format_help_message (prompt_template, prompt.parameters, rac$max_line, prompt.container, status);

  PROCEND initialize_value_prompt;

?? TITLE := 'issue_menu_prompt', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display the menu to output.
{
{ DESIGN:
{

  PROCEDURE issue_menu_prompt
    (    menu: rat$menu;
         prompting_options: rat$prompting_options;
         io_identifiers: rat$io_identifiers;
     VAR status: ost$status);

    VAR
      clear_screen: [STATIC, READ, oss$job_paged_literal] string (2) := '1 ',
      i: rat$number_of_selections,
      ignore_byte_address: amt$file_byte_address;


    status.normal := TRUE;

    IF rac$clear_screen IN prompting_options THEN
      amp$put_next (io_identifiers.output, ^clear_screen, #SIZE (clear_screen), ignore_byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    issue_message (menu.title_container, io_identifiers.output, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO UPPERBOUND (menu.selections^) DO
      issue_message (menu.selections^ [i].container, io_identifiers.output, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

    issue_message (menu.prompt_container, io_identifiers.output, status);

  PROCEND issue_menu_prompt;

?? TITLE := 'issue_message', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display a message from a message container to output.
{
{ DESIGN:
{

  PROCEDURE issue_message
    (    message_container: ost$status_message;
         output_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      ignore_byte_address: amt$file_byte_address,
      message_container_ptr: ^ost$status_message,
      message_line: ^ost$status_message_line,
      message_line_count: ^ost$status_message_line_count,
      message_line_index: 1 .. osc$max_status_message_lines,
      message_line_size: ^ost$status_message_line_size;


    status.normal := TRUE;

    message_container_ptr := ^message_container;
    RESET message_container_ptr;
    NEXT message_line_count IN message_container_ptr;

    FOR message_line_index := 1 TO message_line_count^ DO
      NEXT message_line_size IN message_container_ptr;
      NEXT message_line: [message_line_size^] IN message_container_ptr;

      amp$put_next (output_id, message_line, message_line_size^, ignore_byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND issue_message;

?? TITLE := 'issue_status_message', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display an informative message from a status condition to output.
{
{ DESIGN:
{   The status condition is expected to be at the informative level.  When an informative condition is
{   formated as a brief message, two dashes and a space are appended to the front of the message.  This
{   interface strips the two dashes and two spaces off of the first line in the message container, pads
{   it with blanks to the right, and then puts out the message.

  PROCEDURE issue_status_message
    (    message_condition: ost$status_condition_code;
         message_text: string ( * <= osc$max_string_size);
         output_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      ignore_identifier: ost$status_identifier,
      message_container: ost$status_message,
      message_container_ptr: ^ost$status_message,
      message_line: ^ost$status_message_line,
      message_line_count: ^ost$status_message_line_count,
      message_line_size: ^ost$status_message_line_size,
      message_severity: ost$status_severity,
      message_status: ost$status,
      temp_line: ^ost$status_message_line;


    status.normal := TRUE;

    osp$get_status_severity (message_condition, message_severity, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF message_severity <> osc$informative_status THEN
      osp$set_status_abnormal (rac$process_id, rae$message_not_informative, '', status);
      RETURN;
    IFEND;

    osp$set_status_abnormal (ignore_identifier, message_condition, message_text, message_status);

    osp$format_message (message_status, osc$brief_message_level, rac$max_line, message_container, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    message_container_ptr := ^message_container;
    RESET message_container_ptr;
    NEXT message_line_count IN message_container_ptr;
    NEXT message_line_size IN message_container_ptr;
    NEXT message_line: [message_line_size^] IN message_container_ptr;
    PUSH temp_line: [message_line_size^];

    temp_line^ (1, * ) := message_line^ (5, message_line_size^ -4);
    message_line^ (1, message_line_size^) := temp_line^ (1, message_line_size^);

    issue_message (message_container, output_id, status);

  PROCEND issue_status_message;

?? TITLE := 'issue_value_prompt', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display the prompt to output.
{
{ DESIGN:
{

  PROCEDURE issue_value_prompt
    (    prompt: rat$prompt;
         prompting_options: rat$prompting_options;
         io_identifiers: rat$io_identifiers;
     VAR status: ost$status);

    VAR
      clear_screen: [STATIC, READ, oss$job_paged_literal] string (2) := '1 ',
      ignore_byte_address: amt$file_byte_address;


    status.normal := TRUE;

    IF rac$clear_screen IN prompting_options THEN
      amp$put_next (io_identifiers.output, ^clear_screen, #SIZE (clear_screen), ignore_byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    issue_message (prompt.container, io_identifiers.output, status);

  PROCEND issue_value_prompt;

?? TITLE := 'open_input_output', EJECT ??

{ PURPOSE:
{   The purpose of this request is to open the $input and $output files.
{
{ DESIGN:
{

  PROCEDURE open_input_output
    (VAR io_identifiers: rat$io_identifiers;
     VAR status: ost$status);

    VAR
      read_only_attachment: array [1 .. 2] of fst$attachment_option,
      write_attachment: array [1 .. 3] of fst$attachment_option;


    status.normal := TRUE;

    read_only_attachment [1].selector := fsc$access_and_share_modes;
    read_only_attachment [1].access_modes.selector := fsc$specific_access_modes;
    read_only_attachment [1].access_modes.value := $fst$file_access_options [fsc$read];
    read_only_attachment [1].share_modes.selector := fsc$determine_from_access_modes;
    read_only_attachment [2].selector := fsc$create_file;
    read_only_attachment [2].create_file := FALSE;

    fsp$open_file ('$INPUT', amc$record, ^read_only_attachment, NIL, NIL, NIL, NIL, io_identifiers.input,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    io_identifiers.input_open := TRUE;

    write_attachment [1].selector := fsc$access_and_share_modes;
    write_attachment [1].access_modes.selector := fsc$specific_access_modes;
    write_attachment [1].access_modes.value := $fst$file_access_options
          [fsc$append, fsc$shorten];
    write_attachment [1].share_modes.selector := fsc$determine_from_access_modes;
    write_attachment [2].selector := fsc$access_and_share_modes;
    write_attachment [2].access_modes.selector := fsc$specific_access_modes;
    write_attachment [2].access_modes.value := $fst$file_access_options
          [fsc$append];
    write_attachment [2].share_modes.selector := fsc$determine_from_access_modes;
    write_attachment [3].selector := fsc$create_file;
    write_attachment [3].create_file := FALSE;

    fsp$open_file ('$OUTPUT', amc$record, ^write_attachment, NIL, NIL, NIL, NIL, io_identifiers.output,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    io_identifiers.output_open := TRUE;

  PROCEND open_input_output;

?? TITLE := 'press_next_to_continue', EJECT ??

{ PURPOSE:
{   The purpose of this request is to allow the user to acknowledge previously issued statements before
{   continuing.  Pressing a carriage return causes the processing to continue.
{
{ DESIGN:
{

  PROCEDURE press_next_to_continue
    (    io_identifiers: rat$io_identifiers;
     VAR status: ost$status);

    VAR
      ignore_byte_address: amt$file_byte_address,
      ignore_file_position: amt$file_position,
      ignore_transfer_count: amt$transfer_count,
      ignore_response: string (osc$max_string_size);


    status.normal := TRUE;

    issue_status_message (rae$press_next, '', io_identifiers.output, status);

    amp$get_next (io_identifiers.input, ^ignore_response, #SIZE (ignore_response), ignore_transfer_count,
          ignore_byte_address, ignore_file_position, status);

  PROCEND press_next_to_continue;

?? TITLE := 'prompt_for_value_line_mode', EJECT ??

{ PURPOSE:
{   The purpose of this request is to prompt for a value response in line mode.
{
{ DESIGN:
{

  PROCEDURE prompt_for_value_line_mode
    (    value_declaration: rat$value_declaration;
         prompting_options: rat$prompting_options;
     VAR prompt: rat$prompt;
     VAR value_returned: rat$value_returned;
     VAR status: ost$status);

    VAR
      close_status: ost$status,
      help_requested: boolean,
      ignore_status: ost$status,
      io_identifiers: rat$io_identifiers,
      valid_value: boolean,
      validation_procedure: ost$name;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   The purpose of this request is to close the input and output files on an unexpected abort.
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status;


      IF io_identifiers.input_open THEN
        fsp$close_file (io_identifiers.input, ignore_status);
        io_identifiers.input_open := FALSE;
      IFEND;

      IF io_identifiers.output_open THEN
        fsp$close_file (io_identifiers.output, ignore_status);
        io_identifiers.output_open := FALSE;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    valid_value := FALSE;
    io_identifiers.input_open := FALSE;
    io_identifiers.output_open := FALSE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /get_value/
    BEGIN

      open_input_output (io_identifiers, status);
      IF NOT status.normal THEN
        EXIT /get_value/;
      IFEND;

      initialize_value_prompt (prompt, status);
      IF NOT status.normal THEN
        EXIT /get_value/;
      IFEND;

      initialize_validation_procedure (value_declaration, validation_procedure, status);
      IF NOT status.normal THEN
        EXIT /get_value/;
      IFEND;

      REPEAT

        issue_value_prompt (prompt, prompting_options, io_identifiers, status);
        IF NOT status.normal THEN
          EXIT /get_value/;
        IFEND;

        get_value_response (value_declaration, validation_procedure, prompting_options, io_identifiers,
              value_returned, help_requested, status);
        IF NOT status.normal THEN
          EXIT /get_value/;
        IFEND;

        IF help_requested THEN
          display_value_help (prompt, io_identifiers, status);
          IF NOT status.normal THEN
            EXIT /get_value/;
          IFEND;
        ELSEIF value_returned <> '+INVALID_RESPONSE' THEN
          valid_value := TRUE;
        IFEND;

      UNTIL valid_value;

      amp$return (validation_procedure, ignore_status);

    END /get_value/;

    close_input_output (io_identifiers, close_status);
    IF status.normal AND (NOT close_status.normal) THEN
      status := close_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND prompt_for_value_line_mode;

?? TITLE := 'prompt_via_menu_line_mode', EJECT ??

{ PURPOSE:
{   The purpose of this request is to provide prompting via a menu display in line mode.
{
{ DESIGN:
{

  PROCEDURE prompt_via_menu_line_mode
    (    prompting_options: rat$prompting_options;
     VAR menu: rat$menu;
     VAR selection_chosen: ost$name;
     VAR status: ost$status);

    VAR
      help_requested: boolean,
      input_open: boolean,
      io_identifiers: rat$io_identifiers,
      close_status: ost$status,
      output_open: boolean,
      valid_selection: boolean;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   The purpose of this request is to close the input and output files on an unexpected abort.
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status;

      IF io_identifiers.input_open THEN
        fsp$close_file (io_identifiers.input, ignore_status);
        io_identifiers.input_open := FALSE;
      IFEND;

      IF io_identifiers.output_open THEN
        fsp$close_file (io_identifiers.output, ignore_status);
        io_identifiers.output_open := FALSE;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    valid_selection := FALSE;
    io_identifiers.input_open := FALSE;
    io_identifiers.output_open := FALSE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /get_selection/
    BEGIN

      open_input_output (io_identifiers, status);
      IF NOT status.normal THEN
        EXIT /get_selection/;
      IFEND;

      initialize_menu_prompt (menu, status);
      IF NOT status.normal THEN
        EXIT /get_selection/;
      IFEND;

      REPEAT

        issue_menu_prompt (menu, prompting_options, io_identifiers, status);
        IF NOT status.normal THEN
          EXIT /get_selection/;
        IFEND;

        get_menu_response (menu, prompting_options, io_identifiers, selection_chosen, help_requested, status);
        IF NOT status.normal THEN
          EXIT /get_selection/;
        IFEND;

        IF help_requested THEN
          display_menu_help (menu, selection_chosen, io_identifiers, status);
          IF NOT status.normal THEN
            EXIT /get_selection/;
          IFEND;

        ELSEIF selection_chosen <> '+INVALID_RESPONSE' THEN
          valid_selection := TRUE;
        IFEND;

      UNTIL valid_selection;

    END /get_selection/;

    close_input_output (io_identifiers, close_status);
    IF status.normal AND (NOT close_status.normal) THEN
      status := close_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND prompt_via_menu_line_mode;

MODEND ram$menu_prompting_interfaces;
*DECK DECK=RAM$MERGE_CORRECTORS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE ram$merge_correctors;
?? PUSH (LISTEXT := ON) ??
*copyc rav$correction_package_header
*copyc rav$elements
*copyc rat$correction_package
*copyc rap$move_correction
?? POP ??

*copyc rah$merge_correctors

  PROCEDURE [XDCL] rap$merge_correctors (add_package: ^SEQ ( * );
        j: rat$element_index;
        add_elements: ^rat$correction_package;
    VAR status: ost$status);

    VAR
      temp: integer,
      found: boolean,
      hi: rat$element_index,
      i: rat$element_index,
      low: rat$element_index,
      mid: rat$element_index;

    status.normal := TRUE;

    hi := rav$correction_package_header ^.number_of_elements;
    low := 1;
    found := FALSE;
    WHILE (low <= hi) AND NOT found DO
      temp := low + hi;
      mid := temp DIV 2;
      IF rav$elements^ [mid].name = add_elements^ [j].name THEN
        found := TRUE;
      ELSEIF rav$elements^ [mid].name > add_elements^ [j].name THEN
        hi := mid - 1;
      ELSE
        low := mid + 1;
      IFEND;
    WHILEND;
    IF found THEN
      rav$elements^ [mid] := add_elements^ [j];
      rap$move_correction (add_package, mid);
    ELSE
      i := rav$correction_package_header^.number_of_elements;
      WHILE (i >= 1) AND NOT found DO
        IF (add_elements^ [j].name < rav$elements^ [i].name) THEN
          rav$elements^ [i + 1] := rav$elements^ [i];
          i := i - 1;
        ELSE
          found := TRUE;
        IFEND;
      WHILEND;
      rav$correction_package_header^.number_of_elements := rav$correction_package_header^.number_of_elements +
            1;
      rav$elements^ [i + 1] := add_elements^ [j];
      rap$move_correction (add_package, i + 1);
    IFEND;
  PROCEND rap$merge_correctors;
MODEND ram$merge_correctors;
*DECK DECK=RAM$MESSAGE_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Message Interfaces: Routines used for displaying messages' ??
MODULE ram$message_interfaces;

{ PURPOSE:
{   This module contains interfaces to display messages.
{
{ DESIGN:
{   The interfaces utilize message templates to provide the text to be displayed.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$max_line
*copyc rac$process_id
*copyc rae$prompt_and_message_cc
*copyc rat$message_parameters
?? POP ??
*copyc amp$put_next
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$find_help_module
*copyc osp$find_parameter_prompt
*copyc osp$format_help_message
*copyc osp$set_status_abnormal

?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    rac$max_margin = 26;

  TYPE
    rat$margin = 0 .. rac$max_margin;

?? TITLE := '[XDCL, #GATE] rap$display_message_command', EJECT ??

*copy rah$display_message_command

  PROCEDURE [XDCL, #GATE] rap$display_message_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt display_message_pdt (
{   message_module, mm     : name = $required
{   message_name, mn       : name = $required
{   message_parameters, mp : list 1..10 of string = $optional
{   margin, m              : integer 0 .. 26 = $optional
{   to, t                  : file = $output
{   status                 : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    display_message_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^display_message_pdt_names
      , ^display_message_pdt_params];

  VAR
    display_message_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 11] of
      clt$parameter_name_descriptor := [['MESSAGE_MODULE', 1], ['MM', 1], ['MESSAGE_NAME', 2], ['MN', 2], [
      'MESSAGE_PARAMETERS', 3], ['MP', 3], ['MARGIN', 4], ['M', 4], ['TO', 5], ['T', 5], ['STATUS', 6]];

  VAR
    display_message_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 6] of clt$parameter_descriptor
      := [

{ MESSAGE_MODULE MM }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ MESSAGE_NAME MN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ MESSAGE_PARAMETERS MP }
    [[clc$optional], 1, 10, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 0, osc$max_string_size
      ]],

{ MARGIN M }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 26]],

{ TO T }
    [[clc$optional_with_default, ^display_message_pdt_dv5], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    display_message_pdt_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$output';

?? POP ??

    VAR
      index: 0 .. clc$max_value_sets,
      margin: [STATIC] rat$margin := 0,
      margin_specified: boolean,
      message_module: pmt$program_name,
      message_name: clt$parameter_name,
      message_parameters: ^ost$message_parameters,
      number_of_parameters: 0 .. clc$max_value_sets,
      output: amt$local_file_name,
      value: clt$value;


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_message_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('message_module', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    message_module := value.name.value;

    clp$get_value ('message_name', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    message_name := value.name.value;

    clp$get_set_count ('message_parameters', number_of_parameters, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    message_parameters := NIL;
    IF number_of_parameters > 0 THEN
      PUSH message_parameters: [1 .. number_of_parameters];
      FOR index := 1 TO number_of_parameters DO
        clp$get_value ('message_parameters', index, 1, clc$low, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        PUSH message_parameters^ [index]: [value.str.size];
        message_parameters^ [index]^ := value.str.value;
      FOREND;
    IFEND;

    clp$test_parameter ('margin', margin_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF margin_specified THEN
      clp$get_value ('margin', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      margin := value.int.value;
    IFEND;

    clp$get_value ('to', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output := value.file.local_file_name;

    display_message (message_module, message_name, message_parameters, margin, output, status);

  PROCEND rap$display_message_command;

?? TITLE := 'issue_message', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display a message from a message container to output.
{
{ DESIGN:
{

  PROCEDURE issue_message
    (    message_container: ost$status_message;
         margin: rat$margin;
         output_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      ignore_byte_address: amt$file_byte_address,
      line: string (osc$max_string_size),
      message_container_ptr: ^ost$status_message,
      message_line: ^ost$status_message_line,
      message_line_count: ^ost$status_message_line_count,
      message_line_index: 1 .. osc$max_status_message_lines,
      message_line_size: ^ost$status_message_line_size;


    status.normal := TRUE;

    message_container_ptr := ^message_container;
    RESET message_container_ptr;
    NEXT message_line_count IN message_container_ptr;

    FOR message_line_index := 1 TO message_line_count^ DO
      NEXT message_line_size IN message_container_ptr;
      NEXT message_line: [message_line_size^] IN message_container_ptr;

      line (1, * ) := '';
      line (margin + 1, * ) := message_line^ (1, message_line_size^);

      amp$put_next (output_id, ^line, message_line_size^ +margin, ignore_byte_address, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND issue_message;

?? TITLE := 'display_message', EJECT ??

{ PURPOSE:
{   The purpose of this request is to display the message found in the message module.
{
{ DESIGN:
{

  PROCEDURE display_message
    (    message_module: pmt$program_name;
         message_name: clt$parameter_name;
         message_parameters: ^ost$message_parameters;
         margin: rat$margin;
         output: amt$local_file_name;
     VAR status: ost$status);

    VAR
      close_status: ost$status,
      ignore_natural_language: ost$natural_language,
      ignore_online_manual_name: ost$online_manual_name,
      message_container: ost$status_message,
      message_module_ptr: ^ost$help_module,
      message_template: ^ost$message_template,
      output_id: amt$file_identifier,
      output_open: boolean,
      write_attachment: array [1 .. 3] of fst$attachment_option;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   The purpose of this request is to close the output file on an unexpected abort.
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status;

      IF output_open THEN
        fsp$close_file (output_id, ignore_status);
        output_open := FALSE;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    output_open := FALSE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      osp$find_help_module (message_module, message_module_ptr, ignore_online_manual_name,
            ignore_natural_language, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF message_module_ptr = NIL THEN
        osp$set_status_abnormal (rac$process_id, rae$module_access_error, message_module, status);
        EXIT /main/;
      IFEND;

      write_attachment [1].selector := fsc$access_and_share_modes;
      write_attachment [1].access_modes.selector := fsc$specific_access_modes;
      write_attachment [1].access_modes.value := $fst$file_access_options [fsc$append];
      write_attachment [1].share_modes.selector := fsc$determine_from_access_modes;
      write_attachment [2].selector := fsc$create_file;
      write_attachment [2].create_file := FALSE;
      write_attachment [3].selector := fsc$open_position;
      write_attachment [3].open_position := amc$open_at_eoi;

      fsp$open_file (output, amc$record, ^write_attachment, NIL, NIL, NIL, NIL, output_id, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      output_open := TRUE;

      osp$find_parameter_prompt (message_module_ptr, message_name, message_template, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF message_template = NIL THEN
        osp$set_status_abnormal (rac$process_id, rae$message_not_found, message_name, status);
        EXIT /main/;
      IFEND;

      osp$format_help_message (message_template, message_parameters, rac$max_line, message_container, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      issue_message (message_container, margin, output_id, status);

    END /main/;

    fsp$close_file (output_id, close_status);
    output_open := FALSE;
    IF status.normal AND (NOT close_status.normal) THEN
      status := close_status;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND display_message;

MODEND ram$message_interfaces;

*DECK DECK=RAM$MESSAGE_INTERFACES_PD EXPAND=TRUE
create_program_description name=(rap$display_message) starting_procedure=rap$display_message_command ..
      library=osf$current_library a=hidden
*DECK DECK=RAM$MESSAGE_TEMPLATE_MODULE EXPAND=TRUE
MODULE ram$message_template_module;
*copy rae$condition_codes
MODEND ram$message_template_module;
*DECK DECK=RAM$MONTHS_AND_DAYS$DUTCH EXPAND=TRUE
create_message_module name=months_and_days$dutch natural_language=dutch
create_parameter_prompt_message name=january collect_template_until='end_of_month'
januari, jan
end_of_month
"
create_parameter_prompt_message name=february collect_template_until='end_of_month'
februari, feb
end_of_month
"
create_parameter_prompt_message name=march collect_template_until='end_of_month'
maart, mrt
end_of_month
"
create_parameter_prompt_message name=april collect_template_until='end_of_month'
april, apr
end_of_month
"
create_parameter_prompt_message name=may collect_template_until='end_of_month'
mei, mei
end_of_month
"
create_parameter_prompt_message name=june collect_template_until='end_of_month'
juni, jun
end_of_month
"
create_parameter_prompt_message name=july collect_template_until='end_of_month'
juli, jul
end_of_month
"
create_parameter_prompt_message name=august collect_template_until='end_of_month'
augustus, aug
end_of_month
"
create_parameter_prompt_message name=september collect_template_until='end_of_month'
september, sep
end_of_month
"
create_parameter_prompt_message name=october collect_template_until='end_of_month'
oktober, okt
end_of_month
"
create_parameter_prompt_message name=november collect_template_until='end_of_month'
november, nov
end_of_month
"
create_parameter_prompt_message name=december collect_template_until='end_of_month'
december, dec
end_of_month
"
"
create_parameter_prompt_message name=monday collect_template_until='end_of_day'
maandag, ma
end_of_day
"
create_parameter_prompt_message name=tuesday collect_template_until='end_of_day'
dinsdag, di
end_of_day
"
create_parameter_prompt_message name=wednesday collect_template_until='end_of_day'
woensdag, woe
end_of_day
"
create_parameter_prompt_message name=thursday collect_template_until='end_of_day'
donderdag, do
end_of_day
"
create_parameter_prompt_message name=friday collect_template_until='end_of_day'
vrijdag, vrij
end_of_day
"
create_parameter_prompt_message name=saturday collect_template_until='end_of_day'
zaterdag, zat
end_of_day
"
create_parameter_prompt_message name=sunday collect_template_until='end_of_day'
zondag, zon
end_of_day
"
end_message_module
*DECK DECK=RAM$MONTHS_AND_DAYS$FLEMISH EXPAND=TRUE
create_message_module name=months_and_days$flemish natural_language=flemish
create_parameter_prompt_message name=january collect_template_until='end_of_month'
januari, jan
end_of_month
"
create_parameter_prompt_message name=february collect_template_until='end_of_month'
februari, feb
end_of_month
"
create_parameter_prompt_message name=march collect_template_until='end_of_month'
maart, mrt
end_of_month
"
create_parameter_prompt_message name=april collect_template_until='end_of_month'
april, apr
end_of_month
"
create_parameter_prompt_message name=may collect_template_until='end_of_month'
mei, mei
end_of_month
"
create_parameter_prompt_message name=june collect_template_until='end_of_month'
juni, jun
end_of_month
"
create_parameter_prompt_message name=july collect_template_until='end_of_month'
juli, jul
end_of_month
"
create_parameter_prompt_message name=august collect_template_until='end_of_month'
augustus, aug
end_of_month
"
create_parameter_prompt_message name=september collect_template_until='end_of_month'
september, sep
end_of_month
"
create_parameter_prompt_message name=october collect_template_until='end_of_month'
oktober, okt
end_of_month
"
create_parameter_prompt_message name=november collect_template_until='end_of_month'
november, nov
end_of_month
"
create_parameter_prompt_message name=december collect_template_until='end_of_month'
december, dec
end_of_month
"
"
create_parameter_prompt_message name=monday collect_template_until='end_of_day'
maandag, ma
end_of_day
"
create_parameter_prompt_message name=tuesday collect_template_until='end_of_day'
dinsdag, di
end_of_day
"
create_parameter_prompt_message name=wednesday collect_template_until='end_of_day'
woensdag, woe
end_of_day
"
create_parameter_prompt_message name=thursday collect_template_until='end_of_day'
donderdag, do
end_of_day
"
create_parameter_prompt_message name=friday collect_template_until='end_of_day'
vrijdag, vrij
end_of_day
"
create_parameter_prompt_message name=saturday collect_template_until='end_of_day'
zaterdag, zat
end_of_day
"
create_parameter_prompt_message name=sunday collect_template_until='end_of_day'
zondag, zon
end_of_day
"
end_message_module
*DECK DECK=RAM$MONTHS_AND_DAYS$FRENCH EXPAND=TRUE
create_message_module name=months_and_days$french natural_language=french
create_parameter_prompt_message name=january collect_template_until='end_of_month'
Janvier, Jan
end_of_month
"
create_parameter_prompt_message name=february collect_template_until='end_of_month'
Fevrier, Fev
end_of_month
"
create_parameter_prompt_message name=march collect_template_until='end_of_month'
Mars, Mars
end_of_month
"
create_parameter_prompt_message name=april collect_template_until='end_of_month'
Avril, Avr
end_of_month
"
create_parameter_prompt_message name=may collect_template_until='end_of_month'
Mai, Mai
end_of_month
"
create_parameter_prompt_message name=june collect_template_until='end_of_month'
Juin, Juin
end_of_month
"
create_parameter_prompt_message name=july collect_template_until='end_of_month'
Juillet, Juil
end_of_month
"
create_parameter_prompt_message name=august collect_template_until='end_of_month'
Aout, Aout
end_of_month
"
create_parameter_prompt_message name=september collect_template_until='end_of_month'
Septembre, Sep
end_of_month
"
create_parameter_prompt_message name=october collect_template_until='end_of_month'
Octobre, Oct
end_of_month
"
create_parameter_prompt_message name=november collect_template_until='end_of_month'
Novembre, Nov
end_of_month
"
create_parameter_prompt_message name=december collect_template_until='end_of_month'
Decembre, Dec
end_of_month
"
"
create_parameter_prompt_message name=monday collect_template_until='end_of_day'
Lundi, Lu
end_of_day
"
create_parameter_prompt_message name=tuesday collect_template_until='end_of_day'
Mardi, Ma
end_of_day
"
create_parameter_prompt_message name=wednesday collect_template_until='end_of_day'
Mercredi, Me
end_of_day
"
create_parameter_prompt_message name=thursday collect_template_until='end_of_day'
Jeudi, Je
end_of_day
"
create_parameter_prompt_message name=friday collect_template_until='end_of_day'
Vendredi, Ve
end_of_day
"
create_parameter_prompt_message name=saturday collect_template_until='end_of_day'
Samedi, Sa
end_of_day
"
create_parameter_prompt_message name=sunday collect_template_until='end_of_day'
Dimanche, Di
end_of_day
"
end_message_module
*DECK DECK=RAM$MONTHS_AND_DAYS$GERMAN EXPAND=TRUE
create_message_module name=months_and_days$german natural_language=german
create_parameter_prompt_message name=january collect_template_until='end_of_month'
Januar, Jan
end_of_month
"
create_parameter_prompt_message name=february collect_template_until='end_of_month'
Februar, Feb
end_of_month
"
create_parameter_prompt_message name=march collect_template_until='end_of_month'
M{rz, M{rz
end_of_month
"
create_parameter_prompt_message name=april collect_template_until='end_of_month'
April, April
end_of_month
"
create_parameter_prompt_message name=may collect_template_until='end_of_month'
Mai, Mai
end_of_month
"
create_parameter_prompt_message name=june collect_template_until='end_of_month'
Juni, Juni
end_of_month
"
create_parameter_prompt_message name=july collect_template_until='end_of_month'
Juli, Juli
end_of_month
"
create_parameter_prompt_message name=august collect_template_until='end_of_month'
August, Aug
end_of_month
"
create_parameter_prompt_message name=september collect_template_until='end_of_month'
September, Sep
end_of_month
"
create_parameter_prompt_message name=october collect_template_until='end_of_month'
Oktober, Okt
end_of_month
"
create_parameter_prompt_message name=november collect_template_until='end_of_month'
November, Nov
end_of_month
"
create_parameter_prompt_message name=december collect_template_until='end_of_month'
Dezember, Dez
end_of_month
"
"
create_parameter_prompt_message name=monday collect_template_until='end_of_day'
Montag, Mo
end_of_day
"
create_parameter_prompt_message name=tuesday collect_template_until='end_of_day'
Dienstag, Di
end_of_day
"
create_parameter_prompt_message name=wednesday collect_template_until='end_of_day'
Mittwoch, Mi
end_of_day
"
create_parameter_prompt_message name=thursday collect_template_until='end_of_day'
Donnerstag, Do
end_of_day
"
create_parameter_prompt_message name=friday collect_template_until='end_of_day'
Freitag, Fr
end_of_day
"
create_parameter_prompt_message name=saturday collect_template_until='end_of_day'
Samstag, Sa
end_of_day
"
create_parameter_prompt_message name=sunday collect_template_until='end_of_day'
Sonntag, So
end_of_day
"
end_message_module
*DECK DECK=RAM$MONTHS_AND_DAYS$ITALIAN EXPAND=TRUE
create_message_module name=months_and_days$italian natural_language=italian
create_parameter_prompt_message name=january collect_template_until='end_of_month'
Gennaio, Gen
end_of_month
"
create_parameter_prompt_message name=february collect_template_until='end_of_month'
Febraio, Feb
end_of_month
"
create_parameter_prompt_message name=march collect_template_until='end_of_month'
Marzo, Mar
end_of_month
"
create_parameter_prompt_message name=april collect_template_until='end_of_month'
Aprile, Apr
end_of_month
"
create_parameter_prompt_message name=may collect_template_until='end_of_month'
Maggio, Mag
end_of_month
"
create_parameter_prompt_message name=june collect_template_until='end_of_month'
Giugno, Giu
end_of_month
"
create_parameter_prompt_message name=july collect_template_until='end_of_month'
Luglio, Lug
end_of_month
"
create_parameter_prompt_message name=august collect_template_until='end_of_month'
Agosto, Ago
end_of_month
"
create_parameter_prompt_message name=september collect_template_until='end_of_month'
Settembre, Set
end_of_month
"
create_parameter_prompt_message name=october collect_template_until='end_of_month'
Ottobre, Ott
end_of_month
"
create_parameter_prompt_message name=november collect_template_until='end_of_month'
Novembre, Nov
end_of_month
"
create_parameter_prompt_message name=december collect_template_until='end_of_month'
Dicembre, Dic
end_of_month
"
"
create_parameter_prompt_message name=monday collect_template_until='end_of_day'
Lunedi, Lun
end_of_day
"
create_parameter_prompt_message name=tuesday collect_template_until='end_of_day'
Martedi, Mar
end_of_day
"
create_parameter_prompt_message name=wednesday collect_template_until='end_of_day'
Mercoledi, Mer
end_of_day
"
create_parameter_prompt_message name=thursday collect_template_until='end_of_day'
Giovedi, Gio
end_of_day
"
create_parameter_prompt_message name=friday collect_template_until='end_of_day'
Venerdi, Ven
end_of_day
"
create_parameter_prompt_message name=saturday collect_template_until='end_of_day'
Sabato, Sab
end_of_day
"
create_parameter_prompt_message name=sunday collect_template_until='end_of_day'
Domenica, Dom
end_of_day
"
end_message_module
*DECK DECK=RAM$MONTHS_AND_DAYS$NORWEGIAN EXPAND=TRUE
create_message_module name=months_and_days$norwegian natural_language=norwegian
create_parameter_prompt_message name=january collect_template_until='end_of_month'
Januar, Jan
end_of_month
"
create_parameter_prompt_message name=february collect_template_until='end_of_month'
Februar, Feb
end_of_month
"
create_parameter_prompt_message name=march collect_template_until='end_of_month'
Mars, Mars
end_of_month
"
create_parameter_prompt_message name=april collect_template_until='end_of_month'
April, April
end_of_month
"
create_parameter_prompt_message name=may collect_template_until='end_of_month'
Mai, Mai
end_of_month
"
create_parameter_prompt_message name=june collect_template_until='end_of_month'
Juni, Juni
end_of_month
"
create_parameter_prompt_message name=july collect_template_until='end_of_month'
Juli, Juli
end_of_month
"
create_parameter_prompt_message name=august collect_template_until='end_of_month'
August, Aug
end_of_month
"
create_parameter_prompt_message name=september collect_template_until='end_of_month'
September, Sep
end_of_month
"
create_parameter_prompt_message name=october collect_template_until='end_of_month'
Oktober, Okt
end_of_month
"
create_parameter_prompt_message name=november collect_template_until='end_of_month'
November, Nov
end_of_month
"
create_parameter_prompt_message name=december collect_template_until='end_of_month'
Desember, Des
end_of_month
"
"
create_parameter_prompt_message name=monday collect_template_until='end_of_day'
Mandag, Man
end_of_day
"
create_parameter_prompt_message name=tuesday collect_template_until='end_of_day'
Tirsdag, Tir
end_of_day
"
create_parameter_prompt_message name=wednesday collect_template_until='end_of_day'
Onsdag, On
end_of_day
"
create_parameter_prompt_message name=thursday collect_template_until='end_of_day'
Torsdag, Tors
end_of_day
"
create_parameter_prompt_message name=friday collect_template_until='end_of_day'
Fredag, Fre
end_of_day
"
create_parameter_prompt_message name=saturday collect_template_until='end_of_day'
L|rdag, L|r
end_of_day
"
create_parameter_prompt_message name=sunday collect_template_until='end_of_day'
S|ndag, S|n
end_of_day
"
end_message_module
*DECK DECK=RAM$MONTHS_AND_DAYS$PORTUGUESE EXPAND=TRUE
create_message_module name=months_and_days$portuguese natural_language=portuguese
create_parameter_prompt_message name=january collect_template_until='end_of_month'
Janeiro, Jan
end_of_month
"
create_parameter_prompt_message name=february collect_template_until='end_of_month'
Fevereiro, Fev
end_of_month
"
create_parameter_prompt_message name=march collect_template_until='end_of_month'
Marco, Mar
end_of_month
"
create_parameter_prompt_message name=april collect_template_until='end_of_month'
Abril, Abr
end_of_month
"
create_parameter_prompt_message name=may collect_template_until='end_of_month'
Maio, Mai
end_of_month
"
create_parameter_prompt_message name=june collect_template_until='end_of_month'
Junho, Jun
end_of_month
"
create_parameter_prompt_message name=july collect_template_until='end_of_month'
Julho, Jul
end_of_month
"
create_parameter_prompt_message name=august collect_template_until='end_of_month'
Agosto, Ago
end_of_month
"
create_parameter_prompt_message name=september collect_template_until='end_of_month'
Setembro, Set
end_of_month
"
create_parameter_prompt_message name=october collect_template_until='end_of_month'
Outubro, Out
end_of_month
"
create_parameter_prompt_message name=november collect_template_until='end_of_month'
Novembro, Nov
end_of_month
"
create_parameter_prompt_message name=december collect_template_until='end_of_month'
Dezembro, Dez
end_of_month
"
"
create_parameter_prompt_message name=monday collect_template_until='end_of_day'
Segunda, Seg
end_of_day
"
create_parameter_prompt_message name=tuesday collect_template_until='end_of_day'
Terca, Ter
end_of_day
"
create_parameter_prompt_message name=wednesday collect_template_until='end_of_day'
Quarta, Qua
end_of_day
"
create_parameter_prompt_message name=thursday collect_template_until='end_of_day'
Quinta, Qui
end_of_day
"
create_parameter_prompt_message name=friday collect_template_until='end_of_day'
Sexta, Sex
end_of_day
"
create_parameter_prompt_message name=saturday collect_template_until='end_of_day'
Sabado, Sab
end_of_day
"
create_parameter_prompt_message name=sunday collect_template_until='end_of_day'
Domingo, Dom
end_of_day
"
end_message_module
*DECK DECK=RAM$MONTHS_AND_DAYS$SPANISH EXPAND=TRUE
create_message_module name=months_and_days$spanish natural_language=spanish
create_parameter_prompt_message name=january collect_template_until='end_of_month'
Enero
end_of_month
"
create_parameter_prompt_message name=february collect_template_until='end_of_month'
Febrero, Feb
end_of_month
"
create_parameter_prompt_message name=march collect_template_until='end_of_month'
Marzo
end_of_month
"
create_parameter_prompt_message name=april collect_template_until='end_of_month'
Abril
end_of_month
"
create_parameter_prompt_message name=may collect_template_until='end_of_month'
Mayo
end_of_month
"
create_parameter_prompt_message name=june collect_template_until='end_of_month'
Junio
end_of_month
"
create_parameter_prompt_message name=july collect_template_until='end_of_month'
Julio
end_of_month
"
create_parameter_prompt_message name=august collect_template_until='end_of_month'
Agosto
end_of_month
"
create_parameter_prompt_message name=september collect_template_until='end_of_month'
Septiembre, Sept
end_of_month
"
create_parameter_prompt_message name=october collect_template_until='end_of_month'
Octubre, Oct
end_of_month
"
create_parameter_prompt_message name=november collect_template_until='end_of_month'
Noviembre, Nov
end_of_month
"
create_parameter_prompt_message name=december collect_template_until='end_of_month'
Diciembre, Dic
end_of_month
"
"
create_parameter_prompt_message name=monday collect_template_until='end_of_day'
Lunes, L
end_of_day
"
create_parameter_prompt_message name=tuesday collect_template_until='end_of_day'
Martes, M
end_of_day
"
create_parameter_prompt_message name=wednesday collect_template_until='end_of_day'
Miercoles, X
end_of_day
"
create_parameter_prompt_message name=thursday collect_template_until='end_of_day'
Jueves, J
end_of_day
"
create_parameter_prompt_message name=friday collect_template_until='end_of_day'
Viernes, V
end_of_day
"
create_parameter_prompt_message name=saturday collect_template_until='end_of_day'
Sabado, S
end_of_day
"
create_parameter_prompt_message name=sunday collect_template_until='end_of_day'
Domingo, D
end_of_day
"
end_message_module
*DECK DECK=RAM$MONTHS_AND_DAYS$SWEDISH EXPAND=TRUE
create_message_module name=months_and_days$swedish natural_language=swedish
create_parameter_prompt_message name=january collect_template_until='end_of_month'
januari, Jan
end_of_month
"
create_parameter_prompt_message name=february collect_template_until='end_of_month'
februari, feb
end_of_month
"
create_parameter_prompt_message name=march collect_template_until='end_of_month'
mars, mar
end_of_month
"
create_parameter_prompt_message name=april collect_template_until='end_of_month'
april, apr
end_of_month
"
create_parameter_prompt_message name=may collect_template_until='end_of_month'
maj, maj
end_of_month
"
create_parameter_prompt_message name=june collect_template_until='end_of_month'
juni, jun
end_of_month
"
create_parameter_prompt_message name=july collect_template_until='end_of_month'
juli, jul
end_of_month
"
create_parameter_prompt_message name=august collect_template_until='end_of_month'
augusti, aug
end_of_month
"
create_parameter_prompt_message name=september collect_template_until='end_of_month'
september, sep
end_of_month
"
create_parameter_prompt_message name=october collect_template_until='end_of_month'
oktober, okt
end_of_month
"
create_parameter_prompt_message name=november collect_template_until='end_of_month'
november, nov
end_of_month
"
create_parameter_prompt_message name=december collect_template_until='end_of_month'
december, dec
end_of_month
"
"
create_parameter_prompt_message name=monday collect_template_until='end_of_day'
m}ndag, m}
end_of_day
"
create_parameter_prompt_message name=tuesday collect_template_until='end_of_day'
tisdag, ti
end_of_day
"
create_parameter_prompt_message name=wednesday collect_template_until='end_of_day'
onsdag, on
end_of_day
"
create_parameter_prompt_message name=thursday collect_template_until='end_of_day'
torsdag, to
end_of_day
"
create_parameter_prompt_message name=friday collect_template_until='end_of_day'
fredag, fr
end_of_day
"
create_parameter_prompt_message name=saturday collect_template_until='end_of_day'
l|rdag, l|
end_of_day
"
create_parameter_prompt_message name=sunday collect_template_until='end_of_day'
s|ndag, s|
end_of_day
"
end_message_module
*DECK DECK=RAM$MOVE_CORRECTION EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$move_correction;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc rav$corp
*copyc rav$elements
?? POP ??

*copyc rah$move_correction

  PROCEDURE [XDCL] rap$move_correction (add_package: ^SEQ ( * );
        ordinal: rat$element_index);

    VAR
      add_correction: ^SEQ ( * ),
      add_psrs: ^array [1 .. * ] of rat$psr_ident,
      correction: ^SEQ ( * ),
      psrs: ^array [1 .. * ] of rat$psr_ident;

    add_correction := #PTR (rav$elements^ [ordinal].correction_package, add_package^);
    NEXT correction: [[REP rav$elements^ [ordinal].size OF cell]] IN rav$corp.sequence_pointer;
    rav$elements^ [ordinal].correction_package := #REL (correction, rav$corp.sequence_pointer^);
    correction^ := add_correction^;
    IF rav$elements^ [ordinal].number_of_psrs > 0 THEN
      add_psrs := #PTR (rav$elements^ [ordinal].psr_info, add_package^);
      NEXT psrs: [1 .. rav$elements^ [ordinal].number_of_psrs] IN rav$corp.sequence_pointer;
      rav$elements^ [ordinal].psr_info := #REL (psrs, rav$corp.sequence_pointer^);
      psrs^ := add_psrs^;
    IFEND;
  PROCEND rap$move_correction;
MODEND ram$move_correction;
*DECK DECK=RAM$NETWORK_ACTIVATION_EPILOG EXPAND=TRUE

" This is the NETWORK_ACTIVATION_EPILOG file.  It is stored in the catalog
" $SYSTEM.PROLOGS_AND_EPILOGS.  This file will be run every time the
" network is activated.
"
" Execution of this file occurs inside a procedure with a WHEN handler so
" that every command in this file will be attempted, regardless of errors.
" In addition you have the status variables IGNORE_STATUS and LOCAL_STATUS
" available to you.
"
" This file is released containing commands to activate network file
" access, the network initializer, network logging and the network clock.

" NOTE: Any changes made in this file may necessitate changes in the
"       NETWORK_DEACTIVATION_PROLOG.

  activate_network_file_access
  activate_network_initializer
  activate_network_log
  activate_network_clock     "Only one network clock command per network."

*DECK DECK=RAM$NETWORK_ACTIVATION_PROLOG EXPAND=TRUE

" This is the NETWORK_ACTIVATION_PROLOG file.  It is stored in the catalog
" $SYSTEM.PROLOGS_AND_EPILOGS. The commands in this file are executed every
" time the network is activated.
"
" Execution of this file occurs inside a procedure with a WHEN handler so
" that every command in this file will be attempted, regardless of errors.
" In addition you have the status variables IGNORE_STATUS and LOCAL_STATUS
" available to you.
"
" This file contains no commands when it is released.

" NOTE: Any changes made in this file may necessitate changes in the
"       NETWORK_DEACTIVATION_EPILOG.
*DECK DECK=RAM$NETWORK_DEACTIVATION_EPILOG EXPAND=TRUE

" This is the NETWORK_DEACTIVATION_EPILOG file.  It is stored in the catalog
" $SYSTEM.PROLOGS_AND_EPILOGS. The commands in this file are executed every
" time the network is deactivated.
"
" Execution of this file occurs inside a procedure with a WHEN handler so
" that every command in this file will be attempted, regardless of errors.
" In addition you have the status variables IGNORE_STATUS and LOCAL_STATUS
" available to you.
"
" This file contains no commands when it is released.

*DECK DECK=RAM$NETWORK_DEACTIVATION_PROLOG EXPAND=TRUE

" This is the NETWORK_DEACTIVATION_PROLOG file.  It is stored in the catalog
" $SYSTEM.PROLOGS_AND_EPILOGS.  This file will be run every time the
" network is deactivated.
"
" Execution of this file occurs inside a procedure with a WHEN handler so
" that every command in this file will be attempted, regardless of errors.
" In addition you have the status variables IGNORE_STATUS and LOCAL_STATUS
" available to you.
"
" This file is released containing commands to deactivate network file
" access, the network initializer, network logging and the network clock.

  deactivate_network_file_access
  deactivate_network_initializer
  deactivate_network_log
  deactivate_network_clock
*DECK DECK=RAM$NETWORK_OPERATOR_UTILITY EXPAND=TRUE
create_program_description (NETWORK_OPERATOR_UTILITY, NETOU, NOU) ..
      l=('$system.osf$system_library_46d' '$system.osf$system_library') ..
      sp=nap$send_network_commands lm=$null lmo=none tel=warning dm=off
*DECK DECK=RAM$NORMAL_DEFERRED_MENU EXPAND=TRUE
CREATE_MESSAGE_MODULE normal_deferred_menu$us_english


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This deck contains the command calls to create a menu message module
"   that is used by the procedure RAP$GET_NORMAL_DEFERRED_OPTION.  The
"   messages are formatted for the RAP$PROMPT_VIA_MENU interface.
"
" DESIGN:
"   The function of a message module is to provide help for a user executing
"   commands interactively.  Therefore the kinds of messages found in a
"   message module reflect that purpose.  In setting up menus using message
"   module technology the message kinds are given new meanings.
"
"     The menu title is created as the brief help message.
"     The menu help is created as the full help message.
"     The menu selections are created as parameter prompt messages.
"     The menu selection help (optional) is created as a parameter help message.
"     The menu selection confirmation (optional) is created as a parameter
"     assist message.
"     The menu prompt is created as a parameter prompt message.
"
" NOTES:
"
"
*IFEND


CREATE_BRIEF_HELP_MESSAGE
+X2+N0Choose one of the following selections:+N+X2
**

CREATE_FULL_HELP_MESSAGE
+X2+N0This menu shows your options for either installing software or
 activating the system.+X2If you choose to install deferred products, you will
 be prompted for your system activation choice after the deferred products have
 been installed.+X2If you select any other choice, you will not receive an
 additional prompt.+X2Processing will be complete when you see the message:
+N+X2
+N2----- SYSTEM ACTIVATION COMPLETE -----
+N+X2
+N0This message will be followed by the NOS/VE slash (/) prompt at which time
 you may enter commands.
+N+X2+N0To get help for a particular selection, enter the number of the selection,
 followed by a question mark.
 For example, to get help for selection 1, you would enter:
+N+X2+N2 1?+N+X2
**

CREATE_PARAMETER_PROMPT_MESSAGE n=production_usage
+X2+P1.+X2Activate the system for production.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=console_usage_only
+X2+P1.+X2Activate the system for system console usage only.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=install_installation_tape
+X2+P1.+X2Install the Installation Tape.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=install_deferred_products
+X2+P1.+X2Install deferred products.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=prompt
+X2+N0Enter selection or ? for HELP.
**

CREATE_PARAMETER_HELP_MESSAGE n=production_usage
+X2+N0This selection causes the system to be activated for general
 use.+X2If the network is configured and has been enabled (by the
 NETWORK_ACTIVATION system attribute), all of the tasks and applications
 associated with it will be activated.+X2In a dual-state mainframe, the
 tasks used to communicate with the 170 partner system will be activated.
 +X2Activating the system makes the mainframe available to users.+N+X2
**

CREATE_PARAMETER_HELP_MESSAGE n=console_usage_only
+N0This selection causes the system to be activated for system console
 usage only.+X2This means that the mainframe will not be
 available to users other than the system console operator.+X2One reason
 to do this might be to restore permanent files on a disk device that has
 just been put online.+X2To subsequently activate the system for
 production, enter the command
 ACTIVATE_PRODUCTION_ENVIRONMENT (ACTPE).
+N+X2
**

CREATE_PARAMETER_HELP_MESSAGE n=install_installation_tape
+X2+N0This selection causes the Installation Tape to be
 installed.+X2Typically, this is done only during the installation of a new NOS/VE
 release.+X2Once the Installation Tape has been installed, the system will be
 activated for system console usage only.+X2(You will not be prompted for a system
 activation choice.)+X2This
 means that the mainframe will not be available to users other than
 the system console operator.+X2This is done to prevent users from accessing
 the system until the installation is complete.
+N+X2
**

CREATE_PARAMETER_HELP_MESSAGE n=install_deferred_products
+X2+N0This selection installs files which were corrected but not
 installed during the application of a BCU.+X2Once the deferred installation
 files have been copied to their proper location on the system, you will
 have a choice of activating the system for production or for system console usage
 only.
+N+X2
**

END_MESSAGE_MODULE
*DECK DECK=RAM$NORMAL_MENU EXPAND=TRUE
CREATE_MESSAGE_MODULE normal_menu$us_english


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This deck contains the command calls to create a menu message module
"   that is used by the procedure RAP$GET_NORMAL_OPTION.  The module is
"   formatted for the RAP$PROMPT_VIA_MENU interface.
"
" DESIGN:
"   The function of a message module is to provide help for a user executing
"   commands interactively.  Therefore the kinds of messages found in a
"   message module reflect that purpose.  In setting up menus using message
"   module technology the message kinds are given new meanings.
"
"     The menu title is created as the brief help message.
"     The menu help is created as the full help message.
"     The menu selections are created as parameter prompt messages.
"     The menu selection help (optional) is created as a parameter help message.
"     The menu selection confirmation (optional) is created as a parameter
"         assist message.
"     The menu prompt is created as a parameter prompt message.
"
" NOTES:
"
"
*IFEND


CREATE_BRIEF_HELP_MESSAGE
+X2+N0Choose one of the following selections:+N+X2
**

CREATE_FULL_HELP_MESSAGE
+X2+N0This menu shows your options for either installing software or
 activating the system.  Processing will be complete when you see the message:
+N+X2
+N2----- SYSTEM ACTIVATION COMPLETE -----
+N+X2
+N0This message will be followed by the NOS/VE slash (/) prompt at which time
 you may enter commands.
+N+X2+N0To get help for a particular selection, enter the number of the selection,
 followed by a question mark.
 For example, to get help for selection 1, you would enter:
+N+X2+N2 1?+N+X2
**

CREATE_PARAMETER_PROMPT_MESSAGE n=production_usage
+X2+P1.+X2Activate the system for production.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=console_usage_only
+X2+P1.+X2Activate the system for system console usage only.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=install_installation_tape
+X2+P1.+X2Install the Installation Tape.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=prompt
+X2+N0Enter selection or ? for HELP.
**

CREATE_PARAMETER_HELP_MESSAGE n=production_usage
+X2+N0This selection causes the system to be activated for general
 use.+X2If the network is configured and has been enabled (by the
 NETWORK_ACTIVATION system attribute), all of the tasks and applications
 associated with it will be activated.+X2In a dual-state mainframe, the
 tasks used to communicate with the 170 partner system will be activated.
 +X2Activating the system makes the mainframe available to users.+N+X2
**

CREATE_PARAMETER_HELP_MESSAGE n=console_usage_only
+N0This selection causes the system to be activated for system console
 usage only.+X2This means that the mainframe will not be
 available to users other than the system console operator.+X2One reason
 to do this might be to restore permanent files on a disk device that has
 just been put online.+X2To subsequently activate the system for
 production, enter the command
 ACTIVATE_PRODUCTION_ENVIRONMENT (ACTPE).
+N+X2
**

CREATE_PARAMETER_HELP_MESSAGE n=install_installation_tape
+X2+N0This selection causes the Installation Tape to be
 installed.+X2Typically, this is done only during the installation of a new NOS/VE
 release.+X2Once the Installation Tape has been installed, the system will be
 activated for system console usage only.+X2(You will not be prompted for a system
 activation choice.)+X2This
 means that the mainframe will not be available to users other than
 the system console operator.+X2This is done to prevent users from accessing
 the system until the installation is complete.
+N+X2
**

END_MESSAGE_MODULE
*DECK DECK=RAM$NOS_FILE_TRANSFER EXPAND=TRUE
MODULE ram$nos_file_transfer;
*copyc OSD$DEFAULT_PRAGMATS
?? PUSH (LISTEXT := OFF) ??
*copyc CLP$EVALUATE_PARAMETERS
*copyc fsp$open_file
*copyc AMP$WRITE_TAPE_MARK
*copyc AMP$ACCESS_METHOD
*copyc fsp$close_file
*copyc AMP$GET_NEXT
*copyc AMP$PUT_NEXT
*copyc AMP$WRITE_END_PARTITION
*copyc I#MOVE
*copyc I#BUILD_ADAPTABLE_SEQ_POINTER
*copyc OSP$SET_STATUS_ABNORMAL
*copyc MLP$SIGN_ON
*copyc MLP$CONFIRM_SEND
*copyc MLP$ADD_SENDER
*copyc MLP$SEND_MESSAGE
*copyc MLP$RECEIVE_MESSAGE
*copyc MLP$RECEIVE_MESSAGE
*copyc MLP$SIGN_OFF
*copyc PMP$LONG_TERM_WAIT
*copyc PMT$PROGRAM_PARAMETERS
*copyc PMP$LOG
*copyc AMT$FAP_DECLARATIONS
?? POP ??

  CONST
    ic_file = 'nos_tape_ic_file               ',
    lfn170 = 'nos_xfer                       ',
    ai_ident_170 = 0,
    ai_begin_write = 1,
    ai_begin_read = 2,
    ai_data = 3,
    ai_eop = 4,
    ai_rewind = 5,
    ai_skipf = 6,
    ai_end_of_file = 7,
    ai_end_of_op = 8,
    wait_time = 1000,
    max_words = (mlc$max_message_length DIV (512 * 8)) * 512,
    max_bytes = max_words * 8;

  VAR
    mlibuf: array [1 .. max_bytes] of cell,
    curpos: integer := 1,
    an170,
    an180: mlt$application_name,
    operation: integer := 0,
    total_bytes,
    total_blocks: integer := 0,
    curdata: integer := 0,
    last_ai: mlt$arbitrary_info := ai_data,
    open: boolean := FALSE,
    type_of_partition: integer,
    ic_fid: amt$file_identifier;


  PROCEDURE init_xfer (op_type: mlt$arbitrary_info;
    VAR status: ost$status);

    VAR
      tc: amt$transfer_count,
      ba: amt$file_byte_address,
      id180: array [1 .. 2] of integer,
      fp: amt$file_position;

    status.normal := TRUE;
    IF open THEN
      RETURN;
    IFEND;
    fsp$open_file (ic_file, amc$record, NIL, NIL, NIL, NIL, NIL, ic_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    amp$get_next (ic_fid, #LOC (an170), #SIZE (an170), tc, ba, fp, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    REPEAT
      mlp$sign_on (mlc$unique_name, 0, an180, status);
      IF NOT status.normal THEN
        CASE status.condition OF
        = mlc$ant_full, mlc$busy_interlock, mlc$pool_buffer_not_avail =
          pmp$long_term_wait (wait_time, wait_time);
        ELSE
          RETURN;
        CASEND;
      IFEND;
    UNTIL status.normal;

    REPEAT
      mlp$add_sender (an180, an170, status);
      IF NOT status.normal THEN
        CASE status.condition OF
        = mlc$busy_interlock =
          pmp$long_term_wait (wait_time, wait_time);
        ELSE
          RETURN;
        CASEND;
      IFEND;
    UNTIL status.normal;

    id180 [1] := an180;
    id180 [2] := op_type;
    amp$put_next (ic_fid, #LOC (id180), #SIZE (id180), ba, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    operation := op_type;
    open := TRUE;

  PROCEND init_xfer;
?? EJECT ??

  PROCEDURE terminate_xfer (VAR status: ost$status);

    VAR
      ai: mlt$arbitrary_info,
      ml: mlt$message_length,
      str: string (40),
      iii: integer,
      sn: mlt$application_name;

    IF operation = ai_begin_write THEN
      flush (ai_end_of_op, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    /wait_end/
      BEGIN
        REPEAT
          mlp$receive_message (an180, ai, NIL, #LOC (mlibuf), ml, 1, 0, sn,
                status);
          IF NOT status.normal THEN
            CASE status.condition OF
            = mlc$busy_interlock, mlc$receive_list_index_invalid =
              pmp$long_term_wait (wait_time, wait_time);
            ELSE
              EXIT /wait_end/;
            CASEND;
          IFEND;
        UNTIL status.normal;
      END /wait_end/;
    IFEND;

    REPEAT
      mlp$sign_off (an180, status);
      IF NOT status.normal THEN
        CASE status.condition OF
        = mlc$busy_interlock =
          pmp$long_term_wait (wait_time, wait_time);
        ELSE
          RETURN;
        CASEND;
      IFEND;
    UNTIL status.normal;

    fsp$close_file (ic_fid, status);
    str := '    ';
    STRINGREP (str, iii, ' BLOCKS/BYTES: ', total_blocks, total_bytes);
    pmp$log (str, status);
    total_blocks := 0;
    total_bytes := 0;
    status.normal := TRUE;
    open := FALSE;
  PROCEND terminate_xfer;
?? EJECT ??

  PROCEDURE flush (ai: mlt$arbitrary_info;
    VAR status: ost$status);

    VAR
{!      iii: integer,
{!      str: string (30),
      ps: ^cell,
{     ci: syt$conversion_info,
      xb: array [1 .. max_words] of integer,
      sl: integer;

{!    str := '   ';
{!    STRINGREP (str, iii, ' flush ', curpos - 1);
{!    pmp$log (str, status);
    REPEAT
      mlp$send_message (an180, ai, NIL, #LOC (mlibuf), curpos - 1, an170,
            status);
      IF NOT status.normal THEN
        CASE status.condition OF
        = mlc$busy_interlock, mlc$prior_msg_not_received,
              mlc$receive_list_full, mlc$pool_buffer_not_avail,
                mlc$sender_not_permitted =
          pmp$long_term_wait (wait_time, wait_time);
        ELSE
          RETURN;
        CASEND;
      IFEND;
    UNTIL status.normal;
    total_bytes := total_bytes + curpos - 1;
    total_blocks := total_blocks + 1;
    curpos := 1;
  PROCEND flush;
?? EJECT ??

  PROCEDURE send_to_170 (data: ^cell;
        len: integer;
    VAR status: ost$status);

    VAR
      xl,
      llen: integer,
      ps: ^cell,
{     ci: syt$conversion_info,
      xb: array [1 .. max_words] of integer,
      sl: integer,
{!      str: string (30),
{!      iii: integer,
      pac: ^array [1 .. 07ffffff(16)] of cell,
      clp: integer,
      done: boolean;

    llen := len;
    done := FALSE;
    pac := data;
    clp := 1;
{!    str := '   ';
{!    STRINGREP (str, iii, ' put ', len);
{!    pmp$log (str, status);
    REPEAT
      IF (curpos + llen) > max_bytes THEN
        xl := max_bytes - (curpos - 1);
        i#move (#LOC (pac^ [clp]), #LOC (mlibuf [curpos]), xl);
{!        str := '   ';
{!        STRINGREP (str, iii, ' send 170 ', sl);
{!        pmp$log (str, status);
        REPEAT
          mlp$send_message (an180, ai_data, NIL, #LOC (mlibuf), max_bytes,
                an170, status);
          IF NOT status.normal THEN
            CASE status.condition OF
            = mlc$busy_interlock, mlc$prior_msg_not_received,
                  mlc$receive_list_full, mlc$pool_buffer_not_avail,
                    mlc$sender_not_permitted =
              pmp$long_term_wait (wait_time, wait_time);
            ELSE
              RETURN;
            CASEND;
          IFEND;
        UNTIL status.normal;
        total_bytes := total_bytes + max_bytes;
        total_blocks := total_blocks + 1;
        curpos := 1;
        llen := llen - xl;
        clp := clp + xl;
      ELSE
        i#move (#LOC (pac^ [clp]), #LOC (mlibuf [curpos]), llen);
        curpos := curpos + llen;
        done := TRUE;
      IFEND;
    UNTIL done;
  PROCEND send_to_170;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] rap$nos_file_write (file_id: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    VAR
      iii: integer,
      str: string (30);

    CASE call_block.operation OF
    = amc$open_req =
      IF call_block.open.access_level <> amc$record THEN
        osp$set_status_abnormal ('XX', 99, 'must be record access', status);
        RETURN;
      IFEND;
      amp$access_method (file_id, call_block, layer_number, status);
      IF status.normal THEN
        init_xfer (ai_begin_write, status);
      IFEND;
    = amc$put_next_req =
      send_to_170 (call_block.putn.working_storage_area, call_block.putn.
            working_storage_length, status);
    = amc$put_partial_req =
      send_to_170 (call_block.putp.working_storage_area, call_block.putp.
            working_storage_length, status);
    = amc$fetch_access_information_rq, amc$fetch_req, amc$store_req =
      amp$access_method (file_id, call_block, layer_number, status);
    = amc$rewind_req =
    = amc$write_end_partition_req =
      flush (ai_eop, status);
    = amc$close_req =
      terminate_xfer (status);
      amp$access_method (file_id, call_block, layer_number, status);
    = amc$write_tape_mark_req =
      flush (ai_end_of_file, status);
    ELSE
      str := '   ';
      STRINGREP (str, iii, ' amp$? ', call_block.operation);
      osp$set_status_abnormal ('XX', 98, str, status);
    CASEND;
  PROCEND rap$nos_file_write;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] rap$nos_file_read (file_id: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

    VAR
      iii: integer,
      str: string (30);

    CASE call_block.operation OF
    = amc$open_req =
      IF call_block.open.access_level <> amc$record THEN
        osp$set_status_abnormal ('XX', 99, 'must be record access', status);
        RETURN;
      IFEND;
      amp$access_method (file_id, call_block, layer_number, status);
      IF status.normal THEN
        init_xfer (ai_begin_read, status);
      IFEND;
    = amc$get_next_req =
      receive_from_170 (call_block.getn.working_storage_area, call_block.getn.
            working_storage_length, call_block.getn.transfer_count, call_block.
            getn.file_position, status);
    = amc$get_partial_req =
      receive_from_170 (call_block.getp.working_storage_area, call_block.getp.
            working_storage_length, call_block.getp.transfer_count, call_block.
            getp.file_position, status);
    = amc$fetch_access_information_rq, amc$fetch_req, amc$store_req =
      amp$access_method (file_id, call_block, layer_number, status);
    = amc$rewind_req =
    = amc$skip_req =
      IF call_block.skp.direction <> amc$forward THEN
        osp$set_status_abnormal ('XX', 96, 'skip not forward', status);
        RETURN;
      IFEND;
      IF call_block.skp.unit <> amc$skip_partition THEN
        osp$set_status_abnormal ('XX', 95, 'skip not partition', status);
        RETURN;
      IFEND;
{!      str := '  ';
{!      STRINGREP (str, iii, ' skip count', call_block.skp.count);
{!      pmp$log (str, status);
      skip (status);
      IF last_ai <> ai_end_of_op THEN
        call_block.skp.file_position^ := amc$bop;
      ELSE
        call_block.skp.file_position^ := amc$eoi;
      IFEND;
    = amc$close_req =
      terminate_xfer (status);
      amp$access_method (file_id, call_block, layer_number, status);
    ELSE
      str := '   ';
      STRINGREP (str, iii, ' amp$? ', call_block.operation);
      osp$set_status_abnormal ('XX', 98, str, status);
    CASEND;
  PROCEND rap$nos_file_read;
?? EJECT ??

  PROCEDURE receive_from_170 (wsa: ^cell;
        wsl: integer;
        tc: ^amt$transfer_count;
        fp: ^amt$file_position;
    VAR status: ost$status);

    VAR
      psa,
      ps: ^cell,
{     ci: syt$conversion_info,
      xb: array [1 .. max_words] of integer,
      sl: integer,
      xl,
      llen: integer,
      sn: mlt$application_name,
      ml: mlt$message_length,
      pac: ^array [1 .. 07ffffff(16)] of cell,
{!      str: string (40),
{!      iii: integer,
      clp: integer;

    status.normal := TRUE;
    clp := 1;
    pac := wsa;
    llen := wsl;

  /get_next/
    BEGIN
      REPEAT

        IF curpos > curdata THEN
          IF last_ai <> ai_data THEN
            EXIT /get_next/;
          IFEND;

{ get more data from 170

          REPEAT
            mlp$receive_message (an180, last_ai, NIL, #LOC (mlibuf), ml, #SIZE
                  (mlibuf), 0, sn, status);
            IF NOT status.normal THEN
              CASE status.condition OF
              = mlc$busy_interlock, mlc$receive_list_index_invalid =
                pmp$long_term_wait (wait_time, wait_time);
              ELSE
                RETURN;
              CASEND;
            IFEND;
          UNTIL status.normal;

          curdata := ml;
          curpos := 1;
          total_bytes := total_bytes + curdata;
          total_blocks := total_blocks + 1;
{!          str := '  ';
{!          STRINGREP (str, iii, ' curdata= ', curdata);
{!          pmp$log (str, status);
{!          str := '   ';
{!          STRINGREP (str, iii, ' get 170 ', ml, curdata);
{!          pmp$log (str, status);
        IFEND;

        IF (curdata - (curpos - 1)) < llen THEN
          xl := curdata - (curpos - 1);
        ELSE
          xl := llen;
        IFEND;

        i#move (#LOC (mlibuf [curpos]), #LOC (pac^ [clp]), xl);
        clp := clp + xl;
        llen := llen - xl;
        curpos := curpos + xl;
      UNTIL llen = 0;
    END /get_next/;

    IF curpos > curdata THEN
      CASE last_ai OF
      = ai_eop =
{!        str := '   ';
{!        STRINGREP (str, iii, ' get eop ', clp - 1);
{!        pmp$log (str, status);
        type_of_partition := ai_eop;
        IF fp <> NIL THEN
          IF llen > 0 THEN
            fp^ := amc$eop;
          ELSE
            fp^ := amc$eor;
          IFEND;
        IFEND;
        IF llen > 0 THEN
          last_ai := ai_data;
        IFEND;
      = ai_end_of_file =
{!        str := '   ';
{!        STRINGREP (str, iii, ' get eof ', clp - 1);
{!        pmp$log (str, status);
        type_of_partition := ai_end_of_file;
        IF fp <> NIL THEN
          IF llen > 0 THEN
            fp^ := amc$eop;
          ELSE
            fp^ := amc$eor;
          IFEND;
        IFEND;
        IF llen > 0 THEN
          last_ai := ai_data;
        IFEND;
      = ai_end_of_op =
{!        str := '   ';
{!        STRINGREP (str, iii, ' get eoi ', clp - 1);
{!        pmp$log (str, status);
        type_of_partition := ai_end_of_op;
        IF fp <> NIL THEN
          fp^ := amc$eoi;
        IFEND;
      = ai_data =
{!        str := '   ';
{!        STRINGREP (str, iii, ' get data ', clp - 1, wsl);
{!        pmp$log (str, status);
        IF fp <> NIL THEN
          fp^ := amc$eor;
        IFEND;
      ELSE
        osp$set_status_abnormal ('XX', 96, 'last ai on get confused', status);
        RETURN;
      CASEND;
    ELSE
{!      str := '   ';
{!      STRINGREP (str, iii, ' get data ', clp - 1, wsl);
{!      pmp$log (str, status);
      IF fp <> NIL THEN
        fp^ := amc$eor;
      IFEND;
    IFEND;
    IF tc <> NIL THEN
      tc^ := clp - 1;
    IFEND;
  PROCEND receive_from_170;
?? EJECT ??

  PROCEDURE skip (VAR status: ost$status);

    VAR
      xb: array [1 .. max_words] of integer,
      sn: mlt$application_name,
      ml: mlt$message_length;

    status.normal := TRUE;
    IF last_ai = ai_eop THEN
      last_ai := ai_data;
      curdata := 0;
      curpos := 1;
      RETURN;
    IFEND;

    REPEAT
      REPEAT
        mlp$receive_message (an180, last_ai, NIL, #LOC (xb), ml, #SIZE (xb), 0,
              sn, status);
        IF NOT status.normal THEN
          CASE status.condition OF
          = mlc$busy_interlock, mlc$receive_list_index_invalid =
            pmp$long_term_wait (wait_time, wait_time);
          ELSE
            RETURN;
          CASEND;
        IFEND;
      UNTIL status.normal;
    UNTIL last_ai <> ai_data;

    IF last_ai <> ai_end_of_op THEN
      last_ai := ai_data;
    IFEND;
    curdata := 0;
    curpos := 1;
  PROCEND skip;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] rap$getmrf (plist: clt$parameter_list;
    VAR status: ost$status);

{    PROCEDURE (osm$mrf) mrf (
{        file: file = $required
{        status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 4, 22, 15, 17, 0, 500],
    clc$command, 2, 2, 1, 0, 0, 0, 2, 'OSM$MRF'], [
    ['FILE                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$file = 1,
    p$status = 2;

  VAR
    pvt: array [1 .. 2] of clt$parameter_value;
?? EJECT ??

    VAR
      oa: array [1 .. 2] of fst$attachment_option,
      ia: array [1 .. 1] of fst$attachment_option,
      fid170,
      fid180: amt$file_identifier,
      tc: amt$transfer_count,
      ba: amt$file_byte_address,
      fp: amt$file_position,
      buffer: array [1 .. max_bytes] of cell;

    clp$evaluate_parameters (plist, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    oa [1].selector := fsc$open_position;
    oa [1].open_position := amc$open_at_boi;
    oa [2].selector := fsc$access_and_share_modes;
    oa [2].share_modes.selector := fsc$specific_share_modes;
    oa [2].share_modes.value := $fst$file_access_options[];
    oa [2].access_modes.selector := fsc$specific_access_modes;
    oa [2].access_modes.value := $fst$file_access_options[fsc$shorten, fsc$append,
          fsc$modify, fsc$read];
    ia [1].selector := fsc$access_and_share_modes;
    ia [1].share_modes.selector := fsc$specific_share_modes;
    ia [1].share_modes.value := $fst$file_access_options[fsc$read, fsc$shorten,
          fsc$append, fsc$modify, fsc$execute];
    ia [1].access_modes.selector := fsc$specific_access_modes;
    ia [1].access_modes.value := $fst$file_access_options[fsc$read];

    fsp$open_file (pvt [p$file].value^.file_value^, amc$record, ^oa, NIL,
        NIL, NIL, NIL, fid180, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    fsp$open_file (lfn170, amc$record, NIL, NIL, NIL, NIL, NIL, fid170, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    REPEAT
      amp$get_next (fid170, #LOC (buffer), #SIZE (buffer), tc, ba, fp, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      amp$put_next (fid180, #LOC (buffer), tc, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE fp OF
      = amc$eor =
      = amc$mid_record =
        osp$set_status_abnormal ('XX', 99, 'mid record file position', status);
        RETURN;
      = amc$eop, amc$eoi =
        amp$write_end_partition (fid180, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        amp$put_next (fid180, #LOC (type_of_partition), #SIZE
              (type_of_partition), ba, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      CASEND;
    UNTIL fp = amc$eoi;

    fsp$close_file (fid170, status);
    fsp$close_file (fid180, status);
  PROCEND rap$getmrf;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] rap$repmrf (plist: clt$parameter_list;
    VAR status: ost$status);

{    PROCEDURE (osm$mrf) mrf (
{        file: file = $required
{        status)

?? PUSH (LISTEXT := ON) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 2] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 4, 22, 15, 17, 0, 500],
    clc$command, 2, 2, 1, 0, 0, 0, 2, 'OSM$MRF'], [
    ['FILE                           ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? POP ??

  CONST
    p$file = 1,
    p$status = 2;

  VAR
    pvt: array [1 .. 2] of clt$parameter_value;
?? EJECT ??

    VAR
      oa: array [1 .. 2] of fst$attachment_option,
      ia: array [1 .. 1] of fst$attachment_option,
      fid170,
      fid180: amt$file_identifier,
      tc: amt$transfer_count,
      ba: amt$file_byte_address,
      fp: amt$file_position,
      buffer: array [1 .. max_bytes] of cell;

    clp$evaluate_parameters (plist, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    oa [1].selector := fsc$open_position;
    oa [1].open_position := amc$open_at_boi;
    oa [2].selector := fsc$access_and_share_modes;
    oa [2].share_modes.selector := fsc$specific_share_modes;
    oa [2].share_modes.value := $fst$file_access_options[];
    oa [2].access_modes.selector := fsc$specific_access_modes;
    oa [2].access_modes.value := $fst$file_access_options[fsc$shorten, fsc$append,
          fsc$modify, fsc$read];
    ia [1].selector := fsc$access_and_share_modes;
    ia [1].share_modes.selector := fsc$specific_share_modes;
    ia [1].share_modes.value := $fst$file_access_options[fsc$read, fsc$shorten,
          fsc$append, fsc$modify, fsc$execute];
    ia [1].access_modes.selector := fsc$specific_access_modes;
    ia [1].access_modes.value := $fst$file_access_options[fsc$read];
    fsp$open_file (pvt [p$file].value^.file_value^, amc$record, ^ia, NIL,
        NIL, NIL, NIL, fid180, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    fsp$open_file (lfn170, amc$record, ^oa, NIL, NIL, NIL, NIL, fid170, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    REPEAT
      amp$get_next (fid180, #LOC (buffer), #SIZE (buffer), tc, ba, fp, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      amp$put_next (fid170, #LOC (buffer), tc, ba, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE fp OF
      = amc$eor, amc$eoi =
      = amc$mid_record =
        osp$set_status_abnormal ('XX', 99, 'mid record file position', status);
        RETURN;
      = amc$eop =
        type_of_partition := 999;
        amp$get_next (fid180, #LOC (type_of_partition), #SIZE
              (type_of_partition), tc, ba, fp, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        CASE type_of_partition OF
        = ai_eop =
          amp$write_end_partition (fid170, status);
        = ai_end_of_file =
          amp$write_tape_mark (fid170, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        = ai_end_of_op =
          IF curpos > 1 THEN
            amp$write_end_partition (fid170, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal ('XX', 109, 'unknown partition', status);
          RETURN;
        CASEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      CASEND;
    UNTIL fp = amc$eoi;

    fsp$close_file (fid170, status);
    fsp$close_file (fid180, status);
  PROCEND rap$repmrf;
MODEND ram$nos_file_transfer;
*DECK DECK=RAM$NVEPFU EXPAND=TRUE
          IDENT  NVEPFU,130B
          TITLE  RAM$NVEPFU
          ABS
          SYSCOM B1
          ENTRY  XPFUA
          ORG    130B
          TITLE  NVEPFU - NOS-NOSVE TAPE FAP TRANSFER.

CKIOST    MACRO  FET
          LOCAL  CONT
          SA1    FET+0
          MX0    5
          LX0    14
          BX2    X1*X0
          ZR     X2,CONT     IF NO IO STATUS
          AX2    9
          SX3    X2-1
          NZ     X3,IOERR    IF ERROR
          MX6    5
          SA6    EOI         SET EOI FLAG
CONT      BSS    0
          ENDM

RESET     MACRO  FET
          SA1    FET+1
          SX6    X1
          SA6    FET+2
          SA6    FET+3
          ENDM

CKMST     MACRO  MASK
          LOCAL  READY,BEGIN,DONE,RCLP,RCLCNT
BEGIN     BSS    0
          SA1    NTHSR
          NG     X1,READY    IF REQUEST COMPLETE
          RJ     POLL
          SA1    NTHSR
          NG     X1,READY    IF REQUEST COMPLETE
          SA1    WMLI
          SX6    X1+1
          SA6    A1
          RECALL
          EQ     BEGIN

READY     BSS    0
          SA1    MLIPAR+MLPSV
          ZR     X1,DONE     IF MLI STATUS OK
          BX6    X1
          SA6    STS
          SB4    X6
          SA2    MASK
          SX0    1
          LX0    B4,X0
          BX2    X2*X0
          ZR     X2,MLERR    IF NON RETRY MLI ERROR

* REISSUE REQUEST

          SA1    REISSUE
          SX6    X1+1
          SA6    A1

* WAIT FOR A WHILE - 180 HAS UP TO 3 BLOCKS TO CATCH UP

          SX6    6           6 RECALLS
          SA6    RCLCNT
RCLP      BSS    0
          RECALL
          SA1    RCLCNT
          SX6    X1-1
          SA6    RCLCNT
          NZ     X6,RCLP     IF MORE
          RJ     ISSUE
          EQ     BEGIN
RCLCNT    BSS    1
DONE      BSS    0
          ENDM

SNDM      MACRO  HW,BUF
          SA1    HW
          SX6    BUF         ADDRESS
***          SX7    X1+1        (HEADER+DATA)+TRAILER
          SX7    X1
          SA6    MLIPAR+MLPFA
          SA7    MLIPAR+MLPBL
          RJ     ISSUE
          ENDM

SMSG      MACRO  HW,FET,BUF
          LOCAL  NOTEOI,NOTEOR,NOTEOF,SSS
          CKIOST FET
          SA1    FET+1
          SA2    FET+2
          SX1    X1
          SX2    X2
          IX6    X2-X1
***          SX6    X6+1        DATA+HEADER
          SA6    HW
          SA1    BLOCKS
          SA2    WORDS
          IX6    X6+X2
          SX7    X1+1
          SA7    A1
          SA6    A2

          MX0    1
          SA1    FET
          LX0    10
          BX2    X1*X0
          ZR     X2,NOTEOI
          SX6    AIEND
          SA6    MLIPAR+MLPAR
          MESSAGE (=C* EOI SENT *),3,R
          EQ     SSS
NOTEOI    BSS    0
          MX0    2
          LX0    5
          BX2    X1*X0
          AX2    3
          SX3    X2-2
          NZ     X3,NOTEOR
          SX6    AIEOP
          SA6    MLIPAR+MLPAR
**          MESSAGE (=C* EOP SENT *),3,R
          EQ     SSS
NOTEOR    BSS    0
          SX3    X2-3
          NZ     X3,NOTEOF
          SX6    AIEOF
          SA6    MLIPAR+MLPAR
**          MESSAGE (=C* EOF SENT*),3,R
          EQ     SSS
NOTEOF    BSS    0
          SX6    AIDATA
          SA6    MLIPAR+MLPAR
SSS       BSS    0
**          SA1    HW
**          RJ     CDD
**          SA6    M16
**          MESSAGE M15,3,R
          SNDM   HW,BUF
          SA1    EOI
          NZ     X1,EXIT     IF SENT EOI BLOCK
          ENDM

RECM      MACRO  HW
***          MX7    0
***          SA7    HW          CLEAR HEADER WORD (LENGTH)
          SX6    HW
          SA6    MLIPAR+MLPFA
          RJ     ISSUE
          ENDM

WRITF     MACRO  FET,HW
          LOCAL  WEOF,QQQ,WEOR,WWW
***          SX2    1
***          SA1    HW
***          MX0    22
***          LX0    22
***          BX3    X1*X0
***          IX3    X3-X2       LENGTH
          SA1    FET+3       OUT
          SA2    FET+2       IN
          BX1    X1-X2
          MX0    18
          LX0    18
          BX1    X1*X0
          NZ     X1,ERR2     IF BUFFER NOT EMPTY
**          SA1    MLIPAR+MLPV1
**          RJ     CDD
**          SA6    M16
**          MESSAGE M15,3,R
          SA3    MLIPAR+MLPV1  LENGTH
          SA4    FET+1
          SX6    X4
          SA6    FET+3       OUT=FIRST
          IX7    X4+X3
          SA7    FET+2       IN=FIRST+LENGTH
          SA2    BLOCKS
          SX6    X2+1
          SA6    A2
          SA2    WORDS
          IX6    X2+X3
          SA6    A2

          SA1    MLIPAR+MLPV2 ARB INFO
          BX6    X1
          SA6    MLIPAR+MLPAR FOR USE BY EXIT
          SX2    X1-AIDATA
          NZ     X2,WWW
          WRITE  FET
**          MESSAGE (=C*WRITE DATA*),3,R
          EQ     QQQ

WWW       BSS    0
          SX2    X1-AIEOP
          ZR     X2,WEOR
          SX2    X1-AIEOF
          ZR     X2,WEOF
          SX2    X1-AIEND
          NZ     X2,RAIERR
****          WRITER FET
          MESSAGE (=C*END OF OP RECD*),3,R
          EQ     EXIT

WEOR      BSS    0
          WRITER FET
**          MESSAGE (=C*WRITE EOP*),3,R
          EQ     QQQ

WEOF      BSS    0
          WRITEF FET
**          MESSAGE (=C*WRITE EOF*),3,R

QQQ       BSS    0
          ENDM
OPL       XTEXT  COMCCDD
OPL       XTEXT  COMCMAC
OPL       XTEXT  COMCCIO
OPL       XTEXT  COMCSYS
*copy COMSCVS
*copy COMMCVS
*copy COMSMLI
*copy COMMMLI
*copy mla$c170_memory_link_interface
BUFSIZ    EQU    3072+2
HWA       BSS    1
BUFA      BSS    BUFSIZ
TWA       BSS    1
*
HWB       BSS    1
BUFB      BSS    BUFSIZ
TWB       BSS    1
*
FETA      FILEB  BUFA,BUFSIZ
FETB      FILEB  BUFB,BUFSIZ
INPUT     FILEB  BUFB,BUFSIZ
AN170     BSS    1
AN180     BSS    1
STS       BSS    1
NTHSR     DATA   -2
REISSUE   DATA   0
WMLI      DATA   0
BLOCKS    DATA   0
WORDS     DATA   0
M1        DATA   10HMLI ERROR
M2        BSSZ   2

M3        DATA   10HCIO ERROR
M4        BSSZ   2

M13       DATA   20HREC ARBINFO ERROR
M14       BSS    1
          DATA   0
M15       DATA   10HRECLEN=
M16       BSS    1
          DATA   0
SMASK     VFD    60/1014040B
RMASK     VFD    60/40040B
MMASK     VFD    60/0
EOI       DATA   0
AIID170   EQU    0
AIWRITE   EQU    1
AIREAD    EQU    2
AIDATA    EQU    3
AIEOP     EQU    4
AIREWF    EQU    5
AISKIPF   EQU    6
AIEOF     EQU    7
AIEND     EQU    8
SIGNAL    BSS    1
ARBINFO   BSS    1
MSGLEN    BSS    1
SENDER    BSS    1
OPTYPE    BSS    1
SIONM     VFD    60/41000040B
ASM       VFD    60/40B
SMM       VFD    60/1016040B
RMM       VFD    60/40040B

CHKMLI    MACRO  MSK,BRANCH,STAT
          LOCAL  DONE
          SA1    STAT
          ZR     X1,DONE     IF STATUS=OK
          SA2    MSK
          SX0    1
          SB4    X1
          LX0    B4,X0
          BX2    X2*X0
          ZR     X2,MLERR
          RECALL
          EQ     BRANCH
DONE      BSS    0
          ENDM

BEGREAD   BSS    0
          SX6    AIDATA
          SA6    MLIPAR+MLPAR
          SX6    100
          SA6    MLIPAR+MLPSG
          SX6    MLFSE
          SA6    MLIPAR+MLPFN
          SX6    MLSOK
          SA6    MLIPAR+MLPSV
*
          SA1    SMASK
          BX7    X1
          SA7    MMASK
          READ   FETA,R

LOOP      BSS    0
          RESET  FETB
          READ   FETB
          SMSG   HWA,FETA,BUFA
          RECALL FETB
          CKMST  MMASK

          RESET  FETA
          READ   FETA
          SMSG   HWB,FETB,BUFB
          RECALL FETA
          CKMST  MMASK
          EQ     LOOP

BEGWRIT   BSS    0
          SX6    100
          SA6    MLIPAR+MLPSG
          SX6    MLFRE
          SA6    MLIPAR+MLPFN
          SX6    MLSOK
          SA6    MLIPAR+MLPSV
          SX6    BUFSIZ
          SA6    MLIPAR+MLPBL  BUFFER LENGTH
          MX6    0
          SA6    MLIPAR+MLPRI  RECEIVE INDEX
*
          SA1    RMASK
          BX7    X1
          SA7    MMASK
          REWIND FETA,R

RLOOP     BSS    0
          RECM   BUFA
          RECALL FETB
          CKIOST FETB
          CKMST  MMASK
          WRITF  FETA,HWA

          RECM   BUFB
          RECALL FETA
          CKIOST FETA
          CKMST  MMASK
          WRITF  FETB,HWB
          EQ     RLOOP

RAIERR    BSS    0
          SA1    MLIPAR+MLPV2
          RJ     CDD
          SA6    M14
          MESSAGE M13,0,R
          EQ     EXIT

MLERR     BSS    0
          SA2    MLIPAR+MLPSV
          MX6    0
          SA6    MLIPAR+MLPSV  TO PREVENT LOOP WITH EXIT/CKMST/MLERR
          BX1    X2
          RJ     CDD
          SA6    M2
          MESSAGE M1,0,R
          EQ     EXIT

IOERR     BSS    0
          BX1    X2
          RJ     CDD
          SA6    M4
          MESSAGE M3,0,R
          EQ     EXIT

ERR1      BSS    0
          MESSAGE (=C*NO AN180 IN INPUT FILE*),3,R
          EQ     EXIT

ERR2      BSS    0
          MESSAGE (=C*WRITE DIDNT FLUSH*),3,R
          EQ     EXIT

EXIT      BSS    0
          CKMST  MMASK
          RECALL FETA
          RECALL FETB
          SA1    OPTYPE
          SX0    X1-AIWRITE
          NZ     X0,EXIT2    IF NOT WRITE
EXIT1     BSS    0
          SEND   AN170,=0,SIGNAL,SIGNAL,=1,AN180,STS
          CHKMLI SMM,EXIT1,STS
EXIT2     BSS    0
          ENDRUN

          EJECT
ISSUE     BSS    1
ISSUE0    BSS    0
          SA1    NTHSR
          PL     X1,ISSUE3   IF REQUEST OUTSTANDING
          SX4    0
          SX2    MLIPAR
          CALLVS X2,X4,CVSMLIU,0
          ZR     X0,ISSUE    IF REQUEST COMPLETE
          BX1    X0
          AX1    30
          NZ     X1,ISSUE1   IF NOS/VE DOWN
          SX0    X0-1
          NZ     X0,ISSUE2   IF REQUEST NOT COMPLETE
          RECALL
          EQ     ISSUE0

ISSUE2    BSS    0
          BX6    X4
          SA6    NTHSR
          EQ     ISSUE       RETURN

ISSUE1    BSS    0
          SX6    MLSND
          SA6    MLIPAR+MLPSV
          EQ     ISSUE

ISSUE3    BSS    0
          MESSAGE (=C* REQ W/REQ OUTSTANDING*),3,R
          ABORT

**********************************************

POLL      BSS    1
          SA4    NTHSR
          NG     X4,POLL     IF NO REQUEST
          SX1    MLIPAR
          CALLVS X1,X4,CVSMLIU,0
          ZR     X0,POLL1    IF REQUEST COMPLETE
          AX0    30
          NZ     X0,POLL2    IF NOSVE DOWN
          EQ     POLL

POLL1     BSS    0
          SX6    -2
          SA6    NTHSR
          EQ     POLL

POLL2     BSS    0
          SX6    MLSND
          SA6    MLIPAR+MLPSV
          EQ     POLL
          EJECT
PFU       BSS    0
 XPFUA    BSS    0
          SB1    1
          MX6    0
          SA6    BUFB
          READ   INPUT,R
          SA1    BUFB
          ZR     X1,ERR1     IF NO AN180
          BX6    X1
          SA6    AN180

          MESSAGE (=C*SIGNON*),3,R
PFU1      BSS    0
          SIGNON =0,=0,AN170,STS
          CHKMLI SIONM,PFU1,STS

          MESSAGE (=C*ADDSPL*),3,R
PFU2      BSS    0
          ADDSPL AN170,AN180,STS
          CHKMLI ASM,PFU2,STS

          MESSAGE (=C*SEND AN170*),3,R
PFU3      BSS    0

* IC CONVENTION FOR AI IS:
* BIT0 = LAST
* BIT1 = FIRST
* BIT2 = EOP
* BIT3 = EOI
* BIT4-N = UBC

          SEND   AN170,=3,SIGNAL,AN170,=1,AN180,STS
          CHKMLI SMM,PFU3,STS

          MX6    0
          SA6    BUFB
          SA6    BUFB+1
          MESSAGE (=C*REC AN180*),3,R
PFU4      BSS    0
          RECEIVE AN170,ARBINFO,SIGNAL,BUFB,MSGLEN,=2,=0,SENDER,STS
          CHKMLI RMM,PFU4,STS

          SA2    BUFB
          BX6    X2
          SA6    AN180
          SA1    BUFB+1
          SX0    X1-AIWRITE
          NZ     X0,PFU6     IF NOT WRITE
          SX6    AIWRITE
          SA6    OPTYPE
          MESSAGE (=C*BEGIN WRITE*),3,R
          EQ     PFU8

PFU6      BSS    0
          SX0    X1-AIREAD
          NZ     X0,PFU7     IF NOT READ
          SX6    AIREAD
          SA6    OPTYPE
          MESSAGE (=C*BEGIN READ*),3,R
          EQ     PFU8

PFU7      BSS    0
          MESSAGE (=C*ILLEGAL START REQ*),3,R
          EQ     EXIT

PFU8      BSS    0
          MESSAGE (=C*ADD NEW AN180*),3,R
          ADDSPL AN170,AN180,STS
          CHKMLI ASM,PFU8,STS

* SETUP

          SA1    AN170
          SA2    AN180
          BX6    X1
          BX7    X2
          SA6    MLIPAR+MLPAN
          SA7    MLIPAR+MLPSN

          MX0    42
          SA1    =0LTAPE
          SA2    FETA
          BX2    -X0*X2
          BX6    X2+X1
          SA6    FETA
          SA6    FETB

          SA1    OPTYPE
          SX0    X1-AIWRITE
          ZR     X0,BEGWRIT  BEGIN TAPE WRITE
          EQ     BEGREAD     ELSE BEGIN READ
          END    XPFUA
*DECK DECK=RAM$NVEPROL EXPAND=TRUE
.PROC,NVEPROL*I,
UN "- USER NAME OF FILES"           = (*N,*F),
.
.HELP
 The NVEPROL procedure makes NVELIB part of the Global Library Set.
 On NOS/BE, the library NVELIB must first be created from the
 release file NVELIBB.
.ENDHELP
.IFE,SYS=NOS,NOSSYS.
  .IFE,OT.EQ.TXO,TERMINAL.
    $RECOVER,OP=T.
  .ENDIF,TERMINAL.
  $ATTACH,NVELIB/NA,M=R.
  $IFE,.NOT.FILE(NVELIB,AS),GETFROMSYS.
  COMMON,SYSTEM.
  GTR,SYSTEM,NVELIB,U.ULIB/NVELIB
  $UNLOAD,SYSTEM.
  $ENDIF,GETFROMSYS.
  $LIBRARY,NVELIB/D.
  $LIBRARY,NVELIB/A.
.ELSE,NOSSYS.
  .IFE,FILE(NVELIBB,.NOT.AS),GETNVEB.
    ATTACH,NVELIBB,ID=UN,MR=1.
    SKIP,ATTA1.
      EXIT(U)
      REVERT,ABORT. NVELIBB NOT FOUND
    ENDIF,ATTA1.
  .ENDIF,GETNVEB.
  LIBRARY.
  RETURN,NVELIB.
  REQUEST,NVELIB,SN,PF.
  EDITLIB,I=DIR,L=0.
  LIBRARY,NVELIB.
  CATALOG,NVELIB,ID=UN,RP=999.
  NOTE(OUTPUT,NR)+ NVELIB CREATED
  COMMENT. NVELIB CREATED
  .IFE,FILE(NVELIBB,.NOT.AS).RETURN,NVELIBB.
  SKIP,NOERR.
    EXIT.
    REVERT,ABORT. CREATION OF NVELIB FAILED.
  ENDIF,NOERR.
.ENDIF,NOSSYS.
UNLOAD,NVEPROL,DIR.
REVERT. END NVEPROL
.DATA,DIR
LIBRARY(NVELIB,NEW)
ADD(*,NVELIBB,AL=3,FL=40000)
SETAL(ICAMMLI,0)
SETAL(REWIND,0)
SETAL(ABEND,0)
SETAL(READSKP,0)
FINISH.
ENDRUN.
/EOR
*DECK DECK=RAM$OMIT_ENTRY_POINTS EXPAND=TRUE
PROC omit_entry_points, omiep (
  module m: name = $required
  keep k: list of name
  keep_all ka: list of name
  number n: integer 1 .. 5000 = 5000
  status)

"----------------------------------------------------------------------"
" OMIT_ENTRY_POINTS
"
" PURPOSE:
"
"  Generate commands to omit all entry points from a module except
" those specified by the Keep parameter.  Must be called from inside
" CREATE_OBJECT_LIBRARY.
"
" PARAMETERS:
"
" Module: Name of module to be changed.  Required.
" Keep: List of entry_points to keep.
" Keep_All: List of names, where all entry_points beginning with
"  each of the names are kept.  Example: ka=SMP$.
" Number: Ususally defaulted to 5000.  Max number of entry points to
"  omit.
"----------------------------------------------------------------------"

  create_variable ignore_status kind=status
  commands = $unique
  set_file_attributes $fname(commands) fc=legible pf=continuous
  display_new_library $value(module) o=$fname(commands) do=ep
  create_variable discard_output kind=string value=$unique
  EDIT_FILE $fname(commands) o=$fname(discard_output)
    put_message 'Omit entry points from '//$string($value(module))//' keeping:'
    create_variable ignore_status kind=status
    create_variable entry_point_found kind=status
    set_verify_option echo=off
    delete_lines n=7
    change_text 'GATED' n=all status=ignore_status
    change_text 'RETAINED' n=all status=ignore_status
    FOR i = 1 TO $set_count(keep) DO
      put_message '    '//$string($value(keep i))
      search_backward n=all status=ignore_status
      search_forward $string($value(keep i)) us=yes status=entry_point_found
      IF entry_point_found.normal THEN
        delete_lines n=1
      IFEND
    FOREND
    FOR i = 1 TO $set_count(keep_all) DO
      put_message '    '//$string($value(keep_all i))//'*'
      set_search_margins 3..$strlen($string($value(keep_all i)))+2
      delete_lines $string($value(keep_all i)) all first..last status=ignore_status
    FOREND
    set_search_margins
    search_backward n=all status=ignore_status
    search_forward 'starting procedure:' status=entry_point_found
    IF NOT entry_point_found.normal THEN
      search_forward line=last
    ELSE
      search_backward n=1
    IFEND
    delete_lines n=all
    search_backward n=all status=ignore_status
    create_variable last_status kind=status
    FOR i = 1 TO $value(number) DO
      i p=before nt='change_module_attributes '//$string($value(module))//' o='
      search_forward n=1 status=last_status
      EXIT WHEN NOT last_status.normal
    FOREND
    search_backward n=all status=ignore_status
    change_text 'o=' 'o=...' n=all
  END
  include_file $fname(commands)
  detach_file $fname(discard_output)
  detach_file $fname(commands)

PROCEND omit_entry_points
*DECK DECK=RAM$OPEN_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: Module RAM$OPEN_FILE.' ??
MODULE ram$open_file;

{ PURPOSE:
{   This module contains a procedures to open a file.
{
{ DESIGN:
{   The FILE is opened with the file attachment option and
{   create file definitions provided in the procedure parameters.
{
{ NOTES:
{   This procedure should be called from within a block structure
{   which has a condition handler.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*copyc fsp$open_file

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := 'rap$open_segment_file [XDCL]', EJECT ??

{ PURPOSE:
{   This procedure opens a file.
{
{ DESIGN:
{   The FILE is opened with the attachment_option and
{        defined in the procedure parameters.
{
{ NOTES:
{   This procedure should be called from within a block structure
{   which has a condition handler.

  PROCEDURE [XDCL] rap$open_file
    (    path_ref_p: ^fst$file_reference;
         access_level: amt$access_level;
         file_attachment: fst$file_access_option;
         create_file: boolean;
         attribute_override_p: ^array [1 .. 1] of fst$file_cycle_attribute;
     VAR file_id: amt$file_identifier;
     VAR file_opened: boolean;
     VAR status: ost$status);


    VAR
      attachment_option: array [1 .. 3] of fst$attachment_option;


    status.normal := TRUE;
    file_opened := FALSE;

    attachment_option [1].selector := fsc$access_and_share_modes;
    attachment_option [1].access_modes.selector := fsc$specific_access_modes;

    IF file_attachment = fsc$read THEN

      attachment_option [1].access_modes.value := $fst$file_access_options [fsc$read];
      attachment_option [2].create_file := FALSE;

    ELSEIF file_attachment = fsc$modify THEN

      attachment_option [1].access_modes.value := $fst$file_access_options
            [fsc$read, fsc$shorten, fsc$append, fsc$modify];
      IF create_file = TRUE THEN
        attachment_option [2].create_file := TRUE;
      ELSE
        attachment_option [2].create_file := FALSE;
      IFEND;

    IFEND;

    attachment_option [1].share_modes.selector := fsc$determine_from_access_modes;
    attachment_option [2].selector := fsc$create_file;

{   The following attachment option is designed to detect offline residence of
{   the file being opened; ie. if the file has offline residence, an abnormal
{   status is returned from the open.  The allowed exceptions set below
{   includes all the current default allowed exception values, except the
{   one for offline residence (rac$data_retrieval_required).  Due to the way
{   the set is defined (ie. with several default names and several temporary
{   names to hold places for future values), the defaults had to be specified.
{   If the defaults change, the statment below sepcifying the defaults must
{   also change.

    attachment_option [3].selector := fsc$allowed_exceptions;
    attachment_option [3].allowed_exceptions.damage_symptoms :=
          $fst$cycle_damage_symptoms [];
    attachment_option [3].allowed_exceptions.access_conditions :=
           $fst$file_access_conditions[fsc$catalog_media_missing, fsc$catalog_volume_unavailable,
             fsc$cycle_busy, fsc$file_server_inactive, fsc$media_missing,
             fsc$space_unavailable, fsc$volume_unavailable];

    file_opened := TRUE;
    fsp$open_file (path_ref_p^, access_level, ^attachment_option, NIL, NIL, NIL, attribute_override_p,
          file_id, status);
    IF NOT status.normal THEN
      file_opened := FALSE;
      RETURN;
    IFEND;

  PROCEND rap$open_file;

MODEND ram$open_file;
*DECK DECK=RAM$OPEN_PACKING_LIST_USING_ICR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$OPEN_PACKING_LIST_USING_ICR Interface.' ??
MODULE ram$open_packing_list_using_icr;

{ PURPOSE:
{   This module contains the interface that opens the packing list using an
{   installation control record.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$install_software_cc
*copyc rac$control_job_identifier
*copyc rac$packing_list_level
*copyc rac$pacs_processor_version
*copyc fst$path
*copyc rat$installation_control_record
*copyc rat$packing_list_sequence
*copyc rat$sequence_descriptor_types
?? POP ??
*copyc amp$get_segment_pointer
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$open_packing_list_using_icr', EJECT ??

{ PURPOSE:
{   This interface opens the packing list specified by the installation
{   control record.
{
{ DESIGN:
{   The packing list is expected to reside in the installation database as
{   defined by the installation control record.  The file is opened and a
{   pointer to the packing list sequence is registered in the installation
{   control record.
{
{   A boolean declaring when the packing list is open and the file
{   identifier are returned.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$open_packing_list_using_icr
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR packing_list_fid: amt$file_identifier;
     VAR file_opened: boolean;
     VAR status: ost$status);


    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      ignore_status: ost$status,
      length: integer,
      packing_list_path: fst$path,
      segment_pointer: amt$segment_pointer;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to close the packing list
{   file when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (packing_list_fid, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options [fsc$read];
    attachment_options [1].share_modes.selector := fsc$determine_from_access_modes;
    attachment_options [2].selector := fsc$create_file;
    attachment_options [2].create_file := FALSE;
    attachment_options [3].selector := fsc$wait_for_attachment;
    attachment_options [3].wait_for_attachment.wait := osc$wait;
    attachment_options [3].wait_for_attachment.wait_time := fsc$longest_wait_time;

{  Assemble the path to the packing list using the installation database path and the packing list name. }

    STRINGREP (packing_list_path, length, installation_control_record.processing_header_p^.
          installation_defaults.installation_database.path (1,
          installation_control_record.processing_header_p^.installation_defaults.installation_database.size),
          '.', installation_control_record.processing_header_p^.
          packing_list_name (1, clp$trimmed_string_size (installation_control_record.processing_header_p^.
          packing_list_name)));

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      file_opened := TRUE;
      fsp$open_file (packing_list_path (1, length), amc$segment, ^attachment_options, NIL, NIL, NIL, NIL,
            packing_list_fid, status);
      IF NOT status.normal THEN
        file_opened := FALSE;
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (packing_list_fid, amc$sequence_pointer, segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      installation_control_record.packing_list_pointers.sequence_p := segment_pointer.sequence_pointer;

    END /main/;

    IF NOT status.normal AND file_opened THEN
      fsp$close_file (packing_list_fid, ignore_status);
      file_opened := FALSE;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$open_packing_list_using_icr;

MODEND ram$open_packing_list_using_icr;
*DECK DECK=RAM$OPEN_SHOP_DI_CONFIGURATIONS EXPAND=TRUE
PROC SYSTEM_08002510006B
"
"  DI-107 (10006B)  Connected to channel 7 on RED.
"
DEFINE_SYSTEM SN=MTDI_10006B
CHANGE_PROTOCOL_STACK_SUPPORT SS=OSI PS=OSI
DEFINE_ETHER_TRUNK TN=PERF_TRUNK
DEFINE_ETHER_NET TN=PERF_TRUNK NN=PERF_NET NI=2 COST=2000
DEFINE_TIP TN=ASYNCTIP
LOAD_MODULE M=ASYNCTIP_MODULE R=YES
LOAD_MODULE M=BATCH_STATUS_CONTROL_MODULE R=YES
DEFINE_LINE LIM=1 PORT=0 TN=ASYNCTIP LN=LINE10 AR=NONE LS=9600 ..
  LT=DEDICATED TDP=VE_ASYNC_TDP_1 DATA_PARITY=ODD
DEFINE_LINE LIM=1 PORT=1 TN=ASYNCTIP LN=LINE11 AR=NONE LS=9600 ..
  LT=DEDICATED TDP=VE_ASYNC_TDP_2 DATA_PARITY=ODD
DEFINE_LINE LIM=1 PORT=2 TN=ASYNCTIP LN=LINE12 AR=SCP LT=DEDICATED
DEFINE_LINE LIM=1 PORT=3 TN=ASYNCTIP LN=LINE13 AR=SCP LT=DEDICATED
"
" Passin line from Closed Shop network.
" (create_connection eval_pass / create_connection red)
"
DEFINE_LINE LIM=0 PORT=0 TN=ASYNCTIP LN=L06B00 LT=DEDICATED LS=9600 EFC=ON ..
  CDT=120
DISPLAY_DATE_AND_TIME
PROCEND SYSTEM_08002510006B
PROC SYSTEM_080025100092
"
"  DI-146 (100092)  Connected to channel 31 on VIOLET.
"
DEFINE_SYSTEM SN=MTDI_100092
DEFINE_ETHER_TRUNK TN=SS_TRUNK
DEFINE_ETHER_NET TN=SS_TRUNK NN=SS_LAN NI=2 COST=2000
DEFINE_IP_NET IN=(129,179,53,192) TN=SS_TRUNK SMS=26
DEFINE_VE_INTERFACE IN=NVE NI=769 S=FALSE
DEFINE_TCP_INTERFACE MC=500
DEFINE_UDP_INTERFACE
DEFINE_IP_HOST IA=(129 179 53 194) HT=LOCAL
DEFINE_IP_HOST IA=(129 179 53 195) HT=CDC_HOST
ADD_TCPIP_ACCESS IA=(129,179,53,195) IN=NVE
DEFINE_TIP TN=TELNET
ADDTS SN=TELNET_TO_VEHOST IA=(129,179,53,195) CDT=0 TUP=VE_TELNET_TUP
LOAD_MODULE M=ASYNCTIP_MODULE R=YES
LOAD_MODULE M=BATCH_STATUS_CONTROL_MODULE R=YES
DEFINE_LINE LIM=0 PORT=0 TN=ASYNCTIP LN=LINE00 AR=SCP LT=DEDICATED
PROCEND SYSTEM_080025100092
PROC SYSTEM_0800253000C2
"
"  DI-294 (3000C2)  MDI on COBALT connected to channels 5 (VE) and 11 (NOS)
"
DEFINE_SYSTEM SN=MTI_3000C2
CHANGE_PROTOCOL_STACK_SUPPORT SS=OSI PS=OSI
DEFINE_ETHER_TRUNK TN=PERF_TRUNK
DEFINE_ETHER_NET TN=PERF_TRUNK NN=PERF_NET NI=2 COST=2000
DEFINE_CHANNEL_TRUNK SLOT=5 TN=PERF_TRUNK
DEFINE_TIP TN=ASYNCTIP
LOAD_MODULE M=ASYNCTIP_MODULE R=YES
LOAD_MODULE M=BATCH_STATUS_CONTROL_MODULE R=YES
DEFINE_LINE LIM=1 PORT=1 TN=ASYNCTIP LN=LINE11 AR=NONE LS=9600 ..
  LT=DEDICATED CCT=INFINITE CDT=INFINITE TDP=VE_ASYNC_TDP_2 DP=ODD
DEFINE_LINE LIM=1 PORT=2 TN=ASYNCTIP LN=LINE12 AR=SCP LT=DEDICATED
DISPLAY_DATE_AND_TIME
PROCEND SYSTEM_0800253000C2
PROC SYSTEM_0800253000D3
"
DEFINE_SYSTEM SN=MTDI_3000D3
DEFINE_ETHER_TRUNK TN=SS_TRUNK
DEFINE_ETHER_NET TN=SS_TRUNK NN=SS_LAN NI=2 COST=2000
DEFINE_IP_NET IN=(129,179,53,192) TN=SS_TRUNK SMS=26
DEFINE_VE_INTERFACE IN=NVE NI=767 S=FALSE
DEFINE_TCP_INTERFACE MC=500
DEFINE_UDP_INTERFACE
DEFINE_IP_HOST IA=(129 179 53 200) HT=LOCAL
DEFINE_IP_HOST IA=(129 179 53 201) HT=CDC_HOST
ADD_TCPIP_ACCESS IA=(129,179,53,201) IN=NVE
DEFINE_TIP TN=TELNET
ADDTS SN=TELNET_TO_VEHOST IA=(129,179,53,201) CDT=0 TUP=VE_TELNET_TUP
LOAD_MODULE M=ASYNCTIP_MODULE R=YES
LOAD_MODULE M=BATCH_STATUS_CONTROL_MODULE R=YES
DEFINE_LINE LIM=0 PORT=0 TN=ASYNCTIP LN=LINE00 AR=SCP LT=DEDICATED
PROCEND SYSTEM_0800253000D3
PROC SYSTEM_0800253000D6
"
"  DI-314 (3000D6) MTI connected to channel 32 on MAUVE.
"
DEFINE_SYSTEM SN=MTI_3000D6
DEFINE_TIP TN=ASYNCTIP
LOAD_MODULE M=ASYNCTIP_MODULE R=YES
LOAD_MODULE M=BATCH_STATUS_CONTROL_MODULE R=YES
DEFINE_LINE LIM=0 PORT=0 TN=ASYNCTIP LN=LINE00 AR=SCP LT=DEDICATED
DEFINE_LINE LIM=0 PORT=1 TN=ASYNCTIP LN=LINE01 AR=SCP LT=DEDICATED
DEFINE_LINE LIM=0 PORT=2 TN=ASYNCTIP LN=LINE02 AR=NONE LS=9600 ..
  LT=DEDICATED TDP=VE_ASYNC_TDP_1 DATA_PARITY=ODD
DEFINE_LINE LIM=0 PORT=3 TN=ASYNCTIP LN=LINE03 AR=NONE LS=9600 ..
  LT=DEDICATED TDP=VE_ASYNC_TDP_2 DATA_PARITY=ODD
DISPLAY_DATE_AND_TIME
PROCEND SYSTEM_0800253000D6
PROC SYSTEM_0800253000F0
"
"  DI-340 (3000F0)  Connected to channel 11 on VIOLET.
"
DEFINE_SYSTEM SN=MTDI_3000F0
DEFINE_ETHER_TRUNK TN=SS_TRUNK
DEFINE_ETHER_NET TN=SS_TRUNK NN=SS_LAN NI=2 COST=2000
DEFINE_IP_NET IN=(129,179,53,192) TN=SS_TRUNK SMS=26
DEFINE_VE_INTERFACE IN=NVE NI=765 S=FALSE
DEFINE_TCP_INTERFACE MC=500
DEFINE_UDP_INTERFACE
DEFINE_IP_HOST IA=(129 179 53 202) HT=LOCAL
DEFINE_IP_HOST IA=(129 179 53 203) HT=CDC_HOST
ADD_TCPIP_ACCESS IA=(129,179,53,203) IN=NVE
DEFINE_TIP TN=TELNET
ADDTS SN=TELNET_TO_VEHOST IA=(129,179,53,203) CDT=0 TUP=VE_TELNET_TUP
DEFINE_TIP TN=ASYNCTIP
DEFINE_PASSTHROUGH_SERVICE
LOAD_MODULE M=ASYNCTIP_MODULE R=YES
LOAD_MODULE M=BATCH_STATUS_CONTROL_MODULE R=YES
DEFINE_LINE LIM=0 PORT=0 TN=ASYNCTIP LN=LINE00 AR=SCP LT=DEDICATED
DEFINE_LINE LIM=0 PORT=1 TN=ASYNCTIP LN=LINE01 AR=NONE LS=9600 ..
  LT=DEDICATED TDP=VE_ASYNC_TDP_1 DATA_PARITY=ODD
DEFINE_LINE LIM=0 PORT=3 TN=ASYNCTIP LN=LINE03 AR=NONE LS=9600 ..
  LT=DEDICATED TDP=VE_ASYNC_TDP_2 DATA_PARITY=ODD
"
" X25 line to SN 636 Lim 2 Port 1
"
DEFINE_X25_TRUNK LIM=0 PORT=2 TN=ARH_CLSH M=DTE CLOCKING=TRANSMIT ..
  TRUNK_SPEED=19200
DEFINE_X25_INTERFACE TN=ARH_CLSH PDN=TELENET TR=1..16 DPS=1024 DWS=7 LDA='1'
DEFINE_X25_GW GN=ARHCLSH_GW TN=ARH_CLSH
ADD_X25_GW_OUTCALL TITLE=PTFS$TAN PROTOCOL_ID=0C2(16) GN=ARHCLSH_GW ..
  USER_DATA='505446532454414E' RDA='2'
ADD_X25_GW_OUTCALL TITLE=QTFS$TAN PROTOCOL_ID=0C2(16) GN=ARHCLSH_GW ..
  USER_DATA='515446532454414E' RDA='2'
ADD_X25_GW_OUTCALL TITLE=PTFS$NVE PROTOCOL_ID=0C2(16) GN=ARHCLSH_GW ..
  USER_DATA='50544653244E5645' RDA='2'
ADD_X25_GW_OUTCALL TITLE=QTFS$NVE PROTOCOL_ID=0C2(16) GN=ARHCLSH_GW ..
  USER_DATA='51544653244E5645' RDA='2'
ADD_X25_GW_OUTCALL TITLE=PTFS$NVE3 PROTOCOL_ID=0C2(16) GN=ARHCLSH_GW ..
  USER_DATA='50544653244E564533' RDA='2'
ADD_X25_GW_OUTCALL TITLE=QTFS$NVE3 PROTOCOL_ID=0C2(16) GN=ARHCLSH_GW ..
  USER_DATA='51544653244E564533' RDA='2'
ADD_X25_GW_OUTCALL TITLE=PTFS$YELLOW PROTOCOL_ID=0C2(16) GN=ARHCLSH_GW ..
  USER_DATA='505446532459454C4C4F57' RDA='2'
ADD_X25_GW_OUTCALL TITLE=QTFS$YELLOW PROTOCOL_ID=0C2(16) GN=ARHCLSH_GW ..
  USER_DATA='515446532459454C4C4F57' RDA='2'
"
" Passin lines from Closed Shop network.
"
DEFINE_LINE LIM=1 PORT=0 TN=ASYNCTIP LN=LINE10 LT=DEDICATED LS=19200 EFC=ON ..
  CDT=120 TUP=PASSIN
DEFINE_LINE LIM=1 PORT=1 TN=ASYNCTIP LN=LINE11 LT=DEDICATED LS=19200 EFC=ON ..
  CDT=120 TUP=PASSIN
DEFINE_LINE LIM=1 PORT=2 TN=ASYNCTIP LN=LINE12 LT=DEDICATED LS=19200 EFC=ON ..
  CDT=120 TUP=PASSIN
DEFINE_LINE LIM=1 PORT=3 TN=ASYNCTIP LN=LINE13 LT=DEDICATED LS=19200 EFC=ON ..
  CDT=120 TUP=PASSIN
DEFINE_LINE LIM=1 PORT=4 TN=ASYNCTIP LN=LINE14 LT=DEDICATED LS=19200 EFC=ON ..
  CDT=120 TUP=PASSIN
DEFINE_LINE LIM=1 PORT=5 TN=ASYNCTIP LN=LINE15 LT=DEDICATED LS=19200 EFC=ON ..
  CDT=120 TUP=PASSIN
DEFINE_LINE LIM=1 PORT=6 TN=ASYNCTIP LN=LINE16 LT=DEDICATED LS=19200 EFC=ON ..
  CDT=120 TUP=PASSIN
"
" Passthrough line to Closed Shop network.
"
DEFINE_LINE LIM=1 PORT=7 TN=ASYNCTIP LN=LINE17 LT=DEDICATED LS=19200 EFC=ON ..
  CDT=120 TUP=CLSH_PASS
"
" Service display setup for SN302 network.
"
CHANGE_SERVICE_DISPLAY ADD_SERVICE=(VE302 CLSH_PASS) STATUS_INTERVAL=INFINITE
"
CHANGE_SERVICE_DISPLAY_TEXT SERVICE=CLSH_PASS ..
  TEXT='Passthrough to Closed Shop network.  One available port.'
CHANGE_SERVICE_DISPLAY_TEXT SERVICE=VE302 ..
  TEXT='VE 860/302, Perf Network. Alternate titles: violet.'
DISPLAY_DATE_AND_TIME
PROCEND SYSTEM_0800253000F0
PROC SYSTEM_080025300119
"
" DI-381 (300119)  Connected to channel 2 on GRAY.
"
defs sn=mdi_300119
defet tn=PERF_TRUNK SLOT=6
defen tn=PERF_TRUNK nn=PERF_NET ni=02(16)
defct slot=7
PROCEND SYSTEM_080025300119
PROC SYSTEM_08002530032E
"
"  DI-814 (30032E) MTI connected to channel 23 on EST_860
"
DEFINE_SYSTEM SN=MTI_30032E
DEFINE_TIP TN=ASYNCTIP
LOAD_MODULE M=ASYNCTIP_MODULE R=YES
LOAD_MODULE M=BATCH_STATUS_CONTROL_MODULE R=YES
DEFINE_LINE LIM=0 PORT=0 TN=ASYNCTIP LN=LINE00 AR=SCP LT=DEDICATED
DEFINE_LINE LIM=0 PORT=1 TN=ASYNCTIP LN=LINE01 AR=NONE LS=9600 ..
  LT=DEDICATED TDP=VE_ASYNC_TDP_1 DATA_PARITY=ODD
DISPLAY_DATE_AND_TIME
PROCEND SYSTEM_08002530032E
PROC SYSTEM_08002530034B
"
"  DI-843 (30034B)  TDI on VV Ethernet for PEWTER.
"
DEFINE_SYSTEM TDI_30034B
CHANGE_PROTOCOL_STACK_SUPPORT SS=OSI PS=OSI
DEFINE_ETHER_TRUNK TN=PERF_TRUNK
DEFINE_ETHER_NET TN=PERF_TRUNK NN=PERF_NET NI=2 COST=2000
DEFINE_TIP TN=ASYNCTIP
LOAD_MODULE M=ASYNCTIP_MODULE R=YES
LOAD_MODULE M=BATCH_STATUS_CONTROL_MODULE R=YES
DEFINE_LINE L=0 P=0 LN=LINE00 AR=SCP TN=ASYNCTIP LT=DEDICATED
DEFINE_LINE L=0 P=1 LN=LINE01 AR=SCP TN=ASYNCTIP LT=DEDICATED
DEFINE_LINE L=0 P=3 LN=LINE03 AR=NONE TN=ASYNCTIP LT=DEDICATED ..
    TDP=VE_ASYNC_TDP_1 LS=9600 DP=ODD
DISPLAY_DATE_AND_TIME
PROCEND SYSTEM_08002530034B
PROC SYSTEM_080025300705
"
"  DI-1797 (300705)  TDI on MM/SS Ethernet.
"
DEFINE_SYSTEM SN=TDI_300705
CHANGE_PROTOCOL_STACK_SUPPORT SS=OSI PS=OSI
DEFINE_ETHER_TRUNK TN=PERF_TRUNK
DEFINE_ETHER_NET TN=PERF_TRUNK NN=PERF_NET NI=2 COST=2000
DEFINE_TIP TN=ASYNCTIP
LOAD_MODULE M=ASYNCTIP_MODULE R=YES
DEFINE_LINE LIM=0 PORT=0 TN=ASYNCTIP LN=LINE00 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=1 TN=ASYNCTIP LN=LINE01 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=2 TN=ASYNCTIP LN=LINE02 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=3 TN=ASYNCTIP LN=LINE03 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=4 TN=ASYNCTIP LN=LINE04 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=5 TN=ASYNCTIP LN=LINE05 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=6 TN=ASYNCTIP LN=LINE06 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=7 TN=ASYNCTIP LN=LINE07 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=0 TN=ASYNCTIP LN=LINE10 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=1 TN=ASYNCTIP LN=LINE11 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=2 TN=ASYNCTIP LN=LINE12 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=3 TN=ASYNCTIP LN=LINE13 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=4 TN=ASYNCTIP LN=LINE14 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=5 TN=ASYNCTIP LN=LINE15 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=6 TN=ASYNCTIP LN=LINE16 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=7 TN=ASYNCTIP LN=LINE17 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=0 TN=ASYNCTIP LN=LINE20 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=1 TN=ASYNCTIP LN=LINE21 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=2 TN=ASYNCTIP LN=LINE22 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=3 TN=ASYNCTIP LN=LINE23 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=4 TN=ASYNCTIP LN=LINE24 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=5 TN=ASYNCTIP LN=LINE25 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=6 TN=ASYNCTIP LN=LINE26 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=7 TN=ASYNCTIP LN=LINE27 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=0 TN=ASYNCTIP LN=LINE30 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=1 TN=ASYNCTIP LN=LINE31 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=2 TN=ASYNCTIP LN=LINE32 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=3 TN=ASYNCTIP LN=LINE33 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=4 TN=ASYNCTIP LN=LINE34 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=5 TN=ASYNCTIP LN=LINE35 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=6 TN=ASYNCTIP LN=LINE36 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=7 TN=ASYNCTIP LN=LINE37 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=0 TN=ASYNCTIP LN=LINE40 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=1 TN=ASYNCTIP LN=LINE41 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=2 TN=ASYNCTIP LN=LINE42 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=3 TN=ASYNCTIP LN=LINE43 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=4 TN=ASYNCTIP LN=LINE44 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=5 TN=ASYNCTIP LN=LINE45 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=6 TN=ASYNCTIP LN=LINE46 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=7 TN=ASYNCTIP LN=LINE47 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=0 TN=ASYNCTIP LN=LINE50 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=1 TN=ASYNCTIP LN=LINE51 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=2 TN=ASYNCTIP LN=LINE52 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=3 TN=ASYNCTIP LN=LINE53 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=4 TN=ASYNCTIP LN=LINE54 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=5 TN=ASYNCTIP LN=LINE55 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=6 TN=ASYNCTIP LN=LINE56 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=7 TN=ASYNCTIP LN=LINE57 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=0 TN=ASYNCTIP LN=LINE60 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=1 TN=ASYNCTIP LN=LINE61 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=2 TN=ASYNCTIP LN=LINE62 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=3 TN=ASYNCTIP LN=LINE63 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=4 TN=ASYNCTIP LN=LINE64 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=5 TN=ASYNCTIP LN=LINE65 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=6 TN=ASYNCTIP LN=LINE66 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=7 TN=ASYNCTIP LN=LINE67 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=0 TN=ASYNCTIP LN=LINE70 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=1 TN=ASYNCTIP LN=LINE71 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=2 TN=ASYNCTIP LN=LINE72 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=3 TN=ASYNCTIP LN=LINE73 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=4 TN=ASYNCTIP LN=LINE74 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=5 TN=ASYNCTIP LN=LINE75 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=6 TN=ASYNCTIP LN=LINE76 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=7 TN=ASYNCTIP LN=LINE77 AR=SCP LT=DEDICATED TUP=TUPPCR
DISPLAY_DATE_AND_TIME
PROCEND SYSTEM_080025300705
PROC SYSTEM_080025300706
"
"  DI-1798 (300706)  TDI on MM/SS Ethernet.
"
DEFINE_SYSTEM SN=TDI_300706
CHANGE_PROTOCOL_STACK_SUPPORT SS=OSI PS=OSI
DEFINE_ETHER_TRUNK TN=PERF_TRUNK
DEFINE_ETHER_NET TN=PERF_TRUNK NN=PERF_NET NI=2 COST=2000
DEFINE_TIP TN=ASYNCTIP
LOAD_MODULE M=ASYNCTIP_MODULE R=YES
DEFINE_LINE LIM=0 PORT=0 TN=ASYNCTIP LN=LINE00 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=1 TN=ASYNCTIP LN=LINE01 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=2 TN=ASYNCTIP LN=LINE02 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=3 TN=ASYNCTIP LN=LINE03 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=4 TN=ASYNCTIP LN=LINE04 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=5 TN=ASYNCTIP LN=LINE05 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=6 TN=ASYNCTIP LN=LINE06 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=7 TN=ASYNCTIP LN=LINE07 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=0 TN=ASYNCTIP LN=LINE10 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=1 TN=ASYNCTIP LN=LINE11 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=2 TN=ASYNCTIP LN=LINE12 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=3 TN=ASYNCTIP LN=LINE13 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=4 TN=ASYNCTIP LN=LINE14 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=5 TN=ASYNCTIP LN=LINE15 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=6 TN=ASYNCTIP LN=LINE16 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=7 TN=ASYNCTIP LN=LINE17 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=0 TN=ASYNCTIP LN=LINE20 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=1 TN=ASYNCTIP LN=LINE21 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=2 TN=ASYNCTIP LN=LINE22 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=3 TN=ASYNCTIP LN=LINE23 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=4 TN=ASYNCTIP LN=LINE24 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=5 TN=ASYNCTIP LN=LINE25 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=6 TN=ASYNCTIP LN=LINE26 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=7 TN=ASYNCTIP LN=LINE27 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=0 TN=ASYNCTIP LN=LINE30 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=1 TN=ASYNCTIP LN=LINE31 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=2 TN=ASYNCTIP LN=LINE32 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=3 TN=ASYNCTIP LN=LINE33 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=4 TN=ASYNCTIP LN=LINE34 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=5 TN=ASYNCTIP LN=LINE35 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=6 TN=ASYNCTIP LN=LINE36 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=7 TN=ASYNCTIP LN=LINE37 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=0 TN=ASYNCTIP LN=LINE40 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=1 TN=ASYNCTIP LN=LINE41 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=2 TN=ASYNCTIP LN=LINE42 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=3 TN=ASYNCTIP LN=LINE43 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=4 TN=ASYNCTIP LN=LINE44 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=5 TN=ASYNCTIP LN=LINE45 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=6 TN=ASYNCTIP LN=LINE46 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=7 TN=ASYNCTIP LN=LINE47 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=0 TN=ASYNCTIP LN=LINE50 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=1 TN=ASYNCTIP LN=LINE51 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=2 TN=ASYNCTIP LN=LINE52 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=3 TN=ASYNCTIP LN=LINE53 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=4 TN=ASYNCTIP LN=LINE54 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=5 TN=ASYNCTIP LN=LINE55 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=6 TN=ASYNCTIP LN=LINE56 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=7 TN=ASYNCTIP LN=LINE57 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=0 TN=ASYNCTIP LN=LINE60 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=1 TN=ASYNCTIP LN=LINE61 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=2 TN=ASYNCTIP LN=LINE62 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=3 TN=ASYNCTIP LN=LINE63 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=4 TN=ASYNCTIP LN=LINE64 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=5 TN=ASYNCTIP LN=LINE65 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=6 TN=ASYNCTIP LN=LINE66 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=7 TN=ASYNCTIP LN=LINE67 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=0 TN=ASYNCTIP LN=LINE70 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=1 TN=ASYNCTIP LN=LINE71 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=2 TN=ASYNCTIP LN=LINE72 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=3 TN=ASYNCTIP LN=LINE73 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=4 TN=ASYNCTIP LN=LINE74 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=5 TN=ASYNCTIP LN=LINE75 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=6 TN=ASYNCTIP LN=LINE76 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=7 TN=ASYNCTIP LN=LINE77 AR=SCP LT=DEDICATED TUP=TUPPCR
DISPLAY_DATE_AND_TIME
PROCEND SYSTEM_080025300706
PROC SYSTEM_080025300708
"
"  DI-1800 (300708)  TDI on MM/SS Ethernet.
"
DEFINE_SYSTEM SN=TDI_300708
CHANGE_PROTOCOL_STACK_SUPPORT SS=OSI PS=OSI
DEFINE_ETHER_TRUNK TN=PERF_TRUNK
DEFINE_ETHER_NET TN=PERF_TRUNK NN=PERF_NET NI=2 COST=2000
DEFINE_TIP TN=ASYNCTIP
LOAD_MODULE M=ASYNCTIP_MODULE R=YES
DEFINE_LINE LIM=0 PORT=0 TN=ASYNCTIP LN=LINE00 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=1 TN=ASYNCTIP LN=LINE01 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=2 TN=ASYNCTIP LN=LINE02 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=3 TN=ASYNCTIP LN=LINE03 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=4 TN=ASYNCTIP LN=LINE04 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=5 TN=ASYNCTIP LN=LINE05 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=6 TN=ASYNCTIP LN=LINE06 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=7 TN=ASYNCTIP LN=LINE07 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=0 TN=ASYNCTIP LN=LINE10 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=1 TN=ASYNCTIP LN=LINE11 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=2 TN=ASYNCTIP LN=LINE12 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=3 TN=ASYNCTIP LN=LINE13 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=4 TN=ASYNCTIP LN=LINE14 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=5 TN=ASYNCTIP LN=LINE15 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=6 TN=ASYNCTIP LN=LINE16 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=7 TN=ASYNCTIP LN=LINE17 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=0 TN=ASYNCTIP LN=LINE20 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=1 TN=ASYNCTIP LN=LINE21 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=2 TN=ASYNCTIP LN=LINE22 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=3 TN=ASYNCTIP LN=LINE23 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=4 TN=ASYNCTIP LN=LINE24 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=5 TN=ASYNCTIP LN=LINE25 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=6 TN=ASYNCTIP LN=LINE26 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=7 TN=ASYNCTIP LN=LINE27 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=0 TN=ASYNCTIP LN=LINE30 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=1 TN=ASYNCTIP LN=LINE31 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=2 TN=ASYNCTIP LN=LINE32 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=3 TN=ASYNCTIP LN=LINE33 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=4 TN=ASYNCTIP LN=LINE34 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=5 TN=ASYNCTIP LN=LINE35 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=6 TN=ASYNCTIP LN=LINE36 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=7 TN=ASYNCTIP LN=LINE37 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=0 TN=ASYNCTIP LN=LINE40 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=1 TN=ASYNCTIP LN=LINE41 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=2 TN=ASYNCTIP LN=LINE42 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=3 TN=ASYNCTIP LN=LINE43 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=4 TN=ASYNCTIP LN=LINE44 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=5 TN=ASYNCTIP LN=LINE45 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=6 TN=ASYNCTIP LN=LINE46 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=7 TN=ASYNCTIP LN=LINE47 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=0 TN=ASYNCTIP LN=LINE50 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=1 TN=ASYNCTIP LN=LINE51 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=2 TN=ASYNCTIP LN=LINE52 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=3 TN=ASYNCTIP LN=LINE53 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=4 TN=ASYNCTIP LN=LINE54 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=5 TN=ASYNCTIP LN=LINE55 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=6 TN=ASYNCTIP LN=LINE56 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=7 TN=ASYNCTIP LN=LINE57 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=0 TN=ASYNCTIP LN=LINE60 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=1 TN=ASYNCTIP LN=LINE61 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=2 TN=ASYNCTIP LN=LINE62 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=3 TN=ASYNCTIP LN=LINE63 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=4 TN=ASYNCTIP LN=LINE64 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=5 TN=ASYNCTIP LN=LINE65 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=6 TN=ASYNCTIP LN=LINE66 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=7 TN=ASYNCTIP LN=LINE67 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=0 TN=ASYNCTIP LN=LINE70 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=1 TN=ASYNCTIP LN=LINE71 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=2 TN=ASYNCTIP LN=LINE72 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=3 TN=ASYNCTIP LN=LINE73 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=4 TN=ASYNCTIP LN=LINE74 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=5 TN=ASYNCTIP LN=LINE75 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=6 TN=ASYNCTIP LN=LINE76 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=7 TN=ASYNCTIP LN=LINE77 AR=SCP LT=DEDICATED TUP=TUPPCR
DISPLAY_DATE_AND_TIME
PROCEND SYSTEM_080025300708
PROC SYSTEM_08002530070A
"
"  DI-1802 (30070A)  TDI on MM/SS Ethernet.
"
DEFINE_SYSTEM SN=TDI_30070A
CHANGE_PROTOCOL_STACK_SUPPORT SS=OSI PS=OSI
DEFINE_ETHER_TRUNK TN=PERF_TRUNK
DEFINE_ETHER_NET TN=PERF_TRUNK NN=PERF_NET NI=2 COST=2000
DEFINE_TIP TN=ASYNCTIP
LOAD_MODULE M=ASYNCTIP_MODULE R=YES
DEFINE_LINE LIM=0 PORT=0 TN=ASYNCTIP LN=LINE00 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=1 TN=ASYNCTIP LN=LINE01 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=2 TN=ASYNCTIP LN=LINE02 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=3 TN=ASYNCTIP LN=LINE03 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=4 TN=ASYNCTIP LN=LINE04 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=5 TN=ASYNCTIP LN=LINE05 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=6 TN=ASYNCTIP LN=LINE06 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=7 TN=ASYNCTIP LN=LINE07 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=0 TN=ASYNCTIP LN=LINE10 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=1 TN=ASYNCTIP LN=LINE11 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=2 TN=ASYNCTIP LN=LINE12 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=3 TN=ASYNCTIP LN=LINE13 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=4 TN=ASYNCTIP LN=LINE14 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=5 TN=ASYNCTIP LN=LINE15 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=6 TN=ASYNCTIP LN=LINE16 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=7 TN=ASYNCTIP LN=LINE17 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=0 TN=ASYNCTIP LN=LINE20 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=1 TN=ASYNCTIP LN=LINE21 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=2 TN=ASYNCTIP LN=LINE22 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=3 TN=ASYNCTIP LN=LINE23 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=4 TN=ASYNCTIP LN=LINE24 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=5 TN=ASYNCTIP LN=LINE25 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=6 TN=ASYNCTIP LN=LINE26 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=7 TN=ASYNCTIP LN=LINE27 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=0 TN=ASYNCTIP LN=LINE30 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=1 TN=ASYNCTIP LN=LINE31 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=2 TN=ASYNCTIP LN=LINE32 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=3 TN=ASYNCTIP LN=LINE33 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=4 TN=ASYNCTIP LN=LINE34 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=5 TN=ASYNCTIP LN=LINE35 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=6 TN=ASYNCTIP LN=LINE36 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=7 TN=ASYNCTIP LN=LINE37 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=0 TN=ASYNCTIP LN=LINE40 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=1 TN=ASYNCTIP LN=LINE41 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=2 TN=ASYNCTIP LN=LINE42 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=3 TN=ASYNCTIP LN=LINE43 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=4 TN=ASYNCTIP LN=LINE44 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=5 TN=ASYNCTIP LN=LINE45 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=6 TN=ASYNCTIP LN=LINE46 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=7 TN=ASYNCTIP LN=LINE47 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=0 TN=ASYNCTIP LN=LINE50 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=1 TN=ASYNCTIP LN=LINE51 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=2 TN=ASYNCTIP LN=LINE52 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=3 TN=ASYNCTIP LN=LINE53 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=4 TN=ASYNCTIP LN=LINE54 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=5 TN=ASYNCTIP LN=LINE55 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=6 TN=ASYNCTIP LN=LINE56 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=7 TN=ASYNCTIP LN=LINE57 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=0 TN=ASYNCTIP LN=LINE60 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=1 TN=ASYNCTIP LN=LINE61 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=2 TN=ASYNCTIP LN=LINE62 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=3 TN=ASYNCTIP LN=LINE63 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=4 TN=ASYNCTIP LN=LINE64 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=5 TN=ASYNCTIP LN=LINE65 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=6 TN=ASYNCTIP LN=LINE66 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=7 TN=ASYNCTIP LN=LINE67 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=0 TN=ASYNCTIP LN=LINE70 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=1 TN=ASYNCTIP LN=LINE71 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=2 TN=ASYNCTIP LN=LINE72 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=3 TN=ASYNCTIP LN=LINE73 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=4 TN=ASYNCTIP LN=LINE74 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=5 TN=ASYNCTIP LN=LINE75 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=6 TN=ASYNCTIP LN=LINE76 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=7 TN=ASYNCTIP LN=LINE77 AR=SCP LT=DEDICATED TUP=TUPPCR
DISPLAY_DATE_AND_TIME
PROCEND SYSTEM_08002530070A
PROC SYSTEM_08002530070F
"
"  DI-1807 (30070F)  TDI on MM/SS Ethernet.
"
DEFINE_SYSTEM SN=TDI_30070F
CHANGE_PROTOCOL_STACK_SUPPORT SS=OSI PS=OSI
DEFINE_ETHER_TRUNK TN=PERF_TRUNK
DEFINE_ETHER_NET TN=PERF_TRUNK NN=PERF_NET NI=2 COST=2000
DEFINE_TIP TN=ASYNCTIP
LOAD_MODULE M=ASYNCTIP_MODULE R=YES
DEFINE_LINE LIM=0 PORT=0 TN=ASYNCTIP LN=LINE00 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=1 TN=ASYNCTIP LN=LINE01 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=2 TN=ASYNCTIP LN=LINE02 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=3 TN=ASYNCTIP LN=LINE03 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=4 TN=ASYNCTIP LN=LINE04 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=5 TN=ASYNCTIP LN=LINE05 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=6 TN=ASYNCTIP LN=LINE06 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=7 TN=ASYNCTIP LN=LINE07 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=0 TN=ASYNCTIP LN=LINE10 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=1 TN=ASYNCTIP LN=LINE11 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=2 TN=ASYNCTIP LN=LINE12 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=3 TN=ASYNCTIP LN=LINE13 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=4 TN=ASYNCTIP LN=LINE14 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=5 TN=ASYNCTIP LN=LINE15 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=6 TN=ASYNCTIP LN=LINE16 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=7 TN=ASYNCTIP LN=LINE17 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=0 TN=ASYNCTIP LN=LINE20 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=1 TN=ASYNCTIP LN=LINE21 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=2 TN=ASYNCTIP LN=LINE22 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=3 TN=ASYNCTIP LN=LINE23 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=4 TN=ASYNCTIP LN=LINE24 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=5 TN=ASYNCTIP LN=LINE25 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=6 TN=ASYNCTIP LN=LINE26 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=7 TN=ASYNCTIP LN=LINE27 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=0 TN=ASYNCTIP LN=LINE30 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=1 TN=ASYNCTIP LN=LINE31 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=2 TN=ASYNCTIP LN=LINE32 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=3 TN=ASYNCTIP LN=LINE33 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=4 TN=ASYNCTIP LN=LINE34 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=5 TN=ASYNCTIP LN=LINE35 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=6 TN=ASYNCTIP LN=LINE36 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=7 TN=ASYNCTIP LN=LINE37 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=0 TN=ASYNCTIP LN=LINE40 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=1 TN=ASYNCTIP LN=LINE41 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=2 TN=ASYNCTIP LN=LINE42 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=3 TN=ASYNCTIP LN=LINE43 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=4 TN=ASYNCTIP LN=LINE44 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=5 TN=ASYNCTIP LN=LINE45 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=6 TN=ASYNCTIP LN=LINE46 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=7 TN=ASYNCTIP LN=LINE47 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=0 TN=ASYNCTIP LN=LINE50 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=1 TN=ASYNCTIP LN=LINE51 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=2 TN=ASYNCTIP LN=LINE52 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=3 TN=ASYNCTIP LN=LINE53 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=4 TN=ASYNCTIP LN=LINE54 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=5 TN=ASYNCTIP LN=LINE55 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=6 TN=ASYNCTIP LN=LINE56 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=7 TN=ASYNCTIP LN=LINE57 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=0 TN=ASYNCTIP LN=LINE60 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=1 TN=ASYNCTIP LN=LINE61 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=2 TN=ASYNCTIP LN=LINE62 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=3 TN=ASYNCTIP LN=LINE63 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=4 TN=ASYNCTIP LN=LINE64 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=5 TN=ASYNCTIP LN=LINE65 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=6 TN=ASYNCTIP LN=LINE66 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=7 TN=ASYNCTIP LN=LINE67 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=0 TN=ASYNCTIP LN=LINE70 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=1 TN=ASYNCTIP LN=LINE71 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=2 TN=ASYNCTIP LN=LINE72 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=3 TN=ASYNCTIP LN=LINE73 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=4 TN=ASYNCTIP LN=LINE74 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=5 TN=ASYNCTIP LN=LINE75 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=6 TN=ASYNCTIP LN=LINE76 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=7 TN=ASYNCTIP LN=LINE77 AR=SCP LT=DEDICATED TUP=TUPPCR
DISPLAY_DATE_AND_TIME
PROCEND SYSTEM_08002530070F
PROC SYSTEM_080025300711
"
"  DI-1809 (300711)  TDI on MM/SS Ethernet.
"
DEFINE_SYSTEM SN=TDI_300711
CHANGE_PROTOCOL_STACK_SUPPORT SS=OSI PS=OSI
DEFINE_ETHER_TRUNK TN=PERF_TRUNK
DEFINE_ETHER_NET TN=PERF_TRUNK NN=PERF_NET NI=2 COST=2000
DEFINE_TIP TN=ASYNCTIP
LOAD_MODULE M=ASYNCTIP_MODULE R=YES
DEFINE_LINE LIM=0 PORT=0 TN=ASYNCTIP LN=LINE00 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=1 TN=ASYNCTIP LN=LINE01 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=2 TN=ASYNCTIP LN=LINE02 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=3 TN=ASYNCTIP LN=LINE03 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=4 TN=ASYNCTIP LN=LINE04 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=5 TN=ASYNCTIP LN=LINE05 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=6 TN=ASYNCTIP LN=LINE06 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=7 TN=ASYNCTIP LN=LINE07 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=0 TN=ASYNCTIP LN=LINE10 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=1 TN=ASYNCTIP LN=LINE11 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=2 TN=ASYNCTIP LN=LINE12 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=3 TN=ASYNCTIP LN=LINE13 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=4 TN=ASYNCTIP LN=LINE14 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=5 TN=ASYNCTIP LN=LINE15 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=6 TN=ASYNCTIP LN=LINE16 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=7 TN=ASYNCTIP LN=LINE17 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=0 TN=ASYNCTIP LN=LINE20 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=1 TN=ASYNCTIP LN=LINE21 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=2 TN=ASYNCTIP LN=LINE22 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=3 TN=ASYNCTIP LN=LINE23 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=4 TN=ASYNCTIP LN=LINE24 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=5 TN=ASYNCTIP LN=LINE25 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=6 TN=ASYNCTIP LN=LINE26 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=7 TN=ASYNCTIP LN=LINE27 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=0 TN=ASYNCTIP LN=LINE30 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=1 TN=ASYNCTIP LN=LINE31 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=2 TN=ASYNCTIP LN=LINE32 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=3 TN=ASYNCTIP LN=LINE33 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=4 TN=ASYNCTIP LN=LINE34 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=5 TN=ASYNCTIP LN=LINE35 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=6 TN=ASYNCTIP LN=LINE36 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=7 TN=ASYNCTIP LN=LINE37 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=0 TN=ASYNCTIP LN=LINE40 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=1 TN=ASYNCTIP LN=LINE41 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=2 TN=ASYNCTIP LN=LINE42 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=3 TN=ASYNCTIP LN=LINE43 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=4 TN=ASYNCTIP LN=LINE44 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=5 TN=ASYNCTIP LN=LINE45 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=6 TN=ASYNCTIP LN=LINE46 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=7 TN=ASYNCTIP LN=LINE47 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=0 TN=ASYNCTIP LN=LINE50 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=1 TN=ASYNCTIP LN=LINE51 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=2 TN=ASYNCTIP LN=LINE52 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=3 TN=ASYNCTIP LN=LINE53 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=4 TN=ASYNCTIP LN=LINE54 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=5 TN=ASYNCTIP LN=LINE55 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=6 TN=ASYNCTIP LN=LINE56 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=7 TN=ASYNCTIP LN=LINE57 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=0 TN=ASYNCTIP LN=LINE60 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=1 TN=ASYNCTIP LN=LINE61 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=2 TN=ASYNCTIP LN=LINE62 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=3 TN=ASYNCTIP LN=LINE63 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=4 TN=ASYNCTIP LN=LINE64 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=5 TN=ASYNCTIP LN=LINE65 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=6 TN=ASYNCTIP LN=LINE66 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=7 TN=ASYNCTIP LN=LINE67 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=0 TN=ASYNCTIP LN=LINE70 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=1 TN=ASYNCTIP LN=LINE71 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=2 TN=ASYNCTIP LN=LINE72 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=3 TN=ASYNCTIP LN=LINE73 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=4 TN=ASYNCTIP LN=LINE74 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=5 TN=ASYNCTIP LN=LINE75 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=6 TN=ASYNCTIP LN=LINE76 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=7 TN=ASYNCTIP LN=LINE77 AR=SCP LT=DEDICATED TUP=TUPPCR
DISPLAY_DATE_AND_TIME
PROCEND SYSTEM_080025300711
PROC SYSTEM_080025300712
"
"  DI-1810 (300712)  TDI on MM/SS Ethernet.
"
DEFINE_SYSTEM SN=TDI_300712
CHANGE_PROTOCOL_STACK_SUPPORT SS=OSI PS=OSI
DEFINE_ETHER_TRUNK TN=PERF_TRUNK
DEFINE_ETHER_NET TN=PERF_TRUNK NN=PERF_NET NI=2 COST=2000
DEFINE_TIP TN=ASYNCTIP
LOAD_MODULE M=ASYNCTIP_MODULE R=YES
DEFINE_LINE LIM=0 PORT=0 TN=ASYNCTIP LN=LINE00 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=1 TN=ASYNCTIP LN=LINE01 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=2 TN=ASYNCTIP LN=LINE02 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=3 TN=ASYNCTIP LN=LINE03 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=4 TN=ASYNCTIP LN=LINE04 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=5 TN=ASYNCTIP LN=LINE05 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=6 TN=ASYNCTIP LN=LINE06 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=7 TN=ASYNCTIP LN=LINE07 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=0 TN=ASYNCTIP LN=LINE10 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=1 TN=ASYNCTIP LN=LINE11 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=2 TN=ASYNCTIP LN=LINE12 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=3 TN=ASYNCTIP LN=LINE13 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=4 TN=ASYNCTIP LN=LINE14 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=5 TN=ASYNCTIP LN=LINE15 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=6 TN=ASYNCTIP LN=LINE16 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=7 TN=ASYNCTIP LN=LINE17 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=0 TN=ASYNCTIP LN=LINE20 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=1 TN=ASYNCTIP LN=LINE21 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=2 TN=ASYNCTIP LN=LINE22 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=3 TN=ASYNCTIP LN=LINE23 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=4 TN=ASYNCTIP LN=LINE24 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=5 TN=ASYNCTIP LN=LINE25 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=6 TN=ASYNCTIP LN=LINE26 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=7 TN=ASYNCTIP LN=LINE27 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=0 TN=ASYNCTIP LN=LINE30 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=1 TN=ASYNCTIP LN=LINE31 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=2 TN=ASYNCTIP LN=LINE32 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=3 TN=ASYNCTIP LN=LINE33 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=4 TN=ASYNCTIP LN=LINE34 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=5 TN=ASYNCTIP LN=LINE35 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=6 TN=ASYNCTIP LN=LINE36 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=7 TN=ASYNCTIP LN=LINE37 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=0 TN=ASYNCTIP LN=LINE40 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=1 TN=ASYNCTIP LN=LINE41 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=2 TN=ASYNCTIP LN=LINE42 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=3 TN=ASYNCTIP LN=LINE43 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=4 TN=ASYNCTIP LN=LINE44 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=5 TN=ASYNCTIP LN=LINE45 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=6 TN=ASYNCTIP LN=LINE46 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=7 TN=ASYNCTIP LN=LINE47 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=0 TN=ASYNCTIP LN=LINE50 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=1 TN=ASYNCTIP LN=LINE51 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=2 TN=ASYNCTIP LN=LINE52 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=3 TN=ASYNCTIP LN=LINE53 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=4 TN=ASYNCTIP LN=LINE54 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=5 TN=ASYNCTIP LN=LINE55 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=6 TN=ASYNCTIP LN=LINE56 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=7 TN=ASYNCTIP LN=LINE57 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=0 TN=ASYNCTIP LN=LINE60 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=1 TN=ASYNCTIP LN=LINE61 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=2 TN=ASYNCTIP LN=LINE62 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=3 TN=ASYNCTIP LN=LINE63 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=4 TN=ASYNCTIP LN=LINE64 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=5 TN=ASYNCTIP LN=LINE65 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=6 TN=ASYNCTIP LN=LINE66 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=7 TN=ASYNCTIP LN=LINE67 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=0 TN=ASYNCTIP LN=LINE70 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=1 TN=ASYNCTIP LN=LINE71 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=2 TN=ASYNCTIP LN=LINE72 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=3 TN=ASYNCTIP LN=LINE73 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=4 TN=ASYNCTIP LN=LINE74 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=5 TN=ASYNCTIP LN=LINE75 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=6 TN=ASYNCTIP LN=LINE76 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=7 TN=ASYNCTIP LN=LINE77 AR=SCP LT=DEDICATED TUP=TUPPCR
DISPLAY_DATE_AND_TIME
PROCEND SYSTEM_080025300712
PROC SYSTEM_080025300713
"
"  DI-1811 (300713)  TDI on MM/SS Ethernet.
"
DEFINE_SYSTEM SN=TDI_300713
CHANGE_PROTOCOL_STACK_SUPPORT SS=OSI PS=OSI
DEFINE_ETHER_TRUNK TN=PERF_TRUNK
DEFINE_ETHER_NET TN=PERF_TRUNK NN=PERF_NET NI=2 COST=2000
DEFINE_TIP TN=ASYNCTIP
LOAD_MODULE M=ASYNCTIP_MODULE R=YES
DEFINE_LINE LIM=0 PORT=0 TN=ASYNCTIP LN=LINE00 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=1 TN=ASYNCTIP LN=LINE01 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=2 TN=ASYNCTIP LN=LINE02 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=3 TN=ASYNCTIP LN=LINE03 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=4 TN=ASYNCTIP LN=LINE04 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=5 TN=ASYNCTIP LN=LINE05 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=6 TN=ASYNCTIP LN=LINE06 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=0 PORT=7 TN=ASYNCTIP LN=LINE07 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=0 TN=ASYNCTIP LN=LINE10 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=1 TN=ASYNCTIP LN=LINE11 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=2 TN=ASYNCTIP LN=LINE12 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=3 TN=ASYNCTIP LN=LINE13 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=4 TN=ASYNCTIP LN=LINE14 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=5 TN=ASYNCTIP LN=LINE15 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=6 TN=ASYNCTIP LN=LINE16 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=1 PORT=7 TN=ASYNCTIP LN=LINE17 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=0 TN=ASYNCTIP LN=LINE20 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=1 TN=ASYNCTIP LN=LINE21 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=2 TN=ASYNCTIP LN=LINE22 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=3 TN=ASYNCTIP LN=LINE23 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=4 TN=ASYNCTIP LN=LINE24 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=5 TN=ASYNCTIP LN=LINE25 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=6 TN=ASYNCTIP LN=LINE26 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=2 PORT=7 TN=ASYNCTIP LN=LINE27 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=0 TN=ASYNCTIP LN=LINE30 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=1 TN=ASYNCTIP LN=LINE31 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=2 TN=ASYNCTIP LN=LINE32 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=3 TN=ASYNCTIP LN=LINE33 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=4 TN=ASYNCTIP LN=LINE34 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=5 TN=ASYNCTIP LN=LINE35 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=6 TN=ASYNCTIP LN=LINE36 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=3 PORT=7 TN=ASYNCTIP LN=LINE37 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=0 TN=ASYNCTIP LN=LINE40 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=1 TN=ASYNCTIP LN=LINE41 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=2 TN=ASYNCTIP LN=LINE42 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=3 TN=ASYNCTIP LN=LINE43 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=4 TN=ASYNCTIP LN=LINE44 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=5 TN=ASYNCTIP LN=LINE45 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=6 TN=ASYNCTIP LN=LINE46 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=4 PORT=7 TN=ASYNCTIP LN=LINE47 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=0 TN=ASYNCTIP LN=LINE50 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=1 TN=ASYNCTIP LN=LINE51 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=2 TN=ASYNCTIP LN=LINE52 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=3 TN=ASYNCTIP LN=LINE53 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=4 TN=ASYNCTIP LN=LINE54 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=5 TN=ASYNCTIP LN=LINE55 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=6 TN=ASYNCTIP LN=LINE56 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=5 PORT=7 TN=ASYNCTIP LN=LINE57 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=0 TN=ASYNCTIP LN=LINE60 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=1 TN=ASYNCTIP LN=LINE61 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=2 TN=ASYNCTIP LN=LINE62 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=3 TN=ASYNCTIP LN=LINE63 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=4 TN=ASYNCTIP LN=LINE64 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=5 TN=ASYNCTIP LN=LINE65 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=6 TN=ASYNCTIP LN=LINE66 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=6 PORT=7 TN=ASYNCTIP LN=LINE67 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=0 TN=ASYNCTIP LN=LINE70 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=1 TN=ASYNCTIP LN=LINE71 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=2 TN=ASYNCTIP LN=LINE72 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=3 TN=ASYNCTIP LN=LINE73 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=4 TN=ASYNCTIP LN=LINE74 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=5 TN=ASYNCTIP LN=LINE75 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=6 TN=ASYNCTIP LN=LINE76 AR=SCP LT=DEDICATED TUP=TUPPCR
DEFINE_LINE LIM=7 PORT=7 TN=ASYNCTIP LN=LINE77 AR=SCP LT=DEDICATED TUP=TUPPCR
DISPLAY_DATE_AND_TIME
PROCEND SYSTEM_080025300713
PROC SYSTEM_0800254FFF20
"
"  ICA-124 (4FFF20)  ICA connected to channel 20 on PEWTER.
"
DEFINE_SYSTEM SN=ICA_4FFF20
DEFINE_ETHER_TRUNK TN=SS_TRUNK
DEFINE_ETHER_NET TN=SS_TRUNK NN=SS_LAN NI=2 COST=2000
DEFINE_IP_NET IN=(129,179,53,192) TN=SS_TRUNK SMS=26
DEFINE_VE_INTERFACE IN=nve NI=20(16)
DEFINE_TCP_INTERFACE
DEFINE_UDP_INTERFACE
DEFINE_IP_HOST IA=(129 179 53 194) HT=LOCAL
DEFINE_IP_HOST IA=(129 179 53 195) HT=CDC_HOST
ADD_TCPIP_ACCESS IA=(129,179,53,195) IN=NVE
DEFINE_TIP TN=TELNET
ADDTS SN=TELNET_TO_VEHOST IA=(129,179,53,195) CDT=0 TUP=VE_TELNET_TUP
PROCEND SYSTEM_0800254FFF20
PROC SYSTEM_0800254FFF21
  define_system sn=YY_ICA_4FFF21

" define_source_log_group lg=TCP_IP_LOG_GROUP
" change_source_log_group lg=TCP_IP_LOG_GROUP amn=(1348 1356 1368)
  define_source_alarm_message
  define_source_alarm_message mn=(1348 1356 1368)
  define_tcp_interface
  define_udp_interface

  define_ve_interface in=PEWTER ni=768

  define_ether_trunk tn=ETHER_NET_YY
  define_ether_net tn=ETHER_NET_YY ni=0A00F(16) nn=ETHER_NET_YY
  define_ip_net in=(129 179 52 192) tn=ETHER_NET_YY sms=26 eib=TRUE
  define_ip_host ia=(129 179 52 195) ht=LOCAL

  define_ip_net in=(0 0 0 0)        ia=(129 179 52 248) hc=99 " default route
  define_ip_net in=(129 179 52 64)  ia=(129 179 52 193) hc=1
  define_ip_net in=(129 179 52 128) ia=(129 179 52 193) hc=1
  add_rip_service in=(129 179 52 0) pr=NO

  define_snmp_agent n='yy_ica_4fff21.ahse.cdc.com' l='AHSE shared lab' ..
      c='Lab Support, x3592'
"
" Change to use communication device instead of gateway.
"
  define_ip_host ia=(129 179 52 201) ht=CDC_HOST  "pewteryy"
  add_tcpip_access ia=(129 179 52 201) in=PEWTER
" define_tcpip_gw gn=GW_TCPIP_9303_121 t=GW_TCPIP_9303_121 p=(TCP UDP)

  define_tip tn=TELNET
  add_telnet_server ia=(129 179 52 201) sn=TELNET_TIP_129_179_52_201 ..
          tup=TUP_TELNET_TIP_CREC_PEWTER cct=30 cdt=0
  load_file f=TUP_TELNET_TIP_CREC_PEWTER ft=USER_PROCEDURE

" Support for OSI transfers from PEWTER to GRAY over the CLSH_BATCH_PDN "
" X.25 trunk in DI 080025100089."

  change_osi_transport enable_over_cons=true

PROCEND SYSTEM_0800254FFF21
PROC SYSTEM_0800254FFF22
  define_system sn=COS_ICA_4FFF22
  define_di_debug

" define_source_log_group lg=LAB_LOG_GROUP
  define_source_alarm_message
  change_osi_transport enable_over_cons=TRUE

  define_ve_interface in=PEWTER ni=770 "302(16)

  define_ether_trunk tn=ICA_MUX_2
  define_ether_net tn=ICA_MUX_2 nn=ICA_MUX_2 ni=0ABBB(16)

  define_ip_net  in=(129 179 53 0) sms=26 tn=ICA_MUX_2 eib=TRUE
  define_ip_host ia=(129 179 53 2) ht=LOCAL
  define_ip_net  in=(45) ia=(129 179 53 62) hc=2

  define_tcp_interface
  define_udp_interface
  define_snmp_agent n='cos_ica_4fff22.ahse.cdc.com' l='AHSE shared lab' ..
      c='Lab Support, x3592'

  define_ip_host ia=(129 179 53 1) ht=CDC_HOST
  add_tcpip_access ia=(129 179 53 1) in=PEWTER

  define_tip tn=TELNET
  add_telnet_server ia=(129 179 53 1) sn=TELNET_TIP_129_179_53_1 ..
          tup=TUP_TELNET_TIP_CREC_PEWTER cct=30 cdt=0
  load_file f=TUP_TELNET_TIP_CREC_PEWTER ft=USER_PROCEDURE

" J.P. Little commands
" Define an NSAP address prefix and size that foreign vendors can access
" Change_cdcnet_address_prefix for Interoperability and Conformance testing
"
" NOTE: subnet id changed to 4d for interop 90 9/27 by BJK.  25 used for ilab

  chacap ap='4700040025' as=14

" Define default logs/alarms and add Initialization M-E and HDLC IDs as alarms
  defsam 809..824
  defsam 657..672
  defsam 1128

" Interoperability addressing : See J.P. Little before removing any of these
" ADDNCAPS REMOVED 1991-03-28 BY BILL GAUPP -- NOT NEEDED AT 1.6.1

"BULL address:
" addncap ap='4700040025020100006242484e00' nh=((0abbb(16),'080025300557'))
"DIGITAL address:
" addncap ap='47000400250201aa0004002a1200' nh=((0abbb(16),'080025300557'))
"NIST address:
" addncap ap='4700040052020108002000336000' nh=((0abbb(16),'080025300557'))
"SUN address:
" addncap ap='4700040025020108002001635400' nh=((0abbb(16),'080025300557'))
"UNISYS address:
" addncap ap='4700040025020108000b400c6000' nh=((0abbb(16),'080025300557'))

"Remote addresses."
"NIST "
" addncap ap='470004000300030207010010AF00' nh=((0abbb(16),'080025300557'))
"SUN MHS, Mountain View, CA"
" addncap ap='4700040003000302070100AAAA00' nh=((0abbb(16),'080025300557'))
"CDC France"
" addncap ap='4700040003000302070100AAAB00' nh=((0abbb(16),'080025300557'))
"ATTMAIL"
" addncap ap='4700040003000302070100AAAC00' nh=((0abbb(16),'080025300557'))
"CDC Sweden"
" addncap ap='4700040003000302070100AAAD00' nh=((0abbb(16),'080025300557'))
"Hewlett-Packard, CA"
" addncap ap='4700040003000302070100AAAE00' nh=((0abbb(16),'080025300557'))
"IBM, Palo Alto"
" addncap ap='4700040003000302070100AAAF00' nh=((0abbb(16),'080025300557'))
"EP/IX Ransom "
" addncap ap='470004004d0002' nh=((0abbb(16),'080025300557'))
"HP "
" addncap ap='470004004D0201080009033AE701' nh=((0abbb(16),'080025300557'))
"HP ftam at interop
" addncap ap='470004004d1014'               nh=((0abbb(16),'080025300557'))
"IBM ftam at interop
" addncap ap='47000400010018'               nh=((0abbb(16),'080025300557'))

"Conformance address for Royal Transport ITS
" addncap ap='490003080020008e3efe01' nh=((0abbb(16),'080025300557'))

"Conformance address for LYNX Transport ITS
" addncap ap='49000308002001ae6afe01' nh=((0abbb(16),'08002001ae6a'))

PROCEND SYSTEM_0800254FFF22
*DECK DECK=RAM$OPEN_SHOP_TERMINAL_PROCS EXPAND=TRUE
PROC BTF_PACER_TDP_1
  DEFIOS IOSN=BTF_PRINTER CF=STATION_CONTROLLER_1 DJD=RBF PMA=DISPLAY SU=PUBLIC
  DEFINE_BATCH_DEVICE DN=PACER_PRINTER_1 CCS=BOTH PW=136 TBS=400
PROCEND BTF_PACER_TDP_1
PROC BTF_PACER_TDP_2
  DEFIOS IOSN=BTF_PRINTER CF=STATION_CONTROLLER_1 DJD=RBF PMA=DISPLAY SU=PUBLIC
  DEFINE_BATCH_DEVICE DN=PACER_PRINTER_2 CCS=BOTH PW=136 TBS=400
PROCEND BTF_PACER_TDP_2
PROC BTF_PACER_TDP_3
  DEFIOS IOSN=BTF_PRINTER CF=STATION_CONTROLLER_1 DJD=RBF PMA=DISPLAY SU=PUBLIC
  DEFINE_BATCH_DEVICE DN=PACER_PRINTER_3 CCS=BOTH PW=136 TBS=400
PROCEND BTF_PACER_TDP_3
PROC BTF_PACER_TDP_4
  DEFIOS IOSN=BTF_PRINTER CF=STATION_CONTROLLER_1 DJD=RBF PMA=DISPLAY SU=PUBLIC
  DEFINE_BATCH_DEVICE DN=PACER_PRINTER_4 CCS=BOTH PW=136 TBS=400
PROCEND BTF_PACER_TDP_4
PROC VE_ASYNC_TDP_1
  DEFIOS IOSN=VE_PRINTER CF=STATION_CONTROLLER_1 DJD=RBF PMA=DISPLAY SU=PUBLIC
  DEFINE_BATCH_DEVICE DN=ASYNC_PRINTER_1 CCS=BOTH PW=136 TBS=400 ..
    TM=ASYNC_PRINTER_WITHOUT_VFU VLO=NONE
PROCEND VE_ASYNC_TDP_1
PROC VE_ASYNC_TDP_2
  DEFIOS IOSN=VE_PRINTER CF=STATION_CONTROLLER_1 DJD=RBF PMA=DISPLAY SU=PUBLIC
  DEFINE_BATCH_DEVICE DN=ASYNC_PRINTER_2 CCS=BOTH PW=136 TBS=400 ..
    TM=ASYNC_PRINTER_WITHOUT_VFU VLO=NONE
PROCEND VE_ASYNC_TDP_2
PROC VE_ASYNC_TDP_3
  DEFIOS IOSN=VE_PRINTER CF=STATION_CONTROLLER_1 DJD=RBF PMA=DISPLAY SU=PUBLIC
  DEFINE_BATCH_DEVICE DN=ASYNC_PRINTER_3 CCS=BOTH PW=136 TBS=400 MFS=500000 ..
    TM=ASYNC_PRINTER_WITHOUT_VFU VLO=NONE
PROCEND VE_ASYNC_TDP_3
PROC VE_ASYNC_TDP_4
  DEFIOS IOSN=VE_PRINTER CF=STATION_CONTROLLER_1 DJD=RBF PMA=DISPLAY SU=PUBLIC
  DEFINE_BATCH_DEVICE DN=ASYNC_PRINTER_4 CCS=BOTH PW=136 TBS=400 MFS=500000 ..
    TM=ASYNC_PRINTER_WITHOUT_VFU VLO=NONE
PROCEND VE_ASYNC_TDP_4
PROC VE_HASP_TDP_1
  DEFTD DT=CONSOLE TBS=400
  DEFIOS IOSN=VE_PRINTER CF=STATION_CONTROLLER_1 DJD=RBF PMA=DISPLAY SU=PUBLIC
  DEFINE_BATCH_DEVICE DN=HASP_PRINTER_1 CCS=BOTH PW=136 TBS=400
PROCEND VE_HASP_TDP_1
PROC VE_HASP_TDP_2
  DEFTD DT=CONSOLE TBS=400
  DEFIOS IOSN=VE_PRINTER CF=STATION_CONTROLLER_1 DJD=RBF PMA=DISPLAY SU=PUBLIC
  DEFINE_BATCH_DEVICE DN=HASP_PRINTER_2 CCS=BOTH PW=136 TBS=400
PROCEND VE_HASP_TDP_2
PROC VE_PRIVATE_TDP_1
  DEFIOS IOSN=PRIVATE_PRINTER CF=STATION_CONTROLLER_1 DJD=RBF PMA=DISPLAY SU=PRIVATE
  DEFINE_BATCH_DEVICE DN=PRIVATE_PRINTER_1 CCS=BOTH PW=136 TBS=400
PROCEND VE_PRIVATE_TDP_1
PROC VE_PRIVATE_TDP_2
  DEFIOS IOSN=PRIVATE_PRINTER CF=STATION_CONTROLLER_1 DJD=RBF PMA=DISPLAY SU=PRIVATE
  DEFINE_BATCH_DEVICE DN=PRIVATE_PRINTER_2 CCS=BOTH PW=136 TBS=400
PROCEND VE_PRIVATE_TDP_2
PROC VE_PRIVATE_TDP_3
  DEFIOS IOSN=PRIVATE_PRINTER CF=STATION_CONTROLLER_1 DJD=RBF PMA=DISPLAY SU=PRIVATE
  DEFINE_BATCH_DEVICE DN=PRIVATE_PRINTER_3 CCS=BOTH PW=136 TBS=400
PROCEND VE_PRIVATE_TDP_3
PROC VE_PRIVATE_TDP_4
  DEFIOS IOSN=PRIVATE_PRINTER CF=STATION_CONTROLLER_1 DJD=RBF PMA=DISPLAY SU=PRIVATE
  DEFINE_BATCH_DEVICE DN=PRIVATE_PRINTER_4 CCS=BOTH PW=136 TBS=400
PROCEND VE_PRIVATE_TDP_4
PROC uri_printer_1
" This Terminal Definition Procedure (TDP) is used to configure a CDC 585      "
" printer as a public I/O station using URI/VFU (Unit Record Interface/Vertical"
" Format Unit).  This TDP should be referenced by the TDP parameter on a       "
" DEFINE_LINE command.                                                         "

" Please note the following:                                                   "

" This TDP assumes that the name of the NOS/VE Status and Control Facility     "
" is STATION_CONTROLLER_1.  If the name on your host is different, you         "
" must change the CONTROL_FACILITY parameter on the DEFINE_I_O_STATION         "
" command.                                                                     "

" By defining the VFU_LOAD_OPTION parameter to USER (default on URI printers), "
" users are allowed to specify which vfu_load_procedure they would like to     "
" use each time they send a file to be printed.  The user can do this by       "
" specifying the VLP parameter on the PRINT_FILE command.                      "

" This is an auto-configured public I/O station with an I/O station name of    "
" AUTOMATIC.  This is the default station name for NOS/VE output.              "

define_i_o_station ..
  i_o_station_name = automatic ..
  control_facility = station_controller_1

define_batch_device ..
  device_name = printer1 ..
  banner_page_count = 2 ..
  terminal_model = CDC_585V ..
  vfu_load_option = user ..
  vfu_load_procedure = vfu_cdc_585v

PROCEND uri_printer_1
*DECK DECK=RAM$OPEN_SHOP_USER_PROCS EXPAND=TRUE
PROC TUPPCR
  CHATA,EOS='}',SA=DISCARD,CFC=OFF
PROCEND TUPPCR
PROC PASSIN

" TUP for use on the 'pass-in' side of a passthrough line."
" For use on lines which support EIA flow control.  Parity=NONE to "
" match the 'pass_out' port parity.  Use only on 'pass-in' line where "
" the parity of the connected 'pass-out' line is NONE. "

change_terminal_attributes ..
  character_flow_control = off ..
  parity = none

PROCEND PASSIN
PROC CLSH_PASS

" TUP for passthrough service to the CLSH network from the COE network. "

" CHARACTER_FLOW_CONTROL=OFF AND PARITY=NONE IN ORDER TO SUPPORT "
" FULL 8-BIT DATA TRANSMISSION.  USE THIS TUP ONLY ON LINES WHICH "
" SUPPORT EIA FLOW CONTROL.  PARITY ON 'PASS-IN' PORT MUST ALSO BE "
" NONE. "

  CHANGE_TERMINAL_ATTRIBUTES RESPONSE_ACTION=DISCARD STATUS_ACTION=DISCARD
  CREATE_CONNECTION SERVICE_NAME=PASSTHROUGH
  PUT_STRING STRING='DEFPT T=CLSH_PASS' DESTINATION=CONNECTION

PROCEND CLSH_PASS
PROC VE_TELNET_TUP
  create_connection sn=nve
PROCEND VE_TELNET_TUP
*DECK DECK=RAM$OPERATE_NTF_PD EXPAND=TRUE
create_program_description (operate_ntf, opentf) ..
   l=('$system.network_transfer_facility.bound_product' ..
   '$system.batch_device_support.osf$batch_device_support') ..
   sp=nfp$operate_ntf dm=off

*DECK DECK=RAM$OPERATE_STATION EXPAND=TRUE
create_program_description (operate_station, opes) l='$system.batch_device_support.osf$batch_device_support' ..
   sp=nfp$operate_station dm=off

*DECK DECK=RAM$OPERATOR_DISPLAY_MANAGER EXPAND=TRUE
PROC operator_display_manager, opedm(status)

  create_variable (proc_status ignore_status) kind=status
  define_system_task name=operator_display_manager sp=ofp$system_display_manager ..
        automatic_restart=TRUE deactivate_task_option=prohibited idle_task_option=ignore ..
        restart_after_idle=TRUE l=osf$task_services_library ..
        tel=warning lm=$null lmo=none dm=off status=proc_status
  IF NOT proc_status.normal THEN
    IF $condition(proc_status.condition) <> 'OSE$SYSTEM_TASK_ALREADY_DEFINED' THEN
      EXIT_PROC WITH proc_status
    IFEND
  IFEND
  deactivate_system_task task_name=operator_display_manager status=ignore_status
  ignore_status = $task_status(operator_display_manager)

  activate_system_task task_name=operator_display_manager
  display_message to=job m=' ----  Operator Display Manager (OPEDM) started.'

PROCEND operator_display_manager
*DECK DECK=RAM$PACKAGE_CORRECTIONS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$package_corrections;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc rac$status_id
*copyc rac$upgrade_system_version
*copyc rae$upgrade_errors
*copyc rat$correction_package
*copyc rat$correction_package_header
*copyc rat$header_record
*copyc rat$table_version
*copyc amp$close
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc clp$get_path_description
*copyc clp$get_value
*copyc clp$push_utility
*copyc clp$scan_command_file
*copyc clp$scan_parameter_list
*copyc osp$set_status_abnormal
?? POP ??
*copyc rah$package_corrections

  VAR
    pc_utility_name: [STATIC, XDCL] ost$name := 'PACKAGE_CORRECTIONS',
    pc_prompt_string: [STATIC, XDCL] string (2) := 'PC',
    rav$correction_package_header: [STATIC, XDCL] ^rat$correction_package_header,
    rav$corp: [STATIC, XDCL] amt$segment_pointer,
    rav$elements: [STATIC, XDCL] ^rat$correction_package,
    rav$installation_table: [STATIC, XDCL] amt$local_file_name,
    rav$new_system_catalog: [STATIC, XDCL] clt$file,
    rav$old_system_catalog: [STATIC, XDCL] clt$file;

  PROGRAM rap$package_corrections (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{ pdt pack_pdt (
{   installation_table, it: file = $required
{   old_system_catalog, osc: file
{   new_system_catalog, nsc: file
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pack_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^pack_pdt_names, ^pack_pdt_params];

    VAR
      pack_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
        clt$parameter_name_descriptor := [['INSTALLATION_TABLE', 1], ['IT', 1], ['OLD_SYSTEM_CATALOG', 2],
        ['OSC', 2], ['NEW_SYSTEM_CATALOG', 3], ['NSC', 3], ['STATUS', 4]];

    VAR
      pack_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor := [

{ INSTALLATION_TABLE IT }
      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ OLD_SYSTEM_CATALOG OSC }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ NEW_SYSTEM_CATALOG NSC }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
        clc$array_not_allowed, clc$status_value]]];

?? POP ??

{ table pacc_command_list t=c s=xdcl
{ command (generate_correction, generate_corrections, genc) p=rap$generate_correction cm=xref
{ command (generate_correction_package, gencp) p=rap$write_correction_package cm=xref
{ command (prepare_element_list, preel) p=rap$prepare_element_list cm=xref
{ command (remove_correction, remove_corrections, remc) p=rap$remove_correction cm=xref
{ command (add_correction, add_corrections, addc) p=rap$add_correction cm=xref
{ command (add_psr, add_psrs, addp) p=rap$add_psrs cm=xref
{ command (display_correction_package, discp) p=rap$display_correction_package cm=proc
{ command (add_applier, adda) p=rap$add_applier cm=xref
{ command (rap$display_corrections_command) p=rap$display_corrections_command cm=xref a=hidden
{ command (rap$write_cp_to_scratch_file) p=rap$write_cp_to_scratch_file cm=xref a=hidden
{ command (quit, qui) p=rap$quit_package_corrections cm=xref

?? PUSH (LISTEXT := ON) ??
VAR
  pacc_command_list: [XDCL, READ] ^clt$command_table := ^pacc_command_list_entries,

  pacc_command_list_entries: [STATIC, READ] array [1 .. 24] of  clt$command_table_entry := [
  {} ['ADDA                           ', clc$abbreviation_entry, clc$advertised_entry, 8,
        clc$automatically_log, clc$linked_call, ^rap$add_applier],
  {} ['ADDC                           ', clc$abbreviation_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^rap$add_correction],
  {} ['ADDP                           ', clc$abbreviation_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^rap$add_psrs],
  {} ['ADD_APPLIER                    ', clc$nominal_entry, clc$advertised_entry, 8,
        clc$automatically_log, clc$linked_call, ^rap$add_applier],
  {} ['ADD_CORRECTION                 ', clc$nominal_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^rap$add_correction],
  {} ['ADD_CORRECTIONS                ', clc$alias_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^rap$add_correction],
  {} ['ADD_PSR                        ', clc$nominal_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^rap$add_psrs],
  {} ['ADD_PSRS                       ', clc$alias_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^rap$add_psrs],
  {} ['DISCP                          ', clc$abbreviation_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$proc_call, 'RAP$DISPLAY_CORRECTION_PACKAGE'],
  {} ['DISPLAY_CORRECTION_PACKAGE     ', clc$nominal_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$proc_call, 'RAP$DISPLAY_CORRECTION_PACKAGE'],
  {} ['GENC                           ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rap$generate_correction],
  {} ['GENCP                          ', clc$abbreviation_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rap$write_correction_package],
  {} ['GENERATE_CORRECTION            ', clc$nominal_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rap$generate_correction],
  {} ['GENERATE_CORRECTIONS           ', clc$alias_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rap$generate_correction],
  {} ['GENERATE_CORRECTION_PACKAGE    ', clc$nominal_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rap$write_correction_package],
  {} ['PREEL                          ', clc$abbreviation_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$prepare_element_list],
  {} ['PREPARE_ELEMENT_LIST           ', clc$nominal_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$prepare_element_list],
  {} ['QUI                            ', clc$abbreviation_entry, clc$advertised_entry, 11,
        clc$automatically_log, clc$linked_call, ^rap$quit_package_corrections],
  {} ['QUIT                           ', clc$nominal_entry, clc$advertised_entry, 11,
        clc$automatically_log, clc$linked_call, ^rap$quit_package_corrections],
  {} ['RAP$DISPLAY_CORRECTIONS_COMMAND', clc$nominal_entry, clc$hidden_entry, 9, clc$automatically_log,
         clc$linked_call, ^rap$display_corrections_command],
  {} ['RAP$WRITE_CP_TO_SCRATCH_FILE   ', clc$nominal_entry, clc$hidden_entry, 10,
        clc$automatically_log, clc$linked_call, ^rap$write_cp_to_scratch_file],
  {} ['REMC                           ', clc$abbreviation_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^rap$remove_correction],
  {} ['REMOVE_CORRECTION              ', clc$nominal_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^rap$remove_correction],
  {} ['REMOVE_CORRECTIONS             ', clc$alias_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^rap$remove_correction]];

  PROCEDURE [XREF] rap$add_applier (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$add_correction (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$add_psrs (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$display_corrections_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$generate_correction (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$prepare_element_list (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$quit_package_corrections (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$remove_correction (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$write_correction_package (parameter_list: clt$parameter_list;
    VAR status: ost$status);

  PROCEDURE [XREF] rap$write_cp_to_scratch_file (parameter_list: clt$parameter_list;
    VAR status: ost$status);

?? POP ??

    VAR
      access_sel: amt$file_access_selections,
      corp_fid: amt$file_identifier,
      corp_lfn: amt$local_file_name,
      cycle_sel: clt$cycle_selector,
      file_ref: clt$file_reference,
      inst_fid: amt$file_identifier,
      install_header: ^rat$header_record,
      install_table: amt$segment_pointer,
      it_path: clt$path_name,
      open_p: clt$open_position,
      path: ^pft$path,
      path_container: clt$path_container,
      value: clt$value,
      version: ^rat$table_version;


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, pack_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('INSTALLATION_TABLE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    rav$installation_table := value.file.local_file_name;

    clp$get_path_description (value.file, file_ref, path_container, path, cycle_sel, open_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    it_path := file_ref.path_name (1, file_ref.path_name_size);

    PUSH access_sel: [1 .. 1];
    access_sel^ [1].key := amc$access_mode;
    access_sel^ [1].access_mode := $pft$usage_selections [pfc$read];

    amp$open (rav$installation_table, amc$segment, access_sel, inst_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (inst_fid, amc$sequence_pointer, install_table, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET install_table.sequence_pointer;
    NEXT version IN install_table.sequence_pointer;
    IF version = NIL THEN
      osp$set_status_abnormal (rac$status_id, rae$file_not_installation_table, it_path, status);
      RETURN;
    IFEND;
    NEXT install_header IN install_table.sequence_pointer;
    IF (install_header = NIL) OR (install_header^.title <> ' INSTALLATION TABLE') THEN
      osp$set_status_abnormal (rac$status_id, rae$file_not_installation_table, it_path, status);
      RETURN;
    IFEND;

    IF version^ <> rac$upgrade_system_version THEN
      osp$set_status_abnormal (rac$status_id, rae$invalid_table_version, it_path, status);
      RETURN;
    IFEND;

    clp$get_value ('OLD_SYSTEM_CATALOG', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      rav$old_system_catalog := value.file;
    IFEND;

    clp$get_value ('NEW_SYSTEM_CATALOG', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.kind <> clc$unknown_value THEN
      rav$new_system_catalog := value.file;
    IFEND;

    corp_lfn := 'current_correction_package';
    amp$open (corp_lfn, amc$segment, NIL, corp_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (corp_fid, amc$sequence_pointer, rav$corp, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET rav$corp.sequence_pointer;
    NEXT rav$correction_package_header IN rav$corp.sequence_pointer;
    IF rav$correction_package_header = NIL THEN
      osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, corp_lfn, status);
      RETURN;
    IFEND;

    rav$correction_package_header^.identification := rac$correction_package_id;
    rav$correction_package_header^.version := rac$correction_package_version;
    rav$correction_package_header^.size_of_applier := 0;
    NEXT rav$elements: [1 .. install_header^.number_of_files] IN rav$corp.sequence_pointer;
    IF rav$elements = NIL THEN
      osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, corp_lfn, status);
      RETURN;
    IFEND;

    rav$correction_package_header^.number_of_elements := 0;

    amp$close (inst_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$push_utility (pc_utility_name, clc$global_command_search, pacc_command_list, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_command_file (clc$current_command_input, pc_utility_name, pc_prompt_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
  PROCEND rap$package_corrections;
MODEND ram$package_corrections;
*DECK DECK=RAM$PACKAGE_SOFTWARE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: PACKAGE_SOFTWARE Utility Command.' ??
MODULE ram$package_software;

{ PURPOSE:
{   This module contains the procedure to set up and control the
{   software packing process.
{
{ DESIGN:
{   This module contains the command table and pdt for package software.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rat$scratch_segment
?? POP ??
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$scan_parameter_list
*copyc clp$scan_command_file
*copyc mmp$create_scratch_segment
*copyc mmp$create_segment
*copyc mmp$delete_scratch_segment
*copyc mmp$delete_segment
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osv$control_codes_to_quest_mark

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    rav$pacs_scratch_segment: [XDCL] rat$scratch_segment;

  VAR
    rav$pacs_utility_name: [XDCL] ost$name := 'PACKAGE_SOFTWARE';

?? TITLE := '[XDCL] rap$package_software', EJECT ??

{ PURPOSE:
{   This procedure sets up the environment for package_software.
{
{
{   RAV$PACS_SCRATCH_SEGMENT is created so that other procedures
{   within PACS will not all have to create their own scratch
{   segment.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$package_software
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt pacs_pdt (
{   status    : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    pacs_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^pacs_pdt_names, ^pacs_pdt_params];

  VAR
    pacs_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
      clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    pacs_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??


{ table n=pacs_command_table t=command s=xdcl
{ command n=(apply_object_correction, appoc) p=rap$apply_object_correction_cmd cm=xref a=hidden
{ command n=(checksum_file, chef) p=rap$checksum_file_command cm=xref a=hidden
{ command n=(create_order_definition, create_order_definitions, creod)   p=rap$create_order_definition     ..
{                     cm=xref
{ command n=(create_subproduct_correction, cresc) p=rap$create_subproduct_corr cm=xref
{ command n=(define_subproduct, defs) p=rap$define_subproduct cm=xref
{ command n=(display_packing_list, displ) p=rap$display_packing_list_pacs cm=xref
{ command n=(generate_object_correction, genoc)   p=rap$generate_object_corr_cmd cm=xref a=hidden
{ command n=(display_subproduct_information, dissi)   p=rap$display_subproduct_info cm=xref
{ command n=(load_packing_list, loapl) p=rap$load_packing_list_pacs_cmd   cm=xref
{ command n=(quit, qui) p=rap$quit_pacs cm=xref
{ command n=(read_tailored_file, reatf) p=rap$read_tailored_file cm=xref
{ command n=(verify_subproduct, vers) p=rap$verify_subproduct_command cm=xref
{ command n=(write_order, wrio) p=rap$write_order cm=proc
{ command n=(rap$write_disk_order) p=rap$write_disk_order cm=proc a=hidden
{ command n=(rap$write_tape_order) p=rap$write_tape_order cm=proc a=hidden
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  pacs_command_table: [XDCL, READ] ^clt$command_table := ^pacs_command_table_entries,

  pacs_command_table_entries: [STATIC, READ] array [1 .. 29] of clt$command_table_entry := [
  {} ['APPLY_OBJECT_CORRECTION        ', clc$nominal_entry, clc$hidden_entry, 1, clc$automatically_log,
         clc$linked_call, ^rap$apply_object_correction_cmd],
  {} ['APPOC                          ', clc$abbreviation_entry, clc$hidden_entry, 1,
        clc$automatically_log, clc$linked_call, ^rap$apply_object_correction_cmd],
  {} ['CHECKSUM_FILE                  ', clc$nominal_entry, clc$hidden_entry, 2, clc$automatically_log,
         clc$linked_call, ^rap$checksum_file_command],
  {} ['CHEF                           ', clc$abbreviation_entry, clc$hidden_entry, 2,
        clc$automatically_log, clc$linked_call, ^rap$checksum_file_command],
  {} ['CREATE_ORDER_DEFINITION        ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$create_order_definition],
  {} ['CREATE_ORDER_DEFINITIONS       ', clc$alias_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$create_order_definition],
  {} ['CREATE_SUBPRODUCT_CORRECTION   ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^rap$create_subproduct_corr],
  {} ['CREOD                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^rap$create_order_definition],
  {} ['CRESC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^rap$create_subproduct_corr],
  {} ['DEFINE_SUBPRODUCT              ', clc$nominal_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^rap$define_subproduct],
  {} ['DEFS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^rap$define_subproduct],
  {} ['DISPL                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^rap$display_packing_list_pacs],
  {} ['DISPLAY_PACKING_LIST           ', clc$nominal_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^rap$display_packing_list_pacs],
  {} ['DISPLAY_SUBPRODUCT_INFORMATION ', clc$nominal_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^rap$display_subproduct_info],
  {} ['DISSI                          ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^rap$display_subproduct_info],
  {} ['GENERATE_OBJECT_CORRECTION     ', clc$nominal_entry, clc$hidden_entry, 7, clc$automatically_log,
         clc$linked_call, ^rap$generate_object_corr_cmd],
  {} ['GENOC                          ', clc$abbreviation_entry, clc$hidden_entry, 7,
        clc$automatically_log, clc$linked_call, ^rap$generate_object_corr_cmd],
  {} ['LOAD_PACKING_LIST              ', clc$nominal_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^rap$load_packing_list_pacs_cmd],
  {} ['LOAPL                          ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^rap$load_packing_list_pacs_cmd],
  {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^rap$quit_pacs],
  {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^rap$quit_pacs],
  {} ['RAP$WRITE_DISK_ORDER           ', clc$nominal_entry, clc$hidden_entry, 14,
        clc$automatically_log, clc$proc_call, 'RAP$WRITE_DISK_ORDER'],
  {} ['RAP$WRITE_TAPE_ORDER           ', clc$nominal_entry, clc$hidden_entry, 15,
        clc$automatically_log, clc$proc_call, 'RAP$WRITE_TAPE_ORDER'],
  {} ['READ_TAILORED_FILE             ', clc$nominal_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^rap$read_tailored_file],
  {} ['REATF                          ', clc$abbreviation_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^rap$read_tailored_file],
  {} ['VERIFY_SUBPRODUCT              ', clc$nominal_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^rap$verify_subproduct_command],
  {} ['VERS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^rap$verify_subproduct_command],
  {} ['WRIO                           ', clc$abbreviation_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$proc_call, 'RAP$WRITE_ORDER'],
  {} ['WRITE_ORDER                    ', clc$nominal_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$proc_call, 'RAP$WRITE_ORDER']];

  PROCEDURE [XREF] rap$apply_object_correction_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$checksum_file_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$create_order_definition
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$create_subproduct_corr
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$define_subproduct
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$display_packing_list_pacs
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$display_subproduct_info
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$generate_object_corr_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$load_packing_list_pacs_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$quit_pacs
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$read_tailored_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rap$verify_subproduct_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??


    VAR
      local_status: ost$status,
      scratch_segment_pointer: amt$segment_pointer;


?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF scratch_segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (scratch_segment_pointer, ignore_status);
        scratch_segment_pointer.sequence_pointer := NIL;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, pacs_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    scratch_segment_pointer.kind := amc$sequence_pointer;
    scratch_segment_pointer.sequence_pointer := NIL;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, scratch_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      rav$pacs_scratch_segment.sequence_p := scratch_segment_pointer.sequence_pointer;
      RESET rav$pacs_scratch_segment.sequence_p;

      clp$push_utility (rav$pacs_utility_name, clc$global_command_search, pacs_command_table, NIL, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      clp$scan_command_file (clc$current_command_input, rav$pacs_utility_name, 'PACS', status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      clp$pop_utility (status);

    END /main/;

    IF scratch_segment_pointer.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (scratch_segment_pointer, local_status);
      scratch_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$package_software;

MODEND ram$package_software;
*DECK DECK=RAM$PACS_MESSAGES$US_ENGLISH EXPAND=TRUE
CREATE_MESSAGE_MODULE ram$pacs_messages$us_english


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This deck contains the command calls to create the package software
"   messages module.
"
" DESIGN:
"   The function of a message module is to provide help for a user executing
"   commands interactively.  Therefore the kinds of messages found in a
"   message module reflect that purpose.  In setting up messages to display
"   using message module technology the parameter prompt messages are used
"   as the displaying messages.
*IFEND

CREATE_PARAMETER_PROMPT_MESSAGE n=backup_complete
+N +P1 backed up to +P2.
**

CREATE_PARAMETER_PROMPT_MESSAGE n=deleted_catalog
+N Deleted +P1.
**

END_MESSAGE_MODULE

*DECK DECK=RAM$PERFORM_INSTALLATION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$PERFORM_INSTALLATION subcommand.' ??
MODULE ram$perform_installation;

{ PURPOSE:
{   This module contains the interface that performs the installation
{   defined by an installation control file.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rat$installation_control_record
*copyc rat$path
?? POP ??
*copyc clp$evaluate_parameters
*copyc fsp$close_file
*copyc mmp$delete_scratch_segment
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc rap$init_processing_seq_fr_file
*copyc rap$perform_installation_steps
*copyc rav$installation_defaults
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$perform_installation', EJECT ??

{ PURPOSE:
{   This interface installs the subproducts assigned to the specified job as
{   defined by the installation control file.  This interface is used in
{   batch processing.  The subproducts may be of any type.
{
{ DESIGN:
{   The installation control record is re-established for the execution of
{   the installation steps.  The installation control file contains a
{   copy of the processing sequence that was originally created prior to
{   submitting the batch job in which this interface is executing.  The
{   processing sequence is re-created from the installation control file and
{   the packing list is re-accessed.
{
{   The global rav$installation_defaults are reset to the values from the
{   installation control file.  This will put the INSTALL_SOFTWARE
{   environment for this batch job in agreement with the INSTALL_SOFTWARE
{   environment established in the originator job.
{
{   The job identifier that was passed in identifies the job and will guide
{   the step processing to perform only the work assigned to this job.
{
{   Once the installation control record is re-established the installation
{   steps are executed.
{
{ NOTES:
{   On the call to RAP$PERFORM_INSTALLATION_STEPS the log is not saved
{   because in this instance it is being called from a batch job and the
{   entire batch job log is already being saved.
{

  PROCEDURE [XDCL] rap$perform_installation
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE peri_pdt (
{   installation_control_file, icf: file = $required
{   job_identifier, ji: name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 6, 29, 15, 48, 52, 12], clc$command, 5, 3, 2, 0, 0, 0, 3, 'INSP_PDT'],
            [['ICF                            ', clc$abbreviation_entry, 1],
            ['INSTALLATION_CONTROL_FILE      ', clc$nominal_entry, 1],
            ['JI                             ', clc$abbreviation_entry, 2],
            ['JOB_IDENTIFIER                 ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3]], [
{ PARAMETER 1
      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],
{ PARAMETER 3
      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$file_type]],
{ PARAMETER 2
      [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 3
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$installation_control_file = 1,
      p$job_identifier = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      packing_list_opened: boolean,
      installation_control_record: rat$installation_control_record,
      local_status: ost$status,
      packing_list_fid: amt$file_identifier,
      processing_segment_pointer: amt$segment_pointer;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to return the processing
{   segment and packing list file when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;


      IF processing_segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (processing_segment_pointer, ignore_status);
        processing_segment_pointer.sequence_pointer := NIL;
      IFEND;

      fsp$close_file (packing_list_fid, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    installation_control_record.job_identifier := pvt [p$job_identifier].value^.name_value;
    installation_control_record.job_status_record_p := NIL;

    processing_segment_pointer.kind := amc$sequence_pointer;
    processing_segment_pointer.sequence_pointer := NIL;
    packing_list_opened := FALSE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      rap$init_processing_seq_fr_file (pvt [p$installation_control_file].value^.file_value^,
            installation_control_record, processing_segment_pointer, packing_list_fid, packing_list_opened,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rav$installation_defaults := installation_control_record.processing_header_p^.installation_defaults;

      rap$perform_installation_steps (installation_control_record, status);

    END /main/;

    IF packing_list_opened THEN
      fsp$close_file (packing_list_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF processing_segment_pointer.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (processing_segment_pointer, local_status);
      processing_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$perform_installation;
MODEND ram$perform_installation;
*DECK DECK=RAM$PERFORM_INSTALLATION_STEPS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$PERFORM_INSTALLATION_STEPS Interface.' ??
MODULE ram$perform_installation_steps;

{ PURPOSE:
{   This module contains the interface and procedures that perform
{   the installation steps.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc rac$inss_processor_version
*copyc rac$summary_file_level
*copyc rac$summary_file_name
*copyc rae$install_software_cc
*copyc rat$installation_control_record
*copyc rat$processing_summary_types
?? POP ??
*copyc amp$flush
*copyc amp$get_segment_pointer
*copyc clp$get_system_file_id
*copyc clp$put_job_command_response
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc rap$activate_products
*copyc rap$convert_job_record_to_strs
*copyc rap$correct_products
*copyc rap$delete_previous_cycles
*copyc rap$execute_installer_procs
*copyc rap$load_products
*copyc rap$reconcile_cycle_conflicts
*copyc rap$stage_products
*copyc rap$update_directory
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$perform_installation_steps', EJECT ??

{ PURPOSE:
{   This interface performs the installation steps as required by the
{   installation control record.
{
{ DESIGN:
{   This interface contains the calls to the installation steps.  Before
{   the steps are performed, the processing summary file is opened and the
{   job status record for this job is located.  A pointer to the job status
{   record is set in the installation control record.  Each step will
{   record processing status into this record.
{
{   The job status record only shows the status at the instant the status
{   record is read.  The processing summary file (and the job status
{   records) are to be read by the DISPLAY_PROCESSING_SUMMARY command for a
{   state of the processing report.
{
{ NOTES:
{   The status variable on each of the processing step interfaces does not
{   return success or failure of the step.  It is used to indicate failure
{   outside of normal processing.  Success or failure of each step shows up
{   in the job logs.
{
{   A scratch segment is setup to provide any subsequently called interface
{   or procedure a place to do scratch work without having to create their
{   own segments.
{

  PROCEDURE [XDCL] rap$perform_installation_steps
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      called_from_package_software: boolean,
      file_opened: boolean,
      ignore_status: ost$status,
      local_status: ost$status,
      subproducts_failed_processing: boolean,
      scratch_segment_pointer: amt$segment_pointer,
      summary_file_fid: amt$file_identifier;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to close the scratch segment
{   and the processing summary file when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;


      IF scratch_segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (scratch_segment_pointer, ignore_status);
        scratch_segment_pointer.sequence_pointer := NIL;
      IFEND;

      fsp$close_file (summary_file_fid, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    subproducts_failed_processing := FALSE;
    called_from_package_software := FALSE;
    scratch_segment_pointer.kind := amc$sequence_pointer;
    scratch_segment_pointer.sequence_pointer := NIL;
    file_opened := FALSE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, scratch_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      installation_control_record.scratch_seq_p := scratch_segment_pointer.sequence_pointer;

      open_processing_summary_file (installation_control_record, summary_file_fid, file_opened, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      display_installing_message (installation_control_record.job_status_record_p^, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$reconcile_cycle_conflicts (installation_control_record, subproducts_failed_processing, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$load_products (called_from_package_software, installation_control_record,
            subproducts_failed_processing, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$correct_products (installation_control_record, subproducts_failed_processing, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$stage_products (installation_control_record, subproducts_failed_processing, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$activate_products (installation_control_record, subproducts_failed_processing, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$execute_installer_procs (installation_control_record, subproducts_failed_processing, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$update_directory (installation_control_record, subproducts_failed_processing, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$delete_previous_cycles (installation_control_record, subproducts_failed_processing, status);

    END /main/;

    IF status.normal AND subproducts_failed_processing THEN
      osp$set_status_abnormal ('RA', rae$subproducts_failed_install, '', status);
    IFEND;

    IF file_opened THEN
      fsp$close_file (summary_file_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF scratch_segment_pointer.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (scratch_segment_pointer, local_status);
      scratch_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$perform_installation_steps;

?? OLDTITLE ??
?? NEWTITLE := 'display_installing_message', EJECT ??

{ PURPOSE:
{   This procedure displays the start of installing message to $RESPONSE.
{
{ DESIGN:
{   The installing message is formatted as follows:
{
{     Installing <a> subproducts (<b> steps).
{
{   where:
{     <a> is the initial subproduct count.
{     <b> is the number of steps.
{
{   As an example the following status line could be created:
{
{    "Installing 10 subproducts (7 steps)"
{
{   The information to be displayed comes from the job status record.
{   The record is first converted to string values for displaying.
{
{ NOTES:
{   The $RESPONSE output buffer must be flushed to get the line to display
{   immediately.
{

  PROCEDURE display_installing_message
    (    job_status_record: rat$job_status_record;
     VAR status: ost$status);


    VAR
      length: integer,
      line: string (osc$max_string_size),
      job_status_strs: rat$job_status_record_strs,
      response_fid: amt$file_identifier;


    status.normal := TRUE;

    rap$convert_job_record_to_strs (job_status_record, job_status_strs, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (line, length, '0Installing ', job_status_strs.initial_subproduct_count.
          value (1, job_status_strs.initial_subproduct_count.size), ' subproducts (',
          job_status_strs.number_of_steps.value (1, job_status_strs.number_of_steps.size), ' steps).');

    clp$put_job_command_response (line (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_system_file_id (clc$job_command_response, response_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$flush (response_fid, osc$nowait, status);

  PROCEND display_installing_message;

?? OLDTITLE ??
?? NEWTITLE := 'open_processing_summary_file', EJECT ??

{ PURPOSE:
{   This procedure opens the processing summary file for the current
{   installation event.
{
{ DESIGN:
{   The processing summary file is opened as a read modify segment access
{   file and the file is validated as being the processing summary file.
{   The job status record for this job is located and a pointer is set in
{   the installation control record.
{
{   When the job status record pointer (from the installation control
{   record) is not nil, the record is already established and the processing
{   summary file is not opened.
{
{   The file must be closed by the calling procedure.
{
{ NOTES:
{

  PROCEDURE open_processing_summary_file
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR summary_file_fid: amt$file_identifier;
     VAR file_opened: boolean;
     VAR status: ost$status);


    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      found: boolean,
      installation_identifier_catalog: rat$path,
      job_status_record_p: ^rat$job_status_record,
      segment_pointer: amt$segment_pointer,
      sequence_descriptor_p: ^rat$sequence_descriptor,
      summary_file: rat$path,
      summary_file_header_p: ^rat$processing_summary_header,
      summary_file_seq_p: ^rat$processing_summary_sequence;


    status.normal := TRUE;

    IF installation_control_record.job_status_record_p <> NIL THEN
      RETURN;
    IFEND;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options [fsc$read, fsc$modify];
    attachment_options [1].share_modes.selector := fsc$specific_share_modes;
    attachment_options [1].share_modes.value := $fst$file_access_options [fsc$read, fsc$modify];
    attachment_options [2].selector := fsc$create_file;
    attachment_options [2].create_file := FALSE;
    attachment_options [3].selector := fsc$wait_for_attachment;
    attachment_options [3].wait_for_attachment.wait := osc$wait;
    attachment_options [3].wait_for_attachment.wait_time := fsc$longest_wait_time;

{ Assemble the path to the processing summary file using the installation logs path,
{ the installation identifier and the processing summary file name.

    STRINGREP (installation_identifier_catalog.path, installation_identifier_catalog.size,
          installation_control_record.processing_header_p^.installation_defaults.installation_logs.
          path (1, installation_control_record.processing_header_p^.installation_defaults.installation_logs.
          size), '.', installation_control_record.processing_header_p^.
          installation_identifier (1, clp$trimmed_string_size
          (installation_control_record.processing_header_p^.installation_identifier)));

    STRINGREP (summary_file.path, summary_file.size, installation_identifier_catalog.
          path (1, installation_identifier_catalog.size), '.', rac$summary_file_name);

    file_opened := TRUE;
    fsp$open_file (summary_file.path (1, summary_file.size), amc$segment, ^attachment_options, NIL, NIL, NIL,
          NIL, summary_file_fid, status);
    IF NOT status.normal THEN
      file_opened := FALSE;
      RETURN;
    IFEND;

    amp$get_segment_pointer (summary_file_fid, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    summary_file_seq_p := segment_pointer.sequence_pointer;

    RESET summary_file_seq_p;
    NEXT sequence_descriptor_p IN summary_file_seq_p;
    IF sequence_descriptor_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$unexpected_eof_summary_file, rac$summary_file_name, status);
      osp$append_status_file (osc$status_parameter_delimiter, installation_identifier_catalog.
            path (1, installation_identifier_catalog.size), status);
      RETURN;
    IFEND;

    NEXT summary_file_header_p IN summary_file_seq_p;
    IF summary_file_header_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$unexpected_eof_summary_file, rac$summary_file_name, status);
      osp$append_status_file (osc$status_parameter_delimiter, installation_identifier_catalog.
            path (1, installation_identifier_catalog.size), status);
      RETURN;
    IFEND;

    found := FALSE;

    WHILE NOT found DO
      NEXT job_status_record_p IN summary_file_seq_p;
      IF job_status_record_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$unexpected_eof_summary_file, rac$summary_file_name, status);
        osp$append_status_file (osc$status_parameter_delimiter, installation_identifier_catalog.
              path (1, installation_identifier_catalog.size), status);
        RETURN;
      IFEND;

      IF job_status_record_p^.job_identifier = installation_control_record.job_identifier THEN
        installation_control_record.job_status_record_p := job_status_record_p;
        found := TRUE;
      IFEND;
    WHILEND;

  PROCEND open_processing_summary_file;
MODEND ram$perform_installation_steps;
*DECK DECK=RAM$PREPARE_ELEMENT_LIST EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$prepare_element_list;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc amv$nil_file_identifier
*copyc rac$status_id
*copyc rae$error_messages
*copyc rat$file_values
*copyc rat$table_version
*copyc rat$header_record
*copyc rat$installation_table
*copyc rat$element_descriptor
*copyc rat$open_file_list
*copyc rav$correction_package_header
*copyc rav$format_types
*copyc rav$installation_table
*copyc rav$new_system_catalog
*copyc rav$old_system_catalog
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc clp$convert_string_to_file
*copyc clp$get_path_description
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc rap$build_element_list
*copyc rap$issue_message
*copyc oss$job_paged_literal
*copyc cli$compare_display_file_input
?? POP ??
?? OLDTITLE ??
?? TITLE := '  rap$prepare_element_list' ??

*copyc rah$prepare_element_list
{  Global variable declarations. }

  VAR
    file_control: clt$get_control_record,
    with_control: clt$get_control_record;

  PROCEDURE [XDCL] rap$prepare_element_list (parameter_list: clt$parameter_list;
    VAR status: ost$status);


{   pdt preel_pdt (
{     previous_system_catalog, psc: file
{     element_list, el: file = $output
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    preel_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^preel_pdt_names, ^preel_pdt_params
      ];

  VAR
    preel_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['PREVIOUS_SYSTEM_CATALOG', 1], ['PSC', 1], ['ELEMENT_LIST', 2], ['EL'
      , 2], ['STATUS', 3]];

  VAR
    preel_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ PREVIOUS_SYSTEM_CATALOG PSC }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ ELEMENT_LIST EL }
    [[clc$optional_with_default, ^preel_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    preel_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$output';

?? POP ??
?? TITLE := '    abort_handler', EJECT ??

    PROCEDURE abort_handler (condition: pmt$condition;
          condition_information: ^pmt$condition_information;
          save_area: ^ost$stack_frame_save_area;
      VAR handler_status: ost$status);


      IF file_control.file_id <> amv$nil_file_identifier THEN
        clp$close_for_get (file_control, handler_status);
      IFEND;
      IF with_control.file_id <> amv$nil_file_identifier THEN
        clp$close_for_get (with_control, handler_status);
      IFEND;

      handler_status.normal := TRUE;

    PROCEND abort_handler;

?? TITLE := '  rap$prepare_element_list', EJECT ??

    VAR
      byte_address: amt$file_byte_address,
      compare: boolean,
      cs: clt$cycle_selector,
      element_list: ^array [1 .. * ] of rat$element_descriptor,
      i: rat$element_index,
      ignore_status: ost$status,
      last: rat$element_index,
      length: integer,
      list_file: amt$local_file_name,
      list_fid: amt$file_identifier,
      message_status: ost$status,
      new_cat_ref: clt$file_reference,
      new_file: clt$file,
      op: clt$open_position,
      parameter_specified: boolean,
      path: ^pft$path,
      path_name: clt$path_name,
      pc: clt$path_container,
      previous_cat_ref: clt$file_reference,
      previous_file: clt$file,
      previous_system_catalog: clt$file,
      response_file: [STATIC] amt$local_file_name := '$RESPONSE                      ',
      value: clt$value,
      write_attachment: array [1 .. 2] of fst$attachment_option;


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, preel_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$test_parameter ('PREVIOUS_SYSTEM_CATALOG', parameter_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF parameter_specified THEN
      clp$get_value ('PREVIOUS_SYSTEM_CATALOG', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      previous_system_catalog := value.file;
    ELSE
      previous_system_catalog := rav$old_system_catalog;
    IFEND;

    clp$get_path_description (previous_system_catalog, previous_cat_ref, pc, path, cs, op, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_path_description (rav$new_system_catalog, new_cat_ref, pc, path, cs, op, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('ELEMENT_LIST', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    list_file := value.file.local_file_name;


    get_element_list (element_list, last, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_control.file_id := amv$nil_file_identifier;
    #spoil (file_control);
    with_control.file_id := amv$nil_file_identifier;
    #spoil (with_control);
    osp$establish_block_exit_hndlr (^abort_handler);

  /prepare_list/
    BEGIN

      FOR i := 1 TO last DO

        STRINGREP (path_name, length, previous_cat_ref.path_name (1, previous_cat_ref.path_name_size), '.',
              element_list^ [i].name);
        clp$convert_string_to_file (path_name (1, length), previous_file, status);
        IF NOT status.normal THEN
          EXIT /prepare_list/;
        IFEND;

        STRINGREP (path_name, length, new_cat_ref.path_name (1, new_cat_ref.path_name_size), '.',
              element_list^ [i].name);
        clp$convert_string_to_file (path_name (1, length), new_file, status);
        IF NOT status.normal THEN
          EXIT /prepare_list/;
        IFEND;

        compare := TRUE;

        compare_elements (previous_file.local_file_name, new_file.local_file_name, compare,
              message_status);
        IF NOT message_status.normal THEN
          rap$issue_message (response_file, message_status, status);
          IF NOT status.normal THEN
            EXIT /prepare_list/;
          IFEND;
        IFEND;

        IF compare THEN
          element_list^ [i].name := osc$null_name;
        IFEND;

      FOREND;


      {  Open the ELEMENT LIST FILE for write access and put the names of elements }
      {  that did not compare into it.                                             }

      write_attachment [1].selector := fsc$access_and_share_modes;
      write_attachment [1].access_modes.selector := fsc$specific_access_modes;
      write_attachment [1].access_modes.value := $fst$file_access_options [fsc$read, fsc$shorten, fsc$append,
            fsc$modify];
      write_attachment [1].share_modes.selector := fsc$determine_from_access_modes;
      write_attachment [2].selector := fsc$create_file;
      write_attachment [2].create_file := TRUE;

      fsp$open_file (list_file, amc$record, ^write_attachment, NIL, NIL, NIL, NIL, list_fid, status);
      IF NOT status.normal THEN
        EXIT /prepare_list/;
      IFEND;

    /output_list/
      FOR i := 1 TO last DO
        IF element_list^ [i].name <> osc$null_name THEN
          amp$put_next (list_fid, ^element_list^ [i].name, #SIZE (element_list^ [i].name), byte_address,
                status);
          IF NOT status.normal THEN
            EXIT /output_list/;
          IFEND;
        IFEND;
      FOREND /output_list/;

      IF status.normal THEN
        fsp$close_file (list_fid, status);
      ELSE
        fsp$close_file (list_fid, ignore_status);
      IFEND;
      IF NOT status.normal THEN
        EXIT /prepare_list/;
      IFEND;

    END /prepare_list/;

    FREE element_list;

    osp$disestablish_cond_handler;

  PROCEND rap$prepare_element_list;

?? TITLE := '  compare_elements', EJECT ??

  PROCEDURE compare_elements (file: amt$local_file_name;
        with: amt$local_file_name;
    VAR compare: boolean;
    VAR status: ost$status);


    TYPE
      word_set = set of 0 .. 63,

      comparer = record
        case 1 .. 3 of
        = 1 =
          word: word_set,
        = 2 =
          digits: packed array [0 .. 15] of 0 .. 15,
        = 3 =
          bytes: packed array [1 .. bytes_per_word] of cell,
        casend,
      recend;

    VAR
      current_byte_address: amt$file_byte_address,
      file_buffer_required: boolean,
      file_position: amt$file_position,
      file_transfer_count: amt$transfer_count,
      file_transfer_word: ^comparer,
      i: 0 .. clc$max_value_sets,
      ignore_status: ost$status,
      with_buffer_required: boolean,
      with_position: amt$file_position,
      with_transfer_count: amt$transfer_count,
      with_transfer_word: ^comparer,
      word_from_file: comparer,
      word_from_with: comparer;

    CONST
      bytes_per_word = 8;


    status.normal := TRUE;

    clp$open_for_get (file, 'PREPARE_ELEMENT_LIST', FALSE, file_position, file_control,
          file_buffer_required, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$open_for_get (with, 'PREPARE_ELEMENT_LIST', FALSE, with_position, with_control,
          with_buffer_required, status);
    IF NOT status.normal THEN
      clp$close_for_get (file_control, ignore_status);
      RETURN;
    IFEND;

    IF file_buffer_required THEN
      ALLOCATE file_control.sequence_pointer: [[REP clc$input_buffer_size OF cell]];
      #spoil (file_control);
    IFEND;
    IF with_buffer_required THEN
      ALLOCATE with_control.sequence_pointer: [[REP clc$input_buffer_size OF cell]];
      #spoil (with_control);
    IFEND;

    compare := TRUE;
    file_transfer_count := 0;
    with_transfer_count := 0;

  /compare_loop/
    WHILE (file_position < amc$eoi) AND (with_position < amc$eoi) DO
      clp$get_next_bytes (bytes_per_word, file_transfer_count, file_position, file_control,
            file_transfer_word, status);
      IF NOT status.normal THEN
        EXIT /compare_loop/;
      IFEND;
      clp$get_next_bytes (bytes_per_word, with_transfer_count, with_position, with_control,
            with_transfer_word, status);
      IF NOT status.normal THEN
        EXIT /compare_loop/;
      IFEND;
      IF file_transfer_count <> with_transfer_count THEN
        compare := FALSE;
        EXIT /compare_loop/;
      IFEND;

      IF file_transfer_count = 0 THEN
        EXIT /compare_loop/;
      ELSEIF file_transfer_count < bytes_per_word THEN
        word_from_file.word := $word_set [];
        word_from_with.word := $word_set [];
        FOR i := 1 TO file_transfer_count DO
          word_from_file.bytes [i] := file_transfer_word^.bytes [i];
          word_from_with.bytes [i] := with_transfer_word^.bytes [i];
        FOREND;
      ELSE
        word_from_file.word := file_transfer_word^.word;
        word_from_with.word := with_transfer_word^.word;
      IFEND;

      IF word_from_file.word <> word_from_with.word THEN
        compare := FALSE;
        EXIT /compare_loop/;
      IFEND;

      current_byte_address := current_byte_address + bytes_per_word;
    WHILEND /compare_loop/;

    IF file_position <> with_position THEN
      compare := FALSE;
    IFEND;


    IF status.normal THEN
      clp$close_for_get (file_control, status);
    ELSE
      clp$close_for_get (file_control, ignore_status);
    IFEND;
    IF status.normal THEN
      clp$close_for_get (with_control, status);
    ELSE
      clp$close_for_get (with_control, ignore_status);
    IFEND;

    IF file_buffer_required THEN
      FREE file_control.sequence_pointer;
      #spoil (file_control);
    IFEND;
    IF with_buffer_required THEN
      FREE with_control.sequence_pointer;
      #spoil (with_control);
    IFEND;

  PROCEND compare_elements;

?? TITLE := '  get_element_list', EJECT ??

  PROCEDURE get_element_list (VAR element_list: ^array [1 .. * ] OF rat$element_descriptor;
    VAR last: rat$element_index;
    VAR status: ost$status);

    VAR
      element_list_allocated: boolean,
      key_all: [STATIC] ost$name := 'ALL                            ',
      ignore_status: ost$status,
      read_only_attachment: array [1 .. 2] of fst$attachment_option,
      table: ^rat$installation_table,
      table_fid: amt$file_identifier,
      table_header: ^rat$header_record,
      table_ptr: amt$segment_pointer,
      table_version: ^rat$table_version;


{   A list is built using the installation table, of all the elements to be compared. }

    status.normal := TRUE;
    element_list_allocated := FALSE;

  /get_list/
    BEGIN

      read_only_attachment [1].selector := fsc$access_and_share_modes;
      read_only_attachment [1].access_modes.selector := fsc$specific_access_modes;
      read_only_attachment [1].access_modes.value := $fst$file_access_options [fsc$read];
      read_only_attachment [1].share_modes.selector := fsc$determine_from_access_modes;
      read_only_attachment [2].selector := fsc$create_file;
      read_only_attachment [2].create_file := FALSE;

      fsp$open_file (rav$installation_table, amc$segment, ^read_only_attachment, NIL, NIL, NIL, NIL,
            table_fid, status);
      IF NOT status.normal THEN
        EXIT /get_list/;
      IFEND;

      amp$get_segment_pointer (table_fid, amc$sequence_pointer, table_ptr, status);
      IF NOT status.normal THEN
        EXIT /get_list/;
      IFEND;

      RESET table_ptr.sequence_pointer;
      NEXT table_version IN table_ptr.sequence_pointer;
      IF table_version = NIL THEN
        osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, 'INSTALLATION_TABLE',
              status);
        EXIT /get_list/;
      IFEND;

      NEXT table_header IN table_ptr.sequence_pointer;
      IF table_header = NIL THEN
        osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, 'INSTALLATION_TABLE',
              status);
        EXIT /get_list/;
      IFEND;

      NEXT table: [1 .. table_header^.number_of_files] IN table_ptr.sequence_pointer;
      IF table = NIL THEN
        osp$set_status_abnormal (rac$status_id, rae$accessed_beyond_segment, 'INSTALLATION_TABLE',
              status);
        EXIT /get_list/;
      IFEND;

      ALLOCATE element_list: [1 .. table_header^.number_of_files];
      element_list_allocated := TRUE;

      last := 0;
      rap$build_element_list (table, key_all, element_list, last, status);
      IF NOT status.normal THEN
        EXIT /get_list/;
      IFEND;

    END /get_list/;

    IF status.normal THEN
      fsp$close_file (table_fid, status);
    ELSE
      fsp$close_file (table_fid, ignore_status);
    IFEND;
    IF NOT status.normal THEN
      IF element_list_allocated THEN
        FREE element_list;
      IFEND;
      RETURN;
    IFEND;

  PROCEND get_element_list;

MODEND ram$prepare_element_list
*DECK DECK=RAM$PREPARE_RELEASE_MATERIALS EXPAND=TRUE
*DECK DECK=RAM$PREVIOUS_COMMANDS_PROG_DESC EXPAND=TRUE
create_program_description name=(display_previous_commands display_previous_command dispc) ..
    starting_procedure=rap$display_previous_commands ..
    libraries=($system.osf$site_command_library osf$task_services_library) ..
    load_map=$null ..
    load_map_options=none ..
    debug_mode=off

create_program_description name=(modify_previous_commands modify_previous_command modpc) ..
    starting_procedure=rap$modify_previous_commands ..
    libraries=($system.osf$site_command_library osf$task_services_library) ..
    load_map=$null ..
    load_map_options=none ..
    debug_mode=off
*DECK DECK=RAM$PRIFILE EXPAND=TRUE
.PROC,PRIFILE*I,
LFN "- Local File Name"                = (*F),
PFN "- Permanent File Name"            = (*N=,*F),
UN "- User Name of permanent file"     = (*N=,*F),
DC "- Disposition Code"                = (*N=LP,LP,LR,LS,LT),
EC "- External Characteristics"        = (*N=A9,A9,A6),
FC "- Forms Code"                      = (*N=,
                                    *S2(ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789)),
.
.HELP
 The PRIFILE procedure routes a PRInt FILE. Requires the GENLSTF binaries.

 Parameter   Default   Description
   Name       Value

   lfn                 local file name by which the file is accessed
  [pfn]       lfn      permanent file name of the stored file
  [un]                 user name in which file resides
  [dc]        lp       disposition code for the output file
  [ec]        a9       external characteristics of the output file
  [fc]                 output file forms code

.HELP,LFN
 The LFN parameter selects the name by which the file is accessed.
.HELP,PFN
 The PFN parameter selects the name by which the file is stored.
 The default is the value specified for the LFN parameter.
.HELP,UN
 The UN parameter specifies the User Name location of the file.
 The default value is the User Name in which this procedure executes.
.HELP,DC
 The DC parameter specifies the disposition code for the output file.
 Options are: lp - queued to print on any printer (default value)
              lr - queued to print on 580-12 printer
              ls - queued to print on 580-16 printer
              lt - queued to print on 580-20 printer
.HELP,EC
 The EC parameter specifies the external characteristics of the file.
 Options are:  a9  - ASCII graphic 95-character set (default value)
               a6  - ASCII graphic 63/64-character set
.HELP,FC
 The FC parameter specifies a 2-character forms code for the file.
 Options are: 1-2 alphanumeric characters, or omitted (default value).
.ENDHELP
.IFE,FILE(LFN,.NOT.AS),FILEPRM.
  GETFILE,LFN,PFN,UN,READ,A=YES.
.ELSE,FILEPRM.
  $REWIND,LFN.
.ENDIF,FILEPRM.
.IFE,$EC$.EQ.$A9$,ASCII95.
  GENLSTF(LFN,YYYYTMP,,CS612,CS812)
.ELSE,ASCII95.
  GENLSTF(LFN,YYYYTMP,,CS612,CS612)
.ENDIF,ASCII95.
.IFE,$FC$.EQ.$$,NOFORMS.
  $ROUTE(YYYYTMP,#DC=DC,TID=C,#EC=EC)
.ELSE,NOFORMS.
  $ROUTE(YYYYTMP,#DC=DC,TID=C,#EC=EC,#FC=FC)
.ENDIF,NOFORMS.
$UNLOAD,YYYYTMP.
$SKIP,NOERROR.
  $EXIT.
  $UNLOAD,YYYYTMP.
  $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    $EXIT. PRIFILE *TERMINATED*
  $ENDIF,TERMINATED.
  $REVERT,ABORT. PRINT OF LFN FAILED
$ENDIF,NOERROR.
.IFE,FILE(LFN,.NOT.AS),FILEPRM.
  $UNLOAD,LFN.
.ENDIF,FILEPRM.
$REVERT. FILE LFN PRINTED
/EOR
*DECK DECK=RAM$PROCESS_PSRS_ENTERED EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'rap$process_psrs_entered utility procedure.' ??
MODULE ram$process_psrs_entered;

{ PURPOSE:
{   This module contains the procedure that adds the PSRS to the
{   subproduct info sequence.
{
{ DESIGN:
{
{   The compiled module resides in RAF$LIBRARY.
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc ost$status
*copyc rae$package_software_cc
*copyc rat$correction_process_record
*copyc rat$subproduct_info_pointers
*copyc rat$subproduct_info_types
?? POP ??
*copyc amp$get_next
*copyc amp$rewind
*copyc clp$evaluate_token
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc rap$sort_psrs

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$process_psrs_entered', EJECT ??

{ PURPOSE:
{   This procedure validates the input PSRs and adds them to the new
{   subproduct info sequence.
{
{ DESIGN:
{   Input validation:
{   1.  All duplicates from within the input PSR list are eliminated with
{       an informative message issued.
{   2.  If a previous correction exists, any of the input PSRs which
{       duplicate entries from the previous correction
{       are also eliminated with an informative message.
{   3.  PSR names are verified to be exactly 8 alpha_numeric characters
{       beginning with a letter.  If a syntax error is found,
{       an ERROR status will be returned and the entire input list will be rejected.
{
{   The new PSRs (minus all duplicates) are stored in the new subproduct info
{   sequence.
{
{   Validation is performed by first checking the current PSR with the list
{   of already validated input PSRs.  If it is not a duplicate, it is then
{   checked for duplication against the PSR list from a previous correction,
{   if it exists.  If it validates successfully, it is added to the end of
{   the validated PSR list.  The validated PSR list is maintained as an
{   adaptable array inside the new subproduct info sequence.
{
{ NOTES:
{   All PSR names are expected to begin with a letter.  The name may only have
{   letters and numerals.
{

  PROCEDURE [XDCL]  rap$process_psrs_entered
    (    psrs_answered: clt$data_value;
     VAR new_subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR previous_correction_sif: rat$correction_process_sif_info;
     VAR status: ost$status);

    VAR
      path_container_p: ^rat$path_container,
      psrs_answered_p: ^rat$psrs_answered,
      previous_psrs_p: ^rat$psrs_answered;

    status.normal := TRUE;
    psrs_answered_p := NIL;

    IF previous_correction_sif.file_opened THEN
      previous_psrs_p := previous_correction_sif.subproduct_info_pointers.psrs_answered_p;
    ELSE
      previous_psrs_p := NIL;
    IFEND;

    IF psrs_answered.kind = clc$list THEN

      process_psrs_from_list (psrs_answered, previous_psrs_p, psrs_answered_p,
            new_subproduct_info_pointers.subproduct_info_seq_p, status);

    ELSEIF psrs_answered.kind = clc$file THEN

      process_psrs_from_file (psrs_answered.file_value, previous_psrs_p, psrs_answered_p,
            new_subproduct_info_pointers.subproduct_info_seq_p, status);

    IFEND;

    IF status.normal AND (psrs_answered_p <> NIL) THEN
      rap$sort_psrs (psrs_answered_p^);

      new_subproduct_info_pointers.psrs_answered_p := psrs_answered_p;

      new_subproduct_info_pointers.info_header_p^.psrs_answered_p :=
            #REL (psrs_answered_p, new_subproduct_info_pointers.subproduct_info_seq_p^);

    IFEND;

  PROCEND rap$process_psrs_entered;

?? OLDTITLE ??
?? NEWTITLE := 'add_psr_to_list', EJECT ??

{ PURPOSE:
{   This procedure adds a psr to the list of psrs.
{
{ DESIGN:
{   The PSR is added to the end of the array containing the
{   new psrs.  The array is located on the new subproduct
{   info sequence.
{
{ NOTES:
{
{

  PROCEDURE add_psr_to_list
    (    psr: rat$psr;
     VAR psrs_answered_p: ^rat$psrs_answered;
     VAR new_subproduct_info_seq_p: ^rat$subproduct_info_sequence);

    VAR
      psr_count: rat$psrs_answered_count;

    IF psrs_answered_p = NIL THEN
      NEXT psrs_answered_p: [1 .. 1] IN new_subproduct_info_seq_p;
      psrs_answered_p^ [1] := psr;
    ELSE
      psr_count := UPPERBOUND (psrs_answered_p^) + 1;
      RESET new_subproduct_info_seq_p TO psrs_answered_p;
      NEXT psrs_answered_p: [1 .. psr_count] IN new_subproduct_info_seq_p;
      psrs_answered_p^ [psr_count] := psr;
    IFEND;

  PROCEND add_psr_to_list;

?? OLDTITLE ??
?? NEWTITLE := 'process_psrs_from_file', EJECT ??

{ PURPOSE:
{   This procedure process a list of psrs from a file.
{
{ DESIGN:
{   The file containing PSRs is opened and read a line at a
{   time.  The entry on each line is verified to be the length
{   of a PSR name.  The PSR name is sent to another procedure
{   to be validated, checked as a duplicate and eventually added
{   to the psrs answered list.
{
{ NOTES:
{
{

  PROCEDURE process_psrs_from_file
    (    psrs_file_p: ^fst$file_reference;
         previous_psrs_p: ^rat$psrs_answered;
     VAR psrs_answered_p: ^rat$psrs_answered;
     VAR new_subproduct_info_seq_p: ^rat$subproduct_info_sequence;
     VAR status: ost$status);

    VAR
      attachment_option: array [1 .. 2] of fst$attachment_option,
      file_position: amt$file_position,
      ignore_byte_address: amt$file_byte_address,
      local_status: ost$status,
      name_length: integer,
      psr: string (osc$max_string_size),
      psr_fid: amt$file_identifier,
      psr_file_opened: boolean,
      psr_name_length: string (osc$max_string_size),
      transfer_count: amt$transfer_count;

?? OLDTITLE ??
?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If an abort situation occurs, all open files are closed.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF psr_file_opened THEN
        fsp$close_file (psr_fid, ignore_status);
        psr_file_opened := FALSE;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    osp$establish_block_exit_hndlr (^abort_handler);


  /main/
    BEGIN

      attachment_option [1].selector := fsc$access_and_share_modes;
      attachment_option [1].access_modes.selector := fsc$specific_access_modes;
      attachment_option [1].access_modes.value := $fst$file_access_options [fsc$read];
      attachment_option [1].share_modes.selector := fsc$determine_from_access_modes;
      attachment_option [2].selector := fsc$create_file;
      attachment_option [2].create_file := FALSE;

      psr_file_opened := TRUE;
      fsp$open_file (psrs_file_p^, amc$record, ^attachment_option, NIL, NIL, NIL, NIL, psr_fid, status);
      IF NOT status.normal THEN
        psr_file_opened := FALSE;
        EXIT /main/;
      IFEND;

      amp$get_next (psr_fid, ^psr, #SIZE (psr), transfer_count, ignore_byte_address, file_position, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      WHILE file_position <> amc$eoi DO

        IF (file_position = amc$eor) AND (transfer_count = rac$psr_name_length) THEN
          validate_psr_and_add_to_list (psr (1, rac$psr_name_length), previous_psrs_p, psrs_answered_p,
                new_subproduct_info_seq_p, status);
          IF NOT status.normal THEN
            EXIT /main/;
          IFEND;

          amp$get_next (psr_fid, ^psr, #SIZE (psr), transfer_count, ignore_byte_address, file_position,
                status);
          IF NOT status.normal THEN
            EXIT /main/;
          IFEND;

        ELSE

          IF transfer_count <> rac$psr_name_length THEN
            STRINGREP (psr_name_length, name_length, rac$psr_name_length);
            osp$set_status_abnormal ('RA', rae$psr_format_error, psr_name_length (1, name_length), status);
            osp$append_status_parameter (osc$status_parameter_delimiter, psr (1, transfer_count), status);
          ELSE
            osp$set_status_abnormal ('RA', rae$unable_to_read_psr_line, '', status);
          IFEND;

          EXIT /main/;
        IFEND;

      WHILEND

    END /main/;

    IF psr_file_opened THEN
      fsp$close_file (psr_fid, local_status);
    IFEND;

    osp$disestablish_cond_handler;

    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

  PROCEND process_psrs_from_file;

?? OLDTITLE ??
?? NEWTITLE := 'process_psrs_from_list', EJECT ??

{ PURPOSE:
{   This procedure process a linked list of psrs from the input parameter
{   PSRS_ANSWERED.
{
{ DESIGN:
{   The procedure loops through the linked list passing each PSR name
{   to other procedures where it is validated, checked as a duplicate
{   and eventually added to the psrs answered list.
{
{ NOTES:
{
{

  PROCEDURE process_psrs_from_list
    (    psr_list: clt$data_value;
         previous_psrs_p: ^rat$psrs_answered;
     VAR psrs_answered_p: ^rat$psrs_answered;
     VAR new_subproduct_info_seq_p: ^rat$subproduct_info_sequence;
     VAR status: ost$status);

    VAR
      psrs: clt$data_value;

    status.normal := TRUE;
    psrs := psr_list;

  /loop/
    WHILE status.normal DO

      validate_psr_and_add_to_list (psrs.element_value^.name_value (1, rac$psr_name_length), previous_psrs_p,
            psrs_answered_p, new_subproduct_info_seq_p, status);

      IF psrs.link = NIL THEN
        EXIT /loop/;
      ELSE
        psrs := psrs.link^;
      IFEND;

    WHILEND /loop/;

  PROCEND process_psrs_from_list;

?? OLDTITLE ??
?? NEWTITLE := 'psr_duplicated', EJECT ??

{ PURPOSE:
{   This function determines if the entered PSR is a duplicate
{   of a previously entered PSR.
{
{ DESIGN:
{   This procedure uses a sequential sort to compare the PSR
{   entered with a list of psrs.
{
{ NOTES:
{

  FUNCTION psr_duplicated
    (    psr: rat$psr,
         psrs_answered_p: ^rat$psrs_answered): boolean;

    VAR
      i: rat$psrs_answered_count,
      psr_found: boolean;


    psr_found := FALSE;

    IF psrs_answered_p <> NIL THEN

    /search_loop/
      FOR i := 1 TO UPPERBOUND (psrs_answered_p^) DO
        IF psr = psrs_answered_p^ [i] THEN
          psr_found := TRUE;
          EXIT /search_loop/;
        IFEND;
      FOREND /search_loop/;

    IFEND;

    psr_duplicated := psr_found;

  FUNCEND psr_duplicated;

?? OLDTITLE ??
?? NEWTITLE := 'validate_psr_and_add_to_list', EJECT ??

{ PURPOSE:
{   This procedure validates a psr and adds it to the list of psrs answered.
{
{ DESIGN:
{   This procedure validates that a PSR:
{   1) Begins with a letter.
{   2) Has only letters and numerals.
{
{   Compares the PSR against the previous psr list and the new
{   list of psrs to see if it is a duplicate.
{
{   Adds the PSR to the list of new psrs.
{
{ NOTES:
{
{

  PROCEDURE validate_psr_and_add_to_list
    (    psr: rat$psr;
         previous_psrs_p: ^rat$psrs_answered;
     VAR psrs_answered_p: ^rat$psrs_answered;
     VAR new_subproduct_info_seq_p: ^rat$subproduct_info_sequence;
     VAR status: ost$status);

    VAR
      evaluation_options: clt$token_evaluation_options,
      i: 0 .. rac$psr_name_length,
      ignore_status: ost$status,
      index: clt$string_index,
      local_status: ost$status,
      name_length: integer,
      psr_name_length: string (osc$max_string_size),
      spaces_preceded_token: boolean,
      token: clt$lexical_token,
      upper_case_psr: rat$psr;

    status.normal := TRUE;
    evaluation_options := $clt$token_evaluation_options [clc$classify_name_token,
          clc$ignore_spaces_before_token];
    #TRANSLATE (osv$lower_to_upper, psr, upper_case_psr);
    index := 1;

    clp$evaluate_token (upper_case_psr, evaluation_options, index, spaces_preceded_token, token, status);
    IF NOT status.normal OR (token.kind <> clc$simple_name_token) THEN
      STRINGREP (psr_name_length, name_length, rac$psr_name_length);
      osp$set_status_abnormal ('RA', rae$psr_format_error, psr_name_length (1, name_length), status);
      osp$append_status_parameter (osc$status_parameter_delimiter, upper_case_psr, status);
      RETURN;
    IFEND;

    IF psr_duplicated (upper_case_psr, psrs_answered_p) THEN
      osp$set_status_abnormal ('RA', rae$psr_entered_twice, upper_case_psr, local_status);
      osp$generate_error_message (local_status, ignore_status);
    ELSEIF psr_duplicated (upper_case_psr, previous_psrs_p) THEN
      osp$set_status_abnormal ('RA', rae$duplicate_psr, upper_case_psr, local_status);
      osp$generate_error_message (local_status, ignore_status);
    ELSE
      add_psr_to_list (upper_case_psr, psrs_answered_p, new_subproduct_info_seq_p);
    IFEND;

  PROCEND validate_psr_and_add_to_list;

MODEND ram$process_psrs_entered;


*DECK DECK=RAM$PROCESS_TIMESHARING_TITLES EXPAND=TRUE
PROCEDURE process_timesharing_titles (
  input, i: string = $required
  processor, p: key delete, add, keyend = $required
  titles, t: (var) array of string = $required
  )


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"    The purpose of this request is to add or delete titles from
"the timesharing application currently being defined.  This
"request is called by PROMPT_FOR_TIMESHARING_TITLES.  In this
"request the INPUT line is processed by excuting either of the
"DEFINE_SERVER subcommands, ADD_TITLES or DELETE_TITLES.  This is
"determined by the PROCESSOR value.  The TITLES array is finally
"updated.  The TITLES array is used by
"PROMPT_FOR_TIMESHARING_TITLES to setup the menu display.
*IFEND


   create_variable local_status k=status
   create_variable prompt k=string
   create_variable max_titles k=integer v=$upperbound(titles)
   create_variable local_titles k=string d=1..max_titles
   create_variable title_count k=integer v=0

  local_titles = titles
  processor = $string($value(processor))
  front = $scan_not_any(' ', $value(input))
  input = $trim($substr($value(input), front, ($strlen($value(input))-front+1)))//' '
  title_value = ''
  command_line = processor//'_titles ('
  input_length = $strlen(input)

  FOR i = 1 TO input_length DO
    char = $substr(input, i, 1)
    get_title: ..
      BLOCK
        IF char = ' ' THEN
          include_line 'x=$string($name(title_value))' status=local_status
          IF NOT local_status.normal THEN
            put_line '0Title '//title_value//' is not a name.' o=$response
            accept_line prompt input p='Press NEXT:'
            EXIT_PROC
          IFEND
          found = false
          IF processor = 'ADD' THEN
            FOR index = 1 TO max_titles DO
              IF $translate(ltu,local_titles(index))=$translate(ltu,title_value) THEN
                put_line '0Title '//title_value//' already exists.' o=$response
                put_line ' Title is being ignored' o=$response
                title_value = ''
                EXIT get_title
              IFEND
              found = (local_titles(index) = '')
              EXIT WHEN found
            FOREND
            IF found THEN
              local_titles(index) = title_value
            ELSE
              put_line '0Attempted title add will exceed maximum number of titles.' o=$response
              accept_line prompt input p='Press NEXT:'
              EXIT_PROC
            IFEND
          ELSE
            FOR index = 1 TO max_titles DO
              found = (local_titles(index) = title_value)
              EXIT WHEN found
            FOREND
            IF found THEN
              local_titles(index) = ''
            ELSE
              put_line '0Attempted to delete an unknown title.' o=$response
              accept_line prompt input p='Press NEXT:'
              EXIT_PROC
            IFEND
          IFEND
          command_line = command_line//' '''//title_value//''''
          title_count = title_count + 1
          title_value = ''
        ELSE
          title_value = title_value//char
        IFEND
      BLOCKEND get_title
  FOREND
  command_line = command_line//')'

  IF title_count>0 THEN
    include_command command_line status=local_status
    IF local_status.normal THEN
      titles = local_titles
    ELSE
      put_line ('0The following error occured during attempt to '//processor//' titles.', ..
                ' '//$strrep(local_status)) o=$response
      accept_line prompt input p='Press NEXT:'
      EXIT_PROC
    IFEND
  ELSE
    put_line '0No titles were added.' o=$response
    accept_line prompt input p='Press NEXT:'
  IFEND

PROCEND process_timesharing_titles
*DECK DECK=RAM$PRODUCT_REFERENCE_UTILITY EXPAND=TRUE
create_program_description name=(product_reference_utility, proru) ..
      starting_procedure=ocp$_product_reference_utility  libraries=('$system.ocu.bound_product' ..
      osf$task_services_library) termination_error_level=warning load_map_options=none ..
      load_map=$null debug_mode=off availability=hidden
*DECK DECK=RAM$PROMPTING_INTERFACES_PD EXPAND=TRUE
create_program_description name=rap$press_next starting_procedure=rap$press_next_command ..
      library=osf$current_library a=hidden

create_program_description name=rap$prompt_for_value starting_procedure=rap$prompt_for_value_command ..
      library=osf$current_library a=hidden

create_program_description name=rap$prompt_via_menu starting_procedure=rap$prompt_via_menu_command ..
      library=osf$current_library a=hidden
*DECK DECK=RAM$PROMPT_FOR_ACTIVE_NETWORK EXPAND=TRUE
PROCEDURE prompt_for_active_network (
  choice : (var) boolean = $optional
  status : (var) status = $optional
  )

  crev yes_response k=boolean

"$ format=off
  put_line (..
    '1'..
    '0NAM/VE has already been activated.  Any changes that you make ' ..
    ' to the network configuration will not take effect until the next '..
    ' system deadstart.' ..
    '  ')
"$ format=on

  $system.osf$builtin_library.prompt_for_answer 'Do you want to continue:' yes_response
  $value(choice) = NOT yes_response

PROCEND prompt_for_active_network
*DECK DECK=RAM$PROMPT_FOR_ADD_ELEMENT EXPAND=TRUE
PROCEDURE prompt_for_add_element (
  physical_data: string = $optional
  system_id: (var) string = $optional
  add_this_element: (var) string = $optional
  )

  create_variable choice kind=string v=''

  main_loop: ..
    loop

 put_line ' '
 put_line '0Would you like to add element  '//$trim($substring(physical_data,11,31))//' to the network?'
 put_line ' Enter YES, NO, QUIT, or ?: '
 accept_line choice input p=''

 IF (choice='?') OR ($translate(lower_to_upper,choice)='HELP') THEN
   put_line ('0Enter YES if this element is to be added to the network configuration. ' ..
             ' Enter NO if this element is NOT to be added to the network configuration. ')
   accept_line choice input p='Press NEXT:'
 ELSEIF ($translate(lower_to_upper,choice)='QUIT') OR ($translate(lower_to_upper,choice)='QUI') THEN
     EXIT main_loop
 ELSEIF ($translate(lower_to_upper,choice)='YES') OR ($translate(lower_to_upper,choice)='Y') THEN
    add_this_element = 'YES'
    IF physical_data(5,5)='ICA2 ' THEN
      prompt_for_system_id ICA2 system_id
    IFEND
    EXIT main_loop
 ELSEIF ($translate(lower_to_upper,choice)='NO') OR ($translate(lower_to_upper,choice)='N') THEN
    add_this_element = ' '
    system_id = ' '
    EXIT main_loop
 IFEND
 LOOPEND main_loop

PROCEND prompt_for_add_element
*DECK DECK=RAM$PROMPT_FOR_CHANNEL_NETWORK EXPAND=TRUE
PROC prompt_for_channel_network (
  di_information : string = $optional
  host_network_id: string = $optional
  pcu_entries    : integer -281474976710655..281474976710655 = $optional
  relays         : var of string = $optional
  network        : var of string = $optional
  lcu_entries    : var of integer = $optional
  status         : var of status = $optional
  )

" Set parameters to local variables

  di_data = $value(di_information)
  relays_restricted = $value(relays)
  network_identifier = $value(network)

" Initialize working variables. "

  create_variable choice k=string
  create_variable configuration_file k=string v='$local.'//$unique
  create_variable cr_requested k=string
  create_variable hex_network_value k=string
  create_variable (local_status ignore) k=status
  create_variable network_string k=string v=' '

" Set default values.

  IF (relays_restricted = ' ') THEN
    relays_restricted = 'NO'
  IFEND
  title = ' ' // $trim($substr(di_data, 5, 36)) // ', ' // $substr(di_data, 43, 4) // ', S/N ' //..
        $strrep($integer($substr(di_data, 50, 6)))

main_loop: ..
  LOOP

  IF network_identifier = ' ' THEN
    network_string = ' '
  ELSE
    hex_network_value = $strrep($integer(network_identifier),16)//'(16)'
    network_string = network_identifier//' or '//hex_network_value
  IFEND

"$ format=off
    put_line (..
     '1Define Channel Network for:'..
     title..
     '01. Network Identifier ................. '//network_string ..
     ' 2. Relays restricted .................. '//relays_restricted ..
     '0Enter a menu selection, QUIT, GO, or ?:'..
     )
"$ format=on
    choice = ' '
    accept_line choice input p=''

    IF choice = '1' THEN

      prompt_for_network_id network_identifier help=channel_network

    ELSEIF choice = '2' THEN " relays restricted. "

      prompt_for_relays_restricted relays_restricted

    ELSEIF ($translate(lower_to_upper, choice) = 'QUIT') OR ($translate(lower_to_upper, choice) = 'QUI') THEN

      EXIT main_loop

    ELSEIF (choice = '?') OR ($translate(lower_to_upper, choice) = 'HELP') THEN

"$ format=off
      put_line (..
        '0With this menu you define a channel network between your mainframe and'..
        ' the CDCNET DI indicated in the menu title. ' ..
        '0You must specify the network identifier for the channel network.  No ' ..
        ' default value is provided.'..
        '0The default value for Relays restricted is NO.  If you set this value '..
        ' to YES, NOS/VE will only relay messages between this network and other '..
        ' networks if no other path is available.'..
        '0Enter a menu selection to supply a parameter.'..
        ' Enter GO or press NEXT to accept the parameters and return to the'..
        '   previous menu.'..
        ' Enter QUIT to return to the previous menu without changing the parameters.'..
        '  ')
"$ format=on
      accept_line cr_requested input p='Press NEXT:'

    ELSEIF (choice = ' ') OR ($translate(lower_to_upper, choice) = 'GO') THEN

      IF network_identifier = ' ' THEN
        accept_line cr_requested input p='Network identifier needed, press NEXT: '
      ELSE
        detach_file $fname(configuration_file) status=ignore
        generate_defhn host_network_id $fname(configuration_file//'.$eoi')
        generate_defcn network_identifier relays_restricted di_data $fname(configuration_file//'.$eoi')
        execute_task sp=logical_configuration_utility
          verify_network_configuration i=$fname(configuration_file) status=local_status
        quit
        detach_file $fname(configuration_file) status=ignore
        IF local_status.normal THEN
          IF $value(network) = ' ' THEN
            $value(lcu_entries) = $value(lcu_entries) + 1
          IFEND
          $value(relays) = relays_restricted
          $value(network) = network_identifier
          put_line ('0Parameters verified.' '  ')
          accept_line cr_requested input p='Press NEXT: '
          EXIT main_loop
        ELSE
          display_value local_status
          accept_line cr_requested input p='Press NEXT: '
        IFEND
      IFEND

    ELSE

      accept_line cr_requested input p='Invalid selection, press NEXT: '

    IFEND

  LOOPEND main_loop
  detach_file $fname(hex_output_file) status=ignore

PROCEND prompt_for_channel_network
*DECK DECK=RAM$PROMPT_FOR_DEVICE_TYPE EXPAND=TRUE
PROCEDURE prompt_for_device_type (
  device_type: (var)  string = $optional
  status)

  "$FORMAT=OFF
  VAR
    choice: string
    display_choices: boolean = true
  VAREND
  "$FORMAT=ON"

  display_choices = true

device_type_loop: ..
  LOOP

    IF display_choices THEN
"$ format=off
      put_line (..
        '0Select the CDCNET device type from the list below:'..
        '01. Mainframe Terminal Interface (MTI) ' ..
        ' 2. Mainframe Device Interface (MDI)'..
        ' 3. Terminal Device Interface (TDI)' ..
        ' 4. Integrated Communications Adapter (ICA-II)' ..
        '  ')
"$ format=off
    IFEND
    accept_line choice input p='Enter menu selection or a ? for help: '
    IF choice = '?' THEN
      put_line (..
        '0- An MTI is a DI that is connected directly to a CYBER mainframe channel'..
        '   and which also has terminal communications lines connected to it.' ..
        ' - An MDI is a DI which is connected to a CYBER mainframe channel, '..
        '   and which has ethernet or other trunk lines connected to it. '..
        '   There are no communications lines attached to an MDI.'..
        ' - A TDI is a DI that is connected to other DIs by an ethernet or other ' ..
        '   trunk line and is not connected to any mainframe by a CYBER channel.'..
        '   A TDI does have communications lines attached to it.'..
        ' - An ICA-II is connected directly to the ethernet and'..
        '   does not have communications lines attached to it.'..
        '  ')
      display_choices = true
    ELSEIF choice = '1' THEN
      device_type = 'MTI'
      EXIT device_type_loop
    ELSEIF choice = '2' THEN
      device_type = 'MDI'
      EXIT device_type_loop
    ELSEIF choice = '3' THEN
      device_type = 'TDI'
      EXIT device_type_loop
    ELSEIF choice = '4' THEN
      device_type = 'ICA_II'
      EXIT device_type_loop
    ELSEIF choice = ' ' THEN
      EXIT device_type_loop
    ELSE
      put_line ('0Invalid menu selection, please correct. ', '  ')
      display_choices = false
    IFEND
  LOOPEND device_type_loop

PROCEND prompt_for_device_type
*DECK DECK=RAM$PROMPT_FOR_FORWARD_SEARCH EXPAND=TRUE
PROCEDURE prompt_for_forward_search (
  forward_search_range : (var) string = $required
  status)

  VAR
    input_string: string
    conversion_status: status
    integer_number: integer
  VAREND

forward_search_loop: ..
  LOOP

    put_line (..
      '0Enter a number in the range 1-16, GO, QUIT, or ? for help.')
    accept_line input_string input p=''
    IF (input_string = '?') OR ($translate(lower_to_upper, input_string) = 'HELP') THEN
        put_line (..
          '0Specify the TCP/IP host forward search range upper value.  The default forward '..
          ' search range is 4. '..
          ' Enter GO or press NEXT to the retain the current forward search range of '//forward_search_range//'.' ..
          '0Enter QUIT to return to the Define TCP/IP Host menu with the default forward ' ..
          ' search range. ' ..
          '  ')
    ELSEIF ($translate(lower_to_upper, input_string) = 'QUIT') OR ($translate(lower_to_upper, input_string) = 'QUI') THEN
      forward_search_range = '4(10)'
      EXIT_PROC
    ELSEIF (input_string = ' ') OR ($translate(lower_to_upper, input_string) = 'GO') THEN
      EXIT_PROC
    ELSE
      include_line 'integer_number=$integer(''0''//input_string)' status=conversion_status
      IF conversion_status.normal THEN
        IF (integer_number >= 1) AND (integer_number <= 16) THEN
          forward_search_range = $strrep(integer_number) // '(10)'
          EXIT_PROC
        ELSE
          accept_line input_string input p=' TCP/IP host forward search is out of range, please correct.  Press NEXT: '
        IFEND
      ELSE
        display_value conversion_status
        accept_line input_string input p=' Invalid forward search value, please correct.  Press NEXT: '
      IFEND
    IFEND
  LOOPEND forward_search_loop

PROCEND prompt_for_forward_search
*DECK DECK=RAM$PROMPT_FOR_HOST_NETWORK EXPAND=TRUE
PROCEDURE prompt_for_host_network (
  host_network: (var) string = $required
  status: (var) status = $optional
  )

" This procedure prompts the user for the host network identifer.


" Make local copies of procedure parameters.

  host_network_id = host_network

  "$FORMAT=OFF
  VAR
    choice: string
    cr_requested: string
    hex_network_value: string
    network_string: string
    processor_serial_number: string
  VAREND
  "$FORMAT=ON"

  processor_serial_number =  $processor(serial_number, 0)
  IF $processor(serial_number, 1) <> '' THEN
    processor_serial_number = processor_serial_number // ',' //$processor(serial_number, 1)
  IFEND
  title = ' ' // $processor(model, 0) // ' SN' // processor_serial_number

main_loop: ..
  LOOP
    IF host_network_id = ' ' THEN
      network_string = ' '
    ELSE
      hex_network_value = $strrep($integer(host_network_id), 16) // '(16)'
      network_string = host_network_id // ' or ' // hex_network_value
    IFEND

"$ format=off
    put_line (..
     '1Define Host Network for:'..
     title ..
     '01. Network Identifier ................. '//network_string ..
     '0Enter a menu selection, QUIT, GO, or ?:'..
     )
"$ format=on

    choice = ' '
    accept_line choice input p=''

    IF choice = '1' THEN
      prompt_for_network_id ve host_network_id
    ELSEIF ($translate(lower_to_upper, choice) = 'QUIT') OR ($translate(lower_to_upper, choice) = 'QUI') THEN
      host_network = ' '
      EXIT main_loop
    ELSEIF (choice = '?') OR ($translate(lower_to_upper, choice) = 'HELP') THEN

"$ format=off
      put_line (..
        '0With this menu you define the host network identifier. This identifier does'..
        ' not identify a physical network, but rather a "pseudo network" by which'..
        ' this host will be known in the CDCNET concatenated network (catenet).'..
        ' It is used for routing messages over the OSI protocol stack.  Hence, the ' ..
        ' network identifier must be unique among all network identifiers assigned' ..
        ' within this catenet.'..
        '0You must specify the network identifier for the host network.  No'..
        ' default value is provided.'..
        '0Enter a ''1'' to supply the host network identifier.'..
        ' Enter GO or press NEXT to accept the current host network identifier and'..
        '   proceed to the next menu.'..
        ' Enter QUIT to return to the previous menu without defining the host network.'..
        )
"$ format=on
      accept_line cr_requested input p='Press NEXT:'
    ELSEIF (choice = ' ') OR ($translate(lower_to_upper, choice) = 'GO') THEN
      IF host_network_id = ' ' THEN
        accept_line cr_requested input p='Network identifier needed, press NEXT: '
      ELSE
        put_line ('0Host network id accepted.' '  ')
        accept_line cr_requested input p='Press NEXT: '
        host_network = host_network_id
        EXIT main_loop
      IFEND
    ELSE
      accept_line cr_requested input p='Invalid selection, press NEXT: '
    IFEND

  LOOPEND main_loop

PROCEND prompt_for_host_network
*DECK DECK=RAM$PROMPT_FOR_NETWORK_CONNECT EXPAND=TRUE
PROCEDURE prompt_for_network_connect (
  device_info: string = $optional
  host_network_id: string = $optional
  system_id: (var) string = $optional
  add_element: (var) boolean = $optional
  lcu_entries: (var) integer = $optional
  status)


  "$FORMAT=OFF
  VAR
    choice: string
    configuration_file: string = '$local.'//$unique
    cr_requested: string
    ignore: status
    local_status: status
    system_identifier: string
    system_id_string: string = ' '
    temp_add: boolean
  VAREND
  "$FORMAT=ON"

main_loop: ..
  LOOP

    IF $substr(device_info,37,4) = 'ICA2' THEN
      IF system_identifier = ' ' THEN
        system_id_string = ' '
      ELSE
        system_id_string = system_identifier // '(16)'
      IFEND
    IFEND

"$ format=off
    put_line (..
     '1Define Network Connection for: '//$substr(device_info,5,36)..
     '0 '..
     '0Do you wish to add this element to the Network Configuration?'..
     '0    1. YES'..
     '0    2. NO'..
     '0Enter a menu selection, QUIT, GO, or ?: '..
     )
"$ format=on
    choice = ' '
    accept_line choice input p=''

    IF choice = '1' THEN
      temp_add = TRUE
      IF $substr(device_info,36,4) = 'ICA2' THEN
        prompt_for_system_id ica2 system_identifier

    ELSEIF choice = '2' THEN

      temp_add = FALSE

    ELSEIF ($translate(lower_to_upper, choice) = 'QUIT') OR ($translate(lower_to_upper, choice) = 'QUI') THEN

      EXIT main_loop

    ELSEIF (choice = '?') OR ($translate(lower_to_upper, choice) = 'HELP') THEN

"$ format=off
      put_line (..
        '0With this menu you define a network connection between your mainframe and'..
        ' the CDCNET $2629_2 Integrated Communications Adapter (ICA-II) indicated'..
        ' in the menu title.'..
        '0You must specify the system identifier for the ICA-II. No default value'..
        ' is provided.' ..
        '0Enter a menu selection to supply a parameter.'..
        ' Enter GO or press NEXT to accept the parameters and return to the'..
        '   previous menu.'..
        ' Enter QUIT to return to the previous menu without changing the parameters.'..
        '  ')
"$ format=on
      accept_line cr_requested input p='Press NEXT:'

    ELSEIF (choice = ' ') OR ($translate(lower_to_upper, choice) = 'GO') THEN

      IF ($substr(device_info,36,4)='ICA2') AND (system_identifier = ' ')  THEN
        accept_line cr_requested input p='System identifier needed, press NEXT: '
      ELSEIF temp_add THEN
        detach_file $fname(configuration_file) status=ignore
        generate_defhn host_network_id $fname(configuration_file//'.$eoi')
        generate_defnc device_info system_identifier $fname(configuration_file//'.$eoi')
        execute_task sp=logical_configuration_utility
          verify_network_configuration i=$fname(configuration_file) status=local_status
        quit
        detach_file $fname(configuration_file) status=ignore
        IF local_status.normal THEN
          system_id = system_identifier
          add_element = temp_add
          put_line ('0Parameters verified.' '  ')
          accept_line cr_requested input p='Press NEXT: '
          EXIT main_loop
        ELSE
          display_value local_status
          accept_line cr_requested input p='Press NEXT: '
        IFEND
      IFEND

    ELSE
      accept_line cr_requested input p='Invalid selection, press NEXT: '
    IFEND

  LOOPEND main_loop

PROCEND prompt_for_network_connect
*DECK DECK=RAM$PROMPT_FOR_NETWORK_ID EXPAND=TRUE
PROCEDURE prompt_for_network_id (
  network_type : key ethernet,ve, keyend = $required
  network : (var) string = $required
  status  : (var) status = $optional
  )

  create_variable input_string k=string
  create_variable conversion_status k=status
  create_variable integer_number k=integer

network_id_loop: ..
  LOOP
    put_line ' Enter a number in the range 1-0FFFF(16) or ? for help.'
    accept_line input_string input p=''
    IF (input_string = '?') OR ($translate(lower_to_upper, input_string) = 'HELP') THEN
      IF $string(network_type) = 'ETHERNET' THEN
        put_line (..
          '0Specify the network identifier of the ethernet to which the device' ..
          ' is connected.  That is, specify the identifier by which this network'..
          ' will be known within the CDCNET concatenated network (catenet).'..
          ' This identifier must be unique among all network identifiers assigned'..
          ' within this catenet.'..
          )
      ELSE
        put_line (..
          '0Specify the VE interface network identifier which is used to route' ..
          ' messages to the host through this device.  That is, the VE interface' ..
          ' identifier by which this network will be known within the CDCNET'..
          ' concatenated network (catenet).  This identifier must be unique among'..
          ' all network identifiers assigned within this catenet.'..
          '0A VE interface network identifier is required if more than one device' ..
          ' was defined during network configuration.'..
          )
      IFEND
      put_line (..
        '0To enter a hexadecimal value, append a radix of (16) to the number.'..
        '  ')
    ELSEIF input_string = ' ' THEN
      EXIT network_id_loop
    ELSE
      include_line 'integer_number=$integer(''0''//input_string)' status=conversion_status
      IF conversion_status.normal THEN
        IF (integer_number >= 1) AND (integer_number <= 0FFFF(16)) THEN
          $value(network) = $strrep(integer_number) // '(10)'
          EXIT network_id_loop
        ELSE
          put_line ('0Network identifier out of range, please correct.', '  ')
        IFEND
      ELSE
        display_value conversion_status
        put_line ('0Invalid network identifier, please correct.', '  ')
      IFEND
    IFEND
  LOOPEND network_id_loop

PROCEND prompt_for_network_id
*DECK DECK=RAM$PROMPT_FOR_RELAYS_RESTRICTD EXPAND=TRUE
PROC prompt_for_relays_restricted (
  relays : var of string = $optional
  status : var of status = $optional
  )

  create_variable input_string k=string

relays_restricted_loop: ..
  LOOP
    accept_line input_string input p='Enter YES, NO, or ? for help:'

    IF input_string = '?' THEN
      put_line ('0Specifies the restrictions on the NOS/VE system with respect to the ' ..
            ' relaying of messages between this network and other networks.  This ' ..
            ' parameter is meaningful only if the NOS/VE system resides on multiple ' ..
            ' networks.  The default for this parameter will not restrict the relay'..
            ' of messages.', '  ')
    ELSEIF $translate(lower_to_upper, input_string) = 'YES' OR..
          $translate(lower_to_upper, input_string) = 'Y' THEN
      $value(relays) = 'YES'
      EXIT relays_restricted_loop
    ELSEIF $translate(lower_to_upper, input_string) = 'NO' OR $translate(lower_to_upper, input_string) = 'N'..
           THEN
      $value(relays) = 'NO'
      EXIT relays_restricted_loop
    ELSEIF input_string = ' ' THEN
      EXIT relays_restricted_loop
    ELSE
      put_line ('0Invalid response, please correct.', '  ')
    IFEND
  LOOPEND relays_restricted_loop

PROCEND prompt_for_relays_restricted
*DECK DECK=RAM$PROMPT_FOR_SYSTEM_ID EXPAND=TRUE
PROCEDURE  prompt_for_system_id (
  device_type : key di,ica2, keyend = $required
  system_id : (var) string = $required
  status: (var) status = $optional
  )

  create_variable input_string k=string
  create_variable integer_number k=integer
  create_variable maximum_sys_id_range k=string
  create_variable minimum_sys_id_range k=string
  create_variable conversion_status k=status

system_id_loop: ..
  LOOP
    IF $string(device_type) = 'DI' THEN
      minimum_sys_id_range = '100000'
      maximum_sys_id_range = '0ffffff'
      put_line  '0Enter last 6 digits of DI system identifier or ? for help:'
      accept_line input_string input p=''
    ELSE
      minimum_sys_id_range = '400101'
      maximum_sys_id_range = '4fffff'
      put_line '0Enter last 6 digits of ICA-II system identifier or ? for help: '
      accept_line input_string input p=''
    IFEND
    IF input_string = '?' THEN
      put_line ('0Supply the last six digits of the 12-digit system identifier.')
      IF $string(device_type) = 'DI' THEN
        put_line (' The system identifier can be found on a plastic tag inside the door' ..
            ' of the DI cabinet.  Note that a 4-digit hexadecimal checksum is appended'..
            ' to the end of the system identifier on the tag; do not enter the checksum ' ..
            ' as part of the identifier.  Also, do not include the radix (16) with the'..
            ' system identifier.', '  ')
      ELSE
        put_line (' The system identifier should be obtained from the customer engineer.'..
            ' Also, do not include the radix (16) with the system identifier.')
      IFEND
    ELSEIF input_string = ' ' THEN
      EXIT system_id_loop
    ELSE
      include_line 'integer_number=$integer(''0''//input_string//''(16)'')' status=conversion_status
      IF conversion_status.normal THEN
          IF (integer_number >= $integer(minimum_sys_id_range//'(16)')) AND ..
             (integer_number <= $integer(maximum_sys_id_range//'(16)')) THEN
            $value(system_id) = '080025' // $translate(lower_to_upper, input_string)
            EXIT system_id_loop
          ELSE
            put_line ('0System identifier out of range, please correct.'..
                 ' System identifier must be in range '//minimum_sys_id_range//'(16) - '//maximum_sys_id_range//'(16).')
          IFEND
        ELSE
          put_line ('0Invalid system identifier, please correct.', '  ')
        IFEND
    IFEND
  LOOPEND system_id_loop

PROCEND prompt_for_system_id
*DECK DECK=RAM$PROMPT_FOR_TCPIP_HOST_NAME EXPAND=TRUE
PROCEDURE prompt_for_tcpip_host_name (
  host_name : (var) string = $required
  status)

  VAR
    input_string: string
  VAREND

tcpip_host_name_loop: ..
  LOOP
    put_line (..
      '0Enter the TCP/IP host name, GO, QUIT, or ? for help.')
    accept_line input_string input p=''
    IF (input_string = '?') OR ($translate(lower_to_upper, input_string) = 'HELP') THEN
        put_line (..
          '0Specify the TCP/IP host name. '..
          ' The Host Name (also known as the domain name) is a' ..
          ' string of 255 characters or less.  The domain name may be subdivided into ' ..
          ' domain labels.  Domain labels may be up to 63 characters in length. ' ..
          ' Domain labels are seperated with periods.  Domain labels must begin ' ..
          ' with a letter (a..z or A..Z) and may be followed with 0 to 62 more ' ..
          ' letters, digits (0..9), hyphens (-), or underscores (_) with the exception ' ..
          ' of the last character which must be either a letter or a digit. ' ..
          ' For example, arh.cdc.q---_5 is a valid host name. ' ..
          ' Enter GO or press NEXT to the retain the current TCP/IP host name of "'//host_name//'".' ..
          ' Enter QUIT to return to the Define TCP/IP Host menu without defining ' ..
          ' the TCP/IP Host Name.' ..
          '  ')
    ELSEIF ($translate(lower_to_upper, input_string) = 'QUIT') OR ($translate(lower_to_upper, input_string) = 'QUI') ..
          THEN
      host_name = ' '
      EXIT tcpip_host_name_loop
    ELSEIF ($translate(lower_to_upper, input_string) = 'GO') OR ($translate(lower_to_upper, input_string) = ' ') THEN
      EXIT tcpip_host_name_loop
    ELSE
      host_name = input_string
      EXIT tcpip_host_name_loop
    IFEND
  LOOPEND tcpip_host_name_loop

PROCEND prompt_for_tcpip_host_name
*DECK DECK=RAM$PROMPT_FOR_TIMESHARING_TITL EXPAND=TRUE
PROC prompt_for_timesharing_titles (
  titles, t: array of string = $required
  changes_accepted, ca: VAR of boolean = $required
  status)


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"    The purpose of this request is to allow the site to define up
"to MAX_TITLES timesharing titles.  This request is called by
"DEFINE_TIMESHARING, and follows the menu format of all
"DEFINE_NETWORK procedures.  The titles are actually processed by
"PROCESS_TIMESHARING_TITLES.
*IFEND


  create_variable choice k=string
  create_variable command_file k=string v='$local.'//$unique
  create_variable conversion_status k=status
  create_variable example_title k=string v='sys'//$strrep($integer($substr($mainframe(identifier), 14, 4)))
  create_variable ignore_status k=status
  create_variable input_line k=string
  create_variable menu k=string v='$local.'//$unique
  create_variable local_status k=status
  create_variable prompted k=string
  create_variable title_count k=integer

main_loop: ..
  LOOP

    collect_text $fname(menu//'.$boi') until='    END_COLLECT'
      put_line ('1Current timesharing titles ......', ..
    END_COLLECT
    title_count = 0
    FOR i = 1 TO $upperbound(titles) DO
      IF titles(i) <> '' THEN
        put_line '''  '//titles(i)//''', ..' o=$fname(menu//'.$eoi')
        title_count = title_count + 1
      IFEND
    FOREND
    put_line ('''01. Add titles'', '' 2. Delete titles'',''  '')') o=$fname(menu//'.$eoi')
    include_file $fname(menu) status=ignore_status
    $system.detach_file $fname(menu) status=ignore_status

    accept_line choice input p='Enter a menu selection, QUIT, GO, or ?:'
    IF choice <> '' THEN
      front = $scan_not_any(' ', choice)
      choice = $translate(lower_to_upper, $trim($substr(choice, front, ($strlen(choice)-front+1))))
    IFEND

    IF choice = '1' THEN
    add_titles: ..
      LOOP
        accept_line input_line input p='Enter timesharing title(s) to be added or ? for help:'
        IF input_line = '' THEN
          EXIT add_titles
        IFEND
        front = $scan_not_any(' ', input_line)
        input_line = $translate(lower_to_upper, $trim($substr(input_line, front, ($strlen(input_line)-front+1))))
        IF input_line = '?' THEN
          put_line ('0Enter the title(s) you want this NOS/VE timesharing application to be known' ..
                    ' by.  The title chosen must be unique from all other titles in the CDCNET ' ..
                    ' concatenated network (catenet).  Multiple titles can be entered separated by ' ..
                    ' a space.  A title must be a valid SCL name.', '  ')


          accept_line prompted input p='Press NEXT:'
        ELSE
          $system.osf$builtin_library.process_timesharing_titles input_line p=add t=titles
          EXIT add_titles
        IFEND
      LOOPEND add_titles

    ELSEIF choice = '2' THEN
    delete_titles: ..
      LOOP
        accept_line input_line input p='Enter timesharing title(s) to be deleted or ? for help:'
        IF input_line = '' THEN
          EXIT delete_titles
        IFEND
        front = $scan_not_any(' ', input_line)
        input_line = $translate(lower_to_upper, $trim($substr(input_line, front, ($strlen(input_line)-front+1))))
        IF input_line = '?' THEN
          put_line ('0Enter the application title(s) you want to delete from the current' ..
                    ' timesharing titles list.  Multiple titles can be entered separated by' ..
                    ' a space.', '  ')
          accept_line prompted input p='Press NEXT:'
        ELSE
          $system.osf$builtin_library.process_timesharing_titles input_line p=delete t=titles
          EXIT delete_titles
        IFEND
      LOOPEND delete_titles

    ELSEIF (choice = 'QUIT') OR (choice = 'QUI') THEN
      changes_accepted = FALSE
      titles_added = FALSE
      EXIT main_loop

    ELSEIF (choice = '?') OR (choice = 'HELP') THEN
      put_line (..
        '0You are required to provide the title(s) by which NOS/VE users' ..
        ' connect to the timesharing application.  The user connects to the' ..
        ' application via the CDCNET CREATE_CONNECTION command which requires' ..
        ' an application title, for example:' ..
        '       create_connection '//example_title ..
        ' The title(s) chosen must be unique from all other titles in the CDCNET ' ..
        ' concatenated network (catenet).  The example title, '//example_title//' was ' ..
        ' generated using your mainframe''s serial number.  A title must be a valid ' ..
        ' SCL name (1 to 31 alphabetic characters, digits, _, $, #, and/or @,' ..
        ' beginning with a nondigit).' ..
        '0Enter a menu selection to add or delete titles.' ..
        ' Enter GO or press NEXT to define the timesharing application with the' ..
        ' current list of titles.' ..
        ' Enter QUIT or QUI to return to the main menu without any changes.')

      accept_line prompted input p='Press NEXT:'

    ELSEIF (choice = ' ') OR (choice = 'GO') THEN
      IF title_count = 0 THEN
        put_line '0No Timesharing titles are defined.'
        accept_line prompted input p='Press NEXT:'
      ELSE
        changes_accepted = TRUE
        titles_added = TRUE
        EXIT main_loop
      IFEND

    ELSE
      accept_line prompted input p='Invalid selection, press NEXT:'
    IFEND
  LOOPEND main_loop

PROCEND prompt_for_timesharing_titles
*DECK DECK=RAM$PTF_SERVER EXPAND=TRUE
create_program_description PTFS l='$system.ptf.osf$user_file_transfer' sp=nfp$ptf_server ..
  lm=$null lmo=none lo=manual a=hidden dm=off
*DECK DECK=RAM$PUT_MESSAGE EXPAND=TRUE
PROC put_message, putm (message, messages, m: list of string = $required
  status)

"---------------------------------------------------------------------
" PUT_MESSAGE
"
" PURPOSE:
"
"  Issue messages to $response.
"
" PARAMETERS:
"
" Messages: List of strings to be output.
"----------------------------------------------------------------------

  FOR i = 1 TO $set_count(messages) DO
    put_line ' == '//$value(message i) o=$response
  FOREND

PROCEND put_message
*DECK DECK=RAM$QUIT_CREATE EXPAND=TRUE
PROCEDURE quit_create, quic, qc

  IF $utility(name) = 'SCU_EDIT' THEN
    "$FORMAT=OFF"
    VAR
      y_or_n  : string 1..1
    VAREND
    "$FORMAT=ON"

    IF $current_object_type = 'FILE' THEN
      IF $file($fname($current_object), assigned) THEN
        IF $file($command_of_caller, device_class) = 'MASS_STORAGE' THEN
          EXIT quit_create WITH $status(false, 'QC', 1001, ' File already exists.')
        IFEND
        IF $screen_active THEN
          y_or_n = $si(' File already exists.  Reply Y to overwrite file or N to resume session.')
        ELSE
          put_line ' File already exists.  Reply Y to overwrite file or N to resume session.'
          get_line v=y_or_n i=$input prompt='? '
        IFEND
        IF y_or_n = 'Y' OR y_or_n = 'y' THEN
          end_file write_file=true
        IFEND
      ELSE
        end_file write_file=true
      IFEND
    ELSE
      IF $current_object_type = 'DECK' THEN
        IF $file($command_of_caller, device_class) = 'MASS_STORAGE' THEN
          EXIT quit_create WITH $status(false, 'QC', 1002, ' This command is not applicable for decks.')
        IFEND
        IF $screen_active THEN
          put_row text=' This command is not applicable for decks.' row=$message_row
        ELSE
          put_line ' This command is not applicable for decks.'
        IFEND
      IFEND
    IFEND

    IF $current_object_type = 'NULL' THEN
      "$FORMAT=OFF"
      quit write_file=false
      "$FORMAT=ON"
    IFEND

  IFEND

PROCEND quit_create
*DECK DECK=RAM$QUIT_CREOD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'CREATE_ORDER_DEFINITION Subutility: QUIT Subcommand.' ??
MODULE ram$quit_creod;

{ PURPOSE:
{   This module contains the procedure to end the create order definition
{   utility session.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$package_software_cc
*copyc clp$end_scan_command_file
*copyc clp$scan_parameter_list
*copyc ost$status
?? POP ??
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc rav$creod_scratch_segment
*copyc rav$creod_utility_name

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$quit_creod', EJECT ??

  PROCEDURE [XDCL] rap$quit_creod
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt quit_creod_pdt (
{   status : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    quit_creod_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^quit_creod_pdt_names,
      ^quit_creod_pdt_params];

  VAR
    quit_creod_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
      clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    quit_creod_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??


    VAR
      ignore_status: ost$status,
      message_status: ost$status,
      write_definition_needed_flag_p: ^boolean;


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, quit_creod_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET rav$creod_scratch_segment.sequence_p;
    NEXT write_definition_needed_flag_p IN rav$creod_scratch_segment.sequence_p;

    IF write_definition_needed_flag_p^ = TRUE THEN
      osp$set_status_abnormal ('RA', rae$command_wrid_required, '', message_status);
      osp$generate_error_message (message_status, ignore_status);
    IFEND;


    clp$end_scan_command_file (rav$creod_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$quit_creod;
MODEND ram$quit_creod;
*DECK DECK=RAM$QUIT_CRESC EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'CREATE_SUBPRODUCT_CORRECTION subutility: QUIT command.' ??
MODULE ram$quit_cresc;

{ PURPOSE:
{   This module contains the procedure that ends the CREATE_SUBPRODUCT_CORRECTION
{   utility.
{
{ DESIGN:
{   This module returns all system resources and ends the
{   CREATE_SUBPRODUCT_CORRECTION utility.
{
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$package_software_cc
?? POP ??
*copyc clp$end_include
*copyc clp$evaluate_parameters
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc rap$reset_correction_environ
*copyc rav$correction_process_record
*copyc rav$cresc_utility_name

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$quit_cresc', EJECT ??

{ PURPOSE:
{   This procedure opens the utility.
{
{ DESIGN:
{   The utility is opened.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$quit_cresc
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE quit_cresc_pdt (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 7, 12, 15, 34, 51, 26], clc$command, 1, 1, 0, 0, 0, 0, 1, 'QUIT_CRESC_PDT'],
            [['STATUS                         ', clc$nominal_entry, 1]], [
{ PARAMETER 1
      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    VAR
      ignore_status: ost$status,
      local_status: ost$status;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF rav$correction_process_record.correction_in_progress THEN
      osp$set_status_abnormal ('RA', rae$genc_not_called, '', local_status);
      osp$generate_error_message (local_status, ignore_status);
    IFEND;

    rap$reset_correction_environ (rav$correction_process_record, local_status);
    IF NOT status.normal THEN
      osp$generate_error_message (local_status, ignore_status);
    IFEND;

    clp$end_include (rav$cresc_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$quit_cresc;

MODEND ram$quit_cresc;
*DECK DECK=RAM$QUIT_DEFO EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'Tailored Release Process:  Quit Define Order Subutility' ??
MODULE ram$quit_defo;

{ PURPOSE:
{   This module contains the procedure to end the define order subutility
{   session.
{
{ DESIGN:
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$end_scan_command_file
*copyc clp$scan_parameter_list
?? POP ??
*copyc rav$defo_utility_name

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL, #GATE] rap$quit_defo', EJECT ??

  PROCEDURE [XDCL, #GATE] rap$quit_defo
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt quit_defo_pdt (
{   status : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    quit_defo_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^quit_defo_pdt_names,
      ^quit_defo_pdt_params];

  VAR
    quit_defo_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
      clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    quit_defo_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, quit_defo_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_scan_command_file (rav$defo_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$quit_defo;
MODEND ram$quit_defo;
*DECK DECK=RAM$QUIT_DEFS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'DEFINE_SUBPRODUCT Subutility: QUIT Subcommand.' ??
MODULE ram$quit_defs;

{ PURPOSE:
{   This module contains the procedure to end the define subproduct subutility
{   session.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$package_software_cc
*copyc rat$path
?? POP ??
*copyc clp$end_scan_command_file
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$generate_error_message
*copyc rap$write_subproduct_info_file
*copyc rav$defs_utility_name
*copyc rav$subproduct_info_pointers
*copyc rav$pacs_catalog_ref_p
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$quit_defs', EJECT ??

{ PURPOSE:
{   This interface completes the define subproduct processing.
{
{ DESIGN:
{   When WRITE_FILE parameter is specified true, the subproduct is verified
{   to be defined and the subproduct information file is written.  The
{   DEFINE_SUBPRODUCT utility is then closed.
{
{   If WRITE_FILE is FALSE, the DEFINE_SUBPRODUCT utility is closed.  No
{   subproduct information file is written.
{
{ NOTES:
{   The format conversion of the PACS catalog path from an
{   fst$file_reference to rat$path eliminates the need for a scratch
{   sequence to store the FS format when traversing through the element
{   list.
{

  PROCEDURE [XDCL] rap$quit_defs
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE quid_pdt (
{   write_file, wf: boolean = true
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          default_value: string (4),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 7, 25, 14, 39, 46, 169], clc$command, 3, 2, 0, 0, 0, 0, 2, 'QUID_PDT'],
            [['STATUS                         ', clc$nominal_entry, 2],
            ['WF                             ', clc$abbreviation_entry, 1],
            ['WRITE_FILE                     ', clc$nominal_entry, 1]], [
{ PARAMETER 1
      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 4],
{ PARAMETER 2
      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$boolean_type], 'true'],
{ PARAMETER 2
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$write_file = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      defined: boolean,
      local_status: ost$status,
      pacs_catalog: rat$path;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$write_file].value^.boolean_value.value THEN
      pacs_catalog.path := rav$pacs_catalog_ref_p^;
      pacs_catalog.size := #SIZE (rav$pacs_catalog_ref_p^);

      verify_subproduct_defined (pacs_catalog, rav$subproduct_info_pointers, defined);

      IF defined THEN

        rap$write_subproduct_info_file (pacs_catalog, rav$subproduct_info_pointers, status);

      ELSE
        osp$set_status_abnormal ('RA', rae$subproduct_not_defined, '', status);
      IFEND;
    IFEND;

    clp$end_scan_command_file (rav$defs_utility_name, local_status);
    IF status.normal THEN
      status := local_status;
    IFEND;

  PROCEND rap$quit_defs;

?? OLDTITLE ??
?? NEWTITLE := 'verify_elements_defined', EJECT ??

{ PURPOSE:
{   This procedure validates that all the required fields in the element
{   list have been filled.
{
{ DESIGN:
{   If the element is a file, a procedure is called to check all the fields
{   that a file element contains.  If the element is a catalog and it
{   contains files, VERIFY_ELEMENTS_DEFINED is called recursively.
{
{ NOTES:
{   The #SPOIL's around the assignment of the CURRENT_ELEMENT_P prevents a
{   cybil bug from occuring when compiled with opt=high.  These statements
{   can be removed when PSR CILB431 is answered.
{

  PROCEDURE verify_elements_defined
    (    catalog_permit_exists: boolean;
         installation_path_indexer: rat$path_container_indexer;
         path_container_p: ^rat$path_container;
         element_path: rat$path;
         element_p: ^rat$element;
     VAR subproduct_info_seq_p {input} : ^rat$subproduct_info_sequence;
     VAR defined: boolean);


    VAR
      current_element_p: ^rat$element,
      current_element_path: rat$path,
      first_element_down_p: ^rat$element,
      next_catalog_permit_exists: boolean;

    current_element_p := element_p;

    WHILE current_element_p <> NIL DO

      STRINGREP (current_element_path.path, current_element_path.size, element_path.
            path (1, element_path.size), '.', current_element_p^.
            name (1, clp$trimmed_string_size (current_element_p^.name)));

      IF current_element_p^.element_type = rac$file THEN

        verify_file_defined (catalog_permit_exists, installation_path_indexer, path_container_p,
              current_element_path, current_element_p, defined);

      ELSEIF (current_element_p^.element_type = rac$catalog) AND (current_element_p^.element_count <> 0) THEN
        next_catalog_permit_exists := (current_element_p^.permit.defined OR catalog_permit_exists);
        first_element_down_p := #PTR (current_element_p^.first_element_down_p, subproduct_info_seq_p^);

        verify_elements_defined (next_catalog_permit_exists, installation_path_indexer, path_container_p,
              current_element_path, first_element_down_p, subproduct_info_seq_p, defined);
      IFEND;

      #SPOIL (current_element_p);
      current_element_p := #PTR (current_element_p^.next_element_across_p, subproduct_info_seq_p^);
      #SPOIL (current_element_p);

    WHILEND;

  PROCEND verify_elements_defined;

?? OLDTITLE ??
?? NEWTITLE := 'verify_file_defined', EJECT ??

{ PURPOSE:
{   This procedure validates each required field in the element list for a
{   FILE.
{
{ DESIGN:
{   This procedure verifies that permits and ring attributes are correctly
{   defined for a FILE.
{
{ NOTES:
{   ** When library merge is implimented it will be validated as well.  The
{      parameters INSTALLATION PATH_INDEXER and PATH_CONTAINER_P are setup to
{      support library merge.  The actual code to validate the libary merge is
{      not, because the path container format is going to change.  See the
{      section below.
{

  PROCEDURE verify_file_defined
    (    catalog_permit_exists: boolean;
         installation_path_indexer: rat$path_container_indexer;
         path_container_p: ^rat$path_container;
         element_path: rat$path;
     VAR element_p: ^rat$element;
     VAR defined: boolean);


    VAR
      ignore_status: ost$status,
      length: integer,
      local_status: ost$status;


    { Verify file permits are defined.

    IF (NOT element_p^.permit.defined) AND (NOT catalog_permit_exists) THEN
      osp$set_status_abnormal ('RA', rae$attribute_required, 'Permit', local_status);
      osp$append_status_file (osc$status_parameter_delimiter, element_path.path (1, element_path.size),
            local_status);
      osp$generate_error_message (local_status, ignore_status);
      defined := FALSE;
    IFEND;

    { Verify ring attributes are defined.

    IF element_p^.ring_attributes.r1 = osc$invalid_ring THEN
      osp$set_status_abnormal ('RA', rae$attribute_required, 'Ring Attributes', local_status);
      osp$append_status_file (osc$status_parameter_delimiter, element_path.path (1, element_path.size),
            local_status);
      osp$generate_error_message (local_status, ignore_status);
      defined := FALSE;
    IFEND;

    { Verify library merge is correctly defined.

    {  ** To be implimented.  When library merge has been defined for this
    {  element it will be validated (ie.  the library merge path indexer
    {  for the file is not 0).  To validate, the family and user names for
    {  the library specified by the library merge path must equal
    {  :$SYSTEM.$SYSTEM or they must equal those defined for the
    {  installation path.  When this is not the case generate an error
    {  message using condition RAE$BAD_MASTER_CATALOG_FOR_LIB (in the same
    {  manner as for the other tests).

  PROCEND verify_file_defined;

?? OLDTITLE ??
?? NEWTITLE := 'verify_subproduct_defined', EJECT ??

{ PURPOSE:
{   This procedure validates that the subproduct attributes record and the
{   element list have been properly defined.
{
{ DESIGN:
{   If the subproducts licensed product field has a valid value then all of
{   the attributes have been defined.  Another procedure is called to
{   validate the element list.
{
{ NOTES:
{
{

  PROCEDURE verify_subproduct_defined
    (    pacs_catalog: rat$path;
     VAR subproduct_info_pointers {input} : rat$subproduct_info_pointers;
     VAR defined: boolean);


    VAR
      ignore_status: ost$status,
      local_status: ost$status;


    defined := TRUE;

    IF subproduct_info_pointers.attributes_p^.licensed_product = '' THEN
      osp$set_status_abnormal ('RA', rae$command_defsa_required, '', local_status);
      osp$generate_error_message (local_status, ignore_status);
      defined := FALSE;
      RETURN;
    IFEND;

    verify_elements_defined (subproduct_info_pointers.attributes_p^.catalog_permit.defined,
          subproduct_info_pointers.attributes_p^.installation_path, subproduct_info_pointers.path_container_p,
          pacs_catalog, subproduct_info_pointers.element_list_p,
          subproduct_info_pointers.subproduct_info_seq_p, defined);

  PROCEND verify_subproduct_defined;
MODEND ram$quit_defs;

*DECK DECK=RAM$QUIT_EXEIP EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'EXECUTE_INSTALLER_PROCEDURE Utility: QUIT Subcommand.' ??
MODULE ram$quit_exeip;

{ PURPOSE:
{   This module contains the command interface to end an EXECUTE_INSTALLER_PROCEDURE
{   utility session.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
?? POP ??
*copyc clp$end_include
*copyc clp$evaluate_parameters
*copyc rav$exeip_utility_name

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$quit_exeip', EJECT ??

{ PURPOSE:
{   This command interface exits an EXECUTE_INSTALLER_PROCEDURE utility session.
{
{ DESIGN:
{   The utility termination follows standard utility design.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$quit_exeip
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE qui_pdt (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 5, 3, 7, 43, 49, 918], clc$command, 1, 1, 0, 0, 0, 0, 1, 'QUI_PDT'],
            [['STATUS                         ', clc$nominal_entry, 1]], [
{ PARAMETER 1
      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_include (rav$exeip_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$quit_exeip;
MODEND ram$quit_exeip;
*DECK DECK=RAM$QUIT_INSS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: QUIT Subcommand.' ??
MODULE ram$quit_inss;

{ PURPOSE:
{   This module contains the command interface to end an INSTALL_SOFTWARE
{   utility session.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
?? POP ??
*copyc clp$end_include
*copyc clp$evaluate_parameters
*copyc rav$inss_utility_name

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$quit_inss', EJECT ??

{ PURPOSE:
{   This command interface exits an INSTALL_SOFTWARE utility session.
{
{ DESIGN:
{   The utility termination follows standard utility design.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$quit_inss
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE qui_pdt (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 5, 3, 7, 43, 49, 918], clc$command, 1, 1, 0, 0, 0, 0, 1, 'QUI_PDT'],
            [['STATUS                         ', clc$nominal_entry, 1]], [
{ PARAMETER 1
      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],
{ PARAMETER 1
      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_include (rav$inss_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$quit_inss;
MODEND ram$quit_inss;
*DECK DECK=RAM$QUIT_PACKAGE_CORRECTIONS EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$quit_package_corrections;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc rac$status_id
*copyc rae$error_messages
*copyc rav$correction_package_header
*copyc rav$pc_var_decs_xref
*copyc clp$scan_parameter_list
*copyc clp$end_scan_command_file
*copyc osp$set_status_abnormal
?? POP ??

{ pdt quit_pdt (
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    quit_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^quit_pdt_names, ^quit_pdt_params];

  VAR
    quit_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
      clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    quit_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

*copyc rah$quit_package_corrections

  PROCEDURE [XDCL] rap$quit_package_corrections (parameter_list: clt$parameter_list;
    VAR status: ost$status);

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, quit_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_scan_command_file (pc_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF rav$correction_package_header^.number_of_elements > 0 THEN
      osp$set_status_abnormal (rac$status_id, rae$cor_package_not_generated, '', status);
      RETURN;
    IFEND;
  PROCEND rap$quit_package_corrections;
MODEND ram$quit_package_corrections;
*DECK DECK=RAM$QUIT_PACS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: QUIT Subcommand.' ??
MODULE ram$quit_pacs;

{ PURPOSE:
{   This module contains the procedure to end the package software
{   utility session.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$end_scan_command_file
*copyc clp$scan_parameter_list
?? POP ??
*copyc rav$pacs_utility_name

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$quit_pacs', EJECT ??

  PROCEDURE [XDCL] rap$quit_pacs
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ pdt quit_pacs_pdt (
{   status : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    quit_pacs_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^quit_pacs_pdt_names,
      ^quit_pacs_pdt_params];

  VAR
    quit_pacs_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
      clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    quit_pacs_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??


    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, quit_pacs_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_scan_command_file (rav$pacs_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$quit_pacs;
MODEND ram$quit_pacs;
*DECK DECK=RAM$QUIT_REPLACE EXPAND=TRUE
PROCEDURE quit_replace, quir, qr

  IF $utility(name) = 'SCU_EDIT' THEN
    "$FORMAT=OFF"
    VAR
      y_or_n  : string 1..1
    VAREND
    "$FORMAT=ON"

    IF $current_object_type = 'FILE' THEN
      IF $file($fname($current_object), assigned) THEN
        end_file write_file=true
      ELSE
        IF $file($command_of_caller, device_class) = 'MASS_STORAGE' THEN
          EXIT quit_replace WITH $status(false, 'QR', 1001, ' File does not exist.')
        IFEND
        IF $screen_active THEN
          y_or_n = $si(' File does not exist.  Reply Y to create file or N to resume session.')
        ELSE
          put_line ' File does not exist.  Reply Y to create file or N to resume session.'
          get_line variable=y_or_n i=$input prompt='? '
        IFEND
        IF y_or_n = 'Y' OR y_or_n = 'y' THEN
          end_file write_file=true
        IFEND
      IFEND
    ELSE
      IF $current_object_type = 'DECK' THEN
        IF $file($command_of_caller, device_class) = 'MASS_STORAGE' THEN
          EXIT quit_replace WITH $status(false, 'QR', 1002, ' This command is not applicable for decks.')
        IFEND
        IF $screen_active THEN
          put_row text=' This command is not applicable for decks.' row=$message_row
        ELSE
          put_line ' This command is not applicable for decks.'
        IFEND
      IFEND
    IFEND

    IF $current_object_type = 'NULL' THEN
      "$FORMAT=OFF"
      quit write_file=false
      "$FORMAT=ON"
    IFEND

  IFEND

PROCEND quit_replace
*DECK DECK=RAM$READ_TAILORED_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: READ_TAILORED_FILE Subcommand.' ??
MODULE ram$read_tailored_file;

{ PURPOSE:
{   This module contains the command interface that reads a tailored file.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{   This module makes extensive use of existing data structures and
{   procedures that are part of the tailored release utility INSTALL
{   SOFTWARE.  A related procedure in INSTALL_SOFTWARE, INSTALL_PRODUCT,
{   was used as a basis to write this module.  Many of the same steps
{   are performed in both modules to read a product tape and copy the
{   contents to some catalog structure.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$control_job_identifier
*copyc rac$sif_file_name
*copyc rac$special_product_designators
*copyc rae$install_software_cc
*copyc rae$package_software_cc
*copyc rat$installation_control_record
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc pfp$convert_string_to_fs_path
*copyc rap$convert_path_to_pf_format
*copyc rap$convert_path_to_str
*copyc rap$init_processing_seq
*copyc rap$load_products
*copyc rap$verify_catalog_exists
*copyc rap$verify_subproduct_interface
*copyc rap$write_file_from_memory
*copyc rav$installation_defaults
*copyc rav$subproduct_type
?? OLDTITLE, NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    rat#subprod_qualifier_catalogs = record
      kind: rat#qualifier_catalogs_kinds,
      user_specified: rat$path,
    recend;

  TYPE
    rat#qualifier_catalogs_kinds = (rac#none, rac#level_and_type, rac#user_specified);

?? OLDTITLE, NEWTITLE := '[XDCL] rap$read_tailored_file', EJECT ??

{ PURPOSE:
{   This command interface reads a file or tape generated by the tailored
{   release process, and re-creates the subproducts' PACS catalogs, with
{   their subproduct information files as they would appear at the time
{   the tailored file or tape was generated.
{
{ DESIGN:
{   The processing of any read request is controlled by a
{   reading control record.  The reading control record contains
{   or has access to all pertainent information (including direct access to
{   information in the packing list).
{
{   The reading control record contains pointers to the packing list,
{   the processing sequence and the job status record (in the processing
{   summary file).
{
{   The initial setup prior to performing the reading is:
{
{     1.  Separate the packing list value, entered as a parameter to this
{         routine, into two parts: the part representing the path to the
{         packing list, and the other representing the actual name of the
{         packing list.  This is done in order to interface with existing
{         install software procedures which require this format.
{
{     2.  Initialize the memory sequence for the reading control record,
{         and create a scratch segment required by load products.
{
{     3.  Open the packing list, and fill the reading control record
{         with values from the packing list.
{
{     4.  Perform necessary initialization steps.  This is based on the
{         PRODUCT parameter which allows the caller to specify a subset
{         of subproducts to read from the order.
{
{     When reading of the file/tape begins, the following steps occur:
{
{     5.  Load the subproducts from the file/tape into the catalog path
{         specified by the CATALOG parameter and the
{         SUBPRODUCT_QUALIFIER_CATALOGS (SQC) parameter.  The SQC parameter
{         further defines the catalog structure into which the products are
{         loaded.
{
{     6.  Re-create a subproduct_information_file (SIF) for each subproduct
{         loaded, and write this permanent file into the PACS catalog
{         structure just loaded.
{
{     7.  Finally, the packing list is closed, and the reading control
{         sequence and scratch segment are deleted.
{
{ NOTES:
{   This command interface utilizes existing routines that are part of the
{   install software utility.  As a result, several coding practices are
{   present which accomodate this fact.
{
{   The scratch segment is used for the processing sequence and is created
{   in RAP$INIT_PROCESSING_SEQ.
{

  PROCEDURE [XDCL] rap$read_tailored_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE reatf_pdt (
{   packing_list, pl: file = $required
{   catalog, c: file = $required
{   subproduct_qualifier_catalogs, sqc: any of
{       key
{         none, level_and_type
{       keyend
{       list of name
{     anyend = level_and_type
{   product, products, p: any of
{       key
{         all
{       keyend
{       list of name
{     anyend = all
{   status
{   )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: 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 .. 2] 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (14),
      recend,
      type4: 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,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        default_value: string (3),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [88, 12, 7, 15, 53, 25, 196],
    clc$command, 10, 5, 2, 0, 0, 0, 5, ''], [
    ['C                              ',clc$abbreviation_entry, 2],
    ['CATALOG                        ',clc$nominal_entry, 2],
    ['P                              ',clc$abbreviation_entry, 4],
    ['PACKING_LIST                   ',clc$nominal_entry, 1],
    ['PL                             ',clc$abbreviation_entry, 1],
    ['PRODUCT                        ',clc$nominal_entry, 4],
    ['PRODUCTS                       ',clc$alias_entry, 4],
    ['SQC                            ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['SUBPRODUCT_QUALIFIER_CATALOGS  ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 122,
  clc$optional_default_parameter, 0, 14],
{ PARAMETER 4
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 85,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['LEVEL_AND_TYPE                 ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'level_and_type'],
{ PARAMETER 4
    [[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]]
      ],
    21, [[1, 0, clc$list_type], [5, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$name_type], [1, osc$max_name_size]]
      ]
    ,
    'all'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$packing_list = 1,
      p$catalog = 2,
      p$subproduct_qualifier_catalogs = 3,
      p$product = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;


    VAR
      called_from_package_software: boolean,
      calling_command: rat$installation_commands,
      file_opened: boolean,
      i: integer,
      ignore_command_compatible_type: rat$subproduct_type,
      ignore_save_previous_cycles: boolean,
      ignore_status: ost$status,
      installation_tasks: rat$task_selections,
      job_status_record: rat$job_status_record,
      local_status: ost$status,
      multiple_job_processing: boolean,
      number_of_steps: rat$step_count,
      packing_list_fid: amt$file_identifier,
      packing_list_file_name: ost$name,
      pacs_catalog_path: rat$path,
      reading_control_record: rat$installation_control_record,
      reading_control_segment_ptr: amt$segment_pointer,
      scratch_segment_pointer: amt$segment_pointer,
      sifs_failed_writing: boolean,
      subproducts_failed_loading: boolean;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to return the scratch
{   segment and reading control sequence, and close the
{   packing list file when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF reading_control_segment_ptr.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (reading_control_segment_ptr, ignore_status);
        reading_control_segment_ptr.sequence_pointer := NIL;
      IFEND;

      IF scratch_segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (scratch_segment_pointer, ignore_status);
        scratch_segment_pointer.sequence_pointer := NIL;
      IFEND;

      fsp$close_file (packing_list_fid, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { The reading control record must be initialized here for use in the
    { main block.

    { The following commented statement will replace the one following it
    { as soon as the appropriate constant is added to the installation
    { command type declaration.
    { calling_command := rac$read_tailored_file;

    calling_command := rac$install_product;
    ignore_command_compatible_type := rac$release;
    ignore_save_previous_cycles := FALSE;

    job_status_record.job_identifier := rac$control_job_identifier;
    job_status_record.number_of_steps := 1;
    job_status_record.step_number := 0;

    reading_control_record.job_identifier := job_status_record.job_identifier;
    reading_control_record.job_status_record_p := ^job_status_record;
    reading_control_segment_ptr.kind := amc$sequence_pointer;
    reading_control_segment_ptr.sequence_pointer := NIL;

    scratch_segment_pointer.kind := amc$sequence_pointer;
    scratch_segment_pointer.sequence_pointer := NIL;

    sifs_failed_writing := FALSE;
    subproducts_failed_loading := FALSE;
    file_opened := FALSE;
    called_from_package_software := TRUE;

    { This module does not do a true product installation, but rather
    { a loading of subproducts into a catalog structure from which
    { customer orders can be generated.  Therefore, the storage
    { class must be ignored.

    rav$installation_defaults.ignore_storage_class := TRUE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, scratch_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      reading_control_record.scratch_seq_p := scratch_segment_pointer.sequence_pointer;

      RESET reading_control_record.scratch_seq_p;

      separate_catalog_from_file_name (pvt [p$packing_list].value^.file_value,
            rav$installation_defaults.installation_database, packing_list_file_name, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$init_processing_seq (packing_list_file_name, ignore_save_previous_cycles, calling_command,
            ignore_command_compatible_type, rav$installation_defaults, reading_control_record,
            reading_control_segment_ptr, packing_list_fid, file_opened, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      initialize_for_product_load (pvt [p$catalog].value^.file_value,
            pvt [p$subproduct_qualifier_catalogs].value, pvt [p$product].value, reading_control_record,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$load_products (called_from_package_software, reading_control_record,
            subproducts_failed_loading, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF subproducts_failed_loading THEN
        osp$set_status_abnormal ('RA', rae$reatf_load_failure, '', local_status);
        osp$generate_error_message (local_status, ignore_status);
      IFEND;

      recreate_subproduct_sifs (reading_control_record.subproduct_processing_records_p, sifs_failed_writing,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

    END /main/;

    IF status.normal AND (subproducts_failed_loading OR sifs_failed_writing) THEN
      osp$set_status_abnormal ('RA', rae$pacs_catalogs_not_restored, '', status);
    IFEND;

    IF file_opened THEN
      fsp$close_file (packing_list_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF reading_control_segment_ptr.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (reading_control_segment_ptr, local_status);
      reading_control_segment_ptr.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF scratch_segment_pointer.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (scratch_segment_pointer, local_status);
      scratch_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$read_tailored_file;

?? OLDTITLE, NEWTITLE := 'assemble_pacs_catalog', EJECT ??

{ PURPOSE:
{   This procedure assembles the PACS catalog path for the subproduct.
{
{ DESIGN:
{   The PACS catalog path is assembled by taking the CATALOG_P path,
{   appending the subproduct's name and one of the following three cases
{   based on the subproduct qualifier catalog specified.  If the subproduct
{   qualifier catalog is specified as level and type, the subproduct's level
{   and type (from the SIF) are appended to the PACS catalog path.  If
{   subproduct qualifier catalog is a list of names, these names are
{   appended to the PACS catalog path.  When the subproduct qualifier
{   catalog is specified as none, nothing is added to the PACS catalog path.
{
{   The subproduct's PACS catalog is stored in the processing sequence.  The
{   catalog is verified to not exist.
{
{ NOTES:
{

  PROCEDURE assemble_pacs_catalog
    (    catalog_p: ^fst$file_reference;
         subproduct_qualifier_catalogs: rat#subprod_qualifier_catalogs;
         subproduct_name: rat$subproduct_name;
         subproduct_level: rat$subproduct_level;
         subproduct_type: rat$subproduct_type;
     VAR pacs_catalog_p: ^pft$path;
     VAR processing_seq_p: ^rat$processing_sequence;
     VAR scratch_seq_p: ^SEQ ( * );
     VAR subproduct_validation_error: boolean;
     VAR status: ost$status);


    VAR
      catalog_exists: boolean,
      ignore_status: ost$status,
      local_status: ost$status,
      pacs_catalog: rat$path;


    status.normal := TRUE;
    subproduct_validation_error := FALSE;

    { Assign the PACS catalog path for the subproduct.

    IF subproduct_qualifier_catalogs.kind = rac#level_and_type THEN

      { Concatenate the catalog with the subproduct name, level and type
      { (in that order) to form the PACS catalog path for the subproduct
      { selected for loading.

      STRINGREP (pacs_catalog.path, pacs_catalog.size, catalog_p^, '.',
            subproduct_name (1, clp$trimmed_string_size (subproduct_name)),
            '.', subproduct_level (1, clp$trimmed_string_size (subproduct_level)),
            '.', rav$subproduct_type [subproduct_type] (1, clp$trimmed_string_size
            (rav$subproduct_type [subproduct_type])));

    ELSEIF subproduct_qualifier_catalogs.kind = rac#none THEN

      { Concatenate the catalog with the subproduct name to form the
      { PACS catalog path for the subproduct selected for loading.

      STRINGREP (pacs_catalog.path, pacs_catalog.size, catalog_p^, '.',
            subproduct_name (1, clp$trimmed_string_size (subproduct_name)));

    ELSE { subproduct_qualifier_catalogs.kind = rac#user_specified }

      { Concatenate the catalog with the subproduct name and the user
      { specified qualifier_catalogs to form the PACS catalog path for the
      { subproduct selected for loading.

      STRINGREP (pacs_catalog.path, pacs_catalog.size, catalog_p^, '.',
            subproduct_name (1, clp$trimmed_string_size (subproduct_name)),
            subproduct_qualifier_catalogs.user_specified.path
            (1, subproduct_qualifier_catalogs.user_specified.size));

    IFEND;

    { Convert the PACS catalog path from a string to PF format and
    { store in the installation catalog path in the reading control
    { record.  This store is made to accomodate subsequent processing
    { which requires this value.

    rap$convert_path_to_pf_format (pacs_catalog, pacs_catalog_p, processing_seq_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { At this point, a check is made to determine if the PACS catalog
    { exists.  If it does, an error message is logged, and a RETURN
    { issued to terminate processing.  The PACS catalog cannot exist prior
    { to the initiation of the reading of a product tape.  See the notes above
    { for more details.

    rap$verify_catalog_exists (pacs_catalog_p^, scratch_seq_p, catalog_exists);
    IF catalog_exists THEN
      osp$set_status_abnormal ('RA', rae$pacs_catalog_already_exists, '', local_status);
      osp$append_status_file (osc$status_parameter_delimiter, pacs_catalog.path (1, pacs_catalog.size),
            local_status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            subproduct_name (1, clp$trimmed_string_size (subproduct_name)), local_status);
      osp$generate_error_message (local_status, ignore_status);
      subproduct_validation_error := TRUE;
      RETURN;
    IFEND;

  PROCEND assemble_pacs_catalog;

?? OLDTITLE, NEWTITLE := 'format_qualifier_catalogs_input', EJECT ??

{ PURPOSE:
{   This procedure reformats the SUBPRODUCT_QUALIFIER_CATALOG parameter
{   input for processing.
{
{ DESIGN:
{   When the qualifier catalog input is a keyword the related module level
{   constant is assigned.  When the qualifier catalog input is a list of
{   names, the names are assembled into a path.  Each name represents a
{   subcatalog.
{
{ NOTES:
{

  PROCEDURE format_qualifier_catalogs_input
    (    qualifier_catalogs_input_p: ^clt$data_value;
     VAR subproduct_qualifier_catalogs: rat#subprod_qualifier_catalogs);


    VAR
      current_p: ^clt$data_value,
      length: integer,
      next_position: integer;


    IF qualifier_catalogs_input_p^.kind = clc$keyword THEN

      IF qualifier_catalogs_input_p^.keyword_value = 'NONE' THEN
        subproduct_qualifier_catalogs.kind := rac#none;
      ELSE { qualifier_catalogs_input_p^.keyword_value = 'LEVEL_AND_TYPE' }
        subproduct_qualifier_catalogs.kind := rac#level_and_type;
      IFEND;

      subproduct_qualifier_catalogs.user_specified.size := 0;

    ELSE {list of names specified}

      subproduct_qualifier_catalogs.kind := rac#user_specified;

      next_position := 1;
      current_p := qualifier_catalogs_input_p;
      WHILE current_p <> NIL DO

        length := clp$trimmed_string_size (current_p^.element_value^.name_value);

        subproduct_qualifier_catalogs.user_specified.path (next_position, * ) := '.';
        next_position := next_position + 1;
        subproduct_qualifier_catalogs.user_specified.path (next_position, * ) :=
              current_p^.element_value^.name_value (1, length);
        next_position := next_position + length;

        current_p := current_p^.link;
      WHILEND;

      subproduct_qualifier_catalogs.user_specified.size := next_position - 1;

    IFEND;

  PROCEND format_qualifier_catalogs_input;

?? OLDTITLE, NEWTITLE := 'initialize_for_product_load', EJECT ??

{ PURPOSE:
{   This procedure performs all necessary initialization steps
{   prior to reading the subproducts into the appropriate catalog
{   structure.
{
{ DESIGN:
{   This procedure performs all the required initialization steps prior
{   to reading the product tape.
{
{   The job processing record is established.  Only a single job is used to
{   read in the tailored tape; therefore, only one record is defined, and
{   the appropriate job identifier is defined.
{
{   The subproduct qualifier catalogs parameter is reformated for subsequent
{  processing.
{
{   The subproduct processing records are established.  One record is
{   defined for each subproduct referenced by the product list.
{
{ NOTES:
{

  PROCEDURE initialize_for_product_load
    (    catalog_p: ^fst$file_reference;
         qualifier_catalogs_input_p: ^clt$data_value;
         product_list_p: ^clt$data_value;
     VAR reading_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      subproduct_qualifier_catalogs: rat#subprod_qualifier_catalogs;


    status.normal := TRUE;

    { Establish the step set and number of steps values.  The only step being performed
    { is to load subproducts.

    reading_control_record.processing_header_p^.step_set := $rat$step_selections [rac$load_subproducts_step];
    reading_control_record.processing_header_p^.number_of_steps := 1;

    { Establish the job processing record.  Only one job is used to read the tape.

    NEXT reading_control_record.job_processing_records_p: [1 .. 1] IN reading_control_record.processing_seq_p;
    IF reading_control_record.job_processing_records_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'PROCESSING SEQUENCE', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'JOB PROCESSING RECORDS', status);
      RETURN;
    IFEND;

    reading_control_record.processing_header_p^.job_processing_rec_rel_p :=
          #REL (reading_control_record.job_processing_records_p, reading_control_record.processing_seq_p^);

    reading_control_record.job_processing_records_p^ [1].job_identifier :=
          reading_control_record.job_identifier;


    format_qualifier_catalogs_input (qualifier_catalogs_input_p, subproduct_qualifier_catalogs);

    process_product_list (product_list_p, catalog_p, subproduct_qualifier_catalogs, reading_control_record,
          status);

  PROCEND initialize_for_product_load;

?? OLDTITLE, NEWTITLE := 'initialize_for_subproduct_load', EJECT ??

{ PURPOSE:
{   This procedure registers the subproduct as selected for reading.  Any
{   validation errors encountered are flagged.
{
{ DESIGN:
{   This procedure assembles the subproduct's PACS path and sets the
{   required task and job information to get that subproduct read.
{
{   The subproduct count for the appropriate medium processing record is
{   incremented.  If the medium is tape the subproduct count for the primary
{   tape that the subproduct resides is incremented.  For disk orders there
{   is only 1 medium processing record.
{
{ NOTES:
{

  PROCEDURE initialize_for_subproduct_load
    (    packing_list_pointers: rat$packing_list_pointers;
         subproduct_index: rat$subproduct_count;
         catalog_p: ^fst$file_reference;
         subproduct_qualifier_catalogs: rat#subprod_qualifier_catalogs;
         job_identifier: rat$job_identifier;
         medium_processing_records_p { input, output } : ^rat$medium_processing_records;
     VAR subproduct_processing_record { input, output } : rat$subp_processing_record;
     VAR processing_seq_p: ^rat$processing_sequence;
     VAR scratch_seq_p: ^SEQ ( * );
     VAR subproduct_validation_error: boolean;
     VAR status: ost$status);


    VAR
      medium_index: rat$tape_count;


    status.normal := TRUE;
    subproduct_validation_error := FALSE;

    { Assign the PACS catalog path for the subproduct.

    assemble_pacs_catalog (catalog_p, subproduct_qualifier_catalogs,
          subproduct_processing_record.subproduct_info_pointers.attributes_p^.name,
          subproduct_processing_record.subproduct_info_pointers.attributes_p^.level,
          subproduct_processing_record.subproduct_info_pointers.attributes_p^.subproduct_type,
          subproduct_processing_record.installation_catalog_p, processing_seq_p, scratch_seq_p,
          subproduct_validation_error, status);
    IF (NOT status.normal) OR (subproduct_validation_error) THEN
      RETURN;
    IFEND;

    { Assign the installation task set and user reference (product type) to the subproduct.

    subproduct_processing_record.task_set := $rat$task_selections [rac$load_files_task];
    subproduct_processing_record.task_status := rac$task_started;

    { Increment the appropriate medium processing record's subproduct count and
    { set the job identifier.

    IF packing_list_pointers.order_medium = rac$tape THEN
      medium_index := packing_list_pointers.tape_subproduct_indexer_p^ [subproduct_index].primary_tape_vsn;
    ELSE { order medium = rac$disk }
      medium_index := 1;
    IFEND;

    medium_processing_records_p^ [medium_index].subproduct_count :=
          medium_processing_records_p^ [medium_index].subproduct_count + 1;
    medium_processing_records_p^ [medium_index].job_identifier := job_identifier;

    { Assign the job responsible to load the subproduct.

    subproduct_processing_record.job_identifier := job_identifier;

  PROCEND initialize_for_subproduct_load;

?? OLDTITLE, NEWTITLE := 'process_product_list', EJECT ??

{ PURPOSE:
{   This procedure initializes the subproduct processing records based on
{   the product list.
{
{ DESIGN:
{   The appropriate product list processing procedure is called (key ALL or
{   names).  When the product list is a list of names the product list is
{   checked for keyword ALL.  An error is returned if names are specified
{   with keyword ALL.
{
{ NOTES:
{   ** We need to test that we won't be trying to load into the same PACS
{   catalog.  This can occur when a tailored file contains both a release
{   and a correction for the same subproduct and the subproduct qualifier
{   catalogs is not LEVEL_AND_TYPE.  If this condition is detected we should
{   flag it as a validation error.
{

  PROCEDURE process_product_list
    (    product_list_p: ^clt$data_value;
         catalog_p: ^fst$file_reference;
         subproduct_qualifier_catalogs: rat#subprod_qualifier_catalogs;
     VAR reading_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      current_p: ^clt$data_value;


    status.normal := TRUE;

    { Process the product list based on whether its the keyword ALL or a list of names.

    IF product_list_p^.kind = clc$keyword THEN

      process_product_list_all (catalog_p, subproduct_qualifier_catalogs, reading_control_record, status);

    ELSE {list of names specified}

      { Test that key ALL is not specified along with product names.

      current_p := product_list_p;
      WHILE current_p <> NIL DO
        IF current_p^.element_value^.name_value = 'ALL' THEN
          osp$set_status_abnormal ('RA', rae$specified_names_and_key_all, '', status);
          RETURN;
        IFEND;
        current_p := current_p^.link;
      WHILEND;

      process_product_list_names (product_list_p, catalog_p, subproduct_qualifier_catalogs,
            reading_control_record, status);

    IFEND;

  PROCEND process_product_list;

?? OLDTITLE, NEWTITLE := 'process_product_list_all', EJECT ??

{ PURPOSE:
{   This procedure processes the product list as the keyword ALL.
{
{ DESIGN:
{   All subproducts known to the packing list have been selected for reading.
{
{   A validation error does not stop subproduct validation from continuing
{   but it will terminate the rest of the reading process.  This allows
{   all the validation errors to be discovered at one time.
{
{ NOTES:
{

  PROCEDURE process_product_list_all
    (    catalog_p: ^fst$file_reference;
         subproduct_qualifier_catalogs: rat#subprod_qualifier_catalogs;
     VAR reading_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      subproduct_index: rat$subproduct_count,
      subproduct_validation_error: boolean,
      validation_errors_occurred: boolean;


    status.normal := TRUE;
    validation_errors_occurred := FALSE;

  /main/
    FOR subproduct_index := 1 TO UPPERBOUND (reading_control_record.subproduct_processing_records_p^) DO

      subproduct_validation_error := FALSE;
      initialize_for_subproduct_load (reading_control_record.packing_list_pointers, subproduct_index,
            catalog_p, subproduct_qualifier_catalogs, reading_control_record.job_identifier,
            reading_control_record.medium_processing_records_p,
            reading_control_record.subproduct_processing_records_p^ [subproduct_index],
            reading_control_record.processing_seq_p, reading_control_record.scratch_seq_p,
            subproduct_validation_error, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      validation_errors_occurred := (validation_errors_occurred OR subproduct_validation_error);
    FOREND /main/;

    IF validation_errors_occurred THEN
      osp$set_status_abnormal ('RA', rae$reatf_validation_errors, 'PRODUCT', status);
    IFEND;

  PROCEND process_product_list_all;

?? OLDTITLE, NEWTITLE := 'process_product_list_names', EJECT ??

{ PURPOSE:
{   This procedure processes the product list as a list of names.
{
{ DESIGN:
{   Each name from the product list is examined to determine which
{   subproducts should be selected for the installation event.  A product
{   name can be a licensed product, subproduct or group name, which
{   references a set of one or more subproducts.  A validation error is
{   returned when the product name does not.
{
{   A validation error does not stop product list validation from continuing
{   but it will terminate the rest of the installation processing.  This
{   allows all the validation errors to be discovered at one time.
{
{ NOTES:
{

  PROCEDURE process_product_list_names
    (    product_list_p: ^clt$data_value;
         catalog_p: ^fst$file_reference;
         subproduct_qualifier_catalogs: rat#subprod_qualifier_catalogs;
     VAR reading_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      current_product_list_p: ^clt$data_value,
      group_name: ost$name,
      ignore_status: ost$status,
      j: 0 .. rac$max_additional_products,
      local_status: ost$status,
      product_name: ost$name,
      product_reference: boolean,
      subproduct_attributes_p: ^rat$subproduct_attributes,
      subproduct_index: rat$subproduct_count,
      subproduct_validation_error: boolean,
      validation_errors_occurred: boolean;


    status.normal := TRUE;
    validation_errors_occurred := FALSE;

    current_product_list_p := product_list_p;
    WHILE current_product_list_p <> NIL DO
      product_name := current_product_list_p^.element_value^.name_value;
      product_reference := FALSE;

    /main/
      FOR subproduct_index := 1 TO UPPERBOUND (reading_control_record.subproduct_processing_records_p^) DO
        subproduct_attributes_p := reading_control_record.subproduct_processing_records_p^ [subproduct_index].
              subproduct_info_pointers.attributes_p;

        subproduct_validation_error := FALSE;

        IF (product_name = subproduct_attributes_p^.licensed_product) OR
              (product_name = subproduct_attributes_p^.name) THEN
          product_reference := TRUE;
          initialize_for_subproduct_load (reading_control_record.packing_list_pointers, subproduct_index,
                catalog_p, subproduct_qualifier_catalogs, reading_control_record.job_identifier,
                reading_control_record.medium_processing_records_p,
                reading_control_record.subproduct_processing_records_p^ [subproduct_index],
                reading_control_record.processing_seq_p, reading_control_record.scratch_seq_p,
                subproduct_validation_error, status);

        ELSE {check for group name}
          group_name (1, * ) := rac$group_designator;
          group_name (clp$trimmed_string_size (rac$group_designator) + 1, * ) :=
                product_name (1, clp$trimmed_string_size (product_name));

        /group_check/
          FOR j := 1 TO UPPERBOUND (subproduct_attributes_p^.additional_products) DO
            IF group_name = subproduct_attributes_p^.additional_products [j] THEN
              product_reference := TRUE;
              initialize_for_subproduct_load (reading_control_record.packing_list_pointers, subproduct_index,
                    catalog_p, subproduct_qualifier_catalogs, reading_control_record.job_identifier,
                    reading_control_record.medium_processing_records_p,
                    reading_control_record.subproduct_processing_records_p^ [subproduct_index],
                    reading_control_record.processing_seq_p, reading_control_record.scratch_seq_p,
                    subproduct_validation_error, status);

              EXIT /group_check/;
            IFEND;
          FOREND /group_check/;

        IFEND;

        IF NOT status.normal THEN
          RETURN;
        IFEND;

        validation_errors_occurred := (validation_errors_occurred OR subproduct_validation_error);
      FOREND /main/;

      IF NOT product_reference THEN
        osp$set_status_abnormal ('RA', rae$unknown_product_name,
              product_name (1, clp$trimmed_string_size (product_name)), local_status);
        osp$generate_error_message (local_status, ignore_status);
        validation_errors_occurred := TRUE;
      IFEND;

      current_product_list_p := current_product_list_p^.link;
    WHILEND;

    IF validation_errors_occurred THEN
      osp$set_status_abnormal ('RA', rae$reatf_validation_errors, 'PRODUCT', status);
      RETURN;
    IFEND;

  PROCEND process_product_list_names;

?? OLDTITLE, NEWTITLE := 'recreate_subproduct_sifs', EJECT ??

{ PURPOSE:
{   This procedure re-creates the individual subproduct information
{   files (SIF) for each subproduct represented in reading_control_record.
{
{ DESIGN:
{   Each subproduct identifier in the packing list (ie. listed in the
{   reading control record) is processed.
{
{   The path to the PACS catalog is converted to string format
{   which is required in subsequent steps.  The name of the SIF file
{   is appended to the PACS catalog name.  The SIF data is subsequently
{   written from memory to the SIF permanent file.
{
{   The subproduct is verified via the RAP$VERIFY_SUBPRODUCT_INTERFACE
{   routine.  The verify_option RECONCILE_EFFECTS_OF_RESTORE is
{   specified to modify the SIF to reflect the new catalog structure
{   is now exists in.
{
{ NOTES:
{


  PROCEDURE recreate_subproduct_sifs
    (    subproduct_processing_records_p: ^rat$subp_processing_records;
     VAR processing_errors_occurred: boolean;
     VAR status: ost$status);


    VAR
      i: integer,
      ignore_status: ost$status,
      local_status: ost$status,
      pacs_catalog: rat$path,
      reconcile_effects_of_restore: [STATIC, READ] ost$name := 'reconcile_effects_of_restore',
      sif_identifier: ost$name,
      subproduct_info_file: rat$path,
      write_status: ost$status;


    status.normal := TRUE;
    processing_errors_occurred := FALSE;
    sif_identifier := '';

  /main/
    FOR i := 1 TO UPPERBOUND (subproduct_processing_records_p^) DO

      IF (rac$load_files_task IN subproduct_processing_records_p^ [i].task_set) AND
            (subproduct_processing_records_p^ [i].task_status <> rac$task_failed) THEN

        rap$convert_path_to_str (subproduct_processing_records_p^ [i].installation_catalog_p^, pacs_catalog);

        STRINGREP (subproduct_info_file.path, subproduct_info_file.size, pacs_catalog.
              path (1, pacs_catalog.size), '.', rac$sif_file_name);

        rap$write_file_from_memory (subproduct_info_file.path (1, subproduct_info_file.size),
              #SIZE (subproduct_processing_records_p^ [i].subproduct_info_pointers.subproduct_info_seq_p^),
              subproduct_processing_records_p^ [i].subproduct_info_pointers.subproduct_info_seq_p,
              write_status);
        IF NOT write_status.normal THEN
          osp$set_status_abnormal ('RA', rae$sif_writing_error, '', local_status);
          osp$append_status_file (osc$status_parameter_delimiter, subproduct_info_file.
                path (1, subproduct_info_file.size), local_status);
          osp$generate_error_message (local_status, ignore_status);
          osp$generate_error_message (write_status, ignore_status);
          processing_errors_occurred := TRUE;
          CYCLE /main/;
        IFEND;

        rap$verify_subproduct_interface (^pacs_catalog.path (1, pacs_catalog.size),
              reconcile_effects_of_restore, sif_identifier, local_status);
        IF NOT local_status.normal THEN
          osp$generate_error_message (local_status, ignore_status);
          processing_errors_occurred := TRUE;
        IFEND;

      IFEND;
    FOREND /main/;

  PROCEND recreate_subproduct_sifs;

?? OLDTITLE, NEWTITLE := 'separate_catalog_from_file_name', EJECT ??

{ PURPOSE:
{   This procedure separates the catalog portion of a path from the file
{   portion, and places each separate part in parameters whose values are
{   returned to the calling procedure.
{
{ DESIGN:
{   Locate the last period in the file reference parameter variable.  The
{   characters to the left of this last period represent the path to the
{   file.  The characters to the right of the this last period represent
{   the file name in the catalog.
{
{ NOTES:
{

  PROCEDURE separate_catalog_from_file_name
    (    file_reference_p: ^fst$file_reference;
     VAR catalog_path: rat$path;
     VAR file_name: ost$name;
     VAR status: ost$status);


    VAR
      fs_path: string (fsc$max_path_size),
      ignore_cycle_reference: fst$cycle_reference,
      ignore_open_position: fst$open_position,
      number_of_elements: fst$number_of_path_elements,
      position: integer;


    status.normal := TRUE;

    { The value of position will be the character position of the period separating the file's catalog
    { path from the file name (ie. the last period in the file reference) after the WHILE loop completes.

    pfp$convert_string_to_fs_path (file_reference_p^ (1, STRLENGTH (file_reference_p^)), fs_path,
          number_of_elements, ignore_cycle_reference, ignore_open_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    position := clp$trimmed_string_size (fs_path);

{   position := STRLENGTH (file_reference_p^);
    WHILE file_reference_p^ (position) <> '.' DO
      position := position - 1;
      IF position <= 0 THEN
        { Set bad status. }
        RETURN;
      IFEND;
    WHILEND;

    { Retreive the file's catalog path.

    catalog_path.path (1, * ) := file_reference_p^ (1, position - 1);
    catalog_path.size := position - 1;

    { Retreive the file's name.

    file_name (1, * ) := file_reference_p^ (position + 1, (STRLENGTH (file_reference_p^) - position));

  PROCEND separate_catalog_from_file_name;

MODEND ram$read_tailored_file;
*DECK DECK=RAM$RECONCILE_CYCLE_CONFLICTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$RECONCILE_CYCLE_CONFLICTS Interface.' ??
MODULE ram$reconcile_cycle_conflicts;

{ PURPOSE:
{   This module contains the interface and procedures that perform the step
{   to reconcile cycle conflicts.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$installation_cycles
*copyc rae$install_software_cc
*copyc rat$installation_control_record
?? POP ??
*copyc osp$generate_log_message
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc pfp$change
*copyc pfp$convert_fs_path_to_pf_path
*copyc pfp$convert_string_to_fs_path
*copyc rap$convert_path_to_str
*copyc rap$get_cycle_data
*copyc rap$record_step_status
*copyc rap$record_subproduct_status
*copyc rap$verify_catalog_exists

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    rat#cycle_map = array [1 .. rac$max_active_cycle] of boolean;

  TYPE
    rat#reconcile_options = (rac#reconcile_for_install, rac#validate_for_activation);

?? TITLE := '[XDCL] rap$reconcile_cycle_conflicts', EJECT ??

{ PURPOSE:
{   This interface controls the step to reconcile cycle conflicts.
{
{ DESIGN:
{   There are two forms of cycle reconcile:  One, to reconcile subproducts
{   for installation.  The second, to validate subproducts for activation.
{   (The rules for reconcile and validate are found within RECONCILE_FILE
{   and VALIDATE_FILE_DEFERRED procedures, respectively.)
{
{   The reconcile option is choosen based on the task set.  When the load
{   files task is in the set, reconcile for installation is choosen.  When
{   activate files task is in the task set and load files task is not,
{   validate for activation is selected.
{
{   In the event a file fails reconciling, continue processing every file,
{   return with general error message.  The subproduct associated with the
{   file will be pulled from further processing.
{
{   Any bad status encountered at lower levels has been displayed to the
{   job log before returning from  reconcile_subproduct.  A general errors
{   encountered boolean is returned to help set the task status.
{
{ NOTES:
{   Shifting files has an effect on other jobs/tasks accessing the files at
{   the time the shift is performed.  If a job/task has the file opened and
{   the cycle number is changed, that job/task will continue to access the
{   same file as long as it remains opened.  But if a job/task is accessing
{   a specific file cycle with multiple opens around the time of a cycle
{   shift, the file would become lost to the job/task.
{
{   After 1.4.1 the need to shift on a properly maintained system should be
{   very rare.  Also installations are usually done during or around
{   deadstarts when the system is closed to production events.  Therefore,
{   the occurance of the just mentioned problem should be close to nil.
{   But this situation needs to be understood by the users of INSS.
{
{   If the installation catalog (or any lower level catalog) is found to
{   not exist, processing of the remaining element list under that catalog
{   will be skipped.
{
{   The SUBPRODUCTS_FAILED_PROCESSING boolean has been initialized outside of
{   this interface and should never be re-initialized here.
{

  PROCEDURE [XDCL] rap$reconcile_cycle_conflicts
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR subproducts_failed_processing: boolean;
     VAR status: ost$status);


    VAR
      catalog_exists: boolean,
      errors_encountered: boolean,
      ignore_status: ost$status,
      local_status: ost$status,
      processing_record: rat$subp_processing_record,
      reconcile_option: rat#reconcile_options,
      subproduct_index: rat$subproduct_count,
      subproduct_info_seq_p: ^rat$subproduct_info_sequence;


    status.normal := TRUE;

    IF NOT (rac$reconcile_subproducts_step IN installation_control_record.processing_header_p^.step_set) THEN
      RETURN;
    IFEND;

    rap$record_step_status (rac$reconcile_subproducts_step, rac$step_started, installation_control_record,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /main/
    FOR subproduct_index := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^) DO
      processing_record := installation_control_record.subproduct_processing_records_p^ [subproduct_index];

      IF (installation_control_record.job_identifier = processing_record.job_identifier) AND
            (rac$reconcile_file_cycles_task IN processing_record.task_set) AND
            (processing_record.task_status <> rac$task_failed) THEN

        rap$record_subproduct_status (rac$reconcile_file_cycles_task, rac$task_started, subproduct_index,
              installation_control_record, ignore_status);

        catalog_exists := TRUE;
        errors_encountered := FALSE;

        IF rac$load_files_task IN processing_record.task_set THEN
          reconcile_option := rac#reconcile_for_install;
        ELSE {rac$activate_files_task IN processing_record.task_set}
          reconcile_option := rac#validate_for_activation;
        IFEND;

        IF reconcile_option = rac#reconcile_for_install THEN
          rap$verify_catalog_exists (processing_record.installation_catalog_p^,
                installation_control_record.scratch_seq_p, catalog_exists);
        IFEND;

        IF catalog_exists THEN
          reconcile_subproduct (reconcile_option, processing_record.installation_catalog_p^,
                processing_record.subproduct_info_pointers.element_list_p,
                processing_record.subproduct_info_pointers.subproduct_info_seq_p,
                installation_control_record.scratch_seq_p, errors_encountered);
        IFEND;

        IF (NOT catalog_exists) OR (NOT errors_encountered) THEN
          rap$record_subproduct_status (rac$reconcile_file_cycles_task, rac$task_completed, subproduct_index,
                installation_control_record, ignore_status);
        ELSE {subproduct failed processing}
          rap$record_subproduct_status (rac$reconcile_file_cycles_task, rac$task_failed, subproduct_index,
                installation_control_record, ignore_status);
          subproducts_failed_processing := TRUE;
        IFEND;

      IFEND;
    FOREND /main/;

    rap$record_step_status (rac$reconcile_subproducts_step, rac$step_completed, installation_control_record,
          local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

  PROCEND rap$reconcile_cycle_conflicts;

?? TITLE := 'compress_to_first_active_cycle', EJECT ??

{ PURPOSE:
{   This procedure compresses all cycles down, starting at the first active
{   cycle in sequential order.
{
{ DESIGN:
{   As an example of cycle compression, assume a file contains the cycles
{   5, 6, 15 and 999.  Also assume that the first active cycle is 3.  After
{   compression the file would contain cycles 3, 4, 5, and  6.
{
{   The first active cycle is one greater than the staging cycle.
{
{ NOTES:
{

  PROCEDURE compress_to_first_active_cycle
    (    file_path: pft$path;
     VAR cycle_exists {input, output} : rat#cycle_map;
     VAR status: ost$status);


    VAR
      current_cycle: pft$cycle_selector,
      cycle_number: 0 .. rac$max_active_cycle,
      first_free_cycle: 0 .. rac$max_active_cycle,
      free_cycle: 0 .. rac$max_active_cycle,
      new_cycle: array [1 .. 1] of pft$change_descriptor,
      password: pft$password;


    status.normal := TRUE;
    current_cycle.cycle_option := pfc$specific_cycle;
    new_cycle [1].change_type := pfc$cycle_number_change;
    password := '';

    { Locate the first free cycle starting after the first active cycle.  A
    { free cycle is guarenteed because of a check by calling procedure.

    cycle_number := rac$staging_cycle + 1;
    WHILE cycle_exists [cycle_number] DO
      cycle_number := cycle_number + 1;
    WHILEND;
    first_free_cycle := cycle_number;
    free_cycle := first_free_cycle;

    { Compress all the cycles that follow the first free cycle.  The cycle map
    { must be updated to reflect the change.  The next free cycle is the cycle
    { following the current free cycle.

    FOR cycle_number := (first_free_cycle + 1) TO rac$max_active_cycle DO
      IF cycle_exists [cycle_number] THEN
        current_cycle.cycle_number := cycle_number;
        new_cycle [1].cycle_number := free_cycle;
        pfp$change (file_path, current_cycle, password, new_cycle, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        cycle_exists [cycle_number] := FALSE;
        cycle_exists [free_cycle] := TRUE;

        free_cycle := free_cycle + 1;
      IFEND;
    FOREND;

  PROCEND compress_to_first_active_cycle;

?? TITLE := 'reconcile_file', EJECT ??

{ PURPOSE:
{   This procedure reconciles cycle conflicts for a file when they exist.
{
{ DESIGN:
{   The file cycles are checked for the availability of file cycles to
{   install into.  This means cycles 1, 2 and 999.
{
{   If files currently reside in any of these cycles they are shifted out of
{   the way, more precisely:
{
{     a.  If cycles 1 and/or 2 exist, they and any cycles sequentially
{     in the way are shifted up, starting at cycle 3.
{
{     b.  If a cycle 999 exists, all cycles are shifted down so that
{     the existing cycles will now occupy cycles 3 and up
{     (sequentially).
{
{     c.  If both case (a) and (b) exist, (a) is performed first and
{     then (b).  This causes the cycles to be compressed.
{
{   When there are not enough empty cycles to perform the shift, an error
{   will be reported and the affected subproduct will be dropped from any
{   further processing.
{
{ NOTES:
{   The type CYCLE_MAP is an array of booleans, one for each cycle
{   possible.  The index into the array represents a possible cycle number
{   and the boolean value defines whether or not that cycle actually
{   exists.  The use of the variable name CYCLE_EXISTS helps convey this
{   meaning when an array index, such as CYCLE_NUMBER is used.
{
{   The scratch sequence is used by GET_CYCLE_DATA as temporary storage
{   for file information.
{

  PROCEDURE reconcile_file
    (    file_path: pft$path;
     VAR scratch_seq_p {input} : ^SEQ ( * );
     VAR status: ost$status);


    VAR
      conflicting_cycles_count: 0 .. rac$staging_cycle,
      cycle_exists: rat#cycle_map,
      cycles_p: pft$p_cycle_array,
      file_fs: rat$path,
      i: 0 .. rac$max_active_cycle,
      number_of_cycles: 0 .. rac$max_active_cycle;


    status.normal := TRUE;

    rap$get_cycle_data (file_path, scratch_seq_p, cycles_p, status);
    IF NOT status.normal THEN
      IF (status.condition = pfe$unknown_permanent_file) OR
            (status.condition = pfe$unknown_last_subcatalog) OR
            (status.condition = pfe$unknown_nth_subcatalog) OR
            (status.condition = pfe$unknown_master_catalog) OR (status.condition = pfe$unknown_family) THEN
        status.normal := TRUE;
      IFEND;
      RETURN;
    IFEND;

    number_of_cycles := UPPERBOUND (cycles_p^);

    IF number_of_cycles > rac$max_active_cycle - 3 THEN

      { This means that cycle conflicts exist and that there are not enough
      { free cycles available to move them out of the way.

      rap$convert_path_to_str (file_path, file_fs);
      osp$set_status_abnormal ('RA', rae$unable_to_reconcile_cycles, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, file_fs.path (1, file_fs.size), status);
      RETURN;
    IFEND;

    { Initialize the cycle map and set cycles that exist.

    FOR i := 1 TO UPPERBOUND (cycle_exists) DO
      cycle_exists [i] := FALSE;
    FOREND;
    FOR i := 1 TO number_of_cycles DO
      cycle_exists [cycles_p^ [i].cycle_number] := TRUE;
    FOREND;

    { Check for cycle conflicts and correct any found.

    conflicting_cycles_count := 0;
    IF cycle_exists [rac$loading_cycle] THEN
      conflicting_cycles_count := conflicting_cycles_count + 1;
    IFEND;
    IF cycle_exists [rac$staging_cycle] THEN
      conflicting_cycles_count := conflicting_cycles_count + 1;
    IFEND;

    IF conflicting_cycles_count > 0 THEN

      shift_to_first_active_cycle (file_path, conflicting_cycles_count, cycle_exists, status);

    IFEND;

    IF cycle_exists [rac$max_active_cycle] THEN

      compress_to_first_active_cycle (file_path, cycle_exists, status);

    IFEND;

  PROCEND reconcile_file;

?? TITLE := 'reconcile_subproduct', EJECT ??

{ PURPOSE:
{   This procedure reconciles any cycle conflicts a subproduct.
{
{ DESIGN:
{   The element list for each subproduct to be processed is used.  Each
{   element in the list describes a file or catalog belonging to that
{   subproduct.
{
{   The element list is traversed.  The traverse is performed recursively.
{   Each call to RECONCILE_SUBPRODUCT processes the next level subcatalog
{   of the subproduct.
{
{   The processing of active and inactive elements is handled differently
{   than in the other steps.  Inactive elements are excluded only when
{   validating that the files are deferred.  An inactive catalog element
{   means that all elements associated with that catalog are also inactive.
{
{ NOTES:
{   When an element turns out to be a catalog it is checked to verify that
{   it exists.  If the catalog does not exist there is no need to check the
{   elements under it.
{
{   The scratch sequence is used by a subsequent procedure as temporary
{   storage for file cycle information.
{
{   The state of the scratch sequence pointers and content is not retained.
{

  PROCEDURE reconcile_subproduct
    (    reconcile_option: rat#reconcile_options;
         element_path: pft$path;
     VAR element_p {input} : ^rat$element;
     VAR subproduct_info_seq_p {input} : ^rat$subproduct_info_sequence;
     VAR scratch_seq_p {input} : ^SEQ ( * );
     VAR errors_encountered {input, output} : boolean);


    VAR
      catalog_exists: boolean,
      current_element_path_p: ^pft$path,
      first_element_down_p: ^rat$element,
      i: integer,
      ignore_status: ost$status,
      local_status: ost$status;


    { The element_path parameter is the path for the current catalog.  Create
    { a PF format path array that is 1 larger than the size of the element
    { path.  This array will be used to construct the PF paths for the files
    { and subcatalogs that reside in the current catalog.

    PUSH current_element_path_p: [1 .. UPPERBOUND (element_path) + 1];
    FOR i := 1 TO UPPERBOUND (element_path) DO
      current_element_path_p^ [i] := element_path [i];
    FOREND;

    { Process the files and subcatalogs at the current catalog level.

    WHILE element_p <> NIL DO

      current_element_path_p^ [UPPERBOUND (current_element_path_p^)] := element_p^.name;

      IF (element_p^.active_element) OR (reconcile_option = rac#reconcile_for_install) THEN

        IF element_p^.element_type = rac$file THEN

          IF reconcile_option = rac#reconcile_for_install THEN
            reconcile_file (current_element_path_p^, scratch_seq_p, local_status);
          ELSE { reconcile option is rac#validate_for_activation }
            validate_file_deferred (current_element_path_p^, scratch_seq_p, local_status);
          IFEND;
          IF NOT local_status.normal THEN
            osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
            errors_encountered := TRUE;
          IFEND;

        ELSEIF (element_p^.element_type = rac$catalog) AND (element_p^.element_count <> 0) THEN

          catalog_exists := TRUE;
          IF reconcile_option = rac#reconcile_for_install THEN
            rap$verify_catalog_exists (current_element_path_p^, scratch_seq_p, catalog_exists);
          IFEND;

          IF catalog_exists THEN
            first_element_down_p := #PTR (element_p^.first_element_down_p, subproduct_info_seq_p^);

            reconcile_subproduct (reconcile_option, current_element_path_p^, first_element_down_p,
                  subproduct_info_seq_p, scratch_seq_p, errors_encountered);
          IFEND;
        IFEND;
      IFEND;

      element_p := #PTR (element_p^.next_element_across_p, subproduct_info_seq_p^);
    WHILEND;

  PROCEND reconcile_subproduct;

?? TITLE := 'shift_to_first_active_cycle', EJECT ??

{ PURPOSE:
{   This procedure shifts any conflicting cycles found in the loading
{   and staging cycles up to the first active cycle.
{
{ DESIGN:
{   Any files in the way are themselves shifted up out of the way.  For
{   example, assume a file contains the cycles 1, 2, 4, 5, and 6.  Also
{   assume the first active cycle is 3.  After shifting the file will
{   contain cycles 3, 4, 5, 6, 7 and 8.
{
{   The first active cycle is one greater than the staging cycle.
{
{ NOTES:
{

  PROCEDURE shift_to_first_active_cycle
    (    file_path: pft$path;
         conflicting_cycles_count: 0 .. rac$max_active_cycle;
     VAR cycle_exists {input, output} : rat#cycle_map;
     VAR status: ost$status);


    VAR
      current_cycle: pft$cycle_selector,
      cycle_number: 0 .. rac$max_active_cycle,
      first_free_cycle: 0 .. rac$max_active_cycle,
      free_cycle: 0 .. rac$max_active_cycle,
      free_cycles_count: 0 .. rac$max_active_cycle,
      new_cycle: array [1 .. 1] of pft$change_descriptor,
      password: pft$password;


    status.normal := TRUE;
    current_cycle.cycle_option := pfc$specific_cycle;
    new_cycle [1].change_type := pfc$cycle_number_change;
    password := '';

    { Find enough free cycles starting with the first active cycle to shift
    { the conflicting cycles out of the loading and/or staging cycles.  The
    { required number of free cycles are guarenteed because of a check by
    { calling procedure.

    free_cycles_count := 0;
    cycle_number := rac$staging_cycle + 1;
    WHILE free_cycles_count < conflicting_cycles_count DO
      IF NOT cycle_exists [cycle_number] THEN
        free_cycles_count := free_cycles_count + 1;
      IFEND;
      cycle_number := cycle_number + 1;
    WHILEND;
    first_free_cycle := cycle_number - 1;
    free_cycle := first_free_cycle;

    { Shift all cycles that preceed the first free cycle.  The cycle map must
    { be updated to reflect the change.  The next free cycle is the cycle
    { preceeding the current free cycle.

    FOR cycle_number := (first_free_cycle - 1) DOWNTO 1 DO
      IF cycle_exists [cycle_number] THEN
        current_cycle.cycle_number := cycle_number;
        new_cycle [1].cycle_number := free_cycle;
        pfp$change (file_path, current_cycle, password, new_cycle, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        cycle_exists [cycle_number] := FALSE;
        cycle_exists [free_cycle] := TRUE;

        free_cycle := free_cycle - 1;
      IFEND;
    FOREND;

  PROCEND shift_to_first_active_cycle;

?? TITLE := 'validate_file_deferred', EJECT ??

{ PURPOSE:
{   This procedure verifies that the file is deferred and that there is an
{   open active cycle.  Any fault is returned in the status variable.
{
{ DESIGN:
{   An error is returned when the staging cycle does not exist.
{
{   If a cycle 999 exists, all cycles are shifted down so that the existing
{   cycles will now occupy cycles 3 and up (sequentially).
{
{   When there are not enough empty cycles to perform the shift, an error
{   will be reported and the affected subproduct will be dropped from any
{   further processing.
{
{ NOTES:
{   The type CYCLE_MAP is an array of booleans, one for each cycle
{   possible.  The index into the array represents a possible cycle number
{   and the boolean value defines whether or not that cycle actually
{   exists.  The use of the variable name CYCLE_EXISTS helps convey this
{   meaning when an array index, such as CYCLE_NUMBER is used.
{
{   The scratch sequence is used by GET_CYCLE_DATA as temporary storage
{   for file information.
{

  PROCEDURE validate_file_deferred
    (    file_path: pft$path;
     VAR scratch_seq_p {input} : ^SEQ ( * );
     VAR status: ost$status);


    VAR
      cycle_exists: rat#cycle_map,
      cycles_p: pft$p_cycle_array,
      file_fs: rat$path,
      i: 0 .. rac$max_active_cycle,
      number_of_cycles: 0 .. rac$max_active_cycle;


    status.normal := TRUE;

    rap$get_cycle_data (file_path, scratch_seq_p, cycles_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF UPPERBOUND (cycles_p^) > rac$max_active_cycle - 2 THEN
      { This means that cycle conflicts exist and that there are not enough
      { free cycles available to move them out of the way.

      rap$convert_path_to_str (file_path, file_fs);
      osp$set_status_abnormal ('RA', rae$unable_to_reconcile_cycles, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, file_fs.path (1, file_fs.size), status);
      RETURN;
    IFEND;

    number_of_cycles := UPPERBOUND (cycles_p^);

    { Initialize the cycle map and set cycles that exist.

    FOR i := 1 TO UPPERBOUND (cycle_exists) DO
      cycle_exists [i] := FALSE;
    FOREND;
    FOR i := 1 TO number_of_cycles DO
      cycle_exists [cycles_p^ [i].cycle_number] := TRUE;
    FOREND;

    { Check for the existence of the staging cycle and then a free max active cycle.

    IF NOT cycle_exists [rac$staging_cycle] THEN
      rap$convert_path_to_str (file_path, file_fs);
      osp$set_status_abnormal ('RA', rae$file_not_deferred, '', status);
      osp$append_status_file (osc$status_parameter_delimiter, file_fs.path (1, file_fs.size), status);

    ELSEIF cycle_exists [rac$max_active_cycle] THEN

      compress_to_first_active_cycle (file_path, cycle_exists, status);

    IFEND;

  PROCEND validate_file_deferred;
MODEND ram$reconcile_cycle_conflicts;
*DECK DECK=RAM$RECORD_DISK_PATH EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$RECORD_DISK_PATH Interface.' ??
MODULE ram$record_disk_path;

{ PURPOSE:
{   This module contains the interface and procedures that records the path
{   to the disk order file in the packing list.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$install_software_cc
*copyc rac$control_job_identifier
*copyc rac$packing_list_level
*copyc rac$pacs_processor_version
*copyc fst$path
*copyc rat$installation_control_record
*copyc rat$packing_list_sequence
*copyc rat$sequence_descriptor_types
?? POP ??
*copyc amp$get_segment_pointer
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc rav$installation_defaults

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$record_disk_path', EJECT ??

{ PURPOSE:
{   This interface records the path to the disk order file in the packing
{   list.
{
{ DESIGN:
{
{ NOTES:
{   This interface was designed for a specific purpose (modifying a packing
{   list for a disk order).  Because of this fact it was deemed uneccessary
{   to report the passing in of a tape order packing list.  This condition
{   is tested for however.
{

  PROCEDURE [XDCL] rap$record_disk_path
    (    disk_path: fst$file_reference;
         packing_list: fst$file_reference;
     VAR status: ost$status);


    VAR
      attachment_options: array [1 .. 4] of fst$attachment_option,
      file_opened: boolean,
      local_status: ost$status,
      packing_list_fid: amt$file_identifier,
      packing_list_header_p: ^rat$packing_list_header;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to close the packing list
{   file when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (packing_list_fid, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      attachment_options [1].selector := fsc$access_and_share_modes;
      attachment_options [1].access_modes.selector := fsc$specific_access_modes;
      attachment_options [1].access_modes.value := $fst$file_access_options [fsc$read, fsc$modify];
      attachment_options [1].share_modes.selector := fsc$specific_share_modes;
      attachment_options [1].share_modes.value := $fst$file_access_options [];
      attachment_options [2].selector := fsc$open_share_modes;
      attachment_options [2].open_share_modes := $fst$file_access_options [];
      attachment_options [3].selector := fsc$create_file;
      attachment_options [3].create_file := FALSE;
      attachment_options [4].selector := fsc$wait_for_attachment;
      attachment_options [4].wait_for_attachment.wait := osc$wait;
      attachment_options [4].wait_for_attachment.wait_time := fsc$longest_wait_time;

      file_opened := TRUE;
      fsp$open_file (packing_list, amc$segment, ^attachment_options, NIL, NIL, NIL, NIL, packing_list_fid,
            status);
      IF NOT status.normal THEN
        file_opened := FALSE;
        EXIT /main/;
      IFEND;

      establish_packing_list_pointers (packing_list_fid, packing_list, packing_list_header_p, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF packing_list_header_p^.order_medium = rac$disk THEN

        packing_list_header_p^.disk_path := disk_path;

      IFEND;

    END /main/;

    IF file_opened THEN
      fsp$close_file (packing_list_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$record_disk_path;

?? TITLE := 'establish_packing_list_pointers', EJECT ??

{ PURPOSE:
{   This procedure establishes the pointers to the major data structures
{   in the packing list.
{
{ DESIGN:
{
{   Validation errors are returned in the status variable.
{
{ NOTES:
{   Commonality between this procedure and establish_packing_list_pointers
{   in ram$access_packing_list should be analyzed and the two written as
{   one.
{

  PROCEDURE establish_packing_list_pointers
    (    packing_list_fid: amt$file_identifier;
         packing_list: fst$file_reference;
     VAR packing_list_header_p {output} : ^rat$packing_list_header;
     VAR status: ost$status);


    VAR
      ignore_status: ost$status,
      local_status: ost$status,
      segment_pointer: amt$segment_pointer,
      sequence_descriptor_p: ^rat$sequence_descriptor;


    status.normal := TRUE;

    amp$get_segment_pointer (packing_list_fid, amc$sequence_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET segment_pointer.sequence_pointer;
    NEXT sequence_descriptor_p IN segment_pointer.sequence_pointer;
    IF sequence_descriptor_p = NIL THEN
      set_status_abnormal (rae$unexpected_eof_packing_list, packing_list, status);
      RETURN;
    IFEND;

    IF sequence_descriptor_p^.sequence_type <> rac$packing_list_sequence THEN
      set_status_abnormal (rae$invalid_packing_list, packing_list, status);
      RETURN;
    IFEND;

    IF sequence_descriptor_p^.sequence_level <> rac$packing_list_level THEN
      osp$set_status_abnormal ('RA', rae$incompatible_sequence_level, 'PACKING LIST', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, sequence_descriptor_p^.sequence_level,
            status);
      RETURN;
    IFEND;

    IF sequence_descriptor_p^.processor_version <> rac$pacs_processor_version THEN
      osp$set_status_abnormal ('RA', rae$different_processor_version, 'PACKING LIST', local_status);
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
    IFEND;

    NEXT packing_list_header_p IN segment_pointer.sequence_pointer;
    IF packing_list_header_p = NIL THEN
      set_status_abnormal (rae$unexpected_eof_packing_list, packing_list, status);
      RETURN;
    IFEND;

  PROCEND establish_packing_list_pointers;

?? TITLE := 'set_status_abnormal', EJECT ??

{ PURPOSE:
{   This procedure sets the status to the defined condition.  The
{   conditions allowed have common parameter values.  The set status is
{   returned in the status parameter.
{
{ DESIGN:
{   Conditions allowed are:  RAE$UNEXPECTED_EOF_PACKING_LIST and
{   RAE$INVALID_PACKING_LIST.
{
{ NOTES:
{

  PROCEDURE set_status_abnormal
    (    condition_code: ost$status_condition_code;
         packing_list: fst$file_reference;
     VAR status: ost$status);


    VAR
      installation_database: rat$path,
      packing_list_name: ost$name,
      packing_list_name_length: integer;


    status.normal := TRUE;

    installation_database := rav$installation_defaults.installation_database;

    packing_list_name_length := #SIZE (packing_list) - installation_database.size - 1;
    packing_list_name := packing_list (installation_database.size + 1, packing_list_name_length);

    osp$set_status_abnormal ('RA', condition_code, packing_list_name (1, packing_list_name_length), status);
    osp$append_status_file (osc$status_parameter_delimiter, installation_database.
          path (1, installation_database.size), status);

  PROCEND set_status_abnormal;
MODEND ram$record_disk_path;
*DECK DECK=RAM$RECORD_STEP_STATUS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$RECORD_STEP_STATUS Interface.' ??
MODULE ram$record_step_status;

{ PURPOSE:
{   This module contains the interface that records the step and step
{   status.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc rat$installation_control_record
?? POP ??
*copyc amp$flush
*copyc clp$convert_integer_to_string
*copyc clp$get_system_file_id
*copyc clp$put_job_command_response
*copyc clp$trimmed_string_size
*copyc pmp$get_compact_date_time
*copyc rap$convert_job_record_to_strs
*copyc osv$upper_to_lower
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$record_step_status', EJECT ??

{ PURPOSE:
{   This interface updates the step and step status in the job status
{   record along with the date/time the update took place.
{
{ DESIGN:
{   If the step status is RAC$STARTED, the subproduct started and completed
{   counts are initialized along with the step number.  The updated job
{   status record is then displayed to $RESPONSE.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$record_step_status
    (    step: rat$steps;
         step_status: rat$step_status;
     VAR icr {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      date_time: ost$date_time;


    status.normal := TRUE;

    pmp$get_compact_date_time (date_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    icr.job_status_record_p^.date_time := date_time;
    icr.job_status_record_p^.step := step;
    icr.job_status_record_p^.step_status := step_status;

    IF icr.job_status_record_p^.step_status = rac$step_started THEN

      icr.job_status_record_p^.step_number := icr.job_status_record_p^.step_number + 1;
      icr.job_status_record_p^.started_subproduct_count := 0;
      icr.job_status_record_p^.completed_subproduct_count := 0;

    IFEND;

    display_job_status_record (icr.job_status_record_p^, icr.job_status_record_p^.step_status, status);

  PROCEND rap$record_step_status;

?? OLDTITLE ??
?? NEWTITLE := 'display_job_status_record', EJECT ??

{ PURPOSE:
{   This procedure displays the job status record to $RESPONSE.
{
{ DESIGN:
{   The record is first converted to string values for displaying.
{
{   The job START status line is formatted as follows:
{
{     <a> (step <b>) ...
{
{   The job COMPLETE status line is formatted as follows:
{
{        step completed.
{
{   The job COMPLETE (with subproducts failed) status line is formatted as
{   follows:
{
{        step completed (<c> subproducts failed).
{
{
{   where:
{     <a> is the step.
{     <b> is the step number.
{     <c> is the started subproduct count minus the completed subproduct count.
{
{   As an example the following status line could be created:
{
{    "Reconciling cycle conflicts (step 1) ... "
{    "   step completed (3 subproducts failed)."
{
{ NOTES:
{   The $RESPONSE output buffer must be flushed to get the line to display
{   immediately.
{

  PROCEDURE display_job_status_record
    (    job_status_record: rat$job_status_record;
         step_status: rat$step_status;
     VAR status: ost$status);


    VAR
      failed_subproduct_count: rat$subproduct_count,
      failed_subproduct_count_str: ost$string,
      length: integer,
      line: string (osc$max_string_size),
      job_status_strs: rat$job_status_record_strs,
      response_fid: amt$file_identifier,
      translated_string: string (osc$max_string_size);


    status.normal := TRUE;

    rap$convert_job_record_to_strs (job_status_record, job_status_strs, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF step_status = rac$step_started THEN

      #TRANSLATE (osv$upper_to_lower, job_status_strs.step.value (2, job_status_strs.step.size),
            translated_string);

      STRINGREP (line, length, ' ', job_status_strs.step.value (1, 1),
            translated_string (1, clp$trimmed_string_size (translated_string)), ' (step ',
            job_status_strs.step_number.value (1, job_status_strs.step_number.size), ') ... ');

    ELSE {step status = rac$step_completed}

      failed_subproduct_count := job_status_record.started_subproduct_count -
            job_status_record.completed_subproduct_count;

      IF failed_subproduct_count = 0 THEN

        line (1, * ) := '       step completed.';
        length := clp$trimmed_string_size (line);

      ELSE {some or all subproducts failed}

        clp$convert_integer_to_string (failed_subproduct_count, 10, FALSE, failed_subproduct_count_str,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        STRINGREP (line, length, '       step completed (', failed_subproduct_count_str.
              value (1, failed_subproduct_count_str.size), ' subproducts failed).');

      IFEND;
    IFEND;

    clp$put_job_command_response (line (1, length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_system_file_id (clc$job_command_response, response_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$flush (response_fid, osc$nowait, status);

  PROCEND display_job_status_record;
MODEND ram$record_step_status;
*DECK DECK=RAM$RECORD_SUBPRODUCT_STATUS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$RECORD_SUBPRODUCT_STATUS Interface.' ??
MODULE ram$record_subproduct_status;

{ PURPOSE:
{   This module contains the interface that records the task and task
{   status.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$string
*copyc rat$installation_control_record
?? POP ??
*copyc clp$trimmed_string_size
*copyc pmp$log_ascii
*copyc rav$task_status
*copyc rav$task_title

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$record_subproduct_status', EJECT ??

{ PURPOSE:
{   This interface records the task and task status in the subproduct
{   processing record and then displays a subproduct processing status
{   message to the job log.  If the task status is RAC$COMPLETED, the
{   subproduct completed count in the job status record is incremented.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$record_subproduct_status
    (    task: rat$tasks;
         task_status: rat$task_status;
         subproduct_index: rat$subproduct_count;
     VAR icr {input} : rat$installation_control_record;
     VAR status: ost$status);


    status.normal := TRUE;

    icr.subproduct_processing_records_p^ [subproduct_index].task := task;
    icr.subproduct_processing_records_p^ [subproduct_index].task_status := task_status;

    IF icr.subproduct_processing_records_p^ [subproduct_index].task_status = rac$task_started THEN
      icr.job_status_record_p^.started_subproduct_count :=
            icr.job_status_record_p^.started_subproduct_count + 1;
    ELSEIF icr.subproduct_processing_records_p^ [subproduct_index].task_status = rac$task_completed THEN
      icr.job_status_record_p^.completed_subproduct_count :=
            icr.job_status_record_p^.completed_subproduct_count + 1;
    IFEND;

    display_subproduct_status (icr.subproduct_processing_records_p^ [subproduct_index], status);

  PROCEND rap$record_subproduct_status;

?? TITLE := 'display_subproduct_status', EJECT ??

{ PURPOSE:
{   This procedure displays the job status record to $JOB_LOG.
{
{ DESIGN:
{   The record is first converted to string values for displaying.
{
{   The job status line to be displayed is formatted as follows:
{
{     Subproduct <a> <b> <c>.
{
{   where:
{     <a> is the subproduct name.
{     <b> is the task status.
{     <c> is the task.
{
{   As an example the following status line could be created:
{
{    "Subproduct CDCNET started loading."
{
{ NOTES:
{

  PROCEDURE display_subproduct_status
    (    subproduct_processing_record: rat$subp_processing_record;
     VAR status: ost$status);


    VAR
      length: integer,
      line: string (osc$max_string_size),
      subproduct: ost$name,
      task: string (osc$max_string_size),
      task_status: string (osc$max_name_size);


    status.normal := TRUE;

    task_status := rav$task_status [subproduct_processing_record.task_status];
    task := rav$task_title [subproduct_processing_record.task];
    subproduct := subproduct_processing_record.subproduct_info_pointers.attributes_p^.name;

    STRINGREP (line, length, '  Subproduct ', subproduct (1, clp$trimmed_string_size (subproduct)),
          ' ', task_status (1, clp$trimmed_string_size (task_status)),
          ' ', task (1, clp$trimmed_string_size (task)), '.');

    pmp$log_ascii (line (1, length), $pmt$ascii_logset [pmc$job_log], pmc$msg_origin_program, status);

  PROCEND display_subproduct_status;
MODEND ram$record_subproduct_status;
*DECK DECK=RAM$RELEASED_DCFILE EXPAND=TRUE
DCF01
" This is the DCFILE.                                    "
"                                                        "
" Your system analyst can replace this text with system  "
" core commands to be processed at every deadstart.      "
"                                                        "
" For further information on system core commands, refer "
" to the NOS/VE System Performance Manual (system        "
" attribute commands).                                   "
" ******************** END OF DCF01 ******************** "
*DECK DECK=RAM$REMOTE_HOST_INPUT EXPAND=TRUE
PROC remote_host_input, rhinput (status)

  VAR
    attempts: integer = 0
    ignore_status: status
    proc_status: status
  VAREND
  define_system_task name=rhinput sp=rhp$input automatic_restart=TRUE ..
        deactivate_task_option=terminate idle_task_option=terminate restart_after_idle=TRUE ..
        spy_identifier=51 l=($system.osf$operator_library osf$task_services_library) ..
        tel=warning lm=$null lmo=none dm=off status=proc_status
  IF NOT proc_status.normal THEN
    IF $condition(proc_status.condition) <> 'OSE$SYSTEM_TASK_ALREADY_DEFINED' THEN
      EXIT_PROC WITH proc_status
    IFEND
  IFEND
  deactivate_system_task task_name=rhinput status=ignore_status

  REPEAT
    activate_system_task task_name=rhinput status=proc_status
    IF NOT proc_status.normal THEN
      IF $condition(proc_status.condition) = 'OSE$SYSTEM_TASK_STILL_RUNNING' THEN

" Wait for 5 seconds and recheck the status. Do this for up to 2 minutes,
" to allow the task to deactivate before attempting to activate it.

        attempts = attempts + 1
        wait 5000
      ELSE
        EXIT_PROC with proc_status
      IFEND
    IFEND
  UNTIL (proc_status.normal) OR (attempts > 24)
  EXIT_PROC with proc_status

PROCEND remote_host_input
*DECK DECK=RAM$REMOTE_HOST_OUTPUT EXPAND=TRUE
PROC remote_host_output, rhoutput (status)

  VAR
    attempts: integer = 0
    ignore_status: status
    proc_status: status
  VAREND
  define_system_task name=rhoutput sp=rhp$output automatic_restart=TRUE ..
        deactivate_task_option=terminate idle_task_option=terminate restart_after_idle=TRUE ..
        spy_identifier=52 l=($system.osf$operator_library osf$task_services_library) ..
        tel=warning lm=$null lmo=none dm=off status=proc_status
  IF NOT proc_status.normal THEN
    IF $condition(proc_status.condition) <> 'OSE$SYSTEM_TASK_ALREADY_DEFINED' THEN
      EXIT_PROC WITH proc_status
    IFEND
  IFEND
  deactivate_system_task task_name=rhoutput status=ignore_status

  REPEAT
    activate_system_task task_name=rhoutput status=proc_status
    IF NOT proc_status.normal THEN
      IF $condition(proc_status.condition) = 'OSE$SYSTEM_TASK_STILL_RUNNING' THEN

" Wait for 5 seconds and recheck the status. Do this for up to 2 minutes,
" to allow the task to deactivate before attempting to activate it.

        attempts = attempts + 1
        wait 5000
      ELSE
        EXIT_PROC with proc_status
      IFEND
    IFEND
  UNTIL (proc_status.normal) OR (attempts > 24)
  EXIT_PROC with proc_status

PROCEND remote_host_output
*DECK DECK=RAM$REMOVE_CORRECTION EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$remove_correction;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc rac$status_id
*copyc rae$error_messages
*copyc rav$elements
*copyc rav$correction_package_header
*copyc rat$correction_package
*copyc clp$scan_parameter_list
*copyc clp$get_set_count
*copyc clp$get_value
*copyc osp$set_status_abnormal
*copyc rap$issue_message
*copyc rap$get_corrector_element
*copyc rap$get_elements_by_product
*copyc rap$get_elements_by_class
?? POP ??

{  pdt rem_pdt (
{    element, elements, e: list of name
{    product, products, p: list of name
{    status)

?? PUSH (LISTEXT := ON) ??

  VAR
    rem_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^rem_pdt_names, ^rem_pdt_params];

  VAR
    rem_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of clt$parameter_name_descriptor
      := [['ELEMENT', 1], ['ELEMENTS', 1], ['E', 1], ['PRODUCT', 2], ['PRODUCTS', 2], ['P', 2], ['STATUS',
      3]];

  VAR
    rem_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ ELEMENT ELEMENTS E }
    [[clc$optional], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
      osc$max_name_size]],

{ PRODUCT PRODUCTS P }
    [[clc$optional], 1, clc$max_value_sets, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
      osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
*copyc rah$remove_correction

  PROCEDURE [XDCL] rap$remove_correction (parameter_list: clt$parameter_list;
    VAR status: ost$status);

    VAR
      element_list: ^array [1 .. * ] of ost$name,
      i: rat$element_index,
      j: rat$element_index,
      k: rat$element_index,
      l: rat$element_index,
      message_status: ost$status,
      number: 0 .. clc$max_value_sets,
      output_lfn: [STATIC] amt$local_file_name := '$OUTPUT',
      value: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, rem_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('ELEMENT', number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /remove_elements/
    FOR i := 1 TO number DO
      clp$get_value ('ELEMENT', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF value.name.value = 'OS' THEN
        rap$get_elements_by_class (rac$os, element_list, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF element_list <> NIL THEN

        /remove_os/
          FOR j := 1 TO UPPERBOUND (element_list^) DO
            rap$get_corrector_element (element_list^ [j], k, status);
            IF NOT status.normal THEN
              IF status.condition = rae$element_not_found THEN
                osp$set_status_abnormal (rac$status_id, rae$no_correction, element_list^ [j], message_status);
                rap$issue_message (output_lfn, message_status, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                CYCLE /remove_os/;
              ELSE
                RETURN;
              IFEND;
            IFEND;

            FOR l := k + 1 TO rav$correction_package_header^.number_of_elements DO
              rav$elements^ [l - 1] := rav$elements^ [l];
            FOREND;

            IF k <> 0 THEN
              rav$correction_package_header^.number_of_elements := rav$correction_package_header^.
                    number_of_elements - 1;
            IFEND;
          FOREND /remove_os/;
          FREE element_list;
        IFEND;
      ELSE
        rap$get_corrector_element (value.name.value, k, status);
        IF NOT status.normal THEN
          IF status.condition = rae$element_not_found THEN
            osp$set_status_abnormal (rac$status_id, rae$no_correction, value.name.value, message_status);
            rap$issue_message (output_lfn, message_status, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            CYCLE /remove_elements/;
          ELSE
            RETURN;
          IFEND;
        IFEND;

        FOR j := k + 1 TO rav$correction_package_header^.number_of_elements DO
          rav$elements^ [j - 1] := rav$elements^ [j];
        FOREND;

        IF k <> 0 THEN
          rav$correction_package_header^.number_of_elements := rav$correction_package_header^.
                number_of_elements - 1;
        IFEND;
      IFEND;
    FOREND /remove_elements/;

    clp$get_set_count ('PRODUCT', number, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    FOR i := 1 TO number DO
      clp$get_value ('PRODUCT', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      rap$get_elements_by_product (value.name.value, element_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF element_list <> NIL THEN

      /remove_product/
        FOR j := 1 TO UPPERBOUND (element_list^) DO
          rap$get_corrector_element (element_list^ [j], k, status);
          IF NOT status.normal THEN
            IF status.condition = rae$element_not_found THEN
              osp$set_status_abnormal (rac$status_id, rae$no_correction, element_list^ [j], message_status);
              rap$issue_message (output_lfn, message_status, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              CYCLE /remove_product/;
            ELSE
              RETURN;
            IFEND;
          IFEND;

          FOR l := k + 1 TO rav$correction_package_header^.number_of_elements DO
            rav$elements^ [l - 1] := rav$elements^ [l];
          FOREND;

          IF k <> 0 THEN
            rav$correction_package_header^.number_of_elements := rav$correction_package_header^.
                  number_of_elements - 1;
          IFEND;
        FOREND /remove_product/;
        FREE element_list;
      IFEND;
    FOREND;
  PROCEND rap$remove_correction;
MODEND ram$remove_correction;
*DECK DECK=RAM$REPFILE EXPAND=TRUE
.PROC,REPFILE*I,
LFN "- Local File Name"                = (*F),
PFN "- Permanent File Name"            = (*N=,*F),
CT "- Catalog Type"                    = (*N=S,P,S,PU,SPRIV,PUBLIC,PR,PRIVATE),
M "- Mode of file access"              = (*N=R,E=E,R=R,EXECUTE=E,READ=R),
DEFINE "- YES causes DIRECT file made" = (*N=NO,YES,NO),
UN  "- PERMANENT FILE ID"              = (*N=,*F),
.
.HELP
 The REPFILE procedure REPlaces local FILEs as either INDIRECT or
 DIRECT permanent files depending upon validation limits.
 When possible, INDIRECT files are created to conserve disk space.

 Parameter   Default   Description
   Name       Value

   lfn                 local file name by which the file is accessed
  [pfn]       lfn      permanent file name of the stored file
  [ct]         s       file catalog type, which limits access
  [m]          r       access mode of the file
  [define]     no      YES value causes DIRECT access file creation
   un                  permanent file id (NOS/BE systems only)

.HELP,LFN
 The LFN parameter selects the name by which the file is accessed.
.HELP,PFN
 The PFN parameter selects the name by which the file is stored.
 The default is the value specified for the LFN parameter.
.HELP,CT
 The CT parameter specifies the file permissions of the saved file.
 Options are:  S | SPRIV        - for semiprivate files (default value)
               PU | PUBLIC      - for public files
               P | PR | PRIVATE - for private files
 This parameter is ignored on NOS/BE.
.HELP,M
 The M parameter selects the Mode of access for the file.
 Options are:  R | READ     - for read access (default value)
               E | EXECUTE  - for execute access
 This parameter is ignored on NOS/BE.
.HELP,DEFINE
 The DEFINE parameter forces creation of a DIRECT access file.
 Options are: no  - create an INDIRECT access file (default value)
              yes - create a DIRECT access file
 This parameter is ignored on NOS/BE.
.HELP,UN
 The UN parameter specifies the permanent file ID under which the
 file is cataloged.
 This parameter must not be specified on NOS.
.ENDHELP
.IFE,$PFN$.EQ.$$,NOPFN.
  REVERT,EX.REPFILE,LFN,LFN,CT,M,DEFINE,UN.
.ENDIF,NOPFN.
.IFE,SYS=NOS,NOSSYS.
  .IFE,$UN$.NE.$$,BEID.
    REVERT,ABORT. UN PARAMETER ILLEGAL FOR NOS REPFILE
  .ENDIF,BEID.
.IFE,FILE(LFN,AS),FILELOC.
  $REWIND,LFN.
    $PURGE,PFN/NA.
  .IFE,$DEFINE$.EQ.$NO$,FILEIND.
    $SAVE,LFN=PFN/#CT=CT,#M=M,NA.
    $GET,YYYREPF=PFN/NA.
  .ENDIF,FILEIND.
  $IFE,.NOT.FILE(YYYREPF,AS),INDFAIL.
    $#DEFINE,YYYREPF=PFN/#CT=CT,#M=M.
    $COPYEI,LFN,YYYREPF.
    $REWIND,LFN.
    $UNLOAD,YYYREPF.
    $REVERT. LFN REPLACED --> PFN(*D)
  $ELSE,INDFAIL.
    $UNLOAD,YYYREPF.
    $REVERT. LFN REPLACED --> PFN(*I)
  $ENDIF,INDFAIL.
.ELSE,FILELOC.
  $REVERT,ABORT. FILE LFN NOT FOUND
.ENDIF,FILELOC.
$EXIT.
$UNLOAD,YYYREPF.
$IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
  $EXIT. REPFILE *TERMINATED*
$ELSE,TERMINATED.
  $REVERT,ABORT. REPFILE FAILED
$ENDIF,TERMINATED.
.ELSE,NOSSYS.
.IFE,$UN$.EQ.$$.REVERT,ABORT. USERNAME NOT SPECIFIED FOR REPFILE.
.IFE,FILE(LFN,AS),FILELOC.
  .IFE,FILE(LFN,PF),PFILE.
    REVERT. LFN ALREADY PERMANENT.
  .ELSE,PFILE.
    .IFE,OT.EQ.TXO.DFLIST,OFF.
    CATALOG,LFN,PFN,ID=UN.
    RETURN,LFN.
    ATTACH,LFN,PFN,ID=UN,MR=1.
    SKIP,CATERR.
      EXIT(U)
      DISCONT,OUTPUT.
      .IFE,OT.EQ.TXO.DFLIST,ON.
      SET(EF=0)
      BKSP,OUTPUT.
      REVERT,ABORT. REPFILE CATALOG ERROR
    ENDIF,CATERR.
    PURGE,YYYREL1,PFN,ID=UN,LC=1.
    SKIP,PURERR.
      EXIT(U)
      DISCONT,OUTPUT.
      SET(EF=0)
      BKSP,OUTPUT.
    ENDIF,PURERR.
    RETURN,YYYREL1.
    .IFE,OT.EQ.TXO.DFLIST,ON.
    REVERT. LFN REPLACED --> PFN
  .ENDIF,PFILE.
.ELSE,FILELOC.
  REVERT,ABORT. FILE LFN NOT FOUND
.ENDIF,FILELOC.
EXIT.
  .IFE,OT.EQ.TXO.DFLIST,ON.
  REVERT,ABORT. REPFILE FAILED
.ENDIF,NOSSYS.
/EOR
*DECK DECK=RAM$REPLACE_MULTIREC_FILE EXPAND=TRUE
PROCEDURE (osm$repmrf) replace_multi_record_file, repmrf (
  nos_ve_file, nvf: file = $required
  nos_file, nf: name 7 = $required
  status)

  "$FORMAT=OFF
  VAR
    lsts: status
  VAREND
  "$FORMAT=ON"
  detach_file $local.nos_tape_ic_file status=lsts
  detach_file $local.nos_xfer status=lsts

  IF $job(c170_os_type) = 'NOS' THEN
    "$FORMAT=OFF
    VAR
      sv: array 1 .. 13 of string
    VAREND
    "$FORMAT=ON"
    sv(1) = 'jobc.'
    sv(2) = 'common(system)'
    sv(3) = 'gtr(system,nvelib,u)ulib/nvelib'
    sv(4) = 'library(nvelib/a)'
    sv(5) = 'settl,*.'
    sv(6) = 'setasl,*.'
    sv(7) = 'setjsl,*.'
    sv(8) = 'purge,' // $string(nos_file) // '/na.'
    sv(9) = 'define,tape=' // $string(nos_file) // '.'
    sv(10) = 'xpfua.'
    sv(11) = 'exit.'
    sv(12) = 'dayfile,day.'
    sv(13) = 'replace,day.'

  ELSE
    "$FORMAT=OFF
    VAR
      sv: array 1 .. 15 of string
    VAREND
    "$FORMAT=ON"
    catalog_id = $nosbe_catalog_id
    sv(1) = 'JOBC,T0.'
    sv(2) = 'LIBRARY(NVELIB)'
    sv(3) = 'PURGE(' // $string(nos_file) // ',ID=' // catalog_id // ')'
    sv(4) = 'SKIP,FNDFILE.'
    sv(5) = '  EXIT(U)'
    sv(6) = '  SET(EF=0)'
    sv(7) = '  BKSP(OUTPUT)'
    sv(8) = 'ENDIF,FNDFILE.'
    sv(9) = 'REQUEST(TAPE,PF)'
    sv(10) = 'XPFUA.'
    sv(11) = 'CATALOG(TAPE,' // $string(nos_file) // ',ID=' // catalog_id // ')'
    sv(12) = 'EXIT.'
    sv(13) = 'REQUEST(DAY,PF)'
    sv(14) = 'DAYFILE,DAY.'
    sv(15) = 'CATALOG(DAY,ID=' // catalog_id // ')'
  IFEND

  set_file_attributes $local.nos_tape_ic_file ui='sv'
  request_link $local.nos_tape_ic_file
  set_file_attributes $local.nos_xfer fap=rap$nos_file_write
  execute_task sp=rap$repmrf l=$system.osf$system_library p=$string(nos_ve_file) lmo=none
  detach_file ($local.nos_tape_ic_file, $local.nos_xfer) status=lsts

PROCEND replace_multi_record_file
*DECK DECK=RAM$REPLACE_PROCEDURE EXPAND=TRUE
PROCEDURE (ram$repp) replace_procedure, replace_procedures, repp (
  procedure, procedures, p: list of any of
      integer radix 16
      name
      string
    anyend = all
  from, f: file = :$local.procedures
  to: file = $working_catalog.command_library
  status)

" PURPOSE:
"   Replace the specified modules on a library or object file.
" DESIGN:
"   Scan every module name on the library for the specified value. Merge the selected modules onto
"   the output file, and update the command list when appropriate.
" NOTES:
"   $WORKING_CATALOG.COMMAND_LIBRARY is overwritten if the catalog is :$LOCAL, otherwise cycle $NEXT
"   is created. An integer procedure value is hexadecimal value, convenient when processing CDCNET
"   configuration procedures. Chronological library order is maintained for audit purposes. A leading
"   or trailing blank constrains the substring match to the beginning or end of a module name.

  VAR
    command_list_altered : status
    format : name = library
    library_list : file = $unique(:$local)
    modules_on_file : list 0..$max_list of string = ()
    modules_to_replace : list 0..$max_list of string = ()
    next_cycle : file = to
    replace_status : status
    specified_name : string 1..31
  VAREND

  IF $file(to, permanent) THEN " create absolute path to cycle $next
    next_cycle=to//$file(to//$next, cycle_number)
  IFEND

  IF ($file(to, fs)= 'DATA') AND ($file(to, fc)= 'LEGIBLE') THEN
    format=scl_proc
  IFEND

  CREATE_OBJECT_LIBRARY
    add_modules library=to status=replace_status
    set_file_attributes file=library_list page_format=continuous file_contents=legible
    display_object_library library=from display_option=date_time output=library_list ..
          alphabetical_order=true status=replace_status
    IF replace_status.normal THEN
      PUSH file_connections " Suppress error messages from attempted update operations.
      delete_file_connection standard_file=$errors file=output
      delete_file_connection standard_file=$errors file=$job_log
      get_line variable=modules_on_file input=library_list
      delete_file file=library_list
      FOR EACH procedure_specified IN procedures DO " select a list of modules to replace
        IF $generic_type(procedure_specified)= integer THEN " a CDCNET configuration procedure reference
          specified_name=$integer_string(procedure_specified, 16)
        ELSE " a substring of the procedure name was specified
          specified_name=$string(procedure_specified)
        IFEND
        IF (specified_name = 'ALL') AND (format = scl_proc) THEN " select all SCL procedures
          modules_to_replace=$union(modules_to_replace, ..
                $select(modules_on_file, $scan_string('procedure', x)>0))
        ELSEIF specified_name = 'ALL' THEN " select all modules regardless of type
          modules_to_replace=$union(modules_to_replace, $select(modules_on_file, $size(x)>0))
        ELSEIF format = scl_proc THEN " select specified SCL procedures
          modules_to_replace=$union(modules_to_replace, $select(modules_on_file, ($scan_string('procedure', ..
                x)>0 AND $scan_string(specified_name, ' '//$substring(x, 1, 32))>0)))
        ELSE " select specified modules regardless of type
          modules_to_replace=$union(modules_to_replace, ..
                $select(modules_on_file, $scan_string(specified_name, ' '//$substring(x, 1, 32))>0))
        IFEND
      FOREND
      IF $nil(modules_to_replace) THEN " assign appropriate add_module status
        add_modules library=from modules=$apply(procedures, $range_of($program_name(x))) status=replace_status
        IF replace_status.normal THEN
          generate_library library=next_cycle format=format status=replace_status
        IFEND
      ELSE " generate the resulting library or object file
        put_line line=' Replacing procedures to     '//next_cycle output=$response
        FOR EACH selected_module IN modules_to_replace DO
          add_module library=from module=selected_module(1, 31) status=replace_status
          IF replace_status.normal THEN " account for the module added
            put_line line=' ADDED    '//$trim(selected_module(1, 31)) output=$response
          ELSE
            delete_module module=selected_module(1, 31) status=replace_status
            add_module library=from module=selected_module(1, 31) status=replace_status
            IF replace_status.normal THEN " account for the modules replaced
              put_line line=' REPLACED '//$trim(selected_module(1, 31)) output=$response
            IFEND
          IFEND
        FOREND
        delete_command_list_entry entry=to status=command_list_altered
        IF command_list_altered.normal THEN
          put_line line=' Deleted command list entry  '//to output=$response
        IFEND
        generate_library library=next_cycle format=format status=replace_status
        IF replace_status.normal THEN " summarize action performed
          put_line line=' Replaced '//$justify($integer_string($size(modules_to_replace)), 4, right)//..
' procedures to '//$string(next_cycle)//' from '//from output=$response
        IFEND
        IF command_list_altered.normal THEN " update the command list
          IF replace_status.normal THEN " add the new command library
            create_command_list_entry entry=next_cycle
            put_line line=' Created command list entry  '//next_cycle output=$response
          ELSE " restore the old command library
            create_command_list_entry entry=to
            put_line line=' Restored command list entry '//to output=$response
          IFEND
        IFEND
      IFEND
    IFEND
  QUIT

  EXIT_PROC WITH replace_status

PROCEND replace_procedure
*DECK DECK=RAM$REPLIB EXPAND=TRUE
.PROC,REPLIB*I,
G "- Group file containing records"    = (*F),
L "- Library file receiving records"   = (*N=#FILE,*F),
T "- Type of record being replaced"    = (*N=,ABS,CAP,OPL,OPLC,OPLD,OVL,
                                               PP,PPU,PROC,REL,TEXT,ULIB),
UN "- permanent file ID"               = (*N=,*F),
.
.HELP
 The REPLIB procedure REPlaces records on a LIBrary file.
 On NOS systems, it requires CATALOG binaries with GENCAT entry point.

 Parameter   Default   Description
   Name       Value

   g                   file containing records to replace
  [l]                  library file for record replacement
  [t]                  type of record being replaced on library
  [un]                 permanent file id (NOS/BE systems only)

.HELP,G
 The G parameter names a file from which records are replaced.
.HELP,L
 The L parameter names the file to which records are replaced.
 The default value is the file containing this procedure.
.HELP,T
 The T parameter selects the type of record to replace from the file
 specified by the G parameter. No type checking is done unless a value
 is specified for the record type.
.HELP,UN
 The UN parameter specifies the permanent file ID of file L and G. It
 is specified for NOS/BE systems only.
.ENDHELP
.IFE,$G$.EQ.$L$,ERROR.
  REVERT,ABORT. CANNOT REPLACE G --> L
.ENDIF,ERROR.
GETFILE,G,G,UN,READ,A=YES.
.IFE,$T$.NE.$$,CHECKTYPE.
  GTR,G,YYYYUPD,,,,NA.T/*
  IFE,FILE(YYYYUPD,AS),FOUNDTYPE.
    UNLOAD,YYYYUPD.
  ELSE,FOUNDTYPE.
    .IFE,FILE(G,.NOT.AS),FILEPRM.
      UNLOAD,G.
    .ENDIF,FILEPRM.
    REVERT,ABORT. NO T RECORDS ON G
  ENDIF,FOUNDTYPE.
.ENDIF,CHECKTYPE.
GETFILE,L,L,UN.
REWIND,G.
.IFE,SYS=NOS,NOSSYS.
$IF,(FILE(L,AS)).AND.(FILE(L,.NOT.WR)).GETFILE,L,L.
UPDVER,DATE+,TIME+,G,L,REPLACE.
DISLIB,ALL,T,G,,O=YYYYUPD,DO=D.
$SKIPEI,YYYYUPD.
$UNLOAD,YYYYERR.
$GTR,G,YYYYERR,,,,NA.PROC/DISVER
$IFE,FILE(YYYYERR,AS),CHECKVER.
  $IFE,$G$.NE.$DISVER$,NEWVER.
    $NOTE(YYYYUPD,NR)+*IGNORE PROC/DISVER
    $NOTE(YYYYUPD,NR)+*FILE DISVER
    $NOTE(YYYYUPD,NR)+*B *,PROC/DISVER
  $ENDIF,NEWVER.
  $UNLOAD,YYYYERR.
$ELSE,CHECKVER.
  $NOTE(YYYYUPD,NR)+*FILE DISVER
  $NOTE(YYYYUPD,NR)+*B *,PROC/DISVER
$ENDIF,CHECKVER.
$PACK(YYYYUPD)
$LIBEDIT,P=L,N=L,B=G,#L=YYYYERR,LO=E,I=YYYYUPD,U=L,NI,D.
$SKIP,NOERROR.
  $EXIT.
  $REWIND,G,YYYYERR.
  $COPYEI,YYYYERR,OUTPUT.
  $UNLOAD,YYYYERR,ZZZZZG2.
  $UNLOAD,DISVER,YYYSCR2,YYYYUPD.
  $REVERT,ABORT. REPLACE G --> L FAILED
$ENDIF,NOERROR.
$REWIND,YYYYERR.
$COPYEI,YYYYERR,OUTPUT.
$UNLOAD,YYYYERR,ZZZZZG2.
  $UNLOAD,DISVER,YYYSCR2,YYYYUPD.
$IFE,.NOT.((FILE(L,PM)).AND.(FILE(L,WR))),REWRITE.
  REPFILE,L,L,DEFINE=YES.
$ENDIF,REWRITE.
.IFE,FILE(L,AS),ADDLIB.
  $LIBRARY,L/D.
  $LIBRARY,L/A.
.ELSE,ADDLIB.
  $UNLOAD,L.
.ENDIF,ADDLIB.
.ELSE,NOSSYS.
  GETFILE,G,G,UN,A=YES.
  REQUEST,LLLLNEW,SN.
  COPYL(L,G,LLLLNEW,,RAT)
  IFE,FILE(L,PF),REPPF.
    RETURN,L.
    REPFILE,LLLLNEW,L,,,,UN.
    RETURN,LLLLNEW.
    .IFE,FILE(L,AS).GETFILE,L,L,UN,A=YES.
  ELSE,REPPF.
    REWIND,L,LLLLNEW.
    COPYBF,LLLLNEW,L.
  ENDIF,REPPF.
  SKIP,NOERROR.
    EXIT.
    UNLOAD,LLLLNEW.
    NOTE(OUTPUT,NR)+ REPLACE G --> L FAILED
    REVERT,ABORT. REPLACE G --> L FAILED
  ENDIF,NOERROR.
  UNLOAD,LLLLNEW.
.ENDIF,NOSSYS.
.IFE,FILE(G,.NOT.AS),NOTLOCAL.
  PURGE,G.
.ENDIF,NOTLOCAL.
UNLOAD,G.
REVERT. REPLACED G --> L
/EOR
*DECK DECK=RAM$REPPROC EXPAND=TRUE
.PROC,REPPROC*I,
G "- Group file containg procedures"   = (*F),
L "- Library file receiving procedures"= (*N=#FILE,*F),
UN "- Permanent file ID"               = (*N=,*F),
.
.HELP
 The REPPROC procedure REPlaces PROCedures on a library file.
 On NOS systems, it requires CATALOG binaries with GENCAT entry point.

 Parameter   Default   Description
   Name       Value

   g                   file containing procedures to replace
  [l]                  library file for procedure replacement
  [un]                 permanent file ID (NOS/BE systems only)
.HELP,G
 The G parameter names a file from which procedures are replaced.
.HELP,L
 The L parameter names the file to which procedures are replaced.
 The default value is the file containing this procedure.
.HELP,UN
 The UN parameter specifies a permanent file ID on NOS/BE systems.
 This parameter is ignored on NOS.
.ENDHELP
.IFE,SYS=NOS,NOSSYS.
$REVERT,EX.REPLIB,#G=G,#L=L,T=PROC.
.ELSE,NOSSYS.
 REVERT,EX.REPLIB,#G=G,#L=L,T=PROC,#UN=UN.
.ENDIF,NOSSYS.
/EOR
*DECK DECK=RAM$REPRECS EXPAND=TRUE
.PROC,REPRECS*I,
DIF "NOS/VE DEADSTART INPUT FILE"                = (*N=TPXXXK,*F),
S   "SITECP FILE"                                = (*N=SITECP,*F),
D   "DCFILE FILE"                                = (*N=DCFILE,*F),
UN  "CATALOG OR PF ID TO SEARCH FOR FILES"       = (*N=,*F),
.
.HELP
 THE REPRECS PROCEDURE REPLACES THE SITECP AND DCFILE RECORDS ON THE
 NOS/VE DEADSTART INPUT FILE.

 PARAMETER   DEFAULT   DESCRIPTION
   NAME       VALUE

   DIF       TPXXXK    THE FILE NAME OF THE NOS/VE DEADSTART INPUT FILE.
   S         SITECP    THE FILE CONTAINING THE CONFIGURATION PROLOG AND
                       OTHER FILES THAT ARE CREATED IN THE $SYSTEM CATALOG
                       OF NOS/VE DURING AN INSTALLATION DEADSTART.
   D         DCFILE    THE FILE CONTAINING SETS OF SYSTEM CORE COMMANDS.
   UN                  USER NAME IN WHICH FILES RESIDE.

.HELP,DIF
 THE NAME OF THE NOS/VE DEDSTART INPUT FILE.
.HELP,S
 THE NAME OF THE SITECP FILE.
.HELP,D
 THE NAME OF THE FILE CONTAINING SETS OF SYSTEM CORE COMMANDS.
.HELP,UN
 THE CATALOG SEARCHED FOR THE FILES. ON NOS/BE, PF ID.
.ENDHELP
GETFILE,DIF,,UN,WRITE,YES.
UNLOAD,NVETAPE.
GETFILE,S,S,UN,READ,YES.
GETFILE,D,D,UN,READ,YES.
.IFE,SYS=NOS,NOSSYS.
  .IFE,$S$.NE.$SITECP$,CHANGES.
    RENAME,SITECP=S.
  .ENDIF,CHANGES.
  .IFE,$D$.NE.$DCFILE$,CHANGED.
    RENAME,DCFILE=D.
  .ENDIF,CHANGED.
  DSMDSTG(DIRS)
  UNLOAD,LGO.
  GTR,NVETAPE,LGO.TEXT/SITECP,TEXT/DCFILE
  REWIND,DIF.
  DEFINE,TMPTPXK.
  REWIND,DIF,TMPTPXK.
  NOTE(OUTPUT,NR)+ REPLACING RECORDS ON TMPTPXK.
  LIBEDIT,P=DIF,N=TMPTPXK,B=LGO,I=0.
  RETURN,DIF.
  PURGE,DIF/NA.
  RETURN,TMPTPXK.
  CHANGE,DIF=TMPTPXK.
.ELSE,NOSSYS.
  .IFE,$S$.NE.$SITECP$,CHNGS.
    COPYBF,S,SITECP.
    REWIND,SITECP.
  .ENDIF,CHNGS.
  .IFE,$D$.NE.$DCFILE$,CHNGD.
    COPYBF,D,DCFILE.
    REWIND,DCFILE.
  .ENDIF,CHNGD.
  .IFE,OT.EQ.TXO.ETL,100.
  DSMDSTG(DIRS)
  UNLOAD,LGO.
  GTR,NVETAPE,LGO.TEXT/SITECP,TEXT/DCFILE
  REWIND,DIF.
  REQUEST,TMPTPXK,SN,PF.
  NOTE(OUTPUT,NR)+ REPLACING RECORDS ON TMPTPXK.
  COPYL,DIF,LGO,TMPTPXK,,RE.
  CATALOG,TMPTPXK,DIF,ID=UN,RP=999.
  PURGE,DIF.
.ENDIF,NOSSYS.
NOTE(OUTPUT,NR)+ DIF UPDATED.
UNLOAD,NVETAPE,LGO,TMPTPXK,DIRS.
REVERT.
EXIT.
NOTE(OUTPUT,NR)+ RECORD REPLACEMENT FAILED...SEE DAYFILE.
REVERT,ABORT. RECORD REPLACEMENT FAILED...SEE DAYFILE.
.DATA,DIRS
LOADDCF,DCFILE
LOADFILE,SITECP,ASCII180
LOADEND
/EOR
*DECK DECK=RAM$REPTEXT EXPAND=TRUE
.PROC,REPTEXT*I,
G "- Group file containing TEXT record"= (*F),
L "- Library file receiving TEXT"      = (*N=#FILE,*F),
.
.HELP
 The REPTEXT procedure REPlaces TEXT records on a library file.
 Requires CATALOG binaries with GENCAT entry point.

 Parameter   Default   Description
   Name       Value

   g                   file containing TEXT records to replace
  [l]                  library file for TEXT record replacement

.HELP,G
 The G parameter names a file from which TEXT records are replaced.
.HELP,L
 The L parameter names the file to which TEXT records are replaced.
 The default value is the file containing this procedure.
.ENDHELP
$REVERT,EX.REPLIB,#G=G,#L=L,T=TEXT.
/EOR
*DECK DECK=RAM$REQUEST_LINK EXPAND=TRUE
PROCEDURE (osm$reql) request_link, reql (
  file, f: file = $required
  status)

  request_null file

  set_file_attributes file file_access_procedure=icp$fap_control

PROCEND request_link
*DECK DECK=RAM$REQUEST_LOCAL_QUEUE EXPAND=TRUE
PROC request_local_queue, reqlq (
  file, f: file = $required
  status)

  request_null $value(file)

  set_file_attributes $value(file) pf=continuous pw=175 fap=clp$local_queue_fap

PROCEND request_local_queue
*DECK DECK=RAM$RESET_CORRECTION_ENVIRON EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'CREATE_SUBPRODUCT_CORRECTION subutility: RAP$RESET_CORRECTION_ENVIRON procedure.' ??
MODULE ram$reset_correction_environ;

{ PURPOSE:
{   This procedure closes the open subproduct information files and
{   sets the global boolean variables to FALSE.
{
{ DESIGN:
{   If the subproduct information files are opened they are closed.
{   The global booleans are set to FALSE.
{
{ NOTES:
{
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*copyc fsp$close_file
*copyc rav$correction_process_record

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$reset_correction_environ', EJECT ??

{ PURPOSE:
{   This procedure closes the open subproduct information files and
{   sets the global boolean variables to FALSE.
{
{ DESIGN:
{   If the subproduct information files are opened they are closed.
{   The global booleans are set to FALSE.
{   The scratch sequence is reset.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$reset_correction_environ
    (VAR correction_process_record: rat$correction_process_record;
     VAR status: ost$status);

    VAR
      local_status: ost$status;

    status.normal := TRUE;

    rav$correction_process_record.correction_in_progress := FALSE;
    RESET rav$correction_process_record.new_subproduct_info_pointers.subproduct_info_seq_p;

    IF rav$correction_process_record.base_level_sif.file_opened THEN
      fsp$close_file (rav$correction_process_record.base_level_sif.fid, local_status);
      IF local_status.normal THEN
        rav$correction_process_record.base_level_sif.file_opened := FALSE;
      ELSE
        status := local_status;
      IFEND;
    IFEND;

    IF rav$correction_process_record.current_level_sif.file_opened THEN
      fsp$close_file (rav$correction_process_record.current_level_sif.fid, local_status);
      IF local_status.normal THEN
        rav$correction_process_record.current_level_sif.file_opened := FALSE;
      ELSE
        status := local_status;
      IFEND;
    IFEND;

    IF rav$correction_process_record.previous_correction_sif.file_opened THEN
      fsp$close_file (rav$correction_process_record.previous_correction_sif.fid, local_status);
      IF local_status.normal THEN
        rav$correction_process_record.previous_correction_sif.file_opened := FALSE;
      ELSE
        status := local_status;
      IFEND;
    IFEND;

  PROCEND rap$reset_correction_environ;

MODEND ram$reset_correction_environ;
*DECK DECK=RAM$RESTORE EXPAND=TRUE
.PROC,RESTORE*I,
UPGRADE "Keyword for partial update"   = (*N=NO,*K=YES,YES,NO),
LFN "Local File Name of install tape"  = (*N=#FILE,*F),
VSN "Volume Serial Number of tape"     = (*N=,
                            *S6(ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789)),
D "tape Density (GE,PE,HD,HY)"         = (*N=PE,GE,PE,HD,HY),
UN "Installation user name"            = (*N=,*F),
.
.HELP
 The RESTORE procedure RESTOREs the NOS/VE installation files.
 Requires REPFILE procedure on NOS systems.

 Parameter   Default   Description
   Name       Value

  [upgrade]    no      Keyword indicating partial update materials used
  [lfn]                Local File Name by which the tape is accessed
  [vsn]                Volume Serial Number of the installation tape
  [d]          pe      Density of the installation tape
  [un]                 Installation user name (NOS/BE systems only)

.HELP,UPGRADE
 The UPGRADE keyword indicates that this procedure is being used as part,
 of a system upgrade and that steps should be taken to avoid damaging
 the files SITECP, DCFILE and TPXXXK.
.HELP,LFN
 The LFN parameter selects the name by which the tape is accessed.
 The default value is the file containing this procedure.
.HELP,VSN
 The VSN parameter specifies the Volume Serial Number of the installation
 tape. The local file specified for the LFN parameter is used if no VSN
 is specified.
.HELP,D
 The D parameter selects the Density of the installation tape.
 The default density is PE.
.HELP,UN
 The UN parameter specifies the permanent file ID under which the release
 files are installed. It is required only on NOS/BE systems.
.ENDHELP
UNLOAD,NVELIB,NVEPROL,NVERELS,NOSBINS,RESTORE,CYBCLIB.
UNLOAD,YYYRES,YYYLIB,YYYNOS,YYYNVP,YYYNVE,YYYSCP,YYYDCF.
UNLOAD,YYYNVR,YYYCRL,NVERELB.
.IFE,$UPGRADE$.EQ.$YES$,SITEFILES.
UNLOAD,NEWTPXK,NEWSCP,NEWDCF.
.ELSE,SITEFILES.
UNLOAD,TPXXXK,SITECP,DCFILE.
.ENDIF,SITEFILES.
.IFE,$VSN$.NE.$$,GETTAPE.
  .IFE,SYS=NOS,NOSSYS.
    LABEL,LFN,#VSN=VSN,#D=D,LB=KU,F=I,PO=R.
  .ELSE,NOSSYS.
    REQUEST,LFN,D,#VSN=VSN.
  .ENDIF,NOSSYS.
.ENDIF,GETTAPE.
.IFE,SYS=NOSB,NBESYS.
  REQUEST(YYYLIB,SN,PF)
  REQUEST(YYYNOS,SN,PF)
  REQUEST(YYYNVP,SN,PF)
  REQUEST(YYYNVE,SN,PF)
  REQUEST(YYYSCP,SN,PF)
  REQUEST(YYYDCF,SN,PF)
  REQUEST(YYYNVR,SN,PF)
  REQUEST(CYBCLIB,SN,PF)
.ENDIF,NBESYS.
REWIND,LFN.
COPYBF(LFN,YYYRES)
COPYBF(LFN,YYYLIB)
COPYBF(LFN,YYYNOS)
COPYBF(LFN,YYYNVP)
COPYBF(LFN,YYYNVE)
COPYBF(LFN,YYYSCP)
COPYBF(LFN,YYYDCF)
COPYBF(LFN,YYYNVR)
COPYBF(LFN,YYYCRL)
.IFE,SYS=NOS,NOSSYS2.
  $REWIND,YYYLIB.
  $COPY(YYYLIB,NVELIB)
  $REWIND,YYYLIB,NVELIB.
  $LIBRARY,NVELIB/A.
  REPFILE(YYYLIB,NVELIB,DEFINE=YES)
  REPFILE(YYYNOS,NOSBINS,DEFINE=YES)
  REPFILE(YYYNVP,NVEPROL)
  REPFILE(YYYNVR,NVERELS,DEFINE=YES)
  REPFILE(YYYCRL,CYBCLIB,DEFINE=YES)
  .IFE,$UPGRADE$.EQ.$YES$,PRESERVE.
    REPFILE,YYYNVE,NEWTPXK,DEFINE=YES.
    REPFILE,YYYSCP,NEWSCP.
    REPFILE,YYYDCF,NEWDCF.
  .ELSE,PRESERVE.
    REPFILE,YYYNVE,TPXXXK,DEFINE=YES.
    REPFILE,YYYSCP,SITECP.
    REPFILE,YYYDCF,DCFILE.
  .ENDIF,PRESERVE.
.ELSE,NOSSYS2.
  .IFE,$UN$.EQ.$$,NOID.
    REVERT,ABORT. NO UN SPECIFIED.
  .ENDIF,NOID.
  CATALOG,YYYLIB,NVELIBB,ID=UN,RP=999.
  CATALOG,YYYNOS,NBEBINS,ID=UN,RP=999.
  CATALOG,YYYNVP,NVEPROL,ID=UN,RP=999.
  CATALOG,YYYNVR,NVERELB,ID=UN,RP=999.
  EDITLIB,I=DIR.
  CATALOG,CYBCLIB,ID=UN,RP=999.
  .IFE,$UPGRADE$.EQ.$YES$,SAVE.
    CATALOG,YYYNVE,NEWTPXK,ID=UN,RP=999.
    CATALOG,YYYSCP,NEWSCP,ID=UN,RP=999.
    CATALOG,YYYDCF,NEWDCF,ID=UN,RP=999.
  .ELSE,SAVE.
    CATALOG,YYYNVE,TPXXXK,ID=UN,RP=999.
    CATALOG,YYYSCP,SITECP,ID=UN,RP=999.
    CATALOG,YYYDCF,DCFILE,ID=UN,RP=999.
  .ENDIF,SAVE.
  RETURN,YYYLIB,YYYNOS,YYYNVP,YYYNVR,YYYNVE,YYYSCP,YYYDCF,CYBCLIB.
  ATTACH,NVEPROL,ID=UN.
.ENDIF,NOSSYS2.
UNLOAD,DIR.
REVERT.  RESTORE COMPLETED NORMALLY.
EXIT.
REVERT,ABORT. RESTORE PROC FAILED.
.DATA,DIR
LIBRARY(CYBCLIB,NEW)
ADD(*,YYYCRL)
FINISH.
ENDRUN.
/EOR
*DECK DECK=RAM$RESTORE_PERMANENT_FILES_DS EXPAND=TRUE
create_program_description name=(restore_permanent_files, restore_permanent_file, respf) ..
      sp=pup$restore_permanent_file l=(osf$current_library osf$task_services_library) ..
      tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$RESTORE_PERMANENT_FILES_SYS EXPAND=TRUE
create_program_description name=(restore_permanent_files, restore_permanent_file, respf) ..
      sp=pup$restore_permanent_file l=('$system.osf$builtin_library' osf$task_services_library) ..
      tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAM$RESTORE_TESTVE EXPAND=TRUE
PROCEDURE restore_testve, rest (
  vsn: any of
         string 1 .. 6
         name 1 .. 6
       anyend = $required
  old_catalog, oc: file = .testve.new_tests
  status)

  create_variables name=(ignore_stat, stat) kind=status

"THIS PROC WILL PURGE AND THEN RESTORE THE CONTENTS OF TESTVE CATALOG
"FROM A BACKUP TAPE.  THE VSN OF THE BACKUP TAPE MUST BE PASSED AS
"A PARAMETER TO THIS PROC.  AN INFORMATIVE ERROR DISPLAY IS PRESENTED
"IF A ERROR IS ENCOUNTERED.

  TASK ring=11 "change to ring 7 when batch ring privilege problem resolved"
    delete_catalog_contents .testve status=stat
  TASKEND
  IF NOT stat.normal AND $condition(stat.condition) = 'PFE$INVALID_RING_ACCESS' THEN
COLLECT_TEXT warning_msg until='  end_of_warning_msg'
YOU MUST DELETE THE FILE .TESTVE.TEST_TOOLS.BOUND_PRODUCT
      USE THE FOLLOWING COMMAND SEQUENCE
            TASK RING=7
            DELETE_FILE .TESTVE.TEST_TOOLS.BOUND_PRODUCT
            TASKEND
      THEN CALL THIS PROCEDURE AGAIN
  end_of_warning_msg
    copy_file warning_msg $output
    EXIT_PROC
  IFEND

  request_magnetic_tape file=tape evsn=vsn type=mt9$6250
  RESTORE_PERMANENT_FILES status=ignore_stat
    restore_existing_catalog catalog=old_catalog backup_file=tape ncn=.testve status=stat
  QUIT

  IF NOT stat.normal THEN
    detach_file file=tape status=ignore_stat
    EXIT_PROC WITH stat
  IFEND
  detach_file file=tape

PROCEND restore_testve

*DECK DECK=RAM$RETAIN_VERSION_ROUTINES EXPAND=TRUE

?? RIGHT := 110 ??
MODULE ram$retain_version_routines;
*copy osd$default_pragmats
*copyc ost$status


VAR
  rav$retain_previous_version: [STATIC, XDCL] boolean := TRUE;

PROCEDURE [XDCL, #GATE] rap$set_retain_version_value (VAR retain_previous_version: boolean;
  VAR status: ost$status);

  status.normal := TRUE;
  rav$retain_previous_version := retain_previous_version;

PROCEND rap$set_retain_version_value;

PROCEDURE [XDCL, #GATE] rap$get_retain_version_value (VAR retain_previous_version: boolean;
  VAR status: ost$status);

  status.normal := TRUE;
  retain_previous_version := rav$retain_previous_version;

PROCEND rap$get_retain_version_value;

MODEND ram$retain_version_routines;
*DECK DECK=RAM$RETRIEVE_QUALIFIED_FILES EXPAND=TRUE
*DECK DECK=RAM$SEARCH_LINK_MAP EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'MAINTAIN_DEADSTART_SOFTWARE Utility: RAP$SEARCH_LINK_MAP Interface' ??
MODULE ram$search_link_map;

{ PURPOSE:
{   This module contains the procedures to search a link map for errors.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc amp$get_next
*copyc amp$put_next
*copyc amp$return
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file

?? OLDTITLE, NEWTITLE := '[XDCL, #GATE] rap$search_link_map', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to search a link map for errors.

  PROCEDURE [XDCL, #GATE] rap$search_link_map
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE search_link_map (
{   link_map, lm: file = $required
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 5] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 9, 20, 14, 25, 25, 790],
    clc$command, 5, 3, 1, 0, 0, 0, 3, ''], [
    ['LINK_MAP                       ',clc$nominal_entry, 1],
    ['LM                             ',clc$abbreviation_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OUTPUT                         ',clc$nominal_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 3
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$link_map = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      attachment_option: array [1 .. 2] of fst$attachment_option,
      blank_string: [STATIC] string (132) := '                                '
            CAT '                                                             '
            CAT '                                       ',
      byte_adr: amt$file_byte_address,
      end_of_string: 0 .. 0ffff(16),
      file_pos: amt$file_position,
      ignore_status: ost$status,
      input_line: string (132),
      map_fid: amt$file_identifier,
      output_fid: amt$file_identifier,
      short: string (7),
      tran_cnt: amt$transfer_count;


    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    attachment_option [1].selector := fsc$access_and_share_modes;
    attachment_option [1].access_modes.selector := fsc$specific_access_modes;
    attachment_option [1].access_modes.value :=
          $fst$file_access_options [fsc$read];
    attachment_option [1].share_modes.selector := fsc$specific_share_modes;
    attachment_option [1].share_modes.value :=
          $fst$file_access_options [fsc$read, fsc$execute];
    attachment_option [2].selector := fsc$create_file;
    attachment_option [2].create_file := FALSE;

    fsp$open_file (pvt [p$link_map].value^.file_value^, amc$record, ^attachment_option,
          NIL, NIL, NIL, NIL, map_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$open_file (pvt [p$output].value^.file_value^, amc$record, NIL, NIL, NIL, NIL,
          NIL, output_fid, status);
    IF NOT status.normal THEN
      fsp$close_file (map_fid, ignore_status);
      RETURN;
    IFEND;

    input_line := blank_string;
    amp$get_next (map_fid, ^input_line, #SIZE (input_line), tran_cnt, byte_adr,
          file_pos, status);
    IF NOT status.normal THEN
      fsp$close_file (output_fid, ignore_status);
      fsp$close_file (map_fid, ignore_status);
      RETURN;
    IFEND;
   /search/
    WHILE (file_pos <> amc$eoi) DO
      short := input_line (3, 8);
      IF (short = '--WARNI') OR (short = '--ERROR') OR (short = '--FATAL') THEN
        amp$put_next (output_fid, ^input_line, tran_cnt, byte_adr, status);
        IF NOT status.normal THEN
          EXIT /search/;
        IFEND;

        end_of_string := clp$trimmed_string_size (input_line);
        IF input_line (end_of_string - 5, 6) = 'module' THEN
          input_line := blank_string;
          amp$get_next (map_fid, ^input_line, #SIZE (input_line), tran_cnt,
                byte_adr, file_pos, status);
          IF NOT status.normal THEN
            EXIT /search/;
          IFEND;

          amp$put_next (output_fid, ^input_line, tran_cnt, byte_adr, status);
          IF NOT status.normal THEN
            EXIT /search/;
          IFEND;
        IFEND;
      IFEND;

      input_line := blank_string;
      amp$get_next (map_fid, ^input_line, #SIZE (input_line), tran_cnt,
            byte_adr, file_pos, status);
      IF NOT status.normal THEN
        EXIT /search/;
      IFEND;
    WHILEND /search/;

    fsp$close_file (map_fid, ignore_status);
    fsp$close_file (output_fid, ignore_status);

  PROCEND rap$search_link_map;
?? OLDTITLE ??
MODEND ram$search_link_map;
*DECK DECK=RAM$SEARCH_LINK_MAP_PD EXPAND=TRUE
create_program_description names=(search_link_map, sealm) ..
  libraries=(osf$current_library cyf$run_time_library osf$task_services_library) ..
  starting_procedure=rap$search_link_map load_map=$null load_map_options=none ..
  termination_error_level=error preset_value=zero
*DECK DECK=RAM$SETUP_INSTALLATION_PROCESS EXPAND=TRUE
PROC setup_installation_process, setip (
  family_name, fn: name = $required
  user_name, un: name = $required
  status)

    create_variable ignore_status k=status
    create_variable local_status k=status


  WHEN any_fault DO
    display_value osv$status o=$response
  WHENEND


  create_family family_name=$value(family_name) family_user_administrator=$value(user_name) ..
        status=local_status
  EXIT_PROC WITH local_status WHEN NOT local_status.normal

  put_line 'change_job_attribute_default login_family='//$string($value(family_name)) ..
        o=$system.prologs_and_epilogs.system_initiation_prolog.$eoi

  change_job_attribute_default login_family=$value(family_name)

  change_terminal_environment configuration_file_access=on fn=$value(family_name) un=$value(user_name)

  copy_file i=$system.mainframe.configuration ..
        o=$system.site_os_maintenance.deadstart_commands.physical_configuration

  detach_file $system.mainframe.configuration status=ignore_status
  detach_file $system.site_os_maintenance.deadstart_commands.physical_configuration status=ignore_status

  create_file_permit f=$system.manuals.site_analyst_examples g=user fn=$value(family_name) ..
        u=$value(user_name)
  create_file_permit f=$system.manuals.examples_files.site_analyst_source_library ..
        g=user fn=$value(family_name) u=$value(user_name)


PROCEND setup_installation_process

*DECK DECK=RAM$SET_FILE_RETENTION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$SET_FILE_RETENTION Interface.' ??
MODULE ram$set_file_retention;

{ PURPOSE:
{   This module contains the interface that sets the retention period
{   for a file.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
?? POP ??
*copyc clp$trimmed_string_size
*copyc pfp$change
*copyc pfp$convert_fs_path_to_pf_path
*copyc pfp$convert_string_to_fs_path
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$set_file_retention', EJECT ??

{ PURPOSE:
{   This interface sets the retention period for a file.
{
{ DESIGN:
{   The file is first converted from FS format to PF format so that the
{   interface that sets the retention period can be called.
{
{ NOTES:
{


  PROCEDURE [XDCL] rap$set_file_retention
    (    file: fst$file_reference;
         retention_period: pft$retention;
     VAR status: ost$status);


    CONST
      no_password = '                               ';

    VAR
      cycle_reference: fst$cycle_reference,
      cycle_selector: clt$cycle_selector,
      fs_path: string (fsc$max_path_size),
      ignore_open_position: fst$open_position,
      ignore_password: pft$password,
      new_retention_period: array [1 .. 1] of pft$change_descriptor,
      number_of_path_elements: fst$number_of_path_elements,
      pf_path_p: ^pft$path;


    status.normal := TRUE;

{ Convert the file path, which is in FS format to PF format.

    pfp$convert_string_to_fs_path (file, fs_path, number_of_path_elements, cycle_reference,
          ignore_open_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH pf_path_p: [1 .. number_of_path_elements];

    pfp$convert_fs_path_to_pf_path (fs_path, pf_path_p, cycle_reference, cycle_selector, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Set the retention period for the file.

    new_retention_period [1].change_type := pfc$retention_change;
    new_retention_period [1].retention := retention_period;

    pfp$change (pf_path_p^, cycle_selector.value, no_password, new_retention_period, status);

  PROCEND rap$set_file_retention;
MODEND ram$set_file_retention;
*DECK DECK=RAM$SORLIB EXPAND=TRUE
.PROC,SORLIB*I,
L "- Library file name"                = (*N=#FILE,*F),
UN "- User Name containing library"    = (*N=,*F),
.
.HELP
 The SORLIB procedure SORts records on a LIBrary file.
 Requires CATALOG binaries with GENCAT entry point.

 Parameter   Default   Description
   Name       Value

  [l]                  library file containing the records
  [un]                 user name in which library resides

.HELP,L
 The L parameter names the file containing records to sort.
 The default value is the file containing this procedure.
.HELP,UN
 The UN parameter specifies the User Name location of the file.
 The default value is the User Name in which this procedure executes.
.ENDHELP
GETFILE,L,L,UN,A=YES.
DISLIB,ALL,,L,UN,O=YYYYINP,DO=D.
$SORT5.FROM=YYYYINP TO=YYYYOUT KEY=(21..21,11..17)
CRELIB,L,#L=L,I=YYYYOUT,N=L.
$UNLOAD,YYYYOLD,YYYYINP,ZZZZZDG,YYYYOUT.
$SKIP,NOERROR.
  $EXIT.
  .IFE,FILE(L,.NOT.AS),FILEPRM.
    $UNLOAD,L.
  .ENDIF,FILEPRM.
  $UNLOAD,YYYYOUT,YYYYINP,ZZZZZDG,YYYYOLD.
  $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    $EXIT. SORLIB *TERMINATED*
  $ENDIF,TERMINATED.
  $REVERT,ABORT. SORT OF L FAILED
$ENDIF,NOERROR.
.IFE,FILE(L,.NOT.AS),FILEPRM.
  $UNLOAD,L.
.ELSE,FILEPRM.
  $LIBRARY,L/D.
  $LIBRARY,L/A.
.ENDIF,FILEPRM.
$REVERT. LIBRARY L SORTED
/EOR
*DECK DECK=RAM$SORPROC EXPAND=TRUE
.PROC,SORPROC*I,
L "- Library containg procedures"      = (*N=#FILE,*F),
UN "- User Name containing library"    = (*N=,*F),
.
.HELP
 The SORPROC procedure SORts PROCedures on a library file.
 Requires CATALOG binaries with GENCAT entry point.

 Parameter   Default   Description
   Name       Value

  [l]                  library file containing the procedures
  [un]                 user name in which library resides

.HELP,L
 The L parameter names the procedure library file to sort.
 The default value is the file containing this procedure.
.HELP,UN
 The UN parameter specifies the User Name location of the file.
 The default value is the User Name in which this procedure executes.
.ENDHELP
$REVERT,EX.SORLIB,L,UN.
/EOR
*DECK DECK=RAM$SORTEXT EXPAND=TRUE
.PROC,SORTEXT*I,
L "- Library containing TEXT records"  = (*N=#FILE,*F),
UN "- User Name containing library"    = (*N=,*F),
.
.HELP
 The SORTEXT procedure SORts TEXT records on a library file.
 Requires CATALOG binaries with GENCAT entry point.

 Parameter   Default   Description
   Name       Value

  [l]                  library file containing the TEXT records
  [un]                 user name in which library resides

.HELP,L
 The L parameter names the TEXT record file to sort.
 The default value is the file containing this procedure.
.HELP,UN
 The UN parameter specifies the User Name location of the file.
 The default value is the User Name in which this procedure executes.
.ENDHELP
$REVERT,EX.SORLIB,L,UN.
/EOR
*DECK DECK=RAM$SORT_PSRS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'CREATE_SUBPRODUCT_CORRECTION subutility: RAP$SORT_PSRS procedure.' ??
MODULE ram$sort_psrs;

{ PURPOSE:
{   This module contains the procedure to sort an array of psrs.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rat$subproduct_info_types
?? POP ??

?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL rap$sort_psrs', EJECT ??

{ PURPOSE:
{   This procedure sorts the psr list.
{
{ DESIGN:
{   This procedure uses a shell sort.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$sort_psrs
    (VAR psr_list: rat$psrs_answered);

    VAR
      current: integer,
      gap: integer,
      start: integer,
      swap: rat$psr;


    gap := UPPERBOUND (psr_list);
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := LOWERBOUND (psr_list) TO UPPERBOUND (psr_list) - gap DO
        current := start;
        WHILE (current > 0) AND (psr_list [current] > psr_list [current + gap]) DO
          swap := psr_list [current];
          psr_list [current] := psr_list [current + gap];
          psr_list [current + gap] := swap;
          current := current - gap;
        WHILEND;
      FOREND;
    WHILEND;

  PROCEND rap$sort_psrs;

MODEND ram$sort_psrs;
*DECK DECK=RAM$STAGE_PRODUCTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$STAGE_PRODUCTS Interface.' ??
MODULE ram$stage_products;

{ PURPOSE:
{   This module contains the interface and procedures that take a
{   subproduct or subproducts from the loading cycle to the staging cycle.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$installation_cycles
*copyc rae$install_software_cc
*copyc rat$installation_control_record
?? POP ??
*copyc amp$change_file_attributes
*copyc amp$return
*copyc avp$ring_min
*copyc fsp$copy_file
*copyc osp$append_status_file
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pfp$change
*copyc pfp$find_directory_array
*copyc pfp$find_direct_info_record
*copyc pfp$find_next_info_record
*copyc pfp$find_permit_array
*copyc pfp$get_item_info
*copyc pfp$permit
*copyc pfp$permit_catalog
*copyc pfp$purge
*copyc rap$clear_installation
*copyc rap$convert_path_to_str
*copyc rap$get_cycle_data
*copyc rap$get_majority_file_class
*copyc rap$record_step_status
*copyc rap$record_subproduct_status
*copyc rmp$request_mass_storage
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$stage_products', EJECT ??

{ PURPOSE:
{   This interface controls the step to stage products.
{
{ DESIGN:
{   The stage products step moves the subproducts from the loading cycle to
{   the staging cycle.  The staging cycle is where the subproducts will
{   reside until they are activated for production.  While moving to the
{   staging cycle the files belonging to the subproducts are placed in
{   their proper storage class.  Once in the staging cycle, catalog and file
{   permits are created (where defined) and the file ring attributes are
{   set.
{
{   By placing the file on the correct storage class during this step
{   rather than the activation step, we prevent the possibility of causing
{   an error (attempting to move a file to a storage class that is
{   unavailable) during a deadstart to activate deferred files.
{
{   The inability to stage any file belonging to a subproduct will cause
{   the entire subproduct to have failed the staging step.  The installation
{   processing record for that subproduct is set as such and the subproduct
{   will be cleared from the system at the conclusion of this step.
{
{   The failure of one subproduct will not jeopardize the remaining
{   subproducts.  Each subproduct will be processed independently.
{
{ NOTES:
{   The SUBPRODUCTS_FAILED_PROCESSING boolean has been initialized outside of
{   this interface and should never be initialized here.
{

  PROCEDURE [XDCL] rap$stage_products
    (VAR installation_control_record {input} : rat$installation_control_record;
     VAR subproducts_failed_processing: boolean;
     VAR status: ost$status);


    VAR
      ignore_keyword: ost$name,
      ignore_status: ost$status,
      local_status: ost$status,
      majority_file_class: rmt$mass_storage_class,
      processing_record: rat$subp_processing_record,
      subproduct_index: rat$subproduct_count,
      task_status: ost$status;


    status.normal := TRUE;

    IF NOT (rac$stage_subproducts_step IN installation_control_record.processing_header_p^.step_set) THEN
      RETURN;
    IFEND;

    rap$record_step_status (rac$stage_subproducts_step, rac$step_started, installation_control_record,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /main/
    FOR subproduct_index := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^)
          DO
      processing_record := installation_control_record.subproduct_processing_records_p^ [subproduct_index];

      IF (installation_control_record.job_identifier = processing_record.job_identifier) AND
            (rac$stage_files_task IN processing_record.task_set) AND
            (processing_record.task_status <> rac$task_failed) THEN

        rap$record_subproduct_status (rac$stage_files_task, rac$task_started, subproduct_index,
              installation_control_record, ignore_status);

        rap$get_majority_file_class (subproduct_index, installation_control_record, ignore_keyword,
              majority_file_class, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        task_status.normal := TRUE;

        IF processing_record.subproduct_info_pointers.attributes_p^.catalog_permit.defined THEN
          create_catalog_permit (processing_record.subproduct_info_pointers.attributes_p^.catalog_permit,
                processing_record.installation_catalog_p^, installation_control_record.scratch_seq_p,
                task_status);
        IFEND;

        IF task_status.normal THEN
          stage_subproduct (processing_record.installation_catalog_p^, majority_file_class,
                installation_control_record.processing_header_p^.installation_defaults.ignore_storage_class,
                installation_control_record.processing_header_p^.installation_defaults.relax_ring_settings,
                processing_record.subproduct_info_pointers.element_list_p,
                processing_record.subproduct_info_pointers.subproduct_info_seq_p,
                installation_control_record.scratch_seq_p, task_status);
        IFEND;

        IF task_status.normal THEN
          rap$record_subproduct_status (rac$stage_files_task, rac$task_completed, subproduct_index,
                installation_control_record, ignore_status);
        ELSE
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], task_status, ignore_status);
          rap$record_subproduct_status (rac$stage_files_task, rac$task_failed, subproduct_index,
                installation_control_record, ignore_status);
          subproducts_failed_processing := TRUE;
        IFEND;

      IFEND;
    FOREND /main/;

    rap$clear_installation (installation_control_record, ignore_status);

    rap$record_step_status (rac$stage_subproducts_step, rac$step_completed, installation_control_record,
          local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

  PROCEND rap$stage_products;

?? OLDTITLE ??
?? NEWTITLE := 'create_catalog_permit', EJECT ??

{ PURPOSE:
{   This procedure creates a permit for a catalog belonging to the
{   subproduct.
{
{ DESIGN:
{   The permit to be created is defined by a permit record that was defined
{   in the SIF for the subproduct.
{
{   If a permit already exists for the catalog the permit is not defined.
{   The standard PF interfaces are used to retrieve permit data for the
{   catalog.
{
{ NOTES:
{   The scratch sequence is used by the PF interfaces as temporary storage
{   for catalog information.
{

  PROCEDURE create_catalog_permit
    (    permit: rat$permit;
         catalog_path: pft$path;
     VAR scratch_seq_p {input} : ^SEQ ( * );
     VAR status: ost$status);


    VAR
      cycles_p: pft$p_cycle_array,
      directory_p: pft$p_directory_array,
      group: pft$group,
      info_record_p: pft$p_info_record,
      permits_p: pft$p_permit_array;


    status.normal := TRUE;

    group.group_type := pfc$member;
    group.member_description.family := osc$null_name;
    group.member_description.account := osc$null_name;
    group.member_description.project := osc$null_name;
    group.member_description.user := osc$null_name;

    RESET scratch_seq_p;

    pfp$get_item_info (catalog_path, group, $pft$catalog_info_selections
          [pfc$catalog_directory, pfc$catalog_description, pfc$catalog_permits], $pft$file_info_selections [],
          scratch_seq_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET scratch_seq_p;

    pfp$find_next_info_record (scratch_seq_p, info_record_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$find_directory_array (info_record_p, directory_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$find_direct_info_record (^info_record_p^.body, directory_p^ [1].info_offset, info_record_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$find_permit_array (info_record_p, permits_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { When no permits are found the catalog permit will be created.

    IF permits_p = NIL THEN

      group.group_type := pfc$public;

      pfp$permit_catalog (catalog_path, group, permit.permit_selections, permit.share_requirements,
            permit.application_info, status);
    IFEND;

  PROCEND create_catalog_permit;

?? OLDTITLE ??
?? NEWTITLE := 'stage_file', EJECT ??

{ PURPOSE:
{   This procedure stages a file for a subproduct.
{
{ DESIGN:
{   The file is moved to the staging cycle.  If the file is not in the
{   proper storage class it must be moved to the correct one.  This is
{   accomplished by a request for mass storage followed by a copy file.
{   The majority of the files were loaded to the proper storage class, so
{   this situation will occur in less that half of the files (determined by
{   size).  If the file is on the correct storage class a cycle change is
{   performed.
{
{   Once in the staging cycle the ring attributes and permits are set.
{
{   The RELAX_RING_SETTINGS flag is an install_software checkout hook.  The normal
{   values are compressed up to the user's minimum ring when the ring
{   values are below the user's minimum ring.
{
{   When a public permit has been declared for the file and the file
{   contains only 1 cycle, the permit is defined.  Otherwise, it is assumed
{   that the file has previously been installed and all desired permits
{   have already been created (and any unwanted public permit has been
{   deleted).  This protects the permits as the site has defined them.
{
{ NOTES:
{   The ring attributes record in the element record is converted
{   to a format that is compatible for PFP$CHANGE_FILE_ATTRIBUTES.
{
{   The scratch sequence is used by GET_CYCLE_DATA as temporary storage
{   for file information.
{

  PROCEDURE stage_file
    (    element_p: ^rat$element;
         file_path: pft$path;
         majority_file_class: rmt$mass_storage_class;
         ignore_storage_class: boolean;
         relax_ring_settings: boolean;
     VAR scratch_seq_p {input} : ^SEQ ( * );
     VAR status: ost$status);


    VAR
      cycles_p: pft$p_cycle_array,
      file_attributes: array [1 .. 1] of amt$file_item,
      file_loading_path: rat$path,
      file_staging_path: rat$path,
      file_fs: rat$path,
      group: pft$group,
      ignore_status: ost$status,
      loading_cycle: pft$cycle_selector,
      local_status: ost$status,
      password: pft$password,
      public_permit: pft$permit_array_entry,
      public_permit_found: boolean,
      ring_attributes: amt$ring_attributes,
      staging_cycle: array [1 .. 1] of pft$change_descriptor,
      user_minimum_ring: ost$ring;


    status.normal := TRUE;
    loading_cycle.cycle_option := pfc$specific_cycle;
    loading_cycle.cycle_number := rac$loading_cycle;
    password := '';

    rap$convert_path_to_str (file_path, file_fs);
    STRINGREP (file_staging_path.path, file_staging_path.size, file_fs.path (1, file_fs.size), '.',
          rac$staging_cycle_str);

    { move the file from the loading cycle to the staging cycle with the correct storage class.

    IF element_p^.storage_class = majority_file_class THEN
      staging_cycle [1].change_type := pfc$cycle_number_change;
      staging_cycle [1].cycle_number := rac$staging_cycle;

      pfp$change (file_path, loading_cycle, password, staging_cycle, status);

    ELSE
      STRINGREP (file_loading_path.path, file_loading_path.size, file_fs.path (1, file_fs.size), '.',
            rac$loading_cycle_str);

      rmp$request_mass_storage (file_staging_path.path (1, file_staging_path.size),
            rmc$unspecified_allocation_size, rmc$unspecified_file_size, element_p^.storage_class,
            rmc$unspecified_vsn, TRUE, status);
      IF (NOT status.normal) AND (NOT ignore_storage_class) THEN
        RETURN;
      IFEND;

      fsp$copy_file (file_loading_path.path (1, file_loading_path.size),
            file_staging_path.path (1, file_staging_path.size), NIL, NIL, NIL, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      { The interface rmp$request_mass_storage attaches the file and therefore must be returned.

      amp$return (file_staging_path.path (1, file_staging_path.size), status);
      IF (NOT status.normal) AND (NOT ignore_storage_class) THEN
        RETURN;
      IFEND;

      pfp$purge (file_path, loading_cycle, password, status);

    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Set rings.

    ring_attributes.r1 := element_p^.ring_attributes.r1;
    ring_attributes.r2 := element_p^.ring_attributes.r2;
    ring_attributes.r3 := element_p^.ring_attributes.r3;
    user_minimum_ring := avp$ring_min ();

    IF NOT relax_ring_settings THEN
      IF (ring_attributes.r1 < user_minimum_ring) OR (ring_attributes.r2 < user_minimum_ring) OR
            (ring_attributes.r3 < user_minimum_ring) THEN
        osp$set_status_abnormal ('RA', rae$insufficient_min_ring, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, file_fs.path (1, file_fs.size), status);
        RETURN;
      IFEND;
    ELSE {compress rings to minimum of user}
      IF ring_attributes.r1 < user_minimum_ring THEN
        ring_attributes.r1 := user_minimum_ring;
      IFEND;
      IF ring_attributes.r2 < user_minimum_ring THEN
        ring_attributes.r2 := user_minimum_ring;
      IFEND;
      IF ring_attributes.r3 < user_minimum_ring THEN
        ring_attributes.r3 := user_minimum_ring;
      IFEND;
    IFEND;

    file_attributes [1].key := amc$ring_attributes;
    file_attributes [1].ring_attributes := ring_attributes;

    amp$change_file_attributes (file_staging_path.path (1, file_staging_path.size), ^file_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Create a public file permit if required.

    IF element_p^.permit.defined THEN

      rap$get_cycle_data (file_path, scratch_seq_p, cycles_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      { When there is only one cycle for the file the permit is defined.
      { When more than one cycle exists it is assumed the permit has previously been defined.

      IF UPPERBOUND (cycles_p^) = 1 THEN

        group.group_type := pfc$public;

        pfp$permit (file_path, group, element_p^.permit.permit_selections,
              element_p^.permit.share_requirements, element_p^.permit.application_info, status);

      IFEND;
    IFEND;

  PROCEND stage_file;

?? OLDTITLE ??
?? NEWTITLE := 'stage_subproduct', EJECT ??

{ PURPOSE:
{   This procedure stages the files belonging to a subproduct.
{
{ DESIGN:
{   Determining what files belong to the subproduct is accomplished by
{   traversing the element list for the subproduct.  The traverse is
{   performed using recursion and each call to STAGE_SUBPRODUCT moves
{   processing down to the next catalog level.
{
{   Only active elements are processed.  An inactive catalog element means
{   that all elements associated with that catalog are also inactive.
{
{   Each file is staged and catalog permits are created as defined.
{
{ NOTES:
{   The scratch sequence is used by a subsequent procedure as temporary
{   storage for file cycle information.  The contents are not preserved.
{

  PROCEDURE stage_subproduct
    (    element_path: pft$path;
         majority_file_class: rmt$mass_storage_class;
         ignore_storage_class: boolean;
         relax_ring_settings: boolean;
     VAR element_p {input} : ^rat$element;
     VAR subproduct_info_seq_p {input} : ^rat$subproduct_info_sequence;
     VAR scratch_seq_p {input} : ^SEQ ( * );
     VAR status: ost$status);


    VAR
      current_element_path_p: ^pft$path,
      first_element_down_p: ^rat$element,
      i: integer;


    status.normal := TRUE;

    { The element_path parameter is the path for the current catalog.  Create
    { a PF format path array that is 1 larger than the size of the element
    { path.  This array will be used to construct the PF paths for the files
    { and subcatalogs that reside in the current catalog.

    PUSH current_element_path_p: [1 .. UPPERBOUND (element_path) + 1];
    FOR i := 1 TO UPPERBOUND (element_path) DO
      current_element_path_p^ [i] := element_path [i];
    FOREND;

    { Process the files and subcatalogs at the current catalog level.

    WHILE element_p <> NIL DO

      current_element_path_p^ [UPPERBOUND (current_element_path_p^)] := element_p^.name;

      IF element_p^.active_element THEN

        IF element_p^.element_type = rac$file THEN

          stage_file (element_p, current_element_path_p^, majority_file_class, ignore_storage_class,
                relax_ring_settings, scratch_seq_p, status);

        ELSEIF (element_p^.element_type = rac$catalog) THEN

          IF element_p^.permit.defined THEN
            create_catalog_permit (element_p^.permit, current_element_path_p^, scratch_seq_p, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

          IF element_p^.element_count <> 0 THEN
            first_element_down_p := #PTR (element_p^.first_element_down_p, subproduct_info_seq_p^);

            stage_subproduct (current_element_path_p^, majority_file_class, ignore_storage_class,
                  relax_ring_settings, first_element_down_p, subproduct_info_seq_p, scratch_seq_p, status);
          IFEND;

        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      element_p := #PTR (element_p^.next_element_across_p, subproduct_info_seq_p^);
    WHILEND;

  PROCEND stage_subproduct;

MODEND ram$stage_products;
*DECK DECK=RAM$SUBMIT_BATCH_JOBS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$SUBMIT_BATCH_JOBS Interface.' ??
MODULE ram$submit_batch_jobs;

{ PURPOSE:
{   This module contains the interface that sets up and submits the batch
{   jobs required to perform an installation event.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$control_file_name
*copyc ost$status
*copyc rat$installation_control_record
*copyc rat$path
?? POP ??
*copyc i#current_sequence_position
*copyc clp$include_line
*copyc clp$put_job_command_response
*copyc clp$trimmed_string_size
*copyc jmp$system_job
*copyc rap$set_file_retention
*copyc rap$write_file_from_memory
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$submit_batch_jobs', EJECT ??

{ PURPOSE:
{   This interface submits the batch jobs required to complete the
{   installation event.
{
{ DESIGN:
{   The installation control file is the mechanism used to pass processing
{   information to the batch jobs.  An installation control file is created
{   from the processing sequence (referenced by the installation control
{   record).  Each batch job will access the installation control file and
{   re-create the processing sequence from it.
{
{   The job processing records from the installation control record contains
{   a record for each job that is required and is used for setting up jobs.
{   The job setup is handled a little differently when a job is submitted
{   from the console than a terminal.
{
{   When submitted from the console the job is created with job class of
{   system.  Also a request for operator action will be given upon any
{   error.  (These are not included in a job submitted from a terminal.)
{
{   In order to install into a family other than that of the current job,
{   the batch job must be in the SYSTEM_OPERATOR_UTILITY.  To still allow
{   testing, SOU is only entered when the batch job is submitted from the
{   console (jmp$system_job=TRUE).
{
{   Each job log is written to EOI of a permanent log file.  The name of the
{   log files are found in the job processing record for each job.
{
{ NOTES:
{   The version of SOU that resides on the deadstart tape is invoked
{   rather than the $SYSTEM (osf$command_library) version.  This avoids
{   problems that may occur if the $SYSTEM version is obsolete.
{
{   ** If installation to other families is to be allowed from a terminal,
{      another scheme will be needed to support testing.  (See above.)
{
{   ** The system catalog default should be coded as a constant.
{

  PROCEDURE [XDCL] rap$submit_batch_jobs
    (VAR installation_control_record {input} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      command_line: string (2500),
      command_line_length: integer,
      current_job: rat$job_count,
      job_identifier: ost$name,
      job_identifier_length: integer,
      installation_control_file: rat$path,
      install_software_command: rat$path,
      length: integer,
      line: string (osc$max_string_size),
      log_file: rat$path,
      system_catalog: rat$path;


    status.normal := TRUE;

    create_control_file (installation_control_record, installation_control_file, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Assemble the command call to INSTALL_SOFTWARE, the program descriptor lives on the builtin library.

    system_catalog := installation_control_record.processing_header_p^.installation_defaults.system_catalog;
    IF system_catalog.size = 0 THEN
      system_catalog.path := ':$SYSTEM.$SYSTEM';
      system_catalog.size := clp$trimmed_string_size (system_catalog.path);
    IFEND;

    STRINGREP (install_software_command.path, install_software_command.size, system_catalog.
          path (1, system_catalog.size), '.OSF$BUILTIN_LIBRARY.INSTALL_SOFTWARE');

{ Each record of the job processing records defines a job that must be submitted.

    FOR current_job := 1 TO UPPERBOUND (installation_control_record.job_processing_records_p^) DO

      job_identifier := installation_control_record.job_processing_records_p^ [current_job].job_identifier;
      job_identifier_length := clp$trimmed_string_size (job_identifier);

      { Assemble the path to the log file under the installation identifier catalog.

      STRINGREP (log_file.path, log_file.size, installation_control_record.processing_header_p^.
            installation_defaults.installation_logs.path (1, installation_control_record.processing_header_p^.
            installation_defaults.installation_logs.size), '.',
            installation_control_record.processing_header_p^.installation_identifier
            (1, clp$trimmed_string_size (installation_control_record.processing_header_p^.
            installation_identifier)), '.', installation_control_record.
            job_processing_records_p^ [current_job].log_file_name
            (1, clp$trimmed_string_size (installation_control_record.job_processing_records_p^ [current_job]
            .log_file_name)), '.$eoi');

      { Assemble the SCL commands that will execute in the batch job.

      IF jmp$system_job () THEN

?? FMT (FORMAT := OFF) ??
        STRINGREP (command_line, command_line_length,
          'JOB jn=', job_identifier (1, job_identifier_length), ' jc=system',
                 ' odi=', log_file.path (1, log_file.size), '; ',
            'WHEN any_fault DO; ',
              '$system.put_line l='' ''//$strrep(osv$status) o=$job_log; ',
              'send_operator_message message=''Job ',
                     job_identifier (1, job_identifier_length),
                     ' failed.  See ', log_file.path (1, log_file.size-5),
                     ' for details.'' operator_class=system_operator; ',
            'WHENEND;',
            'create_variable n=rav$status k=status;',
            '$system.osf$sou_library.system_operator_utility c=system_administration; ',
               install_software_command.path (1, install_software_command.size), '; ',
                'rap$perform_installation ',
                     ' icf=', installation_control_file.path (1, installation_control_file.size),
                     ' ji=', job_identifier (1, job_identifier_length), ' status=rav$status; ',
              'quit; ',
            'quit; ',
            'IF NOT rav$status.normal THEN;',
              'IF $condition(rav$status.condition) = ''RAE$SUBPRODUCTS_FAILED_INSTALL'' THEN;',
                'cancel any_fault;',
                'send_operator_message message=''Errors in job ',
                       job_identifier (1, job_identifier_length),
                       '.  See ', log_file.path (1, log_file.size-5),
                       ' for details.'' operator_class=system_operator; ',
              'ELSE;',
                'cancel any_fault;',
                '$system.put_line l='' ''//$strrep(rav$status) o=$job_log; ',
                'send_operator_message message=''Failure in job ',
                       job_identifier (1, job_identifier_length),
                       '.  See ', log_file.path (1, log_file.size-5),
                       ' for details.'' operator_class=system_operator; ',
              'IFEND;',
            'IFEND;',
          'JOBEND');
?? FMT (FORMAT := ON) ??

      ELSE {not system job}

?? FMT (FORMAT := OFF) ??
        STRINGREP (command_line, command_line_length,
          'JOB jn=', job_identifier (1, job_identifier_length),
                ' odi=', log_file.path (1, log_file.size), '; ',
            '$system.osf$sou_library.system_operator_utility; ',
               install_software_command.path (1, install_software_command.size), '; ',
                'rap$perform_installation ',
                     ' icf=', installation_control_file.path (1, installation_control_file.size),
                     ' ji=', job_identifier (1, job_identifier_length), '; ',
              'quit; ',
            'quit; ',
          'JOBEND');
?? FMT (FORMAT := ON) ??

      IFEND;

      clp$include_line (command_line (1, command_line_length), TRUE, osc$null_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      { Display job identifier to $response.

      STRINGREP (line, length, '0Submitted job ', job_identifier (1, job_identifier_length), '.');
      clp$put_job_command_response (line (1, length), status);

    FOREND;

  PROCEND rap$submit_batch_jobs;

?? OLDTITLE ??
?? NEWTITLE := 'create_control_file', EJECT ??

{ PURPOSE:
{   This procedure creates the installation control file for the current
{   installation event.
{
{ DESIGN:
{   The installation control file is created as a file copy of the
{   processing sequence that resides in memory.  Its purpose is to provide
{   batch jobs with access to the same information originally contained in
{   the processing sequence.
{
{   The current sequence position of the processing sequence is assumed to
{   be eoi.
{
{   A retention period of 7 days is placed on the log file.
{
{ NOTES:
{

  PROCEDURE create_control_file
    (VAR installation_control_record {input} : rat$installation_control_record;
     VAR installation_control_file: rat$path;
     VAR status: ost$status);


    CONST
      retention_period = 7;


    status.normal := TRUE;

    { Assemble the path to the installation control file using the installation logs path,
    { the installation identifier and the installation control file name.

    STRINGREP (installation_control_file.path, installation_control_file.size,
          installation_control_record.processing_header_p^.installation_defaults.installation_logs.
          path (1, installation_control_record.processing_header_p^.installation_defaults.
          installation_logs.size), '.', installation_control_record.processing_header_p^.
          installation_identifier (1, clp$trimmed_string_size
          (installation_control_record.processing_header_p^.installation_identifier)), '.',
          rac$control_file_name);

    rap$write_file_from_memory (installation_control_file.path (1, installation_control_file.size),
          i#current_sequence_position (installation_control_record.processing_seq_p),
          installation_control_record.processing_seq_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Set retention date on the installation control file just created.

    rap$set_file_retention (installation_control_file.path (1, installation_control_file.size),
          retention_period, status);

  PROCEND create_control_file;
MODEND ram$submit_batch_jobs;
*DECK DECK=RAM$SUMMARIZE_DEBUGGER_DUMPS EXPAND=TRUE
PROCEDURE ram$summarize_debugger_dumps, summarize_debugger_dumps, sumdd (
  output, o: any of
      file
    anyend = $output
  status)

  catalog_contents = $catalog_contents($system.dumps include_files)
  put_line ' Summary of Debugger Dumps in '//$string($fname('$system.dumps'))//':' output=output
  put_line ' ' output=output.$eoi

  create_variable ignore_status k=status

  FOR each catalog_file IN catalog_contents DO
    dump_files = $file_cycles($fname('$system.dumps.'//catalog_file) paths)

    FOR EACH dump_file IN dump_files DO
      EDIT_FILE dump_file prolog=$null output=$null status=ignore_status
        create_variable edit_status k=status

        position_cursor l=first status=edit_status
        IF NOT edit_status.normal THEN

" Somehow we attempted to edit a non-editable file.

          QUIT no edit_status "editor
          CYCLE
        IFEND

        locate_text 'System Core Debugger Dump' lines=all number=1 status=edit_status
        IF NOT edit_status.normal THEN

" This file was not produced by the System Core Debugger.

          QUIT no edit_status "editor
          CYCLE
        IFEND

" Describe the dump file.

        output_string = ' ' // dump_file
        put_line output_string output=output.$eoi

" Describe the contents of the file.

        locate_text 'OS Version: ' lines=all number=1 status=edit_status
        IF edit_status.normal THEN
          output_string = '    ' // $line_text
          put_line output_string output=output.$eoi
        IFEND

        position_cursor l=first
        locate_text 'Creation Date: ' lines=all number=1 status=edit_status
        IF edit_status.normal THEN
          output_string = '    ' // $line_text
          put_line output_string output=output.$eoi
        IFEND

        position_cursor l=first
        locate_text 'Creation Time: ' lines=all number=1 status=edit_status
        IF edit_status.normal THEN
          output_string = '    ' // $line_text
          put_line output_string output=output.$eoi
        IFEND

        position_cursor l=first
        locate_text 'System Supplied Job Name: ' lines=all number=1 status=edit_status
        IF edit_status.normal THEN
          output_string = '    ' // $line_text
          put_line output_string output=output.$eoi
        IFEND

        position_cursor l=first
        locate_text 'User Supplied Job Name: ' lines=all number=1 status=edit_status
        IF edit_status.normal THEN
          output_string = '    ' // $line_text
          put_line output_string output=output.$eoi
        IFEND

        position_cursor l=first
        locate_text 'Task Name: ' lines=all number=1 status=edit_status
        IF edit_status.normal THEN
          output_string = '    ' // $line_text
          put_line output_string output=output.$eoi
        IFEND

        position_cursor l=first
        locate_text 'Job Template Name: ' lines=all number=1 status=edit_status
        IF edit_status.normal THEN
          output_string = '    ' // $line_text
          put_line output_string output=output.$eoi
        IFEND

        position_cursor l=first
        locate_text 'Serial Number: ' lines=all number=1 status=edit_status
        IF edit_status.normal THEN
          output_string = '    ' // $line_text
          put_line output_string output=output.$eoi
        IFEND

      locate_block: ..
        BLOCK
          edit_status.normal=true
          position_cursor line=first
          locate_text 'DUMPJOB Dump of Job Task: ' lines=all number=1 status=edit_status
          IF edit_status.normal THEN

" This file was produced by a DUMPJOB command.

            output_string = '    Dump Contents = DUMPJOB command dump'
            put_line output_string output=output.$eoi
            EXIT locate_block
          IFEND

          edit_status.normal=true
          position_cursor line=first
          locate_text 'Automatic Task Dump' lines=all number=1 status=edit_status
          IF edit_status.normal THEN

" This file was produced by an AUTO subcommand.

            output_string = '    Dump Contents = AUTO subcommand dump'
            put_line output_string output=output.$eoi
            EXIT locate_block
          IFEND

" This file was produced by a SET_OUTPUT_DISPOSITION subcommand.

          output_string = '    Dump Contents = SET_OUTPUT_DISPOSITION subcommand dump'
          put_line output_string output=output.$eoi

        BLOCKEND locate_block

        put_line ' ' output=output.$eoi

      QUIT no "editor"

    FOREND "file reference"
  FOREND "catalog contents"

PROCEND ram$summarize_debugger_dumps
*DECK DECK=RAM$SYSTEM_DEADSTART_PROLOG EXPAND=TRUE
*copy rai$system_deadstart_prolog
*DECK DECK=RAM$SYSTEM_EPILOG EXPAND=TRUE
" This deck must be empty
*DECK DECK=RAM$SYSTEM_INITIATION_EPILOG EXPAND=TRUE

" This is the SYSTEM_INITIATION_EPILOG file.  It is stored in the catalog
" $SYSTEM.PROLOGS_AND_EPILOGS.  The commands in this file are executed every
" time the system is initiated.
"
" You may modify this file to perform any work appropriate for your site.
"
" Execution of this file occurs inside a procedure with a WHEN handler so
" that every command in this file will be attempted, regardless of errors.
" In addition you have the status variables IGNORE_STATUS and LOCAL_STATUS
" available to you.
"
" This file is released containing no commands.

*DECK DECK=RAM$SYSTEM_INITIATION_PROLOG EXPAND=TRUE

" This is the SYSTEM_INITIATION_PROLOG file.  It is stored in the catalog
" $SYSTEM.PROLOGS_AND_EPILOGS.  The commands in this file are executed every
" time the system is initiated.  (System initation begins after job recovery.)
"
" You may modify this file to perform any work appropriate for your site.
"
" Execution of this file occurs inside a procedure with a WHEN handler so
" that every command in this file will be attempted, regardless of errors.
" In addition you have the status variables IGNORE_STATUS and LOCAL_STATUS
" available to you.
"
" This file is released containing no commands.

*DECK DECK=RAM$SYSTEM_PROLOG EXPAND=TRUE
" This must be an empty deck
*DECK DECK=RAM$SYSTEM_TERMINATION_PROLOG EXPAND=TRUE

" This is the SYSTEM_TERMINATION_PROLOG file.  It is stored in the catalog
" $SYSTEM.PROLOGS_AND_EPILOGS.  The commands in this file are executed every
" time the system is terminated by the TERMINATE_SYSTEM command.
" You may modify this file to perform any work appropriate for execution
" immediately before the system is terminated.
"
" Execution of this file occurs inside a procedure with a WHEN handler so
" that every command in this file will be attempted, regardless of errors.
" In addition you have the status variables IGNORE_STATUS and LOCAL_STATUS
" available to you.
"
" This file contains no commands when it is released.

*DECK DECK=RAM$TERMINATE_OUTPUT_TASKS EXPAND=TRUE
PROC terminate_output_tasks, terot (
  status)

  create_variable proc_status kind=status
  proc_status.normal = TRUE
  deactivate_system_task task_name=rhoutput status=proc_status
  IF NOT proc_status.normal THEN
    IF $condition(proc_status.condition) <> 'PME$TASK_NOT_CURRENT_CHILD' THEN
      putl ' Deactivation of RHOUTPUT failed for the following reason:' o=$response
      disv proc_status o=$response
      disv proc_status o=$job_log
    IFEND
    proc_status.normal = TRUE
  IFEND
  deactivate_system_task task_name=dump_broken_job status=proc_status
  IF NOT proc_status.normal THEN
    IF $condition(proc_status.condition) <> 'PME$TASK_NOT_CURRENT_CHILD' THEN
      putl ' Deactivation of DUMP_BROKEN_JOB failed for the following reason:' o=$response
      disv proc_status o=$response
      disv proc_status o=$job_log
    IFEND
    proc_status.normal = TRUE
  IFEND

PROCEND terminate_output_tasks
*DECK DECK=RAM$TEST_CYCLES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: Module RAM$TEST_CYCLES.' ??
MODULE ram$test_cycles;

{ PURPOSE:
{   This module contains the procedure to test the cycles on a file.
{
{ DESIGN:
{   If a file cycle exists that should not exist or
{   a file cycle does not exist that should exist,
{   VALIDATION_ERRORS is set to TRUE and passed back to the caller.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$installation_cycles
*copyc rae$package_software_cc
*copyc ost$status
*copyc pft$checksum
*copyc rat$subproduct_info_types
*copyc rat$validation_selections
?? POP ??
*copyc osp$append_status_file
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc pfp$find_cycle_array
*copyc pfp$find_cycle_array_extended
*copyc pfp$find_cycle_directory
*copyc pfp$find_cycle_label
*copyc pfp$find_direct_info_record
*copyc rap$sort_cycles

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$test_cycles', EJECT ??

{ PURPOSE:
{   This procedure tests a file for proper file cycles.
{
{ DESIGN:
{   If a file cycle exists that should not exist or
{   a file cycle does not exist that should exist,
{   VALIDATION_ERRORS is set to TRUE and passed back to the caller.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$test_cycles
    (    validation_selections: rat$validation_selections;
         element_ref_p: ^fst$file_reference;
         info_record_p: pft$p_info_record;
         info_offset: pft$info_offset;
     VAR cycles_p: pft$p_cycle_array;
     VAR validation_errors: boolean;
     VAR attributes_checksum: integer;
     VAR status: ost$status);

    VAR
      cycle_directory_p: pft$p_cycle_directory_array,
      cycle_in_error_p: ^string ( * ),
      cycle_label_seq_p: ^SEQ ( * ),
      cycle_label_checksum_p: ^pft$checksum,
      cycle_length: integer,
      cycle_label_p: pft$p_info_record,
      cycle_record_extended_p: pft$p_info_record,
      cycle_record_p: pft$p_info_record,
      i: pft$array_index,
      ignore_status: ost$status,
      local_status: ost$status,
      max_cycle: string (pfc$maximum_cycle_number),
      message_status: ost$status;


    pfp$find_direct_info_record (^info_record_p^.body, info_offset, cycle_record_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$find_cycle_array_extended (cycle_record_p, cycle_record_extended_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$find_cycle_directory (cycle_record_extended_p, cycle_directory_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$find_direct_info_record (^cycle_record_extended_p^.body,
            cycle_directory_p^ [UPPERBOUND (cycle_directory_p^)].info_offset, cycle_label_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$find_cycle_label (cycle_label_p, cycle_label_seq_p, local_status);
    IF local_status.normal THEN
      RESET cycle_label_seq_p;
      NEXT cycle_label_checksum_p IN cycle_label_seq_p;
      attributes_checksum := cycle_label_checksum_p^;
    ELSE
      osp$set_status_abnormal ('RA', rae$file_never_opened, '', message_status);
      osp$append_status_file (osc$status_parameter_delimiter, element_ref_p^, message_status);
      osp$generate_error_message (message_status, ignore_status);
      validation_errors := TRUE;
    IFEND;

    pfp$find_cycle_array (cycle_record_p, cycles_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$sort_cycles (cycles_p);

    STRINGREP (max_cycle, cycle_length, pfc$maximum_cycle_number);
    PUSH cycle_in_error_p: [cycle_length];

    IF rac$loading_cycle_empty IN validation_selections THEN

      IF rac$loading_cycle = cycles_p^ [UPPERBOUND (cycles_p^)].cycle_number THEN
        STRINGREP (cycle_in_error_p^, cycle_length, rac$loading_cycle);
        osp$set_status_abnormal ('RA', rae$cycle_not_empty, cycle_in_error_p^ (1,cycle_length),
              message_status);
        osp$append_status_file (osc$status_parameter_delimiter, element_ref_p^, message_status);
        osp$generate_error_message (message_status, ignore_status);
        validation_errors := TRUE;
      IFEND;

    IFEND;

    IF rac$staging_cycle_empty IN validation_selections THEN

    /validate_staging_cycle/
      FOR i := UPPERBOUND (cycles_p^) DOWNTO LOWERBOUND (cycles_p^) DO

        IF rac$staging_cycle = cycles_p^ [i].cycle_number THEN
          STRINGREP (cycle_in_error_p^, cycle_length, rac$staging_cycle);
          osp$set_status_abnormal ('RA', rae$cycle_not_empty, cycle_in_error_p^ (1,cycle_length),
                message_status);
          osp$append_status_file (osc$status_parameter_delimiter, element_ref_p^, message_status);
          osp$generate_error_message (message_status, ignore_status);
          validation_errors := TRUE;
          EXIT /validate_staging_cycle/;
        IFEND;

      FOREND /validate_staging_cycle/;

    IFEND;

    IF rac$max_active_cycle_empty IN validation_selections THEN

      IF rac$max_active_cycle = cycles_p^ [LOWERBOUND (cycles_p^)].cycle_number THEN
        STRINGREP (cycle_in_error_p^, cycle_length, rac$max_active_cycle);
        osp$set_status_abnormal ('RA', rae$cycle_not_empty, cycle_in_error_p^ (1,cycle_length),
              message_status);
        osp$append_status_file (osc$status_parameter_delimiter, element_ref_p^, message_status);
        osp$generate_error_message (message_status, ignore_status);
        validation_errors := TRUE;
      IFEND;

    IFEND;

    IF rac$loading_cycle_only IN validation_selections THEN

      IF UPPERBOUND (cycles_p^) > 1 THEN
        STRINGREP (cycle_in_error_p^, cycle_length, rac$loading_cycle);
        osp$set_status_abnormal ('RA', rae$loading_cycle_only, cycle_in_error_p^ (1,cycle_length),
              message_status);
        osp$append_status_file (osc$status_parameter_delimiter, element_ref_p^, message_status);
        osp$generate_error_message (message_status, ignore_status);
        validation_errors := TRUE;
      IFEND;

      IF NOT (rac$loading_cycle = cycles_p^ [UPPERBOUND (cycles_p^)].cycle_number) THEN
        STRINGREP (cycle_in_error_p^, cycle_length, rac$loading_cycle);
        osp$set_status_abnormal ('RA', rae$loading_cycle_only, cycle_in_error_p^ (1,cycle_length),
              message_status);
        osp$append_status_file (osc$status_parameter_delimiter, element_ref_p^, message_status);
        osp$generate_error_message (message_status, ignore_status);
        validation_errors := TRUE;
      IFEND;

    IFEND;

  PROCEND rap$test_cycles;

MODEND ram$test_cycles;
*DECK DECK=RAM$TEST_PERMITS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: Module RAM$TEST_PERMITS.' ??
MODULE ram$test_permits;

{ PURPOSE:
{   This module contains the procedure to test the permits on a
{   catalog or a file.
{
{ DESIGN:
{   If a file or catalog permit exists that should not exist,
{   VALIDATION_ERRORS is set to TRUE and passed back to the caller.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$package_software_cc
*copyc ost$status
*copyc rat$subproduct_info_types
*copyc rat$validation_selections
?? POP ??
*copyc osp$append_status_file
*copyc osp$set_status_abnormal
*copyc pfp$find_direct_info_record
*copyc pfp$find_permit_array
*copyc osp$generate_error_message

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL] rap$test_permits', EJECT ??

{ PURPOSE:
{   This procedure tests for the indicated catalog or file
{   permits.
{
{ DESIGN:
{   If a file or catalog permit exists that should not exist,
{   VALIDATION_ERRORS is set to TRUE and passed back to the caller.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$test_permits
    (    validation_selections: rat$validation_selections;
         element_ref_p: ^fst$file_reference;
         info_record_p: pft$p_info_record;
         info_offset: pft$info_offset;
     VAR validation_errors: boolean;
     VAR status: ost$status);


    VAR
      i: pft$array_index,
      ignore_status: ost$status,
      message_status: ost$status,
      permits_p: pft$p_permit_array,
      permit_info_record_p: pft$p_info_record;

    status.normal := TRUE;

    IF (rac$no_permits IN validation_selections) OR (rac$no_private_permits IN validation_selections) OR
          (rac$warning_public_permits IN validation_selections) THEN

      pfp$find_direct_info_record (^info_record_p^.body, info_offset, permit_info_record_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      pfp$find_permit_array (permit_info_record_p, permits_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF permits_p = NIL THEN
        RETURN;
      IFEND;

      IF rac$no_permits IN validation_selections THEN
        osp$set_status_abnormal ('RA', rae$no_permits_allowed, '', message_status);
        osp$append_status_file (osc$status_parameter_delimiter, element_ref_p^, message_status);
        osp$generate_error_message (message_status, ignore_status);
        validation_errors := TRUE;
      IFEND;

      IF rac$no_private_permits IN validation_selections THEN
        FOR i := LOWERBOUND (permits_p^) TO UPPERBOUND (permits_p^) DO
          IF NOT (permits_p^ [i].group.group_type = pfc$public) THEN
            osp$set_status_abnormal ('RA', rae$no_private_permits_allowed, '', message_status);
            osp$append_status_file (osc$status_parameter_delimiter, element_ref_p^, message_status);
            osp$generate_error_message (message_status, ignore_status);
            validation_errors := TRUE;
          IFEND;
        FOREND;
      IFEND;

      IF rac$warning_public_permits IN validation_selections THEN
        FOR i := LOWERBOUND (permits_p^) TO UPPERBOUND (permits_p^) DO
          IF permits_p^ [i].group.group_type = pfc$public THEN
            osp$set_status_abnormal ('RA', rae$warning_public_permits, '', message_status);
            osp$append_status_file (osc$status_parameter_delimiter, element_ref_p^, message_status);
            osp$generate_error_message (message_status, ignore_status);
            validation_errors := TRUE;
          IFEND;
        FOREND;
      IFEND;
    IFEND;

  PROCEND rap$test_permits;

MODEND ram$test_permits;
*DECK DECK=RAM$TIME_ZONES$DUTCH EXPAND=TRUE
create_message_module name=time_zones$dutch natural_language=dutch
create_parameter_prompt_message name=daylight_saving_time$1 collect_template_until='end_of_time'
Zomertijd, ZT
end_of_time
"
create_parameter_prompt_message name=standard_time$1 collect_template_until='end_of_time'
Wintertijd, WT
end_of_time
"
end_message_module
*DECK DECK=RAM$TIME_ZONES$ENGLISH EXPAND=TRUE
create_message_module name=time_zones$english natural_language=english
create_parameter_prompt_message name=standard_time$0 collect_template_until='end_of_time'
Greenwich Mean Time, GMT
end_of_time
"
create_parameter_prompt_message name=standard_time$_6 collect_template_until='end_of_time'
Central Standard Time, CST
end_of_time
"
create_parameter_prompt_message name=daylight_saving_time$_6 collect_template_until='end_of_time'
Central Daylight Saving Time, CDT
end_of_time
"
create_parameter_prompt_message name=standard_time$_5 collect_template_until='end_of_time'
Eastern Standard Time, EST
end_of_time
"
create_parameter_prompt_message name=daylight_saving_time$_5 collect_template_until='end_of_time'
Eastern Daylight Saving Time, EDT
end_of_time
"
create_parameter_prompt_message name=standard_time$_7 collect_template_until='end_of_time'
Mountain Standard Time, MST
end_of_time
"
create_parameter_prompt_message name=daylight_saving_time$_7 collect_template_until='end_of_time'
Mountain Daylight Saving Time, MDT
end_of_time
"
create_parameter_prompt_message name=standard_time$_8 collect_template_until='end_of_time'
Pacific Standard Time, PST
end_of_time
"
create_parameter_prompt_message name=daylight_saving_time$_8 collect_template_until='end_of_time'
Pacific Daylight Saving Time, PDT
end_of_time
"
create_parameter_prompt_message name=daylight_saving_time$0 collect_template_until='end_of_time'
British Summer Time, BST
end_of_time
"
create_parameter_prompt_message name=standard_time$1 collect_template_until='end_of_time'
Central European Time, CET
end_of_time
"
end_message_module
*DECK DECK=RAM$TIME_ZONES$FLEMISH EXPAND=TRUE
create_message_module name=time_zones$flemish natural_language=flemish
create_parameter_prompt_message name=daylight_saving_time$1 collect_template_until='end_of_time'
Zomertijd, ZT
end_of_time
"
create_parameter_prompt_message name=standard_time$1 collect_template_until='end_of_time'
Wintertijd, WT
end_of_time
"
end_message_module
*DECK DECK=RAM$TIME_ZONES$FRENCH EXPAND=TRUE
create_message_module name=time_zones$french natural_language=french
create_parameter_prompt_message name=standard_time$1 collect_template_until='end_of_time'
Heure d'hiver, HH
end_of_time
"
create_parameter_prompt_message name=daylight_saving_time$1 collect_template_until='end_of_time'
Heure d'ete, HE
end_of_time
end_message_module

*DECK DECK=RAM$TIME_ZONES$GERMAN EXPAND=TRUE
create_message_module name=time_zones$german natural_language=german
create_parameter_prompt_message name=standard_time$1 collect_template_until='end_of_time'
Mitteleurop{ische Zeit, MEZ
end_of_time
"
create_parameter_prompt_message name=daylight_saving_time$1 collect_template_until='end_of_time'
Mitteleurop{ische Sommerzeit, MEZS
end_of_time
end_message_module

*DECK DECK=RAM$TIME_ZONES$ITALIAN EXPAND=TRUE
create_message_module name=time_zones$italian natural_language=italian
create_parameter_prompt_message name=standard_time$1 collect_template_until='end_of_time'
tempo Europeo centrale, TEC
end_of_time
end_message_module

*DECK DECK=RAM$TIME_ZONES$US_ENGLISH EXPAND=TRUE
create_message_module name=time_zones$us_english natural_language=us_english
create_parameter_prompt_message name=standard_time$0 collect_template_until='end_of_time'
Greenwich Mean Time, GMT
end_of_time
"
create_parameter_prompt_message name=standard_time$_6 collect_template_until='end_of_time'
Central Standard Time, CST
end_of_time
"
create_parameter_prompt_message name=daylight_saving_time$_6 collect_template_until='end_of_time'
Central Daylight Saving Time, CDT
end_of_time
"
create_parameter_prompt_message name=standard_time$_5 collect_template_until='end_of_time'
Eastern Standard Time, EST
end_of_time
"
create_parameter_prompt_message name=daylight_saving_time$_5 collect_template_until='end_of_time'
Eastern Daylight Saving Time, EDT
end_of_time
"
create_parameter_prompt_message name=standard_time$_7 collect_template_until='end_of_time'
Mountain Standard Time, MST
end_of_time
"
create_parameter_prompt_message name=daylight_saving_time$_7 collect_template_until='end_of_time'
Mountain Daylight Saving Time, MDT
end_of_time
"
create_parameter_prompt_message name=standard_time$_8 collect_template_until='end_of_time'
Pacific Standard Time, PST
end_of_time
"
create_parameter_prompt_message name=daylight_saving_time$_8 collect_template_until='end_of_time'
Pacific Daylight Saving Time, PDT
end_of_time
"
create_parameter_prompt_message name=daylight_saving_time$0 collect_template_until='end_of_time'
British Summer Time, BST
end_of_time
"
create_parameter_prompt_message name=standard_time$1 collect_template_until='end_of_time'
Central European Time, CET
end_of_time
"
end_message_module
*DECK DECK=RAM$UPDATE_DIRECTORY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$UPDATE_DIRECTORY Interface.' ??
MODULE ram$update_directory;

{ PURPOSE:
{   This module contains the interface and procedures that updates
{   the IDB directory to describe the current state of the installed
{   software.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$install_software_cc
*copyc rac$idb_directory_level
*copyc rac$idb_directory_name
*copyc rac$inss_processor_version
*copyc rac$not_installed
*copyc rat$installation_control_record
*copyc rat$sequence_descriptor_types
?? POP ??
*copyc i#current_sequence_position
*copyc amp$fetch_access_information
*copyc amp$set_segment_eoi
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pmp$get_compact_date_time
*copyc rap$access_directory_for_write
*copyc rap$clear_installation
*copyc rap$convert_path_to_str
*copyc rap$establish_directory_ptrs
*copyc rap$locate_directory_record
*copyc rap$record_step_status
*copyc rap$record_subproduct_status
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$update_directory', EJECT ??

{ PURPOSE:
{   This interface controls the step to update the IDB directory.
{
{ DESIGN:
{   The IDB directory is updated to describe the current state of the
{   installed software.  More precisely, the subproduct information records
{   are set with the proper level data.
{
{   The IDB directory file is opened for write access mode, share mode of
{   none, if not found it will be created.  The directory is then copied to
{   a memory scratch segment where the changes are made.  If the update is
{   successuful the scratch directory is copied back over the IDB directory
{   file.
{
{   Generally, in step processing the failure of one subproduct will not
{   jeopardize the remaining subproducts.  Each subproduct is processed
{   independently.  But in updating the directory a failure of one
{   subproduct affects the remaining subproducts.
{
{ NOTES:
{   The SUBPRODUCTS_FAILED_PROCESSING boolean has been initialized outside of
{   this interface and should never be re-initialized here.
{

  PROCEDURE [XDCL] rap$update_directory
    (VAR installation_control_record {input} : rat$installation_control_record;
     VAR subproducts_failed_processing: boolean;
     VAR status: ost$status);


    VAR
      directory_fid: amt$file_identifier,
      directory_pointers: rat$idb_directory_pointers,
      directory_segment_pointer: amt$segment_pointer,
      file_opened: boolean,
      ignore_status: ost$status,
      local_status: ost$status;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to close the IDB directory
{   when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (directory_fid, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    file_opened := FALSE;

    IF NOT (rac$update_directory_step IN installation_control_record.processing_header_p^.step_set) THEN
      RETURN;
    IFEND;

    rap$record_step_status (rac$update_directory_step, rac$step_started, installation_control_record, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      rap$access_directory_for_write (installation_control_record.processing_header_p^.installation_defaults.
            installation_database, directory_segment_pointer, directory_fid, file_opened, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      copy_directory_into_memory (directory_fid, directory_segment_pointer,
            installation_control_record.scratch_seq_p, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      { Pointers are established to the directory copy in memory.
      { The interface rap$establish_directory_ptrs uses the directory_pointers
      { sequence_p field to establish the rest of the directory pointers.  The
      { path to the installation database catalog is used for message templates
      { only.

      directory_pointers.sequence_p := installation_control_record.scratch_seq_p;

      rap$establish_directory_ptrs (installation_control_record.processing_header_p^.installation_defaults.
            installation_database, directory_pointers, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      update_directory_records (installation_control_record, directory_pointers,
            subproducts_failed_processing, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      write_idb_directory_file (directory_fid, directory_segment_pointer, directory_pointers.sequence_p,
            status);

    END /main/;

    IF file_opened THEN
      fsp$close_file (directory_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;


    osp$disestablish_cond_handler;

    rap$clear_installation (installation_control_record, ignore_status);

    rap$record_step_status (rac$update_directory_step, rac$step_completed, installation_control_record,
          local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;

  PROCEND rap$update_directory;

?? OLDTITLE ??
?? NEWTITLE := 'combine_directory_records', EJECT ??

{ PURPOSE:
{   This procedure combines the new directory records with the
{   directory array.  Once combined the directory is sorted by
{   the sort key field.
{
{ DESIGN:
{   The procedure uses a shell sort.
{
{   The sort key is a combination of the licensed product and
{   subproduct name fields.
{
{ NOTES:
{

  PROCEDURE combine_directory_records
    (    new_directory_record_count: rat$subproduct_count;
     VAR directory_pointers {input} : rat$idb_directory_pointers;
     VAR status: ost$status);


    VAR
      current: integer,
      directory_size: rat$subproduct_count,
      gap: integer,
      start: integer,
      swap: rat$directory_record;


    status.normal := TRUE;

    directory_size := directory_pointers.header_p^.directory_size + new_directory_record_count;

    RESET directory_pointers.sequence_p TO directory_pointers.directory_p;
    NEXT directory_pointers.directory_p: [1 .. directory_size] IN directory_pointers.sequence_p;
    IF directory_pointers.directory_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'IDB directory', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'COMBINING DIRECTORY', status);
      RETURN;
    IFEND;

    directory_pointers.header_p^.directory_size := directory_size;
    directory_pointers.header_p^.directory_rel_p := #REL (directory_pointers.directory_p,
          directory_pointers.sequence_p^);

    { Sort the directory.

    gap := UPPERBOUND (directory_pointers.directory_p^);

    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;

      FOR start := LOWERBOUND (directory_pointers.directory_p^)
            TO UPPERBOUND (directory_pointers.directory_p^) - gap DO
        current := start;

        WHILE (current > 0) AND (directory_pointers.directory_p^ [current].sort_key >
              directory_pointers.directory_p^ [current + gap].sort_key) DO
          swap := directory_pointers.directory_p^ [current];
          directory_pointers.directory_p^ [current] := directory_pointers.directory_p^ [current + gap];
          directory_pointers.directory_p^ [current + gap] := swap;
          current := current - gap;
        WHILEND;

      FOREND;

    WHILEND;

  PROCEND combine_directory_records;

?? OLDTITLE ??
?? NEWTITLE := 'copy_directory_into_memory', EJECT ??

{ PURPOSE:
{   This procedure copies the IDB directory into a scratch memory sequence.
{
{ DESIGN:
{   The direcotry has already been opened for write access.  This causes the
{   end of file to be set far beyond actual EOI.  The actual EOI is
{   retrieved and used to calculate file content size.  This size is
{   reserved in the scratch sequence found in memory and the contents from
{   the directory are copied using a simple assignment statement.
{
{ NOTES:
{

  PROCEDURE copy_directory_into_memory
    (    directory_fid: amt$file_identifier;
     VAR directory_segment_pointer {input} : amt$segment_pointer;
     VAR scratch_seq_p: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      access_information: array [1 .. 1] of amt$access_info,
      file_contents_p: ^rat$idb_directory_sequence,
      ignore_contains_data: boolean,
      ignore_status: ost$status,
      memory_contents_p: ^rat$idb_directory_sequence;


    status.normal := TRUE;

    access_information [1].key := amc$eoi_byte_address;
    amp$fetch_access_information (directory_fid, access_information, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET directory_segment_pointer.sequence_pointer;
    NEXT file_contents_p: [[REP access_information [1].eoi_byte_address OF cell]] IN
          directory_segment_pointer.sequence_pointer;
    IF file_contents_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'IDB directory', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'FILE SEQUENCE', status);
      RETURN;
    IFEND;

    RESET scratch_seq_p;
    NEXT memory_contents_p: [[REP access_information [1].eoi_byte_address OF cell]] IN scratch_seq_p;
    IF memory_contents_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'IDB directory', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'MEMORY SEQUENCE', status);
      RETURN;
    IFEND;

    memory_contents_p^ := file_contents_p^;

  PROCEND copy_directory_into_memory;

?? OLDTITLE ??
?? NEWTITLE := 'initialize_directory_record', EJECT ??

{ PURPOSE:
{   This procedure initializes a new directory record for a subproduct.
{
{ DESIGN:
{   The record is added to the end of the directory sequence.  Later it will
{   be combined and sorted with the rest of the directory records.
{
{ NOTES:
{   Every field except the subproduct's name field will be set by another
{   procedure.
{

  PROCEDURE initialize_directory_record
    (    subproduct_attributes_p: ^rat$subproduct_attributes;
     VAR directory_record_p: ^rat$directory_record;
     VAR directory_sequence_p: ^rat$idb_directory_sequence;
     VAR new_directory_record_count: rat$subproduct_count;
     VAR status: ost$status);


    status.normal := TRUE;

    NEXT directory_record_p IN directory_sequence_p;
    IF directory_record_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'IDB directory', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'NEW ENTRY', status);
      RETURN;
    IFEND;

    new_directory_record_count := new_directory_record_count + 1;

    { Initialize general data and installation identifiers.

    directory_record_p^.subproduct := subproduct_attributes_p^.name;
    directory_record_p^.licensed_product := subproduct_attributes_p^.licensed_product;
    directory_record_p^.primary_subproduct := subproduct_attributes_p^.primary;
    directory_record_p^.description := subproduct_attributes_p^.description;
    directory_record_p^.hidden := subproduct_attributes_p^.hidden;
    directory_record_p^.subproduct_corrupted := FALSE;
    directory_record_p^.base_level_installation_catalog.size := 0;
    directory_record_p^.system_catalog_path_index := 0;
    directory_record_p^.active_information.installation_identifier := rac$not_installed;
    directory_record_p^.deferred_information.installation_identifier := rac$not_installed;
    directory_record_p^.corrective_base_information.installation_identifier := rac$not_installed;

  PROCEND initialize_directory_record;

?? OLDTITLE ??
?? NEWTITLE := 'set_directory_record', EJECT ??

{ PURPOSE:
{   This procedure sets the main directory record fields for a subproduct of
{   type release.
{
{ DESIGN:
{   The subproduct is assumed to be of type release.  The setting of the
{   directory record fields are not very exciting except for the base level
{   installation catalog and system catalog index.
{
{   The installation catalog of a release subproduct is the base level
{   installation catalog for that subproduct.  The path must first be
{   reformated from PF to a string format.
{
{   The system catalog index locates that portion of the base level
{   installation catalog that is defined as the system catalog.  The index
{   is computed by analyzing the system catalog path size defined in the
{   installation defaults.  If the system catalog path size is not zero, the
{   default system catalog path was merged with the subproduct's
{   installation path to create the installation catalog path.  The system
{   catalog index is therefore the same as the default system catalog path
{   size.  Otherwise, the subproduct's installation path was taken as is for
{   the installation catalog path.  The system catalog index is the length
{   of the family and user catalogs combined.
{
{ NOTES:
{

  PROCEDURE set_directory_record
    (    subproduct_attributes_p: ^rat$subproduct_attributes;
         installation_catalog_p: ^pft$path;
         default_system_catalog_size: integer;
     VAR directory_record_p: ^rat$directory_record);


    VAR
      catalog_delimiter_count: 0 .. 2,
      index: integer;


    directory_record_p^.licensed_product := subproduct_attributes_p^.licensed_product;
    directory_record_p^.primary_subproduct := subproduct_attributes_p^.primary;
    directory_record_p^.description := subproduct_attributes_p^.description;
    directory_record_p^.hidden := subproduct_attributes_p^.hidden;

    rap$convert_path_to_str (installation_catalog_p^, directory_record_p^.base_level_installation_catalog);

    IF default_system_catalog_size <> 0 THEN
      directory_record_p^.system_catalog_path_index := default_system_catalog_size;
    ELSE

      { System catalog index is the end of the family and user catalogs on the
      { base level installation catalog path.

      index := 0;
      catalog_delimiter_count := 0;
      WHILE (index < directory_record_p^.base_level_installation_catalog.size) AND
            (catalog_delimiter_count < 2) DO
        index := index + 1;
        IF directory_record_p^.base_level_installation_catalog.path (index, 1) = '.' THEN
          catalog_delimiter_count := catalog_delimiter_count + 1;
        IFEND;
      WHILEND;


      IF catalog_delimiter_count < 2 THEN

        { The length of the system catalog path is the same as the
        { length of the base level installation catalog path.

        directory_record_p^.system_catalog_path_index := index;

      ELSE { catalog_delimiter_count = 2 }

        { The index is adjusted to remove the second catalog delimiter.
        { The adjusted value becomes the system catalog path index.

        directory_record_p^.system_catalog_path_index := index - 1;

      IFEND;
    IFEND;

  PROCEND set_directory_record;

?? OLDTITLE ??
?? NEWTITLE := 'set_installation_information', EJECT ??

{ PURPOSE:
{   This procedure sets the installation information record for the
{   subproduct.
{
{ DESIGN:
{   The installation information record can be one of three kinds:  active,
{   deferred, or corrective base.  The filling of these records is exactly
{   the same.
{
{ NOTES:
{

  PROCEDURE set_installation_information
    (    subproduct_index: rat$subproduct_count;
         date_installed: ost$date_time;
         processing_header_p: ^rat$processing_header;
         subproduct_attributes_p: ^rat$subproduct_attributes;
     VAR information_record: rat$information_record);


    information_record.date_installed := date_installed;
    information_record.installation_identifier := processing_header_p^.installation_identifier;
    information_record.subproduct_level := subproduct_attributes_p^.level;
    information_record.internal_level := subproduct_attributes_p^.internal_level;
    information_record.sif_identifier := subproduct_attributes_p^.sif_identifier;
    information_record.packing_list := processing_header_p^.packing_list_name;
    information_record.packing_list_index := subproduct_index;

  PROCEND set_installation_information;

?? OLDTITLE ??
?? NEWTITLE := 'update_directory_for_subproduct', EJECT ??

{ PURPOSE:
{   This procedure updates the directory record for the current subproduct.
{
{ DESIGN:
{   The record is located in the directory, if not found a new record will
{   be added to the EOI of the directory sequence.  The required
{   information is then registered.
{
{   Later, in another procedure, the new directory records are combined
{   with the current directory array and sorted.
{
{ NOTES:
{   ** When the RAP$CLEAR_INSTALLATION interface is implemented we will be
{   able to protect any previous active level all the way up to executing
{   the installer procedure.  When there is no installer procedure we can
{   cleanly back out of the failed installation and protect any existing
{   active level.  The test to set the subproduct as corrupted will have
{   to be adjusted at that time.
{

  PROCEDURE update_directory_for_subproduct
    (    subproduct_index: rat$subproduct_count;
         date_installed: ost$date_time;
         last_task: rat$tasks;
         last_task_status: rat$task_status;
         processing_header_p: ^rat$processing_header;
         processing_record: rat$subp_processing_record;
     VAR directory_pointers {input} : rat$idb_directory_pointers;
     VAR new_directory_record_count: rat$subproduct_count;
     VAR status: ost$status);


    VAR
      directory_record_p: ^rat$directory_record,
      ignore_status: ost$status,
      local_status: ost$status;



    status.normal := TRUE;

    rap$locate_directory_record (processing_record.subproduct_info_pointers.attributes_p^.name,
          processing_record.subproduct_info_pointers.attributes_p^.licensed_product, directory_pointers,
          directory_record_p);

    IF directory_record_p = NIL THEN
      initialize_directory_record (processing_record.subproduct_info_pointers.attributes_p,
            directory_record_p, directory_pointers.sequence_p, new_directory_record_count, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    IF processing_record.task_set <> $rat$task_selections [rac$update_directory_task] THEN

      { The subproduct underwent task processing other than just guaranteeing a directory
      { record was present.

      IF (directory_record_p^.deferred_information.installation_identifier <> rac$not_installed) AND
            (rac$reconcile_file_cycles_task IN processing_record.task_set) THEN

        { The subproduct was previously deferred.

        IF processing_header_p^.installation_command <> rac$activate_product THEN

          { The deferred files are believed to have been shifted out of position.
          { The deferred files can no longer be used.
          { Display the current deferred information to the job log along with a
          { message that the deferred files have been shifted and are no longer
          { recognized as deferred.

          osp$set_status_abnormal ('RA', rae$deferred_subproduct_cleared, directory_record_p^.
                subproduct (1, clp$trimmed_string_size (directory_record_p^.subproduct)), local_status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                directory_record_p^.deferred_information.subproduct_level
                (1, clp$trimmed_string_size (directory_record_p^.deferred_information.subproduct_level)),
                local_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, directory_record_p^.
                licensed_product (1, clp$trimmed_string_size (directory_record_p^.licensed_product)),
                local_status);
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
        IFEND;

        { Clear the deferred information record and decrement the deferred count.

        directory_record_p^.deferred_information.installation_identifier := rac$not_installed;
        directory_pointers.header_p^.deferred_count := directory_pointers.header_p^.deferred_count - 1;

      IFEND;


      IF rac$activate_files_task IN processing_record.task_set THEN

        { An immediate installation was attempted for this subproduct.

        IF last_task_status = rac$task_completed THEN

          { Set the active information record.

          set_installation_information (subproduct_index, date_installed, processing_header_p,
                processing_record.subproduct_info_pointers.attributes_p,
                directory_record_p^.active_information);

          IF processing_record.subproduct_info_pointers.attributes_p^.subproduct_type = rac$release THEN

            { Set the general directory record and corrective base information.

            set_directory_record (processing_record.subproduct_info_pointers.attributes_p,
                  processing_record.installation_catalog_p, processing_header_p^.installation_defaults.
                  system_catalog.size, directory_record_p);

            set_installation_information (subproduct_index, date_installed, processing_header_p,
                  processing_record.subproduct_info_pointers.attributes_p,
                  directory_record_p^.corrective_base_information);

          IFEND;
          directory_record_p^.subproduct_corrupted := FALSE;

        ELSEIF directory_record_p^.active_information.installation_identifier <> rac$not_installed THEN

          { Processing failed and there is potential for subproduct corruption.

          IF processing_record.subproduct_info_pointers.attributes_p^.installation_scheme =
                rac$version_based THEN

            IF (processing_record.subproduct_info_pointers.attributes_p^.installer_procedure.path_length <>
                  0) AND (last_task >= rac$execute_installer_proc_task) THEN

              { The processing failed during execution of the installer procedure.  It cannot
              { be known what the installer procedure did, therefore, the previous active
              { level of the subproduct is assumed to be corrupted and the directory
              { will be set to reflect this.  The installation identifier for the just
              { failed installation will also be registered.

              directory_record_p^.subproduct_corrupted := TRUE;
              directory_record_p^.active_information.installation_identifier :=
                    processing_header_p^.installation_identifier;

            IFEND;

          ELSE {installation_scheme is rac$cycle_based}

            IF last_task >= rac$activate_files_task THEN

              { The processing failed after at least some of the subproduct's files were
              { moved to the active cycle.  There is now a mixture of subproduct levels
              { sitting in the active cycle.  The previous active level of the
              { subproduct is assumed to be corrupted and the directory will be set to
              { reflect this.  The installation identifier for the just failed
              { installation will also be registered.

              directory_record_p^.subproduct_corrupted := TRUE;
              directory_record_p^.active_information.installation_identifier :=
                    processing_header_p^.installation_identifier;

            IFEND;

          IFEND;
        IFEND;

      ELSEIF rac$stage_files_task IN processing_record.task_set THEN

        { A deferred installation was attempted for this subproduct.

        IF last_task_status = rac$task_completed THEN

          { Set the deferred information record and increment deferred count.

          set_installation_information (subproduct_index, date_installed, processing_header_p,
                processing_record.subproduct_info_pointers.attributes_p,
                directory_record_p^.deferred_information);

          directory_pointers.header_p^.deferred_count := directory_pointers.header_p^.deferred_count + 1;

        ELSE {task failed}
          { Nothing needs to be rectified.  Any existing active level is still okay.
        IFEND;

      IFEND;
    IFEND;

  PROCEND update_directory_for_subproduct;

?? OLDTITLE ??
?? NEWTITLE := 'update_directory_records', EJECT ??

{ PURPOSE:
{   This procedure goes through the subproduct processing list and updates
{   the records for any subproduct that requires directory update.
{
{ DESIGN:
{   The rule of thumb in step processing is that the failure of one
{   subproduct will not jeopardize the remaining subproducts.  Each
{   subproduct is processed independently.  The update directory step
{   attempts to hold to that rule even though its not such a clean
{   separation in processing.
{
{ NOTES:
{

  PROCEDURE update_directory_records
    (VAR installation_control_record {input} : rat$installation_control_record;
     VAR directory_pointers {input, output} : rat$idb_directory_pointers;
     VAR subproducts_failed_processing: boolean;
     VAR status: ost$status);


    VAR
      date_installed: ost$date_time,
      ignore_status: ost$status,
      last_task: rat$tasks,
      last_task_status: rat$task_status,
      new_directory_record_count: rat$subproduct_count,
      processing_record: rat$subp_processing_record,
      subproduct_index: rat$subproduct_count,
      task_status: ost$status;


    status.normal := TRUE;
    new_directory_record_count := 0;

    pmp$get_compact_date_time (date_installed, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /main/
    FOR subproduct_index := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^) DO
      processing_record := installation_control_record.subproduct_processing_records_p^ [subproduct_index];

      IF (installation_control_record.job_identifier = processing_record.job_identifier) AND
            (rac$update_directory_task IN processing_record.task_set) THEN

        { The last task and task status from earlier steps are captured to be used
        { in updating the directory.  The directory is updated regardless of the
        { last task status value.  Afterwards, if the earlier task status was
        { failed the task status is reset to failed preventing any subsequent
        { steps from executing.

        last_task := processing_record.task;
        last_task_status := processing_record.task_status;

        rap$record_subproduct_status (rac$update_directory_task, rac$task_started, subproduct_index,
              installation_control_record, ignore_status);

        update_directory_for_subproduct (subproduct_index, date_installed, last_task, last_task_status,
              installation_control_record.processing_header_p, processing_record, directory_pointers,
              new_directory_record_count, task_status);

        IF task_status.normal THEN
          rap$record_subproduct_status (rac$update_directory_task, rac$task_completed, subproduct_index,
                installation_control_record, ignore_status);
        ELSE
          osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], task_status, ignore_status);
          rap$record_subproduct_status (rac$update_directory_task, rac$task_failed, subproduct_index,
                installation_control_record, ignore_status);
          subproducts_failed_processing := TRUE;
        IFEND;

        IF last_task_status = rac$task_failed THEN
          installation_control_record.subproduct_processing_records_p^ [subproduct_index].task_status :=
                rac$task_failed;
        IFEND;

      IFEND;
    FOREND /main/;

    IF new_directory_record_count > 0 THEN
      combine_directory_records (new_directory_record_count, directory_pointers, status);
    IFEND;

  PROCEND update_directory_records;

?? OLDTITLE ??
?? NEWTITLE := 'write_idb_directory_file', EJECT ??

{ PURPOSE:
{   This procedure copies the updated directory into the IDB directory
{   file.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE write_idb_directory_file
    (    directory_fid: amt$file_identifier;
     VAR directory_segment_pointer {input} : amt$segment_pointer;
     VAR scratch_seq_p: ^SEQ ( * );
     VAR status: ost$status);


    VAR
      file_sequence_p: ^rat$idb_directory_sequence,
      memory_sequence_p: ^rat$idb_directory_sequence,
      sequence_length: integer;


    status.normal := TRUE;

    { Copy the directory from the scratch segment to the directory file.

    sequence_length := i#current_sequence_position (scratch_seq_p);

    RESET scratch_seq_p;
    NEXT memory_sequence_p: [[REP sequence_length OF cell]] IN scratch_seq_p;
    IF memory_sequence_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'IDB directory', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'MEMORY SEQUENCE', status);
      RETURN;
    IFEND;

    RESET directory_segment_pointer.sequence_pointer;
    NEXT file_sequence_p: [[REP sequence_length OF cell]] IN directory_segment_pointer.sequence_pointer;
    IF file_sequence_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'IDB directory', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'FILE SEQUENCE', status);
      RETURN;
    IFEND;

    file_sequence_p^ := memory_sequence_p^;

    amp$set_segment_eoi (directory_fid, directory_segment_pointer, status);

  PROCEND write_idb_directory_file;
MODEND ram$update_directory;
*DECK DECK=RAM$UPDVER EXPAND=TRUE
.PROC,UPDVER*I,
DATE "- Current date"                  = (*A),
TIME "- Current time"                  = (*A),
F "- File name of update"              = (*F),
L "- Library name being updated"       = (*N=#FILE,*F),
U "- Update type"                      = (*N=REPLACE,CREATE,DELETE,REPLACE),
.
.HELP
 The UPDVER procedure UPDates the library VERsion of the DISVER procedure.
 Requires CATALOG binaries with GENCAT entry point.

 Parameter   Default   Description
   Name       Value

   date                date library is being updated
   time                time library is being updated
   f                   file containing library updates
  [l]                  library being updated
  [u]        REPLACE   type of update being performed

.HELP,DATE
 The DATE parameter specifies the date of the update, expressed as DATE+.
.HELP,TIME
 The TIME parameter specifies the time of the update, expressed as TIME+.
.HELP,F
 The F parameter names a file containing updates, or the record being deleted.
.HELP,L
 The L parameter names the library being updated.
 The default value is the file containing this procedure.
.HELP,U
.ENDHELP
.IFE,FILE(DISVER,AS),USERVER.
  $UNLOAD,YYYUPD3.
  $REVERT. LOCAL FILE DISVER FOUND
.ENDIF,USERVER.
.IFE,$U$.EQ.$CREATE$,CREATED.
  .IFE,FILE(F,.NOT.AS),NOTLOCAL.
    GETFILE,F,F,,READ.
  .ELSE,NOTLOCAL.
    $REWIND,F.
  .ENDIF,NOTLOCAL.
  $GTR(F,YYYUPD1,,NR,,NA)PROC/DISVER
.ELSE,CREATED.
  .IFE,FILE(L,.NOT.AS),NOTLOCAL.
    GETFILE,L,L,,READ.
  .ELSE,NOTLOCAL.
    $REWIND,L.
  .ENDIF,NOTLOCAL.
  $GTR(L,YYYUPD1,,NR,,NA)PROC/DISVER
.ENDIF,CREATED.
$IFE,FILE(YYYUPD1,AS),CHANGEVER.
  $UNLOAD,YYYUPD3.
$ELSE,CHANGEVER.
  $RENAME,YYYUPD1=YYYUPD3.
  $SKIPEI,YYYUPD1.
$ENDIF,CHANGEVER.
.IFE,$U$.EQ.$CREATE$,CREATED.
  $NOTE(YYYUPD1,NR)+ CREATED L USING F - #DATE: DATE #TIME: TIME
.ENDIF,CREATED.
.IFE,$U$.EQ.$REPLACE$,REPLACED.
  $NOTE(YYYUPD1,NR)+ REPLACED F --> L - #DATE: DATE #TIME: TIME
.ENDIF,REPLACED.
.IFE,$U$.EQ.$DELETE$,DELETED.
  $NOTE(YYYUPD1,NR)+ DELETED F FROM L - #DATE: DATE #TIME: TIME
.ENDIF,DELETED.
DISLIB,ALL,#L=F,O=YYYUPD2,DO=BRIEF.
$REWIND,YYYUPD2.
$COPY,YYYUPD2,YYYUPD1.
$UNLOAD,YYYUPD2.
$NOTE,YYYUPD1,NR.+
$PACK,YYYUPD1.
$RENAME,DISVER=YYYUPD1.
.IFE,FILE(L,.NOT.AS),NOTLOCAL.
  $UNLOAD,L.
.ENDIF,NOTLOCAL.
.IFE,FILE(F,.NOT.AS),NOTLOCAL.
  $UNLOAD,F.
.ENDIF,NOTLOCAL.
$REVERT. F --> L - #DATE TIME
$SKIP,NOERROR.
  $EXIT.
  $UNLOAD,DISVER,YYYUPD1,YYYUPD2.
  .IFE,FILE(L,.NOT.AS),NOTLOCAL.
    $UNLOAD,L.
  .ENDIF,NOTLOCAL.
  .IFE,FILE(F,.NOT.AS),NOTLOCAL.
    $UNLOAD,F.
  .ENDIF,NOTLOCAL.
  $IFE,(EF.EQ.TIE).OR.(EF.EQ.TAE),TERMINATED.
    $EXIT. UPDVER *TERMINATED*
  $ENDIF,TERMINATED.
  $REVERT,ABORT. UPDVER FAILED
$ENDIF,NOERROR.
.DATA,YYYUPD3
.PROC,DISVER*I
.
.HELP
 THE DISVER PROCEDURE DISPLAYS THE VERSION OF THE CURRENT LIBRARY.
.ENDHELP
$REWIND,YYYSCR2.
$COPYEI,YYYSCR2,OUTPUT.
$UNLOAD,YYYSCR2.
$REVERT. LIBRARY VERSION DISPLAYED
#.DATA,YYYSCR2
  COPYRIGHT CONTROL DATA SYSTEMS INC 1992
  NOS/VE 1.0  - NOS USER LIBRARY MAINTENANCE PROCEDURES

/EOR
*DECK DECK=RAM$USE_NTF_UTILITY_PD EXPAND=TRUE
create_program_description (use_ntf_utility, use_ntf_utilities, usenu) ..
   l=('$system.network_transfer_facility.bound_product' ..
   '$system.batch_device_support.osf$batch_device_support') ..
   sp=nfp$use_ntf_utility dm=off

*DECK DECK=RAM$VALIDATE_DEVELOPMENT_USERS EXPAND=TRUE
proc validate_development_users, valdu(
  family,           f : name = nve
  family_user_administrator, fua: name = eval
  password,        pw : name = evalx
  user_validation, uv : file = $OPTIONAL
  display_values,  dv : boolean = false
  status)

  VAR
    administrator_name  : string = $string($value(family_user_administrator))
    create_status       : status
    display_parameters  : boolean= $value(display_values)
    family_name         : string = $string($value(family))
    line                : string = ''
    password            : string = $string($value(password))
    user_validation     : string
    validation_job      : string = ''
  VAREND

  IF NOT $SPECIFIED(user_validation) THEN
    user_validation = 'NOT_SPECIFIED'
  IFEND

  WHILE display_parameters DO
    put_line '1' output=$output
    COLLECT_TEXT o=$output substitution_mark='&' until='    end_val_display'
    --------------------------------------------------
                VALIDATE_DEVELOPMENT_USERS

    1. FAMILY_NAME = &family_name&
    2. ADMINISTRATOR_NAME = &administrator_name&
    3. PASSWORD = &password&
    4. USER_VALIDATION_FILE= &user_validation&

     Enter  GO  to validate users using the above information, or
     enter the appropriate menu number to change the values specified
     above, or enter  QUIT  to terminate the validation process.
    --------------------------------------------------
    end_val_display

    accept_line variable=line input=input p='Enter selection '
    line = $translate(lower_to_upper, line)
    IF line = 'GO' THEN
      display_parameters=false
    ELSEIF line = 'QUIT' THEN
      EXIT_PROC with $status(FALSE,'TT',0,'USER ABORTED VALIDATION PROCESS IN VALIDATE_FAMILY PROCEDURE')
    ELSEIF line = '1' THEN
      accept_line variable=family_name input=input p='specify family_name: '
    ELSEIF line = '2' THEN
      accept_line variable=administrator_name input=input p='specify administrator_name: '
    ELSEIF line = '3' THEN
      accept_line variable=password input=input p='specify password: '
    ELSEIF line = '4' THEN
      put_line l=' Requesting <permanent_file> user validation file to create users' o=$output
      put_line l='         for the afore-mentioned family. ' o=$output
      accept_line variable=user_validation input=input p='Specify user validation file: '
    ELSE
      put_line l=' IGNORING USER INPUT *'//line//'*' output=$output
      WAIT T=1500
    IFEND
  WHILEND   "for display_parameters = true"

  IF $FILE($FNAME(':'//family_name//'.$SYSTEM.$VALIDATIONS'),assigned) = TRUE THEN
    put_line l=' WARNING: Users not created, validation file already exists for family: '//family_name o=$response
    EXIT_PROC
  IFEND
  validation_job = family_name// '_validate'
  create_family fn=$name(family_name) fua=$name(administrator_name) pw=$name(password) status=create_status
  IF NOT create_status.normal THEN
    put_line l=' Call to command create_family failed. ' o=$response
    EXIT_PROC WITH create_status
  IFEND

" Create the Validation Job to set up validations for the family."

  put_line l='  ----  Submitting Validation Job for family: '//family_name o=$response
  JOB sm='&' jn=validation_job
    VAR
      admv_stat              : status
      family_name            : string  = $strrep(&family_name&)
      ignore                 : status
      issue_operator_warning : boolean = false
      sou_stat               : status
      validation_stat        : status
    VAREND

    WHEN any_fault DO
      display_value v=('The following error occurred in VALIDATION job, ..', osv$status) output=$response
      issue_operator_warning=TRUE
      CONTINUE
    WHENEND

" Initiate the System Operator Utility to allow changes to user validations.

    SYSTEM_OPERATOR_UTILITY capability=system_administration status=sou_stat
      IF NOT sou_stat.normal THEN
        display_value v=('The following error occurred calling utility SYSTEM_OPERATOR_UTILITY, ..', sou_stat) o=$response
        issue_operator_warning=TRUE
      ELSE "utility call returned normal"
    ADMINISTER_VALIDATIONS status=admv_stat
      IF NOT admv_stat.normal THEN
        display_value v=('The following error occurred calling utility ADMINISTER_VALIDATIONS, ..', admv_stat) o=$response
        issue_operator_warning=TRUE
      ELSE "utility call returned normal"
        ADMV_BLOCK: BLOCK
          WHEN any_fault DO
            display_value v=('Received the following error in utility ADMINISTER_VALIDATIONS ..', osv$status) o=$response
            issue_operator_warning=TRUE
            continue
          WHENEND

          use_validation_file vf=$fname(':&family_name&.$SYSTEM.$VALIDATIONS') status=validation_stat
          EXIT WHEN NOT validation_stat.normal
          MANAGE_USER_FIELDS
            change_account_project_field fn=creation_account_project defa=account defp=project status=validation_stat
            EXIT WHEN NOT validation_stat.normal
            change_account_project_field fn=default_account_project defa=account defp=project status=validation_stat
            EXIT WHEN NOT validation_stat.normal
            change_file_field fn=user_prolog dv='$system.testing_user_prolog' status=validation_stat
            EXIT WHEN NOT validation_stat.normal
            change_file_field fn=user_epilog dv='$user.epilog' status=validation_stat
            EXIT WHEN NOT validation_stat.normal
            change_job_class_field ad=(batch,interactive,file_transfer) id=interactive bd=batch status=validation_stat
            EXIT WHEN NOT validation_stat.normal
            change_capability_field fn=explicit_remote_file dv=include status=validation_stat
            EXIT WHEN NOT validation_stat.normal
            change_capability_field fn=implicit_remote_file dv=include status=validation_stat
            EXIT WHEN NOT validation_stat.normal
            change_capability_field fn=network_application_management dv=include status=validation_stat
            EXIT WHEN NOT validation_stat.normal
            change_capability_field fn=network_operation dv=include status=validation_stat
            EXIT WHEN NOT validation_stat.normal
            change_capability_field fn=station_operation dv=include status=validation_stat
            EXIT WHEN NOT validation_stat.normal
            change_capability_field fn=timesharing dv=include  status=validation_stat
            EXIT WHEN NOT validation_stat.normal
            create_capability_field fn=read_system_memory dv=include status=validation_stat ..
              d='Allow the user to display operating system memory with the Analyze System utility.'
            EXIT WHEN NOT validation_stat.normal
          END_MANAGE_USER_FIELDS

          CHANGE_USER &administrator_name&
            change_link_attribute_password value='&password&' status=validation_stat
            EXIT WHEN NOT validation_stat.normal
            change_job_class add=(maintenance) status=validation_stat
            EXIT WHEN NOT validation_stat.normal
            change_capability add=all status=validation_stat
            EXIT WHEN NOT validation_stat.normal
          END_CHANGE_USER  WC=TRUE

          IF $strrep(&user_validation&) = 'NOT_SPECIFIED' THEN
            VAR
              num_of_users : integer = 30
              num_of_changes : integer = 2
            VAREND
            TYPE
             CHANGE_ARRAY :  ARRAY 1..num_of_changes of STRING
              USER_VALIDATION : RECORD
                USER : NAME
                PASSWORD : STRING
                CHANGE : CHANGE_ARRAY
              RECEND
            TYPEND
            VAR
              FAMILY_USERS  : ARRAY 1..num_of_users of USER_VALIDATION
              change_status : status
              chau_stat     : status
              create_status : status
              creu_stat     : status
              include_stat  : status
              ignore        : status
              index         : integer
              chng_indx     : integer
              initial_user  : user_validation
              initial_change: change_array
            VAREND
            FOR i = 1 to num_of_changes DO
              initial_change(i) = ' '
            FOREND
            INITIAL_USER = (NOT_SPECIFIED, ' ' , INITIAL_CHANGE)
            FOR i = 1 to num_of_users DO
              family_users(i) = initial_user
            FOREND
            IF family_name = 'TESTING' THEN
              FAMILY_USERS(1).USER=evt01
              FAMILY_USERS(1).PASSWORD='evt01pw'
              FAMILY_USERS(2).USER=evt02
              FAMILY_USERS(2).PASSWORD='evt02pw'
              FAMILY_USERS(3).USER=evt03
              FAMILY_USERS(3).PASSWORD='evt03pw'
              FAMILY_USERS(4).USER=evt04
              FAMILY_USERS(4).PASSWORD='evt04pw'
              FAMILY_USERS(5).USER=evt05
              FAMILY_USERS(5).PASSWORD='evt05pw'
            ELSEIF $substr(family_name, 1, 6) = 'TESTVE' THEN
              FAMILY_USERS(1).USER=ev01
              FAMILY_USERS(1).PASSWORD='ev01pw'
              FAMILY_USERS(2).USER=ev02
              FAMILY_USERS(2).PASSWORD='ev02pw'
              FAMILY_USERS(3).USER=ev03
              FAMILY_USERS(3).PASSWORD='ev03pw'
              FAMILY_USERS(4).USER=ev04
              FAMILY_USERS(4).PASSWORD='ev04pw'
              FAMILY_USERS(5).USER=ev05
              FAMILY_USERS(5).PASSWORD='ev05pw'
            ELSE
              FAMILY_USERS(1).USER=testve
              FAMILY_USERS(1).PASSWORD='testvex'
              FAMILY_USERS(1).CHANGE(1)='change_ring_privilege minimum_ring=6'
              FAMILY_USERS(2).USER=eval1
              FAMILY_USERS(2).PASSWORD='eval1pw'
              FAMILY_USERS(2).CHANGE(1)='change_job_classes add=(maintenance)'
              FAMILY_USERS(3).USER=eval2
              FAMILY_USERS(3).PASSWORD='eval2pw'
              FAMILY_USERS(4).USER=eval3
              FAMILY_USERS(4).PASSWORD='eval3pw'
              FAMILY_USERS(5).USER=ring4
              FAMILY_USERS(5).PASSWORD='ring4pw'
              FAMILY_USERS(5).CHANGE(1)='change_ring_privilege minimum_ring=4'
              FAMILY_USERS(6).USER=ring7
              FAMILY_USERS(6).PASSWORD='ring7pw'
              FAMILY_USERS(6).CHANGE(1)='change_ring_privilege minimum_ring=7'
              FAMILY_USERS(7).USER=ring10
              FAMILY_USERS(7).PASSWORD='ring10pw'
              FAMILY_USERS(7).CHANGE(1)='change_ring_privilege minimum_ring=10'
              FAMILY_USERS(8).USER=testos
              FAMILY_USERS(8).PASSWORD='testosx'
              FAMILY_USERS(8).CHANGE(1)='change_ring_privilege minimum_ring=4'
              FAMILY_USERS(9).USER=user1
              FAMILY_USERS(9).PASSWORD='user1pw'
              FAMILY_USERS(10).USER=user2
              FAMILY_USERS(10).PASSWORD='user2pw'
              FAMILY_USERS(11).USER=user3
              FAMILY_USERS(11).PASSWORD='user3pw'
              FAMILY_USERS(12).USER=user4
              FAMILY_USERS(12).PASSWORD='user4pw'
              FAMILY_USERS(13).USER=user5
              FAMILY_USERS(13).PASSWORD='user5pw'
              FAMILY_USERS(14).USER=ev01
              FAMILY_USERS(14).PASSWORD='ev01pw'
              FAMILY_USERS(15).USER=ev02
              FAMILY_USERS(15).PASSWORD='ev02pw'
              FAMILY_USERS(16).USER=ev03
              FAMILY_USERS(16).PASSWORD='ev03pw'
              FAMILY_USERS(17).USER=ev04
              FAMILY_USERS(17).PASSWORD='ev04pw'
              FAMILY_USERS(18).USER=ev05
              FAMILY_USERS(18).PASSWORD='ev05pw'
              FAMILY_USERS(19).USER=ev06
              FAMILY_USERS(19).PASSWORD='ev06pw'
              FAMILY_USERS(20).USER=ev07
              FAMILY_USERS(20).PASSWORD='ev07pw'
              FAMILY_USERS(21).USER=ev08
              FAMILY_USERS(21).PASSWORD='ev08pw'
              FAMILY_USERS(22).USER=ev09
              FAMILY_USERS(22).PASSWORD='ev09pw'
              FAMILY_USERS(23).USER=ev10
              FAMILY_USERS(23).PASSWORD='ev10pw'
              FAMILY_USERS(24).USER=utest
              FAMILY_USERS(24).PASSWORD='utestpw'
              FAMILY_USERS(24).CHANGE(1)='change_ring_privilege minimum_ring=6'
              FAMILY_USERS(24).CHANGE(2)='change_job_classes add=(maintenance)'
            IFEND
            index = 1
            WHILE (index <= num_of_users) AND (family_users(index).user <> NOT_SPECIFIED) DO
              CREATE: BLOCK
                put_line l=' Creating user: '//family_users(index).user o=$response
                CREATE_USER user=$name(family_users(index).user) status=creu_stat
                  IF NOT creu_stat.normal then
                    create_status=creu_stat
                    EXIT create WHEN NOT create_status.normal
                  IFEND
                  change_login_password new_password=$name(family_users(index).password) status=create_status
                  EXIT create WHEN NOT create_status.normal
                  change_link_attribute_password value=family_users(index).password status=create_status
                  EXIT create WHEN NOT create_status.normal
                END_CREATE_USER wc=true
              BLOCKEND create
              IF NOT create_status.normal THEN
                issue_operator_warning=true
                display_value v=('User creation failed in ADMV subutility CREATE_USER with error: ', create_status) o=$response
              ELSE
                CHANGE: BLOCK
                  put_line l=' Changing user: '//family_users(index).user o=$response
                  CHANGE_USER U=$name(family_users(index).user) status=chau_stat
                    IF NOT chau_stat.normal then
                      change_status=chau_stat
                      EXIT change WHEN NOT change_status.normal
                    IFEND
                    chng_indx = 1
                    WHILE chng_indx <= num_of_changes DO
                      IF (family_users(index).change(chng_indx) <> ' ') THEN
                        include_command c=family_users(index).change(chng_indx) ee=true status=change_status
                        EXIT change WHEN NOT change_status.normal
                        chng_indx = chng_indx + 1
                      ELSE
                        chng_indx = num_of_changes + 1
                      IFEND
                    WHILEND
                  END_CHANGE_USER wc=true
                BLOCKEND change
                IF NOT change_status.normal THEN
                  issue_operator_warning=true
                  display_value v=('User creation failed in ADMV subutility CHANGE_USER with error: ', create_status) o=$response
                IFEND
              IFEND
              index=index + 1
            WHILEND
          ELSE
            attach_file f=&user_validation& wait=yes status=validation_stat
            EXIT WHEN NOT validation_stat.normal
            include_file f=&user_validation& status=validation_stat
            EXIT WHEN NOT validation_stat.normal
            detach_file f=&user_validation& status=validation_stat
          IFEND
        BLOCKEND ADMV_BLOCK
        IF NOT validation_stat.normal THEN
          display_value v=('The following error may not be fatal to development operations,..', ..
             'but must be noted as possibly impacting special case validations: ..', validation_stat) o=$response
          issue_operator_warning=TRUE
        IFEND
      IFEND
    include_line sl='END_ADMINISTER_VALIDATIONS' ee=true status=ignore

    IF issue_operator_warning THEN
      send_operator_message m=' Validation job failed please see printed job logs for errors.' ..
         operator_class=system_operator
    ELSE
      terminate_print name=output
    IFEND
  JOBEND
Procend validate_development_users

*DECK DECK=RAM$VALIDATE_FAMILY_NVE EXPAND=TRUE

*DECK DECK=RAM$VALIDATE_FOR_CORRECTION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$VALIDATE_FOR_CORRECTION Interface.' ??
MODULE ram$validate_for_correction;
{ PURPOSE:
{   This module contains the interface and procedures that validate that
{   corrections can be installed.
{
{ DESIGN:
{
{   Factors influencing the correction process:
{
{   The correction process is driven by several factors, some of which
{   are controlled by the subproduct being corrected, some of which are
{   controlled by the environment the subproduct is being installed into
{   and some of which are controlled by the user.  The factors of primary
{   interest to this interface are:
{
{     Subproduct:
{        a) The installation scheme (cycle_based or version_based).
{           In a version based correction installation scheme, the corrected
{           files are written into a different catalog than the base level
{           of the subproduct.  This means files which did not need to be
{           corrected must be copied to the new version catalog from the base
{           level.  Files/catalogs which are not present in the correction
{           because they don't require correction were marked as inactive
{           in the element list (by GENERATE_CORRECTION) whereas those which
{           will require correction were marked as active.
{           This also influences processing of the correction base files as
{           described below.
{        b) The correction format of each file (object library, source library,
{           or replacement).  An object library correction consists of a patch
{           which when applied against the base(release) version of the file
{           will produce the corrected file.  When the installation scheme
{           is cycle_based, the corrected file would overwrite the correction
{           base so we must save it in a catalog called
{           the correction base catalog for use in installing future
{           corrections.  For version based, the correction base file need not
{           be copied to the correction base catalog because the newly applied
{           correction is installed to a new version catalog.
{     Environment:
{        a) The existance (or not) of previous corrections to this subproduct.
{           When possible, we will not re-correct a file if the correction
{           has already been installed on the system as part of a previous
{           correction installation.  Also, if an object library has been
{           previously corrected, we know the correction base for the file
{           is in the correction bases catalog (for cycle based corrections).
{           If an object library has not been corrected, the correction base
{           will be where the file was originally installed (base level
{           catalog).
{     User:
{        a) How the user selects the subproduct correction to be installed
{           (by name specifically, by licensed product or by group).
{           When the user selects a subproduct by name, every correction
{           to every file in the subproduct will be installed, no
{           previously installed corrections will be used. When referenced
{           by licensed product or group, previously installed corrections
{           will be used if possible to speed up the installation of the
{           new correction.
{
{   By the time this interface is invoked, we know which subproduct's the
{   user wishes to correct.  This interface will consider
{   the above factors in determining how the correction will be installed
{   and in validating that all files which are required for the installation
{   are available.  Information about the processing requirements of each
{   file will be stored in its element record for later use during the actual
{   application of the corrections.
{
{   The significance of these factors is shown in the following "algorithm"
{   which describes the correction process to a file in a subproduct. These
{   show the combined logic of validation for correction and installation of
{   corrections.
{
{   IF <installation scheme is version_based> THEN
{     IF <not installed by subproduct name and correction format is object
{        and correction was installed previously> THEN
{       <move the installed correction to the loading cycle of the new
{        version catalog.>
{       <validate the installed correction to ensure it is not corrupted.>
{       <delete correction from loading cycle.>
{     ELSEIF <element is inactive> THEN
{       <move base level file forward to loading cycle of the new version
{        catalog.>
{     ELSEIF <file format is object library> THEN
{       <correct as for cycle based>
{     ELSE {file format is source library or replacement}
{       <correct as for cycle based>
{     IFEND
{   ELSE {installation scheme is cycle based}
{     IF <not installed by subproduct name and correction was previously
{        installed> THEN
{       <delete the correction from loading cycle>
{       <validate that file is already installed>
{     ELSEIF <file format is object library> THEN
{       <put base (release) version of file in correction bases catalog
{        if not already there>
{       <apply correction placing corrected file in staging cycle>
{       <delete the correction file and shift corrected file back to
{        loading cycle where it is expected by during staging>
{     ELSE {file format is source library or replacement}
{       {no processing needed}
{     IFEND
{   IFEND
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$control_job_identifier
*copyc rae$install_software_cc
*copyc ost$status
*copyc rat$element_paths
*copyc rat$subproduct_info_types
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc ofp$receive_operator_response
*copyc ofp$send_operator_message
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pmp$get_unique_name
*copyc rap$assemble_installation_path
*copyc rap$convert_path_to_pf_format
*copyc rap$convert_path_to_str
*copyc rap$init_processing_seq
*copyc rap$locate_element
*copyc rap$locate_directory_record

?? OLDTITLE, NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

{   To validate the subproducts which are to be corrected, a linked list
{   of subproduct validation lists is created.  All the subproducts in a
{   subproduct validation list have the same subproduct state, ie they
{   have been previously corrected or they have never been corrected.
{   The header node for each list contains the subproduct state plus
{   pointers to the first and last nodes of the subproduct list and to
{   the next subproduct list.  If the subproducts have been previously
{   corrected, then the header also contains the name of the packing list
{   that the subproducts are from.  This packing list is used in
{   determining what file corrections have already been installed for
{   each subproduct.
{
{   Each node of a subproduct list contains the subproduct name,
{   information to access the directory entry for the subproduct, an
{   index to access its subproduct processing record, and for
{   subproduct's which have been previously corrected, an index into the
{   packing list for this subproducts, subproduct list.
{
{   The validation list is kept in a scratch sequence created specifically
{   to contain the list.

  TYPE

    rat#subproduct_state = (rac#never_corrected, rac#previously_corrected),
    rat#validation_list_header = record
      first_subproduct_p: ^rat#subproduct_info_record,
      last_subproduct_p: ^rat#subproduct_info_record,
      next_validation_list_p: ^rat#validation_list_header,
      packing_list_name: ost$name,
      subproduct_state: rat#subproduct_state,
    recend,
    rat#subproduct_info_record = record
      subproduct_name: rat$subproduct_name,
      directory_record_p: ^rat$directory_record,
      processing_records_index: integer,
      next_subproduct_p: ^rat#subproduct_info_record,
      case subproduct_state: rat#subproduct_state of
      = rac#previously_corrected =
        packing_list_index: rat$subproduct_count,
      = rac#never_corrected =
      casend,
    recend;

{   The following record is used during validation of a subproduct.  It keeps
{   all non-changing input information in one parameter.

  TYPE
    rat#validation_info_record = record
      active_subproduct_info_seq_p: ^rat$subproduct_info_sequence,
      active_element_list_p: ^rat$element,
      active_path_index: integer,
      allowed_to_use_previous_corrs: boolean,
      correction_installation_scheme: rat$installation_scheme,
      subproduct_info_seq_p: ^rat$subproduct_info_sequence,
      subproduct_name: rat$subproduct_name,
      subproduct_state: rat#subproduct_state,
    recend;

?? OLDTITLE, NEWTITLE := '[XDCL] rap$validate_for_correction', EJECT ??

{ PURPOSE:
{   This interface validates that all correction base files are present and
{   establishes the correction_directives for the elements of each
{   subproduct to be corrected.
{
{ DESIGN:
{   Create the subproduct validation lists.  This allows processing of
{   subproducts whose active levels are from the same packing list in the
{   most efficient manner by only requiring one access to each packing list.
{   (Subproducts which have never been corrected are also grouped into
{   one subproduct validation list.
{
{   After the validation lists are created, each list is processed to validate
{   that the corrections in each subproduct can in fact be installed.  The
{   validation process updates the element records of each subproduct to
{   direct the correction process during the correct products step.
{
{   Validation errors for one subproduct list or subproduct in a subproduct
{   list will not prevent validation of other subproducts.
{   All validation errors are reported to the job log.
{ NOTES:
{   1.  The validation lists are kept in a scratch memory segment.

  PROCEDURE [XDCL] rap$validate_for_correction
    (    directory_pointers: rat$idb_directory_pointers;
     VAR installation_control_record: rat$installation_control_record;
     VAR status: ost$status);

    VAR
      current_subproduct_header_p: ^rat#validation_list_header,
      errs_processing_validation_list: boolean,
      local_status: ost$status,
      validation_errors: boolean,
      validation_lists_segment_ptr: amt$segment_pointer,
      validation_lists_p: ^rat#validation_list_header,
      validation_lists_seq_p: ^SEQ ( * );


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to return the
{   validation list scratch segment.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF validation_lists_segment_ptr.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (validation_lists_segment_ptr, ignore_status);
        validation_lists_segment_ptr.sequence_pointer := NIL;
      IFEND;

    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    validation_lists_p := NIL;
    validation_lists_segment_ptr.kind := amc$sequence_pointer;
    validation_lists_segment_ptr.sequence_pointer := NIL;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, validation_lists_segment_ptr,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      validation_lists_seq_p := validation_lists_segment_ptr.sequence_pointer;

      get_subproduct_validation_lists (installation_control_record.subproduct_processing_records_p,
            directory_pointers, validation_lists_p, validation_lists_seq_p, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      current_subproduct_header_p := validation_lists_p;
      validation_errors := FALSE;

      WHILE current_subproduct_header_p <> NIL DO
        process_subp_validation_list (current_subproduct_header_p, installation_control_record,
              errs_processing_validation_list, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
        validation_errors := (validation_errors OR errs_processing_validation_list);
        current_subproduct_header_p := current_subproduct_header_p^.next_validation_list_p;
      WHILEND;

    END /main/;

    IF validation_lists_segment_ptr.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (validation_lists_segment_ptr, local_status);
      validation_lists_segment_ptr.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

    IF status.normal AND validation_errors THEN
      osp$set_status_abnormal ('RA', rae$correction_validation_errs, '', status);
    IFEND;

  PROCEND rap$validate_for_correction;

?? OLDTITLE, NEWTITLE := 'add_to_validation_list', EJECT ??

{ PURPOSE:
{   This procedure adds information about a subproduct to a validation list.
{   If no validation list exists for this subproduct, a new validation list
{   is created and added to the list of validation lists.
{
{ DESIGN:
{   Attempt to locate the proper validation list for the subproduct based upon
{   the subproduct state and if appropriate, packing list name.
{   If the needed validation list is found, add this subproduct to it,
{   initializing the fields for the subproduct.
{
{   If the validation list cannot be found, a new one is created
{   and added to the linked list of validation lists.
{ NOTES:


  PROCEDURE add_to_validation_list
    (    subproduct_state: rat#subproduct_state;
         subproduct_name: rat$subproduct_name;
         processing_records_index: integer;
         directory_record_p: ^rat$directory_record;
     VAR validation_lists_p: ^rat#validation_list_header;
     VAR validation_lists_seq_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      current_validation_list_p: ^rat#validation_list_header,
      new_subproduct_validation_rec_p: ^rat#subproduct_info_record;

    status.normal := TRUE;

    IF validation_lists_p = NIL THEN
      { No validation lists have been initialized.  A validation list is initialized by
      { creating an validation list header for the subproduct state/packing list used
      { by this subproduct.

      NEXT current_validation_list_p IN validation_lists_seq_p;
      IF current_validation_list_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'VALIDATION LIST', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'VALIDATION LIST HEADER', status);
        RETURN;
      IFEND;

      validation_lists_p := current_validation_list_p;

      current_validation_list_p^.subproduct_state := subproduct_state;
      IF subproduct_state = rac#previously_corrected THEN
        current_validation_list_p^.packing_list_name := directory_record_p^.active_information.packing_list;
      ELSE
        current_validation_list_p^.packing_list_name := osc$null_name;
      IFEND;
      current_validation_list_p^.first_subproduct_p := NIL;
      current_validation_list_p^.last_subproduct_p := NIL;
      current_validation_list_p^.next_validation_list_p := NIL;

    ELSE {there is at least one existing validation list}
      { Locate the validation list for the desired subproduct state/packing list.
      { Note that the search will stop with current_validation_list_p pointing
      { to the last validation list.

      current_validation_list_p := validation_lists_p;
      IF subproduct_state = rac#never_corrected THEN
        WHILE (current_validation_list_p^.subproduct_state <> rac#never_corrected) AND
              (current_validation_list_p^.next_validation_list_p <> NIL) DO
          current_validation_list_p := current_validation_list_p^.next_validation_list_p;
        WHILEND;
      ELSE { Search based upon packing list.}
        WHILE (current_validation_list_p^.packing_list_name <>
              directory_record_p^.active_information.packing_list) AND
              (current_validation_list_p^.next_validation_list_p <> NIL) DO
          current_validation_list_p := current_validation_list_p^.next_validation_list_p;
        WHILEND;
      IFEND;

      IF ((subproduct_state = rac#never_corrected) AND (current_validation_list_p^.subproduct_state <>
            subproduct_state)) OR ((subproduct_state = rac#previously_corrected) AND
            (current_validation_list_p^.packing_list_name <> directory_record_p^.active_information.
            packing_list)) THEN
        { We did run to the end of the list without finding the correct validation
        { list.  A new validation list is initialized and linked to
        { the last validation list.

        NEXT current_validation_list_p^.next_validation_list_p IN validation_lists_seq_p;
        IF current_validation_list_p = NIL THEN
          osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'VALIDATION LIST', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'VALIDATION LIST HEADER', status);
          RETURN;
        IFEND;

        current_validation_list_p := current_validation_list_p^.next_validation_list_p;

        current_validation_list_p^.subproduct_state := subproduct_state;
        IF subproduct_state = rac#previously_corrected THEN
          current_validation_list_p^.packing_list_name := directory_record_p^.active_information.packing_list;
        ELSE
          current_validation_list_p^.packing_list_name := osc$null_name;
        IFEND;
        current_validation_list_p^.first_subproduct_p := NIL;
        current_validation_list_p^.last_subproduct_p := NIL;
        current_validation_list_p^.next_validation_list_p := NIL;

      IFEND;
    IFEND;

    { Add the subproduct name to end of the current activation list.

    NEXT new_subproduct_validation_rec_p IN validation_lists_seq_p;
    IF new_subproduct_validation_rec_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'VALIDATION LIST', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'SUBPRODUCT VALIDATION RECORD', status);
      RETURN;
    IFEND;

    IF current_validation_list_p^.first_subproduct_p = NIL THEN
      { This is the first name recorded.
      current_validation_list_p^.first_subproduct_p := new_subproduct_validation_rec_p;
    ELSE
      current_validation_list_p^.last_subproduct_p^.next_subproduct_p := new_subproduct_validation_rec_p;
    IFEND;

    current_validation_list_p^.last_subproduct_p := new_subproduct_validation_rec_p;
    current_validation_list_p^.last_subproduct_p^.subproduct_name := subproduct_name;
    current_validation_list_p^.last_subproduct_p^.directory_record_p := directory_record_p;
    current_validation_list_p^.last_subproduct_p^.processing_records_index := processing_records_index;
    current_validation_list_p^.last_subproduct_p^.subproduct_state := subproduct_state;
    IF subproduct_state = rac#previously_corrected THEN
      current_validation_list_p^.last_subproduct_p^.packing_list_index :=
            directory_record_p^.active_information.packing_list_index;
    IFEND;
    current_validation_list_p^.last_subproduct_p^.next_subproduct_p := NIL;

  PROCEND add_to_validation_list;

?? OLDTITLE, NEWTITLE := 'check_previous_correction', EJECT ??

{ PURPOSE:
{   This procedure checks a previous correction to determine if it can be
{   used to avoid installing the current correction.  If the checksum's
{   match, and we want to use it, then we ensure the file exists.
{
{ DESIGN:
{   If the checksum's in the element lists match, then the previous
{   correction can be used.  It is only used however, if the installation
{   scheme is cycle based, or for a version based installation scheme, if
{   the correction is to an object library.  The reason for
{   selectivity in version based corrections is that it would take more
{   processing to use a previous correction to a source library or
{   replacement file than to use the correction which was loaded into the
{   loading cycle.
{
{   If based on the above, we want to use the previous correction, we make
{   sure the file is present and issue an error message if it's not.
{
{   If we use the previous correction and the installation scheme is
{   cycle based, then the element is made inactive since no further
{   processing is needed.
{ NOTES:


  PROCEDURE check_previous_correction
    (    element_paths: rat$element_paths;
         validation_info_record: rat#validation_info_record;
         previous_correction_element_p: ^rat$element;
         element_p {input, output} : ^rat$element;
     VAR previous_correction_usable: boolean;
     VAR status: ost$status);

    VAR
      display_status: ost$status,
      ignore_status: ost$status,
      previous_correction_file_exists: boolean;

    status.normal := TRUE;
    previous_correction_usable := FALSE;

    IF (previous_correction_element_p^.pre_genc_contents_checksum = element_p^.pre_genc_contents_checksum)
          THEN
      IF (validation_info_record.correction_installation_scheme = rac$cycle_based) THEN

        { We know file already exists since we checked the base file in VALIDATE_FILE.
        element_p^.active_element := FALSE;
        previous_correction_usable := TRUE;

      ELSE {version based}

        IF (element_p^.correction_format = rac$object_library) THEN
          verify_file_exists (element_paths [rac$active_level_path], previous_correction_file_exists, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF previous_correction_file_exists THEN
            previous_correction_usable := TRUE;
          ELSE
            log_missing_file_message (rae$prev_version_corr_missing, element_paths [rac$active_level_path],
                  element_paths [rac$installation_catalog_path], validation_info_record.subproduct_name,
                  ignore_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF previous_correction_usable THEN
       element_p^.correction_directives := $rat$correction_directives [rac$use_previous_correction];
    IFEND;

  PROCEND check_previous_correction;
?? OLDTITLE, NEWTITLE := 'establish_subproduct_paths', EJECT ??

{ PURPOSE:
{   This procedure establishes various paths needed for installing the
{   subproduct.
{
{ DESIGN:
{   Use the directory record plus the active subproduct pointers (if
{   available) to determine the paths.  The path's and relative pointer's
{   to them are stored in the processing sequence.  An array of absolute
{   pointers for the paths is returned to the caller.
{ NOTES:
{   If the ACTIVE_SUBPRODUCT_INFO_PTRS.ATTRIBUTES_P is NIL, then
{   there is no active level of the subproduct.

  PROCEDURE establish_subproduct_paths
    (    directory_record_p: ^rat$directory_record;
         active_subproduct_info_ptrs: rat$subproduct_info_pointers;
         default_correction_base_catalog: rat$path;
     VAR subproduct_processing_record: rat$subp_processing_record;
     VAR subproduct_paths: rat$element_paths;
     VAR processing_sequence_p: ^rat$processing_sequence;
     VAR status: ost$status);


    VAR
      correction_base_catalog: rat$path,
      temp_system_catalog: rat$path;

    status.normal := TRUE;

    subproduct_paths [rac$installation_catalog_path] := subproduct_processing_record.installation_catalog_p;

    { Assemble path for the correction bases catalog for the subproduct.

    STRINGREP (correction_base_catalog.path, correction_base_catalog.size,
          default_correction_base_catalog.path (1, default_correction_base_catalog.size), '.',
          directory_record_p^.subproduct (1, clp$trimmed_string_size (directory_record_p^.subproduct)),
          '.', directory_record_p^.corrective_base_information.
          subproduct_level (1, clp$trimmed_string_size (directory_record_p^.corrective_base_information.
          subproduct_level)));
    rap$convert_path_to_pf_format (correction_base_catalog, subproduct_paths [rac$correction_base_cat_path],
          processing_sequence_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    subproduct_processing_record.correction_base_catalog_rel_p :=
          #REL (subproduct_paths [rac$correction_base_cat_path], processing_sequence_p^);

    { Get path for the base level of the subproduct.

    rap$convert_path_to_pf_format (directory_record_p^.base_level_installation_catalog,
          subproduct_paths [rac$base_level_path], processing_sequence_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    subproduct_processing_record.base_level_catalog_rel_p :=
          #REL (subproduct_paths [rac$base_level_path], processing_sequence_p^);

    { Get path for the active level of the subproduct.  This only occurs if
    { the active level is different than the base level.

    IF active_subproduct_info_ptrs.attributes_p <> NIL THEN
      temp_system_catalog := directory_record_p^.base_level_installation_catalog;
      temp_system_catalog.size := directory_record_p^.system_catalog_path_index;
      rap$assemble_installation_path (temp_system_catalog, active_subproduct_info_ptrs, rac$installation_path,
            subproduct_paths [rac$active_level_path], processing_sequence_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      subproduct_processing_record.active_level_catalog_rel_p :=
            #REL (subproduct_paths [rac$active_level_path], processing_sequence_p^);
    ELSE
      subproduct_processing_record.active_level_catalog_rel_p := NIL;
      subproduct_paths [rac$active_level_path] := NIL;
    IFEND;

  PROCEND establish_subproduct_paths;

?? OLDTITLE, NEWTITLE := 'get_subproduct_validation_lists', EJECT ??

{ PURPOSE:
{   This procedure builds the correction validation lists.
{
{ DESIGN:
{   Go through the subproduct processing records in the installation control
{   record and process each subproduct that has been selected.
{
{   Locate the subproduct's entry in the IDB directory.
{   1.  If the directory indicates that the active and base levels are
{       different, then a previous correction has been installed for this
{       subproduct.  Add this subproduct to the validation list for the
{       packing list of the active level.
{   2.  If the directory indicates that the active level is the same as the
{       base level for the subproduct, then no correction has ever been
{       applied to this subproduct.  This means that every correction in
{       this subproduct must be installed.  Add this subproduct to the
{       validation list for subproducts which have never been corrected.
{ NOTES:
{   If a subproduct has selected, but its correction_base_sif_identifier
{   is null, then the correction was created with DEFINE_SUBPRODUCT
{   and therefore only performs file replacement.  In this case,
{   no validation is necessary, and we will remove the correct_files_task
{   from the subproduct's task list.

  PROCEDURE get_subproduct_validation_lists
    (    subproduct_processing_records_p: ^rat$subp_processing_records;
         directory_pointers: rat$idb_directory_pointers;
     VAR validation_lists_p: ^rat#validation_list_header;
     VAR validation_lists_seq_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      directory_record_p: ^rat$directory_record,
      subproduct_index: rat$subproduct_count,
      subproduct_state: rat#subproduct_state;

    status.normal := TRUE;

    FOR subproduct_index := 1 TO UPPERBOUND (subproduct_processing_records_p^) DO

      IF (rac$correct_files_task IN subproduct_processing_records_p^ [subproduct_index].task_set) THEN

        IF (subproduct_processing_records_p^ [subproduct_index].subproduct_info_pointers.attributes_p^.
              correction_base_sif_identifier = osc$null_name) THEN
          subproduct_processing_records_p^ [subproduct_index].task_set :=
                subproduct_processing_records_p^ [subproduct_index].task_set -
                $rat$task_selections [rac$correct_files_task];

        ELSE

          rap$locate_directory_record (subproduct_processing_records_p^ [subproduct_index].
                subproduct_info_pointers.attributes_p^.name, subproduct_processing_records_p^ [
                subproduct_index].subproduct_info_pointers.attributes_p^.licensed_product, directory_pointers,
                directory_record_p);
          IF directory_record_p^.active_information.sif_identifier =
                directory_record_p^.corrective_base_information.sif_identifier THEN
            subproduct_state := rac#never_corrected;
          ELSE
            subproduct_state := rac#previously_corrected;
          IFEND;

          add_to_validation_list (subproduct_state, subproduct_processing_records_p^ [subproduct_index].
                subproduct_info_pointers.attributes_p^.name, subproduct_index, directory_record_p,
                validation_lists_p, validation_lists_seq_p, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND

        IFEND;

      IFEND;

    FOREND;

  PROCEND get_subproduct_validation_lists;

?? OLDTITLE, NEWTITLE := 'init_validation_info_record', EJECT ??

{ PURPOSE:
{   This interface initializes the record of information needed to drive
{   the validation of a subproduct.
{
{ DESIGN:
{
{ NOTES:
{   If the ACTIVE_SUBPRODUCT_INFO_PTRS.ATTRIBUTES_P is NIL, then
{   there is no active level of the subproduct.
{
{   When calculating the active_path_index (how many catalog elements
{   to skip over during locate_element), we must add 1 to the
{   the number of elements in the active level catalog in order to
{   begin the search in the active level catalog, rather than at
{   the same level as the active level catalog.
{
{   If a subproduct was selected by the user by subproduct name
{   or the licensed product name and subproduct name match,
{   then we will not use previous corrections when correcting
{   the subproduct.  The need to check LP=SP is done
{   because validate_for_installation indicates the product
{   reference is licensed product, not subproduct like it
{   probably should.

  PROCEDURE init_validation_info_record
    (    active_subproduct_info_ptrs: rat$subproduct_info_pointers;
         active_level_path_p: ^pft$path;
         subproduct_processing_record: rat$subp_processing_record;
         subproduct_state: rat#subproduct_state;
     VAR validation_info_record: rat#validation_info_record);

    IF active_subproduct_info_ptrs.attributes_p <> NIL THEN
      validation_info_record.active_subproduct_info_seq_p :=
            active_subproduct_info_ptrs.subproduct_info_seq_p;
      validation_info_record.active_element_list_p := active_subproduct_info_ptrs.element_list_p;
      validation_info_record.active_path_index := UPPERBOUND (active_level_path_p^) + 1;
      IF ((subproduct_processing_record.product_reference = rac$subproduct) OR
         ((subproduct_processing_record.product_reference = rac$licensed_product) AND
         (subproduct_processing_record.subproduct_info_pointers.attributes_p^.licensed_product =
         subproduct_processing_record.subproduct_info_pointers.attributes_p^.name)) ) THEN
        validation_info_record.allowed_to_use_previous_corrs := FALSE;
      ELSE
        validation_info_record.allowed_to_use_previous_corrs := TRUE;
      IFEND;
    ELSE
      validation_info_record.active_subproduct_info_seq_p := NIL;
      validation_info_record.active_element_list_p := NIL;
      validation_info_record.active_path_index := 0;
      validation_info_record.allowed_to_use_previous_corrs := FALSE;
    IFEND;

    validation_info_record.correction_installation_scheme :=
          subproduct_processing_record.subproduct_info_pointers.attributes_p^.installation_scheme;
    validation_info_record.subproduct_info_seq_p := subproduct_processing_record.subproduct_info_pointers.
          subproduct_info_seq_p;
    validation_info_record.subproduct_name := subproduct_processing_record.subproduct_info_pointers.
          attributes_p^.name;
    validation_info_record.subproduct_state := subproduct_state;

  PROCEND init_validation_info_record;

?? OLDTITLE, NEWTITLE := 'locate_correction_base', EJECT ??

{ PURPOSE:
{   This interface locates the correction base for a correction,
{   verifies that the file exists and updates the correction_directives for
{   the file accordingly.
{
{ DESIGN:
{   Use the input parameters to determine where the correction base file
{   should be located and update the correction directives for the file
{   accordingly.  If the file does not exist, display a status message to
{   the job log and return indicating that validation errors occurred.
{
{   Correction bases are located as follows:
{   1. For a version based subproduct, in the base version catalog.
{   2. For cycle based subproduct:
{      a. If the file has been previously corrected, in the correction
{         bases catalog.
{      b. If the file has never been corrected, in the base level catalog.
{      c. If the subproduct has been corrected, but we couldn't get the
{         previous correction info (because of problems accessing the
{         packing list in PROCESS_SUBP_VALIDATION_LIST), then we will use
{         a file in the correction bases catalog as the base if its
{         there, otherwise we will use the file in the base level
{         catalog.
{
  PROCEDURE locate_correction_base
    (    element_paths: rat$element_paths;
         validation_info_record: rat#validation_info_record;
         file_previously_corrected: boolean;
         element_p {input, output} : ^rat$element;
     VAR validation_error: boolean;
     VAR status: ost$status);

    VAR
      file_exists: boolean,
      ignore_status: ost$status;

    status.normal := TRUE;
    validation_error := FALSE;

    IF validation_info_record.correction_installation_scheme = rac$version_based THEN

      { We know file already exists.  This was checked in VALIDATE_FILE.
      element_p^.correction_directives := $rat$correction_directives [rac$use_base_level_catalog];

    ELSE {cycle based correction}

      IF file_previously_corrected THEN

        verify_file_exists (element_paths [rac$correction_base_cat_path], file_exists, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF file_exists THEN
          element_p^.correction_directives := $rat$correction_directives [rac$use_correction_base_catalog];
        ELSE
          log_missing_file_message (rae$corr_base_cat_file_missing,
                element_paths [rac$correction_base_cat_path], element_paths [rac$installation_catalog_path],
                validation_info_record.subproduct_name, ignore_status);
          validation_error := TRUE;
          RETURN;
        IFEND;

      ELSEIF (validation_info_record.subproduct_state = rac#never_corrected) OR
            ((validation_info_record.subproduct_state = rac#previously_corrected) AND
            (validation_info_record.active_subproduct_info_seq_p <> NIL)) THEN

        { We know file already exists.  This was checked in VALIDATE_FILE.
        element_p^.correction_directives := $rat$correction_directives [rac$use_base_level_catalog];

      ELSE {Subproduct previously corrected but active level subproduct info not available.}

        { See if a file exists in correction bases catalog.
        verify_file_exists (element_paths [rac$correction_base_cat_path], file_exists, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF file_exists THEN
          element_p^.correction_directives := $rat$correction_directives [rac$use_correction_base_catalog];
        ELSE
          element_p^.correction_directives := $rat$correction_directives [rac$use_base_level_catalog];
        IFEND;

      IFEND;

    IFEND;

  PROCEND locate_correction_base;

?? OLDTITLE, NEWTITLE := 'log_missing_file_message', EJECT ??

{ PURPOSE:
{   This procedure displays the specified status message for
{   a missing file to the $job_log.
{
{ DESIGN:
{   Convert the PFT$PATH's to strings and log the status message.
{
{ NOTES:

  PROCEDURE log_missing_file_message
    (    display_status: ost$status_condition_code;
         first_pf_path_p: ^pft$path;
         second_pf_path_p: ^pft$path;
         subproduct_name: rat$subproduct_name;
     VAR status: ost$status);

    VAR
      file_string: rat$path,
      working_status: ost$status;

    status.normal := TRUE;

    osp$set_status_abnormal ('RA', display_status, '', working_status);

    IF first_pf_path_p <> NIL THEN
      rap$convert_path_to_str (first_pf_path_p^, file_string);
      osp$append_status_file (osc$status_parameter_delimiter, file_string.path (1, file_string.size),
            working_status);
    IFEND;

    IF second_pf_path_p <> NIL THEN
      rap$convert_path_to_str (second_pf_path_p^, file_string);
      osp$append_status_file (osc$status_parameter_delimiter, file_string.path (1, file_string.size),
            working_status);
    IFEND;

    osp$append_status_parameter (osc$status_parameter_delimiter, subproduct_name, working_status);
    osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], working_status, status);

  PROCEND log_missing_file_message;

?? OLDTITLE, NEWTITLE := 'process_subp_validation_list', EJECT ??

{ PURPOSE:
{   This procedure processes the subproducts in a subproduct validation list.
{
{ DESIGN:
{   Use information in the validation list header record to determine if
{   a packing list is needed to process the subproducts.  If so, use an
{   installation control record (named previous_corr_packing_list_rec)
{   and associated sequence to access information about the previously
{   corrected subproducts.  If there is an error during initialization of
{   the sequence, we will not be able to use previous correction
{   information in processing the subproducts.  Log this fact and proceed
{   with validating each subproduct in the subproduct validation list.
{
{   Note: If a subproduct is being recorrected, the active level may in
{   in fact be the same as the level being installed.  In that case,
{   we will not open the packing list but use the current
{   packing list for previous correction information.
{
{   For each member of the list, establish the subproduct paths which will be
{   needed during installation and store them in the processing sequence for
{   the current installation.  (NOT the processing sequence for previously
{   corrected subproducts.)  Initialize a record to contain all information
{   necessary to validate the subproduct and call a procedure to traverse the
{   element list for the subproduct, validating each element and its
{   correction processing requirements.
{
{   During the initialization of the validation record, it is determined
{   if the previous corrections can be used to speed up the application
{   of the correction.  The corrections cannot be used if the user
{   specified the subproduct by name on the INSTALL_CORRECTION command.
{
{ NOTES:
{   It is possible, although very unlikely, that a packing list used for
{   installing the active level of a subproduct gets reloaded at the site.
{   Since we do not have a unique 'packing_list_id' like we have a unique
{   subproduct identifier, we cannot determine this fact upon accessing
{   the packing list.  It can only be determined while the subproducts
{   with the validation list for that packing list are being processed.
{   An even more unlikely case is that some of the needed subproducts
{   are in the packing list, and that others are not.  This code handles
{   either case, using the information in the packing list if its there.
{   In the future, a packing_list_unique_id should be added to each packing
{   list and to the idb directory.

  PROCEDURE process_subp_validation_list
    (    validation_list_header_p: ^rat#validation_list_header;
     VAR installation_control_record: rat$installation_control_record;
     VAR validation_errors: boolean;
     VAR status: ost$status);

    CONST
      ignore_cmd_compatible_type = rac$correction,
      ignore_installation_command = rac$install_correction,
      ignore_save_previous_cycles = FALSE;

    VAR
      current_subproduct_p: ^rat#subproduct_info_record,
      ignore_status: ost$status,
      local_status: ost$status,
      operator_message: string (256),
      operator_message_length : integer,
      packing_list_fid: amt$file_identifier,
      packing_list_open: boolean,
      previous_corr_info_available: boolean,
      previous_corr_packing_list_rec: rat$installation_control_record,
      previous_corr_segment_pointer: amt$segment_pointer,
      previous_corr_subp_info_ptrs: rat$subproduct_info_pointers,
      response_from_operator: ost$string,
      subproduct_paths: rat$element_paths,
      subproduct_validation_errors: boolean,
      validation_info_record: rat#validation_info_record;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to close the packing list
{   and return the previous correction processing sequence.

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF packing_list_open THEN
        fsp$close_file (packing_list_fid, ignore_status);
        packing_list_open := FALSE;
      IFEND;

      IF previous_corr_segment_pointer.sequence_pointer <> NIL THEN
        mmp$delete_scratch_segment (previous_corr_segment_pointer, ignore_status);
        previous_corr_segment_pointer.sequence_pointer := NIL;
      IFEND;
    PROCEND abort_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    validation_errors := FALSE;
    packing_list_open := FALSE;

    previous_corr_packing_list_rec.job_identifier := rac$control_job_identifier;
    previous_corr_segment_pointer.kind := amc$sequence_pointer;
    previous_corr_segment_pointer.sequence_pointer := NIL;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      previous_corr_info_available := FALSE;
      IF validation_list_header_p^.subproduct_state = rac#previously_corrected THEN
        IF validation_list_header_p^.packing_list_name = installation_control_record.processing_header_p^.
                packing_list_name THEN
           { The subproducts are referencing the current packing list, copy current ICR for validation.
           previous_corr_packing_list_rec := installation_control_record;
           previous_corr_info_available := TRUE;
        ELSE {Must access other packing list.}
          rap$init_processing_seq (validation_list_header_p^.packing_list_name, ignore_save_previous_cycles,
                ignore_installation_command, ignore_cmd_compatible_type,
                installation_control_record.processing_header_p^.installation_defaults,
                previous_corr_packing_list_rec, previous_corr_segment_pointer, packing_list_fid,
                packing_list_open, local_status);
          IF local_status.normal THEN
            previous_corr_info_available := TRUE;
          ELSE
            osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
            osp$set_status_abnormal ('RA', rae$previous_corr_packlist_gone, '', local_status);
            osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
            local_status.normal := TRUE;
            previous_corr_info_available := FALSE;
          IFEND;
        IFEND;
      IFEND;

      current_subproduct_p := validation_list_header_p^.first_subproduct_p;
      WHILE current_subproduct_p <> NIL DO

        IF previous_corr_info_available THEN
          { Validate that the sif id of the active subproduct matches the
          { sif id for the subproduct pointed to in the packing list.
          IF (current_subproduct_p^.packing_list_index <= UPPERBOUND (previous_corr_packing_list_rec.
                subproduct_processing_records_p^)) AND (current_subproduct_p^.directory_record_p^.
                active_information.sif_identifier = previous_corr_packing_list_rec.
                subproduct_processing_records_p^ [current_subproduct_p^.packing_list_index].
                subproduct_info_pointers.attributes_p^.sif_identifier) THEN
            previous_corr_subp_info_ptrs := previous_corr_packing_list_rec.
                  subproduct_processing_records_p^ [current_subproduct_p^.packing_list_index].
                  subproduct_info_pointers;
          ELSE {Original packing list replaced, can't this subproduct's previous corrections.}
            osp$set_status_abnormal ('RA', rae$previous_corr_packlist_bad,
                  validation_list_header_p^.packing_list_name, local_status);
            osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);
            local_status.normal := TRUE;
            previous_corr_subp_info_ptrs.attributes_p := NIL;     {No previous correction info available.}
          IFEND;
        ELSE
          previous_corr_subp_info_ptrs.attributes_p := NIL;       {No previous corrections info available.}
        IFEND;

        establish_subproduct_paths (current_subproduct_p^.directory_record_p, previous_corr_subp_info_ptrs,
              installation_control_record.processing_header_p^.installation_defaults.correction_bases,
              installation_control_record.subproduct_processing_records_p^
              [current_subproduct_p^.processing_records_index], subproduct_paths,
              installation_control_record.processing_seq_p, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        init_validation_info_record (previous_corr_subp_info_ptrs, subproduct_paths [rac$active_level_path],
              installation_control_record.subproduct_processing_records_p^
              [current_subproduct_p^.processing_records_index],
              validation_list_header_p^.subproduct_state, validation_info_record);

        validate_subproduct (subproduct_paths, validation_info_record,
              installation_control_record.subproduct_processing_records_p^
              [current_subproduct_p^.processing_records_index].subproduct_info_pointers.element_list_p,
              installation_control_record.subproduct_processing_records_p^
              [current_subproduct_p^.processing_records_index].task_set,
              subproduct_validation_errors, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        IF (installation_control_record.subproduct_processing_records_p^
              [current_subproduct_p^.processing_records_index].task_set = $rat$task_selections []) THEN
          stringrep(operator_message, operator_message_length, 'The correction to subproduct ',
                validation_info_record.subproduct_name(1, clp$trimmed_string_size(validation_info_record.
                subproduct_name)),
                ' will not be installed due to missing file(s).  See file ',
                installation_control_record.processing_header_p^.installation_defaults.
                installation_logs.path(1,installation_control_record.processing_header_p^.
                installation_defaults.installation_logs.size),
                '.{installation_identifier}.command_log for details');
          ofp$send_operator_message(operator_message (1, operator_message_length), ofc$system_operator,
                {acknowledgement_allowed =} TRUE, ignore_status);
          ofp$receive_operator_response (ofc$system_operator, osc$wait,
                response_from_operator, ignore_status);
        IFEND;
        current_subproduct_p := current_subproduct_p^.next_subproduct_p;
        validation_errors := (validation_errors OR subproduct_validation_errors);
      WHILEND;

    END /main/;

    IF packing_list_open THEN
      fsp$close_file (packing_list_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF previous_corr_segment_pointer.sequence_pointer <> NIL THEN
      mmp$delete_scratch_segment (previous_corr_segment_pointer, local_status);
      previous_corr_segment_pointer.sequence_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND process_subp_validation_list;
?? OLDTITLE, NEWTITLE := 'validate_file', EJECT ??

{ PURPOSE:
{   This interface processes an element to prepare its correction_directives.
{   This processing includes determination if a previous correction can be
{   used and if it can't be used, where the correction base (if its needed)
{   for applying the correction is located.
{
{ DESIGN:
{   We first determine if the base level file for this element is present.
{   If the file is not present then we will not correct the subproduct since
{   it has been corrupted or atleast partially deleted from the system.
{
{   If element is inactive, then this is a subproduct is using a version based
{   installation scheme for the corrections.  All that is needed is to
{   make the element active and set the correction directives for the element
{   so that the release file will be copied forward into the version catalog
{   for this level of the subproduct.
{
{   If the element is active, determine if the base level file has been
{   previously corrected.  This is done by trying to locate the element
{   in the SIF (packing list) for the active level of the subproduct if
{   active level information is available).  If we do locate an element,
{   it can only be used as a previous correction if it was active --
{   inactive elements represent a file in a version based correction
{   which was not corrected.  If we locate an active element, and we want
{   to use it corrected and we want to use it, then the element list will
{   be updated appropriately for the type of installation scheme being
{   used.
{
{   If there was no previous correction, or we can't use it, then the file
{   must be corrected.  If this is an object library, we must locate the
{   correction base for the file and record this information in the correction
{   directives.  If this is not an object library, a correction base is not
{   needed, and the correction directives are updated to indicate that
{   processing is limited to replacing the file only.
{
{ NOTES:


  PROCEDURE validate_file
    (    element_paths: rat$element_paths;
         validation_info_record: rat#validation_info_record;
         element_p {input, output} : ^rat$element;
     VAR task_set: rat$task_selections;
     VAR validation_error: boolean;
     VAR status: ost$status);

    VAR
      base_file_exists: boolean,
      element_located: boolean,
      file_previously_corrected: boolean,
      ignore_status: ost$status,
      local_subproduct_info_seq_ptr: ^rat$subproduct_info_sequence,
      previous_correction_element_p: ^rat$element,
      previous_correction_usable: boolean;


    status.normal := TRUE;

    validation_error := FALSE;
    base_file_exists := FALSE;

    { Ensure the file exists where the original release subproduct was installed

    verify_file_exists (element_paths [rac$base_level_path], base_file_exists, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF NOT base_file_exists THEN
      log_missing_file_message (rae$base_file_missing, element_paths [rac$base_level_path], NIL
            {No second file path} , validation_info_record.subproduct_name, ignore_status);
      task_set := $rat$task_selections [];
      RETURN;
    IFEND;

    IF element_p^.active_element THEN      {The element has a correction.}

      { Attempt to locate a previous correction to the file in the packing list for the
      { active level.  This is done even if the previous correction cannot
      { be used because the existance of a previous correction also determines
      { where the correction base is located.

      file_previously_corrected := FALSE;
      IF validation_info_record.active_subproduct_info_seq_p <> NIL THEN
        previous_correction_element_p := validation_info_record.active_element_list_p;
        local_subproduct_info_seq_ptr := validation_info_record.active_subproduct_info_seq_p;
        rap$locate_element (element_paths [rac$active_level_path], validation_info_record.active_path_index,
              local_subproduct_info_seq_ptr, previous_correction_element_p, element_located);
        IF (element_located) and (previous_correction_element_p^.active_element) THEN
          file_previously_corrected := TRUE;
        ELSE
          previous_correction_element_p := NIL;
        IFEND;
      IFEND;

     { Process the previous correction if we have one and are allowed to use it.

      previous_correction_usable := FALSE;
      IF (validation_info_record.allowed_to_use_previous_corrs) AND (file_previously_corrected) THEN
        check_previous_correction (element_paths, validation_info_record, previous_correction_element_p,
              element_p, previous_correction_usable, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      { Process elements for which we don't have or want to use a previous correction.

      IF NOT (file_previously_corrected AND previous_correction_usable) THEN
        IF element_p^.correction_format = rac$object_library THEN
          locate_correction_base (element_paths, validation_info_record, file_previously_corrected, element_p,
                validation_error, status);
          IF (NOT status.normal) OR validation_error THEN
            RETURN;
          IFEND;
        ELSE
          element_p^.correction_directives := $rat$correction_directives [rac$use_replacement_file];
        IFEND;
      IFEND;
    ELSE {The element has no correction and is in a version based correction.}
      element_p^.active_element := TRUE;
      element_p^.correction_directives := $rat$correction_directives [rac$use_release_file];
    IFEND;

  PROCEND validate_file;

?? OLDTITLE, NEWTITLE := 'validate_subproduct', EJECT ??

{ PURPOSE:
{   This interface processes the elements of a subproduct to set the proper
{   processing attributes for each element of the subproduct.
{
{ DESIGN:
{   Loop through the element list using the standard element list traversal
{   algorithm.
{
{   This procedure processes all the elements at one catalog level, calling
{   itself recursively if the catalog contains a subcatalog.
{
{   In order to ensure that all catalog's are created for version based
{   corrections, all catalog element's are set active.
{
{ NOTES:
{   This code assumes that if an element is inactive, that the
{   installation scheme is version based.
{
{   In a cycle based correction, it is possible that all files in a
{   catalog have been previously corrected.  In this case, the catalog
{   element should be made inactive.  Since it only wastes a small amount
{   of time to "stage/activate" a catalog, no attempt is made in this
{   code to set catalog elements inactive.

  PROCEDURE validate_subproduct
    (    element_paths: rat$element_paths;
         validation_info_record: rat#validation_info_record;
         element_p {output} : ^rat$element;
     VAR task_set: rat$task_selections;
     VAR validation_errors: boolean;
     VAR status: ost$status);

    VAR
      previous_correction_element_p: ^rat$element,
      current_element_p: ^rat$element,
      current_element_paths: rat$element_paths,
      element_validation_error: boolean,
      first_element_down_p: ^rat$element,
      i: integer,
      path_index: rat$installation_paths;

    status.normal := TRUE;
    previous_correction_element_p := NIL;

    { Create a new array of PF paths which contains path's one larger than
    { each of the path arrays in ELEMENT_PATHS and initialize each path.
    { This array will be used to construct the PF
    { paths for the files and subcatalogs that reside in the current catalog.

    FOR path_index := LOWERBOUND (element_paths) TO UPPERBOUND (element_paths) DO
      IF element_paths [path_index] <> NIL THEN
        PUSH current_element_paths [path_index]: [1 .. UPPERBOUND (element_paths [path_index]^) + 1];
        FOR i := 1 TO UPPERBOUND (element_paths [path_index]^) DO
          current_element_paths [path_index]^ [i] := element_paths [path_index]^ [i];
        FOREND;
      ELSE
        current_element_paths [path_index] := NIL;
      IFEND;
    FOREND;

    { Process the files and subcatalogs at the current catalog level.

    current_element_p := element_p;
    validation_errors := FALSE;

    WHILE current_element_p <> NIL DO

      { Add current file name to end of each path.

      FOR path_index := LOWERBOUND (current_element_paths) TO UPPERBOUND (current_element_paths) DO
        IF current_element_paths [path_index] <> NIL THEN
          current_element_paths [path_index]^ [UPPERBOUND (current_element_paths [path_index]^)] :=
                current_element_p^.name;
        IFEND;
      FOREND;

      IF current_element_p^.element_type = rac$file THEN

        validate_file (current_element_paths, validation_info_record, current_element_p,
              task_set, element_validation_error, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSE {current_element_p^.element_type = rac$catalog}

        IF current_element_p^.element_count <> 0 THEN
          first_element_down_p := #PTR (current_element_p^.first_element_down_p,
                validation_info_record.subproduct_info_seq_p^);
          validate_subproduct (current_element_paths, validation_info_record, first_element_down_p,
                task_set, element_validation_error, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        { Turn on inactive catalogs.

        IF (NOT current_element_p^.active_element) THEN
          current_element_p^.active_element := TRUE;
        IFEND;

      IFEND;

      validation_errors := (validation_errors OR element_validation_error);
      current_element_p := #PTR (current_element_p^.next_element_across_p,
            validation_info_record.subproduct_info_seq_p^);
    WHILEND;

  PROCEND validate_subproduct;

?? OLDTITLE, NEWTITLE := 'verify_file_exists', EJECT ??

{ PURPOSE:
{   This procedure verifies that a file exists, returning a boolean
{   flag with the answer.
{
{ DESIGN:
{   Convert PFT$PATH pointer to a string and use get_file_attributes to
{   determine if the file exists.
{ NOTES:

  PROCEDURE verify_file_exists
    (    pft_file_p: ^pft$path;
     VAR file_exists: boolean;
     VAR status: ost$status);

    VAR
      existing_file: boolean,
      file: rat$path,
      ignore_attributes: array [1 .. 1] of amt$get_item,
      ignore_contains_data: boolean,
      local_file: boolean;

    status.normal := TRUE;
    file_exists := FALSE;
    ignore_attributes [1].key := amc$file_length;

    rap$convert_path_to_str (pft_file_p^, file);

    amp$get_file_attributes (file.path (1, file.size), ignore_attributes, local_file, existing_file,
          ignore_contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (local_file) OR (existing_file) THEN
      file_exists := TRUE;
    IFEND;

  PROCEND verify_file_exists;
?? OLDTITLE ??

MODEND ram$validate_for_correction;



*DECK DECK=RAM$VALIDATE_FOR_INSTALLATION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$VALIDATE_FOR_INSTALLATION Interface.' ??
MODULE ram$validate_for_installation;

{ PURPOSE:
{   This module contains the interface and procedures that validate for
{   installation.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$install_software_cc
*copyc rac$control_job_identifier
*copyc rac$idb_directory_level
*copyc rac$idb_directory_name
*copyc rac$inss_processor_version
*copyc rac$not_installed
*copyc rac$packing_list_level
*copyc rac$pacs_processor_version
*copyc rac$special_product_designators
*copyc rac$undefined_inst_path_element
*copyc clt$data_value
*copyc fst$path
*copyc rat$idb_directory_pointers
*copyc rat$installation_control_record
*copyc rat$packing_list_sequence
*copyc rat$product_references
*copyc rat$sequence_descriptor_types
*copyc rat$subproduct_install_paths
?? POP ??
*copyc amp$get_file_attributes
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc ofp$receive_operator_response
*copyc ofp$send_operator_message
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$establish_block_exit_hndlr
*copyc osp$disestablish_cond_handler
*copyc osp$generate_message
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc pfp$change
*copyc pfp$convert_fs_path_to_pf_path
*copyc pfp$convert_string_to_fs_path
*copyc pmp$get_compact_date_time
*copyc rap$access_directory_for_read
*copyc rap$access_directory_for_write
*copyc rap$assemble_installation_path
*copyc rap$establish_directory_ptrs
*copyc rap$locate_directory_record
*copyc rap$validate_for_correction
*copyc rav$product_reference
*copyc rav$subproduct_type
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    rat#licensed_product_references = record
      list_length: rat$subproduct_count,
      list_p: ^array [ * ] of rat#reference_record,
    recend;

  TYPE
    rat#reference_record = record
      name: ost$name,
      selected: boolean,
    recend;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$validate_for_installation', EJECT ??

{ PURPOSE:
{   This interface validates the installation request.
{
{ DESIGN:
{   Everything that can possibly be checked, that can abort the
{   installation, is checked at this time.  This is to eliminate or reduce
{   the potential for encountering an error after the installation work
{   begins.  Once installation processing begins, any errors encountered
{   involves backing out of any work that was already completed.
{
{   At 1.4.1 validation consists of validating the input list and the
{   ability to update the IDB Directory.  Also correction base validation is
{   performed (when dealing with corrections).  In the future the validating
{   may include other items, such as:
{
{     a.  Validate that the user has the authority to install into the
{         subproducts installation paths.
{
{     b.  Minimum ring is compared with file ring values (is the user
{         able to task down and create the lowest ring defined for the
{         files to be installed.)  This will not be needed if the user is
{         the site administrator or running from the system console.
{
{     c.  The amount of space required for the installation will be
{         calculated and the space will be verified as being available.
{         (At 1.4.1 the user is responsible for managing the disk space
{         needs.  The display_packing_list command will provide the user
{         with the subproduct size requirements.)
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$validate_for_installation
    (    product_list_p: ^clt$data_value;
         excluded_product_list_p: ^clt$data_value;
         force_reinstall: boolean;
         installation_tasks: rat$task_selections;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      directory_fid: amt$file_identifier,
      directory_file_opened: boolean,
      directory_pointers: rat$idb_directory_pointers,
      ignore_status: ost$status,
      local_status: ost$status;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to close the IDB directory
{   when an abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (directory_fid, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      access_directory_for_validation (installation_control_record.processing_header_p^.
            installation_defaults.installation_database, directory_pointers, directory_fid,
            directory_file_opened, status);
      IF (NOT status.normal) AND (status.condition = rae$incompatible_sequence_level) THEN
        { Replace incompatible directory with a new directory.

        replace_incompatible_directory (installation_control_record.processing_header_p^.
            installation_defaults.installation_database, directory_pointers, directory_fid,
            directory_file_opened, status);

      IFEND;
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      { Validate the product list.

      validate_product_list (product_list_p, excluded_product_list_p, force_reinstall, directory_pointers,
            installation_tasks, installation_control_record, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF installation_control_record.processing_header_p^.command_compatible_type = rac$correction THEN
        rap$validate_for_correction (directory_pointers, installation_control_record, status);
      IFEND;

    END /main/;

    IF directory_file_opened THEN
      fsp$close_file (directory_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$validate_for_installation;

?? OLDTITLE ??
?? NEWTITLE := 'access_directory_for_validation', EJECT ??

{ PURPOSE:
{   This procedure access the directory for validation.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE access_directory_for_validation
    (    installation_database: rat$path;
     VAR directory_pointers: rat$idb_directory_pointers;
     VAR directory_fid: amt$file_identifier;
     VAR directory_file_opened: boolean;
     VAR status: ost$status);


    VAR
      ignore_directory_segment_ptr: amt$segment_pointer;


    status.normal := TRUE;

    { Validate that the IDB directory can be accessed for write mode.  At the same time assuring that
    { the directory is initialized.  Immediately close the directory and re-access it in read mode.

    rap$access_directory_for_write (installation_database, ignore_directory_segment_ptr, directory_fid,
          directory_file_opened, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF directory_file_opened THEN
      fsp$close_file (directory_fid, status);
      directory_file_opened := FALSE;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    rap$access_directory_for_read (installation_database, directory_pointers, directory_fid,
          directory_file_opened, status);

  PROCEND access_directory_for_validation;

?? OLDTITLE ??
?? NEWTITLE := 'add_to_licensed_prod_references', EJECT ??

{ PURPOSE:
{   This procedure processes the licensed product references made by a
{   specified subproduct or group name from the product list and any
{   references from the excluded product list.
{
{ DESIGN:
{   When a subproduct or group from the product list indirectly references a
{   licensed product that was not directly specified, the IDB directory must
{   be updated to record the licensed product reference.  This is also true
{   for any licensed product references by the excluded product list.
{
{   The licensed product references list is first checked to see if the
{   licensed product name is already on the list.  The licensed product name
{   is processed according to how it was referenced as follows:
{
{     1. When the product reference is from the excluded product list
{        add name to list if not found.  Set the select field
{        to not selected.  If name already on list do nothing.
{
{     2. When the product reference is by group or subproduct add name
{        to list if not found.  In either case set the select field to
{        selected.
{
{     3. When the product referece is by licensed product set the field
{        selected if name is already on the list.  Do nothing if name is
{        not on the list.
{
{ NOTES:
{   The subproduct processing records array contains a record for each
{   subproduct available for processing.  There cannot be more licensed
{   products than subproducts.  Since, the length of the list array used
{   here is established to be the length of the subproduct processing
{   records, it follows that the index can never exceed the upperbound
{   of the list array.  Therefore, no test is present.
{

  PROCEDURE add_to_licensed_prod_references
    (    product_reference: rat$product_references;
         licensed_product: ost$name;
     VAR licensed_product_references {input, output} : rat#licensed_product_references);


    VAR
      index: rat$subproduct_count,
      name_found: boolean;


    name_found := FALSE;
    index := 0;
    WHILE (NOT name_found) AND (index < licensed_product_references.list_length) DO
      index := index + 1;
      IF licensed_product_references.list_p^ [index].name = licensed_product THEN
        name_found := TRUE;
      IFEND;
    WHILEND;


    IF name_found THEN
      IF product_reference <> rac$excluded THEN
        licensed_product_references.list_p^ [index].selected := TRUE;
      IFEND;
    ELSE {name not in list}
      IF product_reference <> rac$licensed_product THEN
        licensed_product_references.list_length := licensed_product_references.list_length + 1;
        licensed_product_references.list_p^ [licensed_product_references.list_length].name :=
              licensed_product;
        IF product_reference = rac$excluded THEN
          licensed_product_references.list_p^ [licensed_product_references.list_length].selected := FALSE;
        ELSE {product reference is rac$subproduct or rac$group}
          licensed_product_references.list_p^ [licensed_product_references.list_length].selected := TRUE;
        IFEND;
      IFEND;
    IFEND;

  PROCEND add_to_licensed_prod_references;

?? OLDTITLE ??
?? NEWTITLE := 'display_product_rejected_msg', EJECT ??

{ PURPOSE:
{   This procedure displays an informative message to $RESPONSE declaring that
{   the product (a licensed product or group) was rejected for processing
{   because all of it's associated subproducts were found to already be
{   installed.
{
{ DESIGN:
{   This is not a validation error, processing will continue.
{
{ NOTES:
{

  PROCEDURE display_product_rejected_msg
    (    some_subproducts_selected: boolean;
         product_reference: rat$product_references;
         product_name: ost$name);


    VAR
      ignore_status: ost$status,
      local_status: ost$status;


    IF some_subproducts_selected THEN

      osp$set_status_abnormal ('RA', rae$subproducts_rejected, 'Some', local_status);

    ELSE {none were selected}

      osp$set_status_abnormal ('RA', rae$subproducts_rejected, 'All', local_status);

    IFEND;

    osp$append_status_parameter (osc$status_parameter_delimiter, rav$product_reference [product_reference],
          local_status);

    osp$append_status_parameter (osc$status_parameter_delimiter,
          product_name (1, clp$trimmed_string_size (product_name)), local_status);

    osp$generate_message (local_status, ignore_status);

  PROCEND display_product_rejected_msg;

?? OLDTITLE ??
?? NEWTITLE := 'display_subproduct_rejected_msg', EJECT ??

{ PURPOSE:
{   This procedure displays one of several informative messages to the job
{   log declaring that the subproduct (belonging to a licensed product or
{   group) was rejected for processing because of the condition that was
{   passed in.
{
{ DESIGN:
{   There are several rejection messages using the same parameters being
{   displayed to the job log.  The commonality of the code was the reason
{   for this procedure.  When the product type is subproduct, the message is
{   constructed using the licensed product name which is also passed in.
{
{   This is not a validation error, processing will continue.
{
{ NOTES:
{

  PROCEDURE display_subproduct_rejected_msg
    (    subproduct_name: rat$subproduct_name;
         licensed_product: rat$licensed_product;
         condition_for_rejection: ost$status_condition_code;
         product_name: ost$name;
         product_reference: rat$product_references);


    VAR
      ignore_status: ost$status,
      local_status: ost$status;


    osp$set_status_abnormal ('RA', condition_for_rejection,
          subproduct_name (1, clp$trimmed_string_size (subproduct_name)), local_status);

    IF product_reference <> rac$subproduct THEN

      osp$append_status_parameter (osc$status_parameter_delimiter, rav$product_reference [product_reference],
            local_status);

      osp$append_status_parameter (osc$status_parameter_delimiter,
            product_name (1, clp$trimmed_string_size (product_name)), local_status);

    ELSE {subproduct was directly referenced by the user}

      osp$append_status_parameter (osc$status_parameter_delimiter,
            rav$product_reference [rac$licensed_product], local_status);

      osp$append_status_parameter (osc$status_parameter_delimiter,
            licensed_product (1, clp$trimmed_string_size (licensed_product)), local_status);

    IFEND;

    osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);

  PROCEND display_subproduct_rejected_msg;

?? OLDTITLE ??
?? NEWTITLE := 'process_excluded_product_list', EJECT ??

{ PURPOSE:
{   This procedure processes the excluded product list.
{
{ DESIGN:
{   Each name from the excluded product list is examined to determine which
{   subproducts should be excluded from the installation event.  A product
{   name can be a licensed product, subproduct or group name, which
{   references a set of 1 or more subproducts.
{
{ NOTES:
{

  PROCEDURE process_excluded_product_list
    (    excluded_product_list_p: ^clt$data_value;
     VAR licensed_product_references {input, output} : rat#licensed_product_references;
     VAR installation_control_record {input, output} : rat$installation_control_record);


    VAR
      current_product_p: ^clt$data_value,
      i: rat$subproduct_count,
      j: 0 .. rac$max_additional_products,
      group_name: ost$name,
      subproduct_pointers: rat$subproduct_info_pointers;


    current_product_p := excluded_product_list_p;
    WHILE current_product_p <> NIL DO

    /main/
      FOR i := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^) DO
        subproduct_pointers := installation_control_record.subproduct_processing_records_p^ [i].
              subproduct_info_pointers;

        IF subproduct_pointers.attributes_p^.subproduct_type <>
              installation_control_record.processing_header_p^.command_compatible_type THEN
          { Skip the subproduct when type is not installable by the executing command.
          CYCLE /main/;
        IFEND;

        IF (current_product_p^.element_value^.name_value = subproduct_pointers.attributes_p^.
              licensed_product) OR (current_product_p^.element_value^.name_value =
              subproduct_pointers.attributes_p^.name) THEN

          { The current exclude product name references this subproduct.
          { The subproduct will be excluded.

          installation_control_record.subproduct_processing_records_p^ [i].product_reference := rac$excluded;
          add_to_licensed_prod_references (rac$excluded, subproduct_pointers.attributes_p^.licensed_product,
                licensed_product_references);

        ELSE {check for group name}
          group_name (1, * ) := rac$group_designator;
          group_name (clp$trimmed_string_size (rac$group_designator) + 1, * ) :=
                current_product_p^.element_value^.name_value (1,
                clp$trimmed_string_size (current_product_p^.element_value^.name_value));

        /group_check/
          FOR j := 1 TO UPPERBOUND (subproduct_pointers.attributes_p^.additional_products) DO
            IF group_name = subproduct_pointers.attributes_p^.additional_products [j] THEN

              { The current exclude product name references this subproduct.
              { The subproduct will be excluded.

              installation_control_record.subproduct_processing_records_p^ [i].product_reference :=
                    rac$excluded;
              add_to_licensed_prod_references (rac$excluded, subproduct_pointers.attributes_p^.
                    licensed_product, licensed_product_references);

              EXIT /group_check/;
            IFEND;
          FOREND /group_check/;

        IFEND;
      FOREND /main/;

      current_product_p := current_product_p^.link;
    WHILEND;

  PROCEND process_excluded_product_list;

?? OLDTITLE ??
?? NEWTITLE := 'process_product_list_all', EJECT ??

{ PURPOSE:
{   This procedure processes the product list as the keyword ALL.
{
{ DESIGN:
{   Each subproduct known to the packing list is examined.  Subproducts of
{   type correction are skipped when the installation command is
{   INSTALL_PRODUCT.  Subproducts of type release are skipped when the
{   installation command is INSTALL_CORRECTION.  Those subproducts not
{   skipped and set to be automatically installed become selection
{   candidates.  The rules for selection are described in detail in the
{   procedure that actually performs the selection.
{
{   A validation error does not stop subproduct validation from continuing
{   but it will terminate the rest of the installation processing.  This allows
{   all the validation errors to be discovered at one time.
{
{   The subproduct's user reference will be defined as licensed product.
{
{   Those subproducts that were not selected and are of type release will be
{   assigned the task to have an IDB Directory record added (when not
{   already listed).  This guarantees that the entire licensed product is
{   documented in the IDB Directory even when some of it's associated
{   subproducts are not actually installed.  (Incidently, this means that a
{   licensed product that is not automatically installed will have records
{   added to the IDB Directory.)
{
{ NOTES:
{   The COMMAND_COMPATIBLE_SOFTWARE boolean indicates whether or not the
{   packing list (used in processing the installation event) contained
{   subproducts that were compatible with the originating command.  That is,
{   when called by INSTALL_PRODUCT, the packing list contains subproducts of
{   type release, and when called by INSTALL_CORRECTION, the packing list
{   contains subproducts of type correction.
{

  PROCEDURE process_product_list_all
    (    force_reinstall: boolean;
         directory_pointers: rat$idb_directory_pointers;
         installation_tasks: rat$task_selections;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      auto_install: boolean,
      command_compatible_software: boolean,
      i: rat$subproduct_count,
      ignore_licensed_prod_references: rat#licensed_product_references,
      software_to_install: boolean,
      subproduct_pointers: rat$subproduct_info_pointers,
      subproduct_selected: boolean,
      subproduct_validation_error: boolean,
      validation_errors_occurred: boolean;


    status.normal := TRUE;
    command_compatible_software := FALSE;
    ignore_licensed_prod_references.list_p := NIL;
    software_to_install := FALSE;
    validation_errors_occurred := FALSE;


  /main/
    FOR i := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^) DO
      subproduct_pointers := installation_control_record.subproduct_processing_records_p^ [i].
            subproduct_info_pointers;

      IF subproduct_pointers.attributes_p^.subproduct_type <>
            installation_control_record.processing_header_p^.command_compatible_type THEN
        { Skip the subproduct when type is not compatible with the originating command.
        CYCLE /main/;
      IFEND;

      command_compatible_software := TRUE;
      subproduct_validation_error := FALSE;
      subproduct_selected := FALSE;

      IF installation_control_record.packing_list_pointers.order_medium = rac$tape THEN
        auto_install := installation_control_record.packing_list_pointers.tape_subproduct_indexer_p^ [i].
              auto_install;
      ELSE  { order_medium = rac$disk }
        auto_install := installation_control_record.packing_list_pointers.disk_subproduct_indexer_p^ [i].
              auto_install;
      IFEND;

      IF auto_install AND (installation_control_record.subproduct_processing_records_p^ [i].
            product_reference <> rac$excluded) THEN

        process_subproduct_candidate (subproduct_pointers.attributes_p^.licensed_product,
              rac$licensed_product, force_reinstall, directory_pointers, subproduct_pointers.attributes_p,
              subproduct_selected);

        IF subproduct_selected THEN
          register_subproduct_selection (rac$licensed_product,
                installation_control_record.packing_list_pointers, installation_tasks, i,
                installation_control_record.processing_header_p^.installation_defaults.system_catalog,
                installation_control_record.medium_processing_records_p,
                installation_control_record.subproduct_processing_records_p^ [i],
                ignore_licensed_prod_references, installation_control_record.processing_seq_p,
                subproduct_validation_error, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;

        software_to_install := (software_to_install OR subproduct_selected);
        validation_errors_occurred := (validation_errors_occurred OR subproduct_validation_error);

      IFEND;

      IF (NOT subproduct_selected) AND (subproduct_pointers.attributes_p^.subproduct_type = rac$release) THEN
        installation_control_record.subproduct_processing_records_p^ [i].
              task_set := $rat$task_selections [rac$update_directory_task];
      IFEND;
    FOREND /main/;

    IF validation_errors_occurred THEN
      osp$set_status_abnormal ('RA', rae$validation_errors_occurred, 'PRODUCT', status);
    ELSEIF NOT software_to_install THEN
      IF command_compatible_software THEN
        osp$set_status_abnormal ('RA', rae$no_software_to_install, '', status);
      ELSE
        osp$set_status_abnormal ('RA', rae$incompatible_software,
              rav$subproduct_type [installation_control_record.processing_header_p^.command_compatible_type],
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              installation_control_record.processing_header_p^.
              packing_list_name (1, clp$trimmed_string_size (installation_control_record.processing_header_p^.
              packing_list_name)), status);
      IFEND;
    IFEND;

  PROCEND process_product_list_all;

?? OLDTITLE ??
?? NEWTITLE := 'process_product_list_names', EJECT ??

{ PURPOSE:
{   This procedure processes the product list as a list of names.
{
{ DESIGN:
{   Each name from the product list is examined to determine which
{   subproducts should be selected for the installation event.  A product
{   name can be a licensed product, subproduct or group name, which
{   references a set of one or more subproducts.  A validation error is
{   returned when the product name does not.
{
{   A validation error does not stop product list validation from continuing
{   but it will terminate the rest of the installation processing.  This
{   allows all the validation errors to be discovered at one time.
{
{ NOTES:
{   The COMMAND_COMPATIBLE_SOFTWARE boolean indicates whether or not the
{   packing list (used in processing the installation event) contained
{   subproducts that were compatible with the originating command.  That is,
{   when called by INSTALL_PRODUCT, the packing list contains subproducts of
{   type release, and when called by INSTALL_CORRECTION, the packing list
{   contains subproducts of type correction.
{

  PROCEDURE process_product_list_names
    (    product_list_p: ^clt$data_value;
         force_reinstall: boolean;
         directory_pointers: rat$idb_directory_pointers;
         installation_tasks: rat$task_selections;
     VAR licensed_product_references {input, output} : rat#licensed_product_references;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      command_compatible_software: boolean,
      current_product_list_p: ^clt$data_value,
      subproducts_to_install: boolean,
      validation_errors_occurred: boolean;


    status.normal := TRUE;
    command_compatible_software := FALSE;
    subproducts_to_install := FALSE;
    validation_errors_occurred := FALSE;

    current_product_list_p := product_list_p;
    WHILE current_product_list_p <> NIL DO

      process_product_name (current_product_list_p^.element_value^.name_value, force_reinstall,
            directory_pointers, installation_tasks, licensed_product_references,
            installation_control_record, validation_errors_occurred, command_compatible_software,
            subproducts_to_install, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      current_product_list_p := current_product_list_p^.link;
    WHILEND;

    IF validation_errors_occurred THEN
      osp$set_status_abnormal ('RA', rae$validation_errors_occurred, 'PRODUCT', status);
      RETURN;
    ELSEIF NOT subproducts_to_install THEN
      IF command_compatible_software THEN
        osp$set_status_abnormal ('RA', rae$no_software_to_install, '', status);
      ELSE
        osp$set_status_abnormal ('RA', rae$incompatible_software,
              rav$subproduct_type [installation_control_record.processing_header_p^.command_compatible_type],
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              installation_control_record.processing_header_p^.
              packing_list_name (1, clp$trimmed_string_size (installation_control_record.processing_header_p^.
              packing_list_name)), status);
      IFEND;
      RETURN;
    IFEND;

    process_licnsed_prod_references (licensed_product_references, installation_control_record);

  PROCEND process_product_list_names;

?? OLDTITLE ??
?? NEWTITLE := 'process_product_name', EJECT ??

{ PURPOSE:
{   This procedure processes a single product name from the product list
{   against the subproduct list from the packing list.
{
{ DESIGN:
{   Each subproduct known to the packing list is examined.  Subproducts of
{   type correction are skipped when the installation command is
{   INSTALL_PRODUCT.  Subproducts of type release are skipped when the
{   installation command is INSTALL_CORRECTION.  Those subproducts not
{   skipped and referenced by the user (using the product list) either
{   directly (by subproduct name) or indirectly (by licensed product or
{   group name) become candidates for selection.  The rules for selection
{   are described in detail in the procedure that actually performs the
{   selection.
{
{   A licensed product reference is assumed when a product list name matches
{   the names of both a subproduct and a licensed product.  This means all
{   of the licensed product's subproducts are processed.
{
{   If any of the input list is determined to be not valid a validation error
{   is displayed and the validation error flag is set.
{
{ NOTES:
{

  PROCEDURE process_product_name
    (    product_name: ost$name;
         force_reinstall: boolean;
         directory_pointers: rat$idb_directory_pointers;
         installation_tasks: rat$task_selections;
     VAR licensed_product_references {input, output} : rat#licensed_product_references;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR validation_errors_occurred {input, output} : boolean;
     VAR command_compatible_software {input, output} : boolean;
     VAR subproducts_to_install: boolean;
     VAR status: ost$status);


    VAR
      auto_install: boolean,
      group_name: ost$name,
      i: rat$subproduct_count,
      ignore_status: ost$status,
      j: 0 .. rac$max_additional_products,
      local_status: ost$status,
      product_reference: rat$product_references,
      some_subproducts_rejected: boolean,
      some_subproducts_selected: boolean,
      subproduct_pointers: rat$subproduct_info_pointers,
      subproduct_selected: boolean,
      subproduct_validation_error: boolean;


    status.normal := TRUE;
    product_reference := rac$not_referenced;
    some_subproducts_rejected := FALSE;
    some_subproducts_selected := FALSE;

  /main/
    FOR i := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^) DO
      subproduct_pointers := installation_control_record.subproduct_processing_records_p^ [i].
            subproduct_info_pointers;

      IF subproduct_pointers.attributes_p^.subproduct_type <>
            installation_control_record.processing_header_p^.command_compatible_type THEN
        { Skip the subproduct when type is not installable by the executing command.
        CYCLE /main/;
      IFEND;

      command_compatible_software := TRUE;
      subproduct_validation_error := FALSE;
      subproduct_selected := FALSE;

      IF installation_control_record.packing_list_pointers.order_medium = rac$tape THEN
        auto_install := installation_control_record.packing_list_pointers.tape_subproduct_indexer_p^ [i].
              auto_install;
      ELSE  { order_medium = rac$disk }
        auto_install := installation_control_record.packing_list_pointers.disk_subproduct_indexer_p^ [i].
              auto_install;
      IFEND;

      IF product_name = subproduct_pointers.attributes_p^.licensed_product THEN
        product_reference := rac$licensed_product;
        IF installation_control_record.subproduct_processing_records_p^ [i].product_reference <>
              rac$excluded THEN

          {  The subproduct is only processed when auto install is true or the licensed product
          {  and subproduct names match.  When auto install is false, a task is assigned to add
          {  an entry to the directory if not already present.

          IF auto_install OR (subproduct_pointers.attributes_p^.licensed_product =
                subproduct_pointers.attributes_p^.name) THEN
            process_subproduct_candidate (product_name, product_reference, force_reinstall,
                  directory_pointers, subproduct_pointers.attributes_p, subproduct_selected);
            some_subproducts_rejected := (some_subproducts_rejected OR NOT subproduct_selected);
          ELSE {not auto install}
            installation_control_record.subproduct_processing_records_p^ [i].task_set :=
                  $rat$task_selections [rac$update_directory_task];
          IFEND;
        IFEND;

      ELSEIF product_name = subproduct_pointers.attributes_p^.name THEN
        product_reference := rac$subproduct;
        IF installation_control_record.subproduct_processing_records_p^ [i].product_reference <>
              rac$excluded THEN
          process_subproduct_candidate (product_name, product_reference, force_reinstall,
                directory_pointers, subproduct_pointers.attributes_p, subproduct_selected);
          some_subproducts_rejected := (some_subproducts_rejected OR NOT subproduct_selected);
        IFEND;

      ELSE {check for group name}
        group_name (1, * ) := rac$group_designator;
        group_name (clp$trimmed_string_size (rac$group_designator) + 1, * ) :=
              product_name (1, clp$trimmed_string_size (product_name));

      /group_check/
        FOR j := 1 TO UPPERBOUND (subproduct_pointers.attributes_p^.additional_products) DO
          IF group_name = subproduct_pointers.attributes_p^.additional_products [j] THEN
            product_reference := rac$group;
            IF auto_install AND (installation_control_record.subproduct_processing_records_p^ [i].
                  product_reference <> rac$excluded) THEN
              process_subproduct_candidate (product_name, product_reference, force_reinstall,
                    directory_pointers, subproduct_pointers.attributes_p, subproduct_selected);
              some_subproducts_rejected := (some_subproducts_rejected OR NOT subproduct_selected);
            IFEND;

            EXIT /group_check/;
          IFEND;
        FOREND /group_check/;

      IFEND;

      IF subproduct_selected THEN
        register_subproduct_selection (product_reference, installation_control_record.packing_list_pointers,
              installation_tasks, i, installation_control_record.processing_header_p^.installation_defaults.
              system_catalog, installation_control_record.medium_processing_records_p,
              installation_control_record.subproduct_processing_records_p^ [i], licensed_product_references,
              installation_control_record.processing_seq_p, subproduct_validation_error, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      some_subproducts_selected := (some_subproducts_selected OR subproduct_selected);
      validation_errors_occurred := (validation_errors_occurred OR subproduct_validation_error);

    FOREND /main/;


    IF product_reference = rac$not_referenced THEN
      osp$set_status_abnormal ('RA', rae$unknown_product_name,
            product_name (1, clp$trimmed_string_size (product_name)), local_status);
      osp$generate_message (local_status, ignore_status);
      validation_errors_occurred := TRUE;
    ELSEIF some_subproducts_rejected THEN
      display_product_rejected_msg (some_subproducts_selected, product_reference, product_name);
    IFEND;

    subproducts_to_install := (subproducts_to_install OR some_subproducts_selected);

  PROCEND process_product_name;

?? OLDTITLE ??
?? NEWTITLE := 'process_licnsed_prod_references', EJECT ??

{ PURPOSE:
{   This procedure processes the indirect licensed product references made
{   by a specified subproduct or group name or the excluded product list.
{
{ DESIGN:
{   When a subproduct or group from the product list indirectly references
{   a licensed product that was not directly specified, the IDB directory
{   must be updated to record the licensed product reference.
{
{   At this time the list of indirect licensed product references are
{   checked and all subproducts associated with the licensed product, that
{   are not already selected will have their task list set to update directory.
{
{ NOTES:
{

  PROCEDURE process_licnsed_prod_references
    (    licensed_product_references: rat#licensed_product_references;
     VAR installation_control_record {input, output} : rat$installation_control_record);


    VAR
      i: rat$subproduct_count,
      j: rat$subproduct_count;


    FOR i := 1 TO licensed_product_references.list_length DO

      IF licensed_product_references.list_p^ [i].selected THEN

        FOR j := 1 TO UPPERBOUND (installation_control_record.subproduct_processing_records_p^) DO

          IF (licensed_product_references.list_p^ [i].name =
                installation_control_record.subproduct_processing_records_p^ [j].subproduct_info_pointers.
                attributes_p^.licensed_product) AND (installation_control_record.
                subproduct_processing_records_p^ [j].subproduct_info_pointers.attributes_p^.subproduct_type =
                rac$release) THEN

            IF installation_control_record.subproduct_processing_records_p^ [j].task_set =
                  $rat$task_selections [] THEN

              installation_control_record.subproduct_processing_records_p^ [j].task_set :=
                    $rat$task_selections [rac$update_directory_task];

            IFEND;
          IFEND;
        FOREND;
      IFEND;
    FOREND;

  PROCEND process_licnsed_prod_references;

?? OLDTITLE ??
?? NEWTITLE := 'process_subproduct_candidate', EJECT ??

{ PURPOSE:
{   This procedure checks the IDB Directory to determine if the subproduct
{   candidate should be selected.  A boolean is returned based on the
{   results of the check.
{
{ DESIGN:
{   The following rules cause a subproduct to be rejected:
{
{     1.  If no directory record for the subproduct exists or the
{         subproduct is not active and the subproduct level to be
{         installed is a correction.
{
{     2.  If the subproduct level to be installed is a correction and
{         its correction base level does not match that of the
{         correction base for the subproduct in the directory.
{
{     3.  If the subproduct level to be installed is already active and
{         there is no other level deferred.
{
{     4.  If the subproduct level to be installed is already deferred.
{
{     5.  If the subproduct level to be installed matches the correction
{         base level for the subproduct in the directory.  This is to
{         prevent release levels from being re-installed after corrections
{         have been installed.
{
{   An exception to the rules occurs the force_reinstall parameter is
{   specified.  This causes rules #3, #4 and #5 to be ignored.
{
{   When a subproduct is determined not selected, the reason for the
{   rejection is displayed in an informative message to the job log.
{
{ NOTES:
{   All the "level checks" are done using the SIF identifier, except
{   when a correction was generated using DEFINE_SUBPRODUCT.  In this
{   case the CORRECTION_BASE_LEVEL_SIF_IDENTIFIER is not available, so
{   that the actual level fields are compared.
{

  PROCEDURE process_subproduct_candidate
    (    product_name: ost$name;
         product_reference: rat$product_references;
         force_reinstall: boolean;
         directory_pointers: rat$idb_directory_pointers;
         subproduct_attributes_p: ^rat$subproduct_attributes;
     VAR subproduct_selected: boolean);


    VAR
      directory_record_p: ^rat$directory_record,
      ignore_status: ost$status,
      operator_message: string (256),
      operator_message_length : integer,
      response_from_operator: ost$string,
      subproduct_can_be_installed: boolean;


    subproduct_can_be_installed := TRUE;

    rap$locate_directory_record (subproduct_attributes_p^.name, subproduct_attributes_p^.licensed_product,
          directory_pointers, directory_record_p);

    IF directory_record_p = NIL THEN

      IF subproduct_attributes_p^.subproduct_type = rac$correction THEN

        { Subproduct correction cannot be installed, subproduct currently not active.

        subproduct_can_be_installed := FALSE;
        display_subproduct_rejected_msg (subproduct_attributes_p^.name,
              subproduct_attributes_p^.licensed_product, rae$cannot_install_correction, product_name,
              product_reference);

      IFEND;

    ELSE {directory record found}

      IF (subproduct_attributes_p^.subproduct_type = rac$correction) AND
            (directory_record_p^.active_information.installation_identifier = rac$not_installed) THEN

        { Subproduct correction cannot be installed, subproduct currently not active.

        subproduct_can_be_installed := FALSE;
        display_subproduct_rejected_msg (subproduct_attributes_p^.name,
              subproduct_attributes_p^.licensed_product, rae$cannot_install_correction, product_name,
              product_reference);

      ELSEIF (subproduct_attributes_p^.subproduct_type = rac$correction) AND
            (((subproduct_attributes_p^.correction_base_sif_identifier <> osc$null_name) AND
            (directory_record_p^.corrective_base_information.installation_identifier <> rac$not_installed) AND
            (subproduct_attributes_p^.correction_base_sif_identifier <>
            directory_record_p^.corrective_base_information.sif_identifier)) OR
            ((subproduct_attributes_p^.correction_base_sif_identifier = osc$null_name) AND
            (subproduct_attributes_p^.correction_base_level <>
            directory_record_p^.corrective_base_information.subproduct_level))) THEN

        { Subproduct correction is not applicable to subproduct currently active.

        subproduct_can_be_installed := FALSE;
        display_subproduct_rejected_msg (subproduct_attributes_p^.name,
              subproduct_attributes_p^.licensed_product, rae$correction_not_applicable, product_name,
              product_reference);
        stringrep(operator_message, operator_message_length, 'Subproduct ',
              subproduct_attributes_p^.name (1, clp$trimmed_string_size(subproduct_attributes_p^.name)),
              ' of ', subproduct_attributes_p^.licensed_product (1,
              clp$trimmed_string_size(subproduct_attributes_p^.licensed_product)),
              ' not installed due to release level of subproduct in the IDB directory',
              ' not matching the level required for the correction.  See job log.');
        ofp$send_operator_message(operator_message (1, operator_message_length), ofc$system_operator,
              {acknowledgement_allowed =} TRUE, ignore_status);
        ofp$receive_operator_response (ofc$system_operator, osc$wait,
              response_from_operator, ignore_status);
      ELSEIF NOT force_reinstall THEN

        { Force_reinstall is not used.

        IF (directory_record_p^.active_information.installation_identifier <> rac$not_installed) AND
              (subproduct_attributes_p^.sif_identifier = directory_record_p^.active_information.
              sif_identifier) AND ((directory_record_p^.deferred_information.installation_identifier =
              rac$not_installed) OR (subproduct_attributes_p^.sif_identifier =
              directory_record_p^.deferred_information.sif_identifier)) THEN

          { Subproduct at this level is already installed active and no other level deferred.

          subproduct_can_be_installed := FALSE;
          display_subproduct_rejected_msg (subproduct_attributes_p^.name,
                subproduct_attributes_p^.licensed_product, rae$subproduct_installed, product_name,
                product_reference);

        ELSEIF (directory_record_p^.deferred_information.installation_identifier <> rac$not_installed) AND
              (subproduct_attributes_p^.sif_identifier = directory_record_p^.deferred_information.
              sif_identifier) THEN

          { Subproduct at this level is already installed deferred.

          subproduct_can_be_installed := FALSE;
          display_subproduct_rejected_msg (subproduct_attributes_p^.name,
                subproduct_attributes_p^.licensed_product, rae$subproduct_already_deferred, product_name,
                product_reference);

        ELSEIF (directory_record_p^.corrective_base_information.installation_identifier <> rac$not_installed)
              AND (subproduct_attributes_p^.sif_identifier = directory_record_p^.corrective_base_information.
              sif_identifier) THEN

          { Subproduct at this level is already installed as the corrective base.

          subproduct_can_be_installed := FALSE;
          display_subproduct_rejected_msg (subproduct_attributes_p^.name,
                subproduct_attributes_p^.licensed_product, rae$subp_installed_as_corr_base, product_name,
                product_reference);

        IFEND;
      IFEND;
    IFEND;

    subproduct_selected := subproduct_can_be_installed;

  PROCEND process_subproduct_candidate;

?? OLDTITLE ??
?? NEWTITLE := 'register_subproduct_selection', EJECT ??

{ PURPOSE:
{   This procedure registers the subproduct as selected.  Any validation errors
{   encountered are flagged.
{
{ DESIGN:
{   This procedure validates that the subproduct's installation path is
{   defined.  A validation error flag is returned when the path is not.
{
{   The installation task list and user reference (ie.  product type) are
{   assigned to the subproduct processing record.  The task list will cause the
{   subproduct to be processed accordingly when processing actually begins.
{
{   The subproduct count for the appropriate medium processing record is
{   incremented.  If the medium is tape the subproduct count for the primary
{   tape that the subproduct resides is incremented.  For disk orders there
{   is only 1 medium processing record.
{
{   When the user reference is by subproduct or group name, the licensed
{   product associated with that subproduct is added to a reference list.
{
{   The subproduct's installation catalog is also assembled and stored in the
{   processing sequence.
{
{ NOTES:
{

  PROCEDURE register_subproduct_selection
    (    product_reference: rat$product_references;
         packing_list_pointers: rat$packing_list_pointers;
         installation_tasks: rat$task_selections;
         subproduct_index: rat$subproduct_count;
         system_catalog: rat$path;
         medium_processing_records_p { input, output } : ^rat$medium_processing_records;
     VAR subproduct_processing_record { input, output } : rat$subp_processing_record;
     VAR licensed_product_references { input, output } : rat#licensed_product_references;
     VAR processing_seq_p: ^rat$processing_sequence;
     VAR subproduct_validation_error: boolean;
     VAR status: ost$status);


    status.normal := TRUE;
    subproduct_validation_error := FALSE;

    validate_installation_path (subproduct_processing_record.subproduct_info_pointers.attributes_p^.name,
          subproduct_processing_record.subproduct_info_pointers.attributes_p^.subproduct_type,
          subproduct_processing_record.subproduct_info_pointers.attributes_p^.licensed_product,
          subproduct_processing_record.subproduct_info_pointers.attributes_p^.installation_path.
          path_container_index, subproduct_processing_record.subproduct_info_pointers.path_container_p,
          subproduct_validation_error);

    IF subproduct_validation_error THEN
      RETURN;
    IFEND;

    { Assign the installation task set and user reference (product type) to the subproduct.

    subproduct_processing_record.task_set := installation_tasks;
    subproduct_processing_record.product_reference := product_reference;

    { Increment the appropriate medium processing record's subproduct count.

    IF packing_list_pointers.order_medium = rac$tape THEN
      medium_processing_records_p^ [packing_list_pointers.tape_subproduct_indexer_p^ [subproduct_index].
            primary_tape_vsn].subproduct_count := medium_processing_records_p^
            [packing_list_pointers.tape_subproduct_indexer_p^ [subproduct_index].primary_tape_vsn].
            subproduct_count + 1;
    ELSE {order medium = rac$disk}
      medium_processing_records_p^ [1].subproduct_count :=
            medium_processing_records_p^ [1].subproduct_count + 1;
    IFEND;

    { Call ADD_TO_LICENSED_PROD_REFERENCES to updated the licensed product references list, when not nil.
    { How the product was referenced determines what occurs in that procedure.

    IF licensed_product_references.list_p <> NIL THEN
      add_to_licensed_prod_references (product_reference, subproduct_processing_record.
            subproduct_info_pointers.attributes_p^.licensed_product, licensed_product_references);
    IFEND;

    { Assign the installation path for the subproduct.

    rap$assemble_installation_path( system_catalog, subproduct_processing_record.subproduct_info_pointers,
         rac$installation_path, subproduct_processing_record.installation_catalog_p, processing_seq_p,
         status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    subproduct_processing_record.installation_catalog_rel_p :=
          #REL (subproduct_processing_record.installation_catalog_p, processing_seq_p^);

  PROCEND register_subproduct_selection;

?? OLDTITLE ??
?? NEWTITLE := 'replace_incompatible_directory', EJECT ??

{ PURPOSE:
{   This procedure renames the existing incompatible directory
{   so that a new directory can be created in it's place.
{
{ DESIGN:
{
{ NOTES:
{

  PROCEDURE replace_incompatible_directory
    (    installation_database: rat$path;
     VAR directory_pointers: rat$idb_directory_pointers;
     VAR directory_fid: amt$file_identifier;
     VAR directory_file_opened: boolean;
     VAR status: ost$status);


    CONST
      no_password = '                               ';

    VAR
      cycle_reference: fst$cycle_reference,
      cycle_selector: clt$cycle_selector,
      directory: rat$path,
      directory_path_p: ^pft$path,
      fs_directory_path: string (fsc$max_path_size),
      ignore_open_position: fst$open_position,
      ignore_status: ost$status,
      length: integer,
      local_status: ost$status,
      new_directory: rat$path,
      new_name: array [1 .. 1] OF pft$change_descriptor,
      number_of_path_elements: fst$number_of_path_elements;


    status.normal := TRUE;

    { Convert the directory path to the correct format for using pfp$change interface.

    STRINGREP (directory.path, directory.size, installation_database.path (1, installation_database.size),
          '.', rac$idb_directory_name);

    pfp$convert_string_to_fs_path (directory.path (1, directory.size), fs_directory_path,
          number_of_path_elements, cycle_reference, ignore_open_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH directory_path_p: [1 .. number_of_path_elements];
    pfp$convert_fs_path_to_pf_path (fs_directory_path, directory_path_p, cycle_reference, cycle_selector,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Change directory name, this will allow a new directory to be created in it's place.

    new_name [1].change_type := pfc$pf_name_change;
    new_name [1].pfn (1, * ) := rac$idb_directory_name;
    STRINGREP (new_name [1].pfn, length, rac$idb_directory_name, '_OLD');

    pfp$change (directory_path_p^, cycle_selector.value, no_password, new_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { Display message conveying name change of the old directory.

    STRINGREP (new_directory.path, new_directory.size, installation_database.
          path (1, installation_database.size), '.', new_name
          [1].pfn (1, clp$trimmed_string_size (new_name [1].pfn)));

    osp$set_status_abnormal ('RA', rae$directory_moved, '', local_status);
    osp$append_status_file (osc$status_parameter_delimiter, new_directory.path (1, new_directory.size),
          local_status);
    osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], local_status, ignore_status);

    { Call access_directory_for_validation to create a new directory.

    access_directory_for_validation (installation_database, directory_pointers, directory_fid,
          directory_file_opened, status);

  PROCEND replace_incompatible_directory;

?? OLDTITLE ??
?? NEWTITLE := 'validate_installation_path', EJECT ??

{ PURPOSE:
{   This procedure validates that the subproduct's installation path is
{   defined.  A message is displayed to the job log when the path is not
{   defined.  In either case a boolean is returned with the validation
{   results.
{
{ DESIGN:
{   The verify is only of value when the path is user definable and the
{   subproduct is type release.
{
{ NOTES:
{

  PROCEDURE validate_installation_path
    (    subproduct_name: rat$subproduct_name;
         subproduct_type: rat$subproduct_type;
         licensed_product: rat$licensed_product;
         path_container_index: rat$path_container_index;
         path_container_p: ^rat$path_container;
     VAR path_validation_error: boolean);


    VAR
      ignore_status: ost$status,
      local_status: ost$status;


    { Determine whether or not the installation path is defined when the subproduct is
    { for a release.

    path_validation_error := FALSE;

    IF (subproduct_type = rac$release) AND ((path_container_p^ [path_container_index] =
          rac$undefined_inst_path_element) OR (path_container_p^ [path_container_index + 1] =
          rac$undefined_inst_path_element)) THEN

      { Either the family and/or user catalog names are not defined.

      path_validation_error := TRUE;

      osp$set_status_abnormal ('RA', rae$install_path_not_defined,
            subproduct_name (1, clp$trimmed_string_size (subproduct_name)), local_status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            licensed_product (1, clp$trimmed_string_size (licensed_product)), local_status);
      osp$generate_message (local_status, ignore_status);

    IFEND;

  PROCEND validate_installation_path;

?? OLDTITLE ??
?? NEWTITLE := 'validate_product_list', EJECT ??

{ PURPOSE:
{   This interface validates the product list specified on the installation
{   command call.
{
{ DESIGN:
{   Validation of the product list involves, first, verifying that the
{   licensed product, subproduct and/or group names specified by the product
{   list are known to the packing list used for this installation event.
{   Second, verifying that the subproducts referenced by the product list
{   names can be installed.  And third, setting the installation tasks for
{   those subproducts selected and approved for installation.  The
{   optional exclude products list is taken into account during validation.
{
{   Generally, the user will reference the subproducts by the licensed
{   product names.  This is how INSS must relate information back to the
{   user.  When the user references a subproduct by subproduct or group
{   name, the licensed product associated with that subproduct is added to a
{   reference list.  After selection has completed the licensed product
{   references list is processed.  A task is assigned that will add an IDB
{   Directory record (if not already in the directory) to all non-selected
{   subproducts belonging to the licensed products from the references list.
{   This guarantees that the entire licensed product is documented in the
{   IDB Directory even when some of it's associated subproducts are not
{   actually installed.
{
{   The algorithm for this procedure is as follows:
{
{   The subproducts specified by the exclude product list (either directly
{   or indirectly) are set to be excluded from further consideration.  The
{   licensed product names referenced by the excluded subproducts are added
{   to the licensed product references list (with the selected field is not
{   set).
{
{   The appropriate product list processing procedure is called (key ALL or
{   names).  When the product list is the keyword ALL, the licensed product
{   reference list is not used.  When the product list is a list of names
{   the product list is checked for keyword ALL.  An error is returned if
{   names are specified with keyword ALL.
{
{   (The IDB Directory is used to determine if the subproducts referenced by
{   the product list are installable.)
{
{ NOTES:
{

  PROCEDURE validate_product_list
    (    product_list_p: ^clt$data_value;
         excluded_product_list_p: ^clt$data_value;
         force_reinstall: boolean;
         directory_pointers: rat$idb_directory_pointers;
         installation_tasks: rat$task_selections;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


    VAR
      current_p: ^clt$data_value,
      licensed_product_references: rat#licensed_product_references;


    status.normal := TRUE;

    licensed_product_references.list_length := 0;
    PUSH licensed_product_references.list_p: [1 .. UPPERBOUND (installation_control_record.
          subproduct_processing_records_p^)];

    { Process the excluded product list.

    process_excluded_product_list (excluded_product_list_p, licensed_product_references,
          installation_control_record);

    { Process the product list based on whether its the keyword ALL or a list of names.

    IF product_list_p^.kind = clc$keyword THEN

      process_product_list_all (force_reinstall, directory_pointers, installation_tasks,
          installation_control_record, status);

    ELSE {list of names specified}

      { Test that key ALL is not specified along with product names.

      current_p := product_list_p;
      WHILE current_p <> NIL DO
        IF current_p^.element_value^.name_value = 'ALL' THEN
          osp$set_status_abnormal ('RA', rae$specified_names_and_key_all, '', status);
          RETURN;
        IFEND;
        current_p := current_p^.link;
      WHILEND;

      process_product_list_names (product_list_p, force_reinstall, directory_pointers, installation_tasks,
            licensed_product_references, installation_control_record, status);

    IFEND;

  PROCEND validate_product_list;
MODEND ram$validate_for_installation;
*DECK DECK=RAM$VALIDATE_INSTALLATION_PATHS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'CREATE_SUBPRODUCT_CORRECTION subutility: RAP$VALIDATE_INSTALLATION_PATH procedure.' ??
MODULE ram$validate_installation_paths;

{ PURPOSE:
{   This module contains the procedure to validate two installation paths.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rae$package_software_cc
*copyc rat$subproduct_info_types
?? POP ??
*copyc osp$append_status_parameter
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc rap$convert_path_to_str

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$validate_installation_paths', EJECT ??

{ PURPOSE:
{   This procedure compares the two installation paths.
{
{ DESIGN:
{   The installation paths are entered and compared.  If the paths are
{   cycle based, they must be equal.  If the paths are version based,
{   they must be different.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$validate_installation_paths
    (    base_attributes: rat$subproduct_attributes;
         base_path_container: rat$path_container;
         current_attributes: rat$subproduct_attributes;
         current_path_container: rat$path_container;
         installation_scheme: rat$installation_scheme;
         set_status_to_error: boolean;
     VAR status: ost$status);

    VAR
      base_installation_path_str: rat$path,
      base_path_p: ^pft$path,
      current_installation_path_str: rat$path,
      current_path_p: ^pft$path,
      i: rat$path_container_index,
      ignore_status: ost$status,
      local_status: ost$status,
      message_status: ost$status;

    status.normal := TRUE;

    PUSH base_path_p: [1 .. base_attributes.installation_path.path_length];
    FOR i := 1 TO base_attributes.installation_path.path_length DO
      base_path_p^ [i] := base_path_container [i + base_attributes.installation_path.path_container_index -
            1];
    FOREND;

    PUSH current_path_p: [1 .. current_attributes.installation_path.path_length];
    FOR i := 1 TO current_attributes.installation_path.path_length DO
      current_path_p^ [i] := current_path_container [i + current_attributes.installation_path.
            path_container_index - 1];
    FOREND;

    rap$convert_path_to_str (base_path_p^, base_installation_path_str);
    rap$convert_path_to_str (current_path_p^, current_installation_path_str);

    IF installation_scheme = rac$cycle_based THEN
      IF base_installation_path_str.path (1, base_installation_path_str.size) <>
            current_installation_path_str.path (1, current_installation_path_str.size) THEN
        osp$set_status_abnormal ('RA', rae$unmatched_attribute, 'Installation Path', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, base_attributes.pacs_catalog_path.
              path (1, base_attributes.pacs_catalog_path.size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, base_installation_path_str.
              path (1, base_installation_path_str.size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              current_attributes.pacs_catalog_path.path (1, current_attributes.pacs_catalog_path.size),
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, current_installation_path_str.
              path (1, current_installation_path_str.size), status);

      IFEND;

    ELSE {installation_scheme = rac$version_based}

      IF base_installation_path_str.path (1, base_installation_path_str.size) =
            current_installation_path_str.path (1, current_installation_path_str.size) THEN

        IF set_status_to_error THEN
          osp$set_status_abnormal ('RA', rae$matched_version_path_error, '', status);
        ELSE
          osp$set_status_abnormal ('RA', rae$matched_version_path_warn, '', local_status);
          osp$generate_error_message (local_status, ignore_status);
        IFEND;

      IFEND;

    IFEND;

  PROCEND rap$validate_installation_paths;

MODEND ram$validate_installation_paths;
*DECK DECK=RAM$VALIDATE_USER_COMMAND EXPAND=TRUE
PROC validate_user, valu (
  user, u                    : name = $required
  password, pw               : name = $optional
  project, p                 : list 2 of name = (account, project)
  user_prolog, up            : string = '$USER.PROLOG'
  user_epilog, ue            : string = '$USER_EPILOG'
  job_classes, job_class, jc : list of key batch, b, interactive, i, maintenance, m = (batch interactive)
  minimum_ring, mr           : integer 1..15 = 11
  nominal_ring, nr           : integer 1..15 = 11
  status                     : var of status = $optional
  )

  create_variable name=create_status kind=status

  CREATE_USER $value(user)
  create: ..
    BLOCK
      IF $specified(password) THEN
        change_login_password new_password=$value(password) status=create_status
      ELSE
        change_login_password new_password=$name($string($value(user))//'X') status=create_status
      IFEND
      EXIT create WHEN NOT create_status.normal
      IF $specified(password) THEN
        change_link_attribute_password value=$string($value(password)) status=create_status
      ELSE
        change_link_attribute_password value=$string($value(user))//'X' status=create_status
      IFEND
      EXIT create WHEN NOT create_status.normal
      change_account_project_default account=$value(project 1) project=$value(project 2) status=create_status
      EXIT create WHEN NOT create_status.normal
      change_user_prolog value=$value(user_prolog) status=create_status
      EXIT create WHEN NOT create_status.normal
      change_user_epilog value=$value(user_epilog) status=create_status
      EXIT create WHEN NOT create_status.normal
      change_job_class delete=all interactive_default=none batch_default=none status=create_status
      EXIT create WHEN NOT create_status.normal
      FOR i = 1 TO $set_count(job_classes) DO
        IF ($string($value(job_classes, i)) = 'BATCH') OR ($string($value(job_classes, i)) = 'B') THEN
          change_job_class add=batch batch_default=batch status=create_status
        ELSEIF ($string($value(job_classes, i)) = 'INTERACTIVE') OR ($string($value(job_classes, i)) = 'I') ..
              THEN
          change_job_class add=interactive interactive_default=interactive status=create_status
        ELSEIF ($string($value(job_classes, i)) = 'MAINTENANCE') OR ($string($value(job_classes, i)) = 'M') ..
              THEN
          change_job_class add=maintenance status=create_status
        IFEND
        EXIT create WHEN NOT create_status.normal
      FOREND
      change_ring_privilege minimum_ring=$value(minimum_ring) nominal_ring=$value(nominal_ring) ..
            status=create_status
    BLOCKEND create
  END_CREATE_USER
  IF NOT create_status.normal THEN
    delete_user $value(user)
  IFEND
  EXIT_PROC WITH create_status

PROCEND validate_user
*DECK DECK=RAM$VERIFY_OBJECT_LIBRARY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : BCU Generation' ??
MODULE ram$verify_object_library;

{ PURPOSE:
{   The purpose of this module is to determine if the contents of an
{   object library contain binary section maps for bound modules and
{   no compiler debug tables.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc llt$deferred_common_blocks
*copyc llt$deferred_entry_points
*copyc llt$form_definition
*copyc llt$load_module
*copyc oce$library_generator_errors
*copyc rae$package_software_cc
?? POP ??
*copyc amp$close
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc clp$get_path_description
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$verify_object_library', EJECT ??
*copyc rah$verify_object_library

  PROCEDURE [XDCL] rap$verify_object_library
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  pdt vol_pdt (
{    object_library, ol: file = $required
{    status)

?? PUSH (LISTEXT := ON) ??

    VAR
      vol_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^vol_pdt_names, ^vol_pdt_params];

    VAR
      vol_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['OBJECT_LIBRARY', 1], ['OL', 1], ['STATUS', 2]];

    VAR
      vol_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ OBJECT_LIBRARY OL

      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS

      [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed,
            [NIL, clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??

    VAR
      access_sel: amt$file_access_selections,
      cycle_sel: clt$cycle_selector,
      file_ref: clt$file_reference,
      found: boolean,
      i: 0 .. llc$max_dictionaries_on_library,
      interpretive_element: ^llt$object_text_descriptor,
      j: llt$module_index,
      library_fid: amt$file_identifier,
      library_lfn: amt$local_file_name,
      library_name: clt$path_name,
      library_seg: amt$segment_pointer,
      module_dictionary: ^llt$module_dictionary,
      module_header: ^llt$load_module_header,
      object_library: ^SEQ ( * ),
      object_library_dictionaries: ^llt$object_library_dictionaries,
      object_library_header: ^llt$object_library_header,
      object_text_descriptor: ^llt$object_text_descriptor,
      open_p: clt$open_position,
      path: ^pft$path,
      path_container: clt$path_container,
      value: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, vol_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('OBJECT_LIBRARY', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    library_lfn := value.file.local_file_name;

    clp$get_path_description (value.file, file_ref, path_container, path, cycle_sel, open_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    library_name := file_ref.path_name (1, file_ref.path_name_size);

    PUSH access_sel: [1 .. 1];
    access_sel^ [1].key := amc$access_mode;
    access_sel^ [1].access_mode := $pft$usage_selections [pfc$read];

    amp$open (library_lfn, amc$segment, access_sel, library_fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (library_fid, amc$sequence_pointer, library_seg, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    object_library := library_seg.sequence_pointer;

    RESET object_library;
    NEXT object_library_header IN object_library;
    IF object_library_header^.version <> llc$object_library_version THEN
      osp$set_status_abnormal ('OC', oce$e_invalid_library_version, object_library_header^.version, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, library_name, status);
      RETURN;
    IFEND;

    NEXT object_library_dictionaries: [1 .. object_library_header^.number_of_dictionaries] IN object_library;

    i := 1;
    found := FALSE;
    WHILE (i <= object_library_header^.number_of_dictionaries) AND NOT found DO
      IF object_library_dictionaries^ [i].kind = llc$module_dictionary THEN
        found := TRUE;
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;

    IF NOT found THEN
      osp$set_status_abnormal ('RA', rae$no_modules_on_library, library_name, status);
      RETURN;
    IFEND;

    module_dictionary := #PTR (object_library_dictionaries^ [i].module_dictionary, object_library^);

    FOR j := 1 TO UPPERBOUND (module_dictionary^) DO
      CASE module_dictionary^ [j].kind OF
      = llc$load_module =
        module_header := #PTR (module_dictionary^ [j].module_header, object_library^);
        IF llc$interpretive_element IN module_header^.elements_defined THEN
          interpretive_element := #PTR (module_header^.interpretive_element, object_library^);
          RESET object_library TO interpretive_element;
          NEXT object_text_descriptor IN object_library;
          IF object_text_descriptor^.kind <> llc$identification THEN
            osp$set_status_abnormal ('RA', rae$identification_not_first, library_name, status);
            RETURN;
          IFEND;

          check_for_section_maps (module_header, object_library, library_name, module_dictionary^ [j].name,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          check_for_debug_tables (interpretive_element, object_library, library_name, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      ELSE
        ;
      CASEND;
    FOREND;
    amp$close (library_fid, status);
  PROCEND rap$verify_object_library;
?? OLDTITLE ??
?? NEWTITLE := 'check_for_debug_tables', EJECT ??

{ PURPOSE:
{   The purpose of this request is to search through the object library record pairs for
{   debug tables and to return an error message if any are found.

  PROCEDURE check_for_debug_tables
    (    interpretive_element: ^llt$object_text_descriptor;
         p_object_library: ^SEQ ( * );
         library_name: clt$path_name;
     VAR status: ost$status);

    VAR
      abs_68000: ^llt$68000_absolute,
      actual_parameters: ^llt$actual_parameters,
      adr: ^llt$address_formulation,
      application_identifier: ^llt$application_identifier,
      binding_template: ^llt$binding_template,
      bti: ^llt$bit_string_insertion,
      deferred_common_blocks: ^llt$deferred_common_blocks,
      deferred_entry_points: ^llt$deferred_entry_points,
      entry_definition: ^llt$entry_definition,
      ext: ^llt$external_linkage,
      form_definition: ^llt$form_definition,
      formal_parameters: ^llt$formal_parameters,
      found: boolean,
      identification: ^llt$identification,
      libraries: ^llt$libraries,
      module_name: pmt$program_name,
      object_library: ^SEQ ( * ),
      object_text_descriptor: ^llt$object_text_descriptor,
      obsolete_formal_parameters: ^llt$obsolete_formal_parameters,
      obsolete_segment_definition: ^llt$obsolete_segment_definition,
      ppu: ^llt$ppu_absolute,
      record_number: integer,
      relocation: ^llt$relocation,
      replication: ^llt$replication,
      section_definition: ^llt$section_definition,
      segment_definition: ^llt$segment_definition,
      text: ^llt$text;

    status.normal := TRUE;

    object_library := p_object_library;
    module_name := osc$null_name;
    RESET object_library TO interpretive_element;
    NEXT object_text_descriptor IN object_library;
    record_number := 1;
    found := FALSE;
    WHILE NOT found AND (object_text_descriptor^.kind <> llc$transfer_symbol) DO
      CASE object_text_descriptor^.kind OF
      = llc$line_table, llc$symbol_table, llc$obsolete_line_table, llc$symbol_table_fragment,
            llc$line_table_fragment, llc$cybil_symbol_table_fragment, llc$supplemental_debug_tables =
        found := TRUE;
      = llc$identification =
        NEXT identification IN object_library;
        module_name := identification^.name;
      = llc$section_definition, llc$allotted_section_definition, llc$unallocated_common_block =
        NEXT section_definition IN object_library;
      = llc$bit_string_insertion =
        NEXT bti IN object_library;
      = llc$entry_definition =
        NEXT entry_definition IN object_library;
      = llc$binding_template =
        NEXT binding_template IN object_library;
      = llc$obsolete_segment_definition, llc$obsolete_allotted_seg_def =
        NEXT obsolete_segment_definition IN object_library;
      = llc$segment_definition, llc$allotted_segment_definition =
        NEXT segment_definition IN object_library;
      = llc$libraries =
        NEXT libraries: [1 .. object_text_descriptor^.number_of_libraries] IN object_library;
      = llc$deferred_common_blocks =
        NEXT deferred_common_blocks: [1 .. object_text_descriptor^.number_of_common_blocks] IN object_library;
      = llc$deferred_entry_points =
        NEXT deferred_entry_points: [1 .. object_text_descriptor^.number_of_entry_points] IN object_library;
      = llc$text =
        NEXT text: [1 .. object_text_descriptor^.number_of_bytes] IN object_library;
      = llc$replication =
        NEXT replication: [1 .. object_text_descriptor^.number_of_bytes] IN object_library;
      = llc$relocation =
        NEXT relocation: [1 .. object_text_descriptor^.number_of_rel_items] IN object_library;
      = llc$address_formulation =
        NEXT adr: [1 .. object_text_descriptor^.number_of_adr_items] IN object_library;
      = llc$external_linkage =
        NEXT ext: [1 .. object_text_descriptor^.number_of_ext_items] IN object_library;
      = llc$form_definition =
        NEXT form_definition: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;
      = llc$obsolete_formal_parameters =
        NEXT obsolete_formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN
              object_library;
      = llc$formal_parameters =
        NEXT formal_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;
      = llc$actual_parameters =
        NEXT actual_parameters: [[REP object_text_descriptor^.sequence_length OF cell]] IN object_library;
      = llc$ppu_absolute =
        NEXT ppu: [0 .. object_text_descriptor^.number_of_words - 1] IN object_library;
      = llc$68000_absolute =
        NEXT abs_68000: [[REP object_text_descriptor^.number_of_68000_bytes OF cell]] IN object_library;
      = llc$application_identifier =
        NEXT application_identifier IN object_library;
      ELSE
        osp$set_status_abnormal ('OC', oce$e_invalid_object_rec_kind, module_name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, record_number, 10, FALSE, status);
        RETURN;
      CASEND;
      IF NOT found THEN
        NEXT object_text_descriptor IN object_library;
        record_number := record_number + 1;
      IFEND;
    WHILEND;

    IF found THEN
      osp$set_status_abnormal ('RA', rae$debug_tables_on_library, library_name, status);
      RETURN;
    IFEND;

  PROCEND check_for_debug_tables;
?? OLDTITLE ??
?? NEWTITLE := 'check_for_section_maps', EJECT ??

{ PURPOSE:
{   The purpose of this request is to check to see if a bound module has section maps.
{   If it doesn't an error message is returned.

  PROCEDURE check_for_section_maps
    (    module_header: ^llt$load_module_header;
         object_library: ^SEQ ( * );
         library_name: clt$path_name;
         module_name: pmt$program_name;
     VAR status: ost$status);

    VAR
      info_element_header: ^llt$info_element_header;

    status.normal := TRUE;

    IF llc$information_element IN module_header^.elements_defined THEN
      info_element_header := #PTR (module_header^.information_element, object_library^);
      IF (info_element_header^.version <> llc$info_element_version) AND
            (info_element_header^.version <> llc$info_element_version_1_0) THEN
        osp$set_status_abnormal ('RA', rae$invalid_info_version, library_name, status);
        RETURN;
      IFEND;

      IF (info_element_header^.number_of_components > 0) AND
            (info_element_header^.number_of_section_maps < 1) THEN
        osp$set_status_abnormal ('RA', rae$no_section_maps, module_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, library_name, status);
        RETURN;
      IFEND;
    IFEND;
  PROCEND check_for_section_maps;
?? OLDTITLE ??
MODEND ram$verify_object_library;
*DECK DECK=RAM$VERIFY_SUBPRODUCT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: VERIFY_SUBPRODUCT Subcommand.' ??
MODULE ram$verify_subproduct;

{ PURPOSE:
{   This module contains the procedures that verify a subproduct's
{   subproduct information file against its PACS catalog.
{
{ DESIGN:
{   The information stored in the SUBPRODUCT_INFORMATION_FILE is compared
{   with information created by the permanent file procedures.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clc$standard_file_names
*copyc ost$status
*copyc pmt$condition
*copyc rac$sif_file_name
*copyc rae$package_software_cc
*copyc rat$path
*copyc rat$subproduct_info_pointers
*copyc rat$subproduct_info_types
*copyc rat$subproduct_verify_errors
*copyc rat$subproduct_verify_options
*copyc rat$validation_selections
?? POP ??
*copyc amp$flush
*copyc amp$get_segment_pointer
*copyc clp$get_system_file_id
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc mmp$create_segment
*copyc mmp$create_segment
*copyc mmp$delete_scratch_segment
*copyc mmp$delete_segment
*copyc ocp$checksum
*copyc osp$append_status_file
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$generate_error_message
*copyc osp$generate_message
*copyc osp$set_status_abnormal
*copyc pfp$convert_fs_path_to_pf_path
*copyc pfp$convert_string_to_fs_path
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_item_info
*copyc pfp$get_multi_item_info
*copyc rap$convert_path_to_str
*copyc rap$get_file_information
*copyc rap$get_sif_pointers
*copyc rap$locate_element
*copyc rap$open_file
*copyc rap$test_permits
*copyc rap$write_file_from_memory
*copyc osv$lower_to_upper

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$verify_subproduct_interface', EJECT ??

{ PURPOSE:
{   This procedure verifies a subproduct's SIF against its PACS catalog.
{   It will also update the information in the SIF which has changed
{   because of a backup and restore.
{
{ DESIGN:
{   The information stored in the subproduct information file is written
{   to a memory segment.  Then the subproduct information file is closed.
{   The information in the SIF memory segment is compared to the information
{   gathered by using the permanent file procedures.
{   If the reconcile_effects_of_restore verify option is used, the
{   subproduct information file is opened in write mode and rewritten with
{   the updated information.
{   with information created by the permanent file procedures.
{   If the VERIFY OPTION is:
{   1) BRIEF
{   The modification date and time is checked.
{   Verification stops when the first error is encountered.
{
{   2) FULL
{   The modification date and time is checked.
{   The attributes checksum is checked.
{   All files and catalogs are compared.
{   Verification does NOT stop on first error.
{   Offline residence of a file is checked.
{
{   3) RECONCILE_EFFECTS_OF_RESTORE
{   The modification date and time is checked.
{   The attributes checksum is checked.
{   The modification date and time are updated if needed and the attributes
{   checksum verifies.
{   The pacs catalog path is updated if necessary.
{   The subproduct size field is updated.
{   Offline residence of a file is checked.
{
{   4) MANUFACTURING
{   The modification date and time is checked.
{   Verification stops when the first error is encountered.
{   Offline residence of a file is checked.
{
{   Modification date and time will change if the file has been backed up and
{   restored or if the file has been modified.  To determine if the file has been
{   backed up and restored, the attributes checksum is checked.  If the
{   attributes checksum has also changed the file has been modified.

{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$verify_subproduct_interface
    (    pacs_ref_p: ^fst$file_reference;
         verify_option: ost$name;
         sif_identifier: ost$name;
     VAR status: ost$status);



    VAR
      amt_nil_segment_p: amt$segment_pointer,
      attributes_p: ^rat$subproduct_attributes,
      file_segment_p: amt$segment_pointer,
      file_sequence_p: ^rat$subproduct_info_sequence,
      ignore_status: ost$status,
      local_status: ost$status,
      memory_segment_p: mmt$segment_pointer,
      memory_seq_p: ^rat$subproduct_info_sequence,
      message_status: ost$status,
      response_fid: amt$file_identifier,
      sif_file_id: amt$file_identifier,
      sif_length: integer,
      sif_memory_size: integer,
      sif_ref: string (fsc$max_path_size),
      subproduct_info_pointers: rat$subproduct_info_pointers,
      subproduct_info_sequence_size: integer,
      upper_case_verify_option: ost$name,
      verify_errors: rat$subproduct_verify_errors,
      verify_options: rat$subproduct_verify_options,
      validation_selections: rat$validation_selections;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the file has been opened, it will be closed before the
{   the procedure returns.  If the sequence has been created,
{   it will be deleted before the procedure returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF memory_segment_p.seq_pointer <> NIL THEN
        mmp$delete_segment (memory_segment_p, 1, ignore_status);
        memory_segment_p.seq_pointer := NIL;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;
    amt_nil_segment_p.sequence_pointer := NIL;
    memory_segment_p.kind := mmc$sequence_pointer;
    memory_segment_p.seq_pointer := NIL;
    verify_errors := $rat$subproduct_verify_errors [];
    validation_selections := $rat$validation_selections [rac$loading_cycle_only, rac$no_rings_below_11,
          rac$no_permits];

    #TRANSLATE (osv$lower_to_upper, verify_option, upper_case_verify_option);

    IF upper_case_verify_option = 'BRIEF' THEN
      verify_options := $rat$subproduct_verify_options
            [rac$test_mod_date_time, rac$stop_on_first_error];
    ELSEIF upper_case_verify_option = 'FULL' THEN
      verify_options := $rat$subproduct_verify_options [rac$test_mod_date_time, rac$test_attributes_checksum,
            rac$test_offline_residence];
    ELSEIF upper_case_verify_option = 'RECONCILE_EFFECTS_OF_RESTORE' THEN
      verify_options := $rat$subproduct_verify_options
            [rac$test_mod_date_time, rac$test_attributes_checksum, rac$reconcile_mod_date_time,
            rac$reconcile_pacs_catalog, rac$calculate_size, rac$test_offline_residence];
    ELSEIF upper_case_verify_option = 'MANUFACTURING' THEN
      verify_options := $rat$subproduct_verify_options
            [rac$test_mod_date_time, rac$stop_on_first_error, rac$test_offline_residence];
    ELSE
      osp$set_status_abnormal ('RA', rae$incorrect_verify_option, upper_case_verify_option, status);
      RETURN;
    IFEND;

    STRINGREP (sif_ref, sif_length, pacs_ref_p^, '.', rac$sif_file_name);

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      write_sif_to_memory (^sif_ref (1, sif_length), sif_memory_size, memory_segment_p,
            subproduct_info_pointers, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      rap$get_sif_pointers (amt_nil_segment_p, memory_segment_p, ^sif_ref (1, sif_length),
            subproduct_info_pointers, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      attributes_p := subproduct_info_pointers.attributes_p;

{
{   Validate that the value of the PACS catalog path as stored in the
{   subproduct information file is equal to the value of the PACS catalog
{   path given on the procedure call.
{

      IF pacs_ref_p^ <> attributes_p^.pacs_catalog_path.path (1, attributes_p^.pacs_catalog_path.size) THEN

        IF rac$reconcile_pacs_catalog IN verify_options THEN
          attributes_p^.pacs_catalog_path.path := pacs_ref_p^;
          attributes_p^.pacs_catalog_path.size := #SIZE (pacs_ref_p^);

        ELSE

          IF rac$stop_on_first_error IN verify_options THEN
            osp$set_status_abnormal ('RA', rae$pacs_catalog_name_changed, attributes_p^.
                  pacs_catalog_path.path (1, attributes_p^.pacs_catalog_path.size), status);
            RETURN;
          ELSE
            verify_errors := verify_errors + $rat$subproduct_verify_errors [rac$pacs_catalog_moved];
          IFEND;

        IFEND;

      IFEND;

      IF sif_identifier <> '' THEN
        { Verify that the SIF identifier has not changed.

         IF sif_identifier <> attributes_p^.sif_identifier THEN
          osp$set_status_abnormal ('RA', rae$sif_identifier_changed, attributes_p^.
                name, status);
          RETURN;
         IFEND;

      IFEND;

{   Determine if the PACS catalog has changed.

      rap$verify_subproduct (pacs_ref_p, validation_selections, TRUE, verify_options, verify_errors,
            subproduct_info_pointers, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      osp$set_status_abnormal ('RA', rae$pacs_verify_successful, '', message_status);
      osp$append_status_file (osc$status_parameter_delimiter, pacs_ref_p^, message_status);
      osp$generate_message (message_status, ignore_status);
      clp$get_system_file_id (clc$job_command_response, response_fid, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$flush (response_fid, osc$nowait, status);

      IF upper_case_verify_option = 'RECONCILE_EFFECTS_OF_RESTORE' THEN
        rap$write_file_from_memory (sif_ref (1, sif_length), sif_memory_size,
              subproduct_info_pointers.subproduct_info_seq_p, status);
      IFEND;

    END /main/;

    IF memory_segment_p.seq_pointer <> NIL THEN
      mmp$delete_segment (memory_segment_p, 1, local_status);
      memory_segment_p.seq_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$verify_subproduct_interface;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$verify_subproduct', EJECT ??

{ PURPOSE:
{   This procedure will verify that the PACS catalog has not changed
{   since the SUBPRODUCT INFORMATION FILE was written.
{
{ DESIGN:
{   The information in the SUBPRODUCT INFORMATION FILE is compared to the
{   information gathered by the PF procedures to see if any changes
{   have been made in the PACS catalog since the subproduct information file was written.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$verify_subproduct
        (pacs_ref_p: ^fst$file_reference;
         validation_selections: rat$validation_selections;
         sif_present: boolean;
     VAR verify_options: rat$subproduct_verify_options;
     VAR verify_errors {input} : rat$subproduct_verify_errors;
     VAR subproduct_info_pointers {input} : rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      catalog_element_count: integer,
      catalog_element_p: ^rat$element,
      fs_path: fst$path,
      ignore_cycle_reference: fst$cycle_reference,
      ignore_cycle_selector: clt$cycle_selector,
      ignore_open_position: fst$open_position,
      ignore_status: ost$status,
      local_status: ost$status,
      number_of_path_elements: fst$number_of_path_elements,
      pacs_path_p: ^pft$path,
      path_index: integer,
      pf_info_seq_p: pft$p_info,
      pf_segment_pointer: mmt$segment_pointer,
      subproduct_size: integer;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the sequence has been created, it will be deleted before
{   the procedure returns.
{
{ NOTES:
{
{


    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF pf_segment_pointer.seq_pointer <> NIL THEN
        mmp$delete_segment (pf_segment_pointer, 1, ignore_status);
        pf_segment_pointer.seq_pointer := NIL;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    catalog_element_p := NIL;
    pf_segment_pointer.kind := mmc$sequence_pointer;
    pf_segment_pointer.seq_pointer := NIL;
    subproduct_size := 0;

    catalog_element_count := subproduct_info_pointers.attributes_p^.first_level_element_count;

    IF sif_present THEN
      catalog_element_count := catalog_element_count + 1;
    IFEND;

{  Convert the pacs catalog, which is in file reference format to PF format. }

    pfp$convert_string_to_fs_path (pacs_ref_p^, fs_path, number_of_path_elements, ignore_cycle_reference,
          ignore_open_position, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH pacs_path_p: [1 .. number_of_path_elements];
    pfp$convert_fs_path_to_pf_path (fs_path, pacs_path_p, ignore_cycle_reference, ignore_cycle_selector,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    path_index := UPPERBOUND (pacs_path_p^) + 1;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

{
{   Create a segment for the permanent file procedures.  All information that is
{   gathered by the permanent file procedures is written to this segment.
{

      mmp$create_segment (NIL, mmc$sequence_pointer, 1, pf_segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      pf_info_seq_p := pf_segment_pointer.seq_pointer;
      RESET pf_info_seq_p;

      process_catalog_information (catalog_element_p, pacs_path_p^, path_index,
            catalog_element_count, pf_info_seq_p, validation_selections, sif_present,
            subproduct_info_pointers, verify_options, verify_errors, subproduct_size, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF rac$calculate_size IN verify_options THEN
        subproduct_info_pointers.attributes_p^.size := subproduct_size;
      IFEND;

      IF NOT (verify_errors = $rat$subproduct_verify_errors []) THEN
        issue_error_message (pacs_ref_p, subproduct_info_pointers.attributes_p, verify_errors, status);
      IFEND;

    END /main/;

    IF pf_segment_pointer.seq_pointer <> NIL THEN
      mmp$delete_segment (pf_segment_pointer, 1, local_status);
      pf_segment_pointer.seq_pointer := NIL;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$verify_subproduct;

?? OLDTITLE ??
?? NEWTITLE := 'find_unmatched_elements', EJECT ??

{ PURPOSE:
{   This procedure finds all elements that are in
{   the subproduct information file and not in the PACS catalog.
{
{ DESIGN:
{   The pointer to the catalog element is passed to this procedure.
{   All elements in that catalog that are in the subproduct information file
{   are compared with the entries for the same catalog as described by the
{   permanent files directory.  When an element is in the SIF, but not in
{   the permanent files directory, an error message will be displayed.
{
{ NOTES:
{

  PROCEDURE find_unmatched_elements
    (    pf_directory_p: pft$p_directory_array;
         catalog_ref_p: ^fst$file_reference;
         catalog_element_p: ^rat$element;
         subproduct_info_pointers {input, output} : rat$subproduct_info_pointers;
     VAR verify_errors: rat$subproduct_verify_errors);

    VAR
      element_found: boolean,
      element_p: ^rat$element,
      file_length: integer,
      file_name: string (fsc$max_path_size),
      i: pft$array_index,
      ignore_status: ost$status,
      message_status: ost$status;


{
{   Start searching at the beginning of the element list when a NIL catalog_element_p is
{   passed to this procedure.  This will happen whenever the PACS catalog is checked
{   because it is not in the element list.
{

    IF catalog_element_p = NIL THEN
      element_p := subproduct_info_pointers.element_list_p;
    ELSE
      element_p := #PTR (catalog_element_p^.first_element_down_p,
            subproduct_info_pointers.subproduct_info_seq_p^);
    IFEND;

    WHILE element_p <> NIL DO
      element_found := FALSE;

    IF element_p^.active_element THEN

      /search_loop/
        FOR i := 1 TO UPPERBOUND (pf_directory_p^) DO

          IF element_p^.name = pf_directory_p^ [i].name THEN

            IF ((element_p^.element_type = rac$file) AND (pf_directory_p^ [i].name_type = pfc$file_name)) OR
                  ((element_p^.element_type = rac$catalog) AND (pf_directory_p^ [i].name_type =
                  pfc$catalog_name)) THEN
              element_found := TRUE;
            IFEND;

            EXIT /search_loop/;

          IFEND;

        FOREND /search_loop/;

        IF NOT element_found THEN

          STRINGREP (file_name, file_length, catalog_ref_p, '.', element_p^.name);

          IF element_p^.element_type = rac$file THEN
            osp$set_status_abnormal ('RA', rae$file_missing_from_pacs, '', message_status);
          ELSE {rac$catalog}
            osp$set_status_abnormal ('RA', rae$catalog_missing_from_pacs, '', message_status);
          IFEND;

          osp$append_status_file (osc$status_parameter_delimiter, file_name (1, file_length), message_status);
          osp$generate_error_message (message_status, ignore_status);
          verify_errors := verify_errors + $rat$subproduct_verify_errors [rac$unmatched_element];

        IFEND;

      IFEND;

{
{   The last element in a catalog has its next_element_across_p set to NIL.
{

      element_p := #PTR (element_p^.next_element_across_p, subproduct_info_pointers.subproduct_info_seq_p^);

    WHILEND;

  PROCEND find_unmatched_elements;

?? OLDTITLE ??
?? NEWTITLE := 'issue_error_message', EJECT ??

{ PURPOSE:
{
{ DESIGN:
{
{
{ NOTES:
{

  PROCEDURE issue_error_message
    (    pacs_ref_p: ^fst$file_reference;
         attributes_p: ^rat$subproduct_attributes;
     VAR verify_errors: rat$subproduct_verify_errors;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      message_status: ost$status;

    IF rac$pacs_catalog_moved IN verify_errors THEN
      osp$set_status_abnormal ('RA', rae$pacs_catalog_moved, attributes_p^.name, message_status);
      osp$append_status_parameter (osc$status_parameter_delimiter, attributes_p^.
            pacs_catalog_path.path (1, attributes_p^.pacs_catalog_path.size), message_status);
      osp$append_status_file (osc$status_parameter_delimiter, pacs_ref_p^, message_status);
      osp$generate_error_message (message_status, ignore_status);
    IFEND;

    IF NOT (verify_errors = $rat$subproduct_verify_errors []) THEN
      osp$set_status_abnormal ('RA', rae$pacs_does_not_verify, attributes_p^.name, status);
      osp$append_status_file (osc$status_parameter_delimiter, pacs_ref_p^, status);
    IFEND;

  PROCEND issue_error_message;

?? OLDTITLE ??
?? NEWTITLE := 'process_catalog_information', EJECT ??

{ PURPOSE:
{   This procedure gathers information about a catalog
{   and compares this information with the information in
{   SUBPRODUCT INFORMATION FILE.
{
{ DESIGN:
{   This procedure gathers information about a catalog using
{   the permanent file procedures.  PFP$GET_ITEM_INFO only
{   returns information about the catalog.  This is used to check
{   the catalog permits.  PFP$GET_MULTI_ITEM_INFO returns information
{   about all the files and catalogs one level down from the input catalog.
{   The directory_p^ contains an array of records.  Each record contains
{   the name of one element, its type (file or catalog) and the offset into
{   the permanent file sequence where more information about the element
{   can be found.
{
{ NOTES:
{   The subproduct size is a close estimation of the size of the
{   backup file of this catalog.

  PROCEDURE process_catalog_information
        (catalog_element_p: ^rat$element;
         catalog_path: pft$path;
         path_index: integer;
         catalog_element_count: integer;
         pf_info_seq_p: pft$p_info;
         validation_selections: rat$validation_selections;
         sif_present: boolean;
     VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR verify_options {input} : rat$subproduct_verify_options;
     VAR verify_errors {input} : rat$subproduct_verify_errors;
     VAR subproduct_size {input} : integer;
     VAR status: ost$status);


    VAR
      catalog_string: rat$path,
      current_subproduct_size: integer,
      checksum_files: boolean,
      directory_p: pft$p_directory_array,
      element_p: ^rat$element,
      element_found: boolean,
      file_path: rat$path,
      group: pft$group,
      i: pft$array_index,
      ignore_status: ost$status,
      info_record_p: pft$p_info_record,
      local_status: ost$status,
      message_status: ost$status,
      new_catalog_count: integer,
      path_p: ^pft$path,
      pf_element: rat$element,
      pf_info_item_seq_p: pft$p_info,
      validation_errors: boolean;


    status.normal := TRUE;
    group.group_type := pfc$public;
    validation_errors := FALSE;

    IF rac$calculate_contents_checksum IN verify_options THEN
      checksum_files := TRUE;
      { When checksum_files is TRUE, the contents checksum will be calculated by RAP$GET_FILE_INFORMATION.
    ELSE
      checksum_files := FALSE;
    IFEND;

    pf_element.name := catalog_path [UPPERBOUND (catalog_path)];
    pf_element.permit.defined := FALSE;
    pf_element.permit.permit_selections := $pft$permit_selections [];
    pf_element.permit.share_requirements := $pft$share_requirements [];
    pf_element.permit.application_info := '';
    pf_element.element_type := rac$catalog;
    pf_element.element_count := 0;

    pf_info_item_seq_p := pf_info_seq_p;

    pfp$get_item_info (catalog_path, group, $pft$catalog_info_selections
          [pfc$catalog_directory, pfc$catalog_permits, pfc$indirect_catalog_permits],
          $pft$file_info_selections [], pf_info_item_seq_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pf_info_item_seq_p := pf_info_seq_p;
    pfp$find_next_info_record (pf_info_item_seq_p, info_record_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$find_directory_array (info_record_p, directory_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rap$convert_path_to_str (catalog_path, catalog_string);

    rap$test_permits (validation_selections, ^catalog_string.path (1, catalog_string.size), info_record_p,
          directory_p^ [1].info_offset, validation_errors, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF validation_errors = TRUE THEN
      verify_errors := verify_errors + $rat$subproduct_verify_errors [rac$permit_errors];
      IF rac$stop_on_first_error IN verify_options THEN
        RETURN;
      IFEND;
    IFEND;

    pf_info_item_seq_p := pf_info_seq_p;
    pfp$get_multi_item_info (catalog_path, group, $pft$catalog_info_selections
          [pfc$catalog_directory, pfc$catalog_permits, pfc$indirect_catalog_permits],
          $pft$file_info_selections [pfc$file_directory, pfc$file_permits, pfc$file_description,
          pfc$file_cycles, pfc$cycle_label_descriptor], pf_info_item_seq_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pf_info_item_seq_p := pf_info_seq_p;
    pfp$find_next_info_record (pf_info_item_seq_p, info_record_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF rac$calculate_size IN verify_options THEN
      { This formula was created through trial and error.
      { This same formula is also used in ram$create_element_list.
      current_subproduct_size := subproduct_size + ((info_record_p^.body_size *
            ((UPPERBOUND (catalog_path) DIV 2) * UPPERBOUND (catalog_path) + 91)) DIV 10);
    IFEND;

    pfp$find_directory_array (info_record_p, directory_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF directory_p = NIL THEN {EMPTY CATALOG}
      IF catalog_element_count <> 0 THEN
        find_unmatched_elements (directory_p, ^catalog_string.path (1, catalog_string.size),
              catalog_element_p, subproduct_info_pointers, verify_errors);
      IFEND;
      RETURN;
    IFEND;

{
{   Increase the size the path container by 1 and fill the first
{   elements of the array with the catalog path.
{

    PUSH path_p: [1 .. UPPERBOUND (catalog_path) + 1];
    FOR i := 1 TO UPPERBOUND (catalog_path) DO
      path_p^ [i] := catalog_path [i];
    FOREND;

  /directory_loop/
    FOR i := 1 TO UPPERBOUND (directory_p^) DO

      IF sif_present AND (directory_p^ [i].name = rac$sif_file_name) THEN
        CYCLE /directory_loop/;
      IFEND;

{
{   Add the last name to the path.  This may be a file or a catalog name.
{

      path_p^ [UPPERBOUND (path_p^)] := directory_p^ [i].name;

      rap$convert_path_to_str (path_p^, file_path);

      element_p := subproduct_info_pointers.element_list_p;
      rap$locate_element (path_p, path_index, subproduct_info_pointers.subproduct_info_seq_p, element_p,
            element_found);

      IF element_found THEN

        IF element_p^.active_element THEN

          IF directory_p^ [i].name_type = pfc$file_name THEN

            rap$get_file_information (^file_path.path (1, file_path.size), path_p^, info_record_p,
                  directory_p^ [i].info_offset, validation_selections, checksum_files, validation_errors,
                  pf_element, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            IF validation_errors = TRUE THEN
              verify_errors := verify_errors + $rat$subproduct_verify_errors [rac$other_errors];
              IF rac$stop_on_first_error IN verify_options THEN
                RETURN;
              IFEND;
            IFEND;

            IF rac$calculate_size IN verify_options THEN
              current_subproduct_size := current_subproduct_size + pf_element.size;
            IFEND;

            process_file_information (^file_path.path (1, file_path.size), verify_options,
                  subproduct_info_pointers, pf_element, element_p^, verify_errors, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

        ELSE {pfc$catalog_name}

          new_catalog_count := element_p^.element_count;

            process_catalog_information (element_p, path_p^, path_index, new_catalog_count,
                  pf_info_item_seq_p, validation_selections, FALSE, subproduct_info_pointers, verify_options,
                    verify_errors, current_subproduct_size, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;

        IFEND;

      ELSE {Element NOT found}

        IF directory_p^ [i].name_type = pfc$file_name THEN
          osp$set_status_abnormal ('RA', rae$extra_file_in_pacs, '', message_status);
        ELSE
          osp$set_status_abnormal ('RA', rae$extra_catalog_in_pacs, '', message_status);
        IFEND;

        osp$append_status_file (osc$status_parameter_delimiter, file_path.path (1, file_path.size),
              message_status);
        osp$generate_error_message (message_status, ignore_status);
        verify_errors := verify_errors + $rat$subproduct_verify_errors [rac$unmatched_element];

      IFEND;

      IF (verify_errors <> $rat$subproduct_verify_errors []) AND
            (rac$stop_on_first_error IN verify_options) THEN
        RETURN;
      IFEND;

    FOREND /directory_loop/;


    find_unmatched_elements (directory_p, ^catalog_string.path (1, catalog_string.size), catalog_element_p,
          subproduct_info_pointers, verify_errors);


    IF rac$calculate_size IN verify_options THEN
      subproduct_size := current_subproduct_size;
    IFEND;

  PROCEND process_catalog_information;

?? OLDTITLE ??
?? NEWTITLE := 'process_file_information', EJECT ??

{ PURPOSE:
{   This procedure compare the information for one file element in the
{   subproduct information file with the information provided for the
{   same element by the permanent file procedures.
{
{ DESIGN:
{   The information from the subproduct information file and from the
{   permanent files procedures is passed into the procedure.  According
{   to the verify options, different fields are tested or reconciled.
{
{ NOTES:
{

  PROCEDURE process_file_information
    (    file_ref_p: ^fst$file_reference;
         verify_options: rat$subproduct_verify_options;
         subproduct_info_pointers {input, output} : rat$subproduct_info_pointers;
     VAR pf_element: rat$element;
     VAR element: rat$element;
     VAR verify_errors {input} : rat$subproduct_verify_errors;
     VAR status: ost$status);


    VAR
      attribute_override: array [1 .. 1] of fst$file_cycle_attribute,
      attributes_p: ^rat$subproduct_attributes,
      current_verify_options: rat$subproduct_verify_options,
      file_id: amt$file_identifier,
      file_opened: boolean,
      file_seg_p: amt$segment_pointer,
      ignore_status: ost$status,
      message_status: ost$status;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the file has been opened, it will be closed before the
{   the procedure returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF file_opened THEN
        fsp$close_file (file_id, ignore_status);
        file_opened := FALSE;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    attributes_p := subproduct_info_pointers.attributes_p;
    current_verify_options := verify_options;
    file_opened := FALSE;

    IF rac$test_mod_date_time IN current_verify_options THEN

      IF pf_element.modification_date_time <> element.modification_date_time THEN

        IF rac$stop_on_first_error IN current_verify_options THEN
          osp$set_status_abnormal ('RA', rae$mod_date_time_changed, '', message_status);
          osp$append_status_file (osc$status_parameter_delimiter, file_ref_p^, message_status);
          osp$generate_error_message (message_status, ignore_status);
          verify_errors := verify_errors + $rat$subproduct_verify_errors [rac$unmatched_date_time];
          RETURN;
        IFEND;

{
{   Since the file's modification date and time changed if the file was backed
{   up and restored, the contents checksum is checked to be sure that the file has really
{   changed.
{

        current_verify_options := current_verify_options + $rat$subproduct_verify_options
              [rac$test_contents_checksum];

      IFEND;

    IFEND;

    IF rac$get_attributes_checksum IN current_verify_options THEN
      element.attributes_checksum := pf_element.attributes_checksum;
    IFEND;

    IF rac$test_attributes_checksum IN current_verify_options THEN

      IF pf_element.attributes_checksum <> element.attributes_checksum THEN
        osp$set_status_abnormal ('RA', rae$attributes_checksum_changed, '', message_status);
        osp$append_status_file (osc$status_parameter_delimiter, file_ref_p^, message_status);
        osp$generate_error_message (message_status, ignore_status);
        verify_errors := verify_errors + $rat$subproduct_verify_errors [rac$unmatched_attrib_checksum];
        RETURN;
      IFEND;

    IFEND;

    IF (rac$test_contents_checksum IN current_verify_options) AND
          (NOT attributes_p^.calculate_contents_checksum) THEN
      osp$set_status_abnormal ('RA', rae$unable_to_compare_checksums, attributes_p^.name, message_status);
      osp$append_status_parameter (osc$status_parameter_delimiter, attributes_p^.
            pacs_catalog_path.path (1, attributes_p^.pacs_catalog_path.size), message_status);
      osp$generate_error_message (message_status, ignore_status);
      verify_errors := verify_errors + $rat$subproduct_verify_errors [rac$no_contents_checksum];
      RETURN;

    IFEND;

    IF ((rac$test_contents_checksum IN current_verify_options) AND
       NOT (rac$calculate_contents_checksum IN current_verify_options) AND
       (pf_element.size <> 0)) THEN

{
{   Open the file in read mode to compute the checksum.
{

      attribute_override [1].selector := fsc$file_organization;
      attribute_override [1].file_organization := amc$sequential;

      rap$open_file (file_ref_p, amc$segment, fsc$read, FALSE, ^attribute_override, file_id, file_opened,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      osp$establish_block_exit_hndlr (^abort_handler);

    /main/
      BEGIN

        amp$get_segment_pointer (file_id, amc$sequence_pointer, file_seg_p, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;

        RESET file_seg_p.sequence_pointer;
        pf_element.contents_checksum := ocp$checksum (file_seg_p.sequence_pointer);

      END /main/;

      fsp$close_file (file_id, ignore_status);
      osp$disestablish_cond_handler;

    ELSEIF (rac$test_offline_residence IN current_verify_options) THEN

{
{   Open the file in read mode to test for offline residence of the file.  An
{   abnormal status is returned from the open if the file is currently being
{   stored offline (ie. archived.)
{
{   In the future, it is recommended that the error indicating offline residence
{   be recorded, and the verification process continued to allow searching for
{   all files that are offline.  The process will still abort eventually; however,
{   it would wait until all errors are detected.
{

      attribute_override [1].selector := fsc$file_organization;
      attribute_override [1].file_organization := amc$sequential;

      rap$open_file (file_ref_p, amc$segment, fsc$read, FALSE, ^attribute_override, file_id, file_opened,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fsp$close_file (file_id, ignore_status);

    IFEND;

    IF (rac$test_contents_checksum IN current_verify_options) AND
          (pf_element.contents_checksum <> element.contents_checksum) THEN
      osp$set_status_abnormal ('RA', rae$contents_checksum_changed, '', message_status);
      osp$append_status_file (osc$status_parameter_delimiter, file_ref_p^, message_status);
      osp$generate_error_message (message_status, ignore_status);
      verify_errors := verify_errors + $rat$subproduct_verify_errors [rac$unmatched_contents_checksum];
      RETURN;
    IFEND;

    IF rac$reconcile_mod_date_time IN current_verify_options THEN
      element.modification_date_time := pf_element.modification_date_time;
    IFEND;

    IF rac$get_attributes_checksum IN current_verify_options THEN
      element.attributes_checksum := pf_element.attributes_checksum;
    IFEND;

    IF rac$calculate_contents_checksum IN current_verify_options THEN
      element.contents_checksum := pf_element.contents_checksum;
    IFEND;

  PROCEND process_file_information;

?? OLDTITLE ??
?? NEWTITLE := 'write_sif_to_memory', EJECT ??

{ PURPOSE:
{   This procedure writes a subproduct information file to memory.
{
{ DESIGN:
{   This procedure creates a scratch memory segment, opens the subproduct
{   information file, and writes the contents of the subproduct information
{   file to the memory segment.
{
{ NOTES:
{

  PROCEDURE write_sif_to_memory
    (    sif_ref_p: ^fst$file_reference;
     VAR subproduct_info_sequence_size: integer;
     VAR memory_segment_p: mmt$segment_pointer;
     VAR suproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);

    VAR
      file_opened: boolean,
      file_segment_p: amt$segment_pointer,
      file_sequence_p: ^rat$subproduct_info_sequence,
      memory_seq_p: ^rat$subproduct_info_sequence,
      sif_file_id: amt$file_identifier;

?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the file has been opened, it will be closed before the
{   the procedure returns.  If the sequence has been created,
{   it will be deleted before the procedure returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF file_opened THEN
        fsp$close_file (sif_file_id, ignore_status);
        file_opened := FALSE;
      IFEND;

      IF memory_segment_p.seq_pointer <> NIL THEN
        mmp$delete_segment (memory_segment_p, 1, ignore_status);
        memory_segment_p.seq_pointer := NIL;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

{ Create a scratch memory segment.

    mmp$create_segment (NIL, mmc$sequence_pointer, 1, memory_segment_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{
{ Open the subproduct information file and put its contents into a memory segment.
{

    file_opened := TRUE;
    rap$open_file (sif_ref_p, amc$segment, fsc$read, FALSE, NIL, sif_file_id, file_opened, status);
    IF NOT status.normal THEN
      file_opened := FALSE;
      RETURN;
    IFEND;

  /main/
    BEGIN

      amp$get_segment_pointer (sif_file_id, amc$sequence_pointer, file_segment_p, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      subproduct_info_sequence_size := #SIZE (file_segment_p.sequence_pointer^);

      RESET file_segment_p.sequence_pointer;
      NEXT file_sequence_p: [[REP subproduct_info_sequence_size OF cell]] IN file_segment_p.sequence_pointer;
      IF file_sequence_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
        RETURN;
      IFEND;

      RESET memory_segment_p.seq_pointer;
      NEXT memory_seq_p: [[REP subproduct_info_sequence_size OF cell]] IN memory_segment_p.seq_pointer;
      IF memory_seq_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
        RETURN;
      IFEND;

      memory_seq_p^ := file_sequence_p^;

    END /main/;

    IF file_opened THEN
      fsp$close_file (sif_file_id, status);
      IF NOT status.normal    THEN
        file_opened := FALSE;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND write_sif_to_memory;

MODEND ram$verify_subproduct;
*DECK DECK=RAM$VERIFY_SUBPRODUCT_COMMAND EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'PACKAGE_SOFTWARE Utility: VERIFY_SUBPRODUCT_COMMAND Subcommand.' ??
MODULE ram$verify_subproduct_command;

{ PURPOSE:
{   This module contains the procedure to interpret the SCL parameters
{   and to make a call to the CYBIL interface for VERIFY_SUBPRODUCT.
{
{ DESIGN:
{   This module interprets the SCL parameters and makes a call to
{   the CYBIL interface for VERIFY_SUBPRODUCT.
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*copyc clp$evaluate_parameters
*copyc rap$verify_subproduct_interface

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$verify_subproduct_command', EJECT ??

{ PURPOSE:
{   This procedure contains the procedure to interpret the SCL parameters
{   and to make a call to the CYBIL interface for VERIFY_SUBPRODUCT.
{
{ DESIGN:
{   This procedure interprets the SCL parameters and makes a call to
{   the CYBIL interface for VERIFY_SUBPRODUCT.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$verify_subproduct_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PROCEDURE vers_pdt (
{   pacs_catalog, pc: file = $required
{   verify_option, vo: key
{       (full, f)
{       (brief, b)
{       (reconcile_effects_of_restore, reor)
{       (manufacturing, m)
{     keyend = brief
{   sif_identifier: (BY_NAME, HIDDEN) name = $optional
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 8] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 9, 20, 19, 11, 42, 57],
    clc$command, 6, 4, 1, 0, 1, 0, 4, ''], [
    ['PACS_CATALOG                   ',clc$nominal_entry, 1],
    ['PC                             ',clc$abbreviation_entry, 1],
    ['SIF_IDENTIFIER                 ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4],
    ['VERIFY_OPTION                  ',clc$nominal_entry, 2],
    ['VO                             ',clc$abbreviation_entry, 2]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 303,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 3
    [3, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [8], [
    ['B                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['BRIEF                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['F                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['FULL                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
    ['MANUFACTURING                  ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['RECONCILE_EFFECTS_OF_RESTORE   ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['REOR                           ', clc$abbreviation_entry, clc$normal_usage_entry, 3]]
    ,
    'brief'],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$pacs_catalog = 1,
      p$verify_option = 2,
      p$sif_identifier = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

  VAR
    sif_identifier: ost$name;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$sif_identifier].specified THEN
      sif_identifier := pvt [p$sif_identifier].value^.name_value;
    ELSE
      sif_identifier := '';
    IFEND;

    rap$verify_subproduct_interface (pvt [p$pacs_catalog].value^.file_value, pvt [p$verify_option].
          value^.keyword_value, sif_identifier, status);

  PROCEND rap$verify_subproduct_command;

MODEND ram$verify_subproduct_command;
*DECK DECK=RAM$VERIFY_USER_INFO EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE ram$verify_user_info;
?? PUSH (LISTEXT := ON) ??
*copyc amd$file_attributes
*copyc amp$get_file_attributes
?? POP ??

*copyc rah$verify_user_info

  PROCEDURE [XDCL] rap$verify_user_info (old_file_name: amt$local_file_name;
        new_file_name: amt$local_file_name;
    VAR user_info_differs: boolean;
    VAR new_user_info: amt$user_info;
    VAR status: ost$status);

    VAR
      contains_data: boolean,
      get_attribute: ^amt$get_attributes,
      local_file: boolean,
      old_file: boolean,
      old_user_info: amt$user_info;

    PUSH get_attribute: [1 .. 1];
    get_attribute^ [1].key := amc$user_info;

    amp$get_file_attributes (old_file_name, get_attribute^, local_file, old_file, contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    old_user_info := get_attribute^ [1].user_info;

    amp$get_file_attributes (new_file_name, get_attribute^, local_file, old_file, contains_data, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    new_user_info := get_attribute^ [1].user_info;

    user_info_differs := (old_user_info <> new_user_info);
  PROCEND rap$verify_user_info;
MODEND ram$verify_user_info;
*DECK DECK=RAM$WRITE_CORRECTION_PACKAGE EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$write_correction_package;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc rae$error_messages
*copyc rav$correction_package_header
*copyc rav$corp
*copyc rav$elements
*copyc rat$correction_package_header
*copyc rat$correction_package
*copyc amp$open
*copyc amp$close
*copyc amp$set_segment_eoi
*copyc amp$get_segment_pointer
*copyc clp$scan_parameter_list
*copyc clp$get_value
*copyc osp$set_status_abnormal
?? POP ??

{    pdt gencp_pdt (
{      correction_package, cp: file = $required
{      status)

?? PUSH (LISTEXT := ON) ??

  VAR
    gencp_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^gencp_pdt_names, ^gencp_pdt_params
      ];

  VAR
    gencp_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['CORRECTION_PACKAGE', 1], ['CP', 1], ['STATUS', 2]];

  VAR
    gencp_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ CORRECTION_PACKAGE CP }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
*copyc rah$write_correction_package

  PROCEDURE [XDCL] rap$write_correction_package (parameter_list: clt$parameter_list;
    VAR status: ost$status);

    VAR
      correction: ^SEQ ( * ),
      current_correction: ^SEQ ( * ),
      i: rat$element_index,
      out: amt$segment_pointer,
      out_package: ^SEQ ( * ),
      out_psrs: ^array [1 .. * ] of rat$psr_ident,
      output_elements: ^rat$correction_package,
      output_fid: amt$file_identifier,
      output_file: clt$file,
      output_header: ^rat$correction_package_header,
      psr_info: ^array [1 .. * ] of rat$psr_ident,
      psrs: ^array [1 .. * ] of rat$psr_ident,
      value: clt$value;

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, gencp_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('CORRECTION_PACKAGE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output_file := value.file;

    IF rav$correction_package_header^.number_of_elements > 0 THEN
      amp$open (output_file.local_file_name, amc$segment, NIL, output_fid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$get_segment_pointer (output_fid, amc$sequence_pointer, out, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      RESET out.sequence_pointer;
      NEXT output_header IN out.sequence_pointer;
      output_header^ := rav$correction_package_header^;
      NEXT output_elements: [1 .. output_header^.number_of_elements] IN out.sequence_pointer;

      FOR i := 1 TO output_header^.number_of_elements DO
        output_elements^ [i] := rav$elements^ [i];
        current_correction := #PTR (rav$elements^ [i].correction_package, rav$corp.sequence_pointer^);
        RESET rav$corp.sequence_pointer TO current_correction;
        NEXT correction: [[REP rav$elements^ [i].size OF cell]] IN rav$corp.sequence_pointer;
        NEXT out_package: [[REP rav$elements^ [i].size OF cell]] IN out.sequence_pointer;
        out_package^ := correction^;
        output_elements^ [i].correction_package := #REL (out_package, out.sequence_pointer^);
        IF output_elements^ [i].number_of_psrs > 0 THEN
          psr_info := #PTR (rav$elements^ [i].psr_info, rav$corp.sequence_pointer^);
          RESET rav$corp.sequence_pointer TO psr_info;
          NEXT psrs: [1 .. rav$elements^ [i].number_of_psrs] IN rav$corp.sequence_pointer;
          NEXT out_psrs: [1 .. output_elements^ [i].number_of_psrs] IN out.sequence_pointer;
          out_psrs^ := psrs^;
          output_elements^ [i].psr_info := #REL (out_psrs, out.sequence_pointer^);
        IFEND;
      FOREND;
      amp$set_segment_eoi (output_fid, out, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      rav$correction_package_header^.number_of_elements := 0;

      amp$close (output_fid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      osp$set_status_abnormal ('RA', rae$no_correction_package, ' ', status);
      RETURN;
    IFEND;
  PROCEND rap$write_correction_package;
MODEND ram$write_correction_package;
*DECK DECK=RAM$WRITE_CP_TO_SCRATCH_FILE EXPAND=TRUE
?? RIGHT := 110 ??
MODULE ram$write_cp_to_scratch_file;
*copyc osd$default_pragmats
?? PUSH (LISTEXT := ON) ??
*copyc rav$correction_package_header
*copyc rav$corp
*copyc rav$elements
*copyc rat$correction_package_header
*copyc rat$correction_package
*copyc rac$status_id
*copyc rae$error_messages
*copyc amp$open
*copyc amp$close
*copyc amp$set_segment_eoi
*copyc amp$get_segment_pointer
*copyc clp$scan_parameter_list
*copyc clp$get_value
*copyc osp$set_status_abnormal
?? POP ??

{   pdt write_cp_pdt (
{     output, o: file = $required
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    write_cp_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^write_cp_pdt_names,
      ^write_cp_pdt_params];

  VAR
    write_cp_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['OUTPUT', 1], ['O', 1], ['STATUS', 2]];

  VAR
    write_cp_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ OUTPUT O }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
*copyc rah$write_cp_to_scratch_file

  PROCEDURE [XDCL] rap$write_cp_to_scratch_file (parameter_list: clt$parameter_list;
    VAR status: ost$status);

    VAR
      correction: ^SEQ ( * ),
      current_correction: ^SEQ ( * ),
      i: rat$element_index,
      out: amt$segment_pointer,
      out_package: ^SEQ ( * ),
      out_psrs: ^array [1 .. * ] of rat$psr_ident,
      output_elements: ^rat$correction_package,
      output_fid: amt$file_identifier,
      output_file: clt$file,
      output_header: ^rat$correction_package_header,
      psr_info: ^array [1 .. * ] of rat$psr_ident,
      psrs: ^array [1 .. * ] of rat$psr_ident,
      temp_seq: ^SEQ ( * ),
      value: clt$value;

    status.normal := TRUE;

    temp_seq := rav$corp.sequence_pointer;

    clp$scan_parameter_list (parameter_list, write_cp_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output_file := value.file;

    IF rav$correction_package_header^.number_of_elements > 0 THEN
      amp$open (output_file.local_file_name, amc$segment, NIL, output_fid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$get_segment_pointer (output_fid, amc$sequence_pointer, out, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      RESET out.sequence_pointer;
      NEXT output_header IN out.sequence_pointer;
      output_header^ := rav$correction_package_header^;
      NEXT output_elements: [1 .. output_header^.number_of_elements] IN out.sequence_pointer;

      FOR i := 1 TO output_header^.number_of_elements DO
        output_elements^ [i] := rav$elements^ [i];
        current_correction := #PTR (rav$elements^ [i].correction_package, temp_seq^);
        RESET temp_seq TO current_correction;
        NEXT correction: [[REP rav$elements^ [i].size OF cell]] IN temp_seq;
        NEXT out_package: [[REP rav$elements^ [i].size OF cell]] IN out.sequence_pointer;
        out_package^ := correction^;
        output_elements^ [i].correction_package := #REL (out_package, out.sequence_pointer^);
        IF output_elements^ [i].number_of_psrs > 0 THEN
          psr_info := #PTR (rav$elements^ [i].psr_info, temp_seq^);
          RESET temp_seq TO psr_info;
          NEXT psrs: [1 .. rav$elements^ [i].number_of_psrs] IN temp_seq;
          NEXT out_psrs: [1 .. output_elements^ [i].number_of_psrs] IN out.sequence_pointer;
          out_psrs^ := psrs^;
          output_elements^ [i].psr_info := #REL (out_psrs, out.sequence_pointer^);
        IFEND;
      FOREND;
      amp$set_segment_eoi (output_fid, out, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      amp$close (output_fid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      osp$set_status_abnormal (rac$status_id, rae$no_current_correction, '', status);
    IFEND;
  PROCEND rap$write_cp_to_scratch_file;
MODEND ram$write_cp_to_scratch_file;
*DECK DECK=RAM$WRITE_DEFINITION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'CREATE_ORDER_DEFINITION Subutility: WRITE_DEFINITION Subcommand.' ??
MODULE ram$write_definition;

{ PURPOSE:
{   This module contains the procedures that complete the order definition and
{   write the packing list and the order data file into the order catalog.
{
{ DESIGN:
{   An order catalog is not to be confused with a PACS catalog.
{
{   An order catalog is required by WRITE_DEFINITION as a place to create files
{   important to order filling (writing).  The order catalog is created by
{   WRITE_DEFINITION and therefore cannot exist prior to the execution of
{   WRITE_DEFINITION.  After an order definition is written the catalog will
{   contain a packing list and an order data file.
{
{      1. The packing list is shipped with the order and is required to
{         install and maintain the ordered software at the site.  A packing
{         list is a segment access file.  The packing list is originally
{         created in memory and then written into the order catalog.
{
{      2. The order data file contains information used in the writing of
{         the order by WRITE_ORDER.  The order data file is a text file that
{         when "included" will create SCL variables containing order data.
{
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{   Multiple calls to WRITE_DEFINITION without calling the QUIT command between
{   each call will create excess space in the packing list.
{
{   6/8/89
{   According to the tape project:
{
{   For 9 track:
{
{   1. VE writes 4128 byte blocks by default. (Of the 4128 bytes, 14 bytes are
{      header information.
{   2. Each block followed by inter-record-gap (IRG) which equals .3 of an inch
{      +/- .1 of an inch.
{   3. A tape mark plus its associated header and trailer labels (80 characters
{      per label) occupies about 3 inches of tape.  A tape mark is 2.5 inches
{      +/- .5 inches.
{   4. The label and tape marks which separate ansi_files in a multiple file
{      ANSI tape are about 9 inches.  The sequence is: file1, TM, EOF1, EOF2,
{      TM, HDR1, HDR2, TM, file2.
{
{   For 18 track:
{
{   1. VE writes 32640 byte blocks by default. (Of the 32640 bytes, 14 bytes are
{      header information.
{   2. Each block followed by inter-record-gap (IRG) which equals .079 of an inch
{      + .039/- .016 of an inch.
{   3. A tape mark plus its associated header and trailer labels (80 characters
{      per label) occupies less than 1 inch of tape.  A tape mark is .039 inches
{      +/- .011 inches.
{   4. The label and tape marks which separate ansi_files in a multiple file
{      ANSI tape are less than 1 inch.  The sequence is: file1, TM, EOF1, EOF2,
{      TM, HDR1, HDR2, TM, file2.
{
{   From our experimentation:
{   1. A 600 foot MT9$1600 tape can hold approximately 8,985,000 bytes.
{      That's 1248 bytes per inch.
{      That's 14,975 bytes per foot.
{   2. A 600 foot MT9$6250 tape can hold approximately 29,716,000 bytes.
{      That's 4127 bytes per inch.
{      That's 49,527 bytes per foot.
{   3. A 540 foot MT18$38000 tape can hold approximately 223,000,000 bytes.
{      That's 34,413 bytes per inch.
{      That's 412,962 bytes per foot.
{
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$not_assigned
*copyc rac$order_data_file_name
*copyc rac$packing_list_name
*copyc rac$sif_file_name
*copyc rac$tape_types
*copyc rae$package_software_cc
*copyc amt$file_byte_address
*copyc ost$string
*copyc rat$string
*copyc rat$tape
?? POP ??
*copyc i#current_sequence_position
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc amp$set_segment_eoi
*copyc clp$evaluate_file_reference
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pfp$define_catalog
*copyc pmp$get_date
*copyc pmp$get_unique_name
*copyc rap$add_name_to_path_ref
*copyc rap$get_file_path
*copyc smp$begin_sort_specification
*copyc smp$end_specification
*copyc smp$from_memory_area
*copyc smp$key
*copyc smp$to_memory_area
*copyc rap$open_file
*copyc rav$creod_scratch_segment
*copyc rav$order_contents_count
*copyc rav$order_contents_list_p
*copyc rav$packing_list_header_p
*copyc rav$packing_list_seq_p
*copyc rav$subproduct_type
*copyc rav$tape_information

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    bytes_per_foot_mt9$1600 = 14975,
    bytes_per_foot_mt9$6250 = 49527,
    bytes_per_foot_mt18$38000 = 412962,
    bytes_per_tape_gap_mt9$1600 = (75 * bytes_per_foot_mt9$1600) DIV 100, {9 inch gap}
    bytes_per_tape_gap_mt9$6260 = (75 * bytes_per_foot_mt9$6250) DIV 100, {9 inch gap}
    bytes_per_tape_gap_mt18$38000 = (bytes_per_foot_mt18$38000) DIV 12; {1 inch gap}


?? TITLE := '[XDCL] rap$write_definition', EJECT ??

{ PURPOSE:
{   This interface completes the order definition and writes the packing list
{   and the order data file into the order catalog.
{
{ DESIGN:
{   This is the main driver.
{
{   When processing orders to be written to tape:  The sorting of the contents
{   list before and after the the assignment of the contents list to tape is
{   required.  The first sort places the contents list into descending order by
{   priority and size.  The assignment algorithm is set up assuming this
{   ordering.  The second sort, rearranges the contents list into the order each
{   item was assigned.  The writing of the order data file and the creating of the
{   subproduct indexer assumes this ordering.
{
{   When processing disk orders there is no sorting required of the contents
{   list.  The contents list items are assigned to the disk file in the order
{   they were added (ADD_SUBPRODUCT).
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$write_definition
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ pdt wrid_pdt (
{  order_catalog, oc : file = $required
{  tape_list         : (BY_NAME, HIDDEN) list of name = $optional
{  status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 4, 15, 10, 5, 48, 561],
    clc$command, 4, 3, 1, 0, 1, 0, 3, ''], [
    ['OC                             ',clc$abbreviation_entry, 1],
    ['ORDER_CATALOG                  ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3],
    ['TAPE_LIST                      ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$hidden_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$order_catalog = 1,
      p$tape_list = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;


    VAR
      disk_subproduct_indexer_p: ^rat$disk_subproduct_indexer,
      order_catalog_p: ^pft$path,
      order_catalog_ref_p: ^fst$file_reference,
      tape_list_p: ^rat$primary_tape,
      write_definition_needed_flag_p: ^boolean;


    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF rav$order_contents_count < rac$first_subproduct_entry THEN
      osp$set_status_abnormal ('RA', rae$no_subproducts_ordered, '', status);
      RETURN;
    IFEND;

    IF (rav$packing_list_header_p^.order_medium = rac$tape) AND
          (rav$tape_information.tape_type = 'UNKNOWN') THEN
      osp$set_status_abnormal ('RA', rae$tape_attributes_not_defined, '', status);
      RETURN;
    IFEND;

    RESET rav$creod_scratch_segment.sequence_p TO rav$creod_scratch_segment.reset_p;

    order_catalog_ref_p := pvt [p$order_catalog].value^.file_value;
    create_order_catalog (order_catalog_ref_p, rav$creod_scratch_segment, order_catalog_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF rav$packing_list_header_p^.order_medium = rac$tape THEN

      estimate_tape_packing_list_size (rav$packing_list_seq_p, rav$tape_information, rav$order_contents_count,
            rav$order_contents_list_p);

      sort_order_contents ('PRIORITY_AND_SIZE', rav$order_contents_count, rav$order_contents_list_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      assign_order_contents_to_tape (pvt [p$tape_list].value, rav$tape_information, rav$order_contents_list_p,
            tape_list_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      sort_order_contents ('POSITION_ASSIGNED', rav$order_contents_count, rav$order_contents_list_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      create_tape_subproduct_indexer (rav$order_contents_count, rav$order_contents_list_p,
            rav$tape_information, tape_list_p, rav$packing_list_header_p, rav$packing_list_seq_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      write_tape_order_data_file (rav$packing_list_header_p, rav$order_contents_list_p, rav$tape_information,
            tape_list_p, order_catalog_ref_p, status);

    ELSE { medium is disk }

      estimate_disk_packing_list_size (rav$packing_list_seq_p, rav$order_contents_count,
            rav$order_contents_list_p);

      assign_order_contents_to_disk (rav$order_contents_list_p, order_catalog_p, rav$packing_list_header_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      create_disk_subproduct_indexer (rav$order_contents_count, rav$order_contents_list_p,
            rav$packing_list_header_p, rav$packing_list_seq_p, disk_subproduct_indexer_p, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      write_disk_order_data_file (rav$packing_list_header_p, rav$order_contents_list_p,
            disk_subproduct_indexer_p, order_catalog_ref_p, status);

    IFEND;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    write_packing_list (order_catalog_ref_p, rav$packing_list_seq_p, status);

    RESET rav$creod_scratch_segment.sequence_p;
    NEXT write_definition_needed_flag_p IN rav$creod_scratch_segment.sequence_p;
    write_definition_needed_flag_p^ := FALSE;

  PROCEND rap$write_definition;

?? TITLE := 'add_volume_to_tape', EJECT ??

{ PURPOSE:
{   This procedure assigns an additional tape volume to the current tape.
{
{ DESIGN:
{   An additional volume record is added to the end of the current tape's
{   additional volume linked list.  The ADDITIONAL_VOL_P points to the last
{   additional volume added (if additional volumes already exist).
{
{   The tape is designated as full by setting the bytes assigned field
{   with the maximum usable bytes for the tape.
{
{ NOTES:
{   The first tape size in the tape information record's size field will be
{   the largest size defined.  This is the size we will use.
{

  PROCEDURE add_volume_to_tape
    (VAR tape_info: rat$tape_information;
     VAR tape_vsn: string (6);
     VAR vsn_list_p: ^rat$tape_vsn_list;
     VAR tape_p: ^rat$primary_tape;
     VAR additional_vol_p: ^rat$additional_volume;
     VAR status: ost$status);


    VAR
      new_additional_vol_p: ^rat$additional_volume;


    status.normal := TRUE;

    get_next_vsn (tape_vsn, vsn_list_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT new_additional_vol_p IN rav$creod_scratch_segment.sequence_p;
    IF new_additional_vol_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    new_additional_vol_p^.evsn := tape_vsn;
    new_additional_vol_p^.rvsn := tape_vsn;
    new_additional_vol_p^.size := tape_info.sizes [1];
    new_additional_vol_p^.bytes_assigned := tape_info.sizes [1].usable_bytes;
    new_additional_vol_p^.next_volume_p := NIL;

    IF tape_p^.next_volume_p = NIL THEN
      tape_p^.next_volume_p := new_additional_vol_p;
    ELSE
      additional_vol_p^.next_volume_p := new_additional_vol_p;
    IFEND;

    additional_vol_p := new_additional_vol_p;

    tape_info.number_of_tapes := tape_info.number_of_tapes + 1;

  PROCEND add_volume_to_tape;

?? TITLE := 'assign_order_contents_to_disk', EJECT ??

{ PURPOSE:
{   This procedure assigns the ordered subproducts and packing list to the
{   required disk file.
{
{ DESIGN:
{   The total bytes required for the order is calculated.  This value cannot
{   exceed the maximum bytes allowed for a file.
{
{   The backup catalog path is created.  The subproducts will be backed up to
{   this catalog when the order is written.  There is no special arranging
{   algorithm required, the subproducts will be backed up in the same sequence
{   as they were added to the order.
{
{ NOTES:
{

  PROCEDURE assign_order_contents_to_disk
    (    contents_list_p: ^rat$order_contents_list;
         order_catalog_p: ^pft$path;
     VAR packing_list_header_p: ^rat$packing_list_header;
     VAR status: ost$status);


    VAR
      backup_catalog_path: string (fsc$max_path_size),
      backup_catalog_name: ost$name,
      i: integer,
      length: integer,
      total_bytes: integer;


    status.normal := TRUE;

    total_bytes := 0;
    FOR i := 1 TO UPPERBOUND (contents_list_p^) DO
      total_bytes := total_bytes + contents_list_p^ [i].size;
    FOREND;

    IF total_bytes > amc$file_byte_limit THEN
      osp$set_status_abnormal ('RA', rae$exceeded_max_size_disk_ordr, '', status);
      RETURN;
    IFEND;

    pmp$get_unique_name (backup_catalog_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (backup_catalog_path, length, ':', order_catalog_p^
          [1] (1, clp$trimmed_string_size (order_catalog_p^ [1])), '.', order_catalog_p^ [2]
          (1, clp$trimmed_string_size (order_catalog_p^ [2])), '.', backup_catalog_name);

    packing_list_header_p^.disk_backup_catalog (1, * ) := backup_catalog_path (1, length);
    packing_list_header_p^.disk_path (1, * ) := '';

  PROCEND assign_order_contents_to_disk;

?? TITLE := 'assign_order_contents_to_tape', EJECT ??

{ PURPOSE:
{   This procedure assigns the ordered subproducts and packing list to the
{   required tapes.  The order contents list is returned with the position
{   assigned for each subproduct set.  Also a list of tapes is returned.
{
{ DESIGN:
{   The subproduct tape assignment algorithm uses a best fit approach.
{   The order contents list has previously been sorted by priority and
{   size in decending order.  Looping through the contents list the
{   contents items are added to a tape until it is full or all contents
{   items have been assigned.  Additional tapes are added as required.
{
{     Assumptions and Requirements
{
{     1.  Minimize the number of tapes needed.  The ideal or theoretical
{         number of tapes is the number of tapes required when the
{         subproducts are backed up together as one multi-volume set.
{
{     2.  In general, tapes will be independent backups that can be
{         accessed asynchronously.  The only exception is when a subproduct
{         is too large to fit on a single tape.  Then the tape will become
{         multi-volume, with the additional tape volumes containing only
{         the subproduct in question.
{
{     3.  A subproduct will only be allowed to span across tapes when the
{         subproduct is larger than one tape.
{
{     4.  Files larger than one tape are not an issue since subproducts
{         will be allowed to be larger than one tape.
{
{     5.  When dealing with a subproduct larger than one tape the following
{         rules apply:
{
{           A tape can only be assigned one subproduct belonging to the
{           "too large" category.  A tape assigned a subproduct of this type
{           then is designated as the 1st tape of a multi-volume set.
{           (This means a separate multi-volume set will be defined for
{           each subproduct of type "too large".)
{
{           The subproduct is assigned to as many additional tape volumes
{           as the subproduct can completely fill.  Once the amount left
{           to be assigned is less than a single tape the remainder is
{           assigned to the 1st tape of the multi-volume set.
{
{           The subproduct causing the need for multi-volumes is the only
{           subproduct that can be assigned to the additional tapes of the
{           multi-volume set.
{
{           Additional subproducts are assigned to the 1st tape until the
{           tape is "completed".
{
{           The subproduct of type "too large" must be the last subproduct
{           backed up to the 1st tape of the multi-volume set.  This is
{           accomplished by setting the assigned field (of the "too large"
{           subproduct's contents record) to -1.  Once all the other
{           subproducts have had a chance to be assigned to the tape, the
{           assigned field will be set to the next available value.
{
{     6.  The largest tape size defined will be used in the tape
{         assignment algorithm.  Adjustments to smaller tape sizes (if
{         allowed) will be made after the assignments have been made.  When
{         adjusting a multi-volume tape place the smallest tape as the last
{         tape in the volume.
{
{ NOTES:
{   The tape sizes are assumed to be sorted from largest to smallest.
{   The first tape size is used during the assignment.
{

  PROCEDURE assign_order_contents_to_tape
    (    tape_list_parameter_p: ^clt$data_value;
     VAR tape_info: rat$tape_information;
     VAR contents_list_p: ^rat$order_contents_list;
     VAR tape_list_p: ^rat$primary_tape;
     VAR status: ost$status);


    CONST
      assigned_last_to_tape = -1;

    VAR
      additional_volume_p: ^rat$additional_volume,
      contents_assigned: integer,
      contents_index: integer,
      bytes_per_tape_gap: integer,
      contents_item_tape_size: integer,
      free_bytes: integer,
      i: integer,
      j: integer,
      max_bytes_per_tape: integer,
      multi_volume: boolean,
      tape_p: ^rat$primary_tape,
      vsn_list_p: ^rat$tape_vsn_list,
      tape_vsn: string (6);


    status.normal := TRUE;

    initialize_tape_assignment (tape_list_parameter_p, contents_list_p, tape_info, vsn_list_p, tape_list_p,
          tape_p, tape_vsn, max_bytes_per_tape, bytes_per_tape_gap, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    contents_assigned := 0;

    WHILE contents_assigned < UPPERBOUND (contents_list_p^) DO

{ One interation will complete the assignment to one tape.

      start_assignment_to_tape (contents_assigned, tape_info, tape_list_p, tape_p, tape_vsn, vsn_list_p,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      free_bytes := max_bytes_per_tape;
      multi_volume := FALSE;

{
{   Search the contents list to find subproducts that have not been assigned to a tape.
{

      FOR i := 1 TO UPPERBOUND (contents_list_p^) DO

        IF contents_list_p^ [i].position_assigned = rac$not_assigned THEN

          contents_item_tape_size := contents_list_p^ [i].size + bytes_per_tape_gap;

{
{   If the size of the subproduct is smaller than the number of bytes left on the tape,
{   assign the subproduct to the tape.
{

          IF contents_item_tape_size <= free_bytes THEN

            contents_assigned := contents_assigned + 1;

{
{   Indicate the position that the subproduct will have on the tape by setting
{   the position assigned to the number of contents that have been assigned.
{

            contents_list_p^ [i].position_assigned := contents_assigned;
            free_bytes := free_bytes - contents_item_tape_size;

          ELSEIF (multi_volume = FALSE) AND (contents_item_tape_size > max_bytes_per_tape) THEN

{
{   Determine if part of the multi volume subproduct can be assigned to the present tape vsn.
{

            IF (contents_item_tape_size MOD max_bytes_per_tape) <= free_bytes THEN

              multi_volume := TRUE;
              contents_list_p^ [i].position_assigned := assigned_last_to_tape;
              free_bytes := free_bytes - (contents_item_tape_size MOD max_bytes_per_tape);
              contents_index := i;

              FOR j := 1 TO (contents_item_tape_size DIV max_bytes_per_tape) DO
                add_volume_to_tape (tape_info, tape_vsn, vsn_list_p, tape_p, additional_volume_p, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              FOREND;

            IFEND;

          IFEND;

        IFEND;

      FOREND;

      IF multi_volume = TRUE THEN
        contents_assigned := contents_assigned + 1;
        contents_list_p^ [contents_index].position_assigned := contents_assigned;
        tape_info.number_of_multi_vol_sets := tape_info.number_of_multi_vol_sets + 1;
      IFEND;
      end_assignment_to_tape (contents_assigned, free_bytes, tape_info, tape_p, additional_volume_p);

    WHILEND;

  PROCEND assign_order_contents_to_tape;

?? TITLE := 'bytes_to_feet', EJECT ??

{ PURPOSE:
{   This function converts bytes to feet.
{
{ DESIGN:
{   The density representation of bytes per inch is required in the conversion.
{
{ NOTES:
{
{

  FUNCTION bytes_to_feet
    (    bytes: integer;
         density: ost$name): integer;


    IF density = rac$mt9$6250 THEN
      bytes_to_feet := bytes DIV bytes_per_foot_mt9$6250;
    ELSEIF density = rac$mt9$1600 THEN
      bytes_to_feet := bytes DIV bytes_per_foot_mt9$1600;
    ELSE { density = rac$mt18$38000 }
      bytes_to_feet := bytes DIV bytes_per_foot_mt18$38000;
    IFEND;

  FUNCEND bytes_to_feet;

?? TITLE := 'create_disk_subproduct_indexer', EJECT ??

{ PURPOSE:
{   This procedure creates the disk_subproduct_indexer within the packing list.
{
{ DESIGN:
{   The disk subproduct indexer array is created 1 size less then the order
{   contents list (the item in the contents list for the packing list is not
{   used in the subproduct indexer array).  The indexer is created at the end of
{   the packing list sequence.  The packing list header fields are set to
{   "recognize" the disk subproduct indexer.  Finally, the fields of the disk
{   subproduct indexer are set from the corresponding order contents list
{   fields.
{
{ NOTES:
{   The assumption is made that the current position pointer in the packing list
{   is at end of sequence.
{
{   Also that the packing list should be the first item in the order contents
{   list.  The "[i - 1]" indexing assumes this fact.
{

  PROCEDURE create_disk_subproduct_indexer
    (    contents_count: rat$subproduct_count;
         contents_list_p: ^rat$order_contents_list;
     VAR packing_list_header_p: ^rat$packing_list_header;
     VAR packing_list_seq_p: ^rat$packing_list_sequence;
     VAR disk_subproduct_indexer_p: ^rat$disk_subproduct_indexer;
     VAR status: ost$status);


    VAR
      backup_file_name: ost$name,
      i: integer;


    status.normal := TRUE;

    NEXT disk_subproduct_indexer_p: [1 .. (contents_count - 1)] IN packing_list_seq_p;
    IF disk_subproduct_indexer_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    packing_list_header_p^.subproduct_count := contents_count - 1;
    packing_list_header_p^.disk_subproduct_indexer_p := #REL (disk_subproduct_indexer_p, packing_list_seq_p^);

    FOR i := rac$first_subproduct_entry TO contents_count DO

      pmp$get_unique_name (backup_file_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      disk_subproduct_indexer_p^ [i - 1].subproduct_seq_length := contents_list_p^ [i].subproduct_seq_length;
      disk_subproduct_indexer_p^ [i - 1].subproduct_seq_p := contents_list_p^ [i].subproduct_seq_p;
      disk_subproduct_indexer_p^ [i - 1].backup_file := backup_file_name;
      disk_subproduct_indexer_p^ [i - 1].auto_install := contents_list_p^ [i].auto_install;
    FOREND;

  PROCEND create_disk_subproduct_indexer;

?? TITLE := 'create_order_catalog', EJECT ??

{ PURPOSE:
{   This procedure creates the order catalog.  In so doing, the order catalog is
{   verified to be non-exsistent, and the user is verified to have the necessary
{   privileges to create and write in this catalog.
{
{ DESIGN:
{   The order catalog path was specified as an input parameter of
{   WRITE_DEFINITION.  The input value is formated as a path reference string
{   and a path container array.  The path container array is required to
{   create the catalog and the former is passed back for further processing.
{   If the order catalog exists or the user does not have the necessary write
{   priveleges, a bad status will be returned.
{
{ NOTES:
{
{

  PROCEDURE create_order_catalog
    (    order_catalog_ref_p: ^fst$file_reference;
     VAR scratch_segment: rat$scratch_segment;
     VAR order_catalog_p: ^pft$path;
     VAR status: ost$status);


    status.normal := TRUE;

    rap$get_file_path (order_catalog_ref_p, scratch_segment.sequence_p, order_catalog_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pfp$define_catalog (order_catalog_p^, status);

  PROCEND create_order_catalog;

?? TITLE := 'create_scl_primary_vsn_list', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to convert the list of primary vsns to an
{   SCL list.
{
{ DESIGN:
{   The primary vsns are located by traversing the tape list along the next tape
{   pointers.  The RVSN is used as the vsn value.
{
{ NOTES:
{   The assumption is made that the tape list has at least one entry.
{

  PROCEDURE create_scl_primary_vsn_list
    (    tape_list_p: ^rat$primary_tape;
     VAR primary_vsns: rat$string);


    VAR
      length: integer,
      tape_p: ^rat$primary_tape,
      vsns: string (osc$max_string_size);


    STRINGREP (vsns, length, '(''', tape_list_p^.rvsn (1, clp$trimmed_string_size (tape_list_p^.rvsn)), '''');
    tape_p := tape_list_p^.next_tape_p;

    WHILE tape_p <> NIL DO
      STRINGREP (vsns, length, vsns (1, length), ',''', tape_p^.
            rvsn (1, clp$trimmed_string_size (tape_p^.rvsn)), '''');
      tape_p := tape_p^.next_tape_p;
    WHILEND;

    STRINGREP (primary_vsns.value, primary_vsns.length, vsns (1, length), ')');

  PROCEND create_scl_primary_vsn_list;

?? TITLE := 'create_scl_tape_data_lists', EJECT ??

{ PURPOSE:
{   This procedure creates the SCL tape data lists for the order data file.
{
{ DESIGN:
{   The tape data lists are created by following the primary tape's additional
{   volume pointers along the linked list (if any).
{
{   The length of measure used during the assignment algorithm is bytes.  This
{   is converted to feet for the SCL tape data lists.
{
{ NOTES:
{
{

  PROCEDURE create_scl_tape_data_lists
    (    tape_p: ^rat$primary_tape;
         density: ost$name;
     VAR assigned: rat$string;
     VAR evsn: rat$string;
     VAR rvsn: rat$string;
     VAR size: rat$string;
     VAR usable: rat$string);


    VAR
      additional_vol_p: ^rat$additional_volume;


    STRINGREP (evsn.value, evsn.length, '(''', tape_p^.evsn (1, clp$trimmed_string_size (tape_p^.evsn)),
          '''');
    STRINGREP (rvsn.value, rvsn.length, '(''', tape_p^.rvsn (1, clp$trimmed_string_size (tape_p^.rvsn)),
          '''');
    STRINGREP (size.value, size.length, '(', tape_p^.size.feet);
    STRINGREP (usable.value, usable.length, '(', bytes_to_feet (tape_p^.size.usable_bytes, density));
    STRINGREP (assigned.value, assigned.length, '(', bytes_to_feet (tape_p^.bytes_assigned, density));

    additional_vol_p := tape_p^.next_volume_p;
    WHILE additional_vol_p <> NIL DO
      STRINGREP (evsn.value, evsn.length, evsn.value (1, evsn.length),
            ', ''', additional_vol_p^.evsn (1, clp$trimmed_string_size (additional_vol_p^.evsn)), '''');
      STRINGREP (rvsn.value, rvsn.length, rvsn.value (1, rvsn.length),
            ', ''', additional_vol_p^.rvsn (1, clp$trimmed_string_size (additional_vol_p^.rvsn)), '''');
      STRINGREP (size.value, size.length, size.value (1, size.length), ', ', additional_vol_p^.size.feet);
      STRINGREP (usable.value, usable.length, usable.value (1, usable.length),
            ', ', bytes_to_feet (additional_vol_p^.size.usable_bytes, density));
      STRINGREP (assigned.value, assigned.length, assigned.value (1, assigned.length),
            ', ', bytes_to_feet (additional_vol_p^.bytes_assigned, density));

      additional_vol_p := additional_vol_p^.next_volume_p;
    WHILEND;

    STRINGREP (evsn.value, evsn.length, evsn.value (1, evsn.length), ')');
    STRINGREP (rvsn.value, rvsn.length, rvsn.value (1, rvsn.length), ')');
    STRINGREP (size.value, size.length, size.value (1, size.length), ')');
    STRINGREP (usable.value, usable.length, usable.value (1, usable.length), ')');
    STRINGREP (assigned.value, assigned.length, assigned.value (1, assigned.length), ')');

  PROCEND create_scl_tape_data_lists;

?? TITLE := 'create_tape_subproduct_indexer', EJECT ??

{ PURPOSE:
{   This procedure creates the tape_subproduct_indexer and the tape_vsns list at
{   the current end of the packing list sequence.
{
{ DESIGN:
{   The tape_subproduct_indexer array is created 1 size less then the order
{   contents list (the item in the contents list for the packing list is not
{   used in the subproduct indexer array).  The indexer is created at the end of
{   the packing list sequence.  The packing list header fields are set to
{   "recognize" the tape_subproduct_indexer.
{
{   The tape_vsns list is create at the current end of the packing list.  This
{   is indexed by the tape_subproduct_indexer and contains the RVSN and EVSN
{   strings for all the tapes.  There are 2 parts to the list:  First, an array
{   1 to m of vsn records (where m is the number of primary tapes).  Second,
{   each (if any) additional volume required by the primary tapes is added to
{   the end of the packing list sequence.  Additional_volume_p connects them
{   with their primary tape record.
{
{   The tape list provides the information for creating the tape_vsn section.
{
{   While processing each tape list item the subproducts that are assigned to
{   that tape have their tape_subproduct_indexer entries initialized.  The
{   fields of the tape_subproduct_indexer are set from the corresponding order
{   contents list fields.
{
{ NOTES:
{   The assumption is made that the current position pointer in the packing list
{   is at end of sequence.
{
{   Also that the packing list should be the first item in the order contents
{   list.  The "[i - 1]" indexing assumes this fact.
{

  PROCEDURE create_tape_subproduct_indexer
    (    contents_count: rat$subproduct_count;
         contents_list_p: ^rat$order_contents_list;
         tape_info: rat$tape_information;
         tape_list_p: ^rat$primary_tape;
     VAR packing_list_header_p: ^rat$packing_list_header;
     VAR packing_list_seq_p: ^rat$packing_list_sequence;
     VAR status: ost$status);


    VAR
      additional_volume_p: ^rat$additional_volume,
      additional_vol_vsn_p: ^rat$tape_vsn,
      assignment_range_lowerbound: integer,
      file_sequence_number: integer,
      i: integer,
      index: integer,
      tape_p: ^rat$primary_tape,
      tape_subproduct_indexer_p: ^rat$tape_subproduct_indexer,
      tape_vsn_list_p: ^rat$tape_vsns,
      tape_vsn_p: ^rat$tape_vsn;


    status.normal := TRUE;

    NEXT tape_subproduct_indexer_p: [1 .. (contents_count - 1)] IN packing_list_seq_p;
    IF tape_subproduct_indexer_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    packing_list_header_p^.subproduct_count := contents_count - 1;
    packing_list_header_p^.tape_subproduct_indexer_p := #REL (tape_subproduct_indexer_p, packing_list_seq_p^);

    NEXT tape_vsn_list_p: [1 .. tape_info.number_of_primary_tapes] IN packing_list_seq_p;
    IF tape_vsn_list_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    packing_list_header_p^.primary_tape_count := tape_info.number_of_primary_tapes;
    packing_list_header_p^.tape_vsns_p := #REL (tape_vsn_list_p, packing_list_seq_p^);

    tape_p := tape_list_p;

    FOR index := 1 TO packing_list_header_p^.primary_tape_count DO
      tape_vsn_list_p^ [index].recorded_vsn := tape_p^.rvsn;
      tape_vsn_list_p^ [index].external_vsn := tape_p^.evsn;
      tape_vsn_p := ^tape_vsn_list_p^ [index];
      additional_volume_p := tape_p^.next_volume_p;
      WHILE additional_volume_p <> NIL DO
        NEXT additional_vol_vsn_p IN packing_list_seq_p;
        IF additional_vol_vsn_p = NIL THEN
          osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
          RETURN;
        IFEND;

        additional_vol_vsn_p^.recorded_vsn := additional_volume_p^.rvsn;
        additional_vol_vsn_p^.external_vsn := additional_volume_p^.evsn;
        tape_vsn_p^.additional_volume_p := #REL (additional_vol_vsn_p, packing_list_seq_p^);
        tape_vsn_p := additional_vol_vsn_p;
        additional_volume_p := additional_volume_p^.next_volume_p;
      WHILEND;

      tape_vsn_p^.additional_volume_p := NIL;

      IF tape_p^.assignment_range_lowerbound = 1 THEN

{ Adjust lowerbound and file sequence number to skip over the packing list.

        assignment_range_lowerbound := rac$first_subproduct_entry;
        file_sequence_number := rac$first_subproduct_entry;
      ELSE
        assignment_range_lowerbound := tape_p^.assignment_range_lowerbound;
        file_sequence_number := 1;
      IFEND;

      FOR i := assignment_range_lowerbound TO tape_p^.assignment_range_upperbound DO
        tape_subproduct_indexer_p^ [i - 1].subproduct_seq_length := contents_list_p^ [i].
              subproduct_seq_length;
        tape_subproduct_indexer_p^ [i - 1].subproduct_seq_p := contents_list_p^ [i].subproduct_seq_p;
        tape_subproduct_indexer_p^ [i - 1].primary_tape_vsn := index;
        tape_subproduct_indexer_p^ [i - 1].tape_file_sequence_number := file_sequence_number;
        tape_subproduct_indexer_p^ [i - 1].auto_install := contents_list_p^ [i].auto_install;
        file_sequence_number := file_sequence_number + 1;
      FOREND;

      tape_p := tape_p^.next_tape_p;
    FOREND;

  PROCEND create_tape_subproduct_indexer;

?? TITLE := 'end_assignment_to_tape', EJECT ??

{ PURPOSE:
{   This procedure is called when a tape or multi volume tape has been
{   assigned as many subproducts as it can contain.
{
{ DESIGN:
{   The tape size is adjusted down to the smallest tape that will
{   hold the bytes assigned.  When the tape is multi-volume the
{   size adjustment is made to the last tape of the volume set.
{
{   When the tape is multi-volume the bytes assigned field for the last
{   volume and the first are swapped (this reflects the actual byte
{   dispersal when the tapes are written).  This swap is done regardless
{   of whether or not there was a size adjustment.
{
{ NOTES:
{   The first tape size on list is the largest.  The tape size array
{   is ordered by size from largest to smallest.
{   The additional_volume pointer is pointing to the last volume of the
{   tape (if multi-volume).
{

  PROCEDURE end_assignment_to_tape
    (    assigned: integer;
         free_bytes: integer;
         tape_info: rat$tape_information;
     VAR tape_p: ^rat$primary_tape;
     VAR additional_volume_p: ^rat$additional_volume);


    VAR
      bytes_assigned: integer,
      i: integer;


    tape_p^.assignment_range_upperbound := assigned;
    tape_p^.bytes_assigned := tape_p^.size.usable_bytes - free_bytes;

  /adjust_tape_size/
    FOR i := UPPERBOUND (tape_info.sizes) DOWNTO 2 DO
      IF tape_p^.bytes_assigned <= tape_info.sizes [i].usable_bytes THEN
        IF tape_p^.next_volume_p = NIL THEN
          tape_p^.size := tape_info.sizes [i];
        ELSE
          additional_volume_p^.size := tape_info.sizes [i];
        IFEND;
        EXIT /adjust_tape_size/;
      IFEND;
    FOREND /adjust_tape_size/;

    IF tape_p^.next_volume_p <> NIL THEN
      bytes_assigned := additional_volume_p^.bytes_assigned;
      additional_volume_p^.bytes_assigned := tape_p^.bytes_assigned;
      tape_p^.bytes_assigned := bytes_assigned;
    IFEND;

  PROCEND end_assignment_to_tape;

?? TITLE := 'estimate_disk_packing_list_size', EJECT ??

{ PURPOSE:
{   This procedure estimates the size required for the packing list
{   when the order medium is defined for disk.
{
{ DESIGN:
{   The packing list currently contains the sequence_descriptor,
{   packing_list_header, and the SIF's for all the subproducts ordered.
{   The size for the disk_subproduct_indexer is estimated and added to
{   the current packing list size.  The estimation for the
{   disk_subproduct_indexer is based on the number of subproducts
{   ordered * the size of the index record.
{
{ NOTES:
{   Contents count includes the packing list.  This is adjusted
{   when computing the packing_list size.
{

  PROCEDURE estimate_disk_packing_list_size
    (    packing_list_seq_p: ^rat$packing_list_sequence;
         contents_count: rat$subproduct_count;
     VAR contents_list_p: ^rat$order_contents_list);


    VAR
      subproduct_indexer_size: integer;


    subproduct_indexer_size := (#SIZE (rat$disk_subproduct_index) * contents_count - 1);

    contents_list_p^ [rac$packing_list_entry].size := i#current_sequence_position (packing_list_seq_p) +
          subproduct_indexer_size;

  PROCEND estimate_disk_packing_list_size;

?? TITLE := 'estimate_tape_packing_list_size', EJECT ??

{ PURPOSE:
{   This procedure estimates the size required for the packing list when the
{   order medium is defined as tape.
{
{ DESIGN:
{   The packing list currently contains the sequence_descriptor,
{   packing_list_header, and the SIF's for all the subproducts ordered.  The
{   sizes for the tape_subproduct_indexer and tape_vsns are estimated and
{   added to the current packing list size.  The estimation for the
{   tape_subproduct_indexer is based on the number of subproducts ordered *
{   the size of the index record.  The estimation for the tape_vsns is based
{   on the size of the tape vsn record * a general guess factor for the
{   number of tapes at the specified tape density.  (The general guess is
{   assuming an order of 400 mega bytes and 2400 foot tapes for 9 track and
{   540 foot tapes for 18 track.)
{
{ NOTES:
{   Contents count includes the packing list.  This is not adjusted when
{   computing the packing_list size.  It is felt that this provides a small
{   cushion for error in the size estimation.
{

  PROCEDURE estimate_tape_packing_list_size
    (    packing_list_seq_p: ^rat$packing_list_sequence;
         tape_info: rat$tape_information;
         contents_count: rat$subproduct_count;
     VAR contents_list_p: ^rat$order_contents_list);


    CONST
      tape_factor_mt9$1600 = 12,
      tape_factor_mt9$6250 = 4,
      tape_factor_mt18$38000 = 2;

    VAR
      subproduct_indexer_size: integer;


    IF tape_info.tape_type = rac$mt9$6250 THEN
      subproduct_indexer_size := (#SIZE (rat$tape_subproduct_index) * contents_count) +
            (#SIZE (rat$tape_vsn) * tape_factor_mt9$6250);
    ELSEIF tape_info.tape_type = rac$mt9$1600 THEN
      subproduct_indexer_size := (#SIZE (rat$tape_subproduct_index) * contents_count) +
            (#SIZE (rat$tape_vsn) * tape_factor_mt9$1600);
    ELSE {tape_type = rac$mt18$38000}
      subproduct_indexer_size := (#SIZE (rat$tape_subproduct_index) * contents_count) +
            (#SIZE (rat$tape_vsn) * tape_factor_mt18$38000);
    IFEND;

    contents_list_p^ [rac$packing_list_entry].size := i#current_sequence_position (packing_list_seq_p) +
          subproduct_indexer_size;

  PROCEND estimate_tape_packing_list_size;

?? TITLE := 'get_next_vsn', EJECT ??

{ PURPOSE:
{   This procedure returns the next available vsn.  The next available
{   vsn is based on the vsn passed in.  If an empty string is passed in
{   the vsn seed is returned.
{
{ DESIGN:
{   The next vsn is generated by incrementing the last character of
{   the vsn string passed in.  Incremental range is the uppercase
{   alpha ('A'..'Z') and numbers ('0'..'9').  This means there is
{   a maximum of 36 unique tape vsns.  When this limit is reached
{   an error is returned.
{
{ NOTES:
{   This assumes the vsn is uppercase alpha or numbers.
{

  PROCEDURE get_next_vsn
    (VAR vsn: string (6);
     VAR vsn_list_p: ^rat$tape_vsn_list;
     VAR status: ost$status);


    CONST
      max_number_of_tapes = 36;

    VAR
      character: string (1),
      ignore_length: integer,
      length: 0 .. 6,
      max_tapes_str: string (3);


    IF vsn_list_p <> NIL THEN
      vsn := vsn_list_p^.vsn;
      vsn_list_p := vsn_list_p^.next_vsn_p;
    ELSEIF vsn = '' THEN
      vsn := rav$tape_information.vsn_seed;
    ELSE
      length := clp$trimmed_string_size (vsn);

      IF vsn (length, 1) = '9' THEN {switch to alpha}
        character := 'A';
      ELSEIF vsn (length, 1) = 'Z' THEN {switch to numbers}
        character := '0';
      ELSE
        character := $CHAR ($INTEGER (vsn (length, 1)) + 1);
      IFEND;

      vsn (length, 1) := character;

      IF vsn = rav$tape_information.vsn_seed THEN
        STRINGREP (max_tapes_str, ignore_length, max_number_of_tapes);
        osp$set_status_abnormal ('RA', rae$exceeded_max_tapes_allowed, max_tapes_str, status);
        RETURN;
      IFEND;
    IFEND;

  PROCEND get_next_vsn;

?? TITLE := 'initialize_tape_assignment', EJECT ??

{ PURPOSE:
{   This procedure initializes the variables required by the tape
{   assignment algorithm.
{
{ DESIGN:
{   The usable length in bytes for each tape size is calculated.
{   This is determined by the percent usable value and the tape
{   density.  The usable bytes for the largest tape size becomes the
{   maximum bytes allowed.
{
{   The theoretical number of tapes is calculated for statistical
{   comparision (by others) with the actual tapes required.
{   This value is the number of tapes required when the
{   subproducts are backed up together as one multi-volume set.
{   This is calculated by adding up all the sizes of the order contents
{   and adding the size of a tape file gap for each content item (since
{   each content item will be a discrete backup file on the tape).
{   This is then divided by the maximum bytes for the largest tape.
{   One tape is added to this value to account for a reminder lost
{   using integer division.  Example:
{                            Total bytes in all subproducts = 9,000,000
{                            Total bytes per tape = 2,000,000
{                            9,000,000 DIV 2,000,000 = 4
{                            But 4 tapes will only hold 8,000,000 bytes
{                            So the number of tapes must be 4 + 1 = 5.
{ NOTES:
{   The first tape size on list is the largest.
{
{

  PROCEDURE initialize_tape_assignment
    (    tape_list_parameter_p: ^clt$data_value;
         contents_list_p: ^rat$order_contents_list;
     VAR tape_info: rat$tape_information;
     VAR vsn_list_p: ^rat$tape_vsn_list;
     VAR tape_list_p: ^rat$primary_tape;
     VAR tape_p: ^rat$primary_tape;
     VAR tape_vsn: string (6);
     VAR max_bytes_per_tape: integer;
     VAR bytes_per_tape_gap: integer;
     VAR status: ost$status);


    VAR
      current_tape_p: ^clt$data_value,
      i: integer,
      new_vsn_p: ^rat$tape_vsn_list,
      number_of_tapes_theoretical: integer,
      total_bytes: integer,
      usable_feet: integer,
      vsn_p: ^rat$tape_vsn_list;


    FOR i := 1 TO UPPERBOUND (tape_info.sizes) DO

      IF tape_info.sizes [i].feet <> 0 THEN
        usable_feet := (tape_info.sizes [i].feet * tape_info.percent_usable) DIV 100;

        IF tape_info.tape_type = rac$mt9$6250 THEN
          tape_info.sizes [i].usable_bytes := usable_feet * bytes_per_foot_mt9$6250;
        ELSEIF tape_info.tape_type = rac$mt9$1600 THEN
          tape_info.sizes [i].usable_bytes := usable_feet * bytes_per_foot_mt9$1600;
        ELSE { tape type = rac$mt18$38000 }
          tape_info.sizes [i].usable_bytes := usable_feet * bytes_per_foot_mt18$38000;
        IFEND;

      IFEND;

    FOREND;

    max_bytes_per_tape := tape_info.sizes [1].usable_bytes;

    IF tape_info.tape_type = rac$mt9$6250 THEN
      bytes_per_tape_gap := bytes_per_tape_gap_mt9$6260;
    ELSEIF tape_info.tape_type = rac$mt9$1600 THEN
      bytes_per_tape_gap := bytes_per_tape_gap_mt9$1600;
    ELSE { tape type = rac$mt18$38000 }
      bytes_per_tape_gap := bytes_per_tape_gap_mt18$38000;
    IFEND;

    total_bytes := 0;
    FOR i := 1 TO UPPERBOUND (contents_list_p^) DO
      total_bytes := total_bytes + contents_list_p^ [i].size + bytes_per_tape_gap;
    FOREND;

    number_of_tapes_theoretical := total_bytes DIV max_bytes_per_tape + 1;

    tape_info.number_of_tapes := 0;
    tape_info.number_of_primary_tapes := 0;
    tape_info.number_of_multi_vol_sets := 0;
    tape_info.number_of_tapes_theoretical := number_of_tapes_theoretical;

    tape_list_p := NIL;
    tape_vsn := '';
    vsn_list_p := NIL;

    current_tape_p := tape_list_parameter_p;
    WHILE current_tape_p <> NIL DO

      NEXT new_vsn_p IN rav$creod_scratch_segment.sequence_p;
      IF new_vsn_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
        RETURN;
      IFEND;

      new_vsn_p^.vsn := current_tape_p^.element_value^.name_value;
      new_vsn_p^.next_vsn_p := NIL;

      IF vsn_list_p = NIL THEN
        vsn_list_p := new_vsn_p;
      ELSE
        vsn_p^.next_vsn_p := new_vsn_p;
      IFEND;
      vsn_p := new_vsn_p;

      current_tape_p := current_tape_p^.link;

    WHILEND;

  PROCEND initialize_tape_assignment;

?? TITLE := 'sort_order_contents', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to sort the order contents list by
{   the specified keys (fields).
{
{ DESIGN:
{   The sorting is performed by the standard NOS/VE Sort/Merge interfaces.
{   The sort_key parameter defines the type of sort that is performed.
{   The supported sorts are:
{
{     1. Sort by priority and size fields.  This sort is done prior to
{        the assignment of the contents list to tape.  The tape assignment
{        algorithm requires the contents list to be sorted in this way.
{
{     2. Sort by position assigned.  Once the contents has been assigned
{        this sort puts the contents list into the correct assignment order
{        for writing the order data file and packing list's
{        tape subproduct_indexer.
{
{   The contents list is rewritten to a new location within the scratch
{   segment.  The pointer to the contents list is reset to point to the
{   new (sorted) contents list.
{
{ NOTES:
{   The result_array is used by the sorting interfaces to return status
{   information about the sort.  At this time, this information is being
{   ignored.
{

  PROCEDURE sort_order_contents
    (    sort_key: string ( * <= osc$max_name_size);
         contents_count: rat$subproduct_count;
     VAR contents_list_p: ^rat$order_contents_list;
     VAR status: ost$status);


    VAR
      new_contents_list_p: ^rat$order_contents_list,
      order_catalog_p: ^pft$path,
      result_array: smt$info_array;


    status.normal := TRUE;
    result_array [1] := 0; {Number of result elements returned in this array.}

    NEXT new_contents_list_p: [1 .. contents_count] IN rav$creod_scratch_segment.sequence_p;
    IF new_contents_list_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    smp$begin_sort_specification (result_array, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    smp$from_memory_area (#LOC (contents_list_p^), 'FIXED', #SIZE (rat$order_contents), contents_count,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    smp$to_memory_area (#LOC (new_contents_list_p^), 'FIXED', #SIZE (rat$order_contents), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF sort_key = 'PRIORITY_AND_SIZE' THEN

      smp$key (1, #SIZE (rat$subproduct_priority), 'INTEGER', 'D', status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      smp$key ((1 + #SIZE (rat$subproduct_priority)), #SIZE (rat$subproduct_size), 'INTEGER', 'D', status);

    ELSE { sort_key = 'POSITION_ASSIGNED' }

      smp$key ((1 + #SIZE (rat$subproduct_priority) + #SIZE (rat$subproduct_size)),
            #SIZE (rat$position_assigned), 'INTEGER', 'A', status);

    IFEND;

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    smp$end_specification (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    contents_list_p := new_contents_list_p;

  PROCEND sort_order_contents;

?? TITLE := 'start_assignment_to_tape', EJECT ??

{ PURPOSE:
{   This procedure adds a new primary tape to the tape list.
{   This tape becomes the current tape of assignment.
{
{ DESIGN:
{   A new tape record is added to the tape list.  The tape list
{   is a linked list of tape records.  There is one record per
{   primary tape.  If the tape is required to be multi-volume
{   additional volume records are linked to the tape record
{   (this is done in ADD_VOLUME_TO_TAPE).
{
{   The assignment_range_lowerbound (and assignment_range_upperbound)
{   will index into the order contents list after it has been sorted
{   by priority assigned (this is after assignment is complete).
{   This index range gives us the contents items assigned to this tape.
{
{ NOTES:
{   The first tape size in the tape information record's size field
{   will be the largest size defined.  This is the size we will use.
{

  PROCEDURE start_assignment_to_tape
    (    assigned: integer;
     VAR tape_info: rat$tape_information;
     VAR tape_list_p: ^rat$primary_tape;
     VAR tape_p: ^rat$primary_tape;
     VAR tape_vsn: string (6);
     VAR vsn_list_p: ^rat$tape_vsn_list;
     VAR status: ost$status);


    VAR
      new_tape_p: ^rat$primary_tape;


    status.normal := TRUE;

    get_next_vsn (tape_vsn, vsn_list_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT new_tape_p IN rav$creod_scratch_segment.sequence_p;
    IF new_tape_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    new_tape_p^.evsn := tape_vsn;
    new_tape_p^.rvsn := tape_vsn;
    new_tape_p^.size := tape_info.sizes [1];
    new_tape_p^.bytes_assigned := 0;
    new_tape_p^.assignment_range_lowerbound := assigned + 1;
    new_tape_p^.assignment_range_upperbound := 0;
    new_tape_p^.next_volume_p := NIL;
    new_tape_p^.next_tape_p := NIL;

    IF tape_list_p = NIL THEN
      tape_list_p := new_tape_p;
    ELSE
      tape_p^.next_tape_p := new_tape_p;
    IFEND;
    tape_p := new_tape_p;

    tape_info.number_of_tapes := tape_info.number_of_tapes + 1;
    tape_info.number_of_primary_tapes := tape_info.number_of_primary_tapes + 1;

  PROCEND start_assignment_to_tape;

?? TITLE := 'write_disk_order_data_file', EJECT ??

{ PURPOSE:
{   This procedure writes the order data file into the order catalog for disk
{   orders.
{
{ DESIGN:
{   The order data file contains information used in the writing of the order by
{   WRITE_ORDER.  The order data file is a text file that when "included" will
{   create SCL variables containing order data.
{
{   The file has two parts; a SCL variable declarations part and a SCL variable
{   initializations part.
{
{ NOTES:
{
{

  PROCEDURE write_disk_order_data_file
    (    packing_list_header_p: ^rat$packing_list_header;
         contents_list_p: ^rat$order_contents_list;
         disk_subproduct_indexer_p: ^rat$disk_subproduct_indexer;
         order_catalog_ref_p: ^fst$file_reference;
     VAR status: ost$status);


    VAR
      file_opened: boolean,
      local_status: ost$status,
      order_data_file_id: amt$file_identifier,
      order_data_file_ref_p: ^fst$file_reference;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   If the file has been opened, it will be closed before the
{   the procedure returns.
{
{ NOTES:
{
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF file_opened THEN
        fsp$close_file (order_data_file_id, ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    file_opened := FALSE;

    rap$add_name_to_path_ref (order_catalog_ref_p, rac$order_data_file_name,
          rav$creod_scratch_segment.sequence_p, order_data_file_ref_p);

    rap$open_file (order_data_file_ref_p, amc$record, fsc$modify, TRUE, NIL, order_data_file_id, file_opened,
          status);
    IF NOT status.normal THEN
      file_opened := FALSE;
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

  /write_file/
    BEGIN

      write_disk_scl_declarations (packing_list_header_p, disk_subproduct_indexer_p, order_data_file_id,
            status);
      IF NOT status.normal THEN
        EXIT /write_file/;
      IFEND;

      write_disk_scl_initializations (contents_list_p, disk_subproduct_indexer_p, order_data_file_id, status);

    END /write_file/;

    IF file_opened THEN
      fsp$close_file (order_data_file_id, local_status);
      file_opened := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND write_disk_order_data_file;

?? TITLE := 'write_disk_scl_declarations', EJECT ??

{ PURPOSE:
{   This procedure writes the SCL variable declaration lines for a disk order.
{
{ DESIGN:
{   The declaration lines are constructed and put to the order data file using
{   a local procedure.  The status is checked within the local procedure to limit
{   the number of times it has to be checked in the main procedure.
{
{ NOTES:
{

  PROCEDURE write_disk_scl_declarations
    (    packing_list_header_p: ^rat$packing_list_header;
         disk_subproduct_indexer_p: ^rat$disk_subproduct_indexer;
         order_data_file_id: amt$file_identifier;
     VAR status: ost$status);


    VAR
      date_defined: ost$date,
      ignore_byte_address: amt$file_byte_address,
      order_type: ost$name,
      packing_list_name: [STATIC] ost$name := rac$packing_list_name,
      sif_file_name: [STATIC] ost$name := rac$sif_file_name,
      subproduct_count: integer;

?? NEWTITLE := 'format', EJECT ??

{ PURPOSE:
{   This procedure writes an initial string and a boolean, integer, or string
{   to a file.
{
{ DESIGN:
{   If the pointer to the boolean, string, or integer is not NIL, the initial
{   string and the boolean, string, or integer is written to the file.
{
{ NOTES:
{   Status is checked at the beginning of this procedure to determine if the
{   command should be completed.  This was done to limit the status check to
{   one place rather than after each call to this procedure in the main procedure.
{
{

    PROCEDURE write_formatted_line
      (    initial_string: string ( * );
           boolean_p: ^boolean;
           integer_p: ^integer;
           string_p: ^string ( * );
           closing_string: string ( * ));

      VAR
        length: integer,
        output_line: string (osc$max_string_size);


      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF boolean_p <> NIL THEN
        STRINGREP (output_line, length, initial_string, boolean_p^, closing_string);
      ELSEIF integer_p <> NIL THEN
        STRINGREP (output_line, length, initial_string, integer_p^, closing_string);
      ELSEIF string_p <> NIL THEN
        STRINGREP (output_line, length, initial_string, string_p^, closing_string);
      ELSE
        STRINGREP (output_line, length, initial_string, closing_string);
      IFEND;

      amp$put_next (order_data_file_id, ^output_line, length, ignore_byte_address, status);

    PROCEND write_formatted_line;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    pmp$get_date (osc$ordinal_date, date_defined, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    order_type := rav$subproduct_type [packing_list_header_p^.order_type];
    subproduct_count := UPPERBOUND (disk_subproduct_indexer_p^);

    write_formatted_line ('" The following variable declarations are critical to the "', NIL, NIL, NIL, '');
    write_formatted_line ('" writing of the order they define.  It is very important "', NIL, NIL, NIL, '');
    write_formatted_line ('" that these values are not modified.                     "', NIL, NIL, NIL, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');
    write_formatted_line ('VAR                                           ', NIL, NIL, NIL, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');

    write_formatted_line ('  order_identifier: name = ', NIL, NIL, ^packing_list_header_p^.order_identifier,
          '');
    write_formatted_line ('  order_type: name = ', NIL, NIL, ^order_type, '');
    write_formatted_line ('  date_defined: string 7 = ''', NIL, NIL, ^date_defined.ordinal, '''');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');

    write_formatted_line ('  packing_list_name: name = ', NIL, NIL, ^packing_list_name, '');
    write_formatted_line ('  sif_file_name: name = ', NIL, NIL, ^sif_file_name, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');

    write_formatted_line ('  order_medium: name = DISK', NIL, NIL, NIL, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');

    write_formatted_line ('  disk_backup_catalog: file = ', NIL, NIL,
          ^packing_list_header_p^.disk_backup_catalog (1, clp$trimmed_string_size
          (packing_list_header_p^.disk_backup_catalog)), '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');


    write_formatted_line ('  subproducts: array 1..', NIL, ^subproduct_count, NIL, ' of RECORD');
    write_formatted_line ('      name: name                              ', NIL, NIL, NIL, '');
    write_formatted_line ('      level: name                             ', NIL, NIL, NIL, '');
    write_formatted_line ('      licensed_product: name                  ', NIL, NIL, NIL, '');
    write_formatted_line ('      type: name                              ', NIL, NIL, NIL, '');
    write_formatted_line ('      pacs_catalog: file                      ', NIL, NIL, NIL, '');
    write_formatted_line ('      auto_install: boolean                   ', NIL, NIL, NIL, '');
    write_formatted_line ('      backup_file: name                       ', NIL, NIL, NIL, '');
    write_formatted_line ('      sif_identifier: name                    ', NIL, NIL, NIL, '');
    write_formatted_line ('    RECEND                                    ', NIL, NIL, NIL, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');
    write_formatted_line ('VAREND                                        ', NIL, NIL, NIL, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');

  PROCEND write_disk_scl_declarations;

?? TITLE := 'write_disk_scl_initializations', EJECT ??

{ PURPOSE:
{   This procedure writes the SCL variable initialization lines for a disk
{   order.
{
{ DESIGN:
{   Lines are added to the order data file to initialize an SCL variable array
{   that contains subproduct information.
{
{   The lines are constructed into a data array and then written to EOI of the
{   order data file.
{
{ NOTES:
{   The contents list contains an item for the packing list.  The SCL variable
{   being initialized is for subproduct information, therefore the packing list
{   item is excluded.  The packing list is assumed to be the first item in the
{   order contents list.  The "[i - 1]" indexing adjusts for this fact.
{

  PROCEDURE write_disk_scl_initializations
    (    contents_list_p: ^rat$order_contents_list;
         disk_subproduct_indexer_p: ^rat$disk_subproduct_indexer;
         order_data_file_id: amt$file_identifier;
     VAR status: ost$status);


    VAR
      data: array [1 .. 9] of rat$string,
      i: integer,
      ignore_byte_address: amt$file_byte_address,
      j: integer,
      subproduct_type: ost$name;

    status.normal := TRUE;

    FOR i := rac$first_subproduct_entry TO UPPERBOUND (contents_list_p^) DO
      subproduct_type := rav$subproduct_type [contents_list_p^ [i].subproduct_type];

      STRINGREP (data [1].value, data [1].length, '     ');
      STRINGREP (data [2].value, data [2].length, 'subproducts(', (i - 1), ').name = ',
            contents_list_p^ [i].name);
      STRINGREP (data [3].value, data [3].length, 'subproducts(', (i - 1), ').level = ',
            contents_list_p^ [i].level);
      STRINGREP (data [4].value, data [4].length, 'subproducts(', (i - 1), ').licensed_product = ',
            contents_list_p^ [i].licensed_product);
      STRINGREP (data [5].value, data [5].length, 'subproducts(', (i - 1), ').type = ', subproduct_type);
      STRINGREP (data [6].value, data [6].length, 'subproducts(', (i - 1), ').pacs_catalog = ',
            contents_list_p^ [i].pacs_catalog.path (1, contents_list_p^ [i].pacs_catalog.size));
      STRINGREP (data [7].value, data [7].length, 'subproducts(', (i - 1), ').auto_install = ',
            contents_list_p^ [i].auto_install);
      STRINGREP (data [8].value, data [8].length, 'subproducts(', (i - 1), ').backup_file = ',
            disk_subproduct_indexer_p^ [i - 1].backup_file);
      STRINGREP (data [9].value, data [9].length, 'subproducts(', (i - 1), ').sif_identifier = ',
            contents_list_p^ [i].sif_identifier);

      FOR j := 1 TO UPPERBOUND (data) DO
        amp$put_next (order_data_file_id, ^data [j].value, data [j].length, ignore_byte_address, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    FOREND;

  PROCEND write_disk_scl_initializations;

?? TITLE := 'write_packing_list', EJECT ??

{ PURPOSE:
{   This procedure writes the PACKING LIST sequence to a permanent file in the
{   order catalog.
{
{ DESIGN:
{   A permanent file is opened in write mode and the SIF sequence in memory is
{   transferred to the permanent file.
{
{ NOTES:
{   The assumption is made that the current position pointer in the packing list
{   is at end of sequence.
{
{   In variable naming, 'P_LIST' is used as a short form for packing list.
{

  PROCEDURE write_packing_list
    (    order_catalog_ref_p: ^fst$file_reference;
     VAR packing_list_sequence_p: ^rat$packing_list_sequence;
     VAR status: ost$status);


    VAR
      file_opened: boolean,
      local_status: ost$status,
      packing_list_file_id: amt$file_identifier,
      packing_list_file_ref_p: ^fst$file_reference,
      packing_list_file_segment_p: amt$segment_pointer,
      packing_list_file_seq_p: ^SEQ ( * ),
      packing_list_seq_p: ^SEQ ( * ),
      packing_list_sequence_size: integer;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF file_opened THEN
        fsp$close_file (packing_list_file_id, ignore_status);
        file_opened := FALSE;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    file_opened := FALSE;

    rap$add_name_to_path_ref (order_catalog_ref_p, rac$packing_list_name,
          rav$creod_scratch_segment.sequence_p, packing_list_file_ref_p);

    rap$open_file (packing_list_file_ref_p, amc$segment, fsc$modify, TRUE, NIL, packing_list_file_id,
          file_opened, status);
    IF NOT status.normal THEN
      file_opened := FALSE;
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

  /write_file/
    BEGIN

      amp$get_segment_pointer (packing_list_file_id, amc$sequence_pointer, packing_list_file_segment_p,
            status);
      IF NOT status.normal THEN
        EXIT /write_file/;
      IFEND;

      packing_list_sequence_size := i#current_sequence_position (packing_list_sequence_p);

      RESET packing_list_sequence_p;
      NEXT packing_list_seq_p: [[REP packing_list_sequence_size OF cell]] IN packing_list_sequence_p;
      IF packing_list_seq_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
        RETURN;
      IFEND;

      RESET packing_list_file_segment_p.sequence_pointer;
      NEXT packing_list_file_seq_p: [[REP packing_list_sequence_size OF cell]] IN
            packing_list_file_segment_p.sequence_pointer;
      IF packing_list_file_seq_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
        RETURN;
      IFEND;

      packing_list_file_seq_p^ := packing_list_seq_p^;

      amp$set_segment_eoi (packing_list_file_id, packing_list_file_segment_p, status);

    END /write_file/;

    IF file_opened THEN
      fsp$close_file (packing_list_file_id, local_status);
      file_opened := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND write_packing_list;

?? TITLE := 'write_tape_order_data_file', EJECT ??

{ PURPOSE:
{   This procedure writes the order data file into the order catalog for tape
{   orders.
{
{ DESIGN:
{   The order data file contains information used in the writing of the order by
{   WRITE_ORDER.  The order data file is a text file that when "included" will
{   create SCL variables containing order data.
{
{   The file has two parts; a SCL variable declarations part and a SCL variable
{   initializations part.
{
{ NOTES:
{

  PROCEDURE write_tape_order_data_file
    (    packing_list_header_p: ^rat$packing_list_header;
         contents_list_p: ^rat$order_contents_list;
         tape_info: rat$tape_information;
         tape_list_p: ^rat$primary_tape;
         order_catalog_ref_p: ^fst$file_reference;
     VAR status: ost$status);


    VAR
      file_opened: boolean,
      local_status: ost$status,
      order_data_file_id: amt$file_identifier,
      order_data_file_ref_p: ^fst$file_reference;


?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      IF file_opened THEN
        fsp$close_file (order_data_file_id, ignore_status);
        file_opened := FALSE;
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;
    file_opened := FALSE;

    rap$add_name_to_path_ref (order_catalog_ref_p, rac$order_data_file_name,
          rav$creod_scratch_segment.sequence_p, order_data_file_ref_p);

    rap$open_file (order_data_file_ref_p, amc$record, fsc$modify, TRUE, NIL, order_data_file_id, file_opened,
          status);
    IF NOT status.normal THEN
      file_opened := FALSE;
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^abort_handler);

  /write_file/
    BEGIN

      write_tape_scl_declarations (packing_list_header_p, tape_info, tape_list_p, contents_list_p,
            order_data_file_id, status);
      IF NOT status.normal THEN
        EXIT /write_file/;
      IFEND;

      write_tape_scl_initializations (tape_info, tape_list_p, contents_list_p, order_data_file_id, status);

    END /write_file/;

    IF file_opened THEN
      fsp$close_file (order_data_file_id, local_status);
      file_opened := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND write_tape_order_data_file;

?? TITLE := 'write_tape_scl_declarations', EJECT ??

{ PURPOSE:
{   This procedure writes the SCL variable declaration lines for a tape order.
{
{ DESIGN:
{   The declaration lines are constructed and put to the order data file using
{   a local procedure.  The status is checked within the local procedure to limit
{   the number of times it has to be checked in the main procedure.
{
{ NOTES:
{

  PROCEDURE write_tape_scl_declarations
    (    packing_list_header_p: ^rat$packing_list_header;
         tape_info: rat$tape_information;
         tape_list_p: ^rat$primary_tape;
         contents_list_p: ^rat$order_contents_list;
         order_data_file_id: amt$file_identifier;
     VAR status: ost$status);


    VAR
      date_defined: ost$date,
      ignore_byte_address: amt$file_byte_address,
      order_type: ost$name,
      packing_list_name: [STATIC] ost$name := rac$packing_list_name,
      percent_usable: integer,
      primary_vsns: rat$string,
      sif_file_name: [STATIC] ost$name := rac$sif_file_name,
      subproduct_count: integer;


?? NEWTITLE := 'format', EJECT ??

{ PURPOSE:
{   This procedure writes an initial string and a boolean, integer, or string
{   to a file.
{
{ DESIGN:
{   If the pointer to the boolean, string, or integer is not NIL, the initial
{   string and the boolean, string, or integer is written to the file.
{
{ NOTES:
{   Status is checked at the beginning of this procedure to determine if the
{   command should be completed.  This was done to limit the status check to
{   one place rather than after each call to this procedure in the main procedure.
{
{

    PROCEDURE write_formatted_line
      (    initial_string: string ( * );
           boolean_p: ^boolean;
           integer_p: ^integer;
           string_p: ^string ( * );
           closing_string: string ( * ));

      VAR
        length: integer,
        output_line: string (osc$max_string_size);


      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF boolean_p <> NIL THEN
        STRINGREP (output_line, length, initial_string, boolean_p^, closing_string);
      ELSEIF integer_p <> NIL THEN
        STRINGREP (output_line, length, initial_string, integer_p^, closing_string);
      ELSEIF string_p <> NIL THEN
        STRINGREP (output_line, length, initial_string, string_p^, closing_string);
      ELSE
        STRINGREP (output_line, length, initial_string, closing_string);
      IFEND;

      amp$put_next (order_data_file_id, ^output_line, length, ignore_byte_address, status);

    PROCEND write_formatted_line;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    pmp$get_date (osc$ordinal_date, date_defined, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    order_type := rav$subproduct_type [packing_list_header_p^.order_type];

    percent_usable := tape_info.percent_usable;
    subproduct_count := UPPERBOUND (contents_list_p^) - 1;

    create_scl_primary_vsn_list (tape_list_p, primary_vsns);

    write_formatted_line ('" The following variable declarations are critical to the "', NIL, NIL, NIL, '');
    write_formatted_line ('" writing of the order they define.  It is very important "', NIL, NIL, NIL, '');
    write_formatted_line ('" that these values are not modified.  The one exception  "', NIL, NIL, NIL, '');
    write_formatted_line ('" is the TAPE''s EVSN field.                              "', NIL, NIL, NIL, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');
    write_formatted_line ('VAR                                           ', NIL, NIL, NIL, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');

    write_formatted_line ('  order_identifier: name = ', NIL, NIL, ^packing_list_header_p^.order_identifier,
          '');
    write_formatted_line ('  order_type: name = ', NIL, NIL, ^order_type, '');
    write_formatted_line ('  date_defined: string 7 = ''', NIL, NIL, ^date_defined.ordinal, '''');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');

    write_formatted_line ('  packing_list_name: name = ', NIL, NIL, ^packing_list_name, '');
    write_formatted_line ('  sif_file_name: name = ', NIL, NIL, ^sif_file_name, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');

    write_formatted_line ('  order_medium: name = TAPE', NIL, NIL, NIL, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');

    write_formatted_line ('  tape_type: name = ', NIL, NIL, ^tape_info.tape_type, '');
    write_formatted_line ('  percent_usable_tape: integer 1..100 = ', NIL, ^percent_usable, NIL, '');
    write_formatted_line ('  number_of_tapes: integer = ', NIL, ^tape_info.number_of_tapes, NIL, '');
    write_formatted_line ('  number_of_primary_tapes: integer = ', NIL, ^tape_info.number_of_primary_tapes,
          NIL, '');
    write_formatted_line ('  number_of_multi_vol_sets: integer = ', NIL, ^tape_info.number_of_multi_vol_sets,
          NIL, '');
    write_formatted_line ('  number_of_tapes_theoretical: integer = ', NIL,
          ^tape_info.number_of_tapes_theoretical, NIL, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');

    write_formatted_line ('  primary_vsns: list 1..', NIL, ^tape_info.number_of_primary_tapes, NIL,
          ' of string 1..6 = ..');
    write_formatted_line ('    ', NIL, NIL, ^primary_vsns.value (1, primary_vsns.length), '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');

    write_formatted_line ('  tapes: array 1..', NIL, ^tape_info.number_of_primary_tapes, NIL, ' of RECORD');
    write_formatted_line ('      evsn: list of string 1..6               ', NIL, NIL, NIL, '');
    write_formatted_line ('      rvsn: list of string 1..6               ', NIL, NIL, NIL, '');
    write_formatted_line ('      size: list of integer                   ', NIL, NIL, NIL, '');
    write_formatted_line ('      usable_length: list of integer          ', NIL, NIL, NIL, '');
    write_formatted_line ('      length_assigned: list of integer        ', NIL, NIL, NIL, '');
    write_formatted_line ('      subproducts_index_lowerbound: integer   ', NIL, NIL, NIL, '');
    write_formatted_line ('      subproducts_index_upperbound: integer   ', NIL, NIL, NIL, '');
    write_formatted_line ('    RECEND                                    ', NIL, NIL, NIL, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');

    write_formatted_line ('  subproducts: array 1..', NIL, ^subproduct_count, NIL, ' of RECORD');
    write_formatted_line ('      name: name                              ', NIL, NIL, NIL, '');
    write_formatted_line ('      level: name                             ', NIL, NIL, NIL, '');
    write_formatted_line ('      licensed_product: name                  ', NIL, NIL, NIL, '');
    write_formatted_line ('      type: name                              ', NIL, NIL, NIL, '');
    write_formatted_line ('      pacs_catalog: file                      ', NIL, NIL, NIL, '');
    write_formatted_line ('      auto_install: boolean              ', NIL, NIL, NIL, '');
    write_formatted_line ('      tape_index: integer                     ', NIL, NIL, NIL, '');
    write_formatted_line ('      sif_identifier: name                    ', NIL, NIL, NIL, '');
    write_formatted_line ('    RECEND                                    ', NIL, NIL, NIL, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');
    write_formatted_line ('VAREND                                        ', NIL, NIL, NIL, '');
    write_formatted_line ('                                              ', NIL, NIL, NIL, '');

  PROCEND write_tape_scl_declarations;

?? TITLE := 'write_tape_scl_initializations', EJECT ??

{ PURPOSE:
{   This procedure writes the SCL variable initialization lines for a tape
{   order.
{
{ DESIGN:
{   Lines are added to the order data file to initialize two SCL variable
{   arrays.  The first is for tape information.  The second is for subproduct
{   information.  The two SCL variables have fields that "tie" them together.
{
{   The lines are constructed into a data array and then written to EOI of the
{   order data file.
{
{ NOTES:
{   The contents list contains an item for the packing list.  The SCL variable
{   being initialized for the subproducts does not include the packing list item.
{   The packing list is assumed to be the first item in the order contents
{   list.  The "[i - 1]" indexing adjusts for this fact.
{

  PROCEDURE write_tape_scl_initializations
    (    tape_info: rat$tape_information;
         tape_list_p: ^rat$primary_tape;
         contents_list_p: ^rat$order_contents_list;
         order_data_file_id: amt$file_identifier;
     VAR status: ost$status);


    VAR
      additional_vol_p: ^rat$additional_volume,
      assigned: rat$string,
      assignment_range_lowerbound: integer,
      tape_data: array [1 .. 8] of rat$string,
      subproduct_data: array [1 .. 9] of rat$string,
      evsn: rat$string,
      i: integer,
      ignore_byte_address: amt$file_byte_address,
      j: integer,
      rvsn: rat$string,
      size: rat$string,
      subproduct_type: ost$name,
      tape_indexes_p: ^array [ * ] of integer,
      tape_p: ^rat$primary_tape,
      usable: rat$string;


    status.normal := TRUE;

    PUSH tape_indexes_p: [1 .. UPPERBOUND (contents_list_p^)];
    IF tape_indexes_p = NIL THEN
      osp$set_status_abnormal ('RA', rae$accessed_beyond_memory_seg, '', status);
      RETURN;
    IFEND;

    i := 1;
    tape_p := tape_list_p;

    WHILE tape_p <> NIL DO

      create_scl_tape_data_lists (tape_p, tape_info.tape_type, assigned, evsn, rvsn, size, usable);

      STRINGREP (tape_data [1].value, tape_data [1].length, '     ');
      STRINGREP (tape_data [2].value, tape_data [2].length, 'tapes(', i, ').evsn = ', evsn.
            value (1, evsn.length));
      STRINGREP (tape_data [3].value, tape_data [3].length, 'tapes(', i, ').rvsn = ', rvsn.
            value (1, rvsn.length));
      STRINGREP (tape_data [4].value, tape_data [4].length, 'tapes(', i, ').size = ', size.
            value (1, size.length));
      STRINGREP (tape_data [5].value, tape_data [5].length, 'tapes(', i, ').usable_length = ', usable.
            value (1, usable.length));
      STRINGREP (tape_data [6].value, tape_data [6].length, 'tapes(', i, ').length_assigned = ',
            assigned.value (1, assigned.length));

      IF tape_p^.assignment_range_lowerbound = 1 THEN

{ Adjust lowerbound to skip over the packing list.

        assignment_range_lowerbound := rac$first_subproduct_entry;
      ELSE
        assignment_range_lowerbound := tape_p^.assignment_range_lowerbound;
      IFEND;

      STRINGREP (tape_data [7].value, tape_data [7].length, 'tapes(', i, ').subproducts_index_lowerbound = ',
            (assignment_range_lowerbound - 1));
      STRINGREP (tape_data [8].value, tape_data [8].length, 'tapes(', i, ').subproducts_index_upperbound = ',
            (tape_p^.assignment_range_upperbound - 1));

      FOR j := 1 TO UPPERBOUND (tape_data) DO
        amp$put_next (order_data_file_id, ^tape_data [j].value, tape_data [j].length, ignore_byte_address,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

      FOR j := tape_p^.assignment_range_lowerbound TO tape_p^.assignment_range_upperbound DO
        tape_indexes_p^ [j] := i;
      FOREND;

      i := i + 1;
      tape_p := tape_p^.next_tape_p;
    WHILEND;


    FOR i := rac$first_subproduct_entry TO UPPERBOUND (contents_list_p^) DO
      subproduct_type := rav$subproduct_type [contents_list_p^ [i].subproduct_type];

      STRINGREP (subproduct_data [1].value, subproduct_data [1].length, '     ');
      STRINGREP (subproduct_data [2].value, subproduct_data [2].length, 'subproducts(', (i - 1), ').name = ',
            contents_list_p^ [i].name);
      STRINGREP (subproduct_data [3].value, subproduct_data [3].length, 'subproducts(', (i - 1), ').level = ',
            contents_list_p^ [i].level);
      STRINGREP (subproduct_data [4].value, subproduct_data [4].length, 'subproducts(', (i - 1),
            ').licensed_product = ', contents_list_p^ [i].licensed_product);
      STRINGREP (subproduct_data [5].value, subproduct_data [5].length, 'subproducts(', (i - 1), ').type = ',
            subproduct_type);
      STRINGREP (subproduct_data [6].value, subproduct_data [6].length, 'subproducts(', (i - 1),
            ').pacs_catalog = ', contents_list_p^ [i].pacs_catalog.
            path (1, contents_list_p^ [i].pacs_catalog.size));
      STRINGREP (subproduct_data [7].value, subproduct_data [7].length, 'subproducts(', (i - 1),
            ').auto_install = ', contents_list_p^ [i].auto_install);
      STRINGREP (subproduct_data [8].value, subproduct_data [8].length, 'subproducts(', (i - 1),
            ').tape_index = ', tape_indexes_p^ [i]);
      STRINGREP (subproduct_data [9].value, subproduct_data [9].length, 'subproducts(', (i - 1),
            ').sif_identifier = ', contents_list_p^ [i].sif_identifier);

      FOR j := 1 TO UPPERBOUND (subproduct_data) DO
        amp$put_next (order_data_file_id, ^subproduct_data [j].value, subproduct_data [j].
              length, ignore_byte_address, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    FOREND;

  PROCEND write_tape_scl_initializations;

MODEND ram$write_definition;

*DECK DECK=RAM$WRITE_FILE_FROM_MEMORY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: RAP$WRITE_FILE_FROM_MEMORY Interface.' ??
MODULE ram$write_file_from_memory;

{ PURPOSE:
{   This module contains the interface and procedures to write a file
{   from a sequence in memory.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$install_software_cc
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$write_file_from_memory', EJECT ??

{ PURPOSE:
{   This interface creates a file and then copies the contents for the file
{   from a memory sequence.
{
{ DESIGN:
{   The memory sequence is copied to the specified file.
{
{ NOTES:
{

  PROCEDURE [XDCL] rap$write_file_from_memory
    (    file: fst$file_reference;
         memory_seq_size: integer;
     VAR memory_seq_p {input} : ^SEQ ( * );
     VAR status: ost$status);


    VAR
      attachment_options: array [1 .. 3] of fst$attachment_option,
      file_contents_p: ^SEQ ( * ),
      file_fid: amt$file_identifier,
      file_opened: boolean,
      local_status: ost$status,
      memory_seq_contents_p: ^SEQ ( * ),
      segment_pointer: amt$segment_pointer;


?? NEWTITLE := 'abort_handler', EJECT ??

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs within the
{   block structure.
{
{ DESIGN:
{   The function of this condition handler is to close the file when an
{   abort condition arises.
{
{ NOTES:
{

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      fsp$close_file (file_fid, ignore_status);

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??


    status.normal := TRUE;

    attachment_options [1].selector := fsc$access_and_share_modes;
    attachment_options [1].access_modes.selector := fsc$specific_access_modes;
    attachment_options [1].access_modes.value := $fst$file_access_options
          [fsc$read, fsc$shorten, fsc$append, fsc$modify];
    attachment_options [1].share_modes.selector := fsc$determine_from_access_modes;
    attachment_options [2].selector := fsc$create_file;
    attachment_options [2].create_file := TRUE;
    attachment_options [3].selector := fsc$wait_for_attachment;
    attachment_options [3].wait_for_attachment.wait := osc$wait;
    attachment_options [3].wait_for_attachment.wait_time := fsc$longest_wait_time;


    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      file_opened := TRUE;
      fsp$open_file (file, amc$segment, ^attachment_options, NIL, NIL, NIL, NIL, file_fid, status);
      IF NOT status.normal THEN
        file_opened := FALSE;
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (file_fid, amc$sequence_pointer, segment_pointer, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      { Establish pointers to the memory and file contents as the size of the memory sequence.

      RESET memory_seq_p;
      NEXT memory_seq_contents_p: [[REP memory_seq_size OF cell]] IN memory_seq_p;
      IF memory_seq_contents_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'MEMORY SEQUENCE', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'CONTENTS', status);
        EXIT /main/;
      IFEND;

      RESET segment_pointer.sequence_pointer;
      NEXT file_contents_p: [[REP memory_seq_size OF cell]] IN segment_pointer.sequence_pointer;
      IF file_contents_p = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment_eoi, 'FILE', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'CONTENTS', status);
        EXIT /main/;
      IFEND;

      { Copy the processing sequence to the installation control file.

      file_contents_p^ := memory_seq_contents_p^;

      amp$set_segment_eoi (file_fid, segment_pointer, status);

    END /main/;

    IF file_opened THEN
      fsp$close_file (file_fid, local_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND rap$write_file_from_memory;
MODEND ram$write_file_from_memory;
*DECK DECK=RAM$WRITE_STRINGS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'RAP$WRITE_STRINGS procedure.' ??
MODULE ram$write_strings;

{ PURPOSE:
{   This module contains the procedures to display strings.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$max_line
*copyc ost$status
?? POP ??
*copyc clp$put_partial_display

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$write_strings', EJECT ??

{ PURPOSE:
{   This procedure writes two strings to the output display.
{
{ DESIGN:
{   The two strings are combined into one string and a procedure
{   writes them to output.
{
{ NOTES:
{
{

  PROCEDURE [XDCL] rap$write_strings
    (    string_a: string ( * );
         string_b: string ( * );
         continue_line: boolean;
         indent: 0 .. rac$max_line;
     VAR display_control: clt$display_control;
     VAR display_status: ost$status);


    VAR
      ignore_status: ost$status,
      line: string (osc$max_string_size),
      line_size: integer;


    IF NOT display_status.normal THEN
      RETURN;
    IFEND;

    line := '';
    STRINGREP (line, line_size, string_a, string_b);

    WHILE (line_size + display_control.column_number) > rac$max_line DO
      write_partial_line (indent, line, line_size, display_control);
    WHILEND;

    IF continue_line THEN
      clp$put_partial_display (display_control, line (1, line_size), clc$no_trim, amc$continue,
            ignore_status);
    ELSE
      clp$put_partial_display (display_control, line (1, line_size), clc$no_trim, amc$terminate,
            ignore_status);
    IFEND;

  PROCEND rap$write_strings;

?? OLDTITLE ??
?? NEWTITLE := 'write_partial_line', EJECT ??

{ PURPOSE:
{   This procedure finds a good breaking point for a string and writes the
{   partial string to the display.
{
{ DESIGN:
{   The string is searched for a period or a blank.  The beginning of the line
{   to this break is displayed.
{
{ NOTES:
{
{

  PROCEDURE write_partial_line
    (    indent: 0 .. rac$max_line;
     VAR line: string (osc$max_string_size);
     VAR line_size: integer;
     VAR display_control: clt$display_control);


    VAR
      i: 0 .. rac$max_line,
      ignore_status: ost$status,
      max_line_size: 0 .. rac$max_line,
      partial_line_size: 0 .. rac$max_line,
      temp_line: string (osc$max_string_size);

    partial_line_size := 0;

    IF line_size > rac$max_line THEN
      max_line_size := rac$max_line;
    ELSE
      max_line_size := line_size;
    IFEND;

  /find_partial_line_length/
    FOR i := max_line_size DOWNTO 1 DO
      IF (line (i, 1) = ' ') OR (line (i, 1) = '.') THEN
        partial_line_size := i;
        EXIT /find_partial_line_length/;
      IFEND;
    FOREND /find_partial_line_length/;

    IF partial_line_size <> 0 THEN
      clp$put_partial_display (display_control, line (1, partial_line_size), clc$no_trim, amc$terminate,
            ignore_status);
      line_size := line_size - partial_line_size + indent;
    ELSE
      clp$put_partial_display (display_control, line (1, line_size), clc$no_trim, amc$terminate,
            ignore_status);
      line_size := 0;
    IFEND;

    temp_line := '';
    IF indent <> 0 THEN
      temp_line (1, indent) := '';
    IFEND;
    temp_line (indent + 1, * ) := line (partial_line_size + 1, * );
    line := temp_line;

  PROCEND write_partial_line;

MODEND ram$write_strings;

*DECK DECK=RAM$WRITE_SUBPRODUCT_INFO_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'DEFINE_SUBPRODUCT Subutility: RAP$WRITE_SUBPRODUCT_INFO_FILE Interface.' ??
MODULE ram$write_subproduct_info_file;

{ PURPOSE:
{   This module contains the interface and procedure that writes the
{   subproduct information file.
{
{ DESIGN:
{   The compiled module resides in RAF$LIBRARY.
{
{ NOTES:
{   **What do we do about the main title above?  This interface is also
{     called by CREATE_SUBPRODUCT_CORRECTION utility.
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rac$sif_file_name
*copyc rae$package_software_cc
*copyc rat$path
*copyc rat$subproduct_verify_errors
*copyc rat$subproduct_verify_options
*copyc rat$validation_selections
?? POP ??
*copyc i#current_sequence_position
*copyc osp$append_status_file
*copyc osp$set_status_abnormal
*copyc rap$verify_subproduct
*copyc rap$write_file_from_memory
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] rap$write_subproduct_info_file', EJECT ??

{ PURPOSE:
{   This interface writes the subproduct information file from the
{   subproduct info sequence residing in memory.
{
{ DESIGN:
{   The subproduct information is first verified against the PACS catalog
{   for which it was defined.  How and what is verfied is based on certain
{   criteria.
{
{   The modification date and time and the attributes checksum values stored
{   in the element list are compared with the actual values of the files
{   they define.  Any difference found causes the verification to fail.
{   Verification will stop on first error.
{
{   When contents checksuming is turned on for the subproduct, the contents
{   checksum will be calculated.
{
{   Once verified the subproduct information file is created under the PACS
{   catalog and the sequence copied into it.
{
{ NOTES:
{   **Explain what verify_errors is all about.
{

  PROCEDURE [XDCL] rap$write_subproduct_info_file
    (    pacs_catalog: rat$path;
     VAR subproduct_info_pointers {input} : rat$subproduct_info_pointers;
     VAR status: ost$status);


    VAR
      subproduct_info_file: rat$path,
      validation_selections: rat$validation_selections,
      verify_errors: rat$subproduct_verify_errors,
      verify_options: rat$subproduct_verify_options;


    status.normal := TRUE;
    validation_selections := $rat$validation_selections [rac$loading_cycle_only, rac$no_rings_below_11,
          rac$no_permits];
    verify_errors := $rat$subproduct_verify_errors [];

    IF subproduct_info_pointers.attributes_p^.calculate_contents_checksum THEN
      verify_options := $rat$subproduct_verify_options [rac$calculate_contents_checksum,
            rac$stop_on_first_error, rac$test_attributes_checksum, rac$test_mod_date_time];
    ELSE {do not calculate contents checksum}
      verify_options := $rat$subproduct_verify_options [rac$stop_on_first_error, rac$test_attributes_checksum,
            rac$test_mod_date_time];
    IFEND;

    rap$verify_subproduct (^pacs_catalog.path (1, pacs_catalog.size), validation_selections, FALSE
          {sif present} , verify_options, verify_errors, subproduct_info_pointers, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF verify_errors <> $rat$subproduct_verify_errors [] THEN
      osp$set_status_abnormal ('RA', rae$pacs_does_not_verify, subproduct_info_pointers.attributes_p^.name,
            status);
      osp$append_status_file (osc$status_parameter_delimiter, pacs_catalog.path (1, pacs_catalog.size),
            status);
      RETURN;
    IFEND;

    STRINGREP (subproduct_info_file.path, subproduct_info_file.size, pacs_catalog.path (1, pacs_catalog.size),
          '.', rac$sif_file_name);

    rap$write_file_from_memory (subproduct_info_file.path (1, subproduct_info_file.size),
          i#current_sequence_position (subproduct_info_pointers.subproduct_info_seq_p),
          subproduct_info_pointers.subproduct_info_seq_p, status);

  PROCEND rap$write_subproduct_info_file;
MODEND ram$write_subproduct_info_file;

*DECK DECK=RAM$WRITE_TAILORED_FILE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'Tailored Release Process:  Package Softwate Utility - Write Tailored File command' ??
MODULE ram$write_tailored_file;

{ PURPOSE:
{   This module contains the procedure that writes a tailored file.
{
{ DESIGN:
{
{ NOTES:
{

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$scan_parameter_list
?? POP ??

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

?? TITLE := '[XDCL, #GATE] rap$write_tailored_file', EJECT ??

  PROCEDURE [XDCL, #GATE] rap$write_tailored_file
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);


{ PDT writf_pdt (
{   order_catalog, oc             : file = $required
{   rewrite_vsns, rewrite_vsn, rv : list of string 6 = $optional
{   status                        : var of status = $optional
{   )

?? PUSH (LISTEXT := ON) ??

  VAR
    writf_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^writf_pdt_names, ^writf_pdt_params
      ];

  VAR
    writf_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
      clt$parameter_name_descriptor := [['ORDER_CATALOG', 1], ['OC', 1], ['REWRITE_VSNS', 2], ['REWRITE_VSN',
      2], ['RV', 2], ['STATUS', 3]];

  VAR
    writf_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ ORDER_CATALOG OC }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ REWRITE_VSNS REWRITE_VSN RV }
    [[clc$optional], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 6, 6]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??

    status.normal := TRUE;

    clp$scan_parameter_list ( parameter_list, writf_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$write_tailored_file;
MODEND ram$write_tailored_file;
*DECK DECK=RAM$WRITE_TAPE_MARK EXPAND=TRUE
*DECK DECK=RAM$WRITE_TAPE_MARK_COMMAND EXPAND=TRUE
create_program_description name=(write_tape_mark, writm) sp=clp$_write_tape_mark_command ..
      l=('$system.osf$system_library' osf$task_services_library) tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAP$ACCESS_DIRECTORY_FOR_READ EXPAND=FALSE
  PROCEDURE [XREF] rap$access_directory_for_read
    (    installation_database: rat$path;
     VAR directory_pointers: rat$idb_directory_pointers;
     VAR directory_fid: amt$file_identifier;
     VAR file_opened: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$path
*copyc amt$file_identifier
*copyc rat$idb_directory_pointers
?? POP ??
*DECK DECK=RAP$ACCESS_DIRECTORY_FOR_WRITE EXPAND=FALSE

  PROCEDURE [XREF] rap$access_directory_for_write
    (    installation_database: rat$path;
     VAR directory_segment_pointer: amt$segment_pointer;
     VAR directory_fid: amt$file_identifier;
     VAR directory_file_opened: boolean;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$segment_pointer
*copyc ost$status
*copyc rat$path
?? POP ??
*DECK DECK=RAP$ACKNOWLEDGE_OPERATOR_MSG EXPAND=TRUE
create_command_description name=(acknowledge_operator_message, ackom) ..
      sp=ofp$acknowledge_oper_msg_cmd
*DECK DECK=RAP$ACTIVATE_ARCHIVE_VE EXPAND=TRUE
PROC activate_archive_ve, actav (
  processor_jobs, processor_job, pj, processor, p: list of name or key all = all
  status)

  SYSTEM_OPERATOR_UTILITY capability=system_administration
    create_variable name=arv$activate_processor kind=boolean value=true
    create_variable name=arv$archive_job_file kind=string value=$unique
    create_variable name=arv$archive_job_status kind=status
    create_variable name=arv$archive_system_job_name kind=string
    create_variable name=arv$archive_ve_path kind=string value='$system.archive_ve'
    create_variable name=arv$character_save kind=string
    create_variable name=arv$index kind=integer
    create_variable name=arv$local_status kind=status
    create_variable name=arv$processors_processed kind=string dimension=$set_count(processor) value=' '
    create_variable name=arv$processor_jobs_catalog kind=string value='processor_jobs'
    create_variable name=arv$processor_jobs_list kind=string value=$unique
    create_variable name=arv$processor_jobs_path kind=string value=' '
    create_variable name=arv$processor_job_name_line kind=string value=' '
    create_variable name=arv$processor_job_name kind=string
    create_variable name=arv$processor_job_path kind=string value=' '
    create_variable name=arv$processor_name kind=string value=' '
    create_variable name=arv$processor_name_short kind=string value=' '
    create_variable name=ignore kind=status
    create_command_list_entry $system.osf$operator_command_library p=after status=ignore

    arv$processor_jobs_path = arv$archive_ve_path // '.' // arv$processor_jobs_catalog

    display_catalog catalog=$fname(arv$processor_jobs_path) output=$fname(arv$processor_jobs_list) ..
          status= arv$local_status
    IF NOT arv$local_status.normal THEN
      EXIT procedure WITH arv$local_status
    IFEND

    rewind_file file=$fname(arv$processor_jobs_list)
  activate_archive_ve_jobs: ..
    LOOP
      arv$processor_job_name_line = ' '
      accept_line variable=arv$processor_job_name_line input=$fname(arv$processor_jobs_list//'.$ASIS')
      EXIT activate_archive_ve_jobs WHEN arv$processor_job_name_line = ' '
      IF $substr(arv$processor_job_name_line, 5, 10) <> 'FILE: ARF$' THEN
        CYCLE activate_archive_ve_jobs
      IFEND
      arv$processor_name = $trim($substr(arv$processor_job_name_line, 15, 27))
      arv$processor_job_path = arv$processor_jobs_path // '.ARF$' // arv$processor_name
      arv$character_save = $substr(arv$processor_name, 1, 1)
      arv$processor_name_short = ''
      FOR arv$index = 1 TO $strlen(arv$processor_name) DO
        IF $substr(arv$processor_name, arv$index, 1) = '_' THEN
          arv$processor_name_short = arv$processor_name_short // arv$character_save
          arv$character_save = $substr(arv$processor_name, arv$index+1, 1)
        IFEND
      FOREND
      arv$processor_name_short = arv$processor_name_short // arv$character_save

      IF $specified(processor) AND $string($value(processor)) <> 'ALL' THEN
        arv$activate_processor = false
        FOR arv$index = 1 TO $set_count(processor) DO
          IF ((arv$processor_name_short = $string($value(processor, arv$index))) OR ..
                (arv$processor_name = $string($value(processor, arv$index)))) THEN
            arv$activate_processor = true
            arv$processors_processed(arv$index) = $string($value(processor, arv$index))
          IFEND
        FOREND
      IFEND

    activate_processor_block: ..
      BLOCK

        EXIT activate_processor_block WHEN NOT arv$activate_processor

        arv$processor_job_name = ' '
        include_file file=$fname(arv$processor_job_path) status=arv$local_status
        IF NOT arv$local_status.normal THEN
          display_value arv$local_status
          $system.put_line line=('  Unable to activate Archive/VE processor '//arv$processor_name//..
' because of error.') output=$response
          EXIT activate_processor_block
        IFEND

        IF arv$processor_job_name = ' ' THEN
          $system.put_line line=(' An INCLUDE_FILE command executed on file: ') output=$response
          $system.put_line line=('       '//arv$processor_job_path) output=$response
          arv$archive_system_job_name = ' '
          include_file file=$fname(arv$archive_job_file) status=arv$local_status
          IF NOT arv$local_status.normal THEN
            display_value arv$local_status
            $system.put_line line=('  Unable to execute INCLUDE_FILE command on file: '//..
arv$archive_job_file//' because of error.') output=$response
            EXIT activate_processor_block
          IFEND

          CYCLE activate_archive_ve_jobs
        IFEND

        IF $string($job_status($name(arv$processor_job_name), job_state)) <> 'UNKNOWN' THEN
          IF $string($job_status($name(arv$processor_job_name), job_state)) = 'TERMINATING' THEN
            $system.put_line line=(' Waiting for Archive/VE processor '//arv$processor_job_name//..
' to terminate.') output=$response
            REPEAT
              wait 10*1000
            UNTIL $string($job_status($name(arv$processor_job_name), job_state)) = 'UNKNOWN'
          ELSE
            $system.put_line line=(' Archive/VE processor '//arv$processor_job_name//' is already active.') ..
                  output=$response
            EXIT activate_processor_block
          IFEND
        IFEND

        arv$archive_system_job_name = ' '
        include_file file=$fname(arv$archive_job_file) status=arv$local_status
        IF NOT arv$local_status.normal THEN
          display_value arv$local_status
          $system.put_line line=('  Unable to activate Archive/VE processor '//arv$processor_name//..
' because of error.') output=$response
          EXIT activate_processor_block
        IFEND

        IF arv$archive_job_status.normal THEN
          $system.put_line line=(' Archive/VE processor '//arv$processor_job_name//' activated') ..
                output=$response
          IF arv$archive_system_job_name <> ' ' THEN
            $system.put_line line=('       as System Job '//arv$archive_system_job_name) output=$response
          IFEND
        ELSE
          display_value arv$archive_job_status
          $system.put_line line=(' Unable to activate Archive/VE processor '//arv$processor_name//..
' because of error.') output=$response
        IFEND
        EXIT procedure WITH arv$archive_job_status WHEN NOT arv$archive_job_status.normal

      BLOCKEND activate_processor_block

      detach_file file=$fname(arv$archive_job_file) status=arv$local_status
    LOOPEND activate_archive_ve_jobs

    IF $specified(processor) AND $string($value(processor)) <> 'ALL' THEN
      FOR arv$index = 1 TO $set_count(processor) DO
        IF arv$processors_processed(arv$index) = ' ' THEN
          $system.put_line line=(' Unable to activate Archive/VE processor '//..
$string($value(processor, arv$index))) output=$response
          $system.put_line line=('       because there is no processor job file defined in catalog') ..
                output=$response
          $system.put_line line=('       '//arv$processor_jobs_path) output=$response
        IFEND
      FOREND
    IFEND

    detach_file file=$fname(arv$processor_jobs_list) status=arv$local_status
  END_SYSTEM_OPERATOR_UTILITY

PROCEND activate_archive_ve
*DECK DECK=RAP$ACTIVATE_BTFS EXPAND=TRUE
PROCEDURE activate_btfs (
  load_map, lm: file = $null
  convert_netdata, cn: boolean = false
  file_notification, fn: boolean = false
  job_class, jc: name = system
  protocol_trace, pt: (BY_NAME, ADVANCED) boolean = false
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request activates BTFS.
*IFEND

  VAR
    btf_library: file = $system.batch_device_support.osf$batch_device_support
    local_status: status
    options: name
  VAREND

  IF NOT $file(btf_library, permanent) THEN
    EXIT_PROC WITH $status(false 'AM' ame$file_not_known btf_library 'BTFS_ACTIVATION')
  IFEND

  MANAGE_JOBS
    select_job name=$name('btfs'//$mainframe(id)) job_state=(deferred, queued, initiated) ..
          user_information='Batch Transfer Facility Server (BTFS) for NOS/VE' status=local_status
    IF local_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        EXIT_PROC WITH $status(false 'RA' 0 'An identical BTFS job was found. BTFS will not be activated')
      IFEND
    ELSE
      EXIT_PROC WITH local_status
    IFEND
  QUIT

  IF $specified(load_map) THEN
    options = all
  ELSE
    options = none
  IFEND

  SYSTEM_OPERATOR_UTILITY c=(system_operation, system_administration)

    JOB ujn=$name('btfs'//$mainframe(id)) job_abort_disposition=terminate job_class=job_class ..
          job_destination_usage=ve_local job_execution_ring=6 job_recovery_disposition=terminate ..
          output_disposition=$fname('$system.batch_device_support.btfs_output_'//$mainframe(id)) ..
          substitution_mark='!' user_information='Batch Transfer Facility Server (BTFS) for NOS/VE' ..
          status=local_status

      SYSTEM_OPERATOR_UTILITY c=(system_operation, system_administration)
        VAR
          btfs_job_status: status
          ignore_status: status
          nfv$ntf_convert_netdata: boolean = !convert_netdata!
          nfv$ntf_file_notification: boolean = !file_notification!
          nfv$ntf_log_debug_messages: boolean = !protocol_trace!
        VAREND

        IF !protocol_trace! THEN
          VAR
            nfv$rhf_protocol_trace: (job) string = 'BTFS'
          VAREND
        IFEND

        change_message_level il=full status=ignore_status

        execute_task library=!btf_library! starting_procedure=nfp$btfs_boot load_map=!load_map! ..
              load_map_options=!options! termination_error_level=error status=btfs_job_status

        display_value btfs_job_status
      END_SYSTEM_OPERATOR_UTILITY
    JOBEND
    EXIT_PROC WITH local_status WHEN NOT local_status.normal
  END_SYSTEM_OPERATOR_UTILITY

PROCEND activate_btfs
*DECK DECK=RAP$ACTIVATE_DUAL_STATE_TASKS EXPAND=TRUE
PROCEDURE activate_dual_state_tasks, actdst (
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure activates the dual state tasks.
"
" NOTES:
"   Things to do:  Convert the dual state task activation commands to use the SCL command naming
"   convention.
"   Margins have been turned off (set to 0) until all messages can be properly aligned together.  To
"   turn the margins back on replace the 0's with a 2.
*IFEND


  WHEN any_fault DO
    IF NOT rav$event_message.normal THEN
      $system.put_line ' '//$strrep(rav$event_message) o=$response
      rav$event_message.normal=true
    IFEND
    $system.put_line ' '//$strrep(osv$status) o=$response

    local_status=$status(false, 'RA', rae$errors_occurred_warning, 'ACTIVATE_DUAL_STATE_TASKS')
  WHENEND


*copy rav$margin

  "$FORMAT=OFF
  VAR
    ignore_status: status
    local_status: status
    rav$event_message: (XDCL) status
  VAREND
  "$FORMAT=ON"

  rap$display_message mm=initiation_messages mn=activating_dual_state_tasks m=rav$margin t=$response ..
        status=ignore_status
  rav$margin=rav$margin + 0

  remote_host_output
  remote_host_input
  interactive_executive

  rav$margin=rav$margin - 0

  IF local_status.normal THEN
    rap$display_message mm=initiation_messages mn=dual_state_tasks_activated m=rav$margin t=$response ..
          status=ignore_status
  IFEND

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND activate_dual_state_tasks
*DECK DECK=RAP$ACTIVATE_HISTORY_LOG EXPAND=TRUE
create_command_description name=(activate_history_log, acthl) ..
      sp=clp$activate_job_history
*DECK DECK=RAP$ACTIVATE_JOB_ENVIRONMENT EXPAND=TRUE
PROCEDURE activate_job_environment, actje (
  network_activation, na: boolean = true
  start_hpa, shpa: boolean = true
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure activates system processes which will allow user jobs
"   to execute.
"
" NOTES:
"   Margins have been turned off (set to 0) until all messages can be properly aligned together.  To
"   turn the margins back on replace the 0's with a 2.
*IFEND

*copy rav$margin
*copy rav$system_paths

  "$FORMAT=OFF
  VAR
    rav$event_message: (XDCL) status
    ignore_status: status
    local_status: status
    proc_status: status
  VAREND
  "$FORMAT=ON"

  local_status.normal = true
  proc_status.normal = true

  rap$display_message mm=initiation_messages mn=activating_job_environment m=rav$margin t=$response ..
        status=ignore_status
  rav$margin = rav$margin + 0

  rap$run_initiation_commands icn=job_activation_prolog status=local_status
  IF NOT local_status.normal THEN
    rap$handle_status si=local_status so=proc_status
  IFEND

  $system.include_command 'change_tape_validation validate_tape_access=true enforce_tape_security=false' ..
       status=ignore_status

  rap$establish_job_classes initiate_jobs=true status=local_status
  IF NOT local_status.normal THEN
    rap$handle_status si=local_status so=proc_status
  IFEND

" IF start_hpa THEN
    start_hpa_monitor_job status=local_status
    IF NOT local_status.normal THEN
      rap$handle_status si=local_status so=proc_status
    IFEND
" IFEND

  IF $job(c170_os_type) <> 'NONE' THEN
    activate_dual_state_tasks status=local_status
    IF NOT local_status.normal THEN
      rap$handle_status si=local_status so=proc_status
    IFEND
  IFEND

  IF network_activation THEN
    activate_network status=local_status
    IF NOT local_status.normal THEN
      rap$handle_status si=local_status so=proc_status
    IFEND
  IFEND

  rap$run_initiation_commands icn=job_activation_epilog status=local_status
  IF NOT local_status.normal THEN
    rap$handle_status si=local_status so=proc_status
  IFEND

  rav$margin = rav$margin - 0

  IF proc_status.normal THEN
    rap$display_message mm=initiation_messages mn=job_environment_activated m=rav$margin t=$response ..
          status=ignore_status
  ELSE
    EXIT procedure WITH $status(false, 'RA', rae$errors_occurred_warning, 'ACTIVATE_JOB_ENVIRONMENT')
  IFEND

PROCEND activate_job_environment

*DECK DECK=RAP$ACTIVATE_NAMVE EXPAND=TRUE
PROCEDURE (HIDDEN) rap$activate_namve (
  status)


*IF $variable(rav$proc_doc declared) <> 'UNKNOWN'

" PURPOSE:
"   This procedure activates NAM/VE.
*IFEND


*copy rav$margin

  "$FORMAT=OFF
  VAR
    ignore_status: status
    local_status: status
  VAREND
  "$FORMAT=ON"


  rap$display_message mm=initiation_messages mn=activating_namve m=rav$margin t=$response status=ignore_status


activate_configuration: ..
  BLOCK

    define_system_task name=namve_system_input_task, sp=nap$system_input_task automatic_restart=true ..
          deactivate_task_option=terminate, idle_task_option=ignore tel=warning lm=$null lmo=none dm=off ..
          status=local_status
    IF NOT local_status.normal AND $condition(local_status.condition) <> 'OSE$SYSTEM_TASK_ALREADY_DEFINED' THEN
      EXIT activate_configuration
    IFEND

    define_system_task name=namve_completed_output_task, sp=nap$completed_output_task, ..
          automatic_restart=true deactivate_task_option=terminate idle_task_option=ignore tel=warning ..
          lm=$null lmo=none dm=off status=local_status
    IF NOT local_status.normal AND $condition(local_status.condition) <> 'OSE$SYSTEM_TASK_ALREADY_DEFINED' THEN
      EXIT activate_configuration
    IFEND

    define_system_task name=namve_directory_me sp=nlp$directory_manager automatic_restart=true ..
          deactivate_task_option=terminate idle_task_option=ignore tel=warning lm=$null lmo=none dm=off ..
          status=local_status
    IF NOT local_status.normal AND $condition(local_status.condition) <> 'OSE$SYSTEM_TASK_ALREADY_DEFINED' THEN
      EXIT activate_configuration
    IFEND

    define_system_task name=namve_timer_monitor sp=nlp$monitor_timers automatic_restart=true ..
          deactivate_task_option=terminate idle_task_option=ignore tel=warning lm=$null lmo=none dm=off ..
          status=local_status
    IF NOT local_status.normal AND $condition(local_status.condition) <> 'OSE$SYSTEM_TASK_ALREADY_DEFINED' THEN
      EXIT activate_configuration
    IFEND

    define_system_task name=namve_connection_establisher sp=nap$connection_establish_task ..
          automatic_restart=true deactivate_task_option=terminate idle_task_option=ignore tel=warning ..
          lm=$null lmo=none dm=off status=local_status
    IF NOT local_status.normal AND $condition(local_status.condition) <> 'OSE$SYSTEM_TASK_ALREADY_DEFINED' THEN
      EXIT activate_configuration
    IFEND

    define_system_task name=namve_poll_connections_task sp=nap$am_poll_connections automatic_restart=true ..
          deactivate_task_option=terminate idle_task_option=ignore tel=warning lm=$null lmo=none dm=off ..
          status=local_status
    IF NOT local_status.normal AND $condition(local_status.condition) <> 'OSE$SYSTEM_TASK_ALREADY_DEFINED' THEN
      EXIT activate_configuration
    IFEND

    define_system_task name=intranet_layer_mgmt_task sp=nap$manage_intranet_layer automatic_restart=true ..
          deactivate_task_option=terminate idle_task_option=ignore tel=warning lm=$null lmo=none dm=off ..
          status=local_status
    IF NOT local_status.normal AND $condition(local_status.condition) <> 'OSE$SYSTEM_TASK_ALREADY_DEFINED' THEN
      EXIT activate_configuration
    IFEND

    execute_task sp=nap$initialize_networks tel=warning lm=$null lmo=none dm=off status=local_status
    IF NOT local_status.normal THEN
      IF $condition(local_status.condition) = 'NAE$INITIALIZATION_WARNING' THEN
        put_line $strrep(local_status) o=$response
      ELSE
        EXIT activate_configuration
      IFEND
    IFEND

    activate_system_task task_name=intranet_layer_mgmt_task status=local_status
    IF NOT local_status.normal AND $condition(local_status.condition) <> 'OSE$SYSTEM_TASK_ACTIVE' THEN
      EXIT activate_configuration
    IFEND

    activate_system_task task_name=namve_system_input_task status=local_status
    IF NOT local_status.normal AND $condition(local_status.condition) <> 'OSE$SYSTEM_TASK_ACTIVE' THEN
      EXIT activate_configuration
    IFEND

    activate_system_task task_name=namve_completed_output_task status=local_status
    IF NOT local_status.normal AND $condition(local_status.condition) <> 'OSE$SYSTEM_TASK_ACTIVE' THEN
      EXIT activate_configuration
    IFEND

    activate_system_task task_name=namve_directory_me status=local_status
    IF NOT local_status.normal AND $condition(local_status.condition) <> 'OSE$SYSTEM_TASK_ACTIVE' THEN
      EXIT activate_configuration
    IFEND

    activate_system_task task_name=namve_timer_monitor status=local_status
    IF NOT local_status.normal AND $condition(local_status.condition) <> 'OSE$SYSTEM_TASK_ACTIVE' THEN
      EXIT activate_configuration
    IFEND

    activate_system_task task_name=namve_connection_establisher status=local_status
    IF NOT local_status.normal AND $condition(local_status.condition) <> 'OSE$SYSTEM_TASK_ACTIVE' THEN
      EXIT activate_configuration
    IFEND

    activate_system_task task_name=namve_poll_connections_task status=local_status

  BLOCKEND activate_configuration

  IF local_status.normal OR ($condition(local_status.condition) = 'OSE$SYSTEM_TASK_ACTIVE') THEN
    rap$display_message mm=initiation_messages mn=namve_activated m=rav$margin t=$response ..
          status=ignore_status
  ELSE
    EXIT procedure WITH local_status
  IFEND

PROCEND rap$activate_namve
*DECK DECK=RAP$ACTIVATE_NETWORK EXPAND=TRUE
PROCEDURE activate_network, actn (
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure activates the network by activating NAM/VE and executing the network activation
"   prolog and epilog.
"
" NOTES:
"   One of the restrictions placed on NAM/VE activation is that it cannot occur after the activation of
"   RHFAM because of shared buffer problems.
"   Margins have been turned off (set to 0) until all messages can be properly aligned together.  To
"   turn the margins back on replace the 0's with a 2.
*IFEND


*copy rav$margin
*copy rav$system_paths

  "$FORMAT=OFF
  VAR
    ignore_status: status
    local_status: status
    proc_status: status
    rav$event_message: (XDCL) status
  VAREND
  "$FORMAT=ON"


  IF $substring($string($job(sjn)),12,8) <> 'AAA_0000' THEN
    EXIT procedure WITH $status(FALSE, 'NA', nae$insufficient_privilege)
  IFEND

  local_status.normal=true
  proc_status.normal=true

  rap$display_message mm=initiation_messages mn=activating_network m=rav$margin t=$response ..
        status=ignore_status
  rav$margin=rav$margin + 0

  IF NOT $namve_active THEN
    rap$check_rhfam_for_namve status=local_status
    IF NOT local_status.normal THEN
      rap$handle_status si=local_status so=proc_status
    IFEND
  IFEND

  rap$verify_configuration status=local_status
  IF NOT local_status.normal THEN
    rap$handle_status si=local_status so=proc_status
  IFEND

  IF proc_status.normal THEN
    rap$run_initiation_commands icn=network_activation_prolog status=local_status
    IF NOT local_status.normal THEN
      rap$handle_status si=local_status so=proc_status
    IFEND

    rap$activate_namve status=local_status
    IF NOT local_status.normal THEN
      rap$handle_status si=local_status so=proc_status
    IFEND
  IFEND

  IF $namve_active THEN
    rap$run_initiation_commands icn=network_activation_epilog status=local_status
    IF NOT local_status.normal THEN
      rap$handle_status si=local_status so=proc_status
    IFEND
  IFEND

  rav$margin=rav$margin - 0

  IF proc_status.normal THEN
    rap$display_message mm=initiation_messages mn=network_activated m=rav$margin t=$response ..
          status=ignore_status
  ELSE
    EXIT procedure WITH $status(false, 'RA', rae$errors_occurred_warning, 'ACTIVATE_NETWORK')
  IFEND

PROCEND activate_network


*DECK DECK=RAP$ACTIVATE_NET_CLOCK EXPAND=TRUE
PROC activate_network_clock, actnc (
  maximum_connections, mc : integer 1..1000 = 1000
  status                  : var of status = $optional
  )

    create_variable nav$status kind=status
    create_variable nav$ignore_status kind=status
    create_variable nav$parameter_list kind=string

actnc_block: ..
  BLOCK

    EXIT actnc_block WHEN NOT nav$status.normal

    nav$parameter_list = 'maximum_connections=' // $strrep($value(maximum_connections))

    delete_system_task name=network_clock status=nav$status
    IF NOT nav$status.normal AND ($condition(nav$status.condition) <> 'OSE$SYSTEM_TASK_NOT_DEFINED') THEN
      EXIT actnc_block
    IFEND

    define_system_task name=network_clock l=$system.osf$operator_library_46d m=nam$bound_clock_manager ..
          p=nav$parameter_list automatic_restart=false deactivate_task_option=terminate ..
          idle_task_option=terminate restart_after_idle=true lm=$null lmo=none tel=warning status=nav$status
    EXIT actnc_block WHEN NOT nav$status.normal

    activate_system_task network_clock status=nav$status

  BLOCKEND actnc_block

  IF nav$status.normal THEN
    display_value 'Network clock activated.' o=$response
  IFEND

  EXIT_PROC WITH nav$status WHEN NOT nav$status.normal

PROCEND activate_network_clock
*DECK DECK=RAP$ACTIVATE_NET_FILE_ACCESS EXPAND=TRUE
PROC activate_network_file_access, actnfa (
  file_type, ft           : list of key exception, boot, domain_name_server, dump, library, configuration, ..
                                 load_procedure, terminal_procedure, user_procedure, validation, all = all
  maximum_connections, mc : integer 1..1000 = 1000
  maximum_dumps, md       : integer 0..1000 = 10
  maximum_dump_size, mds  : integer = 16000000
  status                  : var of status = $optional
  )

  create_variable nav$status kind=status
  create_variable nav$ignore_status kind=status
  create_variable nav$parameter_list kind=string

actnfa_block: ..
  BLOCK

    EXIT actnfa_block WHEN NOT nav$status.normal

    nav$parameter_list = 'file_type=('

    FOR nav$set_count = 1 TO $set_count(file_type) DO
      nav$parameter_list = nav$parameter_list // ' ' // $strrep($value(file_type, nav$set_count, 1))
    FOREND

    nav$parameter_list = nav$parameter_list // ') '
    nav$parameter_list = nav$parameter_list // 'maximum_connections=' // $strrep(..
          $value(maximum_connections)) // ' '
    nav$parameter_list = nav$parameter_list // 'maximum_dumps=' // $strrep($value(maximum_dumps)) // ' '
    nav$parameter_list = nav$parameter_list // 'maximum_dump_size=' // $strrep($value(maximum_dump_size))

    delete_system_task name=network_file_access status=nav$status
    IF NOT nav$status.normal AND ($condition(nav$status.condition) <> 'OSE$SYSTEM_TASK_NOT_DEFINED') THEN
      EXIT actnfa_block
    IFEND

    define_system_task name=network_file_access l=$system.osf$operator_library_46d ..
          sp=nap$file_access_me ..
          m=nam$bound_file_access_manager p=nav$parameter_list automatic_restart=false ..
          deactivate_task_option=terminate idle_task_option=terminate restart_after_idle=true lm=$null ..
          lmo=none tel=warning status=nav$status
    EXIT actnfa_block WHEN NOT nav$status.normal

    activate_system_task network_file_access status=nav$status

  BLOCKEND actnfa_block

  IF nav$status.normal THEN
    display_value 'Network file access activated.' o=$response
  IFEND

  EXIT_PROC WITH nav$status WHEN NOT nav$status.normal

PROCEND activate_network_file_access
*DECK DECK=RAP$ACTIVATE_NET_INIT EXPAND=TRUE
PROC activate_network_initializer, actni (
  priority, p             : integer 0..3 = 3
  maximum_connections, mc : integer 1..1000 = 1000
  maximum_dumps, md       : integer 0..1000 = 10
  maximum_dump_size, mds  : integer = 16000000
  status                  : var of status = $optional
  )

  create_variable nav$status kind=status
  create_variable nav$ignore_status kind=status
  create_variable nav$parameter_list kind=string

actni_block: ..
  BLOCK

    EXIT actni_block WHEN NOT nav$status.normal

    nav$parameter_list = 'priority=' // $strrep($value(priority)) // ' '
    nav$parameter_list = nav$parameter_list // 'maximum_connections=' // $strrep(..
          $value(maximum_connections)) // ' '
    nav$parameter_list = nav$parameter_list // 'maximum_dumps=' // $strrep($value(maximum_dumps)) // ' '
    nav$parameter_list = nav$parameter_list // 'maximum_dump_size=' // $strrep($value(maximum_dump_size))

    delete_system_task name=network_initializer status=nav$status
    IF NOT nav$status.normal AND ($condition(nav$status.condition) <> 'OSE$SYSTEM_TASK_NOT_DEFINED') THEN
      EXIT actni_block
    IFEND

    define_system_task name=network_initializer l=$system.osf$operator_library_46d ..
          m=nam$bound_initialization_mgr p=nav$parameter_list automatic_restart=false ..
          deactivate_task_option=terminate idle_task_option=terminate restart_after_idle=true lm=$null ..
          lmo=none tel=warning status=nav$status
    EXIT actni_block WHEN NOT nav$status.normal

    activate_system_task network_initializer status=nav$status

  BLOCKEND actni_block

  IF nav$status.normal THEN
    display_value 'Network initializer activated.' o=$response
  IFEND

  EXIT_PROC WITH nav$status WHEN NOT nav$status.normal

PROCEND activate_network_initializer
*DECK DECK=RAP$ACTIVATE_NET_LOG EXPAND=TRUE
PROC activate_network_log, actnl (
  groups, group, g        : list 1..16, 1..2 of any = ((CATENET,1))
  maximum_connections, mc : integer 1..1000 = 1000
  maximum_log_cycles, mlc : integer 2..999 = 999
  maximum_log_size, mls   : integer or key none = none
  interval, i             : integer 1..1440 or key none = none
  status                  : var of status = $optional
  )

  create_variable nav$status kind=status
  create_variable nav$ignore_status kind=status
  create_variable nav$parameter_list kind=string

actnl_block: ..
  BLOCK

    EXIT actnl_block WHEN NOT nav$status.normal

    nav$parameter_list = 'group=('

    FOR set_count = 1 TO $set_count(group) DO
      nav$parameter_list = nav$parameter_list // '('
      FOR nav$value_count = 1 TO $value_count(group, set_count) DO
        nav$parameter_list = nav$parameter_list // $strrep($value(group, set_count, nav$value_count))
        IF (nav$value_count = $value_count(group, set_count)) AND (set_count = $set_count(group)) THEN
          nav$parameter_list = nav$parameter_list // ')'
        ELSEIF (nav$value_count = $value_count(group, set_count)) AND (set_count < $set_count(group)) THEN
          nav$parameter_list = nav$parameter_list // ') '
        ELSE
          nav$parameter_list = nav$parameter_list // ','
        IFEND
      FOREND
    FOREND

    nav$parameter_list = nav$parameter_list // ') '
    nav$parameter_list = nav$parameter_list // 'maximum_connections=' // $strrep(..
          $value(maximum_connections)) // ' '
    nav$parameter_list = nav$parameter_list // 'maximum_log_cycles=' // $strrep(..
          $value(maximum_log_cycles)) // ' '
    nav$parameter_list = nav$parameter_list // 'maximum_log_size=' // $strrep($value(maximum_log_size)) //..
           ' '
    nav$parameter_list = nav$parameter_list // 'interval=' // $strrep($value(interval))

    delete_system_task name=network_log status=nav$status
    IF NOT nav$status.normal AND ($condition(nav$status.condition) <> 'OSE$SYSTEM_TASK_NOT_DEFINED') THEN
      EXIT actnl_block
    ELSE
      nav$status.normal = true
    IFEND

    FOR set_count = 1 TO $set_count(groups) DO
      value_kind = $value_kind(groups, set_count, 1)
      IF value_kind <> 'NAME' THEN
        nav$status = $status(false, 'NA', nae$invalid_log_group_name, $strrep($value(groups, set_count, 1)))
        EXIT actnl_block
      IFEND
      value_kind = $value_kind(groups, set_count, 2)
      IF value_kind = 'INTEGER' THEN
        priority = $value(groups, set_count, 2)
        IF (priority > 255) OR (priority < 1) THEN
          nav$status = $status(false, 'NA', nae$invalid_log_group_priority, $strrep(priority))
        IFEND
      ELSEIF value_kind = 'UNKNOWN' THEN
        priority = 1
      ELSE
        nav$status = $status(false, 'NA', nae$invalid_log_group_priority, value)
      IFEND
      EXIT actnl_block WHEN NOT nav$status.normal
    FOREND

    define_system_task name=network_log l=$system.osf$operator_library_46d m=nam$bound_log_manager ..
          p=nav$parameter_list automatic_restart=false deactivate_task_option=terminate ..
          idle_task_option=terminate restart_after_idle=true lm=$null lmo=none tel=warning status=nav$status
    EXIT actnl_block WHEN NOT nav$status.normal

    activate_system_task network_log status=nav$status

  BLOCKEND actnl_block

  IF nav$status.normal THEN
    display_value 'Network log activated.' o=$response
  IFEND

  EXIT_PROC WITH nav$status WHEN NOT nav$status.normal

PROCEND activate_network_log
*DECK DECK=RAP$ACTIVATE_NTF EXPAND=TRUE
PROCEDURE activate_ntf (
  automatic_station_name, asn: name = $required
  nodes_list, nl: file = $optional
  load_map, lm: file = $null
  dump_file, df: file = $optional
  job_class, jc: name = system
  notify_after_aborting, naa: boolean = false
  maximum_restart_attempts, maxra: (BY_NAME, ADVANCED) integer 0..65535 = 0
  protocol_trace, pt: (BY_NAME, ADVANCED) boolean = false
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request activates NTF.
*IFEND

  VAR
    abort_file_commands: file = $system.network_transfer_facility.ntf_abort_file_commands
    dump_file_specified : boolean = $specified(dump_file)
    dump_file_value : file = $local.$null
    ignore_status: status
    local_status: status
    mannln_file : file = $system.network_transfer_facility.local_names
    nodes_list_value: file = $local.$null
    ntf_library : file = $system.network_transfer_facility.bound_product
    ntf_log_file : file = $fname('$system.network_transfer_facility.ntf_output_'//$mainframe(id))
    options : name
    scf_library : file = $system.batch_device_support.osf$batch_device_support
  VAREND

  IF $specified(nodes_list) THEN
    nodes_list_value = nodes_list
  IFEND

  IF NOT $file(ntf_library permanent) THEN
    EXIT procedure WITH $status(false 'AM' ame$file_not_known ntf_library 'NTF_ACTIVATION')
  IFEND

  IF NOT $file(scf_library permanent) THEN
    EXIT procedure WITH $status(false 'AM' ame$file_not_known scf_library 'NTF_ACTIVATION')
  IFEND

  MANAGE_JOBS
    select_job name=$name('ntf'//$mainframe(id)) job_state=(deferred, queued, initiated) ..
          user_information='Network Transfer Facility (NTF) for NOS/VE' status=local_status
    IF local_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        EXIT procedure WITH $status(false 'RA' 0 'An identical NTF job was found. NTF will not be activated')
      IFEND
    ELSE
      EXIT procedure WITH local_status
    IFEND
  QUIT

  include_line 'use_ntf_utility;manage_ntf_local_names;quit;quit' status=ignore_status
  create_file_permit mannln_file g=public status=ignore_status

  IF $specified(load_map) THEN
    options = all
  ELSE
    options = none
  IFEND

  IF dump_file_specified THEN
    dump_file_value = dump_file
  IFEND

  IF $file(abort_file_commands permanent) THEN
    REPEAT
      delete_file file=abort_file_commands status=local_status
    UNTIL NOT local_status.normal
  IFEND

  TASK ring=11
COLLECT_TEXT output=abort_file_commands until='** END OF ABORT COMMANDS **' substitution_mark='#' status=local_status

  VAR
    abort_commands_status: status
    dump_file: file = $fname('$system.network_transfer_facility.ntf_dump_'//$date('Y2M2D2')//'_'//$time('H24MMSS'))
  VAREND

  IF #dump_file_specified# THEN
    dump_file = #dump_file_value#
  IFEND

  display_message message=' ' to=job
  display_message message='**** Please write a PSR against NTF/VE and provide' to=job
  display_message message='**** as supporting material a permanent file backup' t=job
  display_message message='**** of catalog $SYSTEM.NETWORK_TRANSFER_FACILITY.' t=job
  display_message message=' ' to=job

"  The following commands will display the abort information
"  through the use of the debugger.

  set_file_attributes dump_file fc=list pf=continuous
  put_line '1***** ABORT DUMP OF NTF' o=dump_file
  change_file_attributes file=dump_file ring_attributes=(6, 11, 11)
  put_line '       '//$date(iso)//' '//$time(millisecond) o=dump_file.$eoi
  put_line '       '//$job(os_version)//' - '//$default_family//' - CYBER '//..
$processor(model_number, 0)//' Serial '//$processor(serial_number, 0) o=dump_file.$eoi
  put_lines ('', ' ***** ENVIRONMENT:', '') output=dump_file.$eoi
  display_debugging_environment display_option=user_address output=dump_file.$eoi
  display_debug_task_status task_number=all output=dump_file.$eoi
  put_lines ('', ' ***** TRACEBACK:', '') output=dump_file.$eoi
  display_call count=all start=1 display_option=all_calls output=dump_file.$eoi
  put_lines ('', ' ***** JOB LOG:', '') output=dump_file.$eoi
  display_log display_option=200 output=dump_file.$eoi
  put_lines ('', ' ***** REGISTERS:', '') output=dump_file.$eoi
  display_register kind=all_program number=all type=hex output=dump_file.$eoi
  put_lines ('', ' ***** STACK FRAMES:', '') output=dump_file.$eoi
  display_stack_frame count=all start=1 display_option=all output=dump_file.$eoi
  put_lines ('', ' ***** STATIC SECTION:', '') output=dump_file.$eoi
  display_memory section=$static module=$name($current_module) byte_offset=0 byte_count=16 repeat_count=all ..
        output=dump_file.$eoi

** END OF ABORT COMMANDS **
    IF NOT local_status.normal THEN
      IF local_status.condition = ame$file_not_known THEN
        local_status=$status(false 'PF' pfe$unknown_permanent_file $string(abort_file_commands))
      IFEND
      EXIT PROCEDURE WITH local_status
    IFEND
  TASKEND

  SYSTEM_OPERATOR_UTILITY c=system_operation
    JOB jn=$name('ntf'//$mainframe(id)) job_abort_disposition=terminate job_class=job_class ..
          job_destination_usage=ve_local job_execution_ring=6 job_recovery_disposition=terminate ..
          output_disposition=ntf_log_file ..
          substitution_mark='!' user_information='Network Transfer Facility (NTF) for NOS/VE' ..
          status=local_status

      VAR
        ignore_status: status
        maximum_restart_attempts: integer = !maximum_restart_attempts!
        ntf_job_status: status
        ntf_log_file: file = !ntf_log_file!
        nfv$notify_after_aborting: (JOB) boolean = !notify_after_aborting!
        nfv$ntf_log_debug_messages: (JOB) boolean = !protocol_trace!
        number_of_restarts: integer = 0
        parameters: string ='automatic_station_name=!automatic_station_name!'
        status_string_value: list of string
      VAREND

      IF !protocol_trace! THEN
        VAR
          nfv$rhf_protocol_trace : (JOB) string = 'BTFC'
        VAREND
      IFEND

      IF !nodes_list_value! <> $null THEN
        parameters = parameters//' nl=!nodes_list_value!'
      IFEND

      change_message_level il=full status=ignore_status

      set_debug_ring ring=6

      SYSTEM_OPERATOR_UTILITY c=system_operation
        REPEAT
          IF number_of_restarts > 0 THEN
            display_message message='*** NTF has aborted with the following status:' to=job

            status_string_value = $string(ntf_job_status)

            FOR EACH status_string_list_element IN status_string_value DO
              display_message message=status_string_list_element to=job
            FOREND

            display_message message='*** Attempting restart #'//$string(number_of_restarts) to=(job, job_message)
            display_message message='*************************' to=job
            display_log o=ntf_log_file do=all
            change_file_attributes ntf_log_file ra=(11, 11, 11)

" A small (7 1/2 second) delay is forced before the next restart attempt. The delay will reduce the impact
" on the system should NTF continuously abort immediately after beginning execution.

            wait time=0-0-0.00:00:07.500
          IFEND

          execute_task library=(!ntf_library!, !scf_library!) ..
                starting_procedure=nfp$network_transfer_facility ..
                abort_file=!abort_file_commands! parameters=parameters ..
                load_map=!load_map! load_map_options=!options! status=ntf_job_status

          number_of_restarts = number_of_restarts + 1
        UNTIL (number_of_restarts > maximum_restart_attempts)
      END_SYSTEM_OPERATOR_UTILITY

      IF $variable(nfv$notify_after_aborting, defined) THEN
        IF nfv$notify_after_aborting THEN
          send_operator_message m='NTF job failed, see '//ntf_log_file oc=system_operator
        IFEND
      IFEND
    JOBEND

    EXIT procedure WITH local_status WHEN NOT local_status.normal
  END_SYSTEM_OPERATOR_UTILITY

PROCEND activate_ntf
*DECK DECK=RAP$ACTIVATE_NTF_MAIL EXPAND=TRUE
PROC activate_ntf_mail (
  control_facility_name, cfn : name = $required
  load_map, lm               : file = $optional
  gateway_node_name, gnn     : any = $optional
  gateway_user_name, gun     : any = $optional
  status                     : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request activates NTF_MAIL if already installed.
*IFEND


  create_variable ignore_status k=status
  create_variable local_status k=status
  create_variable manna_status k=status
  create_variable ntf_library k=string v='$system.network_transfer_facility.bound_product'
  create_variable scf_library k=string v='$system.batch_device_support.osf$batch_device_support'
  create_variable mailbag_file k=string v='$system.mailve.mail.rfc#822_mail_from_mailve'
  create_variable control_facility_name k=string v=$string($value(control_facility_name))
  create_variable gateway_node_name_parm k=string v=' '
  create_variable gateway_user_name_parm k=string v=' '

  IF NOT $file($fname(ntf_library) permanent) THEN
      put_line ('  ',' --ERROR-- Unable to activate: NTF is not installed.') o=$response
      EXIT_PROC
  IFEND

  IF NOT $file($fname(mailbag_file) permanent) THEN
      put_line ('  ',' --ERROR-- Unable to activate: MAIL/VE ARPANET hooks are not installed.') o=$response
      EXIT_PROC
  IFEND

  IF NOT $file($fname(scf_library) permanent) THEN
      put_line ('  ',' --ERROR-- Unable to activate: SCF is not installed.') o=$response
      EXIT_PROC
  IFEND

  $system.osf$command_library.manage_network_applications status=manna_status
  EXIT_PROC WITH manna_status WHEN NOT manna_status.normal

  display_client_status client=osa$network_transfer_fac_client o=$null status=local_status
  include_line 'quit' status=ignore_status
  EXIT_PROC WITH local_status WHEN NOT local_status.normal

  IF $specified(load_map) THEN
    map_file = $string($value(load_map))
    options = 'all'
  ELSE
    map_file = '$null'
    options = 'none'
  IFEND

  IF $specified(gateway_node_name) THEN
    gateway_node_name_parm = ' gateway_node_name='''//$string($value(gateway_node_name))//''' ';
  IFEND;

  IF $specified(gateway_user_name) THEN
    gateway_user_name_parm = ' gateway_user_name='''//$string($value(gateway_user_name))//''' ';
  IFEND;

  delete_system_task name=ntf_mail_client status=local_status
  IF NOT local_status.normal AND ($condition(local_status.condition) <> 'OSE$SYSTEM_TASK_NOT_DEFINED') THEN
    EXIT_PROC WITH local_status
  IFEND

  define_system_task name=ntf_mail_client library=($fname(ntf_library),$fname(scf_library)) ..
        starting_procedure=nfp$begin_ntf_mail_client ..
        parameters='control_facility_name='//control_facility_name//gateway_node_name_parm//..
gateway_user_name_parm  ..
        automatic_restart=false ..
        restart_after_idle=true deactivate_task_option=terminate ..
        idle_task_option=terminate load_map=$fname(map_file) ..
        load_map_options=$name(options) termination_error_level=error ..
        status=local_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

  activate_system_task task_name=ntf_mail_client status=local_status

  EXIT_PROC WITH local_status

PROCEND activate_ntf_mail
*DECK DECK=RAP$ACTIVATE_PRODUCTION_ENVIRON EXPAND=TRUE
PROCEDURE activate_production_environment, actpe, actse (
  network_activation, na: boolean = true
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure executes the sequence of commands required to activate the
"   system for production.  Production activation may include installation
"   of software.
"
" NOTES:
"   The creation of the path variable RAV$SYSTEM is to allow for internal testing.
"   Margins have been turned off (set to 0) until all messages can be properly aligned together.  To
"   turn the margins back on replace the 0's with a 2.
"
"   When called by INITIATE_SYSTEM, the variable RAV$PROMPTING_ALLOWED will exist.
"   This will allow prompting to occur based upon system attributes.
"
"   When called by a user, prompting will never take place and installation
"   will never take place.
"
"   The variable rav$initiate_operator_interface will only be XREFable when ACTPE is called
"   by initiate system.  This variable allows ACTPE to tell INITIATE_SYSTEM
"   if it should start up the operator interface.  The interface is not started
"   if the system is activated for console usage only.
"   !! A better solution is to change the INITIATE_SYSTEM/ACTPE code
"   !! such that actpe is the only one which can start the operator interface.
"   !! This will make the code much cleaner.
*IFEND

*copy rav$system_paths

  "$FORMAT=OFF
  TYPE
    inst_param_record: ..
*copy rat$installation_parameters

  TYPEND

  VAR
    activation_status: status
    ignore_status: status
    installation_parameters: inst_param_record
    installation_status: status
    local_status: status
    model_number: string = $unique
    osv$deadstart_phase: (XREF) string 0 .. $max_name
    proc_status: status
    rav$activate_operator_interface: (XREF) string
    rav$margin: (XDCL) integer = 0
    rav$event_message: (XDCL) status
    rav$set_operator_command_list: (XDCL) string = ''
    rav$set_operator_library_list: (XDCL) string = ''
    sys_libs: list of file = ($system.osf$command_library $system.osf$operator_command_library ..
          $system.osf$operator_library $system.osf$operator_library_46d ..
          $system.osf$system_library $system.osf$system_library_46d)
    sys_libs_error_flag: boolean = false
  VAREND
  "$FORMAT=ON"

  IF $variable(rav$prompting_allowed, nonlocal) THEN
    called_by_initiate_system = true
  ELSE
    called_by_initiate_system = false
  IFEND

  IF $variable(rav$initiate_operator_interface, nonlocal) THEN
    "$FORMAT=OFF
    VAR
      rav$initiate_operator_interface: (XREF) boolean
    VAREND
    "$FORMAT=ON"
  ELSE
    "$FORMAT=OFF
    VAR
      rav$initiate_operator_interface: boolean = FALSE
    VAREND
    "$FORMAT=ON"
  IFEND

  IF NOT called_by_initiate_system THEN

    "$FORMAT=OFF
    VAR
      rav$errors_occurred: (XDCL) boolean = false
    VAREND
    "$FORMAT=ON"
  ELSE
    "$FORMAT=OFF
    VAR
      rav$errors_occurred: (XREF) boolean
    VAREND
    "$FORMAT=ON"

  IFEND

  IF $field(rav$installation_tape_values, packing_list, initialized) THEN
    installation_parameters.packing_list = $string(rav$installation_tape_values.packing_list)
    installation_parameters.evsn = rav$installation_tape_values.evsn
    installation_parameters.rvsn = rav$installation_tape_values.rvsn
    IF installation_parameters.rvsn = '' THEN
      installation_parameters.rvsn = installation_parameters.evsn
    ELSEIF installation_parameters.evsn = '' THEN
      installation_parameters.evsn = installation_parameters.rvsn
    IFEND
    IF $field(rav$installation_tape_values, tape_type, initialized) THEN
      installation_parameters.tape_type = $string(rav$installation_tape_values.tape_type)
    ELSE " tape type was not specified "
      installation_parameters.tape_type = 'MT9$6250'
    IFEND
  ELSE " SET_INSTALLATION_TAPE was not called at system core time "
    installation_parameters.packing_list = ''
    installation_parameters.evsn = ''
    installation_parameters.rvsn = ''
    installation_parameters.tape_type = 'MT9$6250'
  IFEND

  IF osv$deadstart_phase = 'INSTALL' THEN
    " There are no pervious cycles to worry about.
    " The following assignment will prevent the delete previous cycles step from executing.
    installation_parameters.save_previous_cycles = true
  ELSE
    installation_parameters.save_previous_cycles = false
  IFEND

  IF called_by_initiate_system THEN

    IF $file(rav$accounting_utils_library, permanent) THEN
      $system.include_command c=$string(rav$accounting_utils_library.record_system_initiation) status=ignore_status
    IFEND

    rap$get_system_initiation_opt ip=installation_parameters

  ELSE

    rap$create_operator_environment
    rap$display_message mm=initiation_messages mn=activating_for_production t=$response status=ignore_status
    installation_parameters.installation_option = 'NONE'
    installation_parameters.activation_option = 'PRODUCTION'

  IFEND

  IF (NOT called_by_initiate_system) OR (osv$deadstart_phase <> 'INSTALL') THEN
    "Run prolog if ACTPE called directly by user OR if run by INITIATE_SYSTEM on continuation deadstart.
    rap$run_initiation_commands icn=system_initiation_prolog status=local_status
    IF NOT local_status.normal THEN
      rap$handle_status si=local_status so=proc_status
    IFEND
  IFEND

  IF called_by_initiate_system THEN

    IF installation_parameters.installation_option <> 'NONE' THEN
      rap$perform_installation_option ip=installation_parameters status=installation_status
      IF NOT installation_status.normal THEN
        rap$handle_status si=installation_status so=proc_status
      IFEND
    IFEND

  IFEND

  IF (installation_parameters.activation_option = 'PRODUCTION') AND (installation_status.normal) THEN
    IF installation_parameters.installation_option = 'INSTALLATION_TAPE' THEN
      activate_job_environment na=network_activation shpa=false status=activation_status
    ELSE
      activate_job_environment na=network_activation shpa=true status=activation_status
    IFEND
    IF NOT activation_status.normal THEN
      rap$handle_status si=activation_status so=proc_status
    IFEND
  IFEND

  IF (called_by_initiate_system) AND (osv$deadstart_phase = 'INSTALL') AND ..
        (installation_parameters.installation_option <> 'INSTALLATION_TAPE') THEN
    " Do not run epilog since the file is not yet present
  ELSE
    rap$run_initiation_commands icn=system_initiation_epilog status=local_status
    IF NOT local_status.normal THEN
      rap$handle_status si=local_status so=proc_status
    IFEND
  IFEND

  IF (called_by_initiate_system AND (installation_parameters.activation_option <> ..
    'CONSOLE')) OR (NOT called_by_initiate_system) THEN
    install_exception_policies status=ignore_status
  IFEND

  binary_model_number = $processor(binary_model_number)
  IF activation_status.normal THEN
    IF (installation_parameters.activation_option = 'PRODUCTION') THEN
      begin_production_environment " for SYSTEM_OPERATOR_UTILITY "
      rav$initiate_operator_interface=true
      rap$display_message mm=initiation_messages mn=production_activated t=$response status=ignore_status
    ELSE
      IF (binary_model_number = 3d(16)) OR (binary_model_number = 3c(16)) OR (binary_model_number = 43(16)) THEN

" This is a Soviet Nuclear Safety or China Weather system.
" Run begin_production_environment to clear capabilities.

        begin_production_environment
      IFEND
      rav$initiate_operator_interface=false
      rap$display_message mm=initiation_messages mn=console_only_activated t=$response status=ignore_status
    IFEND
  ELSE
    IF (binary_model_number = 3d(16)) OR (binary_model_number = 3c(16)) OR (binary_model_number = 43(16)) THEN

" This is a Soviet Nuclear Safety or China Weather System.
" Even if something went wrong earlier, run begin_production_environment
" to clear capabilities from the $system job.

      begin_production_environment
    IFEND
  IFEND

  FOR each library in sys_libs DO
    IF $field($file_attributes(library exception_conditions)(1) exception_conditions specified) THEN
      sys_libs_error_flag = TRUE
      $system.put_line ' Exception condition on file '//library
    ELSE
      IF NOT ($file_attributes(library registered)(1).registered) THEN
        sys_libs_error_flag = TRUE
        $system.put_line ' Missing file '//library
      IFEND
    IFEND
  FOREND
  IF sys_libs_error_flag THEN
    rav$errors_occurred = TRUE
    $system.put_line ' ' o=$local.$output
    $system.put_line ' WARNING:  One or more of the NOS/VE system libraries is not available.' o=$local.$output
    $system.put_line ' Contact your site analyst.' o=$local.$output
    $system.put_line ' ' o=$local.$output
    IF (installation_parameters.activation_option = 'PRODUCTION') THEN
      EXIT procedure WITH $status(false, 'RA', rae$activation_errors_warning, 'production')
    ELSE
      EXIT procedure WITH $status(false, 'RA', rae$activation_errors_warning, 'system console usage only')
    IFEND
  IFEND

  IF called_by_initiate_system THEN

    IF NOT proc_status.normal THEN
      IF (installation_parameters.activation_option = 'PRODUCTION') THEN
        EXIT procedure WITH $status(false, 'RA', rae$activation_errors_warning, 'production')
      ELSE
        EXIT procedure WITH $status(false, 'RA', rae$activation_errors_warning, 'system console usage only')
      IFEND
    IFEND

  ELSE

    IF (rav$activate_operator_interface = '') OR (NOT rav$initiate_operator_interface) THEN
      EXIT procedure WITH $status(false, 'RA', rae$errors_occurred_warning, ..
            'ACTIVATE_PRODUCTION_ENVIRONMENT') WHEN rav$errors_occurred
    ELSE
      IF rav$errors_occurred THEN
        " Have user acknowledge errors, prior to activating the operator interface.
        $system.put_line ' '//..
$strrep($status(false, 'RA', rae$errors_occurred_warning, 'ACTIVATE_PRODUCTION_ENVIRONMENT'))
        rap$press_next
      IFEND
      $system.include_command c=rav$activate_operator_interface status=activation_status
      IF NOT activation_status.normal THEN
        $system.put_line (' '//..
$strrep($status(false, 'RA', rae$errors_occurred_warning, 'RAV$ACTIVATE_OPERATOR_INTERFACE')) ' '//..
$strrep(activation_status)) o=$response
      IFEND
    IFEND

  IFEND

PROCEND activate_production_environment
*DECK DECK=RAP$ACTIVATE_PRODUCTS EXPAND=FALSE

  PROCEDURE [XREF] rap$activate_products
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR subproducts_failed_processing: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$ACTIVATE_PTF EXPAND=TRUE
PROC activate_ptf (
  load_map, lm : file = $optional
  status       : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request defines and activates the system task for the PTF server application.
*IFEND


  create_variable local_status kind=status
  create_variable ptf_library kind=string value='$system.ptf_qtf.osf$user_file_transfer'


  display_catalog_entry $fname(ptf_library) display_option=log output=$null status=local_status
  IF NOT local_status.normal THEN
    display_value value=local_status output=$response
    put_line ('  ', ' --ERROR-- Unable to activate:  PTF is not installed.') o=$response
    EXIT_PROC
  IFEND

  IF $specified(load_map) THEN
    map_file = $string($value(load_map))
    options = 'all'
  ELSE
    map_file = '$null'
    options = 'none'
  IFEND

  delete_system_task name=osa$file_transfer_server status=local_status
  IF NOT local_status.normal AND ($condition(local_status.condition) <> 'OSE$SYSTEM_TASK_NOT_DEFINED') THEN
    EXIT_PROC WITH local_status
  IFEND

  define_system_task name=osa$file_transfer_server library=$fname(ptf_library) ..
        starting_procedure=nfp$file_transfer_boot automatic_restart=false restart_after_idle=true ..
        deactivate_task_option=terminate idle_task_option=terminate load_map=$fname(map_file) ..
        load_map_options=$name(options) termination_error_level=error status=local_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

  activate_system_task task_name=osa$file_transfer_server

PROCEND activate_ptf

*DECK DECK=RAP$ACTIVATE_QTF EXPAND=TRUE
PROCEDURE activate_qtf (
  host_physical_identifier, hpi: string 1..31 = $required
  maximum_subtasks, ms: any of
      key
        unlimited
      keyend
      integer 1..20
    anyend = unlimited
  load_map, lm: file = $optional
  dump_file, df: file = $optional
  single_transfer_per_connection, stpc: boolean = false
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request defines and activates the system task for the QTF client application.

*IFEND


  "$FORMAT=OFF
  VAR
    abort_file_commands: file = $SYSTEM.PTF_QTF.QTF_ABORT_FILE_COMMANDS
    dump_file_value: string = ''
    dump_file_specified: boolean = $specified(dump_file)
    local_status: status
    load_map_options: name = NONE
    load_map_value: file = $NULL
    qtf_library: file = $SYSTEM.PTF_QTF.OSF$USER_FILE_TRANSFER
    task_parameters: string = 'HOST_PHYSICAL_IDENTIFIER='//$quote(host_physical_identifier)
  VAREND
  "$FORMAT=ON"

  display_catalog_entry file=qtf_library display_option=log output=$null status=local_status
  IF NOT local_status.normal THEN
    display_value value=local_status output=$response
    put_line lines=('  ', ' --ERROR-- Unable to activate:  QTF is not installed.') output=$response
    EXIT_PROC
  IFEND

  IF $string(maximum_subtasks) = 'UNLIMITED' THEN
" NOTE: 0 denotes an unlimited value "
    task_parameters = task_parameters//' MAXIMUM_QTFI_SUBTASKS=0'
  ELSE
    task_parameters = task_parameters//' MAXIMUM_QTFI_SUBTASKS='//$integer_string(maximum_subtasks 10 no)
  IFEND

  task_parameters = task_parameters//' SINGLE_TRANSFER_PER_CONNECTION='//$string(..
        single_transfer_per_connection)

  IF $specified(load_map) THEN
    load_map_value = load_map
    load_map_options = ALL
  IFEND

  IF $specified(dump_file) THEN
    dump_file_value = $string(dump_file)
  IFEND

  IF $file(abort_file_commands, permanent) THEN
    REPEAT
      delete_file file=abort_file_commands status=local_status
    UNTIL NOT local_status.normal
  IFEND

COLLECT_TEXT output=abort_file_commands until='** END OF ABORT COMMANDS **' substitution_mark='#'

  VAR
    abort_commands_status: (UTILITY) status
    dump_file: (UTILITY) file = $fname('$system.ptf_qtf.qtf_dump_'//$date('Y2M2D2')//'_'//$time('H24MMSS'))
  VAREND

  create_command_list_entry entry=$system.osf$command_library status=abort_commands_status

  IF #dump_file_specified# THEN
    dump_file = #dump_file_value#
  IFEND

  display_message message=' ' to=job
  display_message message='**** Please write a PSR against QTF/VE and provide' to=job
  display_message message='**** as supporting material a permanent file backup' t=job
  display_message message='**** of catalog $SYSTEM.PTF_QTF.' t=job
  display_message message=' ' to=job

"  The following commands will display the abort information
"  through the use of the debugger.

  set_file_attributes dump_file fc=list pf=continuous
  put_line '1***** ABORT DUMP OF QTF' o=dump_file
  put_line '       '//$date(iso)//' '//$time(millisecond) o=dump_file.$eoi
  put_line '       '//$job(os_version)//' - '//$default_family//' - CYBER '//..
$processor(model_number, 0)//' Serial '//$processor(serial_number, 0) o=dump_file.$eoi
  put_lines ('', ' ***** ENVIRONMENT:', '') output=dump_file.$eoi
  display_debugging_environment display_option=user_address output=dump_file.$eoi
  display_debug_task_status task_number=all output=dump_file.$eoi
  put_lines ('', ' ***** TRACEBACK:', '') output=dump_file.$eoi
  display_call count=all start=1 display_option=all_calls output=dump_file.$eoi
  put_lines ('', ' ***** JOB LOG:', '') output=dump_file.$eoi
  display_log display_option=200 output=dump_file.$eoi
  put_lines ('', ' ***** REGISTERS:', '') output=dump_file.$eoi
  display_register kind=all_program number=all type=hex output=dump_file.$eoi
  put_lines ('', ' ***** STACK FRAMES:', '') output=dump_file.$eoi
  display_stack_frame count=all start=1 display_option=all output=dump_file.$eoi
  put_lines ('', ' ***** STATIC SECTION:', '') output=dump_file.$eoi
  display_memory section=$static module=$name($current_module) byte_offset=0 byte_count=16 repeat_count=all ..
        output=dump_file.$eoi
  IF $variable(nfv$appl_def_segment_for_qtf, declared) = 'LOCAL' THEN
    put_lines ( '-***** NFV$APPL_DEF_SEGMENT_FOR_QTF:', '') output=dump_file.$eoi
    display_memory address=?nfv$appl_def_segment_for_qtf byte_offset=0 byte_count=16 ..
          repeat_count=0FFFFF(16) output=dump_file.$eoi
    delete_variable name=nfv$appl_def_segment_for_qtf status=abort_commands_status
  IFEND

  IF $variable(nfv$notify_after_aborting, defined) THEN
    IF nfv$notify_after_aborting THEN
      send_operator_message m='QTF task failed, see system job log.' oc=system_operator
    IFEND
  IFEND
** END OF ABORT COMMANDS **


  delete_system_task name=queue_transfer_client status=local_status
  IF NOT local_status.normal AND ($condition(local_status.condition) <> 'OSE$SYSTEM_TASK_NOT_DEFINED') THEN
    EXIT_PROC WITH local_status
  IFEND

  define_system_task name=queue_transfer_client library=qtf_library ..
        starting_procedure=nfp$qtf_controller abort_file=abort_file_commands ..
        automatic_restart=false restart_after_idle=true deactivate_task_option=terminate ..
        idle_task_option=terminate load_map=load_map_value parameters=task_parameters ..
        load_map_options=load_map_options termination_error_level=error execution_ring=6 ..
        status=local_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

  activate_system_task task_name=queue_transfer_client

PROCEND activate_qtf
*DECK DECK=RAP$ACTIVATE_QTFS EXPAND=TRUE
PROCEDURE activate_qtfs (
  host_physical_identifier, hpi: string 1..31 = $required
  load_map, lm: file = $optional
  account_prefix_character, apc: (BY_NAME, ADVANCED) name 1..1 = A
  project_prefix_character, ppc: (BY_NAME, ADVANCED) name 1..1 = P
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request will define and activate the system task for the QTF/VE server application.
*IFEND

  VAR
    load_map_file: file
    load_map_options: name
    local_status: status
    qtf_library: file = $system.ptf_qtf.osf$user_file_transfer
    task_parameters: string 1..512
  VAREND

  IF $first($file_attributes(qtf_library, registered)).registered THEN

    IF $specified(load_map) THEN
      load_map_file = load_map
      load_map_options = all
    ELSE
      load_map_file = $local.$null
      load_map_options = none
    IFEND

    task_parameters = 'host_physical_identifier ='//$quote(host_physical_identifier)
    task_parameters = task_parameters//' account_prefix_character='//account_prefix_character
    task_parameters = task_parameters//' project_prefix_character='//project_prefix_character

    delete_system_task name=queue_transfer_server status=local_status
    IF (NOT local_status.normal) AND local_status.condition <> ose$system_task_not_defined THEN
      EXIT procedure WITH local_status
    IFEND

    define_system_task name=queue_transfer_server library=qtf_library starting_procedure=nfp$qtfs_boot ..
          automatic_restart=false restart_after_idle=true deactivate_task_option=terminate ..
          idle_task_option=terminate load_map=load_map_file load_map_options=load_map_options ..
          termination_error_level=error parameters=task_parameters execution_ring=6 status=local_status

    EXIT procedure WITH local_status WHEN (NOT local_status.normal)

    activate_system_task task_name=queue_transfer_server

  ELSE
    display_value value=$status(false, 'PF', pfe$unknown_permanent_file, $fname(qtf_library))
    put_line lines=('  ', ' --ERROR-- Unable to activate:  QTF is not installed.') output=$response
  IFEND

PROCEND activate_qtfs
*DECK DECK=RAP$ACTIVATE_SCF EXPAND=TRUE
PROCEDURE activate_scf (
  load_map, lm: file = $null
  dump_file, df: file = $optional
  job_class, jc: name = system
  notify_after_aborting, naa: boolean = false
  protocol_trace, pt: (BY_NAME, ADVANCED) boolean = false
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request activates SCF.

*IFEND

  VAR
    abort_file_commands: file = $system.batch_device_support.scf_abort_file_commands
    dump_file_specified : boolean = $specified(dump_file)
    dump_file_value : file = $local.$null
    load_map_options: name = none
    local_status: status
    scf_library: file = $system.batch_device_support.osf$batch_device_support
  VAREND

  IF NOT $file(scf_library permanent) THEN
    EXIT_PROC WITH $status(false 'AM' ame$file_not_known scf_library 'SCF_ACTIVATION')
  IFEND

  MANAGE_JOBS
    select_job name=$name('scf'//$mainframe(id)) job_state=(deferred, queued, initiated) ..
          user_information='Status and Control Facility (SCF) for NOS/VE' status=local_status
    IF local_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        EXIT_PROC WITH $status(false 'RA' 0 'An identical SCF job was found. SCF will not be activated')
      IFEND
    ELSE
      EXIT_PROC WITH local_status
    IFEND
  QUIT
  IF $specified(load_map) THEN
    load_map_options = all
  ELSE
    load_map_options = none
  IFEND

IF dump_file_specified THEN
  dump_file_value = dump_file
IFEND

  IF $file(abort_file_commands, permanent) THEN
    REPEAT
      delete_file file=abort_file_commands status=local_status
    UNTIL NOT local_status.normal
  IFEND

  TASK ring=11
COLLECT_TEXT output=abort_file_commands until='** END OF ABORT COMMANDS **' substitution_mark='#' status=local_status

  VAR
    abort_commands_status: status
    dump_file: file = $fname('$system.batch_device_support.scf_dump_'//$date('Y2M2D2')//'_'//$time('H24MMSS'))
  VAREND

  IF #dump_file_specified# THEN
    dump_file = #dump_file_value#
  IFEND

  display_message message=' ' to=job
  display_message message='**** Please write a PSR against SCF/VE and provide' to=job
  display_message message='**** as supporting material a permanent file backup' t=job
  display_message message='**** of catalog $SYSTEM.BATCH_DEVICE_SUPPORT.' t=job
  display_message message=' ' to=job

"  The following commands will display the abort information
"  through the use of the debugger.

  set_file_attributes dump_file fc=list pf=continuous
  put_line '1***** ABORT DUMP OF SCF' o=dump_file
  change_file_attributes file=dump_file ring_attributes=(6, 11, 11)
  put_line '       '//$date(iso)//' '//$time(millisecond) o=dump_file.$eoi
  put_line '       '//$job(os_version)//' - '//$default_family//' - CYBER '//..
$processor(model_number, 0)//' Serial '//$processor(serial_number, 0) o=dump_file.$eoi
  put_lines ('', ' ***** ENVIRONMENT:', '') output=dump_file.$eoi
  display_debugging_environment display_option=user_address output=dump_file.$eoi
  display_debug_task_status task_number=all output=dump_file.$eoi
  put_lines ('', ' ***** TRACEBACK:', '') output=dump_file.$eoi
  display_call count=all start=1 display_option=all_calls output=dump_file.$eoi
  put_lines ('', ' ***** JOB LOG:', '') output=dump_file.$eoi
  display_log display_option=200 output=dump_file.$eoi
  put_lines ('', ' ***** REGISTERS:', '') output=dump_file.$eoi
  display_register kind=all_program number=all type=hex output=dump_file.$eoi
  put_lines ('', ' ***** STACK FRAMES:', '') output=dump_file.$eoi
  display_stack_frame count=all start=1 display_option=all output=dump_file.$eoi
  put_lines ('', ' ***** STATIC SECTION:', '') output=dump_file.$eoi
  display_memory section=$static module=$name($current_module) byte_offset=0 byte_count=16 repeat_count=all ..
        output=dump_file.$eoi
  IF $variable(nfv$appl_def_segment_for_scf, declared) = 'LOCAL' THEN
    put_lines ( '-***** NFV$APPL_DEF_SEGMENT_FOR_SCF:', '') output=dump_file.$eoi
    display_memory address=?nfv$appl_def_segment_for_scf byte_offset=0 byte_count=16 ..
          repeat_count=0FFFFF(16) output=dump_file.$eoi
    delete_variable name=nfv$appl_def_segment_for_scf status=abort_commands_status
  IFEND

  IF $variable(nfv$notify_after_aborting, defined) THEN
    IF nfv$notify_after_aborting THEN
      send_operator_message ..
            m='SCF job failed, see $SYSTEM.BATCH_DEVICE_SUPPPORT.SCF_OUTPUT_'//$mainframe(id) ..
            oc=system_operator
    IFEND
  IFEND
** END OF ABORT COMMANDS **
    IF NOT local_status.normal THEN
      IF local_status.condition = ame$file_not_known THEN
        local_status=$status(false 'PF' pfe$unknown_permanent_file $string(abort_file_commands))
      IFEND
      EXIT PROCEDURE WITH local_status
    IFEND
  TASKEND

  JOB user_job_name=$name('scf'//$mainframe(id)) job_abort_disposition=terminate job_class=job_class ..
        job_destination_usage=ve_local job_execution_ring=6 job_recovery_disposition=terminate ..
        output_disposition=$fname('$system.batch_device_support.scf_output_'//$mainframe(id)) ..
        substitution_mark='!' user_information='Status and Control Facility (SCF) for NOS/VE' ..
        status=local_status

    SYSTEM_OPERATOR_UTILITY capability=system_operation
      VAR
        ignore_status: status
        nfv$notify_after_aborting : (JOB) boolean = !notify_after_aborting!
        scf_job_status: status
      VAREND

      IF !protocol_trace! THEN
        VAR
          nfv$rhf_protocol_trace : (JOB) string = 'BTFC'
        VAREND
      IFEND

      change_message_level il=full status=ignore_status

      set_debug_ring ring=6

      execute_task library=!scf_library! starting_procedure=nfp$status_and_control_facility ..
            abort_file=!abort_file_commands! load_map=!load_map! load_map_options=!load_map_options! ..
            status=scf_job_status

      display_value scf_job_status
    END_SYSTEM_OPERATOR_UTILITY
  JOBEND

  EXIT_PROC WITH local_status

PROCEND activate_scf
*DECK DECK=RAP$ACTIVATE_SCFS EXPAND=TRUE
PROCEDURE activate_scfs (
  application_name, an: name = $optional
  control_facility_name, cfn: name = $optional
  system_task_name, stn: name = $optional
  logging, l: boolean = $optional
  load_map, lm: file = $optional
  ntf_system_list, nsl: file = $optional
  dump_file, df: file = $optional
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request activates SCFS.
"
"    The parameters APPLICATION_NAME, CONTROL_FACILITY_NAME and
"SYSTEM_TASK_NAME can only be used in the following manner.
"
"    1.  Specify none of the parameters and allow the defaults to
"        be used.
"    2.  Specify all three parameters.
"    3.  Specify only the parameter APPLICATION_NAME and the value
"        will be used for all three names.
"
"NOTE:  You cannot specify any of the defaults when doing 2 or 3.

*IFEND


  "$FORMAT=OFF
  VAR
    abort_file_commands: file = $SYSTEM.BATCH_DEVICE_SUPPORT.SCFS_ABORT_FILE_COMMANDS
    application_name_value: string  = 'OSA$STATUS_CONTROL_FAC_SERVER'
    control_facility_name_value: string = 'STATION_CONTROLLER_1'
    dump_file_specified: boolean = $specified(dump_file)
    dump_file_value: string = ''
    local_status: status
    load_map_options: name = NONE
    load_map_value: file = $NULL
    logging_value: string = 'FALSE'
    ntf_systems: string = ' '
    scfs_library: file = $SYSTEM.BATCH_DEVICE_SUPPORT.OSF$BATCH_DEVICE_SUPPORT
    system_task_name_value: string = 'SCF_SERVER'
  VAREND
  "$FORMAT=ON"

  IF $specified(application_name) THEN
    application_name_value = $string(application_name)

    IF $specified(control_facility_name) AND $specified(system_task_name) THEN
      control_facility_name_value = $string(control_facility_name)
      system_task_name_value = $string(system_task_name)
    ELSEIF NOT $specified(control_facility_name) AND NOT $specified(system_task_name) THEN
      control_facility_name_value = application_name_value
      system_task_name_value = application_name_value
    ELSE
      put_line lines=(' ', ' --ERROR-- The APPLICATION_NAME parameter was incorrectly', ..
            ' specified with only one of the CONTROL_FACILITY_NAME or', ..
            ' SYSTEM_TASK_NAME parameters, either eliminate that parameter' ..
            ' or add the other parameter.') output=$response
      EXIT_PROC
    IFEND

    IF (application_name_value = 'OSA$STATUS_CONTROL_FAC_SERVER') OR ..
          (control_facility_name_value = 'STATION_CONTROLLER_1') OR ..
          (system_task_name_value = 'SCF_SERVER') THEN
      IF application_name_value = 'OSA$STATUS_CONTROL_FAC_SERVER' THEN
        put_line lines=(' ', ' --ERROR-- The APPLICATION_NAME parameter can not specify', ..
              ' the default value of OSA$STATUS_CONTROL_FAC_SERVER') output=$response
      IFEND
      IF control_facility_name_value = 'STATION_CONTROLLER_1' THEN
        put_line lines=(' ', ' --ERROR-- The CONTROL_FACILITY_NAME parameter can not specify', ..
              ' the default value of STATION_CONTROLLER_1') output=$response
      IFEND
      IF system_task_name_value = 'SCF_SERVER' THEN
        put_line lines=(' ', ' --ERROR-- The SYSTEM_TASK_NAME parameter can not specify', ..
              ' the default value of SCF_SERVER') output=$response
      IFEND
      EXIT_PROC
    IFEND
  ELSEIF $specified(control_facility_name) AND $specified(system_task_name) THEN
    put_line lines=(' ', ' --ERROR-- The APPLICATION_NAME parameter must be specified if both', ..
          ' the APPLICATION_NAME and SYSTEM_TASK_NAME parameters are specified.') output=$response
    EXIT_PROC
  ELSEIF $specified(control_facility_name) THEN
    put_line lines=(' ', ' --ERROR-- The CONTROL_FACILITY_NAME parameter can only be specified', ..
          ' with both the APPLICATION_NAME and SYSTEM_TASK_NAME parameters.') output=$response
    EXIT_PROC
  ELSEIF $specified(system_task_name) THEN
    put_line lines=(' ', ' --ERROR-- The SYSTEM_TASK_NAME parameter can only be specified', ..
          ' with both the APPLICATION_NAME and CONTROL_FACILITY_NAME parameters.') output=$response
    EXIT_PROC
  IFEND

  IF $specified(load_map) THEN
    load_map_value = load_map
    load_map_options = ALL
  IFEND

  IF $specified(logging) THEN
    logging_value = $string(logging)
  IFEND

  IF $specified(ntf_system_list) THEN
    ntf_systems = ' NSL='//$string(ntf_system_list)
  IFEND

  IF $specified(dump_file) THEN
    dump_file_value = $string(dump_file)
  IFEND

  IF $file(abort_file_commands, permanent) THEN
    REPEAT
      delete_file file=abort_file_commands status=local_status
    UNTIL NOT local_status.normal
  IFEND

  TASK ring=11
COLLECT_TEXT output=abort_file_commands until='** END OF ABORT COMMANDS **' substitution_mark='#' status=local_status

  VAR
    abort_commands_status: (UTILITY) status
    dump_file: (UTILITY) file = $fname('$system.batch_device_support.scfs_dump_'//$date('Y2M2D2')//'_'//$time('H24MMSS'))
  VAREND

  create_command_list_entry entry=$system.osf$command_library status=abort_commands_status

  IF #dump_file_specified# THEN
    dump_file = #dump_file_value#
  IFEND

  display_message message=' ' to=job
  display_message message='**** Please write a PSR against SCFS and provide' to=job
  display_message message='**** as supporting material a permanent file backup' t=job
  display_message message='**** of catalog $SYSTEM.BATCH_DEVICE_SUPPORT.' t=job
  display_message message=' ' to=job

"  The following commands will display the abort information
"  through the use of the debugger.

  set_file_attributes dump_file fc=list pf=continuous
  put_line '1***** ABORT DUMP OF SCFS - CFN:#control_facility_name_value#' o=dump_file
  put_line '       '//$date(iso)//' '//$time(millisecond) o=dump_file.$eoi
  put_line '       '//$job(os_version)//' - '//$default_family//' - CYBER '//..
$processor(model_number, 0)//' Serial '//$processor(serial_number, 0) o=dump_file.$eoi
  put_lines ('', ' ***** ENVIRONMENT:', '') output=dump_file.$eoi
  display_debugging_environment display_option=user_address output=dump_file.$eoi
  display_debug_task_status task_number=all output=dump_file.$eoi
  put_lines ('', ' ***** TRACEBACK:', '') output=dump_file.$eoi
  display_call count=all start=1 display_option=all_calls output=dump_file.$eoi
  put_lines ('', ' ***** JOB LOG:', '') output=dump_file.$eoi
  display_log display_option=200 output=dump_file.$eoi
  put_lines ('', ' ***** REGISTERS:', '') output=dump_file.$eoi
  display_register kind=all_program number=all type=hex output=dump_file.$eoi
  put_lines ('', ' ***** STACK FRAMES:', '') output=dump_file.$eoi
  display_stack_frame count=all start=1 display_option=all output=dump_file.$eoi
  put_lines ('', ' ***** STATIC SECTION:', '') output=dump_file.$eoi
  display_memory section=$static module=$name($current_module) byte_offset=0 byte_count=16 repeat_count=all ..
        output=dump_file.$eoi
  IF $variable(nfv$appl_def_segment_for_scfs, declared) = 'LOCAL' THEN
    put_lines ( '-***** NFV$APPL_DEF_SEGMENT_FOR_SCFS:', '') output=dump_file.$eoi
    display_memory address=?nfv$appl_def_segment_for_scfs byte_offset=0 byte_count=16 ..
          repeat_count=0FFFFF(16) output=dump_file.$eoi
    delete_variable name=nfv$appl_def_segment_for_scfs status=abort_commands_status
  IFEND

  IF $variable(nfv$notify_after_aborting, defined) THEN
    IF nfv$notify_after_aborting THEN
      send_operator_message m='SCFS task failed, see system job log.' oc=system_operator
    IFEND
  IFEND
** END OF ABORT COMMANDS **
    IF NOT local_status.normal THEN
      IF local_status.condition = ame$file_not_known THEN
        local_status=$status(false 'PF' pfe$unknown_permanent_file $string(abort_file_commands))
      IFEND
      EXIT PROCEDURE WITH local_status
    IFEND
  TASKEND

  delete_system_task name=$name(system_task_name_value) status=local_status
  IF NOT local_status.normal AND ($condition(local_status.condition) <> 'OSE$SYSTEM_TASK_NOT_DEFINED') THEN
    EXIT_PROC WITH local_status
  IFEND

  define_system_task name=$name(system_task_name_value) library=(scfs_library, $system.debug.bound_product, ..
        $system.tdu.bound_product) starting_procedure=nfp$status_control_fac_server ..
        parameters='CF='//control_facility_name_value//' S='//application_name_value//' L='//logging_value//ntf_systems ..
        abort_file=abort_file_commands automatic_restart=false restart_after_idle=true ..
        deactivate_task_option=terminate idle_task_option=terminate load_map=load_map_value ..
        load_map_options=load_map_options termination_error_level=error status=local_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

  activate_system_task task_name=$name(system_task_name_value) status=local_status

  EXIT_PROC WITH local_status

PROCEND activate_scfs
*DECK DECK=RAP$ACTIVATE_SET EXPAND=TRUE
create_command_description name=(activate_set, acts) sp=stp$activate_set_command
*DECK DECK=RAP$ACTIVATE_SMTP EXPAND=TRUE
PROCEDURE activate_smtp (
  debug_mode, dm              : boolean = $optional
  default_destination, dd     : application = $optional
  job_class, jc               : name = $job_default(job_class, batch)
  load_map, lm                : file = $optional
  maximum_queued_time, mqt    : any of integer 0..65535, ..
                                       key infinite, keyend, anyend = $optional
  maximum_subtasks, ms        : integer 1..20 = $optional
  process_interval, pi        : integer 0..60 = $optional
  retransmission_interval, ri : integer 5..60 = $optional
  status
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request initiates the SMTP client application as a NOS/VE job.
*IFEND


  VAR
    application_job_name: name = $name('SMTP'//$mainframe(id))
    ignore_status: status
    manna_status: status
    map_file: string
    options: string
    smtp_bound_product: file = $system.tcp_ip.smtp_bound_product
    smtp_job_log: file = $system.tcp_ip.smtp_job_log
    select_status: status
    starting_procedure_name: name = ipp$smtp_controller
    submit_status: status
    system_job_name: name
    task_parameters: string
  VAREND

  IF NOT $file(smtp_bound_product permanent) THEN
    put_line ' --ERROR-- Unable to activate:  SMTP is not installed.'..
      o=$response
    EXIT procedure
  IFEND

  $system.osf$command_library.manage_network_applications status=manna_status
  EXIT_PROC WITH manna_status WHEN NOT manna_status.normal

  display_client_status client=osa$smtp_client o=$null status=manna_status
  include_line 'quit' status=ignore_status
  EXIT_PROC WITH manna_status WHEN NOT manna_status.normal

  MANAGE_JOBS
    SELECT_JOB login_user=$SYSTEM login_family=$SYSTEM ..
      name=application_job_name job_state=(deferred, queued, initiated) ..
      status=select_status
    IF select_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        put_line ' SMTP is already active as job(s):' ..
          o=$response
        display_value jmv$selected_jobs o=$response
        EXIT procedure
      IFEND
    ELSE
      EXIT procedure WITH select_status
    IFEND
  QUIT

  IF $specified(load_map) THEN
    map_file = $string(load_map)
    options = 'all'
  ELSE
    map_file = '$null'
    options = 'none'
  IFEND

" Build task parameters string for activate_system_task "

  task_parameters = ''

  IF $specified(debug_mode) THEN
    task_parameters = task_parameters // ' debug_mode=' // ..
          $strrep(debug_mode)
  IFEND

  IF $specified(default_destination) THEN
    task_parameters = task_parameters // ' default_destination=' // ..
          $string(default_destination)
  IFEND

  IF $specified(maximum_queued_time) THEN
    task_parameters = task_parameters // ' maximum_queued_time=' // ..
          $strrep(maximum_queued_time)
  IFEND

  IF $specified(maximum_subtasks) THEN
    task_parameters = task_parameters // ' maximum_subtasks=' // ..
          $strrep(maximum_subtasks)
  IFEND

  IF $specified(process_interval) THEN
    task_parameters = task_parameters // ' process_interval=' // ..
          $strrep(process_interval)
  IFEND

  IF $specified(retransmission_interval) THEN
    task_parameters = task_parameters // ' retransmission_interval=' // ..
          $strrep(retransmission_interval)
  IFEND

  JOB user_job_name=application_job_name ..
      job_class=job_class ..
      job_recovery_disposition=terminate ..
      job_abort_disposition=terminate ..
      output_disposition=smtp_job_log ..
      substitution_mark='?' ..
      system_job_name=system_job_name ..
      status=submit_status

    VAR
      ignore: status
    VAREND

    TASK ring=6
      execute_task l=?smtp_bound_product? ..
         sp=?starting_procedure_name? p='?task_parameters?' ..
         load_map=?map_file? load_map_options=?options?
    TASKEND

  JOBEND

  IF submit_status.normal THEN
    put_line ' SMTP has been activated as job '//..
$string(application_job_name)//' ('//$string(system_job_name)//').' ..
          o=$response
  ELSE
    put_line ' --ERROR-- Unable to submit job for SMTP.' ..
      o=$response
  IFEND
  EXIT procedure WITH submit_status WHEN NOT submit_status.normal

PROCEND activate_smtp
*DECK DECK=RAP$ACTIVATE_SYSTEM_LOGGING EXPAND=TRUE
create_command_description name=(activate_system_logging, actsl) ..
      sp=clp$activate_system_logging
*DECK DECK=RAP$ACTIVATE_SYSTEM_STATISTIC EXPAND=TRUE
create_command_description name=(activate_system_statistic, activate_system_statistics, actss) ..
      sp=sfp$activate_sys_stat_command
*DECK DECK=RAP$ACTIVATE_SYSTEM_TASK EXPAND=TRUE
create_command_description name=(activate_system_task, activate_system_tasks, actst) ..
      sp=clp$activate_system_task
*DECK DECK=RAP$ACTIVATE_XTF EXPAND=TRUE
*DECK DECK=RAP$ADD_CORRECTION_FORMAT EXPAND=FALSE

  PROCEDURE [XREF] rap$add_correction_format
    (    correction_format: rat$correction_format;
         element_count: rat$element_count;
     VAR element_p: ^rat$element;
     VAR subproduct_info_seq_p: ^rat$subproduct_info_sequence);


?? PUSH (LISTEXT := ON) ??
*copyc rat$subproduct_info_types
?? POP ??


*DECK DECK=RAP$ADD_NAME_TO_PATH_REF EXPAND=FALSE

  PROCEDURE [INLINE] rap$add_name_to_path_ref
    (    path_ref_p: ^fst$file_reference;
         name: ost$name;
     VAR sequence_p: ^SEQ ( * );
     VAR new_path_ref_p: ^fst$file_reference);

?? PUSH (LISTEXT := ON) ??


    VAR
      name_size: integer,
      path_size: integer;


    name_size := clp$trimmed_string_size (name);

    IF path_ref_p = NIL THEN
      NEXT new_path_ref_p: [name_size] IN sequence_p;
      new_path_ref_p^ (1, name_size) := name;
    ELSE
      path_size := clp$trimmed_string_size (path_ref_p^);
      NEXT new_path_ref_p: [path_size + name_size + 1] IN sequence_p;
      new_path_ref_p^ (1, path_size) := path_ref_p^;
      new_path_ref_p^ (path_size + 1, 1) := '.';
      new_path_ref_p^ (path_size + 2, name_size) := name;
    IFEND;

  PROCEND rap$add_name_to_path_ref;

{ PURPOSE:
{   This procedure adds a name to a file reference to create a new
{   file reference.
{
{ DESIGN:
{   If the file reference passed to the procedure contains a NIL pointer, then
{   the name is passed back as a file reference.
{   Else the file reference is concatenated with a period and the name and
{   then passed back to the calling procedure.
{
{ NOTES:
{
{

*copyc fst$file_reference
*copyc ost$name
*copyc clp$trimmed_string_size
?? POP ??
*DECK DECK=RAP$ADMINISTER_SECURITY_AUDIT_P EXPAND=TRUE
PROCEDURE administer_security_audit, admsa (
  scope, s: key
      (job, j)
      (system, s)
    keyend = system
  status)

  IF $file($system.audit.osf$audit_library permanent) THEN

" Call the utility via its program description.

    $system.audit.osf$audit_library.administer_security_audit_pd scope=scope
    include_file file=$command_of_caller utility=administer_security_audit
    QUIT
  ELSE
    EXIT procedure WITH $status(false, 'SF', sfe$audit_not_installed)
  IFEND

PROCEND administer_security_audit
*DECK DECK=RAP$ALTER_ACCESS_MODES EXPAND=TRUE
PROCEDURE alter_access_modes (
  status)

"  This procedure is executed after the installation of
"  $system.software_maintenance.raf$library.  This code
"  alters the access modes of some NOS/VE product files
"  to prevent sites from copying software for which they
"  are not licensed.

VAR
  ignore_status:  status
  version_catalogs : list of file = ()
  version_catalog_names : list of name = ()
  version : name
VAREND

" The CDCNET TIPS residing in the version catalog need to
" have the read permits deleted from all version catalogs
" that exist.

version_catalogs = $wild_card_files($system.cdcnet.version_* include_catalogs)
version_catalogs = $difference(version_catalogs $system.cdcnet.version_independent)
version_catalog_names = $apply(version_catalogs $name($path(x last)))

FOR EACH version IN version_catalog_names DO

  "bisync_3270_tip
  create_file_permit f=$system.cdcnet//version.di_products.bisync_3270_tip g=public am=execute status=ignore_status

  "high_speed_hdlc
  create_file_permit f=$system.cdcnet//version.di_products.high_speed_hdlc g=public am=execute status=ignore_status

  "mode_4_tip
  create_file_permit f=$system.cdcnet//version.di_products.mode4_tip g=public am=execute  status=ignore_status

  "monitor_tools
  create_file_permit f=$system.cdcnet//version.di_products.monitor_tools g=public am=execute status=ignore_status

  "cdcnet_network_validation
  create_file_permit f=$system.cdcnet//version.di_products.cdcnet_network_validation g=public am=execute ..
    status=ignore_status

  "service_access_control
  create_file_permit f=$system.cdcnet//version.di_products.service_access_control g=public am=execute ..
    status=ignore_status

  "terminal_passthrough
  create_file_permit f=$system.cdcnet//version.di_products.terminal_passthrough g=public am=execute ..
    status=ignore_status

  "tcp_ip_tip
  create_file_permit f=$system.cdcnet//version.di_products.tcp_ip_tip g=public am=execute ..
    status=ignore_status

  "cdcnet_tp0_cons
  create_file_permit f=$system.cdcnet//version.di_products.cdcnet_tp0_cons g=public am=execute ..
    status=ignore_status

  "x29_pad_server
  create_file_permit f=$system.cdcnet//version.di_products.x29_pad_server g=public am=execute ..
    status=ignore_status

  "x25_terminal_gateway
  create_file_permit f=$system.cdcnet//version.di_products.x25_terminal_gateway g=public am=execute ..
    status=ignore_status

FOREND

"cdcnet netcu
create_file_permit f=$system.cdcnet.netcu.bound_product g=public am=execute status=ignore_status

"nis
create_file_permit f=$system.tcp_ip.onc.yp_library g=public am=execute status=ignore_status

"nqs
create_file_permit f=$system.nqs.nqf$bound_66d g=public am=execute status=ignore_status
create_file_permit f=$system.nqs.nqf$bound_6dd g=public am=execute status=ignore_status

"tcp_ip_host
create_file_permit f=$system.tcp_ip.ftp_bound_product g=public am=execute status=ignore_status
create_file_permit f=$system.tcp_ip.inetd_bound_product g=public am=execute status=ignore_status
create_file_permit f=$system.tcp_ip.manta_bound_product g=public am=execute status=ignore_status
create_file_permit f=$system.tcp_ip.smtp_bound_product g=public am=execute status=ignore_status
create_file_permit f=$system.tcp_ip.lpd_bound_product g=public am=execute status=ignore_status

"rexec
create_file_permit f=$system.tcp_ip.rexec_bound_product g=public am=execute status=ignore_status

"tftp_ve
create_file_permit f=$system.tcp_ip.tftp_bound_product g=public am=execute  status=ignore_status

"accounting_analysis_system
create_file_permit f=$system.accounting_analysis_system.avf$bound_aas_34d_library g=public am=execute status=ignore_status
create_file_permit f=$system.accounting_analysis_system.avf$bound_aas_3dd_library g=public am=execute status=ignore_status

"accounting_utilities
create_file_permit f=$system.accounting_and_validation.avf$bound_33d_library g=public am=execute  status=ignore_status
create_file_permit f=$system.accounting_and_validation.avf$bound_3dd_library g=public am=execute  status=ignore_status

"ada
create_file_permit f=$system.ada.bound_product g=public am=execute status=ignore_status

"apl
create_file_permit f=$system.apl.bound_product g=public am=execute status=ignore_status

"archive_ve_queue_manager
create_file_permit f=$system.archive_ve.bound_36d_library g=public am=execute status=ignore_status
create_file_permit f=$system.archive_ve.bound_3dd_library g=public am=execute status=ignore_status

"assembler_ve
create_file_permit f=$system.assemble.bound_product g=public am=execute  status=ignore_status

"audit
create_file_permit f=$system.audit.osf$audit_library g=public am=execute status=ignore_status

"basic
create_file_permit f=$system.basic.bound_product g=public am=execute status=ignore_status

"cobol
create_file_permit f=$system.cobol.bound_product g=public am=execute status=ignore_status

"cybil
create_file_permit f=$system.cybil.bound_product g=public am=execute status=ignore_status

"cybilir
create_file_permit f=$system.cybilir.bound_product g=public am=execute status=ignore_status

"cv2
create_file_permit f=$system.cv2.bound_product g=public am=execute status=ignore_status

"data_encryption
create_file_permit f=$system.data_encryption.edf$bound_des_3dd_library g=public am=execute status=ignore_status

"dx_access_method
create_file_permit f=$system.dx.dx_bound_product g=public am=execute status=ignore_status

"fortran_version_1
create_file_permit f=$system.fortran.bound_product g=public am=execute status=ignore_status

"fortran_version_2
create_file_permit f=$system.fortran_version_2.bound_product g=public am=execute status=ignore_status

"ftam
create_file_permit f=$system.ftam.bound_product g=public am=execute status=ignore_status

"im_control
create_file_permit f=$system.control.bound_product g=public am=execute status=ignore_status

"im_fast
create_file_permit f=$system.fast.bound_product g=public am=execute status=ignore_status

"im_quick
create_file_permit f=$system.quick.bound_product g=public am=execute status=ignore_status

"im_smart
create_file_permit f=$system.smart.bound_product g=public am=execute status=ignore_status

"language_services
create_file_permit f=$system.lsf$lis_3dd_library g=public am=execute status=ignore_status

"lisp
create_file_permit f=$system.lisp.bound_product g=public am=execute  status=ignore_status

"network_archiving
create_file_permit f=$system.tcp_ip.netarc.command_66b_library g=public am=execute status=ignore_status

"network_validation
create_file_permit f=$system.network_validation.netval_bound_product g=public am=execute status=ignore_status

"network_transfer_facility
create_file_permit f=$system.network_transfer_facility.bound_product g=public am=execute status=ignore_status

"pascal
create_file_permit f=$system.pascal.bound_product g=public am=execute status=ignore_status

"ppe
create_file_permit f=$system.ppe.bound_product g=public am=execute status=ignore_status

"prolog
create_file_permit f=$system.prolog.bound_product g=public am=execute status=ignore_status

"ptf_qtf
create_file_permit f=$system.ptf_qtf.osf$user_file_transfer g=public am=execute status=ignore_status

"eta_rhfam
create_file_permit f=$system.rhfam.eta_access.bound_product g=public am=execute status=ignore_status

"rhfam
create_file_permit f=$system.rhfam.microcode_c180 g=public am=execute status=ignore_status

"rms
create_file_permit f=$system.rsf$bound_product_333 g=public am=execute status=ignore_status
create_file_permit f=$system.rsf$bound_product_46d g=public am=execute status=ignore_status
create_file_permit f=$system.rsf$bound_product_4dd g=public am=execute status=ignore_status
create_file_permit f=$system.rsf$bound_library_4dd g=public am=execute status=ignore_status

"sdf
create_file_permit f=$system.sdf.bound_product g=public am=execute status=ignore_status

"snap
create_file_permit f=$system.snap.libsnap g=public am=execute status=ignore_status

"xtf
create_file_permit f=$system.xtf.bound_product g=public am=execute status=ignore_status

"x_windows
create_file_permit f=$system.x11r4.bin.uil g=public am=execute status=ignore_status

PROCEND alter_access_modes
*DECK DECK=RAP$ASSEMBLE_INSTALLATION_PATH EXPAND=FALSE
  PROCEDURE [XREF] rap$assemble_installation_path
    (    system_catalog: rat$path;
         subproduct_info_pointers: rat$subproduct_info_pointers;
         path_selection: rat$subproduct_install_paths;
     VAR assembled_path_p: ^pft$path;
     VAR sequence_p: ^SEQ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc rat$subproduct_install_paths
*copyc rat$path
*copyc rat$subproduct_info_pointers
?? POP ??
*DECK DECK=RAP$ASSIGN_DEVICE EXPAND=TRUE
create_command_description name=(assign_device, assd) ..
      sp=clp$assign_device_command

*DECK DECK=RAP$ASSIGN_INSTALL_IDENTIFIER EXPAND=FALSE

  PROCEDURE [XREF] rap$assign_install_identifier
    (    installation_command: rat$installation_commands;
         installation_logs: rat$path;
         packing_list_name: ost$name;
     VAR installation_identifier: rat$installation_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc rat$installation_commands
*copyc rat$installation_identifier
*copyc rat$path
?? POP ??
*DECK DECK=RAP$ATTACH_INSTALLATION_TABLE EXPAND=FALSE

*copyc amt$local_file_name
*copyc ost$status

PROCEDURE [XREF] rap$attach_installation_table (
  VAR table_file:  amt$local_file_name;  VAR status: ost$status);

*DECK DECK=RAP$BIN_SEARCH EXPAND=FALSE
  PROCEDURE [XREF] rap$bin_search (name: ost$name;
        new_array: ^rat$match_decks;
    VAR j: rat$deck_index;
    VAR found: boolean);

*copyc ost$name
*copyc rat$match_decks

*DECK DECK=RAP$BRING_FORWARD_UNCOR_TIPS EXPAND=TRUE
PROCEDURE rap$bring_forward_uncor_tips (
  status)

  "$FORMAT=OFF
  VAR
    actual_di_object: file
    actual_di_products: file
    base_di_products: file
    cdcnet_tip: name
    list_of_actual_tips: list 0..$max_list of name
    list_of_base_tips: list 0..$max_list of name
    list_of_uncorrected_tips: list 0..$max_list of name
    local_status: status

    rav$subproduct_information: (XREF) rat$subproduct_information
  VAREND
  "$FORMAT=ON

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"  This routine updates DI_OBJECT in the actual installation catalog
"with CDCNET tips that were not corrected (ie. either CDCNET did not
"correct them, or the customer chose not to install a correction for
"a tip; this later constitutes an error that is warned about in the
"CDCNET correction documentation).  Only DI_OBJECT is updated with
"the uncorrected tips; DI_PRODUCTS is not updated.
"
"  The subcatalog DI_PRODUCTS in the actual version catalog and the
"base version catalog is used to determine the list of unocrrected
"tips.  A list of files in each DI_PRODUCTS subcatalog is generated
"and subtracted, leaving the list of uncorrected tips.  If the list
"has entries, each tip is added to DI_OBJECT in the actual installation
"catalog.
"
*IFEND


  actual_di_object = rav$subproduct_information.actual_installation_path.DI_OBJECT
  actual_di_products = rav$subproduct_information.actual_installation_path.DI_PRODUCTS
  base_di_products = rav$subproduct_information.base_level_path.DI_PRODUCTS

  rap$get_catalog_file_names c=actual_di_products ..
    names=list_of_actual_tips status=local_status
  EXIT procedure WITH local_status WHEN NOT local_status.normal

  rap$get_catalog_file_names c=base_di_products ..
    names=list_of_base_tips status=local_status
  EXIT procedure WITH local_status WHEN NOT local_status.normal

  list_of_uncorrected_tips = $difference(list_of_base_tips, list_of_actual_tips)

  IF NOT $nil(list_of_uncorrected_tips) THEN

    FOR each cdcnet_tip in list_of_uncorrected_tips DO
      update_library f=base_di_products//cdcnet_tip l=actual_di_object status=local_status
      EXIT procedure WITH local_status WHEN NOT local_status.normal
    FOREND

  IFEND

PROCEND rap$bring_forward_uncor_tips
*DECK DECK=RAP$BUILD_ELEMENT_LIST EXPAND=FALSE
  PROCEDURE [XREF] rap$build_element_list (table: ^rat$installation_table;
        name: ost$name;
    VAR element_list: ^array [1 .. *] of rat$element_descriptor;
    VAR last: rat$element_index;
    VAR status: ost$status);

*copyc rat$installation_table
*copyc ost$status
*copyc ost$name
*copyc rat$element_descriptor
*copyc rat$correction_package

*DECK DECK=RAP$BUILD_REPLACEMENT_SL EXPAND=FALSE
  PROCEDURE [XREF] rap$build_replacement_sl (source_file: rat$file_values;
        decks_ok: ^array [1 .. * ] of ost$name;
        replace_sl: ost$name;
    VAR status: ost$status);

*copyc clt$file_reference
*copyc ost$name
*copyc ost$status
*copyc rat$file_values
*DECK DECK=RAP$CHANGE_CONFIG_FILE_ACCESS EXPAND=TRUE
PROCEDURE rap$change_config_file_access (
  configuration_file_access, cfa: boolean = $required
  family_name, fn: name = $required
  user_name, un: name = $required
  status)

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"  Creates the catalogs $SYSTEM.SITE_OS_MAINTENANCE and
"$SYSTEM.SITE_OS_MAINTENANCE.DEADSTART_COMMANDS.
"
"  This procedure changes access for the user_name to the catalogs
"$SYSTEM.MAINFRAME.CONFIGURATION and $SYSTEM.SITE_OS_MAINTENANCE.

"  The configuration_file_access parameter allows
"these permissions to either be turned on or off.
"
*IFEND


  "$FORMAT=OFF
  VAR
    command_file: file = $unique($local)
    ignore_status: status
    local_status: status
  VAREND
  "$FORMAT=ON"


  IF NOT $job(system) THEN
    text = 'CHANGE_CONFIG_FILE_ACCESS' // $char(31) // 'except from the console'
    EXIT_PROC WITH $status(false, 'RA', rae$illegal_command_call, text)
  IFEND


COLLECT_TEXT o=command_file until='**'
  IF configuration_file_access THEN
    $system.create_file_permit $system.mainframe.configuration g=user fn=family_name u=user_name ..
          am=read
    $system.create_catalog $system.site_os_maintenance status=ignore_status
    $system.create_catalog $system.site_os_maintenance.deadstart_commands status=ignore_status
    $system.create_catalog_permit $system.site_os_maintenance ..
      g=user fn=family_name u=user_name am=(all cycle control)
  ELSE
    $system.delete_file_permit $system.mainframe.configuration g=user fn=family_name u=user_name
    $system.delete_catalog_permit $system.site_os_maintenance.deadstart_commands ..
      g=user fn=family_name u=user_name
  IFEND
**

  $system.include_file f=command_file status=local_status
  $system.delete_file f=command_file status=ignore_status

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$change_config_file_access

*DECK DECK=RAP$CHANGE_DATE EXPAND=TRUE
create_command_description name=(change_date, chad) sp=osp$_change_date
*DECK DECK=RAP$CHANGE_DEFAULT_DATE_FORMAT EXPAND=TRUE
create_command_description name=(change_default_date_format, chaddf) ..
      sp=osp$_change_default_date_format
*DECK DECK=RAP$CHANGE_DEFAULT_TIME_FORMAT EXPAND=TRUE
create_command_description name=(change_default_time_format, chadtf) ..
      sp=osp$_change_default_time_format
*DECK DECK=RAP$CHANGE_DUAL_STATE_ENVIRON EXPAND=TRUE
create_command_description name=(change_dual_state_environment, chadse) ..
      sp=rhp$change_dual_state_environ
*DECK DECK=RAP$CHANGE_FAMILY EXPAND=TRUE
create_command_description name=(change_family) sp=avp$change_family_command
*DECK DECK=RAP$CHANGE_JOB_ATTR_DEFAULT EXPAND=TRUE
create_command_description name=(change_job_attribute_default, change_job_attribute_defaults, chajad) ..
      sp=clp$change_job_attr_default_cmd
*DECK DECK=RAP$CHANGE_KILL_JOB_ACTION EXPAND=TRUE
create_command_description name=(change_kill_job_action, chakja) ..
      starting_procedure=jmp$_change_kill_job_action
*DECK DECK=RAP$CHANGE_NAM_ATTRIBUTES EXPAND=TRUE
create_command_description name=(change_nam_attributes, change_nam_attribute, chana) ..
      sp=nap$change_nam_attributes
*DECK DECK=RAP$CHANGE_PRIORITY EXPAND=TRUE
create_command_description name=(change_priority, chap) ..
      sp=clp$change_priority_command
*DECK DECK=RAP$CHANGE_TAPE_SCAN_FREQUENCY EXPAND=TRUE
create_command_description name=(change_tape_scan_frequency, chatsf) ..
      sp=clp$_change_tape_scan_freq_cmd
*DECK DECK=RAP$CHANGE_TAPE_VALIDATION EXPAND=TRUE
create_command_description name=(change_tape_validation, chatv) ..
      sp=clp$change_tape_validation_cmd
*DECK DECK=RAP$CHANGE_TIME EXPAND=TRUE
create_command_description name=(change_time, chat) sp=osp$_change_time
*DECK DECK=RAP$CHANGE_TIME_ZONE EXPAND=TRUE
create_command_description name=(change_time_zone, chatz) ..
      sp=osp$_change_time_zone

*DECK DECK=RAP$CHECKSUM_FILE EXPAND=FALSE

  PROCEDURE [XREF] rap$checksum_file
    (    file: fst$file_reference;
     VAR checksum: integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??



*DECK DECK=RAP$CHECK_FOR_DEFERRED_PRODUCTS EXPAND=TRUE
PROCEDURE (HIDDEN) rap$check_for_deferred_products (
  deferred_products, dp: (VAR) boolean = $required
  )

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure returns a boolean value based on whether or not there are deferred products to be
"   activated.
"
" NOTES:
"
"   If the directory file is not present, then we assume the customer is
"   upgrading from a system which does not have INSS (pre 1.4.1) and
"   therefore their cannot be deferred products.
"
"   If the include file returns the incompatible sequence then we
"   can't read the directory.  Therefore their are no deferred products
"   that we can process.
*IFEND

  "$FORMAT=OFF
  VAR
    command_file: file = $unique($local)
    ignore_status: status
    local_status: status
    rav$system: (XREF) file
  VAREND
  "$FORMAT=ON"

IF NOT $file(rav$system.software_maintenance.installation_database.raf$idb_directory, permanent) THEN
  $value(deferred_products) = FALSE
  EXIT procedure
IFEND

COLLECT_TEXT o=command_file
  install_software
    IF rav$system <> :$system.$system THEN
      change_installation_defaults system_catalog=rav$system
    IFEND
    $value(deferred_products)=$deferred_subproducts
  quit
**
  $system.include_file f=command_file status=local_status
  $system.delete_file f=command_file status=ignore_status

  IF NOT local_status.normal THEN
    $value(deferred_products) = FALSE
    IF (($condition(local_status.condition)='RAE$INCOMPATIBLE_SEQUENCE_LEVEL') OR ..
       ($condition(local_status.condition)='CLE$WRONG_KIND_OF_VALUE')) THEN
      local_status.normal = TRUE
    IFEND
  IFEND

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$check_for_deferred_products
*DECK DECK=RAP$CHECK_RHFAM_FOR_NAMVE EXPAND=TRUE
PROCEDURE (HIDDEN) rap$check_rhfam_for_namve (
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure checks the state of RHFAM and returns bad status if RHFAM has ever been activated
"   on the running system.
"
" DESIGN:
"   One of the restrictions placed on NAM/VE activation is that it cannot occur after the activation of
"   RHFAM because of shared buffer problems.  The status condition OSF$SYSTEM_TASK_NOT_DEFINED must be
"   returned by DISPLAY_SYSTEM_TASK_DATA before we can be sure RHFAM has not been activate at any time
"   since the last deadstart.
*IFEND


  "$FORMAT=OFF
  VAR
    local_status: status
    rav$event_message: (XREF) status
  VAREND
  "$FORMAT=ON"


  rav$event_message=$status(false, 'RA', rae$testing_error, 'for RHFAM')

  display_system_task_data task_name=rhfam o=$null status=local_status

  IF local_status.normal THEN
    local_status=$status(false, 'RA', rae$no_namve_due_to_rhfam)
  ELSEIF $condition(local_status.condition) = 'OSE$SYSTEM_TASK_NOT_DEFINED' THEN
    local_status.normal=true
  IFEND

  IF local_status.normal THEN
    rav$event_message.normal=true
  ELSE
    EXIT procedure WITH local_status
  IFEND

PROCEND rap$check_rhfam_for_namve
*DECK DECK=RAP$CHOOSE_NETWORK_TYPE EXPAND=TRUE
PROC choose_network_type (
  network_type: var of string
  status)

  create_variable choice k=string

main_loop: ..
  LOOP

    put_line ('1Choose Network Type'..
          '01. Define Channel Network (Mainframe to DI across Cyber channel) ' ..
          ' 2. Define ICA Access (Mainframe connection to network using an ICA) ' ..
          '0Enter a menu selection, QUIT, ?: ')

    choice = ' '
    accept_line choice input p=''

  IF choice = '1' THEN
    $value(network_type) = 'DEFINE_CHANNEL_NETWORK'
    EXIT main_loop
  ELSEIF choice = '2' THEN
    $value(network_type) = 'DEFINE_ICA_ACCESS'
    EXIT main_loop
  ELSEIF ($translate(lower_to_upper, choice) = 'QUIT') OR ($translate(lower_to_upper, choice) = 'QUI') THEN
    $value(network_type) = ' '
    EXIT main_loop
  ELSEIF choice = ' ' THEN
      " Do nothing if the user types-ahead."
  ELSEIF choice = '?' or ($translate(lower_to_upper, choice) = 'HELP') THEN

      put_line (..
            '0This menu prompts you to choose the type of network configuration ' ..
            ' on your mainframe. ' ..
            '01.  Select number 1 if your mainframe is connected to a CDCNET ' ..
            '     DI via a CYBER channel. '..
            '02.  Select number 2 if your mainframe is connected to the network ' ..
            '     via  an ICA.' ..
            '0Enter QUIT to return to the main menu without choosing a network ' ..
            '   type. '..
            '  ')
      accept_line choice input p='Press NEXT: '
  IFEND
  LOOPEND main_loop

PROCEND choose_network_type
*DECK DECK=RAP$CLEAR_INSTALLATION EXPAND=FALSE

  PROCEDURE [XREF] rap$clear_installation
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$COLLECT_DUMP_MATERIALS EXPAND=TRUE
PROCEDURE rap$collect_dump_materials (
  external_vsn, evsn, ev: any of
      string 1..6
      name 1..6
    anyend = $optional
  recorded_vsn, rvsn, rv: any of
      string 1..6
      name 1..6
    anyend = $optional
  type, t: key
      mt9$1600, mt9$6250, mt18$38000
    keyend = mt9$6250
  link_output_catalog, loc: file = $optional
  status)


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"    The purpose of this request is to collect the linker output
"files (JOB_TEMPLATE_LINK_MAP, SYSTEM_CORE_LINK_MAP and
"SYSTEM_DEBUG_TABLE) that are required for debugging a system
"altered by a site.  The collected files are written to the tape
"specified by either the EVSN or RVSN (or both). The parameter
"can optionally be specified to locate the files to be dumped; if this
"parameter is not specified, it is computed by using the level value
"returned from the procedure GET_SYSTEM_LEVEL.
*IFEND

*copyc rav$maids_file_catalog_names

  "$FORMAT=OFF
  VAR
    backup_jt_link_map: string
    backup_sc_link_map: string
    backup_system_debug_table: string
    command_file: file = $local//$name($unique)
    evsn_string: string 0..14 = ''
    jt_link_map: file
    ignore_status: status
    local_status: status

    nosve_link_input_catalog: file
    nosve_version_file: file
    output_vsn: string 0..5 = ''
    rvsn_string: string 0..14 = ''
    sc_link_map: file
    system_debug_table: file
    system_level: name
    text: string
  VAREND
  "$FORMAT=ON"


  WHEN any_fault DO
    EXIT procedure WITH osv$status
  WHENEND

  main_block: ..
    BLOCK

*copyc rav$system_root_variable

  IF NOT $specified(link_output_catalog) THEN
    nosve_version_file = rav$system//name_nosve_maintenance_catalog//name_link_input_catalog//name_os_version_file
    rap$get_system_level ovf=nosve_version_file sl=system_level status=local_status
    EXIT main_block WHEN NOT local_status.normal
    link_output_catalog = rav$system//name_site_maintenance_catalog//system_level//name_link_output_catalog
  IFEND

  jt_link_map = link_output_catalog//name_jt_link_map
  sc_link_map = link_output_catalog//name_sc_link_map
  system_debug_table = link_output_catalog//name_system_debug_table

  backup_jt_link_map = 'backup_file ' // $string(jt_link_map)
  backup_sc_link_map = 'backup_file ' // $string(sc_link_map)
  backup_system_debug_table = 'backup_file ' // $string(system_debug_table)

  IF $specified(external_vsn) THEN
    evsn_string = 'evsn=' // $quote($string(external_vsn))
    output_vsn = $string(external_vsn)
  IFEND
  IF $specified(recorded_vsn) THEN
    rvsn_string = 'rvsn=' // $quote($string(recorded_vsn))
    output_vsn = $string(recorded_vsn)
  IFEND

  collect_block: ..
    BLOCK

  IF output_vsn = '' THEN
    local_status = $status(FALSE, 'RA', rae$vsn_param_required, ' ')
    EXIT collect_block WHEN NOT local_status.normal
  IFEND

  IF NOT $file(jt_link_map, assigned) OR ($file(jt_link_map, size) <= 0) THEN
    backup_jt_link_map = ''
    $system.put_line ' Missing dump material file: '//$string(jt_link_map) o=$response
  IFEND
  IF NOT $file(sc_link_map, assigned) OR ($file(sc_link_map, size) <= 0) THEN
    backup_sc_link_map = ''
    $system.put_line ' Missing dump material file: '//$string(sc_link_map) o=$response
  IFEND
  IF NOT $file(system_debug_table, assigned) OR ($file(system_debug_table, size) <= 0) THEN
    backup_system_debug_table = ''
    $system.put_line ' Missing dump material file: '//$string(system_debug_table) o=$response
  IFEND
  IF (backup_jt_link_map = '') AND (backup_sc_link_map = '') AND (backup_system_debug_table = '') THEN
    local_status = $status(FALSE, 'RA', rae$missing_required_file, 'needed for the dump materials')
    EXIT collect_block WHEN NOT local_status.normal
  IFEND

  $system.put_line ' Submitting batch job to write dump materials to tape '//output_vsn o=$response

COLLECT_TEXT o=command_file until='END_COLLECT' sm='?'
  JOB jn=coldm jc=system
    $system.request_magnetic_tape f=$local.tape t=?type? ..
      ?evsn_string?  ?rvsn_string?  ring=true
    $system.backup_permanent_files bf=$local.tape l=$null
      ?backup_jt_link_map?
      ?backup_sc_link_map?
      ?backup_system_debug_table?
    quit
    $system.detach_file f=$local.tape
  JOBEND
END_COLLECT

  $system.include_file f=command_file status=local_status
  $system.detach_file f=command_file status=ignore_status

  BLOCKEND collect_block

  BLOCKEND main_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$collect_dump_materials
*DECK DECK=RAP$COMBINE_BUILTIN_LIBRARY EXPAND=TRUE
PROCEDURE rap$combine_builtin_library (
  nosve_builtin_library, nbl: file = $required
  site_builtin_library, sbl: file = $required
  builtin_library, bl: file = $required
  status)


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"   This procedure combines a site-specified version of the file
"   BUILTIN_LIBRARY with the system released version of BUILTIN_LIBRARY.
"   and places the result in the file specified by the parameter
"   BUILTIN_LIBRARY.
"
*IFEND


  "$FORMAT=OFF
  VAR
    command_file: file = $local//$name($unique)
    ignore_status: status
    local_status: status
  VAREND
  "$FORMAT=ON"


  IF $file(site_builtin_library permanent) THEN
    $system.put_line (' Merging '//$string(site_builtin_library)//' ..' ..
       '    with '//$string(nosve_builtin_library)) o=$response

COLLECT_TEXT o=command_file until='**'
  $system.CREATE_OBJECT_LIBRARY
    add_modules l=nosve_builtin_library
    combine_modules l=site_builtin_library
    generate_library l=builtin_library
  QUIT
**
    $system.include_file command_file status=local_status
    $system.delete_file command_file status=ignore_status

  IFEND

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$combine_builtin_library
*DECK DECK=RAP$COMBINE_NON_BOOT_DRIVERS EXPAND=TRUE
PROCEDURE rap$combine_non_boot_drivers (
  nosve_non_boot_drivers_file, nnbdf: file = $required
  site_non_boot_drivers_catalog, snbdc: file = $required
  non_boot_drivers_file, nbdf: file = $required
  status)

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"   The purpose of this request is to combine PP routines
"supplied by the site with the released version of the
"non_boot_drivers (specified by the first parameter).
"A catalog may optionally exist containing site-supplied PP
"routines.  If so, they are combined with the release version and
"placed on the non_boot_drivers_file.  If the site_non_boot_drivers
"catalog does not exist, this routine returns with a normal status.
"
*IFEND



  "$FORMAT=OFF
  VAR
    command_file: file = $local//$name($unique)
    format_status: status
    formatted_count: integer = 0
    formatted_pp: file = $local//$name($unique)
    ignore_status: status
    local_status: status
    pp_add_status: status
    pp_count: integer = 0
    pp_status: status
    scratch_file: file = $local//$name($unique)
    site_pp: string
  VAREND
  "$FORMAT=ON"


build_block: ..
  BLOCK

    rap$get_catalog_list c=site_non_boot_drivers_catalog fl=scratch_file ..
          d=1 fc=pp_count status=pp_status

    IF (NOT pp_status.normal) OR (pp_status.normal AND (pp_count = 0)) THEN
      EXIT build_block
    IFEND

    $system.put_line ' Builing new non_boot_drivers file ...' o=$response

    "$FORMAT=OFF
    VAR
      pp_files: array 1 .. pp_count of string
    VAREND
    "$FORMAT=ON"

    $system.accept_line v=pp_files i=scratch_file status=local_status
    $system.detach_file scratch_file status=ignore_status
    EXIT build_block WHEN NOT local_status.normal

COLLECT_TEXT o=command_file until='END FORMAT COLLECT' sm='?' status=local_status
    manage_deadstart_files
      create_binary_formatted_file
        add_record i=nosve_non_boot_drivers_file f=NVE_FILE
        FOR i = 1 TO pp_count DO
          site_pp = $path($fname(pp_files(i)), last)
          $system.include_line 'format_binary_record i=$fname(pp_files(i)) o=formatted_pp f=CIP_PERIPHERAL_PROCESSOR' ..
             status=format_status
          IF format_status.normal THEN
            formatted_count = formatted_count + 1
            $system.include_line 'add_record i=formatted_pp f=NVE_FILE' status=pp_add_status
            IF NOT pp_add_status.normal THEN
              $system.put_line $strrep($status(FALSE, 'RA', rae$unable_to_add_formatted_pp, pp_files(i)) o=$response
            IFEND
            $system.delete_file f=formatted_pp status=ignore_status
          ELSE
            $system.put_line $strrep($status(FALSE, 'RA', rae$unable_to_format_pp, site_pp)) o=$response
          IFEND
        FOREND
        generate_file o=non_boot_drivers_file ff=NVE_FILE
      quit
    quit
END FORMAT COLLECT


    $system.include_file f=command_file status=local_status
    $system.delete_file f=command_file status=ignore_status
    EXIT build_block WHEN NOT local_status.normal

    IF NOT (pp_count = formatted_count) THEN
      text = 'PP catalog ' // $string(site_non_boot_drivers_catalog)
      local_status = $status(false, 'RA', rae$not_all_files_processed, text)
    IFEND
    EXIT build_block WHEN NOT local_status.normal

  BLOCKEND build_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$combine_non_boot_drivers
*DECK DECK=RAP$COMBINE_SOU_LIBRARY EXPAND=TRUE
PROCEDURE rap$combine_sou_library (
  nosve_sou_library, nsl: file = $required
  site_sou_library, ssl: file = $required
  sou_library, sl: file = $required
  status)


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"   This procedure combines the site-specified versions of the file
"   SOU_LIBRARY with the system released version of SOU_LIBRARY,
"   and places the result in the file specified by the parameter
"   SOU_LIBRARY.
"
*IFEND


  "$FORMAT=OFF
  VAR
    command_file: file = $local//$name($unique)
    ignore_status: status
    local_status: status
  VAREND
  "$FORMAT=ON"

  IF $file(site_sou_library permanent) THEN
    $system.put_line (' Merging '//$string(site_sou_library)//' ..' ..
       '    with '//$string(nosve_sou_library)) o=$response

COLLECT_TEXT o=command_file until='**'
  $system.CREATE_OBJECT_LIBRARY
    add_modules l=nosve_sou_library
    combine_modules l=site_sou_library
    generate_library l=sou_library
  QUIT
**
    $system.include_file command_file status=local_status
    $system.delete_file command_file status=ignore_status

  IFEND

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$combine_sou_library
*DECK DECK=RAP$COMMIT_NEW_SYSTEM EXPAND=TRUE
PROCEDURE rap$commit_new_system (
  set_flag, sf: boolean = true
  status)

VAR
  local_status: status
VAREND


  IF $job(system) THEN
    dsp$commit_new_system set_flag status=local_status
  ELSE
    local_status = $status(FALSE, 'RA', rae$must_initiate_from_system,'COMMIT_NEW_SYSTEM')
  IFEND

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$commit_new_system
*DECK DECK=RAP$COMPARE_SL_DECKS EXPAND=FALSE
  PROCEDURE [XREF] rap$compare_sl_decks (deck_name: ost$name;
        old_path: clt$path_name;
        old_path_length: 1 .. clc$max_path_name_size;
        new_path: clt$path_name;
        new_path_length: 1 .. clc$max_path_name_size;
    VAR decks_dont_differ: boolean;
    VAR status: ost$status);

*copyc ost$name
*copyc clt$path_name
*copyc ost$status

*DECK DECK=RAP$CONFIGURE_LINES EXPAND=TRUE
PROCEDURE configure_lines (
di_procedure_file, dpf: string = $required
line_type, lt: key async_terminal, async_printer, keyend = $required
status)

  create_variable choice k=string
  create_variable cr_requested k=string
  create_variable first_file k=string v='$local.'//$unique
  create_variable ignore_status k=status
  create_variable lim k=string
  create_variable port k=string
  create_variable second_file k=string v='$local.'//$unique
  create_variable tup k=string
  create_variable parity k=string v=' '


configure_lines_loop: ..
  LOOP

If $string($value(line_type)) = 'ASYNC_TERMINAL' THEN
"$ format=off
    put_line (..
     '1Configure a line for an ASYNC terminal.'..
     '01. LIM number .......... '//lim..
     ' 2. PORT number ......... '//port..
     ' 3. TUP name ............ '//tup..
     '0Enter a menu selection, QUIT, GO, or ?:'..
    )
ELSEIF $string($value(line_type)) = 'ASYNC_PRINTER' THEN
"$ format=off
    put_line (..
     '1Configure a line for an ASYNC printer.'..
     '01. LIM number .......... '//lim..
     ' 2. PORT number ......... '//port..
     ' 3. Printer Parity ...... '//parity..
     '0Enter a menu selection, QUIT, GO, or ?:'..
    )
IFEND
"$ format=on
    choice = ' '
    accept_line choice input p=''

    IF choice = '1' THEN

      prompt_for_lim lim

    ELSEIF choice = '2' THEN

      prompt_for_port port

    ELSEIF choice = '3' THEN

      IF $string($value(line_type)) = 'ASYNC_TERMINAL' THEN
        prompt_for_tup tup
      ELSE
        prompt_for_printer_parity parity
      IFEND

    ELSEIF ($translate(lower_to_upper, choice) = 'QUIT') OR ($translate(lower_to_upper, choice) = 'QUI') THEN

      EXIT configure_lines_loop

    ELSEIF ((choice = '?') OR ($translate(lower_to_upper, choice) = 'HELP')) AND ..
         ($string($value(line_type)) = 'ASYNC_TERMINAL') THEN

"$ format=off
    put_line (..
     '1By default a terminal is defined on LIM 0 PORT 0.'..
     ' To define another terminal select: ' ..
     '0Number 1 to give the value of the LIM.' ..
     ' Number 2 to give the value of the PORT.' ..
     ' Number 3 to give the name of the TUP. ' ..
     '0You must give values for the LIM and the PORT, but ' ..
     ' the TUP value is optional. ' ..
    )
      accept_line cr_requested input p='Press NEXT: '
"$ format=on

    ELSEIF ((choice = '?') OR ($translate(lower_to_upper, choice) = 'HELP')) AND ..
         ($string($value(line_type)) = 'ASYNC_PRINTER') THEN

"$ format=off
    put_line (..
     '1This procedure defines a line between a CDCNET DI and an ASYNC printer.'..
     ' All printers are configured at a line speed of 9600 baud.' ..
     '0If the name of your Control Facility or Station Name is different than ' ..
     ' the defaults, be sure to change TDP PRINTER_WITHOUT_VFU.  Refer to the ' ..
     ' CDCNET Site Administration and Configuration Guide Appendix J for a' ..
     ' complete description of TDP PRINTER_WITHOUT_VFU.' ..
     '0The operator must define  Status Control Facility Server (SCFS),' ..
     ' Status Control Facility (SCF), Batch Transfer Facility (BTF), ' ..
     ' and Operator Station and activate SCFS and SCF before the printer will ' ..
     ' become active. ' ..
     '0To define an ASYNC printer select: ' ..
     '0Number 1 to give the value of the LIM.' ..
     ' Number 2 to give the value of the PORT.' ..
     ' Number 3 to give the PARITY of the printer. ' ..
    )
      accept_line cr_requested input p='Press NEXT: '
"$ format=on

    ELSEIF (choice = ' ') or ($translate(lower_to_upper, choice) = 'GO') THEN

      IF lim = ' ' THEN
        put_line '  '
        accept_line cr_requested input p='LIM is a required value.  Please enter a value for LIM, press NEXT: '
        CYCLE configure_lines_loop
      ELSEIF port = ' ' THEN
        put_line '  '
        accept_line cr_requested input p='PORT is a required value.  Please enter a value for PORT, press NEXT: '
        CYCLE configure_lines_loop
      IFEND

      IF ($string($value(line_type)) = 'ASYNC_PRINTER') AND (parity = ' ') THEN
        put_line '  '
        accept_line cr_requested input p='PARITY is a required value.  Please enter a value for PARITY, press NEXT: '
        CYCLE configure_lines_loop
      IFEND

      IF $string($value(line_type)) = 'ASYNC_TERMINAL' THEN
        IF tup <> ' ' THEN
          put_line l = 'define_line lim = '//lim//', port = '//port//..
', ln = line'//lim//port//', tn = asynctip, lt = dedicated'//..
', ar = scp, tup = '//tup o=$fname(first_file)
        ELSE
          put_line l = 'define_line lim = '//lim//', port = '//port//..
', ln = line'//lim//port//', tn = asynctip, lt = dedicated'//..
', ar = scp ' o=$fname(first_file)
        IFEND
      ELSEIF $string($value(line_type)) = 'ASYNC_PRINTER' THEN
        put_line l = 'define_line lim = '//lim//', port = '//port//..
', ln = line'//lim//port//', tn = asynctip, lt = dedicated'//..
', ls=9600, tdp = PRINTER_WITHOUT_VFU data_parity = '//parity o=$fname(first_file)
      IFEND
      EXIT configure_lines_loop
    ELSE

      put_line '  '
      accept_line cr_requested input p='Invalid selection, press NEXT: '

    IFEND
  LOOPEND configure_lines_loop

  copy_file i=$fname($value(di_procedure_file)) o=$fname(second_file) status=ignore_status
  copy_file i=$fname(first_file) o=$fname($value(di_procedure_file)) status=ignore_status
  copy_file i=$fname(second_file) o=$fname($value(di_procedure_file)//'.$eoi') status=ignore_status
  detach_file $fname(first_file) status=ignore_status
  detach_file $fname(second_file) status=ignore_status

PROCEND configure_lines
*DECK DECK=RAP$CONVERT_JOB_RECORD_TO_STRS EXPAND=FALSE

  PROCEDURE [XREF] rap$convert_job_record_to_strs
    (    job_status_record: rat$job_status_record;
     VAR job_status_strings {output} : rat$job_status_record_strs;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
*copyc rat$job_status_record_strs
?? POP ??
*DECK DECK=RAP$CONVERT_PATH_TO_PF_FORMAT EXPAND=TRUE

  PROCEDURE [XREF] rap$convert_path_to_pf_format
    (    catalog_path: rat$path;
     VAR pf_destination_p: ^pft$path;
     VAR processing_seq_p: ^rat$processing_sequence;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$CONVERT_PATH_TO_STR EXPAND=FALSE

  PROCEDURE [INLINE] rap$convert_path_to_str
    (    path: pft$path;
     VAR path_str: rat$path);

?? PUSH (LISTEXT := ON) ??

    VAR
      fs_path: fst$path,
      fs_path_size: fst$path_size;


    pfp$convert_pft$path_to_fs_path (path, fs_path, fs_path_size);

    path_str.path := fs_path;
    path_str.size := fs_path_size;

  PROCEND rap$convert_path_to_str;

{ PURPOSE:
{   This procedure converts the PF path array into a string format usable
{   as a file reference for further processing.
{
{ DESIGN:
{   The conversion is done by another interface.  The values returned are
{   repackaged into a record type that is usable by STRINGREP (which is
{   used in building paths).
{
{ NOTES:
{

*copyc pfp$convert_pft$path_to_fs_path
?? POP ??

*DECK DECK=RAP$CONVERT_STATUS EXPAND=FALSE

*copyc cld$variable_reference
*copyc ost$status

  PROCEDURE [XREF] rap$convert_status (clv$status: clt$status;
    VAR osv$status: ost$status);

*DECK DECK=RAP$COPY_CONFIGURATION_FILES EXPAND=TRUE
PROCEDURE rap$copy_configuration_files (
  configuration_files_catalog, cfc: file = $required
  deadstart_catalog, dc: file = $required
  status)

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"   This procedure copies the files DCFILE, PROLOG_LIBRARY, and
"PHYSICAL_CONFIG from teh configuration files catalog to their
"appropriate places in the deadstart catalog.  These files will
"only be copies if they exist.
"
*IFEND


*copyc rav$maids_file_catalog_names

  "$FORMAT=OFF
  VAR
    command_file: file = $unique($local)
    ignore_status: status
    lcu_mainframe_subcommands: file = $unique($local)
    lcu_status: status
    local_status: status
    message: string

    new_dcfile: file
    new_lcu_mainframe_subcommands: file
    new_physical_config: file
    new_prolog_library: file

    old_prolog_file: file

    site_dcfile: file
    site_physical_config: file
    site_physical_configuration: file
    site_prolog_library: file
  VAREND
  "$FORMAT=ON"

  site_dcfile = configuration_files_catalog//name_dcfile
  site_physical_config = configuration_files_catalog//name_physical_config
  site_physical_configuration = configuration_files_catalog//name_physical_configuration
  site_prolog_library = configuration_files_catalog//name_prolog_library

  new_dcfile = deadstart_catalog//name_dcfile
  new_lcu_mainframe_subcommands = deadstart_catalog//name_mf_config_files.LCU_MF_SUBCMDS
  new_physical_config = deadstart_catalog//name_mf_config_files//name_physical_config
  new_prolog_library = deadstart_catalog//name_mf_config_files//name_prolog_library

  old_prolog_file = configuration_files_catalog//name_prolog_file

copy_block: ..
  BLOCK

    IF $file(site_dcfile, permanent) THEN
      $system.put_line l=(' Copying file '//$string(site_dcfile)//' to '//$string(new_dcfile))..
             o=$job_log
      $system.copy_file site_dcfile new_dcfile status=local_status
      EXIT copy_block WHEN NOT local_status.normal
    ELSE
      $system.put_line l=(' '//$string(site_dcfile)//' does not exist, DCFILE not replaced.') o=$job_log
    IFEND

    IF ($file(site_physical_config, permanent)) OR ($file(site_physical_configuration, permanent)) THEN
      IF $file(site_physical_config, permanent) THEN
        $system.put_line l=(' Copying file '//$string(site_physical_config)//' to '//$string(new_physical_config))..
               o=$job_log
        $system.copy_file site_physical_config new_physical_config status=local_status
      ELSE
        $system.put_line l=(' Copying file '//$string(site_physical_configuration)//' to '//$string(new_physical_config))..
               o=$job_log
        $system.copy_file site_physical_configuration new_physical_config status=local_status
      IFEND
      EXIT copy_block WHEN NOT local_status.normal
    ELSE
      $system.put_line l=(' '//$string(site_physical_config)//' does not exist, PHYSICAL_CONFIG not replaced.')..
             o=$job_log
    IFEND

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"   At release L716 the format of the prolog file changed.  If a new format
"   prolog file does not already exist, but an old format prolog file is
"   present, pass the old format prolog file into a converter that creates
"   a new format prolog file from the old format prolog file.
*IFEND

    IF (NOT $file(site_prolog_library, permanent)) AND ($file(old_prolog_file, permanent)) THEN
      cmp$convert_config_prolog pf=old_prolog_file npl=site_prolog_library status=local_status
      IF NOT local_status.normal THEN
        $system.put_line l=(' The following error occured while converting ', ..
                              '   '//$strrep(old_prolog_file)//' to ', ..
                            '   '//$strrep(site_prolog_library), ..
                            '   '//$strrep(local_status)) o=$response
        EXIT copy_block
      IFEND
    IFEND

    IF $file(site_prolog_library, permanent) THEN
      $system.put_line l=(' Copying file '//$string(site_prolog_library)//' to '//$string(new_prolog_library))..
             o=$job_log
      $system.copy_file site_prolog_library new_prolog_library status=local_status
      EXIT copy_block WHEN NOT local_status.normal
COLLECT_TEXT command_file until='**'
        $system.create_object_library
          add_module l=site_prolog_library
          generate_library l=lcu_mainframe_subcommands f=sp
          quit
        $system.delete_file f=$local.lcu_mainframe_subcommands status=ignore_status
        $system.delete_file f=$local.pcu_subcommands status=ignore_status
        $system.delete_file f=$local.lcu_network_subcommands status=ignore_status
        $system.include_command $strrep(lcu_mainframe_subcommands)
        $system.copy_file $local.lcu_mainframe_subcommands new_lcu_mainframe_subcommands
        $system.delete_file f=$local.lcu_mainframe_subcommands status=ignore_status
        $system.delete_file f=$local.pcu_subcommands status=ignore_status
        $system.delete_file f=$local.lcu_network_subcommands status=ignore_status
        $system.delete_file f=lcu_mainframe_subcommands status=ignore_status
**
      $system.include_file f=command_file status=lcu_status
      $system.delete_file f=command_file status=ignore_status
      IF NOT lcu_status.normal THEN
        $system.put_line l=(' The following error occured while creating LCU_MF_SUBCMDS - skipping this file ', ..
          $strrep(lcu_status)) o=$response
      IFEND
    ELSE
      $system.put_line l=(' '//$string(site_prolog_library)//' does not exist, PROLOG_LIBRARY not replaced.')..
             o=$job_log
    IFEND

  BLOCKEND copy_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$copy_configuration_files
*DECK DECK=RAP$COPY_PARTITION EXPAND=FALSE

PROCEDURE [XREF] rap$copy_partition (input_fid: amt$file_identifier;
        output_fid: amt$file_identifier;
    VAR file_position: amt$file_position;
        starting_input_record: boolean;
        starting_output_record: boolean;
    VAR status: ost$status);

*copyc amt$file_identifier
*copyc amt$file_position
*copyc ost$status



*DECK DECK=RAP$COPY_PROCESSOR_JOB_FILES EXPAND=TRUE
PROCEDURE rap$copy_processor_job_files (
  processor, p: any of
      key
        all
      keyend
      list of key
        (mag_tape,mt), (mag_tape_rms,mtr), (cartridge_tape,ct), (cartridge_tape_rms,ctr),
        (pseudo_tape,pt), (cartridge_storage_system,css), (clustered_mainframes,cm),
        (archive_to_nos,atn)
      keyend
    anyend = $required
  status)

" This procedure copies the proper archive/VE processor jobs to the
" catalog $SYSTEM.ARCHIVE_VE.PROCESSOR_JOBS.  The user may specify
" multiple processors.
"
" This procedure will exit when any error occurs rather than continue
" because if the input files are not present, there is some other problem
" that must be addressed (i.e. the files did not install properly).  This
" approach was taken because re-running this procedure will not cause
" any problems because we do a straight copy of the files and do not deal with
" cycles.

WHEN any_fault DO
  display_value osv$status o=$response
  EXIT_PROC
WHENEND


  "$FORMAT=OFF"
  VAR
    cartridge_storage_sys_catalog : file = $system.archive_ve.cartridge_storage_system
    clustered_mainframes_catalog : file = $system.archive_ve.clustered_mainframes
    ignore_status : status
    magnetic_tape_catalog : file = $system.archive_ve.magnetic_tape
    nos_7990_catalog : file = $system.archive_ve.nos_7990
    processor_jobs_catalog : file = $system.archive_ve.processor_jobs
    processor_list        : list 1..8 of name

  VAREND
  "$FORMAT=ON"

  IF $generic_type(processor) = key THEN
  " Assume the entry was ALL.
    processor_list = (mag_tape, mag_tape_rms, cartridge_tape, cartridge_tape_rms, ..
          pseudo_tape, cartridge_storage_system, clustered_mainframes, archive_to_nos)
  ELSE
    processor_list = $apply(processor $name(x))
  IFEND

  create_catalog c=processor_jobs_catalog status=ignore_status

  IF $subset(mag_tape, processor_list) THEN

" Copy files necessary to run archive/VE with magnetic tape.

    copy_file i=magnetic_tape_catalog.arf$magnetic_tape ..
          o=processor_jobs_catalog.arf$magnetic_tape
  IFEND

  IF $subset(mag_tape_rms, processor_list) THEN

" Copy files necessary to run archive/VE with magnetic tape with RMS.

    copy_file i=magnetic_tape_catalog.arf$rms_magnetic_tape ..
          o=processor_jobs_catalog.arf$rms_magnetic_tape
  IFEND

  IF $subset(cartridge_tape, processor_list) THEN

" Copy files necessary to run archive/VE with cartridge tape.

    copy_file i=magnetic_tape_catalog.arf$cartridge_tape ..
          o=processor_jobs_catalog.arf$cartridge_tape
  IFEND

  IF $subset(cartridge_tape_rms, processor_list) THEN

" Copy files necessary to run archive/VE with cartridge tape with RMS.

    copy_file i=magnetic_tape_catalog.arf$rms_cartridge_tape ..
          o=processor_jobs_catalog.arf$rms_cartridge_tape
  IFEND

  IF $subset(pseudo_tape, processor_list) THEN

" Copy files necessary to run archive/VE with pseudo tape.

    copy_file i=magnetic_tape_catalog.arf$pseudo_tape ..
          o=processor_jobs_catalog.arf$pseudo_tape
  IFEND

  IF $subset(cartridge_storage_system, processor_list) THEN

" Copy file necessary to run archive/VE with Cartridge Storage System.

    copy_file i=cartridge_storage_sys_catalog.arf$cartridge_storage_system ..
          o=processor_jobs_catalog.arf$cartridge_storage_system
  IFEND

  IF $subset(clustered_mainframes, processor_list) THEN

" Copy files necessary to run archive/VE with clustered mainframes.

    copy_file i=clustered_mainframes_catalog.arf$remote_processors ..
          o=processor_jobs_catalog.arf$remote_processors
  IFEND

  IF $subset(archive_to_nos, processor_list) THEN

" Copy file necessary to run archive/VE with 7990-NOS Option.

    copy_file i=nos_7990_catalog.arf$archive_to_nos ..
          o=processor_jobs_catalog.arf$archive_to_nos
  IFEND

PROCEND rap$copy_processor_job_files
*DECK DECK=RAP$CORRECT_PRODUCTS EXPAND=FALSE

  PROCEDURE [XREF] rap$correct_products
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR subproducts_failed_processing: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$CORRECT_SOURCE_LIBRARY EXPAND=FALSE
  PROCEDURE [XREF] rap$correct_source_library (base_file: clt$file;
        target_file: clt$file;
        correction: ^SEQ ( * );
    VAR status: ost$status);

*copyc clt$file
*copyc ost$status
*DECK DECK=RAP$CREATE_AAM_FILES EXPAND=TRUE
PROCEDURE (HIDDEN) rap$create_aam_files (
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure creates the AAM lock and dependency files plus the
"   shared recovery log.
"
" NOTES:
"   In order to execute the AAM utilities in this procedure, the local
"   files AAF$44D_LIBRARY, AAF$4DD_LIBRARY, MLF$LIBRARY, SMF$LIBRARY,
"   and CYF$RUN_TIME_LIBRARY must exist and $SYSTEM.OSF$COMMAND_LIBRARY
"   must be on the command list.  The procedure assumes that all of these
"   products have been installed.
"
"   Executing ADMINISTER_RECOVERY_LOG utility displays messages to the
"   $ERRORS file.  These messages are redirected to the $JOB_LOG
"   by this procedure.
"
"   To facilitate running this procedure in test mode (ie.  from a terminal
"   running in ring 11), the variable rav$system is used.  Whenever the
"   value of the variable is not :$SYSTEM.$SYSTEM, then the procedure is in
"   test mode and commands commands requiring priviledge are skipped.
"
"   In order to delete the shared recovery log, use the commands:
"     administer_recovery_log
"       delete_log c=<shared_recovery_log catalog name> rc=no
"     quit
*IFEND

  "$FORMAT=OFF"
  VAR
    aam_catalog: file
    command_file: file = $unique($local)
    delete_status: status
    dependency_file_cycle: integer 1..999 = 7
    dependency_file_path: file
    execution_ring : integer 3..15
    ignore_status: status
    local_status: status
    lock_file_cycle: integer 1..999 = 7
    lock_file_path : file
    rav$system: (xref) file
    running_in_test_mode: boolean = (rav$system <> :$system.$system)
    shared_recovery_log_path: file
  VAREND
  "$FORMAT=ON"

  aam_catalog = rav$system.aam
  dependency_file_path = aam_catalog.AAF$DEPENDENCY_FILE
  lock_file_path = aam_catalog.AAF$LOCK_FILE
  shared_recovery_log_path = aam_catalog.SHARED_RECOVERY_LOG

install_block: ..
  BLOCK

    PUSH file_connections
    $system.delete_file_connection sf=$errors f=$local.output status=ignore_status
    $system.create_file_connection sf=$errors f=$job_log status=ignore_status

    " Delete old lock and dependency files.  Number of cycles unknown.

    IF running_in_test_mode THEN
      execution_ring = 11
    ELSE
      execution_ring = 4
    IFEND

    TASK ring=execution_ring

      REPEAT
        $system.delete_file f=lock_file_path status=delete_status
      UNTIL NOT delete_status.normal

      REPEAT
        $system.delete_file f=dependency_file_path status=delete_status
      UNTIL NOT delete_status.normal

    TASKEND

    " Create the dependency file.  This code is older than history itself.

    dependency_file_path = dependency_file_path//dependency_file_cycle

    $system.create_file f=dependency_file_path lfn=dependency
    $system.set_file_attributes f=dependency_file_path file_limit=100000
COLLECT_TEXT o=dependency_file_path
**
    $system.change_file_attributes $local.dependency fl=1000000
    $system.detach_file $local.dependency status=ignore_status
    $system.create_file_permit f=dependency_file_path g=public am=(read modify shorten append) sm=none
    IF NOT running_in_test_mode THEN
      $system.change_file_attributes f=dependency_file_path ra=(4 4 4) file_limit=100000000
    IFEND
    $system.change_catalog_entry f=dependency_file_path nl=yes

    " Create the lock file.

    lock_file_path = lock_file_path//lock_file_cycle

COLLECT_TEXT o=command_file until='COLLECT_END'
    ADMINISTER_LOCK_FILE
      use_lock_file lf=lock_file_path
      create_lock_file private=false
    QUIT
COLLECT_END

    $system.include_file command_file status=local_status
    $system.delete_file command_file status=ignore_status

    EXIT install_block WHEN NOT local_status.normal

    " Create the recovery log.

    IF running_in_test_mode THEN
      execution_ring = 11
    ELSE
      execution_ring = 6
    IFEND

    $system.create_catalog c=shared_recovery_log_path status=local_status

    IF local_status.normal THEN
      $system.create_catalog_permit c=shared_recovery_log_path group=public access_mode=(read write) ..
            share_mode=none
    IFEND

    IF (local_status.normal) OR ($condition(local_status.condition) = 'PFE$NAME_ALREADY_SUBCATALOG') THEN

COLLECT_TEXT o=command_file until='COLLECT_END'
  TASK ring=execution_ring
    ADMINISTER_RECOVERY_LOG
      use_log c=shared_recovery_log_path
      configure_log_residence status=ignore_status
    QUIT
  TASKEND
COLLECT_END

      $system.include_file command_file status=local_status
      $system.delete_file command_file status=ignore_status

    IFEND

    POP file_connections

  BLOCKEND install_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$create_aam_files
*DECK DECK=RAP$CREATE_AAM_RECOVERY_LOG EXPAND=TRUE
PROCEDURE (HIDDEN) rap$create_aam_recovery_log (
  status)

*copy rav$system_paths

  "$FORMAT=OFF
  VAR
    command_file: file = $fname($unique)
    ignore_status: status
    local_status: status
    aam_recovery_log: file = rav$system.aam.shared_recovery_log
  VAREND
  "$FORMAT=ON"

  $system.create_catalog c=aam_recovery_log status=local_status

  IF local_status.normal THEN
    $system.create_catalog_permit c=aam_recovery_log group=public access_mode=(read write) ..
          share_mode=none
  IFEND

  IF (local_status.normal) OR ($condition(local_status.condition)= 'PFE$NAME_ALREADY_SUBCATALOG') THEN

COLLECT_TEXT command_file until='COLLECT_END'
  TASK ring=6
    PUSH command_list
    $system.create_command_list_entry e=$system.osf$command_library
    ADMINISTER_RECOVERY_LOG
      use_log c=aam_recovery_log
      configure_log_residence status=ignore_status
    QUIT
    POP command_list
  TASKEND
COLLECT_END

    $system.include_file command_file status=local_status
    $system.delete_file command_file status=ignore_status

  IFEND

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$create_aam_recovery_log
*DECK DECK=RAP$CREATE_BLANK_LABELED_VOLUME EXPAND=TRUE
create_command_description name=(create_blank_labeled_volume, creblv) ..
      sp=rmp$create_blank_labeled_volume
*DECK DECK=RAP$CREATE_BLANK_UNLABELED_VOL EXPAND=TRUE
create_command_description name=(create_blank_unlabeled_volume, crebuv) ..
      sp=rmp$create_blank_unlabeled_vol
*DECK DECK=RAP$CREATE_DEFAULT_FAMILY EXPAND=TRUE
PROCEDURE rap$create_default_family (
  family_name, fn: name = $required
  user_name, un: name = $required
  password, pw, p: (SECURE) name = $required
  account_name, an: name = NONE
  project_name, pn: name = NONE
  permanent_file_set, pfs: name = $optional
  status)

*IF $variable(wev$prod_doc,declared)<>'UNKNOWN'
"
"   This procedure performs several miscellaneous tasks which must be
"performed during an initial installation.
"
"  1.  Create the family specified in the parameter FAMILY_NAME, and
"      define the specified password.  If account or project level validations
"      are planned, specify the account and/or project name parameters.
"      This prevents a possible deadlock situation if in the future, the
"      site uses a validation level other than user.  If so, a log on to
"      the family administrator user name would fail unless the validation
"      level was temporarily set to user, the account and/or project name
"      set for the administrator user, and the appropriate validation level
"      reset to what it was previously.
"
"  2.  Make this family the default login family by executing the
"      approriate system command, and also by placing this command
"      in the system_initiation_prolog.
"
"  3.  Calls the procedure to allow the user_name access to the
"      configuration files.
"
"  4.  Copies the released version of PHYSICAL_CONFIG to the site's
"      version in the configuration file catalog.
"
"  5.  Creates file permits for user_name to the files
"      $SYSTEM.MANUALS.SITE_ANALYST_EXAMPLES, and
"      $SYSTEM.MANUALS.EXAMPLES_FILES.SITE_ANALYST_SOURCE.
"
"
*IFEND


  "$FORMAT=OFF
  VAR
    ignore_status: status
    local_status: status
    validation_file: string
  VAREND
  "$FORMAT=ON"

setup_block: ..
  BLOCK

  IF NOT $specified(permanent_file_set) THEN
    $system.osf$sou_library.create_family family_name=family_name family_user_administrator=user_name ..
          password=password account_name=account_name project_name=project_name status=local_status
  ELSE "permanent_file_set was specified
    $system.osf$sou_library.create_family family_name=family_name family_user_administrator=user_name ..
          password=password account_name=account_name project_name=project_name ..
          permanent_file_set=permanent_file_set status=local_status
  IFEND
  EXIT setup_block WHEN NOT local_status.normal

  $system.put_line 'change_job_attribute_default login_family='//$string(family_name) ..
        o=$system.prologs_and_epilogs.system_initiation_prolog.$eoi status=local_status
  EXIT setup_block WHEN NOT local_status.normal

  $system.osf$sou_library.change_job_attribute_default login_family=family_name ..
    status=local_status
  EXIT setup_block WHEN NOT local_status.normal

  change_config_file_access configuration_file_access=on fn=family_name un=user_name ..
    status=local_status
  EXIT setup_block WHEN NOT local_status.normal

  $system.copy_file i=$system.mainframe.configuration ..
        o=$system.site_os_maintenance.deadstart_commands.physical_config status=local_status
  EXIT setup_block WHEN NOT local_status.normal

  $system.detach_file $system.mainframe.configuration status=ignore_status
  $system.detach_file $system.site_os_maintenance.deadstart_commands.physical_config status=ignore_status

  $system.create_file_permit f=$system.manuals.site_analyst_examples g=user fn=family_name u=user_name ..
    am=(read execute) status=local_status
  EXIT setup_block WHEN NOT local_status.normal

  $system.create_file_permit f=$system.manuals.examples_files.site_analyst_source_library g=user ..
        fn=family_name u=user_name am=(read execute) status=local_status
  EXIT setup_block WHEN NOT local_status.normal

  BLOCKEND setup_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$create_default_family

*DECK DECK=RAP$CREATE_DMROOT_USER_NAME EXPAND=TRUE
PROCEDURE rap$create_dmroot_user_name, credun (
  password, pw: (secure) name = $required
  family, f: name = NVE
  account_name, an: name = NONE
  project_name, pn: name = NONE
  scheduling_class, sc: name = DM_KERNEL
  status)

  "$FORMAT=OFF"
  VAR
    local_status       : status
    ignore_status      : status
    job_complete       : boolean
    command_file       : file = $fname($unique)
    scratch_file       : file = $fname($unique)
    dmroot_catalog     : file
  VAREND
  "$FORMAT=ON"

create_block: BLOCK

COLLECT_TEXT o=command_file sm='?'

  ADMINISTER_VALIDATIONS
    use_validation_file vf=:?family?.$system.$validations
    CREATE_USER u=dmroot
      change_login_password npw=password
      change_ring_privilege minr=4
      change_job_class add=scheduling_class
      change_default_account_project account=account_name project=project_name
    QUIT
  QUIT
**

include_file f=command_file status=local_status
delete_file f=command_file status=ignore_status

EXIT create_block WHEN NOT local_status.normal

COLLECT_TEXT o=scratch_file sm='?'
      login u=dmroot pw=?password? lf=?family?
      logout
**
  submit_job f=scratch_file ujn=dmroot_job_name
  delete_file f=scratch_file

REPEAT
  wait 5000
UNTIL $job_status(dmroot_job_name, job_state) <> INITIATED

dmroot_catalog=$fname(':'//family//'.dmroot')
display_catalog c=dmroot_catalog status=local_status o=$null

BLOCKEND   create_block

EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$create_dmroot_user_name

*DECK DECK=RAP$CREATE_ELEMENT_LIST EXPAND=FALSE

  PROCEDURE [XREF] rap$create_element_list
    (    catalog_ref_p: ^fst$file_reference;
         catalog_path: pft$path;
         validation_selections: rat$validation_selections;
         checksum_files: boolean;
     VAR validation_errors: boolean;
     VAR subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc rat$subproduct_info_pointers
*copyc rat$validation_selections
?? POP ??
*DECK DECK=RAP$CREATE_FAMILY EXPAND=TRUE
create_command_description name=(create_family) sp=avp$create_family_command lo=manual
*DECK DECK=RAP$CREATE_INSTALLATION_ENV EXPAND=TRUE
PROCEDURE create_installation_environment, creie (
  status)

  VAR
    command_table: file = $unique($Local)
    ignore_status: status
  VAREND


$system.collect_text o=command_table
  command n=(change_config_file_access, chacfa) p=rap$change_config_file_access
  command n=(create_default_family, credf) p=rap$create_default_family
  command n=(create_dmroot_user_name, credun) p=rap$create_dmroot_user_name
  command n=(create_profile_for_upgrade, crepfu) p=rap$create_profile_for_upgrade
  command n=(create_scheduling_class, create_scheduling_classes, cresc) ..
          p=rap$create_scheduling_class
  IF $file($system.archive_ve catalog) THEN
    command n=(copy_processor_job_files,coppjf) p=rap$copy_processor_job_files
    command n=(update_sysfiles_for_archive,updsfa) p=rap$update_sysfiles_for_archive
  IFEND
  IF $file($system.nqs catalog) THEN
    command n=(install_nqs, insn) p=rap$install_nqs
  IFEND
  command n=(quit, qui) p=rap$quit_creie
TABLEND
**


  UTILITY n=create_installation_environment p='creie' ..
    l=$system.software_maintenance.raf$library ..
    t=command_table

    $system.delete_file f=command_table status=ignore_status
    $system.include_file f=$command_of_caller u=$utility(name)

  UTILITYEND

PROCEND create_installation_environment

*DECK DECK=RAP$CREATE_OPERATOR_ENVIRONMENT EXPAND=TRUE
PROCEDURE (hidden) rap$create_operator_environment (
  output_file, of: file = $job_log
)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure creates the operator's environment by setting up the command list, the local files
"   and the library list.
"
" DESIGN:
"   The degree to which this procedure can setup the environment depends on the state of the system at
"   the time of execution.  RAP$CREATE_OPERATOR_ENVIRONMENT will setup the environment as complete as
"   possible.  Bad status will only be displayed to OUTPUT_FILE.
"
" NOTES:
"   The path variable RAV$BUILTIN_LIBRARY allows for internal checkout.
"   The variables RAV$SET_OPERATOR_COMMAND_LIST and RAV$SET_OPERATOR_LIBRARY_LIST
"   allow the site to retain their modifications to the command list and library list
"   even when we reset them.
"   This procedure does not exit with status since it is designed handle all errors
"   itself and need not communicate with the caller via a STATUS variable.
*IFEND


  WHEN any_fault DO
    $system.put_line ' '//$strrep(osv$status) o=output_file
  WHENEND

  "$FORMAT=OFF
  VAR
    rav$accounting_utils_library: (XREF) file
    rav$builtin_library: (XREF) file
    ignore_status: status
    local_status: status
  VAREND
  "$FORMAT=ON"

  PUSH file_connections
  $system.delete_file_connection sf=$errors f=$local.output
  $system.create_file_connection sf=$errors f=output_file

  create_command_list_block: ..
  BLOCK
    $system.set_command_list delete=all
    $system.set_command_list add=($local, $system.osf$operator_command_library, $system.osf$sou_library, ..
          rav$builtin_library, $system) system_command_library=$system.osf$command_library status=local_status
    IF local_status.normal THEN
      EXIT create_command_list_block
    ELSE
      $system.put_line ' '//$strrep(local_status) o=output_file
      IF osv$deadstart_phase <> 'INSTALL' THEN
        $system.put_line ' ' o=$local.$output
        $system.put_line ' WARNING:  Errors occurred while trying to create the operator command list.'  o=$local.$output
        $system.put_line ' See NOS/VE system job log for details.'  o=$local.$output
        rap$press_next
      IFEND
      $system.delete_command_list_entry e=all

" Try adding the system command library to the command list.

      IF NOT $FILE_ATTRIBUTES($system.osf$operator_command_library registered) THEN
        $system.set_command_list add=($local, $system.osf$sou_library, rav$builtin_library, $system) ..
              system_command_library=$system.osf$command_library status=local_status
        IF local_status.normal THEN
          EXIT create_command_list_block
        ELSE
          $system.put_line ' '//$strrep(local_status) o=output_file
          $system.delete_command_list_entry e=all
        IFEND
      IFEND

" Add the minimum known library set.  This includes osf$sou_library and osf$builtin_library which reside
" on the deadstart tape.

      $system.create_command_list_entry e=($local, $system.osf$sou_library, rav$builtin_library, $system)
    IFEND
  BLOCKEND create_command_list_block

  IF $file(rav$accounting_utils_library, permanent) THEN
    $system.create_command_list_entry e=rav$accounting_utils_library p=after status=ignore_status
  IFEND

  IF $variable(rav$set_operator_command_list, nonlocal) THEN
    "$FORMAT=OFF
    VAR
      rav$set_operator_command_list: (XREF) string
    VAREND
    "$FORMAT=ON"
    $system.include_command c=rav$set_operator_command_list status=local_status
    IF NOT local_status.normal THEN
      $system.put_line (' '//..
$strrep($status(false, 'RA', rae$errors_occurred_warning, 'RAV$SET_OPERATOR_COMMAND_LIST')) ' '//..
$strrep(local_status)) o=output_file
    IFEND
  IFEND

  $system.detach_file $local.cyf$run_time_library status=ignore_status
  $system.attach_file $system.cybil.cyf$run_time_library

  $system.detach_file $local.smf$library status=ignore_status
  $system.attach_file $system.sort.smf$library

  $system.detach_file $local.aaf$44d_library status=ignore_status
  $system.attach_file $system.aam.aaf$44d_library am=execute

  $system.detach_file $local.aaf$4dd_library status=ignore_status
  $system.attach_file $system.aam.aaf$4dd_library am=(read execute)

  $system.detach_file $local.mlf$library status=ignore_status
  $system.attach_file $system.common.mlf$library am=(read execute)

  $system.set_program_attributes delete_library=all
  $system.set_program_attributes add_library=($local.aaf$44d_library, $local.aaf$4dd_library)

  IF $variable(rav$set_operator_library_list, nonlocal) THEN
    "$FORMAT=OFF
    VAR
      rav$set_operator_library_list: (XREF) string
    VAREND
    "$FORMAT=ON"
    $system.include_command c=rav$set_operator_library_list status=local_status
    IF NOT local_status.normal THEN
      $system.put_line (' '//..
$strrep($status(false, 'RA', rae$errors_occurred_warning, 'RAV$SET_OPERATOR_LIBRARY_LIST')) ' '//..
$strrep(local_status)) o=output_file
    IFEND
  IFEND

  POP file_connections


PROCEND rap$create_operator_environment
*DECK DECK=RAP$CREATE_PROFILE_FOR_UPGRADE EXPAND=TRUE
PROCEDURE rap$create_profile_for_upgrade, crepfu (
  enable_site_classes, esc: list of record
      class_name: name
      job_count: integer
    recend = $optional
  saved_profile, sp: file = $system.scheduling_profile
  status)

" This procedure modifies the active profile to create the proper environment
" for the upgrade.  The active profile is saved on the base profile so the
" site environment prior to the upgrade can be restored after the upgrade is
" complete.

  "$FORMAT=OFF"
  VAR
    local_status    : status
    error_flag      : boolean = false
  VAREND
  "$FORMAT=ON"

  MANAGE_ACTIVE_SCHEDULING

    write_profile r=saved_profile

    change_job_class cn=all eci=false
    change_job_class cn=system il=10 eci=true
    change_job_class cn=maintenance il=10 eci=true
    change_job_class cn=interactive il=1
    IF $specified(enable_site_classes) THEN
      FOR EACH site_class IN enable_site_classes DO
        change_job_class cn=site_class.class_name eci=true ..
              il=site_class.job_count status=local_status
        IF NOT local_status.normal THEN
          IF local_status.condition = jme$object_not_known THEN
            put_line l=' '//..
$status(false, 'ra', rae$invalid_site_class, site_class.class_name)
          ELSE
            EXIT procedure WITH local_status
          IFEND
        IFEND
      FOREND
    IFEND

  QUIT sc=TRUE

PROCEND rap$create_profile_for_upgrade

*DECK DECK=RAP$CREATE_SCHEDULING_CLASS EXPAND=TRUE
PROCEDURE rap$create_scheduling_class, create_scheduling_classes, cresc (
  option, o: any of
      key
        all
      keyend
      list of key
        default, ptf_qtf, basisp, nfs, netarc, x_client
      keyend
    anyend = default
  basisp_scheduling_class, bsc: name = DM_KERNEL
  activate_profile, ap: boolean = true
  status)

" This procedure creates and activates the scheduling profile file.

  "$FORMAT=OFF"
  VAR
    option_list           : list 1..7 of name = default
    local_status          : status
    error_flag            : boolean = false
    save_changes          : boolean = true
  VAREND
  "$FORMAT=ON"

"Create the default scheduling profile file.

  ADMINISTER_SCHEDULING

  administer_scheduling_block: ..
    BLOCK

      IF $generic_type(option)= key THEN
        "Assume that the entry was ALL.
       option_list = (default,ptf_qtf,basisp,nfs,netarc,x_client)
      ELSE
        option_list=$apply(option $name(x))
      IFEND

      IF $subset(default, option_list) THEN
        create_default_profile r=$user.scheduling_profile
      IFEND

  file_transfer_block: ..
    BLOCK

      IF $subset(ptf_qtf, option_list) THEN
        create_job_category cn=file_transfer oan=(osa$file_transfer_server, ftpd)

"This command will clean up any duplicate job categories.

        change_job_category cn=file_transfer oan=(osa$file_transfer_server, ftpd)
        ADMINISTER_SERVICE_CLASS
          create_class cn=file_transfer dv=batch status=local_status
          IF (local_status.normal) THEN
            change_attribute a=ft maxaj=40
          IFEND
        QUIT
        EXIT file_transfer_block WHEN NOT local_status.normal
        ADMINISTER_JOB_CLASS
          create_class cn=file_transfer dv=batch status=local_status
          IF (local_status.normal) THEN
            change_attribute iic=true il=40 isc=file_transfer rc=file_transfer a=ft
          IFEND
        QUIT
      IFEND

    BLOCKEND file_transfer_block

    IF NOT (local_status.normal) AND ($condition(local_status.condition)<> 'JME$OBJECT_ALREADY_KNOWN') THEN
      error_flag=true
      save_changes=false
      EXIT administer_scheduling_block
    IFEND

  basisp_block: ..
    BLOCK
      local_status.normal=true

      IF $subset(basisp, option_list) THEN
        ADMINISTER_SERVICE_CLASS
          create_class cn=basisp_scheduling_class dv=maintenance status=local_status
          IF (local_status.normal) THEN
            change_attribute a=dm
          IFEND
        QUIT
        EXIT basisp_block WHEN NOT local_status.normal
        ADMINISTER_JOB_CLASS
          create_class cn=basisp_scheduling_class dv=maintenance status=local_status
          IF (local_status.normal) THEN
            change_attribute a=dm
          IFEND
        QUIT
      IFEND

    BLOCKEND basisp_block

  nfs_block: ..
    BLOCK
      local_status.normal=true

      IF $subset(nfs, option_list) THEN
        ADMINISTER_SERVICE_CLASS
          create_class cn=network_file_system dv=system status=local_status
          IF (local_status.normal) THEN
            change_attribute a=nfs dc=((p9,unlimited,1,1))
          IFEND
          create_class cn=portmap_pcnfs dv=system status=local_status
          IF (local_status.normal) THEN
            change_attribute a=pp dc=((p6,unlimited,1,1))
          IFEND
        QUIT
        EXIT nfs_block WHEN NOT local_status.normal
        ADMINISTER_JOB_CLASS
          create_class cn=network_file_system dv=system status=local_status
          IF (local_status.normal) THEN
            change_attribute a=nfs isc=network_file_system
          IFEND
          create_class cn=portmap_pcnfs dv=system status=local_status
          IF (local_status.normal) THEN
            change_attribute a=pp isc=portmap_pcnfs
          IFEND
        QUIT
      IFEND

    BLOCKEND nfs_block

  netarc_block: ..
    BLOCK
      local_status.normal=true

      IF $subset(netarc, option_list) THEN
        ADMINISTER_SERVICE_CLASS
          create_class cn=network_archiving dv=system status=local_status
          IF (local_status.normal) THEN
            change_attribute a=netarc dc=((p9,5000,1,1) (p5,8000,1,1))
          IFEND
        QUIT
        EXIT netarc_block WHEN NOT local_status.normal
        ADMINISTER_JOB_CLASS
          create_class cn=network_archiving dv=system status=local_status
          IF (local_status.normal) THEN
            change_attribute a=netarc isc=network_archiving
          IFEND
        QUIT
      IFEND

    BLOCKEND netarc_block

  x_client_block: ..
    BLOCK
      local_status.normal=true

      IF $subset(x_client, option_list) THEN
        ADMINISTER_SERVICE_CLASS
          create_class cn=x_client dv=interactive status=local_status
          IF (local_status.normal) THEN
            change_attribute a=xc dc=((p6,1000,1,1) (p5,unlimited))
          IFEND
        QUIT
        EXIT x_client_block WHEN NOT local_status.normal
        ADMINISTER_APPLICATION
          create_application an=x_client status=local_status
          IF (local_status.normal) THEN
            change_attribute service_class=x_client
          IFEND
        QUIT
        EXIT x_client_block WHEN NOT local_status.normal
        ADMINISTER_JOB_CLASS
          create_class cn=x_client dv=interactive status=local_status
          IF (local_status.normal) THEN
            change_attribute a=xc isc=x_client
          IFEND
        QUIT
      IFEND

    BLOCKEND x_client_block

    IF NOT (local_status.normal) AND ($condition(local_status.condition)<> 'JME$OBJECT_ALREADY_KNOWN') THEN
      error_flag=true
      save_changes=false
    IFEND

  BLOCKEND administer_scheduling_block

  QUIT sc=save_changes

  EXIT_PROC WITH local_status WHEN error_flag

  IF (activate_profile = true) THEN
    MANAGE_ACTIVE_SCHEDULING
      activate_profile p=$user.scheduling_profile ejr=true o=$null
    QUIT sc=no
  IFEND

PROCEND rap$create_scheduling_class
*DECK DECK=RAP$CREATE_SCL_STATUS_VARIABLE EXPAND=FALSE

  PROCEDURE [XREF] rap$create_scl_status_variable
    (    name: clt$variable_name_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$variable_name_reference
*copyc ost$status
?? POP ??
*DECK DECK=RAP$DEACTIVATE_ARCHIVE_VE EXPAND=TRUE
PROC deactivate_archive_ve, deaav (
  processor_jobs, processor_job, pj, processor, p: list of name or key all = all
  status)

  SYSTEM_OPERATOR_UTILITY capability=system_administration
    create_variable name=arv$local_status kind=status
    create_variable name=arv$archive_job_file kind=string value=$unique
    create_variable name=arv$archive_job_status kind=status
    create_variable name=arv$archive_system_job_name kind=string
    create_variable name=arv$archive_ve_path kind=string value=':$system.$system.archive_ve'
    create_variable name=arv$character_save kind=string
    create_variable name=arv$deactivate_processor kind=boolean value=true
    create_variable name=arv$index kind=integer
    create_variable name=arv$processors_processed kind=string dimension=$set_count(processor) value=' '
    create_variable name=arv$processor_jobs_catalog kind=string value='processor_jobs'
    create_variable name=arv$processor_jobs_list kind=string value=$unique
    create_variable name=arv$processor_jobs_path kind=string value=' '
    create_variable name=arv$processor_job_name_line kind=string value=' '
    create_variable name=arv$processor_job_name kind=string
    create_variable name=arv$processor_job_path kind=string value=' '
    create_variable name=arv$processor_name kind=string value=' '
    create_variable name=arv$processor_name_short kind=string value=' '

    arv$processor_jobs_path = arv$archive_ve_path // '.' // arv$processor_jobs_catalog

    display_catalog catalog=$fname(arv$processor_jobs_path) output=$fname(arv$processor_jobs_list)

    rewind_file file=$fname(arv$processor_jobs_list)
  deactivate_archive_ve_jobs: ..
    LOOP
      arv$processor_job_name_line = ' '
      accept_line variable=arv$processor_job_name_line input=$fname(arv$processor_jobs_list//'.$ASIS')
      EXIT deactivate_archive_ve_jobs WHEN arv$processor_job_name_line = ' '
      IF $substr(arv$processor_job_name_line, 5, 10) <> 'FILE: ARF$' THEN
        CYCLE deactivate_archive_ve_jobs
      IFEND
      arv$processor_name = $trim($substr(arv$processor_job_name_line, 15, 27))
      arv$processor_job_path = arv$processor_jobs_path // '.ARF$' // arv$processor_name
      arv$character_save = $substr(arv$processor_name, 1, 1)
      arv$processor_name_short = ''
      FOR arv$index = 1 TO $strlen(arv$processor_name) DO
        IF $substr(arv$processor_name, arv$index, 1) = '_' THEN
          arv$processor_name_short = arv$processor_name_short // arv$character_save
          arv$character_save = $substr(arv$processor_name, arv$index+1, 1)
        IFEND
      FOREND
      arv$processor_name_short = arv$processor_name_short // arv$character_save

      IF $specified(processor) AND $string($value(processor)) <> 'ALL' THEN
        arv$deactivate_processor = false
        FOR arv$index = 1 TO $set_count(processor) DO
          IF ((arv$processor_name_short = $string($value(processor, arv$index))) OR ..
                (arv$processor_name = $string($value(processor, arv$index)))) THEN
            arv$deactivate_processor = true
            arv$processors_processed(arv$index) = $string($value(processor, arv$index))
          IFEND
        FOREND
      IFEND

    deactivate_processor_block: ..
      BLOCK

        EXIT deactivate_processor_block WHEN NOT arv$deactivate_processor

        arv$processor_job_name = ' '
        include_file file=$fname(arv$processor_job_path) status=arv$local_status
        IF NOT arv$local_status.normal THEN
          display_value arv$local_status
          $system.put_line line=('  Unable to deactivate Archive/VE processor '//arv$processor_name//..
' because of error.') output=$response
          EXIT deactivate_processor_block
        IFEND

        IF arv$processor_job_name = ' ' THEN
"
" This is a remote processor job file, so there is no processor job to
" deactivate.
"
          CYCLE deactivate_archive_ve_jobs
        IFEND

        IF $string($job_status($name(arv$processor_job_name), job_state)) = 'UNKNOWN' THEN
          $system.put_line line=(' Archive/VE processor '//arv$processor_job_name//' is not active.') ..
                output=$response
          EXIT deactivate_processor_block
        IFEND

        terminate_job job_name=$name(arv$processor_job_name) status=arv$local_status
        IF arv$local_status.normal THEN
          $system.put_line line=(' Archive/VE processor '//arv$processor_job_name//' deactivated') ..
                output=$response
          IF arv$archive_system_job_name <> ' ' THEN
            $system.put_line line=('       as System Job '//arv$archive_system_job_name) output=$response
          IFEND
        ELSE
          display_value arv$local_status
          $system.put_line line=('  Unable to deactivate Archive/VE processor '//arv$processor_name//..
' because of error.') output=$response
          EXIT deactivate_processor_block
        IFEND

        EXIT procedure WITH arv$archive_job_status WHEN NOT arv$archive_job_status.normal

      BLOCKEND deactivate_processor_block

      detach_file file=$fname(arv$archive_job_file) status=arv$local_status
    LOOPEND deactivate_archive_ve_jobs

    IF $specified(processor) AND $string($value(processor)) <> 'ALL' THEN
      FOR arv$index = 1 TO $set_count(processor) DO
        IF arv$processors_processed(arv$index) = ' ' THEN
          $system.put_line line=(' Unable to deactivate Archive/VE processor '//..
$string($value(processor, arv$index))) output=$response
          $system.put_line line=('       because there is no processor job file defined in catalog') ..
                output=$response
          $system.put_line line=('       '//arv$processor_jobs_path) output=$response
        IFEND
      FOREND
    IFEND

    detach_file file=$fname(arv$processor_jobs_list) status=arv$local_status
  END_SYSTEM_OPERATOR_UTILITY

PROCEND deactivate_archive_ve
*DECK DECK=RAP$DEACTIVATE_BTFS EXPAND=TRUE
PROCEDURE deactivate_btfs (
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request deactivates and deletes the BTFS system task.
*IFEND

  VAR
    local_status: status
  VAREND


  MANAGE_JOBS
    select_job name=$name('btfs'//$mainframe(id)) job_state=(deferred, queued, initiated) ..
          user_information='Batch Transfer Facility Server (BTFS) for NOS/VE' status=local_status
    IF local_status.normal AND ($size(jmv$selected_jobs) > 0) THEN
      terminate_job names=jmv$selected_jobs status=local_status
    ELSE
      local_status = $status(false 'JM' jme$job_not_found 'BTFS'//$mainframe(id))
    IFEND
  QUIT

  EXIT_PROC WITH local_status

PROCEND deactivate_btfs
*DECK DECK=RAP$DEACTIVATE_HISTORY_LOG EXPAND=TRUE
create_command_description name=(deactivate_history_log, deahl) ..
      sp=clp$deactivate_job_history
*DECK DECK=RAP$DEACTIVATE_NAMVE EXPAND=TRUE

PROCEDURE (HIDDEN) rap$deactivate_namve (
  status)


*IF $variable(rav$proc_doc declared) <> 'UNKNOWN'

" PURPOSE:
"   This procedure deactivates NAM/VE.
*IFEND


*copy rav$margin

  "$FORMAT=OFF
  VAR
    ignore_status: status
    local_status: status
  VAREND
  "$FORMAT=ON"


  EXIT procedure WHEN NOT $namve_active

  rap$display_message mm=initiation_messages mn=deactivating_namve m=rav$margin t=$response status=ignore_status


deactivate_configuration: ..
  BLOCK

    REPEAT
      execute_task sp=nap$idle_namve tel=warning lm=$null lmo=none dm=off status=local_status
      IF NOT local_status.normal THEN
        IF ($condition(local_status.condition) <> 'NAE$CONNECTIONS_STILL_ACTIVE') AND ..
              ($condition(local_status.condition) <> 'NAE$NETWORK_APPLICATIONS_ACTIVE') THEN
          EXIT deactivate_configuration
        IFEND
        wait 5000
      IFEND
    UNTIL local_status.normal

    deactivate_system_task task_name=intranet_layer_mgmt_task status=local_status
    EXIT deactivate_configuration WHEN NOT local_status.normal

    deactivate_system_task task_name=namve_system_input_task status=local_status
    EXIT deactivate_configuration WHEN NOT local_status.normal

    deactivate_system_task task_name=namve_completed_output_task status=local_status
    EXIT deactivate_configuration WHEN NOT local_status.normal

    deactivate_system_task task_name=namve_directory_me status=local_status
    EXIT deactivate_configuration WHEN NOT local_status.normal

    deactivate_system_task task_name=namve_timer_monitor status=local_status
    EXIT deactivate_configuration WHEN NOT local_status.normal

    deactivate_system_task task_name=namve_connection_establisher status=local_status
    EXIT deactivate_configuration WHEN NOT local_status.normal

    deactivate_system_task task_name=namve_poll_connections_task status=local_status
    EXIT deactivate_configuration WHEN NOT local_status.normal

    execute_task sp=nap$terminate_namve tel=warning lm=$null lmo=none dm=off status=local_status

  BLOCKEND deactivate_configuration

  IF local_status.normal THEN
    rap$display_message mm=initiation_messages mn=namve_deactivated m=rav$margin t=$response ..
          status=ignore_status
  ELSE
    EXIT procedure WITH local_status
  IFEND

PROCEND rap$deactivate_namve
*DECK DECK=RAP$DEACTIVATE_NETWORK EXPAND=TRUE

PROCEDURE deactivate_network (
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure deactivates the network by deactivating NAM/VE and executing the network deactivation
"   prolog and epilog.
"
" NOTES:
"   One of the restrictions placed on NAM/VE deactivation is that RHFAM must be deactivated first
"   because of shared buffer problems.
"   Margins have been turned off (set to 0) until all messages can be properly aligned together.  To
"   turn the margins back on replace the 0's with a 2.
*IFEND


*copy rav$margin
*copy rav$system_paths

  "$FORMAT=OFF
  VAR
    ignore_status: status
    local_status: status
    proc_status: status
    rav$event_message: (XDCL) status
  VAREND
  "$FORMAT=ON"


  IF $substring($string($job(sjn)),12,8) <> 'AAA_0000' THEN
    EXIT procedure WITH $status(FALSE, 'NA', nae$insufficient_privilege)
  IFEND

  local_status.normal=true
  proc_status.normal=true

  rap$display_message mm=initiation_messages mn=deactivating_network m=rav$margin t=$response ..
        status=ignore_status
  rav$margin=rav$margin + 0

  IF $namve_active THEN
    rap$run_initiation_commands icn=network_deactivation_prolog status=local_status
    IF NOT local_status.normal THEN
      rap$handle_status si=local_status so=proc_status
    IFEND

    rap$check_rhfam_for_namve status=local_status
    IF NOT local_status.normal THEN
      IF $condition(local_status.condition) = 'RAE$NO_NAMVE_DUE_TO_RHFAM'
        local_status = $status(FALSE, 'RA', rae$no_namve_deactivate_rhfam)
      IFEND
      rap$handle_status si=local_status so=proc_status
    IFEND

    IF proc_status.normal THEN
      rap$deactivate_namve status=local_status
      IF NOT local_status.normal THEN
        rap$handle_status si=local_status so=proc_status
      IFEND
    IFEND
  IFEND

  IF NOT $namve_active THEN
    rap$run_initiation_commands icn=network_deactivation_epilog status=local_status
    IF NOT local_status.normal THEN
      rap$handle_status si=local_status so=proc_status
    IFEND
  IFEND

  rav$margin=rav$margin - 0

  IF proc_status.normal THEN
    rap$display_message mm=initiation_messages mn=network_deactivated m=rav$margin t=$response ..
          status=ignore_status
  ELSE
    EXIT procedure WITH $status(false, 'RA', rae$errors_occurred_warning, 'DEACTIVATE_NETWORK')
  IFEND

PROCEND deactivate_network


*DECK DECK=RAP$DEACTIVATE_NET_CLOCK EXPAND=TRUE
PROC deactivate_network_clock, deanc (
    status)

  create_variable nav$status kind=status

  deactivate_system_task network_clock status=nav$status

  IF nav$status.normal THEN
    display_value 'Network clock deactivated.'
  ELSE
    EXIT_PROC with nav$status
  IFEND

  delete_system_task name=network_clock status=nav$status

  IF NOT nav$status.normal THEN
    EXIT_PROC with nav$status
  IFEND

PROCEND deactivate_network_clock
*DECK DECK=RAP$DEACTIVATE_NET_FILE_ACCESS EXPAND=TRUE
PROC deactivate_network_file_access, deanfa (
    status)

  create_variable nav$status kind=status

  deactivate_system_task network_file_access status=nav$status

  IF nav$status.normal THEN
    display_value 'Network file access deactivated.'
  ELSE
    EXIT_PROC with nav$status
  IFEND

  delete_system_task name=network_file_access status=nav$status

  IF NOT nav$status.normal THEN
    EXIT_PROC with nav$status
  IFEND

PROCEND deactivate_network_file_access
*DECK DECK=RAP$DEACTIVATE_NET_INIT EXPAND=TRUE
PROC deactivate_network_initializer, deani (
    status)

  create_variable nav$status kind=status

  deactivate_system_task network_initializer status=nav$status

  IF nav$status.normal THEN
    display_value 'Network initializer deactivated.'
  ELSE
    EXIT_PROC with nav$status
  IFEND

  delete_system_task name=network_initializer status=nav$status

  IF NOT nav$status.normal THEN
    EXIT_PROC with nav$status
  IFEND

PROCEND deactivate_network_initializer
*DECK DECK=RAP$DEACTIVATE_NET_LOG EXPAND=TRUE
PROC deactivate_network_log, deanl (
    status)

  create_variable nav$status kind=status

  deactivate_system_task network_log status=nav$status

  IF nav$status.normal THEN
    display_value 'Network log deactivated.'
  ELSE
    EXIT_PROC with nav$status
  IFEND

  delete_system_task name=network_log status=nav$status

  IF NOT nav$status.normal THEN
    EXIT_PROC with nav$status
  IFEND

PROCEND deactivate_network_log
*DECK DECK=RAP$DEACTIVATE_NTF EXPAND=TRUE
PROCEDURE deactivate_ntf (
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request deactivates NTF system task.
*IFEND

  VAR
    local_status: status
  VAREND

  MANAGE_JOBS
    select_job name=$name('ntf'//$mainframe(id)) job_state=(deferred, queued, initiated) ..
          user_information='Network Transfer Facility (NTF) for NOS/VE' status=local_status
    IF local_status.normal AND ($size(jmv$selected_jobs) > 0) THEN
      terminate_job names=jmv$selected_jobs status=local_status
    ELSE
      local_status = $status(false 'JM' jme$job_not_found 'NTF'//$mainframe(id))
    IFEND
  QUIT

  EXIT_PROC WITH local_status

PROCEND deactivate_ntf
*DECK DECK=RAP$DEACTIVATE_NTF_MAIL EXPAND=TRUE
PROC deactivate_ntf_mail (
  status : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request deactivates NTF_MAIL system task.
*IFEND


  create_variable local_status k=status


  deactivate_system_task task_name=ntf_mail_client status=local_status
  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND deactivate_ntf_mail
*DECK DECK=RAP$DEACTIVATE_PTF EXPAND=TRUE
PROC deactivate_ptf (
  status       : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request deactivates and deletes the PTF system task.
*IFEND


  create_variable local_status k=status


  deactivate_system_task task_name=osa$file_transfer_server status=local_status
  IF local_status.normal OR ($condition(local_status.condition) =   ..
        'OSE$SYSTEM_TASK_NOT_ACTIVE') THEN
    wait time=2000
    delete_system_task name=osa$file_transfer_server status=local_status
  IFEND
  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND deactivate_ptf

*DECK DECK=RAP$DEACTIVATE_QTF EXPAND=TRUE
PROC deactivate_qtf (
  status : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request deactivates and deletes the system task for the QTF client application.
*IFEND


  create_variable local_status kind=status

  deactivate_system_task task_name=queue_transfer_client status=local_status
  IF local_status.normal OR ($condition(local_status.condition) =   ..
        'OSE$SYSTEM_TASK_NOT_ACTIVE') THEN
    wait time=2000  "allow time for task to terminate"
    delete_system_task name=queue_transfer_client status=local_status
  IFEND

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND deactivate_qtf
*DECK DECK=RAP$DEACTIVATE_QTFS EXPAND=TRUE
PROC deactivate_qtfs (
  status : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request deactivates and deletes the system task for the QTF server application.
*IFEND


  create_variable local_status kind=status

  deactivate_system_task task_name=queue_transfer_server status=local_status
  IF local_status.normal OR ($condition(local_status.condition) =  ..
        'OSE$SYSTEM_TASK_NOT_ACTIVE') THEN
    wait time=2000 "allow time for task to terminate"
    delete_system_task name=queue_transfer_server status=local_status
  IFEND

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND deactivate_qtfs
*DECK DECK=RAP$DEACTIVATE_SCF EXPAND=TRUE
PROCEDURE deactivate_scf (
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request deactivates and deletes the SCF system task.
*IFEND

  VAR
    local_status : status
  VAREND

  MANAGE_JOBS
    select_job name=$name('scf'//$mainframe(id)) job_state=(deferred, queued, initiated) ..
          user_information='Status and Control Facility (SCF) for NOS/VE' status=local_status
    IF local_status.normal AND ($size(jmv$selected_jobs) > 0) THEN
      terminate_job names=jmv$selected_jobs status=local_status
    ELSE
      local_status = $status(false 'JM' jme$job_not_found 'SCF'//$mainframe(id))
    IFEND
  QUIT

  EXIT_PROC WITH local_status

PROCEND deactivate_scf
*DECK DECK=RAP$DEACTIVATE_SCFS EXPAND=TRUE
PROC deactivate_scfs (
  system_task_name, stn : name = $optional
  status                : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request deactivates and deletes the SCFS system task.
*IFEND


  create_variable local_status k=status


  system_task_name = 'scf_server'
  IF $specified(system_task_name) THEN
    system_task_name = $string($value(system_task_name))
  IFEND

  deactivate_system_task task_name=$name(system_task_name) status=local_status
  IF local_status.normal OR ($condition(local_status.condition) =   ..
        'OSE$SYSTEM_TASK_NOT_ACTIVE') THEN
    wait time=2000
    delete_system_task name=$name(system_task_name) status=local_status
  IFEND
  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND deactivate_scfs

*DECK DECK=RAP$DEACTIVATE_SMTP EXPAND=TRUE
PROCEDURE deactivate_smtp (
  status
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"   This request terminates the SMTP client job.
*IFEND

  VAR
    application_job_name: name = $name('SMTP'//$mainframe(id))
    select_status: status
    terminate_status: status
  VAREND

  MANAGE_JOBS
    SELECT_JOB login_user=$SYSTEM login_family=$SYSTEM ..
      name=application_job_name job_state=all status=select_status
    IF select_status.normal THEN
      IF $size(jmv$selected_jobs) > 0 THEN
        WHILE $size(jmv$selected_jobs) > 0 DO
          terminate_job job_name=$first(jmv$selected_jobs) ..
            status=terminate_status
          IF terminate_status.normal THEN
            put_line ' SMTP '//$string($first(jmv$selected_jobs))//..
' terminated.' o=$response
          ELSE
            display_value $status_message(terminate_status, 80) o=$response
          IFEND
          jmv$selected_jobs =$rest(jmv$selected_jobs)
        WHILEND
      ELSE
        put_line ' SMTP is not active.' o=$response
      IFEND
    ELSE
      EXIT procedure WITH select_status
    IFEND
  QUIT

PROCEND deactivate_smtp

*DECK DECK=RAP$DEACTIVATE_SYSTEM_LOGGING EXPAND=TRUE
create_command_description name=(deactivate_system_logging, deasl) ..
      sp=clp$deactivate_system_logging
*DECK DECK=RAP$DEACTIVATE_SYSTEM_STATISTIC EXPAND=TRUE
create_command_description name=(deactivate_system_statistic, deactivate_system_statistics, deass) ..
      sp=sfp$deactivate_sys_stat_command
*DECK DECK=RAP$DEACTIVATE_SYSTEM_TASK EXPAND=TRUE
create_command_description name=(deactivate_system_task, deactivate_system_tasks, deast) ..
      sp=clp$deactivate_system_task
*DECK DECK=RAP$DEACTIVATE_XTF EXPAND=TRUE
*DECK DECK=RAP$DEFINE_NFS_TIME_SERVERS EXPAND=TRUE
PROCEDURE rap$define_nfs_time_servers (
  status: (var) status)

  create_variable tcp_daytime_status kind=status
  create_variable tcp_time_status    kind=status
  create_variable udp_daytime_status kind=status
  create_variable udp_time_status    kind=status
  create_variable local_status       kind=status

  crecle $system.software_maintenance.raf$library status=local_status

  IF local_status.normal THEN

    rap$define_tcp_daytime_server status=tcp_daytime_status
    IF NOT tcp_daytime_status.normal THEN
      disv tcp_daytime_status o=$response
    IFEND

    rap$define_tcp_time_server status=tcp_time_status
    IF NOT tcp_time_status.normal THEN
      disv tcp_time_status o=$response
    IFEND

    rap$define_udp_daytime_server status=udp_daytime_status
    IF NOT udp_daytime_status.normal THEN
      disv udp_daytime_status o=$response
    IFEND

    rap$define_udp_time_server status=udp_time_status
    IF NOT udp_time_status.normal THEN
      disv udp_time_status o=$response
    IFEND

    delcle $system.software_maintenance.raf$library

  ELSE

    EXIT_PROC WITH local_status

  IFEND

PROCEND rap$define_nfs_time_servers
*DECK DECK=RAP$DEFINE_NQS_HOST EXPAND=TRUE
PROCEDURE rap$define_nqs_host (
  machine_id, mid, mi: integer = $required
  host, h: record
      display_name: application
      primary_names: list rest of application
    recend = $required
  status)

  VAR
    ls: status
  VAREND

  EDIT_FILE $system.nqs.host_map_file output=$null prolog=$null

    locate_text $string(machine_id) n=1 l=all word=yes status=ls
    IF ls.normal THEN
      put_line ' Machine id '//machine_id//' is already used.'
      EXIT PROCEDURE
    IFEND

    locate_text $string(host.display_name) n=1 l=all word=yes upper_case=yes status=ls
    IF ls.normal THEN
      put_line ' Host name "'//host.display_name//'" is already defined.'
      EXIT PROCEDURE
    IFEND

    FOR EACH alias IN host.primary_names DO
      locate_text $string(alias) n=1 l=all word=yes upper_case=yes status=ls
      IF ls.normal THEN
        put_line ' Host name "'//alias//'" is already defined.'
        EXIT PROCEDURE
      IFEND
    FOREND

    FOR EACH s IN $apply($string(host display_element) x//' '//machine_id) DO
      insert_line s placement=after insertion_location=last
    FOREND

    put_line ' Host "'//host.display_name//'" defined as machine id '//machine_id//'.'

  QUIT yes

  create_file_permit $system.nqs.host_map_file public am=read

PROCEND rap$define_nqs_host

*DECK DECK=RAP$DEFINE_ORASRV EXPAND=TRUE
PROCEDURE rap$define_orasrv (
  protocol, p: key (stream_socket, ss), (cdna_session, cs), keyend = stream_socket
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request defines the ORACLE client application.
"
*IFEND

  VAR
    command_file: file = $unique($local)
    ignore_status: status
    local_status: status
  VAREND

  IF protocol = stream_socket THEN
    collect_text command_file until='    collect_end' sm='?'
      $system.osf$command_library.manage_network_applications
        define_tcpip_application application=osa$oracle_client protocol=?protocol?
          change_maximum_sockets maximum_sockets=40
        quit
        activate_tcpip_application application=osa$oracle_client
      quit
    collect_end
  ELSE
    put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1' o=$response
    collect_text command_file until='    collect_end' sm='?'
      $system.osf$command_library.manage_network_applications
        define_client client=osa$oracle_client protocol=?protocol?
          change_maximum_connections maximum_connections=40
        quit
        activate_client client=osa$oracle_client
      quit
    collect_end
  IFEND

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  IF local_status.normal THEN
    put_line ' ORACLE client is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND rap$define_orasrv

*DECK DECK=RAP$DEFINE_ORASRVS EXPAND=TRUE
PROCEDURE rap$define_orasrvs (
  protocol, p: key (stream_socket, ss), (cdna_session, cs), keyend = stream_socket
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request defines the ORACLE server.
"
*IFEND


  VAR
    command_file: file = $unique($local)
    ignore_status: status
    local_status: status
  VAREND

  IF protocol = stream_socket THEN
    collect_text command_file until='    collect_end' sm='?'
      $system.osf$command_library.manage_network_applications
        define_tcpip_application application=osa$oracle_server_tcp protocol=?protocol?
          change_maximum_sockets maximum_sockets=40
        quit
        activate_tcpip_application application=osa$oracle_server_tcp
      quit
    collect_end
  ELSE
    put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1' o=$response
    collect_text command_file until='    collect_end' sm='?'
      $system.osf$command_library.manage_network_applications
        define_client client=osa$oracle_server_tcp protocol=?protocol?
          change_maximum_connections maximum_connections=40
        quit
        activate_client client=osa$oracle_server_tcp
      quit
    collect_end
  IFEND

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  IF local_status.normal THEN
    put_line ' ORACLE server is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND rap$define_orasrvs

*DECK DECK=RAP$DEFINE_PERMIT EXPAND=FALSE

  PROCEDURE [XREF] rap$define_permit
    (    element_type: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??


*DECK DECK=RAP$DEFINE_RLM EXPAND=TRUE
PROCEDURE rap$define_rlm (
  status)

  VAR
    command_file : file = $unique($local)
    ignore_status : status
    local_status : status
  VAREND

COLLECT_TEXT output=command_file until='COLLECT_END'
    $system.osf$command_library.manage_network_applications
      define_client client=$REMOTE_LINE_MONITOR_CLIENT ..
            protocol=cdna_session
        change_connection_priority connection_priority=5
        change_maximum_connections maximum_connections=40
        change_client_validation system_privilege=FALSE
        change_application_identifier application_identifier=VARIABLE
      end_define_client
      activate_client client=$REMOTE_LINE_MONITOR_CLIENT
    quit
COLLECT_END

  include_file file=command_file status=local_status
  delete_file file=command_file status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

  put_line line=' $REMOTE_LINE_MONITOR_CLIENT defined and activated.' ..
    output=$response

PROCEND rap$define_rlm
*DECK DECK=RAP$DEFINE_SMTP EXPAND=TRUE
PROCEDURE rap$define_smtp (
  protocol, p: key
      (stream_socket, ss)
      (cdna_session, cs)
    keyend = stream_socket
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request defines the SMTP client.
"
*IFEND


  "$FORMAT=OFF"
  VAR
    command_file: file = $unique($local)
    ignore_status: status
    local_status: status
  VAREND
  "$FORMAT=ON"


  IF protocol = stream_socket THEN
COLLECT_TEXT command_file until='    collect_end' sm='?'
      $system.osf$command_library.manage_network_applications
        define_tcpip_application application=osa$smtp_client protocol=?protocol?
          change_maximum_sockets maximum_sockets=100
        quit
        activate_tcpip_application application=osa$smtp_client
      quit
    collect_end
  ELSE
COLLECT_TEXT command_file until='  collect_end' sm='?'
    put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1' o=$response
    $system.osf$command_library.manage_network_applications
      define_client client=osa$smtp_client protocol=?protocol?
        change_maximum_connections mc=100
      end_define_client
      activate_client client=osa$smtp_client
    quit
  collect_end
  IFEND

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  IF local_status.normal THEN
    put_line ' SMTP client is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND rap$define_smtp

*DECK DECK=RAP$DEFINE_SMTPS EXPAND=TRUE
PROCEDURE rap$define_smtps (
  protocol, p: key
      (stream_socket, ss)
      (cdna_session, cs)
    keyend = stream_socket
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request defines the SMTP server.
"
*IFEND

  "$FORMAT=OFF"
  VAR
    command_file: file = $unique($local)
    ignore_status: status
    local_status: status
  VAREND
  "$FORMAT=ON"

  IF protocol = stream_socket THEN
COLLECT_TEXT command_file until='    collect_end' sm='?'
      $system.osf$command_library.manage_network_applications
        define_tcpip_application application=osa$smtp_server protocol=?protocol?
          change_maximum_sockets maximum_sockets=100
          change_tcpip_validation sp=true
        quit
        activate_tcpip_application application=osa$smtp_server
      quit
    collect_end
  ELSE
    put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1' o=$response
    collect_text command_file until='  collect_end' sm='?'
    $system.osf$command_library.manage_network_applications
      define_client client=osa$smtp_server protocol=?protocol?
        change_maximum_connections mc=100
        change_client_validation sp=true
      end_define_client
      activate_client client=osa$smtp_server
    quit
  collect_end
  IFEND

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  IF local_status.normal THEN
    put_line ' SMTP server is defined' o=$response
  IFEND

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND rap$define_smtps

*DECK DECK=RAP$DEFINE_SYSTEM_TASK EXPAND=TRUE
create_command_description name=(define_system_task, defst) ..
      sp=clp$define_system_task
*DECK DECK=RAP$DEFINE_TCP_DAYTIME_SERVER EXPAND=TRUE
PROCEDURE rap$define_tcp_daytime_server (
  status: (var) status )

    create_variable command_file k=string v='$local.'//$unique
    create_variable define_status_1 k=status
    create_variable define_status_2 k=status
    create_variable ignore_status k=status
    create_variable local_status k=status

  collect_text $fname(command_file) until='  collect_end'
    $system.osf$command_library.manage_network_applications
"   put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1'
"     display_client_status client=osa$tcp_daytime_server output=$null  status=define_status_1
"     IF define_status_1.normal THEN
"       activate_client client=osa$tcp_daytime_server status=define_status_1
"     ELSEIF $condition(define_status_1.condition)='NAE$UNKNOWN_APPLICATION' THEN
"       define_client client=osa$tcp_daytime_server protocol=cdna_session status=define_status_1
"         change_maximum_connections mc=40
"       end_define_client
"       activate_client client=osa$tcp_daytime_server status=define_status_1
"     IFEND

      display_tcpip_status application=osa$tcp_daytime_server output=$null  status=define_status_2
      IF define_status_2.normal THEN
        activate_tcpip_application application=osa$tcp_daytime_server status=define_status_2
      ELSEIF $condition(define_status_2.condition)='NAE$UNKNOWN_APPLICATION' THEN
        define_tcpip_application application=osa$tcp_daytime_server protocol=stream_socket status=define_status_2
        end_define_tcpip_application
        activate_tcpip_application application=osa$tcp_daytime_server status=define_status_2
      IFEND
    quit
  collect_end

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  IF local_status.normal THEN
    IF define_status_1.normal THEN
      put_line ' CLIENT (tcp) daytime server applications are defined' o=$response
    ELSE
      disv define_status_1
    IFEND

    IF define_status_2.normal THEN
      put_line ' TCP/IP (tcp) daytime server applications are defined' o=$response
    ELSE
      disv define_status_2
    IFEND
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$define_tcp_daytime_server
*DECK DECK=RAP$DEFINE_TCP_TIME_SERVER EXPAND=TRUE
PROCEDURE rap$define_tcp_time_server (
  status: (var) status )

    create_variable command_file k=string v='$local.'//$unique
    create_variable define_status_1 k=status
    create_variable define_status_2 k=status
    create_variable ignore_status k=status
    create_variable local_status k=status

  collect_text $fname(command_file) until='  collect_end'
    $system.osf$command_library.manage_network_applications
"     put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1'
"     display_client_status client=osa$tcp_time_server output=$null   status=define_status_1
"     IF define_status_1.normal THEN
"       activate_client client=osa$tcp_time_server status=define_status_1
"     ELSEIF $condition(define_status_1.condition)='NAE$UNKNOWN_APPLICATION' THEN
"       define_client client=osa$tcp_time_server protocol=cdna_session status=define_status_1
"         change_maximum_connections mc=40
"       end_define_client
"       activate_client client=osa$tcp_time_server status=define_status_1
"     IFEND

      display_tcpip_status application=osa$tcp_time_server output=$null  status=define_status_2
      IF define_status_2.normal THEN
        activate_tcpip_application application=osa$tcp_time_server status=define_status_2
      ELSEIF $condition(define_status_2.condition)='NAE$UNKNOWN_APPLICATION' THEN
        define_tcpip_application application=osa$tcp_time_server protocol=stream_socket status=define_status_2
        end_define_tcpip_application
        activate_tcpip_application application=osa$tcp_time_server status=define_status_2
      IFEND
    quit
  collect_end

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  IF local_status.normal THEN
    IF define_status_1.normal THEN
      put_line ' CLIENT (tcp) time server applications are defined' o=$response
    ELSE
      disv define_status_1
    IFEND

    IF define_status_2.normal THEN
      put_line ' TCP/IP (tcp) time server applications are defined' o=$response
    ELSE
      disv define_status_2
    IFEND
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$define_tcp_time_server
*DECK DECK=RAP$DEFINE_UDP_DAYTIME_SERVER EXPAND=TRUE
PROCEDURE rap$define_udp_daytime_server (
  status: (var) status )

    create_variable command_file k=string v='$local.'//$unique
    create_variable define_status_1 k=status
    create_variable define_status_2 k=status
    create_variable ignore_status k=status
    create_variable local_status k=status

  collect_text $fname(command_file) until='  collect_end'
    $system.osf$command_library.manage_network_applications
"     put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1'
"     display_client_status client=osa$udp_daytime_server output=$null   status=define_status_1
"     IF define_status_1.normal THEN
"       activate_client client=osa$udp_daytime_server status=define_status_1
"     ELSEIF $condition(define_status_1.condition)='NAE$UNKNOWN_APPLICATION' THEN
"       define_client client=osa$udp_daytime_server protocol=cdna_session status=define_status_1
"         change_maximum_connections mc=40
"       end_define_client
"       activate_client client=osa$udp_daytime_server
"     IFEND

      display_tcpip_status application=osa$udp_daytime_server output=$null  status=define_status_2
      IF define_status_2.normal THEN
        activate_tcpip_application application=osa$udp_daytime_server status=define_status_2
      ELSEIF $condition(define_status_2.condition)='NAE$UNKNOWN_APPLICATION' THEN
        define_tcpip_application application=osa$udp_daytime_server protocol=datagram_socket status=define_status_2
        end_define_tcpip_application
        activate_tcpip_application application=osa$udp_daytime_server status=define_status_2
      IFEND
    quit
  collect_end

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  IF local_status.normal THEN
    IF define_status_1.normal THEN
      put_line ' CLIENT (udp) daytime server applications are defined' o=$response
    ELSE
      disv define_status_1
    IFEND

    IF define_status_2.normal THEN
      put_line ' TCP/IP (udp) daytime server applications are defined' o=$response
    ELSE
      disv define_status_2
    IFEND
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$define_udp_daytime_server
*DECK DECK=RAP$DEFINE_UDP_TIME_SERVER EXPAND=TRUE
PROCEDURE rap$define_udp_time_server (
  status: (var) status )

    create_variable command_file k=string v='$local.'//$unique
    create_variable define_status_1 k=status
    create_variable define_status_2 k=status
    create_variable ignore_status k=status
    create_variable local_status k=status

  collect_text $fname(command_file) until='  collect_end'
    $system.osf$command_library.manage_network_applications
"     put_line 'WARNING - TCP/IP Gateway support terminated at release level 1.7.1'
"     display_client_status client=osa$udp_time_server output=$null     status=define_status_1
"     IF define_status_1.normal THEN
"       activate_client client=osa$udp_time_server status=define_status_1
"     ELSEIF $condition(define_status_1.condition)='NAE$UNKNOWN_APPLICATION' THEN
"       define_client client=osa$udp_time_server protocol=cdna_session status=define_status_1
"         change_maximum_connections mc=40
"       end_define_client
"       activate_client client=osa$udp_time_server status=define_status_1
"     IFEND

      display_tcpip_status application=osa$udp_time_server output=$null  status=define_status_2
      IF define_status_2.normal THEN
        activate_tcpip_application application=osa$udp_time_server status=define_status_2
      ELSEIF $condition(define_status_2.condition)='NAE$UNKNOWN_APPLICATION' THEN
        define_tcpip_application application=osa$udp_time_server protocol=datagram_socket status=define_status_2
        end_define_tcpip_application
        activate_tcpip_application application=osa$udp_time_server status=define_status_2
      IFEND
    quit
  collect_end

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  IF local_status.normal THEN
    IF define_status_1.normal THEN
      put_line ' CLIENT (udp) time server applications are defined' o=$response
    ELSE
      disv define_status_1
    IFEND

    IF define_status_2.normal THEN
      put_line ' TCP/IP (udp) time server applications are defined' o=$response
    ELSE
      disv define_status_2
    IFEND
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$define_udp_time_server
*DECK DECK=RAP$DEFINE_UNNAMED_TCP_APPL EXPAND=TRUE
PROCEDURE rap$define_unnamed_tcp_appl (
  status: (var) status )

    VAR
      application_name : name = UNNAMED_TCP_APPLICATION
      command_file : file = $unique($local)
      define_status : status
      ignore_status : status
      local_status : status
    VAREND

  collect_text command_file until='  collect_end'
    $system.osf$command_library.manage_network_applications

      display_tcpip_status application=application_name output=$null  status=define_status
      IF define_status.normal THEN
        activate_tcpip_application application=application_name status=define_status
      ELSEIF $condition(define_status.condition)='NAE$UNKNOWN_APPLICATION' THEN
        define_tcpip_application application=application_name protocol=stream_socket status=define_status
        end_define_tcpip_application
        activate_tcpip_application application=application_name status=define_status
      IFEND
    quit
  collect_end

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  IF local_status.normal THEN
    IF define_status.normal THEN
      put_line '  '//$STRING(application_name)//' has been defined.' o=$response
    ELSE
      disv define_status
    IFEND
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$define_unnamed_tcp_appl
*DECK DECK=RAP$DEFINE_UNNAMED_UDP_APPL EXPAND=TRUE
PROCEDURE rap$define_unnamed_udp_appl (
  status: (var) status )

    VAR
      application_name : name = UNNAMED_UDP_APPLICATION
      command_file : file = $unique($local)
      define_status : status
      ignore_status : status
      local_status : status
    VAREND

  collect_text command_file until='  collect_end'
    $system.osf$command_library.manage_network_applications

      display_tcpip_status application=application_name output=$null  status=define_status
      IF define_status.normal THEN
        activate_tcpip_application application=application_name status=define_status
      ELSEIF $condition(define_status.condition)='NAE$UNKNOWN_APPLICATION' THEN
        define_tcpip_application application=application_name protocol=datagram_socket status=define_status
        end_define_tcpip_application
        activate_tcpip_application application=application_name status=define_status
      IFEND
    quit
  collect_end

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  IF local_status.normal THEN
    IF define_status.normal THEN
      put_line '  '//$STRING(application_name)//' has been defined.' o=$response
    ELSE
      disv define_status
    IFEND
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$define_unnamed_udp_appl
*DECK DECK=RAP$DELETE_CRITICAL_FILES EXPAND=TRUE
PROC delete_critical_files (
  status : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" This is one of several procedures created to simplify the installation process.
" These procedures are kept in the OSF$SITE_COMMAND_LIBRARY and therefore will
" receive minimal support.
"
" The purpose of this procedure is to submit a batch job to delete files critical
" to a proper upgrade.  This procedure is called out in the upgrade chapter of the
" SRB.
*IFEND


  create_variable delete_job k=string v=$unique
  create_variable ignore_status k=status
  create_variable local_status k=status


COLLECT_TEXT $fname(delete_job) until='END_COLLECT'
  JOB jc=system
    WHEN any_fault DO
      put_line $strrep(osv$status) o=$response
    WHENEND

    create_variable local_status k=status

    TASK r=3
      delete_file f=$system.osf$operator_library
      delete_file f=$system.$account_log
      delete_file f=$system.$engineering_log
      delete_file f=$system.$history_log
      delete_file f=$system.$statistic_log
      delete_file f=$system.$system_log
    TASKEND
    display_log o=$user.delete_critical_files_log status=local_status
    change_catalog_entry f=$user.delete_critical_files_log nr=3
    IF local_status.normal THEN
      terminate_output n=output
    ELSE
      put_line $strrep(local_status) o=$response
    IFEND
  JOBEND
END_COLLECT

  include_file $fname(delete_job) status=local_status
  delete_file $fname(delete_job) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND delete_critical_files
*DECK DECK=RAP$DELETE_NFS_TIME_SERVERS EXPAND=TRUE
PROCEDURE rap$delete_nfs_time_servers (
  terminate_active_connections, tac : boolean = false
  status                            : (var) status = $optional )

  create_variable tcp_daytime_status kind=status
  create_variable tcp_time_status    kind=status
  create_variable udp_daytime_status kind=status
  create_variable udp_time_status    kind=status
  create_variable local_status       kind=status

  crecle $system.software_maintenance.raf$library status=local_status

  IF local_status.normal THEN

    rap$delete_tcp_daytime_server tac=tac  status=tcp_daytime_status
    IF NOT tcp_daytime_status.normal THEN
      disv tcp_daytime_status o=$response
    IFEND

    rap$delete_tcp_time_server tac=tac  status=tcp_time_status
    IF NOT tcp_time_status.normal THEN
      disv tcp_time_status o=$response
    IFEND

    rap$delete_udp_daytime_server tac=tac  status=udp_daytime_status
    IF NOT udp_daytime_status.normal THEN
      disv udp_daytime_status o=$response
    IFEND

    rap$delete_udp_time_server tac=tac  status=udp_time_status
    IF NOT udp_time_status.normal THEN
      disv udp_time_status o=$reponse
    IFEND

    delcle $system.software_maintenance.raf$library

  ELSE

    EXIT_PROC WITH local_status

  IFEND

PROCEND rap$delete_nfs_time_servers


*DECK DECK=RAP$DELETE_ORASRV EXPAND=TRUE
PROCEDURE rap$delete_orasrv (
  terminate_active_connections, tac : boolean = false
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request deletes the ORACLE client.
*IFEND


  VAR
    command_file: file = $unique($local)
    delete_status: status
    ignore_status: status
    local_status: status
  VAREND

COLLECT_TEXT command_file until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$oracle_client tac=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$oracle_client status=delete_status
    IFEND

    deactivate_tcpip_application application=osa$oracle_client tas=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$oracle_client status=delete_status
    IFEND

  quit
COLLECT_END

  include_file command_file status=local_status
  delete_file command_file status=ignore_status


PROCEND rap$delete_orasrv

*DECK DECK=RAP$DELETE_ORASRVS EXPAND=TRUE
PROCEDURE rap$delete_orasrvs (
  terminate_active_connections, tac : boolean = false
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"    This request deletes the ORACLE server.
*IFEND

  VAR
    command_file: file = $unique($local)
    delete_status: status
    ignore_status: status
    local_status: status
  VAREND

COLLECT_TEXT command_file until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$oracle_server_tcp tac=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$oracle_server_tcp status=delete_status
    IFEND

    deactivate_tcpip_application application=osa$oracle_server_tcp tas=terminate_active_connections ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$oracle_server_tcp status=delete_status
    IFEND

  quit
COLLECT_END

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

PROCEND rap$delete_orasrvs

*DECK DECK=RAP$DELETE_PREVIOUS_CYCLES EXPAND=FALSE

  PROCEDURE [XREF] rap$delete_previous_cycles
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR subproducts_failed_processing: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$DELETE_RLM EXPAND=TRUE
PROCEDURE rap$delete_rlm (
  terminate_active_connections, tac : boolean = false
  status)

  VAR
    command_file : file = $unique($local)
    delete_status : status
    ignore_status : status
    local_status : status
  VAREND

COLLECT_TEXT output=command_file until='COLLECT_END' sm='%'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=$REMOTE_LINE_MONITOR_CLIENT ..
          terminate_active_connections=%terminate_active_connections% ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = ..
          'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=$REMOTE_LINE_MONITOR_CLIENT status=delete_status
    IFEND
  quit
COLLECT_END

  include_file file=command_file status=local_status
  delete_file file=command_file status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal

  put_line line=' $REMOTE_LINE_MONITOR_CLIENT deleted.' ..
    output=$response

PROCEND rap$delete_rlm
*DECK DECK=RAP$DELETE_SMTP EXPAND=TRUE
PROCEDURE rap$delete_smtp (
  terminate_active_connections, tac: boolean = false
  status: status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"
"    This request deletes the SMTP client.
"
*IFEND


  "$FORMAT=OFF"
  VAR
    command_file: file = $unique($local)
    delete_status: status
    ignore_status: status
    local_status: status
  VAREND
  "$FORMAT=ON"

COLLECT_TEXT command_file until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$smtp_client tac=terminate_active_connections ..
          status=delete_status
    IF (delete_status.normal) OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$smtp_client status=delete_status
      IF (NOT delete_status.normal) AND ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
        delete_status.normal = true
      IFEND
    IFEND
    deactivate_tcpip_application application=osa$smtp_client tas=terminate_active_connections ..
          status=delete_status
    IF (delete_status.normal) OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$smtp_client status=delete_status
      IF (NOT delete_status.normal) AND ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
        delete_status.normal = true
      IFEND
    ELSEIF ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
        delete_status.normal = true
    IFEND
  quit
COLLECT_END

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal


PROCEND rap$delete_smtp

*DECK DECK=RAP$DELETE_SMTPS EXPAND=TRUE
PROCEDURE rap$delete_smtps (
  terminate_active_connections, tac: boolean = false
  status: status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'
"
"    This request deletes the SMTP server.
"
*IFEND


  "$FORMAT=OFF"
  VAR
    command_file: file = $unique($local)
    delete_status: status
    ignore_status: status
    local_status: status
  VAREND
  "$FORMAT=ON"

COLLECT_TEXT command_file until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$smtp_server tac=terminate_active_connections ..
          status=delete_status
    IF (delete_status.normal) OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$smtp_server status=delete_status
      IF (NOT delete_status.normal) AND ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
        delete_status.normal = true
      IFEND
    IFEND
    deactivate_tcpip_application application=osa$smtp_server tas=terminate_active_connections ..
          status=delete_status
    IF (delete_status.normal) OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$smtp_server status=delete_status
        IF (NOT delete_status.normal) AND ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
          delete_status.normal = true
        IFEND
      ELSEIF ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
          delete_status.normal = true
      IFEND
  quit
COLLECT_END

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal
  EXIT_PROC WITH delete_status WHEN NOT delete_status.normal


PROCEND rap$delete_smtps

*DECK DECK=RAP$DELETE_SYSTEM_TASK EXPAND=TRUE
create_command_description name=(delete_system_task, remove_system_task, remst, delst) ..
      sp=clp$delete_system_task
*DECK DECK=RAP$DELETE_TCP_DAYTIME_SERVER EXPAND=TRUE
PROCEDURE rap$delete_tcp_daytime_server (
  terminate_active_connections, tac : boolean = false
  status                            : (var) status = $optional )

  create_variable command_file k=string v='$local.'//$unique
  create_variable delete_status_1 k=status
  create_variable delete_status_2 k=status
  create_variable ignore_status k=status
  create_variable local_status k=status


COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$tcp_daytime_server tac=terminate_active_connections ..
          status=delete_status_1
    IF delete_status_1.normal OR ($condition(delete_status_1.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$tcp_daytime_server status=delete_status_1
    IFEND

    IF delete_status_1.normal OR ($condition(delete_status_1.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status_1.normal = true
    IFEND

    deactivate_tcpip_application application=osa$tcp_daytime_server tas=terminate_active_connections ..
          status=delete_status_2
    IF delete_status_2.normal OR ($condition(delete_status_2.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$tcp_daytime_server status=delete_status_2
    IFEND

    IF delete_status_2.normal OR ($condition(delete_status_2.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status_2.normal = true
    IFEND

  quit
COLLECT_END

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  IF NOT delete_status_1.normal THEN
    disv delete_status_1
  IFEND

  IF NOT delete_status_2.normal THEN
    disv delete_status_2
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$delete_tcp_daytime_server
*DECK DECK=RAP$DELETE_TCP_TIME_SERVER EXPAND=TRUE
PROCEDURE rap$delete_tcp_time_server (
  terminate_active_connections , tac : boolean = false
  status                             : (var) status = $optional )

  create_variable command_file k=string v='$local.'//$unique
  create_variable delete_status_1 k=status
  create_variable delete_status_2 k=status
  create_variable ignore_status k=status
  create_variable local_status k=status


COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$tcp_time_server tac=terminate_active_connections ..
          status=delete_status_1
    IF delete_status_1.normal OR ($condition(delete_status_1.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$tcp_time_server status=delete_status_1
    IFEND

    IF delete_status_1.normal OR ($condition(delete_status_1.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status_1.normal = true
    IFEND

    deactivate_tcpip_application application=osa$tcp_time_server tas=terminate_active_connections ..
          status=delete_status_2
    IF delete_status_2.normal OR ($condition(delete_status_2.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$tcp_time_server status=delete_status_2
    IFEND

    IF delete_status_2.normal OR ($condition(delete_status_2.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status_2.normal = true
    IFEND

  quit
COLLECT_END

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  IF NOT delete_status_1.normal THEN
    disv delete_status_1
  IFEND

  IF NOT delete_status_2.normal THEN
    disv delete_status_2
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$delete_tcp_time_server
*DECK DECK=RAP$DELETE_UDP_DAYTIME_SERVER EXPAND=TRUE
PROCEDURE rap$delete_udp_daytime_server (
  terminate_active_connections, tac : boolean = false
  status                            : (var) status = $optional )

  create_variable command_file k=string v='$local.'//$unique
  create_variable delete_status_1 k=status
  create_variable delete_status_2 k=status
  create_variable ignore_status k=status
  create_variable local_status k=status


COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$udp_daytime_server tac=terminate_active_connections ..
          status=delete_status_1
    IF delete_status_1.normal OR ($condition(delete_status_1.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$udp_daytime_server status=delete_status_1
    IFEND

    IF delete_status_1.normal OR ($condition(delete_status_1.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status_1.normal = true
    IFEND

    deactivate_tcpip_application application=osa$udp_daytime_server tas=terminate_active_connections ..
          status=delete_status_2
    IF delete_status_2.normal OR ($condition(delete_status_2.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$udp_daytime_server status=delete_status_2
    IFEND

    IF delete_status_2.normal OR ($condition(delete_status_2.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status_2.normal = true
    IFEND

  quit
COLLECT_END

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  IF NOT delete_status_1.normal THEN
    disv delete_status_1
  IFEND

  IF NOT delete_status_2.normal THEN
    disv delete_status_2
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$delete_udp_daytime_server
*DECK DECK=RAP$DELETE_UDP_TIME_SERVER EXPAND=TRUE
PROCEDURE rap$delete_udp_time_server (
  terminate_active_connections, tac : boolean = false
  status                            : (var) status = $optional )

  create_variable command_file k=string v='$local.'//$unique
  create_variable delete_status_1 k=status
  create_variable delete_status_2 k=status
  create_variable ignore_status k=status
  create_variable local_status k=status


COLLECT_TEXT $fname(command_file) until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_client client=osa$udp_time_server tac=terminate_active_connections ..
          status=delete_status_1
    IF delete_status_1.normal OR ($condition(delete_status_1.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_client client=osa$udp_time_server status=delete_status_1
    IFEND

    IF delete_status_1.normal OR ($condition(delete_status_1.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status_1.normal = true
    IFEND

    deactivate_tcpip_application application=osa$udp_time_server tas=terminate_active_connections ..
          status=delete_status_2
    IF delete_status_2.normal OR ($condition(delete_status_2.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=osa$udp_time_server status=delete_status_2
    IFEND

    IF delete_status_2.normal OR ($condition(delete_status_2.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status_2.normal = true
    IFEND

  quit
COLLECT_END

  include_file $fname(command_file) status=local_status
  delete_file $fname(command_file) status=ignore_status

  IF NOT delete_status_1.normal THEN
    disv delete_status_1
  IFEND

  IF NOT delete_status_2.normal THEN
    disv delete_status_2
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$delete_udp_time_server
*DECK DECK=RAP$DELETE_UNNAMED_TCP_APPL EXPAND=TRUE
PROCEDURE rap$delete_unnamed_tcp_appl (
  terminate_active_sockets, tas : boolean = false
  status                            : (var) status = $optional )

    VAR
      application_name : name = UNNAMED_TCP_APPLICATION
      command_file : file = $unique($local)
      delete_status : status
      ignore_status : status
      local_status : status
    VAREND

COLLECT_TEXT command_file until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_tcpip_application application=application_name tas=terminate_active_sockets ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=application_name status=delete_status
    IFEND

    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status.normal = true
    IFEND

  quit
COLLECT_END

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  IF NOT delete_status.normal THEN
    disv delete_status
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$delete_unnamed_tcp_appl
*DECK DECK=RAP$DELETE_UNNAMED_UDP_APPL EXPAND=TRUE
PROCEDURE rap$delete_unnamed_udp_appl (
  terminate_active_sockets, tas : boolean = false
  status                            : (var) status = $optional )

    VAR
      application_name : name = UNNAMED_UDP_APPLICATION
      command_file : file = $unique($local)
      delete_status : status
      ignore_status : status
      local_status : status
    VAREND

COLLECT_TEXT command_file until='COLLECT_END'
  $system.osf$command_library.manage_network_applications

    deactivate_tcpip_application application=application_name tas=terminate_active_sockets ..
          status=delete_status
    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$APPLICATION_ALREADY_INACTIV') THEN
      delete_tcpip_application application=application_name status=delete_status
    IFEND

    IF delete_status.normal OR ($condition(delete_status.condition) = 'NAE$UNKNOWN_APPLICATION') THEN
      delete_status.normal = true
    IFEND

  quit
COLLECT_END

  include_file command_file status=local_status
  delete_file command_file status=ignore_status

  IF NOT delete_status.normal THEN
    disv delete_status
  IFEND

  EXIT_PROC WITH local_status

PROCEND rap$delete_unnamed_udp_appl
*DECK DECK=RAP$DELPV EXPAND=FALSE

*copyc cld$parameter_list
*copyc ost$status

PROCEDURE [XREF] rap$delpv (parameter_list: clt$parameter_list;
  VAR status: ost$status);

*DECK DECK=RAP$DISPLAY_ALL_INPUT EXPAND=TRUE
create_command_description name=(display_all_input, disai) ..
      sp=clp$display_all_input_command
*DECK DECK=RAP$DISPLAY_ALL_OUTPUT EXPAND=TRUE
create_command_description name=(display_all_output, disao) ..
      sp=clp$display_all_output_command
*DECK DECK=RAP$DISPLAY_CORRECTIONS_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] rap$display_corrections_command (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copyc cld$parameter_list
*copyc ost$status
*DECK DECK=RAP$DISPLAY_CRITICAL_WINDOW_LOG EXPAND=TRUE
create_command_description name=(display_critical_window_log, discwl) sp=lgp$display_critical_window_log
*DECK DECK=RAP$DISPLAY_JOB_LOG_TO_CMD_LOG EXPAND=FALSE

  PROCEDURE [XREF] rap$display_job_log_to_cmd_log
    (    installation_logs: rat$path;
         installation_identifier: rat$installation_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_identifier
*copyc rat$path
?? POP ??
*DECK DECK=RAP$DISPLAY_KILL_JOB_ACTION EXPAND=TRUE
create_command_description name=(display_kill_job_action, diskja) ..
      starting_procedure=jmp$_display_kill_job_action
*DECK DECK=RAP$DISPLAY_NAM_ATTRIBUTES EXPAND=TRUE
create_command_description name=(display_nam_attributes, disna) ..
      sp=nap$display_nam_attributes
*DECK DECK=RAP$DISPLAY_OPER_ACTION_MENU EXPAND=TRUE
create_command_description name=(display_operator_action_menu, display_operator_action_menus, disoam) ..
      sp=ofp$display_operator_menus_cmd
*DECK DECK=RAP$DISPLAY_OPER_ACTION_STATUS EXPAND=TRUE
create_command_description name=(display_operator_action_status, disoas) ..
      sp=ofp$display_operator_status_cmd
*DECK DECK=RAP$DISPLAY_PACKING_LIST EXPAND=FALSE
  PROCEDURE [XREF] rap$display_packing_list
    (    packing_list_path_p: ^fst$file_reference;
         subtitle_p: ^string(*);
         idb_title_path_p: ^fst$file_reference;
         display_option: ost$name;
         output_file_path_p: ^fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$name
*copyc fst$file_reference
?? POP ??
*DECK DECK=RAP$DISPLAY_PSRS_ANSWERED EXPAND=FALSE

  PROCEDURE [XREF] rap$display_psrs_answered
    (    psrs_answered_p: ^rat$psrs_answered;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc ost$status
*copyc rat$subproduct_info_types
?? POP ??
*DECK DECK=RAP$DISPLAY_SIF EXPAND=FALSE

  PROCEDURE [XREF] rap$display_sif
    (    subproduct_info_pointers: rat$subproduct_info_pointers,
         catalog_ref_p: ^fst$file_reference;
     VAR scratch_sequence_p: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc rat$subproduct_info_types
?? POP ??
*DECK DECK=RAP$DISPLAY_SITE_VED_NAMES EXPAND=TRUE
create_command_description name=(display_site_ved_names, dissvn) sp=ofp$_display_site_ved_names
*DECK DECK=RAP$DISPLAY_SYSTEM_ATTRIBUTE EXPAND=TRUE
create_command_description name=(display_system_attribute, dissa) ..
      sp=osp$display_system_attribute
*DECK DECK=RAP$DISPLAY_SYSTEM_CONFIGURATIO EXPAND=TRUE
PROC display_system_configuration, dissc (
  output, o: file = $output
  status)

  VAR
    display_status: status
    parameter: string
  VAREND
  parameter = 'output = '//$strrep($value(output))//' status = display_status'
  execute_task starting_procedure=cmp$display_mf_configuration tel=warning p=parameter
  EXIT_PROC WITH display_status

PROCEND display_system_configuration
*DECK DECK=RAP$DISPLAY_SYSTEM_LOG EXPAND=TRUE
create_command_description name=(display_system_log, dissl) ..
      sp=lgp$_display_system_log
*DECK DECK=RAP$DISPLAY_SYSTEM_TASK_DATA EXPAND=TRUE
create_command_description name=(display_system_task_data, disstd) ..
      sp=clp$display_system_task_command
*DECK DECK=RAP$DISPLAY_TAPE_SCAN_FREQUENCY EXPAND=TRUE
create_command_description name=(display_tape_scan_frequency, distsf) ..
      sp=clp$_display_tape_scan_freq_cmd
*DECK DECK=RAP$DISPLAY_TAPE_VALIDATION EXPAND=TRUE
create_command_description name=(display_tape_validation, distv) ..
      sp=clp$display_tape_validate_cmd
*DECK DECK=RAP$DISPLAY_VOL_CLASSIFICATION EXPAND=TRUE
create_program_description name=(display_volume_classification, disvc) ..
      sp=rap$display_vol_classification l=osf$current_library
*DECK DECK=RAP$END_INSTALL_NQS EXPAND=TRUE
PROCEDURE rap$end_install_nqs

  EXIT install_nqs

PROCEND rap$end_install_nqs
*DECK DECK=RAP$ESTABLISH_DIRECTORY_PTRS EXPAND=FALSE

  PROCEDURE [XREF] rap$establish_directory_ptrs
    (    installation_database: rat$path;
     VAR directory_pointers {input} : rat$idb_directory_pointers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$idb_directory_pointers
*copyc rat$path
?? POP ??
*DECK DECK=RAP$ESTABLISH_ICR_PACKLIST_PTRS EXPAND=FALSE

  PROCEDURE [XREF] rap$establish_icr_packlist_ptrs
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$ESTABLISH_ICR_SUBP_PTRS EXPAND=FALSE

  PROCEDURE [XREF] rap$establish_icr_subp_ptrs
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$ESTABLISH_JOB_CLASSES EXPAND=TRUE
PROCEDURE (HIDDEN) rap$establish_job_classes (
  initiate_jobs: boolean = $required
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure establishes job classes.
"
" DESIGN:
"   This procedure is called by OSP$INITIALIZE_VIRTUAL_SYSTEM on a normal deadstart and later by
"   ACTIVATE_JOB_ENVIRONMENT on all deadstarts.
"   When called by OSP$INITIALIZE_VIRTUAL_SYSTEM, the system scheduling profile is recovered and
"   initiation of jobs is prevented for classes other than SYSTEM and MAINTENANCE.
"   When called by ACTIVATE_JOB_ENVIRONMENT, the system scheduling profile is refreshed in memory
"   and initiation of jobs is allowed.
"
" NOTES:
"   When this procedure is called by the ACTIVATE_JOB_ENVIRONMENT command an event message is
"   used to help isolate where an error originated from.  The variable RAV$EVENT_MESSAGE is set for
"   establishing job classes and will be displayed along with the error should one occur.  The event
"   message is cleared if the procedure finishes without an error.
*IFEND


  IF $variable(rav$event_message, nonlocal) THEN
    "$FORMAT=OFF
    VAR
      rav$event_message: (XREF) status
    VAREND
    "$FORMAT=ON"
    rav$event_message=$status(false, 'RA', rae$establishing_error, 'job classes')
  IFEND

  " Create the subcatalog for scheduling.  Refresh or recover the system
  " scheduling profile.

  "$FORMAT=OFF
  VAR
    ignore_status: status
  VAREND
  "$FORMAT=ON"
  $system.create_catalog catalog=$system.scheduling status=ignore_status

  IF $value(initiate_jobs) THEN
    "$manage_active_scheduling
    $system.osf$builtin_library.manage_active_scheduling
      FOR EACH jc IN $profile_summary(job_class) DO
        change_job_class jc initiation_level=$job_class(jc initiation_level)
      FOREND
    QUIT save_change=true
  ELSE
    "$manage_active_scheduling
    $system.osf$builtin_library.manage_active_scheduling
    QUIT save_change=false
  IFEND

  IF $variable(rav$event_message, local) THEN
    rav$event_message.normal=true
  IFEND

PROCEND rap$establish_job_classes
*DECK DECK=RAP$ESTABLISH_PROCESSING_CNTRLS EXPAND=FALSE

  PROCEDURE [XREF] rap$establish_processing_cntrls
    (    multiple_job_processing: boolean;
         execute_in_job_of_caller: boolean;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$ESTABLISH_VARIABLES EXPAND=FALSE
 PROCEDURE [XREF] rap$establish_variables (VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=RAP$EXECUTE_INSTALLER_PROCS EXPAND=FALSE

  PROCEDURE [XREF] rap$execute_installer_procs
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR subproducts_failed_processing: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$EXECUTE_INSTALLER_PROCS_UTL EXPAND=FALSE

  PROCEDURE [XREF] rap$execute_installer_procs_utl
    (    subp_processing_record: rat$subp_processing_record;
         subproduct_data_available: boolean;
     VAR installation_control_record: rat$installation_control_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$path
*copyc rat$installation_control_record
*copyc rat$processing_types
*copyc rat$subproduct_info_pointers
?? POP ??
*DECK DECK=RAP$EXTERNALIZE_ACCESS_MODE EXPAND=FALSE

  PROCEDURE [XREF] rap$externalize_access_mode (access_mode: pft$permit_selections;
    VAR value: clt$value;
    VAR status: ost$status);

*copyc cld$value
*copyc pfd$permanent_file_definitions
*copyc ost$status


*DECK DECK=RAP$EXTERNALIZE_SHARE_MODE EXPAND=FALSE

  PROCEDURE [XREF] rap$externalize_share_mode (share_mode: pft$share_selections;
    VAR value: clt$value;
    VAR status: ost$status);

*copyc cld$value
*copyc pfd$permanent_file_attributes
*copyc ost$status


*DECK DECK=RAP$GENERATE_170_MODSET EXPAND=FALSE
 PROCEDURE [XREF] rap$generate_170_modset (old_lfn: amt$local_file_name;
        old_name: clt$path_name;
        new_lfn: amt$local_file_name;
        new_name: clt$path_name;
        lgo_lfn: amt$local_file_name;
        dir_lfn: amt$local_file_name;
    VAR compare_equal: BOOLEAN;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ost$status
*copyc clt$path_name
?? POP ??
*DECK DECK=RAP$GENERATE_OBJECT_CORRECTION EXPAND=FALSE

  PROCEDURE [XREF] rap$generate_object_correction
    (    base_file: fst$file_reference;
         current_file: fst$file_reference;
         new_file: fst$file_reference;
         calculate_checksums: boolean;
         base_checksum: rat$checksum;
         current_checksum: rat$checksum;
         element_p {output} : ^rat$element;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc rat$subproduct_info_types
?? POP ??
*DECK DECK=RAP$GENERATE_VE_DEADSTART_CAT EXPAND=TRUE
PROCEDURE rap$generate_ve_deadstart_cat (
  configuration_files_catalog, cfc: file = $system.site_os_maintenance.deadstart_commands
  deadstart_catalog_path: (VAR HIDDEN) file = $optional
  status)

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"    The purpose of this request is to create a deadstart catalog
"suitable for creating a deadstart tape.  It calls several other
"procedures to accomplish this task.
"
*IFEND


*copyc rav$maids_file_catalog_names

  "$FORMAT=OFF
  VAR
    bacpf_file: file = $local//$name($unique)
    command_file: file = $local//$name($unique)

    ignore_status: status
    local_status: status

    new_builtin_library: file
    new_deadstart_catalog: file
    new_link_output_catalog: file
    new_non_boot_drivers_file: file
    new_sou_library: file
    new_version_catalog: file

    nosve_builtin_library: file
    nosve_deadstart_catalog: file
    nosve_link_input_catalog: file
    nosve_maintenance_catalog: file
    nosve_non_boot_drivers_file: file
    nosve_sou_library: file
    nosve_version_file: file

    site_builtin_library: file
    site_maintenance_catalog: file
    site_non_boot_drivers_catalog: file
    site_sou_library: file

    system_level: name
    text: string
  VAREND
  "$FORMAT=ON"


main_block: ..
  BLOCK


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"    Determine the base (defined by RAV$SYSTEM) for all files and catalogs.
"
"    Get the OS release level.
"
"    Compute values for various catalog and file paths.  Most of these
"    paths are replacements for the values as they used to exist in the
"    installation table.
"
*IFEND

*copyc rav$system_root_variable

    nosve_maintenance_catalog = rav$system//name_nosve_maintenance_catalog
    nosve_deadstart_catalog = nosve_maintenance_catalog//name_deadstart_catalog
    nosve_non_boot_drivers_file = nosve_deadstart_catalog//name_non_boot_drivers_file
    nosve_builtin_library = nosve_deadstart_catalog//name_product_files_catalog//name_builtin_library
    nosve_sou_library = nosve_deadstart_catalog//name_product_files_catalog//name_sou_library
    nosve_link_input_catalog = nosve_maintenance_catalog//name_link_input_catalog
    nosve_version_file = nosve_link_input_catalog//name_os_version_file

    rap$get_system_level ovf=nosve_version_file sl=system_level status=local_status
    EXIT main_block WHEN NOT local_status.normal

    site_maintenance_catalog = rav$system//name_site_maintenance_catalog
    site_non_boot_drivers_catalog = site_maintenance_catalog//name_non_boot_drivers_catalog
    site_builtin_library = site_maintenance_catalog//name_osf_builtin_library
    site_sou_library = site_maintenance_catalog//name_osf_sou_library

    new_version_catalog = site_maintenance_catalog//system_level
    new_deadstart_catalog = new_version_catalog//name_deadstart_catalog
    new_link_output_catalog = new_version_catalog//name_link_output_catalog
    new_non_boot_drivers_file = new_deadstart_catalog//name_non_boot_drivers_file
    new_builtin_library = new_deadstart_catalog//name_product_files_catalog//name_builtin_library
    new_sou_library = new_deadstart_catalog//name_product_files_catalog//name_sou_library

    IF $specified(deadstart_catalog_path) THEN
      deadstart_catalog_path = new_deadstart_catalog
    IFEND


  build_dc_block: ..
    BLOCK


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"    Create a subcatalog in SITE_OS_MAINTENANCE representing the release
"    level for the deadstart tape being created.  The release level is
"    obtained from the procedure RAM$GET_SYSTEM_LEVEL.  The version catalog
"    which will contain the deadstart catalog and link output catalog is deleted
"    if any thing exists prior to initiating this command.
"
*IFEND


      $system.delete_catalog c=new_version_catalog do=catalog_and_contents status=ignore_status
COLLECT_TEXT o=command_file until='**' sm='?'
      $system.create_catalog c=new_version_catalog
      $system.create_catalog c=new_deadstart_catalog
      $system.create_catalog c=new_link_output_catalog
**
      $system.include_file f=command_file status=local_status
      $system.delete_file f=command_file status=ignore_status
      EXIT build_dc_block WHEN NOT local_status.normal



*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"  Backup and restore the NOSVE_MAINTENACE version of the deadstart catalog
"  into the SITE_OS_MAINTENANCE version of the deadstart catalog.
"  All low cycles are deleted from the SITE_OS_MAINTENANCE version of
"  the deadstart catalog after the restore has occurred.
"
*IFEND


      $system.put_line l=' Creating '//$string(new_deadstart_catalog) o=$response

COLLECT_TEXT o=command_file until='**'
  $system.BACKUP_PERMANENT_FILE bf=bacpf_file
    backup_catalog c=nosve_deadstart_catalog
    quit
  $system.RESTORE_PERMANENT_FILE l=$null
    restore_existing_catalog c=nosve_deadstart_catalog ..
                             ncn=new_deadstart_catalog ..
                             bf=bacpf_file
    quit
  $system.BACKUP_PERMANENT_FILE bf=$null
    exclude_highest_cycle number_of_cycles=1
    delete_catalog_content c=new_deadstart_catalog
    quit

**
      $system.include_file f=command_file status=local_status
      $system.delete_file f=command_file status=ignore_status
      $system.delete_file f=bacpf_file status=ignore_status
      EXIT build_dc_block WHEN NOT local_status.normal



*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"Any site modification to the load modules or procedures in SOU_LIBRARY
"or BUILTIN_LIBRARY must first be combined with the released version of the
"libraries found in the NOSVE_MAINTENANCE catalog.  A site modification exists
"when osf$sou_library or osf$builtin_library is found in the SITE_OS_MAINTENANCE
"catalog.
*IFEND


      rap$combine_builtin_library nbl=nosve_builtin_library ..
            sbl=site_builtin_library bl=new_builtin_library status=local_status
      EXIT build_dc_block WHEN NOT local_status.normal

      rap$combine_sou_library nsl=nosve_sou_library ssl=site_sou_library ..
            sl=new_sou_library status=local_status
      EXIT build_dc_block WHEN NOT local_status.normal


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"   Copy the configuration files, if present, from their site-maintained
"locations (CONFIGURATIONS_FILES_CATALOG) to
"their appropriate locations in the deadstart catalog.
*IFEND


      rap$copy_configuration_files configuration_files_catalog=configuration_files_catalog ..
            deadstart_catalog=new_deadstart_catalog status=local_status
      EXIT build_dc_block WHEN NOT local_status.normal



*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"    Link the operating system files creating the
"MONITOR_IMAGE, SYSTEM_CORE_IMAGE
"and JOB_IMAGE as output.
*IFEND


      $system.put_line ' Begin linking the OS files ...' o=$response
      rap$link_operating_system_ii ..
            nlic=nosve_link_input_catalog slic=site_maintenance_catalog ..
            dc=new_deadstart_catalog loc=new_link_output_catalog status= local_status
      EXIT build_dc_block WHEN NOT local_status.normal



*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"    The PP files are taken from the non_boot_drivers catalog.  All files found
"in this catalog are assumed to be pps suppied by the site
"They are formated with MANAGE_DEADSTART_FILES.
"Those pps that fail formating will be skipped and a
"message will be displayed.
*IFEND


      rap$combine_non_boot_drivers nnbdf=nosve_non_boot_drivers_file ..
            snbdc=site_non_boot_drivers_catalog ..
            nbdf=new_non_boot_drivers_file status=local_status
      EXIT build_dc_block WHEN NOT local_status.normal


"  Display the exact deadstart catalog path just created.

      text = ' Deadstart catalog created: ' // $string(new_deadstart_catalog)
      $system.put_line l=text o=output


    BLOCKEND build_dc_block

  BLOCKEND main_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal


PROCEND rap$generate_ve_deadstart_cat






*DECK DECK=RAP$GET_ACTIVATION_OPTION EXPAND=TRUE
PROCEDURE (hidden) rap$get_activation_option (
  menu_module, mm: name = $required
  activation_option, ao: (VAR) string 0 .. $max_name = $required
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure prompts the operator to determine if they wish to activate
"   the system.  The response is returned in the activation_option field of
"   installation_parameters.
*IFEND

  "$FORMAT=OFF
  VAR
    local_status: status
    selection: string
  VAREND
  "$FORMAT=ON"

  rap$prompt_via_menu menu_module=menu_module menu_selections=(production_usage, console_usage_only)..
         prompting_options=clear_screen selection_chosen=selection status=local_status

  IF local_status.normal THEN
    IF selection = 'PRODUCTION_USAGE' THEN
      activation_option = 'PRODUCTION'
    ELSEIF selection = 'CONSOLE_USAGE_ONLY' THEN
      activation_option = 'CONSOLE'
    IFEND
  ELSE
    EXIT procedure WITH local_status
  IFEND

PROCEND rap$get_activation_option
*DECK DECK=RAP$GET_CATALOG_FILE_NAMES EXPAND=TRUE
PROCEDURE rap$get_catalog_file_names (
  catalog, c: file = $required
  names, n: (VAR) list 0..$max_list of name = $required
  status)


  "$FORMAT=OFF
  VAR
    catalog_list: list 0..$max_list of string 0..60
    file_name: name
    ignore_status: status
    local_status: status
    scratch_file: file = $unique($local)
  VAREND
  "$FORMAT=ON"


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"  This routine processes the display_catalog list and locates all
"  file names in the specified catalog.  The result is a list of
"  these file names.
"
*IFEND


  main_block: ..
    BLOCK

  names = ()

  $system.set_file_attributes f=scratch_file pf=continuous
  $system.display_catalog c=catalog do=identifier o=scratch_file status=local_status
  EXIT main_block WHEN NOT local_status.normal

  $system.get_lines v=catalog_list i=scratch_file status=local_status
  EXIT main_block WHEN NOT local_status.normal

  catalog_list = $select(catalog_list, x(1, 10)='    FILE: ')
  names = $apply(catalog_list, $name(x(11, $size(x)-10)))

  BLOCKEND main_block

  $system.delete_file f=scratch_file status=ignore_status

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$get_catalog_file_names
*DECK DECK=RAP$GET_CATALOG_LIST EXPAND=TRUE
PROCEDURE rap$get_catalog_list (
  catalog, c: file = $required
  file_list, fl: file = $null
  depth, d: integer 1..$max_integer = 1
  file_count, fc: (VAR) integer = $optional
  status)


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"  The purpose of this request is to create a file listing of all the files
"under the specified catalog and it's subcatalogs.  Each file is listed by
"it's complete path name and a count is kept on the total number of files
"found if parameter file_count is specified.  NOTE: File_count must be initialized
"to '0' by the caller in order to work properly.
*IFEND


  "$FORMAT=OFF
  VAR
    ignore_status: status
    local_status: status
    scratch_file: file = $LOCAL//$name($unique)
    new_catalog: file
  VAREND
  "$FORMAT=ON"


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"  A catalog listing is obtained and processed line by line.
"An end of list marker is placed at the bottom of the list to
"determine when to stop list processing.  The DEPTH parameter
"is used to indicate how many subcatalog level to traverse
"looking for files.  The procedure decrements it by one.
"When the depth parameter = 0, subsequent catalogs are not searched.
*IFEND

  depth = depth - 1
  $system.set_file_attributes f=scratch_file fc=legible pf=continuous pw=65000
  $system.display_catalog c=catalog do=identifier o=scratch_file status=local_status
  IF NOT local_status.normal THEN
    $system.delete_file f=scratch_file status=ignore_status
    EXIT procedure WITH local_status
  IFEND

  $system.rewind_file f=scratch_file status=ignore_status
  LOOP
    line = ' '
    $system.accept_line v=line i=scratch_file//$name('$asis') status=local_status
    EXIT WHEN (NOT local_status.normal) OR (line = ' ')
    index = $scan_string('CATALOG:', line)

    IF (index <> 0) AND (depth > 0) THEN


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"  The catalog contains a subcatalog that is to be processed before
"continuing with the current catalog and the current catalog depth has
"not been exceeded.
*IFEND


      new_catalog = catalog//$name($substring(line, index+9, $size(line)-(index+8)))
      IF $specified(file_count) THEN
        rap$get_catalog_list new_catalog file_list depth file_count status=local_status
      ELSE
        rap$get_catalog_list new_catalog file_list depth status=local_status
      IFEND
      EXIT WHEN NOT local_status.normal
    ELSE

      index = $scan_string('FILE:', line) + 6
      IF index > 6 THEN


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"  The catalog contains a file.  Construct the path and add it to the file list.
*IFEND


        $system.put_line $string(catalog)//'.'//$substring(line, index, $size(line)-index+1) ..
              o=file_list//$name('$eoi') status=local_status
        EXIT WHEN NOT local_status.normal
        IF $specified(file_count) THEN
          file_count = file_count + 1
        IFEND
      IFEND
    IFEND

  LOOPEND
  $system.delete_file f=scratch_file status=ignore_status

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$get_catalog_list
*DECK DECK=RAP$GET_CONSOLE_TASK_STATUS EXPAND=FALSE

  PROCEDURE [XREF] rap$get_console_task_status
    (VAR task_restarted: boolean);
*DECK DECK=RAP$GET_CORRECTOR_ELEMENT EXPAND=FALSE
  PROCEDURE [XREF] rap$get_corrector_element (element: ost$name;
      VAR k: rat$element_index;
      VAR status: ost$status);

*copyc ost$name
*copyc ost$status
*copyc rat$correction_package

*DECK DECK=RAP$GET_CYCLE_DATA EXPAND=FALSE

  PROCEDURE [XREF] rap$get_cycle_data
    (    file_path: pft$path;
     VAR info_p {input} : pft$p_info;
     VAR cycles_p {output} : pft$p_cycle_array;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc pfd$catalog_info
*copyc ost$status
?? POP ??
*DECK DECK=RAP$GET_CYCLE_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] rap$get_cycle_information
    (    file: fst$file_reference;
     VAR attributes_checksum: integer;
     VAR modification_date_time: ost$date_time;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$date_time
*copyc ost$status
?? POP ??
*DECK DECK=RAP$GET_DECKS EXPAND=FALSE
  PROCEDURE [XREF] rap$get_decks (name: ost$name;
        old_path: clt$path_name;
        old_path_length: 1 .. clc$max_path_name_size;
        new_path: clt$path_name;
        new_path_length: 1 .. clc$max_path_name_size;
        old_deck: ost$name;
        new_deck: ost$name;
    VAR status: ost$status);

*copyc ost$name
*copyc clt$path_name
*copyc ost$status

*DECK DECK=RAP$GET_DECK_LIST EXPAND=FALSE
  PROCEDURE [XREF] rap$get_deck_list (path_name: string (osc$max_string_size);
        path_name_size: 1 .. osc$max_string_size;
        file_name: ost$name;
    VAR status: ost$status);

*copyc ost$name
*copyc ost$status

*DECK DECK=RAP$GET_DEVELOPMENT_DS_VALUE EXPAND=FALSE

  PROCEDURE [XREF] rap$get_development_ds_value
    (VAR development_deadstart: boolean);
*DECK DECK=RAP$GET_ELEMENTS_BY_CLASS EXPAND=FALSE
  PROCEDURE [XREF] rap$get_elements_by_class (class: rat$file_class;
      VAR element_list: ^array [1 .. *] of ost$name;
      VAR status: ost$status);

*copyc rat$file_class
*copyc ost$name
*copyc ost$status

*DECK DECK=RAP$GET_ELEMENTS_BY_PRODUCT EXPAND=FALSE
  PROCEDURE [XREF] rap$get_elements_by_product (product: ost$name;
      VAR element_list: ^array [1 .. *] of ost$name;
      VAR status: ost$status);

*copyc ost$name
*copyc ost$status

*DECK DECK=RAP$GET_ELEMENT_NAME EXPAND=FALSE

*copyc clt$file
*copyc ost$status

PROCEDURE [XREF] rap$get_element_name (base_file: clt$file;
  VAR element: string(7);  VAR user_library: boolean;  VAR status: ost$status);

*DECK DECK=RAP$GET_FILE_INFORMATION EXPAND=FALSE

  PROCEDURE [XREF] rap$get_file_information
    (    file_ref_p: ^fst$file_reference;
         file_path: pft$path;
         pf_info_record_p: pft$p_info_record;
         info_offset: pft$info_offset;
         validation_selections: rat$validation_selections;
         checksum_files: boolean;
     VAR validation_errors: {output} boolean;
     VAR element: {output} rat$element;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc pfd$catalog_info
*copyc rat$subproduct_info_types
*copyc rat$validation_selections
?? POP ??
*DECK DECK=RAP$GET_FILE_NAMES EXPAND=FALSE
  PROCEDURE [XREF] rap$get_file_names (element: ost$name;
        old_file: rat$file_values;
        new_file: rat$file_values;
    VAR status: ost$status);

*copyc ost$name
*copyc ost$status
*copyc rat$file_values

*DECK DECK=RAP$GET_FILE_PATH EXPAND=FALSE

  PROCEDURE [INLINE] rap$get_file_path
    (    path_ref_p: ^fst$file_reference;
     VAR sequence_p: {input, output} ^SEQ ( * );
     VAR path_p: ^pft$path;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      path_string: fst$path,
      path_string_size: fst$path_size;


    status.normal := TRUE;

    clp$evaluate_file_reference (path_ref_p^, $clt$file_ref_parsing_options [clc$use_$local_as_working_cat],
          FALSE, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_file_ref_to_string (evaluated_file_reference, FALSE,
          path_string, path_string_size, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT path_p: [1 .. evaluated_file_reference.number_of_path_elements] IN
          sequence_p;
    fsp$convert_fs_structure_to_pf (evaluated_file_reference, path_p);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$get_file_path;

{ PURPOSE:
{   This procedure takes the value of a PDT file parameter and
{   returns the value using two different Cybil variable formats.
{   Both variables are used in tailored release file processing.
{
{ DESIGN:
{   The file variables must be created in a sequence, so that they will survive
{   outside the scope of this procedure.  A pointer to the sequence and the
{   PDT file
{   parameter name are passed in.  Pointers to the two file variables are
{   passed out.
{
{ NOTES:
{

*copyc fst$file_reference
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc clp$convert_file_ref_to_string
*copyc clp$evaluate_file_reference
*copyc fsp$convert_fs_structure_to_pf
?? POP ??

*DECK DECK=RAP$GET_FILE_PATH_AND_REF EXPAND=FALSE

  PROCEDURE [INLINE] rap$get_file_path_and_ref
    (    pdt_input_string: string ( * );
     VAR sequence_p: {input, output} ^SEQ ( * );
     VAR path_p: ^pft$path;
     VAR path_ref_p: ^fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      path_string: fst$path,
      path_string_size: fst$path_size,
      value: clt$value;


    status.normal := TRUE;

    clp$get_value (pdt_input_string, 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_fs_path_elements (value.file.local_file_name, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$convert_file_ref_to_string (evaluated_file_reference, FALSE, path_string, path_string_size, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    NEXT path_ref_p: [path_string_size] IN sequence_p;
    path_ref_p^ := path_string (1, path_string_size);

    NEXT path_p: [1 .. evaluated_file_reference.number_of_path_elements] IN sequence_p;
    fsp$convert_fs_structure_to_pf (evaluated_file_reference, path_p);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rap$get_file_path_and_ref;

{ PURPOSE:
{   This procedure takes the value of a PDT file parameter and
{   returns the value using two different Cybil variable formats.
{   Both variables are used in tailored release file processing.
{
{ DESIGN:
{   The file variables must be created in a sequence, so that they will survive
{   outside the scope of this procedure.  A pointer to the sequence and the PDT file
{   parameter name are passed in.  Pointers to the two file variables are passed out.
{
{ NOTES:
{

*copyc fst$file_reference
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc clp$convert_file_ref_to_string
*copyc clp$get_fs_path_elements
*copyc clp$get_value
*copyc fsp$convert_fs_structure_to_pf
?? POP ??

*DECK DECK=RAP$GET_FILE_RING_ATTRIBUTES EXPAND=TRUE
PROCEDURE rap$get_file_ring_attributes (
  file_name, fn: file = $required
  ring, r: (VAR) array 1..3 of integer = $required
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'
"
"  This procedure gets the ring attributes of a file and places
"  them in a variable array parameter as separate integer values.
"  Array position 1 is R1, position 2 is R2, and position 3 is R3.
"
*IFEND


  VAR
    local_status: status
    file_attributes: list of any
  VAREND



*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'
"
"  The following IF check is performed because the function $FILE_ATTRIBUTES
"  cannot return a bad status if the file does not exist.
"
*IFEND


  file_attributes = $file_attributes(file_name (registered, ring_attributes))
  IF NOT file_attributes(1).registered THEN
    local_status = $status(FALSE, 'PF', pfe$unknown_permanent_file, $string(file_name))
  ELSE
    ring(1) = file_attributes(1).ring_attributes.r1
    ring(2) = file_attributes(1).ring_attributes.r2
    ring(3) = file_attributes(1).ring_attributes.r3
  IFEND

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$get_file_ring_attributes
*DECK DECK=RAP$GET_INITIAL_OPTION EXPAND=TRUE
PROCEDURE (hidden) rap$get_initial_option (
  installation_parameters, ip: (VAR) ..
*copy rat$installation_parameters
                                  = $required
  first_menu, fm : key install_tape_menu, initiation_menu keyend = $required
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure prompts the operator to determine if they wish to
"   install the installation tape or to activate the system for console usage
"   only (presumably for the purpose of doing a reload).
"   System initiation parameters are set based on the response.
*IFEND

  "$FORMAT=OFF
  VAR
    local_status: status
    selection: string = ''
    skip_first_menu : boolean = false
    menu_selection: string 0 .. $max_name
    menu_selection_chosen: boolean = FALSE
  VAREND
  "$FORMAT=ON"

  local_status.normal = true
  IF first_menu=initiation_menu THEN
    skip_first_menu = false
  ELSE
    skip_first_menu = true
  IFEND

get_input: ..
  WHILE NOT menu_selection_chosen DO

    menu_selection_chosen = true
    IF skip_first_menu THEN
      selection='INSTALL_INSTALLATION_TAPE'
      skip_first_menu = false
    ELSE
      rap$prompt_via_menu menu_module=initiation_menu menu_selections=(install_installation_tape, ..
            console_usage_only) prompting_options=clear_screen selection_chosen=selection status=local_status
    IFEND

    IF local_status.normal THEN

      IF selection = 'INSTALL_INSTALLATION_TAPE' THEN
        installation_parameters.installation_option = 'INSTALLATION_TAPE'
        rap$get_install_tape_values ip=installation_parameters ms=menu_selection
        IF menu_selection = '+QUIT' THEN
           menu_selection_chosen = false
        IFEND
      ELSEIF selection = 'CONSOLE_USAGE_ONLY' THEN
        installation_parameters.installation_option = 'NONE'
        installation_parameters.activation_option = 'CONSOLE'
      IFEND

    ELSE

      EXIT get_input

    IFEND

  WHILEND get_input

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$get_initial_option
*DECK DECK=RAP$GET_INSTALL_TAPE_VALUES EXPAND=TRUE
PROCEDURE (HIDDEN) rap$get_install_tape_values (
  installation_parameters, ip: (VAR) ..
*copy rat$installation_parameters
                                  = $required
  menu_selection, ms: (VAR) string 0..$max_name = $required
  )

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure prompts the operator by means of a menu to set the values for the installation
"   tape.
" NOTES:
"   The variable used to receive the selection_chosen from the prompt interfaces
"   must be of type string. Not a VAR parameter, not a string(0..31), just
"   a plain old STRING.
*IFEND


  "$FORMAT=OFF
  VAR
    local_status: status
    menu_response: string
    packing_list_name_valid: boolean
    parameters: $type(installation_parameters)
    save_previous_cycles_string: string 0..5
    value_selection: string
  VAREND
  "$FORMAT=ON"


  parameters = installation_parameters
  menu_response = ''
  menu_selection = ''
  parameters.packing_list = $translate(lower_to_upper, parameters.packing_list)
  parameters.evsn = $translate(lower_to_upper, parameters.evsn)
  parameters.rvsn = $translate(lower_to_upper, parameters.rvsn)
  parameters.tape_type = $translate(lower_to_upper, parameters.tape_type)

get_input: ..
  WHILE (menu_response <> '+GO') AND (menu_response <> '+NULL') DO

    save_previous_cycles_string = $strrep(parameters.save_previous_cycles)
    rap$prompt_via_menu mm=install_tape_menu ms=(packing_list external_vsn recorded_vsn tape_type ..
          save_previous_cycles) mp=(parameters.packing_list, parameters.evsn, parameters.rvsn, ..
          parameters.tape_type, save_previous_cycles_string) ..
          po=(allow_go, allow_null, allow_quit, clear_screen) sc=menu_response

    IF menu_response = 'PACKING_LIST' THEN

      packing_list_name_valid = false
      value_selection = ''
      REPEAT
        rap$prompt_for_value pm=install_tape_menu pn=packing_list_prompt po=allow_null vd=('name 1..16') ..
              vr=value_selection
        IF value_selection <> '+NULL' THEN
          rap$validate_packing_list_name pln=$trim($substr(value_selection, 1, 16)) ..
                require_user_acknowledgement=false plnv=packing_list_name_valid
        IFEND
      UNTIL (packing_list_name_valid) OR (value_selection = '+NULL')
      IF packing_list_name_valid THEN
        parameters.packing_list = $translate(lower_to_upper, $trim($substr(value_selection, 1, 16)))
      IFEND

    ELSEIF menu_response = 'EXTERNAL_VSN' THEN

      rap$prompt_for_value pm=install_tape_menu pn=external_vsn_prompt po=allow_null vd=('string 1..6') ..
            vr=value_selection

      IF value_selection <> '+NULL' THEN
        parameters.evsn = $translate(lower_to_upper, value_selection(2, $size($trim(value_selection))-2))
        IF parameters.rvsn = '' THEN
          parameters.rvsn = parameters.evsn
        IFEND
      IFEND

    ELSEIF menu_response = 'RECORDED_VSN' THEN

      rap$prompt_for_value pm=install_tape_menu pn=recorded_vsn_prompt po=allow_null vd=('string 1..6') ..
            vr=value_selection

      IF value_selection <> '+NULL' THEN
        parameters.rvsn = $translate(lower_to_upper, value_selection(2, $size($trim(value_selection))-2))
        IF parameters.evsn = '' THEN
          parameters.evsn = parameters.rvsn
        IFEND
      IFEND

    ELSEIF menu_response = 'TAPE_TYPE' THEN

      rap$prompt_for_value pm=install_tape_menu pn=tape_type_prompt po=allow_null ..
            vd=('key a mt9$1600 b mt9$6250 c mt18$38000') vr=value_selection

      IF value_selection <> '+NULL' THEN
        parameters.tape_type = $translate(lower_to_upper, value_selection)
        IF parameters.tape_type = 'A' THEN
          parameters.tape_type = 'MT9$1600'
        ELSEIF parameters.tape_type = 'B' THEN
          parameters.tape_type = 'MT9$6250'
        ELSEIF parameters.tape_type = 'C' THEN
          parameters.tape_type = 'MT18$38000'
        IFEND
      IFEND

    ELSEIF menu_response = 'SAVE_PREVIOUS_CYCLES' THEN

      rap$prompt_for_value pm=install_tape_menu pn=save_previous_cycles_prompt po=allow_null vd=(..
            'key yes no y n true false t f') vr=value_selection

      IF value_selection <> '+NULL' THEN
        value_selection = $translate(lower_to_upper, value_selection)

        IF ($substr(value_selection, 1) = 'T') OR ($substr(value_selection, 1) = 'Y') THEN
          parameters.save_previous_cycles = true
        ELSE
          parameters.save_previous_cycles = false
        IFEND

      IFEND

    ELSEIF (menu_response = '+GO') OR (menu_response = '+NULL') THEN

      IF (parameters.evsn = '') AND (parameters.rvsn = '') THEN
        $system.put_line ' '//$strrep($status(false, 'RA', rae$one_vsn_parameter_required))
        menu_response = ''
      IFEND
      rap$validate_packing_list_name pln=parameters.packing_list ..
            require_user_acknowledgement=false plnv=packing_list_name_valid
      IF NOT packing_list_name_valid THEN
        menu_response = ''
      IFEND
      IF menu_response = '' THEN
        rap$press_next
      IFEND

    ELSEIF menu_response = '+QUIT' THEN

      EXIT get_input

    IFEND

  WHILEND get_input

  IF menu_response <> '+QUIT' THEN
    installation_parameters = parameters
  IFEND
  menu_selection = menu_response

PROCEND rap$get_install_tape_values
*DECK DECK=RAP$GET_INST_TAPE_VALUES EXPAND=FALSE

  PROCEDURE [XREF] rap$get_inst_tape_values
    (VAR installation_tape_values: rat$installation_tape_values);

?? PUSH (LISTEXT := ON) ??
*copyc rat$installation_tape_values
?? POP ??
*DECK DECK=RAP$GET_JOBS_RECOVERED_VALUE EXPAND=FALSE

  PROCEDURE [XREF] rap$get_jobs_recovered_value
    (VAR jobs_recovered: boolean);
*DECK DECK=RAP$GET_MAJORITY_FILE_CLASS EXPAND=FALSE

  PROCEDURE [INLINE] rap$get_majority_file_class
    (    subproduct_index: rat$subproduct_count;
         icr: rat$installation_control_record;
     VAR majority_class_keyword : ost$name;
     VAR majority_file_class : rmt$mass_storage_class;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??

    VAR
      attributes_p: ^rat$subproduct_attributes;


    attributes_p := icr.subproduct_processing_records_p^ [subproduct_index].subproduct_info_pointers.
          attributes_p;

    IF icr.processing_header_p^.installation_defaults.ignore_storage_class THEN
      majority_class_keyword := 'PRODUCT';
    ELSEIF (attributes_p^.service_critical_file_size > attributes_p^.product_file_size) AND
          (attributes_p^.service_critical_file_size > attributes_p^.user_permanent_file_size) THEN
      majority_class_keyword := 'SERVICE_CRITICAL_PRODUCT';
    ELSEIF (attributes_p^.user_permanent_file_size > attributes_p^.product_file_size) AND
          (attributes_p^.user_permanent_file_size > attributes_p^.service_critical_file_size) THEN
      majority_class_keyword := 'USER_PERMANENT_FILE';
    ELSE
      majority_class_keyword := 'PRODUCT';
    IFEND;

    rmp$convert_keyword_to_class (majority_class_keyword, majority_file_class, status);

  PROCEND rap$get_majority_file_class;

{ PURPOSE:
{   This procedure returns the file storage class for the majority of the
{   subproducts files based on size.  The majority storage class is
{   returned as a keyword and a class character symbol.
{
{ DESIGN:
{   The installation default IGNORE_STORAGE_CLASS is used to determine
{   whether file class should be honored.  When set to true the majority
{   class is defaulted to PRODUCT.  This is used for INSS testing purposes.
{
{ NOTES:
{

*copyc ost$status
*copyc rat$installation_control_record
*copyc rmp$convert_keyword_to_class
?? POP ??

*DECK DECK=RAP$GET_NETWORK_ACTIVATE_VALUE EXPAND=FALSE

  PROCEDURE [XREF] rap$get_network_activate_value
    (VAR network_activation: boolean);
*DECK DECK=RAP$GET_NORMAL_DEFERRED_OPTION EXPAND=TRUE
PROCEDURE (hidden) rap$get_normal_deferred_option (
  installation_parameters, ip: (VAR) ..
*copy rat$installation_parameters
                                  = $required
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure prompts the operator by means of a menu to select one of the available system
"   initiation options for a normal deadstart with deferred products.  System initiation control values
"   are set based on the option selected.
*IFEND


  "$FORMAT=OFF
  VAR
    local_status: status
    selection: string
    menu_selection: string 0..$max_name
    menu_selection_chosen: boolean = false
    parameters: $type(installation_parameters)
    value_selection: string
  VAREND
  "$FORMAT=ON"


get_input: ..
  WHILE NOT menu_selection_chosen DO

    parameters = installation_parameters

    rap$prompt_via_menu menu_module=normal_deferred_menu menu_selections=(production_usage, ..
          console_usage_only, install_installation_tape, install_deferred_products) ..
          prompting_options=clear_screen selection_chosen=selection status=local_status
    menu_selection_chosen = true

    IF local_status.normal THEN

      IF selection = 'PRODUCTION_USAGE' THEN
        parameters.activation_option = 'PRODUCTION'
        parameters.installation_option = 'NONE'

      ELSEIF selection = 'CONSOLE_USAGE_ONLY' THEN
        parameters.activation_option = 'CONSOLE'
        parameters.installation_option = 'NONE'

      ELSEIF selection = 'INSTALL_INSTALLATION_TAPE' THEN
        parameters.activation_option = 'CONSOLE'
        parameters.installation_option = 'INSTALLATION_TAPE'
        rap$get_install_tape_values ip=parameters ms=menu_selection
        IF menu_selection = '+QUIT' THEN
           menu_selection_chosen = false
        IFEND

      ELSEIF selection = 'INSTALL_DEFERRED_PRODUCTS' THEN
        parameters.activation_option = 'MANUAL' "The user is allowed to change this later."
        parameters.installation_option = 'DEFERRED_PRODUCTS'

      IFEND

    ELSE
      EXIT get_input
    IFEND

  WHILEND get_input

  EXIT procedure WITH local_status WHEN NOT local_status.normal
  installation_parameters = parameters

PROCEND rap$get_normal_deferred_option

*DECK DECK=RAP$GET_NORMAL_OPTION EXPAND=TRUE
PROCEDURE (hidden) rap$get_normal_option (
  installation_parameters, ip: (VAR) ..
*copy rat$installation_parameters
                                  = $required
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure prompts the operator by means of a menu to select one of the available system
"   initiation options for a normal deadstart.  System initiation control values are set based on
"   the option selected.
*IFEND


  "$FORMAT=OFF
  VAR
    local_status: status
    selection: string
    menu_selection: string 0 .. $max_name
    menu_selection_chosen: boolean = FALSE
    parameters: $type(installation_parameters)
  VAREND
  "$FORMAT=ON"

  parameters = installation_parameters

get_input: ..
  WHILE NOT menu_selection_chosen DO

    rap$prompt_via_menu menu_module=normal_menu menu_selections=(production_usage, console_usage_only, ..
          install_installation_tape) prompting_options=clear_screen selection_chosen=selection ..
          status=local_status
    menu_selection_chosen = true

    IF local_status.normal THEN
      IF selection = 'PRODUCTION_USAGE' THEN
        parameters.activation_option = 'PRODUCTION'
        parameters.installation_option = 'NONE'
      ELSEIF selection = 'CONSOLE_USAGE_ONLY' THEN
        parameters.activation_option = 'CONSOLE'
        parameters.installation_option = 'NONE'
      ELSEIF selection = 'INSTALL_INSTALLATION_TAPE' THEN
        parameters.activation_option = 'CONSOLE'
        parameters.installation_option = 'INSTALLATION_TAPE'
        rap$get_install_tape_values ip=parameters ms=menu_selection
        IF menu_selection = '+QUIT' THEN
           menu_selection_chosen = false
        IFEND
      IFEND
    ELSE
      EXIT get_input
    IFEND

  WHILEND get_input

  EXIT procedure WITH local_status WHEN NOT local_status.normal
  installation_parameters = parameters

PROCEND rap$get_normal_option
*DECK DECK=RAP$GET_SIF_POINTERS EXPAND=FALSE

  PROCEDURE [XREF] rap$get_sif_pointers
    (    seg_p: amt$segment_pointer;
         mmt_seg_p: mmt$segment_pointer;
         path_ref_p: ^fst$file_reference;
     VAR subproduct_info_pointers: {output} rat$subproduct_info_pointers;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc amt$segment_pointer
*copyc mmt$attribute_keyword
*copyc rat$subproduct_info_pointers
?? POP ??

*DECK DECK=RAP$GET_SYSTEM_ACTIVATION_VALUE EXPAND=FALSE

  PROCEDURE [XREF] rap$get_system_activation_value
    (VAR system_activation: boolean);
*DECK DECK=RAP$GET_SYSTEM_INITIATION_OPT EXPAND=TRUE
PROCEDURE (hidden) rap$get_system_initiation_opt (
  installation_parameters, ip: (VAR) ..
*copy rat$installation_parameters
                                  = $required
  )

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure returns the system initiation control option values in
"   the installation_parameters record.
" METHOD:
"   Which menus/prompts are displayed to the user, and therefore which
"   control values are returned is based upon variables set at system core
"   command entry.
"
"   Input variables and their source:
"     RAV$SYSTEM_ACTIVATION - boolean set via system attribute SYSTEM_ACTIVATION.
"     OSV$DEADSTART_PHASE - INITIAL/NORMAL set via use (or not) of INITIALIZE_DEADSTART_DEVICE command.
"     OSV$OPERATOR_INTERVENTION - true if system core command entry terminated with GO instead of AUTO.
"     RAV$JOBS_RECOVERED - TRUE if there are executing jobs to recover.
"     The presence of deferred files for installation also influences the users choices.
"
"   Factors for determining if user is prompted:
"     If OSV$OPERATOR_INTERVENTION is TRUE (operator terminated system core with GO),
"       the RAV$SYSTEM_ACTIVATION value is ignored and ACTIVATION_OPTION is set to MANUAL.
"     If OSV$OPERATOR_INTERVENTION is FALSE (operator terminated system core with AUTO),
"       ACTIVATION_OPTION is set to MANUAL if RAV$SYSTEM_ACTIVATION is false or to
"       AUTOMATIC if RAV$SYSTEM_ACTIVATION is true.
"     The user will be prompted if ACTIVATION_OPTION is MANUAL.
"
"   Processing possibilities:
"     -------------- Inputs -------------      Result
"      DST_PH  ACT_OPT    JOB_REC  DEF_FIL
"     initial  production   n/a      n/a       Automatically install the Installation Tape without prompting.
"                                              Activate production.
"     initial    manual     n/a      n/a       IO, AO set based upon get_initial_option prompt.
"     normal   production   n/a      n/a       Activate the system for production without prompting.
"     normal     manual    false    false      IO, AO set based upon get_normal_option prompt.
"     normal     manual    false    true       IO, AO set based upon get_normal_deferred_option prompt.
"     normal     manual    true      n/a       IO=NONE, activation determined by get_activation_option prompt.
"
"     n/a means value of this variable or condition is not a consideration
"
*IFEND


  WHEN any_fault DO

    installation_parameters.installation_option = 'NONE'
    installation_parameters.activation_option = 'CONSOLE'

    $system.put_line ' '//$strrep($status(false, 'RA', rae$establishing_error, 'system initiation option')) o=$response
    $system.put_line ' '//$strrep(osv$status) o=$response

    IF $variable(rav$errors_occurred, nonlocal) THEN
      "$FORMAT=OFF
      VAR
        rav$errors_occurred: (XREF) boolean
      VAREND
      "$FORMAT=ON"
      rav$errors_occurred = true
    IFEND

    rap$display_message mm=initiation_messages mn=continuing_without_action t=$output status=ignore_status

    rap$log_system_initiation_opt ip=installation_parameters

    EXIT procedure
  WHENEND


  "$FORMAT=OFF
  VAR
    deferred_products: boolean
    ignore_status: status
    menu_selection: string 0 .. $max_name
    osv$deadstart_phase: (XREF) string 0 .. $max_name
    osv$operator_intervention: (XREF) boolean
    packing_list_name_valid: boolean
    rav$jobs_recovered: (XREF) boolean
    rav$system_activation: (XREF) boolean
  VAREND
  "$FORMAT=ON"


  IF osv$operator_intervention THEN
    installation_parameters.activation_option = 'MANUAL'
  ELSEIF rav$system_activation THEN
    installation_parameters.activation_option = 'PRODUCTION'
  ELSE
    installation_parameters.activation_option = 'MANUAL'
  IFEND

  installation_parameters.installation_option = 'NONE' "initialize field

  IF installation_parameters.activation_option = 'PRODUCTION' THEN
    IF osv$deadstart_phase = 'INSTALL' THEN
      packing_list_name_valid = false
      rap$validate_packing_list_name installation_parameters.packing_list require_user_acknowledgement=true ..
        plnv=packing_list_name_valid
      if packing_list_name_valid then
        installation_parameters.installation_option = 'INSTALLATION_TAPE'
      else
        rap$get_initial_option ip=installation_parameters first_menu=install_tape_menu
      ifend
    ELSE
      installation_parameters.installation_option = 'NONE'
    IFEND
  ELSE
    IF osv$deadstart_phase  = 'INSTALL' THEN
      rap$get_initial_option ip=installation_parameters first_menu=initiation_menu
    ELSEIF rav$jobs_recovered THEN
      installation_parameters.installation_option = 'NONE'
      rap$get_activation_option menu_module=jobs_rec_activation ao=installation_parameters.activation_option
    ELSE
      rap$check_for_deferred_products deferred_products
      IF deferred_products THEN
        rap$get_normal_deferred_option ip=installation_parameters
      ELSE
        rap$get_normal_option ip=installation_parameters
      IFEND
    IFEND
  IFEND

  rap$log_system_initiation_opt ip=installation_parameters

PROCEND rap$get_system_initiation_opt

*DECK DECK=RAP$GET_SYSTEM_LEVEL EXPAND=TRUE
PROCEDURE rap$get_system_level (
  os_version_file, ovf    : file = $required
  system_level, sl        : (VAR) name = $required
  status)

*IF $variable(wev$prod_doc,declared)<>'UNKNOWN'
"
"  Extract the value of the currently installed operating system
"  level by including the file specified by the parameter OVF.
"  Doing so creates three variables, BUILD_ID, VERSION_ID, and
"  LEVEL_ID, which contain build level and release level information.
"
*IFEND

  VAR
    level_string: string
    local_status : status
  VAREND

  $system.include_file f=os_version_file status=local_status
  IF local_status.normal THEN
    IF $variable(level_id, defined) THEN
      system_level = level_id
    ELSE
      level_string = $trim($substr(version_id,16,6))
      system_level = $name('level_'//level_string)
    IFEND
  ELSE
    EXIT procedure WITH local_status WHEN NOT local_status.normal
  IFEND

PROCEND rap$get_system_level
*DECK DECK=RAP$GET_TABLE_ENTRY_INDEX EXPAND=FALSE

*copyc ost$name
*copyc rat$header_record
*copyc rat$installation_table
*copyc rat$inst_table_index
*copyc ost$status

PROCEDURE [XREF] rap$get_table_entry_index (
  file: ost$name; header: ^rat$header_record; table: ^rat$installation_table;
  VAR table_index: rat$inst_table_index; VAR status: ost$status);


*DECK DECK=RAP$HANDLE_STATUS EXPAND=TRUE
PROCEDURE (hidden) rap$handle_status (
  status_input, si: status = $required
  status_output, so: (VAR) status = $required
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"
" PURPOSE:
"   This procedure handles a bad status returned by some event on behalf of the calling procedure.
"
" DESIGN:
"   If there is any event message for the status to be handled it is displayed.  The status itself is
"   displayed.  Finally, the procedure returns with a general warning error if the error passed to it
"   was at error level or higher.  The event message is cleared.
*IFEND


  "$FORMAT=OFF
  VAR
    rav$event_message: (XREF) status
    status_input: status = $value(status_input)
  VAREND
  "$FORMAT=ON"


  IF NOT rav$event_message.normal THEN
    $system.put_line ' '//$strrep(rav$event_message) o=$response
    rav$event_message.normal=true
  IFEND

  $system.put_line l=(' '//$strrep(status_input) '  ') o=$response

  IF $variable(rav$errors_occurred, nonlocal) THEN
    "$FORMAT=OFF
    VAR
      rav$errors_occurred: (XREF) boolean
    VAREND
    "$FORMAT=ON"
    rav$errors_occurred=true
  IFEND

  IF $condition(status_input.condition)= 'RAE$ERRORS_OCCURRED_WARNING' THEN
    "Do not change STATUS_OUTPUT since warning error indicates more severe
    "error has already been recorded.
  ELSE
    $value(status_output)=$status(false, 'RA', rae$errors_occurred_warning)
  IFEND

PROCEND rap$handle_status
*DECK DECK=RAP$INITIALIZE_LOAD_OPTION EXPAND=FALSE
PROCEDURE [XREF] rap$initialize_load_option (status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=RAP$INITIALIZE_TAPE_VOL EXPAND=TRUE
*DECK DECK=RAP$INITIATE_SOU EXPAND=TRUE
PROCEDURE initiate_sou (
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'
" PURPOSE:
"   This procedure executes the sequence of commands required to initiate the system_operator_utility
"   (or other site operator interface) based upon a boolean variable set by activate_production_environment.
*IFEND

  "$FORMAT=OFF
  VAR
    local_status: status
    rav$activate_operator_interface: (XREF) string
    rav$initiate_operator_interface: (XREF) boolean
  VAREND
  "$FORMAT=ON"

  IF (rav$activate_operator_interface <> '') AND rav$initiate_operator_interface THEN
    $system.include_command rav$activate_operator_interface status=local_status
    IF NOT local_status.normal THEN
      $system.put_line (' '//..
$strrep($status(false, 'RA', rae$errors_occurred_warning, 'RAV$ACTIVATE_OPERATOR_INTERFACE')) ' '//..
$strrep(local_status)) o=$response
    IFEND
  IFEND

  " Two delete_variable's are needed to delete JOB defined variables.

  delete_variable n=rav$initiate_operator_interface status=local_status
  delete_variable n=rav$initiate_operator_interface status=local_status

PROCEND initiate_sou
*DECK DECK=RAP$INITIATE_SYSTEM EXPAND=TRUE
PROCEDURE initiate_system (
  task_restarted: (BY_NAME, HIDDEN) boolean = false
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure executes the sequence of commands required to initiate the system software and
"   environment.  It will conditionally invoke the system_operator_utility (or other site
"   operator interface) based upon a boolean variable set by activate_production_environment.
" NOTES:
"   The creation of the path variable RAV$SYSTEM is to allow for internal testing.
"   Margins have been turned off (set to 0) until all messages can be properly aligned together.  To
"   turn the margins back on replace the 0's with a 2.
"
"   Whenever the console interaction task is restarted, the operator environment reverts back
"   to the environment of the system job.  The environment is reset to the default operator
"   environment.  All site defined environment values have been lost.  A better solution to
"   this problem will be implemented at 1.4.1.
*IFEND


  IF $variable(rav$activate_operator_interface, nonlocal) THEN
    "$FORMAT=OFF
    VAR
      rav$activate_operator_interface: (XREF) string
    VAREND
    "$FORMAT=ON"
  ELSE
    "This is a scope JOB variable to deal with task_restarted=TRUE.
    "$FORMAT=OFF
    VAR
      rav$activate_operator_interface: (JOB) string = '$system.osf$sou_library.system_operator_utility i=$local.command'
    VAREND
    "$FORMAT=ON"
  IFEND

  IF $variable(rav$initiate_operator_interface, nonlocal) THEN
    "$FORMAT=OFF
    VAR
      rav$initiate_operator_interface: (XREF) boolean
    VAREND
    "$FORMAT=ON"
  ELSE
    "$FORMAT=OFF
    VAR
      rav$initiate_operator_interface: (JOB) boolean = false
    VAREND
    "$FORMAT=ON"
  IFEND

*copy rav$system_paths

  "$FORMAT=OFF
  VAR
    activation_status: status
    ignore_status: status
    osv$deadstart_phase: (XREF) string 0 .. $max_name
    rav$errors_occurred: (XDCL) boolean = false
    rav$margin: (XDCL) integer = 0
    rav$network_activation: (XREF) boolean
    rav$prompting_allowed: (XDCL) boolean = true
  VAREND
  "$FORMAT=ON"


  IF NOT task_restarted THEN

    IF osv$deadstart_phase = 'INSTALL' THEN
      "Prevent logging of errors on an INISD deadstart.
      rav$builtin_library.rap$create_operator_environment of=$null
    ELSE
      rav$builtin_library.rap$create_operator_environment
    IFEND

    PUSH file_connections
    $system.create_catalog c=rav$software_maintenance status=ignore_status
    $system.delete_file f=rav$system_initiation_log status=ignore_status
    $system.create_file_connection sf=$response f=rav$system_initiation_log.$eoi status=ignore_status

    rap$display_message mm=initiation_messages mn=initiating_system t=$response status=ignore_status
    rav$margin=rav$margin + 0

    activate_production_environment na=rav$network_activation status=activation_status

    IF NOT activation_status.normal THEN
      $system.put_line ' '//$strrep(activation_status) o=$response
      rav$errors_occurred=true
    IFEND

    IF rav$errors_occurred THEN
      rap$press_next
    IFEND

    rav$margin=rav$margin - 0
    rap$display_message mm=initiation_messages mn=system_initiation_complete t=$response status=ignore_status

    rap$display_message mm=initiation_messages mn=system_activation_complete t=$response status=ignore_status
    POP file_connections

  ELSE
    rav$initiate_operator_interface=true
    rav$builtin_library.rap$create_operator_environment
    $system.put_lines ('  WARNING: The operator environment (command list, working catalog, etc.)', ..
          '           may need to be recreated.') o=$response
  IFEND

PROCEND initiate_system
*DECK DECK=RAP$INIT_PROCESSING_SEQ EXPAND=FALSE

  PROCEDURE [XREF] rap$init_processing_seq
    (    packing_list_name: ost$name;
         save_previous_cycles: boolean;
         installation_command: rat$installation_commands;
         command_compatible_type: rat$subproduct_type;
         installation_defaults: rat$installation_defaults;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR processing_segment_pointer: amt$segment_pointer;
     VAR packing_list_fid: amt$file_identifier;
     VAR packing_list_opened: boolean;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$segment_pointer
*copyc ost$name
*copyc ost$status
*copyc rat$installation_commands
*copyc rat$installation_control_record
*copyc rat$installation_defaults
*copyc rat$subproduct_type
?? POP ??
*DECK DECK=RAP$INIT_PROCESSING_SEQ_FR_FILE EXPAND=FALSE

  PROCEDURE [XREF] rap$init_processing_seq_fr_file
    (    installation_control_file: fst$file_reference;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR processing_segment_pointer: amt$segment_pointer;
     VAR packing_list_fid: amt$file_identifier;
     VAR packing_list_opened: boolean;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$segment_pointer
*copyc fst$file_reference
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$INSERT_OR_REPLACE_CORRECTOR EXPAND=FALSE
  PROCEDURE [XREF] rap$insert_or_replace_corrector (file: rat$element_descriptor;
        corrector: ^SEQ ( * );
        size: oct$corrector_size;
        new_user_info: amt$user_info);

*copyc amd$file_attributes
*copyc rat$element_descriptor
*copyc oct$corrector

*DECK DECK=RAP$INSTALL_BATCH_FILTERS EXPAND=TRUE
PROCEDURE install_batch_filters (
  status)

" This procedure installs the Batch Output Filters Command Library.
" Only those filters that the site does not already have installed will be
" included.  The $device_attributes function will always be replaced.

  VAR
    bof_command_library: file = $system.batch_device_support.standard_filters.command_library
    bof_command_library_temp: file = $system.batch_device_support.standard_filters.command_library_temp
    bof_command_library_temp_new: file = $system.batch_device_support.standard_filters.command_library_temp_new
    ignore_status: status
    local_status: status
  VAREND

install_block: ..
  BLOCK

    $system.put_line l=' Installing '//$string(bof_command_library) o=$job_log

    execute_task l=$system.ocu.bound_product sp=ocp$_create_object_library lmo=none lm=$null tel=error
      add_modules l=bof_command_library_temp status=local_status
      EXIT install_block WHEN NOT local_status.normal
      combine_modules l=bof_command_library status=ignore_status
      combine_module l=bof_command_library_temp m=$device_attributes status=local_status
      EXIT install_block WHEN NOT local_status.normal
      generate_library l=bof_command_library_temp_new status=local_status
      EXIT install_block WHEN NOT local_status.normal
    QUIT

    install_file f=bof_command_library_temp_new t=bof_command_library am=(read execute) ra=(3 6 6) ..
          status=local_status
    EXIT install_block WHEN NOT local_status.normal

    TASK r=3
      $system.delete_file f=bof_command_library_temp_new status=local_status
      EXIT install_block WHEN NOT local_status.normal
    TASKEND

  BLOCKEND install_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND install_batch_filters
*DECK DECK=RAP$INSTALL_CDCNET_SOFTWARE EXPAND=TRUE
PROCEDURE install_cdcnet_software, inscs (
  status)

  "$FORMAT=OFF
  VAR
    actual_catalog: file
    cdcnet_catalog: file
    command_file: file = $unique($local)
    dcv$execution_path: (XDCL) string
    ignore_status: status
    installer_procedure_library: file
    local_status: status

    rav$subproduct_information: (XREF) rat$subproduct_information
    rav$installation_defaults: (XREF) rat$installation_defaults
    rav$installation_environment: (XREF) rat$installation_environment

  VAREND
  "$FORMAT=ON"


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"  This routine is the installer procedure for CDCNET.
"
*IFEND


  $system.put_line ' Installing CDCNET files ...' o=$job_log

  install_block: ..
    BLOCK


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"  Determine path to the library containing the installer
"  and miscellaneous procedures.
"
*IFEND

  rap$remove_elements_from_path p=rav$subproduct_information.installer_procedure ..
    noe=1 np=installer_procedure_library status=local_status
  EXIT install_block WHEN NOT local_status.normal
  actual_catalog = rav$subproduct_information.actual_installation_path


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"  Remove the VERSION_xxxx portion of the actual installation path.
"
*IFEND

  rap$remove_elements_from_path p=actual_catalog noe=1 np=cdcnet_catalog status=local_status
  EXIT install_block WHEN NOT local_status.normal
  dcv$execution_path = $string(cdcnet_catalog)


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"  UPDATE_LIBRARY if DI_OBJECT already exists; ie. a correction is being re-installed.
"  Otherwise, call INSTALL_FILE to install the base DI_OBJECT from the copy found in
"  the DI_PRODUCTS subcatalog
"
*IFEND

  IF $file(actual_catalog.DI_OBJECT permanent) THEN
    update_library f=actual_catalog.DI_PRODUCTS.BASE_DI_OBJECT ..
      l=actual_catalog.DI_OBJECT status=local_status
  ELSE
    install_file f=actual_catalog.DI_PRODUCTS.BASE_DI_OBJECT ..
      t=actual_catalog.DI_OBJECT status=local_status
  IFEND
  EXIT install_block WHEN NOT local_status.normal


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"  Install the version independent catalog.
"
*IFEND

  installer_procedure_library.install_version_independent ..
    cc=cdcnet_catalog vc=actual_catalog status=local_status
  EXIT install_block WHEN NOT local_status.normal

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"  If this is a release (not a correction) installation, install the
"  site controlled catalog.  If in addition to being a release, if the
"  subproduct name is cdcnet open shop (internal development subproduct),
"  install the npa database catalog.  If this is a correction installation,
"  locate and bring forward any uncorrected tips from the base version
"  subcatalog, and update the actual di object library with them.
"
*IFEND


  IF rav$subproduct_information.subproduct_type = RELEASE THEN
    installer_procedure_library.install_site_controlled ..
      cc=cdcnet_catalog vc=actual_catalog status=local_status
    EXIT install_block WHEN NOT local_status.normal

    IF rav$subproduct_information.subproduct_name <> CDCNET_OPEN_SHOP THEN
      installer_procedure_library.install_npa_databases ..
        cc=cdcnet_catalog vc=actual_catalog status=local_status
      EXIT install_block WHEN NOT local_status.normal
    IFEND

  ELSEIF rav$subproduct_information.subproduct_type = CORRECTION THEN
    installer_procedure_library.rap$bring_forward_uncor_tips
    EXIT install_block WHEN NOT local_status.normal

  IFEND

  $system.put_line ' CDCNET files installed.' o=$job_log

  BLOCKEND install_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND install_cdcnet_software
*DECK DECK=RAP$INSTALL_CDCNET_TIP EXPAND=TRUE
PROCEDURE install_cdcnet_tip (
  status)


  "$FORMAT=OFF
  VAR
    di_object_library: file
    ignore_status: status
    local_status: status
    message: string

    name_of_tip: name

    rav$subproduct_information: (XREF) rat$subproduct_information
    rav$installation_defaults: (XREF) rat$installation_defaults
    rav$installation_environment: (XREF) rat$installation_environment

    tip_library: file
  VAREND
  "$FORMAT=ON"

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"  This procedure installs a CDCNET separately priced tip.  This same
"  procedure can install any tip; the tip name is obtained from the
"  subproduct_name field of the subproduct_information variable.
"
*IFEND


  install_block: ..
    BLOCK

  name_of_tip = rav$subproduct_information.subproduct_name

  message = ' Merging the DI product '//$string(name_of_tip)//' onto DI_OBJECT.'
  $system.put_line l=message o=$job_log

  di_object_library = ..
    rav$subproduct_information.actual_installation_path.DI_OBJECT
  tip_library = ..
    rav$subproduct_information.actual_installation_path.DI_PRODUCTS//name_of_tip


*IF $variable(wev$prod_doc,declared)<>'UNKNOWN'
"
"  Call UPDATE_LIBRARY if the di object library already exists; otherwise
"  call INSTALL_FILE to create a new di object library file.
"
*IFEND

  IF $file(di_object_library permanent) THEN
    update_library f=tip_library l=di_object_library status=local_status
  ELSE
    install_file f=tip_library t=di_object_library status=local_status
  IFEND
  EXIT install_block WHEN NOT local_status.normal

  $system.put_line l=' Merge complete.' o=$job_log

  BLOCKEND install_block

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND install_cdcnet_tip
*DECK DECK=RAP$INSTALL_DEBUG EXPAND=TRUE
PROCEDURE install_debug (
  status)


  VAR
    local_status: status

    debug_bound_product: file
    name_bound_product: name = bound_product

    rav$subproduct_information: (XREF) rat$subproduct_information
    rav$installation_defaults: (XREF) rat$installation_defaults
    rav$installation_environment: (XREF) rat$installation_environment
  VAREND

  install_block: ..
    BLOCK

      debug_bound_product = ..
        rav$subproduct_information.actual_installation_path//name_bound_product
      $system.put_line l=' Installing Debug ...' o=$job_log
      $system.change_file_attributes debug_bound_product ..
        fp=debugger status=local_status
      EXIT install_block WHEN NOT local_status.normal

    BLOCKEND install_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND install_debug
*DECK DECK=RAP$INSTALL_DEFERRED_PRODUCTS EXPAND=TRUE
PROCEDURE (hidden) rap$install_deferred_products (
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure installs all currently deferred products.
"
" NOTES:
"
*IFEND


*copy rav$margin

  "$FORMAT=OFF
  VAR
    command_file: file = $unique($local)
    ignore_status: status
    local_status: status
    rav$system: (XREF) file
  VAREND
  "$FORMAT=ON"


  rap$display_message mm=initiation_messages mn=installing_deferred_products m=rav$margin t=$response ..
        status=ignore_status

COLLECT_TEXT o=command_file
  install_software
    IF rav$system <> :$system.$system THEN
      change_installation_defaults system_catalog=rav$system
    IFEND
    activate_products s=all
  quit
**
  $system.include_file f=command_file status=local_status
  $system.delete_file f=command_file status=ignore_status

  rap$create_operator_environment

  IF NOT local_status.normal THEN
    rap$press_next
  IFEND

  IF local_status.normal THEN
    rap$display_message mm=initiation_messages mn=deferred_products_installed m=rav$margin t=$response ..
          status=ignore_status
  IFEND

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$install_deferred_products

*DECK DECK=RAP$INSTALL_FILE EXPAND=TRUE
PROCEDURE rap$install_file (
  from, f: file = $required
  to, t: file = $required
  save_previous_cycles, spc: boolean = $optional
  access_modes, access_mode, am: list of key
      none, read, execute, append, modify, shorten, write, all, cycle, control
    keyend = $optional
  share_modes, share_mode, sm: list of key
      none, read, execute, append, modify, shorten, write, all
    keyend = $optional
  application_information, ai: string 0..31 = $optional
  ring_attributes, ring_attribute, ra: (BY_NAME) list 1..3 of ..
    integer 1..15 = $optional
  storage_class, sc: any of
      key
        unspecified, product, service_critical_product, system_critical_file
        system_permanent_file, user_permanent_file
      keyend
      name 1..1
    anyend = $optional
  status)

  VAR
    command_file: file = $local//$name($unique)
    delete_extra_cycles: boolean = false
    destination_file_exists: boolean = false
    from_file_string: string
    high_cycle: integer
    hold_string_am: string 0..$max_string = ''
    hold_string_sm: string 0..$max_string = ''
    hold_string_ai: string 0..$max_string = ''
    ignore_status: status
    local_status: status
    loop: integer
    rav$installation_defaults: (XREF) rat$installation_defaults
    rav$installation_environment: (XREF) rat$installation_environment
    rav$subproduct_information: (XREF) rat$subproduct_information
    ring: array 1 .. 3 of integer
    task_ring: integer
    temp_file: file = $local//$name($unique)
  VAREND

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
" This routine copies a file from a source ('FROM') to a destination ('TO')
" and appropriately manages file permits and attributes.
"
" A note regarding backing up and restoring a file:
" If a cycle is backed up and restored to a non-existent file, permits
" are lost; however, ring attributes are retained.  Permits apply to
" files; ring attributes apply to cycles of a file.
"
" If the 'TO' file already exists, the following statements are true:
"   *  The $high cycle of 'FROM' is restored to the $next cycle of 'TO'
"   *  Permits of 'TO' are inherited from the existing destination file,
"      unless specifically overridden by parameters or installation
"      default/environment variables.
"
" If the 'TO' file does not exist, the following statements are true:
"   *  All cycles of 'FROM' are restored to 'TO'
"   *  Permits of 'TO' are inherited from the cycles of 'FROM', unless
"      specifically overidden by parameters and/or values
"      contained in global variables.
"
*IFEND



  install_block: ..
    BLOCK


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"  Get the ring attributes of the 'FROM' file for later processing
"  The R2 value of the 'FROM' file determines the ring level of the
"  task that will perform the installation.
"
*IFEND


  IF $specified(ring_attributes) THEN
    ring(1) = ring_attributes(1)
    ring(2) = ring_attributes(2)
    ring(3) = ring_attributes(3)
  ELSE
    rap$get_file_ring_attributes fn=from r=ring status=local_status
    EXIT install_block WHEN NOT local_status.normal
  IFEND


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"  Establish requested storage class
"
"  Should 'TO' file inherit storage class from 'FROM' file????
"
*IFEND


  IF NOT rav$installation_defaults.ignore_storage_class THEN
    IF $specified(storage_class) THEN
      $system.include_command 'request_mass_storage to fc=storage_class' status=local_status
      EXIT install_block WHEN NOT local_status.normal
    IFEND
  IFEND



*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"  Backup and restore the source file ('FROM') to the destination file ('TO').
"  Use the ring established by R2 of 'FROM'.
"
*IFEND


  IF ring(2) < $ring THEN
    task_ring = ring(2)
  ELSE
    task_ring = $ring
  IFEND

  IF NOT $file(to permanent) THEN
COLLECT_TEXT command_file until='**'
    $system.osf$sou_library.system_operator_utility
        TASK r=task_ring
          $system.osf$builtin_library.backup_permanent_file bf=temp_file l=$null
            backup_file f=from
          quit
          $system.osf$builtin_library.restore_permanent_file l=$null
            restore_file f=from bf=temp_file nfn=to
          quit
        TASKEND
    quit
**
  ELSE    " Destination file ('TO') already exists
COLLECT_TEXT command_file until='**'
    destination_file_exists = true
    high_cycle = $file(from cycle_number)
    from_file_string = $string(from)//'.'//$string(high_cycle)
    $system.osf$sou_library.system_operator_utility
        TASK r=task_ring
          $system.osf$builtin_library.backup_permanent_file bf=temp_file l=$null
            backup_file f=$fname(from_file_string)
          quit
          $system.osf$builtin_library.restore_permanent_file l=$null
            restore_file f=$fname(from_file_string) bf=temp_file nfn=to.$next
          quit
      TASKEND
    quit
**
  IFEND

  $system.include_file f=command_file status=local_status
  $system.delete_file f=command_file status=ignore_status
  $system.delete_file f=temp_file status=ignore_status
  EXIT install_block WHEN NOT local_status.normal



*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"  Only delete previous cycles if requested, and only after a successful
"  file install has been performed, and only if the destination file existed
"  prior to the creation of the destination file ('TO').
"
"  The parameter SAVE_PREVIOUS_CYCLES takes precedence over the value of the
"  global variable SAVE_PREVIOUS_CYCLES
"
*IFEND


  IF destination_file_exists THEN
    delete_extra_cycles = NOT rav$installation_environment.save_previous_cycles
    IF $specified(save_previous_cycles) THEN
      delete_extra_cycles = NOT save_previous_cycles
    IFEND
    IF delete_extra_cycles THEN
      IF ring(1) < $ring THEN
        task_ring = ring(1)
      ELSE
        task_ring = $ring
      IFEND
COLLECT_TEXT command_file until='**'
    $system.osf$sou_library.system_operator_utility
        TASK r=task_ring
          $system.osf$builtin_library.backup_permanent_files bf=$null l=$list
            exclude_highest_cycle noc=1
            delete_file_contents f=to
          QUIT
        TASKEND
    quit
**
      $system.include_file f=command_file status=local_status
      $system.delete_file f=command_file status=ignore_status
      EXIT install_block WHEN NOT local_status.normal
    IFEND
  IFEND


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"  Create a public file permit for the destination file if the destination
"  file did not previously exist and any of the parameters access_modes,
"  share_modes, or application_information were specified.
"
*IFEND

    IF (NOT destination_file_exists) AND ..
         ($specified(access_modes) OR $specified(share_modes) OR $specified(application_information)) THEN
      $system.create_file_permit f=to g=public am=access_modes sm=share_modes ai=application_information ..
            status=local_status
      EXIT install_block WHEN NOT local_status.normal
    IFEND


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"  Establish proper file ring attributes for destination file.  If the
"  installation default variable RELAX_RING_SETTINGS is false, set the
"  destination file's ring attributes based on the following:
"
"     1.  If the parameter ring_attributes is specified, use these values;
"     2.  if not, use the ring attributes from the source file ('FROM').
"
"  If the installation default variable RELAX_RING_SETTINGS is true, set the
"  destination file's ring attributes based on the following:
"
"     1.  If the parameter ring_attributes is specified, use these values;
"     2.  If not, do not set any specific ring attributes for the destination
"         file ('FROM')
"
"
*IFEND


  IF (NOT rav$installation_defaults.relax_ring_settings) OR ..
     ((rav$installation_defaults.relax_ring_settings) AND ($specified(ring_attributes))) THEN
    $system.change_file_attributes to ra=(ring(1) ring(2) ring(3)) status=local_status
    EXIT install_block WHEN NOT local_status.normal
  IFEND


    BLOCKEND install_block

  EXIT procedure with local_status WHEN NOT local_status.normal

PROCEND rap$install_file
*DECK DECK=RAP$INSTALL_INITIAL_LOAD_SW EXPAND=TRUE
PROCEDURE install_initial_load_software (
  status)

  VAR
    ignore_status: status
    local_status: status
    loop: integer

    nosve_maintenance_catalog: file

    prolog_names: array 1..9 of name = (system_initiation_prolog ..
                                        system_initiation_epilog ..
                                        job_activation_prolog ..
                                        job_activation_epilog ..
                                        system_termination_prolog ..
                                        network_activation_prolog ..
                                        network_activation_epilog ..
                                        network_deactivation_prolog ..
                                        network_deactivation_epilog ..
                                       )

    name_nosve_maintenance: name = nosve_maintenance
    name_prolog_catalog: name = prologs_and_epilogs
    name_osf_command_library: name = osf$command_library

    rav$installation_defaults: (XREF) rat$installation_defaults
    rav$installation_environment: (XREF) rat$installation_environment
    rav$subproduct_information: (XREF) rat$subproduct_information

    source_prolog_catalog: file
    system_prolog_catalog: file
    system_catalog: file

  VAREND

  nosve_maintenance_catalog = ..
    rav$subproduct_information.actual_installation_path//name_nosve_maintenance
  system_catalog = ..
    rav$subproduct_information.actual_installation_path
  source_prolog_catalog = ..
    rav$subproduct_information.actual_installation_path//name_nosve_maintenance//name_prolog_catalog
  system_prolog_catalog = ..
    rav$subproduct_information.actual_installation_path//name_prolog_catalog


  install_block: ..
    BLOCK

      $system.create_catalog c=system_prolog_catalog status=ignore_status

      FOR loop = 1 to $upper_bound(prolog_names) DO
        IF NOT $file(system_prolog_catalog//prolog_names(loop) permanent) THEN
          $system.put_line l=' Installing '//$string(prolog_names(loop)) o=$job_log
          install_file f=source_prolog_catalog//prolog_names(loop) ..
            t=system_prolog_catalog//prolog_names(loop) status=local_status
          EXIT install_block WHEN NOT local_status.normal
        IFEND
      FOREND

      IF rav$subproduct_information.subproduct_type = release THEN
        install_file f=nosve_maintenance_catalog//name_osf_command_library ..
          t=system_catalog//name_osf_command_library status=local_status
        EXIT install_block WHEN NOT local_status.normal
      ELSE
        update_library f=nosve_maintenance_catalog//name_osf_command_library ..
          l=system_catalog//name_osf_command_library lock_out_library=false ..
          status=local_status
        EXIT install_block WHEN NOT local_status.normal
      IFEND

    BLOCKEND install_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal

" Call installer procedure for batch_output_filters.

  $system.software_maintenance.raf$library.install_batch_filters ..
        status=local_status

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND install_initial_load_software
*DECK DECK=RAP$INSTALL_INSTALLATION_TAPE EXPAND=TRUE
PROCEDURE (hidden) rap$install_installation_tape (
  installation_parameters, ip: (VAR) ..
*copy rat$installation_parameters
                                  = $required
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure installs the installation tape and creates the aam files.
"
" NOTES:
"   This routine assumes that packing list path has already been
"   checked to ensure that there will not be a collision when the packing
"   list is loaded.  Thus any error during the packing list load is of
"   unknown cause and it aborts the installation.
"
"   Need to check after each install for status rae$subproducts_failed_install
"
"   The error handling in this routine leaves something to be desired.
"   It should probably use rap$handle_status and do INSS in include files.
"   This, install_deferred_products and perform_installation_option need
"   the error handling modified to now consider that
"   install can return with warning/informative messages and yet have
"   the rest of system initiation continue.
*IFEND


*copy rav$margin

  "$FORMAT=OFF
  VAR
    create_status: status
    ignore_status: status
    local_status: status
    menu_selection: string 0 .. $max_name
    packing_list_loaded: boolean = false
    rav$software_maintenance: (xref) file
    rav$system: (xref) file
    tape_file: file
    temp_packing_list_name: name 1..16 = raf$temporary_pl
    temp_packing_list_path: file
    utility_status: status
    wait_for_operator_response: boolean = false
  VAREND
  "$FORMAT=ON"

  rap$display_message mm=initiation_messages ..
        mn=installing_installation_tape m=rav$margin t=$response ..
        status=ignore_status

  rap$load_installation_tools ip=installation_parameters tp=tape_file ..
        status=local_status
  EXIT procedure WITH local_status WHEN NOT local_status.normal

  inss_block: ..
  BLOCK

  "$ INSTALL_SOFTWARE
      $system.execute_task l=$local.raf$library sp=rap$install_software ..
            status=utility_status
      EXIT inss_block WHEN NOT utility_status.normal

    install_block: ..
      BLOCK

        IF rav$system <> :$system.$system THEN
          change_installation_defaults system_catalog=rav$system
        IFEND
        " Set tape back to the beginning_of_set so LOAD_PACKING_LIST will
        " find the packing list.
        change_tape_label_attributes f=tape_file fsp=bos status=local_status
        EXIT install_block WHEN NOT local_status.normal

        " Load the packing list into a temporary location to avoid possible collision.
        " Any conflicts are worked out when the packing list is moved to its
        " destination.

        temp_packing_list_path = rav$software_maintenance.installation_database//temp_packing_list_name
        $system.delete_file temp_packing_list_path status=ignore_status

        load_packing_list ..
              pl=temp_packing_list_name evsn=installation_parameters.evsn ..
              rvsn=installation_parameters.rvsn status=local_status
        EXIT install_block WHEN NOT local_status.normal

        rap$move_packing_list tplp=temp_packing_list_path ..
              pln=installation_parameters.packing_list status=local_status
        EXIT install_block WHEN NOT local_status.normal

        install_product pl=$name(installation_parameters.packing_list) ..
              p=nosve_installation_boot execute_in_job_of_caller=true ..
              spc=installation_parameters.save_previous_cycles ..
              status=local_status
        IF (NOT local_status.normal) AND ..
              (($condition(local_status.condition) = 'RAE$NO_SOFTWARE_TO_INSTALL') OR ..
               ($condition(local_status.condition) = 'RAE$SUBPRODUCTS_FAILED_INSTALL')) THEN
          $system.put_line l=' '//$strrep(local_status) o=$response
          wait_for_operator_response = TRUE
          local_status.normal = true
        IFEND
        EXIT install_block WHEN NOT local_status.normal

        install_product pl=$name(installation_parameters.packing_list) ..
              p=nosve_initial_software_load ..
              execute_in_job_of_caller=true ..
              spc=installation_parameters.save_previous_cycles ..
              status=local_status
        IF (NOT local_status.normal) AND ..
              (($condition(local_status.condition) = 'RAE$NO_SOFTWARE_TO_INSTALL') OR ..
               ($condition(local_status.condition) = 'RAE$SUBPRODUCTS_FAILED_INSTALL')) THEN
          $system.put_line l=' '//$strrep(local_status) o=$response
          wait_for_operator_response = TRUE
          local_status.normal = true
        IFEND
        EXIT install_block WHEN NOT local_status.normal

      BLOCKEND install_block

    QUIT

  BLOCKEND inss_block

  $system.detach_file f=tape_file status=ignore_status
  $system.detach_file f=$local.raf$library status=ignore_status

  " The operator environment must be recreated before the aam files can be created.

  rap$create_operator_environment

  IF wait_for_operator_response THEN
    rap$press_next
  IFEND

  IF local_status.normal AND utility_status.normal THEN
    rap$create_aam_files status=create_status
    IF NOT create_status.normal THEN
      $system.put_line (' '//$strrep($status(false, 'RA', rae$error_creating_aam_files)) ' '//$strrep(create_status)) ..
            o=$response
      local_status = $status(false, 'RA', rae$errors_occurred_warning, 'RAP$CREATE_AAM_FILES')
    IFEND
    rap$display_message mm=initiation_messages mn=installation_tape_installed m=rav$margin t=$response ..
          status=ignore_status
  IFEND

  EXIT procedure WITH local_status WHEN NOT local_status.normal
  EXIT procedure WITH utility_status WHEN NOT utility_status.normal

PROCEND rap$install_installation_tape
*DECK DECK=RAP$INSTALL_LIB99 EXPAND=TRUE
PROCEDURE install_lib99 (
  status)

"  This procedure installs lib99 vector or lib99 scalar
"  based on the processor model number.  The list of model
"  numbers of vector processors was taken from
"  PMT$PROCESSOR_MODEL_NUMBER deck.  There is a note in that
"  deck to update this procedure if the list changes.

VAR
  command_file: file = $local//$name($unique)
  high_cycle: integer
  ignore_status: status

  lib99_library: file
  lib99_file: file
  local_status: status
  model_number: string

  name_lib99_file: name = lib99
  name_lib99_vector_180 : name = lib99_vector_180
  name_lib99_vector_2000: name = lib99_vector_2000
  name_lib99_scalar: name = lib99_scalar

  rav$installation_defaults: (XREF) rat$installation_defaults
  rav$installation_environment: (XREF) rat$installation_environment
  rav$subproduct_information: (XREF) rat$subproduct_information


VAREND


  install_block: ..
    BLOCK

"  Install for both correction and release.

  model_number = $processor(model_number, 0)
  IF (model_number = '990') OR (model_number = '990E') OR (model_number = '9923') ..
        OR (model_number = '9943') THEN
    " This is a 180 vector processor.
    lib99_library = ..
      rav$subproduct_information.actual_installation_path//name_lib99_vector_180
  ELSEIF (model_number = '20V1') OR (model_number = '20U1') THEN
    " This is a 2000 vector processor.
    lib99_library = ..
      rav$subproduct_information.actual_installation_path//name_lib99_vector_2000
  ELSE
    " This is a scalar processor.
    lib99_library = ..
      rav$subproduct_information.actual_installation_path//name_lib99_scalar
  IFEND

  IF NOT $file(lib99_library permanent) THEN
    local_status = $status(FALSE, 'PF', pfe$unknown_permanent_file, $string(lib99_library))
    EXIT install_block WHEN NOT local_status.normal
  IFEND

  lib99_file = ..
    rav$subproduct_information.actual_installation_path//name_lib99_file

  $system.put_line l=' Installing '//$string(lib99_file) o=$job_log
  install_file f=lib99_library t=lib99_file status=local_status
  EXIT install_block WHEN NOT local_status.normal

  $system.create_file_permit f=lib99_file g=public am=(read execute) ..
    sm=(read execute)

  BLOCKEND install_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND install_lib99

*DECK DECK=RAP$INSTALL_MATH_LIBRARY EXPAND=TRUE
PROCEDURE install_math_library (
  status)

"  This procedure installs one of two  mlf$librarys depending on
"  the processor model number.  A special math library has been
"  created for the CYBER 2000s.   The list of model
"  numbers of vector processors was taken from
"  PMT$PROCESSOR_MODEL_NUMBER deck.  There is a note in that
"  deck to update this procedure if the list changes.

VAR
  command_file: file = $local//$name($unique)
  high_cycle: integer
  ignore_status: status

  cmml_library: file
  cmml_file: file
  local_status: status
  model_number: string

  name_cmml_file: name = mlf$library
  name_cmml_2000: name = mlf$library_2000
  name_cmml_180: name = mlf$library_180

  rav$installation_defaults: (XREF) rat$installation_defaults
  rav$installation_environment: (XREF) rat$installation_environment
  rav$subproduct_information: (XREF) rat$subproduct_information


VAREND


  install_block: ..
    BLOCK

"  Install for both correction and release.

  model_number = $processor(model_number, 0)
  IF (model_number = '20V1') OR (model_number = '20S1') OR (model_number = '20U1') THEN
    " This is a math library for the CYBER 2000.
    cmml_library = ..
      rav$subproduct_information.actual_installation_path//name_cmml_2000
  ELSE
    " This is the math library for the CYBER 180.
    cmml_library = ..
      rav$subproduct_information.actual_installation_path//name_cmml_180
  IFEND

  IF NOT $file(cmml_library permanent) THEN
    local_status = $status(FALSE, 'PF', pfe$unknown_permanent_file, $string(cmml_library))
    EXIT install_block WHEN NOT local_status.normal
  IFEND

  cmml_file = ..
    rav$subproduct_information.actual_installation_path//name_cmml_file

  $system.put_line l=' Installing '//$string(cmml_file) o=$job_log
  install_file f=cmml_library t=cmml_file status=local_status
  EXIT install_block WHEN NOT local_status.normal

  $system.create_file_permit f=cmml_file g=public am=(read execute) ..
    sm=(read execute)

  BLOCKEND install_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND install_math_library
*DECK DECK=RAP$INSTALL_MENU_VE EXPAND=TRUE
PROCEDURE install_menu_ve (
  status)

  VAR
    local_status: status
    rav$subproduct_information: (XREF) rat$subproduct_information
  VAREND

  IF rav$subproduct_information.subproduct_type = release THEN
    $system.put_line ' Completing conversion of MENU/VE from an APPLICATION to VE.' o=$job_log
    $system.include_command '$system.osf$builtin_library.convert_menu_ve' ..
      status=local_status
  IFEND

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND install_menu_ve
*DECK DECK=RAP$INSTALL_NOSVE_MAINTENANCE EXPAND=TRUE
PROCEDURE install_nosve_maintenance (
  status)

  VAR
    appac_deadstart_info_file: file
    command_file: file = $unique($local)
    deadstart_catalog: file
    ignore_status: status
    local_status: status
    nosve_maintenance_catalog: file
    field_maintenance_catalog: file
    rav$installation_environment: (XREF) rat$installation_environment
    rav$subproduct_information: (XREF) rat$subproduct_information
  VAREND

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"   This installer procedure is for the subproduct NOSVE_MAINTENANCE.
"
*IFEND


  install_block: ..
    BLOCK

      $system.put_line l=' Installing NOSVE_MAINTENANCE ...' o=$job_log

      qcu_maintenance_catalog   = $system.qcu_maintenance
      field_maintenance_catalog = $system.field_maintenance
      nosve_maintenance_catalog = rav$subproduct_information.actual_installation_path
      appac_deadstart_info_file = nosve_maintenance_catalog.RAF$APPAC_DEADSTART_INFO


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"   If this is a CORRECTION installation, check to see if a new deadstart
"tape is to be created. If the APPLY_ALL_CORRECTIONS deadstart information
"file is present, either a deadstart file or tape is to be generated.  This
"contains key variables with assigned values to determine the proper course
"of action.  All variable names in this file begin with RAV#APPAC.
"If this file is not present, no deadstart tape is to be generated.
"
*IFEND


   $system.put_line l=' Deleting QCU/CCU environment' o=$job_log
   $system.delete_catalog c=field_maintenance_catalog do=cac status=ignore_status
   $system.delete_catalog c=qcu_maintenance_catalog do=cac status=ignore_status

      IF rav$subproduct_information.subproduct_type = CORRECTION THEN

        IF $file(appac_deadstart_info_file permanent) THEN

          $system.include_file f=appac_deadstart_info_file status=local_status
          $system.delete_file f=appac_deadstart_info_file status=ignore_status
          EXIT install_block WHEN NOT local_status.normal

          IF rav#appac_installation_id <> rav$installation_environment.installation_identifier THEN
            EXIT install_block
          IFEND

          IF rav#appac_deadstart_medium = DISK THEN

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"   Generate a new deadstart catalog and leave it on disk.
"
*IFEND


COLLECT_TEXT command_file until='**'
            $system.osf$builtin_library.maintain_deadstart_software
              generate_ve_deadstart_catalog cfc=rav#appac_cfc_catalog
              quit
**
          ELSE " rav#appac_deadstart_medium = TAPE


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"
"   Generate a new deadstart catalog and write it to a tape.  When the
"tape completes, delete the deadstart catalog.
"
*IFEND


COLLECT_TEXT command_file until='**'
            $system.osf$builtin_library.maintain_deadstart_software
              generate_ve_deadstart_catalog cfc=rav#appac_cfc_catalog ..
                     deadstart_catalog_path=deadstart_catalog
              IF NOT rav$linker_errors_found THEN
                create_ve_deadstart_tape dc=deadstart_catalog evsn=rav#appac_evsn ..
                     rvsn=rav#appac_rvsn type=rav#appac_type ..
                     unload_deadstart_tape=rav#appac_udv
              IFEND
              $system.delete_catalog c=deadstart_catalog do=catalog_and_contents
**

          IFEND

          include_file f=command_file status=local_status
          delete_file command_file status=ignore_status
          EXIT install_block WHEN NOT local_status.normal

        IFEND

      IFEND

    BLOCKEND install_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND install_nosve_maintenance

*DECK DECK=RAP$INSTALL_NPA_DATABASES EXPAND=TRUE
PROCEDURE install_npa_databases, insnd (
  cdcnet_catalog, cc: file = $required
  version_catalog, vc: file = $required
  status)

  "Install all NPA databases.

  "$FORMAT=OFF
  VAR
    database_catalog: name = ANALYSIS
    dcv$execution_path: (XREF) string
    ignore_status: status
    local_status: status
    npa_commands: file = $local//$name($unique)
  VAREND
  "$FORMAT=ON"

  install_block: ..
    BLOCK

  $system.put_line l=' Installing NPA Data Base files ...' o=$job_log

  dcv$execution_path = $string(cdcnet_catalog)
  $system.create_catalog c=cdcnet_catalog//database_catalog status=ignore_status

COLLECT_TEXT npa_commands until='**' sm='?'
  ?cdcnet_catalog?.version_independent.command_library.network_performance_analyzer
   create_databases dbfun=?cdcnet_catalog?.?database_catalog?
   quit
**
  include_file f=npa_commands status=local_status
  detach_file f=npa_commands status=ignore_status
  EXIT install_block WHEN NOT local_status.normal

  BLOCKEND install_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND install_npa_databases

*DECK DECK=RAP$INSTALL_NQS EXPAND=TRUE
PROCEDURE rap$install_nqs (
  status)

  VAR
    coc: file = $command_of_caller
    ls: status
    source: file = $system.software_maintenance.raf$library
  VAREND

  SYSTEM_OPERATOR_UTILITY system_administration

    create_catalog $system.nqs.control status=ls
    create_catalog $system.nqs.transactions status=ls

    UTILITY n=install_nqs p='in' l=source t=$command
      command n=(define_nqs_host, defnh) p=rap$define_nqs_host
      command n=(define_validation_fields, defvf) p=rap$nqs_define_validation_flds
      command n=(update_network_files, updnf) p=rap$nqs_update_network_files
      command n=(quit, qui, end_install_nqs, endin) p=rap$end_install_nqs
      tablend

      $system.include_file f=coc u=install_nqs

    UTILITYEND
  QUIT

PROCEND rap$install_nqs

*DECK DECK=RAP$INSTALL_PPM EXPAND=TRUE
PROCEDURE install_ppm (
  status)


VAR
  ignore_status: status
  local_status: status

  name_dev_catalog: name = dev
  name_tmp_catalog: name = tmp
  name_usr_catalog: name = usr
  name_null_file: name = null

  c_catalog: file
  c_dev_catalog: file
  c_tmp_catalog: file
  c_usr_catalog: file
  c_usr_tmp_catalog: file
  c_dev_null_file: file

  rav$installation_defaults: (XREF) rat$installation_defaults
  rav$installation_environment: (XREF) rat$installation_environment
  rav$subproduct_information: (XREF) rat$subproduct_information

VAREND


  IF rav$subproduct_information.subproduct_type = release THEN
    c_catalog = rav$subproduct_information.actual_installation_path

    c_dev_catalog = c_catalog//name_dev_catalog
    c_tmp_catalog = c_catalog//name_tmp_catalog
    c_usr_catalog = c_catalog//name_usr_catalog
    c_usr_tmp_catalog = c_usr_catalog//name_tmp_catalog
    c_dev_null_file = c_dev_catalog//name_null_file

    $system.create_catalog c_catalog status=ignore_status
    $system.create_catalog c_dev_catalog status=ignore_status
    $system.create_catalog c_tmp_catalog status=ignore_status
    $system.create_catalog c_usr_catalog status=ignore_status
    $system.create_catalog c_usr_tmp_catalog status=ignore_status

    $system.create_catalog_permit c_tmp_catalog g=public ..
      am=(all, cycle, control) sm=none status=ignore_status
    $system.create_catalog_permit c_usr_tmp_catalog g=public ..
      am=(all, cycle, control) sm=none status=ignore_status

    COLLECT_TEXT c_dev_null_file until='END_COLLECT' status=ignore_status
END_COLLECT

    $system.change_file_attributes c_dev_null_file fc=unknown fs=unknown ..
      ra=(11 11 11) status=ignore_status
    $system.create_file_permit c_dev_null_file g=public am=none sm=none status=ignore_status
  IFEND

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND install_ppm

*DECK DECK=RAP$INSTALL_SITE_CONTROLLED EXPAND=TRUE
PROCEDURE install_site_controlled, inssc (
  cdcnet_catalog, cc: file = $required
  version_catalog, vc: file = $required
  status)

  "Install files to $SYSTEM.CDCNET.SITE_CONTROLLED catalog.

  "$FORMAT=OFF
  VAR
    ignore_status: status
    local_status: status
    loop: integer

    name_network_management: name = NETWORK_MANAGEMENT
    name_procedures: name = PROCEDURES
    name_site_controlled: name = SITE_CONTROLLED

    rav$subproduct_information: (XREF) rat$subproduct_information
    rav$installation_defaults: (XREF) rat$installation_defaults
    rav$installation_environment: (XREF) rat$installation_environment

    site_controlled_names: array 1..2 of name = (..
      configuration ..
      exception_list ..
      )
    procedure_names: array 1..3 of name = (..
      device_load ..
      terminal ..
      user ..
      )

  VAREND
  "$FORMAT=ON"

  install_block: ..
    BLOCK

  $system.put_line l=' Installing CDCNET Site Controlled files ...' o=$job_log

" create required catalogs

  $system.create_catalog cdcnet_catalog//name_site_controlled status=ignore_status
  $system.create_catalog cdcnet_catalog//name_site_controlled//name_network_management ..
    status=ignore_status
  $system.create_catalog cdcnet_catalog//name_site_controlled//name_procedures status=ignore_status

" Install the files"

  FOR loop = 1 to $upper_bound(site_controlled_names) DO
    IF NOT $file(cdcnet_catalog//name_site_controlled//site_controlled_names(loop), permanent) THEN
      install_file ..
        f=version_catalog//name_site_controlled//site_controlled_names(loop) ..
        t=cdcnet_catalog//name_site_controlled//site_controlled_names(loop) ..
        ra=(11 11 11) status=local_status
      EXIT install_block WHEN NOT local_status.normal
      delete_file_permit f=cdcnet_catalog//name_site_controlled//site_controlled_names(loop) ..
        g=public status=ignore_status
    IFEND
  FOREND



*IF $variable(rav$prod_doc,declared)<>'UNKNOWN'
"
"  The following code processes the file PROCESS_LOG_JOB.  In previous releases,
"  this file was in the VERSION_INDEPENDENT subcatalog of CDCNET.  It is now installed in
"  the SITE_CONTROLLED subcatalog.
"
"  To provide compatability with previous systems, this file is processed separately here.
"  The following logic applies to the code below to determine if the process log job file
"  should be installed.
"
"     1.  If the file currently exists in the version independent catalog, it is there as
"         a result of a previous release.  Leave it there, and do not install a new copy
"         into the site controlled catalog.
"
"     2.  If the file already exists in the site controlled catalog, do not install over
"         top of it.  The assumption is made that files in the site controlled catalog
"         are site modififable, and should not be overwritten by new release copies.
"
"     3.  If the above two tests indicate that the file currently does not exist in
"         version independent or site controlled, the file will be installed based on
"         the following logic:
"
"         a.  If the subproduct being installed (which called this installer procedure)
"             is not the cdcnet open shop subproduct, install the file.  This is the
"             customer's case.
"
"         b.  If the subproduct being installed is the cdcnet open shop product, this
"             is an internal installation.  It is not desired to use this file and
"             its related processes in open shop testing. Therefore, if the file
"             is found in the version catalog (ie. it was included on the open shop
"             product tape, voiding the statement about it not being desired to be
"             installed), install the file.  This case assumes that the file should
"             be installed.  If the file is not found in the version catalog, it
"             will not be installed.
"
"  The result of the above logic is that, in general, the process log job file and
"  its related processes are not normally required in cdcnet open shop testing;
"  therefore it is not installed, unless the file is present on the open shop
"  product tape.  If the file is already installed anyway, do not re-install it
"  because this is a site modifiable file.  If the file exists in the version
"  independent catalog (where is used to in previous releases), do not install
"  to site controlled, rather, let it remain in version independent.
"
*IFEND

  IF NOT $file(cdcnet_catalog.VERSION_INDEPENDENT.PROCESS_LOG_JOB, permanent) THEN
    IF NOT $file(cdcnet_catalog//name_site_controlled.PROCESS_LOG_JOB, permanent) THEN
      IF (rav$subproduct_information.subproduct_name <> CDCNET_OPEN_SHOP) OR ..
         ((rav$subproduct_information.subproduct_name = CDCNET_OPEN_SHOP) AND ..
           ($file(version_catalog//name_site_controlled.PROCESS_LOG_JOB, permanent))) THEN
        install_file ..
          f=version_catalog//name_site_controlled.PROCESS_LOG_JOB ..
          t=cdcnet_catalog//name_site_controlled.PROCESS_LOG_JOB ..
          ra=(11 11 11) status=local_status
        EXIT install_block WHEN NOT local_status.normal
        delete_file_permit f=cdcnet_catalog//name_site_controlled.PROCESS_LOG_JOB ..
          g=public status=ignore_status
      IFEND
    IFEND
  IFEND

  FOR loop = 1 to $upper_bound(procedure_names) DO
    IF NOT $file(cdcnet_catalog//name_site_controlled//name_procedures//procedure_names(loop), permanent) THEN
      install_file ..
        f=version_catalog//name_site_controlled//name_procedures//procedure_names(loop) ..
        t=cdcnet_catalog//name_site_controlled//name_procedures//procedure_names(loop) ..
        ra=(11 11 11) status=local_status
      EXIT install_block WHEN NOT local_status.normal
      delete_file_permit f=cdcnet_catalog//name_procedures//procedure_names(loop) ..
        g=public status=ignore_status
    IFEND
  FOREND


  BLOCKEND install_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND install_site_controlled
*DECK DECK=RAP$INSTALL_TDU EXPAND=TRUE
PROCEDURE install_tdu (
  status)

  VAR
    rav$subproduct_information: (XREF) rat$subproduct_information

    local_status: status
    tdu_catalog: file
  VAREND

  tdu_catalog = rav$subproduct_information.actual_installation_path

  $system.put_line l=' Installing terminal definitions.' o=$job_log
  install_file f=tdu_catalog.CDC_TERMINAL_DEFINITIONS ..
        t=tdu_catalog.TERMINAL_DEFINITIONS ..
        am=(read, execute) sm=(read, execute) status=local_status

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND install_tdu
*DECK DECK=RAP$INSTALL_VERSION_INDEPENDENT EXPAND=TRUE
PROCEDURE install_version_independent, insvi (
  cdcnet_catalog, cc: file = $required
  version_catalog, vc: file = $required
  status)

  "Install files to $SYSTEM.CDCNET.VERSION_INDEPENDENT catalog."

  "$FORMAT=OFF
  VAR
    local_status: status
    ignore_status: status
    name_version_independent: name = version_independent

    rav$subproduct_information: (XREF) rat$subproduct_information
    rav$installation_defaults: (XREF) rat$installation_defaults
    rav$installation_environment: (XREF) rat$installation_environment

    version_independent_names: array 1..5 of name = (..
      npailib ..
      npahlib ..
      cdcnet_version ..
      di_message_templates ..
      command_library ..
      )

  VAREND
  "$FORMAT=ON"

  install_block: ..
    BLOCK

  $system.put_line l=' Installing CDCNET Version Independent files ...' o=$job_log

" create the catalog"

  $system.create_catalog c=cdcnet_catalog//name_version_independent status=local_status
  IF local_status.normal THEN
    $system.create_catalog_permit cdcnet_catalog//name_version_independent ..
      g=public am=(read, execute) sm=(read, execute)
  ELSE
   local_status.normal = TRUE
  IFEND

" Install the files

  FOR loop = 1 to $upper_bound(version_independent_names) DO
    IF (rav$subproduct_information.subproduct_name <> CDCNET_OPEN_SHOP) OR ..
       ((rav$subproduct_information.subproduct_name  = CDCNET_OPEN_SHOP) and ..
         ($file(version_catalog//name_version_independent//version_independent_names(loop), permanent))) THEN
      install_file ..
        f=version_catalog//name_version_independent//version_independent_names(loop) ..
        t=cdcnet_catalog//name_version_independent//version_independent_names(loop) ..
        spc=true ra=(11 11 11) status=local_status
      EXIT install_block WHEN NOT local_status.normal
    IFEND
  FOREND


  BLOCKEND install_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND install_version_independent
*DECK DECK=RAP$INSTALL_XTF EXPAND=TRUE
PROCEDURE install_xtf    (
  status)

  VAR
    ignore_status: status
    local_status: status

    name_base_configuration: name = base_configuration
    name_initial_configuration: name = initial_configuration

    rav$installation_defaults: (XREF) rat$installation_defaults
    rav$installation_environment: (XREF) rat$installation_environment
    rav$subproduct_information: (XREF) rat$subproduct_information

    destination_xtf_file: file
    source_xtf_file: file
    xtf_catalog: file

  VAREND

  xtf_catalog = ..
    rav$subproduct_information.actual_installation_path
  source_xtf_file = xtf_catalog//name_initial_configuration
  destination_xtf_file = xtf_catalog//name_base_configuration


  install_block: ..
    BLOCK

      IF NOT $file(destination_xtf_file permanent) THEN
        $system.put_line l=' Installing '//$string(name_base_configuration) o=$job_log
        install_file f=source_xtf_file t=destination_xtf_file status=local_status
        EXIT install_block WHEN NOT local_status.normal
      IFEND

    BLOCKEND install_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND install_xtf
*DECK DECK=RAP$INTERNALIZE_ACCESS_MODE EXPAND=FALSE

  PROCEDURE [XREF] rap$internalize_access_mode (VAR internal_value_set: pft$permit_selections;
    VAR status: ost$status);

*copyc pfd$permanent_file_definitions
*copyc ost$status

*DECK DECK=RAP$INTERNALIZE_ATTRIBUTE_NAME EXPAND=FALSE

*copyc ost$name
*copyc ost$status
*copyc rat$entry_attributes

PROCEDURE [XREF] rap$internalize_attribute_name (attribute: ost$name;
  VAR internal_name: rat$entry_attributes;  VAR status: ost$status);

*DECK DECK=RAP$INTERNALIZE_FILE_CLASS EXPAND=FALSE

*copyc ost$name
*copyc rat$file_class
*copyc ost$status

PROCEDURE [XREF] rap$internalize_file_class (class: ost$name;
  VAR internal_value: rat$file_class;  VAR status: ost$status);

*DECK DECK=RAP$INTERNALIZE_FILE_FORMAT EXPAND=FALSE

*copyc ost$name
*copyc ost$status
*copyc rat$file_format

PROCEDURE [XREF] rap$internalize_file_format (format: ost$name;
  VAR internal_value: rat$file_format;  VAR status: ost$status);

*DECK DECK=RAP$INTERNALIZE_SHARE_MODE EXPAND=FALSE

  PROCEDURE [XREF] rap$internalize_share_mode (VAR internal_value_set: pft$share_selections;
    VAR status: ost$status);

*copyc pfd$permanent_file_attributes
*copyc ost$status

*DECK DECK=RAP$INTERVENE_IN_DEADSTART EXPAND=FALSE

PROCEDURE [XREF] rap$intervene_in_deadstart (VAR status: ost$status);

*copyc ost$status

*DECK DECK=RAP$ISOLATE_FILE_DIFFERENCES EXPAND=FALSE
  PROCEDURE [XREF] rap$isolate_file_differences (old_file_name: amt$local_file_name;
        new_file_name: amt$local_file_name;
    VAR corrector: ^SEQ ( * );
    VAR size: rat$corrector_size;
    VAR status: ost$status);

*copyc amt$local_file_name
*copyc rat$corrector_size
*copyc ost$status

*DECK DECK=RAP$ISOLATE_ISAM_DIFFERENCES EXPAND=FALSE
  PROCEDURE [XREF] rap$isolate_isam_differences (old_file: clt$path_name;
        new_file: clt$path_name;
    VAR corrector: ^SEQ ( * );
    VAR size: rat$corrector_size;
    VAR status: ost$status);

*copyc clt$path_name
*copyc rat$correction_package
*copyc ost$status
*DECK DECK=RAP$ISOLATE_SOURCE_CHANGES EXPAND=FALSE
  PROCEDURE [XREF] rap$isolate_source_changes (old_file: rat$file_values;
        new_file: rat$file_values;
    VAR corrector: ^SEQ ( * );
    VAR size: rat$corrector_size;
    VAR status: ost$status);

*copyc ost$status
*copyc rat$corrector_size
*copyc rat$file_values

*DECK DECK=RAP$ISSUE_MESSAGE EXPAND=FALSE
  PROCEDURE [XREF] rap$issue_message (output_file: amt$local_file_name;
    VAR message_status: ost$status;
    VAR status: ost$status);

*copyc amt$local_file_name
*copyc ost$status
*DECK DECK=RAP$LINE_LENGTH EXPAND=FALSE
FUNCTION rap$line_length (line: string(*)) : integer;

  VAR
    i: integer;

  rap$line_length := 0;
  /SKIP_TRAILING_BLANKS/
  FOR i := strlength(line) DOWNTO 1 DO
    IF line(i) <> ' ' THEN
      rap$line_length := i;
      EXIT /SKIP_TRAILING_BLANKS/;
    IFEND;
  FOREND /SKIP_TRAILING_BLANKS/;
FUNCEND rap$line_length;

*DECK DECK=RAP$LINK_OPERATING_SYSTEM_II EXPAND=TRUE
PROCEDURE rap$link_operating_system_ii (
  nosve_link_input_catalog, nlic: file = $required
  site_link_input_catalog, slic: file = $required
  deadstart_catalog, dc: file = $required
  link_output_catalog, loc: file = $required
  status)


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"    The purpose of this request is to link the OS files
"previously installed into the catalog specified by the
"SITE_LINK_INPUT_CATALOG parameter with the released versions.
"The path names to the files are hardcoded
"using this parameter as the base.  The bi-products of this procedure,
"files which are classified as OS_SUPPORT files (JOB_IMAGE, MONITOR_IMAGE,
"and SYSTEM_CORE_IMAGE) are placed in the catalog specified by the
"DEADSTART_CATALOG parameter.  All output from the link is stored in
"the catalog specified by the LINK_OUTPUT_CATALOG parameter.
"
"   This routine has been converted to SCL new types as much as it
"possibly can.  The three (3) common decks (*CALL) have not been
"converted to new types (Integration owns them).  Because of this,
"this procedure must interface to these common decks in the old SCL.
"
*IFEND


  "$FORMAT=OFF
  VAR
    directives_file: file = $LOCAL//$name($unique)
    ignore_status: status
    job_file: file = $LOCAL//$name($unique)
    jt_virtual_memory_string: string
    jt_link_map: string
    link_errors: file = $unique(:$local)
    link_input_catalog: string
    local_job_template_223: string = '$LOCAL.'//$unique
    local_job_template_23d: string = '$LOCAL.'//$unique
    local_status: status
    monitor_debug_table: string = '$LOCAL.'//$unique
    monitor_symbols_string: string = '$LOCAL.'//$unique
    monitor_virtual_memory_string: string = '$LOCAL.'//$unique
    new_deadstart_catalog: string
    new_link_output_catalog: string
    ol_job_template_223: string
    ol_job_template_236: string
    ol_job_template_23d: string
    ol_job_template_2dd: string
    ol_system_core_113: string
    ol_system_core_133: string
    ol_system_core_13d: string
    ol_system_core_1dd: string
    ol_monitor: string
    ol_message_templates: string
    os_version: string
    pageable_segment: integer = 2
    sc_link_map: string
    site_bound_job_template_223: string
    site_bound_job_template_23d: string
    site_os_maintenance: string
    system_core_debug_table: string = '$LOCAL.'//$unique
    system_debug_table: string
    system_symbols_string: string = '$LOCAL.'//$unique
    system_virtual_memory_string: string = '$LOCAL.'//$unique
    wired_segment: integer = 1
  VAREND
  "$FORMAT=ON"

  IF NOT $variable(rav$linker_errors_found, defined) THEN
    VAR
      rav$linker_errors_found: (JOB) boolean
    VAREND
  IFEND

  rav$linker_errors_found = FALSE
  link_input_catalog = $string(nosve_link_input_catalog)

  site_os_maintenance = $string(site_link_input_catalog)
  site_bound_job_template_223 = site_os_maintenance // '.OSF$BOUND_JOB_TEMPLATE_223'
  site_bound_job_template_23d = site_os_maintenance // '.OSF$BOUND_JOB_TEMPLATE_23D'

  new_deadstart_catalog = $string(deadstart_catalog)
  new_link_output_catalog = $string(link_output_catalog)



link_block: ..
  BLOCK


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"    Setup the variables with the paths for the linker output
"files.
*IFEND


    jt_virtual_memory_string = new_deadstart_catalog // '.job_image'
    monitor_virtual_memory_string = new_deadstart_catalog // '.monitor_image'
    system_virtual_memory_string = new_deadstart_catalog // '.system_core_image'
    jt_link_map = new_link_output_catalog // '.job_template_link_map'
    sc_link_map = new_link_output_catalog // '.system_core_link_map'
    system_debug_table = new_link_output_catalog // '.system_debug_table'



*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"    Setup the variable with the path for the input file for the
"monitor.
*IFEND



    ol_monitor = link_input_catalog // '.osf$bound_monitor'


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"    Setup the variables with the paths for the input files for
"the system core.
*IFEND


    ol_system_core_113 = link_input_catalog // '.osf$bound_system_core_113'
    ol_system_core_133 = link_input_catalog // '.osf$bound_system_core_133'
    ol_system_core_13d = link_input_catalog // '.osf$bound_system_core_13d'
    ol_system_core_1dd = link_input_catalog // '.osf$bound_system_core_1dd'



*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"    Setup the variables with the paths for the input files for
"the job template.
*IFEND


    ol_job_template_223 = link_input_catalog // '.osf$bound_job_template_223'
    ol_job_template_236 = link_input_catalog // '.osf$bound_job_template_236'
    ol_job_template_23d = link_input_catalog // '.osf$bound_job_template_23d'
    ol_job_template_2dd = link_input_catalog // '.osf$bound_job_template_2dd'
    ol_message_templates = link_input_catalog // '.osf$message_templates'



*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"    Obtain the VERSION_ID and the BUILD_ID for the OS files from
"the specified SYSTEM_CATALOG.  By doing an include file on the
"OSF$VERSION file the two variables are automatically created.
*IFEND


    os_version = link_input_catalog // '.os_version'
    $system.include_file f=$fname(os_version) status=local_status
    $system.detach_file f=$fname(os_version) status=ignore_status
    EXIT link_block WHEN NOT local_status.normal



*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"Any site modification to the load modules in OSF$BOUND_JOB_TEMPLATE_223 or
"OSF$BOUND_JOB_TEMPLATE_23D must first be merged onto the released versions
"found in the NOSVE_MAINTENANCE catalog.  A site modification exists when either
"OSF$BOUND_JOB_TEMPLATE_223 or OSF$BOUND_JOB_TEMPLATE_23D are found in the
"SITE_OS_MAINTENANCE catalog.
*IFEND


    IF $file($fname(site_bound_job_template_223) permanent) THEN
      $system.put_line (' Merging '//site_bound_job_template_223//' ..' '       with '//ol_job_template_223) ..
            o=$response

COLLECT_TEXT o=job_file until='**'
  $system.CREATE_OBJECT_LIBRARY
    add_modules l=$fname(ol_job_template_223)
    replace_modules l=$fname(site_bound_job_template_223)
    generate_library l=$fname(local_job_template_223)
  QUIT
  ol_job_template_223 = local_job_template_223
**
      $system.include_file f=job_file status=local_status
      $system.delete_file f=job_file status=ignore_status
      EXIT link_block WHEN NOT local_status.normal
    IFEND

    IF $file($fname(site_bound_job_template_23d) permanent) THEN
      $system.put_line (' Merging '//site_bound_job_template_23d//' ..' '       with '//ol_job_template_23d) ..
            o=$response

COLLECT_TEXT o=job_file until='**'
  $system.CREATE_OBJECT_LIBRARY
    add_modules l=$fname(ol_job_template_23d)
    replace_modules l=$fname(site_bound_job_template_23d)
    generate_library l=$fname(local_job_template_23d)
  QUIT
  ol_job_template_23d = local_job_template_23d
**
      $system.include_file job_file status=local_status
      $system.delete_file job_file status=ignore_status
      EXIT link_block WHEN NOT local_status.normal
    IFEND


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
" Link the monitor.
*IFEND


    map_file_string = $trim(sc_link_map)

    $system.put_line '   Linking monitor.' o=$response

COLLECT_TEXT directives_file until='**' status=ignore_status
  $system.LINK_VIRTUAL_ENVIRONMENT
*copy raf$monitor_linker_commands
  QUIT
**

    $system.include_file f=directives_file status=local_status
    $system.delete_file f=directives_file status=ignore_status
    EXIT link_block WHEN NOT local_status.normal


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
" Link the system core.
*IFEND


    input_debug_table = monitor_debug_table

    $system.put_line '   Linking system core.' o=$response

COLLECT_TEXT directives_file until='**' status=ignore_status
  $system.LINK_VIRTUAL_ENVIRONMENT
*copy raf$system_core_linker_commands
  QUIT
**

    $system.include_file f=directives_file status=local_status
    $system.delete_file f=directives_file status=ignore_status
    EXIT link_block WHEN NOT local_status.normal


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"  Link the job template.
"  Supplement the standard linker directives with a directive specifying where to get
"  cyf$run_time_library, in case the site analyst has added code that needs it.
*IFEND


    map_file_string = jt_link_map
    input_debug_table = system_core_debug_table

    $system.put_line '   Linking job template.' o=$response

COLLECT_TEXT directives_file until='**' status=ignore_status
  $system.LINK_VIRTUAL_ENVIRONMENT
    use_object_library $system.cybil.cyf$run_time_library ring_brackets=(3 13 13)
*copy raf$job_template_linker_comnds
  QUIT
**

    $system.include_file f=directives_file status=local_status
    $system.delete_file f=directives_file status=ignore_status
    EXIT link_block WHEN NOT local_status.normal


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"    Search the job template link map for errors.
*IFEND

    $system.software_maintenance.raf$library.search_link_map link_map=$fname(jt_link_map) ..
          output=link_errors status=local_status
    EXIT link_block WHEN NOT local_status.normal

    IF $file_attributes(link_errors, size) <> 0 THEN
      $system.put_line '   Linker errors found.  See file: ' o=$response
      $system.put_line '      '//jt_link_map o=$response
      rav$linker_errors_found = TRUE
      EXIT link_block
    IFEND

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"    Add the BUILD_ID to the output files created by this command.
*IFEND


    $system.change_file_attribute $fname(monitor_virtual_memory_string) ui=build_id status=ignore_status
    $system.put_line '   Linker output MONITOR VIRTUAL MEMORY IMAGE is installed as:' o=$response
    $system.put_line '      '//monitor_virtual_memory_string o=$response

    $system.change_file_attribute $fname(system_virtual_memory_string) ui=build_id status=ignore_status
    $system.put_line '   Linker output SYSTEM CORE VIRTUAL MEMORY IMAGE is installed as:' o=$response
    $system.put_line '      '//system_virtual_memory_string o=$response

    $system.change_file_attribute $fname(jt_virtual_memory_string) ui=build_id status=ignore_status
    $system.put_line '   Linker output JOB TEMPLATE VIRTUAL MEMORY IMAGE is installed as:' o=$response
    $system.put_line '      '//jt_virtual_memory_string o=$response

    $system.change_file_attribute $fname(sc_link_map) ui=build_id status=ignore_status
    $system.put_line '   Linker output SYSTEM CORE LINK MAP is installed as:' o=$response
    $system.put_line '      '//sc_link_map o=$response

    $system.change_file_attribute $fname(jt_link_map) ui=build_id status=ignore_status
    $system.put_line '   Linker output JOB TEMPLATE LINK MAP is installed as:' o=$response
    $system.put_line '      '//jt_link_map o=$response

    $system.change_file_attribute $fname(system_debug_table) ui=build_id status=ignore_status
    $system.put_line '   Linker output SYSTEM DEBUG TABLE is installed as:' o=$response
    $system.put_line '      '//system_debug_table o=$response


  BLOCKEND link_block

  $system.detach_file f=$fname(ol_system_core_113) status=ignore_status
  $system.detach_file f=$fname(ol_system_core_133) status=ignore_status
  $system.detach_file f=$fname(ol_system_core_13d) status=ignore_status
  $system.detach_file f=$fname(ol_system_core_1dd) status=ignore_status
  $system.detach_file f=$fname(ol_monitor) status=ignore_status
  $system.detach_file f=$fname(ol_job_template_223) status=ignore_status
  $system.detach_file f=$fname(ol_job_template_236) status=ignore_status
  $system.detach_file f=$fname(ol_job_template_23d) status=ignore_status
  $system.detach_file f=$fname(ol_job_template_2dd) status=ignore_status
  $system.detach_file f=$fname(ol_message_templates) status=ignore_status
  $system.detach_file f=$fname(sc_link_map) status=ignore_status
  $system.detach_file f=$fname(system_core_debug_table) status=ignore_status
  $system.detach_file f=$fname(system_debug_table) status=ignore_status
  $system.detach_file f=$fname(system_symbols_string) status=ignore_status
  $system.detach_file f=$fname(system_virtual_memory_string) status=ignore_status
  $system.detach_file f=$fname(monitor_debug_table) status=ignore_status
  $system.detach_file f=$fname(monitor_symbols_string) status=ignore_status
  $system.detach_file f=$fname(monitor_virtual_memory_string) status=ignore_status
  $system.detach_file f=$fname(jt_virtual_memory_string) status=ignore_status
  $system.detach_file f=$fname(jt_link_map) status=ignore_status
  $system.detach_file f=link_errors status=ignore_status

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$link_operating_system_ii
*DECK DECK=RAP$LOAD_BASE_1_FILES EXPAND=TRUE
PROC load_base_1_files, load_base_1_file, loab1f (
  tape_file, tf  : file = $local.tape
  files, file, f : list of key new_prologs_and_epilogs, npae, sitecp_components, sc, ..
                       site_analyst_examples_manual, saem, all, a ..
                 = (new_prologs_and_epilogs sitecp_components)
  status         : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" This is one of several procedures created to simplify the installation process.
" These procedures are kept in the OSF$SITE_COMMAND_LIBRARY and therefore will
" receive minimal support.
"
" The purpose of this procedure is to load the specified files off of the BASE_1
" release tape.  The files are loaded to $NEXT of their actual destination as
" when installed by UPGRADE_SOFTWARE (rings, file permits and storage class may
" not be set correctly).
*IFEND


  create_variable file_destination k=string d=11
  create_variable file_name k=(string $max_name) d=11
  create_variable file_selected k=boolean d=11 v=false
  create_variable ignore_status k=status
  create_variable load_selected_files k=string v=$unique
  create_variable local_status k=status
  create_variable restore_status k=status
  create_variable tape_file k=string v=$string($value(tape_file))
  create_variable tape_vsn k=(string 6) v='NVE003'


  FOR i = 1 TO $set_count(files) DO
    files = $string($value(files, i))
    IF (files = 'NEW_PROLOGS_AND_EPILOGS') OR (files = 'NPAE') OR (files = 'ALL') OR (files = 'A') THEN
      create_catalog $user.prologs_and_epilogs status=ignore_status

      file_name(1) = 'JOB_ACTIVATION_PROLOG'
      file_destination(1) = '$USER.PROLOGS_AND_EPILOGS.JOB_ACTIVATION_PROLOG.$NEXT'
      file_selected(1) = true

      file_name(2) = 'JOB_ACTIVATION_EPILOG'
      file_destination(2) = '$USER.PROLOGS_AND_EPILOGS.JOB_ACTIVATION_EPILOG.$NEXT'
      file_selected(2) = true

      file_name(3) = 'NETWORK_ACTIVATION_PROLOG'
      file_destination(3) = '$USER.PROLOGS_AND_EPILOGS.NETWORK_ACTIVATION_PROLOG.$NEXT'
      file_selected(3) = true

      file_name(4) = 'NETWORK_ACTIVATION_EPILOG'
      file_destination(4) = '$USER.PROLOGS_AND_EPILOGS.NETWORK_ACTIVATION_EPILOG.$NEXT'
      file_selected(4) = true

      file_name(5) = 'SYSTEM_INITIATION_PROLOG'
      file_destination(5) = '$USER.PROLOGS_AND_EPILOGS.SYSTEM_INITIATION_PROLOG.$NEXT'
      file_selected(5) = true

      file_name(6) = 'SYSTEM_INITIATION_EPILOG'
      file_destination(6) = '$USER.PROLOGS_AND_EPILOGS.SYSTEM_INITIATION_EPILOG.$NEXT'
      file_selected(6) = true

      file_name(7) = 'SYSTEM_TERMINATION_PROLOG'
      file_destination(7) = '$USER.PROLOGS_AND_EPILOGS.SYSTEM_TERMINATION_PROLOG.$NEXT'
      file_selected(7) = true
    IFEND
    IF (files = 'SITECP_COMPONENTS') OR (files = 'SC') OR (files = 'ALL') OR (files = 'A') THEN
      create_catalog $user.nosve_maintenance status=ignore_status
      create_catalog $user.nosve_maintenance.deadstart_commands status=ignore_status

      file_name(8) = 'INSTALLATION_DEADSTART_COMMANDS'
      file_destination(8) = '$USER.NOSVE_MAINTENANCE.DEADSTART_COMMANDS.INSTALLATION_DEADSTART_COMMANDS.$NEXT'
      file_selected(8) = true

      file_name(9) = 'SYSTEM_DEADSTART_PROLOG'
      file_destination(9) = '$USER.NOSVE_MAINTENANCE.DEADSTART_COMMANDS.SYSTEM_DEADSTART_PROLOG.$NEXT'
      file_selected(9) = true
    IFEND
    IF (files = 'SITE_ANALYST_EXAMPLES_MANUAL') OR (files = 'SAEM') OR (files = 'ALL') OR (files = 'A') THEN
      create_catalog $user.manuals status=ignore_status
      create_catalog $user.manuals.examples_files status=ignore_status

      file_name(10) = 'SA_EXAMPLES_MANUALS'
      file_destination(10) = '$USER.MANUALS.SITE_ANALYST_EXAMPLES.$NEXT'
      file_selected(10) = true

      file_name(11) = 'SA_EXAMPLES_SOURCE_LIBRARY'
      file_destination(11) = '$USER.MANUALS.EXAMPLES_FILES.SITE_ANALYST_SOURCE_LIBRARY.$NEXT'
      file_selected(11) = true
    IFEND
  FOREND


load_files: ..
  BLOCK

    IF NOT $file($fname(tape_file), assigned) THEN
      put_line '   Mount the BASE_1 tape with VSN NVE003.' o=$response
      request_magnetic_tape f=$fname(tape_file) evsn=tape_vsn r=no status=local_status
      EXIT load_files WHEN NOT local_status.normal
    IFEND

COLLECT_TEXT $fname(load_selected_files//'.$boi') until='END_COLLECT'
  $system.osf$builtin_library.restore_permanent_files l=$job_log
  FOR i = 1 TO $variable(file_selected, upper_bound) DO
    IF file_selected(i) THEN
      put_line ('   Loading '//file_name(i)//' to:', ..
            '      '//$string($fname(file_destination(i)))) o=$response
      restore_file f=$fname($backup_file($fname(tape_file), identifier)//'.'//file_name(i)//'.1') ..
            bf=$fname(tape_file) nfn=$fname(file_destination(i)) status=restore_status
      EXIT WHEN NOT restore_status.normal AND ..
            ($condition(restore_status.condition) <> 'PUE$ERROR_SUMMARY_STATUS')
    IFEND
  FOREND
  quit
END_COLLECT

    include_file $fname(load_selected_files) status=local_status
    detach_file $fname(tape_file) status=ignore_status
    IF local_status.normal AND NOT restore_status.normal AND ..
          ($condition(restore_status.condition) <> 'PUE$ERROR_SUMMARY_STATUS') THEN
      local_status = restore_status
    IFEND

  BLOCKEND load_files

  delete_file $fname(load_selected_files) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND load_base_1_files
*DECK DECK=RAP$LOAD_BASE_3_FILES EXPAND=TRUE
PROC load_base_3_files, load_base_3_file, loab3f (
  tape_file, tf  : file = $local.tape
  files, file, f : list of key srb, s, uib, u cip_support_library, csl, all, a ..
                 = $required
  status         : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" This is one of several procedures created to simplify the installation process.
" These procedures are kept in the OSF$SITE_COMMAND_LIBRARY and therefore will
" receive minimal support.
"
" The purpose of this procedure is to load the specified files off of the BASE_3
" release tape.  The files are loaded to $NEXT of their actual destination as
" when installed by UPGRADE_SOFTWARE (rings, file permits and storage class may
" not be set correctly).
*IFEND


  create_variable file_destination k=string d=4
  create_variable file_name k=(string $max_name) d=4
  create_variable file_selected k=boolean d=4 v=false
  create_variable ignore_status k=status
  create_variable load_selected_files k=string v=$unique
  create_variable local_tape_file k=string v=$unique
  create_variable local_status k=status
  create_variable restore_status k=status
  create_variable tape_file k=string v=$string($value(tape_file))
  create_variable tape_vsn k=(string 6) v='NVE005'


  FOR i = 1 TO $set_count(files) DO
    files = $string($value(files, i))
    IF (files = 'SRB') OR (files = 'S') OR (files = 'ALL') OR (files = 'A') THEN
      create_catalog $user.documentation status=ignore_status

      file_name(1) = 'SOFTWARE_RELEASE_BULLETIN'
      file_destination(1) = '$USER.DOCUMENTATION.SOFTWARE_RELEASE_BULLETIN.$NEXT'
      file_selected(1) = true
    IFEND
    IF (files = 'UIB') OR (files = 'U') OR (files = 'ALL') OR (files = 'A') THEN
      create_catalog $user.documentation status=ignore_status

      file_name(2) = 'USER_IMPACT_BULLETIN'
      file_destination(2) = '$USER.DOCUMENTATION.USER_IMPACT_BULLETIN.$NEXT'
      file_selected(2) = true

      file_name(3) = 'CREATE_UIB_ONLINE_MANUAL'
      file_destination(3) = '$USER.DOCUMENTATION.CREATE_UIB_ONLINE_MANUAL.$NEXT'
      file_selected(3) = true
    IFEND
    IF (files = 'CIP_SUPPORT_LIBRARY') OR (files = 'CSL') OR (files = 'ALL') OR (files = 'A') THEN

      file_name(4) = 'RAF$CIP_SUPPORT_LIBRARY'
      file_destination(4) = '$USER.RAF$CIP_SUPPORT_LIBRARY.$NEXT'
      file_selected(4) = true
    IFEND
  FOREND


load_files: ..
  BLOCK

    IF NOT $file($fname(tape_file), assigned) THEN
      put_line '   Mount the BASE_3 tape with VSN NVE005.' o=$response
      request_magnetic_tape f=$fname(tape_file) evsn=tape_vsn r=no status=local_status
      EXIT load_files WHEN NOT local_status.normal
    IFEND

COLLECT_TEXT $fname(load_selected_files//'.$boi') until='END_COLLECT'
  $system.osf$builtin_library.restore_permanent_files l=$job_log
  FOR i = 1 TO $variable(file_selected, upper_bound) DO
    IF file_selected(i) THEN
      put_line ('   Loading '//file_name(i)//' to:', ..
            '      '//$string($fname(file_destination(i)))) o=$response
      restore_file f=$fname($backup_file($fname(tape_file), identifier)//'.'//file_name(i)//'.1') ..
            bf=$fname(tape_file) nfn=$fname(file_destination(i)) status=restore_status
      EXIT WHEN NOT restore_status.normal AND ..
            ($condition(restore_status.condition) <> 'PUE$ERROR_SUMMARY_STATUS')
    IFEND
  FOREND
  quit
END_COLLECT

    include_file $fname(load_selected_files) status=local_status
    detach_file $fname(tape_file) status=ignore_status
    IF local_status.normal AND NOT restore_status.normal AND ..
          ($condition(restore_status.condition) <> 'PUE$ERROR_SUMMARY_STATUS') THEN
      local_status = restore_status
    IFEND

  BLOCKEND load_files

  delete_file $fname(load_selected_files) status=ignore_status

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND load_base_3_files
*DECK DECK=RAP$LOAD_INSTALLATION_TOOLS EXPAND=TRUE
PROCEDURE (HIDDEN) rap$load_installation_tools (
  installation_parameters, ip: (VAR) ..
*copy rat$installation_parameters
                                  = $required
  tape_file, tp: (VAR) file
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure loads the installation tools from the installation
"   tape.
"
" NOTES:
"   Three tries allowed when there are restore errors.
"
*IFEND


  "$FORMAT=OFF
  VAR
    ignore_status: status
    local_status: status
    menu_selection: string 0 .. $max_name
    number_of_trys: integer = 1
    installation_tools_loaded: boolean = false
    restore_status: status
    tape_name: string = '$local.raf$primary_tape_'
    tools_library: name = raf$library
    unique_catalog: file = $user//$name($unique)
  VAREND
  "$FORMAT=ON"

load_installation_tools: ..
  WHILE NOT installation_tools_loaded DO

    local_status.normal = true
    restore_status.normal = true
    IF number_of_trys > 3 THEN
      local_status = $status(false, 'RA', rae$invalid_installation_tape)
      EXIT load_installation_tools
    IFEND
    tape_file = $fname(tape_name//$trim(installation_parameters.rvsn)//'.1')
    detach_file f=tape_file status=ignore_status

    rap$display_message mm=initiation_messages ..
          mn=requesting_installation_tape mp=(..
          installation_parameters.evsn, installation_parameters.rvsn, ..
          installation_parameters.tape_type) t=$response status=ignore_status
    request_magnetic_tape f=tape_file ..
          evsn=installation_parameters.evsn rvsn=installation_parameters.rvsn ..
          type=$name(installation_parameters.tape_type) r=false status=local_status
    EXIT load_installation_tools WHEN NOT local_status.normal

    change_tape_label_attributes f=tape_file fsp=fsp ..
          fsn=2 "RAF$LIBRARY should be the second file on the tape."

"$RESTORE_PERMANENT_FILES
      $system.osf$builtin_library.restore_permanent_files l=$job_log ..
            status=restore_status
      EXIT load_installation_tools WHEN NOT restore_status.normal
      restore_catalog c=$fname($backup_file(tape_file)) bf=tape_file ..
            ncn=unique_catalog status=local_status
"$QUIT
    include_command c='QUIT' status=ignore_status

    IF (local_status.normal) AND (NOT restore_status.normal) THEN
      local_status = restore_status
    IFEND

    IF (local_status.normal) AND $file(unique_catalog//tools_library, permanent) THEN

      delete_file f=$local//tools_library status=ignore_status
      copy_file i=unique_catalog//tools_library ..
            o=$local//tools_library status=local_status
      EXIT load_installation_tools WHEN NOT local_status.normal
      delete_catalog c=unique_catalog do=cac status=ignore_status
      installation_tools_loaded = true

    ELSE

      detach_file f=tape_file status=ignore_status
      delete_catalog c=unique_catalog do=cac status=ignore_status
      number_of_trys = number_of_trys + 1
      IF local_status.normal THEN
        "Restore successfull but content was not the installation tools
        rap$display_message mm=initiation_messages ..
              mn=incorrect_installation_tape t=$response ..
              status=ignore_status
      ELSEIF $condition(local_status.condition) = ..
            'IFE$TERMINATE_BREAK_RECEIVED' THEN
            rap$display_message mm=initiation_messages ..
                 mn=user_aborts_tape_request t=$response ..
                 status=ignore_status
      ELSE
         $system.put_line l=' '//$strrep(local_status) o=$response
         rap$display_message mm=initiation_messages ..
             mn=unable_to_restore_from_tape t=$response ..
             status=ignore_status
      IFEND
      rap$press_next
      rap$get_install_tape_values ip=installation_parameters ..
            ms=menu_selection
      IF menu_selection = '+QUIT' THEN
        local_status = $status(false, 'RA', ..
              rae$install_aborted_by_user)
        restore_status.normal = true
        EXIT load_installation_tools
      IFEND

    IFEND

  WHILEND load_installation_tools

  EXIT procedure WITH local_status WHEN NOT local_status.normal
  EXIT procedure WITH restore_status WHEN NOT restore_status.normal

PROCEND rap$load_installation_tools

*DECK DECK=RAP$LOAD_PACKING_LIST EXPAND=FALSE

  PROCEDURE [XREF] rap$load_packing_list
    (    external_vsn: clt$parameter_value;
         recorded_vsn: clt$parameter_value;
         tape_type: clt$parameter_value;
         disk_file: clt$parameter_value;
         loading_destination: fst$file_reference;
         unload_volume: boolean;
         removable_media_group: clt$parameter_value;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_value
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=RAP$LOAD_PRODUCTS EXPAND=FALSE

  PROCEDURE [XREF] rap$load_products
    (VAR called_from_package_software: boolean;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR subproducts_failed_processing: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$LOCATE_DIRECTORY_RECORD EXPAND=FALSE

  PROCEDURE [XREF] rap$locate_directory_record
    (    subproduct_name: rat$subproduct_name;
         licensed_product: rat$licensed_product;
         directory_pointers: rat$idb_directory_pointers;
     VAR directory_record_p: ^rat$directory_record);


?? PUSH (LISTEXT := ON) ??
*copyc rat$idb_directory_pointers
?? POP ??
*DECK DECK=RAP$LOCATE_ELEMENT EXPAND=FALSE


  PROCEDURE [INLINE] rap$locate_element
    (    path_p: ^pft$path;
         path_index: integer;
     VAR subproduct_info_seq_p: ^rat$subproduct_info_sequence;
     VAR element_p: ^rat$element;
     VAR element_found: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      path_found_at_current_level: boolean,
      next_path_index: integer;


    path_found_at_current_level := FALSE;
    element_found := FALSE;
    next_path_index := path_index;

  /find_element/
    WHILE NOT element_found DO
      path_found_at_current_level := (element_p^.name = path_p^ [next_path_index]);
      WHILE NOT path_found_at_current_level DO
        element_p := #PTR (element_p^.next_element_across_p, subproduct_info_seq_p^);
        IF element_p = NIL THEN
          EXIT /find_element/;
        IFEND;
        path_found_at_current_level := (element_p^.name = path_p^ [next_path_index]);
      WHILEND;

      IF next_path_index = UPPERBOUND (path_p^) THEN
        element_found := TRUE;

      ELSE { next level down }
        next_path_index := next_path_index + 1;

        IF element_p^.element_type = rac$catalog THEN
          element_p := #PTR (element_p^.first_element_down_p, subproduct_info_seq_p^);

          IF element_p = NIL THEN
            EXIT /find_element/;
          IFEND;

        ELSE
          EXIT /find_element/;
        IFEND;


      IFEND;

    WHILEND /find_element/;

  PROCEND rap$locate_element;

{ PURPOSE:
{   This procedure locates a specific element in the element list.
{
{ DESIGN:
{   An element can be either a catalog or a file within the installation
{   catalog.  An element is identified by its name and its relationship
{   to the other elements in the list.  That is its element path.
{   The relationship between elements is established using pointers.
{   An element of type catalog has a 'DOWN' pointer to the first element
{   (catalog or file) in it.  Each element in a catalog has a 'ACROSS'
{   pointer to the next element in the catalog, with the exception of
{   the last element, which has a NIL pointer if it is a file or an
{   empty catalog.
{
{ NOTES:
{
{

*copyc pfd$permanent_file_definitions
*copyc rat$subproduct_info_types
?? POP ??

*DECK DECK=RAP$LOCATE_TABLE_ENTRY_BY_PATH EXPAND=FALSE

*copyc cld$value
*copyc ost$status

PROCEDURE [XREF] rap$locate_table_entry_by_path ( function_name: clt$name;
  argument_list: string(*);  VAR value: clt$value;  VAR status: ost$status);

*DECK DECK=RAP$LOGICAL_CONFIGURATION_UTIL EXPAND=TRUE
create_program_description name=(logical_configuration_utility, lcu) dm=off sp=logical_configuration_utility ..
      l=osf$task_services_library tel=error lm=$null lmo=none
*DECK DECK=RAP$LOG_SYSTEM_INITIATION_OPT EXPAND=TRUE
PROCEDURE (hidden) rap$log_system_initiation_opt (
  installation_parameters, ip: (VAR) ..
*copy rat$installation_parameters
                                  = $required
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure logs the system initiation control options selected in the $JOB_LOG and
"   System Initiation Log.
*IFEND


  "$FORMAT=OFF
  VAR
    rav$system_initiation_log: (XREF) file
    ignore_status: status
  VAREND
  "$FORMAT=ON"


  rap$display_message mm=initiation_messages mn=installation_option_set ..
        mp=installation_parameters.installation_option t=$job_log status=ignore_status
  rap$display_message mm=initiation_messages mn=activation_option_set ..
        mp=installation_parameters.activation_option t=$job_log status=ignore_status
  rap$display_message mm=initiation_messages mn=installation_option_set ..
        mp=installation_parameters.installation_option t=rav$system_initiation_log.$eoi status=ignore_status
  rap$display_message mm=initiation_messages mn=activation_option_set ..
        mp=installation_parameters.activation_option t=rav$system_initiation_log.$eoi status=ignore_status

PROCEND rap$log_system_initiation_opt
*DECK DECK=RAP$MAINTAIN_DEADSTART_SOFTWARE EXPAND=TRUE
PROCEDURE maintain_deadstart_software, maids (
  status)

  VAR
    command_table: file = $local//$name($unique)
    ignore_status: status
  VAREND


COLLECT_TEXT o=command_table
  command n=(collect_dump_materials, coldm) p=rap$collect_dump_materials
  command n=(commit_new_system, comns) p=rap$commit_new_system
  command n=(create_prolog, crep) p=cmp$create_prolog
  command n=(create_ve_deadstart_catalog, crevdc) p=create_ve_deadstart_catalog
  command n=(create_ve_deadstart_tape, crevdt) p=create_ve_deadstart_tape
  command n=(establish_disk_based_system, estdbs) p=establish_disk_based_system
  command n=(generate_ve_deadstart_catalog, genvdc) p=rap$generate_ve_deadstart_cat
  command n=(quit, qui) p=rap$quit_maids
  command n=(replace_ds_tape_configurations, repdtc) ..
          p=rap$replace_ds_tape_config
" hidden commands
  command n=(cmp$convert_config_prolog) p=cmp$convert_config_prolog a=hidden
  command n=(get_block_and_record_type) p=get_block_and_record_type a=hidden
  command n=(manage_deadstart_files) p=manage_deadstart_files a=hidden
  command n=(rap$combine_builtin_library) p=rap$combine_builtin_library a=hidden
  command n=(rap$combine_sou_library) p=rap$combine_sou_library a=hidden
  command n=(rap$combine_non_boot_drivers) p=rap$combine_non_boot_drivers a=hidden
  command n=(rap$copy_configuration_files) p=rap$copy_configuration_files a=hidden
  command n=(rap$get_catalog_list) p=rap$get_catalog_list a=hidden
  command n=(rap$get_system_level) p=rap$get_system_level a=hidden
  command n=(rap$link_operating_system_ii) p=rap$link_operating_system_ii a=hidden
  command n=(establish_deadstart_catalog) p=establish_deadstart_catalog a=hidden
  command n=(install_ds_catalog_to_disk) p=install_ds_catalog_to_disk a=hidden
  command n=(search_link_map) p=search_link_map a=hidden
TABLEND
**

  UTILITY n=maintain_deadstart_software p='maids' ..
    l=$system.software_maintenance.raf$library ..
    t=command_table

    delete_file f=command_table status=ignore_status
    include_file f=$command_of_caller u=$utility(name)

  UTILITYEND

PROCEND maintain_deadstart_software

*DECK DECK=RAP$MANAGE_APPLICATION_DEFS EXPAND=TRUE
PROCEDURE manage_application_definitions, manad (
  status)

  VAR
    command_table: file = $local//$name($unique)
    ignore_status: status
  VAREND

COLLECT_TEXT o=command_table
  command n=(define_btf)    p=rap$define_btf
  command n=(define_btfs)   p=rap$define_btfs
  command n=(define_c_socket) p=rap$define_c_socket
  command n=(define_desktop_environment) p=rap$define_desktop_environment
  command n=(define_drje)   p=rap$define_drje
  command n=(define_ftp)    p=rap$define_ftp
  command n=(define_ftps)   p=rap$define_ftps
  command n=(define_ipc_applications)    p=rap$define_ipc_applications
  command n=(define_lpd)    p=rap$define_lpd
  command n=(define_lpds)   p=rap$define_lpds
  command n=(define_name_resolver) p=rap$define_name_resolver
  command n=(define_nqs)    p=rap$define_nqs
  command n=(define_nfs_time_servers)    p=rap$define_nfs_time_servers
  command n=(define_ntf)    p=rap$define_ntf
  command n=(define_opentf) p=rap$define_opentf
  command n=(define_opes)   p=rap$define_opes
  command n=(define_orasrv) p=rap$define_orasrv
  command n=(define_orasrvs) p=rap$define_orasrvs
  command n=(define_ptf)    p=rap$define_ptf
  command n=(define_qtf)    p=rap$define_qtf
  command n=(define_qtfs)   p=rap$define_qtfs
  command n=(define_rexec)  p=rap$define_rexec
  command n=(define_rexecs) p=rap$define_rexecs
  command n=(define_rlm)    p=rap$define_rlm
  command n=(define_scf)    p=rap$define_scf
  command n=(define_scfs)   p=rap$define_scfs
  command n=(define_smtp)   p=rap$define_smtp
  command n=(define_smtps)  p=rap$define_smtps
  command n=(define_tcp_daytime_server) p=rap$define_tcp_daytime_server
  command n=(define_tcp_time_server) p=rap$define_tcp_time_server
  command n=(define_tftp)   p=rap$define_tftp
  command n=(define_tftps)  p=rap$define_tftps
  command n=(define_udp_daytime_server) p=rap$define_udp_daytime_server
  command n=(define_udp_time_server) p=rap$define_udp_time_server
  command n=(define_unnamed_tcp_application) p=rap$define_unnamed_tcp_appl
  command n=(define_unnamed_udp_application) p=rap$define_unnamed_udp_appl
  command n=(define_5744_interface)          p=rap$define_5744_interface
"
  command n=(delete_btf)    p=rap$delete_btf
  command n=(delete_btfs)   p=rap$delete_btfs
  command n=(delete_c_socket) p=rap$delete_c_socket
  command n=(delete_desktop_environment)     p=rap$delete_desktop_environment
  command n=(delete_drje)   p=rap$delete_drje
  command n=(delete_ftp)    p=rap$delete_ftp
  command n=(delete_ftps)   p=rap$delete_ftps
  command n=(delete_ipc_applications)    p=rap$delete_ipc_applications
  command n=(delete_lpd)    p=rap$delete_lpd
  command n=(delete_lpds)   p=rap$delete_lpds
  command n=(delete_name_resolver) p=rap$delete_name_resolver
  command n=(delete_nqs)    p=rap$delete_nqs
  command n=(delete_nfs_time_servers) p=rap$delete_nfs_time_servers
  command n=(delete_ntf)    p=rap$delete_ntf
  command n=(delete_opentf) p=rap$delete_opentf
  command n=(delete_opes)   p=rap$delete_opes
  command n=(delete_orasrv) p=rap$delete_orasrv
  command n=(delete_orasrvs) p=rap$delete_orasrvs
  command n=(delete_ptf)    p=rap$delete_ptf
  command n=(delete_qtf)    p=rap$delete_qtf
  command n=(delete_qtfs)   p=rap$delete_qtfs
  command n=(delete_rexec)  p=rap$delete_rexec
  command n=(delete_rexecs) p=rap$delete_rexecs
  command n=(delete_rlm)    p=rap$delete_rlm
  command n=(delete_scf)    p=rap$delete_scf
  command n=(delete_scfs)   p=rap$delete_scfs
  command n=(delete_smtp)   p=rap$delete_smtp
  command n=(delete_smtps)  p=rap$delete_smtps
  command n=(delete_tcp_daytime_server) p=rap$delete_tcp_daytime_server
  command n=(delete_tcp_time_server) p=rap$delete_tcp_time_server
  command n=(delete_tftp)   p=rap$delete_tftp
  command n=(delete_tftps)  p=rap$delete_tftps
  command n=(delete_udp_daytime_server) p=rap$delete_udp_daytime_server
  command n=(delete_udp_time_server) p=rap$delete_udp_time_server
  command n=(delete_unnamed_tcp_application) p=rap$delete_unnamed_tcp_appl
  command n=(delete_unnamed_udp_application) p=rap$delete_unnamed_udp_appl
  command n=(quit, qui)     p=rap$quit_manad
  command n=(delete_5744_interface)          p=rap$delete_5744_interface
TABLEND
**

  UTILITY n=manage_application_definitions p='manad' ..
        l=$system.software_maintenance.raf$library ..
        t=command_table

    $system.include_file f=$command_of_caller u=$utility(name)
    $system.delete_file f=command_table status=ignore_status

  UTILITYEND

PROCEND manage_application_definitions
*DECK DECK=RAP$MANAGE_EXCEPTION_POLICIES EXPAND=TRUE
create_command_description names=(manage_exception_policies, manep) ..
      sp=osp$_manage_exception_policies
*DECK DECK=RAP$MANAGE_PERIODIC_STATISTICS EXPAND=TRUE
create_program_description name=(manage_periodic_statistics, manps) ..
       sp=lgp$manage_periodic_statistics ..
       l=(:$system.$system.osf$sou_library osf$task_services_library) ..
       tel=warning lmo=none lm=$NULL
*DECK DECK=RAP$MANAGE_QUEUE_FILE EXPAND=TRUE
*DECK DECK=RAP$MERGE_CORRECTORS EXPAND=FALSE
  PROCEDURE [XREF] rap$merge_correctors (add_package: ^SEQ ( * );
        j: rat$element_index;
        add_elements: ^rat$correction_package;
    VAR status: ost$status);

*copyc ost$status
*copyc rat$correction_package

*DECK DECK=RAP$MOVE_CLASSES EXPAND=TRUE
  create_command_description names=(move_classes move_class movc) sp=pfp$move_classes_command
*DECK DECK=RAP$MOVE_CORRECTION EXPAND=FALSE
  PROCEDURE [XREF] rap$move_correction (add_package: ^SEQ ( * );
        i: rat$element_index);

*copyc rat$correction_package

*DECK DECK=RAP$MOVE_PACKING_LIST EXPAND=TRUE
PROCEDURE (hidden) rap$move_packing_list (
  temp_packing_list_path, tplp: file = $required
  packing_list_name, pln: (VAR) string 0..16 = $required
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure moves the packing list from the temporary location where
"   it was loaded, to the permanent location indicated by the packing list
"   name passed in.
"
"   Before this can be done the destination must be tested that a packing
"   list does'nt already reside there.  If one does, it is compared to the
"   packing list loaded into the temporary location.  The comparison is done
"   by checksuming the respective files.  When the checksums compare, the
"   packing list already in the destination is kept and the packing list in
"   the temporary location is deleted.  Otherwise, the user is prompted to
"   provide a new name for the packing list and the testing is repeated
"   using the new name.
"
"   When the destination is clear (that is, no packing list resides there),
"   the packing list from the temporary location is moved there.
"
"   If the packing list name was changed, the new name is returned to
"   the caller.
"
*IFEND



  "$FORMAT=OFF
  VAR
    ignore_status: status
    local_status: status
    packing_list_already_present: boolean
    packing_list_name_already_used: boolean
    packing_list_checksum: integer
    packing_list_path: file
    rav$software_maintenance: (xref) file
    temp_packing_list_checksum: integer
    utility_status: status
    value_response: string
  VAREND
  "$FORMAT=ON"


  move_block: ..
    BLOCK

      packing_list_path = rav$software_maintenance.installation_database//$name(packing_list_name)
      packing_list_name_already_used = $file(packing_list_path, permanent)
      packing_list_already_present = FALSE

      WHILE packing_list_name_already_used AND (NOT packing_list_already_present) DO

        " Compare the checksums

        "$ PACKAGE_SOFTWARE
        $system.execute_task sp=rap$package_software l=$local.raf$library status=utility_status
        EXIT move_block WHEN NOT utility_status.normal

          checksum_file f=packing_list_path c=packing_list_checksum status=local_status
          IF local_status.normal THEN
            checksum_file f=temp_packing_list_path c=temp_packing_list_checksum status=local_status
          IFEND
        QUIT
        EXIT move_block WHEN NOT local_status.normal

        IF packing_list_checksum = temp_packing_list_checksum THEN

          "Use packing list already installed.
          packing_list_already_present = TRUE
          $system.delete_file f=temp_packing_list_path status=ignore_status

        ELSE "checksums do not match"
          "The packing lists are not the same,
          "prompt user for new packing list name to resolve conflict.
          value_response = ''

          rap$display_message mm=initiation_messages mn=packing_list_name_already_used ..
                mp=(packing_list_name) t=$response status=ignore_status

          "User must acknowledge
          rap$press_next

          rap$prompt_for_value pm=install_tape_menu pn=packing_list_prompt vd=('name 1..16') ..
                vr=value_response

          packing_list_name = $translate(lower_to_upper, $trim($substr(value_response, 1, 16)))
          packing_list_path = rav$software_maintenance.installation_database//$name(packing_list_name)
          packing_list_name_already_used = $file(packing_list_path, permanent)

        IFEND
      WHILEND

      IF NOT packing_list_already_present THEN

        change_catalog_entry f=temp_packing_list_path nfn=$name(packing_list_name) status=local_status

      IFEND

    BLOCKEND move_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal
  EXIT procedure WITH utility_status WHEN NOT utility_status.normal

PROCEND rap$move_packing_list
*DECK DECK=RAP$MOVE_SITE_FILES EXPAND=TRUE
PROC move_site_files (
  status : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" This is one of several procedures created to simplify the installation process.
" These procedures are kept in the OSF$SITE_COMMAND_LIBRARY and therefore will
" receive minimal support.
"
" The purpose of this procedure is to make sure certain site files reside on a K
" classed device.  This is accomplished by simply copying the files to their
" respective $NEXT cycles.  All existing lower cycles will be given a retention
" period of 7 days.  This procedure is called out in the upgrade chapter of the
" SRB.
*IFEND


  create_variable files k=string d=14
  create_variable ignore_status k=status
  create_variable local_status k=status
  create_variable retention k=integer v=7

  files(1) = '$SYSTEM.PROLOGS_AND_EPILOGS.JOB_ACTIVATION_PROLOG'
  files(2) = '$SYSTEM.PROLOGS_AND_EPILOGS.JOB_ACTIVATION_EPILOG'
  files(3) = '$SYSTEM.PROLOGS_AND_EPILOGS.NETWORK_ACTIVATION_PROLOG'
  files(4) = '$SYSTEM.PROLOGS_AND_EPILOGS.NETWORK_ACTIVATION_EPILOG'
  files(5) = '$SYSTEM.PROLOGS_AND_EPILOGS.SYSTEM_INITIATION_PROLOG'
  files(6) = '$SYSTEM.PROLOGS_AND_EPILOGS.SYSTEM_INITIATION_EPILOG'
  files(7) = '$SYSTEM.PROLOGS_AND_EPILOGS.SYSTEM_TERMINATION_PROLOG'
  files(8) = '$SYSTEM.PROLOGS_AND_EPILOGS.SYSTEM_PROLOG'
  files(9) = '$SYSTEM.PROLOGS_AND_EPILOGS.SYSTEM_EPILOG'
  files(10) = '$SYSTEM.CDCNET.SITE_CONTROLLED.CONFIGURATION'
  files(11) = '$SYSTEM.CDCNET.SITE_CONTROLLED.EXCEPTION_LIST'
  files(12) = '$SYSTEM.CDCNET.SITE_CONTROLLED.PROCEDURES.USER'
  files(13) = '$SYSTEM.CDCNET.SITE_CONTROLLED.PROCEDURES.TERMINAL'
  files(14) = '$SYSTEM.CDCNET.SITE_CONTROLLED.PROCEDURES.DEVICE_LOAD'


move_files: ..
  FOR i = 1 TO $variable(files, upper_bound) DO
    IF NOT $file($fname(files(i)), assigned) THEN
      put_line ' Unable to move '//$string($fname(files(i)))//'; file unknown.' o=$response
    ELSE
      put_line ' Copying file '//$string($fname(files(i)))//' to $NEXT cycle.' o=$response
      copy_file i=$fname(files(i)) o=$fname(files(i)//'.$next') status=local_status
      IF NOT local_status.normal THEN
        put_line $strrep(local_status) o=$response
        CYCLE move_files
      IFEND

      low_cycle = $file($fname(files(i)//'.$low'), cycle_number)
      high_cycle = $file($fname(files(i)//'.$high'), cycle_number)

      FOR cycle = low_cycle TO (high_cycle - 1) DO
        IF $file($fname(files(i)//'.'//$strrep(cycle)), assigned) THEN
          change_catalog_entry $fname(files(i)//'.'//$strrep(cycle)) nr=retention status=ignore_status
        IFEND
      FOREND
    IFEND
  FOREND move_files

  EXIT_PROC WITH local_status WHEN NOT local_status.normal

PROCEND move_site_files
*DECK DECK=RAP$NQS_DEFINE_VALIDATION_FLDS EXPAND=TRUE
PROCEDURE rap$nqs_define_validation_flds (
  family, f: name = $required
  default_unix_user_name, duun: (BY_NAME) key
      $translate, none
    keyend = none
  default_queue_name, dqn: (BY_NAME) string 0..128 = ''
  status)

  VAR
    ls: status
  VAREND

  ADMINISTER_VALIDATIONS status=ls

  use_validation_file: ..
    BLOCK
      use_validation_file $fname(':'//family//'.$system.$validations') status=ls
      WHILE NOT ls.normal DO
        IF ls.condition <> ave$must_specify_password THEN
          EXIT use_validation_file
        IFEND
        put_line ' A password is required to access the validation file.'
        ?use_validation_file $fname(':'//family//'.$system.$validations') status=ls
      WHILEND

      MANAGE_USER_FIELDS

        IF $validation_field(unix_user_name declared) = active THEN
          put_line ' The field UNIX_USER_NAME already exists.'
        ELSE
          user_name_default = ''
          IF default_unix_user_name = '$translate' THEN
            user_name_default = '$TRANSLATE'
          IFEND

          create_string_field field_name=unix_user_name default_value=user_name_default size=0..15 ..
                description='Users unix user name.' display_authority=user ..
                change_authority=user_administration manage_authority=system_administration
          put_line ' Created field UNIX_USER_NAME.'
        IFEND

        IF $validation_field(unix_uid declared) = active THEN
          put_line ' The field UNIX_UID already exists.'
        ELSE
          create_integer_field field_name=unix_uid default_value=0 value_range=0..65531 ..
                description='Users unix UID.' display_authority=user change_authority=user_administration ..
                manage_authority=system_administration
          put_line ' Created field UNIX_UID.'
        IFEND

        IF $validation_field(nqs_queue_name declared) = active THEN
          put_line ' The field NQS_QUEUE_NAME already exists.'
        ELSE
          create_string_field field_name=nqs_queue_name default_value=default_queue_name size=0..128 ..
                description='Users default queue name for NQS.' display_authority=user ..
                change_authority=user_administration manage_authority=system_administration
          put_line ' Created field NQS_QUEUE_NAME.'
        IFEND

      QUIT
    BLOCKEND use_validation_file
  QUIT

  EXIT procedure WITH ls

PROCEND rap$nqs_define_validation_flds
*DECK DECK=RAP$NQS_UPDATE_NETWORK_FILES EXPAND=TRUE
PROCEDURE rap$nqs_update_network_files (
  port_number, pn: integer = 607
  status)

  VAR
    ls:status
    service_definition: file = $unique($local)
    service_entry: string = 'nqs '//port_number//'/tcp'
  VAREND

  EDIT_FILE $system.tcp_ip.inetd_configuration output=$null prolog=$null
    locate_text 'nqs' 1 all word=on upper_case=yes status=ls
    IF ls.normal THEN
      put_line ' A service definition already exist in the INETD configuration file for NQS.'
      EXIT PROCEDURE
    IFEND

COLLECT_TEXT service_definition sm='!'

 "INETD configuration file entry for the NQS server.

   define_service ..
     service=nqs ..
     application_name=OSA$NQS_SERVER ..
     debug_mode=OFF ..
     debug_mode_interactive=off ..
     initial_state=active ..
     port=!port_number! ..
     protocol=TCP ..
     service_task=$system.nqs.nqf$system_666 ..
     starting_procedure=nqp$nqs_server
**

    read_file f=service_definition insertion_location=last
    detach_file service_definition status=ls

  QUIT yes

  put_line ' An entry for the NQS server was added to the INETD configuration file.'

  EDIT_FILE $system.tcp_ip.services output=$null prolog=$null
    locate_text 'nqs' 1 all word=on upper_case=yes status=ls
    IF ls.normal THEN
      replace_line nt=service_entry lines=c
    ELSE
      insert_line service_entry insertion_location=last placement=after
    IFEND
  QUIT yes

  put_line ' The NQS service was defined as port '//port_number//'.'

PROCEND rap$nqs_update_network_files
*DECK DECK=RAP$OPEN_FILE EXPAND=FALSE

  PROCEDURE [XREF] rap$open_file
    (    path_ref_p: ^fst$file_reference;
         access_level: amt$access_level;
         file_attachment: fst$file_access_option;
         create_file: boolean;
         attribute_override_p: ^array [1 .. 1] of fst$file_cycle_attribute;
     VAR file_id: {output} amt$file_identifier;
     VAR file_opened: {output} boolean;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc fsp$open_file
*copyc ost$status
?? POP ??



*DECK DECK=RAP$OPEN_INSTALLATION_TABLE EXPAND=FALSE

*copyc amt$local_file_name
*copyc amt$file_identifier
*copyc rat$installation_table
*copyc rat$header_record
*copyc rat$table_version
*copyc ost$status

PROCEDURE [XREF] rap$open_installation_table (table_file:  amt$local_file_name;
  VAR table_file_id: amt$file_identifier;
  VAR table: ^rat$installation_table;
  VAR header: ^rat$header_record;
  VAR version: ^rat$table_version;
  VAR status: ost$status);

*DECK DECK=RAP$OPEN_PACKING_LIST_USING_ICR EXPAND=FALSE

  PROCEDURE [XREF] rap$open_packing_list_using_icr
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR packing_list_fid: amt$file_identifier;
     VAR file_opened: boolean;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$PERFORM_INSTALLATION_OPTION EXPAND=TRUE
PROCEDURE (hidden) rap$perform_installation_option (
  installation_parameters, ip: (VAR) ..
*copy rat$installation_parameters
                                  = $required
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure performs the requested installation option.
"
" NOTES:
"   $SYSTEM.$VALIDATIONS file cycle number changed to be greater
"     than 1 on INISD deadstarts where the Installation Tape is loaded.
"     This is done to avoid cycle conflicts on reload deadstarts.
*IFEND


  "$FORMAT=OFF
  VAR
    ignore_status: status
    installation_status: status
    local_status: status
    osv$deadstart_phase: (XREF) string 0 .. $max_name
  VAREND
  "$FORMAT=ON"


  IF osv$deadstart_phase = 'INSTALL' THEN
    IF $file($system.$validations, cycle_number) = 1 THEN
      $system.change_catalog_entry f=$system.$validations nc=2 status=ignore_status
    IFEND
  IFEND

  IF installation_parameters.installation_option = 'INSTALLATION_TAPE' THEN

    rap$install_installation_tape ip=installation_parameters status=installation_status

    IF installation_status.normal THEN
      IF (osv$deadstart_phase = 'INSTALL') AND ..
            (installation_parameters.activation_option = 'MANUAL') THEN
        rap$get_activation_option menu_module=inidd_activation ao=installation_parameters.activation_option
      IFEND
    ELSE
      installation_parameters.activation_option = 'CONSOLE'
    IFEND

  ELSE

    rap$install_deferred_products status=installation_status

    IF installation_status.normal THEN
      rap$get_activation_option menu_module=deferred_activation ao=installation_parameters.activation_option
    ELSE
      installation_parameters.activation_option = 'CONSOLE'
    IFEND
  IFEND

  EXIT procedure WITH installation_status WHEN NOT installation_status.normal

PROCEND rap$perform_installation_option
*DECK DECK=RAP$PERFORM_INSTALLATION_STEPS EXPAND=FALSE

  PROCEDURE [XREF] rap$perform_installation_steps
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$PREVIOUS_CLONE_ACCESS EXPAND=FALSE

*copyc cld$value
*copyc ost$status

PROCEDURE [XREF] rap$previous_clone_access (function_name: clt$name;
  argument_list: string(*);  VAR value: clt$value;  VAR status: ost$status);


*DECK DECK=RAP$PROCESS_ENTRY_CHANGES EXPAND=FALSE

*copyc rat$installation_table
*copyc rat$inst_table_index
*copyc ost$status

PROCEDURE [XREF] rap$process_entry_changes (table: ^rat$installation_table;
  table_index: rat$inst_table_index;  VAR status: ost$status);

*DECK DECK=RAP$PROCESS_HEADER_CHANGES EXPAND=FALSE

*copyc ost$status
*copyc rat$header_record

PROCEDURE [XREF] rap$process_header_changes (header: ^rat$header_record;
  VAR status: ost$status);

*DECK DECK=RAP$PROCESS_PSRS_ENTERED EXPAND=FALSE

  PROCEDURE [XREF]  rap$process_psrs_entered
    (    psrs_answered: clt$data_value;
     VAR new_subproduct_info_pointers: rat$subproduct_info_pointers;
     VAR previous_correction_sif: rat$correction_process_sif_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc ost$status
*copyc rat$subproduct_info_types
*copyc rat$correction_process_record
?? POP ??

*DECK DECK=RAP$PRODUCT_FILES_LIST EXPAND=FALSE
*DECK DECK=RAP$PRODUCT_VSN EXPAND=FALSE
*DECK DECK=RAP$PROMPT_FOR_LIM EXPAND=TRUE
PROCEDURE prompt_for_lim (
  lim : (var) string = $optional
  status: (var) status = $optional
  )

  create_variable input_string k=string
  create_variable integer_number k=integer
  create_variable conversion_status k=status

lim_loop: ..
  LOOP
    put_line '0Enter the LIM number to which your terminal/printer is connected or ? for help:'
    accept_line input_string input p=''

    IF (input_string = '?') OR ($translate(lower_to_upper, input_string) = 'HELP') THEN
      put_line ('0Supply the LIM number to which your terminal/printer is connected.' ..
            ' This is a number from 0 to 7.  Look at the back of your DI.' ..
            ' Each LIM has a number stamped on it.'..
            ' Find the line to your terminal/printer and enter its LIM number.', '  ')
    ELSEIF input_string = ' ' THEN
      IF ($value(lim) <> ' ') THEN
        EXIT lim_loop
      IFEND
    ELSEIF ($translate(lower_to_upper, input_string) = 'QUIT') OR ($translate(lower_to_upper, input_string) = 'QUI') THEN
      $value(lim) = ' '
      EXIT lim_loop
    ELSE
      include_line 'integer_number=$integer(input_string)' status=conversion_status
      IF conversion_status.normal THEN
        IF (integer_number >= 0) AND (integer_number <= 7) THEN
          $value(lim) = input_string
          EXIT lim_loop
        ELSE
          put_line ('0LIM number out of range, please correct.', '  ')
        IFEND
      ELSE
        put_line ('0Invalid LIM number, please correct.', '  ')
      IFEND
    IFEND
  LOOPEND lim_loop

PROCEND prompt_for_lim
*DECK DECK=RAP$PROMPT_FOR_PORT EXPAND=TRUE
PROCEDURE prompt_for_port (
  port : (var) string = $optional
  status)

  create_variable input_string k=string
  create_variable integer_number k=integer
  create_variable conversion_status k=status

port_loop: ..
  LOOP
    put_line '0Enter the PORT number to which your terminal/printer is connected or ? for help:'
    accept_line input_string input p=''

    IF (input_string = '?') OR ($translate(lower_to_upper, input_string) = 'HELP') THEN
      put_line ('0Supply the PORT number to which your terminal/printer is connected.' ..
            ' This is a number from 0 to 7.  Look at the back of your DI.' ..
            ' Each async LIM has either 4 ports or 8 ports.'..
            ' The top PORT on each LIM is number 0.'..
            ' Find the line to your terminal/printer and enter its PORT number.', '  ')
    ELSEIF input_string = ' ' THEN
      IF ($value(port) <> ' ') THEN
        EXIT port_loop
      IFEND
    ELSEIF ($translate(lower_to_upper, input_string) = 'QUIT') OR ($translate(lower_to_upper, input_string) = 'QUI') THEN
      $value(port) = ' '
      EXIT port_loop
    ELSE
      include_line 'integer_number=$integer(input_string)' status=conversion_status
      IF conversion_status.normal THEN
        IF (integer_number >= 0) AND (integer_number <= 7) THEN
          $value(port) = input_string
          EXIT port_loop
        ELSE
          put_line ('0PORT number out of range, please correct.', '  ')
        IFEND
      ELSE
        put_line ('0Invalid PORT number, please correct.', '  ')
      IFEND
    IFEND
  LOOPEND port_loop

PROCEND prompt_for_port
*DECK DECK=RAP$PROMPT_FOR_PRINTER_PARITY EXPAND=TRUE
PROCEDURE prompt_for_printer_parity (
  parity : (var) string = $optional
  status : (var) status = $optional
  )

  create_variable input_string k=string

parity_loop: ..
  LOOP
    put_line '0Enter the parity to be used with the ASYNC printer or ? for help:'
    accept_line input_string input p=''

    IF (input_string = '?') OR ($translate(lower_to_upper, input_string) = 'HELP') THEN
      put_line ('1Supply the data parity of your ASYNC printer. ' ..
            ' If your printer is a CDC 536 printer, choose ODD parity. ' ..
            ' If your printer is a CDC 537 printer, choose EVEN parity. ')
    ELSEIF input_string = ' ' THEN
      EXIT parity_loop
    ELSEIF ($translate(lower_to_upper, input_string) = 'QUIT') OR ..
          ($translate(lower_to_upper, input_string) = 'QUI') THEN
      $value(parity) = ' '
      EXIT parity_loop
    ELSE
      $value(parity) = $translate(lower_to_upper, input_string)
      IF $value(parity) = 'ODD' OR $value(parity) = 'EVEN' THEN
        EXIT parity_loop
      ELSE
        put_line '0 --ERROR--  '//$value(parity)//' is not an acceptable value for parity.' o=$response
        accept_line input_string input p='Press NEXT'
      IFEND
    IFEND
  LOOPEND parity_loop

PROCEND prompt_for_printer_parity
*DECK DECK=RAP$PROMPT_FOR_TUP EXPAND=TRUE
PROC prompt_for_tup (
  tup : var of string = $optional
  status)

  create_variable count k=integer
  create_variable cr_requested k=string
  create_variable help_file k=string v='$local.'//$unique
  create_variable help_line k=string d=16
  create_variable input_string k=string
  create_variable local_status k=status
  create_variable user k=string v='$system.cdcnet.site_controlled.procedures.user'

  set_file_attributes f=$fname(help_file) pf=c
  $system.osf$command_library.display_object_library l=$fname(user) do=none o=$fname(help_file) ao=true

tup_loop: ..
  LOOP
    put_line '0Enter the name of the tup to configure with your terminal or ? for help:'
    accept_line input_string input p=''

    IF (input_string = '?') OR ($translate(lower_to_upper, input_string) = 'HELP') THEN
      put_line ('1Supply the name of the TUP with which to configure your terminal.' ..
                ' A description of the TUPs can be found in the CDCNET Configuration ' ..
                ' and Site Administration Guide Appendix J.' ..
                ' If you do not wish to specify a TUP, Press NEXT.' ..
                ' You have the choice of any of the following TUPs:')
      rewind_file $fname(help_file)
      REPEAT
         accept_line v=help_line i=$fname(help_file//'.$asis') lc=count
         for i=1 to count do
           put_line help_line(i)
         forend
         put_line ' '
         accept_line cr_requested input p='Press NEXT: '
         put_line ' '
      UNTIL count < 16
    ELSEIF input_string = ' ' THEN
      EXIT tup_loop
    ELSEIF ($translate(lower_to_upper, input_string) = 'QUIT') OR ($translate(lower_to_upper, input_string) = 'QUI') THEN
      $value(tup) = ' '
      EXIT tup_loop
    ELSE
       $value(tup) = $translate(lower_to_upper, input_string)
       PUSH file_connections
         delete_file_connection $errors output
         $system.osf$command_library.display_object_library l=$fname(user) m=$name($value(tup)) o=$null ..
               status=local_status
       POP file_connections
       IF local_status.normal THEN
         EXIT tup_loop
       ELSE
         put_line '0 --ERROR--  '//$value(tup)//' is not in '//user//'.' o=$response
         $value(tup) = ' '
       IFEND
    IFEND
  LOOPEND tup_loop
  detach_file $fname(help_file)

PROCEND prompt_for_tup
*DECK DECK=RAP$PROMPT_FOR_VALUE EXPAND=FALSE

  PROCEDURE [XREF] rap$prompt_for_value
    (    prompt_module: pmt$program_name;
         prompt_name: clt$parameter_name;
         prompt_parameters: rat$message_parameters;
         prompting_options: rat$prompting_options;
         value_declaration: rat$value_declaration;
     VAR value_returned: rat$value_returned;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_name
*copyc ost$status
*copyc pmt$program_name
*copyc rat$message_parameters
*copyc rat$prompting_options
*copyc rat$value_declaration
*copyc rat$value_returned
?? POP ??
*DECK DECK=RAP$PROMPT_VIA_MENU EXPAND=FALSE

  PROCEDURE [XREF] rap$prompt_via_menu
    (    menu_module: pmt$program_name;
         menu_selections: array [ * ] of ost$name;
         menu_parameters: rat$message_parameters;
         prompting_options: rat$prompting_options;
     VAR selection_chosen: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc pmt$program_name
*copyc rat$message_parameters
*copyc rat$prompting_options
?? POP ??
*DECK DECK=RAP$QUIT EXPAND=FALSE

*copyc cld$parameter_list
*copyc ost$status

PROCEDURE [XREF] rap$quit (
  parameter_list: clt$parameter_list;  VAR status: ost$status);

*DECK DECK=RAP$QUIT_CREIE EXPAND=TRUE
PROCEDURE rap$quit_creie ()

  EXIT create_installation_environment

PROCEND rap$quit_creie
*DECK DECK=RAP$QUIT_MAIDS EXPAND=TRUE
PROCEDURE rap$quit_maids ()

  EXIT maintain_deadstart_software

PROCEND rap$quit_maids
*DECK DECK=RAP$QUIT_MANAD EXPAND=TRUE
PROCEDURE rap$quit_manad ()

  EXIT manage_application_definitions

PROCEND rap$quit_manad
*DECK DECK=RAP$REASSIGN_DEVICE EXPAND=TRUE
create_command_description name=(reassign_device, read) ..
      sp=clp$reassign_device_command
*DECK DECK=RAP$RECONCILE_CYCLE_CONFLICTS EXPAND=FALSE

  PROCEDURE [XREF] rap$reconcile_cycle_conflicts
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR subproducts_failed_processing: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$RECORD_DISK_PATH EXPAND=FALSE

  PROCEDURE [XREF] rap$record_disk_path
    (    disk_path: fst$file_reference;
         packing_list: fst$file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=RAP$RECORD_STEP_STATUS EXPAND=FALSE

  PROCEDURE [XREF] rap$record_step_status
    (    step: rat$steps;
         step_status: rat$step_status;
     VAR icr {input, output} : rat$installation_control_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$RECORD_SUBPRODUCT_STATUS EXPAND=FALSE

  PROCEDURE [XREF] rap$record_subproduct_status
    (    task: rat$tasks;
         task_status: rat$task_status;
         subproduct_index: rat$subproduct_count;
     VAR icr {input, output} : rat$installation_control_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$REMOVE_ELEMENTS_FROM_PATH EXPAND=TRUE
PROCEDURE rap$remove_elements_from_path (
  path, p: file = $required
  number_of_elements, noe: integer = $required  "to remove from path"
  new_path, np: (VAR) file = $required
  status)

  VAR
    command_file: file = $local//$name($unique)
    ignore_status: status
    last_element: string
    local_status: status
    loop: integer
    path_string: string
    pos: integer

  VAREND

COLLECT_TEXT command_file until='**'
  path_string = $string(path)
  FOR loop = 1 to number_of_elements DO
    last_element = $path($fname(path_string), last)
    pos = $scan_string(last_element, path_string)
    path_string = $substr(path_string, 1, pos-2)
  FOREND
**

  $system.include_file f=command_file status=local_status
  $system.delete_file f=command_file status=ignore_status
  EXIT procedure WITH local_status WHEN NOT local_status.normal

  new_path = $fname(path_string)

PROCEND rap$remove_elements_from_path
*DECK DECK=RAP$REPLACE_DS_TAPE_CONFIG EXPAND=TRUE
PROCEDURE rap$replace_ds_tape_config (
  input_external_vsn, ievsn, iev: any of
         string 1..6
         name 1..6
       anyend = $optional
  input_recorded_vsn, irvsn, irv: any of
         string 1..6
         name 1..6
       anyend = $optional
  output_external_vsn, oevsn, oev: any of
         string 1..6
         name 1..6
       anyend = $optional
  output_recorded_vsn, orvsn, orv: any of
         string 1..6
         name 1..6
       anyend = $optional
  configuration_files_catalog, cfc: file = $system.site_os_maintenance.deadstart_commands
  input_type, it, type, t: key
      mt9$1600, mt9$6250, mt18$38000
    keyend = mt9$6250
  output_type, ot: key
      mt9$1600, mt9$6250, mt18$38000
    keyend = $optional
  input_removable_media_group, irmg: (BY_NAME, ADVANCED) any of
      key
        none
      keyend
      name
    anyend = osd$reqmt_removable_media_group, none
  output_removable_media_group, ormg: (BY_NAME, ADVANCED) any of
      key
        none
      keyend
      name
    anyend = osd$reqmt_removable_media_group, none
  unload_output_deadstart_tape, uodt: boolean = TRUE
  status)

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

"
"  The purpose of this procedure is write a new deadstart tape from an
"  existing deadstart tape, allowing changes to DCFILE, PROLOG_LIBRARY,
"  and PHYSICAL_CONFIG.
"
*IFEND


  "$FORMAT=OFF
  VAR
    command_file: file = $local//$name($unique)
    command_status: status
    ignore_status: status

"         string length choosen to accomodate string EVSN='xxxxxx' plus pad
    ievsn_string: string 0..14 = ''
    irvsn_string: string 0..14 = ''
    ivsn_specified: boolean = false

    local_status: status

    oevsn_string: string 0..14 = ''
    orvsn_string: string 0..14 = ''
    ovsn_specified: boolean = false

    temp_deadstart_catalog: file = $user//$name($unique)
    text: string
  VAREND
  "$FORMAT=ON"




*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"  Either the external VSN or recorded VSN must be specified for both
"  the input and output VSN parameters.
*IFEND

  IF NOT $specified(output_type) THEN
    output_type = input_type
  IFEND

  IF $specified(input_external_vsn) THEN
    ivsn_specified = true
    ievsn_string = 'evsn=' // $quote($string(input_external_vsn))
  IFEND
  IF $specified(input_recorded_vsn) THEN
    ivsn_specified = true
    irvsn_string = 'rvsn=' // $quote($string(input_recorded_vsn))
  IFEND
  IF input_removable_media_group <> 'NONE' THEN
    ivsn_specified = true
  IFEND
  IF $specified(output_external_vsn) THEN
    ovsn_specified = true
    oevsn_string = 'evsn=' // $quote($string(output_external_vsn))
  IFEND
  IF $specified(output_recorded_vsn) THEN
    ovsn_specified = true
    orvsn_string = 'rvsn=' // $quote($string(output_recorded_vsn))
  IFEND
  IF output_removable_media_group <> 'NONE' THEN
    ovsn_specified = true
  IFEND
  IF NOT ivsn_specified THEN
    local_status = $status(false, 'RA', rae$vsn_param_required, ' ')
    EXIT procedure WITH local_status
  IFEND
  IF NOT ovsn_specified THEN
    local_status = $status(false, 'RA', rae$vsn_param_required, ' ')
    EXIT procedure WITH local_status
  IFEND


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"  If this job is being initiated from the operator console, submit the
"  job as a batch job to the system;  if this job is not being submitted
"  from the system console, continue the procedure interactively.
*IFEND

  $system.delete_file f=command_file status=ignore_status

  IF $job(system) THEN
    $system.put_line l=' Submitting job to write a new deadstart tape ...' o=output
COLLECT_TEXT command_file.$eoi until='**' sm='?'
      JOB job_name=repdtc job_class=system
        VAR
          local_status: status
          ignore_status: status
        VAREND
        SYSTEM_OPERATOR_UTILITY C=system_administration
        replace_block: BLOCK
        $system.osf$builtin_library.maintain_deadstart_software
**
  ELSE
COLLECT_TEXT command_file.$eoi until='**'
        replace_block: BLOCK
**
  IFEND


"  Call the procedure to create a deadstart catalog; the input deadstart
"  tape is read and a unqiue deadstart catalog is built in $USER

COLLECT_TEXT command_file.$eoi until='  COLLECT_END' sm='?'
    $system.create_catalog c=?temp_deadstart_catalog?  status=local_status
    EXIT replace_block WHEN NOT local_status.normal

    create_ve_deadstart_catalog dc=?temp_deadstart_catalog? ..
               ?ievsn_string? ?irvsn_string? type=?input_type? ..
               rmg=?input_removable_media_group? status=local_status
    EXIT replace_block WHEN NOT local_status.normal


"  Copy site-specified configuration files to the deadstart catalog, if any
"

    rap$copy_configuration_files cfc=?configuration_files_catalog? ..
      deadstart_catalog=?temp_deadstart_catalog? status=local_status
    EXIT replace_block WHEN NOT local_status.normal


"  Call procedure to write a new deadstart tape from the unique
"  deadstart catalog in $USER.

    create_ve_deadstart_tape ..
              deadstart_catalog=?temp_deadstart_catalog? ..
              ?oevsn_string? ?orvsn_string? ..
              type=?output_type? ..
              removable_media_group=?output_removable_media_group? ..
              unload_deadstart_tape=?unload_output_deadstart_tape? ..
              status=local_status

    EXIT replace_block WHEN NOT local_status.normal

    $system.delete_catalog c=?temp_deadstart_catalog? do=catalog_and_contents status=ignore_status

  COLLECT_END


  IF $job(system) THEN
COLLECT_TEXT command_file.$eoi until='**' sm='?'
      quit      " for maintain_software
      BLOCKEND replace_block
      QUIT "from SOU"
      IF NOT local_status.normal THEN
        $system.put_line l=(' '//$strrep($status(FALSE, 'RA', rae$executing_error, 'REPLACE_DS_TAPE_CONFIGURATIONS')) ..
        ' '//$strrep(local_status)) o=$job_log
        $system.send_operator_message 'REPLACE_DS_TAPE_CONFIGURATIONS aborted...See job log for details' ..
           operator_class=system_operator
      IFEND
    JOBEND
**
  ELSE
COLLECT_TEXT command_file.$eoi until='**' sm='?'
      BLOCKEND replace_block
**
  IFEND

  $system.include_file f=command_file status=command_status
  $system.delete_file f=command_file status=ignore_status

  $system.delete_catalog c=temp_deadstart_catalog do=catalog_and_contents status=ignore_status

*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'
"  The variable command_status is the status returned from the include_file
"  command.  The variable local_status is the status of individual commands
"  within the include_file command.  If an individual command within returns
"  a bad status in local_status and the include file is running interactively,
"  command_status will be normal.  In this circumstance, local_status will
"  capture the bad status.  Using two status variables allows the capture
"  of bad status from all possible failures.  The intent is to always exit
"  this procedure with local_status when either local_status or command_status
"  is bad.
*IFEND

  IF NOT command_status.normal THEN
    local_status = command_status
  IFEND

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$replace_ds_tape_config
*DECK DECK=RAP$REPL_BASE_CATALOG_OF_PATH EXPAND=FALSE

*copyc ost$status
*copyc clt$path_name

PROCEDURE [XREF] rap$repl_base_catalog_of_path (VAR path: clt$path_name;
  catalog: clt$path_name;  VAR status: ost$status);

*DECK DECK=RAP$RESET_CORRECTION_ENVIRON EXPAND=FALSE

  PROCEDURE [XREF] rap$reset_correction_environ
    (VAR correction_process_record: rat$correction_process_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$correction_process_record
?? POP ??
*DECK DECK=RAP$RUNNING_OS_LEVEL EXPAND=FALSE

*copyc cld$value
*copyc ost$status

PROCEDURE [XREF] rap$running_os_level (function_name: clt$name;
  argument_list: string(*);  VAR value: clt$value;  VAR status: ost$status);


*DECK DECK=RAP$RUN_INITIATION_COMMANDS EXPAND=TRUE
PROCEDURE (HIDDEN) rap$run_initiation_commands (
  initiation_commands_name, icn: name = $required
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure executes the specified command file.  The command file is expected to be either a
"   prolog or an epilog from the PROLOGS_AND_EPILOGS catalog.
"
" DESIGN:
"   To allow all the commands to be executed a procedure with a when block is built around the commands.
"   The procedure is then executed.
"
" NOTES:
"   The initiation commands name is translated into the initiation commands phrase to be used in logging
"   begining and ending messages.  The translation involves replacing all underscores with blanks and
"   changing all upper case characters to lower case.  The status variable RAV$STATUS is reserved
"   and cannot be used within the initiation command file.
"
"   Margins have been turned off (set to 0) until all messages can be properly aligned together.  To
"   turn the margins back on replace the 0's with a 2.
*IFEND


*copy rav$margin
*copy rav$system_paths

  "$FORMAT=OFF
  VAR
    ignore_status: status
    initiation_commands: file = $unique($local)
    initiation_commands_file: file = rav$system.prologs_and_epilogs//initiation_commands_name
    initiation_commands_name: string 0 .. $max_name = $translate(upper_to_lower, $string($value(initiation_commands_name)))
    initiation_commands_phrase: string 0 .. $max_name = ''
    local_status: status
  VAREND
  "$FORMAT=ON"


  FOR i = 1 TO $size(initiation_commands_name) DO
    char=$substring(initiation_commands_name, i, 1)
    IF char = '_' THEN
      char=' '
    IFEND
    initiation_commands_phrase=initiation_commands_phrase // char
  FOREND

  rap$display_message mm=initiation_messages mn=executing_initiation_commands mp=initiation_commands_phrase ..
        m=rav$margin t=$response status=ignore_status

  IF $file(initiation_commands_file, assigned) THEN

COLLECT_TEXT initiation_commands until='END_COLLECT' sm='?'
PROC initiation_commands (
  status : var of status = $optional
  )


  WHEN any_fault DO
    IF NOT rav$event_message.normal THEN
      $system.put_line ' '//$strrep(rav$event_message) o=$response
      rav$event_message.normal = TRUE
    IFEND
    $system.put_line ' '//$strrep(osv$status) o=$response

    rav$status = ..
          $status(false, 'RA', rae$errors_occurred_warning, '?initiation_commands_name?')
  WHENEND


  create_variable rav$event_message k=status s=xdcl

  create_variable ignore_status k=status
  create_variable local_status k=status
  create_variable rav$status k=status

END_COLLECT

    $system.copy_file i=initiation_commands_file o=initiation_commands.$eoi status=local_status
    IF local_status.normal THEN

COLLECT_TEXT initiation_commands.$eoi until='END_COLLECT'

  EXIT_PROC WITH rav$status WHEN NOT rav$status.normal

PROCEND initiation_commands
END_COLLECT

      rav$margin=rav$margin + 0

      $system.include_command c=$string(initiation_commands) status=local_status

      rav$margin=rav$margin - 0

      IF local_status.normal THEN
        "Capitalize first letter.
        initiation_commands_phrase=$translate(lower_to_upper, $substring(initiation_commands_phrase, 1))// ..
              $substring(initiation_commands_phrase, 2, $size(initiation_commands_phrase)-1)
        rap$display_message mm=initiation_messages mn=initiation_commands_executed mp=initiation_commands_phrase ..
              m=rav$margin t=$response status=ignore_status
      IFEND
    IFEND
    $system.detach_file f=initiation_commands status=ignore_status

  ELSE
    $system.put_line l=' '//$strrep($status(false, 'PF', pfe$unknown_permanent_file, initiation_commands_file)) o=$response
    local_status = ..
          $status(false, 'RA', rae$errors_occurred_warning, $string(initiation_commands_name))
  IFEND

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$run_initiation_commands
*DECK DECK=RAP$SCAN_FILE EXPAND=FALSE

  PROCEDURE [XREF] rap$scan_file (fid: amt$file_identifier;
    VAR dir: rat$170_file_directory;
    VAR status: ost$status);

*copyc amt$file_identifier
*copyc rat$170_file_directory
*copyc ost$status

*DECK DECK=RAP$SET_FILE_RETENTION EXPAND=FALSE

  PROCEDURE [XREF] rap$set_file_retention
    (    file: fst$file_reference;
         retention_period: pft$retention;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc pfd$permanent_file_definitions
*copyc ost$status
?? POP ??
*DECK DECK=RAP$SET_JOB_CLASS_LIMIT EXPAND=TRUE
create_command_description name=(set_job_class_limit, set_job_class_limits, setjcl) ..
      sp=clp$set_job_class_limit_command  availability=hidden
*DECK DECK=RAP$SET_SYSTEM_ATTRIBUTE EXPAND=TRUE
create_command_description name=(set_system_attribute, setsa) ..
      sp=osp$set_system_attribute
*DECK DECK=RAP$SET_TABLE_VIOLATION EXPAND=FALSE

  PROCEDURE [XREF] rap$set_table_violation (table_lfn: amt$local_file_name;
        table_path: clt$path_name;
    VAR status: ost$status);

*copyc amt$local_file_name
*copyc clt$file_reference
*copyc ost$status

*DECK DECK=RAP$SOFTWARE_MAINTENANCE_PATH EXPAND=FALSE

*copyc cld$value
*copyc ost$status

PROCEDURE [XREF] rap$software_maintenance_path (function_name: clt$name;
  argument_list: string(*);  VAR value: clt$value;  VAR status: ost$status);

*DECK DECK=RAP$SORT_CYCLES EXPAND=FALSE

  PROCEDURE [INLINE] rap$sort_cycles
    (    cycles_p: pft$p_cycle_array);

?? PUSH (LISTEXT := ON) ??

    VAR
      current: integer,
      gap: integer,
      start: integer,
      swap: pft$cycle_array_entry;


    gap := UPPERBOUND (cycles_p^);
    WHILE gap > 1 DO
      gap := 2 * (gap DIV 4) + 1;
      FOR start := LOWERBOUND (cycles_p^) TO UPPERBOUND (cycles_p^) - gap DO
        current := start;
        WHILE (current > 0) AND (cycles_p^ [current].cycle_number < cycles_p^ [current + gap].cycle_number) DO
          swap := cycles_p^ [current];
          cycles_p^ [current] := cycles_p^ [current + gap];
          cycles_p^ [current + gap] := swap;
          current := current - gap;
        WHILEND;
      FOREND;
    WHILEND;

  PROCEND rap$sort_cycles;

{ PURPOSE:
{   This procedure sorts the cycles of a permanent file
{   in descending order.
{
{ DESIGN:
{   This procedure uses a shell sort technique.
{
{ NOTES:
{

*copyc pfd$catalog_info
?? POP ??

*DECK DECK=RAP$SORT_PSRS EXPAND=FALSE

  PROCEDURE [XREF] rap$sort_psrs
    (VAR psr_list: rat$psrs_answered);

?? PUSH (LISTEXT := ON) ??
*copyc rat$subproduct_info_types
?? POP ??
*DECK DECK=RAP$STAGE_PRODUCTS EXPAND=FALSE

  PROCEDURE [XREF] rap$stage_products
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR subproducts_failed_processing: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$START_HPA_MONITOR_JOB EXPAND=TRUE
PROCEDURE (HIDDEN) start_hpa_monitor_job (
  status)


*IF $variable(wev$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure starts the HPA monitor job.
"
" NOTES:
"   When this procedure is called by the ACTIVATE_JOB_ENVIRONMENT command an event message is
"   used to help isolate where an error originated from.  The variable RAV$EVENT_MESSAGE is set for
"   starting the job and will be displayed along with the error should one occur.  The event
"   message is cleared if the procedure finishes without an error.
*IFEND

*copy rav$system_paths

  IF $variable(rav$event_message, nonlocal) THEN
    "$FORMAT=OFF
    VAR
      rav$event_message: (XREF) status
    VAREND
    "$FORMAT=ON"
    rav$event_message=$status(false, 'RA', rae$starting_error, 'the HPA monitor job')
  IFEND
  "$FORMAT=OFF
  VAR
    local_status: status
    permanent: boolean = false
    hpa_monitor_job_file: file = rav$system.hardware_maintenance.hpa.hpf$start_monitor_job
  VAREND
  "$FORMAT=ON"

  $system.include_line 'permanent = $file(hpa_monitor_job_file, permanent)' status=local_status

  IF local_status.normal AND permanent THEN
    $system.include_file hpa_monitor_job_file status=local_status
  ELSE
    local_status=$status(false, 'PF', pfe$unknown_permanent_file, $string(hpa_monitor_job_file))
  IFEND

  IF (local_status.normal) AND ($variable(rav$event_message, local)) THEN
    rav$event_message.normal=true
  IFEND

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND start_hpa_monitor_job


*DECK DECK=RAP$SUBMIT_BATCH_JOBS EXPAND=FALSE

  PROCEDURE [XREF] rap$submit_batch_jobs
    (VAR installation_control_record {input} : rat$installation_control_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$SWAP_IN_JOB EXPAND=TRUE
create_command_description name=(swap_in_job, swapin, swaij) ..
      sp=jmp$oper_swapin_of_job
*DECK DECK=RAP$SWAP_OUT_JOB EXPAND=TRUE
create_command_description name=(swap_out_job, swapout, swaoj) ..
      sp=jmp$oper_swapout_of_job
*DECK DECK=RAP$TABLE_ENTRY_ATTRIBUTE EXPAND=FALSE
*DECK DECK=RAP$TABLE_ENTRY_LIST EXPAND=FALSE
*DECK DECK=RAP$TERMINATE_LOG EXPAND=TRUE
create_command_description name=(terminate_log, terl) sp=lgp$_terminate_log
*DECK DECK=RAP$TERMINATE_SYSTEM EXPAND=TRUE
create_command_description name=(terminate_system) ..
      sp=clp$terminate_system_command
*DECK DECK=RAP$TERMINATE_SYSTEM_LOGS EXPAND=TRUE
PROC terminate_system_logs (
  status : var of status = $optional
  )


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" This is one of several procedures created to simplify the installation process.
" These procedures are kept in the OSF$SITE_COMMAND_LIBRARY and therefore will
" receive minimal support.
"
" The purpose of this procedure is to terminate the system logs prior to performing
" an  upgrade.  This procedure is called out in the upgrade chapter of the SRB.
*IFEND


  create_variable proc_status k=status

  WHEN any_fault DO
    put_line $strrep(osv$status) o=$response
    proc_status = osv$status
  WHENEND

  terminate_log t=account
  terminate_log t=engineering
  deactivate_history_log
  terminate_log t=history
  terminate_log t=statistic
  terminate_log t=system

  EXIT_PROC WITH proc_status WHEN NOT proc_status.normal

PROCEND terminate_system_logs
*DECK DECK=RAP$TERMINATE_TAPE_ASSIGNMENT EXPAND=TRUE
create_command_description name=(terminate_tape_assignment, terta) ..
      sp=clp$terminate_tape_assignment
*DECK DECK=RAP$TEST_CYCLES EXPAND=FALSE

  PROCEDURE [XREF] rap$test_cycles
    (    validation_selections: rat$validation_selections;
         element_ref_p: ^fst$file_reference;
         info_record_p: pft$p_info_record;
         info_offset: pft$info_offset;
     VAR cycles_p: {output}  pft$p_cycle_array;
     VAR validation_errors: {output} boolean;
     VAR attributes_checksum: {output} integer;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc pfd$catalog_info
*copyc rat$subproduct_info_types
*copyc rat$validation_selections
?? POP ??



*DECK DECK=RAP$TEST_FOR_ENTRY_CHANGES EXPAND=FALSE

*copyc ost$status

PROCEDURE [XREF] rap$test_for_entry_changes (VAR status: ost$status);
*DECK DECK=RAP$TEST_FOR_HEADER_CHANGES EXPAND=FALSE

*copyc ost$status

PROCEDURE [XREF] rap$test_for_header_changes (VAR status: ost$status);

*DECK DECK=RAP$TEST_PERMITS EXPAND=FALSE

  PROCEDURE [XREF] rap$test_permits
    (    validation_selections: rat$validation_selections;
         element_ref_p: ^fst$file_reference;
         info_record_p: pft$p_info_record;
         info_offset: pft$info_offset;
     VAR validation_errors: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc pfd$catalog_info
*copyc rat$subproduct_info_types
*copyc rat$validation_selections
?? POP ??
*DECK DECK=RAP$UPDATE_DIRECTORY EXPAND=FALSE

  PROCEDURE [XREF] rap$update_directory
    (VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR subproducts_failed_processing: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$UPDATE_LIBRARY EXPAND=TRUE
PROCEDURE rap$update_library(
  file, f: file = $required
  library, l: file = $required
  lock_out_library, lol: boolean = true
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'
"
"  This procedure combines modules from a file onto a library.  If the
"  lock out library parameter is true, the high and next cycles of the library
"  are locked to prevent any other attempt at writing a new cycle of this
"  library (this can happen when updating the di object library for CDCNET).
"
"  NOTE:  The library specified by the library parameter is assumed to not
"  have a cycle reference.
*IFEND


  VAR
    base_cycle: integer
    base_lfn: name = $name($unique)
    command_file: file = $local//$name($unique)
    delete_ring: integer
    ignore_status: status
    library_status: status
    local_status: status
    low_cycle: integer
    new_cycle: integer
    new_lfn: name = $name($unique)
    ring: array 1..3 of integer
    update_ring: integer

    rav$installation_environment: (XREF) rat$installation_environment
  VAREND


  update_block: ..
    BLOCK

  IF NOT $file(file permanent) THEN
    local_status = $status(FALSE, 'PF', pfe$unknown_permanent_file , $string(file))
    EXIT update_block WHEN NOT local_status.normal
  IFEND

  IF NOT $file(library permanent) THEN
    local_status = $status(FALSE, 'PF', pfe$unknown_permanent_file , $string(library))
    EXIT update_block WHEN NOT local_status.normal
  IFEND

  IF (($file(file file_content)<>'OBJECT') AND ($file(file file_structure)<>'LIBRARY')) THEN
    local_status = $status(FALSE, 'RA', rae$file_not_correct_format, $string(file), 'OBJECT LIBRARY')
    EXIT update_block WHEN NOT local_status.normal
  IFEND


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"  In the following discussion, 'R1' and 'R2' refer to the 1st and
"  2nd ring attributes respectively.
"
"  To perform the library update, task to R2 of the library
"  being updated when R2 is lower than the current execution ring.
"  Otherwise, stay at the current execution ring.  The library merge
"  cannot be performed on libraries whose R2 value is 3.  This is
"  because CREATE_OBJECT_LIBRARY cannot be called from ring 3.
"
"  To delete the previous cycle of the library, task to R1 of the library
"  whose cycle is being deleted when R1 is lower than the current
"  execution ring.  Otherwise, stay at the current execution ring.
*IFEND


  rap$get_file_ring_attributes fn=library r=ring status=local_status
  EXIT update_block WHEN NOT local_status.normal

  IF ring(1) < $ring THEN
    delete_ring = ring(1)
  ELSE
    delete_ring = $ring
  IFEND

  IF ring(2) < $ring THEN
    update_ring = ring(2)
  ELSE
    update_ring = $ring
  IFEND



  IF lock_out_library THEN


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"  The high cycle of the library is attached with share mode of none and
"  wait turned on.  This cycle of the library is then validated as an object
"  library.  The high cycle becomes the base source in CREOL.
"
"  The next cycle of the library is created using CREATE_FILE, this attaches
"  the next cycle until released by this procedure. The result of combining
"  the high cycle of the library and the file (from the file parameter) is
"  written to the next cycle (or new cycle as it is referred to in the code).
"
"  Once generation is complete and the ring attributes set on the new cycle, the
"  base and new cycles of the library are detached (releasing the lock).  The
"  base cycle is then deleted.
*IFEND


COLLECT_TEXT command_file until='END_LOCK_OUT_TEXT'
  TASK r=update_ring
    $system.attach_file f=library lfn=base_lfn sm=none wait=true
    base_cycle = $file(library cycle_number)

    IF (($file(library//base_cycle file_content) <> 'OBJECT') ..
          OR ($file(library//base_cycle file_structure) <> 'LIBRARY')) THEN
      library_status = $status(FALSE, 'RA', rae$file_not_correct_format, ..
            $string(library//base_cycle), 'OBJECT LIBRARY')
    ELSE

      $system.create_file f=library lfn=new_lfn
      new_cycle = $file(library cycle_number)

      $system.create_object_library
        add_module library//base_cycle
        combine_module file
        generate_library library//new_cycle
        quit
      $system.change_file_attributes library//new_cycle ra=(ring(1) ring(2) ring(3))
      $system.detach_file f=library//new_cycle status=ignore_status

      $system.detach_file f=library//base_cycle status=ignore_status
    IFEND
  TASKEND
  IF library_status.normal THEN
    IF NOT rav$installation_environment.save_previous_cycles THEN
      TASK r=delete_ring
        FOR low_cycle = 1 to ($size($file_cycles(library)) - 1) DO   "delete all cycles except 1."
          $system.delete_file f=library status=ignore_status
        FOREND
      TASKEND
    IFEND
  IFEND
END_LOCK_OUT_TEXT

  ELSE

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"  Do not lock out.
"
"  The library specifed on the parameter is validated as an object library.
"
"  The high cycle of the library and the file (from the file parameter) are combined
"  and the result is written to the $NEXT cycle of library.  Ring attributes are set
"  on the new cycle.
"  The $LOW cycle (assumed to be the old high cycle) of the library is then deleted.
"
"  NOTE:  The results cannot be guaranteed if other attempts are made to write to the
"  library at the same time without lockout.
*IFEND

  IF (($file(library file_content)<>'OBJECT') OR ($file(library file_structure)<>'LIBRARY')) THEN
    local_status = $status(FALSE, 'RA', rae$file_not_correct_format, $string(library), 'OBJECT LIBRARY')
    EXIT update_block WHEN NOT local_status.normal
  IFEND

COLLECT_TEXT command_file until='END_NO_LOCK_TEXT'
  TASK r=update_ring
    $system.create_object_library
      add_module library
      combine_module file
      generate_library library.$next
      quit
    $system.change_file_attributes library ra=(ring(1) ring(2) ring(3))
  TASKEND
  IF NOT rav$installation_environment.save_previous_cycles THEN
    TASK r=delete_ring
      FOR low_cycle = 1 to ($size($file_cycles(library)) - 1) DO   "delete all cycles except 1."
        $system.delete_file f=library status=ignore_status
      FOREND
    TASKEND
  IFEND
END_NO_LOCK_TEXT

  IFEND

  $system.include_file f=command_file status=local_status
  $system.delete_file f=command_file status=ignore_status
  EXIT update_block WHEN NOT local_status.normal

  BLOCKEND update_block

  EXIT procedure WITH local_status WHEN NOT local_status.normal
  EXIT procedure WITH library_status WHEN NOT library_status.normal

PROCEND rap$update_library
*DECK DECK=RAP$UPDATE_SYSFILES_FOR_ARCHIVE EXPAND=TRUE
PROCEDURE rap$update_sysfiles_for_archive, updsfa (
  retrieval_precedence, rp: list of key
      (tape, t)
      (cartridge_tape, ct)
      (cartridge_storage_system, css)
      (archive_to_nos, atn)
    keyend = (tape)
  status)

"This procedure copies text into the following file:
"
"  $SYSTEM.PROLOGS_AND_EPILOGS.JOB_ACTIVATION_EPILOG
"
" This text adds the commands necessary to run Archive/VE
" to the  appropriate prologs and epilogs.
"

WHEN any_fault DO
  display_value osv$status o=$response
  EXIT_PROC
WHENEND

SYSTEM_OPERATOR_UTILITY
  TASK r=3
COLLECT_TEXT o=$system.prologs_and_epilogs.job_activation_epilog.$eoi u='**' sm='?'
  VAR
    rav$jobs_recovered: (xref) boolean
  VAREND

  IF NOT rav$jobs_recovered THEN
    deactivate_archive_ve
    TASK r=3
      delete_file f=$system.archive_ve.archive_retrieval_file ..
        status=osv$status
    TASKEND
  IFEND
  activate_archive_ve
  manage_archive_activity list=$null
    change_retrieval_precedence p=?retrieval_precedence?
  quit
**
  TASKEND
QUIT

PROCEND rap$update_sysfiles_for_archive
*DECK DECK=RAP$VALIDATE_FOR_CORRECTION EXPAND=FALSE
  PROCEDURE [XREF] rap$validate_for_correction
    (    directory_pointers: rat$idb_directory_pointers;
     VAR installation_control_record: rat$installation_control_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$idb_directory_types
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$VALIDATE_FOR_INSTALLATION EXPAND=FALSE

  PROCEDURE [XREF] rap$validate_for_installation
    (    product_list_p: ^clt$data_value;
         excluded_product_list_p: ^clt$data_value;
         force_reinstall: boolean;
         installation_tasks: rat$task_selections;
     VAR installation_control_record {input, output} : rat$installation_control_record;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$data_value
*copyc ost$status
*copyc rat$installation_control_record
?? POP ??
*DECK DECK=RAP$VALIDATE_INSTALLATION_PATHS EXPAND=FALSE

  PROCEDURE [XREF] rap$validate_installation_paths
    (    base_attributes: rat$subproduct_attributes;
         base_path_container: rat$path_container;
         current_attributes: rat$subproduct_attributes;
         current_path_container: rat$path_container;
         installation_scheme: rat$installation_scheme;
         set_status_to_error: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$subproduct_info_types
?? POP ??

*DECK DECK=RAP$VALIDATE_PACKING_LIST_NAME EXPAND=TRUE
PROCEDURE (HIDDEN) rap$validate_packing_list_name (
  packing_list_name, pln: string 0..$max_name = $required
  require_user_acknowledgement, rua: boolean = $required
  packing_list_name_valid, plnv: (VAR) boolean = $required
  )

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure validates that the packing list name given is non blank.
" NOTES:
*IFEND

  "$FORMAT=OFF
  VAR
    ignore_status: status
  VAREND
"$FORMAT=ON

  packing_list_name_valid = true
validate_block: ..
  BLOCK

    IF packing_list_name = '' THEN
      packing_list_name_valid = false
      rap$display_message mm=initiation_messages mn=no_setit_command t=$response status=ignore_status
      IF require_user_acknowledgement THEN
        rap$press_next
      IFEND
      EXIT validate_block
    IFEND

  BLOCKEND validate_block

PROCEND rap$validate_packing_list_name
*DECK DECK=RAP$VEDISPLAY EXPAND=TRUE
create_command_description name=(vedisplay, ved) sp=ofp$vedisplay_command
*DECK DECK=RAP$VED_UTILITY EXPAND=TRUE
create_command_description name=(ved_utility, vedu) sp=ofp$_ved_utility
*DECK DECK=RAP$VERIFY_CATALOG_EXISTS EXPAND=FALSE

  PROCEDURE [INLINE] rap$verify_catalog_exists
    (    catalog: pft$path;
     VAR scratch_seq_p {input} : ^SEQ ( * );
     VAR catalog_exists {output} : boolean);


?? PUSH (LISTEXT := ON) ??

    VAR
      group: pft$group,
      local_status: ost$status;


    local_status.normal := TRUE;
    group.group_type := pfc$public;

    catalog_exists := TRUE;

    RESET scratch_seq_p;

    pfp$get_item_info (catalog, group, $pft$catalog_info_selections [pfc$catalog_directory],
          $pft$file_info_selections [], scratch_seq_p, local_status);
    IF NOT local_status.normal THEN
      catalog_exists := FALSE;
    IFEND;

  PROCEND rap$verify_catalog_exists;

{ PURPOSE:
{   This inline procedure verifies that the catalog exists.  The existence
{   of the catalog is returned in a boolean.
{
{ DESIGN:
{   Any error returned by the PF interface is taken to mean the catalog
{   does not exits.
{
{ NOTES:
{   This is a temporary procedure until a feature to
{   AMP$GET_FILE_ATTRIBUTES is transmitted (sometime around July 6, 1988)
{   that will verify that catalogs exist.  Because of this fact very little
{   effort has gone into this interface.
{

*copyc pfp$get_item_info
?? POP ??

*DECK DECK=RAP$VERIFY_CONFIGURATION EXPAND=TRUE
PROCEDURE (HIDDEN) rap$verify_configuration (
  status: (var) status = $optional
  )

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

" PURPOSE:
"   This procedure verifies that the network configuration file is present and valid.
*IFEND


  "$FORMAT=OFF
  VAR
    ignore_status: status
    local_status: status
    rav$event_message: (XREF) status
    rav$system: (XREF) file
    network_configuration_file: file = rav$system.network.configuration
    verify_configuration: file = $fname($unique)
  VAREND
  "$FORMAT=ON"


  rav$event_message=$status(false, 'RA', rae$verifying_error, 'the network configuration')

  $system.include_line 'permanent = $file(network_configuration_file, permanent)' status=local_status

  IF local_status.normal AND permanent THEN

COLLECT_TEXT o=verify_configuration until='END_COLLECT'

    execute_task sp=logical_configuration_utility
      verify_network_configuration i=network_configuration_file e=$response
    quit

END_COLLECT

    $system.include_file f=verify_configuration status=local_status
    $system.delete_file f=verify_configuration status=ignore_status

  ELSE
    local_status=$status(false, 'RA', rae$missing_configuration, 'network')
  IFEND

  IF local_status.normal THEN
    rav$event_message.normal=true
  ELSE
    EXIT procedure WITH local_status
  IFEND

PROCEND rap$verify_configuration
*DECK DECK=RAP$VERIFY_SUBPRODUCT EXPAND=FALSE

  PROCEDURE [XREF] rap$verify_subproduct
        (pacs_ref_p: ^fst$file_reference;
         validation_selections: rat$validation_selections;
         sif_present: boolean;
     VAR verify_options: rat$subproduct_verify_options;
     VAR verify_errors: {input/output} rat$subproduct_verify_errors;
     VAR subproduct_info_pointers: {input, output} rat$subproduct_info_pointers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc rat$scratch_segment
*copyc rat$subproduct_info_pointers
*copyc rat$subproduct_info_types
*copyc rat$subproduct_verify_errors
*copyc rat$subproduct_verify_options
*copyc rat$validation_selections
?? POP ??

*DECK DECK=RAP$VERIFY_SUBPRODUCT_INTERFACE EXPAND=FALSE

  PROCEDURE [XREF] rap$verify_subproduct_interface
    (    pacs_ref_p: ^fst$file_reference;
         verify_option: ost$name;
         sif_identifier: ost$name;
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=RAP$VERIFY_USER_INFO EXPAND=FALSE
  PROCEDURE [XREF] rap$verify_user_info (old_file_name: amt$local_file_name;
        new_file_name: amt$local_file_name;
    VAR user_info_differs: boolean;
    VAR new_user_info: amt$user_info;
    VAR status: ost$status);

*copyc amt$local_file_name
*copyc amd$file_attributes
*copyc ost$status
*DECK DECK=RAP$WRITE_CORRECTION_PACKAGE EXPAND=FALSE
  PROCEDURE [XREF] rap$write_correction_package (output_file_name: clt$file;
    VAR status: ost$status);

*copyc ost$status
*copyc clt$file

*DECK DECK=RAP$WRITE_DISK_ORDER EXPAND=TRUE
PROCEDURE rap$write_disk_order (
  order_catalog, oc: file = $required
  disk_file, df: file = $required
  list, l: file = $list
  verify_option, vo: (BY_NAME, HIDDEN) key
      (brief, b)
      (full, f)
      (manufacturing, m)
    keyend = brief
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"
" PURPOSE:
"   This procedure writes an order to a disk file.
"
" DESIGN:
"   The information from the order data file and the input parameters
"   on this procedure are used to write the packing list and the
"   subproducts to a disk file.  When the order data file is included,
"   a set of SCL variables is created and initialized.
"
" NOTES:
"
"
*IFEND

"$FORMAT=OFF
  VAR
    backup_file: name
    backup_status: status
    delete_status: status
    ignore_status: status
    local_status: status
    order_data: name = raf$order_data
  VAREND
"$FORMAT=ON


  include_file f=order_catalog//order_data status=local_status
  EXIT procedure WITH local_status WHEN NOT local_status.normal

  IF order_medium <> disk THEN
    local_status = $status(false, 'RA', rae$medium_and_param_mismatch, order_medium, 'DISK_FILE')
    EXIT procedure WITH local_status
  IFEND

  IF $FILE(disk_file, catalog) THEN
    local_status = $status(false, 'RA', rae$disk_file_cannot_be_catalog, disk_file)
    EXIT procedure WITH local_status
  IFEND

  create_catalog c=disk_backup_catalog status=local_status
  EXIT procedure WHEN NOT local_status.normal

" The WHEN handler is started here since it will be executed whenever the
" the procedure exits, even if the exit is because of an EXIT statement.

  WHEN exit DO
    include_command 'delete_catalog c=disk_backup_catalog do=catalog_and_contents' status=ignore_status
    EXIT procedure WITH osv$status
  WHENEND

main: ..
  BLOCK

    FOR subproduct_index = 1 TO $upperbound(subproducts) DO
      backup_file = subproducts(subproduct_index).backup_file

      verify_subproduct pc=subproducts(subproduct_index).pacs_catalog vo=verify_option ..
           sif_identifier=subproducts(subproduct_index).sif_identifier status=local_status
      EXIT main WHEN NOT local_status.normal

      BACKUP_PERMANENT_FILE bf=disk_backup_catalog//backup_file l=list.$eoi status=backup_status
        EXIT main WHEN NOT backup_status.normal

        " The following line prevents compatibility problems in the backup file.
        set_backup_options backup_file_version=1 include_data=(ud rd od) ..
               include_archive_information=false status=local_status
        EXIT main WHEN NOT local_status.normal

        exclude_file f=subproducts(subproduct_index).pacs_catalog//sif_file_name status=local_status
        EXIT main WHEN NOT local_status.normal

        backup_catalog c=subproducts(subproduct_index).pacs_catalog status=local_status
        EXIT main WHEN NOT local_status.normal

        rap$display_message mm=ram$pacs_messages mn=backup_complete t=$response mp=($string(..
              subproducts(subproduct_index).name), 'disk backup catalog') status=ignore_status

      QUIT

    FOREND

    BACKUP_PERMANENT_FILE bf=disk_file l=list.$eoi status=backup_status
      EXIT main WHEN NOT backup_status.normal

      " The following line prevents compatibility problems in the backup file.
      set_backup_options backup_file_version=1 include_data=(ud rd od) ..
             include_archive_information=false status=local_status
      EXIT main WHEN NOT local_status.normal

      backup_file f=order_catalog//packing_list_name status=local_status
      EXIT main WHEN NOT local_status.normal

      rap$display_message mm=ram$pacs_messages mn=backup_complete t=$response mp=($string(packing_list_name)..
            , $string(disk_file)) status=ignore_status

      backup_catalog c=disk_backup_catalog status=local_status
      EXIT main WHEN NOT local_status.normal

      rap$display_message mm=ram$pacs_messages mn=backup_complete t=$response mp=(('All Subproducts'), ..
            $string(disk_file)) status=ignore_status

    QUIT

  BLOCKEND main

" This procedure displays bad status on the delete_catalog command because the "
" disk catalog may be extremely large. "

  delete_catalog c=disk_backup_catalog do=catalog_and_contents status=delete_status

  IF delete_status.normal THEN
    rap$display_message mm=ram$pacs_messages mn=deleted_catalog t=$response mp='disk backup catalog' ..
          status=ignore_status
  IFEND

  CANCEL exit

  EXIT procedure WITH local_status WHEN NOT local_status.normal
  EXIT procedure WITH backup_status WHEN NOT backup_status.normal
  EXIT procedure WITH delete_status WHEN NOT delete_status.normal

PROCEND rap$write_disk_order
*DECK DECK=RAP$WRITE_FILE_FROM_MEMORY EXPAND=FALSE

  PROCEDURE [XREF] rap$write_file_from_memory
    (    file: fst$file_reference;
         memory_seq_size: integer;
     VAR memory_seq_p {input} : ^SEQ ( * );
     VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
?? POP ??
*DECK DECK=RAP$WRITE_ORDER EXPAND=TRUE
PROCEDURE rap$write_order (
  order_catalog, oc: file = $required
  external_vsn, evsn: any of
      key
        all
      keyend
      list of string 1..6
      list of name 1..6
    anyend = $optional
  disk_file, df: file = $optional
  list, l: file = $list
  tape_file, tf: (BY_NAME, HIDDEN) file = $optional
  request_tape_labeling, request_tape_labelling, rtl: (BY_NAME, HIDDEN) boolean = false
  unload_volume, uv: boolean = true
  verify_option, vo: (BY_NAME, HIDDEN) key
      (brief, b)
      (full, f)
      (manufacturing, m)
    keyend = brief
  volume_overflow_allowed, voa: (BY_NAME, HIDDEN) boolean = false
  tape_permit, tp: (BY_NAME, HIDDEN) any of
      key
        public, private, (release_tapes, release), none
      keyend
      name 1..13
    anyend = none
  status)


*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"
" PURPOSE:
"   This procedure writes an order to a list of tapes or to a
"   disk file.
"
" DESIGN:
"   The order is defined by the order data file in the specified order catalog.
"   Either the VSNS or the DISK_FILE parameter must be specified, but not both.
"   The appropriate procedure is called to write the order to disk or tape.
"
" NOTES:
"
*IFEND
"$FORMAT=OFF
  VAR
    ignore_status: status
    local_status: status
    order_data: name = raf$order_data
    packing_list: name = raf$packing_list
  VAREND
"$FORMAT=ON


  IF (NOT $specified(disk_file)) AND (NOT $specified(external_vsn)) THEN
    local_status = $status(false, 'RA', rae$parameter_disk_or_vsn_req)
    EXIT procedure WITH local_status
  ELSEIF $specified(disk_file) AND $specified(external_vsn) THEN
    local_status = $status(false, 'RA', rae$only_one_param_disk_or_vsn)
    EXIT procedure WITH local_status
  ELSEIF $specified(disk_file) AND $specified(tape_file) THEN
    local_status = $status(false, 'RA', rae$tape_file_param_incorrect)
    EXIT procedure WITH local_status
  IFEND

  IF NOT $file(order_catalog//order_data, permanent) THEN
    local_status = $status(false, 'RA', rae$file_missing_from_order_cat, $string(order_catalog//order_data))
    EXIT procedure WITH local_status
  ELSEIF NOT $file(order_catalog//packing_list, permanent) THEN
    local_status = $status(false, 'RA', rae$file_missing_from_order_cat, $string(order_catalog//packing_list))
    EXIT procedure WITH local_status
  IFEND

  PUSH command_list

  delete_command_list_entry :$system.$system.osf$builtin_library status=ignore_status
  create_command_list_entry :$system.$system.osf$builtin_library status=local_status
  EXIT procedure WITH local_status WHEN NOT local_status.normal

  IF $specified(external_vsn) THEN
    IF (NOT $generic_type(external_vsn) = KEY) THEN
      external_vsn = $string(external_vsn)
    IFEND
    rap$write_tape_order oc=order_catalog evsn=external_vsn l=list tf=tape_file vo=verify_option rtl=request_tape_labeling ..
          uv=unload_volume voa=volume_overflow_allowed tape_permit=tape_permit status=local_status

  ELSEIF $specified(disk_file) THEN

    rap$write_disk_order oc=order_catalog df=disk_file l=list vo=verify_option status=local_status

  IFEND

  POP command_list

  EXIT procedure WITH local_status WHEN NOT local_status.normal

PROCEND rap$write_order
*DECK DECK=RAP$WRITE_STRINGS EXPAND=FALSE

  PROCEDURE [XREF] rap$write_strings
    (    string_a: string ( * );
         string_b: string ( * );
         continue_line: boolean;
         indent: 0 .. rac$max_line;
     VAR display_control: clt$display_control;
     VAR display_status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc rac$max_line
*copyc clt$display_control
?? POP ??
*DECK DECK=RAP$WRITE_SUBPRODUCT_INFO_FILE EXPAND=FALSE

  PROCEDURE [XREF] rap$write_subproduct_info_file
    (    pacs_catalog: rat$path;
     VAR subproduct_info_pointers {input} : rat$subproduct_info_pointers;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rat$path
*copyc rat$subproduct_info_pointers
?? POP ??
*DECK DECK=RAP$WRITE_TAPE_ORDER EXPAND=TRUE
PROCEDURE rap$write_tape_order (
  order_catalog, oc: file = $required
  external_vsn, evsn: any of
      key
        all
      keyend
      list of string 1..6
      list of name 1..6
    anyend = $required
  list, l: file = $list
  tape_file, tf: (BY_NAME, HIDDEN) file = $optional
  request_tape_labeling, request_tape_labelling, rtl: (BY_NAME, HIDDEN) boolean = $optional
  unload_volume, uv: boolean = true
  verify_option, vo: (BY_NAME, HIDDEN) key
      (brief, b)
      (full, f)
      (manufacturing, m)
    keyend = brief
  volume_overflow_allowed, voa: (BY_NAME, HIDDEN) boolean = false
  tape_permit, rmg: (BY_NAME, HIDDEN) any of
      key
        public, private, (release_tapes, release), none
      keyend
      name 1..13
    anyend = release_tapes
  status)

*IF $variable(rav$proc_doc,declared)<>'UNKNOWN'

"
" PURPOSE:
"   This procedure writes an order to a list of tapes.
"
" DESIGN:
"   The information from the order data file and the input parameters
"   on this procedure are used to write the packing list and the
"   subproducts to a list of tapes.  When the order data file is included,
"   a set of SCL variables is created and initialized.
"
"   The volume overflow allowed optional parameter allows specification
"   as to whether it is desired to allow tape volumes to overflow onto
"   additional tapes when the previous tape was not long enough, or
"   abort on an overflow condition.
"
" NOTES:
"
"
*IFEND

"$FORMAT=OFF
  VAR
    ignore_status: status
    local_status: status
    order_data: name = raf$order_data
    backup_status: status
    selected_evsns: list of string 1..6
    unique_tape_file: file = $fname($unique)
    tape_selected: boolean
    upper_evsns: list of string 1..6
    operator_reply: string
  VAREND
"$FORMAT=ON

  include_file f=order_catalog//order_data status=local_status
  EXIT procedure WITH local_status WHEN NOT local_status.normal

  IF order_medium <> tape THEN
    local_status = $status(false, 'RA', rae$medium_and_param_mismatch, order_medium, 'VSNS')
    EXIT procedure WITH local_status
  IFEND

  IF $generic_type(evsn) = key THEN
    selected_evsns = primary_vsns
  ELSE
    upper_evsns = evsn
    FOR evsn_index = 1 TO $size(evsn) DO
      upper_evsns(evsn_index) = $translate(lower_to_upper, evsn(evsn_index))
    FOREND

    IF $subset(upper_evsns, primary_vsns) THEN
      selected_evsns = upper_evsns
    ELSE
      local_status = $status(false, 'RA', rae$invalid_vsn_list)
      EXIT procedure WITH local_status
    IFEND

  IFEND

  IF $specified(tape_file) THEN
    unique_tape_file = $fname(tape_file)
  IFEND

" The WHEN handler is started here since it will be executed whenever the
" the procedure exits, even if the exit is because of an EXIT statement.

  WHEN exit DO
    include_command 'detach_file f=unique_tape_file uv=unload_volume' status=ignore_status
    EXIT procedure WITH osv$status
  WHENEND

main: ..
  BLOCK

    FOR tape_index = 1 TO $upperbound(tapes) DO

      tape_selected = $subset($first(tapes(tape_index).evsn), selected_evsns)

      IF tape_selected THEN

        IF request_tape_labeling THEN

          send_operator_message message=('PLS blank label '//..
tapes(tape_index).evsn//': internal_vsn='//tapes(tape_index).rvsn//'; density='//tape_type) ..
             operator_class=removable_media_operator status=ignore_status

        IFEND

        request_magnetic_tape f=unique_tape_file evsn=tapes(tape_index).evsn rvsn=tapes(tape_index).rvsn ..
              t=tape_type r=true voa=volume_overflow_allowed status=local_status
        EXIT main WHEN NOT local_status.normal

        IF tape_permit = public THEN
          change_tape_label_attributes file=unique_tape_file volume_accessibility=none ..
                owner_identifier=none status=local_status
        ELSEIF tape_permit = private THEN
          change_tape_label_attributes file=unique_tape_file volume_accessibility=a ..
                owner_identifier=$substr($string($job(login_user)) 1 14) status=local_status
        ELSEIF tape_permit = none THEN
          change_tape_label_attributes file=unique_tape_file volume_accessibility=$unspecified ..
                owner_identifier=$unspecified status=local_status
        ELSEIF tape_permit = release_tapes THEN
          change_tape_label_attributes file=unique_tape_file volume_accessibility=a ..
                removable_media_group=release_tapes status=local_status
        ELSE
          change_tape_label_attributes file=unique_tape_file volume_accessibility=a ..
                removable_media_group=tape_permit status=local_status
        IFEND
        EXIT main WHEN NOT local_status.normal

        IF tape_index = 1 THEN
          change_tape_label_attributes f=unique_tape_file fi=$string(packing_list_name) status=local_status
          EXIT main WHEN NOT local_status.normal

          BACKUP_PERMANENT_FILE bf=unique_tape_file l=list.$eoi status=backup_status
            EXIT main WHEN NOT backup_status.normal

            " The following line prevents compatibility problems in the backup file.
            set_backup_options backup_file_version=1 include_data=(ud rd od) ..
                  include_archive_information=false status=local_status
            EXIT main WHEN NOT local_status.normal

            backup_file f=order_catalog//packing_list_name status=local_status
            EXIT main WHEN NOT local_status.normal

            rap$display_message mm=ram$pacs_messages mn=backup_complete t=$response mp=($string(..
                  packing_list_name), primary_vsns(tape_index)) status=ignore_status
          QUIT

        IFEND

        FOR subproduct_index = tapes(tape_index).subproducts_index_lowerbound TO ..
              tapes(tape_index).subproducts_index_upperbound DO

          change_tape_label_attributes f=unique_tape_file fsp=next_file ..
                fi=$substr($string(subproducts(subproduct_index).name), 1, 17) status=local_status
          EXIT main WHEN NOT local_status.normal

          verify_subproduct pc=subproducts(subproduct_index).pacs_catalog vo=verify_option ..
                sif_identifier=subproducts(subproduct_index).sif_identifier status=local_status
          EXIT main WHEN NOT local_status.normal

          BACKUP_PERMANENT_FILE bf=unique_tape_file l=list.$eoi status=backup_status
            EXIT main WHEN NOT backup_status.normal

            " The following line prevents compatibility problems in the backup file.
            set_backup_options backup_file_version=1 include_data=(ud rd od) ..
                  include_archive_information=false status=local_status
            EXIT main WHEN NOT local_status.normal

            exclude_file f=subproducts(subproduct_index).pacs_catalog//sif_file_name status=local_status
            EXIT main WHEN NOT local_status.normal

            backup_catalog c=subproducts(subproduct_index).pacs_catalog status=local_status
            EXIT main WHEN NOT local_status.normal

            rap$display_message mm=ram$pacs_messages mn=backup_complete t=$response mp=($string(..
                  subproducts(subproduct_index).name), primary_vsns(tape_index)) status=ignore_status
          QUIT

        FOREND

      IFEND

      detach_file f=unique_tape_file uv=unload_volume status=ignore_status

    FOREND

  BLOCKEND main

  detach_file f=unique_tape_file uv=unload_volume status=ignore_status

  CANCEL exit

  EXIT procedure WITH local_status WHEN NOT local_status.normal
  EXIT procedure WITH backup_status WHEN NOT backup_status.normal

PROCEND rap$write_tape_order
*DECK DECK=RAP$WRITE_TO_UPGRADE_LOG EXPAND=FALSE

*copyc ost$status

PROCEDURE [XREF] rap$write_to_upgrade_log (VAR status: ost$status);

*DECK DECK=RAP$_ADMINISTER_SECURITY_AUDIT EXPAND=TRUE
create_program_description name=administer_security_audit_pd ..
      sp=sfp$_administer_security_audit l=(osf$current_library $system.cybil.cyf$run_time_library) ..
      tel=warning lmo=none lm=$null dm=off
*DECK DECK=RAT$170_FILE_DIRECTORY EXPAND=FALSE

*copyc rat$170_record_definitions

  TYPE

    rat$170_file_directory = ^rat$170_directory_entry,

    rat$170_directory_entry = record
      rec_name: string (7),
      rec_type: rat$nos_records,
      partition_number: integer,
      next_entry: rat$170_file_directory,
    recend;

*DECK DECK=RAT$170_RECORD_DEFINITIONS EXPAND=FALSE

  CONST

    rac$eor_170 = 4,
    rac$eof_170 = 7,
    rac$eoi_170 = 8,
    rac$buffer_length_170 = 3072;

  TYPE

    rat$nos_records = (rac$abs, rac$acf, rac$cap, rac$opl, rac$oplc, rac$opld,
      rac$ovcap, rac$ovl, rac$pp, rac$ppu, rac$proc, rac$relo, rac$text,
      rac$ucf, rac$ulib, rac$uplx),

    rat$170_file_position = (rac$170_boi, rac$170_eor, rac$170_eof,
      rac$170_eoi),

    rat$word_170 = packed record
      case 0 .. 5 of
      = 0 = { full cyber 180 64 bit word }
        structure_mark: integer,
      = 1 = { raw Cyber 170 60 bit word }
        filler1: 0 .. 0f(16),
        first_170_word: 0 .. 7777777777(8), { note: nos word is split because }
        last_170_word: 0 .. 7777777777(8), { of 57 bit alignment rule. }
      = 2 = { 10 display code characters }
        filler2: 0 .. 0f(16),
        { note: the display code representation is specified as separate }
        { characters because of the 57 bit alignment rule. }
        dc1: 0 .. 77(8),
        dc2: 0 .. 77(8),
        dc3: 0 .. 77(8),
        dc4: 0 .. 77(8),
        dc5: 0 .. 77(8),
        dc6: 0 .. 77(8),
        dc7: 0 .. 77(8),
        dc8: 0 .. 77(8),
        dc9: 0 .. 77(8),
        dc10: 0 .. 77(8),
      = 3 = { loader table header word }
        filler3: 0 .. 0f(16),
        table_type: 0 .. 0fff(16),
        word_count: 0 .. 0fff(16),
        filler4: 0 .. 0ffffffff(16),
      = 4 = { other header word }
        filler5: 0 .. 0f(16),
        rec_type: 0 .. 7777777777(8),
        filler6: 0 .. 7777777777(8),
      = 5 = { prefix table word 2 }
        filler7: 0 .. 0f(16),
        filler8: 0 .. 77777777777777(8),
        ptr_170: 0 .. 777777(8),
      casend,
    recend,

    rat$record_170 = record
      name: string (7),
      rtype: rat$nos_records,
      length: 0 .. rac$buffer_length_170,
      position: 0 .. rac$buffer_length_170,
      buffer: array [0 .. rac$buffer_length_170] of rat$word_170,
    recend;
*DECK DECK=RAT$ARRAY EXPAND=FALSE

CONST
  rac$max_array_index = 30;

TYPE
  rat$array = array [1 .. rac$max_array_index] of string (256);


*DECK DECK=RAT$CORRECTION_PACKAGE EXPAND=FALSE
  TYPE
    rat$correction_package = array [1 .. *] of rat$correction_element,

    rat$correction_element = record
      name: ost$name,
      size: rat$corrector_size,
      user_info: amt$user_info,
      class: rat$file_class,
      format: rat$file_format,
      correction_package: REL (rat$correction) ^SEQ ( * ),
      psr_info: REL (rat$correction) ^array [1 .. *] of rat$psr_ident,
      number_of_psrs: rat$psr_index,
    recend;

  TYPE
    rat$psr_ident = string (8),
    rat$element_index = 0 .. rac$max_correction_p_elements,
    rat$correction = SEQ ( * ),
    rat$psr_index = 0 .. rac$max_psrs;

*copyc rac$correction_constants
*copyc ost$name
*copyc amd$file_attributes
*copyc rat$corrector_size
*copyc rat$file_class
*copyc rat$file_format
*DECK DECK=RAT$CORRECTION_PACKAGE_HEADER EXPAND=FALSE
  TYPE
    rat$correction_package_header = record
      identification: string (18),
      version: string (4),
      applier: REL (rat$correction) ^SEQ ( * ),
      size_of_applier: rat$applier_size,
      number_of_elements: rat$element_index,
    recend;

  TYPE
    rat$applier_size = 0 .. 7FFFFFFF(16);

  CONST
    rac$correction_package_id = 'CORRECTION_PACKAGE',
    rac$correction_package_version = 'V1.4';

*copyc rat$correction_package

*DECK DECK=RAT$CORRECTION_PROCESS_RECORD EXPAND=FALSE

{ The correction process record is used by the CREATE_SUBPRODUCT_CORRECTION utility
{ to communicate information among the various procedures.


  TYPE
    rat$correction_process_sif_info = record
      fid: amt$file_identifier,
      file_opened: boolean,
      subproduct_info_pointers: rat$subproduct_info_pointers,
    recend;

  TYPE
    rat$correction_process_record = record
      base_level_sif: rat$correction_process_sif_info,
      current_level_sif: rat$correction_process_sif_info,
      correction_in_progress: boolean,
      new_subproduct_info_pointers: rat$subproduct_info_pointers,
      previous_correction_sif: rat$correction_process_sif_info,
    recend;

*copyc amt$file_identifier
*copyc ost$name
*copyc rat$subproduct_info_pointers
*DECK DECK=RAT$CORRECTOR_SIZE EXPAND=FALSE
  TYPE
    rat$corrector_size = 0 .. 7fffffff(16);

*DECK DECK=RAT$DATE_TIME EXPAND=FALSE
  TYPE
    rat$date_time = ost$date_time;

*copyc ost$date_time
*DECK DECK=RAT$DECK_INDEX EXPAND=FALSE
  TYPE
    rat$deck_index = 0 .. rac$max_decks;

*copyc rac$max_decks
*DECK DECK=RAT$ELEMENT_DESCRIPTOR EXPAND=FALSE
  TYPE
    rat$element_descriptor = record
      name: ost$name,
      format: rat$file_format,
      class: rat$file_class,
    recend;

*copyc ost$name
*copyc rat$file_format
*copyc rat$file_class

*DECK DECK=RAT$ELEMENT_PATHS EXPAND=FALSE
  TYPE
    rat$element_paths = array [rat$installation_paths] of ^pft$path;

*copyc pfd$permanent_file_definitions
*copyc rat$installation_paths
*DECK DECK=RAT$ENTRY_ATTRIBUTES EXPAND=FALSE

TYPE
  rat$entry_attributes = (rac$unused_attribute, rac$name, rac$new_name, rac$path,
                          rac$access_mode, rac$share_mode, rac$ring, rac$format, rac$class,
                          rac$storage_class,rac$product, rac$version, rac$intve_path, rac$comment);


*DECK DECK=RAT$FILE_CLASS EXPAND=FALSE

  TYPE
    rat$file_class = (rac$unused_class, rac$os, rac$pf, rac$cdcnet, rac$os_support, rac$none);


*DECK DECK=RAT$FILE_COMMENT EXPAND=FALSE

*copyc rac$max_line_size

TYPE
  rat$file_comment = string (rac$max_line_size);

*DECK DECK=RAT$FILE_FORMAT EXPAND=FALSE

TYPE
  rat$file_format = (rac$unused_format, rac$object_library, rac$online_manual,
                     rac$source_library, rac$v_record_file, rac$real_state_library,
                     rac$deadstart_tape_modules, rac$indexed_sequential_file,
                     rac$symbol_table, rac$installation_table, rac$ppu_format, rac$other);

*DECK DECK=RAT$FILE_VALUES EXPAND=FALSE

  TYPE
    rat$file_values = record
      lfn: amt$local_file_name,
      ref: clt$file_reference,
      path: ^pft$path,
    recend;

*copyc amt$local_file_name
*copyc clt$file_reference
*copyc pfd$permanent_file_definitions
*DECK DECK=RAT$HEADER_ATTRIBUTES EXPAND=FALSE

TYPE
  rat$header_attributes = (rac$unused_header_attribute, rac$title, rac$build_level,
                             rac$number_of_files, rac$table_violation);


*DECK DECK=RAT$HEADER_RECORD EXPAND=FALSE

*copyc rat$inst_table_index
TYPE
  rat$header_record = record
                        title: string(31),
                        build_level: string(31),
                        number_of_files: rat$inst_table_index,
                        table_violation: boolean,
                      recend;

*DECK DECK=RAT$IDB_DIRECTORY_POINTERS EXPAND=FALSE

  TYPE
    rat$idb_directory_pointers = record
      sequence_p: ^rat$idb_directory_sequence,
      sequence_descriptor_p: ^rat$sequence_descriptor,
      header_p: ^rat$directory_header,
      directory_p: ^rat$directory,
    recend;

*copyc rat$idb_directory_types
*copyc rat$sequence_descriptor_types
*DECK DECK=RAT$IDB_DIRECTORY_TYPES EXPAND=FALSE

{ PURPOSE:
{   This deck contains the type declarations for the IDB directory
{   sequence.  The fields for the major components are documented here:
{
{   The RAT$DIRECTORY_HEADER record contains the following fields:
{
{     DEFERRED_COUNT  - Number of deferred subproducts.
{
{     DIRECTORY_SIZE  - Number of records registered in the IDB directory.
{
{     DIRECTORY_REL_P  - A relative pointer to the directory records.
{
{
{   The RAT$DIRECTORY is an adaptable array of directory records
{   (RAT$DIRECTORY_RECORD).  Each RAT$DIRECTORY_RECORD record contains the
{   following fields:
{
{     PRIMARY_SUBPRODUCT  - Boolean value defining the subproduct as the
{                  spokesperson for the licensed product.  (Used for
{                  displaying licensed product information.)
{
{     DESCRIPTION  - A string value description of the subproduct.
{                  If the subproduct is defined as the primary subproduct
{                  of a licensed product this description applies for the
{                  licensed product as well.
{
{     HIDDEN  - Boolean value describing wheather or not this is a hidden
{                  subproduct.
{
{     SUBPRODUCT_CORRUPTED  - A Boolean to flag the active level of
{                  the subproduct as being corrupted.  This arises when a
{                  later installation of another level fails to activate.
{
{     BASE_LEVEL_INSTALLATION_CATALOG  - The path to the installation catalog
{                  that contains the corrective base level path.
{
{     SYSTEM_CATALOG_PATH_INDEX  - The index for the system catalog part of
{                  the base level installation catalog.
{
{     ACTIVE_INFORMATION  - An information record for the subproduct
{                  level that is currently active.
{
{     DEFERRED_INFORMATION  - An information record for the subproduct
{                  level that is currently deferred.
{
{     CORRECTIVE_BASE_INFORMATION  - An information record for the
{                  subproduct that is the corrective base for the
{                  currently active.
{
{     The following two fields taken together become the SORT_KEY,
{     or the field on which the directory is sorted.
{
{     LICENSED_PRODUCT  - Name of the licensed product that this subproduct
{                  belongs to.
{
{     SUBPRODUCT  - Name of the subproduct.
{
{
{   The RAT$INFORMATION_RECORD record contains the following fields:
{
{     DATE_INSTALLED  - Date and time the subproduct was installed.
{                  This is stored in compact date and time format.
{
{     INSTALLATION_IDENTIFIER  - Name field specifying the identifier
{                  associated with the installation of this subproduct.
{                  RAC$NOT_INSTALLED will be used as the installation
{                  identifier when the RAT$INFORMATION_RECORD is not
{                  being used.
{
{     SUBPRODUCT_LEVEL  -  The subproduct level in the notation given by
{                  the developing group.  This is a 31 character name.
{
{     INTERNAL_LEVEL  - An NOS/VE level representation used internally
{                  by NOS/VE development.  This is hidden from
{                  displays unless asked for directly.
{
{     SIF_IDENTIFIER  - A unique name that identifies the SIF used to
{                  define the subproduct referenced by this record.
{
{     PACKING_LIST  - Contains the name of the packing list file that
{                  defines the subproduct referenced by this record.
{
{     PACKING_LIST_INDEX  - Contains the index into the subproduct
{                  indexer for the subproduct referenced by this record.
{                  The subproduct indexer is found in the packing list
{                  named in the last field.
{
{

  TYPE
    rat$directory_header = record
      deferred_count: rat$directory_size,
      directory_size: rat$directory_size,
      directory_rel_p: REL (rat$idb_directory_sequence) ^rat$directory,
    recend;

  TYPE
    rat$directory = array [ * ] of rat$directory_record;

  TYPE
    rat$directory_record = record
      primary_subproduct: rat$primary_subproduct,
      description: rat$subproduct_description,
      hidden: boolean,
      subproduct_corrupted: boolean,
      base_level_installation_catalog: rat$path,
      system_catalog_path_index: 0 .. fsc$max_path_size,
      active_information: rat$information_record,
      deferred_information: rat$information_record,
      corrective_base_information: rat$information_record,
      case 1 .. 2 of
      = 1 =
        licensed_product: rat$licensed_product,
        subproduct: rat$subproduct_name,
      = 2 =
        sort_key: rat$directory_sort_key,
      casend,
    recend;

  TYPE
    rat$directory_size = rat$subproduct_count;

  TYPE
    rat$directory_sort_key = string (osc$max_name_size * 2);

  TYPE
    rat$idb_directory_sequence = SEQ ( * );

  TYPE
    rat$information_record = record
      date_installed: ost$date_time,
      installation_identifier: rat$installation_identifier,
      subproduct_level:  rat$subproduct_level,
      internal_level: rat$subproduct_internal_level,
      sif_identifier: rat$sif_identifier,
      packing_list: ost$name,
      packing_list_index: rat$subproduct_count,
    recend;

*copyc fsc$max_path_size
*copyc ost$date_time
*copyc ost$name
*copyc rat$installation_identifier
*copyc rat$licensed_product
*copyc rat$path
*copyc rat$primary_subproduct
*copyc rat$sif_identifier
*copyc rat$subproduct_count
*copyc rat$subproduct_description
*copyc rat$subproduct_internal_level
*copyc rat$subproduct_level
*copyc rat$subproduct_name

*DECK DECK=RAT$INSTALLATION_COMMANDS EXPAND=FALSE

  TYPE
    rat$installation_commands = (rac$install_product,
          rac$install_correction, rac$activate_product);
*DECK DECK=RAT$INSTALLATION_CONTROL_RECORD EXPAND=FALSE
{
{ PURPOSE:
{   The installation control record is used to manage all information
{   required to process an installation request.  The fields are defined as
{   follows:
{
{
{        JOB_IDENTIFIER  - Gives the identifier for the job that the
{            installation control record was created for.
{
{        JOB_STATUS_RECORD_P  - A pointer to the job status record in
{            the processing summary file.
{
{        PROCESSING_SEQ_P  - A pointer to the sequence where the
{            process dependent processing information is stored.
{
{        PROCESSING_HEADER_P  - A pointer to the processing header
{            record within the processing sequence.
{
{        JOB_PROCESSING_RECORDS_P  - A pointer to the array of records
{            that contain job processing information.
{
{        MEDIUM_PROCESSING_RECORDS_P  - A pointer to the array of records
{            that contain medium processing information.  There is a one
{            to one mapping between this array and the tape vsns array
{            found in the packing list when the medium format is tape.
{
{        SUBPRODUCT_PROCESSING_RECORDS_P  - A pointer to the array of records
{            that contain subproduct processing information.  There is a
{            one to one mapping between this array and the subproduct
{            indexer found in the packing list.
{
{        PACKING_LIST_POINTERS  - A record that contains the pointers
{            into the major components of the packing list used in
{            current processing.
{
{        SCRATCH_SEQ_P  - A pointer to a temporary memory sequence that
{            can be used as scratch by any procedure or interface
{            involved in processing.
{

  TYPE
    rat$installation_control_record = record
      job_identifier: rat$job_identifier,
      job_status_record_p: ^rat$job_status_record,
      processing_seq_p: ^rat$processing_sequence,
      processing_header_p: ^rat$processing_header,
      job_processing_records_p: ^rat$job_processing_records,
      medium_processing_records_p: ^rat$medium_processing_records,
      subproduct_processing_records_p: ^rat$subp_processing_records,
      packing_list_pointers: rat$packing_list_pointers,
      scratch_seq_p: ^SEQ ( * ),
    recend;

*copyc rat$processing_summary_types
*copyc rat$processing_types
*DECK DECK=RAT$INSTALLATION_DEFAULTS EXPAND=FALSE

  TYPE
    rat$installation_defaults = record
      correction_bases: rat$path,
      correction_packages: rat$path,
      installation_database: rat$path,
      installation_logs: rat$path,
      system_catalog: rat$path,
      ignore_storage_class: boolean,
      relax_ring_settings: boolean,
    recend;

*copyc rat$path
*DECK DECK=RAT$INSTALLATION_IDENTIFIER EXPAND=FALSE

  TYPE
    rat$installation_identifier = ost$name;

*copyc ost$name
*DECK DECK=RAT$INSTALLATION_PARAMETERS EXPAND=FALSE
    record
      activation_option: string 0 .. $max_name
      installation_option: string 0 .. $max_name
      packing_list: string 0..16
      evsn: string 0..6
      rvsn: string 0..6
      tape_type: string 0 .. $max_name
      save_previous_cycles: boolean
    recend ..
*DECK DECK=RAT$INSTALLATION_PATHS EXPAND=FALSE
  TYPE
    rat$installation_paths = (rac$installation_catalog_path, rac$correction_base_cat_path,
          rac$base_level_path, rac$active_level_path);







*DECK DECK=RAT$INSTALLATION_TABLE EXPAND=FALSE

*copyc rat$table_record
TYPE
  rat$installation_table = array [1..*] of rat$table_record;


*DECK DECK=RAT$INSTALLATION_TAPE_VALUES EXPAND=FALSE

  TYPE
    rat$installation_tape_values = record
      packing_list: ost$name,
      evsn: string (rmc$external_vsn_size),
      rvsn: string (rmc$recorded_vsn_size),
      tape_type: ost$name,
    recend;

*copyc rmc$external_vsn_size
*copyc rmc$recorded_vsn_size
*copyc ost$name
*DECK DECK=RAT$INST_TABLE_INDEX EXPAND=FALSE
TYPE
  rat$inst_table_index = 0..0ffff(16);

*DECK DECK=RAT$JOB_STATUS_RECORD_STRS EXPAND=FALSE

  TYPE
    rat$job_status_record_strs = record
      job_identifier: ost$string,
      log_file_name: ost$string,
      date: ost$string,
      time: ost$string,
      number_of_steps: ost$string,
      step_number: ost$string,
      step: ost$string,
      step_status: ost$string,
      initial_subproduct_count: ost$string,
      started_subproduct_count: ost$string,
      completed_subproduct_count: ost$string,
    recend;

*copyc ost$string
*DECK DECK=RAT$LICENSED_PRODUCT EXPAND=FALSE
{  NOTE:
{   If the following type declaration is ever changed determine impact on
{   RAT$DIRECTORY_SORT_KEY found in deck RAT$IDB_DIRECTORY_TYPES and update
{   as necessary.

  TYPE
    rat$licensed_product = ost$name;

*copyc ost$name
*DECK DECK=RAT$LINE_LENGTH EXPAND=FALSE

*copyc rac$max_line_size
TYPE
  rat$line_length = 1..rac$max_line_size;


*DECK DECK=RAT$MATCH_DECKS EXPAND=FALSE
  TYPE
    rat$match_decks = array [1 .. * ] of rat$match_item,

    rat$match_item = record
      name: ost$name,
      index: rat$deck_index,
    recend;

*copyc rat$deck_index
*copyc ost$name

*DECK DECK=RAT$MESSAGE_PARAMETERS EXPAND=FALSE

  CONST
    rac$max_message_parameters = 50;

  TYPE
    rat$message_parameter = string (rac$max_line);

  TYPE
    rat$message_parameters = ^array [ * ] of rat$message_parameter;

  TYPE
    rat$number_of_message_params = 0 .. rac$max_message_parameters;

*copyc rac$max_line
*DECK DECK=RAT$MONITORING_OPTIONS EXPAND=FALSE

  TYPE
    rat$monitoring_options = (rac$direct_monitoring,
          rac$indirect_monitoring);
*DECK DECK=RAT$OPEN_FILE_LIST EXPAND=FALSE
  TYPE
    rat$open_file_list = array [1 .. 2 ] of rat$open_file_item,

    rat$open_file_item = record
      name: amt$local_file_name,
      identifier: amt$file_identifier,
      attached: boolean,
      opened: boolean,
    recend;

*copyc amt$local_file_name
*copyc amt$file_identifier
*DECK DECK=RAT$ORDER_CONTENTS_LIST EXPAND=FALSE

  CONST
    rac$min_assignment_priority = 0,
    rac$max_assignment_priority = 10;

  CONST
    rac$packing_list_entry = 1;

  CONST
    rac$first_subproduct_entry = rac$packing_list_entry + 1;

  TYPE
    rat$assignment_priority = rac$min_assignment_priority ..
          rac$max_assignment_priority;

  TYPE
    rat$order_contents = record
      assignment_priority: rat$assignment_priority,
      size: rat$subproduct_size,
      position_assigned: rat$position_assigned,
      name: rat$subproduct_name,
      case contents_type: rat$order_contents_type of
      = subproduct =
        subproduct_type: rat$subproduct_type,
        level: rat$subproduct_level,
        licensed_product: rat$licensed_product,
        pacs_catalog: rat$path,
        subproduct_seq_length: amt$file_length,
        subproduct_seq_p: rat$subproduct_info_p,
        auto_install: boolean,
        sif_identifier: ost$name,
      = packing_list =
      casend,
    recend,

    rat$order_contents_list = array [ * ] of rat$order_contents;

  TYPE
    rat$order_contents_type = (packing_list, subproduct);

  TYPE
    rat$position_assigned = integer;

*copyc ost$name
*copyc rat$path
*copyc rat$subproduct_info_p
*copyc rat$subproduct_info_types
*DECK DECK=RAT$PACKING_LIST_SEQUENCE EXPAND=FALSE

  TYPE
    rat$packing_list_sequence = SEQ ( * );
*DECK DECK=RAT$PACKING_LIST_TYPES EXPAND=FALSE
{
{   This deck contains the type declarations for the packing list sequence.
{   The fields for the major components are documented here:
{
{   The RAT$PACKING_LIST_HEADER record is a variant record containing the
{   following records and fields:
{
{     ORDER_IDENTIFIER  - Identifies the order as unique name.  This value
{                  is also used as the packing list name when installed in
{                  the IDB at the site.
{
{                  Defined by user with DEFINE_ORDER.
{
{                  Used by PACS and INSS.
{
{     ORDER_TYPE  - The order type the packing list is defined for.  The
{                  possible key values are rac$release_order or
{                  rac$correction_order.
{
{                  Defined by user with DEFINE_ORDER.
{
{                  Used by PACS and INSS.
{
{     SUBPRODUCT_COUNT  - The number of subproducts in the order.  This
{                  is also the size of the subproduct indexer.
{
{                  Defined by WRITE_DEFINITION as a result of
{                  ADD_SUBPRODUCT.
{
{                  Used by PACS and INSS.
{
{     TAPE_CLASS  - The device class of the tapes for this order.
{
{                  Defined by user with DEFINE_TAPE_ATTRIBUTES.
{
{                  Used by INSS.
{
{         ** Because of compatibility reasons this field was placed here at 1.4.2.
{         Logically it belongs with the tape fields.  If or when compatibility is
{         to be broken, this field should be moved under the tape case.
{
{     TAPE_DENSITY  - The density of the tapes for this order.
{
{                  Defined by user with DEFINE_TAPE_ATTRIBUTES.
{
{                  Used by INSS.
{
{         ** Because of compatibility reasons this field was placed here at 1.4.2.
{         Logically it belongs with the tape fields.  If or when compatibility is
{         to be broken, this field should be moved under the tape case.
{
{     UNUSED  - Space available for future fields as needed.  This is
{                  described in bytes.
{
{     ORDER_MEDIUM  - The medium the order is written to.  The possible
{                  choices are rac$tape or rac$disk.
{
{                  Defined by user with DEFINE_ORDER.
{
{                  Used by PACS and INSS.
{
{
{   The following fields is available when the order medium is RAC$TAPE:
{
{     PRIMARY_TAPE_COUNT  - Number of primary tapes defined for the order.
{
{                  Defined by WRITE_DEFINITION.
{
{                  Used by INSS.
{
{     TAPE_VSNS_P  - Relative pointer to an array of rat$tape_vsn
{                  records.
{
{                  Defined by WRITE_DEFINITION.
{
{                  Used by PACS and INSS.
{
{     TAPE_SUBPRODUCT_INDEXER_P  - Relative pointer to an array of
{                  rat$tape_subproduct_index records.
{
{                  Defined by WRITE_DEFINITION as a result of
{                  ADD_SUBPRODUCT.
{
{                  Used by PACS and INSS.
{
{
{   The following fields are available when the order medium is RAC$DISK:
{
{     DISK_PATH  - The path to the disk file that contains the backup of
{                  the packing list and the disk_backup_catalog.  This
{                  field is set after the packing list is installed at
{                  the site.
{
{                  Defined by WRITE_DEFINITION.
{
{                  Used by INSS.
{
{     DISK_BACKUP_CATALOG  - The path to the catalog that was backed up
{                  to create the disk file.
{
{                  Defined by WRITE_DEFINITION.
{
{                  Used by INSS.
{
{     DISK_SUBPRODUCT_INDEXER_P  - Relative pointer to an array of
{                  rat$disk_subproduct_index records.
{
{                  Defined by WRITE_DEFINITION as a result of
{                  ADD_SUBPRODUCT.
{
{                 Used by PACS and INSS.
{
{
{   Each RAT$TAPE_VSN record contains the following fields:
{
{     EXTERNAL_VSN  - External tape label.
{
{                  Defined by user with DEFINE_TAPE_ATTRIBUTES.
{
{                  Used by INSS.
{
{     RECORDED_VSN  - Recorded tape label.  This must be the same as the
{                  recorded VSN for automatic tape recognition.
{
{                  Defined by DEFINE_TAPE_ATTRIBUTES (same value as
{                  external vsn).
{
{                  Used by INSS.
{
{     ADDITIONAL_VOLUME_P  - A relative pointer to a rat$tape_vsn record
{                  when there is an additional volume for the primary tape.
{                  The pointer is set to NIL when there are no more
{                  additional tape volumes.
{
{                  Defined by WRITE_DEFINITION.
{
{                  Used by INSS.
{
{
{   Each RAT$DISK_SUBPRODUCT_INDEX record contains the following fields:
{
{     SEQ_LENGTH  - The length of the subproduct info sequence referenced
{                  by this record.
{
{                  Defined by WRITE_DEFINITION.
{
{                  Used by INSS.
{
{     SEQ_P  - A relative pointer of type cell to the subproduct info
{                  sequence.
{
{                  Defined by WRITE_DEFINITION.
{
{                  Used by INSS.
{
{     BACKUP_FILE  - The name of the file in the disk_backup_catalog
{                  which contains the backup of the subproduct.
{
{                  Defined by WRITE_DEFINITION.
{
{                  Used by INSS.
{
{     AUTO_INSTALL  - Boolean specifying if the subproduct represented
{                  by this record is auto installed or not.
{
{                  Defined by user with ADD_SUBPRODUCT.
{
{                  Used by INSS.
{
{
{   Each RAT$TAPE_SUBPRODUCT_INDEX record contains the following fields:
{
{     SEQ_LENGTH  - The length of the subproduct info sequence referenced
{                  by this record.
{
{                  Defined by WRITE_DEFINITION.
{
{                  Used by INSS.
{
{     SEQ_P  - A relative pointer of type cell to the subproduct info
{                  sequence.
{
{                  Defined by WRITE_DEFINITION.
{
{                  Used by INSS.
{
{     PRIMARY_TAPE_VSN  - Contains the index into the rat$tape_vsns
{                  array for the tape record belonging to the tape this
{                  subproduct is associated with.
{
{                  Defined by WRITE_DEFINITION.
{
{                  Used by INSS.
{
{     TAPE_FILE_SEQUENCE_NUMBER  - The position on the tape the subproduct
{                  resides.
{
{                  Defined by WRITE_DEFINITION.
{
{                  Used by INSS.
{
{     AUTO_INSTALL  - Boolean specifying if the subproduct represented
{                  by this record is auto installed or not.
{
{                  Defined by user with ADD_SUBPRODUCT.
{
{                  Used by INSS.
{


  CONST
    rac$max_number_of_tapes = 36;

  TYPE
    rat$additional_volume_p = REL (rat$packing_list_sequence) ^rat$tape_vsn;

  TYPE
    rat$tape_count = 0 .. rac$max_number_of_tapes;

  TYPE
    rat$disk_subproduct_index = record
      subproduct_seq_length: amt$file_length,
      subproduct_seq_p: rat$subproduct_info_p,
      backup_file: ost$name,
      auto_install: boolean,
    recend,

    rat$disk_subproduct_indexer = array [ * ] of rat$disk_subproduct_index;

  TYPE
    rat$disk_subproduct_indexer_p = REL (rat$packing_list_sequence)
          ^rat$disk_subproduct_indexer;

  TYPE
    rat$file_path = string (fsc$max_path_size);

  TYPE
    rat$order_medium = (rac$tape, rac$disk);

  TYPE
    rat$packing_list_header = record
      order_identifier: ost$name,
      order_type: rat$subproduct_type,
      subproduct_count: rat$subproduct_count,
      tape_class: rmt$tape_class,
      tape_density: rmt$density,
      unused: array [1 .. 46] of cell,
      case order_medium: rat$order_medium of
      = rac$tape =
        primary_tape_count: rat$tape_count,
        tape_vsns_p: rat$tape_vsns_p,
        tape_subproduct_indexer_p: rat$tape_subproduct_indexer_p,
      = rac$disk =
        disk_path: rat$file_path,
        disk_backup_catalog: rat$file_path,
        disk_subproduct_indexer_p: rat$disk_subproduct_indexer_p,
      casend,
    recend;

  TYPE
    rat$release_level = string (6);

  TYPE
    rat$tape_subproduct_index = record
      subproduct_seq_length: amt$file_length,
      subproduct_seq_p: rat$subproduct_info_p,
      primary_tape_vsn: rat$tape_count,
      tape_file_sequence_number: 1 .. 9999,
      auto_install: boolean,
    recend,

    rat$tape_subproduct_indexer = array [ * ] of rat$tape_subproduct_index;

  TYPE
    rat$tape_subproduct_indexer_p = REL (rat$packing_list_sequence)
          ^rat$tape_subproduct_indexer;

  TYPE
    rat$tape_vsn = record
      external_vsn: rmt$external_vsn,
      recorded_vsn: rmt$recorded_vsn,
      additional_volume_p: rat$additional_volume_p,
    recend;

  TYPE
    rat$tape_vsns = array [ * ] of rat$tape_vsn;

  TYPE
    rat$tape_vsns_p = REL (rat$packing_list_sequence) ^rat$tape_vsns;

*copyc fsc$max_path_size
*copyc amt$file_length
*copyc ost$name
*copyc rat$packing_list_sequence
*copyc rat$subproduct_count
*copyc rat$subproduct_info_p
*copyc rat$subproduct_type
*copyc rmt$density
*copyc rmt$external_vsn
*copyc rmt$recorded_vsn
*copyc rmt$tape_class

*DECK DECK=RAT$PATH EXPAND=FALSE

  TYPE
    rat$path = record
      size: integer,  {This is declared as an integer for usage in STRINGREP.}
      path: fst$path,
    recend;

*copyc fst$path
*DECK DECK=RAT$PATH_LENGTH EXPAND=FALSE

*copyc rac$max_path_size
TYPE
  rat$path_length = 1..rac$max_path_size;


*DECK DECK=RAT$PERCENT_OF_TAPE_USABLE EXPAND=FALSE

  TYPE
    rat$percent_of_tape_usable = 1 .. 100;
*DECK DECK=RAT$PRIMARY_SUBPRODUCT EXPAND=FALSE

  TYPE
    rat$primary_subproduct = boolean;
*DECK DECK=RAT$PROCESSING_SUMMARY_TYPES EXPAND=FALSE
{
{ PURPOSE:
{   This deck contains the type declarations for the processing summary
{   sequence.  The processing summary sequence contains summary information
{   regarding each job involved in processing an installation event.
{
{   The fields are defined as follows:
{
{       JOB_IDENTIFIER  - The unique identifier for the job this record
{           is for.
{
{       LOG_FILE_NAME  - The name of the file to where the job log will be
{           written.
{
{       DATE_TIME  - The date and time the last entry was made.  This
{           is in compact format.
{
{       NUMBER_OF_STEPS  - The number of steps to be performed by this job.
{
{       STEP_NUMBER  - The current step number the job is processing.
{
{       STEP  - The ordinal value for the current step the job is processing.
{
{       STEP_STATUS  - The status for the current step at the time the last
{           entry was made.
{
{       INITIAL_SUBPRODUCT_COUNT  - The initial number of products to be
{           processed.
{
{       STARTED_SUBPRODUCT_COUNT  - The number of subproducts for which
{           processing was started for the current step.
{
{       COMPLETED_SUBPRODUCT_COUNT  - The number of subproducts for which
{           processing has completed successfully for the current step.
{

  TYPE
    rat$job_status_record = record
      job_identifier: rat$job_identifier,
      log_file_name: rat$log_file_name,
      date_time: ost$date_time,
      number_of_steps: rat$step_count,
      step_number: rat$step_count,
      step: rat$steps,
      step_status: rat$step_status,
      initial_subproduct_count: rat$subproduct_count,
      started_subproduct_count: rat$subproduct_count,
      completed_subproduct_count: rat$subproduct_count,
    recend;

  TYPE
    rat$job_status_records = array [ * ] of rat$job_status_record;

  TYPE
    rat$job_status_records_rel_p = REL (rat$processing_summary_sequence)
          ^rat$job_status_records;

  TYPE
    rat$processing_summary_header = record
      job_count: rat$job_count,
      job_status_records_rel_p: rat$job_status_records_rel_p,
    recend;

  TYPE
    rat$processing_summary_sequence = SEQ ( * );

*copyc ost$date_time
*copyc rat$processing_types

*DECK DECK=RAT$PROCESSING_TYPES EXPAND=FALSE
{
{  PURPOSE:
{   This deck contains the type declarations for the processing sequence.
{   The processing sequence contains the information required in
{   installation processing.  The major components of the processing
{   sequence are the header record and the job, medium and subproduct
{   processing records.
{
{   In addition to the just mentioned components, the packing list pointers
{   and the installation catalog paths for the subproducts are stored in
{   the processing sequence.
{
{   An installation control record is used to access the different
{   components found in the processing sequence during processing.
{
{   The processing header contains the following fields:
{
{        INSTALLATION_IDENTIFIER  - A unique identifier assigned to
{            the installation event.   This is used for communication
{            between the user and the processing jobs.
{
{        INSTALLATION_COMMAND  - Gives the identifier for the command
{            that initiated the installation event.
{
{        COMMAND_COMPATIBLE_TYPES - Gives the subproduct type the
{            installation command can process.
{
{        INSTALLATION_DEFAULTS  - A copy of the installation
{            defaults at the time the installation event was requested.
{            This allows the evironment to be recreated in any batch job.
{
{        PACKING_LIST_NAME  - The name of the packing list being used
{            for this installation event.
{
{        PACKING_LIST_SEQ_REL_P  - The relative pointer to the packing list
{            when it is included as part of the processing sequence.  This
{            only occurs when the packing list must be modified for processing.
{            The pointer is set to NIL when the packing list is not part of
{            the processing sequence.
{
{        PACKING_LIST_SEQ_SIZE  - The size of the packing list in bytes.
{            This field is only meaningful when the packing list is included
{            as part of the processing sequence.
{
{        JOB_PROCESSING_REC_REL_P  - A relative pointer to the job processing
{            records.  This is used for locating the section when the
{            processing sequence is taken from a file.
{
{        MEDIUM_PROCESSING_REC_REL_P  - A relative pointer to the medium
{            processing records.  This is used for locating the section
{            when the processing sequence is taken from a file.
{
{        SUBPRODUCT_PROCESSING_REC_REL_P  - A relative pointer to the
{            subproduct processing records.  This is used for locating
{            the section when the processing sequence is taken from a file.
{
{        NUMBER_OF_STEPS  - The number of steps to be performed by this installation
{            event.
{
{        STEP_SET  - The set of steps to be performed.
{
{        SAVE_PREVIOUS_CYCLES  - Stores the boolean value of whether or not to save
{            previous cycles set on the originating command.  This field is used to
{            pass this information on to the activate command in a deferred situation.
{

  CONST
    rac$max_number_of_steps = 8;

  TYPE
    rat$job_count = rat$tape_count;

  TYPE
    rat$job_identifier = ost$name;

  TYPE
    rat$job_processing_rec_rel_p = REL (rat$processing_sequence)
          ^rat$job_processing_records;

  TYPE
    rat$job_processing_record = record
      job_identifier: rat$job_identifier,
      log_file_name: rat$log_file_name,
    recend,

    rat$job_processing_records = array [ * ] of
          rat$job_processing_record;

  TYPE
    rat$log_file_name = ost$name;

  TYPE
    rat$medium_processing_rec_rel_p = REL (rat$processing_sequence)
          ^rat$medium_processing_records;

  TYPE
    rat$medium_processing_record = record
      job_identifier: rat$job_identifier,
      subproduct_count: rat$subproduct_count,
    recend,

    rat$medium_processing_records = array [ * ] of
          rat$medium_processing_record;

  TYPE
    rat$packing_list_pointers = record
      sequence_p: ^rat$packing_list_sequence,
      sequence_descriptor_p: ^rat$sequence_descriptor,
      header_p: ^rat$packing_list_header,
      case order_medium: rat$order_medium of
      = rac$tape =
        tape_subproduct_indexer_p: ^rat$tape_subproduct_indexer,
        tape_vsns_p: ^rat$tape_vsns,
      = rac$disk =
        disk_subproduct_indexer_p: ^rat$disk_subproduct_indexer,
      casend,
    recend;

  TYPE
    rat$processing_header = record
      installation_identifier: rat$installation_identifier,
      installation_command: rat$installation_commands,
      command_compatible_type: rat$subproduct_type,
      installation_defaults: rat$installation_defaults,
      packing_list_name: ost$name,
      packing_list_seq_rel_p: REL (rat$processing_sequence)
            ^rat$packing_list_sequence,
      packing_list_seq_size: amt$file_length,
      job_processing_rec_rel_p: rat$job_processing_rec_rel_p,
      medium_processing_rec_rel_p: rat$medium_processing_rec_rel_p,
      subproduct_processing_rec_rel_p: rat$subp_processing_rec_rel_p,
      number_of_steps: rat$step_count,
      step_set: rat$step_selections,
      save_previous_cycles: boolean,
    recend;

  TYPE
    rat$processing_sequence = SEQ ( * );

  TYPE
    rat$step_count = 0 .. rac$max_number_of_steps;

  TYPE
    rat$steps = (rac$null_step, rac$reconcile_subproducts_step,
          rac$load_subproducts_step, rac$correct_subproducts_step,
          rac$stage_subproducts_step, rac$activate_subproducts_step,
          rac$execute_installer_proc_step, rac$update_directory_step,
          rac$delete_previous_cycles_step);

  TYPE
    rat$step_selections = set of rac$reconcile_subproducts_step ..
          rac$delete_previous_cycles_step;

  TYPE
    rat$step_status = (rac$step_started, rac$step_completed);

  TYPE
    rat$subp_processing_record = record
      job_identifier: rat$job_identifier,
      product_reference: rat$product_references,
      task_set: rat$task_selections,
      task: rat$tasks,
      task_status: rat$task_status,
      subproduct_info_pointers: rat$subproduct_info_pointers,
      installation_catalog_p: ^pft$path,
      installation_catalog_rel_p: REL (rat$processing_sequence) ^pft$path,
      active_level_catalog_rel_p: REL (rat$processing_sequence) ^pft$path,
      base_level_catalog_rel_p: REL (rat$processing_sequence) ^pft$path,
      correction_base_catalog_rel_p: REL (rat$processing_sequence) ^pft$path,
    recend,

    rat$subp_processing_records = array [ * ] of rat$subp_processing_record;

  TYPE
    rat$subp_processing_rec_rel_p = REL (rat$processing_sequence)
          ^rat$subp_processing_records;

  TYPE
    rat$tasks = (rac$null_task, rac$reconcile_file_cycles_task,
          rac$load_files_task, rac$correct_files_task, rac$stage_files_task,
          rac$activate_files_task, rac$execute_installer_proc_task,
          rac$update_directory_task, rac$delete_previous_cycles_task);

{  The positions of the ordinals in rat$tasks must not be altered.
{  This order reflects processing relationship.


  TYPE
    rat$task_selections = set of rac$reconcile_file_cycles_task ..
          rac$delete_previous_cycles_task;

  TYPE
    rat$task_status = (rac$task_started, rac$task_completed, rac$task_failed);

*copyc pfd$permanent_file_definitions
*copyc amt$file_length
*copyc ost$name
*copyc rat$subproduct_info_pointers
*copyc rat$idb_directory_types
*copyc rat$installation_commands
*copyc rat$installation_defaults
*copyc rat$installation_identifier
*copyc rat$packing_list_sequence
*copyc rat$packing_list_types
*copyc rat$product_references
*DECK DECK=RAT$PRODUCT_REFERENCES EXPAND=FALSE

  TYPE
    rat$product_references = (rac$not_referenced, rac$licensed_product,
          rac$subproduct, rac$group, rac$excluded);

*DECK DECK=RAT$PROMPTING_OPTIONS EXPAND=FALSE

  TYPE
    rat$prompting_options = set of (rac$allow_go, rac$allow_null, rac$allow_quit, rac$clear_screen,
                                    rac$confirm_selection);
*DECK DECK=RAT$PSR_INFO EXPAND=FALSE
  TYPE
    rat$psr_info = record
      ident: string (8),
      element: string (31),
    recend;

*DECK DECK=RAT$RING_INDEX EXPAND=FALSE

TYPE
  rat$ring_index = 1..3;


*DECK DECK=RAT$RING_VALUES EXPAND=FALSE

TYPE
  rat$ring_values = 1..15;


*DECK DECK=RAT$SCL_STRING_VALUE EXPAND=FALSE

*copyc ost$string

TYPE
  rat$scl_string_value = RECORD
            CASE 1 .. 2 OF
            = 1 =
              cell_access: array [1 .. (2 + osc$max_string_size)] of cell,
            = 2 =
              string_access: array [1 .. 1] of ost$string,
            CASEND,
          RECEND;
*DECK DECK=RAT$SCRATCH_SEGMENT EXPAND=FALSE

  TYPE
    rat$scratch_segment = record
      sequence_p: ^SEQ ( * ),
      reset_p: ^cell,
    recend;

*DECK DECK=RAT$SEQUENCE_DESCRIPTOR_TYPES EXPAND=FALSE

{ PURPOSE:
{   These types are used to define a SEQUENCE DESCRIPTOR.
{
{      The Sequence Descriptor record contains the following fields:
{
{        PROCESSOR_VERSION  - The version and creation date of the PACS/INSS
{                     used to build the sequence.
{
{        SEQUENCE_CREATION_DATE_TIME  - The creation date/time for the sequence.
{
{        SEQUENCE_LEVEL  - The level of the data structures contained in the
{                     sequence.  The level identifies changes in the type
{                     declarations used in creating the data structures.
{                     This field is important in understanding how to access
{                     the information within the sequence.
{
{        SEQUENCE_TYPE  - The type of sequence the descriptor is for
{                     (rac$subproduct_info_sequence,
{                     rac$packing_list_sequence,
{                     rac$idb_directory_sequence or
{                     rac$processing_summary_sequence).
{

  TYPE
    rat$processor_version = string (31);

  TYPE
    rat$sequence_descriptor = record
      processor_version: rat$processor_version,
      sequence_creation_date_time: rat$date_time,
      sequence_level: rat$sequence_level,
      sequence_type: rat$sequence_type,
    recend;

  TYPE
    rat$sequence_level = string (31);

  TYPE
    rat$sequence_type = (rac$subproduct_info_sequence,
          rac$packing_list_sequence, rac$idb_directory_sequence,
          rac$processing_summary_sequence);

*copyc rat$date_time
*DECK DECK=RAT$SIF_IDENTIFIER EXPAND=FALSE

  TYPE
    rat$sif_identifier = ost$name;

*copyc ost$name
*DECK DECK=RAT$SINGLE_CORRECTION_HEADER EXPAND=FALSE
  TYPE
    rat$single_correction_header = record
      user_information: amt$user_info,
      size_of_correction: rat$corrector_size,
    recend;

*copyc amd$file_attributes
*copyc rat$corrector_size
*DECK DECK=RAT$SOURCE_LIB_CORRECTION_HDR EXPAND=FALSE
  TYPE
    rat$source_lib_correction_hdr = record
      decks_to_delete: rat$deck_index,
      decks_to_insert: rat$deck_index,
      size_of_replacement: rat$corrector_size,
    recend;

*copyc ost$name
*copyc rat$deck_index
*copyc rat$corrector_size

*DECK DECK=RAT$STORAGE_CLASS EXPAND=FALSE

  TYPE
    rat$storage_class = ost$name;
*DECK DECK=RAT$STRING EXPAND=FALSE

  TYPE
    rat$string = record
      value: string (osc$max_string_size),
      length: integer,
    recend;

*copyc ost$string

*DECK DECK=RAT$SUBPRODUCT_COUNT EXPAND=FALSE

  CONST
    rac$max_number_of_subproducts = 500;

  TYPE
    rat$subproduct_count = 0 .. rac$max_number_of_subproducts;

*DECK DECK=RAT$SUBPRODUCT_DESCRIPTION EXPAND=FALSE

  CONST
    rac$max_description_size = 50;

  TYPE
    rat$subproduct_description = string (rac$max_description_size);
*DECK DECK=RAT$SUBPRODUCT_INFO_P EXPAND=FALSE

  TYPE
    rat$subproduct_info_p = REL (rat$packing_list_sequence) ^cell;

*copyc rat$packing_list_sequence
*DECK DECK=RAT$SUBPRODUCT_INFO_POINTERS EXPAND=FALSE

  TYPE
    rat$subproduct_info_pointers = record
      sequence_descriptor_p: ^rat$sequence_descriptor,
      subproduct_info_seq_p: ^rat$subproduct_info_sequence,
      info_header_p: ^rat$subproduct_info_header,
      attributes_p: ^rat$subproduct_attributes,
      element_list_p: ^rat$element,
      path_container_p: ^rat$path_container,
      psrs_answered_p: ^rat$psrs_answered,
    recend;


*copyc rat$sequence_descriptor_types
*copyc rat$subproduct_info_types
*DECK DECK=RAT$SUBPRODUCT_INFO_TYPES EXPAND=FALSE
{
{ PURPOSE:
{   These types are used to define a SUBPRODUCT INFORMATION FILE.
{
{      RAT$SUBPRODUCT_INFO_HEADER record contains the following fields:
{
{        ATTRIBUTES_P  - Relative pointer to the record containing
{                     subproduct attributes.
{
{                     Defined by DEFINE_SUBPRODUCT.
{
{                     Used by INSS.
{
{        ELEMENT_LIST_P  - Relative pointer to the first element that makes
{                     up the element list.
{
{                     Defined by DEFINE_SUBPRODUCT.
{
{                     Used by INSS.
{
{
{        PATH_CONTAINER_LENGTH  - The length of the path container.
{
{                     Defined by QUIT for DEFINE_SUBPRODUCT utility.
{
{                     Used by INSS.
{
{        PATH_CONTAINER_P  - Relative pointer to an array containing the
{                     names that form paths critical to installation.  The
{                     path container contains the installation catalog path,
{                     and optionally defined installer procedure path and/or
{                     library merge paths.
{
{                     Defined by QUIT for DEFINE_SUBPRODUCT utility.
{
{                     Used by INSS.
{
{        PSRS_ANSWERED_COUNT  - The number of PSR answered by this
{                     correction (if this does represent a correction to a
{                     subproduct).  This is not a required field.
{
{                     Defined by DEFINE_PSRS_ANSWERED.
{
{                     Used by INSS.
{
{        PSRS_ANSWERED_P  - Relative pointer to an array containing
{                     names of PSRs answered by this correction.  This is
{                     not a required field.
{
{                     Defined by user with DEFINE_PSRS_ANSWERED.
{
{                     Used by INSS.
{
{
{   The RAT$SUBPRODUCT_ATTRIBUTES record contains the following fields:
{
{
{        ADDITIONAL_PRODUCTS  - List of names of other licensed products
{                     this subproduct can be associated with.  This list is
{                     in addition to the LICENSED_PRODUCT field.  This is a
{                     31 character field.
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{
{                     Used by SMD and INSS.
{
{        AUTO_INSTALL  - Boolean value that when set to true indicates that
{                     this subproduct is automatically installed without
{                     directly naming the subproduct.  If false the
{                     subproduct can only be installed by specifying the
{                     subproduct by name.
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{
{                     Used by INSS.
{
{
{        CALCULATE_CONTENTS_CHECKSUM - Boolean value that indicates if the
{                     contents checksum should be calculated.
{
{
{        CATALOG_PERMIT  - A record defining the public access and share
{                     modes and application information allowed for the
{                     contents of the installation catalog.  Permits are not
{                     required to be defined.  If none given, none will be
{                     created.
{
{                     Defined by user with DEFINE_CATALOG_PERMITS.
{
{                     Used by INSS.
{
{        CORRECTION_BASE_LEVEL  - The subproduct level used as the base to
{                     apply against when this subproduct record represents a
{                     correction.  This is in the same format as the
{                     subproduct LEVEL field.  This field is ignored when
{                     the SUBPRODUCT_TYPE is release.
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{
{                     Used by INSS.
{
{        CORRECTION_BASE_SIF_IDENTIFIER  - The sif identifier from the base PACS
{                     catalog.  This should only be set when this PACS catalog
{                     was created by CREATE SUBPRODUCT CORRECTION.
{
{                     Copied from the base level PACS catalog during CREATE SUBPRODUCT CORRECTION.
{
{                     Used by CREATE SUBPRODUCT CORRECTION.
{
{        (subproduct_)DATE_LEVEL  - A julian date that indicates the
{                     subproduct's time line relationship between this level
{                     and other levels of this subproduct.
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{
{                     Used by INSS.
{
{        (subproduct_)DEPENDENCIES  -  List of names of licensed products
{                     and/or subproducts this subproduct is dependent upon
{                     in regrades to installation.
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{
{                     Used by INSS.
{
{        (subproduct_)NAME  - Name of the subproduct.  This is a 31
{                     character name field.
{
{                     Defined by user with DEFINE_SUBPRODUCT.
{
{                     Used by SMD and INSS.
{
{        DESCRIPTION  - A string value description of the subproduct.
{                     If the subproduct is defined as the primary subproduct
{                     of a licensed product this description applies for the
{                     licensed product as well.
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{
{                     Used by INSS and PACS display commands.
{
{        DEVELOPMENT_GROUP  - The name of the group responsible for the
{                     subproducts development.
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{
{                     Use by (unknown).
{
{                     Used by PACS.
{
{        FIRST_LEVEL_ELEMENT_COUNT  - Number of elements that are contained
{                     directly under the installation catalog.  An element
{                     can either be a catalog or a file.
{
{                     Defined by DEFINE_SUBPRODUCT.
{
{                     Used by PACS and INSS.
{
{        FILES_STAMPED  - Boolean that signifies if the user information
{                     (UI) field of the subproduct's files has been used to
{                     identify the files.  The value stored in the UI is the
{                     contents of the subproduct LEVEL field.
{
{                     All the files in the PACS catalog will automatically
{                     be stamped when the STAMP_FILES parameter is
{                     specified TRUE on the DEFINE_SUBPRODUCT_ATTRIBUTES
{                     subcommand.
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{                     All the files in the PACS catalog will automatically
{                     be stamped stam when the STAMP_FILES parameter is
{                     specified TRUE on the DEFINE_SUBPRODUCT_ATTRIBUTES
{                     subcommand.
{
{                     Used by INSS.
{
{        HIDDEN(_subproduct)  - Boolean value that when set to true will
{                     cause the subproduct to not be processed in any way
{                     unless the subproduct is named directly.
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{
{                     Used by INSS.
{
{        INSTALLATION_SCHEME  - Describes the installation scheme used for
{                     the subproduct type (rac$release or rac$correction)
{                     as either rac$cycle_based, rac$catalog_based or
{                     rac$version_based.  This field is important for
{                     managing the active directory.
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{
{                     Used by INSS.
{
{        INSTALLATION_PATH  - A record containing the index and length into
{                     the path container for the subproduct's installation
{                     path.  The installation path defines the catalog that
{                     is the lowest level subcatalog that still contains all
{                     of the subproduct's files and subcatalogs as defined
{                     by the element list.  The first 2 names in the
{                     container are the master catalog which may be user
{                     definable (see INSTALLATION_PATH_OPTION).
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{
{                     Used by INSS.
{
{        INSTALLATION_PATH_OPTION  - Contains the option given (or required
{                     of) the user regarding the subproduct's
{                     INSTALLATION_PATH.   The user may be allowed (or
{                     required) to define the master catalog, define the
{                     family name or define the user name.
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{
{                     Used by INSS.
{
{        INSTALLER_PROCEDURE  - A record containing the index and length
{                     into the path container for the path to the
{                     subproduct's installation procedure.  The path
{                     contains only that part of the path that is not the
{                     same as the INSTALLATION_PATH (it is appended
{                     to the installation path at time of
{                     execution).  The path will also include the command
{                     procedure name or program descriptor).  If an
{                     INSTALLER_PROCEDURE is not defined the values will be
{                     set to 0.
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{
{                     Used by INSS.
{
{        (subproduct_)INTERNAL_LEVEL  - An NOS/VE level representation used
{                     internally by NOS/VE development.  This is hidden from
{                     displays unless asked for directly.
{
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{
{                     Used by NOS/VE development.
{
{        (subproduct_)LEVEL  - The subproduct level in the notation given by
{                     the developing group.  This is a 31 character name.
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{
{                     Used by SMD and INSS.
{
{        LICENSED_PRODUCT  - Name of the licensed product that this
{                     subproduct belongs to.
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{
{                     Used by SMD and INSS.
{
{         (subproduct)NAME  - A string containing the name of the subproduct.
{
{                     Defined by user with DEFINE_SUBPRODUCT.
{
{                     Used by INSS.
{
{        PACS_CATALOG_PATH  - A record containing the path to the PACS catalog
{                     and the length of the path.
{
{                     Defined by user with DEFINE_SUBPRODUCT.
{
{                     Used by INSS.
{
{        PRIMARY(_subproduct)  - Boolean value defining the subproduct as
{                     the representative for the licensed product.  (Used for
{                     displaying the level of the licensed product.)
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{
{                     Used by INSS.
{
{        PRODUCT_FILE_SIZE  - The total file space used by files that
{                     are of storage class type PRODUCT.
{
{                     Calculated by DEFINE_SUBPRODUCT and DEFINE_STORAGE_CLASS.
{
{                     Used by PACS and INSS.
{
{        SERVICE_CRITICAL_FILE_SIZE  - The total file space used by files that
{                     are of storage class type SERVICE CRITICAL.
{
{                     Calculated by DEFINE_SUBPRODUCT and DEFINE_STORAGE_CLASS.
{
{                     Used by PACS and INSS.
{
{        SIF_IDENTIFIER - A unique name that is assigned to each
{                     SUBPRODUCT INFORMATION FILE.
{
{        (subproduct_)SIZE  - Disk space in bytes required to load the
{                     subproduct.  This is the size of the backup file of
{                     the PACS catalog.  This is required for building the
{                     release materials.
{
{                     Calculated by DEFINE_SUBPRODUCT.
{
{                     Used by PACS and INSS.
{
{        SUBPRODUCT_ELEMENT_COUNT - Total number of files and catalogs in the element list.
{
{                     Calculated by DEFINE_SUBPRODUCT.
{
{                     Used by CRESC.
{
{
{        SUBPRODUCT_PRIORITY  - Defines the subproduct's relative importance
{                     to the installation process.  If a file is needed early
{                     in the installation process to load other products it
{                     should be given a high priority.
{
{                     Defined by user with DEFINE_SUBPRODUCT_ATTRIBUTES.
{
{                     Used by SMD and INSS.
{
{        SUBPRODUCT_TYPE  - Defines the subproduct's type as being a
{                     rac$release, rac$correction.
{
{                     Defined by user with DEFINE_SUBPRODUCT.
{
{                     Used by SMD and INSS.
{
{        UNUSED  - Space available for future fields as needed.  This is
{                     described in bytes.
{
{
{      RAT$ELEMENT record is a variant record containing the following
{      fields:
{
{
{        (element_)NAME  - The name of the element the record is defined
{                     for.
{
{                     Defined by DEFINE_SUBPRODUCT.
{
{                     Used by PACS and INSS.
{
{        PERMIT  - Record defining the public access and share modes
{                     and any application information allowed.
{
{                     Defined by user with either DEFINE_CATALOG_PERMITS or
{                     DEFINE_FILE_PERMITS depending on element type.
{
{                     Used by INSS.
{
{        ACTIVE_ELEMENT - Boolean indicating if the element represents
{                     an actual catalog or file in the PACS catalog. If the
{                     element is not active, then there is no corresponding file
{                     or catalog in the PACS catalog.  Currently, only
{                     subproduct corrections using a version based installation
{                     contain active elements.  Inactive elements are not
{                     staged/activated by INSTALL_SOFTWARE.
{
{                     Set to TRUE (always) by CREATE_ELEMENT_LIST.  Set FALSE
{                     if appropriate by GENERATE_CORRECTION.  Manipulated by
{                     VALIDATE_FOR_CORRECTION of INSTALL_SOFTWARE.
{
{                     Used by PACS and INSS.
{
{        NEXT_ELEMENT_ACROSS_P  - Relative pointer to the next
{                     element at the current catalog level.
{
{                     Defined by DEFINE_SUBPRODUCT.
{
{                     Used by PACS and INSS.
{
{        ELEMENT_TYPE  - The element's type as either rac$catalog or
{                     rac$file.
{
{                     Defined by DEFINE_SUBPRODUCT.
{
{                     Used by PACS and INSS.
{
{
{        The following fields are available when the element type is
{        rac$catalog:
{
{
{        ELEMENT_COUNT  - Number of elements contained in the
{                     catalog.
{
{                     Defined by DEFINE_SUBPRODUCT.
{
{                     Used by PACS and INSS.
{
{
{        FIRST_ELEMENT_DOWN_P  - Relative pointer to the first element under
{                     the catalog defined by the element record.
{
{                     Defined by DEFINE_SUBPRODUCT.
{
{                     Used by PACS and INSS.
{
{        The following fields are available when the element type is
{        RAC$FILE:
{
{
{        (file_)CONTENTS_CHECKSUM  - Checksum of the contents of this subproduct file.
{
{                     Defined by DEFINE_SUBPRODUCT.
{
{                     Used by PACS and INSS.
{
{        (file_)CORRECTION_BASE_CONTENTS_CKSUM  - Checksum of the contents of the
{                     base file for this correction.  Copied by CREATE SUBPRODUCT CORRECTION
{                     from the base level subproduct information file to the new
{                     subproduct information file.
{
{                     Used by CREATE SUBPRODUCT CORRECTION.
{
{        (file_)ATTRIBUTES_CHECKSUM  - Checksum of the attributes of this subproduct file.
{
{                     Defined by DEFINE_SUBPRODUCT.
{
{                     Used by PACS and INSS.
{
{        (file_)PRE_GENC_CONTENTS_CHECKSUM  - Checksum of the contents of this subproduct file
{                     before GENERATE CORRECTION was used to create a correction file for this
{                     subproduct.
{
{                     Defined by DEFINE_SUBPRODUCT and moved to this location by GENERATE CORRECTION.
{
{                     Used by CRESC and INSS.
{
{        (file_)SIZE  - Size of the file (in bytes).  Used in building
{                     release materials.
{
{                     Defined by DEFINE_SUBPRODUCT.
{
{                     Used by PACS and INSS.
{
{        STORAGE_CLASS  - Storage class to which the file will be installed
{                     when activated.
{
{                     Defined by user with DEFINE_STORAGE_CLASS.
{
{                     Used by INSS.
{
{        RING_ATTRIBUTES  - Ring attributes to which the files will be set
{                     when the file is stagged.
{
{                     Defined by user with DEFINE_RING_ATTRIBUTES.
{
{                     Used by INSS.
{
{        CORRECTION_DIRECTIVES - A set which is used to direct correcting
{                     this element.
{
{                     Set to the empty set by CREATE_ELEMENT_LIST.
{                     Updated in VALIDATE_FOR_CORRECTION of INSTALL_SOFTWARE.
{
{                     Used by INSS.
{
{        CORRECTION_FORMAT  - File format for applying the correction if
{                     file represents a correction.  The formats are rac$corr_format_not_defined
{                     rac$object_library, rac$source_library or
{                     rac$replacement.  This is only required for subproduct's
{                     with SUBPRODUCT_TYPE defined as rac$correction.
{
{                     Defined by CREATE_ELEMENT_LIST.
{                     May be redefined by user with DEFINE_CORRECTION_FORMAT.
{
{                     Used by INSS.
{
{        FILE_CONTENTS_AND_STRUCTURE - The file contents and structure of a
{                     file.  The formats are rac$object, rac$source_library
{                     and rac$replacement.  Rac$replacement is used if neither
{                     rac$object_library or rac$source_library is correct.
{
{                     Defined in CREATE_ELEMENT_LIST.
{
{                     Used by DEFINE_CORRECTION_FORMAT.
{
{        LIBRARY_MERGE  - A record containing the index and length into the
{                     path container for the path to the library that the
{                     file will be merged with (if a library merge is
{                     required).  If a LIBRARY_MERGE is not defined the
{                     values will be set to 0.
{
{                     Defined by user with DEFINE_LIBRARY_MERGE.
{
{                     Used by INSS.
{

  CONST
    rac$max_additional_products = 5,
    rac$max_dependencies = 5,
    rac$max_path_container_length = 0ffffffff(16),
    rac$max_psr_count = 1000,
    rac$psr_name_length = 7;

  TYPE
    rat$additional_products = array [1 .. rac$max_additional_products] of
          ost$name;

  TYPE
    rat$checksum = integer;

  TYPE
    rat$correction_directive_types = (rac$use_base_level_catalog,
          rac$use_correction_base_catalog, rac$use_previous_correction,
          rac$use_release_file, rac$use_replacement_file);

  TYPE
    rat$correction_directives = set of rat$correction_directive_types;

  TYPE
    rat$correction_format = (rac$object_library, rac$source_library,
          rac$replacement);
  TYPE
    rat$psr = string (rac$psr_name_length);

  TYPE
    rat$psrs_answered_count = 0 .. rac$max_psr_count;

  TYPE
    rat$psrs_answered = array [ * ] of rat$psr;

  TYPE
    rat$psrs_answered_p = REL (rat$subproduct_info_sequence)
          ^rat$psrs_answered;

  TYPE
    rat$development_group = string (31);

  TYPE
    rat$element = record
      name: ost$name,
      permit: rat$permit,
      active_element: boolean,
      next_element_across_p: rat$element_p,
      case element_type: rat$element_type of
      = rac$catalog =
        element_count: rat$element_count,
        first_element_down_p: rat$element_p,
      = rac$file =
        attributes_checksum: rat$checksum,
        contents_checksum: rat$checksum,
        correction_base_contents_cksum: rat$checksum,
        correction_directives: rat$correction_directives,
        correction_format: rat$correction_format,
        file_contents_and_structure: rat$correction_format,
        library_merge: rat$path_container_indexer,
        modification_date_time: ost$date_time,
        pre_genc_contents_checksum: rat$checksum,
        ring_attributes: rat$ring_attributes,
        size: amt$file_length,
        storage_class: rmt$mass_storage_class,
      casend,
    recend;

  TYPE
    rat$element_count = integer;

  TYPE
    rat$element_list_p = REL (rat$subproduct_info_sequence)
          ^rat$element;

  TYPE
    rat$element_p = REL (rat$subproduct_info_sequence) ^rat$element;

  TYPE
    rat$element_type = (rac$catalog, rac$file);

  TYPE
    rat$installation_path_option = (rac$not_definable,
          rac$definable_master_catalog, rac$definable_family_name,
          rac$definable_user_name);

  TYPE
    rat$installation_scheme = (rac$cycle_based, rac$catalog_based,
          rac$version_based);

  TYPE
    rat$path_container = array [ * ] of ost$name;

  TYPE
    rat$path_container_index = 0 .. rac$max_path_container_length;

  TYPE
    rat$path_container_indexer = record
      path_container_index: rat$path_container_index,
      path_length: rat$path_container_length,
    recend;

  TYPE
    rat$path_container_length = 0 .. rac$max_path_container_length;

  TYPE
    rat$path_container_p = REL (rat$subproduct_info_sequence)
          ^rat$path_container;

  TYPE
    rat$permit = record
      defined: boolean,
      permit_selections: pft$permit_selections,
      share_requirements: pft$share_requirements,
      application_info: pft$application_info,
    recend;

  TYPE
    rat$ring_attributes = record
      r1: ost$ring,
      r2: ost$ring,
      r3: ost$ring,
    recend;

  TYPE
    rat$subproduct_attributes = record
      additional_products: rat$additional_products,
      auto_install: boolean,
      calculate_contents_checksum: boolean,
      catalog_permit: rat$permit,
      correction_base_level: rat$subproduct_level,
      correction_base_sif_identifier: rat$sif_identifier,
      date_level: rat$subproduct_date_level,
      dependencies: rat$subproduct_dependencies,
      description: rat$subproduct_description,
      development_group: rat$development_group,
      first_level_element_count: rat$element_count,
      files_stamped: boolean,
      hidden: boolean,
      installation_scheme: rat$installation_scheme,
      installation_path: rat$path_container_indexer,
      installation_path_option: rat$installation_path_option,
      installer_procedure: rat$path_container_indexer,
      internal_level: rat$subproduct_internal_level,
      level: rat$subproduct_level,
      licensed_product: rat$licensed_product,
      name: rat$subproduct_name,
      pacs_catalog_path: rat$path,
      primary: rat$primary_subproduct,
      product_file_size: rat$subproduct_size,
      service_critical_file_size: rat$subproduct_size,
      sif_identifier: rat$sif_identifier,
      size: rat$subproduct_size,
      subproduct_element_count: rat$subproduct_element_count,
      subproduct_priority: rat$subproduct_priority,
      subproduct_type: rat$subproduct_type,
      user_permanent_file_size: rat$subproduct_size,
      unused: array [1 .. 47] of cell,
    recend;

  TYPE
    rat$subproduct_attributes_p = REL (rat$subproduct_info_sequence)
          ^rat$subproduct_attributes;

  TYPE
    rat$subproduct_date_level = string (7);

  TYPE
    rat$subproduct_dependencies = array [1 .. rac$max_dependencies] of
          ost$name;

  TYPE
    rat$subproduct_element_count = integer;

  TYPE
    rat$subproduct_info_header = record
      attributes_p: rat$subproduct_attributes_p,
      element_list_p: rat$element_list_p,
      path_container_length: rat$path_container_length,
      path_container_p: rat$path_container_p,
      psrs_answered_count: rat$psrs_answered_count,
      psrs_answered_p: rat$psrs_answered_p,
    recend;

  TYPE
    rat$subproduct_info_sequence = SEQ ( * );

  TYPE
    rat$subproduct_size = amt$file_length;

  TYPE
    rat$subproduct_priority = (rac$low, rac$medium, rac$high,
          rac$installation_tools, rac$packing_list);



*copyc fsc$max_path_size
*copyc amt$file_length
*copyc amt$ring_attributes
*copyc ost$date_time
*copyc ost$name
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc rat$licensed_product
*copyc rat$path
*copyc rat$primary_subproduct
*copyc rat$sif_identifier
*copyc rat$subproduct_description
*copyc rat$subproduct_internal_level
*copyc rat$subproduct_level
*copyc rat$subproduct_name
*copyc rat$subproduct_type
*copyc rmt$mass_storage_class
*DECK DECK=RAT$SUBPRODUCT_INSTALL_PATHS EXPAND=FALSE
  TYPE
    rat$subproduct_install_paths = (rac$installation_path,
          rac$installer_procedure);

*DECK DECK=RAT$SUBPRODUCT_INTERNAL_LEVEL EXPAND=FALSE

  TYPE
    rat$subproduct_internal_level = ost$name;

*copyc ost$name
*DECK DECK=RAT$SUBPRODUCT_LEVEL EXPAND=FALSE

  TYPE
    rat$subproduct_level = ost$name;

*copyc ost$name
*DECK DECK=RAT$SUBPRODUCT_NAME EXPAND=FALSE
{  NOTE:
{   If the following type declaration is ever changed determine impact on
{   RAT$DIRECTORY_SORT_KEY found in deck RAT$IDB_DIRECTORY_TYPES and update
{   as necessary.

  TYPE
    rat$subproduct_name = ost$name;

*copyc ost$name
*DECK DECK=RAT$SUBPRODUCT_TYPE EXPAND=FALSE

  TYPE
    rat$subproduct_type = (rac$correction, rac$release);
*DECK DECK=RAT$SUBPRODUCT_VERIFY_ERRORS EXPAND=FALSE


  TYPE
    rat$subproduct_verify_err_types = (rac$pacs_catalog_moved, rac$permit_errors,
          rac$unmatched_element, rac$unmatched_date_time, rac$unmatched_attrib_checksum,
          rac$unmatched_contents_checksum, rac$no_contents_checksum, rac$other_errors),

    rat$subproduct_verify_errors = set of rat$subproduct_verify_err_types;

*DECK DECK=RAT$SUBPRODUCT_VERIFY_OPTIONS EXPAND=FALSE

  TYPE
    rat$subproduct_verify_types = (rac$test_mod_date_time, rac$test_attributes_checksum,
          rac$test_contents_checksum, rac$reconcile_mod_date_time,
          rac$get_attributes_checksum, rac$calculate_contents_checksum, rac$stop_on_first_error,
          rac$reconcile_pacs_catalog, rac$calculate_size, rac$test_offline_residence),

    rat$subproduct_verify_options = set of rat$subproduct_verify_types;

*DECK DECK=RAT$TABLE_ENTRY_NAME EXPAND=FALSE

*copyc ost$string

TYPE
  rat$table_entry_name = record
                           size: ost$string_size,
                           value: ost$name,
                         recend;


*DECK DECK=RAT$TABLE_RECORD EXPAND=FALSE

TYPE
  rat$table_record  = record
                        mnemonic_name: ALIGNED [0 MOD 32] ost$name,
                        access_mode: pft$permit_selections,
                        share_mode: pft$share_selections,
                        ring: array [1..3] of rat$ring_values,
                        format: rat$file_format,
                        class: rat$file_class,
                        storage_class: rat$storage_class,
                        product: ost$name,
                        version: string (osc$max_name_size),
                        installation_path: clt$path_name,
                        integration_path: string (rac$max_path_name_size),
                        comment: rat$file_comment,
                      recend;

CONST
  rac$max_path_name_size = 256;

*copyc pfd$permanent_file_definitions
*copyc clt$path_name
*copyc ost$name
*copyc rat$file_class
*copyc rat$storage_class
*copyc rat$file_comment
*copyc rat$file_format
*copyc rat$ring_values

*DECK DECK=RAT$TABLE_VERSION EXPAND=FALSE

TYPE
  rat$table_version = string (31);

*DECK DECK=RAT$TAPE EXPAND=FALSE

  TYPE
    rat$additional_volume = record
      evsn: string (6),
      rvsn: string (6),
      size: rat$tape_size,
      bytes_assigned: integer,
      next_volume_p: ^rat$additional_volume,
    recend,

    rat$primary_tape = record
      evsn: string (6),
      rvsn: string (6),
      size: rat$tape_size,
      bytes_assigned: integer,
      assignment_range_lowerbound: rat$subproduct_count,
      assignment_range_upperbound: rat$subproduct_count,
      next_volume_p: ^rat$additional_volume,
      next_tape_p: ^rat$primary_tape,
    recend,

    rat$tape_vsn_list = record
      vsn: string(6),
      next_vsn_p: ^rat$tape_vsn_list,
    recend;

*copyc rat$packing_list_types
*copyc rat$tape_sizes
*DECK DECK=RAT$TAPE_INFORMATION EXPAND=FALSE

  TYPE
    rat$tape_information = record
      vsn_seed: rmt$external_vsn,
      tape_type: ost$name,
      sizes: rat$tape_sizes,
      percent_usable: rat$percent_of_tape_usable,
      number_of_tapes: integer,
      number_of_primary_tapes: integer,
      number_of_multi_vol_sets: integer,
      number_of_tapes_theoretical: integer,
    recend;

*copyc ost$name
*copyc rat$percent_of_tape_usable
*copyc rat$tape_sizes
*copyc rmt$external_vsn
*DECK DECK=RAT$TAPE_SIZES EXPAND=FALSE

  CONST
    rac$max_tape_sizes = 5;

  TYPE
    rat$tape_size = record
      feet: integer,
      usable_bytes: integer,
    recend;

  TYPE
    rat$tape_sizes = array [1 .. rac$max_tape_sizes] OF rat$tape_size;
*DECK DECK=RAT$UPPER_LEVEL_PERMIT EXPAND=FALSE

  TYPE
    rat$upper_level_permit = record
      catalog: string (fsc$max_path_size),
      size: 0 .. fsc$max_path_size,
      permit: rat$permit,
    recend;

*copyc rat$subproduct_info_types
*copyc fsc$max_path_size
*DECK DECK=RAT$VALIDATION_SELECTIONS EXPAND=FALSE

  TYPE
    rat$validation_types = (rac$loading_cycle_empty, rac$staging_cycle_empty,
          rac$max_active_cycle_empty, rac$loading_cycle_only,
          rac$no_rings_below_11, rac$no_permits, rac$no_private_permits,
          rac$warning_public_permits),

    rat$validation_selections = set of rat$validation_types;

*DECK DECK=RAT$VALUE_DECLARATION EXPAND=FALSE

  TYPE
    rat$value_declaration = record
      specification: string (osc$max_string_size),
      key: rat$value_format_keys,
    recend;

  TYPE
    rat$value_format_keys = (rac$undeclared, rac$hex, rac$list, rac$string);

*copyc ost$string
*DECK DECK=RAT$VALUE_RETURNED EXPAND=FALSE

  TYPE
    rat$value_returned = string (osc$max_string_size);

*copyc ost$string
*DECK DECK=RAT$WRITE_SCL_COMMANDS EXPAND=FALSE
  TYPE
    rat$write_scl_commands = record
      command: string (osc$max_string_size),
      size: integer,
    recend;

*DECK DECK=RAV$1ST_DIR_RECORD EXPAND=FALSE

VAR
*copyc rat$170_record_definitions

  rav$1st_dir_record: [STATIC] record
                                 name: string (7),
                                 rtype: rat$nos_records,
                               recend;

*DECK DECK=RAV$ACCESS_KEYS EXPAND=FALSE

*copyc ost$name
*copyc pfd$permanent_file_definitions

VAR
  rav$access_keys: [STATIC, READ] array [pfc$read .. pfc$control] of ost$name := [
                   'READ', 'SHORTEN', 'APPEND', 'MODIFY', 'EXECUTE', 'CYCLE', 'CONTROL'];


*DECK DECK=RAV$ALLOWABLE_CATALOG_LIST EXPAND=FALSE

*copyc clt$path_name

VAR
  rav$allowable_catalog_list: [XREF] array [1..256] of clt$path_name;


*DECK DECK=RAV$BASE EXPAND=FALSE

*copyc ost$user_identification

VAR
  rav$base: [XREF] ost$user_identification;


*DECK DECK=RAV$CLASS_TYPES EXPAND=FALSE

  VAR
    rav$class_types: [STATIC, READ] array[rac$os .. rac$none] of ost$name := [
                     'OS', 'PF', 'CDCNET', 'OS_SUPPORT', 'NONE'];

*copyc rat$file_class
*copyc ost$name

*DECK DECK=RAV$CLONE_CATALOG EXPAND=FALSE

*copyc ost$name

VAR
  rav$clone_catalog: [XREF] array [1..4] of ost$name;

*DECK DECK=RAV$CORP EXPAND=FALSE
  VAR
    rav$corp: [STATIC, XREF] amt$segment_pointer;

*copyc amt$segment_pointer

*DECK DECK=RAV$CORRECTION_FORMAT EXPAND=FALSE

  VAR
    rav$correction_format: [READ] array [rat$correction_format] of string (14) := ['OBJECT_LIBRARY',
          'SOURCE_LIBRARY', 'REPLACEMENT'];



?? PUSH (LISTEXT := ON) ??
*copyc rat$subproduct_info_types
?? POP ??
*DECK DECK=RAV$CORRECTION_PACKAGE_HEADER EXPAND=FALSE
  VAR
    rav$correction_package_header: [STATIC, XREF] ^rat$correction_package_header;

*copyc rat$correction_package_header

*DECK DECK=RAV$CORRECTION_PROCESS_RECORD EXPAND=FALSE

  VAR
    rav$correction_process_record: [XREF] rat$correction_process_record;

?? PUSH (LISTEXT := ON) ??
*copyc rat$correction_process_record
?? POP ??
*DECK DECK=RAV$CREOD_SCRATCH_SEGMENT EXPAND=FALSE

  VAR
    rav$creod_scratch_segment: [XREF] rat$scratch_segment;

?? PUSH (LISTEXT := ON) ??
*copyc rat$scratch_segment
?? POP ??
*DECK DECK=RAV$CREOD_UTILITY_NAME EXPAND=FALSE

  VAR
    rav$creod_utility_name: [XREF, READ] ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=RAV$CRESC_UTILITY_NAME EXPAND=FALSE

  VAR
    rav$cresc_utility_name: [XREF] ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=RAV$DEADSTART_INTERVENTION EXPAND=FALSE

  VAR
    rav$deadstart_intervention: [XREF] boolean;


*DECK DECK=RAV$DEFO_UTILITY_NAME EXPAND=FALSE
  VAR
    rav$defo_utility_name: [XREF, READ] ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=RAV$DEFS_SCRATCH_SEGMENT EXPAND=FALSE

  VAR
    rav$defs_scratch_segment: [XREF] rat$scratch_segment;

?? PUSH (LISTEXT := ON) ??
*copyc rat$scratch_segment
?? POP ??
*DECK DECK=RAV$DEFS_UTILITY_NAME EXPAND=FALSE
  VAR
    rav$defs_utility_name: [XREF, READ] ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=RAV$DEVELOPMENT_DEADSTART EXPAND=FALSE

  VAR
    rav$development_deadstart: [XREF] boolean;



*DECK DECK=RAV$DISPLAY_64_TO_ASCII EXPAND=FALSE

 VAR
    display_64_to_ascii: packed array [0 .. 77(8)] of char := [':','A','B','C',
      'D','E','F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T','U',
      'V','W','X','Y','Z','0','1','2','3','4','5','6','7','8','9','+','-','*',
      '/','(',')','$','=',' ',',','.','#','[',']','%','"','_','!','&','''','?',
      '<','>','@','\','^',';'];


*DECK DECK=RAV$ELEMENTS EXPAND=FALSE
  VAR
    rav$elements: [STATIC, XREF] ^rat$correction_package;

*copyc rat$correction_package

*DECK DECK=RAV$ENTRY_ATTRIBUTES EXPAND=FALSE

*copyc rat$entry_attributes

VAR
  rav$entry_attributes: [STATIC, READ] array[rac$name..rac$comment] of string(31) := [
                        'NAME', 'NEW_NAME', 'PATH', 'ACCESS_MODE', 'SHARE_MODE',
                        'RING', 'FORMAT', 'CLASS','STORAGE_CLASS','PRODUCT', 'VERSION', 'INTVE_PATH',
                        'COMMENT'];

*DECK DECK=RAV$EXEIP_UTILITY_NAME EXPAND=FALSE
  VAR
    rav$exeip_utility_name: [XREF, READ] clt$utility_name;

?? PUSH (LISTEXT := ON) ??
*copyc clt$utility_name
?? POP ??
*DECK DECK=RAV$FORMAT_TYPES EXPAND=FALSE

VAR
  rav$format_types: [STATIC, READ] array [rac$object_library..rac$other] of ost$name := [
               'OBJECT_LIBRARY', 'ONLINE_MANUAL', 'SOURCE_LIBRARY', 'V_RECORD_FILE',
               'REAL_STATE_LIBRARY', 'DEADSTART_TAPE_MODULES', 'INDEXED_SEQUENTIAL_FILE',
               'SYMBOL_TABLE', 'INSTALLATION_TABLE', 'PPU', 'OTHER'];

*copyc ost$name
*copyc rat$file_format

*DECK DECK=RAV$HEADER_ATTRIBUTES EXPAND=FALSE

*copyc rat$header_attributes

VAR
  rav$header_attributes: [STATIC, READ] array[rac$build_level..rac$table_violation] of string(31) :=
                            ['BUILD_LEVEL', 'NUMBER_OF_FILES', 'TABLE_VIOLATION'];

*DECK DECK=RAV$INSS_UTILITY_NAME EXPAND=FALSE

  VAR
    rav$inss_utility_name: [XREF, READ] clt$utility_name;

?? PUSH (LISTEXT := ON) ??
*copyc clt$utility_name
?? POP ??
*DECK DECK=RAV$INSTALLATION_CATALOG EXPAND=FALSE

*copyc ost$name

VAR
  rav$installation_catalog: [XREF] array [1..4] of ost$name;

*DECK DECK=RAV$INSTALLATION_COMMAND EXPAND=FALSE

  VAR
    rav$installation_command: [READ] array [rat$installation_commands]
          of string (22) := ['RAP$INSTALL_PRODUCT', 'RAP$INSTALL_CORRECTION',
          'RAP$ACTIVATE_PRODUCT'];

?? PUSH (LISTEXT := ON) ??
*copyc rat$installation_commands
?? POP ??
*DECK DECK=RAV$INSTALLATION_COMMAND_ABBRV EXPAND=FALSE

  VAR
    rav$installation_command_abbrv: [READ] array [rat$installation_commands]
          of string (4) := ['INSP', 'INSC', 'ACTP'];

?? PUSH (LISTEXT := ON) ??
*copyc rat$installation_commands
?? POP ??
*DECK DECK=RAV$INSTALLATION_DEFAULTS EXPAND=FALSE

  VAR
    rav$installation_defaults: [XREF] rat$installation_defaults;

?? PUSH (LISTEXT := ON) ??
*copyc rat$installation_defaults
?? POP ??
*DECK DECK=RAV$INSTALLATION_PATH_OPTION EXPAND=FALSE

  VAR
    rav$installation_path_option: [READ] array [rat$installation_path_option] of string (24) :=
          ['NOT_DEFINABLE', 'DEFINABLE_MASTER_CATALOG', 'DEFINABLE_FAMILY_NAME', 'DEFINABLE_USER_NAME'];


?? PUSH (LISTEXT := ON) ??
*copyc rat$subproduct_info_types
?? POP ??
*DECK DECK=RAV$INSTALLATION_SCHEME EXPAND=FALSE

  VAR
    rav$installation_scheme: [READ] array [rat$installation_scheme] of string (13) := ['CYCLE_BASED',
          'CATALOG_BASED', 'VERSION_BASED'];


?? PUSH (LISTEXT := ON) ??
*copyc rat$subproduct_info_types
?? POP ??
*DECK DECK=RAV$INSTALLATION_TABLE EXPAND=FALSE
  VAR
    rav$installation_table: [STATIC, XREF] amt$local_file_name;

*copyc amt$local_file_name

*DECK DECK=RAV$INSTALLATION_TABLE_PATH EXPAND=FALSE

*copyc pfd$permanent_file_definitions

VAR
  rav$installation_table_path: [XREF] ^pft$path;

*DECK DECK=RAV$INSTALLATION_TAPE_VALUES EXPAND=FALSE

  VAR
    rav$installation_tape_values: [XREF] rat$installation_tape_values;

?? PUSH (LISTEXT := ON) ??
*copyc rat$installation_tape_values
?? POP ??
*DECK DECK=RAV$INTERVENE_IN_DEADSTART_NAME EXPAND=FALSE

VAR
  rav$intervene_in_deadstart_name: [XREF] ost$name;

*copyc ost$name
*DECK DECK=RAV$MAIDS_FILE_CATALOG_NAMES EXPAND=FALSE
  "$FORMAT=OFF"
  VAR
    name_builtin_library: name = builtin_library
    name_sou_library: name = sou_library
    name_dcfile: name = dcfile
    name_deadstart_catalog: name = deadstart_catalog
    name_deadstart_commands_catalog: name = deadstart_commands
    name_jt_link_map: name = job_template_link_map
    name_link_input_catalog: name = link_input_files
    name_link_output_catalog: name = link_output_files
    name_mf_config_catalog: name = mf_config_files
    name_mf_config_files: name = mf_config_files
    name_non_boot_drivers_catalog: name = non_boot_drivers
    name_non_boot_drivers_file: name = non_boot_drivers
    name_nosve_maintenance_catalog: name = nosve_maintenance
    name_os_version_file: name = os_version
    name_osf_builtin_library: name = osf$builtin_library
    name_osf_sou_library: name = osf$sou_library
    name_physical_config: name = physical_config
    name_physical_configuration: name = physical_configuration
    name_product_files_catalog: name = product_files
    name_prolog_file: name = prolog_file
    name_prolog_library: name = prolog_library
    name_sc_link_map: name = system_core_link_map
    name_site_maintenance_catalog: name = site_os_maintenance
    name_system_debug_table: name = system_debug_table
  VAREND
  "$FORMAT=ON"
*DECK DECK=RAV$MARGIN EXPAND=FALSE
  IF $variable(rav$margin, nonlocal) THEN
    "$FORMAT=OFF
    VAR
      rav$margin: (XREF) integer
    VAREND
    "$FORMAT=ON"
  ELSE
    "$FORMAT=OFF
    VAR
      rav$margin: (XDCL) integer = 0
    VAREND
    "$FORMAT=ON"
  IFEND
*DECK DECK=RAV$NETWORK_ACTIVATION EXPAND=FALSE

  VAR
    rav$network_activation: [XREF] boolean;


*DECK DECK=RAV$NEW_PF_PATH_NAME EXPAND=FALSE
  VAR
    rav$new_pf_path_name: [STATIC, XREF] clt$path_name;

*copyc clt$path_name
*DECK DECK=RAV$NEW_SYSTEM_CATALOG EXPAND=FALSE
  VAR
    rav$new_system_catalog: [STATIC, XREF] clt$file;

*copyc clt$file

*DECK DECK=RAV$OLD_PF_PATH_NAME EXPAND=FALSE
  VAR
    rav$old_pf_path_name: [STATIC, XREF] clt$path_name;

*copyc clt$path_name

*DECK DECK=RAV$OLD_SYSTEM_CATALOG EXPAND=FALSE
  VAR
    rav$old_system_catalog: [STATIC, XREF] clt$file;

*copyc clt$file

*DECK DECK=RAV$ORDER_CONTENTS_COUNT EXPAND=FALSE

  VAR
    rav$order_contents_count: [XREF] rat$subproduct_count;

?? PUSH (LISTEXT := ON) ??
*copyc rat$packing_list_types
?? POP ??
*DECK DECK=RAV$ORDER_CONTENTS_LIST_P EXPAND=FALSE

  VAR
    rav$order_contents_list_p: [XREF] ^rat$order_contents_list;

?? PUSH (LISTEXT := ON) ??
*copyc rat$order_contents_list
?? POP ??
*DECK DECK=RAV$ORDER_MEDIUM EXPAND=FALSE

  VAR
    rav$order_medium: [READ] array [rat$order_medium] of string (4) := ['TAPE',
          'DISK'];

?? PUSH (LISTEXT := ON) ??
*copyc rat$packing_list_types
?? POP ??
*DECK DECK=RAV$PACKING_LIST_HEADER_P EXPAND=FALSE

  VAR
    rav$packing_list_header_p: [XREF] ^rat$packing_list_header;

?? PUSH (LISTEXT := ON) ??
*copyc rat$packing_list_types
?? POP ??

*DECK DECK=RAV$PACKING_LIST_SEQ_P EXPAND=FALSE

  VAR
    rav$packing_list_seq_p: [XREF] ^rat$packing_list_sequence;

?? PUSH (LISTEXT := ON) ??
*copyc rat$packing_list_types
?? POP ??
*DECK DECK=RAV$PACS_CATALOG_P EXPAND=FALSE

  VAR
    rav$pacs_catalog_p: [XREF] ^pft$path;

?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=RAV$PACS_CATALOG_REF_P EXPAND=FALSE

  VAR
    rav$pacs_catalog_ref_p: [XREF] ^fst$file_reference;

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
?? POP ??
*DECK DECK=RAV$PACS_SCRATCH_SEGMENT EXPAND=FALSE

  VAR
    rav$pacs_scratch_segment: [XREF] rat$scratch_segment;

?? PUSH (LISTEXT := ON) ??
*copyc rat$scratch_segment
?? POP ??
*DECK DECK=RAV$PACS_UTILITY_NAME EXPAND=FALSE
  VAR
    rav$pacs_utility_name: [XREF, READ] ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=RAV$PC_VAR_DECS_XREF EXPAND=FALSE
  VAR
    pc_utility_name: [STATIC, XREF] ost$name,
    pc_prompt_string: [STATIC, XREF] string (2);

*DECK DECK=RAV$PERMIT_NAMES EXPAND=FALSE

  VAR
    rav$permit_names: [READ] array [pft$permit_options] of string (7) := ['READ', 'SHORTEN', 'APPEND',
          'MODIFY', 'EXECUTE', 'CYCLE', 'CONTROL'];


?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=RAV$PREVIOUS_CLONE_ACCESS EXPAND=FALSE

VAR
  rav$previous_clone_access: [XREF] boolean;


*DECK DECK=RAV$PRODUCT_REFERENCE EXPAND=FALSE

  VAR
    rav$product_reference: [READ] array [rat$product_references] of string (16) :=
          ['not referenced', 'licensed product', 'subproduct', 'group', 'excluded'];

?? PUSH (LISTEXT := ON) ??
*copyc rat$product_references
?? POP ??
*DECK DECK=RAV$SHARE_KEYS EXPAND=FALSE

*copyc ost$name
*copyc pfd$permanent_file_attributes

VAR
  rav$share_keys: [STATIC, READ] array [pfc$read .. pfc$execute] of ost$name := [
                  'READ', 'SHORTEN', 'APPEND', 'MODIFY', 'EXECUTE'];


*DECK DECK=RAV$SHARE_NAMES EXPAND=FALSE

  VAR
    rav$share_names: [READ] array [pft$share_options] of string (7) := ['READ', 'SHORTEN', 'APPEND', 'MODIFY',
          'EXECUTE'];

?? PUSH (LISTEXT := ON) ??
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=RAV$STEP_STATUS EXPAND=FALSE

  VAR
    rav$step_status: [READ] array [rat$step_status] OF string (9) := ['STARTED',
          'COMPLETED'];

?? PUSH (LISTEXT := ON) ??
*copyc rat$processing_summary_types
?? POP ??

*DECK DECK=RAV$STEP_TITLE EXPAND=FALSE

  VAR
    rav$step_title: [READ] array [rat$steps] of string (34) := [
          'INITIALIZING FOR INSTALLATION', 'RECONCILING CYCLE CONFLICTS',
          'LOADING THE SUBPRODUCTS', 'CORRECTING THE SUBPRODUCTS',
          'STAGING THE SUBPRODUCTS', 'ACTIVATING THE SUBPRODUCTS',
          'EXECUTING THE INSTALLER PROCEDURES', 'UPDATING THE IDB DIRECTORY',
          'DELETING PREVIOUS CYCLES'];

?? PUSH (LISTEXT := ON) ??
*copyc rat$processing_summary_types
?? POP ??
*DECK DECK=RAV$SUBPRODUCT_INFO_POINTERS EXPAND=FALSE

  VAR
    rav$subproduct_info_pointers: [XREF] rat$subproduct_info_pointers;

?? PUSH (LISTEXT := ON) ??
*copyc rat$subproduct_info_pointers
?? POP ??
*DECK DECK=RAV$SUBPRODUCT_PRIORITY EXPAND=FALSE


  VAR
    rav$subproduct_priority: [READ] array [rat$subproduct_priority] of string (18) := ['LOW',
          'MEDIUM', 'HIGH', 'INSTALLATION_TOOLS', 'PACKING_LIST'];


?? PUSH (LISTEXT := ON) ??
*copyc rat$subproduct_info_types
?? POP ??
*DECK DECK=RAV$SUBPRODUCT_TYPE EXPAND=FALSE

  VAR
    rav$subproduct_type: [READ] array [rat$subproduct_type] of string (20) := ['CORRECTION', 'RELEASE'];


?? PUSH (LISTEXT := ON) ??
*copyc rat$subproduct_info_types
?? POP ??
*DECK DECK=RAV$SYSTEM_ACTIVATION EXPAND=FALSE

  VAR
    rav$system_activation: [XREF, READ] boolean;
*DECK DECK=RAV$SYSTEM_PATHS EXPAND=FALSE

  "$FORMAT=OFF
  IF $variable(rav$system, nonlocal) THEN
    VAR
      rav$system: (XREF) file
    VAREND
  ELSE
    VAR
      rav$system: (XDCL) file = $system
    VAREND
  IFEND

  VAR
    rav$accounting_utils_library: (XDCL) file = rav$system.accounting_and_validation.command_library
    rav$builtin_library: (XDCL) file = rav$system.osf$builtin_library
    rav$software_maintenance: (XDCL) file = rav$system.software_maintenance
    rav$system_initiation_log: (XDCL) file = rav$software_maintenance.system_initiation_log
  VAREND
  "$FORMAT=ON

*DECK DECK=RAV$SYSTEM_ROOT_VARIABLE EXPAND=FALSE

    IF $variable(rav$system,declared) = 'NONLOCAL' THEN
      VAR
        rav$system: (XREF) file
      VAREND
    ELSE
      VAR
        rav$system: (XDCL) file = $system
      VAREND
    IFEND
*DECK DECK=RAV$TAPE_INFORMATION EXPAND=FALSE

  VAR
    rav$tape_information: [XREF] rat$tape_information;

?? PUSH (LISTEXT := ON) ??
*copyc rat$tape_information
?? POP ??
*DECK DECK=RAV$TASK_STATUS EXPAND=FALSE

  VAR
    rav$task_status: [READ] array [rat$task_status] of string (9) := [
          'started', 'completed', 'failed'];

?? PUSH (LISTEXT := ON) ??
*copyc rat$processing_types
?? POP ??
*DECK DECK=RAV$TASK_TITLE EXPAND=FALSE

  VAR
    rav$task_title: [READ] array [rat$tasks] of string (10) := [
          'initialize', 'reconcile', 'loading', 'correcting', 'staging',
          'activating', 'exec_iproc', 'updating', 'deleting'];

?? PUSH (LISTEXT := ON) ??
*copyc rat$processing_types
?? POP ??
*DECK DECK=RAV$UPGRADE_LOG EXPAND=FALSE

*copyc ost$name

VAR
  rav$upgrade_log: [XREF] array [1..4] of ost$name;

*DECK DECK=RAV$UTILITY_NAME EXPAND=FALSE

*copyc ost$name

VAR
  rav$utility_name: [XREF] ost$name;

*DECK DECK=RAV$UTILITY_SESSION_ID EXPAND=FALSE

VAR
  rav$utility_session_id: [XREF] string (43);


*DECK DECK=REPORT_FILES EXPAND=TRUE
create_program_description n=(report_files) sp=usp#report_files l=( ..
      ':$system.$system.osf$site_command_library') lm=$null lmo=none ..
      pv=zero af=$null dm=off
*DECK DECK=RFC$CONDITION_CODE_RANGE EXPAND=FALSE

{    DECK: RFC$CONDITION_CODE_RANGE


*copyc rfc$product_id

  CONST
    rfc$min_ecc = (($INTEGER ('R') * 100(16)) + $INTEGER ('F')) * 1000000(16),
    rfc$min_ecc_rhf_access_method = rfc$min_ecc,
    rfc$max_ecc_rhf_access_method = rfc$min_ecc_rhf_access_method + 9999;

*DECK DECK=RFC$CONFIGURATION_DEFS EXPAND=FALSE

{    DECK: RFC$CONFIGURATION_DEFS
{
{    This deck defines the constants used to define the Loosely Coupled
{    Network (LCN) architecture.


CONST


{    This group of definitions is limited by the current LCN hardware.

     rfc$min_tcu = 0,
     rfc$max_tcu = 3,

     rfc$min_nad_address = 0,
     rfc$max_nad_address = 0FF(16),

     rfc$min_destination_device_addr = 0,
     rfc$max_destination_device_addr = 0F(16),

     rfc$min_nad_access_code = 0,
     rfc$max_nad_access_code = 0FFFF(16),

     rfc$min_host_connect = 0,
     rfc$max_host_connect = 3,

     rfc$max_local_nads = 24,

{    This group of definitions is limited by current LCN host software.

     rfc$max_connections = 07F(16),

     rfc$max_rnads_per_lnad = 0FF(16),

     rfc$max_trace_size = 1F(16),

     rfc$max_nad_queue_limit = 1F(16),

     rfc$min_logical_network = 0,
     rfc$max_logical_network = 0FF(16),

     rfc$min_logical_nad = 0,
     rfc$max_logical_nad = 0FF(16),

     rfc$connection_pw_length = 7,

     rfc$subsystem_id_length = 2,

{    This group of definitions have abitrary limitations based on
{    intuitive reasonability assumptions.

     rfc$status_change_threshold = 5 * 60 * 1000 * 1000,  { five minutes }

     rfc$max_concurrent_requests = 30,

     rfc$max_microcode_reloads = 99,

{    This group of definitions is abitrarily large to prevent
{    overflow errors by optimistic users.

     rfc$max_paths_per_host = 0FFFFFFFF(16),

     rfc$max_logical_ids_per_host = 0FFFFFFFF(16),

     rfc$max_remote_nads = 0FFFFFFFF(16);

CONST

{    Configuration file information.

     rfc$configuration_label = 'RHFAM/VE VER 1.6',

     rfc$config_label_length = 16,

     rfc$password = '', {  The $SYSTEM catalog permits should be sufficient  }

     rfc$config_file_lfn = '$RHFAM_CONFIG_FILE',

     rfc$rhfam_family_name = '$SYSTEM',

     rfc$rhfam_master_catalog = '$SYSTEM',

     rfc$rhfam_sub_catalog = 'RHFAM',

     rfc$microcode_sub_catalog = 'MICROCODE',

     rfc$dump_sub_catalog = 'NAD_DUMPS',

     rfc$server_sub_catalog = 'SERVERS',

     rfc$configuration_file = 'CONFIGURATION_FILE',

     rfc$startup_command_file = 'STARTUP_COMMAND_FILE',

     rfc$configuration_cmd_file = 'CONFIGURATION_CMD_FILE';


{    The following is a pictoral representation of the configuration file image.
{
{
{                  +---------------------------------+
{                  !       configuration label       !
{                  +---------------------------------+
{                  !     number of local host LIDs   !
{                  +---------------------------------+
{                  !       local host entry          !
{                  +---------------------------------+
{                  !   number of local host paths    !
{                  +---------------------------------+
{                  !       local host paths          !
{                  +---------------------------------+
{                  !      number of remote hosts     !
{                  +---------------------------------+
{                  !  number of remote host LIDs 1   !
{                  +---------------------------------+
{                  !      remote host entry 1        !
{                  +---------------------------------+
{                  !  number of remote host paths 1  !
{                  +---------------------------------+
{                  !      remote host paths 1        !
{                  +---------------------------------+
{                  !                .                !
{                  !                .                !
{                  !                .                !
{                  +---------------------------------+
{                  !  number of remote host LIDs N   !
{                  +---------------------------------+
{                  !      remote host entry N        !
{                  +---------------------------------+
{                  !  number of remote host paths N  !
{                  +---------------------------------+
{                  !      remote host paths N        !
{                  +---------------------------------+
{                  !      number of local NADs       !
{                  +---------------------------------+
{                  !      local NAD entries          !
{                  +---------------------------------+
{                  !      number of remote NADs      !
{                  +---------------------------------+
{                  !      remote NAD entries         !
{                  +---------------------------------+
{
*DECK DECK=RFC$EXTERNAL_INTERFACE EXPAND=FALSE

{    DECK: RFC$EXTERNAL_INTERFACE
{
{    The purpose of this deck is to define the constants
{    required for usage of the RHFAM external interface.


  CONST

    rfc$appl_name_length = 7,

    rfc$physical_id_length = 3,

    rfc$logical_id_length = 31,

    rfc$max_appl_block_number = 3ffff(16),

    rfc$max_appl_connections = 255,

    rfc$max_available_hosts = 10,

    rfc$max_lcn_hosts = 1000,

    rfc$min_rhfam_reject_code = 0,

    rfc$max_rhfam_reject_code = 127,

    rfc$min_server_reject_code = 128,

    rfc$max_server_reject_code = 255,

    rfc$max_block_size = 4096,

    rfc$max_buffer_length = osc$max_segment_length,

    rfc$max_connect_time = 0FFFFFFFFFFFF(16),

    rfc$max_data_fragment_count = 255,

    rfc$max_data_length = osc$max_segment_length,

    rfc$min_connection_timeout = 0,

    rfc$max_connection_timeout = 30*60*1000, { 30 minutes }

    rfc$min_transfer_timeout = 0,

    rfc$max_transfer_timeout = 10*60*60*1000, { 10 hours }

    rfc$max_bytes_transferred = osc$max_segment_length,

    rfc$min_network_reason_code = 0,

    rfc$max_network_reason_code = 0ff(16);


?? PUSH (LISTEXT := ON) ??
*copyc ost$hardware_subranges
?? POP ??
*DECK DECK=RFC$PP_INTERFACE_DEFS EXPAND=FALSE

{    DECK:  RFC$PP_INTERFACE_DEFS
{
{    The purpose of this deck is to define the CYBIL constants for
{    the RHFAM/VE CPU to PP interface.
{
{    Most of the definitions here correspond to definitions in the NAD
{    pp driver (deck rfm$nad_pp_driver).  Changes here will require assembly
{    language equivalent changes in the driver.


{    The following is a list of the supported logical_commands.

    CONST
        rfc$min_logical_command = 0a0(16),
        rfc$lc_request_connection = 0a0(16),
        rfc$lc_obtain_connect_request = 0a1(16),
        rfc$lc_accept_connect_request = 0a2(16),
        rfc$lc_reject_connect_request = 0a3(16),
        rfc$lc_send_data = 0a4(16),
        rfc$lc_receive_data = 0a5(16),
        rfc$lc_status_nad = 0a6(16),
        rfc$lc_send_control_message = 0a7(16),
        rfc$lc_receive_control_message = 0a8(16),
        rfc$lc_disconnect_paths = 0a9(16),
        rfc$lc_read_path_status_table = 0aa(16),
        rfc$lc_obtain_nad_general_stat = 0ab(16),
        rfc$lc_process_physical_command = 0ac(16),
        rfc$max_logical_command = 0ac(16);

{    The following are the supported physical commands.

    CONST
        rfc$min_physical_command = 20(16),
        rfc$pc_function_nad = 20(16),
        rfc$pc_output_8_in_8_mode = 23(16),
        rfc$pc_input_8_in_8_mode = 25(16),
        rfc$pc_set_addr_and_length = 28(16),
        rfc$pc_hardware_status = 29(16),
        rfc$pc_microcode_status = 2a(16),
        rfc$max_physical_command = 2a(16);

{    The following are the supported PP commands.

    CONST
        rfc$min_pp_command = 4,
        rfc$pp_idle = 4,
        rfc$pp_resume = 5,
        rfc$max_pp_command = 5;

{    The following determines the maximum peripheral request buffer
{    size.  One must understand the type definitions specified
{    in RFT$PP_INTERFACE_DEFS prior to changing this constant.
{    Specifically, the buffer cannot exceed 1024 bytes.

    CONST
        rfc$command_buffer_size = 80;  {  640 bytes }

{    The following is a list of functions that are sent to the NAD by the
{    PP driver.

    CONST
        rfc$nf_purge_all_paths = 0,
        rfc$nf_nad_general_status = 1,
        rfc$nf_abort_transaction = 3,
        rfc$nf_send_control_message = 4,
        rfc$nf_connect_path = 5,
        rfc$nf_ready = 10(8),
        rfc$nf_accept_connect_request = 11(8),
        rfc$nf_reject_connect_request = 12(8),
        rfc$nf_receive_control_message = 14(8),
        rfc$nf_get_rejected_ctrl_mess = 17(8),
        rfc$nf_normal_disconnect = 21(8),
        rfc$nf_abnormal_disconnect = 22(8),
        rfc$nf_transmit_data = 23(8),
        rfc$nf_read_path_status = 35(8),
        rfc$nf_receive_rej_control_mess = 36(8),
        rfc$nf_connect_maintenance_path = 40(8),
        rfc$nf_maintenance_path_input = 42(8),
        rfc$nf_read_remote_status = 46(8),
        rfc$nf_reset_transaction = 50(8),
        rfc$nf_univeral_command = 53(8),
        rfc$nf_local_nad_status = 54(8),
        rfc$nf_select_path = 200(8),
        rfc$nf_flag_function = 400(8);

{    The following is a list of the universal command sub-functions.

    CONST
        rfc$uc_read_binary_data = 5,
        rfc$uc_write_binary_data = 6,
        rfc$uc_obtain_connect_request = 7;

{    The following is a list of functions that are sent to the
{    S0 ICI/C170 converter by the PP driver.

    CONST
        rfc$s0c_set_conversion_mode = 110000(8),
        rfc$s0c_set_12_bit_mode = 120000(8),
        rfc$s0c_select_c170_converter = 170000(8);

{    The following is a list of the NAD DI functions.

    CONST
        rfc$di_input_bit_string = 0,
        rfc$di_input_8_in_12 = 2,
        rfc$di_output_bit_string = 10(8),
        rfc$di_output_12_to_8 = 12(8),
        rfc$di_obtain_hardware_status = 200(8),
        rfc$di_obtain_microcode_stat = 201(8),
        rfc$di_set_addr_and_length = 202(8)+ rfc$s0c_set_12_bit_mode,
        rfc$di_clear_parity_error = 204(8),
        rfc$di_interface_master_clear = 277(8) + rfc$s0c_select_c170_converter,
        rfc$di_step_processor = 301(8),
        rfc$di_go_nad = 302(8),
        rfc$di_processor_master_clear = 304(8);

{    The following is a list of nad response codes.

    CONST
        rfc$nad_response_mask = 37(8),
        rfc$nr_acknowledge = 1,
        rfc$nr_negative_acknowledge = 2,
        rfc$nr_universal_acknowledge = 5,
        rfc$nr_routing_error = 15(8),
        rfc$nr_initializing_to_rnad = 16(8),
        rfc$nr_transfer_not_ready = 17(8),
        rfc$nr_connect_in_progress = 21(8),
        rfc$nr_disconnected = 22(8),
        rfc$nr_abort = 23(8),
        rfc$nr_undefined_command = 24(8),
        rfc$nr_illegal_command = 25(8),
        rfc$nr_buffer_terminated = 26(8),
        rfc$nr_flush = 27(8);


    CONST
        rfc$min_pf_criteria = 0,
        rfc$pf_match_both_characters = 0,
        rfc$pf_match_first_character = 1,
        rfc$pf_match_second_character = 2,
        rfc$pf_unconditional_match = 3,
        rfc$max_pf_criteria = 3;

{    The following constants are used to index into the command
{    buffer for the PP requests.

    CONST

        rfc$cbi_pp_request = 1,
        rfc$cbi_unit_request_1 = 1,
        rfc$cbi_unit_request_2 = 2,
        rfc$cbi_general_buffer = 3,
        rfc$cbi_in_pointer = 3,
        rfc$cbi_out_pointer = 4,
        rfc$cbi_first_io_entry = 5,
        rfc$cbi_last_io_entry = 60,
        rfc$cbi_limit_pointer = 61,
        rfc$cbi_first_indirect_pva = 61,
        rfc$cbi_last_command_entry = rfc$command_buffer_size;


*DECK DECK=RFC$PP_RESPONSE_AVAILABLE EXPAND=FALSE
*DECK DECK=RFC$PRODUCT_ID EXPAND=FALSE

{    DECK: RFC$PRODUCT_ID

    CONST
        rfc$product_id = 'RF';



*DECK DECK=RFC$R1_INTERFACE_DEFS EXPAND=FALSE

{    DECK:  RFC$R1_INTERFACE_DEFS



  CONST

      rfc$max_nad_retries = 3,

      rfc$max_load_dump_buffers = 15,

      rfc$max_load_dump_buffer_size = 4096,

      rfc$max_r1_request_id = 255,

      rfc$max_r3_request_id = 255,

      rfc$max_outstanding_blocks = 12,

      rfc$max_network_wired_buffers = 100,

      rfc$max_wired_buffers_per_req = 18,

      rfc$max_blocks_to_add = 6,

      rfc$min_unwired_data_length = 28000,

      rfc$unit_request_wait_time = 500,

      rfc$ur_expected_wait = 25;

?? PUSH (LISTEXT := ON) ??
*copyc rfc$external_interface
?? POP ??

*DECK DECK=RFD$CDT_CONFIGURATION_FILE EXPAND=FALSE

{ table rfv$config_commands type=command
{ command (install_rhfam_configuration, insrc) processor=rfp$install_rhfam_configuration
{ command (verify_rhfam_configuration, verrc) processor=rfp$verify_rhfam_configuration
{ command (quit, q) processor=rfp$cu_quit

?? PUSH (LISTEXT := ON) ??
VAR
  rfv$config_commands: [STATIC, READ] ^clt$command_table := ^rfv$config_command_entries,

  rfv$config_command_entries: [STATIC, READ] array [1 .. 6] of  clt$command_table_entry := [
  {} ['INSRC                          ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rfp$install_rhfam_configuration],
  {} ['INSTALL_RHFAM_CONFIGURATION    ', clc$nominal_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rfp$install_rhfam_configuration],
  {} ['Q                              ', clc$abbreviation_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rfp$cu_quit],
  {} ['QUIT                           ', clc$nominal_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rfp$cu_quit],
  {} ['VERIFY_RHFAM_CONFIGURATION     ', clc$nominal_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rfp$verify_rhfam_configuration],
  {} ['VERRC                          ', clc$abbreviation_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rfp$verify_rhfam_configuration]];

?? POP ??

*DECK DECK=RFD$CDT_INSTALL_BIN_DIRECTIVES EXPAND=FALSE
{ table rfv$install_cmd_binary type=command
{ command (define_local_host, deflh) processor=rfp$define_local_host
{ command (define_remote_host, defrh) processor=rfp$define_remote_host
{ command (define_local_nad, defln) processor=rfp$define_local_nad
{ command (define_remote_nad, defrn) processor=rfp$define_remote_nad
{ command (define_lcn_path, deflp) processor=rfp$define_lcn_path
{ command (auto_path_generation, autpg) processor=rfp$auto_path_generation
{ command (quit, q) processor=rfp$irb_quit
{ tablend

?? PUSH (LISTEXT := ON) ??
VAR
  rfv$install_cmd_binary: [STATIC, READ] ^clt$command_table := ^rfv$install_cmd_binary_entries,

  rfv$install_cmd_binary_entries: [STATIC, READ] array [1 .. 14] of  clt$command_table_entry := [
  {} ['AUTO_PATH_GENERATION           ', clc$nominal_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^rfp$auto_path_generation],
  {} ['AUTPG                          ', clc$abbreviation_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^rfp$auto_path_generation],
  {} ['DEFINE_LCN_PATH                ', clc$nominal_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^rfp$define_lcn_path],
  {} ['DEFINE_LOCAL_HOST              ', clc$nominal_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rfp$define_local_host],
  {} ['DEFINE_LOCAL_NAD               ', clc$nominal_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rfp$define_local_nad],
  {} ['DEFINE_REMOTE_HOST             ', clc$nominal_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rfp$define_remote_host],
  {} ['DEFINE_REMOTE_NAD              ', clc$nominal_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^rfp$define_remote_nad],
  {} ['DEFLH                          ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rfp$define_local_host],
  {} ['DEFLN                          ', clc$abbreviation_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rfp$define_local_nad],
  {} ['DEFLP                          ', clc$abbreviation_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^rfp$define_lcn_path],
  {} ['DEFRH                          ', clc$abbreviation_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rfp$define_remote_host],
  {} ['DEFRN                          ', clc$abbreviation_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^rfp$define_remote_nad],
  {} ['Q                              ', clc$abbreviation_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^rfp$irb_quit],
  {} ['QUIT                           ', clc$nominal_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^rfp$irb_quit]];

?? POP ??


*DECK DECK=RFD$CDT_INSTALL_DIRECTIVES EXPAND=FALSE

{ table rfv$install_directives type=command
{ command (define_local_host, deflh) processor=rfp$define_local_host
{ command (define_remote_host, defrh) processor=rfp$define_remote_host
{ command (define_local_nad, defln) processor=rfp$define_local_nad
{ command (define_remote_nad, defrn) processor=rfp$define_remote_nad
{ command (define_lcn_path, deflp) processor=rfp$define_lcn_path
{ command (auto_path_generation, autpg) processor=rfp$auto_path_generation
{ command (quit, q) processor=rfp$irc_quit

?? PUSH (LISTEXT := ON) ??
VAR
  rfv$install_directives: [STATIC, READ] ^clt$command_table := ^rfv$install_directives_entries,

  rfv$install_directives_entries: [STATIC, READ] array [1 .. 14] of  clt$command_table_entry := [
  {} ['AUTO_PATH_GENERATION           ', clc$nominal_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^rfp$auto_path_generation],
  {} ['AUTPG                          ', clc$abbreviation_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^rfp$auto_path_generation],
  {} ['DEFINE_LCN_PATH                ', clc$nominal_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^rfp$define_lcn_path],
  {} ['DEFINE_LOCAL_HOST              ', clc$nominal_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rfp$define_local_host],
  {} ['DEFINE_LOCAL_NAD               ', clc$nominal_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rfp$define_local_nad],
  {} ['DEFINE_REMOTE_HOST             ', clc$nominal_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rfp$define_remote_host],
  {} ['DEFINE_REMOTE_NAD              ', clc$nominal_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^rfp$define_remote_nad],
  {} ['DEFLH                          ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rfp$define_local_host],
  {} ['DEFLN                          ', clc$abbreviation_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rfp$define_local_nad],
  {} ['DEFLP                          ', clc$abbreviation_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^rfp$define_lcn_path],
  {} ['DEFRH                          ', clc$abbreviation_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rfp$define_remote_host],
  {} ['DEFRN                          ', clc$abbreviation_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^rfp$define_remote_nad],
  {} ['Q                              ', clc$abbreviation_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^rfp$irc_quit],
  {} ['QUIT                           ', clc$nominal_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^rfp$irc_quit]];

?? POP ??

*DECK DECK=RFD$CDT_MANAGE_RHFAM_NETWORK EXPAND=FALSE

{ table manrn_command_list t=c sn=oss$job_paged_literal s=local
{ command (activate_rhfam_client, actrc) activate_rhfam_client cm=local
{ command (activate_rhfam_server, actrs) activate_rhfam_server cm=local
{ command (change_host_state, chahs) change_host_state cm=local
{ command (change_lid_state, chals) change_lid_state cm=local
{ command (change_nad_state, chans) change_nad_state cm=local
{ command (change_trunk_state, chats) change_trunk_state cm=local
{ command (deactivate_rhfam_client, dearc) deactivate_rhfam_client cm=local
{ command (deactivate_rhfam_server, dears) deactivate_rhfam_server cm=local
{ command (define_rhfam_client, defrc) define_rhfam_client cm=local
{ command (define_rhfam_server, defrs) define_rhfam_server cm=local
{ command (delete_rhfam_client, delrc) delete_rhfam_client cm=local
{ command (delete_rhfam_server, delrs) delete_rhfam_server cm=local
{ command (display_active_applications, display_active_application, display_active_appl, disaa)          ..
{   display_active_appl cm=local
{ command (display_logical_identifiers, display_logical_identifier, disli)   display_logical_identifier    ..
{            cm=local
{ command (display_nad_status, disns) display_nad_status cm=local
{ command (display_physical_paths, display_physical_path, dispp)   display_physical_path cm=local
{ command (display_rhfam_clients, display_rhfam_client, disrc)   display_rhfam_clients cm=local
{ command (display_rhfam_servers, display_rhfam_server, disrs)   display_rhfam_servers cm=local
{ command (display_trunk_status, dists) display_trunk_status cm=local
{ command (format_nad_dump, fornd) format_nad_dump cm=local
{ command (install_rhfam_configuration, insrc)   rfp$install_rhfam_configuration cm=xref
{ command (install_rhfam_config_bin, insrcb)   rfp$install_rhf_config_bin cm=xref a=hidden
{ command (test_local_nad, tesln) test_local_nad cm=local
{ command (verify_rhfam_configuration, verrc)   rfp$verify_rhfam_configuration cm=xref
{ command (quit, qui) quit cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  manrn_command_list: [STATIC, READ, oss$job_paged_literal] ^clt$command_table := ^manrn_command_list_entries,

  manrn_command_list_entries: [STATIC, READ, oss$job_paged_literal] array [1 .. 56] of
      clt$command_table_entry := [
  {} ['ACTIVATE_RHFAM_CLIENT          ', clc$nominal_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^activate_rhfam_client],
  {} ['ACTIVATE_RHFAM_SERVER          ', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^activate_rhfam_server],
  {} ['ACTRC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^activate_rhfam_client],
  {} ['ACTRS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^activate_rhfam_server],
  {} ['CHAHS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^change_host_state],
  {} ['CHALS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^change_lid_state],
  {} ['CHANGE_HOST_STATE              ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^change_host_state],
  {} ['CHANGE_LID_STATE               ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^change_lid_state],
  {} ['CHANGE_NAD_STATE               ', clc$nominal_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^change_nad_state],
  {} ['CHANGE_TRUNK_STATE             ', clc$nominal_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^change_trunk_state],
  {} ['CHANS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^change_nad_state],
  {} ['CHATS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^change_trunk_state],
  {} ['DEACTIVATE_RHFAM_CLIENT        ', clc$nominal_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^deactivate_rhfam_client],
  {} ['DEACTIVATE_RHFAM_SERVER        ', clc$nominal_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^deactivate_rhfam_server],
  {} ['DEARC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^deactivate_rhfam_client],
  {} ['DEARS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^deactivate_rhfam_server],
  {} ['DEFINE_RHFAM_CLIENT            ', clc$nominal_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^define_rhfam_client],
  {} ['DEFINE_RHFAM_SERVER            ', clc$nominal_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^define_rhfam_server],
  {} ['DEFRC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^define_rhfam_client],
  {} ['DEFRS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^define_rhfam_server],
  {} ['DELETE_RHFAM_CLIENT            ', clc$nominal_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^delete_rhfam_client],
  {} ['DELETE_RHFAM_SERVER            ', clc$nominal_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^delete_rhfam_server],
  {} ['DELRC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^delete_rhfam_client],
  {} ['DELRS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^delete_rhfam_server],
  {} ['DISAA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^display_active_appl],
  {} ['DISLI                          ', clc$abbreviation_entry, clc$normal_usage_entry, 14,
        clc$automatically_log, clc$linked_call, ^display_logical_identifier],
  {} ['DISNS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 15,
        clc$automatically_log, clc$linked_call, ^display_nad_status],
  {} ['DISPLAY_ACTIVE_APPL            ', clc$alias_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^display_active_appl],
  {} ['DISPLAY_ACTIVE_APPLICATION     ', clc$alias_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^display_active_appl],
  {} ['DISPLAY_ACTIVE_APPLICATIONS    ', clc$nominal_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^display_active_appl],
  {} ['DISPLAY_LOGICAL_IDENTIFIER     ', clc$alias_entry, clc$normal_usage_entry, 14,
        clc$automatically_log, clc$linked_call, ^display_logical_identifier],
  {} ['DISPLAY_LOGICAL_IDENTIFIERS    ', clc$nominal_entry, clc$normal_usage_entry, 14,
        clc$automatically_log, clc$linked_call, ^display_logical_identifier],
  {} ['DISPLAY_NAD_STATUS             ', clc$nominal_entry, clc$normal_usage_entry, 15,
        clc$automatically_log, clc$linked_call, ^display_nad_status],
  {} ['DISPLAY_PHYSICAL_PATH          ', clc$alias_entry, clc$normal_usage_entry, 16,
        clc$automatically_log, clc$linked_call, ^display_physical_path],
  {} ['DISPLAY_PHYSICAL_PATHS         ', clc$nominal_entry, clc$normal_usage_entry, 16,
        clc$automatically_log, clc$linked_call, ^display_physical_path],
  {} ['DISPLAY_RHFAM_CLIENT           ', clc$alias_entry, clc$normal_usage_entry, 17,
        clc$automatically_log, clc$linked_call, ^display_rhfam_clients],
  {} ['DISPLAY_RHFAM_CLIENTS          ', clc$nominal_entry, clc$normal_usage_entry, 17,
        clc$automatically_log, clc$linked_call, ^display_rhfam_clients],
  {} ['DISPLAY_RHFAM_SERVER           ', clc$alias_entry, clc$normal_usage_entry, 18,
        clc$automatically_log, clc$linked_call, ^display_rhfam_servers],
  {} ['DISPLAY_RHFAM_SERVERS          ', clc$nominal_entry, clc$normal_usage_entry, 18,
        clc$automatically_log, clc$linked_call, ^display_rhfam_servers],
  {} ['DISPLAY_TRUNK_STATUS           ', clc$nominal_entry, clc$normal_usage_entry, 19,
        clc$automatically_log, clc$linked_call, ^display_trunk_status],
  {} ['DISPP                          ', clc$abbreviation_entry, clc$normal_usage_entry, 16,
        clc$automatically_log, clc$linked_call, ^display_physical_path],
  {} ['DISRC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 17,
        clc$automatically_log, clc$linked_call, ^display_rhfam_clients],
  {} ['DISRS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 18,
        clc$automatically_log, clc$linked_call, ^display_rhfam_servers],
  {} ['DISTS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 19,
        clc$automatically_log, clc$linked_call, ^display_trunk_status],
  {} ['FORMAT_NAD_DUMP                ', clc$nominal_entry, clc$normal_usage_entry, 20,
        clc$automatically_log, clc$linked_call, ^format_nad_dump],
  {} ['FORND                          ', clc$abbreviation_entry, clc$normal_usage_entry, 20,
        clc$automatically_log, clc$linked_call, ^format_nad_dump],
  {} ['INSRC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 21,
        clc$automatically_log, clc$linked_call, ^rfp$install_rhfam_configuration],
  {} ['INSRCB                         ', clc$abbreviation_entry, clc$hidden_entry, 22,
        clc$automatically_log, clc$linked_call, ^rfp$install_rhf_config_bin],
  {} ['INSTALL_RHFAM_CONFIGURATION    ', clc$nominal_entry, clc$normal_usage_entry, 21,
        clc$automatically_log, clc$linked_call, ^rfp$install_rhfam_configuration],
  {} ['INSTALL_RHFAM_CONFIG_BIN       ', clc$nominal_entry, clc$hidden_entry, 22,
        clc$automatically_log, clc$linked_call, ^rfp$install_rhf_config_bin],
  {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 25,
        clc$automatically_log, clc$linked_call, ^quit],
  {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 25,
        clc$automatically_log, clc$linked_call, ^quit],
  {} ['TESLN                          ', clc$abbreviation_entry, clc$normal_usage_entry, 23,
        clc$automatically_log, clc$linked_call, ^test_local_nad],
  {} ['TEST_LOCAL_NAD                 ', clc$nominal_entry, clc$normal_usage_entry, 23,
        clc$automatically_log, clc$linked_call, ^test_local_nad],
  {} ['VERIFY_RHFAM_CONFIGURATION     ', clc$nominal_entry, clc$normal_usage_entry, 24,
        clc$automatically_log, clc$linked_call, ^rfp$verify_rhfam_configuration],
  {} ['VERRC                          ', clc$abbreviation_entry, clc$normal_usage_entry, 24,
        clc$automatically_log, clc$linked_call, ^rfp$verify_rhfam_configuration]];

  PROCEDURE [XREF] rfp$install_rhfam_configuration
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rfp$install_rhf_config_bin
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] rfp$verify_rhfam_configuration
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??

*DECK DECK=RFD$CDT_VERIFY_DIRECTIVES EXPAND=FALSE

{ table rfv$verify_directives type=command
{ command (define_local_host, deflh) processor=rfp$define_local_host
{ command (define_remote_host, defrh) processor=rfp$define_remote_host
{ command (define_local_nad, defln) processor=rfp$define_local_nad
{ command (define_remote_nad, defrn) processor=rfp$define_remote_nad
{ command (define_lcn_path, deflp) processor=rfp$define_lcn_path
{ command (auto_path_generation, autpg) processor=rfp$auto_path_generation
{ command (quit, q) processor=rfp$vrc_quit

?? PUSH (LISTEXT := ON) ??
VAR
  rfv$verify_directives: [STATIC, READ] ^clt$command_table := ^rfv$verify_directives_entries,

  rfv$verify_directives_entries: [STATIC, READ] array [1 .. 14] of  clt$command_table_entry := [
  {} ['AUTO_PATH_GENERATION           ', clc$nominal_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^rfp$auto_path_generation],
  {} ['AUTPG                          ', clc$abbreviation_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^rfp$auto_path_generation],
  {} ['DEFINE_LCN_PATH                ', clc$nominal_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^rfp$define_lcn_path],
  {} ['DEFINE_LOCAL_HOST              ', clc$nominal_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rfp$define_local_host],
  {} ['DEFINE_LOCAL_NAD               ', clc$nominal_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rfp$define_local_nad],
  {} ['DEFINE_REMOTE_HOST             ', clc$nominal_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rfp$define_remote_host],
  {} ['DEFINE_REMOTE_NAD              ', clc$nominal_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^rfp$define_remote_nad],
  {} ['DEFLH                          ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^rfp$define_local_host],
  {} ['DEFLN                          ', clc$abbreviation_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^rfp$define_local_nad],
  {} ['DEFLP                          ', clc$abbreviation_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^rfp$define_lcn_path],
  {} ['DEFRH                          ', clc$abbreviation_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^rfp$define_remote_host],
  {} ['DEFRN                          ', clc$abbreviation_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^rfp$define_remote_nad],
  {} ['Q                              ', clc$abbreviation_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^rfp$vrc_quit],
  {} ['QUIT                           ', clc$nominal_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^rfp$vrc_quit]];

?? POP ??

*DECK DECK=RFD$MC_INITIALIZATION_PRAMS EXPAND=FALSE

{    DECK:  RFD$MC_INITIALIZATION_PRAMS
{
{    This deck defines the template used to generate the microcode
{    initialization parameters.  Further information on these
{    constants can be obtained in the NAD Hardware reference manuals.


  CONST
      rfc$nad_type_1_buff_lgth = 0810(16);

  CONST
      rfc$nad_type_1_header_lgth = 10(16);

  CONST
      rfc$nad_ctrl_mess_buff_lgth = 30(16);

  CONST
      rfc$min_type_1_buffs = 2;

  CONST
      rfc$max_nad_memory_size = 0ffff(16),
      rfc$default_memory_size = 00ff(16);

  TYPE
      rft$mc_initialization_prams = PACKED RECORD
        memory_size: rft$nad_memory_size,
        fill1: 0..0fff(16),
        tcu_enables: rft$tcu_mask,
        stream_mode: 0..0ffff(16),
        connecting_nads: 0..0ffff(16),
        max_connections: 0..0ffff(16),
        fill2: 0..0ffff(16),
        system_buffers: 0..0ffff(16),
        fill3: 0..0ffff(16),
        control_messages: 0..0ffff(16),
        type_0_buff_size: rft$nad_buffer_size,
        type_0_buff_count: rft$nad_buffer_count,
        type_1_buff_size: rft$nad_buffer_size,
        type_1_buff_count: rft$nad_buffer_count,
        type_2_buff_size: rft$nad_buffer_size,
        type_2_buff_count: rft$nad_buffer_count,
        type_3_buff_size: rft$nad_buffer_size,
        type_3_buff_count: rft$nad_buffer_count,
        fill4: 0..0ffff(16),
        fill5: 0..0ffff(16),
        incoming_control_messages: 0..0ffff(16),
        outgoing_control_messages: 0..0ffff(16),
        send_queue_limit: 0..0ffff(16),
        receive_queue_limit: 0..0ffff(16),
        fill6: 0..1,
        monitor_trace: rft$nad_trace_parameter,
        trunk_trace: rft$nad_trace_parameter,
        device_trace: rft$nad_trace_parameter,
        fill7: 0..0ffff(16),
        fill8: 0..0ffff(16),
        fill9: 0..0ffff(16),
        fill10: 0..0ffff(16),
        dummy_1: 0..0ffff(16),  {  These dummy entries are used to make
        dummy_2: 0..0ffff(16),  {  the init prams a multiple of 6.  This
      RECEND;                   {  is to handle the 12-bit to 16-bit
                                {  transition across the 170 channel.

  TYPE
      rft$nad_buffer_size = 0..0ffff(16);

  TYPE
      rft$nad_buffer_count = 0..0ffff(16);

  TYPE
      rft$nad_memory_size = 0..0ffff(16);

?? PUSH (LISTEXT := ON) ??
*copyc rft$configuration_defs
?? POP ??

*DECK DECK=RFD$NAD_GENERAL_STATUS EXPAND=FALSE

{    DECK : RFD$NAD_GENERAL_STATUS
{
{    This deck defines the fields of a NAD general status entry.
{    Further information on this table can be obtained from the
{    NAD Hardware Reference Manual.

  TYPE
      rft$nad_general_status = PACKED RECORD
        nad_address: rft$nad_address,
        error_queue_entries: 0..0ff(16),
        outgoing_control_messages: 0..0ff(16),
        incoming_control_messages: 0..0ff(16),
        reject_queue_entries: 0..0ff(16),
        retry_queue_entries: 0..0ff(16),
        messages_sent: 0..0ffffffff(16),
        messages_received: 0..0ffffffff(16),
        queue_fulls_sent: 0..0ffff(16),
        queue_fulls_received: 0..0ffff(16),
        nak_responses_sent: 0..0ffff(16),
        nak_responses_received: 0..0ffff(16),
        device_interface_type: 0..0ff(16),
        hardware_unique_identifier: 0..0ff(16),
        unused_memory: 0..0ffff(16),
        microcode_revision_level: 0..3,
        microcode_release_level: 0..3f(16),
        requested_tcus: rft$tcu_mask,
        actual_tcus: rft$tcu_mask,
        connects_received: 0..0ffff(16),
        control_messages_received: 0..0ffff(16),
        data_messages_received: 0..0ffff(16),
        host_inactive_flag: 0..0ffff(16),
        dead_code: 0..0ffff(16),
        fill1: 0..0ffffffffffff(16),
        actual_memory_size: 0..0ffff(16),
        trunk_busy_retries: 0..0ffff(16),
        errlog_entries: SEQ(REP rfc$max_error_log_size OF cell),
      RECEND;

  CONST
      rfc$max_error_log_size = 21*9*2;  { 21 = number of entries
                                        { 9  = number of NAD words per entry
                                        { 2  = number of bytes per NAD word

*DECK DECK=RFD$PATH_STATUS_TABLE EXPAND=FALSE

{    DECK : RFD$PATH_STATUS_TABLE
{
{    This deck contains the various definitions for the Path Control
{    Table that is passed from the NAD on a Read Path Status Table
{    request.  Further information about this table can be obtained
{    from the NAD Hardware Reference Manual.

  TYPE
      rft$path_status_table = PACKED RECORD
        path_state: rft$path_state,
        path_clarifier: rft$path_clarifier,
        send_qcb_address: 0..0ffff(16),
        receive_qcb_address: 0..0ffff(16),
        flags: 0..0ffff(16),
        address: rft$nad_address,
        tcus: rft$tcu_mask,
        destination_device: rft$destination_device_address,
        access_code: rft$nad_access_code,
        name: rft$subsystem_identifier,
        resources: 0..0ffff(16),
        my_id: rft$path_id,
        his_id: rft$path_id,
        receive_code: rft$termination_code,
        send_code: rft$termination_code,
        last_command_received: 0..0ffff(16),
        last_response_sent: 0..0ffff(16),
        unused: 0..0ffff(16),
        queue_fulls_sent: 0..0ffff(16),
        queue_fulls_received: 0..0ffff(16),
        messages_sent: 0..0ffffffff(16),
        messages_received: 0..0ffffffff(16),
      RECEND;


  TYPE
      rft$termination_code = PACKED RECORD
        CASE  rft$termination_type  OF
        = rfc$tt_reject =
          reject_code: rft$reject_code,
        = rfc$tt_abort =
          hop_count : 0..0ff(16),
          nad_address: rft$nad_address,
          logical_network: rft$logical_network,
          reason_code: rft$network_break_reason_code,
        CASEND,
      RECEND;

  TYPE
      rft$termination_type = (rfc$tt_reject, rfc$tt_abort);

  CONST   { path states }

      rfc$ps_unused = 0,
      rfc$ps_connecting = 1,
      rfc$ps_established = 2,
      rfc$ps_flushing = 3,
      rfc$ps_aborted = 4;

  CONST   { unused state clarifiers }

      rfc$pcu_empty = 0;

  CONST   { connecting state clarifiers }

      rfc$pcc_locally_initiated = 0,
      rfc$pcc_sending_connect = 1,
      rfc$pcc_remote_nad_accept = 2,
      rfc$pcc_incoming_connect = 4,
      rfc$pcc_remote_reject = 5,
      rfc$pcc_local_reject = 6,
      rfc$pcc_network_reject = 7;

  CONST   { established state clarifiers }

      rfc$pce_local_host_uninformed = 0,
      rfc$pce_normal = 1,
      rfc$pce_local_disconnect_1 = 2,
      rfc$pce_local_disconnect_2 = 3,
      rfc$pce_remote_streaming = 5,
      rfc$pce_local_streaming = 6,
      rfc$pce_streaming_accepted = 7,
      rfc$pce_incoming_disconnect = 8;

  CONST   { flushing state clarifiers }

      rfc$pcf_purging = 0,
      rfc$pcf_flush_in_progress = 1,
      rfc$pcf_flush_complete = 2,
      rfc$pcf_remote_purge = 3;

  CONST   { abort state clarifiers }

      rfc$pca_during_send = 0,
      rfc$pca_during_receive = 1;


  CONST   { connection termination network reason codes }

      rfc$ctnrc_no_response = 0,
      rfc$ctnrc_local_tci_tcu = 1,
      rfc$ctnrc_garbled_message = 2,
      rfc$ctnrc_remote_nad_dead = 3,
      rfc$ctnrc_remote_not_responding = 4,
      rfc$ctnrc_remote_hdwc_or_fcs = 5,
      rfc$ctnrc_long_haul_failure =8,
      rfc$ctnrc_no_long_haul_response = 9,
      rfc$ctnrc_remote_auto_load = 16,
      rfc$ctnrc_no_remote_pct = 17,
      rfc$ctnrc_invalid_tcus = 18,
      rfc$ctnrc_path_disappeared = 19,
      rfc$ctnrc_host_inactive = 20,
      rfc$ctnrc_controlware_mismatch = 21,
      rfc$ctnrc_no_pct_in_ntn = 24,
      rfc$ctnrc_invalid_tcus_ntn = 25,
      rfc$ctnrc_routing_error_ntn = 26,
      rfc$ctnrc_invalid_connect_ntn = 27,
      rfc$ctnrc_connection_limit_ntn = 28;

  TYPE
      rft$network_failure_symptoms = (rfc$connection_failure, rfc$reserved);



?? PUSH (LISTEXT := ON) ??
*copyc rft$configuration_defs
?? POP ??





*DECK DECK=RFD$PDT_ACTIVATE_RHFAM_CLIENT EXPAND=FALSE

{ PDT activate_rhfam_cli_pdt (
{     client, c : NAME 1..7 = $REQUIRED
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    activate_rhfam_cli_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^activate_rhfam_cli_pdt_names, ^activate_rhfam_cli_pdt_params];

  VAR
    activate_rhfam_cli_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['CLIENT', 1], ['C', 1], ['STATUS', 2]];

  VAR
    activate_rhfam_cli_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
      clt$parameter_descriptor := [

{ CLIENT C }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, 7]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
*DECK DECK=RFD$PDT_ACTIVATE_RHFAM_SERVER EXPAND=FALSE

{ PDT activate_rhfam_ser_pdt (
{     server, s : NAME 1..7 = $REQUIRED
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    activate_rhfam_ser_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^activate_rhfam_ser_pdt_names, ^activate_rhfam_ser_pdt_params];

  VAR
    activate_rhfam_ser_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['SERVER', 1], ['S', 1], ['STATUS', 2]];

  VAR
    activate_rhfam_ser_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
      clt$parameter_descriptor := [

{ SERVER S }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, 7]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
*DECK DECK=RFD$PDT_AUTO_PATH_GENERATION EXPAND=FALSE

{ pdt  auto_path_generation

?? PUSH (LISTEXT := ON) ??

  VAR
    auto_path_generation: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??
*DECK DECK=RFD$PDT_CHANGE_HOST_STATE EXPAND=FALSE

{ PDT change_host_state_pdt (
{     physical_identifier, pid, pi : LIST OF STRING 3 OR KEY ALL = $REQUIRED
{     state, s : KEY ON OFF = $REQUIRED
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    change_host_state_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^change_host_state_pdt_names, ^change_host_state_pdt_params];

  VAR
    change_host_state_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 6] of
      clt$parameter_name_descriptor := [['PHYSICAL_IDENTIFIER', 1], ['PID', 1], ['PI', 1], ['STATE', 2], ['S'
      , 2], ['STATUS', 3]];

  VAR
    change_host_state_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
      clt$parameter_descriptor := [

{ PHYSICAL_IDENTIFIER PID PI }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [^change_host_state_pdt_kv1,
      clc$string_value, 3, 3]],

{ STATE S }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^change_host_state_pdt_kv2, clc$keyword_value
      ]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    change_host_state_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['ALL'
      ];

  VAR
    change_host_state_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := ['ON',
      'OFF'];

?? POP ??
*DECK DECK=RFD$PDT_CHANGE_LID_STATE EXPAND=FALSE

{ PDT change_lid_state_pdt (
{     physical_identifier, pid, pi : LIST OF STRING 3 OR KEY ALL = $REQUIRED
{     logical_identifier, lid, li : LIST OF STRING 1..31 = $REQUIRED
{     state, s : KEY ON OFF = $REQUIRED
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    change_lid_state_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^change_lid_state_pdt_names, ^change_lid_state_pdt_params];

  VAR
    change_lid_state_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 9] of
      clt$parameter_name_descriptor := [['PHYSICAL_IDENTIFIER', 1], ['PID', 1], ['PI', 1], [
      'LOGICAL_IDENTIFIER', 2], ['LID', 2], ['LI', 2], ['STATE', 3], ['S', 3], ['STATUS', 4]];

  VAR
    change_lid_state_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
      clt$parameter_descriptor := [

{ PHYSICAL_IDENTIFIER PID PI }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [^change_lid_state_pdt_kv1,
      clc$string_value, 3, 3]],

{ LOGICAL_IDENTIFIER LID LI }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 1, 31]],

{ STATE S }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^change_lid_state_pdt_kv3, clc$keyword_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    change_lid_state_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := ['ALL'
      ];

  VAR
    change_lid_state_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := ['ON',
      'OFF'];

?? POP ??
*DECK DECK=RFD$PDT_CHANGE_NAD_STATE EXPAND=FALSE

{ PDT change_nad_state_pdt (
{     nad, n : LIST OF NAME = $REQUIRED
{     state, s  : KEY ON OFF DOWN = $REQUIRED
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    change_nad_state_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^change_nad_state_pdt_names, ^change_nad_state_pdt_params];

  VAR
    change_nad_state_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['NAD', 1], ['N', 1], ['STATE', 2], ['S', 2], ['STATUS', 3]];

  VAR
    change_nad_state_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
      clt$parameter_descriptor := [

{ NAD N }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
      osc$max_name_size]],

{ STATE S }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^change_nad_state_pdt_kv2, clc$keyword_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    change_nad_state_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of ost$name := ['ON',
      'OFF','DOWN'];

?? POP ??
*DECK DECK=RFD$PDT_CHANGE_TRUNK_STATE EXPAND=FALSE

{ PDT change_trunk_state_pdt (
{     nad, n : LIST OF NAME OR KEY ALL = ALL
{     trunk, t : LIST OF NAME  = $REQUIRED
{     state, s  : KEY ON OFF = $REQUIRED
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    change_trunk_state_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^change_trunk_state_pdt_names, ^change_trunk_state_pdt_params];

  VAR
    change_trunk_state_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
      clt$parameter_name_descriptor := [['NAD', 1], ['N', 1], ['TRUNK', 2], ['T', 2], ['STATE', 3], ['S', 3],
      ['STATUS', 4]];

  VAR
    change_trunk_state_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
      clt$parameter_descriptor := [

{ NAD N }
    [[clc$optional_with_default, ^change_trunk_state_pdt_dv1], 1, clc$max_value_sets,1, 1,
      clc$value_range_not_allowed, [^change_trunk_state_pdt_kv1, clc$name_value, 1, osc$max_name_size]],

{ TRUNK T }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1,
      osc$max_name_size]],

{ STATE S }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [^change_trunk_state_pdt_kv3, clc$keyword_value
      ]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    change_trunk_state_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := [
      'ALL'];

  VAR
    change_trunk_state_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := ['ON'
      ,'OFF'];

  VAR
    change_trunk_state_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'ALL';

?? POP ??
*DECK DECK=RFD$PDT_DEACTIVATE_RHFAM_CLIENT EXPAND=FALSE

{ PDT deact_rhfam_client_pdt (
{     client, c : NAME 1..7 = $REQUIRED
{     terminate_active_connections, tac : BOOLEAN = FALSE
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    deact_rhfam_client_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^deact_rhfam_client_pdt_names, ^deact_rhfam_client_pdt_params];

  VAR
    deact_rhfam_client_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['CLIENT', 1], ['C', 1], ['TERMINATE_ACTIVE_CONNECTIONS', 2], ['TAC',
      2], ['STATUS', 3]];

  VAR
    deact_rhfam_client_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
      clt$parameter_descriptor := [

{ CLIENT C }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, 7]],

{ TERMINATE_ACTIVE_CONNECTIONS TAC }
    [[clc$optional_with_default, ^deact_rhfam_client_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$boolean_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    deact_rhfam_client_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'FALSE';

?? POP ??
*DECK DECK=RFD$PDT_DEACTIVATE_RHFAM_SERVER EXPAND=FALSE
{
{ PDT deact_rhfam_server_pdt (
{     server, s : NAME 1..7 = $REQUIRED
{     terminate_active_connections, tac : BOOLEAN = FALSE
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    deact_rhfam_server_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^deact_rhfam_server_pdt_names, ^deact_rhfam_server_pdt_params];

  VAR
    deact_rhfam_server_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['SERVER', 1], ['S', 1], ['TERMINATE_ACTIVE_CONNECTIONS', 2], ['TAC',
      2], ['STATUS', 3]];

  VAR
    deact_rhfam_server_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
      clt$parameter_descriptor := [

{ SERVER S }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, 7]],

{ TERMINATE_ACTIVE_CONNECTIONS TAC }
    [[clc$optional_with_default, ^deact_rhfam_server_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$boolean_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    deact_rhfam_server_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'FALSE';

?? POP ??
*DECK DECK=RFD$PDT_DEFINE_LCN_PATH EXPAND=FALSE

{ pdt define_lcn_path   (local_nad, ln: name = $required
{                        remote_nad, rn: name = $required
{                        exclude_trunk, et: list 1..3 of name = $optional
{                        physical_identifier, pid, pi: string 3 = $optional
{                        host_connection, hc: integer 0..3 = 0
{                        logical_network, lnet: integer 0..0FF(16) = 0
{                        logical_nad, lnad: integer 0..0FF(16) = 0
{                        access_code, ac: integer 0..0FFFF(16) = 0)

?? PUSH (LISTEXT := ON) ??

  VAR
    define_lcn_path: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^define_lcn_path_names,
      ^define_lcn_path_params];

  VAR
    define_lcn_path_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 17] of
      clt$parameter_name_descriptor := [['LOCAL_NAD', 1], ['LN', 1], ['REMOTE_NAD', 2], ['RN', 2], [
      'EXCLUDE_TRUNK', 3], ['ET', 3], ['PHYSICAL_IDENTIFIER', 4], ['PID', 4], ['PI', 4], ['HOST_CONNECTION', 5
      ], ['HC', 5], ['LOGICAL_NETWORK', 6], ['LNET', 6], ['LOGICAL_NAD', 7], ['LNAD', 7], ['ACCESS_CODE', 8],
      ['AC', 8]];

  VAR
    define_lcn_path_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 8] of clt$parameter_descriptor := [

{ LOCAL_NAD LN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ REMOTE_NAD RN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ EXCLUDE_TRUNK ET }
    [[clc$optional], 1, 3, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ PHYSICAL_IDENTIFIER PID PI }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 3, 3]],

{ HOST_CONNECTION HC }
    [[clc$optional_with_default, ^define_lcn_path_dv5], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 3]],

{ LOGICAL_NETWORK LNET }
    [[clc$optional_with_default, ^define_lcn_path_dv6], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 0FF(16)]],

{ LOGICAL_NAD LNAD }
    [[clc$optional_with_default, ^define_lcn_path_dv7], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 0FF(16)]],

{ ACCESS_CODE AC }
    [[clc$optional_with_default, ^define_lcn_path_dv8], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 0FFFF(16)]]];

  VAR
    define_lcn_path_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    define_lcn_path_dv6: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    define_lcn_path_dv7: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    define_lcn_path_dv8: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

?? POP ??
*DECK DECK=RFD$PDT_DEFINE_LOCAL_HOST EXPAND=FALSE

{ pdt define_local_host (physical_identifier, pid, pi : string 3 = $required
{                        logical_identifiers, logical_identifier, lid, ..
{                           li : list of string 1..31 = $required
{                        connection_password, cp : name 7 = passwrd
{                        subsystem_identifier, si : name 2 = rh
{                        connection_timeout, ct : integer 10..1800 = 30
{                        data_transfer_timeout, dtt : integer 30..3600 = 600)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    define_local_host: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^define_local_host_names,
  ^define_local_host_params];

  VAR
    define_local_host_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 15] of
  clt$parameter_name_descriptor := [['PHYSICAL_IDENTIFIER', 1], ['PID', 1], ['PI', 1], ['LOGICAL_IDENTIFIERS'
  , 2], ['LOGICAL_IDENTIFIER', 2], ['LID', 2], ['LI', 2], ['CONNECTION_PASSWORD', 3], ['CP', 3], [
  'SUBSYSTEM_IDENTIFIER', 4], ['SI', 4], ['CONNECTION_TIMEOUT', 5], ['CT', 5], ['DATA_TRANSFER_TIMEOUT', 6], [
  'DTT', 6]];

  VAR
    define_local_host_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 6] of clt$parameter_descriptor
  := [

{ PHYSICAL_IDENTIFIER PID PI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 3, 3]],

{ LOGICAL_IDENTIFIERS LOGICAL_IDENTIFIER LID LI }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 1, 31]],

{ CONNECTION_PASSWORD CP }
    [[clc$optional_with_default, ^define_local_host_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$name_value, 7, 7]],

{ SUBSYSTEM_IDENTIFIER SI }
    [[clc$optional_with_default, ^define_local_host_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$name_value, 2, 2]],

{ CONNECTION_TIMEOUT CT }
    [[clc$optional_with_default, ^define_local_host_dv5], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, 10, 1800]],

{ DATA_TRANSFER_TIMEOUT DTT }
    [[clc$optional_with_default, ^define_local_host_dv6], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$integer_value, 30, 3600]]];

  VAR
    define_local_host_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := 'passwrd';

  VAR
    define_local_host_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := 'rh';

  VAR
    define_local_host_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := '30';

  VAR
    define_local_host_dv6: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := '600';

?? FMT (FORMAT := ON) ??
?? POP ??
*DECK DECK=RFD$PDT_DEFINE_LOCAL_NAD EXPAND=FALSE

{ pdt define_local_nad (nad, n : name = $required
{                       address, a : integer 1..0ff(16) = $required
{                       trunk_control_unit_0, tcu0 : name = $optional
{                       trunk_control_unit_1, tcu1 : name = $optional
{                       trunk_control_unit_2, tcu2 : name = $optional
{                       trunk_control_unit_3, tcu3 : name = $optional
{                       tcu_access_code_0, tac0 : integer 0..0ffff(16) = 0
{                       tcu_access_code_1, tac1 : integer 0..0ffff(16) = 0
{                       tcu_access_code_2, tac2 : integer 0..0ffff(16) = 0
{                       tcu_access_code_3, tac3 : integer 0..0ffff(16) = 0
{                       pp_drivers, pd : integer 1..2 = 1
{                       perform_auto_reload, par : boolean = TRUE
{                       reload_threshold, rt : integer 1..99 = 10
{                       dump_disposition, dd : key DISCARD,SAVE_LAST,SAVE_ALL = DISCARD
{                       maximum_connections, mc : integer 2..127 = 35
{                       maximum_nad_entries, mne : integer 2..255 = 25
{                       send_queue_limit, sql : integer 1..127 = 2
{                       receive_queue_limit, rql : integer 1..127 = 2
{                       monitor_trace, mt : integer 0..31 = 0
{                       trunk_trace, tt : integer 0..31 = 0
{                       device_trace, dt : integer 0..31 = 0)

?? PUSH (LISTEXT := ON) ??

  VAR
    define_local_nad: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^define_local_nad_names,
      ^define_local_nad_params];

  VAR
    define_local_nad_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 42] of
      clt$parameter_name_descriptor := [['NAD', 1], ['N', 1], ['ADDRESS', 2], ['A', 2], [
      'TRUNK_CONTROL_UNIT_0', 3], ['TCU0', 3], ['TRUNK_CONTROL_UNIT_1', 4], ['TCU1', 4], [
      'TRUNK_CONTROL_UNIT_2', 5], ['TCU2', 5], ['TRUNK_CONTROL_UNIT_3', 6], ['TCU3', 6], ['TCU_ACCESS_CODE_0'
      , 7], ['TAC0', 7], ['TCU_ACCESS_CODE_1', 8], ['TAC1', 8], ['TCU_ACCESS_CODE_2', 9], ['TAC2', 9], [
      'TCU_ACCESS_CODE_3', 10], ['TAC3', 10], ['PP_DRIVERS', 11], ['PD', 11], ['PERFORM_AUTO_RELOAD', 12], [
      'PAR', 12], ['RELOAD_THRESHOLD', 13], ['RT', 13], ['DUMP_DISPOSITION', 14], ['DD', 14], [
      'MAXIMUM_CONNECTIONS', 15], ['MC', 15], ['MAXIMUM_NAD_ENTRIES', 16], ['MNE', 16], ['SEND_QUEUE_LIMIT',
      17], ['SQL', 17], ['RECEIVE_QUEUE_LIMIT', 18], ['RQL', 18], ['MONITOR_TRACE', 19], ['MT', 19], [
      'TRUNK_TRACE', 20], ['TT', 20], ['DEVICE_TRACE', 21], ['DT', 21]];

  VAR
    define_local_nad_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 21] of clt$parameter_descriptor
      := [

{ NAD N }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ ADDRESS A }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 1, 0ff(16)]],

{ TRUNK_CONTROL_UNIT_0 TCU0 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ TRUNK_CONTROL_UNIT_1 TCU1 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ TRUNK_CONTROL_UNIT_2 TCU2 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ TRUNK_CONTROL_UNIT_3 TCU3 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ TCU_ACCESS_CODE_0 TAC0 }
    [[clc$optional_with_default, ^define_local_nad_dv7], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 0ffff(16)]],

{ TCU_ACCESS_CODE_1 TAC1 }
    [[clc$optional_with_default, ^define_local_nad_dv8], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 0ffff(16)]],

{ TCU_ACCESS_CODE_2 TAC2 }
    [[clc$optional_with_default, ^define_local_nad_dv9], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 0ffff(16)]],

{ TCU_ACCESS_CODE_3 TAC3 }
    [[clc$optional_with_default, ^define_local_nad_dv10], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 0ffff(16)]],

{ PP_DRIVERS PD }
    [[clc$optional_with_default, ^define_local_nad_dv11], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 1, 2]],

{ PERFORM_AUTO_RELOAD PAR }
    [[clc$optional_with_default, ^define_local_nad_dv12], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$boolean_value]],

{ RELOAD_THRESHOLD RT }
    [[clc$optional_with_default, ^define_local_nad_dv13], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 1, 99]],

{ DUMP_DISPOSITION DD }
    [[clc$optional_with_default, ^define_local_nad_dv14], 1, 1, 1, 1, clc$value_range_not_allowed, [^
      define_local_nad_kv14, clc$keyword_value]],

{ MAXIMUM_CONNECTIONS MC }
    [[clc$optional_with_default, ^define_local_nad_dv15], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 2, 127]],

{ MAXIMUM_NAD_ENTRIES MNE }
    [[clc$optional_with_default, ^define_local_nad_dv16], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 2, 255]],

{ SEND_QUEUE_LIMIT SQL }
    [[clc$optional_with_default, ^define_local_nad_dv17], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 1, 127]],

{ RECEIVE_QUEUE_LIMIT RQL }
    [[clc$optional_with_default, ^define_local_nad_dv18], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 1, 127]],

{ MONITOR_TRACE MT }
    [[clc$optional_with_default, ^define_local_nad_dv19], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 31]],

{ TRUNK_TRACE TT }
    [[clc$optional_with_default, ^define_local_nad_dv20], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 31]],

{ DEVICE_TRACE DT }
    [[clc$optional_with_default, ^define_local_nad_dv21], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 31]]];

  VAR
    define_local_nad_kv14: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of ost$name := ['DISCARD'
      ,'SAVE_LAST','SAVE_ALL'];

  VAR
    define_local_nad_dv7: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    define_local_nad_dv8: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    define_local_nad_dv9: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    define_local_nad_dv10: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    define_local_nad_dv11: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '1';

  VAR
    define_local_nad_dv12: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'TRUE';

  VAR
    define_local_nad_dv13: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := '10';

  VAR
    define_local_nad_dv14: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := 'DISCARD';

  VAR
    define_local_nad_dv15: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := '35';

  VAR
    define_local_nad_dv16: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := '25';

  VAR
    define_local_nad_dv17: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '2';

  VAR
    define_local_nad_dv18: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '2';

  VAR
    define_local_nad_dv19: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    define_local_nad_dv20: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    define_local_nad_dv21: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

?? POP ??
*DECK DECK=RFD$PDT_DEFINE_REMOTE_HOST EXPAND=FALSE

{ pdt define_remote_host (physical_identifier, pid, pi : string 3 = $required
{                         logical_identifiers, logical_identifier, lid, ..
{                            li : list of string 1..31 = $required)

?? PUSH (LISTEXT := ON) ??

  VAR
    define_remote_host: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^define_remote_host_names,
  ^define_remote_host_params];

  VAR
    define_remote_host_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
      clt$parameter_name_descriptor := [['PHYSICAL_IDENTIFIER', 1], ['PID', 1], ['PI', 1], [
      'LOGICAL_IDENTIFIERS', 2], ['LOGICAL_IDENTIFIER', 2], ['LID', 2], ['LI', 2]];

  VAR
    define_remote_host_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor
  := [

{ PHYSICAL_IDENTIFIER PID PI }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 3, 3]],

{ LOGICAL_IDENTIFIERS LOGICAL_IDENTIFIER LID LI }
    [[clc$required], 1, clc$max_value_sets,1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 1, 31
      ]]];

?? POP ??
*DECK DECK=RFD$PDT_DEFINE_REMOTE_NAD EXPAND=FALSE

{ pdt define_remote_nad     (nad, n : name = $required
{                            address, a : integer 1..0ff(16) = $required
{                            host_connection_0, hc0 : string 3 = $optional
{                            host_connection_1, hc1 : string 3 = $optional
{                            host_connection_2, hc2 : string 3 = $optional
{                            host_connection_3, hc3 : string 3 = $optional
{                            trunk_control_unit_0, tcu0 : name = $optional
{                            trunk_control_unit_1, tcu1 : name = $optional
{                            trunk_control_unit_2, tcu2 : name = $optional
{                            trunk_control_unit_3, tcu3 : name = $optional
{                            nad_type, nt : key C170,C180,IBM,VAX,C200,NTN,INET = C180
{                            tcu_access_code_0, tac0 : integer 0..0ffff(16) = 0
{                            tcu_access_code_1, tac1 : integer 0..0ffff(16) = 0
{                            tcu_access_code_2, tac2 : integer 0..0ffff(16) = 0
{                            tcu_access_code_3, tac3 : integer 0..0ffff(16) = 0)

?? PUSH (LISTEXT := ON) ??

  VAR
    define_remote_nad: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^define_remote_nad_names,
      ^define_remote_nad_params];

  VAR
    define_remote_nad_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 30] of
      clt$parameter_name_descriptor := [['NAD', 1], ['N', 1], ['ADDRESS', 2], ['A', 2], ['HOST_CONNECTION_0',
      3], ['HC0', 3], ['HOST_CONNECTION_1', 4], ['HC1', 4], ['HOST_CONNECTION_2', 5], ['HC2', 5], [
      'HOST_CONNECTION_3', 6], ['HC3', 6], ['TRUNK_CONTROL_UNIT_0', 7], ['TCU0', 7], ['TRUNK_CONTROL_UNIT_1',
      8], ['TCU1', 8], ['TRUNK_CONTROL_UNIT_2', 9], ['TCU2', 9], ['TRUNK_CONTROL_UNIT_3', 10], ['TCU3', 10], [
      'NAD_TYPE', 11], ['NT', 11], ['TCU_ACCESS_CODE_0', 12], ['TAC0', 12], ['TCU_ACCESS_CODE_1', 13], ['TAC1'
      , 13], ['TCU_ACCESS_CODE_2', 14], ['TAC2', 14], ['TCU_ACCESS_CODE_3', 15], ['TAC3', 15]];

  VAR
    define_remote_nad_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 15] of clt$parameter_descriptor
      := [

{ NAD N }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ ADDRESS A }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 1, 0ff(16)]],

{ HOST_CONNECTION_0 HC0 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 3, 3]],

{ HOST_CONNECTION_1 HC1 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 3, 3]],

{ HOST_CONNECTION_2 HC2 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 3, 3]],

{ HOST_CONNECTION_3 HC3 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$string_value, 3, 3]],

{ TRUNK_CONTROL_UNIT_0 TCU0 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ TRUNK_CONTROL_UNIT_1 TCU1 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ TRUNK_CONTROL_UNIT_2 TCU2 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ TRUNK_CONTROL_UNIT_3 TCU3 }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ NAD_TYPE NT }
    [[clc$optional_with_default, ^define_remote_nad_dv11], 1, 1, 1, 1, clc$value_range_not_allowed, [^
      define_remote_nad_kv11, clc$keyword_value]],

{ TCU_ACCESS_CODE_0 TAC0 }
    [[clc$optional_with_default, ^define_remote_nad_dv12], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 0ffff(16)]],

{ TCU_ACCESS_CODE_1 TAC1 }
    [[clc$optional_with_default, ^define_remote_nad_dv13], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 0ffff(16)]],

{ TCU_ACCESS_CODE_2 TAC2 }
    [[clc$optional_with_default, ^define_remote_nad_dv14], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 0ffff(16)]],

{ TCU_ACCESS_CODE_3 TAC3 }
    [[clc$optional_with_default, ^define_remote_nad_dv15], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 0ffff(16)]]];

  VAR
    define_remote_nad_kv11: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of ost$name := ['C170',
      'C180','IBM','VAX','C200','NTN','INET'];

  VAR
    define_remote_nad_dv11: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'C180';

  VAR
    define_remote_nad_dv12: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    define_remote_nad_dv13: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    define_remote_nad_dv14: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    define_remote_nad_dv15: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

?? POP ??
*DECK DECK=RFD$PDT_DEFINE_RHFAM_CLIENT EXPAND=FALSE

{   PDT define_rhfam_client_pdt (
{   client, c                  : NAME 1..7 = $REQUIRED
{   maximum_connections, mc    : INTEGER 1..255 = 255
{   user_capability, uc        : NAME OR KEY none = none
{   ring, r                    : INTEGER 1..15 = 13
{   system_privilege, sp       : BOOLEAN = FALSE
{   system_wide_connection_mgmt, swcm  : BOOLEAN = FALSE
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    define_rhfam_client_pdt: [STATIC, READ, cls$pdt]
  clt$parameter_descriptor_table := [^define_rhfam_client_pdt_names,
  ^define_rhfam_client_pdt_params];

  VAR
    define_rhfam_client_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults]
  array [1 .. 13] of clt$parameter_name_descriptor := [['CLIENT', 1], ['C', 1]
  , ['MAXIMUM_CONNECTIONS', 2], ['MC', 2], ['USER_CAPABILITY', 3], ['UC', 3], [
  'RING', 4], ['R', 4], ['SYSTEM_PRIVILEGE', 5], ['SP', 5], [
  'SYSTEM_WIDE_CONNECTION_MGMT', 6], ['SWCM', 6], ['STATUS', 7]];

  VAR
    define_rhfam_client_pdt_params: [STATIC, READ, cls$pdt_parameters] array [
  1 .. 7] of clt$parameter_descriptor := [

{ CLIENT C }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$name_value, 1, 7]],

{ MAXIMUM_CONNECTIONS MC }
    [[clc$optional_with_default, ^define_rhfam_client_pdt_dv2], 1, 1, 1, 1,
  clc$value_range_not_allowed, [NIL, clc$integer_value, 1, 255]],

{ USER_CAPABILITY UC }
    [[clc$optional_with_default, ^define_rhfam_client_pdt_dv3], 1, 1, 1, 1,
  clc$value_range_not_allowed, [^define_rhfam_client_pdt_kv3, clc$name_value,
  1, osc$max_name_size]],

{ RING R }
    [[clc$optional_with_default, ^define_rhfam_client_pdt_dv4], 1, 1, 1, 1,
  clc$value_range_not_allowed, [NIL, clc$integer_value, 1, 15]],

{ SYSTEM_PRIVILEGE SP }
    [[clc$optional_with_default, ^define_rhfam_client_pdt_dv5], 1, 1, 1, 1,
  clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ SYSTEM_WIDE_CONNECTION_MGMT SWCM }
    [[clc$optional_with_default, ^define_rhfam_client_pdt_dv6], 1, 1, 1, 1,
  clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

  VAR
    define_rhfam_client_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults]
  array [1 .. 1] of ost$name := ['NONE'];

  VAR
    define_rhfam_client_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults
  ] string (3) := '255';

  VAR
    define_rhfam_client_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults
  ] string (4) := 'none';

  VAR
    define_rhfam_client_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults
  ] string (2) := '13';

  VAR
    define_rhfam_client_pdt_dv5: [STATIC, READ, cls$pdt_names_and_defaults
  ] string (5) := 'FALSE';

  VAR
    define_rhfam_client_pdt_dv6: [STATIC, READ, cls$pdt_names_and_defaults
  ] string (5) := 'FALSE';

?? FMT (FORMAT := ON) ??
?? POP ??
*DECK DECK=RFD$PDT_DEFINE_RHFAM_SERVER EXPAND=FALSE

{ PDT define_rhfam_server_pdt (
{     server, s : NAME 1..7 = $REQUIRED
{     rhfam_initiated, ri : BOOLEAN = TRUE
{     maximum_connections, mc : INTEGER 1..255 = 255
{     user_capability, uc : NAME OR KEY none = none
{     ring, r : INTEGER 1..15 = 13
{     system_privilege, sp : BOOLEAN = FALSE
{     server_job, sj : FILE = $OPTIONAL
{     server_job_maximum_connections, sjmc : INTEGER 1..255 = 255
{     accept_connection, ac : BOOLEAN = TRUE
{     rhfam_validates_connection_lid, rvcl : BOOLEAN = TRUE
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    define_rhfam_server_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^define_rhfam_server_pdt_names, ^define_rhfam_server_pdt_params];

  VAR
    define_rhfam_server_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 21] of
      clt$parameter_name_descriptor := [['SERVER', 1], ['S', 1], ['RHFAM_INITIATED', 2], ['RI', 2], [
      'MAXIMUM_CONNECTIONS', 3], ['MC', 3], ['USER_CAPABILITY', 4], ['UC', 4], ['RING', 5], ['R', 5], [
      'SYSTEM_PRIVILEGE', 6], ['SP', 6], ['SERVER_JOB', 7], ['SJ', 7], ['SERVER_JOB_MAXIMUM_CONNECTIONS', 8],
      ['SJMC', 8], ['ACCEPT_CONNECTION', 9], ['AC', 9], ['RHFAM_VALIDATES_CONNECTION_LID', 10], ['RVCL', 10],
      ['STATUS', 11]];

  VAR
    define_rhfam_server_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 11] of
      clt$parameter_descriptor := [

{ SERVER S }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, 7]],

{ RHFAM_INITIATED RI }
    [[clc$optional_with_default, ^define_rhfam_server_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
      [NIL, clc$boolean_value]],

{ MAXIMUM_CONNECTIONS MC }
    [[clc$optional_with_default, ^define_rhfam_server_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed,
      [NIL, clc$integer_value, 1, 255]],

{ USER_CAPABILITY UC }
    [[clc$optional_with_default, ^define_rhfam_server_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [^
      define_rhfam_server_pdt_kv4, clc$name_value, 1, osc$max_name_size]],

{ RING R }
    [[clc$optional_with_default, ^define_rhfam_server_pdt_dv5], 1, 1, 1, 1, clc$value_range_not_allowed,
      [NIL, clc$integer_value, 1, 15]],

{ SYSTEM_PRIVILEGE SP }
    [[clc$optional_with_default, ^define_rhfam_server_pdt_dv6], 1, 1, 1, 1, clc$value_range_not_allowed,
      [NIL, clc$boolean_value]],

{ SERVER_JOB SJ }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ SERVER_JOB_MAXIMUM_CONNECTIONS SJMC }
    [[clc$optional_with_default, ^define_rhfam_server_pdt_dv8], 1, 1, 1, 1, clc$value_range_not_allowed,
      [NIL, clc$integer_value, 1, 255]],

{ ACCEPT_CONNECTION AC }
    [[clc$optional_with_default, ^define_rhfam_server_pdt_dv9], 1, 1, 1, 1, clc$value_range_not_allowed,
      [NIL, clc$boolean_value]],

{ RHFAM_VALIDATES_CONNECTION_LID }
    [[clc$optional_with_default, ^define_rhfam_server_pdt_dv10], 1, 1, 1, 1, clc$value_range_not_allowed,
      [NIL, clc$boolean_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    define_rhfam_server_pdt_kv4: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := [
      'NONE'];

  VAR
    define_rhfam_server_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'TRUE';

  VAR
    define_rhfam_server_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := '255';

  VAR
    define_rhfam_server_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'none';

  VAR
    define_rhfam_server_pdt_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := '13';

  VAR
    define_rhfam_server_pdt_dv6: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'FALSE';

  VAR
    define_rhfam_server_pdt_dv8: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := '255';

  VAR
    define_rhfam_server_pdt_dv9: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'TRUE';

  VAR
    define_rhfam_server_pdt_dv10: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'TRUE';

?? POP ??
*DECK DECK=RFD$PDT_DELETE_RHFAM_CLIENT EXPAND=FALSE

{ PDT delete_rhfam_client_pdt (
{     client, c : NAME 1..7 = $REQUIRED
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    delete_rhfam_client_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^delete_rhfam_client_pdt_names, ^delete_rhfam_client_pdt_params];

  VAR
    delete_rhfam_client_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['CLIENT', 1], ['C', 1], ['STATUS', 2]];

  VAR
    delete_rhfam_client_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
      clt$parameter_descriptor := [

{ CLIENT C }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, 7]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
*DECK DECK=RFD$PDT_DELETE_RHFAM_SERVER EXPAND=FALSE

{ PDT delete_rhfam_server_pdt (
{     server, s : NAME 1..7 = $REQUIRED
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    delete_rhfam_server_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^delete_rhfam_server_pdt_names, ^delete_rhfam_server_pdt_params];

  VAR
    delete_rhfam_server_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['SERVER', 1], ['S', 1], ['STATUS', 2]];

  VAR
    delete_rhfam_server_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of
      clt$parameter_descriptor := [

{ SERVER S }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, 7]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
*DECK DECK=RFD$PDT_DISPLAY_ACTIVE_APPL EXPAND=FALSE

{ PDT display_active_appl_pdt (
{     job_name, jn : LIST OF NAME  OR  KEY ALL = ALL
{     application_name, an : LIST OF NAME 1..7  OR  KEY ALL = ALL
{     display_option, do : KEY applications a connections c = a
{     output, o : FILE = $OUTPUT
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    display_active_appl_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^display_active_appl_pdt_names, ^display_active_appl_pdt_params];

  VAR
    display_active_appl_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 9] of
      clt$parameter_name_descriptor := [['JOB_NAME', 1], ['JN', 1], ['APPLICATION_NAME', 2], ['AN', 2], [
      'DISPLAY_OPTION', 3], ['DO', 3], ['OUTPUT', 4], ['O', 4], ['STATUS', 5]];

  VAR
    display_active_appl_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of
      clt$parameter_descriptor := [

{ JOB_NAME JN }
    [[clc$optional_with_default, ^display_active_appl_pdt_dv1], 1, clc$max_value_sets,1, 1,
      clc$value_range_not_allowed, [^display_active_appl_pdt_kv1, clc$name_value, 1, osc$max_name_size]],

{ APPLICATION_NAME AN }
    [[clc$optional_with_default, ^display_active_appl_pdt_dv2], 1, clc$max_value_sets,1, 1,
      clc$value_range_not_allowed, [^display_active_appl_pdt_kv2, clc$name_value, 1, 7]],

{ DISPLAY_OPTION DO }
    [[clc$optional_with_default, ^display_active_appl_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [^
      display_active_appl_pdt_kv3, clc$keyword_value]],

{ OUTPUT O }
    [[clc$optional_with_default, ^display_active_appl_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed,
      [NIL, clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    display_active_appl_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := [
      'ALL'];

  VAR
    display_active_appl_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := [
      'ALL'];

  VAR
    display_active_appl_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := [
      'APPLICATIONS','A','CONNECTIONS','C'];

  VAR
    display_active_appl_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'ALL';

  VAR
    display_active_appl_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'ALL';

  VAR
    display_active_appl_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := 'a';

  VAR
    display_active_appl_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??
*DECK DECK=RFD$PDT_DISPLAY_LOGICAL_IDS EXPAND=FALSE

{ PDT display_logical_id_pdt (
{     physical_identifier, pid, pi : LIST OF STRING 3 OR KEY ALL LOCAL = ALL
{     logical_identifier, lid, li : LIST OF STRING 1..31 OR KEY ALL NONE = ALL
{     display_option, do : KEY ACTIVE A INSTALLED I = ACTIVE
{     output, o : FILE = $OUTPUT
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    display_logical_id_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^display_logical_id_pdt_names, ^display_logical_id_pdt_params];

  VAR
    display_logical_id_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 11] of
      clt$parameter_name_descriptor := [['PHYSICAL_IDENTIFIER', 1], ['PID', 1], ['PI', 1], [
      'LOGICAL_IDENTIFIER', 2], ['LID', 2], ['LI', 2], ['DISPLAY_OPTION', 3], ['DO', 3], ['OUTPUT', 4], ['O',
      4], ['STATUS', 5]];

  VAR
    display_logical_id_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of
      clt$parameter_descriptor := [

{ PHYSICAL_IDENTIFIER PID PI }
    [[clc$optional_with_default, ^display_logical_id_pdt_dv1], 1, clc$max_value_sets,1, 1,
      clc$value_range_not_allowed, [^display_logical_id_pdt_kv1, clc$string_value, 3, 3]],

{ LOGICAL_IDENTIFIER LID LI }
    [[clc$optional_with_default, ^display_logical_id_pdt_dv2], 1, clc$max_value_sets,1, 1,
      clc$value_range_not_allowed, [^display_logical_id_pdt_kv2, clc$string_value, 1, 31]],

{ DISPLAY_OPTION DO }
    [[clc$optional_with_default, ^display_logical_id_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [^
      display_logical_id_pdt_kv3, clc$keyword_value]],

{ OUTPUT O }
    [[clc$optional_with_default, ^display_logical_id_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    display_logical_id_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := [
      'ALL','LOCAL'];

  VAR
    display_logical_id_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := [
      'ALL','NONE'];

  VAR
    display_logical_id_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := [
      'ACTIVE','A','INSTALLED','I'];

  VAR
    display_logical_id_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'ALL';

  VAR
    display_logical_id_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'ALL';

  VAR
    display_logical_id_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (6) := 'ACTIVE';

  VAR
    display_logical_id_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??
*DECK DECK=RFD$PDT_DISPLAY_NAD_STATUS EXPAND=FALSE

{ PDT display_nad_status_pdt (
{     local_nad, ln : LIST OF NAME OR KEY ALL NONE = ALL
{     remote_nad, rn : LIST OF NAME OR KEY ALL NONE = ALL
{     display_option, do : KEY BRIEF B FULL F = BRIEF
{     output, o : FILE = $OUTPUT
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    display_nad_status_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^display_nad_status_pdt_names, ^display_nad_status_pdt_params];

  VAR
    display_nad_status_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 9] of
      clt$parameter_name_descriptor := [['LOCAL_NAD', 1], ['LN', 1], ['REMOTE_NAD', 2], ['RN', 2], [
      'DISPLAY_OPTION', 3], ['DO', 3], ['OUTPUT', 4], ['O', 4], ['STATUS', 5]];

  VAR
    display_nad_status_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of
      clt$parameter_descriptor := [

{ LOCAL_NAD LN }
    [[clc$optional_with_default, ^display_nad_status_pdt_dv1], 1, clc$max_value_sets,1, 1,
      clc$value_range_not_allowed, [^display_nad_status_pdt_kv1, clc$name_value, 1, osc$max_name_size]],

{ REMOTE_NAD RN }
    [[clc$optional_with_default, ^display_nad_status_pdt_dv2], 1, clc$max_value_sets,1, 1,
      clc$value_range_not_allowed, [^display_nad_status_pdt_kv2, clc$name_value, 1, osc$max_name_size]],

{ DISPLAY_OPTION DO }
    [[clc$optional_with_default, ^display_nad_status_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [^
      display_nad_status_pdt_kv3, clc$keyword_value]],

{ OUTPUT O }
    [[clc$optional_with_default, ^display_nad_status_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    display_nad_status_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := [
      'ALL','NONE'];

  VAR
    display_nad_status_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := [
      'ALL','NONE'];

  VAR
    display_nad_status_pdt_kv3: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := [
      'BRIEF','B','FULL','F'];

  VAR
    display_nad_status_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'ALL';

  VAR
    display_nad_status_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'ALL';

  VAR
    display_nad_status_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'BRIEF';

  VAR
    display_nad_status_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??
*DECK DECK=RFD$PDT_DISPLAY_PHYSICAL_PATHS EXPAND=FALSE

{ PDT display_phys_paths_pdt (
{     physical_identifier, pid, pi : LIST OF STRING 3 OR KEY ALL LOCAL = ALL
{     display_option, do : KEY ACTIVE A INSTALLED I = ACTIVE
{     output, o : FILE = $OUTPUT
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    display_phys_paths_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^display_phys_paths_pdt_names, ^display_phys_paths_pdt_params];

  VAR
    display_phys_paths_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 8] of
      clt$parameter_name_descriptor := [['PHYSICAL_IDENTIFIER', 1], ['PID', 1], ['PI', 1], ['DISPLAY_OPTION',
      2], ['DO', 2], ['OUTPUT', 3], ['O', 3], ['STATUS', 4]];

  VAR
    display_phys_paths_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
      clt$parameter_descriptor := [

{ PHYSICAL_IDENTIFIER PID PI }
    [[clc$optional_with_default, ^display_phys_paths_pdt_dv1], 1, clc$max_value_sets,1, 1,
      clc$value_range_not_allowed, [^display_phys_paths_pdt_kv1, clc$string_value, 3, 3]],

{ DISPLAY_OPTION DO }
    [[clc$optional_with_default, ^display_phys_paths_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [^
      display_phys_paths_pdt_kv2, clc$keyword_value]],

{ OUTPUT O }
    [[clc$optional_with_default, ^display_phys_paths_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    display_phys_paths_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of ost$name := [
      'ALL','LOCAL'];

  VAR
    display_phys_paths_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := [
      'ACTIVE','A','INSTALLED','I'];

  VAR
    display_phys_paths_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'ALL';

  VAR
    display_phys_paths_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (6) := 'ACTIVE';

  VAR
    display_phys_paths_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??
*DECK DECK=RFD$PDT_DISPLAY_RHFAM_CLIENTS EXPAND=FALSE

{ PDT display_rhfam_client_pdt (
{     client, c : LIST OF NAME 1 .. 7 OR KEY ALL = ALL
{     output, o : FILE = $OUTPUT
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    display_rhfam_client_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^display_rhfam_client_pdt_names, ^display_rhfam_client_pdt_params];

  VAR
    display_rhfam_client_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['CLIENT', 1], ['C', 1], ['OUTPUT', 2], ['O', 2], ['STATUS', 3]];

  VAR
    display_rhfam_client_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
      clt$parameter_descriptor := [

{ CLIENT C }
    [[clc$optional_with_default, ^display_rhfam_client_pdt_dv1], 1, clc$max_value_sets,1, 1,
      clc$value_range_not_allowed, [^display_rhfam_client_pdt_kv1, clc$name_value, 1, 7]],

{ OUTPUT O }
    [[clc$optional_with_default, ^display_rhfam_client_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
      [NIL, clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    display_rhfam_client_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := [
      'ALL'];

  VAR
    display_rhfam_client_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'ALL';

  VAR
    display_rhfam_client_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??
*DECK DECK=RFD$PDT_DISPLAY_RHFAM_SERVERS EXPAND=FALSE

{ PDT display_rhfam_server_pdt (
{     server, s : LIST OF NAME 1 .. 7 OR KEY ALL = ALL
{     output, o : FILE = $OUTPUT
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    display_rhfam_server_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^display_rhfam_server_pdt_names, ^display_rhfam_server_pdt_params];

  VAR
    display_rhfam_server_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['SERVER', 1], ['S', 1], ['OUTPUT', 2], ['O', 2], ['STATUS', 3]];

  VAR
    display_rhfam_server_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
      clt$parameter_descriptor := [

{ SERVER S }
    [[clc$optional_with_default, ^display_rhfam_server_pdt_dv1], 1, clc$max_value_sets,1, 1,
      clc$value_range_not_allowed, [^display_rhfam_server_pdt_kv1, clc$name_value, 1, 7]],

{ OUTPUT O }
    [[clc$optional_with_default, ^display_rhfam_server_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
      [NIL, clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    display_rhfam_server_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := [
      'ALL'];

  VAR
    display_rhfam_server_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'ALL';

  VAR
    display_rhfam_server_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??
*DECK DECK=RFD$PDT_DISPLAY_TRUNK_STATUS EXPAND=FALSE

{ PDT display_trunk_status_pdt (
{     trunk, t : LIST OF NAME  OR  KEY ALL = ALL
{     display_option, do : KEY BRIEF B FULL F = BRIEF
{     output, o : FILE = $OUTPUT
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    display_trunk_status_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^display_trunk_status_pdt_names, ^display_trunk_status_pdt_params];

  VAR
    display_trunk_status_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
      clt$parameter_name_descriptor := [['TRUNK', 1], ['T', 1], ['DISPLAY_OPTION', 2], ['DO', 2], ['OUTPUT', 3
      ], ['O', 3], ['STATUS', 4]];

  VAR
    display_trunk_status_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of
      clt$parameter_descriptor := [

{ TRUNK T }
    [[clc$optional_with_default, ^display_trunk_status_pdt_dv1], 1, clc$max_value_sets,1, 1,
      clc$value_range_not_allowed, [^display_trunk_status_pdt_kv1, clc$name_value, 1, osc$max_name_size]],

{ DISPLAY_OPTION DO }
    [[clc$optional_with_default, ^display_trunk_status_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [^
      display_trunk_status_pdt_kv2, clc$keyword_value]],

{ OUTPUT O }
    [[clc$optional_with_default, ^display_trunk_status_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed,
      [NIL, clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    display_trunk_status_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of ost$name := [
      'ALL'];

  VAR
    display_trunk_status_pdt_kv2: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := [
      'BRIEF','B','FULL','F'];

  VAR
    display_trunk_status_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'ALL';

  VAR
    display_trunk_status_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (5) := 'BRIEF';

  VAR
    display_trunk_status_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??
*DECK DECK=RFD$PDT_FORMAT_NAD_DUMP EXPAND=FALSE

{ PDT format_nad_dump_pdt (
{     dump_file, df : FILE = $REQUIRED
{     output, o : FILE = $OUTPUT
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    format_nad_dump_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^format_nad_dump_pdt_names
      , ^format_nad_dump_pdt_params];

  VAR
    format_nad_dump_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['DUMP_FILE', 1], ['DF', 1], ['OUTPUT', 2], ['O', 2], ['STATUS', 3]];

  VAR
    format_nad_dump_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor
      := [

{ DUMP_FILE DF }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ OUTPUT O }
    [[clc$optional_with_default, ^format_nad_dump_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    format_nad_dump_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$OUTPUT';

?? POP ??
*DECK DECK=RFD$PDT_INSTALL_RHFAM_CONFIG EXPAND=FALSE

{ pdt install_configuration (input, i : file = $required
{                            error, e : file = $errors
{                            status)

?? PUSH (LISTEXT := ON) ??

  VAR
    install_configuration: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^install_configuration_names, ^install_configuration_params];

  VAR
    install_configuration_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['INPUT', 1], ['I', 1], ['ERROR', 2], ['E', 2], ['STATUS', 3]];

  VAR
    install_configuration_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
      clt$parameter_descriptor := [

{ INPUT I }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ ERROR E }
    [[clc$optional_with_default, ^install_configuration_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    install_configuration_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$errors';

?? POP ??
*DECK DECK=RFD$PDT_INSTALL_RHF_CONFIG_BIN EXPAND=FALSE

{ pdt install_config_bin (error, e : file = $errors
{                            status)

?? PUSH (LISTEXT := ON) ??

  VAR
    install_config_bin: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^install_config_bin_names,
      ^install_config_bin_params];

  VAR
    install_config_bin_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['ERROR', 1], ['E', 1], ['STATUS', 2]];

  VAR
    install_config_bin_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor
      := [

{ ERROR E }
    [[clc$optional_with_default, ^install_config_bin_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    install_config_bin_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$errors';

?? POP ??
*DECK DECK=RFD$PDT_MANAGE_RHFAM_NETWORK EXPAND=FALSE

{ PDT manage_rhfam_network_pdt (
{     status)

?? PUSH (LISTEXT := ON) ??

  VAR
    manage_rhfam_network_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^manage_rhfam_network_pdt_names, ^manage_rhfam_network_pdt_params];

  VAR
    manage_rhfam_network_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
      clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    manage_rhfam_network_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of
      clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
*DECK DECK=RFD$PDT_TEST_LOCAL_NAD EXPAND=FALSE

{ PDT test_local_nad_pdt (
{   nad, n : name = $required
{   status)

?? PUSH (LISTEXT := ON) ??

  VAR
    test_local_nad_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table
      := [^test_local_nad_pdt_names, ^test_local_nad_pdt_params];

  VAR
    test_local_nad_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults]
      array [1 .. 3] of clt$parameter_name_descriptor := [['NAD', 1], ['N', 1]
      , ['STATUS', 2]];

  VAR
    test_local_nad_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2
      ] of clt$parameter_descriptor := [

{ NAD N }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

?? POP ??
*DECK DECK=RFD$PDT_VERIFY_RHFAM_CONFIG EXPAND=FALSE

{ pdt verify_configuration (input, i : file = $required
{                           output, o : file = $output
{                           status)

?? PUSH (LISTEXT := ON) ??

  VAR
    verify_configuration: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^verify_configuration_names, ^verify_configuration_params];

  VAR
    verify_configuration_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['INPUT', 1], ['I', 1], ['OUTPUT', 2], ['O', 2], ['STATUS', 3]];

  VAR
    verify_configuration_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
      clt$parameter_descriptor := [

{ INPUT I }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$file_value]],

{ OUTPUT O }
    [[clc$optional_with_default, ^verify_configuration_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$file_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    verify_configuration_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (7) := '$output';

?? POP ??
*DECK DECK=RFE$CONDITION_CODES EXPAND=FALSE

{    DECK: RFE$CONDITION_CODES


*copyc rfc$condition_code_range


CONST
    rfc$error_code = rfc$min_ecc_rhf_access_method;

CONST

{    The following group of condition codes are used by the external interface.

     rfe$async_req_terminated = rfc$error_code + 0,
     {W +P request on connection +F was terminated by user.

     rfe$invalid_data_fragment = rfc$error_code + 1,
     {F An invalid data fragment has been detected by +P.

     rfe$file_already_exists = rfc$error_code + 2,
     {E File +F existed prior to the attempt to establish a connection.

     rfe$connect_in_progress = rfc$error_code + 3,
     {E Connection +F is not established.  Server has not responded.

     rfe$not_registered_server = rfc$error_code + 4,
     {F This job is not registered as the RHFAM initiated server, +P.

     rfe$file_not_closed = rfc$error_code + 5,
     {E Unable to switch connection file +F because the file is open.

     rfe$network_block_exceeded = rfc$error_code + 6,
     {F A network block has been received that exceeds the requested size,
     {  requested size : +P, received size : +P.

     rfe$partial_network_block = rfc$error_code + 7,
     {F A record mode network block has been received that is smaller than the
     {  requested size and does not have a termination mark.

     rfe$connection_not_available = rfc$error_code + 8,
     {I No connection available for application +P.

     rfe$max_appl_connects_exceeded = rfc$error_code + 9,
     {F The maximum active connection limit has been reached for application
     { +P.

     rfe$invalid_connection_event = rfc$error_code + 10,
     {E An invalid connection event has been specified for await connection
     {  event.

     rfe$connection_terminated = rfc$error_code + 11,
     {E Connection +F was terminated.

     rfe$max_connection_mismatch = rfc$error_code + 12,
     {F Connection limit does not match defined value for +P.

     rfe$destination_host_undefined = rfc$error_code + 13,
     {E Host +P is not defined in the RHFAM configuration.

     rfe$appl_not_active = rfc$error_code + 14,
     {E Application +P is defined but not active.

     rfe$defined_connects_exceeded = rfc$error_code + 15,
     {F Specifying +P2 connections on the sign-on request exceeds the
     {  defined limit for +P1.

     rfe$invalid_application_kind = rfc$error_code + 16,
     {E An invalid application kind has been specified for +P.

     rfe$paths_to_destination_down = rfc$error_code + 21,
     {E All paths to +P are currently down.

     rfe$remote_host_busy = rfc$error_code + 26,
     {E Connection +F2 was rejected because host +P1 does not currently
     {  have the resources to satisfy the request.

     rfe$remote_server_undefined = rfc$error_code + 27,
     {E Server +P is not defined locally to RHFAM.

     rfe$task_terminated = rfc$error_code + 31,
     {E +P request terminated at task termination.

     rfe$transfer_timeout = rfc$error_code + 32,
     {E +P request terminated because the transfer timeout was exceeded.

     rfe$not_signed_on = rfc$error_code + 34,
     {E +P request failed because the job is not signed on as application
     {  +P.

     rfe$unknown_reject_code = rfc$error_code + 35,
     {E Connection +F3 was rejected by host +P1 with an invalid reject
     {  code: +P2.

     rfe$exceeded_connect_limit = rfc$error_code + 37,
     {F +P failed because application +P has reached its
     {  connection limit.

     rfe$path_to_remote_undefined = rfc$error_code + 38,
     {E There is no path defined to remote server +P on remote host +P.

     rfe$not_signed_on_as_server = rfc$error_code + 39,
     {F +P failed because the job is not signed on as server
     {  application +P.

     rfe$not_an_rhfam_job = rfc$error_code + 40,
     {F +P failed because this job is not signed on as an
     {  RHFAM application.

     rfe$invalid_attribute_value = rfc$error_code + 41,
     {E An invalid attribute value has been specified for +P.

     rfe$already_signed_on = rfc$error_code + 42,
     {E This job is already signed on as +P.

     rfe$connections_not_terminated = rfc$error_code + 43,
     {E Application +P could not sign-off because all connections
     {  have not been terminated.

     rfe$no_server_response = rfc$error_code + 44,
     {E No server response has been received for connection +F.

     rfe$server_busy = rfc$error_code + 45,
     {E Connection +F3 was rejected by host +P1 because server +P2
     {  had reached its connection limit.

     rfe$remote_rhf_shutdown = rfc$error_code + 46,
     {E Connection +F2 was rejected by host +P1 because the remote
     {  RHFAM was terminating.

     rfe$server_lid_disabled = rfc$error_code + 47,
     {E Connection +F3 was rejected by host +P1 because the destination
     {  LID +P2 is currently disabled.

     rfe$server_reject_response = rfc$error_code + 48,
     {E Connection +F3 was rejected by server application +P1 on
     {  host +P2.

     rfe$password_undefined = rfc$error_code + 49,
     {E Connection +F2 was rejected by host +P1 because the password
     {  was not valid.

     rfe$client_undefined = rfc$error_code + 50,
     {E Connection +F3 was rejected by host +P1 because client +P2
     {  is not defined.

     rfe$server_disabled = rfc$error_code + 51,
     {E Connection +F3 was rejected by host +P1 because server +P2 is
     {  currently disabled.

     rfe$client_disabled = rfc$error_code + 52,
     {E Connection +F3 was rejected by host +P1 because client +P2 is
     {  currently disabled.

     rfe$client_pid_disabled = rfc$error_code + 53,
     {E Connection +F3 was rejected by host +P1 because the source PID
     {  +P2 is currently disabled.

     rfe$client_nad_disabled = rfc$error_code + 54,
     {E Connection +F3 was rejected by host +P1 because the source NAD
     {  +P2 is currently disabled.

     rfe$tcu_disabled = rfc$error_code + 55,
     {E Connection +F2 was rejected by host +P1 because the specified
     {  TCUs are currently disabled.

     rfe$rhf_not_active = rfc$error_code + 56,
     {E Connection +F2 to host +P1 failed because the remote RHFAM
     {  is not active.

     rfe$server_undefined = rfc$error_code + 57,
     {E Connection +F3 was rejected by host +P1 because server +P2 is
     {  not defined.

     rfe$server_lid_undefined = rfc$error_code + 58,
     {E Connection +F3 was rejected by host +P1 because the server LID
     {  +P2 is not defined.

     rfe$client_pid_undefined = rfc$error_code + 59,
     {E Connection +F3 was rejected by host +P1 because the source
     {  PID +P2 is not defined.

     rfe$client_nad_undefined = rfc$error_code + 60,
     {E Connection +F3 was rejected by host +P1 because the source
     {  NAD +P2 is not defined.

     rfe$access_code_invalid = rfc$error_code + 61,
     {E Connection +F2 was rejected by host +P1 because the NAD access
     {  codes do not match.

     rfe$device_invalid = rfc$error_code + 62,
     {E Connection +F2 was rejected by host +P1 because the destination
     {  device is invalid.

     rfe$tcu_invalid = rfc$error_code + 63,
     {E Connection +F2 was rejected by host +P1 because the specified
     {  TCUs were undefined or invalid.

     rfe$no_available_event = rfc$error_code + 64,
     {W The requested event is not available.

     rfe$connection_not_active = rfc$error_code + 65,
     {E Connection +F does not exist.

     rfe$send_data_active = rfc$error_code + 66,
     {E A send data request is already active for connection +F.

     rfe$receive_data_active = rfc$error_code + 67,
     {E A receive data request is already active for connection +F.

     rfe$system_task_not_active = rfc$error_code + 69,
     {E +P failed because RHFAM is not active.

     rfe$file_device_class_not_rhf = rfc$error_code + 70,
     {E +P request failed because connection file +F is
     {  not a RHFAM device class file.

     rfe$unexpected_connection_state = rfc$error_code + 71,
     {C Connection +F was found with an unexpected state ordinal:  +P.

     rfe$block_sequence_error = rfc$error_code + 74,
     {E A network block sequence error has been detected on connection
     {  +F.  Expected block = +P, Received block = +P.

     rfe$connection_waiting_accept = rfc$error_code + 75,
     {E Request failed because connection +F is waiting for an accept or
     { reject.

     rfe$connection_rejected = rfc$error_code + 76,
     {E Connection +F has been rejected.

     rfe$receive_mode_conflict = rfc$error_code + 77,
     {E A +P block was received during a +P transfer on connection +F.

     rfe$switch_offered = rfc$error_code + 78,
     {W Connection +F has been offered for switching to job +P.

     rfe$switch_accepted = rfc$error_code + 79,
     {I Connection +F has been switched and accepted by job +P.

     rfe$connected = rfc$error_code + 80,
     {I Connection +F is normal.

     rfe$switch_offer_not_accepted = rfc$error_code + 81,
     {W The switch offer on connection +F has not been accepted.

     rfe$no_switch_offered = rfc$error_code + 82,
     {W There is no connection switch offer for application +P.

     rfe$no_switch_offer_pending = rfc$error_code + 83,
     {W There is no switch offer on connection +F to cancel.

     rfe$invalid_attribute_key = rfc$error_code + 84,
     {E An invalid attribute key has been specified for +P.

     rfe$system_task_shutdown = rfc$error_code + 85,
     {E Connection +F has been terminated by a shutdown of the
     {  RHFAM/VE system task.

     rfe$local_nad_failure = rfc$error_code + 86,
     {E Connection +F has been terminated because of a local network
     {  access device failure.

     rfe$system_interrupt = rfc$error_code + 87,
     {E Connection +F has been terminated because of a local system
     {  interrupt.

     rfe$local_nad_busy = rfc$error_code + 88,
     {E The attempted connection failed because local NAD +P
     {  is currently saturated.

     rfe$local_nad_down = rfc$error_code + 89,
     {E Request +P failed because the local NAD is down.

     rfe$invalid_alert_received = rfc$error_code + 90,
     {C An invalid alert ordinal has been received on
     {  connection +F: +P.

     rfe$destination_host_disabled = rfc$error_code + 91,
     {W Host +P is currently disabled in the RHFAM configuration.

     rfe$not_signed_on_as_client = rfc$error_code + 92,
     {E +P failed because the job is not signed on as client
     {  application +P.

     rfe$unable_to_send_all_data = rfc$error_code + 93,
     {W All of the specified record mode data was not sent because
     {  +P.

{    The following condition codes are used by the configuration utility.

     rfe$configuration_file_error = rfc$error_code + 100,
     {E The configuration file directives in +F1 are not installable.
     {  Check the +F2 file for errors.

     rfe$duplicate_local_host = rfc$error_code + 101,
     {E A local host directive has already been processed.

     rfe$duplicate_component_name = rfc$error_code + 102,
     {E The element +P was specified on another +P definition.

     rfe$configuration_overflow = rfc$error_code + 103,
     {C The configuration file has overflowed the +P.

     rfe$invalid_host_connection = rfc$error_code + 104,
     {E Host connection +P on nad +P is not valid for this request.

     rfe$undefined_path_element = rfc$error_code + 105,
     {E Component +P must be defined prior to use in a DEFINE_LCN_PATH
     {  directive.

     rfe$no_trunk_match = rfc$error_code + 106,
     {E Invalid path.  NAD +P and NAD +P do not have a common trunk.

     rfe$parameter_problem = rfc$error_code + 108,
     {C The +P parameter had an undefined value specified.

     rfe$physical_id_required = rfc$error_code + 109,
     {E An inter-network path requires a physical_identifier parameter value.

     rfe$duplicate_autpg = rfc$error_code + 110,
     {F The AUTO_PATH_GENERATION directive can only be specified once in
     {  a directives file.

     rfe$autpg_after_deflp = rfc$error_code + 111,
     {F The AUTO_PATH_GENERATION directive can not be specified after a
     {  DEFINE_LCN_PATH directive.

     rfe$required_def_missing = rfc$error_code + 112,
     {E A minimum of one +P definition is required.

     rfe$multiple_config_command = rfc$error_code + 113,
     {E Multiple VERRC/INSRC commands are not allowed.

     rfe$concurrent_installation = rfc$error_code + 114,
     {E Only one configuration installation can be in progress at any
     {  instant.

     rfe$duplicate_lid = rfc$error_code + 115,
     {E Logical identifier +P is defined more than once for the same host.

     rfe$all_is_not_a_legal_name = rfc$error_code + 116,
     {E The keyword "ALL" cannot be used to identify a +P.

     rfe$startup_cmd_file_error = rfc$error_code + 117,
     {E The startup command file directives in +F1 are not installable.
     {  Check the +F2 file for errors.

     rfe$unsupported_request_type = rfc$error_code + 130,
     {C A caller must specify either a PP request or a UNIT request.

     rfe$invalid_peripheral_element = rfc$error_code + 131,
     {C Logical +P number +P is invalid.

     rfe$request_processing_err = rfc$error_code + 132,
     {C The peripheral request could not be completed because +P;
     {  in routine +P.

     rfe$invalid_request_command = rfc$error_code + 134,
     {C Peripheral request command +P is not supported.

{    The following condition codes are used by the system task and
{    by the internal PP request processing routines.

     rfe$invalid_task_origin = rfc$error_code + 150,
     {F The RHFAM/VE system task must be initiated from the
     {  system job.

     rfe$system_task_running = rfc$error_code + 151,
     {F Only one copy of the RHFAM/VE system task can be
     {  running at any instant.

     rfe$invalid_config_file = rfc$error_code + 152,
     {F Unusable RHFAM/VE configuration file : +P.

     rfe$configuration_too_big = rfc$error_code + 153,
     {F The labels in the configuration file specify a file
     {  that is larger than the actual configuration_file.

     rfe$unable_to_start_a_pp = rfc$error_code + 154,
     {C The RHFAM system task failed to start a pp program.

     rfe$heap_exhausted = rfc$error_code + 155,
     {C The following request could not be completed because
     {  the +P heap is exhausted; routine +P.

     rfe$abnormal_state = rfc$error_code + 156,
     {C The +P encountered an invalid state: +P.

     rfe$unexpected_response = rfc$error_code + 157,
     {C A +P received an invalid response: +P.

     rfe$unknown_request = rfc$error_code + 158,
     {C A response for an unknown +P command: +P.

     rfe$microcode_loaded = rfc$error_code + 159,
     {I Microcode load +P for +P +P.

     rfe$alert_condition = rfc$error_code + 160,
     {E The PP returned an alert condition: +P, for a +P
     {  request.

     rfe$interface_error = rfc$error_code + 161,
     {F The PP processing failed, interface error: +P, for a +P
     {  request.

     rfe$nad_processing_error = rfc$error_code + 162,
     {E PP returned NAD error +P: MCFUNC=+P: MCSTAT=+P:
     {  HWFUNC=+P: HWSTAT=+P: TRANSFER LENGTH=+P, for a +P
     {  request.

     rfe$pp_start_up_failed = rfc$error_code + 163,
     {C Unable to start PP +P: interface error +P.

     rfe$unexpected_control_message = rfc$error_code + 164,
     {I +P control message was received: nad=+P, my path=+P,
     {  his path=+P, block type=+P.

     rfe$nad_tcu_unavailable = rfc$error_code + 165,
     {W NAD +P has trunk +P on TCU +P configured, but the TCU is not
     {  available.

     rfe$nad_address_mismatch = rfc$error_code + 166,
     {W NAD +P is configured with address +P, but +P is the real address.

     rfe$nad_microcode_mismatch = rfc$error_code + 167,
     {W NAD +P is loaded with microcode level +P.  +P is the currently
     {  supported microcode level.

     rfe$nad_device_type_mismatch = rfc$error_code + 168,
     {W NAD +P is loaded with microcode for device type +P. +P is the
     {  currently supported device type.

     rfe$pp_number_not_found = rfc$error_code + 169,
     {E NOS/VE cannot determine the logical PP number. }

     rfe$segment_access_error = rfc$error_code + 170,
     {F Segment access error while accessing user data file. }

     rfe$test_nad_failure = rfc$error_code + 171,
     {F NAD +P failed device test.}

{     This following group of codes are used by the MANAGE_RHFAM_NETWORK
{ Utility and may be seen by the operator or the Network Application
{ Manager.

     rfe$illegal_output_file = rfc$error_code + 200,
     {E File +F must have page width of at least +P characters.

     rfe$element_not_found = rfc$error_code + 202,
     {E Unable to find element +P.

     rfe$logical_id_not_found = rfc$error_code + 203,
     {E Unable to find logical identifier +P.

     rfe$physical_id_not_found = rfc$error_code + 204,
     {E Unable to find remote host +P.

     rfe$nad_dump_file_empty = rfc$error_code + 205,
     {E The NAD dump file, +F1 is empty.

     rfe$no_local_host_defined = rfc$error_code + 206,
     {E RHFAM is up but no local host for +P.

     rfe$not_an_rhfam_config_file = rfc$error_code + 207,
     {E File +F1 is not an RHFAM configuration file.

     rfe$down_trunk_not_changeable = rfc$error_code + 208,
     {E Unable to change state of DOWN trunk +P connection to NAD +P.

     rfe$down_nad_not_changable = rfc$error_code + 209,
     {E Unable to change state of DOWN NAD +P.

     rfe$cannot_down_remote_trunk = rfc$error_code + 210,
     {E Illegal to DOWN remote trunks.

     rfe$cannot_down_remote_nad = rfc$error_code + 211,
     {E Illegal to DOWN remote NADs.

     rfe$too_many_key_values = rfc$error_code + 212,
     {E Key value +P must be alone in list when specifying +P.

     rfe$skipped_lines = rfc$error_code + 213,
     {I +P duplicate lines are suppressed.}

     rfe$appl_not_defined = rfc$error_code + 214,
     {E Unable to find application definition for +P.

     rfe$appl_already_active = rfc$error_code + 215,
     {W The application +P, is already active.

     rfe$appl_already_inactive = rfc$error_code + 216,
     {W The application +P, is already inactive.

     rfe$client_defined_as_server = rfc$error_code + 217,
     {E The client application +P, is already defined as a server.

     rfe$duplicate_appl_definition = rfc$error_code + 218,
     {E The application +P, is already defined.

     rfe$appl_not_inactive = rfc$error_code + 219,
     {E Cannot delete active application definition +P.

     rfe$appl_job_signed_on = rfc$error_code + 220,
     {E Cannot delete application definition +P, while job signed on.

     rfe$server_defined_as_client = rfc$error_code + 221,
     {E The server application +P, is already defined as a client.

     rfe$server_job_not_specified = rfc$error_code + 222,
     {E Job file not specified for rhfam_initiated server +P.

     rfe$caller_not_privileged = rfc$error_code + 223,
     {F Caller not validated to +P.

     rfe$improper_nad_state_for_test = rfc$error_code + 224,
     {F NAD +P can only be tested when OFF.

     rfe$test_already_in_process = rfc$error_code + 225;
     {F NAD +P is currently being tested.
*DECK DECK=RFH$ACCEPT_CONNECT_REQUEST EXPAND=FALSE
{
{      The purpose of this request is to inform the access method that
{ the server application has accepted the incoming connect request.
{ This request is only valid after a successful
{ RFP$ACQUIRE_CONNECT_REQUEST.  Once this request successfully
{ completes, the server can then open the connection file for data
{ transfers.
{
{      The client application is notified of the successful completion
{ of this request (see RFP$AWAIT_SERVER_RESPONSE).
{
{ RFP$ACCEPT_CONNECT_REQUEST(CONNECTION_FILE, STATUS)
{
{ CONNECTION_FILE: (input) This parameter specifies the temporary file
{   which is assigned to the connection to accept.
{
{ STATUS: (output) This parameter returns the results of the request.
{   If the status is normal, the specified connection has been
{   successfully accepted and the connection is considered
{   established.
{   CONDITIONS:  rfe$connect_in_progress
{                rfe$connected
{                rfe$connection_not_active
{                rfe$connection_rejected
{                rfe$connection_terminated
{                rfe$local_nad_failure
{                rfe$switch_accepted
{                rfe$switch_offered
{                rfe$system_interrupt
{                rfe$system_task_shutdown
{   IDENTIFIER:  'RF'
{
*DECK DECK=RFH$ACCEPT_SWITCH_OFFER EXPAND=FALSE
{
{
{      The purpose of this request is to accept a switch of ownership of a
{ connection end point from another job on the local system. Switching
{ ownership of a connection end point is a local system operation. The
{ peer application at the remote connection end point receives no indication
{ of this action.
{
{      Switching ownership of a connection end point is a cooperative
{ process which requires the active participation of both the source job
{ (current owner) and the destination job (proposed owner). The source job
{ makes an offer to switch a connection end point to a destination job.
{ The destination job uses this request to accept the switch offer and
{ complete the connection end point switch.
{
{      The request is terminated if either a switch offer is received or
{ the WAIT_TIME has expired (whichever comes first).
{
{      If a connection switch has been offered, the access method creates
{ the file specified by the CONNECTION_FILE parameter, assigns the
{ connection end point to that file, and assigns the initial file
{ attributes.  The default attributes are migrated from the
{ source jobs connection file.
{
{ RFP$ACCEPT_SWITCH_OFFER(APPLICATION_NAME, CONNECTION_FILE,
{   FILE_ATTRIBUTES, WAIT_TIME, SOURCE_JOB, STATUS)
{
{ APPLICATION_NAME: (input) This parameter specifies the name of a signed
{   on application.  A connection switch offer must be destined for this
{   application to satisfy the request.
{
{ CONNECTION_FILE: (input) This parameter specifies the name of the
{   file, which the access method should create and assign to the
{   local connection end point.  The application must use the file
{   name for all future references to the connection.  The file must
{   not be present before this request is issued.  The connection file
{   is created in the $local catalog.
{
{ FILE_ATTRIBUTES: (input) This parameter specifies the file attributes,
{   whose values are to be changed to the corresponding values specified
{   by this parameter. A value of NIL for this parameter indicates that
{   default values are to be used for all attributes. Further
{   information on the file attributes is provided in the BAM request
{   section.
{
{ WAIT_TIME: (input) This parameter specifies the number of milliseconds to
{   suspend the application if an offered connection is not immediately
{   available.  If the WAIT_TIME expires before an offered connection
{   is available the access method terminates the request with a status
{   of 'rfe$connection_not_available'.  A value of zero can be specified
{   to avoid waiting.
{
{ SOURCE_JOB: (output) This parameter returns the system job name of the
{   job that offered the connection to this job.
{
{ STATUS: (output) This parameter returns the results of the request.
{   A status of normal means that an offered  connection has been assigned
{   to the job.
{   CONDITIONS:  rfe$not_signed_on
{                rfe$exceeded_connect_limit
{                rfe$file_already_exists
{                rfe$invalid_attribute_key
{                rfe$no_switch_offered
{   IDENTIFIER:  'RF'
{
*DECK DECK=RFH$ACQUIRE_CONNECT_REQUEST EXPAND=FALSE
{
{      This request is used to acquire incoming connect requests that
{ are assigned to the corresponding job.  This request can only be issued
{ by "signed on" server applications.  If an incoming connect request
{ has been assigned to the requester's job, the access method creates a
{ file (specified by the CONNECTION_FILE) and assigns the connection end
{ point to that file.
{
{      The application is suspended until either an incoming connect
{ request is available or the WAIT_TIME expires (whichever comes first).
{
{      Once the connection is assigned the server application must either
{ accept or reject the connection.
{
{ RFP$ACQUIRE_CONNECT_REQUEST(SERVER_NAME, CONNECTION_FILE,
{   FILE_ATTRIBUTES, WAIT_TIME, CLIENT_NAME, SOURCE_HOST_NAME, STATUS)
{
{ SERVER_NAME: (input) This parameter must specify the name of a
{   server application which is currently "signed on" to the local
{   access method for this job.
{
{ CONNECTION_FILE: (input) This parameter specifies the file name, which
{   the access method should create and assign to the incoming connection
{   request end point.  The application must use the file name
{   for all future references to the connection.  The file must reside
{   in a temporary master catalog.
{
{ FILE_ATTRIBUTES: (input) This parameter specifies the file attributes,
{   whose values are to be changed to the corresponding values specified
{   by this parameter. A value of NIL for this parameter indicates that
{   default values are to be used for all attributes. Further
{   information on the file attributes is provided in the BAM request
{   section.
{
{ WAIT_TIME (input) This parameter specifies the number of milliseconds the
{   access method should suspend the application if an incoming connect
{   request is not immediately available.  If the WAIT_TIME expires
{   before an incoming connect request is available the request is
{   terminated with a status of 'rfe$connection_not_available'.  A value
{   of zero can be specified to avoid waiting.
{
{ CLIENT_NAME: (output)  This parameter specifies the name of the
{   client application that requested the connection.  This parameter is
{   only meaningful if the status is 'normal'.
{
{ SOURCE_HOST_NAME: (output)  This parameter specifies the host
{   where the client application resides.  This parameter is only
{   meaningful if the status is 'normal'.
{
{ STATUS: (output) This parameter returns the results of the request.
{   A status of normal means the caller is validated to obtain a
{   connection.
{   CONDITIONS:  rfe$connection_not_available
{                rfe$exceeded_connect_limit
{                rfe$file_already_exists
{                rfe$invalid_attribute_key
{                rfe$not_signed_on
{                rfe$not_signed_on_as_server
{   IDENTIFIER:  'RF'
{
*DECK DECK=RFH$ACTIVATE_RHFAM_CLIENT EXPAND=FALSE
{
{       This subcommand activates a previously defined RHFAM client application.
{ Connection requests may be made only by active client applications.
{
{       The caller must have NETWORK_APPLICATION_MANAGEMENT capability specified
{ in the validation file, or be the system job in order to use this command.
{
{
{ ACTIVATE_RHFAM_CLIENT, ACTRC(
{     client, c : NAME 1..7 = $REQUIRED
{     status)
{
{ client: This parameter specifies the name of the client application to
{   be activated.
{
{ status: This parameter returns the results of this request. A normal status
{   means that the requested client is activated.
{
*DECK DECK=RFH$ACTIVATE_RHFAM_CLIENT_R3 EXPAND=FALSE
{
{       The purpose of this routine is to activate a previously defined
{ RHFAM client, making it available for connection establishment. The table
{ of RHFAM client definitions is searched for the specified client, which,
{ if found and inactive, is set to active.
{        This routine must be called within the system job or the caller
{ must have NETWORK_APPLICATION_MGMT capability.
{
{ RFP$ACTIVATE_RHFAM_CLIENT (CLIENT, STATUS)
{
{ CLIENT: (input) This parameter specifies the name of the client that is
{   to be activated.
{
{ STATUS: (output) This status returns the result of the request. A status
{   of normal indicates that the specified client is active.
{
{     CONDITIONS: rfe$appl_not_defined
{                 rfe$appl_already_active
{
{     IDENTIFIER: 'RF'
{
*DECK DECK=RFH$ACTIVATE_RHFAM_SERVER EXPAND=FALSE
{
{       This subcommand activates a previously defined RHFAM server application.
{ A server application must be in an active state in order to receive client
{ connection requests.
{
{       The caller must have NETWORK_APPLICATION_MANAGEMENT capability specified
{ in the validation file, or be the system job in order to use this command.
{
{
{ ACTIVATE_RHFAM_SERVER, ACTRS(
{     server, s : NAME 1..7 = $REQUIRED
{     status)
{
{ server: This parameter specifies the name of the server application to
{   be activated.
{
{ status: This parameter returns the results of this request. A normal status
{   means that the requested server is deactivated.
{
*DECK DECK=RFH$ACTIVATE_RHFAM_SERVER_R3 EXPAND=FALSE
{
{       The purpose of this routine is to activate a previously defined
{ RHFAM server, making it available to receive connection requests. The
{ table of RHFAM server definitions is searched for the specified server,
{ which, if found and inactive, is set to active.
{        This routine must be called within the system job or the caller
{ must have NETWORK_APPLICATION_MGMT capability.
{
{ RFP$ACTIVATE_RHFAM_SERVER (SERVER, STATUS)
{
{ SERVER: (input) This parameter specifies the name of the server that is
{   to be activated.
{
{ STATUS: (output) This status returns the result of the request. A status
{   of normal indicates that the specified server is active.
{
{     CONDITIONS: rfe$appl_not_defined
{                 rfe$appl_already_active
{
{     IDENTIFIER: 'RF'
{
*DECK DECK=RFH$ANALYZE_LOCAL_NAD_STATUS EXPAND=FALSE
{      When the NAD status information is obtained from a local NAD the
{ event processor must examine the status of all paths to determine what
{ action, if any, is required.  The NAD status information contains the
{ path state and clarifier of all active paths in the NAD (including
{ path zero).  The NAD status information also contains the I/O
{ threshold flags for each path.
*DECK DECK=RFH$APPLICATION_SIGN_OFF EXPAND=FALSE
{
{      The purpose of this request is to notify the local access method
{ that the requesting job relinquishes its access to the network, via
{ the specified APPLICATION_NAME.
{
{      This request can only be executed once all connections,
{ established under the specified APPLICATION_NAME, have been terminated.
{
{ RFP$APPLICATION_SIGN_OFF(APPLICATION_NAME, STATUS)
{
{ APPLICATION_NAME: (input) This parameter specifies the name of the
{   application to sign off.
{
{ STATUS: (output) This parameter specifies the results of the request.
{   A status of normal means that the specified server has been signed
{   off.
{      CONDITIONS:  rfe$not_signed_on
{                   rfe$connections_not_terminated
{      IDENTIFIER:  'RF'
{
*DECK DECK=RFH$APPLICATION_SIGN_ON EXPAND=FALSE
{
{      The purpose of this request is to notify the local access method
{ that the requesting job is performing the network services of
{ APPLICATION_NAME.  The caller, under whose domain the job is running,
{ must be validated to utilize the capability provided by the specified
{ application (see ADMINISTER_VALIDATIONS utility). A server or client of
{ APPLICATION_NAME must have been defined under the MANAGE_RHFAM_NETWORK
{ Utility by a DEFINE_RHFAM_SERVER or DEFINE_RHFAM_CLIENT command and
{ activated by an ACTIVATE_RHFAM_CLIENT or ACTIVATE_RHFAM_SERVER command
{ before sign on is valid.
{
{      A job must sign on for each network service that is provided, with
{ the requirement that each sign on specifies a unique APPLICATION_NAME.
{
{      The scope of a signed on application is job (i.e. all tasks within
{ the job may establish (or acquire) connections on behalf of the signed
{ on application).
{
{      The sign on remains in affect until the job explicitly signs off
{ (via RFP$APPLICATION_SIGN_OFF) or the job is terminated.
{
{
{ RFP$APPLICATION_SIGN_ON(APPLICATION_NAME, APPLICATION_KIND,
{   MAXIMUM_CONNECTIONS, STATUS)
{
{ APPLICATION_NAME: (input) The purpose of this parameter is to identify
{   the application being signed on.  This value must be used by the
{   RFP$REQUEST_CONNECTION, RFP$ACQUIRE_CONNECT_REQUEST, and
{   RFP$ACCEPT_SWITCH_OFFER requests to identify the application service
{   associated with the connection.
{
{ APPLICATION_KIND: (input) The purpose of this parameter is to identify
{   the kind of application being signed on.  The following kinds are
{   allowed:
{
{   rfc$client:  The client application is allowed to establish connections
{     between itself and server applications.  The client can also
{     accept connections that are switched to this application from
{     partner applications.
{
{   rfc$server:  The server application is allowed to acquire incoming
{     connect requests from client applications.  The server can also
{     accept connections that are switched to this application from partner
{     applications.
{
{   rfc$partner:  The partner application kind is only capable of
{     accepting established connections which are switched to this
{     application from cooperating jobs.
{
{     note - the partner application must sign on with the same
{            APPLICATION_NAME as the client or server application that
{            is passing the established connection.
{
{ MAXIMUM_CONNECTIONS:  (input,output) This parameter specifies the
{   maximum number of connections that the specified job can have
{   established, for the specified APPLICATION_NAME, at any instant.
{   Determination of the connection limit is based on application kind:
{
{   rfc$client:  If zero is specified, the number of maximum connections
{     for all instances of the client application specified in the
{     DEFINE_RHFAM_CLIENT command (minus the number of connections currently
{     in use for this client definition) is returned in this parameter. If
{     the value specified exceeds the number of available connections, a
{     status of 'rfe$defined_connects_exceeded' and the actual number of
{     available connections is returned.
{
{   rfc$server:  The connection limit is based on the type of server
{     signing on:
{
{     RHFAM-initiated: The caller must specify the exact number of
{       connections defined per server job in the DEFINE_RHFAM_SERVER
{       command, or a status of 'rfe$max_connection_mismatch' and the actual
{       number of connections per job is returned.
{
{     Non-RHFAM-initiated: If zero is specified, the number of maximum
{       connections for all instances of the server application specified
{       in the DEFINE_RHFAM_SERVER command (minus the number of connections
{       currently in use for this server definition) is returned in this
{       parameter. If the value specified exceeds the number of available
{       connections, a status of 'rfe$defined_connects_exceeded' and the
{       actual number of available connections is returned.
{
{   rfc$partner:  The partner application is subject to the connection
{     limit established when its partner server or client signed on.
{     The MAXIMUM_CONNECTIONS parameter is ignored.
{
{ STATUS:  This parameter returns the results of the request.  If normal,
{   the application has successfully signed on.
{
{      CONDITIONS:  rfe$already_signed_on
{                   rfe$appl_not_active
{                   rfe$appl_not_defined
{                   rfe$defined_connects_exceeded
{                   rfe$invalid_application_kind
{                   rfe$max_connection_mismatch
{                   rfe$system_task_not_active
{      IDENTIFIER:  'RF'
{

*DECK DECK=RFH$AUTO_DUMP_AND_RELOAD EXPAND=FALSE

{    The purpose of this routine is to dump and reload any malfunctioning
{ local NADs that are maintained by this host.
{
{      When a NAD that is maintained by the local RHFAM/VE is flagged
{ as unoperational (nad_status = rfc$es_down), the access method
{ attempts a microcode dump and a microcode reload to restore the
{ NAD.  If the NAD is successfully reloaded the 'nad_status' is updated
{ and the NAD is considered available for future activity.  If the
{ NAD reload fails the status is set to rfc$es_off and the corresponding
{ 'reload_failed' field is set to TRUE.  The following algorithm is
{ used for determining dump/reload requirements:
{
{      FOR  each local nad  DO
{        IF  the nad is unoperational
{            AND  this host is to perform the reloading
{            AND  (reload count below threshold
{                   AND  reload has not already failed)
{              OR   operator has requested a nad test      THEN
{          IF  the reload has not started  THEN
{            force status request to complete.
{            clear the incoming connects.
{            clear the current connections.
{            delete any control messages.
{            wake up tasks waiting for events from this NAD.
{            IF NOT operator requested local nad test  THEN
{              post dump request.
{            IFEND
{          IFEND
{          IF  the dump failed or completed  THEN
{            post load request.
{          IFEND
{          IF  the nad reload failed
{            OR  the local nad test failed  THEN
{            set the NAD status to off.
{            log the final statistics.
{          IFEND
{        IFEND
{        IF  the operator has disabled the NAD  THEN
{          force status request to complete.
{          clear the incoming connects.
{          clear the current connections.
{          delete any control messages.
{          wake up tasks waiting for events from this NAD.
{          log the final statistics.
{        IFEND
{      FOREND
{
{    The dump and reload processing requires multiple requests to
{ perform the necessary functions to restore the NAD hardware to the
{ appropriate state.  As each request is completed the response
{ handler must analyze the results and determine if the next
{ request should be posted, the previous request should be retried,
{ the request cannot be retried, or the request is completed.
{
{    If a local NAD load or test fails, then the NAD is turned OFF
{ to return it to the system for maintenance.  If a remote NAD reload
{ fails, then a subsequent reload is attempted after an extended delay.
{
{    current_time: (input) This parameter specifies the current time
{      in microseconds, which is used for event timing.
*DECK DECK=RFH$AUTO_PATH_GENERATION EXPAND=FALSE

{
{    This directive requests the access method to create the necessary
{ physical paths from local host to the various remote hosts,
{ using the directives that have already been processed.  This
{ directive is invalid if a DEFINE_LCN_PATH directive has already
{ been encountered.  This directive may only occur once in any
{ directives file.  The directives file may contain other directives that
{ follow this one, however the automatic path generation is not applied to
{ any directive that is processed after the AUTPG directive.
{
{    The auto_path_generation only applies to hosts which are connected
{ by directly coupled NADs (i.e. the local and remote NADs must have a common
{ trunk).  This parameter also requires that the connecting NADs'
{ trunk control units all have the same access code.  If a local NAD has
{ multiple TCUs then the access code of the first configured TCU
{ (TCU zero is first to be checked) will be used as matching criteria
{ to determine if a path can be created.  If the user requires the use
{ of multiple access codes per NAD or is configuring inter-network devices
{ then the DEFINE_LCN_PATH directives must be used.
{
{ AUTO_PATH_GENERATION, AUTPG
{

*DECK DECK=RFH$AWAIT_RHFAM_EVENT EXPAND=FALSE
{
{      The purpose of this request is to wait for the occurence of
{ an LCN connection related event.  Currently the only connection events
{ are;
{
{    1)   input available:  There is incoming data available for the
{         corresponding connection.
{
{    2)   output below threshold:  The amount of data, waiting to be
{         sent across the connection, is below the threshold level.
{
{ RFP$AWAIT_RHFAM_EVENT(CONNECTION_IDENTIFIER, EVENT, WAIT_TIME,
{   STATUS)
{
{ CONNECTION_IDENTIFIER: (input) This parameter specifies the identifier
{   of the open connection file which the event must be for.
{
{ EVENT: (input) This parameter specifies the connection event that
{   the requester is waiting to occur.
{
{ WAIT_TIME: (input) This parameter specifies the amount of time that the
{   access method should wait for the specified event to occur.  A value
{   of zero can be specified to avoid waiting.  If the wait_time expires
{   before the event occurs, a status of 'rfe$no_available_event' is
{   returned.
{
{ STATUS: (output) This parameter returns the results of the request.
{   A status of normal means the connection is established and in
{   a normal state.
{   CONDITIONS:  ame$improper_file_id
{                rfe$connect_in_progress
{                rfe$connected
{                rfe$connection_not_active
{                rfe$connection_rejected
{                rfe$connection_terminated
{                rfe$file_device_class_not_rhf
{                rfe$no_available_event
{                rfe$local_nad_failure
{                rfe$switch_accepted
{                rfe$switch_offered
{                rfe$system_interrupt
{                rfe$system_task_shutdown
{   IDENTIFIER:  'RF'
{
*DECK DECK=RFH$AWAIT_SERVER_RESPONSE EXPAND=FALSE
{
{      The purpose of this request is to suspend execution of the
{ requesting task until a response is received for a previous
{ request to establish a connection.
{
{      This request is terminated when the server response is received
{ or when the specified time interval expires (whichever comes first).
{
{      If this request is issued for a connection that is already
{ established a normal status is returned.
{
{ RFP$AWAIT_SERVER_RESPONSE(CONNECTION_FILE, WAIT_TIME, SERVER_RESPONSE,
{   STATUS)
{
{ CONNECTION_FILE: (input) This parameter specifies the name of the
{   connection file, which has a pending connect request.
{
{ WAIT_TIME: (input) This parameter specifies the number of milliseconds
{   that the access method should wait for a server
{   response.  If no response is given within the specified time a
{   status of 'rfe$no_server_response' is returned.  A value of zero
{   can be used to avoid waiting.
{
{ SERVER_RESPONSE: (output) This parameter specifies the response data
{   that was sent from the server application.
{
{   Currently, the access method only allows additional information
{   to be passed on server rejects.  This field is only meaningful if the
{   status is 'rfe$server_reject_response'.
{
{ STATUS: (output) This parameter returns the result of the request.
{   A status of normal means the requested connection has been
{   accepted by the server.
{   CONDITIONS:  rfe$access_code_invalid
{                rfe$client_disabled
{                rfe$client_undefined
{                rfe$client_nad_disabled
{                rfe$client_nad_undefined
{                rfe$client_pid_disabled
{                rfe$client_pid_undefined
{                rfe$connection_not_active
{                rfe$connection_rejected
{                rfe$connection_terminated
{                rfe$device_invalid
{                rfe$local_nad_failure
{                rfe$no_server_response
{                rfe$password_undefined
{                rfe$remote_host_busy
{                rfe$remote_rhf_shutdown
{                rfe$rhf_not_active
{                rfe$server_busy
{                rfe$server_disabled
{                rfe$server_lid_disabled
{                rfe$server_lid_undefined
{                rfe$server_reject_response
{                rfe$server_undefined
{                rfe$switch_accepted
{                rfe$switch_offered
{                rfe$system_interrupt
{                rfe$system_task_shutdown
{                rfe$tcu_disabled
{                rfe$tcu_invalid
{                rfe$unknown_reject_code
{   IDENTIFIER:  'RF'
{
*DECK DECK=RFH$CANCEL_SWITCH_OFFER EXPAND=FALSE

{      The purpose of this request is to cancel an offer to switch ownership of
{ an LCN connection end point to another job executing on the local system.
{
{      Switching ownership of a connection end point is a cooperative process
{ which requires the active participation of both the source job (current
{ owner) and the destination job (proposed owner).  The source job makes an
{ offer to switch a connection end point to a destination job.  The destination
{ job accepts this switch offer to complete the connection end point switch.
{
{      This request is used by a source job to retract a switch offer which has
{ not been accepted by the destination job within a reasonable amount of time.
{
{ RFP$CANCEL_SWITCH_OFFER (CONNECTION_FILE, STATUS)
{
{ CONNECTION_FILE: (input) This parameter specifies the name of the network file
{   identifies the connection end point for which a switch of ownership has
{   been offered.
{
{ STATUS: (output) This parameter returns the results of the request.  A
{   status of normal means that the switch offer has been canceled.
{   CONDITIONS:  rfe$connect_in_progress
{                rfe$connected
{                rfe$connection_not_active
{                rfe$connection_rejected
{                rfe$connection_terminated
{                rfe$local_nad_failure
{                rfe$not_signed_on
{                rfe$switch_accepted
{                rfe$system_interrupt
{                rfe$system_task_shutdown
{   IDENTIFIER:  'RF'
{
*DECK DECK=RFH$CHANGE_ATTRIBUTES EXPAND=FALSE
{
{     The purpose of this request is to change connection attribute
{ values in use for a connection file.  The connection whose attributes are
{ to be changed is specified via the connection file parameter.
{
{     All connection file attributes are global to the job.
{
{ RFP$CHANGE_ATTRIBUTES(CONNECTION_FILE, FILE_ATTRIBUTES, STATUS)
{
{ CONNECTION_FILE: (input) This parameter specifies the name of the
{   connection file to retrieve the attributes from.
{
{ FILE_ATTRIBUTES: (output) This parameter specifies the attributes
{   whose values are to be changed and the desired values.
{
{ STATUS: (output) This parameter returns the status of the request.
{   A value of normal indicates that the specified attributes were
{   changed.
{      CONDITIONS: rfe$invalid_attribute_key
{                  rfe$connection_not_active
{      IDENTIFIER: 'RF'
*DECK DECK=RFH$CHANGE_HOST_OR_LID_STATE EXPAND=FALSE
{
{       The purpose of this routine is to change the state of local or remote
{ host physical identifiers or their logical identifiers in the currently
{ active RHFAM configuration to "ON" or "OFF". This process is valid only
{ when the RHFAM system task is active, and the state change is not preserved
{ when the system task is deactivated.
{
{ RFP$CHANGE_HOST_OR_LID_STATE (PHYSICAL_ID_LIST_P, LOGICAL_ID_LIST_P,
{   ALL_PIDS_SPECIFIED, STATE, STATUS)
{
{ PHYSICAL_ID_LIST_P: (input) This parameter specifies the pointer to a list
{   host names that are to have their state, or state of their specified
{   logical identifiers changed.
{
{ LOGICAL_ID_LIST_P: (input) This parameter specifies the pointer to a list
{   of logical identifiers defined under the the specified physical hosts
{   that are to have their states changed. If this value is NIL, only the
{   states of the specified hosts are changed.
{
{ ALL_PIDS_SPECIFIED: (input) This parameter specifies a boolean value
{   which, if TRUE, specifies that all the hosts are to have their state,
{   or state of their specified logical identifiers changed.
{
{ STATE: (input) This parameter specifies a boolean value denoting the new
{   state of the specified identifier. If true, the identifier is set to
{   "OFF" (disabled).
{
{ STATUS: (output) This status returns the result of the request. A status
{   of normal indicates that the specified state changes have been done.
{
{     CONDITIONS: rfe$logical_id_not_found
{                 rfe$physical_id_not_found
{                 rfe$system_task_not_active
{
{     IDENTIFIER: 'RF'
{
*DECK DECK=RFH$CHANGE_HOST_STATE EXPAND=FALSE
{
{      This subcommand provides the operator with the capability to change
{ the state of the local host and/or any of the remote hosts defined in
{ the currently active RHFAM configuration. This command is valid only while
{ the RHFAM system task is active. The OFF state of a host is lost when
{ the RHFAM system task is de-activated. Changing the state of any host to
{ OFF will inhibit the establishment of subsequent connections between the
{ local host and the corresponding remote host. Changing the state of the
{ local host to OFF has an additional impact. Subsequent connects from any
{ remote host are inhibited. Use of the keyword ALL when specifying the host
{ physical identifier along with the OFF state is an effective way of idling
{ all traffic to or from the local host.
{
{      The caller must have NETWORK_OPERATION capability specified in the
{ validation file, or be the system job in order to use this command.
{
{ CHANGE_HOST_STATE, CHAHS (
{     physical_identifier, pid, pi : LIST OF STRING 3 OR KEY ALL = $REQUIRED
{     state, s : KEY ON OFF = $REQUIRED
{     status)
{
{ physical_identifier:  This parameter specifies the names of the hosts which
{   are to have their states changed. The keyword of ALL can be used to change
{   the state of all hosts.
{
{ state:  This parameter specifies the new state of the specified hosts.
{
{ status:  This parameter returns the results of the request.
{
*DECK DECK=RFH$CHANGE_LID_STATE EXPAND=FALSE
{
{      This subcommand provides the operator with the capability to change
{ the state of a local and/or remote logical identifier defined in the
{ currently active RHFAM configuration. This command is valid only while
{ the RHFAM system task is active. The OFF state of a LID is lost when
{ the RHFAM system task is de-activated. Changing the state of any LID to
{ OFF will inhibit the establishment of subsequent connections to that LID
{ from this host. Changing the state of a local LID to OFF has an additional
{ impact. Subsequent connects from any remote host to that LID are inhibited.
{
{      The caller must have NETWORK_OPERATION capability specified in the
{ validation file, or be the system job in order to use this command.
{
{ CHANGE_LID_STATE, CHALS(
{     physical_identifier, pid, pi : LIST OF STRING 3 OR KEY ALL = $REQUIRED
{     logical_identifier, lid, li : LIST OF STRING 1..31 = $REQUIRED
{     state, s : KEY ON OFF = $REQUIRED
{     status)
{
{ physical_identifier:  This parameter specifies the names of the host
{   mainframes for which the specified LIDs are to have their states changed.
{   The keyword of ALL specifies all host mainframes.
{
{ logical_identifier:  This parameter specifies the names of the LIDs belonging
{   to the specified host mainframes which are to have their states changed.
{
{ state: This parameter specifies the state to set for the specified LIDs.
{
{ status:  This parameter returns the results of the request.
{
*DECK DECK=RFH$CHANGE_NAD_OR_TRUNK_STATE EXPAND=FALSE
{
{       The purpose of this routine is to change the state of Network Access
{ Devices or their trunk connections in the currently active RHFAM
{ configuration to ON, OFF or DOWN. This process is valid only when the
{ RHFAM system task is active. The state change is not preserved when the
{ system task is deactivated. This routine will not attempt to change the
{ state of a NAD or trunk connection that is DOWN as that particular element
{ is under control of maintenance software.
{
{ RFP$CHANGE_NAD_OR_TRUNK_STATE (NAD_NAMES_P, TRUNK_NAMES_P, STATE, STATUS)
{
{ NAD_NAMES_P: (input) This parameter specifies the pointer to a list of nads
{   or the keyword ALL, that are to have their state, or specified trunk
{   connections state changed.
{
{ TRUNK_NAMES_P: (input) This parameter specifies the pointer to a list
{   of trunks which are to have the state of their connections to the specified
{   nads changed. If this value is NIL, only the states of the specified
{   nads are changed.
{
{ STATE: (input) This parameter the value of the state change, either "OFF",
{   "ON", or "DOWN". The value "DOWN" is not possible if the state of a trunk
{   connection is being changed.
{
{ STATUS: (output) This status returns the result of the request. A status
{   of normal indicates that the specified state changes have been done.
{
{     CONDITIONS: rfe$down_trunk_not_changable
{                 rfe$down_nad_not_changable
{                 rfe$element_not_found
{                 rfe$system_task_not_active
{
{     IDENTIFIER: 'RF'
{
*DECK DECK=RFH$CHANGE_NAD_STATE EXPAND=FALSE
{
{      This subcommand provides the operator with the capability of changing
{ the state of a local and/or remote network access device(NAD) defined
{ in the currently active RHFAM configuration to ON, OFF, or DOWN (only local
{ NADS may be set DOWN). OFF or DOWN states are not preserved when the system
{ task is deactivated. Changing the state of a local NAD to OFF or DOWN will
{ cause all activity on that device to terminate immediately, in addition,
{ setting a local NAD DOWN subjects the NAD to the local maintenance routines.
{ While the NAD is DOWN, its state may not be changed by this command. The
{ NAD state may be automatically changed to ON if the maintenance routines
{ deem the NAD usable.
{
{      The caller must have NETWORK_OPERATION capability specified in the
{ validation file, or be the system job in order to use this command.
{
{ CHANGE_NAD_STATE, CHANS(
{     nad, n : LIST OF NAME = $REQUIRED
{     state, s  : KEY ON OFF DOWN = $REQUIRED
{     status)
{
{ nad:  This parameter specifies the names of the nads which are to have
{   their states changed.
{
{ state: This parameter specifies the state to set for the specified NADs.
{
{ status:  This parameter returns the results of the request.
{
*DECK DECK=RFH$CHANGE_TRUNK_STATE EXPAND=FALSE
{
{      This subcommand provides the operator with the capability of changing
{ the state of an LCN trunk, with respect to specified NADS defined in the
{ currently active RHFAM configuration, to ON or OFF. OFF states are not
{ preserved when the RHFAM system task is de-activated. Setting a trunk
{ connection for a NAD to OFF will prevent the use of that trunk connection
{ on subsequent connect requests made from the local host. Any currently
{ active connection using the trunk connection will not be affected.
{
{      The caller must have NETWORK_OPERATION capability specified in the
{ validation file, or be the system job in order to use this command.
{
{ CHANGE_TRUNK_STATE, CHATS(
{     nad, n : LIST OF NAME OR KEY ALL = ALL
{     trunk, t : LIST OF NAME = $REQUIRED
{     state, s  : KEY ON OFF = $REQUIRED
{     status)
{
{ nad:  This parameter specifies the names of the NADs which are to have
{   the states of their connections to the specified trunk(s) changed.
{
{ trunk:  This parameter specifies the names of the trunk connections to
{   the specified NADs which are to have their states changed.
{
{ state: This parameter specifies the state to set for the specified trunk
{   connections.
{
{ status:  This parameter returns the results of the request.
{
*DECK DECK=RFH$CHECK_APPL_STARTUP EXPAND=FALSE

{    The purpose of this routine is to verify that servers, started by the
{    access method, have successfully signed on.  Once they have signed on
{    the system task no longer has control over the incoming connect requests.
{    If a server has not signed on within the connection time-out limit, the
{    access method will abort any incoming connections.
{
{    FOR  each server entry  DO
{      FOR  each server job  DO
{        IF  not signed on within threshold  THEN
{          remove the job entry.
{        IFEND
{      FOREND
{      FOR  each incoming connect  DO
{        IF  connect has not been retrieved within threshold
{            OR the abort connections deactivation is requested  THEN
{          terminate the incoming connect.
{        IFEND
{      FOREND
{      IF  the server job connects are to be aborted  THEN
{        terminate all corresponding connections.
{      IFEND
{      IF  the server is rhfam-initiated
{          AND  there are excess incoming connects  THEN
{        start more server jobs.
{      IFEND
{    FOREND
{    FOR  each client entry  DO
{      IF  the abort connections deactivation is requested  THEN
{        terminate all corresponding connections.
{      IFEND
{    FOREND
{
{    current_time: (input) This parameter specifies the time, in microseconds, that
{      this procedure was called.
*DECK DECK=RFH$CHECK_EVENT_LIST EXPAND=FALSE

{    The purpose of this routine is to scan the list of tasks, which are waiting
{    for an RHFAM event, and readying any task whose corresponding event has
{    occurred.
{
{    FOR  each entry in the event list  DO
{      IF  event has occurred
{          OR the system task is shutting down  THEN
{        mark the event that occurred.
{        wake up the corresponding task.
{      IFEND
{    FOREND
{
{    current_time: (input) This parameter specifies the current time, in
{      microseconds.
{
{    system_task_shutdown: (input) This parameter specifies whether or not to
{      unconditionally restart all tasks waiting for an RHFAM/VE event.  This
{      flag is used for shut-down purposes.
*DECK DECK=RFH$CHECK_HARDWARE_AVAILABLE EXPAND=FALSE

{    The purpose of this routine is to determine if previously downed
{ RHFAM/VE components are now available for service.
{
{    To optimally utilize the LCN, each local RHFAM/VE keeps track of
{ failing hardware components.  This allows the access method to avoid
{ assigning outgoing connections on LCN paths that may not give the
{ user a quality level of service.  As network anomilies are encountered
{ by the PP drivers these anomilies are analyzed and any failing components
{ are flagged as down.
{
{    If a DOWNed element is a local NAD that is maintained by this host then
{ the auto-dump and reload processes are invoked.  These procedures will
{ place the element back in service if the reload was successful.
{
{    When a path has been disabled then this routine is in charge of
{ determining if that path is now available.  The mechanism used is
{ to enable the path for access after it has been out of service
{ for a threshold time.  There a three threshold times.  Each one is
{ based on the length of time that the path has been out of service.  The
{ constants defined below show the threshold classes and corresponding
{ times.
{
{    NOTE - the failure count is used to determine the class.
{           Once a connection has been successfully established
{           across the connection the count is cleared.
{
{    current_time: (input) This parameter specifies the current time
{      in microseconds, which is used to determine if a threshold
{      time has completed.
*DECK DECK=RFH$CHECK_LOCAL_NAD_TEST EXPAND=FALSE
{
{       The purpose of this routine is to check to see if the local NAD
{ test has completed on the specified NAD.  This process is valid only
{ when the RHFAM system task is active.
{
{  RFP$CHECK_LOCAL_NAD_TEST (NAD_NAME, LOCAL_NAD_TEST_COMPLETE, STATUS)
{
{ NAD_NAME: (input) This parameter specifies the nad that is to
{   checked.
{
{ LOCAL_NAD_TEST_COMPLETE: (output) This parameter indicates whether the
{   NAD test has completed (TRUE) or whether it is not complete (FALSE).
{
{ STATUS: (output) This status returns the result of the request.
{
{     CONDITIONS: rfe$element_not_found
{                 rfe$system_task_not_active
{
{     IDENTIFIER: 'RF'
{
*DECK DECK=RFH$CONFIGURATION_UTILITY EXPAND=FALSE

{*******************************************************************************
{*                                                                             *
{*   This module provides the code necessary to install the configuration      *
{*   file for the Remote Host Facility Access Method (RHFAM/VE).               *
{*   The installation is a four step process: the first two steps are          *
{*   done as the result of the user executing the INSTALL_CONFIGURATION        *
{*   directiv under MANAGE_REMOTE_NETWORK.  The last two are initiated         *
{*   by the operator command to activate RHFAM.                                *
{*                                                                             *
{*     1)  The configuration file is verified to make sure it contains         *
{*         a set of valid directives.                                          *
{*                                                                             *
{*     2)  The directives in SCL format are written to the file                *
{*         ($system.rhfam.configuration_cmd_file).                             *
{*                                                                             *
{*     3)  The configuration from the file                                     *
{*         $system.rhfam.configuration_cmd_file is reverified to               *
{*         make sure it contains a set of valid directives.                    *
{*                                                                             *
{*     4)  The SCL directive definitions are transformed into CYBIL            *
{*         definitions and moved to the file                                   *
{*         ($system.rhfam.configuration_file).                                 *
{*                                                                             *
{*   When the RHFAM/VE system task is activated it retrieves the highest cycle *
{*   of the configuration file and activates it.                               *
{*                                                                             *
{*   An additional capability provided by this module is to allow the user to  *
{*   specify that only the verify process be performed on the configuration    *
{*   directives.  This can be used to verify the integrity of the directives   *
{*   without installing the configuration file.                                *
{*                                                                             *
{*******************************************************************************
*DECK DECK=RFH$CONFIG_UTL_HELPER EXPAND=FALSE


{    The purpose of this module is to provide a global save area for the
{    RHFAM/VE Configuration Utility.  A storage area is created at the start
{    of the INSTALL_RHFAM_CONFIGURATION or VERIFY_RHFAM_CONFIGURATION
{    sub_utility and is released when the sub-utility is terminated.
{    The save area is maintained in the task private section.  The code is
{    constructed such that only one INSRC or one VERRC can be active at any
{    instant within a single task.  This is to prevent ambiguous user results,
{    which could result from allowing the user to have nested INSRC/VERRC
{    commands.
{
{    The code also special cases an INSRC request.  A mainframe global lock is
{    set to inhibit multiple INSRC requests from executing simultaneously
{    within the system.
{
{    NOTE:
{         This module is used because user ring code that is bound into
{         the system cannot have global variables.  The configuration
{         utility is run at the user ring level for security purposes.
*DECK DECK=RFH$CONTINUE_IO_REQUEST EXPAND=FALSE

{    The purpose of this routine is to add I/O buffers to an outstanding I/O request.
{
{    request_info: (input) This parameter points to the adaptable sequence which contains the
{      user's request.  The pointer currently points to the next entry following the initial
{      logical command identifier.
{
{    request_id: (input) This parameter specifies the identifier of the corresponding I/O request.
{
{    io_type: (input) This parameter specifies the type of I/O being performed.
{
{    restart_request: (input) This parameter specifies whether or not the request
{      complete flag should be cleared to allow the PP to process the request.
{
{    status: (output) This paramter returns the results of the request.

*DECK DECK=RFH$CONTROL_MESSAGES EXPAND=FALSE

{      The status of path zero determines the capability to send or
{ receive control messages.  The state and clarifier for this path
{ should always be normal (2,1).  The event processor examines the
{ I/O threshold flags to determine if any action is required.  The
{ following algorithm is used:
{
{      IF  output is below threshold
{          AND   control messages are waiting to be sent   THEN
{        queue a request to send the next control message.
{      IFEND
{      IF  input is available  THEN
{        queue a request to receive a control message.
{      IFEND
{
{      The response handler for the receive control message request validates
{ the control message and queues the control message for the corresponding
{ application to retrieve (except for backs).  In this case a 'BACK' counter
{ is incremented in the corresponding connection entry.  If either a control
{ message for an illegal connection or an unsupported control message
{ is received the event processor discards the control message after
{ logging an appropriate diagnostic.  If a control message is
{ successfully received the response handler posts another request
{ to receive an incoming control message.  This continues until
{ a fatal error is encountered or all incoming control messages have
{ been retrieved.
{
{      The response handler for the send control message request
{ verifies that the control message was successfully sent.  If the
{ control message was successfully sent, the response handler posts
{ a request to send another control message.  This continues until;
{ all queued control messages are sent, a fatal error is encountered,
{ or the NAD resources are exhausted.
{
{    nad_index: (input) This parameter specifies the index of the
{      local NAD to check for control message threshold changes.
*DECK DECK=RFH$DEACTIVATE_RHFAM_CLIENT EXPAND=FALSE
{
{       This subcommand deactivates an RHFAM client application. Connection
{ requests by inactive client applications are rejected and established
{ connections may optionally be terminated.
{
{       The caller must have NETWORK_APPLICATION_MANAGEMENT capability specified
{ in the validation file, or be the system job in order to use this command.
{
{
{ DEACTIVATE_RHFAM_CLIENT, DEARC(
{     client, c : NAME 1..7 = $REQUIRED
{     terminate_active_connections, tac : BOOLEAN = FALSE
{     status)
{
{ client: This parameter specifies the name of the client application to
{   be deactivated.
{
{ terminate_active_connections: If TRUE, currently active connections are
{   terminated immediately. If FALSE, processing of currently established
{   connections is allowed to continue until normal termination occurs.
{
{ status: This parameter returns the results of this request. A normal status
{   means that the requested client was deactivated.
{
*DECK DECK=RFH$DEACTIVATE_RHFAM_CLIENT_R3 EXPAND=FALSE
{
{       The purpose of this routine is to deactivate a previously defined
{ RHFAM client, making it unavailable for connection establishment. The
{ table of RHFAM client definitions is searched for the specified client,
{ which, if found and active, is set to inactive. Currently active
{ connections may optionally be terminated.
{        This routine must be called within the system job or the caller
{ must have NETWORK_APPLICATION_MGMT capability.
{
{ RFP$DEACTIVATE_RHFAM_CLIENT (CLIENT, TERMINATE_ACTIVE_CONNECTIONS, STATUS)
{
{ CLIENT: (input) This parameter specifies the name of the client that is
{   to be deactivated.
{
{ TERMINATE_ACTIVE_CONNECTIONS: (input) This parameter is a boolean value
{   denoting whether or not the currently active connections should be
{   terminated. If active connections exist and the RHFAM system task is
{   running, a flag will be set telling the system task to terminate the
{   connections.
{
{ STATUS: (output) This status returns the result of the request. A status
{   of normal indicates that the specified client is inactive.
{
{     CONDITIONS: rfe$appl_not_defined
{                 rfe$appl_already_inactive
{
{     IDENTIFIER: 'RF'
{
*DECK DECK=RFH$DEACTIVATE_RHFAM_SERVER EXPAND=FALSE
{
{       This subcommand deactivates an RHFAM server application. No new
{ connections may be made to this server, and established connections may
{ optionally be terminated.
{
{       The caller must have NETWORK_APPLICATION_MANAGEMENT capability specified
{ in the validation file, or be the system job in order to use this command.
{
{
{ DEACTIVATE_RHFAM_SERVER, DEARS(
{     server, c : NAME 1..7 = $REQUIRED
{     terminate_active_connections, tac : BOOLEAN = FALSE
{     status)
{
{ server: This parameter specifies the name of the server application to
{   be deactivated.
{
{ terminate_active_connections: If TRUE, currently active connections are
{   terminated immediately. If FALSE, processing of currently established
{   connections is allowed to continue until normal termination occurs.
{
{ status: This parameter returns the results of this request. A normal status
{   means that the requested server was deactivated.
{
*DECK DECK=RFH$DEACTIVATE_RHFAM_SERVER_R3 EXPAND=FALSE
{
{       The purpose of this routine is to deactivate a previously defined
{ RHFAM server, making it unavailable to accept connection requests. The
{ table of RHFAM server definitions is searched for the specified server,
{ which, if found and active, is set to inactive. Currently active
{ connections may optionally be terminated.
{        This routine must be called within the system job or the caller
{ must have NETWORK_APPLICATION_MGMT capability.
{
{ RFP$DEACTIVATE_RHFAM_SERVER (SERVER, TERMINATE_ACTIVE_CONNECTIONS, STATUS)
{
{ SERVER: (input) This parameter specifies the name of the server that is
{   to be deactivated.
{
{ TERMINATE_ACTIVE_CONNECTIONS: (input) This parameter is a boolean value
{   denoting whether or not the currently active connections should be
{   terminated. If active connections exist and the RHFAM system task is
{   running, a flag will be set telling the system task to terminate the
{   connections.
{
{ STATUS: (output) This status returns the result of the request. A status
{   of normal indicates that the specified server is inactive.
{
{     CONDITIONS: rfe$appl_not_defined
{                 rfe$appl_already_inactive
{
{     IDENTIFIER: 'RF'
{
*DECK DECK=RFH$DEFINE_LCN_PATH EXPAND=FALSE

{
{      This directive can be used to define the paths between the local
{ host and the defined remote hosts.  One directive is required for
{ each physical LCN path that the user is defining.  This should
{ only be used if the user wants to limit or extend the
{ physical paths which would be defined by the AUTO_PATH_GENERATION
{ directive.
{
{ DEFINE_LCN_PATH, DEFLP(
{      local_nad, ln: name = $required
{      remote_nad, rn: name = $required
{      exclude_trunk, et: list 1..3 of name = $optional
{      physical_identifier, pid, pi: string 3 = $optional
{      host_connection, hc: integer 0..3 = 0
{      logical_network, lnet: integer 0..0FF(16) = 0
{      logical_nad, lnad: integer 0..0FF(16) = 0
{      access_code, ac: integer 0..0FFFF(16) = 0)
{
{ local_nad:  This parameter specifies the name of the local NAD
{   that is used to access the remote host.  The name must have been
{   defined by a previous define_local_nad directive.
{
{ remote_nad:  This parameter specifies the name of the remote
{   NAD that is used to access the remote host.  The name must have
{   been defined by a previous define_remote_nad directive.
{
{ exclude_trunk:  This parameter specifies which trunks, if any, should
{   not be used for this path.
{
{ physical_identifier:  This parameter specifies the remote host that is
{   the destination host on this path.  This parameter is required if the
{   remote nad is an inter-network type of NAD, otherwise this parameter is
{   ignored.
{
{ host_connection:  This parameter specifies which remote NAD
{   device interface should be used to access the remote host.  This is only
{   used if the remote NAD is a VAX NAD and the destination host is not
{   the default host connection.
{
{ logical_network:  This parameter specifies the logical network where
{   the remote host resides.  If zero, the remote_nad is directly
{   coupled to the remote host.
{
{ logical_nad:  This parameter specifies the destination NAD address
{   within the logical network.  This parameter is only meaningful if
{   if the logical_network parameter is non-zero.
{
{ access_code:  This parameter specifies the software access code which
{   must be defined for each of the remote NAD trunk control units that
{   are to be used for this path.
{
*DECK DECK=RFH$DEFINE_LOCAL_HOST EXPAND=FALSE

{
{      This directive is used to uniquely identify the local host within
{ the accessible domain of the local host.  One (and only one) local host
{ directive must be in the configuration file.
{
{      WARNING -  The physical and logical identifiers allow string
{                 values to be specified.  Currently, only NOS/VE
{                 supports identifiers that are not alpha-numeric.
{                 Also, the lower case characters are mapped into
{                 the equivalent upper case character.
{
{ DEFINE_LOCAL_HOST, DEFLH(
{      physical_identifier, pid, pi: string 3 = $required
{      logical_identifiers, logical_identifier, lid, li:
{           list of string 1..31 = $required
{      connection_password, cp: name 7 = passwrd
{      subsystem_identifier, si: name 2 = rh
{      connection_timeout, ct: integer 10..1800 = 30
{      data_transfer_timeout, dtt: integer 30..3600 = 600)
{
{ physical_identifier:  This parameter specifies a string that uniquely
{   defines an LCN host within the domain of the local host.
{
{ logical_identifier:  This parameter specifies a list of strings
{   used to request the services on this host.  A logical identifier
{   can appear under multiple physical identifiers.
{
{      NOTE - The logical identifiers can be 1 to 31 characters in
{             length.  Currently only NOS/VE hosts can request
{             services with LIDs that are not 3 characters in length.
{
{ connection_password:  This parameter specifies the password that
{   is sent in all outgoing connection requests and is used to verify
{   all incoming connection requests.
{
{ subsystem_identifer:  This parameter specifies the subsystem name that
{   is sent in all outgoing connection requests and outgoing control
{   messages.  The subsystem identifier is also used as selection criteria
{   for receiving incoming connection requests and incoming control
{   messages.
{
{ connection_timeout:  This parameter specifies the default timeout value, in
{   seconds, for connect requests.  This value represents the maximum amount
{   of time that the access method should wait for a remote server response
{   to an outgoing connect request or a local server accept for an
{   incoming connect request.  If the timer expires while waiting for one
{   of the defined events, then the corresponding connection is
{   appropriately terminated.
{
{ data_transfer_timeout:  This parameter selects the default timeout value,
{   in seconds, for all data transactions.  The value specifies the maximum
{   amount of time that the access method should wait for a pending data
{   transmission to complete.  If the time between any two successful
{   data transmissions exceeds this value the pending request is terminated.
{
*DECK DECK=RFH$DEFINE_LOCAL_NAD EXPAND=FALSE

{
{      The purpose of this request is to define a local NAD and its
{ attributes.  One directive is required for each local NAD.
{
{ DEFINE_LOCAL_NAD, DEFLN(
{      nad, n: name = $required
{      address, a: integer 1..0FF(16) = $required
{      trunk_control_unit_0, tcu0: name = $optional
{      trunk_control_unit_1, tcu1: name = $optional
{      trunk_control_unit_2, tcu2: name = $optional
{      trunk_control_unit_3, tcu3: name = $optional
{      tcu_access_code_0, tac0: integer 0..0FFFF(16) = 0
{      tcu_access_code_1, tac1: integer 0..0FFFF(16) = 0
{      tcu_access_code_2, tac2: integer 0..0FFFF(16) = 0
{      tcu_access_code_3, tac3: integer 0..0FFFF(16) = 0
{      pp_drivers, pd: integer 1..2 = 1
{      perform_auto_reload, par: boolean = TRUE
{      reload_threshold, rt: integer 1..99 = 10
{      dump_disposition, dd: key DISCARD,SAVE_LAST,SAVE_ALL = DISCARD
{      maximum_connections, mc: integer 2..127 = 35
{      maximum_nad_entries, mne: integer 2..127 = 25
{      send_queue_limit, sql: integer 1..127 = 2
{      receive_queue_limit, rql: integer 1..127 = 2
{      monitor_trace, mt: integer 0..31 = 0
{      trunk_trace, tt: integer 0..31 = 0
{      device_trace, dt: integer 0..31 = 0)
{
{ nad:  This parameter is used to uniquely identify a local NAD
{   for this configuration file.  This name must match the name of
{   a NAD that is defined in the PHYSICAL_CONFIGURATION_UTILITY.
{   The actual verification of the name is done when the system
{   task activates the configuration.
{
{ address:  This parameter specifies the physical network
{   address of the local NAD.
{
{ trunk_control_unit_0(1,2,3):  These parameters uniquely identify
{   the trunks that are attached to each trunk control unit of this
{   local NAD.
{
{ tcu_access_code_0(1,2,3):  These parameters specify the software access
{   codes, which are used to control routing between the NADs.  Each
{   access code corresponds to the matching trunk control unit.  The
{   parameter values should normally be left set to zero.  See the 380-170 NAD
{   Hardware Reference Manual for further information on NAD access codes.
{
{ pp_drivers: This parameter specifies the number of pp drivers to drive
{   the local NAD.  For performance purposes (especially with 2XPP, i.e.
{   810 or 830 class machines) the site may wish to specify two PP drivers
{   to drive a local NAD.  If the PP utilization is a concern, then this
{   parameter should be set to 1 for each local NAD.
{
{ perform_auto_reload:  This parameter specifies whether the access
{   method is supposed to reload the NAD microcode when an
{   unrecoverable error condition is encountered.
{
{ reload_threshold:  This parameter specifies the number of microcode
{   reloads the access method should allow before declaring the device
{   unusable.  This parameter is not meaningful if the 'par' parameter
{   is FALSE.
{
{ dump_disposition:  This parameter specifies what disposition the access
{   method should use to dispose of the dump file that is generated
{   by the auto reload processing.  If DISCARD, the dump file will be
{   discarded.  If SAVE_LAST, the dump will be saved on a disk
{   file.  Only the most recent copy for this local NAD will be
{   preserved.  If SAVE_ALL, all dumps associated with this local NAD
{   will be preserved on disk until the reload threshold is reached or
{   cycle 999 has been used.  This parameter is not meaningful if
{   the 'par' parameter is FALSE.
{
{      Note - a file ($system.rhfam.nad_dumps.nad, where 'nad' is the name
{             of the local NAD) is created for each NAD dump performed.  Each
{             dump is an individual cycle of the file.
{
{ The remaining parameters are used to tailor the NAD microcode load.
{ These parameters are not meaningful if the 'par' parameter is FALSE.
{ A further explanation of these parameters can be obtained in Appendix
{ E in the 380-170 NAD Hardware Reference Manual (see references).
{
{ WARNING:
{   Changing any of the following parameters will probably impact the
{   performance of the NAD.
{
{ maximum_connections:  The purpose of this parameter is to define
{   the maximum number of concurrent connections that can be active
{   in this NAD at any instant.
{
{ maximum_nad_entries:  The purpose of this parameter is to define the
{   maximum number of remote NADs that this NAD can communicate with.
{
{ send_queue_limit:  The purpose of this parameter is to define the
{   maximum number of messages a connection may have queued, waiting
{   to be sent to the destination NAD, in this NAD.
{
{ receive_queue_limit:  The purpose of this parameter is to define the
{   the maximum number of messages a connection may have queued,
{   waiting to be received by the local host, in this NAD.
{
{ monitor_trace:  The purpose of this parameter is to define the number
{   of 32-word buffers to be used for the monitor trace.  A value of
{   zero means the trace is disabled.
{
{ trunk_trace:  The purpose of this parameter is to define the number
{   of 32-word buffers to be used for the trunk trace.  A value of
{   zero means the trace is disabled.
{
{ device_trace:  The purpose of this parameter is to define the number
{   of 32-word buffers to be used for the device trace.  A value of
{   zero means the trace is disabled.
{
*DECK DECK=RFH$DEFINE_REMOTE_HOST EXPAND=FALSE

{
{      This directive is used to uniquely identify each remote host within
{ the accessable domain of the local host.  One remote host definition is
{ required for each remote host that is to be accessed from the local host.
{
{      WARNING -  The physical and logical identifiers allow string
{                 values to be specified.  Currently, only NOS/VE
{                 supports identifiers that are not alpha-numeric.
{                 Also, the lower case characters are mapped into
{                 the equivalent upper case character.
{
{ DEFINE_REMOTE_HOST, DEFRH(
{      physical_identifier, pid, pi: string 3 = $required
{      logical_identifiers, logical_identifier, lid, li:
{           list of string 1..31 = $required)
{
{ physical_identifier:  This parameter specifies a string that uniquely
{   defines this remote host within the domain of the local host.
{
{ logical_identifier:  This parameter specifies a list of strings
{   used to request the services of this host.  A logical identifier
{   can appear under multiple physical identifiers.
{
{      NOTE - The logical identifiers can be 1 to 31 characters in
{             length.  Currently only NOS/VE hosts can define
{             LIDs that are not 3 characters in length.
{

*DECK DECK=RFH$DEFINE_REMOTE_NAD EXPAND=FALSE

{
{      This directive specifies the remote NADs that are accessable
{ from this mainframe.  One directive is required for each remote NAD
{ that is to be accessed from the local host.
{
{ DEFINE_REMOTE_NAD(
{      nad, n: name = $required
{      address, a: integer 1..0FF(16) = $required
{      host_connection_0, hc0: string 3 = $optional
{      host_connection_1, hc1: string 3 = $optional
{      host_connection_2, hc2: string 3 = $optional
{      host_connection_3, hc3: string 3 = $optional
{      trunk_control_unit_0, tcu0: name = $optional
{      trunk_control_unit_1, tcu1: name = $optional
{      trunk_control_unit_2, tcu2: name = $optional
{      trunk_control_unit_3, tcu3: name = $optional
{      nad_type, nt: key C170,C180,IBM,VAX,C200,NTN,INET = C180
{      tcu_access_code_0, tac0: integer 0..0FFFF(16) = 0
{      tcu_access_code_1, tac1: integer 0..0FFFF(16) = 0
{      tcu_access_code_2, tac2: integer 0..0FFFF(16) = 0
{      tcu_access_code_3, tac3: integer 0..0FFFF(16) = 0)
{
{ nad:  This parameter is used to uniquely define a remote
{   NAD for this configuration file.
{
{ address:  This parameter specifies the physical network
{   address of the remote NAD.
{
{ host_connection_0(1,2,3):  These parameters specify the hosts which are
{   directly coupled to the NAD, via a device interface (i.e. a CYBER
{   channel).  The value of this parameter must be a physical identifier
{   of a previously defined remote host.  For the C170, C180, C200, and IBM
{   NADs, host_connection_0 (and only host_connection_0) must specify the
{   directly coupled host.  For a VAX NAD, any combination of hosts
{   can be connected to any or all of the four NAD host ports.  This
{   parameter is ignored for NTN or INET NADs.
{
{ nad_type:  This parameter specifies the type of nad that is
{   being defined.
{
{ trunk_control_unit_0(1,2,3)  These parameters specify the names of
{   the common trunks between a local NAD and this remote NAD.  The
{   physical trunk control units correspond to the trunk connections
{   to the remote NAD.
{
{ tcu_access_code_0(1,2,3):  These parameters specify the software access
{   codes, which are used to control routing between the NADs.  The
{   access codes correspond to the matching trunk control unit.  The
{   parameter values should normally be left set to zero.  See the 380-170 NAD
{   Hardware Reference Manual for further information on NAD access codes.
{
*DECK DECK=RFH$DEFINE_RHFAM_CLIENT EXPAND=FALSE
{
{       This subcommand defines an RHFAM client application and the client's
{ attributes.
{
{       The caller must have NETWORK_APPLICATION_MANAGEMENT capability specified
{ in the validation file, or be the system job in order to use this command.
{
{
{ DEFINE_RHFAM_CLIENT, DEFRC(
{     client, c : NAME 1..7 = $REQUIRED
{     maximum_connections, mc : INTEGER 1..255 = 255
{     user_capability, uc : NAME OR KEY none = none
{     ring, r : INTEGER 1..15 = 13
{     system_privilege, sp : BOOLEAN = FALSE
{     system_wide_connection_mgmt, swcm : BOOLEAN = FALSE
{     status)
{
{ client: This parameter specifies the name of the client application.
{
{ maximum_connections: This parameter specifies the maximum number of
{   concurrent connections that can be established for all instances of
{   a client application. The default value is 255.
{
{ user_capability: This parameter specifies the name of the capability required
{   to be in the caller's validation file entry in order to call the affected
{   RHFAM program interfaces. The keyword NONE indicates that no capability
{   is to be validated.
{
{ ring: This parameter specifies the maximum ring number from which the
{   affected RHFAM program interfaces may be called. The default value for
{   this attribute is 13.
{
{ system_privilege: A value of TRUE indicates the affected RHFAM program
{   interfaces may be called only from code with system privilege. A value
{   of FALSE indicates requests may be made from any system or user code.
{   The default value is FALSE.
{
{ system_wide_connection_mgmt: (input) This parameter is a boolean value
{   which, if TRUE, specifies that the maximum number of connects, as
{   specified by the parameter MAXIMUM_CONNECTIONS, will be managed across
{   the whole system for this client.  If FALSE, the connections will be
{   managed on a job basis.  This means that, if TRUE, the maximum number
{   of connects per job will not be limited by the number reserved at
{   APPLICATION_SIGN_ON time but is limited by the maximum number of
{   connects allowed for this type of client.  The default value is FALSE.
{
{ status: This parameter returns the results of this request. A normal status
{   means that the requested server was defined.
{
*DECK DECK=RFH$DEFINE_RHFAM_CLIENT_R3 EXPAND=FALSE
{
{       The purpose of this routine is to define an RHFAM client application.
{ The RHFAM client and server tables are searched to verify that the specified
{ application name is unique.
{        This routine must be called within the system job or the caller
{ must have NETWORK_APPLICATION_MGMT capability.
{
{ RFP$DEFINE_RHFAM_CLIENT (CLIENT, MAXIMUM_CONNECTIONS, CAPABILITY, RING,
{   SYSTEM_PRIVILEGE, STATUS)
{
{ CLIENT: (input) This parameter specifies the name of the client that is
{   to be defined.
{
{ MAXIMUM_CONNECTIONS: (input) This parameter specifies the maximum number
{   of concurrent connections allowed for all instances of a client
{   application.
{
{ CAPABILITY: (input) This parameter may specify a user capability that
{   is required to call RHFAM program interfaces which perform client
{   application functions. An empty name specifies that no user capability
{   is required to call these interfaces.
{
{ RING: (input) This parameter specifies the highest ring from which RHFAM
{   program interfaces which perform client application functions may be
{   called.
{
{ SYSTEM_PRIVILEGE: (input) This parameter is a boolean value which, if TRUE,
{   specifies that access to RHFAM program interfaces which perform client
{   application functions is limited to callers with system privilege.
{
{ SYSTEM_WIDE_CONNECTION_MGMT: (input) This parameter is a boolean value
{   which, if TRUE, specifies that the maximum number of connects, as
{   specified by the parameter MAXIMUM_CONNECTIONS, will be managed across
{   the whole system for this client.If FALSE, the connections will be
{   managed on a job basis.  This means that, if TRUE, the maximum number
{   of connects per job will not be limited by the number reserved at
{   APPLICATION_SIGN_ON time but is limited by the maximum number of
{   connects allowed for this type of client.
{
{ STATUS: (output) This status returns the result of the request. A status
{   of normal indicates that the specified client has been defined.
{
{     CONDITIONS: rfe$duplicate_appl_definition
{                 rfe$client_defined_as_server
{
{     IDENTIFIER: 'RF'
{
*DECK DECK=RFH$DEFINE_RHFAM_SERVER EXPAND=FALSE
{
{       This subcommand defines an RHFAM server application and the server's
{ attributes.
{
{       The caller must have NETWORK_APPLICATION_MANAGEMENT capability specified
{ in the validation file, or be the system job in order to use this command.
{
{
{ DEFINE_RHFAM_SERVER, DEFRS(
{     server, s : NAME 1..7 = $REQUIRED
{     rhfam_initiated, ri : BOOLEAN = TRUE
{     maximum_connections, mc : INTEGER 1..255 = 255
{     user_capability, uc : NAME OR KEY none = none
{     ring, r : INTEGER 1..15 = 13
{     system_privilege, sp : BOOLEAN = FALSE
{     server_job, sj : FILE = $OPTIONAL
{     server_job_maximum_connections, sjmc : INTEGER 1..255 = 255
{     accept_connection, ac : BOOLEAN = TRUE
{     rhfam_validates_connection_lid, rvcl : BOOLEAN = TRUE
{     status)
{
{ server: This parameter specifies the name of the server application.
{   Client applications must specify this name on connect requests.
{
{ rhfam_initiated: A value of TRUE indicates that RHFAM is to initiate an
{   instance of the server when necessary to service a connection request
{   from a client. A value of FALSE indicates that instances of the server
{   will be initiated by a process independent of RHFAM. The default value
{   is TRUE.
{
{ maximum_connections: This parameter specifies the the maximum number of
{   concurrent connections that can be established for all instances of
{   a server application. The default value is 255.
{
{ user_capability: This parameter specifies the name of the capability required
{   to be in the caller's validation file entry in order to call the affected
{   RHFAM program interfaces. The keyword NONE indicates that no capability
{   is to be validated.
{
{ ring: This parameter specifies the maximum ring number from which the
{   affected RHFAM program interfaces may be called. The default value for
{   this attribute is 13.
{
{ system_privilege: A value of TRUE indicates the affected RHFAM program
{   interfaces may be called only from code with system privilege. A value
{   of FALSE indicates requests may be made from any system or user code.
{   The default value is FALSE.
{
{ server_job: This parameter specifies the file that contains the job stream
{   that RHFAM is to submit for execution, to process requests for this
{   server. This parameter must be specified if the rhfam_initiated parameter
{   is TRUE, but is ignored if rhfam_initiated is FALSE.
{
{ server_job_maximum_connections: This parameter specifies the number of
{   concurrent connections supported by a specific instance of the server
{   application. This parameter is ignored if the rhfam_initiated parameter
{   is FALSE. The default value is 255.
{
{ accept_connection: This parameter specifies whether RHFAM should accept
{   connection requests on behalf of the specified server before assigning
{   the connection to the server application job. If TRUE, RHFAM accepts
{   incoming connect requests for this server (up to the connection limit).
{   and queues the accepted requests for the server to retrieve. If FALSE,
{   RHFAM queues all incoming connect requests for this server (up to the
{   connection limit). The server must then retrieve AND accept the
{   connections. The default value is TRUE.
{
{ rhfam_validates_connection_lid: This parameter specifies whether or not
{   the destination LID in a connection request must match a local host LID.
{   If TRUE, RHFAM checks the destination LID before starting the server.
{   If FALSE, RHFAM does not check the destination LID.  The default is TRUE.
{
{ status: This parameter returns the results of this request. A normal status
{   means that the requested server was defined.
{
*DECK DECK=RFH$DEFINE_RHFAM_SERVER_R3 EXPAND=FALSE
{
{       The purpose of this routine is to define an RHFAM server application.
{ The RHFAM server and client tables are searched to verify that the specified
{ application name is unique.
{        This routine must be called within the system job or the caller
{ must have NETWORK_APPLICATION_MGMT capability.
{
{ RFP$DEFINE_RHFAM_SERVER (SERVER, RHFAM_INITIATED, MAXIMUM_CONNECTIONS,
{   CAPABILITY, RING, SYSTEM_PRIVILEGE, SERVER_JOB, SERVER_JOB_MAX_CONNECTIONS,
{   ACCEPT_CONNECTION, RHFAM_VALIDATES_CONNECTION_LID, STATUS)
{
{ SERVER: (input) This parameter specifies the name of the server that is
{   to be defined.
{
{ RHFAM_INITIATED: (input) This parameter is a boolean value which, if TRUE,
{   specifies that RHFAM is to initiate an instance of the server application
{   when necessary to process a client's connection request. If FALSE, the
{   server application is initiated via an independent process.
{
{ MAXIMUM_CONNECTIONS: (input) This parameter specifies the maximum number
{   of concurrent connections allowed for all instances of a server
{   application.
{
{ CAPABILITY: (input) This parameter may specify a user capability that
{   is required to call RHFAM program interfaces which perform server
{   application functions. An empty name specifies that no user capability
{   is required to call these interfaces.
{
{ RING: (input) This parameter specifies the highest ring from which RHFAM
{   program interfaces which perform server application functions may be
{   called.
{
{ SYSTEM_PRIVILEGE: (input) This parameter is a boolean value which, if TRUE,
{   specifies that access to RHFAM program interfaces which perform server
{   application functions is limited to callers with system privilege.
{
{ SERVER_JOB: (input) This parameter specifies a file containing a sequence
{   of SCL commands that execute an instance of an RHFAM-initiated server
{   application. This file is saved in the $SYSTEM.RHFAM.SERVER catalog.
{   This parameter is valid only if RHFAM_INITIATED is TRUE.
{
{ SERVER_JOB_MAX_CONNECTIONS: (input) This parameter specifies the maximum
{   number of connections that an RHFAM-initiated server job can support.
{   This parameter may be specified only if RHFAM_INITIATED is TRUE.
{
{ ACCEPT_CONNECTION: (input) This parameter is a boolean value which, if
{   TRUE, specifies that RHFAM is to accept connections on behalf of a
{   server application.
{
{ RHFAM_VALIDATES_CONNECTION_LID: (input) This parameter is a boolean value
{   which specifies that RHFAM ensures that the destination LID in the
{   connection request matches a local host LID.
{
{ STATUS: (output) This status returns the result of the request. A status
{   of normal indicates that the specified server has been defined.
{
{     CONDITIONS: rfe$duplicate_appl_definition
{                 rfe$server_defined_as_client
{
{     IDENTIFIER: 'RF'
{
*DECK DECK=RFH$DELETE_RHFAM_CLIENT EXPAND=FALSE
{
{      This subcommand deletes the definition of an RHFAM client
{ application. A client must be inactive and have no active connections
{ before it can be deleted.
{
{       The caller must have NETWORK_APPLICATION_MANAGEMENT capability specified
{ in the validation file, or be the system job in order to use this command.
{
{
{ DELETE_RHFAM_CLIENT, DELRC(
{      client, c: NAME 1..7 = $REQUIRED
{      status)
{
{ client:  This parameter specifies the name of the client application
{   whose definition is to be deleted.
{
{ status:  This parameter returns the results of the request.
{
*DECK DECK=RFH$DELETE_RHFAM_CLIENT_R3 EXPAND=FALSE
{
{       The purpose of this routine is to delete an RHFAM client definition.
{ A client must be inactive and have no active connections before it can
{ be deleted.
{        This routine must be called within the system job or the caller
{ must have NETWORK_APPLICATION_MGMT capability.
{
{ RFP$DELETE_RHFAM_CLIENT (CLIENT, STATUS)
{
{ CLIENT: (input) This parameter specifies the name of the client that is
{   to be deleted.
{
{ STATUS: (output) This status returns the result of the request. A status
{   of normal indicates that the specified client definition has been deleted.
{
{     CONDITIONS: rfe$appl_not_defined
{                 rfe$appl_not_inactive
{                 rfe$appl_job_signed_on
{
{     IDENTIFIER: 'RF'
{
*DECK DECK=RFH$DELETE_RHFAM_SERVER EXPAND=FALSE
{
{      This subcommand deletes the definition of an RHFAM server
{ application. A server must be inactive and have no active connections
{ before it can be deleted.
{
{       The caller must have NETWORK_APPLICATION_MANAGEMENT capability specified
{ in the validation file, or be the system job in order to use this command.
{
{
{ DELETE_RHFAM_SERVER, DELRS(
{      server, s: NAME 1..7 = $REQUIRED
{      status)
{
{ server:  This parameter specifies the name of the server application
{   whose definition is to be deleted.
{
{ status:  This parameter returns the results of the request.
{
*DECK DECK=RFH$DELETE_RHFAM_SERVER_R3 EXPAND=FALSE
{
{       The purpose of this routine is to delete an RHFAM server definition.
{ A server must be inactive and have no active connections before it can
{ be deleted.
{        This routine must be called within the system job or the caller
{ must have NETWORK_APPLICATION_MGMT capability.
{
{ RFP$DELETE_RHFAM_SERVER (SERVER, STATUS)
{
{ SERVER: (input) This parameter specifies the name of the server that is
{   to be deleted.
{
{ STATUS: (output) This status returns the result of the request. A status
{   of normal indicates that the specified server definition has been deleted.
{
{     CONDITIONS: rfe$appl_not_defined
{                 rfe$appl_not_inactive
{                 rfe$appl_job_signed_on
{
{     IDENTIFIER: 'RF'
{
*DECK DECK=RFH$DELINK_REQUEST EXPAND=FALSE

{    The purpose of this routine is to remove completed requests from the
{ PP or the unit request queue.  In addition to delinking the request,
{ the request buffer is FREEd.
{
{    request_id: (input,output) This parameter specifies the identifier of
{      the request to delink.  Upon return the ring 1 identifier fields
{      are no longer valid.
{
{    status: (output) This parameter returns the results of the request.
*DECK DECK=RFH$DESCRIPTION_OF_DIRECTIVES EXPAND=FALSE

{
{    A configuration file must be installed for RHFAM/VE on each
{ local host that RHFAM/VE is executing on.  This configuration file
{ must define the following:
{
{    1)   The local host identification and the corresponding
{         attributes of the local host.  There must be one and only one
{         local host definition.
{
{    2)   The identification of all accessible remote hosts and
{         the logical identifiers that are used to request the services
{         provided by the corresponding host.  Each remote host must
{         be uniquely named.  The logical identifiers can apply to
{         multiple hosts.
{
{    3)   All NADs that are directly coupled to the local host
{         via a channel (local NADs).  There must be at least one local NAD
{         definition.
{
{    4)   All NADs that are directly accessible from the local NADs (remote
{         NADs).
{
{    5)   All physical paths between the local host and each remote host.
{         The user can either specify each of the desired paths or allow
{         the access method to generate the physical paths between the
{         above elements.
{
{    The configuration file consists of subcommand directives which
{ will be interpreted and installed by a MANAGE_RHFAM_NETWORK
{ subcommand (INSTALL_RHFAM_CONFIGURATION).  This file can be
{ created at any time using whatever editing procedures the user
{ is familiar with.
{
{    NOTE - The configuration directives do not provide for
{           individual status information to be returned.  The
{           status parameter on the INSRC or VERRC sub-commands is used
{           to convey the validity status for a set of configuration
{           directives.
{
{ The following terms are referenced in this section:
{
{ local host:  This refers to the mainframe where the configuration
{   file is being installed.
{
{ local NAD:  This refers to a NAD that is directly coupled, via a
{   channel, to the local host.
{
{ remote host:  This refers to a mainframe that can be accessed via
{   the LCN from the local host.
{
{ remote NAD:  This refers to a NAD that has an LCN communication
{   link between itself and a local NAD.  The remote NADs, in
{   conjunction with the local NADs, are used to define the physical
{   paths between the local host and the remote hosts.
{
{ loopback:  This refers to the establishment of a connection
{   where both connection end points are in a NAD which is attached to the
{   local host.  In this instance the local host and remote host refer to
{   the same host.
{
{      The following configuration directives are used to build the
{ RHFAM configuration file.  The only restriction on the order of
{ the directives is that elements, which are referenced within a directive,
{ must be previously defined by an appropriate directive.  (i.e. a remote
{ host directive must occur prior to a remote NAD directive that
{ specifies that remote host as a connecting host).
{
{    There are some additional constraints between the DEFINE_LCN_PATH
{ and AUTO_PATH_GENERATION directives.
*DECK DECK=RFH$DISPLAY_ACTIVE_APPLICATIONS EXPAND=FALSE
{
{      This subcommand provides the operator with a display of applications
{ which are currently signed on to the local access method. The criteria
{ selection order for this display is as follows:
{
{      1)   All jobs that are specified by the job_name parameter.
{
{      2)   All applications that are specified by the application_name
{           parameter.
{
{ DISPLAY_ACTIVE_APPLICATIONS, DISPLAY_ACTIVE_APPLICATION, ..
{   DISPLAY_ACTIVE_APPL, DISAA(
{      job_name, jn : LIST OF NAME  OR  KEY ALL = ALL
{      application_name, an : LIST OF NAME 1..7  OR  KEY ALL = ALL
{      display_option, do : KEY APPLICATIONS A CONNECTIONS C = A
{      output, o : FILE = $OUTPUT
{      status)
{
{ job_name:  This parameter specifies a list of job names (system-
{   supplied) which serve as selection criteria for the display.
{
{ application_name:  This parameter specifies a list of application
{   names which serve as selection criteria for the display.
{
{ display_option:  This parameter specifies the type of information that
{   the operator wants displayed.
{
{      APPLICATIONS, A:  This option displays all selected applications
{           that are currently signed on to the local access method.
{
{      CONNECTIONS, C:  This option displays all connections associated
{           with the selected applications.
{
{ output:  This parameter specifies the name of the file that is to
{   receive the output from this request.
{
{ status:  This parameter returns the results of the request.
{
*DECK DECK=RFH$DISPLAY_ACTIVE_APPL_R3 EXPAND=FALSE
{
{       The purpose of this routine is to display the applications or
{ connections associated with jobs signed on to the Remote Host Facility
{ Access Method. The information required to produce this display is obtained
{ from RFV$RHFAM_JOB_TABLE.
{ The caller of this routine uses the standard command language display
{ interface routines and has opened the display file. It will be closed by
{ the caller when this routine exits.
{
{ RFP$DISPLAY_ACTIVE_APPL_R3 (JOB_NAME_LIST, APPLICATION_NAME_LIST,
{   DISPLAY_TYPE, DISPLAY_CONTROL, STATUS)
{
{ JOB_NAME_LIST: (input) This parameter specifies a list of job names (either
{   user or system_supplied) or the keyword ALL, which is used as selection
{   criteria for the display.
{
{ APPLICATION_NAME_LIST: (input) This parameter specifies a list of application
{   names or the keyword ALL, which is used as selection criteria for the
{   display.
{
{ DISPLAY_TYPE: (input) This parameter specifies the type of display desired:
{
{     rfc$adt_connections: This option causes all connections associated with
{           the selected applications to be displayed.
{
{     rfc$adt_applications: This option causes all selected applications currently
{           signed on to the local access method to be displayed.
{
{ DISPLAY_CONTROL: (input_output) This parameter specifies all information
{   required by the command language display interface routines about the
{   display file. This data is set up by the caller of this routine when
{   the display file is opened and will be updated by this routine as display
{   information is generated.
{
{ STATUS: (output) This parameter returns the results of the request. A
{   status of normal indicates all applications specified have been displayed:
{
{   CONDITIONS: rfe$appl_not_defined
{
{   IDENTIFIER: 'RF'
{
*DECK DECK=RFH$DISPLAY_LOGICAL_IDS EXPAND=FALSE
{
{      This subcommand provides the operator with a display of the hosts
{ and associated logical identifiers defined within a local RHFAM network.
{ This command will display the physical identifiers and corresponding
{ logical identifiers from the currently active configuration, or optionally,
{ from the installed configuration file prior to activation by the RHFAM
{ system task. If the active configuration is displayed, the availability
{ status of the PIDs and corresponding LIDs are displayed.
{
{ DISPLAY_LOGICAL_IDENTIFIERS, DISPLAY_LOGICAL_IDENTIFIER, DISLI(
{      physical_identifier, pid, pi: LIST OF STRING 3 OR KEY ALL LOCAL
{           = ALL
{      logical_identifier, lid, li: LIST OF STRING 1..31 OR KEY ALL
{           NONE = ALL
{      display_option, do: KEY ACTIVE A INSTALLED I = ACTIVE
{      output, o: FILE = $OUTPUT
{      status)
{
{ physical_identifier:  This parameter specifies the names of the host
{   mainframes that are to be displayed.  Each matching PID will be
{   displayed.
{
{ logical_identifier:  This parameter specifies the names of the LIDs
{   that are to be displayed.  Each matching LID, that is defined under
{   a matching PID, will be displayed.
{
{ display_option:  This parameter specifies whether the active configuration
{   or the installed configuration file generated by the RHFAM configuration
{   utility is used as input data to form the display. If the INSTALLED
{   option is used, it is not possible to display the availability status
{   of the hosts and/or LIDs. The ACTIVE option may be used only when the
{   RHFAM system task is active.
{
{ output:  This parameter specifies the name of the file that is to
{   receive the output of this command.
{
{ status:  This parameter returns the results of the request.
{
*DECK DECK=RFH$DISPLAY_NAD_STATUS EXPAND=FALSE
{
{      This subcommand provides the operator with a display of the
{ current status of all requested NADs.
{
{ DISPLAY_NAD_STATUS, DISNS(
{      local_nad, ln: LIST OF NAME OR KEY ALL NONE = ALL
{      remote_nad, rn: LIST OF NAME OR KEY ALL NONE = ALL
{      display_option, do: KEY BRIEF B FULL F = BRIEF
{      ouptut, o: FILE = $OUTPUT
{      status)
{
{ local_nad:  This parameter specifies the names of corresponding
{   local NADs whose status is to be displayed.
{
{ remote_nad:  This parameter specifies the names of corresponding
{   remote NADs whose status is to be displayed.
{
{ display_option:  This parameter specifies the amount of information
{   to be displayed with the selected NADs.  If BRIEF, for each selected
{   NAD; the name, the unique physical attribute (channel for local NADs
{   and NAD address for remote NADs), and the availability status are
{   displayed.  If FULL, for each selected NAD the last connect time,
{   remote NAD types, and local NAD reload counts are displayed along
{   with the BRIEF data.
{
{ output:  This parameter specifies the name of the file that is to
{   receive the output from this request.
{
{ status:  This parameter returns the results of the request.
{
*DECK DECK=RFH$DISPLAY_PHYSICAL_PATHS EXPAND=FALSE
{
{      This subcommand provides the operator with a display of the physical
{ paths defined within a local RHFAM network. This command will display a
{ description of the physical paths from the local host to each specified
{ PID (including loopback paths) from the currently active configuration,
{ or optionally, from the installed configuration file prior to
{ activation by the RHFAM system task. If the active configuration is
{ displayed, the availability status of each path and the local NAD
{ channel numbers are included in the display.
{
{ DISPLAY_PHYSICAL_PATHS, DISPLAY_PHYSICAL_PATH, DISPP(
{      physical_identifier, pid, pi: LIST OF STRING 3 OR KEY ALL LOCAL
{           = ALL
{      display_option, do: KEY ACTIVE A INSTALLED I = ACTIVE
{      output, o: FILE = $OUTPUT
{      status)
{
{ physical_identifier:  This parameter specifies the names of the host
{   mainframes that are to have their paths from the local host displayed.
{   Each matching PID will have its paths displayed.
{
{ display_option:  This parameter specifies whether the active configuration
{   or the installed configuration file generated by the RHFAM configuration
{   utility is used as input data to form the display. If the INSTALLED
{   option is used, it is not possible to display the availability status
{   of the paths or the channel numbers of the local NADs. The ACTIVE option
{   may be used only while the RHFAM system task is active.
{
{ output:  This parameter specifies the name of the file that is to
{   receive the output of this command.
{
{ status:  This parameter returns the results of the request.
{
*DECK DECK=RFH$DISPLAY_RHFAM_CLIENTS EXPAND=FALSE
{
{      This subcommand provides the network application manager with a
{ display of all clients that have been defined for the local RHFAM.
{
{ DISPLAY_RHFAM_CLIENTS, DISRC(
{      client, c: LIST OF NAME 1..7 OR KEY ALL = ALL
{      ouptut, o: FILE = $OUTPUT
{      status)
{
{ client:  This parameter specifies a list of client applications
{   which, if defined, will be displayed.
{
{ output:  This parameter specifies the name of the file that is to
{   receive the output from this request.
{
{ status:  This parameter returns the results of the request.
{
*DECK DECK=RFH$DISPLAY_RHFAM_CLIENTS_R3 EXPAND=FALSE
{
{       The purpose of this routine is to display the client applications
{ which have been defined for the Remote Host Facility Access Method. The
{ information required to produce the display of the local clients is taken
{ from RFV$RHFAM_CLIENT_TABLE.
{ The caller of this routine uses the standard command language display
{ interface routines and has opened the display file. It will be closed by
{ the caller when this routine exits.
{
{ RFP$DISPLAY_RHFAM_CLIENTS (CLIENT_LIST, DISPLAY_CONTROL, STATUS)
{
{ CLIENT_LIST: (input) This parameter specifies a list of client names or
{   the keyword ALL, which is used as selection criteria for the display.
{
{ DISPLAY_CONTROL: (input_output) This parameter specifies all information
{   required by the command language display interface routines about the
{   display file. This data is set up by the caller of this routine when
{   the display file is opened and will be updated by this routine as display
{   information is generated.
{
{ STATUS: (output) This parameter returns the results of the request. A
{   status of normal indicates all clients specified have been displayed:
{
{   CONDITIONS: rfe$client_not_found
{
{   IDENTIFIER: 'RF'
{
*DECK DECK=RFH$DISPLAY_RHFAM_ELEMENTS EXPAND=FALSE
{
{       The purpose of this routine is to display the hardware elements
{ (local and remote Network Access Devices and trunks) and their status,
{ which are defined for the Remote Host Facility Access Method. The information
{ required to produce the display is taken from RFV$RHFAM_STATUS_TABLE.
{ The caller of this routine uses the standard command language display
{ interface routines and has opened the display file. It will be closed by
{ the caller when this routine exits.
{
{ RFP$DISPLAY_RHFAM_ELEMENTS (ELEMENT_NAMES, DISPLAY_TYPE, DISPLAY_OPTION
{   DISPLAY_CONTROL, STATUS)
{
{ ELEMENT_NAMES: (input) This parameter specifies a list of local or remote
{   nads or trunks or the keyword ALL, signifying all the elements of the
{   specified DISPLAY_TYPE to be  used as selection criteria for the display.
{   determining hosts whose servers are to be displayed.
{
{ DISPLAY_TYPE: (input) This parameter specifies the type of element to be
{   displayed:
{
{       rfc$edt_local_nads: The local nads specified will be displayed.
{
{       rfc$edt_remote_nads: The remote nads specified will be displayed.
{
{       rfc$edt_trunks: The trunks specified will be displayed.
{
{ DISPLAY_OPTION: (input) This parameter specifies the format of the display.
{
{       rfc$do_brief: Only the status of the specified elements is displayed.
{
{       rfc$do_full: Channel or address, type, controlware reloading info, last
{                 connect time, and dump disposition as well as status of the
{                 specified elements is displayed.
{
{ DISPLAY_CONTROL: (input_output) This parameter specifies all information
{   required by the command language display interface routines about the
{   display file. This data is set up by the caller of this routine when
{   the display file is opened and will be updated by this routine as display
{   information is generated.
{
{ STATUS: (output) This parameter returns the results of the request. A
{   status of normal indicates all servers specified have been displayed:
{
{   CONDITIONS: rfe$element_not_found
{
{   IDENTIFIER: 'RF'
{
*DECK DECK=RFH$DISPLAY_RHFAM_SERVERS EXPAND=FALSE
{
{      This subcommand provides the network application manager with a
{ display of all servers that have been defined for the local RHFAM.
{
{ DISPLAY_RHFAM_SERVERS, DISRS(
{      server, s: LIST OF NAME 1..7 OR KEY ALL = ALL
{      ouptut, o: FILE = $OUTPUT
{      status)
{
{ server:  This parameter specifies a list of server applications
{   which, if defined, will be displayed.
{
{ output:  This parameter specifies the name of the file that is to
{   receive the output from this request.
{
{ status:  This parameter returns the results of the request.
{
*DECK DECK=RFH$DISPLAY_RHFAM_SERVERS_R3 EXPAND=FALSE
{
{       The purpose of this routine is to display the server applications
{ which have been defined for the Remote Host Facility Access Method. The
{ information required to produce the display of the local servers is taken
{ from RFV$RHFAM_SERVER_TABLE.
{ The caller of this routine uses the standard command language display
{ interface routines and has opened the display file. It will be closed by
{ the caller when this routine exits.
{
{ RFP$DISPLAY_RHFAM_SERVERS (SERVER_LIST, DISPLAY_CONTROL, STATUS)
{
{ SERVER_LIST: (input) This parameter specifies a list of server names or
{   the keyword ALL, which is used as selection criteria for the display.
{
{ DISPLAY_CONTROL: (input_output) This parameter specifies all information
{   required by the command language display interface routines about the
{   display file. This data is set up by the caller of this routine when
{   the display file is opened and will be updated by this routine as display
{   information is generated.
{
{ STATUS: (output) This parameter returns the results of the request. A
{   status of normal indicates all servers specified have been displayed:
{
{   CONDITIONS: rfe$server_not_found
{
{   IDENTIFIER: 'RF'
{
*DECK DECK=RFH$DISPLAY_ROUTING_INFO_R3 EXPAND=FALSE
{
{       The purpose of this routine is to display the physical and logical
{ identifiers or the LCN paths and their status, which are defined for the
{ Remote Host Facility Access Method. The information required to generate
{ the display is taken from a configuration file produced by the RHFAM
{ configuration utility or from the active configuration contained in
{ RFV$RHFAM_STATUS_TABLE.
{ The caller of this routine uses the standard command language display
{ interface routines and has opened the display file. It will be closed by
{ the caller when this routine exits.
{
{ RFP$DISPLAY_ROUTING_INFO_R3 (PHYSICAL_ID_LIST, LOGICAL_ID_LIST,
{   LOCAL_PID_SPECIFIED, ALL_PIDS_SPECIFIED, ALL_LIDS_SPECIFIED, DISPLAY_TYPE,
{   INPUT_FILE_P, DISPLAY_CONTROL, STATUS)
{
{ PHYSICAL_ID_LIST: (input) This parameter specifies a list of local or
{   remote host identifiers to be used to determine the physical hosts
{   whose lids or paths are to be displayed.
{
{ LOGICAL_ID_LIST: (input) This parameter specifies a list of logical ids
{   to be used to determine the lids to be displayed for the specified
{   hosts. This parameter is ignored if paths are being displayed.
{
{ LOCAL_PID_SPECIFIED: (input) This parameter is a boolean value which, if
{   TRUE, specifies that only the local host is to have routing information
{   displayed.
{
{ ALL_PIDS_SPECIFIED: (input) This parameter is a boolean value which, if
{   TRUE, specifies that all hosts defined in the configuration are to have
{   routing information displayed. This parameter, if TRUE, overrides the
{   LOCAL_PID_SPECIFIED parameter.
{
{ ALL_LIDS_SPECIFIED: (input) This parameter is a boolean value which, if
{   TRUE, specifies that all LIDs for the specified hosts are to be displayed.
{   This parameter is ignored if paths are being displayed.
{
{ DISPLAY_TYPE: (input) This parameter specifies the type of display to be
{   generated:
{
{       rfc$rdt_lids: The specified logical identifiers and their status will
{                 be displayed.
{
{       rfc$rdt_paths: The network paths for the specified hosts and their
{                  status will be displayed.
{
{ INPUT_FILE_P: (input) This parameter specifies a sequence pointer to the
{   first element in a segment access RHFAM configuration file which has
{   been opened and positioned by the calling routine. The file will be
{   closed and returned by the caller when this routine exits. If this
{   pointer is NIL, The active configuration in RFV$RHFAM_STATUS_TABLE is
{   displayed.
{
{ DISPLAY_CONTROL: (input_output) This parameter specifies all information
{   required by the command language display interface routines about the
{   display file. This data is set up by the caller of this routine when
{   the display file is opened and will be updated by this routine as display
{   information is generated.
{
{ STATUS: (output) This parameter returns the results of the request. A
{   status of normal indicates all lids or paths specified have been displayed:
{
{   CONDITIONS: rfe$required_def_missing
{               rfe$configuration_too_big
{               rfe$invalid_config_file
{               rfe$physical_id_not_found
{               rfe$logical_id_not_found
{
{   IDENTIFIER: 'RF'
{
*DECK DECK=RFH$DISPLAY_TRUNK_STATUS EXPAND=FALSE
{
{      This subcommand provides the operator with a display of the
{ status for the specified LCN trunks.
{
{ DISPLAY_TRUNK_STATUS, DISTS(
{      trunk, t: LIST OF NAME  OR  KEY ALL = ALL
{      display_option, do: KEY BRIEF B FULL F = BRIEF
{      ouptut, o: FILE = $OUTPUT
{      status)
{
{ trunk_name:  This parameter specifies the names of the trunks whose
{   stas to be displayed.
{
{ display_option:  This parameter selects the amount of information
{   to be displayed.  If BRIEF, the trunk name and availability status
{   are displayed for each matching trunk.  If FULL, the trunk status
{   and the availability of each TCU on the trunk are provided.
{
{ output:  This parameter specifies the name of the file that is to
{   receive the output from this request.
{
{ status:  This parameter returns the results of the request.
{
*DECK DECK=RFH$FETCH EXPAND=FALSE
{
{     The purpose of this request is to return the connection file
{     attributes of the specified file.
{
{     CONNECTION_IDENTIFIER: (input) This parameter specifies the
{       connection identifier of the file to retrieve the attributes
{       from.
{
{     FILE_ATTRIBUTES: (input,output) This parameter specifies which file
{       attribute to get.
{
{     STATUS: (output) This parameter returns the status of the request.
{       A value of normal indicates that the specified attributes were
{       returned.
*DECK DECK=RFH$FIND_AVAILABLE_SERVICE EXPAND=FALSE
{
{      The purpose of this request is to determine if the desired
{ service is provided on any of the configured LCN hosts.
{
{   RFP$FIND_AVAILABLE_SERVICE(SERVER_NAME, DESTINATION_HOST,
{   HOST_IDENTIFIERS, NUMBER_OF_HOSTS, STATUS);
{
{ SERVER_NAME: (input) This parameter specifies the name of the server
{   application which provides the desired service.
{
{ DESTINATION_HOST: (input) This parameter specifies the name of
{   destination host where the server must reside.  The user may specify
{   a logical identifier or a physical identifier.
{
{ HOST_IDENTIFIERS: (output) This parameter is an array which contains
{   the identifier of each host that provides the desired service.
{   This is a fixed array of length rfc$max_available_hosts.  If the
{   user specified a logical identifier, the identifiers of all hosts
{   that provide the desired service (up to rfc$max_available_hosts) are
{   returned in this array.  This parameter is not meaningful if the
{   user specified a physical identifier and the status is normal.
{
{ NUMBER_OF_HOSTS: (output) This parameter specifies the number of hosts
{   which provide the desired service.  If the value is less than or equal
{   to rfc$max_hosts_available, this value represents the number of
{   elements returned in the HOST_IDENTIFIERS array.  If the value is
{   greater than rfc$max_hosts_available, the number of elements returned
{   in the HOST_IDENTIFIERS array is rfc$max_hosts_available.  This
{   parameter is not meaningful if the user specified a physical identifier
{   and the status is normal.
{
{ STATUS: (output) This parameter returns the result of the request.
{   A status of normal means an accessible LCN host is available to
{   provide the requested service.
{      CONDITIONS: rfe$destination_host_disabled
{                  rfe$destination_host_undefined
{                  rfe$path_to_remote_undefined
{                  rfe$paths_to_destination_down
{                  rfe$remote_server_undefined
{                  rfe$system_task_not_active
{      IDENTIFIER: 'RF'
{
*DECK DECK=RFH$FORMAT_NAD_DUMP EXPAND=FALSE
{
{      The purpose of this request is to format a previously taken
{ NAD memory dump for analysis purposes.
{
{ FORMAT_NAD_DUMP, FORND(
{      dump_file, df: FILE = $REQUIRED
{      output, o: FILE = $OUTPUT
{      status)
{
{ dump_file:  This parameter specifies the name of the file containing
{   the NAD memory dump to be formatted.
{
{ output:  This parameter specifies the name of the file to receive
{   the output from the dump formatting.  The formatted memory dump is
{   likely to be quite long.  The user should assign an appropriate
{   file to receive the output.
{
{ status:  This parameter returns the results of the request.
{
*DECK DECK=RFH$GET_ATTRIBUTES EXPAND=FALSE
{
{     The purpose of this request is to retrieve connection attribute
{ values in use for a connection file.  The connection whose attributes are
{ to be retrieved is specified via the connection file parameter.
{
{     All connection file attributes are global to the job.
{
{ RFP$GET_ATTRIBUTES(CONNECTION_FILE, FILE_ATTRIBUTES, STATUS)
{
{ CONNECTION_FILE: (input) This parameter specifies the name of the
{   connection file to retrieve the attributes from.
{
{ FILE_ATTRIBUTES: (input,output) This parameter specifies the attributes
{   whose values are to be retrieved and returns the current values of
{   the specified attributes.
{
{ STATUS: (output) This parameter returns the status of the request.
{   A value of normal indicates that the specified attributes were
{   retrieved.
{      CONDITIONS: rfe$invalid_attribute_key
{                  rfe$connection_not_active
{      IDENTIFIER: 'RF'
*DECK DECK=RFH$GET_LOCAL_HOST_PHYSICAL_ID EXPAND=FALSE
{
{      The purpose of this request is to return the physical identifier
{ of the local host.
{
{   RFP$GET_LOCAL_HOST_PHYSICAL_ID (PHYSICAL_IDENTIFIER, STATUS);
{
{ PHYSICAL_IDENTIFIER: (output) This parameter returns the physical
{   identifier of the local host.
{
{ STATUS: (output) This parameter returns the result of the request.
{   A status of normal means the physical identifier of the local
{   host has been reutrned.
{      CONDITIONS: rfe$caller_not_privileged
{                  rfe$system_task_not_active
{      IDENTIFIER: 'RF'
{
*DECK DECK=RFH$INCOMING_CONNECT_REQUESTS EXPAND=FALSE

{      The event processor special cases all paths that have an
{ incoming connect request (state and clarifier 1,4).  The event
{ processor queues a request to input the incoming connect request.
{ Assuming the connect request is successfully received, the event
{ processor validates the incoming request.  If the request is valid,
{ the event processor starts up the appropriate server application
{ (if the application is defined as such) and assigns the incoming
{ connect request to the server job.  If the server application is already
{ running, then the event processor queues the incoming connect request
{ for that server to process.  If the request is invalid, the
{ event processor queues up a request to reject the incoming request
{ and issues an appropriate diagnostic.
{
{    The purpose of this routine is to queue a request to retrieve an
{ incoming connect request.
{
{    nad_index: (input) This parameter specifies the local NAD that
{      received the incoming connect request.
{
{    con_index: (input) This parameter specifies the connection number,
{      within the local NAD, that has been assigned to the incoming
{      connect request.
*DECK DECK=RFH$INITIALIZE_CONFIG_POINTERS EXPAND=FALSE

{    The purpose of this procedure is to generate a save area
{    for the configuration utility and to initialize the elements
{    in the save area.  If the request is an intall request then
{    the install-in-progress lock is also set.
{
{    install_request: (input) This parameter specifies whether or
{      not the save area is being created for an install request.
{
{    save_info: (output) This parameter returns an initialized
{      copy of the save area.
{
{    status: (output) This parameter returns the results of the request.
*DECK DECK=RFH$INITIATE_LOCAL_NAD_TEST EXPAND=FALSE
{
{       The purpose of this routine is to initiate a local NAD test.
{ This process is valid only when the RHFAM system task is active.
{ If the NAD has a current state of OFF and the diag_requested
{ flag is not set the testing is allowed.  Then the reloads_performed flag,
{ the reload_failed flag are cleared; the test_requested flag is set and
{ the NAD state is set to DOWN which forces the system task to reload the
{ NAD.
{
{ RFP$INITIATE_LOCAL_NAD_TEST (NAD_NAME, STATUS)
{
{ NAD_NAME: (input) This parameter specifies the nad that is to have
{   a test initiated.
{
{ STATUS: (output) This status returns the result of the request.
{
{     CONDITIONS: rfe$improper_nad_state_for_test
{                 rfe$test_already_in_process
{                 rfe$element_not_found
{                 rfe$system_task_not_active
{
{     IDENTIFIER: 'RF'
{

*DECK DECK=RFH$INSTALL_RHFAM_CONFIGURATION EXPAND=FALSE

{
{    The purpose of this sub_command is to install a new RHFAM
{ configuration file.  This request will create a new cycle of the file
{ $SYSTEM.RHFAM.CONFIGURATION_CMD_FILE.  The file contains the SCL of the
{ configuration commands to be used by RHFAM/VE to create the configuration
{ tables.  This request is a subcommand of the MANAGE_RHFAM_NETWORK utility
{ and can be called by any user that has network operator capabilities or
{ by the system job.
{
{ NOTE - the user must not only be validated to execute
{ the MANRN, but must also be validated to create files under the
{ $SYSTEM.RHFAM catalog.
{
{    The install process is performed as follows:
{
{    1)   The verify process is used to validate that the configuration
{         directives, which are in the input file specified by the user, are
{         valid.
{
{    2)   If any errors were detected, the install procedure is terminated
{         at this point with an abnormal status.
{
{    3)   The next cycle of $SYSTEM.RHFAM.CONFIGURATION_CMD_FILE is created and
{         opened for record access.  (sub-catalog RHFAM is created if
{         necessary).
{
{    4)   The information is written onto the configuration command file.
{
{
{ INSTALL_RHFAM_CONFIGURATION, INSRC(
{      input, i: file = $required
{      error, e: file = $errors
{      status: status = $optional)
{
{ input:  This parameter specifies the name of the file containing
{      the RHFAM configuration directives that will be installed.
{
{ error:  This parameter specifies the name of the file to which
{      descriptions of all errors, detected by this subcommand, are
{      written.
{
{ status:  This parameter returns the results of the subcommand.
{
*DECK DECK=RFH$INSTALL_RHF_CONFIG_BIN EXPAND=FALSE
{
{    The purpose of this sub_command is to install a new RHFAM
{ configuration file.  This request will create a new cycle of the file
{ $SYSTEM.RHFAM.CONFIGURATION_FILE.  The file contains the configuration
{ tables used by RHFAM/VE to access remote hosts via the Loosely Coupled Network
{ (LCN).  This request is a subcommand of the MANAGE_RHFAM_NETWORK utility
{ and can be called by any user that has network operator capabilities or
{ by the system job.
{
{ NOTE - the user must not only be validated to execute
{ the MANRN, but must also be validated to create files under the
{ $SYSTEM.RHFAM catalog.
{
{    The install process is performed as follows:
{
{    1)   The verify process is used to validate that the configuration
{         directives, which are from the file created by the
{         INSTALL_RHFAM_CONFIGURATION, are valid.
{
{    2)   If any errors were detected, the install procedure is terminated
{         at this point with an abnormal status.
{
{    3)   The next cycle of $SYSTEM.RHFAM.CONFIGURATION_FILE is created and
{         opened for segment access.  (sub-catalog RHFAM is created if
{         necessary).
{
{    4)   The information is transformed from the configuration directives
{         and placed into the configuration file.
{
{
{ INSTALL_RHFAM_CONFIGURATION_BIN, INSRCB(
{      error, e: file = $errors
{      status: status = $optional)
{
{ error:  This parameter specifies the name of the file to which
{      descriptions of all errors, detected by this subcommand, are
{      written.
{
{ status:  This parameter returns the results of the subcommand.
{

*DECK DECK=RFH$IO_COMPLETE_PROCESSOR EXPAND=FALSE

{      The NOS/VE monitor is the processor of all PP response buffers.
{ For LCN, the response processing is primarily done in the RHFAM routines
{ that are shared between the various tasks.  This is done to minimize
{ the amount of uninterruptable code.  This means that monitor must remove
{ the data from the response buffer and pass the information to the
{ corresponding task for processing.  To do this the following procedure
{ is followed for normal and abnormal responses:
{
{ 1) Determine the requestor's associated task.
{
{ 2) Move the response information into the designated wired area.
{
{ 3) Update the response buffer pointers.
{
{ 4) Unlock any pages that were locked by a lock RMA list request.
{
{ 5) IF  the task is waiting in ring 2 or 3 (synchronous request)  THEN
{      Ready the task.
{    ELSE
{      Send a system flag to the corresponding task.
{    IFEND
{
{    In the case of an unsolicited response, the corresponding logical
{    PP number and error code are placed in a global variable
{    (rfv$pp_interface_error).  The system task is then READYed.
{
{    In the case of an intermediate response, no data is copied to the
{    wired data section.  The corresponding task is restarted and must
{    determine what actions, if any, are to be performed.
{
{    pp_response: (input) This parameter specifies the pointer to the
{      PP response area.
{
{    detailed_status: (input) This parameter specifies a pointer to
{      an adaptable sequence containing the detailed status (if any).
{
{    logical_pp: (input) This parameter specifies the logical PP
{      number of the PP which posted the response.
{
{    status: (output) This parameter returns the results of the
{      response posting.

*DECK DECK=RFH$LOCAL_NAD_DUMP EXPAND=FALSE

{    The purpose of this procedure is to obtain a snap shot of the current
{ NAD memory image for the specified local NAD.  This procedure performs
{ the necessary functions to initiate the local NAD dump processing.
{
{    The following procedure is followed by the event processor
{ when dumping a local NAD.
{
{      1)  Create any files necessary.
{
{      2)  Reserve the network wired buffers.
{
{      3)  Generate the request to the PP.
{
{      4)  Process the PP response.
{
{      5)  Move the data to the user specified area.
{
{      6)  Repeat steps 2 to 5 until all the NAD memory is dumped.
{
{      7)  Release the network wired buffers.
{
{    nad_index: (input) This parameter specifies the index
{      of the corresponding local NAD to dump.
{
{    status: (output) This parameter returns the results of the
{      request.

*DECK DECK=RFH$LOCAL_NAD_LOAD EXPAND=FALSE

{    The purpose of this procedure is to initiate loading of microcode
{ in a local NAD, using the following procedures:
{
{      1)  Generate the microcode initialization parameters.
{
{      2)  Reserve network buffers.
{
{      3)  Test the NAD, generating and posting PP requests that check
{          proper operation of the NAD's channel, device interface,
{          and memory.
{
{      4)  Move the microcode file image to the network buffers.
{
{      5)  Append the initialization parameters to the microcode.
{
{      6)  Generate the PP request to load the NAD microcode, and post
{          the request in the corresponding unit request queue.
{
{      7)  Process the response.
{
{      8)  Release the buffers when the load is complete.
{
{      The initial NAD microcode status after the NAD 'GO' command is
{ likely to be zero (NAD initializing).  The response handler then issues
{ additional requests to re-obtain the microcode status.  The response
{ handler must continue to obtain the microcode status until one
{ of the following conditions occurs:
{
{      1)  The status is 'ACK'.  This means the load was successful
{          and the NAD status should be updated to operational to
{          allow normal activity to resume.
{
{      2)  The status is non-zero (other than 'ACK').  This means the
{          load failed and that further maintenance action is required.
{
{      3)  The load timer has expired.  This is treated the same as
{          a load failure.
{
{      The initial NAD microcode load does not attempt to optimize
{ the use of NAD memory, because the sizes of various NAD tables
{ are unknown until after the microcode is loaded.  To optimize the
{ NAD memory usage, the NAD general status is obtained to determine
{ the amount of unused NAD memory and the NAD microcode
{ initialization parameters are modified to utilize the unused
{ NAD memory.  The load procedures (4-8) are then repeated
{ to reload the microcode.
{
{    nad_index: (input) This parameter specifies the index of the
{      corresponding local NAD to load.
{
{    status: (output) This parameter specifies the results of the
{      request.

*DECK DECK=RFH$LOCAL_NAD_STATUSING EXPAND=FALSE

{    The purpose of this routine is to monitor the status of the
{ connection end points in each of the local NADs.
{
{    The event processor uses the local NAD table definitions
{ to determine the local NADs that are defined for RHFAM/VE usage.
{ In the local NAD definition is a flag (status_request_posted)
{ which is used by the event processor to determine if a status request
{ needs to be posted.  Also in the local NAD definition is a field
{ (last_status_change) which notifies the event processor when the
{ last NAD status change occurred.  The following algorithm is used
{ by the event processor for scheduling status:
{
{      FOR   each local nad   DO
{        IF  status request posted  THEN
{          IF  no status change within threshold
{              OR  possible connect pending  THEN
{            change request to force status input.
{          IFEND
{        ELSE
{          IF  no status change within threshold
{              OR  possible connect pending  THEN
{            post unconditionally obtain status request.
{          ELSE
{            post obtain status request.
{          IFEND
{        IFEND
{        IF  a status change is available  THEN
{          FOR  each connection entry  DO
{            IF  incoming connect available  THEN
{              IF connection entry not in use  THEN
{                queue request to get the incoming connect.
{              ELSE
{                set possible connect pending flag.
{              IFEND
{            IFEND
{          FOREND
{          check event list.
{        ELSE
{          IF  no change within threshold  THEN
{            must check event list for timeouts.
{          IFEND
{        IFEND
{        check control message queues.
{      FOREND
{
{    current_time: (input) This parameter specifies the
{      current microsecond time which is used to determine if
{      a status threshold has occurred.
{
{    possible_connect_pending: (input,output) This parameter is
{      used to denote whether or not an incoming connect is available,
{      but the previous connection entry owner has not yet released
{      the connection entry.  This parameter is valid on both input
{      and output.
{
{    status: (output) This parameter returns the results of the request.

*DECK DECK=RFH$LOG_PERFORMANCE_STATISTICS EXPAND=FALSE

{    The purpose of this routine is to periodically emit the local NAD
{    statistics data to the engineering log.  This information is to
{    be used by HPA/VE for SQC analysis.
{
{    The following algorithm is used:
{
{         FOR  each local NAD  DO
{           initialize the log entry.
{           set status table lock.
{           put statistics values in the log counters.
{           clear the statistics variables.
{           clear the status table lock.
{           emit the log entry to the engineering log.
{         FOREND
*DECK DECK=RFH$MANAGE_RHFAM_NETWORK EXPAND=FALSE
{
{      The purpose of this request is to initiate execution of the
{ MANAGE_RHFAM_NETWORK(MANRN) utility. MANRN is a command utility used
{ by site operation and/or administrative personnel to manage execution
{ of the local RHF Access Method. These commands provide the following
{ capabilities:
{
{ 1)  Application Management.
{
{ 2)  Network Displays.
{
{ 3)  LCN Identifier State Change Commands
{
{ 4)  Maintenance commands.
{
{       MANRN may be executed by the console operator or by a caller with
{ NETWORK_OPERATOR or NETWORK_APPLICATION_MANAGER capability. The commands
{ pertaining to Application Management require NETWORK_APPLICATION_MANAGER
{ capability.
{
{ manage_rhfam_network, manrn(
{   status)
{
{ status:  This parameter returns the results of the command.
{
*DECK DECK=RFH$NAD_DUMPING EXPAND=FALSE

{      The NAD memory dump is performed when a local NAD has been
{ declared unoperational (down) and the corresponding NAD table entry
{ has 'perform_auto_reload' = TRUE and 'test_requested' = FALSE.
{ The event processor disposes of the NAD memory dump according to
{ the 'dump_disposition' field:
{
{      IF  "discard"   THEN
{         release network wired buffers after the dump is completed.
{      ELSEIF  "save_last"   THEN
{         attach existing file $system.rhfam.[nad_name] (create a new
{           file if none exists).
{         copy network wired buffers (NAD memory image) to the file.
{      ELSE    [save_all]
{         create next cycle of file $system.rhfam.[nad_name] (create
{           cycle 1 if none exists).
{         copy network wired buffers (NAD memory image) to the file.
*DECK DECK=RFH$NAD_LOADING EXPAND=FALSE

{      Each local NAD entry defined in the RHFAM/VE configuration
{ table has a 'perform_auto_reload' field which determines the
{ initialization and maintenance procedures to be performed on the
{ corresponding NAD.  If TRUE, the microcode is loaded in the
{ corresponding NAD each time the RHFAM system task is activated
{ and each time the NAD state is set to DOWN (assuming the
{ 'reload_threshold' has not been exceeded).  If FALSE, the
{ microcode is loaded only when the system task is activated, or
{ when 'test_requested' is TRUE.
*DECK DECK=RFH$OFFER_CONNECTION_SWITCH EXPAND=FALSE
{
{      The purpose of this request is to offer a switch of ownership of a
{ connection end point to another job on the local system. Switching
{ ownership of a connection end point is a local system operation. The
{ peer application at the remote connection end point does not receive
{ an indication of this action.
{
{      Switching ownership of a connection end point is a cooperative
{ process which requires the active participation of both the source
{ job (current owner) and the destination job (proposed owner).
{ The source job uses this request to make an offer to switch a
{ connection end point to a destination job. The destination job must
{ accept this switch offer to complete the connection end point switch.
{
{      The source job determines the duration of the offer to switch a
{ connection end point.  If the destination job does not accept the switch
{ offer within a reasonable amount of time, the source job may cancel the
{ switch offer.
{
{      While the switch offer is in effect, the only valid requests for
{ the specified connection file are rfp$terminate_connection and
{ rfp$cancel_switch offer. Once the destination job accepts the
{ switch offer, the connection file may be terminated without
{ affecting the switched connection.  This is the only request which may
{ be made for the connection file after the switch offer has been accepted.
{
{      An offer to switch a connection end point may not be made if there
{ are any active instances of open for the connection file.
{
{      Connection end point switching causes the source application's
{ connection count to be decremented by one and the destination application's
{ connection count to be incremented by one.
{
{         note - passing a connection from a server application to a
{                partner application does not decrease the number of
{                server connections in the server definition table.
{                (i.e. the current number of server connections = the
{                number of server connections + the number of server
{                partner job connections).  This prevents the maximum
{                connection count, which is specified when the server is
{                defined, from being exceeded.
{
{      The file attributes that are on the connection file are passed
{ to the DESTINATION_JOB along with the connection.  The access method
{ uses those attributes as the initial file attributes for the
{ connection_file specified by the DESTINATION_JOB on the
{ RFP$ACCEPT_SWITCH_OFFER request.
{
{ RFP$OFFER_CONNECTION_SWITCH(CONNECTION_FILE, DESTINATION_JOB,
{   WAIT_TIME, STATUS)
{
{ CONNECTION_FILE: (input) This parameter specifies name of the connection
{   file, whose corresponding connection is to be switched to the
{   DESTINATION_JOB.  The connection state of the connection file goes
{   to 'rfc$switch_accepted' when the switch offer is accepted.
{
{ DESTINATION_JOB: (input) This parameter specifies the system supplied
{   job name of the job, to whom the connection is to be offered.
{
{ WAIT_TIME: (input) This parameter specifies the number of milliseconds
{   that the request is to wait for the destination job to accept the
{   switch offer. A value of 0 indicates that the calling task is to
{   continue execution while the switch offer is in effect. If the
{   WAIT_TIME expires before the switch offer is accepted, the request
{   is terminated with a status of 'rfe$switch_offer_not_accepted'.
{
{   Failure of the destination job to accept the switch offer within
{   this waiting period has no effect on the switch offer.  The source
{   job must explicitly cancel the switch offer if the destination job
{   has not accepted the offer within a reasonable amount of time.
{
{   The osp$await_activity_complete request may also be used to wait for
{   the switch offer to be accepted.
{
{ STATUS: (output) This parameter returns the results of the request.
{   A status of normal means that the specified connection has been offered
{   to the specified job.
{   CONDITIONS:  rfe$connect_in_progress
{                rfe$connected
{                rfe$connection_not_active
{                rfe$connection_rejected
{                rfe$connection_terminated
{                rfe$file_not_closed
{                rfe$local_nad_failure
{                rfe$switch_accepted
{                rfe$switch_offer_not_accepted
{                rfe$switch_offered
{                rfe$system_interrupt
{                rfe$system_task_shutdown
{   IDENTIFIER:  'RF'
{
*DECK DECK=RFH$PATH_STATE_CHANGES EXPAND=FALSE
{      The event processor monitors the state of all active connection
{ end points.  The connection end point is assigned a unique path
{ identifier by the local NAD.  The combination of the local NAD
{ identifier and the path identifier is used by the event processor to
{ correctly identify all connection end points.  When any path, other
{ than path zero, has a state change to a value other than (1,4) the
{ event processor updates the status in the corresponding application's
{ connection table.  If there is an outstanding request waiting for
{ the current connection state change to occur, the event processor sends
{ a signal to notify the task of the state change.
{
{ The signal ID is:
{
{ CONST
{      rfc$path_status_change = 14;
{
{ The format of the signal is:
{
{ TYPE
{      rft$path_change_signal = record,
{        connection_number = rft$connection_identifier,
{        event_type = rft$connection_event,
{      recend;

*DECK DECK=RFH$POST_REQUEST EXPAND=FALSE
{    The purpose of this routine is to provide the interface to queue
{ requests to the PP drivers.  This includes requests on a NAD basis
{ (unit requests) or request on a PP driver basis (PP requests).
{
{      Routines are provided to handle the building and queueing of
{ peripheral requests.  Entry points are provided for each request type
{ that is supported by the NAD PP drivers.  Execution of these
{ routines causes the formation of a request and the queueing of the
{ request in the proper request queue.  An entry point is also
{ provided to dequeue and release a request when processing is
{ complete.  These routines execute in ring 1.
{
{      Internal procedures to these provide the following:
{
{      1) Reserve a mainframe wired request/response buffer for the
{         request.
{
{      2) Build request header.
{
{      3) Generate the remainder of the request fields.
{
{      4) Interlock unit (or PP) request queue.
{
{      5) Link requests into the unit (or PP) request queue.
{
{      6) Release lock on unit (or PP) request queue.
{
{    NOTE
{
{      If pages need to be locked, monitor is called to lock the
{      necessary pages.  To prevent the PP from processing the request,
{      the processing flag is set in the request.  If the monitor mode code
{      successfully locks the pages then the processing flag is cleared in
{      the request and the PP will then process the request when possible.
{      If the page locking fails then this code must remove the request
{      from the queue and return the status to the caller.
*DECK DECK=RFH$PRESERVE_CONFIG_POINTERS EXPAND=FALSE

{    The purpose of this procedure is to save a copy of the
{    configuration utility save area for subsequent request
{    processing.  If the initialize procedure has not been
{    previously executed then the save area is not preserved.
{
{    save_area: (input) This parameter contains a copy of the
{      save area which is to be preserved.
*DECK DECK=RFH$PROCESS_PP_RESPONSE_FLAG EXPAND=FALSE

{    The purpose of this procedure is to process the system flag alerting
{ this task that a PP request has been completed.  This routine is also
{ called directly by tasks that are waiting in ring 3 for a request to
{ complete.
{
{      When a PP respone has been received and Monitor has set the
{ system flag notifying the task of an RHFAM/VE PP response available, the
{ system flag handler is invoked to process the response.
{
{      Once the request type and response type are determined the
{ corresponding request response processor is called.  A separate
{ response routine is used for each logical request (i.e. send data
{ response handler, receive data response handler, etc.).  These
{ individual response handlers are in charge of processing the response
{ as it relates to the corresponding request.
{
{      Each of the request complete processors must check the response
{ to the request to determine what action is to be taken.  Normally the
{ following actions are performed (maintenance functions are possible
{ exceptions):
{
{      1)  If the request is not retriable because of a fatal hardware
{          error, the request is delinked, a fatal status is set in
{          the requestor's status variable, the corresponding
{          connection's status (if appropriate) is set to aborted, and
{          a hardware element error is flagged in the appropriate
{          configuration table entry.
{
{      2)  If the request has failed because the recovered error retry
{          limit is exceeded, the request is delinked, a fatal status
{          is set in the requestor's status variable, and the
{          corresponding connection's status (if appropriate) is
{          set to aborted.
{
{      3)  If the request failed because resources are unavailable, the
{          request is either reset to allow the PP's to attempt to
{          process the request again or the request is delinked and
{          the requestor is notified that the request should not be
{          posted again until resources are available.  The method used
{          is request dependent.
{
{      4)  If the request failed because a connection has changed states,
{          a request is posted to obtain the path status information
{          for the corresponding connection.  This information is then
{          used to determine the response given to the requestor.
{
{      5)  If the request failed and it is retryable, the request is
{          reset for the PP to retry.
{
{      6)  If the request was satisfactorily completed, the response
{          handler proceeds with one of the following events:
{
{          a)  set the requestor's status to "normal completion".
{
{          b)  post the next request when a sequence of requests is
{              required.
{
{          c)  re-issue the request when the request is a send or
{              receive data and further data transactions are required
{              to complete the request.

*DECK DECK=RFH$QUEUE_DATA_FRAGMENTS EXPAND=FALSE

{
{    The purpose of this routine is to add I/O data fragments to
{    an RHFAM I/O request.  The request is generated and linked into
{    the unit I/O queue by the ring 1 processing code.  The RMAs are
{    added into the buffer in a circular buffer fashion.  The CPU
{    processing updates the IN pointer when fragments are queued for
{    processing and the PP processing updates the OUT pointer when the
{    fragment I/O is complete.
{
{    reqcode: (input) This parameter specifies the corresponding
{      request code (syc$rc_queue_rhfam_request).
{
{    status: (output) This parameter returns the results of the
{      request.
{
{    request_buffer: (input) This parameter specifies the wired
{      rhfam request buffer.  This is the destination area for
{      the data fragment RMAs.
{
{    number_of_blocks: (input) This parameter specifies the number
{      of blocks to queue.
{
{    io_type: (input) This parameter specifies the type of I/O
{      performed (read or write).
{
{    clear_complete_flag: (input) This parameter specifies whether or
{      not the PP request processing should be re-initiated after
{      the RMA entries are generated.

*DECK DECK=RFH$QUEUE_REQUEST EXPAND=FALSE

{    The purpose of this routine is to queue a request for the NAD PP Driver to process.  The
{    request can be sent to the PP request queue (PP state change requests) or to the
{    unit request queue (NAD I/O requests).   This routine sets up the request information in
{    the task private heap for subsequent response processing upon request completion.
{
{    nad_index: (input) This parameter specifies the index of the local NAD entry of the corresponding
{      local NAD.
{
{    pp_index: (input) This parameter specifies the index of the PP driver, associated with the local NAD.
{
{    request_type: (input) This parameter specifies the request type (unit or PP).
{
{    nad_request: (input) This parameter specifies the kind of unit request being sent (load, status, etc.).
{
{    request_status: (input) This parameter points to a request dependent status area which is used to
{      maintain the status of multi-step requests.
{
{    request_info: (input) This parameter specifies a pointer to the ring 1 request.
{
{    status: (output) This parameter returns the results of the request.
*DECK DECK=RFH$RECEIVE_DATA EXPAND=FALSE
{
{      The purpose of this request is to receive a message (or a part of
{ a message) that has been sent across an established connection.  The
{ access method inputs data from that connection until a complete message
{ is received, the buffers are exhausted, or an abnormal termination event
{ occurs.
{
{      The access method is only capable of processing one receive data
{ request, per connection, at any instant.  If an additional receive data
{ request is made while there is a pending receive data request, the
{ following actions are performed.
{
{    1)   If the new request is synchronous (wait=osc$wait), the new
{         request is queued to be processed after the pending request is
{         completed.
{
{    2)   If the new request is asynchronous (wait=osc$no_wait), the new
{         request is rejected and a status of 'rfe$receive_data_active'
{         is returned.
{
{      The access method verifies that the connection identifier represents
{ a valid open connection.  The access method uses the BLOCK_SIZE
{ (record or message), DATA_TRANSFER_TIMEOUT, RECEIVE_RECORD_TERMINATOR,
{ INCOMING_RECORD_ABN file attributes to control the receiving of data.
{ The FILE_MARK_RECEIVED attribute is used to convey additional
{ information to the application for record mode transmissions.  Further
{ information on the file attributes is provided in the BAM request
{ section.
{
{      Further information on the actions performed by this request is
{ provided in the send and receive data header section.
{
{ WARNING
{
{      The application must make sure that the attributes specified for
{      the receive data request correspond to the attributes being used
{      by the peer application on the corresponding send data request.
{
{ RFP$RECEIVE_DATA(CONNECTION_IDENTIFIER, TRANSMISSION_MODE, DATA_BUFFER,
{   WAIT, ACTIVITY, DATA_RECEIVED, END_OF_MESSAGE, STATUS)
{
{ CONNECTION_IDENTIFIER: (input) This parameter specifies the identifier
{   of an open connection file to receive data from.
{
{ TRANSMISSION_MODE: (input) This parameter specifies the data
{   transmission mode for receiving the data.  The incoming data
{   mode must match the mode specified by this parameter (i.e. if the
{   data was sent in message mode, this parameter must select message
{   mode).  Further information on this parameter is provided in the
{   send and receive data header section.
{
{ DATA_BUFFER: (input) This parameter specifies an adaptable array of
{   data buffers and data lengths (in 8-bit bytes).  The data will
{   be placed in consecutive locations in the data buffers starting
{   with the first buffer in the array.
{
{ WAIT: (input) This parameter specifies whether to suspend the
{   application until the request is completed.  If osc$wait, the
{   access method will suspend the application until the transfer has
{   completed.  If osc$nowait, the access method will return control
{   to the application after the request has been validated.
{
{ ACTIVITY: (output) This parameter has two fields which
{   return the results of the receive data request.
{
{      1)  complete:  This field is set to TRUE when the request is
{          completed.  If FALSE, the status field, the DATA_RECEIVED
{          parameter, and END_OF_MESSAGE parameters are not
{          meaningful.
{
{      2)  status: This field is normal if either a complete message
{          was received or the receive buffers are exhausted.
{          CONDITIONS:  rfe$async_req_terminated
{                       rfe$block_sequence_error
{                       rfe$connection_terminated
{                       rfe$local_nad_failure
{                       rfe$network_block_exceeded
{                       rfe$transfer_timeout
{                       rfe$receive_mode_conflict
{                       rfe$system_interrupt
{                       rfe$system_task_shutdown
{          IDENTIFIER:  'RF'
{
{ DATA_RECEIVED: (output) This parameter specifies the actual amount
{   of data (in 8-bit bytes) that was delivered to the data buffers.
{
{ END_OF_MESSAGE: (output) This parameter specifies whether or not
{   a complete message was received.
{
{ STATUS: (output) This parameter returns the result of the request.
{   A status of normal means the caller is validated to receive data
{   on the specified connection.
{   CONDITIONS:  ame$improper_file_id
{                rfe$connect_in_progress
{                rfe$connected
{                rfe$connection_not_active
{                rfe$connection_rejected
{                rfe$connection_terminated
{                rfe$invalid_data_fragment
{                rfe$local_nad_failure
{                rfe$receive_data_active
{                rfe$switch_accepted
{                rfe$switch_offered
{                rfe$system_interrupt
{                rfe$system_task_shutdown
{                rfe$transfer_timeout
{                rfe$receive_data_active
{   IDENTIFIER:  'RF'
{
*DECK DECK=RFH$RECEIVE_SWITCHED_DATA EXPAND=FALSE
{
{      The purpose of this request is to receive data that has been
{ passed along with a connection by a SWITCH_CONNECTION request.  The
{ application may only issue this request after a successful
{ OBTAIN_SWITCHED_CONNECTION request.  The access method will discard
{ its copy of the data after this request is completed, which means
{ that the application must receive all the data with a single request.
{ Also, if the application attempts to send or receive any data on this
{ connection before receiving the switched data the access method will
{ discard the switched data.
{
{ RFP$RECEIVE_SWITCHED_DATA(CONNECTION_NAME, BUFFER, BUFFER_LENGTH,
{   STATUS)
{
{ CONNECTION_NAME: (input) This parameter specifies the file reference
{   of the connection from which the switched data is to be received.
{
{ BUFFER: (input) This parameter specifies the address of the buffer to
{   receive the data.
{
{ BUFFER_LENGTH: (input) This parameter specifies the length of the
{   buffer.  This value should be greater than or equal to the
{   DATA_LENGTH value that was returned by the OBTAIN_SWITCHED_CONNECTION
{   request, because the access method will discard any data that does
{   not fit in the specified buffer.
{
{ STATUS: (output) This parameter returns the results of the request.
{   A status of normal means that all data passed with the connection
{   was received.
{   CONDITIONS:  rfe$connection_not_assigned
{                rfe$no_switched_data
{                rfe$buffer_exhausted
{   IDENTIFIER:  'RF'
{
*DECK DECK=RFH$REJECT_CONNECT_REQUEST EXPAND=FALSE
{
{      The purpose of this request is to inform the access method that
{ the server application has rejected the incoming connect request.
{ This request is only valid after a successful
{ RFP$ACQUIRE_CONNECT_REQUEST.  This request effectively terminates
{ the connection.  The connection file is deleted at this point.
{
{    Note - There can be no active instances of open at this point since
{           the connection was never established.
{
{      The client application is notified of the connection reject
{ (see RFP$AWAIT_SERVER_RESPONSE).
{
{ RFP$REJECT_CONNECT_REQUEST(CONNECTION_FILE, SERVER_RESPONSE, STATUS)
{
{ CONNECTION_FILE: (input) This parameter specifies the temporary file
{   which is assigned to the connection to reject.  This file is deleted
{   prior to returning control to the requester.
{
{ SERVER_RESPONSE: (input) This parameter specifies a reject code which
{   explains why the server application rejected the connection.
{   The reject code must be an integer value 'n' (where 128 <= n <= 255).
{
{ STATUS: (output) This parameter returns the results of the request.
{   If the status is normal the connection has been rejected and the
{   connection file has been deleted.
{   CONDITIONS: rfe$invalid_connection_file
{               rfe$connection_established
{   IDENTIFIER: 'RF'
{
*DECK DECK=RFH$RELEASE_CONFIG_POINTERS EXPAND=FALSE

{    The purpose of this procedure is to release the save area
{    for the configuration utility.  If the save area was constructed
{    for an install request then the install-in-progress lock is
{    also cleared.
*DECK DECK=RFH$RELEASE_REQUEST_BUFFERS EXPAND=FALSE

{    The purpose of this routine is to release all of the request buffers
{    that have been reserved by this instance of RHFAM/VE.  This routine
{    also release the buffer table after the buffers are released.
*DECK DECK=RFH$REQUEST_CONNECTION EXPAND=FALSE
{
{      The purpose of this request is to initiate the LCN connection
{ establishment process.  This request is only used by the client
{ application.  The client application must "sign_on" to the local
{ access method prior to issuing this request.
{ If this request successfully completes, a file specified by the
{ CONNECTION_FILE parameter is created and the corresponding RHFAM
{ file attributes are assigned.  The file must then be used to
{ reference this connection on all future requests.
{
{      NOTE - The state of the connection after this request
{             successfully completes is 'connect_in_progress'.  The
{             connection file can not be opened until the remote
{             end accepts the connection.  The user can use
{             RFP$AWAIT_SERVER_RESPONSE or
{             OSP$AWAIT_ACTIVITY_COMPLETE to determine when the
{             connection has been established (or terminated).
{             The user can terminate the connection establishment
{             process with the RFP$TERMINATE_CONNECTION request.
{
{ RFP$REQUEST_CONNECTION(CLIENT_NAME, SERVER_NAME, DESTINATION_HOST,
{   CONNECTION_FILE, FILE_ATTRIBUTES, STATUS)
{
{ CLIENT_NAME: (input) This parameter specifies the name of the
{   requesting client application.  The client name must be the same as
{   a client name used in a previous APPLICATION_SIGN_ON request.
{
{ SERVER_NAME: (input) This parameter specifies the name of the
{   requested server application.
{
{ DESTINATION_HOST: (input) This parameter specifies the name
{   of the remote host where the server application resides.  If the
{   application specifies a logical identifier, the access method will
{   randomly select a physical host (assuming multiple hosts have the same
{   logical identifier defined) to receive the connect request.  If the
{   application specifies a physical identifier, the access method will
{   send the connect request to the specified host.
{
{ CONNECTION_FILE: (input) This parameter specifies a file name that
{   the access method should create and assign to the connection end
{   point.  The file reference must be in a temporary master catalog
{   and must not already exist in that catalog.
{
{ FILE_ATTRIBUTES: (input) This parameter specifies the file attributes,
{   whose values are to be changed to the corresponding values specified
{   by this parameter. A value of NIL for this parameter indicates that
{   default values are to be used for all attributes. Further
{   information on the file attributes is provided in the BAM request
{   section.
{
{ STATUS: (output) This parameter returns the result of the request.
{   A status of normal means the specified file has been created and
{   a connection end point has been assigned to that file.
{   CONDITIONS:  rfe$destination_host_undefined
{                rfe$exceeded_connect_limit
{                rfe$file_already_exists
{                rfe$invalid_attribute_key
{                rfe$max_appl_connects_exceeded
{                rfe$not_signed_on
{                rfe$not_signed_on_as_client
{                rfe$path_to_remote_undefined
{                rfe$paths_to_destination_down
{                rfe$remote_server_undefined
{                rfe$system_task_not_active
{   IDENTIFIER:  'RF'
{
*DECK DECK=RFH$RESERVE_REQUEST_BUFFERS EXPAND=FALSE

{    The purpose of this routine is to generate the ring 1 request buffer
{    tables.  This routine also ALLOCATEs a few buffers up front for
{    performance purposes.
{
{    buffer_count: (input) This parameter specifies the maximum number of
{      buffers that will ever be in use at one instant.
{
{    status: (output) This parameter returns the results of the request.
*DECK DECK=RFH$RETRIEVE_CONFIG_POINTERS EXPAND=FALSE

{    The purpose of this procedure is to retrieve the current
{    copy of the configuration utility save area.  If the
{    initialize procedure had not been executed prior to calling
{    this routine then the value of the save area is indeterminate.
{
{    save_area: (output) This parameter returns a copy of the
{      most recently preserved save area.
*DECK DECK=RFH$RETURN_LID_TYPE EXPAND=FALSE
{
{        The purpose of this procedure is to return the type of a specified
{ RHFAM physical or logical identifier (PID or LID).  The type returned is
{ local PID, local LID, remote PID, remote LID, or unknown.
{
{    RFP$RETURN_LID_TYPE (LID_NAME, LID_TYPE, STATUS);
{
{ LID_NAME: (input) This parameter specifies a physical or logical identifier.
{
{ LID_TYPE: (output) This parameter returns the LID type.
{
{ STATUS: (output) This parameter returns the status of this request.
{
*DECK DECK=RFH$RE_ISSUE_REQUEST EXPAND=FALSE

{    The purpose of this routine is to re-issue imcomplete requests from the
{ PP or the unit request queue.
{
{    request_id: (input,output) This parameter specifies the identifier of
{      the request to re-issue.
{
{    status: (output) This parameter returns the results of the request.
*DECK DECK=RFH$RHFAM_EVENT_PROCESSOR EXPAND=FALSE
{      The RHFAM/VE event processor is responsible for maintaining the
{ current LCN status as viewed from the local mainframe.  The event processor
{ is a system task defined in a system prolog by the DEFINE_SYSTEM_TASK
{ command.  The system task is initiated by an ACTIVATE_SYSTEM_TASK command
{ and remains active until either a DEACTIVATE_SYSTEM_TASK command or
{ a deadstart occurs (a recovery deadstart will not automatically restart
{ the task).
{
{      The event processor has several major tasks that it performs:
{
{ 1)   The system task initializes the RHFAM/VE environment:
{
{      a)  The currently installed RHFAM/VE configuration file is
{          activated ($SYSTEM.RHFAM.CONFIGURATION.$HIGH)
{
{      b)  All system resources that are used by RHFAM/VE are reserved
{          (the NADs and the PPs).
{
{      c)  The microcode is loaded in the PPs (driver NPDR) and the
{          microcode is loaded in the NADs
{          ($SYSTEM.RHFAM.MICROCODE.C180.$HIGH).
{
{ 2)   Maintain the current status of all connection end points that are
{      defined in each of the defined local NADs.
{
{ 3)   When an incoming connect request is received the connect request
{      is queued for the corresponding server application and a
{      server job is initiated (if necessary).
{
{ 4)   If a task is suspended waiting for an RHFAM/VE event that has occurred,
{      the event that occurred is flagged and the task is restarted.
{
{ 5)   Monitor the start-up server jobs and the processing of incoming
{      connect requests to make sure that a response is given to
{      a remote host.
{
{ 6)   Maintain the availability information of the paths that are
{      accessable from this host.
{
{ 7)   Perform automatic dump and reload functions for malfunctioning NADs
{      that are maintained by this host.
{
{ 8)   Perform RHFAM/VE termination process:
{
{      a)  Terminate all incoming connections and currently active
{          connections.
{
{      b)  Wake up all tasks waiting for events.
{
{      c)  Idle down the PP drivers.
{
{      d)  Release all resources (NADs and PPs).
{
{      e)  Deactivate the RHFAM/VE configuration.

*DECK DECK=RFH$SEND_DATA EXPAND=FALSE
{
{      The purpose of this request is to send a message (or part of a
{ message) across the logical connection.  The access method is only
{ capable of processing one send data request at a time.  If a send data
{ request is issued while another send data request is still being
{ processed, the following actions are performed:
{
{    1)   If the new request is synchronous (wait=osc$wait), the
{         new request is queued and processed after the pending send
{         data request is completed.
{
{    2)   If the new request is asynchronous (wait=osc$no_wait), the
{         request is rejected and a status of 'rfe$send_data_active'
{         is returned.
{
{      The access method attempts to send all the data, in the format
{ specified by the requester, across the connection.
{
{      The BLOCK_SIZE (message or record), TRANSFER_DELAY_TIME,
{ SEND_RECORD_TERMINATOR, and the OUTGOING_RECORD_ABN
{ file attributes provide external information for the send data request.
{ These attributes are further defined in the file attributes sub-section
{ of the BAM request section.
{
{      The send and receive data header section provides further
{ information on the actions performed by this request.
{
{ RFP$SEND_DATA(CONNECTION_IDENTIFIER, TRANSMISSION_MODE, DATA,
{   END_OF_MESSAGE, WAIT, ACTIVITY, DATA_SENT, STATUS)
{
{ CONNECTION_IDENTIFIER: (input) This parameter specifies an identifier
{   of an open connection file to send data on.
{
{ TRANSMISSION_MODE: (input) This parameter specifies the transmission
{   mode to be used for packaging the data (message mode or
{   record mode).  In general the message mode is a low volume
{   transmission mode for short non-contiguous data and the record
{   mode is a high volume transmission mode for large contiguous data.
{   Further information on the transmission modes is provided in the
{   general send and receive data section.
{
{ DATA: (input) This parameter specifies an adaptable array
{   of corresponding data buffers and data lengths (in 8-bit bytes).
{   The access method will pack the data into blocks starting with
{   the data in the first buffer on the list.
{
{ END_OF_MESSAGE: (input) This parameter specifies that the data
{   being sent comprises a complete message.
{
{ WAIT: (input)  This parameter specifies whether to suspend the
{   application until all data has been sent.  If osc$wait, the access
{   method will suspend the application until the transfer has been
{   completed.  If osc$nowait, control is returned to the application
{   after the first block has been queued to be sent across the
{   connection.
{
{ ACTIVITY: (output) This parameter contains two fields
{   which return the results of the send data request.
{
{      1)  complete:  This field is set to TRUE when the
{          request has been completed.  If FALSE, the status field
{          and the DATA_SENT parameter are not meaningful.
{
{      2)  status:  This field specifies whether all requested data
{          has been successfully sent by the access method.  If the
{          status is normal, all data has been successfully sent.
{          CONDITIONS:  rfe$async_req_terminated
{                       rfe$connection_terminated
{                       rfe$local_nad_failure
{                       rfe$transfer_timeout
{                       rfe$system_interrupt
{                       rfe$system_task_shutdown
{                       rfe$unable_to_send_all_data
{          IDENTIFIER:  'RF'
{
{ DATA_SENT: (output) This parameter returns the actual amount of
{   data (in 8-bit bytes) that was sent.  This parameter can be used
{   to aid recovery if an unexpected error was encountered while the
{   data was being transferred.  This parameter is also useful for
{   record mode transfers when all of the data could not be
{   transferred, because the END_OF_MESSAGE parameter was FALSE, and
{   the total DATA length was not a multiple of the RECORD_BLOCK_SIZE.
{
{ STATUS: (output) This parameter returns the results of the request.
{   A status of normal means the caller is validated to send data on
{   this connection.
{   CONDITIONS:  ame$improper_file_id
{                rfe$connect_in_progress
{                rfe$connection_not_active
{                rfe$connection_rejected
{                rfe$connection_terminated
{                rfe$invalid_data_fragment
{                rfe$local_nad_failure
{                rfe$receive_data_active
{                rfe$send_data_active
{                rfe$switch_accepted
{                rfe$switch_offered
{                rfe$system_interrupt
{                rfe$system_task_shutdown
{                rfe$transfer_timeout
{   IDENTIFIER:  'RF'
{
*DECK DECK=RFH$SET_SYSTEM_TASK_ID EXPAND=FALSE

{    The purpose of this routine is to set the RHFAM/VE system task id
{    in the mainframe global section.  (Monitor mode code defines it)
{
{    start_up: (input)  This parameter specifies whether the RHFAM/VE system
{      task is initiating.  If TRUE, the task id of this task is plugged.
{      If FALSE, the null task id is plugged.
*DECK DECK=RFH$START_SERVER_JOB EXPAND=FALSE

{    The purpose of this routine is to start a server job to process an incoming connect
{    request.
{
{    server: (input,output) This parameter points to the corresponding server table entry.
{      This entry is updated to reflect the status after the server job is started.
{
{    status: (output) This parameter specifies the results of the request.

*DECK DECK=RFH$STATIC_DATA EXPAND=FALSE
{
{    This module contains the static RHFAM/VE definitions that are defined
{    in the network paged section.  These definitions are initialized at
{    deadstart time and remain valid until a subsequent deadstart.
{
*DECK DECK=RFH$STORE EXPAND=FALSE
{
{     The purpose of this request is to change the connection file
{     attributes of the specified file.
{
{     CONNECTION_IDENTIFIER: (input) This parameter specifies the
{       connection identifier of the connection file to change the
{       attributes on.
{
{     FILE_ATTRIBUTES: (input) This parameter specifies which file
{       attribute to change and the desired values.
{
{     STATUS: (output) This parameter returns the result of the request.
{       A value of normal indicates that the specified attributes were
{       changed.
*DECK DECK=RFH$TERMINATE_ASYNC_ACTIVITY EXPAND=FALSE
{
{      This request allows the calling program to terminate all desired
{ asynchronous activity for a connection without terminating
{ the connection.  All requests that were abnormally terminated by
{ this request will have an error condition of
{ 'rfe$async_req_terminated'.
{
{      Caution should be used when issuing this request, because the
{ results may not be consistent.  The reason for the inconsistencies
{ stems from the inherent nature of the request; attempting to terminate
{ requests that are running asynchronously.  The inconsistent results
{ that the caller may observe:
{
{      1)  Asynchronous requests that were to be terminated by this
{          request could have successfully completed.
{
{      2)  Asynchronous requests that were to be terminated by this
{          request could have failed for a different reason.
{
{ RFP$TERMINATE_ASYNC_ACTIVITY(CONNECTION_IDENTIFIER, ACTIVITY_TYPES,
{   STATUS)
{
{ CONNECTION_IDENTIFIER: (input) This parameter specifies the instance
{   of open of the connection file, for which the application wants the
{   specified asynchronous activity(ies) terminated.
{
{ ACTIVITY_TYPES: (input) This parameter specifies the types of
{   activities that should be terminated.  The valid types are
{   send data, receive data and all asynchronous activities.
{
{ STATUS: (output) This parameter returns the results of the request.
{   A status of normal means that all activity of the requested
{   type(s) has been terminated.
{   CONDITIONS:  ame$improper_file_id
{                rfe$connection_not_active
{                rfe$file_device_class_not_rhf
{   IDENTIFIER:  'RF'
{
*DECK DECK=RFH$TERMINATE_CONNECTION EXPAND=FALSE
{
{      The purpose of this request is to terminate an established
{ connection so that the resources may be used by another application.
{ This request can be issued for a connection any time after a
{ connection file is created  (i.e. RFP$REQUEST_CONNECTION,
{ RFP$ACQUIRE_CONNECT_REQUEST, and RFP$ACQUIRE_ASSIGNED_CONNECTION).
{
{      This request is not legal if there are any active instances of
{ of open for the connection file.
{
{      This request is required by both applications (server and client)
{ regardless of the status of the underlying network connection.
{
{      The CONNECTION_FILE is deleted upon successful completion of
{ of this request.
{
{ RFP$TERMINATE_CONNECTION(CONNECTION_FILE, NORMAL_TERMINATION,
{    CONNECTION_STATISTICS, STATUS)
{
{ CONNECTION_FILE: (input) This parameter specifies the temporary file
{   assigned to the connection to be terminated.  This file is deleted
{   upon successful completion of this request.
{
{ NORMAL_TERMINATION: (input) This parameter specifies the type of
{   connection termination to perform.  If TRUE, the normal disconnect
{   will be issued to allow blocks in transit to be received by the
{   peer application prior to the termination of the connection.  If
{   FALSE, a purge connection will be issued to immediately
{   terminate the connection and the corresponding connection messages.
{
{ CONNECTION_STATISTICS: (output) This parameter returns the network
{   usage statistics for the corresponding connection.
{
{    connect_time:  This parameter returns the time (in milliseconds) from
{      the connection establishment until the connection termination.
{
{    bytes_sent:  This parameter returns the total number of
{      bytes that were sent from this end of the connection.
{
{    bytes_received:  This parameter returns the total number of
{      bytes that were received at this end of the connection.
{
{ STATUS: (output) This parameter returns the results of the request.
{   A status of normal means the connection has been terminated.
{   CONDITIONS: ame$file_not_closed
{               rfe$connection_not_active
{   IDENTIFIER: 'RF'
{
*DECK DECK=RFH$TEST_LOCAL_NAD EXPAND=FALSE
{
{      This subcommand provides the operator with the capability of running
{ a test on a local network access device(NAD) that currently has state of
{ OFF.
{
{      The caller must have NETWORK_OPERATION capability specified in the
{ validation file, or be the system job in order to use this command.
{
{ TEST_LOCAL_NAD, TESLN(
{     nad, n : NAME = $REQUIRED
{     status)
{
{ nad:  This parameter specifies the name of the nad on which is a
{   test is to be run.
{
{ status:  This parameter returns the results of the request.
{
*DECK DECK=RFH$UNCONDITIONALLY_STATUS EXPAND=FALSE

{    The purpose of this routine is to change the NAD status unit
{    request so that the PP will unconditionally obtain the local
{    NAD status.  This request is used at shut-down time to force
{    the termination of the request.  This request is also used
{    when the system task has not received any NAD status within
{    a threshold.
{
{    unit_number: (input) This parameter specifies the logical unit
{      number of the corresponding local NAD.
*DECK DECK=RFH$VERIFY_RHFAM_CONFIGURATION EXPAND=FALSE

{
{      This sub-command is used to verify the contents of a newly
{ generated configuration file.  This allows RHFAM configuration file
{ validity to be checked before installation attempts are made.
{
{      VERRC is a sub-command of the MANAGE_RHFAM_NETWORK
{ and can be executed by any user that has network operator capabilities
{ or by the system job.
{
{ VERIFY_RHFAM_CONFIGURATION, VERRC(
{      input, i: file = $required
{      output, o : file = $output
{      status: status = $optional)
{
{ input:  This parameter specifies the name of the file containing the
{   RHFAM configuration directives to verify.
{
{ output:  This parameter specifies the name of the file to which the
{   verification output will be written.  Each directive will be
{   echoed to the output file, and any diagnostic associated
{   with the directive will be written in the following lines.
{
{    WARNING - The echo is performed by creating a file connection between
{              the 'output' file and the '$echo' file.  If the user specifies
{              a file that can not be connected to '$echo', the command
{              will not be processed and an invalid status will be returned.
{
{ status:  This parameter returns the results of the request.
{
*DECK DECK=RFK$KEYPOINTS EXPAND=FALSE

{     The following are the RHFAM/VE application interface keypoint
{     definitions.

  CONST
    rfk$accept_connect_request = rfk$ai_base + 1,
    {E 'rfp$accept_connect_request'}
    {X 'rfp$accept_connect_request' 'status' I20}

    rfk$acquire_connect_request = rfk$ai_base + 2,
    {E 'rfp_acquire_connect_request'}
    {X 'rfp_acquire_connect_request' 'status' I20}

    rfk$accept_switch_offer = rfk$ai_base + 3,
    {E 'rfp$accept_switch_offer'}
    {X 'rfp$accept_switch_offer' 'status' I20}

    rfk$application_sign_on = rfk$ai_base + 4,
    {E 'rfp$application_sign_on'}
    {X 'rfp$application_sign_on' 'status' I20}

    rfk$application_sign_off = rfk$ai_base + 5,
    {E 'rfp$application_sign_off'}
    {X 'rfp$application_sign_off' 'status' I20}

    rfk$offer_connection_switch  = rfk$ai_base + 6,
    {E 'rfp$offer_connection_switch'}
    {X 'rfp$offer_connection_switch' 'status' I20}

    rfk$await_rhfam_event = rfk$ai_base + 7,
    {E 'rfp$await_rhfam_event'}
    {X 'rfp$await_rhfam_event' 'status' I20}

    rfk$await_server_response = rfk$ai_base + 8,
    {E 'rfp$await_server_response'}
    {X 'rfp$await_server_response' 'status' I20}

    rfk$define_server = rfk$ai_base + 9,
    {E 'rfp$define_server'}
    {X 'rfp$define_server' 'status' I20}

    rfk$find_available_service = rfk$ai_base + 10,
    {E 'rfp$find_available_service'}
    {X 'rfp$find_available_service' 'status' I20}

    rfk$receive_data = rfk$ai_base + 11,
    {E 'rfp$receive_data'}
    {X 'rfp$receive_data' 'status' I20}

    rfk$remove_server = rfk$ai_base + 12,
    {E 'rfp$remove_server'}
    {X 'rfp$remove_server' 'status' I20}

    rfk$reject_connect_request = rfk$ai_base + 13,
    {E 'rfp$reject_connect_request'}
    {X 'rfp$reject_connect_request' 'status' I20}

    rfk$request_connection = rfk$ai_base + 14,
    {E 'rfp$request_connection'}
    {X 'rfp$request_connection' 'status' I20}

    rfk$send_data = rfk$ai_base + 15,
    {E 'rfp$send_data'}
    {X 'rfp$send_data' 'status' I20}

    rfk$terminate_async_activity = rfk$ai_base + 16,
    {E 'rfp$terminate_async_activity'}
    {X 'rfp$terminate_async_activity' 'status' I20}

    rfk$terminate_connection = rfk$ai_base + 17,
    {E 'rfp$terminate_connection'}
    {X 'rfp$terminate_connection' 'status' I20}

    rfk$cancel_switch_offer = rfk$ai_base + 18,
    {E 'rfp$cancel_switch_offer'}
    {X 'rfp$cancel_switch_offer' 'status' I20}

    rfk$ai_limit = rfk$ai_base + 50;

*DECK DECK=RFM$APPLICATION_MANAGEMENT EXPAND=TRUE
*copyc osd$default_pragmats
MODULE rfm$application_management;
?? TITLE := 'RHFAM_APPLICATION_MANAGEMENT' ??
?? NEWTITLE := '  RING BRACKETS 23D' ??
?? NEWTITLE := '    XREF procedures', EJECT ??
*copyc amp$return
*copyc fsp$copy_file
*copyc osp$set_status_abnormal
*copyc pfp$define
*copyc pfp$define_catalog
*copyc pfp$purge
*copyc pmp$generate_unique_name
*copyc pmp$ready_task
*copyc rfp$lock_table
*copyc rfp$unlock_table
?? TITLE := '    INLINE procedures', EJECT ??
*copyc rfp$find_client_entry
*copyc rfp$verify_caller_capability
*copyc syp$cycle
?? NEWTITLE := '      find_server_entry', EJECT ??
  PROCEDURE [INLINE] find_server_entry (server_name: rft$application_name;
    VAR server_entry_p: ^rft$rhfam_server_table_entry);

{
{           The purpose of this procedure is to locate the specified
{     server table entry and return a pointer to the entry.
{     The caller of this routine must have the server table locked.
{
{     SERVER_NAME: (input) This parameter specifies the server to
{       locate.
{
{     SERVER_ENTRY_P: (output) This parameter returns the pointer to the
{       specified server table entry. A NIL pointer indicates no server
{       table entry was found.
{

    server_entry_p := rfv$rhfam_server_table.first_entry;
    WHILE server_entry_p <> NIL DO
      IF (server_entry_p^.server_name = server_name) THEN
        RETURN;
      IFEND;
      server_entry_p := server_entry_p^.next_entry;
    WHILEND;

  PROCEND find_server_entry;
?? OLDTITLE, EJECT ??
?? OLDTITLE, EJECT ??
?? TITLE := '    TYPE/CONST Definitions', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rfe$condition_codes
?? POP ??
*copyc nav$network_paged_heap
*copyc rfv$status_table
*copyc rfv$rhfam_client_table
*copyc rfv$rhfam_server_table
*copyc rfv$system_task_id
*copyc tmv$null_global_task_id
?? TITLE := '    rfp$activate_rhfam_client', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$activate_rhfam_client (client: rft$application_name;
    VAR status: ost$status);

*copy rfh$activate_rhfam_client_r3

    VAR
      abort_connections: BOOLEAN,
      client_entry_p: ^rft$rhfam_client_table_entry,
      capabilities: ARRAY[1..1] OF ost$name,
      local_status: ost$status;

    status.normal := TRUE;

    capabilities [1] := avc$network_applic_management;

    rfp$verify_caller_capability (^capabilities, 'ACTIVATE_RHFAM_CLIENT', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /wait_for_abort_connections/
    REPEAT
      rfp$lock_table (rfv$rhfam_client_table.lock);
      rfp$find_client_entry (client, FALSE, client_entry_p, local_status);
      IF NOT local_status.normal THEN
        osp$set_status_abnormal (rfc$product_id, rfe$appl_not_defined, client, status);
        EXIT /wait_for_abort_connections/;
      IFEND;
      IF client_entry_p^.client_active THEN
        osp$set_status_abnormal (rfc$product_id, rfe$appl_already_active, client, status);
        EXIT /wait_for_abort_connections/;
      IFEND;
      abort_connections := client_entry_p^.abort_connections;
      IF abort_connections AND rfv$status_table.system_task_is_up THEN
        rfp$unlock_table (rfv$rhfam_client_table.lock);
        syp$cycle;
      ELSE
        client_entry_p^.abort_connections := FALSE;
        abort_connections := FALSE;
      IFEND;
    UNTIL NOT abort_connections;

    IF status.normal THEN
      client_entry_p^.client_active := TRUE;
    IFEND;

    rfp$unlock_table (rfv$rhfam_client_table.lock);

  PROCEND rfp$activate_rhfam_client;
?? TITLE := '    rfp$activate_rhfam_server', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$activate_rhfam_server (server: rft$application_name;
    VAR status: ost$status);

*copy rfh$activate_rhfam_server_r3

    VAR
      abort_connections: BOOLEAN,
      server_entry_p: ^rft$rhfam_server_table_entry,
      capabilities: ARRAY[1..1] OF ost$name;

    status.normal := TRUE;

    capabilities [1] := avc$network_applic_management;

    rfp$verify_caller_capability (^capabilities, 'ACTIVATE_RHFAM_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /wait_for_abort_connections/
    REPEAT
      rfp$lock_table (rfv$rhfam_server_table.lock);
      find_server_entry (server, server_entry_p);
      IF server_entry_p = NIL THEN
        osp$set_status_abnormal (rfc$product_id, rfe$appl_not_defined, server, status);
        EXIT /wait_for_abort_connections/;
      IFEND;
      IF server_entry_p^.server_active THEN
        osp$set_status_abnormal (rfc$product_id, rfe$appl_already_active, server, status);
        EXIT /wait_for_abort_connections/;
      IFEND;
      abort_connections := server_entry_p^.abort_connections;
      IF abort_connections AND rfv$status_table.system_task_is_up THEN
        rfp$unlock_table (rfv$rhfam_server_table.lock);
        syp$cycle;
      ELSE
        server_entry_p^.abort_connections := FALSE;
        abort_connections := FALSE;
      IFEND;
    UNTIL NOT abort_connections;

    IF status.normal THEN
      server_entry_p^.server_active := TRUE;
    IFEND;

    rfp$unlock_table (rfv$rhfam_server_table.lock);

  PROCEND rfp$activate_rhfam_server;
?? TITLE := '    rfp$deactivate_rhfam_client', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$deactivate_rhfam_client (client: rft$application_name;
    terminate_active_connections: boolean;
    VAR status: ost$status);

*copy rfh$deactivate_rhfam_client_r3

    VAR
      ignore_status: ost$status,
      task_id: ost$global_task_id,
      client_entry_p: ^rft$rhfam_client_table_entry,
      capabilities: ARRAY[1..1] OF ost$name,
      local_status: ost$status;

    status.normal := TRUE;

    capabilities [1] := avc$network_applic_management;

    rfp$verify_caller_capability (^capabilities, 'DEACTIVATE_RHFAM_CLIENT', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    task_id := tmv$null_global_task_id;

    rfp$lock_table (rfv$rhfam_client_table.lock);

  /deactivate_client/
    BEGIN
      rfp$find_client_entry (client, FALSE, client_entry_p, local_status);
      IF NOT local_status.normal THEN
        osp$set_status_abnormal (rfc$product_id, rfe$appl_not_defined, client, status);
        EXIT /deactivate_client/;
      IFEND;
      IF NOT client_entry_p^.client_active THEN
        osp$set_status_abnormal (rfc$product_id, rfe$appl_already_inactive, client, status);
        EXIT /deactivate_client/;
      IFEND;
      client_entry_p^.client_active := FALSE;
      IF terminate_active_connections AND (client_entry_p^.current_connections <> 0) AND
        rfv$status_table.system_task_is_up THEN
        client_entry_p^.abort_connections := TRUE;
        task_id := rfv$system_task_id;
      IFEND;
    END /deactivate_client/;

    rfp$unlock_table (rfv$rhfam_client_table.lock);

    IF (task_id = rfv$system_task_id) AND (task_id <> tmv$null_global_task_id) THEN
      pmp$ready_task (task_id, ignore_status);
    IFEND;

  PROCEND rfp$deactivate_rhfam_client;
?? TITLE := '    rfp$deactivate_rhfam_server', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$deactivate_rhfam_server (server: rft$application_name;
    terminate_active_connections: boolean;
    VAR status: ost$status);

*copy rfh$deactivate_rhfam_server_r3

    VAR
      active_incoming_connects: BOOLEAN,
      ignore_status: ost$status,
      task_id: ost$global_task_id,
      server_entry_p: ^rft$rhfam_server_table_entry,
      capabilities: ARRAY[1..1] OF ost$name;

    status.normal := TRUE;

    capabilities [1] := avc$network_applic_management;

    rfp$verify_caller_capability (^capabilities, 'DEACTIVATE_RHFAM_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    task_id := tmv$null_global_task_id;

  /wait_for_active_incoming/
    REPEAT
      rfp$lock_table (rfv$rhfam_server_table.lock);
      find_server_entry (server, server_entry_p);
      IF server_entry_p = NIL THEN
        osp$set_status_abnormal (rfc$product_id, rfe$appl_not_defined, server, status);
        EXIT /wait_for_active_incoming/;
      IFEND;
      IF NOT server_entry_p^.server_active THEN
        osp$set_status_abnormal (rfc$product_id, rfe$appl_already_inactive, server, status);
        EXIT /wait_for_active_incoming/;
      IFEND;
      active_incoming_connects := (server_entry_p^.active_incoming_connects <> 0);
      IF active_incoming_connects THEN
        rfp$unlock_table (rfv$rhfam_server_table.lock);
        syp$cycle;
      ELSE
        server_entry_p^.server_active := FALSE;
        IF terminate_active_connections AND (server_entry_p^.current_connections <> 0) AND
          rfv$status_table.system_task_is_up THEN
          server_entry_p^.abort_connections := TRUE;
          task_id := rfv$system_task_id;
        IFEND;
      IFEND;
    UNTIL NOT active_incoming_connects;

    rfp$unlock_table (rfv$rhfam_server_table.lock);

    IF (task_id = rfv$system_task_id) AND (task_id <> tmv$null_global_task_id) THEN
      pmp$ready_task (task_id, ignore_status);
    IFEND;

  PROCEND rfp$deactivate_rhfam_server;
?? TITLE := '    rfp$define_rhfam_client', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$define_rhfam_client (client: rft$application_name;
    maximum_connections: rft$application_connections;
    capability: ost$name;
    ring: ost$ring;
    system_privilege: boolean;
    system_wide_connection_mgmt: boolean;
    VAR status: ost$status);

*copy rfh$define_rhfam_client_r3

    VAR
      client_entry_p: ^rft$rhfam_client_table_entry,
      new_client_entry_p: ^rft$rhfam_client_table_entry,
      server_entry_p: ^rft$rhfam_server_table_entry,
      capabilities: ARRAY[1..1] OF ost$name,
      local_status: ost$status;

    status.normal := TRUE;

    capabilities [1] := avc$network_applic_management;

    rfp$verify_caller_capability (^capabilities, 'DEFINE_RHFAM_CLIENT', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE new_client_entry_p IN nav$network_paged_heap^;

    new_client_entry_p^.next_entry := NIL;
    new_client_entry_p^.client_active := FALSE;
    new_client_entry_p^.client_name := client;
    new_client_entry_p^.maximum_connections := maximum_connections;
    new_client_entry_p^.current_connections := 0;
    new_client_entry_p^.client_capability := capability;
    new_client_entry_p^.client_ring := ring;
    new_client_entry_p^.client_system_privilege := system_privilege;
    new_client_entry_p^.system_wide_connection_mgmt := system_wide_connection_mgmt;
    new_client_entry_p^.connections_reserved := 0;
    new_client_entry_p^.abort_connections := FALSE;

{ Server table is locked first to avoid deadlock with DEFINE_SERVER command.

    rfp$lock_table (rfv$rhfam_server_table.lock);
    rfp$lock_table (rfv$rhfam_client_table.lock);

  /define_client/
    BEGIN

      rfp$find_client_entry (client, FALSE, client_entry_p, local_status);
      IF local_status.normal THEN
        osp$set_status_abnormal (rfc$product_id, rfe$duplicate_appl_definition, client, status);
        EXIT /define_client/;
      IFEND;

      find_server_entry (client, server_entry_p);
      IF server_entry_p <> NIL THEN
        osp$set_status_abnormal (rfc$product_id, rfe$client_defined_as_server, client, status);
        EXIT /define_client/;
      IFEND;
      new_client_entry_p^.next_entry := rfv$rhfam_client_table.first_entry;
      rfv$rhfam_client_table.first_entry := new_client_entry_p;

    END /define_client/;

    rfp$unlock_table (rfv$rhfam_client_table.lock);
    rfp$unlock_table (rfv$rhfam_server_table.lock);

    IF NOT status.normal THEN
      FREE new_client_entry_p IN nav$network_paged_heap^;
    IFEND;


  PROCEND rfp$define_rhfam_client;
?? TITLE := '    rfp$define_rhfam_server', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$define_rhfam_server (server: rft$application_name;
    rhfam_initiated: boolean;
    maximum_connections: rft$application_connections;
    capability: ost$name;
    ring: ost$ring;
    system_privilege: boolean;
    server_job: amt$local_file_name;
    server_job_max_connections: rft$application_connections;
    accept_connection: boolean;
    rhfam_validates_connection_lid: boolean;
    VAR status: ost$status);

*copy rfh$define_rhfam_server_r3

    VAR
      client_entry_p: ^rft$rhfam_client_table_entry,
      new_server_entry_p: ^rft$rhfam_server_table_entry,
      server_entry_p: ^rft$rhfam_server_table_entry,
      capabilities: ARRAY[1..1] OF ost$name,
      local_status: ost$status;

    status.normal := TRUE;

    capabilities [1] := avc$network_applic_management;

    rfp$verify_caller_capability (^capabilities, 'DEFINE_RHFAM_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE new_server_entry_p IN nav$network_paged_heap^;

    new_server_entry_p^.next_entry := NIL;
    new_server_entry_p^.server_active := FALSE;
    new_server_entry_p^.server_name := server;
    new_server_entry_p^.maximum_connections := maximum_connections;
    new_server_entry_p^.server_capability := capability;
    new_server_entry_p^.server_ring := ring;
    new_server_entry_p^.server_system_privilege := system_privilege;
    new_server_entry_p^.current_connections := 0;
    new_server_entry_p^.connections_reserved := 0;
    new_server_entry_p^.partner_job_connections := 0;
    new_server_entry_p^.access_method_accept := accept_connection;
    new_server_entry_p^.validate_connection_lid := rhfam_validates_connection_lid;
    new_server_entry_p^.active_incoming_connects := 0;
    new_server_entry_p^.abort_connections := FALSE;
    new_server_entry_p^.incoming_connect := NIL;
    new_server_entry_p^.server_identifier := NIL;
    new_server_entry_p^.rhfam_initiated_server := rhfam_initiated;
    IF rhfam_initiated THEN
      new_server_entry_p^.server_job_max_connections := server_job_max_connections;
    IFEND;

{ Server table is locked first to avoid deadlock with DEFINE_CLIENT command.

    rfp$lock_table (rfv$rhfam_server_table.lock);
    rfp$lock_table (rfv$rhfam_client_table.lock);

  /define_server/
    BEGIN

      find_server_entry (server, server_entry_p);
      IF server_entry_p <> NIL THEN
        osp$set_status_abnormal (rfc$product_id, rfe$duplicate_appl_definition, server, status);
        EXIT /define_server/;
      IFEND;

      rfp$find_client_entry (server, FALSE, client_entry_p, local_status);
      IF local_status.normal THEN
        osp$set_status_abnormal (rfc$product_id, rfe$server_defined_as_client, server, status);
        EXIT /define_server/;
      IFEND;

      IF rhfam_initiated THEN
        create_server_job_file (server_job, server, status);
        IF NOT status.normal THEN
          EXIT /define_server/;
        IFEND;
      IFEND;

      new_server_entry_p^.next_entry := rfv$rhfam_server_table.first_entry;
      rfv$rhfam_server_table.first_entry := new_server_entry_p;

    END /define_server/;

    rfp$unlock_table (rfv$rhfam_client_table.lock);
    rfp$unlock_table (rfv$rhfam_server_table.lock);

    IF NOT status.normal THEN
      FREE new_server_entry_p IN nav$network_paged_heap^;
    IFEND;

  PROCEND rfp$define_rhfam_server;
?? TITLE := '    rfp$delete_rhfam_client', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$delete_rhfam_client (client: rft$application_name;
    VAR status: ost$status);

*copy rfh$delete_rhfam_client_r3

    VAR
      client_entry_p: ^rft$rhfam_client_table_entry,
      current_entry_p: ^rft$rhfam_client_table_entry,
      previous_entry_p: ^rft$rhfam_client_table_entry,
      capabilities: ARRAY[1..1] OF ost$name,
      local_status: ost$status;

    status.normal := TRUE;

    capabilities [1] := avc$network_applic_management;

    rfp$verify_caller_capability (^capabilities, 'DELETE_RHFAM_CLIENT', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /delete_client/
    BEGIN

      rfp$lock_table (rfv$rhfam_client_table.lock);

      rfp$find_client_entry (client, FALSE, client_entry_p, local_status);
      IF NOT local_status.normal THEN
        osp$set_status_abnormal (rfc$product_id, rfe$appl_not_defined, client, status);
        EXIT /delete_client/;
      IFEND;
      IF client_entry_p^.client_active THEN
        osp$set_status_abnormal (rfc$product_id, rfe$appl_not_inactive, client, status);
        EXIT /delete_client/;
      IFEND;
      IF client_entry_p^.connections_reserved <> 0 THEN
        osp$set_status_abnormal (rfc$product_id, rfe$appl_job_signed_on, client, status);
        EXIT /delete_client/;
      IFEND;

      current_entry_p := rfv$rhfam_client_table.first_entry;
      previous_entry_p := NIL;
    /delete_client_table_entry/
      WHILE current_entry_p <> NIL DO
        IF current_entry_p^.client_name = client_entry_p^.client_name THEN
          IF previous_entry_p = NIL THEN
            rfv$rhfam_client_table.first_entry := client_entry_p^.next_entry;
          ELSE
            previous_entry_p^.next_entry := client_entry_p^.next_entry;
          IFEND;
          EXIT /delete_client_table_entry/;
        IFEND;
        previous_entry_p := current_entry_p;
        current_entry_p := current_entry_p^.next_entry;
      WHILEND /delete_client_table_entry/;

    END /delete_client/;

    rfp$unlock_table (rfv$rhfam_client_table.lock);

    IF status.normal AND (client_entry_p <> NIL) THEN
      FREE client_entry_p IN nav$network_paged_heap^;
    IFEND;

  PROCEND rfp$delete_rhfam_client;
?? TITLE := '    rfp$delete_rhfam_server', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$delete_rhfam_server (server: rft$application_name;
    VAR status: ost$status);

*copy rfh$delete_rhfam_server_r3

    VAR
      cycle_selector: pft$cycle_selector,
      password: pft$name,
      file_path: ^pft$path,
      server_entry_p: ^rft$rhfam_server_table_entry,
      current_entry_p: ^rft$rhfam_server_table_entry,
      previous_entry_p: ^rft$rhfam_server_table_entry,
      capabilities: ARRAY[1..1] OF ost$name;

    status.normal := TRUE;

    capabilities [1] := avc$network_applic_management;

    rfp$verify_caller_capability (^capabilities, 'DELETE_RHFAM_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /delete_server/
    BEGIN

      rfp$lock_table (rfv$rhfam_server_table.lock);

      find_server_entry (server, server_entry_p);
      IF server_entry_p = NIL THEN
        osp$set_status_abnormal (rfc$product_id, rfe$appl_not_defined, server, status);
        EXIT /delete_server/;
      IFEND;
      IF server_entry_p^.server_active THEN
        osp$set_status_abnormal (rfc$product_id, rfe$appl_not_inactive, server, status);
        EXIT /delete_server/;
      IFEND;
      IF server_entry_p^.connections_reserved <> 0 THEN
        osp$set_status_abnormal (rfc$product_id, rfe$appl_job_signed_on, server, status);
        EXIT /delete_server/;
      IFEND;

      IF server_entry_p^.rhfam_initiated_server THEN
        PUSH file_path: [1 .. 5];
        file_path^ [1] := rfc$rhfam_family_name;
        file_path^ [2] := rfc$rhfam_master_catalog;
        file_path^ [3] := rfc$rhfam_sub_catalog;
        file_path^ [4] := rfc$server_sub_catalog;
        file_path^ [5] := server;
        password := rfc$password;
        cycle_selector.cycle_option := pfc$highest_cycle;
        pfp$purge (file_path^, cycle_selector, password, status);
      IFEND;

      current_entry_p := rfv$rhfam_server_table.first_entry;
      previous_entry_p := NIL;
    /delete_server_table_entry/
      WHILE current_entry_p <> NIL DO
        IF current_entry_p^.server_name = server_entry_p^.server_name THEN
          IF previous_entry_p = NIL THEN
            rfv$rhfam_server_table.first_entry := server_entry_p^.next_entry;
          ELSE
            previous_entry_p^.next_entry := server_entry_p^.next_entry;
          IFEND;
          FREE server_entry_p IN nav$network_paged_heap^;
          EXIT /delete_server_table_entry/;
        IFEND;
        previous_entry_p := current_entry_p;
        current_entry_p := current_entry_p^.next_entry;
      WHILEND /delete_server_table_entry/;

    END /delete_server/;

    rfp$unlock_table (rfv$rhfam_server_table.lock);

    IF status.normal AND (server_entry_p <> NIL) THEN
      FREE server_entry_p IN nav$network_paged_heap^;
    IFEND;

  PROCEND rfp$delete_rhfam_server;
?? TITLE := '    Utility Subroutines', EJECT ??
?? NEWTITLE := '      create_server_job_file', EJECT ??
  PROCEDURE create_server_job_file (server_job: amt$local_file_name;
        application_name: rft$application_name;
    VAR status: ost$status);

{
{     The purpose of this procedure is to create the file that contains
{     the server job image.  If the server_job subcatalog does not exist
{     it will be created.  If the file already exists it will be purged
{     and redefined. This file is used by RHFAM/VE to get the job image
{     for an auto started server application. If this routine is executed
{     under a user number other than the rfc$rhfam_master_catalog the
{     subcatalog rfc$rhfam_sub_catalog must have been previously created.
{
{     SERVER_JOB: (input) This parameter specifies the server job definition
{       file to copy to the system catalog.
{
{     APPLICATION_NAME: (input) This parameter specifies the file name to
{       create in the $system.rhfam catalog.
{
{     STATUS: (output) A value of normal is returned if the server job file
{       was successfully copied to the $system catalog.
{

    VAR
      file_attributes: ^fst$file_cycle_attributes,
      ignore_status: ost$status,
      unique_name: ost$unique_name,
      cycle_selector: pft$cycle_selector,
      password: pft$name,
      catalog_path: ^pft$path,
      file_path: ^pft$path;

    status.normal := TRUE;

    PUSH catalog_path: [1 .. 4];
    catalog_path^ [1] := rfc$rhfam_family_name;
    catalog_path^ [2] := rfc$rhfam_master_catalog;
    catalog_path^ [3] := rfc$rhfam_sub_catalog;
    catalog_path^ [4] := rfc$server_sub_catalog;
    pfp$define_catalog (catalog_path^, status);
    IF (status.normal) OR
       (status.condition = pfe$name_already_subcatalog) OR
       (status.condition = pfe$not_master_catalog_owner) THEN
      PUSH file_path: [1 .. 5];
      file_path^ [1] := rfc$rhfam_family_name;
      file_path^ [2] := rfc$rhfam_master_catalog;
      file_path^ [3] := rfc$rhfam_sub_catalog;
      file_path^ [4] := rfc$server_sub_catalog;
      file_path^ [5] := application_name;
      password := rfc$password;
      cycle_selector.cycle_option := pfc$highest_cycle;
      pfp$purge (file_path^, cycle_selector, password, status);
      IF status.normal OR (status.condition = pfe$unknown_permanent_file) THEN
        pmp$generate_unique_name (unique_name, ignore_status);
        pfp$define (unique_name.value, file_path^, cycle_selector, password,
              pfc$maximum_retention, pfc$no_log, status);
        IF status.normal THEN
          PUSH file_attributes: [1..1];
          file_attributes^[1].selector := fsc$ring_attributes;
          file_attributes^[1].ring_attributes.r1 := osc$tsrv_ring;
          file_attributes^[1].ring_attributes.r2 := osc$user_ring_2;
          file_attributes^[1].ring_attributes.r3 := osc$user_ring_2;
          fsp$copy_file (server_job, unique_name.value, NIL, NIL, file_attributes, status);
          amp$return (unique_name.value, ignore_status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND create_server_job_file;
?? OLDTITLE ??
?? OLDTITLE ??
MODEND rfm$application_management;
*DECK DECK=RFM$CHANGE_STATE_COMMANDS_R3 EXPAND=TRUE
*copyc osd$default_pragmats
MODULE rfm$change_state_commands_r3;
?? TITLE := 'RHFAM_CHANGE_STATE_COMMANDS' ??
?? NEWTITLE := '  RING BRACKETS 23D' ??
?? NEWTITLE := '    XREF procedures', EJECT ??
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
*copyc rfp$change_nad_status
*copyc rfp$lock_table
*copyc rfp$unlock_table
?? TITLE := '    INLINE procedures', EJECT ??
*copyc rfp$verify_caller_capability
?? TITLE := '    TYPE/CONST Definitions', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rfe$condition_codes
*copyc rfv$status_table
?? POP ??
?? TITLE := '    rfp$change_nad_or_trunk_state', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$change_nad_or_trunk_state (nad_names_p: ^ARRAY[1 .. *] OF rft$component_name;
    trunk_names_p: ^ARRAY[1 .. *] OF rft$component_name;
    state: rft$element_state;
    VAR status: ost$status);

*copyc rfh$change_nad_or_trunk_state

    VAR
      nad_name_index,
      trunk_name_index: INTEGER,
      local_nad_index: rft$local_nads,
      remote_nad_index: rft$remote_nads,
      tcu_index: rfc$min_tcu..rfc$max_tcu,
      trunk_found_p: ^ARRAY[1..*] OF BOOLEAN,
      capabilities: ARRAY[1..1] OF ost$name;

    status.normal := TRUE;

    capabilities [1] := avc$network_operation;

    rfp$verify_caller_capability (^capabilities, 'change NAD or trunk status', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF trunk_names_p <> NIL THEN
      PUSH trunk_found_p: [1 .. UPPERBOUND(trunk_names_p^)];
      FOR trunk_name_index := LOWERBOUND(trunk_found_p^) TO UPPERBOUND(trunk_found_p^) DO
        trunk_found_p^[trunk_name_index] := FALSE;
      FOREND;
    IFEND;

    rfp$lock_table (rfv$status_table.lock);
    IF NOT rfv$status_table.system_task_is_up THEN
      rfp$unlock_table (rfv$status_table.lock);
      IF trunk_names_p = NIL THEN
        osp$set_status_abnormal (rfc$product_id, rfe$system_task_not_active, 'CHANGE_NAD_STATUS', status);
      ELSE
        osp$set_status_abnormal (rfc$product_id, rfe$system_task_not_active, 'CHANGE_TRUNK_STATUS', status);
      IFEND;
      RETURN;
    IFEND;

  /scan_nad_names/
    FOR nad_name_index := LOWERBOUND(nad_names_p^) TO UPPERBOUND(nad_names_p^) DO
      FOR local_nad_index := LOWERBOUND(rfv$status_table.local_nads^) TO
            UPPERBOUND(rfv$status_table.local_nads^) DO
        IF (rfv$status_table.local_nads^[local_nad_index].name = nad_names_p^[nad_name_index]) OR
              (nad_names_p^[nad_name_index] = 'ALL') THEN
          IF trunk_names_p <> NIL THEN
            FOR trunk_name_index := LOWERBOUND(trunk_names_p^) TO UPPERBOUND(trunk_names_p^) DO
              FOR tcu_index := LOWERBOUND(rfv$status_table.local_nads^[local_nad_index].trunk_control_units)
                    TO UPPERBOUND(rfv$status_table.local_nads^[local_nad_index].trunk_control_units) DO
                IF trunk_names_p^[trunk_name_index] =
                      rfv$status_table.local_nads^[local_nad_index].trunk_control_units[tcu_index] THEN
                  IF rfv$status_table.local_nads^[local_nad_index].current_status.tcu_status[tcu_index] =
                        rfc$es_down THEN
                    osp$set_status_abnormal (rfc$product_id, rfe$down_trunk_not_changeable,
                          trunk_names_p^[trunk_name_index], status);
                    osp$append_status_parameter (osc$status_parameter_delimiter, nad_names_p^[nad_name_index],
                          status);
                    EXIT /scan_nad_names/;
                  IFEND;
                  rfv$status_table.local_nads^[local_nad_index].current_status.tcu_status[tcu_index] := state;
                  trunk_found_p^[trunk_name_index] := TRUE;
                IFEND;
              FOREND;
            FOREND;
          ELSE
            IF (rfv$status_table.local_nads^[local_nad_index].current_status.device_status = rfc$es_down) AND
                  (state <> rfc$es_down) THEN
              osp$set_status_abnormal (rfc$product_id, rfe$down_nad_not_changable,
                    nad_names_p^[nad_name_index], status);
              EXIT /scan_nad_names/;
            ELSEIF (rfv$status_table.local_nads^[local_nad_index].current_status.device_status = rfc$es_off)
                  AND ((state = rfc$es_down) OR (state = rfc$es_on)) THEN
              rfv$status_table.local_nads^[local_nad_index].maintenance_status.reloads_performed := 0;
              rfv$status_table.local_nads^[local_nad_index].maintenance_status.reload_failed := FALSE;
              IF state = rfc$es_on THEN
                rfp$change_nad_status (rfv$status_table.local_nads^[local_nad_index].logical_unit_number,
                      rfc$es_on);
              IFEND;
            IFEND;
            rfv$status_table.local_nads^[local_nad_index].current_status.device_status := state;
          IFEND;
          IF nad_names_p^[nad_name_index] <> 'ALL' THEN
            CYCLE /scan_nad_names/;
          IFEND;
        IFEND;
      FOREND;
      IF rfv$status_table.remote_nads <> NIL THEN
        FOR remote_nad_index := LOWERBOUND(rfv$status_table.remote_nads^) TO
              UPPERBOUND(rfv$status_table.remote_nads^) DO
          IF (rfv$status_table.remote_nads^[remote_nad_index].name = nad_names_p^[nad_name_index]) OR
                (nad_names_p^[nad_name_index] = 'ALL') THEN
            IF trunk_names_p <> NIL THEN
              FOR trunk_name_index := LOWERBOUND(trunk_names_p^) TO UPPERBOUND(trunk_names_p^) DO
                FOR tcu_index :=
                      LOWERBOUND(rfv$status_table.remote_nads^[remote_nad_index].trunk_control_units) TO
                      UPPERBOUND(rfv$status_table.remote_nads^[remote_nad_index].trunk_control_units) DO
                  IF trunk_names_p^[trunk_name_index] =
                        rfv$status_table.remote_nads^[remote_nad_index].trunk_control_units[tcu_index] THEN
                    IF rfv$status_table.remote_nads^[remote_nad_index].current_status.tcu_status[tcu_index] =
                          rfc$es_down THEN
                      osp$set_status_abnormal (rfc$product_id, rfe$down_trunk_not_changeable,
                            trunk_names_p^[trunk_name_index], status);
                      osp$append_status_parameter (osc$status_parameter_delimiter,
                           nad_names_p^[nad_name_index], status);
                      EXIT /scan_nad_names/;
                    IFEND;
                    rfv$status_table.remote_nads^[remote_nad_index].current_status.tcu_status[tcu_index] :=
                          state;
                    trunk_found_p^[trunk_name_index] := TRUE;
                  IFEND;
                FOREND;
              FOREND;
            ELSE
              IF rfv$status_table.remote_nads^[remote_nad_index].current_status.device_status =
                    rfc$es_down THEN
                osp$set_status_abnormal (rfc$product_id, rfe$down_nad_not_changable,
                      nad_names_p^[nad_name_index], status);
                EXIT /scan_nad_names/;
              ELSEIF state = rfc$es_down THEN
                osp$set_status_abnormal (rfc$product_id, rfe$cannot_down_remote_nad, '', status);
                EXIT /scan_nad_names/;
              IFEND;
              rfv$status_table.remote_nads^[remote_nad_index].current_status.device_status := state;
            IFEND;
            IF nad_names_p^[nad_name_index] <> 'ALL' THEN
              CYCLE /scan_nad_names/;
            IFEND;
          IFEND;
        FOREND;
      IFEND;
      IF nad_names_p^[nad_name_index] <> 'ALL' THEN
        osp$set_status_abnormal (rfc$product_id, rfe$element_not_found, nad_names_p^[nad_name_index],
              status);
        EXIT /scan_nad_names/;
      IFEND;
    FOREND /scan_nad_names/;

    rfp$unlock_table (rfv$status_table.lock);

    IF status.normal AND (trunk_names_p <> NIL) THEN
      FOR trunk_name_index := LOWERBOUND(trunk_found_p^) TO UPPERBOUND(trunk_found_p^) DO
        IF NOT trunk_found_p^[trunk_name_index] THEN
          osp$set_status_abnormal (rfc$product_id, rfe$element_not_found, trunk_names_p^[trunk_name_index],
                status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;

  PROCEND rfp$change_nad_or_trunk_state;
?? TITLE := '    rfp$change_host_or_lid_state', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$change_host_or_lid_state (
    physical_id_list_p: ^ARRAY [1 .. *] OF rft$physical_identifier;
    logical_id_list_p: ^ARRAY [1 .. *] OF rft$logical_identifier;
    all_pids_specified: BOOLEAN;
    state: BOOLEAN;
    VAR status: ost$status);

*copyc rfh$change_host_or_lid_state

    VAR
      lid_index: rft$logical_ids_per_host,
      lid_list_index,
      pid_list_index: INTEGER,
      pid_found_p,
      lid_found_p: ^ARRAY[1 .. *] OF BOOLEAN,
      local_pid_specified: BOOLEAN,
      remote_host_entry_p: ^rft$remote_host_definition,
      capabilities: ARRAY[1..1] OF ost$name;

    status.normal := TRUE;

    capabilities [1] := avc$network_operation;

    rfp$verify_caller_capability (^capabilities, 'change host or LID status', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rfp$lock_table (rfv$status_table.lock);
    IF NOT rfv$status_table.system_task_is_up THEN
      rfp$unlock_table (rfv$status_table.lock);
      IF logical_id_list_p = NIL THEN
        osp$set_status_abnormal (rfc$product_id, rfe$system_task_not_active, 'CHANGE_HOST_STATUS', status);
      ELSE
        osp$set_status_abnormal (rfc$product_id, rfe$system_task_not_active, 'CHANGE_LID_STATUS', status);
      IFEND;
      RETURN;
    IFEND;

    local_pid_specified := all_pids_specified;

    FOR pid_list_index := LOWERBOUND(physical_id_list_p^) TO UPPERBOUND(physical_id_list_p^) DO
      IF physical_id_list_p^[pid_list_index] = rfv$status_table.local_host^.physical_identifier THEN
        local_pid_specified := TRUE;
      IFEND;
    FOREND;

    IF logical_id_list_p <> NIL THEN
      PUSH lid_found_p: [1 .. UPPERBOUND(logical_id_list_p^)];
      FOR lid_list_index := LOWERBOUND(lid_found_p^) TO UPPERBOUND(lid_found_p^) DO
        lid_found_p^[lid_list_index] := FALSE;
      FOREND;
    IFEND;

    IF local_pid_specified THEN
      IF logical_id_list_p <> NIL THEN
        FOR lid_list_index := LOWERBOUND(logical_id_list_p^) TO UPPERBOUND(logical_id_list_p^) DO
        /scan_lids/
          FOR lid_index := LOWERBOUND(rfv$status_table.local_host^.logical_identifiers) TO
                    UPPERBOUND(rfv$status_table.local_host^.logical_identifiers) DO
            IF logical_id_list_p^[lid_list_index] =
                  rfv$status_table.local_host^.logical_identifiers[lid_index].logical_id THEN
              rfv$status_table.local_host^.logical_identifiers[lid_index].disabled := state;
              lid_found_p^[lid_list_index] := TRUE;
              EXIT /scan_lids/;
            IFEND;
          FOREND /scan_lids/;
        FOREND;
      ELSE;
        rfv$status_table.local_host^.disabled := state;
      IFEND;
    IFEND;

  /scan_remote_pids/
    FOR pid_list_index := LOWERBOUND(physical_id_list_p^) TO UPPERBOUND(physical_id_list_p^) DO
      remote_host_entry_p := rfv$status_table.remote_hosts;
      IF remote_host_entry_p <> NIL THEN
        REPEAT
          IF (physical_id_list_p^[pid_list_index] = remote_host_entry_p^.physical_identifier) OR
                all_pids_specified THEN
            IF logical_id_list_p <> NIL THEN
              FOR lid_list_index := LOWERBOUND(logical_id_list_p^) TO UPPERBOUND(logical_id_list_p^) DO
              /scan_remote_lids/
                FOR lid_index := LOWERBOUND(remote_host_entry_p^.logical_identifiers) TO
                      UPPERBOUND(remote_host_entry_p^.logical_identifiers) DO
                  IF logical_id_list_p^[lid_list_index] =
                        remote_host_entry_p^.logical_identifiers[lid_index].logical_id THEN
                    remote_host_entry_p^.logical_identifiers[lid_index].disabled := state;
                    lid_found_p^[lid_list_index] := TRUE;
                    EXIT /scan_remote_lids/;
                  IFEND;
                FOREND /scan_remote_lids/;
              FOREND;
            ELSE
              remote_host_entry_p^.disabled := state;
            IFEND;
            IF NOT all_pids_specified THEN
              CYCLE /scan_remote_pids/;
            IFEND;
          IFEND;
          remote_host_entry_p := remote_host_entry_p^.next_entry;
        UNTIL remote_host_entry_p = NIL;
      IFEND;
      IF NOT ((physical_id_list_p^[pid_list_index] = rfv$status_table.local_host^.physical_identifier) OR
            (physical_id_list_p^[pid_list_index] = '')) THEN
        osp$set_status_abnormal (rfc$product_id, rfe$physical_id_not_found,
              physical_id_list_p^[pid_list_index], status);
        EXIT /scan_remote_pids/;
      IFEND;
    FOREND /scan_remote_pids/;

    rfp$unlock_table (rfv$status_table.lock);

    IF status.normal AND (logical_id_list_p <> NIL) THEN
      FOR lid_list_index := LOWERBOUND(lid_found_p^) TO UPPERBOUND(lid_found_p^) DO
        IF lid_found_p^[lid_list_index] = FALSE THEN
          osp$set_status_abnormal (rfc$product_id, rfe$logical_id_not_found,
                logical_id_list_p^[lid_list_index], status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;

  PROCEND rfp$change_host_or_lid_state;
?? TITLE := '    rfp$check_local_nad_test', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$check_local_nad_test (
    nad_name: rft$component_name;
    VAR local_nad_test_complete: BOOLEAN;
    VAR status: ost$status);

*copyc rfh$check_local_nad_test

    VAR
      user_attribute: ARRAY[1..1] OF ost$name,
      local_nad_index: rft$local_nads;

    status.normal := TRUE;
    local_nad_test_complete := FALSE;

    user_attribute[1] := avc$network_operation;

    rfp$verify_caller_capability (^user_attribute, 'check_local_NAD_test', status);

    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rfp$lock_table (rfv$status_table.lock);
    IF NOT rfv$status_table.system_task_is_up THEN
      rfp$unlock_table (rfv$status_table.lock);
      osp$set_status_abnormal (rfc$product_id, rfe$system_task_not_active, 'TEST_LOCAL_NAD', status);
      RETURN;
    IFEND;

  /scan_nad_names/
    BEGIN
      FOR local_nad_index := LOWERBOUND(rfv$status_table.local_nads^) TO
            UPPERBOUND(rfv$status_table.local_nads^) DO
        IF (rfv$status_table.local_nads^[local_nad_index].name = nad_name) THEN
          IF (rfv$status_table.local_nads^[local_nad_index].maintenance_status.test_requested =FALSE) THEN
            local_nad_test_complete := TRUE;
            IF (rfv$status_table.local_nads^[local_nad_index].current_status.device_status <> rfc$es_on) THEN
              osp$set_status_abnormal (rfc$product_id, rfe$test_nad_failure,
                    nad_name, status);
            IFEND;
          IFEND;
          EXIT /scan_nad_names/;
        IFEND;
      FOREND;
      osp$set_status_abnormal (rfc$product_id, rfe$element_not_found, nad_name,
              status);

    END /scan_nad_names/;
    rfp$unlock_table (rfv$status_table.lock);

  PROCEND rfp$check_local_nad_test;
?? TITLE := '    rfp$initiate_local_nad_test', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$initiate_local_nad_test (
    nad_name: rft$component_name;
    VAR status: ost$status);

*copyc rfh$initiate_local_nad_test

    VAR
      user_attribute: ARRAY[1..1] OF ost$name,
      local_nad_index: rft$local_nads;

    status.normal := TRUE;

    user_attribute[1] := avc$network_operation;

    rfp$verify_caller_capability (^user_attribute, 'check_local_NAD_test', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rfp$lock_table (rfv$status_table.lock);
    IF NOT rfv$status_table.system_task_is_up THEN
      rfp$unlock_table (rfv$status_table.lock);
      osp$set_status_abnormal (rfc$product_id, rfe$system_task_not_active, 'TEST_LOCAL_NADS', status);
      RETURN;
    IFEND;

  /scan_nad_names/
    BEGIN
      FOR local_nad_index := LOWERBOUND(rfv$status_table.local_nads^) TO
            UPPERBOUND(rfv$status_table.local_nads^) DO
        IF (rfv$status_table.local_nads^[local_nad_index].name = nad_name) THEN
          IF (rfv$status_table.local_nads^[local_nad_index].current_status.device_status <> rfc$es_off) THEN
            osp$set_status_abnormal (rfc$product_id, rfe$improper_nad_state_for_test,
                  nad_name, status);
          ELSEIF (rfv$status_table.local_nads^[local_nad_index].maintenance_status.test_requested = TRUE) THEN
            osp$set_status_abnormal (rfc$product_id, rfe$test_already_in_process,
                  nad_name, status);
          ELSE
            rfv$status_table.local_nads^[local_nad_index].maintenance_status.test_requested := TRUE;
            rfv$status_table.local_nads^[local_nad_index].maintenance_status.reloads_performed := 0;
            rfv$status_table.local_nads^[local_nad_index].maintenance_status.reload_failed := FALSE;
            rfv$status_table.local_nads^[local_nad_index].current_status.device_status := rfc$es_down;
          IFEND;
          EXIT /scan_nad_names/;
        IFEND;
      FOREND;
      osp$set_status_abnormal (rfc$product_id, rfe$element_not_found, nad_name,
              status);
    END /scan_nad_names/;
    rfp$unlock_table (rfv$status_table.lock);

  PROCEND rfp$initiate_local_nad_test;
?? OLDTITLE ??

MODEND rfm$change_state_commands_r3
*DECK DECK=RFM$CONFIGURATION_UTILITY EXPAND=TRUE
*copyc osd$default_pragmats
?? TITLE := 'RHFAM/VE : Configuration Verification and Installation : R2DD' ??
?? NEWTITLE := '  Common Decks' ??
MODULE rfm$configuration_utility;
*copyc rfh$configuration_utility
?? EJECT ??
*copyc rfh$description_of_directives
?? EJECT ??
*copyc rft$config_utl_pointers
?? EJECT ??
*copyc rfe$condition_codes
?? EJECT ??
*copyc amp$get_next
*copyc amp$get_segment_pointer
*copyc amp$put_next
*copyc amp$return
*copyc amp$set_segment_eoi
*copyc clp$create_file_connection
*copyc clp$delete_file_connection
*copyc clp$end_scan_command_file
*copyc clp$get_data_line
*copyc clp$get_parameter_list_text
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$scan_command_file
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc fsp$close_file
*copyc fsp$copy_file
*copyc fsp$open_file
*copyc jmp$system_job
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$format_message
*copyc osv$lower_to_upper
*copyc osp$set_status_abnormal
*copyc pfp$attach
*copyc pfp$define
*copyc pfp$define_catalog
*copyc pfp$purge
*copyc pmp$continue_to_cause
*copyc pmp$establish_condition_handler
*copyc pmp$generate_unique_name
*copyc pmp$zero_out_table
*copyc rfp$initialize_config_pointers
*copyc rfp$preserve_config_pointers
*copyc rfp$release_config_pointers
*copyc rfp$retrieve_config_pointers
?? TITLE := '  Global Variables' ??
?? EJECT ??
  TYPE
      configuration_search_modes = (csm_local, csm_remote, csm_both);

  VAR
      keyword_all: [READ] ost$name := 'ALL',
      rfv$config_utility: [READ] ost$name := 'rhfam_configuration_utility',
      rfv$verify_command: [READ] ost$name := 'verify_rhfam_configuration',
      rfv$install_command: [READ] ost$name := 'install_rhfam_configuration',
      rfv$install_config_bin: [READ] ost$name := 'install_rhfam_config_bin',
      echo_file: [READ] amt$local_file_name := '$echo';
?? TITLE := '  RFP$VERIFY_RHFAM_CONFIGURATION' ??
?? EJECT ??
  PROCEDURE [XDCL] rfp$verify_rhfam_configuration (parameter_list : clt$parameter_list;
                                               VAR status : ost$status);

*copyc rfh$verify_rhfam_configuration


*copyc rfd$pdt_verify_rhfam_config

?? EJECT ??
    PROCEDURE  clean_up_on_exit(condition: pmt$condition;
                                condition_descriptor: ^pmt$condition_information;
                                save_area: ^ost$stack_frame_save_area;
                            VAR status: ost$status);

{    The purpose of this procedure is clean up the environment upon termination of the
{    VERIFY_RHFAM_CONFIGURATION sub-utility.  The condition handler attempts to release all files,
{    file connections and scratch areas that were in use at the time the main procedure is exited
{    (either normally or abnormally).
{
{    condition: (input) This parameter specifies the condition that caused the abnormal block exit.
{      (not used by this routine).
{
{    condition_descriptor: (input) This parameter specifies the user defined condition. (not used by
{      this routine).
{
{    save_area: (input) This parameter points to the stack frame save area of the offending routine.
{      (not used by this routine).
{
{    status: (output) This parameter specifies the status at the time of the block exit.  This is passed
{      on, unaltered, to the next condition handler.

      VAR
          ignore_status : ost$status;

      IF  (current_state > open_command_file)  OR
          ((current_state = open_command_file)  AND
           (open_command_file_status.normal))  THEN
        fsp$close_file(save_info.temporary_command_file_fid, ignore_status);
        amp$return(temporary_command_file, ignore_status);
      IFEND;
      IF  (current_state > open_scratch_seg)  OR
          ((current_state = open_scratch_seg)  AND
           (open_scratch_seg_status.normal))  THEN
        fsp$close_file(save_info.temporary_fid, ignore_status);
        amp$return(temporary_file_lfn, ignore_status);
      IFEND;
      IF  (current_state > open_output_file) OR
          ((current_state = open_output_file)  AND
           (open_output_file_status.normal))  THEN
        fsp$close_file(save_info.output_fid, ignore_status);
      IFEND;
      IF  (current_state > init_global_vars)  OR
          ((current_state = init_global_vars)  AND
           (init_global_vars_status.normal))  THEN
        rfp$release_config_pointers;
      IFEND;
      IF  (current_state > push_utility)  OR
          ((current_state = push_utility)  AND
            (push_utility_status.normal))  THEN
        clp$pop_utility(ignore_status);
      IFEND;
      IF  (current_state > connect_echo_file)  OR
          ((current_state = connect_echo_file)  AND
           (connect_echo_file_status.normal))  THEN
        clp$delete_file_connection(echo_file, output_file.file.local_file_name, ignore_status);
      IFEND;
      pmp$continue_to_cause(pmc$execute_standard_procedure, status);
    PROCEND  clean_up_on_exit;
?? EJECT ??
    TYPE
        verify_states = (initial, connect_echo_file, push_utility, init_global_vars, open_output_file,
                         open_command_file, open_scratch_seg, ready_to_scan);

    VAR
        block_exit : [STATIC,READ] pmt$condition :=
                   [pmc$condition_combination,$pmt$condition_combination[pmc$block_exit_processing]],
        temporary_command_file: amt$local_file_name,
        temporary_file_lfn: amt$local_file_name,
        unique_name: ost$unique_name,
        exit_descriptor : pmt$established_handler,
        current_state: verify_states,
        input_file : clt$value,
        output_file : clt$value,
        save_info: rft$config_utl_pointers,
        segment_ptr: amt$segment_pointer,
        attachment_options: ^fst$attachment_options,
        connect_echo_file_status,
        push_utility_status,
        init_global_vars_status,
        open_output_file_status,
        open_scratch_seg_status,
        open_command_file_status,
        ignore_status: ost$status;

    status.normal := TRUE;
    current_state := initial;

  /main_section/
    BEGIN

      clp$scan_parameter_list(parameter_list, verify_configuration, status);
      IF  NOT status.normal  THEN
         RETURN;
      IFEND;
      pmp$generate_unique_name(unique_name, ignore_status);
      temporary_file_lfn := unique_name.value;
      pmp$generate_unique_name(unique_name, ignore_status);
      temporary_command_file := unique_name.value;
      clp$get_value('input', 1, 1, clc$low, input_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$get_value('output', 1, 1, clc$low, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      pmp$establish_condition_handler(block_exit, ^clean_up_on_exit, ^exit_descriptor, status);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
      connect_echo_file_status.normal := FALSE;
      #SPOIL(connect_echo_file_status,current_state);
      current_state := connect_echo_file;
      clp$create_file_connection(echo_file, output_file.file.local_file_name, connect_echo_file_status);
      IF  NOT connect_echo_file_status.normal  THEN
        status := connect_echo_file_status;
        RETURN;
      IFEND;
      push_utility_status.normal := FALSE;
      #SPOIL(push_utility_status,current_state);
      current_state := push_utility;
      clp$push_utility(rfv$verify_command, clc$global_command_search, rfv$verify_directives, NIL,
                       push_utility_status);
      IF  NOT push_utility_status.normal  THEN
        status := push_utility_status;
        RETURN;
      IFEND;
      init_global_vars_status.normal := FALSE;
      #SPOIL(init_global_vars_status,current_state);
      current_state := init_global_vars;
      rfp$initialize_config_pointers(FALSE, save_info, init_global_vars_status);
      IF  NOT init_global_vars_status.normal  THEN
        status := init_global_vars_status;
        RETURN;
      IFEND;
      PUSH  attachment_options : [1..1];
      attachment_options^[1].selector := fsc$access_and_share_modes;
      attachment_options^[1].access_modes.selector := fsc$specific_access_modes;
      attachment_options^[1].access_modes.value :=
        $fst$file_access_options[fsc$append];
      attachment_options^[1].share_modes.selector := fsc$determine_from_access_modes;
      open_output_file_status.normal := FALSE;
      #SPOIL(open_output_file_status,current_state);
      current_state := open_output_file;
      fsp$open_file(output_file.file.local_file_name, amc$record, attachment_options, NIL, NIL,
        NIL, NIL, save_info.output_fid, open_output_file_status);
      IF NOT open_output_file_status.normal THEN
        status := open_output_file_status;
        RETURN;
      IFEND;
      attachment_options^[1].access_modes.value :=
        $fst$file_access_options[fsc$read, fsc$append, fsc$shorten];
      open_command_file_status.normal := FALSE;
      #SPOIL(open_command_file_status,current_state);
      current_state := open_command_file;
      fsp$open_file(temporary_command_file, amc$record, attachment_options, NIL, NIL,
        NIL, NIL, save_info.temporary_command_file_fid, open_command_file_status);
      IF NOT open_command_file_status.normal THEN
        status := open_command_file_status;
        RETURN;
      IFEND;
      open_scratch_seg_status.normal := FALSE;
      #SPOIL(open_scratch_seg_status,current_state);
      current_state := open_scratch_seg;
      fsp$open_file(temporary_file_lfn, amc$segment, attachment_options, NIL, NIL,
        NIL, NIL, save_info.temporary_fid, open_scratch_seg_status);
      IF NOT open_scratch_seg_status.normal THEN
        status := open_scratch_seg_status;
        RETURN;
      IFEND;
      current_state := ready_to_scan;
      amp$get_segment_pointer(save_info.temporary_fid, amc$sequence_pointer, segment_ptr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      save_info.temporary_seq := segment_ptr.sequence_pointer;
      RESET save_info.temporary_seq;
      rfp$preserve_config_pointers(save_info);
      clp$scan_command_file(input_file.file.local_file_name, rfv$verify_command, 'VRC', status);
    END  /main_section/;

    rfp$retrieve_config_pointers(save_info);

    IF status.normal THEN
      IF  NOT save_info.local_host_defined  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$required_def_missing, 'local host', status);
        rfp$output_status_message(save_info.output_fid, status);
        save_info.error_encountered := TRUE;
      IFEND;

      IF  save_info.local_nad_count = 0  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$required_def_missing, 'local NAD', status);
        rfp$output_status_message(save_info.output_fid, status);
        save_info.error_encountered := TRUE;
      IFEND;
    IFEND;

    IF save_info.error_encountered THEN
      osp$set_status_abnormal(rfc$product_id, rfe$configuration_file_error, input_file.file.local_file_name,
                              status);
      osp$append_status_parameter(osc$status_parameter_delimiter, output_file.file.local_file_name,
                                  status);
    IFEND;

  PROCEND rfp$verify_rhfam_configuration;
?? NEWTITLE := '    RFP$VERIFY_RHFAM_CONFIGURATION DIRECTIVES'??
?? EJECT ??
*copyc rfd$cdt_verify_directives
?? TITLE := '    RFP$VRC_QUIT' ??
?? EJECT ??
  PROCEDURE rfp$vrc_quit (parameter_list : clt$parameter_list;
                      VAR status : ost$status);
{
{    This procedure ends the verify configuration utility environment.
{

{ pdt quit

?? PUSH (LISTEXT := ON) ??

  VAR
    quit: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??

    clp$scan_parameter_list(parameter_list, quit, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;
    clp$end_scan_command_file(rfv$verify_command, status);
  PROCEND rfp$vrc_quit;
?? OLDTITLE ??
?? TITLE := '  RFP$INSTALL_RHFAM_CONFIGURATION' ??
?? EJECT ??
  PROCEDURE [XDCL] rfp$install_rhfam_configuration (parameter_list : clt$parameter_list;
                                                VAR status : ost$status);

*copyc rfh$install_rhfam_configuration


*copyc rfd$pdt_install_rhfam_config
?? EJECT ??
    PROCEDURE  clean_up_on_exit(condition: pmt$condition;
                                condition_descriptor: ^pmt$condition_information;
                                save_area: ^ost$stack_frame_save_area;
                            VAR status: ost$status);

{    The purpose of this procedure is clean up the environment upon termination of the
{    INSTALL_RHFAM_CONFIGURATION sub-utility.  The condition handler attempts to release all files,
{    file connections and scratch areas that were in use at the time the main procedure is exited
{    (either normally or abnormally).
{
{    condition: (input) This parameter specifies the condition that caused the abnormal block exit.
{      (not used by this routine).
{
{    condition_descriptor: (input) This parameter specifies the user defined condition. (not used by
{      this routine).
{
{    save_area: (input) This parameter points to the stack frame save area of the offending routine.
{      (not used by this routine).
{
{    status: (output) This parameter specifies the status at the time of the block exit.  This is passed
{      on, unaltered, to the next condition handler.

      VAR
          ignore_status : ost$status;

      IF  ((current_state > open_command_file)  AND
           (current_state < close_command_file)) OR
          ((current_state = open_command_file)  AND
           (open_command_file_status.normal))    OR
          ((current_state = close_command_file)  AND
           (NOT open_command_file_status.normal))  THEN
        fsp$close_file(save_info.temporary_command_file_fid, ignore_status);
      IFEND;
      IF   (current_state > open_command_file)   OR
          ((current_state = open_command_file)  AND
           (open_command_file_status.normal))   THEN
        amp$return(temporary_command_file, ignore_status);
      IFEND;
      IF  ((current_state = copy_config_file)  AND
           (config_file_created_status.normal))  THEN
        delete_configuration_file(rfc$configuration_cmd_file, pfc$highest_cycle, ignore_status);
      IFEND;
      IF  (current_state > open_scratch_seg)  OR
          ((current_state = open_scratch_seg)  AND
           (open_scratch_seg_status.normal))  THEN
        fsp$close_file(save_info.temporary_fid, ignore_status);
        amp$return(temporary_file_lfn, ignore_status);
      IFEND;
      IF  (current_state > open_output_file)  OR
          ((current_state = open_output_file)  AND
           (open_output_file_status.normal))  THEN
        fsp$close_file(save_info.output_fid, ignore_status);
      IFEND;
      IF  (current_state > init_global_vars)  OR
          ((current_state = init_global_vars)  AND
           (init_global_vars_status.normal))  THEN
        rfp$release_config_pointers;
      IFEND;
      IF  (current_state > push_utility)  OR
          ((current_state = push_utility)  AND
           (push_utility_status.normal))  THEN
        clp$pop_utility(ignore_status);
      IFEND;
      pmp$continue_to_cause(pmc$execute_standard_procedure, status);
    PROCEND  clean_up_on_exit;
?? EJECT ??
    TYPE
        install_states = (initial, push_utility, init_global_vars, open_output_file, open_command_file,
                          open_scratch_seg, ready_to_scan, close_command_file, copy_config_file,
                          config_file_copied);

    VAR
        block_exit: [STATIC,READ] pmt$condition :=
                   [pmc$condition_combination,$pmt$condition_combination[pmc$block_exit_processing]],
        exit_descriptor: pmt$established_handler,
        temporary_command_file: amt$local_file_name,
        temporary_file_lfn: amt$local_file_name,
        unique_name: ost$unique_name,
        input_file: clt$value,
        output_file: clt$value,
        attachment_options: ^fst$attachment_options,
        configuration_fid: amt$file_identifier,
        save_info: rft$config_utl_pointers,
        segment_ptr: amt$segment_pointer,
        current_state: install_states,
        push_utility_status,
        init_global_vars_status,
        open_output_file_status,
        open_scratch_seg_status,
        open_command_file_status,
        config_file_created_status,
        ignore_status: ost$status;

    status.normal := TRUE;
    current_state := initial;

  /main_section/
    BEGIN

      clp$scan_parameter_list(parameter_list, install_configuration, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      pmp$generate_unique_name(unique_name, ignore_status);
      temporary_command_file := unique_name.value;
      pmp$generate_unique_name(unique_name, ignore_status);
      temporary_file_lfn := unique_name.value;
      clp$get_value('input', 1, 1, clc$low, input_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$get_value('error', 1, 1, clc$low, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      pmp$establish_condition_handler(block_exit, ^clean_up_on_exit, ^exit_descriptor, status);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
      push_utility_status.normal := FALSE;
      #SPOIL(push_utility_status,current_state);
      current_state := push_utility;
      clp$push_utility(rfv$install_command, clc$global_command_search, rfv$install_directives, nil,
                       push_utility_status);
      IF NOT push_utility_status.normal THEN
        status := push_utility_status;
        RETURN;
      IFEND;
      init_global_vars_status.normal := FALSE;
      #SPOIL(init_global_vars_status,current_state);
      current_state := init_global_vars;
      rfp$initialize_config_pointers(TRUE, save_info, init_global_vars_status);
      IF NOT init_global_vars_status.normal THEN
        status := init_global_vars_status;
        RETURN;
      IFEND;
      PUSH  attachment_options : [1..1];
      attachment_options^[1].selector := fsc$access_and_share_modes;
      attachment_options^[1].access_modes.selector := fsc$specific_access_modes;
      attachment_options^[1].access_modes.value :=
        $fst$file_access_options[fsc$append];
      attachment_options^[1].share_modes.selector := fsc$determine_from_access_modes;
      open_output_file_status.normal := FALSE;
      #SPOIL(open_output_file_status,current_state);
      current_state := open_output_file;
      fsp$open_file(output_file.file.local_file_name, amc$record, attachment_options, NIL, NIL,
        NIL, NIL, save_info.output_fid, open_output_file_status);
      IF NOT open_output_file_status.normal THEN
        status := open_output_file_status;
        RETURN;
      IFEND;
      attachment_options^[1].access_modes.value :=
        $fst$file_access_options[fsc$read, fsc$append, fsc$shorten];
      open_command_file_status.normal := FALSE;
      #SPOIL(open_command_file_status,current_state);
      current_state := open_command_file;
      fsp$open_file(temporary_command_file, amc$record, attachment_options, NIL, NIL,
         NIL, NIL, save_info.temporary_command_file_fid, open_command_file_status);
      IF NOT open_command_file_status.normal THEN
        status := open_command_file_status;
        RETURN;
      IFEND;
      open_scratch_seg_status.normal := FALSE;
      #SPOIL(open_scratch_seg_status,current_state);
      current_state := open_scratch_seg;
      fsp$open_file(temporary_file_lfn, amc$segment, attachment_options, NIL, NIL,
        NIL, NIL, save_info.temporary_fid, open_scratch_seg_status);
      IF NOT open_scratch_seg_status.normal THEN
        status := open_scratch_seg_status;
        RETURN;
      IFEND;
      current_state := ready_to_scan;
      amp$get_segment_pointer(save_info.temporary_fid, amc$sequence_pointer, segment_ptr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      save_info.temporary_seq := segment_ptr.sequence_pointer;
      RESET save_info.temporary_seq;
      rfp$preserve_config_pointers(save_info);
      clp$scan_command_file(input_file.file.local_file_name, rfv$install_command, 'IRC', status);
      rfp$retrieve_config_pointers(save_info);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
      IF save_info.error_encountered THEN
        osp$set_status_abnormal(rfc$product_id, rfe$configuration_file_error, input_file.file.local_file_name,
                                status);
        osp$append_status_parameter(osc$status_parameter_delimiter, output_file.file.local_file_name,
                                    status);
        RETURN;
      IFEND;
      open_command_file_status.normal := FALSE;
      #SPOIL(open_command_file_status,current_state);
      current_state := close_command_file;
      fsp$close_file(save_info.temporary_command_file_fid, open_command_file_status);
      IF NOT open_command_file_status.normal THEN
        status := open_command_file_status;
        RETURN;
      IFEND;
      config_file_created_status.normal := FALSE;
      #SPOIL(config_file_created_status,current_state);
      current_state := copy_config_file;
      copy_configuration_file(temporary_command_file, config_file_created_status, status);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
      current_state := config_file_copied;
    END /main_section/;

  PROCEND rfp$install_rhfam_configuration;
?? NEWTITLE := '    RFP$INSTALL_RHFAM_CONFIGURATION DIRECTIVES' ??
?? EJECT ??
*copyc rfd$cdt_install_directives
?? TITLE := '    RFP$IRC_QUIT'??
?? EJECT ??
  PROCEDURE rfp$irc_quit (parameter_list : clt$parameter_list;
                      VAR status : ost$status);
{
{    This procedure ends the install configuration utility environment.
{

{ pdt quit

?? PUSH (LISTEXT := ON) ??

  VAR
    quit: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??
    VAR
      parameter_text: ^clt$parameter_list_text,
      save_info: rft$config_utl_pointers;

    status.normal :=  TRUE;
    rfp$retrieve_config_pointers(save_info);
    clp$get_parameter_list_text(^parameter_list, parameter_text, status);
    clp$scan_parameter_list(parameter_list, quit, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;

    write_cmd_line('quit', parameter_text^, save_info, status);
    clp$end_scan_command_file(rfv$install_command, status);
  PROCEND rfp$irc_quit;
?? OLDTITLE ??
?? TITLE := '  RFP$INSTALL_RHF_CONFIG_BIN' ??
?? EJECT ??
  PROCEDURE [XDCL] rfp$install_rhf_config_bin (parameter_list : clt$parameter_list;
                                                VAR status : ost$status);

*copyc rfh$install_rhf_config_bin


*copyc rfd$pdt_install_rhf_config_bin
?? EJECT ??
    PROCEDURE  clean_up_on_exit(condition: pmt$condition;
                                condition_descriptor: ^pmt$condition_information;
                                save_area: ^ost$stack_frame_save_area;
                            VAR status: ost$status);

{    The purpose of this procedure is clean up the environment upon termination of the
{    INSTALL_RHFAM_CONFIG_BIN sub-utility.  The condition handler attempts to release all files,
{    file connections and scratch areas that were in use at the time the main procedure is exited
{    (either normally or abnormally).
{
{    condition: (input) This parameter specifies the condition that caused the abnormal block exit.
{      (not used by this routine).
{
{    condition_descriptor: (input) This parameter specifies the user defined condition. (not used by
{      this routine).
{
{    save_area: (input) This parameter points to the stack frame save area of the offending routine.
{      (not used by this routine).
{
{    status: (output) This parameter specifies the status at the time of the block exit.  This is passed
{      on, unaltered, to the next condition handler.

      VAR
          ignore_status : ost$status;

      amp$return(input_file, ignore_status);
      IF  (current_state > open_command_file)  OR
          ((current_state = open_command_file)  AND
           (open_command_file_status.normal))  THEN
        fsp$close_file(save_info.temporary_command_file_fid, ignore_status);
        amp$return(temporary_command_file, ignore_status);
      IFEND;
      IF  ((current_state = build_config_file)  AND
           (config_file_created_status.normal))  THEN
        delete_configuration_file(rfc$configuration_file, pfc$highest_cycle, ignore_status);
      IFEND;
      IF  (current_state > open_scratch_seg)  OR
          ((current_state = open_scratch_seg)  AND
           (open_scratch_seg_status.normal))  THEN
        fsp$close_file(save_info.temporary_fid, ignore_status);
        amp$return(temporary_file_lfn, ignore_status);
      IFEND;
      IF  (current_state > open_output_file)  OR
          ((current_state = open_output_file)  AND
           (open_output_file_status.normal))  THEN
        fsp$close_file(save_info.output_fid, ignore_status);
      IFEND;
      IF  (current_state > init_global_vars)  OR
          ((current_state = init_global_vars)  AND
           (init_global_vars_status.normal))  THEN
        rfp$release_config_pointers;
      IFEND;
      IF  (current_state > push_utility)  OR
          ((current_state = push_utility)  AND
           (push_utility_status.normal))  THEN
        clp$pop_utility(ignore_status);
      IFEND;
      pmp$continue_to_cause(pmc$execute_standard_procedure, status);
    PROCEND  clean_up_on_exit;
?? EJECT ??
    TYPE
        install_states = (initial, push_utility, init_global_vars, open_output_file, open_command_file,
                          open_scratch_seg, ready_to_scan, build_config_file, config_file_built);

    VAR
        block_exit: [STATIC,READ] pmt$condition :=
                   [pmc$condition_combination,$pmt$condition_combination[pmc$block_exit_processing]],
        exit_descriptor: pmt$established_handler,
        temporary_command_file: amt$local_file_name,
        temporary_file_lfn: amt$local_file_name,
        unique_name: ost$unique_name,
        input_file: amt$local_file_name,
        output_file: clt$value,
        attachment_options: ^fst$attachment_options,
        configuration_fid: amt$file_identifier,
        save_info: rft$config_utl_pointers,
        segment_ptr: amt$segment_pointer,
        current_state: install_states,
        push_utility_status,
        init_global_vars_status,
        open_output_file_status,
        open_scratch_seg_status,
        open_command_file_status,
        config_file_created_status,
        ignore_status: ost$status;

    status.normal := TRUE;
    current_state := initial;

  /main_section/
    BEGIN

      clp$scan_parameter_list(parameter_list, install_config_bin, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF NOT jmp$system_job() THEN
        osp$set_status_abnormal(rfc$product_id, rfe$invalid_task_origin, '', status);
        RETURN;
      IFEND;
      pmp$generate_unique_name(unique_name, ignore_status);
      temporary_command_file := unique_name.value;
      pmp$generate_unique_name(unique_name, ignore_status);
      temporary_file_lfn := unique_name.value;
      clp$get_value('error', 1, 1, clc$low, output_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      pmp$establish_condition_handler(block_exit, ^clean_up_on_exit, ^exit_descriptor, status);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
      pmp$generate_unique_name(unique_name, ignore_status);
      input_file := unique_name.value;
      attach_configuration_file(input_file, rfc$configuration_cmd_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      push_utility_status.normal := FALSE;
      #SPOIL(push_utility_status,current_state);
      current_state := push_utility;
      clp$push_utility(rfv$install_config_bin, clc$global_command_search, rfv$install_cmd_binary, nil,
                       push_utility_status);
      IF NOT push_utility_status.normal THEN
        status := push_utility_status;
        RETURN;
      IFEND;
      init_global_vars_status.normal := FALSE;
      #SPOIL(init_global_vars_status,current_state);
      current_state := init_global_vars;
      rfp$initialize_config_pointers(TRUE, save_info, init_global_vars_status);
      IF NOT init_global_vars_status.normal THEN
        status := init_global_vars_status;
        RETURN;
      IFEND;
      PUSH  attachment_options : [1..1];
      attachment_options^[1].selector := fsc$access_and_share_modes;
      attachment_options^[1].access_modes.selector := fsc$specific_access_modes;
      attachment_options^[1].access_modes.value :=
        $fst$file_access_options[fsc$append];
      attachment_options^[1].share_modes.selector := fsc$determine_from_access_modes;
      open_output_file_status.normal := FALSE;
      #SPOIL(open_output_file_status,current_state);
      current_state := open_output_file;
      fsp$open_file(output_file.file.local_file_name, amc$record, attachment_options, NIL, NIL,
        NIL, NIL, save_info.output_fid, open_output_file_status);
      IF NOT open_output_file_status.normal THEN
        status := open_output_file_status;
        RETURN;
      IFEND;
      attachment_options^[1].access_modes.value :=
        $fst$file_access_options[fsc$read, fsc$append, fsc$shorten];
      open_command_file_status.normal := FALSE;
      #SPOIL(open_command_file_status,current_state);
      current_state := open_command_file;
      fsp$open_file(temporary_command_file, amc$record, attachment_options, NIL, NIL,
         NIL, NIL, save_info.temporary_command_file_fid, open_command_file_status);
      IF NOT open_command_file_status.normal THEN
        status := open_command_file_status;
        RETURN;
      IFEND;
      open_scratch_seg_status.normal := FALSE;
      #SPOIL(open_scratch_seg_status,current_state);
      current_state := open_scratch_seg;
      fsp$open_file(temporary_file_lfn, amc$segment, attachment_options, NIL, NIL,
        NIL, NIL, save_info.temporary_fid, open_scratch_seg_status);
      IF NOT open_scratch_seg_status.normal THEN
        status := open_scratch_seg_status;
        RETURN;
      IFEND;
      current_state := ready_to_scan;
      amp$get_segment_pointer(save_info.temporary_fid, amc$sequence_pointer, segment_ptr, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      save_info.temporary_seq := segment_ptr.sequence_pointer;
      RESET save_info.temporary_seq;
      rfp$preserve_config_pointers(save_info);
      clp$scan_command_file(input_file, rfv$install_config_bin, 'IRCB', status);
      rfp$retrieve_config_pointers(save_info);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
      IF save_info.error_encountered THEN
        osp$set_status_abnormal(rfc$product_id, rfe$configuration_file_error, input_file,
                                status);
        osp$append_status_parameter(osc$status_parameter_delimiter, output_file.file.local_file_name,
                                    status);
        RETURN;
      IFEND;
      config_file_created_status.normal := FALSE;
      #SPOIL(config_file_created_status,current_state);
      current_state := build_config_file;
      create_the_status_table(save_info, config_file_created_status, status);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
      current_state := config_file_built;
    END /main_section/;

  PROCEND rfp$install_rhf_config_bin;
?? NEWTITLE := '    RFP$INSTALL_RHF_CONFIG_BIN DIRECTIVES' ??
?? EJECT ??
*copyc rfd$cdt_install_bin_directives
?? TITLE := '    RFP$IRB_QUIT'??
?? EJECT ??
  PROCEDURE rfp$irb_quit (parameter_list : clt$parameter_list;
                      VAR status : ost$status);
{
{    This procedure ends the install configuration binary utility environment.
{

{ pdt quit

?? PUSH (LISTEXT := ON) ??

  VAR
    quit: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??

    clp$scan_parameter_list(parameter_list, quit, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;

    clp$end_scan_command_file(rfv$install_config_bin, status);
  PROCEND rfp$irb_quit;
?? OLDTITLE ??
?? TITLE := '  CONFIGURATION COMMAND PROCESSORS' ??
?? NEWTITLE := '    RFP$DEFINE_LOCAL_HOST' ??
?? EJECT ??
  PROCEDURE rfp$define_local_host (parameter_list : clt$parameter_list;
                               VAR status : ost$status);

*copyc rfh$define_local_host

*copyc rfd$pdt_define_local_host

    VAR
        parameter_text: ^clt$parameter_list_text,
        save_info: rft$config_utl_pointers,
        physical_identifier,
        connection_password,
        subsystem_identifier,
        connection_timeout,
        data_transfer_timeout: clt$value,
        pid: rft$physical_identifier,
        logical_ids: ^ARRAY [1..*] OF rft$lids,
        number_of_lids: 0..clc$max_value_sets,
        local_host,
        lhost: ^rft$cu_local_host_entry,
        rhost: ^rft$cu_remote_host_entry,
        local_status: ost$status;

    status.normal := TRUE;
    rfp$retrieve_config_pointers(save_info);

  /main_section/
    BEGIN

      clp$get_parameter_list_text(^parameter_list, parameter_text, status);
      write_cmd_line('DEFLH', parameter_text^, save_info, status);
      clp$scan_parameter_list(parameter_list, define_local_host, local_status);
      IF  NOT local_status.normal  THEN
        IF  local_status.condition = cle$parameters_displayed  THEN
          RETURN;
        ELSE
          EXIT /main_section/;
        IFEND;
      IFEND;

      {   There may be only one local host definition.

      IF  save_info.local_host_defined  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$duplicate_local_host, '', local_status);
        EXIT /main_section/;
      IFEND;

      {    Each physical host identifier must be unique within a configuration file.

      clp$get_value('physical_identifier', 1, 1, clc$low, physical_identifier, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      #TRANSLATE(osv$lower_to_upper, physical_identifier.str.value(1,physical_identifier.str.size), pid);
      check_for_host_name_match(pid, csm_remote, NIL, save_info.remote_hosts, lhost, rhost);
      IF  (rhost <> NIL)  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$duplicate_component_name, pid, local_status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'HOST NAME',local_status);
        EXIT /main_section/;
      IFEND;
      clp$get_set_count('logical_identifiers', number_of_lids, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      IF  number_of_lids <> 0  THEN
        PUSH  logical_ids : [1..number_of_lids];
        get_logical_ids(logical_ids^, local_status);
        IF  NOT local_status.normal  THEN
          EXIT /main_section/;
        IFEND;
      IFEND;
      clp$get_value('connection_password', 1, 1, clc$low, connection_password, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      clp$get_value('subsystem_identifier', 1, 1, clc$low, subsystem_identifier, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      clp$get_value('connection_timeout', 1, 1, clc$low, connection_timeout, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      clp$get_value('data_transfer_timeout', 1, 1, clc$low, data_transfer_timeout, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;

      {   create temporary entry in the temporary sequence.

      NEXT  local_host : [1..number_of_lids]  IN  save_info.temporary_seq;
      IF  local_host = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'temporary sequence',
                                local_status);
        EXIT /main_section/;
      IFEND;

      local_host^.entry.physical_identifier := pid;
      local_host^.entry.connection_password :=
                   connection_password.name.value(1,connection_password.name.size);
      local_host^.entry.subsystem_identifier :=
                   subsystem_identifier.name.value(1,subsystem_identifier.name.size);
      local_host^.entry.connection_timeout := connection_timeout.int.value;
      local_host^.entry.data_transfer_timeout := data_transfer_timeout.int.value;
      IF  number_of_lids <> 0  THEN
        local_host^.entry.logical_identifiers := logical_ids^;
      IFEND;
      local_host^.entry.disabled := FALSE;
      local_host^.entry.associated_paths := NIL;
      local_host^.number_of_paths := 0;
      local_host^.paths := NIL;
      save_info.local_host := local_host;
      save_info.local_host_defined := true;

    END /main_section/;

    IF  NOT local_status.normal  THEN
      rfp$output_status_message(save_info.output_fid, local_status);
      save_info.error_encountered := TRUE;
    IFEND;

    rfp$preserve_config_pointers(save_info);

  PROCEND rfp$define_local_host;
?? TITLE := '    RFP$DEFINE_REMOTE_HOST' ??
?? EJECT ??
  PROCEDURE rfp$define_remote_host (parameter_list : clt$parameter_list;
                                VAR status : ost$status);

*copyc rfh$define_remote_host

*copyc rfd$pdt_define_remote_host

    VAR
        parameter_text: ^clt$parameter_list_text,
        save_info: rft$config_utl_pointers,
        physical_identifier: clt$value,
        pid: rft$physical_identifier,
        lhost: ^rft$cu_local_host_entry,
        rhost: ^rft$cu_remote_host_entry,
        logical_ids : ^ARRAY [1..*] OF rft$lids,
        number_of_lids: 0..clc$max_value_sets,
        remote_host: ^rft$cu_remote_host_entry,
        local_status: ost$status;

    status.normal := TRUE;
    rfp$retrieve_config_pointers(save_info);

  /main_section/
    BEGIN

      clp$get_parameter_list_text(^parameter_list, parameter_text, status);
      write_cmd_line('DEFRH', parameter_text^, save_info, status);
      clp$scan_parameter_list(parameter_list, define_remote_host, local_status);
      IF  NOT local_status.normal  THEN
        IF  local_status.condition = cle$parameters_displayed  THEN
          RETURN;
        ELSE
          EXIT /main_section/;
        IFEND;
      IFEND;

     {    Each physical host identifier must be unique within a configuration file.

      clp$get_value('physical_identifier', 1, 1, clc$low, physical_identifier, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      #TRANSLATE(osv$lower_to_upper, physical_identifier.str.value(1,physical_identifier.str.size), pid);
      check_for_host_name_match(pid, csm_both, save_info.local_host, save_info.remote_hosts, lhost, rhost);
      IF  (lhost <> NIL)  OR  (rhost <> NIL)  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$duplicate_component_name, pid, local_status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'HOST NAME',local_status);
        EXIT /main_section/;
      IFEND;
      clp$get_set_count('logical_identifiers', number_of_lids, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      IF  number_of_lids <> 0  THEN
        PUSH  logical_ids : [1..number_of_lids];
        get_logical_ids(logical_ids^, local_status);
        IF  NOT local_status.normal  THEN
          EXIT /main_section/;
        IFEND;
      IFEND;

      {   create temporary entry in the temporary sequence.

      NEXT  remote_host : [1..number_of_lids]  IN  save_info.temporary_seq;
      IF  remote_host = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'temporary sequence',
                                local_status);
        EXIT /main_section/;
      IFEND;
      remote_host^.entry.physical_identifier := pid;
      IF  number_of_lids <> 0  THEN
        remote_host^.entry.logical_identifiers := logical_ids^;
      IFEND;
      remote_host^.number_of_paths := 0;
      remote_host^.paths := NIL;
      remote_host^.entry.disabled := FALSE;
      remote_host^.entry.associated_paths := NIL;

      {  place the new entry at the head of the temporary list.

      save_info.remote_host_count := save_info.remote_host_count + 1;
      remote_host^.index := save_info.remote_host_count;
      remote_host^.next_entry := save_info.remote_hosts;
      save_info.remote_hosts := remote_host;

    END /main_section/;

    IF  NOT local_status.normal  THEN
      rfp$output_status_message(save_info.output_fid, local_status);
      save_info.error_encountered := true;
    IFEND;

    rfp$preserve_config_pointers(save_info);

  PROCEND rfp$define_remote_host;
?? TITLE := '    RFP$DEFINE_LOCAL_NAD' ??
?? EJECT ??
  PROCEDURE rfp$define_local_nad (parameter_list : clt$parameter_list;
                              VAR status : ost$status);

*copyc rfh$define_local_nad

*copyc rfd$pdt_define_local_nad
    VAR
        parameter_text: ^clt$parameter_list_text,
        trunk_control_units: rft$trunk_control_units,
        tcu_access_codes: rft$nad_access_codes,
        nad_name: rft$component_name,
        nad_address: rft$nad_address,
        save_info: rft$config_utl_pointers,
        perform_auto_reload,
        reload_threshold,
        dump_disposition,
        maximum_connections,
        maximum_nad_entries,
        send_queue_limit,
        receive_queue_limit,
        monitor_trace,
        trunk_trace,
        device_trace,
        pp_drivers: clt$value,
        dump_disp: rft$dump_disposition,
        tcu_index: rfc$min_tcu..rfc$max_tcu,
        matching_local_nad: ^rft$cu_local_nad_entry,
        matching_remote_nad: ^rft$cu_remote_nad_entry,
        local_nad: ^rft$cu_local_nad_entry,
        local_status: ost$status;


    status.normal := TRUE;
    rfp$retrieve_config_pointers(save_info);

  /main_section/
    BEGIN

      clp$get_parameter_list_text(^parameter_list, parameter_text, status);
      write_cmd_line('DEFLN', parameter_text^, save_info, status);
      clp$scan_parameter_list(parameter_list, define_local_nad, local_status);
      IF  NOT local_status.normal  THEN
        IF  local_status.condition = cle$parameters_displayed  THEN
          RETURN;
        ELSE
          EXIT /main_section/;
        IFEND;
      IFEND;

      obtain_common_nad_params(save_info, nad_name, nad_address, trunk_control_units, tcu_access_codes,
        local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;

      clp$get_value('pp_drivers', 1, 1, clc$low, pp_drivers, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;

      clp$get_value('perform_auto_reload', 1, 1, clc$low, perform_auto_reload, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      clp$get_value('reload_threshold', 1, 1, clc$low, reload_threshold, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      clp$get_value('dump_disposition', 1, 1, clc$low, dump_disposition, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      convert_dump_disposition(dump_disposition.name.value(1,dump_disposition.name.size), dump_disp,
                               local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      clp$get_value('maximum_connections', 1, 1, clc$low, maximum_connections, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      clp$get_value('maximum_nad_entries', 1, 1, clc$low, maximum_nad_entries, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      clp$get_value('send_queue_limit', 1, 1, clc$low, send_queue_limit, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      clp$get_value('receive_queue_limit', 1, 1, clc$low, receive_queue_limit, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      clp$get_value('monitor_trace', 1, 1, clc$low, monitor_trace, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      clp$get_value('trunk_trace', 1, 1, clc$low, trunk_trace, local_status);
      IF  NOT local_status.normal  THEN
        RETURN;
      IFEND;
      clp$get_value('device_trace', 1, 1, clc$low, device_trace, local_status);
      IF  NOT local_status.normal  THEN
        RETURN;
      IFEND;

      {   create temporary entry in the temporary sequence.

      NEXT  local_nad  IN  save_info.temporary_seq;
      IF  local_nad = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'temporary sequence',
                                local_status);
        EXIT /main_section/;
      IFEND;

      {   Zero out the table so that the miscellaneous counters do not have to be initialized.

      pmp$zero_out_table(local_nad, #SIZE(rft$cu_local_nad_entry));

      local_nad^.entry.name := nad_name;
      local_nad^.entry.defined_address := nad_address;
      local_nad^.entry.address := nad_address;
      local_nad^.entry.pp_drivers := pp_drivers.int.value;
      FOR  tcu_index := rfc$min_tcu  TO  rfc$max_tcu  DO
        local_nad^.entry.trunk_control_units[tcu_index] := trunk_control_units[tcu_index];
        local_nad^.entry.access_codes[tcu_index] := tcu_access_codes[tcu_index];
      FOREND;
      local_nad^.entry.maintenance_selections.perform_auto_reload := perform_auto_reload.bool.value;
      local_nad^.entry.maintenance_selections.reload_threshold := reload_threshold.int.value;
      local_nad^.entry.maintenance_selections.dump_disposition := dump_disp;
      local_nad^.entry.maintenance_selections.load_parameters.maximum_connections :=
                   maximum_connections.int.value;
      local_nad^.entry.maintenance_selections.load_parameters.maximum_nad_entries :=
                   maximum_nad_entries.int.value;
      local_nad^.entry.maintenance_selections.load_parameters.send_queue_limit :=
                   send_queue_limit.int.value;
      local_nad^.entry.maintenance_selections.load_parameters.receive_queue_limit :=
                   receive_queue_limit.int.value;
      local_nad^.entry.maintenance_selections.load_parameters.monitor_trace :=
                   monitor_trace.int.value;
      local_nad^.entry.maintenance_selections.load_parameters.device_trace :=
                   device_trace.int.value;
      local_nad^.entry.maintenance_selections.load_parameters.trunk_trace :=
                   trunk_trace.int.value;

      {  place the new entry at the head of the temporary list.

      save_info.local_nad_count := save_info.local_nad_count  + 1;
      IF  save_info.local_nad_count > rfc$max_local_nads  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'local nad table',
                                local_status);
        EXIT /main_section/;
      IFEND;
      local_nad^.index := save_info.local_nad_count;
      local_nad^.next_entry := save_info.local_nads;
      save_info.local_nads := local_nad;

    END /main_section/;

    IF  NOT local_status.normal  THEN
      rfp$output_status_message(save_info.output_fid, local_status);
      save_info.error_encountered := true;
    IFEND;

    rfp$preserve_config_pointers(save_info);

  PROCEND rfp$define_local_nad;
?? TITLE := '    RFP$DEFINE_REMOTE_NAD' ??
?? EJECT ??
  PROCEDURE  rfp$define_remote_nad (parameter_list : clt$parameter_list;
                                VAR status : ost$status);

*copyc rfh$define_remote_nad

*copyc rfd$pdt_define_remote_nad

    VAR
        parameter_text: ^clt$parameter_list_text,
        trunk_control_units: rft$trunk_control_units,
        tcu_access_codes: rft$nad_access_codes,
        nad_name: rft$component_name,
        nad_address: rft$nad_address,
        connected_to_host: BOOLEAN,
        save_info: rft$config_utl_pointers,
        lhost: ^rft$cu_local_host_entry,
        rhost: ^rft$cu_remote_host_entry,
        the_parameter_is_specified: boolean,
        remote_nad: ^rft$cu_remote_nad_entry,
        microcode_type,
        inter_network_link,
        host_connection,
        logical_network: clt$value,
        host_connections: rft$host_connections,
        mc_type: rft$microcode_types,
        tcu_index: rfc$min_tcu..rfc$max_tcu,
        host_index: rfc$min_host_connect..rfc$max_host_connect,
        local_status: ost$status;

    status.normal := TRUE;
    rfp$retrieve_config_pointers(save_info);

  /main_section/
    BEGIN

      clp$get_parameter_list_text(^parameter_list, parameter_text, status);
      write_cmd_line('DEFRN', parameter_text^, save_info, status);
      clp$scan_parameter_list(parameter_list, define_remote_nad, local_status);
      IF  NOT local_status.normal  THEN
        IF  local_status.condition = cle$parameters_displayed  THEN
          RETURN;
        ELSE
          EXIT /main_section/;
        IFEND;
      IFEND;

      obtain_common_nad_params(save_info, nad_name, nad_address, trunk_control_units, tcu_access_codes,
        local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;

      clp$get_value('nad_type', 1, 1, clc$low, microcode_type, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      convert_microcode_type(microcode_type.name.value(1,microcode_type.name.size), mc_type,
                               local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;

      connected_to_host := FALSE;
      IF  (mc_type = rfc$mc_type_ntn)  OR  (mc_type = rfc$mc_type_inet)  THEN
        FOR  host_index := rfc$min_host_connect  TO  rfc$max_host_connect  DO
          host_connections[host_index] := '';     {  There cannot be a host directly connected to this NAD }
        FOREND;
        connected_to_host := TRUE;
      ELSE

        {   Obtaining the host connections is similar to the process required for obtaining the
        {   trunk connections.  See comment in routine OBTAIN_COMMON_NAD_PARAMETERS.

        clp$test_parameter('host_connection_0', the_parameter_is_specified, local_status);
        IF  the_parameter_is_specified  THEN
          clp$get_value('host_connection_0', 1, 1, clc$low, host_connection, local_status);
          IF  NOT local_status.normal  THEN
            EXIT /main_section/;
          IFEND;
          #TRANSLATE(osv$lower_to_upper, host_connection.str.value(1,host_connection.str.size),
            host_connections[rfc$min_host_connect]);
          connected_to_host := TRUE;
        ELSE

          {  If a host connection is not attached to a host, then the host connection entry must be set
          {  to the NIL string to prevent erroneous operations when referencing this entity.

          host_connections[rfc$min_host_connect] := '';
        IFEND;
        IF  mc_type <> rfc$mc_type_vax  THEN
          FOR  host_index := (rfc$min_host_connect + 1)  TO  rfc$max_host_connect  DO
            host_connections[host_index] := '';     {  Only host connection 0 is used on non-VAX NADS }
          FOREND;
        ELSE
          clp$test_parameter('host_connection_1', the_parameter_is_specified, local_status);
          IF  the_parameter_is_specified  THEN
            clp$get_value('host_connection_1', 1, 1, clc$low, host_connection, local_status);
            IF  NOT local_status.normal  THEN
              EXIT /main_section/;
            IFEND;
            #TRANSLATE(osv$lower_to_upper, host_connection.str.value(1,host_connection.str.size),
              host_connections[rfc$min_host_connect + 1]);
            connected_to_host := TRUE;
          ELSE
            host_connections[rfc$min_host_connect + 1] := '';
          IFEND;
          clp$test_parameter('host_connection_2', the_parameter_is_specified, local_status);
          IF  the_parameter_is_specified  THEN
            clp$get_value('host_connection_2', 1, 1, clc$low, host_connection, local_status);
            IF  NOT local_status.normal  THEN
              EXIT /main_section/;
            IFEND;
            #TRANSLATE(osv$lower_to_upper, host_connection.str.value(1,host_connection.str.size),
              host_connections[rfc$min_host_connect + 2]);
            connected_to_host := TRUE;
          ELSE
            host_connections[rfc$min_host_connect + 2] := '';
          IFEND;
          clp$test_parameter('host_connection_3', the_parameter_is_specified, local_status);
          IF  the_parameter_is_specified  THEN
            clp$get_value('host_connection_3', 1, 1, clc$low, host_connection, local_status);
            IF  NOT local_status.normal  THEN
              EXIT /main_section/;
            IFEND;
            #TRANSLATE(osv$lower_to_upper, host_connection.str.value(1,host_connection.str.size),
              host_connections[rfc$min_host_connect + 3]);
            connected_to_host := TRUE;
          ELSE
            host_connections[rfc$min_host_connect + 3] := '';
          IFEND;
        IFEND;
      IFEND;

      IF  NOT connected_to_host  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$required_def_missing,
          'HOST CONNECTION per REMOTE NAD', local_status);
        EXIT /main_section/;
      IFEND;

      {   Verify that the NAD is connected to a known remote host.

      FOR  host_index := rfc$min_host_connect  TO  rfc$max_host_connect  DO
        IF  host_connections[host_index] <> ''  THEN
          check_for_host_name_match(host_connections[host_index], csm_remote, NIL, save_info.remote_hosts,
            lhost, rhost);
          IF  rhost = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$invalid_host_connection, '', local_status);
            osp$append_status_integer(osc$status_parameter_delimiter, host_index, 10, FALSE,
                                      local_status);
            osp$append_status_parameter(osc$status_parameter_delimiter, nad_name, local_status);
            EXIT /main_section/;
          IFEND;
        IFEND;
      FOREND;

      {   create temporary entry in the temporary sequence.

      NEXT  remote_nad  IN  save_info.temporary_seq;
      IF  remote_nad = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'temporary sequence',
                                local_status);
        EXIT /main_section/;
      IFEND;

      {   Zero out the table so that the miscellaneous counters do not have to be initialized.

      pmp$zero_out_table(remote_nad, #SIZE(rft$cu_remote_nad_entry));

      remote_nad^.entry.name := nad_name;
      remote_nad^.entry.address := nad_address;
      FOR  tcu_index := rfc$min_tcu  TO  rfc$max_tcu  DO
        remote_nad^.entry.trunk_control_units[tcu_index] := trunk_control_units[tcu_index];
        remote_nad^.entry.access_codes[tcu_index] := tcu_access_codes[tcu_index];
      FOREND;
      FOR  host_index := rfc$min_host_connect  TO  rfc$max_host_connect  DO
        remote_nad^.entry.host_connections[host_index] := host_connections[host_index];
      FOREND;
      remote_nad^.entry.microcode_type := mc_type;

      {  place the new entry at the head of the temporary list.

      save_info.remote_nad_count := save_info.remote_nad_count  + 1;
      remote_nad^.index := save_info.remote_nad_count;
      remote_nad^.next_entry := save_info.remote_nads;
      save_info.remote_nads := remote_nad;

    END /main_section/;

    IF  NOT local_status.normal  THEN
      rfp$output_status_message(save_info.output_fid, local_status);
      save_info.error_encountered := true;
    IFEND;

    rfp$preserve_config_pointers(save_info);

   PROCEND rfp$define_remote_nad;
?? TITLE := '    RFP$DEFINE_LCN_PATH' ??
?? EJECT ??
  PROCEDURE rfp$define_lcn_path (parameter_list: clt$parameter_list;
                             VAR status : ost$status);

*copyc rfh$define_lcn_path

*copyc rfd$pdt_define_lcn_path

    VAR
        parameter_text: ^clt$parameter_list_text,
        save_info: rft$config_utl_pointers,
        local_nad,
        remote_nad,
        host_connection,
        logical_nad,
        logical_network,
        excluded_trunk,
        physical_identifier,
        access_code : clt$value,
        the_parameter_is_specified : boolean,
        log_network : rft$logical_network,
        log_nad : rft$logical_nad,
        host_connection_index : rfc$min_host_connect..rfc$max_host_connect,
        lcn_path : ^rft$cu_lcn_path_entry,
        set_count : 0..clc$max_value_sets,
        number_of_excluded_trunks : 0..3,
        excluded_trunks : ARRAY [1..3] OF rft$component_name,
        index : integer,
        ltcu,
        rtcu : rfc$min_tcu..rfc$max_tcu,
        ltcu_connection,
        rtcu_connection : rft$tcu_mask,
        lhost : ^rft$cu_local_host_entry,
        rhost : ^rft$cu_remote_host_entry,
        lnad_1, lnad_2 : ^rft$cu_local_nad_entry,
        rnad_1, rnad_2 : ^rft$cu_remote_nad_entry,
        pid : rft$physical_identifier,
        lnad_name,
        rnad_name : rft$component_name,
        trunk_match : boolean,
        local_status : ost$status;


    status.normal := TRUE;
    rfp$retrieve_config_pointers(save_info);

  /main_section/
    BEGIN

      clp$get_parameter_list_text(^parameter_list, parameter_text, status);
      write_cmd_line('DEFLP', parameter_text^, save_info, status);
      clp$scan_parameter_list(parameter_list, define_lcn_path, local_status);
      IF  NOT local_status.normal  THEN
        IF  local_status.condition = cle$parameters_displayed  THEN
          RETURN;
        ELSE
          EXIT /main_section/;
        IFEND;
      IFEND;

      save_info.deflp_encountered := TRUE;

      clp$get_value('logical_network', 1, 1, clc$low, logical_network, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      clp$get_value('logical_nad', 1, 1, clc$low, logical_nad, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;

      clp$get_set_count('exclude_trunk', set_count, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      number_of_excluded_trunks := set_count;
      FOR  index := 1  TO  number_of_excluded_trunks  DO
        clp$get_value('exclude_trunk', index, 1, clc$low, excluded_trunk, local_status);
        IF  NOT local_status.normal  THEN
          EXIT /main_section/;
        IFEND;
        excluded_trunks[index] := excluded_trunk.name.value(1,excluded_trunk.name.size);
      FOREND;

      FOR  index := (number_of_excluded_trunks + 1)  TO  3  DO
        excluded_trunks[index] := '';   { clear out any unused entries  }
      FOREND;

      clp$get_value('access_code', 1, 1, clc$low, access_code, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;

      clp$get_value('host_connection', 1, 1, clc$low, host_connection, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      host_connection_index := host_connection.int.value;

      {   The local NAD defined for this path must have been defined in this configuration file.

      clp$get_value('local_nad', 1, 1, clc$low, local_nad, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      lnad_name := local_nad.name.value(1,local_nad.name.size);
      check_for_nad_name_match(lnad_name, csm_local, save_info.local_nads, save_info.remote_nads,
        lnad_1, rnad_1);
      IF  lnad_1 = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$undefined_path_element, lnad_name, local_status);
        EXIT /main_section/;
      IFEND;

      {   The remote NAD defined for this path must have been previously defined in this
      {   configuration.
      {
      {   NOTE - the remote NAD can be either a local (i.e. loop-back path) or a remote NAD.

      clp$get_value('remote_nad', 1, 1, clc$low, remote_nad, local_status);
      IF  NOT local_status.normal  THEN
        EXIT /main_section/;
      IFEND;
      rnad_name := remote_nad.name.value(1,remote_nad.name.size);
      check_for_nad_name_match(rnad_name, csm_both, save_info.local_nads, save_info.remote_nads,
        lnad_2, rnad_2);
      IF  (lnad_2 = NIL)  AND  (rnad_2 = NIL)  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$undefined_path_element, rnad_name, local_status);
        EXIT /main_section/;
      IFEND;

      IF  (lnad_2 <> NIL)  THEN

        {   If the remote NAD is a local NAD then the path is a loopback path  }

        IF  NOT save_info.local_host_defined  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$undefined_path_element, 'LOCAL HOST', local_status);
          EXIT /main_section/;
        IFEND;
        lhost := save_info.local_host;
        rhost := NIL;
        host_connection_index := rfc$min_host_connect;  {  all VE NADs only have host connection zero  }
        log_network := rfc$min_logical_network;
        log_nad := rfc$min_logical_nad;
      ELSE
        IF  (rnad_2^.entry.microcode_type = rfc$mc_type_ntn)
            OR  (rnad_2^.entry.microcode_type = rfc$mc_type_inet)  THEN

          {   If the remote NAD is an NTN or an INET NAD then the physical identifier is needed to
          {   determine the destination host.

          clp$test_parameter('host_connection', the_parameter_is_specified, local_status);
          IF  the_parameter_is_specified  THEN
            clp$get_value('physical_identifier', 1, 1, clc$low, physical_identifier, local_status);
            IF  NOT local_status.normal  THEN
              EXIT /main_section/;
            IFEND;
            pid := physical_identifier.name.value(1,physical_identifier.name.size);
            check_for_host_name_match(pid, csm_both, save_info.local_host, save_info.remote_hosts,
              lhost, rhost);
            IF  (lhost = NIL)  AND  (rhost = NIL)  THEN
              osp$set_status_abnormal(rfc$product_id, rfe$undefined_path_element, pid, local_status);
              EXIT /main_section/;
            IFEND;
          ELSE
            osp$set_status_abnormal(rfc$product_id, rfe$physical_id_required, '', local_status);
            EXIT /main_section/;
          IFEND;
          log_network := logical_network.int.value;
          log_nad := logical_nad.int.value;

        ELSE
          IF  rnad_2^.entry.microcode_type <> rfc$mc_type_vax  THEN

            {  IF the destination NAD is not a VAX NAD, then the host connection must be zero.

            host_connection_index := rfc$min_host_connect;
          IFEND;

          {   Verify that the host connection specified by the user is valid.

          log_network := rfc$min_logical_network;
          log_nad := rfc$min_logical_nad;
          pid := rnad_2^.entry.host_connections[host_connection_index];
          check_for_host_name_match(pid, csm_remote, NIL, save_info.remote_hosts, lhost, rhost);

          {   Note - 'lhost' must be NIL after a call to the above routine.

          IF  rhost = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$invalid_host_connection, '', local_status);
            osp$append_status_integer(osc$status_parameter_delimiter, host_connection_index, 10, FALSE,
                                      local_status);
            osp$append_status_parameter(osc$status_parameter_delimiter, rnad_name, local_status);
            EXIT /main_section/;
          IFEND;
        IFEND;
      IFEND;

      {   Determine which, if any, trunks are common between the two NADs.

      IF  lnad_2 <> NIL  THEN         {  local NAD to local NAD connection  }
        determine_common_trunks(lnad_1^.entry.trunk_control_units, lnad_2^.entry.trunk_control_units,
          lnad_1^.entry.access_codes, lnad_2^.entry.access_codes, access_code.int.value, excluded_trunks,
          ltcu_connection, rtcu_connection, trunk_match);

      ELSE         {   local NAD to remote NAD connection  }

        determine_common_trunks(lnad_1^.entry.trunk_control_units, rnad_2^.entry.trunk_control_units,
          lnad_1^.entry.access_codes, rnad_2^.entry.access_codes, access_code.int.value, excluded_trunks,
          ltcu_connection, rtcu_connection, trunk_match);
      IFEND;

      IF  NOT trunk_match  AND          {  no matching trunks  }
          (lnad_1 <> lnad_2)  THEN      {  and not looping back through the same NAD  }
        osp$set_status_abnormal(rfc$product_id, rfe$no_trunk_match, lnad_name, local_status);
        osp$append_status_parameter(osc$status_parameter_delimiter, rnad_name, local_status);
        EXIT /main_section/;
      IFEND;

      {   create temporary entry in the temporary sequence.

      NEXT  lcn_path  IN  save_info.temporary_seq;
      IF  lcn_path = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'temporary sequence',
                                local_status);
        EXIT /main_section/;
      IFEND;
      pmp$zero_out_table(lcn_path, #SIZE(rft$lcn_path_definition));
      lcn_path^.entry.local_nad := lnad_1^.index;
      IF  lnad_2 <> NIL  THEN
        lcn_path^.entry.loopback := TRUE;
        lcn_path^.entry.destination_nad := lnad_2^.index;
      ELSE
        lcn_path^.entry.loopback := FALSE;
        lcn_path^.entry.remote_nad := rnad_2^.index;
      IFEND;
      lcn_path^.entry.access_code := access_code.int.value;
      lcn_path^.entry.logical_network := logical_network.int.value;
      lcn_path^.entry.logical_nad := logical_nad.int.value;
      lcn_path^.entry.destination_device := host_connection_index;
      lcn_path^.entry.local_tcu_mask := ltcu_connection;
      lcn_path^.entry.remote_tcu_mask := rtcu_connection;

      {   Link the path entry into the corresponding host entry.

      IF  lnad_2 <> NIL  THEN
        lhost^.number_of_paths := lhost^.number_of_paths + 1;
        lcn_path^.next_entry := lhost^.paths;
        lhost^.paths := lcn_path;
      ELSE
        rhost^.number_of_paths := rhost^.number_of_paths + 1;
        lcn_path^.next_entry := rhost^.paths;
        rhost^.paths := lcn_path;
      IFEND;
    END /main_section/;

    IF  NOT local_status.normal  THEN
      rfp$output_status_message(save_info.output_fid, local_status);
      save_info.error_encountered := true;
    IFEND;

    rfp$preserve_config_pointers(save_info);

  PROCEND rfp$define_lcn_path;
?? TITLE := '    RFP$AUTO_PATH_GENERATION' ??
?? EJECT ??
  PROCEDURE  rfp$auto_path_generation (parameter_list : clt$parameter_list;
                                   VAR status : ost$status);

*copyc rfh$auto_path_generation

*copyc rfd$pdt_auto_path_generation

    VAR
        parameter_text: ^clt$parameter_list_text,
        save_info: rft$config_utl_pointers,
        lnad_1, lnad_2: ^rft$cu_local_nad_entry,
        rnad_2: ^rft$cu_remote_nad_entry,
        ltcu_mask, rtcu_mask: rft$tcu_mask,
        lhost: ^rft$cu_local_host_entry,
        rhost: ^rft$cu_remote_host_entry,
        excluded_trunks: ARRAY [1..3] OF rft$component_name,
        default_access_code: rft$nad_access_code,
        exclude_index: 1 .. 3,
        tcu_index: rfc$min_tcu .. rfc$max_tcu,
        host_index: rfc$min_host_connect .. rfc$max_host_connect,
        lcn_path: ^rft$cu_lcn_path_entry,
        match_found: boolean,
        local_status: ost$status;


    status.normal := TRUE;
    rfp$retrieve_config_pointers(save_info);

  /main_section/
    BEGIN

      clp$get_parameter_list_text(^parameter_list, parameter_text, status);
      write_cmd_line('AUTPG', parameter_text^, save_info, status);
      clp$scan_parameter_list(parameter_list, auto_path_generation, local_status);
      IF  NOT local_status.normal  THEN
        IF  local_status.condition = cle$parameters_displayed  THEN
          RETURN;
        ELSE
          EXIT /main_section/;
        IFEND;
      IFEND;

      IF  save_info.autpg_encountered  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$duplicate_autpg, '', local_status);
        EXIT /main_section/;
      IFEND;

      IF  save_info.deflp_encountered  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$autpg_after_deflp, '', local_status);
        EXIT /main_section/;
      IFEND;

      save_info.autpg_encountered := TRUE;

      FOR  exclude_index := 1  TO  3  DO
        excluded_trunks[exclude_index] := '';
      FOREND;


      lnad_1 := save_info.local_nads;
      WHILE  lnad_1 <> NIL  DO

        default_access_code := 0;
      /find_access_code/
        FOR  tcu_index := rfc$min_tcu  TO  rfc$max_tcu  DO
          IF  lnad_1^.entry.trunk_control_units[tcu_index] <> ''  THEN
            default_access_code := lnad_1^.entry.access_codes[tcu_index];
            EXIT /find_access_code/;
          IFEND;
        FOREND /find_access_code/;

        IF  save_info.local_host_defined  THEN
          lnad_2 := save_info.local_nads;
          WHILE  lnad_2 <> NIL  DO
            determine_common_trunks(lnad_1^.entry.trunk_control_units, lnad_2^.entry.trunk_control_units,
                lnad_1^.entry.access_codes, lnad_2^.entry.access_codes, default_access_code,
                excluded_trunks, ltcu_mask, rtcu_mask, match_found);
            IF  (match_found) OR
                (lnad_1 = lnad_2)  THEN

              {   create temporary entry in the temporary sequence.

              NEXT  lcn_path  IN  save_info.temporary_seq;
              IF  lcn_path = NIL  THEN
                osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'temporary sequence',
                                        local_status);
                EXIT /main_section/;
              IFEND;

              pmp$zero_out_table(lcn_path, #SIZE(rft$lcn_path_definition));
              lcn_path^.entry.local_nad := lnad_1^.index;
              lcn_path^.entry.loopback := TRUE;
              lcn_path^.entry.destination_nad := lnad_2^.index;
              lcn_path^.entry.access_code := default_access_code;
              lcn_path^.entry.logical_network := rfc$min_logical_network;
              lcn_path^.entry.logical_nad := rfc$min_logical_nad;
              lcn_path^.entry.destination_device := rfc$min_host_connect;
              lcn_path^.entry.local_tcu_mask := ltcu_mask;
              lcn_path^.entry.remote_tcu_mask := rtcu_mask;

              {   Link the path entry into the local host entry.

              save_info.local_host^.number_of_paths := save_info.local_host^.number_of_paths + 1;
              lcn_path^.next_entry := save_info.local_host^.paths;
              save_info.local_host^.paths := lcn_path;
            IFEND;
            lnad_2 := lnad_2^.next_entry;
          WHILEND;
        IFEND;

        rnad_2 := save_info.remote_nads;
        WHILE  rnad_2 <> NIL  DO
          IF (rnad_2^.entry.microcode_type <> rfc$mc_type_ntn) AND
             (rnad_2^.entry.microcode_type <> rfc$mc_type_inet) THEN

            {      only local area network paths are created      }

            determine_common_trunks(lnad_1^.entry.trunk_control_units, rnad_2^.entry.trunk_control_units,
                lnad_1^.entry.access_codes, rnad_2^.entry.access_codes, default_access_code,
                excluded_trunks, ltcu_mask, rtcu_mask, match_found);

            IF  match_found  THEN

              FOR  host_index := rfc$min_host_connect  TO  rfc$max_host_connect  DO

                IF  rnad_2^.entry.host_connections[host_index] <> ''  THEN
                  check_for_host_name_match(rnad_2^.entry.host_connections[host_index], csm_remote, NIL,
                    save_info.remote_hosts, lhost, rhost);
                  IF  rhost = NIL  THEN
                    osp$set_status_abnormal(rfc$product_id, rfe$invalid_host_connection, '', local_status);
                    osp$append_status_integer(osc$status_parameter_delimiter, host_index, 10, FALSE,
                                              local_status);
                    osp$append_status_parameter(osc$status_parameter_delimiter, rnad_2^.entry.name,
                                                local_status);
                    EXIT /main_section/;
                  IFEND;

                  {   create temporary entry in the temporary sequence.

                  NEXT  lcn_path  IN  save_info.temporary_seq;
                  IF  lcn_path = NIL  THEN
                    osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow,
                                            'temporary sequence', local_status);
                    EXIT /main_section/;
                  IFEND;

                  pmp$zero_out_table(lcn_path, #SIZE(rft$lcn_path_definition));
                  lcn_path^.entry.local_nad := lnad_1^.index;
                  lcn_path^.entry.loopback := FALSE;
                  lcn_path^.entry.remote_nad := rnad_2^.index;
                  lcn_path^.entry.access_code := default_access_code;
                  lcn_path^.entry.logical_network := rfc$min_logical_network;
                  lcn_path^.entry.logical_nad := rfc$min_logical_nad;
                  lcn_path^.entry.destination_device := host_index;
                  lcn_path^.entry.local_tcu_mask := ltcu_mask;
                  lcn_path^.entry.remote_tcu_mask := rtcu_mask;

                  {   Link the path entry into the corresponding remote host entry.

                  rhost^.number_of_paths := rhost^.number_of_paths + 1;
                  lcn_path^.next_entry := rhost^.paths;
                  rhost^.paths := lcn_path;
                IFEND;
              FOREND;
            IFEND;
          IFEND;
          rnad_2 := rnad_2^.next_entry;
        WHILEND;
        lnad_1 := lnad_1^.next_entry;
      WHILEND;
    END /main_section/;

    IF  NOT local_status.normal  THEN
      rfp$output_status_message(save_info.output_fid, local_status);
      save_info.error_encountered := true;
    IFEND;

    rfp$preserve_config_pointers(save_info);

  PROCEND rfp$auto_path_generation;
?? OLDTITLE ??
?? TITLE := '  MISCELLANEOUS ROUTINES' ??
?? NEWTITLE := '    CHECK_FOR_HOST_NAME_MATCH' ??
?? EJECT ??
  PROCEDURE check_for_host_name_match (physical_identifier: rft$physical_identifier;
                                       search_mode: configuration_search_modes;
                                       local_host: ^rft$cu_local_host_entry;
                                       remote_hosts: ^rft$cu_remote_host_entry;
                                   VAR local_host_match: ^rft$cu_local_host_entry;
                                   VAR remote_host_match: ^rft$cu_remote_host_entry);

{    The purpose of this routine is to determine whether or not a host has been defined with
{    the specified physical identifier.
{
{    physical_identifer: (input) This parameter specifies the 3-character host identifier,
{      which must be unique within a configuration file.
{
{    search_mode: (input) This parameter specifies which tables are to be searched to find
{      the specified host.  The caller may search the local host table, remote host table,
{      or both of the tables.  (note - the local host table can only have one entry)
{
{    local_host_match: (output) This parameter points to the matching local host entry.
{      If NIL, then the local host entries' physical identifier did not match the
{      specified physical identifier.
{
{    remote_host_match: (output) This parameter points to the matching remote host entry.
{      If NIL, then none of the remote host entries' physical identifiers matched the
{      specified physical identifier.


    VAR
        remote_host : ^rft$cu_remote_host_entry;

    local_host_match := NIL;
    remote_host_match := NIL;

    IF  (local_host <> NIL)
        AND ((search_mode = csm_local)  OR  (search_mode = csm_both))  THEN
      IF  local_host^.entry.physical_identifier = physical_identifier  THEN
        local_host_match := local_host;
        RETURN;
      IFEND;
    IFEND;

    IF  (search_mode = csm_remote)  OR  (search_mode = csm_both)  THEN
      remote_host := remote_hosts;
      WHILE  remote_host <> NIL  DO
        IF  remote_host^.entry.physical_identifier = physical_identifier  THEN
          remote_host_match := remote_host;
          RETURN;
        IFEND;
        remote_host := remote_host^.next_entry;
      WHILEND;
    IFEND;

  PROCEND check_for_host_name_match;
?? TITLE := '    CHECK_FOR_NAD_NAME_MATCH' ??
?? EJECT ??
  PROCEDURE check_for_nad_name_match (nad_name: rft$component_name;
                                      search_mode: configuration_search_modes;
                                      local_nads: ^rft$cu_local_nad_entry;
                                      remote_nads: ^rft$cu_remote_nad_entry;
                                  VAR local_nad_match: ^rft$cu_local_nad_entry;
                                  VAR remote_nad_match: ^rft$cu_remote_nad_entry);

{    The purpose of this routine is to determine whether or not a nad has been defined with
{    the specified nad name.
{
{    nad_name: (input) This parameter specifies the element name of the local NAD,
{      which must be unique within a configuration file.
{
{    search_mode: (input) This parameter specifies which tables are to be searched to find
{      the specified host.  The caller may search the local nad table, remote nad table,
{      or both of the tables.
{
{    local_nad_match: (output) This parameter points to the matching local nad entry.
{      If NIL, then none of the defined local NAD entries have a matching nad_name.
{
{    remote_nad_match: (output) This parameter points to the matching remote nad entry.
{      If NIL, then none of the defined remote nad entries have a matching nad_name.


    VAR
        remote_nad : ^rft$cu_remote_nad_entry,
        local_nad : ^rft$cu_local_nad_entry;

    local_nad_match := NIL;
    remote_nad_match := NIL;

    IF  (search_mode = csm_local)  OR  (search_mode = csm_both)  THEN
      local_nad := local_nads;
      WHILE  local_nad <> NIL  DO
        IF  local_nad^.entry.name = nad_name  THEN
          local_nad_match := local_nad;
          RETURN;
        IFEND;
        local_nad := local_nad^.next_entry;
      WHILEND;
    IFEND;

    IF  (search_mode = csm_remote)  OR  (search_mode = csm_both)  THEN
      remote_nad := remote_nads;
      WHILE  remote_nad <> NIL  DO
        IF  remote_nad^.entry.name = nad_name  THEN
          remote_nad_match := remote_nad;
          RETURN;
        IFEND;
        remote_nad := remote_nad^.next_entry;
      WHILEND;
    IFEND;

  PROCEND check_for_nad_name_match;
?? TITLE := '    CONVERT_MICROCODE_TYPE' ??
?? EJECT ??
  PROCEDURE convert_microcode_type(name: string(*);
                               VAR microcode_type: rft$microcode_types;
                               VAR status: ost$status);

{    The purpose of this procedure is to convert the microcode type string value into a
{    valid microcode type code.
{
{    name: (input) This parameter specifies the microcode type string value to be converted.
{
{    microcode_type: (output) This parameter returns the internal microcode type code.
{
{    status: (output) This parameter specifies the results of the request.  If the return status
{      is normal, then the parameter microcode_type contains a valid value.

    VAR
        mt_conversion_table : [static] ARRAY [rft$microcode_types] OF string(4) :=
          ['C180', 'C170', 'VAX', 'IBM', 'C200', 'INET', 'NTN'],
        mt_index : rft$microcode_types;

    status.normal := TRUE;

    FOR  mt_index := rfc$mc_type_180  TO  rfc$mc_type_ntn  DO
      IF  mt_conversion_table[mt_index] = name  THEN
        microcode_type := mt_index;
        RETURN;
      IFEND;
    FOREND;

{    If you get to here no match was found, this means there is a major screw up somewhere.

    osp$set_status_abnormal(rfc$product_id, rfe$parameter_problem, 'NAD_TYPE', status);

  PROCEND convert_microcode_type;
?? TITLE := '    CONVERT_DUMP_DISPOSITION' ??
?? EJECT ??
  PROCEDURE convert_dump_disposition(name: string(*);
                                 VAR dump_disposition: rft$dump_disposition;
                                 VAR status: ost$status);

{    The purpose of this procedure is to convert the dump disposition string value into a
{    valid dump disposition code.
{
{    name: (input) This parameter specifies the dump dispostion string value to be converted.
{
{    dump_disposition: (output) This parameter returns the internal dump disposition code.
{
{    status: (output) This parameter specifies the results of the request.  If the return status
{      is normal, then the parameter dump_dispostion contains a valid value.

    VAR
        dd_conversion_table : [static] ARRAY [rft$dump_disposition] OF string(10) :=
          ['DISCARD', 'SAVE_LAST', 'SAVE_ALL'],
        dd_index : rft$dump_disposition;

    status.normal := TRUE;

    FOR  dd_index := rfc$dd_discard  TO  rfc$dd_save_all  DO
      IF  dd_conversion_table[dd_index] = name  THEN
        dump_disposition := dd_index;
        RETURN;
      IFEND;
    FOREND;

{    If you get to here no match was found, this means there is a major screw up somewhere.

    osp$set_status_abnormal(rfc$product_id, rfe$parameter_problem, 'DUMP_DISPOSITION', status);

  PROCEND convert_dump_disposition;
?? TITLE := '    DETERMINE_COMMON_TRUNKS' ??
?? EJECT ??
  PROCEDURE  determine_common_trunks(local_nad_trunks: rft$trunk_control_units;
                                     remote_nad_trunks: rft$trunk_control_units;
                                     local_tcu_access_codes: rft$nad_access_codes;
                                     remote_tcu_access_codes: rft$nad_access_codes;
                                     access_code: rft$nad_access_code;
                                     excluded_trunks: ARRAY [1..3] OF rft$component_name;
                                 VAR local_tcu_mask: rft$tcu_mask;
                                 VAR remote_tcu_mask: rft$tcu_mask;
                                 VAR common_trunk_found: boolean);

{    The purpose of this routine is to determine which trunks, if any, are common between two
{    NADs.  The criteria to determine a matching trunk is as follows:
{
{    1)   A Trunk Control Unit on the local NAD must be attached to a trunk with the same name
{         as a trunk attached to a Trunk Control Unit on the remote NAD.
{
{    2)   The trunk name must not reference a trunk that has been expicitly excluded by the user.
{
{    3)   The remote trunk control unit access code must be the same as the access code
{         specified by the user.
{
{    When a matching trunk is found, both the corresponding tcu mask flag in the local tcu
{    mask and the remote tcu mask are set to TRUE.
{
{
{    local_nad_trunks: (input) This parameter specifies the local NAD trunk attachments.
{
{    remote_nad_trunks: (input) This parameter specifies the remote NAD trunk attachments.
{
{    local_tcu_access_codes: (input) This parameter specifies the access codes which correspond
{      to each of the local NAD trunks.
{
{    remote_tcu_access_codes: (input) This parameter specifies the access codes which correspond
{      to each of the remote NAD trunks.
{
{    access_code: (input) This parameter specifies the access code which must be matched before
{      a trunk match is determined.
{
{    excluded_trunks: (input) This parameter specifies a list of trunk names which are note
{      to be considered as candidates for this compare operation.  Note - all entries that are not
{      defined must be set to the NIL string ('').
{
{    local_tcu_mask: (output) This parameter is an array of flags which denote the matching
{      trunk control units on the local NAD.
{
{    remote_tcu_mask: (output) This parameter is an array of flags which denote the matching
{      trunk control units on the remote NAD.
{
{    common_trunk_found: (output) This parameter returns a value of TRUE if there are any matching
{      trunks between the two NADs.

    VAR
        trunk_match: boolean,
        ltcu,
        rtcu: rfc$min_tcu..rfc$max_tcu;


    FOR  ltcu := rfc$min_tcu  TO  rfc$max_tcu  DO
      local_tcu_mask[ltcu] := FALSE;             {  initially assume no connects available  }
      remote_tcu_mask[ltcu] := FALSE;
    FOREND;
    trunk_match := FALSE;

    FOR  ltcu := rfc$min_tcu  TO  rfc$max_tcu  DO
      IF  local_nad_trunks[ltcu] <> ''  THEN
        FOR  rtcu := rfc$min_tcu  TO rfc$max_tcu  DO
          IF  (local_nad_trunks[ltcu] = remote_nad_trunks[rtcu])
              AND  (access_code = remote_tcu_access_codes[rtcu])
              AND  (NOT the_trunk_is_excluded(excluded_trunks, local_nad_trunks[ltcu]))  THEN
            local_tcu_mask[ltcu] := TRUE;
            remote_tcu_mask[rtcu] := TRUE;
            trunk_match := TRUE;
          IFEND;
        FOREND;
      IFEND;
    FOREND;

    common_trunk_found := trunk_match;

  PROCEND determine_common_trunks;
?? TITLE := '    GET_LOGICAL_IDS' ??
?? EJECT ??
  PROCEDURE  get_logical_ids(VAR lids: ARRAY [1..*] OF rft$lids;
                             VAR status: ost$status);

{    The purpose of this procedure is to get the values of the logical identifiers for the
{    DEFINE_LOCAL_HOST and DEFINE_REMOTE_HOST configurtion directives.  This procedure assumes
{    that CLP$SCAN_PARAMETER_LIST had been called prior to calling this procedure.
{
{    lids: (output) This parameter returns a list of the logical identifiers that have been
{      defined for the corresponding host.
{
{    status: (output) This parameter returns the results of the request.

    VAR
        lid1,lid2,
        lid_index: INTEGER,
        logical_identifier: clt$value;

    FOR  lid_index := 1  TO  UPPERBOUND(lids)  DO
      clp$get_value('logical_identifiers', lid_index, 1, clc$low, logical_identifier, status);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
      #TRANSLATE(osv$lower_to_upper, logical_identifier.str.value(1,logical_identifier.str.size),
        lids[lid_index].logical_id);
      lids[lid_index].disabled := FALSE;
      IF  logical_identifier.str.size <> #SIZE(rft$physical_identifier)  THEN
        lids[lid_index].map_lid_to_pid := TRUE;
      ELSE
        lids[lid_index].map_lid_to_pid := FALSE;
      IFEND;
    FOREND;

    FOR  lid1 := 1  TO  (UPPERBOUND(lids)-1)  DO
      FOR  lid2 := (lid1+1) TO  UPPERBOUND(lids)  DO
        IF  lids[lid1] = lids[lid2]  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$duplicate_lid, lids[lid1].logical_id, status);
          RETURN;
        IFEND;
      FOREND;
    FOREND;

  PROCEND get_logical_ids;
?? TITLE := '    OBTAIN_COMMON_NAD_PARAMS' ??
?? EJECT ??
  PROCEDURE obtain_common_nad_params (save_info: rft$config_utl_pointers;
                                  VAR nad_name: rft$component_name;
                                  VAR nad_address: rft$nad_address;
                                  VAR trunk_control_units: rft$trunk_control_units;
                                  VAR tcu_access_codes: rft$nad_access_codes;
                                  VAR status: ost$status);

{    The purpose of this procedure is to get the values of the common parameters for the
{    DEFINE_LOCAL_NAD and DEFINE_REMOTE_NAD configurtion directives.  This procedure assumes
{    that CLP$SCAN_PARAMETER_LIST prior to calling this procedure.
{
{    save_info: (input) This parameter contains the currently defined configuration
{      elements.
{
{    nad_name: (output) This parameter returns the name of the corresponding NAD.
{
{    nad_address: (output) This parameter returns the physical NAD address of the
{      corresponding NAD.
{
{    trunk_control_units: (output) This parameter returns the names of the trunks that
{      are physically attached to the corresponding NAD.
{
{    tcu_access_codes: (output) This parameter returns the access codes for each of the
{      defined trunks.
{
{    status: (output) This parameter value is NORMAL if all of the common parameters have
{      been successfully obtained.  Thus, none of the return parameters are valid if an
{      abnormal status is returned.

    VAR
        nad,
        address,
        trunk_control_unit,
        tcu_access_code: clt$value,
        the_parameter_is_specified: boolean,
        tcu_index: rfc$min_tcu .. rfc$max_tcu,
        matching_local_nad: ^rft$cu_local_nad_entry,
        matching_remote_nad: ^rft$cu_remote_nad_entry;

    {     Each NAD must be identified by a unique identifier.

    clp$get_value('nad', 1, 1, clc$low, nad, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;
    nad_name := nad.name.value(1,nad.name.size);
    IF  nad_name = keyword_all  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$all_is_not_a_legal_name, 'NAD', status);
      RETURN;
    IFEND;
    check_for_nad_name_match(nad_name, csm_both, save_info.local_nads, save_info.remote_nads,
      matching_local_nad, matching_remote_nad);
    IF  (matching_local_nad <> NIL)  OR  (matching_remote_nad <> NIL)  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$duplicate_component_name, nad_name, status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'NAD', status);
      RETURN;
    IFEND;

    clp$get_value('address', 1, 1, clc$low, address, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;
    nad_address := address.int.value;

    {   Obtaining the trunks connected to the corresponding trunk control units is a tedious
    {   repetitive process, which begs to be done in a FOR loop.  However, externalizing this
    {   as a list to the end user would not be very clean.

    clp$test_parameter('trunk_control_unit_0', the_parameter_is_specified, status);
    IF  the_parameter_is_specified  THEN
      clp$get_value('trunk_control_unit_0', 1, 1, clc$low, trunk_control_unit, status);
      IF  NOT status.normal  THEN
        RETURN;
      ELSE

        {  The Trunk Control Unit Access Code is only meaningful if a valid trunk is connected
        {  to the corresponding trunk control unit.

        clp$get_value('tcu_access_code_0', 1, 1, clc$low, tcu_access_code, status);
        IF  NOT status.normal  THEN
          RETURN;
        IFEND;
        trunk_control_units[rfc$min_tcu] :=
                                  trunk_control_unit.name.value(1,trunk_control_unit.name.size);
        tcu_access_codes[rfc$min_tcu] := tcu_access_code.int.value;
      IFEND;
    ELSE

      {  If a trunk is not attached to a trunk control unit the trunk name must be set to
      {  the NIL string to prevent erroneous operations when referencing this entity.

      trunk_control_units[rfc$min_tcu] := '';
    IFEND;

    clp$test_parameter('trunk_control_unit_1', the_parameter_is_specified, status);
    IF  the_parameter_is_specified  THEN
      clp$get_value('trunk_control_unit_1', 1, 1, clc$low, trunk_control_unit, status);
      IF  NOT status.normal  THEN
        RETURN;
      ELSE
        clp$get_value('tcu_access_code_1', 1, 1, clc$low, tcu_access_code, status);
        IF  NOT status.normal  THEN
          RETURN;
        IFEND;
        trunk_control_units[rfc$min_tcu + 1] :=
                                  trunk_control_unit.name.value(1,trunk_control_unit.name.size);
        tcu_access_codes[rfc$min_tcu + 1] := tcu_access_code.int.value;
      IFEND;
    ELSE
      trunk_control_units[rfc$min_tcu + 1] := '';
    IFEND;

    clp$test_parameter('trunk_control_unit_2', the_parameter_is_specified, status);
    IF  the_parameter_is_specified  THEN
      clp$get_value('trunk_control_unit_2', 1, 1, clc$low, trunk_control_unit, status);
      IF  NOT status.normal  THEN
        RETURN;
      ELSE
        clp$get_value('tcu_access_code_2', 1, 1, clc$low, tcu_access_code, status);
        IF  NOT status.normal  THEN
          RETURN;
        IFEND;
        trunk_control_units[rfc$min_tcu + 2] :=
                                  trunk_control_unit.name.value(1,trunk_control_unit.name.size);
        tcu_access_codes[rfc$min_tcu + 2] := tcu_access_code.int.value;
      IFEND;
    ELSE
      trunk_control_units[rfc$min_tcu + 2] := '';
    IFEND;

    clp$test_parameter('trunk_control_unit_3', the_parameter_is_specified, status);
    IF  the_parameter_is_specified  THEN
      clp$get_value('trunk_control_unit_3', 1, 1, clc$low, trunk_control_unit, status);
      IF  NOT status.normal  THEN
        RETURN;
      ELSE
        clp$get_value('tcu_access_code_3', 1, 1, clc$low, tcu_access_code, status);
        IF  NOT status.normal  THEN
          RETURN;
        IFEND;
        trunk_control_units[rfc$min_tcu + 3] :=
                                  trunk_control_unit.name.value(1,trunk_control_unit.name.size);
        tcu_access_codes[rfc$min_tcu + 3] := tcu_access_code.int.value;
      IFEND;
    ELSE
      trunk_control_units[rfc$min_tcu + 3] := '';
    IFEND;

    FOR  tcu_index := rfc$min_tcu  TO  rfc$max_tcu  DO
      IF  trunk_control_units[tcu_index] = keyword_all  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$all_is_not_a_legal_name, 'TRUNK CONTROL UNIT',
          status);
        RETURN;
      IFEND;
    FOREND;

  PROCEND obtain_common_nad_params;
?? TITLE := '    THE_TRUNK_IS_EXCLUDED' ??
?? EJECT ??
  FUNCTION the_trunk_is_excluded(excluded_trunk_list: ARRAY [*] OF rft$component_name;
                                 trunk_name: rft$component_name): BOOLEAN;

{
{    The purpose of this routine is to determine if the user has specified that a
{    trunk was not to be used for a specified path.  A value of TRUE is returned if the
{    specified trunk name is in the excluded trunk list.
{
{    excluded_trunk_list: (input) This parameter specifies an array of trunks that
{      are not eligible as candidates for this path definition.
{
{    trunk_name: (input) This parameter specifies the name of a trunk that is common
{      between the local NAD and the remote NAD that were specified in the path request.
{

    VAR
        index: integer;

    the_trunk_is_excluded := FALSE;
    FOR  index := LOWERBOUND(excluded_trunk_list)  TO  UPPERBOUND(excluded_trunk_list)  DO
      IF  trunk_name = excluded_trunk_list[index]  THEN
        the_trunk_is_excluded := TRUE;
        RETURN;
      IFEND;
    FOREND;

  FUNCEND the_trunk_is_excluded;
?? TITLE := '    RFP$OUTPUT_STATUS_MESSAGE' ??
?? EJECT ??
  PROCEDURE rfp$output_status_message (output_fid: amt$file_identifier;
                                       status_message: ost$status);

{
{    The purpose of this routine is to format a status message and write the formatted message
{    to the current output file.
{
{    status_message: (input) This parameter specifies the current status message that is to be
{      printed.
{
{    status: (output) This parameter specifies whether or not the specified message was successfully
{      sent to the output file.
{
    CONST
        max_char_per_message_line = 72;
    VAR
        status: ost$status,
        number_of_message_lines : ^ost$status_message_line_count,
        length_of_message_line : ^ost$status_message_line_size,
        message_line : ^ost$status_message_line,
        message_sequence : ost$status_message,
        pointer_to_message_sequence : ^ost$status_message,
        line_counter : integer;

    osp$format_message(status_message, osc$current_message_level, max_char_per_message_line,
                       message_sequence, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;
    write_line('        ', output_fid, status);
    IF  NOT  status.normal  THEN
      RETURN;
    IFEND;
    pointer_to_message_sequence := ^message_sequence;
    RESET pointer_to_message_sequence;
    NEXT  number_of_message_lines  IN  pointer_to_message_sequence;
    FOR  line_counter := 1  TO  number_of_message_lines^  DO
      NEXT  length_of_message_line  IN  pointer_to_message_sequence;
      NEXT  message_line : [length_of_message_line^]  IN  pointer_to_message_sequence;
      write_line(message_line^(1,length_of_message_line^), output_fid, status);
      IF  NOT  status.normal  THEN
        RETURN;
      IFEND;
    FOREND;
    write_line('         ', output_fid, status);
  PROCEND rfp$output_status_message;
?? TITLE := '    CREATE_THE_STATUS_TABLE' ??
?? EJECT ??
  PROCEDURE create_the_status_table(VAR save_info: rft$config_utl_pointers;
                                    VAR config_file_created_status: ost$status;
                                    VAR status: ost$status);

{    The purpose of this procedure is to create the configuration file and move the
{    transformed configuration directives into the file.
{
{    The configuration file is a segment access file that is managed as a SEQUENCE.
{    The various configuration elements are arranged in element order as adaptable arrays.
{    The purpose of this scheme is so that the system task can allocate a HEAP of
{    space in the network paged section and move the configuration file definitions
{    into that heap.  This will preserve the locality of the definitions to
{    minimize any page faults while scanning through the configuration elements.
{    The adaptable arrays are used to further enhance the scanning performance.
{
{    save_info: (input) This parameter contains the information needed to build the
{      new configuration file.
{
{    config_file_created_status: (input,output) This parameter is used to maintain the status
{      of the new configuration file for recovery purposes.
{
{    status: (output) This parameter is set to NORMAL if the configuration file was successfully
{      created.

    VAR
        configuration_file_lfn: amt$local_file_name,
        unique_name: ost$unique_name,
        attachment_options: ^fst$attachment_options,
        configuration_fid: amt$file_identifier,
        status_table_ptr: ^SEQ(*),
        configuration_label : ^string(rfc$config_label_length),
        segment_ptr : amt$segment_pointer,
        ignore_status : ost$status;


    pmp$generate_unique_name(unique_name, ignore_status);
    configuration_file_lfn := unique_name.value;
    attach_configuration_file(configuration_file_lfn, rfc$configuration_file, status);
    IF NOT status.normal THEN
      create_configuration_file(configuration_file_lfn, rfc$configuration_file,
                              config_file_created_status, status);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
    IFEND;

  /main_section/
    BEGIN
      PUSH  attachment_options : [1..3];
      attachment_options^[1].selector := fsc$access_and_share_modes;
      attachment_options^[1].access_modes.selector := fsc$specific_access_modes;
      attachment_options^[1].access_modes.value :=
        $fst$file_access_options[fsc$read, fsc$append, fsc$shorten];
      attachment_options^[1].share_modes.selector := fsc$determine_from_access_modes;
      attachment_options^[2].selector := fsc$create_file;
      attachment_options^[2].create_file := FALSE;
      attachment_options^[3].selector := fsc$open_position;
      attachment_options^[3].open_position := amc$open_at_boi;
      fsp$open_file(configuration_file_lfn, amc$segment, attachment_options, NIL, NIL,
        NIL, NIL, configuration_fid, status);
      IF  NOT status.normal  THEN
        EXIT /main_section/;
      IFEND;
      amp$get_segment_pointer(configuration_fid, amc$sequence_pointer, segment_ptr, status);
      status_table_ptr := segment_ptr.sequence_pointer;
      IF  NOT status.normal  THEN
        EXIT /main_section/;
      IFEND;
      RESET status_table_ptr;

      {     Place the label in the configuration file.

      NEXT  configuration_label  IN  status_table_ptr;
      IF  configuration_label = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'status table SEQ',
                                status);
        EXIT /main_section/;
      IFEND;
      configuration_label^ := rfc$configuration_label;
      move_local_host_definition(save_info, status_table_ptr, status);
      IF  NOT status.normal  THEN
        EXIT /main_section/;
      IFEND;
      move_remote_host_definitions(save_info, status_table_ptr, status);
      IF  NOT status.normal  THEN
        EXIT /main_section/;
      IFEND;
      move_local_nad_definitions(save_info, status_table_ptr, status);
      IF  NOT status.normal  THEN
        EXIT /main_section/;
      IFEND;
      move_remote_nad_definitions(save_info, status_table_ptr, status);

    END /main_section/;

    IF  status.normal  THEN
      segment_ptr.kind := amc$sequence_pointer;
      segment_ptr.sequence_pointer := status_table_ptr;
      amp$set_segment_eoi(configuration_fid, segment_ptr, ignore_status);
    IFEND;
    fsp$close_file(configuration_fid, ignore_status);
    amp$return(configuration_file_lfn, ignore_status);

  PROCEND create_the_status_table;
?? NEWTITLE := '      MOVE_LOCAL_HOST_DEFINITION' ??
?? EJECT ??
  PROCEDURE move_local_host_definition(
                                   VAR save_info: rft$config_utl_pointers;
                                   VAR status_table_ptr: ^SEQ(*);
                                   VAR status: ost$status);

{    The purpose of this procedure is to move the local host definition from a
{    scratch segment into the configuration file.
{
{    save_info: (input) This parameter contains the pointer to the scratch segment, which
{      contains the interpreted configuration commands.
{
{    status_table_ptr: (input,output) This parameter contains the segment access pointer
{      to the configuration file.  This pointer is a sequence pointer and is updated
{      by this routine, as space is allocated within the sequence.
{
{    status: (output) This parameter specifies the results of the transfer.


    VAR
        index : integer,
        logical_id_count,
        path_count : ^integer,
        local_host_temp : ^rft$local_host_definition,
        local_host_paths : ^rft$lcn_paths;

    IF  NOT save_info.local_host_defined  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$required_def_missing, 'local host', status);
      RETURN;
    IFEND;
    NEXT logical_id_count  IN  status_table_ptr;
    IF  logical_id_count = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'status table SEQ',
                              status);
      RETURN;
    IFEND;
    logical_id_count^ := UPPERBOUND(save_info.local_host^.entry.logical_identifiers);
    NEXT  local_host_temp : [1..logical_id_count^] IN status_table_ptr;
    IF  local_host_temp = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'status table SEQ',
                              status);
      RETURN;
    IFEND;
    local_host_temp^ := save_info.local_host^.entry;

    NEXT path_count IN status_table_ptr;
    IF  path_count = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'status table SEQ',
                              status);
      RETURN;
    IFEND;
    path_count^ := save_info.local_host^.number_of_paths;
    IF  path_count^ <> 0  THEN
      NEXT  local_host_paths : [1..path_count^] IN status_table_ptr;
      IF  local_host_paths = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'status table SEQ',
                                status);
        RETURN;
      IFEND;
      FOR  index := 1  TO  path_count^  DO
        local_host_paths^[index] := save_info.local_host^.paths^.entry;
        save_info.local_host^.paths := save_info.local_host^.paths^.next_entry;
      FOREND;
    IFEND;
  PROCEND move_local_host_definition;
?? TITLE := '      MOVE_REMOTE_HOST_DEFINITIONS' ??
?? EJECT ??
  PROCEDURE move_remote_host_definitions(
                                     VAR save_info: rft$config_utl_pointers;
                                     VAR status_table_ptr: ^SEQ(*);
                                     VAR status: ost$status);
{    The purpose of this procedure is to move the remote hosts definition from a
{    scratch segment into the configuration file.
{
{    save_info: (input) This parameter contains the pointer to the scratch segment, which
{      contains the interpreted configuration commands.
{
{    status_table_ptr: (input,output) This parameter contains the segment access pointer
{      to the configuration file.  This pointer is a sequence pointer and is updated
{      by this routine, as space is allocated within the sequence.
{
{    status: (output) This parameter specifies the results of the transfer.


    VAR
        index : integer,
        path_count,
        server_count,
        logical_id_count : ^integer,
        number_of_remote_hosts : ^integer,
        host_count : rft$number_of_hosts,
        remote_host : ^rft$remote_host_definition,
        remote_host_paths : ^rft$lcn_paths;


    status.normal := TRUE;

    NEXT  number_of_remote_hosts  IN  status_table_ptr;
    IF  number_of_remote_hosts = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'status table SEQ',
                              status);
      RETURN;
    IFEND;
    number_of_remote_hosts^ := save_info.remote_host_count;
    IF  save_info.remote_host_count <> 0  THEN
      FOR  host_count := 1  TO  save_info.remote_host_count  DO
        NEXT logical_id_count  IN  status_table_ptr;
        IF  logical_id_count = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'status table SEQ',
                                  status);
          RETURN;
        IFEND;
        logical_id_count^ := UPPERBOUND(save_info.remote_hosts^.entry.logical_identifiers);
        NEXT  remote_host : [1..logical_id_count^] IN status_table_ptr;
        IF  remote_host = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'status table SEQ',
                                  status);
          RETURN;
        IFEND;
        remote_host^ := save_info.remote_hosts^.entry;
        NEXT  path_count  IN  status_table_ptr;
        IF  path_count = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'status table SEQ',
                                  status);
          RETURN;
        IFEND;
        path_count^ := save_info.remote_hosts^.number_of_paths;
        IF  path_count^ <> 0  THEN
          NEXT  remote_host_paths : [1..path_count^] IN status_table_ptr;
          IF  remote_host_paths = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'status table SEQ',
                                    status);
            RETURN;
          IFEND;
          FOR  index := 1  TO  path_count^  DO
            remote_host_paths^[index] := save_info.remote_hosts^.paths^.entry;
            save_info.remote_hosts^.paths := save_info.remote_hosts^.paths^.next_entry;
          FOREND;
        IFEND;
        save_info.remote_hosts := save_info.remote_hosts^.next_entry;
      FOREND;
    IFEND;
  PROCEND move_remote_host_definitions;
?? TITLE := '      MOVE_LOCAL_NAD_DEFINITIONS' ??
?? EJECT ??
  PROCEDURE move_local_nad_definitions(
                                   VAR save_info: rft$config_utl_pointers;
                                   VAR status_table_ptr: ^SEQ(*);
                                   VAR status: ost$status);

{    The purpose of this procedure is to move the local nad definitions from a
{    scratch segment into the configuration file.
{
{    save_info: (input) This parameter contains the pointer to the scratch segment, which
{      contains the interpreted configuration commands.
{
{    status_table_ptr: (input,output) This parameter contains the segment access pointer
{      to the configuration file.  This pointer is a sequence pointer and is updated
{      by this routine, as space is allocated within the sequence.
{
{    status: (output) This parameter specifies the results of the transfer.


    VAR
        nad_count : ^integer,
        index : integer,
        local_nad : ^rft$local_nad_table;


    IF  save_info.local_nad_count = 0  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$required_def_missing, 'local NAD', status);
      RETURN;
    IFEND;
    NEXT  nad_count  IN  status_table_ptr;
    IF  nad_count = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'status table SEQ',
                              status);
      RETURN;
    IFEND;
    nad_count^ := save_info.local_nad_count;
    NEXT  local_nad : [1..nad_count^] IN status_table_ptr;
    IF  local_nad = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'status table SEQ',
                              status);
      RETURN;
    IFEND;

    {     When moving the NADS into the adaptable array the original nad index must be preserved
    {     for the path entries to remain valid.

    FOR  index := 1  TO  nad_count^  DO
      local_nad^[save_info.local_nads^.index] := save_info.local_nads^.entry;
      save_info.local_nads := save_info.local_nads^.next_entry;
    FOREND;

  PROCEND move_local_nad_definitions;
?? TITLE := '      MOVE_REMOTE_NAD_DEFINITIONS' ??
?? EJECT ??
  PROCEDURE move_remote_nad_definitions(
                                    VAR save_info: rft$config_utl_pointers;
                                    VAR status_table_ptr: ^SEQ(*);
                                    VAR status: ost$status);

{    The purpose of this procedure is to move the remote nad definitions from a
{    scratch segment into the configuration file.
{
{    save_info: (input) This parameter contains the pointer to the scratch segment, which
{      contains the interpreted configuration commands.
{
{    status_table_ptr: (input,output) This parameter contains the segment access pointer
{      to the configuration file.  This pointer is a sequence pointer and is updated
{      by this routine, as space is allocated within the sequence.
{
{    status: (output) This parameter specifies the results of the transfer.


    VAR
        nad_count : ^integer,
        index : integer,
        remote_nad : ^rft$remote_nad_table;

    NEXT  nad_count  IN  status_table_ptr;
    IF  nad_count = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'status table SEQ',
                              status);
      RETURN;
    IFEND;
    nad_count^ := save_info.remote_nad_count;
    IF  save_info.remote_nad_count <> 0  THEN
      NEXT  remote_nad : [1..nad_count^] IN status_table_ptr;
      IF  remote_nad = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$configuration_overflow, 'status table SEQ',
                                status);
        RETURN;
      IFEND;

      {   When moving the remote NADs into the adaptable array, the original order must be preserved to
      {   allow the path entries to remain valid.

      FOR  index := 1  TO  nad_count^  DO
        remote_nad^[save_info.remote_nads^.index] := save_info.remote_nads^.entry;
        save_info.remote_nads := save_info.remote_nads^.next_entry;
      FOREND;
    IFEND;
  PROCEND move_remote_nad_definitions;
?? OLDTITLE ??
?? TITLE := '    ATTACH_CONFIGURATION_FILE' ??
?? EJECT ??
  PROCEDURE attach_configuration_file(file_lfn: amt$local_file_name;
                                      file_pfn : string(*);
                                  VAR status: ost$status);


    VAR
        cycle_number : pft$cycle_selector,
        password : pft$name,
        usage_selections : pft$usage_selections,
        share_mode : pft$share_selections,
        pfn : pft$name,
        file_path : ^pft$path;

    pfn := file_pfn;
    PUSH file_path : [1..4];
    file_path^[1] := rfc$rhfam_family_name;
    file_path^[2] := rfc$rhfam_master_catalog;
    file_path^[3] := rfc$rhfam_sub_catalog;
    file_path^[4] := pfn;
    cycle_number.cycle_option := pfc$highest_cycle;
    password := rfc$password;
    usage_selections := $pft$usage_selections[pfc$read, pfc$append, pfc$shorten];
    share_mode := $pft$share_selections[ ];
    pfp$attach(file_lfn, file_path^, cycle_number, password,
               usage_selections, share_mode, pfc$wait, status);

  PROCEND attach_configuration_file;
?? TITLE := '    COPY_CONFIGURATION_FILE' ??
?? EJECT ??
  PROCEDURE copy_configuration_file (   temporary_cmd_file : amt$local_file_name;
    VAR config_file_created_status: ost$status;
    VAR status: ost$status);

{    The purpose of this procedure is to create the configuration file and move the
{    transformed configuration directives into the file.
{
{    The configuration file is a segment access file that is managed as a SEQUENCE.
{    The various configuration elements are arranged in element order as adaptable arrays.
{    The purpose of this scheme is so that the system task can allocate a HEAP of
{    space in the network paged section and move the configuration file definitions
{    into that heap.  This will preserve the locality of the definitions to
{    minimize any page faults while scanning through the configuration elements.
{    The adaptable arrays are used to further enhance the scanning performance.
{
{    save_info: (input) This parameter contains the information needed to build the
{      new configuration file.
{
{    config_file_created_status: (input,output) This parameter is used to maintain the status
{      of the new configuration file for recovery purposes.
{
{    status: (output) This parameter is set to NORMAL if the configuration file was successfully
{      created.

    VAR
        configuration_cmd_file_lfn: amt$local_file_name,
        unique_name: ost$unique_name,
        ignore_status : ost$status;


    pmp$generate_unique_name(unique_name, ignore_status);
    configuration_cmd_file_lfn := unique_name.value;
    create_configuration_file(configuration_cmd_file_lfn, rfc$configuration_cmd_file,
                              config_file_created_status, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;
    attach_configuration_file (configuration_cmd_file_lfn,rfc$configuration_cmd_file, status);
    fsp$copy_file(temporary_cmd_file, configuration_cmd_file_lfn, NIL,
                                  NIL, NIL, status);

    amp$return(configuration_cmd_file_lfn, ignore_status);

  PROCEND copy_configuration_file;
?? TITLE := '    CREATE_CONFIGURATION_FILE' ??
?? EJECT ??
  PROCEDURE create_configuration_file(file_lfn: amt$local_file_name;
                                      file_pfn: string(*);
                                  VAR config_file_created_status: ost$status;
                                  VAR status: ost$status);

{    The purpose of this procedure is to create the file $SYSTEM.RHFAM.xxxxx
{    (where xxxxx is CONFIGURATION_FILE or CONFIGURATION_CMD_FILE)
{    If the sub-catalog RHFAM does not exist it will be created.  If a file specified
{    already exists a new cycle will be created.
{
{    NOTE - a site is required to manage the number of cycles of both the CONFIGURATION_FILE
{           and the CONFIGURATION_CMD_FILE.
{
{    file_lfn: (input) This parameter contains the local file name to attach the file with.
{
{    file_pfn: (input) This parameter contains the permanent file name of the file to be attached.
{
{    config_file_created_status: (input,output) This parameter is used to maintain the status
{      of the new configuration file for recovery purposes.
{
{    status: (output) A value of normal is returned if a new cycle of specified file
{      has been created and attached.

    VAR
        ignore_status: ost$status,
        cycle_number : pft$cycle_selector,
        password : pft$name,
        pfn : pft$name,
        catalog_path,
        file_path : ^pft$path;

    PUSH catalog_path : [1..3];
    catalog_path^[1] := rfc$rhfam_family_name;
    catalog_path^[2] := rfc$rhfam_master_catalog;
    catalog_path^[3] := rfc$rhfam_sub_catalog;
    pfp$define_catalog(catalog_path^, status);
    IF  (status.normal)  OR
        (status.condition = pfe$name_already_subcatalog)  OR
        (status.condition = pfe$not_master_catalog_owner)  THEN
      status.normal := TRUE;
      pfn := file_pfn;
      PUSH file_path : [1..4];
      file_path^[1] := rfc$rhfam_family_name;
      file_path^[2] := rfc$rhfam_master_catalog;
      file_path^[3] := rfc$rhfam_sub_catalog;
      file_path^[4] := pfn;
      password := rfc$password;
      cycle_number.cycle_option := pfc$highest_cycle;
      pfp$define(file_lfn, file_path^, cycle_number, password, pfc$maximum_retention,
                 pfc$no_log, config_file_created_status);
      IF  NOT config_file_created_status.normal  THEN
        status := config_file_created_status;
      IFEND;
    IFEND;

  PROCEND create_configuration_file;
?? TITLE := '    DELETE_CONFIGURATION_FILE' ??
?? EJECT ??
  PROCEDURE delete_configuration_file(file_pfn : string(*);
                                      cycle_to_delete : pft$cycle_options;
                                  VAR status: ost$status);

{    The purpose of this procedure is to delete the file $SYSTEM.RHFAM.xxxxx
{    (where xxxxx is CONFIGURATION_FILE or CONFIGURATION_CMD_FILE)
{    if an attempt to install an RHFAM configuration file has failed.  This removes the highest cycle,
{    which allows a previously installed configuration file to remain available to the system task for
{    activation.
{
{    file_pfn: (input) This parameter contains the permanent file name of the file to be attached.
{
{    status: (output) A value of normal is returned if the highest cycle of CONFIGURATION_FILE
{      has been deleted.

    VAR
        cycle_number : pft$cycle_selector,
        password : pft$name,
        pfn : pft$name,
        file_path : ^pft$path;

    pfn := file_pfn;
    PUSH file_path : [1..4];
    file_path^[1] := rfc$rhfam_family_name;
    file_path^[2] := rfc$rhfam_master_catalog;
    file_path^[3] := rfc$rhfam_sub_catalog;
    file_path^[4] := pfn;
    password := rfc$password;
    cycle_number.cycle_option := cycle_to_delete;
    pfp$purge(file_path^, cycle_number, password, status);
  PROCEND delete_configuration_file;
?? TITLE := '    WRITE_CMD_LINE' ??
?? EJECT ??
  PROCEDURE write_cmd_line (command : string(*);
                        command_text : string(*);
                        save_info : rft$config_utl_pointers;
                    VAR status : ost$status);
{
{      This procedure sends a string of characters to the command file.
{

    VAR
        byte_address : amt$file_byte_address,
        length  : integer,
        output_line : ^string (*);

    PUSH output_line :[STRLENGTH(command) + 1 + STRLENGTH(command_text)];
    stringrep (output_line^, length, command, ' ', command_text);
    amp$put_next(save_info.temporary_command_file_fid, output_line, length, byte_address, status);
  PROCEND write_cmd_line;
?? TITLE := '    WRITE_LINE' ??
?? EJECT ??
  PROCEDURE write_line (line_to_be_written_out : string(*);
                        output_fid: amt$file_identifier;
                    VAR status : ost$status);
{
{      This procedure sends a string of characters to the current output file (output_fid).
{

   VAR
        byte_address : amt$file_byte_address;

    amp$put_next(output_fid, #loc(line_to_be_written_out), strlength(line_to_be_written_out), byte_address,
                 status);
  PROCEND write_line;
?? OLDTITLE ??
?? OLDTITLE ??
MODEND rfm$configuration_utility;

*DECK DECK=RFM$CONFIG_UTL_HELPER EXPAND=TRUE
*copyc osd$default_pragmats
?? TITLE := 'RHFAM/VE : Store configuration data for configuration utility : R23D' ??
?? NEWTITLE := '  Common Decks' ??
MODULE rfm$config_utl_helper;
*copyc rfh$config_utl_helper
?? EJECT ??
*copyc rft$config_utl_pointers
?? EJECT ??
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
*copyc oss$task_private
*copyc osv$task_private_heap
*copyc pmp$get_executing_task_gtid
*copyc rfe$condition_codes
*copyc rfp$verify_caller_capability
*copyc rfp$lock_table
*copyc rfp$unlock_table
*copyc rfv$status_table
*copyc tmv$null_global_task_id
?? TITLE := '  Global Variables' ??
?? EJECT ??
    VAR
        rfv$config_utl_pointers: [XDCL, oss$task_private] ^rft$config_utl_pointers := NIL;
?? TITLE := '  RFP$INITIALIZE_CONFIG_POINTERS' ??
?? EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$initialize_config_pointers(install_request: BOOLEAN;
                                                     VAR save_info: rft$config_utl_pointers;
                                                     VAR status: ost$status);

*copyc rfh$initialize_config_pointers

    VAR
        capabilities: ^ARRAY [1 .. *] of ost$name,
        task_id: ost$global_task_id,
        save_area: ^rft$config_utl_pointers;

    status.normal := TRUE;

    PUSH capabilities: [1..1];
    capabilities^[1] := avc$network_operation;
    rfp$verify_caller_capability(capabilities, 'RHFAM_CONFIGURATION_UTILITY', status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;
    IF  rfv$config_utl_pointers <> NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$multiple_config_command, '', status);
      RETURN;
    IFEND;
    ALLOCATE save_area IN osv$task_private_heap^;
    IF  save_area = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'task private', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$INITIALIZE_CONFIG_POINTERS', status);
      RETURN;
    IFEND;
    IF  (install_request)  THEN
      pmp$get_executing_task_gtid(task_id);
      rfp$lock_table(rfv$status_table.lock);
      IF  (rfv$status_table.install_in_progress_id <> tmv$null_global_task_id)  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$concurrent_installation, '', status);
        rfp$unlock_table(rfv$status_table.lock);
        FREE save_area IN osv$task_private_heap^;
        RETURN;
      ELSE
        rfv$status_table.install_in_progress_id := task_id;
        rfp$unlock_table(rfv$status_table.lock);
      IFEND;
    IFEND;
    save_area^.install_request := install_request;
    save_area^.error_encountered := FALSE;
    save_area^.local_host_defined := FALSE;
    save_area^.autpg_encountered := FALSE;
    save_area^.deflp_encountered := FALSE;
    save_area^.remote_host_count := 0;
    save_area^.local_nad_count := 0;
    save_area^.remote_nad_count := 0;
    save_area^.remote_hosts := NIL;
    save_area^.local_nads := NIL;
    save_area^.remote_nads := NIL;
    save_area^.local_host := NIL;

    rfv$config_utl_pointers := save_area;
    save_info := save_area^;

  PROCEND rfp$initialize_config_pointers;
?? TITLE := '  RFP$PRESERVE_CONFIG_POINTERS' ??
?? EJECT ??
  PROCEDURE  [XDCL, #GATE] rfp$preserve_config_pointers(save_info: rft$config_utl_pointers);

*copyc rfh$preserve_config_pointers

    IF  rfv$config_utl_pointers <> NIL  THEN
      rfv$config_utl_pointers^ := save_info;
    IFEND;
  PROCEND rfp$preserve_config_pointers;
?? TITLE := '  RFP$RETRIEVE_CONFIG_POINTERS' ??
?? EJECT ??
  PROCEDURE  [XDCL, #GATE] rfp$retrieve_config_pointers(VAR save_info: rft$config_utl_pointers);

*copyc rfh$retrieve_config_pointers

    IF  rfv$config_utl_pointers <> NIL  THEN
      save_info := rfv$config_utl_pointers^;
    IFEND;
  PROCEND rfp$retrieve_config_pointers;
?? TITLE := '  RFP$RELEASE_CONFIG_POINTERS' ??
?? EJECT ??
  PROCEDURE  [XDCL, #GATE] rfp$release_config_pointers;

*copyc rfh$release_config_pointers

    VAR
        task_id: ost$global_task_id;

    IF  rfv$config_utl_pointers <> NIL  THEN
      IF  rfv$config_utl_pointers^.install_request  THEN
        pmp$get_executing_task_gtid(task_id);
        rfp$lock_table(rfv$status_table.lock);
        IF  rfv$status_table.install_in_progress_id = task_id  THEN
          rfv$status_table.install_in_progress_id := tmv$null_global_task_id;
        IFEND;
        rfp$unlock_table(rfv$status_table.lock);
      IFEND;
      FREE rfv$config_utl_pointers IN osv$task_private_heap^;
    IFEND;

  PROCEND rfp$release_config_pointers;
MODEND rfm$config_utl_helper;
*DECK DECK=RFM$EXTERNAL_INTERFACE EXPAND=TRUE
*copyc osd$default_pragmats
?? NEWTITLE := 'RHFAM/VE: External Application Interface' ??
?? NEWTITLE := 'Ring Brackets 23D' ??
MODULE rfm$external_interface;
?? NEWTITLE := '  Global Declarations', EJECT ??
?? NEWTITLE := '    Type/Constant Definitions' ??
*copyc rfc$external_interface
*copyc rft$external_interface
*copyc rfe$condition_codes
?? EJECT ??
*copyc rft$rhfam_job_table
?? EJECT ??
*copyc rfk$keypoints
*copyc rft$switched_connection_queue
*copyc rft$file_attributes
*copyc rft$outgoing_control_messages
*copyc rfd$path_status_table
*copyc rft$pp_interface_defs
*copyc rft$rhfam_client_table
*copyc rft$rhfam_event_table
*copyc rft$rhfam_server_table
*copyc rft$r1_interface_defs
?? EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc ame$improper_file_id
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc amt$file_identifier
*copyc bat$task_file_table
*copyc cle$ecc_lexical
*copyc i#ptr
*copyc iot$io_function
*copyc osd$integer_limits
*copyc osk$keypoints
*copyc osk$keypoint_class_codes
*copyc oss$task_shared
?? POP ??

?? TITLE := '    External Variables', EJECT ??

*copyc nav$network_paged_heap
*copyc nav$network_wired_heap
*copyc osv$page_size
*copyc rfv$switched_connection_queue
*copyc rfv$rhfam_job_table
*copyc rfv$rhfam_client_table
*copyc rfv$rhfam_event_table
*copyc rfv$rhfam_server_table
*copyc rfv$status_table
*copyc rfv$system_task_id
*copyc rfv$outstanding_requests
*copyc tmv$null_global_task_id
?? TITLE := '    External Procedures' , EJECT ??

*copyc amp$return
*copyc bap$validate_file_identifier
*copyc clp$construct_path_handle_name
*copyc clp$validate_name
*copyc fmp$create_rhfam_file
*copyc fmp$evaluate_path
*copyc i#ptr
*copyc jmp$job_monitor_xcb
*copyc mmp$advise_out_in
*copyc mmp$verify_access
?? NEWTITLE := ' Overwritten by nap$validate_user' ??
*copyc nap$validate_user
?? OLDTITLE ??
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$begin_subsystem_activity
*copyc osp$clear_job_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$end_subsystem_activity
*copyc osp$i_await_activity
*copyc osp$establish_condition_handler
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc osp$test_set_job_sig_lock
*copyc osp$test_signature_lock
*copyc pmp$find_executing_task_xcb
*copyc pmp$continue_to_cause
*copyc pmp$get_compact_date_time
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_job_names
*copyc pmp$get_microsecond_clock
*copyc pmp$ready_task
*copyc pmp$wait
*copyc pmp$zero_out_table

*copyc rfp$continue_io_request
*copyc rfp$delink_request
*copyc rfp$find_client_entry
*copyc rfp$move_data_to_wired_buffs
*copyc rfp$move_data_from_wired_buffs
*copyc rfp$post_request
*copyc rfp$process_pp_response_flag
*copyc rfp$queue_request
*copyc rfp$release_wired_buffers
*copyc rfp$reserve_wired_buffers
*copyc rfp$re_issue_request
*copyc syp$cycle
*copyc nlv$bm_large_buffer_size
?? TITLE := '    Internal Global Variables' , EJECT ??

      VAR
        rfv$job_entry_pointer: [XDCL, oss$task_shared] ^rft$rhfam_job_table_entry := NIL;


?? OLDTITLE ??
?? TITLE := 'PROCEDURE get_path_handle_name', EJECT ??
  PROCEDURE get_path_handle_name
    (    file: fst$file_reference;
     VAR path_handle_name: fst$path_handle_name;
     VAR status: ost$status);

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
      ignore_cycle_description: ^fmt$cycle_description;

    path_handle_name := '';
    fmp$evaluate_path (file, $bat$process_pt_work_list [bac$resolve_path],
          evaluated_file_reference, ignore_cycle_description, status);
    IF evaluated_file_reference.path_handle_info.path_handle_present THEN
      clp$construct_path_handle_name (evaluated_file_reference.path_handle_info.path_handle,
            path_handle_name);
    IFEND;

  PROCEND get_path_handle_name;
?? TITLE := '  Application Interface Requests', EJECT ??
?? NEWTITLE := '    rfp$accept_connect_request', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$accept_connect_request (connection_file:
        fst$file_reference;
    VAR status: ost$status);

*copy rfh$accept_connect_request

?? NEWTITLE := '      terminate_accept_connect - condition handler', EJECT ??
    PROCEDURE terminate_accept_connect (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

      VAR
        activity_status: ^ost$activity_status,
        current_request: ^rft$outstanding_requests,
        mgmt_status: ^rft$connection_mgmt_status,
        previous_request: ^rft$outstanding_requests;

      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        block_exit_expected := TRUE;
        EXIT rfp$accept_connect_request;
      = pmc$block_exit_processing =
        IF block_exit_expected THEN
          condition_status.normal := TRUE;
        ELSE
          current_request := rfv$outstanding_requests;
        /complete_synchronous_request/
          WHILE current_request <> NIL DO
            IF (current_request^.request_id.ring_1_id.address <> NIL) AND
               (NOT current_request^.request_id.ring_1_id.address^.asynchronous_request) THEN
              mgmt_status := current_request^.request_status;
              activity_status := mgmt_status^.activity_status;
              REPEAT
                #SPOIL (activity_status^);
                syp$cycle;
                rfp$process_pp_response_flag (rfc$pp_response_available);
              UNTIL activity_status^.complete;
              FREE activity_status  IN osv$task_private_heap^;
              current_request := rfv$outstanding_requests;
              EXIT /complete_synchronous_request/;
            IFEND;
            current_request := current_request^.next_entry;
          WHILEND /complete_synchronous_request/;
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, condition_status,
                status);
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          current_request := rfv$outstanding_requests;
          previous_request := NIL;
        /complete_recovered_requests/
          WHILE current_request <> NIL DO
            IF current_request^.request_kind = rfc$rk_accept_connect_request THEN
              mgmt_status := current_request^.request_status;
              FREE mgmt_status^.activity_status IN osv$task_private_heap^;
              IF previous_request = NIL THEN
                rfv$outstanding_requests := current_request^.next_entry;
              ELSE
                previous_request^.next_entry := current_request^.next_entry;
              IFEND;
              FREE mgmt_status IN osv$task_private_heap^;
              FREE current_request IN osv$task_private_heap^;
              EXIT /complete_recovered_requests/;
            IFEND;
            previous_request := current_request;
            current_request := current_request^.next_entry;
          WHILEND /complete_recovered_requests/;
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          block_exit_expected := TRUE;
          EXIT rfp$accept_connect_request;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_accept_connect;
?? OLDTITLE, EJECT ??

    VAR
      activity_status: ^ost$activity_status,
      block_exit_expected: boolean,
      command_identifier: ^rft$logical_commands,
      connection_entry_p: ^rft$connection_entry,
      nad_index: rft$local_nads,
      request_info: ^SEQ ( * ),
      path_handle_name: fst$path_handle_name,
      path_id: ^rft$path_identifier,
      unit_request_status: ^rft$connection_mgmt_status;

    #keypoint (osk$entry, 0, rfk$accept_connect_request);

    block_exit_expected := FALSE;
    osp$establish_condition_handler (^terminate_accept_connect, TRUE);
    status.normal := TRUE;

  /accept_connect_request/
    BEGIN
      get_path_handle_name (connection_file, path_handle_name, status);
      IF NOT status.normal THEN
        EXIT /accept_connect_request/;
      IFEND;

      get_exclusive_to_connection (path_handle_name, connection_entry_p, status);
      IF NOT status.normal THEN
        EXIT /accept_connect_request/;
      IFEND;
      CASE connection_entry_p^.connection_attributes.connection_status.connection_state OF
      = rfc$incoming_connect_active =
      /queue_accept_request/
        BEGIN
          PUSH request_info: [[rft$logical_commands,rft$path_identifier]];
          RESET request_info;
          NEXT command_identifier  IN  request_info;
          IF  command_identifier = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err,
                  'the request overflowed the request sequence', status);
            osp$append_status_parameter(osc$status_parameter_delimiter,
                  'rfp$accept_connect_request', status);
            EXIT  /queue_accept_request/;
          IFEND;
          command_identifier^ := rfc$lc_accept_connect_request;
          NEXT  path_id  IN  request_info;
          IF  path_id = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err,
                  'the request overflowed the request sequence', status);
            osp$append_status_parameter(osc$status_parameter_delimiter,
                  'rfp$accept_connect_request', status);
            EXIT  /queue_accept_request/;
          IFEND;
          path_id^ := connection_entry_p^.connection_descriptor.network_path;
          ALLOCATE unit_request_status IN osv$task_private_heap^;
          IF  unit_request_status = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted,
                  'task private', status);
            osp$append_status_parameter(osc$status_parameter_delimiter,
                  'rfp$accept_connect_request', status);
            EXIT  /queue_accept_request/;
          IFEND;
          unit_request_status^.internal_use := false;
          unit_request_status^.connection := connection_entry_p;

{     The structure activity status is allocated in task private to insure
{     it is writeable by ring 3 code. Pointers to this variable are stored in
{     a task private segment and thus inherit ring 3 privileges.

          ALLOCATE activity_status IN osv$task_private_heap^;
          IF  activity_status = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted,
                  'task private', status);
            osp$append_status_parameter(osc$status_parameter_delimiter,
                  'rfp$accept_connect_request', status);
            EXIT  /queue_accept_request/;
          IFEND;
          unit_request_status^.activity_status := activity_status;
          activity_status^.complete := false;
          activity_status^.status.normal := true;
          #SPOIL (activity_status^);
          nad_index := connection_entry_p^.connection_descriptor.nad_index;
          connection_entry_p^.active_pp_requests := connection_entry_p^.active_pp_requests + 1;
          rfp$unlock_table (connection_entry_p^.lock);
          rfp$queue_request(nad_index, 1, rfc$unit_request, rfc$rk_accept_connect_request,
                unit_request_status, request_info, status);
          IF  NOT status.normal  THEN
            rfp$lock_table(connection_entry_p^.lock);
            connection_entry_p^.active_pp_requests := connection_entry_p^.active_pp_requests - 1;
            EXIT  /queue_accept_request/;
          IFEND;
          REPEAT
            #SPOIL (activity_status^);
            pmp$wait (rfc$unit_request_wait_time,rfc$ur_expected_wait);
            rfp$process_pp_response_flag (rfc$pp_response_available);
          UNTIL activity_status^.complete;
          IF NOT activity_status^.status.normal THEN
            status := activity_status^.status;
          IFEND;
          FREE activity_status IN osv$task_private_heap^;
          EXIT /accept_connect_request/;
        END /queue_accept_request/;
        rfp$unlock_table (connection_entry_p^.lock);

      ELSE
        set_connection_status (connection_entry_p, status);
        rfp$unlock_table (connection_entry_p^.lock);
      CASEND;

    END /accept_connect_request/;

    osp$disestablish_cond_handler;
    IF status.normal THEN
      #keypoint (osk$exit, 0, rfk$accept_connect_request);
    ELSE
      #keypoint (osk$exit, status.condition * osk$m,
            rfk$accept_connect_request);
    IFEND;
  PROCEND rfp$accept_connect_request;
?? TITLE := '    rfp$accept_switch_offer', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$accept_switch_offer (application_name:
        rft$application_name;
        connection_file: fst$file_reference;
        file_attributes: ^rft$change_attributes;
        wait_time: rft$connection_timeout;
    VAR source_job: jmt$system_supplied_name;
    VAR status: ost$status);

*copy rfh$accept_switch_offer

?? NEWTITLE := '      terminate_accept_switch - condition handler', EJECT ??
    PROCEDURE terminate_accept_switch (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$accept_switch_offer;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$accept_switch_offer;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_accept_switch;
?? OLDTITLE, EJECT ??

    VAR
      activity_completed: ost$i_wait_activity,
      application_entry_p: ^rft$application_table_entry,
      application_kind: rft$application_kinds,
      connection_attributes: rft$connection_attributes,
      ignore_status: ost$status,
      job_table_entry_p: ^rft$rhfam_job_table_entry,
      local_file_created: boolean,
      local_source_job: jmt$system_supplied_name,
      local_status: ost$status,
      new_entry: BOOLEAN,
      path_handle_name: fst$path_handle_name,
      ready_index: integer,
      server_entry_p: ^rft$rhfam_server_table_entry,
      switched_connection: ^rft$switched_connection,
      wait_complete: boolean,
      wait_list: ARRAY [ 1.. 2 ] OF ost$i_activity;


    #keypoint (osk$entry, 0, rfk$accept_switch_offer);
    osp$establish_condition_handler (^terminate_accept_switch, FALSE);

    job_table_entry_p := NIL;
    local_file_created := FALSE;
    status.normal := TRUE;

    wait_list [1].activity := rfc$i_await_switch_offer;
    wait_list [1].application_name := application_name;
    wait_list [2].activity := osc$i_await_time;
    wait_list [2].milliseconds := wait_time;
    osp$i_await_activity (wait_list, ready_index, wait_complete, status);

  /accept_switch_offer/
    WHILE status.normal DO
      activity_completed := wait_list [ready_index].activity;
      CASE activity_completed OF
      = rfc$i_await_switch_offer =

{     Verify change_attributes.

        merge_change_attributes (^connection_attributes,
              file_attributes, status);
        IF NOT status.normal THEN
          EXIT /accept_switch_offer/;
        IFEND;

        fmp$create_rhfam_file (connection_file, status);
        IF NOT status.normal THEN
          EXIT /accept_switch_offer/;
        IFEND;
        local_file_created := TRUE;

        get_path_handle_name (connection_file, path_handle_name, status);
        IF NOT status.normal THEN
          EXIT /accept_switch_offer/;
        IFEND;

        rfp$lock_job_table_entry (FALSE, new_entry, job_table_entry_p);
        IF  job_table_entry_p = NIL  THEN
          osp$set_status_abnormal (rfc$product_id, rfe$not_signed_on,
                'Accept switch offer', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, application_name,
                status);
          EXIT /accept_switch_offer/;
        IFEND;

        find_application_entry (application_name, job_table_entry_p, application_entry_p);
        IF application_entry_p = NIL THEN
          osp$set_status_abnormal (rfc$product_id, rfe$not_signed_on,
                'Accept switch offer', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, application_name,
                status);
          EXIT /accept_switch_offer/;
        IFEND;

        IF (NOT application_entry_p^.system_wide_connection_mgmt) AND
           (application_entry_p^.maximum_allowed_connections <=
                application_entry_p^.number_of_active_connections) THEN
          osp$set_status_abnormal (rfc$product_id, rfe$exceeded_connect_limit,
                'Accept switch offer', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                application_name, status);
          EXIT /accept_switch_offer/;
        IFEND;

        get_switched_connection (application_name, switched_connection);
        IF switched_connection <> NIL THEN
          rfp$lock_table (switched_connection^.connection_entry_p^.lock);

          switched_connection^.connection_entry_p^.next_entry :=
                application_entry_p^.connection_table;
          application_entry_p^.connection_table := switched_connection^.connection_entry_p;

          merge_change_attributes (^switched_connection^.connection_entry_p^.connection_attributes,
              file_attributes, ignore_status);
          switched_connection^.connection_entry_p^.connection_name := path_handle_name;
          switched_connection^.connection_entry_p^.application_entry_p := application_entry_p;
          application_entry_p^.number_of_active_connections :=
                application_entry_p^.number_of_active_connections + 1;
          rfp$unlock_table (switched_connection^.connection_entry_p^.lock);
          application_kind := application_entry_p^.application_kind;
          job_table_entry_p^.lock := tmv$null_global_task_id;
          job_table_entry_p := NIL;
          local_source_job := switched_connection^.source_job;

          CASE switched_connection^.source_application_kind OF
          = rfc$server =
            IF application_kind = rfc$partner THEN
              rfp$lock_table (rfv$rhfam_server_table.lock);
              find_server_entry (application_name, FALSE, server_entry_p, local_status);
              IF local_status.normal THEN
                server_entry_p^.partner_job_connections := server_entry_p^.partner_job_connections + 1;
              IFEND;
              rfp$unlock_table (rfv$rhfam_server_table.lock);
            IFEND;
          = rfc$partner =
            IF application_kind = rfc$server THEN
              rfp$lock_table (rfv$rhfam_server_table.lock);
              find_server_entry (application_name, FALSE, server_entry_p, local_status);
              IF local_status.normal THEN
                server_entry_p^.partner_job_connections := server_entry_p^.partner_job_connections - 1;
              IFEND;
              rfp$unlock_table (rfv$rhfam_server_table.lock);
            IFEND
          ELSE
            { No action required.
          CASEND;

          FREE switched_connection IN nav$network_paged_heap^;
          wakeup_accept_switch_waits (local_source_job);
          source_job := local_source_job;
          EXIT /accept_switch_offer/;
        ELSE
          osp$set_status_abnormal (rfc$product_id,
                rfe$no_switch_offered, application_name, status);
        IFEND;
      = osc$i_await_time =
        osp$set_status_abnormal (rfc$product_id,
              rfe$no_switch_offered, application_name, status);
      CASEND;
    WHILEND /accept_switch_offer/;

    IF status.normal THEN
      #keypoint (osk$exit, 0, rfk$accept_switch_offer);
    ELSE
      IF job_table_entry_p <> NIL THEN
        job_table_entry_p^.lock := tmv$null_global_task_id;
      IFEND;
      IF local_file_created THEN
        amp$return (connection_file, ignore_status);
      IFEND;
      #keypoint (osk$exit, status.condition * osk$m,
            rfk$accept_switch_offer);
    IFEND;
  PROCEND rfp$accept_switch_offer;
?? TITLE := '    rfp$acquire_connect_request', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$acquire_connect_request (server_name:
    rft$application_name;
        connection_file: fst$file_reference;
        file_attributes: ^rft$create_attributes;
        wait_time: rft$connection_timeout;
    VAR client_name: rft$application_name;
    VAR source_host_name: rft$host_identifier;
    VAR status: ost$status);

*copy rfh$acquire_connect_request

?? NEWTITLE := '      terminate_acquire_connect - condition handler', EJECT ??
    PROCEDURE terminate_acquire_connect (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$acquire_connect_request;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$acquire_connect_request;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_acquire_connect;
?? OLDTITLE, EJECT ??

    VAR
      access_method_accept: boolean,
      activity_completed: ost$i_wait_activity,
      application_entry_p: ^rft$application_table_entry,
      connection_attributes: rft$connection_attributes,
      connection_entry_p: ^rft$connection_entry,
      job_table_entry_p: ^rft$rhfam_job_table_entry,
      file_attribute_p_valid: boolean,
      ignore_status: ost$status,
      incoming_connect: rft$incoming_connect,
      incoming_connect_available: BOOLEAN,
      local_file_created: BOOLEAN,
      new_entry: BOOLEAN,
      path_handle_name: fst$path_handle_name,
      ready_index: integer,
      wait_complete: boolean,
      wait_list: ARRAY [ 1 .. 2 ] OF ost$i_activity;


    #keypoint (osk$entry, 0, rfk$acquire_connect_request);
    osp$establish_condition_handler (^terminate_acquire_connect, FALSE);


    wait_list [1].activity := rfc$i_await_incoming_connect;
    wait_list [1].application_name := server_name;
    wait_list [2].activity := osc$i_await_time;
    wait_list [2].milliseconds := wait_time;

    job_table_entry_p := NIL;
    local_file_created := FALSE;
    status.normal := TRUE;

    osp$i_await_activity (wait_list, ready_index, wait_complete, status);

    /acquire_connection/
      BEGIN
        activity_completed := wait_list [ready_index].activity;
        CASE activity_completed OF
        = rfc$i_await_incoming_connect =

{     Validate creation file attributes.

          merge_creation_attributes (^connection_attributes,
                file_attributes, status);
          IF NOT status.normal THEN
            EXIT /acquire_connection/;
          IFEND;

{     Create the connection file.

          fmp$create_rhfam_file (connection_file, status);
          IF NOT status.normal THEN
            EXIT /acquire_connection/;
          IFEND;
          local_file_created := TRUE;

          get_path_handle_name (connection_file, path_handle_name, status);
          IF NOT status.normal THEN
            EXIT /acquire_connection/;
          IFEND;

          rfp$lock_job_table_entry (FALSE, new_entry, job_table_entry_p);
          IF  job_table_entry_p = NIL  THEN
            osp$set_status_abnormal (rfc$product_id, rfe$not_signed_on,
                  'Acquire connect request', status);
            osp$append_status_parameter (osc$status_parameter_delimiter, server_name,
                  status);
            EXIT /acquire_connection/;
          IFEND;

{     Get pointer to application table entry and check for application kind
{     of server.

          find_application_entry (server_name, job_table_entry_p, application_entry_p);
          IF application_entry_p = NIL THEN
            osp$set_status_abnormal (rfc$product_id, rfe$not_signed_on,
                  'Acquire connect request', status);
            osp$append_status_parameter (osc$status_parameter_delimiter, server_name,
                  status);
            EXIT /acquire_connection/;
          IFEND;

          IF application_entry_p^.application_kind <> rfc$server THEN
            osp$set_status_abnormal (rfc$product_id, rfe$not_signed_on_as_server,
                  'Acquire connect request', status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  job_table_entry_p^.job_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, server_name,
                  status);
            EXIT /acquire_connection/;
          IFEND;

{         Check for maximum number of connections.

          IF application_entry_p^.maximum_allowed_connections <=
                application_entry_p^.number_of_active_connections THEN
            osp$set_status_abnormal (rfc$product_id, rfe$exceeded_connect_limit,
                   'Acquire connect request', status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  server_name, status);
            EXIT /acquire_connection/;
          IFEND;

{     Get an incoming connect and initialize the connection table.

          get_incoming_connect (server_name, incoming_connect, incoming_connect_available,
                access_method_accept, status);
          IF NOT status.normal THEN
            EXIT /acquire_connection/;
          IFEND;
          IF  incoming_connect_available  THEN
            allocate_connection_entry (application_entry_p, connection_entry_p, status);
            IF NOT status.normal THEN
              EXIT /acquire_connection/;
            IFEND;
            rfp$lock_table (connection_entry_p^.lock);
            job_table_entry_p^.lock := tmv$null_global_task_id;
            job_table_entry_p := NIL;
            IF access_method_accept THEN
              connection_entry_p^.connection_attributes.connection_status.connection_state :=
                  rfc$connected;
              connection_entry_p^.connection_attributes.connection_status.input_available :=
                  FALSE;
              connection_entry_p^.connection_attributes.connection_status.output_below_threshold :=
                  TRUE;
            ELSE
              connection_entry_p^.connection_attributes.connection_status.connection_state :=
                  rfc$incoming_connect_active;
            IFEND;
            connection_entry_p^.connection_name := path_handle_name;
            connection_entry_p^.connection_descriptor := incoming_connect.connection_descriptor;
            pmp$get_microsecond_clock (connection_entry_p^.connection_statistics.connect_time, status);
            connection_entry_p^.connection_statistics.bytes_sent := 0;
            connection_entry_p^.connection_statistics.bytes_received := 0;
            connection_entry_p^.active_pp_requests := 0;
            connection_entry_p^.waiting_tasks := NIL;
            connection_entry_p^.send_request_active := FALSE;
            connection_entry_p^.receive_request_active := FALSE;
            connection_entry_p^.residue_input_data := NIL;
            connection_entry_p^.open_count := 0;

{     Set control message header.

            connection_entry_p^.control_message_header.nad_address :=
                  incoming_connect.connect_message.nad_address;
            connection_entry_p^.control_message_header.local_tcu_enables :=
                  incoming_connect.connect_message.local_tcu_enables;
            connection_entry_p^.control_message_header.destination_device :=
                  incoming_connect.connect_message.destination_device;
            connection_entry_p^.control_message_header.access_code :=
                  incoming_connect.connect_message.access_code;
            connection_entry_p^.control_message_header.name :=
                  incoming_connect.connect_message.name;

{     Set connection attributes.

            connection_entry_p^.connection_attributes.client_name :=
                  incoming_connect.connect_message.requesting_application;
            connection_entry_p^.connection_attributes.server_name := server_name;
            connection_entry_p^.connection_attributes.client_host :=
                  incoming_connect.connect_message.source_physical_id;
            connection_entry_p^.connection_attributes.server_host :=
                  rfv$status_table.local_host^.physical_identifier;
            connection_entry_p^.connection_attributes.connection_timeout :=
                  rfv$status_table.local_host^.connection_timeout * 1000;
            connection_entry_p^.connection_attributes.data_transfer_timeout :=
                  rfv$status_table.local_host^.data_transfer_timeout * 1000;
            connection_entry_p^.connection_attributes.record_block_size :=
                  rfc$default_record_block_size;
            connection_entry_p^.connection_attributes.message_block_size :=
                  rfc$default_message_block_size;
            connection_entry_p^.connection_attributes.incoming_record_abn := 0;
            connection_entry_p^.connection_attributes.outgoing_record_abn := 0;
            connection_entry_p^.connection_attributes.acks_received_count := 0;
            connection_entry_p^.connection_attributes.acks_sent_count := 0;
            connection_entry_p^.connection_attributes.incoming_message_count := 0;
            connection_entry_p^.connection_attributes.outgoing_message_count := 0;
            connection_entry_p^.connection_attributes.receive_record_terminator :=
                  rfc$rm_eoi;
            connection_entry_p^.connection_attributes.file_mark_received :=
                  rfc$rm_null;
            connection_entry_p^.connection_attributes.send_record_terminator :=
                  rfc$rm_eoi;
            connection_entry_p^.connection_attributes.abnormal_termination := FALSE;
            merge_creation_attributes (^connection_entry_p^.connection_attributes,
                  file_attributes, ignore_status);
            rfp$set_connection_entry_p (connection_entry_p, 0, status);
            IF NOT status.normal THEN
              connection_entry_p^.connection_attributes.connection_status.connection_state :=
                    rfc$not_viable;
              rfp$unlock_table (connection_entry_p^.lock);
              EXIT /acquire_connection/;
            IFEND;

{     Set return parameters.

            client_name := connection_entry_p^.connection_attributes.client_name;
            source_host_name.host_identifier_kind := rfc$physical_identifier;
            source_host_name.physical_identifier :=
                  connection_entry_p^.connection_attributes.client_host;
            rfp$unlock_table (connection_entry_p^.lock);
            EXIT /acquire_connection/;
          ELSE
            osp$set_status_abnormal (rfc$product_id,
                  rfe$connection_not_available, server_name, status);
          IFEND;

        = osc$i_await_time =
          osp$set_status_abnormal (rfc$product_id,
                rfe$connection_not_available, server_name, status);
        CASEND;
      END /acquire_connection/;

    IF status.normal THEN
      #keypoint (osk$exit, 0, rfk$acquire_connect_request);
    ELSE
      IF job_table_entry_p <> NIL THEN
        job_table_entry_p^.lock := tmv$null_global_task_id;
      IFEND;
      IF local_file_created THEN
        amp$return (connection_file, ignore_status);
      IFEND;
      #keypoint (osk$exit, status.condition * osk$m,
            rfk$acquire_connect_request);
    IFEND;
  PROCEND rfp$acquire_connect_request;
?? TITLE := '   rfp$application_sign_off', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$application_sign_off (application_name:
    rft$application_name;
    VAR status: ost$status);

*copy rfh$application_sign_off

?? NEWTITLE := '      terminate_sign_off - condition handler', EJECT ??
    PROCEDURE terminate_sign_off (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$application_sign_off;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$application_sign_off;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_sign_off;
?? OLDTITLE, EJECT ??

    VAR
      application_entry_p: ^rft$application_table_entry,
      client_definition_p: ^rft$rhfam_client_table_entry,
      current_entry_p: ^rft$application_table_entry,
      job_table_entry_p: ^rft$rhfam_job_table_entry,
      local_appl_name: rft$application_name,
      maximum_connections: rft$application_connections,
      new_entry: BOOLEAN,
      previous_entry_p: ^rft$application_table_entry,
      system_supplied_name: jmt$system_supplied_name;


    #keypoint (osk$entry, 0, rfk$application_sign_off);
    osp$establish_condition_handler (^terminate_sign_off, FALSE);
    status.normal := TRUE;
    local_appl_name := application_name;

  /main_section/
    BEGIN
      rfp$lock_job_table_entry (FALSE, new_entry, job_table_entry_p);
      IF job_table_entry_p = NIL THEN
        osp$set_status_abnormal (rfc$product_id, rfe$not_signed_on,
              'Application sign off', status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              local_appl_name, status);
        EXIT /main_section/;
      IFEND;
      find_application_entry (local_appl_name, job_table_entry_p,
            application_entry_p);
      IF application_entry_p = NIL THEN
        job_table_entry_p^.lock := tmv$null_global_task_id;
        osp$set_status_abnormal (rfc$product_id, rfe$not_signed_on,
              'Application sign off', status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              local_appl_name, status);
        EXIT /main_section/;
      IFEND;

{     Check for active connections.

      IF application_entry_p^.number_of_active_connections <> 0 THEN
        job_table_entry_p^.lock := tmv$null_global_task_id;
        osp$set_status_abnormal (rfc$product_id,
              rfe$connections_not_terminated, local_appl_name, status);
        EXIT /main_section/;
      IFEND;

{     Remove application table entry.

      maximum_connections := application_entry_p^.maximum_allowed_connections;
      current_entry_p := job_table_entry_p^.application_entry;
      previous_entry_p := NIL;
      system_supplied_name := job_table_entry_p^.job_name;

    /remove_application_entry/
      WHILE current_entry_p <> NIL DO
        IF current_entry_p^.application_name = local_appl_name THEN
          IF previous_entry_p = NIL THEN
            job_table_entry_p^.application_entry := current_entry_p^.next_entry;
            IF current_entry_p^.next_entry = NIL THEN
              remove_job_table_entry(job_table_entry_p);
            IFEND;
          ELSE
            previous_entry_p^.next_entry := current_entry_p^.next_entry;
          IFEND;
          FREE current_entry_p IN nav$network_paged_heap^;
          EXIT /remove_application_entry/;
        IFEND;
        previous_entry_p := current_entry_p;
        current_entry_p := current_entry_p^.next_entry;
      WHILEND /remove_application_entry/;

      IF job_table_entry_p <> NIL THEN
        job_table_entry_p^.lock := tmv$null_global_task_id;
      IFEND;

      CASE application_entry_p^.application_kind OF
      = rfc$client =
        rfp$lock_table (rfv$rhfam_client_table.lock);
        rfp$find_client_entry (local_appl_name, FALSE, client_definition_p, status);
        IF status.normal THEN
          client_definition_p^.connections_reserved := client_definition_p^.
                connections_reserved - maximum_connections;
        IFEND;
        rfp$unlock_table (rfv$rhfam_client_table.lock);
      = rfc$server =
        sign_off_server (local_appl_name, system_supplied_name, maximum_connections,
              status);
      = rfc$partner =
        ;
      CASEND;

    END /main_section/;

    IF status.normal THEN
      #keypoint (osk$exit, 0, rfk$application_sign_off);
    ELSE
      #keypoint (osk$exit, status.condition * osk$m, rfk$application_sign_off);
    IFEND;

  PROCEND rfp$application_sign_off;
?? TITLE := '    rfp$application_sign_on', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$application_sign_on (application_name:
    rft$application_name;
        application_kind: rft$application_kinds;
    VAR maximum_connections: rft$application_connections;
    VAR status: ost$status);

*copy rfh$application_sign_on

?? NEWTITLE := '      terminate_sign_on - condition handler', EJECT ??
    PROCEDURE terminate_sign_on (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$application_sign_on;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$application_sign_on;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_sign_on;
?? OLDTITLE, EJECT ??

    VAR
      application_entry_p: ^rft$application_table_entry,
      capability: ost$name,
      client_definition_p: ^rft$rhfam_client_table_entry,
      first_application_sign_on: boolean,
      job_table_entry_p: ^rft$rhfam_job_table_entry,
      local_appl_kind: rft$application_kinds,
      local_appl_name: rft$application_name,
      local_max_connects: rft$application_connections,
      new_application_entry_p: ^rft$application_table_entry,
      remaining_connections: rft$application_connections,
      ring: ost$ring,
      server_definition_p: ^rft$rhfam_server_table_entry,
      system_privilege: boolean;


    #keypoint (osk$entry, 0, rfk$application_sign_on);
    osp$establish_condition_handler (^terminate_sign_on, FALSE);

    status.normal := TRUE;
    local_max_connects := maximum_connections;
    local_appl_kind := application_kind;
    local_appl_name := application_name;

  /main_section/
    BEGIN
      new_application_entry_p := NIL;
      rfp$lock_job_table_entry (TRUE, first_application_sign_on, job_table_entry_p);
      IF job_table_entry_p = NIL THEN
        osp$set_status_abnormal (rfc$product_id, rfe$heap_exhausted,
              'network paged', status);
        osp$append_status_parameter(osc$status_parameter_delimiter,
              'rfp$application_sign_on', status);
        EXIT /main_section/;
      IFEND;

{     Check for active system task.

      IF NOT rfv$status_table.system_task_is_up THEN
        osp$set_status_abnormal (rfc$product_id,
              rfe$system_task_not_active, 'rfp$application_sign_on', status);
        EXIT /main_section/
      IFEND;

      IF NOT first_application_sign_on  THEN

{     Check for duplicate sign on.

        find_application_entry(application_name, job_table_entry_p, application_entry_p);
        IF  application_entry_p <> NIL  THEN
          osp$set_status_abnormal (rfc$product_id, rfe$already_signed_on,
            application_name, status);
          EXIT /main_section/;
        IFEND;
      IFEND;

{     Allocate application table entry and preset.

      ALLOCATE new_application_entry_p IN nav$network_paged_heap^;
      IF new_application_entry_p = NIL THEN
        osp$set_status_abnormal (rfc$product_id, rfe$heap_exhausted,
              'network paged', status);
        osp$append_status_parameter(osc$status_parameter_delimiter,
              'rfp$application_sign_on', status);
        EXIT /main_section/;
      IFEND;


{     Preset new application table entry

      new_application_entry_p^.next_entry := NIL;
      new_application_entry_p^.application_name := local_appl_name;
      new_application_entry_p^.application_kind := local_appl_kind;
      new_application_entry_p^.number_of_active_connections := 0;
      new_application_entry_p^.connection_table := NIL;
      new_application_entry_p^.system_wide_connection_mgmt := FALSE;

      CASE local_appl_kind OF
      = rfc$client =
        rfp$lock_table (rfv$rhfam_client_table.lock);
        rfp$find_client_entry (application_name, TRUE, client_definition_p, status);
        IF status.normal THEN
          nap$validate_user (client_definition_p^.client_capability, client_definition_p^.client_ring,
                client_definition_p^.client_system_privilege, status);
          IF status.normal THEN
            new_application_entry_p^.system_wide_connection_mgmt :=
                             client_definition_p^.system_wide_connection_mgmt;
            remaining_connections := client_definition_p^.maximum_connections -
                  client_definition_p^.connections_reserved;
            IF local_max_connects = 0 THEN
              local_max_connects := remaining_connections;
            ELSE
              IF remaining_connections <  local_max_connects THEN
                osp$set_status_abnormal (rfc$product_id, rfe$defined_connects_exceeded,
                      application_name, status);
                osp$append_status_integer (osc$status_parameter_delimiter, local_max_connects,
                      10, FALSE, status);
              IFEND;
            IFEND;
            IF status.normal THEN
              new_application_entry_p^.maximum_allowed_connections := local_max_connects;
              client_definition_p^.connections_reserved := client_definition_p^.connections_reserved +
                    local_max_connects;
            IFEND;
          IFEND;
        IFEND;
        rfp$unlock_table (rfv$rhfam_client_table.lock);
      = rfc$server =
        rfp$lock_table (rfv$rhfam_server_table.lock);
        find_server_entry (application_name, TRUE, server_definition_p, status);
        IF status.normal THEN
          nap$validate_user (server_definition_p^.server_capability, server_definition_p^.server_ring,
                server_definition_p^.server_system_privilege, status);
          IF status.normal THEN
            sign_on_server (server_definition_p, job_table_entry_p^.job_name, local_max_connects,
                    status);
            new_application_entry_p^.maximum_allowed_connections := local_max_connects;
          IFEND;
        IFEND;
        rfp$unlock_table (rfv$rhfam_server_table.lock);
      =rfc$partner =
        rfp$lock_table (rfv$rhfam_server_table.lock);
        find_server_entry (application_name, TRUE, server_definition_p, status);
        IF status.normal THEN
          capability := server_definition_p^.server_capability;
          ring := server_definition_p^.server_ring;
          system_privilege := server_definition_p^.server_system_privilege;
          local_max_connects := server_definition_p^.maximum_connections;
          rfp$unlock_table (rfv$rhfam_server_table.lock);
        ELSE
          rfp$unlock_table (rfv$rhfam_server_table.lock);
          rfp$lock_table (rfv$rhfam_client_table.lock);
          rfp$find_client_entry (application_name, TRUE, client_definition_p, status);
          IF status.normal THEN
            capability := client_definition_p^.client_capability;
            ring := client_definition_p^.client_ring;
            system_privilege := client_definition_p^.client_system_privilege;
            local_max_connects := client_definition_p^.maximum_connections;
          IFEND;
          rfp$unlock_table (rfv$rhfam_client_table.lock);
        IFEND;
        IF status.normal THEN
          new_application_entry_p^.maximum_allowed_connections := local_max_connects;
          nap$validate_user (capability, ring, system_privilege, status);
        IFEND;
      ELSE
        osp$set_status_abnormal (rfc$product_id, rfe$invalid_application_kind,
              'application sign on', status);
      CASEND;

      IF status.normal THEN

{     Add new application table entry to this jobs application table.

        new_application_entry_p^.next_entry := job_table_entry_p^.application_entry;
        job_table_entry_p^.application_entry := new_application_entry_p;
        job_table_entry_p^.lock := tmv$null_global_task_id;
      IFEND;

    END /main_section/;

    IF status.normal THEN
      maximum_connections := local_max_connects;
      #keypoint (osk$exit, 0, rfk$application_sign_on);
    ELSE
      IF job_table_entry_p <> NIL THEN
        IF first_application_sign_on THEN
          remove_job_table_entry(job_table_entry_p);
        ELSE
          job_table_entry_p^.lock := tmv$null_global_task_id;
        IFEND;
        IF new_application_entry_p <> NIL THEN
          FREE new_application_entry_p IN nav$network_paged_heap^;
        IFEND;
      IFEND;
      #keypoint (osk$exit, status.condition * osk$m, rfk$application_sign_on);
    IFEND;

  PROCEND rfp$application_sign_on;
?? TITLE := '    rfp$await_rhfam_event', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$await_rhfam_event (connection_identifier:
    amt$file_identifier;
        event: rft$connection_events;
        wait_time: rft$connection_timeout;
    VAR status: ost$status);

*copy rfh$await_rhfam_event

?? NEWTITLE := '      terminate_await_event - condition handler', EJECT ??
    PROCEDURE terminate_await_event (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$await_rhfam_event;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$await_rhfam_event;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_await_event;
?? OLDTITLE, EJECT ??

    VAR
      activity_completed: ost$i_wait_activity,
      ready_index: integer,
      wait_complete: boolean,
      wait_list: ARRAY [ 1 .. 2 ] OF ost$i_activity;


    #keypoint (osk$entry, 0, rfk$await_rhfam_event);
    osp$establish_condition_handler (^terminate_await_event, FALSE);

    status.normal := TRUE;
    wait_list [1].activity := rfc$i_await_connection_event;
    wait_list [1].connection_file_identifier := connection_identifier;
    wait_list [1].event_type := event;
    wait_list [2].activity := osc$i_await_time;
    wait_list [2].milliseconds := wait_time;
    osp$i_await_activity (wait_list, ready_index, wait_complete, status);

    IF status.normal THEN
      activity_completed := wait_list [ready_index].activity;
      CASE activity_completed OF
      = rfc$i_await_connection_event =
        ;
      = osc$i_await_time =
          osp$set_status_abnormal (rfc$product_id, rfe$no_available_event,
                '', status);
      CASEND;
    IFEND;

    IF status.normal THEN
      #keypoint (osk$exit, 0, rfk$await_rhfam_event);
    ELSE
      #keypoint (osk$exit, status.condition * osk$m, rfk$await_rhfam_event);
    IFEND;
  PROCEND rfp$await_rhfam_event;
?? TITLE := '    rfp$await_server_response', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$await_server_response (connection_file:
        fst$file_reference;
        wait_time: rft$connection_timeout;
    VAR server_response: rft$server_response;
    VAR status: ost$status);

*copy rfh$await_server_response

?? NEWTITLE := '      terminate_await_server - condition handler', EJECT ??
    PROCEDURE terminate_await_server (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$await_server_response;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$await_server_response;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_await_server;
?? OLDTITLE, EJECT ??

    VAR
      connection_attributes: ^rft$connection_attributes,
      connection_entry_p: ^rft$connection_entry,
      first_wait: boolean,
      path_handle_name: fst$path_handle_name,
      ready_index: integer,
      remote_host: rft$logical_identifier,
      wait_complete: boolean,
      wait_list: ARRAY [ 1 .. 2 ] OF ost$i_activity;


    #keypoint (osk$entry, 0, rfk$await_server_response);
    osp$establish_condition_handler (^terminate_await_server, FALSE);

    status.normal := TRUE;
    first_wait := TRUE;

    get_path_handle_name (connection_file, path_handle_name, status);
    IF NOT status.normal THEN
      #keypoint (osk$exit, status.condition * osk$m,
            rfk$await_server_response);
      EXIT rfp$await_server_response;
    IFEND;

  /await_server_response/
    WHILE status.normal DO
      get_exclusive_to_connection (path_handle_name, connection_entry_p, status);
      IF NOT status.normal THEN
        EXIT /await_server_response/;
      IFEND;
      connection_attributes := ^connection_entry_p^.connection_attributes;
      CASE connection_attributes^.connection_status.connection_state OF
      = rfc$connected =
        rfp$unlock_table (connection_entry_p^.lock);
        status.normal := TRUE;
        server_response.server_response_kind := rfc$accept;
        EXIT /await_server_response/;
      = rfc$outgoing_connect_active =
        IF first_wait THEN
          rfp$unlock_table (connection_entry_p^.lock);
          first_wait := FALSE;
          wait_list [1].activity := rfc$i_await_server_response;
          wait_list [1].file := ^connection_file;
          wait_list [2].activity := osc$i_await_time;
          wait_list [2].milliseconds := wait_time;
          osp$i_await_activity (wait_list, ready_index, wait_complete, status);
          IF status.normal THEN
            CASE wait_list[ready_index].activity OF
            = rfc$i_await_server_response =
              CYCLE /await_server_response/;
            = osc$i_await_time =
              osp$set_status_abnormal (rfc$product_id, rfe$no_server_response,
                    path_handle_name, status);
              EXIT /await_server_response/;
            CASEND;
          ELSE
            status.normal := TRUE;
            CYCLE /await_server_response/;
          IFEND;
        ELSE
          osp$set_status_abnormal (rfc$product_id, rfe$no_server_response,
                path_handle_name, status);
        IFEND;
      = rfc$connect_rejected =
        CASE connection_attributes^.destination_host.host_identifier_kind OF
          = rfc$logical_identifier =
            remote_host := connection_attributes^.destination_host.logical_identifier;
          = rfc$physical_identifier =
            remote_host := connection_attributes^.destination_host.physical_identifier;
        ELSE
          ;     { This should never happen }
        CASEND;
        CASE connection_attributes^.connection_status.server_response OF
        = rfc$nbp_requested_server_busy, rfc$nbp_server_unavailable =
          osp$set_status_abnormal (rfc$product_id, rfe$server_busy,
                remote_host, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                connection_attributes^.server_name, status);
        = rfc$nbp_requested_host_busy =
          osp$set_status_abnormal (rfc$product_id, rfe$remote_host_busy, remote_host,
                status);
        = rfc$nbp_server_disabled =
          osp$set_status_abnormal (rfc$product_id, rfe$server_disabled,
                remote_host, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                connection_attributes^.server_name, status);
        = rfc$nbp_server_lid_disabled, rfc$nbp_pid_lid_not_available =
          osp$set_status_abnormal (rfc$product_id, rfe$server_lid_disabled,
                connection_attributes^.server_host, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                remote_host, status);
        = rfc$nbp_client_disabled =
          osp$set_status_abnormal (rfc$product_id, rfe$client_disabled,
                remote_host, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                connection_attributes^.client_name, status);
        = rfc$nbp_client_pid_disabled =
          osp$set_status_abnormal (rfc$product_id, rfe$client_pid_disabled,
                remote_host, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                connection_attributes^.client_host, status);
        = rfc$nbp_client_nad_disabled =
          osp$set_status_abnormal (rfc$product_id, rfe$client_nad_disabled,
                remote_host, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                rfv$status_table.local_nads^ [connection_entry_p^.connection_descriptor.nad_index]
                .name, status);
        = rfc$nbp_tcu_disabled =
          osp$set_status_abnormal (rfc$product_id, rfe$tcu_disabled,
                remote_host, status);
        = rfc$nbp_rhf_not_active =
          osp$set_status_abnormal (rfc$product_id, rfe$rhf_not_active,
                remote_host, status);
        = rfc$nbp_rhf_shutdown, rfc$nbp_shutdown =
              osp$set_status_abnormal (rfc$product_id, rfe$remote_rhf_shutdown,
                    remote_host, status);
        = rfc$nbp_server_undefined =
          osp$set_status_abnormal (rfc$product_id, rfe$server_undefined,
                remote_host, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                connection_attributes^.server_name, status);
        = rfc$nbp_server_lid_undefined =
          osp$set_status_abnormal (rfc$product_id, rfe$server_lid_undefined,
                remote_host, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                remote_host, status);
        = rfc$nbp_client_undefined, rfc$nbp_requesting_appl_unknown =
          osp$set_status_abnormal (rfc$product_id, rfe$client_undefined,
                remote_host, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                connection_attributes^.client_name, status);
        = rfc$nbp_client_pid_undefined =
          osp$set_status_abnormal (rfc$product_id, rfe$client_pid_undefined,
                remote_host, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                connection_attributes^.client_host, status);
        = rfc$nbp_password_undefined, rfc$nbp_invalid_password =
          osp$set_status_abnormal (rfc$product_id, rfe$password_undefined,
                remote_host, status);
        = rfc$nbp_client_nad_undefined =
          osp$set_status_abnormal (rfc$product_id, rfe$client_nad_undefined,
                remote_host, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                rfv$status_table.local_nads^ [connection_entry_p^.connection_descriptor.nad_index]
                .name, status);
        = rfc$nbp_access_code_invalid =
          osp$set_status_abnormal (rfc$product_id, rfe$access_code_invalid,
                remote_host, status);
        = rfc$nbp_device_invalid =
          osp$set_status_abnormal (rfc$product_id, rfe$device_invalid,
                remote_host, status);
        = rfc$nbp_tcu_invalid =
          osp$set_status_abnormal (rfc$product_id, rfe$tcu_invalid,
                remote_host, status);

{     Discontinued reject codes.

        = rfc$nbp_path_unavailable =
          osp$set_status_abnormal (rfc$product_id, rfe$client_nad_disabled,
                remote_host, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                rfv$status_table.local_nads^ [connection_entry_p^.connection_descriptor.nad_index]
                .name, status);
        = rfc$nbp_resources_not_available =
          osp$set_status_abnormal (rfc$product_id, rfe$server_busy,
                remote_host, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                connection_attributes^.server_name, status);

{     Server reject codes.

        = rfc$min_server_reject_code .. rfc$max_server_reject_code =
          osp$set_status_abnormal (rfc$product_id, rfe$server_reject_response,
                connection_attributes^.server_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                remote_host, status);
          server_response.server_response_kind := rfc$reject;
          server_response.server_reject_code := connection_attributes^.
                connection_status.server_response;
        ELSE
          osp$set_status_abnormal (rfc$product_id, rfe$unknown_reject_code,
                remote_host, status);
          osp$append_status_integer (osc$status_parameter_delimiter, connection_attributes^.
                connection_status.server_response, 10, FALSE, status);
        CASEND;
        osp$append_status_parameter (osc$status_parameter_delimiter,
              connection_entry_p^.connection_name, status);
      ELSE
        set_connection_status (connection_entry_p, status);
      CASEND;
      rfp$unlock_table (connection_entry_p^.lock);

    WHILEND /await_server_response/;

    IF status.normal THEN
      #keypoint (osk$exit, 0, rfk$await_server_response);
    ELSE
      #keypoint (osk$exit, status.condition * osk$m,
            rfk$await_server_response);
    IFEND;
  PROCEND rfp$await_server_response;
?? TITLE := '    rfp$cancel_switch_offer', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$cancel_switch_offer (connection_file:
        fst$file_reference;
    VAR status: ost$status);

*copy rfh$cancel_switch_offer

?? NEWTITLE := '      terminate_cancel_switch - condition handler', EJECT ??
    PROCEDURE terminate_cancel_switch (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$cancel_switch_offer;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$cancel_switch_offer;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_cancel_switch;
?? OLDTITLE, EJECT ??

    VAR
      connection_entry_p: ^rft$connection_entry,
      job_table_entry_p: ^rft$rhfam_job_table_entry,
      path_handle_name: fst$path_handle_name;


    #keypoint (osk$entry, 0, rfk$cancel_switch_offer);
    osp$establish_condition_handler (^terminate_cancel_switch, FALSE);
    status.normal := TRUE;

  /cancel_switch_offer/
    BEGIN
      get_path_handle_name (connection_file, path_handle_name, status);
      IF NOT status.normal THEN
        EXIT /cancel_switch_offer/;
      IFEND;
      get_exclusive_to_job (path_handle_name, job_table_entry_p,
            connection_entry_p, status);
      IF NOT status.normal THEN
        EXIT /cancel_switch_offer/;
      IFEND;

      CASE connection_entry_p^.connection_attributes.connection_status.connection_state OF
      = rfc$switch_offered =
        remove_switch_offer (job_table_entry_p^.job_name, connection_entry_p);
        IF connection_entry_p^.connection_attributes.connection_status.
              connection_state = rfc$switch_accepted THEN
          set_connection_status (connection_entry_p, status);
        IFEND;
      ELSE
        set_connection_status (connection_entry_p, status);
      CASEND;
      rfp$unlock_table (connection_entry_p^.lock);
      job_table_entry_p^.lock := tmv$null_global_task_id;
    END /cancel_switch_offer/;

    IF status.normal THEN
      #keypoint (osk$exit, 0, rfk$cancel_switch_offer);
    ELSE
      #keypoint (osk$exit, status.condition * osk$m,
            rfk$cancel_switch_offer);
    IFEND;
  PROCEND rfp$cancel_switch_offer;
?? TITLE := '    rfp$find_available_service', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$find_available_service (server_name:
    rft$application_name;
        destination_host: rft$host_identifier;
    VAR host_identifiers: rft$destination_hosts;
    VAR number_of_hosts: rft$number_of_hosts;
    VAR status: ost$status);

*copy rfh$find_available_service

?? NEWTITLE := '      terminate_find_service - condition handler', EJECT ??
    PROCEDURE terminate_find_service (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$find_available_service;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$find_available_service;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_find_service;
?? OLDTITLE, EJECT ??


    VAR
      host_identifier_p: ^rft$destination_hosts,
      map_lid_to_pid: boolean,
      selected_path_p: ^rft$lcn_path_definition,
      selected_pid: rft$physical_identifier,
      server_available_locally: boolean,
      server_entry_p: ^rft$rhfam_server_table_entry;

    #keypoint (osk$entry, 0, rfk$find_available_service);
    osp$establish_condition_handler (^terminate_find_service, FALSE);

    status.normal := TRUE;
    server_available_locally := FALSE;
    rfp$lock_table (rfv$rhfam_server_table.lock);
    find_server_entry (server_name, TRUE, server_entry_p, status);
    IF status.normal THEN
      server_available_locally := TRUE;
    IFEND;
    rfp$unlock_table (rfv$rhfam_server_table.lock);

    rfp$lock_table (rfv$status_table.lock);
    IF rfv$status_table.system_task_is_up THEN
      host_identifier_p := ^host_identifiers;
      search_for_path (server_name, destination_host, server_available_locally,
            selected_path_p, selected_pid, host_identifier_p, number_of_hosts,
            map_lid_to_pid, status);
    ELSE
      osp$set_status_abnormal (rfc$product_id,
            rfe$system_task_not_active, 'rfp$find_available_service', status);
    IFEND;
    rfp$unlock_table (rfv$status_table.lock);

    IF status.normal THEN
      #keypoint (osk$exit, 0, rfk$find_available_service);
    ELSE
      #keypoint (osk$exit, status.condition * osk$m,
            rfk$find_available_service);
    IFEND;
  PROCEND rfp$find_available_service;
?? TITLE := '    rfp$offer_connection_switch', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$offer_connection_switch (connection_file:
        fst$file_reference;
        destination_job: jmt$system_supplied_name;
        wait_time: rft$connection_timeout;
    VAR status: ost$status);

*copy rfh$offer_connection_switch


?? NEWTITLE := '      terminate_offer_connection - condition handler', EJECT ??
    PROCEDURE terminate_offer_connection (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      VAR
        activity_status: ^ost$activity_status,
        current_request: ^rft$outstanding_requests,
        mgmt_status: ^rft$connection_mgmt_status,
        previous_request: ^rft$outstanding_requests;

      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        block_exit_expected := TRUE;
        EXIT rfp$offer_connection_switch;
      = pmc$block_exit_processing =
        IF block_exit_expected THEN
          condition_status.normal := TRUE;
        ELSE
          current_request := rfv$outstanding_requests;
        /complete_synchronous_request/
          WHILE current_request <> NIL DO
            IF (current_request^.request_id.ring_1_id.address <> NIL) AND
               (NOT current_request^.request_id.ring_1_id.address^.asynchronous_request) THEN
              mgmt_status := current_request^.request_status;
              activity_status := mgmt_status^.activity_status;
              REPEAT
                #SPOIL (activity_status^);
                syp$cycle;
                rfp$process_pp_response_flag (rfc$pp_response_available);
              UNTIL activity_status^.complete;
              FREE activity_status  IN osv$task_private_heap^;
              current_request := rfv$outstanding_requests;
              EXIT /complete_synchronous_request/;
            IFEND;
            current_request := current_request^.next_entry;
          WHILEND /complete_synchronous_request/;
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, condition_status,
                status);
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          current_request := rfv$outstanding_requests;
          previous_request := NIL;
        /complete_recovered_requests/
          WHILE current_request <> NIL DO
            IF current_request^.request_kind = rfc$rk_path_status THEN
              mgmt_status := current_request^.request_status;
              FREE mgmt_status^.activity_status IN osv$task_private_heap^;
              IF previous_request = NIL THEN
                rfv$outstanding_requests := current_request^.next_entry;
              ELSE
                previous_request^.next_entry := current_request^.next_entry;
              IFEND;
              FREE mgmt_status IN osv$task_private_heap^;
              FREE current_request IN osv$task_private_heap^;
              EXIT /complete_recovered_requests/;
            IFEND;
            previous_request := current_request;
            current_request := current_request^.next_entry;
          WHILEND /complete_recovered_requests/;
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          block_exit_expected := TRUE;
          EXIT rfp$offer_connection_switch;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_offer_connection;
?? OLDTITLE, EJECT ??


    VAR
      block_exit_expected: boolean,
      connection_entry_p: ^rft$connection_entry,
      connection_unlocked: boolean,
      input_available: boolean,
      job_table_entry_p: ^rft$rhfam_job_table_entry,
      local_destination_job: jmt$system_supplied_name,
      path_handle_name: fst$path_handle_name,
      ready_index: integer,
      wait_complete: boolean,
      wait_list: ARRAY [ 1 .. 2 ] OF ost$i_activity;

    #keypoint (osk$entry, 0, rfk$offer_connection_switch);
    block_exit_expected := FALSE;
    osp$establish_condition_handler (^terminate_offer_connection, TRUE);
    status.normal := TRUE;
    local_destination_job := destination_job;

  /offer_connection_switch/
    BEGIN
    get_path_handle_name (connection_file, path_handle_name, status);
    IF NOT status.normal THEN
      EXIT /offer_connection_switch/;
    IFEND;

    get_exclusive_to_job (path_handle_name, job_table_entry_p,
          connection_entry_p, status);
    IF NOT status.normal THEN
      EXIT /offer_connection_switch/;
    IFEND;

    update_connection_status(connection_entry_p, input_available,
          connection_unlocked, status);

{     During the connection process, an application may be able
{     to get to this code before the system task has time to
{     update the path status table with the correct path state.
{     If this occurs, update_connection_status will unlock the
{     connection and retrieve the path status.  If this case the
{     status returned will be normal but the connection will be
{     unlocked and it is assumed that the connection state in the
{     connection entry is correct.

    IF connection_unlocked THEN
      IF status.normal THEN
        job_table_entry_p^.lock := tmv$null_global_task_id;
        get_exclusive_to_job (path_handle_name, job_table_entry_p,
              connection_entry_p, status);
        IF NOT status.normal THEN
          EXIT /offer_connection_switch/;
        IFEND;
      ELSE
        job_table_entry_p^.lock := tmv$null_global_task_id;
        EXIT /offer_connection_switch/;
      IFEND;
    IFEND;

    CASE connection_entry_p^.connection_attributes.
          connection_status.connection_state OF
    = rfc$connected =
      IF connection_entry_p^.open_count <> 0 THEN
        rfp$unlock_table (connection_entry_p^.lock);
        job_table_entry_p^.lock := tmv$null_global_task_id;
        osp$set_status_abnormal (rfc$product_id, rfe$file_not_closed,
              path_handle_name, status);
        EXIT /offer_connection_switch/;
      IFEND;
      enter_switched_connect_queue  (local_destination_job, connection_entry_p, status);
      IF NOT status.normal THEN
        rfp$unlock_table (connection_entry_p^.lock);
        job_table_entry_p^.lock := tmv$null_global_task_id;
        EXIT /offer_connection_switch/;
      IFEND;
      wakeup_wait_switch_offers (connection_entry_p^.application_entry_p^.application_name);
      IF wait_time <> 0 THEN
        rfp$unlock_table (connection_entry_p^.lock);
        job_table_entry_p^.lock := tmv$null_global_task_id;
        wait_list[1].activity := rfc$i_await_switch_accept;
        wait_list[1].connection_file := ^connection_file;
        wait_list[2].activity := osc$i_await_time;
        wait_list[2].milliseconds := wait_time;
        osp$i_await_activity (wait_list, ready_index, wait_complete, status);
        IF status.normal THEN
          CASE wait_list[ready_index].activity OF
          = rfc$i_await_switch_accept =
            ;
          = osc$i_await_time =
            osp$set_status_abnormal (rfc$product_id, rfe$switch_offer_not_accepted,
                  path_handle_name, status);
          CASEND;
        IFEND;
      ELSE
        rfp$unlock_table (connection_entry_p^.lock);
        job_table_entry_p^.lock := tmv$null_global_task_id;
        osp$set_status_abnormal (rfc$product_id, rfe$switch_offer_not_accepted,
              path_handle_name, status);
      IFEND;
    ELSE
      set_connection_status( connection_entry_p, status);
      rfp$unlock_table (connection_entry_p^.lock);
      job_table_entry_p^.lock := tmv$null_global_task_id;
    CASEND;
    END /offer_connection_switch/;
    osp$disestablish_cond_handler;

    IF status.normal THEN
      #keypoint (osk$exit, 0, rfk$offer_connection_switch);
    ELSE
      #keypoint (osk$exit, status.condition * osk$m, rfk$offer_connection_switch);
    IFEND;
  PROCEND rfp$offer_connection_switch;
?? TITLE := '    rfp$receive_data', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$receive_data (connection_identifier:
    amt$file_identifier;
        transmission_mode: rft$transmission_modes;
        data_buffer: rft$data_buffers;
        wait: ost$wait;
    VAR activity: ost$activity_status;
    VAR data_received: rft$bytes_transferred;
    VAR end_of_message: boolean;
    VAR status: ost$status);

*copy rfh$receive_data


{     NOTE: If this routine is to be called at a ring level below ring3,
{       the VAR parameters must be allocated in a segment that is
{       writable by ring 3 code.  Pointers to this variable are stored in
{       a task private segment and thus inherit ring 3 privileges.


?? NEWTITLE := '      terminate_receive_data - condition handler', EJECT ??
    PROCEDURE terminate_receive_data (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

      VAR
        activities: rft$set_of_async_activities,
        activity_status: ^ost$activity_status,
        current_request: ^rft$outstanding_requests,
        local_status: ost$status,
        mgmt_status: ^rft$connection_mgmt_status,
        previous_request: ^rft$outstanding_requests,
        transfer_status: ^rft$data_transfer_status;

      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        IF wait = osc$wait THEN
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
        ELSE
          osp$set_status_from_condition (rfc$product_id, condition, sfsa,
                activity.status, condition_status);
          activity.complete := TRUE;
        IFEND;
        block_exit_expected := TRUE;
        EXIT rfp$receive_data;
      = pmc$block_exit_processing =
        IF block_exit_expected THEN
          condition_status.normal := TRUE;
        ELSE
          activities := $rft$set_of_async_activities[rfc$aa_receive_data];
          terminate_async_activity (activities, connection_name);
          current_request := rfv$outstanding_requests;
          WHILE current_request <> NIL DO
            IF current_request^.request_kind = rfc$rk_path_status THEN
              mgmt_status := current_request^.request_status;
              activity_status := mgmt_status^.activity_status;
              current_request := current_request^.next_entry;
              syp$cycle;
              rfp$process_pp_response_flag (rfc$pp_response_available);
              IF activity_status^.complete THEN
                FREE activity_status  IN osv$task_private_heap^;
              IFEND;
              current_request := rfv$outstanding_requests;
            ELSEIF current_request^.request_kind = rfc$rk_receive_data THEN
              transfer_status := current_request^.request_status;
              activity_status := transfer_status^.activity_status;
              current_request := current_request^.next_entry;
              IF transfer_status^.connection_name = connection_name THEN
                syp$cycle;
                rfp$process_pp_response_flag (rfc$pp_response_available);
                current_request := rfv$outstanding_requests;
              IFEND;
            ELSE
              current_request := current_request^.next_entry;
            IFEND;
          WHILEND;
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, condition_status,
                local_status);
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          current_request := rfv$outstanding_requests;
          previous_request := NIL;
        /complete_recovered_requests/
          WHILE current_request <> NIL DO
            IF current_request^.request_kind = rfc$rk_path_status THEN
              mgmt_status := current_request^.request_status;
              FREE mgmt_status^.activity_status IN osv$task_private_heap^;
              IF previous_request = NIL THEN
                rfv$outstanding_requests := current_request^.next_entry;
              ELSE
                previous_request^.next_entry := current_request^.next_entry;
              IFEND;
              FREE mgmt_status IN osv$task_private_heap^;
              FREE current_request IN osv$task_private_heap^;
              EXIT /complete_recovered_requests/;
            ELSEIF current_request^.request_kind = rfc$rk_receive_data THEN
              transfer_status := current_request^.request_status;
              IF previous_request = NIL THEN
                rfv$outstanding_requests := current_request^.next_entry;
              ELSE
                previous_request^.next_entry := current_request^.next_entry;
              IFEND;
              FREE transfer_status IN osv$task_private_heap^;
              FREE current_request IN osv$task_private_heap^;
              EXIT /complete_recovered_requests/;
            IFEND;
            previous_request := current_request;
            current_request := current_request^.next_entry;
          WHILEND /complete_recovered_requests/;
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          IF wait = osc$wait THEN
            osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                  condition_status);
          ELSE
            osp$set_status_from_condition (rfc$product_id, condition, sfsa,
                  activity.status, condition_status);
            activity.complete := TRUE;
          IFEND;
          block_exit_expected := TRUE;
          EXIT rfp$receive_data;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_receive_data;
?? OLDTITLE, EJECT ??

    VAR
      activity_completed: ost$i_wait_activity,
      block_exit_expected: boolean,
      cell_to_verify: ^^cell,
      connection_entry_p: ^rft$connection_entry,
      connection_name: fst$path_handle_name,
      connection_status: rft$connection_status,
      connection_unlocked: boolean,
      data_length: rft$data_length,
      data_transfer_status: ^rft$data_transfer_status,
      index: integer,
      input_available: boolean,
      last_data_cell: ^cell,
      local_status: ost$status,
      network_wired_data: boolean,
      number_of_fragments: integer,
      pva_valid: boolean,
      ready_index: integer,
      receive_request_active: boolean,
      residue_input_data: ^rft$residue_data,
      starting_fragment: rft$data_fragment_count,
      wait_complete: boolean,
      wait_list: ARRAY [ 1 .. 2 ] OF ost$i_activity,
      write_only_pva: boolean;


    #keypoint (osk$entry, 0, rfk$receive_data);
    block_exit_expected := FALSE;
    osp$establish_condition_handler (^terminate_receive_data, TRUE);
    status.normal := TRUE;
    activity.complete := FALSE;
    activity.status.normal := TRUE;
    data_received := 0;
    end_of_message := FALSE;

    /main_program/
    BEGIN

{     Validate data fragments.

      data_length := 0;
      number_of_fragments := 0;
      write_only_pva := FALSE;
      starting_fragment := LOWERBOUND(data_buffer^);
      cell_to_verify := ^last_data_cell;
      /validate_data_fragments/
      FOR index := LOWERBOUND(data_buffer^) TO UPPERBOUND(data_buffer^) DO
        IF data_buffer^[index].length > 0 THEN
          last_data_cell := i#ptr(data_buffer^[index].length,
                data_buffer^[index].address);
          pva_valid := mmp$verify_access (cell_to_verify, mmc$va_read_write);
          IF NOT pva_valid THEN
            pva_valid := mmp$verify_access (cell_to_verify, mmc$va_write);
            IF NOT pva_valid THEN
              osp$set_status_abnormal(rfc$product_id, rfe$invalid_data_fragment,
                    'receive data', status);
              EXIT /main_program/;
            IFEND;
            write_only_pva := TRUE;
          IFEND;
          IF number_of_fragments = 0 THEN
            starting_fragment := index;
          IFEND;
          number_of_fragments := number_of_fragments + 1;
          data_length := data_length + data_buffer^[index].length;
        IFEND;
      FOREND /validate_data_fragments/;

      IF number_of_fragments = 0 THEN
        osp$set_status_abnormal(rfc$product_id, rfe$invalid_data_fragment,
              'receive data', status);
        EXIT /main_program/;
      IFEND;

      /wait_for_input_available/
      REPEAT
        /wait_for_active_receive/
        REPEAT
          get_exclusive_to_cid (connection_identifier, connection_entry_p, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

          receive_request_active := connection_entry_p^.receive_request_active;
          IF receive_request_active THEN
            IF wait = osc$wait THEN
              enter_waiting_task_queue(connection_entry_p, local_status);
              rfp$unlock_table (connection_entry_p^.lock);
              pmp$wait(10000, 10000);
            ELSE
              rfp$unlock_table (connection_entry_p^.lock);
              osp$set_status_abnormal (rfc$product_id, rfe$receive_data_active,
                  connection_entry_p^.connection_name, status);
             EXIT /main_program/;
            IFEND;
          IFEND;

        UNTIL NOT receive_request_active;

        update_connection_status (connection_entry_p, input_available,
              connection_unlocked, status);
        IF connection_unlocked THEN
          EXIT /main_program/;
        IFEND;

        connection_status := connection_entry_p^.connection_attributes.connection_status;
        IF connection_status.connection_state <> rfc$connected THEN
          IF NOT ((connection_status.connection_state = rfc$terminated) AND
                  (connection_status.reason_for_termination = rfc$peer_termination) AND
                  (input_available)) THEN
            set_connection_status (connection_entry_p, status);
            rfp$unlock_table (connection_entry_p^.lock);
            EXIT /main_program/;
          IFEND;
        IFEND;

        IF NOT input_available THEN
          rfp$unlock_table (connection_entry_p^.lock);
          wait_list [1].activity := rfc$i_await_connection_event;
          wait_list [1].connection_file_identifier := connection_identifier;
          wait_list [1].event_type := rfc$input_available;
          wait_list [2].activity := osc$i_await_time;
          wait_list [2].milliseconds := connection_entry_p^.connection_attributes.
                data_transfer_timeout;
          osp$i_await_activity (wait_list, ready_index, wait_complete, status);

          IF status.normal THEN
            activity_completed := wait_list [ready_index].activity;
            CASE activity_completed OF
            = rfc$i_await_connection_event =
              input_available := FALSE;
              CYCLE /wait_for_input_available/;
            = osc$i_await_time =
              osp$set_status_abnormal (rfc$product_id, rfe$transfer_timeout,
                    'Send data', status);
              EXIT /main_program/;
            CASEND;
          ELSE
            EXIT /main_program/;
          IFEND;
        IFEND;
      UNTIL input_available;


      connection_name := connection_entry_p^.connection_name;
      IF (#OFFSET(data_buffer^[starting_fragment].address) MOD 8) <> 0 THEN
        network_wired_data := TRUE;
      ELSEIF (transmission_mode = rfc$message_mode) AND (connection_entry_p^.connection_attributes.
            message_block_size MOD 8 <> 0) THEN
        network_wired_data := TRUE;
      ELSEIF (transmission_mode = rfc$record_mode) AND (connection_entry_p^.connection_attributes.
            record_block_size MOD 8 <> 0) THEN
        network_wired_data := TRUE;
      ELSEIF  data_buffer^[starting_fragment].length < rfc$min_unwired_data_length THEN
        network_wired_data := TRUE;
      ELSEIF write_only_pva THEN
        network_wired_data := TRUE;
      ELSE
        network_wired_data := FALSE;
      IFEND;

      ALLOCATE data_transfer_status IN osv$task_private_heap^;
      IF data_transfer_status = NIL THEN
        rfp$unlock_table (connection_entry_p^.lock);
        osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted,
              'task private', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'rfp$receive_data',
              status);
        EXIT /main_program/;
      IFEND;
      data_transfer_status^.connection_name := connection_entry_p^.connection_name;
      data_transfer_status^.connection_entry_p := connection_entry_p;
      data_transfer_status^.transmission_mode := transmission_mode;
      data_transfer_status^.data_area := data_buffer;
      data_transfer_status^.wait := wait;
      data_transfer_status^.activity_status := ^activity;
      data_transfer_status^.data_transferred := ^data_received;
      data_transfer_status^.end_of_message_p := ^end_of_message;
      IF transmission_mode = rfc$message_mode THEN
        data_transfer_status^.block_size := connection_entry_p^.connection_attributes.
              message_block_size;
      ELSE
        data_transfer_status^.block_size := connection_entry_p^.connection_attributes.
              record_block_size;
      IFEND;
      data_transfer_status^.file_mark := connection_entry_p^.connection_attributes.receive_record_terminator;
      data_transfer_status^.connection_descriptor := connection_entry_p^.connection_descriptor;
      data_transfer_status^.network_wired_data := network_wired_data;
      data_transfer_status^.next_to_queue_abn := connection_entry_p^.connection_attributes.
            incoming_record_abn;
      data_transfer_status^.next_to_queue_index := starting_fragment;
      data_transfer_status^.next_to_queue_offset := 0;
      data_transfer_status^.bytes_transferred := 0;
      data_transfer_status^.previous_error.normal := TRUE;
      data_transfer_status^.transfer_kind := rfc$tk_receive_data;
      data_transfer_status^.file_mark_received := rfc$rm_null;
      data_transfer_status^.complete_message_received := FALSE;
      data_transfer_status^.outstanding_control_messages := NIL;
      data_transfer_status^.control_message_header := connection_entry_p^.control_message_header;
      data_transfer_status^.control_message_header.my_path_id :=
            connection_entry_p^.connection_descriptor.network_path;
      data_transfer_status^.control_message_header.connection_number :=
            connection_entry_p^.connection_descriptor.network_path;
      connection_entry_p^.receive_request_active := TRUE;
      residue_input_data := connection_entry_p^.residue_input_data;
      rfp$unlock_table (connection_entry_p^.lock);
      start_receive_data (data_transfer_status, data_length, residue_input_data, status);
      #SPOIL (activity);
      IF (activity.complete) OR
         (NOT status.normal) THEN
        EXIT /main_program/;
      IFEND;

      IF wait = osc$wait THEN
        REPEAT
          #SPOIL (activity);
          pmp$wait (rfc$unit_request_wait_time,rfc$ur_expected_wait);
          rfp$process_pp_response_flag (rfc$pp_response_available);
        UNTIL activity.complete;
      IFEND;

    END /main_program/;

    osp$disestablish_cond_handler;
    IF status.normal THEN
      #keypoint (osk$exit, 0, rfk$receive_data);
    ELSE
      #keypoint (osk$exit, status.condition * osk$m, rfk$receive_data);
    IFEND;
  PROCEND rfp$receive_data;
?? TITLE := '    rfp$reject_connect_request', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$reject_connect_request (connection_file:
        fst$file_reference;
        server_response: rft$server_reject_codes;
    VAR status: ost$status);

*copy rfh$reject_connect_request

?? NEWTITLE := '      terminate_reject_connect - condition handler', EJECT ??
    PROCEDURE terminate_reject_connect (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      VAR
        activity_status: ^ost$activity_status,
        current_request: ^rft$outstanding_requests,
        mgmt_status: ^rft$connection_mgmt_status,
        previous_request: ^rft$outstanding_requests;

      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        block_exit_expected := TRUE;
        EXIT rfp$reject_connect_request;
      = pmc$block_exit_processing =
        IF block_exit_expected THEN
          condition_status.normal := TRUE;
        ELSE
          current_request := rfv$outstanding_requests;
        /complete_synchronous_request/
          WHILE current_request <> NIL DO
            IF (current_request^.request_id.ring_1_id.address <> NIL) AND
               (NOT current_request^.request_id.ring_1_id.address^.asynchronous_request) THEN
              mgmt_status := current_request^.request_status;
              activity_status := mgmt_status^.activity_status;
              REPEAT
                #SPOIL (activity_status^);
                syp$cycle;
                rfp$process_pp_response_flag (rfc$pp_response_available);
              UNTIL activity_status^.complete;
              FREE activity_status  IN osv$task_private_heap^;
              current_request := rfv$outstanding_requests;
              EXIT /complete_synchronous_request/;
            IFEND;
            current_request := current_request^.next_entry;
          WHILEND /complete_synchronous_request/;
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, condition_status,
                status);
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          current_request := rfv$outstanding_requests;
          previous_request := NIL;
        /complete_recovered_requests/
          WHILE current_request <> NIL DO
            IF current_request^.request_kind = rfc$rk_reject_connect_request THEN
              mgmt_status := current_request^.request_status;
              FREE mgmt_status^.activity_status IN osv$task_private_heap^;
              IF previous_request = NIL THEN
                rfv$outstanding_requests := current_request^.next_entry;
              ELSE
                previous_request^.next_entry := current_request^.next_entry;
              IFEND;
              FREE mgmt_status IN osv$task_private_heap^;
              FREE current_request IN osv$task_private_heap^;
              EXIT /complete_recovered_requests/;
            IFEND;
            previous_request := current_request;
            current_request := current_request^.next_entry;
          WHILEND /complete_recovered_requests/;
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          block_exit_expected := TRUE;
          EXIT rfp$reject_connect_request;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_reject_connect;
?? OLDTITLE, EJECT ??

    VAR
      activity_status: ^ost$activity_status,
      block_exit_expected: boolean,
      command_identifier: ^rft$logical_commands,
      connection_entry_p: ^rft$connection_entry,
      ignore_status: ost$status,
      nad_index: rft$local_nads,
      path_handle_name: fst$path_handle_name,
      path_id: ^rft$path_identifier,
      reject_code: ^rft$reject_code,
      request_complete: boolean,
      request_info: ^SEQ ( * ),
      unit_request_status: ^rft$connection_mgmt_status;

    #keypoint (osk$entry, 0, rfk$reject_connect_request);
    block_exit_expected := FALSE;
    osp$establish_condition_handler (^terminate_reject_connect, TRUE);
    status.normal := TRUE;

  /reject_connect_request/
    BEGIN
      get_path_handle_name (connection_file, path_handle_name, status);
      IF NOT status.normal THEN
        EXIT /reject_connect_request/;
      IFEND;

      get_exclusive_to_connection (path_handle_name, connection_entry_p, status);
      IF NOT status.normal THEN
        EXIT /reject_connect_request/;
      IFEND;
      CASE connection_entry_p^.connection_attributes.connection_status.connection_state OF
      = rfc$incoming_connect_active =
      /queue_reject_request/
        BEGIN
          PUSH request_info: [[rft$logical_commands, rft$path_identifier,rft$reject_code]];
          RESET request_info;
          NEXT command_identifier  IN  request_info;
          IF  command_identifier = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err,
                  'the request overflowed the request sequence', status);
            osp$append_status_parameter(osc$status_parameter_delimiter,
                  'rfp$reject_connect_request', status);
            EXIT  /queue_reject_request/;
          IFEND;
          command_identifier^ := rfc$lc_reject_connect_request;
          NEXT  path_id  IN  request_info;
          IF  path_id = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err,
                  'the request overflowed the request sequence', status);
            osp$append_status_parameter(osc$status_parameter_delimiter,
                  'rfp$reject_connect_request', status);
            EXIT  /queue_reject_request/;
          IFEND;
          path_id^ := connection_entry_p^.connection_descriptor.network_path;
          NEXT  reject_code  IN  request_info;
          IF  reject_code = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err,
                  'the request overflowed the request sequence', status);
            osp$append_status_parameter(osc$status_parameter_delimiter,
                  'rfp$reject_connect_request', status);
            EXIT  /queue_reject_request/;
          IFEND;
          reject_code^ := server_response;
          ALLOCATE unit_request_status IN osv$task_private_heap^;
          IF  unit_request_status = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted,
                  'task private', status);
            osp$append_status_parameter(osc$status_parameter_delimiter,
                  'rfp$reject_connect_request', status);
            EXIT /queue_reject_request/;
          IFEND;
          unit_request_status^.internal_use := FALSE;
          unit_request_status^.connection := connection_entry_p;

{     The structure activity status is allocated in task private to insure
{     it is writeable by ring 3 code. Pointers to this variable are stored in
{     a task private segment and thus inherit ring 3 privileges.

          ALLOCATE activity_status IN osv$task_private_heap^;
          IF  activity_status = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted,
                  'task private', status);
            osp$append_status_parameter(osc$status_parameter_delimiter,
                  'rfp$reject_connect_request', status);
            EXIT /queue_reject_request/;
          IFEND;
          unit_request_status^.activity_status := activity_status;
          activity_status^.complete := FALSE;
          activity_status^.status.normal := TRUE;
          nad_index := connection_entry_p^.connection_descriptor.nad_index;
          connection_entry_p^.active_pp_requests :=
                connection_entry_p^.active_pp_requests + 1;
          rfp$unlock_table (connection_entry_p^.lock);
          rfp$queue_request(nad_index, 1, rfc$unit_request, rfc$rk_reject_connect_request,
                unit_request_status, request_info, status);
          IF  NOT status.normal  THEN
            rfp$lock_table (connection_entry_p^.lock);
            connection_entry_p^.active_pp_requests :=
                  connection_entry_p^.active_pp_requests - 1;
            rfp$unlock_table (connection_entry_p^.lock);
            amp$return (connection_file, ignore_status);
            EXIT  /reject_connect_request/;
          IFEND;
          REPEAT
            #SPOIL (activity_status^);
            pmp$wait (rfc$unit_request_wait_time,rfc$ur_expected_wait);
            rfp$process_pp_response_flag (rfc$pp_response_available);
          UNTIL activity_status^.complete;
          IF NOT activity_status^.status.normal THEN
            status := activity_status^.status;
          IFEND;
          FREE activity_status IN osv$task_private_heap^;
          amp$return (connection_file, ignore_status);
          EXIT /reject_connect_request/;
        END /queue_reject_request/;
        rfp$unlock_table (connection_entry_p^.lock);
      ELSE
        set_connection_status (connection_entry_p, status);
        rfp$unlock_table (connection_entry_p^.lock);
      CASEND;

    END /reject_connect_request/;

    osp$disestablish_cond_handler;
    IF status.normal THEN
      #keypoint (osk$exit, 0, rfk$reject_connect_request);
    ELSE
      #keypoint (osk$exit, status.condition * osk$m,
            rfk$reject_connect_request);
    IFEND;
  PROCEND rfp$reject_connect_request;
?? TITLE := '    rfp$request_connection', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$request_connection (client_name:
    rft$application_name;
        server_name: rft$application_name;
        destination_host: rft$host_identifier;
        connection_file: fst$file_reference;
        file_attributes: ^rft$create_attributes;
    VAR status: ost$status);

*copy rfh$request_connection

?? NEWTITLE := '      terminate_request_connection - condition handler', EJECT ??
    PROCEDURE terminate_request_connection (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

      VAR
        activity_status: ^ost$activity_status,
        current_request: ^rft$outstanding_requests,
        mgmt_status: ^rft$connection_mgmt_status,
        previous_request: ^rft$outstanding_requests;

      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        block_exit_expected := TRUE;
        amp$return (connection_file, ignore_status);
        EXIT rfp$request_connection;
      = pmc$block_exit_processing =
        IF block_exit_expected THEN
          condition_status.normal := TRUE;
        ELSE
          current_request := rfv$outstanding_requests;
        /complete_synchronous_request/
          WHILE current_request <> NIL DO
            IF (current_request^.request_id.ring_1_id.address <> NIL) AND
               (NOT current_request^.request_id.ring_1_id.address^.asynchronous_request) THEN
              mgmt_status := current_request^.request_status;
              activity_status := mgmt_status^.activity_status;
              REPEAT
                #SPOIL (activity_status^);
                syp$cycle;
                rfp$process_pp_response_flag (rfc$pp_response_available);
              UNTIL activity_status^.complete;
              FREE activity_status  IN osv$task_private_heap^;
              current_request := rfv$outstanding_requests;
              EXIT /complete_synchronous_request/;
            IFEND;
            current_request := current_request^.next_entry;
          WHILEND /complete_synchronous_request/;
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, condition_status,
                status);
          amp$return (connection_file, ignore_status);
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          amp$return (connection_file, ignore_status);
          current_request := rfv$outstanding_requests;
          previous_request := NIL;
        /complete_recovered_requests/
          WHILE current_request <> NIL DO
            IF current_request^.request_kind = rfc$rk_request_connection THEN
              mgmt_status := current_request^.request_status;
              FREE mgmt_status^.activity_status IN osv$task_private_heap^;
              IF previous_request = NIL THEN
                rfv$outstanding_requests := current_request^.next_entry;
              ELSE
                previous_request^.next_entry := current_request^.next_entry;
              IFEND;
              FREE mgmt_status IN osv$task_private_heap^;
              FREE current_request IN osv$task_private_heap^;
              EXIT /complete_recovered_requests/;
            IFEND;
            previous_request := current_request;
            current_request := current_request^.next_entry;
          WHILEND /complete_recovered_requests/;
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          block_exit_expected := TRUE;
          EXIT rfp$request_connection;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_request_connection;
?? OLDTITLE, EJECT ??

    VAR
      application_entry_p: ^rft$application_table_entry,
      associated_path: ^rft$lcn_path_definition,
      block_exit_expected: boolean,
      client_entry_p: ^rft$rhfam_client_table_entry,
      connection_attributes: rft$connection_attributes,
      connect_request: rft$nbp_outgoing_connect,
      connection_descriptor: rft$connection_descriptor,
      connection_entry_p: ^rft$connection_entry,
      connection_timeout: rft$connection_timeout,
      connections_incremented: boolean,
      data_transfer_timeout: rft$transfer_timeout,
      ignore_status: ost$status,
      job_table_entry_p: ^rft$rhfam_job_table_entry,
      local_file_created: boolean,
      new_entry: BOOLEAN,
      path_handle_name: fst$path_handle_name,
      physical_identifier: rft$physical_identifier,
      server_available_locally: boolean,
      server_entry_p: ^rft$rhfam_server_table_entry,
      server_host_pid: rft$physical_identifier;


    #keypoint (osk$entry, 0, rfk$request_connection);
    local_file_created := FALSE;
    connections_incremented := FALSE;
    job_table_entry_p := NIL;
    block_exit_expected := FALSE;
    osp$establish_condition_handler (^terminate_request_connection, TRUE);
    status.normal := TRUE;

    /request_connection/
      BEGIN

{     Verify creation file attributes.

        merge_creation_attributes (^connection_attributes, file_attributes, status);
        IF NOT status.normal THEN
          EXIT /request_connection/;
        IFEND;

        fmp$create_rhfam_file (connection_file, status);
        IF NOT status.normal THEN
          EXIT /request_connection/;
        IFEND;
        local_file_created := TRUE;
        get_path_handle_name (connection_file, path_handle_name, status);
        IF NOT status.normal THEN
          EXIT /request_connection/;
        IFEND;

{     Lock the job table entry.

        rfp$lock_job_table_entry (FALSE, new_entry, job_table_entry_p);
        IF job_table_entry_p = NIL THEN
          osp$set_status_abnormal (rfc$product_id, rfe$not_signed_on,
                'Request connection', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, client_name,
                status);
          EXIT /request_connection/;
        IFEND;

{     Get pointer to application table entry.

        find_application_entry (client_name, job_table_entry_p, application_entry_p);
        IF application_entry_p = NIL THEN
          osp$set_status_abnormal (rfc$product_id, rfe$not_signed_on,
                'Request_connection', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                client_name, status);
          EXIT /request_connection/;
        IFEND;

{     Check for application type client.

        IF application_entry_p^.application_kind <> rfc$client THEN
          osp$set_status_abnormal (rfc$product_id, rfe$not_signed_on_as_client,
                'rfp$request_connection', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                job_table_entry_p^.job_name, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, client_name, status);
          EXIT /request_connection/;
        IFEND;

{     Check if maximum connections allowed for this client is exceeded.

        IF (NOT application_entry_p^.system_wide_connection_mgmt) AND
           (application_entry_p^.maximum_allowed_connections <=
                application_entry_p^.number_of_active_connections) THEN
          osp$set_status_abnormal (rfc$product_id, rfe$exceeded_connect_limit,
                'Request connection', status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
                client_name, status);
          EXIT /request_connection/;
        IFEND;

{     Check if maximum connections allowed for all clients is exceeded.

        rfp$lock_table (rfv$rhfam_client_table.lock);
        rfp$find_client_entry (client_name, TRUE, client_entry_p, status);
        IF status.normal THEN
          IF client_entry_p^.current_connections < client_entry_p^.maximum_connections THEN
            client_entry_p^.current_connections := client_entry_p^.current_connections + 1;
            connections_incremented := TRUE;
          ELSE
            osp$set_status_abnormal (rfc$product_id, rfe$max_appl_connects_exceeded,
                  client_name, status);
          IFEND;
        IFEND;
        rfp$unlock_table (rfv$rhfam_client_table.lock);
        IF NOT status.normal THEN
          EXIT /request_connection/;
        IFEND;

{     Check if server is available locally.

        rfp$lock_table (rfv$rhfam_server_table.lock);
        find_server_entry (server_name, TRUE, server_entry_p, ignore_status);
        rfp$unlock_table (rfv$rhfam_server_table.lock);
        server_available_locally := ignore_status.normal;

{     Build connect request.

        rfp$lock_table (rfv$status_table.lock);
        IF rfv$status_table.system_task_is_up THEN
          pmp$zero_out_table(^connect_request, #SIZE(connect_request));
          build_connect_request (server_name, client_name, destination_host,
                server_available_locally, ^connect_request, connection_descriptor,
                server_host_pid, associated_path, status);
          physical_identifier := rfv$status_table.local_host^.physical_identifier;
          connection_timeout := rfv$status_table.local_host^.connection_timeout * 1000;
          data_transfer_timeout := rfv$status_table.local_host^.data_transfer_timeout * 1000;
        ELSE
          osp$set_status_abnormal (rfc$product_id,
                rfe$system_task_not_active, 'rfp$request_connection', status);
        IFEND;
        rfp$unlock_table (rfv$status_table.lock);
        IF NOT status.normal THEN
          EXIT /request_connection/;
        IFEND;

{     Create the connection entry and initialize.

        allocate_connection_entry (application_entry_p, connection_entry_p, status);
        IF NOT status.normal THEN
          EXIT /request_connection/;
        IFEND;
        rfp$lock_table (connection_entry_p^.lock);
        job_table_entry_p^.lock := tmv$null_global_task_id;
        job_table_entry_p := NIL;
        connection_entry_p^.connection_name := path_handle_name;
        connection_entry_p^.connection_descriptor := connection_descriptor;
        pmp$get_microsecond_clock (connection_entry_p^.connection_statistics.connect_time,
              ignore_status);
        connection_entry_p^.connection_statistics.bytes_sent := 0;
        connection_entry_p^.connection_statistics.bytes_received := 0;
        connection_entry_p^.active_pp_requests := 0;
        connection_entry_p^.waiting_tasks := NIL;
        connection_entry_p^.send_request_active := FALSE;
        connection_entry_p^.receive_request_active := FALSE;
        connection_entry_p^.residue_input_data := NIL;
        connection_entry_p^.open_count := 0;
        connection_entry_p^.selected_path := associated_path;

{     Set control message header.

        connection_entry_p^.control_message_header.nad_address :=
              connect_request.nad_address;
        connection_entry_p^.control_message_header.local_tcu_enables :=
              connect_request.local_tcu_enables;
        connection_entry_p^.control_message_header.destination_device :=
              connect_request.destination_device;
        connection_entry_p^.control_message_header.access_code :=
              connect_request.access_code;
        connection_entry_p^.control_message_header.name :=
              connect_request.name;

{     Set default connection file attributes.

        connection_entry_p^.connection_attributes.client_name := client_name;
        connection_entry_p^.connection_attributes.server_name := server_name;
        connection_entry_p^.connection_attributes.client_host := physical_identifier;
        connection_entry_p^.connection_attributes.server_host := server_host_pid;
        connection_entry_p^.connection_attributes.destination_host := destination_host;
        connection_entry_p^.connection_attributes.connection_timeout :=
              connection_timeout;
        connection_entry_p^.connection_attributes.data_transfer_timeout :=
              data_transfer_timeout;
        connection_entry_p^.connection_attributes.record_block_size :=
              rfc$default_record_block_size;
        connection_entry_p^.connection_attributes.message_block_size :=
              rfc$default_message_block_size;
        connection_entry_p^.connection_attributes.incoming_record_abn := 0;
        connection_entry_p^.connection_attributes.outgoing_record_abn := 0;
        connection_entry_p^.connection_attributes.acks_received_count := 0;
        connection_entry_p^.connection_attributes.acks_sent_count := 0;
        connection_entry_p^.connection_attributes.incoming_message_count := 0;
        connection_entry_p^.connection_attributes.outgoing_message_count := 0;
        connection_entry_p^.connection_attributes.receive_record_terminator :=
              rfc$rm_eoi;
        connection_entry_p^.connection_attributes.file_mark_received :=
              rfc$rm_null;
        connection_entry_p^.connection_attributes.send_record_terminator :=
              rfc$rm_eoi;
        connection_entry_p^.connection_attributes.abnormal_termination := FALSE;
        merge_creation_attributes (^connection_entry_p^.connection_attributes,
              file_attributes, ignore_status);

        request_lcn_connection (connection_entry_p, ^connect_request, status);

      END /request_connection/;

    IF status.normal THEN
      #keypoint (osk$exit, 0, rfk$request_connection);
    ELSE
      IF job_table_entry_p <> NIL THEN
        job_table_entry_p^.lock := tmv$null_global_task_id;
      IFEND;
      IF connections_incremented THEN
        rfp$lock_table (rfv$rhfam_client_table.lock);
        rfp$find_client_entry (client_name, FALSE, client_entry_p, ignore_status);
        IF ignore_status.normal THEN
          client_entry_p^.current_connections := client_entry_p^.current_connections - 1;
        IFEND;
        rfp$unlock_table (rfv$rhfam_client_table.lock);
      IFEND;
      IF local_file_created THEN
        amp$return (connection_file, ignore_status);
      IFEND;
      #keypoint (osk$exit, status.condition * osk$m, rfk$request_connection);
    IFEND;
    osp$disestablish_cond_handler;

  PROCEND rfp$request_connection;
?? TITLE := '    rfp$send_data', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$send_data (connection_identifier:
    amt$file_identifier;
        transmission_mode: rft$transmission_modes;
        data_buffer: rft$data_buffers;
        end_of_message: boolean;
        wait: ost$wait;
    VAR activity: ost$activity_status;
    VAR data_sent: rft$bytes_transferred;
    VAR status: ost$status);

*copy rfh$send_data


{     NOTE: If this routine is to be called at a ring level below ring3,
{       the VAR parameters must be allocated in a segment that is
{       writable by ring 3 code.  Pointers to this variable are stored in
{       a task private segment and thus inherit ring 3 privileges.


?? NEWTITLE := '      terminate_send_data - condition handler', EJECT ??
    PROCEDURE terminate_send_data (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

      VAR
        activities: rft$set_of_async_activities,
        activity_status: ^ost$activity_status,
        current_request: ^rft$outstanding_requests,
        local_status: ost$status,
        mgmt_status: ^rft$connection_mgmt_status,
        previous_request: ^rft$outstanding_requests,
        transfer_status: ^rft$data_transfer_status;

      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        IF wait = osc$wait THEN
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
        ELSE
          osp$set_status_from_condition (rfc$product_id, condition, sfsa,
                activity.status, condition_status);
          activity.complete := TRUE;
        IFEND;
        block_exit_expected := TRUE;
        EXIT rfp$send_data;
      = pmc$block_exit_processing =
        IF block_exit_expected THEN
          condition_status.normal := TRUE;
        ELSE
          activities := $rft$set_of_async_activities[rfc$aa_send_data];
          terminate_async_activity (activities, connection_name);
          current_request := rfv$outstanding_requests;
          WHILE current_request <> NIL DO
            IF current_request^.request_kind = rfc$rk_path_status THEN
              mgmt_status := current_request^.request_status;
              activity_status := mgmt_status^.activity_status;
              current_request := current_request^.next_entry;
              syp$cycle;
              rfp$process_pp_response_flag (rfc$pp_response_available);
              IF activity_status^.complete THEN
                FREE activity_status  IN osv$task_private_heap^;
              IFEND;
              current_request := rfv$outstanding_requests;
            ELSEIF current_request^.request_kind = rfc$rk_send_data THEN
              transfer_status := current_request^.request_status;
              activity_status := transfer_status^.activity_status;
              current_request := current_request^.next_entry;
              IF transfer_status^.connection_name = connection_name THEN
                syp$cycle;
                rfp$process_pp_response_flag (rfc$pp_response_available);
                current_request := rfv$outstanding_requests;
              IFEND;
            ELSE
              current_request := current_request^.next_entry;
            IFEND;
          WHILEND;
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, condition_status,
                local_status);
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          current_request := rfv$outstanding_requests;
          previous_request := NIL;
        /complete_recovered_requests/
          WHILE current_request <> NIL DO
            IF current_request^.request_kind = rfc$rk_path_status THEN
              mgmt_status := current_request^.request_status;
              FREE mgmt_status^.activity_status IN osv$task_private_heap^;
              IF previous_request = NIL THEN
                rfv$outstanding_requests := current_request^.next_entry;
              ELSE
                previous_request^.next_entry := current_request^.next_entry;
              IFEND;
              FREE mgmt_status IN osv$task_private_heap^;
              FREE current_request IN osv$task_private_heap^;
              EXIT /complete_recovered_requests/;
            ELSEIF current_request^.request_kind = rfc$rk_send_data THEN
              transfer_status := current_request^.request_status;
              IF previous_request = NIL THEN
                rfv$outstanding_requests := current_request^.next_entry;
              ELSE
                previous_request^.next_entry := current_request^.next_entry;
              IFEND;
              FREE transfer_status IN osv$task_private_heap^;
              FREE current_request IN osv$task_private_heap^;
              EXIT /complete_recovered_requests/;
            IFEND;
            previous_request := current_request;
            current_request := current_request^.next_entry;
          WHILEND /complete_recovered_requests/;
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          IF wait = osc$wait THEN
            osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                  condition_status);
          ELSE
            osp$set_status_from_condition (rfc$product_id, condition, sfsa,
                  activity.status, condition_status);
            activity.complete := TRUE;
          IFEND;
          block_exit_expected := TRUE;
          EXIT rfp$send_data;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_send_data;
?? OLDTITLE, EJECT ??

    VAR
      block_exit_expected: boolean,
      cell_to_verify: ^^cell,
      connection_entry_p: ^rft$connection_entry,
      connection_name: fst$path_handle_name,
      connection_unlocked: boolean,
      data_length: rft$data_length,
      data_transfer_status: ^rft$data_transfer_status,
      index: integer,
      input_available: boolean,
      last_data_cell: ^cell,
      local_status: ost$status,
      network_wired_data: boolean,
      number_of_fragments: integer,
      pva_valid: boolean,
      send_request_active: boolean,
      starting_fragment: rft$data_fragment_count;


    #keypoint (osk$entry, 0, rfk$send_data);
    block_exit_expected := FALSE;
    osp$establish_condition_handler (^terminate_send_data, TRUE);
    status.normal := TRUE;
    activity.complete := FALSE;
    activity.status.normal := TRUE;
    data_sent := 0;

    /main_program/
    BEGIN

      data_length := 0;
      number_of_fragments := 0;
      starting_fragment := LOWERBOUND(data_buffer^);
      cell_to_verify := ^last_data_cell;
      /validate_data_fragments/
      FOR index := LOWERBOUND(data_buffer^) TO UPPERBOUND(data_buffer^) DO
        IF data_buffer^[index].length > 0 THEN
          last_data_cell := i#ptr(data_buffer^[index].length,
                data_buffer^[index].address);
          pva_valid := mmp$verify_access (cell_to_verify, mmc$va_read);
          IF pva_valid THEN
            IF number_of_fragments = 0 THEN
              starting_fragment := index;
            IFEND;
            number_of_fragments := number_of_fragments + 1;
            data_length := data_length + data_buffer^[index].length;
          ELSE
            osp$set_status_abnormal(rfc$product_id, rfe$invalid_data_fragment,
                  'send data', status);
            EXIT /main_program/;
          IFEND;
        IFEND;
      FOREND /validate_data_fragments/;

      /wait_for_active_send/
      REPEAT

        get_exclusive_to_cid (connection_identifier, connection_entry_p, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        send_request_active := connection_entry_p^.send_request_active;
        IF send_request_active THEN
          IF wait = osc$wait THEN
            enter_waiting_task_queue(connection_entry_p, local_status);
            rfp$unlock_table (connection_entry_p^.lock);
            pmp$wait(10000, 10000);
          ELSE
            rfp$unlock_table (connection_entry_p^.lock);
            osp$set_status_abnormal (rfc$product_id, rfe$send_data_active,
                  connection_entry_p^.connection_name, status);
            EXIT /main_program/;
          IFEND;
        IFEND;

      UNTIL NOT send_request_active;
      connection_name := connection_entry_p^.connection_name;

      update_connection_status (connection_entry_p, input_available,
            connection_unlocked, status);
      IF connection_unlocked THEN
        EXIT /main_program/;
      IFEND;

      IF connection_entry_p^.connection_attributes.connection_status.connection_state <>
            rfc$connected THEN
        set_connection_status (connection_entry_p, status);
        rfp$unlock_table (connection_entry_p^.lock);
        EXIT /main_program/;
      IFEND;


      IF (#OFFSET(data_buffer^[starting_fragment].address) MOD 8) <> 0 THEN
        network_wired_data := TRUE;
      ELSEIF (transmission_mode = rfc$message_mode) AND
             (connection_entry_p^.connection_attributes.message_block_size MOD 8 <> 0) THEN
        network_wired_data := TRUE;
      ELSEIF (transmission_mode = rfc$record_mode) AND
             (connection_entry_p^.connection_attributes.record_block_size MOD 8 <> 0) THEN
        network_wired_data := TRUE;
      ELSEIF  data_buffer^[starting_fragment].length < rfc$min_unwired_data_length THEN
        network_wired_data := TRUE;
      ELSE
        network_wired_data := FALSE;
      IFEND;

      ALLOCATE data_transfer_status IN osv$task_private_heap^;
      IF data_transfer_status = NIL THEN
        rfp$unlock_table (connection_entry_p^.lock);
        osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted,
              'task private', status);
        osp$append_status_parameter(osc$status_parameter_delimiter,
              'rfp$send_data', status);
        EXIT /main_program/;
      IFEND;
      data_transfer_status^.connection_name := connection_entry_p^.connection_name;
      data_transfer_status^.connection_entry_p := connection_entry_p;
      data_transfer_status^.transmission_mode := transmission_mode;
      data_transfer_status^.data_area := data_buffer;
      data_transfer_status^.end_of_message := end_of_message;
      data_transfer_status^.wait := wait;
      data_transfer_status^.activity_status := ^activity;
      data_transfer_status^.data_transferred := ^data_sent;
      IF transmission_mode = rfc$message_mode THEN
        data_transfer_status^.block_size := connection_entry_p^.connection_attributes.
              message_block_size;
      ELSE
        data_transfer_status^.block_size := connection_entry_p^.connection_attributes.
              record_block_size;
      IFEND;
      data_transfer_status^.file_mark :=
            connection_entry_p^.connection_attributes.send_record_terminator;
      data_transfer_status^.connection_descriptor := connection_entry_p^.connection_descriptor;
      data_transfer_status^.network_wired_data := network_wired_data;
      data_transfer_status^.next_to_queue_abn := connection_entry_p^.connection_attributes.
            outgoing_record_abn;
      data_transfer_status^.next_to_queue_index := starting_fragment;
      data_transfer_status^.next_to_queue_offset := 0;
      data_transfer_status^.bytes_transferred := 0;
      data_transfer_status^.outgoing_message_count := 0;
      data_transfer_status^.previous_error.normal := TRUE;
      data_transfer_status^.transfer_kind := rfc$tk_send_data;
      data_transfer_status^.outstanding_control_messages := NIL;
      data_transfer_status^.residue_data_on_send := FALSE;
      data_transfer_status^.control_message_header :=
            connection_entry_p^.control_message_header;
      data_transfer_status^.control_message_header.my_path_id :=
            connection_entry_p^.connection_descriptor.network_path;
      data_transfer_status^.control_message_header.connection_number :=
            connection_entry_p^.connection_descriptor.network_path;
      connection_entry_p^.send_request_active := TRUE;
      rfp$unlock_table (connection_entry_p^.lock);
      start_send_data (data_transfer_status, data_length, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF wait = osc$wait THEN
        REPEAT
          #SPOIL (activity);
          pmp$wait (rfc$unit_request_wait_time,rfc$ur_expected_wait);
          rfp$process_pp_response_flag (rfc$pp_response_available);
        UNTIL activity.complete;
      IFEND;

    END /main_program/;

    osp$disestablish_cond_handler;
    IF status.normal THEN
      #keypoint (osk$exit, 0, rfk$send_data);
    ELSE
      #keypoint (osk$exit, status.condition * osk$m, rfk$send_data);
    IFEND;
  PROCEND rfp$send_data;
?? TITLE := '    rfp$terminate_async_activity', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$terminate_async_activity (connection_identifier:
    amt$file_identifier;
        activity_types: rft$set_of_async_activities;
    VAR status: ost$status);

*copy rfh$terminate_async_activity

?? NEWTITLE := '      terminate_a_activity - condition handler', EJECT ??
    PROCEDURE terminate_a_activity (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$terminate_async_activity;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$terminate_async_activity;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_a_activity;
?? OLDTITLE, EJECT ??

    VAR
      connection_entry_p: ^rft$connection_entry,
      connection_name: fst$path_handle_name;


    osp$establish_condition_handler (^terminate_a_activity, FALSE);
    status.normal := TRUE;
    get_exclusive_to_cid (connection_identifier, connection_entry_p, status);
    IF status.normal THEN
      connection_name := connection_entry_p^.connection_name;
      rfp$unlock_table (connection_entry_p^.lock);
      terminate_async_activity (activity_types, connection_name);
    IFEND;

    IF status.normal THEN
      #keypoint (osk$exit, 0, rfk$terminate_async_activity);
    ELSE
      #keypoint (osk$exit, status.condition * osk$m,
            rfk$terminate_async_activity);
    IFEND;
  PROCEND rfp$terminate_async_activity;
?? TITLE := '    rfp$terminate_connection', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$terminate_connection (connection_file:
        fst$file_reference;
        normal_termination: boolean;
    VAR connection_statistics: rft$connection_statistics;
    VAR status: ost$status);

*copy rfh$terminate_connection

?? NEWTITLE := '      terminate_term_connection - condition handler', EJECT ??
    PROCEDURE terminate_term_connection (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$terminate_connection;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$terminate_connection;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_term_connection;
?? OLDTITLE, EJECT ??

    VAR
      abnormal_termination: BOOLEAN,
      connection_entry_p: ^rft$connection_entry,
      path_handle_name: fst$path_handle_name,
      time: integer;


    #keypoint (osk$entry, 0, rfk$terminate_connection);
    osp$establish_condition_handler (^terminate_term_connection, FALSE);
    status.normal := true;
    pmp$zero_out_table (^connection_statistics, #SIZE(rft$connection_statistics));
    abnormal_termination := NOT normal_termination;

  /terminate_connection/
    BEGIN
      get_path_handle_name (connection_file, path_handle_name, status);
      IF NOT status.normal THEN
        EXIT /terminate_connection/;
      IFEND;
      get_exclusive_to_connection(path_handle_name, connection_entry_p, status);
      IF NOT status.normal THEN
        EXIT /terminate_connection/;
      IFEND;
      pmp$get_microsecond_clock (time, status);
      IF NOT status.normal THEN
        rfp$unlock_table (connection_entry_p^.lock);
        EXIT /terminate_connection/;
      IFEND;

      connection_entry_p^.connection_attributes.abnormal_termination := abnormal_termination;

      connection_statistics.connect_time :=
            (time - connection_entry_p^.connection_statistics.connect_time) DIV 1000;
      connection_statistics.bytes_sent := connection_entry_p^.connection_statistics.bytes_sent;
      connection_statistics.bytes_received := connection_entry_p^.connection_statistics.bytes_received;
      rfp$unlock_table (connection_entry_p^.lock);

      amp$return (connection_entry_p^.connection_name, status);

    END /terminate_connection/;

    IF status.normal THEN
      #keypoint (osk$exit, 0, rfk$terminate_connection);
    ELSE
      #keypoint (osk$exit, status.condition * osk$m, rfk$terminate_connection);
    IFEND;
  PROCEND rfp$terminate_connection;

?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := '  Utility Procedures', EJECT ??
?? NEWTITLE := '    add_blocks_to_request', EJECT ??
  PROCEDURE add_blocks_to_request (data_transfer_status: ^rft$data_transfer_status;
        unit_request_idle: boolean;
    VAR blocks_to_add: rft$outstanding_blocks;
    VAR unit_request: ^SEQ ( * );
    VAR status: ost$status);


{     The purpose of this procedure is to add the network block data
{     descriptions to the pp send or receive data request. This routine
{     either builds blocks in network wired or in unwired buffers and controls
{     the timing of the switch from using unwired buffers to using network
{     wired buffers.
{
{     DATA_TRANSFER_STATUS: (input) This parameter specifies the parameters
{       for the data transfer request.
{
{     UNIT_REQUEST_IDLE: (input) This parameter specifies if the pp request
{       is active at this time.  A value of TRUE indicates that the
{       pp request is not active and no blocks are queued in the send or receive
{       data request.
{
{     BLOCKS_TO_ADD: (input,output) This parameter specifies the maximum number
{       of blocks to add to the pp request.  Upon return, this parameter returns
{       the actual number of blocks that were added to the transfer request.
{
{     UNIT_REQUEST: (input,output) This parameter specifies the pp request
{       sequence to add the data blocks to.
{
{     STATUS: (output) This parameter returns the results of the procedure call.
{       A status of normal indicates that no erros were encountered.


    VAR
      blocks_built: boolean,
      unit_request_position: ^string ( * );

    status.normal := TRUE;
    NEXT unit_request_position: [ 0 ] IN unit_request;
    blocks_built := FALSE;

  /build_blocks/
    WHILE (NOT blocks_built) AND (status.normal) DO
      IF data_transfer_status^.switch_to_wired_buffers THEN
        IF unit_request_idle THEN
          switch_to_wired_buffers (data_transfer_status, status);
          blocks_to_add := data_transfer_status^.maximum_outstanding_blocks;
          IF NOT status.normal THEN
            EXIT add_blocks_to_request;
          IFEND;
        ELSE
          blocks_to_add := 0;
          RETURN;
        IFEND;
      IFEND;

      IF data_transfer_status^.network_wired_data THEN
        build_network_wired_blocks (data_transfer_status, unit_request, blocks_to_add,
              status);
        IF status.normal THEN
          IF blocks_to_add <> 0 THEN
            blocks_built := TRUE;
          ELSE
            IF unit_request_idle THEN
              IF data_transfer_status^.switch_to_wired_buffers THEN
                ; { This case would be an internal coding error }
              ELSE  { previous error was set }
                status := data_transfer_status^.previous_error;
              IFEND;
            ELSE    { This is an intermediate response.}
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      ELSE
        build_unwired_blocks (data_transfer_status, unit_request, blocks_to_add,
              status);
        IF status.normal THEN
          IF blocks_to_add <> 0 THEN
            blocks_built := TRUE;
          ELSE
            IF unit_request_idle THEN
              IF data_transfer_status^.switch_to_wired_buffers THEN
                switch_to_wired_buffers (data_transfer_status, status);
                blocks_to_add := data_transfer_status^.maximum_outstanding_blocks;
                IF NOT status.normal THEN
                  EXIT add_blocks_to_request;
                IFEND;
                RESET unit_request TO unit_request_position;
                CYCLE /build_blocks/;
              ELSE  { previous error was set }
                status := data_transfer_status^.previous_error;
              IFEND;
            ELSE    { This is an intermediate response.}
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    WHILEND /build_blocks/;

  PROCEND add_blocks_to_request;
?? TITLE := '    advise_out_in', EJECT ??
  PROCEDURE advise_out_in (data_transfer_status: ^rft$data_transfer_status;
     VAR status: ost$status);

{
{     The purpose of this procedure is to advise out any data pages that
{     have been processed and advise in any data pages that are to be queued
{     to the pp for transfer to the LCN network.  This routine is intended to
{     be called after data is queued to the LCN network.  This routine will
{     then advise in pages up to a maximum number begining with the next
{     page of data to be transfered.
{
{     DATA_TRANSFER_STATUS: (input) This parameter specifies the parameters
{       for the data transfer request.

?? NEWTITLE := 'terminate_advise_out_in - condition handler', EJECT ??
    PROCEDURE terminate_advise_out_in
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_information;
           sfsa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

{ This condition handler is designed to catch the case in which an attempt was
{ made to advise past the file limit.  When this happens, an abnormal status
{ will be returned.  This in turn will indicate that cleanup is required and
{ that the data transfer is no longer in progress.

      IF (condition.selector = mmc$segment_access_condition) THEN
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT advise_out_in;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      IFEND;
    PROCEND terminate_advise_out_in;
?? OLDTITLE, EJECT ??

    VAR
      first_page_offset: ost$byte_count,
      ignore_status: ost$status,
      in_length: ost$byte_count,
      in_pva: ^cell,
      last_page_offset: ost$byte_count,
      max_in_length: ost$byte_count,
      new_advise_in_segment: BOOLEAN,
      next_page_offset: ost$byte_count,
      out_length: ost$byte_count,
      out_pva: ^cell,
      page_size: ost$page_size;


    status.normal := TRUE;
    osp$establish_condition_handler (^terminate_advise_out_in, FALSE);
    out_pva := NIL;
    in_pva := NIL;
    out_length := 0;
    in_length := 0;
    new_advise_in_segment := FALSE;
    page_size := osv$page_size;

  /determine_advise_out_parameters/
    BEGIN
      IF (data_transfer_status^.next_to_advise_out_index <>
           data_transfer_status^.complete_index) THEN
        data_transfer_status^.next_to_advise_out_index :=
           data_transfer_status^.complete_index;
        data_transfer_status^.next_to_advise_out_offset := 0;
      IFEND;
      IF (data_transfer_status^.next_to_advise_out_offset <
           data_transfer_status^.complete_offset) THEN
        out_pva := i#ptr(data_transfer_status^.next_to_advise_out_offset,
              data_transfer_status^.data_area^[data_transfer_status^.next_to_advise_out_index].
              address);
        first_page_offset := #OFFSET(
              data_transfer_status^.data_area^[data_transfer_status^.next_to_advise_out_index].address);
        last_page_offset := (((first_page_offset + data_transfer_status^.complete_offset) DIV page_size)
              * page_size) - first_page_offset;
        out_length := last_page_offset - data_transfer_status^.next_to_advise_out_offset;
      ELSE
        last_page_offset := data_transfer_status^.next_to_advise_out_offset;
      IFEND;
    END /determine_advise_out_parameters/;

  /determine_advise_in_parameters/
    BEGIN
      IF NOT (data_transfer_status^.data_exhausted) THEN
        IF  (data_transfer_status^.next_to_queue_index > data_transfer_status^.next_to_advise_in_index)  THEN

          {  This is to make sure that the queuing does not get ahead of the advising.  This
          {  could occur if the user fragments are very small.

          data_transfer_status^.next_to_advise_in_index := data_transfer_status^.next_to_queue_index;
          data_transfer_status^.next_to_advise_in_offset := data_transfer_status^.next_to_queue_offset;
        ELSEIF  (data_transfer_status^.next_to_queue_index = data_transfer_status^.next_to_advise_in_index)
                AND (data_transfer_status^.next_to_advise_in_offset <
                             data_transfer_status^.next_to_queue_offset)  THEN
          data_transfer_status^.next_to_advise_in_offset := data_transfer_status^.next_to_queue_offset;
        IFEND;
        max_in_length := rfc$max_blocks_to_add * page_size * 2;
        IF  (data_transfer_status^.next_to_advise_in_index > data_transfer_status^.next_to_queue_index)  OR
            (data_transfer_status^.next_to_advise_in_offset <
             (data_transfer_status^.next_to_queue_offset + max_in_length))       THEN
          in_pva := i#ptr(data_transfer_status^.next_to_advise_in_offset,
                data_transfer_status^.data_area^[data_transfer_status^.next_to_advise_in_index].
                address);
          in_length := data_transfer_status^.data_area^[data_transfer_status^.next_to_advise_in_index].
                length - data_transfer_status^.next_to_advise_in_offset;
          IF in_length > max_in_length THEN
            in_length := max_in_length;
          ELSE
            IF  data_transfer_status^.next_to_advise_in_index <
                                       UPPERBOUND(data_transfer_status^.data_area^)  THEN
              data_transfer_status^.next_to_advise_in_index :=
                data_transfer_status^.next_to_advise_in_index + 1;
              data_transfer_status^.next_to_advise_in_offset := 0;
              new_advise_in_segment := TRUE;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    END /determine_advise_in_parameters/;

    IF  (in_length > (8 * page_size))  THEN
      mmp$advise_out_in (out_pva, out_length, in_pva, in_length, ignore_status);
      IF  NOT new_advise_in_segment  THEN
        data_transfer_status^.next_to_advise_in_offset :=
              data_transfer_status^.next_to_advise_in_offset + in_length;
      IFEND;

      {  The first time this is called 'block_descriptors' is not initialized.
      {  However, there should not be an 'advise out' either.

      IF  data_transfer_status^.block_descriptors <> NIL  THEN
        IF  (data_transfer_status^.next_to_advise_out_index =
              data_transfer_status^.block_descriptors^[data_transfer_status^.block_descriptor_out].
              data_fragment_index)  THEN
          data_transfer_status^.next_to_advise_out_offset := last_page_offset;
        ELSE
          data_transfer_status^.next_to_advise_out_index :=
              data_transfer_status^.block_descriptors^[data_transfer_status^.block_descriptor_out].
              data_fragment_index;
          data_transfer_status^.next_to_advise_out_offset :=
              data_transfer_status^.block_descriptors^[data_transfer_status^.block_descriptor_out].
              data_fragment_offset;
        IFEND;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND advise_out_in;
?? TITLE := '    allocate_connection_entry', EJECT ??
  PROCEDURE allocate_connection_entry (application_entry_p: ^rft$application_table_entry;
    VAR connection_entry_p: ^rft$connection_entry;
    VAR status: ost$status);

{
{     The purpose of this procedure is to allocate and link a
{     connection entry data structure into the connection list for
{     an application. This routine increments the connection count
{     in the application entry and initializes the connection entry
{     linkage.
{
{     APPLICATION_ENTRY_P: (input) This parameter specifies a pointer
{       to the application entry for which a connection table entry
{       is to be allocated.
{
{     CONNECTION_ENTRY_P: (output) This parameter returns a pointer
{       to the connection table entry that has been allocated. A NIL
{       pointer indicates that table allocation failed.
{
{     STATUS: (output) This parameter returns the status of the
{       allocation.  A status of normal indicates that the table
{       allocation succeeded.



    status.normal := TRUE;
    ALLOCATE connection_entry_p IN nav$network_paged_heap^;
    IF connection_entry_p <> NIL THEN
      pmp$zero_out_table (connection_entry_p, #SIZE(rft$connection_entry));
      application_entry_p^.number_of_active_connections :=
             application_entry_p^.number_of_active_connections + 1;
      connection_entry_p^.application_entry_p := application_entry_p;
      connection_entry_p^.connection_attributes.connection_status.connection_state :=
            rfc$not_viable;
      IF application_entry_p^.connection_table = NIL THEN
        connection_entry_p^.next_entry := NIL;
      ELSE
        connection_entry_p^.next_entry := application_entry_p^.connection_table;
      IFEND;
      application_entry_p^.connection_table := connection_entry_p;
    ELSE
      osp$set_status_abnormal (rfc$product_id, rfe$heap_exhausted,
            'network paged', status);
      osp$append_status_parameter(osc$status_parameter_delimiter,
            'allocate_connection_entry', status);
      EXIT allocate_connection_entry;
    IFEND;

  PROCEND allocate_connection_entry;
?? TITLE := '    allocate_network_wired_buffers', EJECT ??
  PROCEDURE allocate_network_wired_buffers (data_transfer_status: ^rft$data_transfer_status;
        data_length: rft$data_length;
    VAR status: ost$status);

{
{     The purpose of this procedure is to allocate the necessary network
{     wired buffers to transfer data to or from the LCN network.  The number
{     allocated is based on the amount of data to transfer.  If the number
{     required is greater than a maximum, the maximum is allocated and the
{     buffers will be reused as needed.  This routine waits until the
{     required buffers are obtained before exiting.
{
{     DATA_TRANSFER_STATUS: (input) This parameter specifies the parameters
{      for the data transfer.
{
{     DATA_LENGTH: (input) This parameter specifies the length of the data
{       that is to be transferred.
{
{     STATUS: (output) This parameter returns the result of this procedure
{       call.  A status of normal indicates that the network wired buffers
{       were allocated.



    VAR
      number_of_blocks: integer,
      number_of_buffers_per_block: integer,
      number_reserved: rft$buffer_count,
      required_wired_buffers: rft$buffer_count;


    status.normal := TRUE;
    number_of_buffers_per_block :=
          (data_transfer_status^.block_size + #SIZE(rft$nbp_block_header) +
          (nlv$bm_large_buffer_size - 1)) DIV nlv$bm_large_buffer_size;
    IF data_length <> 0 THEN
      number_of_blocks := (data_length + (data_transfer_status^.block_size - 1)) DIV
             data_transfer_status^.block_size;
      IF number_of_blocks > data_transfer_status^.maximum_outstanding_blocks  THEN
        number_of_blocks := data_transfer_status^.maximum_outstanding_blocks;
      IFEND;
      required_wired_buffers := number_of_blocks * number_of_buffers_per_block;
      IF rfc$max_wired_buffers_per_req < required_wired_buffers THEN
        required_wired_buffers := rfc$max_wired_buffers_per_req;
        number_of_blocks := required_wired_buffers DIV number_of_buffers_per_block;
      IFEND;
    ELSE
      number_of_blocks := 1;
      required_wired_buffers := 1;
    IFEND;
    ALLOCATE data_transfer_status^.reserved_buffer_list: [ 1 .. required_wired_buffers]
          IN osv$task_private_heap^;
    REPEAT
      number_reserved := required_wired_buffers;
      rfp$reserve_wired_buffers(data_transfer_status^.reserved_buffer_list^,
            number_reserved);
      IF number_reserved <> required_wired_buffers THEN
        IF number_reserved <> 0 THEN
          rfp$release_wired_buffers(data_transfer_status^.reserved_buffer_list^,
              number_reserved);
        IFEND;
        pmp$wait (1000,1000);
      IFEND;
    UNTIL number_reserved = required_wired_buffers;
    data_transfer_status^.reserved_buffer_count := required_wired_buffers;
    data_transfer_status^.maximum_outstanding_blocks := number_of_blocks;

  PROCEND allocate_network_wired_buffers;
?? TITLE := '    build_back_message', EJECT ??
  PROCEDURE build_back_message (VAR data_transfer_status: ^rft$data_transfer_status;
    header_buffer: ^rft$nbp_block_header);

{
{     The purpose of this procedure is to build a back message for a received
{     network block. A back message entry is allocated, the back is
{     constructed, and linked into a local queue of backs to be sent.
{     This routine assumes the control message header has been set up and
{     updates only BACK related fields.
{
{     DATA_TRANSFER_STATUS: (input,output) This parameter specifies a
{       pointer to the data transfer status block to associate this back
{       with.
{
{     HEADER_BUFFER: (input) This parameter specifies the header of the block
{       for which the back is to be queued.


    VAR
      back_message: ^rft$outgoing_control_message,
      next_entry: ^rft$outgoing_control_message,
      present_entry: ^rft$outgoing_control_message;


    present_entry := NIL;
    next_entry := data_transfer_status^.outstanding_control_messages;
    WHILE next_entry <> NIL DO
      present_entry := next_entry;
      next_entry := present_entry^.next_entry;
    WHILEND;

    ALLOCATE back_message: [0]  IN nav$network_paged_heap^;
    IF back_message <> NIL THEN
      back_message^.purge_on_retry := FALSE;
      back_message^.control_message.header := data_transfer_status^.control_message_header;
      back_message^.control_message.header.name(2,1) := $CHAR(header_buffer^.connection_number);
      back_message^.control_message.header.length := 0;
      back_message^.control_message.header.block_type := rfc$nbp_block_type_back;
      back_message^.control_message.header.abn := header_buffer^.application_block_number;
      back_message^.control_message.data := '';
      back_message^.next_entry := NIL;
      IF present_entry = NIL THEN
        data_transfer_status^.outstanding_control_messages := back_message;
      ELSE
        present_entry^.next_entry := back_message;
      IFEND;
    IFEND;

  PROCEND build_back_message;
?? TITLE := '    build_connect_request', EJECT ??
  PROCEDURE build_connect_request (server_name: rft$application_name;
        requesting_application: rft$application_name;
        destination_host: rft$host_identifier;
        server_available_locally: boolean;
        connect_request: ^rft$nbp_outgoing_connect;
    VAR connection_descriptor: rft$connection_descriptor;
    VAR physical_identifier: rft$physical_identifier;
    VAR selected_path_p: ^rft$lcn_path_definition;
    VAR status: ost$status);

{
{     The purpose of this procedure is to search the configuration tables
{     for the requested server and destination host.  If the server/host
{     combination is found a connect message is formated and returned.
{     The remote host definitions and the local host definitions are
{     searched for the requested host/server combination.
{
{     SERVER_NAME: (input) This parameter specifies the server requested.
{
{     REQUESTING_APPLICATION: (input) This parameter specifies the application
{       that is requesting the connection.
{
{     DESTINATION_HOST: (input) This parameter specifies the remote host
{       where the specified server is to reside.
{
{     SERVER_AVAILABLE_LOCALLY: This parameter specifies if the requested
{       service is available locally.
{
{     CONNECT_REQUEST: (input,output)  This parameter specifies a pointer
{       to the connect request buffer.
{
{     CONNECTION_DESCRIPTOR: (output) This parameter returns the connection
{       descriptor for the connection.
{
{     PHYSICAL_IDENTIFIER: (output) This parameter returns the physical
{       identifier of the choosen remote host.
{
{     SELECTED_PATH_P: (output) This parameter returns a pointer to the selected
{       path.
{
{     STATUS: (output) This parameter returns the results of the request.
{       A status of normal indicates that the requested service has been found.
{

    VAR
      host_identifier: rft$destination_hosts,
      host_identifier_p: ^rft$destination_hosts,
      local_status: ost$status,
      map_lid_to_pid: boolean,
      number_of_hosts: rft$number_of_hosts;


    host_identifier_p := ^host_identifier;
    search_for_path (server_name, destination_host, server_available_locally,
          selected_path_p, physical_identifier, host_identifier_p, number_of_hosts,
          map_lid_to_pid, status);
    IF NOT status.normal THEN
      EXIT build_connect_request;
    IFEND;

    pmp$get_microsecond_clock (selected_path_p^.last_attempted_connect,
          local_status);

    CASE selected_path_p^.loopback OF
    = TRUE =
      connect_request^.nad_address :=
            rfv$status_table.local_nads^[selected_path_p^.destination_nad].address;
    = FALSE =
      connect_request^.nad_address :=
            rfv$status_table.remote_nads^[selected_path_p^.remote_nad].address;
      pmp$get_compact_date_time (rfv$status_table.remote_nads^
            [selected_path_p^.remote_nad].last_connect_time, local_status);
    CASEND;
    connect_request^.local_tcu_enables := selected_path_p^.local_tcu_mask;
    connect_request^.destination_device := selected_path_p^.destination_device;
    connect_request^.access_code := selected_path_p^.access_code;
    connect_request^.name := rfv$status_table.local_host^.subsystem_identifier;
    connect_request^.remote_tcu_enables := selected_path_p^.remote_tcu_mask;
    connect_request^.buffer_size := rfc$buffer_4128;
    connect_request^.logical_network := selected_path_p^.logical_network;
    connect_request^.logical_nad := selected_path_p^.logical_nad;
    connect_request^.requested_application := server_name;
    connect_request^.source_physical_id := rfv$status_table.local_host^.physical_identifier;
    connect_request^.requesting_application := requesting_application;
    connect_request^.application_block_number := 0;
    connect_request^.password := rfv$status_table.local_host^.connection_password;
    IF  destination_host.host_identifier_kind = rfc$physical_identifier THEN
      connect_request^.destination_id := destination_host.physical_identifier;
    ELSE
      IF map_lid_to_pid THEN
        connect_request^.destination_id := destination_host.physical_identifier;
      ELSE
        connect_request^.destination_id := destination_host.logical_identifier(1,3);
      IFEND;
    IFEND;

    connection_descriptor.nad_index := selected_path_p^.local_nad;
    connection_descriptor.logical_unit := rfv$status_table.local_nads^[selected_path_p^.local_nad].
          logical_unit_number;

  PROCEND build_connect_request;
?? TITLE := '    build_network_header', EJECT ??
  PROCEDURE build_network_header (data_transfer_status: ^rft$data_transfer_status;
        data_length: rft$nbp_text_length;
        data_exhausted: boolean;
        current_abn: rft$application_block_number;
        header_buffer_p: ^rft$nbp_block_header);

{
{     The purpose of this procedure is to build the level 6 network block
{     header that is transmitted with each network block of data.
{
{     DATA_TRANSFER_STATUS: (input) This parameter specifies the paramameters
{       for the data transfer request.
{
{     DATA_LENGTH: (input) This parameter specifies the amount of data in bytes,
{       that is in the network block.
{
{     DATA_EXHAUSTED: (input) This parameter specifies if this is the last
{       network block of data for this request. A value of true indicates that
{       this is the last block of data.
{
{     CURRENT_ABN: (input) This parameter specifies the block number of the
{       data block that is being sent.
{
{     HEADER_BUFFER_P: (input,output) This parameter specifies a pointer to
{       the header buffer.  The header is built in this buffer.


{     NOTE: The header buffer is zeroed out to preset fields.  Some RHF
{       implementations rely on unsed fields being zero.  This algorithm
{       provides compatability with older systems.

      pmp$zero_out_table (header_buffer_p, #SIZE(rft$nbp_block_header));
      header_buffer_p^.connection_number :=
            data_transfer_status^.connection_descriptor.network_path;
      header_buffer_p^.length := data_length * 8;
      header_buffer_p^.application_block_number := current_abn;
      CASE data_transfer_status^.transmission_mode OF
      = rfc$record_mode =
        header_buffer_p^.block_type := rfc$nbp_block_type_msg;
        header_buffer_p^.data_block_clarifier.pru_block := TRUE;
        IF (data_exhausted) AND (data_transfer_status^.end_of_message) THEN
          CASE data_transfer_status^.file_mark OF
          = rfc$rm_eoi =
            header_buffer_p^.data_block_clarifier.end_of_information := TRUE;
          = rfc$rm_eor =
            header_buffer_p^.data_block_clarifier.end_of_record := TRUE;
          = rfc$rm_eof =
            header_buffer_p^.data_block_clarifier.end_of_record := TRUE;
            header_buffer_p^.data_block_clarifier.eor_level := 0f(16);
          = rfc$rm_null =
            ;
          CASEND;
        IFEND;
      = rfc$message_mode =
        IF (data_exhausted) AND (data_transfer_status^.end_of_message) THEN
          header_buffer_p^.block_type := rfc$nbp_block_type_msg;
        ELSE
          header_buffer_p^.block_type := rfc$nbp_block_type_blk;
        IFEND;
      CASEND;

  PROCEND build_network_header;
?? TITLE := '    build_network_wired_blocks', EJECT ??
  PROCEDURE build_network_wired_blocks (data_transfer_status: ^rft$data_transfer_status;
    VAR unit_request: ^SEQ(*);
    VAR blocks_to_add: rft$outstanding_blocks;
    VAR status: ost$status);


{
{     The purpose of this procedure is to transform the data fragments specified
{     by the user into network blocks and add them to the send or receive pp
{     request.  This routine builds the network block subfunctions and adds
{     them to the pp transfer request.  If the transfer request is a send data
{     request, the data is moved to network wired buffers.  If the transfer
{     request is a receive data request, the request is built directing the pp
{     to write the incoming data into the specified network wired buffers.
{
{     DATA_TRANSFER_STATUS: (input) This parameter specifies the parameters for
{       the data transfer request.
{
{     BLOCKS_TO_ADD: (input,output) This parameter specifies the number of network
{       blocks to add to the pp unit request. Upon return this parameter contains
{       the actual number of blocks added to the pp unit request.
{
{     UNIT_REQUEST: (input,output) This parameter specifies the pp unit request
{       to add the block definitions to.
{
{     STATUS: (ouput) This parameter specifies the results of the request.  A
{       normal status indicates that no abnormal conditions were encountered.

?? NEWTITLE := 'terminate_build_network_wired - condition handler', EJECT ??
    PROCEDURE terminate_build_network_wired (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

{ This condition handler is designed to prevent forseeable error situations
{ from causing unwanted RHFAM/VE side_effects.  Specifically, segment access
{ conditions and system conditions are not allowed to bubble up but are
{ converted to status instead.

      IF (condition.selector = mmc$segment_access_condition) OR
            (condition.selector = pmc$system_conditions) THEN
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT build_network_wired_blocks;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      IFEND;
    PROCEND terminate_build_network_wired;
?? OLDTITLE, EJECT ??

    VAR
      block_length: rft$bytes_transferred,
      block_size: integer,
      buffers_used: rft$buffer_count,
      current_abn: rft$application_block_number,
      current_block: rft$outstanding_blocks,
      current_fragment: rft$data_fragment_count,
      current_offset: rft$data_length,
      current_wired_buffer: rft$buffer_count,
      data_exhausted: boolean,
      data_p: ^cell,
      header_buffer: rft$nbp_block_header,
      header_buffer_p: ^rft$nbp_block_header,
      i: integer,
      index: integer,
      io_fragment: ^rft$io_fragment,
      move_data_length: rft$bytes_transferred,
      next_wired_buffer_in: rft$buffer_count,
      number_of_blocks: ^0..rfc$command_buffer_size,
      number_of_fragments: ^0..rfc$command_buffer_size,
      remaining_block_size: rft$block_size,
      remaining_fragment_length: rft$data_fragment_count,
      reserved_buffer_count: rft$buffer_count,
      reserved_buffer_list: ^rft$buffer_list,
      send_intermediate_response: ^BOOLEAN,
      temporary_block_length: rft$bytes_transferred,
      temporary_fragment: rft$data_fragment_count,
      temporary_offset: rft$data_length,
      wired_buffer_in: rft$buffer_count;

    osp$establish_condition_handler (^terminate_build_network_wired, FALSE);
    data_exhausted := FALSE;
    current_fragment := data_transfer_status^.next_to_queue_index;
    current_offset := data_transfer_status^.next_to_queue_offset;
    current_abn := data_transfer_status^.next_to_queue_abn;
    current_block := data_transfer_status^.block_descriptor_in;
    reserved_buffer_list := data_transfer_status^.reserved_buffer_list;
    current_wired_buffer := data_transfer_status^.next_wired_buffer_in;
    next_wired_buffer_in := current_wired_buffer;
    reserved_buffer_count := data_transfer_status^.reserved_buffer_count;

    IF blocks_to_add > rfc$max_blocks_to_add THEN
      blocks_to_add := rfc$max_blocks_to_add;
    IFEND;
    NEXT send_intermediate_response IN unit_request;
    IF send_intermediate_response = NIL THEN
      osp$set_status_abnormal ( rfc$product_id, rfe$request_processing_err,
            'the request overflowed the request sequence', status);
      osp$append_status_parameter(osc$status_parameter_delimiter,
            'build_network_wired_blocks', status);
      EXIT build_network_wired_blocks;
    IFEND;
    NEXT number_of_blocks IN unit_request;
    IF number_of_blocks = NIL THEN
      osp$set_status_abnormal ( rfc$product_id, rfe$request_processing_err,
            'the request overflowed the request sequence', status);
      osp$append_status_parameter(osc$status_parameter_delimiter,
            'build_network_wired_blocks', status);
      EXIT build_network_wired_blocks;
    IFEND;
    number_of_blocks^ := 0;

    /build_requested_blocks/
    FOR index := 1 TO blocks_to_add DO
      NEXT number_of_fragments IN unit_request;
      IF number_of_fragments = NIL THEN
        osp$set_status_abnormal ( rfc$product_id, rfe$request_processing_err,
              'the request overflowed the request sequence', status);
        osp$append_status_parameter(osc$status_parameter_delimiter,
              'build_network_wired_blocks', status);
        EXIT build_network_wired_blocks;
      IFEND;
      number_of_fragments^ := 0;

      data_transfer_status^.block_descriptors^[current_block].data_fragment_index :=
            current_fragment;
      data_transfer_status^.block_descriptors^[current_block].data_fragment_offset :=
            current_offset;
      data_transfer_status^.block_descriptors^[current_block].block_sequence_number := current_abn;
      data_transfer_status^.block_descriptors^[current_block].wired_buffer_index := current_wired_buffer;

      remaining_block_size := data_transfer_status^.block_size;
      block_length := 0;
      temporary_block_length := 0;
      temporary_fragment := current_fragment;
      temporary_offset := current_offset;

      CASE data_transfer_status^.transfer_kind OF
      = rfc$tk_send_data =
        block_size := data_transfer_status^.block_size + #SIZE(rft$nbp_block_header);
        wired_buffer_in := next_wired_buffer_in;
      /reset_send_buffers/
        WHILE block_size > 0 DO
          reserved_buffer_list^[wired_buffer_in].byte_count := 0;
          block_size := block_size - nlv$bm_large_buffer_size;
          wired_buffer_in := (wired_buffer_in MOD reserved_buffer_count) + 1;
        WHILEND /reset_send_buffers/;
        header_buffer_p := #LOC(reserved_buffer_list^[next_wired_buffer_in].buffer^);
        move_data_length := #size(rft$nbp_block_header);
        data_p := #LOC(header_buffer);
        rfp$move_data_to_wired_buffs(reserved_buffer_list^, data_p, reserved_buffer_count,
              current_wired_buffer, move_data_length);

      /advance_send_data_by_block/
        WHILE remaining_block_size > 0 {AND NOT data exhausted} DO
          remaining_fragment_length := data_transfer_status^.data_area^[temporary_fragment].length -
                temporary_offset;
          data_p := i#ptr(temporary_offset, data_transfer_status^.data_area^[temporary_fragment].address);
          IF remaining_fragment_length > remaining_block_size THEN
            move_data_length := remaining_block_size;
            temporary_offset := temporary_offset + move_data_length;
            rfp$move_data_to_wired_buffs(reserved_buffer_list^, data_p, reserved_buffer_count,
                  current_wired_buffer, move_data_length);
            temporary_block_length := temporary_block_length + remaining_block_size;
            remaining_block_size := 0;
          ELSE   {remainder of fragment fits in network block}
            move_data_length := remaining_fragment_length;
            rfp$move_data_to_wired_buffs(reserved_buffer_list^, data_p, reserved_buffer_count,
                  current_wired_buffer, move_data_length);
            remaining_block_size := remaining_block_size - remaining_fragment_length;
            temporary_block_length := temporary_block_length + remaining_fragment_length;
            IF temporary_fragment = UPPERBOUND(data_transfer_status^.data_area^) THEN
              temporary_offset := temporary_offset + remaining_fragment_length;
              data_exhausted := TRUE;
              IF data_transfer_status^.transmission_mode = rfc$record_mode THEN
                IF (remaining_block_size <> 0) AND
                    NOT (data_transfer_status^.end_of_message) THEN
                  osp$set_status_abnormal (rfc$product_id, rfe$unable_to_send_all_data,
                        'no end of message was specified', data_transfer_status^.previous_error);
                  EXIT /build_requested_blocks/;
                IFEND;
              IFEND;
              EXIT /advance_send_data_by_block/;
            IFEND;
            temporary_offset := 0;
            temporary_fragment := temporary_fragment + 1;
          IFEND;
        WHILEND /advance_send_data_by_block/;

        block_length := temporary_block_length;
        current_fragment := temporary_fragment;
        current_offset := temporary_offset;
        build_network_header (data_transfer_status, block_length, data_exhausted,
              current_abn, header_buffer_p);

      = rfc$tk_receive_data =

      /advance_receive_data_by_block/
        WHILE remaining_block_size > 0 {AND NOT data exhausted} DO
          remaining_fragment_length := data_transfer_status^.data_area^[temporary_fragment].length -
                temporary_offset;
          IF remaining_fragment_length > remaining_block_size THEN
            temporary_offset := temporary_offset + remaining_block_size;
            temporary_block_length := temporary_block_length + remaining_block_size;
            remaining_block_size := 0;
          ELSE   {remainder of fragment fits in the network block}
            remaining_block_size := remaining_block_size - remaining_fragment_length;
            temporary_block_length := temporary_block_length + remaining_fragment_length;
            IF temporary_fragment = UPPERBOUND(data_transfer_status^.data_area^) THEN

{     Round up the block length to a multiple of network blocks

              temporary_block_length := temporary_block_length + remaining_block_size;
              temporary_offset := temporary_offset + remaining_fragment_length;
              data_exhausted := TRUE;
              EXIT /advance_receive_data_by_block/;
            IFEND;
            temporary_offset := 0;
            temporary_fragment := temporary_fragment + 1;
          IFEND;
        WHILEND /advance_receive_data_by_block/;

        block_length := temporary_block_length;
        current_fragment := temporary_fragment;
        current_offset := temporary_offset;
        block_size := block_length + #SIZE(rft$nbp_block_header);
        wired_buffer_in := next_wired_buffer_in;
     /initialize_reserved_buffers/
        WHILE block_size > 0 DO
          IF block_size > nlv$bm_large_buffer_size THEN
            reserved_buffer_list^[wired_buffer_in].byte_count := nlv$bm_large_buffer_size;
          ELSE
            reserved_buffer_list^[wired_buffer_in].byte_count := block_size;
          IFEND;
          reserved_buffer_list^[wired_buffer_in].current_offset := 0;
          block_size := block_size - nlv$bm_large_buffer_size;
          wired_buffer_in := (wired_buffer_in MOD reserved_buffer_count) + 1;
        WHILEND /initialize_reserved_buffers/;
      CASEND;

      buffers_used := (block_length + #SIZE(rft$nbp_block_header) +
                       nlv$bm_large_buffer_size - 1) DIV nlv$bm_large_buffer_size;

    /build_io_fragments/
      FOR i := 1 TO buffers_used DO
        NEXT io_fragment IN unit_request;
        IF io_fragment = NIL THEN
          osp$set_status_abnormal ( rfc$product_id, rfe$request_processing_err,
              'the request overflowed the request sequence', status);
          osp$append_status_parameter(osc$status_parameter_delimiter,
              'build_network_wired_blocks', status);
          EXIT build_network_wired_blocks;
        IFEND;
        io_fragment^.address := reserved_buffer_list^[next_wired_buffer_in].buffer;
        io_fragment^.length := reserved_buffer_list^[next_wired_buffer_in].byte_count;
        io_fragment^.wired := TRUE;
        number_of_fragments^ := number_of_fragments^ + 1;
        next_wired_buffer_in := (next_wired_buffer_in MOD reserved_buffer_count) + 1;
      FOREND /build_io_fragments/;

      current_wired_buffer := next_wired_buffer_in;
      number_of_blocks^ := number_of_blocks^ + 1;
      data_transfer_status^.block_descriptors^[current_block].byte_count := block_length;

      current_abn := (current_abn + 1) MOD (rfc$max_appl_block_number + 1);
      current_block :=
            (current_block MOD UPPERBOUND(data_transfer_status^.block_descriptors^)) + 1;

      IF data_exhausted THEN
        EXIT /build_requested_blocks/;
      IFEND;

    FOREND /build_requested_blocks/;

    blocks_to_add := number_of_blocks^;
    data_transfer_status^.current_fragment_index :=  current_fragment;
    data_transfer_status^.current_fragment_offset := current_offset;
    data_transfer_status^.current_abn := current_abn;
    data_transfer_status^.block_descriptor_in := current_block;
    data_transfer_status^.next_wired_buffer_in := current_wired_buffer;
    data_transfer_status^.data_exhausted := data_exhausted;
    send_intermediate_response^ := NOT data_exhausted;

    osp$disestablish_cond_handler;

  PROCEND build_network_wired_blocks;
?? TITLE := '    build_transfer_request_header', EJECT ??
  PROCEDURE build_transfer_request_header (
        data_transfer_status: ^rft$data_transfer_status;
        termination_mark: rft$record_marks;
    VAR unit_request: ^ SEQ ( * );
    VAR status: ost$status);

{
{     The purpose of this procedure is to build the header portion of a
{     pp data transfer request.  This header is required whenever a
{     transfer request is initiated.
{
{     DATA_TRANSFER_STATUS: (input) This parameter specifies the parameters
{      for the data transfer request.
{
{     TERMINATION_MARK: (input) This parameter specifies the file mark
{       that will terminate a receive data request when encountered by the
{       pp.
{
{     UNIT_REQUEST: (input,output) This parameter specifies the sequence to build
{       the data transfer request header in.
{
{     STATUS: (output) This parameter returns the results of the request.
{       A status of normal indicates that the transfer header was successfully
{       built.


    VAR
      asynchronous_request: ^boolean,
      command_identifier: ^rft$logical_commands,
      path_id: ^rft$path_identifier,
      transfer_type: ^rft$transfer_mode;



    status.normal := TRUE;
    RESET unit_request;
    NEXT command_identifier  IN  unit_request;
    IF  command_identifier = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err,
            'the request overflowed the request sequence', status);
      osp$append_status_parameter(osc$status_parameter_delimiter,
            'build_transfer_request_header', status);
      EXIT  build_transfer_request_header;
    IFEND;
    CASE data_transfer_status^.transfer_kind OF
    = rfc$tk_send_data =
      command_identifier^ := rfc$lc_send_data;
    = rfc$tk_receive_data =
      command_identifier^ := rfc$lc_receive_data;
      NEXT transfer_type IN  unit_request;
      IF  transfer_type = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err,
              'the request overflowed the request sequence', status);
        osp$append_status_parameter(osc$status_parameter_delimiter,
              'build_transfer_request_header', status);
        EXIT  build_transfer_request_header;
      IFEND;
      IF data_transfer_status^.transmission_mode = rfc$record_mode THEN
        transfer_type^.transfer_mode := rfc$tm_record_mode;
        transfer_type^.termination_mark := termination_mark;
      ELSE
        transfer_type^.transfer_mode := rfc$tm_message_mode;
      IFEND;
    CASEND;
    NEXT asynchronous_request IN  unit_request;
    IF  asynchronous_request = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err,
            'the request overflowed the request sequence', status);
      osp$append_status_parameter(osc$status_parameter_delimiter,
            'build_transfer_request_header', status);
      EXIT  build_transfer_request_header;
    IFEND;
    asynchronous_request^ := (data_transfer_status^.wait = osc$nowait);
    NEXT  path_id  IN  unit_request;
    IF  path_id = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err,
            'the request overflowed the request sequence', status);
      osp$append_status_parameter(osc$status_parameter_delimiter,
            'build_transfer_request', status);
      EXIT  build_transfer_request_header;
    IFEND;
    path_id^ := data_transfer_status^.connection_descriptor.network_path;


  PROCEND build_transfer_request_header;
?? TITLE := '    build_unwired_blocks', EJECT ??
  PROCEDURE build_unwired_blocks (data_transfer_status: ^rft$data_transfer_status;
    VAR unit_request: ^SEQ(*);
    VAR blocks_to_add: rft$outstanding_blocks;
    VAR status: ost$status);


{
{     The purpose of this procedure is to transform the data fragments specified
{     by the user into network blocks and add them to the send or receive pp
{     request.  This routine builds the network block subfunctions and adds
{     them to the pp transfer request.  In the case of send data, the subfunctions
{     direct the pp to the location of the data to be sent. In the case of receive
{     data, the subfunctions direct the pp to where the data is to be written.
{
{     DATA_TRANSFER_STATUS: (input) This parameter specifies the parameters for
{       the data transfer request.
{
{     UNIT_REQUEST: (input,output) This parameter specifies the pp unit request
{       to add the block definitions to.
{
{     BLOCKS_TO_ADD: (input,output) This parameter specifies the number of network
{       blocks to add to the pp unit request. Upon return this parameter contains
{       the actual number of blocks added to the pp unit request.
{
{     STATUS: (ouput) This parameter specifies the results of the request.  A
{       normal status indicates that no abnormal conditions were encountered.


    VAR
      block: rft$outstanding_blocks,
      block_descriptors: ^rft$block_descriptors,
      block_size: rft$block_size,
      current_abn: rft$application_block_number,
      current_block: rft$outstanding_blocks,
      current_fragment: rft$data_fragment_count,
      current_offset: rft$data_length,
      data_exhausted: boolean,
      header_buffers: ^rft$header_buffers,
      header_fragment: ^rft$io_fragment,
      io_fragment: ^rft$io_fragment,
      number_of_blocks: ^0..rfc$command_buffer_size,
      number_of_fragments: ^0..rfc$command_buffer_size,
      remaining_fragment_length: rft$data_fragment_count,
      send_intermediate_response: ^BOOLEAN;

    data_exhausted := FALSE;
    current_fragment := data_transfer_status^.next_to_queue_index;
    current_offset := data_transfer_status^.next_to_queue_offset;
    current_abn := data_transfer_status^.next_to_queue_abn;
    current_block := data_transfer_status^.block_descriptor_in;
    block_size := data_transfer_status^.block_size;
    header_buffers := data_transfer_status^.header_buffers;
    block_descriptors := data_transfer_status^.block_descriptors;


    IF blocks_to_add > rfc$max_blocks_to_add THEN
      blocks_to_add := rfc$max_blocks_to_add;
    IFEND;
    NEXT send_intermediate_response IN unit_request;
    IF send_intermediate_response = NIL THEN
      osp$set_status_abnormal ( rfc$product_id, rfe$request_processing_err,
            'the request overflowed the request sequence', status);
      osp$append_status_parameter(osc$status_parameter_delimiter,
            'build_unwired_blocks', status);
      EXIT build_unwired_blocks;
    IFEND;
    NEXT number_of_blocks IN unit_request;
    IF number_of_blocks = NIL THEN
      osp$set_status_abnormal ( rfc$product_id, rfe$request_processing_err,
            'the request overflowed the request sequence', status);
      osp$append_status_parameter(osc$status_parameter_delimiter,
            'build_unwired_blocks', status);
      EXIT build_unwired_blocks;
    IFEND;
    number_of_blocks^ := 0;

    /build_requested_blocks/
    FOR block := 1 TO blocks_to_add DO
      NEXT number_of_fragments IN unit_request;
      IF number_of_fragments = NIL THEN
        osp$set_status_abnormal ( rfc$product_id, rfe$request_processing_err,
              'the request overflowed the request sequence', status);
        osp$append_status_parameter(osc$status_parameter_delimiter,
              'build_unwired_blocks', status);
        EXIT build_unwired_blocks;
      IFEND;
      number_of_fragments^ := 0;

      NEXT header_fragment IN unit_request;
      IF header_fragment = NIL THEN
        osp$set_status_abnormal ( rfc$product_id, rfe$request_processing_err,
              'the request overflowed the request sequence', status);
        osp$append_status_parameter(osc$status_parameter_delimiter,
              'build_unwired_blocks', status);
        EXIT build_unwired_blocks;
      IFEND;

      header_fragment^.length := #size(rft$nbp_block_header);
      header_fragment^.address := #loc(header_buffers^[current_block]);
      header_fragment^.wired := TRUE;
      number_of_fragments^ := 1;

      NEXT io_fragment IN unit_request;
      IF io_fragment = NIL THEN
        osp$set_status_abnormal ( rfc$product_id, rfe$request_processing_err,
              'the request overflowed the request sequence', status);
        osp$append_status_parameter(osc$status_parameter_delimiter,
              'build_unwired_blocks', status);
        EXIT build_unwired_blocks;
      IFEND;

      remaining_fragment_length := data_transfer_status^.data_area^[current_fragment].length -
            current_offset;
      io_fragment^.address := i#ptr(current_offset, data_transfer_status^.
            data_area^[current_fragment].address);
      block_descriptors^[current_block].data_fragment_index :=
            current_fragment;
      block_descriptors^[current_block].data_fragment_offset :=
            current_offset;
      block_descriptors^[current_block].block_sequence_number := current_abn;
      IF remaining_fragment_length > block_size THEN
        current_offset := current_offset + block_size;
        io_fragment^.length := block_size;
      ELSEIF remaining_fragment_length = block_size THEN
        IF current_fragment = UPPERBOUND(data_transfer_status^.data_area^) THEN
          data_exhausted := TRUE;
        ELSE
          data_transfer_status^.switch_to_wired_buffers := TRUE;
        IFEND;
        current_offset := current_offset + remaining_fragment_length;
        io_fragment^.length := remaining_fragment_length;
      ELSE  { remaining data does not fill the network block }
        CASE data_transfer_status^.transfer_kind OF
        = rfc$tk_send_data =
          IF current_fragment = UPPERBOUND(data_transfer_status^.data_area^) THEN
            data_exhausted := TRUE;
            IF (NOT data_transfer_status^.end_of_message) AND
                  (data_transfer_status^.transmission_mode = rfc$record_mode) THEN
              osp$set_status_abnormal (rfc$product_id, rfe$unable_to_send_all_data,
                    'no end of message was specified', data_transfer_status^.previous_error);
              EXIT /build_requested_blocks/;
            IFEND;
            current_offset := current_offset + remaining_fragment_length;
          ELSE
            data_transfer_status^.switch_to_wired_buffers := TRUE;
            EXIT /build_requested_blocks/;
          IFEND;
        = rfc$tk_receive_data =
          data_transfer_status^.switch_to_wired_buffers := TRUE;
          EXIT /build_requested_blocks/;
        CASEND;
        io_fragment^.length := remaining_fragment_length;
      IFEND;
      number_of_fragments^ := number_of_fragments^ + 1;
      block_descriptors^[current_block].byte_count := io_fragment^.length;
      io_fragment^.wired := FALSE;
      number_of_blocks^ := number_of_blocks^ + 1;

      IF data_transfer_status^.transfer_kind = rfc$tk_send_data THEN
        build_network_header (data_transfer_status, io_fragment^.length, data_exhausted,
              current_abn, ^header_buffers^[current_block].header);
      IFEND;

      current_abn := (current_abn + 1) MOD (rfc$max_appl_block_number + 1);
      current_block := (current_block MOD UPPERBOUND(block_descriptors^)) + 1;

      IF data_exhausted THEN
        EXIT /build_requested_blocks/;
      IFEND;

    FOREND /build_requested_blocks/;

    blocks_to_add := number_of_blocks^;
    data_transfer_status^.current_fragment_index :=  current_fragment;
    data_transfer_status^.current_fragment_offset := current_offset;
    data_transfer_status^.current_abn := current_abn;
    data_transfer_status^.block_descriptor_in := current_block;
    data_transfer_status^.data_exhausted := data_exhausted;
    send_intermediate_response^ := NOT (data_exhausted OR data_transfer_status^.switch_to_wired_buffers);

  PROCEND build_unwired_blocks;
?? TITLE := '    rfp$change_attributes', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$change_attributes (
        connection_file: fst$file_reference;
        file_attributes: rft$change_attributes;
    VAR status: ost$status);

*copyc rfh$change_attributes

?? NEWTITLE := '      terminate_change - condition handler', EJECT ??
    PROCEDURE terminate_change (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        IF connection_entry_p <> NIL THEN
          rfp$unlock_table (connection_entry_p^.lock);
        IFEND;
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$change_attributes;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$change_attributes;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_change;
?? OLDTITLE, EJECT ??


    VAR
      connection_entry_p: ^rft$connection_entry,
      path_handle_name: fst$path_handle_name;


    connection_entry_p := NIL;
    osp$establish_condition_handler (^terminate_change, FALSE);
    status.normal := TRUE;

    get_path_handle_name (connection_file, path_handle_name, status);
    IF NOT status.normal THEN
      EXIT rfp$change_attributes;
    IFEND;
    get_exclusive_to_connection (path_handle_name, connection_entry_p, status);
    IF NOT status.normal THEN
      EXIT rfp$change_attributes;
    IFEND;
    merge_change_attributes (^connection_entry_p^.connection_attributes,
          ^file_attributes, status);
    rfp$unlock_table (connection_entry_p^.lock);

  PROCEND rfp$change_attributes;
?? TITLE := '    rfp$check_for_event', EJECT ??
  PROCEDURE [XDCL] rfp$check_for_event (event: ost$i_activity;
    VAR event_occurred: boolean;
    VAR status: ost$status);

{
{     The purpose of this procedure is to check for the occurrance of
{     the specified event in the RHFAM tables.
{
{     EVENT: (input) This parameter specifies the event to check for.
{
{     EVENT_OCCURRED: (output) This parameter specifies if the event
{       has occurred. This parameter is not meaningful if the status
{       parameter is not normal.
{
{     STATUS: (output) This parameter returns the status of the request.
{       A status of normal indicates that the event was successfully
{       checked.
{
{     NOTE: PMP$WAIT must not be called within this routine unless an
{       abnormal status or an event occurred is going to be returned.
{       If it is called, it could absorb a ready task flag that was
{       raised because of another event occuring.  The ready flag
{       would have intended to pull the task out of the pmp$wait in
{       osp$i_await_activity but it would be spent getting out of the
{       pmp$wait in these routines.

?? NEWTITLE := '      terminate_check_event - condition handler', EJECT ??
    PROCEDURE terminate_check_event (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      VAR
        activity_status: ^ost$activity_status,
        current_request: ^rft$outstanding_requests,
        mgmt_status: ^rft$connection_mgmt_status,
        previous_request: ^rft$outstanding_requests;

      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        block_exit_expected := TRUE;
        EXIT rfp$check_for_event;
      = pmc$block_exit_processing =
        IF block_exit_expected THEN
          condition_status.normal := TRUE;
        ELSE
          current_request := rfv$outstanding_requests;
        /complete_synchronous_request/
          WHILE current_request <> NIL DO
            IF (current_request^.request_id.ring_1_id.address <> NIL) AND
               (NOT current_request^.request_id.ring_1_id.address^.asynchronous_request) THEN
              mgmt_status := current_request^.request_status;
              activity_status := mgmt_status^.activity_status;
              REPEAT
                #SPOIL (activity_status^);
                syp$cycle;
                rfp$process_pp_response_flag (rfc$pp_response_available);
              UNTIL activity_status^.complete;
              FREE activity_status  IN osv$task_private_heap^;
              current_request := rfv$outstanding_requests;
              EXIT /complete_synchronous_request/;
            IFEND;
            current_request := current_request^.next_entry;
          WHILEND /complete_synchronous_request/;
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, condition_status,
                status);
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          current_request := rfv$outstanding_requests;
          previous_request := NIL;
        /complete_recovered_requests/
          WHILE current_request <> NIL DO
            IF current_request^.request_kind = rfc$rk_path_status THEN
              mgmt_status := current_request^.request_status;
              FREE mgmt_status^.activity_status IN osv$task_private_heap^;
              IF previous_request = NIL THEN
                rfv$outstanding_requests := current_request^.next_entry;
              ELSE
                previous_request^.next_entry := current_request^.next_entry;
              IFEND;
              FREE mgmt_status IN osv$task_private_heap^;
              FREE current_request IN osv$task_private_heap^;
              EXIT /complete_recovered_requests/;
            IFEND;
            previous_request := current_request;
            current_request := current_request^.next_entry;
          WHILEND /complete_recovered_requests/;
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          block_exit_expected := TRUE;
          EXIT rfp$check_for_event;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_check_event;
?? OLDTITLE, EJECT ??


    VAR
      application_entry_p: ^rft$application_table_entry,
      block_exit_expected: boolean,
      connection_descriptor: rft$connection_descriptor,
      connection_entry_p: ^rft$connection_entry,
      connection_unlocked: boolean,
      event_queue_entry_p : ^rft$rhfam_event_table_entry,
      event_to_enter: rft$rhfam_event_table_entry,
      first_pass: boolean,
      input_available: boolean,
      ignore_status: ost$status,
      job_name: jmt$system_supplied_name,
      job_table_entry_p: ^rft$rhfam_job_table_entry,
      job_table_locked: boolean,
      new_entry: boolean,
      path_handle_name: fst$path_handle_name,
      server_entry_p: ^rft$rhfam_server_table_entry,
      server_name: rft$application_name,
      switched_connection: ^rft$switched_connection,
      user_job_name: jmt$user_supplied_name;


    block_exit_expected := FALSE;
    first_pass := TRUE;
    osp$establish_condition_handler (^terminate_check_event, TRUE);
    status.normal := TRUE;
    event_occurred := FALSE;


{     The checking of RHFAM events is done in a two pass loop.  The
{     first pass checks for the event and if the event has not occurred,
{     an entry is placed in the RHFAM event queue.  The second pass is
{     used to close the window where the event occurs after the test is
{     made and before the event is entered into the event queue.  This case
{     will cause a several second delay before the system task will
{     again check for the condition and restart the task.  In the case
{     of incoming connects, the system task will not restart the task
{     and the event will never occur.

  /check_event_loop/
    WHILE (NOT event_occurred) AND
          (status.normal ) DO
      CASE event.activity OF
      = rfc$i_await_server_response =
      get_path_handle_name (event.file^, path_handle_name, status);
        IF status.normal THEN
          get_exclusive_to_connection (path_handle_name, connection_entry_p, status);
          IF status.normal THEN
            connection_descriptor := connection_entry_p^.connection_descriptor;
            update_connection_status (connection_entry_p, input_available,
                  connection_unlocked, status);
            IF NOT connection_unlocked THEN
              CASE connection_entry_p^.connection_attributes.connection_status.
                    connection_state OF
              = rfc$outgoing_connect_active =
                ;
              = rfc$connected, rfc$connect_rejected =
                event_occurred := TRUE;
              ELSE
                set_connection_status (connection_entry_p, status);
              CASEND;
              rfp$unlock_table (connection_entry_p^.lock);
            IFEND;
          IFEND;
        IFEND;

        IF (first_pass) AND
           (status.normal) AND
           (NOT event_occurred) THEN
          rfp$lock_table (rfv$status_table.lock);
          IF rfv$status_table.system_task_is_up THEN
            event_to_enter.event_kind := rfc$ana_await_server_response;
            event_to_enter.asr_connection_descriptor := connection_descriptor;
            enter_event_queue (^event_to_enter, event_queue_entry_p, status);
          ELSE
            osp$set_status_abnormal (rfc$product_id,
                  rfe$system_task_not_active, 'Await incoming connection', status);
          IFEND;
          rfp$unlock_table (rfv$status_table.lock);
        IFEND;

      = rfc$i_await_incoming_connect =
        job_table_locked := FALSE;
        rfp$lock_job_table_entry (FALSE, new_entry, job_table_entry_p);
        IF job_table_entry_p <> NIL THEN
          job_table_locked := TRUE;
          server_name := event.application_name;
          find_application_entry (server_name, job_table_entry_p, application_entry_p);
          IF application_entry_p <> NIL THEN
            IF application_entry_p^.application_kind = rfc$server THEN
              job_name := job_table_entry_p^.job_name;
              job_table_entry_p^.lock := tmv$null_global_task_id;
              job_table_locked := FALSE;
              rfp$lock_table (rfv$rhfam_server_table.lock);
              find_server_entry (server_name, FALSE, server_entry_p, status);
              IF status.normal THEN
                event_occurred := (server_entry_p^.incoming_connect <> NIL);
              IFEND;
              rfp$unlock_table(rfv$rhfam_server_table.lock);
            ELSE
              osp$set_status_abnormal (rfc$product_id, rfe$not_signed_on_as_server,
                'Await incoming connection', status);
              osp$append_status_parameter (osc$status_parameter_delimiter, server_name, status);
            IFEND;
          ELSE
            osp$set_status_abnormal (rfc$product_id, rfe$not_signed_on,
              'Await incoming connection', status);
            osp$append_status_parameter (osc$status_parameter_delimiter, server_name, status);
          IFEND;
        ELSE
          osp$set_status_abnormal (rfc$product_id, rfe$not_an_rhfam_job,
                'Await incoming connection', status);
        IFEND;

        IF job_table_locked THEN
           job_table_entry_p^.lock := tmv$null_global_task_id;
        IFEND;

        IF (first_pass) AND
           (status.normal) AND
           (NOT event_occurred) THEN
          rfp$lock_table (rfv$status_table.lock);
          IF rfv$status_table.system_task_is_up THEN
            event_to_enter.event_kind := rfc$ana_await_incoming_connect;
            event_to_enter.aic_job_name := job_name;
            event_to_enter.aic_server_name := server_name;
            enter_event_queue (^event_to_enter, event_queue_entry_p, status);
          ELSE
            osp$set_status_abnormal (rfc$product_id,
                  rfe$system_task_not_active, 'Await incoming connection', status);
          IFEND;
          rfp$unlock_table (rfv$status_table.lock);
        IFEND;

      = rfc$i_await_switch_offer =
        rfp$lock_job_table_entry (FALSE, new_entry, job_table_entry_p);
        IF job_table_entry_p <> NIL THEN
          rfp$lock_table (rfv$switched_connection_queue.lock);
          switched_connection := rfv$switched_connection_queue.first_entry;

        /find_switched_connection/
          WHILE switched_connection <> NIL DO
            IF (job_table_entry_p^.job_name = switched_connection^.destination_job) AND
               (event.application_name = switched_connection^.destination_application) THEN
              event_occurred := TRUE;
              EXIT /find_switched_connection/;
            IFEND;
            switched_connection := switched_connection^.next_entry;
          WHILEND /find_switched_connection/;

          IF (first_pass) AND
             (NOT event_occurred) THEN
            event_to_enter.event_kind := rfc$ana_await_switch_offer;
            event_to_enter.aso_application_name := event.application_name;
            enter_event_queue (^event_to_enter, event_queue_entry_p, status);
          IFEND;
          rfp$unlock_table (rfv$switched_connection_queue.lock);
          job_table_entry_p^.lock := tmv$null_global_task_id;
        ELSE
          osp$set_status_abnormal (rfc$product_id, rfe$not_an_rhfam_job,
                'Await switch offer', status);
        IFEND;

      = rfc$i_await_switch_accept =
        IF first_pass THEN
          get_path_handle_name (event.connection_file^, path_handle_name, status);
          IF status.normal THEN
            get_exclusive_to_connection (path_handle_name, connection_entry_p, status);
            IF status.normal THEN
              CASE connection_entry_p^.connection_attributes.connection_status.connection_state OF
              = rfc$switch_offered =
                event_to_enter.event_kind := rfc$ana_await_switch_accept;
                pmp$get_job_names(user_job_name, event_to_enter.asa_source_job, ignore_status);
                enter_event_queue (^event_to_enter, event_queue_entry_p, status);

{     The connection that is offered for switch is effectively locked until it is either
{     accepted by the new job or the switch offer is withdrawn.  The job accepting the switch
{     sets the connection state without locking the placeholder connection entry, and then
{     issues a ready task for any task waiting for switch accept on the connection.  To prevent
{     a timing window, the waiting task rechecks the connection status after entering the
{     event queue.

                event_occurred := (connection_entry_p^.connection_attributes.connection_status.
                      connection_state = rfc$switch_accepted);
              = rfc$switch_accepted =
                event_occurred := TRUE;
              ELSE
                set_connection_status (connection_entry_p, status);
              CASEND;
              rfp$unlock_table (connection_entry_p^.lock);
            IFEND;
          IFEND;
        IFEND;
      = rfc$i_await_connection_event =
        get_exclusive_to_cid (event.connection_file_identifier, connection_entry_p, status);
        IF status.normal THEN
          connection_descriptor := connection_entry_p^.connection_descriptor;
          update_connection_status (connection_entry_p, input_available,
                connection_unlocked, status);
          IF NOT connection_unlocked THEN
            CASE connection_entry_p^.connection_attributes.connection_status.connection_state OF
            = rfc$connected =
              CASE event.event_type OF
              = rfc$input_available =
                event_occurred := (connection_entry_p^.connection_attributes.connection_status.
                      input_available);
              = rfc$output_below_threshold =
                event_occurred := connection_entry_p^.connection_attributes.connection_status.
                      output_below_threshold;
              ELSE
                osp$set_status_abnormal (rfc$product_id, rfe$invalid_connection_event, '',status);
              CASEND;
            = rfc$terminated =
              CASE event.event_type OF
              = rfc$input_available =
                IF NOT input_available THEN
                  set_connection_status (connection_entry_p, status);
                ELSE
                  event_occurred := input_available;
                IFEND;
              = rfc$output_below_threshold =
                set_connection_status (connection_entry_p, status);
              ELSE
                osp$set_status_abnormal (rfc$product_id, rfe$invalid_connection_event, '',status);
              CASEND;
            ELSE
              set_connection_status (connection_entry_p, status);
            CASEND;
            rfp$unlock_table (connection_entry_p^.lock);

            IF (first_pass) AND
               (status.normal) AND
               (NOT event_occurred) THEN
              rfp$lock_table (rfv$status_table.lock);
              IF rfv$status_table.system_task_is_up THEN
                event_to_enter.event_kind := rfc$ana_await_connection_event;
                event_to_enter.ace_connection_descriptor := connection_descriptor;
                event_to_enter.ace_input_available := (event.event_type = rfc$input_available);
                event_to_enter.ace_output_buffer_available :=
                      (event.event_type = rfc$output_below_threshold);
                event_to_enter.ace_asynchronous_wait := FALSE;
                event_to_enter.ace_data_transfer_in_progress := FALSE;
                enter_event_queue (^event_to_enter, event_queue_entry_p, status);
              ELSE
                osp$set_status_abnormal (rfc$product_id,
                      rfe$system_task_not_active, 'Await incoming connection', status);
              IFEND;
              rfp$unlock_table (rfv$status_table.lock);
            IFEND;
          IFEND;
        IFEND;
      ELSE
        {  This case should never happen. Ignore the undefined event.
      CASEND;
      IF first_pass THEN
        first_pass := FALSE;
      ELSE
        EXIT /check_event_loop/;
      IFEND;
    WHILEND /check_event_loop/;
    osp$disestablish_cond_handler;

  PROCEND rfp$check_for_event;
?? TITLE := '    rfp$close_file', EJECT ??
  PROCEDURE  [XDCL] rfp$close_file (file_identifier: amt$file_identifier;
        layer: amt$fap_layer_number;
        call_block: amt$call_block;
    VAR status: ost$status);

{     The purpose of this procedure is to perform the close processing
{     required on a connection file. It is called by the RHFAM network
{     FAP during close processing.
{
{     FILE_IDENTIFIER: (input) This parameter specifies the file identifier
{       of the connection file that is being closed.
{
{     LAYER: (input) This parameter specifies the fap layer number that
{       this routine is being called from.
{
{     CALL_BLOCK: (input) This parameter specifies the file manager call
{       block that the RHFAM network fap was called with.
{
{     STATUS: (output) This parameter returns the status of the request.
{


?? NEWTITLE := '      terminate_close_file - condition handler', EJECT ??
    PROCEDURE terminate_close_file (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$close_file;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$close_file;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_close_file;
?? OLDTITLE, EJECT ??


      VAR
        activities: rft$set_of_async_activities,
        connection_entry_p: ^rft$connection_entry,
        connection_name: fst$path_handle_name;


    osp$establish_condition_handler (^terminate_close_file, FALSE);
    get_exclusive_to_cid (file_identifier, connection_entry_p, status);
    IF status.normal THEN
      IF connection_entry_p^.open_count > 0 THEN
        connection_entry_p^.open_count := connection_entry_p^.open_count - 1;
      IFEND;
      connection_name := connection_entry_p^.connection_name;
      rfp$unlock_table (connection_entry_p^.lock);
      activities := $rft$set_of_async_activities[rfc$aa_all_async_activities];
      terminate_async_activity (activities, connection_name);

{     Wait for send or receive complete.

      get_exclusive_to_connection (connection_name, connection_entry_p, status);
      IF status.normal THEN
        rfp$unlock_table (connection_entry_p^.lock);
      IFEND;
    IFEND;

  PROCEND rfp$close_file;
?? TITLE := '    complete_received_blocks', EJECT ??
  PROCEDURE  complete_received_blocks (request_response: ^rft$request_response_buffer;
    VAR data_transfer_status: ^rft$data_transfer_status;
    VAR remaining_blocks: rft$outstanding_blocks;
    VAR status: ost$status);

{
{     The purpose of this procedure is to complete the processing associated with
{     any blocks that have been successfully received from the network.  This
{     routine determines the number of blocks that have been processed and updates
{     the data transfer status to reflect the received blocks. In the event of
{     an error, the data transfer status is updated to reflect the last correctly
{     received block.
{
{     REQUEST_RESPONSE: (input) This parameter specifies the pointer to the
{       ring 1 request response buffer.
{
{     DATA_TRANSFER_STATUS: (input,output) This parameter specifies the pointer
{       to the data transfer status block.
{
{     REMAINING_BLOCKS: (output) This parameter returns the number of network blocks
{       that are still queued in the pp request.
{
{     STATUS: (output) This parameter returns the result of this procedure call.
{       A status of normal indicates no errors have occurred.

?? NEWTITLE := 'terminate_complete_received - condition handler', EJECT ??
    PROCEDURE terminate_complete_received (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

{ This condition handler is designed to prevent forseeable error situations
{ from causing unwanted RHFAM/VE side_effects.  Specifically, segment access
{ conditions and system conditions are not allowed to bubble up but are
{ converted to status instead.

      IF (condition.selector = mmc$segment_access_condition) OR
            (condition.selector = pmc$system_conditions) THEN
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT complete_received_blocks;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      IFEND;
    PROCEND terminate_complete_received;
?? OLDTITLE, EJECT ??

    VAR
      blocks_processed: rft$outstanding_blocks,
      cb_present_out: rft$command_entry,
      command_buffer: ^ARRAY [rft$command_entry] OF rft$command,
      current_fragment: rft$data_fragment_count,
      current_offset: rft$data_length,
      data_bytes_delivered: rft$transfer_length,
      data_p: ^cell,
      data_shortage: rft$data_length,
      header: rft$nbp_block_header,
      header_buffer: ^rft$nbp_block_header,
      move_data_length: rft$bytes_transferred,
      bd_present_out: 1 .. rfc$max_outstanding_blocks,
      receive_buffer_exhausted: boolean,
      remaining_block_size: rft$block_size,
      remaining_fragment_length: rft$data_fragment_count,
      reserved_buffer_count: rft$buffer_count,
      reserved_buffer_list: ^rft$buffer_list,
      wired_buffer_index: rft$buffer_count;


    osp$establish_condition_handler (^terminate_complete_received, FALSE);
    blocks_processed := 0;
    data_shortage := 0;
    receive_buffer_exhausted := FALSE;
    current_offset := data_transfer_status^.complete_offset;
    current_fragment := data_transfer_status^.complete_index;
    cb_present_out := data_transfer_status^.present_r1_out_ptr;
    bd_present_out := data_transfer_status^.block_descriptor_out;
    command_buffer := #LOC(request_response^.command_buffer);

{     Note - The previous out pointer in the response buffer is a pointer
{            to the next subfunction that is to be processed by monitor.
{            The present ring 1 out pointer in the data transfer status
{            structure is the next subfunction to be processed by this
{            code.

    /complete_blocks/
    WHILE cb_present_out <> request_response^.previous_out_ptr DO
      #SPOIL (request_response^.previous_out_ptr);

{     Advance to next subfunction.

      data_bytes_delivered := command_buffer^[cb_present_out].sf_transfer_length;
      cb_present_out := cb_present_out + command_buffer^[cb_present_out].sf_length DIV 8;
      IF cb_present_out >= rfc$cbi_limit_pointer THEN
        cb_present_out := cb_present_out - rfc$cbi_limit_pointer + rfc$cbi_first_io_entry;
      IFEND;
      blocks_processed := blocks_processed + 1;

{     Locate network block header.

      IF data_transfer_status^.network_wired_data THEN
        reserved_buffer_list := data_transfer_status^.reserved_buffer_list;
        reserved_buffer_count := data_transfer_status^.reserved_buffer_count;
        wired_buffer_index := data_transfer_status^.block_descriptors^[bd_present_out].
              wired_buffer_index;
        data_p := #LOC(header);
        header_buffer := data_p;
        move_data_length := #SIZE(rft$nbp_block_header);
        rfp$move_data_from_wired_buffs(reserved_buffer_list^, data_p, reserved_buffer_count,
              wired_buffer_index, move_data_length);
      ELSE
        header_buffer := ^data_transfer_status^.header_buffers^[bd_present_out].header;
      IFEND;

{     Verify network block integrity.
{
{       Verify that the data delivered by the PPU equals or exceeds the amount of
{       data indicated in the network block header.

      remaining_block_size := (header_buffer^.length + 7) DIV 8;
      IF remaining_block_size > data_bytes_delivered THEN
        osp$set_status_abnormal (rfc$product_id, rfe$network_block_exceeded,
              '', status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              data_bytes_delivered, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, remaining_block_size,
              10, FALSE, status);
        EXIT /complete_blocks/;
      IFEND;

{       Verify that the data indicated in the network block header does not exceed
{       the defined block size.  This test is required because of data padding that
{       may occur and may not be caught by the previous test.

      IF  remaining_block_size > data_transfer_status^.block_size THEN
        osp$set_status_abnormal (rfc$product_id, rfe$network_block_exceeded,
              '', status);
        osp$append_status_integer (osc$status_parameter_delimiter, data_transfer_status^.
              block_descriptors^[bd_present_out].byte_count, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, remaining_block_size,
              10, FALSE, status);
        EXIT /complete_blocks/;
      IFEND;

      CASE data_transfer_status^.transmission_mode OF
      = rfc$record_mode =
        IF data_transfer_status^.block_descriptors^[bd_present_out].block_sequence_number <>
              header_buffer^.application_block_number THEN
          osp$set_status_abnormal(rfc$product_id, rfe$block_sequence_error,
                data_transfer_status^.connection_name, status);
          osp$append_status_integer(osc$status_parameter_delimiter,
                data_transfer_status^.block_descriptors^[bd_present_out].block_sequence_number,
                10, FALSE, status);
          osp$append_status_integer(osc$status_parameter_delimiter,
                header_buffer^.application_block_number,
                10, FALSE, status);
          EXIT /complete_blocks/;
        IFEND;
        IF remaining_block_size < data_transfer_status^.block_size THEN
          IF (NOT header_buffer^.data_block_clarifier.end_of_information) AND
             (NOT header_buffer^.data_block_clarifier.end_of_record) THEN
            osp$set_status_abnormal (rfc$product_id, rfe$partial_network_block,
                  '', status);
            EXIT /complete_blocks/;
          IFEND;
        IFEND;
      = rfc$message_mode =
        build_back_message (data_transfer_status, header_buffer);
      CASEND;

{     Deliver data block.

      data_shortage := data_shortage + (data_transfer_status^.block_size - remaining_block_size);
      IF data_transfer_status^.network_wired_data THEN
        reserved_buffer_count := data_transfer_status^.reserved_buffer_count;
      /advance_by_block_in_fragments/
        WHILE remaining_block_size > 0 DO
          remaining_fragment_length := data_transfer_status^.data_area^[current_fragment].length -
                current_offset;
          data_p := i#ptr(current_offset, data_transfer_status^.data_area^[current_fragment].address);
          IF remaining_fragment_length > remaining_block_size THEN
            move_data_length := remaining_block_size;
            data_transfer_status^.bytes_transferred := data_transfer_status^.bytes_transferred +
                  move_data_length;
            rfp$move_data_from_wired_buffs(reserved_buffer_list^, data_p, reserved_buffer_count,
                  wired_buffer_index, move_data_length);
            current_offset := current_offset + remaining_block_size;
            remaining_block_size := 0;
          ELSE   {remainder of block does not fit in fragment OR}
                 {remainder of block just fits in fragment}
            move_data_length := remaining_fragment_length;
            data_transfer_status^.bytes_transferred := data_transfer_status^.bytes_transferred +
                  move_data_length;
            rfp$move_data_from_wired_buffs(reserved_buffer_list^, data_p, reserved_buffer_count,
                  wired_buffer_index, move_data_length);
            remaining_block_size := remaining_block_size - remaining_fragment_length;
            IF current_fragment = UPPERBOUND(data_transfer_status^.data_area^) THEN
              receive_buffer_exhausted := TRUE;
              IF (remaining_block_size <> 0) THEN
                save_residue_data (data_transfer_status, remaining_block_size,
                      wired_buffer_index, status);
                remaining_block_size := 0;
                IF NOT status.normal THEN
                  EXIT /complete_blocks/;
                IFEND;
              IFEND;
            ELSE
              current_offset := 0;
              current_fragment := current_fragment + 1;
            IFEND;
          IFEND;
        WHILEND /advance_by_block_in_fragments/;
      ELSE
        data_transfer_status^.bytes_transferred := data_transfer_status^.bytes_transferred +
              remaining_block_size;
        current_offset := current_offset + remaining_block_size;
      IFEND;
      bd_present_out := (bd_present_out MOD
            UPPERBOUND(data_transfer_status^.block_descriptors^)) + 1;
    WHILEND /complete_blocks/;

    data_transfer_status^.complete_offset := current_offset;
    data_transfer_status^.complete_index := current_fragment;
    data_transfer_status^.present_r1_out_ptr := cb_present_out;
    data_transfer_status^.block_descriptor_out := bd_present_out;
    data_transfer_status^.total_blocks_queued := data_transfer_status^.total_blocks_queued -
          blocks_processed;

    IF (data_shortage <> 0) AND
       (NOT receive_buffer_exhausted) THEN
       reset_next_to_queue (data_shortage, data_transfer_status);
    IFEND;

    remaining_blocks := data_transfer_status^.total_blocks_queued;

    osp$disestablish_cond_handler;

  PROCEND complete_received_blocks;
?? TITLE := '    complete_sent_blocks', EJECT ??
  PROCEDURE  complete_sent_blocks (request_response: ^rft$request_response_buffer;
        data_transfer_status: ^rft$data_transfer_status;
    VAR remaining_blocks: rft$outstanding_blocks);

{
{     The purpose of this procedure is to complete the processing associated with
{     any blocks that have been successfully transmitted to the network.  This
{     routine determines the number of blocks that have been processed and updates
{     the data transfer status to reflect the sent blocks.
{
{     REQUEST_RESPONSE: (input) This parameter specifies the pointer to the
{       ring 1 request response buffer.
{
{     DATA_TRANSFER_STATUS: (input,output) This parameter specifies the pointer
{       to the data transfer status block.
{
{     REMAINING_BLOCKS: (output) This parameter returns the number of network blocks
{       that are still queued in the pp request.


    VAR
      block_size: rft$block_size,
      blocks_processed: rft$outstanding_blocks,
      cb_present_out: rft$command_entry,
      command_buffer: ^ARRAY [rft$command_entry] OF rft$command,
      bd_present_out: integer,
      remaining_fragment_length: rft$data_fragment_count,
      wired_buffer_index: rft$buffer_count;


    blocks_processed := 0;
    cb_present_out := data_transfer_status^.present_r1_out_ptr;
    bd_present_out := data_transfer_status^.block_descriptor_out;
    command_buffer := #LOC(request_response^.command_buffer);

{     Note - The previous out pointer in the response buffer is a pointer
{            to the next subfunction that is to be processed by monitor.
{            The present ring 1 out pointer in the data transfer status
{            structure is the next subfunction to be processed by this
{            code.

  /complete_blocks/
    WHILE cb_present_out <> request_response^.previous_out_ptr DO
      #SPOIL (request_response^.previous_out_ptr);

{     Advance to next subfunction.

      cb_present_out := cb_present_out + command_buffer^[cb_present_out].sf_length DIV 8;
      IF cb_present_out >= rfc$cbi_limit_pointer THEN
        cb_present_out := cb_present_out - rfc$cbi_limit_pointer + rfc$cbi_first_io_entry;
      IFEND;
      blocks_processed := blocks_processed + 1;

{     Complete block processing.

      IF data_transfer_status^.network_wired_data THEN
        block_size := data_transfer_status^.block_descriptors^[bd_present_out].byte_count +
              #SIZE(rft$nbp_block_header);
        wired_buffer_index := data_transfer_status^.block_descriptors^[bd_present_out].wired_buffer_index;
      /reset_network_wired_buffers/
        WHILE block_size > 0 DO
          block_size := block_size -
                data_transfer_status^.reserved_buffer_list^[wired_buffer_index].byte_count;
          data_transfer_status^.reserved_buffer_list^[wired_buffer_index].byte_count := 0;
          data_transfer_status^.reserved_buffer_list^[wired_buffer_index].current_offset := 0;
          wired_buffer_index :=
                (wired_buffer_index MOD data_transfer_status^.reserved_buffer_count) + 1;
        WHILEND /reset_network_wired_buffers/;
      IFEND;
      data_transfer_status^.bytes_transferred := data_transfer_status^.bytes_transferred +
        data_transfer_status^.block_descriptors^[bd_present_out].byte_count;

      block_size := data_transfer_status^.block_descriptors^[bd_present_out].byte_count;
      /advance_in_data_fragments/
      WHILE block_size > 0 DO
        remaining_fragment_length := data_transfer_status^.data_area^[data_transfer_status^.
              complete_index].length - data_transfer_status^.complete_offset;
        IF remaining_fragment_length > block_size THEN  {block fits in fragment}
          data_transfer_status^.complete_offset :=
            data_transfer_status^.complete_offset + block_size;
          block_size := 0;
        ELSE  {block does not fit in fragment or just fits}
          block_size := block_size - remaining_fragment_length;
          data_transfer_status^.complete_offset := 0;

{     The routine queueing the data blocks will not queue a block that is larger
{     than the upper fragment. Therefore if at the upperbound of the data fragments,
{     the block size will equal the fragment size.

          IF data_transfer_status^.complete_index <> UPPERBOUND(data_transfer_status^.data_area^) THEN
            data_transfer_status^.complete_index :=
              data_transfer_status^.complete_index + 1;
          IFEND;
        IFEND;
      WHILEND /advance_in_data_fragments/;
      bd_present_out :=
            (bd_present_out MOD UPPERBOUND(data_transfer_status^.block_descriptors^)) + 1;
    WHILEND /complete_blocks/;

    IF data_transfer_status^.transmission_mode = rfc$message_mode THEN
      data_transfer_status^.outgoing_message_count :=
            data_transfer_status^.outgoing_message_count + blocks_processed;
    IFEND;

    data_transfer_status^.present_r1_out_ptr := cb_present_out;
    data_transfer_status^.block_descriptor_out := bd_present_out;
    data_transfer_status^.total_blocks_queued := data_transfer_status^.total_blocks_queued -
          blocks_processed;
    remaining_blocks := data_transfer_status^.total_blocks_queued;

  PROCEND complete_sent_blocks;
?? TITLE := '    rfp$continue_data_transfer', EJECT ??
  PROCEDURE [XDCL] rfp$continue_data_transfer (
        command_buffer: ^ARRAY [ rft$command_entry ] OF rft$command;
        completion_state: rft$transfer_state;
    VAR current_request: ^rft$outstanding_requests;
    VAR release_request: boolean);

{     The purpose of this procedure is to continue the data transfer process
{     when a pp unit request response has been received.  This routine
{     determines the number of network blocks that were sent/received, updates the
{     transfer statistics, and adds new blocks to the pp unit request to
{     reach the maximum network blocks queued. If the data transfer is complete
{     any buffers are released and the activity status is set for the user.
{
{     NOTE: This routine is executing as the result of a pp response system flag.
{     Therefore this request should not call any wait routines.  If a wait
{     routine is called, another copy of this procedure could run causing
{     unpredicable results.
{
{     COMMAND_BUFFER: (input) This parameter specifies a pointer to the
{       completed unit request command buffer.
{
{     COMPLETION_STATE: (input) This parmeter specifies a pointer to the
{       status of the completed transfer request.
{
{     CURRENT_REQUEST: (input) This parameter specifies the pointer to the
{       current request that that has been completed.
{
{     RELEASE_REQUEST: (output) This parameter specifies if the caller should
{       release the unit request buffer associated with this request.  If
{       true, the transfer is complete or is being suspended.
{

    VAR
      blocks_to_add: rft$outstanding_blocks,
      current_time: integer,
      data_transfer_status: ^rft$data_transfer_status,
      event: rft$rhfam_event_table_entry,
      event_occurred_type: rft$event_occurred_type,
      ignore_status: ost$status,
      remaining_blocks: rft$outstanding_blocks,
      request_response: ^rft$request_response_buffer,
      status: ost$status,
      unit_request_idle: boolean;


    release_request := FALSE;
    unit_request_idle := TRUE;
    status.normal := TRUE;
    data_transfer_status := current_request^.request_status;
    request_response := current_request^.request_id.ring_1_id.address;
    remaining_blocks := data_transfer_status^.maximum_outstanding_blocks;

    IF NOT (completion_state.transfer_state = rfc$ts_resource_limit_change) AND
       data_transfer_status^.previous_error.normal THEN
      CASE data_transfer_status^.transfer_kind OF
      = rfc$tk_send_data =
        complete_sent_blocks (request_response, data_transfer_status,
              remaining_blocks);
      = rfc$tk_receive_data =
        complete_received_blocks (request_response, data_transfer_status,
              remaining_blocks,
              data_transfer_status^.previous_error);
      CASEND;
    IFEND;

    CASE completion_state.transfer_state OF
    = rfc$ts_intermediate =
      blocks_to_add := data_transfer_status^.maximum_outstanding_blocks - remaining_blocks;
      IF (NOT data_transfer_status^.data_exhausted) AND
         (data_transfer_status^.previous_error.normal) AND
         (blocks_to_add <> 0) THEN
        unit_request_idle := FALSE;
        continue_data_transfer(data_transfer_status, blocks_to_add,
              current_request, unit_request_idle, data_transfer_status^.previous_error);
      IFEND;
    = rfc$ts_normal =
      IF remaining_blocks <> 0 THEN
        reset_data_buffer(data_transfer_status);
      IFEND;
      blocks_to_add := data_transfer_status^.maximum_outstanding_blocks;
      IF (NOT data_transfer_status^.data_exhausted) AND
         (data_transfer_status^.previous_error.normal) THEN
        continue_data_transfer(data_transfer_status, blocks_to_add,
              current_request, unit_request_idle, data_transfer_status^.previous_error);
        IF (unit_request_idle) AND
           (NOT data_transfer_status^.previous_error.normal) THEN
          terminate_transfer_request (data_transfer_status^.previous_error, data_transfer_status);
          release_request := TRUE;
        IFEND;
      ELSE
        terminate_transfer_request (data_transfer_status^.previous_error,
              data_transfer_status);
        release_request := TRUE;
      IFEND;
    = rfc$ts_retryable_error =
      IF remaining_blocks <> 0 THEN
        reset_data_buffer(data_transfer_status);
      IFEND;
      blocks_to_add := data_transfer_status^.maximum_outstanding_blocks;
      IF data_transfer_status^.previous_error.normal THEN
        continue_data_transfer(data_transfer_status, blocks_to_add,
              current_request, unit_request_idle, data_transfer_status^.previous_error);
        IF (unit_request_idle) AND
           (NOT data_transfer_status^.previous_error.normal) THEN
          terminate_transfer_request (data_transfer_status^.previous_error, data_transfer_status);
          release_request := TRUE;
        IFEND;
      ELSE
        terminate_transfer_request (data_transfer_status^.previous_error,
              data_transfer_status);
        release_request := TRUE;
      IFEND;
    = rfc$ts_resource_limit =
      IF remaining_blocks <> 0 THEN
        reset_data_buffer(data_transfer_status);
      IFEND;

      IF data_transfer_status^.previous_error.normal THEN
        rfp$lock_table(data_transfer_status^.connection_entry_p^.lock);
        IF data_transfer_status^.connection_entry_p^.connection_attributes.connection_status.
              connection_state = rfc$connected THEN
          event.event_kind := rfc$ana_await_connection_event;
          event.ace_connection_descriptor := data_transfer_status^.connection_entry_p^.
                connection_descriptor;
          CASE data_transfer_status^.transfer_kind OF
          = rfc$tk_receive_data =
            event.ace_input_available := TRUE;
            event.ace_output_buffer_available := FALSE;
          = rfc$tk_send_data =
            event.ace_input_available := FALSE;
            event.ace_output_buffer_available := TRUE;
          CASEND;
          event.ace_asynchronous_wait := (data_transfer_status^.wait = osc$nowait);
          event.ace_data_transfer_in_progress := TRUE;
          pmp$get_microsecond_clock (current_time, ignore_status);
          event.ace_asynchronous_timeout := current_time + (data_transfer_status^.
                connection_entry_p^.connection_attributes.data_transfer_timeout*1000);
          enter_event_queue (^event, current_request^.waiting_event, status);
          rfp$unlock_table(data_transfer_status^.connection_entry_p^.lock);
          IF status.normal THEN
            suspend_data_transfer (current_request, status);
            IF NOT status.normal THEN
              remove_data_transfer_event (current_request^.waiting_event);
              terminate_transfer_request (status, data_transfer_status);
              release_request := TRUE;
            IFEND;
          ELSE
            terminate_transfer_request (status, data_transfer_status);
            release_request := TRUE;
          IFEND;
        ELSE
          set_connection_status (data_transfer_status^.connection_entry_p,
                status);
          rfp$unlock_table (data_transfer_status^.connection_entry_p^.lock);
          terminate_transfer_request (status, data_transfer_status);
          release_request := TRUE;
        IFEND;
      ELSE
        terminate_transfer_request (data_transfer_status^.previous_error,
              data_transfer_status);
        release_request := TRUE;
      IFEND;

    = rfc$ts_resource_limit_change =
        event_occurred_type := current_request^.waiting_event^.event_occurred_type;
        remove_data_transfer_event (current_request^.waiting_event);
        CASE event_occurred_type OF
        = rfc$eot_input_available, rfc$eot_output_below_threshold =
          blocks_to_add := data_transfer_status^.maximum_outstanding_blocks;
          restart_data_transfer(current_request, data_transfer_status^.termination_mark,
                blocks_to_add, status);
          IF NOT status.normal THEN
            terminate_transfer_request (status, data_transfer_status);
            release_request := TRUE;
          IFEND;
        = rfc$eot_timeout =
          CASE data_transfer_status^.transfer_kind OF
          = rfc$tk_send_data =
            osp$set_status_abnormal (rfc$product_id, rfe$transfer_timeout,
                  'Send data', status);
          = rfc$tk_receive_data =
            osp$set_status_abnormal (rfc$product_id, rfe$transfer_timeout,
                  'Receive_data', status);
          CASEND;
          terminate_transfer_request (status, data_transfer_status);
          release_request := TRUE;
        = rfc$eot_connection_terminated =
          osp$set_status_abnormal (rfc$product_id, rfe$connection_terminated,
                data_transfer_status^.connection_name, status);
          data_transfer_status^.reason_for_termination := rfc$peer_termination;
          terminate_transfer_request (status, data_transfer_status);
          release_request := TRUE;
        = rfc$eot_async_terminated =
          terminate_transfer_request (data_transfer_status^.previous_error, data_transfer_status);
          release_request := TRUE;
        ELSE
          rfp$lock_table(data_transfer_status^.connection_entry_p^.lock);
          set_connection_status (data_transfer_status^.connection_entry_p, status);
          rfp$unlock_table(data_transfer_status^.connection_entry_p^.lock);
          terminate_transfer_request (status, data_transfer_status);
          release_request := TRUE;
        CASEND;

    = rfc$ts_fatal_error =
      IF remaining_blocks <> 0 THEN
        reset_data_buffer(data_transfer_status);
      IFEND;
      osp$set_status_abnormal (rfc$product_id, rfe$connection_terminated,
            data_transfer_status^.connection_name, status);
      data_transfer_status^.reason_for_termination := rfc$media_failure;
      terminate_transfer_request (status, data_transfer_status);
      release_request := TRUE;
    = rfc$ts_broken =
      IF remaining_blocks <> 0 THEN
        reset_data_buffer(data_transfer_status);
      IFEND;
      osp$set_status_abnormal (rfc$product_id, rfe$connection_terminated,
            data_transfer_status^.connection_name, status);
      data_transfer_status^.reason_for_termination := rfc$peer_termination;
      terminate_transfer_request (status, data_transfer_status);
      release_request := TRUE;
    = rfc$ts_alert =
      IF remaining_blocks <> 0 THEN
        reset_data_buffer(data_transfer_status);
      IFEND;
      CASE data_transfer_status^.transfer_kind OF
      = rfc$tk_send_data =
        osp$set_status_abnormal (rfc$product_id, rfe$invalid_alert_received,
              data_transfer_status^.connection_name, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $INTEGER(completion_state.alert_kind), 10, FALSE, status);
        terminate_transfer_request (status, data_transfer_status);
        release_request := TRUE;
      = rfc$tk_receive_data =
        CASE data_transfer_status^.transmission_mode OF
        = rfc$record_mode =
          CASE completion_state.alert_kind OF
          = rfc$ak_eoi_block =
            IF (data_transfer_status^.connection_entry_p^.residue_input_data = NIL) THEN
              data_transfer_status^.complete_message_received := TRUE;
              data_transfer_status^.file_mark_received := rfc$rm_eoi;
            ELSE
              rfp$lock_table (data_transfer_status^.connection_entry_p^.lock);
              data_transfer_status^.connection_entry_p^.residue_input_data^.
                    record_mark_encountered := TRUE;
              data_transfer_status^.connection_entry_p^.residue_input_data^.
                    record_mark := rfc$rm_eoi;
              rfp$unlock_table (data_transfer_status^.connection_entry_p^.lock);
            IFEND;
            terminate_transfer_request (data_transfer_status^.previous_error,
                  data_transfer_status);
            release_request := TRUE;
          = rfc$ak_eof_block =
            IF (rfc$rm_eof >= data_transfer_status^.file_mark) OR
               (data_transfer_status^.data_exhausted) OR
               (NOT data_transfer_status^.previous_error.normal) THEN
              IF (data_transfer_status^.connection_entry_p^.residue_input_data = NIL) THEN
                data_transfer_status^.complete_message_received := TRUE;
                data_transfer_status^.file_mark_received := rfc$rm_eof;
              ELSE
              rfp$lock_table (data_transfer_status^.connection_entry_p^.lock);
              data_transfer_status^.connection_entry_p^.residue_input_data^.
                    record_mark_encountered := TRUE;
              data_transfer_status^.connection_entry_p^.residue_input_data^.
                    record_mark := rfc$rm_eof;
              rfp$unlock_table (data_transfer_status^.connection_entry_p^.lock);
              IFEND;
              terminate_transfer_request (data_transfer_status^.previous_error,
                    data_transfer_status);
              release_request := TRUE;
            ELSE
              suspend_data_transfer (current_request, status);
              data_transfer_status^.termination_mark := data_transfer_status^.file_mark;
              IF NOT data_transfer_status^.network_wired_data THEN
                data_transfer_status^.switch_to_wired_buffers := TRUE;
              IFEND;
              blocks_to_add := data_transfer_status^.maximum_outstanding_blocks;
              restart_data_transfer (current_request, data_transfer_status^.termination_mark,
                    blocks_to_add, status);
              IF NOT status.normal THEN
                terminate_transfer_request (status, data_transfer_status);
                release_request := TRUE;
              IFEND;
            IFEND;
          = rfc$ak_eor_block =
            IF (rfc$rm_eor >= data_transfer_status^.file_mark) OR
               (data_transfer_status^.data_exhausted) OR
               (NOT data_transfer_status^.previous_error.normal) THEN
              IF (data_transfer_status^.connection_entry_p^.residue_input_data = NIL) THEN
                data_transfer_status^.complete_message_received := TRUE;
                data_transfer_status^.file_mark_received := rfc$rm_eor;
              ELSE
                rfp$lock_table (data_transfer_status^.connection_entry_p^.lock);
                data_transfer_status^.connection_entry_p^.residue_input_data^.
                      record_mark_encountered := TRUE;
                data_transfer_status^.connection_entry_p^.residue_input_data^.
                      record_mark := rfc$rm_eor;
                rfp$unlock_table (data_transfer_status^.connection_entry_p^.lock);
              IFEND;
              terminate_transfer_request (data_transfer_status^.previous_error,
                    data_transfer_status);
              release_request := TRUE;
            ELSE
              suspend_data_transfer (current_request, status);
              data_transfer_status^.termination_mark := data_transfer_status^.file_mark;
              IF NOT data_transfer_status^.network_wired_data THEN
                data_transfer_status^.switch_to_wired_buffers := TRUE;
              IFEND;
              blocks_to_add := data_transfer_status^.maximum_outstanding_blocks;
              restart_data_transfer (current_request, data_transfer_status^.termination_mark,
                    blocks_to_add, status);
              IF NOT status.normal THEN
                terminate_transfer_request (status, data_transfer_status);
                release_request := TRUE;
              IFEND;
            IFEND;
          = rfc$ak_message_block =
            IF data_transfer_status^.previous_error.normal THEN
              osp$set_status_abnormal (rfc$product_id, rfe$receive_mode_conflict,
                    'message mode', status);
              osp$append_status_parameter(osc$status_parameter_delimiter, 'record mode',
                    status);
              osp$append_status_parameter(osc$status_parameter_delimiter,
                    data_transfer_status^.connection_name, status);
              terminate_transfer_request (status, data_transfer_status);
            ELSE
              terminate_transfer_request (data_transfer_status^.previous_error,
                    data_transfer_status);
            IFEND;
            release_request := TRUE;
          ELSE
            osp$set_status_abnormal (rfc$product_id, rfe$invalid_alert_received,
                  data_transfer_status^.connection_name, status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  $INTEGER(completion_state.alert_kind), 10, FALSE, status);
            terminate_transfer_request (status, data_transfer_status);
          CASEND;
        = rfc$message_mode =
          CASE completion_state.alert_kind OF
          = rfc$ak_record_block =
            IF data_transfer_status^.previous_error.normal THEN
              osp$set_status_abnormal (rfc$product_id, rfe$receive_mode_conflict,
                    'record mode', status);
              osp$append_status_parameter(osc$status_parameter_delimiter, 'message mode',
                    status);
              osp$append_status_parameter(osc$status_parameter_delimiter,
                    data_transfer_status^.connection_name, status);
              terminate_transfer_request (status, data_transfer_status);
            ELSE
              terminate_transfer_request (data_transfer_status^.previous_error,
                    data_transfer_status);
            IFEND;
            release_request := TRUE;
          = rfc$ak_end_of_message =
            IF (data_transfer_status^.connection_entry_p^.residue_input_data = NIL) THEN
              data_transfer_status^.complete_message_received := TRUE;
            ELSE
              rfp$lock_table (data_transfer_status^.connection_entry_p^.lock);
              data_transfer_status^.connection_entry_p^.residue_input_data^.
                    record_mark_encountered := TRUE;
              rfp$unlock_table (data_transfer_status^.connection_entry_p^.lock);
            IFEND;
            terminate_transfer_request (data_transfer_status^.previous_error,
                  data_transfer_status);
            release_request := TRUE;
          ELSE
            osp$set_status_abnormal (rfc$product_id, rfe$invalid_alert_received,
                  '', status);
            osp$append_status_integer (osc$status_parameter_delimiter,
                  $INTEGER(completion_state.alert_kind), 10, FALSE, status);
            terminate_transfer_request (status, data_transfer_status);
          CASEND;

        CASEND;
      CASEND;
    CASEND;

  PROCEND rfp$continue_data_transfer;
?? TITLE := '    continue_data_transfer', EJECT ??
  PROCEDURE continue_data_transfer (
    VAR data_transfer_status: ^rft$data_transfer_status;
        blocks_to_add: rft$outstanding_blocks;
        current_request: ^rft$outstanding_requests;
    VAR unit_request_idle: boolean;
    VAR status: ost$status);

{
{     The purpose of this procedure is to continue the data transfer
{     that is in progress.
{
{     DATA_TRANSFER_STATUS: (input,output) This parameter specifies the
{       parameters of the data transfer operation.
{
{     BLOCKS_TO_ADD: (input) This parameter specifies the number of
{       network blocks to add to the pp unit request.
{
{     CURRENT_REQUEST: (input) This parameter specifies a pointer to
{       the PP request to be continued.
{
{     UNIT_REQUEST_IDLE: (input,output) This parameter specifies if the pp request
{       is active at this time.  A value of TRUE indicates that the
{       pp request is not active and no blocks are queued in the send or receive
{       data request.
{
{     STATUS: (output)  This parameter returns the status of the request.
{

    VAR
      blocks_to_queue,
      remaining_blocks: rft$outstanding_blocks,
      restart_request: boolean,
      unit_request: ^SEQ (*);



    status.normal := TRUE;
    PUSH unit_request: [[ rft$command_entry,
            { number of blocks }
          REP rfc$max_blocks_to_add OF rft$command_entry,
            { number of fragments associated with each block }
          REP (rfc$max_blocks_to_add * 4) OF rft$io_fragment]];
            { maximum of four fragments per block }
    blocks_to_queue := blocks_to_add;
    restart_request := unit_request_idle;

  /queue_blocks/
    REPEAT
      RESET unit_request;
      add_blocks_to_request (data_transfer_status, restart_request, blocks_to_queue,
            unit_request, status);
      IF (NOT status.normal) OR
         (blocks_to_queue = 0) THEN
        EXIT /queue_blocks/;
      IFEND;

      RESET unit_request;
      rfp$lock_table (data_transfer_status^.connection_entry_p^.lock);
      IF data_transfer_status^.connection_entry_p^.connection_attributes.
            connection_status.connection_state = rfc$connected THEN
        IF data_transfer_status^.outstanding_control_messages <> NIL THEN
          queue_control_messages (data_transfer_status^.connection_entry_p^.connection_descriptor.
                nad_index, data_transfer_status^.outstanding_control_messages);
        IFEND;
        rfp$unlock_table (data_transfer_status^.connection_entry_p^.lock);
        CASE data_transfer_status^.transfer_kind OF
        = rfc$tk_send_data =
          rfp$continue_io_request( unit_request, current_request^.request_id,
                ioc$explicit_write, restart_request, status);
        = rfc$tk_receive_data =
          rfp$continue_io_request( unit_request, current_request^.request_id,
                ioc$explicit_read, restart_request, status);
        CASEND;
        IF status.normal THEN
          restart_request := FALSE;
          data_transfer_status^.total_blocks_queued := data_transfer_status^.total_blocks_queued +
                blocks_to_queue;
          data_transfer_status^.next_to_queue_abn := data_transfer_status^.current_abn;
          data_transfer_status^.next_to_queue_index := data_transfer_status^.current_fragment_index;
          data_transfer_status^.next_to_queue_offset := data_transfer_status^.current_fragment_offset;
          advise_out_in (data_transfer_status, status);
          IF status.normal THEN
            CASE data_transfer_status^.transfer_kind OF
            = rfc$tk_send_data =
              complete_sent_blocks (current_request^.request_id.ring_1_id.address,
                    data_transfer_status, remaining_blocks);
            = rfc$tk_receive_data =
              complete_received_blocks (current_request^.request_id.ring_1_id.address,
                    data_transfer_status, remaining_blocks, status);
            CASEND;
            blocks_to_queue := data_transfer_status^.maximum_outstanding_blocks - remaining_blocks;
          IFEND;
        IFEND;
      ELSE
        set_connection_status (data_transfer_status^.connection_entry_p, status);
        rfp$unlock_table(data_transfer_status^.connection_entry_p^.lock);
        delete_control_messages (data_transfer_status^.outstanding_control_messages);
      IFEND;
    UNTIL  (blocks_to_queue < 4)    { need to add at least 4 or not worth it }
       OR  (current_request^.request_id.ring_1_id.address^.response_posted)
       OR  (data_transfer_status^.data_exhausted)
       OR  (data_transfer_status^.switch_to_wired_buffers)
       OR  (NOT status.normal);  {  /queue_buffers/  }

    unit_request_idle := restart_request;

  PROCEND continue_data_transfer;
?? TITLE := '    delete_control_messages', EJECT ??
  PROCEDURE [INLINE] delete_control_messages (
    VAR control_message_pointer: ^rft$outgoing_control_message);

{
{     The purpose of this procedure is to release any unqueued control
{     messages when it is determined that for hardware reasons or
{     system task shutdown that they can not be sent.
{
{     CONTROL_MESSAGE_POINTER: (input,output) This parameter specifies
{       a pointer to a linked list of control messages that are to
{       be released. On return this parameter is set to NIL.
{


    VAR
      present_entry: ^rft$outgoing_control_message;


    WHILE control_message_pointer <> NIL DO
      present_entry := control_message_pointer;
      control_message_pointer := present_entry^.next_entry;
      FREE present_entry IN nav$network_paged_heap^;
    WHILEND;

  PROCEND delete_control_messages;
?? TITLE := '    rfp$delete_connection', EJECT ??
  PROCEDURE [XDCL] rfp$delete_connection (connection_file: fst$path_handle_name;
    VAR status: ost$status);

{
{     The purpose of this procedure is to terminate the specified connection.
{     Terminating a connection removes the connection from a job and releases
{     the path that has been established in the LCN network.  If the path is still
{     viable in the network this request issues a pp request to purge the
{     connection. This routine may be called at job termination to
{     delete connections that are still active.  During job termination, signals
{     and flags are disabled, so the pp response processor is called from
{     this routine to process the pp response to the purge path request.
{
{     CONNECTION_FILE: (input) This parameter specifies the file name to
{       delete from the $local catalog.
{
{     STATUS: (output) This parameter returns the result of the request.
{


?? NEWTITLE := '      terminate_delete_connect - condition handler', EJECT ??
    PROCEDURE terminate_delete_connect (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

      VAR
        mgmt_status: ^rft$connection_mgmt_status,
        current_request: ^rft$outstanding_requests,
        previous_request: ^rft$outstanding_requests;

      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$delete_connection;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          current_request := rfv$outstanding_requests;
          previous_request := NIL;
        /complete_recovered_requests/
          WHILE current_request <> NIL DO
            IF current_request^.request_kind = rfc$rk_accept_connect_request THEN
              mgmt_status := current_request^.request_status;
              FREE mgmt_status^.activity_status IN osv$task_private_heap^;
              IF previous_request = NIL THEN
                rfv$outstanding_requests := current_request^.next_entry;
              ELSE
                previous_request^.next_entry := current_request^.next_entry;
              IFEND;
              FREE mgmt_status IN osv$task_private_heap^;
              FREE current_request IN osv$task_private_heap^;
              EXIT /complete_recovered_requests/;
            IFEND;
            previous_request := current_request;
            current_request := current_request^.next_entry;
          WHILEND /complete_recovered_requests/;
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$delete_connection;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_delete_connect;
?? OLDTITLE, EJECT ??


    VAR
      abnormal_termination: ^boolean,
      activity_status: ^ost$activity_status,
      back_processing_complete: boolean,
      command_identifier: ^rft$logical_commands,
      connection_entry_p: ^rft$connection_entry,
      connection_status: ^rft$connection_table_entry,
      connection_timeout: boolean,
      connection_timeout_time: integer,
      entry_to_delete: ^rft$outgoing_control_message,
      job_table_entry_p: ^rft$rhfam_job_table_entry,
      local_status: ost$status,
      locked: boolean,
      nad_index: rft$local_nads,
      path_id: ^rft$path_identifier,
      present_entry: ^rft$outgoing_control_message,
      previous_entry: ^rft$outgoing_control_message,
      purge_path: boolean,
      request_info: ^ SEQ( * ),
      start_time: integer,
      time: integer,
      unit_request_status: ^rft$connection_mgmt_status,
      wait_back_processing: boolean,
      xcb: ^ost$execution_control_block;


      osp$establish_condition_handler (^terminate_delete_connect, FALSE);
      status.normal := TRUE;
      back_processing_complete := FALSE;
      pmp$find_executing_task_xcb (xcb);
      pmp$get_microsecond_clock (start_time, local_status);

    /wait_termination_processing/
      REPEAT
        get_exclusive_to_job (connection_file, job_table_entry_p,
              connection_entry_p, status);
        IF NOT status.normal THEN
          EXIT rfp$delete_connection;
        IFEND;

        IF connection_entry_p^.connection_attributes.connection_status.connection_state =
              rfc$switch_offered THEN
          remove_switch_offer (job_table_entry_p^.job_name, connection_entry_p);
        IFEND;

        IF (connection_entry_p^.connection_attributes.connection_status.connection_state >=
              rfc$not_viable) OR
           (connection_entry_p^.connection_attributes.connection_status.connection_state =
              rfc$switch_accepted) THEN
          remove_connection_entry (connection_entry_p);
          job_table_entry_p^.lock := tmv$null_global_task_id;
          EXIT rfp$delete_connection;
        IFEND;

        purge_path := connection_entry_p^.connection_attributes.abnormal_termination;
        nad_index := connection_entry_p^.connection_descriptor.nad_index;
        rfp$test_set_table_lock (rfv$status_table.local_nads^[nad_index].
              outgoing_cm_queue.lock, locked);
        IF NOT locked THEN
          rfp$unlock_table (connection_entry_p^.lock);
          job_table_entry_p^.lock := tmv$null_global_task_id;
          syp$cycle;
          CYCLE /wait_termination_processing/;
        IFEND;

        pmp$get_microsecond_clock (time, local_status);
        connection_timeout := (time > (start_time + (connection_entry_p^.connection_attributes.
              connection_timeout * 1000)));

        connection_status := ^rfv$status_table.local_nads^[nad_index].
               connection_table^[connection_entry_p^.connection_descriptor.
               network_path];

        IF ((connection_status^.connection_state <> rfc$ps_established) OR
                (connection_status^.connection_clarifier <> rfc$pce_normal)) OR
           (xcb^.task_is_terminating) OR
           (pmc$sf_terminate_task IN xcb^.system_flags) OR
           (connection_timeout) THEN
          purge_path := TRUE;
        IFEND;

        present_entry := rfv$status_table.local_nads^[nad_index].
              outgoing_cm_queue.first_entry;
        IF purge_path THEN
          previous_entry := NIL;
          IF (present_entry <> NIL) AND
             (rfv$status_table.local_nads^[nad_index].processing_out_control_mess) THEN
            present_entry^.purge_on_retry := TRUE;
            previous_entry := present_entry;
            present_entry := present_entry^.next_entry;
          IFEND;
        /delete_queued_backs/
          WHILE present_entry <> NIL DO
            IF present_entry^.control_message.header.my_path_id =
                  connection_entry_p^.connection_descriptor.network_path THEN
              entry_to_delete := present_entry;
              present_entry := present_entry^.next_entry;
              IF previous_entry = NIL THEN
                rfv$status_table.local_nads^[nad_index].outgoing_cm_queue.first_entry :=
                  present_entry;
              ELSE
                previous_entry^.next_entry := present_entry;
              IFEND;
              FREE entry_to_delete IN nav$network_paged_heap^;
            ELSE
              previous_entry := present_entry;
              present_entry := present_entry^.next_entry;
            IFEND;
          WHILEND /delete_queued_backs/;
          rfp$unlock_table (rfv$status_table.local_nads^[nad_index].outgoing_cm_queue.lock);
          back_processing_complete := TRUE;
        ELSE
          wait_back_processing := FALSE;
        /locate_outstanding_backs/
          WHILE present_entry <> NIL DO
            IF present_entry^.control_message.header.my_path_id =
                  connection_entry_p^.connection_descriptor.network_path THEN
              wait_back_processing := TRUE;
              EXIT /locate_outstanding_backs/;
            IFEND;
            present_entry := present_entry^.next_entry;
          WHILEND /locate_outstanding_backs/;
          rfp$unlock_table (rfv$status_table.local_nads^[nad_index].outgoing_cm_queue.lock);
          IF NOT wait_back_processing THEN
            IF connection_entry_p^.connection_attributes.outgoing_message_count =
                  connection_entry_p^.connection_attributes.acks_received_count THEN
              back_processing_complete := TRUE;
              EXIT /wait_termination_processing/;
            IFEND;
          IFEND;
          rfp$unlock_table (connection_entry_p^.lock);
          job_table_entry_p^.lock := tmv$null_global_task_id;
          syp$cycle;
        IFEND;
      UNTIL back_processing_complete;  {wait_termination_processing}

    job_table_entry_p^.lock := tmv$null_global_task_id;
    /queue_disconnect_request/
      BEGIN
        PUSH request_info: [[rft$logical_commands,    {command identifier}
                             boolean,                 {abnormal termination}
                             rft$path_identifier]];   {path identifier}
        RESET request_info;
        NEXT command_identifier  IN  request_info;
        IF  command_identifier = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err,
                'the request overflowed the request sequence', status);
          osp$append_status_parameter(osc$status_parameter_delimiter,
                'rfp$delete_connection', status);
          EXIT  /queue_disconnect_request/;
        IFEND;
        command_identifier^ := rfc$lc_disconnect_paths;
        NEXT  abnormal_termination IN  request_info;
        IF  abnormal_termination = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err,
                'the request overflowed the request sequence', status);
          osp$append_status_parameter(osc$status_parameter_delimiter,
                'rfp$delete_connection', status);
          EXIT  /queue_disconnect_request/;
        IFEND;
        abnormal_termination^ := purge_path;
        NEXT  path_id IN  request_info;
        IF  path_id = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err,
                'the request overflowed the request sequence', status);
          osp$append_status_parameter(osc$status_parameter_delimiter,
                'rfp$delete_connection', status);
          EXIT  /queue_disconnect_request/;
        IFEND;
        path_id^ := connection_entry_p^.connection_descriptor.network_path;

        ALLOCATE unit_request_status IN osv$task_private_heap^;
        IF  unit_request_status = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted,
                'task private', status);
          osp$append_status_parameter(osc$status_parameter_delimiter,
                'rfp$delete_connection', status);
          EXIT  /queue_disconnect_request/;
        IFEND;

{     The structure activity status is allocated in task private to insure
{     it is writeable by ring 3 code. Pointers to this variable are stored in
{     a task private segment and thus inherit ring 3 privileges.

        ALLOCATE activity_status IN osv$task_private_heap^;
        IF  activity_status = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted,
                'task private', status);
          osp$append_status_parameter(osc$status_parameter_delimiter,
                'rfp$delete_connection', status);
          EXIT  /queue_disconnect_request/;
        IFEND;
        unit_request_status^.internal_use := FALSE;
        unit_request_status^.connection := connection_entry_p;
        unit_request_status^.activity_status := activity_status;
        activity_status^.complete := FALSE;
        activity_status^.status.normal := TRUE;
        connection_entry_p^.active_pp_requests := connection_entry_p^.active_pp_requests + 1;
        nad_index := connection_entry_p^.connection_descriptor.nad_index;
        rfp$unlock_table (connection_entry_p^.lock);
        rfp$queue_request(nad_index, 1, rfc$unit_request, rfc$rk_disconnect_path,
              unit_request_status, request_info, status);
        IF  NOT status.normal  THEN
          rfp$remove_connection(0, connection_entry_p);
          EXIT  rfp$delete_connection;
        IFEND;
        REPEAT
          #SPOIL (activity_status^);
          syp$cycle;
          rfp$process_pp_response_flag (rfc$pp_response_available);
        UNTIL activity_status^.complete;
        IF NOT activity_status^.status.normal THEN
          status := activity_status^.status;
        IFEND;
        FREE activity_status IN osv$task_private_heap^;
        RETURN;
      END /queue_disconnect_request/;
      rfp$unlock_table (connection_entry_p^.lock);

  PROCEND rfp$delete_connection;
?? TITLE := '    delink_connection_entry', EJECT ??
  PROCEDURE  delink_connection_entry (
        connection_entry_p: ^rft$connection_entry);

{
{     The purpose of this procedure is to delink the specified
{     connection entry data structure from the connection entry list.
{
{     CONNECTION_ENTRY_P: (input) This parameter specifies a pointer
{       to the connection entry to remove.


    VAR
      current_entry_p: ^rft$connection_entry,
      previous_entry_p: ^rft$connection_entry;


    previous_entry_p := NIL;
    current_entry_p := connection_entry_p^.application_entry_p^.connection_table;
    WHILE current_entry_p <> NIL DO
      IF current_entry_p^.connection_name =
            connection_entry_p^.connection_name THEN
        IF previous_entry_p = NIL THEN
          connection_entry_p^.application_entry_p^.connection_table :=
                current_entry_p^.next_entry;
        ELSE
          previous_entry_p^.next_entry := current_entry_p^.next_entry;
        IFEND;
        RETURN;
      IFEND;
      previous_entry_p := current_entry_p;
      current_entry_p := current_entry_p^.next_entry;
    WHILEND ;

  PROCEND delink_connection_entry;
?? TITLE := '    deliver_residue_data', EJECT ??
  PROCEDURE deliver_residue_data (data_transfer_status: ^rft$data_transfer_status;
    VAR residue_input_data: ^rft$residue_data;
    VAR transfer_complete: boolean;
    VAR status: ost$status);

{
{     The purpose of this routine is to deliver to the application any residue
{     data that was received during a previous receive data request, but could
{     not be delivered because of a buffer full condition.
{
{     DATA_TRANSFER_STATUS: (input) This parameter specifies the parameters for
{       the data transfer request.
{
{     RESIDUE_INPUT_DATA: (input,output) This parameter specifies a pointer to
{       the residue data.  Upon exit, if all the data has been delivered, this
{       pointer is set to NIL.
{
{     TRANSFER_COMPLETE: (output) This parameter returns a value of TRUE if all
{       residue data is delivered and the residue data had a receive data
{       termination indicator.
{
{     STATUS: (output) This parameter returns the status of this request.



    VAR
      current_fragment: rft$data_fragment_count,
      current_offset: rft$data_length,
      residue_data: ^SEQ ( * ),
      delivered_data_buffer: ^cell,
      remaining_fragment_length: rft$data_fragment_count,
      saved_data_buffer: ^cell;


    status.normal := TRUE;
    transfer_complete := FALSE;

    current_offset := data_transfer_status^.next_to_queue_offset;
    current_fragment := data_transfer_status^.next_to_queue_index;
    NEXT residue_data: [[REP 0 OF CELL]] IN residue_input_data^.data_pointer;
  /deliver_data_to_application/
    WHILE residue_input_data^.remaining_data > 0 DO
      remaining_fragment_length := data_transfer_status^.data_area^[current_fragment].length -
            current_offset;
      delivered_data_buffer := i#ptr(current_offset,
            data_transfer_status^.data_area^[current_fragment].address);
      saved_data_buffer := residue_data;
      IF remaining_fragment_length > residue_input_data^.remaining_data THEN
        data_transfer_status^.bytes_transferred := data_transfer_status^.bytes_transferred +
              residue_input_data^.remaining_data;
        i#move (saved_data_buffer, delivered_data_buffer, residue_input_data^.remaining_data);
        current_offset := current_offset + residue_input_data^.remaining_data;
        residue_input_data^.remaining_data := 0;
      ELSE   {remainder of block either just fits in fragment or exceeds fragment length}
        data_transfer_status^.bytes_transferred := data_transfer_status^.bytes_transferred +
              remaining_fragment_length;
        i#move (saved_data_buffer, delivered_data_buffer, remaining_fragment_length);
        residue_input_data^.remaining_data := residue_input_data^.remaining_data -
              remaining_fragment_length;
        NEXT residue_data:
              [[REP remaining_fragment_length OF CELL]] IN residue_input_data^.data_pointer;
        IF current_fragment = UPPERBOUND(data_transfer_status^.data_area^) THEN
          transfer_complete := TRUE;
          EXIT /deliver_data_to_application/;
        IFEND;
        current_offset := 0;
        current_fragment := current_fragment + 1;
      IFEND;
    WHILEND /deliver_data_to_application/;

    IF (residue_input_data^.remaining_data = 0) THEN
      IF residue_input_data^.record_mark_encountered THEN
        data_transfer_status^.complete_message_received :=
              residue_input_data^.record_mark_encountered;
        IF data_transfer_status^.transmission_mode = rfc$record_mode THEN
          data_transfer_status^.file_mark_received :=
                residue_input_data^.record_mark;
        IFEND;
        transfer_complete := TRUE;
      IFEND;
      rfp$lock_table(data_transfer_status^.connection_entry_p^.lock);
      FREE data_transfer_status^.connection_entry_p^.residue_input_data IN nav$network_paged_heap^;
      rfp$unlock_table(data_transfer_status^.connection_entry_p^.lock);
    IFEND;

    data_transfer_status^.next_to_queue_offset := current_offset;
    data_transfer_status^.next_to_queue_index := current_fragment;

  PROCEND deliver_residue_data;
?? TITLE := '    determine_path_state', EJECT ??
  PROCEDURE determine_path_state (path_p: ^rft$lcn_path_definition;
    VAR path_enabled: boolean);

{
{     The purpose of this procedure is to determine if the specified path
{     is in a useable state.  It checks that the path is enabled, the NAD
{     is enabled and that the TCU's at both ends are ON.
{
{     PATH_P: (input) This parameter specifies a pointer to the path to
{       check.
{
{     PATH_ENABLED: (output) This parameter returns a value of TRUE if
{       the path is usable.



    VAR
      local_nad_tcu: integer,
      local_tcu_state: rft$element_state,
      local_trunk: rft$component_name,
      remote_nad_tcu: integer,
      remote_tcu_state: rft$element_state,
      remote_trunk: rft$component_name,
      temp_enabled: boolean;


    path_enabled := NOT path_p^.disabled;
    IF path_enabled THEN
      path_enabled := (rfv$status_table.local_nads^[path_p^.local_nad].
            current_status.device_status = rfc$es_on);
      IF path_enabled THEN
        CASE path_p^.loopback OF
        = TRUE =
          path_enabled := (rfv$status_table.local_nads^[path_p^.destination_nad].
                current_status.device_status = rfc$es_on);
          IF rfv$status_table.local_nads^[path_p^.destination_nad].address =
             rfv$status_table.local_nads^[path_p^.local_nad].address THEN
            RETURN
          IFEND;
        = FALSE =
          path_enabled := (rfv$status_table.remote_nads^[path_p^.remote_nad].
                current_status.device_status = rfc$es_on);
        CASEND;
        IF path_enabled THEN
          temp_enabled := FALSE;
          FOR local_nad_tcu := LOWERBOUND(path_p^.local_tcu_mask) TO
                UPPERBOUND(path_p^.local_tcu_mask) DO
            IF path_p^.local_tcu_mask[local_nad_tcu] THEN
              local_trunk := rfv$status_table.local_nads^[path_p^.local_nad].
                    trunk_control_units[local_nad_tcu];
              local_tcu_state := rfv$status_table.local_nads^[path_p^.local_nad].current_status.
                    tcu_status[local_nad_tcu];
              FOR remote_nad_tcu := LOWERBOUND(path_p^.remote_tcu_mask) TO
                    UPPERBOUND(path_p^.remote_tcu_mask) DO
                IF path_p^.remote_tcu_mask[remote_nad_tcu] THEN
                  CASE path_p^.loopback OF
                  = TRUE =
                    remote_trunk := rfv$status_table.local_nads^[path_p^.destination_nad].
                          trunk_control_units[remote_nad_tcu];
                    remote_tcu_state := rfv$status_table.local_nads^[path_p^.destination_nad].
                          current_status.tcu_status[remote_nad_tcu];
                  = FALSE =
                    remote_trunk := rfv$status_table.remote_nads^[path_p^.remote_nad].
                          trunk_control_units[remote_nad_tcu];
                    remote_tcu_state := rfv$status_table.remote_nads^[path_p^.remote_nad].
                          current_status.tcu_status[remote_nad_tcu];
                  CASEND;
                  IF remote_trunk = local_trunk THEN
                    IF (local_tcu_state = rfc$es_on) AND (remote_tcu_state = rfc$es_on) THEN
                      path_enabled := TRUE;
                      RETURN;
                    IFEND;
                  IFEND;
                IFEND;
              FOREND;
            IFEND;
          FOREND;
          path_enabled := temp_enabled;
        IFEND;
      IFEND;
    IFEND;

  PROCEND determine_path_state;
?? TITLE :='    enter_event_queue', EJECT ??
  PROCEDURE enter_event_queue(event: ^rft$rhfam_event_table_entry;
    VAR event_queue_entry_p: ^rft$rhfam_event_table_entry;
    VAR status: ost$status);

{
{     The purpose of this procedure is to enter the event specified into the
{     RHFAM event queue.
{
{     EVENT: (input) This parameter specifies a pointer to the event that
{       is to be entered into the queue. The caller must initialize the
{       varient portion of this structure.
{
{     STATUS: (output) This parameter returns the result of the request. A status
{       of normal indicates that the event has been entered into the event
{       queue.


    VAR
      current_event: ^rft$rhfam_event_table_entry,
      duplicate: boolean,
      global_task_id: ost$global_task_id,
      previous_event: ^rft$rhfam_event_table_entry;


    previous_event := NIL;
    pmp$get_executing_task_gtid (global_task_id);
    rfp$lock_table (rfv$rhfam_event_table.lock);
    current_event := rfv$rhfam_event_table.first_entry;
    duplicate := FALSE;
    WHILE current_event <> NIL DO
      IF (current_event^.task_id = global_task_id) AND
         (current_event^.event_kind = event^.event_kind) THEN
        CASE event^.event_kind OF
        = rfc$ana_await_server_response =
          duplicate := (current_event^.asr_connection_descriptor =
                event^.asr_connection_descriptor);
        = rfc$ana_await_incoming_connect =
          duplicate := ((current_event^.aic_job_name = event^.aic_job_name) AND
                       (current_event^.aic_server_name = event^.aic_server_name));
        = rfc$ana_await_connection_event =
          IF NOT current_event^.ace_data_transfer_in_progress THEN
            duplicate := ((current_event^.ace_connection_descriptor =
                event^.ace_connection_descriptor) AND (current_event^.ace_input_available =
                event^.ace_input_available) AND (current_event^.ace_output_buffer_available =
                event^.ace_output_buffer_available));
          IFEND;
        = rfc$ana_await_switch_offer =
          duplicate := (current_event^.aso_application_name = event^.aso_application_name);
        = rfc$ana_await_switch_accept =
          duplicate := (current_event^.asa_source_job = event^.asa_source_job);
        CASEND;
        IF duplicate THEN
          current_event^.event_occurred_type := rfc$eot_no_event;
          rfp$unlock_table (rfv$rhfam_event_table.lock);
          event_queue_entry_p := current_event;
          RETURN;
        IFEND;
      IFEND;
      previous_event := current_event;
      current_event := current_event^.next_entry;
    WHILEND;
    ALLOCATE event_queue_entry_p IN nav$network_paged_heap^;
    IF event_queue_entry_p = NIL THEN
      rfp$unlock_table (rfv$rhfam_event_table.lock);
      osp$set_status_abnormal (rfc$product_id, rfe$heap_exhausted,
            'network paged', status);
      osp$append_status_parameter(osc$status_parameter_delimiter,
            'enter_event_queue', status);
      EXIT enter_event_queue;
    IFEND;

    event_queue_entry_p^ := event^;
    event_queue_entry_p^.next_entry := NIL;
    event_queue_entry_p^.task_id := global_task_id;
    event_queue_entry_p^.event_occurred_type := rfc$eot_no_event;

    IF previous_event = NIL THEN
      rfv$rhfam_event_table.first_entry := event_queue_entry_p;
    ELSE
      previous_event^.next_entry := event_queue_entry_p;
    IFEND;
    rfp$unlock_table (rfv$rhfam_event_table.lock);

  PROCEND enter_event_queue;
?? TITLE := '    enter_switched_connect_queue', EJECT ??
  PROCEDURE enter_switched_connect_queue (
        destination_job: jmt$system_supplied_name;
    VAR connection_entry_p: ^rft$connection_entry;
    VAR status: ost$status);

{
{     The purpose of this procedure is to enter a connection into
{     the switched connection queue.  This connection may then be
{     accepted by the destination job.
{
{     DESTINATION_JOB: (input) This parameter specifies the name of the
{       job to offer the connection to.
{
{     CONNECTION_ENTRY_P: (input) This parameter specifies a pointer
{       to the connection table entry of the connection that is being
{       offered for switch.
{
{     STATUS: (output) This parameter returns the status of the
{       switch offer. A status of normal indicates that the connection
{       has been sucessfully offered.


    VAR
      new_connection_entry_p: ^rft$connection_entry,
      next_entry: ^rft$switched_connection,
      next_connection_entry_p: ^rft$connection_entry,
      present_entry: ^rft$switched_connection,
      switched_connection: ^rft$switched_connection,
      user_supplied_name: jmt$user_supplied_name;


    rfp$lock_table (rfv$switched_connection_queue.lock);
    present_entry := NIL;
    next_entry := rfv$switched_connection_queue.first_entry;
    WHILE next_entry <> NIL DO
      present_entry := next_entry;
      next_entry := present_entry^.next_entry;
    WHILEND;

    ALLOCATE switched_connection IN nav$network_paged_heap^;
    IF switched_connection <> NIL THEN
      switched_connection^.next_entry := NIL;
      IF present_entry = NIL THEN
        rfv$switched_connection_queue.first_entry := switched_connection;
      ELSE
        present_entry^.next_entry := switched_connection;
      IFEND;
    ELSE
      rfp$unlock_table (rfv$switched_connection_queue.lock);
      osp$set_status_abnormal (rfc$product_id, rfe$heap_exhausted,
            'network paged', status);
      osp$append_status_parameter(osc$status_parameter_delimiter,
            'enter_switched_connect_queue', status);
      EXIT enter_switched_connect_queue;
    IFEND;

{     Initialize switched connection entry.

    switched_connection^.destination_job := destination_job;
    pmp$get_job_names (user_supplied_name, switched_connection^.source_job, status);
    switched_connection^.connection_entry_p := connection_entry_p;
    switched_connection^.destination_application :=
          connection_entry_p^.application_entry_p^.application_name;
    switched_connection^.source_application_kind := connection_entry_p^.
          application_entry_p^.application_kind;
    link_new_connection_entry (connection_entry_p^.application_entry_p,
          new_connection_entry_p, status);
    IF NOT status.normal THEN
      rfp$unlock_table (rfv$switched_connection_queue.lock);
      EXIT enter_switched_connect_queue;
    IFEND;
    switched_connection^.connection_entry_source_job := new_connection_entry_p;

{     A pointer to all connection entries is maintained in the status table.
{     To avoid having to update this pointer the process used to switch the
{     connection is to allocate a new entry to use as a placeholder at the
{     source job.  The active connection entry is then pointed to by the
{     switched connection queue until the receiving job picks it up.

    delink_connection_entry (connection_entry_p);

{     Copy connection entry contents to placeholder.

    next_connection_entry_p := new_connection_entry_p^.next_entry;
    new_connection_entry_p^ := connection_entry_p^;

{     Unlock connection entry. Placeholder connection entry inherited
{     the lock and will be cleared later by the calling routine.
{     Replace next_entry pointer that was destroyed because of copy.
{     The inline procedure osp$clear_job_signature_lock is used to
{     unlock the connection entry to prevent the subsystem activity count
{     from being decremented.

    osp$clear_job_signature_lock (connection_entry_p^.lock);
    new_connection_entry_p^.next_entry := next_connection_entry_p;

{     Change pointer to point to new connection entry.

    connection_entry_p := new_connection_entry_p;

{     Set source job connection entry state to switched.

    connection_entry_p^.
          connection_attributes.connection_status.connection_state :=
          rfc$switch_offered;
    connection_entry_p^.
          connection_attributes.connection_status.destination_job :=
          destination_job;
    rfp$unlock_table (rfv$switched_connection_queue.lock);

  PROCEND enter_switched_connect_queue;
?? TITLE :='    enter_waiting_task_queue', EJECT ??
  PROCEDURE enter_waiting_task_queue(connection_entry_p: ^rft$connection_entry;
    VAR status: ost$status);

{     The purpose of this procedure is to enter the running task into a list of
{     tasks to be restarted when a data transfer request is complete.
{
{     CONNECTION_ENTRY_P: (input) This parameter specifies the connection entry
{       pointer to the connection entry that the task wishes to wait on.
{
{     STATUS: (output) This parameter returns the result of the request. A status
{       of normal indicates that the task has been entered into the wait queue.


    VAR
      current_waiting_task: ^rft$waiting_task_queue,
      global_task_id: ost$global_task_id,
      local_status: ost$status,
      new_task: ^rft$waiting_task_queue,
      previous_waiting_task: ^rft$waiting_task_queue,
      task_id: pmt$task_id;


    previous_waiting_task := NIL;
    current_waiting_task := connection_entry_p^.waiting_tasks;
    pmp$get_executing_task_gtid (global_task_id);
    WHILE current_waiting_task <> NIL DO
      IF connection_entry_p^.waiting_tasks^.global_task_id =
            global_task_id THEN
        EXIT enter_waiting_task_queue;
      IFEND;
      previous_waiting_task := current_waiting_task;
      current_waiting_task := current_waiting_task^.next_entry;
    WHILEND;
    ALLOCATE new_task IN nav$network_paged_heap^;
    IF new_task = NIL THEN
      osp$set_status_abnormal (rfc$product_id, rfe$heap_exhausted,
            'network paged', status);
      osp$append_status_parameter(osc$status_parameter_delimiter,
            'enter_waiting_task_queue', status);
      EXIT enter_waiting_task_queue;
    IFEND;
    new_task^.global_task_id := global_task_id;
    new_task^.next_entry := NIL;
    IF previous_waiting_task = NIL THEN
      connection_entry_p^.waiting_tasks := new_task;
    ELSE
      previous_waiting_task^.next_entry := new_task;
    IFEND;


  PROCEND enter_waiting_task_queue;
?? TITLE := '    rfp$fetch', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$fetch (
        connection_identifier: amt$file_identifier;
    VAR file_attributes: rft$get_attributes;
    VAR status: ost$status);

*copyc rfh$fetch

?? NEWTITLE := '      terminate_fetch - condition handler', EJECT ??
    PROCEDURE terminate_fetch (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        IF connection_entry_p <> NIL THEN
          rfp$unlock_table (connection_entry_p^.lock);
        IFEND;
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$fetch;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$fetch;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_fetch;
?? OLDTITLE, EJECT ??


    VAR
      connection_entry_p: ^rft$connection_entry;


    connection_entry_p := NIL;
    osp$establish_condition_handler (^terminate_fetch, FALSE);
    status.normal := TRUE;

    get_exclusive_to_cid (connection_identifier, connection_entry_p, status);
    IF NOT status.normal THEN
      EXIT rfp$fetch;
    IFEND;
    fetch_get_attributes (^connection_entry_p^.connection_attributes,
          ^file_attributes, status);
    rfp$unlock_table (connection_entry_p^.lock);

  PROCEND rfp$fetch;
?? TITLE := '    fetch_get_attributes', EJECT ??
  PROCEDURE fetch_get_attributes (
        connection_attributes: ^rft$connection_attributes;
        attributes: ^rft$get_attributes;
    VAR status: ost$status);

{
{     The purpose of this procedure is to fetch the specified attributes
{     of the connection.
{
{     CONNECTION_ATTRIBUTES: (input,output) This parameter specifies a
{       pointer to the current connection attributes.
{
{     ATTRIBUTES: (input,output) This parameter specifies a pointer to the
{       attribute keys to return.
{
{     STATUS: (output) This parameter returns the result of the request.



    VAR
      attribute_index : integer;

    status.normal := TRUE;
    IF attributes <> NIL THEN
      FOR attribute_index := LOWERBOUND (attributes^) TO UPPERBOUND (attributes^) DO
        CASE attributes^ [attribute_index].key OF
        = rfc$client_name =
          attributes^[attribute_index].client_name :=
                connection_attributes^.client_name;
        = rfc$server_name =
          attributes^[attribute_index].server_name :=
                 connection_attributes^.server_name;
        = rfc$client_host =
          attributes^[attribute_index].client_host :=
                 connection_attributes^.client_host;
        = rfc$server_host =
          attributes^[attribute_index].server_host :=
                 connection_attributes^.server_host;
        = rfc$destination_host =
          attributes^[attribute_index].destination_host :=
                 connection_attributes^.destination_host;
        = rfc$connection_timeout =
          attributes^[attribute_index].connection_timeout :=
                 connection_attributes^.connection_timeout;
        = rfc$data_transfer_timeout =
          attributes^[attribute_index].data_transfer_timeout :=
                 connection_attributes^.data_transfer_timeout;
        = rfc$record_block_size =
          attributes^[attribute_index].record_block_size :=
                 connection_attributes^.record_block_size;
        = rfc$message_block_size =
          attributes^[attribute_index].message_block_size :=
                 connection_attributes^.message_block_size;
        = rfc$incoming_record_abn =
          attributes^[attribute_index].incoming_record_abn :=
                 connection_attributes^.incoming_record_abn;
        = rfc$outgoing_record_abn =
          attributes^[attribute_index].outgoing_record_abn :=
                 connection_attributes^.outgoing_record_abn;
        = rfc$receive_record_terminator =
          attributes^[attribute_index].receive_record_terminator :=
                 connection_attributes^.receive_record_terminator;
        = rfc$file_mark_received =
          attributes^[attribute_index].file_mark_received :=
                 connection_attributes^.file_mark_received;
        = rfc$send_record_terminator =
          attributes^[attribute_index].send_record_terminator :=
                 connection_attributes^.send_record_terminator;
        = rfc$connection_status =
          attributes^[attribute_index].connection_status :=
                 connection_attributes^.connection_status;
        ELSE
          osp$set_status_abnormal (rfc$product_id, rfe$invalid_attribute_key,
                'get file attributes', status);
        CASEND;
      FOREND;
    IFEND;
  PROCEND fetch_get_attributes;
?? TITLE := '    find_application_entry', EJECT ??
  PROCEDURE find_application_entry (application_name: rft$application_name;
        job_table_entry_p: ^rft$rhfam_job_table_entry;
    VAR application_entry_p: ^rft$application_table_entry);

{
{     The purpose of this procedure is to locate the specified
{     applications's application table entry and return a pointer to
{     the entry.
{
{     APPLICATION_NAME: (input) This parameter specifies the application to
{       locate.
{
{     JOB_TABLE_ENTRY_P: (input) This parameter specifies the pointer to
{       to the job table entry.
{
{     APPLICATION_ENTRY_P: (output) This parameter returns a pointer to
{       the application table entry that was found. A NIL pointer indicates
{       no application entry was found.
{



    application_entry_p := job_table_entry_p^.application_entry;
    WHILE application_entry_p <> NIL DO
      IF application_entry_p^.application_name = application_name THEN
        RETURN;
      IFEND;
      application_entry_p := application_entry_p^.next_entry;
    WHILEND;

  PROCEND find_application_entry;
?? TITLE := '    rfp$find_connection_entry', EJECT ??
  PROCEDURE rfp$find_connection_entry (connection_file: fst$path_handle_name;
        job_table_entry_p: ^rft$rhfam_job_table_entry;
    VAR connection_entry_p: ^rft$connection_entry);

{
{     The purpose of this procedure is to locate the specified
{     connection table entry and return a pointer to
{     the entry.
{
{     CONNECTION_FILE: (input) This parameter specifies the connection to
{       locate.
{
{     JOB_TABLE_ENTRY_P: (input) This parameter specifies the pointer to
{       to the job table entry.
{
{     CONNECTION_ENTRY_P: (output) This parameter specifies a pointer to
{       the connection table entry specified by connection name.
{       A NIL pointer indicates no connection entry was found.
{



    VAR
      application_entry_p: ^rft$application_table_entry;


    connection_entry_p := NIL;
    application_entry_p := job_table_entry_p^.application_entry;
    WHILE application_entry_p <> NIL DO
      connection_entry_p := application_entry_p^.connection_table;
      WHILE connection_entry_p <> NIL DO
        IF connection_entry_p^.connection_name =
              connection_file THEN
          RETURN;
        IFEND;
        connection_entry_p := connection_entry_p^.next_entry;
      WHILEND;
      application_entry_p := application_entry_p^.next_entry;
    WHILEND;

  PROCEND rfp$find_connection_entry;
?? TITLE := '    find_server_entry', EJECT ??
  PROCEDURE [INLINE] find_server_entry (server_name: rft$application_name;
        require_active: boolean;
    VAR server_entry_p: ^rft$rhfam_server_table_entry;
    VAR status: ost$status);

{
{     The purpose of this procedure is to locate the specified
{     server table entry and return a pointer to the entry.
{
{     SERVER_NAME: (input) This parameter specifies the server to
{       locate.
{
{     REQUIRE_ACTIVE: (input); This parameter specifies if the server
{       definition must be active to match.
{
{     SERVER_ENTRY_P: (input) This parameter specifies the pointer to
{       to the specified server table entry. A NIL pointer indicates no
{       server table entry was found.
{
{     STATUS: (output) This parameter returns the results of the request.
{       A status of normal means the server was found.
{



    status.normal := TRUE;
    server_entry_p := rfv$rhfam_server_table.first_entry;
    WHILE server_entry_p <> NIL DO
      IF (server_entry_p^.server_name = server_name) THEN
        IF require_active THEN
          IF server_entry_p^.server_active THEN
            RETURN;
          ELSE
            osp$set_status_abnormal (rfc$product_id, rfe$appl_not_active,
                  server_name, status);
            EXIT find_server_entry;
          IFEND;
        ELSE
          RETURN;
        IFEND;
      IFEND;
      server_entry_p := server_entry_p^.next_entry;
    WHILEND;

    osp$set_status_abnormal (rfc$product_id, rfe$appl_not_defined,
          server_name, status);

  PROCEND find_server_entry;
?? TITLE := '    rfp$get_attributes', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$get_attributes (
        connection_file: fst$file_reference;
    VAR file_attributes: rft$get_attributes;
    VAR status: ost$status);

*copyc rfh$get_attributes


?? NEWTITLE := '      terminate_get_attributes - condition handler', EJECT ??
    PROCEDURE terminate_get_attributes (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        IF connection_entry_p <> NIL THEN
          rfp$unlock_table (connection_entry_p^.lock);
        IFEND;
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$get_attributes;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$get_attributes;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_get_attributes;
?? OLDTITLE, EJECT ??


    VAR
      connection_entry_p: ^rft$connection_entry,
      path_handle_name: fst$path_handle_name;


    connection_entry_p := NIL;
    osp$establish_condition_handler (^terminate_get_attributes, FALSE);
    status.normal := TRUE;

    get_path_handle_name (connection_file, path_handle_name, status);
    IF NOT status.normal THEN
      EXIT rfp$get_attributes;
    IFEND;
    get_exclusive_to_connection (path_handle_name, connection_entry_p, status);
    IF NOT status.normal THEN
      EXIT rfp$get_attributes;
    IFEND;
    fetch_get_attributes (^connection_entry_p^.connection_attributes,
          ^file_attributes, status);
    rfp$unlock_table (connection_entry_p^.lock);

  PROCEND rfp$get_attributes;
?? TITLE := '    get_exclusive_to_connection', EJECT ??
  PROCEDURE get_exclusive_to_connection(connection_file: fst$path_handle_name;
    VAR connection_entry_p: ^rft$connection_entry;
    VAR status: ost$status);

{
{     The purpose of this procedure is to acquire exclusive access to a connection
{     entry.  Exclusive access to a connection entry means getting the connection
{     entry lock with no active pp requests, no send data request and no receive
{     data request on the specifed connection file.  The connection entry is
{     locked upon successful completion of this request, and must be unlocked
{     by the calling routine.
{
{     CONNECTION_FILE: (input) This parameter specifies the connection to
{       acquire access to.
{
{     CONNECTION_ENTRY_P: (output) This parameter returns the pointer to the
{       connection table entry.
{
{     STATUS: (output) This parameter returns the completion status of the
{       request.  A status of normal indicates that the connection was found
{       and the job table was successfully locked.  An abnormal status
{       indicates that the job table was not locked.


    VAR
      active_request: boolean,
      job_table_entry_p: ^rft$rhfam_job_table_entry,
      local_status: ost$status,
      new_entry: boolean;


    status.normal := TRUE;

    /get_exclusive_access/
    REPEAT
      rfp$lock_job_table_entry (FALSE, new_entry, job_table_entry_p);
      IF job_table_entry_p = NIL  THEN
        connection_entry_p := NIL;
        osp$set_status_abnormal(rfc$product_id, rfe$connection_not_active,
              connection_file, status);
        EXIT get_exclusive_to_connection;
      IFEND;
      rfp$find_connection_entry (connection_file, job_table_entry_p, connection_entry_p);
      IF connection_entry_p = NIL THEN
        job_table_entry_p^.lock := tmv$null_global_task_id;
        osp$set_status_abnormal (rfc$product_id, rfe$connection_not_active,
              connection_file, status);
        EXIT get_exclusive_to_connection;
      IFEND;
      rfp$lock_table (connection_entry_p^.lock);
      job_table_entry_p^.lock := tmv$null_global_task_id;
      active_request:= false;
      IF connection_entry_p^.active_pp_requests <> 0 THEN
        rfp$unlock_table (connection_entry_p^.lock);
        active_request := TRUE;
        syp$cycle;
      ELSEIF (connection_entry_p^.receive_request_active) OR
         (connection_entry_p^.send_request_active) THEN
        active_request := TRUE;
        enter_waiting_task_queue(connection_entry_p, local_status);
        rfp$unlock_table (connection_entry_p^.lock);
        connection_entry_p := NIL;
        job_table_entry_p := NIL;
        pmp$wait(10000, 10000);
      IFEND;
    UNTIL NOT active_request;

  PROCEND get_exclusive_to_connection;
?? TITLE :='    get_exclusive_to_cid', EJECT ??
  PROCEDURE get_exclusive_to_cid (connection_identifier: amt$file_identifier;
    VAR connection_entry_p: ^rft$connection_entry;
    VAR status: ost$status);


{     The purpose of this procedure is to acquire exclusive access to a connection
{     entry.  Exclusive access to a connection entry means getting the
{     connection entry lock with no active pp requests.  The connection entry
{     is locked upon successful completion of this request, and must be
{     unlocked by the calling routine. This routine does not check for
{     active send or receive requests.
{
{     CONNECTION_IDENTIFIER: (input) This parameter specifies the connection
{       identifier of the connection file to acquire access to.
{
{     CONNECTION_ENTRY_P: (output) This parameter returns a pointer to
{       the connection entry of the specified connection.
{
{     STATUS: (output) This parameter returns the status of the request.
{       A value of normal indicates that the connection has been locked.
{



    VAR
      active_pp_requests: boolean,
      file_instance_p: ^bat$task_file_entry,
      file_is_valid: boolean,
      job_table_entry_p : ^rft$rhfam_job_table_entry,
      new_entry: boolean;


    status.normal := TRUE;

    REPEAT
      job_table_entry_p := NIL;
      connection_entry_p := NIL;
      bap$validate_file_identifier (connection_identifier, file_instance_p,
            file_is_valid);
      IF NOT file_is_valid THEN
        osp$set_status_abnormal (amc$access_method_id, ame$improper_file_id, '',
              status);
        EXIT get_exclusive_to_cid;
      IFEND;
      IF file_instance_p^.device_class <> rmc$rhfam_device THEN
        osp$set_status_abnormal (rfc$product_id, rfe$file_device_class_not_rhf,
              ' ', status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              file_instance_p^.local_file_name, status);
        EXIT get_exclusive_to_cid;
      IFEND;
      rfp$lock_job_table_entry (FALSE, new_entry, job_table_entry_p);
      IF job_table_entry_p = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$connection_not_active,
              file_instance_p^.local_file_name, status);
        EXIT get_exclusive_to_cid;
      IFEND;
      rfp$find_connection_entry (file_instance_p^.local_file_name,
            job_table_entry_p, connection_entry_p);
      IF connection_entry_p = NIL THEN
        job_table_entry_p^.lock := tmv$null_global_task_id;
        osp$set_status_abnormal (rfc$product_id, rfe$connection_not_active,
              file_instance_p^.local_file_name, status);
        EXIT get_exclusive_to_cid;
      IFEND;
      rfp$lock_table (connection_entry_p^.lock);
      job_table_entry_p^.lock := tmv$null_global_task_id;
      active_pp_requests := (connection_entry_p^.active_pp_requests <> 0);
      IF active_pp_requests THEN
        rfp$unlock_table (connection_entry_p^.lock);
        syp$cycle;
      IFEND;
    UNTIL NOT active_pp_requests;

  PROCEND get_exclusive_to_cid;
?? TITLE := '    get_exclusive_to_job', EJECT ??
  PROCEDURE get_exclusive_to_job(connection_file: fst$path_handle_name;
    VAR job_table_entry_p: ^rft$rhfam_job_table_entry;
    VAR connection_entry_p: ^rft$connection_entry;
    VAR status: ost$status);

{
{     The purpose of this procedure is to acquire exclusive access to a connection
{     entry.  Exclusive access to a connection entry means getting the job table
{     entry lock with no active pp requests, no send data request and no receive
{     data request on the specifed connection file.  The job table entry and the
{     connection entry are locked upon successful completion of
{     this request, and both must be unlocked  by the calling routine.
{
{     CONNECTION_FILE: (input) This parameter specifies the connection to
{       acquire access to.
{
{     JOB_TABLE_ENTRY_P: (output) This parameter returns the pointer to the
{       locked job table entry.
{
{     CONNECTION_ENTRY_P: (output) This parameter returns the pointer to the
{       connection table entry.
{
{     STATUS: (output) This parameter returns the completion status of the
{       request.  A status of normal indicates that the connection was found
{       and the job table was successfully locked.  An abnormal status
{       indicates that the job table was not locked.


    VAR
      active_request: boolean,
      local_status: ost$status,
      new_entry: boolean;


    status.normal := TRUE;
    /get_exclusive_access/
    REPEAT
      rfp$lock_job_table_entry (FALSE, new_entry, job_table_entry_p);
      IF job_table_entry_p = NIL  THEN
        connection_entry_p := NIL;
        osp$set_status_abnormal(rfc$product_id, rfe$connection_not_active,
              connection_file, status);
        EXIT get_exclusive_to_job;
      IFEND;
      rfp$find_connection_entry (connection_file, job_table_entry_p, connection_entry_p);
      IF connection_entry_p = NIL THEN
        job_table_entry_p^.lock := tmv$null_global_task_id;
        osp$set_status_abnormal (rfc$product_id, rfe$connection_not_active,
              connection_file, status);
        EXIT get_exclusive_to_job;
      IFEND;
      rfp$lock_table (connection_entry_p^.lock);
      active_request:= false;
      IF connection_entry_p^.active_pp_requests <> 0 THEN
        rfp$unlock_table (connection_entry_p^.lock);
        job_table_entry_p^.lock := tmv$null_global_task_id;
        active_request := TRUE;
        syp$cycle;
      ELSEIF (connection_entry_p^.receive_request_active) OR
         (connection_entry_p^.send_request_active) THEN
        active_request := TRUE;
        enter_waiting_task_queue(connection_entry_p, local_status);
        rfp$unlock_table (connection_entry_p^.lock);
        job_table_entry_p^.lock := tmv$null_global_task_id;
        connection_entry_p := NIL;
        job_table_entry_p := NIL;
        pmp$wait(10000, 10000);
      IFEND;
    UNTIL NOT active_request;

  PROCEND get_exclusive_to_job;
?? TITLE := '    get_incoming_connect', EJECT ??
  PROCEDURE get_incoming_connect (server_name: rft$application_name;
    VAR incoming_connect: rft$incoming_connect;
    VAR incoming_connect_available: boolean;
    VAR access_method_accept: boolean;
    VAR status: ost$status);

{
{     The purpose of this procedure is to obtain from the rhfam server
{     table an incoming connect that has been assigned to the specified
{     server by the rhfam system task. If an incoming connect is found
{     it is returned to the caller and the incoming connect buffer is
{     released from the network paged section.
{
{     SERVER_NAME: (input) This parameter specifies the server to get
{       an incoming connect for.
{
{     INCOMING_CONNECT: (OUTPUT) This parameter returns the incoming
{       connect that has been received.
{
{     INCOMING_CONNECT_AVAILABLE: (output) This parameter returns a
{       TRUE value if an incoming connect has been found for the specified
{       server. A value of FALSE indicates that no connect is available.
{
{     ACCESS_METHOD_ACCEPT: (output) This parameter returns the access
{       method accept attribute of this server.  A value of TRUE indicates
{       that the system task has accepted the connection request on
{       behalf of the server.  A value of FALSE indicates that the server
{       must accept or reject the connection.
{


  VAR
    active_incoming_connects: boolean,
    incoming_connect_p: ^rft$incoming_connect,
    server_entry_p: ^rft$rhfam_server_table_entry;


    incoming_connect_available := false;

  /wait_for_active_incoming/
    REPEAT
      rfp$lock_table (rfv$rhfam_server_table.lock);
      find_server_entry(server_name, FALSE, server_entry_p, status);
      IF NOT status.normal THEN
        rfp$unlock_table (rfv$rhfam_server_table.lock);
        EXIT get_incoming_connect;
      IFEND;
      active_incoming_connects :=
            (server_entry_p^.active_incoming_connects <> 0);
      IF active_incoming_connects THEN
        rfp$unlock_table (rfv$rhfam_server_table.lock);
        syp$cycle;
      IFEND;
    UNTIL NOT active_incoming_connects;

    IF server_entry_p^.incoming_connect <> NIL THEN
      incoming_connect_p := server_entry_p^.incoming_connect;
      incoming_connect := incoming_connect_p^;
      incoming_connect_available := TRUE;
      server_entry_p^.incoming_connect := incoming_connect_p^.next_entry;
      access_method_accept := server_entry_p^.access_method_accept;
      FREE incoming_connect_p IN nav$network_paged_heap^;
    IFEND;
    rfp$unlock_table (rfv$rhfam_server_table.lock);

  PROCEND get_incoming_connect;
?? TITLE := '    rfp$get_local_host_physical_id', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$get_local_host_physical_id (
    VAR physical_identifier: rft$physical_identifier;
    VAR status: ost$status);

*copyc rfh$get_local_host_physical_id

?? NEWTITLE := '      terminate_get_local_host - condition handler', EJECT ??
    PROCEDURE terminate_get_local_host (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$get_local_host_physical_id;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$get_local_host_physical_id;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_get_local_host;
?? OLDTITLE, EJECT ??


    VAR
      local_physical_id : rft$physical_identifier;

    status.normal := TRUE;
    osp$establish_condition_handler (^terminate_get_local_host, FALSE);
    rfp$lock_table (rfv$status_table.lock);
    IF rfv$status_table.system_task_is_up THEN
      local_physical_id := rfv$status_table.local_host^.physical_identifier;
    ELSE
      osp$set_status_abnormal (rfc$product_id,
            rfe$system_task_not_active, 'rfp$find_available_service', status);
    IFEND;
    rfp$unlock_table (rfv$status_table.lock);

    IF status.normal THEN
      physical_identifier := local_physical_id;
    IFEND;

  PROCEND rfp$get_local_host_physical_id;
?? TITLE := '    get_path_status', EJECT ??
  PROCEDURE get_path_status (
        connection_entry_p: ^rft$connection_entry;
    VAR status: ost$status);

{
{     The purpose of this procedure is to build and queue a request
{     to get the specified paths present status.  The connection entry
{     must be locked upon entry to this procedure and will be unlocked
{     upon return.
{
{     CONNECTION_ENTRY_P: (input) This parameter specifies the pointer
{       to the connection table entry to get the status for.
{
{     STATUS: (output) This parameter returns the result of the request.
{

    VAR
      activity_status: ^ost$activity_status,
      command_identifier: ^rft$logical_commands,
      nad_index: rft$local_nads,
      path_id: ^rft$path_identifier,
      request_info: ^ SEQ( * ),
      unit_request_status: ^rft$connection_mgmt_status;


      status.normal := TRUE;

    /queue_path_status_request/
      BEGIN
        ALLOCATE unit_request_status IN osv$task_private_heap^;
        IF  unit_request_status = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted,
                'task private', status);
          osp$append_status_parameter(osc$status_parameter_delimiter,
                'get_path_status', status);
          EXIT  /queue_path_status_request/;
        IFEND;
        unit_request_status^.internal_use := FALSE;
        unit_request_status^.connection := connection_entry_p;

{     The structure activity status is allocated in task private to insure
{     it is writeable by ring 3 code. Pointers to this variable are stored in
{     a task private segment and thus inherit ring 3 privileges.

        ALLOCATE activity_status IN osv$task_private_heap^;
        IF  activity_status = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted,
                'task private', status);
          osp$append_status_parameter(osc$status_parameter_delimiter,
                'get_path_status', status);
          EXIT  /queue_path_status_request/;
        IFEND;
        unit_request_status^.activity_status := activity_status;

        activity_status^.complete := FALSE;
        activity_status^.status.normal := TRUE;

        PUSH request_info: [[rft$logical_commands,       {command_identifier}
              rft$path_identifier]];                     {path identifier}

        RESET request_info;
        NEXT command_identifier  IN  request_info;
        IF  command_identifier = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err,
                'the request overflowed the request sequence', status);
          osp$append_status_parameter(osc$status_parameter_delimiter,
                'get_path_status', status);
          EXIT  /queue_path_status_request/;
        IFEND;
        command_identifier^ := rfc$lc_read_path_status_table;
        NEXT  path_id IN  request_info;
        IF  path_id = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err,
                'the request overflowed the request sequence', status);
          osp$append_status_parameter(osc$status_parameter_delimiter,
                'get_path_status', status);
          EXIT  /queue_path_status_request/;
        IFEND;
        path_id^ := connection_entry_p^.connection_descriptor.network_path;
        nad_index := connection_entry_p^.connection_descriptor.nad_index;
        unit_request_status^.connection^.active_pp_requests :=
              unit_request_status^.connection^.active_pp_requests + 1;
        rfp$unlock_table (connection_entry_p^.lock);
        rfp$queue_request(nad_index, 1, rfc$unit_request, rfc$rk_path_status,
              unit_request_status, request_info, status);
        IF status.normal THEN
          REPEAT
            #SPOIL (activity_status^);
            pmp$wait (rfc$unit_request_wait_time, rfc$ur_expected_wait);
            rfp$process_pp_response_flag (rfc$pp_response_available);
          UNTIL activity_status^.complete;
          IF NOT activity_status^.status.normal THEN
            status := activity_status^.status;
          IFEND;
          FREE activity_status IN osv$task_private_heap^;
          EXIT get_path_status;
        ELSE
          rfp$lock_table (connection_entry_p^.lock);
          unit_request_status^.connection^.active_pp_requests :=
                unit_request_status^.connection^.active_pp_requests - 1;
          FREE unit_request_status IN osv$task_private_heap^;
        IFEND;
      END /queue_path_status_request/;
      rfp$unlock_table (connection_entry_p^.lock);

  PROCEND get_path_status;
?? TITLE := '    get_switched_connection', EJECT ??
  PROCEDURE   get_switched_connection (application_name: rft$application_name;
    VAR switched_connection: ^rft$switched_connection);

{
{     The purpose of this procedure is to locate an entry in the switched
{     connection queue, delink the entry from the queue and return a pointer
{     to the found entry.  It is the responsibility of the calling routine
{     to deallocate the entry when finished with it.
{
{     APPLICATION_NAME: (input) This parameter specifies the name of the
{       application that is asking for a switched connection.
{
{     SWITCHED_CONNECTION: (output) This parameter returns a pointer to
{       the switched connection that was found.  A value of NIL indicates
{       that no switched connection was found.



    VAR
      ignore_status: ost$status,
      previous_entry: ^rft$switched_connection,
      system_supplied_name: jmt$system_supplied_name,
      user_supplied_name: jmt$user_supplied_name;


    rfp$lock_table (rfv$switched_connection_queue.lock);
    previous_entry := NIL;
    switched_connection := rfv$switched_connection_queue.first_entry;
    pmp$get_job_names (user_supplied_name, system_supplied_name, ignore_status);
  /find_switched_connection/
    WHILE switched_connection <> NIL DO
      IF (application_name = switched_connection^.destination_application) AND
         (system_supplied_name = switched_connection^.destination_job) THEN
        EXIT /find_switched_connection/;
      IFEND;
      previous_entry := switched_connection;
      switched_connection := switched_connection^.next_entry;
    WHILEND /find_switched_connection/;

    IF switched_connection <> NIL THEN
      switched_connection^.connection_entry_source_job^.connection_attributes.
            connection_status.connection_state := rfc$switch_accepted;
      IF previous_entry = NIL THEN
        rfv$switched_connection_queue.first_entry := switched_connection^.next_entry;
      ELSE
        previous_entry^.next_entry := switched_connection^.next_entry;
      IFEND;
    IFEND;
    rfp$unlock_table (rfv$switched_connection_queue.lock);

  PROCEND get_switched_connection;
?? TITLE := '    rfp$job_termination', EJECT ??
  PROCEDURE [XDCL] rfp$job_termination;

{
{     The purpose of this procedure is remove any tables that RHFAM
{     has associated with this job. It assumes that no connections
{     are associated with the job.  The connections are previously
{     terminated by the local name table manager when the local files
{     are returned.
{

    VAR
      application_entry_p: ^rft$application_table_entry,
      client_definition_p: ^rft$rhfam_client_table_entry,
      ignore_status: ost$status,
      job_table_entry_p: ^rft$rhfam_job_table_entry,
      next_application_entry_p: ^rft$application_table_entry,
      new_entry: boolean;


  /main_section/
    BEGIN
    rfp$lock_job_table_entry (FALSE, new_entry, job_table_entry_p);
    IF job_table_entry_p <> NIL THEN
      application_entry_p := job_table_entry_p^.application_entry;
      WHILE application_entry_p <> NIL DO
        next_application_entry_p := application_entry_p^.next_entry;
        CASE application_entry_p^.application_kind OF
        = rfc$client =
          rfp$lock_table (rfv$rhfam_client_table.lock);
          rfp$find_client_entry (application_entry_p^.application_name, FALSE,
                client_definition_p, ignore_status);
          IF ignore_status.normal THEN
            client_definition_p^.connections_reserved := client_definition_p^.
                  connections_reserved - application_entry_p^.maximum_allowed_connections;
          IFEND;
          rfp$unlock_table (rfv$rhfam_client_table.lock);
        = rfc$server =
          sign_off_server (application_entry_p^.application_name, job_table_entry_p^.job_name,
                application_entry_p^.maximum_allowed_connections, ignore_status);
        = rfc$partner =
          ;
        CASEND;
        FREE application_entry_p IN nav$network_paged_heap^;
        application_entry_p := next_application_entry_p;
      WHILEND;
      remove_job_table_entry(job_table_entry_p);
    IFEND;
    END /main_section/;

  PROCEND rfp$job_termination;
?? TITLE := '    link_new_connection_entry', EJECT ??
  PROCEDURE link_new_connection_entry (application_entry_p: ^rft$application_table_entry;
    VAR connection_entry_p: ^rft$connection_entry;
    VAR status: ost$status);

{
{     The purpose of this procedure is to allocate and link a
{     connection entry data structure into the connection list for
{     an application. This routine increments the connection count
{     in the application entry and initializes the connection entry
{     linkage.
{
{     APPLICATION_ENTRY_P: (input) This parameter specifies a pointer
{       to the application entry for which a connection table entry
{       is to be allocated.
{
{     CONNECTION_ENTRY_P: (output) This parameter returns a pointer
{       to the connection table entry that has been allocated. A NIL
{       pointer indicates that table allocation failed.
{
{     STATUS: (output) This parameter returns the status of the
{       allocation.  A status of normal indicates that the table
{       allocation succeeded.



    ALLOCATE connection_entry_p IN nav$network_paged_heap^;
    IF connection_entry_p <> NIL THEN
      pmp$zero_out_table (connection_entry_p, #SIZE(rft$connection_entry));
      connection_entry_p^.application_entry_p := application_entry_p;
      IF application_entry_p^.connection_table = NIL THEN
        application_entry_p^.connection_table := connection_entry_p;
        connection_entry_p^.next_entry := NIL;
      ELSE
        connection_entry_p^.next_entry := application_entry_p^.connection_table;
        application_entry_p^.connection_table := connection_entry_p;
      IFEND;
    ELSE
      osp$set_status_abnormal (rfc$product_id, rfe$heap_exhausted,
            'network paged', status);
      osp$append_status_parameter(osc$status_parameter_delimiter,
            'link_new_connection_entry', status);
      EXIT link_new_connection_entry;
    IFEND;

  PROCEND link_new_connection_entry;
?? TITLE := '    rfp$lock_job_table_entry', EJECT ??
  PROCEDURE [XDCL] rfp$lock_job_table_entry (create_new_entry: BOOLEAN;
    VAR new_entry_created: BOOLEAN;
    VAR job_table_entry_p:^rft$rhfam_job_table_entry);

{
{     The purpose of this procedure is to set the entry lock on a RHFAM
{     job table entry.  This procedure first obtains the global table lock
{     and if the entry lock is not set, the entry lock is set and the
{     pointer to the table entry is returned.  If the entry lock is set
{     the global lock is released, a delay is performed and the entry lock
{     is again attempted.
{
{     CREATE_NEW_ENTRY: (input) This parameter states whether or not a new job
{       table is to be created if an existing entry is not found.
{
{     NEW_ENTRY_CREATED: (output) This parameter states whether or not a new
{       job table entry has been created.  This parameter is only meaningful if the
{       create_new_entry parameter is TRUE.
{
{     JOB_TABLE_ENTRY_P: (output) This parameter specifies the pointer to
{       the locked job table entry. A NIL value indicates that no job table
{       entry was found.
{


    VAR
      global_task_id: ost$global_task_id,
      local_status: ost$status,
      system_supplied_name: jmt$system_supplied_name,
      user_supplied_name: jmt$user_supplied_name;


    job_table_entry_p := NIL;
    new_entry_created := FALSE;
    pmp$get_executing_task_gtid (global_task_id);

    rfp$lock_table (rfv$rhfam_job_table.lock);
    IF rfv$job_entry_pointer <> NIL THEN
    /lock_entry/
      WHILE rfv$job_entry_pointer <> NIL DO
        IF rfv$job_entry_pointer^.lock = tmv$null_global_task_id THEN
          job_table_entry_p := rfv$job_entry_pointer;
          job_table_entry_p^.lock := global_task_id;
          EXIT /lock_entry/;
        ELSE
          rfp$unlock_table (rfv$rhfam_job_table.lock);
          syp$cycle;
          rfp$lock_table (rfv$rhfam_job_table.lock);
          CYCLE /lock_entry/;
        IFEND;
      WHILEND /lock_entry/;

    ELSE
      IF  create_new_entry  THEN

        ALLOCATE rfv$job_entry_pointer IN nav$network_paged_heap^;

        pmp$get_job_names (user_supplied_name, system_supplied_name, local_status);
        job_table_entry_p := rfv$job_entry_pointer;
        job_table_entry_p^.lock := global_task_id;
        job_table_entry_p^.job_name := system_supplied_name;
        job_table_entry_p^.next_entry := NIL;
        job_table_entry_p^.application_entry := NIL;

{     Add new entry to end of rhfam job table.

        IF rfv$rhfam_job_table.first_entry = NIL THEN
          rfv$rhfam_job_table.first_entry := job_table_entry_p;
          rfv$rhfam_job_table.last_entry := job_table_entry_p;
        ELSE
          rfv$rhfam_job_table.last_entry^.next_entry := job_table_entry_p;
          rfv$rhfam_job_table.last_entry := job_table_entry_p;
        IFEND;
        new_entry_created := TRUE;
      IFEND;
    IFEND;

    rfp$unlock_table (rfv$rhfam_job_table.lock);

  PROCEND rfp$lock_job_table_entry;
?? TITLE := '    rfp$lock_table', EJECT ??
  PROCEDURE [XDCL] rfp$lock_table (VAR lock: ost$signature_lock);

{
{     The purpose of this procedure is to obtain the global lock on a
{     RHFAM ring 3 table.  This procedure increments the system table lock
{     count to prevent unnecessary swapping.
{
{     LOCK: (input,output)  This parameter specifies the signature lock to
{       obtain.
{


    osp$begin_subsystem_activity;
    osp$set_job_signature_lock(lock);

  PROCEND rfp$lock_table;
?? TITLE := '    merge_change_attributes', EJECT ??
  PROCEDURE merge_change_attributes (
        connection_attributes: ^rft$connection_attributes;
        attributes: ^rft$change_attributes;
    VAR status: ost$status);

{     The purpose of this procedure is to merge the specified attributes
{     with the current connection attributes.
{
{     CONNECTION_ATTRIBUTES: (input,output) This parameter specifies a
{       pointer to the current connection attributes.
{
{     ATTRIBUTES: (input) This parameter specifies a pointer to the
{       attributes to merge with the connection attributes.
{
{     STATUS: (output) This parameter returns the result of the attribute
{       merge.
{



    VAR
      attribute_index: integer,
      invalid_attribute_value: boolean;

    status.normal := TRUE;
    invalid_attribute_value := FALSE;
    IF attributes <> NIL THEN
      FOR attribute_index := LOWERBOUND (attributes^) TO UPPERBOUND (attributes^) DO
        CASE attributes^ [attribute_index].key OF
        = rfc$connection_timeout =
          IF (attributes^[attribute_index].connection_timeout >=
                    LOWERVALUE(rft$connection_timeout)) AND
             (attributes^[attribute_index].connection_timeout <=
                    UPPERVALUE(rft$connection_timeout)) THEN
            connection_attributes^.connection_timeout :=
                  attributes^[attribute_index].connection_timeout;
          ELSE
            invalid_attribute_value := TRUE;
          IFEND;
        = rfc$data_transfer_timeout =
          IF (attributes^[attribute_index].data_transfer_timeout >=
                    LOWERVALUE(rft$transfer_timeout)) AND
             (attributes^[attribute_index].data_transfer_timeout <=
                    UPPERVALUE(rft$transfer_timeout)) THEN
            connection_attributes^.data_transfer_timeout :=
                  attributes^ [attribute_index].data_transfer_timeout;
          ELSE
            invalid_attribute_value := TRUE;
          IFEND;
        = rfc$record_block_size =
          IF (attributes^[attribute_index].record_block_size >=
                    LOWERVALUE(rft$block_size)) AND
             (attributes^[attribute_index].record_block_size <=
                    UPPERVALUE(rft$block_size)) THEN
            IF attributes^ [attribute_index].record_block_size <> 0 THEN
              connection_attributes^.record_block_size :=
                    attributes^ [attribute_index].record_block_size;
            ELSE
              connection_attributes^.record_block_size :=
                    rfc$max_block_size;
            IFEND;
          ELSE
            invalid_attribute_value := TRUE;
          IFEND;
        = rfc$message_block_size =
          IF (attributes^[attribute_index].message_block_size >=
                    LOWERVALUE(rft$block_size)) AND
             (attributes^[attribute_index].message_block_size <=
                    UPPERVALUE(rft$block_size)) THEN
            IF attributes^[attribute_index].message_block_size <> 0 THEN
              connection_attributes^.message_block_size :=
                    attributes^ [attribute_index].message_block_size;
            ELSE
              connection_attributes^.message_block_size :=
                    rfc$max_block_size;
            IFEND;
          ELSE
            invalid_attribute_value := TRUE;
          IFEND;
        = rfc$incoming_record_abn =
          IF (attributes^[attribute_index].incoming_record_abn >=
                    LOWERVALUE(rft$application_block_number)) AND
             (attributes^[attribute_index].incoming_record_abn <=
                    UPPERVALUE(rft$application_block_number)) THEN
            connection_attributes^.incoming_record_abn :=
                  attributes^ [attribute_index].incoming_record_abn;
          ELSE
            invalid_attribute_value := TRUE;
          IFEND;
        = rfc$outgoing_record_abn =
          IF (attributes^[attribute_index].outgoing_record_abn >=
                    LOWERVALUE(rft$application_block_number)) AND
             (attributes^[attribute_index].outgoing_record_abn <=
                    UPPERVALUE(rft$application_block_number)) THEN
            connection_attributes^.outgoing_record_abn :=
                  attributes^ [attribute_index].outgoing_record_abn;
          ELSE
            invalid_attribute_value := TRUE;
          IFEND;
        = rfc$receive_record_terminator =
          IF (attributes^[attribute_index].receive_record_terminator >=
                    LOWERVALUE(rft$record_marks)) AND
             (attributes^[attribute_index].receive_record_terminator <=
                    UPPERVALUE(rft$record_marks)) THEN
            connection_attributes^.receive_record_terminator :=
                  attributes^[attribute_index].receive_record_terminator;
          ELSE
            invalid_attribute_value := TRUE;
          IFEND;
        = rfc$send_record_terminator =
          IF (attributes^[attribute_index].send_record_terminator >=
                    LOWERVALUE(rft$record_marks)) AND
             (attributes^[attribute_index].send_record_terminator <=
                    UPPERVALUE(rft$record_marks)) THEN
            connection_attributes^.send_record_terminator :=
                  attributes^ [attribute_index].send_record_terminator;
          ELSE
            invalid_attribute_value := TRUE;
          IFEND;
        ELSE
          osp$set_status_abnormal (rfc$product_id, rfe$invalid_attribute_key,
                'change file attributes', status);
        CASEND;
      FOREND;
    IFEND;
    IF (status.normal) AND
       (invalid_attribute_value) THEN
      osp$set_status_abnormal (rfc$product_id, rfe$invalid_attribute_value,
            'change file attributes', status);
    IFEND;

  PROCEND merge_change_attributes;
?? TITLE := '    merge_creation_attributes', EJECT ??
  PROCEDURE merge_creation_attributes (
        connection_attributes: ^rft$connection_attributes;
        attributes: ^rft$create_attributes;
    VAR status: ost$status);

{     The purpose of this procedure is to merge the specified attributes
{     with the current connection attributes.
{
{     CONNECTION_ATTRIBUTES: (input,output) This parameter specifies a
{       pointer to the current connection attributes.
{
{     ATTRIBUTES: (input) This parameter specifies a pointer to the
{       attributes to merge with the connection attributes.
{
{     STATUS: (output) This parameter returns the result of the attribute
{       merge.
{



    VAR
      attribute_index: integer,
      invalid_attribute_value: boolean;


    status.normal := TRUE;
    invalid_attribute_value := FALSE;
    IF attributes <> NIL THEN
      FOR attribute_index := LOWERBOUND (attributes^) TO UPPERBOUND (attributes^) DO
        CASE attributes^ [attribute_index].key OF
        = rfc$connection_timeout =
          IF (attributes^[attribute_index].connection_timeout >=
                    LOWERVALUE(rft$connection_timeout)) AND
             (attributes^[attribute_index].connection_timeout <=
                    UPPERVALUE(rft$connection_timeout)) THEN
            connection_attributes^.connection_timeout :=
                  attributes^[attribute_index].connection_timeout;
          ELSE
            invalid_attribute_value := TRUE;
          IFEND;
        = rfc$data_transfer_timeout =
          IF (attributes^[attribute_index].data_transfer_timeout >=
                    LOWERVALUE(rft$transfer_timeout)) AND
             (attributes^[attribute_index].data_transfer_timeout <=
                    UPPERVALUE(rft$transfer_timeout)) THEN
            connection_attributes^.data_transfer_timeout :=
                  attributes^ [attribute_index].data_transfer_timeout;
          ELSE
            invalid_attribute_value := TRUE;
          IFEND;
        = rfc$record_block_size =
          IF (attributes^[attribute_index].record_block_size >=
                    LOWERVALUE(rft$block_size)) AND
             (attributes^[attribute_index].record_block_size <=
                    UPPERVALUE(rft$block_size)) THEN
            IF attributes^ [attribute_index].record_block_size <> 0 THEN
              connection_attributes^.record_block_size :=
                    attributes^ [attribute_index].record_block_size;
            ELSE
              connection_attributes^.record_block_size :=
                    rfc$max_block_size;
            IFEND;
          ELSE
            invalid_attribute_value := TRUE;
          IFEND;
        = rfc$message_block_size =
          IF (attributes^[attribute_index].message_block_size >=
                    LOWERVALUE(rft$block_size)) AND
             (attributes^[attribute_index].message_block_size <=
                    UPPERVALUE(rft$block_size)) THEN
            IF attributes^[attribute_index].message_block_size <> 0 THEN
              connection_attributes^.message_block_size :=
                    attributes^ [attribute_index].message_block_size;
            ELSE
              connection_attributes^.message_block_size :=
                    rfc$max_block_size;
            IFEND;
          ELSE
            invalid_attribute_value := TRUE;
          IFEND;
        = rfc$incoming_record_abn =
          IF (attributes^[attribute_index].incoming_record_abn >=
                    LOWERVALUE(rft$application_block_number)) AND
             (attributes^[attribute_index].incoming_record_abn <=
                    UPPERVALUE(rft$application_block_number)) THEN
            connection_attributes^.incoming_record_abn :=
                  attributes^ [attribute_index].incoming_record_abn;
          ELSE
            invalid_attribute_value := TRUE;
          IFEND;
        = rfc$outgoing_record_abn =
          IF (attributes^[attribute_index].outgoing_record_abn >=
                    LOWERVALUE(rft$application_block_number)) AND
             (attributes^[attribute_index].outgoing_record_abn <=
                    UPPERVALUE(rft$application_block_number)) THEN
            connection_attributes^.outgoing_record_abn :=
                  attributes^ [attribute_index].outgoing_record_abn;
          ELSE
            invalid_attribute_value := TRUE;
          IFEND;
        = rfc$receive_record_terminator =
          IF (attributes^[attribute_index].receive_record_terminator >=
                    LOWERVALUE(rft$record_marks)) AND
             (attributes^[attribute_index].receive_record_terminator <=
                    UPPERVALUE(rft$record_marks)) THEN
            connection_attributes^.receive_record_terminator :=
                  attributes^[attribute_index].receive_record_terminator;
          ELSE
            invalid_attribute_value := TRUE;
          IFEND;
        = rfc$send_record_terminator =
          IF (attributes^[attribute_index].send_record_terminator >=
                    LOWERVALUE(rft$record_marks)) AND
             (attributes^[attribute_index].send_record_terminator <=
                    UPPERVALUE(rft$record_marks)) THEN
            connection_attributes^.send_record_terminator :=
                  attributes^ [attribute_index].send_record_terminator;
          ELSE
            invalid_attribute_value := TRUE;
          IFEND;
        ELSE
          osp$set_status_abnormal (rfc$product_id, rfe$invalid_attribute_key,
                'creation file attributes', status);
        CASEND;
      FOREND;
    IFEND;
    IF (status.normal) AND
       (invalid_attribute_value) THEN
      osp$set_status_abnormal (rfc$product_id, rfe$invalid_attribute_value,
            'creation file attributes', status);
    IFEND;

  PROCEND merge_creation_attributes;
?? TITLE := '    rfp$open_file', EJECT ??
  PROCEDURE  [XDCL] rfp$open_file (file_identifier: amt$file_identifier;
        layer: amt$fap_layer_number;
        call_block: amt$call_block;
    VAR status: ost$status);

{     The purpose of this procedure is to perform the open processing
{     required on a connection file. It is called by the RHFAM network
{     FAP during open processing.
{
{     FILE_IDENTIFIER: (input) This parameter specifies the file identifier
{       of the connection file that is being opened.
{
{     LAYER: (input) This parameter specifies the fap layer number that
{       this routine is being called from.
{
{     CALL_BLOCK: (input) This parameter specifies the file manager call
{       block that the RHFAM network fap was called with.
{
{     STATUS: (output) This parameter returns the status of the request.
{


?? NEWTITLE := '      terminate_open_file - condition handler', EJECT ??
    PROCEDURE terminate_open_file (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        block_exit_expected := TRUE;
        EXIT rfp$open_file;
      = pmc$block_exit_processing =
        IF block_exit_expected THEN
          condition_status.normal := TRUE;
        ELSE
          osp$set_status_from_condition (rfc$product_id, condition, sfsa,
                condition_status, status);
        IFEND;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          block_exit_expected := TRUE;
          EXIT rfp$open_file;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_open_file;
?? OLDTITLE, EJECT ??


    VAR
      block_exit_expected: boolean,
      connection_entry_p: ^rft$connection_entry,
      connect_in_progress: boolean,
      connection_unlocked: boolean,
      input_available: boolean;



    block_exit_expected := FALSE;
    osp$establish_condition_handler (^terminate_open_file, TRUE);

{     During the connection process, an application may be able
{     to get to this code before the system task has time to
{     update the path status table with the correct path state.
{     If this occurs, update_connection_status will unlock the
{     connection and retrieve the path status.  In this case the
{     status returned will be normal but the connection will be
{     unlocked. This loop waits for the status table to be updated
{     with the proper status.

    /wait_for_path_status_to_sync/
    REPEAT
      get_exclusive_to_connection (call_block.open.local_file_name,
            connection_entry_p, status);
      IF status.normal THEN
        connect_in_progress := (rfc$outgoing_connect_active = connection_entry_p^.connection_attributes.
              connection_status.connection_state);
        update_connection_status(connection_entry_p, input_available,
              connection_unlocked, status);
        IF connection_unlocked THEN
          IF status.normal THEN
            IF NOT connect_in_progress THEN
              syp$cycle;
            ELSE
              get_exclusive_to_connection (call_block.open.local_file_name,
                    connection_entry_p, status);
              IF NOT status.normal THEN
                osp$disestablish_cond_handler;
                EXIT rfp$open_file;
              IFEND;
            IFEND;
          ELSE
            osp$disestablish_cond_handler;
            EXIT rfp$open_file;
          IFEND;
        IFEND;
      ELSE
        osp$disestablish_cond_handler;
        EXIT rfp$open_file;
      IFEND;
    UNTIL (NOT connection_unlocked) OR connect_in_progress;

    IF (connection_entry_p^.connection_attributes.connection_status.connection_state =
          rfc$connected) OR
       ((connection_entry_p^.connection_attributes.connection_status.connection_state =
          rfc$terminated) AND input_available) THEN
      connection_entry_p^.open_count := connection_entry_p^.open_count + 1;
    ELSE
      set_connection_status (connection_entry_p, status);
    IFEND;
    rfp$unlock_table (connection_entry_p^.lock);
    osp$disestablish_cond_handler;

  PROCEND rfp$open_file;
?? TITLE := '    queue_control_messages', EJECT ??
  PROCEDURE  queue_control_messages (
        nad_index: rft$local_nads;
    VAR control_messages: ^rft$outgoing_control_message);

{
{     The purpose of this routine is to add a list of control
{     messages to the local NAD outstanding control message queue.
{
{     NAD_INDEX: (input) This parameter specifies the local
{       nad index to queue the list of control messages to.
{
{     CONTROL_MESSAES: (input,output) This parameter specifies
{       a pointer to a list of control messages to add to the local
{       NAD outstanding control message queue.



    VAR
      ignore_status: ost$status,
      next_entry: ^rft$outgoing_control_message,
      present_entry: ^rft$outgoing_control_message,
      ready_system_task: boolean;


    present_entry := NIL;
    ready_system_task := FALSE;
    rfp$lock_table(rfv$status_table.local_nads^[nad_index].
          outgoing_cm_queue.lock);
    next_entry := rfv$status_table.local_nads^[nad_index].outgoing_cm_queue.first_entry;
    WHILE next_entry <> NIL DO
      present_entry := next_entry;
      next_entry := present_entry^.next_entry;
    WHILEND;

    IF present_entry = NIL THEN
      rfv$status_table.local_nads^[nad_index].outgoing_cm_queue.first_entry :=
            control_messages;
    ELSE
      present_entry^.next_entry := control_messages;
    IFEND;

    IF NOT rfv$status_table.local_nads^[nad_index].processing_out_control_mess THEN
      ready_system_task := TRUE;
    IFEND;
    rfp$unlock_table(rfv$status_table.local_nads^[nad_index].
          outgoing_cm_queue.lock);
    control_messages := NIL;

    IF ready_system_task THEN
      pmp$ready_task(rfv$system_task_id, ignore_status);
    IFEND;

  PROCEND queue_control_messages;
?? TITLE := '    rfp$recover_task_activity', EJECT ??
  PROCEDURE [XDCL] rfp$recover_task_activity (VAR status: ost$status);

{
{     The purpose of this routine is to terminate any asynchronous send
{     or receive data requests that were in progress when a deadstart recovery
{     occurred.  Only the asynchronous requests are terminated.  The remaining
{     requests are handled by condition handlers in the appropriate routines.
{
{     STATUS: (output) This parameter returns the result of the request.
{

?? NEWTITLE := '      terminate_recovery - condition handler', EJECT ??
    PROCEDURE terminate_recovery (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);

      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$recover_task_activity;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_recovery;
?? OLDTITLE, EJECT ??

    VAR
      current_request: ^rft$outstanding_requests,
      previous_request: ^rft$outstanding_requests,
      request_to_free: ^rft$outstanding_requests,
      transfer_status: ^rft$data_transfer_status;


    osp$establish_condition_handler (^terminate_recovery, FALSE);
    status.normal := TRUE;
    current_request := rfv$outstanding_requests;
    previous_request := NIL;
    request_to_free := NIL;

  /complete_recovered_requests/
    WHILE current_request <> NIL DO
      CASE current_request^.request_kind OF
      = rfc$rk_send_data, rfc$rk_receive_data =
        transfer_status := current_request^.request_status;
        IF transfer_status^.wait = osc$nowait THEN
          osp$set_status_abnormal (rfc$product_id, rfe$system_interrupt, '',
                transfer_status^.activity_status^.status);
          transfer_status^.activity_status^.complete := TRUE;
          IF previous_request = NIL THEN
            rfv$outstanding_requests := current_request^.next_entry;
          ELSE
            previous_request^.next_entry := current_request^.next_entry;
          IFEND;
          FREE transfer_status IN osv$task_private_heap^;
          request_to_free := current_request;
        IFEND;
      ELSE
          ;
      CASEND;
      previous_request := current_request;
      current_request := current_request^.next_entry;
      IF request_to_free <> NIL THEN
        FREE request_to_free IN osv$task_private_heap^;
      IFEND;
    WHILEND /complete_recovered_requests/;

  PROCEND rfp$recover_task_activity;
?? TITLE := '    remove_data_transfer_event', EJECT ??
  PROCEDURE remove_data_transfer_event (VAR event: ^rft$rhfam_event_table_entry);

{
{     The purpose of this routine is to remove a resource limit wait event
{     from the rhfam event queue.
{
{     EVENT: (input,output) This parameter specifies a pointer to the resource
{       limit event that is to be removed from the event queue.  Upon return,
{       this pointer is set to NIL.



    VAR
      current_entry_p: ^rft$rhfam_event_table_entry,
      previous_entry_p: ^rft$rhfam_event_table_entry;



    previous_entry_p := NIL;
    rfp$lock_table(rfv$rhfam_event_table.lock);
    current_entry_p := rfv$rhfam_event_table.first_entry;
  /remove_event/
    WHILE current_entry_p <> NIL DO
      IF #offset(current_entry_p) = #offset(event) THEN
        IF previous_entry_p = NIL THEN
          rfv$rhfam_event_table.first_entry := current_entry_p^.next_entry;
        ELSE
          previous_entry_p^.next_entry := current_entry_p^.next_entry;
        IFEND;
        FREE event IN nav$network_paged_heap^;
        EXIT /remove_event/;
      IFEND;
      previous_entry_p := current_entry_p;
      current_entry_p := current_entry_p^.next_entry;
    WHILEND /remove_event/;
    rfp$unlock_table(rfv$rhfam_event_table.lock);

  PROCEND remove_data_transfer_event;
?? TITLE := '    rfp$remove_connection', EJECT ??
  PROCEDURE [XDCL] rfp$remove_connection (
         response_seq_number: integer;
     VAR connection_entry_p: ^rft$connection_entry);

{     The purpose of this procedure is to remove the connection entry from
{     this jobs connection table. This procedure is called as the result of
{     a disconnect lcn path request. If the application that this connection
{     is assigned to is of type server or partner, the number of current
{     connections assigned to this server is decremented.
{
{     RESPONSE_SEQ_NUMBER: (input) This paramter specifies the sequence
{       number of the disconnect response that is being processed.
{
{     CONNECTION_ENTRY_P: (input,output) This parameter specifies the
{       connection to remove.  On completion, this parameter is
{       set to NIL;


    VAR
      application_kind: rft$application_kinds,
      application_name: rft$application_name,
      client_entry_p: ^rft$rhfam_client_table_entry,
      connection_status: rft$connection_status,
      job_table_entry_p: ^rft$rhfam_job_table_entry,
      local_status: ost$status,
      new_entry: boolean,
      server_entry_p: ^rft$rhfam_server_table_entry;


    rfp$lock_job_table_entry (FALSE, new_entry, job_table_entry_p);
    rfp$lock_table (connection_entry_p^.lock);
    application_kind := connection_entry_p^.application_entry_p^.application_kind;
    application_name := connection_entry_p^.application_entry_p^.application_name;

    remove_connection_entry_p (response_seq_number, connection_entry_p);
    connection_status := connection_entry_p^.connection_attributes.connection_status;

    remove_connection_entry (connection_entry_p);
    job_table_entry_p^.lock := tmv$null_global_task_id;

    IF connection_status.connection_state < rfc$not_viable THEN
      CASE application_kind OF
      = rfc$server =
        rfp$lock_table (rfv$rhfam_server_table.lock);
        find_server_entry (application_name, FALSE, server_entry_p, local_status);
        IF local_status.normal THEN
          server_entry_p^.current_connections := server_entry_p^.current_connections - 1;
        IFEND;
        rfp$unlock_table (rfv$rhfam_server_table.lock);
      = rfc$client =
        rfp$lock_table (rfv$rhfam_client_table.lock);
        rfp$find_client_entry (application_name, FALSE, client_entry_p, local_status);
        IF local_status.normal THEN
          client_entry_p^.current_connections := client_entry_p^.current_connections - 1;
        IFEND;
        rfp$unlock_table (rfv$rhfam_client_table.lock);
      = rfc$partner =
        rfp$lock_table (rfv$rhfam_server_table.lock);
        find_server_entry (application_name, FALSE, server_entry_p, local_status);
        IF local_status.normal THEN
          server_entry_p^.current_connections := server_entry_p^.current_connections - 1;
          server_entry_p^.partner_job_connections := server_entry_p^.partner_job_connections - 1;
          rfp$unlock_table (rfv$rhfam_server_table.lock);
        ELSE
          rfp$unlock_table (rfv$rhfam_server_table.lock);
          rfp$lock_table (rfv$rhfam_client_table.lock);
          rfp$find_client_entry (application_name, FALSE, client_entry_p, local_status);
          IF local_status.normal THEN
            client_entry_p^.current_connections := client_entry_p^.current_connections - 1;
          IFEND;
          rfp$unlock_table (rfv$rhfam_client_table.lock);
        IFEND;
      ELSE
        ;
      CASEND;
    IFEND;

  PROCEND rfp$remove_connection;
?? TITLE := '    remove_connection_entry', EJECT ??
  PROCEDURE  remove_connection_entry (
    VAR connection_entry_p: ^rft$connection_entry);

{     The purpose of this procedure is to delink and free the specified
{     connection entry data structure.
{
{     CONNECTION_ENTRY_P: (input,output) This parameter specifies a pointer
{       to the connection entry to remove.  This parameter is set to NIL
{       upon return.


    VAR
      current_entry_p: ^rft$connection_entry,
      previous_entry_p: ^rft$connection_entry;


    previous_entry_p := NIL;
    current_entry_p := connection_entry_p^.application_entry_p^.connection_table;
    WHILE current_entry_p <> NIL DO
      IF current_entry_p^.connection_name =
            connection_entry_p^.connection_name THEN
        IF previous_entry_p = NIL THEN
          connection_entry_p^.application_entry_p^.connection_table :=
                current_entry_p^.next_entry;
        ELSE
          previous_entry_p^.next_entry := current_entry_p^.next_entry;
        IFEND;
        connection_entry_p^.application_entry_p^.number_of_active_connections :=
              connection_entry_p^.application_entry_p^.number_of_active_connections - 1;
        IF connection_entry_p^.residue_input_data <> NIL THEN
          FREE connection_entry_p^.residue_input_data IN nav$network_paged_heap^;
        IFEND;
        IF connection_entry_p^.waiting_tasks <> NIL THEN
          wakeup_waiting_tasks (connection_entry_p);
        IFEND;

{     The old connection entry is unlocked which also decrements the subsystem
{     activity count.

        rfp$unlock_table (connection_entry_p^.lock);
        FREE connection_entry_p IN nav$network_paged_heap^;
        RETURN;
      IFEND;
      previous_entry_p := current_entry_p;
      current_entry_p := current_entry_p^.next_entry;
    WHILEND ;

  PROCEND remove_connection_entry;
?? TITLE := '    remove_connection_entry_p', EJECT ??
  PROCEDURE remove_connection_entry_p (
        response_seq_number: integer;
        connection_entry_p: ^rft$connection_entry);

{
{     The purpose of this procedure is to remove the connection entry pointer
{     from the local nad table. If the connection state is rfc$not_viable or
{     greater, then the number of active connections and the connection
{     entry pointer have been removed from the status table connection entry
{     by the system task.
{
{     RESPONSE_SEQ_NUMBER: (input) This paramter specifies the sequence
{       number of the disconnect response that is being processed.
{
{     CONNECTION_ENTRY_P: (input) This parameter specifies a pointer to the
{       connection entry that is to be removed.
{


    VAR
      locked: boolean,
      locks_set: boolean,
      nad_index: rft$local_nads;

    nad_index := connection_entry_p^.connection_descriptor.nad_index;
    locks_set := FALSE;
  /lock_tables/
    REPEAT
      IF connection_entry_p^.connection_attributes.connection_status.connection_state <
            rfc$not_viable THEN
        rfp$test_set_table_lock (rfv$status_table.local_nads^[nad_index].
              connection_table_lock, locked);
        IF NOT locked THEN
          rfp$unlock_table (connection_entry_p^.lock);
          syp$cycle;
          rfp$lock_table (connection_entry_p^.lock);
        ELSE
          locks_set := TRUE;
        IFEND;
      ELSE
        EXIT remove_connection_entry_p;
      IFEND;
    UNTIL locks_set;

    rfv$status_table.local_nads^[nad_index].connections_established :=
          rfv$status_table.local_nads^[nad_index].connections_established - 1;
    rfv$status_table.local_nads^[nad_index].connection_table^[connection_entry_p^.
          connection_descriptor.network_path].connection_table_entry := NIL;
    rfv$status_table.local_nads^[nad_index].connection_table^[connection_entry_p^.
          connection_descriptor.network_path].processing_incoming_connect := FALSE;
    IF response_seq_number >
          rfv$status_table.local_nads^[nad_index].last_status_seq_number THEN
      rfv$status_table.local_nads^[nad_index].connection_table^[connection_entry_p^.
             connection_descriptor.network_path].connection_state := rfc$ps_unused;
      rfv$status_table.local_nads^[nad_index].connection_table^[connection_entry_p^.
            connection_descriptor.network_path].connection_clarifier := rfc$pcu_empty;
    IFEND;
    rfp$unlock_table(rfv$status_table.local_nads^[nad_index].connection_table_lock);

  PROCEND remove_connection_entry_p;
?? TITLE := '    remove_job_table_entry', EJECT ??
  PROCEDURE remove_job_table_entry(
    VAR job_table_entry_p: ^rft$rhfam_job_table_entry);


{
{     The purpose of this procedure is to remove the specified rhfam job
{     table entry from the list of rhfam job table entries.
{
{     JOB_TABLE_ENTRY_P: (input, output) This parameter specifies a pointer
{       to the job table entry to be removed.  This routine assumes that the
{       corresponding job table entry has been locked by the calling procedure.
{       Upon return this parameter is set to NIL.



    VAR
      current_entry_p: ^rft$rhfam_job_table_entry,
      previous_entry_p: ^rft$rhfam_job_table_entry;


    rfp$lock_table(rfv$rhfam_job_table.lock);
    previous_entry_p := NIL;
    current_entry_p := rfv$rhfam_job_table.first_entry;
    WHILE current_entry_p <> NIL DO
      IF current_entry_p^.job_name = job_table_entry_p^.job_name THEN
        IF previous_entry_p = NIL THEN
          rfv$rhfam_job_table.first_entry := current_entry_p^.next_entry;
        ELSE
          previous_entry_p^.next_entry := current_entry_p^.next_entry;
        IFEND;
        IF  current_entry_p = rfv$rhfam_job_table.last_entry  THEN
          rfv$rhfam_job_table.last_entry := previous_entry_p;
        IFEND;
        rfv$job_entry_pointer := NIL;
        rfp$unlock_table(rfv$rhfam_job_table.lock);
        FREE job_table_entry_p IN nav$network_paged_heap^;
        RETURN;
      IFEND;
      previous_entry_p := current_entry_p;
      current_entry_p := current_entry_p^.next_entry;
    WHILEND;
    rfv$job_entry_pointer := NIL;
    job_table_entry_p := NIL;
    rfp$unlock_table(rfv$rhfam_job_table.lock);
  PROCEND remove_job_table_entry;
?? TITLE := '    remove_switch_offer', EJECT ??
  PROCEDURE remove_switch_offer (job_name: jmt$system_supplied_name;
    VAR connection_entry_p: ^rft$connection_entry);

{
{     The purpose of this procedure is to remove a connection from the
{     switched connection queue and reset the connection status to
{     connected. The switched connection is located, delinked and the
{     data structure is released.
{
{     JOB_NAME (input): This parameter specifies the job name of the
{       connection to remove from the switched queue.
{
{     CONNECTION_ENTRY_P: (input,output) This parameter specifies the
{       connection to remove from the switched queue.



    VAR
      previous_entry: ^rft$switched_connection,
      switched_connection: ^rft$switched_connection;


    rfp$lock_table (rfv$switched_connection_queue.lock);
    previous_entry := NIL;
    switched_connection := rfv$switched_connection_queue.first_entry;
  /find_switched_connection/
    WHILE switched_connection <> NIL DO
      IF (job_name = switched_connection^.source_job) AND
         (connection_entry_p^.connection_name =
          switched_connection^.connection_entry_p^.connection_name) THEN
        EXIT /find_switched_connection/;
      IFEND;
      previous_entry := switched_connection;
      switched_connection := switched_connection^.next_entry;
    WHILEND /find_switched_connection/;

    IF switched_connection <> NIL THEN
      IF previous_entry = NIL THEN
        rfv$switched_connection_queue.first_entry := switched_connection^.next_entry;
      ELSE
        previous_entry^.next_entry := switched_connection^.next_entry;
      IFEND;

{     Remove placeholder connection entry from source job.

      delink_connection_entry (connection_entry_p);
      FREE connection_entry_p IN nav$network_paged_heap^;

{     Switch connection entry pointer to active connection entry.

      connection_entry_p := switched_connection^.connection_entry_p;
      rfp$lock_table (connection_entry_p^.lock);

{     Relink active connection entry into connections for source job.

      connection_entry_p^.next_entry :=
            connection_entry_p^.application_entry_p^.connection_table;
      connection_entry_p^.application_entry_p^.connection_table :=
            connection_entry_p;
      FREE switched_connection IN nav$network_paged_heap^;
    IFEND;

    rfp$unlock_table (rfv$switched_connection_queue.lock);

  PROCEND remove_switch_offer;
?? TITLE := '    rfp$remove_waits', EJECT ??
  PROCEDURE [XDCL] rfp$remove_waits;

{
{     The purpose of this procedure is to delink and free events from the
{     event queue for the presently executing task.
{


    VAR
      current_entry_p: ^rft$rhfam_event_table_entry,
      free_entry: ^rft$rhfam_event_table_entry,
      global_task_id: ost$global_task_id,
      previous_entry_p: ^rft$rhfam_event_table_entry;


    previous_entry_p := NIL;
    pmp$get_executing_task_gtid (global_task_id);
    rfp$lock_table(rfv$rhfam_event_table.lock);
    current_entry_p := rfv$rhfam_event_table.first_entry;
  /remove_wait/
    WHILE current_entry_p <> NIL DO
      IF (current_entry_p^.task_id = global_task_id) THEN
        IF ((current_entry_p^.event_kind <> rfc$ana_await_connection_event) OR
           ((current_entry_p^.event_kind = rfc$ana_await_connection_event) AND
            (NOT current_entry_p^.ace_asynchronous_wait))) THEN
          IF previous_entry_p = NIL THEN
            rfv$rhfam_event_table.first_entry := current_entry_p^.next_entry;
          ELSE
            previous_entry_p^.next_entry := current_entry_p^.next_entry;
          IFEND;
          free_entry := current_entry_p;
          current_entry_p := current_entry_p^.next_entry;
          FREE free_entry IN nav$network_paged_heap^;
          CYCLE /remove_wait/;
        IFEND;
      IFEND;
      previous_entry_p := current_entry_p;
      current_entry_p := current_entry_p^.next_entry;
    WHILEND /remove_wait/;
    rfp$unlock_table(rfv$rhfam_event_table.lock);

  PROCEND rfp$remove_waits;
?? TITLE := '    request_lcn_connection', EJECT ??
  PROCEDURE request_lcn_connection (connection_entry_p: ^rft$connection_entry;
        connect_request: ^rft$nbp_outgoing_connect;
    VAR status: ost$status);

{
{     The purpose of this request is to build and queue the pp request to
{     request an lcn connection.  This routine assumes that the connection
{     entry is locked upon entry.
{
{     NOTE: This routine unlocks the connection entry before exit.
{
{     CONNECTION_ENTRY_P: (input) This parameter specifies a pointer to
{       the connection entry pointer that the lcn connection is to be made
{       for.
{
{     CONNECT_REQUEST: (input) This parameter specifies a pointer to the
{       network block protocal that is to be used to request the connection.
{
{     STATUS: (output) This parameter returns the results of the request.
{       A status of normal indicates that the request connection was
{       successfully completed.


    VAR
      activity_status: ^ost$activity_status,
      command_identifier: ^rft$logical_commands,
      connect_request_p: ^rft$nbp_outgoing_connect,
      maintenance_connection: ^boolean,
      nad_index: rft$local_nads,
      request_info: ^SEQ (* ),
      unit_request_status: ^rft$connection_mgmt_status;


    /request_connection/
      BEGIN
        PUSH request_info: [[rft$logical_commands,   {command identifier}
              boolean,                               {maintenance connection}
              rft$nbp_outgoing_connect]];            {outgoing connect message}
        RESET request_info;
        NEXT command_identifier  IN  request_info;
        IF  command_identifier = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err,
                'the request overflowed the request sequence', status);
          osp$append_status_parameter(osc$status_parameter_delimiter,
                'rfp$request_connection', status);
          EXIT  /request_connection/;
        IFEND;
        command_identifier^ := rfc$lc_request_connection;
        NEXT  maintenance_connection  IN  request_info;
        IF  maintenance_connection = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err,
                'the request overflowed the request sequence', status);
          osp$append_status_parameter(osc$status_parameter_delimiter,
                'rfp$request_connection', status);
          EXIT  /request_connection/;
        IFEND;
        maintenance_connection^ := FALSE;
        NEXT  connect_request_p IN  request_info;
        IF  connect_request_p = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err,
                'the request overflowed the request sequence', status);
          osp$append_status_parameter(osc$status_parameter_delimiter,
                'rfp$request_connection', status);
          EXIT  /request_connection/;
        IFEND;
        connect_request_p^ := connect_request^;
        ALLOCATE unit_request_status IN osv$task_private_heap^;
        IF  unit_request_status = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted,
                'task private', status);
          osp$append_status_parameter(osc$status_parameter_delimiter,
                'rfp$request_connection', status);
          EXIT  /request_connection/;
        IFEND;
        unit_request_status^.internal_use := FALSE;
        unit_request_status^.connection := connection_entry_p;

{     The structure activity status is allocated in task private to insure
{     it is writeable by ring 3 code. Pointers to this variable are stored in
{     a task private segment and thus inherit ring 3 privileges.

        ALLOCATE activity_status IN osv$task_private_heap^;
        IF  activity_status = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted,
                'task private', status);
          osp$append_status_parameter(osc$status_parameter_delimiter,
                'rfp$request_connection', status);
          EXIT  /request_connection/;
        IFEND;
        unit_request_status^.activity_status := activity_status;
        activity_status^.complete := FALSE;
        activity_status^.status.normal := TRUE;
        nad_index := connection_entry_p^.connection_descriptor.nad_index;
        connection_entry_p^.active_pp_requests := connection_entry_p^.active_pp_requests + 1;
        rfp$unlock_table (connection_entry_p^.lock);
        rfp$queue_request(nad_index, 1, rfc$unit_request, rfc$rk_request_connection,
              unit_request_status, request_info, status);
        IF  NOT status.normal  THEN
          rfp$lock_table (connection_entry_p^.lock);
          connection_entry_p^.active_pp_requests :=
                connection_entry_p^.active_pp_requests - 1;
          EXIT  /request_connection/;
        IFEND;
        REPEAT
          #SPOIL (activity_status^);
          pmp$wait (rfc$unit_request_wait_time,rfc$ur_expected_wait);
          rfp$process_pp_response_flag (rfc$pp_response_available);
        UNTIL activity_status^.complete;
        IF NOT activity_status^.status.normal THEN
          status := activity_status^.status;
        IFEND;
        FREE activity_status IN osv$task_private_heap^;
        EXIT request_lcn_connection;
      END /request_connection/;

      IF NOT status.normal THEN
        rfp$unlock_table (connection_entry_p^.lock);
      IFEND;

  PROCEND request_lcn_connection;
?? TITLE := '    reset_data_buffer', EJECT ??
  PROCEDURE reset_data_buffer (data_transfer_status: ^rft$data_transfer_status);

{
{     The purpose of this procedure is to reset a data transfer request.
{     Data is queued to be sent to the network and conditions may exist
{     that cause the data to not be sent at the present time.  This routine
{     resets the data transfer such that when the data transfer is
{     continued, the blocks that were queued and not sent are requeued.
{
{     DATA_TRANSFER_STATUS: (input,output) This parameter specifies the
{       data transfer to be reset.  The appropriate fields in this structure
{       are updated upon return.



    VAR
      block_descriptor_out: rft$outstanding_blocks;

    block_descriptor_out := data_transfer_status^.block_descriptor_out;
    data_transfer_status^.next_to_queue_index := data_transfer_status^.
          complete_index;
    data_transfer_status^.next_to_queue_offset := data_transfer_status^.
          complete_offset;
    data_transfer_status^.next_to_queue_abn := data_transfer_status^.
          block_descriptors^[block_descriptor_out].block_sequence_number;
    data_transfer_status^.data_exhausted := FALSE;
    data_transfer_status^.total_blocks_queued := 0;
    data_transfer_status^.block_descriptor_in := block_descriptor_out;
    data_transfer_status^.switch_to_wired_buffers := FALSE;


  PROCEND reset_data_buffer;
?? TITLE := '    reset_next_to_queue', EJECT ??
  PROCEDURE reset_next_to_queue (data_shortage: rft$data_length;
    VAR data_transfer_status: ^rft$data_transfer_status);

{
{     The purpose of this procedure is to reset the next to queue index
{     and offset to account for a short network block that has been
{     received.  This index must be backed up so that the end of the
{     data fragment buffer can be correctly detected. This routine assumes
{     that the receive buffer is not full and that the complete pointers
{     are valid.
{
{     DATA_SHORTAGE: (input) This parameter specifies the number of bytes
{       of data shortage that occurred.
{
{     DATA_TRANSFER_STATUS: (input,output) This parameter specifies the
{       parameters for the data transfer request.


    VAR
      data_bytes_short: rft$data_length,
      offset_differential: integer;


      data_bytes_short := data_shortage;
      IF data_transfer_status^.data_exhausted THEN
        IF data_transfer_status^.total_blocks_queued = 0 THEN
          data_transfer_status^.next_to_queue_index := data_transfer_status^.complete_index;
          data_transfer_status^.next_to_queue_offset := data_transfer_status^.complete_offset;
          data_transfer_status^.data_exhausted := FALSE;
        IFEND;
      ELSE
        WHILE data_bytes_short > 0 DO
          offset_differential := data_transfer_status^.next_to_queue_offset - data_bytes_short;
          IF offset_differential >= 0 THEN
            data_bytes_short := 0;
            data_transfer_status^.next_to_queue_offset := offset_differential;
          ELSE
            IF data_transfer_status^.data_area^[data_transfer_status^.next_to_queue_index].
                  length <> 0 THEN
              data_bytes_short := data_bytes_short - data_transfer_status^.next_to_queue_offset - 1;
              data_transfer_status^.next_to_queue_index :=
                    data_transfer_status^.next_to_queue_index - 1;
              IF data_transfer_status^.data_area^[data_transfer_status^.next_to_queue_index].
                    length <> 0 THEN
                data_transfer_status^.next_to_queue_offset :=
                      data_transfer_status^.data_area^[data_transfer_status^.
                      next_to_queue_index].length - 1;
              ELSE
                data_transfer_status^.next_to_queue_offset := 0;
              IFEND;
            ELSE
              data_transfer_status^.next_to_queue_index :=
                    data_transfer_status^.next_to_queue_index - 1;
            IFEND;
          IFEND;
        WHILEND;
        data_transfer_status^.data_exhausted := FALSE;
      IFEND;

  PROCEND reset_next_to_queue;
?? TITLE := '    restart_data_transfer', EJECT ??
  PROCEDURE restart_data_transfer(current_request: ^rft$outstanding_requests;
        termination_mark: rft$record_marks;
    VAR blocks_to_add: rft$outstanding_blocks;
    VAR status: ost$status);

{
{     The purpose of this procedure is to restart a data transfer after it
{     has been suspended either because of a resource limit condition in the
{     NAD or after suspending a data transfer on a record mark termination
{     that is of less priority than that specified on the receive data call.
{
{     CURRENT_REQUEST: (input) This parameter specifies a pointer to the
{       request that is to be restarted.
{
{     TERMINATION_MARK: (input) This parameter specifies the termination mark
{       to be used for the data transfer.
{
{     BLOCKS_TO_ADD: (input,output) This parameter specifies the number of
{       network blocks to add to the pp unit request. Upon return this parameter
{       returns the number of blocks added to the request.
{
{     STATUS: (output) This parameter returns the status of the request.



    VAR
      data_transfer_status: ^rft$data_transfer_status,
      done: boolean,
      nad_index: rft$local_nads,
      unit_request: ^SEQ (  * );



    data_transfer_status := current_request^.request_status;
    PUSH unit_request: [[rft$logical_commands, rft$transfer_mode, boolean,
          rft$path_identifier,
          BOOLEAN,
                { intermediate response flag }
          rft$command_entry,
                { block count }
          REP data_transfer_status^.maximum_outstanding_blocks OF rft$command_entry,
                { fragment count }
          REP (data_transfer_status^.maximum_outstanding_blocks * 4) OF rft$io_fragment]];
                { assume maximum of 4 fragments per block }
    RESET unit_request;
    build_transfer_request_header (data_transfer_status, data_transfer_status^.termination_mark,
          unit_request, status);
    IF  NOT status.normal THEN
      EXIT  restart_data_transfer;
    IFEND;

    add_blocks_to_request (data_transfer_status, TRUE, blocks_to_add,
          unit_request, status);
    IF NOT status.normal THEN
      EXIT restart_data_transfer;
    IFEND;
    RESET unit_request;

    data_transfer_status^.present_r1_out_ptr := rfc$cbi_first_io_entry;
    rfp$lock_table (data_transfer_status^.connection_entry_p^.lock);
    IF data_transfer_status^.connection_entry_p^.connection_attributes.
          connection_status.connection_state = rfc$connected THEN
      IF data_transfer_status^.outstanding_control_messages <> NIL THEN
        queue_control_messages (data_transfer_status^.connection_entry_p^.connection_descriptor.
              nad_index, data_transfer_status^.outstanding_control_messages);
      IFEND;
      nad_index := data_transfer_status^.connection_entry_p^.
            connection_descriptor.nad_index;
      rfp$unlock_table (data_transfer_status^.connection_entry_p^.lock);

      done := FALSE;
      REPEAT
        rfp$lock_table (rfv$status_table.lock);
        IF (NOT rfv$status_table.system_task_is_up) OR
           (rfv$status_table.local_nads^[nad_index].current_status.device_status <> rfc$es_on) THEN
          osp$set_status_abnormal (rfc$product_id, rfe$local_nad_down, 'to the NAD', status);
          done := TRUE;
        ELSEIF rfv$status_table.local_nads^[nad_index].requests_posted <
              rfc$max_concurrent_requests THEN
          rfv$status_table.local_nads^[nad_index].requests_posted :=
                rfv$status_table.local_nads^[nad_index].requests_posted + 1;
          done := TRUE;
        ELSE
          rfp$unlock_table (rfv$status_table.lock);
          syp$cycle;
          current_request^.processing_request := TRUE;
          rfp$process_pp_response_flag (rfc$pp_response_available);
          current_request^.processing_request := FALSE;
        IFEND;
      UNTIL done;
      rfp$unlock_table (rfv$status_table.lock);
      IF NOT status.normal THEN
        EXIT restart_data_transfer;
      IFEND;

      rfp$post_request (unit_request, current_request^.request_id, status);
      IF NOT status.normal THEN
        rfp$lock_table (rfv$status_table.lock);
          rfv$status_table.local_nads^[nad_index].requests_posted :=
                rfv$status_table.local_nads^[nad_index].requests_posted - 1;
        rfp$unlock_table (rfv$status_table.lock);
      ELSE
        data_transfer_status^.total_blocks_queued := blocks_to_add;
        data_transfer_status^.next_to_queue_abn := data_transfer_status^.current_abn;
        data_transfer_status^.next_to_queue_index := data_transfer_status^.current_fragment_index;
        data_transfer_status^.next_to_queue_offset := data_transfer_status^.current_fragment_offset;
        current_request^.posted := TRUE;
        advise_out_in (data_transfer_status, data_transfer_status^.previous_error);
      IFEND;
    ELSE
      set_connection_status (data_transfer_status^.connection_entry_p, status);
      rfp$unlock_table (data_transfer_status^.connection_entry_p^.lock);
      delete_control_messages (data_transfer_status^.outstanding_control_messages);
    IFEND;

  PROCEND restart_data_transfer;
?? TITLE := '    rfp$return_lid_type', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$return_lid_type (
        lid_name: rft$logical_identifier;
    VAR lid_type: rft$type_of_lid;
    VAR status: ost$status);

*copyc rfh$return_lid_type

?? NEWTITLE := '      terminate_return_lid_type - condition handler', EJECT ??
    PROCEDURE terminate_return_lid_type (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$return_lid_type;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$return_lid_type;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_return_lid_type;
?? OLDTITLE, EJECT ??


    VAR
      lid_index: ost$non_negative_integers,
      remote_host: ^rft$remote_host_definition,
      temp_lid: rft$logical_identifier,
      temp_type: rft$type_of_lid;

    status.normal := TRUE;
    temp_lid := lid_name;
    temp_type := rfc$unknown_logical_id;
    osp$establish_condition_handler (^terminate_return_lid_type, FALSE);
    rfp$lock_table (rfv$status_table.lock);

  /find_lid/
    BEGIN
      IF rfv$status_table.system_task_is_up THEN
        IF rfv$status_table.local_host^.physical_identifier = temp_lid THEN
          temp_type := rfc$local_physical_id;
          EXIT /find_lid/;
        ELSE
          FOR lid_index := 1 TO UPPERBOUND (rfv$status_table.local_host^.logical_identifiers) DO
            IF rfv$status_table.local_host^.logical_identifiers [lid_index].logical_id = temp_lid THEN
              temp_type := rfc$local_logical_id;
              EXIT /find_lid/;
            IFEND;
          FOREND;

          remote_host := rfv$status_table.remote_hosts;
          WHILE remote_host <> NIL DO
            IF remote_host^.physical_identifier = temp_lid THEN
              temp_type := rfc$remote_physical_id;
              EXIT /find_lid/;
            ELSE
              FOR lid_index := 1 TO UPPERBOUND (remote_host^.logical_identifiers) DO
                IF remote_host^.logical_identifiers [lid_index].logical_id = temp_lid THEN
                  temp_type := rfc$remote_logical_id;
                  EXIT /find_lid/;
                IFEND;
              FOREND;
            IFEND;
            remote_host := remote_host^.next_entry;
          WHILEND;
        IFEND;
      IFEND;
    END /find_lid/;

    rfp$unlock_table (rfv$status_table.lock);
    lid_type := temp_type;
  PROCEND rfp$return_lid_type;
?? TITLE := '    save_residue_data', EJECT ??
  PROCEDURE save_residue_data (data_transfer_status: ^rft$data_transfer_status;
        remaining_block_size: rft$block_size;
        wired_buffer_index: rft$buffer_count;
    VAR status: ost$status);

{
{     The purpose of this routine is to save any residue data that has been
{     received from the NAD but could not be delivered to the user because
{     of a buffer full condition.  Data is read in complete blocks from the
{     NAD.  If a buffer full is detected, any remaining data is moved
{     (at most a network block - 1) to the network paged section to be saved
{     until it can be delivered on the next receive data.
{
{     DATA_TRANSFER_STATUS: (input) This parameter specifies the parameters
{       of the data transfer.
{
{     REMAINING_BLOCK_SIZE: (input) This parameter specifies the amount
{       of data that is to be saved.
{
{     WIRED_BUFFER_INDEX: (input) This parameter specifies the index of
{       the wired buffer that contains the start of the data.
{
{     STATUS: (output) This parameter returns the status of the request.
{       A status of normal indicates that the data was saved.



    VAR
      buffer_index: rft$buffer_count,
      data_count: rft$bytes_transferred,
      data: ^SEQ ( * ),
      data_p: ^cell,
      residue_data: ^rft$residue_data;

    status.normal := TRUE;
    ALLOCATE residue_data: [[REP remaining_block_size OF CELL]] IN nav$network_paged_heap^;
    IF residue_data = NIL THEN
      osp$set_status_abnormal (rfc$product_id, rfe$heap_exhausted,
            'network paged', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            'save_residue_data', status);
      EXIT save_residue_data;
    IFEND;

    residue_data^.remaining_data := remaining_block_size;
    residue_data^.record_mark_encountered := FALSE;

    residue_data^.data_pointer := ^residue_data^.data;
    RESET residue_data^.data_pointer;
    NEXT data: [[REP remaining_block_size OF CELL]] IN residue_data^.data_pointer;
    data_count := remaining_block_size;
    buffer_index := wired_buffer_index;
    data_p := data;
    rfp$move_data_from_wired_buffs (data_transfer_status^.reserved_buffer_list^, data_p,
          data_transfer_status^.reserved_buffer_count, buffer_index,
          data_count);
    RESET residue_data^.data_pointer;

    rfp$lock_table (data_transfer_status^.connection_entry_p^.lock);
    data_transfer_status^.connection_entry_p^.residue_input_data := residue_data;
    rfp$unlock_table (data_transfer_status^.connection_entry_p^.lock);
  PROCEND save_residue_data;
?? TITLE := '    search_for_path', EJECT ??
  PROCEDURE search_for_path (server_name: rft$application_name;
        destination_host: rft$host_identifier;
        server_available_locally: boolean;
    VAR selected_path_p: ^rft$lcn_path_definition;
    VAR selected_pid: rft$physical_identifier;
    VAR host_identifiers: ^rft$destination_hosts;
    VAR number_of_hosts: rft$number_of_hosts;
    VAR map_lid_to_pid: boolean;
    VAR status: ost$status);


{     The purpose of this procedure is to search the local configuration
{     file for a path definition to a remote host.
{
{     SERVER_NAME: (input) This parameter specifies the server name that
{       must be present on the remote host.
{
{     DESTINATION_HOST: (input) This parameter specifies the remote host
{       to search for.
{
{     SERVER_AVAILABLE_LOCALLY: (input) This parameter specifies if the
{       requested server is available locally.
{
{     SELECTED_PATH_P: (output) This parameter returns a pointer to the
{       selected path. This parameter is not meaningful if status is not
{       normal.
{
{     SELECTED_PID: (output) This parameter returns the physical identifier
{       of the remote host choosen.
{
{     HOST_IDENTIFIERS: (output) This parameter returns an array of the
{       physical identifiers that match the specified logical identifier
{       and server name.  This parameter is returned whether the elements
{       are 'on' or 'off'
{
{     NUMBER_OF_HOSTS: (output) This parameter returns the number of hosts
{       that match on server name and destination host.
{
{     MAP_LID_TO_PID: (output) This parameter returns the lid to pid
{       mapping status for the specified lid. A status of TRUE indicates
{       that the PID should be used in the connection request message.
{
{     STATUS: (output) This parameter returns the status of the search.
{       A status of normal means that a path has been found and it is
{       operational.



    VAR
      associated_paths_p: ^rft$lcn_paths,
      earliest_connect_time: integer,
      index: integer,
      least_number_of_connects: rft$concurrent_connections,
      local_host_p: ^rft$local_host_definition,
      logical_id_index: integer,
      path_enabled: boolean,
      path_index: integer,
      remote_host_p: ^rft$remote_host_definition,
      remote_host_defined: boolean,
      remote_host_enabled: boolean,
      remote_host_matches: boolean,
      remote_lid_enabled: boolean,
      remote_path_defined: boolean,
      remote_server_defined: boolean;



    status.normal := TRUE;
    selected_path_p := NIL;
    remote_host_defined := FALSE;
    remote_host_enabled := FALSE;
    remote_server_defined := FALSE;
    remote_path_defined := FALSE;
    number_of_hosts := 0;
    earliest_connect_time := UPPERVALUE(INTEGER);
    least_number_of_connects := UPPERVALUE(rft$concurrent_connections);


    remote_host_p := rfv$status_table.remote_hosts;
    /locate_remote_path/
      WHILE remote_host_p <> NIL DO
        remote_host_matches := FALSE;
        remote_lid_enabled := TRUE;
        CASE destination_host.host_identifier_kind OF
        = rfc$physical_identifier =
          IF remote_host_p^.physical_identifier = destination_host.
                physical_identifier THEN
            remote_host_matches := TRUE;
          IFEND;
        = rfc$logical_identifier =
          /check_for_remote_lid/
          FOR logical_id_index := 1 TO UPPERBOUND (remote_host_p^.logical_identifiers) DO
            IF destination_host.logical_identifier = remote_host_p^.
                  logical_identifiers[logical_id_index].logical_id THEN
              remote_host_matches := TRUE;
              IF remote_host_p^.logical_identifiers[logical_id_index].disabled THEN
                remote_lid_enabled := FALSE;
              ELSE
                map_lid_to_pid := remote_host_p^.logical_identifiers[logical_id_index].
                      map_lid_to_pid;
              IFEND;
              EXIT /check_for_remote_lid/;
            IFEND;
          FOREND /check_for_remote_lid/;
        CASEND;
        IF remote_host_matches THEN
          remote_host_defined := TRUE;
          remote_server_defined := TRUE;
          number_of_hosts := number_of_hosts + 1;
          IF number_of_hosts <= UPPERBOUND(host_identifiers^) THEN
            host_identifiers^[number_of_hosts].host_identifier_kind := rfc$physical_identifier;
            host_identifiers^[number_of_hosts].physical_identifier :=
                  remote_host_p^.physical_identifier;
          IFEND;
          IF (remote_lid_enabled) AND
             (NOT remote_host_p^.disabled) THEN
            remote_host_enabled := TRUE;
            associated_paths_p := remote_host_p^.associated_paths;
            IF associated_paths_p <> NIL THEN
              remote_path_defined := TRUE;
              FOR path_index := 1 TO UPPERBOUND (associated_paths_p^) DO
                determine_path_state (^associated_paths_p^[path_index], path_enabled);
                IF path_enabled THEN
                  IF rfv$status_table.local_nads^[associated_paths_p^[path_index].local_nad].
                        connections_established <= least_number_of_connects THEN
                    IF associated_paths_p^[path_index].last_attempted_connect <
                          earliest_connect_time THEN
                      selected_path_p := ^associated_paths_p^ [path_index];
                      selected_pid := remote_host_p^.physical_identifier;
                      earliest_connect_time := selected_path_p^.last_attempted_connect;
                      least_number_of_connects := rfv$status_table.local_nads^
                            [selected_path_p^.local_nad].connections_established;
                    IFEND;
                  IFEND;
                IFEND;
              FOREND;
            IFEND;
          IFEND;
        IFEND;
        remote_host_p := remote_host_p^.next_entry;
      WHILEND /locate_remote_path/;

    /locate_local_path/
      BEGIN
        local_host_p := rfv$status_table.local_host;
        remote_host_matches := FALSE;
        remote_lid_enabled := TRUE;
        CASE destination_host.host_identifier_kind OF
        = rfc$physical_identifier =
          IF local_host_p^.physical_identifier = destination_host.
                physical_identifier THEN
            remote_host_matches := TRUE;
          IFEND;
        = rfc$logical_identifier =
          /check_for_local_lid/
          FOR index := 1 TO UPPERBOUND (local_host_p^.logical_identifiers) DO
            IF destination_host.logical_identifier = local_host_p^.
                  logical_identifiers[index].logical_id THEN
              remote_host_matches := TRUE;
              IF local_host_p^.logical_identifiers[index].disabled THEN
                remote_lid_enabled := FALSE;
              ELSE
                map_lid_to_pid := local_host_p^.logical_identifiers[index].
                      map_lid_to_pid;
              IFEND;
              EXIT /check_for_local_lid/;
            IFEND;
          FOREND /check_for_local_lid/;
        CASEND;
        IF remote_host_matches THEN
          remote_host_defined := TRUE;
          IF server_available_locally THEN
            remote_server_defined := TRUE;
            number_of_hosts := number_of_hosts + 1;
            IF number_of_hosts <= UPPERBOUND(host_identifiers^) THEN
              host_identifiers^[number_of_hosts].host_identifier_kind := rfc$physical_identifier;
              host_identifiers^[number_of_hosts].physical_identifier :=
                    rfv$status_table.local_host^.physical_identifier;
            IFEND;
            IF selected_path_p = NIL THEN
              IF (remote_lid_enabled) AND
                 (NOT local_host_p^.disabled) THEN
                remote_host_enabled := TRUE;
                associated_paths_p := local_host_p^.associated_paths;
                IF associated_paths_p <> NIL THEN
                  remote_path_defined := TRUE;
                  FOR path_index := 1 TO UPPERBOUND (associated_paths_p^) DO
                    determine_path_state (^associated_paths_p^[path_index], path_enabled);
                    IF path_enabled THEN
                      IF rfv$status_table.local_nads^[associated_paths_p^[path_index].local_nad].
                          connections_established <= least_number_of_connects THEN
                        IF associated_paths_p^[path_index].last_attempted_connect <
                              earliest_connect_time THEN
                          selected_path_p := ^associated_paths_p^ [path_index];
                          selected_pid := local_host_p^.physical_identifier;
                          earliest_connect_time := selected_path_p^.last_attempted_connect;
                          least_number_of_connects := rfv$status_table.local_nads^
                                [selected_path_p^.local_nad].connections_established;
                        IFEND;
                      IFEND;
                    IFEND;
                  FOREND;
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      END /locate_local_path/;


    IF NOT remote_host_defined THEN
      CASE destination_host.host_identifier_kind OF
      = rfc$physical_identifier =
        osp$set_status_abnormal (rfc$product_id, rfe$destination_host_undefined,
              destination_host.physical_identifier, status);
      = rfc$logical_identifier =
        osp$set_status_abnormal (rfc$product_id,rfe$destination_host_undefined,
              destination_host.logical_identifier, status);
      CASEND;
      EXIT search_for_path;
    IFEND;

    IF NOT remote_host_enabled THEN
      CASE destination_host.host_identifier_kind OF
      = rfc$physical_identifier =
        osp$set_status_abnormal (rfc$product_id, rfe$destination_host_disabled,
              destination_host.physical_identifier, status);
      = rfc$logical_identifier =
        osp$set_status_abnormal (rfc$product_id,rfe$destination_host_disabled,
              destination_host.logical_identifier, status);
      CASEND;
      EXIT search_for_path;
    IFEND;

    IF NOT remote_server_defined THEN
      osp$set_status_abnormal (rfc$product_id, rfe$remote_server_undefined,
            server_name, status);
      EXIT search_for_path;
    IFEND;

    IF NOT remote_path_defined THEN
      osp$set_status_abnormal(rfc$product_id, rfe$path_to_remote_undefined,
            server_name, status);
      CASE destination_host.host_identifier_kind OF
      = rfc$physical_identifier =
        osp$append_status_parameter (osc$status_parameter_delimiter,
              destination_host.physical_identifier, status);
      = rfc$logical_identifier =
        osp$append_status_parameter (osc$status_parameter_delimiter,
              destination_host.logical_identifier, status);
      CASEND;
      EXIT search_for_path;
    IFEND;

    IF selected_path_p = NIL THEN
      osp$set_status_abnormal (rfc$product_id, rfe$paths_to_destination_down,
            server_name, status);
    IFEND;

  PROCEND search_for_path;
?? TITLE := '    rfp$set_connection_entry_p', EJECT ??
  PROCEDURE [XDCL] rfp$set_connection_entry_p (connection_entry_p: ^rft$connection_entry;
        response_seq_number: integer;
    VAR status: ost$status);

{
{     The purpose of this procedure is to enter the connection entry pointer
{     into the local nad table under the NAD associated with the connection.
{     This routine verifies that RHFAM is not in shutdown and that the NAD
{     is not UP.
{
{     NOTE: This routine assumes that the connection entry is locked upon
{       entry.  This locking algorithm does not conflict with the system
{       task because until the pointer is entered into the connection entry
{       in the status table, the system task does not know about the
{       connection and therefore does not try to lock the connection entry.
{
{     RESPONSE_SEQ_NUMBER: (input) This paramter specifies the sequence
{       number of the disconnect response that is being processed.
{
{     CONNECTION_ENTRY_P: (input) This parameter specifies a pointer to the
{       connection entry that is to be registered with RHFAM.
{
{     STATUS: (output) This parameter returns the result of the request.
{       A value of TRUE indicates that the connection has been registered.


    VAR
      nad_index: rft$local_nads;

    status.normal := TRUE;
    nad_index := connection_entry_p^.connection_descriptor.nad_index;
    rfp$lock_table(rfv$status_table.lock);
    IF rfv$status_table.system_task_is_up THEN
      rfp$lock_table(rfv$status_table.local_nads^[nad_index].connection_table_lock);
      IF rfv$status_table.local_nads^[nad_index].current_status.device_status =
            rfc$es_on THEN
        IF (rfv$status_table.local_nads^[nad_index].connection_table^[connection_entry_p^.
              connection_descriptor.network_path].connection_table_entry = NIL)  AND
           ((connection_entry_p^.connection_attributes.connection_status.connection_state <>
                rfc$outgoing_connect_active)  OR
            (NOT rfv$status_table.local_nads^[nad_index].connection_table^[connection_entry_p^.
              connection_descriptor.network_path].processing_incoming_connect))  THEN
          rfv$status_table.local_nads^[nad_index].connection_table^[connection_entry_p^.
                connection_descriptor.network_path].connection_table_entry :=
                connection_entry_p;
          rfv$status_table.local_nads^[nad_index].connections_established :=
                rfv$status_table.local_nads^[nad_index].connections_established + 1;
          rfv$status_table.local_nads^[nad_index].statistics.connections_established :=
                rfv$status_table.local_nads^[nad_index].statistics.connections_established + 1;
          IF connection_entry_p^.connection_attributes.connection_status.connection_state =
                rfc$outgoing_connect_active THEN
            IF response_seq_number >
                   rfv$status_table.local_nads^[nad_index].last_status_seq_number THEN
              rfv$status_table.local_nads^[nad_index].connection_table^[connection_entry_p^.
                    connection_descriptor.network_path].connection_state := rfc$ps_connecting;
              rfv$status_table.local_nads^[nad_index].connection_table^[connection_entry_p^.
                    connection_descriptor.network_path].connection_clarifier :=
                    rfc$pcc_locally_initiated;
            IFEND;
          IFEND;
        ELSE
         osp$set_status_abnormal (rfc$product_id, rfe$local_nad_busy,
               rfv$status_table.local_nads^[nad_index].name, status);
        IFEND;
      ELSE
        connection_entry_p^.connection_attributes.connection_status.connection_state :=
              rfc$local_nad_failure;
        osp$set_status_abnormal (rfc$product_id, rfe$local_nad_down,
              '', status);
      IFEND;
      rfp$unlock_table(rfv$status_table.local_nads^[nad_index].connection_table_lock);
    ELSE
      connection_entry_p^.connection_attributes.connection_status.connection_state :=
            rfc$system_task_shutdown;
      osp$set_status_abnormal (rfc$product_id, rfe$system_task_not_active,
            '', status);
    IFEND;
    rfp$unlock_table(rfv$status_table.lock);

  PROCEND rfp$set_connection_entry_p;
?? TITLE := '    set_connection_status', EJECT ??
  PROCEDURE set_connection_status (connection_entry_p: ^rft$connection_entry;
    VAR status: ost$status);

{
{     The purpose of this procedure is to set the status parameter to
{     reflect the current state of the connection in the connection
{     table.
{
{     CONNECTION_ENTRY_P: (input) This parameter specifies the
{       connection to return the status of.
{
{     STATUS: (output) This parameter returns the status of the
{       connection.
{


    CASE connection_entry_p^.connection_attributes.connection_status.
          connection_state OF
    = rfc$outgoing_connect_active =
      osp$set_status_abnormal (rfc$product_id, rfe$connect_in_progress,
            connection_entry_p^.connection_name, status);
    = rfc$incoming_connect_active =
      osp$set_status_abnormal (rfc$product_id, rfe$connection_waiting_accept,
            'Incoming connect', status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            connection_entry_p^.connection_name, status);
    = rfc$connected =
      osp$set_status_abnormal (rfc$product_id, rfe$connected,
            connection_entry_p^.connection_name, status);
    = rfc$connect_rejected =
      osp$set_status_abnormal (rfc$product_id, rfe$connection_rejected,
            connection_entry_p^.connection_name, status);
    = rfc$switch_offered =
      osp$set_status_abnormal (rfc$product_id, rfe$switch_offered,
            connection_entry_p^.connection_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            connection_entry_p^.connection_attributes.connection_status.
            destination_job, status);
    = rfc$switch_accepted =
      osp$set_status_abnormal (rfc$product_id, rfe$switch_accepted,
            connection_entry_p^.connection_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
            connection_entry_p^.connection_attributes.connection_status.
            receiving_job, status);
    = rfc$terminated =
      osp$set_status_abnormal (rfc$product_id, rfe$connection_terminated,
            connection_entry_p^.connection_name, status);
    = rfc$not_viable =
      osp$set_status_abnormal (rfc$product_id, rfe$unexpected_connection_state,
            connection_entry_p^.connection_name, status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            $integer(connection_entry_p^.connection_attributes.connection_status.
            connection_state), 10, FALSE, status);
    = rfc$system_task_shutdown =
      osp$set_status_abnormal (rfc$product_id, rfe$system_task_shutdown,
            connection_entry_p^.connection_name, status);
    = rfc$local_nad_failure =
      osp$set_status_abnormal (rfc$product_id, rfe$local_nad_failure,
            connection_entry_p^.connection_name, status);
    = rfc$system_interrupt =
      osp$set_status_abnormal (rfc$product_id, rfe$system_interrupt,
            connection_entry_p^.connection_name, status);
    ELSE
      osp$set_status_abnormal (rfc$product_id, rfe$unexpected_connection_state,
            connection_entry_p^.connection_name, status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            $integer(connection_entry_p^.connection_attributes.connection_status.
            connection_state), 10, FALSE, status);
    CASEND;

  PROCEND set_connection_status;
?? TITLE := '    sign_off_server', EJECT ??
  PROCEDURE sign_off_server (server_name: rft$application_name;
        job_name: jmt$system_supplied_name;
        current_connections: rft$application_connections;
    VAR status: ost$status);

{
{     The purpose of this procedure is to locate a server entry in the
{     defined server table, remove the server identifier, and decrement
{     the number of connections reserved by this server.
{
{     SERVER_NAME: (input) This parameter specifies the server that
{       is signing off.
{
{     JOB_NAME: (input) This parameter specifies the job name of the server
{       that is signing off.
{
{     STATUS: (output) A value of normal is returned if the server definition
{       is successfully removed.
{


    VAR
      current_entry_p: ^rft$server_identifier,
      previous_entry_p: ^rft$server_identifier,
      server_entry_p: ^rft$rhfam_server_table_entry;


    rfp$lock_table (rfv$rhfam_server_table.lock);
    find_server_entry(server_name, FALSE, server_entry_p, status);
    IF status.normal THEN
      server_entry_p^.connections_reserved := server_entry_p^.connections_reserved -
            current_connections;

      previous_entry_p := NIL;
      current_entry_p := server_entry_p^.server_identifier;

    /remove_identifier/
      WHILE current_entry_p <> NIL DO
        IF current_entry_p^.job_name = job_name THEN
          IF previous_entry_p = NIL THEN
            server_entry_p^.server_identifier := current_entry_p^.next_entry;
          ELSE
            previous_entry_p^.next_entry := current_entry_p^.next_entry;
          IFEND;
          FREE current_entry_p IN nav$network_paged_heap^;
          EXIT /remove_identifier/;
        IFEND;
        previous_entry_p := current_entry_p;
        current_entry_p := current_entry_p^.next_entry;
      WHILEND /remove_identifier/;

    IFEND;
    rfp$unlock_table (rfv$rhfam_server_table.lock);

  PROCEND sign_off_server;
?? TITLE := '    sign_on_server', EJECT ??
  PROCEDURE sign_on_server (server_entry_p: ^rft$rhfam_server_table_entry;
        system_supplied_name: jmt$system_supplied_name;
    VAR maximum_connections: rft$application_connections;
    VAR status: ost$status);

{
{     The purpose of this procedure is to verify that the server
{     signing on is the server started by RHFAM or if the server is
{     not defined, then to register the server as an implicit server
{     definition.
{
{     SERVER_ENTRY_P: (input) This parameter specifies a pointer to the
{       server definition of the server that is signing on.
{
{     SYSTEM_SUPPLIED_NAME: (input) This parameter specifies the job name
{       of the currently executing job.
{
{     MAXIMUM_CONNECTIONS: (input,output) This parameter specifies the number
{       of connections the server wishes to sign on with.  On return, this
{       parameter returns the actual number of connections the server was
{       signed on with.
{
{     STATUS: (output) This parameter returns the status of the request.
{       A status of normal indicates that the server was successfully signed
{       on.



    VAR
      remaining_connections: rft$application_connections,
      server_identifier_p: ^rft$server_identifier;


    status.normal := TRUE;
    IF server_entry_p^.rhfam_initiated_server THEN

{     Server was started by RHFAM so match on server identifier to
{     insure this is the job started by RHFAM.

      server_identifier_p := server_entry_p^.server_identifier;
      WHILE server_identifier_p <> NIL DO
        IF server_identifier_p^.job_name = system_supplied_name THEN
          IF maximum_connections <> server_entry_p^.server_job_max_connections THEN
            osp$set_status_abnormal (rfc$product_id, rfe$max_connection_mismatch,
                  server_entry_p^.server_name, status);
            EXIT sign_on_server;
          IFEND;
          server_identifier_p^.server_signed_on := TRUE;
          EXIT sign_on_server;
        IFEND;
        server_identifier_p := server_identifier_p^.next_entry;
      WHILEND;

      osp$set_status_abnormal (rfc$product_id, rfe$not_registered_server,
            server_entry_p^.server_name, status);
    ELSE

{     This server was not started by RHFAM so allocate a server identifier record.

      ALLOCATE server_identifier_p IN nav$network_paged_heap^;
      IF server_identifier_p = NIL THEN
        osp$set_status_abnormal (rfc$product_id, rfe$heap_exhausted,
              'network paged', status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              'sign_on_server', status);
        EXIT sign_on_server;
      IFEND;
      remaining_connections := server_entry_p^.maximum_connections -
            server_entry_p^.connections_reserved;
      IF maximum_connections = 0 THEN
        maximum_connections := remaining_connections;
      ELSE
        IF remaining_connections <  maximum_connections THEN
          osp$set_status_abnormal (rfc$product_id, rfe$defined_connects_exceeded,
                server_entry_p^.server_name, status);
          osp$append_status_integer (osc$status_parameter_delimiter, maximum_connections,
                10, FALSE, status);
          EXIT sign_on_server;
        IFEND;
      IFEND;
      server_entry_p^.connections_reserved := server_entry_p^.connections_reserved +
              maximum_connections;
      server_identifier_p^.job_name := system_supplied_name;
      pmp$get_microsecond_clock (server_identifier_p^.server_started_time, status);
      server_identifier_p^.server_signed_on := TRUE;

{     Link new server identifier into list of server identifiers.

      server_identifier_p^.next_entry := server_entry_p^.server_identifier;
      server_entry_p^.server_identifier := server_identifier_p;

    IFEND;

  PROCEND sign_on_server;
?? TITLE := '    start_receive_data', EJECT ??
  PROCEDURE start_receive_data (VAR data_transfer_status: ^rft$data_transfer_status;
        data_length: rft$data_length;
    VAR residue_input_data: ^rft$residue_data;
    VAR status: ost$status);


{
{     The purpose of this procedure is to allocate any necessary buffers
{     and initialize the receive data pp unit request.
{
{     DATA_TRANSFER_STATUS: (input) This parameter specifies the parameters for
{       the data send operation. A NIL pointer is returned if an error has occurred
{       and the transfer was terminated.
{
{     DATA_LENGTH: (input) This parameter specifies the total data length for this
{       request.
{
{     RESIDUE_INPUT_DATA: (input) This parameter specifies a pointer to any residue
{       data that has been received from the network but not yet delivered to the
{       application because of a buffer full condition.  A nil pointer indicates
{       no residue data.
{
{     STATUS: (output) A value of normal is returned if the send data request
{       has been successfully initiated.
{


    VAR
      blocks_to_add: rft$outstanding_blocks,
      nad_index: rft$local_nads,
      transfer_complete: boolean,
      unit_request: ^SEQ ( * );


    data_transfer_status^.present_r1_out_ptr := rfc$cbi_first_io_entry;
    data_transfer_status^.block_descriptors := NIL;
    data_transfer_status^.block_descriptor_in := 1;
    data_transfer_status^.block_descriptor_out := 1;
    data_transfer_status^.reserved_buffer_list := NIL;
    data_transfer_status^.next_wired_buffer_in := 1;
    data_transfer_status^.next_wired_buffer_out := 1;
    data_transfer_status^.data_exhausted := FALSE;
    data_transfer_status^.next_to_advise_out_index := data_transfer_status^.next_to_queue_index;
    data_transfer_status^.next_to_advise_out_offset :=
          data_transfer_status^.next_to_queue_offset;
    data_transfer_status^.next_to_advise_in_index := data_transfer_status^.next_to_queue_index;
    data_transfer_status^.next_to_advise_in_offset :=
          data_transfer_status^.next_to_queue_offset;
    data_transfer_status^.complete_index := data_transfer_status^.next_to_queue_index;
    data_transfer_status^.complete_offset := data_transfer_status^.next_to_queue_offset;
    data_transfer_status^.switch_to_wired_buffers := FALSE;
    data_transfer_status^.termination_mark := rfc$rm_eor;
    data_transfer_status^.header_buffers := NIL;
    data_transfer_status^.maximum_outstanding_blocks := rfc$max_outstanding_blocks;

    {  Start the disk processing to minimize future page faulting.
    {  WARNING - 'data_transfer_status^.block_decriptors' must equal the NIL value.

    advise_out_in (data_transfer_status, status);
    IF NOT status.normal THEN
      terminate_transfer_request (status, data_transfer_status);
      EXIT start_receive_data;
    IFEND;

    IF residue_input_data <> NIL THEN
      deliver_residue_data (data_transfer_status, residue_input_data, transfer_complete,
            status);
      IF (transfer_complete) OR
         (NOT status.normal) THEN
        terminate_transfer_request (status, data_transfer_status);
        EXIT start_receive_data;
      IFEND;
      data_transfer_status^.network_wired_data := TRUE;
    IFEND;

    IF data_transfer_status^.network_wired_data THEN
      allocate_network_wired_buffers (data_transfer_status, data_length, status);
      IF NOT status.normal THEN
        terminate_transfer_request (status, data_transfer_status);
        EXIT start_receive_data;
      IFEND;
    ELSE
      ALLOCATE  data_transfer_status^.header_buffers:
            [ 1 .. data_transfer_status^.maximum_outstanding_blocks ]
            IN nav$network_wired_heap^;
    IFEND;

    ALLOCATE data_transfer_status^.block_descriptors:
          [ 1 .. data_transfer_status^.maximum_outstanding_blocks ]
          IN osv$task_private_heap^;

    PUSH unit_request: [[rft$logical_commands, rft$transfer_mode, boolean, rft$path_identifier,
          BOOLEAN,
                { intermediate response flag }
          rft$command_entry,
                { block count }
          REP data_transfer_status^.maximum_outstanding_blocks OF rft$command_entry,
                { fragment count }
          REP (data_transfer_status^.maximum_outstanding_blocks * 4) OF rft$io_fragment]];
                { assume maximum of 4 fragments per block }
    RESET unit_request;
    build_transfer_request_header (data_transfer_status, rfc$rm_eor, unit_request, status);
    IF  NOT status.normal THEN
      terminate_transfer_request (status, data_transfer_status);
      EXIT  start_receive_data;
    IFEND;

    blocks_to_add := data_transfer_status^.maximum_outstanding_blocks;
    add_blocks_to_request (data_transfer_status, TRUE, blocks_to_add,
          unit_request, status);
    IF NOT status.normal THEN
      terminate_transfer_request (status, data_transfer_status);
      EXIT start_receive_data;
    IFEND;

    rfp$lock_table (data_transfer_status^.connection_entry_p^.lock);
    IF (data_transfer_status^.connection_entry_p^.connection_attributes.
          connection_status.connection_state = rfc$connected) OR
       (data_transfer_status^.connection_entry_p^.connection_attributes.
          connection_status.connection_state = rfc$terminated) THEN
      nad_index := data_transfer_status^.connection_entry_p^.
            connection_descriptor.nad_index;
      rfp$unlock_table (data_transfer_status^.connection_entry_p^.lock);
      rfp$queue_request(nad_index, 1, rfc$unit_request,
          rfc$rk_receive_data, data_transfer_status, unit_request, status);
      IF NOT status.normal THEN
        terminate_transfer_request (status, data_transfer_status);
      ELSE
        data_transfer_status^.total_blocks_queued := blocks_to_add;
        data_transfer_status^.next_to_queue_abn := data_transfer_status^.current_abn;
        data_transfer_status^.next_to_queue_index := data_transfer_status^.current_fragment_index;
        data_transfer_status^.next_to_queue_offset := data_transfer_status^.current_fragment_offset;
      IFEND;
    ELSE
      set_connection_status (data_transfer_status^.connection_entry_p, status);
      rfp$unlock_table (data_transfer_status^.connection_entry_p^.lock);
      terminate_transfer_request (status, data_transfer_status);
    IFEND;

  PROCEND start_receive_data;
?? TITLE := '    start_send_data', EJECT ??
  PROCEDURE start_send_data (VAR data_transfer_status: ^rft$data_transfer_status;
        data_length: rft$data_length;
    VAR status: ost$status);


{
{     The purpose of this procedure is to allocate any necessary buffers
{     and initialize the send data pp unit request.
{
{     DATA_TRANSFER_STATUS: (input) This parameter specifies the parameters for
{       the data send operation. A NIL pointer is returned if an error has occurred
{       and the transfer was terminated.
{
{     DATA_LENGTH: (input) This parameter specifies the total data length for this
{       request.
{
{     STATUS: (output) A value of normal is returned if the send data request
{       has been successfully initiated.
{


    VAR
      blocks_to_add: rft$outstanding_blocks,
      nad_index: rft$local_nads,
      unit_request: ^SEQ ( * );


    data_transfer_status^.present_r1_out_ptr := rfc$cbi_first_io_entry;
    data_transfer_status^.block_descriptor_in := 1;
    data_transfer_status^.block_descriptor_out := 1;
    data_transfer_status^.next_wired_buffer_in := 1;
    data_transfer_status^.next_wired_buffer_out := 1;
    data_transfer_status^.data_exhausted := FALSE;
    data_transfer_status^.next_to_advise_out_index := data_transfer_status^.next_to_queue_index;
    data_transfer_status^.next_to_advise_out_offset :=
          data_transfer_status^.next_to_queue_offset;
    data_transfer_status^.next_to_advise_in_index := data_transfer_status^.next_to_queue_index;
    data_transfer_status^.next_to_advise_in_offset :=
          data_transfer_status^.next_to_queue_offset;
    data_transfer_status^.complete_index := data_transfer_status^.next_to_queue_index;
    data_transfer_status^.complete_offset := data_transfer_status^.next_to_queue_offset;
    data_transfer_status^.switch_to_wired_buffers := FALSE;
    data_transfer_status^.reserved_buffer_list := NIL;
    data_transfer_status^.block_descriptors := NIL;
    data_transfer_status^.header_buffers := NIL;
    data_transfer_status^.maximum_outstanding_blocks := rfc$max_outstanding_blocks;

    {  Start the disk processing to minimize future page faulting.
    {  WARNING - 'data_transfer_status^.block_decriptors' must equal the NIL value.

    advise_out_in (data_transfer_status, status);
    IF NOT status.normal THEN
      terminate_transfer_request (status, data_transfer_status);
      EXIT start_send_data;
    IFEND;

    IF data_transfer_status^.network_wired_data THEN
      allocate_network_wired_buffers (data_transfer_status, data_length, status);
      IF NOT status.normal THEN
        terminate_transfer_request (status, data_transfer_status);
        EXIT start_send_data;
      IFEND;
    ELSE
      ALLOCATE  data_transfer_status^.header_buffers:
            [ 1 .. data_transfer_status^.maximum_outstanding_blocks ]
            IN nav$network_wired_heap^;
    IFEND;

    ALLOCATE data_transfer_status^.block_descriptors:
          [ 1 .. data_transfer_status^.maximum_outstanding_blocks ]
          IN osv$task_private_heap^;

    PUSH unit_request: [[rft$logical_commands, boolean, rft$path_identifier,
          BOOLEAN,
                { intermediate response flag }
          rft$command_entry,
                { block count }
          REP data_transfer_status^.maximum_outstanding_blocks OF rft$command_entry,
                { fragment count }
          REP (data_transfer_status^.maximum_outstanding_blocks * 4) OF rft$io_fragment]];
                { assume maximum of 4 fragments per block }
    RESET unit_request;
    build_transfer_request_header (data_transfer_status, rfc$rm_eor, unit_request, status);
    IF NOT status.normal THEN
      terminate_transfer_request (status, data_transfer_status);
      EXIT  start_send_data;
    IFEND;

    blocks_to_add := data_transfer_status^.maximum_outstanding_blocks;
    add_blocks_to_request (data_transfer_status, TRUE, blocks_to_add,
          unit_request, status);
    IF NOT status.normal THEN
      terminate_transfer_request (status, data_transfer_status);
      EXIT start_send_data;
    IFEND;

    rfp$lock_table (data_transfer_status^.connection_entry_p^.lock);
    IF data_transfer_status^.connection_entry_p^.connection_attributes.
          connection_status.connection_state = rfc$connected THEN
      nad_index := data_transfer_status^.connection_entry_p^.
            connection_descriptor.nad_index;
      rfp$unlock_table (data_transfer_status^.connection_entry_p^.lock);
      rfp$queue_request(nad_index, 1, rfc$unit_request,
          rfc$rk_send_data, data_transfer_status, unit_request, status);
      IF NOT status.normal THEN
        terminate_transfer_request (status, data_transfer_status);
      ELSE
        data_transfer_status^.total_blocks_queued := blocks_to_add;
        data_transfer_status^.next_to_queue_abn := data_transfer_status^.current_abn;
        data_transfer_status^.next_to_queue_index := data_transfer_status^.current_fragment_index;
        data_transfer_status^.next_to_queue_offset := data_transfer_status^.current_fragment_offset;
      IFEND;
    ELSE
      set_connection_status (data_transfer_status^.connection_entry_p, status);
      rfp$unlock_table (data_transfer_status^.connection_entry_p^.lock);
      terminate_transfer_request (status, data_transfer_status);
    IFEND;

  PROCEND start_send_data;
?? TITLE := '    rfp$store', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$store (
        connection_identifier: amt$file_identifier;
        file_attributes: rft$change_attributes;
    VAR status: ost$status);

*copyc rfh$store

?? NEWTITLE := '      terminate_store - condition handler', EJECT ??
    PROCEDURE terminate_store (condition: pmt$condition;
          ignore_condition_descriptor: ^pmt$condition_information;
          sfsa: ^ost$stack_frame_save_area;
      VAR condition_status: ost$status);


      CASE condition.selector OF
      = mmc$segment_access_condition, pmc$system_conditions =
        IF connection_entry_p <> NIL THEN
          rfp$unlock_table (connection_entry_p^.lock);
        IFEND;
        osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
              condition_status);
        EXIT rfp$store;
      = pmc$user_defined_condition =
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rfc$product_id, condition, sfsa, status,
                condition_status);
          EXIT rfp$store;
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND terminate_store;
?? OLDTITLE, EJECT ??

    VAR
      connection_entry_p: ^rft$connection_entry;


    connection_entry_p := NIL;
    osp$establish_condition_handler (^terminate_store, FALSE);
    status.normal := TRUE;

    get_exclusive_to_cid (connection_identifier, connection_entry_p, status);
    IF NOT status.normal THEN
      EXIT rfp$store;
    IFEND;
    merge_change_attributes (^connection_entry_p^.connection_attributes,
          ^file_attributes, status);
    rfp$unlock_table (connection_entry_p^.lock);

  PROCEND rfp$store;
?? TITLE := '    suspend_data_transfer', EJECT ??
  PROCEDURE [INLINE]  suspend_data_transfer(current_request: ^rft$outstanding_requests;
    VAR status: ost$status);


{     The purpose of this procedure is to suspend the data transfer on
{     a connection when a NAD resource limit is reached.  The PP request
{     is removed from the unit queue and the number of requests posted
{     to the NAD is decremented.  It is assumed that the resource limit is
{     going to be of sufficient duration to warrant removing the request
{     from the unit request queue.
{
{     CURRENT_REQUEST: (input) This parameter specifies the request to
{       remove from the unit queue.
{
{     STATUS: (output) This parameter returns the result of the procedure.
{       A status of normal indicates the procedure completed normally.



    rfp$delink_request (current_request^.request_id, status);
    rfp$lock_table (rfv$status_table.lock);
    rfv$status_table.local_nads^[current_request^.request_id.ring_3_id.nad].requests_posted :=
      rfv$status_table.local_nads^[current_request^.request_id.ring_3_id.nad].requests_posted -1;
    rfp$unlock_table (rfv$status_table.lock);
    current_request^.posted := FALSE;

  PROCEND suspend_data_transfer;
?? TITLE := '    switch_to_wired_buffers', EJECT ??
  PROCEDURE switch_to_wired_buffers (data_transfer_status: ^rft$data_transfer_status;
    VAR status: ost$status);

{
{     The purpose of this routine is to change the data transfer mode from
{     using unwired buffers to using network wired buffers.  Any structures
{     allocated and used only during unwired transfers are released and the
{     necessy buffers to transfer in network wired mode are allocated.
{
{     DATA_TRANSFER_STATUS: (input) This parameter specifies a pointer to
{       the data transfer parameters.
{
{     STATUS: (output) This parameter returns the status of the request.
{       A status of normal indicates that the switch was successfully made.



    VAR
      current_fragment: rft$data_fragment_count,
      current_offset: rft$data_length,
      data_length: rft$data_length;

    status.normal := TRUE;
    data_transfer_status^.next_wired_buffer_out := 1;
    data_transfer_status^.next_wired_buffer_in := 1;
    data_transfer_status^.switch_to_wired_buffers := FALSE;
    data_transfer_status^.network_wired_data := TRUE;

    FREE data_transfer_status^.header_buffers IN nav$network_wired_heap^;
    current_fragment := data_transfer_status^.next_to_queue_index;
    current_offset := data_transfer_status^.next_to_queue_offset;
    data_length := 0;
    WHILE current_fragment <= UPPERBOUND(data_transfer_status^.data_area^) DO
      data_length := data_length + data_transfer_status^.data_area^[current_fragment].length -
            current_offset;
      current_offset := 0;
      current_fragment := current_fragment + 1;
    WHILEND;
    allocate_network_wired_buffers (data_transfer_status, data_length, status);

  PROCEND switch_to_wired_buffers;
?? TITLE := '    terminate_async_activity', EJECT ??
  PROCEDURE terminate_async_activity (requests: rft$set_of_async_activities;
        connection_name: fst$path_handle_name);


{     The purpose of this procedure is to terminate the asynchronous activities
{     that are specified.  To do this the outstanding request queue is scanned
{     and any requests that do not have an error already set and that match
{     the requests to terminate are told to terminate.  These requests will
{     then terminate when any outstanding PP requests complete.
{
{     REQUESTS: (input) This parameter specifies a set of activities that are
{       to be terminated.
{
{     CONNECTION_NAME: (input) This parameter specifies the connection file to
{       terminate the requests for.



    VAR
      current_request: ^rft$outstanding_requests,
      data_transfer_status: ^rft$data_transfer_status,
      process_pp_responses: boolean;


    process_pp_responses := FALSE;
    current_request := rfv$outstanding_requests;
    WHILE current_request <> NIL DO
      IF (current_request^.request_kind = rfc$rk_send_data) OR
         (current_request^.request_kind = rfc$rk_receive_data) THEN
        data_transfer_status := current_request^.request_status;
        IF (data_transfer_status^.connection_name = connection_name) AND
           data_transfer_status^.previous_error.normal THEN
          CASE data_transfer_status^.transfer_kind OF
          = rfc$tk_send_data =
            IF (rfc$aa_send_data IN requests) OR
               (rfc$aa_all_async_activities IN requests) THEN
              osp$set_status_abnormal (rfc$product_id, rfe$async_req_terminated,
                    'Send data', data_transfer_status^.previous_error);
              osp$append_status_parameter (osc$status_parameter_delimiter, connection_name,
                    data_transfer_status^.previous_error);
              IF current_request^.waiting_event <> NIL THEN
                rfp$lock_table (rfv$rhfam_event_table.lock);
                IF current_request^.waiting_event^.event_occurred_type = rfc$eot_no_event THEN
                  current_request^.waiting_event^.event_occurred_type := rfc$eot_async_terminated;
                  process_pp_responses := TRUE;
                IFEND;
                rfp$unlock_table (rfv$rhfam_event_table.lock);
              IFEND;
            IFEND;
          = rfc$tk_receive_data =
            IF (rfc$aa_receive_data IN requests) OR
               (rfc$aa_all_async_activities IN requests) THEN
              osp$set_status_abnormal (rfc$product_id, rfe$async_req_terminated,
                    'Receive data', data_transfer_status^.previous_error);
              osp$append_status_parameter (osc$status_parameter_delimiter, connection_name,
                    data_transfer_status^.previous_error);
              IF current_request^.waiting_event <> NIL THEN
                rfp$lock_table (rfv$rhfam_event_table.lock);
                IF current_request^.waiting_event^.event_occurred_type = rfc$eot_no_event THEN
                  current_request^.waiting_event^.event_occurred_type := rfc$eot_async_terminated;
                  process_pp_responses := TRUE;
                IFEND;
                rfp$unlock_table (rfv$rhfam_event_table.lock);
              IFEND;
            IFEND;
          CASEND;
        IFEND;
      IFEND;
      current_request := current_request^.next_entry;
    WHILEND;

    IF process_pp_responses THEN
      rfp$process_pp_response_flag (rfc$pp_response_available);
    IFEND;

  PROCEND terminate_async_activity;
?? TITLE := '    terminate_transfer_request', EJECT ??
  PROCEDURE terminate_transfer_request (
        status: ost$status;
    VAR data_transfer_status: ^rft$data_transfer_status);

{
{     The purpose of this procedure is to terminate an active data transfer
{     process. This routine updates the connection table entry from the
{     data transfer status block, releases any transfer buffers and sets
{     the activity status complete parameter.
{
{     DATA_TRANSFER_STATUS: (input) This parameter specifies a pointer
{       to the data transfer parameters.
{
{     STATUS: (input) This parameter specifies the ending status of the
{       data transfer.  It is returned to the data transfer initiator in
{       the activity status parameter.
{



    VAR
      activity_status_p: ^ost$activity_status,
      buffer_count: rft$buffer_count,
      bytes_transferred: rft$bytes_transferred,
      bytes_transferred_p: ^rft$bytes_transferred,
      connection_entry_p: ^rft$connection_entry,
      end_of_message: boolean,
      end_of_message_p: ^boolean,
      local_nad_index: rft$local_nads,
      transfer_kind: rft$transfer_kinds;



    IF data_transfer_status^.block_descriptors <> NIL THEN
      FREE data_transfer_status^.block_descriptors IN osv$task_private_heap^;
    IFEND;
    IF data_transfer_status^.network_wired_data THEN
      buffer_count := data_transfer_status^.reserved_buffer_count;
      IF data_transfer_status^.reserved_buffer_list <> NIL THEN
        rfp$release_wired_buffers(data_transfer_status^.reserved_buffer_list^, buffer_count);
        FREE data_transfer_status^.reserved_buffer_list IN osv$task_private_heap^;
      IFEND;
    ELSE
      IF data_transfer_status^.header_buffers <> NIL THEN
        FREE data_transfer_status^.header_buffers IN nav$network_wired_heap^;
      IFEND;
    IFEND;

    local_nad_index := 0;
    connection_entry_p := data_transfer_status^.connection_entry_p;
    transfer_kind := data_transfer_status^.transfer_kind;
    bytes_transferred := data_transfer_status^.bytes_transferred;
    bytes_transferred_p :=data_transfer_status^.data_transferred;
    activity_status_p := data_transfer_status^.activity_status;
    rfp$lock_table (connection_entry_p^.lock);
    IF connection_entry_p^.connection_attributes.connection_status.connection_state =
          rfc$connected THEN
      local_nad_index := connection_entry_p^.connection_descriptor.nad_index;
      IF data_transfer_status^.outstanding_control_messages <> NIL THEN
        queue_control_messages (local_nad_index, data_transfer_status^.
              outstanding_control_messages);
      IFEND;
      IF NOT (status.normal) AND (status.condition = rfe$connection_terminated) THEN
        connection_entry_p^.connection_attributes.connection_status.connection_state :=
              rfc$terminated;
        connection_entry_p^.connection_attributes.connection_status.reason_for_termination :=
              data_transfer_status^.reason_for_termination;
      IFEND;
    ELSE
      delete_control_messages (data_transfer_status^.outstanding_control_messages);
    IFEND;
    CASE transfer_kind OF
    = rfc$tk_send_data =
      CASE data_transfer_status^.transmission_mode OF
      = rfc$record_mode =
        connection_entry_p^.connection_attributes.outgoing_record_abn :=
              data_transfer_status^.next_to_queue_abn;
      = rfc$message_mode =
        connection_entry_p^.connection_attributes.outgoing_message_count :=
              connection_entry_p^.connection_attributes.outgoing_message_count +
              data_transfer_status^.outgoing_message_count;
      CASEND;
      connection_entry_p^.connection_statistics.bytes_sent :=
            connection_entry_p^.connection_statistics.bytes_sent  +
            bytes_transferred;
      connection_entry_p^.send_request_active := FALSE;
    = rfc$tk_receive_data =
      CASE data_transfer_status^.transmission_mode OF
      = rfc$record_mode =
        connection_entry_p^.connection_attributes.incoming_record_abn :=
               data_transfer_status^.next_to_queue_abn;
        IF data_transfer_status^.complete_message_received THEN
          connection_entry_p^.connection_attributes.file_mark_received :=
                data_transfer_status^.file_mark_received;
        IFEND;
      = rfc$message_mode =
        ;
      CASEND;
      end_of_message := data_transfer_status^.complete_message_received;
      end_of_message_p := data_transfer_status^.end_of_message_p;
      connection_entry_p^.connection_statistics.bytes_received :=
            connection_entry_p^.connection_statistics.bytes_received  +
            bytes_transferred;
      connection_entry_p^.receive_request_active := FALSE;
    CASEND;

    wakeup_waiting_tasks (connection_entry_p);
    rfp$unlock_table (connection_entry_p^.lock);
    FREE data_transfer_status IN osv$task_private_heap^;
    IF local_nad_index <> 0 THEN
      rfp$lock_table (rfv$status_table.lock);
      IF rfv$status_table.system_task_is_up THEN
        CASE transfer_kind OF
        = rfc$tk_receive_data =
          rfv$status_table.local_nads^[local_nad_index].statistics.bytes_received :=
                rfv$status_table.local_nads^[local_nad_index].statistics.bytes_received +
                bytes_transferred;
        = rfc$tk_send_data =
          rfv$status_table.local_nads^[local_nad_index].statistics.bytes_sent :=
                rfv$status_table.local_nads^[local_nad_index].statistics.bytes_sent +
                bytes_transferred;
        CASEND;
      IFEND;
      rfp$unlock_table (rfv$status_table.lock);
    IFEND;
    bytes_transferred_p^ := bytes_transferred;
    IF transfer_kind = rfc$tk_receive_data THEN
      end_of_message_p^ := end_of_message;
    IFEND;
    IF NOT status.normal THEN
      activity_status_p^.status := status;
    IFEND;
    activity_status_p^.complete := TRUE;

  PROCEND terminate_transfer_request;
?? TITLE := '    rfp$test_set_table_lock', EJECT ??
  PROCEDURE [XDCL] rfp$test_set_table_lock (VAR lock: ost$signature_lock;
    VAR locked: boolean);

{
{     The purpose of this procedure is to test and set a signature
{     lock on a RHFAM ring 3 table. If the table is not locked,
{     the lock is set. If the table is locked, control is returned
{     without setting the lock.
{
{     LOCK: (input,output)  This parameter specifies the signature lock to
{       obtain.
{
{     LOCKED: (output) This parameter returns a TRUE value if the
{       signature lock was set by this call.  A value of FALSE is
{       returned if the lock was previously set.
{


    osp$begin_subsystem_activity;
    osp$test_set_job_sig_lock(lock, locked);
    IF NOT locked THEN
      osp$end_subsystem_activity;
    IFEND;

  PROCEND rfp$test_set_table_lock;
?? TITLE := '    update_connection_status', EJECT ??
  PROCEDURE update_connection_status (
        connection_entry_p: ^rft$connection_entry;
    VAR input_available: boolean;
    VAR connection_unlocked: boolean;
    VAR status: ost$status);

{
{     The purpose of this procedure is to update the connection status
{     of the specified connection.  The present state of the connection
{     is compared with the present state of the connection in the NAD.
{     If the connection state in the connection entry does not match the
{     connection state as reported by the NAD hardware, the connection
{     entry state is updated. The connection entry must be locked
{     upon entry to this routine.  On exit the calling routine must
{     check to see if the connection entry has been unlocked.
{
{     CONNECTION_ENTRY_P: (input) This parameter specifies the pointer
{       to the connection table entry to get the status for.
{
{     INPUT_AVAILABLE: (output) This parameter returns a flag giving the
{       current status of input available on the connection.  A value of
{       true indicates that input is available.  A connection in a state
{       of terminated by peer termination may still have input that can
{       be received by an application.
{
{     CONNECTION_UNLOCKED: (output) This parameter returns the present
{       lock status of the connection entry.  If a pp request is needed
{       to update the connection status, the connection will be unlocked.
{
{     STATUS: (output) This parameter returns the result of the request.


    VAR
      connection_status: ^rft$connection_table_entry;


      status.normal := TRUE;
      input_available := FALSE;
      connection_unlocked := FALSE;
      CASE connection_entry_p^.connection_attributes.connection_status.
            connection_state OF
      = rfc$connected =
        connection_status := ^rfv$status_table.local_nads^[connection_entry_p^.connection_descriptor.
               nad_index].connection_table^[connection_entry_p^.connection_descriptor.
               network_path];
        CASE connection_status^.connection_state OF
        = rfc$ps_established =
          CASE connection_status^.connection_clarifier OF
          = rfc$pce_normal, rfc$pce_local_host_uninformed =
            input_available := (connection_status^.input_available) OR
                  (connection_entry_p^.residue_input_data <> NIL);
            connection_entry_p^.connection_attributes.connection_status.
                  input_available := input_available;
            connection_entry_p^.connection_attributes.connection_status.
                  output_below_threshold := connection_status^.output_below_threshold;
          = rfc$pce_incoming_disconnect =
            input_available := (connection_status^.input_available) OR
                  (connection_entry_p^.residue_input_data <> NIL);
            connection_entry_p^.connection_attributes.connection_status.
                   connection_state := rfc$terminated;
            connection_entry_p^.connection_attributes.connection_status.
                   reason_for_termination := rfc$peer_termination;
          ELSE
            get_path_status(connection_entry_p, status);
            connection_unlocked := TRUE;
          CASEND;
        ELSE
          get_path_status(connection_entry_p, status);
          connection_unlocked := TRUE;
        CASEND;
      = rfc$terminated =
        IF connection_entry_p^.connection_attributes.connection_status.
            reason_for_termination = rfc$peer_termination THEN
          connection_status := ^rfv$status_table.local_nads^[connection_entry_p^.connection_descriptor.
                 nad_index].connection_table^[connection_entry_p^.connection_descriptor.
                 network_path];
          CASE connection_status^.connection_state OF
          = rfc$ps_established =
            CASE connection_status^.connection_clarifier OF
            = rfc$pce_incoming_disconnect =
              input_available := (connection_status^.input_available) OR
                    (connection_entry_p^.residue_input_data <> NIL);
            ELSE
              ;
            CASEND;
          ELSE
            ;
          CASEND;
        IFEND;
      = rfc$outgoing_connect_active =
        connection_status := ^rfv$status_table.local_nads^[connection_entry_p^.connection_descriptor.
               nad_index].connection_table^[connection_entry_p^.connection_descriptor.
               network_path];
        CASE connection_status^.connection_state OF
        = rfc$ps_established =
          CASE connection_status^.connection_clarifier OF
          = rfc$pce_normal, rfc$pce_local_host_uninformed =
            connection_entry_p^.connection_attributes.connection_status.
                  connection_state := rfc$connected;
            connection_entry_p^.connection_attributes.connection_status.
                  input_available := connection_status^.input_available;
            connection_entry_p^.connection_attributes.connection_status.
                  output_below_threshold := connection_status^.output_below_threshold;
            rfp$lock_table (rfv$status_table.lock);
            connection_entry_p^.selected_path^.disabled := FALSE;
            connection_entry_p^.selected_path^.failure_count := 0;
            rfp$unlock_table (rfv$status_table.lock);
          = rfc$pce_incoming_disconnect =
            connection_entry_p^.connection_attributes.connection_status.
                   connection_state := rfc$terminated;
            connection_entry_p^.connection_attributes.connection_status.
                   reason_for_termination := rfc$peer_termination;
            input_available := connection_status^.input_available;
          ELSE
            get_path_status(connection_entry_p, status);
            connection_unlocked := TRUE;
          CASEND;
        = rfc$ps_connecting =
          CASE connection_status^.connection_clarifier OF
          = rfc$pcc_remote_reject, rfc$pcc_local_reject, rfc$pcc_network_reject =
            get_path_status(connection_entry_p, status);
            connection_unlocked := TRUE;
          ELSE
            ;     {still connecting}
          CASEND;
        ELSE
          get_path_status(connection_entry_p, status);
          connection_unlocked := TRUE;
        CASEND;
      = rfc$incoming_connect_active =
        ;
      = rfc$connect_rejected =
        ;
      = rfc$switch_offered =
        ;
      = rfc$switch_accepted =
        ;
      = rfc$system_task_shutdown =
        ;
      = rfc$local_nad_failure =
        ;
      = rfc$system_interrupt =
        ;
      ELSE
        rfp$unlock_table (connection_entry_p^.lock);
        connection_unlocked := TRUE;
        osp$set_status_abnormal (rfc$product_id, rfe$unexpected_connection_state,
              connection_entry_p^.connection_name, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              $integer(connection_entry_p^.connection_attributes.connection_status.
              connection_state), 10, FALSE, status);
      CASEND;

  PROCEND update_connection_status;
?? TITLE := '    rfp$unlock_table ', EJECT ??
  PROCEDURE [XDCL] rfp$unlock_table (VAR lock: ost$signature_lock);

{
{     The purpose of this procedure is to release a global lock on a RHFAM
{     ring 3 table.  This procedure decrements the system buffer locked
{     count that was incremented when the table was locked.
{
{     LOCK: (input,output)  This parameter specifies the signature lock to
{       obtain.
{


    osp$clear_job_signature_lock(lock);
    osp$end_subsystem_activity;

  PROCEND rfp$unlock_table;
?? TITLE := '    wakeup_accept_switch_waits', EJECT ??
  PROCEDURE wakeup_accept_switch_waits (source_job: jmt$system_supplied_name);

{     The purpose of this procedure is to send a ready task to all tasks
{     that are waiting for switch offer accepts under the specified
{     job name.
{
{     SOURCE_JOB: (input) This parameter specifies the source job of the
{       connection that is being accepted.
{

    VAR
      current_wait: ^rft$rhfam_event_table_entry,
      ignore_status: ost$status;


    rfp$lock_table (rfv$rhfam_event_table.lock);
    current_wait := rfv$rhfam_event_table.first_entry;
  /wakeup_waits/
    WHILE current_wait <> NIL DO
      IF current_wait^.event_kind = rfc$ana_await_switch_accept THEN
        IF source_job = current_wait^.asa_source_job THEN
          current_wait^.event_occurred_type := rfc$eot_switch_accept;
          pmp$ready_task (current_wait^.task_id, ignore_status);
        IFEND;
      IFEND;
      current_wait := current_wait^.next_entry;
    WHILEND /wakeup_waits/;
    rfp$unlock_table (rfv$rhfam_event_table.lock);

  PROCEND wakeup_accept_switch_waits;
?? TITLE := '    wakeup_wait_switch_offers', EJECT ??
  PROCEDURE wakeup_wait_switch_offers (application_name: rft$application_name);


{     The purpose of this procedure is to ready any tasks that are waiting
{     for a connection switch offer.  All tasks that are waiting for
{     the specified application name are sent a ready task.
{
{     APPLICATION_NAME: (input) This parameter specifies the application
{       name of the switched connection.



    VAR
      current_wait: ^rft$rhfam_event_table_entry,
      ignore_status: ost$status;


    rfp$lock_table (rfv$rhfam_event_table.lock);
    current_wait := rfv$rhfam_event_table.first_entry;
  /wakeup_waits/
    WHILE current_wait <> NIL DO
      IF current_wait^.event_kind = rfc$ana_await_switch_offer THEN
        IF application_name = current_wait^.aSo_application_name THEN
          current_wait^.event_occurred_type := rfc$eot_switch_offer;
          pmp$ready_task (current_wait^.task_id, ignore_status);
        IFEND;
      IFEND;
      current_wait := current_wait^.next_entry;
    WHILEND /wakeup_waits/;
    rfp$unlock_table (rfv$rhfam_event_table.lock);

  PROCEND wakeup_wait_switch_offers;
?? TITLE := '    wakeup_waiting_tasks', EJECT ??
  PROCEDURE wakeup_waiting_tasks (connection_entry_p: ^rft$connection_entry);

{     The purpose of this procedure is to wake up any tasks that have
{     been suspended due to active send or receive data requests.  This
{     routine issues a pmp$ready task to all waiting tasks and frees all
{     the waiting task entries.
{
{     CONNECTION_ENTRY_P: (input,output) This parameter specifies the
{       connection entry to wake up the tasks for.



    VAR
      current_waiting_task: ^rft$waiting_task_queue,
      ignore_status: ost$status,
      next_waiting_task: ^rft$waiting_task_queue;


    next_waiting_task := connection_entry_p^.waiting_tasks;
    IF next_waiting_task <> NIL THEN
      connection_entry_p^.waiting_tasks := NIL;
      WHILE next_waiting_task <> NIL DO
        current_waiting_task := next_waiting_task;
        pmp$ready_task (current_waiting_task^.global_task_id, ignore_status);
        next_waiting_task := current_waiting_task^.next_entry;
        FREE current_waiting_task IN nav$network_paged_heap^;
      WHILEND;
    IFEND;

  PROCEND wakeup_waiting_tasks;
?? OLDTITLE ??
?? OLDTITLE ??
MODEND rfm$external_interface;
*DECK DECK=RFM$MANAGE_RHFAM_NETWORK EXPAND=TRUE
*copyc osd$default_pragmats
MODULE rfm$manage_rhfam_network;
?? TITLE := 'MANAGE_RHFAM_NETWORK' ??
?? NEWTITLE := '  RING BRACKETS 2DD' ??
?? NEWTITLE := '    XREF procedures', EJECT ??
*copyc amp$get_segment_pointer
*copyc amp$return
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$end_scan_command_file
*copyc clp$execute_command
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$horizontal_tab_display
*copyc clp$new_display_line
*copyc clp$open_display
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$scan_command_file
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc fsp$close_file
*copyc fsp$open_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$format_message
*copyc osp$get_message_level
*copyc osp$set_status_abnormal
*copyc pfp$attach
*copyc pmp$establish_condition_handler
*copyc pmp$generate_unique_name
*copyc pmp$long_term_wait
*copyc pmt$task_id
*copyc rfp$activate_rhfam_client
*copyc rfp$activate_rhfam_server
*copyc rfp$change_host_or_lid_state
*copyc rfp$change_nad_or_trunk_state
*copyc rfp$deactivate_rhfam_client
*copyc rfp$deactivate_rhfam_server
*copyc rfp$define_rhfam_client
*copyc rfp$define_rhfam_server
*copyc rfp$delete_rhfam_client
*copyc rfp$delete_rhfam_server
*copyc rfp$display_active_appl_r3
*copyc rfp$display_rhfam_clients
*copyc rfp$display_rhfam_servers
*copyc rfp$display_rhfam_elements
*copyc rfp$display_routing_info_r3
*copyc rfp$check_local_nad_test
*copyc rfp$initiate_local_nad_test
?? TITLE := '    INLINE procedures', EJECT ??
  PROCEDURE [INLINE] check_page_width (value: clt$value; display_control: clt$display_control;
    VAR status: ost$status);

    IF display_control.page_width < rfc$minimum_page_size THEN
      osp$set_status_abnormal (rfc$product_id, rfe$illegal_output_file, value.file.local_file_name,
            status);
      osp$append_status_integer (osc$status_parameter_delimiter, rfc$minimum_page_size,
        10, FALSE, status);
      status.normal := FALSE;
     IFEND;

  PROCEND check_page_width;
?? EJECT ??
*copyc rfp$verify_caller_capability
?? TITLE := '    TYPE/CONST Definitions', EJECT ??

*copyc clt$path_display_chunks

  CONST
    rfc$minimum_page_size = 72;
?? PUSH (LISTEXT := ON) ??
*copyc rfe$condition_codes
?? POP ??
?? TITLE := '    GLOBAL variables', EJECT ??
*copyc oss$job_paged_literal
  VAR
    rfv$utility_name: [STATIC, READ, oss$job_paged_literal] ost$name :=
      'MANAGE_RHFAM_NETWORK';
*copyc osv$lower_to_upper
?? TITLE := '    rfp$manage_rhfam_network', EJECT ??

  PROCEDURE [XDCL, #GATE] rfp$manage_rhfam_network (parameter_list:
    clt$parameter_list;
    VAR status: ost$status);

*copyc rfh$manage_rhfam_network

*copyc rfd$pdt_manage_rhfam_network

    VAR
      capabilities: ARRAY[1..2] OF ost$name;
?? EJECT ??
*copyc rfd$cdt_manage_rhfam_network

    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, manage_rhfam_network_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    capabilities[1] := avc$network_applic_management;
    capabilities[2] := avc$network_operation;

    rfp$verify_caller_capability (^capabilities, 'MANAGE_RHFAM_NETWORK', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$push_utility (rfv$utility_name, clc$global_command_search, manrn_command_list, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_command_file (clc$current_command_input, rfv$utility_name, 'MRN', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$pop_utility (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND rfp$manage_rhfam_network;
?? TITLE := '    activate_rhfam_client',EJECT ??
  PROCEDURE activate_rhfam_client (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copyc rfh$activate_rhfam_client
*copyc rfd$pdt_activate_rhfam_client

    VAR
      client: rft$application_name,
      capability: ARRAY[1..1] OF ost$name,
      value: clt$value;
??EJECT ??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, activate_rhfam_cli_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    capability[1] := avc$network_applic_management;

    rfp$verify_caller_capability (^capability, 'ACTIVATE_RHFAM_CLIENT', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('CLIENT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    client := value.name.value;

    rfp$activate_rhfam_client (client, status);

  PROCEND activate_rhfam_client;
?? TITLE := '    activate_rhfam_server',EJECT ??
  PROCEDURE activate_rhfam_server (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copyc rfh$activate_rhfam_server
*copyc rfd$pdt_activate_rhfam_server

    VAR
      server: rft$application_name,
      capability: ARRAY[1..1] OF ost$name,
      value: clt$value;
??EJECT??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, activate_rhfam_ser_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    capability[1] := avc$network_applic_management;

    rfp$verify_caller_capability (^capability, 'ACTIVATE_RHFAM_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('SERVER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server := value.name.value;

    rfp$activate_rhfam_server (server, status);

  PROCEND activate_rhfam_server;
?? TITLE := '    change_host_state',EJECT ??
  PROCEDURE change_host_state (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copy  rfh$change_host_state

    VAR
      physical_id_list_p: ^ARRAY [1 .. *] OF rft$physical_identifier,
      all_pids_specified,
      state: BOOLEAN,
      capability: ARRAY[1..1] OF ost$name;
?? EJECT ??
    status.normal := TRUE;

    capability[1] := avc$network_operation;

    rfp$verify_caller_capability (^capability, 'CHANGE_HOST_STATE', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rfp$change_host_state (parameter_list, physical_id_list_p, all_pids_specified, state, status);
    IF status.normal THEN
      rfp$change_host_or_lid_state (physical_id_list_p, NIL, all_pids_specified, state, status);
    IFEND;
    IF physical_id_list_p <> NIL THEN
      FREE physical_id_list_p;
    IFEND;

  PROCEND change_host_state;
?? TITLE := '    rfp$change_host_state',EJECT ??
  PROCEDURE [XDCL] rfp$change_host_state (parameter_list: clt$parameter_list;
    VAR physical_id_list_p: ^ARRAY [1 .. *] OF rft$physical_identifier;
    VAR all_pids_specified: BOOLEAN;
    VAR state: BOOLEAN;
    VAR status: ost$status);

*copy  rfh$change_host_state
*copyc rfd$pdt_change_host_state

    VAR
      i: INTEGER,
      set_count: 0 .. clc$max_value_sets,
      value: clt$value;
?? EJECT ??
    status.normal := TRUE;
    physical_id_list_p := NIL;

    clp$scan_parameter_list (parameter_list, change_host_state_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('PHYSICAL_IDENTIFIER', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE physical_id_list_p: [1 .. set_count];
    IF physical_id_list_p = NIL THEN
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'default heap', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$CHANGE_HOST_STATE',
          status);
    IFEND;

    all_pids_specified := FALSE;

    FOR i := 1 TO set_count DO

      clp$get_value ('PHYSICAL_IDENTIFIER', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE value.kind OF
      = clc$name_value =
        IF set_count > 1 THEN
          osp$set_status_abnormal (rfc$product_id, rfe$too_many_key_values, value.name.value, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'PHYSICAL_IDENTIFIER', status);
          RETURN;
        IFEND;
        all_pids_specified := TRUE;
        physical_id_list_p^[i] := '';
      = clc$string_value =
        #TRANSLATE (osv$lower_to_upper, value.str.value,  physical_id_list_p^[i]);
      CASEND;

    FOREND;

    clp$get_value ('STATE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.name.value = 'OFF' THEN
      state := TRUE;
    ELSE
      state := FALSE;
    IFEND;


  PROCEND rfp$change_host_state;
?? TITLE := '    change_lid_state',EJECT ??
  PROCEDURE change_lid_state (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copy  rfh$change_lid_state

    VAR
      logical_id_list_p: ^ARRAY [1 .. *] OF rft$logical_identifier,
      physical_id_list_p: ^ARRAY [1 .. *] OF rft$physical_identifier,
      all_pids_specified,
      state: BOOLEAN,
      capability: ARRAY[1..1] OF ost$name;
?? EJECT ??
    status.normal := TRUE;

    capability[1] := avc$network_operation;

    rfp$verify_caller_capability (^capability, 'CHANGE_LID_STATE', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rfp$change_lid_state (parameter_list, physical_id_list_p, logical_id_list_p, all_pids_specified,
                             state, status);
    IF status.normal THEN
      rfp$change_host_or_lid_state (physical_id_list_p, logical_id_list_p, all_pids_specified, state, status);
    IFEND;

    IF physical_id_list_p <> NIL THEN
      FREE physical_id_list_p;
    IFEND;
    IF logical_id_list_p <> NIL THEN
      FREE logical_id_list_p;
    IFEND;

  PROCEND change_lid_state;
?? TITLE := '    rfp$change_lid_state',EJECT ??
  PROCEDURE [XDCL] rfp$change_lid_state (parameter_list: clt$parameter_list;
    VAR physical_id_list_p: ^ARRAY [1 .. *] OF rft$physical_identifier;
    VAR logical_id_list_p: ^ARRAY [1 .. *] OF rft$logical_identifier;
    VAR all_pids_specified: BOOLEAN;
    VAR state: BOOLEAN;
    VAR status: ost$status);

*copy  rfh$change_lid_state
*copyc rfd$pdt_change_lid_state

    VAR
      i: INTEGER,
      set_count: 0 .. clc$max_value_sets,
      value: clt$value;
?? EJECT ??
    status.normal := TRUE;
    physical_id_list_p := NIL;
    logical_id_list_p := NIL;

    clp$scan_parameter_list (parameter_list, change_lid_state_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('PHYSICAL_IDENTIFIER', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE physical_id_list_p: [1 .. set_count];
    IF physical_id_list_p = NIL THEN
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'default heap', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$CHANGE_LID_STATE',
          status);
    IFEND;
    all_pids_specified := FALSE;

    FOR i := 1 TO set_count DO

      clp$get_value ('PHYSICAL_IDENTIFIER', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE value.kind OF
      = clc$name_value =
        IF set_count > 1 THEN
          osp$set_status_abnormal (rfc$product_id, rfe$too_many_key_values, value.name.value, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'PHYSICAL_IDENTIFIER', status);
          RETURN;
        IFEND;
        all_pids_specified := TRUE;
        physical_id_list_p^[i] := '';
      = clc$string_value =
        #TRANSLATE (osv$lower_to_upper, value.str.value,  physical_id_list_p^[i]);
      CASEND;

    FOREND;

    clp$get_set_count ('LOGICAL_IDENTIFIER', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE logical_id_list_p: [1 .. set_count];
    IF logical_id_list_p = NIL THEN
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'default heap', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$CHANGE_LID_STATE',
          status);
    IFEND;

    FOR i := 1 TO set_count DO

      clp$get_value ('LOGICAL_IDENTIFIER', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #TRANSLATE (osv$lower_to_upper, value.str.value,  logical_id_list_p^[i]);

    FOREND;

    clp$get_value ('STATE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.name.value = 'OFF' THEN
      state := TRUE;
    ELSE
      state := FALSE;
    IFEND;

  PROCEND rfp$change_lid_state;
?? TITLE := '    change_nad_state',EJECT ??
  PROCEDURE change_nad_state (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copy  rfh$change_nad_state

    VAR
      nad_list_p: ^ARRAY [1 .. *] OF rft$component_name,
      state: rft$element_state,
      capability: ARRAY[1..1] OF ost$name;
?? EJECT ??
    status.normal := TRUE;

    capability[1] := avc$network_operation;

    rfp$verify_caller_capability (^capability, 'CHANGE_NAD_STATE', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rfp$change_nad_state (parameter_list, nad_list_p, status);
    IF status.normal THEN
      rfp$change_nad_or_trunk_state (nad_list_p, NIL, state, status);
    IFEND;
    IF nad_list_p <> NIL THEN
      FREE nad_list_p;
    IFEND;

  PROCEND change_nad_state;
?? TITLE := '    rfp$change_nad_state',EJECT ??
  PROCEDURE [XDCL] rfp$change_nad_state (parameter_list: clt$parameter_list;
    VAR nad_list_p: ^ARRAY [1 .. *] OF rft$component_name;
    VAR status: ost$status);

*copy  rfh$change_nad_state
*copyc rfd$pdt_change_nad_state

    VAR
      element_state: [STATIC, READ] ARRAY [rft$element_state] of ost$name := ['ON', 'OFF', 'DOWN'],
      i: INTEGER,
      set_count: 0 .. clc$max_value_sets,
      state: rft$element_state,
      value: clt$value;
?? EJECT ??
    status.normal := TRUE;
    nad_list_p := NIL;

    clp$scan_parameter_list (parameter_list, change_nad_state_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('NAD', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE nad_list_p: [1 .. set_count];
    IF nad_list_p = NIL THEN
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'default heap', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$CHANGE_NAD_STATE',
          status);
    IFEND;

    FOR i := 1 TO set_count DO

      clp$get_value ('NAD', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      nad_list_p^[i] := value.name.value;
    FOREND;

    clp$get_value ('STATE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    /state_loop/
      FOR state := LOWERVALUE(rft$element_state) TO UPPERVALUE(rft$element_state) DO
        IF element_state[state] = value.name.value THEN
          EXIT /state_loop/;
        IFEND;
      FOREND /state_loop/;

  PROCEND rfp$change_nad_state;
?? TITLE := '    change_trunk_state',EJECT ??
  PROCEDURE change_trunk_state (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copy  rfh$change_trunk_state

    VAR
      nad_list_p: ^ARRAY [1 .. *] OF rft$component_name,
      trunk_list_p: ^ARRAY [1 .. *] OF rft$component_name,
      state: rft$element_state,
      capability: ARRAY[1..1] OF ost$name;
?? EJECT ??
    status.normal := TRUE;

    capability[1] := avc$network_operation;

    rfp$verify_caller_capability (^capability, 'CHANGE_TRUNK_STATE', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rfp$change_trunk_state (parameter_list, nad_list_p, trunk_list_p, state, status);
    IF status.normal THEN
      rfp$change_nad_or_trunk_state (nad_list_p, trunk_list_p, state, status);
    IFEND;
    IF nad_list_p <> NIL THEN
      FREE nad_list_p;
    IFEND;
    IF trunk_list_p <> NIL THEN
      FREE trunk_list_p;
    IFEND;

  PROCEND change_trunk_state;
?? TITLE := '    rfp$change_trunk_state',EJECT ??
  PROCEDURE [XDCL] rfp$change_trunk_state (parameter_list: clt$parameter_list;
    VAR nad_list_p: ^ARRAY [1 .. *] OF rft$component_name;
    VAR trunk_list_p: ^ARRAY [1 .. *] OF rft$component_name;
    VAR state: rft$element_state;
    VAR status: ost$status);

*copy  rfh$change_trunk_state
*copyc rfd$pdt_change_trunk_state

    VAR
      element_state: [STATIC, READ] ARRAY [rft$element_state] of ost$name := ['ON', 'OFF', 'DOWN'],
      i: INTEGER,
      set_count: 0 .. clc$max_value_sets,
      value: clt$value;
?? EJECT ??
    status.normal := TRUE;
    nad_list_p := NIL;
    trunk_list_p := NIL;

    clp$scan_parameter_list (parameter_list, change_trunk_state_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('NAD', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE nad_list_p: [1 .. set_count];
    IF nad_list_p = NIL THEN
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'default heap', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$CHANGE_TRUNK_STATE',
          status);
    IFEND;

    FOR i := 1 TO set_count DO

      clp$get_value ('NAD', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (value.name.value = 'ALL') AND (set_count > 1) THEN
        osp$set_status_abnormal (rfc$product_id, rfe$too_many_key_values, value.name.value, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'NAD', status);
        RETURN;
      IFEND;
      nad_list_p^[i] := value.name.value;
    FOREND;

    clp$get_set_count ('TRUNK', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ALLOCATE trunk_list_p: [1 .. set_count];
    IF trunk_list_p = NIL THEN
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'default heap', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$CHANGE_TRUNK_STATE',
          status);
    IFEND;

    FOR i := 1 TO set_count DO

      clp$get_value ('TRUNK', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      trunk_list_p^[i] := value.name.value;
    FOREND;

    clp$get_value ('STATE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    /state_loop/
      FOR state := LOWERVALUE(rft$element_state) TO UPPERVALUE(rft$element_state) DO
        IF element_state[state] = value.name.value THEN
          EXIT /state_loop/;
        IFEND;
      FOREND /state_loop/;

  PROCEND rfp$change_trunk_state;
?? TITLE := '    deactivate_rhfam_client',EJECT ??
  PROCEDURE deactivate_rhfam_client (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copyc rfh$deactivate_rhfam_client
*copyc rfd$pdt_deactivate_rhfam_client

    VAR
      client: rft$application_name,
      capability: ARRAY[1..1] OF ost$name,
      terminate,
      value: clt$value;
??EJECT??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, deact_rhfam_client_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    capability[1] := avc$network_applic_management;

    rfp$verify_caller_capability (^capability, 'DEACTIVATE_RHFAM_CLIENT', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('CLIENT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    client := value.name.value;

    clp$get_value ('TERMINATE_ACTIVE_CONNECTIONS', 1, 1, clc$low, terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rfp$deactivate_rhfam_client (client, terminate.bool.value, status);

  PROCEND deactivate_rhfam_client;
?? TITLE := '    deactivate_rhfam_server',EJECT ??
  PROCEDURE deactivate_rhfam_server (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copyc rfh$deactivate_rhfam_server
*copyc rfd$pdt_deactivate_rhfam_server

    VAR
      server: rft$application_name,
      capability: ARRAY[1..1] OF ost$name,
      terminate,
      value: clt$value;
??EJECT??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, deact_rhfam_server_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    capability[1] := avc$network_applic_management;

    rfp$verify_caller_capability (^capability, 'DEACTIVATE_RHFAM_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('SERVER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server := value.name.value;

    clp$get_value ('TERMINATE_ACTIVE_CONNECTIONS', 1, 1, clc$low, terminate, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rfp$deactivate_rhfam_server (server, terminate.bool.value, status);

  PROCEND deactivate_rhfam_server;
?? TITLE := '    define_rhfam_client',EJECT ??
  PROCEDURE define_rhfam_client (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copyc rfh$define_rhfam_client
*copyc rfd$pdt_define_rhfam_client

    VAR
      client: rft$application_name,
      maximum_connections: rft$application_connections,
      user_capability: ost$name,
      ring: ost$ring,
      system_wide_connection_mgmt,
      system_privilege: boolean,
      capability: ARRAY[1..1] OF ost$name,
      value: clt$value;
??EJECT??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, define_rhfam_client_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    capability[1] := avc$network_applic_management;

    rfp$verify_caller_capability (^capability, 'DEFINE_RHFAM_CLIENT', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('CLIENT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.name.value = 'ALL' THEN
      osp$set_status_abnormal (rfc$product_id, rfe$all_is_not_a_legal_name, 'CLIENT', status);
      RETURN;
    IFEND;

    client := value.name.value;

    clp$get_value ('MAXIMUM_CONNECTIONS', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    maximum_connections := value.int.value;

    clp$get_value ('USER_CAPABILITY', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.name.value = 'NONE' THEN
      user_capability := osc$null_name;
    ELSE
      user_capability := value.name.value;
    IFEND;

    clp$get_value ('RING', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ring := value.int.value;

    clp$get_value ('SYSTEM_PRIVILEGE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    system_privilege := value.bool.value;

    clp$get_value ('SYSTEM_WIDE_CONNECTION_MGMT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    system_wide_connection_mgmt := value.bool.value;

    rfp$define_rhfam_client (client, maximum_connections, user_capability, ring,
          system_privilege ,system_wide_connection_mgmt, status);

  PROCEND define_rhfam_client;
?? TITLE := '    define_rhfam_server',EJECT ??
  PROCEDURE define_rhfam_server (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copyc rfh$define_rhfam_server
*copyc rfd$pdt_define_rhfam_server

    VAR
      server: rft$application_name,
      rhfam_initiated: boolean,
      maximum_connections: rft$application_connections,
      user_capability: ost$name,
      ring: ost$ring,
      system_privilege: boolean,
      server_job: amt$local_file_name,
      server_job_max_connections: rft$application_connections,
      server_job_specified: boolean,
      accept_connection: boolean,
      rhfam_validates_connection_lid: boolean,
      capability: ARRAY[1..1] OF ost$name,
      value: clt$value;
??EJECT ??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, define_rhfam_server_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    capability[1] := avc$network_applic_management;

    rfp$verify_caller_capability (^capability, 'DEFINE_RHFAM_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('SERVER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.name.value = 'ALL' THEN
      osp$set_status_abnormal (rfc$product_id, rfe$all_is_not_a_legal_name, 'SERVER', status);
      RETURN;
    IFEND;

    server := value.name.value;

    clp$get_value ('RHFAM_INITIATED', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rhfam_initiated := value.bool.value;

    clp$get_value ('MAXIMUM_CONNECTIONS', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    maximum_connections := value.int.value;

    clp$get_value ('USER_CAPABILITY', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF value.name.value = 'NONE' THEN
      user_capability := osc$null_name;
    ELSE
      user_capability := value.name.value;
    IFEND;

    clp$get_value ('RING', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    ring := value.int.value;

    clp$get_value ('SYSTEM_PRIVILEGE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    system_privilege := value.bool.value;

    clp$get_value ('ACCEPT_CONNECTION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    accept_connection := value.bool.value;

    clp$get_value ('RHFAM_VALIDATES_CONNECTION_LID', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rhfam_validates_connection_lid := value.bool.value;

    server_job := osc$null_name;
    server_job_max_connections := 0;

    IF rhfam_initiated THEN

      clp$test_parameter ('SERVER_JOB', server_job_specified, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF NOT server_job_specified THEN
        osp$set_status_abnormal (rfc$product_id, rfe$server_job_not_specified, server, status);
        RETURN;
      ELSE;
        clp$get_value ('SERVER_JOB', 1, 1, clc$low, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        server_job := value.file.local_file_name;
      IFEND;

      clp$get_value ('SERVER_JOB_MAXIMUM_CONNECTIONS', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      server_job_max_connections := value.int.value;
    IFEND;

    rfp$define_rhfam_server (server, rhfam_initiated, maximum_connections, user_capability, ring,
          system_privilege, server_job, server_job_max_connections, accept_connection,
          rhfam_validates_connection_lid, status);

  PROCEND define_rhfam_server;
?? TITLE := '    delete_rhfam_client',EJECT ??
  PROCEDURE delete_rhfam_client (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copyc rfh$delete_rhfam_client
*copyc rfd$pdt_delete_rhfam_client

    VAR
      client: rft$application_name,
      capability: ARRAY[1..1] OF ost$name,
      value: clt$value;
??EJECT??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, delete_rhfam_client_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    capability[1] := avc$network_applic_management;

    rfp$verify_caller_capability (^capability, 'DELETE_RHFAM_CLIENT', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('CLIENT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    client := value.name.value;

    rfp$delete_rhfam_client (client, status);

  PROCEND delete_rhfam_client;
?? TITLE := '    delete_rhfam_server',EJECT ??
  PROCEDURE delete_rhfam_server (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copyc rfh$delete_rhfam_server
*copyc rfd$pdt_delete_rhfam_server

    VAR
      server: rft$application_name,
      capability: ARRAY[1..1] OF ost$name,
      value: clt$value;
??EJECT??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, delete_rhfam_server_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    capability[1] := avc$network_applic_management;

    rfp$verify_caller_capability (^capability, 'DELETE_RHFAM_SERVER', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('SERVER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    server := value.name.value;

    rfp$delete_rhfam_server (server, status);

  PROCEND delete_rhfam_server;
?? TITLE := '    display_active_appl', EJECT ??
*block
  PROCEDURE display_active_appl (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copyc rfh$display_active_applications
*copyc rfd$pdt_display_active_appl

    VAR
      display_control: clt$display_control,
      job_name_list_p: ^ARRAY [1 .. *] OF ost$name,
      application_name_list_p: ^ARRAY [1 .. *] OF rft$application_name,
      display_type: rft$application_display_type,
      i: INTEGER,
      output_open_status,
      ignore_status: ost$status,
      set_count: 0 .. clc$max_value_sets,
      value: clt$value;

*copyc clv$display_variables
*copyc clp$abort_handler
?? NEWTITLE := '      clean_up', EJECT ??
    PROCEDURE clean_up;

      VAR
        ignore_status: ost$status;

      IF output_open_status.normal THEN
        clp$close_display (display_control,ignore_status);
      IFEND;

    PROCEND clean_up;
?? OLDTITLE, EJECT ??
?? NEWTITLE := '      put_subtitle', EJECT ??
    PROCEDURE put_subtitle (VAR display_control: clt$display_control;
      VAR status: ost$status);

      { The display_active_appl command has subtitles, but they are
      { written by another routine. This is a dummy routine to keep the module
      { consistent.

    PROCEND put_subtitle;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_active_appl_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DISPLAY_OPTION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (value.name.value = 'APPLICATIONS') OR (value.name.value = 'A') THEN
      display_type := rfc$adt_applications;
    ELSE
      display_type := rfc$adt_connections;
    IFEND;

    clp$get_set_count ('JOB_NAME', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH job_name_list_p: [1 .. set_count];

    FOR i := 1 TO set_count DO

      clp$get_value ('JOB_NAME', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (value.name.value = 'ALL') AND (set_count > 1) THEN
        osp$set_status_abnormal (rfc$product_id, rfe$too_many_key_values, value.name.value, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'JOB_NAME', status);
        RETURN;
      IFEND;
      job_name_list_p^[i] := value.name.value;
    FOREND;

    clp$get_set_count ('APPLICATION_NAME', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH application_name_list_p: [1 .. set_count];

    FOR i := 1 TO set_count DO

      clp$get_value ('APPLICATION_NAME', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (value.name.value = 'ALL') AND (set_count > 1) THEN
        osp$set_status_abnormal (rfc$product_id, rfe$too_many_key_values, value.name.value, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'APPLICATION_NAME',
              status);
        RETURN;
      IFEND;
      application_name_list_p^[i] := value.name.value;
    FOREND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /display_appl/
    BEGIN

      output_open_status.normal := FALSE;

      pmp$establish_condition_handler (clv$abort_conditions, ^clp$abort_handler,
            ^clv$established_abort_handler, status);
      IF NOT status.normal THEN
        EXIT /display_appl/;
      IFEND;

{     A new page procedure is not specified on clp$open_display because the
{     display is generated by ring 3 code.  If a new page procedure is specified
{     it is loaded at ring 11 and causes an outward call/inward return error
{     when writing to a file other than output.

      clp$open_display (value.file, NIL, display_control, output_open_status);
      IF NOT output_open_status.normal THEN
        status := output_open_status;
        EXIT /display_appl/;
      IFEND;

      clv$titles_built := FALSE;
      clv$command_name := 'display_active_applications';

      check_page_width (value, display_control, status);
      IF NOT status.normal THEN
        EXIT /display_appl/;
      IFEND;

      rfp$display_active_appl_r3 (job_name_list_p^, application_name_list_p^, display_type,
            display_control, status);
      IF NOT status.normal THEN
        EXIT /display_appl/;
      IFEND;

    END /display_appl/;

    IF output_open_status.normal THEN
      clp$close_display (display_control, ignore_status);
    IFEND;

  PROCEND display_active_appl;
*blockend
?? TITLE := '    display_nad_status', EJECT ??
*block
  PROCEDURE display_nad_status (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copyc rfh$display_nad_status
*copyc rfd$pdt_display_nad_status

    VAR
      display_control: clt$display_control,
      display_option: rft$display_option,
      display_type: rft$element_display_type,
      local_nad_list_p: ^ARRAY [1 .. *] OF rft$component_name,
      remote_nad_list_p: ^ARRAY [1 .. *] OF rft$component_name,
      i: INTEGER,
      output_open_status,
      ignore_status: ost$status,
      set_count: 0 .. clc$max_value_sets,
      value: clt$value;

*copyc clv$display_variables
*copyc clp$abort_handler
?? NEWTITLE := '      clean_up', EJECT ??
    PROCEDURE clean_up;

      VAR
        ignore_status: ost$status;

      IF output_open_status.normal THEN
        clp$close_display (display_control,ignore_status);
      IFEND;

    PROCEND clean_up;
?? PUSH (LISTEXT := ON) ??
?? OLDTITLE, EJECT ??
?? NEWTITLE := '      put_subtitle', EJECT ??
    PROCEDURE put_subtitle (VAR display_control: clt$display_control;
      VAR status: ost$status);

      { The display_nad_status command has subtitles, but they are written
      { by another routine. This is a dummy routine to keep the module
      { consistent.

    PROCEND put_subtitle;
?? POP ??
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_nad_status_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DISPLAY_OPTION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (value.name.value = 'BRIEF') OR (value.name.value = 'B') THEN
      display_option := rfc$do_brief;
    ELSE
      display_option := rfc$do_full;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /display_nad/
    BEGIN

      output_open_status.normal := FALSE;

      pmp$establish_condition_handler (clv$abort_conditions, ^clp$abort_handler,
            ^clv$established_abort_handler, status);
      IF NOT status.normal THEN
        EXIT /display_nad/;
      IFEND;

{     A new page procedure is not specified on clp$open_display because the
{     display is generated by ring 3 code.  If a new page procedure is specified
{     it is loaded at ring 11 and causes an outward call/inward return error
{     when writing to a file other than output.

      clp$open_display (value.file, NIL, display_control, output_open_status);
      IF NOT output_open_status.normal THEN
        status := output_open_status;
        EXIT /display_nad/;
      IFEND;

      clv$titles_built := FALSE;
      clv$command_name := 'display_nad_status';

      check_page_width (value, display_control, status);
      IF NOT status.normal THEN
        EXIT /display_nad/;
      IFEND;

      clp$get_set_count ('LOCAL_NAD', set_count, status);
      IF NOT status.normal THEN
        EXIT /display_nad/;
      IFEND;

    /display_local_nads/
      BEGIN

        PUSH local_nad_list_p: [1 .. set_count];
        display_type := rfc$edt_local_nads;

        FOR i := 1 TO set_count DO

          clp$get_value ('LOCAL_NAD', i, 1, clc$low, value, status);
          IF NOT status.normal THEN
            EXIT /display_nad/;
          IFEND;

          IF ((value.name.value = 'ALL') OR (value.name.value = 'NONE')) AND (set_count > 1) THEN
            osp$set_status_abnormal (rfc$product_id, rfe$too_many_key_values, value.name.value, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'LOCAL_NAD', status);
            EXIT /display_nad/;
          IFEND;

          IF value.name.value = 'NONE' THEN
            EXIT /display_local_nads/;
          IFEND;

          local_nad_list_p^[i] := value.name.value;
        FOREND;

        rfp$display_rhfam_elements (local_nad_list_p^, display_type, display_option, display_control,
               status);
        IF NOT status.normal THEN
          EXIT /display_nad/;
        IFEND;

      END /display_local_nads/;

      clp$get_set_count ('REMOTE_NAD', set_count, status);
      IF NOT status.normal THEN
        EXIT /display_nad/;
      IFEND;

    /display_remote_nads/
      BEGIN

        PUSH remote_nad_list_p: [1 .. set_count];
        display_type := rfc$edt_remote_nads;

        FOR i := 1 TO set_count DO

          clp$get_value ('REMOTE_NAD', i, 1, clc$low, value, status);
          IF NOT status.normal THEN
            EXIT /display_nad/;
          IFEND;

          IF ((value.name.value = 'ALL') OR (value.name.value = 'NONE')) AND (set_count > 1) THEN
            osp$set_status_abnormal (rfc$product_id, rfe$too_many_key_values, value.name.value, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'REMOTE_NAD', status);
            EXIT /display_nad/;
          IFEND;

          IF value.name.value = 'NONE' THEN
            EXIT /display_remote_nads/;
          IFEND;

          remote_nad_list_p^[i] := value.name.value;
        FOREND;

        rfp$display_rhfam_elements (remote_nad_list_p^, display_type, display_option, display_control,
              status);
        IF NOT status.normal THEN
          EXIT /display_nad/;
        IFEND;

      END /display_remote_nads/;

    END /display_nad/;

    IF output_open_status.normal THEN
      clp$close_display (display_control, ignore_status);
    IFEND;

  PROCEND display_nad_status;
*blockend
?? TITLE := '    display_rhfam_clients', EJECT ??
*block
  PROCEDURE display_rhfam_clients (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copyc rfh$display_rhfam_clients
*copyc rfd$pdt_display_rhfam_clients

    VAR
      display_control: clt$display_control,
      client_list_p: ^ARRAY [1 .. *] OF rft$application_name,
      i: INTEGER,
      output_open_status,
      ignore_status: ost$status,
      set_count: 0 .. clc$max_value_sets,
      value: clt$value;

*copyc clv$display_variables
*copyc clp$abort_handler
?? NEWTITLE := '      clean_up', EJECT ??
    PROCEDURE clean_up;

      VAR
        ignore_status: ost$status;

      IF output_open_status.normal THEN
        clp$close_display (display_control,ignore_status);
      IFEND;

    PROCEND clean_up;
?? PUSH (LISTEXT := ON) ??
?? OLDTITLE, EJECT ??
?? NEWTITLE := '      put_subtitle', EJECT ??
    PROCEDURE put_subtitle (VAR display_control: clt$display_control;
      VAR status: ost$status);

      { The display_rhfam_clients command has subtitles, but they are written
      { by another routine. This is a dummy routine to keep the module
      { consistent.

    PROCEND put_subtitle;
?? POP ??
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_rhfam_client_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('CLIENT', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH client_list_p: [1 .. set_count];

    FOR i := 1 TO set_count DO

      clp$get_value ('CLIENT', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (value.name.value = 'ALL') AND (set_count > 1) THEN
        osp$set_status_abnormal (rfc$product_id, rfe$too_many_key_values, value.name.value, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'CLIENT_DEFINITION', status);
        RETURN;
      IFEND;

      client_list_p^[i] := value.name.value;
    FOREND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /display_clients/
    BEGIN

      output_open_status.normal := FALSE;

      pmp$establish_condition_handler (clv$abort_conditions, ^clp$abort_handler,
            ^clv$established_abort_handler, status);
      IF NOT status.normal THEN
        EXIT /display_clients/;
      IFEND;

{     A new page procedure is not specified on clp$open_display because the
{     display is generated by ring 3 code.  If a new page procedure is specified
{     it is loaded at ring 11 and causes an outward call/inward return error
{     when writing to a file other than output.

      clp$open_display (value.file, NIL, display_control, output_open_status);
      IF NOT output_open_status.normal THEN
        status := output_open_status;
        EXIT /display_clients/;
      IFEND;

      clv$titles_built := FALSE;
      clv$command_name := 'display_rhfam_clients';

      check_page_width (value, display_control, status);
      IF NOT status.normal THEN
        EXIT /display_clients/;
      IFEND;

      rfp$display_rhfam_clients (client_list_p^, display_control, status);
      IF NOT status.normal THEN
        EXIT /display_clients/;
      IFEND;

    END /display_clients/;

    IF output_open_status.normal THEN
      clp$close_display (display_control, ignore_status);
    IFEND;

  PROCEND display_rhfam_clients;
*blockend
?? TITLE := '    display_rhfam_servers', EJECT ??
*block
  PROCEDURE display_rhfam_servers (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copyc rfh$display_rhfam_servers
*copyc rfd$pdt_display_rhfam_servers

    VAR
      display_control: clt$display_control,
      server_list_p: ^ARRAY [1 .. *] OF rft$application_name,
      i: INTEGER,
      output_open_status,
      ignore_status: ost$status,
      set_count: 0 .. clc$max_value_sets,
      value: clt$value;

*copyc clv$display_variables
*copyc clp$abort_handler
?? NEWTITLE := '      clean_up', EJECT ??
    PROCEDURE clean_up;

      VAR
        ignore_status: ost$status;

      IF output_open_status.normal THEN
        clp$close_display (display_control,ignore_status);
      IFEND;

    PROCEND clean_up;
?? PUSH (LISTEXT := ON) ??
?? OLDTITLE, EJECT ??
?? NEWTITLE := '      put_subtitle', EJECT ??
    PROCEDURE put_subtitle (VAR display_control: clt$display_control;
      VAR status: ost$status);

      { The display_rhfam_server command has subtitles, but they are written
      { by another routine. This is a dummy routine to keep the module
      { consistent.

    PROCEND put_subtitle;
?? POP ??
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_rhfam_server_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('SERVER', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH server_list_p: [1 .. set_count];

    FOR i := 1 TO set_count DO

      clp$get_value ('SERVER', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (value.name.value = 'ALL') AND (set_count > 1) THEN
        osp$set_status_abnormal (rfc$product_id, rfe$too_many_key_values, value.name.value, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'SERVER_DEFINITION', status);
        RETURN;
      IFEND;

      server_list_p^[i] := value.name.value;
    FOREND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /display_servers/
    BEGIN

      output_open_status.normal := FALSE;

      pmp$establish_condition_handler (clv$abort_conditions, ^clp$abort_handler,
            ^clv$established_abort_handler, status);
      IF NOT status.normal THEN
        EXIT /display_servers/;
      IFEND;

{     A new page procedure is not specified on clp$open_display because the
{     display is generated by ring 3 code.  If a new page procedure is specified
{     it is loaded at ring 11 and causes an outward call/inward return error
{     when writing to a file other than output.

      clp$open_display (value.file, NIL, display_control, output_open_status);
      IF NOT output_open_status.normal THEN
        status := output_open_status;
        EXIT /display_servers/;
      IFEND;

      clv$titles_built := FALSE;
      clv$command_name := 'display_rhfam_servers';

      check_page_width (value, display_control, status);
      IF NOT status.normal THEN
        EXIT /display_servers/;
      IFEND;

      rfp$display_rhfam_servers (server_list_p^, display_control, status);
      IF NOT status.normal THEN
        EXIT /display_servers/;
      IFEND;

    END /display_servers/;

    IF output_open_status.normal THEN
      clp$close_display (display_control, ignore_status);
    IFEND;

  PROCEND display_rhfam_servers;
*blockend
?? TITLE := '    display_logical_identifier', EJECT ??
  PROCEDURE display_logical_identifier (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copyc rfh$display_logical_ids
*copyc rfd$pdt_display_logical_ids

    display_routing_info (parameter_list, display_logical_id_pdt, TRUE, status);

  PROCEND display_logical_identifier;
?? TITLE := '    display_physical_path', EJECT ??
  PROCEDURE display_physical_path (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copyc rfh$display_physical_paths
*copyc rfd$pdt_display_physical_paths

    display_routing_info (parameter_list, display_phys_paths_pdt, FALSE, status);

  PROCEND display_physical_path;
?? TITLE := '    display_routing_info', EJECT ??
*block
  PROCEDURE display_routing_info (parameter_list: clt$parameter_list;
        display_routing_info_pdt: clt$parameter_descriptor_table;
        logical_id_display: BOOLEAN;
    VAR status: ost$status);

{
{     This procedure does the utility level common processing for the
{ DISPLAY_LOGICAL_IDENTIFIER and DISPLAY_PHYSICAL_PATH commands. The
{ parameters received by these command processors are passed to this
{ routine along with a boolean value to denote which command is being
{ processed.
{

    VAR
      configuration_header: ^string(rfc$config_label_length),
      display_control: clt$display_control,
      display_type: rft$routing_display_type,
      i: INTEGER,
      config_file_attach_status,
      config_file_open_status,
      output_open_status,
      ignore_status: ost$status,
      config_file_lfn: amt$local_file_name,
      config_file_id: amt$file_identifier,
      config_file_p: amt$segment_pointer,
      all_pids_specified,
      all_lids_specified,
      local_pid_specified: BOOLEAN,
      logical_id_list_p: ^ARRAY [1 .. *] OF rft$logical_identifier,
      physical_id_list_p: ^ARRAY [1 .. *] OF rft$physical_identifier,
      path: ^pft$path,
      password: pft$name,
      usage_selections: pft$usage_selections,
      share_selections: pft$share_selections,
      cycle_selector: pft$cycle_selector,
      set_count: 0 .. clc$max_value_sets,
      unique_name: ost$unique_name,
      value: clt$value;
*copyc clv$display_variables
*copyc clp$abort_handler
?? NEWTITLE := '      clean_up', EJECT ??
    PROCEDURE clean_up;

      VAR
        ignore_status: ost$status;

      IF config_file_open_status.normal THEN
        fsp$close_file (config_file_id, ignore_status);
        amp$return(config_file_lfn, ignore_status);
      ELSEIF config_file_attach_status.normal THEN
        amp$return(config_file_lfn, ignore_status);
      IFEND;

      IF output_open_status.normal THEN
        clp$close_display (display_control,ignore_status);
      IFEND;

    PROCEND clean_up;
?? PUSH (LISTEXT := ON) ??
?? OLDTITLE, EJECT ??
?? NEWTITLE := '      put_subtitle', EJECT ??
    PROCEDURE put_subtitle (VAR display_control: clt$display_control;
      VAR status: ost$status);

      { The display_logical_identifier and display_physical_paths commands
      { have subtitles, but they are written by another routine. This is a
      { dummy routine to keep the module consistent.

    PROCEND put_subtitle;
?? POP ??
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_routing_info_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_set_count ('PHYSICAL_IDENTIFIER', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH physical_id_list_p: [1 .. set_count];
    all_pids_specified := FALSE;
    local_pid_specified := FALSE;

    FOR i := 1 TO set_count DO

      clp$get_value ('PHYSICAL_IDENTIFIER', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE value.kind OF
      = clc$name_value =
        IF set_count > 1 THEN
          osp$set_status_abnormal (rfc$product_id, rfe$too_many_key_values, value.name.value, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'PHYSICAL_IDENTIFIER', status);
          RETURN;
        IFEND;
        local_pid_specified := TRUE;
        IF value.name.value = 'ALL' THEN
          all_pids_specified := TRUE;
        IFEND;
        physical_id_list_p^[i] := '';
      = clc$string_value =
        #TRANSLATE (osv$lower_to_upper, value.str.value,  physical_id_list_p^[i]);
      CASEND;

    FOREND;

    IF logical_id_display THEN
      display_type := rfc$rdt_lids;
      clv$command_name := 'display_logical_identifier';

      clp$get_set_count ('LOGICAL_IDENTIFIER', set_count, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      PUSH logical_id_list_p: [1 .. set_count];
      all_lids_specified := FALSE;

      FOR i := 1 TO set_count DO

        clp$get_value ('LOGICAL_IDENTIFIER', i, 1, clc$low, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        CASE value.kind OF
        = clc$name_value =
          IF set_count > 1 THEN
            osp$set_status_abnormal (rfc$product_id, rfe$too_many_key_values, value.name.value, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, 'LOGICAL_IDENTFIER', status);
            RETURN;
          IFEND;
          IF value.name.value <> 'NONE' THEN
            all_lids_specified := TRUE;
          IFEND;
          logical_id_list_p^[i] := '';
        = clc$string_value =
          #TRANSLATE (osv$lower_to_upper, value.str.value,  logical_id_list_p^[i]);
        CASEND;

      FOREND;

    ELSE
      display_type := rfc$rdt_paths;
      clv$command_name := 'display_physical_path';
      PUSH logical_id_list_p: [1..1];
      logical_id_list_p^[1] := '';
      all_lids_specified := FALSE;
    IFEND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /display_routing/
    BEGIN

      config_file_attach_status.normal := FALSE;
      config_file_open_status.normal := FALSE;
      output_open_status.normal := FALSE;

      pmp$establish_condition_handler (clv$abort_conditions, ^clp$abort_handler,
            ^clv$established_abort_handler, status);
      IF NOT status.normal THEN
        EXIT /display_routing/;
      IFEND;

{     A new page procedure is not specified on clp$open_display because the
{     display is generated by ring 3 code.  If a new page procedure is specified
{     it is loaded at ring 11 and causes an outward call/inward return error
{     when writing to a file other than output.

      clp$open_display (value.file, NIL, display_control, output_open_status);
      IF NOT output_open_status.normal THEN
        status := output_open_status;
        EXIT /display_routing/;
      IFEND;

      clv$titles_built := FALSE;

      check_page_width (value, display_control, status);
      IF NOT status.normal THEN
        EXIT /display_routing/;
      IFEND;

      clp$get_value ('DISPLAY_OPTION', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (value.name.value = 'INSTALLED') OR (value.name.value = 'I') THEN

        pmp$generate_unique_name (unique_name, status);
        IF NOT status.normal THEN
          EXIT /display_routing/;
        IFEND;

        config_file_lfn := unique_name.value;

        PUSH path : [1..4];
        path^[1] := rfc$rhfam_family_name;
        path^[2] := rfc$rhfam_master_catalog;
        path^[3] := rfc$rhfam_sub_catalog;
        path^[4] := rfc$configuration_file;
        usage_selections := $pft$usage_selections[pfc$read];
        share_selections := $pft$share_selections[pfc$read,pfc$execute];
        cycle_selector.cycle_option := pfc$highest_cycle;
        password := rfc$password;

        pfp$attach(config_file_lfn, path^, cycle_selector, password, usage_selections, share_selections,
               pfc$no_wait, config_file_attach_status);
        IF NOT config_file_attach_status.normal THEN
          status := config_file_attach_status;
          EXIT /display_routing/;
        IFEND;

        fsp$open_file (config_file_lfn, amc$segment, NIL, NIL, NIL, NIL, NIL, config_file_id,
              config_file_open_status);
        IF NOT config_file_open_status.normal THEN
          status := config_file_open_status;
          EXIT /display_routing/;
        IFEND;

        amp$get_segment_pointer (config_file_id, amc$sequence_pointer, config_file_p, status);
        IF NOT status.normal THEN
          EXIT /display_routing/;
        IFEND;
        RESET config_file_p.sequence_pointer;
        NEXT configuration_header IN config_file_p.sequence_pointer;
        IF (configuration_header = NIL) OR (configuration_header^ <> rfc$configuration_label) THEN
          osp$set_status_abnormal (rfc$product_id, rfe$not_an_rhfam_config_file,
                value.file.local_file_name, status);
          EXIT /display_routing/;
        IFEND;
      ELSE
        config_file_p.sequence_pointer := NIL;
      IFEND;

      rfp$display_routing_info_r3 (physical_id_list_p^, logical_id_list_p^, local_pid_specified,
            all_pids_specified, all_lids_specified, display_type, config_file_p.sequence_pointer,
            display_control, status);
      IF NOT status.normal THEN
        EXIT /display_routing/;
      IFEND;

    END /display_routing/;

    IF config_file_open_status.normal THEN
      fsp$close_file (config_file_id, ignore_status);
      amp$return(config_file_lfn, ignore_status);
    ELSEIF config_file_attach_status.normal THEN
      amp$return(config_file_lfn, ignore_status);
    IFEND;

    IF output_open_status.normal THEN
      clp$close_display (display_control, ignore_status);
    IFEND;

  PROCEND display_routing_info;
*blockend
?? TITLE := '    display_trunk_status', EJECT ??
*block
  PROCEDURE display_trunk_status (parameter_list: clt$parameter_list;
    VAR status: ost$status);

*copyc rfh$display_trunk_status
*copyc rfd$pdt_display_trunk_status

    VAR
      display_control: clt$display_control,
      display_option: rft$display_option,
      display_type: rft$element_display_type,
      trunk_list_p: ^ARRAY [1 .. *] OF rft$component_name,
      i: INTEGER,
      output_open_status,
      ignore_status: ost$status,
      set_count: 0 .. clc$max_value_sets,
      value: clt$value;
*copyc clv$display_variables
*copyc clp$abort_handler
?? NEWTITLE := '      clean_up', EJECT ??
    PROCEDURE clean_up;

      VAR
        ignore_status: ost$status;

      IF output_open_status.normal THEN
        clp$close_display (display_control,ignore_status);
      IFEND;

    PROCEND clean_up;
?? PUSH (LISTEXT := ON) ??
?? OLDTITLE, EJECT ??
?? NEWTITLE := '      put_subtitle', EJECT ??
    PROCEDURE put_subtitle (VAR display_control: clt$display_control;
      VAR status: ost$status);

      { The display_trunk_status command has subtitles, but they are written
      { by another routine. This is a dummy routine to keep the module
      { consistent.

    PROCEND put_subtitle;
?? POP ??
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, display_trunk_status_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DISPLAY_OPTION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (value.name.value = 'BRIEF') OR (value.name.value = 'B') THEN
      display_option := rfc$do_brief;
    ELSE
      display_option := rfc$do_full;
    IFEND;

    clp$get_set_count ('TRUNK', set_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH trunk_list_p: [1 .. set_count];
    display_type := rfc$edt_trunks;

    FOR i := 1 TO set_count DO

      clp$get_value ('TRUNK', i, 1, clc$low, value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF (value.name.value = 'ALL') AND (set_count > 1) THEN
        osp$set_status_abnormal (rfc$product_id, rfe$too_many_key_values, value.name.value, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'TRUNK', status);
        RETURN;
      IFEND;
      trunk_list_p^[i] := value.name.value;
    FOREND;

    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /display_trunk/
    BEGIN

      output_open_status.normal := FALSE;

      pmp$establish_condition_handler (clv$abort_conditions, ^clp$abort_handler,
            ^clv$established_abort_handler, status);
      IF NOT status.normal THEN
        EXIT /display_trunk/;
      IFEND;

{     A new page procedure is not specified on clp$open_display because the
{     display is generated by ring 3 code.  If a new page procedure is specified
{     it is loaded at ring 11 and causes an outward call/inward return error
{     when writing to a file other than output.

      clp$open_display (value.file, NIL, display_control, output_open_status);
      IF NOT output_open_status.normal THEN
        status := output_open_status;
        EXIT /display_trunk/;
      IFEND;

      clv$titles_built := FALSE;
      clv$command_name := 'display_trunk_status';

      check_page_width (value, display_control, status);
      IF NOT status.normal THEN
        EXIT /display_trunk/;
      IFEND;

      rfp$display_rhfam_elements (trunk_list_p^, display_type, display_option, display_control, status);
      IF NOT status.normal THEN
        EXIT /display_trunk/;
      IFEND;

    END /display_trunk/;

    IF output_open_status.normal THEN
      clp$close_display (display_control, ignore_status);
    IFEND;

  PROCEND display_trunk_status;
*blockend
*block
?? TITLE := '    format_nad_dump', EJECT ??
  PROCEDURE format_nad_dump (parameter_list: clt$parameter_list;
   VAR status: ost$status);

*copyc rfh$format_nad_dump
*copyc rfd$pdt_format_nad_dump

    CONST
      bytes_per_word = 2,
      words_per_item = 8,
      space_for_ascii_item = bytes_per_word * words_per_item,
      radix = 16,
      size_of_address = 4,
      spaces_bet_ad_and_display = 2,
      space_for_numeric_word = 4,
      space_for_numeric_item = words_per_item * (space_for_numeric_word + 1),
      fixed = size_of_address + spaces_bet_ad_and_display;

    VAR
      control_codes_to_space: [STATIC, READ] string (256) := '            '
            CAT '                     !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcd'
            CAT 'efghijklmnopqrstuvwxyz{|}~                                                                '
            CAT '                                                                 ',
      current_item: 1 .. 63,
      current_word: 1 .. words_per_item,
      display_address: 0 .. 0ffff(16),
      display_control: clt$display_control,
      first_item: ^cell,
      header: [STATIC, READ] string (80) := '   0    1    2    3    4    5    6    7'
            CAT '    8    9    A    B    C    D    E    F ',
      ignore_status: ost$status,
      item_ascii: ^string ( * ),
      items_per_line: 0 .. 100,
      line_buffer: ^string ( * ),
      line_index: 1 .. 256,
      micro_code_p: ^SEQ ( * ),
      nad_dump_file_id: amt$file_identifier,
      nad_dump_file_open_status,
      output_open_status,
      local_status: ost$status,
      nad_dump_file_attach: array [1 .. 3] of fst$attachment_option,
      nad_dump_file_p: amt$segment_pointer,
      page_width: amt$page_width,
      previous_line: ^string ( * ),
      repeated_lines: integer,
      word: ^0 .. 0ffff(16),
      words_this_line: 0 .. 16,
      value: clt$value;
*copyc clv$display_variables
*copyc clp$abort_handler
?? NEWTITLE := '      clean_up', EJECT ??
    PROCEDURE clean_up;

      VAR
        ignore_status: ost$status;

      IF nad_dump_file_open_status.normal THEN
        fsp$close_file (nad_dump_file_id, ignore_status);
      IFEND;

      IF output_open_status.normal THEN
        clp$close_display (display_control,ignore_status);
      IFEND;

    PROCEND clean_up;
*copyc clp$new_page_procedure
?? OLDTITLE, EJECT ??
?? NEWTITLE := '      print_subtitle', EJECT ??
    PROCEDURE print_subtitle (header: string (80);
      VAR status: ost$status);

      clp$new_display_line (display_control, 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$horizontal_tab_display (display_control, fixed + 1, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      clp$put_partial_display (display_control, header(1, space_for_numeric_item * items_per_line), clc$trim,
            amc$continue, status);

    PROCEND print_subtitle;
?? OLDTITLE, EJECT ??
?? NEWTITLE := '      put_subtitle', EJECT ??
    PROCEDURE put_subtitle (VAR display_control: clt$display_control;
      VAR status: ost$status);

      print_subtitle (header,status);

    PROCEND put_subtitle;
?? OLDTITLE, EJECT ??
?? NEWTITLE := '      display_status_message', EJECT ??
    PROCEDURE display_status_message (status_message: ost$status;
      VAR display_control: clt$display_control;
      VAR status: ost$status);

      VAR
        line_counter: ost$status_message_line_count,
        line_count: ^ost$status_message_line_count,
        line_size: ^ost$status_message_line_size,
        message: ^ost$status_message,
        message_level: ost$status_message_level,
        message_width: ost$max_status_message_line,
        message_line: ^string ( * );

      osp$get_message_level (message_level, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      PUSH message;
      RESET message;
      IF display_control.page_width < LOWERVALUE (message_width) THEN
        message_width := LOWERVALUE (message_width);
      ELSEIF display_control.page_width > UPPERVALUE (message_width) THEN
        message_width := UPPERVALUE (message_width);
      ELSE
        message_width := display_control.page_width;
      IFEND;
      osp$format_message (status_message, message_level, message_width, message^,
            status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      RESET message;
      NEXT line_count IN message;
      FOR line_counter := 1 TO line_count^ DO
        NEXT line_size IN message;
        NEXT message_line: [line_size^] IN message;
        clp$put_display (display_control, message_line^, clc$no_trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

    PROCEND display_status_message;
?? OLDTITLE ??
?? EJECT ??
    status.normal := TRUE;

    clp$scan_parameter_list (parameter_list, format_nad_dump_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$get_value ('OUTPUT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /format_dump/
    BEGIN

      nad_dump_file_open_status.normal := FALSE;
      output_open_status.normal := FALSE;

      pmp$establish_condition_handler (clv$abort_conditions, ^clp$abort_handler,
            ^clv$established_abort_handler, status);
      IF NOT status.normal THEN
        EXIT /format_dump/;
      IFEND;

      clp$open_display (value.file, ^clp$new_page_procedure, display_control, output_open_status);
      IF NOT output_open_status.normal THEN
        status := output_open_status;
        EXIT /format_dump/;
      IFEND;

      clv$titles_built := FALSE;
      clv$command_name := 'format_nad_dump';

      clp$get_value ('DUMP_FILE', 1, 1, clc$low, value, status);
      IF NOT status.normal THEN
        EXIT /format_dump/;
      IFEND;
      nad_dump_file_attach [1].selector := fsc$access_and_share_modes;
      nad_dump_file_attach [1].access_modes.selector := fsc$specific_access_modes;
      nad_dump_file_attach [1].access_modes.value := $fst$file_access_options [fsc$read];
      nad_dump_file_attach [1].share_modes.selector := fsc$determine_from_access_modes;
      nad_dump_file_attach [2].selector := fsc$create_file;
      nad_dump_file_attach [2].create_file := FALSE;
      nad_dump_file_attach [3].selector := fsc$open_position;
      nad_dump_file_attach [3].open_position := amc$open_at_boi;

      fsp$open_file (value.file.local_file_name, amc$segment, ^nad_dump_file_attach, NIL, NIL, NIL,
            NIL, nad_dump_file_id, nad_dump_file_open_status);
      IF NOT nad_dump_file_open_status.normal THEN
        status := nad_dump_file_open_status;
        EXIT /format_dump/;
      IFEND;

      amp$get_segment_pointer (nad_dump_file_id, amc$sequence_pointer, nad_dump_file_p, status);
      IF NOT status.normal THEN
        EXIT /format_dump/;
      IFEND;

      micro_code_p := nad_dump_file_p.sequence_pointer;
      RESET micro_code_p;
      NEXT word IN micro_code_p;
      IF word = NIL THEN
        osp$set_status_abnormal (rfc$product_id, rfe$nad_dump_file_empty,
              value.file.local_file_name, status);
        EXIT /format_dump/;
      IFEND;
      RESET micro_code_p;

      IF display_control.page_width > 132 THEN
        page_width := 132;
      ELSEIF display_control.page_width < 40 THEN
        page_width := 40;
      ELSE
        page_width := display_control.page_width;
      IFEND;
      items_per_line := (page_width - fixed) DIV (space_for_ascii_item +
            space_for_numeric_item);
      IF items_per_line = 0 THEN
        items_per_line := 1;
        page_width := fixed + space_for_ascii_item + space_for_numeric_item;
      IFEND;

      PUSH line_buffer: [page_width];
      PUSH previous_line: [page_width];

      previous_line^ := ' ';
      repeated_lines := 0;
      display_address := 0;

    /display_items/
      WHILE TRUE DO
        NEXT word IN micro_code_p;
        IF word = NIL THEN
          EXIT /format_dump/;
        IFEND;
        first_item := word;
        RESET micro_code_p TO first_item;

        line_buffer^ := '';
        line_index := 1;
        clp$convert_integer_to_rjstring (display_address, radix, FALSE, ' ',
              line_buffer^ (line_index, size_of_address), status);
        IF NOT status.normal THEN
          EXIT /format_dump/;
        IFEND;
        line_index := line_index + size_of_address + spaces_bet_ad_and_display;
        words_this_line := 0;

      /format_numeric/
        FOR current_item := 1 TO items_per_line DO
          FOR current_word := 1 TO words_per_item DO
            NEXT word IN micro_code_p;
            IF word = NIL THEN
              EXIT /format_numeric/;
            IFEND;
            IF word^ = 0 THEN
              line_buffer^ (line_index + (space_for_numeric_word - 4), 4) :=
                '----';
            ELSE
              clp$convert_integer_to_rjstring (word^, radix, FALSE, '0',
                    line_buffer^ (line_index, space_for_numeric_word), status);
              IF NOT status.normal THEN
                EXIT /format_dump/;
              IFEND;
            IFEND;
            line_index := line_index + space_for_numeric_word + 1;
            words_this_line := words_this_line + 1;
          FOREND;
        FOREND /format_numeric/;

        RESET micro_code_p TO first_item;
        NEXT item_ascii: [words_this_line * bytes_per_word] IN micro_code_p;
        IF item_ascii = NIL THEN
          clp$put_display (display_control, previous_line^, clc$trim, status);
          EXIT /format_dump/;
        IFEND;
        #TRANSLATE (control_codes_to_space, item_ascii^, line_buffer^
              (line_index, words_this_line * bytes_per_word));
        IF line_buffer^(size_of_address + 1, * ) = previous_line^(size_of_address + 1, * ) THEN
          previous_line^ := line_buffer^;
          repeated_lines := repeated_lines + 1;
        ELSE
          IF repeated_lines > 1 THEN
            osp$set_status_abnormal (rfc$product_id, rfe$skipped_lines, '', local_status);
            osp$append_status_integer (osc$status_parameter_delimiter, repeated_lines, 10, FALSE,
                  local_status);
            display_status_message (local_status, display_control, status);
            IF NOT status.normal THEN
              EXIT /format_dump/;
            IFEND;
          ELSEIF repeated_lines = 1 THEN
            clp$put_display (display_control, previous_line^, clc$trim, status);
            IF NOT status.normal THEN
              EXIT /format_dump/;
            IFEND;
          IFEND;
          repeated_lines := 0;
          clp$put_display (display_control, line_buffer^, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /format_dump/;
          IFEND;
          previous_line^ := line_buffer^;
        IFEND;
        display_address := display_address + words_this_line;
      WHILEND /display_items/;

    END /format_dump/;

    IF nad_dump_file_open_status.normal THEN
      fsp$close_file (nad_dump_file_id, ignore_status);
    IFEND;

    IF output_open_status.normal THEN
      clp$close_display (display_control, ignore_status);
    IFEND;

  PROCEND format_nad_dump;
*blockend
?? TITLE := '    quit', EJECT ??
  PROCEDURE quit (parameter_list: clt$parameter_list;
    VAR status: ost$status);

{  PDT quit_pdt ()

?? PUSH (LISTEXT := ON) ??

  VAR
    quit_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [NIL, NIL];

?? POP ??
    clp$scan_parameter_list (parameter_list, quit_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_scan_command_file (rfv$utility_name, status);

  PROCEND quit;
?? TITLE := '   test_local_nad',EJECT ??
  PROCEDURE test_local_nad (parameter_list: clt$parameter_list;
  VAR status: ost$status);

*copyc rfh$test_local_nad
*copyc rfd$pdt_test_local_nad

    CONST
      gen_error_report = 'GENERATE_LCN_ERROR_REPORT ';


    VAR
      capability: ARRAY[1..1] OF ost$name,
      test_local_nad_complete: BOOLEAN,
      nad_name_s: string (31),
      nad_name: rft$component_name,
      command: ^string ( * ),
      len: integer,
      hold_status: ost$status,
      task_id: pmt$task_id,
      value: clt$value,
      wait_time : INTEGER;

?? EJECT ??
    status.normal := TRUE;

    capability[1] := avc$network_operation;

    rfp$verify_caller_capability (^capability, 'TEST_LOCAL_NAD', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, test_local_nad_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('NAD', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    nad_name := value.name.value;

    rfp$initiate_local_nad_test (nad_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    test_local_nad_complete := FALSE;

  /wait_local_nad_test_complete/
    WHILE (NOT test_local_nad_complete) AND status.normal DO
      pmp$long_term_wait (500,500);
      rfp$check_local_nad_test (nad_name, test_local_nad_complete, status);

    WHILEND /wait_local_nad_test_complete/;

    IF (NOT  status.normal)   AND  (status.condition = rfe$test_nad_failure) THEN
      hold_status := status;
      stringrep(nad_name_s, len, nad_name : 31);
      PUSH command: [26+len];
      command^ := gen_error_report;
      command^(27) := nad_name_s;
      clp$execute_command (  command^, '', FALSE, '', task_id, status );
      status := hold_status;
    IFEND;

  PROCEND test_local_nad;
?? OLDTITLE ??

MODEND rfm$manage_rhfam_network;
*DECK DECK=RFM$NAD_I0_PP_DRIVER EXPAND=TRUE
          IDENT  NDI0
          CIPPU  J
          ORG    0
          CON    MCM-1       PROGRAM ENTRY POINT
          TITLE  RFM$NAD I0 PP DRIVER (NDI0) - NAD I0 PP DRIVER
          COMMENT *SMD* LVL=01
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4,10
**        NDI0 - NAD I0 PP DRIVER.
*         G.J. GAZDA.        87/04/23.
NDI0      EQU    1           SET DRIVER VERSION FOR I0
*copyc rfs$nad_pp_driver
          END    NDI0
/EOR
*DECK DECK=RFM$NAD_PP_DRIVER EXPAND=TRUE
          IDENT  NPDR
          CIPPU  J
          ORG    0
          CON    MCM-1       PROGRAM ENTRY POINT
          TITLE  RFM$NAD PP DRIVER (NPDR) - NAD PP DRIVER
          COMMENT *SMD* LVL=01
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
          SPACE  4,10
**        NPDR - NAD PP DRIVER.
*         G.S. ANDERSON.     85/07/01.
NPDR      EQU    1           SET DRIVER VERSION FOR NON-I0
*copyc rfs$nad_pp_driver
          END    NPDR
/EOR
*DECK DECK=RFM$NETWORK_DISPLAYS EXPAND=TRUE
*copyc osd$default_pragmats
MODULE rfm$network_displays;
?? TITLE := 'RHFAM_NETWORK_DISPLAYS' ??
?? NEWTITLE := '  RING BRACKETS 23D' ??
?? NEWTITLE := '    XREF procedures', EJECT ??
*copyc clp$convert_integer_to_rjstring
*copyc clp$new_display_line
*copyc clp$put_display
*copyc jmp$convert_name_to_ssn
*copyc jmp$system_job
*copyc osp$format_message
*copyc osp$get_message_level
*copyc osp$set_status_abnormal
*copyc oss$job_paged_literal
*copyc pmp$format_compact_time
*copyc pmp$get_microsecond_clock
*copyc rfp$lock_table
*copyc rfp$unlock_table
?? TITLE := '    INLINE procedures', EJECT ??
*copyc pmp$get_executing_task_gtid
*copyc rfp$find_client_entry
*copyc syp$cycle
?? NEWTITLE := '      rfp$clear_display_active', EJECT ??
  PROCEDURE [INLINE] rfp$clear_display_active;

    rfp$lock_table (rfv$status_table.lock);
    rfv$status_table.display_active := tmv$null_global_task_id;
    rfp$unlock_table (rfv$status_table.lock);

  PROCEND rfp$clear_display_active;
?? TITLE := '      rfp$convert_tcu_mask', EJECT ??
  PROCEDURE [INLINE] rfp$convert_tcu_mask (tcu_mask: rft$tcu_mask;
        VAR tcu_mask_string: string (4));
    VAR
      tcu_index: rfc$min_tcu .. rfc$max_tcu;

    tcu_mask_string := '0000';

    FOR tcu_index := LOWERBOUND(tcu_mask) TO UPPERBOUND(tcu_mask) DO
      IF tcu_mask[tcu_index] THEN
        tcu_mask_string (1+tcu_index,1) := '1';
      IFEND;
    FOREND;

  PROCEND rfp$convert_tcu_mask;
?? TITLE := '      rfp$set_display_active', EJECT ??
  PROCEDURE [INLINE] rfp$set_display_active ( display_command: STRING(*); VAR status: ost$status);

    VAR
      task_id: ost$global_task_id;

    pmp$get_executing_task_gtid (task_id);

  /set_display_active/
    REPEAT
      rfp$lock_table (rfv$status_table.lock);
      IF NOT rfv$status_table.system_task_is_up THEN
        osp$set_status_abnormal (rfc$product_id, rfe$system_task_not_active, display_command, status);
        EXIT /set_display_active/;
      IFEND;
      IF rfv$status_table.display_active = tmv$null_global_task_id THEN
        rfv$status_table.display_active := task_id;
      ELSE
        rfp$unlock_table (rfv$status_table.lock);
        syp$cycle;
      IFEND
    UNTIL rfv$status_table.display_active = task_id;

    rfp$unlock_table (rfv$status_table.lock);

  PROCEND rfp$set_display_active;
?? OLDTITLE, EJECT ??
?? TITLE := '    TYPE/CONST Definitions', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rfe$condition_codes
?? POP ??
*copyc rft$manage_rhfam_network_types
*copyc rfv$network_break_rc
*copyc rfv$status_table
*copyc rfv$rhfam_client_table
*copyc rfv$rhfam_job_table
*copyc rfv$rhfam_server_table
*copyc tmv$null_global_task_id
?? TITLE := '    rfp$display_active_appl_r3', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$display_active_appl_r3 (job_name_list: ARRAY [1 .. *] OF ost$name;
    application_name_list: ARRAY [1 .. *] OF rft$application_name;
    display_type: rft$application_display_type;
    VAR display_control: clt$display_control;
    VAR status: ost$status);

*copyc rfh$display_active_appl_r3

    VAR
      appl_name_index,
      job_name_index,
      current_time,
      microseconds: INTEGER,
      application_name_displayed_p: ^ARRAY[1 .. *] OF BOOLEAN,
      compact_time: ost$date_time,
      job_found: BOOLEAN,
      privileged_job: boolean,
      legible_time: ost$time,
      line: string (72),
      application_kinds: [STATIC, READ, oss$job_paged_literal]
        ARRAY [rft$application_kinds] OF
        STRING (7):= ['SERVER', 'CLIENT', 'PARTNER'],
      appl_entry_p: ^rft$application_table_entry,
      client_entry_p: ^rft$rhfam_client_table_entry,
      connect_entry_p: ^rft$connection_entry,
      job_entry_p: ^^rft$rhfam_job_table_entry,
      current_entry_p,
      previous_entry_p: ^rft$rhfam_job_table_entry,
      system_supplied_names_p: ^ARRAY[1 .. *] OF jmt$system_supplied_name,
      task_id: ost$global_task_id,
      maximum_connections: rft$application_connections,
      local_status,
      ignore_status: ost$status;

    status.normal := TRUE;
    local_status.normal := TRUE;

    PUSH system_supplied_names_p: [1 .. UPPERBOUND(job_name_list)];

    IF job_name_list[1] <> 'ALL' THEN
      privileged_job := jmp$system_job ();
      FOR job_name_index := LOWERBOUND(job_name_list) TO UPPERBOUND(job_name_list) DO
        jmp$convert_name_to_ssn (job_name_list[job_name_index], privileged_job,
        system_supplied_names_p^[job_name_index], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    ELSE
      system_supplied_names_p^[1] := 'ALL';
    IFEND;

    PUSH application_name_displayed_p: [1 .. UPPERBOUND(application_name_list)];

    FOR appl_name_index := LOWERBOUND(application_name_list) TO UPPERBOUND(application_name_list) DO
      application_name_displayed_p^[appl_name_index] := FALSE;
    FOREND;

    clp$new_display_line (display_control, 2, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    line (1,*) := '   ';

    IF display_type = rfc$adt_connections THEN
      line (25,*) := 'ACTIVE CONNECTIONS';
      clp$put_display (display_control, line, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$new_display_line (display_control, 2, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      line (9,*) := 'JOB            APPL   REMOTE  CONNECT      BYTES      BYTES';
      clp$put_display (display_control, line, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      line (9,*) := 'NAME           NAME    HOST    TIME         SENT     RECEIVED';
      clp$put_display (display_control, line, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      line (21,*) := 'ACTIVE APPLICATIONS';
      clp$put_display (display_control, line, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      clp$new_display_line (display_control, 2, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      line (9,*) := 'JOB            APPL    MAXIMUM   CURRENT     APPL';
      clp$put_display (display_control, line, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      line (9,*) := 'NAME           NAME    CONNECTS  CONNECTS    KIND';
      clp$put_display (display_control, line, clc$trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
    clp$new_display_line (display_control, 2, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_executing_task_gtid (task_id);

    pmp$get_microsecond_clock (current_time, ignore_status);

    job_entry_p := ^rfv$rhfam_job_table.first_entry;
    current_entry_p := NIL;

  /display_jobs/
    WHILE TRUE DO
      previous_entry_p := current_entry_p;
      current_entry_p := NIL;
      rfp$lock_table (rfv$rhfam_job_table.lock);
      WHILE (job_entry_p^ <> NIL) AND (current_entry_p = NIL) DO
        IF job_entry_p^^.lock = tmv$null_global_task_id THEN
          current_entry_p := job_entry_p^;
          current_entry_p^.lock := task_id;
        ELSE
          rfp$unlock_table (rfv$rhfam_job_table.lock);
          syp$cycle;
          rfp$lock_table (rfv$rhfam_job_table.lock);
        IFEND;
      WHILEND;
      rfp$unlock_table (rfv$rhfam_job_table.lock);
      IF previous_entry_p <> NIL THEN
        previous_entry_p^.lock := tmv$null_global_task_id;
      IFEND;
      IF job_entry_p^ = NIL THEN
        IF previous_entry_p = NIL THEN
          clp$put_display (display_control, '    No active applications.', clc$trim, status);
        IFEND;
        EXIT /display_jobs/;
      IFEND;
      job_entry_p := ^current_entry_p^.next_entry;
      job_found := FALSE;
      FOR job_name_index := LOWERBOUND(system_supplied_names_p^) TO UPPERBOUND(system_supplied_names_p^) DO
        IF (system_supplied_names_p^[job_name_index] = current_entry_p^.job_name) OR
              (system_supplied_names_p^[job_name_index] = 'ALL') THEN
          job_found := TRUE;
        IFEND;
      FOREND;
      IF job_found AND (current_entry_p^.application_entry <> NIL) THEN
        line (1,*) := '   ';
        line (2,*) := current_entry_p^.job_name;
        FOR appl_name_index := LOWERBOUND(application_name_list) TO UPPERBOUND(application_name_list) DO
          appl_entry_p := current_entry_p^.application_entry;
        /display_applications/
          REPEAT
            IF (application_name_list[appl_name_index] = appl_entry_p^.application_name) OR
                   (application_name_list[appl_name_index] = 'ALL') THEN
              line (23,#SIZE(rft$application_name)) := appl_entry_p^.application_name;
              connect_entry_p := appl_entry_p^.connection_table;
              IF display_type = rfc$adt_connections THEN
                WHILE connect_entry_p <> NIL DO
                  IF connect_entry_p^.connection_attributes.connection_status.connection_state <>
                        rfc$not_viable THEN
                    IF appl_entry_p^.application_kind = rfc$client THEN
                      line (32,#SIZE(rft$physical_identifier)) :=
                            connect_entry_p^.connection_attributes.server_host;
                    ELSE
                      line (32,#SIZE(rft$physical_identifier)) :=
                            connect_entry_p^.connection_attributes.client_host;
                    IFEND;
                    microseconds := current_time - connect_entry_p^.connection_statistics.connect_time;
                    compact_time.millisecond := 0;
                    compact_time.second := (microseconds DIV 1000000) MOD 60;
                    compact_time.minute := ((microseconds DIV 1000000) DIV 60) MOD 60;
                    compact_time.hour := ((microseconds DIV 1000000) DIV 60) DIV 60;
                    IF compact_time.hour > 23 THEN
                      compact_time.hour := 23;
                      line (37,1) := '*';
                    IFEND;
                    pmp$format_compact_time (compact_time, osc$hms_time, legible_time, status);
                    IF NOT status.normal THEN
                      EXIT /display_jobs/;
                    IFEND;
                    line (38,8) := legible_time.hms;
                    clp$convert_integer_to_rjstring (connect_entry_p^.connection_statistics.
                          bytes_sent, 10, FALSE, ' ', line (48,10), status);
                    IF NOT status.normal THEN
                      EXIT /display_jobs/;
                    IFEND;
                    clp$convert_integer_to_rjstring (connect_entry_p^.connection_statistics.
                          bytes_received, 10, FALSE, ' ', line (60,10), status);
                    IF NOT status.normal THEN
                      EXIT /display_jobs/;
                    IFEND;
                    clp$put_display (display_control, line, clc$trim, status);
                    IF NOT status.normal THEN
                      EXIT /display_jobs/;
                    IFEND;
                    line (1,*) := '   ';
                  IFEND;
                  connect_entry_p := connect_entry_p^.next_entry;
                WHILEND;
                IF line (23,1) <> ' ' THEN
                  clp$put_display (display_control, line, clc$trim, status);
                  IF NOT status.normal THEN
                    EXIT /display_jobs/;
                  IFEND;
                IFEND;
              ELSE
                IF NOT appl_entry_p^.system_wide_connection_mgmt THEN
                  clp$convert_integer_to_rjstring (appl_entry_p^.maximum_allowed_connections, 10, FALSE,
                        ' ', line (34,3), status);
                  IF NOT status.normal THEN
                    EXIT /display_jobs/;
                  IFEND;
                ELSE
                  rfp$lock_table (rfv$rhfam_client_table.lock);
                  rfp$find_client_entry(appl_entry_p^.application_name, FALSE, client_entry_p, status);
                  IF status.normal THEN
                    maximum_connections := client_entry_p^.maximum_connections;
                  IFEND;
                  rfp$unlock_table (rfv$rhfam_client_table.lock);
                  IF NOT status.normal THEN
                    EXIT /display_jobs/;
                  IFEND;
                  clp$convert_integer_to_rjstring (maximum_connections, 10, FALSE, ' ', line (34,3), status);
                IFEND;
                clp$convert_integer_to_rjstring (appl_entry_p^.number_of_active_connections, 10, FALSE,
                      ' ', line (44,3), status);
                IF NOT status.normal THEN
                  EXIT /display_jobs/;
                IFEND;
                line (53,7) := application_kinds[appl_entry_p^.application_kind];
                clp$put_display (display_control, line, clc$trim, status);
                IF NOT status.normal THEN
                  EXIT /display_jobs/;
                IFEND;
              IFEND;
              application_name_displayed_p^[appl_name_index] := TRUE;
              line (1,*) := '   ';
              IF application_name_list[appl_name_index] <> 'ALL' THEN
                EXIT /display_applications/;
              IFEND;
            IFEND;
            appl_entry_p := appl_entry_p^.next_entry;
          UNTIL appl_entry_p = NIL;
        FOREND;
      IFEND;
    WHILEND /display_jobs/;

    IF current_entry_p <> NIL THEN
      current_entry_p^.lock := tmv$null_global_task_id;
    IFEND;

    IF status.normal AND (application_name_list[appl_name_index] <> 'ALL') THEN
      FOR appl_name_index := LOWERBOUND(application_name_displayed_p^) TO
            UPPERBOUND(application_name_displayed_p^) DO
        IF NOT application_name_displayed_p^[appl_name_index] THEN
          IF NOT status.normal THEN
            display_status_message (status, display_control, local_status);
            IF NOT local_status.normal THEN
              status := local_status;
              RETURN;
            IFEND;
          IFEND;
          osp$set_status_abnormal (rfc$product_id, rfe$appl_not_defined,
                application_name_list[appl_name_index], status);
        IFEND;
      FOREND;
    IFEND;

  PROCEND rfp$display_active_appl_r3;
?? TITLE := '    rfp$display_rhfam_clients', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$display_rhfam_clients (
    client_list: ARRAY [1 .. *] OF rft$application_name;
    VAR display_control: clt$display_control;
    VAR status: ost$status);

*copyc rfh$display_rhfam_clients_r3

    VAR
      client_list_index: INTEGER,
      line: string (72),
      client_displayed_p: ^ARRAY[1 .. *] OF BOOLEAN,
      client_table_p: ^rft$rhfam_client_table_entry,
      local_status: ost$status;

    status.normal := TRUE;
    local_status.normal := TRUE;

    PUSH client_displayed_p: [1 .. UPPERBOUND(client_list)];

    FOR client_list_index := LOWERBOUND(client_list) TO UPPERBOUND(client_list) DO
      client_displayed_p^[client_list_index] := FALSE;
    FOREND;

    clp$new_display_line (display_control, 2, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    line (1,*) := '   ';
    line (10,*) := 'RHFAM CLIENT DEFINITIONS';
    clp$put_display (display_control, line, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 2, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    line (10,*) := 'MAXIMUM    RESERVED  CLIENT';
    clp$put_display (display_control, line, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    line (3,*) := 'NAME   CONNECTS   CONNECTS  STATUS';
    clp$put_display (display_control, line, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 2, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /main_program/
    BEGIN

      rfp$lock_table (rfv$rhfam_client_table.lock);
      client_table_p := rfv$rhfam_client_table.first_entry;
      IF client_table_p = NIL THEN
        clp$put_display (display_control, '    No local clients defined.', clc$trim, status);
          EXIT /main_program/
      ELSE
        FOR client_list_index := LOWERBOUND(client_list) TO UPPERBOUND(client_list) DO
          client_table_p := rfv$rhfam_client_table.first_entry;
        /display_local_clients/
          REPEAT
            IF (client_list[client_list_index] = client_table_p^.client_name) OR
                  (client_list[client_list_index] = 'ALL') THEN
              line (1,*) := '   ';
              line (2, #SIZE(rft$application_name)) := client_table_p^.client_name;
              clp$convert_integer_to_rjstring (client_table_p^.maximum_connections, 10, FALSE, ' ',
                LINE (12,3), status);
              IF NOT status.normal THEN
                EXIT /main_program/
              IFEND;
              clp$convert_integer_to_rjstring (client_table_p^.connections_reserved, 10, FALSE, ' ',
                    LINE (23,3), status);
              IF NOT status.normal THEN
                EXIT /main_program/
              IFEND;
              IF client_table_p^.client_active THEN
                line (31,6) := 'ACTIVE';
              ELSE
                line (31,8) := 'INACTIVE';
              IFEND;
              clp$put_display (display_control, line, clc$trim, status);
              IF NOT status.normal THEN
                EXIT /main_program/
              IFEND;
              client_displayed_p^[client_list_index] := TRUE;
              IF client_list[client_list_index] <> 'ALL' THEN
                EXIT /display_local_clients/;
              IFEND;
            IFEND;
            client_table_p := client_table_p^.next_entry;
          UNTIL client_table_p = NIL;
        FOREND;
      IFEND;

      IF client_list[1] <> 'ALL' THEN
        FOR client_list_index := LOWERBOUND(client_displayed_p^) TO UPPERBOUND(client_displayed_p^) DO
          IF client_displayed_p^[client_list_index] = FALSE THEN
            IF NOT status.normal THEN
              display_status_message (status, display_control, local_status);
              IF NOT local_status.normal THEN
                status := local_status;
                EXIT /main_program/;
              IFEND;
            IFEND;
            osp$set_status_abnormal (rfc$product_id, rfe$appl_not_defined, client_list[client_list_index],
                  status);
          IFEND;
        FOREND;
      IFEND;

    END /main_program/;

    rfp$unlock_table (rfv$rhfam_client_table.lock);

  PROCEND rfp$display_rhfam_clients;
?? TITLE := '    rfp$display_rhfam_servers', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$display_rhfam_servers (
    server_list: ARRAY [1 .. *] OF rft$application_name;
    VAR display_control: clt$display_control;
    VAR status: ost$status);

*copyc rfh$display_rhfam_servers_r3

    VAR
      server_list_index: INTEGER,
      line: string (72),
      server_displayed_p: ^ARRAY[1 .. *] OF BOOLEAN,
      server_table_p: ^rft$rhfam_server_table_entry,
      local_status: ost$status;

    status.normal := TRUE;
    local_status.normal := TRUE;

    PUSH server_displayed_p: [1 .. UPPERBOUND(server_list)];

    FOR server_list_index := LOWERBOUND(server_list) TO UPPERBOUND(server_list) DO
      server_displayed_p^[server_list_index] := FALSE;
    FOREND;

    clp$new_display_line (display_control, 2, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    line (1,*) := '   ';
    line (10,*) := 'RHFAM SERVER DEFINITIONS';
    clp$put_display (display_control, line, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 2, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    line (10,*) := '  RHFAM-    MAXIMUM    RESERVED   CURRENT   SERVER';
    clp$put_display (display_control, line, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    line (3,*) := 'NAME   INITIATED   CONNECTS   CONNECTS   CONNECTS  STATUS';
    clp$put_display (display_control, line, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$new_display_line (display_control, 2, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /main_program/
    BEGIN

      rfp$lock_table (rfv$rhfam_server_table.lock);
      server_table_p := rfv$rhfam_server_table.first_entry;
      IF server_table_p = NIL THEN
        clp$put_display (display_control, '    No local servers defined.', clc$trim, status);
          EXIT /main_program/
      ELSE
        FOR server_list_index := LOWERBOUND(server_list) TO UPPERBOUND(server_list) DO
          server_table_p := rfv$rhfam_server_table.first_entry;
        /display_local_servers/
          REPEAT
            IF (server_list[server_list_index] = server_table_p^.server_name) OR
                  (server_list[server_list_index] = 'ALL') THEN
              line (1,*) := '   ';
              line (2, #SIZE(rft$application_name)) := server_table_p^.server_name;
              CASE server_table_p^.rhfam_initiated_server OF
              =TRUE=
                line (14,3) := 'YES';
              =FALSE=
                line (14,3) := 'NO';
              CASEND;
              clp$convert_integer_to_rjstring (server_table_p^.maximum_connections, 10, FALSE, ' ',
                LINE (24,3), status);
              IF NOT status.normal THEN
                EXIT /main_program/
              IFEND;
              clp$convert_integer_to_rjstring (server_table_p^.connections_reserved, 10, FALSE, ' ',
                    LINE (35,3), status);
              IF NOT status.normal THEN
                EXIT /main_program/
              IFEND;
              clp$convert_integer_to_rjstring (server_table_p^.current_connections, 10, FALSE, ' ',
                    LINE (46,3), status);
              IF NOT status.normal THEN
                EXIT /main_program/
              IFEND;
              IF server_table_p^.server_active THEN
                line (54,6) := 'ACTIVE';
              ELSE
                line (54,8) := 'INACTIVE';
              IFEND;
              clp$put_display (display_control, line, clc$trim, status);
              IF NOT status.normal THEN
                EXIT /main_program/
              IFEND;
              server_displayed_p^[server_list_index] := TRUE;
              IF server_list[server_list_index] <> 'ALL' THEN
                EXIT /display_local_servers/;
              IFEND;
            IFEND;
            server_table_p := server_table_p^.next_entry;
          UNTIL server_table_p = NIL;
        FOREND;
      IFEND;

      IF server_list[1] <> 'ALL' THEN
        FOR server_list_index := LOWERBOUND(server_displayed_p^) TO UPPERBOUND(server_displayed_p^) DO
          IF server_displayed_p^[server_list_index] = FALSE THEN
            IF NOT status.normal THEN
              display_status_message (status, display_control, local_status);
              IF NOT local_status.normal THEN
                status := local_status;
                EXIT /main_program/;
              IFEND;
            IFEND;
            osp$set_status_abnormal (rfc$product_id, rfe$appl_not_defined, server_list[server_list_index],
                  status);
          IFEND;
        FOREND;
      IFEND;

    END /main_program/;

    rfp$unlock_table (rfv$rhfam_server_table.lock);

  PROCEND rfp$display_rhfam_servers;
?? TITLE := '    rfp$display_rhfam_elements', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$display_rhfam_elements (element_names: ARRAY[1 .. *] OF rft$component_name;
    display_type: rft$element_display_type;
    display_option: rft$display_option;
    VAR display_control: clt$display_control;
    VAR status: ost$status);

*copyc rfh$display_rhfam_elements

    TYPE
      trunk_info = RECORD
        name: rft$component_name,
        next_trunk: ^trunk_info,
        state: rft$element_state,
        next_nad: ^nad_info,
      RECEND,

      nad_info = RECORD
        name: rft$component_name,
        next_nad: ^nad_info,
        tcu_state: rft$element_state,
        tcu: rfc$min_tcu .. rfc$max_tcu,
      RECEND;

    VAR
      microcode_type: [STATIC, READ, oss$job_paged_literal]
        ARRAY [rft$microcode_types] OF STRING (4):= ['C180',
        'C170', 'VAX', 'IBM', 'C205', 'INET', 'NTN'],
      dump_action: [STATIC, READ, oss$job_paged_literal]
        ARRAY [rft$dump_disposition] OF STRING (7):= ['DISCARD', 'LAST', 'ALL'],
      element_name_index: INTEGER,
      local_nad_index: rft$local_nads,
      remote_nad_index: rft$remote_nads,
      tcu_index: rfc$min_tcu .. rfc$max_tcu,
      legible_time: ost$time,
      line: string (72),
      state_info: [STATIC, READ, oss$job_paged_literal]
        ARRAY [rft$element_state] OF STRING (4):= ['ON', 'OFF', 'DOWN'],
      nad_info_p: ^nad_info,
      first_trunk_info_p,
      trunk_info_p: ^trunk_info;

    status.normal := TRUE;

    IF display_type = rfc$edt_trunks THEN
      rfp$set_display_active ('DISPLAY_TRUNK_STATUS', status);
    ELSE
      rfp$set_display_active ('DISPLAY_NAD_STATUS', status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /main_program/
    BEGIN

      clp$new_display_line (display_control, 2, status);
      IF NOT status.normal THEN
        EXIT /main_program/
      IFEND;

      CASE display_type OF
      = rfc$edt_local_nads =
        line (1,*) := '   ';
        IF display_option = rfc$do_brief THEN
          line (17,*) := 'LOCAL NADS';
          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          clp$new_display_line (display_control, 2, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          line (1,*) := '   ';
          line (4,*) := 'NAME                         CHAN  STATUS';
          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          clp$new_display_line (display_control, 2, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
        ELSE
          line (31,*) := 'LOCAL NADS';
          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          clp$new_display_line (display_control, 2, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          line (1,*) := '   ';
          line (55,*) := 'LOADS       DUMP';
          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          line (1,*) := '   ';
          line (6,*) := 'NAME                       CHAN STATUS CONN REQS NO/MX TYPE ACTION';
          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          clp$new_display_line (display_control, 2, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
        IFEND;

      /display_local_nads/
        FOR element_name_index := LOWERBOUND(element_names) TO UPPERBOUND(element_names) DO
          FOR local_nad_index := LOWERBOUND(rfv$status_table.local_nads^) TO
                UPPERBOUND(rfv$status_table.local_nads^) DO
            IF (rfv$status_table.local_nads^[local_nad_index].name = element_names[element_name_index]) OR
                  (element_names[element_name_index] = 'ALL') THEN
              line (1,*) := '   ';
              line (2, #SIZE(rft$component_name)) := rfv$status_table.local_nads^[local_nad_index].name;
              clp$convert_integer_to_rjstring (rfv$status_table.local_nads^[local_nad_index].channel_number,
                    10, FALSE, ' ', line (33,3), status);
              IF NOT status.normal THEN
                EXIT /main_program/
              IFEND;
              line (39,4) :=
                    state_info[rfv$status_table.local_nads^[local_nad_index].current_status.device_status];
              IF display_option <> rfc$do_brief THEN
                clp$convert_integer_to_rjstring (rfv$status_table.local_nads^[local_nad_index].
                      connections_established, 10, FALSE, ' ', LINE (45,4), status);
                IF NOT status.normal THEN
                  EXIT /main_program/
                IFEND;
                clp$convert_integer_to_rjstring (rfv$status_table.local_nads^[local_nad_index].
                      requests_posted, 10, FALSE, ' ', LINE (50,3), status);
                IF NOT status.normal THEN
                  EXIT /main_program/
                IFEND;
                clp$convert_integer_to_rjstring (rfv$status_table.local_nads^[local_nad_index].
                      maintenance_status.reloads_performed, 10, FALSE, ' ', LINE (54,3), status);
                IF NOT status.normal THEN
                  EXIT /main_program/
                IFEND;
                clp$convert_integer_to_rjstring (rfv$status_table.local_nads^[local_nad_index].
                      maintenance_selections.reload_threshold, 10, FALSE, ' ', LINE (57,3), status);
                IF NOT status.normal THEN
                  EXIT /main_program/
                IFEND;
                line (57,1) := '/';
                line (61,4) := 'C180';
                line (66,7) := dump_action[rfv$status_table.local_nads^[local_nad_index].
                      maintenance_selections.dump_disposition];
              IFEND;
              clp$put_display (display_control, line, clc$trim, status);
              IF NOT status.normal THEN
                EXIT /main_program/
              IFEND;
              IF element_names[element_name_index] <> 'ALL' THEN
                CYCLE /display_local_nads/;
              IFEND;
            IFEND;
          FOREND;
          IF element_names[element_name_index] = 'ALL' THEN
            EXIT /display_local_nads/;
          IFEND;
          osp$set_status_abnormal (rfc$product_id, rfe$element_not_found, element_names[element_name_index],
                status);
          EXIT /main_program/;
        FOREND /display_local_nads/;

      = rfc$edt_remote_nads =
        IF rfv$status_table.remote_nads = NIL THEN
          clp$put_display (display_control, '    No remote NADs defined.', clc$trim, status);
          EXIT /main_program/
        IFEND;
        line (1,*) := '   ';
        IF display_option = rfc$do_brief THEN
          line (17,*) := 'REMOTE NADS';
          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          clp$new_display_line (display_control, 2, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          line (1,*) := '   ';
          line (4,*) := 'NAME                         ADDR  STATUS';
          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          clp$new_display_line (display_control, 2, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
        ELSE
          line (31,*) := 'REMOTE NADS';
          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          clp$new_display_line (display_control, 2, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          line (1,*) := '   ';
          line (46,*) := 'LAST';
          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          line (1,*) := '   ';
          line (6,*) := 'NAME                       ADDR STATUS CONNECT   TYPE';
          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          clp$new_display_line (display_control, 2, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
        IFEND;

      /display_remote_nads/
        FOR element_name_index := LOWERBOUND(element_names) TO UPPERBOUND(element_names) DO
          FOR remote_nad_index := LOWERBOUND(rfv$status_table.remote_nads^) TO
                UPPERBOUND(rfv$status_table.remote_nads^) DO
            IF (rfv$status_table.remote_nads^[remote_nad_index].name = element_names[element_name_index]) OR
                  (element_names[element_name_index] = 'ALL') THEN
              line (1,*) := '   ';
              line (2, #SIZE(rft$component_name)) := rfv$status_table.remote_nads^[remote_nad_index].name;
              clp$convert_integer_to_rjstring (rfv$status_table.remote_nads^[remote_nad_index].address, 16,
                    FALSE, ' ', line (33,3), status);
              IF NOT status.normal THEN
                EXIT /main_program/
              IFEND;
              line (33,1) := ' ';
              line (39,4) :=
                    state_info[rfv$status_table.remote_nads^[remote_nad_index].current_status.device_status];
              IF display_option <> rfc$do_brief THEN
                pmp$format_compact_time (rfv$status_table.remote_nads^[remote_nad_index].last_connect_time,
                      osc$hms_time, legible_time, status);
                IF NOT status.normal THEN
                  EXIT /main_program/
                IFEND;
                line (45,8) := legible_time.hms;
                line (55,4) := microcode_type[rfv$status_table.remote_nads^[remote_nad_index].microcode_type];
              IFEND;
              clp$put_display (display_control, line, clc$trim, status);
              IF NOT status.normal THEN
                EXIT /main_program/
              IFEND;
              IF element_names[element_name_index] <> 'ALL' THEN
                CYCLE /display_remote_nads/;
              IFEND;
            IFEND;
          FOREND;
          IF element_names[element_name_index] = 'ALL' THEN
            EXIT /display_remote_nads/;
          IFEND;
          osp$set_status_abnormal (rfc$product_id, rfe$element_not_found, element_names[element_name_index],
            status);
          EXIT /main_program/;
        FOREND /display_remote_nads/;

      = rfc$edt_trunks =
        line (1,*) := '   ';
        IF display_option = rfc$do_brief THEN
          line (17,*) := 'TRUNKS';
          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          clp$new_display_line (display_control, 2, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          line (1,*) := '   ';
          line (4,*) := 'NAME                          STATUS';
          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          clp$new_display_line (display_control, 2, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
        ELSE
          line (31,*) := 'TRUNKS';
          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          clp$new_display_line (display_control, 2, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          line (4,*) := 'NAME                              NAD NAME                   TCU STAT';
          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
          clp$new_display_line (display_control, 2, status);
          IF NOT status.normal THEN
            EXIT /main_program/
          IFEND;
        IFEND;

        PUSH first_trunk_info_p;
        first_trunk_info_p^.name := '';
        first_trunk_info_p^.next_trunk := NIL;

        FOR local_nad_index := LOWERBOUND(rfv$status_table.local_nads^) TO
              UPPERBOUND(rfv$status_table.local_nads^) DO
          FOR tcu_index := LOWERBOUND(rfv$status_table.local_nads^[local_nad_index].trunk_control_units) TO
                  UPPERBOUND(rfv$status_table.local_nads^[local_nad_index].trunk_control_units) DO
            IF rfv$status_table.local_nads^[local_nad_index].trunk_control_units[tcu_index] <> '' THEN
              trunk_info_p := first_trunk_info_p;

            /search_local_nad_tcus/
              BEGIN

              /build_local_trunk_list/
                WHILE TRUE DO
                  IF trunk_info_p^.name =
                        rfv$status_table.local_nads^[local_nad_index].trunk_control_units[tcu_index] THEN
                    EXIT /search_local_nad_tcus/;
                  ELSEIF trunk_info_p^.next_trunk = NIL THEN
                    EXIT /build_local_trunk_list/;
                  IFEND;
                  trunk_info_p := trunk_info_p^.next_trunk;
                WHILEND /build_local_trunk_list/;

                IF trunk_info_p^.name <> '' THEN
                  PUSH trunk_info_p^.next_trunk;
                  trunk_info_p := trunk_info_p^.next_trunk;
                IFEND;
                trunk_info_p^.name :=
                      rfv$status_table.local_nads^[local_nad_index].trunk_control_units[tcu_index];
                trunk_info_p^.next_trunk := NIL;
                trunk_info_p^.next_nad := NIL;
                trunk_info_p^.state := rfc$es_down;
              END /search_local_nad_tcus/;

              IF trunk_info_p^.next_nad = NIL THEN
                PUSH trunk_info_p^.next_nad;
                nad_info_p := trunk_info_p^.next_nad;
              ELSE
                nad_info_p := trunk_info_p^.next_nad;
                WHILE nad_info_p^.next_nad <> NIL DO
                  nad_info_p := nad_info_p^.next_nad;
                WHILEND;
                PUSH nad_info_p^.next_nad;
                nad_info_p := nad_info_p^.next_nad;
              IFEND;
              nad_info_p^.name := rfv$status_table.local_nads^[local_nad_index].name;
              nad_info_p^.next_nad := NIL;
              nad_info_p^.tcu := tcu_index;
              nad_info_p^.tcu_state :=
                    rfv$status_table.local_nads^[local_nad_index].current_status.tcu_status[tcu_index];
              IF nad_info_p^.tcu_state = rfc$es_on THEN
                trunk_info_p^.state := rfc$es_on;
              ELSEIF (nad_info_p^.tcu_state = rfc$es_off) and (trunk_info_p^.state <> rfc$es_on) THEN
                trunk_info_p^.state := rfc$es_off;
              IFEND;
            IFEND;
          FOREND;
        FOREND;

        IF rfv$status_table.remote_nads <> NIL THEN
          FOR remote_nad_index := LOWERBOUND(rfv$status_table.remote_nads^) TO
                UPPERBOUND(rfv$status_table.remote_nads^) DO
            FOR tcu_index :=
                  LOWERBOUND(rfv$status_table.remote_nads^[remote_nad_index].trunk_control_units) TO
                  UPPERBOUND(rfv$status_table.remote_nads^[remote_nad_index].trunk_control_units) DO
              IF rfv$status_table.remote_nads^[remote_nad_index].trunk_control_units[tcu_index] <> '' THEN
                trunk_info_p := first_trunk_info_p;

              /search_remote_nad_tcus/
                BEGIN

                /build_remote_trunk_list/
                  WHILE TRUE DO
                    IF trunk_info_p^.name =
                          rfv$status_table.remote_nads^[remote_nad_index].trunk_control_units[tcu_index] THEN
                      EXIT /search_remote_nad_tcus/;
                    ELSEIF trunk_info_p^.next_trunk = NIL THEN
                      EXIT /build_remote_trunk_list/;
                    IFEND;
                    trunk_info_p := trunk_info_p^.next_trunk;
                  WHILEND /build_remote_trunk_list/;

                  IF trunk_info_p^.name <> '' THEN
                    PUSH trunk_info_p^.next_trunk;
                    trunk_info_p := trunk_info_p^.next_trunk;
                  IFEND;
                  trunk_info_p^.name :=
                        rfv$status_table.remote_nads^[remote_nad_index].trunk_control_units[tcu_index];
                  trunk_info_p^.next_trunk := NIL;
                  trunk_info_p^.next_nad := NIL;
                  trunk_info_p^.state := rfc$es_down;
                END /search_remote_nad_tcus/;

                IF trunk_info_p^.next_nad = NIL THEN
                  PUSH trunk_info_p^.next_nad;
                  nad_info_p := trunk_info_p^.next_nad;
                ELSE
                  nad_info_p := trunk_info_p^.next_nad;
                  WHILE nad_info_p^.next_nad <> NIL DO
                    nad_info_p := nad_info_p^.next_nad;
                  WHILEND;
                  PUSH nad_info_p^.next_nad;
                  nad_info_p := nad_info_p^.next_nad;
                IFEND;
                nad_info_p^.name := rfv$status_table.remote_nads^[remote_nad_index].name;
                nad_info_p^.next_nad := NIL;
                nad_info_p^.tcu := tcu_index;
                nad_info_p^.tcu_state :=
                      rfv$status_table.remote_nads^[remote_nad_index].current_status.tcu_status[tcu_index];
                IF nad_info_p^.tcu_state = rfc$es_on THEN
                  trunk_info_p^.state := rfc$es_on;
                ELSEIF (nad_info_p^.tcu_state = rfc$es_off) and (trunk_info_p^.state <> rfc$es_on) THEN
                  trunk_info_p^.state := rfc$es_off;
                IFEND;
              IFEND;
            FOREND;
          FOREND;
        IFEND;

      /display_trunks/
        FOR element_name_index := LOWERBOUND(element_names) TO UPPERBOUND(element_names) DO
          line (1,*) := '   ';
          trunk_info_p := first_trunk_info_p;

          REPEAT
            IF (element_names[element_name_index] = trunk_info_p^.name) OR
                  (element_names[element_name_index] = 'ALL') THEN
              line (2, #SIZE(rft$component_name)) := trunk_info_p^.name;
              IF display_option <> rfc$do_brief THEN
                nad_info_p := trunk_info_p^.next_nad;

                REPEAT
                  line (34,#SIZE(rft$component_name)) := nad_info_p^.name;
                  clp$convert_integer_to_rjstring (nad_info_p^.tcu, 10, FALSE, ' ', LINE (65,2), status);
                  IF NOT status.normal THEN
                    EXIT /main_program/
                  IFEND;
                  line (69,4) := state_info[nad_info_p^.tcu_state];
                  clp$put_display (display_control, line, clc$trim, status);
                  IF NOT status.normal THEN
                    EXIT /main_program/
                  IFEND;
                  line (1,*) := '   ';
                  nad_info_p := nad_info_p^.next_nad;
                UNTIL nad_info_p = NIL;

              ELSE
                line (35,4) := state_info[trunk_info_p^.state];
                clp$put_display (display_control, line, clc$trim, status);
                IF NOT status.normal THEN
                  EXIT /main_program/
                IFEND;
                line (1,*) := '   ';
              IFEND;
              clp$new_display_line (display_control, 2, status);
              IF NOT status.normal THEN
                EXIT /main_program/
              IFEND;
              IF element_names[element_name_index] <> 'ALL' THEN
                CYCLE /display_trunks/;
              IFEND;
            IFEND;
            trunk_info_p := trunk_info_p^.next_trunk;
          UNTIL trunk_info_p = NIL;

          IF element_names[element_name_index] = 'ALL' THEN
            EXIT /display_trunks/;
          IFEND;
          osp$set_status_abnormal (rfc$product_id, rfe$element_not_found, element_names[element_name_index],
                status);
          EXIT /main_program/;
        FOREND /display_trunks/;

      CASEND;

    END /main_program/;

    rfp$clear_display_active;

  PROCEND rfp$display_rhfam_elements;
?? TITLE := '    rfp$display_routing_info_r3', EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$display_routing_info_r3 (physical_id_list: ARRAY [1 .. *]
        OF rft$physical_identifier;
    logical_id_list: ARRAY [1 .. *] OF rft$logical_identifier;
    local_pid_specified: BOOLEAN;
    all_pids_specified: BOOLEAN;
    all_lids_specified: BOOLEAN;
    display_type: rft$routing_display_type;
    VAR input_file_p: ^SEQ(*);
    VAR display_control: clt$display_control;
    VAR status: ost$status);

*copyc rfh$display_routing_info_r3

    VAR
      path_index: rft$paths_per_host,
      lid_index: rft$logical_ids_per_host,
      lid_list_index,
      pid_list_index: INTEGER,
      lid_displayed_p: ^ARRAY[1 .. *] OF BOOLEAN,
      line: string (72),
      local_status: ost$status,
      local_pid_selected,
      remote_pid_selected: BOOLEAN,
      mask_string: STRING (4),
      path_state: rft$element_state,
      local_status_table: rft$status_table,
      remote_host_entry_p: ^rft$remote_host_definition,
      state_reason: string(25),
      state_info: [STATIC, READ, oss$job_paged_literal]
        ARRAY [rft$element_state] OF STRING (4):= ['ON', 'OFF', 'DOWN'];

    status.normal := TRUE;
    local_status.normal := TRUE;

    IF input_file_p <> NIL THEN

      get_installed_configuration (input_file_p, local_status_table, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      CASE display_type OF
      = rfc$rdt_lids =
        rfp$set_display_active( 'DISPLAY_LOGICAL_IDENTIFIER', status);
      = rfc$rdt_paths =
        rfp$set_display_active( 'DISPLAY_PHYSICAL_PATH', status);
      CASEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      local_status_table := rfv$status_table;
    IFEND;

    local_pid_selected := local_pid_specified;
    remote_pid_selected := all_pids_specified;

    FOR pid_list_index := LOWERBOUND(physical_id_list) TO UPPERBOUND(physical_id_list) DO
      IF physical_id_list[pid_list_index] = local_status_table.local_host^.physical_identifier THEN
        local_pid_selected := TRUE;
      ELSEIF physical_id_list[pid_list_index] <> '' THEN
        remote_pid_selected := TRUE;
      IFEND;
    FOREND;

    PUSH lid_displayed_p: [1 .. UPPERBOUND(logical_id_list)];

    FOR lid_list_index := LOWERBOUND(logical_id_list) TO UPPERBOUND(logical_id_list) DO
      lid_displayed_p^[lid_list_index] := FALSE;
    FOREND;

  /main_program/
    BEGIN

      clp$new_display_line (display_control, 2, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      line (1,*) := '   ';

      CASE display_type OF
      = rfc$rdt_lids =
        line (16,*) := 'LOGICAL IDENTIFIERS';
        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        clp$new_display_line (display_control, 2, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        IF input_file_p = NIL THEN
          line (2,*) := 'PID/                              HOST   STATUS';
        ELSE
          line (2,*) := 'PID/                              HOST';
        IFEND;
        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        line (2,*) := '  LIDS                            TYPE';
        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        clp$new_display_line (display_control, 2, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        IF local_pid_selected THEN
          line (1,*) := '   ';
          line (2,#SIZE(rft$physical_identifier)) := local_status_table.local_host^.physical_identifier;
          line (37,1) := 'L';
          IF input_file_p = NIL THEN
            IF local_status_table.local_host^.disabled THEN
              line (44,3) := 'OFF';
            ELSE
              line (44,2) := 'ON';
            IFEND;
          IFEND;
          clp$put_display (display_control, line, clc$trim, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;

        /display_local_lids/
          FOR lid_list_index := LOWERBOUND(logical_id_list) TO UPPERBOUND(logical_id_list) DO
            FOR lid_index := LOWERBOUND(local_status_table.local_host^.logical_identifiers) TO
                  UPPERBOUND(local_status_table.local_host^.logical_identifiers) DO
              IF (logical_id_list[lid_list_index] =
                    local_status_table.local_host^.logical_identifiers[lid_index].logical_id) OR
                    all_lids_specified THEN
                line (1,*) := '   ';
                line (4,#SIZE(rft$logical_identifier)) := local_status_table.local_host^.
                      logical_identifiers[lid_index].logical_id;
                IF input_file_p = NIL THEN
                  IF local_status_table.local_host^.logical_identifiers[lid_index].disabled THEN
                    line (44,3) := 'OFF';
                  ELSE
                    line (44,2) := 'ON';
                  IFEND;
                IFEND;
                clp$put_display (display_control, line, clc$trim, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
                lid_displayed_p^[lid_list_index] := TRUE;
                IF NOT all_lids_specified THEN
                  CYCLE /display_local_lids/;
                IFEND;
              IFEND;
            FOREND;
          FOREND /display_local_lids/;

          clp$new_display_line (display_control, 2, status);
          IF NOT status.normal THEN
            EXIT /main_program/;
          IFEND;
        IFEND;

        IF all_pids_specified OR remote_pid_selected THEN

        /display_remote_pids_lids/
          FOR pid_list_index := LOWERBOUND(physical_id_list) TO UPPERBOUND(physical_id_list) DO
            remote_host_entry_p := local_status_table.remote_hosts;
            IF remote_host_entry_p = NIL THEN
              clp$put_display (display_control, '    No remote hosts defined.', clc$trim, status);
              EXIT /main_program/;
            IFEND;

            REPEAT
              IF all_pids_specified OR
                    (physical_id_list[pid_list_index] = remote_host_entry_p^.physical_identifier)  THEN
                line (1,*) := '   ';
                line (2,#SIZE(rft$physical_identifier)) := remote_host_entry_p^.physical_identifier;
                line (37,1) := 'R';
                IF input_file_p = NIL THEN
                  IF remote_host_entry_p^.disabled THEN
                    line (44,3) := 'OFF';
                  ELSE
                    line (44,2) := 'ON';
                  IFEND;
                IFEND;
                clp$put_display (display_control, line, clc$trim, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;

              /display_remote_lids/
                FOR lid_list_index := LOWERBOUND(logical_id_list) TO UPPERBOUND(logical_id_list) DO
                  FOR lid_index := LOWERBOUND(remote_host_entry_p^.logical_identifiers) TO
                        UPPERBOUND(remote_host_entry_p^.logical_identifiers) DO
                    IF (logical_id_list[lid_list_index] =
                          remote_host_entry_p^.logical_identifiers[lid_index].logical_id) OR
                          all_lids_specified THEN
                      line (1,*) := '   ';
                      line (4,#SIZE(rft$logical_identifier)) :=
                            remote_host_entry_p^.logical_identifiers[lid_index].logical_id;
                      IF input_file_p = NIL THEN
                        IF remote_host_entry_p^.logical_identifiers[lid_index].disabled THEN
                          line (44,3) := 'OFF';
                        ELSE
                          line (44,2) := 'ON';
                        IFEND;
                      IFEND;
                      clp$put_display (display_control, line, clc$trim, status);
                      IF NOT status.normal THEN
                        EXIT /main_program/;
                      IFEND;
                      lid_displayed_p^[lid_list_index] := TRUE;
                      IF NOT all_lids_specified THEN
                        CYCLE /display_remote_lids/;
                      IFEND;
                    IFEND;
                  FOREND;
                FOREND /display_remote_lids/;

                clp$new_display_line (display_control, 2, status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
                IF NOT all_pids_specified THEN
                  CYCLE /display_remote_pids_lids/;
                IFEND;
              IFEND;
              remote_host_entry_p := remote_host_entry_p^.next_entry;
            UNTIL remote_host_entry_p = NIL;

            IF all_pids_specified THEN
                EXIT /display_remote_pids_lids/;
            IFEND;
            IF NOT ((physical_id_list[pid_list_index] = local_status_table.local_host^.physical_identifier) OR
                  (physical_id_list[pid_list_index] = '')) THEN
              osp$set_status_abnormal (rfc$product_id, rfe$physical_id_not_found,
                    physical_id_list[pid_list_index], status);
              EXIT /main_program/;
            IFEND;
          FOREND /display_remote_pids_lids/;

        IFEND;

        IF logical_id_list[1] <> '' THEN
          FOR lid_list_index := LOWERBOUND(logical_id_list) TO UPPERBOUND(logical_id_list) DO
            IF lid_displayed_p^[lid_list_index] = FALSE THEN
              IF NOT status.normal THEN
                display_status_message (status, display_control, local_status);
                IF NOT local_status.normal THEN
                  status := local_status;
                  EXIT /main_program/;
                IFEND;
              IFEND;
              osp$set_status_abnormal (rfc$product_id, rfe$logical_id_not_found,
                    logical_id_list[lid_list_index], status);
            IFEND;
          FOREND;
        IFEND;
      = rfc$rdt_paths =
        line (23,*) := 'RHFAM NETWORK PATHS';
        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        clp$new_display_line (display_control, 2, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        line (2,*) := 'PID HOST       LNAD LTCU  RTCU RNAD  DEST LOG LOG ACCESS';
        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
           EXIT /main_program/;
        IFEND;
        IF input_file_p = NIL THEN
          line (2,*) := '    TYPE  CHAN ADDR 0123  0123 ADDR  DEV  NET NAD  CODE   STATUS';
        ELSE
          line (2,*) := '    TYPE  CHAN ADDR 0123  0123 ADDR  DEV  NET NAD  CODE';
        IFEND;
        clp$put_display (display_control, line, clc$trim, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        clp$new_display_line (display_control, 2, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;

        IF local_pid_selected THEN
          line (1,*) := '   ';
          line (2,#SIZE(rft$physical_identifier)) := local_status_table.local_host^.physical_identifier;
          line (8,1) := 'L';
          IF local_status_table.local_host^.associated_paths <> NIL THEN

            FOR path_index := LOWERBOUND(local_status_table.local_host^.associated_paths^) TO
                  UPPERBOUND(local_status_table.local_host^.associated_paths^) DO
              IF input_file_p = NIL THEN
                clp$convert_integer_to_rjstring (local_status_table.local_nads^[local_status_table.
                      local_host^.associated_paths^[path_index].local_nad].channel_number, 10, FALSE, ' ',
                      line (12,3), status);
                IF NOT status.normal THEN
                  EXIT /main_program/;
                IFEND;
              ELSE
                line (13,2) := '**';
              IFEND;
              clp$convert_integer_to_rjstring (local_status_table.local_nads^[local_status_table.
                    local_host^.associated_paths^[path_index].local_nad].address, 16, FALSE, ' ', line (18,3),
                    status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              line (18,1) := ' ';

              rfp$convert_tcu_mask (
                    local_status_table.local_host^.associated_paths^[path_index].local_tcu_mask, mask_string);
              line (22,4) := mask_string;

              rfp$convert_tcu_mask (
                    local_status_table.local_host^.associated_paths^[path_index].remote_tcu_mask,
                    mask_string);
              line (28,4) := mask_string;

              CASE local_status_table.local_host^.associated_paths^[path_index].loopback OF
              = TRUE =
                clp$convert_integer_to_rjstring (local_status_table.local_nads^[local_status_table.
                      local_host^.associated_paths^[path_index].destination_nad].address, 16, FALSE, ' ',
                      line (34,3), status);
              = FALSE =
                clp$convert_integer_to_rjstring (local_status_table.remote_nads^[local_status_table.
                      local_host^.associated_paths^[path_index].remote_nad].address, 16, FALSE, ' ',
                      line (34,3), status);
              CASEND;

              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              line (34,1) := ' ';
              clp$convert_integer_to_rjstring (local_status_table.local_host^.associated_paths^[path_index].
                    destination_device, 10, FALSE,' ', line (40,2), status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              clp$convert_integer_to_rjstring (local_status_table.local_host^.associated_paths^[path_index].
                    logical_network, 16, FALSE,' ', line (44,3), status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              clp$convert_integer_to_rjstring (local_status_table.local_host^.associated_paths^[path_index].
                    logical_nad, 16, FALSE,' ', line (48,3), status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              clp$convert_integer_to_rjstring (local_status_table.local_host^.associated_paths^[path_index].
                    access_code, 16, FALSE,' ', line (52,5), status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              IF input_file_p = NIL THEN
                determine_path_state (local_status_table, local_status_table.local_host^.
                      associated_paths^[path_index], path_state, state_reason);
                line (61,4) := state_info[path_state];
                IF path_state <> rfc$es_on THEN
                  clp$put_display (display_control, line, clc$trim, status);
                  IF NOT status.normal THEN
                    EXIT /main_program/;
                  IFEND;
                  line (1,*) := '            ***PATH UNAVAILABLE - ';
                  line (35,*) := state_reason;
                IFEND;
              IFEND;
              clp$put_display (display_control, line, clc$trim, status);
              IF NOT status.normal THEN
                EXIT /main_program/;
              IFEND;
              line (1,*) := '   ';
            FOREND;

          ELSE
            clp$put_display (display_control, line, clc$trim, status);
            IF NOT status.normal THEN
              EXIT /main_program/;
            IFEND;
          IFEND;
        IFEND;

        IF all_pids_specified OR remote_pid_selected THEN

        /display_remote_pids_paths/
          FOR pid_list_index := LOWERBOUND(physical_id_list) TO UPPERBOUND(physical_id_list) DO
            remote_host_entry_p := local_status_table.remote_hosts;
            IF remote_host_entry_p = NIL THEN
              clp$put_display (display_control, '    No remote hosts defined.', clc$trim, status);
              EXIT /main_program/;
            IFEND;

            REPEAT
              IF all_pids_specified OR
                    (physical_id_list[pid_list_index] = remote_host_entry_p^.physical_identifier) THEN
                line (1,*) := '   ';
                line (2,#SIZE(rft$physical_identifier)) := remote_host_entry_p^.physical_identifier;
                line (8,1) := 'R';
                IF remote_host_entry_p^.associated_paths <> NIL THEN

                  FOR path_index := LOWERBOUND(remote_host_entry_p^.associated_paths^) TO
                        UPPERBOUND(remote_host_entry_p^.associated_paths^) DO
                    IF input_file_p = NIL THEN
                      clp$convert_integer_to_rjstring (local_status_table.local_nads^
                            [remote_host_entry_p^.associated_paths^[path_index].local_nad].channel_number, 10,
                            FALSE, ' ', line (12,3), status);
                      IF NOT status.normal THEN
                        EXIT /main_program/;
                      IFEND;
                    ELSE
                      line (13,2) := '**';
                    IFEND;
                    clp$convert_integer_to_rjstring (local_status_table.local_nads^
                          [remote_host_entry_p^.associated_paths^[path_index].local_nad].address, 16, FALSE,
                          ' ', line (18,3), status);
                    IF NOT status.normal THEN
                      EXIT /main_program/;
                    IFEND;

                    rfp$convert_tcu_mask (remote_host_entry_p^.associated_paths^[path_index].local_tcu_mask,
                          mask_string);
                    line (22,4) := mask_string;

                    rfp$convert_tcu_mask (remote_host_entry_p^.associated_paths^[path_index].remote_tcu_mask,
                          mask_string);
                    line (28,4) := mask_string;

                    clp$convert_integer_to_rjstring (local_status_table.remote_nads^[remote_host_entry_p^.
                          associated_paths^[path_index].remote_nad].address, 16, FALSE, ' ', line (34,3),
                          status);
                    IF NOT status.normal THEN
                      EXIT /main_program/;
                    IFEND;
                    clp$convert_integer_to_rjstring (remote_host_entry_p^.associated_paths^[path_index].
                          destination_device, 10, FALSE,' ', line (40,2), status);
                    IF NOT status.normal THEN
                      EXIT /main_program/;
                    IFEND;
                    clp$convert_integer_to_rjstring (remote_host_entry_p^.associated_paths^[path_index].
                          logical_network, 16, FALSE,' ', line (44,3), status);
                    IF NOT status.normal THEN
                      EXIT /main_program/;
                    IFEND;
                    clp$convert_integer_to_rjstring (
                          remote_host_entry_p^.associated_paths^[path_index].logical_nad, 16, FALSE,' ',
                          line (48,3), status);
                    IF NOT status.normal THEN
                      EXIT /main_program/;
                    IFEND;
                    clp$convert_integer_to_rjstring (
                          remote_host_entry_p^.associated_paths^[path_index].access_code, 16, FALSE,' ',
                          line (52,5), status);
                    IF NOT status.normal THEN
                      EXIT /main_program/;
                    IFEND;
                    IF input_file_p = NIL THEN
                      determine_path_state (local_status_table,
                            remote_host_entry_p^.associated_paths^[path_index], path_state, state_reason);
                      line (61,4) := state_info[path_state];
                      IF path_state <> rfc$es_on THEN
                        clp$put_display (display_control, line, clc$trim, status);
                        IF NOT status.normal THEN
                          EXIT /main_program/;
                        IFEND;
                        line (1,*) := '            ***PATH UNAVAILABLE - ';
                        line (35,*) := state_reason;
                      IFEND;
                    IFEND;
                    clp$put_display (display_control, line, clc$trim, status);
                    IF NOT status.normal THEN
                      EXIT /main_program/;
                    IFEND;
                    line (1,*) := '   ';
                  FOREND;
                ELSE
                  clp$put_display (display_control, line, clc$trim, status);
                  IF NOT status.normal THEN
                   EXIT /main_program/;
                  IFEND;
                IFEND;
                IF NOT all_pids_specified THEN
                  CYCLE /display_remote_pids_paths/;
                IFEND;
              IFEND;
              remote_host_entry_p := remote_host_entry_p^.next_entry;
            UNTIL remote_host_entry_p = NIL;

            IF all_pids_specified THEN
                EXIT /display_remote_pids_paths/;
            IFEND;
            IF NOT ((physical_id_list[pid_list_index] = local_status_table.local_host^.physical_identifier) OR
                  (physical_id_list[pid_list_index] = '')) THEN
              osp$set_status_abnormal (rfc$product_id, rfe$physical_id_not_found,
                    physical_id_list[pid_list_index], status);
              EXIT /main_program/;
            IFEND;
          FOREND /display_remote_pids_paths/;

        IFEND;
      CASEND;

    END /main_program/;

    IF input_file_p = NIL THEN
      rfp$clear_display_active;
    IFEND;

  PROCEND rfp$display_routing_info_r3;
?? TITLE := '    UTILITY SUBROUTINES', EJECT ??
?? NEWTITLE := '      determine_path_state', EJECT ??
  PROCEDURE determine_path_state (local_status_table: rft$status_table;
        path: rft$lcn_path_definition;
        VAR path_state: rft$element_state;
        VAR state_reason: STRING(*));

    VAR
      destination_nad_state: rft$element_state,
      local_tcu_index,
      remote_tcu_index: rfc$min_tcu .. rfc$max_tcu,
      remote_tcu_state: rft$element_state,
      trunk: rft$component_name,
      trunk_state: rft$element_state;

  /scan_path_elements/
    BEGIN

      state_reason := ' ';
      path_state := local_status_table.local_nads^[path.local_nad].current_status.device_status;
      CASE path_state OF
      = rfc$es_down =
        state_reason := 'the local NAD is down.';
        EXIT /scan_path_elements/;
      = rfc$es_off =
        state_reason := 'the local NAD is off.';
      ELSE
        ;
      CASEND;

      CASE path.loopback OF
      = TRUE =
        destination_nad_state :=
               local_status_table.local_nads^[path.destination_nad].current_status.device_status;
      = FALSE =
        destination_nad_state :=
               local_status_table.remote_nads^[path.remote_nad].current_status.device_status;
      CASEND;
      CASE destination_nad_state OF
      = rfc$es_off =
        IF path_state <> rfc$es_off THEN
          state_reason := 'the destination NAD is off.';
          path_state := rfc$es_off;
        IFEND;
      = rfc$es_down =
        state_reason := 'the destination NAD is down.';
        path_state := rfc$es_down;
      = rfc$es_on =
        ;
      CASEND;

      IF path_state <> rfc$es_on THEN
        EXIT /scan_path_elements/;
      IFEND;

      trunk_state := rfc$es_off;
      FOR local_tcu_index := LOWERBOUND(path.local_tcu_mask) TO UPPERBOUND(path.local_tcu_mask) DO
        IF path.local_tcu_mask[local_tcu_index] THEN

          FOR remote_tcu_index := LOWERBOUND(path.remote_tcu_mask) TO UPPERBOUND(path.remote_tcu_mask) DO
            IF path.remote_tcu_mask[remote_tcu_index] THEN
              CASE path.loopback OF
              = TRUE =
                trunk := local_status_table.local_nads^[path.destination_nad].
                      trunk_control_units[remote_tcu_index];
                remote_tcu_state := local_status_table.local_nads^[path.destination_nad].current_status.
                      tcu_status[remote_tcu_index];
              = FALSE =
                trunk :=
                      local_status_table.remote_nads^[path.remote_nad].trunk_control_units[remote_tcu_index];
                remote_tcu_state := local_status_table.remote_nads^[path.remote_nad].current_status.
                      tcu_status[remote_tcu_index];
              CASEND;
              IF trunk =
                    local_status_table.local_nads^[path.local_nad].trunk_control_units[local_tcu_index] THEN
                IF (local_status_table.local_nads^[path.local_nad].current_status.tcu_status[local_tcu_index]
                      = rfc$es_on) AND
                      (remote_tcu_state = rfc$es_on) THEN
                  EXIT /scan_path_elements/;
                ELSEIF NOT ((local_status_table.local_nads^[path.local_nad].current_status.
                      tcu_status[local_tcu_index] = rfc$es_down) OR
                      (remote_tcu_state = rfc$es_down)) THEN
                  trunk_state := rfc$es_down;
                IFEND;
              IFEND;
            IFEND;
          FOREND;

        IFEND;
      FOREND;

      state_reason := 'no trunks available';
      path_state := trunk_state;

    END /scan_path_elements/;

    IF (path_state = rfc$es_on) AND (path.failure_count <> 0) THEN
      path_state := rfc$es_down;
      state_reason := rfv$network_break_rc[path.last_network_break_rc];
    IFEND;

  PROCEND determine_path_state;
?? OLDTITLE, EJECT ??
?? NEWTITLE := '      display_status_message', EJECT ??
  PROCEDURE display_status_message (status_message: ost$status;
    VAR display_control: clt$display_control;
    VAR status: ost$status);

    VAR
      line_counter: ost$status_message_line_count,
      line_count: ^ost$status_message_line_count,
      line_size: ^ost$status_message_line_size,
      message: ^ost$status_message,
      message_level: ost$status_message_level,
      message_width: ost$max_status_message_line,
      message_line: ^string ( * );

    osp$get_message_level (message_level, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    PUSH message;
    RESET message;
    IF display_control.page_width < LOWERVALUE (message_width) THEN
      message_width := LOWERVALUE (message_width);
    ELSEIF display_control.page_width > UPPERVALUE (message_width) THEN
      message_width := UPPERVALUE (message_width);
    ELSE
      message_width := display_control.page_width;
    IFEND;
    osp$format_message (status_message, message_level, message_width, message^,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET message;
    NEXT line_count IN message;
    FOR line_counter := 1 TO line_count^ DO
      NEXT line_size IN message;
      NEXT message_line: [line_size^] IN message;
      clp$put_display (display_control, message_line^, clc$no_trim, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND display_status_message;
?? OLDTITLE, EJECT ??
?? NEWTITLE := '      get_installed_configuration', EJECT ??
  PROCEDURE [INLINE] get_installed_configuration (VAR input_file_p: ^SEQ(*);
    VAR local_status_table: rft$status_table;
    VAR status: ost$status);

    VAR
      i: INTEGER,
      lid_count,
      nad_count,
      path_count,
      remote_host_count: ^INTEGER,
      first_entry: BOOLEAN,
      input_path_entry_p,
      path_entry_p: ^rft$lcn_paths,
      input_local_host_entry_p,
      local_host_entry_p: ^rft$local_host_definition,
      previous_remote_host,
      input_remote_host_entry_p,
      remote_host_entry_p: ^rft$remote_host_definition,
      input_local_nad_table_p,
      local_nad_table_p: ^rft$local_nad_table,
      input_remote_nad_table_p,
      remote_nad_table_p: ^rft$remote_nad_table;

  {   Move the local host definition from the input configuration file into the status_table.

      NEXT  lid_count  IN  input_file_p;
      IF  lid_count = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$required_def_missing, 'local host', status);
        RETURN;
      IFEND;
      NEXT  input_local_host_entry_p : [1..lid_count^]  IN  input_file_p;
      IF  input_local_host_entry_p = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$required_def_missing, 'local host', status);
        RETURN;
      IFEND;
      PUSH  local_host_entry_p : [1..lid_count^];
      IF  local_host_entry_p = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$configuration_too_big, '', status);
        RETURN;
      IFEND;
      local_host_entry_p^ := input_local_host_entry_p^;
      local_status_table.local_host := local_host_entry_p;
      NEXT  path_count  IN  input_file_p;
      IF  path_count = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$invalid_config_file,
          'the local host path count is missing', status);
        RETURN;
      IFEND;
      IF  path_count^ <> 0  THEN
        NEXT  input_path_entry_p : [1..path_count^]  IN  input_file_p;
        IF  input_path_entry_p = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$invalid_config_file,
            'the local host path count is invalid', status);
          RETURN;
        IFEND;
        PUSH  path_entry_p : [1..path_count^];
        IF  path_entry_p = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$configuration_too_big, '', status);
          RETURN;
        IFEND;
        path_entry_p^ := input_path_entry_p^;
        local_status_table.local_host^.associated_paths := path_entry_p;
      ELSE
        local_status_table.local_host^.associated_paths := NIL;
      IFEND;

  { Move the remote host definitions from the input configuration file into the local_status_table.

      NEXT  remote_host_count  IN  input_file_p;
      IF  (remote_host_count = NIL)  OR  (remote_host_count^ = 0) THEN
        local_status_table.remote_hosts := NIL;
      ELSE
        first_entry := TRUE;
        FOR  i := 1  TO  remote_host_count^  DO
          NEXT  lid_count  IN  input_file_p;
          IF  lid_count = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$invalid_config_file,
                  'the remote host count is missing', status);
            RETURN;
          IFEND;
          NEXT  input_remote_host_entry_p : [1..lid_count^]  IN  input_file_p;
          IF  input_remote_host_entry_p = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$invalid_config_file,
                  'the remote host count is invalid', status);
            RETURN;
          IFEND;
          PUSH  remote_host_entry_p : [1..lid_count^];
          IF  remote_host_entry_p = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$configuration_too_big, '', status);
            RETURN;
          IFEND;
          remote_host_entry_p^ := input_remote_host_entry_p^;
          remote_host_entry_p^.next_entry := NIL;
          IF  first_entry  THEN
            local_status_table.remote_hosts := remote_host_entry_p;
            first_entry := FALSE;
            previous_remote_host := remote_host_entry_p;
          ELSE
            previous_remote_host^.next_entry := remote_host_entry_p;
            previous_remote_host := remote_host_entry_p;
          IFEND;
          NEXT  path_count  IN  input_file_p;
          IF  path_count = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$invalid_config_file,
                  'a remote host path count is missing', status);
            RETURN;
          IFEND;
          IF  path_count^ <> 0  THEN
            NEXT  input_path_entry_p : [1..path_count^]  IN  input_file_p;
            IF  input_path_entry_p = NIL  THEN
              osp$set_status_abnormal(rfc$product_id, rfe$invalid_config_file,
                    'a remote host path count is invalid', status);
              RETURN;
            IFEND;
            PUSH  path_entry_p : [1..path_count^];
            IF  path_entry_p = NIL  THEN
              osp$set_status_abnormal(rfc$product_id, rfe$configuration_too_big, '', status);
              RETURN;
            IFEND;
            path_entry_p^ := input_path_entry_p^;
            remote_host_entry_p^.associated_paths := path_entry_p;
          ELSE
            remote_host_entry_p^.associated_paths := NIL;
          IFEND;
        FOREND;
      IFEND;

  { Move the local nad definitions from the input configuration file into the local_status_table.

      NEXT  nad_count  IN  input_file_p;
      IF  (nad_count = NIL)  OR  (nad_count^ = 0)  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$required_def_missing, 'local NAD', status);
        RETURN;
      IFEND;
      NEXT  input_local_nad_table_p : [1..nad_count^]  IN  input_file_p;
      IF  input_local_nad_table_p = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$required_def_missing, 'local NAD', status);
        RETURN;
      IFEND;
      PUSH  local_nad_table_p : [1..nad_count^];
      IF  local_nad_table_p = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$configuration_too_big, '', status);
        RETURN;
      IFEND;
      local_nad_table_p^ := input_local_nad_table_p^;
      local_status_table.local_nads := local_nad_table_p;

  { Move the remote nad definitions from the input configuration file into the local_status_table.

      NEXT  nad_count  IN  input_file_p;
      IF  (nad_count = NIL)  OR  (nad_count^ = 0)  THEN
        local_status_table.remote_nads := NIL;
      ELSE
        NEXT  input_remote_nad_table_p : [1..nad_count^]  IN  input_file_p;
        IF  input_remote_nad_table_p = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$invalid_config_file, 'the remote NAD count is missing',
                status);
          RETURN;
        IFEND;
        PUSH remote_nad_table_p : [1..nad_count^];
        IF  remote_nad_table_p = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$configuration_too_big, '', status);
          RETURN;
        IFEND;
        remote_nad_table_p^ := input_remote_nad_table_p^;
        local_status_table.remote_nads := remote_nad_table_p;
      IFEND;

  PROCEND get_installed_configuration;
?? OLDTITLE ??
?? OLDTITLE ??
?? OLDTITLE ??

MODEND rfm$network_displays;
*DECK DECK=RFM$NETWORK_FAP EXPAND=TRUE
*copyc osd$default_pragmats
?? TITLE := 'RHFAM/VE: rfm$network_fap' ??
?? NEWTITLE := 'Ring Brackets 23D' ??
MODULE rfm$network_fap;
?? NEWTITLE := '  Global Declarations', EJECT ??
?? NEWTITLE := '    Type/Constant Definitions' ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc ame$unimplemented_request
*copyc amt$call_block
*copyc amt$fap_declarations
*copyc ost$caller_identifier
*copyc ost$status
?? POP ??
?? OLDTITLE ??
?? NEWTITLE := '    External Procedures', EJECT ??
*copyc amp$set_file_instance_abnormal
*copyc amp$validate_caller_privilege
*copyc bap$close
*copyc bap$fetch
*copyc bap$fetch_access_information
*copyc bap$store
*copyc bap$validate_file_identifier
*copyc osp$set_status_abnormal
*copyc rfp$close_file
*copyc rfp$open_file
?? OLDTITLE ??
?? NEWTITLE := '    rfp$network_fap', EJECT ??

  PROCEDURE [XDCL, #GATE] rfp$network_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer: amt$fap_layer_number;
    VAR status: ost$status);


    VAR
      caller_id: ost$caller_identifier,
      file_instance: ^bat$task_file_entry,
      ignore_structure_pointer: ^cell,
      validation_ok: boolean,
      ignore_status: ost$status;

    #caller_id (caller_id);

    status.normal := TRUE;

    bap$validate_file_identifier (file_identifier, file_instance, validation_ok);
    IF NOT validation_ok THEN
      amp$set_file_instance_abnormal (file_identifier, ame$improper_file_id, call_block.operation,
        'INVALID FILE_IDENTIFIER IN rfp$network_fap', status);
    ELSE

      CASE call_block.operation OF
      = amc$open_req =
        rfp$open_file (file_identifier, layer, call_block, status);
      = amc$close_req =
        rfp$close_file (file_identifier, layer, call_block, status);
        bap$close (file_identifier, status);
      = amc$fetch_access_information_rq =
        amp$validate_caller_privilege (file_identifier, call_block, layer, $pft$usage_selections
              [], caller_id.ring, ignore_structure_pointer, status);
        IF status.normal THEN
          bap$fetch_access_information (file_identifier, call_block, layer, status);
        IFEND;
      = amc$fetch_req =
        amp$validate_caller_privilege (file_identifier, call_block, layer, $pft$usage_selections
              [], caller_id.ring, ignore_structure_pointer, status);
        IF status.normal THEN
          bap$fetch (file_identifier, call_block, layer, status);
        IFEND;
      = amc$store_req =
        bap$store (file_identifier, call_block, layer, status);
      = amc$flush_req, amc$rewind_req, amc$skip_req, amc$write_end_partition_req =
        ; {ignore request (return normal status)
      ELSE
        ; {invalid request (return bad status)
        amp$set_file_instance_abnormal (file_identifier, ame$unimplemented_request, call_block.operation,
          'for network device files', status);
      CASEND;
    IFEND;

    file_instance^.global_file_information^.last_access_operation := call_block.operation;
    IF status.normal THEN
      file_instance^.global_file_information^.error_status := 0;
    ELSE
      file_instance^.global_file_information^.error_status := status.condition;
    IFEND;
  PROCEND rfp$network_fap;

MODEND rfm$network_fap;
*DECK DECK=RFM$PROCESS_PP_RESPONSE_FLAG EXPAND=TRUE
*copyc osd$default_pragmats
?? TITLE := 'RHFAM/VE : Process PP Response System Flag : R23D' ??
?? NEWTITLE := '  Common Decks' ??
MODULE rfm$process_pp_response_flag;
?? EJECT ??
*copyc rft$r1_interface_defs
?? EJECT ??
*copyc amp$return
*copyc amp$set_segment_eoi
*copyc cml$rhfam_failure_data
*copyc cml$rhfam_network_failure
*copyc cmp$return_desc_data_by_lun_lpn
*copyc dpp$put_critical_message
*copyc fsp$close_file
*copyc i#move
*copyc jmp$submit_job
*copyc nav$network_paged_heap
*copyc nav$network_wired_heap
*copyc osp$establish_condition_handler
*copyc osp$set_status_from_condition
*copyc osp$set_status_abnormal
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osv$task_private_heap
*copyc oss$task_private
*copyc oss$job_paged_literal
*copyc pfp$attach
*copyc pmp$continue_to_cause
*copyc pmp$exit
*copyc pmp$log
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_microsecond_clock
*copyc pmp$generate_unique_name
*copyc pmp$ready_task
*copyc rfd$mc_initialization_prams
*copyc rfd$nad_general_status
*copyc rfd$path_status_table
*copyc rfe$condition_codes
*copyc rft$network_block_protocol
*copyc rfp$release_wired_buffers
*copyc rfp$move_data_from_wired_buffs
*copyc rfp$change_nad_status
*copyc rfp$common_internal_procs
*copyc rfp$continue_data_transfer
*copyc rfp$delink_request
*copyc rfp$re_issue_request
*copyc rfp$set_connection_entry_p
*copyc rfp$lock_table
*copyc rfp$unlock_table
*copyc rfp$post_request
*copyc rfp$remove_connection
*copyc rfv$status_table
*copyc rfv$pp_interface_error
*copyc rfv$rhfam_event_table
*copyc rfv$rhfam_server_table
*copyc rfv$status_response_pending
*copyc rfv$system_task_id
*copyc sfp$emit_statistic
*copyc syp$cycle
*copyc tmv$null_global_task_id
?? TITLE := '  Global Variables' ??
?? EJECT ??

  VAR
      rfv$failure_data_symptoms: [XDCL, READ, oss$job_paged_literal]
        ARRAY [rft$failure_data_symptoms] OF STRING(25) :=
        ['FUNCTION TIMEOUT', 'CHANNEL ACTIVATE FAILED', 'CHANNEL HUNG EMPTY','PRIME FLAG TIMEOUT',
         'FLAG FUNCTION TIMEOUT', 'ABNORMAL NAD RESPONSE', 'NAD HARDWARE ABNORMAL',
         'INPUT TERMINATED EARLY', 'OUTPUT TERMINATED EARLY', 'CHANNEL PARITY ERROR',
         'UNIVERSAL COMMAND TIMEOUT', 'MEMORY ERROR ADDRESS', 'CONCURRENT CHANNEL ERROR'];

  VAR
      rfv$network_break_rc: [XDCL, READ, oss$job_paged_literal]
        ARRAY [rfc$ctnrc_no_response .. rfc$ctnrc_connection_limit_ntn] OF STRING(25) :=
        ['no answer from remote NAD', 'local TCU/TCI problem    ', 'bad remote NAD response  ',
         'remote NAD not running   ', 'remote NAD not responding', 'remote NAD hardware error',
         'unknown network failure  ', 'unknown network failure  ', 'long haul NAD lost link  ',
         'long haul NAD cannot link', 'unknown network failure  ', 'unknown network failure  ',
         'unknown network failure  ', 'unknown network failure  ', 'unknown network failure  ',
         'unknown network failure  ', 'remote NAD autoloaded    ', 'remote NAD saturated     ',
         'TCUs do not validate     ', 'path purged by remote NAD', 'remote host is inactive  ',
         'microcode level mismatch ', 'unknown network failure  ', 'unknown network failure  ',
         'NTN NAD is saturated     ', 'NTN NAD found invalid TCU', 'NTN NAD routing undefined',
         'NTN to NTN is not allowed', 'NTN link is saturated    '];

  VAR
      rfv$network_failure_symptoms: [XDCL, READ, oss$job_paged_literal]
        ARRAY [rft$network_failure_symptoms] OF STRING(25) :=
        ['CONNECTION FAILURE', 'NOT BEING USED'];

  VAR
      rfv$outstanding_requests: [XDCL, oss$task_private] ^rft$outstanding_requests := NIL;

  VAR
      rfv$request_names: [XDCL, READ, #GATE, oss$job_paged_literal]
        ARRAY [rft$nad_request_kinds] OF  STRING(25) :=
        ['local NAD load', 'local NAD status', 'local NAD dump', 'local NAD general status',
         'send data', 'receive data', 'request connection', 'accept connect request',
         'reject connect request', 'obtain connect request', 'remote NAD dump',
         'remote NAD load', 'remote NAD general status', 'path status', 'disconnect path',
         'send control message', 'receive control message', 'resume PP', 'idle PP'];

{    There is a fair amount of code in this module and RFM$EXTERNAL_INTERFACE under the
{    auspicies of synchronizing with status.  The status is a local copy of the NAD
{    path control table (actually only a subset of the NAD table).  This table is maintained
{    by the system task and is updated each time the NAD has encountered a path state change.
{    This table is also updated by other tasks during connection establishment and termination.
{    These asynchronous updates must be synchronized with the system task update.  There is
{    some additional synchronization within the system task, since PP responses are not
{    guaranteed to be processed in the order of their completion.  This code is somewhat
{    complex and may lead to a new design somewhere down the road.  For now, the coder should
{    be aware of these synchronization requirements and deal with them appropriately.

  TYPE
     rft$clear_connection_id = RECORD
       next_entry: ^rft$clear_connection_id,
       local_nad: rft$local_nads,
       connection_id: rft$concurrent_connections,
       sequence_number: INTEGER,
     RECEND;

  VAR
     rfv$clear_connection_id: [oss$task_private] ^rft$clear_connection_id := NIL;
?? TITLE := '  RFP$PROCESS_PP_RESPONSE_FLAG' ??
?? EJECT ??
  PROCEDURE  [XDCL] rfp$process_pp_response_flag(flag_id: ost$system_flag);

*copyc rfh$process_pp_response_flag
?? NEWTITLE := '    RESPONSE_PROCESSOR_CLEANUP' ??
?? EJECT ??
    PROCEDURE  response_processor_cleanup(condition: pmt$condition;
                                          condition_descriptor: ^pmt$condition_information;
                                          sfsa: ^ost$stack_frame_save_area;
                                      VAR condition_status: ost$status);


    {     This condition handler is designed to prevent normal occurrances from
    {     from causing unwanted RHFAM/VE side-affects.
    {
    {     1)  The user has passed a bad return parameter.  Segment access or
    {         possible system condition (ring 0 error).   The current request
    {         is removed (the ring 1 buffer is removed, if present).  The error condition
    {         is logged and the outer routine is EXITed.
    {
    {     2)  The system has just completed a recovery deadstart.  The request
    {         being process is removed from the list and the condition is
    {         sent to the next processor.  If control returns after the
    {         continue to cause routine is called, the outer routine is EXITed.
    {
    {     3)  All other conditions are logged.  (NOTE - the interactive condition
    {         should never be seen by this procedure).

      VAR
          status,
          ignore_status: ost$status,
          run_time_error: ^ost$status;

      CASE  condition.selector  OF
      = mmc$segment_access_condition, pmc$system_conditions =
        osp$set_status_from_condition(rfc$product_id, condition, sfsa, status, condition_status);
        IF  condition_status.normal  THEN
          IF current_request^.request_kind <> rfc$rk_disconnect_path THEN

{     Note - During the disconnect path function, this code is running under file management code
{       that prevents the logging of error messages because the local file table is locked.

            rfp$log_the_status(status);
          IFEND;
        IFEND;
        IF  current_request <> NIL  THEN
          IF  (current_request^.request_id.ring_1_id.address <> NIL)  AND
              (current_request^.posted)  THEN
            rfp$delink_request(current_request^.request_id, ignore_status);
          IFEND;
          remove_outstanding_request(current_request);
        IFEND;
        pmp$exit (condition_status);

      = pmc$user_defined_condition =
        IF  condition.user_condition_name = 'OSC$JOB_RECOVERY'  THEN
          osp$set_status_from_condition(rfc$product_id, condition, sfsa, status, condition_status);
          IF  condition_status.normal  THEN
            IF current_request^.request_kind <> rfc$rk_disconnect_path THEN

{     Note - During the disconnect path function, this code is running under file management code
{       that prevents the logging of error messages because the local file table is locked.

              rfp$log_the_status(status);
            IFEND;
          IFEND;
          IF  current_request <> NIL  THEN
            remove_outstanding_request(current_request);
          IFEND;
          pmp$continue_to_cause(pmc$execute_standard_procedure, condition_status);

          {  We cannot continue after a recovery deadstart.  This routine relies to heavily  }
          {  on the network and mainframe global segments.                                   }

          pmp$exit (condition_status);
        ELSEIF condition.user_condition_name = 'CYE$RUN_TIME_CONDITION' THEN

          {  Here if this exception is due to a run time condition (ie. a range
          {  checking error). Attempt to write a message to the system dayfile.

          IF current_request^.request_kind <> rfc$rk_disconnect_path THEN
            run_time_error := condition_descriptor;
            rfp$log_the_status(run_time_error^);
          IFEND;
          condition_status.normal := TRUE;
        ELSE
          condition_status.normal := TRUE;
        IFEND;
      ELSE
        osp$set_status_from_condition(rfc$product_id, condition, sfsa, status, condition_status);
        IF  condition_status.normal  THEN
          IF current_request^.request_kind <> rfc$rk_disconnect_path THEN
            rfp$log_the_status(status);
          IFEND;
        IFEND;
        condition_status.normal := TRUE;
      CASEND;

    PROCEND response_processor_cleanup;
?? OLDTITLE ??
?? EJECT ??

    VAR
        release_request: BOOLEAN,
        transfer_status: rft$transfer_state,
        command_buff: ^ARRAY [rft$command_entry] OF rft$command,
        current_request: ^rft$outstanding_requests;

    current_request := rfv$outstanding_requests;

    {  NOTE - the condition handler must be established after current_request is initialized.

    osp$establish_condition_handler(^response_processor_cleanup, FALSE);
    WHILE  current_request <> NIL  DO
      IF current_request^.request_id.ring_1_id.address <> NIL THEN
        command_buff := #LOC(current_request^.request_id.ring_1_id.address^.command_buffer);
      ELSE
        command_buff := NIL;
      IFEND;
      IF  current_request^.request_id.ring_3_id.location.kind = rfc$pp_request  THEN
        IF  current_request^.request_id.ring_1_id.address^.response_posted  THEN
          rfp$completed_pp_request(command_buff, current_request);
          remove_outstanding_request(current_request);
        ELSE
          current_request := current_request^.next_entry;
        IFEND;

      ELSE  {assume unit request}
        IF NOT current_request^.processing_request THEN
          IF  (current_request^.waiting_event = NIL) AND
              (current_request^.request_id.ring_1_id.address^.response_posted)  THEN
            rfp$completed_unit_request(command_buff, current_request);
          ELSEIF  (current_request^.request_kind = rfc$rk_send_data)  OR
                  (current_request^.request_kind = rfc$rk_receive_data)  THEN
            release_request := FALSE;
            IF  current_request^.waiting_event = NIL  THEN
              transfer_status.transfer_state := rfc$ts_intermediate;
              rfp$continue_data_transfer(command_buff, transfer_status, current_request, release_request);
            ELSE
              IF  current_request^.waiting_event^.event_occurred_type <> rfc$eot_no_event  THEN
                transfer_status.transfer_state := rfc$ts_resource_limit_change;
                rfp$continue_data_transfer(command_buff, transfer_status, current_request, release_request);
              IFEND;
            IFEND;
            IF  release_request  THEN
              remove_outstanding_request(current_request);
            ELSE
              current_request := current_request^.next_entry;
            IFEND;
          ELSE
            current_request := current_request^.next_entry;
          IFEND;
        ELSE
          current_request := current_request^.next_entry;
        IFEND;
      IFEND;
    WHILEND;

  PROCEND rfp$process_pp_response_flag;
?? NEWTITLE := '    RFP$COMPLETED_PP_REQUEST' ??
?? EJECT ??
  PROCEDURE rfp$completed_pp_request(command_buff: ^ARRAY [rft$command_entry] OF rft$command;
                                 VAR current_request: ^rft$outstanding_requests);

{    The purpose of this procedure is to process a completed pp request.
{
{    command_buff: (input) This parameter points to the command buffer of the request.
{
{    current_request: (input,output) This parameter specifies the pointer to the completed request.

    VAR
        response_value: integer,
        request_id: rft$request_identifier,
        status: ost$status;

    status.normal := TRUE;
    request_id := current_request^.request_id;

    CASE  command_buff^[rfc$cbi_pp_request].pp_function_code  OF

    = rfc$pp_idle =
      IF  request_id.ring_1_id.address^.response.response_code.primary_response = ioc$normal_response  THEN
        rfv$status_table.local_nads^[request_id.ring_3_id.nad].pp[request_id.ring_3_id.pp].pp_state :=
          rfc$pps_idle;
      ELSE
        osp$set_status_abnormal(rfc$product_id, rfe$unexpected_response, 'pp idle request', status);
        response_value := $INTEGER(request_id.ring_1_id.address^.response.response_code.primary_response);
        osp$append_status_integer(osc$status_parameter_delimiter, response_value, 10, FALSE, status);
      IFEND;

    = rfc$pp_resume =
      IF  request_id.ring_1_id.address^.response.response_code.primary_response = ioc$normal_response  THEN
        rfv$status_table.local_nads^[request_id.ring_3_id.nad].pp[request_id.ring_3_id.pp].pp_state :=
          rfc$pps_normal;
      ELSE
        osp$set_status_abnormal(rfc$product_id, rfe$unexpected_response, 'pp resume request', status);
        response_value := $INTEGER(request_id.ring_1_id.address^.response.response_code.primary_response);
        osp$append_status_integer(osc$status_parameter_delimiter, response_value, 10, FALSE, status);
      IFEND;

    ELSE
      osp$set_status_abnormal(rfc$product_id, rfe$unknown_request, 'pp', status);
      osp$append_status_integer(osc$status_parameter_delimiter,
        command_buff^[rfc$cbi_pp_request].pp_function_code, 16, TRUE, status);
    CASEND;

    IF  NOT status.normal  THEN
      rfp$log_the_status(status);
    IFEND;
    rfp$delink_request(request_id, status);
    IF  NOT status.normal  THEN
      rfp$log_the_status(status);
    IFEND;

  PROCEND rfp$completed_pp_request;
?? TITLE := '    REMOVE_OUTSTANDING_REQUEST' ??
?? EJECT ??
  PROCEDURE  remove_outstanding_request(VAR request: ^rft$outstanding_requests);

{    The purpose of this procedure is to remove a request identifier from the
{    outstanding request queue.
{
{    request: (input,output) This parameter points to the entry to be removed
{      from the list.  Upon exit this parameter points to the next entry in the
{      outstanding request list.

    VAR
        next_request,
        previous_request: ^rft$outstanding_requests;

    IF  request^.posted  THEN
      rfp$lock_table(rfv$status_table.lock);
      rfv$status_table.local_nads^[request^.request_id.ring_3_id.nad].requests_posted :=
        rfv$status_table.local_nads^[request^.request_id.ring_3_id.nad].requests_posted - 1;
      rfp$unlock_table(rfv$status_table.lock);
    IFEND;
    IF  rfv$outstanding_requests^.request_id.ring_3_id.entry = request^.request_id.ring_3_id.entry  THEN
      rfv$outstanding_requests := request^.next_entry;
    ELSE
      previous_request := rfv$outstanding_requests;
      WHILE  previous_request^.next_entry^.request_id.ring_3_id.entry <> request^.request_id.ring_3_id.entry
                                                                                                          DO
        previous_request := previous_request^.next_entry;
      WHILEND;
      previous_request^.next_entry := request^.next_entry;
    IFEND;
    next_request := request^.next_entry;

    FREE  request  IN  osv$task_private_heap^;

    request := next_request;

  PROCEND remove_outstanding_request;
?? OLDTITLE ??
?? TITLE := '  RFP$COMPLETED_UNIT_REQUEST' ??
?? EJECT ??
  PROCEDURE [XDCL] rfp$completed_unit_request(command_buff:^ARRAY[rft$command_entry] OF rft$command;
                                          VAR current_request: ^rft$outstanding_requests);

{    The purpose of this procedure is to process a completed unit request.
{
{    command_buff: (input) This parameter points to the command buffer of the corresponding request.
{
{    current_request: (input,output) This parameter specifies the pointer to the completed request.

    VAR
        recoverable: boolean,
        pp_response: ^iot$pp_response,
        detailed_status: ^rft$detailed_status,
        release_request: boolean,
        abnormal_stat: iot$abnormal_status,
        abnormal_status: ^rft$abnormal_status,
        response_value,
        state_value: integer,
        transfer_status: rft$transfer_state,
        ignore_status,
        status: ost$status;

    status.normal := TRUE;
    release_request := TRUE;
    detailed_status := ^current_request^.request_id.ring_1_id.address^.detailed_status;
    pp_response := ^current_request^.request_id.ring_1_id.address^.response;

  /main_section/
    BEGIN

      IF    (pp_response^.response_code.primary_response <> ioc$normal_response)  AND
            (pp_response^.response_code.primary_response <> ioc$abnormal_response)  THEN
        rfp$delink_request(current_request^.request_id, ignore_status);
        osp$set_status_abnormal(rfc$product_id, rfe$unexpected_response, 'unit request', status);
        response_value := $INTEGER(pp_response^.response_code.primary_response);
        osp$append_status_integer(osc$status_parameter_delimiter, response_value, 10, FALSE, status);
        EXIT  /main_section/;
      IFEND;

      CASE  current_request^.request_kind  OF

      = rfc$rk_local_nad_load =

        process_local_load_response(command_buff, pp_response, detailed_status, current_request,
          release_request, status);

      = rfc$rk_local_nad_dump =

        process_local_dump_response(command_buff, pp_response, detailed_status, current_request,
          release_request, status);

      = rfc$rk_local_nad_status =

        process_nad_status_response(command_buff, pp_response, detailed_status, current_request,
          release_request, status);

      = rfc$rk_request_connection =

        process_req_connect_response(command_buff, pp_response, detailed_status, current_request,
          release_request, status);

      = rfc$rk_obtain_connect_request =

        process_obt_connect_response(command_buff, pp_response, detailed_status, current_request,
          release_request, status);

      = rfc$rk_accept_connect_request =

        process_acc_connect_response(command_buff, pp_response, detailed_status, current_request,
          release_request, status);

      = rfc$rk_reject_connect_request =

        process_rej_connect_response(command_buff, pp_response, detailed_status, current_request,
          release_request, status);

      = rfc$rk_send_data, rfc$rk_receive_data =

        abnormal_stat := pp_response^.abnormal_status;
        abnormal_status := #LOC(abnormal_stat);
        IF  pp_response^.response_code.primary_response = ioc$normal_response  THEN
          transfer_status.transfer_state := rfc$ts_normal;
        ELSEIF  (abnormal_status^.invalid_status_value) AND
                (detailed_status^.last_mc_status.response = rfc$nr_transfer_not_ready) AND
                (NOT detailed_status^.last_mc_status.hardware_fault)  THEN
          transfer_status.transfer_state := rfc$ts_resource_limit;
        ELSEIF  ((detailed_status^.last_mc_status.response = rfc$nr_abort) OR
                 (detailed_status^.last_mc_status.response = rfc$nr_flush) OR
                 (detailed_status^.last_mc_status.response = rfc$nr_disconnected) OR
                 (detailed_status^.last_mc_status.response = rfc$nr_negative_acknowledge))
              AND (abnormal_status^.invalid_status_value)
              AND (NOT detailed_status^.last_mc_status.hardware_fault) THEN
          transfer_status.transfer_state := rfc$ts_broken;
        ELSE
          IF  abnormal_status^.alert_condition_encountered  THEN
            log_alert_condition(pp_response^.alert_conditions, pp_response^.alert_mask,
              current_request^.request_kind, transfer_status, ignore_status);
          ELSE
            log_nad_error(pp_response, detailed_status, current_request^.request_kind,
              current_request^.retry_count, current_request^.request_id.ring_3_id.nad,
              command_buff^[rfc$cbi_unit_request_2].lc_path_id, FALSE, recoverable);
            IF  recoverable  THEN
              current_request^.retry_count := current_request^.retry_count + 1;
              transfer_status.transfer_state := rfc$ts_retryable_error;
            ELSE
              transfer_status.transfer_state := rfc$ts_fatal_error;
            IFEND;
          IFEND;
        IFEND;
        rfp$continue_data_transfer(command_buff, transfer_status, current_request, release_request);
        IF  release_request  THEN
          rfp$delink_request(current_request^.request_id, ignore_status);
        IFEND;

      = rfc$rk_disconnect_path =

        rfp$process_disconnect_response(command_buff, pp_response, detailed_status, current_request,
          release_request, status);

      = rfc$rk_path_status =

        process_path_status_response(command_buff, pp_response, detailed_status, current_request,
          release_request, status);

      = rfc$rk_send_control_mess =

        process_send_ctrl_response(command_buff, pp_response, detailed_status, current_request,
          release_request, status);

      = rfc$rk_receive_control_mess =

        process_rec_ctrl_response(command_buff, pp_response, detailed_status, current_request,
          release_request, status);

      ELSE   { end unit request CASE statement }
        rfp$delink_request(current_request^.request_id, ignore_status);
        osp$set_status_abnormal(rfc$product_id, rfe$unknown_request, 'unit', status);
        osp$append_status_integer(osc$status_parameter_delimiter,
          command_buff^[rfc$cbi_unit_request_1].lc_function_code, 16, TRUE, status);
      CASEND;

    END /main_section/;

    IF  NOT status.normal  THEN
      IF current_request^.request_kind <> rfc$rk_disconnect_path THEN

{     Note - During the disconnect path function, this code is running under file management code
{       that prevents the logging of error messages because the local file table is locked.

        rfp$log_the_status(status);
      IFEND;
    IFEND;

    IF  release_request  THEN
      remove_outstanding_request(current_request);
    ELSE
      current_request := current_request^.next_entry;
    IFEND;

  PROCEND rfp$completed_unit_request;
?? NEWTITLE := '    PROCESS_LOCAL_LOAD_RESPONSE' ??
?? EJECT ??
  PROCEDURE  process_local_load_response(command_buff: ^ARRAY [rft$command_entry] OF rft$command;
                                         pp_response: ^iot$pp_response;
                                         detailed_status: ^rft$detailed_status;
                                     VAR current_request: ^rft$outstanding_requests;
                                     VAR release_request: BOOLEAN;
                                     VAR status: ost$status);

{    The purpose of this procedure is to process a completed local NAD load request.
{
{    command_buff: (input) This parameter specifies a pointer to the command buffer of the
{      corresponding request.
{
{    pp_response: (input) This parameter speicifies a pointer to the corresponding pp response.
{
{    detailed_status: (input) This parameter specifies a pointer to the detailed status (if any).
{
{    current_request: (input,output) This parameter specifies the pointer to the completed request.
{
{    release_request: (input,output) This parameter states whether the corresponding request has been
{      completed and should be removed from the outstanding request queue.  The calling routine must
{      initialize this to TRUE.
{
{    status: (output) This parameter returns the results of the request.  The calling routine must
{      initialize the status to normal.

    CONST
        rfc$180_device_type = 212,
        rfc$current_microcode_revision = 0,
        rfc$nt_starting_address = 66;

    VAR
        request_info: ^SEQ(*),
        mc_status: ^rft$nad_general_status,
        actual_memory,
        unused_memory: rft$nad_memory_size,
        nad_address: rft$nad_address,
        tcu_enabled: rft$tcu_mask,
        device_type,
        revision_level: 0..0ff(16),
        tcu_index: rfc$min_tcu .. rfc$max_tcu,
        recoverable: boolean,
        current_time: integer,
        response_value,
        state_value: integer,
        load_request_status: ^rft$load_dump_status,
        nad_index: rft$local_nads,
        local_nad: ^rft$local_nad_entry,
        local_status,
        ignore_status: ost$status;

    load_request_status := current_request^.request_status;
    nad_index := current_request^.request_id.ring_3_id.nad;
    local_nad := ^rfv$status_table.local_nads^[nad_index];

  /main_section/
    BEGIN

      { Response will be abnormal at beginning of NAD test, if 32K/48K NAD memory size.

      IF  (pp_response^.response_code.primary_response = ioc$normal_response)  OR
            ( (load_request_status^.state = rfc$lt_mem_test_read)  AND
              (load_request_status^.nt_data = rfc$nt_inc_addr) )  THEN

        IF  load_request_status^.state = rfc$ls_get_mc_status  THEN
          mc_status := #LOC(command_buff^[rfc$cbi_general_buffer]);
{         IF  load_request_status^.initial_phase  THEN
            actual_memory := mc_status^.actual_memory_size;
            unused_memory := mc_status^.unused_memory;
{         ELSE
            nad_address := mc_status^.nad_address;
            tcu_enabled := mc_status^.actual_tcus;
            revision_level := mc_status^.microcode_revision_level;
            device_type := mc_status^.device_interface_type;
{         IFEND;
        IFEND;

        rfp$delink_request(current_request^.request_id, status);
        IF  NOT status.normal  THEN
          EXIT  /main_section/;
        IFEND;

        CASE  load_request_status^.state  OF

        = rfc$lt_mem_test_begin, rfc$lt_mem_test_write, rfc$lt_mem_test_read =

          IF  load_request_status^.state = rfc$lt_mem_test_begin  THEN
            load_request_status^.state := rfc$lt_mem_test_write;
            load_request_status^.current_nad_address := rfc$nt_starting_address;
            load_request_status^.nt_data := rfc$nt_inc_addr;
            IF load_request_status^.mem_test_first_pass THEN
              load_request_status^.nt_length := (((rfc$max_nad_memory_size * 2) DIV 6) * 6) + 6;
            IFEND;
            load_request_status^.nt_offset := load_request_status^.current_nad_address * 2;
          IFEND;

          IF  load_request_status^.state = rfc$lt_mem_test_read  THEN
            IF  (load_request_status^.nt_length - load_request_status^.nt_offset)  > 0  THEN
              check_data_in_wired_buffs(load_request_status^.buffer_list^,
                load_request_status^.number_of_buffers, nad_index, load_request_status, status);
              IF  NOT status.normal  THEN
                EXIT  /main_section/;
              IFEND;
            IFEND;
            IF  load_request_status^.state = rfc$lt_mem_test_write  THEN
              load_request_status^.current_nad_address := rfc$nt_starting_address;
              load_request_status^.nt_offset := load_request_status^.current_nad_address * 2;
            ELSEIF  load_request_status^.state = rfc$lt_mem_test_begin  THEN
              rfp$change_nad_status(local_nad^.logical_unit_number, rfc$es_on);
              EXIT  /main_section/;
            ELSE
              IF  load_request_status^.state = rfc$ls_begin_load  THEN
                load_request_status^.current_nad_address := 0;
              IFEND;
            IFEND;
          IFEND;

          IF  load_request_status^.state = rfc$lt_mem_test_write  THEN
            IF  (load_request_status^.nt_length - load_request_status^.nt_offset)  > 0  THEN
              put_data_in_wired_buffs(load_request_status^.buffer_list^,
                load_request_status^.number_of_buffers, load_request_status, status);
              IF  NOT status.normal  THEN
                EXIT  /main_section/;
              IFEND;
            ELSE  { NAD memory written
              load_request_status^.state := rfc$lt_mem_test_read;
              load_request_status^.current_nad_address := rfc$nt_starting_address;
              load_request_status^.nt_offset := load_request_status^.current_nad_address * 2;
              IF  (load_request_status^.mem_test_first_pass)  AND
                  (load_request_status^.nt_length > (rfc$max_nad_memory_size * 2))  THEN
                load_request_status^.nt_length := (((rfc$max_nad_memory_size * 2) DIV 6) * 6);
              IFEND;
            IFEND;
          IFEND;

        = rfc$ls_begin_load, rfc$ls_sending_microcode, rfc$ls_sending_init_prams =

          {        Continue load request      }

        = rfc$ls_go_sent =

          load_request_status^.state := rfc$ls_get_mc_status;

        = rfc$ls_get_mc_status =

{ The following clause is commented out as a temporary fix to the problem of
{ 2 times too much memory being requested of the NAD when the default memory size
{ is set to 0ff(16). 0ff(16) indicates that the amount of NAD memory available
{ should be determined and the appropriate amount used.
{
{         IF  load_request_status^.initial_phase  THEN
{           load_request_status^.initial_phase := FALSE;
{           load_request_status^.state := rfc$ls_begin_load;
{           load_request_status^.time_of_first_go := 0;
{           load_request_status^.current_nad_address := 0;
{           unused_memory := (actual_memory - load_request_status^.init_prams.memory_size) + unused_memory;
{           load_request_status^.init_prams.memory_size := actual_memory;
{           load_request_status^.init_prams.type_1_buff_count :=
{             load_request_status^.init_prams.type_1_buff_count + (unused_memory DIV
{             (rfc$nad_type_1_buff_lgth + rfc$nad_type_1_header_lgth));
{           unused_memory := unused_memory MOD (rfc$nad_type_1_buff_lgth + rfc$nad_type_1_header_lgth);
{           load_request_status^.init_prams.control_messages :=
{             load_request_status^.init_prams.control_messages +
{             (unused_memory DIV rfc$nad_ctrl_mess_buff_lgth);
{         ELSE
            rfp$lock_table(rfv$status_table.lock);
            IF  local_nad^.current_status.device_status = rfc$es_down  THEN
              local_nad^.current_status.device_status := rfc$es_on;
            IFEND;
            local_nad^.address := nad_address;
            FOR  tcu_index := rfc$min_tcu  TO  rfc$max_tcu  DO
              IF  (local_nad^.current_status.tcu_status[tcu_index] <> rfc$es_off)  THEN
                IF  tcu_enabled[tcu_index]  THEN
                  local_nad^.current_status.tcu_status[tcu_index] := rfc$es_on;
                ELSE
                  local_nad^.current_status.tcu_status[tcu_index] := rfc$es_down;
                IFEND;
              IFEND;
            FOREND;
            local_nad^.maintenance_status.reloads_performed :=
              local_nad^.maintenance_status.reloads_performed + 1;
            rfp$unlock_table(rfv$status_table.lock);
            IF  local_nad^.address <> local_nad^.defined_address  THEN
              osp$set_status_abnormal(rfc$product_id, rfe$nad_address_mismatch, local_nad^.name,
                local_status);
              osp$append_status_integer(osc$status_parameter_delimiter, local_nad^.defined_address,
                16, TRUE, local_status);
              osp$append_status_integer(osc$status_parameter_delimiter, local_nad^.address, 16, TRUE,
                local_status);
              rfp$log_the_status(local_status);
            IFEND;
            IF  device_type <> rfc$180_device_type  THEN
              osp$set_status_abnormal(rfc$product_id, rfe$nad_device_type_mismatch, local_nad^.name,
                local_status);
              osp$append_status_integer(osc$status_parameter_delimiter, device_type,
                10, FALSE, local_status);
              osp$append_status_integer(osc$status_parameter_delimiter, rfc$180_device_type, 10,
                FALSE, local_status);
              rfp$log_the_status(local_status);
            IFEND;
            IF  revision_level <> rfc$current_microcode_revision  THEN
              osp$set_status_abnormal(rfc$product_id, rfe$nad_microcode_mismatch, local_nad^.name,
                local_status);
              osp$append_status_integer(osc$status_parameter_delimiter, revision_level,
                10, FALSE, local_status);
              osp$append_status_integer(osc$status_parameter_delimiter, rfc$current_microcode_revision, 10,
                FALSE, local_status);
              rfp$log_the_status(local_status);
            IFEND;
            FOR  tcu_index := rfc$min_tcu  TO  rfc$max_tcu  DO
              IF  (local_nad^.trunk_control_units[tcu_index] <> '') AND
                  (local_nad^.current_status.tcu_status[tcu_index] = rfc$es_down)  THEN
                osp$set_status_abnormal(rfc$product_id, rfe$nad_tcu_unavailable, local_nad^.name,
                  local_status);
                osp$append_status_parameter(osc$status_parameter_delimiter,
                  local_nad^.trunk_control_units[tcu_index], local_status);
                osp$append_status_integer(osc$status_parameter_delimiter, tcu_index, 10, FALSE,
                  local_status);
                rfp$log_the_status(local_status);
              IFEND;
            FOREND;
            osp$set_status_abnormal(rfc$product_id, rfe$microcode_loaded, 'SUCCEEDED', status);
            osp$append_status_parameter(osc$status_parameter_delimiter, 'local NAD:  ', status);
            osp$append_status_parameter(osc$status_parameter_delimiter,
              local_nad^.name, status);
{         IFEND;

        ELSE

          osp$set_status_abnormal(rfc$product_id, rfe$abnormal_state, 'load request', status);
          state_value := $INTEGER(load_request_status^.state);
          osp$append_status_integer(osc$status_parameter_delimiter, state_value, 10, FALSE, status);
        CASEND;

      ELSE  {  ioc$abnormal_response  }

        IF  (load_request_status^.state = rfc$ls_go_sent)
            AND (pp_response^.response_code.secondary_response = 1) {detailed status appended}
            AND (detailed_status^.last_mc_status.response = 0)
            AND (NOT detailed_status^.last_mc_status.hardware_fault)  THEN
          pmp$get_microsecond_clock(current_time, ignore_status);
          IF  (current_time - load_request_status^.time_of_first_go) < (10*1000*1000)  THEN { 10 seconds }
            rfp$delink_request(current_request^.request_id, status);
            EXIT  /main_section/;
          IFEND;
        IFEND;

        log_nad_error(pp_response, detailed_status, current_request^.request_kind,
          current_request^.retry_count, nad_index, 0, TRUE, recoverable);
        rfp$delink_request(current_request^.request_id, status);
        IF  NOT status.normal  THEN
          EXIT  /main_section/;
        IFEND;
        IF  recoverable  THEN
          current_request^.retry_count := current_request^.retry_count + 1;
          IF  (load_request_status^.state = rfc$lt_mem_test_begin)   OR
              (load_request_status^.state = rfc$lt_mem_test_write)   OR
              (load_request_status^.state = rfc$lt_mem_test_read)  THEN
            load_request_status^.state := rfc$lt_mem_test_begin;
          ELSE
            load_request_status^.state := rfc$ls_begin_load;
          IFEND;
          load_request_status^.time_of_first_go := 0;
          load_request_status^.current_nad_address := 0;
        ELSE
          rfv$status_table.local_nads^[nad_index].maintenance_status.reload_failed := TRUE;
          osp$set_status_abnormal(rfc$product_id, rfe$microcode_loaded, 'FAILED', status);
          osp$append_status_parameter(osc$status_parameter_delimiter, 'local NAD: ', status);
          osp$append_status_parameter(osc$status_parameter_delimiter,
            rfv$status_table.local_nads^[nad_index].name, status);
        IFEND;
      IFEND;

    END /main_section/;

    IF  status.normal  THEN

      {   NOTE - status is abnormal for failures and for completed local loads }

      PUSH  request_info : [[REP  2*rfc$command_buffer_size OF rft$command]];
      RESET request_info;
      rfp$build_load_request(load_request_status, request_info, status);
      IF  status.normal  THEN
        rfp$post_request(request_info, current_request^.request_id, status);
        IF  status.normal  THEN
          release_request := FALSE;
        IFEND;
      IFEND;
    IFEND;

    IF  NOT status.normal  THEN
      IF  (load_request_status^.state = rfc$lt_mem_test_begin)   OR
          (load_request_status^.state = rfc$lt_mem_test_write)   OR
          (load_request_status^.state = rfc$lt_mem_test_read)  THEN
        local_nad^.maintenance_status.reload_failed := TRUE;
      IFEND;
      rfv$status_table.local_nads^[nad_index].maintenance_status.test_requested := FALSE;
      fsp$close_file(load_request_status^.mc_file_id, ignore_status);
      amp$return(load_request_status^.mc_lfn, ignore_status);
      rfp$release_wired_buffers(load_request_status^.buffer_list^, load_request_status^.number_of_buffers);
      FREE  load_request_status^.buffer_list  IN  osv$task_private_heap^;
      FREE  load_request_status  IN  osv$task_private_heap^;
    IFEND;

  PROCEND process_local_load_response;
 ?? NEWTITLE := '      PUT_DATA_IN_WIRED_BUFFS' ??
 ?? EJECT ??
  PROCEDURE [INLINE] put_data_in_wired_buffs(VAR buffer_list: rft$buffer_list;
                                                 buffer_count: rft$buffer_count;
                                             VAR load_request_status: ^rft$load_dump_status;
                                             VAR status: ost$status);

{    This procedure stores test data in network wired buffers.
{
{    buffer_list: (input,output) This parameter specifies the list of wired buffers to write.
{
{    buffer_count: (input) This parameter specifies the number of wired buffers.
{
{    load_request_status: (input,output). This parameter points to the load_dump_status block,
{      which contains the current offset of the next portion of test data. On exit, the offset is updated.


    VAR
        buffer_ptr: ^CELL,
        bytes_remaining: rft$bytes_transferred,
        current_buffer: rft$buffer_count,
        dest_ptr: ^rft$nad_memory_size,
        index: integer,
        nad_addr: rft$nad_memory_size,
        nad_data: rft$nad_memory_size,
        nad_data_inc: integer,
        room_in_buffer: rft$bytes_transferred;


    nad_addr := ((load_request_status^.nt_offset DIV 2) MOD (rfc$max_nad_memory_size+1));
    bytes_remaining := load_request_status^.nt_length - load_request_status^.nt_offset;

    CASE  load_request_status^.nt_data OF

    = rfc$nt_inc_addr =
      nad_data := nad_addr;
      nad_data_inc := 1;

    = rfc$nt_dec_addr =
      nad_data := 0ffff(16) - nad_addr;
      nad_data_inc := -1;

    = rfc$nt_con_5555 =
      nad_data := 05555(16);
      nad_data_inc := 0;

    = rfc$nt_con_aaaa =
      nad_data := 0aaaa(16);
      nad_data_inc := 0;

    ELSE
      nad_data := 0;
      nad_data_inc := 0;

    CASEND;

    status.normal := TRUE;
    FOR current_buffer := 1 TO buffer_count DO
      buffer_list[current_buffer].byte_count := 0;
    FOREND;

    current_buffer := 1;
    WHILE  (bytes_remaining > 0) AND
           (current_buffer <= buffer_count) DO
      room_in_buffer := buffer_list[current_buffer].length;
      IF  room_in_buffer > bytes_remaining  THEN
        room_in_buffer := bytes_remaining;
      IFEND;

      FOR  index := 0 TO ((room_in_buffer DIV 2) - 1) DO
        buffer_ptr := i#ptr((index * 2), buffer_list[current_buffer].buffer);
        dest_ptr := buffer_ptr;
        dest_ptr^ := nad_data;
        nad_data := ((nad_data + nad_data_inc) MOD (rfc$max_nad_memory_size+1));
      FOREND;
      buffer_list[current_buffer].byte_count := room_in_buffer;
      bytes_remaining := bytes_remaining - room_in_buffer;
      current_buffer := current_buffer + 1;
    WHILEND;
    load_request_status^.nt_offset := load_request_status^.nt_length - bytes_remaining;
  PROCEND put_data_in_wired_buffs;
?? TITLE := '      CHECK_DATA_IN_WIRED_BUFFS' ??
?? EJECT ??
  PROCEDURE [INLINE] check_data_in_wired_buffs(VAR buffer_list: rft$buffer_list;
                                                   buffer_count: rft$buffer_count;
                                                   nad_index: rft$local_nads;
                                               VAR load_request_status: ^rft$load_dump_status;
                                               VAR status: ost$status);

{    This procedure checks test data read from NAD memory into the network wired buffers.
{
{    buffer_list: (input,output) This parameter specifies the list of buffers to check.
{
{    buffer_count: (input) This parameter specifies the number of wired buffers.
{
{    nad_index: (input) This parameter specifies the local NAD that is being tested.
{
{    load_request_status: (input,output). This parameter points to the load-dump-status block,
{      which contains the current offset of the next portion of test data. On exit, the offset is updated.

    CONST
        nad_memory_bank_words = 4000(16);    { Number of 16-bit words }

    VAR
        buffer_ptr: ^CELL,
        bytes_remaining: rft$bytes_transferred,
        current_buffer: rft$buffer_count,
        data_in_buffer: rft$bytes_transferred,
        index: rft$bytes_transferred,
        nad_addr: rft$nad_memory_size,
        nad_data: rft$nad_memory_size,
        nad_data_inc: integer,
        source_ptr: ^rft$nad_memory_size;


    nad_addr := load_request_status^.nt_offset DIV 2;
    bytes_remaining := load_request_status^.nt_length - load_request_status^.nt_offset;

    CASE  load_request_status^.nt_data OF

    = rfc$nt_inc_addr =
      nad_data := nad_addr;
      nad_data_inc := 1;

    = rfc$nt_dec_addr =
      nad_data := 0ffff(16) - nad_addr;
      nad_data_inc := -1;

    = rfc$nt_con_5555 =
      nad_data := 05555(16);
      nad_data_inc := 0;

    = rfc$nt_con_aaaa =
      nad_data := 0aaaa(16);
      nad_data_inc := 0;

    ELSE
      nad_data := 0;
      nad_data_inc := 0;

    CASEND;

    status.normal := TRUE;
    current_buffer := 1;
    /check_data/
    WHILE  (bytes_remaining > 0) AND
           (current_buffer <= buffer_count) AND
           (buffer_list[current_buffer].byte_count > 0)  DO
      data_in_buffer := buffer_list[current_buffer].byte_count;
      IF  data_in_buffer > bytes_remaining  THEN
        data_in_buffer := bytes_remaining;
      IFEND;

      FOR  index := 0 TO ((data_in_buffer DIV 2) - 1) DO
        buffer_ptr := i#ptr((index * 2), buffer_list[current_buffer].buffer);
        source_ptr := buffer_ptr;
        IF  nad_data = source_ptr^  THEN
          nad_data := ((nad_data + nad_data_inc) MOD (rfc$max_nad_memory_size+1));
        ELSE
          IF  (load_request_status^.mem_test_first_pass)  AND
              (((nad_data - 1) MOD nad_memory_bank_words) >= 0FFB(16))  THEN
            load_request_status^.nt_length := (((nad_data - 1) * 2) DIV 6) * 6;
            bytes_remaining := 0;
            EXIT /check_data/;
          ELSE
            log_nad_memory_error(nad_index, (nad_addr+index), nad_data, source_ptr^);
            osp$set_status_abnormal(rfc$product_id, rfe$test_nad_failure,
              rfv$status_table.local_nads^[nad_index].name, status);
            rfp$log_the_status(status);
            osp$set_status_abnormal(rfc$product_id, rfe$microcode_loaded, 'FAILED', status);
            osp$append_status_parameter(osc$status_parameter_delimiter, 'local NAD:  ', status);
            osp$append_status_parameter(osc$status_parameter_delimiter,
            rfv$status_table.local_nads^[nad_index].name, status);
            RETURN;
          IFEND;
        IFEND;
      FOREND;
      buffer_list[current_buffer].byte_count := 0;
      bytes_remaining := bytes_remaining - data_in_buffer;
      current_buffer := current_buffer + 1;
      nad_addr := nad_addr + (data_in_buffer DIV 2);
    WHILEND/check_data/;

    IF  bytes_remaining > 0  THEN
      load_request_status^.nt_offset := load_request_status^.nt_length - bytes_remaining;
    ELSE
      IF load_request_status^.mem_test_first_pass THEN
        load_request_status^.mem_test_first_pass := FALSE;
        load_request_status^.state := rfc$lt_mem_test_begin;
      ELSE
        load_request_status^.state := rfc$lt_mem_test_write;

        CASE  load_request_status^.nt_data OF
        = rfc$nt_inc_addr =
          load_request_status^.nt_data := rfc$nt_dec_addr;

        = rfc$nt_dec_addr =
          load_request_status^.nt_data := rfc$nt_con_5555;

        = rfc$nt_con_5555 =
          load_request_status^.nt_data := rfc$nt_con_aaaa;


        ELSE {testing done
          load_request_status^.state := rfc$ls_begin_load;
        CASEND;
      IFEND;
    IFEND;

  PROCEND check_data_in_wired_buffs;
?? TITLE := '            LOG_NAD_MEMORY_ERROR' ??
?? EJECT ??
  PROCEDURE  log_nad_memory_error(nad_index: rft$local_nads;
                                  mem_addr: rft$nad_memory_size;
                                  mem_val1: rft$nad_memory_size;
                                  mem_val2: rft$nad_memory_size);

{    This procedure generates and logs a message indicating a NAD memory test error.
{
{    The message has the form "device-identifier*UF*MEMORY ERROR ADDRESS xxxx EXPECTED yyyy ACTUAL zzzz"
{      where device-identifier shows the system and NAD names, IOU, PP, and channel numbers (decimal),
{      and xxxx, yyyy, and zzzz (hexidecimal) show the address, expected and actual contents of the
{      word in NAD memory.
{
{    nad_index: (input) This parameter specifies the local NAD that failed.
{
{    mem_addr: (input) This parameter specifies the faulty NAD memory address.
{
{    mem_val1: (input) This parameter specifies the value expected.
{
{    mem_val2: (input) This parameter specifies the value actually read.


    VAR
        concurrent_channel_flag: integer,
        counters: ^ARRAY [1..*] OF sft$counter,
        descriptor_data: ost$string,
        ignore: ost$status,
        iou_number: dst$iou_number,
        local_nad: ^rft$local_nad_entry,
        message: ^STRING(*),
        pp_number: 0..31,
        request_kind: rft$nad_request_kinds,
        severity_value: 0..4,
        str_len: integer,
        symptom: rft$failure_data_symptoms;

    symptom := rfc$memory_error_address;
    local_nad := ^rfv$status_table.local_nads^[nad_index];
    PUSH  counters : [1..15];
    cmp$return_desc_data_by_lun_lpn(local_nad^.logical_unit_number,
      local_nad^.pp[1].pp_number, iou_number, descriptor_data, pp_number);
    PUSH  message : [descriptor_data.size+4+20+31];
    message^(1,descriptor_data.size) := descriptor_data.value;
    message^(descriptor_data.size+1,4) := '*UF*';
    message^(descriptor_data.size+1+4,25) := rfv$failure_data_symptoms[symptom];
    stringrep(message^(descriptor_data.size+1+4+20,30), str_len, mem_addr:5:#(16),
      ' EXPECTED':9, mem_val1:5:#(16), ' ACTUAL':7, mem_val2:5:#(16));
    severity_value := 1;

    concurrent_channel_flag :=0;
    IF local_nad^.concurrent_channel THEN
      concurrent_channel_flag := 1*40(16);
    IFEND;
    counters^[1] := pp_number + concurrent_channel_flag + iou_number * 1000(16);
    counters^[2] := local_nad^.channel_number + concurrent_channel_flag + iou_number * 1000(16);
    counters^[3] := 0;
    counters^[4] := 0;
    counters^[5] := 1;     { $380-170 }
    counters^[6] := 0;
    counters^[7] := severity_value;
    counters^[8] := ORD(symptom);
    counters^[9] := 0;
    counters^[10] := 0;
    counters^[11] := 0;
    counters^[12] := 0;
    counters^[13] := 0ffff(16);
    counters^[14] := 0ffff(16);
    counters^[15] := 0;
    sfp$emit_statistic(cml$rhfam_failure_data, message^, counters, ignore);

  PROCEND log_nad_memory_error;
?? OLDTITLE ??
?? TITLE := '    PROCESS_LOCAL_DUMP_RESPONSE' ??
?? EJECT ??
  PROCEDURE  process_local_dump_response(command_buff: ^ARRAY [rft$command_entry] OF rft$command;
                                         pp_response: ^iot$pp_response;
                                         detailed_status: ^rft$detailed_status;
                                     VAR current_request: ^rft$outstanding_requests;
                                     VAR release_request: BOOLEAN;
                                     VAR status: ost$status);

{    The purpose of this procedure is to process a completed local NAD dump request.
{
{    command_buff: (input) This parameter specifies a pointer to the command buffer of the
{      corresponding request.
{
{    pp_response: (input) This parameter speicifies a pointer to the corresponding pp response.
{
{    detailed_status: (input) This parameter specifies a pointer to the detailed status (if any).
{
{    current_request: (input,output) This parameter specifies the pointer to the completed request.
{
{    release_request: (input,output) This parameter states whether the corresponding request has been
{      completed and should be removed from the outstanding request queue.  The calling routine must
{      initialize this to TRUE.
{
{    status: (output) This parameter returns the results of the request.  The calling routine must
{      initialize the status to normal.

    CONST
        nad_memory_bank_size = 4000(16)*2;   {  Number of 8-bit bytes  }

    VAR
        buffer_count,
        current_buffer: rft$buffer_count,
        buffer_size,
        byte_count: rft$bytes_transferred,
        current_command_index,
        last_command_index: rft$command_entry,
        current_bank: 0..4,
        current_location: INTEGER,
        request_info: ^SEQ(*),
        recoverable: boolean,
        dump_request_status: ^rft$load_dump_status,
        nad_index: rft$local_nads,
        segment_ptr: amt$segment_pointer,
        ignore_status: ost$status;

    dump_request_status := current_request^.request_status;
    nad_index := current_request^.request_id.ring_3_id.nad;

  /main_section/
    BEGIN
      IF  pp_response^.response_code.primary_response = ioc$normal_response  THEN

        rfp$delink_request(current_request^.request_id, status);
        IF  NOT status.normal  THEN
          EXIT  /main_section/;
        IFEND;
        byte_count := 0;
        FOR  current_buffer := 1  TO  dump_request_status^.buffers_in_use  DO
          byte_count := byte_count + dump_request_status^.buffer_list^[current_buffer].byte_count;
        FOREND;
        current_buffer := 1;
        rfp$move_data_from_wired_buffs(dump_request_status^.buffer_list^, dump_request_status^.mc_image,
          dump_request_status^.number_of_buffers, current_buffer, byte_count);
        IF  dump_request_status^.state <> rfc$ds_end_of_dump  THEN
          PUSH  request_info : [[REP  2*rfc$command_buffer_size OF rft$command]];
          RESET request_info;
          rfp$build_dump_request(dump_request_status, request_info, status);
          IF  status.normal  THEN
            rfp$post_request(request_info, current_request^.request_id, status);
            IF  status.normal  THEN
              release_request := FALSE;
            IFEND;
          IFEND;
        IFEND;

      ELSE  {  ioc$abnormal_response  }

        {  determine the amount of NAD memory dumped.

        current_command_index := rfc$cbi_general_buffer;
        last_command_index := ((pp_response^.last_command - pp_response^.request_rma -
        #SIZE(rft$peripheral_request)) DIV 8) + 1;

        {  determine number of buffers completed.

        current_buffer := 1;
        byte_count := 0;
        WHILE  current_command_index <= last_command_index  DO
          IF  command_buff^[current_command_index].pc_function_code = rfc$pc_input_8_in_8_mode  THEN
            IF  current_command_index = last_command_index  THEN
              byte_count := byte_count + pp_response^.transfer_count;
            ELSE
              byte_count := byte_count + dump_request_status^.buffer_list^[current_buffer].byte_count;
              current_buffer := current_buffer + 1;
            IFEND;
          IFEND;
          current_command_index := current_command_index + 1;
        WHILEND;

        { determine if error occurred on a memory increment boundary.

        current_location := #OFFSET(dump_request_status^.mc_image) + byte_count;
        current_bank := current_location DIV nad_memory_bank_size;
        current_location := current_location MOD nad_memory_bank_size;

        { The PP attempts to read up to the nearest multiple of six to prevent channel errors.

        IF  (current_location <> 0) OR
            (current_bank = 0)  THEN

          {   IF error is not near a NAD memory boundary then log it.

          log_nad_error(pp_response, detailed_status, current_request^.request_kind,
            current_request^.retry_count, nad_index, 0, TRUE, recoverable);
          IF  recoverable  THEN
            current_request^.retry_count := current_request^.retry_count + 1;
            rfp$re_issue_request(current_request^.request_id, status);
            IF  status.normal  THEN
              release_request := FALSE;
              EXIT /main_section/;
            IFEND;
          ELSE
            osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'fatal NAD error', status);
            osp$append_status_parameter(osc$status_parameter_delimiter, 'PROCESS_LOCAL_DUMP_RESPONSE',
              status);
          IFEND;
        IFEND;

        {  Move all data that has been successfully dumped to the buffer.

        current_buffer := 1;
        rfp$move_data_from_wired_buffs(dump_request_status^.buffer_list^, dump_request_status^.mc_image,
          dump_request_status^.number_of_buffers, current_buffer, byte_count);
        rfp$delink_request(current_request^.request_id, ignore_status);
      IFEND;

    END /main_section/;

    IF  (NOT status.normal)  OR  (release_request)  THEN
      segment_ptr.kind := amc$cell_pointer;
      segment_ptr.cell_pointer := dump_request_status^.mc_image;
      amp$set_segment_eoi(dump_request_status^.mc_file_id, segment_ptr, ignore_status);
      fsp$close_file(dump_request_status^.mc_file_id, ignore_status);
      amp$return(dump_request_status^.mc_lfn, ignore_status);
      rfp$release_wired_buffers(dump_request_status^.buffer_list^, dump_request_status^.number_of_buffers);
      FREE  dump_request_status^.buffer_list  IN  osv$task_private_heap^;
      FREE  dump_request_status  IN  osv$task_private_heap^;
    IFEND;

  PROCEND process_local_dump_response;
?? TITLE := '    PROCESS_NAD_STATUS_RESPONSE' ??
?? EJECT ??
  PROCEDURE  process_nad_status_response(command_buff: ^ARRAY [rft$command_entry] OF rft$command;
                                         pp_response: ^iot$pp_response;
                                         detailed_status: ^rft$detailed_status;
                                     VAR current_request: ^rft$outstanding_requests;
                                     VAR release_request: BOOLEAN;
                                     VAR status: ost$status);

{    The purpose of this procedure is to process a completed local NAD status request.
{
{    command_buff: (input) This parameter specifies a pointer to the command buffer of the
{      corresponding request.
{
{    pp_response: (input) This parameter speicifies a pointer to the corresponding pp response.
{
{    detailed_status: (input) This parameter specifies a pointer to the detailed status (if any).
{
{    current_request: (input,output) This parameter specifies the pointer to the completed request.
{
{    release_request: (input,output) This parameter states whether the corresponding request has been
{      completed and should be removed from the outstanding request queue.  The calling routine must
{      initialize this to TRUE.
{
{    status: (output) This parameter returns the results of the request.  The calling routine must
{      initialize the status to normal.

    VAR
        local_nad: ^rft$local_nad_entry,
        recoverable: BOOLEAN,
        connection_entry: ^rft$connection_table_entry,
        connection_status: ^PACKED ARRAY [rft$concurrent_connections] OF rft$nad_status_entry,
        largest_path_id,
        number_of_changes,
        path_id,
        con_index: rft$concurrent_connections,
        current_time: integer,
        nad_index: rft$local_nads,
        previous_connect_entry,
        connect_entry_to_free,
        current_connect_entry: ^rft$clear_connection_id,
        ignore_status: ost$status;

      nad_index := current_request^.request_id.ring_3_id.nad;

  /main_section/
      BEGIN

        local_nad := ^rfv$status_table.local_nads^[nad_index];
        IF  pp_response^.response_code.primary_response = ioc$normal_response  THEN

          number_of_changes := pp_response^.transfer_count DIV #SIZE(rft$nad_status_entry);
          connection_status := #LOC(command_buff^[rfc$cbi_general_buffer]);
          largest_path_id := 0;
          rfp$lock_table(local_nad^.connection_table_lock);
          local_nad^.last_status_seq_number :=
            current_request^.request_id.ring_1_id.address^.response_seq_number;

        /update_connection_table/
          FOR  con_index := 0  TO  (number_of_changes-1)  DO
            path_id := connection_status^[con_index].path_identifier;

            {      This is a consistency check.

            IF  path_id > UPPERBOUND(local_nad^.connection_table^)  THEN
              EXIT /update_connection_table/;
            IFEND;
            connection_entry := ^local_nad^.connection_table^[path_id];

            {  This test is necessary because the NAD will pad the data to handle the assembly/disassembly
            {  cases.  The PAD is assumed to be binary zeroes.

            IF  (connection_status^[con_index].path_state = rfc$ps_unused)  AND
                (connection_status^[con_index].path_clarifier = rfc$pcu_empty)  THEN
              EXIT /update_connection_table/;
            IFEND;

            largest_path_id := path_id;
            connection_entry^.connection_state := connection_status^[con_index].path_state;
            connection_entry^.connection_clarifier := connection_status^[con_index].path_clarifier;
            connection_entry^.input_available := connection_status^[con_index].input_available;
            connection_entry^.output_below_threshold :=
              connection_status^[con_index].output_below_threshold;
          FOREND /update_connection_table/;
          local_nad^.current_max_connect_id := largest_path_id;
          IF  rfv$clear_connection_id <> NIL  THEN
            current_connect_entry := rfv$clear_connection_id;
            previous_connect_entry := NIL;
            REPEAT
              IF  nad_index = current_connect_entry^.local_nad  THEN
                IF  current_connect_entry^.sequence_number > local_nad^.last_status_seq_number  THEN
                  local_nad^.connection_table^[current_connect_entry^.connection_id].connection_state :=
                    rfc$ps_unused;
                  local_nad^.connection_table^[current_connect_entry^.connection_id].connection_clarifier :=
                    rfc$pcu_empty;
                IFEND;
                connect_entry_to_free := current_connect_entry;
                current_connect_entry := current_connect_entry^.next_entry;
                FREE  connect_entry_to_free  IN  osv$task_private_heap^;
                IF  previous_connect_entry = NIL  THEN
                  rfv$clear_connection_id := current_connect_entry;
                ELSE
                  previous_connect_entry^.next_entry := current_connect_entry;
                IFEND;
              ELSE
                previous_connect_entry := current_connect_entry;
                current_connect_entry := current_connect_entry^.next_entry;
              IFEND;
            UNTIL  current_connect_entry = NIL;
          IFEND;
          rfp$unlock_table(local_nad^.connection_table_lock);

          pmp$get_microsecond_clock(current_time, ignore_status);
          local_nad^.status_posted := FALSE;
          local_nad^.status_change_available := TRUE;
          local_nad^.last_status_change := current_time;

          rfp$delink_request(current_request^.request_id, status);

        ELSE  {  ioc$abnormal_response  }

          IF  rfv$clear_connection_id <> NIL  THEN
            current_connect_entry := rfv$clear_connection_id;
            previous_connect_entry := NIL;
            REPEAT
              IF  nad_index = current_connect_entry^.local_nad  THEN
                connect_entry_to_free := current_connect_entry;
                current_connect_entry := current_connect_entry^.next_entry;
                FREE  connect_entry_to_free  IN  osv$task_private_heap^;
                IF  previous_connect_entry = NIL  THEN
                  rfv$clear_connection_id := current_connect_entry;
                ELSE
                  previous_connect_entry^.next_entry := current_connect_entry;
                IFEND;
              ELSE
                previous_connect_entry := current_connect_entry;
                current_connect_entry := current_connect_entry^.next_entry;
              IFEND;
            UNTIL  current_connect_entry = NIL;
          IFEND;

          log_nad_error(pp_response, detailed_status, current_request^.request_kind,
            current_request^.retry_count, nad_index, 0, FALSE, recoverable);

          IF  NOT recoverable  THEN
            rfp$delink_request(current_request^.request_id, status);
            local_nad^.status_posted := FALSE;
          ELSE
            current_request^.retry_count := current_request^.retry_count + 1;
            rfp$re_issue_request(current_request^.request_id, status);
            IF  NOT status.normal  THEN
              rfp$delink_request(current_request^.request_id, ignore_status);
              local_nad^.status_posted := FALSE;
            ELSE
              release_request := FALSE;
            IFEND;
          IFEND;
        IFEND;
     END /main_section/;

  PROCEND process_nad_status_response;
?? TITLE := '    PROCESS_REQ_CONNECT_RESPONSE' ??
?? EJECT ??
  PROCEDURE  process_req_connect_response(command_buff: ^ARRAY [rft$command_entry] OF rft$command;
                                          pp_response: ^iot$pp_response;
                                          detailed_status: ^rft$detailed_status;
                                      VAR current_request: ^rft$outstanding_requests;
                                      VAR release_request: BOOLEAN;
                                      VAR status: ost$status);

{    The purpose of this procedure is to process a completed create connection request.
{
{    command_buff: (input) This parameter specifies a pointer to the command buffer of the
{      corresponding request.
{
{    pp_response: (input) This parameter speicifies a pointer to the corresponding pp response.
{
{    detailed_status: (input) This parameter specifies a pointer to the detailed status (if any).
{
{    current_request: (input,output) This parameter specifies the pointer to the completed request.
{
{    release_request: (input,output) This parameter states whether the corresponding request has been
{      completed and should be removed from the outstanding request queue.  The calling routine must
{      initialize this to TRUE.
{
{    status: (output) This parameter returns the results of the request.  The calling routine must
{      initialize the status to normal.

    VAR
        response_seq_number: INTEGER,
        job_table_entry_p: ^rft$rhfam_job_table_entry,
        new_entry,
        recoverable: boolean,
        connection_mgmt_status: ^rft$connection_mgmt_status,
        ignore_status: ost$status;


  /main_section/
    BEGIN

      connection_mgmt_status := current_request^.request_status;
      response_seq_number := current_request^.request_id.ring_1_id.address^.response_seq_number;

      IF  pp_response^.response_code.primary_response = ioc$normal_response  THEN

        IF  NOT connection_mgmt_status^.internal_use  THEN
          IF  connection_mgmt_status^.connection <> NIL  THEN
            rfp$synchronize_with_status(current_request^.request_id.ring_3_id.nad);
            rfp$lock_table(connection_mgmt_status^.connection^.lock);
            connection_mgmt_status^.connection^.connection_descriptor.network_path :=
              command_buff^[rfc$cbi_unit_request_2].lc_path_id;
            connection_mgmt_status^.connection^.active_pp_requests :=
              connection_mgmt_status^.connection^.active_pp_requests - 1;
            connection_mgmt_status^.connection^.connection_attributes.connection_status.connection_state :=
              rfc$outgoing_connect_active;

            {  This routine expects the connection entry to be locked upon entry.

            rfp$set_connection_entry_p(connection_mgmt_status^.connection, response_seq_number, status);

            {  and assumes the caller will release the lock upon exit.

            rfp$unlock_table(connection_mgmt_status^.connection^.lock);
          IFEND;
          connection_mgmt_status^.activity_status^.status := status;
          connection_mgmt_status^.activity_status^.complete := TRUE;
        IFEND;
        FREE connection_mgmt_status IN osv$task_private_heap^;
        rfp$delink_request(current_request^.request_id, status);

      ELSE  {  ioc$abnormal_response  }

        IF  (detailed_status^.last_mc_status.response = rfc$nr_negative_acknowledge)
            AND (NOT detailed_status^.last_mc_status.hardware_fault)
            AND (NOT detailed_status^.last_mc_status.function_flag)  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$local_nad_busy,
            rfv$status_table.local_nads^[current_request^.request_id.ring_3_id.nad].name, status);
        ELSE
          log_nad_error(pp_response, detailed_status, current_request^.request_kind,
            current_request^.retry_count, current_request^.request_id.ring_3_id.nad, 0, FALSE, recoverable);
          IF  recoverable  THEN
            current_request^.retry_count := current_request^.retry_count + 1;
            rfp$re_issue_request(current_request^.request_id, status);
            IF  status.normal  THEN
              release_request := FALSE;
              EXIT /main_section/;
            IFEND;
          IFEND;
        IFEND;
        rfp$delink_request(current_request^.request_id, ignore_status);
        IF  status.normal  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'fatal NAD error', status);
          osp$append_status_parameter(osc$status_parameter_delimiter, 'PROCESS_REQ_CONNECT_RESPONSE',
            status);
        IFEND;
        IF  NOT connection_mgmt_status^.internal_use  THEN
          IF  connection_mgmt_status^.connection <> NIL  THEN
            rfp$synchronize_with_status(current_request^.request_id.ring_3_id.nad);
            rfp$remove_connection(response_seq_number, connection_mgmt_status^.connection);
          IFEND;
          connection_mgmt_status^.activity_status^.status := status;
          connection_mgmt_status^.activity_status^.complete := TRUE;
        IFEND;
        FREE connection_mgmt_status IN osv$task_private_heap^;
      IFEND;
    END /main_section/;

  PROCEND process_req_connect_response;
?? TITLE := '    PROCESS_OBT_CONNECT_RESPONSE' ??
?? EJECT ??
  PROCEDURE  process_obt_connect_response(command_buff: ^ARRAY [rft$command_entry] OF rft$command;
                                          pp_response: ^iot$pp_response;
                                          detailed_status: ^rft$detailed_status;
                                      VAR current_request: ^rft$outstanding_requests;
                                      VAR release_request: BOOLEAN;
                                      VAR status: ost$status);

{    The purpose of this procedure is to process a completed create connection request.
{
{    command_buff: (input) This parameter specifies a pointer to the command buffer of the
{      corresponding request.
{
{    pp_response: (input) This parameter speicifies a pointer to the corresponding pp response.
{
{    detailed_status: (input) This parameter specifies a pointer to the detailed status (if any).
{
{    current_request: (input,output) This parameter specifies the pointer to the completed request.
{
{    release_request: (input,output) This parameter states whether the corresponding request has been
{      completed and should be removed from the outstanding request queue.  The calling routine must
{      initialize this to TRUE.
{
{    status: (output) This parameter returns the results of the request.  The calling routine must
{      initialize the status to normal.


    VAR
        response_seq_number: INTEGER,
        clear_connect_entry: ^rft$clear_connection_id,
        connect_request: ^rft$nbp_incoming_connect,
        recoverable: boolean,
        connection_mgmt_status: ^rft$connection_mgmt_status,
        nad_index: rft$local_nads,
        connection_index: rft$concurrent_connections,
        ignore_status: ost$status;

  /main_section/
    BEGIN
      connection_mgmt_status := current_request^.request_status;
      nad_index := current_request^.request_id.ring_3_id.nad;
      connection_index := command_buff^[rfc$cbi_unit_request_2].lc_path_id;
      response_seq_number := current_request^.request_id.ring_1_id.address^.response_seq_number;

      IF  pp_response^.response_code.primary_response = ioc$normal_response  THEN
        connect_request := #LOC(command_buff^[rfc$cbi_general_buffer]);
        process_incoming_connect(connect_request, pp_response^.transfer_count, connection_index,
          nad_index, current_request, release_request, status);
        IF  NOT release_request  THEN
          EXIT /main_section/;
        IFEND;
      ELSE  {  ioc$abnormal_response  }

        IF  ((detailed_status^.last_mc_status.response = rfc$nr_abort) OR
             (detailed_status^.last_mc_status.response = rfc$nr_negative_acknowledge))
            AND (NOT detailed_status^.last_mc_status.hardware_fault)
            AND (NOT detailed_status^.last_mc_status.function_flag)  THEN
          rfp$delink_request(current_request^.request_id, ignore_status);
          purge_path(command_buff^[rfc$cbi_unit_request_2].lc_path_id, current_request, status);
          IF  status.normal  THEN
            release_request := FALSE;
            EXIT /main_section/;
          IFEND;
        ELSE
          log_nad_error(pp_response, detailed_status, current_request^.request_kind,
            current_request^.retry_count, nad_index,
            command_buff^[rfc$cbi_unit_request_2].lc_path_id, FALSE, recoverable);
          IF  recoverable  THEN
            current_request^.retry_count := current_request^.retry_count + 1;
            rfp$re_issue_request(current_request^.request_id, status);
            IF  status.normal  THEN
              release_request := FALSE;
              EXIT /main_section/;
            IFEND;
          IFEND;
          rfp$delink_request(current_request^.request_id, ignore_status);
        IFEND;
        rfp$lock_table(rfv$status_table.local_nads^[nad_index].connection_table_lock);
        rfv$status_table.local_nads^[nad_index].connection_table^[connection_index].
          processing_incoming_connect := FALSE;
        IF  response_seq_number > rfv$status_table.local_nads^[nad_index].last_status_seq_number  THEN
          rfv$status_table.local_nads^[nad_index].connection_table^[connection_index].
            connection_state := rfc$ps_unused;
          rfv$status_table.local_nads^[nad_index].connection_table^[connection_index].
            connection_clarifier := rfc$pcu_empty;
        IFEND;
        IF  rfv$status_response_pending^[nad_index].in_host  THEN
          ALLOCATE  clear_connect_entry  IN  osv$task_private_heap^;
          IF  clear_connect_entry <> NIL  THEN
            clear_connect_entry^.local_nad := nad_index;
            clear_connect_entry^.connection_id := connection_index;
            clear_connect_entry^.sequence_number := response_seq_number;
            clear_connect_entry^.next_entry := rfv$clear_connection_id;
            rfv$clear_connection_id := clear_connect_entry;
          IFEND;
        IFEND;
        rfp$unlock_table(rfv$status_table.local_nads^[nad_index].connection_table_lock);
      IFEND;
      FREE connection_mgmt_status IN osv$task_private_heap^;
    END /main_section/;

  PROCEND process_obt_connect_response;
?? NEWTITLE := '      PROCESS_INCOMING_CONNECT' ??
?? EJECT ??
  PROCEDURE process_incoming_connect(connect_request: ^rft$nbp_incoming_connect;
                                     request_length: rft$transfer_length;
                                     connection: rft$path_identifier;
                                     nad_index: rft$local_nads;
                                 VAR current_request: ^rft$outstanding_requests;
                                 VAR release_request: BOOLEAN;
                                 VAR status: ost$status);

{    The purpose of this routine is to validate an incoming connect request and to assign
{    the request to the respective server for processing.
{
{    connect_request: (input) This parameter contains a pointer to the incoming connect request.
{
{    request_length: (input) This parameter specifies the length of the connect request.
{
{    connection: (input) This parameter specifies the corresponding path identifier (relative to the
{      local NAD) of the incoming request.
{
{    nad_index: (input) This parameter specifies the local NAD that received the incoming connect
{      request.
{
{    current_request: (input, output) This parameter specifies the supporting request information.  This
{      is used if an ACCEPT or REJECT request is required.
{
{    release_request: (input,output) This parameter specifies whether the current_request can be deleted.
{      Code assumes an initial value of TRUE.
{
{    status: (output) This parameter returns the results of the request.

    VAR
        cm_routing: rft$nbp_control_message_header,
        path_entry: ^rft$lcn_path_definition,
        remote_host: ^rft$remote_host_definition,
        lid_index: rft$logical_ids_per_host,
        server_name: rft$application_name,
        server_id_index: rft$concurrent_connections,
        server_entry: ^rft$rhfam_server_table_entry,
        reject_code: rft$reject_code,
        ignore_status: ost$status,
        remote_host_found,
        accept_in_progress,
        matching_lid_found,
        matching_server_found: boolean;


    accept_in_progress := FALSE;
    status.normal := TRUE;
    reject_code := 0;

  /validate_incoming_connect/
    BEGIN

      IF  request_length < #SIZE(rft$nbp_incoming_connect)  THEN
        reject_code := rfc$nbp_password_undefined;  {  This should have a more meaningful code !!!! }
        EXIT /validate_incoming_connect/;
      IFEND;
      IF  connect_request^.password <> rfv$status_table.local_host^.connection_password  THEN
        reject_code := rfc$nbp_password_undefined;
        EXIT /validate_incoming_connect/;
      IFEND;
      IF  rfv$status_table.local_host^.disabled  THEN
        reject_code := rfc$nbp_server_lid_disabled;
        EXIT /validate_incoming_connect/;
      IFEND;
      IF  connect_request^.destination_id = rfv$status_table.local_host^.physical_identifier  THEN
        matching_lid_found := TRUE;
      ELSE
        matching_lid_found := FALSE;
      /find_matching_lid/
        FOR  lid_index := 1  TO  UPPERBOUND(rfv$status_table.local_host^.logical_identifiers)  DO
          IF  connect_request^.destination_id =
                rfv$status_table.local_host^.logical_identifiers[lid_index].logical_id(1,3)  THEN
            matching_lid_found := TRUE;
            EXIT /find_matching_lid/;
          IFEND;
        FOREND  /find_matching_lid/;
        IF  (matching_lid_found)  AND
            (rfv$status_table.local_host^.logical_identifiers[lid_index].disabled)  THEN
          reject_code := rfc$nbp_server_lid_disabled;
          EXIT /validate_incoming_connect/;
        IFEND;
      IFEND;

      cm_routing.nad_address := connect_request^.nad_address;
      cm_routing.logical_network := 0;
      cm_routing.logical_nad := 0;
      cm_routing.destination_device := connect_request^.destination_device;
      cm_routing.local_tcu_enables := connect_request^.local_tcu_enables;
      IF  rfv$status_table.local_host^.physical_identifier = connect_request^.source_physical_id  THEN
        find_matching_path(rfv$status_table.local_host^.associated_paths, nad_index,
          cm_routing, path_entry);
      ELSE
        remote_host := rfv$status_table.remote_hosts;
        remote_host_found := FALSE;
      /find_matching_remote_host/
        WHILE  remote_host <> NIL  DO
          IF  remote_host^.physical_identifier = connect_request^.source_physical_id  THEN
            find_matching_path(remote_host^.associated_paths, nad_index,
              cm_routing, path_entry);
            remote_host_found := TRUE;
            EXIT /find_matching_remote_host/;
          IFEND;
          remote_host := remote_host^.next_entry;
        WHILEND /find_matching_remote_host/;
        IF  NOT remote_host_found  THEN
          reject_code := rfc$nbp_client_pid_undefined;
          EXIT /validate_incoming_connect/;
        IFEND;
        IF  remote_host^.disabled  THEN
          reject_code := rfc$nbp_client_pid_disabled;
          EXIT /validate_incoming_connect/;
        IFEND;
      IFEND;
      IF  path_entry <> NIL  THEN
        rfp$lock_table(rfv$status_table.lock);
        path_entry^.disabled := FALSE;
        path_entry^.failure_count := 0;
        rfp$unlock_table(rfv$status_table.lock);
      IFEND;

      rfp$lock_table(rfv$rhfam_server_table.lock);

    /server_table_update/
      BEGIN
        server_name := connect_request^.requested_application;
        server_entry := rfv$rhfam_server_table.first_entry;
        matching_server_found := FALSE;

      /find_matching_server/
        WHILE  server_entry <> NIL  DO
          IF  (server_name = server_entry^.server_name)  THEN
            matching_server_found := TRUE;
            EXIT /find_matching_server/;
          IFEND;
          server_entry := server_entry^.next_entry;
        WHILEND  /find_matching_server/;
        IF  NOT matching_server_found  THEN
          reject_code := rfc$nbp_server_undefined;
          EXIT /server_table_update/;
        IFEND;
        IF  (NOT server_entry^.server_active)  THEN
          reject_code := rfc$nbp_server_disabled;
          EXIT /server_table_update/;
        IFEND;
        IF  (NOT server_entry^.rhfam_initiated_server) AND
            (server_entry^.connections_reserved = 0 ) THEN
          reject_code := rfc$nbp_server_undefined;
          EXIT /server_table_update/;
        IFEND;
        IF  (server_entry^.validate_connection_lid)  AND
            (NOT matching_lid_found)  THEN
          reject_code := rfc$nbp_server_lid_undefined;
          EXIT /server_table_update/;
        IFEND;
        IF  (server_entry^.current_connections >= server_entry^.maximum_connections)  OR
            ((NOT server_entry^.rhfam_initiated_server) AND
             (server_entry^.current_connections >= server_entry^.connections_reserved))  THEN
          reject_code := rfc$nbp_requested_server_busy;
          EXIT /server_table_update/;
        IFEND;
        IF  reject_code <> 0  THEN
          EXIT /server_table_update/;
        IFEND;

        {  The server table is locked upon entry into assign_connect.  The assign connect
        {  routine have the lock set upon return.

        assign_connect_to_server(connection, connect_request, server_entry, current_request,
          accept_in_progress, status);
        IF  NOT status.normal  THEN
           reject_code := rfc$nbp_requested_host_busy;
        IFEND;
      END /server_table_update/;
      rfp$unlock_table(rfv$rhfam_server_table.lock);

    END  /validate_incoming_connect/;

    IF  accept_in_progress  THEN
      release_request := FALSE;
    ELSE
      rfp$delink_request(current_request^.request_id, ignore_status);
      IF  reject_code <> 0  THEN
        IF  NOT status.normal  THEN
          rfp$log_the_status(status);
        IFEND;
        reject_connect_request(connection, reject_code, current_request, status);
        IF  status.normal  THEN
          release_request := FALSE;
        IFEND;
      ELSE  {  getting here means that the request is assigned to a server.
        wake_up_server_job(server_name);
      IFEND;
    IFEND;

  PROCEND process_incoming_connect;
?? NEWTITLE := '        ASSIGN_CONNECT_TO_SERVER' ??
?? EJECT ??
  PROCEDURE assign_connect_to_server(connection: rft$path_identifier;
                                     connect_request: ^rft$nbp_incoming_connect;
                                 VAR server_entry: ^rft$rhfam_server_table_entry;
                                 VAR current_request: ^rft$outstanding_requests;
                                 VAR accept_in_progress: BOOLEAN;
                                 VAR status: ost$status);

{    The purpose of this routine is to assign a valid connect request to a server application for
{    further processing.
{
{    NOTE - This routine assumes the calling procedure has locked the server table.
{           Upon return the lock will still be set.
{
{    connection: (input) This parameter specifies the path of the incoming connect request.
{
{    connect_request: (input) This parameter specifies a pointer to the incoming connect request.
{
{    server_entry: (input,output) This parameter specifies the server entry, of the corresponding server,
{      to assign the incoming connect request.
{
{    current_request: (input, output) This parameter specifies the supporting request information.  This
{      is used if an ACCEPT or REJECT request is required.
{
{    accept_in_progress: (input, output) This parameter specifies whether the current_request can be
{      deleted.  Code assumes the initial value is FALSE.
{
{    status: (output) This parameter returns the results of the request.

    VAR
        current_time: INTEGER,
        ignore_status: ost$status,
        connection_mgmt_status: ^rft$connection_mgmt_status,
        current_connect,
        incoming_connect: ^rft$incoming_connect;

    status.normal := TRUE;

    pmp$get_microsecond_clock(current_time, ignore_status);
    ALLOCATE incoming_connect IN nav$network_paged_heap^;
    IF  incoming_connect = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'network paged', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'ASSIGN CONNECT TO SERVER', status);
      RETURN;
    IFEND;
    incoming_connect^.connect_message := connect_request^;
    incoming_connect^.connection_descriptor.nad_index := current_request^.request_id.ring_3_id.nad;
    incoming_connect^.connection_descriptor.logical_unit :=
      current_request^.request_id.ring_3_id.location.logical_unit;
    incoming_connect^.connection_descriptor.network_path := connection;
    incoming_connect^.time_received := current_time;
    incoming_connect^.connection_status.connection_state := rfc$incoming_connect_active;
    incoming_connect^.next_entry := NIL;

    IF  server_entry^.access_method_accept  THEN
      server_entry^.current_connections := server_entry^.current_connections + 1;
      server_entry^.active_incoming_connects := server_entry^.active_incoming_connects + 1;
      rfp$unlock_table(rfv$rhfam_server_table.lock);
      connection_mgmt_status := current_request^.request_status;
      connection_mgmt_status^.server_entry_p := server_entry;
      connection_mgmt_status^.incoming_connect := incoming_connect;
      rfp$delink_request(current_request^.request_id, ignore_status);
      accept_connect_request(connection, current_request, status);
      rfp$lock_table(rfv$rhfam_server_table.lock);
      IF  status.normal  THEN
        accept_in_progress := TRUE;
      ELSE
        FREE incoming_connect IN nav$network_paged_heap^;
        server_entry^.current_connections := server_entry^.current_connections - 1;
        server_entry^.active_incoming_connects := server_entry^.active_incoming_connects - 1;
      IFEND;
    ELSE
      server_entry^.current_connections := server_entry^.current_connections + 1;
      IF  (server_entry^.rhfam_initiated_server)  AND
          ((server_entry^.current_connections - server_entry^.partner_job_connections)
                                              > server_entry^.connections_reserved)  THEN
        server_entry^.active_incoming_connects := server_entry^.active_incoming_connects + 1;
        rfp$unlock_table(rfv$rhfam_server_table.lock);
        rfp$start_server_job(server_entry, status);
        rfp$lock_table(rfv$rhfam_server_table.lock);
        server_entry^.active_incoming_connects := server_entry^.active_incoming_connects - 1;
        IF  NOT status.normal  THEN
          FREE incoming_connect IN nav$network_paged_heap^;
          server_entry^.current_connections := server_entry^.current_connections - 1;
          RETURN;
        IFEND;
      IFEND;
      current_connect := server_entry^.incoming_connect;
      IF  current_connect = NIL  THEN
        server_entry^.incoming_connect := incoming_connect;
      ELSE
        WHILE  current_connect^.next_entry <> NIL  DO
          current_connect := current_connect^.next_entry;
        WHILEND;
        current_connect^.next_entry := incoming_connect;
      IFEND;
    IFEND;

  PROCEND assign_connect_to_server;
?? OLDTITLE ??
?? OLDTITLE ??
?? OLDTITLE ??
?? TITLE := '  RFP$START_SERVER_JOB' ??
?? EJECT ??
  PROCEDURE [XDCL] rfp$start_server_job(VAR server: ^rft$rhfam_server_table_entry;
                                        VAR status: ost$status);

*copyc rfh$start_server_job

    VAR
        current_time: INTEGER,
        new_server_id: ^rft$server_identifier,
        job_start_up_attrs: ^jmt$job_submission_options,
        job_name: jmt$system_supplied_name,
        path: ^pft$path,
        password: pft$name,
        cycle_selector: pft$cycle_selector,
        usage_selections: pft$usage_selections,
        share_selections: pft$share_selections,
        unique_name: ost$unique_name,
        server_file_name: amt$local_file_name,
        ignore_status: ost$status;

    ALLOCATE  new_server_id  IN  nav$network_paged_heap^;
    IF  new_server_id = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'network paged', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$START_SERVER_JOB', status);
      RETURN;
    IFEND;

    pmp$generate_unique_name(unique_name, ignore_status);
    server_file_name := unique_name.value;

    PUSH path : [1..5];
    path^[1] := osc$null_name;
    path^[2] := rfc$rhfam_master_catalog;
    path^[3] := rfc$rhfam_sub_catalog;
    path^[4] := rfc$server_sub_catalog;
    path^[5] := server^.server_name;
    usage_selections := $pft$usage_selections[pfc$read];
    share_selections := $pft$share_selections[pfc$read,pfc$execute];
    cycle_selector.cycle_option := pfc$highest_cycle;
    password := rfc$password;

    pfp$attach(server_file_name, path^, cycle_selector, password, usage_selections, share_selections,
      pfc$no_wait, status);
    IF  NOT status.normal  THEN
      FREE  new_server_id  IN  nav$network_paged_heap^;
      RETURN;
    IFEND;

    PUSH job_start_up_attrs : [1..1];
    job_start_up_attrs^[1].key := jmc$immediate_init_candidate;
    job_start_up_attrs^[1].immediate_init_candidate := TRUE;
    jmp$submit_job(server_file_name, job_start_up_attrs, job_name, status);

    amp$return(server_file_name, ignore_status);

    IF  NOT status.normal  THEN
      FREE  new_server_id  IN  nav$network_paged_heap^;
    ELSE
      pmp$get_microsecond_clock(current_time, ignore_status);
      rfp$lock_table(rfv$rhfam_server_table.lock);
      new_server_id^.job_name := job_name;
      new_server_id^.server_signed_on := FALSE;
      new_server_id^.server_started_time := current_time;
      new_server_id^.next_entry := server^.server_identifier;
      server^.server_identifier := new_server_id;
      server^.connections_reserved := server^.connections_reserved + server^.server_job_max_connections;
      rfp$unlock_table(rfv$rhfam_server_table.lock);
    IFEND;

  PROCEND rfp$start_server_job;
?? NEWTITLE := '    ACCEPT_CONNECT_REQUEST' ??
?? EJECT ??
  PROCEDURE  accept_connect_request(connection: rft$path_identifier;
                                VAR current_request: ^rft$outstanding_requests;
                                VAR status: ost$status);

{    The purpose of this routine is to accept an incoming connect request.
{
{    connection: (input) This parameter specifies the local NAD connection identifier.
{
{    current_request: (input, output) This paramter contains all the information of the current
{      request.
{
{    status: (output) This parameter returns the results of the request.


    VAR
        request_info: ^SEQ(*),
        command_identifier: ^rft$logical_commands,
        path_identifier: ^rft$path_identifier;

    status.normal := TRUE;

    PUSH  request_info : [[rft$logical_commands,rft$path_identifier]];
    RESET request_info;
    NEXT command_identifier IN request_info;
    IF  command_identifier = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'ACCEPT_CONNECT_REQUEST', status);
      RETURN;
    IFEND;
    command_identifier^ := rfc$lc_accept_connect_request;
    NEXT path_identifier IN request_info;
    IF  path_identifier = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'path id too big',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'ACCEPT_CONNECT_REQUEST', status);
      RETURN;
    IFEND;
    path_identifier^ := connection;
    RESET request_info;
    rfp$post_request(request_info, current_request^.request_id, status);

    IF  status.normal  THEN
      current_request^.retry_count := 0;
      current_request^.request_kind := rfc$rk_accept_connect_request;
    IFEND;

  PROCEND accept_connect_request;
?? TITLE := '    PURGE_PATH' ??
?? EJECT ??
  PROCEDURE  purge_path(connection: rft$path_identifier;
                    VAR current_request: ^rft$outstanding_requests;
                    VAR status: ost$status);

{    The purpose of this routine is to purge the NAD path for a specified connection.
{
{    connection: (input) This parameter specifies the local NAD connection identifier.
{
{    current_request: (input, output) This paramter contains all the information of the current
{      request.
{
{    status: (output) This parameter returns the results of the request.


    VAR
        abnormal_termination: ^BOOLEAN,
        request_info: ^SEQ(*),
        command_identifier: ^rft$logical_commands,
        path_identifier: ^rft$path_identifier;

    status.normal := TRUE;

    PUSH  request_info : [[rft$logical_commands,BOOLEAN,rft$path_identifier]];
    RESET request_info;
    NEXT command_identifier IN request_info;
    IF  command_identifier = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'PURGE_PATH', status);
      RETURN;
    IFEND;
    command_identifier^ := rfc$lc_disconnect_paths;
    NEXT abnormal_termination IN request_info;
    IF  abnormal_termination = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'termination type too big',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'PURGE_PATH', status);
      RETURN;
    IFEND;
    abnormal_termination^ := TRUE;
    NEXT path_identifier IN request_info;
    IF  path_identifier = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'path id too big',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'PURGE_PATH', status);
      RETURN;
    IFEND;
    path_identifier^ := connection;
    RESET request_info;
    rfp$post_request(request_info, current_request^.request_id, status);

    IF  status.normal  THEN
      current_request^.retry_count := 0;
      current_request^.request_kind := rfc$rk_disconnect_path;
    IFEND;

  PROCEND purge_path;
?? TITLE := '    REJECT_CONNECT_REQUEST' ??
?? EJECT ??
  PROCEDURE  reject_connect_request(connection: rft$path_identifier;
                                    reject_code: rft$reject_code;
                                VAR current_request: ^rft$outstanding_requests;
                                VAR status: ost$status);

{    The purpose of this routine is to reject an incoming connect request.
{
{    connection: (input) This parameter specifies the local NAD connection identifier.
{
{    reject_code: (input) This parameter specifies the reject code to send to the source host.
{
{    current_request: (input, output) This paramter contains all the information of the current
{      request.
{
{    status: (output) This parameter returns the results of the request.


    VAR
        request_info: ^SEQ(*),
        command_identifier: ^rft$logical_commands,
        reject_id: ^rft$reject_code,
        path_identifier: ^rft$path_identifier;

    status.normal := TRUE;

    PUSH  request_info : [[rft$logical_commands,rft$path_identifier,rft$reject_code]];
    RESET request_info;
    NEXT command_identifier IN request_info;
    IF  command_identifier = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'REJECT_CONNECT_REQUEST', status);
      RETURN;
    IFEND;
    command_identifier^ := rfc$lc_reject_connect_request;
    NEXT path_identifier IN request_info;
    IF  path_identifier = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'path id too big',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'REJECT_CONNECT_REQUEST', status);
      RETURN;
    IFEND;
    path_identifier^ := connection;
    NEXT reject_id IN request_info;
    IF  reject_id = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'reject code too big',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'REJECT_CONNECT_REQUEST', status);
      RETURN;
    IFEND;
    reject_id^ := reject_code;
    RESET request_info;
    rfp$post_request(request_info, current_request^.request_id, status);

    IF  status.normal  THEN
      current_request^.retry_count := 0;
      current_request^.request_kind := rfc$rk_reject_connect_request;
    IFEND;

  PROCEND reject_connect_request;
?? OLDTITLE ??
?? TITLE := '    WAKE_UP_SERVER_JOB' ??
?? EJECT ??
  PROCEDURE  wake_up_server_job(server_name: rft$application_name);

{    The purpose of this routine is to scan the list of tasks, which are waiting
{    for an RHFAM event, and readying a task (if any) that is waiting for an
{    incoming connect request for the specified server.
{
{    server_name: (input) This parameter specifies the name of the server application that
{      was requested on the incoming connect request.

    VAR
        task_id: ost$global_task_id,
        event_entry: ^rft$rhfam_event_table_entry,
        ignore_status: ost$status;

    task_id := tmv$null_global_task_id;
    rfp$lock_table(rfv$rhfam_event_table.lock);
    event_entry := rfv$rhfam_event_table.first_entry;

  /find_waiting_task/
    WHILE  event_entry <> NIL  DO
      IF  (event_entry^.event_occurred_type = rfc$eot_no_event) AND
          (event_entry^.event_kind = rfc$ana_await_incoming_connect) AND
          (event_entry^.aic_server_name = server_name) THEN
        event_entry^.event_occurred_type := rfc$eot_incoming_connect;
        task_id := event_entry^.task_id;
        EXIT /find_waiting_task/;
      IFEND;
      event_entry := event_entry^.next_entry;
    WHILEND /find_waiting_task/;

    rfp$unlock_table(rfv$rhfam_event_table.lock);

    IF  task_id <> tmv$null_global_task_id  THEN
      pmp$ready_task(task_id, ignore_status);
    IFEND;

  PROCEND wake_up_server_job;
?? OLDTITLE ??
?? OLDTITLE ??
?? TITLE := '    PROCESS_ACC_CONNECT_RESPONSE' ??
?? EJECT ??
  PROCEDURE  process_acc_connect_response(command_buff: ^ARRAY [rft$command_entry] OF rft$command;
                                          pp_response: ^iot$pp_response;
                                          detailed_status: ^rft$detailed_status;
                                      VAR current_request: ^rft$outstanding_requests;
                                      VAR release_request: BOOLEAN;
                                      VAR status: ost$status);

{    The purpose of this procedure is to process a completed accept incoming connect request.
{
{    command_buff: (input) This parameter specifies a pointer to the command buffer of the
{      corresponding request.
{
{    pp_response: (input) This parameter speicifies a pointer to the corresponding pp response.
{
{    detailed_status: (input) This parameter specifies a pointer to the detailed status (if any).
{
{    current_request: (input,output) This parameter specifies the pointer to the completed request.
{
{    release_request: (input,output) This parameter states whether the corresponding request has been
{      completed and should be removed from the outstanding request queue.  The calling routine must
{      initialize this to TRUE.
{
{    status: (output) This parameter returns the results of the request.  The calling routine must
{      initialize the status to normal.


    VAR
        current_connect: ^rft$incoming_connect,
        server: ^rft$rhfam_server_table_entry,
        server_name: rft$application_name,
        job_table_entry_p: ^rft$rhfam_job_table_entry,
        new_entry,
        recoverable: boolean,
        connection_mgmt_status: ^rft$connection_mgmt_status,
        nad_index: rft$local_nads,
        connection_index: rft$concurrent_connections,
        response_seq_number: INTEGER,
        clear_connect_entry: ^rft$clear_connection_id,
        ignore_status: ost$status;

  /main_section/
    BEGIN
      connection_mgmt_status := current_request^.request_status;
      nad_index := current_request^.request_id.ring_3_id.nad;
      connection_index := command_buff^[rfc$cbi_unit_request_2].lc_path_id;
      response_seq_number := current_request^.request_id.ring_1_id.address^.response_seq_number;

      IF  pp_response^.response_code.primary_response = ioc$normal_response  THEN

        IF  connection_mgmt_status^.internal_use  THEN
          server_name := '';
          server := connection_mgmt_status^.server_entry_p;
          rfp$lock_table(rfv$rhfam_server_table.lock);
          IF  (server^.rhfam_initiated_server)  AND
            ((server^.current_connections - server^.partner_job_connections)
                                              > server^.connections_reserved)  THEN
            rfp$unlock_table(rfv$rhfam_server_table.lock);
            rfp$start_server_job(server, status);
            rfp$lock_table(rfv$rhfam_server_table.lock);
            server^.active_incoming_connects := server^.active_incoming_connects - 1;
            IF  NOT status.normal  THEN
              FREE connection_mgmt_status^.incoming_connect IN nav$network_paged_heap^;
              server^.current_connections := server^.current_connections - 1;
              rfp$unlock_table(rfv$rhfam_server_table.lock);
              rfp$delink_request(current_request^.request_id, ignore_status);
              purge_path(connection_index, current_request, ignore_status);
              IF  ignore_status.normal  THEN
                release_request := FALSE;
              ELSE
                FREE connection_mgmt_status IN osv$task_private_heap^;
              IFEND;
              EXIT /main_section/;
            IFEND;
          ELSE   {  Do not have to start Server Job  }
            server^.active_incoming_connects := server^.active_incoming_connects - 1;
            server_name := server^.server_name;
          IFEND;

          {  Queue request for server job.

          current_connect := server^.incoming_connect;
          IF  current_connect = NIL  THEN
            server^.incoming_connect := connection_mgmt_status^.incoming_connect;
          ELSE
            WHILE  current_connect^.next_entry <> NIL  DO
              current_connect := current_connect^.next_entry;
            WHILEND;
            current_connect^.next_entry := connection_mgmt_status^.incoming_connect;
          IFEND;
          rfp$unlock_table(rfv$rhfam_server_table.lock);
          IF  server_name <> ''  THEN
            wake_up_server_job(server_name);
          IFEND;

        ELSE  {  user mode request  }
          IF  connection_mgmt_status^.connection <> NIL  THEN
            rfp$lock_table(connection_mgmt_status^.connection^.lock);
            connection_mgmt_status^.connection^.active_pp_requests :=
              connection_mgmt_status^.connection^.active_pp_requests - 1;
            IF  connection_mgmt_status^.connection^.connection_attributes.connection_status.connection_state
                  < rfc$not_viable  THEN
              connection_mgmt_status^.connection^.connection_attributes.connection_status.connection_state :=
                  rfc$connected;
              connection_mgmt_status^.connection^.connection_attributes.connection_status.input_available :=
                  FALSE;
              connection_mgmt_status^.connection^.connection_attributes.connection_status.
                  output_below_threshold := TRUE;
            IFEND;
            rfp$unlock_table(connection_mgmt_status^.connection^.lock);
          IFEND;
          connection_mgmt_status^.activity_status^.complete := TRUE;
        IFEND;
        FREE connection_mgmt_status IN osv$task_private_heap^;
        rfp$delink_request(current_request^.request_id, status);

      ELSE  {  ioc$abnormal_response  }

        IF  ((detailed_status^.last_mc_status.response = rfc$nr_abort) OR
             (detailed_status^.last_mc_status.response = rfc$nr_negative_acknowledge))
            AND (NOT detailed_status^.last_mc_status.hardware_fault)
            AND (NOT detailed_status^.last_mc_status.function_flag)  THEN
          rfp$delink_request(current_request^.request_id, ignore_status);
          get_path_status(connection_index, current_request, status);
          IF  status.normal  THEN
            IF  connection_mgmt_status^.internal_use  THEN
              server := connection_mgmt_status^.server_entry_p;
              FREE connection_mgmt_status^.incoming_connect IN nav$network_paged_heap^;
              rfp$lock_table(rfv$rhfam_server_table.lock);
              server^.current_connections := server^.current_connections - 1;
              server^.active_incoming_connects := server^.active_incoming_connects - 1;
              rfp$unlock_table(rfv$rhfam_server_table.lock);
            IFEND;
            release_request := FALSE;
            EXIT /main_section/;
          IFEND;
        ELSE
          log_nad_error(pp_response,detailed_status,current_request^.request_kind,
            current_request^.retry_count, nad_index, connection_index, FALSE, recoverable);
          IF  recoverable  THEN
            current_request^.retry_count := current_request^.retry_count + 1;
            rfp$re_issue_request(current_request^.request_id, status);
            IF  status.normal  THEN
              release_request := FALSE;
              EXIT /main_section/;
            IFEND;
          IFEND;
          rfp$delink_request(current_request^.request_id, ignore_status);
        IFEND;
        IF  status.normal  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'fatal NAD error', status);
          osp$append_status_parameter(osc$status_parameter_delimiter, 'PROCESS_ACC_CONNECT_RESPONSE',
            status);
        IFEND;
        IF  connection_mgmt_status^.internal_use  THEN
          server := connection_mgmt_status^.server_entry_p;
          FREE connection_mgmt_status^.incoming_connect IN nav$network_paged_heap^;
          rfp$lock_table(rfv$rhfam_server_table.lock);
          server^.current_connections := server^.current_connections - 1;
          server^.active_incoming_connects := server^.active_incoming_connects - 1;
          rfp$unlock_table(rfv$rhfam_server_table.lock);
        ELSE   {  user mode request  }
          IF  connection_mgmt_status^.connection <> NIL  THEN
            rfp$lock_table(connection_mgmt_status^.connection^.lock);
            connection_mgmt_status^.connection^.active_pp_requests :=
              connection_mgmt_status^.connection^.active_pp_requests - 1;
            IF  connection_mgmt_status^.connection^.connection_attributes.connection_status.connection_state
                  < rfc$not_viable  THEN
              connection_mgmt_status^.connection^.connection_attributes.connection_status.connection_state :=
                rfc$terminated;
              connection_mgmt_status^.connection^.connection_attributes.connection_status.
                reason_for_termination := rfc$media_failure;
            IFEND;
            rfp$unlock_table(connection_mgmt_status^.connection^.lock);
          IFEND;
          connection_mgmt_status^.activity_status^.status := status;
          connection_mgmt_status^.activity_status^.complete := TRUE;
          rfp$lock_table(rfv$status_table.local_nads^[nad_index].connection_table_lock);
          rfv$status_table.local_nads^[nad_index].connection_table^[connection_index].
            processing_incoming_connect := FALSE;
          IF  response_seq_number > rfv$status_table.local_nads^[nad_index].last_status_seq_number  THEN
            rfv$status_table.local_nads^[nad_index].connection_table^[connection_index].
              connection_state := rfc$ps_unused;
            rfv$status_table.local_nads^[nad_index].connection_table^[connection_index].
              connection_clarifier := rfc$pcu_empty;
          IFEND;
          IF  rfv$status_response_pending^[nad_index].in_host  THEN
            ALLOCATE  clear_connect_entry  IN  osv$task_private_heap^;
            IF  clear_connect_entry <> NIL  THEN
              clear_connect_entry^.local_nad := nad_index;
              clear_connect_entry^.connection_id := connection_index;
              clear_connect_entry^.sequence_number := response_seq_number;
              clear_connect_entry^.next_entry := rfv$clear_connection_id;
              rfv$clear_connection_id := clear_connect_entry;
            IFEND;
          IFEND;
          rfp$unlock_table(rfv$status_table.local_nads^[nad_index].connection_table_lock);
        IFEND;
        FREE connection_mgmt_status IN osv$task_private_heap^;
      IFEND;
    END /main_section/;

  PROCEND process_acc_connect_response;
?? NEWTITLE := '      GET_PATH_STATUS' ??
?? EJECT ??
  PROCEDURE  get_path_status(connection: rft$path_identifier;
                         VAR current_request: ^rft$outstanding_requests;
                         VAR status: ost$status);

{    The purpose of this routine is to obtain the path status for a specified connection.
{
{    connection: (input) This parameter specifies the local NAD connection identifier.
{
{    current_request: (input, output) This paramter contains all the information of the current
{      request.
{
{    status: (output) This parameter returns the results of the request.


    VAR
        request_info: ^SEQ(*),
        command_identifier: ^rft$logical_commands,
        path_identifier: ^rft$path_identifier;

    status.normal := TRUE;

    PUSH  request_info : [[rft$logical_commands,rft$path_identifier]];
    RESET request_info;
    NEXT command_identifier IN request_info;
    IF  command_identifier = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'GET_PATH_STATUS', status);
      RETURN;
    IFEND;
    command_identifier^ := rfc$lc_read_path_status_table;
    NEXT path_identifier IN request_info;
    IF  path_identifier = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'path id too big',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'GET_PATH_STATUS', status);
      RETURN;
    IFEND;
    path_identifier^ := connection;
    RESET request_info;
    rfp$post_request(request_info, current_request^.request_id, status);

    IF  status.normal  THEN
      current_request^.retry_count := 0;
      current_request^.request_kind := rfc$rk_path_status;
    IFEND;

  PROCEND get_path_status;
?? OLDTITLE ??
?? TITLE := '    PROCESS_REJ_CONNECT_RESPONSE' ??
?? EJECT ??
  PROCEDURE  process_rej_connect_response(command_buff: ^ARRAY [rft$command_entry] OF rft$command;
                                          pp_response: ^iot$pp_response;
                                          detailed_status: ^rft$detailed_status;
                                      VAR current_request: ^rft$outstanding_requests;
                                      VAR release_request: BOOLEAN;
                                      VAR status: ost$status);

{    The purpose of this procedure is to process a completed reject incoming connect request.
{
{    command_buff: (input) This parameter specifies a pointer to the command buffer of the
{      corresponding request.
{
{    pp_response: (input) This parameter speicifies a pointer to the corresponding pp response.
{
{    detailed_status: (input) This parameter specifies a pointer to the detailed status (if any).
{
{    current_request: (input,output) This parameter specifies the pointer to the completed request.
{
{    release_request: (input,output) This parameter states whether the corresponding request has been
{      completed and should be removed from the outstanding request queue.  The calling routine must
{      initialize this to TRUE.
{
{    status: (output) This parameter returns the results of the request.  The calling routine must
{      initialize the status to normal.


    VAR
        clear_connect_entry: ^rft$clear_connection_id,
        response_seq_number: INTEGER,
        local_nad: ^rft$local_nad_entry,
        nad_index: rft$local_nads,
        connection_index: rft$concurrent_connections,
        job_table_entry_p: ^rft$rhfam_job_table_entry,
        new_entry,
        recoverable: boolean,
        connection_mgmt_status: ^rft$connection_mgmt_status,
        ignore_status: ost$status;

  /main_section/
    BEGIN
      connection_mgmt_status := current_request^.request_status;
      nad_index := current_request^.request_id.ring_3_id.nad;
      local_nad := ^rfv$status_table.local_nads^[nad_index];
      connection_index := command_buff^[rfc$cbi_unit_request_2].lc_path_id;
      response_seq_number := current_request^.request_id.ring_1_id.address^.response_seq_number;
      IF  pp_response^.response_code.primary_response = ioc$normal_response  THEN
        IF  NOT connection_mgmt_status^.internal_use  THEN
          IF  connection_mgmt_status^.connection <> NIL  THEN
            rfp$synchronize_with_status(nad_index);
            rfp$remove_connection(response_seq_number, connection_mgmt_status^.connection);
          IFEND;
          connection_mgmt_status^.activity_status^.complete := TRUE;
        IFEND;
        rfp$delink_request(current_request^.request_id, status);

      ELSE  {  ioc$abnormal_response  }

        IF  ((detailed_status^.last_mc_status.response = rfc$nr_abort) OR
             (detailed_status^.last_mc_status.response = rfc$nr_negative_acknowledge))
            AND (NOT detailed_status^.last_mc_status.hardware_fault)
            AND (NOT detailed_status^.last_mc_status.function_flag)  THEN
          rfp$delink_request(current_request^.request_id, ignore_status);
          purge_path(command_buff^[rfc$cbi_unit_request_2].lc_path_id, current_request, status);
          IF  status.normal  THEN
            release_request := FALSE;
            EXIT /main_section/;
          IFEND;
        ELSE
          log_nad_error(pp_response, detailed_status, current_request^.request_kind,
            current_request^.retry_count, nad_index,
            command_buff^[rfc$cbi_unit_request_2].lc_path_id, FALSE, recoverable);
          IF  recoverable  THEN
            current_request^.retry_count := current_request^.retry_count + 1;
            rfp$re_issue_request(current_request^.request_id, status);
            IF  status.normal  THEN
              release_request := FALSE;
              EXIT /main_section/;
            IFEND;
          IFEND;
          rfp$delink_request(current_request^.request_id, ignore_status);
        IFEND;
        IF  status.normal  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'fatal NAD error', status);
          osp$append_status_parameter(osc$status_parameter_delimiter, 'PROCESS_REJ_CONNECT_RESPONSE',
            status);
        IFEND;
        IF  NOT connection_mgmt_status^.internal_use  THEN
          IF  connection_mgmt_status^.connection <> NIL  THEN
            rfp$synchronize_with_status(nad_index);
            rfp$remove_connection(response_seq_number, connection_mgmt_status^.connection);
          IFEND;
          connection_mgmt_status^.activity_status^.status := status;
          connection_mgmt_status^.activity_status^.complete := TRUE;
        IFEND;
      IFEND;

      IF  connection_mgmt_status^.internal_use  THEN
        rfp$lock_table(local_nad^.connection_table_lock);
        local_nad^.connection_table^[connection_index].processing_incoming_connect := FALSE;
        IF  response_seq_number > local_nad^.last_status_seq_number  THEN
          local_nad^.connection_table^[connection_index].connection_state := rfc$ps_unused;
          local_nad^.connection_table^[connection_index].connection_clarifier := rfc$pcu_empty;
        IFEND;
        IF  rfv$status_response_pending^[nad_index].in_host  THEN
          ALLOCATE  clear_connect_entry  IN  osv$task_private_heap^;
          IF  clear_connect_entry <> NIL  THEN
            clear_connect_entry^.local_nad := nad_index;
            clear_connect_entry^.connection_id := connection_index;
            clear_connect_entry^.sequence_number := response_seq_number;
            clear_connect_entry^.next_entry := rfv$clear_connection_id;
            rfv$clear_connection_id := clear_connect_entry;
          IFEND;
        IFEND;
        rfp$unlock_table(local_nad^.connection_table_lock);
      IFEND;
      FREE connection_mgmt_status IN osv$task_private_heap^;

    END /main_section/;

  PROCEND process_rej_connect_response;
?? TITLE := '    PROCESS_DISCONNECT_RESPONSE' ??
?? EJECT ??
  PROCEDURE [XDCL,#GATE] rfp$process_disconnect_response (command_buff:
                                ^ARRAY [rft$command_entry] OF rft$command;
                                         pp_response: ^iot$pp_response;
                                         detailed_status: ^rft$detailed_status;
                                     VAR current_request: ^rft$outstanding_requests;
                                     VAR release_request: BOOLEAN;
                                     VAR status: ost$status);

{    The purpose of this procedure is to process a completed terminate connection request.
{
{    command_buff: (input) This parameter specifies a pointer to the command buffer of the
{      corresponding request.
{
{    pp_response: (input) This parameter speicifies a pointer to the corresponding pp response.
{
{    detailed_status: (input) This parameter specifies a pointer to the detailed status (if any).
{
{    current_request: (input,output) This parameter specifies the pointer to the completed request.
{
{    release_request: (input,output) This parameter states whether the corresponding request has been
{      completed and should be removed from the outstanding request queue.  The calling routine must
{      initialize this to TRUE.
{
{    status: (output) This parameter returns the results of the request.  The calling routine must
{      initialize the status to normal.


    VAR
        clear_connect_entry: ^rft$clear_connection_id,
        response_seq_number: INTEGER,
        job_table_entry_p: ^rft$rhfam_job_table_entry,
        new_entry,
        recoverable: boolean,
        connection_mgmt_status: ^rft$connection_mgmt_status,
        nad_index: rft$local_nads,
        connection_index: rft$concurrent_connections,
        ignore_status: ost$status;

  /main_section/
    BEGIN
      connection_mgmt_status := current_request^.request_status;
      nad_index := current_request^.request_id.ring_3_id.nad;
      connection_index := command_buff^[rfc$cbi_unit_request_2].lc_path_id;
      response_seq_number := current_request^.request_id.ring_1_id.address^.response_seq_number;

      IF  pp_response^.response_code.primary_response = ioc$normal_response  THEN
        IF  NOT connection_mgmt_status^.internal_use  THEN
          IF  connection_mgmt_status^.connection <> NIL  THEN
            rfp$synchronize_with_status(nad_index);
            rfp$remove_connection(response_seq_number, connection_mgmt_status^.connection);
          IFEND;
          connection_mgmt_status^.activity_status^. complete := TRUE;
        IFEND;
        rfp$delink_request(current_request^.request_id, status);

      ELSE  {  ioc$abnormal_response  }

        IF  (detailed_status^.last_mc_status.response = rfc$nr_negative_acknowledge)
            AND (detailed_status^.last_mc_function = (rfc$nf_normal_disconnect + rfc$nf_flag_function))
            AND (NOT detailed_status^.last_mc_status.hardware_fault)
            AND (NOT detailed_status^.last_mc_status.function_flag)  THEN
          rfp$delink_request(current_request^.request_id, ignore_status);
          purge_path(command_buff^[rfc$cbi_unit_request_2].lc_path_id, current_request, status);
          IF  status.normal  THEN
            release_request := FALSE;
            EXIT /main_section/;
          IFEND;
        ELSE
          log_nad_error(pp_response, detailed_status, current_request^.request_kind,
            current_request^.retry_count, current_request^.request_id.ring_3_id.nad,
            command_buff^[rfc$cbi_unit_request_2].lc_path_id, FALSE, recoverable);
          IF  recoverable  THEN
            current_request^.retry_count := current_request^.retry_count + 1;
            rfp$re_issue_request(current_request^.request_id, status);
            IF  status.normal  THEN
              release_request := FALSE;
              EXIT /main_section/;
            IFEND;
          IFEND;
          rfp$delink_request(current_request^.request_id, ignore_status);
        IFEND;
        IF  status.normal  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'fatal NAD error', status);
          osp$append_status_parameter(osc$status_parameter_delimiter, 'PROCESS_DISCONNECT_RESPONSE',
            status);
        IFEND;
        IF  NOT connection_mgmt_status^.internal_use  THEN
          IF  connection_mgmt_status^.connection <> NIL  THEN
            rfp$synchronize_with_status(nad_index);
            rfp$remove_connection(response_seq_number, connection_mgmt_status^.connection);
          IFEND;
          connection_mgmt_status^.activity_status^.status := status;
          connection_mgmt_status^.activity_status^.complete := TRUE;
        IFEND;
      IFEND;

      IF  (connection_index <> 0)  AND
          (connection_mgmt_status^.internal_use)  THEN
        rfp$lock_table(rfv$status_table.local_nads^[nad_index].connection_table_lock);
        rfv$status_table.local_nads^[nad_index].connection_table^[connection_index].
          processing_incoming_connect := FALSE;
        IF  response_seq_number > rfv$status_table.local_nads^[nad_index].last_status_seq_number  THEN
          rfv$status_table.local_nads^[nad_index].connection_table^[connection_index].
            connection_state := rfc$ps_unused;
          rfv$status_table.local_nads^[nad_index].connection_table^[connection_index].
            connection_clarifier := rfc$pcu_empty;
        IFEND;
        IF  rfv$status_response_pending^[nad_index].in_host  THEN
          ALLOCATE  clear_connect_entry  IN  osv$task_private_heap^;
          IF  clear_connect_entry <> NIL  THEN
            clear_connect_entry^.local_nad := nad_index;
            clear_connect_entry^.connection_id := connection_index;
            clear_connect_entry^.sequence_number := response_seq_number;
            clear_connect_entry^.next_entry := rfv$clear_connection_id;
            rfv$clear_connection_id := clear_connect_entry;
          IFEND;
        IFEND;
        rfp$unlock_table(rfv$status_table.local_nads^[nad_index].connection_table_lock);
      IFEND;
      FREE connection_mgmt_status IN osv$task_private_heap^;
    END /main_section/;

  PROCEND rfp$process_disconnect_response;
?? NEWTITLE := '      SYNCHRONIZE_WITH_STATUS' ??
?? EJECT ??
  PROCEDURE [XDCL,#GATE] rfp$synchronize_with_status (nad: rft$local_nads);

{    The purpose of this routine is to make sure that the local nad status has been
{    processed before the remove connection pointer routine clears out the state
{    and clarifier in the local nad table.
{
{    nad: (input) This parameter specifies the corresponding local NAD to synchronize with.

   VAR
     starting_wait_time: ost$free_running_clock,
     ignore_status: ost$status,
     current_time: ost$free_running_clock;

    starting_wait_time := #free_running_clock (0);

    /wait_for_response/
    WHILE  rfv$status_response_pending^[nad].in_host  AND
           rfv$status_table.system_task_is_up  DO
      #SPOIL (rfv$status_response_pending^);
      #SPOIL (rfv$status_table);
      syp$cycle;
      current_time := #free_running_clock(0);
      IF current_time > starting_wait_time + 45000000 THEN
        dpp$put_critical_message('LCN timeout occurred', ignore_status);
        EXIT /wait_for_response/;
      IFEND;
    WHILEND /wait_for_response/;

  PROCEND rfp$synchronize_with_status;
?? OLDTITLE ??
?? TITLE := '    PROCESS_PATH_STATUS_RESPONSE' ??
?? EJECT ??
  PROCEDURE  process_path_status_response(command_buff: ^ARRAY [rft$command_entry] OF rft$command;
                                          pp_response: ^iot$pp_response;
                                          detailed_status: ^rft$detailed_status;
                                      VAR current_request: ^rft$outstanding_requests;
                                      VAR release_request: BOOLEAN;
                                      VAR status: ost$status);

{    The purpose of this procedure is to process a completed path status request.
{
{    command_buff: (input) This parameter specifies a pointer to the command buffer of the
{      corresponding request.
{
{    pp_response: (input) This parameter speicifies a pointer to the corresponding pp response.
{
{    detailed_status: (input) This parameter specifies a pointer to the detailed status (if any).
{
{    current_request: (input,output) This parameter specifies the pointer to the completed request.
{
{    release_request: (input,output) This parameter states whether the corresponding request has been
{      completed and should be removed from the outstanding request queue.  The calling routine must
{      initialize this to TRUE.
{
{    status: (output) This parameter returns the results of the request.  The calling routine must
{      initialize the status to normal.


    VAR
        job_table_entry_p: ^rft$rhfam_job_table_entry,
        new_entry,
        recoverable: boolean,
        connection_mgmt_status: ^rft$connection_mgmt_status,
        ignore_status: ost$status;

  /main_section/
    BEGIN

      connection_mgmt_status := current_request^.request_status;

      IF  pp_response^.response_code.primary_response = ioc$normal_response  THEN

        IF  NOT connection_mgmt_status^.internal_use  THEN
          IF  connection_mgmt_status^.connection <> NIL  THEN
            rfp$lock_table(connection_mgmt_status^.connection^.lock);
            connection_mgmt_status^.connection^.active_pp_requests :=
              connection_mgmt_status^.connection^.active_pp_requests - 1;
            IF  connection_mgmt_status^.connection^.connection_attributes.connection_status.connection_state
                  < rfc$not_viable  THEN
              set_connection_status(^command_buff^[rfc$cbi_general_buffer],
                current_request^.request_id.ring_3_id.nad,
                connection_mgmt_status^.connection, status);
            IFEND;
            rfp$unlock_table(connection_mgmt_status^.connection^.lock);
          IFEND;
          connection_mgmt_status^.activity_status^.status := status;
          connection_mgmt_status^.activity_status^.complete := TRUE;
        IFEND;
        FREE connection_mgmt_status IN osv$task_private_heap^;
        rfp$delink_request(current_request^.request_id, status);

      ELSE  {  ioc$abnormal_response  }

        log_nad_error(pp_response, detailed_status, current_request^.request_kind,
          current_request^.retry_count, current_request^.request_id.ring_3_id.nad,
          command_buff^[rfc$cbi_unit_request_2].lc_path_id, FALSE, recoverable);
        IF  recoverable  THEN
          current_request^.retry_count := current_request^.retry_count + 1;
          rfp$re_issue_request(current_request^.request_id, status);
          IF  status.normal  THEN
            release_request := FALSE;
            EXIT /main_section/;
          IFEND;
        IFEND;
        rfp$delink_request(current_request^.request_id, ignore_status);
        IF  status.normal  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'fatal NAD error', status);
          osp$append_status_parameter(osc$status_parameter_delimiter, 'PROCESS_PATH_STATUS_RESPONSE',
            status);
        IFEND;
        IF  NOT connection_mgmt_status^.internal_use  THEN
          IF  connection_mgmt_status^.connection <> NIL  THEN
            rfp$lock_table(connection_mgmt_status^.connection^.lock);
            connection_mgmt_status^.connection^.active_pp_requests :=
              connection_mgmt_status^.connection^.active_pp_requests - 1;
            IF  connection_mgmt_status^.connection^.connection_attributes.connection_status.connection_state
                  < rfc$not_viable  THEN
              connection_mgmt_status^.connection^.connection_attributes.connection_status.connection_state :=
                rfc$terminated;
              connection_mgmt_status^.connection^.connection_attributes.connection_status.
                reason_for_termination := rfc$media_failure;
            IFEND;
            rfp$unlock_table(connection_mgmt_status^.connection^.lock);
          IFEND;
          connection_mgmt_status^.activity_status^.status := status;
          connection_mgmt_status^.activity_status^.complete := TRUE;
        IFEND;
        FREE connection_mgmt_status IN osv$task_private_heap^;
      IFEND;

    END /main_section/;

  PROCEND process_path_status_response;
?? NEWTITLE := '      SET_CONNECTION_STATUS' ??
?? EJECT ??
  PROCEDURE set_connection_status(path_status: ^CELL;
                                  nad_index: rft$local_nads;
                              VAR connection: ^rft$connection_entry;
                              VAR status: ost$status);

{    The purpose of this routine is to retrieve the current connection status from
{    a complete read path status request.  The connection entry is updated and an appropriate
{    status message is formatted.
{
{    NOTE - the caller of this routine must set any required locks, and also validate that the
{           corresponding connection is indeed viable.
{
{    path_status: (input) This parameter specifies a pointer to the path status buffer.
{
{    nad_index: (input) This parameter specifies the index of the local nad, which contains
{      this path.
{
{    connection: (input, output) This parameter specifies the pointer of the connection entry
{      which corresponds to the path status information.
{
{    status: (output) The status is abnormal only if a connection state change has occurred.

    VAR
        path_status_table: ^rft$path_status_table;


    status.normal := TRUE;
    path_status_table := path_status;

    CASE  path_status_table^.path_state  OF
    = rfc$ps_connecting =
      CASE  path_status_table^.path_clarifier  OF
      = rfc$pcc_remote_reject =
        connection^.connection_attributes.connection_status.connection_state := rfc$connect_rejected;
        connection^.connection_attributes.connection_status.server_response :=
          path_status_table^.receive_code.reject_code;
        osp$set_status_abnormal(rfc$product_id, rfe$connection_terminated, connection^.connection_name,
          status);
      = rfc$pcc_network_reject =
        connection^.connection_attributes.connection_status.connection_state := rfc$terminated;
        connection^.connection_attributes.connection_status.reason_for_termination :=
          rfc$media_failure;
        osp$set_status_abnormal(rfc$product_id, rfe$connection_terminated, connection^.connection_name,
          status);
        log_network_failure(nad_index, connection^.control_message_header, path_status_table);
      ELSE
        {  should be a connect in progress  }
      CASEND;

    = rfc$ps_established =
      CASE  path_status_table^.path_clarifier  OF
      = rfc$pce_normal, rfc$pce_local_host_uninformed =
        {  path in normal state }
      = rfc$pce_local_disconnect_1, rfc$pce_local_disconnect_2 =
        connection^.connection_attributes.connection_status.connection_state := rfc$terminated;
        connection^.connection_attributes.connection_status.reason_for_termination :=
          rfc$local_termination;
        osp$set_status_abnormal(rfc$product_id, rfe$connection_terminated, connection^.connection_name,
          status);
      = rfc$pce_incoming_disconnect =
        connection^.connection_attributes.connection_status.connection_state := rfc$terminated;
        connection^.connection_attributes.connection_status.reason_for_termination :=
          rfc$peer_termination;
        osp$set_status_abnormal(rfc$product_id, rfe$connection_terminated, connection^.connection_name,
          status);
      ELSE  { invalid state clarifier }
        connection^.connection_attributes.connection_status.connection_state := rfc$terminated;
        connection^.connection_attributes.connection_status.reason_for_termination :=
          rfc$media_failure;
        osp$set_status_abnormal(rfc$product_id, rfe$connection_terminated, connection^.connection_name,
          status);
      CASEND;

    = rfc$ps_flushing =      { treat as a remote disconnect }
      connection^.connection_attributes.connection_status.connection_state := rfc$terminated;
      connection^.connection_attributes.connection_status.reason_for_termination :=
        rfc$peer_termination;
      osp$set_status_abnormal(rfc$product_id, rfe$connection_terminated, connection^.connection_name,
        status);

    = rfc$ps_aborted =       { treat as a media failure }
      connection^.connection_attributes.connection_status.connection_state := rfc$terminated;
      connection^.connection_attributes.connection_status.reason_for_termination :=
        rfc$media_failure;
      osp$set_status_abnormal(rfc$product_id, rfe$connection_terminated, connection^.connection_name,
        status);
      log_network_failure(nad_index, connection^.control_message_header, path_status_table);

    ELSE                     { unknown state, treat as media failure }

      connection^.connection_attributes.connection_status.connection_state := rfc$terminated;
      connection^.connection_attributes.connection_status.reason_for_termination :=
        rfc$media_failure;
      osp$set_status_abnormal(rfc$product_id, rfe$connection_terminated, connection^.connection_name,
        status);
    CASEND;

  PROCEND set_connection_status;
?? NEWTITLE := '        LOG_NETWORK_FAILURE' ??
?? EJECT ??
  PROCEDURE log_network_failure(nad_index: rft$local_nads;
                                cm_routing: rft$nbp_control_message_header;
                                path_status_table: ^rft$path_status_table);

{    The purpose of this routine is to extract the information from the path status table
{    and log it in the engineering log.
{
{    nad_index: (input) This parameter contains the index of the corresponding NAD.
{
{    cm_routing: (input) This parameter contains the control message routing information
{      which is used to find a matching path.
{
{    path_status_table: (input) This parameter contains the pointer to the path status table.


   VAR
        rfv$log_network_break_rc: [STATIC,READ,oss$job_paged_literal] ARRAY [0..28] OF BOOLEAN :=
          [TRUE,TRUE,TRUE,FALSE,TRUE,TRUE,FALSE,FALSE,TRUE,TRUE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,
           FALSE,FALSE,TRUE,FALSE,FALSE,TRUE,FALSE,FALSE,FALSE,TRUE,TRUE,TRUE,FALSE];

    VAR
        concurrent_channel_flag: integer,
        pp_number: 0..31,
        descriptor_data: ost$string,
        counters: ^ARRAY [1..*] OF sft$counter,
        message: ^STRING(*),
        tcu_index: rfc$min_tcu..rfc$max_tcu,
        local_nad: ^rft$local_nad_entry,
        reason_code: INTEGER,
        paths: ^rft$lcn_paths,
        path_entry: ^rft$lcn_path_definition,
        current_time: INTEGER,
        iou_number: dst$iou_number,
        ignore_status: ost$status,
        generate_log: BOOLEAN,
        remote_host_entry: ^rft$remote_host_definition;


    {   Find matching path in the RHFAM configuration file.

    paths := rfv$status_table.local_host^.associated_paths;
    find_matching_path(paths, nad_index, cm_routing, path_entry);
    IF  path_entry = NIL  THEN
      remote_host_entry := rfv$status_table.remote_hosts;

    /check_remote_paths/
      WHILE  remote_host_entry <> NIL  DO
        paths := remote_host_entry^.associated_paths;
        find_matching_path(paths, nad_index, cm_routing, path_entry);
        IF  path_entry <> NIL  THEN
          EXIT /check_remote_paths/;
        IFEND;
        remote_host_entry := remote_host_entry^.next_entry;
      WHILEND /check_remote_paths/;
    IFEND;

    IF  path_entry <> NIL  THEN
      reason_code := path_status_table^.receive_code.reason_code;
      IF  (reason_code <> rfc$ctnrc_path_disappeared)  THEN
        pmp$get_microsecond_clock(current_time, ignore_status);
        rfp$lock_table(rfv$status_table.lock);
        path_entry^.failure_count := path_entry^.failure_count + 1;
        IF  NOT path_entry^.disabled  THEN
          path_entry^.time_disabled := current_time;
          path_entry^.disabled := TRUE;
        IFEND;
        IF  (path_entry^.last_network_break_rc <> reason_code)  OR
            (path_entry^.failure_count = 1)  THEN
          path_entry^.last_network_break_rc := reason_code;
          generate_log := TRUE;
        ELSE
          generate_log := FALSE;
        IFEND;
        rfp$unlock_table(rfv$status_table.lock);
        IF  (generate_log)  AND
            ((reason_code >= 0)  AND  (reason_code <= 28))  AND
            (rfv$log_network_break_rc[reason_code])  THEN

          {  send log message to engineering log  }

          local_nad := ^rfv$status_table.local_nads^[path_entry^.local_nad];
          PUSH  counters : [1..20];
          cmp$return_desc_data_by_lun_lpn(local_nad^.logical_unit_number,
            local_nad^.pp[1].pp_number, iou_number, descriptor_data, pp_number);
          PUSH  message : [descriptor_data.size+4+25];
          message^(1,descriptor_data.size) := descriptor_data.value;
          message^(descriptor_data.size+1,4) := '*IM*';
          message^(descriptor_data.size+1+4,25) := rfv$network_failure_symptoms[rfc$connection_failure];

          concurrent_channel_flag :=0;
          IF local_nad^.concurrent_channel THEN
            concurrent_channel_flag := 1*40(16);
          IFEND;
          counters^[1] := pp_number + concurrent_channel_flag + iou_number * 1000(16);
          counters^[2] := local_nad^.channel_number + concurrent_channel_flag + iou_number * 1000(16);
          counters^[3] := 0;
          counters^[4] := 0;
          counters^[5] := 1;   { $380-170 }
          counters^[6] := 0;
          counters^[7] := 3;   { informative message }
          counters^[8] := ORD(rfc$connection_failure);
          counters^[9] := 0;
          counters^[10] := path_status_table^.my_id;
          counters^[11] := reason_code;
          counters^[12] := 0;
          counters^[13] := 0;
          IF  path_entry^.local_tcu_mask[0]  THEN
            counters^[12] := counters^[12] + 1;
          IFEND;
          IF  path_entry^.local_tcu_mask[1]  THEN
            counters^[12] := counters^[12] + 2;
          IFEND;
          IF  path_entry^.local_tcu_mask[2]  THEN
            counters^[12] := counters^[12] + 4;
          IFEND;
          IF  path_entry^.local_tcu_mask[3]  THEN
            counters^[12] := counters^[12] + 8;
          IFEND;
          IF  path_entry^.remote_tcu_mask[0]  THEN
            counters^[13] := counters^[13] + 1;
          IFEND;
          IF  path_entry^.remote_tcu_mask[1]  THEN
            counters^[13] := counters^[13] + 2;
          IFEND;
          IF  path_entry^.remote_tcu_mask[2]  THEN
            counters^[13] := counters^[13] + 4;
          IFEND;
          IF  path_entry^.remote_tcu_mask[3]  THEN
            counters^[13] := counters^[13] + 8;
          IFEND;
          counters^[14] := cm_routing.nad_address;
          counters^[15] := path_entry^.logical_network;
          counters^[16] := path_entry^.logical_nad;
          counters^[17] := path_status_table^.receive_code.logical_network;
          counters^[18] := path_status_table^.receive_code.nad_address;
          counters^[19] := path_status_table^.receive_code.hop_count;
          counters^[20] := path_status_table^.his_id;
          sfp$emit_statistic(cml$rhfam_network_failure, message^, counters, ignore_status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND log_network_failure;
?? NEWTITLE := '          FIND_MATCHING_PATH' ??
?? EJECT ??
  PROCEDURE find_matching_path(paths: ^rft$lcn_paths;
                               nad_index: rft$local_nads;
                               cm_routing: rft$nbp_control_message_header;
                           VAR path: ^rft$lcn_path_definition);

{    The purpose of this routine is to match LCN routing parameters with the
{    paths defined in the currently active configuration file.
{
{    paths: (input) This parameter specifies a list of paths to compare against the
{      routing information.
{
{    nad_index: (input) This parameter specifies the index of the local NAD that
{      received the routing block.
{
{    cm_routing: (input) This parameter specifies the routing information of a
{      corresponding network path.
{
{    path: (output) This parameter returns a pointer to the matching path entry.  A value
{      of NIL means that no matching path was found.


    VAR
        path_index: INTEGER,
        tcu_index: rfc$min_tcu .. rfc$max_tcu,
        path_entry: ^rft$lcn_path_definition;

    path := NIL;
    IF paths <> NIL  THEN
    /find_path/
      FOR  path_index := 1  TO  UPPERBOUND(paths^)  DO
        path_entry := ^paths^[path_index];
        IF  (nad_index = path_entry^.local_nad) AND
            (((path_entry^.loopback) AND
              (cm_routing.nad_address =
                     rfv$status_table.local_nads^[path_entry^.destination_nad].address)) OR
             ((NOT path_entry^.loopback) AND
              (cm_routing.nad_address =
                     rfv$status_table.remote_nads^[path_entry^.remote_nad].address)))  AND
            (cm_routing.logical_network = path_entry^.logical_network)  AND
            (cm_routing.logical_nad = path_entry^.logical_nad)  AND
            (cm_routing.destination_device = path_entry^.destination_device)  THEN
          FOR  tcu_index := rfc$min_tcu  TO  rfc$max_tcu  DO
            IF  cm_routing.local_tcu_enables[tcu_index]  AND
                path_entry^.local_tcu_mask[tcu_index]  THEN
              path := path_entry;
              EXIT /find_path/;
            IFEND;
          FOREND;
        IFEND;
      FOREND /find_path/;
    IFEND;

  PROCEND find_matching_path;
?? OLDTITLE ??
?? OLDTITLE ??
?? OLDTITLE ??
?? TITLE := '    PROCESS_SEND_CTRL_RESPONSE' ??
?? EJECT ??
  PROCEDURE  process_send_ctrl_response(command_buff: ^ARRAY [rft$command_entry] OF rft$command;
                                        pp_response: ^iot$pp_response;
                                        detailed_status: ^rft$detailed_status;
                                    VAR current_request: ^rft$outstanding_requests;
                                    VAR release_request: BOOLEAN;
                                    VAR status: ost$status);

{    The purpose of this procedure is to process a completed send control message request.
{
{    command_buff: (input) This parameter specifies a pointer to the command buffer of the
{      corresponding request.
{
{    pp_response: (input) This parameter speicifies a pointer to the corresponding pp response.
{
{    detailed_status: (input) This parameter specifies a pointer to the detailed status (if any).
{
{    current_request: (input,output) This parameter specifies the pointer to the completed request.
{
{    release_request: (input,output) This parameter states whether the corresponding request has been
{      completed and should be removed from the outstanding request queue.  The calling routine must
{      initialize this to TRUE.
{
{    status: (output) This parameter returns the results of the request.  The calling routine must
{      initialize the status to normal.


    VAR
        request_size: INTEGER,
        abnormal_stat: iot$abnormal_status,
        abnormal_status: ^rft$abnormal_status,
        local_nad: ^rft$local_nad_entry,
        request_info: ^SEQ(*),
        command_identifier: ^rft$logical_commands,
        entry_to_free,
        current_entry: ^rft$outgoing_control_message,
        control_message: ^rft$nbp_control_message,
        control_message_text_size: ^rft$control_message_text,
        table_locked,
        recoverable: BOOLEAN,
        ignore_status: ost$status;

  /main_section/
    BEGIN

      local_nad := ^rfv$status_table.local_nads^[current_request^.request_id.ring_3_id.nad];
      IF  pp_response^.response_code.primary_response = ioc$normal_response  THEN
        rfp$delink_request(current_request^.request_id, status);
        rfp$lock_table(local_nad^.outgoing_cm_queue.lock);
        table_locked := TRUE;

      /queue_next_request/
        BEGIN

          {   Make sure the queue has not been flushed by a termination request  }

          IF  (local_nad^.outgoing_cm_queue.first_entry <> NIL)  THEN

            {  Clear out the message that was just sent  }

            entry_to_free := local_nad^.outgoing_cm_queue.first_entry;
            local_nad^.outgoing_cm_queue.first_entry := entry_to_free^.next_entry;
            current_entry := local_nad^.outgoing_cm_queue.first_entry;
            FREE  entry_to_free  IN  nav$network_paged_heap^;
            IF  current_entry <> NIL  THEN
              request_size := #SIZE(rft$logical_commands) + #SIZE(rft$control_message_text) +
                rfc$max_control_message_size;
              PUSH  request_info : [[REP request_size OF CELL]];
              RESET request_info;
              NEXT  command_identifier  IN  request_info;
              IF  command_identifier = NIL  THEN
                osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big',
                  status);
                osp$append_status_parameter(osc$status_parameter_delimiter, 'PROCESS_SEND_CTRL_RESPONSE',
                  status);
                EXIT /queue_next_request/;
              IFEND;
              command_identifier^ := rfc$lc_send_control_message;
              NEXT  control_message_text_size IN  request_info;
              IF  control_message_text_size = NIL  THEN
                osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'text size too big',
                  status);
                osp$append_status_parameter(osc$status_parameter_delimiter, 'PROCESS_SEND_CTRL_RESPONSE',
                  status);
                EXIT /queue_next_request/;
              IFEND;
              control_message_text_size^ := #SIZE(current_entry^.control_message.data);
              NEXT  control_message : [control_message_text_size^] IN  request_info;
              IF  control_message = NIL  THEN
                osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'message too big',
                  status);
                osp$append_status_parameter(osc$status_parameter_delimiter, 'PROCESS_SEND_CTRL_RESPONSE',
                  status);
                EXIT /queue_next_request/;
              IFEND;
              control_message^ := current_entry^.control_message;
              rfp$unlock_table(local_nad^.outgoing_cm_queue.lock);
              table_locked := FALSE;
              rfp$post_request(request_info, current_request^.request_id, status);
              IF  status.normal  THEN
                release_request := FALSE;
                EXIT /main_section/;
              IFEND;
            IFEND;
          IFEND;
        END /queue_next_request/;
        local_nad^.processing_out_control_mess := FALSE;
        IF  table_locked  THEN
          rfp$unlock_table(local_nad^.outgoing_cm_queue.lock);
        IFEND;

      ELSE  {  ioc$abnormal_response  }

        abnormal_stat := pp_response^.abnormal_status;
        abnormal_status := #LOC(abnormal_stat);
        IF  NOT ((abnormal_status^.invalid_status_value)
                 AND ((detailed_status^.last_mc_status.response = rfc$nr_transfer_not_ready) OR
                      (detailed_status^.last_mc_status.response = rfc$nr_negative_acknowledge))
                 AND (NOT detailed_status^.last_mc_status.hardware_fault))  THEN
          log_nad_error(pp_response, detailed_status, current_request^.request_kind,
            current_request^.retry_count, current_request^.request_id.ring_3_id.nad, 0, FALSE, recoverable);
          IF  recoverable  THEN
            current_request^.retry_count := current_request^.retry_count + 1;
            rfp$re_issue_request(current_request^.request_id, status);
            IF  status.normal  THEN
              release_request := FALSE;
              EXIT /main_section/;
            IFEND;
          IFEND;
        IFEND;
        rfp$delink_request(current_request^.request_id, ignore_status);
        relink_control_message_queue(local_nad);
      IFEND;
    END /main_section/;

  PROCEND process_send_ctrl_response;
?? NEWTITLE := '      RELINK_CONTROL_MESSAGE_QUEUE' ??
?? EJECT ??
  PROCEDURE relink_control_message_queue(local_nad: ^rft$local_nad_entry);

{    This routine is called after a failure to send a control message.  This routine will
{    flush all control messages associated with a disconnected path.  If there are no
{    messages removed from this queue then a check is made to see if there are any
{    messages destined for a remote NAD that is not the same as the destination NAD
{    for the entry at the head of the list.  If such a message is found it is placed at the
{    head of the list.  This is to help regulate data flow when NAD saturation cases are encountered.
{
{    local_nad: (input) This parameter specifies a pointer to the local NAD entry.

    VAR
        entry_flushed: BOOLEAN,
        connection: rft$concurrent_connections,
        destination_nad: rft$nad_address,
        previous_entry,
        entry_to_flush,
        current_entry: ^rft$outgoing_control_message;

    entry_flushed := FALSE;
    rfp$lock_table(local_nad^.outgoing_cm_queue.lock);

    {   We should free all entries associated with a terminated path.

    current_entry := local_nad^.outgoing_cm_queue.first_entry;
    IF  current_entry <> NIL  THEN
      destination_nad := current_entry^.control_message.header.nad_address;
      previous_entry := NIL;
      REPEAT
        connection := current_entry^.control_message.header.my_path_id;
        IF  (local_nad^.connection_table^[connection].connection_state <> rfc$ps_established) OR
            (local_nad^.connection_table^[connection].connection_clarifier <> rfc$pce_normal) OR
            (current_entry^.purge_on_retry)  THEN
          entry_flushed := TRUE;
          entry_to_flush := current_entry;
          current_entry := current_entry^.next_entry;
          FREE  entry_to_flush  IN  nav$network_paged_heap^;
          IF  previous_entry = NIL  THEN
            local_nad^.outgoing_cm_queue.first_entry := current_entry;
          ELSE
            previous_entry^.next_entry := current_entry;
          IFEND;
        ELSE
          previous_entry := current_entry;
          current_entry := current_entry^.next_entry;
        IFEND;
      UNTIL  current_entry = NIL;
      IF  NOT entry_flushed  THEN
        current_entry := local_nad^.outgoing_cm_queue.first_entry;
        previous_entry := NIL;
      /rethread_queue/
        WHILE  current_entry <> NIL  DO
          IF  current_entry^.control_message.header.nad_address <> destination_nad  THEN
            IF  previous_entry <> NIL  THEN
              previous_entry^.next_entry := current_entry^.next_entry;
              current_entry^.next_entry := local_nad^.outgoing_cm_queue.first_entry;
              local_nad^.outgoing_cm_queue.first_entry := current_entry;
            IFEND;
            EXIT /rethread_queue/;
          ELSE
            previous_entry := current_entry;
            current_entry := current_entry^.next_entry;
          IFEND;
        WHILEND  /rethread_queue/;
      IFEND;
    IFEND;
    local_nad^.processing_out_control_mess := FALSE;
    rfp$unlock_table(local_nad^.outgoing_cm_queue.lock);

  PROCEND relink_control_message_queue;
?? OLDTITLE ??
?? TITLE := '    PROCESS_REC_CTRL_RESPONSE' ??
?? EJECT ??
  PROCEDURE  process_rec_ctrl_response(command_buff: ^ARRAY [rft$command_entry] OF rft$command;
                                       pp_response: ^iot$pp_response;
                                       detailed_status: ^rft$detailed_status;
                                   VAR current_request: ^rft$outstanding_requests;
                                   VAR release_request: BOOLEAN;
                                   VAR status: ost$status);

{    The purpose of this procedure is to process a completed receive control message request.
{
{    command_buff: (input) This parameter specifies a pointer to the command buffer of the
{      corresponding request.
{
{    pp_response: (input) This parameter speicifies a pointer to the corresponding pp response.
{
{    detailed_status: (input) This parameter specifies a pointer to the detailed status (if any).
{
{    current_request: (input,output) This parameter specifies the pointer to the completed request.
{
{    release_request: (input,output) This parameter states whether the corresponding request has been
{      completed and should be removed from the outstanding request queue.  The calling routine must
{      initialize this to TRUE.
{
{    status: (output) This parameter returns the results of the request.  The calling routine must
{      initialize the status to normal.


    VAR
        abnormal_stat: iot$abnormal_status,
        abnormal_status: ^rft$abnormal_status,
        local_nad: ^rft$local_nad_entry,
        data_length: rft$control_message_text,
        control_message: ^rft$nbp_control_message,
        reject_tried,
        recoverable: boolean,
        ignore_status: ost$status;

  /main_section/
    BEGIN
      local_nad := ^rfv$status_table.local_nads^[current_request^.request_id.ring_3_id.nad];
      IF  pp_response^.response_code.primary_response = ioc$normal_response  THEN
        data_length := command_buff^[rfc$cbi_unit_request_1].lc_length -
          #SIZE(rft$nbp_control_message_header);
        PUSH control_message : [data_length];
        i#move(#LOC(command_buff^[rfc$cbi_general_buffer]), #LOC(control_message^),
          command_buff^[rfc$cbi_unit_request_1].lc_length);
        process_control_message(control_message, current_request^.request_id.ring_3_id.nad,
          control_message^.header.my_path_id,
          command_buff^[rfc$cbi_unit_request_1].lc_flags.rejected_control_message);
        rfp$delink_request(current_request^.request_id, status);
        get_next_control_message(current_request, local_nad, FALSE, status);
        IF  status.normal  THEN
          release_request := FALSE;
        ELSE
          local_nad^.processing_in_control_mess := FALSE;
        IFEND;

      ELSE  {  ioc$abnormal_response  }

        abnormal_stat := pp_response^.abnormal_status;
        abnormal_status := #LOC(abnormal_stat);
        IF  (abnormal_status^.invalid_status_value)
            AND ((detailed_status^.last_mc_status.response = rfc$nr_transfer_not_ready) OR
                 (detailed_status^.last_mc_status.response = rfc$nr_negative_acknowledge))
            AND (NOT detailed_status^.last_mc_status.hardware_fault)  THEN
          reject_tried := command_buff^[rfc$cbi_unit_request_1].lc_flags.rejected_control_message;
          rfp$delink_request(current_request^.request_id, ignore_status);
          IF  reject_tried  THEN
            local_nad^.processing_in_control_mess := FALSE;
          ELSE
            get_next_control_message(current_request, local_nad, TRUE, status);
            IF  status.normal  THEN
              release_request := FALSE;
            ELSE
              local_nad^.processing_in_control_mess := FALSE;
            IFEND;
          IFEND;
        ELSE
          log_nad_error(pp_response, detailed_status, current_request^.request_kind,
            current_request^.retry_count, current_request^.request_id.ring_3_id.nad, 0, FALSE, recoverable);
          IF  recoverable  THEN
            current_request^.retry_count := current_request^.retry_count + 1;
            rfp$re_issue_request(current_request^.request_id, status);
            IF  status.normal  THEN
              release_request := FALSE;
              EXIT /main_section/;
            IFEND;
          IFEND;
          rfp$delink_request(current_request^.request_id, ignore_status);
          local_nad^.processing_in_control_mess := FALSE;
          local_nad^.connection_table^[0].input_available := FALSE;
        IFEND;
      IFEND;
    END /main_section/;

  PROCEND process_rec_ctrl_response;
?? NEWTITLE := '      GET_NEXT_CONTROL_MESSAGE' ??
?? EJECT ??
  PROCEDURE  get_next_control_message(VAR current_request: ^rft$outstanding_requests;
                                          local_nad: ^rft$local_nad_entry;
                                          get_rejected_control_message: BOOLEAN;
                                      VAR status: ost$status);

    VAR
        request_info: ^SEQ(*),
        command_identifier: ^rft$logical_commands,
        rejected_control_message: ^BOOLEAN,
        physical_from: ^rft$physical_from;

  /process_incoming_messages/
    BEGIN
      PUSH  request_info : [[rft$logical_commands,BOOLEAN,rft$physical_from]];
      RESET request_info;
      NEXT  command_identifier  IN  request_info;
      IF  command_identifier = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big',
          status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'GET_NEXT_CONTROL_MESSAGE',
          status);
        EXIT /process_incoming_messages/;
      IFEND;
      command_identifier^ := rfc$lc_receive_control_message;
      NEXT  rejected_control_message  IN  request_info;
      IF  rejected_control_message = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'reject flag too big',
          status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'GET_NEXT_CONTROL_MESSAGE',
          status);
        EXIT /process_incoming_messages/;
      IFEND;
      rejected_control_message^ := get_rejected_control_message;
      NEXT  physical_from  IN  request_info;
      IF  physical_from = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'physical from too big',
          status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'GET_NEXT_CONTROL_MESSAGE',
          status);
        EXIT /process_incoming_messages/;
      IFEND;
      physical_from^.compare_name := TRUE;
      physical_from^.criteria := rfc$pf_match_first_character;
      physical_from^.char1 := rfv$status_table.local_host^.subsystem_identifier(1,1);
      RESET request_info;
      rfp$post_request(request_info, current_request^.request_id, status);
    END /process_incoming_messages/;

  PROCEND get_next_control_message;
?? TITLE := '      PROCESS_CONTROL_MESSAGE' ??
?? EJECT ??
  PROCEDURE  process_control_message(control_message: ^rft$nbp_control_message;
                                     nad_index: rft$local_nads;
                                     connection_number: rft$concurrent_connections;
                                     rejected: BOOLEAN);

{    The purpose of this routine is to process incoming control messages.
{
{    control_message: (input) This parameter specifies the incoming control message that
{      was received.
{
{    nad_index: (input) This parameter specifies the nad that the incoming control message
{      was received from.
{
{    connection_number: (input) This parameter specifies the connection number of the
{      destination path.
{
{    rejected: (input) This parameter specifies whether the control message was a rejected
{      control message.

    VAR
        status: ost$status,
        connection_entry: ^rft$connection_entry,
        local_nad: ^rft$local_nad_entry,
        rejected_string: STRING(11);

    local_nad := ^rfv$status_table.local_nads^[nad_index];
    IF  (NOT rejected)  AND
        (control_message^.header.block_type = rfc$nbp_block_type_back)  THEN
      rfp$lock_table(local_nad^.connection_table_lock);
      connection_entry := local_nad^.connection_table^[connection_number].connection_table_entry;
      IF  connection_entry <> NIL  THEN
        rfp$lock_table(connection_entry^.lock);
        connection_entry^.connection_attributes.acks_received_count :=
          connection_entry^.connection_attributes.acks_received_count + 1;
        rfp$unlock_table(connection_entry^.lock);
      IFEND;
      rfp$unlock_table(local_nad^.connection_table_lock);
    ELSE
      IF  rejected  THEN
        rejected_string := 'A REJECTED';
      ELSE
        rejected_string := 'AN ABNORMAL';
      IFEND;
      osp$set_status_abnormal(rfc$product_id, rfe$unexpected_control_message, rejected_string, status);
      osp$append_status_parameter(osc$status_parameter_delimiter, local_nad^.name, status);
      osp$append_status_integer(osc$status_parameter_delimiter, control_message^.header.my_path_id, 10,
        FALSE, status);
      osp$append_status_integer(osc$status_parameter_delimiter, control_message^.header.his_path_id, 10,
        FALSE, status);
      osp$append_status_integer(osc$status_parameter_delimiter, control_message^.header.block_type,  10,
        FALSE, status);
      rfp$log_the_status(status);
    IFEND;

  PROCEND process_control_message;
?? OLDTITLE ??
?? OLDTITLE ??
?? TITLE := '  MISCELLANEOUS ERROR PROCESSING ROUTINES' ??
?? NEWTITLE := '    LOG_NAD_ERROR' ??
?? EJECT ??
  PROCEDURE  log_nad_error(pp_response: ^iot$pp_response;
                           detailed_status: ^rft$detailed_status;
                           request_kind: rft$nad_request_kinds;
                           retry_count: 0..rfc$max_nad_retries;
                           nad_index: rft$local_nads;
                           connection_number: rft$concurrent_connections;
                           retry_on_processor_halt: BOOLEAN;
                       VAR recoverable: BOOLEAN);

{    The purpose of this request is to extract all meaningful information from an abnormal
{    NAD status and log appropriate diagnostics.
{
{    pp_response: (input) This parameter specifies the pointer to the response buffer.
{
{    detailed_status: (input) This parameter specifies the pointer to the detailed status buffer.
{
{    request_kind: (input) This parameter specifies the NAD function sequence that was currently
{      being executed.
{
{    retry_count: (input) This parameter speicifies the number of retries that have been attempted.
{
{    nad_index: (input) This parameter specifies the local nad table index of the corresponding
{      local NAD.
{
{    connection_number: (input) This parameter specifies the connection number of the local
{      path that was being processed at the time of the failure.  A value of zero means
{      that a non-path related function was issued.
{
{    retry_on_processor_halt: (input)  This parameter specifies whether or not retries are
{      permissible on a processor halt condition.
{
{    recoverable: (output) This parameter returns a value stating whether or not the request can
{      be retried.


    VAR
        transfer_status: rft$transfer_state,
        abnormal_stat: iot$abnormal_status,
        nad_requires_maintenance: BOOLEAN,
        status: ost$status,
        abnormal_status: ^rft$abnormal_status;

    recoverable := FALSE;
    nad_requires_maintenance := FALSE;

    abnormal_stat := pp_response^.abnormal_status;
    abnormal_status := #LOC(abnormal_stat);
    IF  abnormal_status^.alert_condition_encountered  THEN
      log_alert_condition(pp_response^.alert_conditions, pp_response^.alert_mask, request_kind,
        transfer_status, status);
      IF request_kind <> rfc$rk_disconnect_path THEN

{     Note - During the disconnect path function, this code is running under file management code
{       that prevents the logging of error messages because the local file table is locked.

        rfp$log_the_status(status);
      IFEND;
    ELSEIF  abnormal_status^.interface_error  THEN
      log_interface_error(pp_response^.interface_error_code, request_kind, status);
      IF request_kind <> rfc$rk_disconnect_path THEN

{     Note - During the disconnect path function, this code is running under file management code
{       that prevents the logging of error messages because the local file table is locked.

        rfp$log_the_status(status);
      IFEND;

    ELSE  {  all other conditions should be NAD processing errors.

      log_nad_processing_error(pp_response, detailed_status, abnormal_status, request_kind,
        retry_on_processor_halt, retry_count, nad_index, connection_number, recoverable);
    IFEND;

  PROCEND log_nad_error;
?? NEWTITLE := '      LOG_ALERT_CONDITION' ??
?? EJECT ??
  PROCEDURE  log_alert_condition(alert_condition: iot$alert_conditions;
                                 alert_mask: iot$alert_conditions;
                                 request_kind: rft$nad_request_kinds;
                             VAR transfer_status: rft$transfer_state;
                             VAR status: ost$status);

{    This routine is used to generate a log message for an alert condition.  This routine also
{    returns the current transfer status, as determined by the alert condition that was
{    encountered.
{
{    alert_condition: (input) This parameter specifies the condition that was encountered.
{
{    request_kind: (input) This parameter specifies the NAD function sequence that was currently
{      being executed.
{
{    transfer_status: (output) This parameter returns the current transfer status based on the
{      alert condition encountered.
{
{    status: (output) This parameter contains the message to log.

    VAR
        condition_string: STRING(28),
        switch_condition_ptr: ^cell,
        condition: ^rft$alert_conditions,
        mask: ^rft$alert_conditions;

    condition := #LOC(alert_condition);
    mask := #LOC(alert_mask);
    transfer_status.transfer_state := rfc$ts_alert;

    IF  condition^.end_of_message  AND  mask^.end_of_message  THEN
      condition_string := 'end of message encountered  ';
      transfer_status.alert_kind := rfc$ak_end_of_message;

    ELSEIF  condition^.eoi_mark_encountered  AND  mask^.eoi_mark_encountered  THEN
      condition_string := 'eoi mark encountered       ';
      transfer_status.alert_kind := rfc$ak_eoi_block;

    ELSEIF  condition^.eof_mark_encountered  AND  mask^.eof_mark_encountered  THEN
      condition_string := 'eof mark encountered       ';
      transfer_status.alert_kind := rfc$ak_eof_block;

    ELSEIF  condition^.eor_mark_encountered  AND  mask^.eor_mark_encountered  THEN
      condition_string := 'eor mark encountered       ';
      transfer_status.alert_kind := rfc$ak_eor_block;

    ELSEIF  condition^.pru_block_next  AND  mask^.pru_block_next  THEN
      condition_string := 'record block encountered    ';
      transfer_status.alert_kind := rfc$ak_record_block;

    ELSEIF  condition^.non_pru_block_next  AND  mask^.non_pru_block_next  THEN
      condition_string := 'message block encountered   ';
      transfer_status.alert_kind := rfc$ak_message_block;

    ELSEIF  condition^.long_input_block  AND  mask^.long_input_block  THEN
      condition_string := 'long input block encountered';
      transfer_status.alert_kind := rfc$ak_long_input;

    ELSE  {  unknown alert condition   }
      condition_string := 'unknown alert encountered   ';

      {  This should never happen.  To prevent further errors, an EOI status is returned.
      {  This will fake the caller into thinking the transfer has ended, which will cause
      {  termination processing to occur.

      transfer_status.alert_kind := rfc$ak_eoi_block;
    IFEND;

    osp$set_status_abnormal(rfc$product_id, rfe$alert_condition, condition_string, status);
    osp$append_status_parameter(osc$status_parameter_delimiter, rfv$request_names[request_kind],
      status);

  PROCEND log_alert_condition;
?? TITLE := '      LOG_INTERFACE_ERROR' ??
?? EJECT ??
  PROCEDURE  log_interface_error(interface_error_code: iot$interface_error_code;
                                 request_kind: rft$nad_request_kinds;
                             VAR status: ost$status);

{    The purpose of this routine is to generate a log message for an invalid status condition.
{
{    interface_error_code: (input) This parameter specifies the interface error code that was
{      returned from the pp.
{
{    request_kind: (input) This parameter specifies the NAD function sequence that was currently
{      being executed.
{
{    status: (output) This parameter contains the formatted message.

    VAR
        iec_string: STRING(23);

    CASE  interface_error_code  OF
    = 020A(16) =
      iec_string := 'unknown channel number ';
    = 0211(16) =
      iec_string := 'maximum units exceeded ';
    = 0220(16) =
      iec_string := 'invalid PP number      ';
    = 0301(16) =
      iec_string := 'LUN in UD <> LUN in UIT';
    = 0306(16) =
      iec_string := 'invalid unit type      ';
    = 0501(16) =
      iec_string := 'invalid command code   ';
    = 0503(16) =
      iec_string := 'channel hardware error ';
    = 0505(16) =
      iec_string := 'length error in command';
    = 050B(16) =
      iec_string := 'invalid parameter value';
    ELSE
      iec_string := 'unknown interface error';
    CASEND;

    osp$set_status_abnormal(rfc$product_id, rfe$interface_error, iec_string, status);
    osp$append_status_parameter(osc$status_parameter_delimiter, rfv$request_names[request_kind],
      status);

  PROCEND log_interface_error;
?? TITLE := '      LOG_NAD_PROCESSING_ERROR' ??
?? EJECT ??
  PROCEDURE  log_nad_processing_error(pp_response: ^iot$pp_response;
                                      detailed_status: ^rft$detailed_status;
                                      abnormal_status: ^rft$abnormal_status;
                                      request_kind: rft$nad_request_kinds;
                                      retry_on_processor_halt: BOOLEAN;
                                      retry_count: 0..rfc$max_nad_retries;
                                      nad_index: rft$local_nads;
                                      connection_number: rft$concurrent_connections;
                                  VAR recoverable: BOOLEAN);

{    The purpose of this procedure is to generate a log message for a NAD interface error.
{
{    pp_response: (input) This parameter specifies a pointer to the pp response.
{
{    detailed_status: (input) This parameter specifies a pointer to the detailed status field.
{
{    abnormal_status: (input) This parameter specifies a pointer to the abnormal status that was
{      returned by the PP.
{
{    request_kind: (input) This parameter specifies the NAD function sequence that was currently
{      being executed.
{
{    retry_on_processor_halt: (input) This parameter specifies whether or not retries are
{      allowed if the processor is not running (used for dumps and loads).
{
{    retry_count: (input) This parameter specifies the number of retries that have been
{      made while attempting to complete this request.
{
{    nad_index: (input) This parameter specifies the local NAD that failed.
{
{    connection_number: (input) This parameter specifies the connection number of the local
{      path that was being processed at the time of the failure.  A value of zero means
{      that a non-path related function was issued.
{
{    recoverable: (output) This parameter returns a BOOLEAN value stating whether or not
{      the request is a candidate for retrying.

    TYPE
        output_nad_status = PACKED RECORD
          mc_func: 0..0ffff(16),
          mc_stat: 0..0ffff(16),
          hw_func: 0..0ffff(16),
          hw_stat: 0..0ffff(16),
        RECEND;

    VAR
        pp_number: 0..31,
        concurrent_channel_flag : integer,
        descriptor_data: ost$string,
        iou_number: dst$iou_number,
        ignore: ost$status,
        counters: ^ARRAY [1..*] OF sft$counter,
        message: ^STRING(*),
        local_nad: ^rft$local_nad_entry,
        switch_ptr: ^CELL,
        temp_status: ^output_nad_status,
        severity_value: 0..4,
        symptom: rft$failure_data_symptoms;

    recoverable := FALSE;

    IF  abnormal_status^.function_timeout  THEN
      symptom := rfc$function_timeout;
    ELSEIF  abnormal_status^.channel_activate_failed  THEN
      symptom := rfc$channel_activate_failed;
    ELSEIF  abnormal_status^.channel_hung_empty  THEN
      symptom := rfc$channel_hung_empty;
    ELSEIF  abnormal_status^.prime_flag_timeout  THEN
      symptom := rfc$prime_flag_timeout;
    ELSEIF  abnormal_status^.flag_function_timeout  THEN
      symptom := rfc$flag_function_timeout;
    ELSEIF  abnormal_status^.invalid_status_value  THEN
      symptom := rfc$abnormal_nad_response;
    ELSEIF  abnormal_status^.hardware_fault  THEN
      symptom := rfc$nad_hardware_abnormal;
    ELSEIF  abnormal_status^.input_transfer_abnormal  THEN
      symptom := rfc$input_terminated_early;
    ELSEIF  abnormal_status^.output_transfer_abnormal  THEN
      symptom := rfc$output_terminated_early;
    ELSEIF  abnormal_status^.channel_parity_error  THEN
      symptom := rfc$channel_parity_error;
    ELSEIF  abnormal_status^.universal_command_timeout  THEN
      symptom := rfc$universal_command_timeout;
    ELSE
      {  NAD assumed to be already down  }
      RETURN;
    IFEND;

    IF  detailed_status^.last_hw_status.nad_processor_not_running  THEN
      IF  (retry_count < rfc$max_nad_retries) AND
          (retry_on_processor_halt)  THEN
        rfp$change_nad_status(rfv$status_table.local_nads^[nad_index].logical_unit_number, rfc$es_on);
        recoverable := TRUE;
      IFEND;
    ELSE
      IF  retry_count < rfc$max_nad_retries  THEN
        recoverable := TRUE;
      IFEND;
    IFEND;
    local_nad := ^rfv$status_table.local_nads^[nad_index];
    PUSH  counters : [1..15];
    cmp$return_desc_data_by_lun_lpn(local_nad^.logical_unit_number,
      local_nad^.pp[1].pp_number, iou_number, descriptor_data, pp_number);
    concurrent_channel_flag :=0;
    IF local_nad^.concurrent_channel THEN
      concurrent_channel_flag := 1*40(16);
      IF symptom = rfc$channel_parity_error THEN
        symptom := rfc$concurrent_channel_error
      IFEND;
    IFEND;
    PUSH  message : [descriptor_data.size+4+25];
    message^(1,descriptor_data.size) := descriptor_data.value;
    IF  recoverable  THEN
      message^(descriptor_data.size+1,4) := '*IF*';
      severity_value := 2;
    ELSE
      message^(descriptor_data.size+1,4) := '*UF*';
      severity_value := 1;
    IFEND;
    message^(descriptor_data.size+1+4,25) := rfv$failure_data_symptoms[symptom];
    switch_ptr := detailed_status;
    temp_status := switch_ptr;

    counters^[1] := pp_number + concurrent_channel_flag + iou_number * 1000(16);
    IF symptom = rfc$concurrent_channel_error THEN
      counters^[1] := counters^[1] + pp_response^.interface_error_code * 1000000000000(16)
    IFEND;
    counters^[2] := local_nad^.channel_number + concurrent_channel_flag + iou_number * 1000(16);
    counters^[3] := 0;
    counters^[4] := 0;
    counters^[5] := 1;     { $380-170 }
    counters^[6] := ORD(request_kind);
    counters^[7] := severity_value;
    counters^[8] := ORD(symptom);
    counters^[9] := retry_count;
    counters^[10] := connection_number;
    counters^[11] := temp_status^.mc_func;
    counters^[12] := temp_status^.hw_func;
    counters^[13] := temp_status^.mc_stat;
    counters^[14] := temp_status^.hw_stat;
    counters^[15] := pp_response^.transfer_count;
    sfp$emit_statistic(cml$rhfam_failure_data, message^, counters, ignore);
    IF  NOT recoverable  THEN
      rfp$lock_table(rfv$status_table.lock);
      IF  rfv$status_table.local_nads^[nad_index].current_status.device_status = rfc$es_on  THEN
        rfv$status_table.local_nads^[nad_index].current_status.device_status := rfc$es_down;
      IFEND;
      rfp$unlock_table(rfv$status_table.lock);
    IFEND;

  PROCEND log_nad_processing_error;
?? OLDTITLE ??
?? OLDTITLE ??
?? TITLE := '  RFP$QUEUE_REQUEST' ??
?? EJECT ??
  PROCEDURE [XDCL] rfp$queue_request(nad_index: rft$local_nads;
                                     pp_index: 1..2;
                                     request_type: rft$request_types;
                                     nad_request: rft$nad_request_kinds;
                                     request_status: ^cell;
                                 VAR request_info: ^SEQ(*);
                                 VAR status: ost$status);

*copyc rfh$queue_request

    VAR
        done: BOOLEAN,
        task_id: ost$global_task_id,
        local_nad: ^rft$local_nad_entry,
        current_request: 0..rfc$max_r3_request_id,
        request: ^rft$outstanding_requests,
        ignore_status: ost$status,
        request_id: rft$request_identifier;

    status.normal := TRUE;

    ALLOCATE  request  IN  osv$task_private_heap^;
    IF  request = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'task private', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$QUEUE_REQUEST', status);
      RETURN;
    IFEND;
    pmp$get_executing_task_gtid(task_id);
    done := FALSE;
    REPEAT
      rfp$lock_table(rfv$status_table.lock);
      IF  (rfv$system_task_id <> task_id) AND
          ((NOT rfv$status_table.system_task_is_up) OR
           (rfv$status_table.local_nads^[nad_index].current_status.device_status <> rfc$es_on))  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$local_nad_down, 'to the NAD', status);
        done := TRUE;
      ELSEIF  rfv$status_table.local_nads^[nad_index].requests_posted < rfc$max_concurrent_requests  THEN
        rfv$status_table.local_nads^[nad_index].requests_posted :=
          rfv$status_table.local_nads^[nad_index].requests_posted + 1;
        done := TRUE;
      ELSE
        rfp$unlock_table(rfv$status_table.lock);
        syp$cycle;
        rfp$process_pp_response_flag(rfc$pp_response_available);
      IFEND;
    UNTIL done;
    rfp$unlock_table(rfv$status_table.lock);
    IF  NOT status.normal  THEN
      FREE  request  IN  osv$task_private_heap^;
      RETURN;
    IFEND;
    local_nad := ^rfv$status_table.local_nads^[nad_index];
    IF  rfv$outstanding_requests = NIL  THEN
      current_request := 1;
    ELSE
      current_request := (rfv$outstanding_requests^.request_id.ring_3_id.entry + 1)
        MOD rfc$max_r3_request_id;
    IFEND;
    request_id.ring_3_id.entry := current_request;
    request_id.ring_3_id.nad := nad_index;
    request_id.ring_3_id.pp := pp_index;
    request_id.ring_3_id.location.kind := request_type;
    IF  request_type = rfc$unit_request  THEN
      request_id.ring_3_id.location.logical_unit := local_nad^.logical_unit_number;
    ELSE
      request_id.ring_3_id.location.logical_pp := local_nad^.pp[pp_index].pp_number;
    IFEND;
    RESET request_info;
    rfp$post_request(request_info, request_id, status);
    IF  NOT status.normal  THEN
      rfp$lock_table(rfv$status_table.lock);
      local_nad^.requests_posted := local_nad^.requests_posted - 1;
      rfp$unlock_table(rfv$status_table.lock);
      FREE  request  IN  osv$task_private_heap^;
    ELSE
      request^.waiting_event := NIL;
      request^.posted := TRUE;
      request^.processing_request := FALSE;
      request^.request_id := request_id;
      request^.request_status := request_status;
      request^.retry_count := 0;
      request^.request_kind := nad_request;
      request^.next_entry := rfv$outstanding_requests;
      rfv$outstanding_requests := request;
    IFEND;

  PROCEND rfp$queue_request;
?? OLDTITLE ??
MODEND rfm$process_pp_response_flag;
*DECK DECK=RFM$REQUEST_PROCESSING_MTR EXPAND=TRUE
*copyc osd$default_pragmats
?? TITLE := 'RHFAM/VE : Monitor Processing' ??
?? NEWTITLE := '  Common Decks' ??
MODULE rfm$request_processing_mtr;


*copyc rft$rb_queue_data_fragments
?? EJECT ??
*copyc i$real_memory_address
*copyc mmp$build_lock_rma_list
*copyc mmp$xtask_pva_to_sva
*copyc mmp$unlock_rma_list
*copyc mtp$error_stop
*copyc ost$global_task_id
*copyc osv$page_size
*copyc rft$r1_interface_defs
*copyc rft$status_response_pending
*copyc tmp$check_taskid
*copyc tmp$set_task_ready
*copyc tmp$set_system_flag
*copyc syt$monitor_status
?? TITLE := '  Mainframe Global Variables' ??
?? EJECT ??

{
{    The following global definition is used to globally identify the RHFAM/VE
{    system task for use by monitor.
{

  VAR
      rfv$system_task_id: [XDCL, #GATE] ost$global_task_id := [0,0];

  VAR
      rfv$response_processor: [XDCL, #GATE] iot$response_processor := ^rfp$io_complete_processor;

  VAR
      rfv$pp_interface_error: [XDCL, #GATE] rft$pp_interface_error := [0,0];

  VAR
      rfv$status_response_pending: [XDCL, #GATE] rft$status_response_pending := NIL;

  VAR
      rfv$response_seq_number: INTEGER := 0;
?? TITLE := '  RFP$IO_COMPLETE_PROCESSOR' ??
?? EJECT ??
  PROCEDURE  [XDCL] rfp$io_complete_processor(pp_response: ^iot$pp_response;
                                  detailed_status: ^iot$detailed_status;
                                  logical_pp: 1..ioc$pp_count;
                              VAR status: syt$monitor_status);

*copyc rfh$io_complete_processor


    VAR
        command_buffer: ^ARRAY [rft$command_entry] OF rft$command,
        current_in_ptr,
        current_out_ptr: rft$command_entry,
        request: ^rft$peripheral_request,
        request_response_buffer: ^rft$request_response_buffer,
        detailed_status_entry: ^rft$detailed_status,
        detail_status: ^iot$detailed_status,
        io_type: iot$io_function,
        ignore_status: syt$monitor_status;


    detail_status := detailed_status;
    status.normal := TRUE;

    CASE  pp_response^.response_code.primary_response  OF

    = ioc$unsolicited_response =

      {  An unsolicited response should only be returned if there is an error encountered by the
      {  PP, when the PP is validating its PP interface table entry and unit interface table entry.
      {  The unsolicited response code is placed in a global variable and the system task is
      {  READYed.  The system task will abort with an invalid status.  Since the system task aborts
      {  if any PP reports an interface error, it is only necessary to capture the first error.

      IF  (rfv$system_task_id.index = 0)  AND  (rfv$system_task_id.seqno = 0)  THEN

        {  A PP response should not be given if the system task is not running  }

        mtp$error_stop('RF - INVALID UNSOLICITED RESPONSE');
      ELSE
        IF  rfv$pp_interface_error.interface_error_code <> 0  THEN
          rfv$pp_interface_error.pp_number := logical_pp;
          rfv$pp_interface_error.interface_error_code := pp_response^.interface_error_code;
          tmp$check_taskid(rfv$system_task_id, tmc$opt_return, ignore_status);
          IF ignore_status.normal THEN
            tmp$set_task_ready(rfv$system_task_id, 0 {readying_task_priority},
              tmc$rc_ready_conditional_wi);
          IFEND;
        IFEND;
      IFEND;

    = ioc$normal_response, ioc$abnormal_response =

      {  For either of these response types the response is simply copied into
      {  the specified wired area and the queuing task is restarted to
      {  perform the response processing.

      request := pp_response^.request^.device_request_p;
      request_response_buffer := request^.request_buffer_ptr;
      request_response_buffer^.response := pp_response^;
      IF  request_response_buffer^.response.response_code.secondary_response = 1  THEN {detailed status}
        RESET  detail_status;
        NEXT  detailed_status_entry IN detail_status;
        IF  detailed_status_entry <> NIL  THEN
          request_response_buffer^.detailed_status := detailed_status_entry^;
        IFEND;
      IFEND;
      command_buffer := #LOC(request_response_buffer^.command_buffer);
      IF  (command_buffer^[rfc$cbi_unit_request_1].lc_function_code = rfc$lc_send_data)  OR
          (command_buffer^[rfc$cbi_unit_request_1].lc_function_code = rfc$lc_receive_data)  THEN
        IF  command_buffer^[rfc$cbi_unit_request_1].lc_function_code = rfc$lc_send_data  THEN
          io_type := ioc$explicit_write;
        ELSE
          io_type := ioc$explicit_read;
        IFEND;
        current_in_ptr := (command_buffer^[rfc$cbi_in_pointer].bp_offset DIV 8) + rfc$cbi_first_io_entry;

        {   This pointer is updated on terminating responses to prevent the request queueing routine
        {   from adding additional entries after the request has completed.

        request_response_buffer^.previous_in_ptr := current_in_ptr;
        current_out_ptr := (command_buffer^[rfc$cbi_out_pointer].bp_offset DIV 8) + rfc$cbi_first_io_entry;
        unlock_pages(command_buffer, request_response_buffer^.previous_out_ptr, current_out_ptr, io_type);

        {   This pointer is only updated by this routine.  This is used to detect the amount of
        {   data that has actually been transferred.

        request_response_buffer^.previous_out_ptr := current_out_ptr;

        {  NOTE - on a terminating response the pages that have been locked but not transferred to/from
        {         must be unlocked.

        unlock_pages(command_buffer, current_out_ptr, current_in_ptr, ioc$no_io);
      ELSEIF  (command_buffer^[rfc$cbi_unit_request_1].lc_function_code = rfc$lc_status_nad)  THEN
        rfv$status_response_pending^[request_response_buffer^.request_id.ring_3_id.nad].in_host := TRUE;
      IFEND;
      rfv$response_seq_number := rfv$response_seq_number + 1;
      request_response_buffer^.response_seq_number := rfv$response_seq_number;
      #SPOIL(request_response_buffer^.response_seq_number, request_response_buffer^.response_posted);
      request_response_buffer^.response_posted := TRUE;
      IF  request_response_buffer^.asynchronous_request  THEN
        tmp$set_system_flag(request_response_buffer^.task_id, rfc$pp_response_available, ignore_status);
      ELSE
        tmp$check_taskid(request_response_buffer^.task_id, tmc$opt_return, ignore_status);
        IF ignore_status.normal THEN
          tmp$set_task_ready(request_response_buffer^.task_id, 0 {readying_task_priority},
             tmc$rc_ready_conditional_wi);
        IFEND;
      IFEND;

    = ioc$intermediate_response =

      {  This response is only given when a send data or receive data request
      {  has room for more data addresses to be placed in the request buffer.
      {  No data is passed to the task.  The task is simply restarted and it
      {  is up to that task to determine what actions, if any, should be taken.

      request := pp_response^.request^.device_request_p;
      request_response_buffer := request^.request_buffer_ptr;
      command_buffer := #LOC(request_response_buffer^.command_buffer);
      IF  (command_buffer^[rfc$cbi_unit_request_1].lc_function_code = rfc$lc_send_data)  OR
          (command_buffer^[rfc$cbi_unit_request_1].lc_function_code = rfc$lc_receive_data)  THEN
        IF  command_buffer^[rfc$cbi_unit_request_1].lc_function_code = rfc$lc_send_data  THEN
          io_type := ioc$explicit_write;
        ELSE
          io_type := ioc$explicit_read;
        IFEND;
        current_out_ptr := (command_buffer^[rfc$cbi_out_pointer].bp_offset DIV 8) + rfc$cbi_first_io_entry;
        unlock_pages(command_buffer, request_response_buffer^.previous_out_ptr, current_out_ptr, io_type);

        {   This pointer is only updated by this routine.  This is used to detect the amount of
        {   data that has actually been transferred.

        request_response_buffer^.previous_out_ptr := current_out_ptr;
      IFEND;
      IF  request_response_buffer^.asynchronous_request  THEN
        tmp$set_system_flag(request_response_buffer^.task_id, rfc$pp_response_available, ignore_status);
      ELSE
        tmp$check_taskid(request_response_buffer^.task_id, tmc$opt_return, ignore_status);
        IF ignore_status.normal THEN
          tmp$set_task_ready(request_response_buffer^.task_id, 0 {readying_task_priority},
             tmc$rc_ready_conditional_wi);
        IFEND;
      IFEND;

    ELSE

      {  If we ever get here, some super-natural event probably occurred.  For
      {  now we will stop the system.  We may do something more fault tolerant
      {  in the future.

      mtp$error_stop('RF - INAVLID PP RESPONSE');

    CASEND;

  PROCEND rfp$io_complete_processor;
?? NEWTITLE := '    UNLOCK_PAGES' ??
?? EJECT ??
  PROCEDURE unlock_pages(command_buffer: ^ARRAY [rft$command_entry] of rft$command;
                         first_entry_index: rft$command_entry;
                         last_entry_index: rft$command_entry;
                         io_type: iot$io_function);

{    The purpose of this procedure is to unlock pages after the I/O transfer has completed.
{
{    command_buffer: (input) This parameter specifies a pointer to the command buffer which
{      contains the RMA entries.
{
{    first_entry_index: (input) This parameter specifies the index of the first entry to be
{      unlocked.
{
{    last_entry_index: (input) This parameter specifies the index (+ 1) of the the last
{      entry to be unlocked.
{
{    io_type: (input) This parameter specifies the type of I/O that was actually performed.

    VAR
        io_error: iot$io_error,
        io_id: mmt$io_identifier,
        actual_rma_list: ARRAY [rfc$cbi_first_io_entry..rfc$cbi_last_io_entry] OF mmt$rma_list_entry,
        rma_list: ^mmt$rma_list,
        rma_list_length: 0..mmc$max_rma_list_length,
        ignore_status: syt$monitor_status,
        number_of_entries: 0..rfc$command_buffer_size,
        fragment,
        current_entry_index: rft$command_entry;


    io_id.specified := FALSE;
    io_id.io_function := io_type;
    current_entry_index := first_entry_index;
    rma_list := #LOC(actual_rma_list);

    WHILE  current_entry_index <> last_entry_index  DO
      number_of_entries := (command_buffer^[current_entry_index].sf_length DIV 8) - 1;
      current_entry_index := current_entry_index + 1;
      IF  current_entry_index >= rfc$cbi_limit_pointer  THEN
        current_entry_index := rfc$cbi_first_io_entry;
      IFEND;
      rma_list_length := 0;
      FOR  fragment := 1 TO number_of_entries  DO
        IF  NOT command_buffer^[current_entry_index].wired  THEN
          rma_list_length := rma_list_length + 1;
          rma_list^[rma_list_length].length := command_buffer^[current_entry_index].re_length;
          rma_list^[rma_list_length].rma := command_buffer^[current_entry_index].re_address;
        IFEND;
        current_entry_index := current_entry_index + 1;
        IF  current_entry_index >= rfc$cbi_limit_pointer  THEN
          current_entry_index := rfc$cbi_first_io_entry;
        IFEND;
      FOREND;
      IF  rma_list_length <> 0  THEN
        io_error := ioc$no_error;
        mmp$unlock_rma_list(io_type, rma_list, rma_list_length, io_id, {MF_JOB_FILE} FALSE,
               io_error, ignore_status);
      IFEND;
    WHILEND;


  PROCEND unlock_pages;
?? OLDTITLE ??
?? TITLE := '  RFP$QUEUE_DATA_FRAGMENTS' ??
?? EJECT ??
  PROCEDURE [XDCL] rfp$queue_data_fragments(VAR request_block: rft$rb_queue_data_fragments);

*copyc rfh$queue_data_fragments


    VAR
        pva: ^cell,
        sva: ost$system_virtual_address,
        io_identifier: mmt$io_identifier,
        buffer_descriptor: mmt$buffer_descriptor,
        actual_rma_list: ARRAY [rfc$cbi_first_io_entry..rfc$cbi_last_io_entry] OF mmt$rma_list_entry,
        rma_list,
        current_rma_list: ^mmt$rma_list,
        rma_entry,
        rma_list_total_count,
        rma_list_count: 0..mmc$max_rma_list_length,
        command_buff: ^ARRAY [rft$command_entry] OF rft$command,
        entry_index,
        fragment_count: 0 .. rfc$command_buffer_size,
        save_old_in_pointer,
        save_last_block_pointer,
        buffer_index: rft$command_entry,
        request_buffer: ^rft$request_response_buffer,
        command_entry: rft$command,
        ignore_status,
        monitor_status: syt$monitor_status,
        data_length: rft$transfer_length,
        first_page_locked,
        pages_locked_in_block: BOOLEAN,
        previous_segment: ost$segment,
        page_size: ost$page_size;


    monitor_status.normal := TRUE;
    io_identifier.specified := FALSE;
    io_identifier.io_function := ioc$no_io;
    page_size := osv$page_size;
    request_buffer := request_block.request_buffer;
    rma_list_total_count := 0;
    rma_list := #LOC(actual_rma_list);
    command_buff := #LOC(request_buffer^.command_buffer);
    buffer_descriptor.buffer_descriptor_type := mmc$bd_explicit_io;
    first_page_locked := TRUE;

  /process_request/
    BEGIN

      save_old_in_pointer := request_buffer^.previous_in_ptr;
      save_last_block_pointer := request_buffer^.previous_in_ptr;
      buffer_index := request_buffer^.previous_in_ptr;
      #SPOIL(command_buff^);
      IF  (NOT request_block.clear_complete_flag) AND
          (command_buff^[rfc$cbi_unit_request_1].lc_flags.pp_process_complete)  THEN

        {  If we get here, the PP has completed the request and the previous in pointer is no
        {  longer valid.  We will return a normal status and let the user determine appropriate
        {  action based on the PP response.

        EXIT /process_request/;
      IFEND;
      FOR  entry_index := 1 TO request_block.number_of_blocks  DO
        fragment_count := (command_buff^[buffer_index].sf_length DIV 8) - 1;
        buffer_index := buffer_index + 1;
        IF  buffer_index >= rfc$cbi_limit_pointer  THEN
          buffer_index := rfc$cbi_first_io_entry;
        IFEND;
        pages_locked_in_block := FALSE;
        WHILE  fragment_count > 0  DO
          IF  NOT command_buff^[buffer_index].wired  THEN
            IF  pages_locked_in_block  THEN

              {  The RHFAM/VE ring 1 and monitor mode code were designed to support multiple
              {  user fragments aligned in any fashion.  Unfortunately this design is not
              {  currently supported by the memory management lock and unlock rma lists.
              {  Some work must be done in RHFAM/VE to make sure that each RMA list
              {  returned by the lock program is given back to the unlock program verbatim.

              mtp$error_stop('RF - MULTI-FRAGMENT FEATURE DISABLED');
            ELSE
              pages_locked_in_block := TRUE;
            IFEND;
            pva := command_buff^[command_buff^[buffer_index].pe_pva_index].pv_pva;

            IF  (first_page_locked)  OR
                (previous_segment <> #SEGMENT(pva))  OR
                (sva.offset <> #OFFSET(pva))         THEN
              first_page_locked := FALSE;
              previous_segment := #SEGMENT(pva);
              mmp$xtask_pva_to_sva(pva, sva, monitor_status);
              IF  NOT monitor_status.normal  THEN
                EXIT /process_request/;
              IFEND;
            IFEND;

            buffer_descriptor.sva := sva;
            data_length := command_buff^[buffer_index].pe_length;
            buffer_descriptor.page_count := (((sva.offset MOD page_size) + data_length - 1) DIV page_size)
              + 1;
            rma_list_count := ((sva.offset + data_length + (page_size * 2) - 1) DIV page_size) -
              ((sva.offset + page_size) DIV page_size);
            current_rma_list := #LOC(rma_list^[rma_list_total_count+1]);
            mmp$build_lock_rma_list(buffer_descriptor, data_length, request_block.io_type,
              current_rma_list, rma_list_count, monitor_status);
            IF  NOT monitor_status.normal  THEN
              EXIT /process_request/;
            IFEND;
            sva.offset := sva.offset + data_length;
            rma_list_total_count := rma_list_total_count + rma_list_count;
            rma_entry := 1;
            WHILE  rma_entry <= rma_list_count  DO
              command_entry.wired := FALSE;
              command_entry.re_length := current_rma_list^[rma_entry].length;
              command_entry.re_address := current_rma_list^[rma_entry].rma;
              command_buff^[buffer_index] := command_entry;
              rma_entry := rma_entry + 1;
              fragment_count := fragment_count - 1;
              buffer_index := buffer_index + 1;
              IF  buffer_index >= rfc$cbi_limit_pointer  THEN
                buffer_index := rfc$cbi_first_io_entry;
              IFEND;
            WHILEND;
          ELSE
            fragment_count := fragment_count - 1;
            buffer_index := buffer_index + 1;
            IF  buffer_index >= rfc$cbi_limit_pointer  THEN
              buffer_index := rfc$cbi_first_io_entry;
            IFEND;
          IFEND;
        WHILEND;
        save_last_block_pointer := buffer_index;
      FOREND;

      {   This pointer is updated in this routine after the data is queued.  The response processor
      {   may reset this pointer if a terminating PP response was received.  Therefore this pointer
      {   must be set before the PP processing complete flag is checked.

      request_buffer^.previous_in_ptr := buffer_index;
      #SPOIL(request_buffer^.previous_in_ptr);
      IF  request_block.clear_complete_flag  THEN
        request_buffer^.response_posted := FALSE;

        {   This pointer is only updated in this routine (when the page locking code is in use).

        command_buff^[rfc$cbi_in_pointer].bp_offset := (buffer_index - rfc$cbi_first_io_entry) * 8;
        #SPOIL(command_buff^);
        command_buff^[rfc$cbi_unit_request_1].lc_flags.pp_process_complete := FALSE;
      ELSE
        #SPOIL(command_buff^);
        IF  command_buff^[rfc$cbi_unit_request_1].lc_flags.pp_process_complete  THEN

          {   If the PP processing had completed before the additional buffers could be queued,
          {   the pages just locked must be unlocked.  A normal status is returned and
          {   the calling program must determine if the pages are to be requeued.

          unlock_pages(command_buff, save_old_in_pointer, save_last_block_pointer, ioc$no_io);
        ELSE

          {   This pointer is only updated in this routine (when the page locking code is in use).

          command_buff^[rfc$cbi_in_pointer].bp_offset := (buffer_index - rfc$cbi_first_io_entry) * 8;
          #SPOIL(command_buff^);

          {  The following test is used as a fail safe for multi-processor environments.  There is
          {  a possibility (none with today's implementation) that a PP response could be received and
          {  the IN pointer be reset before this routine updated the IN pointer offset.  Therefore
          {  the following test is made to make sure that all pages are unlocked if the above
          {  scenario would ever occur.  A normal status is returned and the calling program must
          {  determine if the pages are to be requeued.

          IF  ((request_buffer^.previous_in_ptr - rfc$cbi_first_io_entry) * 8) <>
               (command_buff^[rfc$cbi_in_pointer].bp_offset)  THEN
            unlock_pages(command_buff, save_old_in_pointer, save_last_block_pointer, ioc$no_io);
          IFEND;
        IFEND;
      IFEND;
    END /process_request/;

    IF  monitor_status.normal  THEN
      request_block.status.normal := TRUE;
    ELSE
      IF  (rma_list_total_count <> 0)  THEN
        unlock_pages(command_buff, save_old_in_pointer, save_last_block_pointer, ioc$no_io);
      IFEND;
      request_block.status := monitor_status;
    IFEND;

  PROCEND rfp$queue_data_fragments;

MODEND rfm$request_processing_mtr;
*DECK DECK=RFM$REQUEST_PROCESSING_R1 EXPAND=TRUE
*copyc osd$default_pragmats
MODULE rfm$request_processing_r1;
?? TITLE := 'RHFAM/VE : PP Request Processing : R113' ??
?? NEWTITLE := '  Common Decks' ??
?? EJECT ??
*copyc rft$pp_interface_defs
?? EJECT ??
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc i#call_monitor
*copyc i#move
*copyc i$real_memory_address
?? PUSH (LISTEXT := ON) ??
*copyc mme$condition_codes
?? POP ??
*copyc osv$mainframe_wired_cb_heap
*copyc osv$page_size
*copyc ost$signature_lock
*copyc osp$set_status_abnormal
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$begin_system_activity
*copyc osp$end_system_activity
*copyc osp$set_job_signature_lock
*copyc osp$clear_job_signature_lock
*copyc oss$mainframe_pageable
*copyc osv$mainframe_pageable_heap
*copyc osv$external_interrupt_selector
*copyc pmp$get_executing_task_gtid
?? PUSH (LISTEXT := ON) ??
*copyc rfd$path_status_table
*copyc rfd$nad_general_status
*copyc rfe$condition_codes
?? POP ??
*copyc rft$rhfam_server_table
*copyc rft$r1_interface_defs
*copyc rft$network_block_protocol
*copyc rft$rb_queue_data_fragments
*copyc rfv$response_processor
*copyc rfv$status_response_pending
*copyc rfv$system_task_id
*copyc syp$continue_to_cause
*copyc syp$cycle
*copyc syp$establish_condition_handler
*copyc tmv$null_global_task_id
?? TITLE := '  Global Variables' ??
?? EJECT ??
    CONST
        rfc$max_lock_retries = 50;

    TYPE
        rft$r1_buffer_management = RECORD
          lock: ost$signature_lock,
          entry_count: 0..rfc$max_r1_request_id,
          free_entries: 0..rfc$max_r1_request_id,
          first_free_entry: 0..rfc$max_r1_request_id,
          first_open_entry: 0..rfc$max_r1_request_id,
          buffer_list: ^ARRAY [1..*] OF rft$ring_1_buffer,
        RECEND,

        rft$ring_1_buffer = RECORD
          next_free_entry: 0..rfc$max_r1_request_id,
          next_open_entry: 0..rfc$max_r1_request_id,
          buffer: ^rft$request_response_buffer,
        RECEND;

    VAR
        rfv$request_buffers: [XDCL, oss$mainframe_pageable] rft$r1_buffer_management :=
          [[0], 0, 0, 0, 0, NIL];

    VAR
        clear_lockword: [READ] iot$lockword := [FALSE, 0, [FALSE, 0, 0]],
        set_lockword: [READ] iot$lockword := [TRUE, 0, [TRUE, FALSE, 0, 0]];
?? TITLE := '  RFP$POST_REQUEST' ??
?? EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$post_request(VAR request_info: ^SEQ(*);
                                VAR request_ids: rft$request_identifier;
                                VAR status: ost$status);

*copyc rfh$post_request

    VAR
        request_id: rft$request_identifier;

    status.normal := TRUE;

    {     Save ring 3 identification.

    request_id := request_ids;

    CASE  request_ids.ring_3_id.location.kind  OF
    = rfc$pp_request =

      rfp$post_pp_request(request_ids.ring_3_id.location.logical_pp, request_info, request_id, status);
      IF  status.normal  THEN

        {   Add ring 1 identification.

        request_ids := request_id;
      IFEND;

    = rfc$unit_request =

      rfp$post_unit_request(request_ids.ring_3_id.location.logical_unit, request_info, request_id, status);
      IF  status.normal  THEN

        {   Add ring 1 identification.

        request_ids := request_id;
      IFEND;

    ELSE

      {   This should never occur with normal CYBIL type checking

      osp$set_status_abnormal(rfc$product_id, rfe$unsupported_request_type, '', status);

    CASEND;
  PROCEND rfp$post_request;
?? NEWTITLE := '    RFP$POST_PP_REQUEST' ??
?? EJECT ??
  PROCEDURE rfp$post_pp_request(pp_number: iot$pp_number;
                            VAR request_info: ^SEQ(*);
                            VAR request_id: rft$request_identifier;
                            VAR status: ost$status);


{    The purpose of this request is to post a request for the specified peripheral
{    processor to perform.  A peripheral request is generated in the wired section and
{    the request is queued for the PP driver to process.
{
{    pp_number: (input) This parameter specifies the logical pp number of the corresponding
{      PP.  The request is queued in the pp interface table for this PP.
{
{    request_info: (input) This parameter specifies a pointer to an adaptable sequence which
{      contains the information that is required to generate the request.
{
{    request_id: (output) This parameter returns the identifier of the request that was posted.
{      This parameter is only meaningful if the status is normal.
{
{    status: (output) This parameter returns the results of the request.  A status of normal
{      means that the request was successfully posted.

    VAR
        command_buffer: ^ARRAY [rft$command_entry] OF rft$command,
        pp_interface_table: ^iot$pp_interface_table,
        request_buffer_ptr: ^rft$request_response_buffer,
        command_identifier: ^rft$pp_commands,
        command_entry: rft$command,
        command_flags: rft$function_flags;

    status.normal := TRUE;
    pp_interface_table :=  cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p;

    IF  pp_interface_table = NIL  THEN

      {  This should not happen.

      osp$set_status_abnormal(rfc$product_id, rfe$invalid_peripheral_element, 'PP', status);
      osp$append_status_integer(osc$status_parameter_delimiter, pp_number, 10, false, status);
      RETURN;
    IFEND;

    RESET  request_info;
    NEXT  command_identifier  IN  request_info;
    IF  command_identifier = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'the request buffer is empty',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$POST_PP_REQUEST', status);
      RETURN;
    IFEND;

    get_wired_request_buffer(request_buffer_ptr, request_id);
    IF  request_buffer_ptr = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'mainframe_wired', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$POST_PP_REQUEST', status);
      RETURN;
    IFEND;

    command_flags.store_response := TRUE;
    command_flags.indirect_address := FALSE;
    command_flags.pp_processing := FALSE;
    command_flags.pp_process_complete := FALSE;
    command_flags.flush_buffer := FALSE;

    command_buffer := #LOC(request_buffer_ptr^.command_buffer);

    CASE  command_identifier^  OF
    = ioc$cc_idle =

      command_entry.pp_flags := command_flags;
      command_entry.pp_function_code := rfc$pp_idle;
      command_buffer^[rfc$cbi_pp_request] := command_entry;
      request_buffer_ptr^.rhfam_request.request_length := request_buffer_ptr^.rhfam_request.request_length
        + #SIZE(rft$command);

    = ioc$cc_resume =

      command_entry.pp_flags := command_flags;
      command_entry.pp_function_code := rfc$pp_resume;
      command_buffer^[rfc$cbi_pp_request] := command_entry;
      request_buffer_ptr^.rhfam_request.request_length := request_buffer_ptr^.rhfam_request.request_length
        + #SIZE(rft$command);

    ELSE

      {  Sorry, but your request is not currently supported.

      osp$set_status_abnormal(rfc$product_id, rfe$invalid_request_command, '', status);
      osp$append_status_integer(osc$status_parameter_delimiter, command_identifier^, 16, TRUE, status);
    CASEND;

    IF  status.normal  THEN
      link_request_buffer(request_buffer_ptr, ^pp_interface_table^.lockword,
        ^pp_interface_table^.pp_request_queue, ^pp_interface_table^.pp_request_queue_rma);
    ELSE
      free_wired_request_buffer(request_id.ring_1_id.entry);
    IFEND;

  PROCEND rfp$post_pp_request;
?? TITLE := '    RFP$POST_UNIT_REQUEST' ??
?? EJECT ??
  PROCEDURE rfp$post_unit_request(unit_number: iot$logical_unit;
                              VAR request_info: ^SEQ(*);
                              VAR request_id: rft$request_identifier;
                              VAR status: ost$status);


{    The purpose of this request is to post a request in the specified unit interface table
{    for a PP to process.  A peripheral request is generated in the wired section and
{    the request is queued for the PP driver to process.
{
{    unit_number: (input) This parameter specifies the logical unit number of the corresponding
{      NAD.  The request is queued in the unit interface table for this NAD.
{
{    request_info: (input) This parameter specifies a pointer to an adaptable sequence which
{      contains the information that is required to generate the request.
{
{    request_id: (output) This parameter returns the identifier of the request that was posted.
{      This parameter is only meaningful if the status is normal.
{
{    status: (output) This parameter returns the results of the request.  A status of normal
{      means that the request was successfully posted.


    VAR
        error_string: STRING(35),
        unit_interface_table: ^iot$unit_interface_table,
        request_buffer_ptr: ^rft$request_response_buffer,
        command_entry: rft$command,
        command_identifier: ^rft$logical_commands,
        command_buffer: ^ARRAY [rft$command_entry] OF rft$command,
        path_id: ^rft$path_identifier,
        reject_code: ^rft$reject_code,
        physical_from: ^rft$physical_from,
        receive_conditions: ^rft$transfer_mode,
        rejected_control_message,
        asynchronous_request,
        remote_status_primed,
        unconditionally_status,
        abnormal_termination,
        maintenance_connection: ^BOOLEAN,
        control_message_size: ^rft$control_message_text,
        control_message: ^rft$nbp_control_message,
        out_connect_request,
        out_connect_request_buff: ^rft$nbp_outgoing_connect,
        in_connect_request,
        in_connect_request_buff: ^rft$nbp_incoming_connect,
        retry_count: ^rft$retry_count,
        alert_mask: rft$alert_conditions,
        rma: integer,
        ignore_status: ost$status,
        path_count: ^rft$path_identifier,
        command_flags: rft$function_flags;

    status.normal := TRUE;
    unit_interface_table :=  cmv$logical_unit_table^[unit_number].unit_interface_table;

    IF  unit_interface_table = NIL  THEN

      {  This should not happen.

      osp$set_status_abnormal(rfc$product_id, rfe$invalid_peripheral_element, 'UNIT', status);
      osp$append_status_integer(osc$status_parameter_delimiter, unit_number, 10, false, status);
      RETURN;
    IFEND;

    RESET  request_info;
    NEXT  command_identifier  IN  request_info;
    IF  command_identifier = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'the request buffer is empty',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$POST_UNIT_REQUEST', status);
      RETURN;
    IFEND;

    get_wired_request_buffer(request_buffer_ptr, request_id);
    IF  request_buffer_ptr = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'mainframe_wired', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$POST_UNIT_REQUEST', status);
      RETURN;
    IFEND;

    command_entry.lc_function_code := command_identifier^;
    command_flags.store_response := TRUE;
    command_flags.indirect_address := FALSE;
    command_flags.pp_processing := FALSE;
    command_flags.pp_process_complete := FALSE;
    command_flags.flush_buffer := TRUE;
    request_buffer_ptr^.rhfam_request.request_length := request_buffer_ptr^.rhfam_request.request_length
      + (rfc$cbi_unit_request_2 * #SIZE(rft$command));

    command_buffer := #LOC(request_buffer_ptr^.command_buffer);

  /create_request/
    BEGIN

      CASE  command_identifier^  OF
      = rfc$lc_request_connection =

        NEXT  maintenance_connection  IN  request_info;
        IF  maintenance_connection = NIL  THEN
          status.normal := FALSE;
          error_string := 'no type flag: REQUEST CONNECT';
          EXIT /create_request/;
        IFEND;
        command_flags.maintenance_connection := maintenance_connection^;
        command_entry.lc_flags := command_flags;
        NEXT  out_connect_request  IN  request_info;
        IF  out_connect_request = NIL  THEN
          status.normal := FALSE;
          error_string := 'no message: REQUEST CONNECT';
          EXIT /create_request/;
        IFEND;
        out_connect_request_buff := #LOC(command_buffer^[rfc$cbi_general_buffer]);
        out_connect_request_buff^ := out_connect_request^;
        i#real_memory_address(out_connect_request_buff, rma);
        command_entry.lc_rma := rma;
        command_entry.lc_length := #SIZE(rft$nbp_outgoing_connect);
        command_buffer^[rfc$cbi_unit_request_1] := command_entry;
        command_buffer^[rfc$cbi_unit_request_2].lc_path_id := 0;

      = rfc$lc_obtain_connect_request =

        command_entry.lc_flags := command_flags;
        NEXT  physical_from  IN  request_info;
        IF  physical_from = NIL  THEN
          status.normal := FALSE;
          error_string := 'no physical from: OBTAIN CONNECT';
          EXIT /create_request/;
        IFEND;
        NEXT  path_id  IN  request_info;
        IF  path_id = NIL  THEN
          status.normal := FALSE;
          error_string := 'no path ID: OBTAIN CONNECT';
          EXIT /create_request/;
        IFEND;
        i#real_memory_address(^command_buffer^[rfc$cbi_general_buffer], rma);
        command_entry.lc_rma := rma;
        command_entry.lc_length := #SIZE(rft$nbp_incoming_connect);
        command_buffer^[rfc$cbi_unit_request_1] := command_entry;
        command_buffer^[rfc$cbi_unit_request_2].cm_physical_from := physical_from^;
        command_buffer^[rfc$cbi_unit_request_2].cm_path_id := path_id^;

      = rfc$lc_accept_connect_request =

        command_entry.lc_flags := command_flags;
        NEXT  path_id  IN  request_info;
        IF  path_id = NIL  THEN
          status.normal := FALSE;
          error_string := 'no path ID: CONNECT ACCEPT';
          EXIT /create_request/;
        IFEND;
        command_buffer^[rfc$cbi_unit_request_1] := command_entry;
        command_buffer^[rfc$cbi_unit_request_2].lc_path_id := path_id^;

      = rfc$lc_reject_connect_request =

        command_entry.lc_flags := command_flags;
        NEXT  path_id  IN  request_info;
        IF  path_id = NIL  THEN
          status.normal := FALSE;
          error_string := 'no path ID: CONNECT REJECT';
          EXIT /create_request/;
        IFEND;
        NEXT  reject_code  IN  request_info;
        IF  reject_code = NIL  THEN
          status.normal := FALSE;
          error_string := 'no reject_code: CONNECT REJECT';
          EXIT /create_request/;
        IFEND;
        command_buffer^[rfc$cbi_unit_request_1] := command_entry;
        command_buffer^[rfc$cbi_unit_request_2].rc_reject_code := reject_code^;
        command_buffer^[rfc$cbi_unit_request_2].rc_path_id := path_id^;

      = rfc$lc_send_data =

        command_flags.pp_process_complete := TRUE;
        command_entry.lc_flags := command_flags;
        NEXT  asynchronous_request  IN  request_info;
        IF  asynchronous_request = NIL  THEN
          status.normal := FALSE;
          error_string := 'no async flag: SEND DATA';
          EXIT /create_request/;
        IFEND;
        request_buffer_ptr^.asynchronous_request := asynchronous_request^;
        NEXT  path_id  IN  request_info;
        IF  path_id = NIL  THEN
          status.normal := FALSE;
          error_string := 'no path ID: SEND DATA';
          EXIT /create_request/;
        IFEND;
        command_buffer^[rfc$cbi_unit_request_1] := command_entry;
        command_buffer^[rfc$cbi_unit_request_2].io_path_id := path_id^;
        command_buffer^[rfc$cbi_in_pointer].bp_offset := 0;
        command_buffer^[rfc$cbi_out_pointer].bp_offset := 0;
        request_buffer_ptr^.previous_out_ptr := rfc$cbi_first_io_entry;
        request_buffer_ptr^.rhfam_request.request_length := request_buffer_ptr^.rhfam_request.request_length
          + ((rfc$cbi_last_io_entry - rfc$cbi_unit_request_2) * #SIZE(rft$command));
        link_request_buffer(request_buffer_ptr, ^unit_interface_table^.unit_q_lockword,
          ^unit_interface_table^.next_request, ^unit_interface_table^.next_request_rma);
        rfp$continue_io_request(request_info, request_id, ioc$explicit_write, TRUE, status);
        IF  NOT status.normal  THEN
          delink_and_free_buffer(request_id.ring_1_id.entry, ^unit_interface_table^.unit_q_lockword,
            ^unit_interface_table^.next_request, ^unit_interface_table^.next_request_rma, ignore_status);
        IFEND;

        {  Once we get here we cannot continue with the end of block processing.

        RETURN;

      = rfc$lc_receive_data =

        NEXT  receive_conditions  IN  request_info;
        IF  receive_conditions = NIL  THEN
          status.normal := FALSE;
          error_string := 'missing transfer mode: RECEIVE DATA';
          EXIT /create_request/;
        IFEND;
        alert_mask.long_input_block := FALSE;
        alert_mask.pru_block_next := FALSE;
        alert_mask.non_pru_block_next := FALSE;
        alert_mask.end_of_message := FALSE;
        alert_mask.eor_mark_encountered := FALSE;
        alert_mask.eof_mark_encountered := FALSE;
        alert_mask.eoi_mark_encountered := FALSE;
        CASE  receive_conditions^.transfer_mode OF
        = rfc$tm_record_mode =
          alert_mask.non_pru_block_next := TRUE;
          CASE  receive_conditions^.termination_mark  OF
          = rfc$rm_eor =
            alert_mask.eor_mark_encountered := TRUE;
            alert_mask.eof_mark_encountered := TRUE;
            alert_mask.eoi_mark_encountered := TRUE;
          = rfc$rm_eof =
            alert_mask.eof_mark_encountered := TRUE;
            alert_mask.eoi_mark_encountered := TRUE;
          = rfc$rm_eoi =
            alert_mask.eoi_mark_encountered := TRUE;
          ELSE
            {  no additional flags.
          CASEND;
        = rfc$tm_message_mode =
          alert_mask.pru_block_next := TRUE;
          alert_mask.end_of_message := TRUE;
        ELSE
          {  no additional flags.
        CASEND;
        request_buffer_ptr^.rhfam_request.alert_mask := alert_mask;
        command_flags.pp_process_complete := TRUE;
        command_entry.lc_flags := command_flags;
        NEXT  asynchronous_request  IN  request_info;
        IF  asynchronous_request = NIL  THEN
          status.normal := FALSE;
          error_string := 'no async flag: RECEIVE DATA';
          EXIT /create_request/;
        IFEND;
        request_buffer_ptr^.asynchronous_request := asynchronous_request^;
        NEXT  path_id  IN  request_info;
        IF  path_id = NIL  THEN
          status.normal := FALSE;
          error_string := 'no path ID: RECEIVE DATA';
          EXIT /create_request/;
        IFEND;
        command_buffer^[rfc$cbi_unit_request_1] := command_entry;
        command_buffer^[rfc$cbi_unit_request_2].io_path_id := path_id^;
        command_buffer^[rfc$cbi_in_pointer].bp_offset := 0;
        command_buffer^[rfc$cbi_out_pointer].bp_offset := 0;
        request_buffer_ptr^.previous_out_ptr := rfc$cbi_first_io_entry;
        request_buffer_ptr^.rhfam_request.request_length := request_buffer_ptr^.rhfam_request.request_length
          + ((rfc$cbi_last_io_entry - rfc$cbi_unit_request_2) * #SIZE(rft$command));
        link_request_buffer(request_buffer_ptr, ^unit_interface_table^.unit_q_lockword,
          ^unit_interface_table^.next_request, ^unit_interface_table^.next_request_rma);
        rfp$continue_io_request(request_info, request_id, ioc$explicit_read, TRUE, status);
        IF  NOT status.normal  THEN
          delink_and_free_buffer(request_id.ring_1_id.entry, ^unit_interface_table^.unit_q_lockword,
            ^unit_interface_table^.next_request, ^unit_interface_table^.next_request_rma, ignore_status);
        IFEND;

        {  Once we get here we cannot continue with the end of block processing.

        RETURN;

      = rfc$lc_status_nad =

        NEXT  unconditionally_status  IN  request_info;
        IF  unconditionally_status = NIL  THEN
          status.normal := FALSE;
          error_string := 'no type flag: STATUS NAD';
          EXIT /create_request/;
        IFEND;
        command_flags.unconditionally_status := unconditionally_status^;
        command_entry.lc_flags := command_flags;
        NEXT  path_count  IN  request_info;
        IF  path_count = NIL  THEN
          status.normal := FALSE;
          error_string := 'no path count: STATUS NAD';
          EXIT /create_request/;
        IFEND;
        i#real_memory_address(^command_buffer^[rfc$cbi_general_buffer], rma);
        command_entry.lc_rma := rma;
        command_entry.lc_length := path_count^ * #SIZE(rft$nad_status_entry);
        command_buffer^[rfc$cbi_unit_request_1] := command_entry;

      = rfc$lc_send_control_message =

        command_entry.lc_flags := command_flags;
        NEXT  control_message_size IN  request_info;
        IF  control_message_size = NIL  THEN
          status.normal := FALSE;
          error_string := 'no text size: SEND CONTROL MESSAGE';
          EXIT /create_request/;
        IFEND;
        NEXT  control_message : [control_message_size^] IN  request_info;
        IF  control_message = NIL  THEN
          status.normal := FALSE;
          error_string := 'no message: SEND CONTROL MESSAGE';
          EXIT /create_request/;
        IFEND;
        i#move(control_message, #LOC(command_buffer^[rfc$cbi_general_buffer]), #SIZE(control_message^));
        i#real_memory_address(^command_buffer^[rfc$cbi_general_buffer], rma);
        command_entry.lc_rma := rma;
        command_entry.lc_length := #SIZE(control_message^);
        command_buffer^[rfc$cbi_unit_request_1] := command_entry;

      = rfc$lc_receive_control_message =

        NEXT  rejected_control_message IN  request_info;
        IF  rejected_control_message = NIL  THEN
          status.normal := FALSE;
          error_string := 'no type flag: RECEIVE CONTROL MESSAGE';
          EXIT /create_request/;
        IFEND;
        command_flags.rejected_control_message := rejected_control_message^;
        command_entry.lc_flags := command_flags;
        NEXT  physical_from  IN  request_info;
        IF  physical_from = NIL  THEN
          status.normal := FALSE;
          error_string := 'no physical from: RECEIVE CONTROL MESSAGE';
          EXIT /create_request/;
        IFEND;
        i#real_memory_address(^command_buffer^[rfc$cbi_general_buffer], rma);
        command_entry.lc_rma := rma;
        command_entry.lc_length := rfc$max_control_message_size;
        command_buffer^[rfc$cbi_unit_request_1] := command_entry;
        command_buffer^[rfc$cbi_unit_request_2].cm_physical_from := physical_from^;

      = rfc$lc_disconnect_paths =

        NEXT  abnormal_termination  IN  request_info;
        IF  abnormal_termination = NIL  THEN
          status.normal := FALSE;
          error_string := 'no type flag: DISCONNECT';
          EXIT /create_request/;
        IFEND;
        command_flags.abnormal_termination := abnormal_termination^;
        command_entry.lc_flags := command_flags;
        NEXT  path_id  IN  request_info;
        IF  path_id = NIL  THEN
          status.normal := FALSE;
          error_string := 'no path ID: DISCONNECT';
          EXIT /create_request/;
        IFEND;
        command_buffer^[rfc$cbi_unit_request_1] := command_entry;
        command_buffer^[rfc$cbi_unit_request_2].lc_path_id := path_id^;

      = rfc$lc_read_path_status_table =

        command_entry.lc_flags := command_flags;
        NEXT  path_id  IN  request_info;
        IF  path_id = NIL  THEN
          status.normal := FALSE;
          error_string := 'no path ID: PATH STATUS';
          EXIT /create_request/;
        IFEND;
        i#real_memory_address(^command_buffer^[rfc$cbi_general_buffer], rma);
        command_entry.lc_rma := rma;
        command_entry.lc_length := #SIZE(rft$path_status_table);
        command_buffer^[rfc$cbi_unit_request_1] := command_entry;
        command_buffer^[rfc$cbi_unit_request_2].lc_path_id := path_id^;

      = rfc$lc_obtain_nad_general_stat =

        NEXT  remote_status_primed  IN  request_info;
        IF  remote_status_primed = NIL  THEN
          status.normal := FALSE;
          error_string := 'no type flag: GENERAL STATUS';
          EXIT /create_request/;
        IFEND;
        command_flags.primed := remote_status_primed^;
        command_entry.lc_flags := command_flags;
        i#real_memory_address(^command_buffer^[rfc$cbi_general_buffer], rma);
        command_entry.lc_rma := rma;
        command_entry.lc_length := #SIZE(rft$nad_general_status);
        command_buffer^[rfc$cbi_unit_request_1] := command_entry;
        NEXT  retry_count  IN  request_info;
        IF  retry_count = NIL  THEN
          status.normal := FALSE;
          error_string := 'no retry count: GENERAL STATUS';
          EXIT /create_request/;
        IFEND;
        command_buffer^[rfc$cbi_unit_request_2].os_retry_count := retry_count^;
        NEXT  path_id  IN  request_info;
        IF  path_id = NIL  THEN
          status.normal := FALSE;
          error_string := 'no path ID: GENERAL STATUS';
          EXIT /create_request/;
        IFEND;
        command_buffer^[rfc$cbi_unit_request_2].os_path_id := path_id^;

      = rfc$lc_process_physical_command =

        command_entry.lc_flags := command_flags;
        command_buffer^[rfc$cbi_unit_request_1] := command_entry;
        add_physical_command_entries(request_info, request_buffer_ptr, error_string, status);

      ELSE

        {  Sorry, but your request is not currently supported.

        status.normal := FALSE;
        error_string := 'invalid unit request command';
      CASEND;

    END /create_request/;

    IF  status.normal  THEN
      link_request_buffer(request_buffer_ptr, ^unit_interface_table^.unit_q_lockword,
        ^unit_interface_table^.next_request, ^unit_interface_table^.next_request_rma);
    ELSE
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, error_string, status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$POST_UNIT_REQUEST', status);
      free_wired_request_buffer(request_id.ring_1_id.entry);
    IFEND;

  PROCEND rfp$post_unit_request;
??  NEWTITLE := '      ADD_PHYSICAL_COMMAND_ENTRIES' ??
??  EJECT ??
  PROCEDURE  add_physical_command_entries(VAR request_info: ^SEQ(*);
                                          VAR request_buffer: ^rft$request_response_buffer;
                                          VAR error_string: STRING(35);
                                          VAR status: ost$status);

{    The purpose of this routine is to generate the user specified physical command entries and add
{    them into the request buffer.
{
{    request_info: (input,output) This parameter points to the adaptable sequence which contains the
{      user's request.  The pointer currently points to the next entry following the initial
{      logical command identifier.  Upon exit this pointer points to the entry after the last
{      physical command.
{
{    request_buffer: (input,ouput) This parameter points to the request response buffer.  If status
{      is normal then the contents of this buffer contains all of the physical commands specified
{      by the caller.
{
{    error_string: (output) This parameter contains the status text string if status is not
{      normal.
{
{    status: (output) This paramter returns the results of the request.  A status of normal
{      means that the request is ready to be queued.

    VAR
        command_buffer: ^ARRAY [rft$command_entry] OF rft$command,
        function_code: ^rft$nad_function_codes,
        buffer_address: ^^cell,
        buffer_rma: integer,
        transfer_length: ^rft$transfer_length,
        nad_memory_addr,
        nad_memory_length: ^rft$transfer_lgth_addr,
        nad_status_mask,
        nad_status_value: ^rft$nad_status_flags,
        command_identifier: ^rft$physical_commands,
        command_entry: rft$command,
        current_command,
        last_command,
        index: rft$command_entry,
        number_of_commands: ^rft$command_entry;

    command_buffer := #LOC(request_buffer^.command_buffer);
    current_command := rfc$cbi_general_buffer;
    last_command := rfc$cbi_last_command_entry;
    status.normal := TRUE;

    NEXT  number_of_commands  IN  request_info;
    IF  (number_of_commands = NIL) OR
        (number_of_commands^ = 0) THEN
      status.normal := FALSE;
      error_string := 'the physical command list is empty';
      RETURN;
    IFEND;
    FOR  index := 1  TO  number_of_commands^  DO
      NEXT  command_identifier  IN  request_info;
      IF  command_identifier = NIL  THEN
        status.normal := FALSE;
        error_string := 'missing physical command entry';
        RETURN;
      IFEND;

      command_entry.pc_function_code := command_identifier^;

      CASE  command_identifier^  OF
      = rfc$pc_function_nad =
        NEXT  function_code  IN  request_info;
        IF  function_code = NIL  THEN
          status.normal := FALSE;
          error_string := 'missing function code';
          RETURN;
        IFEND;
        command_entry.fn_nad_function_code := function_code^;

      = rfc$pc_output_8_in_8_mode, rfc$pc_input_8_in_8_mode =

        NEXT  transfer_length  IN  request_info;
        IF  transfer_length = NIL  THEN
          status.normal := FALSE;
          error_string := 'missing transfer length';
          RETURN;
        IFEND;
        command_entry.pc_length := transfer_length^;
        NEXT  buffer_address  IN  request_info;
        IF  buffer_address = NIL  THEN
          status.normal := FALSE;
          error_string := 'missing buffer address';
          RETURN;
        IFEND;
        i#real_memory_address(buffer_address^, buffer_rma);
        command_entry.pc_rma := buffer_rma;

      = rfc$pc_set_addr_and_length =
        NEXT  nad_memory_addr  IN  request_info;
        IF  nad_memory_addr = NIL  THEN
          status.normal := FALSE;
          error_string := 'missing NAD memory address';
          RETURN;
        IFEND;
        command_entry.nm_addr := nad_memory_addr^;
        NEXT  nad_memory_length  IN  request_info;
        IF  nad_memory_length = NIL  THEN
          status.normal := FALSE;
          error_string := 'missing NAD memory length';
          RETURN;
        IFEND;
        command_entry.nm_length := nad_memory_length^;
        command_buffer^[last_command] := command_entry;
        i#real_memory_address(#LOC(command_buffer^[last_command]), buffer_rma);
        command_entry.pc_function_code := command_identifier^;
        command_entry.pc_length := #SIZE(rft$command);
        command_entry.pc_rma := buffer_rma;
        last_command := last_command - 1;

      = rfc$pc_microcode_status, rfc$pc_hardware_status =

        NEXT  nad_status_mask  IN  request_info;
        IF  nad_status_mask = NIL  THEN
          status.normal := FALSE;
          error_string := 'missing nad status mask';
          RETURN;
        IFEND;
        command_entry.st_mask := nad_status_mask^;
        NEXT  nad_status_value  IN  request_info;
        IF  nad_status_value = NIL  THEN
          status.normal := FALSE;
          error_string := 'missing nad status mask';
          RETURN;
        IFEND;
        command_entry.st_value := nad_status_value^;

      ELSE

        {  Sorry, but your request is not currently supported.

        status.normal := FALSE;
        error_string := 'invalid physical command id';
        RETURN;
      CASEND;
      IF  current_command > last_command  THEN
        status.normal := FALSE;
        error_string := 'request exceeds maximum buffer size';
        RETURN;
      IFEND;
      command_buffer^[current_command] := command_entry;
      request_buffer^.rhfam_request.request_length := request_buffer^.rhfam_request.request_length
        + #SIZE(rft$command);
      current_command := current_command + 1;

    FOREND;

  PROCEND add_physical_command_entries;
??  TITLE := '      RFP$CONTINUE_IO_REQUEST' ??
??  EJECT ??
  PROCEDURE  [XDCL, #GATE] rfp$continue_io_request(VAR request_info: ^SEQ(*);
                                                   request_id: rft$request_identifier;
                                                   io_type: iot$io_function;
                                                   restart_request: BOOLEAN;
                                               VAR status: ost$status);

*copyc rfh$continue_io_request

    VAR
        request_block: rft$rb_queue_data_fragments,
        command_buff: ^ARRAY [rft$command_entry] OF rft$command,
        buffer_rma: integer,
        header,
        command_entry: rft$command,
        block_length,
        fragment_length: integer,
        fragment_address: ^CELL,
        page_size: ost$page_size,
        touch_page: CELL,
        ring: ost$ring,
        segment: ost$segment,
        offset: ost$segment_offset,
        io_fragment: ^rft$io_fragment,
        sub_function_length: 0..rfc$command_buffer_size,
        request_buffer: ^rft$request_response_buffer,
        fragment,
        block,
        pva_index,
        header_index,
        old_buff_index,
        buffer_index: rft$command_entry,
        send_intermediate_response: ^BOOLEAN,
        pages_swapped,
        all_data_wired: BOOLEAN,
        identifier: 1..rfc$max_r1_request_id,
        error_string: STRING(35),
        task_id: ost$global_task_id,
        number_of_fragments,
        number_of_blocks: ^0..rfc$command_buffer_size;

??  NEWTITLE := '        CONTINUE_IO_CONDITION_HANDLER' ??
??  EJECT ??
    PROCEDURE continue_io_condition_handler (mf: ost$monitor_fault;
                                             p_msa: ^ost$minimum_save_area;
                                        VAR  continue:  syt$continue_option);
    VAR
      p_sac: ^mmt$segment_access_condition,
      ignore: ost$status;

    IF mf.identifier = mmc$segment_fault_processor_id THEN
      p_sac := #LOC(mf.contents);

      CASE p_sac^.identifier OF
      = mmc$sac_io_read_error =
        osp$set_status_abnormal (rfc$product_id, rfe$segment_access_error,
           'io error accessing file', status);
        EXIT rfp$continue_io_request
      ELSE
      CASEND;
    IFEND;

    syp$continue_to_cause (mf, p_msa, syc$condition_ignored, continue);

  PROCEND  continue_io_condition_handler;
?? OLDTITLE ??
?? EJECT ??
    identifier := request_id.ring_1_id.entry;
    request_buffer := rfv$request_buffers.buffer_list^[identifier].buffer;
    page_size := osv$page_size;
    command_buff := #LOC(request_buffer^.command_buffer);
    status.normal := TRUE;
    all_data_wired := TRUE;
    syp$establish_condition_handler (^continue_io_condition_handler);

  /main_section/
    BEGIN
      NEXT  send_intermediate_response  IN  request_info;
      IF  send_intermediate_response = NIL  THEN
        status.normal := FALSE;
        error_string := 'missing intermediate response flag';
        EXIT /main_section/;
      IFEND;
      IF  restart_request  THEN
        IF  NOT command_buff^[rfc$cbi_unit_request_1].lc_flags.pp_process_complete  THEN
          status.normal := FALSE;
          error_string := 'cannot restart active I/O request';
          EXIT /main_section/;
        IFEND;

        {  The previous IN pointer is reset here because the buffer must be empty
        {  whenever the complete flag is set and new requests are to be added.

        request_buffer^.previous_in_ptr := request_buffer^.previous_out_ptr;

        {  Can only change the command flags when restarting the request, otherwise
        {  a conflict could occur if the PP was updating the word at the same time.

        command_buff^[rfc$cbi_unit_request_1].lc_flags.send_intermediate_response :=
          send_intermediate_response^;
        IF  send_intermediate_response^  THEN
          command_buff^[rfc$cbi_unit_request_2].io_retry_count := 0;
          command_buff^[rfc$cbi_unit_request_2].io_previous_in_pointer :=
            command_buff^[rfc$cbi_out_pointer].bp_offset;  {  the out pointer is used to cause a
                                                           {  comparison match to force a PP response
          command_buff^[rfc$cbi_unit_request_2].io_in_pointer_change := 0;
        IFEND;
      IFEND;

      command_buff^[rfc$cbi_in_pointer].bp_more_data := send_intermediate_response^;

    /queue_request/
      REPEAT
        pages_swapped := FALSE;
        buffer_index := request_buffer^.previous_in_ptr;
        old_buff_index := request_buffer^.previous_out_ptr;
        pva_index := rfc$cbi_first_indirect_pva;

        NEXT  number_of_blocks  IN  request_info;
        IF  (number_of_blocks = NIL) OR
            (number_of_blocks^ = 0)  THEN
          status.normal := FALSE;
          error_string := 'no blocks to queue for I/O request';
          EXIT /main_section/;
        IFEND;
        FOR  block := 1  TO  number_of_blocks^  DO
          NEXT  number_of_fragments  IN  request_info;
          IF  (number_of_fragments = NIL) OR
              (number_of_fragments^ = 0)  THEN
            status.normal := FALSE;
            error_string := 'missing I/O fragment count';
            EXIT /main_section/;
          IFEND;

          header_index := buffer_index;
          buffer_index := buffer_index + 1;
          IF  buffer_index >= rfc$cbi_limit_pointer  THEN
            buffer_index := rfc$cbi_first_io_entry;
          IFEND;
          IF  buffer_index = old_buff_index  THEN
            status.normal := FALSE;
            error_string := 'attempt to overflow request buffer';
            EXIT /main_section/;
          IFEND;
          sub_function_length := #SIZE(rft$command);
          block_length := 0;

          FOR  fragment := 1 TO number_of_fragments^  DO

            NEXT  io_fragment  IN  request_info;
            IF  io_fragment = NIL  THEN
              status.normal := FALSE;
              error_string := 'missing I/O fragment';
              EXIT /main_section/;
            IFEND;

            IF  io_fragment^.wired  THEN
              i#real_memory_address(io_fragment^.address, buffer_rma);
              command_entry.wired := TRUE;
              command_entry.re_length := io_fragment^.length;
              command_entry.re_address := buffer_rma;
              command_buff^[buffer_index] := command_entry;
              buffer_index := buffer_index + 1;
              IF  buffer_index >= rfc$cbi_limit_pointer  THEN
                buffer_index := rfc$cbi_first_io_entry;
              IFEND;
              IF  buffer_index = old_buff_index  THEN
                status.normal := FALSE;
                error_string := 'attempt to overflow request buffer';
                EXIT /main_section/;
              IFEND;
              sub_function_length := sub_function_length + #SIZE(rft$command);
            ELSE
              command_entry.wired := FALSE;
              command_entry.pe_length := io_fragment^.length;
              fragment_length := io_fragment^.length;
              command_entry.pe_pva_index := pva_index;
              command_buff^[buffer_index] := command_entry;
              command_buff^[pva_index].pv_pva := io_fragment^.address;
              fragment_address := io_fragment^.address;
              pva_index := pva_index + 1;
              ring := #ring(fragment_address);
              segment := #segment(fragment_address);
              offset := #offset(fragment_address);
            /touch_pages/
              WHILE  TRUE  DO
                touch_page := fragment_address^;

                { reserve space for monitor to insert the RMA entry.

                buffer_index := buffer_index + 1;
                IF  buffer_index >= rfc$cbi_limit_pointer  THEN
                  buffer_index := rfc$cbi_first_io_entry;
                IFEND;
                IF  buffer_index = old_buff_index  THEN
                  status.normal := FALSE;
                  error_string := 'attempt to overflow request buffer';
                  EXIT /main_section/;
                IFEND;
                sub_function_length := sub_function_length + #SIZE(rft$command);
                fragment_length := fragment_length - (page_size - (offset MOD page_size));
                IF  fragment_length <= 0  THEN
                  EXIT /touch_pages/;
                IFEND;
                offset := ((offset DIV page_size) * page_size) + page_size;
                fragment_address := #address(ring, segment, offset);
              WHILEND /touch_pages/;
              all_data_wired := FALSE;
            IFEND;
            block_length := block_length + io_fragment^.length;
          FOREND;
          header.sf_transfer_length := 0;
          header.sf_buffer_length := block_length;
          header.sf_length := sub_function_length;
          command_buff^[header_index] := header;
        FOREND;

        IF  all_data_wired  THEN
          request_buffer^.previous_in_ptr := buffer_index;
          #SPOIL(request_buffer^.previous_in_ptr,command_buff^);
          command_buff^[rfc$cbi_in_pointer].bp_offset := (buffer_index - rfc$cbi_first_io_entry) * 8;
          IF  restart_request  THEN
            request_buffer^.response_posted := FALSE;
            #SPOIL(request_buffer^.response_posted,command_buff^);
            command_buff^[rfc$cbi_unit_request_1].lc_flags.pp_process_complete := FALSE;
          IFEND;
        ELSE
          request_block.clear_complete_flag := restart_request;
          request_block.io_type := io_type;
          request_block.reqcode := syc$rc_queue_rhfam_request;
          request_block.number_of_blocks := number_of_blocks^;
          request_block.request_buffer := request_buffer;
          i#call_monitor(#LOC(request_block), #SIZE(rft$rb_queue_data_fragments));
          IF  NOT request_block.status.normal  THEN
            IF  request_block.status.condition = mme$page_frame_not_assigned  THEN
              RESET  request_info  TO  number_of_blocks;
              pages_swapped := TRUE;
            ELSE
              status.normal := FALSE;
              error_string := 'monitor page lock failed';
            IFEND;
          IFEND;
        IFEND;
      UNTIL  NOT pages_swapped;    { /queue_request/ }
    END /main_section/;

    IF  NOT status.normal  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, error_string, status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$CONTINUE_IO_REQUEST', status);
    IFEND;

  PROCEND rfp$continue_io_request;
?? TITLE := '      GET_WIRED_REQUEST_BUFFER' ??
?? EJECT ??
  PROCEDURE  get_wired_request_buffer(VAR buffer_pointer: ^rft$request_response_buffer;
                                      VAR request_id: rft$request_identifier);

{    The purpose of this procedure is to reserve a request response buffer in the mainframe wired
{    section for issuing a peripheral request.
{
{    buffer_pointer: (output) This parameter returns a pointer to a buffer in the
{      mainframe wired heap.  A value of NIL means that no space is available.
{
{    request_id: (input, output) This parameter specifies the ring 3 identifier on entry.  On exit
{      this parameter contains the ring 1 and the ring 3 identifiers.

    VAR
        request_ptr: ^rft$peripheral_request,
        request_response_buffer : ^rft$request_response_buffer,
        buff_id: 0..rfc$max_r1_request_id,
        task_id: ost$global_task_id;


    lock_table(rfv$request_buffers.lock);
    IF  rfv$request_buffers.first_free_entry <> 0  THEN
      buff_id := rfv$request_buffers.first_free_entry;
      rfv$request_buffers.first_free_entry := rfv$request_buffers.buffer_list^[buff_id].next_free_entry;
      rfv$request_buffers.free_entries := rfv$request_buffers.free_entries - 1;
      request_response_buffer := rfv$request_buffers.buffer_list^[buff_id].buffer;
    ELSE
      unlock_table(rfv$request_buffers.lock);
      ALLOCATE  request_response_buffer  IN  osv$mainframe_wired_cb_heap^;
      IF  request_response_buffer = NIL  THEN
        buffer_pointer := NIL;
        RETURN;
      ELSE
        lock_table(rfv$request_buffers.lock);
        rfv$request_buffers.entry_count := rfv$request_buffers.entry_count + 1;
        buff_id := rfv$request_buffers.first_open_entry;
        rfv$request_buffers.first_open_entry := rfv$request_buffers.buffer_list^[buff_id].next_open_entry;
        rfv$request_buffers.buffer_list^[buff_id].buffer := request_response_buffer;
      IFEND;
    IFEND;
    unlock_table(rfv$request_buffers.lock);

    request_id.ring_1_id.entry := buff_id;
    request_id.ring_1_id.address := request_response_buffer;
    request_response_buffer^.io_request.response_processor_p := rfv$response_processor;
    pmp$get_executing_task_gtid(task_id);
    request_response_buffer^.task_id := task_id;
    request_response_buffer^.response_posted := FALSE;
    request_response_buffer^.request_id := request_id;
    request_response_buffer^.asynchronous_request := FALSE;
    request_ptr := ^request_response_buffer^.rhfam_request;
    request_response_buffer^.io_request.device_request_p := request_ptr;
    request_ptr^.request_buffer_ptr := request_response_buffer;
    request_ptr^.request_length := #SIZE(rft$peripheral_request);
    request_ptr^.recovery := ioc$terminate_at_error;
    request_ptr^.interrupt.value := TRUE;
    request_ptr^.interrupt.port_number := osv$external_interrupt_selector;
    request_ptr^.priority := 1;
    buffer_pointer := request_response_buffer;

  PROCEND get_wired_request_buffer;
?? TITLE := '      LINK_REQUEST_BUFFER' ??
?? EJECT ??
  PROCEDURE link_request_buffer(request_buffer: ^rft$request_response_buffer;
                                lockword: ^iot$lockword;
                                request_queue: ^^iot$io_request;
                                request_queue_rma: ^ost$real_memory_address);

{    The purpose of this routine is to link a peripheral request into the
{    specified request queue.
{
{    request_buffer: (input) This parameter specifies a pointer to the request that is to be
{      linked into the specified request queue.
{
{    lockword: (input) This parameter specifies a pointer to the lockword that must be set
{      prior to placing the request into the queue.
{
{    request_queue: (input) This parameter specifies a pointer to the request queue.
{
{    request_queue_rma: (input) This parameter specifies the RMA of the request queue pointer.

    VAR
        ignore_status: ost$status,
        cs_status: 0..2,
        actual_lockword: iot$lockword,
        io_request_ptr: ^iot$io_request,
        count,
        pp_request_rma: integer,
        rhfam_request: ^rft$peripheral_request;

    i#real_memory_address(^request_buffer^.rhfam_request, pp_request_rma);
    request_buffer^.rhfam_request.next_pp_request := NIL;
    request_buffer^.rhfam_request.next_pp_request_rma := 0;
    count := 0;

    osp$begin_system_activity;
    REPEAT
      #compare_swap(lockword^, clear_lockword, set_lockword, actual_lockword, cs_status);
      CASE cs_status OF
      = osc$cs_failed =
        count := count + 1;
        IF (actual_lockword.lock_owner.cpu_lock) OR (count > rfc$max_lock_retries) THEN
          osp$end_system_activity;
          syp$cycle;
          count := 0;
          osp$begin_system_activity;
        IFEND;
      ELSE
        ;
      CASEND;
    UNTIL  cs_status = osc$cs_successful;

    IF  request_queue^ = NIL  THEN
      request_queue^ := ^request_buffer^.io_request;
      request_queue_rma^ := pp_request_rma;
    ELSE
      io_request_ptr := request_queue^;
      REPEAT
        rhfam_request := io_request_ptr^.device_request_p;
        io_request_ptr := rhfam_request^.next_pp_request;
      UNTIL  io_request_ptr = NIL;

      rhfam_request^.next_pp_request := ^request_buffer^.io_request;
      rhfam_request^.next_pp_request_rma := pp_request_rma;
    IFEND;

    REPEAT
      #compare_swap(lockword^, set_lockword, clear_lockword, actual_lockword, cs_status);
    UNTIL  cs_status = osc$cs_successful;

    osp$end_system_activity;

  PROCEND link_request_buffer;
?? OLDTITLE ??
?? OLDTITLE ??
?? TITLE := '  RFP$DELINK_REQUEST' ??
?? EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$delink_request(VAR request_ids: rft$request_identifier;
                                             VAR status: ost$status);

*copyc rfh$delink_request

    VAR
        command_buffer: ^ARRAY [rft$command_entry] OF rft$command,
        unit_number: iot$logical_unit,
        unit_interface_table: ^iot$unit_interface_table;

    status.normal := TRUE;
    CASE  request_ids.ring_3_id.location.kind  OF
    = rfc$pp_request =

      free_wired_request_buffer(request_ids.ring_1_id.entry);

    = rfc$unit_request =

      unit_number := request_ids.ring_3_id.location.logical_unit;
      unit_interface_table :=  cmv$logical_unit_table^[unit_number].unit_interface_table;

      IF  unit_interface_table <> NIL  THEN
        command_buffer := #LOC(request_ids.ring_1_id.address^.command_buffer);
        IF  command_buffer^[rfc$cbi_unit_request_1].lc_function_code = rfc$lc_status_nad  THEN
          rfv$status_response_pending^[request_ids.ring_3_id.nad].in_host := FALSE;
        IFEND;
        delink_and_free_buffer(request_ids.ring_1_id.entry, ^unit_interface_table^.unit_q_lockword,
          ^unit_interface_table^.next_request, ^unit_interface_table^.next_request_rma, status);
      ELSE

        {  This should not happen.

        osp$set_status_abnormal(rfc$product_id, rfe$invalid_peripheral_element, 'UNIT', status);
        osp$append_status_integer(osc$status_parameter_delimiter, unit_number, 10, false, status);
      IFEND;

    ELSE

      {   This means there is a RING 1 TO RING 3 communication error.

      osp$set_status_abnormal(rfc$product_id, rfe$unsupported_request_type, '', status);

    CASEND;

    request_ids.ring_1_id.address := NIL;
    request_ids.ring_1_id.entry := rfc$max_r1_request_id;

  PROCEND rfp$delink_request;
?? NEWTITLE := '    DELINK_AND_FREE_BUFFER' ??
?? EJECT ??
  PROCEDURE delink_and_free_buffer(ring_1_entry: 1..rfc$max_r1_request_id;
                                   lockword: ^iot$lockword;
                                   request_queue: ^^iot$io_request;
                                   request_queue_rma: ^ost$real_memory_address;
                               VAR status: ost$status);

{    The purpose of this routine is to delink a peripheral request from the
{    specified request queue.
{
{    ring_1_entry: (input, output) This parameter specifies the request identifier of the request to
{      delink.
{
{    lockword: (input) This parameter specifies a pointer to the lockword that must be set
{      prior to removing the request from the queue.
{
{    request_queue: (input) This parameter specifies a pointer to the request queue.
{
{    request_queue_rma: (input) This parameter specifies the RMA of the request queue pointer.
{
{    status: (output) This parameter returns the results of the request.  A status of normal
{      means that the request buffer was successfully delinked.

    VAR
        request_ptr: ^rft$request_response_buffer,
        cs_status: 0..2,
        actual_lockword: iot$lockword,
        io_request_ptr: ^iot$io_request,
        count,
        pp_request_rma: integer,
        previous_request,
        rhfam_request: ^rft$peripheral_request;

    status.normal := TRUE;
    count := 0;

    osp$begin_system_activity;
    REPEAT
      #compare_swap(lockword^, clear_lockword, set_lockword, actual_lockword, cs_status);
      CASE cs_status OF
      = osc$cs_failed =
        count := count + 1;
        IF (actual_lockword.lock_owner.cpu_lock) OR (count > rfc$max_lock_retries) THEN
          osp$end_system_activity;
          syp$cycle;
          count := 0;
          osp$begin_system_activity;
        IFEND;
      ELSE
        ;
      CASEND;
    UNTIL  cs_status = osc$cs_successful;

    IF  request_queue^ = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'the request ID is invalid',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'DELINK_AND_FREE_BUFFER',
        status);
    ELSE
      rhfam_request := request_queue^^.device_request_p;
      IF  rhfam_request^.request_buffer_ptr^.request_id.ring_1_id.entry = ring_1_entry  THEN
        request_queue^ := rhfam_request^.next_pp_request;
        request_queue_rma^ := rhfam_request^.next_pp_request_rma;
      ELSE
        io_request_ptr := rhfam_request^.next_pp_request;
        WHILE   (io_request_ptr <> NIL)
            AND (rhfam_request^.request_buffer_ptr^.request_id.ring_1_id.entry <> ring_1_entry)  DO
          previous_request := rhfam_request;
          rhfam_request := io_request_ptr^.device_request_p;
          io_request_ptr := rhfam_request^.next_pp_request;
        WHILEND;
        IF  rhfam_request^.request_buffer_ptr^.request_id.ring_1_id.entry = ring_1_entry  THEN
          previous_request^.next_pp_request := rhfam_request^.next_pp_request;
          previous_request^.next_pp_request_rma := rhfam_request^.next_pp_request_rma;
        ELSE
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'the request ID is invalid',
            status);
          osp$append_status_parameter(osc$status_parameter_delimiter, 'DELINK_AND_FREE_BUFFER',
            status);
        IFEND;
      IFEND;
    IFEND;

    REPEAT
      #compare_swap(lockword^, set_lockword, clear_lockword, actual_lockword, cs_status);
    UNTIL  cs_status = osc$cs_successful;

    osp$end_system_activity;

    IF  status.normal  THEN
      free_wired_request_buffer(ring_1_entry);
    IFEND;

  PROCEND delink_and_free_buffer;
?? TITLE := '    FREE_WIRED_REQUEST_BUFFER' ??
?? EJECT ??
  PROCEDURE [INLINE] free_wired_request_buffer(buffer_id: 0..rfc$max_r1_request_id);

    lock_table(rfv$request_buffers.lock);
    IF  (buffer_id >= LOWERBOUND(rfv$request_buffers.buffer_list^))  AND
        (buffer_id <= UPPERBOUND(rfv$request_buffers.buffer_list^))  THEN
      rfv$request_buffers.buffer_list^[buffer_id].next_free_entry := rfv$request_buffers.first_free_entry;
      rfv$request_buffers.first_free_entry := buffer_id;
      rfv$request_buffers.free_entries := rfv$request_buffers.free_entries + 1;
    IFEND;
    unlock_table(rfv$request_buffers.lock);

  PROCEND;
?? OLDTITLE ??
?? TITLE := '  RFP$RE_ISSUE_REQUEST' ??
?? EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$re_issue_request(VAR request_ids: rft$request_identifier;
                                               VAR status: ost$status);

*copyc rfh$re_issue_request

    VAR
        pp_number: iot$pp_number,
        unit_number: iot$logical_unit,
        unit_interface_table: ^iot$unit_interface_table,
        pp_interface_table: ^iot$pp_interface_table;

    status.normal := TRUE;

    CASE  request_ids.ring_3_id.location.kind  OF
    = rfc$pp_request =

      pp_number := request_ids.ring_3_id.location.logical_pp;
      pp_interface_table :=  cmv$logical_pp_table_p^ [pp_number].pp_info.pp_interface_table_p;

      IF  pp_interface_table <> NIL  THEN
        clear_complete_flag(request_ids.ring_1_id.entry, ^pp_interface_table^.lockword,
          ^pp_interface_table^.pp_request_queue, status);
      ELSE

        {  This should not happen.

        osp$set_status_abnormal(rfc$product_id, rfe$invalid_peripheral_element, 'PP', status);
        osp$append_status_integer(osc$status_parameter_delimiter, pp_number, 10, false, status);
      IFEND;

    = rfc$unit_request =

      unit_number := request_ids.ring_3_id.location.logical_unit;
      unit_interface_table :=  cmv$logical_unit_table^[unit_number].unit_interface_table;

      IF  unit_interface_table <> NIL  THEN
        clear_complete_flag(request_ids.ring_1_id.entry, ^unit_interface_table^.unit_q_lockword,
          ^unit_interface_table^.next_request, status);
      ELSE

        {  This should not happen.

        osp$set_status_abnormal(rfc$product_id, rfe$invalid_peripheral_element, 'UNIT', status);
        osp$append_status_integer(osc$status_parameter_delimiter, unit_number, 10, false, status);
      IFEND;

    ELSE

      {   This means there is a RING 1 TO RING 3 communication error.

      osp$set_status_abnormal(rfc$product_id, rfe$unsupported_request_type, '', status);

    CASEND;

  PROCEND rfp$re_issue_request;
?? NEWTITLE := '    CLEAR_COMPLETE_FLAG' ??
?? EJECT ??
  PROCEDURE clear_complete_flag(ring_1_entry: 1..rfc$max_r1_request_id;
                                lockword: ^iot$lockword;
                                request_queue: ^^iot$io_request;
                            VAR status: ost$status);

{    The purpose of this routine is to clear the complete flag of a peripheral request to
{    have the PP program retry the request.
{
{    ring_1_entry: (input) This parameter specifies the request identifier of the request to
{      delink.
{
{    lockword: (input) This parameter specifies a pointer to the lockword that must be set
{      prior to clearing the complete flag.
{
{    request_queue: (input) This parameter specifies a pointer to the request queue.
{
{    status: (output) This parameter returns the results of the request.  A status of normal
{      means that the request buffer was successfully delinked.

    VAR
        command_buffer: ^ARRAY [rft$command_entry] OF rft$command,
        cs_status: 0..2,
        actual_lockword: iot$lockword,
        count: INTEGER,
        io_request_ptr: ^iot$io_request,
        rhfam_request: ^rft$peripheral_request;

    status.normal := TRUE;
    count := 0;

    osp$begin_system_activity;
    REPEAT
      #compare_swap(lockword^, clear_lockword, set_lockword, actual_lockword, cs_status);
      CASE cs_status OF
      = osc$cs_failed =
        count := count + 1;
        IF (actual_lockword.lock_owner.cpu_lock) OR (count > rfc$max_lock_retries) THEN
          osp$end_system_activity;
          syp$cycle;
          count := 0;
          osp$begin_system_activity;
        IFEND;
      ELSE
        ;
      CASEND;
    UNTIL  cs_status = osc$cs_successful;

    IF  request_queue^ <> NIL  THEN
      io_request_ptr := request_queue^;
      REPEAT
        rhfam_request := io_request_ptr^.device_request_p;
        io_request_ptr := rhfam_request^.next_pp_request;
      UNTIL  (io_request_ptr = NIL)
          OR (rhfam_request^.request_buffer_ptr^.request_id.ring_1_id.entry = ring_1_entry);
      IF  (rhfam_request^.request_buffer_ptr^.request_id.ring_1_id.entry = ring_1_entry)  THEN
        rhfam_request^.request_buffer_ptr^.response_posted := FALSE;
        command_buffer := #LOC(rhfam_request^.request_buffer_ptr^.command_buffer);
        IF  command_buffer^[rfc$cbi_unit_request_1].lc_function_code = rfc$lc_status_nad  THEN
          command_buffer^[rfc$cbi_unit_request_1].lc_flags.unconditionally_status := TRUE;
          rfv$status_response_pending^[rhfam_request^.request_buffer_ptr^.request_id.ring_3_id.nad].in_host
            := FALSE;
        IFEND;
        command_buffer^[rfc$cbi_unit_request_1].lc_flags.pp_process_complete := FALSE;
      ELSE
        osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'the request ID is invalid',
          status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'CLEAR_COMPLETE_FLAG',
          status);
      IFEND;
    ELSE
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'the request ID is invalid',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'CLEAR_COMPLETE_FLAG',
        status);
    IFEND;

    REPEAT
      #compare_swap(lockword^, set_lockword, clear_lockword, actual_lockword, cs_status);
    UNTIL  cs_status = osc$cs_successful;

    osp$end_system_activity;

  PROCEND clear_complete_flag;
?? OLDTITLE ??
?? TITLE := '  RFP$UNCONDITIONALLY_STATUS' ??
?? EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$unconditionally_status(unit_number: iot$logical_unit);

*copyc rfh$unconditionally_status

    VAR
        count: INTEGER,
        waiting_for_pp: BOOLEAN,
        request_queue: ^^iot$io_request,
        command_buffer: ^ARRAY [rft$command_entry] OF rft$command,
        cs_status: 0..2,
        lockword: ^iot$lockword,
        actual_lockword: iot$lockword,
        io_request_ptr: ^iot$io_request,
        rhfam_request: ^rft$peripheral_request,
        unit_interface_table: ^iot$unit_interface_table;

    unit_interface_table :=  cmv$logical_unit_table^[unit_number].unit_interface_table;
    IF  unit_interface_table = NIL  THEN
      RETURN;
    IFEND;
    lockword := ^unit_interface_table^.unit_q_lockword;
    request_queue :=  ^unit_interface_table^.next_request;
    REPEAT
      count := 0;
      waiting_for_pp := FALSE;
      osp$begin_system_activity;
      REPEAT
        #compare_swap(lockword^, clear_lockword, set_lockword, actual_lockword, cs_status);
        CASE cs_status OF
        = osc$cs_failed =
          count := count + 1;
          IF (actual_lockword.lock_owner.cpu_lock) OR (count > rfc$max_lock_retries) THEN
            osp$end_system_activity;
            syp$cycle;
            count := 0;
            osp$begin_system_activity;
          IFEND;
        ELSE
          ;
        CASEND;
      UNTIL  cs_status = osc$cs_successful;

      IF  request_queue^ <> NIL  THEN
        io_request_ptr := request_queue^;
        REPEAT
          rhfam_request := io_request_ptr^.device_request_p;
          command_buffer := #LOC(rhfam_request^.request_buffer_ptr^.command_buffer);
          io_request_ptr := rhfam_request^.next_pp_request;
        UNTIL  (io_request_ptr = NIL) OR
               (command_buffer^[rfc$cbi_unit_request_1].lc_function_code = rfc$lc_status_nad);
        IF  command_buffer^[rfc$cbi_unit_request_1].lc_function_code = rfc$lc_status_nad  THEN
          IF  NOT command_buffer^[rfc$cbi_unit_request_1].lc_flags.pp_process_complete  THEN
            IF  NOT command_buffer^[rfc$cbi_unit_request_1].lc_flags.pp_processing  THEN
              command_buffer^[rfc$cbi_unit_request_1].lc_flags.unconditionally_status := TRUE;
            ELSE
              waiting_for_pp := TRUE;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      REPEAT
        #compare_swap(lockword^, set_lockword, clear_lockword, actual_lockword, cs_status);
      UNTIL  cs_status = osc$cs_successful;

      osp$end_system_activity;

      IF  waiting_for_pp  THEN
        syp$cycle;
      IFEND;

    UNTIL  NOT waiting_for_pp;

  PROCEND rfp$unconditionally_status;
?? TITLE := '  RFP$SET_SYSTEM_TASK_ID' ??
?? EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$set_system_task_id(start_up: boolean);

*copyc rfh$set_system_task_id

    VAR
        task_id: ost$global_task_id;

    IF  start_up  THEN
      pmp$get_executing_task_gtid(task_id);
    ELSE
      task_id := tmv$null_global_task_id;
    IFEND;
    rfv$system_task_id := task_id;

  PROCEND rfp$set_system_task_id;
?? NEWTITLE := '    RFP$RELEASE_REQUEST_BUFFERS' ??
?? EJECT ??
  PROCEDURE [XDCL,#GATE]  rfp$release_request_buffers;

*copyc rfh$release_request_buffers

    VAR
        buffer_id: 0..rfc$max_r1_request_id,
        free_buffer: ^rft$request_response_buffer;


    {  No interlock is obtained here since the system task should not call this routine
    {  if there are any active pp requests.

    IF  rfv$request_buffers.buffer_list <> NIL  THEN
      FOR  buffer_id := LOWERBOUND(rfv$request_buffers.buffer_list^)  TO
                        UPPERBOUND(rfv$request_buffers.buffer_list^)  DO
        IF  rfv$request_buffers.buffer_list^[buffer_id].buffer <> NIL  THEN
          FREE  rfv$request_buffers.buffer_list^[buffer_id].buffer  IN osv$mainframe_wired_cb_heap^;
        IFEND;
      FOREND;
      FREE  rfv$request_buffers.buffer_list  IN  osv$mainframe_pageable_heap^;
    IFEND;
    IF  rfv$status_response_pending <> NIL  THEN
      FREE  rfv$status_response_pending  IN  osv$mainframe_wired_cb_heap^;
    IFEND;

  PROCEND rfp$release_request_buffers;
?? TITLE := '    RFP$RESERVE_REQUEST_BUFFERS' ??
?? EJECT ??
  PROCEDURE [XDCL,#GATE]  rfp$reserve_request_buffers(buffer_count: INTEGER;
                                                  VAR status: ost$status);

*copyc rfh$reserve_request_buffers

    VAR
        nad_index,
        local_nads: rft$local_nads,
        buffer_id,
        buff_id: 0..rfc$max_r1_request_id,
        buffer: ^rft$request_response_buffer;

    local_nads := buffer_count DIV rfc$max_concurrent_requests;
    ALLOCATE  rfv$status_response_pending : [1..local_nads]  IN  osv$mainframe_wired_cb_heap^;
    IF  rfv$status_response_pending = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'mainframe_wired', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$RESERVE_REQUEST_BUFFERS', status);
      RETURN;
    IFEND;
    FOR  nad_index := 1  TO  local_nads  DO
      rfv$status_response_pending^[nad_index].in_host := FALSE;
    FOREND;

    {  No interlock is obtained here because the system task calls this
    {  routine before initialization is complete.

    ALLOCATE  rfv$request_buffers.buffer_list : [1..buffer_count]  IN  osv$mainframe_pageable_heap^;
    IF  rfv$request_buffers.buffer_list <> NIL  THEN
      rfv$request_buffers.free_entries := 0;
      rfv$request_buffers.entry_count := 0;
      rfv$request_buffers.first_free_entry := 0;
      rfv$request_buffers.first_open_entry := LOWERBOUND(rfv$request_buffers.buffer_list^);
      FOR  buffer_id := LOWERBOUND(rfv$request_buffers.buffer_list^)  TO
                        UPPERBOUND(rfv$request_buffers.buffer_list^)  DO
        rfv$request_buffers.buffer_list^[buffer_id].buffer := NIL;
        rfv$request_buffers.buffer_list^[buffer_id].next_free_entry := 0;
        IF  buffer_id = UPPERBOUND(rfv$request_buffers.buffer_list^)  THEN
          rfv$request_buffers.buffer_list^[buffer_id].next_open_entry := 0;
        ELSE
          rfv$request_buffers.buffer_list^[buffer_id].next_open_entry := buffer_id + 1;
        IFEND;
      FOREND;

      {  Pre-allocate a few buffers for performance purposes.

      FOR  buffer_id := 1 TO 4  DO
        ALLOCATE buffer IN osv$mainframe_wired_cb_heap^;
        IF  buffer = NIL  THEN
          RETURN;
        IFEND;
        buff_id := rfv$request_buffers.first_open_entry;
        rfv$request_buffers.first_open_entry := rfv$request_buffers.buffer_list^[buff_id].next_open_entry;
        rfv$request_buffers.buffer_list^[buff_id].buffer := buffer;
        rfv$request_buffers.buffer_list^[buff_id].next_free_entry := rfv$request_buffers.first_free_entry;
        rfv$request_buffers.first_free_entry := buff_id;
        rfv$request_buffers.free_entries := rfv$request_buffers.free_entries + 1;
        rfv$request_buffers.entry_count := rfv$request_buffers.entry_count + 1;
      FOREND;
    ELSE
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'mainframe_paged', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$RESERVE_REQUEST_BUFFERS', status);
    IFEND;

  PROCEND rfp$reserve_request_buffers;
?? OLDTITLE ??
?? TITLE := '  RFP$CHANGE_NAD_STATUS' ??
?? EJECT ??
  PROCEDURE [XDCL, #GATE] rfp$change_nad_status(nad_unit: iot$logical_unit;
                                                nad_state: rft$element_state);

{    The purpose of this routine is to change the state of a nad.
{
{    nad_unit: (input) This parameter specifies the logical unit number of the corresponding
{      nad, whose status is to be changed.
{
{    nad_state: (input) This parameter specifies the state that the corresponding NAD should be
{      changed to.

    VAR
        count: INTEGER,
        nad_state_flags: ^rft$nad_state_flags,
        switch_state_ptr: ^cell,
        unit_status: iot$unit_status,
        unit_interface_table: ^iot$unit_interface_table,
        ignore_status: ost$status,
        cs_status: 0..2,
        lockword: ^iot$lockword,
        actual_lockword: iot$lockword;

    unit_interface_table :=  cmv$logical_unit_table^[nad_unit].unit_interface_table;

    IF  unit_interface_table = NIL  THEN

      {  This should not happen, ignore request }

      RETURN;
    IFEND;

    lockword := ^unit_interface_table^.unit_q_lockword;
    count := 0;

    osp$begin_system_activity;
    REPEAT
      #compare_swap(lockword^, clear_lockword, set_lockword, actual_lockword, cs_status);
      CASE cs_status OF
      = osc$cs_failed =
        count := count + 1;
        IF (actual_lockword.lock_owner.cpu_lock) OR (count > rfc$max_lock_retries) THEN
          osp$end_system_activity;
          syp$cycle;
          count := 0;
          osp$begin_system_activity;
        IFEND;
      ELSE
        ;
      CASEND;
    UNTIL  cs_status = osc$cs_successful;

    unit_status := unit_interface_table^.unit_status;
    switch_state_ptr := ^unit_status;
    nad_state_flags := switch_state_ptr;

    IF  nad_state = rfc$es_on  THEN
      nad_state_flags^.disabled := FALSE;
      nad_state_flags^.down := FALSE;
    ELSEIF nad_state = rfc$es_down  THEN
      nad_state_flags^.down := TRUE;
    ELSE
      nad_state_flags^.disabled := TRUE;
    IFEND;

    unit_interface_table^.unit_status := unit_status;

    REPEAT
      #compare_swap(lockword^, set_lockword, clear_lockword, actual_lockword, cs_status);
    UNTIL  cs_status = osc$cs_successful;

    osp$end_system_activity;

  PROCEND rfp$change_nad_status;
?? TITLE := '  lock_table', EJECT ??
  PROCEDURE  lock_table (VAR lock: ost$signature_lock);

{
{     The purpose of this procedure is to obtain the global lock on a
{     RHFAM ring 1 table.  This procedure increments the system table lock
{     count to prevent unnecessary swapping.
{
{     LOCK: (input,output)  This parameter specifies the signature lock to
{       obtain.
{


    osp$begin_system_activity;
    osp$set_job_signature_lock(lock);

  PROCEND lock_table;
?? TITLE := '  unlock_table ', EJECT ??
  PROCEDURE unlock_table (VAR lock: ost$signature_lock);

{
{     The purpose of this procedure is to release a global lock on a RHFAM
{     ring 1 table.  This procedure decrements the system buffer locked
{     count that was incremented when the table was locked.
{
{     LOCK: (input,output)  This parameter specifies the signature lock to
{       release.
{


    osp$clear_job_signature_lock(lock);
    osp$end_system_activity;

  PROCEND unlock_table;
MODEND rfm$request_processing_r1;

*DECK DECK=RFM$STATIC_DATA EXPAND=TRUE
*copyc osd$default_pragmats
MODULE rfm$static_data;
?? TITLE := 'RHFAM/VE : Static Data Definitions : R133' ??
?? NEWTITLE := '  Mainframe Global Variables' ??

*copyc rfh$static_data

?? EJECT ??
  VAR
      rfv$switched_connection_queue: [XDCL, #GATE, oss$network_paged]
          rft$switched_connection_queue := [[0], NIL];

  VAR
      rfv$rhfam_event_table : [XDCL, #GATE, oss$network_paged] rft$rhfam_event_table :=
          [[0], NIL];

  VAR
      rfv$rhfam_job_table : [XDCL, #GATE, oss$network_paged] rft$rhfam_job_table :=
          [[0], NIL, NIL];

  VAR
      rfv$rhfam_server_table : [XDCL, #GATE, oss$network_paged] rft$rhfam_server_table :=
          [[0], NIL];

  VAR
      rfv$rhfam_client_table : [XDCL, #GATE, oss$network_paged] rft$rhfam_client_table :=
          [[0], NIL];

  VAR
      rfv$status_table : [XDCL, #GATE, oss$network_paged] rft$status_table :=
          [[0],  NIL, NIL, NIL, NIL, NIL, FALSE, [0,0], [0,0]];

  VAR
      rfv$network_wired_buffers : [XDCL, #GATE, oss$network_paged] rft$network_wired_buffers :=
          [[0],  rfc$max_network_wired_buffers, 0];

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
*copyc rfc$r1_interface_defs
*copyc rft$switched_connection_queue
*copyc rft$configuration_defs
*copyc rft$rhfam_job_table
*copyc rft$rhfam_server_table
*copyc rft$rhfam_client_table
*copyc rft$rhfam_event_table
*copyc rft$r1_interface_defs
?? POP ??

MODEND rfm$static_data;

*DECK DECK=RFM$SYSTEM_TASK EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'RHFAM/VE : System Task : R23D' ??
?? NEWTITLE := '  Common Decks' ??
module rfm$system_task;
*copyc rft$configuration_defs
?? EJECT ??
*copyc amp$fetch_access_information
*copyc amp$get_segment_pointer
*copyc amp$return
*copyc clp$scan_parameter_list
*copyc cml$rhfam_usage_data
*copyc cmp$convert_channel_ordinal
*copyc cmp$convert_pp_ordinal
*copyc cmp$convert_iou_name
*copyc cmp$search_pp_table
*copyc cmp$execute_pp_program
*copyc cmp$reserve_element
*copyc cmp$release_element
*copyc cmp$get_element_definition
*copyc cmp$get_iou_definition
*copyc cmp$get_logical_unit_number
*copyc cmp$return_desc_data_by_lun_lpn
*copyc cmp$execute_pp_program
*copyc dpp$put_critical_message
*copyc fsp$open_file
*copyc fsp$close_file
*copyc jmv$executing_within_system_job
*copyc nav$network_paged_heap
*copyc nlp$bm_initialize_buffer_pools
*copyc nlv$bm_buffer_pool
*copyc nlc$bm_buffer_pool_index
*copyc osp$set_status_abnormal
*copyc osp$append_status_parameter
*copyc osp$append_status_integer
*copyc osp$establish_condition_handler
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$format_message
*copyc oss$job_paged_literal
*copyc osv$task_private_heap
*copyc pfp$attach
*copyc pfp$define
*copyc pfp$define_catalog
*copyc pfp$purge
*copyc pmp$generate_unique_name
*copyc pmp$get_executing_task_gtid
*copyc pmp$log
*copyc pmp$wait
*copyc pmp$get_microsecond_clock
*copyc pmp$ready_task
*copyc pmp$set_system_flag
*copyc pmp$zero_out_table
?? PUSH (LISTEXT := ON) ??
*copyc rfd$mc_initialization_prams
*copyc rfd$path_status_table
*copyc rfe$condition_codes
?? POP ??
*copyc rfp$change_nad_status
*copyc rfp$lock_table
*copyc rfp$move_data_to_wired_buffs
*copyc rfp$process_pp_response_flag
*copyc rfp$queue_request
*copyc rfp$reserve_wired_buffers
*copyc rfp$release_wired_buffers
*copyc rfp$reserve_request_buffers
*copyc rfp$release_request_buffers
*copyc rfp$set_system_task_id
*copyc rfp$start_server_job
*copyc rfp$unconditionally_status
*copyc rfp$unlock_table
*copyc rft$r1_interface_defs
*copyc rfv$network_wired_buffers
*copyc rfv$outstanding_requests
*copyc rfv$pp_interface_error
*copyc rfv$rhfam_server_table
*copyc rfv$rhfam_event_table
*copyc rfv$rhfam_client_table
*copyc rfv$system_task_id
*copyc rfv$status_table
*copyc sfp$emit_statistic
*copyc syp$cycle
*copyc tmv$null_global_task_id
?? TITLE := '  Global Variables' ??
?? EJECT ??
  VAR
      rfv$null_hardware_status: [STATIC,READ,oss$job_paged_literal] rft$nad_status_flags :=
        [rfc$sk_hardware_status,0,FALSE,FALSE,FALSE, FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE];

  VAR
      rfv$null_microcode_status: [STATIC,READ,oss$job_paged_literal] rft$nad_status_flags :=
        [rfc$sk_microcode_status,0,FALSE,FALSE, FALSE,FALSE,FALSE,FALSE,0];

  VAR
      rfv$initial_transfer_length: [STATIC,READ,oss$job_paged_literal] rft$transfer_lgth_addr := [0,0,0,0];

  VAR
      rfv$initial_transfer_address: [STATIC,READ,oss$job_paged_literal] rft$transfer_lgth_addr := [0,0,0,0];
?? TITLE := '  RFP$RHFAM_EVENT_PROCESSOR' ??
?? EJECT ??
  PROCEDURE  [XDCL, #GATE] rfp$rhfam_event_processor  (param_list: clt$parameter_list;
                                                  VAR  status: ost$status);

*copyc rfh$rhfam_event_processor
?? NEWTITLE := '    PROCESS_ABNORMAL_CONDITION' ??
?? EJECT ??
    PROCEDURE  process_abnormal_condition(condition: pmt$condition;
                                          condition_descriptor: ^pmt$condition_information;
                                          save_area: ^ost$stack_frame_save_area;
                                      VAR local_status: ost$status);

    {  The purpose of this procedure is to recognize a task termination condition and to
    {  attempt a graceful termination of the RHFAM/VE system task.
    {
    {  condition: (input) This parameter specifies the condition which caused the condition handler
    {    to be invoked.
    {
    {  condition_descriptor: (input) This parameter specifies a user defined condition.
    {
    {  stack_frame_save_area: (input) This parameter points to the stack frame save area of the
    {    routine that was executing at the time the trap occurred.
    {
    {  local_status: (output) This paramter specifies the current status.

      VAR
          critical_msg: string(40),
          ignore_status: ost$status,
          gtid: ost$global_task_id;

      local_status.normal := TRUE;
      CASE condition.selector OF
      = pmc$block_exit_processing =
        IF  status.normal  THEN
          osp$set_status_from_condition(rfc$product_id, condition, save_area, status, local_status);
          rfp$log_the_status (status);
        ELSE
          critical_msg(1,*) := 'RHFAM is not available.';
          dpp$put_critical_message(critical_msg,ignore_status);
        IFEND;

        pmp$get_executing_task_gtid(gtid);
        IF  gtid = rfv$system_task_id  THEN
          IF abnormal_exit THEN
            rfv$status_table.system_task_is_up := FALSE;
          ELSE
            termination_phase;
          IFEND;
        IFEND;
      = pmc$user_defined_condition =
        ;
      ELSE
        osp$set_status_from_condition(rfc$product_id, condition, save_area, status, local_status);
        rfp$log_the_status (status);
        abnormal_exit := TRUE;
        EXIT rfp$rhfam_event_processor;
      CASEND;

    PROCEND process_abnormal_condition;
?? OLDTITLE ??
?? EJECT ??
    CONST
         appl_startup_interval = 1*1000*1000,          { one second }
         reload_status_interval = 2*1000*1000,         { two seconds }
         nad_availability_interval = 30*1000*1000,     { thrity seconds }
         log_perf_stats_interval = 1*60*60*1000*1000;  { one hour }


    VAR
        reload_status_timer,
        appl_startup_timer,
        nad_availability_timer,
        log_perf_stats_timer,
        current_time: INTEGER,
        abnormal_exit,
        possible_connect_pending: BOOLEAN,
        ignore_status: ost$status;

    status.normal := TRUE;
    IF  NOT jmv$executing_within_system_job  THEN
      osp$set_status_condition ( rfe$invalid_task_origin,  status);
      rfp$log_the_status(status);
      RETURN;
    IFEND;

    abnormal_exit := FALSE;
    osp$establish_condition_handler (^process_abnormal_condition, TRUE);

    initialization_phase(status);
    IF NOT status.normal  THEN
      rfp$log_the_status(status);
      RETURN;
    IFEND;

    pmp$get_microsecond_clock(current_time, ignore_status);
    reload_status_timer := current_time;
    appl_startup_timer := current_time;
    nad_availability_timer := current_time;
    log_perf_stats_timer := current_time;
    possible_connect_pending := FALSE;

    {   The system task will execute forever or until one of the following conditions
    {   occurs:
    {
    {   1)  A catastrophic error is encountered in the local NAD statusing routine.
    {
    {   2)  The system task is terminated.  This shows up as a block exit condition.

 /main_section/
    REPEAT
      pmp$get_microsecond_clock(current_time, ignore_status);

      rfp$local_nad_statusing(current_time, possible_connect_pending, status);
      IF  NOT status.normal  THEN
        rfp$log_the_status(status);
        EXIT /main_section/;
      IFEND;

      IF  (current_time >= (appl_startup_timer + appl_startup_interval)) THEN
        appl_startup_timer := current_time;
        rfp$check_appl_startup(current_time);
      IFEND;

      IF  (current_time >= (reload_status_timer + reload_status_interval)) THEN
        reload_status_timer := current_time;
        rfp$auto_dump_and_reload(current_time);
      IFEND;

      IF  (current_time >= (nad_availability_timer + nad_availability_interval)) THEN
        nad_availability_timer := current_time;
        rfp$check_hardware_available(current_time);
      IFEND;

      IF  (current_time >= (log_perf_stats_timer + log_perf_stats_interval)) THEN
        log_perf_stats_timer := current_time;
        rfp$log_performance_statistics;
      IFEND;

      IF  possible_connect_pending  THEN
        syp$cycle;
      ELSE
        pmp$wait(5000, 100);
      IFEND;
      rfp$process_pp_response_flag(rfc$pp_response_available);

    UNTIL  FALSE;

  PROCEND rfp$rhfam_event_processor;
?? NEWTITLE := '    INITIALIZATION_PHASE' ??
?? EJECT ??
  PROCEDURE  initialization_phase(VAR status: ost$status);

{    This procedure performs the necessary actions to initialize the various RHFAM/VE
{    tables.  A description of the initialization phase activities is given in the
{    header information of this module.
{
{    status: (input) This procedure returns a status of NORMAL if all the initialization
{      activities have been successfully performed.

    VAR
       buffer_count: INTEGER;

    set_system_task_id(status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;

    activate_current_configuration(status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;

    reserve_configured_elements(status);
    IF  NOT status.normal  THEN
       RETURN;
    IFEND;

    buffer_count := (UPPERBOUND(rfv$status_table.local_nads^) - LOWERBOUND(rfv$status_table.local_nads^) + 1)
      * rfc$max_concurrent_requests;
    rfp$reserve_request_buffers(buffer_count, status);
    IF  NOT status.normal  THEN
       RETURN;
    IFEND;

    start_the_pps(status);
    IF  NOT status.normal  THEN
       RETURN;
    IFEND;

{   We must currently allocate the NAM/VE buffer pools if NAM/VE has
{   not already done so.  This code should be removed when we have
{   resolved the problem of NAM/VE not always being present.

    IF  nlv$bm_buffer_pool [nlc$bm_large_buffer_index].allocated_memory = NIL  THEN
      nlp$bm_initialize_buffer_pools(status);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
    IFEND;

    load_the_nads(status);
    IF  NOT status.normal  THEN
       RETURN;
    IFEND;

{   At this point we can let the rest of the world know that RHFAM/VE is now
{   ready for action.

    rfv$status_table.system_task_is_up := TRUE;

  PROCEND initialization_phase;
?? NEWTITLE := '      SET_SYSTEM_TASK_ID' ??
?? EJECT ??
  PROCEDURE  set_system_task_id(VAR status: ost$status);

{    The purpose of this procedure is to set the system task name in the
{    status table.  This is to prevent multiple system tasks from being
{    initiated.
{
{    status: (output) This parameter returns the results of the request.
{      A status of normal means that the system task can continue to run.

    VAR
        system_startup: [STATIC,READ, oss$job_paged_literal] BOOLEAN := TRUE;

    rfp$lock_table(rfv$status_table.lock);
    IF  rfv$system_task_id = tmv$null_global_task_id  THEN
      rfp$set_system_task_id(system_startup);
    ELSE
      osp$set_status_condition ( rfe$system_task_running,  status);
    IFEND;
    rfp$unlock_table(rfv$status_table.lock);

  PROCEND set_system_task_id;
?? TITLE := '      ACTIVATE_CURRENT_CONFIGURATION' ??
?? EJECT ??
  PROCEDURE  activate_current_configuration(VAR status: ost$status);

{    The purpose of this procedure is to activate the currently installed RHFAM/VE
{    configuration file.  This file is assumed to be highest cycle of
{    $SYSTEM.RHFAM.CONFIGURATION_FILE.  The following procedure is followed to
{    activate the configuration:
{
{         1)  Attach the configuration file and open it for segment access.
{
{         2)  Determine the size of the configuration file and allocate a corresponding
{             amount of space in the network paged heap.
{
{         3)  Move each of the definitions from the configuration file into the heap.
{
{    status: (output) This parameter returns the result of the request.  A normal status
{      means that the above activation procedure was successfully performed.

    VAR
        config_file_lfn: amt$local_file_name,
        config_file_id: amt$file_identifier,
        config_file_ptr: ^SEQ(*),
        current_status_table_ptr: ^SEQ(*),
        unique_name: ost$unique_name,
        ignore_status: ost$status;

    pmp$generate_unique_name(unique_name, ignore_status);
    config_file_lfn := unique_name.value;
    attach_and_validate_file(config_file_lfn, config_file_id, config_file_ptr, status);
    IF  status.normal  THEN
      allocate_status_table(config_file_id, current_status_table_ptr, status);
      IF  status.normal  THEN
        move_defs_to_status_table(config_file_ptr, current_status_table_ptr, status);
        IF  NOT status.normal  THEN
          FREE  rfv$status_table.location  IN  nav$network_paged_heap^;
        IFEND;
      IFEND;
      fsp$close_file(config_file_id, ignore_status);
      amp$return(config_file_lfn, ignore_status);
    IFEND;

  PROCEND activate_current_configuration;
?? NEWTITLE := '        ATTACH_AND_VALIDATE_FILE' ??
?? EJECT ??
  PROCEDURE  attach_and_validate_file(config_file_lfn: amt$local_file_name;
                                      VAR config_file_id: amt$file_identifier;
                                      VAR config_file_ptr: ^SEQ(*);
                                      VAR status: ost$status);

{    The purpose of this procedure is to attach the currently installed
{    RHFAM configuration file and open it for segment access.  This code
{    also checks the configuration file header to verify that the configuration
{    file integrity.
{
{    config_file_lfn: (input) This parameter specifies the local file name of
{      the configuration file.
{
{    config_file_id: (output) This parameter returns the file identifier of the
{      open configuration file.
{
{    config_file_ptr: (output) This parameter returns a pointer within the
{      configuration file to the first entry in the status table (i.e. the
{      first beyond the header).
{
{    status: (output) This parameter returns the results of the request.  A
{      status of normal means that the requested configuration file has been
{      successfully opened.


    VAR
        ignore_status: ost$status,
        segment_ptr: amt$segment_pointer,
        file_open: BOOLEAN,
        configuration_header: ^string(rfc$config_label_length),
        path: ^pft$path,
        password: pft$name,
        usage_selections: pft$usage_selections,
        share_selections: pft$share_selections,
        cycle_selector: pft$cycle_selector;

    PUSH path : [1..4];
    path^[1] := rfc$rhfam_family_name;
    path^[2] := rfc$rhfam_master_catalog;
    path^[3] := rfc$rhfam_sub_catalog;
    path^[4] := rfc$configuration_file;
    usage_selections := $pft$usage_selections[pfc$read];
    share_selections := $pft$share_selections[pfc$read,pfc$execute];
    cycle_selector.cycle_option := pfc$highest_cycle;
    password := rfc$password;
    pfp$attach(config_file_lfn, path^, cycle_selector, password, usage_selections, share_selections,
                    pfc$no_wait, status);
    IF  (NOT status.normal)  THEN
      RETURN;
    IFEND;
    file_open := FALSE;

  /main_section/
    BEGIN

      fsp$open_file(config_file_lfn, amc$segment, NIL, NIL, NIL, NIL, NIL,
        config_file_id, status);
      IF  NOT status.normal  THEN
        EXIT /main_section/;
      IFEND;
      file_open := TRUE;

      amp$get_segment_pointer(config_file_id, amc$sequence_pointer, segment_ptr, status);
      IF  NOT status.normal  THEN
        EXIT /main_section/;
      IFEND;
      RESET segment_ptr.sequence_pointer;
      NEXT configuration_header IN segment_ptr.sequence_pointer;
      IF  configuration_header = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$invalid_config_file, 'the file is empty', status);
        EXIT /main_section/;
      IFEND;

      IF  configuration_header^ <> rfc$configuration_label  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$invalid_config_file, 'the label is wrong', status);
      IFEND;

    END /main_section/;

    IF  status.normal  THEN
      config_file_ptr := segment_ptr.sequence_pointer;
    ELSE
      IF  file_open  THEN
        fsp$close_file(config_file_id, ignore_status);
      IFEND;
      amp$return(config_file_lfn, ignore_status);
    IFEND;

  PROCEND attach_and_validate_file;
?? NEWTITLE := '          ALLOCATE_STATUS_TABLE' ??
?? EJECT ??
  PROCEDURE  allocate_status_table(config_file_id: amt$file_identifier;
                               VAR current_status_table_ptr: ^SEQ(*);
                               VAR status: ost$status);

{    The purpose of this procedure is to allocate an appropriate amount of space in the network paged
{    section for the RHFAM/VE status table.
{
{    NOTE - The space calculation does not have to take into account the extra alignment
{           overhead because there is an extra word allocated between each group of entries.
{           This word contains the entry count, which is of type INTEGER.
{
{    config_file_id: (input) This parameter specifies the file identifier of the current configuration file.
{
{    current_status_table_ptr: (input,output) This paramter points to the SEQUENCE that has been allocated
{      for the status table.  This parameter is only meaningful if the status is normal.
{
{    status: (output) This parameter returns the results of the request.


    VAR
        access_information: ^amt$access_information,
        byte_size: integer,
        word_size: integer;


    PUSH access_information : [1..1];
    access_information^[1].key := amc$eoi_byte_address;
    amp$fetch_access_information(config_file_id, access_information^, status);
    byte_size := access_information^[1].eoi_byte_address;
    word_size := (byte_size + 7) DIV 8;
    ALLOCATE  rfv$status_table.location : [[REP word_size  OF  integer]]  IN  nav$network_paged_heap^;
    IF  rfv$status_table.location = NIL  THEN
      osp$set_status_condition ( rfe$configuration_too_big,  status);
      RETURN;
    IFEND;
    RESET rfv$status_table.location;
    current_status_table_ptr := rfv$status_table.location;

  PROCEND allocate_status_table;
?? OLDTITLE ??
?? TITLE := '        MOVE_DEFS_TO_STATUS_TABLE' ??
?? EJECT ??
  PROCEDURE  move_defs_to_status_table(VAR config_file_ptr: ^SEQ(*);
                                       VAR current_status_table_ptr: ^SEQ(*);
                                       VAR status: ost$status);

{    The purpose of this procedure is to move the configuration file definitions into
{    the status table.  This procedure also sets up the pointers to the various sub-tables
{    in the global status table (local_nad_table, remote_nad_table, local_host_table,
{    and the remote_host_table);
{
{    NOTE - no interlock is obtained while the status table is being created and the
{           RFV$STATUS_TABLE entries are updated.  This is because there is only one system task
{           running and no other tasks should access the table while the SYSTEM_TASK_IS_RUNNING flag
{           is FALSE.
{
{    config_file_ptr: (input,output) This variable points to the first entry in the configuration file
{      table.  (A RESET must be performed prior to calling this routine).
{
{    current_status_table_ptr: (input,output) This variable points to the first word address of the status
{      table sequence.  (A RESET must be performed prior to calling this routine).
{
{    status: (output) This parameter returns the results of the request.


    move_the_local_host_entry(config_file_ptr, current_status_table_ptr, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;

    move_the_remote_host_entries(config_file_ptr, current_status_table_ptr, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;

    move_the_local_nad_entries(config_file_ptr, current_status_table_ptr, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;

    move_the_remote_nad_entries(config_file_ptr, current_status_table_ptr, status);

  PROCEND move_defs_to_status_table;
?? NEWTITLE := '          ALIGN_SEQ_POINTER' ??
?? EJECT ??
  PROCEDURE [INLINE] align_seq_pointer(size_of_entry: INTEGER;
                                   VAR seq_pointer: ^SEQ(*));

{    The purpose of this routine is to word align the RHFAM status table sequence pointer
{    after each entry is moved into the sequence.  This is to insure that all ALIGNED
{    entries are maintained.
{
{    NOTE - This routine is covering for a CYBIL deficiency.
{
{    size_of_entry: (input) This parameter specifies the size of the entry moved into the
{      the status table.
{
{    seq_pointer: (input, output) This parameter specifies the current pointer to the RHFAM
{      status table sequence.


    VAR
        amount_to_align: 0..7,
        alignment_entry: ^STRING(*);

    amount_to_align := (8 - (size_of_entry MOD 8)) MOD 8;
    NEXT  alignment_entry : [amount_to_align] IN seq_pointer;

  PROCEND align_seq_pointer;
?? TITLE := '          MOVE_THE_LOCAL_HOST_ENTRY' ??
?? EJECT  ??
  PROCEDURE  move_the_local_host_entry(VAR config_file_ptr: ^SEQ(*);
                                       VAR current_status_table_ptr: ^SEQ(*);
                                       VAR status: ost$status);

{    The purpose of this procedure is to move the local host definition from the configuration
{    file into the status_table.
{
{    config_file_ptr: (input,output) Upon entry this variable specifies the pointer to the next
{      element in the configuration file.  Upon exit this parameter points to the element following
{      the local host definition.
{
{    current_status_table_ptr: (input,output) Upon entry this variable specifies the pointer to the next free
{      entry in the status table.  Upon exit this parameter points to the next free entry beyond the
{      local host definition.
{
{    status: (output) This parameter returns the results of the request.  If the returned status is
{      not NORMAL, then all other return parameters are undefined.

    VAR
        lid_count,
        path_count: ^integer,
        path_entry_1,
        path_entry_2: ^rft$lcn_paths,
        local_host_entry_1,
        local_host_entry_2: ^rft$local_host_definition;

    status.normal := TRUE;

    NEXT  lid_count  IN  config_file_ptr;
    IF  lid_count = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$required_def_missing, 'local host', status);
      RETURN;
    IFEND;
    NEXT  local_host_entry_1 : [1..lid_count^]  IN  config_file_ptr;
    IF  local_host_entry_1 = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$required_def_missing, 'local host', status);
      RETURN;
    IFEND;
    NEXT  local_host_entry_2 : [1..lid_count^]  IN  current_status_table_ptr;
    IF  local_host_entry_2 = NIL  THEN
      osp$set_status_condition ( rfe$configuration_too_big,  status);
      RETURN;
    IFEND;
    align_seq_pointer(#SIZE(local_host_entry_2^), current_status_table_ptr);
    local_host_entry_2^ := local_host_entry_1^;
    rfv$status_table.local_host := local_host_entry_2;
    NEXT  path_count  IN  config_file_ptr;
    IF  path_count = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$invalid_config_file,
        'the local host path count is missing', status);
      RETURN;
    IFEND;
    IF  path_count^ <> 0  THEN
      NEXT  path_entry_1 : [1..path_count^]  IN  config_file_ptr;
      IF  path_entry_1 = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$invalid_config_file,
          'the local host path count is invalid', status);
        RETURN;
      IFEND;
      NEXT  path_entry_2 : [1..path_count^]  IN  current_status_table_ptr;
      IF  path_entry_2 = NIL  THEN
        osp$set_status_condition ( rfe$configuration_too_big,  status);
        RETURN;
      IFEND;
      align_seq_pointer(#SIZE(path_entry_2^), current_status_table_ptr);
      path_entry_2^ := path_entry_1^;
      rfv$status_table.local_host^.associated_paths := path_entry_2;
    ELSE
      rfv$status_table.local_host^.associated_paths := NIL;
    IFEND;

  PROCEND move_the_local_host_entry;
?? TITLE := '          MOVE_THE_REMOTE_HOST_ENTRIES' ??
?? EJECT  ??
  PROCEDURE  move_the_remote_host_entries(VAR config_file_ptr: ^SEQ(*);
                                          VAR current_status_table_ptr: ^SEQ(*);
                                          VAR status: ost$status);

{    The purpose of this procedure is to move the remote host definitions from the configuration
{    file into the status_table.
{
{    config_file_ptr: (input,output) Upon entry this variable specifies the pointer to the next
{      element in the configuration file.  Upon exit this variable points to the element following
{      the last remote host definition.
{
{    current_status_table_ptr: (input,output) Upon entry this variable specifies the pointer to the next free
{      entry in the status table.  Upon exit this variable points to the next free entry beyond the
{      last remote host definition.
{
{    status: (output) This parameter returns the results of the request.  If the returned status is
{      not NORMAL, then all other return parameters are undefined.

    VAR
        index: integer,
        remote_host_count,
        lid_count,
        path_count: ^integer,
        path_entry_1,
        path_entry_2: ^rft$lcn_paths,
        first_entry: boolean,
        previous_remote_host,
        remote_host_entry_1,
        remote_host_entry_2: ^rft$remote_host_definition;

    status.normal := TRUE;

    NEXT  remote_host_count  IN  config_file_ptr;
    IF  (remote_host_count = NIL)  OR  (remote_host_count^ = 0) THEN
      rfv$status_table.remote_hosts := NIL;
      RETURN;
    IFEND;
    first_entry := TRUE;
    FOR  index := 1  TO  remote_host_count^  DO
      NEXT  lid_count  IN  config_file_ptr;
      IF  lid_count = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$invalid_config_file, 'the remote host count is missing',
          status);
        RETURN;
      IFEND;
      NEXT  remote_host_entry_1 : [1..lid_count^]  IN  config_file_ptr;
      IF  remote_host_entry_1 = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$invalid_config_file, 'the remote host count is invalid',
          status);
        RETURN;
      IFEND;
      NEXT  remote_host_entry_2 : [1..lid_count^]  IN  current_status_table_ptr;
      IF  remote_host_entry_2 = NIL  THEN
        osp$set_status_condition ( rfe$configuration_too_big,  status);
        RETURN;
      IFEND;
      align_seq_pointer(#SIZE(remote_host_entry_2^), current_status_table_ptr);
      remote_host_entry_2^ := remote_host_entry_1^;
      remote_host_entry_2^.next_entry := NIL;
      IF  first_entry  THEN
        rfv$status_table.remote_hosts := remote_host_entry_2;
        first_entry := FALSE;
        previous_remote_host := remote_host_entry_2;
      ELSE
        previous_remote_host^.next_entry := remote_host_entry_2;
        previous_remote_host := remote_host_entry_2;
      IFEND;
      NEXT  path_count  IN  config_file_ptr;
      IF  path_count = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$invalid_config_file,
          'a remote host path count is missing', status);
        RETURN;
      IFEND;
      IF  path_count^ <> 0  THEN
        NEXT  path_entry_1 : [1..path_count^]  IN  config_file_ptr;
        IF  path_entry_1 = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$invalid_config_file,
            'a remote host path count is invalid', status);
          RETURN;
        IFEND;
        NEXT  path_entry_2 : [1..path_count^]  IN  current_status_table_ptr;
        IF  path_entry_2 = NIL  THEN
          osp$set_status_condition ( rfe$configuration_too_big,  status);
          RETURN;
        IFEND;
        align_seq_pointer(#SIZE(path_entry_2^), current_status_table_ptr);
        path_entry_2^ := path_entry_1^;
        remote_host_entry_2^.associated_paths := path_entry_2;
      ELSE
        remote_host_entry_2^.associated_paths := NIL;
      IFEND;
    FOREND;

  PROCEND move_the_remote_host_entries;
?? TITLE := '          MOVE_THE_LOCAL_NAD_ENTRIES' ??
?? EJECT  ??
  PROCEDURE  move_the_local_nad_entries(VAR config_file_ptr: ^SEQ(*);
                                        VAR current_status_table_ptr: ^SEQ(*);
                                        VAR status: ost$status);


{    The purpose of this procedure is to move the local nad definitions from the configuration
{    file into the status_table.
{
{    config_file_ptr: (input,output) Upon entry this variable specifies the pointer to the next
{      element in the configuration file.  Upon exit this variable points to the element following
{      the last local nad definition.
{
{    current_status_table_ptr: (input,output) Upon entry this variable specifies the pointer to the next free
{      entry in the status table.  Upon exit this variable points to the next free entry beyond the
{      last local_nad definition.
{
{    status: (output) This parameter returns the results of the request.  If the returned status is
{      not NORMAL, then all other return parameters are undefined.


    VAR
        nad_index: rft$local_nads,
        connection_table: ^rft$connections,
        nad_count: ^integer,
        nad_table_1,
        nad_table_2: ^rft$local_nad_table;

    status.normal := TRUE;

    NEXT  nad_count  IN  config_file_ptr;
    IF  (nad_count = NIL)  OR  (nad_count^ = 0)  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$required_def_missing, 'local NAD', status);
      RETURN;
    IFEND;
    NEXT  nad_table_1 : [1..nad_count^]  IN  config_file_ptr;
    IF  nad_table_1 = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$required_def_missing, 'local NAD', status);
      RETURN;
    IFEND;
    NEXT  nad_table_2 : [1..nad_count^]  IN  current_status_table_ptr;
    IF  nad_table_2 = NIL  THEN
      osp$set_status_condition ( rfe$configuration_too_big,  status);
      RETURN;
    IFEND;
    align_seq_pointer(#SIZE(nad_table_2^), current_status_table_ptr);
    nad_table_2^ := nad_table_1^;
    rfv$status_table.local_nads := nad_table_2;
    FOR  nad_index := 1  TO  nad_count^  DO
      ALLOCATE connection_table : [0..rfc$max_connections] IN nav$network_paged_heap^;
      IF  connection_table = NIL  THEN
        osp$set_status_condition ( rfe$configuration_too_big,  status);
        RETURN;
      IFEND;
      pmp$zero_out_table(connection_table, #SIZE(connection_table^));
      rfv$status_table.local_nads^[nad_index].connection_table := connection_table;
    FOREND;

  PROCEND move_the_local_nad_entries;
?? TITLE := '          MOVE_THE_REMOTE_NAD_ENTRIES' ??
?? EJECT  ??
  PROCEDURE  move_the_remote_nad_entries(VAR config_file_ptr: ^SEQ(*);
                                         VAR current_status_table_ptr: ^SEQ(*);
                                         VAR status: ost$status);

{    The purpose of this procedure is to move the remote nad definitions from the configuration
{    file into the status_table.
{
{    config_file_ptr: (input,output) Upon entry this variable specifies the pointer to the next
{      element in the configuration file.  Upon exit this variable points to the element following
{      the last remote nad definition.
{
{    current_status_table_ptr: (input,output) Upon entry this variable specifies the pointer to the next free
{      entry in the status table.  Upon exit this variable points to the next free entry beyond the
{      last remote_nad definition.
{
{    status: (output) This parameter returns the results of the request.  If the returned status is
{      not NORMAL, then all other return parameters are undefined.

    VAR
        nad_count: ^integer,
        nad_table_1,
        nad_table_2: ^rft$remote_nad_table;

    status.normal := TRUE;

    NEXT  nad_count  IN  config_file_ptr;
    IF  (nad_count = NIL)  OR  (nad_count^ = 0)  THEN
      rfv$status_table.remote_nads := NIL;
      RETURN;
    IFEND;
    NEXT  nad_table_1 : [1..nad_count^]  IN  config_file_ptr;
    IF  nad_table_1 = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$invalid_config_file, 'the remote NAD count is missing',
        status);
      RETURN;
    IFEND;
    NEXT  nad_table_2 : [1..nad_count^]  IN  current_status_table_ptr;
    IF  nad_table_2 = NIL  THEN
      osp$set_status_condition ( rfe$configuration_too_big,  status);
      RETURN;
    IFEND;
    align_seq_pointer(#SIZE(nad_table_2^), current_status_table_ptr);
    nad_table_2^ := nad_table_1^;
    rfv$status_table.remote_nads := nad_table_2;

  PROCEND move_the_remote_nad_entries;
?? OLDTITLE ??
?? OLDTITLE ??
?? TITLE := '      RESERVE_CONFIGURED_ELEMENTS' ??
?? EJECT ??
  PROCEDURE  reserve_configured_elements(VAR status: ost$status);

{    The purpose of this procedure is to reserve the channel and peripheral processor
{    elements.
{
{    status: (output) This parameter returns the results of the request.  A status of normal
{      means that there were no fatal errors while attempting to reserve the required elements.

    VAR
        nad_descriptor,
        chan_descriptor: cmt$element_descriptor,
        logical_pp_number : iot$pp_number,
        found : boolean,
        concurrent : boolean,
        physical_pp : dst$iou_resource,
        nad_definition,
        chan_definition: cmt$element_definition,
        iou_definition: cmt$iou_definition,
        iou_name: cmt$element_name,
        program_description: ARRAY [1..1] OF cmt$pp_program_description,
        element_access: ARRAY [1..1] OF cmt$hardware_address,
        nad_entry,
        local_nad_count: rft$local_nads,
        pp_entry: 1..2,
        elements: ^ARRAY [*] OF cmt$element_reservation,
        ignore_status: ost$status,
        error_string: STRING(57),
        element_count,
        current_element: INTEGER,
        pp_interface_table: ^iot$pp_interface_table,
        channel_name : cmt$element_name,
        channel_number : ost$physical_channel_number,
        channel_port : cmt$channel_port,
        channel: cmt$channel_ordinal;

    element_count := 0;
    local_nad_count := UPPERBOUND(rfv$status_table.local_nads^);
    FOR  nad_entry := 1  TO  local_nad_count  DO
      element_count := element_count + 2 + rfv$status_table.local_nads^[nad_entry].pp_drivers;
    FOREND;

    PUSH  elements : [1..element_count];
    current_element := 1;
    nad_descriptor.element_type := cmc$communications_element;
    nad_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
    chan_descriptor.element_type := cmc$data_channel_element;
    chan_descriptor.channel_descriptor.use_logical_identification := TRUE;
    FOR  nad_entry := 1  TO  local_nad_count  DO
      nad_descriptor.peripheral_descriptor.element_name :=
        rfv$status_table.local_nads^[nad_entry].name;
      cmp$get_element_definition(nad_descriptor, nad_definition, status);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
      chan_descriptor.channel_descriptor.name :=
        nad_definition.communications_element.connection.port[0].element_name;
      chan_descriptor.channel_descriptor.iou :=
        nad_definition.communications_element.connection.port[0].iou;
      cmp$get_element_definition(chan_descriptor, chan_definition, status);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
      channel := chan_definition.data_channel.ordinal;
      cmp$convert_channel_ordinal(channel, channel_name, channel_number,
                  concurrent, channel_port, status);
      iou_name := chan_definition.data_channel.iou;
      rfv$status_table.local_nads^[nad_entry].channel_ordinal := channel;
      rfv$status_table.local_nads^[nad_entry].channel_number := channel_number;
      rfv$status_table.local_nads^[nad_entry].concurrent_channel := concurrent;
      elements^[current_element].element_type := cmc$data_channel_element;
      elements^[current_element].channel_descriptor := chan_descriptor.channel_descriptor;
      current_element := current_element + 1;
      elements^[current_element].element_type := cmc$communications_element;
      elements^[current_element].peripheral_descriptor := nad_descriptor.peripheral_descriptor;
      current_element := current_element + 1;
      FOR  pp_entry := 1  TO  rfv$status_table.local_nads^[nad_entry].pp_drivers  DO
        elements^[current_element].element_type := cmc$pp_element;
        elements^[current_element].pp_reservation.selector := cmc$choose_pp_by_channel;
        elements^[current_element].pp_reservation.channel.iou := iou_name;
        elements^[current_element].pp_reservation.channel.ordinal := channel;
        current_element := current_element + 1;
      FOREND;
    FOREND;

    cmp$reserve_element(elements^, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;

    current_element := 1;
    FOR  nad_entry := 1  TO  local_nad_count  DO
      current_element := current_element + 2;
      FOR  pp_entry := 1  TO  rfv$status_table.local_nads^[nad_entry].pp_drivers  DO
        rfv$status_table.local_nads^[nad_entry].pp[pp_entry].pp_state := rfc$pps_reserved;
        rfv$status_table.local_nads^[nad_entry].pp[pp_entry].pp_id :=
          elements^[current_element].pp_reservation.acquired_pp_identification;
        current_element := current_element + 1;
      FOREND;
    FOREND;

    cmp$get_iou_definition (iou_name, iou_definition, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;
    IF iou_definition.kind = dsc$imn_i0_5x_model THEN
      program_description[1].iou_program_name := 'NDI0';
    ELSE
      program_description[1].iou_program_name := 'NPDR';
    IFEND;
    program_description[1].master_pp := TRUE;
    program_description[1].pp_program := NIL;
    program_description[1].communication_buffer_length := osc$min_page_size;
    program_description[1].element_access := ^element_access;
    element_access[1].physical_address_specifier := $cmt$physical_address_specifier
       [cmc$iou, cmc$channel, cmc$channel_address];
    element_access[1].channel_address := 0;
    FOR  nad_entry := 1  TO  local_nad_count  DO
      FOR  pp_entry := 1  TO  rfv$status_table.local_nads^[nad_entry].pp_drivers  DO
        program_description[1].pp_identification :=
          rfv$status_table.local_nads^[nad_entry].pp[pp_entry].pp_id;
        element_access[1].iou := rfv$status_table.local_nads^[nad_entry].pp[pp_entry].pp_id.iou;
        element_access[1].channel.ordinal := rfv$status_table.local_nads^[nad_entry].channel_ordinal;
        element_access[1].channel.iou := rfv$status_table.local_nads^[nad_entry].pp[pp_entry].pp_id.iou;
        cmp$execute_pp_program(program_description, status);
        IF  NOT status.normal  THEN
          RETURN;
        IFEND;
        cmp$convert_pp_ordinal (program_description[1].pp_identification.ordinal, physical_pp);
        cmp$convert_iou_name (program_description[1].pp_identification.iou, physical_pp.iou_number, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        cmp$search_pp_table (physical_pp, logical_pp_number, found, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF NOT found THEN
          osp$set_status_condition ( rfe$pp_number_not_found,
               status);
          RETURN;
        IFEND;
        rfv$status_table.local_nads^[nad_entry].pp[pp_entry].pp_number :=
               logical_pp_number;
        rfv$status_table.local_nads^[nad_entry].pp[pp_entry].pp_state := rfc$pps_idle;
      FOREND;
      cmp$get_logical_unit_number(rfv$status_table.local_nads^[nad_entry].name,
        rfv$status_table.local_nads^[nad_entry].logical_unit_number, status);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND reserve_configured_elements;
?? TITLE := '      START_THE_PPS' ??
?? EJECT ??
  PROCEDURE  start_the_pps(VAR status: ost$status);

{    The purpose of this routine is to issue a resume request to each
{    of the PP drivers.
{
{    status: (output) This parameter returns the results of the request.

    VAR
        active_pp_found : boolean,
        local_status: ost$status,
        command_identifier: ^rft$pp_commands,
        request_buf: ^SEQ(*),
        nad_index: rft$local_nads,
        pp_index: 1..2;

    status.normal := TRUE;

    PUSH  request_buf : [[rft$pp_commands]];
    IF  request_buf = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'the local stack overflowed',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'START_THE_PPS', status);
      RETURN;
    IFEND;
    RESET request_buf;
    NEXT  command_identifier  IN  request_buf;
    IF  command_identifier = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'START_THE_PPS', status);
      RETURN;
    IFEND;
    command_identifier^ := rfc$pp_resume;

  /resume_pp_loop/
    FOR  nad_index := 1  TO  UPPERBOUND(rfv$status_table.local_nads^)  DO
      FOR  pp_index := 1  TO  rfv$status_table.local_nads^[nad_index].pp_drivers  DO
        IF  rfv$status_table.local_nads^[nad_index].pp[pp_index].pp_state = rfc$pps_idle  THEN
          rfp$queue_request(nad_index, pp_index, rfc$pp_request, rfc$rk_resume_pp, NIL, request_buf,
            local_status);
          IF  NOT  local_status.normal  THEN
            rfp$log_the_status(local_status);
          IFEND;
        IFEND;
      FOREND;
    FOREND /resume_pp_loop/;

{   wait for all of the PP's to resume.

    WHILE  (rfv$outstanding_requests <> NIL) AND
           (rfv$pp_interface_error.interface_error_code = 0)  DO
      pmp$wait(2000, 100);
      rfp$process_pp_response_flag(rfc$pp_response_available);
    WHILEND;


{   see if any PP's failed to start.

    IF  rfv$pp_interface_error.interface_error_code <> 0  THEN
      osp$set_status_condition ( rfe$pp_start_up_failed,  status);
      osp$append_status_integer(osc$status_parameter_delimiter, rfv$pp_interface_error.pp_number,
        10, TRUE, status);
      osp$append_status_integer(osc$status_parameter_delimiter,
        rfv$pp_interface_error.interface_error_code,16, TRUE, status);
      RETURN;
    IFEND;

    active_pp_found := FALSE;

  /find_active_pp/
    FOR  nad_index := 1  TO  UPPERBOUND(rfv$status_table.local_nads^)  DO
      FOR  pp_index := 1  TO  rfv$status_table.local_nads^[nad_index].pp_drivers  DO
        IF  rfv$status_table.local_nads^[nad_index].pp[pp_index].pp_state = rfc$pps_normal  THEN
          active_pp_found := TRUE;
          EXIT /find_active_pp/;
        IFEND;
      FOREND;
    FOREND /find_active_pp/;

    IF  NOT active_pp_found  THEN
      osp$set_status_condition ( rfe$unable_to_start_a_pp,  status);
    IFEND;

  PROCEND start_the_pps;
?? TITLE := '      LOAD_THE_NADS' ??
?? EJECT ??
  PROCEDURE  load_the_nads(VAR status: ost$status);

{    The purpose of this routine is to load the local NADs and to also set up the
{    local NAD tables for normal processing.
{
{    status: (output) This parameter returns the results of the request.

    VAR
        local_status: ost$status,
        nad_index: rft$local_nads;

    status.normal := TRUE;

    FOR  nad_index := 1  TO  UPPERBOUND(rfv$status_table.local_nads^)  DO
      initialize_local_nad_entry(nad_index);
      rfp$local_nad_load(nad_index, local_status);
      IF  NOT local_status.normal  THEN
        rfp$log_the_status(local_status);
      IFEND;
    FOREND;

    {   wait for the load to complete.

    WHILE  rfv$outstanding_requests <> NIL  DO
      pmp$wait(2000, 100);
      rfp$process_pp_response_flag(rfc$pp_response_available);
    WHILEND;

  PROCEND load_the_nads;
?? NEWTITLE := '        INITIALIZE_LOCAL_NAD_ENTRY' ??
?? EJECT ??
  PROCEDURE  initialize_local_nad_entry(nad_index: rft$local_nads);

{    The purpose of this procedure is to initialize the status timers and flags in the
{    local nad entry.
{
{    nad_index: (input) This parameter specifies the index within the local NAD table of
{      the corresponding NAD definition.


    VAR
        con_index: rft$concurrent_connections,
        ignore_status: ost$status,
        nad_entry: ^rft$local_nad_entry,
        current_time: integer;


    nad_entry := ^rfv$status_table.local_nads^[nad_index];
    pmp$get_microsecond_clock(current_time, ignore_status);
    nad_entry^.status_posted := FALSE;
    nad_entry^.status_change_available := FALSE;
    nad_entry^.maintenance_status.test_requested := FALSE;
    nad_entry^.current_status.device_status := rfc$es_down;
    nad_entry^.last_status_change := current_time;
    nad_entry^.processing_out_control_mess := FALSE;
    nad_entry^.processing_in_control_mess := FALSE;
    nad_entry^.outgoing_cm_queue.first_entry := NIL;
    nad_entry^.incoming_connect_pending := FALSE;
    nad_entry^.current_max_connect_id := 0;
    FOR  con_index := LOWERBOUND(nad_entry^.connection_table^)  TO
                      UPPERBOUND(nad_entry^.connection_table^)  DO
      nad_entry^.connection_table^[con_index].connection_table_entry := NIL;
    FOREND;

  PROCEND initialize_local_nad_entry;
?? OLDTITLE ??
?? OLDTITLE ??
?? TITLE := '    RFP$LOG_THE_STATUS' ??
?? EJECT ??
  PROCEDURE [XDCL] rfp$log_the_status (status_message : ost$status);

{
{    The purpose of this routine is to format a status message and write the formatted message
{    to the current output file.
{
{    status_message: (input) This parameter specifies the current status message that is to be
{      printed.

    CONST
        max_char_per_message_line = 72;
    VAR
        local_status: ost$status,
        number_of_message_lines : ^ost$status_message_line_count,
        length_of_message_line : ^ost$status_message_line_size,
        message_line : ^ost$status_message_line,
        message_sequence : ost$status_message,
        pointer_to_message_sequence : ^ost$status_message,
        line_counter : integer;

    osp$format_message(status_message, osc$current_message_level, max_char_per_message_line,
                       message_sequence, local_status);
    IF  NOT local_status.normal  THEN
      RETURN;
    IFEND;
    pointer_to_message_sequence := ^message_sequence;
    RESET pointer_to_message_sequence;
    NEXT  number_of_message_lines  IN  pointer_to_message_sequence;
    FOR  line_counter := 1  TO  number_of_message_lines^  DO
      NEXT  length_of_message_line  IN  pointer_to_message_sequence;
      NEXT  message_line : [length_of_message_line^]  IN  pointer_to_message_sequence;
      pmp$log(message_line^(1,length_of_message_line^), local_status);
      IF  NOT  local_status.normal  THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND rfp$log_the_status;
?? TITLE := '    RFP$LOCAL_NAD_STATUSING' ??
?? EJECT ??
  PROCEDURE  rfp$local_nad_statusing(current_time: INTEGER;
                                 VAR possible_connect_pending: BOOLEAN;
                                 VAR status: ost$status);

*copyc rfh$local_nad_statusing


    TYPE
        incoming_connect_entry = RECORD
          next_entry: ^incoming_connect_entry,
          nad_index: rft$local_nads,
          path_number: rft$concurrent_connections,
        RECEND;

    VAR
        connect_entry,
        connect_list: ^incoming_connect_entry,
        con_index: rft$concurrent_connections,
        connection_entry: ^rft$connection_table_entry,
        unconditionally_status: ^BOOLEAN,
        path_count: ^rft$path_identifier,
        new_connect_pending,
        check_event_list: BOOLEAN,
        ignore_status: ost$status,
        local_nad: ^rft$local_nad_entry,
        request: ^rft$outstanding_requests,
        command_identifier: ^rft$logical_commands,
        nad_index: rft$local_nads,
        request_info: ^SEQ(*);

    status.normal := TRUE;
    connect_list := NIL;
    check_event_list := FALSE;
    new_connect_pending := FALSE;
    FOR  nad_index := 1  TO  UPPERBOUND(rfv$status_table.local_nads^)  DO
      local_nad := ^rfv$status_table.local_nads^[nad_index];
      IF  local_nad^.current_status.device_status = rfc$es_on  THEN
        IF  local_nad^.status_posted  THEN
          IF  ((local_nad^.last_status_change + rfc$status_change_threshold) <= current_time)  OR
              (local_nad^.incoming_connect_pending)  THEN
            rfp$unconditionally_status(local_nad^.logical_unit_number);
          IFEND;
        ELSE
          PUSH  request_info : [[rft$logical_commands,BOOLEAN,rft$path_identifier]];
          RESET request_info;
          NEXT  command_identifier  IN  request_info;
          IF  command_identifier = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big',
              status);
            osp$append_status_parameter(osc$status_parameter_delimiter, 'LOAD_THE_NADS', status);
            RETURN;
          IFEND;
          command_identifier^ := rfc$lc_status_nad;
          NEXT  unconditionally_status  IN  request_info;
          IF  unconditionally_status = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'status flag too big',
              status);
            osp$append_status_parameter(osc$status_parameter_delimiter, 'LOAD_THE_NADS', status);
            RETURN;
          IFEND;
          IF  ((local_nad^.last_status_change + rfc$status_change_threshold) <= current_time)  THEN
            unconditionally_status^ := TRUE;
          ELSE
            unconditionally_status^ := FALSE;
          IFEND;
          NEXT  path_count  IN  request_info;
          IF  path_count = NIL  THEN
            osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'path count too big',
              status);
            osp$append_status_parameter(osc$status_parameter_delimiter, 'LOAD_THE_NADS', status);
            RETURN;
          IFEND;
          path_count^ := UPPERBOUND(local_nad^.connection_table^) -
                         LOWERBOUND(local_nad^.connection_table^) + 1;
          rfp$queue_request(nad_index, 1, rfc$unit_request, rfc$rk_local_nad_status, NIL, request_info,
            status);
          IF  NOT status.normal  THEN
            RETURN;
          IFEND;
          local_nad^.status_posted := TRUE;
        IFEND;
        local_nad^.incoming_connect_pending := FALSE;
        IF  local_nad^.status_change_available  THEN
          rfp$lock_table(local_nad^.connection_table_lock);
          FOR  con_index := 1 TO local_nad^.current_max_connect_id  DO
            connection_entry := ^local_nad^.connection_table^[con_index];
            IF  (connection_entry^.connection_state = rfc$ps_connecting)  AND
                (connection_entry^.connection_clarifier = rfc$pcc_incoming_connect) AND
                (NOT connection_entry^.processing_incoming_connect)  THEN
              IF  (connection_entry^.connection_table_entry = NIL)  THEN
                PUSH connect_entry;
                connect_entry^.path_number := con_index;
                connect_entry^.nad_index := nad_index;
                connect_entry^.next_entry := connect_list;
                connect_list := connect_entry;
                connection_entry^.processing_incoming_connect := TRUE;
              ELSE
                new_connect_pending := TRUE;
                local_nad^.incoming_connect_pending := TRUE;
              IFEND;
            IFEND;
          FOREND;
          rfp$unlock_table(local_nad^.connection_table_lock);
          check_event_list := TRUE;
          local_nad^.status_change_available := FALSE;
        IFEND;
        IF  (current_time - local_nad^.last_status_change) >= (5*1000*1000)  THEN
          check_event_list := TRUE;
        IFEND;
        rfp$control_messages(nad_index);
      ELSE  { NAD is not ON }
        local_nad^.incoming_connect_pending := FALSE;
      IFEND;
    FOREND;

    IF  (check_event_list)  THEN
      rfp$check_event_list(current_time, FALSE);
    IFEND;

    WHILE  connect_list <> NIL  DO
      rfp$incoming_connect_requests(connect_list^.nad_index, connect_list^.path_number);
      connect_list := connect_list^.next_entry;
    WHILEND;

    possible_connect_pending := new_connect_pending;

  PROCEND rfp$local_nad_statusing;
?? NEWTITLE := '      RFP$INCOMING_CONNECT_REQUESTS' ??
?? EJECT ??
  PROCEDURE  rfp$incoming_connect_requests(nad_index: rft$local_nads;
                                           con_index: rft$concurrent_connections);

*copyc rfh$incoming_connect_requests

    VAR
        local_status: ost$status,
        request_info: ^SEQ(*),
        connection_mgmt_status: ^rft$connection_mgmt_status,
        command_identifier: ^rft$logical_commands,
        physical_from: ^rft$physical_from,
        path_identifier: ^rft$path_identifier;

    local_status.normal := TRUE;

  /main_section/
    BEGIN
      PUSH  request_info : [[rft$logical_commands,rft$physical_from,rft$path_identifier]];
      RESET request_info;
      NEXT command_identifier IN request_info;
      IF  command_identifier = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big',
          local_status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$INCOMING_CONNECT_REQUESTS',
          local_status);
        EXIT /main_section/;
      IFEND;
      command_identifier^ := rfc$lc_obtain_connect_request;
      NEXT physical_from IN request_info;
      IF  physical_from = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'physical from too big',
          local_status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$INCOMING_CONNECT_REQUESTS',
          local_status);
        EXIT /main_section/;
      IFEND;
      physical_from^.compare_name := TRUE;
      physical_from^.criteria := rfc$pf_match_both_characters;
      physical_from^.char1 := rfv$status_table.local_host^.subsystem_identifier(1,1);
      physical_from^.char2 := rfv$status_table.local_host^.subsystem_identifier(2,1);
      NEXT path_identifier IN request_info;
      IF  path_identifier = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'path id too big',
          local_status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$INCOMING_CONNECT_REQUESTS',
          local_status);
        EXIT /main_section/;
      IFEND;
      path_identifier^ := con_index;
      ALLOCATE  connection_mgmt_status  IN  osv$task_private_heap^;
      IF  connection_mgmt_status = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'task private', local_status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$INCOMING_CONNECT_REQUEST',
          local_status);
        EXIT /main_section/;
      IFEND;
      connection_mgmt_status^.internal_use := TRUE;

      rfp$queue_request(nad_index, 1, rfc$unit_request, rfc$rk_obtain_connect_request, connection_mgmt_status,
        request_info, local_status);

      IF  NOT local_status.normal  THEN
        FREE  connection_mgmt_status  IN  osv$task_private_heap^;
      IFEND;

    END /main_section/;

    IF  NOT local_status.normal  THEN
      rfp$log_the_status(local_status);
    IFEND;

  PROCEND rfp$incoming_connect_requests;
?? TITLE := '      RFP$CHECK_EVENT_LIST' ??
?? EJECT ??
  PROCEDURE  rfp$check_event_list(current_time: INTEGER;
                                  system_task_shutdown: BOOLEAN);

*copyc rfh$check_event_list

    TYPE
        task_entry = RECORD
          next_entry: ^task_entry,
          task_id: ost$global_task_id,
          asynchronous: BOOLEAN,
        RECEND;

    VAR
        asynchronous: BOOLEAN,
        task_list: ^task_entry,
        task_to_wake_up: ^task_entry,
        event_entry: ^rft$rhfam_event_table_entry,
        event_type: rft$event_occurred_type,
        ignore_status: ost$status;

    task_list := NIL;
    rfp$lock_table(rfv$rhfam_event_table.lock);

    event_entry := rfv$rhfam_event_table.first_entry;

    WHILE  event_entry <> NIL  DO
      event_type := event_entry^.event_occurred_type;
      IF event_type = rfc$eot_no_event  THEN
        asynchronous := FALSE;
        CASE  event_entry^.event_kind  OF
        = rfc$ana_await_server_response =

          IF  (rfv$status_table.local_nads^[event_entry^.asr_connection_descriptor.nad_index].
                 connection_table^[event_entry^.asr_connection_descriptor.network_path].connection_state <>
                                                                     rfc$ps_connecting)  OR
              NOT ((rfv$status_table.local_nads^[event_entry^.asr_connection_descriptor.nad_index].
                 connection_table^[event_entry^.asr_connection_descriptor.network_path].connection_clarifier
                                                                  = rfc$pcc_locally_initiated)
               OR  (rfv$status_table.local_nads^[event_entry^.asr_connection_descriptor.nad_index].
                 connection_table^[event_entry^.asr_connection_descriptor.network_path].connection_clarifier
                                                                  = rfc$pcc_sending_connect)
               OR  (rfv$status_table.local_nads^[event_entry^.asr_connection_descriptor.nad_index].
                 connection_table^[event_entry^.asr_connection_descriptor.network_path].connection_clarifier
                                                                  = rfc$pcc_remote_nad_accept))  THEN
            event_type := rfc$eot_server_response;
          IFEND;

        = rfc$ana_await_incoming_connect =

          {  This event is checked in the response processor when an incoming connect request is received.

        = rfc$ana_await_connection_event =

          asynchronous := event_entry^.ace_asynchronous_wait;

          {  NOTE - Input available must be checked prior to connection broken, because the
          {         NAD will set the connection broken (on normal disconnects) even if there
          {         is data in the input queue.  This will allow users to retrieve the remaining
          {         data.

          IF
              (event_entry^.ace_input_available  AND
                rfv$status_table.local_nads^[event_entry^.ace_connection_descriptor.nad_index].
                  connection_table^[event_entry^.ace_connection_descriptor.network_path].input_available)
                                                                                                     THEN
            event_type := rfc$eot_input_available;
          ELSEIF
              (rfv$status_table.local_nads^[event_entry^.asr_connection_descriptor.nad_index].
                 connection_table^[event_entry^.asr_connection_descriptor.network_path].connection_state <>
                                                                     rfc$ps_established)  OR
              ((rfv$status_table.local_nads^[event_entry^.asr_connection_descriptor.nad_index].
                 connection_table^[event_entry^.asr_connection_descriptor.network_path].connection_clarifier
                                                                  <> rfc$pce_normal)  AND
               (rfv$status_table.local_nads^[event_entry^.asr_connection_descriptor.nad_index].
                 connection_table^[event_entry^.asr_connection_descriptor.network_path].connection_clarifier
                                                                  <> rfc$pce_local_host_uninformed))  THEN
            event_type := rfc$eot_connection_terminated;
          ELSEIF
              (event_entry^.ace_output_buffer_available  AND
                rfv$status_table.local_nads^[event_entry^.ace_connection_descriptor.nad_index].
                  connection_table^[event_entry^.ace_connection_descriptor.network_path].
                                                                               output_below_threshold)  THEN
            event_type := rfc$eot_output_below_threshold;
          ELSEIF
              (event_entry^.ace_data_transfer_in_progress  AND
                (current_time >= event_entry^.ace_asynchronous_timeout))  THEN
            event_type := rfc$eot_timeout;
          IFEND;

        ELSE

          {  Any unexpected event type is simply ignored.

        CASEND;

        {  NOTE - the system task shutdown supercedes any other event that may have occurred.

        IF  system_task_shutdown  THEN
          event_type := rfc$eot_system_task_shutdown;
        IFEND;

        IF  event_type <> rfc$eot_no_event  THEN
          event_entry^.event_occurred_type := event_type;
          PUSH  task_to_wake_up;
          task_to_wake_up^.task_id := event_entry^.task_id;
          task_to_wake_up^.asynchronous := asynchronous;
          task_to_wake_up^.next_entry := task_list;
          task_list := task_to_wake_up;
        IFEND;
      IFEND;
      event_entry := event_entry^.next_entry;
    WHILEND;

    rfp$unlock_table(rfv$rhfam_event_table.lock);

    WHILE  task_list <> NIL  DO
      IF  task_list^.asynchronous  THEN
        pmp$set_system_flag(rfc$pp_response_available, task_list^.task_id, ignore_status);
      ELSE
        pmp$ready_task(task_list^.task_id, ignore_status);
      IFEND;
      task_list := task_list^.next_entry;
    WHILEND;

  PROCEND rfp$check_event_list;
?? TITLE := '      RFP$CONTROL_MESSAGES' ??
?? EJECT ??
  PROCEDURE  rfp$control_messages(nad_index: rft$local_nads);

*copyc rfh$control_messages

    VAR
        table_locked: BOOLEAN,
        request_size: INTEGER,
        local_nad: ^rft$local_nad_entry,
        status: ost$status,
        request_info: ^SEQ(*),
        command_identifier: ^rft$logical_commands,
        physical_from: ^rft$physical_from,
        rejected_control_message: ^BOOLEAN,
        connection: rft$concurrent_connections,
        current_entry: ^rft$outgoing_control_message,
        control_message: ^rft$nbp_control_message,
        control_message_text_size: ^rft$control_message_text;

    status.normal := TRUE;
    local_nad := ^rfv$status_table.local_nads^[nad_index];
    request_size := #SIZE(rft$logical_commands) + #SIZE(rft$control_message_text) +
      rfc$max_control_message_size;

    PUSH  request_info : [[REP request_size OF CELL]];
    RESET request_info;
    rfp$lock_table(local_nad^.outgoing_cm_queue.lock);
    table_locked := TRUE;

/process_outgoing_messages/
    BEGIN
      IF  (local_nad^.connection_table^[0].output_below_threshold)  AND
          (local_nad^.outgoing_cm_queue.first_entry <> NIL)  AND
          (NOT local_nad^.processing_out_control_mess)  THEN
        current_entry := local_nad^.outgoing_cm_queue.first_entry;
        NEXT  command_identifier  IN  request_info;
        IF  command_identifier = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'OCM command id too big',
            status);
          osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$CONTROL_MESSAGES', status);
          EXIT /process_outgoing_messages/;
        IFEND;
        command_identifier^ := rfc$lc_send_control_message;
        NEXT  control_message_text_size IN  request_info;
        IF  control_message_text_size = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'OCM text size too big',
             status);
          osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$CONTROL_MESSAGES', status);
          EXIT /process_outgoing_messages/;
        IFEND;
        control_message_text_size^ := #SIZE(current_entry^.control_message.data);
        NEXT  control_message : [control_message_text_size^] IN  request_info;
        IF  control_message = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'OCM message too big',
            status);
          osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$CONTROL_MESSAGES', status);
          EXIT /process_outgoing_messages/;
        IFEND;
        control_message^ := current_entry^.control_message;
        local_nad^.processing_out_control_mess := TRUE;
        rfp$unlock_table(local_nad^.outgoing_cm_queue.lock);
        table_locked := FALSE;
        rfp$queue_request(nad_index, 1, rfc$unit_request, rfc$rk_send_control_mess, NIL, request_info,
          status);
        IF  NOT status.normal  THEN
          rfp$lock_table(local_nad^.outgoing_cm_queue.lock);
          table_locked := TRUE;
          local_nad^.processing_out_control_mess := FALSE;
          IF  current_entry^.purge_on_retry  THEN
            local_nad^.outgoing_cm_queue.first_entry := current_entry^.next_entry;
            FREE  current_entry  IN  nav$network_paged_heap^;
          IFEND;
        IFEND;
      IFEND;
    END /process_outgoing_messages/;

    IF  table_locked  THEN
      rfp$unlock_table(local_nad^.outgoing_cm_queue.lock);
    IFEND;
    IF  NOT status.normal  THEN
      rfp$log_the_status(status);
      status.normal := TRUE;
    IFEND;

  /process_incoming_messages/
    BEGIN
      IF  local_nad^.connection_table^[0].input_available  AND
          (NOT local_nad^.processing_in_control_mess)  THEN
        PUSH  request_info : [[rft$logical_commands,BOOLEAN,rft$physical_from]];
        RESET request_info;
        NEXT  command_identifier  IN  request_info;
        IF  command_identifier = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'ICM command id too big',
            status);
          osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$CONTROL_MESSAGES', status);
          EXIT /process_incoming_messages/;
        IFEND;
        command_identifier^ := rfc$lc_receive_control_message;
        NEXT  rejected_control_message  IN  request_info;
        IF  rejected_control_message = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'ICM reject too big',
            status);
          osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$CONTROL_MESSAGES', status);
          EXIT /process_incoming_messages/;
        IFEND;
        rejected_control_message^ := FALSE;
        NEXT  physical_from  IN  request_info;
        IF  physical_from = NIL  THEN
          osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'ICM phy. from too big',
            status);
          osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$CONTROL_MESSAGES', status);
          EXIT /process_incoming_messages/;
        IFEND;
        physical_from^.compare_name := TRUE;
        physical_from^.criteria := rfc$pf_match_first_character;
        physical_from^.char1 := rfv$status_table.local_host^.subsystem_identifier(1,1);
        rfp$queue_request(nad_index, 1, rfc$unit_request, rfc$rk_receive_control_mess, NIL, request_info,
          status);
        IF  status.normal  THEN
          local_nad^.processing_in_control_mess := TRUE;
        IFEND;
      IFEND;
    END /process_incoming_messages/;

    IF  NOT status.normal  THEN
      rfp$log_the_status(status);
    IFEND;

  PROCEND rfp$control_messages;
?? OLDTITLE ??
?? TITLE := '    RFP$CHECK_APPL_STARTUP' ??
?? EJECT ??
  PROCEDURE rfp$check_appl_startup(current_time: INTEGER);

*copyc rfh$check_appl_startup

    TYPE
        purge_entry = RECORD
          next_entry: ^purge_entry,
          access_method_accept: BOOLEAN,
          descriptor: rft$connection_descriptor,
        RECEND,

        application_entry = RECORD
          next_entry: ^application_entry,
          name: rft$application_name,
          is_a_server: BOOLEAN,
        RECEND,

        server_job_entry_list = RECORD
          next_entry: ^server_job_entry_list,
          entry: ^rft$rhfam_server_table_entry,
          number_to_start: rft$application_connections,
        RECEND;

    VAR
        status: ost$status,
        nad_index: rft$local_nads,
        job_index: rft$application_connections,
        connects_over_committed: INTEGER,
        server_job_list,
        server_job_to_start: ^server_job_entry_list,
        application_list,
        application_to_purge_entry: ^application_entry,
        current_client_entry: ^rft$rhfam_client_table_entry,
        current_server_entry: ^rft$rhfam_server_table_entry,
        connect_to_free,
        previous_connect,
        current_connect: ^rft$incoming_connect,
        server_job_entry,
        previous_server_job_entry,
        server_to_free: ^rft$server_identifier,
        abort_all_connects: BOOLEAN,
        purge_list,
        connect_to_purge: ^purge_entry;

    purge_list := NIL;
    application_list := NIL;
    server_job_list := NIL;

    rfp$lock_table(rfv$rhfam_server_table.lock);
    current_server_entry := rfv$rhfam_server_table.first_entry;
    WHILE  current_server_entry <> NIL  DO
      IF  current_server_entry^.rhfam_initiated_server  THEN
        server_job_entry := current_server_entry^.server_identifier;
        previous_server_job_entry := NIL;
        WHILE  server_job_entry <> NIL  DO
          IF  (NOT server_job_entry^.server_signed_on)  AND
              ((current_time - server_job_entry^.server_started_time) >
               (rfv$status_table.local_host^.connection_timeout * 1000 * 1000))  THEN
            current_server_entry^.connections_reserved := current_server_entry^.connections_reserved -
              current_server_entry^.server_job_max_connections;
            server_to_free := server_job_entry;
            server_job_entry := server_job_entry^.next_entry;
            FREE  server_to_free  IN  nav$network_paged_heap^;
            IF  previous_server_job_entry = NIL  THEN
              current_server_entry^.server_identifier := server_job_entry;
            ELSE
              previous_server_job_entry^.next_entry := server_job_entry;
            IFEND;
          ELSE
            previous_server_job_entry := server_job_entry;
            server_job_entry := server_job_entry^.next_entry;
          IFEND;
        WHILEND;
      IFEND;
      IF  (NOT current_server_entry^.server_active)  AND
          (current_server_entry^.abort_connections)  THEN
        abort_all_connects := TRUE;
        PUSH  application_to_purge_entry;
        application_to_purge_entry^.name := current_server_entry^.server_name;
        application_to_purge_entry^.is_a_server := TRUE;
        application_to_purge_entry^.next_entry := application_list;
        application_list := application_to_purge_entry;
        current_server_entry^.abort_connections := FALSE;
      ELSE
        abort_all_connects := FALSE;
      IFEND;
      current_connect := current_server_entry^.incoming_connect;
      previous_connect := NIL;
      WHILE  current_connect <> NIL  DO
        IF  ((current_time - current_connect^.time_received) >
             (rfv$status_table.local_host^.connection_timeout * 1000 * 1000))  OR
            (abort_all_connects)  THEN
          PUSH  connect_to_purge;
          connect_to_purge^.descriptor := current_connect^.connection_descriptor;
          connect_to_purge^.access_method_accept := current_server_entry^.access_method_accept;
          connect_to_purge^.next_entry := purge_list;
          purge_list := connect_to_purge;
          current_server_entry^.current_connections := current_server_entry^.current_connections - 1;
          connect_to_free := current_connect;
          current_connect := current_connect^.next_entry;
          FREE  connect_to_free  IN  nav$network_paged_heap^;
          IF  previous_connect = NIL  THEN
            current_server_entry^.incoming_connect := current_connect;
          ELSE
            previous_connect^.next_entry := current_connect;
          IFEND;
        ELSE
          previous_connect := current_connect;
          current_connect := current_connect^.next_entry;
        IFEND;
      WHILEND;
      connects_over_committed := current_server_entry^.current_connections -
        current_server_entry^.partner_job_connections - current_server_entry^.connections_reserved;
      IF  (current_server_entry^.rhfam_initiated_server)  AND
          (current_server_entry^.active_incoming_connects = 0)  AND
          (connects_over_committed > 0)  THEN
        PUSH server_job_to_start;
        server_job_to_start^.entry := current_server_entry;
        server_job_to_start^.number_to_start := (connects_over_committed +
          current_server_entry^.server_job_max_connections - 1) DIV
          current_server_entry^.server_job_max_connections;
        server_job_to_start^.next_entry := server_job_list;
        server_job_list := server_job_to_start;
      IFEND;
      current_server_entry := current_server_entry^.next_entry;
    WHILEND;
    rfp$unlock_table(rfv$rhfam_server_table.lock);

    rfp$lock_table(rfv$rhfam_client_table.lock);
    current_client_entry := rfv$rhfam_client_table.first_entry;
    WHILE  current_client_entry <> NIL  DO
      IF  (NOT current_client_entry^.client_active)  AND
          (current_client_entry^.abort_connections)  THEN
        PUSH  application_to_purge_entry;
        application_to_purge_entry^.name := current_client_entry^.client_name;
        application_to_purge_entry^.is_a_server := FALSE;
        application_to_purge_entry^.next_entry := application_list;
        application_list := application_to_purge_entry;
        current_client_entry^.abort_connections := FALSE;
      IFEND;
      current_client_entry := current_client_entry^.next_entry;
    WHILEND;
    rfp$unlock_table(rfv$rhfam_client_table.lock);

    WHILE  purge_list <> NIL  DO
      IF  purge_list^.access_method_accept  THEN
        purge_path(purge_list^.descriptor);
      ELSE
        reject_incoming_connect(purge_list^.descriptor);
      IFEND;
      purge_list := purge_list^.next_entry;
    WHILEND;

    WHILE  server_job_list <> NIL  DO
      FOR  job_index := 1  TO  server_job_list^.number_to_start  DO
        rfp$start_server_job(server_job_list^.entry, status);
        IF  NOT status.normal  THEN
          rfp$log_the_status(status);
        IFEND;
      FOREND;
      server_job_list := server_job_list^.next_entry;
    WHILEND;

    WHILE  application_list <> NIL  DO
      FOR  nad_index := 1  TO  UPPERBOUND(rfv$status_table.local_nads^)  DO
        clear_connection_entries(nad_index, application_list^.name, rfc$terminated);
      FOREND;
      IF  application_list^.is_a_server  THEN
        wake_up_tasks(application_list^.name);
      IFEND;
      application_list := application_list^.next_entry;
    WHILEND;

  PROCEND rfp$check_appl_startup;
?? NEWTITLE := '      PURGE_PATH' ??
?? EJECT ??
  PROCEDURE  purge_path(connection_descriptor: rft$connection_descriptor);

{    The purpose of this routine is to purge the NAD path for a specified connection.
{
{    connection_descriptor: (input) This parameter specifies the local NAD index and connection
{      number of the path to purge.


    VAR
        status: ost$status,
        connection_mgmt_status: ^rft$connection_mgmt_status,
        abnormal_termination: ^BOOLEAN,
        request_info: ^SEQ(*),
        command_identifier: ^rft$logical_commands,
        path_identifier: ^rft$path_identifier;

    status.normal := TRUE;

  /main_section/
    BEGIN
      PUSH  request_info : [[rft$logical_commands,BOOLEAN,rft$path_identifier]];
      RESET request_info;
      NEXT command_identifier IN request_info;
      IF  command_identifier = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big',
          status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'PURGE_PATH', status);
        EXIT /main_section/;
      IFEND;
      command_identifier^ := rfc$lc_disconnect_paths;
      NEXT abnormal_termination IN request_info;
      IF  abnormal_termination = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'termination type too big',
          status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'PURGE_PATH', status);
        EXIT /main_section/;
      IFEND;
      abnormal_termination^ := TRUE;
      NEXT path_identifier IN request_info;
      IF  path_identifier = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'path id too big',
          status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'PURGE_PATH', status);
        EXIT /main_section/;
      IFEND;
      path_identifier^ := connection_descriptor.network_path;
      ALLOCATE connection_mgmt_status IN osv$task_private_heap^;
      IF  connection_mgmt_status = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'task private', status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'PURGE_PATH', status);
        EXIT /main_section/;
      IFEND;
      connection_mgmt_status^.internal_use := TRUE;
      rfp$queue_request(connection_descriptor.nad_index, 1, rfc$unit_request, rfc$rk_disconnect_path,
        connection_mgmt_status, request_info, status);
      IF  NOT status.normal  THEN
        FREE connection_mgmt_status IN osv$task_private_heap^;
      IFEND;

    END  /main_section/;

    IF  NOT status.normal  THEN
      rfp$log_the_status(status);
    IFEND;

  PROCEND purge_path;
?? TITLE := '      REJECT_INCOMING_CONNECT' ??
?? EJECT ??
  PROCEDURE  reject_incoming_connect(connection_descriptor: rft$connection_descriptor);

{    The purpose of this routine is to reject the incoming connect across the specified path.
{    A reject code of rfc$nbp_requested_host_busy is used.
{
{    connection_descriptor: (input) This parameter specifies the local NAD index and connection
{      number of the path to purge.

    VAR
        status: ost$status,
        connection_mgmt_status: ^rft$connection_mgmt_status,
        request_info: ^SEQ(*),
        command_identifier: ^rft$logical_commands,
        reject_id: ^rft$reject_code,
        path_identifier: ^rft$path_identifier;

    status.normal := TRUE;

  /main_section/
    BEGIN
      PUSH  request_info : [[rft$logical_commands,rft$path_identifier,rft$reject_code]];
      RESET request_info;
      NEXT command_identifier IN request_info;
      IF  command_identifier = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big',
          status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'REJECT_INCOMING_CONNECT', status);
        EXIT /main_section/;
      IFEND;
      command_identifier^ := rfc$lc_reject_connect_request;
      NEXT path_identifier IN request_info;
      IF  path_identifier = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'path id too big',
          status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'REJECT_INCOMING_CONNECT', status);
        EXIT /main_section/;
      IFEND;
      path_identifier^ := connection_descriptor.network_path;
      NEXT reject_id IN request_info;
      IF  reject_id = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'reject code too big',
          status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'REJECT_INCOMING_CONNECT', status);
        EXIT /main_section/;
      IFEND;
      reject_id^ := rfc$nbp_requested_host_busy;
      ALLOCATE connection_mgmt_status IN osv$task_private_heap^;
      IF  connection_mgmt_status = NIL  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'task private', status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'REJECT_INCOMING_CONNECT', status);
        EXIT /main_section/;
      IFEND;
      connection_mgmt_status^.internal_use := TRUE;
      rfp$queue_request(connection_descriptor.nad_index, 1, rfc$unit_request, rfc$rk_reject_connect_request,
        connection_mgmt_status, request_info, status);
      IF  NOT status.normal  THEN
        FREE connection_mgmt_status IN osv$task_private_heap^;
      IFEND;

    END  /main_section/;

    IF  NOT status.normal  THEN
      rfp$log_the_status(status);
    IFEND;

  PROCEND reject_incoming_connect;
?? TITLE := '      WAKE_UP_TASKS' ??
?? EJECT ??
  PROCEDURE  wake_up_tasks(server_name: rft$application_name);

{    The purpose of this routine is to scan the list of tasks, which are waiting
{    for incoming connect request from the corresponding server, and start the
{    task.  The event occurred type is set to incoming connect available.
{    The task being restarted must determine that the corresponding server
{    application has been disabled.
{
{    server_name: (input) This parameter specifies the name of the server that
{      is no longer enabled to receive incoming connects.

    TYPE
        task_entry = RECORD
          next_entry: ^task_entry,
          task_id: ost$global_task_id,
        RECEND;

    VAR
        task_list,
        task_to_wake_up: ^task_entry,
        event_entry: ^rft$rhfam_event_table_entry,
        ignore_status: ost$status;

    task_list := NIL;
    rfp$lock_table(rfv$rhfam_event_table.lock);

    event_entry := rfv$rhfam_event_table.first_entry;

    WHILE  event_entry <> NIL  DO
      IF event_entry^.event_occurred_type = rfc$eot_no_event  THEN
        CASE  event_entry^.event_kind  OF
        = rfc$ana_await_incoming_connect =

          IF  event_entry^.aic_server_name = server_name  THEN
            event_entry^.event_occurred_type := rfc$eot_incoming_connect;
            PUSH  task_to_wake_up;
            task_to_wake_up^.task_id := event_entry^.task_id;
            task_to_wake_up^.next_entry := task_list;
            task_list := task_to_wake_up;
          IFEND;

        ELSE

          {  Any other event type is simply ignored.

        CASEND;
      IFEND;
      event_entry := event_entry^.next_entry;
    WHILEND;

    rfp$unlock_table(rfv$rhfam_event_table.lock);

    WHILE  task_list <> NIL  DO
      pmp$ready_task(task_list^.task_id, ignore_status);
      task_list := task_list^.next_entry;
    WHILEND;

  PROCEND wake_up_tasks;
?? OLDTITLE ??
?? TITLE := '    RFP$CHECK_HARDWARE_AVAILABLE' ??
?? EJECT ??
  PROCEDURE  rfp$check_hardware_available(current_time: INTEGER);

*copyc rfh$check_hardware_available

    VAR
        paths: ^rft$lcn_paths,
        remote_host_entry: ^rft$remote_host_definition;

    {  Check to see if there are local paths to be enabled  }

    rfp$lock_table(rfv$status_table.lock);
    paths := rfv$status_table.local_host^.associated_paths;
    IF  paths <> NIL  THEN
      enable_timed_out_paths(current_time, paths);
    IFEND;

    {  Check to see if there are remote host paths to be enabled  }

    remote_host_entry := rfv$status_table.remote_hosts;
    WHILE  remote_host_entry <> NIL  DO
      paths := remote_host_entry^.associated_paths;
      IF  paths <> NIL  THEN
        enable_timed_out_paths(current_time, paths);
      IFEND;
      remote_host_entry := remote_host_entry^.next_entry;
    WHILEND;
    rfp$unlock_table(rfv$status_table.lock);

  PROCEND rfp$check_hardware_available;
?? NEWTITLE := '      ENABLE_TIMED_OUT_PATHS' ??
?? EJECT ??
  PROCEDURE  enable_timed_out_paths(current_time: INTEGER;
                                VAR paths: ^rft$lcn_paths);

{    The purpose of this routine is to enable any path that has been disabled for
{    the specified threshold level.
{
{    NOTE - The calling routine is required to set and clear the required lock.
{
{    current_time: (input) This parameter specifies the current time in microseconds.
{
{    paths: (input,output) This parameter specifies the list of paths to check.
{      Each path that has been disabled for the specified time is subsequently enabled.

    CONST
        rfc$initial_threshold = 30 * 1000 * 1000,           { 30 seconds }
        rfc$intermediate_threshold = 5 * 60 * 1000 * 1000,  { 5 minutes }
        rfc$long_term_threshold = 30 * 60 * 1000 * 1000;    { 30 minutes }

    CONST
        rfc$initial_retries = 10,          {  1 - 10 }
        rfc$intermediate_retries = 30,     { 11 - 30 }
        rfc$long_term_retries = 99999;     { 31 - forever }

    VAR
        time_disabled: INTEGER,
        path_index: rft$paths_per_host;

    FOR  path_index := LOWERBOUND(paths^)  TO  UPPERBOUND(paths^)  DO
      IF  (paths^[path_index].disabled)  THEN
        time_disabled := current_time - paths^[path_index].time_disabled;
        IF (((paths^[path_index].failure_count <= rfc$initial_retries)  AND
             (time_disabled >= rfc$initial_threshold))  OR
            ((paths^[path_index].failure_count <= rfc$intermediate_retries)  AND
             (time_disabled >= rfc$intermediate_threshold))  OR
            (time_disabled >= rfc$long_term_threshold))  THEN
          paths^[path_index].disabled := FALSE;
        IFEND;
      IFEND;
    FOREND;

  PROCEND enable_timed_out_paths;
?? OLDTITLE ??
?? TITLE := '    RFP$LOG_PERFORMANCE_STATISTICS' ??
?? EJECT ??
  PROCEDURE  rfp$log_performance_statistics;

*copyc rfh$log_performance_statistics

    VAR
        nad_index: rft$local_nads,
        local_nad: ^rft$local_nad_entry;

    FOR  nad_index := 1  TO  UPPERBOUND(rfv$status_table.local_nads^)  DO
      local_nad := ^rfv$status_table.local_nads^[nad_index];
      IF  local_nad^.current_status.device_status <> rfc$es_off  THEN
        log_nad_statistics(local_nad);
      IFEND;
    FOREND;

  PROCEND rfp$log_performance_statistics;
?? NEWTITLE := '      LOG_NAD_STATISTICS' ??
?? EJECT ??
  PROCEDURE  log_nad_statistics(local_nad: ^rft$local_nad_entry);

{    The purpose of this routine is to log the performance statistics for a
{    specified local NAD.  This routine also clears the counters after the statistics
{    are logged.
{
{    local_nad: (input) This parameter specifies a pointer to the corresponding local
{      NAD to log.

    VAR
        concurrent_channel_flag: integer,
        descriptor_data: ost$string,
        iou_number: dst$iou_number,
        status: ost$status,
        pp_number: 0..31,
        counters: ^ARRAY [1..*] OF sft$counter;

    PUSH  counters : [1..5];
    cmp$return_desc_data_by_lun_lpn(local_nad^.logical_unit_number,
      local_nad^.pp[1].pp_number, iou_number, descriptor_data, pp_number);
    concurrent_channel_flag :=0;
    IF local_nad^.concurrent_channel THEN
      concurrent_channel_flag := 1*40(16);
    IFEND;
    counters^[1] := local_nad^.channel_number + concurrent_channel_flag + iou_number * 1000(16);
    rfp$lock_table(rfv$status_table.lock);
    counters^[2] := local_nad^.statistics.bytes_sent;
    local_nad^.statistics.bytes_sent := 0;
    counters^[3] := local_nad^.statistics.bytes_received;
    local_nad^.statistics.bytes_received := 0;
    counters^[4] := local_nad^.maintenance_status.reloads_performed;
    IF  local_nad^.current_status.device_status <> rfc$es_off  THEN
      local_nad^.maintenance_status.reloads_performed := 0;
    IFEND;
    counters^[5] := local_nad^.statistics.connections_established;
    local_nad^.statistics.connections_established := 0;
    rfp$unlock_table(rfv$status_table.lock);
    sfp$emit_statistic(cml$rhfam_usage_data, descriptor_data.value(1,descriptor_data.size), counters, status);

    IF  NOT status.normal  THEN
      rfp$log_the_status(status);
    IFEND;

  PROCEND log_nad_statistics;
?? OLDTITLE ??
?? TITLE := '    RFP$AUTO_DUMP_AND_RELOAD' ??
?? EJECT ??
*copyc rfh$nad_loading

*copyc rfh$nad_dumping
?? EJECT ??
  PROCEDURE  rfp$auto_dump_and_reload(current_time: INTEGER);

*copyc rfh$auto_dump_and_reload

    VAR
        local_nad: ^rft$local_nad_entry,
        con_index: rft$concurrent_connections,
        i: integer,
        critical_msg: string(55),
        local_status: ost$status,
        nad_index: rft$local_nads;

    {   NOTE - the requests_posted count is used to prevent multiple dumps or loads from
    {          occurring simultaneously for the same NAD.

  /reload_local_nads/
    FOR  nad_index := 1  TO  UPPERBOUND(rfv$status_table.local_nads^)  DO
      local_nad := ^rfv$status_table.local_nads^[nad_index];
      IF  (local_nad^.current_status.device_status = rfc$es_down)  THEN
        IF  NOT local_nad^.maintenance_status.reload_in_progress  THEN
          rfp$unconditionally_status(local_nad^.logical_unit_number);
          clear_incoming_connects(nad_index);
          clear_connection_entries(nad_index, '       ', rfc$local_nad_failure);
          release_all_control_messages(nad_index);
          rfp$check_event_list(current_time, FALSE);
          IF  (local_nad^.requests_posted = 0)                          AND
              (NOT local_nad^.maintenance_status.reload_failed)         AND
              (   (local_nad^.maintenance_status.test_requested)          OR
                ( (local_nad^.maintenance_selections.perform_auto_reload)   AND
                  (local_nad^.maintenance_status.reloads_performed <
                   local_nad^.maintenance_selections.reload_threshold)))  THEN

            {  Tell the driver to process unit requests.

            rfp$change_nad_status(rfv$status_table.local_nads^[nad_index].logical_unit_number, rfc$es_on);

            {  Initiate the dump process.

            IF  (NOT local_nad^.maintenance_status.test_requested)  THEN
              rfp$local_nad_dump(nad_index, local_status);
              IF  NOT local_status.normal  THEN
                rfp$log_the_status(local_status);
              IFEND;
            IFEND;
            local_nad^.maintenance_status.reload_in_progress := TRUE;
          IFEND;
        IFEND;
        IF  (local_nad^.maintenance_status.reload_in_progress) AND
            (local_nad^.requests_posted = 0)  THEN

          {  Tell the driver to process unit requests.  (in case the dump failed)

          rfp$change_nad_status(local_nad^.logical_unit_number, rfc$es_on);

          {  Initiate the reload process.

          rfp$local_nad_load(nad_index, local_status);
          IF  NOT local_status.normal  THEN
            rfp$log_the_status(local_status);
            local_nad^.maintenance_status.reload_failed := TRUE;
          IFEND;
          local_nad^.maintenance_status.reload_in_progress := FALSE;
        IFEND;
        IF  (NOT local_nad^.maintenance_selections.perform_auto_reload) OR
            (local_nad^.maintenance_status.reload_failed) OR
            (local_nad^.maintenance_status.reloads_performed >=
                local_nad^.maintenance_selections.reload_threshold) THEN

          {   Changing the state to OFF prevents further access until an explicit operator
          {   action re-instates the device.

          local_nad^.maintenance_status.reload_failed := TRUE;
          local_nad^.current_status.device_status := rfc$es_off;
          log_nad_statistics(local_nad);

          stringrep(critical_msg, i, 'NAD ', local_nad^.name, ' is not available.');
          dpp$put_critical_message(critical_msg(1,i), {ignore} local_status);
        IFEND;
      IFEND;
      IF  (NOT local_nad^.maintenance_status.reload_failed) AND
          (local_nad^.current_status.device_status = rfc$es_off)  THEN
        rfp$unconditionally_status(local_nad^.logical_unit_number);
        clear_incoming_connects(nad_index);
        clear_connection_entries(nad_index, '       ', rfc$local_nad_failure);
        release_all_control_messages(nad_index);
        rfp$check_event_list(current_time, FALSE);
        WHILE  (local_nad^.requests_posted <> 0)  DO
          pmp$wait(1000, 100);
          rfp$process_pp_response_flag(rfc$pp_response_available);
        WHILEND;
        local_nad^.maintenance_status.reload_failed := TRUE;
        log_nad_statistics(local_nad);
      IFEND;
    FOREND;

  PROCEND rfp$auto_dump_and_reload;
?? NEWTITLE := '      RFP$LOCAL_NAD_LOAD' ??
?? EJECT ??
  PROCEDURE  [XDCL] rfp$local_nad_load(nad_index: rft$local_nads;
                                   VAR status: ost$status);
*copyc rfh$local_nad_load

    VAR
        actual_buff_size: nlt$bm_buffer_length,
        buffer_index: rft$buffer_count,
        mc_file_open: BOOLEAN,
        ignore_status: ost$status,
        request_info: ^SEQ(*),
        load_request_status: ^rft$load_dump_status;

    mc_file_open := FALSE;
    status.normal := TRUE;

    ALLOCATE  load_request_status  IN  osv$task_private_heap^;
    IF  load_request_status = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'task private', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$LOCAL_NAD_LOAD', status);
      RETURN;
    IFEND;
    ALLOCATE  load_request_status^.buffer_list : [1..rfc$max_load_dump_buffers] IN  osv$task_private_heap^;
    IF  load_request_status^.buffer_list = NIL  THEN
      FREE  load_request_status  IN  osv$task_private_heap^;
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'task private', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$LOCAL_NAD_LOAD', status);
      RETURN;
    IFEND;
    load_request_status^.number_of_buffers := 0;

  /main_section/
    BEGIN
      get_nad_microcode(rfc$mc_type_180,
        load_request_status^.mc_lfn, load_request_status^.mc_file_id,
        load_request_status^.mc_image, load_request_status^.mc_length, status);
      IF  NOT status.normal  THEN
        EXIT /main_section/;
      IFEND;
      mc_file_open := TRUE;
      generate_mc_init_prams(nad_index, load_request_status^.init_prams);
      load_request_status^.number_of_buffers := rfc$max_load_dump_buffers;
      rfp$reserve_wired_buffers(load_request_status^.buffer_list^, load_request_status^.number_of_buffers);
      IF  load_request_status^.number_of_buffers = 0  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'network wired', status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$LOCAL_NAD_LOAD', status);
        EXIT /main_section/;
      IFEND;

{     Note. Reduce the space in each buffer to the next lower multiple of 6 bytes so the PP can send
{           multiples of 48-bits through the 12-bit channel to the 16-bit NAD, thus preventing the NAD
{           from padding test and load data.

      IF load_request_status^.buffer_list^[1].length > rfc$max_load_dump_buffer_size THEN
        actual_buff_size := (rfc$max_load_dump_buffer_size DIV 6) * 6;
      ELSE
        actual_buff_size := (load_request_status^.buffer_list^[1].length DIV 6) * 6;
      IFEND;

      FOR  buffer_index := 1 TO load_request_status^.number_of_buffers  DO
        load_request_status^.buffer_list^[buffer_index].length := actual_buff_size;
      FOREND;

      load_request_status^.time_of_first_go := 0;
      load_request_status^.state := rfc$lt_mem_test_begin;
      load_request_status^.mem_test_first_pass := TRUE;
      load_request_status^.initial_phase := TRUE;
      load_request_status^.current_nad_address := 0;

      { The request buffer size is set to two times the command buffer size.  This number was derived from
      { from the fact that each request size is no more than two times the actual command size.

      PUSH  request_info : [[REP  2*rfc$command_buffer_size OF rft$command]];
      RESET request_info;

      rfp$build_load_request(load_request_status, request_info, status);
      IF  NOT status.normal  THEN
        EXIT /main_section/;
      IFEND;
      rfp$queue_request(nad_index, 1, rfc$unit_request, rfc$rk_local_nad_load, load_request_status,
        request_info, status);

    END  /main_section/;

    IF  NOT status.normal  THEN
      IF  mc_file_open  THEN
        fsp$close_file(load_request_status^.mc_file_id, ignore_status);
        amp$return(load_request_status^.mc_lfn, ignore_status);
      IFEND;
      IF  load_request_status^.number_of_buffers <> 0  THEN
        rfp$release_wired_buffers(load_request_status^.buffer_list^, load_request_status^.number_of_buffers);
      IFEND;
      FREE  load_request_status^.buffer_list  IN  osv$task_private_heap^;
      FREE  load_request_status  IN  osv$task_private_heap^;
    IFEND;

  PROCEND rfp$local_nad_load;
?? NEWTITLE := '        GET_NAD_MICROCODE' ??
?? EJECT ??
  PROCEDURE get_nad_microcode(mc_type: rft$microcode_types;
                          VAR mc_lfn: amt$local_file_name;
                          VAR mc_fid: amt$file_identifier;
                          VAR mc_image: ^CELL;
                          VAR mc_length: INTEGER;
                          VAR status: ost$status);

{    The purpose of this request is to obtain the NAD microcode file.
{
{    mc_type: (input) This paramter specifies the type of microcode to load.
{      The name identified by the microcode type determines the name of the
{      microcode file.
{
{    mc_lfn: (output) This parameter returns the local file name of the
{      microcode file.
{
{    mc_fid: (output) This parameter returns the file identifier of the open
{      microcode file.
{
{    mc_image: (output) This parameter returns the pointer to the first byte
{      within the file.
{
{    mc_length: (output) This parameter returns the eoi_byte_address.
{
{    status: (output) This paramter returns the results of the request.  A status of
{      normal means that the microcode file was found and has been opened for segment
{      access.

    VAR
        mt_conversion_types: [STATIC,READ, oss$job_paged_literal] ARRAY [rft$microcode_types] OF string(4) :=
          ['C180', 'C170', 'VAX', 'IBM', 'C205', 'INET', 'NTN'];

    VAR
        access_info: ^amt$access_information,
        segment_ptr: amt$segment_pointer,
        ignore_status: ost$status,
        path: ^pft$path,
        password: pft$name,
        usage_selections: pft$usage_selections,
        share_selections: pft$share_selections,
        cycle_selector: pft$cycle_selector;

    PUSH path : [1..5];
    path^[1] := rfc$rhfam_family_name;
    path^[2] := rfc$rhfam_master_catalog;
    path^[3] := rfc$rhfam_sub_catalog;
    path^[4] := rfc$microcode_sub_catalog;
    path^[5] := mt_conversion_types[mc_type];
    usage_selections := $pft$usage_selections[pfc$read];
    share_selections := $pft$share_selections[pfc$read,pfc$execute];
    cycle_selector.cycle_option := pfc$highest_cycle;
    password := rfc$password;
    mc_lfn(1,7) := '$RHFAM_';
    mc_lfn(8,*) := mt_conversion_types[mc_type];
    pfp$attach(mc_lfn, path^, cycle_selector, password, usage_selections, share_selections,
                    pfc$no_wait, status);
    IF  NOT status.normal  AND
        (status.condition <> pfe$cycle_busy) AND
        (status.condition <> pfe$lfn_in_use) THEN
      RETURN;
    IFEND;

    fsp$open_file(mc_lfn, amc$segment, NIL, NIL, NIL, NIL, NIL,
      mc_fid, status);
    IF  NOT status.normal  THEN
      amp$return(mc_lfn, ignore_status);
      RETURN;
    IFEND;

    amp$get_segment_pointer(mc_fid, amc$cell_pointer, segment_ptr, status);
    IF  NOT status.normal  THEN
      fsp$close_file(mc_fid, ignore_status);
      amp$return(mc_lfn, ignore_status);
      RETURN;
    IFEND;
    mc_image := segment_ptr.cell_pointer;

    PUSH access_info : [1..1];
    access_info^[1].key := amc$eoi_byte_address;
    amp$fetch_access_information(mc_fid, access_info^, status);
    IF  NOT status.normal  THEN
      fsp$close_file(mc_fid, ignore_status);
      amp$return(mc_lfn, ignore_status);
      RETURN;
    IFEND;
    mc_length := access_info^[1].eoi_byte_address;

  PROCEND get_nad_microcode;
?? TITLE := '        GENERATE_MC_INIT_PRAMS' ??
?? EJECT ??
  PROCEDURE generate_mc_init_prams(nad_table_index: rft$local_nads;
                               VAR init_prams: rft$mc_initialization_prams);

{    The purpose of this proceure is to generate the microcode intialization parameters
{    for the specified NAD.
{
{    nad_table_index: (input) This parameter specifies the index of withing the local NAD
{      table of the corresponding NAD.
{
{    init_prams: (output) This paramter returns the initialization table entries.

    VAR
        tcu_index: rfc$min_tcu .. rfc$max_tcu,
        nad_load_prams: rft$load_parameters;

    nad_load_prams := rfv$status_table.local_nads^[nad_table_index].maintenance_selections.load_parameters;
    pmp$zero_out_table(#LOC(init_prams), #SIZE(init_prams));
    init_prams.memory_size := rfc$default_memory_size;
    FOR  tcu_index := rfc$min_tcu  TO  rfc$max_tcu  DO
      init_prams.tcu_enables[tcu_index] := TRUE;
    FOREND;
    init_prams.connecting_nads := nad_load_prams.maximum_nad_entries;
    init_prams.max_connections := nad_load_prams.maximum_connections;
    init_prams.system_buffers := nad_load_prams.maximum_connections + 1;
    init_prams.control_messages := nad_load_prams.maximum_connections;
    init_prams.type_1_buff_size := rfc$nad_type_1_buff_lgth;
    init_prams.type_1_buff_count := rfc$min_type_1_buffs;
    init_prams.incoming_control_messages := nad_load_prams.maximum_connections - 1;
    init_prams.outgoing_control_messages := nad_load_prams.maximum_connections - 1;
    init_prams.send_queue_limit := nad_load_prams.send_queue_limit;
    init_prams.receive_queue_limit := nad_load_prams.receive_queue_limit;
    init_prams.monitor_trace := nad_load_prams.monitor_trace;
    init_prams.trunk_trace := nad_load_prams.trunk_trace;
    init_prams.device_trace := nad_load_prams.device_trace;

  PROCEND generate_mc_init_prams;
?? TITLE := '        RFP$BUILD_LOAD_REQUEST' ??
?? EJECT ??
  PROCEDURE  [XDCL]  rfp$build_load_request(VAR load_request_status: ^rft$load_dump_status;
                                            VAR request_info: ^SEQ(*);
                                            VAR status: ost$status);

{    This routine builds requests, first for testing the local NAD, and then for loading the
{    microcode.
{
{    load_request_buffer: (input,output) This parameter points to the buffer specifying the
{      current microcode load status information.  This routine moves as much data as possible
{      into the wired buffers and returns the current microcode load status.
{
{    request_info: (input,output) This parameter specifies an adaptable sequence where the
{      request is to be placed.  Upon exit the sequence contains the load request functions.
{
{    status: (output) This parameter returns the results of the request.


    VAR
        number_of_commands: ^0..rfc$command_buffer_size,
        command_identifier: ^rft$logical_commands,
        physical_command: ^rft$physical_commands;

    status.normal := TRUE;

    NEXT  command_identifier  IN  request_info;
    IF  command_identifier = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$BUILD_LOAD_REQUEST', status);
      RETURN;
    IFEND;
    command_identifier^ := rfc$lc_process_physical_command;
    NEXT  number_of_commands  IN  request_info;
    IF  number_of_commands = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command count too big', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$BUILD_LOAD_REQUEST', status);
      RETURN;
    IFEND;
    number_of_commands^ := 0;

    CASE  load_request_status^.state  OF
    = rfc$lt_mem_test_begin, rfc$lt_mem_test_write, rfc$lt_mem_test_read =
      test_nad_memory(load_request_status, request_info, number_of_commands, status);
    ELSE
      rfp$move_mc_to_wired_buffers(load_request_status, request_info, number_of_commands, status);
    CASEND;
  PROCEND rfp$build_load_request;
?? NEWTITLE := '          TEST_NAD_MEMORY' ??
?? EJECT ??
  PROCEDURE test_nad_memory(VAR load_request_status: ^rft$load_dump_status;
                            VAR request_info: ^SEQ(*);
                            VAR number_of_commands: ^0..rfc$command_buffer_size;
                            VAR status: ost$status);

{    The purpose of this procedure is to test the local NAD's memory before loading microcode.
{
{    The test first checks the channel and device interface (mem_test_begin).  If successful,
{    the test then writes (mem_test_write) and reads (mem_test_read) the lower 32K words
{    of NAD memory several times, using the wired buffers; module RFM$PROCESS_PP_RESPONSE_FLAG
{    supplies and checks the test data in the buffers.
{
{    load_request_status: (input,output) This parameter points to the buffer containing
{      current status of the microcode loading process.
{
{    request_info:(input,output) This parameter specifies the position within the adaptable sequence
{      for adding the next physical command entry.
{
{    number_of_commands: (input,output) This parameter points to the counter containing the number
{      of commands in the adaptable sequence.
{
{    status: (output) This parameter returns the results of the test.

    VAR
        actual_buff_size: nlt$bm_buffer_length,
        buffer_index: rft$buffer_count,
        remaining_bytes: rft$bytes_transferred;

      CASE  load_request_status^.state  OF

      = rfc$lt_mem_test_begin =

        add_nad_di_start_up(request_info, number_of_commands, status);
        IF  NOT status.normal  THEN
          RETURN;
        IFEND;

      = rfc$lt_mem_test_write =

          buffer_index := 1;
          WHILE (buffer_index <= load_request_status^.number_of_buffers)  AND
            (load_request_status^.buffer_list^[buffer_index].byte_count > 0)  DO
            add_nad_transfer_piece(rfc$io_output,
              load_request_status^.buffer_list^[buffer_index].byte_count,
              load_request_status^.buffer_list^[buffer_index].buffer,
              load_request_status^.current_nad_address, request_info, number_of_commands, status);
            IF  NOT status.normal  THEN
              RETURN;
            IFEND;
            buffer_index := buffer_index + 1;
          WHILEND;

      = rfc$lt_mem_test_read =

        actual_buff_size := load_request_status^.buffer_list^[1].length;
        remaining_bytes := load_request_status^.nt_length - load_request_status^.nt_offset;
        buffer_index := 1;
        WHILE  (buffer_index <= load_request_status^.number_of_buffers)  AND
               (remaining_bytes > 0) DO
          IF  remaining_bytes >= actual_buff_size  THEN
            load_request_status^.buffer_list^[buffer_index].byte_count := actual_buff_size;
            remaining_bytes := remaining_bytes - actual_buff_size;
          ELSE
            load_request_status^.buffer_list^[buffer_index].byte_count := remaining_bytes;
            remaining_bytes := 0;
          IFEND;
          add_nad_transfer_piece(rfc$io_input,
            load_request_status^.buffer_list^[buffer_index].byte_count,
            load_request_status^.buffer_list^[buffer_index].buffer,
            load_request_status^.current_nad_address,
            request_info, number_of_commands, status);
          IF  NOT status.normal  THEN
            RETURN;
          IFEND;
          buffer_index := buffer_index + 1;
        WHILEND;

      ELSE  {  This should never happen  }

        osp$set_status_abnormal(rfc$product_id, rfe$abnormal_state, 'test request', status);
        osp$append_status_integer(osc$status_parameter_delimiter, $INTEGER(load_request_status^.state), 10,
          FALSE, status);
      CASEND;

  PROCEND test_nad_memory;
?? TITLE := '          RFP$MOVE_MC_TO_WIRED_BUFFERS' ??
?? EJECT ??
  PROCEDURE rfp$move_mc_to_wired_buffers(VAR load_request_status: ^rft$load_dump_status;
                                         VAR request_info: ^SEQ(*);
                                         VAR number_of_commands: ^0..rfc$command_buffer_size;
                                         VAR status: ost$status);

{    The purpose of this procedure is to move the microcode file image into the
{    network wired buffers.
{
{    load_request_buffer: (input,output) This parameter points to the buffer specifying the
{      current microcode load status information.  This routine moves as much data as possible
{      into the wired buffers and returns the current microcode load status.
{
{    request_info: (input,output) This paramter specifies the current location within the request sequence
{      to add the next command.  The physical command entry is added to the sequence and this pointer
{      upon return specifies the next entry location.
{
{    number_of_commands: (input,output) This parameter points to the counter in the sequence, which
{      maintains a count of the number of commands in the sequence.
{
{    status: (output) This parameter returns the results of the request.
{

    VAR
        ignore_status: ost$status,
        mc_init_prams: ^rft$mc_initialization_prams,
        buffer_index,
        last_buffer,
        current_buffer: rft$buffer_count,
        fill_bytes,
        remaining_bytes: rft$bytes_transferred,
        fill_word: [STATIC,READ, oss$job_paged_literal] 0..0ffffffffff(16) := 0,
        fill_buffer,
        current_ptr: ^CELL,
        microcode_mask,
        microcode_value: rft$nad_status_flags,
        state_integer_value: integer,
        continuing_process: boolean;

    current_buffer := 1;

  /load_states/
    REPEAT

      CASE  load_request_status^.state  OF
      = rfc$ls_begin_load =

        add_nad_di_start_up(request_info, number_of_commands, status);
        IF  NOT status.normal  THEN
          RETURN;
        IFEND;
        load_request_status^.state := rfc$ls_sending_microcode;
        load_request_status^.mc_offset := 0;
        continuing_process := TRUE;

      = rfc$ls_sending_microcode =

        continuing_process := FALSE;
        remaining_bytes := load_request_status^.mc_length - load_request_status^.mc_offset;
        current_ptr := i#ptr(load_request_status^.mc_offset, load_request_status^.mc_image);
        rfp$move_data_to_wired_buffs(load_request_status^.buffer_list^, current_ptr,
          load_request_status^.number_of_buffers, current_buffer, remaining_bytes);
        load_request_status^.mc_offset := load_request_status^.mc_length - remaining_bytes;

        buffer_index := 1;
        WHILE  (buffer_index <= load_request_status^.number_of_buffers)  AND
               (load_request_status^.buffer_list^[buffer_index].byte_count =
                load_request_status^.buffer_list^[buffer_index].length)  DO
          add_nad_transfer_piece(rfc$io_output,
            load_request_status^.buffer_list^[buffer_index].byte_count,
            load_request_status^.buffer_list^[buffer_index].buffer,
            load_request_status^.current_nad_address, request_info, number_of_commands, status);
          load_request_status^.buffer_list^[buffer_index].byte_count := 0;
          IF  NOT status.normal  THEN
            RETURN;
          IFEND;
          buffer_index := buffer_index +1;
        WHILEND;

        IF  (remaining_bytes = 0)  THEN
          IF  (buffer_index <= load_request_status^.number_of_buffers)  THEN

            {  NOTE - The NAD microcode must be zero filled to the next multiple of six bytes.

            fill_bytes := (6 - (load_request_status^.buffer_list^[current_buffer].byte_count MOD 6)) MOD 6;
            fill_buffer := #LOC(fill_word);
            last_buffer := current_buffer;
            rfp$move_data_to_wired_buffs(load_request_status^.buffer_list^, fill_buffer,
              load_request_status^.number_of_buffers, current_buffer, fill_bytes);
            IF  last_buffer <> current_buffer  THEN
              add_nad_transfer_piece(rfc$io_output,
                load_request_status^.buffer_list^[last_buffer].byte_count,
                load_request_status^.buffer_list^[last_buffer].buffer,
                load_request_status^.current_nad_address, request_info, number_of_commands, status);
              load_request_status^.buffer_list^[last_buffer].byte_count := 0;
              IF  NOT status.normal  THEN
                RETURN;
              IFEND;
            IFEND;
            continuing_process := TRUE;
          IFEND;
          load_request_status^.state := rfc$ls_sending_init_prams;
        IFEND;

      = rfc$ls_sending_init_prams =

        continuing_process := FALSE;
        IF  (#SIZE(rft$mc_initialization_prams) >
            ((load_request_status^.buffer_list^[current_buffer].length) -
             (load_request_status^.buffer_list^[current_buffer].byte_count)))  THEN
          add_nad_transfer_piece(rfc$io_output,
            load_request_status^.buffer_list^[current_buffer].byte_count,
            load_request_status^.buffer_list^[current_buffer].buffer,
            load_request_status^.current_nad_address, request_info, number_of_commands, status);
          load_request_status^.buffer_list^[current_buffer].byte_count := 0;
          IF  NOT status.normal  THEN
            RETURN;
          IFEND;
          current_buffer := current_buffer + 1;
          IF  current_buffer > load_request_status^.number_of_buffers  THEN
            RETURN;
          IFEND;
        IFEND;
        last_buffer := current_buffer;
        mc_init_prams  := #LOC(load_request_status^.init_prams);
        remaining_bytes := #SIZE(rft$mc_initialization_prams);
        rfp$move_data_to_wired_buffs(load_request_status^.buffer_list^, mc_init_prams,
          load_request_status^.number_of_buffers, current_buffer, remaining_bytes);
        add_nad_transfer_piece(rfc$io_output,
          load_request_status^.buffer_list^[last_buffer].byte_count,
          load_request_status^.buffer_list^[last_buffer].buffer,
          load_request_status^.current_nad_address, request_info, number_of_commands, status);
        load_request_status^.buffer_list^[last_buffer].byte_count := 0;
        IF  NOT status.normal  THEN
          RETURN;
        IFEND;
        load_request_status^.state := rfc$ls_send_go;
        continuing_process := TRUE;

      = rfc$ls_send_go =

        add_physical_function(rfc$di_go_nad, request_info, status);
        IF  NOT status.normal  THEN
          RETURN;
        IFEND;
        number_of_commands^ := number_of_commands^ + 1;
        microcode_mask := rfv$null_microcode_status;
        microcode_value := rfv$null_microcode_status;
        microcode_mask.response := rfc$nad_response_mask;
        microcode_value.response := rfc$nr_acknowledge;
        add_nad_status_request(rfc$sk_microcode_status, microcode_mask, microcode_value,
          request_info, status);
        IF  NOT status.normal  THEN
          RETURN;
        IFEND;
        number_of_commands^ := number_of_commands^ + 1;
        pmp$get_microsecond_clock(load_request_status^.time_of_first_go, ignore_status);

        load_request_status^.state := rfc$ls_go_sent;
        continuing_process := FALSE;

      = rfc$ls_go_sent =

        microcode_mask := rfv$null_microcode_status;
        microcode_value := rfv$null_microcode_status;
        microcode_mask.response := rfc$nad_response_mask;
        microcode_value.response := rfc$nr_acknowledge;
        add_nad_status_request(rfc$sk_microcode_status, microcode_mask, microcode_value,
          request_info, status);
        number_of_commands^ := number_of_commands^ + 1;
        continuing_process := FALSE;

      = rfc$ls_get_mc_status =

        rfp$form_obtain_status_req(0, 0, FALSE, request_info, status);
        continuing_process := FALSE;

      ELSE  {  This should never happen  }

        osp$set_status_abnormal(rfc$product_id, rfe$abnormal_state, 'load request', status);
        state_integer_value := $INTEGER(load_request_status^.state);
        osp$append_status_integer(osc$status_parameter_delimiter, state_integer_value, 10,
          FALSE, status);
        continuing_process := FALSE;
      CASEND;

    UNTIL  NOT continuing_process;

  PROCEND rfp$move_mc_to_wired_buffers;
?? NEWTITLE := '            RFP$FORM_OBTAIN_STATUS_REQ' ??
?? EJECT ??
  PROCEDURE  [XDCL] rfp$form_obtain_status_req(path_number: rft$path_identifier;
                                               retry_count: rft$retry_count;
                                               remote_status_primed: BOOLEAN;
                                           VAR request_buf: ^SEQ(*);
                                           VAR status: ost$status);

{    The purpose of this routine is to form a request to obtain the general status entry
{    from the specified nad.
{
{    path_number: (input) This parameter specifies the path number to be used to solicit the NAD
{      general status information from.  IF zero, the general status from the local NAD, identified
{      by the logical unit number, is obtained.  If non-zero, a remote general status is requested
{      from the remote NAD associated with the path identied by the path identifier.
{
{    retry_count: (input) This parameter specifies the number of retries to be attempted to
{      obtain a remote NAD general status.  This parameter is only meaningful if the corresponding
{      path identifier is non-zero.
{
{    remote_status_primed: (input) This parameter specifies whether or not the read remote status
{      has already been issued for the corresponding path.  This parameter is only meaningful if
{      the corresponding path identifier is non-zero.
{
{    request_buf: (input,output) This parameter contians a pointer to an adaptable sequence
{      which is to contain the ring 1 request.
{
{    status: (output) This parameter specifies the results of the request.

    VAR
        command_identifier: ^rft$logical_commands,
        retry_count_p: ^rft$retry_count,
        status_primed: ^BOOLEAN,
        path_id: ^rft$path_identifier;

    status.normal := TRUE;

    RESET request_buf;
    NEXT  command_identifier  IN  request_buf;
    IF  command_identifier = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$FORM_OBTAIN_STATUS_REQ', status);
      RETURN;
    IFEND;
    command_identifier^ := rfc$lc_obtain_nad_general_stat;
    NEXT  status_primed  IN  request_buf;
    IF  status_primed = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'primed flag too big',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$FORM_OBTAIN_STATUS_REQ', status);
      RETURN;
    IFEND;
    status_primed^ := remote_status_primed;
    NEXT  path_id  IN  request_buf;
    IF  path_id = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'path id too big',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$FORM_OBTAIN_STATUS_REQ', status);
      RETURN;
    IFEND;
    path_id^ := path_number;
    NEXT  retry_count_p  IN  request_buf;
    IF  retry_count_p = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'retry count too big',
        status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$FORM_OBTAIN_STATUS_REQ', status);
      RETURN;
    IFEND;
    retry_count_p^ := retry_count;

  PROCEND rfp$form_obtain_status_req;
?? OLDTITLE ??
?? OLDTITLE ??
?? OLDTITLE ??
?? TITLE := '      LOAD AND DUMP HELPER ROUTINES' ??
?? NEWTITLE := '        ADD_PHYSICAL_FUNCTION' ??
?? EJECT ??
  PROCEDURE  add_physical_function(nad_function: rft$nad_function_codes;
                               VAR request_info: ^SEQ(*);
                               VAR status: ost$status);

{    The purpose of this routine is to add a function nad entry into the physical command list of the
{    NAD request block.
{
{    nad_function: (input) This parameter specifies the NAD function to be issued.
{
{    request_info: (input,output) This paramter specifies the current location within the request sequence
{      to add the next function.  The physical command entry is added to the sequence and this pointer
{      upon return specifies the next entry location.
{
{    status: (output) This parameter returns the results of the request.


    VAR
        function_code: ^rft$nad_function_codes,
        physical_command: ^rft$physical_commands;

    NEXT  physical_command  IN  request_info;
    IF  physical_command = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'ADD_PHYSICAL_FUNCTION', status);
      RETURN;
    IFEND;
    physical_command^ := rfc$pc_function_nad;
    NEXT  function_code  IN  request_info;
    IF  function_code = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'function code too big', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'ADD_PHYSICAL_FUNCTION', status);
      RETURN;
    IFEND;
    function_code^ := nad_function;

  PROCEND add_physical_function;
?? TITLE := '        ADD_NAD_STATUS_REQUEST' ??
?? EJECT ??
  PROCEDURE  add_nad_status_request(nad_status_kind: rft$nad_status_kinds;
                                    nad_status_mask: rft$nad_status_flags;
                                    nad_status_value: rft$nad_status_flags;
                                VAR request_info: ^SEQ(*);
                                VAR status: ost$status);

{    The purpose of this routine is to add a function nad entry into the physical command list of the
{    NAD request block.
{
{    nad_status_kind: (input) This parameter specifies the type of NAD status.
{
{    nad_status_mask: (input) This parameter specifies the NAD status mask.
{
{    nad_status_value: (input) This parameter specifies the expected NAD status value.
{
{    request_info: (input,output) This paramter specifies the current location within the request sequence
{      to add the next function.  The physical command entry is added to the sequence and this pointer
{      upon return specifies the next entry location.
{
{    status: (output) This parameter returns the results of the request.


    VAR
        nad_status: ^rft$nad_status_flags,
        physical_command: ^rft$physical_commands;

    NEXT  physical_command  IN  request_info;
    IF  physical_command = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'ADD_NAD_STATUS_REQUEST', status);
      RETURN;
    IFEND;
    CASE  nad_status_kind  OF
    = rfc$sk_microcode_status =
      physical_command^ := rfc$pc_microcode_status;
    = rfc$sk_hardware_status =
      physical_command^ := rfc$pc_hardware_status;
    CASEND;
    NEXT  nad_status  IN  request_info;
    IF  nad_status = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'status mask too big', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'ADD_NAD_STATUS_REQUEST', status);
      RETURN;
    IFEND;
    nad_status^ := nad_status_mask;
    NEXT  nad_status  IN  request_info;
    IF  nad_status = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'status value too big', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'ADD_NAD_STATUS_REQUEST', status);
      RETURN;
    IFEND;
    nad_status^ := nad_status_value;

  PROCEND add_nad_status_request;
?? TITLE := '        ADD_XFR_LGTH_ADDR' ??
?? EJECT ??
  PROCEDURE  add_xfr_lgth_addr(transfer_address: rft$transfer_lgth_addr;
                               transfer_length: rft$transfer_lgth_addr;
                           VAR request_info: ^SEQ(*);
                           VAR status: ost$status);

{    The purpose of this routine is to add a function nad entry into the physical command list of the
{    NAD request block.
{
{    transfer_address: (input) This parameter specifies the NAD address to start sending/receiving the data.
{
{    transfer_length: (input) This parameter specifies the number of NAD words being sent/received.
{
{    request_info: (input,output) This paramter specifies the current location within the request sequence
{      to add the next command.  The physical command entry is added to the sequence and this pointer
{      upon return specifies the next entry location.
{
{    status: (output) This parameter returns the results of the request.


    VAR
        xfr_lgth_addr: ^rft$transfer_lgth_addr,
        physical_command: ^rft$physical_commands;

    NEXT  physical_command  IN  request_info;
    IF  physical_command = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'ADD_XFR_LGTH_ADDR', status);
      RETURN;
    IFEND;
    physical_command^ := rfc$pc_set_addr_and_length;
    NEXT  xfr_lgth_addr  IN  request_info;
    IF  xfr_lgth_addr = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'xfer length too big', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'ADD_XFR_LGTH_ADDR', status);
      RETURN;
    IFEND;
    xfr_lgth_addr^ := transfer_address;
    NEXT  xfr_lgth_addr  IN  request_info;
    IF  xfr_lgth_addr = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'xfer address too big', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'ADD_XFR_LGTH_ADDR', status);
      RETURN;
    IFEND;
    xfr_lgth_addr^ := transfer_length;

  PROCEND add_xfr_lgth_addr;
?? TITLE := '        ADD_IO_BUFFER' ??
?? EJECT ??
  PROCEDURE  add_io_buffer(io_type: rft$io_types;
                           buff_pva: ^cell;
                           buff_length: rft$transfer_length;
                       VAR request_info: ^SEQ(*);
                       VAR status: ost$status);

{    The purpose of this routine is to add a function nad entry into the physical command list of the
{    NAD request block.
{
{    io_type: (input) This parameter specifies the type of I/O performed.
{
{    buff_pva: (input) This parameter specifies the pointer to the data buffer.
{
{    buff_length: (input) This parameter specifies the length of the data buffer (in 8-bit bytes).
{
{    request_info: (input,output) This paramter specifies the current location within the request sequence
{      to add the next command.  The physical command entry is added to the sequence and this pointer
{      upon return specifies the next entry location.
{
{    status: (output) This parameter returns the results of the request.


    VAR
        pva_ptr: ^^cell,
        length_ptr: ^rft$transfer_length,
        physical_command: ^rft$physical_commands;

    NEXT  physical_command  IN  request_info;
    IF  physical_command = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'ADD_IO_BUFFER', status);
      RETURN;
    IFEND;
    CASE  io_type  OF
    = rfc$io_input =
      physical_command^ := rfc$pc_input_8_in_8_mode;
    = rfc$io_output =
      physical_command^ := rfc$pc_output_8_in_8_mode;
    CASEND;
    NEXT  length_ptr  IN  request_info;
    IF  length_ptr = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'pva length too big', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'ADD_IO_BUFFER', status);
      RETURN;
    IFEND;
    length_ptr^ := buff_length;
    NEXT  pva_ptr  IN  request_info;
    IF  pva_ptr = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'pva too big', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'ADD_IO_BUFFER', status);
      RETURN;
    IFEND;
    pva_ptr^ := buff_pva;

  PROCEND add_io_buffer;
?? TITLE := '        ADD_NAD_DI_START_UP' ??
?? EJECT ??
  PROCEDURE  add_nad_di_start_up(VAR request_info: ^SEQ(*);
                                 VAR number_of_commands: ^0..rfc$command_buffer_size;
                                 VAR status: ost$status);

{    The purpose of this procedure is to generate a direct NAD I/O request for the PP driver to
{    to process.
{
{    request_info: (input,output) This paramter specifies the current location within the request sequence
{      to add the next command.  The physical command entry is added to the sequence and this pointer
{      upon return specifies the next entry location.
{
{    number_of_commands: (input,output) This parameter points to the counter in the sequence, which
{      maintains a count of the number of commands in the sequence.
{
{    status: (output) This parameter returns the results of the request.

    VAR
        hardware_mask,
        hardware_value: rft$nad_status_flags;

    add_physical_function(rfc$di_interface_master_clear, request_info, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;
    number_of_commands^ := number_of_commands^ + 1;
    add_physical_function(rfc$di_clear_parity_error, request_info, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;
    number_of_commands^ := number_of_commands^ + 1;
    hardware_mask := rfv$null_hardware_status;
    hardware_value := rfv$null_hardware_status;
    hardware_mask.device_not_enabled := TRUE;
    add_nad_status_request(rfc$sk_hardware_status, hardware_mask, hardware_value, request_info, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;
    number_of_commands^ := number_of_commands^ + 1;
    add_physical_function(rfc$di_processor_master_clear, request_info, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;
    number_of_commands^ := number_of_commands^ + 1;

  PROCEND add_nad_di_start_up;
?? TITLE := '        ADD_NAD_TRANSFER_PIECE' ??
?? EJECT ??
  PROCEDURE  add_nad_transfer_piece(io_type: rft$io_types;
                                    bytes_to_transfer: rft$transfer_length;
                                    current_buffer: ^cell;
                                VAR nad_address: rft$nad_memory_size;
                                VAR request_info: ^SEQ(*);
                                VAR number_of_commands: ^0..rfc$command_buffer_size;
                                VAR status: ost$status);

{    The purpose of this procedure is to generate a direct NAD I/O request for the PP driver to
{    to process.
{
{    bytes_transferred: (input) This parameter specifies the number of bytes to be transferred.
{
{    current_buffer: (input) This parameter points to the buffer that is to be transferred.
{
{    nad_address: (input,output) This parameter specifies the starting address, within NAD memory, to
{      transfer the data.  Upon exit this parameter contains the next nad address.
{
{    request_info: (input,output) This paramter specifies the current location within the request sequence
{      to add the next command.  The physical command entry is added to the sequence and this pointer
{      upon return specifies the next entry location.
{
{    number_of_commands: (input,output) This parameter points to the counter in the sequence, which
{      maintains a count of the number of commands in the sequence.
{
{    status: (output) This parameter returns the results of the request.

    VAR
        microcode_mask,
        microcode_value: rft$nad_status_flags,
        transfer_length,
        transfer_address: rft$transfer_lgth_addr;

    add_physical_function(rfc$di_set_addr_and_length, request_info, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;
    number_of_commands^ := number_of_commands^ + 1;
    transfer_length := rfv$initial_transfer_length;
    transfer_address := rfv$initial_transfer_address;
    transfer_address.lower_8_bits := nad_address MOD 256;
    transfer_address.upper_8_bits := nad_address DIV 256;
    transfer_length.lower_8_bits := (bytes_to_transfer DIV 2) MOD 256;
    transfer_length.upper_8_bits := (bytes_to_transfer DIV 2) DIV 256;
    add_xfr_lgth_addr(transfer_address, transfer_length, request_info, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;
    number_of_commands^ := number_of_commands^ + 1;
    add_io_buffer(io_type, current_buffer, bytes_to_transfer, request_info, status);
    IF  NOT status.normal  THEN
      RETURN;
    IFEND;
    number_of_commands^ := number_of_commands^ + 1;
    IF (nad_address + (bytes_to_transfer DIV 2)) > rfc$max_nad_memory_size THEN
      nad_address := 0;
    ELSE
      nad_address := nad_address + (bytes_to_transfer DIV 2);
    IFEND;

  PROCEND  add_nad_transfer_piece;
?? OLDTITLE ??
?? TITLE := '      RFP$LOCAL_NAD_DUMP' ??
?? EJECT ??
  PROCEDURE  [XDCL] rfp$local_nad_dump(nad_index: rft$local_nads;
                                   VAR status: ost$status);

*copyc rfh$local_nad_dump

    VAR
        request_info: ^SEQ(*),
        dump_file_open: BOOLEAN,
        ignore_status: ost$status,
        dump_request_status: ^rft$load_dump_status;

    status.normal := TRUE;
    dump_file_open := FALSE;

    ALLOCATE  dump_request_status  IN  osv$task_private_heap^;
    IF  dump_request_status = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'task private', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$LOCAL_NAD_DUMP', status);
      RETURN;
    IFEND;
    ALLOCATE  dump_request_status^.buffer_list : [1..rfc$max_load_dump_buffers]  IN  osv$task_private_heap^;
    IF  dump_request_status^.buffer_list = NIL  THEN
      FREE  dump_request_status  IN  osv$task_private_heap^;
      osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'task private', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$LOCAL_NAD_DUMP', status);
      RETURN;
    IFEND;
    dump_request_status^.number_of_buffers := 0;

  /main_section/
    BEGIN
      get_dump_file(rfv$status_table.local_nads^[nad_index].maintenance_selections.dump_disposition,
        rfv$status_table.local_nads^[nad_index].name, dump_request_status^.mc_image,
        dump_request_status^.mc_lfn, dump_request_status^.mc_file_id, status);
      IF  NOT status.normal  THEN
        EXIT /main_section/;
      IFEND;
      dump_file_open := TRUE;
      dump_request_status^.number_of_buffers := rfc$max_load_dump_buffers;
      rfp$reserve_wired_buffers(dump_request_status^.buffer_list^, dump_request_status^.number_of_buffers);
      IF  dump_request_status^.number_of_buffers = 0  THEN
        osp$set_status_abnormal(rfc$product_id, rfe$heap_exhausted, 'network wired', status);
        osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$LOCAL_NAD_DUMP', status);
        EXIT /main_section/;
      IFEND;

      dump_request_status^.state := rfc$ds_begin_dump;
      dump_request_status^.current_nad_address := 0;

      { The request buffer size is set to two times the command buffer size.  This number was derived from
      { from the fact that each request size is no more than two times the actual command size.

      PUSH  request_info : [[REP  2*rfc$command_buffer_size OF integer]];
      RESET request_info;

      rfp$build_dump_request(dump_request_status, request_info, status);
      IF  NOT status.normal  THEN
        EXIT /main_section/;
      IFEND;
      rfp$queue_request(nad_index, 1, rfc$unit_request, rfc$rk_local_nad_dump, dump_request_status,
        request_info, status);

    END  /main_section/;

    IF  NOT status.normal  THEN
      IF  dump_file_open  THEN
        fsp$close_file(dump_request_status^.mc_file_id, ignore_status);
        amp$return(dump_request_status^.mc_lfn, ignore_status);
      IFEND;
      IF  dump_request_status^.number_of_buffers <> 0  THEN
        rfp$release_wired_buffers(dump_request_status^.buffer_list^, dump_request_status^.number_of_buffers);
      IFEND;
      FREE  dump_request_status^.buffer_list  IN  osv$task_private_heap^;
      FREE  dump_request_status  IN  osv$task_private_heap^;
    IFEND;

  PROCEND rfp$local_nad_dump;
?? NEWTITLE := '        GET_DUMP_FILE' ??
?? EJECT ??
  PROCEDURE get_dump_file(dump_disposition: rft$dump_disposition;
                          nad_name: rft$component_name;
                      VAR dump_image: ^CELL;
                      VAR dump_lfn: amt$local_file_name;
                      VAR dump_fid: amt$file_identifier;
                      VAR status: ost$status);

{    The purpose of this request is to create a file to dump the nad memory
{    image onto.
{
{    dump_disposition: (input) This paramter specifies the destination of the nad
{      memory image dump.  This determines the file to contain the NAD dump.
{
{    nad_name: (input) This parameter defines the name of the nad being dumped.
{      This determines the file name to be used to save the nad dump image.
{
{    dump_image: (output) This parameter returns a pointer to the dump
{      file segment.
{
{    dump_lfn: (output) This parameter returns the local file name of the dump
{      file image.
{
{    dump_fid: (output) This parameter returns the file identifier of the
{      open dump file.
{
{    status: (output) This paramter returns the results of the request.  A status of
{      normal means that the microcode file was found and has been opened for segment
{      access.

    VAR
        ignore_status: ost$status,
        segment_ptr: amt$segment_pointer,
        file_attributes: ^fst$file_cycle_attributes,
        unique_name: ost$unique_name,
        catalog_path,
        file_path: ^pft$path,
        password: pft$name,
        retention: pft$retention,
        cycle_selector: pft$cycle_selector;

    pmp$generate_unique_name(unique_name, ignore_status);
    dump_lfn := unique_name.value;
    IF  (dump_disposition = rfc$dd_save_last)  OR
        (dump_disposition = rfc$dd_save_all)  THEN
      PUSH catalog_path : [1..4];
      catalog_path^[1] := rfc$rhfam_family_name;
      catalog_path^[2] := rfc$rhfam_master_catalog;
      catalog_path^[3] := rfc$rhfam_sub_catalog;
      catalog_path^[4] := rfc$dump_sub_catalog;
      pfp$define_catalog(catalog_path^, status);
      IF  (NOT status.normal) AND (status.condition <> pfe$name_already_subcatalog)  THEN
        RETURN;
      IFEND;

      PUSH file_path : [1..5];
      file_path^[1] := rfc$rhfam_family_name;
      file_path^[2] := rfc$rhfam_master_catalog;
      file_path^[3] := rfc$rhfam_sub_catalog;
      file_path^[4] := rfc$dump_sub_catalog;
      file_path^[5] := nad_name;
      password := rfc$password;

      IF  dump_disposition = rfc$dd_save_last  THEN
        cycle_selector.cycle_option := pfc$specific_cycle;
        cycle_selector.cycle_number := 1;
        pfp$purge(file_path^, cycle_selector, password, ignore_status);
      ELSE
        cycle_selector.cycle_option := pfc$highest_cycle;
      IFEND;
      retention := 999;
      pfp$define(dump_lfn, file_path^, cycle_selector, password, retention, pfc$no_log, status);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
    IFEND;

    PUSH file_attributes : [1..1];
    file_attributes^[1].selector := fsc$ring_attributes;
    file_attributes^[1].ring_attributes.r1 := osc$user_ring_2;
    file_attributes^[1].ring_attributes.r2 := osc$user_ring_2;
    file_attributes^[1].ring_attributes.r3 := osc$user_ring_2;
    fsp$open_file(dump_lfn, amc$segment, NIL, file_attributes, NIL, NIL, NIL,
      dump_fid, status);
    IF  NOT status.normal  THEN
      amp$return(dump_lfn, ignore_status);
      RETURN;
    IFEND;

    amp$get_segment_pointer(dump_fid, amc$cell_pointer, segment_ptr, status);
    IF  status.normal  THEN
      dump_image := segment_ptr.cell_pointer;
    ELSE
      fsp$close_file(dump_fid, ignore_status);
      amp$return(dump_lfn, ignore_status);
    IFEND;

  PROCEND get_dump_file;
?? TITLE := '        RFP$BUILD_DUMP_REQUEST' ??
?? EJECT ??
  PROCEDURE  [XDCL]  rfp$build_dump_request(VAR dump_request_status: ^rft$load_dump_status;
                                            VAR request_info: ^SEQ(*);
                                            VAR status: ost$status);

{    The purpose of this routine is to build the request for dumping the local NAD
{    memory image.
{
{    dump_request_buffer: (input,output) This parameter points to the buffer specifying the
{      current nad memory image dump status information.
{
{    request_info: (input,output) This parameter specifies an adaptable sequence where the
{      request is to be placed.  Upon exit the sequence contains the dump request functions.
{
{    status: (output) This parameter returns the results of the request.


     CONST
         nad_memory_bank_size = 4000(16);        {  Number of 16-bit words  }

    VAR
        memory_words_to_reset,
        memory_remaining_in_bank: INTEGER,
        reset_to_multiple_of_three: BOOLEAN,
        buff_index: 0..rfc$max_load_dump_buffers,
        buffer_size: nlt$bm_buffer_length,
        number_of_commands: ^0..rfc$command_buffer_size,
        command_identifier: ^rft$logical_commands,
        hardware_mask,
        hardware_value: rft$nad_status_flags,
        physical_command: ^rft$physical_commands;

    status.normal := TRUE;

    NEXT  command_identifier  IN  request_info;
    IF  command_identifier = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id too big', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$BUILD_DUMP_REQUEST', status);
      RETURN;
    IFEND;
    command_identifier^ := rfc$lc_process_physical_command;
    NEXT  number_of_commands  IN  request_info;
    IF  number_of_commands = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command count too big', status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'RFP$BUILD_DUMP_REQUEST', status);
      RETURN;
    IFEND;
    number_of_commands^ := 0;

    CASE  dump_request_status^.state OF
    = rfc$ds_begin_dump =
      dump_request_status^.state := rfc$ds_continue_dump;
      add_physical_function(rfc$di_interface_master_clear, request_info, status);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
      number_of_commands^ := number_of_commands^ + 1;
      hardware_mask := rfv$null_hardware_status;
      hardware_value := rfv$null_hardware_status;
      hardware_mask.device_not_enabled := TRUE;
      add_nad_status_request(rfc$sk_hardware_status, hardware_mask, hardware_value, request_info, status);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
      number_of_commands^ := number_of_commands^ + 1;
      add_physical_function(rfc$di_step_processor, request_info, status);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
      number_of_commands^ := number_of_commands^ + 1;

    = rfc$ds_continue_dump =
      add_physical_function(rfc$di_interface_master_clear, request_info, status);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
      number_of_commands^ := number_of_commands^ + 1;
      hardware_mask := rfv$null_hardware_status;
      hardware_value := rfv$null_hardware_status;
      hardware_mask.nad_processor_not_running := TRUE;
      hardware_value.nad_processor_not_running := TRUE;
      add_nad_status_request(rfc$sk_hardware_status, hardware_mask, hardware_value, request_info, status);
      IF  NOT status.normal  THEN
        RETURN;
      IFEND;
      number_of_commands^ := number_of_commands^ + 1;

      dump_request_status^.buffers_in_use := 0;

    /queue_buffers/
      FOR  buff_index := 1  TO  dump_request_status^.number_of_buffers  DO

        {  To prevent NAD I/O errors, the PP cannot attempt a read beyond the NAD memory.
        {  Therefore each read operation should stop at a NAD memory boundary.

        IF dump_request_status^.buffer_list^[buff_index].length > rfc$max_load_dump_buffer_size THEN
          buffer_size := (rfc$max_load_dump_buffer_size DIV 6) * 6;
        ELSE
          buffer_size := (dump_request_status^.buffer_list^[buff_index].length DIV 6) * 6;
        IFEND;

        dump_request_status^.buffer_list^[buff_index].length := buffer_size;

        reset_to_multiple_of_three := FALSE;
        memory_remaining_in_bank := nad_memory_bank_size -
          (dump_request_status^.current_nad_address MOD nad_memory_bank_size);
        IF  (memory_remaining_in_bank * 2) < (buffer_size + 6)  THEN
          IF  memory_remaining_in_bank = ((memory_remaining_in_bank DIV 3) * 3)  THEN
            buffer_size := memory_remaining_in_bank * 2;
          ELSE
            buffer_size := ((memory_remaining_in_bank * 2) DIV 6) * 6;
            reset_to_multiple_of_three := TRUE;
          IFEND;
        IFEND;
        IF  (dump_request_status^.current_nad_address + (buffer_size DIV 2)) > rfc$max_nad_memory_size  THEN
          dump_request_status^.state := rfc$ds_end_of_dump;
        IFEND;
        add_nad_transfer_piece(rfc$io_input, buffer_size,
          dump_request_status^.buffer_list^[buff_index].buffer, dump_request_status^.current_nad_address,
          request_info, number_of_commands, status);
        IF  NOT status.normal  THEN
          RETURN;
        IFEND;
        dump_request_status^.buffer_list^[buff_index].byte_count := buffer_size;
        dump_request_status^.buffer_list^[buff_index].current_offset := 0;
        dump_request_status^.buffers_in_use := dump_request_status^.buffers_in_use + 1;
        IF  dump_request_status^.state = rfc$ds_end_of_dump  THEN
          EXIT /queue_buffers/;
        IFEND;
        IF  reset_to_multiple_of_three  THEN
          memory_words_to_reset := ((3 - (memory_remaining_in_bank MOD 3)) MOD 3);
          dump_request_status^.current_nad_address := dump_request_status^.current_nad_address -
            memory_words_to_reset;
          dump_request_status^.buffer_list^[buff_index].byte_count :=
            dump_request_status^.buffer_list^[buff_index].byte_count - (memory_words_to_reset*2);
        IFEND;
      FOREND /queue_buffers/;

    ELSE
      {  dump is complete, return normal status.
    CASEND;

  PROCEND rfp$build_dump_request;
?? OLDTITLE ??
?? OLDTITLE ??
?? TITLE := '    TERMINATION_PHASE' ??
?? EJECT ??
  PROCEDURE termination_phase;

{    The purpose of this routine is to perform the various clean up
{    activities to allow the access method to gracefully go away.
{    This routine should only be called once the user has validated that
{    this is the system routine and subsequently plugged the corresponding
{    global system task id in the rfv$system_task_id variable.


    VAR
        request_active: BOOLEAN,
        client_entry: ^rft$rhfam_client_table_entry,
        server_entry: ^rft$rhfam_server_table_entry,
        connection_descriptor: rft$connection_descriptor,
        nad_index: rft$local_nads;

    {  The system task status must be set to down prior to removing the tables.

    rfv$status_table.system_task_is_up := FALSE;
    #SPOIL(rfv$status_table.system_task_is_up);

    {  Clean up all local NAD connections and corresponding data.

    IF   rfv$status_table.location <> NIL  THEN
      IF  rfv$status_table.local_nads <> NIL  THEN
        FOR  nad_index := 1 TO UPPERBOUND(rfv$status_table.local_nads^)  DO
          IF  rfv$status_table.local_nads^[nad_index].pp[1].pp_state = rfc$pps_normal  THEN
            rfp$unconditionally_status(rfv$status_table.local_nads^[nad_index].logical_unit_number);
            clear_incoming_connects(nad_index);
            clear_connection_entries(nad_index, '       ', rfc$system_task_shutdown);
            release_all_control_messages(nad_index);
            IF  rfv$status_table.local_nads^[nad_index].current_status.device_status = rfc$es_on  THEN
              connection_descriptor.nad_index := nad_index;
              connection_descriptor.network_path := 0; {  purge all paths  }
              purge_path(connection_descriptor);
            IFEND;
          IFEND;
        FOREND;

        {  Make sure all requests have completed.

        REPEAT
          request_active := FALSE;
          syp$cycle;
          rfp$process_pp_response_flag(rfc$pp_response_available);
          FOR  nad_index := 1 TO UPPERBOUND(rfv$status_table.local_nads^)  DO
            IF  rfv$status_table.local_nads^[nad_index].requests_posted <> 0  THEN
              request_active := TRUE;
            IFEND;
          FOREND;
        UNTIL  NOT request_active;

        rfp$check_event_list(0, TRUE);

        idle_the_pps;
        release_elements;
        rfp$release_request_buffers;
      IFEND;

      rfp$lock_table(rfv$rhfam_client_table.lock);
      client_entry := rfv$rhfam_client_table.first_entry;
      WHILE  client_entry <> NIL  DO
        client_entry^.abort_connections := FALSE;
        client_entry := client_entry^.next_entry;
      WHILEND;
      rfp$unlock_table(rfv$rhfam_client_table.lock);

      rfp$lock_table(rfv$rhfam_server_table.lock);
      server_entry := rfv$rhfam_server_table.first_entry;
      WHILE  server_entry <> NIL  DO
        server_entry^.abort_connections := FALSE;
        server_entry := server_entry^.next_entry;
      WHILEND;
      rfp$unlock_table(rfv$rhfam_server_table.lock);

      WHILE  rfv$status_table.display_active <> tmv$null_global_task_id  DO
        syp$cycle;
      WHILEND;

      IF  rfv$status_table.local_nads <> NIL  THEN
        FOR  nad_index := 1 TO UPPERBOUND(rfv$status_table.local_nads^)  DO
          IF  rfv$status_table.local_nads^[nad_index].connection_table <> NIL  THEN
            FREE rfv$status_table.local_nads^[nad_index].connection_table IN nav$network_paged_heap^;
          IFEND;
        FOREND;
        rfv$status_table.local_nads := NIL;
      IFEND;

      FREE rfv$status_table.location IN nav$network_paged_heap^;
    IFEND;

    rfp$set_system_task_id(FALSE);     {  This clears the system task id  }

  PROCEND termination_phase;
?? NEWTITLE := '      CLEAR_INCOMING_CONNECTS' ??
?? EJECT ??
  PROCEDURE clear_incoming_connects(nad_index: rft$local_nads);

{    The purpose of this routine is clear out all incoming connects that have
{    not been assigned to a connection file.
{
{    nad_index: (input) This parameter specifies the local nad, through which the corresponding
{      connections have been received.

    VAR
        current_server_entry: ^rft$rhfam_server_table_entry,
        job_index: INTEGER,
        previous_connect,
        current_connect,
        connect_to_purge: ^rft$incoming_connect;

    rfp$lock_table(rfv$rhfam_server_table.lock);
    current_server_entry := rfv$rhfam_server_table.first_entry;
    WHILE  current_server_entry <> NIL  DO
      current_connect := current_server_entry^.incoming_connect;
      previous_connect := NIL;
      WHILE  current_connect <> NIL  DO
        IF  (current_connect^.connection_descriptor.nad_index = nad_index)  THEN
          connect_to_purge := current_connect;
          current_connect := current_connect^.next_entry;
          FREE connect_to_purge IN nav$network_paged_heap^;
          current_server_entry^.current_connections := current_server_entry^.current_connections - 1;
          IF  previous_connect = NIL  THEN
            current_server_entry^.incoming_connect := current_connect;
          ELSE
            previous_connect^.next_entry := current_connect;
          IFEND;
        ELSE
          previous_connect := current_connect;
          current_connect := current_connect^.next_entry;
        IFEND;
      WHILEND;
      current_server_entry := current_server_entry^.next_entry;
    WHILEND;
    rfp$unlock_table(rfv$rhfam_server_table.lock);

  PROCEND clear_incoming_connects;
?? TITLE := '      CLEAR_CONNECTION_ENTRIES' ??
?? EJECT ??
  PROCEDURE clear_connection_entries(nad_index: rft$local_nads;
                                     application_name: rft$application_name;
                                     reason_code: rft$connection_states);

{    The purpose of this routine is to set the state of all connection entries, currently
{    active in the specified NAD, to a non-viable state.  This should prevent further
{    network access by the corresponding connection.
{
{    nad_index: (input) This parameter specifies the corresponding nad.
{
{    applicaition_name: (input) This parameter specifies the name of the
{      application that must be matched if the reason code is rfc$terminated.
{
{    reason_code: (input) This parameter specifies the reason for the removal of the
{      connection entry.  The reason code is essentially the new state of the connection.

    TYPE
        terminated_appl_connects = RECORD
          next_entry: ^terminated_appl_connects,
          appl_kind: rft$application_kinds,
          appl_name: rft$application_name,
        RECEND;

    VAR
        local_nad: ^rft$local_nad_entry,
        connection_entry: ^rft$connection_entry,
        appl_connect_terminated,
        appl_term_list: ^terminated_appl_connects,
        client_entry: ^rft$rhfam_client_table_entry,
        server_entry: ^rft$rhfam_server_table_entry,
        entry_cleared: BOOLEAN,
        connect_count,
        con_index: rft$concurrent_connections;

    connect_count := 0;
    appl_term_list := NIL;
    local_nad := ^rfv$status_table.local_nads^[nad_index];
    rfp$lock_table(local_nad^.connection_table_lock);
    FOR  con_index := 1  TO  UPPERBOUND(local_nad^.connection_table^)  DO
      connection_entry := local_nad^.connection_table^[con_index].connection_table_entry;
      IF  connection_entry <> NIL  THEN
        rfp$lock_table(connection_entry^.lock);
        IF  reason_code = rfc$terminated  THEN
          IF  connection_entry^.application_entry_p^.application_name = application_name  THEN
            connection_entry^.connection_attributes.connection_status.connection_state := reason_code;
            connection_entry^.connection_attributes.connection_status.reason_for_termination :=
              rfc$local_termination;
          IFEND;
        ELSE
          connection_entry^.connection_attributes.connection_status.connection_state := reason_code;
          connection_entry^.connection_descriptor.nad_index := 0;
          connection_entry^.connection_descriptor.logical_unit := 0;
          connection_entry^.connection_descriptor.network_path := 0;
          connect_count := connect_count + 1;
          PUSH  appl_connect_terminated;
          appl_connect_terminated^.appl_name := connection_entry^.application_entry_p^.application_name;
          appl_connect_terminated^.appl_kind := connection_entry^.application_entry_p^.application_kind;
          appl_connect_terminated^.next_entry := appl_term_list;
          appl_term_list := appl_connect_terminated;
        IFEND;
        rfp$unlock_table(connection_entry^.lock);
      IFEND;
      IF  reason_code <> rfc$terminated  THEN
        local_nad^.connection_table^[con_index].connection_table_entry := NIL;
        local_nad^.connection_table^[con_index].connection_state := rfc$ps_unused;
        local_nad^.connection_table^[con_index].connection_clarifier := rfc$pcu_empty;
        local_nad^.connection_table^[con_index].processing_incoming_connect := FALSE;
      IFEND;
    FOREND;
    rfp$unlock_table(local_nad^.connection_table_lock);
    rfp$lock_table(rfv$status_table.lock);
    local_nad^.connections_established := local_nad^.connections_established - connect_count;
    rfp$unlock_table(rfv$status_table.lock);

    WHILE  appl_term_list <> NIL  DO
      entry_cleared := FALSE;
      rfp$lock_table(rfv$rhfam_server_table.lock);
      server_entry := rfv$rhfam_server_table.first_entry;
    /find_matching_server/
      WHILE  server_entry <> NIL  DO
        IF  server_entry^.server_name = appl_term_list^.appl_name  THEN
          server_entry^.current_connections := server_entry^.current_connections - 1;
          IF  appl_term_list^.appl_kind = rfc$partner  THEN
            server_entry^.partner_job_connections := server_entry^.partner_job_connections - 1;
            entry_cleared := TRUE;
            EXIT /find_matching_server/;
          IFEND;
        IFEND;
        server_entry := server_entry^.next_entry;
      WHILEND /find_matching_server/;
      rfp$unlock_table(rfv$rhfam_server_table.lock);

      IF  NOT entry_cleared  THEN
        rfp$lock_table(rfv$rhfam_client_table.lock);
        client_entry := rfv$rhfam_client_table.first_entry;
      /find_matching_client/
        WHILE  client_entry <> NIL  DO
          IF  client_entry^.client_name = appl_term_list^.appl_name  THEN
            client_entry^.current_connections := client_entry^.current_connections - 1;
            EXIT /find_matching_client/;
          IFEND;
          client_entry := client_entry^.next_entry;
        WHILEND /find_matching_client/;
        rfp$unlock_table(rfv$rhfam_client_table.lock);
      IFEND;
      appl_term_list := appl_term_list^.next_entry;
    WHILEND;

  PROCEND clear_connection_entries;
?? TITLE := '      RELEASE_ALL_CONTROL_MESSAGES' ??
?? EJECT ??
  PROCEDURE  release_all_control_messages(nad_index: rft$local_nads);

{    The purpose of this routine is to release all control messages that have been queued to the
{    corresponding NAD.
{
{    nad_index: (input) This parameter specifies the local NAD, whose control messages should
{      be released.

    VAR
        local_nad: ^rft$local_nad_entry,
        previous_entry,
        current_entry: ^rft$outgoing_control_message;

    local_nad := ^rfv$status_table.local_nads^[nad_index];

    rfp$lock_table(local_nad^.outgoing_cm_queue.lock);

    current_entry := local_nad^.outgoing_cm_queue.first_entry;
    local_nad^.outgoing_cm_queue.first_entry := NIL;
    WHILE  current_entry <> NIL  DO
      previous_entry := current_entry;
      current_entry := current_entry^.next_entry;
      FREE previous_entry IN nav$network_paged_heap^;
    WHILEND;
    rfp$unlock_table(local_nad^.outgoing_cm_queue.lock);

  PROCEND release_all_control_messages;
?? TITLE := '      IDLE_THE_PPS' ??
?? EJECT ??
  PROCEDURE  idle_the_pps;

{    The purpose of this routine is to issue a idle pp request to each
{    of the PP drivers.

    VAR
        local_status: ost$status,
        command_identifier: ^rft$pp_commands,
        request_buf: ^SEQ(*),
        nad_index: rft$local_nads,
        pp_index: 1..2;

    PUSH  request_buf : [[rft$pp_commands]];
    IF  request_buf = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'the local stack overflowed',
        local_status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'IDLE_THE_PPS', local_status);
      RETURN;
    IFEND;
    RESET request_buf;
    NEXT  command_identifier  IN  request_buf;
    IF  command_identifier = NIL  THEN
      osp$set_status_abnormal(rfc$product_id, rfe$request_processing_err, 'command id is too big',
        local_status);
      osp$append_status_parameter(osc$status_parameter_delimiter, 'IDLE_THE_PPS', local_status);
      RETURN;
    IFEND;
    command_identifier^ := rfc$pp_idle;

  /idle_pp_loop/
    FOR  nad_index := 1  TO  UPPERBOUND(rfv$status_table.local_nads^)  DO
      FOR  pp_index := 1  TO  rfv$status_table.local_nads^[nad_index].pp_drivers  DO
        IF  rfv$status_table.local_nads^[nad_index].pp[pp_index].pp_state = rfc$pps_normal  THEN
          rfp$queue_request(nad_index, pp_index, rfc$pp_request, rfc$rk_idle_pp, NIL, request_buf,
            local_status);
          IF  NOT  local_status.normal  THEN
            rfp$log_the_status(local_status);
          IFEND;
        IFEND;
      FOREND;
    FOREND /idle_pp_loop/;

{   wait for all of the PP's to idle.

    WHILE  (rfv$outstanding_requests <> NIL)  DO
      syp$cycle;
      rfp$process_pp_response_flag(rfc$pp_response_available);
    WHILEND;

  PROCEND idle_the_pps;
?? TITLE := '      RELEASE_ELEMENTS' ??
?? EJECT ??
  PROCEDURE  release_elements;

{    The purpose of this procedure is to release the channel and peripheral processor
{    elements.

    VAR
        status: ost$status,
        elements: ^ARRAY [*] OF cmt$element_reservation,
        element_count,
        current_element: INTEGER,
        channel: cmt$channel_ordinal,
        channel_name: cmt$element_name,
        channel_iou: cmt$element_name,
        pp_number: cmt$pp_ordinal,
        nad_descriptor: cmt$element_descriptor,
        nad_definition: cmt$element_definition,
        nad_entry: rft$local_nads,
        pp_entry: 1..2;

    element_count := 0;
    FOR  nad_entry := 1  TO  UPPERBOUND(rfv$status_table.local_nads^)  DO
      IF  rfv$status_table.local_nads^[nad_entry].pp[1].pp_state >= rfc$pps_reserved  THEN
        element_count := element_count + 2 + rfv$status_table.local_nads^[nad_entry].pp_drivers;
      IFEND;
    FOREND;

    IF element_count > 0 THEN
      PUSH  elements : [1..element_count];
      current_element := 1;
      FOR  nad_entry := 1  TO  UPPERBOUND(rfv$status_table.local_nads^)  DO
        IF  rfv$status_table.local_nads^[nad_entry].pp[1].pp_state >= rfc$pps_reserved  THEN
          channel := rfv$status_table.local_nads^[nad_entry].channel_ordinal;
          channel_iou := rfv$status_table.local_nads^[nad_entry].pp[1].pp_id.iou;
          nad_descriptor.element_type := cmc$communications_element;
          nad_descriptor.peripheral_descriptor.use_logical_identification := TRUE;
          nad_descriptor.peripheral_descriptor.element_name :=
                rfv$status_table.local_nads^[nad_entry].name;
          cmp$get_element_definition(nad_descriptor, nad_definition, status);
          IF  NOT status.normal  THEN
            RETURN;
          IFEND;
          channel_name := nad_definition.communications_element.connection.
                port [0].element_name;
          elements^[current_element].element_type := cmc$data_channel_element;
          elements^[current_element].channel_descriptor.use_logical_identification := TRUE;
          elements^[current_element].channel_descriptor.name := channel_name;
          elements^[current_element].channel_descriptor.iou := channel_iou;
          current_element := current_element + 1;
          elements^[current_element].element_type := cmc$communications_element;
          elements^[current_element].peripheral_descriptor.use_logical_identification := TRUE;
          elements^[current_element].peripheral_descriptor.element_name :=
            rfv$status_table.local_nads^[nad_entry].name;
          current_element := current_element + 1;
          FOR  pp_entry := 1  TO  rfv$status_table.local_nads^[nad_entry].pp_drivers  DO
            elements^[current_element].element_type := cmc$pp_element;
            elements^[current_element].pp_reservation.selector := cmc$choose_pp_by_channel;
            elements^[current_element].pp_reservation.channel.iou := channel_iou;
            elements^[current_element].pp_reservation.channel.ordinal := channel;
            elements^[current_element].pp_reservation.acquired_pp_identification :=
              rfv$status_table.local_nads^[nad_entry].pp[pp_entry].pp_id;
            current_element := current_element + 1;
          FOREND;
        IFEND;
      FOREND;

      cmp$release_element(elements^, status);
      IF  NOT status.normal  THEN
        rfp$log_the_status(status);
      IFEND;

      FOR  nad_entry := 1  TO  UPPERBOUND(rfv$status_table.local_nads^)  DO
        rfv$status_table.local_nads^[nad_entry].pp[1].pp_state := rfc$pps_released;
      FOREND;
    IFEND;

  PROCEND release_elements;
?? OLDTITLE ??
?? OLDTITLE ??
MODEND rfm$system_task;
*DECK DECK=RFP$ACCEPT_CONNECT_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] rfp$accept_connect_request(
        connection_file: fst$file_reference;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc rfe$condition_codes
?? POP ??
*DECK DECK=RFP$ACCEPT_SWITCH_OFFER EXPAND=FALSE

  PROCEDURE [XREF] rfp$accept_switch_offer (
        application_name: rft$application_name;
        connection_file: fst$file_reference;
        file_attributes: ^rft$change_attributes;
        wait_time: rft$connection_timeout;
    VAR source_job: jmt$system_supplied_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jmt$system_supplied_name
*copyc ost$status
*copyc rfe$condition_codes
*copyc rft$external_interface
*copyc rft$file_attributes
?? POP ??
*DECK DECK=RFP$ACQUIRE_CONNECT_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] rfp$acquire_connect_request(
        server_name: rft$application_name;
        connection_file: fst$file_reference;
        file_attributes: ^rft$create_attributes;
        wait_time: rft$connection_timeout;
    VAR client_name: rft$application_name;
    VAR source_host_name: rft$host_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc rfe$condition_codes
*copyc rft$external_interface
*copyc rft$file_attributes
?? POP ??

*DECK DECK=RFP$ACTIVATE_RHFAM_CLIENT EXPAND=FALSE

  PROCEDURE [XREF] rfp$activate_rhfam_client (client: rft$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$ACTIVATE_RHFAM_SERVER EXPAND=FALSE

  PROCEDURE [XREF] rfp$activate_rhfam_server (server: rft$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$APPLICATION_SIGN_OFF EXPAND=FALSE

  PROCEDURE [XREF] rfp$application_sign_off(
        application_name: rft$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rfe$condition_codes
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$APPLICATION_SIGN_ON EXPAND=FALSE

  PROCEDURE [XREF] rfp$application_sign_on(
        application_name: rft$application_name;
        application_kind: rft$application_kinds;
    VAR maximum_connections: rft$application_connections;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rfe$condition_codes
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$AWAIT_RHFAM_EVENT EXPAND=FALSE

  PROCEDURE [XREF] rfp$await_rhfam_event (
        connection_identifier: amt$file_identifier;
        event: rft$connection_events;
        wait_time: rft$connection_timeout;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
*copyc rfe$condition_codes
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$AWAIT_SERVER_RESPONSE EXPAND=FALSE

  PROCEDURE [XREF] rfp$await_server_response(
        connection_file: fst$file_reference;
        wait_time: rft$connection_timeout;
    VAR server_response: rft$server_response;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc rfe$condition_codes
*copyc rft$external_interface
*copyc ost$status
?? POP ??
*DECK DECK=RFP$CANCEL_SWITCH_OFFER EXPAND=FALSE

  PROCEDURE [XREF] rfp$cancel_switch_offer (
        connection_file: fst$file_reference;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc rfe$condition_codes
?? POP ??
*DECK DECK=RFP$CHANGE_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] rfp$change_attributes (
        connection_file: fst$file_reference;
        file_attributes: rft$change_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc rfe$condition_codes
*copyc rft$file_attributes
?? POP ??
*DECK DECK=RFP$CHANGE_HOST_OR_LID_STATE EXPAND=FALSE

  PROCEDURE [XREF] rfp$change_host_or_lid_state (
    physical_id_list_p: ^ARRAY [1 .. *] OF rft$physical_identifier;
    logical_id_list_p: ^ARRAY [1 .. *] OF rft$logical_identifier;
    all_pids_specified: BOOLEAN;
    state: BOOLEAN;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rft$host_identifier
?? POP ??
*DECK DECK=RFP$CHANGE_NAD_OR_TRUNK_STATE EXPAND=FALSE

  PROCEDURE [XREF] rfp$change_nad_or_trunk_state (nad_names: ^ARRAY[1 .. *] OF rft$component_name;
    trunk_names_p: ^ARRAY[1 .. *] OF rft$component_name;
    state: rft$element_state;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc rft$configuration_defs
*copyc ost$status
?? POP ??
*DECK DECK=RFP$CHANGE_NAD_STATUS EXPAND=FALSE

  PROCEDURE [XREF] rfp$change_nad_status(nad_unit: iot$logical_unit;
                                         new_state: rft$element_state);


?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
*copyc rft$configuration_defs
?? POP ??

*DECK DECK=RFP$CHECK_FOR_EVENT EXPAND=FALSE

  PROCEDURE [XREF] rfp$check_for_event (wait_list: ost$i_activity;
    VAR await_complete: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$i_wait
*copyc OST$STATUS
?? POP ??
*DECK DECK=RFP$CHECK_LOCAL_NAD_TEST EXPAND=FALSE

  PROCEDURE [XREF] rfp$check_local_nad_test (nad_name:  rft$component_name;
    VAR local_nad_test_complete: BOOLEAN;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc rft$configuration_defs
*copyc ost$status
?? POP ??
*DECK DECK=RFP$CLOSE_FILE EXPAND=FALSE

  PROCEDURE [XREF] rfp$close_file (file_identifier: amt$file_identifier;
        layer: amt$fap_layer_number;
        call_block: amt$call_block;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc rfe$condition_codes
?? POP ??
*DECK DECK=RFP$COMMON_INTERNAL_PROCS EXPAND=FALSE

{    DECK:  RFP$COMMON_INTERNAL_PROCS
{
{    This deck contains the XREF declarations for the RHFAM/VE common,
{    internal procedures.

  PROCEDURE [XREF] rfp$log_the_status (status_message : ost$status);

  PROCEDURE [XREF] rfp$build_load_request(VAR load_request_status: ^rft$load_dump_status;
                                          VAR request_info: ^SEQ(*);
                                          VAR status: ost$status);

  PROCEDURE [XREF] rfp$build_dump_request(VAR dump_request_status: ^rft$load_dump_status;
                                          VAR request_info: ^SEQ(*);
                                          VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rft$r1_interface_defs
*copyc rft$configuration_defs
*copyc rft$pp_interface_defs
?? POP ??
*DECK DECK=RFP$CONTINUE_DATA_TRANSFER EXPAND=FALSE

  PROCEDURE [XREF] rfp$continue_data_transfer (
    command_buffer: ^ARRAY [rft$command_entry] OF rft$command;
    transfer_status: rft$transfer_state;
    VAR current_request: ^rft$outstanding_requests;
    VAR release_request: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc rft$r1_interface_defs
*copyc rft$pp_interface_defs
?? POP ??
*DECK DECK=RFP$CONTINUE_IO_REQUEST EXPAND=FALSE

  PROCEDURE  [XREF] rfp$continue_io_request(VAR request_info: ^SEQ(*);
                                            request_id: rft$request_identifier;
                                            io_type: iot$io_function;
                                            restart_request: BOOLEAN;
                                        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc rft$r1_interface_defs
?? POP ??
*DECK DECK=RFP$DEACTIVATE_RHFAM_CLIENT EXPAND=FALSE

  PROCEDURE [XREF] rfp$deactivate_rhfam_client (client: rft$application_name;
    terminate_active_connections: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$DEACTIVATE_RHFAM_SERVER EXPAND=FALSE

  PROCEDURE [XREF] rfp$deactivate_rhfam_server (server: rft$application_name;
    terminate_active_connections: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$DEFINE_RHFAM_CLIENT EXPAND=FALSE

  PROCEDURE [XREF] rfp$define_rhfam_client (client: rft$application_name;
    maximum_connections: rft$application_connections;
    capability: ost$name;
    ring: ost$ring;
    system_privilege: boolean;
    system_wide_connection_mgmt: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$DEFINE_RHFAM_SERVER EXPAND=FALSE

  PROCEDURE [XREF] rfp$define_rhfam_server (server: rft$application_name;
    rhfam_initiated: boolean;
    maximum_connections: rft$application_connections;
    capability: ost$name;
    ring: ost$ring;
    system_privilege: boolean;
    server_job: amt$local_file_name;
    server_job_max_connections: rft$application_connections;
    accept_connection: boolean;
    rhfam_validates_connection_lid: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$DELETE_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] rfp$delete_connection (
        local_file_name: amt$local_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=RFP$DELETE_RHFAM_CLIENT EXPAND=FALSE

  PROCEDURE [XREF] rfp$delete_rhfam_client (client: rft$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$DELETE_RHFAM_SERVER EXPAND=FALSE

  PROCEDURE [XREF] rfp$delete_rhfam_server (server: rft$application_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$DELINK_REQUEST EXPAND=FALSE

PROCEDURE [XREF] rfp$delink_request(VAR request_id: rft$request_identifier;
                                    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rft$r1_interface_defs
?? POP ??

*DECK DECK=RFP$DISPLAY_ACTIVE_APPL_R3 EXPAND=FALSE

  PROCEDURE [XREF] rfp$display_active_appl_r3 (job_name_list: ARRAY [1 .. *] OF ost$name;
    application_name_list: ARRAY [1 .. *] OF rft$application_name;
    display_type: rft$application_display_type;
    VAR display_control: clt$display_control;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc ost$name
*copyc ost$status
*copyc rft$external_interface
*copyc rft$manage_rhfam_network_types
?? POP ??
*DECK DECK=RFP$DISPLAY_RHFAM_CLIENTS EXPAND=FALSE

  PROCEDURE [XREF] rfp$display_rhfam_clients (
    client_list: ARRAY [1 .. *] OF rft$application_name;
    VAR display_control: clt$display_control;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc ost$status
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$DISPLAY_RHFAM_ELEMENTS EXPAND=FALSE

  PROCEDURE [XREF] rfp$display_rhfam_elements (element_names: ARRAY[1 .. *] OF rft$component_name;
    display_type: rft$element_display_type;
    display_option: rft$display_option;
    VAR display_control: clt$display_control;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc rft$configuration_defs
*copyc rft$manage_rhfam_network_types
*copyc ost$status
?? POP ??
*DECK DECK=RFP$DISPLAY_RHFAM_SERVERS EXPAND=FALSE

  PROCEDURE [XREF] rfp$display_rhfam_servers (
    server_list: ARRAY [1 .. *] OF rft$application_name;
    VAR display_control: clt$display_control;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc ost$status
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$DISPLAY_ROUTING_INFO_R3 EXPAND=FALSE

  PROCEDURE [XREF] rfp$display_routing_info_r3 (physical_id_list: ARRAY [1 .. *] OF rft$physical_identifier;
    logical_id_list: ARRAY [1 .. *] OF rft$logical_identifier;
    local_pid_specified: BOOLEAN;
    all_pids_specified: BOOLEAN;
    all_lids_specified: BOOLEAN;
    display_type: rft$routing_display_type;
    VAR input_file_p: ^SEQ(*);
    VAR display_control: clt$display_control;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc ost$status
*copyc rft$host_identifier
*copyc rft$manage_rhfam_network_types
?? POP ??
*DECK DECK=RFP$FETCH EXPAND=FALSE

  PROCEDURE [XREF] rfp$fetch (
        file_identifier: amt$file_identifier;
    VAR file_attributes: rft$get_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
*copyc rfe$condition_codes
*copyc rft$file_attributes
?? POP ??
*DECK DECK=RFP$FIND_AVAILABLE_SERVICE EXPAND=FALSE

  PROCEDURE [XREF] rfp$find_available_service (
        server_name: rft$application_name;
        destination_host: rft$host_identifier;
    VAR host_identifiers: rft$destination_hosts;
    VAR number_of_hosts: rft$number_of_hosts;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rfe$condition_codes
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$FIND_CLIENT_ENTRY EXPAND=FALSE

  PROCEDURE [INLINE] rfp$find_client_entry (client_name: rft$application_name;
        require_active: boolean;
    VAR client_entry_p: ^rft$rhfam_client_table_entry;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
{
{           The purpose of this procedure is to locate the specified
{     client table entry and return a pointer to the entry.
{     The caller of this routine must have the client table locked.
{
{
{     CLIENT_NAME: (input) This parameter specifies the client to
{       locate.
{
{     REQUIRE_ACTIVE: (input); This parameter specifies if the client
{       definition must be active to match.
{
{     CLIENT_ENTRY_P: (output) This parameter returns the pointer to the
{       specified client table entry. A NIL pointer indicates no client
{       table entry was found.
{
{     STATUS: (output) This parameter returns the results of the request.
{       A status of normal means the client was found.
{

    status.normal := TRUE;
    client_entry_p := rfv$rhfam_client_table.first_entry;
    WHILE client_entry_p <> NIL DO
      IF (client_entry_p^.client_name = client_name) THEN
        IF require_active THEN
          IF client_entry_p^.client_active THEN
            RETURN;
          ELSE
            osp$set_status_abnormal (rfc$product_id, rfe$appl_not_active,
                  client_name, status);
            EXIT rfp$find_client_entry;
          IFEND;
        ELSE
          RETURN;
        IFEND;
      IFEND;
      client_entry_p := client_entry_p^.next_entry;
    WHILEND;

    osp$set_status_abnormal (rfc$product_id, rfe$appl_not_defined,
            client_name, status);

  PROCEND rfp$find_client_entry;
?? POP ??
*DECK DECK=RFP$GET_ATTRIBUTES EXPAND=FALSE

  PROCEDURE [XREF] rfp$get_attributes (
        connection_file: fst$file_reference;
    VAR file_attributes: rft$get_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc rfe$condition_codes
*copyc rft$file_attributes
?? POP ??
*DECK DECK=RFP$GET_LOCAL_HOST_PHYSICAL_ID EXPAND=FALSE

  PROCEDURE [XREF] rfp$get_local_host_physical_id (
    VAR physical_identifier: rft$physical_identifier;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rfe$condition_codes
*copyc rft$host_identifier
?? POP ??
*DECK DECK=RFP$INITIALIZE_CONFIG_POINTERS EXPAND=FALSE

  PROCEDURE [XREF] rfp$initialize_config_pointers(install_request: BOOLEAN;
                                              VAR save_info: rft$config_utl_pointers;
                                              VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rft$config_utl_pointers
?? POP ??

*DECK DECK=RFP$INITIATE_LOCAL_NAD_TEST EXPAND=FALSE

  PROCEDURE [XREF] rfp$initiate_local_nad_test (nad_name: rft$component_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc rft$configuration_defs
*copyc ost$status
?? POP ??
*DECK DECK=RFP$JOB_TERMINATION EXPAND=FALSE

  PROCEDURE [XREF] rfp$job_termination;
*DECK DECK=RFP$LOCK_JOB_TABLE_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] rfp$lock_job_table_entry(create_new_entry: BOOLEAN;
                                        VAR new_entry_created: BOOLEAN;
                                        VAR job_table_entry_p: ^rft$rhfam_job_table_entry);

?? PUSH (LISTEXT := ON) ??
*copyc rft$rhfam_job_table
?? POP ??
*DECK DECK=RFP$LOCK_TABLE EXPAND=FALSE

  PROCEDURE [XREF] rfp$lock_table (VAR lock: ost$signature_lock);

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??
*DECK DECK=RFP$MOVE_DATA_FROM_WIRED_BUFFS EXPAND=FALSE
?? EJECT ??
  PROCEDURE [INLINE] rfp$move_data_from_wired_buffs(VAR buffer_list: rft$buffer_list;
                                                    VAR pva: ^CELL;
                                                        buffer_count: rft$buffer_count;
                                                    VAR current_buffer: rft$buffer_count;
                                                    VAR byte_count: rft$bytes_transferred);

{    The purpose of this routine is to move data from the network wired buffers into
{    the specified user data field.
{
{    buffer_list: (input,output) This parameter specifies the list of buffers to move
{      the data from.
{
{    data: (input,output) This parameter specifies the pointer of the user buffer
{      to recieve the data.  Upon exit this parameter points to the byte beyond the
{      last byte written to the buffer.
{
{    buffer_count: (input) This parameter specifies the number of wired buffers.
{
{    current_buffer: (input,output) This parameter specifies the first buffer to
{      move the data from.  Upon exit this parameter points to the next buffer
{      to move the data from.
{
{    byte_count: (input,output) This parameter specifies the number of bytes to move.
{      Upon exit this parameter specifies the number of bytes that were not moved.


    VAR
        buffer_ptr: ^CELL,
        data_in_buffer: rft$bytes_transferred;

    WHILE  (byte_count > 0) AND
           (buffer_list[current_buffer].byte_count > 0)  DO
      data_in_buffer := buffer_list[current_buffer].byte_count;
      IF  data_in_buffer > byte_count  THEN
        data_in_buffer := byte_count;
      IFEND;
      buffer_ptr := i#ptr(buffer_list[current_buffer].current_offset, buffer_list[current_buffer].buffer);
      i#move(buffer_ptr, pva, data_in_buffer);
      pva := i#ptr(data_in_buffer, pva);
      buffer_list[current_buffer].byte_count := buffer_list[current_buffer].byte_count - data_in_buffer;
      buffer_list[current_buffer].current_offset := buffer_list[current_buffer].current_offset +
        data_in_buffer;
      IF  buffer_list[current_buffer].byte_count = 0  THEN
        current_buffer := (current_buffer MOD buffer_count) + 1;
      IFEND;
      byte_count := byte_count - data_in_buffer;
    WHILEND;

  PROCEND rfp$move_data_from_wired_buffs;
?? PUSH (LISTEXT := ON) ??
*copyc i#move
*copyc i#ptr
*copyc rft$r1_interface_defs
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$MOVE_DATA_TO_WIRED_BUFFS EXPAND=FALSE
?? EJECT ??
  PROCEDURE [INLINE] rfp$move_data_to_wired_buffs(VAR buffer_list: rft$buffer_list;
                                                  VAR pva: ^CELL;
                                                      buffer_count: rft$buffer_count;
                                                  VAR current_buffer: rft$buffer_count;
                                                  VAR byte_count: rft$bytes_transferred);

{    The purpose of this routine is to move data from a user specified field into the
{    network wired buffers.
{
{    buffer_list: (input,output) This parameter specifies the list of buffers to move
{      the data into.
{
{    data: (input,output) This parameter specifies the pointer to the user data.
{      Upon exit this parameter points to the byte beyond the last byte placed
{      in the buffer.
{
{    buffer_count: (input) This parameter specifies the number of wired buffers.
{
{    current_buffer: (input,output) This parameter specifies the first buffer to
{      receive the data.  Upon exit this parameter points to the next buffer
{      to receive data.
{
{    byte_count: (input,output) This parameter specifies the number of bytes to move.
{      Upon exit this parameter specifies the number of bytes that were not moved.


    VAR
        buffer_ptr: ^CELL,
        room_in_buffer: rft$bytes_transferred;

    WHILE  (byte_count > 0) AND
           (buffer_list[current_buffer].byte_count < buffer_list[current_buffer].length)  DO
      room_in_buffer := buffer_list[current_buffer].length - buffer_list[current_buffer].byte_count;
      IF  room_in_buffer > byte_count  THEN
        room_in_buffer := byte_count;
      IFEND;
      buffer_ptr := i#ptr(buffer_list[current_buffer].byte_count, buffer_list[current_buffer].buffer);
      i#move(pva, buffer_ptr, room_in_buffer);
      pva := i#ptr(room_in_buffer, pva);
      buffer_list[current_buffer].byte_count := buffer_list[current_buffer].byte_count + room_in_buffer;
      IF  buffer_list[current_buffer].byte_count = buffer_list[current_buffer].length  THEN
        current_buffer := (current_buffer MOD buffer_count) + 1;
      IFEND;
      byte_count := byte_count - room_in_buffer;
    WHILEND;

  PROCEND rfp$move_data_to_wired_buffs;
?? PUSH (LISTEXT := ON) ??
*copyc i#move
*copyc i#ptr
*copyc rft$r1_interface_defs
*copyc rft$external_interface
?? POP ??

*DECK DECK=RFP$NETWORK_FAP EXPAND=FALSE

  PROCEDURE [XREF] rfp$network_fap (file_identifier: amt$file_identifier;
        call_block: amt$call_block;
        layer_number: amt$fap_layer_number;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$fap_declarations
?? POP ??
*DECK DECK=RFP$OFFER_CONNECTION_SWITCH EXPAND=FALSE

  PROCEDURE [XREF] rfp$offer_connection_switch(
         connection_file: fst$file_reference;
         destination_job: jmt$system_supplied_name;
         wait_time: rft$connection_timeout;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc jmt$system_supplied_name
*copyc ost$status
*copyc rfe$condition_codes
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$OPEN_FILE EXPAND=FALSE

  PROCEDURE [XREF] rfp$open_file (
        file_identifier: amt$file_identifier;
        layer: amt$fap_layer_number;
        call_block: amt$call_block;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$fap_layer_number
*copyc amt$call_block
*copyc ost$status
*copyc ame$device_class_validation
*copyc ame$improper_file_id
*copyc rfe$condition_codes
?? POP ??
*DECK DECK=RFP$POST_REQUEST EXPAND=FALSE

PROCEDURE [XREF] rfp$post_request(VAR request_info: ^SEQ(*);
                              VAR request_id: rft$request_identifier;
                              VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rft$r1_interface_defs
?? POP ??
*DECK DECK=RFP$PRESERVE_CONFIG_POINTERS EXPAND=FALSE

  PROCEDURE [XREF] rfp$preserve_config_pointers(save_info: rft$config_utl_pointers);

?? PUSH (LISTEXT := ON) ??
*copyc rft$config_utl_pointers
?? POP ??

*DECK DECK=RFP$PROCESS_PP_RESPONSE_FLAG EXPAND=FALSE

  PROCEDURE [XREF] rfp$process_pp_response_flag(flag_id: ost$system_flag);

?? PUSH (LISTEXT := ON) ??
*copyc ost$system_flag
?? POP ??
*DECK DECK=RFP$QUEUE_DATA_FRAGMENTS EXPAND=FALSE

  PROCEDURE [XREF] rfp$queue_data_fragments(request_block: rft$rb_queue_data_fragments);

?? PUSH (LISTEXT := ON) ??
*copyc rft$rb_queue_data_fragments
?? POP ??
*DECK DECK=RFP$QUEUE_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] rfp$queue_request(nad_index: rft$local_nads;
                                     pp_index: 1..2;
                                     request_type: rft$request_types;
                                     nad_request: rft$nad_request_kinds;
                                     request_status: ^cell;
                                 VAR request_info: ^SEQ(*);
                                 VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc osv$task_private_heap
*copyc rft$r1_interface_defs
*copyc rft$configuration_defs
*copyc rft$pp_interface_defs
*copyc rfp$post_request
*copyc rfv$status_table
?? POP ??
*DECK DECK=RFP$RECEIVE_DATA EXPAND=FALSE

  PROCEDURE [XREF] rfp$receive_data (
        connection_identifier: amt$file_identifier;
        transmission_mode: rft$transmission_modes;
        data_buffer: rft$data_buffers;
        wait: ost$wait;
    VAR activity: ost$activity_status;
    VAR data_received: rft$bytes_transferred;
    VAR end_of_message: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$activity_status
*copyc ost$status
*copyc ost$wait
*copyc rfe$condition_codes
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$RECOVER_TASK_ACTIVITY EXPAND=FALSE

  PROCEDURE [XREF] rfp$recover_task_activity (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=RFP$REJECT_CONNECT_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] rfp$reject_connect_request(
        connection_file: fst$file_reference;
        server_response: rft$server_reject_codes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc rfe$condition_codes
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$RELEASE_CONFIG_POINTERS EXPAND=FALSE

  PROCEDURE [XREF] rfp$release_config_pointers;

*DECK DECK=RFP$RELEASE_REQUEST_BUFFERS EXPAND=FALSE

  PROCEDURE [XREF] rfp$release_request_buffers;
*DECK DECK=RFP$RELEASE_WIRED_BUFFERS EXPAND=FALSE
?? EJECT ??
  PROCEDURE [INLINE] rfp$release_wired_buffers(buffer_list: rft$buffer_list;
                                               buffer_count: rft$buffer_count);

{    The purpose of this request is to call the NAM/VE buffer manager to release
{    a list of buffers in the network wired section.
{
{    buffer_list: (input) This parameter specifies the list of buffers to release.
{
{    buffer_count: (input) This parameter specifies the number of buffers to release.

    VAR
        message_id: nlt$bm_message_id,
        descriptor_ptr: ^^nlt$bm_message_descriptor,
        index: rft$buffer_count;

    IF buffer_count <> 0 THEN
      descriptor_ptr := ^message_id.descriptor;
      message_id.sequence_number := buffer_list [1].descriptor^.sequence_number;

      FOR  index := 1  TO  buffer_count  DO
        descriptor_ptr^ := buffer_list[index].descriptor;
        descriptor_ptr := ^descriptor_ptr^^.link;
      FOREND;

      descriptor_ptr^ := NIL;

      nlp$bm_release_message(message_id);
      rfp$lock_table (rfv$network_wired_buffers.lock);
      rfv$network_wired_buffers.current_buffers := rfv$network_wired_buffers.
            current_buffers - buffer_count;
      rfp$unlock_table (rfv$network_wired_buffers.lock);
    IFEND;

  PROCEND rfp$release_wired_buffers;
?? PUSH (LISTEXT := ON) ??
*copyc nlp$bm_release_message
*copyc rft$r1_interface_defs
*copyc rfv$network_wired_buffers
?? POP ??

*DECK DECK=RFP$REMOVE_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] rfp$remove_connection (
         response_seq_number: INTEGER;
     VAR connection_entry_p: ^rft$connection_entry);


?? PUSH (LISTEXT := ON) ??
*copyc rft$rhfam_job_table
?? POP ??


*DECK DECK=RFP$REMOVE_WAITS EXPAND=FALSE

  PROCEDURE [XREF] rfp$remove_waits;
*DECK DECK=RFP$REQUEST_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] rfp$request_connection (client_name: rft$application_name;
        server_name: rft$application_name;
        destination_host: rft$host_identifier;
        connection_file: fst$file_reference;
        file_attributes: ^rft$create_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc rfe$condition_codes
*copyc rft$external_interface
*copyc rft$file_attributes
?? POP ??
*DECK DECK=RFP$RESERVE_REQUEST_BUFFERS EXPAND=FALSE

  PROCEDURE [XREF] rfp$reserve_request_buffers(buffer_count: INTEGER;
                                           VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=RFP$RESERVE_WIRED_BUFFERS EXPAND=FALSE
?? EJECT ??
  PROCEDURE [INLINE]  rfp$reserve_wired_buffers(VAR reserved_buffers: rft$buffer_list;
                                                VAR buffer_count: rft$buffer_count);

{    The purpose of this request is to call the NAM/VE buffer manager to obtain
{    a list of buffers in the network wired section.
{
{    reserved_buffers: (output) This parameter specifies the array of buffers reserved.
{      Upon return a pointer to each of the reserved buffers is returned in this array.
{
{    buffer_count: (input, output) This parameter specifies the number of buffers to
{      reserve.  Upon output this parameter specifies the number of buffers actually
{      reserved.

    VAR
        buffer_list_array: nlt$bm_buffer_list_array,
        buffers_acquired: BOOLEAN,
        buffers_allowed: rft$network_wired_buffer_count,
        buffers_requested: rft$buffer_count,
        index: rft$buffer_count;


    rfp$lock_table (rfv$network_wired_buffers.lock);
    buffers_allowed := rfv$network_wired_buffers.maximum_buffers -
          rfv$network_wired_buffers.current_buffers;
    IF buffer_count > buffers_allowed THEN
      buffer_count := buffers_allowed;
    IFEND;
    rfv$network_wired_buffers.current_buffers := rfv$network_wired_buffers.current_buffers +
          buffer_count;
    rfp$unlock_table (rfv$network_wired_buffers.lock);
    buffers_requested := buffer_count;

    IF buffer_count > 0 THEN
      FOR index := LOWERBOUND (buffer_list_array) TO UPPERBOUND (buffer_list_array) DO
        buffer_list_array [index].count := 0;
        buffer_list_array [index].buffer_list := NIL;
      FOREND;
      buffer_list_array [nlc$bm_large_buffer_index].count := buffer_count;
      PUSH  buffer_list_array [nlc$bm_large_buffer_index].buffer_list : [1..buffer_count];

      nlp$bm_get_buffer_list(buffer_list_array, buffers_acquired);

      IF  buffers_acquired  THEN
        buffer_count := buffer_list_array [nlc$bm_large_buffer_index].count;

        FOR  index := 1 TO buffer_count  DO
          reserved_buffers[index].length := nlv$bm_large_buffer_size;
          reserved_buffers[index].byte_count := 0;
          reserved_buffers[index].current_offset := 0;
          reserved_buffers[index].descriptor := buffer_list_array [nlc$bm_large_buffer_index].
                buffer_list^[index];
          reserved_buffers[index].buffer := buffer_list_array [nlc$bm_large_buffer_index].
                buffer_list^[index]^.container;
        FOREND;
      ELSE
        buffer_count := 0;
      IFEND;
      IF buffer_count <> buffers_requested THEN
        rfp$lock_table (rfv$network_wired_buffers.lock);
        rfv$network_wired_buffers.current_buffers := rfv$network_wired_buffers.current_buffers -
              (buffers_requested - buffer_count);
        rfp$unlock_table (rfv$network_wired_buffers.lock);
      IFEND;
    IFEND;

  PROCEND rfp$reserve_wired_buffers;
?? PUSH (LISTEXT := ON) ??
*copyc nlt$bm_buffer_list_array
*copyc rft$r1_interface_defs
*copyc nlp$bm_get_buffer_list
*copyc nlv$bm_large_buffer_size
*copyc rfv$network_wired_buffers
?? POP ??
*DECK DECK=RFP$RETRIEVE_CONFIG_POINTERS EXPAND=FALSE

  PROCEDURE [XREF] rfp$retrieve_config_pointers(VAR save_info: rft$config_utl_pointers);

?? PUSH (LISTEXT := ON) ??
*copyc rft$config_utl_pointers
?? POP ??

*DECK DECK=RFP$RETURN_LID_TYPE EXPAND=FALSE
  PROCEDURE [XREF] rfp$return_lid_type (
        lid_name: rft$logical_identifier;
    VAR lid_type: rft$type_of_lid;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rft$configuration_defs
*copyc rft$external_interface
?? POP ??

*DECK DECK=RFP$RE_ISSUE_REQUEST EXPAND=FALSE

PROCEDURE [XREF] rfp$re_issue_request(VAR request_id: rft$request_identifier;
                                      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rft$r1_interface_defs
?? POP ??

*DECK DECK=RFP$RHFAM_EVENT_PROCESSOR EXPAND=FALSE

 PROCEDURE [XREF] rfp$rhfam_event_processor(VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=RFP$SEND_DATA EXPAND=FALSE

  PROCEDURE [XREF] rfp$send_data (connection_identifier: amt$file_identifier;
        transmission_mode: rft$transmission_modes;
        data: rft$data_buffers;
        end_of_message: boolean;
        wait: ost$wait;
    VAR activity: ost$activity_status;
    VAR data_sent: rft$bytes_transferred;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$activity_status
*copyc ost$status
*copyc ost$wait
*copyc rfe$condition_codes
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$SET_CONNECTION_ENTRY_P EXPAND=FALSE

  PROCEDURE [XREF] rfp$set_connection_entry_p (connection_entry_p: ^rft$connection_entry;
        response_seq_number: INTEGER;
    VAR status: ost$status);


?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rfe$condition_codes
*copyc rft$rhfam_job_table
?? POP ??
*DECK DECK=RFP$SET_SYSTEM_TASK_ID EXPAND=FALSE

  PROCEDURE  [XREF]  rfp$set_system_task_id(start_up: boolean);

*DECK DECK=RFP$START_SERVER_JOB EXPAND=FALSE

  PROCEDURE [XREF] rfp$start_server_job(VAR server: ^rft$rhfam_server_table_entry;
                                        VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc rft$rhfam_server_table
*copyc ost$status
?? POP ??
*DECK DECK=RFP$STORE EXPAND=FALSE

  PROCEDURE [XREF] rfp$store (
        file_identifier: amt$file_identifier;
        file_attributes: rft$change_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
*copyc rfe$condition_codes
*copyc rft$file_attributes
?? POP ??
*DECK DECK=RFP$TERMINATE_ASYNC_ACTIVITY EXPAND=FALSE

  PROCEDURE [XREF] rfp$terminate_async_activity (
        connection_identifier: amt$file_identifier;
        activity_types: rft$set_of_async_activities;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc ost$status
*copyc rfe$condition_codes
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$TERMINATE_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] rfp$terminate_connection (
        connection_file: fst$file_reference;
        normal_termination: boolean;
    VAR connection_statistics: rft$connection_statistics;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ost$status
*copyc rfe$condition_codes
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFP$TEST_SET_TABLE_LOCK EXPAND=FALSE

  PROCEDURE [XREF] rfp$test_set_table_lock (VAR lock: ost$signature_lock;
    VAR locked: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??
*DECK DECK=RFP$UNCONDITIONALLY_STATUS EXPAND=FALSE

  PROCEDURE [XREF] rfp$unconditionally_status(unit_number: iot$logical_unit);

?? PUSH (LISTEXT := ON) ??
*copyc iot$logical_unit
?? POP ??
*DECK DECK=RFP$UNLOCK_TABLE EXPAND=FALSE

  PROCEDURE [XREF] rfp$unlock_table (VAR lock: ost$signature_lock);

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
?? POP ??
*DECK DECK=RFP$VERIFY_CALLER_CAPABILITY EXPAND=FALSE

  PROCEDURE [INLINE] rfp$verify_caller_capability
    (    capabilities: ^array [1 .. * ] of ost$name;
         application_command: string ( * );
     VAR status: ost$status);

{       The purpose of this routine is to validate that the caller has at
{ least one of a list of specified_capabilities or is the system job.

    VAR
      index: integer,
      ignore_status: ost$status,
      user_has_capability: boolean;

    status.normal := TRUE;
    IF NOT jmp$system_job () THEN
      FOR index := LOWERBOUND (capabilities^) TO UPPERBOUND (capabilities^) DO
        avp$get_capability (capabilities^ [index], avc$user, user_has_capability, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF user_has_capability THEN
          RETURN;
        IFEND;
      FOREND;
      osp$set_status_abnormal (rfc$product_id, rfe$caller_not_privileged,
            application_command, status);
    IFEND;

  PROCEND rfp$verify_caller_capability;

?? PUSH (LISTEXT := ON) ??
*copyc avc$validation_field_names
*copyc avp$get_capability
*copyc jmp$system_job
?? POP ??
*DECK DECK=RFS$NAD_PP_DRIVER EXPAND=FALSE
*                THE FOLLOWING SYMBOL IS USED TO CONTROL MAINTENANCE
*                CONNECTION CODE IN RQC AND OGS.  THIS CODE IS
*                DELETED TO CONSERVE SPACE.  DEFINING THE SYMBOL
*                MCON WILL CAUSE THE CODE TO BE ASSEMBLED.
*MCON      EQU    1           INCLUDE MAINTENANCE CONNECTION CODE
          SPACE  4,10
***
*         THE NAD PP DRIVER (OR DRIVERS) IS LOADED WHEN THE RHFAM/VE
*         SYSTEM TASK IS ACTIVATED AND REMAINS PP RESIDENT UNTIL A
*         DEADSTART OR THE SYSTEM TASK IS DEACTIVATED.  THE DRIVERS
*         SCAN THE CORRESPONDING UNIT REQUEST QUEUES LOOKING FOR REQUESTS TO
*         PROCESS.  ONCE AN AVAILABLE REQUEST IS FOUND THE PP INTERLOCKS THE
*         REQUEST, PROCESSES THE REQUEST, AND RETURNS THE RESPONSE TO THE
*         PREDEFINED PP RESPONSE BUFFER.
          TITLE  MACRO DEFINITIONS
**        MACRO DEFINITIONS
*
*COPY IODMAC1
*COPY IODMAC4
SUBR      SPACE  4,10
**        SUBR - SUBROUTINE ENTRY/EXIT LINE.
*
*NAME     SUBR
*
*         *NAME* IS THE SUBROUTINE ENTRY POINT AND *NAMEX* IS THE
*         SUBROUTINE EXIT ADDRESS.


          PURGMAC SUBR

          MACRO  SUBR,A
 A_X    LJM    *
 A      EQU    *-1
          ENDM
LOADCM    SPACE  4,10
**        LOADCM  - LOAD CENTRAL MEMORY ADDRESS
*
*         LOADCM ADDRESS,INDEX,OFFSET
*
*         THIS MACRO IS USED TO LOAD THE *A* AND *R* REGISTERS FOR A
*         CENTRAL MEMORY READ OR WRITE OPERATION.
*
*         ENTRY
*           ADDRESS     A PP ADDRESS POINTING TO A TWO PP-WORD CENTRAL
*                         MEMORY RMA. (REQUIRED)
*           INDEX       A PP DIRECT CELL WHICH CONTAINS AN INDEX WHICH IS
*                         ADDED TO *ADDRESS* TO DETERMINE THE PP WORD
*                         ADDRESS OF THE RMA. (OPTIONAL)
*           OFFSET      A CONSTANT TO BE USED AS A CENTRAL MEMORY WORD
*                         OFFSET. (OPTIONAL).
*
*         EXIT   (R-REGISTER) = CM ADDRESS/100B.
*                (A-REGISTER) = MOD(CM ADDRESS,100B) + 400000B


          PURGMAC LOADCM

LOADCM    MACRO  ADDRESS,ADDRIND,OFFSET
          LDK    ADDRESS
A         IFC    NE,$ADDRIND$$
          ADDL   ADDRIND
A         ENDIF
          RJM    FCA
B         IFC    NE,$OFFSET$$
          ADK    OFFSET
B         ENDIF
          ENDM
LOADCB    SPACE  4,10
**        LOADCB  - LOAD CENTRAL MEMORY ADDRESS PLUS BYTE OFFSET
*
*         LOADCB ADDRESS,BYTEOFF,WORDOFF
*
*         THIS MACRO IS USED TO LOAD THE *A* AND *R* REGISTERS FOR A
*         CENTRAL MEMORY READ OR WRITE OPERATION.
*
*         ENTRY
*           ADDRESS     A PP ADDRESS POINTING TO A THREE PP-WORD CENTRAL
*                         MEMORY REFORMATTED RMA. (REQUIRED)
*                         (ADDRESS) = UPPER 11 BITS OF RMA/100B
*                         (ADDRESS+1) = LOWER 12 BITS OF RMA/100B
*                         (ADDRESS+2) = MOD(RMA,100B)
*           BYTEOFF     A DIRECT CELL CONTAINING A CENTRAL MEMORY BYTE
*                         OFFSET. (OPTIONAL).
*           WORDOFF     A CONSTANT CONTAINING A CENTRAL MEMORY WORD
*                         OFFSET. (OPTIONAL).
*
*         EXIT   (R-REGISTER) = CM ADDRESS/100B.
*                (A-REGISTER) = MOD(CM ADDRESS,100B) + 400000B


          PURGMAC LOADCB

LOADCB    MACRO  ADDRESS,BYTEOFF,WORDOFF
          LRD    ADDRESS
A         IFC    NE,$BYTEOFF$$
          LDDL   BYTEOFF
          SHN    -3
          ADDL   ADDRESS+2
A         ELSE
          LDDL   ADDRESS+2
A         ENDIF
B         IFC    NE,$WORDOFF$$
          ADK    WORDOFF
B         ENDIF
          ADC    400000B
          ENDM
ADK       SPACE  4,10
**        ADK - ADD CONSTANT.
*
*         GENERATES ADC, ADN, SBN OR NOTHING.


          PURGMAC  ADK

 ADK      MACRO  A
  IF DEF,A,9D
  IFLT A,,4
  IFGE A,-77B,7
'?SCP#BB SET A
  SBN -'?SCP#BB
  SKIP 5
  IFLE A,77B,3
  IFNE A,,3
  ADN A
  SKIP 1
  ADC A
  ENDM
LDK       SPACE  4,10
**        LDK - LOAD CONSTANT.
*
*         GENERATES LDC, LDN OR LCN.


          PURGMAC  LDK

 LDK      MACRO  A
  IF DEF,A,8D
  IFMI A,4
  IFGE A,-77B,6
'?SCP#BB SET A
  LCN -'?SCP#BB
  SKIP 4
  IFLE A,77B,2
  LDN A
  SKIP 1
  LDC A
  ENDM
LMK       SPACE  4,10
**        LMC - LOGICAL MINUS CONSTANT.
*
*         GENERATES LMC, LMN OR NOTHING.


          PURGMAC  LMK

 LMK      MACRO  A
  IF DEF,A,5
  IFPL A,4
  IFLE A,77B,3
  IFNE A,,3
  LMN A
  SKIP 1
  LMC A
  ENDM
LPK       SPACE  4,10
**        LPK - LOGICAL PRODUCT CONSTANT.
*
*         GENERATES LPC, LPN, SCN OR NOTHING.


          PURGMAC  LPK

 LPK      MACRO  A
  IF DEF,A,9D
  IFMI A,5
  IFGE A,-77B,7
  IFNE A,,7
'?SCP#BB SET A
  SCN -'?SCP#BB
  SKIP 4
  IFLE A,77B,2
  LPN A
  SKIP 1
  LPC A
  ENDM
'?SCP#DS  SPACE  4,10
**        '?SCP#DS - DEFINE SYMBOL
*
*         THIS IS AN INTERNAL MACRO USED ONLY
*         BY SBK AND SCK . ASSEMBLY OF THIS
*         MACRO WILL ONLY OCCUR WHEN THE PARAMETER
*         ON THE SBK OR SCK MACRO IS UNDEFINED .
          PURGMAC  '?SCP#DS


'?SCP#DS  MACRO  A
          LOCAL  B
  RMT
B EQU A
  RMT
'?SCP#BB  MICRO  1,,*B*
  ENDM
SBK       SPACE  4,10
**        SBK - SUBTRACT CONSTANT.
*
*         GENERATES ADC, ADN, SBN OR NOTHING.


          PURGMAC  SBK

 SBK      MACRO  A
  IF DEF,A,3
'?SCP#BB SET A
  ADK -'?SCP#BB
  SKIP 2
  '?SCP#DS A
  ADC -"'?SCP#BB"
  ENDM
SCK       SPACE  4,10
**        SCK - SELECTIVE CLEAR CONSTANT.
*
*         GENERATES LPC, LPN, SCN OR NOTHING.


          PURGMAC  SCK

 SCK      MACRO  A
  IF DEF,A,3
'?SCP#BB SET A
  LPK -'?SCP#BB
  SKIP 2
  '?SCP#DS A
  LPK -"'?SCP#BB"
  ENDM
UJK       SPACE  4,10
**        UJK - UNCONDITIONAL JUMP.
*
*         UJK    M

          PURGMAC UJK

UJK       MACRO  P
  IF DEF,P,5
'?SCP#LF SET P
  IFGT *-'?SCP#LF,-40B,3
  IFLT *-'?SCP#LF,40B,2
  UJN P
  SKIP 1
  LJM P
  ENDM
          SPACE  4,10
          TITLE  UNIT INTERFACE TABLE DEFINITIONS.
**        UNIT INTERFACE TABLE FORMAT
*
*         FOR EACH LOCAL NAD THAT IS SUCCESSFULLY DEFINED BY A DEFINE_
*         LOCAL_NAD CONFIGURATION DIRECTIVE A CORRESPONDING UNIT INTERFACE
*         TABLE ENTRY IS GENERATED.
          SPACE  4,10
**        UNIT INTERFACE TABLE.
*


 UIT      RECORD PACKED

 LUN      PPWORD             LOGICAL UNIT NUMBER
 DIS      BOOLEAN            UNIT IS ENABLED/DISABLED (SET = DISABLED)
 DOWN     BOOLEAN            UNIT IS UP/DOWN (SET = DOWN)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
                               203(16) = NAD
 RQCLK     PPWORD             REQUEST CLOCK

          ALIGN  16,64
 UCOML    PPWORD             UNIT COMMUNICATION AREA LENGTH
 UCOMB    RMA                UNIT COMMUNICATION AREA BUFFER

 ULOCK    BOOLEAN            UNIT LOCK
          ALIGN  48,64
 ULOWN    PPWORD             UNIT LOCK OWNER

 UQLOCK   BOOLEAN            UNIT REQUEST QUEUE LOCK
          ALIGN  48,64
 UQLOWN   PPWORD             UNIT REQUEST QUEUE LOCK OWNER

          ALIGN  16,64
 PVANR    STRUCT 6           PVA OF NEXT UNIT REQUEST

          ALIGN  32,64
 RMANR    RMA                RMA OF NEXT UNIT REQUEST

 UIT      RECEND

          ERRNZ  C.UIT*4-P.UIT         THIS MUST BE A MULTIPLE OF CM WORDS
          TITLE  PP INTERFACE TABLE DEFINITIONS.
**        PP INTERFACE TABLE
*
*         A PP INTERFACE TABLE ENTRY MUST BE GENERATED FOR EACH NAD PP
*         DRIVER THAT IS TO BE INITIATED.  THE NUMBER OF PP DRIVERS THAT ARE
*         INITIATED IS SPECIFIED BY THE VALUE OF THE NUMBER_OF_PP_DRIVERS
*         DIRECTIVE THAT IS SPECIFIED IN THE INSTALLED RHFAM CONFIGURATION
*         FILE.  IF NO VALUE IS SPECIFIED, RHFAM LOADS ONE PP DRIVER FOR
*         EACH LOCAL NAD THAT IS DEFINED.
          SPACE  4,10
**        PP INTERFACE TABLE.
*


 PIT      RECORD PACKED

 PPNO     PPWORD             LOGICAL PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT NUMBER
 UNITC    PPWORD             NUMBER OF UNITS
 AFLAG    PPWORD             PP ACTIVE FLAG

          ALIGN  0,64
 INTREG   RMA                INTERRUPT REGISTER
 CIT      RMA                CHANNEL INTERLOCK TABLE

          ALIGN  16,64
 PCOML    PPWORD             PP COMMUNICATION AREA LENGTH
 PCOMB    RMA                PP COMMUNICATION AREA BUFFER

 PQLOCK   BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 PQLOWN   PPWORD             PP REQUEST QUEUE LOCK OWNER

          ALIGN  16,64
 PVANPR   STRUCT 6           PVA OF NEXT PP REQUEST

          ALIGN  32,64
 RMANPR   RMA                RMA OF NEXT PP REQUEST

          ALIGN  16,64
 RBPVA    STRUCT 6           PVA OF RESPONSE BUFFER

 FILL1    STRUCT 8           RESPONSE BUFFER LENGTH

          ALIGN  32,64
 RBRMA    RMA                RMA OF RESPONSE BUFFER

          ALIGN  48,64
 RBIN     PPWORD             RESPONSE BUFFER *IN* POINTER

          ALIGN  48,64
 RBOUT    PPWORD             RESPONSE BUFFER *OUT* POINTER

          ALIGN  48,64
 RBLIM    PPWORD             RESPONSE BUFFER *LIMIT* POINTER

 PIT      RECEND

          ERRNZ  C.PIT*4-P.PIT         THIS MUST BE A MULTIPLE OF CM WORDS
          SPACE  4,10
**        UNIT DESCRIPTORS.
*


 UD       RECORD PACKED

 LUN      PPWORD             LOGICAL UNIT NUMBER
 PVAUIT   STRUCT 6           PVA OF UNIT INTERFACE TABLE

 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 PUN      PPWORD             PHYSICAL UNIT NUMBER
 RMAUIT   RMA                RMA OF UNIT INTERFACE TABLE

 UD       RECEND

          ERRNZ  C.UD*4-P.UD           THIS MUST BE A MULTIPLE OF CM WORDS
          TITLE  PROCESSING REQUESTS.
**        PROCESSING REQUESTS
*
*         THE DRIVERS ISSUE THE NECESSARY NAD CONTROLWARE FUNCTIONS
*         TO COMPLETE THE VARIOUS REQUESTS.  IF THE CORRESPONDING REQUESTS
*         REQUIRE ANY DATA TRANSACTIONS THE DRIVER USES THE BUFFERS DEFINED
*         IN THE REQUEST AREA TO TRANSMIT DATA TO/FROM CENTRAL MEMORY FROM/TO
*         THE NAD.  IF AT ANY POINT DURING THE REQUEST PROCESSING THE DRIVER
*         ENCOUNTERS AN ERROR, THE DRIVER STOPS PROCESSING THE REQUEST AND
*         RESPONDS TO THE REQUESTOR.  THE RESPONSE PROVIDES THE REQUESTOR
*         WITH THE TYPE OF ERROR, THE POINT WITHIN THE REQUEST PROCESSING
*         THAT THE ERROR WAS ENCOUNTERED, AND ANY OTHER APPROPRIATE INFORMATION
*         TO AID IN THE PROBLEM ISOLATION/CORRECTION PROCESS.
*
*              EACH REQUEST THAT IS POSTED TO THE DRIVERS CONSISTS OF A SINGLE
*         LOGICAL COMMAND.  REQUESTS THAT REQUIRE FUNCTIONS NOT DEFINED BY THE
*         LOGICAL COMMANDS CAN BE CREATED BY USING THE PERFORM PHYSICAL
*         SUBCOMMANDS COMMAND (AC).  THE PERFORM PHYSICAL SUBCOMMANDS COMMAND
*         PROVIDES THE DRIVER WITH THE EXACT FUNCTION SEQUENCE TO PROCESS
*         THE REQUEST.  THIS FORMAT IS USED BY THE LOCAL NAD LOAD
*         AND DUMP PROCESSING AND IS ALSO AVAILABLE FOR FUTURE MAINTENANCE
*         FUNCTION CONSIDERATIONS.
          SPACE  4,10
**        SPECIAL PROCESSING NOTES
*
*         THE PP DRIVER IS DESIGNED WITH PERFORMANCE AND SIMPLICITY AS THE
*         MAJOR DRIVING FORCES IN THE DESIGN.  TO THIS END THE FOLLOWING
*         CONSTRAINTS AND FEATURES ARE EMPLOYED
*
*         1)   ALL DATA AND BUFFER ADDRESSES MUST BEGIN ON A WORD BOUNDARY.
*
*         2)   ALL DATA LENGTHS (EXCEPT FOR THE LAST ONE IN A BLOCK TRANSFER)
*              MUST BE A MULTIPLE OF TWO.
*
*         3)   NO RETRIES ON NAD ERRORS ARE MADE.  THIS MEANS THAT THE CPU
*              PROGRAMS MUST DISTINGUISH WHETHER A REQUEST IS RETRIABLE.
*
*         4)   THE SEND AND RECEIVE DATA FUNCTIONS ALLOW THE ACCESS METHOD TO
*              ADD AN OPTIONAL RETRY COUNT FOR EACH INDIVIDUAL BLOCK TRANSFER.
*              THIS REQUESTS THE DRIVER TO ATTEMPT RETRIES ON TRANSACTIONS
*              THAT ARE TEMPORARILY DELAYED BY NAD RESOURCE AVAILABILITY.
*
*         5)   THE SEND AND RECEIVE DATA FUNCTIONS USE A CIRCULAR BUFFER TO PASS
*              THE DRIVER ADDITIONAL BUFFER (OR DATA) ADDRESSES WHILE THE REQUEST
*              IS BEING PROCESSED.  THIS ALLOWS THE CPU ROUTINES TO POST
*              CONSECUTIVE REQUESTS WITHOUT GOING THROUGH MULTIPLE REQUEST/
*              RESPONSE SEQUENCES.
*
*         6)   SEVERAL OF THE COMMANDS HAVE THE ASSOCIATED BUFFER (DATA) AREAS
*              CONCATENATED TO THE REQUEST AREA.  THIS IS TO PROVIDE A BETTER
*              USE OF "REAL MEMORY" WHEN SHORT DATA TRANSACTIONS ARE PERFORMED.
          TITLE  PERIPHERAL REQUEST FORMAT.
**        PERIPHERAL REQUEST FORMAT
*
*         THIS SECTION DEFINES THE FORMAT FOR THE REQUESTS THAT THE
*         PP DRIVER PROCESSES.  EACH REQUEST HAS A STANDARD HEADER FORMAT
*         FOLLOWED BY THE ACTUAL NAD REQUEST.
*
*         STANDARD HEADER FORMAT
          SPACE  4,10
**        PERIPHERAL REQUEST.
*


 PR       RECORD PACKED

          ALIGN  16,64
 PVANPR   STRUCT 6           PVA OF NEXT PERIPHERAL REQUEST

          ALIGN  32,64
 RMANPR   RMA                RMA OF NEXT PERIPHERAL REQUEST

 RL       PPWORD             REQUEST LENGTH
 LUN      PPWORD             LOGICAL UNIT NUMBER (UNIT REQUESTS ONLY)
 RECOV    SUBRANGE 0,3       RECOVERY OPTIONS
                               0 = ATTEMPT RECOVERY
                               1 = SUPPRESS RECOVERY, RETURN ERROR
                               2 = RESERVED FOR FUTURE USE
                               3 = SUPPRESS RECOVERY, IGNORE ERRORS
 INTCPU   BOOLEAN            INTERRUPT CPU (IF SET)
 CPUP     SUBRANGE 0,31      CPU PORT TO INTERRUPT
 PRIOR    SUBRANGE 0,377B    RELATIVE PRIORITY OF REQUEST
 ALERTM   PPWORD             ALERT MASK

 SECADD   INTEGER            SECONDARY ADDRESS

          MGEN   N.CPUP      RIGHT JUSTIFIED CPU MASK
 M.CPUP   EQU    MASK$

 PR       RECEND

          ERRNZ  C.PR*4-P.PR           THIS MUST BE A MULTIPLE OF CM WORDS
          TITLE  COMMAND FORMATS
**        COMMAND FORMATS
*
*         THE FOLLOWING ARE THE DEFAULT COMMAND FORMATS FOR THE VARIOUS
*         COMMANDS THAT ARE PROCESSED BY THE PP.
          SPACE  4,10
**        PP COMMAND FORMAT
*


 CF       RECORD PACKED

 PPCMND   SUBRANGE 0,377B    PP COMMAND
 RESP     BOOLEAN            SEND RESPONSE
 INDADD   BOOLEAN            INDIRECT ADDRESS SPECIFIED
*                            REMAINING FLAGS USED ON INDIVIDUAL REQUESTS
          ALIGN  16,64
 LENGTH   PPWORD             LENGTH OF DATA/BUFFER
 BUFFER   RMA                RMA OF DATA BUFFER

 CF       RECEND

          ERRNZ  C.CF*4-P.CF           THIS MUST BE A MULTIPLE OF CM WORDS
          SPACE  4,10
**        LOGICAL COMMAND FORMAT
*


 LCF      RECORD PACKED

 LCMND    SUBRANGE 0,377B    LOGICAL COMMAND
 RESP     BOOLEAN            SEND RESPONSE
 INDADD   BOOLEAN            INDIRECT ADDRESS SPECIFIED
 PPLOCK   BOOLEAN            PP IS PROCESSING REQUEST
 PPCOMP   BOOLEAN            PP HAS COMPLETED REQUEST PROCESSING
 FLUSH    BOOLEAN            FLUSH EXCESS DATA ON INPUT REQUEST
*                            REMAINING FLAGS USED ON INDIVIDUAL REQUESTS
          ALIGN  16,64
 LENGTH   PPWORD             LENGTH OF DATA/BUFFER
 BUFFER   RMA                RMA OF DATA BUFFER

          ALIGN  48,64       USED FOR INDIVIDUAL REQUESTS
 PATHID   PPWORD             PATH IDENTIFIER

          MASKP  PPLOCK
 M.PPLOCK EQU    MSK
          MASKP  PPCOMP
 M.PPCOMP EQU    MSK

 LCF      RECEND

          ERRNZ  C.LCF*4-P.LCF         THIS MUST BE A MULTIPLE OF CM WORDS
          SPACE  4,10
**        PHYSICAL COMMAND FORMAT
*


 PCF      RECORD PACKED

 PCMND    SUBRANGE 0,377B    PHYSICAL COMMAND
          ALIGN  16,64
 LENGTH   PPWORD             LENGTH OF DATA/BUFFER
 BUFFER   RMA                RMA OF DATA BUFFER

 PCF      RECEND

          ERRNZ  C.PCF*4-P.PCF         THIS MUST BE A MULTIPLE OF CM WORDS
          TITLE  PP REQUEST FORMATS.
**        PP REQUESTS
*
*         THIS SECTION DEFINES THE COMMAND FORMATS FOR THE SUPPORTED PP
*         REQUESTS.
          SPACE  4,10
**        IDLE (4).
*
*         THE PURPOSE OF THIS REQUEST IS TO STOP THE PP FROM PROCESSING
*         ANY REQUESTS UNTIL A RESUME ACTIVITY PP REQUEST IS ENCOUNTERED.


 IDLE     RECORD PACKED

 PPCMND   SUBRANGE 0,377B    PP COMMAND
 RESP     BOOLEAN            SEND RESPONSE
 INDADD   BOOLEAN            INDIRECT ADDRESS SPECIFIED

 IDLE     RECEND
          SPACE  4,10
**        RESUME (5).
*
*         THE PURPOSE OF THIS REQUEST IS TO HAVE THE PP LEAVE THE IDLE STATE
*         AND RESUME NORMAL PROCESSING.


 RESUME   RECORD PACKED

 PPCMND   SUBRANGE 0,377B    PP COMMAND
 RESP     BOOLEAN            SEND RESPONSE
 INDADD   BOOLEAN            INDIRECT ADDRESS SPECIFIED

 RESUME   RECEND
          TITLE  UNIT REQUEST FORMATS.
**        UNIT REQUESTS
*
*         THIS SECTION DEFINES THE COMMAND FORMATS FOR THE SUPPORTED UNIT
*         REQUESTS.
          SPACE  4,10
**        REQUEST CONNECTION (A0).
*
*         THE PURPOSE OF THIS REQUEST IS TO INITIATE THE CONNECTION
*         ESTABLISHMENT PROCESS BY SENDING A CONNECT REQUEST MESSAGE TO THE
*         DESTINATION HOST.


 RC       RECORD PACKED

 LCMND    SUBRANGE 0,377B    LOGICAL COMMAND
 RESP     BOOLEAN            SEND RESPONSE
 INDADD   BOOLEAN            INDIRECT ADDRESS SPECIFIED
 PPLOCK   BOOLEAN            PP IS PROCESSING REQUEST
 PPCOMP   BOOLEAN            PP HAS COMPLETED REQUEST PROCESSING
 FLUSH    BOOLEAN            FLUSH EXCESS DATA ON INPUT REQUEST
 CTYPE    BOOLEAN            CONNECTION TYPE (0 = NORMAL, 1 = MAINT.)
          ALIGN  16,64
 LENGTH   PPWORD             LENGTH OF DATA/BUFFER
 BUFFER   RMA                RMA OF DATA BUFFER

          ALIGN  48,64
 PATHID   PPWORD             PATH ID OF NAD ASSIGNED PATH (RETURN PARAMETER)

 RC       RECEND
          SPACE  4,10
**        OBTAIN CONNECTION (A1).
*
*         THE PURPOSE OF THIS REQUEST IS TO OBTAIN THE INCOMING CONNECT
*         REQUEST ASSOCIATED WITH THE CONNECTION END POINT SPECIFIED BY THE
*         'PATH ID' FIELD.


 OC       RECORD PACKED

 LCMND    SUBRANGE 0,377B    LOGICAL COMMAND
 RESP     BOOLEAN            SEND RESPONSE
 INDADD   BOOLEAN            INDIRECT ADDRESS SPECIFIED
 PPLOCK   BOOLEAN            PP IS PROCESSING REQUEST
 PPCOMP   BOOLEAN            PP HAS COMPLETED REQUEST PROCESSING
 FLUSH    BOOLEAN            FLUSH EXCESS DATA ON INPUT REQUEST
          ALIGN  16,64
 LENGTH   PPWORD             LENGTH OF DATA/BUFFER
 BUFFER   RMA                RMA OF DATA BUFFER

 PHYFRM   STRUCT 4           PHYSICAL FROM (USED AS SELECTION CRITERIA)
          ALIGN  48,64
 PATHID   PPWORD             PATH IDENTIFIER

 OC       RECEND
          SPACE  4,10
**        ACCEPT CONNECTION (A2).
*
*         THE PURPOSE OF THIS REQUEST IS TO ACCEPT AN INCOMING CONNECT
*         REQUEST.


 AC       RECORD PACKED

 LCMND    SUBRANGE 0,377B    LOGICAL COMMAND
 RESP     BOOLEAN            SEND RESPONSE
 INDADD   BOOLEAN            INDIRECT ADDRESS SPECIFIED
 PPLOCK   BOOLEAN            PP IS PROCESSING REQUEST
 PPCOMP   BOOLEAN            PP HAS COMPLETED REQUEST PROCESSING
 FLUSH    BOOLEAN            FLUSH EXCESS DATA ON INPUT REQUEST

          ALIGN  0,64
          ALIGN  48,64
 PATHID   PPWORD             PATH IDENTIFIER

 AC       RECEND
          SPACE  4,10
**        REJECT CONNECTION (A3).
*
*         THE PURPOSE OF THIS REQUEST IS TO REJECT AN INCOMING CONNECT
*         REQUEST.


 RJ       RECORD PACKED

 LCMND    SUBRANGE 0,377B    LOGICAL COMMAND
 RESP     BOOLEAN            SEND RESPONSE
 INDADD   BOOLEAN            INDIRECT ADDRESS SPECIFIED
 PPLOCK   BOOLEAN            PP IS PROCESSING REQUEST
 PPCOMP   BOOLEAN            PP HAS COMPLETED REQUEST PROCESSING
 FLUSH    BOOLEAN            FLUSH EXCESS DATA ON INPUT REQUEST

          ALIGN  0,64
 RCODE    STRUCT 4           REJECT CODE
          ALIGN  48,64
 PATHID   PPWORD             PATH IDENTIFIER

 RJ       RECEND
          SPACE  4,10
**        SEND DATA (A4).
*
*         THE PURPOSE OF THIS REQUEST IS TO SEND BLOCKS OF DATA
*         ACROSS THE SPECIFIED CONNECTION.  THE SEND DATA COMMAND IS BROKEN
*         UP INTO SUBFUNCTIONS, WHERE EACH SUBFUNCTION REPRESENTS THE
*         TRANSMISSION OF A SINGLE NETWORK BLOCK.
*
*              THE SEND DATA COMMAND PROVIDES AN INTERFACE FOR REQUESTORS
*         TO POST ADDITIONAL SUBFUNCTIONS WHILE THE REQUEST IS BEING
*         PROCESSED.  THE PP PROVIDES THE NECESSARY INTERRUPTS TO NOTIFY
*         THE REQUESTOR WHEN ADDITIONAL SUBFUNCTIONS CAN BE POSTED.  THE
*         PP CAUSES THE INTERRUPT BY SENDING AN INTERMEDIATE RESPONSE TO THE
*         REQUESTOR.  INTERMEDIATE RESPONSES ARE SENT WHEN THE SUBFUNCTION
*         BUFFER IS LESS THAN HALF FULL.  MONITOR REFORMATS THE RESPONSE AND
*         SIGNALS THE CORRESPONDING TASK.  THE SIGNAL HANDLER DETERMINES THAT
*         THIS IS AN INTERMEDIATE RESPONSE FOR A SEND DATA COMMAND AND
*         POSTS ADDITIONAL SUBFUNCTIONS, IF APPROPRIATE.
*
*         THE SEND DATA FUNCTION ASSUMES THE REQUESTOR HAS STARTED ALL
*         BUFFERS ON A WORD BOUNDARY AND THAT ALL BUFFER LENGTHS (EXCEPT THE
*         LAST) ARE A MULTIPLE OF TWO.  THE PP DRIVER READS UP EACH BUFFER
*         IN THE SUBFUNCTION, CONCATENATING THE BUFFERS TO FORM A BLOCK, AND
*         SENDS THE DATA WITH A SINGLE TRANSACTION.  THE PP TERMINATES THE
*         REQUEST IF ONE OF THE FOLLOWING OCCURS
*
*              1)  THE IN AND OUT POINTERS ARE EQUIVALANT.  IN THIS CASE A
*                  NORMAL RESPONSE IS RETURNED.
*
*              2)  THE RETRY COUNT FOR THE CURRENT SUBFUNCTION IS ZERO AND THE
*                  CURRENT NAD RESPONSE IS RESOURCES UNAVAILABLE.  IN THIS
*                  CASE AN ABNORMAL RESPONSE IS RETURNED AND THE CONTROLWARE
*                  STATUS SHOULD REFLECT THE RESOURCE CONDITION.
*
*              3)  AN ERROR WAS ENCOUNTERED.  IN THIS CASE THE RESPONSE
*                  CONTAINS THE APPROPRIATE INFORMATION TO ALLOW THE CPU
*                  PROGRAMS TO DETERMINE THE REASON FOR THE FAILURE.


 SD       RECORD PACKED

 LCMND    SUBRANGE 0,377B    LOGICAL COMMAND
 RESP     BOOLEAN            SEND RESPONSE
 INDADD   BOOLEAN            INDIRECT ADDRESS SPECIFIED
 PPLOCK   BOOLEAN            PP IS PROCESSING REQUEST
 PPCOMP   BOOLEAN            PP HAS COMPLETED REQUEST PROCESSING
 FLUSH    BOOLEAN            FLUSH EXCESS DATA ON INPUT REQUEST
 SINTR    BOOLEAN            SEND INTERMEDIATE RESPONSE

          ALIGN  0,64
 RESRTY   PPWORD             WAITING FOR RESOURCES RETRY COUNTER
 PREVIN   PPWORD             PREVIOUS IN POINTER
 INPTRC   PPWORD             IN POINTER CHANGE
 PATHID   PPWORD             PATH IDENTIFIER

          ALIGN  0,64
 MORDAT   BOOLEAN            CPU HAS MORE DATA TO SEND
          ALIGN  48,64
 INPTR    PPWORD             IN POINTER

          ALIGN  48,64
 OUTPTR   PPWORD             OUT POINTER

          MASKP  SINTR
 M.SINTR  EQU    MSK

 SD       RECEND


**        SEND DATA SUBFUNCTIONS.
*


 SDSF     RECORD PACKED

 SFL      PPWORD             SUBFUNCTION LENGTH
          ALIGN  48,64
 FILL     PPWORD             USED TO GET THE RIGHT BYTE SIZE
 SDSF     RECEND


**        I/O DATA BUFFERS.
*


 IODB     RECORD PACKED

          ALIGN  16,64
 LENGTH   PPWORD             BUFFER LENGTH
 BUFFER   RMA                RMA OF DATA BUFFER

 IODB     RECEND

          SPACE  4,10
**        RECEIVE DATA (A5).
*
*         THE PURPOSE OF THIS REQUEST IS TO RECEIVE BLOCKS OF DATA
*         FROM THE SPECIFIED CONNECTION.  THE RECEIVE DATA COMMAND IS BROKEN
*         UP INTO SUBFUNCTIONS, WHERE EACH SUBFUNCTION REPRESENTS THE
*         RECEIVING OF A SINGLE NETWORK BLOCK.
*
*              THE RECEIVE DATA COMMAND PROVIDES AN INTERFACE FOR REQUESTORS
*         TO POST ADDITIONAL SUBFUNCTIONS WHILE THE REQUEST IS BEING
*         PROCESSED.  THE PP PROVIDES THE NECESSARY INTERRUPTS TO NOTIFY
*         THE REQUESTOR WHEN ADDITIONAL SUBFUNCTIONS CAN BE POSTED.  THE
*         PP CAUSES THE INTERRUPT BY SENDING AN INTERMEDIATE RESPONSE TO THE
*         REQUESTOR.  INTERMEDIATE RESPONSES ARE SENT WHEN THE SUBFUNCTION
*         BUFFER IS LESS THAN HALF FULL.  MONITOR REFORMATS THE RESPONSE AND
*         SIGNALS THE CORRESPONDING TASK.  THE SIGNAL HANDLER DETERMINES THAT
*         THIS IS AN INTERMEDIATE RESPONSE FOR A RECEIVE DATA COMMAND AND
*         POSTS ADDITIONAL SUBFUNCTIONS, IF APPROPRIATE.
*
*         THE RECEIVE DATA FUNCTION ASSUMES THE REQUESTOR HAS STARTED ALL
*         BUFFERS ON A WORD BOUNDARY AND THAT ALL BUFFER LENGTHS (EXCEPT THE
*         LAST) ARE A MULTIPLE OF TWO.  THE PP DRIVER READS THE AMOUNT OF DATA
*         SPECIFIED BY THE 'TOTAL BUFFER LENGTH' FIELD INTO THE PP.  THE PP
*         TRANSFERS THE DATA INTO THE BUFFERS ACCORDING TO THE AMOUNT OF
*         DATA EACH BUFFER CAN HOLD.  NOTE, BUFFERS NOT ENDING ON A WORD
*         BOUNDARY ARE GARBAGE FILLED UP TO THE WORD BOUNDARY.  THE RECEIVE
*         DATA REQUEST IS TERMINATED WHEN ONE OF THE FOLLOWING CONDITIONS
*         OCCURS
*
*              1)  THE IN AND OUT POINTERS ARE EQUIVALANT.  IN THIS CASE A
*                  NORMAL RESPONSE IS RETURNED.
*
*              2)  THE RETRY COUNT FOR THE CURRENT SUBFUNCTION IS ZERO AND THE
*                  CURRENT NAD RESPONSE IS RESOURCES UNAVAILABLE.  IN THIS
*                  CASE AN ABNORMAL RESPONSE IS RETURNED AND THE CONTROLWARE
*                  STATUS SHOULD REFLECT THE RESOURCE CONDITION.
*
*              3)  AN ERROR IS ENCOUNTERED.  IN THIS CASE THE RESPONSE
*                  CONTAINS THE APPROPRIATE INFORMATION TO ALLOW THE CPU
*                  PROGRAMS TO DETERMINE THE REASON FOR THE FAILURE.
*
*              4)  A FILE MARK OR A BLOCK MODE SWITCH (PRU TO NON-PRU OR VICE-
*                  VERSA) IS ENCOUNTERED.


 RD       RECORD PACKED

 LCMND    SUBRANGE 0,377B    LOGICAL COMMAND
 RESP     BOOLEAN            SEND RESPONSE
 INDADD   BOOLEAN            INDIRECT ADDRESS SPECIFIED
 PPLOCK   BOOLEAN            PP IS PROCESSING REQUEST
 PPCOMP   BOOLEAN            PP HAS COMPLETED REQUEST PROCESSING
 FLUSH    BOOLEAN            FLUSH EXCESS DATA ON INPUT REQUEST
 SINTR    BOOLEAN            SEND INTERMEDIATE RESPONSE

          ALIGN  0,64
 RESRTY   PPWORD             WAITING FOR RESOURCES RETRY COUNTER
 PREVIN   PPWORD             PREVIOUS IN POINTER
 INPTRC   PPWORD             IN POINTER CHANGE
 PATHID   PPWORD             PATH IDENTIFIER

          ALIGN  0,64
 MORDAT   BOOLEAN            CPU IS EXPECTING MORE DATA
          ALIGN  48,64
 INPTR    PPWORD             IN POINTER

          ALIGN  48,64
 OUTPTR   PPWORD             OUT POINTER

          MASKP  SINTR
 M.SINTR  EQU    MSK

 RD       RECEND


**        READ DATA SUBFUNCTIONS.
*


 RDSF     RECORD PACKED

 SFL      PPWORD             SUBFUNCTION LENGTH
 TBL      PPWORD             TOTAL BUFFER LENGTH
 NBT      PPWORD             NUMBER OF BYTES TRANSFERRED
 FILL     PPWORD             USED TO GET THE RIGHT BYTE SIZE

 RDSF     RECEND


**        I/O DATA BUFFERS.  (SAME AS SEND DATA)
*


*IODB     RECORD PACKED
*
*         ALIGN  16,64
*LENGTH   PPWORD             BUFFER LENGTH
*BUFFER   RMA                RMA OF DATA BUFFER
*
*IODB     RECEND

          SPACE  4,10
**        STATUS NAD (A6).
*
*         THE PURPOSE OF THIS REQUEST IS TO OBTAIN THE STATUS INFORMATION
*         OF THE CORRESPONDING LOCAL NAD.


 SN       RECORD PACKED

 LCMND    SUBRANGE 0,377B    LOGICAL COMMAND
 RESP     BOOLEAN            SEND RESPONSE
 INDADD   BOOLEAN            INDIRECT ADDRESS SPECIFIED
 PPLOCK   BOOLEAN            PP IS PROCESSING REQUEST
 PPCOMP   BOOLEAN            PP HAS COMPLETED REQUEST PROCESSING
 FLUSH    BOOLEAN            FLUSH EXCESS DATA ON INPUT REQUEST
 UNCOND   BOOLEAN            UNCONDITIONALLY OBTAIN STATUS
          ALIGN  16,64
 LENGTH   PPWORD             LENGTH OF DATA/BUFFER
 BUFFER   RMA                RMA OF DATA BUFFER

 SN       RECEND
          SPACE  4,10
**        SEND CONTROL MESSAGE (A7).
*
*         THE PURPOSE OF THIS REQUEST IS TO SEND A CONTROL MESSAGE TO
*         A REMOTE HOST.


 SCM      RECORD PACKED

 LCMND    SUBRANGE 0,377B    LOGICAL COMMAND
 RESP     BOOLEAN            SEND RESPONSE
 INDADD   BOOLEAN            INDIRECT ADDRESS SPECIFIED
 PPLOCK   BOOLEAN            PP IS PROCESSING REQUEST
 PPCOMP   BOOLEAN            PP HAS COMPLETED REQUEST PROCESSING
 FLUSH    BOOLEAN            FLUSH EXCESS DATA ON INPUT REQUEST
          ALIGN  16,64
 LENGTH   PPWORD             LENGTH OF DATA/BUFFER
 BUFFER   RMA                RMA OF DATA BUFFER

 SCM      RECEND
          SPACE  4,10
**        RECEIVE CONTROL MESSAGE (A8).
*
*         THE PURPOSE OF THIS REQUEST IS TO RECEIVE A CONTROL MESSAGE FROM
*         A REMOTE HOST.


 RCM      RECORD PACKED

 LCMND    SUBRANGE 0,377B    LOGICAL COMMAND
 RESP     BOOLEAN            SEND RESPONSE
 INDADD   BOOLEAN            INDIRECT ADDRESS SPECIFIED
 PPLOCK   BOOLEAN            PP IS PROCESSING REQUEST
 PPCOMP   BOOLEAN            PP HAS COMPLETED REQUEST PROCESSING
 FLUSH    BOOLEAN            FLUSH EXCESS DATA ON INPUT REQUEST
 CMTYPE   BOOLEAN            CONTROL MESSAGE TYPE (0=INCOMING,1=REJECTED)
          ALIGN  16,64
 LENGTH   PPWORD             LENGTH OF DATA/BUFFER
 BUFFER   RMA                RMA OF DATA BUFFER

 PHYFRM   STRUCT 4           PHYSICAL FROM (USED AS SELECTION CRITERIA)

 RCM      RECEND
          SPACE  4,10
**        DISCONNECT PATHS (A9).
*
*         THE PURPOSE OF THIS REQUEST IS TO TERMINATE CONNECTIONS.


 DP       RECORD PACKED

 LCMND    SUBRANGE 0,377B    LOGICAL COMMAND
 RESP     BOOLEAN            SEND RESPONSE
 INDADD   BOOLEAN            INDIRECT ADDRESS SPECIFIED
 PPLOCK   BOOLEAN            PP IS PROCESSING REQUEST
 PPCOMP   BOOLEAN            PP HAS COMPLETED REQUEST PROCESSING
 FLUSH    BOOLEAN            FLUSH EXCESS DATA ON INPUT REQUEST
 ABNORM   BOOLEAN            ABNORMAL TERMINATION FLAG

          ALIGN  0,64
          ALIGN  48,64
 PATHID   PPWORD             PATH IDENTIFIER

 DP       RECEND
          SPACE  4,10
**        READ PATH STATUS TABLE (AA).
*
*         THE PURPOSE OF THIS REQUEST IS TO OBTAIN THE PATH STATUS TABLE
*         INFORMATION FOR A SPECIFIED PATH IDENTIFIER.


 RPST     RECORD PACKED

 LCMND    SUBRANGE 0,377B    LOGICAL COMMAND
 RESP     BOOLEAN            SEND RESPONSE
 INDADD   BOOLEAN            INDIRECT ADDRESS SPECIFIED
 PPLOCK   BOOLEAN            PP IS PROCESSING REQUEST
 PPCOMP   BOOLEAN            PP HAS COMPLETED REQUEST PROCESSING
 FLUSH    BOOLEAN            FLUSH EXCESS DATA ON INPUT REQUEST
          ALIGN  16,64
 LENGTH   PPWORD             LENGTH OF DATA/BUFFER
 BUFFER   RMA                RMA OF DATA BUFFER

          ALIGN  48,64
 PATHID   PPWORD             PATH IDENTIFIER

 RPST     RECEND
          SPACE  4,10
**        OBTAIN NAD GENERAL STATUS (AB).
*
*         THE PURPOSE OF THIS REQUEST IS TO OBTAIN THE GENERAL STATUS
*         INFORMATION FOR THE CORRESPONDING NAD.


 ONGS     RECORD PACKED

 LCMND    SUBRANGE 0,377B    LOGICAL COMMAND
 RESP     BOOLEAN            SEND RESPONSE
 INDADD   BOOLEAN            INDIRECT ADDRESS SPECIFIED
 PPLOCK   BOOLEAN            PP IS PROCESSING REQUEST
 PPCOMP   BOOLEAN            PP HAS COMPLETED REQUEST PROCESSING
 FLUSH    BOOLEAN            FLUSH EXCESS DATA ON INPUT REQUEST
 RNADP    BOOLEAN            REMOTE NAD PRIMED FOR GENERAL STATUS
          ALIGN  16,64
 LENGTH   PPWORD             LENGTH OF DATA/BUFFER
 BUFFER   RMA                RMA OF DATA BUFFER

 RETRYC   PPWORD             RETRY COUNT
          ALIGN  48,64
 PATHID   PPWORD             PATH IDENTIFIER

 ONGS     RECEND

*         NOTE - TO OBTAIN THE REMOTE NAD GENERAL STATUS THE REQUEST
*         CONNECTION COMMAND MUST BE USED TO GENERATE A MAINTENANCE
*         CONNECTION TO THE REMOTE NAD.  ALSO, THE ABNORMAL PATH
*         DISCONNECT SHOULD BE USED TO TERMINATE THE PATH AFTER THE
*         GENERAL STATUS IS OBTAINED.
          SPACE  4,10
**        PHYSICAL COMMAND PROCESSING (AC).
*
*         THE PURPOSE OF THIS FUNCTION IS TO PROVIDE A PRIMITIVE COMMAND
*         INTERFACE FOR PHYSICAL NAD FUNCTIONS.


 PCP      RECORD PACKED

 LCMND    SUBRANGE 0,377B    PHYSICAL COMMAND
 RESP     BOOLEAN            SEND RESPONSE
 INDADD   BOOLEAN            INDIRECT ADDRESS SPECIFIED
 PPLOCK   BOOLEAN            PP IS PROCESSING REQUEST
 PPCOMP   BOOLEAN            PP HAS COMPLETED REQUEST PROCESSING
 FLUSH    BOOLEAN            FLUSH EXCESS DATA ON INPUT REQUEST

 PCP      RECEND
          SPACE  4,10
**        ISSUE NAD FUNCTION (20).
*
*         THE PURPOSE OF THIS COMMAND IS TO ISSUE A FUNCTION TO THE NAD.


 INF      RECORD PACKED

 PCMND    SUBRANGE 0,377B    PHYSICAL COMMAND
          ALIGN  48,64
 FUNC     PPWORD             NAD FUNCTION TO ISSUE

 INF      RECEND
          SPACE  4,10
**        OUTPUT 8/8 DATA (23).
*
*         THE PURPOSE OF THIS COMMAND IS TO SEND DATA TO THE NAD IN AN
*         8/8 FORMAT.


 O8D      RECORD PACKED

 PCMND    SUBRANGE 0,377B    PHYSICAL COMMAND
          ALIGN  16,64
 LENGTH   PPWORD             LENGTH OF DATA TO SEND
 BUFFER   RMA                RMA OF DATA BUFFER

 O8D      RECEND
          SPACE  4,10
**        INPUT 8/8 DATA (25).
*
*         THE PURPOSE OF THIS COMMAND IS TO RECEIVE DATA FROM THE NAD IN AN
*         8/8 FORMAT.


 I8D      RECORD PACKED

 PCMND    SUBRANGE 0,377B    PHYSICAL COMMAND
          ALIGN  16,64
 LENGTH   PPWORD             LENGTH OF DATA BUFFER
 BUFFER   RMA                RMA OF DATA BUFFER

 I8D      RECEND
          SPACE  4,10
**        SET TRANSFER ADDRESS AND LENGTH (28)
*
*         THE PURPOSE OF THIS COMMAND IS TO SEND THE DATA TRANSFER LENGTH
*         AND ADDRESS TO THE DATA.  THE DATA MUST BE IN AN 8/16 FORMAT IN
*         CM, WHERE THE LOW ORDER 8 BITS CONTAINS THE ACTUAL DATA.


 SAL      RECORD PACKED

 PCMND    SUBRANGE 0,377B    PHYSICAL COMMAND
          ALIGN  16,64
 LENGTH   PPWORD             LENGTH OF DATA TO SEND
 BUFFER   RMA                RMA OF DATA BUFFER

 SAL      RECEND
          SPACE  4,10
**        OBTAIN NAD HARDWARE STATUS (29).
*
*         THE PURPOSE OF THIS COMMAND IS TO OBTAIN THE NAD HARDWARE STATUS.


 ONHS     RECORD PACKED

 PCMNC    SUBRANGE 0,377B    PHYSICAL COMMAND
          ALIGN  32,64
 HWMASK   PPWORD             HARDWARE STATUS MASK
 HWVAL    PPWORD             HARDWARE STATUS VALUE

 ONHS     RECEND
          SPACE  4,10
**        OBTAIN NAD CONTROLWARE STATUS (2A).
*
*         THE PURPOSE OF THIS COMMAND IS TO OBTAIN THE NAD CONTROLWARE STATUS.


 ONCS     RECORD PACKED

 PCMND    SUBRANGE 0,377B    PHYSICAL COMMAND
          ALIGN  32,64
 CWMASK   PPWORD             CONTROLWARE STATUS MASK
 CWVAL    PPWORD             CONTROLWARE STATUS VALUE

 ONCS     RECEND
          TITLE  CHANNEL PASSING ALGORITHM.
**        CHANNEL PASSING
*
*         THE ABILITY TO UTILIZE THE FULL CAPACITY OF THE 170 NAD REQUIRES
*         MULTIPLE PP DRIVERS.  TO ALLOW MULTIPLE DRIVERS (INCLUDING MAINTENANCE
*         PPS) TO SHARE A SINGLE NAD, A MECHANISM FOR SHARING ACCESS
*         TO THE CHANNEL MUST BE EMPLOYED.  THE RHFAM/VE DRIVERS ONLY INTERLOCK A
*         CHANNEL FOR THE DURATION OF THE CHANNEL ACTIVITY.  ONCE THE CHANNEL
*         ACTIVITY IS COMPLETE THE CHANNEL IS RELEASED IMMEDIATELY ALLOWING
*         OTHER DRIVERS TO PROCESS REQUESTS ON THAT CHANNEL.  THE EXCEPTIONS
*         TO THIS RULE ARE THE PHYSICAL SUBCOMMANDS.  FOR THESE REQUESTS
*         THE PP HOLDS THE CHANNEL UNTIL ALL PHYSICAL SUBCOMMANDS ARE PROCESSED.
*
*              EACH TIME THAT A PP DRIVER OBTAINS THE CHANNEL, THE PP DRIVER MUST
*         RECHECK THE UNIT FLAGS FOR THE CORRESPONDING LOCAL NAD TO VERIFY THAT
*         THE NAD IS IN THE APPROPRIATE STATE FOR PROCESSING THE REQUEST.  IF
*         THE NAD STATE HAS CHANGED, THE PP CLEARS THE PROCESSING FLAG AND DOES
*         NOT POST A RESPONSE.  THE PP THEN CONTINUES WITH ITS SEARCH THROUGH
*         THE UNIT INTERFACE TABLES (STARTING WITH THE NEXT UNIT TABLE).
          TITLE   RESPONSE INTERRUPT ALGORITHM.
**        RESPONSE INTERRUPTS
*
*         THE PP DRIVERS ARE PROGRAMMED TO MINIMIZE THE NUMBER OF EXTERNAL
*         INTERRUPTS.  AS EACH RESPONSE IS POSTED TO MONITOR, THE DRIVERS SET THE
*         CORRESPONDING INTERRUPT REGISTER, WHICH IS DEFINED BY A POINTER IN THE
*         PP'S INTERFACE TABLE ENTRY.  WHEN THE RESPONSE BUFFER IS MORE THAN HALF
*         FULL THE PP CAUSES A MONITOR INTERRUPT TO PROCESS THE RESPONSES.
*         THE PP, HOWEVER, KEEPS PROCESSING REQUESTS AND POSTING RESPONSES
*         UNTIL THE RESPONSE BUFFER IS FULL.  AT THIS POINT THE PP MUST WAIT,
*         ATTEMPTING MONITOR INTERRUPTS IF NECESSARY, UNTIL THERE IS ROOM FOR
*         THE NEXT RESPONSE.
*
*              THIS ALGORITHM ASSUMES THAT THROUGH NORMAL PROCESSING MONITOR
*         SHOULD BE INVOKED OFTEN ENOUGH, WITHOUT PP INTERRUPTION, TO PROCESS
*         THE PP RESPONSES BEFORE THE BUFFER THRESHOLD IS REACHED.  THIS
*         ALGORITHM ALSO ASSUMES THAT ONCE MONITOR IS INTERRUPTED, BECAUSE
*         THE RESPONSE BUFFER THRESHOLD WAS REACHED, THAT MONITOR SHOULD
*         PROCESS THE PP RESPONSES BEFORE THE DRIVER COULD FILL THE BUFFER.
*         GIVEN THE ABOVE ASSUMPTIONS THE PP DRIVERS SHOULD ONLY CAUSE A
*         MINIMUM NUMBER OF INTERRUPTS AND THE PP DRIVER SHOULD RARELY, IF
*         EVER, SUSPEND PROCESSING BECAUSE THE PP RESPONSE BUFFER IS FULL.
          SPACE  4,10
**        PERIPHERAL RESPONSE FORMAT
*
*         THIS SECTION DEFINES THE FORMAT FOR THE PERIPHERAL REQUEST RESPONSES
*         POSTED BY PP DRIVER PROCESSES.  EACH RESPONSE HAS A STANDARD HEADER
*         FORMAT FOLLOWED BY THE DETAILED STATUS INFORMATION (IF SPECIFIED).
          SPACE  4,10
**        PERIPHERAL RESPONSE.
*


 PRS      RECORD PACKED


          ALIGN  16,64
 PVAOR    STRUCT 6           PVA OF REQUEST

          ALIGN  32,64
 RMAOR    RMA                RMA OF REQUEST

 RL       PPWORD             RESPONSE LENGTH
 LUN      PPWORD             LOGICAL UNIT NUMBER  (UNIT REQUESTS ONLY)
 RECOV    SUBRANGE 0,3       RECOVERY OPTIONS
                               0 = ATTEMPT RECOVERY
                               1 = SUPPRESS RECOVERY, RETURN ERROR
                               2 = RESERVED FOR FUTURE USE
                               3 = SUPPRESS RECOVERY, IGNORE ERRORS
 INTCPU   BOOLEAN            INTERUPT CPU (IF SET)
 CPUP     SUBRANGE 0,31      CPU PORT TO INTERRUPT
 PRIOR    SUBRANGE 0,377B    RELATIVE PRIORITY OF REQUEST
 ALERTM   PPWORD             ALERT MASK

*ABNSTA   PPWORD             ABNORMAL STATUS
 ALERT    BOOLEAN              A MASKED ALERT CONDITION OCCURRED
 INTERR   BOOLEAN              INTERFACE TABLE ERROR
          ALIGN  3,64
 CPE      BOOLEAN              CHANNEL PARITY ERROR
          ALIGN  6,64
 DTO      BOOLEAN              DATA TIMEOUT
 UTO      BOOLEAN              UNIVERSAL COMMAND TIMEOUT
 FTO      BOOLEAN              FUNCTION TIMEOUT
 FFT      BOOLEAN              FLAG FUNCTION TIMEOUT
 PTO      BOOLEAN              PRIME FLAG TIMEOUT
 HWF      BOOLEAN              HARDWARE ERROR
 CIA      BOOLEAN              CHANNEL INACTIVE AFTER ACTIVATE
 IVR      BOOLEAN              ABNORMAL CONTROLWARE RESPONSE
 ITE      BOOLEAN              CHANNEL INPUT ERROR
 OTE      BOOLEAN              CHANNEL OUTPUT ERROR
 IEC      PPWORD             INTERFACE ERROR CODE
 RTYPE    SUBRANGE 0,3       RESPONSE TYPE
                               0 = UNSOLICITED
                               1 = INTERMEDIATE
                               2 = NORMAL
                               3 = ABNORMAL
 CC       SUBRANGE 0,3       CONDITION CLARIFIER
                               0 = NO DETAILED STATUS
                               1 = DETAILED STATUS APPENDED
                               2 = NOT CURRENTLY USED
                               3 = NOT CURRENTLY USED
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE
*ALERTC   PPWORD             ALERT CONDITIONS
 LIB      BOOLEAN              LONG INPUT BLOCK
 EOI      BOOLEAN              EOI MARK ENCOUNTERED
 EOF      BOOLEAN              EOF MARK ENCOUNTERED
 EOR      BOOLEAN              EOR MARK ENCOUNTERED
 PRU      BOOLEAN              PRU BLOCK ENCOUNTERED
 NONPRU   BOOLEAN              NON-PRU BLOCK ENCOUNTERED
 EOM      BOOLEAN              END OF MESSAGE

          ALIGN  0,64
 TC       STRUCT 4           TRANSFER COUNT (BYTES SENT/RECEIVED)
 RMALC    RMA                RMA OF LAST COMMAND

          MASKP  CPE
 M.CPE    EQU    MSK
          MASKP  DTO
 M.DTO    EQU    MSK
          MASKP  UTO
 M.UTO    EQU    MSK
          MASKP  FTO
 M.FTO    EQU    MSK
          MASKP  FFT
 M.FFT    EQU    MSK
          MASKP  PTO
 M.PTO    EQU    MSK
          MASKP  HWF
 M.HWF    EQU    MSK
          MASKP  CIA
 M.CIA    EQU    MSK
          MASKP  IVR
 M.IVR    EQU    MSK
          MASKP  ITE
 M.ITE    EQU    MSK
          MASKP  OTE
 M.OTE    EQU    MSK

 PRS      RECEND
          SPACE  4,10
**        RESPONSE DETAILED STATUS
*


 RDS      RECORD PACKED

 LCWF     PPWORD             LAST CONTROLWARE FUNCTION
 LCWS     PPWORD             LAST CONTROLWARE STATUS
 LHWF     PPWORD             LAST HARDWARE FUNCTION
 LHWS     PPWORD             LAST HARDWARE STATUS

 RDS      RECEND
          SPACE  4,10
**        INTERFACE ERROR CODES
*


 IEC.20A  EQU    0#20A       INVALID CHANNEL NUMBER
 IEC.211  EQU    0#211       UNIT DESCRIPTOR COUNT ERROR
 IEC.220  EQU    0#220       INVALID PP NUMBER
 IEC.301  EQU    0#301       LOGICAL UNIT NUMBERS IN *UD* AND *UIT* NOT EQUAL
 IEC.306  EQU    0#306       INVALID UNIT TYPE
 IEC.501  EQU    0#501       INVALID COMMAND CODE
 IEC.503  EQU    0#503       CIO HARDWARE ERROR
 IEC.505  EQU    0#505       INVALID LENGTH SPECIFICATION IN COMMAND
 IEC.50B  EQU    0#50B       INVALID PARAMETER SPECIFICATION
          SPACE  4,10
**        RESPONSE TYPES
*


 RT.UNS   EQU    0           UNSOLICITED RESPONSE
 RT.INT   EQU    1           INTERMEDIATE RESPONSE
 RT.NOR   EQU    2           NORMAL RESPONSE
 RT.ABN   EQU    3           ABNORMAL RESPONSE
          SPACE  4,10
**        CONDITION CLARIFIER
*


 CC.NDS   EQU    0           NO DETAILED STATUS
 CC.DSA   EQU    1           DETAILED STATUS APPENDED
          SPACE  4,10
**        UNSOLICITED RESPONSE CODES
*


 URC.IE   EQU    3           INTERFACE TABLE ERROR (SEE INTERFACE ERROR FIELD)
          SPACE  4,10
**        BLOCK HEADER FORMAT
*


 BH       RECORD PACKED

 LENGTH   PPWORD             LENGTH OF BLOCK IN BITS
          ALIGN  0,32
 DN       SUBRANGE 0,255     DESTINATION NODE
 SN       SUBRANGE 0,255     SOURCE NODE
 CN       SUBRANGE 0,255     CONNECTION NUMBER
 BSN      SUBRANGE 0,31      BLOCK SEQUENCE NUMBER
 BT       SUBRANGE 0,7       BLOCK TYPE
 PRU      BOOLEAN            PRU BLOCK FLAG
 EOI      BOOLEAN            EOI FLAG
 EOR      BOOLEAN            EOR FLAG
          ALIGN  0,4
 LEVEL    SUBRANGE 0,15      RECORD LEVEL
          ALIGN  0,16
 ABN      STRUCT 2           APPLICATION BLOCK NUMBER

          MASKP  BT
 M.BT     EQU    MSK
          MASKP  PRU
 M.PRU    EQU    MSK
          MASKP  EOI
 M.EOI    EQU    MSK
          MASKP  EOR
 M.EOR    EQU    MSK
 M.EOF    EQU    17B

 BH       RECEND
          SPACE  4,10
 BT.BLK   EQU    1           BLOCK TYPE *BLK*
 BT.MSG   EQU    2           BLOCK TYPE *MSG*
 BT.CMD   EQU    3           BLOCK TYPE *CMD*
          TITLE  UNIT REQUEST CODES
**        UNIT REQUEST, LOGICAL COMMAND CODES
*


 LC.FT    EQU    0#A0        FIRST UNIT REQUEST CODE
 LC.RC    EQU    0#A0        REQUEST CONNECTION
 LC.OC    EQU    0#A1        OBTAIN CONNECT REQUEST
 LC.AC    EQU    0#A2        ACCEPT CONNECT REQUEST
 LC.RJ    EQU    0#A3        REJECT CONNECT REQUEST
 LC.SD    EQU    0#A4        SEND DATA
 LC.RD    EQU    0#A5        RECEIVE DATA
 LC.SN    EQU    0#A6        STATUS NAD
 LC.SM    EQU    0#A7        SEND CONTROL MESSAGE
 LC.RM    EQU    0#A8        RECEIVE CONTROL MESSAGE
 LC.DP    EQU    0#A9        DISCONNECT PATHS
 LC.RS    EQU    0#AA        READ PATH STATUS TABLE
 LC.OS    EQU    0#AB        OBTAIN NAD GENERAL STATUS
 LC.PP    EQU    0#AC        PROCESS PHYSICAL COMMANDS
 LC.LT    EQU    0#AC        LAST UNIT REQUEST CODE
          TITLE  UNIT REQUEST PHYSICAL COMMAND CODES
**        UNIT REQUEST PHYSICAL COMMAND CODES
*


 PC.IF    EQU    0#20        ISSUE NAD FUNCTION
 PC.OB    EQU    0#23        OUTPUT BIT STRING DATA MODE
 PC.IB    EQU    0#25        INPUT BIT STRING DATA MODE
 PC.SA    EQU    0#28        SET TRANSFER LENGTH AND ADDRESS
 PC.HS    EQU    0#29        OBTAIN NAD HARDWARE STATUS
 PC.CS    EQU    0#2A        OBTAIN NAD CONTROLWARE STATUS
          TITLE  CONCURRENT CHANNEL HARDWARE REQUEST CODES
**        CONCURRENT CHANNEL HARDWARE REQUEST CODES
*


 F.MCLEAR EQU    100000B     MASTER CLEAR CIO ADAPTOR BOARD
 F.RDESR  EQU    112000B     READ ERROR STATUS REGISTER OF CIO ADAPTOR
 F.WRCR   EQU    111000B     WRITE CONTROL REGISTER OF CIO ADAPTOR
          TITLE  PP REQUEST COMMAND CODES
**        PP REQUEST COMMAND CODES
*


 PR.ID    EQU    4           IDLE PP DRIVER
 PR.RS    EQU    5           RESUME REQUEST PROCESSING
          TITLE  DIRECT CELL DEFINITIONS.
**        DIRECT CELL DEFINITIONS.
*
*         WARNING  -  THE DIRECT CELL DEFINITIONS ARE OVERLAPPED TO
*                     MINIMIZE CODE GENERATION.  ONE MUST BE CAREFUL WHEN
*                     MODIFYING CODE NOT TO CAUSE A DIRECT CELL CONFLICT.


 SCRATCH  EQU    1 - 6       DIRECT CELLS RESERVED FOR SCRATCH USAGE
 SPECSAV  EQU    7           SPECIAL SAVE AREA FOR SCRATCH PURPOSES
*                              USED TO PRESERVE SCRATCH INFO ACROSS CALLS
 CMADR    EQU    10B - 12B   USED FOR CM ADDRESS GENERATION
 CWSTAT   EQU    13B         CONTROLWARE STATUS
 WTOXFR   EQU    14B         WORDS TO TRANSFER
 BUFSIZE  EQU    15B         BUFFER SIZE
 TWO      EQU    16B         CONSTANT TWO
 BYTXFR   EQU    17B         BYTES ACTUALLY TRANSFERRED
 BYTCNT   EQU    20B         DATA TRANSFER BYTE COUNT
 PPSTATE  EQU    21B         CURRENT PP STATE
 CURCHAN  EQU    22B         CURRENT CHANNEL BEING FUNCTIONED
 CHANRES  EQU    23B         CHANNEL RESERVED FLAG
 NRTIMER  EQU    24B         NAD RESPONSE TIMER
 REQLGTH  EQU    25B         REQUEST LENGTH
 SUBFEA   EQU    26B         SUBFUNCTION ENTRIES AVAILABLE
 PPFRC    EQU    27B         PP FREE RUNNING CLODK

*         SEND/RECEIVE DATA SUBFUNCTION PROCESSING

 NUMREQ   EQU    30B         NUMBER OF SUBFUNCTIONS PROCESSED
 TEMPOUT  EQU    31B         TEMPORARY OUT POINTER
 SUBF     EQU    32B - 35B   SUBFUNCTION HEADER WORD
 SFPTR    EQU    36B - 40B   POINTER TO SUBFUNCTION BUFFER
 SFIN     EQU    41B         IN POINTER FOR SUBFUNCTION BUFFER
 SFOUT    EQU    42B         OUT POINTER FOR SUBFUNCTION BUFFER
 SFLIMIT  EQU    43B         LIMIT POINTER FOR SUBFUNCTION BUFFER (LWA+8)
 MDATF    EQU    44B         MORE DATA FLAG (WAIT FOR HOST BUFFERS)


*         PHYSICAL COMMAND PROCESSING

 NUMCMND  EQU    30B         NUMBER OF PHYSICAL COMMANDS PROCESSED
 CURCMND  EQU    31B         CURRENT PHYSICAL COMMAND BEING PROCESSED
 PCMND    EQU    32B - 35B   PHYSICAL COMMAND BUFFER
 TRADDR   EQU    36B - 41B   TRANSFER ADDRESS BUFFER

*         LOGICAL COMMAND PROCESSING

 LCMND    EQU    45B - 54B   LOGICAL COMMAND BUFFER

*         PP COMMAND PROCESSING

 PPCMND   EQU    45B - 50B   PP COMMAND BUFFER

*         UNIT INTERFACE TABLE POINTERS

 CURUIT   EQU    55B - 60B   CURRENT UNIT INTERFACE TABLE HEADER WORD
 UITADDR  EQU    61B - 63B   UNIT INTERFACE TABLE POINTER

*         PP INTERFACE TABLE POINTERS

 RBFIRST  EQU    64B - 66B   RMA OF FWA FOR PP RESPONSE BUFFER
 RBIN     EQU    67B         IN POINTER FOR PP RESPONSE BUFFER
 RBOUT    EQU    70B         OUT POINTER FOR PP RESPONSE BUFFER
 RBLIMIT  EQU    71B         LIMIT POINTER FOR PP RESPONSE BUFFER (LWA+8)
 PITADDR  EQU    72B - 74B   PP INTERFACE TABLE ADDRESS
*                            NOTE - THE INITIAL PIT ADDR IS A 2-BYTE RMA
*                                   THE INITIALIZATION PROCESS REFORMATS
*                                   THE ADDRESS TO 3 BYTES.


*         AVAILABLE DIRECT CELLS

 AVAIL    EQU    75B - 77B   CURRENTLY UNUSED DIRECT CELLS

          ERRNZ  PPCMND-LCMND          CODE ASSUMES THESE TWO ARE EQUAL
          ERRNZ  NUMREQ-NUMCMND        CODE ASSUMES THESE TWO ARE EQUAL
          TITLE  NAD INTERFACE DEFINITIONS.
**        NAD INTERFACE DEFINITIONS
*
          IF     DEF,NDI0
          SPACE  4,10
**        S0 C170 CONVERTER FUNCTION CODES.
*
*         NOTE   THE FOLLOWING FUNCTION CODES ARE THE FIRST
*                FOUR BITS OF THE FUNCTION CODE PASSED ON AN S0
*                CHANNEL.  THESE FUNCTION CODES ARE INTERPRETED
*                BY THE S0 ICI/C170 CONVERTER.


 S0C.SCM  EQU    110000B     SET CONVERSON MODE
 S0C.S12  EQU    120000B     SET 12 BIT MODE
 S0C.SEL  EQU    170000B     SELECT C170 CONVERTER


          ENDIF
          SPACE  4,10
**        DEVICE INTERFACE FUNCTION CODES.
*


          IF     DEF,NDI0
 DI.IB    EQU    0+S0C.SCM   INPUT IN BIT STRING MODE
          ELSE
 DI.IB    EQU    0           INPUT IN BIT STRING MODE
          ENDIF
 DI.I8    EQU    2           INPUT IN 8/12 MODE
          IF     DEF,NDI0
 DI.OB    EQU    10B+S0C.SCM   OUTPUT IN BIT STRING MODE
          ELSE
 DI.OB    EQU    10B         OUTPUT IN BIT STRING MODE
          ENDIF
 DI.O8    EQU    12          OUTPUT IN 12/8 MODE
          IF     DEF,NDI0
 DI.HS    EQU    200B+S0C.S12  OBTAIN HARDWARE STATUS
 DI.CS    EQU    201B+S0C.S12  OBTAIN CONTROLWARE STATUS
          ELSE
 DI.HS    EQU    200B        OBTAIN HARDWARE STATUS
 DI.CS    EQU    201B        OBTAIN CONTROLWARE STATUS
          ENDIF
 DI.CE    EQU    204B        CLEAR PARITY ERROR
 DI.MC    EQU    277B        INTERFACE MASTER CLEAR
          SPACE  4,10
**        NAD FUNCTION CODES.
*


 NF.FF    EQU    400B        NAD FUNCTION FLAG
 NF.PA    EQU    0           PURGE ALL PATHS
 NF.GS    EQU    1           GET NAD GENERAL STATUS
 NF.AB    EQU    3           ABORT CURRENT TRANSACTION
 NF.SC    EQU    4           SEND CONTROL MESSAGE
 NF.CP    EQU    5           CONNECT PATH
 NF.RY    EQU    10B         READY
 NF.AC    EQU    11B         ACCEPT CONNECT REQUEST
 NF.RJ    EQU    12B         REJECT CONNECT REQUEST
 NF.IC    EQU    14B         INQUIRE SELECTED CONTROL MESSAGE
 NF.DP    EQU    21B         DISCONNECT PATH
 NF.PP    EQU    22B         PURGE PATH
 NF.TD    EQU    23B         TRANSMIT DATA
 NF.PS    EQU    35B         READ PATH STATUS
 NF.IR    EQU    36B         INQUIRE SELECTED REJECTED CONTROL MESSAGE
 NF.CM    EQU    40B         CONNECT MAINTENANCE PATH
 NF.MI    EQU    42B         MAINTENANCE PATH INPUT
 NF.RR    EQU    46B         READ REMOTE STATUS
 NF.RT    EQU    50B         RESET CURRENT TRANSFER POINTERS
 NF.UC    EQU    53B         UNIVERSAL COMMAND
 NF.NS    EQU    54B         NAD STATUS
 NF.SP    EQU    200B        SELECT PATH
          SPACE  4,10
**        UNIVERSAL COMMAND SUBFUNCTIONS
*


 UC.WB    EQU    5           WRITE DATA IN BINARY MODE
 UC.RB    EQU    6           READ DATA IN BINARY MODE
 UC.OC    EQU    7           OBTAIN CONNECT REQUEST


*         NOTE   CURRENTLY THE NAD ONLY LOOKS (AT MOST) AT THE FIRST 3
*                PP WORDS PASSED FROM THE PP TO THE NAD.  HOWEVER, 6 PP
*                WORDS MUST BE PASSED TO THE NAD.  A THREE WORD UNIVERSAL
*                COMMAND BUFFER IS USED AND THE REMAINING FIELDS ARE GARBAGE.

 UC.CBLP  EQU    3           UNIVERSAL COMMAND BUFFER LENGTH (IN PP WORDS)
          IF     DEF,NDI0
 UC.CBLC  EQU    6           UNIVERSAL COMMAND BUFFER LENGTH (IN I0 CHANNEL WORDS)
          ELSE
 UC.CBLC  EQU    8           UNIVERSAL COMMAND BUFFER LENGTH (IN CHANNEL WORDS)
          ENDIF

 UCB.SF   EQU    0           UNIVERSAL COMMAND SUBFUNCTION FIELD
 UCB.PF   EQU    1 - 2       UNIVERSAL COMMAND PHYSICAL FROM FIELD
 UCB.NWC  EQU    1           UNIVERSAL COMMAND NAD WORD COUNT (16 BITS)
          SPACE  4,10
**        NAD RESPONSE CODES
*


 NR.RM    EQU    37B         RESPONSE MASK
 NR.AK    EQU    1           ACKNOWLEDGE
 NR.NK    EQU    2           NEGATIVE ACKNOWLEDGE
 NR.UA    EQU    5           UNIVERSAL COMMAND ACKNOWLEDGE
 NR.TN    EQU    17B         TRANSFER NOT READY
 NR.CP    EQU    21B         CONNECT IN PROGRESS
 NR.PI    EQU    177B        PATH ID MASK
          SPACE  4,10
**        NAD RESPONSE FLAGS
*


 NRF.OB   EQU    5           OUTPUT BELOW THRESHOLD
 NRF.IA   EQU    6           INPUT AVAILABLE
 NRF.SP   EQU    7           SELECTED PATH
 NRF.FF   EQU    10B         FUNCTION FLAG
 NRF.PF   EQU    11B         PRIMED FLAG
 NRF.HF   EQU    12B         HARDWARE FAULT FLAG
          SPACE  4,10
**        NAD RESPONSE CODES
*


 NHF.PS   EQU    1           NAD PROCESSOR STOPPED FLAG
 M.NHFPS  EQU    2           NAD PROCESSOR STOPPED MASK
 NHF.PA   EQU    2           NAD PROCESSOR ABNORMAL FLAG
 M.NHFPA  EQU    4           NAD PROCESSOR ABNORMAL MASK
          SPACE  4,10
**        NAD INTERFACE ERRORS
*
*         NOTE   THE NAD ERRORS CORRESPOND TO THE ACTUAL ABNORMAL STATUS
*                FLAGS PASSED IN THE PP RESPONSE.


 NE.CHD   EQU    0                CHANNEL DOWN (THIS IS NOT A RETURN STATUS)
 NE.CPE   EQU    /PRS/M.CPE       CHANNEL PARITY ERROR
 NE.HWF   EQU    /PRS/M.HWF       HARDWARE FAULT
 NE.UTO   EQU    /PRS/M.UTO       UNIVERSAL COMMAND TIMEOUT
 NE.FTO   EQU    /PRS/M.FTO       FUNCTION TIMEOUT
 NE.FFT   EQU    /PRS/M.FFT       FLAG FUNCTION TIMEOUT
 NE.PTO   EQU    /PRS/M.PTO       PRIME TIMEOUT
 NE.DTO   EQU    /PRS/M.DTO       DATA TIMEOUT
 NE.CIA   EQU    /PRS/M.CIA       CHANNEL INACTIVE AFTER ACTIVATE
 NE.IVR   EQU    /PRS/M.IVR       INVALID RESPONSE
 NE.ITE   EQU    /PRS/M.ITE       INPUT TRANSFER ERROR
 NE.OTE   EQU    /PRS/M.OTE       OUTPUT TRANSFER ERROR

          SPACE  4,10
**        PP STATES
*


 PP.IDLE  EQU    0           PP IS IN AN IDLE STATE
 PP.NORM  EQU    1           PP IS IN A NORMAL STATE
          SPACE  4,10
**        MISCELLANEOUS CONSTANTS
*


          IF     DEF,NDI0
 IDLEDEL  EQU    4000        IDLE DELAY TIME (1 MILLI-SECONDS)
 INTERDY  EQU    40000       INTERFACE ERROR DELAY TIME (10 MILLI-SECONDS)
 RESTO    EQU    800         RESOURCE RETRY TIME-OUT (100 MILLI_SECONDS)
          ELSE
 IDLEDEL  EQU    2000        IDLE DELAY TIME (1 MILLI-SECONDS)
 INTERDY  EQU    20000       INTERFACE ERROR DELAY TIME (10 MILLI-SECONDS)
 RESTO    EQU    400         RESOURCE RETRY TIME-OUT (100 MILLI_SECONDS)
          ENDIF
 CH       EQU    0           DEFAULT CHANNEL NUMBER
 FIRST    EQU    0           ALL BUFFER *FIRST* POINTERS = 0
 MAXUNIT  EQU    1           MAXIMUM UNITS SUPPORTED
 LCBLL    EQU    0           LOWER CHANNEL BARREL LOWER LIMIT
 LCBUL    EQU    13B         LOWER CHANNEL BARREL UPPER LIMIT
 UCBLL    EQU    20B         UPPER CHANNEL BARREL LOWER LIMIT
 UCBUL    EQU    33B         UPPER CHANNEL BARREL UPPER LIMIT
 NADTYPE  EQU    0#203       NAD HARDWARE TYPE
 TRUE     EQU    1           CONSTANT TRUE
 FALSE    EQU    0           CONSTANT FALSE
 MINRBE   EQU    20*8        MINIMUM REQUEST BUFFER ENTRIES
 MSF      EQU    60          MAXIMUM SUBFUNCTIONS PROCESSED
 MAXBYTES EQU    4128        MAXIMUM BYTES PER TRANSFER
          IF     DEF,NDI0
 MTRDEL   EQU    120         MONITOR RESPONSE DELAY TIME (30 MICRO-SECONDS)
 CHANDEL  EQU    120         CHANNEL DELAY TIME (30 MICRO-SECONDS)
          ELSE
 MTRDEL   EQU    60          MONITOR RESPONSE DELAY TIME (30 MICRO-SECONDS)
 CHANDEL  EQU    60          CHANNEL DELAY TIME (30 MICRO-SECONDS)
          ENDIF
 TRLENCH  EQU    4           XFR LENGTH AND ADDRESS SIZE (IN CHANNEL WORDS)
 TRLENC   EQU    1           XFR LENGTH AND ADDRESS SIZE (IN CM WORDS)
 TRLENB   EQU    8           XFR LENGTH AND ADDRESS SIZE (IN 8-BIT BYTES)
 .INPN    EQU    102600B
 .IAN     EQU    7000B
 .PSN     EQU    2400B
 .SBN     EQU    1700B
 .STM     EQU    5400B
 .STML    EQU    105400B

          TITLE  BUFFER AREAS
**        BUFFER AREAS
*


          ORG    100B

 INTREG   BSSZ   2                     INTERRUPT REGISTER
 UNCB     BSSZ   UC.CBLP               UNIVERSAL COMMAND BUFFER
 URQIL    BSSZ   2                     UNIT REQUEST Q INTERLOCK PTR
 PPRQIL   BSSZ   2                     PP REQUEST QUEUE INTERLOCK POINTER
 CITADDR  BSSZ   2                     CHANNEL INTERLOCK TABLE ADDRESS
 RESBUF   BSSZ   P.PRS                 RESPONSE BUFFER
 RESDS    BSSZ   P.RDS                 RESPONSE DETAILED STATUS
          ERRNZ  RESBUF+P.PRS-RESDS    THESE BUFFERS MUST BE CONTIGUOUS
MCM       TITLE  MAIN CONTROL MODULE
**        MCM    MAIN CONTROL MODULE
*
*         THE PURPOSE OF THIS ROUTINE IS TO PROVIDE THE HIGH LEVEL
*         CONTROL FOR THE PP DRIVER.
*
*         INITIALIZE PP DRIVER.
*         WHILE   TRUE  DO
*           PERFORM PP REQUESTS.
*           IF  PP IS IN AN IDLE STATE   THEN
*             DELAY FOR A WHILE.
*           ELSE
*             PERFORM UNIT REQUESTS.
*             IF   NO REQUESTS WERE PROCESSED IN LAST CYCLE    THEN
*               DELAY FOR A WHILE.
*             IFEND
*           IFEND
*         WHILEND


 MCM      BSS    0           PROGRAM ENTRY POINT
          RJM    IPD         INITIALIZE PP DRIVER
 MCM1     RJM    PPQ         PROCESS PP REQUEST QUEUE
          LDDL   PPSTATE
          LMK    PP.IDLE
          ZJN    MCM2        IF PP IS IN AN IDLE STATE
          RJM    PUQ         PROCESS UNIT REQUEST QUEUE
          LDDL   PPFRC
          NJN    MCM1        IF REQUESTS WERE PROCESSED IN LAST CYCLE

 MCM2     LDK    IDLEDEL
 MCM3     SBN    1
 MCMA     EQU    *-1         *SBN 2* IS USED IF 2XPP
          NJN    MCM3        IF DELAY NOT COMPLETE
          UJN    MCM1
PPQ       TITLE  PPQ - PROCESS PP REQUEST QUEUE.
**        PPQ    PROCESS PP REQUEST QUEUE
*
*         THE PURPOSE OF THIS ROUTINE IS TO FIND AND INTERLOCK PP REQUESTS.
*
*         ENTRY  (PITADDR - PITADDR+2) = RMA OF PP INTERFACE TABLE.
*
*         EXIT   (PPSTATE) = CURRENT PP STATE.
*
*         WHILE   PP REQUEST QUEUE IS NOT EMPTY  DO
*           ACQUIRE PP REQUEST QUEUE INTERLOCK.
*           IF  PP REQUEST QUEUE INTERLOCK OBTAINED  THEN
*             IF  PP REQUEST AVAILABLE  THEN
*               REMOVE ENTRY FROM PP QUEUE.
*               RELEASE PP REQUEST QUEUE INTERLOCK.
*               INITIALIZE RESPONE BUFFER.
*               PROCESS PP REQUEST.
*               SEND RESPONSE AND ACQUIRE PP REQUEST QUEUE INTERLOCK.
*             IFEND
*             GET NEXT REQUEST POINTER.
*           IFEND
*         WHILEND
*         RELEASE PP REQUEST QUEUE INTERLOCK.


 PPQ      SUBR               ENTRY/EXIT
          IF     DEF,NDI0
          LDN    1           930 PP DRIVERS SHOULD NOT DO CRD*S IN THE IDLE LOOP
          STDL   SCRATCH+4
          ENDIF
          LCN    0
          STDL   SCRATCH
          STDL   SCRATCH+1
          STDL   SCRATCH+2
          LDK    0#7FFF
          STDL   SCRATCH+3
          LOADCB PITADDR,,/PIT/C.AFLAG
          RDCL   SCRATCH     CLEAR PP ACTIVE FLAG
          ADK    /PIT/C.RMANPR-/PIT/C.AFLAG
          IF     DEF,NDI0
          CRML   SCRATCH,SCRATCH+4  930 PP DRIVERS SHOULD NOT DO CRD*S IN THE IDLE LOOP
          ELSE
          CRDL   SCRATCH     READ PP REQUEST QUEUE POINTER
          ENDIF
          LDDL   SCRATCH+2
          ADDL   SCRATCH+3
          ZJN    PPQX        IF NO PP REQUEST TO PROCESS
 PPQ1     LDK    PPRQIL
          RJM    ATI         ACQUIRE PP REQUEST QUEUE INTERLOCK
          NJN    PPQ1        IF INTERLOCK BUSY
 PPQ2     LOADCB PITADDR,,/PIT/C.PVANPR
          CRML   RESBUF+/PRS/P.PVAOR/4*4,TWO     PP REQUEST QUEUE POINTER
          LDML   RESBUF+/PRS/P.RMAOR
          ADML   RESBUF+/PRS/P.RMAOR+1
          NJN    PPQ3        IF PP REQUEST TO PROCESS
          LDK    PPRQIL
          RJM    RTI         RELEASE PP REQUEST QUEUE INTERLOCK
          UJK    PPQX

 PPQ3     LDN    1
          STDL   SCRATCH+1
          LOADCM RESBUF+/PRS/P.RMAOR
          CRML   BUFFER,TWO                      READ NEXT REQUEST PTRS
          CRML   RESBUF+/PRS/P.RL,SCRATCH+1      READ REQUEST OPTIONS
          ADK    C.PR-/PR/C.SECADD
          CRDL   PPCMND      READ PP REQUEST
          LOADCB PITADDR,,/PIT/C.PVANPR
          CWML   BUFFER,TWO                   REMOVE REQUEST FROM QUEUE
          LDK    PPRQIL
          RJM    RTI         RELEASE PP REQUEST QUEUE INTERLOCK
          RJM    IRB         INITIALIZE RESPONSE BUFFER
          RJM    PPR         PROCESS PP REQUEST
          LDK    PPRQIL
          RJM    SRP         SEND RESPONSE AND ACQUIRE PP REQUEST Q I/L
          UJK    PPQ2        PROCESS NEXT REQUEST
PPR       SPACE  4,25
**        PPR    PROCESS PP REQUEST
*
*         THIS ROUTINE PROCESS THE PP REQUESTS.
*
*         ENTRY  PP REQUEST LOCKED.
*                (PPCMND) = PP REQUEST TO PROCESS.
*
*         EXIT   (A) : STATUS
*                    => 0, COMPLETE.
*                    < 0, ERROR; DETAILED STATUS SET UP.
*
*
*         CASE  TYPE OF PP REQUEST  OF
*           = IDLE =
*             SET PP STATE TO IDLE.
*           = RESUME =
*             SET PP STATE TO NORMAL.
*         ELSE
*           SET UP ERROR RESPONSE.
*         CASEND


 PPR      SUBR               ENTRY/EXIT
          LDDL   PPCMND+/CF/P.PPCMND
          SHN    -16+/CF/L.PPCMND+/CF/N.PPCMND
          LMK    PR.ID
          NJN    PPR1        IF NOT AN IDLE REQUEST
          LDK    PP.IDLE
          STDL   PPSTATE
          UJK    PPRX        RETURN, PP IS IN AN IDLE STATE

 PPR1     LMK    PR.RS&PR.ID
          NJN    PPR2        IF NOT RESUME REQUEST
          LDK    PP.NORM
          STDL   PPSTATE
          UJN    PPRX        RETURN, PP IS IN A NORMAL STATE

 PPR2     LDK    IEC.501
          RJM    FIE         FORMAT INTERFACE ERROR
*         LCN    0           (A) < 0, INTERFACE ERROR
          UJN    PPRX        RETURN, INVALID COMMAND
PUQ       TITLE  PUQ - PROCESS UNIT REQUEST QUEUE.
**        PUQ    PROCESS UNIT REQUEST QUEUE.
*
*         THIS ROUTINE PERFORMS A CIRCULAR CHECK ON THE LOGICAL UNITS
*         THAT ARE DEFINED IN THE PP INTERFACE TABLE TO FIND A REQUEST
*         TO PROCESS.
*
*         ENTRY  (UNITTAB) = UNIT INTERFACE TABLE POINTERS AND CHANNELS.
*                (UTABL) = SIZE OF THE *UNITTAB*.
*
*
*         IF   REQUEST IS IN QUEUE   OR
*              THE PP COUNTER MUST BE UPDATED   THEN
*           ACQUIRE UNIT REQUEST QUEUE INTERLOCK.
*           WHILE  NOT END OF REQUEST CHAIN    DO
*             IF  REQUEST IS AVAILABLE   THEN
*               SET PROCESSING BIT.
*               RELEASE REQUEST QUEUE INTERLOCK.
*               PROCESS REQUEST.
*               SEND RESPONSE AND ACQUIRE UNIT REQUEST QUEUE INTERLOCK.
*               CLEAR PP PROCESSING FLAG. (PROCESSING COMPLETE MAY BE SET)
*             IFEND
*             GET NEXT REQUEST POINTER.
*           WHILEND
*           RELEASE REQUEST QUEUE INTERLOCK.
*         IFEND


 PUQ      SUBR               ENTRY/EXIT
          LDDL   PPFRC
          NJN    PUQ1        IF PP CLOCK COUNTER MUST BE UPDATED
          LOADCB UITADDR,,/UIT/C.RMANR
          CRDL   SCRATCH     READ NEXT REQUEST POINTER
          LDDL   SCRATCH+2
          ADDL   SCRATCH+3
          ZJN    PUQX        IF NO REQUEST TO PROCESS
 PUQ1     LDK    URQIL
          RJM    ATI         ACQUIRE UNIT QUEUE INTERLOCK
          NJN    PUQ1        IF INTERLOCK IS BUSY
          RJM    CFA         CHECK FOR AVAILABLE REQUEST
          NJN    PUQ4        IF REQUEST AVAILABLE
 PUQ2     LDK    URQIL
          RJM    RTI         RELEASE UNIT QUEUE INTERLOCK
 PUQ3     UJK    PUQX

 PUQ4     BSS    0
 PUQ5     LDN    1
          STDL   SCRATCH+1
          LOADCM RESBUF+/PRS/P.RMAOR,,/PR/C.RL
          CRML   RESBUF+/PRS/P.RL,SCRATCH+1      READ REQUEST HEADER
          ADK    C.PR-/PR/C.SECADD
          STDL   SCRATCH
          CRML   LCMND,TWO   READ LOGICAL COMMAND
          LDDL   LCMND+/LCF/P.PPLOCK
          SHN    17-15+/LCF/L.PPLOCK
          MJN    PUQ6        IF REQUEST IS BEING PROCESSED
          SHN    17-15+/LCF/L.PPCOMP-17+15-/LCF/L.PPLOCK
          PJN    PUQ7        IF REQUEST IS AVAILABLE
 PUQ6     LOADCM RESBUF+/PRS/P.RMAOR,,/PR/C.PVANPR
          CRML   RESBUF+/PRS/P.PVAOR/4*4,TWO     READ NEXT REQUEST POINTER
          LDML   RESBUF+/PRS/P.RMAOR
          ADML   RESBUF+/PRS/P.RMAOR+1
          NJN    PUQ5        IF NEXT REQUEST POSTED
          UJK    PUQ2        CHECK NEXT UNIT FOR REQUESTS

 PUQ7     LDDL   LCMND+/LCF/P.PPLOCK
          LMK    /LCF/M.PPLOCK
          STDL   LCMND+/LCF/P.PPLOCK
          LDDL   SCRATCH
          ADK    400000B
          CWDL   LCMND+/LCF/P.PPCOMP/4*4        SET PP REQUEST LOCK
          LDK    URQIL
          RJM    RTI         RELEASE UNIT REQUEST QUEUE INTERLOCK
          RJM    IRB         INITIALIZE RESPONSE BUFFER
          RJM    PUR         PROCESS UNIT REQUEST
          LDK    URQIL
          RJM    SRP         SEND RESPONSE AND ACQUIRE UNIT REQUEST Q I/L
          UJK    PUQ6        CHECK FOR NEXT REQUEST IN QUEUE
CFA       SPACE  4,25
**        CFA    CHECK FOR AVAILABLE REQUEST
*
*         THE PURPOSE OF THIS ROUTINE IS TO CHECK THE CURRENT UNIT
*         INTERFACE TABLE FOR AN AVAILABLE REQUEST.
*
*         ENTRY  (UTABI) = INDEX OF CURRENT UNIT BEING PROCESSED.
*
*         EXIT   (A) : STATUS
*                    <> 0, NEXT REQUEST AVAILABLE.
*                    = 0, NO REQUEST AVAILABLE OR UNIT DISABLED.
*
*         READ IN UNIT INTERFACE TABLE.
*         UPDATE THE PP CLOCK.
*         IF  UNIT DISABLED
*             OR REQUEST QUEUE EMPTY  THEN
*           RETURN NO REQUEST AVAILABLE.
*         ELSE
*           RETURN REQUEST AVAILABLE STATUS.
*         IFEND


 CFA      SUBR               ENTRY/EXIT
          LOADCB UITADDR,,/UIT/C.DIS
          CRDL   CURUIT      READ UNIT INTERFACE TABLE HEADER WORD
          STDL   SCRATCH
          ADK    /UIT/C.PVANR-/UIT/C.DIS
          CRML   RESBUF,TWO  READ PVA AND RMA OF REQUEST INTO RESPONSE BUFFER
          LDDL   PPFRC
          RADL   CURUIT+/UIT/P.RQCLK   UPDATE FREE RUNNING CLOCK
          SHN    -16
          RADL   CURUIT+/UIT/P.RQCLK   USE 1*S COMPLEMENT TO AVOID ZERO
          LDDL   SCRATCH
          ADK    400000B
          CWDL   CURUIT      REWRITE THE FREE RUNNING CLOCK FOR DUAL_PP
          LDN    0
          STDL   PPFRC
          LDDL   CURUIT+/UIT/P.DIS
          SHN    17-15+/UIT/L.DIS
          MJN    CFA1        IF UNIT IS DISABLED
          LDML   RESBUF+/PRS/P.RMAOR
          ADML   RESBUF+/PRS/P.RMAOR+1
          NJN    CFAX        IF REQUEST TO PROCESS
 CFA1     LDN    0
          UJK    CFAX        RETURN, NO REQUEST TO PROCESS
PUR       SPACE  4,35
**        PUR    PROCESS UNIT REQUEST
*
*         THE PURPOSE OF THIS ROUTINE IS TO CONTROL THE PROCESSING FOR
*         A UNIT REQUEST.
*
*         ENTRY  UNIT REQUEST INTERLOCKED.
*                (LCMND) = UNIT REQUEST.
*
*         EXIT   (LCMND+/LCF/P.PPCOMP) = SET UP.
*                (RESBUF) = SET UP.
*
*
*         VALIDATE LOGICAL FUNCTION.
*         IF  THE FUNCTION IS NOT VALID   THEN
*           SET UP ERROR RESPONSE.
*           EXIT THE ROUTINE.
*         ELSE
*           CALL FUNCTION PROCESSOR.
*           RELEASE CHANNEL INTERLOCK.
*           IF  REQUEST COMPLETE
*               OR  ERROR ENCOUNTERED  THEN
*             SET LOGICAL COMMAND INTERLOCK WORD TO COMPLETE CURRENT REQUEST.
*           ELSE
*             SET RESPONSE LENGTH TO ZERO (NO RESPONSE).
*             SET LOGICAL COMMAND INTERLOCK WORD TO RELEASE REQUEST FROM PP.
*           IFEND
*         IFEND


 PUR      SUBR               ENTRY/EXIT
          LDDL   LCMND+/LCF/P.LCMND
          SHN    -16+/LCF/L.LCMND+/LCF/N.LCMND
          SBK    LC.FT
          STDL   SCRATCH     SAVE COMMAND NUMBER INDEX
          MJN    PUR1        IF INVALID COMMAND
          SBK    LC.LT+1-LC.FT
          MJN    PUR2        IF THE COMAND IS VALID
 PUR1     LDK    IEC.501
          RJM    FIE         FORMAT INTERFACE ERROR
          UJN    PUR3        INVALID COMMAND

 PUR2     LDML   CMNDTAB,SCRATCH
          STD    SCRATCH     SAVE ENTRY POINT
          SHN    -14
          STML   PEPA        SAVE ERROR PROCESSING FLAGS
          RJM    0,SCRATCH   PROCESS THE LOGICAL COMMAND
          ZJN    PUR3        IF NORMAL RESPONSE
          PJN    PUR6        IF REQUEST NOT COMPLETE
 PUR3     LDDL   LCMND+/LCF/P.PPCOMP
          LMK    /LCF/M.PPCOMP&/LCF/M.PPLOCK     CLEAR LOCK AND SET COMPLETE
 PUR4     STDL   LCMND+/LCF/P.PPCOMP
          RJM    REL         MAKE SURE THE CHANNEL IS RELEASED
          LDDL   NUMREQ
          SHN    3
          NJN    PUR5        IF DATA BLOCKS TRANSFERRED
          LDN    1
 PUR5     RADL   PPFRC       UPDATE THE FREE RUNNING CLOCK
          UJK    PURX        RETURN

 PUR6     LDN    0
          STML   RESBUF+/PRS/P.RL      SET RESPONSE LENGTH TO ZERO, NO RESP.
          LDDL   LCMND+/LCF/P.PPCOMP
          LMK    /LCF/M.PPLOCK                   CLEAR LOCK
          UJN    PUR4

*         NOTE   THIS TABLE CORRESPONDS TO THE LOGICAL COMMAND CODES
*                DEFINED IN THE DEFINITIONS SECTION.
*
*
*         THE TABLE HAS THE FOLLOWING FORMAT:
*
*         FIELD 1: ISSUE *RESET* ON FAILURE.
*         FIELD 2: ISSUE *ABORT* ON FAILURE. (1 AND 2 ARE MUTUALLY EXCLUSIVE)
*         FIELD 3: UNUSED.
*         FIELD 4: LOGICAL COMMAND PROCESSOR ENTRY POINT.



 CMNDTAB  BSS    0           COMMAND TABLE
          LOC    0
          VFD    1/0,1/1,2/0,12/RQC    REQUEST CONNECTION
          VFD    1/0,1/1,2/0,12/OCR    OBTAIN CONNECT REQUEST
          VFD    1/0,1/0,2/0,12/ACR    ACCEPT CONNECT REQUEST
          VFD    1/0,1/1,2/0,12/RCR    REJECT CONNECT REQUEST
          VFD    1/0,1/1,2/0,12/SDN    SEND DATA TO THE NAD
          VFD    1/1,1/0,2/0,12/RDN    RECEIVE DATA FROM THE NAD
          VFD    1/0,1/1,2/0,12/ONS    OBTAIN NAD STATUS
          VFD    1/0,1/1,2/0,12/SCM    SEND CONTROL MESSAGE
          VFD    1/0,1/1,2/0,12/RCM    RECEIVE CONTROL MESSAGE
          VFD    1/0,1/0,2/0,12/TCN    TERMINATE CONNECTION
          VFD    1/0,1/1,2/0,12/RPS    READ PATH STATUS
          VFD    1/0,1/1,2/0,12/OGS    OBTAIN NAD GENERAL STATUS
          VFD    1/0,1/0,2/0,12/PPC    PERFORM PHYSICAL COMMANDS
          LOC    *O
LCM       TITLE  LCM - LOGICAL COMMANDS.
**        LCM    LOGICAL COMMANDS
*
RQC       SPACE  4,35
**        RQC    REQEUST CONNECTION
*
*         THE PURPOSE OF THIS ROUTINE IS TO SEND A CONNECT REQUEST TO
*         THE NAD.
*
*         ENTRY  UNIT REQUEST INTERLOCKED.
*                (LCMND) = LOGICAL COMMAND.
*
*         EXIT   (A) : STATUS
*                    = O, COMPLETE; CONNECT REQUEST ACCEPTED BY NAD.
*                         PATH ID IS WRITTEN TO REQUEST BUFFER.
*                    > 0, OK; NO ERROR ENCOUNTERED, BUT REQUEST NOT COMPLETE.
*                    < 0, NAD ERROR; DETAILED STATUS SET UP.
*
*
*         READ CONNECT REQUEST FROM CENTRAL MEMORY.
*         ISSUE REQUEST CONNECTION FUNCTION.
*         IF  ERROR ENCOUNTERED   THEN
*           CALL THE NAD ERROR PROCESSOR.
*         ELSE
*           SEND CONNECT REQUEST TO NAD.
*           IF  ERROR ENCOUNTERED  THEN
*             CALL THE NAD ERROR PROCESSOR.
*           ELSE
*             ISSUE READY FUNCTION.
*             IF  ERROR ENCOUNTERED  THEN
*               CALL THE NAD ERROR PROCESSOR.
*             ELSE
*               RETURN CONNECTION NUMBER.
*             IFEND
*           IFEND
*         IFEND


 RQC      SUBR               ENTRY/EXIT
          LDDL   LCMND+/RC/P.LENGTH
          RJM    CVT         CONVERT BYTE COUNT INTO CM WORD AND CHANNEL WORD
          MJN    RQCX        IF LENGTH ERROR
          LOADCM LCMND+/RC/P.BUFFER
          CRML   BUFFER,BUFSIZE        READ IN CONNECT REQUEST
          IF     DEF,MCON
          LDDL   LCMND+/RC/P.CTYPE
          SHN    17-15+/RC/L.CTYPE
          MJN    RQC1        IF MAINTENANCE CONNECT
          ENDIF
          LDK    NF.CP
          IF     DEF,MCON
          UJN    RQC2        ISSUE CONNECT PATH FUNCTION

 RQC1     LDK    NF.CM       ISSUE CONNECT MAINTENANCE PATH FUNCTION
          ENDIF
 RQC2     RJM    ICF         ISSUE THE REQUESTED CONNECT PATH FUNCTION
          ZJN    RQC6        IF FUNCTION ACCEPTED
          MJN    RQC4        IF NAD ERROR
 RQC3     LCN    NE.IVR      INVALID NAD RESPONSE
 RQC4     RJM    PEP         PERFORM ERROR PROCESSING
 RQC5     UJN    RQCX

 RQC6     RJM    OOC         OUTPUT CONNECT MESSAGE
          MJN    RQC4        IF ERROR IN DATA TRANSMISSION
          LDK    NF.RY
          RJM    ICF         ISSUE READY FUNCTION
          MJN    RQC4        IF FUNCTION ERROR
          LDDL   CWSTAT
          SHN    17-NRF.SP
          PJN    RQC3        IF CONNECT REQUEST NOT ACCEPTED
          LDDL   CWSTAT
          LPK    NR.PI
          STDL   LCMND+/RC/P.PATHID
          LDN    0
          UJK    RQC5        RETURN, (A) = 0, CONNECTION ACCEPTED BY NAD
OCR       SPACE  4,35
**        OCR    OBTAIN CONNECT REQEUST
*
*         THE PURPOSE OF THIS REQUEST IS TO OBTAIN AN INCOMING CONNECT
*         REQUEST FOR THE SPECIFIED CONNECTION.
*
*         ENTRY  UNIT REQUEST INTERLOCKED.
*                (LCMND) = LOGICAL COMMAND.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; INCOMING CONNECT REQUEST PLACED IN BUFFER.
*                    > 0, OK; NO ERROR, BUT REQUEST NOT COMPLETE.
*                    < 0, ERROR; DETAILED STATUS SET UP.
*
*
*         GENERATE UNIVERSAL COMMAND FUNCTION BLOCK.
*         ISSUE UNIVERSAL COMMAND SEQUENCE.
*         IF  NO ERROR ENCOUNTERED   THEN
*           IF  STATUS NOT NORMAL  THEN
*             SET ERROR TO INVALID STATUS.
*             CALL NAD ERROR PROCESSOR.
*           ELSE
*             INPUT BLOCK FROM THE CHANNEL.
*             IF  ERROR ENCOUNTERED  THEN
*               CALL NAD ERROR PROCESSOR.
*             ELSE
*               WRITE MESSAGE TO BUFFER.
*             IFEND
*           IFEND
*         IFEND


 OCR      SUBR               ENTRY/EXIT
          LDDL   LCMND+/OC/P.LENGTH
          RJM    CVT         CONVERT BYTE COUNT INTO CM WORD AND CHANNEL WORD
          MJN    OCRX        IF LENGTH ERROR
          LDK    UC.OC                 OBTAIN INCOMIN CONNECT REQUEST
          SHN    8
          ADDL   LCMND+/OC/P.PATHID    ASSIGNED TO THIS PATHID
          STML   UNCB+UCB.SF
          LDDL   LCMND+/OC/P.PHYFRM    MUST BE DESTINED FOR THIS ACCESS METHOD
          STML   UNCB+UCB.PF
          LDDL   LCMND+/OC/P.PHYFRM+1
          STML   UNCB+UCB.PF+1
          RJM    IUC         ISSUE UNIVERSAL COMMAND
          MJN    OCR1        IF NAD ERROR
          ZJN    OCR3        IF FUNCTION ACCEPTED
 OCR0     LCN    NE.IVR      INVALID NAD RESPONSE
 OCR1     RJM    PEP         PERFORM NAD ERROR PROCESSING
 OCR2     UJN    OCRX

 OCR3     LDDL   LCMND+/OC/P.LENGTH
          RJM    CVT

*         ONE CANNOT EXIT A NAD TRANSACTION AT THIS POINT.
*         THE CONNECT REQUEST LENGTH IS VALIDATED BY
*         CALLING *CVT* AT THE BEGINNING OF THIS ROUTINE.
*         THEREFORE, *CVT* SHOULD ALWAYS RETURN A NORMAL STATUS HERE.

          RJM    IFC         INPUT DATA FROM CHANNEL
          MJN    OCR1        IF DATA TRANSFER ERROR
          LDK    NF.RY
          RJM    ICF         ISSUE READY FUNCTION
          MJN    OCR1        IF FUNCTION TIME-OUT ERROR
          NJN    OCR0        IF INVALID NAD RESPONSE
          LOADCM LCMND+/OC/P.BUFFER
          CWML   BUFFER,BUFSIZE        WRITE CONNECT REQUEST TO CM BUFFER
          LDN    0
          UJK    OCR2        RETURN, (A) = 0, CONNECT REQUEST RECEIVED
ACR       SPACE  4,30
**        ACR    ACCEPT CONNECT REQUEST
*
*         THE PURPOSE OF THIS REQUEST IS TO ACCEPT AN INCOMING CONNECT
*         REQUEST FOR THE SPECIFIED CONNECTION.
*
*         ENTRY  UNIT REQUEST INTERLOCKED.
*                (LCMND) = LOGICAL COMMAND.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; CONNECTION HAS BEEN ESTABLISHED.
*                    > 0, OK; NO ERROR, BUT REQUEST NOT COMPLETE.
*                    < 0, NAD ERROR; DETAILED STATUS SET UP.
*
*
*         ISSUE SELECT PATH CONTROLWARE FUNCTION.
*         IF  ERROR ENCOUNTERED  THEN
*           CALL NAD ERROR PROCESSOR.
*         ELSE
*           ISSUE ACCEPT CONNECT REQUEST FUNCTION.
*           IF  ERROR ENCOUNTERED  THEN
*             CALL NAD ERROR PROCESSOR.
*           IFEND
*         IFEND


 ACR      SUBR               ENTRY/EXIT
          LDDL   LCMND+/AC/P.PATHID
          LMK    NF.SP
          RJM    ICF         ISSUE SELECT PATH FUNCTION
          MJN    ACR2        IF NAD ERROR
          LMK    NR.CP&NR.AK
          ZJN    ACR3        IF STATUS IS CONNECT IN PROGRESS
 ACR1     LCN    NE.IVR
 ACR2     RJM    PEP         PERFORM ERROR PROCESSING
          UJN    ACRX

 ACR3     LDK    NF.AC
          RJM    ICF         ACCEPT CONNECT REQUEST
          ZJN    ACRX        RETURN, (A) = 0, CONNECT REQUEST ACCEPTED
          MJN    ACR2        IF NAD ERROR ENCOUNTERED
          UJN    ACR1        PROCESS ABNORMAL RESPONSE
RCR       SPACE  4,40
**        RCR    REJECT CONNECT REQEUST
*
*         THE PURPOSE OF THIS REQUEST IS TO REJECT AN INCOMING CONNECT
*         REQUEST FOR THE SPECIFIED CONNECTION.
*
*         ENTRY  UNIT REQUEST INTERLOCKED.
*                (LCMND) = FWA OF LOGICAL COMMAND.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; CONNECTION HAS BEEN REJECTED.
*                    > 0, OK; NO ERROR, BUT REQUEST NOT COMPLETE.
*                    < 0, NAD ERROR, DETAILED STATUS SET UP.
*
*
*         ISSUE SELECT PATH CONTROLWARE FUNCTION.
*         IF  ERROR ENCOUNTERED  THEN
*           CALL NAD ERROR PROCESSOR.
*         ELSE
*           ISSUE REJECT FUNCTION.
*           IF  ERROR ENCOUNTERED  THEN
*             CALL NAD ERROR PROCESSOR.
*           ELSE
*             SEND REJECT REASON CODE.
*             IF  ERROR ENCOUNTERED  THEN
*               CALL NAD ERROR PROCESSOR.
*             ELSE
*               ISSUE READY FUNCTION.
*               IF  ERROR ENCOUNTERED   THEN
*                 CALL NAD ERROR PROCESSOR.
*               IFEND
*             IFEND
*           IFEND
*         IFEND


 RCR      SUBR               ENTRY/EXIT
          LDDL   LCMND+/RJ/P.PATHID
          LMK    NF.SP
          RJM    ICF         ISSUE SELECT PATH FUNCTION
          MJN    RCR2        IF ERROR ENCOUNTERED
          LMK    NR.CP&NR.AK
          NJN    RCR1        IF NOT IN CONNECT IN PROGRESS STATE
          LDK    NF.RJ
          RJM    ICF         ISSUE REJECT CONNECTION FUNCTION
          ZJN    RCR4        IF ACK RESPONSE
          MJN    RCR2        IF ERROR ENCOUNTERED
 RCR1     LCN    NE.IVR      INVALID NAD RESPONSE
 RCR2     RJM    PEP         PERFORM NAD ERROR PROCESSING
 RCR3     UJK    RCRX        RETURN, NAD ERROR ENCOUNTERED

 RCR4     LDN    /RJ/B.RCODE
          ERRZR  /RJ/B.RCODE           LENGTH CANNOT BE ZERO
          RJM    CVT         CONVERT BYTE LENGTH

*         ONE CANNOT EXIT A NAD TRANSACTION AT THIS POINT.
*         THE REJECT CODE LENGTH IS VALIDATED BY
*         USE OF AN *LDN* INSTRUCTION AND THE *ERRZR* TEST.
*         THEREFORE, *CVT* SHOULD ALWAYS RETURN A NORMAL STATUS HERE.

          LDK    LCMND+/RJ/P.RCODE
          STML   OOCA        SET FWA OF BUFFER
          RJM    OOC         SEND CONNECT REJECT MESSAGE TO THE NAD
          MJN    RCR2        IF NAD RESPONSE ERROR
          LDK    NF.RY
          RJM    ICF         ISSUE READY FUNCTION
          ZJN    RCR3        RETURN, (A) = 0, CONNECT REQUEST REJECTED
          MJN    RCR2        IF NAD ERROR
          UJN    RCR1        PROCESS ABNORMAL RESPONSE
SDN       SPACE  4,30
**        SDN    SEND DATA TO NAD
*
*         THE PURPOSE OF THIS ROUTINE IS TO CONTROL THE SENDING OF DATA
*         BLOCKS TO THE NAD.
*
*         ENTRY  UNIT REQUEST INTERLOCKED.
*                (LCMND) = LOGICAL COMMAND.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; ALL REQUESTED DATA HAS BEEN SENT.
*                    > 0, OK; NO ERROR, BUT RESOURCES NOT AVAILABLE.
*                    < 0, ERROR; DETAILED STATUS SET UP.
*
*
*         VERIFY AND INITIALIZE SUBFUNCTION POINTERS.
*         REPEAT
*           GET SUBFUNCTION HEADER.
*           READ BLOCK FROM CENTRAL MEMORY.
*           IF  NO ERRORS IN SUBFUNCTION  THEN
*             SEND BLOCK TO THE NAD.
*             IF  BLOCK SUCCESSFULLY SENT  THEN
*               UPDATE SUBFUNCTION POINTERS.
*             IFEND
*           IFEND
*         UNTIL   BUFFERS EXHAUSTED
*              OR ERROR ENCOUNTERED


 SDN0     RJM    CRT         CHECK RETRY TIMER

*         (A) > 0, IF WE ARE TO DELAY FOR DISK I/O SYNCHRONIZATION.

 SDN      SUBR               ENTRY/EXIT
          RJM    VSP         VERIFY AND INITIALIZE SUBFUNCTION POINTERS
          MJN    SDNX        IF ERROR IN INITIALIZATION
 SDN1     BSS    0
          ZJN    SDN0        IF BUFFER IS EMPTY
          LOADCB SFPTR,SFOUT
          CRDL   SUBF        READ SUBFUNCTION HEADER WORD
          LDDL   SUBFEA
          SBDL   SUBF+/SDSF/P.SFL
          MJN    SDN0        IF NO MORE ROOM IN BUFFER
          LDDL   SUBF+/SDSF/P.SFL
          SHN    -3
          SBN    C.SDSF      COMPUTE SUBFUNCTION LENGTH - HEADER
          RJM    RDC         READ DATA FROM CENTRAL MEMORY
          MJN    SDNX        IF ERROR IN CENTRAL MEMORY READ
          RJM    SBN         SEND DATA BLOCK TO THE NAD
          NJN    SDNX        IF ERROR IN DATA TRANSMISSION
*         LDN    0
          STDL   LCMND+/SD/P.RESRTY      RESET RETRY COUNTER
          RJM    USP         UPDATE SUBFUNCTION POINTERS
          PJN    SDN1        IF ROOM IN THE BUFFER
          UJK    SDNX        IF SUBFUNCTION ERROR
RDC       SPACE  4,25
**        RDC    READ DATA FROM CENTRAL MEMORY
*
*         THE PURPOSE OF THE FOLLOWING ROUTINE IS TO PASS DATA INTO THE PP
*         BUFFER FROM THE SPECIFIED CENTRAL MEMORY BUFFERS.
*
*         ENTRY  (SFOUT) = BYTE OFFSET OF SUBFUNCTION WITHIN THE BUFFER.
*                (SFPTR) = 3-WORD RMA POINTER TO BEGINNING OF *SF* BUFFER.
*                (A) = NUMBER OF BUFFER/LENGTH ENTRIES.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; ALL DATA READ INTO PP BUFFER.
*                         (TEMPOUT) = BYTE OFFSET OF NEXT SUBFUNCTION.
*                         (BYTCNT) = NUMBER OF BYTES IN BUFFER.
*                    < 0, ERROR; LENGTH ERROR, DETAILED RESPONSE SET UP.
*
*       /LOOP/
*         FOR  EACH CENTRAL MEMORY BUFFER  DO
*           IF  DATA LENGTH ERROR  THEN
*             FORMAT ABNORMAL RESPONSE.
*             EXIT /LOOP/.
*           ELSE
*             READ CORRESPONDING AMOUNT OF DATA FROM CENTRAL MEMORY.
*           IFEND
*         FOREND /LOOP/


 RDC0     LDN    0           RETURN, (A) = 0, DATA INPUT SUCCESSFULLY

 RDC      SUBR               ENTRY/EXIT
          STDL   SCRATCH     SAVE SUBFUNCTION BUFFER LENGTH
          SBK    C.IODB
          PJN    RDC2        IF AT LEAST ONE BUFFER SPECIFIED
 RDC1     LDK    IEC.505     INVALID LENGTH SPECIFICATION
          RJM    FIE         FORMAT INTERFACE ERROR
*         LCN    0
          UJN    RDCX        RETURN, (A) < 0, FATAL ERROR

 RDC2     LDK    BUFFER
          STML   RDCA        RESET FWA OF BUFFER
          LDN    0
          STDL   BYTCNT      BYTE COUNT
          LDDL   SFOUT
          ADK    B.SDSF

*         THE OUT POINTER MUST BE INCREMENTED BY 8 EACH TIME OTHERWISE
*         THIS ALGORITHM WILL FAIL WHEN THE BUFFER WRAPS AROUND.

 RDC3     STDL   TEMPOUT     POINT TO NEXT BUFFER POINTER
          SBDL   SFLIMIT
          MJN    RDC4        IF NOT BEYOND BUFFER
          LDK    FIRST
          STDL   TEMPOUT     OUT = FIRST
 RDC4     SODL   SCRATCH
          MJN    RDC0        IF ALL BUFFERS READ UP
          LOADCB SFPTR,TEMPOUT
          CRDL   SCRATCH+1
          ERRNZ  C.IODB-1    CODE ASSUMES THE I/O BUFFER DESC. ARE 1 WORD
          LDDL   SCRATCH+2
          RADL   BYTCNT      UPDATE NUMBER OF BYTES READ
          SBK    MAXBYTES+1
          PJN    RDC1        IF MAXIMUM BUFFER SIZE EXCEEDED
          LDDL   SCRATCH+2
          ADN    7
          SHN    -3
          STDL   BUFSIZE     NUMBER OF CM WORDS TO INPUT
          ZJN    RDC5        IF EMPTY BUFFER SPECIFIED
          LOADCM SCRATCH+3
          CRML   BUFFER,BUFSIZE        INPUT BLOCK OF WORDS
 RDCA     EQU    *-1         CURRENT PLACE WITHIN BUFFER
          LDDL   SCRATCH+2
          SHN    -1          CONVERT BYTES TO PP WORDS
          RAML   RDCA        UPDATE CURRENT BUFFER POSITION
 RDC5     LDDL   TEMPOUT
          ADK    B.IODB
          UJK    RDC3        PROCESS NEXT BUFFER
SBN       SPACE  4,40
**        SBN    SEND BLOCK TO THE NAD
*
*         THE PURPOSE OF THIS REQUEST IS TO INPUT A BLOCK FROM THE NAD.
*
*         ENTRY  (LCMND) = LOGICAL COMMAND.
*                (SFOUT) = OFFSET OF CURRENT SUBFUNCTION.
*                (SFPTR) = POINTER TO SUBFUNCTION BUFFER.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; BLOCK SUCCESSFULLY SENT TO NAD.
*                    > 0, OK; NO ERROR, BUT REQUEST CAN NOT BE COMPLETED.
*                    < 0, ERROR; DETAILED STATUS SET UP.
*
*         GENERATE UNIVERSAL COMMAND FUNCTION BLOCK.
*         ISSUE UNIVERSAL COMMAND.
*         IF  NO ERRORS ENCOUNTERED  THEN
*           IF  STATUS NORMAL  THEN
*             SEND BLOCK ON THE CHANNEL.
*             IF  ERROR ENCOUNTERED  THEN
*               CALL NAD ERROR PROCESSOR.
*             IFEND
*           ELSE
*             IF  RESOURCE LIMIT  THEN
*               IF  RESOURCE TIMER EXPRIED  THEN
*                 SET ABNORMAL STATUS.
*                 CALL NAD ERROR PROCESSOR.
*               IFEND
*             ELSE
*               SET ABNORMAL STATUS.
*               CALL NAD ERROR PROCESSOR.
*             IFEND
*           IFEND
*         IFEND
*         RELEASE THE CHANNEL.


 SBN      SUBR               ENTRY/EXIT
          LDK    UC.WB       WRITE DATA IN BINARY MODE
          SHN    8
          ADDL   LCMND+/SD/P.PATHID    ACROSS THIS PATH
          STML   UNCB+UCB.SF
          LDDL   BYTCNT                CALCULATE NAD WORD COUNT
          ADN    1                     ROUND UP TO NEAREST NAD WORD
          SHN    -1
          STML   UNCB+UCB.NWC
          RJM    IUC         ISSUE UNIVERSAL COMMAND
          ZJN    SBN4        IF FUNCTION ACCEPTED AND READY FOR I/O
          MJN    SBN3        IF NAD ERROR
          LMK    NR.TN&NR.AK
          NJN    SBN2        IF NOT *TRANSFER NOT READY* RESPONSE
          RJM    CRT         CHECK RETRY TIMER
          ZJN    SBN2        IF RETRIES EXHAUSTED
 SBN1     UJN    SBNX

 SBN2     LCN    NE.IVR      INVALID NAD RESPONSE
 SBN3     RJM    PEP         PERFORM NAD ERROR PROCESSING
          UJN    SBN1

 SBN4     LDDL   BYTCNT
          RJM    CVT         SET UP BYTE COUNT

*         ONE CANNOT EXIT A NAD TRANSACTION AT THIS POINT.
*         THE BLOCK SIZE IS VALIDATED IN ROUTINE *RDC*.
*         THEREFORE, *CVT* SHOULD ALWAYS RETURN A NORMAL STATUS HERE.

          RJM    OOC         SEND BLOCK TO THE NAD
          MJN    SBN3        IF NAD ERROR
          LDK    NF.TD
          RJM    ICF         ISSUE TRANSMIT DATA FUNCTION
          MJN    SBN3        IF NAD ERROR
          NJN    SBN2        IF ABNORMAL RESPONSE
          RJM    REL         RELEASE THE CHANNEL
*         LDN    0
          UJK    SBN1        RETURN, (A) = 0, BLOCK SUCCESSFULLY SENT
RDN       SPACE  4,40
**        RDN    RECEIVE DATA FROM NAD
*
*         THE PURPOSE OF THIS ROUTINE IS TO CONTROL THE RECEPTION OF DATA
*         BLOCKS FROM THE NAD.
*
*         ENTRY  UNIT REQUEST INTERLOCKED.
*                (LCMND) = LOGICAL COMMAND.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; ALL REQUESTED DATA HAS BEEN SENT.
*                    > 0, OK; NO ERRORS, BUT REQUEST NOT COMPLETE.
*                    < 0, ERROR; DETAILED STATUS SET UP.
*
*
*         VERIFY AND INITIALIZE SUBFUNCTION POINTERS.
*         WHILE   SPACE AVAILABLE IN THE BUFFER
*                 AND   NO ERRORS ENCOUNTERED     DO
*           READ SUBFUNCTION HEADER.
*           IF  SUBFUNCTION LENGTH ERROR  THEN
*             FORMAT AN INTERFACE ERROR RESPONSE
*           ELSE
*             INPUT BLOCK FROM THE NAD.
*             IF  BLOCK SUCCESSFULLY INPUT  THEN
*               SEND DATA TO CENTAL MEMORY.
*               UPDATE SUBFUNCTION POINTERS.
*               IF  FILE MARK IN HEADER
*                   AND FILE MARK ALERT SELECTED   THEN
*                 FORMAT AN ALERT RESPONSE.
*               IFEND
*             IFEND
*           IFEND
*         WHILEND


 RDN0     RJM    CRT         CHECK RETRY TIMER

*         (A) > 0, IF WE ARE TO DELAY FOR DISK I/O SYNCHRONIZATION.

 RDN      SUBR               ENTRY/EXIT
          RJM    VSP         VERIFY AND INITIALIZE POINTERS
          MJN    RDNX        IF ERROR IN PARAMETERS
 RDN1     LOADCB SFPTR,SFOUT
          CRDL   SUBF        READ SUBFUNCTION HEADER WORD
          LDDL   SUBFEA
          ZJN    RDN0        IF BUFFER IS EMPTY
          SBDL   SUBF+/RDSF/P.SFL
          MJN    RDN0        IF NOT ENOUGH ROOM IN THE BUFFER
          LDDL   SUBF+/RDSF/P.SFL
          SHN    -3
          SBK    C.RDSF
          MJN    RDN3        IF SUBFUNCTION LENGTH ERROR
          STDL   SPECSAV     SAVE LENGTH OF SUBFUNCTION
          RJM    IBN         INPUT BLOCK FROM THE NAD
          NJN    RDNX        IF ERROR ENCOUNTERED
*         LDN    0
          STDL   LCMND+/RD/P.RESRTY    RESET RETRY COUNTER
          RJM    SDC         SEND DATA TO CENTRAL MEMORY
          LOADCB SFPTR,SFOUT
          CWDL   SUBF        REWRITE HEADER WITH TRANSFER LENGTH
          RJM    USP         UPDATE SUBFUNCTION POINTERS
          MJN    RDN4        IF BUFFER POINTER ERROR
          LDML   BUFFER+/BH/P.BT
          LPK    /BH/M.BT
          LMK    BT.MSG
          ZJN    RDN5        IF MESSAGE BLOCK ENCOUNTERED
 RDN2     UJK    RDN1        PROCESS NEXT SUBFUNCTION

 RDN3     LDK    IEC.505     INVALID LENGTH SPECIFICATION
          RJM    FIE         FORMAT INTERFACE ERROR
*         LCN    0
 RDN4     UJK    RDNX        RETURN, (A) < 0, SUBFUNCTION LENGTH ERROR

 RDN5     LDK    TRUE
          SHN    16-/PRS/L.EOM-/PRS/N.EOM
          STML   RESBUF+/PRS/P.EOM     SET END OF MESSAGE ALERT FLAG
          LPML   RESBUF+/PRS/P.ALERTM
          ZJN    RDN7        IF END OF MESSAGE ALERT NOT SELECTED
 RDN6     RJM    FAR         FORMAT AN ALERT RESPONSE
*         LCN    0
          UJN    RDN4        RETURN (A) < 0, ALERT CONDITION ENCOUNTERED

 RDN7     LDML   BUFFER+/BH/P.EOR
          SHN    17-15+/BH/L.EOI
          PJN    RDN10       IF EOI NOT ENCOUNTERED
 RDN8     LDK    TRUE
          SHN    16-/PRS/L.EOI-/PRS/N.EOI        CHECK EOI ALERT
 RDN9     STML   RESBUF+/PRS/P.EOI     SET FILE MARK ALERT FLAG
          LPML   RESBUF+/PRS/P.ALERTM
          NJN    RDN6        IF FILE MARK ALERT SELECTED
          UJN    RDN2        NO ALERTS ENCOUNTERED

 RDN10    SHN    17-15+/BH/L.EOR-17+15-/BH/L.EOI
          PJN    RDN2        IF EOR/EOF NOT FLAG SET
          SHN    17-15+/BH/L.LEVEL-17+15-/BH/L.EOR
          SHN    -18+/BH/N.LEVEL       ISOLATE THE EOR LEVEL NUMBER
          LMK    /BH/M.EOF
          ZJN    RDN11       IF EOF ENCOUNTERED
          LDK    TRUE
          SHN    16-/PRS/L.EOR-/PRS/N.EOR
          UJN    RDN9        CHECK FOR EOR ALERT

 RDN11    LDK    TRUE
          SHN    16-/PRS/L.EOF-/PRS/N.EOF
          UJN    RDN9        CHECK FOR EOF ALERT
IBN       SPACE  4,40
**        IBN    INPUT BLOCK FROM THE NAD
*
*         THE PURPOSE OF THIS REQUEST IS TO INPUT A BLOCK FROM THE NAD.
*
*         ENTRY  (LCMND) = LOGICAL COMMAND.
*                (SFOUT) = OFFSET WITHIN BUFFER OF CURRENT SUBFUNCTION.
*                (SFPTR) = POINTER TO SUBFUNCTION BUFFER.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; BLOCK SUCCESSFULLY RECEIVED FROM NAD.
*                    > 0, OK; NO ERRORS, BUT REQUEST NOT COMPLETE.
*                    < 0, ERROR; DETAILED STATUS SET UP.
*
*
*         GENERATE UNIVERSAL COMMAND FUNCTION BLOCK.
*         ISSUE UNIVERSAL COMMAND.
*         IF  NO ERRORS ENCOUNTERED  THEN
*           IF  STATUS NORMAL  THEN
*             RECEIVE BLOCK FROM THE CHANNEL.
*             IF  ERROR ENCOUNTERED  THEN
*               CALL NAD ERROR PROCESSOR.
*             ELSE
*               IF  BLOCK TYPE ALERT ENCOUNTERED  THEN
*                 RESET BLOCK POINTERS IN THE NAD.
*                 IF  ERROR ENCOUNTERED  THEN
*                   CALL NAD ERROR PROCESSOR.
*                 ELSE
*                   RETURN ALERT CONDITION.
*                 IFEND
*               IFEND
*             IFEND
*           ELSE
*             IF  RESOURCE LIMIT  THEN
*               IF  RESOURCE TIMER EXPIRED  THEN
*                 SET ABNORMAL STATUS.
*                 CALL NAD ERROR PROCESSOR.
*               IFEND
*             ELSE
*               SET ABNORMAL STATUS.
*               CALL NAD ERROR PROCESSOR.
*             IFEND
*           IFEND
*         IFEND
*         RELEASE THE CHANNEL.


 IBN      SUBR               ENTRY/EXIT
          LDK    UC.RB       READ DATA IN BINARY MODE
          SHN    8
          ADDL   LCMND+/SD/P.PATHID    ACROSS THIS PATH
          STML   UNCB+UCB.SF
          RJM    IUC         ISSUE UNIVERSAL COMMAND
          ZJN    IBN4        IF FUNCTION ACCEPTED AND READY FOR I/O
          MJN    IBN3        IF NAD ERROR
          LMK    NR.TN&NR.AK
          NJN    IBN2        IF NOT RESOURCES UNAVAILABLE RESPONSE
          RJM    CRT         CHECK RETRY TIMER
          ZJN    IBN2        IF RETRIES EXHAUSTED
 IBN1     UJN    IBNX

 IBN2     LCN    NE.IVR      INVALID NAD RESPONSE
 IBN3     RJM    PEP         PERFORM NAD ERROR PROCESSING
          UJN    IBN1

 IBN4     LDDL   SUBF+/RDSF/P.TBL
          RJM    CVT         SET TRANSFER COUNT AND ADDRESS
          MJN    IBN7        IF INVALID DATA LENGTH
          RJM    IFC         INPUT BLOCK FROM THE NAD
          MJN    IBN3        IF NAD ERROR
          STDL   SUBF+/RDSF/P.NBT      SAVE NUMBER OF BYTES TRANSFERRED
          LDML   BUFFER+/BH/P.PRU
          SHN    17-15+/BH/L.PRU
          MJN    IBN5        IF PRU FLAG SET IN THE BLOCK HEADER
          LDK    TRUE
          SHN    16-/PRS/L.NONPRU-/PRS/N.NONPRU
          UJN    IBN6        NON-PRU BLOCK ALERT ENCOUNTERED

 IBN5     LDK    TRUE
          SHN    16-/PRS/L.PRU-/PRS/N.PRU        PRU BLOCK ALERT ENCOUNTERED
 IBN6     STML   RESBUF+/PRS/P.PRU               SET ALERT CONDITION
          LPML   RESBUF+/PRS/P.ALERTM
          ZJN    IBN8        IF ALERT CONDITION NOT SELECTED
          RJM    FAR         FORMAT ALERT RESPONSE
 IBN7     LDK    NF.RT
          RJM    ICF         ISSUE RESET FUNCTION
          LCN    0
          UJN    IBN9        RETURN, (A) < 0, ALERT CONDITION ENCOUNTERED

 IBN8     RJM    REL         RELEASE THE CHANNEL
*         LDN    0
 IBN9     UJK    IBNX        RETURN, (A) = 0, BLOCK SUCCESSFULLY SENT
SDC       SPACE  4,20
**        SDC    SEND DATA TO CENTRAL MEMORY
*
*         THE PURPOSE OF THE FOLLOWING ROUTINE IS TO PASS DATA FROM THE PP
*         BUFFER INTO THE SPECIFIED CENTRAL MEMORY BUFFERS.
*
*         ENTRY  (SPECSAV) = NUMBER OF CM WORDS IN THE SUBFUNCTION.
*                (SFOUT) = BYTE OFFSET WITHIN BUFFER OF THE SUBFUNCTION.
*                (SFPTR) = 3-WORD CM ADDRESS POINTER TO *SF* BUFFER.
*
*         EXIT   (A) : STATUS
*                    = 0, ALL DATA SUCCESSFULLY SENT TO CENTRAL MEMORY.
*                    < 0, SUBFUNCTION LENGTH ERROR; DETAILED STATUS SET UP.
*                (TEMPOUT) = OFFSET WITHIN BUFFER OF THE NEXT SUBFUNCTION.
*
*
*         FOR  EACH CENTRAL MEMORY BUFFER  DO
*           WRITE CORRESPONDING AMOUNT OF DATA TO CENTRAL MEMORY.
*         FOREND


 SDC      SUBR               ENTRY/EXIT
          LDK    BUFFER
          STML   SDCA        RESET FWA OF BUFFER
          LDDL   SFOUT
          ADK    B.RDSF

*         THE OUT POINTER MUST BE INCREMENTED BY 8 EACH TIME OTHERWISE
*         THIS ALGORITHM WILL FAIL WHEN THE BUFFER WRAPS AROUND.

 SDC1     STDL   TEMPOUT     POINT TO NEXT BUFFER POINTER
          SBDL   SFLIMIT
          MJN    SDC2        IF NOT BEYOND BUFFER
          LDK    FIRST
          STDL   TEMPOUT     OUT = FIRST
 SDC2     SODL   SPECSAV
          MJN    SDCX        IF ALL BUFFERS PROCESSED
          LOADCB SFPTR,TEMPOUT
          ERRNZ  C.SD-C.RD   CODE ASSUMES THESE TWO VALUES ARE EQUAL
          CRDL   SCRATCH+1
          ERRNZ  C.IODB-1    CODE ASSUMES THE I/O BUFFER DESC. ARE 1 WORD
          LDDL   BYTXFR
          ZJN    SDC4        IF ALL BYTES TRANSFERRED
          SBDL   SCRATCH+2
          PJN    SDC3        IF MORE DATA TO SEND AFTER THIS BUFFER
          LDN    0           NO MORE DATA LEFT
 SDC3     STDL   BYTXFR      UPDATE NUMBER OF BYTES LEFT TO SEND
          LDDL   SCRATCH+2
          ADN    7
          SHN    -3
          STDL   BUFSIZE     NUMBER OF CM WORDS TO OUTPUT
          ZJN    SDC4        IF EMPTY BUFFER
          LOADCM SCRATCH+3
          CWML   BUFFER,BUFSIZE        OUTPUT BLOCK TO CENRAL MEMORY
 SDCA     EQU    *-1         CURRENT PLACE WITHIN BUFFER
          LDDL   SCRATCH+2
          SHN    -1          CONVERT BYTES TO PP WORDS
          RAML   SDCA        UPDATE CURRENT BUFFER POSITION
 SDC4     LDDL   TEMPOUT
          ADK    B.IODB
          UJK    SDC1        PROCESS NEXT BUFFER
ONS       SPACE  4,40
**        ONS    OBTAIN NAD STATUS
*
*         THE PURPOSE OF THIS ROUTINE IS TO OBTAIN THE STATUS OF THE
*         PATHS IN THE CORRESPONDING NAD.
*
*
*         ENTRY  UNIT REQUEST INTERLOCKED.
*                (LCMND) = LOGICAL COMMAND.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; NAD STATUS HAS BEEN UPTAINED.
*                    > 0, OK; NO ERRORS, BUT REQUEST NOT COMPLETED.
*                    < 0, ERROR; DETAILED STATUS SET UP.
*
*
*         ISSUE NAD STATUS FUNCTION.
*         IF  STATUS CHANGE OCCURRED
*             OR  UNCONDITIONAL OBTAIN STATUS SELECTED   THEN
*           INPUT STATUS BLOCK FROM NAD.
*           IF  NO ERROR ENCOUNTERED  THEN
*             WRITE STATUS BLOCK TO CENTRAL MEMORY.
*           ELSE
*            CALL NAD ERROR PROCESSOR.
*           IFEND
*         ELSE
*           IF  ERROR ENCOUNTERED  THEN
*             CALL NAD ERROR PROCESSOR.
*           ELSE
*             SET FLAG TO NOT RETURN A RESPONSE.
*           IFEND
*         IFEND


 ONS      SUBR               ENTRY/EXIT
          LDDL   LCMND+/SN/P.LENGTH
          RJM    CVT         SET UP FOR DATA TRANSFER
          MJN    ONSX        IF TRANSFER LENGTH ERROR
          LDK    NF.NS
          RJM    ICF         ISSUE OBTAIN NAD STATUS FUNCTION
          ZJN    ONS4        IF FUNCTION ACCEPTED
          MJN    ONS2        IF NAD ERROR
          LMK    NR.NK&NR.AK
          NJN    ONS1        IF UNEXPECTED RESPONSE
          LDDL   LCMND+/SN/P.UNCOND
          SHN    17-15+/SN/L.UNCOND
          MJN    ONS4        IF UNCONDITIONAL OBTAIN STATUS
          LDK    NF.AB
          RJM    ICF         ABORT TRANSACTION
          NJN    ONS1        IF NOT SUCCESSFUL
          LDN    1
          UJN    ONSX        RETURN, (A) > 0, NO ERROR BUT NOT COMPLETE

 ONS1     LCN    NE.IVR      INVALID NAD RESPONSE
 ONS2     RJM    PEP         PERFORM NAD ERROR PROCESSING
 ONS3     UJK    ONSX

 ONS4     RJM    IFC         INPUT NAD STATUS
          MJN    ONS2        IF NAD ERROR
          LDDL   BYTXFR      BYTES TRANSFERRED
          ADN    7           ROUND UP BYTES TRANSFERRED TO MULTIPLE OF CM WORD
          SHN    -3
          STDL   BUFSIZE     BYTES TO TRANSFER TO CM
          LOADCM LCMND+/SN/P.BUFFER
          CWML   BUFFER,BUFSIZE        WRITE STATUS TABLE TO CM
          LDN    0
          UJK    ONS3        RETURN (A) = 0, SUCCESSFUL
SCM       SPACE  4,35
**        SCM    SEND CONTROL MESSAGE
*
*         THE PURPOSE OF THIS REQUEST IS TO SEND A CONTROL MESSAGE ACROSS
*         THE NETWORK.
*
*         ENTRY  UNIT REQUEST INTERLOCKED.
*                (LCMND) = LOGICAL COMMAND.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; CONTROL MESSAGE HAS BEEN SENT.
*                    > 0, OK; NO ERRORS, BUT REQUEST NOT COMPLETE.
*                    < 0, ERROR; DETAILED STATUS SET UP.
*
*
*         READ MESSAGE FROM BUFFER.
*         ISSUE SEND CONTROL MESSAGE FUNCTION.
*         IF  ERROR ENCOUNTERED  THEN
*           CALL NAD ERROR PROCESSOR.
*         ELSE
*           OUTPUT BLOCK ON THE CHANNEL.
*           IF  ERROR ENCOUNTERED  THEN
*             CALL NAD ERROR PROCESSOR.
*           ELSE
*             SEND READY FUNCTION TO THE NAD.
*             IF  ERROR ENCOUNTERED  THEN
*               CALL NAD ERROR PROCESSOR.
*             IFEND
*           IFEND
*         IFEND


 SCM      SUBR               ENTRY/EXIT
          LDDL   LCMND+/SCM/P.LENGTH
          RJM    CVT         CONVERT BYTE COUNT
          MJN    SCMX        IF LENGTH ERROR
          LOADCM LCMND+/SCM/P.BUFFER
          CRML   BUFFER,BUFSIZE        READ IN CONTROL MESSAGE
          LDK    NF.SC
          RJM    ICF         ISSUE SEND CONTROL MESSAGE FUNCTION
          MJN    SCM1        IF NAD ERROR
          NJN    SCM4        IF NOT ACK RESPONSE
          RJM    OOC         OUTPUT CONTROL MESSAGE
          ZJN    SCM3        IF ALL BYTES TRANSFERRED
 SCM1     RJM    PEP         PERFORM ERROR PROCESSING
 SCM2     UJK    SCMX        RETURN NAD ERROR

 SCM3     LDK    NF.RY
          RJM    ICF         ISSUE READY FUNCTION
          ZJN    SCMX        IF ACK RESPONSE, RETURN (A) = 0, MESSAGE SENT
          MJN    SCM1        IF NAD ERROR
 SCM4     LCN    NE.IVR
          UJN    SCM1        PROCESS INVALID RESPONSE
RCM       SPACE  4,45
**        RCM    RECEIVE CONTROL MESSAGE
*
*         THE PURPOSE OF THIS REQUEST IS TO OBTAIN AN INCOMING CONTROL
*         MESSAGE.
*
*         ENTRY  UNIT REQUEST INTERLOCKED.
*                (LDMND) = LOGICAL COMMAND.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; CONTROL MESSAGE HAS BEEN RECEIVED.
*                    > 0, OK; NO ERRORS, BUT REQUEST NOT COMPLETE.
*                    < 0, ERROR; DETAILED STATUS SET UP.
*
*
*         IF   RECEIVING INCOMING CONTROL MESSAGES  THEN
*           ISSUE INQUIRE SELECTED CONTROL MESSAGE FUNCTION.
*         ELSE
*           ISSUE INQUIRE SELECTED REJECTED CONTROL MESSAGE FUNCTION.
*         IFEND
*         IF  ERROR ENCOUNTERED  THEN
*           CALL NAD ERROR PROCESSOR.
*         ELSE
*           OUTPUT BLOCK ON THE CHANNEL.
*           IF  ERROR ENCOUNTERED  THEN
*             CALL NAD ERROR PROCESSOR.
*           ELSE
*             SEND READY FUNCTION TO THE NAD.
*             IF  ERROR ENCOUNTERED  THEN
*               CALL NAD ERROR PROCESSOR.
*             ELSE
*               INPUT BLOCK FROM THE CHANNEL
*               IF  ERROR ENCOUNTERED  THEN
*                 CALL NAD ERROR PROCESSOR.
*               ELSE
*                 ISSUE READY FUNCTION.
*                 IF  ERROR ENCOUNTERED  THEN
*                   CALL NAD ERROR PROCESSOR.
*                 ELSE
*                   WRITE MESSAGE TO BUFFER.
*                 IFEND
*               IFEND
*             IFEND
*           IFEND
*         IFEND


 RCM      SUBR               ENTRY/EXIT
          LDDL   LCMND+/RCM/P.LENGTH
          RJM    CVT         SET UP FOR TRANSFER
          MJN    RCMX        IF TRANSFER LENGTH ERROR
          LDDL   LCMND+/RCM/P.CMTYPE
          SHN    17-15+/RCM/L.CMTYPE
          MJN    RCM1        IF INPUTTING REJECTED CONTROL MESSAGE
          LDK    NF.IC
          UJN    RCM2        INQUIRE SELECTED CONTROL MESSAGE

 RCM1     LDK    NF.IR       INQUIRE SELECTED REJECTED CONTROL MESSAGE
 RCM2     RJM    ICF         ISSUE CONTROLWARE FUNCTION
          NJN    RCM5        IF UNEXPECTED REPONSE
          MJN    RCM3        IF NAD ERROR
          LDN    /RCM/B.PHYFRM
          ERRZR  /RCM/B.PHYFRM
          RJM    CVT         CONVERT BYTE COUNT

*         ONE CANNOT EXIT A NAD TRANSACTION AT THIS POINT.
*         THE LENGTH OF THE PHYSICAL FROM IS VALIDATED BY
*         USE OF AN *LDN* INSTRUCTION AND THE *ERRZR* TEST.
*         THEREFORE, *CVT* SHOULD ALWAYS RETURN A NORMAL STATUS.

          LDK    LCMND+/RCM/P.PHYFRM
          STML   OOCA        SET FWA OF BUFFER
          RJM    OOC         SEND PHYSICAL FROM TO THE NAD
          ZJN    RCM6        IF TRANSFER SUCCESSFUL
 RCM3     RJM    PEP         PERFORM NAD ERROR PROCESSING
 RCM4     UJN    RCMX

 RCM5     LCN    NE.IVR      INVALID NAD RESPONSE
          UJN    RCM3

 RCM6     LDK    NF.RY
          RJM    ICF         ISSUE READY FUNCTION
          MJN    RCM3        IF NAD ERROR
          NJN    RCM5        IF NOT ACK RESPONSE
          LDDL   LCMND+/RCM/P.LENGTH
          RJM    CVT         SET UP FOR TRANSFER

*         ONE CANNOT EXIT A NAD TRANSACTION AT THIS POINT.
*         THE CONNECT REQUEST LENGTH IS VALIDATED BY
*         CALLING *CVT* AT THE BEGINNING OF THIS ROUTINE.
*         THEREFORE, *CVT* SHOULD ALWAYS RETURN A NORMAL STATUS HERE.

          RJM    IFC         INPUT CONTROL MESSAGE
          MJN    RCM3        IF NAD ERROR
          LDK    NF.RY
          RJM    ICF         ISSUE READY FUNCTION
          MJN    RCM3        IF NAD ERROR
          NJN    RCM5        IF NOT AN ACK RESPONSE
          LOADCM LCMND+/RCM/P.BUFFER
          CWML   BUFFER,BUFSIZE        WRITE CONTROL MESSAGE TO CM BUFFER
          LDN    0
          UJK    RCM4        RETURN, (A) = 0, CONTROL MESSAGE RECEIVED
TCN       SPACE  4,40
**        TCN    TERMINATE CONNECTION
*
*         THE PURPOSE OF THIS REQUEST IS TO TERMINATE THE SPECIFIED
*         CONNECTION(S) AS SPECIFIED.
*
*         ENTRY  UNIT REQUEST INTERLOCKED.
*                (LCMND) = LOGICAL COMMAND.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE = REQUESTED CONNECTION(S) TERMINATED.
*                    > 0, OK; NO ERRORS, BUT REQUEST NOT COMPLETE.
*                    < 0, NAD ERROR; DETAILED STATUS SET UP.
*
*
*         IF  TERMINATING ALL PATHS  THEN
*           ISSUE PURGE ALL PATHS FUNCTION.
*           IF  ERROR ENCOUNTERED  THEN
*             CALL NAD ERROR PROCESSOR.
*           IFEND
*         ELSE
*           ISSUE SELECT PATH FUNCTION.
*           IF  ERROR ENCOUNTERED  THEN
*             CALL NAD ERROR PROCESSOR.
*           ELSE
*             IF  NORMAL TERMINATION  THEN
*               ISSUE DISCONNECT PATH FUNCTION.
*             ELSE
*               ISSUE PURGE PATH FUNCTION.
*             IFEND
*             IF  ERROR ENCOUNTERED  THEN
*               CALL NAD ERROR PROCESSOR.
*             IFEND
*           IFEND
*         IFEND


 TCN      SUBR               ENTRY/EXIT
          LDDL   LCMND+/DP/P.PATHID
          ZJN    TCN5        IF TERMINATING ALL PATHS
          ADK    NF.SP
          RJM    ICF         ISSUE SELECT PATH FUNCTION
          MJN    TCN3        IF NAD ERROR

*         IGNORE CONTROLWARE RESPONSE

          LDDL   LCMND+/DP/P.ABNORM
          SHN    17-15+/DP/L.ABNORM
          MJN    TCN1        IF ABNORMAL TERMINATION
          LDK    NF.DP
          UJN    TCN2        ISSUE NORMAL DISCONNECT FUNCTION

 TCN1     LDK    NF.PP       ISSUE PURGE PATH FUNCTION
 TCN2     RJM    ICF
          ZJN    TCNX        IF PATH DISCONNECTED (OR PURGED)
          MJN    TCN4        IF FUNCTION NOT ACCEPTED
 TCN3     LCN    NE.IVR      PROCESS INVALID REPONSE ERROR
 TCN4     RJM    PEP         PERFORM ERROR PROCESSING
          UJK    TCNX        RETURN ERROR

 TCN5     LDK    NF.PA
          UJN    TCN2        ISSUE PURGE ALL PATHS FUNCTION
RPS       SPACE  4,35
**        RPS    READ PATH STATUS TABLE
*
*         THE PURPOSE OF THIS REQUEST IS TO OBTAIN THE PATH STATUS
*         INFORMATION FOR THE SPECIFIED CONNECTION.
*
*         ENTRY  UNIT REQUEST INTERLOCKED.
*                (LCMND) = LOGICAL COMMAND.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; PATH STATUS RECEIVED.
*                    > 0, OK; NO ERRORS, BUT REQUEST NOT COMPLETE.
*                    < 0, NAD ERROR; DETAILED STATUS SET UP.
*
*
*         ISSUE SELECT PATH FUNCTION.
*         IF  ERROR ENCOUNTERED  THEN
*           CALL NAD ERROR PROCESSOR.
*         ELSE
*           ISSUE READ PATH STATUS FUNCTION.
*           IF  ERROR ENCOUNTERED  THEN
*             CALL NAD ERROR PROCESSOR.
*           ELSE
*             INPUT BLOCK FROM THE NAD.
*             IF  ERROR ENCOUNTERED  THEN
*               CALL NAD ERROR PROCESSOR.
*             ELSE
*               SEND BLOCK TO CENTRAL MEMORY.
*             IFEND
*           IFEND
*         IFEND


 RPS      SUBR               ENTRY/EXIT
          LDDL   LCMND+/RPST/P.LENGTH
          RJM    CVT         CONVERT BYTE COUNT
          MJN    RPSX        IF TRANSFER LENGTH ERROR
          LDDL   LCMND+/RPST/P.PATHID
          ADK    NF.SP
          RJM    ICF         ISSUE SELECT PATH FUNCTION
          MJN    RPS1        IF NAD ERROR

*         IGNORE CURRENT PATH STATUS

          LDK    NF.PS
          RJM    ICF         ISSUE READ PATH STATUS FUNCTION
          MJN    RPS1        IF NAD ERROR
          NJN    RPS3        IF NOT ACKNOWLEDGED TO READ THE STATUS
          RJM    IFC         INPUT FROM CHANNEL
          PJN    RPS4        IF ALL DATA TRANSFERRED
 RPS1     RJM    PEP         PERFORM NAD ERROR PROCESSING
 RPS2     UJK    RPSX

 RPS3     LCN    NE.IVR
          UJN    RPS1        PROCESS INVALID RESPONSE

 RPS4     LOADCM LCMND+/RPST/P.BUFFER
          CWML   BUFFER,BUFSIZE        PUT PATH STATUS IN BUFFER
          LDN    0
          UJN    RPSX        RETURN (A) = 0, PATH STATUS RECEIVED
OGS       SPACE  4,10
**        OGS    OBTAIN NAD GENERAL STATUS
*
*         THE PURPOSE OF THIS ROUTINE IS TO OBTAIN THE NAD GENERAL STATUS
*         INFORMATION FROM THE SPECIFIED NAD.
*
*         ENTRY  UNIT REQUEST INTERLOCKED.
*                (LCMND) = LOGICAL COMMAND.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; GENERAL STATUS RECEIVED.
*                    > 0, OK; NO ERROR, BUT REQUEST NOT COMPLETE.
*                    < 0, ERROR; DETAILED STATUS SET UP.
*
*
*         IF  OBTAINING REMOTE NAD GENERAL STATUS  THEN
*           ISSUE SELECT PATH FUNCTION.
*           IF  ERROR ENCOUNTERED  THEN
*             CALL NAD ERROR PROCESSOR.
*           ELSE
*             IF  REMOTE STATUS PRIMED  THEN
*               ISSUE MAINTENANCE INPUT FUNCTION.
*             ELSE
*               ISSUE READ REMOTE STATUS FUNCTION.
*             IFEND
*             IF  ERROR ENCOUNTERED  THEN
*               CALL NAD ERROR PROCESSOR.
*             ELSE
*               INPUT BLOCK FROM THE NAD.
*               IF  ERROR ENCOUNTERED  THEN
*                 CALL NAD ERROR PROCESSOR.
*               ELSE
*                 WRITE GENERAL STATUS DATA TO CENTRAL MEMORY.
*               IFEND
*             IFEND
*           IFEND
*         ELSE
*           ISSUE OBTAIN GENERAL STATUS FUNCTION.
*           IF  ERROR ENCOUNTERED  THEN
*             CALL NAD ERROR PROCESSOR.
*           ELSE
*             INPUT BLOCK FROM THE NAD.
*             IF  ERROR ENCOUNTERED  THEN
*               CALL NAD ERROR PROCESSOR.
*             ELSE
*               WRITE GENERAL STATUS DATA TO CENTRAL MEMORY.
*             IFEND
*           IFEND
*         IFEND


 OGS      SUBR               ENTRY/EXIT
          LDDL   LCMND+/ONGS/P.LENGTH
          RJM    CVT         CONVERT BYTE COUNT TO CM AND CHANNEL WORD COUNTS
          MJN    OGSX        IF TRANSFER LENGTH ERROR
          IF     DEF,MCON
          LDDL   LCMND+/ONGS/P.PATHID
          NJN    OGS1        IF REMOTE STATUS FUNCTION
          ENDIF
          LDK    NF.GS
          UJN    OGS7        ISSUE GENERAL STATUS FUNCTION

          IF     DEF,MCON
 OGS1     ADK    NF.SP
          RJM    ICF         ISSUE SELECT PATH FUNCTION
          ZJN    OGS5        IF PATH IN A VALID STATE
          MJN    OGS3        IF NAD ERROR
 OGS2     LCN    NE.IVR      INVALID NAD RESPONSE
          ENDIF
 OGS3     RJM    PEP         PERFORM NAD ERROR PROCESSING
 OGS4     UJN    OGSX

          IF     DEF,MCON
 OGS5     LDDL   LCMND+/ONGS/P.RNADP
          SHN    17-15+/ONGS/L.RNADP
          MJN    OGS6        IF REMOTE NAD STATUS PRIMED

*         THE FOLLOWING FLAG IS SET SO THAT SUBSEQUENT RETRIES WILL USE
*         THE MAINTENANCE PATH INPUT FUNCTION TO RETRIEVE THE GENERAL STATUS.

          LDK    TRUE
          SHN    16-/ONGS/L.RNADP-/ONGS/N.RNADP
          STDL   LCMND+/ONGS/P.RNADP   SET PRIMED FLAG
          LDK    NF.RR
          UJN    OGS7        ISSUE READ REMOTE STATUS FUNCTION

 OGS6     LDK    NF.MI       ISSUE MAINTENANCE PATH INPUT FUNCTION
          ENDIF
 OGS7     RJM    ICF         ISSUE CONTROLWARE FUNCTION
          ZJN    OGS9        IF READY FOR INPUT
          MJN    OGS3        IF NAD ERROR
          IF     DEF,MCON
          LMK    NR.TN&NR.AK
          ZJN    OGS11       IF  *TRANSFER NOT READY* STATUS
          ENDIF
 OGS8     LCN    NE.IVR
          UJN    OGS3        PROCESS INVALID RESPONSE

 OGS9     RJM    IFC         INPUT GENERAL STATUS
          MJN    OGS3        IF INPUT ERROR
          LOADCM LCMND+/ONGS/P.BUFFER
          CWML   BUFFER,BUFSIZE
          LDN    0
 OGS10    UJK    OGS4        RETURN, (A) = 0, GENERAL STATUS RETURNED

          IF     DEF,MCON
 OGS11    SODL   LCMND+/ONGS/P.RETRYC
          MJN    OGS8        IF RETRIES EXHAUSTED
          LDN    1
          UJN    OGS10       RETURN, (A) > 0, REQUEST NOT COMPLETE
          ENDIF
PPC       TITLE  PPC - PROCESS PHYSICAL COMMANDS.
**        PPC    PROCESS PHYSICAL COMMANDS
*
*         THE PURPOSE OF THIS ROUTINE IS TO PROCESS A SERIES OF PHYSICAL
*         COMMANDS.
*
*         ENTRY  UNIT REQUEST INTERLOCKED.
*                (LCMND) = LOGICAL COMMAND.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE;  PHYSICAL FUNCTIONS COMPLETED.
*                    < 0, ERROR; DETAILED STATUS SET UP.
*
*
*         REPEAT
*           CASE   TYPE OF PHYSICAL COMMAND   OF
*             =  ISSUE CONTROLWARE FUNCTION  =
*               ISSUE THE SPECIFIED NAD FUNCTION.
*             =  OUTPUT 8/8 MODE  =
*               READ BLOCK FROM CENTAL MEMORY.
*               OUTPUT BLOCK.
*             =  SEND TRANSFER ADDRESS AND LENGTH  =
*               READ BLOCK FROM CENTAL MEMORY.
*               OUTPUT BLOCK.
*             =  INPUT 8/8 MODE  =
*               INPUT BLOCK FROM NAD.
*               WRITE DATA TO CENTRAL MEMORY.
*             =  GET CONTROLWARE STATUS  =
*               GET CONTROLWARE STATUS.
*               VERIFY STATUS WITH USER MASK.
*             =  GET HARDWARE STATUS  =
*               GET HARDWARE STATUS.
*               VERIFY STATUS WITH USER MASK.
*           ELSE
*             RETURN ILLEGAL PHYSICAL COMMAND RESPONSE.
*           CASEND
*           IF  NO ERROR ENCOUNTERED  THEN
*             INCREMENT COMMAND POINTER.
*           IFEND
*         UNTIL  END OF COMMAND LIST
*                OR  AN ERROR IS ENCOUNTERED


 PPC0     LDN    0           RETURN, (A) = 0, NORMAL COMPLETION

 PPC      SUBR               ENTRY/EXIT
          LDDL   REQLGTH
          SHN    -3
          SBK    C.PR+C.LCF
          STDL   NUMCMND     NUMBER OF COMMANDS TO PROCESS
          ERRNZ  C.PCF-1     CODE ASSUMES PHYSICAL COMMAND LENGTH = 1 CM WORD
          LDK    C.LCF*8
 PPC1     RAML   RESBUF+/PRS/P.RMALC+1           POINT TO NEXT PHYSCIAL COMMAND
          SHN    -16
          RAML   RESBUF+/PRS/P.RMALC
          SODL   NUMCMND
          MJN    PPC0        IF ALL COMMANDS PROCESSED
          LOADCM RESBUF+/PRS/P.RMALC
          CRDL   PCMND       READ PHYSICAL COMMAND
          LDDL   PCMND+/PCF/P.PCMND
          SHN    -16+/PCF/L.PCMND+/PCF/N.PCMND
          LMK    PC.IF
          NJN    PPC3        IF NOT ISSUE FUNCTION REQUEST
          LDDL   PCMND+/INF/P.FUNC
          RJM    FUN         ISSUE NAD FUNCTION
          MJN    PPC5        IF NAD ERROR
 PPC2     LDK    C.PCF*8
          UJK    PPC1        PROCESS NEXT PHYSICAL COMMAND

 PPC3     LMK    PC.OB&PC.IF
          NJN    PPC7        IF NOT OUTPUT DATA IN BIT STRING MODE
          LDDL   PCMND+/O8D/P.LENGTH
          RJM    CVT
          MJN    PPC6
          LOADCM PCMND+/O8D/P.BUFFER
          CRML   BUFFER,BUFSIZE        READ IN DATA BLOCK
          RJM    OOC         OUTPUT DATA ON CHANNEL
          ZJN    PPC2        IF ALL DATA TRANSFERRED
 PPC5     RJM    PEP         PERFORM NAD ERROR PROCESSING
 PPC6     UJK    PPCX

 PPC7     LMK    PC.SA&PC.OB
          NJN    PPC8        IF NOT SEND TRANSFER ADDRESS REQUEST
          LOADCM PCMND+/SAL/P.BUFFER
          CRDL   TRADDR      READ IN TRANSFER LENGTH AND ADDRESS
          ERRNZ  TRLENC-1    CODE ASSUMES THE LENGTH IS ONE CM WORD
          ACN    CH+40B
          LDK    TRLENCH
          OAM    TRADDR,CH   SEND TRANSFER LENGTH AND ADDRESS TO THE NAD
          IF     DEF,NDI0
          STDL   SCRATCH     SAVE WORD COUNT
          LCN    0
 PPC7.3   EJM    PPC7.5,CH   IF CHANNEL EMPTY
          SBN    1
          NJN    PPC7.3      IF TIMER HAS NOT EXPIRED
          LDC    -NE.DTO
          UJN    PPC5        RETURN, DATA TIMEOUT ERROR

 PPC7.5   LDDL   SCRATCH
          ENDIF
          DCN    CH+40B
          ZJN    PPC9        IF TRANSFER SUCCESSFUL
          LCN    NE.OTE
          UJK    PPC5        PROCESS TRANSFER ERROR

 PPC8     LMK    PC.IB&PC.SA
          NJN    PPC10       IF NOT INPUT DATA IN BIT STRING MODE
          LDDL   PCMND+/I8D/P.LENGTH
          RJM    CVT
          MJN    PPC6        IF LENGTH ERROR ENCOUNTERED
          RJM    IFC         INPUT BLOCK FROM THE NAD
          STDL   SCRATCH+1
          SHN    -16
          STDL   SCRATCH
          LOADCM PCMND+/I8D/P.BUFFER
          CWML   BUFFER,BUFSIZE        WRITE BLOCK TO CENTRAL MEMORY
          LDDL   SCRATCH
          SHN    16
          LMDL   SCRATCH+1
          MJN    PPC12       IF ERROR ENCOUNTERED
          SBDL   PCMND+/I8D/P.LENGTH
          PJN    PPC9        IF ALL EXPECTED DATA RECEIVED
          LCN    NE.ITE      IF INPUT TRANSFER ERROR
          UJN    PPC12

 PPC9     UJK    PPC2        IF NORMAL RESPONSE

 PPC10    LMK    PC.HS&PC.IB
          NJN    PPC13       IF NOT OBTAIN HARDWARE STATUS REQUEST
          RJM    OHS         OBTAIN HARDWARE STATUS
          MJN    PPC12       IF NAD ERROR
          LPDL   PCMND+/ONHS/P.HWMASK
          LMDL   PCMND+/ONHS/P.HWVAL
 PPC11    ZJN    PPC9        IF EXPECTED RESPONSE RECEIVED
          LCN    NE.IVR
 PPC12    UJK    PPC5        PROCESS INVALID NAD RESPONSE

 PPC13    LMK    PC.CS&PC.HS
          NJN    PPC14       IF NOT OBTAIN CONTROLWARE STATUS REQUEST
          RJM    OCS         OBTAIN CONTROLWARE STATUS
          MJN    PPC12       IF NAD ERROR
          LPDL   PCMND+/ONCS/P.CWMASK
          LMDL   PCMND+/ONCS/P.CWVAL
          UJN    PPC11       VALIDATE STATUS

 PPC14    LDK    IEC.501     INVALID PHYSICAL COMMAND
          RJM    FIE         FORMAT INTERFACE ERROR
*         LCN    0
          UJK    PPCX        RETURN, (A) < 0, INTERFACE ERROR
MPR       TITLE  MPR - MISCELLANEOUS PROCEDURES.
**        MPR    MISCELLANEOUS PROCECURES
*
*         THE FOLLOWING ROUTINES PERFORM COMMON PROCESSES THAT ARE UTILIZED
*         BY MORE THAN ONE ROUTINE.
ATI       SPACE  4,30
**        ACQUIRE TABLE INTERLOCK
*
*         THE PURPOSE OF THIS ROUTINE IS TO OBTAIN THE INTERLOCK FOR A
*         SPECIFIED TABLE.
*
*         ENTRY  (A) = POINTER TO INTERLOCK WORD ADDRESS.
*
*         EXIT   (A) : STATUS
*                    = 0, SET = REQUESTED INTERLOCK SET.
*                    <> 0, IN USE = INTERLOCK IS CURRENTLY IN USE.
*
*
*         REPEAT
*           SET UPPER 32 BITS OF I/L WORD TO ONE'S.
*           IF   ORIGINAL MEMORY CONTENTS ARE ZERO   THEN
*             SET INTERLOCK FOR THIS PP.
*           ELSE
*             IF  SOMEONE ELSE HAD THE INTERLOCK   THEN
*               RESTORE THE ORIGINAL CONTENTS.
*             IFEND
*           IFEND
*         UNTIL  INTERLOCK OBTAINED
*                OR SOMEONE ELSE HAS THE INTERLOCK


 ATI      SUBR               ENTRY/EXIT
          STDL   SCRATCH     SAVE INTERLOCK ADDRESS POINTER
 ATI1     RJM    SCL         SET COMPARE/SWAP LOCK
          ZJN    ATI1        IF ANOTHER INTERLOCK OPERATION IS IN PROGRESS
          LDDL   SCRATCH+1
          SHN    17-15
          MJN    ATI2        IF INTERLOCK ALREADY SET (RESTORE WORD)
          LDC    100000B
          RADL   SCRATCH+1   SET INTERLOCK BIT
          LDN    **          PP NUMBER
 ATIA     EQU    *-1           (PLUGGED BY INITIALIZATION ROUTINE)
          STDL   SCRATCH+4
 ATI2     LDDL   SCRATCH+5
          ADC    400000B
          CWDL   SCRATCH+1   UPDATE INTERLOCK WORD
          LDDL   SCRATCH+4
          LMN    **          PP NUMBER
 ATIB     EQU    *-1           (PLUGGED BY INITIALIZATION ROUTINE)

*         (A) = 0, IF THE INTERLOCK IS OWNED BY THIS PP

          UJK    ATIX        RETURN, INTERLOCK SET
CBT       SPACE  4,20
**        CBT    CONVERT THE NUMBER OF BYTES TRANSFERRED
*
*         THE PURPOSE OF THIS ROUTINE IS TO CALCULATE THE NUMBER OF BYTES
*         TRANSFERRED BY A PREVIOUS CHANNEL INPUT OR OUTPUT.
*
*         ENTRY  (BYTXFR) = NUMBER OF CHANNEL WORDS NOT TRANSFERRED.
*                (WTOXFR) = NUMBER OF CHANNEL WORDS TO TRANSFER.
*
*         EXIT   (A) = (BYTXFR) = (RESBUF+/PRS/P.TC) = BYTES TRANSFERRED.
*
*         CALCULATE NUMBER OF CHANNEL WORDS TRANSFERRED.
          IF     DEF,NDI0
*         BYTES TRANSFERRED = CHANNEL WORDS TRANSFERRED * 2.
          ELSE
*         BYTES TRANSFERRED = CHANNEL WORDS TRANSFERRED * 3 / 2.
          ENDIF


 CBT      SUBR               ENTRY/EXIT
          LDDL   WTOXFR      WORDS TO TRANSFER
          SBDL   BYTXFR      WORDS NOT TRANSFERRED
          IF     DEF,NDI0
          SHN    1           CHAN WORDS * 2
          ELSE
          STDL   SCRATCH     NUMBER OF CHANNEL WORDS TRANSFERRED
          SHN    1           CHAN WORDS * 2
          ADDL   SCRATCH     CHAN WORDS * 3
          ADN    1           ROUND UP TO NEAREST BYTE
          SHN    -1          CHAN WORDS * 3 / 2
          ENDIF
          STDL   BYTXFR      SAVE NUMBER OF BYTES TRANSFERRED
          STML   RESBUF+/PRS/P.TC+1    SAVE TRANSFER COUNT FOR ERROR PROCS
          UJN    CBTX
CRT       SPACE  4,20
**        CRT    CHECK RETRY TIMER
*
*         THE PURPOSE OF THIS ROUTINE IS TO CHECK THE I/O RESOURCE
*         RETRY TIMER TO SEE IF THE REQUESTED DELAY TIME HAS BEEN
*         EXCEEDED.
*
*         ENTRY  (PPFRC) = THE PP FREE RUNNING CLOCK.
*
*         EXIT   (A) : STATUS
*                    > 0, OK; RETRY COUNT NOT EXHAUSTED.
*                    = 0, DONE; RETRIES EXHAUSTED.
*
*         IF  RETRIES REQUESTED  THEN
*           IF  FIRST TIME AT THRESHOLD  THEN
*             INITIALIZE TO CURRENT CLOCK TIME.
*           ELSE
*             CHECK CURRENT TIME VERSUS INITIAL TIME.
*             IF  100 MILLI-SECONDS ELAPSED  THEN
*               SET REQUEST TO DONE.
*             ELSE
*         IFEND


 CRT      SUBR
          LDDL   MDATF       MORE DATA COMING FLAG
          SHN    17-15+/SD/L.MORDAT
          ERRNZ  /SD/L.MORDAT-/RD/L.MORDAT       COSE ASSUMES EQUALITY
          MJN    CRT1        IF MORE DATA COMING
          LDDL   SFIN
          SBDL   SFOUT
          ZJN    CRTX        IF BUFFER IS EMPTY
 CRT1     LDDL   LCMND+/SD/P.RESRTY
          NJN    CRT2        IF NOT INITIAL RETRY
          LDDL   CURUIT+/UIT/P.RQCLK
          STDL   LCMND+/SD/P.RESRTY    INITIALIZE RETRY TIMER
          UJN    CRTX

 CRT2     SBDL   CURUIT+/UIT/P.RQCLK
          ZJN    CRTX        IF THESE TWO ARE EQUAL ASSUME TIME-OUT
          MJN    CRT3        IF COUNTER HAS NOT RAPPED
          ADC    -177777B    GET THE NEGATIVE VALUE
 CRT3     ADC    RESTO
 CRTA     EQU    *-1         CHANGED TO *RESTO/2* FOR 2XPP
          PJN    CRTX        IF > 0, TIMER NOT EXPIRED
          LDN    0
          UJK    CRTX        RETURN, TIMER EXPIRED
CVT       SPACE  4,20
**        CVT    CONVERT BYTE COUNT
*
*         THE PURPOSE OF THIS ROUTINE IS TO CONVERT A BYTE COUNT (8-BIT) INTO
          IF     DEF,NDI0
*         A CHANNEL TRANSFER COUNT (16-BIT) AND A CENTRAL MEMORY TRANSFER
          ELSE
*         A CHANNEL TRANSFER COUNT (12-BIT) AND A CENTRAL MEMORY TRANSFER
          ENDIF
*         COUNT (64-BIT).
*
*         ENTRY  (A) = BYTE COUNT.
*
*         EXIT   (A) : STATUS
*                    => 0, OK; BYTE COUNT CONVERTED AND VALID.
*                    < 0, ERROR; DETAILED STATUS SET UP.
*                (WTOXFR) = CHANNEL COUNT.
*                (BUFSIZE) = CENTRAL MEMORY COUNT.
*                (OOCA) = (IFCA) = POINTER TO BUFFER.
*
          IF     DEF,NDI0
*         CHANNEL COUNT = BYTE COUNT / 2.
          ELSE
*         CHANNEL COUNT = BYTE COUNT * 2 / 3.
          ENDIF
*         WORD COUNT = (BYTE COUNT + 7) * 8.
*         IF  COUNT = 0   OR  COUNT EXCEEDS MAXIMUM LENGTH  THEN
*           FORMAT AN INTERFACE ERROR.
*         IFEND
*
          IF     DEF,NDI0
*         NOTE   THE FOLLOWING ALGORITHM IS USED TO MULTIPY THE WORD
*                COUNT PLUS 2 BY 1/3 TO ROUND IT TO A MULTIPLE OF 3
*
*                ((10*WORDSP2) + (11*WORDSP2/16) - (21*WORDSP2/1024))/32
          ELSE
*         NOTE   THE FOLLOWING ALGORITHM IS USED TO MULTIPY THE BYTE
*                COUNT BY 2/3 TO OBTAIN THE CHANNEL COUNT
*
*                ((10*BYTES) + (11*BYTES/16) - (21*BYTES/1024))/16
          ENDIF
*
*                THE INITIAL BYTE COUNT IS INCREMENTED BY ONE PRIOR TO THE
*                COMPUTATION TO MAKE SURE THE CHANNEL COUNT IS ROUNDED UP TO
*                THE NEXT CHANNEL WORD.
*
*                THIS ALGORITHM WORKS FOR NUMBERS BETWEEN 0 AND 6000.
*                VALUES BEYOND THIS RANGE WILL NOT WORK DUE TO THE LIMITATIONS
*                OF THE A-REGISTER AND THE MEMORY LOCATIONS.
*
          IF     DEF,NDI0
*                THE COMPUTED COUNT IS ROUNDED UP TO A MULTIPLE OF 3.
*                THIS IS TO HANDLE THE CHANNEL RESIDUE PROBLEMS WHEN GOING
*                BETWEEN THE NAD, CONVERTER, AND THE 16-BIT PP MEMORY.
          ELSE
*                THE COMPUTED COUNT IS ROUNDED UP TO A MULTIPLE OF 4.
*                THIS IS TO HANDLE THE CHANNEL RESIDUE PROBLEMS WHEN GOING
*                BETWEEN THE 12-BIT CHANNEL AND THE 16-BIT PP MEMORY.
          ENDIF


 CVT      SUBR               ENTRY/EXIT
          ADN    1
          IF     DEF,NDI0
          STDL   SCRATCH+3   BYTES
          SHN    -1          BYTES / 2
          ADN    2           WORDS + 2
          STDL   SCRATCH     CHANNEL WORD COUNT + 2 (WORDSP2)
          SHN    1           2*WORDSP2
          STDL   SCRATCH+1
          SHN    2           8*WORDSP2
          ADDL   SCRATCH+1   10*WORDSP2
          STDL   SCRATCH+2
          SHN    1           20*WORDSP2
          ADDL   SCRATCH     21*WORDSP2
          SHN    -10         (21*WORDSP2/1024)
          STDL   SCRATCH+1
          LDDL   SCRATCH+2   10*WORDSP2
          ADDL   SCRATCH     11*WORDSP2
          SHN    -4          (11*WORDSP2/16)
          ADDL   SCRATCH+2   (10*WORDSP2) + (11*WORDSP2/16)
          SBDL   SCRATCH+1   (10*WORDSP2) + (11*WORDSP2/16) - (21*WORDSP2/1024)
          SHN    -5          ((10*WORDSP2)+(11*WORDSP2/16)-(21*WORDSP2/1024))/32
          STDL   SCRATCH+1   (WORDS+2)/3
          SHN    1           (WORDS+2)/3 * 2
          ADDL   SCRATCH+1   (WORDS+2)/3 * 3
          STDL   WTOXFR      CHANNEL WORDS = BYTES / 2
          ZJN    CVT2        IF TRANSFER LENGTH ZERO
          SBK    MAXBYTES/2+1
          PJN    CVT2        IF MAXIMUM BUFFER SIZE EXCEEDED
          ERRNZ  MAXBYTES/2*2-MAXBYTES    MAXBYTES NOT A MULTIPLE OF 2
          LDDL   SCRATCH+3   ORIGINAL BYTE COUNT + 1
          ELSE
          STDL   SCRATCH     BYTES
          SHN    1           2*BYTES
          STDL   SCRATCH+1
          SHN    2           8*BYTES
          ADDL   SCRATCH+1   10*BYTES
          STDL   SCRATCH+2
          SHN    1           20*BYTES
          ADDL   SCRATCH     21*BYTES
          SHN    -10         (21*BYTES/1024)
          STDL   SCRATCH+1
          LDDL   SCRATCH+2   10*BYTES
          ADDL   SCRATCH     11*BYTES
          SHN    -4          (11*BYTES/16)
          ADDL   SCRATCH+2   (10*BYTES) + (11*BYTES/16)
          SBDL   SCRATCH+1   (10*BYTES) + (11*BYTES/16) - (21*BYTES/1024)
          SHN    -4          ((10*BYTES)+(11*BYTES/16)-(21*BYTES/1024))/16
          ADN    3
          SCN    3           LENGTH MUST BE A MULTIPLE OF 4
          STDL   WTOXFR      CHANNEL WORDS = BYTES * 2 / 3
          ZJN    CVT2        IF TRANSFER LENGTH ZERO
          SBK    MAXBYTES*2/3+1
          PJN    CVT2        IF MAXIMUM BUFFER SIZE EXCEEDED
          ERRNZ  MAXBYTES/3*3-MAXBYTES           MAXBYTES NOT A MULTIPLE OF 3
          LDDL   SCRATCH     ORIGINAL BYTE COUNT + 1
          ENDIF
          ADN    6
          SHN    -3
          STDL   BUFSIZE     CM WORDS TO TRANSFER
          LDC    BUFFER
          STML   OOCA        INITIALIZE DATA BUFFER POINTERS
          STML   IFCA
 CVT1     UJK    CVTX        RETURN, (A) => 0, TRANSFER COUNTS SET UP

 CVT2     LDK    IEC.505
          RJM    FIE         FORMAT INTERFACE ERROR
*         LCN    0
          UJN    CVT1        RETURN, (A) < 0, INTERFACE ERROR
FAR       SPACE  4,20
**        FAR    FORMAT AN ALERT RESPONSE.
*
*         EXIT   (A) < 0.
*
*         SET ALERT STATUS FLAG.
*         SET ABNORMAL RESPONSE TYPE.


 FAR      SUBR               ENTRY/EXIT
          LDK    TRUE
          SHN    16-/PRS/L.ALERT-/PRS/N.ALERT
          STML   RESBUF+/PRS/P.ALERT   SET ALERT CONDITION ENCOUNTERED FLAG
          LDK    RT.ABN
          SHN    16-/PRS/L.RTYPE-/PRS/N.RTYPE
          STML   RESBUF+/PRS/P.RTYPE
          LCN    0
          UJN    FARX
FCA       SPACE  4,20
**        FCA    FORMAT CENTRAL MEMORY ADDRESS
*
*         ENTRY  (A) = POINTER TO CENTRAL MEMORY ADDRESS.
*
*         EXIT   (A) = CENTRAL MEMORY ADDRESS OFFSET + 400000B.
*                (R) = CENTRAL MEMORY ADDRESS.
*
*         SET R-REGISTER TO RMA/1000B.
*         SET A-REGISTER TO MOD(RMA/10B,100B) + OFFSET + 400000B.


 FCA      SUBR               ENTRY/EXIT
          STDL   CMADR
          LDML   1,CMADR
          SHN    -3          REMOVE BYTE OFFSET (ROUND DOWN)
          SHN    12
          STD    CMADR+1     PRESERVE LOWER 7 BITS OF  ADDR/100B
          SHN    -12
          STD    CMADR+2     CM ADDRESS OFFSET    MOD(ADDR,100B)
          LDIL   CMADR
          LPN    37B
          SHN    7
          RAD    CMADR+1     LOW ORDER 12 BITS OF  ADDR/100B
          LDIL   CMADR
          SHN    -5
          STD    CMADR       UPPER 11 BITS OF  ADDR/100B
          LRD    CMADR
          LDD    CMADR+2
          ADC    400000B     SET (A) NEGATIVE FOR R-REGISTER USAGE
          UJK    FCAX
FIE       SPACE  4,20
**        FIE    FORMAT INTERFACE ERROR
*
*         ENTRY  (A) = INTERFACE ERROR CODE.
*
*         EXIT   (A) < 0
*
*         PLUG ERROR CODE.
*         SET INTERFACE ERROR FLAG IN ABNORMAL STATUS FIELD.
*         SET ABNORMAL STATUS.


 FIE      SUBR               ENTRY/EXIT
          STML   RESBUF+/PRS/P.IEC               INTERFACE ERROR CODE
          LDN    TRUE
          SHN    16-/PRS/L.INTERR-/PRS/N.INTERR
          STML   RESBUF+/PRS/P.INTERR            INTERFACE ERROR
          LDK    RT.ABN
          SHN    16-/PRS/L.RTYPE-/PRS/N.RTYPE
          STML   RESBUF+/PRS/P.RTYPE             ABNORMAL RESPONSE
          LCN    0
          UJN    FIEX
SCL       SPACE  4,20
**        SCL    SET COMPARE SWAP LOCK
*         SET UPPER 32 BITS OF I/L WORD TO ONE'S.
*
*         ENTRY  (SCRATCH) = POINTER TO INTERLOCK WORD ADDRESS.
*
*         EXIT   (A) : STATUS
*                    = 0, IF ANOTHER INTERLOCK OPERATION IN PROCESS.
*                   <> 0, IF LOCK SET
*                   (SCRATCH - SCRATCH+4) = CONTNETS OF WORD
*                   (SCRATCH+5) = ADDRESS OFFSET OF WORD


 SCL      SUBR               ENTRY/EXIT
          LDC    177777B
          STDL   SCRATCH+1
          STDL   SCRATCH+2
          LDN    0
          STDL   SCRATCH+3
          STDL   SCRATCH+4
          LOADCM 0,SCRATCH
          STDL   SCRATCH+5
          RDSL   SCRATCH+1   SET UPPER 32 BITS OF LOCK WORD TO '1'S
          LDDL   SCRATCH+1
          ADDL   SCRATCH+2
          SBK    177777B*2
          UJN    SCLX        EXIT
IRB       SPACE  4,20
**        IRB    INITIALIZE RESPONSE BUFFER
*
*         ENTRY  (REQBUF) = REQUEST HEADER.
*                (RESBUF) = PVA AND RMA REQUEST POINTERS SET UP.
*
*         CLEAR ABNORMAL STATUS FLAGS.
*         CLEAR TRANSFER COUNT.
*         SET RESPONSE TYPE TO NORMAL.
*         SET LAST COMMAND TO CURRENT COMMAND.
*         SET NORMAL RESPONSE LENGTH.


 IRB      SUBR               ENTRY/EXIT
          LDN    0
          STML   RESBUF+/PRS/P.ALERT             CLEAR ABNORMAL STATUS FIELD
          STML   RESBUF+/PRS/P.TC                RESET TRANSFER COUNT
          STML   RESBUF+/PRS/P.TC+1
          STDL   NUMREQ
          LDK    RT.NOR
          SHN    16-/PRS/L.RTYPE-/PRS/N.RTYPE
          STML   RESBUF+/PRS/P.RTYPE             PRESET TO NORMAL RESPONSE
          LDML   RESBUF+/PRS/P.RMAOR+1
          ADK    B.PR
          STML   RESBUF+/PRS/P.RMALC+1           SET CURRENT COMMAND TO
          SHN    -16                                 LAST COMMAND COMPLETED
          ADML   RESBUF+/PRS/P.RMAOR
          STML   RESBUF+/PRS/P.RMALC
          LDML   RESBUF+/PRS/P.RL
          STDL   REQLGTH                         SAVE THE REQUEST LENGTH
          LDK    B.PRS
          STML   RESBUF+/PRS/P.RL                SET NORMAL RESPONSE LENGTH
          LDML   RESBUF+/PRS/P.CPUP              INTERRUPT INFORMATION
          SHN    -16+/PR/L.CPUP+/PR/N.CPUP
          LPN    /PR/M.CPUP
          ADK    .INPN
          STML   SRPB                            STORE PROCESSOR TO INTERRUPT
          UJK    IRBX
REL       SPACE  4,20
**        REL    RELEASE THE CHANNEL
*
*         THE PURPOSE OF THIS ROUTINE IS TO CLEAR THE INTERLOCK ON A
*         PREVIOUSLY RESERVED CHANNEL.
*
*         ENTRY  (CITADDR) = POINTER TO CHANNEL INTERLOCK WORD.
*
*         EXIT   (A) = 0.
*                (CHANRES) = FALSE.
*
*         IF  CHANNEL IS RESERVED  THEN
*           RELEASE CHANNEL INTERLOCK.
*           CLEAR CHANNEL RESERVED FLAG.
*         IFEND


 REL      SUBR               ENTRY/EXIT
          LDDL   CHANRES
          LMK    FALSE
          ZJN    RELX        IF CHANNEL NOT RESERVED
          LDK    CITADDR
          RJM    RTI         RELEASE CHANNEL INTERLOCK
          LDK    FALSE
          STDL   CHANRES
          ERRNZ  FALSE       CODE ASSUMES THE CONSTANT *FALSE* IS ZERO
          UJN    RELX        RETURN, CHANNEL RELEASED
RES       SPACE  4,30
**        RES    RESERVE THE CHANNEL
*
*         THE PURPOSE OF THIS ROUTINE IS TO RESERVE THE CHANNEL OF THE
*         CORRESPONDING NAD.
*
*         ENTRY  (UTABI) = CURRENT UNIT BEING PROCESSED.
*                (CHANRES) = FALSE.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; CHANNEL RESERVED AND READY FOR USE.
*                    < 0, ERROR; NAD NOT OPERATIONAL.
*
*
*         REPEAT
*           ACQUIRE CHANNEL INTERLOCK.
*         UNTIL  INTERLOCK ACQUIRED
*         SET CHANNEL RESERVED FLAG.
*         IF  NAD MALFUNCTIONING FLAG SET  THEN
*           RELEASE CHANNEL INTERLOCK.
*           RETURN NAD UNUSABLE STATUS.
*         IFEND


 RES      SUBR               ENTRY/EXIT
 RES2     LDK    CITADDR
          RJM    ATI         ACQUIRE CHANNEL INTERLOCK
          ZJN    RES4        IF CHANNEL INTERLOCK ACQUIRED
          LDK    CHANDEL     DELAY FOR A SHORT TIME
 RES3     SBN    1
 RESA     EQU    *-1         SET TO *SBN 2* IF 2XPP
          NJN    RES3        IF DELAY NOT COMPLETE
          UJN    RES2        RE-ATTEMPT TO ACQUIRE CHANNEL INTERLOCK

 RES4     LDK    TRUE
          STDL   CHANRES     SET CHANNEL RESERVED FLAG
          LOADCB UITADDR,,/UIT/C.DOWN
          CRDL   SCRATCH
          LDDL   SCRATCH+/UIT/P.DOWN
          SHN    17-15+/UIT/L.DOWN
          MJN    RES7        IF CHANNEL DOWN
 RES5     LDN    0
 RES6     UJK    RESX        RETURN, CHANNEL RESERVED

 RES7     RJM    REL         RELEASE CHANNEL INTERLOCK
          LCN    NE.CHD
          UJN    RES6        RETURN, CHANNEL DOWN
RTI       SPACE  4,30
**        RTI    RELEASE TABLE INTERLOCK
*
*         THE PURPOSE OF THIS ROUTINE IS TO RELEASE A PREVIOUSLY OBTAINED
*         TABLE INTERLOCK.
*
*         ENTRY  (A) = POINTER TO THE INTERLOCKED WORD ADDRESS.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; INTERLOCK CLEARED.
*                    < 0, ERROR; INTERLOCK ASSIGNMENT ERROR.
*
*
*         REPEAT
*           SET UPPER 32 BITS OF I/L WORD TO ONES.
*           IF  ORIGINAL I/L CONTENTS INTACT  THEN
*             ZERO OUT I/L WORD.
*           ELSE
*             IF  COMPARE SWAP NOT IN PROGRESS  THEN
*               RESTORE CONTENTS (ASSUME INTERLOCK NOT OBTAINED OR LOST).
*             IFEND
*           IFEND
*         UNTIL  INTERLOCK NOT OWNED BY THIS PP


 RTI      SUBR               ENTRY/EXIT
          STDL   SCRATCH     SAVE INTERLOCK ADDRESS POINTER
 RTI1     RJM    SCL         SET COMPARE/SWAP LOCK
          ZJN    RTI1        IF ANOTHER INTERLOCK OPERATION IS IN PROGRESS
          LDDL   SCRATCH+1
          SHN    17-15
          PJN    RTI2        IF INTERLOCK LOST (RESTORE ORIGINAL CONTENTS)
          LDDL   SCRATCH+4
          LMN    **          PP NUMBER
 RTIA     EQU    *-1           (PLUGGED BY INITIALIZATION ROUTINE)
          NJN    RTI2        IF SOMEONE ELSE HAS GRABBED THE INTERLOCK
*         LDN    0
          STDL   SCRATCH+1   CLEAR INTERLOCK WORD
          STDL   SCRATCH+2
          STDL   SCRATCH+3
          STDL   SCRATCH+4
 RTI2     LDDL   SCRATCH+5
          ADC    400000B
          CWDL   SCRATCH+1   UPDATE INTERLOCK WORD
          UJK    RTIX        RETURN
SDD       SPACE  4,15
**        SDD    SET DEVICE DOWN
*
*         ENTRY  (UTABI) = CURRENT UNIT BEING PROCESSED.
*
*         GET UNIT INTERLOCK.
*         IF  DEVICE NOT ALREADY DOWN  THEN
*           SET UNIT DOWN BIT.
*         IFEND
*         RELEASE UNIT INTERLOCK.


 SDD      SUBR               ENTRY/EXIT
 SDD1     LDK    URQIL
          RJM    ATI         SET UNIT INTERLOCK
          NJN    SDD1        IF INTERLOCK IS BUSY
          LOADCB UITADDR,,/UIT/C.DOWN
          CRDL   CURUIT
          STDL   SCRATCH
          LDDL   CURUIT+/UIT/P.DOWN
          SHN    17-15+/UIT/L.DOWN
          MJN    SDD2        IF UNIT IS ALREADY DOWN
          LDK    TRUE
          SHN    16-/UIT/L.DOWN-/UIT/N.DOWN
          RADL   CURUIT+/UIT/P.DOWN
          LDDL   SCRATCH
          ADC    400000B
          CWDL   CURUIT      SET UNIT DOWN FLAG
 SDD2     LDK    URQIL
          RJM    RTI         RELEASE UNIT INTERLOCK
          UJK    SDDX
SRP       SPACE  4,25
**        SRP    SEND RESPONSE
*
*         THE PURPOSE OF THIS ROUTINE IS TO PLACE A RESPONSE IN THE PP
*         RESPONSE TABLE FOR MONITOR TO PROCESS.
*
*         ENTRY  (RESBUF) = RESPONSE.
*                (A) <> 0, POINTER TO INTERLOCK ADDRESS OF INTERLOCK TO
*                          PRIOR TO PLACING THE RESPONSE IN THE BUFFER.
*                    = 0, DO NOT ACQUIRE ANY INTERLOCK.
*
*
*         WHILE   NO ROOM IN RESPONSE BUFFER   DO
*           DELAY FOR A WHILE.
*         WHILEND
*         IF  INTERLOCK REQUIRED  THEN
*           REPEAT
*             ACQUIRE TABLE INTERLOCK.
*           UNTIL INTERLOCK ACQUIRED.
*         IFEND
*         WRITE RESPONSE IN BUFFER.
*         UPDATE *IN* POINTER.
*         SET INTERRUPT REGISTER.
*         EXCHANGE MONITOR.


 SRP      SUBR               ENTRY/EXIT
          STDL   SPECSAV     SAVE INTERLOCK POINTER
 SRP1     LOADCB PITADDR,,/PIT/C.RBOUT
          CRDL   SCRATCH     READ OUT POINTER
          LDDL   SCRATCH+3
          STDL   RBOUT
          SBDL   RBIN
          SBN    8           OUT - IN - 8
          PJN    SRP2        IF BUFFER HAS NOT WRAPPED
          ADDL   RBLIMIT     OUT - IN - 8 + LIMIT - FIRST
          SBK    FIRST       ALL FIRST POINTER OFFSETS ARE ZERO
 SRP2     SBML   RESBUF+/PRS/P.RL
          PJN    SRP3        IF ROOM IN BUFFER FOR DATA
          LDK    MTRDEL      WAIT FOR MONITOR TO CLEAR BUFFER
          SBN    1
 SRPA     EQU    *-1         SET TO *SBN 2* FOR 2XPP
          NJN    *-1
          UJN    SRP1

 SRP3     LDDL   SPECSAV
          ZJN    SRP5        IF NO INTERLOCK TO ACQUIRE
 SRP4     RJM    ATI         ACQUIRE REQUESTED INTERLOCK
          NJN    SRP3        IF INTERLOCK BUSY
 SRP5     LDML   RESBUF+/PRS/P.RL
          ZJN    SRP7        IF NO RESPONSE TO SEND
          RJM    WRB         WRITE TO RESPONSE BUFFER

*         NOTE   FOR PP REQUEST RESPONSES AND INTERMEDIATE RESPONSES
*                THE RE-WRITING OF THE REQUEST WORD IS A NO-OP.

          LOADCM RESBUF+/PRS/P.RMAOR,,C.PR
          CWML   LCMND,TWO             UPDATE PP REQUEST LOCK WORD
          ERRNZ  LCMND-PPCMND          THESE TWO BUFFERS MUST HAVE SAME FWA
          LOADCB PITADDR,,/PIT/C.RBIN
          CWDL   RBIN-3      UPDATE IN POINTER
          LOADCM INTREG
          CWDL   TWO-3       SET INTERRUPT REGISTER NON-ZERO
          LDN    0           SET (A)=0 FOR S0
          INPN   **          INTERRUPT PROCESSOR
 SRPB     EQU    *-1         PROCESSOR TO INTERRUPT SET BY REQUEST INIT
          CRDL   SCRATCH     ACCESS CM TO UNLOCK ADU
 SRP6     UJK    SRPX

 SRP7     LOADCM RESBUF+/PRS/P.RMAOR,,C.PR       MUST CLEAR PP PROCESSING
          CWML   LCMND,TWO                         FLAG ON NULL RESPONSES
          UJN    SRP6
USP       SPACE  4,20
**        USP    UPDATE SUBFUNCTION POINTERS
*
*         THE PURPOSE OF THIS ROUTINE IS TO ADVANCE THE SUBFUNCTION POINTERS.
*
*         ENTRY  (TEMPOUT) = POINTER TO NEXT SUBFUNCTION.
*
*         EXIT   (A) : STATUS
*                    => 0, OK; (A) = (SUBFEA)= SUBFUNCTION ENTRIES AVAILABLE
*                    < 0, ERROR; DETAILED STATUS SET UP.
*                (SFOUT) = POINTER TO NEXT SUBFUNCTION.
*
*
*         ADVANCE SUBFUNCTION *OUT* POINTER.
*         IF  BUFFER THRESHOLD
*             AND INTERMEDIATE RESPONSE FLAG SET   THEN
*           SEND INTERMEDIATE RESPONSE.
*         IFEND
*         GET NEW *IN* POINTER.


 USP      SUBR               ENTRY/EXIT
          LDDL   TEMPOUT
          STDL   SFOUT       UPDATE OUT POINTER
          LOADCB SFPTR
          ADK    /SD/C.OUTPTR-C.SD
          CWDL   SFOUT-3     UPDATE OUT POINTER
          ADK    /SD/C.INPTR-/SD/C.OUTPTR
          CRDL   SCRATCH     READ IN POINTER
          LDDL   SCRATCH
          STDL   MDATF       SAVE MORE DATA FLAG FOR RETRY ALGORITHM
          LDDL   SCRATCH+3
          STDL   SFIN
          SBDL   LCMND+/SD/P.PREVIN
          ERRNZ  /SD/P.PREVIN-/RD/P.PREVIN    THESE FIELDS MUST BE THE SAME
          ZJN    USP0        IF NO CHANGE IN THE IN POINTER
          RADL   LCMND+/SD/P.PREVIN    SET PREVIOUS IN POINTER TO CURRENT IN
          LDN    1
          STDL   LCMND+/SD/P.INPTRC    REMEMBER THAT THE POINTER CHANGED
          ERRNZ  /SD/P.INPTRC-/RD/P.INPTRC    THESE FIELDS MUST BE THE SAME
 USP0     BSS    0
          LDK    SFIN
          RJM    VIO         VERIFY I/O POINTERS
          MJN    USPX        IF POINTERS INVALID
          STDL   SUBFEA      SAVE NUMBER OF SUBFUNCTION ENTRIES
          SBK    MINRBE
          PJN    USP1        IF ENOUGH DATA REMAINING IN BUFFER
          LDDL   LCMND+/SD/P.INPTRC
          ZJN    USP1        IF IN POINTER HAS NOT CHANGED SINCE LAST INT.
          LDN    0
          STDL   LCMND+/SD/P.INPTRC  REMEMBER INTERRUPT SENT
          LDDL   MDATF       MORE DATA COMING FLAG
          SHN    17-15+/SD/L.MORDAT
          ERRNZ  /SD/L.MORDAT-/RD/L.MORDAT       COSE ASSUMES EQUALITY
          PJN    USP1        IF NO MORE DATA COMING
          LDK    RT.INT
          SHN    16-/PRS/L.RTYPE-/PRS/N.RTYPE
          STML   RESBUF+/PRS/P.RTYPE
          LDN    0
          RJM    SRP         SEND INTERMEDIATE RESPONSE
          LDK    RT.NOR
          SHN    16-/PRS/L.RTYPE-/PRS/N.RTYPE
          STML   RESBUF+/PRS/P.RTYPE             RESET TO NORMAL RESPONSE
 USP1     AODL   NUMREQ      INCREMENT NUMBER OF REQUESTS PROCESSED
          SBK    MSF
          ZJN    USP3        IF MAXIMUM SUBFUNCTIONS PROCESSED
          LDDL   SUBFEA      SUBFUNCTION ENTRIES AVAILABLE
 USP2     UJK    USPX        RETURN (A) = NUMBER OF REQUEST BUFFER ENTRIES

 USP3     STDL   SUBFEA      FAKE A BUFFER EMPTY CONDITION
          UJN    USP2
VIO       SPACE  4,25
**        VIO    VERIFY *IN* AND *OUT* POINTERS
*
*         THE PURPOSE OF THIS ROUTINE IS TO VALIDATE THE READ (OR WRITE)
*         SUBFUNCTION BUFFER POINTERS.
*
*         ENTRY  (A) = ADDRESS OF DIRECT CELL CONTAINING THE *IN* POINTER.
*                (A+1) = ADDRESS OF DIRECT CELL CONTAINING THE *OUT* POINTER.
*                (A+2) = ADDRESS OF DIRECT CELL CONTRINING THE *LIMIT* POINTER.
*
*         EXIT   (A) : STATUS
*                    = 0, OK; IN AND OUT POINTERS VALID.
*                    < 0, ERROR; INVALID BUFFER POINTERS.
*
*
*         IF *IN* .GE.  *LIMIT*  THEN
*           FORMAT INVALID REQUEST RESPONSE.
*         IFEND
*         IF *OUT* .GE.  *LIMIT*  THEN
*           FORMAT INVALID REQUEST RESPONSE.
*         IFEND


 VIO      SUBR               ENTRY/EXIT
          STDL   SCRATCH     SAVE IN POINTER
          ADN    1
          STDL   SCRATCH+1   SAVE OUT POINTER
          ADN    1
          STDL   SCRATCH+2   SAVE LIMIT POINTER
          LDIL   SCRATCH
          SBIL   SCRATCH+2
          PJN    VIO2        IF OUT .GE. LIMIT
          LDIL   SCRATCH+1
          SBIL   SCRATCH+2
          PJN    VIO2        IF IN .GE. LIMIT
          LDIL   SCRATCH
          SBIL   SCRATCH+1   IN - OUT
          PJN    VIOX        RETURN, (A) = AMOUNT OF DATA IN THE BUFFER
          ADIL   SCRATCH+2   ADD LIMIT - FIRST
          SBK    FIRST
          UJN    VIOX        RETURN, (A) = AMOUNT OF DATA IN THE BUFFER

 VIO2     LDK    IEC.50B     INVALID PARAMETER SPECIFICATION
          RJM    FIE         FORMAT INTERFACE ERROR
*         LCN    0
          UJN    VIOX        RETURN, (A) < 0, BUFFER POINTERS INVALID
VSP       SPACE  4,20
**        VSP    VERIFY AND INITIALIZE SUBFUNCTION POINTERS
*
*         THE PURPOSE OF THIS ROUTINE IS TO GENERATE THE SUBFUNCTION BUFFER
*         POINTERS AND VALIDATE THEM.
*
*         ENTRY  (LCMND) = LOGICAL COMMAND.
*                (REQBUF) = CURRENT REQUEST.
*
*         EXIT   (A) : STATUS
*                    => 0, OK; (A) = (SUBFEA) = SUBFUNCTION ENTRIES AVAILABLE
*                    < 0, ERROR; SUBFUNCTION POINTERS INVALID.
*                (SFPTR - SFPTR+2) = POINTER TO SUBFUNCTION BUFFER.
*                (SFOUT) = POINTER TO FWA OF CURRENT SUBFUNCTION.
*
*
*         DETERMINE LIMIT AND FIRST.
*         INITIALIZE IN AND OUT.
*         VERIFY IN AND OUT.
*
*         NOTE   THE BUFFER OFFSET PRESERVED IN *SFPTR+2* IS LARGE
*                ENOUGH SUCH THAT */SD/C.INPTR* AND */SD/C.OUTPTR* CAN
*                BE ACCESSED BY SUBTRACTING THE APPROPRIATE VALUE FROM
*                THE OFFSET.


 VSP      SUBR               ENTRY/EXIT
          LDDL   REQLGTH
          SBK    B.PR+B.SD
          STDL   SFLIMIT     LIMIT = TOTAL LENGTH - REQ. HDR. - SD. HDR.
          LOADCM RESBUF+/PRS/P.RMAOR,,/SD/C.INPTR+C.PR
          STDL   SCRATCH+4   PRESERVE ADDRESS
          CRDL   SCRATCH     READ IN POINTER
          LDDL   SCRATCH
          STDL   MDATF       SAVE MORE DATA FLAG FOR RETRY ALGORITHM
          LDDL   SCRATCH+3
          STDL   SFIN
          LDDL   SCRATCH+4
          ADK    400000B+/SD/C.OUTPTR-/SD/C.INPTR
          CRDL   SCRATCH     READ OUT POINTER
          ADK    C.SD-/SD/C.OUTPTR
          STDL   SFPTR+2     SAVE OFFSET OF POINTER TO SUBFUNCTION BUFFER
          SRD    SFPTR       SAVE R-REGISTER CONTENTS
          LDDL   SCRATCH+3
          STDL   SFOUT
          LDK    SFIN
          RJM    VIO         VERIFY *IN* AND *OUT* POINTERS
          STDL   SUBFEA      SAVE THE NUMBER OF SUBFUNCTION ENTRIES
          UJN    VSPX        RETURN, (A) FROM *VIO* IS THE RETURN STATUS
WRB       SPACE  4,25
**        WRB    WRITE RESPONSE BUFFER
*
*         THE PURPOSE OF THIS ROUTINE IS TO WRITE A PP RESPONSE INTO THE
*         SPECIFIED RESPONSE BUFFER.
*
*         ENTRY  (A) = REPONSE LENGTH IN BYTES.
*                (RBIN) = CURRENT BUFFER IN POINTER.
*                (RBLIMIT) = CURRENT LIMIT POINTER.
*
*         EXIT   (RBIN) = POINTER TO LOCATION FOR NEXT PP RESPONSE.
*
*
*         DETERMINE IF THERE IS A BUFFER WRAP.
*         WRITE FIRST HALF OF RESPONSE INTO THE BUFFER.
*         IF  BUFFER WRAP  THEN
*           WRITE SECOND HALF OF RESPONSE INTO THE BUFFER.
*         IFEND
*         UPDATE THE IN POINTER.


 WRB      SUBR               ENTRY/EXIT
          STDL   SCRATCH     SAVE BUFFER SIZE
          STDL   SCRATCH+3   SAVE BUFFER SIZE FOR WRAP CASE
          LDN    0
          STDL   SCRATCH+1   ASSUME NO WRAP CASE
          LDK    RESBUF
          STML   WRBA        SET WRITE BUFFER TO BEGINNING OF RESPONSE
          LDDL   RBLIMIT
          SBDL   RBIN
          SBDL   SCRATCH     LIMIT - IN - SIZE
          PJN    WRB1        IF NO WRAP CASE
          RADL   SCRATCH     LIMIT - IN
          STDL   SCRATCH+1   SET WRAP CASE FLAG
 WRB1     LDDL   SCRATCH
          SHN    -3
          STDL   SCRATCH+2   SET NUMBER OF CM WORDS TO TRANSFER
          LOADCB RBFIRST,RBIN
          CWML   RESBUF,SCRATCH+2      WRITE RESPONSE TO CENTRAL MEMORY
 WRBA     EQU    *-1
          LDDL   SCRATCH+1
          ZJN    WRB2        IF NOT WRAP CASE
          SHN    -1          CHANGE BYTE COUNT TO PP WORD COUNT
          RAML   WRBA        UPDATE BUFFER POINTER
          LDK    FIRST
          STDL   RBIN        UPDATE IN POINTER
          ERRNZ  FIRST       CODE ASSUMES THE CONSTANT FIRST IS ZERO
          STDL   SCRATCH+1   CLEAR WRAP FLAG
          LDDL   SCRATCH+3
          SBDL   SCRATCH
          STDL   SCRATCH     NUMBER OF BYTES LEFT TO TRANSFER
          UJK    WRB1

 WRB2     LDDL   SCRATCH
          RADL   RBIN        UPDATE IN POINTER
          SBDL   RBLIMIT
          MJN    WRB3        IF NOT END OF BUFFER
          LDK    FIRST
          STDL   RBIN        IN = FIRST
 WRB3     UJK    WRBX
GIO       TITLE  GENERAL I/O ROUTINES
**        GENERAL I/O ROUTINES
*
*         THE FOLLOWING ROUTINES PERFORM THE VARIOUS I/O FUNCTIONS THAT ARE
*         UTILIZED BY THE VARIOUS ROUTINES.
FAI       SPACE  4,30
**        FAI    FUNCTION THE CHANNEL AND INPUT DATA
*
*         THE PURPOSE OF THIS ROUTINE IS TO FUNCTION THE NAD AND INPUT
*         A STATUS BYTE WHEN THE CHANNEL GOES FULL.
*
*         ENTRY  (A) = NAD FUNCTION TO ISSUE.
*
*         EXIT   (A) : STATUS
*                    => 0, COMPLETE; (A) = DATA READ FROM CHANNEL.
*                    < 0, NAD ERROR; (A) = COMPLEMENTED NAD ERROR CODE.
*
*         ISSUE NAD FUNCTION.
*         IF  FUNCTION ACCEPTED  THEN
*           ACTIVATE CHANNEL.
*           REPEAT
*             TEST CHANNEL FULL FLAG.
*           UNTIL  CHANNEL FULL
*                OR TIMER EXPIRED
*           IF  TIMER EXPIRED  THEN
*             IF  CHANNEL INACTIVE  THEN
*               RETURN, CHANNEL INACTIVE AFTER ACTIVATE ERROR.
*             ELSE
*               RETURN, DATA TIMEOUT ERROR.
*             IFEND
*           ELSE
*             INPUT BYTE FROM CHANNEL INTO A-REGISTER.
*           IFEND
*         IFEND


 FAI      SUBR               ENTRY/EXIT
          RJM    FUN         ISSUE NAD FUNCTION
          MJN    FAIX        IF ERROR ENCOUNTERED
          ACN    CH+40B
          LCN    0
 FAI1     FJM    FAI3,CH     IF CHANNEL FULL
          SBN    1
          NJN    FAI1        IF TIMER NOT EXPIRED
          IJM    FAI2,CH     IF CHANNEL IS INACTIVE
          LDC    -NE.DTO
          UJN    FAIX        RETURN, DATA TIMEOUT ERROR

 FAI2     LCN    NE.CIA
          UJN    FAIX        RETURN, CHANNEL INACTIVE AFTER ACTIVATE ERROR

 FAI3     IAN    CH+40B      INPUT STATUS BYTE
          DCN    CH+40B
          SFM    FAI4,CH     IF CHANNEL ERROR DURING TRANSFER
          UJN    FAIX        RETURN, (A) = DATA INPUT FROM CHANNEL

 FAI4     LDC    -NE.CPE
          UJN    FAIX        RETURN, CHANNEL PARITY ERROR
FUN       SPACE  4,30
**        FUN    FUNCTION NAD
*
*         THE PURPOSE OF THIS ROUTINE IS TO ISSUE A FUNCTION TO THE NAD
*         AND WAIT FOR THE NAD TO ACCEPT THE FUNCTION.
*
*         ENTRY  (A) = FUNCTION TO ISSUE.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; FUNCTION ACCEPTED.
*                    < 0, NAD ERROR; (A) = COMPLEMENTED NAD ERROR CODE.
*
*
*         IF  CHANNEL NOT RESERVED  THEN
*           RESERVE CHANNEL.
*         IFEND
*         IF  NAD IS AVAILABLE FOR USE   THEN
*           ISSUE FUNCTION TO NAD.
*           REPEAT
*             CHECK CHANNEL ACTIVE FLAG.
*           UNITL  CHANNEL INACTIVE (FUNCTION ACCEPTED)
*               OR TIMER EXPIRED
*           IF  NAD ACCEPTED THE FUNCTION  THEN
*             RETURN NORMAL STATUS.
*           ELSE
*             RETURN FUNCTION TIMEOUT STATUS.
*           IFEND
*         IFEND


 FUN      SUBR               ENTRY/EXIT
          IF     DEF,NDI0
          STML   FUNA        PLUG NAD AND S0 CONVERTER FUNCTION
          ELSE
 FUNB     STM    FUNA        PLUG NAD FUNCTION
*         STML   FUNA        PLUG NAD AND CIO CONVERTER FUNCTION
          ENDIF
          LDDL   CHANRES
          LMK    FALSE
          NJN    FUN1        IF CHANNEL ALREADY RESERVED
          RJM    RES         RESERVE NAD CHANNEL
          MJN    FUNX        IF CHANNEL WAS DECLARED DOWN
 FUN1     DCN    CH+40B      MAKE SURE CHANNEL IS DISCONNECTED
          FNC    **,CH+40B
 FUNA     EQU    *-1         USED TO PLUG NAD FUNCTION
          LCN    0
 FUN2     IJM    FUN3,CH     IF NAD FUNCTION ACCEPTED
          SBN    1
          NJN    FUN2        IF TIMER HAS NOT EXPIRED
          LDC    -NE.FTO
          UJK    FUNX        RETURN, FUNCTION TIMEOUT ERROR

 FUN3     LDN    0
          UJK    FUNX        RETURN, FUNCTION ACCEPTED
ICF       SPACE  4,25
**        ICF    ISSUE CONTROLWARE FUNCTION
*
*         THE PURPOSE OF THIS ROUTINE IS TO ISSUE A NAD CONTROLWARE FUNCTION
*         AND OBTAIN THE NAD CONTROLWARE RESPONSE.
*
*         INPUT  (A) = CONTROLWARE FUNCTION TO ISSUE.
*
*         OUTPUT (A) : STATUS
*                    => 0, COMPLETE; (A) = CONTROLWARE RESPONSE  .LMK.  N
*                                    (CWSTAT) = CURRENT CONTROLWARE STATUS.
*                    < 0, NAD ERROR; (A) = COMPLEMENTED NAD ERROR CODE.
*
*
*         FUNCTION NAD.
*         IF  FUNCTION ACCEPTED  THEN
*           REPEAT
*             GET CONTROLWARE STATUS.
*           UNTIL  CONTROLWARE HAS RESPONDED
*                  OR TIME LIMIT EXCEEDED
*                  OR ERROR ENCOUNTERED
*         IFEND


 ICF      SUBR               ENTRY/EXIT
          LMK    NF.FF       SET CONTROLWARE FUNCTION FLAG
          STM    ICFA        PRESERVE LAST CONTROLWARE FUNCTION
          RJM    FUN         ISSUE CONTROLWARE FUNCTION
          MJN    ICFX        IF NAD ERROR
          LCN    0
          STDL   NRTIMER
 ICF1     RJM    OCS         OBTAIN CONTROLWARE STATUS
          MJN    ICFX        IF NAD ERROR
          SHN    17-NRF.HF
          MJN    ICF3        IF NAD HARDWARE FAULT
          SHN    17-NRF.FF-17+NRF.HF
          PJN    ICF4        IF CONTROLWARE RESPONSE AVAILABLE
          SODL   NRTIMER
          NJN    ICF1        IF TIMER HAS NOT EXPIRED
          LDC    -NE.FFT
 ICF2     UJN    ICFX        RETURN, FLAG FUNCTION TIMEOUT

 ICF3     LCN    NE.HWF
          UJN    ICF2        RETURN, NAD HARDWARE FAULT

 ICF4     LDDL   CWSTAT      RETURN CONTROLWARE STATUS
          LPK    NR.RM       MASK OUT RESPONSE FLAGS
          LMK    NR.AK
          UJN    ICF2        RETURN, FUNCTION RESPONSE AVAILABLE

 ICFA     CON    0           LAST CONTROLWARE FUNCTION ISSUED
IFC       SPACE  4,30
**        IFC    INPUT FROM CHANNEL
*
*         THE PURPOSE OF THIS ROUTINE IS TO INPUT A BLOCK OF DATA FROM THE
*         NAD.
*
*         ENTRY  (WTOXFR) = AMOUNT OF DATA TO RECEIVE.
*                (IFCA) = FWA OF BUFFER TO RECEIVE DATA.
*
*         EXIT   (A) : STATUS
*                    > 0, COMPLETE; (A) = (BYTXFR) = AMOUNT OF DATA RECEIVED.
*                    < 0, NAD ERROR; (A) = COMPLEMENTED ERROR CODE.
*                (WTOXFR) = AMOUNT OF DATA TO RECEIVE.
*
*
*         WAIT FOR PRIMED.
*         IF   PRIMED BIT SET   THEN
*           SET DI ASSEMBLY/DISASSEMBLY FUNCTION.
*           IF  FUNCTION ACCEPTED  THEN
*             INPUT DATA FROM CHANNEL.
*             GET FINAL CONTROLWARE STATUS.
*           IFEND
*         IFEND


 IFC      SUBR               ENTRY/EXIT
          RJM    WFP         WAIT FOR PRIMED
          MJN    IFCX        IF NAD ERROR
          LDK    DI.IB
          RJM    FUN         SELECT BIT STRING ASSEMBLY/DISASSEMBLY MODE
          MJN    IFCX        IF NAD ERROR
          ACN    CH+40B
          LCN    0
 IFC1     FJM    IFC4,CH     IF CHANNEL IS FULL
          SBN    1
          NJN    IFC1        IF TIMER HAS NOT EXPIRED
          IJM    IFC2,CH     IF CHANNEL IS INACTIVE
          LDC    -NE.DTO
          UJN    IFCX        RETURN, DATA TIMEOUT ERROR

 IFC2     LCN    NE.CIA
 IFC3     UJN    IFCX        RETURN, CHANNEL INACTIVE AFTER ACTIVATE ERROR

 IFC4     LDDL   WTOXFR
          IF     DEF,NDI0
          IAM    *,CH        INPUT BLOCK FROM CHANNEL
          ELSE
          IAPM   *,CH        INPUT BLOCK FROM CHANNEL
          ENDIF
 IFCA     EQU    *-1         FWA OF DATA BUFFER
          STDL   BYTXFR      SAVE NUMBER OF BYTES NOT RECEIVED
          LDDL   LCMND+/LCF/P.FLUSH
          SHN    17-15+/LCF/L.FLUSH
          PJN    IFC6        IF FLUSH FLAG NOT SET
 IFC5     IJM    IFC6,CH     IF CHANNEL IS INACTIVE
          IF     DEF,NDI0
          LDN    3
          IAM    SCRATCH+1,CH          REMOVE EXCESS DATA
          ELSE
          LDN    4
          IAPM   SCRATCH+1,CH          REMOVE EXCESS DATA
          ENDIF
          ZJN    IFC5        IF FLUSH NOT DONE
 IFC6     DCN    CH+40B
          SFM    IFC9,CH     IF CHANNEL ERROR DURING TRANSFER
          RJM    OHS         OBTAIN HARDWARE STATUS
          MJN    IFC3        IF HARDWARE STATUS WAS NOT OBTAINED
          SCN    M.NHFPS+M.NHFPA      IGNORE PROCESSOR STOPPED AND ABNORMAL
          NJN    IFC7        IF HARDWARE FAULT ENCOUNTERED
          RJM    CBT         COMPUTE THE NUMBER OF BYTES TRANSFERRED
          NJN    IFC3        RETURN, (A) = AMOUNT OF DATA RECEIVED
          LCN    NE.ITE
          UJN    IFC3        RETURN, INPUT TRANSFER ERROR

 IFC7     RJM    CBT         COMPUTE THE BYTES TRANSFERRED FOR ERROR PROCS
          LCN    NE.HWF
 IFC8     UJK    IFC3        RETURN, NAD HARDWARE FAULT

 IFC9     LDC    -NE.CPE
          UJK    IFC8        RETURN, CHANNEL PARITY ERROR
IUC       SPACE  4,30
**        IUC    ISSUE UNIVERSAL COMMAND.
*
*         ENTRY  (UNCB) = UNIVERSAL COMMAND BLOCK.
*
*         EXIT   (A) : STATUS
*                    => 0, NORMAL; (A) = NAD RESPONSE .LMK. NR.AK.
*                    < 0, NAD ERROR; (A) = COMPLEMENTED NAD ERROR CODE.
*
*         ISSUE UNIVERSAL COMMAND.
*         IF  COMMAND ACCEPTED  THEN
*           SEND COMMAND BLOCK TO THE NAD.
*           IF  COMMAND BLOCK SENT SUCCESSFULLY  THEN
*             REPEAT
*               GET CONTROLWARE STATUS.
*             UNTIL   RESPONSE AVAILABLE
*                  OR TIMER EXPIRED
*             IF  TIMER EXPIRED  THEN
*               RETURN ERROR STATUS
*             IFEND
*           IFEND
*         IFEND


 IUC      SUBR               ENTRY/EXIT
          LDK    NF.UC
          RJM    ICF         ISSUE UNIVERAL COMMAND
          MJN    IUCX        IF NAD ERROR
          LMK    NR.UA&NR.AK
          ZJN    IUC2        IF COMMAND ACCEPTED
          LCN    NE.IVR      INVALID NAD RESPONSE
 IUC1     UJN    IUCX

 IUC2     LDK    UC.CBLC
          STDL   WTOXFR      CHANNEL WORDS TO TRANSFER
          LDML   UNCB+UCB.SF
          SHN    -8
          STML   ICFA        SAVE SUB-FUNCTION FOR ERROR PROCESSING
          LDC    UNCB
          STML   OOCA        FWA OF BUFFER
          RJM    OOC         OUTPUT DATA ON CHANNEL
          MJN    IUCX        IF TRANSFER ERROR
          LCN    0
          STDL   NRTIMER
 IUC3     RJM    OCS         OBTAIN CONTROLWARE STATUS
          MJN    IUCX        IF NAD ERROR
          LPK    NR.RM
          LMK    NR.UA
          NJN    IUC4        IF RESPONSE AVAILABLE
          SODL   NRTIMER
          NJN    IUC3        IF TIMER HAS NOT EXPIRED
          LDC    -NE.UTO
          UJN    IUC1        RETURN, UNIVERSAL COMMAND TIMEOUT

 IUC4     LMK    NR.AK&NR.UA
          UJK    IUC1        RETURN, (A) = NAD RESPONSE  .LMK.  NR.AK.
OCS       SPACE  4,25
**        OCS    OBTAIN NAD CONTROLWARE STATUS
*
*         THE PURPOSE OF THIS REQUEST IS TO OBTAIN THE CURRENT NAD CONTROLWARE
*         STATUS.
*
*         EXIT   (A) : STATUS
*                    => 0, COMPLETE; (A) = (CWSTAT) = CONTROLWARE STATUS.
*                    < 0, NAD ERROR; (A) = COMPLEMENTED NAD ERROR CODE.
*
*         ISSUE NAD CONTROLWARE STATUS FUNCTION AND INPUT DATA.
*         IF  NO ERROR  THEN
*           SAVE CONTROLWARE STATUS.
*         IFEND



 OCS      SUBR               ENTRY/EXIT
          LCN    0
          STDL   CWSTAT      (-0) IS AN INVALID STATUS
          LDK    DI.CS       OBTAIN CONTROLWARE STATUS
          RJM    FAI         FUNCTION CHANNEL AND INPUT DATA
          MJN    OCSX        IF NAD ERROR OR CHANNEL IS NOT USABLE
          STDL   CWSTAT      SAVE CONTROLWARE STATUS
          UJN    OCSX        RETURN, CONTROLWARE STATUS OBTAINED
OHS       SPACE  4,25
**        OHS    OBTAIN NAD HARDWARE STATUS
*
*         THE PURPOSE OF THIS REQUEST IS TO OBTAIN THE CURRENT NAD HARDWARE
*         STATUS.
*
*         EXIT   (A) : STATUS
*                    => 0, COMPLETE; (A) = HARDWARE STATUS.
*                    < 0, NAD ERROR; (A) = COMPLEMENTED NAD ERROR CODE.
*
*         ISSUE NAD HARDWARE STATUS FUNCTION AND WAIT FOR DATA.
*         IF  NO ERROR  THEN
*           SAVE HARDWARE STATUS.
*         IFEND


 OHS      SUBR               ENTRY/EXIT
          LCN    0
          STML   RESDS+/RDS/P.LHWS     (-0) IS AN INVALID STATUS
          LDK    DI.HS       OBTAIN HARDWARE STATUS
          RJM    FAI         FUNCTION CHANNEL AND INPUT DATA
          MJN    OHSX        IF NAD ERROR OR CHANNEL IS NOT USABLE
          STML   RESDS+/RDS/P.LHWS
          UJN    OHSX        RETURN, HARDWARE STATUS OBTAINED
OOC       SPACE  4,30
**        OOC    OUTPUT ON CHANNEL
*
*         THE PURPOSE OF THIS ROUTINE IS TO SEND A BLOCK OF DATA ACROSS THE
*         CHANNEL TO THE NAD.
*
*         ENTRY  (WTOXFR) = AMOUNT OF DATA TO SEND.
*                (OOCA) = FWA OF BUFFER CONTAINING THE DATA.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; ALL DATA SUCCESSFULLY SENT.
*                    < 0, NAD ERROR; (A) = COMPLEMENTED NAD ERROR CODE.
*                (WTOXFR) = AMOUNT OF DATA TO SEND.
*
*
*         WAIT FOR PRIMED.
*         IF   PRIMED BIT SET   THEN
*           SET DI ASSEMBLY/DISASSEMBLY FUNCTION.
*           IF  FUNCTION ACCEPTED  THEN
*             OUTPUT DATA ON CHANNEL.
*             GET FINAL CONTROLWARE STATUS.
*           IFEND
*         IFEND


 OOC      SUBR               ENTRY/EXIT
          RJM    WFP         WAIT FOR PRIMED
          MJN    OOCX        IF NAD ERROR
          LDK    DI.OB
          RJM    FUN         SELECT BIT STRING ASSEMBLY/DISASSEMBLY MODE
          MJN    OOCX        IF NAD ERROR
          ACN    CH+40B
          LDDL   WTOXFR
          IF     DEF,NDI0
          OAM    *,CH        OUTPUT BLOCK ON CHANNEL
          ELSE
          OAPM   *,CH        OUTPUT BLOCK ON CHANNEL
          ENDIF
 OOCA     EQU    *-1         FWA OF DATA BUFFER
          STDL   BYTXFR      SAVE NUMBER OF WORDS NOT SENT
          IF     DEF,NDI0
          LCN    0
 OOC0.3   EJM    OOC0.5,CH   IF CHANNEL EMPTY
          SBN    1
          NJN    OOC0.3      IF TIMER HAS NOT EXPIRED
          LDC    -NE.DTO
 OOC0.4   UJN    OOCX        RETURN, DATA TIMEOUT ERROR

 OOC0.5   DCN    CH+40B      MAKE SURE CHANNEL IS DISCONNECTED
          ELSE
          DCN    CH+40B      MAKE SURE CHANNEL IS DISCONNECTED
          ENDIF
          SFM    OOC3,CH     IF CHANNEL ERROR DURING TRANSFER
          RJM    OHS         OBTAIN HARDWARE STATUS
          MJN    OOCX        IF HARDWARE STATUS UNAVAILABLE
          SCN    M.NHFPS+M.NHFPA       IGNORE PROCESSOR STOPPED AND ABNORMAL
          NJN    OOC2        IF HARDWARE FAULT ENCOUNTERED
          LDDL   BYTXFR
          IF     DEF,NDI0
          ZJK    OOC0.4      IF TRANSFER SUCCESSFUL
          ELSE
          ZJK    OOCX        IF TRANSFER SUCCESSFUL
          ENDIF
          RJM    CBT         COMPUTE BYTES TRANSFERRED FOR ERROR PROCS
          LCN    NE.OTE      RETURN, OUTPUT TRANSFER ERROR
 OOC1     UJK    OOCX

 OOC2     RJM    CBT         COMPUTE BYTES TRANSFERRED FOR ERROR PROCS
          LCN    NE.HWF
          UJN    OOC1        RETURN, HARDWARE FAULT ERROR

 OOC3     LDC    -NE.CPE
          UJN    OOC1        RETURN, CHANNEL PARITY ERROR
PEP       SPACE  4,25
**        PEP    PERFORM ERROR PROCESSING
*
*         THE PURPOSE OF THIS ROUTINE IS TO OBTAIN THE NECESSARY DATA FOR
*         ERROR LOGGING AND RETRY PROCESSING.
*
*         ENTRY  (A) = ERROR ENCOUNTERED.
*
*         EXIT   DETAILED STATUS SET UP.
*
*
*         IF  NAD IS NOT FLAGGED AS UNUSABLE  THEN
*           PRESERVE LAST CONTROLWARE FUNCTION.
*           PRESERVE LAST HARDWARE FUNCTION.
*           IF  NOT ABNORMAL RESPONSE  THEN
*             OBTAIN CONTROLWARE STATUS.
*           IFEND
*           IF  CONTROLWARE STATUS SHOWS A HARDWARE FAULT  THEN
*             OBTAIN THE HARDWARE STATUS.
*             SET NAD UNUSABLE FLAG.
*           IFEND
*         IFEND
*
*         NOTE   IF THE CONTROLWARE STATUS OR THE HARDWARE STATUS IS
*                UNAVAILABLE, A VALUE OF 177777B IS RETURNED IN THE
*                CORRESPONDING DETAILED STATUS FIELD.


 PEP      SUBR               ENTRY/EXIT
          LMK    777777B
          STML   RESBUF+/PRS/P.FTO     SET ABNORMAL STATUS FLAG
          IF     DEF,NPDR
          LMK    NE.CPE
          NJN    PEP0.2     IF NOT CHANNEL PARITY ERROR
 PEPB     UJN    PEP0.2     IF NOT CIO TYPE OF CHANNEL
*         PSN               IF CIO TYPE OF CHANNEL

          LDK    .STML      SET FOR 16 BIT FUNCTIONS
          STML   FUNB
          LDC    F.RDESR    READ ERROR STATUS REGISTER
          RJM    FUN
          ZJN    PEP0.0     IF NO ERROR ON FUNCTION
          LCN    0
          UJN    PEP0.1

 PEP0.0   ACN    CH+40B
          IAN    CH
          DCN    CH+40B
 PEP0.1   STM    RESBUF+/PRS/P.IEC    RETURN CIO STATUS
          LDK    .STM       SET FOR 12 BIT FUNCTIONS
          STML   FUNB
          UJN    PEP1

 PEP0.2   LMC    NE.CHD&NE.CPE

          ELSE
          LMK    NE.CHD
          ENDIF

          NJN    PEP1        IF NOT CHANNEL DOWN ERROR
          LJM    PEP10       SEND ABNORMAL RESPONSE TO CLEAR REQUEST

 PEP1     LDML   ICFA
          STML   RESDS+/RDS/P.LCWF     LAST CONTROLWARE FUNCTION
          LDML   FUNA
          STML   RESDS+/RDS/P.LHWF     LAST NAD FUNCTION
          LMK    DI.CS
          ZJN    PEP2        IF LAST FUNCTION WAS GET CONTROLWARE STATUS
          RJM    OCS         OBTAIN CONTROLWARE STATUS
 PEP2     LDDL   CWSTAT
          STML   RESDS+/RDS/P.LCWS     LAST CONTROLWARE STATUS
          SHN    17-NRF.HF
          PJN    PEP6        IF NO HARDWARE FAULT ENCOUNTERED
          LDML   RESDS+/RDS/P.LHWF     LAST NAD FUNCTION
          LMK    DI.HS
          ZJN    PEP5        IF LAST FUNCTION WAS GET HARDWARE STATUS
          RJM    OHS         OBTAIN HARDWARE STATUS
 PEP5     LDML   RESDS+/RDS/P.LHWS
          SHN    17-NHF.PS
          PJN    PEP6        IF NAD PROCESSOR STILL RUNNING
          RJM    SDD         SET DEVICE DOWN
          UJN    PEP9        RETURN DEVICE UNAVAILABLE

 PEP6     LDK    DI.MC
          RJM    FUN         MASTER CLEAR INTERFACE
          LDK    DI.CE
          RJM    FUN         CLEAR PARITY ERROR
          LDC    **          CLEAN-UP REQUEST (IF ANY)
 PEPA     EQU    *-1         SET WHEN FUNCTION IS DETERMINED
          ZJN    PEP9        IF NO CLEAN-UP REQUEST TO ISSUE
          LMN    2
          ZJN    PEP7        IF RESET REQUEST IS NEEDED
          LDK    NF.AB       ISSUE ABORT FUNCTION TO NORMALIZE THE NAD
          UJN    PEP8        ABORT CURRENT TRANSFER

 PEP7     LDK    NF.RT       RESET CURRENT BUFFER POINTERS
 PEP8     RJM    ICF         ISSUE CONTROLWARE FUNCTION
 PEP9     LDK    B.RDS
          RAML   RESBUF+/PRS/P.RL      SET LENGTH TO INCLUDE DETAILED STATUS
          LDK    CC.DSA*10000B         SET DETAILED STATUS RETURNED FLAG
 PEP10    ADK    RT.ABN*40000B         ABNORMAL RESPONSE
          STML   RESBUF+/PRS/P.RTYPE
          LCN    0
          UJK    PEPX        RETURN, (A) < 0 DETAILED STATUS SET UP
WFP       SPACE  4,20
**        WFP    WAIT FOR PRIMED
*
*         THE PURPOSE OF THIS REQUEST IS TO WAIT FOR THE NAD TO PRIME THE
*         CHANNEL FOR A DATA TRANSFER.
*
*         ENTRY  AN I/O REQUEST HAS BEEN SUCCESSFULLY ISSUED.
*
*         EXIT   (A) : STATUS
*                    = 0, COMPLETE; NAD PRIMED FOR INPUT.
*                    < 0, ERROR; (A) = COMPLEMENTED NAD ERROR CODE.
*
*         REPEAT
*           OBTAIN NAD CONTROLWARE STATUS.
*         UNTIL   AN ERROR IS ENCOUNTERED
*              OR THE PRIMED TIMER EXPIRED
*              OR THE NAD IS PRIMED FOR I/O


 WFP      SUBR               ENTRY/EXIT
          LCN    0
          STDL   NRTIMER
 WFP1     RJM    OCS         OBTAIN CONTROLWARE STATUS
          MJN    WFPX        IF CONTROLWARE ERROR
          SHN    17-NRF.PF
          MJN    WFP2        IF PRIMED FLAG IS SET
          SODL   NRTIMER
          PJN    WFP1        IF TIMER HAS NOT EXPIRED
          LCN    NE.PTO
          UJN    WFPX        RETURN, PRIME TIMEOUT ERROR

 WFP2     LDN    0
          UJN    WFPX        RETURN, PRIMED FOR I/O
          SPACE  4,10
 BUFFER   EQU    *
          ERRMI  7777B-BUFFER-MAXBYTES/2-3
IPD       TITLE  IPD - INITIALIZE PP DRIVER.
**        IPD    INITIALIZE PP DRIVER
*
*         THE PURPOSE OF THIS ROUTINE IS TO FIND THE CORRESPONDING CENTRAL
*         MEMORY TABLES AND INTIALIZE THE INTERNAL PP DRIVER POINTERS.
*
*         ENTRY  (PITADDR - PITADDR+1) = FWA OF PP INTERFACE TABLE.
*
*         EXIT   ALL STATIC POINTERS ARE SET UP.
*                ALL STATIC VARIABLES ARE SET UP.
*                ALL REQUIRED DYNAMIC VARIABLES ARE INITIALIZED.
*                (PPSTATE) = PP.IDLE.
*
*         REPEAT
*           SET UP RESPONSE BUFFER POINTERS.
*           IF  RESPONSE POINTERS ARE VALID   THEN
*             SET UP PP INTERFACE TABLE POINTERS.
*             IF  INVALID PP INTERFACE TABLE  THEN
*               POST ERROR RESPONSE.
*             ELSE
*               SET UP UNIT INTERFACE TABLE POINTERS.
*               IF  INVALID UNIT INTERFACE TABLE  THEN
*                 POST ERROR RESPONSE.
*               ELSE
*                 INITIALIZE MISCELLANEOUS VARIABLES.
*               IFEND
*             IFEND
*           IFEND
*           IF  ANY ERROR WAS ENCOUNTERED   THEN
*             DELAY TO ALLOW THE CPU PROGRAMS TO CORRECT THE PROBLEM.
*           IFEND
*         UNTIL   ALL POINTERS ARE INITIALIZED
*         SET PP STATE TO *IDLE*.


 IPD      SUBR               ENTRY/EXIT
          IF     DEF,NPDR
          RJM    ILC         INITIALIZE LOOP COUNTERS
          ENDIF
 IPD1     RJM    SRB         SET UP PP RESPONSE BUFFER POINTERS
          NJN    IPD3        IF INVALID (OR BUFFER NOT EMPTY)
          RJM    SPT         SET UP PP INTERFACE TABLE POINTERS
          NJN    IPD2        IF PP INTERFACE TABLE INVALID
          RJM    SUT         SET UP UNIT INTERFACE TABLE POINTERS
          NJN    IPD2        IF INVALID UNIT INTERFACE TABLE ENCOUNTERED
*         LDN    0
          STDL   PPFRC       INITIALIZE THE PP FREE RUNNING CLOCK
          LDK    FALSE
          STDL   CHANRES     NO CHANNEL RESERVED
          LDN    2
          STDL   TWO         CONSTANT TWO
          LDK    PP.IDLE
          STDL   PPSTATE     SET INITIAL PP STATE TO IDLE
          IF     DEF,NPDR
          RJM    ICH         INITIALIZE CIO/IOU HARDWARE
          MJN    IPD2        IF CIO HARDWARE INITIALIZATION ERROR
          ENDIF
          RJM    CPR         CHECK FOR PP RELOAD
          UJN    IPDX

 IPD2     LDN    0           NO INTERLOCK TO OBTAIN
          RJM    SRP         SEND PP RESPONSE
 IPD3     LDK    INTERDY     DELAY FOR A WHILE
 IPD4     SBN    1
 IPDA     EQU    *-1         CHANGED TO *SBN 2* FOR 2XPP
          NJN    IPD4
*
*         WHEN MORE FAULT TOLERANT CODE IS EMPLOYED IN THE CPU,
*         RETRYING MAY BE A VIABLE OPTION.  FOR NOW THE PP IS HUNG.
*
*         UJK    IPD1        RECHECK VALIDITY OF PP TABLES
*
          UJN    IPD3
          IF     DEF,NPDR
ICH       SPACE  4,10
**        ICH    INITIALIZE IOU HARDWARE BASED ON IOU HARDWARE TYPE
*
*         THE PURPOSE OF THIS ROUTINE IS TO INITIALIZE THE CONCURRENT CHANNEL
*         HARDWARE.  OTHER TYPES DO NOT NEED INITIALIZATION.
*
*         ENTRY  INTPIT MUST BE VALID
*                CURCHAN MUST BE INITIALIZED
*
*         EXIT   (A) >= 0, IF NO ERROR
*                (A) < 0, IF ERROR
*
*         SAVE FLAG TO INDICATE CONCURRENT CHANNEL IOU.
*         INITIALIZE THE CONCURRENT CHANNEL HARDWARE
*


 ICH      SUBR
          LOADCM INTPIT+/PIT/P.CIT
          ADDL   CURCHAN     CURRENT CHANNEL
          ADN    32
          CRDL   SCRATCH     READ CHANNEL TYPE TABLE
          LDDL   SCRATCH
          SHN    17-15
          PJN    ICHX        IF NOT CIO TYPE CHANNEL
          LDK    .PSN        PASS INSTRUCTION
          STML   PEPB        SET CONCURRENT CHANNEL HARDWARE TYPE FLAG
          LDK    .STML       STML INSTRUCTION
          STML   FUNB        SET CONCURRENT CHANNEL HARDWARE TYPE FLAG
          LDK    F.MCLEAR    MASTER CLEAR ERROR STATUS REGISTERS
          RJM    FUN
          ZJN    ICH2        IF NO ERROR ON FUNCTION
 ICH1     LDK    IEC.503     CIO HARDWARE ERROR
          STML   RESBUF+/PRS/P.IEC               INTERFACE ERROR CODE
          LDK    B.PRS
          STML   RESBUF+/PRS/P.RL                RESPONSE LENGTH
          LDN    1
          SHN    16-/PRS/L.INTERR-/PRS/N.INTERR
          STML   RESBUF+/PRS/P.INTERR            ABNORMAL STATUS
          LDK    RT.UNS
          SHN    16-/PRS/L.RTYPE-/PRS/N.RTYPE
          ADK    URC.IE
          STML   RESBUF+/PRS/P.URC               UNSOLICITED RESPONSE
          RJM    REL
          LDK    .STM        STM  INSTRUCTION
          STML   FUNB
          LCN    0           RETURN, INTERFACE ERROR
          UJN    ICH3

 ICH2     LDK    F.WRCR      WRITE CONTROL REGISTERS
          RJM    FUN
          NJN    ICH1        IF CHANNEL ERROR
          ACN    CH+40B
          LDK    ICHC        CIO INITIALIZE FUNCTION
          OAN    CH
          DCN    CH+40B
          RJM    REL
          LDK    .STM        STM INSTRUCTION
          STML   FUNB        SET CONCURRENT CHANNEL HARDWARE TYPE FLAG
          LDN    0
 ICH3     LJM    ICHX        EXIT

 ICHC     EQU    400B        VALUE FOR CONTROL REGISTER (CIO ONLY)

ILC       SPACE  4,10
**        ILC    INITIALIZE LOOP COUNTERS BASED ON PP SPEED.
*
*         THE PURPOSE OF THIS ROUTINE IS TO INITIALIZE ALL
*         TIMERS IN THE PP TO PROVIDE CONSISTENT TIMING BETWEEN
*         2XPP AND 4XPP.
*
*         ENTRY  NONE.
*
*         EXIT
*
*         DETERMINE PP SPEED
*         IF  2XPP  THEN
*           SET COUNTERS TO DECREMENT BY 2 INSTEAD OF 1.
*         IFEND
*
*         NOTE   12-BIT STORE AND LOAD INSTRUCTIONS ARE USED
*                IN THIS ROUTINE TO SUPPORT BOTH 12-BIT AND 16-BIT
*                MICROSECOND CLOCK CHANNELS.


 ILC      SUBR
          IAN    14B         GET MICROSECOND CLOCK
          STD    SCRATCH
          LDC    500
 ILC1     SBN    1
          NJN    ILC1        IF TIMER NOT COMPLETE
          IAN    14B         GET CURRENT TIME
          STD    SCRATCH+1
          LDD    SCRATCH+1
          SBD    SCRATCH

*         THESE TIMES SHOULD NEVER BE EQUAL.

          PJN    ILC2        IF CLOCK DID NOT WRAP
          ADC    7777B       COMPUTE THE ACTUAL CLOCK DIFFERENCE
 ILC2     ADC    -400
          MJN    ILCX        IF THE TIME < 400 MICS THEN SHOULD BE 4XPP
          LDK    .SBN+2      SWITCH TO DECREMENT BY 2 FOR 2XPP
          STML   MCMA
          STML   RESA
          STML   SRPA
          STML   IPDA
          LDC    RESTO/2
          STML   CRTA        CHANGE CLOCK TIMER
          UJK    ILCX
          ENDIF
SRB       SPACE  4,25
**        SRB    SET UP RESPONSE BUFFER POINTERS
*
*         THE PURPOSE OF THIS ROUTINE IS TO VERIFY THAT THE PP RESPONSE
*         BUFFER POINTERS ARE VALID AND THEN INITIALIZE THE CORRESPONDING
*         VARIABLES.
*
*         ENTRY  (PITADDR - PITADDR+1) = FWA OF PP INTERFACE TABLE.
*
*         EXIT   (A) : STATUS
*                    > 0, RESPONSE BUFFER NOT EMPTY
*                    = 0, RESPONSE POINTERS VALID AND VARIABLES
*                         INITIALIZED.
*                    < 0, RESPONSE POINTERS INVALID.
*                (INTPIT) = PP INTERFACE TABLE.
*
*
*         OBTAIN *FIRST* AND *LIMIT* POINTERS.
*         IF  *LIMIT* IS VALID  THEN
*           OBTAIN *IN* AND *OUT* POINTERS.
*           VERIFY *IN* AND *OUT* POINTERS.
*         IFEND


 SRB      SUBR               ENTRY/EXIT
          LDK    C.PIT
          STDL   SCRATCH     LENGTH OF PP INTERFACE TABLE
          LDDL   PITADDR+1
          ADK    /PIT/C.PQLOCK*8
          STML   PPRQIL+1    PP REQUEST QUEUE INTERLOCK POINTER
          SHN    -16
          ADDL   PITADDR
          STML   PPRQIL
          LOADCM PITADDR
          STDL   PITADDR+2
          CRML   INTPIT,SCRATCH        READ RESPONSE BUFFER POINTERS
          SRD    PITADDR               SAVE THE REFORMATTED PIT ADDRESS
          LOADCM INTPIT+/PIT/P.RBRMA   FORMAT CM ADDRESS POINTER
          STDL   RBFIRST+2             SAVE ADDRESS OFFSET
          SRD    RBFIRST               SAVE R-REGISTER CONTENTS
          LDML   INTPIT+/PIT/P.RBLIM
          STDL   RBLIMIT
          SBK    P.PRS+8
          MJN    SRBX        IF RESPONSE BUFFER SIZE INADEQUATE
          LDML   INTPIT+/PIT/P.RBIN
          STDL   RBIN
          LDML   INTPIT+/PIT/P.RBOUT
          STDL   RBOUT
          LDK    RBIN
          RJM    VIO         VERIFY IN AND OUT POINTERS

*         RETURN THE RESPONSE FROM *VIO*

          UJK    SRBX
SPT       SPACE  4,30
**        SPT    SET UP PP INTERFACE POINTERS
*
*         THE PURPOSE OF THIS ROUTINE IS TO INITIALIZE THE VARIABLES WHICH
*         POINT TO THE STATIC TABLES POINTED TO BY THE PP INTERFACE TABLE.
*
*         ENTRY  (INTPIT) = PP INTERFACE TABLE.
*
*         EXIT   (A) : STATUS
*                    =  0, ENTRIES VALID AND VARIABLES INITIALIZED.
*                    <  0, THE PPIT IS NOT VALID AND AN ABNORMAL
*                          RESPONSE HAS BEEN CREATED.
*
*
*         INITIALIZE INTERRUPT REGISTER POINTER.
*         INITIALIZE CHANNEL INTERLOCK TABLE POINTER.
*         INITIALIZE PP REQUEST QUEUE POINTER.
*         INITIALIZE NUMBER OF UNITS.
*         IF  PHYSICAL DESCRIPTOR VALID  THEN
*           SAVE CHANNEL NUMBER.
*           SAVE UIT POINTER.
*           CONSTRUCT CHANNEL INTERLOCK TABLE POINTER.
*           PLUG CHANNEL NUMBER.
*         ELSE
*           SET UP ERROR RESPONSE.
*         IFEND


 SPT      SUBR               ENTRY/EXIT
          LDML   INTPIT+/PIT/P.INTREG
          STML   INTREG                     POINTER TO PP INTERRUPT REGISTER
          LDML   INTPIT+/PIT/P.INTREG+1
          STML   INTREG+1
          LDML   INTPIT+/PIT/P.PPNO
          ZJN    SPT1        PP NUMBER CAN NOT BE ZERO
          RAML   ATIA        PLUG LOGICAL PP NUMBER
          LDML   INTPIT+/PIT/P.PPNO
          RAML   ATIB
          STML   RTIA
          LDML   INTPIT+/PIT/P.UNITC
          ZJN    SPT0        IF NO UNITS TO FUNCTION
          SBK    MAXUNIT+1
          ERRNZ  MAXUNIT-1   CODE ONLY SUPPORTS ONE UNIT
          MJN    SPT2        IF MAXIMUM UNITS NOT EXCEEDED
 SPT0     LDK    IEC.211     UNIT DESCRIPTOR LENGTH ERROR
          LJM    SPT6

 SPT1     LDK    IEC.220     INVALID PP NUMBER
          LJM    SPT6

 SPT2     ADK    MAXUNIT+1
          STDL   SCRATCH+2   NUMBER OF UNITS
          SHN    1
          ERRNZ  C.UD/2-1    CODE ASSUMES C.UD = 2
          STDL   SCRATCH     LENGTH OF UNIT DESCRIPTOR AREA
          LOADCB PITADDR,,C.PIT
          CRML   INTPIT+P.PIT,SCRATCH            READ UNIT DESCRIPTORS
          LDN    0
          STDL   SCRATCH+1
 SPT3     LDML   INTPIT+P.PIT+/UD/P.CHAN,SCRATCH+1
          SHN    -16+/UD/L.CHAN+/UD/N.CHAN
          STDL   CURCHAN     SAVE CHANNEL
          SBK    LCBUL+1
          MJN    SPT4        IF CHANNEL IS IN LOWER BARREL
          SBK    UCBLL-LCBUL-1
          MJN    SPT5        IF CHANNEL IS NOT IN UPPER BARREL
          SBK    UCBUL+1-UCBLL
          PJN    SPT5        IF CHANNEL IS NOT IN UPPER BARREL
 SPT4     LDML   INTPIT+P.PIT+/UD/P.RMAUIT,SCRATCH+1
          STDL   UITADDR     SAVE UNFORMATTED UIT RMA
          LDML   INTPIT+P.PIT+/UD/P.RMAUIT+1,SCRATCH+1
          STDL   UITADDR+1
          LOADCM UITADDR     LOAD UIT TO FORMAT THE ADDRESS
          STDL   UITADDR+2   SAVE FORMATTED UIT RMA
          SRD    UITADDR
          LDDL   CURCHAN     CURRENT CHANNEL
          SHN    3           (CHANNEL * 8) = INTERLOCK WORD OFFSET
          ADML   INTPIT+/PIT/P.CIT+1
          STML   CITADDR+1   CURRENT CHANNEL INTERLOCK POINTER
          SHN    -16
          ADML   INTPIT+/PIT/P.CIT
          STML   CITADDR
          UJN    SPT8        PLUG CHANNEL INTO DRIVER CODE

 SPT5     LDK    IEC.20A     INVALID CHANNEL
 SPT6     STML   RESBUF+/PRS/P.IEC               INTERFACE ERROR CODE
          LDK    B.PRS
          STML   RESBUF+/PRS/P.RL                RESPONSE LENGTH
          LDN    1
          SHN    16-/PRS/L.INTERR-/PRS/N.INTERR
          STML   RESBUF+/PRS/P.INTERR            ABNORMAL STATUS
          LDK    RT.UNS
          SHN    16-/PRS/L.RTYPE-/PRS/N.RTYPE
          ADK    URC.IE
          STML   RESBUF+/PRS/P.URC               UNSOLICITED RESPONSE
          LCN    0           RETURN, INTERFACE ERROR
 SPT7     LJM    SPTX


 SPT8     LDC    CHANTAB
          STDL   SCRATCH     LIST OF INSTRUCTIONS TO PLUG
 SPT9     LDIL   SCRATCH
          ZJN    SPT7        IF ALL INSTRUCTIONS PLUGGED, RETURN 0 = OK
          STD    SCRATCH+1
          LDIL   SCRATCH+1   FETCH INSTRUCTION
          SCN    37B         CLEAR OLD CHANNEL NUMBER
          LMDL   CURCHAN     STORE NEW CHANNEL NUMBER
          STIL   SCRATCH+1
          AODL   SCRATCH
          UJN    SPT9        PLUG NEXT LOCATION
SUT       SPACE  4,30
**        SUT    SET UP UNIT INTERFACE TABLE POINTERS
*
*         THE PURPOSE OF THIS ROUTINE IS TO INTITIALIZE THE VARIABLES WHICH
*         DEFINE THE ACCESSABLE UNIT INTERFACE TABLES.
*
*         ENTRY  (INTPIT) = UNIT DESCRIPTORS FOR THE CORRESPONDING UNITS.
*                (UNITTAB) = RMA POINTERS TO THE UITS.
*                (UTABL) = LENGTH OF UNITTAB.
*
*         EXIT   (A) : STATUS
*                    = 0, OK; ENTRIES VALID AND VARIABLES INITIALIZED.
*                    < 0, ERROR; AN INVALID UIT WAS ENCOUNTERED AND AN
*                                ABNORMAL RESPONSE HAS BEEN CREATED.
*
*         IF  UNIT INTERFACE TABLE INVALID  THEN
*           SET UP ERROR RESPONSE.
*         ELSE
*           SAVE UIT REQUEST QUEUE LOCK POINTER.
*         IFEND


 SUT      SUBR               ENTRY/EXIT
          LDK    C.UIT
          STDL   SCRATCH     LENGTH OF UNIT INTERFACE TABLE
          LDN    0
          STDL   SCRATCH+1   CURRENT UNIT DESCRIPTOR POINTER
 SUT1     LOADCB UITADDR
          CRML   INTUIT,SCRATCH        READ UNIT INTERFACE TABLE ENTRY
          LDML   INTPIT+P.PIT+/UD/P.LUN,SCRATCH+1
          LMML   INTUIT+/UIT/P.LUN
          NJN    SUT3        LOGICAL UNIT NUMBER MISMATCH

*         THE FOLLOWING LINES OF CODE ARE CURRENTLY COMMENTED
*         OUT BECAUSE THERE IS NO UNIT TYPE FOR A NAD.
*
*         LDML   INTUIT+/UIT/P.UTYPE
*         LMK    NADTYPE
*         NJN    SUT4        UNIT TYPE IS NOT A NAD TYPE

          LDML   INTPIT+P.PIT+/UD/P.RMAUIT+1,SCRATCH+1
          ADK    /UIT/C.UQLOCK*8
          STML   URQIL+1
          SHN    -16
          ADML   INTPIT+P.PIT+/UD/P.RMAUIT,SCRATCH+1
          STML   URQIL
          LDN    0
 SUT2     UJK    SUTX

 SUT3     LDK    IEC.301     LOGICAL UNIT NUMBER OF *UD* <> LUN OF *UIT*
          UJN    SUT5

 SUT4     LDK    IEC.306     INVALID UNIT TYPE
 SUT5     STML   RESBUF+/PRS/P.IEC               INTERFACE ERROR CODE
          LDK    B.PRS
          STML   RESBUF+/PRS/P.RL                RESPONSE LENGTH
          LDN    1
          SHN    16-/PRS/L.INTERR-/PRS/N.INTERR
          STML   RESBUF+/PRS/P.INTERR            ABNORMAL STATUS
          LDK    RT.UNS
          SHN    16-/PRS/L.RTYPE-/PRS/N.RTYPE
          ADK    URC.IE
          STML   RESBUF+/PRS/P.URC               UNSOLICITED RESPONSE
          LCN    0           RETURN, INTERFACE ERROR
          UJK    SUT2

** CPR CHECK FOR PP RELOAD
*
* THE PURPOSE OF THIS ROUTINE IS TO DETERMINE WHETHER OR NOT
* THE PP IS BEING RESTARTED BECAUSE THE PP WAS RE-LOADED DURING
* THE PROCESSING OF AN I/O REQUEST.
*
* NOTE    IF THE PP WAS PROCESSING A PP REQUEST AT THE POINT OF
*  RELOAD, THE CORRESPONDING INFORMATION FROM THAT
*  REQUEST IS LOST.  HOWEVER, THIS SHOULD NOT HANG
*  ANY CPU SOFTWARE.
*
* ENTRY (UITADDR) = UNIT INTERFACE TABLE POINTER
*
* EXIT (PPSTATE) = PP.NORM, IF THIS IS A RELOAD
*       PP.IDLE, IF THIS IS A REGULAR PP LOAD
*
* IF   THIS IS NOT AN INITIAL LOAD    THEN
*   CLEAR ANY OUTSTANDING LOCKS.
*   ACQUIRE UNIT INTERFACE TABLE LOCK.
*   FOR   EACH ENTRY IN THE QUEUE   DO
*     CLEAR PP PROCESSING FLAGS.
*   FOREND
*   SET UNIT STATE TO *DOWN*.
*   SET PP STATE TO NORMAL TO CLEAR QUEUES.
*   RELEASE UNIT INTERFACE TABLE LOCK
* IFEND


 CPR      SUBR               ENTRY/EXIT
          LOADCB UITADDR,,/UIT/C.RQCLK
          CRDL   CURUIT      READ PP REQUEST QUEUE LOCK
          LDDL   CURUIT+/UIT/P.RQCLK
          ZJN    CPRX        IF NO REQUESTS HAVE BEEN PROCESSED
          LDK    URQIL
          RJM    RTI         RELEASE UNIT REQUEST INTERLOCK
          LDK    PPRQIL
          RJM    RTI         RELEASE PP REQUEST QUEUE INTERLOCK
          LDK    CITADDR
          RJM    RTI         RELEASE CHANNEL INTERLOCK
          LDK    URQIL
          RJM    ATI         ACQUIRE UNIT INTERFACE TABLE
          LOADCB UITADDR,,/UIT/C.PVANR
          CRML   RESBUF,TWO  READ UP THE UNIT REQUEST LIST POINTER
          LDML   RESBUF+/PRS/P.RMAOR
          ADML   RESBUF+/PRS/P.RMAOR+1
          NJN    CPR1        RELOAD WITH OUTSTANDING I/O
          UJK    CPR2        RELOAD WITH NO REQUESTS IN QUEUE

 CPR1     LOADCM RESBUF+/PRS/P.RMAOR
          CRML   RESBUF,TWO
          ADK    C.PR-2
          CRDL   LCMND       READ COMMAND WORD
          STDL   SCRATCH     SAVE ADDRESS FOR RE-WRITE
          LDDL   LCMND+/LCF/P.PPLOCK
          LPK    -/LCF/M.PPLOCK-/LCF/M.PPCOMP
          STDL   LCMND+/LCF/P.PPLOCK CLEAR PP LOCK FLAGS
          LDDL   SCRATCH
          ADK    400000B
          CWDL   LCMND       RE-WRITE COMMAND WITH PP FLAGS CLEARED
          LDML   RESBUF+/PRS/P.RMAOR
          ADML   RESBUF+/PRS/P.RMAOR+1
          NJN    CPR1        MORE REQUESTS IN QUEUE
          LOADCB UITADDR,,/UIT/C.DOWN
          CRDL   CURUIT      READ UNIT INTERFACE TABLE HEADER
          STDL   SCRATCH     SAVE ADDRESS FOR RE-WRITE
          LDDL   CURUIT+/UIT/P.DOWN
          SHN    17-15+/UIT/L.DOWN
          MJN    CPR2        IF UNIT IS ALREADY DOWN
          LDK    TRUE
          SHN    16-/UIT/L.DOWN+/UIT/N.DOWN
          RADL   CURUIT+/UIT/P.DOWN SET DEVIDE DOWN FLAG
          LDDL   SCRATCH
          ADK    400000B
          CWDL   CURUIT      REWRITE DOWN FLAG TO CLEAR REQUESTS
 CPR2     LDK    PP.NORM
          STDL   PPSTATE     SET PP STATE TO RESUME PROCESSING
          LDK    URQIL
          RJM    RTI         RELEASE UNIT INTERFACE TABLE LOCK
          UJK    CPRX
          SPACE  4,10
 CHANTAB  BSS    0
 TCH+40B  HERE
 T40B+CH  HERE
 TCH      HERE
          CON    0           END OF CHANNEL TABLE
          SPACE  4,10
 INTPIT   BSSZ   P.PIT+MAXUNIT*P.UD
 INTUIT   BSSZ   P.UIT
          ERRPL  *+3-7777B


*DECK DECK=RFT$APPLICATION_TABLE_ENTRY EXPAND=FALSE

{    DECK:  RFT$APPLICATION_TABLE_ENTRY
{
{    This deck contains the definitions for maintaining the status of
{    all active RHFAM applications.

  TYPE
    rft$application_table_entry = record
      next_entry: ^rft$application_table_entry,
      application_name: rft$application_name,
      application_kind: rft$application_kinds,
      maximum_allowed_connections: rft$application_connections,
      number_of_active_connections: rft$application_connections,
      system_wide_connection_mgmt: boolean,
      connection_table: ^rft$connection_entry,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc rft$connection_entry
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFT$CHANNEL_DESCRIPTORS EXPAND=FALSE

    TYPE
        rft$channel_descriptors = ARRAY [1..*] OF rft$channel_descriptor;

    TYPE
        rft$channel_descriptor = RECORD
          channel: 0..27,
          number_of_pps: 1..2,
          pp_number: ARRAY [1..2] OF iot$pp_number,
          unit_number: iot$logical_unit,
        RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc iot$pp_number
*copyc iot$logical_unit
?? POP ??
*DECK DECK=RFT$CONFIGURATION_DEFS EXPAND=FALSE

{    DECK: RFT$CONFIGURATION_DEFS
{
{    The following definitions define the status table for the remote host
{    facility access method (RHFAM).  These definitions include the
{    hardware configuration, the mainframe identifiers, and the current status
{    information of the loosely coupled network (LCN) as viewed from the
{    local host.


TYPE

     {    The RHFAM/VE status table is broken up in to the various
     {    LCN components.  An additional break-down is made to isolate
     {    by field accessibility.
     {
     {    1)  Read only fields.  Can be read while the reader has the
     {        global lock, while the reader has the display lock, and
     {        while the reader has incremented an active connection count.
     {        (the system task can read at any time).
     {
     {    2)  System task only.  These fields are read or written at any
     {        instant while the system task is up.  Can be read by
     {        other tasks satisfying rule 1.
     {
     {    3)  Read/write fields.  These fields require the status table
     {        lock to be set prior to access.  (NOTE - if the user only
     {        wants to read the value, rule 1 applies).
     {
     {    4)  Special read/write fields.  These fields are only
     {        accessible while the user has obtained the corresponding
     {        special lock.  (NOTE - these fields are nested within the
     {        status table, therefore the user must have satisfied the
     {        the requirements of rule 1 prior to setting a special lock).

     rft$status_table = RECORD
       lock: ost$signature_lock,

       {  Read.

       location: ^SEQ(*),
       local_nads: ^rft$local_nad_table,
       remote_nads: ^rft$remote_nad_table,
       local_host: ^rft$local_host_definition,
       remote_hosts: ^rft$remote_host_definition,

       {  Read/write.

       system_task_is_up: BOOLEAN,
       display_active: ost$global_task_id,
       install_in_progress_id: ost$global_task_id,
     RECEND;

TYPE
     rft$local_nad_table = ARRAY [1..*] of rft$local_nad_entry;

TYPE
     rft$local_nad_entry = RECORD

       {  Read.

       name: ALIGNED [0 MOD 8] rft$component_name,
       channel_ordinal: cmt$channel_ordinal,
       channel_number: ost$physical_channel_number,
       concurrent_channel: boolean,
       trunk_control_units: rft$trunk_control_units,
       defined_address: rft$nad_address,
       address: rft$nad_address,              { Initialized by system task }
       access_codes: rft$nad_access_codes,
       logical_unit_number: iot$logical_unit, { Initialized by system task }
       pp_drivers: 1..2,

       {  System task.

       pp: ARRAY [1..2] OF rft$pp_attributes,
       maintenance_selections: rft$maintenance_selections,
       maintenance_status: rft$maintenance_status,
       processing_out_control_mess: BOOLEAN,
       processing_in_control_mess: BOOLEAN,
       status_change_available: BOOLEAN,
       status_posted: BOOLEAN,
       incoming_connect_pending: BOOLEAN,
       current_max_connect_id: rft$concurrent_connections,
       last_status_change: INTEGER,
       last_status_seq_number: INTEGER,

       {  Read/write.

       current_status: ALIGNED [0 MOD 8] rft$nad_state,
       statistics: rft$nad_statistics,
       requests_posted: rft$concurrent_requests,
       connections_established: rft$concurrent_connections,

       {  Special read/write.

       outgoing_cm_queue: rft$outgoing_control_messages,

       {  Special read/write.

       connection_table_lock: ost$signature_lock,
       connection_table: ^rft$connections,
     RECEND;

TYPE
     rft$connections = ARRAY [0..*] OF rft$connection_table_entry;

TYPE
     rft$connection_table_entry = RECORD
       connection_state: rft$path_state,
       connection_clarifier: rft$path_clarifier,
       input_available: BOOLEAN,
       output_below_threshold: BOOLEAN,
       processing_incoming_connect: BOOLEAN,
       connection_table_entry: ^rft$connection_entry,
     RECEND;

TYPE
     rft$remote_nad_table = array [1..*] of rft$remote_nad_entry;

TYPE
     rft$remote_nad_entry = RECORD

       {  Read.

       name: ALIGNED [0 MOD 8] rft$component_name,
       microcode_type: rft$microcode_types,
       host_connections: rft$host_connections,
       address: rft$nad_address,
       trunk_control_units: rft$trunk_control_units,
       access_codes: rft$nad_access_codes,

       {  Read/write.

       current_status: ALIGNED [0 MOD 8] rft$nad_state,
       last_connect_time: ost$date_time,
     RECEND;

TYPE
     rft$local_host_definition = RECORD

       {  Read/write.

       disabled: ALIGNED [0 MOD 8] BOOLEAN,

       {  Read.

       physical_identifier: rft$physical_identifier,
       connection_password: rft$connection_password,
       subsystem_identifier: rft$subsystem_identifier,
       connection_timeout: rft$connection_timeout,
       data_transfer_timeout: rft$transfer_timeout,

       {  Check nested type definition for access information.

       associated_paths: ^rft$lcn_paths,
       logical_identifiers: array [1..*] of rft$lids,
     recend;

TYPE
     rft$lids = RECORD

       {  Read/write.

       disabled: BOOLEAN,

       {  Read.

       map_lid_to_pid: BOOLEAN,
       logical_id: rft$logical_identifier,
     RECEND;

TYPE
     rft$remote_host_definition = RECORD

       {  Read/write.

       disabled: ALIGNED [0 MOD 8] BOOLEAN,

       {  Read.

       next_entry: ^rft$remote_host_definition,
       physical_identifier: rft$physical_identifier,

       {  Check nested type definition for access information.

       associated_paths: ^rft$lcn_paths,
       logical_identifiers: array [1..*] of rft$lids,
     RECEND;

TYPE
     rft$lcn_paths = array [1..*] of rft$lcn_path_definition;

TYPE
     rft$lcn_path_definition = RECORD

       {  Read/write.

       disabled: ALIGNED [0 MOD 8] BOOLEAN,
       time_disabled: INTEGER,
       last_network_break_rc: rft$network_break_reason_code,
       failure_count: INTEGER,
       last_attempted_connect: INTEGER,

       {  Read.

       local_tcu_mask: rft$tcu_mask,
       remote_tcu_mask: rft$tcu_mask,
       access_code: rft$nad_access_code,
       destination_device: rft$destination_device,
       logical_network: rft$logical_network,
       logical_nad: rft$logical_nad,
       local_nad: rft$local_nads,
       CASE  loopback : boolean  OF
       = TRUE =
         destination_nad: rft$local_nads,
       = FALSE =
         remote_nad: rft$remote_nads,
       CASEND,
     RECEND;

TYPE
     rft$trunk_control_units = array [rfc$min_tcu..rfc$max_tcu] of
       rft$component_name;

TYPE
     rft$pp_attributes = RECORD
       pp_number: iot$pp_number,
       pp_state: rft$pp_state,
       pp_id: cmt$pp_identification,
     RECEND;

TYPE
     rft$pp_state = (rfc$pps_released, rfc$pps_reserved, rfc$pps_idle,
                     rfc$pps_normal);

TYPE
     rft$nad_state = record
       device_status: rft$element_state,
       tcu_status: array [rfc$min_tcu..rfc$max_tcu] of rft$element_state,
     recend;

TYPE
     rft$nad_statistics = record
       connections_established: rft$number_of_connects,
       bytes_sent: rft$bytes_transferred,
       bytes_received: rft$bytes_transferred,
     recend;

TYPE
     rft$maintenance_selections = record
       perform_auto_reload: boolean,
       reload_threshold: rft$microcode_reloads,
       dump_disposition: rft$dump_disposition,
       load_parameters: rft$load_parameters,
     recend;

TYPE

     rft$load_parameters = record
       maximum_connections: rft$concurrent_connections,
       maximum_nad_entries: rft$rnads_per_lnad,
       send_queue_limit: rft$nad_queue_limit,
       receive_queue_limit: rft$nad_queue_limit,
       monitor_trace: rft$nad_trace_parameter,
       trunk_trace: rft$nad_trace_parameter,
       device_trace: rft$nad_trace_parameter,
     recend;

TYPE

     rft$maintenance_status = record
       reload_in_progress: boolean,
       reloads_performed: rft$microcode_reloads,
       reload_failed: boolean,
       test_requested: boolean,
     recend;

TYPE
     rft$nad_status_entries = PACKED ARRAY [1..*] OF rft$nad_status_entry,

     rft$nad_status_entry = PACKED RECORD
       path_state: rft$path_state,
       path_clarifier: rft$path_clarifier,
       input_available: boolean,
       output_below_threshold: boolean,
       fill: 0..03f(16),
       path_identifier: rft$path_id,
     RECEND;

TYPE
     rft$path_state = 0..0ff(16),
     rft$path_clarifier = 0..0ff(16),
     rft$path_id = 0..0ff(16);

TYPE

     rft$component_name = ost$name,
     rft$host_connections = array [rfc$min_host_connect..rfc$max_host_connect]
       of rft$physical_identifier,
     rft$element_state = (rfc$es_on,rfc$es_off,rfc$es_down),
     rft$microcode_reloads = 0..rfc$max_microcode_reloads,
     rft$dump_disposition = (rfc$dd_discard,rfc$dd_save_last,
       rfc$dd_save_all),
     rft$rnads_per_lnad = 0..rfc$max_rnads_per_lnad,
     rft$number_of_connects = INTEGER,
     rft$request_count = INTEGER,
     rft$concurrent_requests = 0..rfc$max_concurrent_requests,
     rft$concurrent_connections = 0..rfc$max_connections,
     rft$nad_address = rfc$min_nad_address..rfc$max_nad_address,
     rft$nad_access_codes = array [rfc$min_tcu..rfc$max_tcu] of
       rft$nad_access_code,
     rft$nad_access_code = rfc$min_nad_access_code..rfc$max_nad_access_code,
     rft$microcode_types = (rfc$mc_type_180,rfc$mc_type_170,rfc$mc_type_vax,
       rfc$mc_type_ibm, rfc$mc_type_205, rfc$mc_type_inet, rfc$mc_type_ntn),
     rft$nad_queue_limit = 0..rfc$max_nad_queue_limit,
     rft$nad_trace_parameter = 0..rfc$max_trace_size,
     rft$connection_password = string(rfc$connection_pw_length),
     rft$subsystem_identifier = string(rfc$subsystem_id_length),
     rft$logical_ids_per_host = 0..rfc$max_logical_ids_per_host,
     rft$paths_per_host = 0..rfc$max_paths_per_host,
     rft$tcu_mask = packed array [rfc$min_tcu..rfc$max_tcu] of boolean,
     rft$logical_network = rfc$min_logical_network..rfc$max_logical_network,
     rft$logical_nad = rfc$min_logical_nad..rfc$max_logical_nad,
     rft$local_nads = 0..rfc$max_local_nads,
     rft$remote_nads = 0..rfc$max_remote_nads,
     rft$network_break_reason_code = rfc$min_network_reason_code..
       rfc$max_network_reason_code,
     rft$destination_device_address = rfc$min_destination_device_addr..
       rfc$max_destination_device_addr,
     rft$destination_device = rfc$min_host_connect..rfc$max_host_connect;

{    End of RHFAM/VE status table entries........

?? PUSH (LISTEXT := ON) ??
*copyc cmt$channel_ordinal
*copyc cmt$pp_identification
*copyc iot$logical_unit
*copyc iot$pp_number
*copyc ost$name
*copyc ost$physical_channel_number
*copyc ost$signature_lock
*copyc ost$date_time
*copyc rfc$configuration_defs
*copyc rft$host_identifier
*copyc rft$outgoing_control_messages
*copyc rft$connection_entry
?? POP ??
*DECK DECK=RFT$CONFIG_UTL_POINTERS EXPAND=FALSE

{    DECK: RFT$CONFIG_UTL_POINTERS



  TYPE

      rft$cu_local_host_entry = RECORD
        number_of_paths : rft$paths_per_host,
        paths : ^rft$cu_lcn_path_entry,
        entry : rft$local_host_definition,
      RECEND,

      rft$cu_remote_host_entry = RECORD
        next_entry : ^rft$cu_remote_host_entry,
        index : rft$number_of_hosts,
        number_of_paths : rft$paths_per_host,
        paths : ^rft$cu_lcn_path_entry,
        entry : rft$remote_host_definition,
      RECEND,

      rft$cu_local_nad_entry = RECORD
        next_entry : ^rft$cu_local_nad_entry,
        index : rft$local_nads,
        entry : rft$local_nad_entry,
      RECEND,

      rft$cu_remote_nad_entry = RECORD
        next_entry : ^rft$cu_remote_nad_entry,
        index : rft$remote_nads,
        entry : rft$remote_nad_entry,
      RECEND,

      rft$cu_lcn_path_entry = RECORD
        next_entry : ^rft$cu_lcn_path_entry,
        entry : rft$lcn_path_definition,
      RECEND;

  TYPE
      rft$config_utl_pointers = RECORD
        install_request: BOOLEAN,
        error_encountered: BOOLEAN,
        autpg_encountered: BOOLEAN,
        deflp_encountered: BOOLEAN,
        output_fid: amt$file_identifier,
        temporary_fid: amt$file_identifier,
        temporary_command_file_fid: amt$file_identifier,
        temporary_seq: ^SEQ(*),
        local_host_defined: BOOLEAN,
        remote_host_count: INTEGER,
        local_nad_count: INTEGER,
        remote_nad_count: INTEGER,
        remote_hosts : ^rft$cu_remote_host_entry,
        local_nads : ^rft$cu_local_nad_entry,
        remote_nads : ^rft$cu_remote_nad_entry,
        local_host : ^rft$cu_local_host_entry,
      RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc rft$configuration_defs
?? POP ??
*DECK DECK=RFT$CONNECTION_ENTRY EXPAND=FALSE

{    DECK: RFT$CONNECTION_ENTRY
{
{    This deck contains the definitions for maintaining the status of
{    all RHFAM connections.

  TYPE
    rft$connection_entry = RECORD
      next_entry: ^rft$connection_entry,
      lock: ost$signature_lock,
      connection_name: fst$path_handle_name,
      connection_attributes: rft$connection_attributes,
      connection_descriptor: rft$connection_descriptor,
      connection_statistics: rft$connection_statistics,
      application_entry_p: ^rft$application_table_entry,
      active_pp_requests: rft$concurrent_requests,
      waiting_tasks: ^rft$waiting_task_queue,
      send_request_active: BOOLEAN,
      receive_request_active: BOOLEAN,
      residue_input_data: ^rft$residue_data,
      open_count: integer,
      selected_path: ^rft$lcn_path_definition,
      control_message_header: rft$nbp_control_message_header,
    RECEND;

  TYPE
    rft$connection_descriptor = RECORD
      nad_index: rft$local_nads,
      logical_unit: iot$logical_unit,
      network_path: rft$path_id,
    RECEND;

  TYPE
    rft$connection_attributes = RECORD
      connection_status: rft$connection_status,
      client_name: rft$application_name,
      server_name: rft$application_name,
      client_host: rft$physical_identifier,
      server_host: rft$physical_identifier,
      destination_host: rft$host_identifier,
      connection_timeout: rft$connection_timeout,
      data_transfer_timeout: rft$transfer_timeout,
      record_block_size: rft$block_size,
      message_block_size: rft$block_size,
      incoming_record_abn: rft$application_block_number,
      outgoing_record_abn: rft$application_block_number,
      acks_received_count: rft$blocks_transferred,
      acks_sent_count: rft$blocks_transferred,
      incoming_message_count: rft$blocks_transferred,
      outgoing_message_count: rft$blocks_transferred,
      receive_record_terminator: rft$record_marks,
      file_mark_received: rft$record_marks,
      send_record_terminator: rft$record_marks,
      abnormal_termination: BOOLEAN,
    RECEND;

  TYPE
    rft$residue_data = RECORD
      remaining_data: rft$block_size,
      record_mark_encountered: BOOLEAN,
      record_mark: rft$record_marks,
      data_pointer: ^SEQ ( * ),
      data: SEQ ( * ),
    RECEND;

  TYPE
    rft$waiting_task_queue = record
      next_entry: ^rft$waiting_task_queue,
      global_task_id: ost$global_task_id,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc fst$path_handle_name
*copyc iot$logical_unit
*copyc ost$signature_lock
*copyc ost$global_task_id
*copyc rft$application_table_entry
*copyc rft$configuration_defs
*copyc rft$external_interface
*copyc rft$network_block_protocol
?? POP ??
*DECK DECK=RFT$EXTERNAL_INTERFACE EXPAND=FALSE


{    DECK: RFT$EXTERNAL_INTERFACE
{
{    The purpose of this deck is to define the data types required
{    for usage of the RHFAM external interface.


  TYPE

    rft$application_name = string (rfc$appl_name_length),

    rft$application_kinds = (rfc$server, rfc$client, rfc$partner),

    rft$application_connections = 0..rfc$max_appl_connections,

    rft$server_job_validation = (rfc$requester_validation,
      rfc$requester_supplied),

    rft$transfer_timeout = rfc$min_transfer_timeout ..
      rfc$max_transfer_timeout,

    rft$server_response = record
      case server_response_kind: rft$server_response_kind of
      = rfc$accept =
        ,
      = rfc$reject =
        server_reject_code: rft$server_reject_codes,
      casend
    recend,

    rft$server_response_kind = (rfc$accept,rfc$reject),

    rft$rhfam_reject_codes = rfc$min_rhfam_reject_code ..
      rfc$max_rhfam_reject_code,

    rft$server_reject_codes = rfc$min_server_reject_code ..
      rfc$max_server_reject_code,

    rft$connect_reject_codes = rfc$min_rhfam_reject_code ..
      rfc$max_server_reject_code,

    rft$block_size = 0 .. rfc$max_block_size,

    rft$application_block_number = 0 .. rfc$max_appl_block_number,

    rft$transmission_modes = (rfc$record_mode, rfc$message_mode),

    rft$data_buffers = ^rft$data,

    rft$data = array [1 .. * ] of rft$data_fragment,

    rft$data_fragment = record
      address: ^cell,
      length: rft$data_length,
    recend,

    rft$data_length = 0 .. rfc$max_data_length,

    rft$data_fragment_count = 0 .. rfc$max_data_fragment_count,

    rft$record_marks = (rfc$rm_null, rfc$rm_eor, rfc$rm_eof, rfc$rm_eoi),

    rft$connection_timeout = rfc$min_connection_timeout ..
      rfc$max_connection_timeout,

    rft$async_activities = (rfc$aa_send_data, rfc$aa_receive_data,
      rfc$aa_all_async_activities),

    rft$set_of_async_activities = set of rft$async_activities,

    rft$connection_events = (rfc$input_available, rfc$output_below_threshold),

    rft$blocks_transferred = INTEGER,

    rft$bytes_transferred = 0 .. rfc$max_bytes_transferred,

    rft$connect_time = 0 .. rfc$max_connect_time,

    rft$connection_statistics = record
      connect_time: integer,
      bytes_sent: rft$bytes_transferred,
      bytes_received: rft$bytes_transferred,
    recend,

    rft$connection_states = (rfc$unassigned, rfc$outgoing_connect_active,
      rfc$incoming_connect_active, rfc$connected, rfc$connect_rejected,
      rfc$switch_offered, rfc$switch_accepted, rfc$terminated,
      rfc$not_viable, rfc$system_task_shutdown, rfc$local_nad_failure,
      rfc$system_interrupt),

    rft$termination_kinds = (rfc$peer_termination, rfc$media_failure,
      rfc$local_termination),

    rft$type_of_lid = (rfc$unknown_logical_id, rfc$local_physical_id,
      rfc$local_logical_id, rfc$remote_physical_id, rfc$remote_logical_id),

    rft$connection_status = record
      case connection_state: rft$connection_states of
      = rfc$unassigned =
        ,
      = rfc$outgoing_connect_active =
        ,
      = rfc$incoming_connect_active =
        ,
      = rfc$connected =
        input_available: boolean,
        output_below_threshold: boolean,
      = rfc$connect_rejected =
        server_response: rft$connect_reject_codes,
      = rfc$switch_offered =
        destination_job: jmt$system_supplied_name,
      = rfc$switch_accepted =
        receiving_job: jmt$system_supplied_name,
      = rfc$terminated =
        reason_for_termination: rft$termination_kinds,
      = rfc$not_viable =
        ,
      = rfc$system_task_shutdown =
        ,
      = rfc$local_nad_failure =
        ,
      = rfc$system_interrupt =
        ,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc rfc$external_interface
*copyc rft$host_identifier
?? POP ??
*DECK DECK=RFT$FILE_ATTRIBUTES EXPAND=FALSE

  TYPE
    rft$file_attributes = array [1 .. * ] of rft$file_attribute,
    rft$file_attribute = record
      case key {input} : rft$file_attribute_keys of {input}

{}
{ The following attributes are only used to describe files which}
{ are used as connection files by RHFAM/VE. The}
{ documentation for these attributes is found in the RHFAM/VE ERS.}
{}

      = rfc$client_name =
        client_name: rft$application_name,
      = rfc$server_name =
        server_name: rft$application_name,
      = rfc$client_host =
        client_host: rft$physical_identifier,
      = rfc$server_host =
        server_host: rft$physical_identifier,
      = rfc$destination_host =
        destination_host: rft$host_identifier,
      = rfc$connection_timeout =
        connection_timeout: rft$connection_timeout,
      = rfc$data_transfer_timeout =
        data_transfer_timeout: rft$transfer_timeout,
      = rfc$record_block_size =
        record_block_size: rft$block_size,
      = rfc$message_block_size =
        message_block_size: rft$block_size,
      = rfc$incoming_record_abn =
        incoming_record_abn: rft$application_block_number,
      = rfc$outgoing_record_abn =
        outgoing_record_abn: rft$application_block_number,
      = rfc$receive_record_terminator =
        receive_record_terminator: rft$record_marks,
      = rfc$file_mark_received =
        file_mark_received: rft$record_marks,
      = rfc$send_record_terminator =
        send_record_terminator: rft$record_marks,
      = rfc$connection_status =
        connection_status: rft$connection_status,
      casend
    recend;

  TYPE
    rft$file_attribute_keys = (rfc$client_name,rfc$server_name,rfc$client_host,
      rfc$server_host,rfc$destination_host,rfc$connection_timeout,
      rfc$data_transfer_timeout,rfc$message_block_size,rfc$record_block_size,
      rfc$incoming_record_abn,rfc$outgoing_record_abn,
      rfc$receive_record_terminator,rfc$file_mark_received,
      rfc$send_record_terminator,rfc$connection_status);

  TYPE
    rft$get_attributes = array [1 .. * ] of rft$get_attribute,
    rft$get_attribute = record
      case key {input} : rft$file_attribute_keys of {input}

{}
{ The following attributes are only used to describe files which}
{ are used as connection files by RHFAM/VE. The}
{ documentation for these attributes is found in the RHFAM/VE ERS.}
{ These attributes comprise the set of attributes that may be read
{ by an application.
{}

      = rfc$client_name =
        client_name: rft$application_name,
      = rfc$server_name =
        server_name: rft$application_name,
      = rfc$client_host =
        client_host: rft$physical_identifier,
      = rfc$server_host =
        server_host: rft$physical_identifier,
      = rfc$destination_host =
        destination_host: rft$host_identifier,
      = rfc$connection_timeout =
        connection_timeout: rft$connection_timeout,
      = rfc$data_transfer_timeout =
        data_transfer_timeout: rft$transfer_timeout,
      = rfc$record_block_size =
        record_block_size: rft$block_size,
      = rfc$message_block_size =
        message_block_size: rft$block_size,
      = rfc$incoming_record_abn =
        incoming_record_abn: rft$application_block_number,
      = rfc$outgoing_record_abn =
        outgoing_record_abn: rft$application_block_number,
      = rfc$receive_record_terminator =
        receive_record_terminator: rft$record_marks,
      = rfc$file_mark_received =
        file_mark_received: rft$record_marks,
      = rfc$send_record_terminator =
        send_record_terminator: rft$record_marks,
      = rfc$connection_status =
        connection_status: rft$connection_status,
      casend
    recend;

  TYPE
    rft$change_attributes = array [1 .. * ] of rft$change_attribute,
    rft$change_attribute = record
      case key {input} : rft$file_attribute_keys of {input}

{}
{ The following attributes are only used to describe files which}
{ are used as connection files by RHFAM/VE. The}
{ documentation for these attributes is found in the RHFAM/VE ERS.}
{ These attributes comprise the set of attributes that may be
{ changed by an application.
{}

      = rfc$connection_timeout =
        connection_timeout: rft$connection_timeout,
      = rfc$data_transfer_timeout =
        data_transfer_timeout: rft$transfer_timeout,
      = rfc$record_block_size =
        record_block_size: rft$block_size,
      = rfc$message_block_size =
        message_block_size: rft$block_size,
      = rfc$incoming_record_abn =
        incoming_record_abn: rft$application_block_number,
      = rfc$outgoing_record_abn =
        outgoing_record_abn: rft$application_block_number,
      = rfc$receive_record_terminator =
        receive_record_terminator: rft$record_marks,
      = rfc$send_record_terminator =
        send_record_terminator: rft$record_marks,
      casend
    recend;

  TYPE
    rft$create_attributes = array [1 .. * ] of rft$create_attribute,
    rft$create_attribute = record
      case key {input} : rft$file_attribute_keys of {input}

{}
{ The following attributes are only used to describe files which}
{ are used as connection files by RHFAM/VE. The}
{ documentation for these attributes is found in the RHFAM/VE ERS.}
{ These attributes comprise the set of attributes that may be
{ changed by an application at connection file creation time.
{}

      = rfc$connection_timeout =
        connection_timeout: rft$connection_timeout,
      = rfc$data_transfer_timeout =
        data_transfer_timeout: rft$transfer_timeout,
      = rfc$record_block_size =
        record_block_size: rft$block_size,
      = rfc$message_block_size =
        message_block_size: rft$block_size,
      = rfc$incoming_record_abn =
        incoming_record_abn: rft$application_block_number,
      = rfc$outgoing_record_abn =
        outgoing_record_abn: rft$application_block_number,
      = rfc$receive_record_terminator =
        receive_record_terminator: rft$record_marks,
      = rfc$send_record_terminator =
        send_record_terminator: rft$record_marks,
      casend
    recend;

?? PUSH (LISTEXT := on) ??
*copyc rft$external_interface
?? POP ??

*DECK DECK=RFT$HOST_IDENTIFIER EXPAND=FALSE

{    DECK:  RFT$HOST_IDENTIFIER
{
{    This deck contains the definitions for the LCN host
{    names (PIDs and LIDs).


  TYPE

    rft$physical_identifier = string (rfc$physical_id_length),

    rft$logical_identifier = string (rfc$logical_id_length),

    rft$host_identifier = record
      case host_identifier_kind: rft$host_identifier_kind of
      = rfc$physical_identifier =
        physical_identifier: rft$physical_identifier,
      = rfc$logical_identifier =
        logical_identifier: rft$logical_identifier,
      casend
    recend,

    rft$host_identifier_kind = (rfc$physical_identifier,
            rfc$logical_identifier),

    rft$destination_hosts = array [1 .. rfc$max_available_hosts] of
      rft$host_identifier,

    rft$number_of_hosts = 0 .. rfc$max_lcn_hosts;

?? PUSH (LISTEXT := ON) ??
*copyc rfc$external_interface
?? POP ??
*DECK DECK=RFT$MANAGE_RHFAM_NETWORK_TYPES EXPAND=FALSE

{     DECK: RFT$MANAGE_RHFAM_NETWORK_TYPES
{
{     The purpose of this deck is to define the data types
{ for the MANAGE_RHFAM_NETWORK utility.

  TYPE

    rft$application_display_type = (rfc$adt_applications, rfc$adt_connections),

    rft$element_display_type = (rfc$edt_local_nads, rfc$edt_remote_nads, rfc$edt_trunks),

    rft$routing_display_type = (rfc$rdt_paths, rfc$rdt_lids),

    rft$display_option = (rfc$do_brief, rfc$do_full);
*DECK DECK=RFT$NETWORK_BLOCK_PROTOCOL EXPAND=FALSE

{     DECK: RFT$NETWORK_BLOCK_PROTOCOL
{
{     Application to application network block protocol definitions.


{     Default network block sizes.

  CONST
    rfc$default_record_block_size = 4096,
    rfc$default_message_block_size = 2043;

{     Network block types and text length.

  CONST
    rfc$nbp_block_type_min = rfc$nbp_block_type_unused,
    rfc$nbp_block_type_unused = 0,
    rfc$nbp_block_type_blk = 1,
    rfc$nbp_block_type_msg = 2,
    rfc$nbp_block_type_back = 3,
    rfc$nbp_block_type_cmd = 4,
    rfc$nbp_block_type_qblk = 6,
    rfc$nbp_block_type_qmsg = 7,
    rfc$nbp_block_type_max = rfc$nbp_block_type_qmsg;

  TYPE
    rft$nbp_block_type = rfc$nbp_block_type_min .. rfc$nbp_block_type_max;

  CONST
    rfc$nbp_min_text_length = 0,
    rfc$nbp_max_text_length = 0ffff(16);

  TYPE
    rft$nbp_text_length = rfc$nbp_min_text_length .. rfc$nbp_max_text_length;

{     Nad buffer descriptor.

  CONST
    rfc$min_buffer_descriptor = rfc$buffer_258,
    rfc$buffer_258 = 0,
    rfc$buffer_4128 = 1,
    rfc$buffer_reserved_2 = 2,
    rfc$buffer_reserved_3 = 3,
    rfc$max_buffer_descriptor = rfc$buffer_reserved_3;

  TYPE
    rft$nbp_buffer_descriptor = rfc$min_buffer_descriptor .. rfc$max_buffer_descriptor;

{     Connect reject codes.

  CONST

{     Discontinued reject codes.

    rfc$nbp_min_reject_code = 1,
    rfc$nbp_server_unavailable = 1,
    rfc$nbp_shutdown = 2,
    rfc$nbp_pid_lid_not_available = 4,
    rfc$nbp_path_unavailable = 8,
    rfc$nbp_invalid_password = 9,
    rfc$nbp_requesting_appl_unknown = 10,
    rfc$nbp_resources_not_available = 11,

{     Temporarily unavailable reject codes.

    rfc$nbp_requested_server_busy = 16,
    rfc$nbp_requested_host_busy = 30,

{     Disabled reject codes.

    rfc$nbp_server_disabled = 32,
    rfc$nbp_server_lid_disabled = 33,
    rfc$nbp_client_disabled = 34,
    rfc$nbp_client_pid_disabled = 35,
    rfc$nbp_client_nad_disabled = 37,
    rfc$nbp_tcu_disabled = 40,
    rfc$nbp_rhf_not_active = 46,
    rfc$nbp_rhf_shutdown = 47,

{     Invalid/undefined reject codes.

    rfc$nbp_server_undefined = 48,
    rfc$nbp_server_lid_undefined = 49,
    rfc$nbp_client_undefined = 50,
    rfc$nbp_client_pid_undefined = 51,
    rfc$nbp_password_undefined = 52,
    rfc$nbp_client_nad_undefined = 53,
    rfc$nbp_access_code_invalid = 54,
    rfc$nbp_device_invalid = 55,
    rfc$nbp_tcu_invalid = 56,
    rfc$nbp_max_reject_code = rfc$max_server_reject_code;

{     Network block header format.

  TYPE
    rft$nbp_block_header = packed record
      length: ALIGNED [0 MOD 8] rft$nbp_text_length,
      fill1: 0 .. 0ffff(16),
      destination_node: rft$nad_address,
      source_node: rft$nad_address,
      connection_number: rft$path_id,
      fill2: 0 .. 1f(16),
      block_type: rft$nbp_block_type,
      data_block_clarifier: rft$nbp_data_block_clarifier,
      fill3: 0 .. 03f(16),
      application_block_number: rft$application_block_number,
    recend;

  TYPE
    rft$nbp_data_block_clarifier = packed record
      pru_block: boolean,
      end_of_information: boolean,
      end_of_record: boolean,
      reserved: 0 .. 1,
      eor_level: 0 .. 0f(16),
    recend;

{     Outgoing connect path message.

  TYPE
    rft$nbp_outgoing_connect = packed record
      nad_address: ALIGNED [0 MOD 8] rft$nad_address,
      local_tcu_enables: rft$tcu_mask,
      destination_device: rft$destination_device_address,
      access_code: rft$nad_access_code,
      name: rft$subsystem_identifier,
      fill1: 0 .. 0ff(16),
      remote_tcu_enables: rft$tcu_mask,
      fill2: 0 .. 3,
      buffer_size: rft$nbp_buffer_descriptor,
      connection_entry: 0..0ffff(16),
      logical_network: rft$logical_network,
      logical_nad: rft$logical_nad,
      requested_application: rft$application_name,
      source_physical_id: rft$physical_identifier,
      requesting_application: rft$application_name,
      fill4: 0..3,
      application_block_number: rft$application_block_number,
      password: rft$connection_password,
      destination_id: rft$physical_identifier,
    recend;

{     Incoming connect path message.

  TYPE
    rft$nbp_incoming_connect = packed record
      nad_address: ALIGNED [0 MOD 8] rft$nad_address,
      local_tcu_enables: rft$tcu_mask,
      destination_device: rft$destination_device_address,
      access_code: rft$nad_access_code,
      name: rft$subsystem_identifier,
      path_id: rft$path_id,
      fill2: 0 .. 3f(16),
      buffer_size: rft$nbp_buffer_descriptor,
      fill3: 0 .. 0ffffffff(16),
      requested_application: rft$application_name,
      source_physical_id: rft$physical_identifier,
      requesting_application: rft$application_name,
      fill4: 0..3,
      application_block_number: rft$application_block_number,
      password: rft$connection_password,
      destination_id: rft$physical_identifier,
    recend;

{   control message format.

  CONST
    rfc$min_control_message_text = 0,
    rfc$max_control_message_text = 40,
    rfc$max_control_message_size = 64;

  TYPE
    rft$control_message_text = rfc$min_control_message_text ..
                               rfc$max_control_message_text;

  TYPE
    rft$nbp_control_message_header = PACKED RECORD
      nad_address: ALIGNED [0 MOD 8] rft$nad_address,
      local_tcu_enables: rft$tcu_mask,
      destination_device: rft$destination_device_address,
      access_code: rft$nad_access_code,
      name: rft$subsystem_identifier,
      my_path_id: rft$path_id,
      his_path_id: rft$path_id,
      connect: 0..0ffff(16),
      logical_network: rft$logical_network,
      logical_nad: rft$logical_nad,
      length: rft$transfer_length,
      fill1: 0..0ffff(16),
      destination_nad: rft$nad_address,
      source_nad: rft$nad_address,
      connection_number: rft$path_id,
      fill2: 0..1f(16),
      block_type: rft$nbp_block_type,
      fill3: 0..3fff(16),
      abn: rft$application_block_number,
    RECEND;

  TYPE
    rft$nbp_control_message = PACKED RECORD
      header: rft$nbp_control_message_header,
      data: STRING(*),
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc rft$external_interface
*copyc rft$configuration_defs
*copyc rft$pp_interface_defs
?? POP ??
*DECK DECK=RFT$OUTGOING_CONTROL_MESSAGES EXPAND=FALSE

{     DECK: RFT$OUTGOING_CONTROL_MESSAGES
{
{     This deck defines a queue of control messages that
{     are waiting to be sent accross the LCN network.


  TYPE
    rft$outgoing_control_messages = record
      lock: ALIGNED [0 MOD 8] ost$signature_lock,
      first_entry: ^rft$outgoing_control_message,
    recend;

  TYPE
    rft$outgoing_control_message = record
      next_entry: ^rft$outgoing_control_message,
      purge_on_retry: BOOLEAN,
      control_message: rft$nbp_control_message,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc rft$network_block_protocol
*copyc ost$signature_lock
?? POP ??
*DECK DECK=RFT$PP_INTERFACE_DEFS EXPAND=FALSE

{    DECK : RFT$PP_INTERFACE_DEFS
{
{    The purpose of this deck is to define the various CYBIL types which
{    are used to interface between the RHFAM CPU and PP programs.


  TYPE
      rft$peripheral_request = PACKED RECORD
        fill1: 0..0ffff(16),
        next_pp_request: ^iot$io_request,
        fill2: 0..0ffffffff(16),
        next_pp_request_rma: ost$real_memory_address,
        request_length: rft$request_length,
        logical_unit: iot$logical_unit,
        recovery: iot$request_recovery,
        interrupt: iot$interrupt,
        priority: iot$priority,
        alert_mask: rft$alert_conditions,
        fill4: 0..0ffff(16),
        request_buffer_ptr: ^rft$request_response_buffer,
      RECEND;

  TYPE
      rft$request_length = 0..0ffff(16);

  TYPE
      rft$transfer_length = 0..0ffff(16);

  TYPE
      rft$alert_conditions = PACKED RECORD
        long_input_block: BOOLEAN,
        eoi_mark_encountered: BOOLEAN,
        eof_mark_encountered: BOOLEAN,
        eor_mark_encountered: BOOLEAN,
        pru_block_next: BOOLEAN,
        non_pru_block_next: BOOLEAN,
        end_of_message: BOOLEAN,
        fill_2: 0..1ff(16),
      RECEND;

  TYPE
      rft$abnormal_status = PACKED RECORD
        alert_condition_encountered: BOOLEAN,
        interface_error: BOOLEAN,
        fill1: 0..1,
        channel_parity_error: BOOLEAN,
        fill2: 0..3,
        channel_hung_empty: BOOLEAN,
        universal_command_timeout: BOOLEAN,
        function_timeout: BOOLEAN,
        flag_function_timeout: BOOLEAN,
        prime_flag_timeout: BOOLEAN,
        hardware_fault: BOOLEAN,
        channel_activate_failed: BOOLEAN,
        invalid_status_value: BOOLEAN,
        input_transfer_abnormal: BOOLEAN,
        output_transfer_abnormal: BOOLEAN,
      RECEND;

  TYPE
      rft$detailed_status = PACKED RECORD
        last_mc_function: rft$nad_function_codes,
        last_mc_status: rft$nad_status_flags,
        last_hw_function: rft$nad_function_codes,
        last_hw_status: rft$nad_status_flags,
      RECEND;

  TYPE
      rft$nad_function_codes = 0..0ffff(16);

  TYPE
      rft$request_response_buffer = RECORD
        io_request: ALIGNED [0 MOD 1024] iot$io_request,
        rhfam_request: ALIGNED [0 MOD 8] rft$peripheral_request,
        command_buffer: ALIGNED [0 MOD 8] SEQ(REP  rfc$command_buffer_size  OF rft$command),
        response: ALIGNED [0 MOD 8] iot$pp_response,
        detailed_status: ALIGNED [0 MOD 8] rft$detailed_status,
        previous_in_ptr: rft$command_entry,
        previous_out_ptr: rft$command_entry,
        asynchronous_request: BOOLEAN,
        response_posted: BOOLEAN,
        task_id: ost$global_task_id,
        request_id: rft$request_identifier,
        response_seq_number: INTEGER,
      RECEND;

  TYPE
      rft$command_entry = 1..rfc$command_buffer_size;

  TYPE
      rft$command_code = 0..0ff(16);

{    Each variant of this record must be exactly one central memory word (i.e. 8 bytes).

  TYPE
      rft$command = PACKED RECORD
        CASE  rft$command_types  OF
        = rfc$ct_pp_command =
          pp_function_code: rft$command_code,
          pp_flags: rft$function_flags,
          pp_fill: 0..0ffffffffffff(16),
        = rfc$ct_logical_command_1 =
          lc_function_code: rft$command_code,
          lc_flags: rft$function_flags,
          lc_length: rft$transfer_length,
          lc_rma: ost$real_memory_address,
        = rfc$ct_logical_command_2 =
          CASE  rft$logical_commands  OF
          = rfc$lc_obtain_connect_request, rfc$lc_receive_control_message =
            cm_physical_from: rft$physical_from,
            cm_fill: 0..0ffff(16),
            cm_path_id: rft$path_identifier,
          = rfc$lc_reject_connect_request =
            rc_reject_code: rft$reject_code,
            rc_fill: 0..0ffff(16),
            rc_path_id: rft$path_identifier,
          = rfc$lc_obtain_nad_general_stat =
            os_retry_count: rft$retry_count,
            os_fill: 0..0ffffffff(16),
            os_path_id: rft$path_identifier,
          = rfc$lc_send_data, rfc$lc_receive_data =
            io_retry_count: rft$retry_count,
            io_previous_in_pointer: rft$request_length,
            io_in_pointer_change: rft$request_length,
            io_path_id: rft$path_identifier,
          = rfc$lc_request_connection, rfc$lc_accept_connect_request,
              rfc$lc_status_nad, rfc$lc_send_control_message,
              rfc$lc_disconnect_paths,
              rfc$lc_read_path_status_table, rfc$lc_process_physical_command =
            lc_fill: 0..0ffffffffffff(16),
            lc_path_id: rft$path_identifier,
          CASEND,
        = rfc$ct_physical_command =
          pc_function_code: rft$command_code,
          pc_fill: 0..0ff(16),
          CASE  rft$physical_commands  OF
          = rfc$pc_function_nad =
            fn_fill: 0..0ffffffff(16),
            fn_nad_function_code: rft$nad_function_codes,
          = rfc$pc_microcode_status, rfc$pc_hardware_status =
            st_fill: 0..0ffff(16),
            st_mask: rft$nad_status_flags,
            st_value: rft$nad_status_flags,
          = rfc$pc_output_8_in_8_mode, rfc$pc_input_8_in_8_mode,
              rfc$pc_set_addr_and_length =
            pc_length: rft$transfer_length,
            pc_rma: ost$real_memory_address,
          CASEND,
        = rfc$ct_buffer_pointer =
          bp_more_data: BOOLEAN,
          bp_fill: 0..07fffffffffff(16),
          bp_offset: rft$request_length,
        = rfc$ct_subfunction_header =
          sf_length: rft$request_length,
          sf_buffer_length: rft$transfer_length,
          sf_transfer_length: rft$transfer_length,
          sf_fill: 0..0ffff(16),
        = rfc$ct_rma_entry =
          CASE wired: BOOLEAN OF
          = TRUE =
            re_fill: 0..07fff(16),
            re_length: rft$transfer_length,
            re_address: ost$real_memory_address,
          = FALSE =
            pe_fill1: 0..07fff(16),
            pe_length: rft$transfer_length,
            pe_fill2: 0..0ffff(16),
            pe_pva_index: 0..0ffff(16),
          CASEND,
        = rfc$ct_pva_entry =
          pv_fill: 0..0ffff(16),
          pv_pva: ^CELL,
        = rfc$ct_nad_memory_loc =
          nm_addr: rft$transfer_lgth_addr,
          nm_length: rft$transfer_lgth_addr,
        CASEND,
      RECEND;

  TYPE
      rft$command_types = (rfc$ct_pp_command, rfc$ct_logical_command_1, rfc$ct_logical_command_2,
        rfc$ct_physical_command, rfc$ct_buffer_pointer, rfc$ct_subfunction_header,
        rfc$ct_rma_entry,rfc$ct_pva_entry, rfc$ct_nad_memory_loc);

  TYPE
      rft$path_identifier = 0..0ffff(16);

  TYPE
      rft$reject_code = 0..0ffffffff(16);

  TYPE
      rft$retry_count = 0..0ffff(16);

  TYPE
      rft$transfer_lgth_addr = PACKED RECORD
        fill1: 0..0ff(16),
        upper_8_bits: 0..0ff(16),
        fill2: 0..0ff(16),
        lower_8_bits: 0..0ff(16),
      RECEND;

{    This entry must be exactly 4 bytes.

  TYPE
       rft$physical_from = PACKED RECORD
         address: rft$nad_address,
         unused: BOOLEAN,
         criteria: rft$physical_from_criteria,
         compare_name: BOOLEAN,
         device: rft$destination_device_address,
         char1: STRING(1),
         char2: STRING(1),
       RECEND;

{    This record must be exactly one byte.

  TYPE
       rft$function_flags = PACKED RECORD
         store_response: BOOLEAN,
         indirect_address: BOOLEAN,
         pp_processing: BOOLEAN,
         pp_process_complete: BOOLEAN,
         flush_buffer: BOOLEAN,
         CASE  rft$logical_commands  OF
         = rfc$lc_request_connection =
           maintenance_connection: BOOLEAN,
           fill1: 0..3,
         = rfc$lc_send_data, rfc$lc_receive_data =
           send_intermediate_response: BOOLEAN,
           fill2: 0..3,
         = rfc$lc_status_nad =
           unconditionally_status: BOOLEAN,
           fill3: 0..3,
         = rfc$lc_receive_control_message =
           rejected_control_message: BOOLEAN,
           fill4: 0..3,
         = rfc$lc_disconnect_paths =
           abnormal_termination: BOOLEAN,
           fill5: 0..3,
         = rfc$lc_obtain_nad_general_stat =
           primed: BOOLEAN,
           fill6: 0..3,
         = rfc$lc_obtain_connect_request, rfc$lc_accept_connect_request,
             rfc$lc_reject_connect_request, rfc$lc_read_path_status_table,
             rfc$lc_send_control_message, rfc$lc_process_physical_command =
           fill7: 0..7,
         CASEND,
       RECEND;


  TYPE
      rft$physical_from_criteria = rfc$min_pf_criteria .. rfc$max_pf_criteria;

  TYPE
      rft$logical_commands = rfc$min_logical_command .. rfc$max_logical_command;

  TYPE
      rft$physical_commands = rfc$min_physical_command .. rfc$max_physical_command;

  TYPE
      rft$pp_commands = rfc$min_pp_command .. rfc$max_pp_command;

  TYPE
      rft$nad_status_kinds = (rfc$sk_microcode_status, rfc$sk_hardware_status);

  TYPE
      rft$io_types = (rfc$io_input, rfc$io_output);

{    Both of the following variants must be exactly 16 bits.

  TYPE
      rft$nad_status_flags = PACKED RECORD
        CASE  rft$nad_status_kinds  OF
        = rfc$sk_microcode_status =
          fill1: 0..01f(16),
          hardware_fault: BOOLEAN,
          primed_flag: BOOLEAN,
          function_flag: BOOLEAN,
          selected_path: BOOLEAN,
          input_available: BOOLEAN,
          output_below_threshold: BOOLEAN,
          response: 0..01f(16),
        = rfc$sk_hardware_status =
          fill2: 0..3f(16),
          di_error: BOOLEAN,
          residue_error: BOOLEAN,
          assembly_disassembly_error: BOOLEAN,
          channel_sequence_error: BOOLEAN,
          device_not_enabled: BOOLEAN,
          illegal_function: BOOLEAN,
          memory_parity_error: BOOLEAN,
          nad_processor_abnormal: BOOLEAN,
          nad_processor_not_running: BOOLEAN,
          channel_parity_error: BOOLEAN,
        CASEND,
      RECEND;

  TYPE
      rft$nad_state_flags = PACKED RECORD
        disabled: BOOLEAN,
        down: BOOLEAN,
        fill: 0..3fff(16),
      RECEND;

  TYPE
      rft$pp_interface_error = RECORD
        pp_number: iot$pp_number,
        interface_error_code: iot$interface_error_code,
      RECEND;


?? PUSH (LISTEXT := ON) ??
*copyc rfc$pp_interface_defs
*copyc iot$io_request
*copyc ost$global_task_id
*copyc rft$r1_interface_defs
?? POP ??

*DECK DECK=RFT$R1_INTERFACE_DEFS EXPAND=FALSE

{    DECK:  RFT$R1_INTERFACE_DEFS
{
{    The purpose of this deck is to define the CYBIL types which are used
{    to interface between the RING 1 and RING 3 RHFAM/VE code.



{    The ring 3 identifier is passed to ring 1 when a request is issued.  The
{    identifier should be unique for the corresponding task.  The ring 1 code
{    assigns its own unique identifier, then passes the identifier and the
{    address of the request to ring 3.  The ring 3 code uses the address to
{    monitor the completion of the request.  A system flag is sent to ring 3
{    when a request is completed and the ring 3 code must check to see which
{    request was completed (This is not necessary if the ring 3 code only has
{    a single outstanding request).

{    NOTE:  These structures are allocated in task private and therefore
{    inherit ring 3 privileges. Any pointers that are stored in
{    these structures must point to structures that are allocated in
{    a segment that is writable at ring 3.  If this is not done, a segment
{    access error will occur if the routine allocating and storing the
{    structure pointer is running at a ring below 3.


  TYPE
      rft$request_identifier = RECORD
        ring_1_id: rft$r1_request_id,
        ring_3_id: rft$r3_request_id,
      RECEND;

  TYPE
      rft$r1_request_id = RECORD
        entry: 1..rfc$max_r1_request_id,
        address: ^rft$request_response_buffer,
      RECEND;

  TYPE
      rft$r3_request_id = RECORD
        entry: 1..rfc$max_r3_request_id,
        nad: rft$local_nads,
        pp: 1..2,  {only used for pp requests}
        location: rft$request_selector,
      RECEND;

  TYPE
      rft$request_selector = RECORD
        CASE  kind: rft$request_types  OF
        = rfc$pp_request =
          logical_pp: iot$pp_number,
        = rfc$unit_request =
          logical_unit: iot$logical_unit,
        CASEND,
      RECEND;

  TYPE
      rft$request_types = (rfc$pp_request, rfc$unit_request);

  TYPE
      rft$outstanding_requests = RECORD
        next_entry: ^rft$outstanding_requests,
        retry_count: 0..rfc$max_nad_retries,
        request_kind: rft$nad_request_kinds,
        request_status: ^cell,
        request_id: rft$request_identifier,
        posted: BOOLEAN,
        processing_request: BOOLEAN,
        waiting_event: ^rft$rhfam_event_table_entry,
      RECEND;

  TYPE
      rft$load_dump_status = RECORD
        state: rft$load_dump_states,
        mc_lfn: amt$local_file_name,
        mc_file_id: amt$file_identifier,
        mc_length: integer,
        mc_offset: integer,
        initial_phase: BOOLEAN,
        init_prams: rft$mc_initialization_prams,
        time_of_first_go: integer,
        current_nad_address: rft$nad_memory_size,
        mc_image: ^CELL,
        buffers_in_use: rft$buffer_count,
        number_of_buffers: rft$buffer_count,
        buffer_list: ^rft$buffer_list,
        nt_data : rft$nad_test_data,
        nt_length: rft$bytes_transferred,
        nt_offset: rft$bytes_transferred,
        mem_test_first_pass: BOOLEAN,
      RECEND;

  TYPE
      rft$connection_mgmt_status = RECORD
        CASE internal_use: boolean OF
        = TRUE =
          server_entry_p: ^rft$rhfam_server_table_entry,
          incoming_connect: ^rft$incoming_connect,
        = FALSE =
          connection: ^rft$connection_entry,
          activity_status: ^ost$activity_status,
        CASEND,
      RECEND;

  TYPE
    rft$data_transfer_status = RECORD
      connection_name: amt$local_file_name,
      connection_entry_p : ^rft$connection_entry,
      transmission_mode: rft$transmission_modes,
      wait: ost$wait,
      activity_status: ^ost$activity_status,
      data_transferred: ^rft$bytes_transferred,
      block_size: rft$block_size,
      file_mark: rft$record_marks,
      termination_mark: rft$record_marks,
      connection_descriptor: rft$connection_descriptor,
      data_area: rft$data_buffers,
      network_wired_data: boolean,
      data_exhausted: boolean,
      total_blocks_queued: rft$outstanding_blocks,
      next_to_queue_index: rft$data_fragment_count,
      next_to_queue_offset: rft$data_length,
      next_to_queue_abn: rft$application_block_number,
      current_fragment_index: rft$data_fragment_count,
      current_fragment_offset: rft$data_length,
      current_abn: rft$application_block_number,
      block_descriptors: ^rft$block_descriptors,
      block_descriptor_in: rft$outstanding_blocks,
      block_descriptor_out: rft$outstanding_blocks,
      next_to_advise_out_index: rft$data_fragment_count,
      next_to_advise_out_offset: rft$data_length,
      next_to_advise_in_index: rft$data_fragment_count,
      next_to_advise_in_offset: rft$data_length,
      complete_index: rft$data_fragment_count,
      complete_offset: rft$data_length,
      header_buffers: ^rft$header_buffers,
      present_r1_out_ptr: rft$command_entry,
      bytes_transferred: rft$bytes_transferred,
      outgoing_message_count: rft$blocks_transferred,
      previous_error: ost$status,
      reason_for_termination: rft$termination_kinds,
      reserved_buffer_list: ^rft$buffer_list,
      reserved_buffer_count: rft$buffer_count,
      next_wired_buffer_in: rft$buffer_count,
      next_wired_buffer_out: rft$buffer_count,
      switch_to_wired_buffers: boolean,
      outstanding_control_messages: ^rft$outgoing_control_message,
      control_message_header: rft$nbp_control_message_header,
      maximum_outstanding_blocks: rft$outstanding_blocks,
      CASE transfer_kind: rft$transfer_kinds OF
      = rfc$tk_send_data =
        end_of_message: boolean,
        residue_data_on_send: boolean,
      = rfc$tk_receive_data =
        file_mark_received: rft$record_marks,
        complete_message_received: boolean,
        end_of_message_p: ^boolean,
      CASEND,
    RECEND;

  TYPE rft$transfer_kinds = (rfc$tk_send_data, rfc$tk_receive_data);

  TYPE
    rft$outstanding_blocks = 0 .. rfc$max_outstanding_blocks;

  TYPE
    rft$block_descriptors = ARRAY [1..*] OF
          rft$block_descriptor;

  TYPE
    rft$block_descriptor = RECORD
      block_sequence_number: rft$application_block_number,
      data_fragment_index: rft$data_fragment_count,
      data_fragment_offset: rft$data_length,
      byte_count: rft$block_size,
      wired_buffer_index: rft$buffer_count,
    RECEND;

  TYPE
    rft$header_buffers = ARRAY [1..*] OF
          rft$header_buffer;

  TYPE
    rft$header_buffer = RECORD
      header: ALIGNED [ 0 MOD 16 ] rft$nbp_block_header,
    RECEND;

  TYPE
    rft$transfer_state = RECORD
      CASE transfer_state: rft$transfer_states OF
      = rfc$ts_intermediate, rfc$ts_normal, rfc$ts_resource_limit,
        rfc$ts_resource_limit_change, rfc$ts_retryable_error,
        rfc$ts_broken, rfc$ts_fatal_error =
        ,
      = rfc$ts_alert =
        alert_kind: rft$alert_kinds,
      CASEND,
    RECEND;

  TYPE
    rft$transfer_states = (rfc$ts_intermediate, rfc$ts_normal, rfc$ts_alert,
      rfc$ts_resource_limit, rfc$ts_resource_limit_change, rfc$ts_retryable_error,
      rfc$ts_broken, rfc$ts_fatal_error);

  TYPE
    rft$alert_kinds = (rfc$ak_message_block, rfc$ak_record_block, rfc$ak_eor_block,
      rfc$ak_eof_block, rfc$ak_eoi_block, rfc$ak_long_input, rfc$ak_end_of_message);

  TYPE
    rft$transfer_mode = RECORD
      CASE transfer_mode: rft$transfer_modes OF
      = rfc$tm_message_mode, rfc$tm_unformatted_mode =
        ,
      = rfc$tm_record_mode =
        termination_mark: rft$record_marks,
      CASEND,
    RECEND;

  TYPE
    rft$transfer_modes = (rfc$tm_message_mode, rfc$tm_unformatted_mode, rfc$tm_record_mode);

  TYPE
    rft$network_wired_buffer_count =  0 .. rfc$max_network_wired_buffers;

  TYPE
    rft$network_wired_buffers = RECORD
      lock: ost$signature_lock,
      maximum_buffers: rft$network_wired_buffer_count,
      current_buffers: rft$network_wired_buffer_count,
    RECEND;

  TYPE
    rft$buffer_list = ARRAY [1..*] OF rft$wired_buffer_def;

  TYPE
      rft$wired_buffer_def = RECORD
        length: nlt$bm_buffer_length,
        byte_count: nlt$bm_buffer_length,
        current_offset: nlt$bm_buffer_length,
        descriptor: ^nlt$bm_message_descriptor,
        buffer: ^CELL,
      RECEND;

  TYPE
      rft$buffer_count = 0..rfc$max_wired_buffers_per_req+1;

  TYPE
      rft$io_fragment = RECORD
        wired: BOOLEAN,
        length: rft$transfer_length,
        address: ^CELL,
      RECEND;

  TYPE
      rft$nad_request_kinds = (rfc$rk_local_nad_load, rfc$rk_local_nad_status,
        rfc$rk_local_nad_dump, rfc$rk_local_nad_gen_stat, rfc$rk_send_data,
        rfc$rk_receive_data, rfc$rk_request_connection,
        rfc$rk_accept_connect_request, rfc$rk_reject_connect_request,
        rfc$rk_obtain_connect_request, rfc$rk_remote_nad_dump,
        rfc$rk_remote_nad_load, rfc$rk_remote_nad_gen_stat,
        rfc$rk_path_status, rfc$rk_disconnect_path,
        rfc$rk_send_control_mess, rfc$rk_receive_control_mess,
        rfc$rk_resume_pp, rfc$rk_idle_pp);

  TYPE
      rft$load_dump_states = (rfc$lt_mem_test_begin, rfc$lt_mem_test_write,
        rfc$lt_mem_test_read, rfc$ls_begin_load, rfc$ls_sending_microcode,
        rfc$ls_sending_init_prams, rfc$ls_send_go, rfc$ls_go_sent,
        rfc$ls_get_mc_status, rfc$ds_begin_dump, rfc$ds_continue_dump,
        rfc$ds_end_of_dump);

  TYPE
      rft$nad_test_data = (rfc$nt_inc_addr, rfc$nt_dec_addr, rfc$nt_con_5555,
        rfc$nt_con_aaaa);

  TYPE
      rft$failure_data_symptoms =
        (rfc$function_timeout, rfc$channel_activate_failed, rfc$channel_hung_empty, rfc$prime_flag_timeout,
         rfc$flag_function_timeout, rfc$abnormal_nad_response, rfc$nad_hardware_abnormal,
         rfc$input_terminated_early, rfc$output_terminated_early, rfc$channel_parity_error,
         rfc$universal_command_timeout, rfc$memory_error_address, rfc$concurrent_channel_error);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc amt$file_identifier
*copyc iot$pp_number
*copyc iot$logical_unit
*copyc ost$wait
*copyc ost$status
*copyc ost$activity_status
*copyc nat$data_fragments
*copyc nlt$bm_message_descriptor
*copyc rfc$r1_interface_defs
*copyc rfd$mc_initialization_prams
*copyc rft$network_block_protocol
*copyc rft$pp_interface_defs
*copyc rft$configuration_defs
*copyc rft$rhfam_event_table
*copyc rft$rhfam_server_table
*copyc rft$rhfam_job_table
?? POP ??

*DECK DECK=RFT$RB_QUEUE_DATA_FRAGMENTS EXPAND=FALSE

{    DECK:  RFT$RB_QUEUE_DATA_FRAGMENTS


   TYPE
     rft$rb_queue_data_fragments = record
       reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
       status: syt$monitor_status,
       request_buffer: ^rft$request_response_buffer,
       number_of_blocks: rft$outstanding_blocks,
       io_type: iot$io_function,
       clear_complete_flag: BOOLEAN,
     recend;

?? PUSH (LISTEXT := ON) ??
*copyc iot$io_function
*copyc rft$pp_interface_defs
*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*copyc syt$monitor_status
?? POP ??
*DECK DECK=RFT$RHFAM_CLIENT_TABLE EXPAND=FALSE

{    DECK:  RFT$RHFAM_CLIENT_TABLE
{
{    This deck contains the definitions for maintaining the status
{    of all defined RHFAM clients.

  TYPE
    rft$rhfam_client_table = record
      lock: ost$signature_lock,
      first_entry: ^rft$rhfam_client_table_entry,
    recend;


  TYPE
    rft$rhfam_client_table_entry = record
      next_entry: ^rft$rhfam_client_table_entry,
      client_active: boolean,
      client_name: rft$application_name,
      maximum_connections: rft$application_connections,
      current_connections: rft$application_connections,
      system_wide_connection_mgmt: boolean,
      client_capability: ost$name,
      client_ring: ost$ring,
      client_system_privilege: boolean,
      connections_reserved: rft$application_connections,
      abort_connections: boolean,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$signature_lock
*copyc rft$external_interface
?? POP ??
*DECK DECK=RFT$RHFAM_EVENT_TABLE EXPAND=FALSE

{    DECK:  RFT$RHFAM_EVENT_TABLE
{
{    This common deck defines the table for tasks waiting for
{    RHFAM events to occur.

  TYPE
    rft$rhfam_event_table = record
      lock: ost$signature_lock,
      first_entry: ^rft$rhfam_event_table_entry,
    recend;

  TYPE
    rft$rhfam_event_table_entry = record
      next_entry: ^rft$rhfam_event_table_entry,
      task_id: ost$global_task_id,
      event_occurred_type: rft$event_occurred_type,
      case event_kind: rft$await_network_activity of
      = rfc$ana_await_server_response =
        asr_connection_descriptor: rft$connection_descriptor,
      = rfc$ana_await_incoming_connect =
        aic_job_name: jmt$system_supplied_name,
        aic_server_name: rft$application_name,
      = rfc$ana_await_connection_event =
        ace_connection_descriptor: rft$connection_descriptor,
        ace_input_available: BOOLEAN,
        ace_output_buffer_available: BOOLEAN,
        ace_data_transfer_in_progress: BOOLEAN,
        ace_asynchronous_wait: BOOLEAN,
        ace_asynchronous_timeout: INTEGER,
      = rfc$ana_await_switch_offer =
        aso_application_name: rft$application_name,
      = rfc$ana_await_switch_accept =
        asa_source_job: jmt$system_supplied_name,
      casend,
    recend;

  TYPE
    rft$event_occurred_type = (rfc$eot_no_event, rfc$eot_server_response,
      rfc$eot_incoming_connect, rfc$eot_input_available,
      rfc$eot_output_below_threshold, rfc$eot_timeout, rfc$eot_switch_offer,
      rfc$eot_switch_accept, rfc$eot_connection_terminated,
      rfc$eot_system_task_shutdown, rfc$eot_async_terminated);

  TYPE
    rft$await_network_activity = (rfc$ana_await_server_response, rfc$ana_await_incoming_connect,
      rfc$ana_await_connection_event, rfc$ana_await_switch_offer, rfc$ana_await_switch_accept);


?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc jmt$system_supplied_name
*copyc rft$external_interface
*copyc ost$signature_lock
?? POP ??
*DECK DECK=RFT$RHFAM_JOB_TABLE EXPAND=FALSE

{    DECK: RFT$RHFAM_JOB_TABLE
{
{    This deck contains the definitions for maintaining
{    the status of all RHFAM jobs.

  TYPE
    rft$rhfam_job_table = record
      lock: ost$signature_lock,
      first_entry: ^rft$rhfam_job_table_entry,
      last_entry: ^rft$rhfam_job_table_entry,
    recend;

  TYPE
    rft$rhfam_job_table_entry = record
      next_entry: ^rft$rhfam_job_table_entry,

{     The remainder of this structure is aligned on a word boundary.  This
{     isolates the next_entry pointer from the remainder of the structure
{     and allows the entries on either side of a locked entry to be
{     relinked through the locked entry.  If this is not done, dual cpus
{     may conflict.

      lock: ALIGNED [0 MOD 8] ost$global_task_id,
      job_name: jmt$system_supplied_name,
      application_entry: ^rft$application_table_entry,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc ost$global_task_id
*copyc ost$signature_lock
*copyc rft$application_table_entry
?? POP ??
*DECK DECK=RFT$RHFAM_SERVER_TABLE EXPAND=FALSE

{    DECK:  RFT$RHFAM_SERVER_TABLE
{
{    This deck contains the definitions for maintaining the
{    status of all defined RHFAM servers.

  TYPE
    rft$rhfam_server_table = record
      lock: ost$signature_lock,
      first_entry: ^rft$rhfam_server_table_entry,
    recend;


  TYPE
    rft$rhfam_server_table_entry = record
      next_entry: ^rft$rhfam_server_table_entry,
      server_active: boolean,
      server_name: rft$application_name,
      maximum_connections: rft$application_connections,
      server_capability: ost$name,
      server_ring: ost$ring,
      server_system_privilege: boolean,
      current_connections: rft$application_connections,
      connections_reserved: rft$application_connections,
      partner_job_connections: rft$application_connections,
      access_method_accept: boolean,
      validate_connection_lid: boolean,
      active_incoming_connects: rft$application_connections,
      abort_connections: boolean,
      incoming_connect: ^rft$incoming_connect,
      server_identifier: ^rft$server_identifier,
      CASE rhfam_initiated_server: boolean OF
      = TRUE =
        server_job_max_connections: rft$application_connections,
      = FALSE =
      CASEND,
    recend;

  TYPE
    rft$incoming_connect = record
      next_entry: ^rft$incoming_connect,
      connection_descriptor: rft$connection_descriptor,
      connect_message: rft$nbp_incoming_connect,
      connection_status: rft$connection_status,
      time_received: integer,
  recend;

  TYPE
    rft$server_identifier = record
      next_entry: ^rft$server_identifier,
      job_name: jmt$system_supplied_name,
      server_started_time: integer,
      server_signed_on: boolean,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$signature_lock
*copyc rft$external_interface
*copyc rft$network_block_protocol
*copyc rft$rhfam_job_table
?? POP ??
*DECK DECK=RFT$STATUS_RESPONSE_PENDING EXPAND=FALSE

 TYPE
     rft$status_response_pending = ^ARRAY [1..*] OF rft$status_pending;

 TYPE
     rft$status_pending = RECORD
       in_host: ALIGNED [0 MOD 8] BOOLEAN,
     RECEND;
*DECK DECK=RFT$SWITCHED_CONNECTION_QUEUE EXPAND=FALSE

{     DECK: RFT$SWITCHED_CONNECTION_QUEUE
{
{     This deck defines the RHFAM switched connection queue. This
{     queue is used to transfer control of connections from one
{     job to another.

  TYPE
    rft$switched_connection_queue = record
      lock: ost$signature_lock,
      first_entry: ^rft$switched_connection,
    recend;

  TYPE
    rft$switched_connection = record
      next_entry: ^rft$switched_connection,
      connection_entry_p: ^rft$connection_entry,
      destination_job: jmt$system_supplied_name,
      destination_application: rft$application_name,
      source_job: jmt$system_supplied_name,
      connection_entry_source_job: ^rft$connection_entry,
      source_application_kind: rft$application_kinds,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc rft$rhfam_job_table
*copyc ost$signature_lock
?? POP ??
*DECK DECK=RFV$FAILURE_DATA_SYMPTOMS EXPAND=FALSE

    VAR
        rfv$failure_data_symptoms: [XREF, READ, oss$job_paged_literal]
          ARRAY [rft$failure_data_symptoms] OF STRING(25);

?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
*copyc rft$r1_interface_defs
?? POP ??




*DECK DECK=RFV$JOB_ENTRY_POINTER EXPAND=FALSE

  VAR
    rfv$job_entry_pointer: [XREF, oss$task_shared] ^rft$rhfam_job_table_entry;

?? PUSH (LISTEXT := ON) ??
*copyc rft$rhfam_job_table
?? POP ??
*DECK DECK=RFV$NAD_PATH_TABLE EXPAND=FALSE

  VAR
    rfv$nad_path_table: [XREF, oss$network_paged] ^rft$nad_path_table;

?? PUSH (LISTEXT := ON) ??
*copyc rft$nad_path_table
*copyc oss$network_paged
?? POP ??

*DECK DECK=RFV$NETWORK_BREAK_RC EXPAND=FALSE

    VAR
        rfv$network_break_rc: [XREF, READ, oss$job_paged_literal]
          ARRAY [rfc$ctnrc_no_response .. rfc$ctnrc_connection_limit_ntn] OF STRING(25);

?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
*copyc rfd$path_status_table
?? POP ??
*DECK DECK=RFV$NETWORK_FAILURE_SYMPTOMS EXPAND=FALSE

    VAR
        rfv$network_failure_symptoms: [XREF, READ, oss$job_paged_literal]
          ARRAY [rft$network_failure_symptoms] OF STRING(25);

?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
*copyc rfd$path_status_table
?? POP ??

*DECK DECK=RFV$NETWORK_WIRED_BUFFERS EXPAND=FALSE

  VAR
    rfv$network_wired_buffers : [XREF, oss$network_paged]
          rft$network_wired_buffers;

?? PUSH (LISTEXT := ON) ??
*copyc rft$r1_interface_defs
*copyc oss$network_paged
?? POP ??
*DECK DECK=RFV$OUTGOING_CONTROL_MESSAGES EXPAND=FALSE

  VAR
    rfv$outgoing_control_messages: [XREF, oss$network_paged]
          rft$outgoing_control_messages;

?? PUSH (LISTEXT := ON) ??
*copyc rft$outgoing_control_messages
*copyc oss$network_paged
?? POP ??
*DECK DECK=RFV$OUTSTANDING_REQUESTS EXPAND=FALSE

  VAR
      rfv$outstanding_requests: [XREF, oss$task_private] ^rft$outstanding_requests;

?? PUSH (LISTEXT := ON) ??
*copyc rft$r1_interface_defs
*copyc oss$task_private
?? POP ??
*DECK DECK=RFV$PP_INTERFACE_ERROR EXPAND=FALSE

  VAR
      rfv$pp_interface_error: [XREF] rft$pp_interface_error;

?? PUSH (LISTEXT := ON) ??
*copyc rft$pp_interface_defs
?? POP ??
*DECK DECK=RFV$REQUEST_NAMES EXPAND=FALSE

  VAR
      rfv$request_names: [XREF, READ, oss$job_paged_literal]
        ARRAY [rft$nad_request_kinds] OF  STRING(25);

?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
*copyc rft$r1_interface_defs
?? POP ??
*DECK DECK=RFV$RESPONSE_PROCESSOR EXPAND=FALSE

  VAR
      rfv$response_processor: [XREF] iot$response_processor;

?? PUSH (LISTEXT := ON) ??
*copyc iot$io_request
?? POP ??
*DECK DECK=RFV$RHFAM_CLIENT_TABLE EXPAND=FALSE

  VAR
    rfv$rhfam_client_table: [XREF, oss$network_paged] rft$rhfam_client_table;

?? PUSH (LISTEXT := ON) ??
*copyc rft$rhfam_client_table
*copyc oss$network_paged
?? POP ??

*DECK DECK=RFV$RHFAM_EVENT_TABLE EXPAND=FALSE

  VAR
    rfv$rhfam_event_table: [XREF, oss$network_paged] rft$rhfam_event_table;

?? PUSH (LISTEXT := ON) ??
*copyc rft$rhfam_event_table
*copyc oss$network_paged
?? POP ??
*DECK DECK=RFV$RHFAM_JOB_TABLE EXPAND=FALSE

  VAR
    rfv$rhfam_job_table: [XREF, oss$network_paged] rft$rhfam_job_table;

?? PUSH (LISTEXT := ON) ??
*copyc rft$rhfam_job_table
*copyc oss$network_paged
?? POP ??
*DECK DECK=RFV$RHFAM_SERVER_TABLE EXPAND=FALSE

  VAR
    rfv$rhfam_server_table: [XREF, oss$network_paged] rft$rhfam_server_table;

?? PUSH (LISTEXT := ON) ??
*copyc rft$rhfam_server_table
*copyc oss$network_paged
?? POP ??

*DECK DECK=RFV$STATUS_RESPONSE_PENDING EXPAND=FALSE

  VAR
      rfv$status_response_pending: [XREF] rft$status_response_pending;

?? PUSH (LISTEXT := ON) ??
*copyc rft$status_response_pending
?? POP ??
*DECK DECK=RFV$STATUS_TABLE EXPAND=FALSE

VAR

     rfv$status_table: [XREF,oss$network_paged] rft$status_table;

?? PUSH (LISTEXT := ON) ??
*copyc oss$network_paged
*copyc rft$configuration_defs
?? POP ??
*DECK DECK=RFV$SWITCHED_CONNECTION_QUEUE EXPAND=FALSE

  VAR
    rfv$switched_connection_queue: [XREF, oss$network_paged]
          rft$switched_connection_queue;

?? PUSH (LISTEXT := ON) ??
*copyc rft$switched_connection_queue
*copyc oss$network_paged
?? POP ??
*DECK DECK=RFV$SYSTEM_TASK_ID EXPAND=FALSE

  VAR
      rfv$system_task_id: [XREF] ost$global_task_id;

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
?? POP ??
*DECK DECK=RHA$CPM_FUNCTION_REQUEST EXPAND=TRUE

          IDENT  RHACPM
          TITLE  RHA$CPM FUNCTION REQUEST
          ENTRY  CPMFP
          SYSCOM
          LIST   F
* CPMFP
*
*     THE PURPOSE OF THIS A170 COMPASS ROUTINE IS TO PROVIDE AN
* INTERFACE BETWEEN A CYBIL PROCEDURE AND THE NOS/A170 CPM FUNCTION
* PROCESSOR.  IT IS ASSUMED THE USER HAS PLACED THE CPM FUNCTION
* CODE IN REGISTER X1, I.E. THE CPM FUNCTION CODE IS THE FIRST
* PARAMETER IN THE CPMFP CALL.  FURTHER, IT IS ASSUMED THE USER
* HAS PLACED THE FUNCTION PARAMETER IN REGISTER X2, I.E. THE
* FUNCTION PARAMETER IS THE SECOND PARAMETER IN THE CPMFP CALL.
* FOR FURTHER INFORMATION ON CPM, CPM FUNCTION CODES, AND FUNCTION
* PARAMETERS PLEASE REFER TO CPM DOCUMENTATION.
*
*            CPMFP (FUNCTION_CODE,FUNCTION_PARAMETER)
*
* FUNCTION_CODE: (INPUT) THIS PARAMETER SPECIFIES WHICH CPM FUNCTION
*                IS TO BE PERFORMED.
*
* FUNCTION_PARAMETER: (INPUT) THIS PARAMETER SPECIFIES EITHER A
*                     FUNCTION PARAMETER VALUE OR A PARAMETER BLOCK
*                     ADDRESS DEPENDING ON THE REQUIREMENTS OF THE
*                     GIVEN FUNCTION CODE.
*
 CPMFP    BSS
*
* SAVE CYBIL ENVIRONMENT
*
          RJ     =XPXSAVE
*
* CALL NOS/A170 CPM FUNCTION PROCESSOR
*
          IF     -DEF,RA.ORG,2
          BX0    X1
          LX0    6
          BX5    X2
          IF     -DEF,RA.ORG,1
          SYSTEM CPM,1,X5,X0
NOSBE     IF     DEF,RA.ORG
          SX6    X1-13B
          NZ     X6,ILLFUNC
          SYSTEM  ACT,RECALL,STATUS
          SA1    STATUS+1
          BX6    X1          CONTAINS JN/JDT
          SA6    X5          RETURN TO CYBIL VARIABLE
          RJ     =XPXRSTR
ILLFUNC   MESSAGE  (=C* UNSUPPORTED CPM FUNCTION ATTEMPTED.*),3,R
NOSBE     ENDIF
*
* RESTORE CYBIL ENVIRONMENT AND RETURN TO CALLER
*
          RJ     =XPXRSTR
          IF     DEF,RA.ORG,2
 STATUS   VFD    7/1,17/W.CPJNAM,12/1,24/10B
          BSS    1           STATUS+1 KEEPS ACT OUTPUT
          END
*DECK DECK=RHA$ENTRY_POINT_PFP EXPAND=TRUE

          IDENT  RHAPFP
          TITLE  RHA$ENTRY POINT PFP
          ENTRY  RHPPFP
          ENTRY  SSJ=
* RHPPFP
*
*      THE PURPOSE OF THIS A170 COMPASS ROUTINE IS TO DEFINE THE
* RHMPFP ENTRY POINT IN A NON-CYBIL MANNER.  THIS IS DONE TO
* FACILITATE NOS/A170 PROCEDURE EXECUTION OF THE REMOTE HOST
* PERMANENT FILE FUNCTION PROCESSOR.
*


 SSJ=     EQU    0
 RHPPFP   BSS    0
*
* TRANSFER TO CYBIL MAIN PROGRAM, I.E. RHMPFP
*
          JP     =XSW=MAIN
          END
*DECK DECK=RHA$ENTRY_POINT_PSO EXPAND=TRUE

          IDENT  RHAPSO
          ENTRY  RHPPSO
* RHPPSO
*
*      THE PURPOSE OF THIS A170 COMPASS ROUTINE IS TO DEFINE THE
* RHMPSO ENTRY POINT IN A NON-CYBIL MANNER.  THIS IS DONE TO
* FACILITATE NOS/A170 PROCEDURE EXECUTION OF THE REMOTE HOST.
*



*
 RHPPSO   BSS    0
*
* TRANSFER TO CYBIL MAIN PROGRAM, I.E. RHMPSO
*
          JP     =XSW=MAIN
          END
*DECK DECK=RHA$ENTRY_POINT_QAC_MACRO EXPAND=TRUE
          IDENT  RHAQAC
          TITLE  RHA$ENTRY POINT QAC MACRO
          ENTRY  RHPQAC,ICPQAC,RHPRQD
          LIST   F
          SYSCOM
*copyc dsa$cybil_if_macros
* RHPQAC
*
*     THE PURPOSE OF THIS A170 COMPASS ROUTINE IS TO PROVIDE AN
* INTERFACE BETWEEN A CYBIL PROCEDURE AND THE NOS/A170 QAC MACRO.
*
*           RHPQAC (PARAMETER_BLOCK)
*
* // THIS ROUTINE IS CALLED BY:          (AS OF 84/11/20)
* //   DSMRUN MODULE=RHMJEP PROC=STATUS_PARTNER_JOB
*        INPUT: JSN   OUTPUT: FOUND OR NOT_FOUND
* //   DSMRUN MODULE=ICM$PAR PROC=FIND_PARTNER_QUEUE
*        INPUT: JSN   OUTPUT: IN_INPUT, IN_EXEC, NOT_FOUND
* //   RHAQEP MODULE=RHMQFA
*        INPUT: NO JSN OR LFN    OUTPUT: EC=NOT_FOUND OR LFN
*
* RHPRQD
*
*     THIS ROUTINE REQUESTS A QUEUE DEVICE RESIDENCE (FOR NOS/BE)
*         REQUEST_QUEUE_DEVICE ( LFN: INTEGER)
*     IT ACTS AS A NOOP FOR NOS.

 RHPQAC   BSS
 ICPQAC   EQU    RHPQAC
          RJ     =XPXSAVE
          BX0    X1
NOSSYS    IF     -DEF,RA.ORG
*
* CALL NOS/A170 QAC FUNCTION PROCESSOR
*
          SYSTEM QAC,1,X0,0
NOSSYS    ELSE
*
* CALL NOS/BE QAF FUNCTION PROCESSOR
*
          ACQUIRE X0,RECALL,N
NOSSYS    ENDIF
          EQ     =XZSMRRET

RHPRQD    BSS    0
NBESYS    IF     DEF,RA.ORG
          LX1    18D         LEFT ADJUST LFN
          BX6    X1
          SA6    RTELIST
          MX6    1
          LX6    1+55D
          SA6    A6+B1
          MX6    0
          SA6    A6+B1
          SA6    A6+B1
          REQUEST RTELIST,RECALL
NBESYS    ENDIF
          SHORTEX
RTELIST   BSS    6           RETURN/REPLY SPACE
          END
*DECK DECK=RHA$ENTRY_POINT_QEP EXPAND=TRUE

          IDENT  RHAQEP
          TITLE  RHA$ENTRY POINT QEP
          ENTRY  RHPQEP
* RHPQEP
*
*      THE PURPOSE OF THIS A170 COMPASS ROUTINE IS TO DEFINE THE
* RHMQEP ENTRY POINT IN A NON-CYBIL MANNER.  THIS IS DONE TO
* FACILITATE NOS/A170 OPERATOR INVOCATION OF THE REMOTE HOST.
*



*
 RHPQEP   BSS    0
*
* TRANSFER TO CYBIL MAIN PROGRAM, I.E. RHMQEP
*
          JP     =XSW=MAIN
          END
*DECK DECK=RHA$ENTRY_POINT_QOQ EXPAND=TRUE

          IDENT  RHAQOQ
          ENTRY  RHPQOQ
* RHPQOQ
*
*      THE PURPOSE OF THIS A170 COMPASS ROUTINE IS TO DEFINE THE
* RHMQOQ ENTRY POINT IN A NON-CYBIL MANNER.  THIS IS DONE TO
* FACILITATE NOS/A170 PROCEDURE EXECUTION OF THE REMOTE HOST.
*



*
 RHPQOQ   BSS    0
*
* TRANSFER TO CYBIL MAIN PROGRAM, I.E. RHMQOQ
*
          JP     =XSW=MAIN
          END
*DECK DECK=RHA$ENTRY_POINT_QSO EXPAND=TRUE

           IDENT  RHAQSO
           ENTRY  RHPQSO
* RHPQSO
*
*      THE PURPOSE OF THIS A170 COMPASS ROUTINE IS TO DEFINE THE
* RHMQSO ENTRY POINT IN A NON-CYBIL MANNER.  THIS IS DONE TO
* FACILITATE NOS/A170 PROCEDURE EXECUTION OF THE REMOTE HOST.
*
*
 RHPQSO   BSS    0
*
* TRANSFER TO CYBIL MAIN PROGRAM, I.E. RHMQSO
*
          JP     =XSW=MAIN
          END
*DECK DECK=RHA$FILE_TO_MLI EXPAND=TRUE
          IDENT  RHQXFER
          TITLE  RHA$FILE TO MLI - 170 REMOTE HOST MLI/CIO I/F.
          SST
          SYSCOM B1
          LIST   F

*copy RHA$MLI_TO_FILE
OPL XTEXT COMCCDD
          SKIP   RA.MTR
          ERR    SYSCOM NOT CALLED
          IF     -DEF,RA.ORG,1
OPL XTEXT COMCMAC
*copy COMSCVS
*copy COMMCVS
*copy COMSMLI
         BASE   D
BUFSIZ    EQU    3072+2
AIMOI     EQU    1
AIEOI     EQU    2
HWA       BSS    1
BUFA      BSS    BUFSIZ
TWA       BSS    1
*
HWB       BSS    1
BUFB      BSS    BUFSIZ
TWB       BSS    1
*
*IF ($string($name(wev$target_operating_system))='NOS')
FETA      FILEB  BUFA,BUFSIZ,(FET=10),EPR,UPR
FETB      FILEB  BUFB,BUFSIZ,(FET=10),EPR,UPR
*ELSE
FETA      FILEB  BUFA,BUFSIZ
FETB      FILEB  BUFB,BUFSIZ
*IFEND
MLIPAR    BSS    15
NTHSR     DATA   -2
REISSUE   DATA   0
WMLI      DATA   0
BLOCKS    DATA   0
WORDS     DATA   0
M1        DATA   10HMLI ERROR
M2        BSSZ   2

M3        DATA   10HCIO ERROR
M4        BSSZ   2

M13       DATA   20HREC ARBINFO ERROR
M14       BSS    1
          DATA   0
SMASK     VFD    60/1014040B
RMASK     VFD    60/40040B
MMASK     VFD    60/0
EOI       DATA   0
COUNT     BSS    1
          EXT    PARSV
DSTSA     EQU    PARSV+3
STSA      EQU    DSTSA+1

* PROCEDURE QFSEND (LFN
*                   AN170
*                   AN180
*               VAR DSTS
*               VAR STS)
* STS: LAST ARBINFO VALUE
*
          ENTRY  QFSEND
QFSEND    BSS    0
          RJ     =XPXSAVE
          BX6    X2
          BX7    X3
          SA6    MLIPAR+MLPAN
          SA7    MLIPAR+MLPSN
          MX6    0
          SA6    X5          SET STATUS OK
          SA6    EOI         CLEAR EOI FLAG

          R=     X6,AIMOI
          R=     X7,MLSOK
          SA6    MLIPAR+MLPAR
          SX6    100
          SA6    MLIPAR+MLPSG
          SX6    MLFSE
          SA6    MLIPAR+MLPFN
          SA7    MLIPAR+MLPSV
*
          SA2    FETA
          MX0    42
          BX3    -X0*X2
          LX1    18
          BX6    X1+X3
          SA6    FETB
          SA6    A2
*
          SA1    SMASK
          BX7    X1
          SA7    MMASK

          RESET  FETA
          READ   FETA,R
          SX6    10
LOOP      SA6    COUNT
          RESET  FETB
          READ   FETB
          SMSG   HWA,FETA,BUFA
          RECALL FETB
          CKMST  MMASK

          RESET  FETA
          READ   FETA
          SMSG   HWB,FETB,BUFB
          RECALL FETA
          CKMST  MMASK
          SA1    COUNT
          SX6    X1-2
          NZ     X6,LOOP     IF MORE

* INTERRUPT XFER IN MIDDLE AND RETURN

          SMSG   HWA,FETA,BUFA
          EQ     EXIT

* PROCEDURE QFREC

          ENTRY  QFREC
QFREC     BSS    0
          RJ     =XPXSAVE
          BX6    X2
          BX7    X3
          SA6    MLIPAR+MLPAN
          SA7    MLIPAR+MLPSN
          MX6    0
          SA6    X5          SET STATUS OK
          SA6    EOI         CLEAR EOI FLAG

          SA6    MLIPAR+MLPRI  RECEIVE INDEX
          SX6    100
          SA6    MLIPAR+MLPSG
          SX6    MLFRE
          SA6    MLIPAR+MLPFN
          SX6    MLSOK
          SA6    MLIPAR+MLPSV
          SX6    BUFSIZ
          SA6    MLIPAR+MLPBL  BUFFER LENGTH
*
          SA2    FETA
          MX0    42
          BX3    -X0*X2
          LX1    18
          BX6    X1+X3
          SA6    FETB
          SA6    A2
*
          SA1    RMASK
          BX7    X1
          SA7    MMASK
          SX6    10
RLOOP     SA6    COUNT
          RECM   BUFA
          RECALL FETB
          CKIOST FETB
          CKMST  MMASK
          WRITF  FETA,HWA

          RECM   BUFB
          RECALL FETA
          CKIOST FETA
          CKMST  MMASK
          WRITF  FETB,HWB
          SA1    COUNT
          SX6    X1-2
          NZ     X6,RLOOP    IF MORE

* INTERRUPT XFER IN MIDDLE AND RETURN

          EQ     EXIT

RAIERR    BSS    0
          SA1    MLIPAR+MLPV2
          RJ     CDD
          SA6    M14
          MESSAGE M13,3,R
          EQ     EXIT

MLERR     BSS    0
          SX6    B1
          SA1    STSA
          SA6    X1
          SA2    MLIPAR+MLPSV
          SA3    DSTSA
          BX6    X2
          SA6    X3
          MX6    0
          BX1    X2
          SA6    MLIPAR+MLPSV  TO PREVENT LOOP WITH EXIT/CKMST/MLERR
          RJ     CDD
          SA6    M2
          MESSAGE M1,3,R
          EQ     EXIT

IOERR     BSS    0
          SX6    2
          SA1    STSA
          SA6    X1
          BX6    X2
          SA3    DSTSA
          SA6    X3
          BX1    X2
          RJ     CDD
          SA6    M4
          EQ     EXIT

EXIT      BSS    0
          CKMST  MMASK
          RECALL FETA
          RECALL FETB
          SA1    MLIPAR+MLPAR
          SA2    STSA
*IF ($string($name(wev$target_operating_system))='NOS')
          SA3    X2               CHECK FOR NON-ZERO RETURNED
          NZ     X3,EXIT1         IF SO, THEN DONT OVERWRITE X REG
*IFEND
          BX6    X1
          SA6    X2          RETURN LAST ARBINFO
*IF ($string($name(wev$target_operating_system))='NOS')
EXIT1     EQ     =XZSMRRET
*ELSE
          EQ     =XZSMRRET
*IFEND

ISSUE2    BX6    X4
          SA6    NTHSR
ISSUE     BSS    1
ISSUE0    BSS    0
          SA1    NTHSR
          PL     X1,ISSUE3   IF REQUEST OUTSTANDING
          SX4    0
          SX2    MLIPAR
          CALLVS X2,X4,CVSMLIU,0
          ZR     X0,ISSUE    IF REQUEST COMPLETE
          BX1    X0
          AX1    30
          NZ     X1,ISSUE1   IF NOS/VE DOWN
          SX0    X0-1
          NZ     X0,ISSUE2   IF REQUEST NOT COMPLETE
          RECALL
          EQ     ISSUE0

ISSUE1    BSS    0
          SX6    MLSND
          SA6    MLIPAR+MLPSV
          EQ     ISSUE

ISSUE3    BSS    0
          MESSAGE (=C* REQ W/REQ OUTSTANDING*),3,R
          ABORT

**********************************************

POLL1     SX6    -2
          SA6    NTHSR
POLL      BSS    1
          SA4    NTHSR
          NG     X4,POLL     IF NO REQUEST
          SX1    MLIPAR
          CALLVS X1,X4,CVSMLIU,0
          ZR     X0,POLL1    IF REQUEST COMPLETE
          AX0    30
          ZR     X0,POLL     IF NOSVE UP
          SX6    MLSND
          SA6    MLIPAR+MLPSV
          EQ     POLL
          END
*DECK DECK=RHA$GET_NOS_LEVEL EXPAND=TRUE
          IDENT  RHAGLVL
*IF ($string($name(wev$target_operating_system))='NOS')
          TITLE  RHA$GET NOS LEVEL
          ENTRY  RHPGLVL
*
* RHPGLVL
*
*     THE PURPOSE OF THIS A170 COMPASS ROUTINE IS TO PROVIDE
*  A WAY OF GETTING THE CURRENT NOS LEVEL THAT IS RUNNING.
*
*         RHPGLVL (LEVEL_NUMBER)
 RHPGLVL  BSS    0
*
* SAVE CYBIL ENVIRONMENT
          RJ     =XPXSAVE
*
 OPL      XTEXT  COMSVER
          SX6    NOSLVL
          SA6    X1
* RESTORE CYBIL ENVIRONMENT
          RJ     =XPXRSTR
*
* RETURN TO CALLING PROCEDURE
*
          JP     B7
*IFEND
          END

*DECK DECK=RHA$GET_PERMANENT_FILE_INFO EXPAND=TRUE

          IDENT  RHAGPFP
*IF ($string($name(wev$target_operating_system))='NOS')
          TITLE  RHA$GET PERMANENT FILE INFO
          ENTRY  RHPGPFP
* RHPGPFP
*
*      THE PURPOSE OF THIS A170 COMPASS ROUTINE IS TO CALL THE
* GETPFP NOS MACRO IN ORDER TO GET THE DEFAULT FAMILY AND USER
* THAT IRHF 170 IS RUNNING UNDER.
*
*
 RHPGPFP  BSS    0
*
* SAVE CYBIL ENVIRONMENT
*
          RJ      =XPXSAVE
* CALL NOS A170 MACRO
          BX0     X1
          GETPFP  X0
* RESTORE CYBIL ENVIRONMENT
          RJ      =XPXRSTR
* RETURN TO CALLING PROCEDURE
          JP      B7
*IFEND
          END
*DECK DECK=RHA$INTERFACE_TO_QFM_MACRO EXPAND=TRUE
           IDENT  RHAQFM                                                 R123_OS        1
           TITLE  RHA$INTERFACE TO QFM MACRO                             R123_OS        2
           ENTRY  RHPQFM,SSJ=                                            R123_OS        3
* RHPQFM                                                                 R123_OS        4
*                                                                        R123_OS        5
*     THE PURPOSE OF THIS A170 COMPASS ROUTINE IS TO PROVIDE AN          R123_OS        6
* INTERFACE BETWEEN A CYBIL PROCEDURE AND THE NOS/A170 QFM MACRO.        R123_OS        7
*                                                                        R123_OS        8
*             RHPQFM (FUNCTION_CODE,FET_ADDRESS)                         R123_OS        9
*                                                                        R123_OS       10
*copyc dsa$cybil_if_macros                                               R123_OS       11
          SYSCOM B1                                                      R123_OS       12
          LIST   F                                                       R123_OS       13
 RHPQFM   BSS                                                            R123_OS       14
 NOSBE    IF     DEF,RA.ORG                                              R123_OS       15
          SA1    X2          LFN=JOBNAME                                 R123_OS       16
          BX6    X1                                                      R123_OS       17
          SA1    A1+B1       GET FET FIRST POINTER                       R123_OS       18
          SA6    X1          STORE IN *FNSS* FIELD                       R123_OS       19
          SA6    X1+34B      STORE IN *OASS* FIELD                       R123_OS       20
          SA6    X1+32B                                                  R123_OS       21
          SHORTEX            RETURN TO CYBIL                             R123_OS       22
 NOSBE    ELSE                                                           R123_OS       23
          RJ     =XPXSAVE                                                R123_OS       24
          BX0    X1                                                      R123_OS       25
          LX0    6                                                       R123_OS       26
          BX5    X2                                                      R123_OS       27
          SYSTEM QFM,1,X5,X0                                             R123_OS       28
*                                                                        R123_OS       29
* RESTORE CYBIL ENVIRONMENT AND RETURN TO CALLER                         R123_OS       30
*                                                                        R123_OS       31
          RJ     =XPXRSTR                                                R123_OS       32
 NOSBE    ENDIF                                                          R123_OS       33
 SSJ=     EQU    0                                                       R123_OS       34
          END                                                            R123_OS       35
*DECK DECK=RHA$INTERFACE_TO_ROUTE_MACRO EXPAND=TRUE
          IDENT  RHAQRM
          TITLE  RHA$INTERFACE TO ROUTE MACRO
          ENTRY  RHPQRM,ICPROUT,RHPPJR
          SYSCOM B1
          LIST   F
*
* RHPQRM, ICPROUT, RHPPJR
*
*    THE PURPOSE OF THIS A170 COMPASS ROUTINE IS TO PROVIDE AN
* INTERFACE BETWEEN A CYBIL PROCEDURE AND THE 170 ROUTE MACRO.
*
*            RHPQRM (ROUTE_PARAMETER_BLOCK)
*
 RHPQRM   BSS    0
 NBESYS   IF     DEF,RA.ORG
          RJ     =XPXSAVE
          EQ     RTE               TO CALL ROUTE

 RHPPJR   BSS    0
 NBESYS   ENDIF
 ICPROUT  RJ     =XPXSAVE

 NBESYS   IF     DEF,RA.ORG
          SX3    1
          SA2    NJNAME            PSEUDO-JSN
          LX3    36D
          IX2    X2+X3             ADD ONE IN BIT 36
 L1       LX3    5
          MI     X3,RESET          IF LEFTMOST, RESET PSEUDO-JSN
          BX5    X2*X3             FIND 40B= DC '5' THIS CHARACTER
          ZR     X5,DONE
          LX3    1                 POSITION TO NEXT CHARACTER
          IX2    X2+X5             ADD ANOTHER 40B
          AX5    5
          IX2    X2+X5             ADD ANOTHER 01B
          EQ     L1
 RESET    SA2    JOBNAME
 DONE     BX7    X2
          SA7    NJNAME
          SA2    X1+3
          MX6    42D
          BX6    -X6*X2
          BX7    X7+X6
          SA7    A2                ROUTE PB FID
 NBESYS   ENDIF
*
 RTE      BX0    X1
          ROUTE  X0,1
*
* RESTORE CYBIL ENVIRONMENT AND RETURN TO CALLER
*
          EQ     =XZSMRRET

 NBESYS   IF     DEF,RA.ORG
 JOBNAME  VFD    42/7LAAAA000,18/0       JOB NAME
 NJNAME   VFD    42/7LAAAA000,18/0       COUNT UP PSEUDO-JSN HERE

 NBESYS   ELSE
          SPACE  3,10
* RHPPJR
*
*    THE PURPOSE OF THIS COMPASS ROUTINE IS TO VERIFY A USER'S
* ACCOUNTING INFO AND ROUTE A PARTNER JOB TO EXECUTE A GET_FILE OR
* REPLACE_FILE.
*
*            RHAPJR (ROUTE_PARAMETER_BLOCK)
*
 RHPPJR   RJ     =XPXSAVE
*
* VERIFY USER ACCOUNTING INFORMATION
*
          SA1    X1
          MX6    42
          BX6    X1*X6
          SX1    1
          BX6    X6+X1
          SA6    FET                   SAVE FILE NAME
          SX6    BUFFER
          SX7    BUFFER+65
          SA6    A6+B1                 SET FIRST
          SA6    A6+B1                 SET IN
          SA6    A6+B1                 SET OUT
          SA7    A6+B1                 SET LIMIT
          READ   FET,RECALL              READ CARDS

          SX6    B0
          SA6    FET
          SA6    A6+B1
          SYSTEM VEJ,RECALL,FET        VERIFY USER INFO

          SA1    FET                   CHECK IF ERROR
          AX1    12
          MX6    6
          BX6    X1*X6
          ZR     X6,ROUTE               ROUTE JOB IF NO ERROR

          LX6    12                    PUT ERROR CODE IN THE
          SA1    =XPARSV               ROUTE PARAMETER BLOCK
          SA2    X1
          BX6    X2+X6
          SA6    X1                     RETURN ERROR CODE
          EQ     =XZSMRRET
*
* RETURN FILE AND CALL 170 ROUTE MACRO
*
ROUTE     BSS
          RETURN FET,R
          SA1    =XPARSV                SET POINTER TO ROUTE FET
          EQ     RTE
*
FET       BSSZ   5
BUFFER    BSSZ   65
NBESYS    ENDIF

          END
*DECK DECK=RHA$MLI_CIO EXPAND=TRUE
          IDENT  RHMLIO
          TITLE  RHA$MLI CIO - 170 REMOTE HOST MLI/CIO I/F.

          SYSCOM B1
          LIST   F

*copy RHA$MLI_TO_FILE
OPL XTEXT COMCCDD
          IF     -DEF,RA.ORG,1
OPL XTEXT COMCMAC
*copy COMSCVS
*copy COMMCVS
*copy COMSMLI
BUFSIZ    EQU    3072+2
AIMOI     EQU    1
AIEOI     EQU    2
HWA       BSS    1
BUFA      BSS    BUFSIZ
TWA       BSS    1
*
HWB       BSS    1
BUFB      BSS    BUFSIZ
TWB       BSS    1
*
FETA      FILEB  BUFA,BUFSIZ
FETB      FILEB  BUFB,BUFSIZ
MLIPAR    BSS    15
MLICON    BSS    15
ISSUECNT  BSS    1
NTHSR     DATA   -2
REISSUE   DATA   0
WMLI      DATA   0
BLOCKS    DATA   0
WORDS     DATA   0
STIME     BSS    1
ETIME     BSS    1

M3        DATA   10HCIO ERROR
M4        BSSZ   2

M5        DATA   10HPFSEND
M6        BSS    1
M7        BSS    1
M8        BSS    1
M9        BSS    1
M10       DATA   0
          DATA   0
M13       DATA   20HREC ARBINFO ERROR
M14       BSS    1
          DATA   0
SMASK     VFD    60/1014040B
RMASK     VFD    60/40040B
MMASK     VFD    60/0
          EXT    PARSV
DSTSA     EQU    PARSV+3
STSA      EQU    DSTSA+1
EOI       DATA   0
          SKIP   RA.MTR
          ERR    SYSCOM WAS NOT CALLED
TAB       VFD    42/0,6/5,11/0,1/1
          BSSZ   4
FLEN      DATA   0

* PROCEDURE PFSEND (LFN
*                   AN170
*                   AN180
*               VAR DSTS
*               VAR STS)
* STS: 0=OK, 1=MLI ERROR, 2=IO ERROR
*
          ENTRY  PFSEND
PFSEND    BSS    0
          RJ     =XPXSAVE
          BX6    X2
          BX7    X3
          SA6    MLIPAR+MLPAN
          SA7    MLIPAR+MLPSN
          MX6    0
          SA6    X5          SET STATUS OK

          R=     X6,AIMOI
          R=     X7,MLSOK
          SA6    MLIPAR+MLPAR
          SX6    100
          SA6    MLIPAR+MLPSG
          SX6    MLFSE
          SA6    MLIPAR+MLPFN
          SA7    MLIPAR+MLPSV
*
          SA2    FETA
          MX0    42
          BX3    -X0*X2
          LX1    18
          BX6    X1+X3
          SA6    FETB
          SA6    A2
*
          SA1    =10HPFSEND
          BX6    X1
          SA6    M5
          SA1    SMASK
          BX7    X1
          SA7    MMASK
          RTIME  STIME

* SEND FILE LENGTH TO NOSVE

          SA1    FETA
          IF     DEF,RA.ORG,2
          SX3    50000B      NO COMPLETE BIT FOR NOS/BE
          SKIP   1
          SX3    50001B      SET COMPLETE BIT FOR NOS
          MX0    42
          BX2    X0*X1
          BX6    X3+X2
          SA6    TAB
          FILINFO TAB
          SA1    TAB+3
          MX0    24
          BX6    X0*X1
          LX6    24
          SA6    FLEN
          SX7    B1
          SX6    FLEN
          SA6    MLIPAR+MLPFA
          SA7    MLIPAR+MLPBL
          RJ     ISSUE
          CKMST  MMASK

          REWIND FETA,R
          READ   FETA,R

LOOP      BSS    0
          RESET  FETB
          READ   FETB
          SMSG   HWA,FETA,BUFA
          RECALL FETB
          CKMST  MMASK

          RESET  FETA
          READ   FETA
          SMSG   HWB,FETB,BUFB
          RECALL FETA
          CKMST  MMASK
          EQ     LOOP

* PROCEDURE PFREC

          ENTRY  PFREC
PFREC     BSS    0
          RJ     =XPXSAVE
          BX6    X2
          BX7    X3
          SA6    MLIPAR+MLPAN
          SA6    MLICON+MLPAN
          SA7    MLIPAR+MLPSN
          SA7    MLICON+MLPSN
          MX6    0
          SA6    X5          SET STATUS OK

          SA6    MLIPAR+MLPRI  RECEIVE INDEX
          SX6    100
          SA6    MLIPAR+MLPSG
          SX6    MLFRE
          SA6    MLIPAR+MLPFN
          SX6    MLSOK
          SA6    MLIPAR+MLPSV
          SX6    BUFSIZ
          SA6    MLIPAR+MLPBL  BUFFER LENGTH
*
          SA2    FETA
          MX0    42
          BX3    -X0*X2
          LX1    18
          BX6    X1+X3
          SA6    FETB
          SA6    A2
*
          SA1    =10HPFREC
          BX6    X1
          SA6    M5
          SA1    RMASK
          BX7    X1
          SA7    MMASK
          RTIME  STIME
          REWIND FETA,R

RLOOP     BSS    0
          RECM   BUFA
          RECALL FETB
          CKIOST FETB
          CKMST  MMASK
          WRITF  FETA,HWA

          RECM   BUFB
          RECALL FETA
          CKIOST FETA
          CKMST  MMASK
          WRITF  FETB,HWB
          EQ     RLOOP

RAIERR    BSS    0
          SA1    MLIPAR+MLPV2
          RJ     CDD
          SA6    M14
          MESSAGE M13,0,R
          EQ     EXIT

MLERR     BSS    0
          SX6    B1
          SA1    STSA
          SA6    X1
          SA2    MLIPAR+MLPSV
          SA3    DSTSA
          BX6    X2
          SA6    X3
          MX6    0
          BX1    X2
          SA6    MLIPAR+MLPSV  TO PREVENT LOOP WITH EXIT/CKMST/MLERR
          RJ     CDD
          EQ     EXIT

IOERR     BSS    0
          SX6    2
          SA1    STSA
          SA6    X1
          BX6    X2
          SA3    DSTSA
          SA6    X3
          BX1    X2
          RJ     CDD
          SA6    M4
          MESSAGE M3,0,R
          EQ     EXIT

EXIT      BSS    0
          CKMST  MMASK
          RECALL FETA
          RECALL FETB
          RTIME  ETIME
          SA1    REISSUE
          RJ     CDD
          SA6    M6
          SA1    WMLI
          RJ     CDD
          SA6    M7
          SA1    BLOCKS
          RJ     CDD
          SA6    M8
          SA1    WORDS
          RJ     CDD
          SA6    M9
          SA1    STIME
          SA2    ETIME
          AX1    36
          AX2    36
          IX3    X2-X1
          ZR     X3,EXIT1    IF ET=0
          SA4    WORDS
          IX1    X4/X3
          RJ     CDD
          SA6    M10
EXIT1     BSS    0
          MESSAGE M5,0,R
          RJ     =XPXRSTR

ISSUE2    BX6    X4
          SA6    NTHSR
ISSUE     BSS    1
ISSUECT   SX6    -100D
          SA6    ISSUECNT
ISSUE0    BSS    0
          SA1    NTHSR
          PL     X1,ISSUE3   IF REQUEST OUTSTANDING
          SX4    0
          SX2    MLIPAR
          CALLVS X2,X4,CVSMLIU,0
          ZR     X0,ISSUE    IF REQUEST COMPLETE
          LX0    29
          AX0    30
          MI     X0,ISSUE1   IF NOS/VE DOWN
          NZ     X0,ISSUE2   IF REQUEST NOT COMPLETE
          SA1    ISSUECNT
          SX6    X1+B1
          SA6    A1
          MI     X6,ISSUE02
*   CALL CONFIRM SEND.
          SA1    MLIPAR+MLPST
          SX6    MLFCO
          SA6    MLICON+MLPFN
          SX2    MLICON
          SX4    0
          CALLVS X2,X4,CVSMLIU,0
          NZ     X0,ISSUE02
          SA5    MLICON+MLPSV
          SX6    X5
          SX5    X5-MLSRN
          SA5    MLIPAR+MLPSV
          ZR     X5,ISSUE
          SX6    -100D
          SA6    ISSUECNT
ISSUE02   RECALL
          EQ     ISSUE0

ISSUE1    BSS    0
          SX6    MLSND
          SA6    MLIPAR+MLPSV
          EQ     ISSUE

ISSUE3    BSS    0
          MESSAGE (=C* REQ W/REQ OUTSTANDING*),3,R
          ABORT

**********************************************

POLL1     SX6    -2
          SA6    NTHSR
POLL      BSS    1
          SA4    NTHSR
          NG     X4,POLL     IF NO REQUEST
          SX1    MLIPAR
          CALLVS X1,X4,CVSMLIU,0
          ZR     X0,POLL1    IF REQUEST COMPLETE
          AX0    30
          ZR     X0,POLL     IF NOSVE UP
          SX6    MLSND
          SA6    MLIPAR+MLPSV
          EQ     POLL
          END
*DECK DECK=RHA$MLI_TO_FILE EXPAND=FALSE
CKIOST    MACRO  FET
          LOCAL  CONT
          SA1    FET+0
          MX6    5
          LX1    46
          BX1    X6*X1
          ZR     X1,CONT     IF NO IO STATUS
          AX1    56
          NZ     X1,IOERR    IF ERROR
          SA6    EOI         SET EOI FLAG
CONT      BSS    0
          ENDM

RESET     MACRO  FET
          SA1    FET+1
          SX6    X1
          SA6    A1+B1
          SA6    A6+B1
          ENDM

CKMST     MACRO  MASK
          LOCAL  READY,BEGIN,DONE,RCLP,RCLCNT
BEGIN     BSS    0
          SA1    NTHSR
          NG     X1,READY    IF REQUEST COMPLETE
          RJ     POLL
          SA1    NTHSR
          NG     X1,READY    IF REQUEST COMPLETE
          SA1    WMLI
          SX6    X1+B1
          SA6    A1
          RECALL
          EQ     BEGIN

READY     BSS    0
          SA1    MLIPAR+MLPSV
          ZR     X1,DONE     IF MLI STATUS OK
          SA2    MASK
          SB4    X1
          SX0    B1
          LX0    B4,X0
          BX2    X2*X0
          ZR     X2,MLERR    IF NON RETRY MLI ERROR

* REISSUE REQUEST

          SA1    REISSUE
          SX6    X1+B1
          SA6    A1

* WAIT FOR A WHILE - 180 HAS UP TO 3 BLOCKS TO CATCH UP

NOSBE     IF     DEF,RA.ORG
          SYSTEM RCL,,600    WAIT 150 MSEC.
NOSBE     ELSE
          SX6    6           6 RECALLS
RCLP      SA6    RCLCNT
          RECALL
          SA1    RCLCNT
          SX6    X1-1
          NZ     X6,RCLP     IF MORE
NOSBE     ENDIF
          RJ     ISSUE
          EQ     BEGIN
NOS       IF     -DEF,RA.ORG,1
RCLCNT    BSS    1
DONE      BSS    0
          ENDM

SEND      MACRO  HW,BUF
          SA1    HW
          SX6    BUF         ADDRESS
***          SX7    X1+1        (HEADER+DATA)+TRAILER
          SX7    X1
          SA6    MLIPAR+MLPFA
          SA7    MLIPAR+MLPBL
          RJ     ISSUE
          ENDM

SMSG      MACRO  HW,FET,BUF
          LOCAL  NOTEOI
          CKIOST FET
          SA1    FET+1
          SA2    A1+B1
          SX1    X1
          IX6    X2-X1
***          SX6    X6+1        DATA+HEADER
          SA6    HW
          SA1    BLOCKS
          SA2    WORDS
          IX6    X6+X2
          SX7    X1+B1
          SA7    A1
          SA6    A2
          SA1    EOI
          ZR     X1,NOTEOI
          SX6    AIEOI
          SA6    MLIPAR+MLPAR
NOTEOI    BSS    0
          SEND   HW,BUF
          SA1    EOI
          NZ     X1,EXIT     IF SENT EOI BLOCK
          ENDM

RECM      MACRO  HW
***          MX7    0
***          SA7    HW          CLEAR HEADER WORD (LENGTH)
          SX6    HW
          SA6    MLIPAR+MLPFA
          RJ     ISSUE
          ENDM

WRITF     MACRO  FET,HW
          LOCAL  WEOI,QQQ,WEOR
***          SX2    1
***          SA1    HW
***          MX0    22
***          LX0    22
***          BX3    X1*X0
***          IX3    X3-X2       LENGTH
          SA3    MLIPAR+MLPV1  LENGTH
          SA4    FET+1
          SX6    X4
          IX7    X6+X3
          SA7    A4+B1       IN=FIRST+LENGTH
          SA6    A7+B1       OUT=FIRST
          SA2    BLOCKS
          SX6    X2+B1
          SA6    A2
          SA2    WORDS
          IX6    X2+X3
          SA6    A2

          SA1    MLIPAR+MLPV2 ARB INFO
          BX6    X1
          SA6    MLIPAR+MLPAR FOR USE BY EXIT
          SX2    X1-AIEOI
          ZR     X2,WEOI     IF EOI
          SX2    X1-AIMOI
          NZ     X2,RAIERR   AI NOT EOI/MOI
          MX0    54D
          BX0    -X0*X3
          NZ     X0,WEOR     IF LENGTH NOT 0 MOD 64
          WRITE  FET
          EQ     QQQ

WEOI      BSS    0
          ZR     X3,EXIT     IF NO DATA
          WRITER FET,R
          EQ     EXIT

WEOR      WRITER FET
QQQ       BSS    0
          ENDM
*DECK DECK=RHA$NOSBE_MACRO_INTERFACE EXPAND=TRUE
          IDENT  RHABEIO
          TITLE  RHA$NOSBE MACRO INTERFACE - NOSBE REQUEST/ATTACH/CATALOG
          SYSCOM B1
          LIST   F
*copyc dsa$cybil_if_macros
          IF     DEF,RA.ORG,1
OPL       XTEXT  PFCOM
          ENTRY  RHPREQ,RHPATT,RHPCAT
          SPACE  2
*     THE PURPOSE OF THIS ROUTINE IS TO PROVIDE AN INTERFACE
* BETWEEN A CYBIL PROCEDURE AND THE NOS/BE REQUEST MACRO.
*
*         RHPREQ  (REQUEST_PARAMETER_BLOCK)

RHPREQ    BSS
          IF     DEF,RA.ORG,3
          RJ     =XPXSAVE
          REQUEST  X1
          EQ     =XZSMRRET         RETURN TO CALLING CYBIL PROGRAM
          SPACE  3,10
*     THE NEXT 2 ROUTINES PERFORM GET/REPLACE PF ACTIVITY FOR
* NOS/BE. THE NOS VERSION PROVIDES THE ENTRY POINTS ONLY FOR
* COMPATIBILITY AND PROTECTION DURING LOAD AND EXECUTION.
*
*         RHPATT (LFN,PFN,ID,CYCLE,PW1,PW2,CONDITION)
*         RHPCAT (LFN,PFN,ID,CYCLE,PW1,PW2,CONDITION)
* *** WARNING *** LFN 'ZZZZPFP' SHOULD NOT BE USED ANY TIME.

NOSSYS    IF     -DEF,RA.ORG
RHPATT    BSS    0
RHPCAT    SHORTEX                  QUICK RETURN TO CYBIL
NOSSYS    ELSE

FINDRC    MACRO
          SA2    FDB
          MX6    51
          AX2    9
          BX6    -X6*X2
          ENDM

BYZ  MACRO  INPUT,BLNKS,FIVES,MASKX,OUTPT
     SX_MASKX  B1
     BX_OUTPT  X_INPUT-X_BLNKS
     IX_MASKX  X_OUTPT-X_MASKX
     BX_OUTPT  -X_MASKX+X_OUTPT
     BX_MASKX  X_FIVES*X_OUTPT
     BX_OUTPT  X_MASKX
     LX_OUTPT  55D
     IX_OUTPT  X_MASKX-X_OUTPT
     BX_MASKX  X_MASKX+X_OUTPT
     BX_OUTPT  X_MASKX*X_INPUT
BYZ  ENDM

          ENTRY  PFM=              SATISFY UNUSED (NOS) ENTRY
PFM=      BSS    1                 DO NOTHING
          SHORTEX
RHPATT    RJ     =XPXSAVE
          MX7    0                 FLAG ATTACH OPERATION
          EQ     MAIN
RHPCAT    RJ     =XPXSAVE
          MX7    54                FLAG NON-ATTACH (CATALOG)
*--- SET ATTACH/CATALOG FLAG .FALSE. FOR ATTACH
MAIN      SA7    CATFLAG
*--- CONVERT CYCLE TO BINARY AND SAVE ( 4TH PARAMETER )
          SA2    X2                FETCH CYCLE IN DISPLAY CODE
          MX6    0                 PRESET BINARY VALUE
          MX7    54
          SB3    3                 LOOP COUNTER
CYLOOP    LX2    6
          BX1    -X7*X2
          SX1    X1-55B
          ZR     X1,CYOUT          BLANK MEANS TERMINATOR
          SX1    X1+22B            BINARY FOR DIGIT
          LX6    1
          IX1    X1+X6
          LX6    2
          IX6    X6+X1             GIVES PREVIOUS * 10 + LAST DIGIT
          SB3    B3-B1
          GT     B3,CYLOOP
CYOUT     LX6    6                 ALLOW FOR KEY TO BE ADDED
          SB4    X6                SAVE CYCLE * 100B
          SX6    X6+CYKEY
          SA6    FDB+2             CYCLE PROCESSING COMPLETE
*--- FDB[0] = LFN     ( 1ST PARAMETER )
          SA1    B5                FETCH LFN
          MX7    42D
          SA4    =10H              - BLANKS -
          LX1    18D
          BX6    X1*X7
          BX1    -X7*X4            3R BLANKS
          BX6    X6+X1
          SA6    FDB
*--- FDB[-4..-1] = PFN     ( 2ND PARAMETER )
          SA1    B5+B1             FETCH PFN
          SA1    X1
          SA2    A1+B1
          BX6    X1
          BX7    X2
          SA1    A2+B1
          SA6    FDB-4
          SA2    A1+B1
          SA7    A6+B1
          BX6    X1
          SA6    A7+B1
          MX7    6
          BX1    -X7*X4            9R BLANKS
          BX7    X7*X2
          BX7    X7+X1
          SA7    A6+B1             PFN IS NOW STORED IN FDB[-4..-1]
          SA2    =10H5555555555
*--- BLANK_TO_ZERO LFN
          MX7    6
          SA1    FDB
          BX6    X1-X4
          BX6    X6*X7
          ZR     X6,NOLFN
          BYZ    1,4,2,0,6
NOLFN     SA6    A1                LFN IS NOW ZERO PADDED
*--- FOR I = 1 TO 4 DO
*---     IF FDB[-I].BYTE0 = BLANK THEN  FDB[-I] = 0
*---                              ELSE BLANK_TO_ZERO FDB[I]
*---                                   EXIT FOR_LOOP
*---     IFEND
*--- FOREND
          SB3    4                 LOOP COUNTER
NEXTPFN   SA1    A1-B1
          BX6    X1-X4
          MX7    6
          BX6    X6*X7
          NZ     X6,PFNDONE        FOUND PFN WORD WITH SIGNIFICANCE
          SA6    A1
          SB3    B3-B1
          GT     B3,NEXTPFN
          EQ     NOPFN
PFNDONE   BYZ    1,4,2,0,6
          SA6    A1                PFN PROCESSING COMPLETED
*--- REFORMAT ID     ( 3RD PARAMETER )
*--- FDB[1] = ID + 14B
NOPFN     SA1    =XPARSV
          SB5    =XPARSV+3         PW2 POINTER
          SA1    X1                GET ID
          RJ     FORMAT
          SX1    IDKEY
          BX6    X6+X1
          SA6    FDB+1             ID PROCESSING COMPLETED
* NOW CHECK FOR LFN/PFN NONZERO AND SET DEFAULT IF ZERO.
*--- IF FDB[0]=0 THEN FDB[0]=MASK(42).AND.FDB[-4]
*--- IF FDB[-4]=0 THEN FDB[-4]=FDB[0]
          SA1    FDB               LFN
          SA3    FDB-4             1ST WORD OF PFN
          NZ     X1,HAVELFN
          MX6    42
          BX6    X6*X3
          SA6    A1
HAVELFN   NZ     X3,HAVEPFN
          BX6    X1
          SA6    A3
HAVEPFN   SA1    A1
          BX6    X1
          SA6    SAVELFN
*--- REFORMAT TURNKEY   ( 5TH PARAMETER )
          SA1    B5-B1             FETCH TURNKEY PARAMETER
          SA1    X1
          RJ     FORMAT
*--- INDEX = 3;  KEY = 20B
          SB3    3
          SX5    PWKEY
*--- IF TURNKEY <> 0 THEN  FDB[INDEX] = TURNKEY + 04B
*---                       FDB[INDEX+1] = TURNKEY + KEY
*---                       INDEX = INDEX + 2
*---                       KEY = KEY + 1
          ZR     X6,NOPW1          TURNKEY OR 1ST PASSWORD NOT THERE
          SX1    TKKEY
          BX7    X6+X1             ADD TK KEY
          SA7    FDB+B3
          BX6    X6+X5             ADD PW KEY
          SA6    A7+B1
          SX5    X5+B1             INCREMENT PW KEY
          SB3    B3+2              INCREMENT INDEX
*--- REFORMAT PASSWORD     ( 6TH PARAMETER )
NOPW1     SA1    B5
          SA1    X1
          RJ     FORMAT
*--- IF PASSWORD <> 0 THEN  FDB[INDEX] = PASSWORD + 10B
*---                        FDB[INDEX+1] = PASSWORD + KEY
*---                        INDEX = INDEX + 2
*---             IF CATALOG THEN FDB[INDEX-2] = FDB[INDEX-2] + 03B
          ZR     X6,NOPW2          NO 2ND PASSWORD
          SB3    B3+2              INCREMENT INDEX
          SX1    RDKEY
          BX7    X6+X5             ADD PW KEY
          BX6    X6+X1             ADD RD KEY
          SA3    CATFLAG
          PL     X3,WASATT
          SX1    XRKEY-RDKEY
          IX6    X6+X1             CHANGE RD KEY INTO XR KEY
WASATT    SA6    FDB-2+B3
          SA7    A6+B1
*--- FDB[INDEX] = 0   ( TERMINATOR )
          MX6    0
NOPW2     SA6    FDB+B3
*
* END OF FDB SETUP FOR BOTH ATTACH AND CATALOG.
*
          REPRIEVE RPVPARM,SETUP,20B
          SA3    CATFLAG
          MI     X3,CATALOG
          ATTACH FDB,RC,RT
          FINDRC
          NZ     X6,GOSETRC
          PERM   FDB,RC
          FINDRC
          BX7    X6
          MX6    0
          LX7    59-0              READ PERMISSION BIT
          NG     X7,GOSETRC
          SX6    71B
GOSETRC   SA1    B5+B1             FETCH RC POINTER
          SA6    X1                STORE CYBIL CONDITION CODE
          EQ     =XZSMRRET         RETURN TO CALLING CYBIL PROGRAM
CATALOG   ZR     B4,GOCAT          ZERO OR NO CYCLE SPECIFIED
GOPURGE   SA1    TEMPLFN
          MX7    1
          LX7    18D
          BX6    X1
          IX7    X7+X1
          SA6    FDB
          SA7    A1
          PURGE  FDB,RC,RT
          FINDRC                   GET RETURN CODE IN X6
          ZR     X6,GOCAT
          SX7    X6-12B            FILE NOT CATALOGUED
          NZ     X7,GOSETRC
GOCAT     SA1    SAVELFN
          BX6    X1
          SA6    FDB               RESTORE GOOD LFN
          SX7    B4+CYKEY
          SA7    FDB+2             RESTORE GOOD CYCLE
          CATALOG FDB,RC,RT
          FINDRC                   GET RETURN CODE IN X6
          SX7    X6-4              NO ROOM FOR EXTRA CYCLE
          NZ     X7,GOSETRC
          SX7    LCKEY+100B
          SA7    FDB+2             SET LC=1
          EQ     GOPURGE
*
FORMAT    BSSZ   1
          BX6    X1-X4
          MX7    6
          BX6    X6*X7
          LX7    12
          ZR     X6,FORMAT         LEADING BLANK DETECTED
          MX6    54
          BX3    -X6*X4            ONE BLANK RIGHT JUSTIFIED
          BX1    X6*X1             LEFT 54 BITS
          BX1    X1+X3
          BYZ    1,4,2,0,6
CHZERO    BX3    X7*X6
          NZ     X3,FORMAT         IS RIGHT JUSTIFIED TO BIT 6 NOW
          LX6    54
          EQ     CHZERO
*
RPVPARM   VFD    42/31B,18/0       * REPRIEVE  *
          VFD    60/MYRPV          * PARAMETER *
          BSSZ   27B               *   BLOCK   *
MYRPV     BSS    0
          REPRIEVE RPVPARM,RESUME,77B
*
TEMPLFN   VFD    42/0LZZZZPFP,18/0
CATFLAG   BSS    1
SAVELFN   BSS    5                 KEEP THESE 2 LINES TOGETHER
FDB       BSSZ   8                 ---------------------------
* FOLLOWING KEYS ARE LISTED IN THE NOS/BE 1 RM CHAPTER 7
*            UNDER THE *FDB* MACRO (CURRENTLY PAGE 7-86).
CYKEY     EQU    03B
TKKEY     EQU    04B
RDKEY     EQU    10B
XRKEY     EQU    13B
IDKEY     EQU    14B
PWKEY     EQU    20B
LCKEY     EQU    31B
NOSSYS    ENDIF
          END
*DECK DECK=RHA$SAVE_QUEUE_PRIORITY EXPAND=TRUE

          IDENT  RHAQPR
          ENTRY  SETQP
          ENTRY  RSTRQP
          SST
* MODQP
*
*     THE PURPOSE OF THIS MODULE IS TO PROVIDE A MEANS BY WHICH AN
* A170 COMPASS ROUTINE CAN SAVE ITS CURRENT QUEUE PRIORITY, SET ITS
* QUEUE PRIORITY TO MXPS+1, AND RESTORE ITS QUEUE PRIORITY TO ITS
* ORIGINAL VALUE.
*
*
* SETQP
*
*     THE PURPOSE OF THIS A170 COMPASS ROUTINE IS TO SAVE THE CURRENT
* QUEUE PRIORITY AND SET THE QUEUE PRIORITY TO MXPS+1.
*
 SETQP    BSS    1
          GETQP  SAVEQP              SAVE CURRENT QUEUE PRIORITY
          SETQP  MXPS+1              SET QUEUE PRIORITY TO MXPS+1
          EQ     SETQP
*
* RSTRQP
*
*     THE PURPOSE OF THIS A170 COMPASS ROUTINE IS TO RESTORE THE
* QUEUE PRIORITY OF AN A170 JOB TO ITS ORIGINAL VALUE.  IT IS ASSUMED
* THE ORIGINAL QUEUE PRIORITY WAS SAVED VIA A PREVIOUS CALL TO SETQP.
*
 RSTRQP   BSS    1
          SA5    SAVEQP
          SETQP  X5
          EQ     RSTRQP
*
* SAVEQP
*
*     THIS WORD OF MEMORY IS THE LOCATION IN WHICH THE CURRENT QUEUE
* PRIORITY IS SAVED BY SETQP AND RETREIVED BY RSTRQP.
*
 SAVEQP   BSSZ   1
*
          END
*DECK DECK=RHA$SET_DSMRUN_TO_SSJ EXPAND=TRUE
          IDENT  RHASDTS
*IF ($string($name(wev$target_operating_system))='NOS')
          TITLE  RHA$SET DSMRUN TO SSJ
          ENTRY  SSJ=,DSMRUN
DSMRUN    EQ     =XSW=MAIN
SSJ=      EQU    0
*IFEND
          END
*DECK DECK=RHA$VALIDATE_FAMILY EXPAND=TRUE

          IDENT  RHAVFAM
*IF ($string($name(wev$target_operating_system))='NOS')
          TITLE  RHA$VALIDATE FAMILY
          ENTRY  RHPVFAM
* RHPVFAM
*
*      THE PURPOSE OF THIS A170 COMPASS ROUTINE IS TO CALL THE
* GETPFP NOS MACRO IN ORDER TO GET THE DEFAULT FAMILY AND USER
* THAT IRHF 170 IS RUNNING UNDER.
*
*
 RHPVFAM  BSS    0
*
* SAVE CYBIL ENVIRONMENT
*
          RJ      =XPXSAVE
* CALL NOS A170 MACRO
          BX0     X1
          ENFAM   X0
* RESTORE CYBIL ENVIRONMENT
          RJ      =XPXRSTR
* RETURN TO CALLING PROCEDURE
          JP      B7
*IFEND
          END
*DECK DECK=RHC$CONDITION_LIMITS EXPAND=FALSE


*copyc RHE$CONDITION_CODES
?? NEWTITLE := 'Miscellaneous         : ''RH'' 0 .. 9999', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    rhc$remote_host_id = 'RH',
    rhc$min_ecc_rhf                    = rhc$min_ecc + 0,

    rhe$missing_file                   = rhc$min_ecc_rhf + 0,
    {E The NOS/170 file specified could not be found.}

    rhe$cycle_busy                     = rhc$min_ecc_rhf + 1,
    {E The NOS/170 file specified is busy.}

    rhe$file_io_error                  = rhc$min_ecc_rhf + 2,
    {E A NOS/170 i/o error occurred processing this file.}

    rhe$too_many_permanent_files       = rhc$min_ecc_rhf + 3,
    {E The NOS/170 limit of permanent files has been exceeded.}

    rhe$too_much_pf_storage            = rhc$min_ecc_rhf + 4,
    {E The NOS/170 limit for permanent file storage has been exceeded.}

    rhe$permanent_file_too_large       = rhc$min_ecc_rhf + 5,
    {E The length of the file exceeds the NOS/170 limit allowed.}

    rhe$rh_system_error                = rhc$min_ecc_rhf + 6,
    {E An error internal to remote host has occurred.}

    rhe$mass_storage_unavailable       = rhc$min_ecc_rhf + 7,
    {E The amount of mass storage required is unavailable.}

    rhe$file_error                     = rhc$min_ecc_rhf + 8,
    {E An error occurred referencing the NOS/170 file.}

    rhe$unable_to_communicate          = rhc$min_ecc_rhf + 9,
    {E Unable to communicate with NOS/170 Remote Host.}

    rhe$terminal_break_occurred        = rhc$min_ecc_rhf + 10,
    {E The user terminated this command with a break.}

    rhe$partner_job_not_executing      = rhc$min_ecc_rhf + 11,
    {E Not able to communicate with the NOS/170 partner job.}

    rhe$open_position_conflict         = rhc$min_ecc_rhf + 12,
    {E Replace_file at other than $boi not allowed, file +P.}

    rhe$unable_to_route_file           = rhc$min_ecc_rhf + 13,
    {E IRHF170 was unable to route to nos's output queue}
    { the nos/ve print file +P.}

    rhe$unable_to_complete_transfer    = rhc$min_ecc_rhf + 14,
    {E Irhf encountered error trying to transfer a print file for}
    { user +P.  The file was purged.}

    rhe$purged_file                    = rhc$min_ecc_rhf + 15,
    {E The file +P was purged from NOS's queue.}

    rhe$no_ml_free_entries_found       = rhc$min_ecc_rhf + 16,
    {E The transfer wanted cannot be done due to no memory link}
    { table space being available.}

    rhe$unexpected_ml_error            = rhc$min_ecc_rhf + 17,
    {E The transfer wanted cannot be done due to an unexpected internal}
    { system status +P.}

    rhe$no_partner_exists              = rhc$min_ecc_rhf + 18,
    {E The system is not running NOS or NOS/BE dual state, so the}
    { +P command is not available.}

    rhe$mismatching_code               = rhc$min_ecc_rhf + 19,
    {E A problem occurred during file transfer.  Contact your site analyst.}

    rhe$receiver_already_signed_on     = rhc$min_ecc_rhf + 20,
    {E The +P partner job is already signed on to the memory link but by a}
    { different application name.  Retry the command or contact your site}
    { analyst.}

    rhe$receiver_not_signed_on         = rhc$min_ecc_rhf + 21,
    {E A problem occurred on the +P side - check your +P validations or}
    { your +P file being busy.}

    rhe$pause_break_received           = rhc$min_ecc_rhf + 22,
    {E A pause break was received during GET_FILE or REPLACE_FILE execution.}
    { The file transfer was terminated.}

    rhe$terminal_connection_broken     = rhc$min_ecc_rhf + 23,
    {E A terminal disconnect was received during GET_FILE or REPLACE_FILE}
    { execution.  The file transfer was terminated.}

    rhe$lud_cannot_be_found = rhc$min_ecc_rhf + 24,
    {E No LINK_USER entry has been defined for family (+P).}

?? TITLE := '      NOS/BE file error codes      :''RH'' + 50 .. ''RH'' + 99' ??

    rhe$id_error                        = rhc$min_ecc_rhf + 50,
    {E The NOS/BE permanent file OWNER IDENTIFICATION (ID) is in error.}

    rhe$unknown_lfn                     = rhc$min_ecc_rhf + 51,
    {E The NOS/BE local file name (LFN) is unknown.}

    rhe$pfc_full                        = rhc$min_ecc_rhf + 52,
    {E The NOS/BE permanent file catalog (PFC) is full.}

    rhe$file_not_cataloged              = rhc$min_ecc_rhf + 53,
    {E The NOS/BE file is not cataloged.}

    rhe$cycle_number_over_999           = rhc$min_ecc_rhf + 54,
    {E The NOS/BE file cycle limit (999) was reached.}

    rhe$pfd_full                        = rhc$min_ecc_rhf + 55,
    {E The NOS/BE permanent file directory (PFD) is full.}

    rhe$cycle_incomplete                = rhc$min_ecc_rhf + 57,
    {E The NOS/BE file cycle is incomplete or was dumped.}

    rhe$file_archived                   = rhc$min_ecc_rhf + 58,
    {E The NOS/BE permanent file being referenced is archived.}

    rhe$ill_char_in_fdb_param           = rhc$min_ecc_rhf + 59,
    {E An illegal character in one of the parameters was specified.}

    rhe$file_dumped                     = rhc$min_ecc_rhf + 60,
    {E The NOS/BE permanent file specified has been dumped.}

    rhe$no_apf_space                    = rhc$min_ecc_rhf + 61,
    {E NOS/BE has no APF space available.}

    rhe$permission_conflicts            = rhc$min_ecc_rhf + 62,
    {E The NOS/BE file is attached elsewhere with exclusive access.}

    rhe$rbt_chain_too_large             = rhc$min_ecc_rhf + 63,
    {E The NOS/BE file's RBT chain is too large for the PFC.}

    rhe$unavailable_device              = rhc$min_ecc_rhf + 64,
    {E The NOS/BE file specified resides on an unavailable device.}

    rhe$file_not_available              = rhc$min_ecc_rhf + 65,
    {E The NOS/BE file specified is not available.}

    rhe$pfm_stopped_by_system           = rhc$min_ecc_rhf + 66,
    {E The NOS/BE permanent file manager has been stopped by the system.}

    rhe$incorrect_permission            = rhc$min_ecc_rhf + 67,
    {E The NOS/BE permission given is incorrect.}

    rhe$io_error                        = rhc$min_ecc_rhf + 68;
    {E NOS/BE had an I/O error processing this request.}
*DECK DECK=RHC$CONSTANTS EXPAND=FALSE
*copyc MLD$MEMORY_LINK_DECLARATIONS
   CONST rhc$beginning_of_information=0,
         rhc$middle_of_information=1,
         rhc$end_of_information=2,
         rhc$completed=3,
         rhc$error=4,
         rhc$delete_file=5,
         rhc$max_messages=1,
         rhc$max_message_length=(mlc$max_message_length DIV (64 * 8)) * 64,
         rhc$ok=0,
         rhc$job_not_found=0,
         rhc$job_found=1,
         rhc$get_pf=0,
         rhc$replace_pf=1,
         rhc$submit_pj=0,
         rhc$status_pj=1,
       { rhc$receive_remote_output=010010001000010010010010001111(2),  {RHRRO}
       { rhc$send_input_to_remote=010010001000010011001001010010(2),   {RHSIR}
       { rhc$partner_job_processor=010010001000010000001010010000(2),  {RHPJP}
       { rhc$receive_remote_input=010010001000010010010010001001(2),   {RHRRI}
       { rhc$send_output_to_remote=010010001000010011001111010010(2);  {RHSOR}
 rhc$receive_remote_output=1,
 rhc$send_input_to_remote=2,
 rhc$partner_job_processor=3,
 rhc$receive_remote_input=4,
 rhc$send_output_to_remote=5;
{ ****************************** END OF COMMON DECK RHDCONS ************************ }
*DECK DECK=RHC$NOSBE_PF_ERROR_CODES EXPAND=FALSE

{ ZN7PFDB     Type definition for NOS/BE permanent file error codes. }

  CONST { NOS/BE permanent file manager error codes }
    n7c$fdb_file_found = 0(16),
    n7c$fdb_ok = 0(16),
    n7c$fdb_id_error = 1(16),
    n7c$fdb_lfn_already_in_use = 2(16),
    n7c$fdb_unknown_lfn = 3(16),
    n7c$fdb_over_five_cycle_limit = 4(16),
    n7c$fdb_pfc_full = 5(16),
    n7c$fdb_no_lfn_or_pfn = 6(16),
    n7c$fdb_not_used = 7(16),
    n7c$fdb_latest_index_not_writ = 8(16),
    n7c$fdb_file_not_on_pf_device = 9(16),
    n7c$fdb_file_not_cataloged = 0a(16),
    n7c$fdb_archive_retrieval_abort = 0b(16),
    n7c$fdb_bad_lpf_communication = 0c(16),
    n7c$fdb_cycle_number_over_999= 0d(16),
    n7c$fdb_pfd_full = 0e(16),
    n7c$fdb_req_tried_nonperm_file = 0f(16),
    n7c$fdb_req_tried_nonlocal_file = 10(16),
    n7c$fdb_illegal_retrieval_call = 11(16),
    n7c$fdb_file_not_assigned = 12(16),
    n7c$fdb_cycle_incomplete = 13(16),
    n7c$fdb_pf_already_attached = 14(16),
    n7c$fdb_file_archived = 15(16),
    n7c$fdb_ill_char_in_fdb_param = 16(16),
    n7c$fdb_illegal_lfn = 17(16),
    n7c$fdb_file_dumped = 18(16),
    n7c$fdb_illegal_function_code = 19(16),
    n7c$fdb_purge_attempt_ignored = 1a(16),
    n7c$fdb_exclusive_access_needed = 1b(16),
    n7c$fdb_fdb_is_too_large = 1c(16),
    n7c$fdb_file_already_in_system = 1d(16),
    n7c$fdb_no_apf_space = 1e(16),
    n7c$fdb_permission_conflicts = 1f(16),
    n7c$fdb_ill_setname_specified = 20(16),
    n7c$fdb_set_not_at_cont_point = 21(16),
    n7c$fdb_rbt_chain_too_large = 22(16),
    n7c$fdb_unavailable_device = 23(16),
    n7c$fdb_file_not_available = 24(16),
    n7c$fdb_reserved_45 = 25(16),
    n7c$fdb_reserved_46 = 26(16),
    n7c$fdb_reserved_47 = 27(16),
    n7c$fdb_reserved_50 = 28(16),
    n7c$fdb_reserved_51 = 29(16),
    n7c$fdb_reserved_52 = 2a(16),
    n7c$fdb_reserved_53 = 2b(16),
    n7c$fdb_reserved_54 = 2c(16),
    n7c$fdb_reserved_55 = 2d(16),
    n7c$fdb_reserved_56 = 2e(16),
    n7c$fdb_reserved_57 = 2f(16),
    n7c$fdb_reserved_60 = 30(16),
    n7c$fdb_reserved_61 = 31(16),
    n7c$fdb_reserved_62 = 32(16),
    n7c$fdb_reserved_63 = 33(16),
    n7c$fdb_reserved_64 = 34(16),
    n7c$fdb_reserved_65 = 35(16),
    n7c$fdb_reserved_66 = 36(16),
    n7c$fdb_reserved_67 = 37(16),
    n7c$fdb_pfm_stopped_by_system = 38(16),
    n7c$fdb_incorrect_permission = 39(16),
    n7c$fdb_fdb_address_error = 3a(16),
    n7c$fdb_io_error_on_pfd_or_pfc = 3b(16),
    n7c$fdb_reserved_74 = 3c(16),
    n7c$fdb_reserved_75 = 3d(16),
    n7c$fdb_reserved_76 = 3e(16),
    n7c$fdb_reserved_77 = 3f(16),
    n7c$fdb_reserved_100 = 40(16),
    n7c$fdb_reserved_101 = 41(16),
    n7c$fdb_reserved_102 = 42(16),
    n7c$fdb_reserved_103 = 43(16),
    n7c$fdb_reserved_104 = 44(16),
    n7c$fdb_reserved_105 = 45(16),
    n7c$fdb_reserved_106 = 46(16),
    n7c$fdb_reserved_107 = 47(16),
    n7c$fdb_reserved_110 = 48(16),
    n7c$fdb_reserved_111 = 49(16);

*DECK DECK=RHD$C170_FET EXPAND=FALSE
*copyc ZN7TFET
*DECK DECK=RHD$CONDITION_CODES EXPAND=FALSE

?? NEWTITLE := 'Remote Host Facility          : ''RH'' 0 .. 9999' ??
*copyc RHE$CONDITION_CODES
*copyc RHC$CONDITION_LIMITS
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=RHD$NOS_VE_TYPES EXPAND=FALSE
*copyc amt$file_identifier
*copyc amt$local_file_name
*copyc jmt$routing_external
*copyc mld$memory_link_declarations
*copyc rhc$constants
  { IRHF TYPES
  {
  {

  TYPE
    rht$status = (successful, non_fatal_error),
    rht$exec_status = (beginning, middle, unrecoverable_error),
    rht$mli_link_direction = (on, off),
    rht$file_data_buffer = array [1 .. rhc$max_message_length + 1] of integer,
    rht$file_data_buffer_pointer = ^rht$file_data_buffer,
    rht$file_position = mlt$arbitrary_info,
    rht$irhf_exec_types = (transmit_exec, receive_exec, pj_exec),
    rht$machine_types = (a170, c180, nuder),
    rht$pf_functions = rhc$get_pf .. rhc$replace_pf,
    rht$pj_functions = rhc$submit_pj .. rhc$status_pj,
    rht$ascii812_char = packed record
      filler: 0 .. 0f(16),
      ascii88_char: char,
    recend,
    rht$c180_ascii812_word = packed record
      filler: 0 .. 0f(16),
      ascii812_char1: rht$ascii812_char,
      ascii812_char2_5: packed array [2 .. 5] of rht$ascii812_char,
    recend,
    rht$mli_application_name = record
      case name_ref_type: (application_name, a170_id, c180_id) of
      = application_name =
        application_name: mlt$application_name,
      = a170_id =
        a170_id: packed record
          application_identifier: 0 .. 3fffffff(16),
          filler: 0 .. 3fffffff(16),
        recend,
      = c180_id =
        c180_id: packed record
          filler1: 0 .. 0f(16),
          application_identifier: 0 .. 3fffffff(16),
          filler2: 0 .. 3fffffff(16),
        recend,
      casend,
    recend,
    rht$mli_application_names = record
      application: rht$mli_application_name,
      destination: rht$mli_application_name,
    recend,
    rht$mli_message_info = record
      message_area: mlt$message_ptr,
      message_area_length: mlt$message_length,
      message_length: mlt$message_length,
      arbitrary_info: mlt$arbitrary_info,
    recend,
    rht$local_file_info = record
      case machine_type: rht$machine_types of
      = a170 =
        fet: integer,
      = c180 =
        local_file_name: amt$local_file_name,
        file_identifier: amt$file_identifier,
      casend,
    recend,
    rht$queue_file_info = record
      case machine_type: rht$machine_types of
      = a170 =
        a170: record
          file_name: record
            case machine_type: rht$machine_types of
            = a170 =
              a170_job_name: string (7),
            = c180 =
              c180_file_name: string (31),
            casend,
          recend,
          form_code: string (2),
          repeat_count: 0 .. jmc$routing_repeat_count_max,
          family_name_of_creator: record
            case machine_type: rht$machine_types of
            = a170 =
              a170_creator_family_name: string (9),
            = c180 =
              c180_creator_family_name: string (31),
            casend,
          recend,
        user_number_of_owner: record
          case machine_type: rht$machine_types of
          = a170 =
            a170_owner_user_num: string (9),
          = c180 =
            c180_owner_user_num: string (31),
          casend,
        recend,
        user_password: string(31),
        user_charge_number: string(31),
        user_project_number: string(31),
        original_family_name: record
          case machine_type: rht$machine_types of
          = a170 =
            a170_original_family_name: string (9),
          = c180 =
            c180_original_family_name: string (31),
          casend,
        recend,
        original_user_name: record
          case machine_type: rht$machine_types of
          = a170 =
            a170_original_user_name: string (9),
          = c180 =
            c180_original_user_name: string (31),
          casend,
        recend,
        original_charge_number: string(31),
        original_project_number: string(31),
        logical_identifier: record
          case machine_type: rht$machine_types of
          = a170 =
            a170_logical_identifier: string (3),
          = c180 =
            c180_logical_identifier: string (31),
          casend,
        recend,
        implicit_text_size: 0 .. 0fff(16),
        implicit_routing_text: string (256),
        dual_state_routing_text_size: 0 .. 0fff(16),
        dual_state_routing_text: string(255),
      recend,
      = c180 =
        c180: packed record
          file_name: record
            case machine_type: ALIGNED [0 MOD 8] rht$machine_types of
            = a170 =
              a170_job_name: ALIGNED [0 MOD 8] array [1 .. 2] of
                rht$c180_ascii812_word,
            = c180 =
              c180_file_name: ALIGNED [0 MOD 8] array [1 .. 7] of
                rht$c180_ascii812_word,
            casend,
          recend,
          filler2: 0 .. 0f(16),
          form_code_char1: rht$ascii812_char,
          form_code_char2: rht$ascii812_char,
          filler3: 0 .. 0fffffffff(16),
          repeat_count: integer,
          family_name_of_creator: record
            case machine_type: ALIGNED [0 MOD 8] rht$machine_types of
            = a170 =
              a170_creator_family_name: ALIGNED [0 MOD 8] array [1 .. 2] of
                rht$c180_ascii812_word,
            = c180 =
              c180_creator_family_name: ALIGNED [0 MOD 8] array [1 .. 7] of
                rht$c180_ascii812_word,
            casend,
          recend,
          user_number_of_owner: record
            case machine_type: ALIGNED [0 MOD 8] rht$machine_types of
            = a170 =
              a170_owner_user_num: ALIGNED [0 MOD 8] array [1 .. 2] of
                rht$c180_ascii812_word,
            = c180 =
              c180_owner_user_num: ALIGNED [0 MOD 8] array [1 .. 7] of
                rht$c180_ascii812_word,
            casend,
          recend,
        user_password: ALIGNED [0 MOD 8] array [1 .. 7] of
          rht$c180_ascii812_word,
        user_charge_number: ALIGNED [0 MOD 8] array [1 .. 7] of
          rht$c180_ascii812_word,
        user_project_number: ALIGNED [0 MOD 8] array [1 .. 7] of
          rht$c180_ascii812_word,
        original_family_name: record
          case machine_type: ALIGNED [0 MOD 8] rht$machine_types of
          = a170 =
            a170_original_family_name: ALIGNED [0 MOD 8] array [1 .. 2] of
              rht$c180_ascii812_word,
          = c180 =
            c180_original_family_name: ALIGNED [0 MOD 8] array [1 .. 7] of
              rht$c180_ascii812_word,
          casend,
        recend,
        original_user_name: record
          case machine_type: ALIGNED [0 MOD 8] rht$machine_types of
          = a170 =
            a170_original_user_name: ALIGNED [0 MOD 8] array [1 .. 2] of
              rht$c180_ascii812_word,
          = c180 =
            c180_original_user_name: ALIGNED [0 MOD 8] array [1 .. 7] of
              rht$c180_ascii812_word,
          casend,
        recend,
        original_charge_number: ALIGNED [0 MOD 8] array [1 .. 7] of
          rht$c180_ascii812_word,
        original_project_number: ALIGNED [0 MOD 8] array [1 .. 7] of
          rht$c180_ascii812_word,
        logical_identifier: record
          case machine_type: ALIGNED [0 MOD 8] rht$machine_types of
          = a170 =
            a170_logical_identifier: ALIGNED [0 MOD 8] array [1 .. 1] of
              rht$c180_ascii812_word,
          = c180 =
            c180_logical_identifier: ALIGNED [0 MOD 8] array [1 .. 7] of
              rht$c180_ascii812_word,
          casend,
        recend,
        filler9: 0 .. 0fffffffffffff(16),
        implicit_text_size: 0 .. 0fff(16),
        implicit_routing_text: ALIGNED [0 MOD 8] array [1 .. 52] of
            rht$c180_ascii812_word,
        filler10: 0 .. 0fffffffffffff(16),
        dual_state_routing_text_size: 0 .. 0fff(16),
        dual_state_routing_text: ALIGNED [0 MOD 8] array [1 .. 51] of
          rht$c180_ascii812_word,
      recend,
      = nuder =
        equalizer: ALIGNED [0 MOD 8] array [1 .. 184] of integer,
      casend,
    recend;

{ ***************************** END OF COMMON DECK RHDTYPE
{**************************** }
*DECK DECK=RHE$CONDITION_CODES EXPAND=FALSE

CONST
  rhc$min_ecc = (($INTEGER ('R') * 100(16)) + $INTEGER ('H')) * 1000000(16),
  rhc$max_ecc = rhc$min_ecc + 9999;

*DECK DECK=RHH$ACQUIRE_QUEUE_FILE EXPAND=FALSE
{
{ ACQUIRE_QUEUE_FILE
{
{     The purpose of this procedure is to acquire an output
{ queue file which is to be printed on the 170 side by NOS.
{ A banner page is also created and put on a local file.
{
{       ACQUIRE_QUEUE_FILE (LOCAL_FILE_INFO, BANNER_PAGE_FILE_INFO,
{        QUEUE_FILE_INFO, ACQUIRE_STATUS)
{
{ LOCAL_FILE_INFO: (output) This parameter specifies all information
{     pertinent to local file access of the acquired queue file.
{
{ BANNER_PAGE_FILE_INFO: (output) This parameter specifies all
{     information pertinent to the file used for the banner page.
{
{ QUEUE_FILE_INFO: (output) This parameter communicates all
{     queue file attributes needed for IRHF routing.
{
{ ACQUIRE_STATUS: (output) This parameter specifies the acquire
{     request status.  The following status values may be returned
{     by this request:
{          not_acquired
{          acquired

*DECK DECK=RHH$ASCII812_TO_ASCII88 EXPAND=FALSE
{
{ CONVERT_ASCII812_TO_ASCII88
{
{       The purpose of this procedure is to convert an A170 8/12 ascii string
{           to an 8/8 ascii string.
{
{       CONVERT_ASCII812_TO_ASCII88 (ASCII812_STRING,ASCII88_STRING,
{          CONVERSION_STATUS)
{
{ ASCII812_STRING: (input) This parameter contains the 8/12 ascii string which
{                  is to be converted.
{
{ ASCII88_STRING: (output) This parameter contains the 8/8 ascii string which
{                  is the result of the conversion.
{
{ CONVERSION_STATUS: (output) This parameter indicates the success or failure
{                    of the conversion.  If the output string is not large
{                    enough to complete the conversion of the entire input
{                    string then a status of non_fatal_error will be returned
{                    otherwise the conversion will be successful.  In either
{                    case, conversion of as much of the string as is
{                    possible will be performed.
{

*DECK DECK=RHH$ASCII88_TO_ASCII812 EXPAND=FALSE
{
{ CONVERT_ASCII88_TO_ASCII812
{
{       The purpose of this procedure is to convert an 8/8 ascii string to
{ an A170 8/12 ascii string.
{
{       CONVERT_ASCII88_TO_ASCII812 (ASCII88_STRING,ASCII812_STRING,
{          CONVERSION_STATUS)
{
{ ASCII88_STRING: (input) This parameter contains the 8/8 ascii string which
{                 is to be converted.
{
{ ASCII812_STRING: (output) This parameter contains the 8/12 ascii string which
{                  is the result of the conversion.
{
{ CONVERSION_STATUS: (output) This parameter indicates the success or failure
{                    of the conversion.  If the output string is not large
{                    enough to complete the conversion of the entire input
{                    input then a status of non_fatal_error will be returned
{                    otherwise the conversion will be successful.  In
{                    either case, conversion of as much of the string as
{                    is possible will be performed.
{

*DECK DECK=RHH$CHANGE_DUAL_STATE_ENVIRON EXPAND=FALSE
{
{  This procedure changes the site's dual state environment.
{
{         RHP$CHANGE_DUAL_STATE_ENVIRON (PARAMETER_LIST, STATUS);
{
{  PARAMETER_LIST: (input) This parameter is the list of parameters for the
{      command CHANGE_DUAL_STATE_ENVIRONMENT that was entered by a user.
{
{  STATUS: (output) This parameter specifies the request status.
{      Conditions: cle$wrong_kind_of_value
{

*DECK DECK=RHH$CHANGE_LINK_ATTRIBUTES EXPAND=FALSE
{
{  This procedure changes the user's link attributes in order to
{  use dual state commands.
{
{         RHP$CHANGE_LINK_ATTRIBUTES (PARAMETER_LIST, STATUS);
{
{  PARAMETER_LIST: (input) This parameter is the list of parameters for the
{      command CHANGE_LINK_ATTRIBUTES that was entered by a user.
{
{  STATUS: (output) This parameter specifies the request status.
{      Conditions: cle$wrong_kind_of_value
{                  cle$string_too_long
{
*DECK DECK=RHH$DISPLAY_LINK_ATTRIBUTES EXPAND=FALSE
{
{  This procedure displays the user's link attributes in order to
{  use dual state commands.
{
{         RHP$DISPLAY_LINK_ATTRIBUTES (PARAMETER_LIST, STATUS);
{
{  PARAMETER_LIST: (input) This parameter is the list of parameters for the
{      command DISPLAY_LINK_ATTRIBUTES that was entered by a user.
{
{  STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=RHH$FORM_A_LARGE_LETTER_ROW EXPAND=FALSE
{
{ FORM_A_LARGE_LETTER_ROW
{
{      This procedure will generate 10 large characters if called
{  10 times with row increased by 1 each time.  The first 10
{  characters of the input string will be converted to 10 large
{  characters.
{
{  NOTE: The characters used are determined on the first call
{            when ROW = 1.
{
{      FORM_A_LARGE_LETTER_ROW (INPUT_STRING, ROW, LINE, STATUS)
{
{  INPUT_STRING : (input) This parameter specifies the character
{     string to make large letters from.
{
{  ROW: (input) This parameter specifies the next row within the
{     large letters to use.
{
{  LINE (input) This parameter provides a buffer into which
{     the next row is to be generated.
{
{  STATUS: (output) This parameter returns the status of the request.
{
{       EXAMPLE CALL;
{
{         FOR row := 1 to 10 DO
{           form_a_large_letter_row (input_string, row, line, status);
{           amp$put_next (file_name, ^line,
{             line_length, byte_address, status);
{         FOREND;
{

*DECK DECK=RHH$GENERATE_BANNER EXPAND=FALSE
{
{ GENERATE_BANNER
{
{     This procedure generates a banner page for all output files
{ being sent to NOS/170 for printing.
{
{          GENERATE_BANNER (BANNER_FILE_INFO, INPUT_STRING,
{            INCLUDE_NOTICE, STATUS)
{
{ BANNER_FILE_INFO: (input) This parameter specifies all information
{     required to create the banner file.
{
{ INPUT_STRING: (input) This parameter is a string of 31 characters
{     that identify the user name to be put on the banner.
{
{ INCLUDE_NOTICE: (input) This parameter indicates if a notice,
{      indicating errors occurred when processing the data file,
{      should be put on the banner.
{
{ STATUS: (output) This parameter returns the status of the request.
{

*DECK DECK=RHH$GET_DISPLAY_LINK_ATTR_VALUE EXPAND=FALSE
{
{  This procedure gets the values of which link attributes a site will
{  allow a user to display using the DISPLAY_LINK_ATTRIBUTES command.
{  This is the ring 3 procedure interface.
{
{         RHP$GET_DISPLAY_LINK_ATTR_VALUE (DISPLAY_CHARGE, DISPLAY_FAMILY,
{             DISPLAY_PROJECT, DISPLAY_USER);
{
{  DISPLAY_CHARGE: (output) This parameter tells whether to display the user's
{      charge number on the DISPLAY_LINK_ATTRIBUTES command or not.
{
{  DISPLAY_FAMILY: (output) This parameter tells whether to display the user's
{      family name on the DISPLAY_LINK_ATTRIBUTES command or not.
{
{  DISPLAY_PROJECT: (output) This parameter tells whether to display the user's
{      project number on the DISPLAY_LINK_ATTRIBUTES command or not.
{
{  DISPLAY_USER: (output) This parameter tells whether to display the user's
{      user name on the DISPLAY_LINK_ATTRIBUTES command or not.
{

*DECK DECK=RHH$GET_FILE EXPAND=FALSE
{
{      The purpose of this request is to obtain a copy of a NOS/170
{ permanent file.  A NOS/170 indirect or direct access permanent file
{ that resides on online family storage can be copied.
{
{      A prior LINK_USER command identifies the NOS/170 family to
{ which the file belongs as well as the requesting user's accounting
{ and user identification information needed to access the family and
{ file.  RHP$GET will generate NOS/170 GET or ATTACH commands using
{ these values to gain access to the file.  If access is granted the
{ file is copied to a NOS/VE file.
{
{           RHP$GET (TO_LOCAL_FILE, FROM_PERMANENT_FILE,
{             CONVERSION, USER_NAME, PASSWORD, STATUS)
{
{ TO_LOCAL_FILE: (input) This parameter specifies the NOS/VE file
{           to which the file is copied.
{
{ FROM_PERMANENT_FILE: (input) This parameter specifies the NOS/170
{           permanent file to be copied to a local NOS/VE file.
{
{ CONVERSION: (input) This parameter specifies the type of conversion
{           to be done during the file copy.  The conversion options
{           are:
{
{           amc$bcd (b60):   Each 60-bit C170 word is placed into the
{                right most bits of each 64-bit C180 word.  The left most
{                4-bits of each C180 word are set to zero.
{
{           amc$ascii (b56): The right most 56-bits of each C170 word
{                are packed into contiquous C180 bits.  The left most
{                4-bits of each C170 word are ignored.
{
{           amc$as6 (a6):   The C170 file contains character data in the
{                6/12 ASCII format.  Each character is converted to
{                an 8-bit ASCII character.
{
{           amc$as8 (a8):   The C170 file contains character data in the
{                8/12 ASCII format.  Each character is converted to
{                an 8-bit ASCII character.
{
{           amc$dis4 (d64):  The C170 file contains display code data
{                according to the 64 character set representation.  Each
{                character is converted to a 8-bit ASCII character.
{
{           Default is amc$bcd (b60).
{
{ USER_NAME: (input) This parameter specifies the NOS/170 user
{           identification of the owner of the file.  This parameter
{           is only necessary if the file is registered in a catalog
{           belonging to a user whose identification is different
{           than the requesting user's NOS/170 identification.
{
{ PASSWORD: (input) This parameter specifies the NOS/170 file password
{           needed to access the file.  It is only required when the
{           file does not belong to the requesting user.
{
{ STATUS: (output) The status of the request will be returned with
{           this parameter.
{
*DECK DECK=RHH$GET_LINK_USER_DESCRIPTOR EXPAND=FALSE

{   The purpose of this request is to return a link_user_descriptor
{ that has been defined previously by a SET_LINK_ATTRIBUTES command.
{
{     RHP$GET_LINK_USER_DESCRIPTOR (LUD, STATUS)
{
{ LUD: (output) This parameter contains the
{     link_user_descriptor.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=RHH$INPUT EXPAND=FALSE
{
{ RHP$INPUT
{
{     This procedure initializes and monitors the process which
{ receives input files from NOS/170 and routes them to NOS/VE's
{ input queue for execution.
{
{     RHP$INPUT
{
{ NOTE: This procedure executes under the system job and will
{       be called upon by the memory link when an input file
{       has been sent from NOS/170.  When no files are being
{       processed this procedure is in a long term wait.
{
*DECK DECK=RHH$LINK_USER_DESCRIPTOR_SAVED EXPAND=FALSE
{
{ RHP$LINK_USER_DESCRIPTOR_SAVED
{
{     The purpose of this request is to save the last link user
{ description entered by a user.  The information is saved in
{ the user's job environment.
{
{              RHP$LINK_USER_DESCRIPTOR_SAVED (USER, FAMILY, PASSWORD,
{                CHARGE, PROJECT, STATUS)
{
{ USER: (input) This parameter specifies the NOS/170 user name
{           under which the user is validated.
{
{ FAMILY: (input) This parameter specifies the NOS/170 family under
{           which the user is validated.
{
{ PASSWORD: (input) This parameter specifies the user's NOS/170
{           password needed to gain access to NOS/170 via the
{           user name.
{
{ CHARGE: (input) This parameter specifies the user's NOS/170 charge
{           number to be charged.
{
{ PROJECT: (input) This parameter specifies the user's NOS/170 project
{           number to be charged.
{
{ STATUS: (output) This parameter specifies the request status.
{

*DECK DECK=RHH$MLI_GET_PERMANENT_FILE EXPAND=FALSE

{ RHP$MLI_GET_PERMANENT_FILE
{
{       The purpose of this procedure is to link to a partner job
{ on the NOS/170 side and have a NOS/170 permanent file copied to
{ a NOS/VE local file.
{
{          RHP$MLI_GET_PERMANENT_FILE (PERMANENT_FILE_NAME,
{           USER_NUMBER, PASSWORD, LOCAL_FILE_INFO,
{           CONVERSION, STATUS)
{
{ PERMANENT_FILE_NAME: (input) This parameter specifies the name of
{          a direct or indirect NOS/170 file to get.
{
{ USER_NUMBER: (input) This parameter specifies the NOS/170 user
{          number of the owner of the file.  This parameter is
{          necessary if the file is registered in a catalog
{          whose user number is different than the user number
{          specified on the last SET_LINK_ATTRIBUTES command.
{
{ PASSWORD: (input) This parameter specifies the NOS/170 file password
{          needed to gain access to the file.  It is required when the
{          file does not belong to the requesting user.
{
{ LOCAL_FILE_NAME: (input) This parameter specifies the name of the
{          NOS/VE local file to which the file is copied.
{
{ CONVERSION: (input) This parameter gives the method of conversion
{          of the 170 file into a NOS/VE file.
{
{ STATUS: (output) This parameter specifies the request status.
{
{
*DECK DECK=RHH$MLI_LINK EXPAND=FALSE
{
{ MLI_LINK
{
{     The purpose of this procedure is to provide all linkage
{ facilities to the MLI for all IRHF applications.  This
{ procedure allows an application to sign on and sign off
{ the MLI.  As part of the sign on facilities, the partner
{ sending application is also identified to the MLI.
{
{     MLI_LINK (DIRECTION,APPLICATION_NAMES)
{
{ DIRECTION: (input) This parameter specifies the linkage
{     direction; i.e., sign_on or sign_off.
{
{ APPLICATION_NAMES: (input) This parameter contains the sending and
{     receiving application names required for MLI communications.
{

*DECK DECK=RHH$MLI_REPLACE_PERMANENT_FILE EXPAND=FALSE

{ RHP$MLI_REPLACE_PERMANENT_FILE
{
{       The purpose of this procedure is to link to a partner job
{ on the NOS/170 side and have a NOS/170 permanent file replaced by
{ a NOS/VE local file.
{
{          RHP$MLI_REPLACE_PERMANENT_FILE (PERMANENT_FILE_NAME,
{           USER_NUMBER, PASSWORD, LOCAL_FILE_INFO,
{           CONVERSION, STATUS)
{
{ PERMANENT_FILE_NAME: (input) This parameter specifies the name of
{          the NOS/170 file to be copied to.
{
{ USER_NUMBER: (input) This parameter specifies the NOS/170 user
{          number of the owner of the file.  This parameter is
{          necessary if the file is registered in a catalog
{          whose user number is different than the user number
{          specified on the last SET_LINK_ATTRIBUTES command.
{
{ PASSWORD: (input) This parameter specifies the NOS/170 file password
{          needed to gain access to the file.  It is required when the
{          file does not belong to the requesting user.
{
{ LOCAL_FILE_NAME: (input) This parameter specifies the name of the
{          NOS/VE local file to copy from.
{
{ CONVERSION: (input) This parameter gives the conversion necessary
{          for create the 170 data file.
{
{ STATUS: (output) This parameter specifies the request status.
{
{
*DECK DECK=RHH$OUTPUT EXPAND=FALSE
{
{ RHP$OUTPUT
{
{     This procedure initializes and monitors the process which
{ sends NOS/VE output queue files to NOS/170 for printing.
{
{     RHP$OUTPUT
{
{ NOTE: This procedure executes under the system job and will be
{       called upon by the queue file processor when a file is
{       put into NOS/VE's output queue.  When no files are
{       being processed this procedure is in a long term wait.
{
*DECK DECK=RHH$QUEUE_FILE_RECEIVE_EXEC EXPAND=FALSE
{
{ RHP$QUEUE_FILE_RECEIVE_EXEC
{
{     This procedure is responsible for receiving queue files from
{ its partner application.  This includes the responsibilities of
{ protocol maintenance, reception control, and final file disposition.
{
{     RHP$QUEUE_FILE_RECEIVE_EXEC (APPLICATION_NAMES,
{               DATA_BUFFER_POINTER,EXEC_STATUS)
{
{ APPLICATION_NAMES: (input) This parameter contains the sending and
{     receiving application names required for MLI communications.
{
{ DATA_BUFFER_POINTER: (input) This parameter contains the address
{     of a buffer that will be used to receive data.
{
{ EXEC_STATUS: (output) This parameter specifies the request status.

*DECK DECK=RHH$QUEUE_FILE_TRANSMIT_EXEC EXPAND=FALSE
{
{ RHP$QUEUE_FILE_TRANSMIT_EXEC
{
{     This procedure is responsible for the acquisition and subsequent
{ transfer of a queued file to its receiving partner application.  This
{ transfer includes the responsibilities of performing protocol
{ maintenance, file transmission control, and final file disposition.
{
{     RHP$QUEUE_FILE_TRANSMIT_EXEC (QUEUE_FILE_PASSWORD, APPLICATION_NAMES,
{               DATA_BUFFER_POINTER, EXEC_STATUS)
{
{ QUEUE_FILE_PASSWORD: (input) This is the password assigned to the
{        application when it was registered with queue file management.
{
{ APPLICATION_NAMES: (input) This parameter contains the sending and
{     receiving application names required for MLI communication.
{
{ DATA_BUFFER_POINTER: (input) This parameter contains the address
{      of a buffer that will be used to transmit data from.
{
{ EXEC_STATUS: (output) This parameter specifies the request status.

*DECK DECK=RHH$REPLACE EXPAND=FALSE
{
{      The purpose of this request is to transfer a copy of a NOS/VE
{ file to a NOS/170 direct or indirect access permanent file.
{ If a NOS/170 direct access permanent file of the same name already
{ exists and if the file can be attached with write mode then the
{ existing direct access file is overwritten with a copy of the
{ NOS/VE file.  If write mode access is not granted an error status is
{ returned.  If a NOS/170 indirect access permanent file of the same name
{ already exists then its contents are replaced by a copy of the NOS/VE
{ file.  If neither a NOS/170 direct or indirect permanent file of the
{ specified name exists in the catalog, a direct access permanent file
{ is created.
{
{      A prior LINK_USER command identifies the NOS/170 family to which the
{ file belongs as well as the user's accounting and user identification
{ information needed to access the family and file.  RHP$REPLACE will
{ generate NOS/170 REPLACE or ATTACH commands using these values to gain
{ access to the NOS/170 file.
{
{           RHP$REPLACE (FROM_LOCAL_FILE, TO_PERMANENT_FILE,
{             CONVERSION, USER_NAME, PASSWORD, STATUS)
{
{ FROM_LOCAL_FILE: (input) This parameter specifies the NOS/VE file
{           to be copied into a NOS/170 file.
{
{ TO_PERMANENT_FILE: (input) This parameter specifies the name of
{           the NOS/170 file to be replaced or created.  This is
{           the permanent file name as registered in the NOS/170
{           file system and can be up to 7-characters in length.
{
{ CONVERSION: (input) This parameter specifies the type of conversion
{           to be done during the file copy.  The conversion options
{           are:
{
{           amc$bcd (b60):   The right most 60 bits of each 64-bit C180
{                word are placed into a 60-bit C170 word.  The left
{                most 4-bits of each C180 word are ignored.
{
{           amc$ascii (b56): Contiguous bits from the C180 words are
{                packed into the right most 56 bits of each C170 word.
{                The left most 4-bits of C170 word are set to zero.
{
{           amc$as6 (a6):   Each 8-bit character in the C180 file is
{                converted to 6/12 ASCII representation in the C170 file.
{
{           amc$as8 (a8):   Each 8-bit character in the C180 file is
{                converted to 8/12 ASCII representation in the C170 file.
{
{           amc$dis4 (d64):  Each 8-bit character in the C180 file is
{                converted to display coded according to the 64 character
{                is representation in the C170 file.
{
{           Default is amc$bcd (b60).
{
{ USER_NAME: (input) This parameter specifies the NOS/170 user
{           identification of the owner of the file.  This parameter
{           is only necessary if the file is registered in a catalog
{           belonging to a user whose identification is different
{           than the requesting user's NOS/170 identification.
{
{ PASSWORD: (input) This parameter specifies the NOS/170 file password
{           needed to access the file.  It is only required when the
{           file does not belong to the requesting user.
{
{ STATUS: (output) The status of the request will be returned in this
{           parameter.
{
*DECK DECK=RHH$ROUTE_FILE EXPAND=FALSE
{
{ ROUTE_FILE
{
{     The purpose of this procedure is to route a local file to
{       the system input queue.
{
{           ROUTE_FILE (EXEC_TYPE,LOCAL_FILE_INFO,QUEUE_FILE_INFO,ROUTE_STATUS)
{
{ EXEC_TYPE: (input) This parameter specifies the type of queue file transfer
{             exec which is requesting the file route.
{
{ LOCAL_FILE_INFO: (input) This parameter specifies all information
{                  pertinent to local file access.
{
{ QUEUE_FILE_INFO: (input) This parameter communicates all queue file
{                  attributes needed for IRHF routing.
{
{ ROUTE_STATUS: (output) This parameter indicates to the calling
{               procedure the completion status of the route function,
{               i.e. the success or failure of the route.  The
{               following status values may be returned by this
{               request:     unsuccessful
{                            successful
{                            fatal_error
{

*DECK DECK=RHH$SAVE_LINK_USER_DESCRIPTOR EXPAND=FALSE
{
{     The purpose of this request is to save information needed to gain
{ access to permanent files controlled by NOS/170.  The parameters
{ provide the accounting and user identification under which a requesting
{ user has been validated to execute on the NOS/170 system.  The
{ information is saved with the user's job environment for use by
{ NOS/VE when processing subsequent RHP$GET and RHP$REPLACE requests.
{
{           RHP$SAVE_LINK_USER_DESCRIPTOR (USER, FAMILY, PASSWORD,
{             CHARGE, PROJECT, STATUS)
{
{ USER: (input) This parameter specifies the NOS/170 user name
{           under which the user is validated.
{
{ FAMILY: (input) This parameter specifies the NOS/170 family under
{           which the user is validated.
{
{ PASSWORD: (input) This parameter specifies the user's NOS/170
{           password needed to gain access to NOS/170 via the
{           user name.
{
{ CHARGE: (input) This parameter specifies the user's NOS/170 charge
{           number to be charged.
{
{ PROJECT: (input) This parameter specifies the user's NOS/170 project
{           number to be charged.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=RHH$SEND_PJ_FUNCTION_REQUEST EXPAND=FALSE
{
{ SEND_PJ_FUNCTION_REQUEST
{
{        The purpose of this procedure is to transmit a partner job function
{ request to the partner job function processor and receive the results of
{ the processing of the requested function.
{
{        SEND_PJ_FUNCTION_REQUEST (PJ_FUNCTION,FAMILY_NAME,
{          PJ_IDENTIFIER,STATUS)
{
{ PJ_FUNCTION: (input) This parameter specifies the partner job function to
{              be performed.
{
{ FAMILY_NAME: (input) This parameter specifies the users family and is used
{              for the submit_pj function to acquire job validation info-
{              rmation from the link_user_descriptor.
{
{ PJ_IDENTIFIER: (input/output) This parameter is used to specify the partner
{                job identifier.  PJ_IDENTIFIER is returned (output) from a
{                submit_pj function.  PJ_IDENTIFIER must be supplied (input)
{                by the user for a status_pj pj_function.
{
{ STATUS: (output) This parameter indicates the status of sending the partner
{         job function request or the condition of the partner job.
{

*DECK DECK=RHH$SET_STATUS_ABNORMAL EXPAND=FALSE
{
{    The purpose of this request is to set the error status for certain
{  errors encountered by remote host processors.
{
{       RHP$SET_STATUS_ABNORMAL (STATUS)
{
{ STATUS: (input/output) This parameter specifies the error status to be
{       processed.  The status from this procedure replaces this input status.
{
*DECK DECK=RHH$UPDATE_DUAL_STATE_ENVIRON EXPAND=FALSE
{
{  This procedure updates the site's dual state environment.
{
{         RHP$UPDATE_DUAL_STATE_ENVIRON (DISPLAY_CHARGE, DISPLAY_FAMILY,
{             DISPLAY_PROJECT, DISPLAY_USER);
{
{  DISPLAY_CHARGE: (input) This parameter tells whether to display the user's
{      charge number on the DISPLAY_LINK_ATTRIBUTES command or not.
{
{  DISPLAY_FAMILY: (input) This parameter tells whether to display the user's
{      family name on the DISPLAY_LINK_ATTRIBUTES command or not.
{
{  DISPLAY_PROJECT: (input) This parameter tells whether to display the user's
{      project number on the DISPLAY_LINK_ATTRIBUTES command or not.
{
{  DISPLAY_USER: (input) This parameter tells whether to display the user's
{      user namethe DISPLAY_LINK_ATTRIBUTES command or not.
{
*DECK DECK=RHM$ACQUIRE_QUEUE_FILE EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := '170 NOS/VE REMOTE HOST' ??
MODULE rhmqfa;

{ Select target 170 operating system.

*IF ($string($name(wev$target_operating_system))='NOS')
  ?VAR rhv$nos_be: boolean := FALSE ?;
*ELSE
  ?VAR rhv$nos_be: boolean := TRUE ?;
*IFEND
?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc RHT$FUNCTION_STATUS

?? TITLE := 'EXTERNAL PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc RHP$LOG_STATUS
*copyc ZUTPDNS
*copyc ZUTPS2D
*copyc ZUTPD2S

{ Word 67 contains the bit to tell whether the system is a 63
{ character set or a 64 character set.

  TYPE
    rht$ra_word_67 = packed record
      character_set_64: boolean,
      fill1: 0 .. 7fffffff(16),
      fill2: 0 .. 0fffffff(16),
    recend;

  Procedure [XREF] getword (address: integer;
     word: ^cell);

?? TITLE := 'RHP$ACQUIRE_QUEUE_FILE' ??
?? SET (LIST := ON) ??
?? EJECT ??
{ RHP$ACQUIRE_QUEUE_FILE
{
{     The purpose of this procedure is to acquire a queue file
{ destined for transmission to the remote host.
{
{       RHP$ACQUIRE_QUEUE_FILE (LOCAL_FILE_INFO,QUEUE_FILE_INFO,
{           LID_LIST, ACQUIRE_STATUS)
{
{ LOCAL_FILE_INFO: (output) This parameter specifies all information
{     pertinent to local file access of the acquired queue file.
{
{ QUEUE_FILE_INFO: (output) This parameter communicates all
{     queue file attributes needed for IRHF routing.
{
{ LID_LIST: (input) This parameter specifies the pointer to the
{     list of lids that a site can route jobs from.
{
{ ACQUIRE_STATUS: (output) This parameter specifies the acquire
{     request status.  The following status values may be returned
{     by this request:
{          not_acquired
{          acquired

  PROCEDURE [XDCL] rhp$acquire_queue_file ALIAS 'rhmqfa' (VAR local_file_info: rht$local_file_info;
    VAR queue_file_info: rht$queue_file_info;
    lid_list: ^cell;
    VAR acquire_status: rht$acquire_status);

  ? IF rhv$nos_be = FALSE THEN
    CONST
      no_file_found_qac_error_code = 7,
      qac_get_code = 2,
      qac_get_parameter_block_length = 78,
      qfm_fet_extension_length = 18,
      qfm_read_system_sector_fn_code = 10,
      rhc$a170_input_file_dlid = 001110010110000101(2), { display code for NVE }
      rhc$a170_input_file_forms_code = 010010001000(2), { display code for RH }
      rhc$a170_input_file_origin_type = 0,
      rhc$no_output_disp_code = 1617(8), { display code for NO }
      rhc$wait_disp_code = 2417(8); { display code for TO }

    TYPE
      lid_conv_record = packed record
        case i: integer of
        = 1 =
          dc_string: array [1 .. 1] of packed array [0 .. 9] of 0 .. 3f(16),
        = 2 =
          lid_rec: packed record
            lid: 0 .. 3ffff(16),
            filler: 0 .. 3ffffffffff(16),
          recend,
        casend,
      recend,

      perm_file_info_rec = packed record
        family_name: 0 .. 3ffffffffff(16),
        filler1: 0 .. 3fff(16),
        filler2: integer,
        user_name: 0 .. 3ffffffffff(16),
        filler3: 0 .. 3ffff(16),
      recend,

      qac_parameter_block = packed record
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 0
        file_name: 0 .. 3ffffffffff(16),
        error_code: 0 .. 0ff(16),
        function_code: 0 .. 1ff(16),
        complete_bit: boolean,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 1
        fill1: 0 .. 3ffffffff(16),
        length_of_request_block: 0 .. 0ff(16),
        fwa_of_additional_info: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 2
        fill2: 0 .. 3ffffffffff(16),
        lwa_plus_1_of_msg_returned: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 3
        fill3: 0 .. 3ffffffffff(16),
        fwa_of_msg_returned: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 4
        fnt_ordinal: 0 .. 0fff(16),
        io_queue_table_ordinal: 0 .. 0fff(16),
        file_found_in_queue: 0 .. 0fff(16),
        fill4: 0 .. 3f(16),
        limit_address: 0 .. 3ffff(16),

{ Selection Criteria
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 5
        destination_family_name: 0 ..3ffffffffff(16),
        batch_device_id: 0 .. 3f(16),
        origin_type_to_select: 0 .. 0fff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 6
        destination_user_number: 0 .. 3ffffffffff(16),
        destination_user_index: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 7
        job_sequence_number: 0 .. 0ffffff(16),
        selection_flags: packed record
          reserved_for_installation: 0 .. 7,
          reserved: 0 .. 7fff(16),
          enabled_dlid: boolean,
          slid_specified: boolean,
          alid_list_address_present: boolean,
          dlid_specified: boolean,
          reserved_for_security_use: boolean,
          ic_selection: boolean,
          include_ec_0_in_selection: boolean,
          hierarchical_ec: boolean,
          expicit_ec: boolean,
          disposition_code: boolean,
          forms_code: boolean,
          job_sequence_number: boolean,
          origin: boolean,
          destination_batch_id: boolean,
          destination_fm_un_ui: boolean,
          include_priority_0_in_selection: boolean,
          inhibit_duplicate_lfn_search: boolean,
          specific_ordinal_in_w4: boolean,       { Bit 0 }
        recend,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 8
        selection_queues: packed record
          reserved2: 0 .. 7,
          installation: 0 .. 1,
          reserved1: 0 .. 3,
          terminal_queue: boolean,
          plot_queue: boolean,
          punch_queue: boolean,
          print_queue: boolean,
          executing_queue: boolean,
          input_queue: boolean,     { Bit 0 }
        recend,
        forms_code: 0 .. 0fff(16),
        disposition_code: 0 .. 0fff(16),
        external_characteristics: 0 .. 7,
        internal_characteristics: 0 .. 7,
        link_address: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 9
        source_mainframe_logical_id: 0 .. 3ffff(16),
        destination_mainfram_logical_id: 0 .. 3ffff(16),
        fill9a: 0 .. 3f(16),
        alternate_dlid_list_address: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 10
        security_level: 0 .. 0fff(16),
        reserved_for_cdc: 0 .. 0ffffffffffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 11
        reserved11: integer,

{ GET Function Portion
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 12
        dayfile_random_address: 0 .. 3fffffff(16),
        fill12a: 0 .. 3f(16),
        account_limit: 0 .. 0ffffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 13
        interrupt_random_address: 0 .. 3fffffff(16),
        fill13a: 0 .. 3f(16),
        spacing_code: 0 .. 0fff(16),
        fill13b: 0 .. 3f(16),
        repeat_count: 0 .. 3f(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 14
        file_length: 0 .. 3fffffff(16),
        fill14a: 0 .. 3fffffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 15
        reserved15: integer,
{ Extended GET QAC parameter block.
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 16
        accounting_info_ahmt: integer,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 17
        accounting_info_ahds: integer,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 18
        accounting_info_aacw: integer,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 19
        owner_user_number: 0 .. 3ffffffffff(16),
        filler19: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 20
        owner_family_name: 0 .. 3ffffffffff(16),
        filler20: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 21
        creation_user_name: integer,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 22
        creation_family_name: integer,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 23
        remote_mainframe_user: integer,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 24
        remote_mainframe_family: integer,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 25
        user_job_name: integer,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 26
        data_declaration: 0 .. 0fff(16),
        filler26: 0 .. 0ffffff(16),
        imp_text_length: 0 .. 0fff(16),
        exp_text_length: 0 .. 0fff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 27 thru 52
        implicit_routing_text: array [1 .. 26] of packed array [0 .. 9]
            of 0 .. 63,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 53 thru 78
        explicit_routing_text: array [1 .. 26] of integer,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 79
        encrypted_batch_password: 0 .. 3ffffffffff(16),
        reserved79: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 80 thru 82
        charge_number: array [1 .. 1] of packed array [0 .. 9] of 0 .. 3f(16),
{- - - - - - - - - - - - - - - - - - - - - - Words 81 and 82
        project_number: array [1 .. 2] of packed array [0 .. 9] of 0 ..3f(16),
      recend,

      system_sector = packed record
        fnt_entry: packed record
          job_name: utt$dc_name,
          control_info1: 0 .. 3ffff(16),
          equipment_number: 0 .. 0fff(16),
          control_info2: 0 .. 0ffffffffffff(16),
        recend,
        date_and_time: integer,
        filler1: array [1 .. 5] of integer,
        qft_entry: packed record
          jsnq: integer,
          entq: integer,
          insq: integer,
          file_service_type: 0 .. 3f(16),
          file_origin_type: 0 .. 3f(16),
          default_routing_info: 0 .. 0ffffff(16),
          reserved1: 0 .. 3f(16),
          external_characteristics: 0 .. 7,
          internal_characteristics: 0 .. 7,
          forms_code: 0 .. 0fff(16),
          filler_qft: array [12 .. 15] of integer,
        recend,
        job_output_data: array [16 .. 22] of integer,
        filler23a: 0 .. 0fff(16),
        resident_mainframe_machine_id: 0 .. 0fff(16),
        creation_mainframe_machine_id: 0 .. 0fff(16),
        file_length_in_sectors: 0 .. 0ffffff(16),
        account_number_of_destination: utt$dc_name,
        user_index_of_destination: 0 .. 3ffff(16),
        family_name_of_destination: utt$dc_name,
        reserved25: 0 .. 3ffff(16),
        user_number_of_creator: utt$dc_name,
        user_index_of_creator: 0 .. 3ffff(16),
        creation_family_name: utt$dc_name,
        reserved27: 0 .. 3ffff(16),
        user_number_of_owner: utt$dc_name,
        user_index_of_owner: 0 .. 3ffff(16),
        family_name_of_owner: utt$dc_name,
        reserved29: 0 .. 3ffff(16),
        job_sequence_number_of_creator: 0 .. 0ffffff(16),
        reserved30: 0 .. 0fff(16),
        disposition_code: 0 .. 0fff(16),
        priority: 0 .. 0fff(16),
        original_job_sequence_number: 0 .. 0ffffff(16),
        queued_file_creation_date: 0 .. 0fffffffff(16),
        user_job_name: utt$dc_name,
        reserved32: 0 .. 3ffff(16),
        charge_number: integer,
        project_number: array [34 .. 35] of integer,
        filler36: array [36 ..63] of integer,
        end_of_system_sector: array [64 .. 65] of integer,
      recend;


    VAR
      alid_addr: 0 .. 3ffff(16),
      alid_address_ptr: ^integer,
      charge_project_string: string(31),
      dc_name: utt$dc_name,
      dc_string_char_index: 0 .. 9,
      dc_string_word_index: integer,
      disp_code: string (7),
      eol: boolean,
      error_code_length: 1 .. 2,
      lid_conv_buffer: lid_conv_record,
      perm_file_info: perm_file_info_rec,
      qacpb: qac_parameter_block,
      qacpb_init_block: [STATIC] qac_parameter_block :=
        [0, 0, qac_get_code, FALSE,  0, qac_get_parameter_block_length, 0,
         0, 0,  0, 0,  0, 0, 0, 0, 0,
{        - - - - selection criteria (words 5 - 11) - - - -
         0, 0, 0,  0, 0,  0, [0, 0, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE,
         FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
         FALSE, FALSE, FALSE],
         [0, 0, 0, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE],
         0, 0, 0, 0, 0,
         0, 0, 0, 0, 0, 0, 0,
{        - - - - get function portion (words 12 - 15) - - - -
         0, 0, 0,  0, 0, 0, 0, 0,  0, 0,  0,
{        - - - - extended get function portion (words 16-82) - - -
         0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
{        - - - - initialize implicit and explicit text (words 27-78)
         [REP 26 OF [REP 10 OF 0]], [REP 26 OF 0],
{        - - - - initialize rest of block (words 79-82) - - - -
         0, 0, [REP 1 OF [REP 10 OF 0]], [REP 2 OF [REP 10 OF 0]]],
      ra_word_67: rht$ra_word_67,
      res_length: ost$string_length,
      result_length: 0 .. 7,
      result_string: string(256),
      size: integer,
      sys_sector: system_sector;


    PROCEDURE [XREF] rhpgpfp (VAR perm_file_info: perm_file_info_rec);

    PROCEDURE [XREF] rhpqac ALIAS 'rhpqac' (VAR qacpb: qac_parameter_block);

    PROCEDURE [XREF] rhpqfm ALIAS 'rhpqfm' (function_code: integer;
      VAR fet_address: n7t$fet);

{ Documentation for the qac parameter block is located in the
{ NOS REFERENCE SET VOLUME 4 PROGRAM INTERFACE manual.

{ Attempt acquire of the queue file.

    local_file_info.machine_type := a170;
    queue_file_info.machine_type := a170;
    qacpb := qacpb_init_block;
    alid_address_ptr := #LOC (lid_list);
    alid_addr := alid_address_ptr^;
    qacpb.alternate_dlid_list_address := alid_addr;
    rhpqac (qacpb);
    IF qacpb.error_code = no_file_found_qac_error_code THEN
      acquire_status := not_acquired;
    ELSE

{ Read the system sector for the acquired file.

      local_file_info.fet.completed := FALSE;
      local_file_info.fet.extension_length := qfm_fet_extension_length;
      local_file_info.fet.filename := qacpb.file_name;
      local_file_info.fet.next_in := #LOC (sys_sector);
      local_file_info.fet.next_out := #LOC (sys_sector);
      local_file_info.fet.first := #LOC (sys_sector);
      local_file_info.fet.limit := #LOC (sys_sector.end_of_system_sector [65]);
      rhpqfm (qfm_read_system_sector_fn_code, local_file_info.fet);

{ Save system sector data required by remote host to route the file back.

{ Get the type of character set running on the 170 side.  If it is a 64
{ character set, set forms code to blank, otherwise set it to CS.

      getword (67(8), #LOC (ra_word_67));
      IF ra_word_67.character_set_64 THEN
        queue_file_info.a170.form_code := '  ';
      ELSE
        queue_file_info.a170.form_code := 'CS';
      IFEND;
      utp$convert_dc_name_to_string (sys_sector.fnt_entry.job_name,
          queue_file_info.a170.file_name.a170_job_name, result_length);
      utp$convert_dc_name_to_string (qacpb.owner_family_name,
          queue_file_info.a170.family_name_of_creator.a170_creator_family_name(1,7), result_length);

      { blank fill queue_file_info.a170.family_name_of_creator.a170_creator_family_name to 9 characters
      queue_file_info.a170.family_name_of_creator.a170_creator_family_name(8,2) := '  ';
      IF qacpb.owner_user_number = 0 THEN
        rhpgpfp (perm_file_info);
        utp$convert_dc_name_to_string (perm_file_info.user_name,
            queue_file_info.a170.user_number_of_owner.a170_owner_user_num(1,7), result_length);

        { blank fill queue_file_info.a170.user_number_of_owner.a170_owner_user_num to 9 characters
        queue_file_info.a170.user_number_of_owner.a170_owner_user_num(8,2) := '  ';
      ELSE
        utp$convert_dc_name_to_string (qacpb.owner_user_number,
            queue_file_info.a170.user_number_of_owner.a170_owner_user_num(1,7), result_length);

        { blank fill queue_file_info.a170.user_number_of_owner.a170_owner_user_num to 9 characters
        queue_file_info.a170.user_number_of_owner.a170_owner_user_num(8,2) := '  ';
      IFEND;
      dc_string_word_index := 1;
      dc_string_char_index := 0;
      lid_conv_buffer.lid_rec.lid := qacpb.source_mainframe_logical_id;
      eol := FALSE;
      utp$convert_dc_string_to_string (utc$ascii64, lid_conv_buffer.dc_string,
          dc_string_word_index, dc_string_char_index, result_string (1,10),
          res_length, eol);
      queue_file_info.a170.logical_identifier.a170_logical_identifier := result_string (1,3);
      charge_project_string := ' ';
      dc_string_word_index := 1;
      dc_string_char_index := 0;
      eol := FALSE;
      utp$convert_dc_string_to_string (utc$ascii64, qacpb.charge_number,
          dc_string_word_index, dc_string_char_index,
          charge_project_string (1,10), res_length, eol);
      queue_file_info.a170.user_charge_number := charge_project_string;
      charge_project_string := ' ';
      dc_string_word_index := 1;
      dc_string_char_index := 0;
      eol := FALSE;
      utp$convert_dc_string_to_string (utc$ascii64, qacpb.project_number,
          dc_string_word_index, dc_string_char_index,
          charge_project_string (1,20), res_length, eol);
      queue_file_info.a170.user_project_number := charge_project_string;
      queue_file_info.a170.implicit_text_size := qacpb.imp_text_length;
      IF qacpb.imp_text_length <> 0 THEN
        dc_string_word_index := 1;
        dc_string_char_index := 0;
        eol := false;
        utp$convert_dc_string_to_string (utc$ascii64, qacpb.implicit_routing_text,
            dc_string_word_index, dc_string_char_index, result_string (1,256),
            res_length, eol);
        queue_file_info.a170.implicit_routing_text := result_string;
      ELSE

  {  If the implicit routing text was not present in the QAC parameter block, then
  {  an implicit routing text will be created in order to route the output from
  {  the 180 batch job being submitted to the place where the job was submitted
  {  from.

        result_string := ' ';
        result_string(1,81) :=
           'IRHNVE ROUTE,,DFN =        ,DUN =        , DC =   , OFN =        , OUN =        .';
        result_string (59, 7) :=
           queue_file_info.a170.family_name_of_creator.a170_creator_family_name;
        result_string (74, 7) :=
           queue_file_info.a170.user_number_of_owner.a170_owner_user_num;
        IF (qacpb.destination_family_name <> 0) AND
           (qacpb.destination_user_number <> 0) THEN
          utp$convert_dc_name_to_string (qacpb.destination_family_name,
              result_string (21,7), result_length);
          utp$convert_dc_name_to_string (qacpb.destination_user_number,
              result_string (35,7), result_length);
          IFEND;
        IF (qacpb.disposition_code = rhc$no_output_disp_code) THEN
          result_string (49, 2) := 'NO';
        ELSEIF (qacpb.disposition_code = rhc$wait_disp_code) THEN
          result_string (49, 2) := 'TO';
        IFEND;
        queue_file_info.a170.implicit_routing_text := result_string;
        queue_file_info.a170.implicit_text_size := 256;
      IFEND;
      acquire_status := acquired;
    IFEND;
  ? ELSE
    CONST
      no_file_found_qaf_error_code = 2,
      qaf_did_word_count = 10,
      qaf_dummy_dest_id = 100111100111100111(2), { ***
      qaf_get_code = 1,
      qaf_queue_type = 1;

    TYPE
      lid_array = array [1 .. 10] of 0 .. 0ffffffffffff(16),

      lid_conv_record = packed record
        case i: integer of
        = 1 =
          dc_string: array [1 .. 1] of packed array [0 .. 9] of 0 .. 3f(16),
        = 2 =
          lid_rec: packed record
            lid: 0 .. 3ffff(16),
            filler: 0 .. 3ffffffffff(16),
          recend,
        casend,
      recend,

      qaf_parameter_block = packed record
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 0
        file_name: 0 .. 3ffffffffff(16),
        error_code: 0 .. 03f(16),
        queue_type: 0 .. 0ff(16),
        function_code: 0 .. 7(16),
        complete_bit: boolean,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 1
        alter_flags: packed record
          fill1: 0 .. 3f(16),
          abort_evict: boolean,
          change_repeat_count: boolean,
          change_or_compare_fc: boolean,
          change_priority: boolean,
          change_terminal_id: boolean,
          send_to_central_site: boolean,
        recend,
        forms_code: 0 .. 0fff(16),
        disposition_code: 0 .. 0fff(16),
        fill2: 0 .. 1,
        repeat_count: 0 .. 1f(16),
        fwa_of_additional_info: ^CELL,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 2
        source_mainframe_logical_id: 0 .. 3ffff(16),
        destination_mainfram_logical_id: 0 .. 3ffff(16),
        fnt_address: 0 .. 0fff(16),
        job_class: 0 .. 0fff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 3
        return_routing_info: boolean,
        fill3: 0 .. 7ff(16),
        new_terminal_id: 0 .. 0fff(16),
        fill4: 0 .. 0fff(16),
        current_terminal_id: 0 .. 0fff(16),
        priority: 0 .. 0fff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 4
        pre_dayfile_file_name: 0 .. 03ffffffffff(16),
        pre_dayfile_flag: boolean,
        class_2_inhibit: boolean,
        class_1_inhibit: boolean,
        inhibit_dup_file_search: boolean,
        ignore_file_list_specified: boolean,
        ignore_file_did_host_match: boolean,
        executing_job_count: 0 .. 0fff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 5
        additional_did_words: 0 .. 0fff(16),
        original_fnt_add: 0 .. 0fff(16),
        fill5: 0 .. 3f(16),
        ignore_file_list_length: 0 .. 0fff(16),
        ignore_file_list_fwa: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 6 thru 15
        qaf_lid_list: array [1 .. 10] of 0 .. 0ffffffffffff(16),
      recend,

      routing_info_packet = packed record
{ - - - - - - - - - - - - - - - - -  - - - - - - - - - - - Word 0
        fill1: 0 .. 3ffffffffff(16),
        imp_text_length: 0 .. 0fff(16),
        imp_text_word_count: 0 .. 3f(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 1 thru 26
        implicit_routing_text: array [1 .. 26] of packed array [0 .. 9]
            of 0 .. 63,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 27
        fill2: 0 .. 3ffffffffff(16),
        exp_text_length: 0 .. 0fff(16),
        exp_text_word_count: 0 .. 3f(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 28 thru 53
        explicit_routing_text: array [1 .. 26] of integer,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 54
        fill3: 0 .. 0ffffffffffff(16),
        data_declaration: 0 .. 0fff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 55
        id: 0 .. 3f(16),
        fill4a: 0 .. 3f(16),
        fill4: 0 .. 0ffffffffffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 56
        owner_user_number: 0 .. 3ffffffffff(16),
        fill5: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 57
        owner_family_name: 0 .. 3ffffffffff(16),
        fill6: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 58 thru 63
        reserved58_63: array [1 ..5] of integer,
      recend,

      tid_conv_record = packed record
        case i: integer of
        = 1 =
          dc_string: array [1 .. 1] of packed array [0 .. 9] of 0 .. 3f(16),
        = 2 =
          tid_rec: packed record
            tid: 0 .. 0fff(16),
            filler: 0 ..0ffffffffffff(16),
          recend,
        casend,
      recend;

    VAR
      dc_string_char_index: 0 .. 9,
      dc_string_word_index: integer,
      eol: boolean,
      i: integer,
      lid_array_ptr: ^lid_array,
      lid_conv_buffer: lid_conv_record,
      qafpb: qaf_parameter_block,
      qafpb_init_block: [STATIC] qaf_parameter_block :=
        [0, 0, qaf_queue_type, qaf_get_code, FALSE, [0, FALSE, FALSE, FALSE,
         FALSE, FALSE, FALSE], 0, 0, 0, 0, NIL, 0, qaf_dummy_dest_id, 0, 0,
         TRUE, 0, 0, 0, 0, 1, 0, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, 0,
         qaf_did_word_count, 0, 0, 0, 0,
{        - - - - additional did words (words 6-15) - - -
         [REP 10 OF 0]],
      ra_word_67: rht$ra_word_67,
      routeip: routing_info_packet,
      routeip_init_block: [STATIC] routing_info_packet :=
{     - - - - implicit routing info - - - -
        [0, 0, 0, [REP 26 OF [REP 10 OF 0]],
{     - - - - explicit routing info - - - -
         0, 0, 0, [REP 26 OF 0],
{     - - - - initialize rest of block (words 55 thru 63)
         0, 0, 0, 0, 0, 0, 0, 0, 0, [REP 5 OF 0]],
      tid_conv_buffer: tid_conv_record,
      res_length: ost$string_length,
      result_length: 0 .. 7,
      result_string: string(256);

    PROCEDURE [XREF] rhpqac ALIAS 'rhpqac' (VAR qafpb: qaf_parameter_block);

{ Attempt acquire of the queue file.

    local_file_info.machine_type := a170;
    queue_file_info.machine_type := a170;
    routeip := routeip_init_block;
    qafpb := qafpb_init_block;
    qafpb.fwa_of_additional_info := #LOC (routeip);
    lid_array_ptr := lid_list;
    FOR i := 1 TO 10 DO
      qafpb.qaf_lid_list[i] := lid_array_ptr^[i];
    FOREND;
    rhpqac (qafpb);
    IF qafpb.error_code = no_file_found_qaf_error_code THEN
      acquire_status := not_acquired;
    ELSE
{ Setup local file info.

      local_file_info.fet.completed := FALSE;
      local_file_info.fet.filename := qafpb.file_name;

{ Save qaf block data required by remote host to route the file back.

{ Get the type of character set running on the 170 side.  If it is a 64
{ character set, set forms code to blank, otherwise set it to CS.

      getword (67(8), #LOC (ra_word_67));
      IF ra_word_67.character_set_64 THEN
        queue_file_info.a170.form_code := '  ';
      ELSE
        queue_file_info.a170.form_code := 'CS';
      IFEND;
      utp$convert_dc_name_to_string (qafpb.file_name,
          queue_file_info.a170.file_name.a170_job_name, result_length);
      utp$convert_dc_name_to_string (qafpb.file_name,
          queue_file_info.a170.family_name_of_creator.a170_creator_family_name(1,7), result_length);

      { blank fill queue_file_info.a170.family_name_of_creator.a170_creator_family_name to 9 characters
      queue_file_info.a170.family_name_of_creator.a170_creator_family_name(8,2) := '  ';
      utp$convert_dc_name_to_string (qafpb.file_name,
          queue_file_info.a170.user_number_of_owner.a170_owner_user_num(1,7), result_length);

      { blank fill queue_file_info.a170.user_number_of_owner.a170_owner_user_num to 9 characters
      queue_file_info.a170.user_number_of_owner.a170_owner_user_num(8,2) := '  ';
      dc_string_word_index := 1;
      dc_string_char_index := 0;
      lid_conv_buffer.lid_rec.lid := qafpb.source_mainframe_logical_id;
      eol := FALSE;
      utp$convert_dc_string_to_string (utc$ascii64, lid_conv_buffer.dc_string,
          dc_string_word_index, dc_string_char_index, result_string (1,10),
          res_length, eol);
      queue_file_info.a170.logical_identifier.a170_logical_identifier := result_string (1,3);

{ Save implicit routing text.

      queue_file_info.a170.implicit_text_size := routeip.imp_text_length;
      IF (qafpb.return_routing_info = TRUE) OR
        (qafpb.current_terminal_id <> 0) THEN
        IF routeip.imp_text_length <> 0 THEN
          dc_string_word_index := 1;
          dc_string_char_index := 0;
          eol := false;
          utp$convert_dc_string_to_string (utc$ascii64, routeip.implicit_routing_text,
              dc_string_word_index, dc_string_char_index, result_string (1,256),
              res_length, eol);
          queue_file_info.a170.implicit_routing_text := result_string;
        ELSEIF qafpb.current_terminal_id <> 0 THEN
          dc_string_word_index := 1;
          dc_string_char_index := 0;
          tid_conv_buffer.tid_rec.tid := qafpb.current_terminal_id;
          eol := FALSE;
          result_string := ' ';
          result_string(1,10) := 'IRHNBE    ';
          utp$convert_dc_string_to_string (utc$ascii64, tid_conv_buffer.dc_string,
              dc_string_word_index, dc_string_char_index, result_string (9,10),
              res_length, eol);
          queue_file_info.a170.implicit_text_size := 256;
          queue_file_info.a170.implicit_routing_text := result_string;
        IFEND;
      IFEND;
      acquire_status := acquired;
    IFEND;
  ? IFEND

  PROCEND rhp$acquire_queue_file;

MODEND rhmqfa;
*DECK DECK=RHM$CHANGE_DUAL_STATE_ENVIRON EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'rhm$change_dual_state_environ' ??

MODULE rhm$change_dual_state_environ;

{
{ PURPOSE:
{   This module contains the processor for the command that allow the users to change their link
{   attributes in order to be able to use interstate communication commands (REPLACE_FILE, GET_FILE,
{   CREATE_INTERSTATE_CONNECTION, and PRINT_FILE with the Dual_State_Routing_Parameter).

?? NEWTITLE := '  Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc cle$ecc_file_reference
*copyc ofe$error_codes
*copyc ost$status
?? POP ??
*copyc avp$configuration_administrator
*copyc clp$get_value
*copyc clp$scan_parameter_list
*copyc rhp$update_dual_state_environ
*copyc osp$set_status_abnormal

?? TITLE := '  [XDCL, #GATE] rhp$change_dual_state_environ', EJECT ??
*copy rhh$change_dual_state_environ

  PROCEDURE [XDCL, #GATE] rhp$change_dual_state_environ (
         parameter_list: clt$parameter_list;
     VAR status: ost$status);

{         PDT change_ds_link_envir_pdt (
{           display_charge_link_attribute, dcla: boolean = TRUE
{           display_family_link_attribute, dfla: boolean = TRUE
{           display_project_link_attribute, dpla: boolean = TRUE
{           display_user_link_attribute, dula: boolean = TRUE
{           status)

?? PUSH (LISTEXT := ON) ??

  VAR
    change_ds_link_envir_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^change_ds_link_envir_pdt_names, ^change_ds_link_envir_pdt_params];

  VAR
    change_ds_link_envir_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 9] of
      clt$parameter_name_descriptor := [['DISPLAY_CHARGE_LINK_ATTRIBUTE', 1], ['DCLA', 1], [
      'DISPLAY_FAMILY_LINK_ATTRIBUTE', 2], ['DFLA', 2], ['DISPLAY_PROJECT_LINK_ATTRIBUTE', 3], ['DPLA', 3], [
      'DISPLAY_USER_LINK_ATTRIBUTE', 4], ['DULA', 4], ['STATUS', 5]];

  VAR
    change_ds_link_envir_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5] of
      clt$parameter_descriptor := [

{ DISPLAY_CHARGE_LINK_ATTRIBUTE DCLA }
    [[clc$optional_with_default, ^change_ds_link_envir_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
      [NIL, clc$boolean_value]],

{ DISPLAY_FAMILY_LINK_ATTRIBUTE DFLA }
    [[clc$optional_with_default, ^change_ds_link_envir_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed,
      [NIL, clc$boolean_value]],

{ DISPLAY_PROJECT_LINK_ATTRIBUTE DPLA }
    [[clc$optional_with_default, ^change_ds_link_envir_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed,
      [NIL, clc$boolean_value]],

{ DISPLAY_USER_LINK_ATTRIBUTE DULA }
    [[clc$optional_with_default, ^change_ds_link_envir_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed,
      [NIL, clc$boolean_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    change_ds_link_envir_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'TRUE';

  VAR
    change_ds_link_envir_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'TRUE';

  VAR
    change_ds_link_envir_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'TRUE';

  VAR
    change_ds_link_envir_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (4) := 'TRUE';

?? POP ??

    VAR
      attribute_value: clt$value,
      display_charge: boolean,
      display_family: boolean,
      display_project: boolean,
      display_user: boolean;

    status.normal := TRUE;

    IF NOT avp$configuration_administrator () THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active, 'configuration_administration', status);
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, change_ds_link_envir_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('DISPLAY_CHARGE_LINK_ATTRIBUTE', 1, 1, clc$low, attribute_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display_charge := attribute_value.bool.value;

    clp$get_value ('DISPLAY_FAMILY_LINK_ATTRIBUTE', 1, 1, clc$low, attribute_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display_family := attribute_value.bool.value;

    clp$get_value ('DISPLAY_PROJECT_LINK_ATTRIBUTE', 1, 1, clc$low, attribute_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display_project := attribute_value.bool.value;

    clp$get_value ('DISPLAY_USER_LINK_ATTRIBUTE', 1, 1, clc$low, attribute_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display_user := attribute_value.bool.value;

    rhp$update_dual_state_environ (display_charge, display_family,
        display_project, display_user);

  PROCEND rhp$change_dual_state_environ;

MODEND rhm$change_dual_state_environ;
*DECK DECK=RHM$CHANGE_LINK_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'rhm$change_link_attributes' ??

MODULE rhm$change_link_attributes;

{
{ PURPOSE:
{   This module contains the processor for the command that allow the users to change their link
{   attributes in order to be able to use interstate communication commands (REPLACE_FILE, GET_FILE,
{   CREATE_INTERSTATE_CONNECTION, and PRINT_FILE with the Dual_State_Routing_Parameter).

?? NEWTITLE := '  Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_expression_result
*copyc ost$status
*copyc rhc$condition_limits
?? POP ??
*copyc clp$evaluate_parameters
*copyc osp$set_status_abnormal
*copyc pmp$get_170_os_type
*copyc rhp$get_link_user_descriptor
*copyc rhp$save_link_user_description

?? TITLE := '  [XDCL] rhp$_change_link_attributes', EJECT ??
*copy rhh$change_link_attributes

  PROCEDURE [XDCL] rhp$_change_link_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (osm$chala) change_link_attributes, change_link_attribute, chala (
{     family, f: any of
{         string 0..osc$max_name_size
{         name
{       anyend = $optional
{     user, u: any of
{         string 0..osc$max_name_size
{         name
{       anyend = $optional
{     password, pw: (SECURE) any of
{         string 0..osc$max_name_size
{         name
{       anyend = $optional
{     charge, c, account, a: any of
{         string 0..osc$max_name_size
{         name
{       anyend = $optional
{     project, p: any of
{         string 0..osc$max_name_size
{         name
{       anyend = $optional
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type3: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type4: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type5: 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$string_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 11, 16, 15, 17, 19, 890],
    clc$command, 13, 6, 0, 0, 0, 0, 6, 'OSM$CHALA'], [
    ['A                              ',clc$abbreviation_entry, 4],
    ['ACCOUNT                        ',clc$alias_entry, 4],
    ['C                              ',clc$alias_entry, 4],
    ['CHARGE                         ',clc$nominal_entry, 4],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FAMILY                         ',clc$nominal_entry, 1],
    ['P                              ',clc$abbreviation_entry, 5],
    ['PASSWORD                       ',clc$nominal_entry, 3],
    ['PROJECT                        ',clc$nominal_entry, 5],
    ['PW                             ',clc$abbreviation_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 6],
    ['U                              ',clc$abbreviation_entry, 2],
    ['USER                           ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 3
    [8, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 6
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    TRUE, 2],
    8, [[1, 0, clc$string_type], [0, osc$max_name_size, FALSE]],
    5, [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$family = 1,
      p$user = 2,
      p$password = 3,
      p$charge = 4,
      p$project = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      charge: ost$name,
      family: ost$name,
      link_user_descriptor: rht$link_user_descriptor,
      os_type: ost$170_os_type,
      password: ost$name,
      project: ost$name,
      user: ost$name;

    pmp$get_170_os_type (os_type, status);
    IF status.normal THEN

{ If the OS type is none, then the command cannot be executed.

      IF os_type = osc$ot7_none THEN
        osp$set_status_abnormal (rhc$remote_host_id,
                                 rhe$no_partner_exists, 'CHANGE_LINK_ATTRIBUTES', status);
        RETURN;
      IFEND;
    IFEND;

    status.normal := TRUE;
    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Get the current link attribute values of the user.

    rhp$get_link_user_descriptor (link_user_descriptor, status);
    IF NOT status.normal THEN
      IF status.condition = rhe$lud_cannot_be_found THEN

{ This error only occurs when entering a dual state command at
{ the NOS/VE console and a CHALA or a SETLA command has not been
{ previously executed.  A link user descriptor will be created for
{ this user with all values initialized to blank.

        link_user_descriptor.family := ' ';
        link_user_descriptor.user := ' ';
        link_user_descriptor.password := ' ';
        link_user_descriptor.charge := ' ';
        link_user_descriptor.project := ' ';
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$family].specified THEN
      IF pvt [p$family].value^.kind = clc$name THEN
        family := pvt [p$family].value^.name_value;
      ELSE
        family := pvt [p$family].value^.string_value^;
      IFEND;
    ELSE
      family := link_user_descriptor.family;
    IFEND;

    IF pvt [p$user].specified THEN
      IF pvt [p$user].value^.kind = clc$name THEN
        user := pvt [p$user].value^.name_value;
      ELSE
        user := pvt [p$user].value^.string_value^;
      IFEND;
    ELSE
      user := link_user_descriptor.user;
    IFEND;

    IF pvt [p$password].specified THEN
      IF pvt [p$password].value^.kind = clc$name THEN
        password := pvt [p$password].value^.name_value;
      ELSE
        password := pvt [p$password].value^.string_value^;
      IFEND;
    ELSE
      password := link_user_descriptor.password;
    IFEND;

    IF pvt [p$charge].specified THEN
      IF pvt [p$charge].value^.kind = clc$name THEN
        charge := pvt [p$charge].value^.name_value;
      ELSE
        charge := pvt [p$charge].value^.string_value^;
      IFEND;
    ELSE
      charge := link_user_descriptor.charge;
    IFEND;

    IF pvt [p$project].specified THEN
      IF pvt [p$project].value^.kind = clc$name THEN
        project := pvt [p$project].value^.name_value;
      ELSE
        project := pvt [p$project].value^.string_value^;
      IFEND;
    ELSE
      project := link_user_descriptor.project;
    IFEND;

    rhp$save_link_user_description (user, family, password, charge, project, status);

  PROCEND rhp$_change_link_attributes;

MODEND rhm$change_link_attributes;
*DECK DECK=RHM$CLOSE_FILE EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := '170 NOS/VE REMOTE HOST' ??
MODULE rhmcls;

?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc RHT$FUNCTION_STATUS

?? TITLE := 'EXTERNAL PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc ZN7PCIO

?? TITLE := 'RHP$CLOSE_FILE' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ RHP$CLOSE_FILE
{
{     The purpose of this procedure is to close a local file.
{
{     RHP$CLOSE_FILE (LOCAL_FILE_INFO)
{
{ LOCAL_FILE_INFO: (input) This parameter specifies all information
{     pertinent to local file access.
{

  PROCEDURE [XDCL] rhp$close_file ALIAS 'rhmcls' (VAR local_file_info: rht$local_file_info);

    local_file_info.fet.completed := TRUE;
    n7p$cio (local_file_info.fet, - n7c$cio_close_rewind);

  PROCEND rhp$close_file;

MODEND rhmcls;
*DECK DECK=RHM$DISPLAY_LINK_ATTRIBUTES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'rhm$display_link_attributes' ??

MODULE rhm$display_link_attributes;

{
{ PURPOSE:
{   This module contains the processor for the command that allow the users to display their link
{   attributes that are used to run use interstate communication commands (REPLACE_FILE, GET_FILE,
{   CREATE_INTERSTATE_CONNECTION, and PRINT_FILE with the Dual_State_Routing_Parameter).

?? NEWTITLE := '  Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cld$parameter_list
*copyc cle$ecc_file_reference
*copyc cle$ecc_expression_result
*copyc ost$status
*copyc osp$set_status_abnormal
*copyc rhc$condition_limits
?? POP ??
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc pmp$get_170_os_type
*copyc rhp$get_display_link_attr_value
*copyc rhp$get_link_user_descriptor

  CONST
    max_link_attribute_size = 7;

?? TITLE := '  [XDCL] rhp$display_link_attributes', EJECT ??
*copy rhh$display_link_attributes

  PROCEDURE [XDCL] rhp$display_link_attributes
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PROCEDURE (osm$disla) display_link_attributes, display_link_attribute, disla (
{     display_options, display_option, do : list of KEY
{         all
{         (charge, c)
{         (family, f)
{         (project, p)
{         (user, u)
{       keyend = all
{     output, o : file = $output
{     status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 6] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 9] of clt$keyword_specification,
          recend,
          default_value: string (3),
        recend,
        type2: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 4, 21, 14, 24, 30, 797], clc$command, 6, 3, 0, 0, 0, 0, 3, 'OSM$DISLA'],
            [['DISPLAY_OPTION                 ', clc$alias_entry, 1],
            ['DISPLAY_OPTIONS                ', clc$nominal_entry, 1],
            ['DO                             ', clc$abbreviation_entry, 1],
            ['O                              ', clc$abbreviation_entry, 2],
            ['OUTPUT                         ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 356, clc$optional_default_parameter, 0, 3],

{ PARAMETER 2

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 3

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$list_type], [340, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [9], [['ALL                            ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['C                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['CHARGE                         ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['F                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['FAMILY                         ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['P                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['PROJECT                        ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['U                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['USER                           ', clc$nominal_entry,
            clc$normal_usage_entry, 5]]], 'all'],

{ PARAMETER 2

      [[1, 0, clc$file_type], '$output'],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$display_options = 1,
      p$output = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

*copyc clv$display_variables
*copyc clv$nil_display_control

    VAR
      current_option: ^clt$data_value,
      default_ring_attributes: amt$ring_attributes,
      display_charge: boolean,
      display_control: clt$display_control,
      display_family: boolean,
      display_project: boolean,
      display_user: boolean,
      link_user_descriptor: rht$link_user_descriptor,
      local_status: ost$status,
      os_type: ost$170_os_type;

?? NEWTITLE := 'abort_handler', EJECT ??

    PROCEDURE abort_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND abort_handler;

*copyc clp$new_page_procedure

?? TITLE := '    put_subtitle', EJECT ??

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

{ The display_link_attributes command has no subtitles, this
{ is merely a dummy routine used to keep the module consistent
{ with those that do produce subtitles.

    PROCEND put_subtitle;

?? TITLE := 'display_attributes', EJECT ??

    PROCEDURE display_attributes
      (    header: string ( * );
           attribute_value: string ( * );
       VAR status: ost$status);

      CONST
        tab_over = max_link_attribute_size + 3;

      VAR
        edited_header: string (tab_over),
        start_option: amt$term_option;

      status.normal := TRUE;
      start_option := amc$start;
      edited_header := header;
      edited_header (tab_over - 1) := ':';
      clp$put_partial_display (display_control, edited_header, clc$no_trim, start_option, status);
      IF NOT status.normal THEN
        EXIT rhp$display_link_attributes;
      IFEND;
      clp$put_partial_display (display_control, attribute_value, clc$trim, amc$terminate, status);
      IF NOT status.normal THEN
        EXIT rhp$display_link_attributes;
      IFEND;
    PROCEND display_attributes;

?? TITLE := 'display_selected_attributes', EJECT ??

    PROCEDURE display_selected_attributes
      (    attribute_name: ost$name;
           link_user_descriptor: rht$link_user_descriptor;
       VAR status: ost$status);

      status.normal := TRUE;
      CASE attribute_name (1) OF
      = 'A' =
        display_attributes ('CHARGE', link_user_descriptor.charge, status);
        display_attributes ('FAMILY', link_user_descriptor.family, status);
        display_attributes ('PROJECT', link_user_descriptor.project, status);
        display_attributes ('USER', link_user_descriptor.user, status);
      = 'C' =
        display_attributes ('CHARGE', link_user_descriptor.charge, status);
      = 'F' =
        display_attributes ('FAMILY', link_user_descriptor.family, status);
      = 'P' =
        display_attributes ('PROJECT', link_user_descriptor.project, status);
      = 'U' =
        display_attributes ('USER', link_user_descriptor.user, status);
      ELSE
        osp$set_status_abnormal ('CL', cle$name_not_a_keyword_value, attribute_name, status);
      CASEND;
    PROCEND display_selected_attributes;

?? TITLE := 'rhp$display_link_attributes', EJECT ??

{ Begin procedure RHP$DISPLAY_LINK_ATTRIBUTES.

    pmp$get_170_os_type (os_type, status);
    IF status.normal THEN

{ If the OS type is none, then the command cannot be executed.

      IF os_type = osc$ot7_none THEN
        osp$set_status_abnormal (rhc$remote_host_id,
                                 rhe$no_partner_exists, 'DISPLAY_LINK_ATTRIBUTES', status);
        RETURN;
      IFEND;
    IFEND;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    rhp$get_link_user_descriptor (link_user_descriptor, status);
    IF NOT status.normal THEN
      IF status.condition = rhe$lud_cannot_be_found THEN

{ This error only occurs when entering a dual state command at
{ the NOS/VE console and a CHALA or a SETLA command has not been
{ previously executed.  A link user descriptor will be created for
{ this user with all values initialized to blank.

        link_user_descriptor.charge := ' ';
        link_user_descriptor.family := ' ';
        link_user_descriptor.project := ' ';
        link_user_descriptor.user := ' ';
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

{ Get the displayable link attributes.

    rhp$get_display_link_attr_value (display_charge, display_family, display_project, display_user);
    IF NOT display_charge THEN
      link_user_descriptor.charge := 'value suppressed               ';
    IFEND;
    IF NOT display_family THEN
      link_user_descriptor.family := 'value suppressed               ';
    IFEND;
    IF NOT display_project THEN
      link_user_descriptor.project := 'value suppressed               ';
    IFEND;
    IF NOT display_user THEN
      link_user_descriptor.user := 'value suppressed                ';
    IFEND;

  /display_attb/
    BEGIN
      display_control := clv$nil_display_control;
      #SPOIL (display_control);
      osp$establish_block_exit_hndlr (^abort_handler);
      default_ring_attributes.r1 := #RING (^default_ring_attributes);
      default_ring_attributes.r2 := #RING (^default_ring_attributes);
      default_ring_attributes.r3 := #RING (^default_ring_attributes);
      clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, fsc$list,
            default_ring_attributes, display_control, status);
      IF NOT status.normal THEN
        EXIT /display_attb/;
      IFEND;
      clv$titles_built := FALSE;
      clv$command_name := 'DISPLAY_LINK_ATTRIBUTES';

      IF display_control.page_width < clc$narrow_page_width THEN
        clv$page_width := clc$narrow_page_width;
      ELSEIF display_control.page_width > clc$wide_page_width THEN
        clv$page_width := clc$wide_page_width;
      ELSE
        clv$page_width := display_control.page_width;
      IFEND;

      current_option := pvt [p$display_options].value;
      WHILE current_option <> NIL DO
        display_selected_attributes (current_option^.element_value^.keyword_value, link_user_descriptor,
              status);
        IF NOT status.normal THEN
          EXIT /display_attb/;
        IFEND;
        IF (current_option^.element_value^.keyword_value (1) = 'A') THEN
          EXIT /display_attb/;
        IFEND;

        current_option := current_option^.link;
      WHILEND;
    END /display_attb/;

    clp$close_display (display_control, local_status);
    IF status.normal AND (NOT local_status.normal) THEN
      status := local_status;
    IFEND;
    osp$disestablish_cond_handler;
  PROCEND rhp$display_link_attributes;

MODEND rhm$display_link_attributes;
*DECK DECK=RHM$GET_DISPLAY_LINK_ATTR_VALUE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Remote Host Link Attribute Routines' ??
MODULE rhm$get_display_link_attr_value;

{
{ PURPOSE:
{   This module gets the values of the link attributes that a site will allow
{   a user to display when they enter the DISPLAY_LINK_ATTRIBUTES command.

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osp$verify_system_privilege
*copyc rhv$display_charge_link_attr
*copyc rhv$display_family_link_attr
*copyc rhv$display_project_link_attr
*copyc rhv$display_user_link_attr
?? POP ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL,#GATE] rhp$get_display_link_attr_value', EJECT ??
*copy rhh$get_display_link_attr_value

  PROCEDURE [XDCL, #GATE] rhp$get_display_link_attr_value (
     VAR display_charge: boolean;
     VAR display_family: boolean;
     VAR display_project: boolean;
     VAR display_user: boolean);

{ Check to see whether the call is able to call this procedure.

    osp$verify_system_privilege;

    display_charge := rhv$display_charge_link_attr;
    display_family := rhv$display_family_link_attr;
    display_project := rhv$display_project_link_attr;
    display_user := rhv$display_user_link_attr;

  PROCEND rhp$get_display_link_attr_value;
?? OLDTITLE ??
MODEND rhm$get_display_link_attr_value;
*DECK DECK=RHM$GET_LINK_USER_DESCRIPTOR EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE  Remote Host :' ??
MODULE rhm$get_link_user_descriptor;

{ PURPOSE:
{   The purpose of this module is to return the current link
{   user descriptor.

?? NEWTITLE := '         Global Type Declarations' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc RHT$LINK_USER_DESCRIPTOR
*copyc rhd$condition_codes

?? TITLE := '         External Procedures Referenced By This Module' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc OSP$SET_STATUS_ABNORMAL

?? TITLE := '         rhp$get_link_user_descriptor' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc RHH$GET_LINK_USER_DESCRIPTOR

   VAR
    rhv$link_user_current_family: [XREF] string(31),
    rhv$link_user_descriptor_p: [XREF] ^rht$link_user_descriptor;

PROCEDURE [XDCL, #GATE] rhp$get_link_user_descriptor  (
  VAR lud: rht$link_user_descriptor;
  VAR status: ost$status);

  VAR
    lud_p: ^rht$link_user_descriptor,
    valid_family_name: string(31),
    endchar:char;

{ Initialize a pointer to the pointer of the link user descriptors.

  lud_p := rhv$link_user_descriptor_p;
  status.normal := TRUE;

{ Return if no link user description defined.

  IF lud_p = NIL THEN
    osp$set_status_abnormal ('RH',rhe$lud_cannot_be_found, '',
      status);
    RETURN;
  IFEND;

{ Return the link user descriptor that was last entered by a
{   link_user command.

  lud := lud_p^;
  valid_family_name := rhv$link_user_current_family;

  /scan_thru_lud_list/
  WHILE TRUE DO
    IF (lud_p <> NIL) THEN
      IF valid_family_name = lud_p^.family THEN
        LUD := lud_p^;
        RETURN;
      ELSE
        lud_p := lud_p^.next_lud_p;
      IFEND;
    ELSE
      osp$set_status_abnormal ('RH',rhe$lud_cannot_be_found, valid_family_name, status);
      RETURN;
    IFEND;
  WHILEND;

PROCEND rhp$get_link_user_descriptor;

MODEND rhm$get_link_user_descriptor;
*DECK DECK=RHM$GET_REPLACE_EXEC EXPAND=TRUE

*copyc osd$default_pragmats
?? NEWTITLE := '170 NOS/VE REMOTE HOST' ??
MODULE rhm$get_replace_exec ALIAS 'rhmpfp';

{ Select target 170 operating system.
*IF ($string($name(wev$target_operating_system))='NOS')

  ?VAR rhv$nos_be: boolean := FALSE ?;
*ELSE

  ?VAR rhv$nos_be: boolean := TRUE ?;
*IFEND

?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc rhc$constants
*copyc rht$function_status
*copyc mld$memory_link_declarations

?? TITLE := 'EXTERNAL PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc rhp$sign_on_and_off_os
*copyc rhp$add_sender_os
*copyc rhp$confirm_send_os
*copyc rhp$send_message_os
*copyc rhp$receive_message_os
*copyc rhp$log_status
*copyc rhp$wait
*copyc rhp$open_file
*copyc rhp$close_file
*copyc rhp$return_file
*copyc rhp$map_pfm_code_to_rh_code
*copyc zutpsfn
*copyc rhp$cpm_function_request
*copyc pxiotyp
*copyc bizopen
*copyc bizget
*copyc bizclos
*copyc zn7ppfm
*copyc zn7pcio

  PROCEDURE [XREF] pfsend (lfn: integer;
        an170: integer;
        an180: integer;
    VAR detailed_status: integer;
    VAR pfsend_status: integer);

  PROCEDURE [XREF] pfrec (lfn: integer;
        an170: integer;
        an180: integer;
    VAR detailed_status: integer;
    VAR pfsend_status: integer);

?? SET (LIST := ON) ??
{
{ The following variable defines the value of the signal option parameter
{ for all mli send/receive request issued by the irhf c170 pf routines.

    VAR
      signal_record: [STATIC] mlt$signal_record := [0, *, * ],
      rhv$signal: [XDCL, STATIC] mlt$signal := ^signal_record;

?? TITLE := 'RHP$170_PF_FUNCTION_PROCESSOR' ??
?? SET (LIST := ON) ??
?? EJECT ??


  PROGRAM rhp$170_pf_function_processor;

    CONST
      get_pf = rhc$get_pf,
      time_out_limit = 100,
      replace_pf = rhc$replace_pf;

    VAR
      application_names: [STATIC] rht$mli_application_names,
      sender_name: mlt$application_name,
      status: ost$status,
      unique: mlt$application_name, { see note below }
      abnormal_mli_status_message: string (42),
      conf_stat: ost$status,
      time_cnt: 0 .. 100,
      string_length: integer,
      message_info: [STATIC] rht$mli_message_info :=
            [^permanent_file_info, *, *, *],
      permanent_file_info: [STATIC] record
        permanent_file_name: string (31),
        user_or_id: string (9),
        file_cycle: string (3),
        passwords: array [1 .. 2] of string (9),
      recend;

{ Form memory link application names.

    form_application_names (application_names);

{ Sign on to the memory link.

  /ml_sign_on/
    REPEAT
      rhp$sign_on_os (application_names.application.application_name, 0, unique,
            status);
      IF NOT status.normal THEN
        CASE status.condition OF
        = mlc$ant_full, mlc$busy_interlock, mlc$pool_buffer_not_avail =
        ELSE
          abnormal_mli_status_message (1, 31) :=
                'sign on mli abnormal condition =';
          STRINGREP (abnormal_mli_status_message (32, 3), string_length,
                status.condition);
          log_status (dayfile_log_and_display, abnormal_mli_status_message (1,
                31 + string_length));
        CASEND;
        wait (1000);
      IFEND;
    UNTIL status.normal; {ml_sign_on}

{ Give name of sender to the memory link.

  /ml_add_sender/
    REPEAT
      rhp$add_sender_os (application_names.application.application_name,
            application_names.destination.application_name, status);
      IF NOT status.normal THEN
        IF status.condition <> mlc$busy_interlock THEN
          abnormal_mli_status_message (1, 34) :=
                'add sender mli abnormal condition=';
          STRINGREP (abnormal_mli_status_message (35, 3), string_length,
                status.condition);
          log_status (dayfile_log_and_display, abnormal_mli_status_message (1,
                34 + string_length));
        IFEND;
        wait (1000);
      IFEND;
    UNTIL status.normal; {ml_add_sender}

{ Receive function code and call the processor of the function.

    message_info.message_area_length := #SIZE (permanent_file_info);
    time_cnt := 0;
  /process_function/
    REPEAT
      rhp$receive_message_os (application_names.application.application_name,
            message_info.arbitrary_info, rhv$signal, message_info.message_area,
            message_info.message_length, message_info.message_area_length,
            0{index for receive any pending message}, sender_name,
            status);
      IF status.normal OR (status.condition = mlc$signal_failed_ignored) THEN
        CASE message_info.arbitrary_info OF
        = get_pf =
          get_permanent_file (permanent_file_info, application_names);
        = replace_pf =
          replace_permanent_file (permanent_file_info, application_names);
        CASEND;
      ELSE
        CASE status.condition OF
          = mlc$busy_interlock =
            wait (1000);
          = mlc$receive_list_index_invalid =
            time_cnt := time_cnt + 1;
            IF time_cnt = time_out_limit THEN
              rhp$confirm_send_os (application_names.application.application_name,
                                application_names.destination.application_name,conf_stat);
              IF (NOT(conf_stat.normal)) AND
                 (conf_stat.condition = mlc$receiver_not_signed_on) THEN
                EXIT /process_function/;
              ELSE
                time_cnt := 0;
                wait (1000);
              IFEND;
            IFEND;
          = mlc$nosve_not_up =
            EXIT /process_function/;
        ELSE
          abnormal_mli_status_message (1, 39) :=
                  'receive message mli abnormal condition=';
          STRINGREP (abnormal_mli_status_message (40, 3), string_length,
                status.condition);
          log_status (dayfile_log_and_display, abnormal_mli_status_message
                (1, 39 + string_length));
        CASEND;
      IFEND;
    UNTIL status.normal OR (status.condition = mlc$signal_failed_ignored);
          { process_function }

    rhp$sign_off_os (application_names.application.application_name,  status);

  PROCEND rhp$170_pf_function_processor;

?? TITLE := 'GET_PERMANENT_FILE' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ GET_PERMANENT_FILE
{
{       The purpose of this procedure is to perform all work necessary to
{ accomplish an A170/NOS permanent file GET of the file identified by pf_info
{ and transfer that file to the application which is identified by the
{ destination field of application_names.
{
{       GET_PERMANENT_FILE (PERMANENT_FILE_INFO,APPLICATION_NAMES)
{
{ PERMANENT_FILE_INFO: (input) This parameter contains all information
{                      required to identify the permanent file on which
{                      the permanent file function is to be performed.
{
{ APPLICATION_NAMES: (input) This parameter identifies the application
{                    performing the permanent file function and the
{                    application to which the permanent file is transfered.
{

  PROCEDURE get_permanent_file (
    permanent_file_info: record
      permanent_file_name: string (31),
      user_or_id: string (9),
      file_cycle: string (3),
      passwords: array [1 .. 2] of string (9),
    recend;
    VAR application_names: rht$mli_application_names);

    CONST
      file_acquired = rhc$ok;

    VAR
      local_file_info: rht$local_file_info,
      permanent_file_type: rht$permanent_file_types,
      condition: integer,
      state: (send_file, send_condition),
      { message_info: [STATIC] rht$mli_message_info:=[^data_buffer,0,*,*],
      message_info: [STATIC] rht$mli_message_info := [ * , 0, * , * ], { kludge
      abnormal_mli_status_message: string(39),
      string_length: integer,
      data_buffer: integer,
      detailed_status,
      pfsend_status: integer,
      status: ost$status;


{ Acquire the permanent file requested by the GET.

    message_info.message_area := ^data_buffer;

? IF rhv$nos_be = TRUE THEN
      local_file_info.fet.filename := local_file_name1;
      attach_file (permanent_file_info, local_file_info.fet.filename, condition);
? ELSE
    acquire_permanent_file (permanent_file_info, local_file_info.fet,
          permanent_file_type, condition);
? IFEND
    IF condition = file_acquired THEN
      state := send_file;
    ELSE
      message_info.arbitrary_info := condition;
      state := send_condition;
    IFEND;

{ Send data in the permanent file to the 180 side.

    CASE state OF
      = send_file =
        pfsend (local_file_info.fet.filename, application_names.application.
              application_name, application_names.destination.application_name,
              detailed_status, pfsend_status);
        IF pfsend_status = 1 THEN
          log_status (dayfile_log, 'File could not be transferred to the 180 side');
          log_status (dayfile_log, 'due to the file INPUT empty or mispositioned.');
          log_status (dayfile_log, 'check your NOS prolog or call your site analyst.');
        IFEND;
      = send_condition =
        message_info.message_length := 0;
        /send_loop/
        REPEAT
          rhp$send_message_os (application_names.application.application_name,
                message_info.arbitrary_info, rhv$signal, message_info.
                message_area, message_info.message_length, application_names.
                destination.application_name, status);
          IF NOT status.normal THEN
            CASE status.condition OF
            = mlc$busy_interlock, mlc$pool_buffer_not_avail,
              mlc$prior_msg_not_received =
              wait (1000);
            ELSE
              abnormal_mli_status_message (1, 36) :=
                    'send message mli abnormal condition=';
              STRINGREP (abnormal_mli_status_message (37, 3), string_length,
                    status.condition);
              log_status (dayfile_log_and_display, abnormal_mli_status_message
                    (1, 36 + string_length));
              EXIT /send_loop/;
            CASEND;
          IFEND;
        UNTIL status.normal; {send_loop}
      CASEND;

  PROCEND get_permanent_file;

?? TITLE := 'REPLACE_PERMANENT_FILE' ??
?? SET (LIST := ON) ??
?? EJECT ??

{
{       The purpose of this procedure is to receive transmission of a file
{ from the application identified by the destination field of application_
{ names and perform all work necessary to accomplish an A170/NOS permanent
{ file REPLACE of the file identified by pf_info with the transmitted file.
{
{       REPLACE_PERMANENT_FILE (PERMANENT_FILE_INFO,APPLICATION_NAMES)
{
{ PERMANENT_FILE_INFO: (input) This parameter contains all information
{                      required to identify the permanent file on which
{                      the permanent file function is to be performed.
{
{ APPLICATION_NAMES: (input) This parameter identifies the application
{                    performing the permanent file function and the
{                    application to which the permanent file is transfered.
{

  PROCEDURE replace_permanent_file (
    permanent_file_info: record
      permanent_file_name: string (31),
      user_or_id: string (9),
      file_cycle: string (3),
      passwords: array [1 .. 2] of string (9),
    recend;
    VAR application_names: rht$mli_application_names);

    CONST
      file_defined = rhc$ok,
      zero_message_length = 0;

    VAR
      local_file_info: rht$local_file_info,
      permanent_file_type: rht$file_type,
      permanent_file_status: rht$file_status_type,
      condition: integer,
      arbitrary_info: mlt$arbitrary_info,
      sender_application_name: mlt$application_name,
      detailed_status,
      pfrec_status: integer,
      message_length: mlt$message_length,
      status: ost$status,
      tran_status: rht$trans_status_type;

{ Define a file that will receive the data.

? IF rhv$nos_be = TRUE THEN
      local_file_info.fet.filename := local_file_name1;
      local_file_request (local_file_info.fet.filename, condition);
? ELSE
      define_receive_file (permanent_file_info, local_file_info.fet,
            permanent_file_type, permanent_file_status, condition);
? IFEND;

    IF condition = file_defined THEN

{ Copy data from 170 side to a local file on the 180 side.

      pfrec (local_file_info.fet.filename, application_names.application.
            application_name, 0, detailed_status, pfrec_status);
      tran_status := ok;
? IF rhv$nos_be = TRUE THEN
        catalog_file (permanent_file_info, local_file_info.fet.filename, arbitrary_info);
        IF arbitrary_info <> rhc$ok THEN
          tran_status := a170_error;
        IFEND;
? ELSE
        dispose_files (local_file_info.fet, permanent_file_type,
            permanent_file_status, tran_status, arbitrary_info);
? IFEND;
    ELSE
      arbitrary_info := condition;
      tran_status := a170_error;
    IFEND;

{ If error occurred on 170 side transfer error to 180 side.

    IF tran_status <> c180_error THEN

    /send_condition/
      REPEAT
        rhp$send_message_os (application_names.application.application_name,
              arbitrary_info, rhv$signal, ^condition, zero_message_length,
              application_names.destination.application_name, status);
        IF NOT status.normal THEN
          CASE status.condition OF
          = mlc$busy_interlock, mlc$pool_buffer_not_avail,
            mlc$prior_msg_not_received =
             wait (1000);
          = mlc$receiver_name_syntax_error =
            log_status (dayfile_log, 'File could not be received from the 180 side');
            log_status (dayfile_log, 'due to the file INPUT empty or mispositioned.');
            log_status (dayfile_log, 'check your NOS prolog or call your site analyst.');
            EXIT /send_condition/;
          ELSE
            EXIT /send_condition/;
          CASEND;
        IFEND;
      UNTIL status.normal; {send_codition}
    IFEND;

  PROCEND replace_permanent_file;

?? TITLE := 'ACQUIRE_PERMANENT_FILE' ??
?? SET (LIST := ON) ??
?? EJECT ??

{
{      The purpose of this procedure is to acquire the permanent file
{ identified by permanent_file_info.
{
{      ACQUIRE_PERMANENT_FILE (PERMANENT_FILE_INFO,FET,PERMANENT_FILE_TYPE,
{           ACQUIRE_CONDITION)
{
{ PERMANENT_FILE_INFO: (input) This parameter contains all information required
{                      to identify the permanent file which is to be acquired.
{
{ FET: (output) This parameter specifies all information pertinent to the
{      identification and access of the acquired (local) permanent file.
{
{ PERMANENT_FILE_TYPE: (output) This parameter identifies the access type of
{                      the permanent file, i.e. indirect or direct.
{                      Permanent_file_type is not set if the file does not
{                      exist as defined by permanent_file_info.
{
{ ACQUIRE_CONDITION: (output) This parameter indicates the condition of the
{                    acquire request.  All conditions are remote host def-
{                    initions of A170/NOS permanent file manager condition
{                    codes.
{

  PROCEDURE acquire_permanent_file (
    permanent_file_info: record
      permanent_file_name: string (31),
      user_or_id: string (9),
      file_cycle: string (3),
      passwords: array [1 .. 2] of string (9),
    recend;
    VAR fet: n7t$fet;
    VAR permanent_file_type: rht$permanent_file_types;
    VAR acquire_condition: integer);

    CONST
      pfm_fet_extension_length = 10;

    TYPE nonfast_attach_set = SET of 1 .. 5;

    VAR
      i: integer,
      dc_file_name: utt$dc_name;

{ Initialize the file enviroment table (fet) to acquire the permanent file.}

    FOR i:=1 TO 22 DO
      fet.fet1_22[i]:=0;
    FOREND;
    fet.completed:=TRUE;
    utp$convert_string_to_file_name(permanent_file_info.permanent_file_name,
          dc_file_name);
    fet.filename:=dc_file_name;
    fet.user_processing:=FALSE;
    fet.error_processing:=TRUE;
    fet.extension_length:=pfm_fet_extension_length;
    fet.pfn:=dc_file_name;

{ Set fill8 to not allow attach of NOS fast attach files.

    fet.fill8 := $nonfast_attach_set [4];
    utp$convert_string_to_file_name(permanent_file_info.user_or_id,
          dc_file_name);
    fet.optional_un:=dc_file_name;
    utp$convert_string_to_file_name(permanent_file_info.passwords [1] (1, 7),
          dc_file_name);
    fet.file_password:=dc_file_name;
    fet.file_mode := n7c$pfm_m_read;

{ Acquire the permanent file.}

    n7p$pfm (n7c$pfm_attach, fet); { Try attaching it first.}
    IF fet.response_code = n7c$pfm_file_not_found THEN
      n7p$pfm (n7c$pfm_get, fet); { Get the file.}
    IFEND;
    map_pfm_code_to_rh_code(fet.response_code,acquire_condition);

  PROCEND acquire_permanent_file;

?? TITLE := 'DEFINE_RECEIVE_FILE' ??
?? SET (LIST := ON) ??
?? EJECT ??

{
{      The purpose of this procedure is to determine the existence and
{ access type of the permanent file to be replaced and define the file
{ to which the transfer of data, from the C180 task, will be made.
{
{      DEFINE_RECEIVE_FILE (PERMANENT_FILE_INFO,FET,PERMANENT_FILE_TYPE,
{                               PERMANENT_FILE_STATUS,DEFINE_CONDITION)
{
{ PERMANENT_FILE_INFO: (input) This parameter contains all information
{                      required to identify the permanent file which is
{                      to be replaced.
{
{ FET (output): This parameter specifies the fet which identifies the file
{     which will receive transmition of the file data from the C180 task.
{
{ PERMANENT_FILE_TYPE: (output) This parameter indicates the access type of
{                      the permanent file, i.e. direct or indirect.
{
{ PERMANENT_FILE_STATUS: (output) This parameter indicates wheather the file
{                        is new or if it already exists.
{
{ DEFINE_CONDITION: (output) This parameter indicates the condition of the
{                   define request.  All conditions are remote host definitions
{                   of A170/NOS permanent file manager condition codes.
{

  PROCEDURE define_receive_file (
    permanent_file_info: record
      permanent_file_name: string (31),
      user_or_id: string (9),
      file_cycle: string (3),
      passwords: array [1 .. 2] of string (9),
    recend;
    VAR fet: n7t$fet;
    VAR permanent_file_type: rht$file_type;
    VAR permanent_file_status: rht$file_status_type;
    VAR define_condition: integer);

    CONST
      pfm_fet_extension_length = 10;

    TYPE nonfast_attach_set = SET of 1 .. 5;

    VAR
      i: integer,
      dc_file_name: utt$dc_name;

{ Initialize the fet that identifies the file to be used as a receiving file.

    FOR i := 1 TO 22 DO
      fet.fet1_22 [i] := 0;
    FOREND;
    fet.completed := TRUE;
    utp$convert_string_to_file_name (permanent_file_info.permanent_file_name, dc_file_name);
    fet.filename := dc_file_name;
    fet.user_processing := FALSE;
    fet.error_processing := TRUE;
    fet.extension_length := pfm_fet_extension_length;

{ Set fill8 to not allow attach of NOS fast attach files.

    fet.fill8 := $nonfast_attach_set [4];
    fet.pfn := dc_file_name;
    utp$convert_string_to_file_name (permanent_file_info.user_or_id,
          dc_file_name);
    fet.optional_un := dc_file_name;
    utp$convert_string_to_file_name (permanent_file_info.passwords [1] (1, 7),
         dc_file_name);
    fet.file_password := dc_file_name;
    fet.file_mode := n7c$pfm_m_write;

{ Determine if the permanent file to be replaced exists.

    n7p$pfm (n7c$pfm_define, fet);
    CASE fet.response_code OF

    = n7c$pfm_ok =         { A new permanent file was created.
      permanent_file_type := direct;
      permanent_file_status := new;

    = n7c$pfm_file_already_permanent =   { Permanent file found in user catalog.
      permanent_file_status := old;
      n7p$pfm (n7c$pfm_attach, fet);
      CASE fet.response_code OF
      = n7c$pfm_ok =
        permanent_file_type := direct;
        permanent_file_status := new;
      = n7c$pfm_file_not_found =
        fet.response_code := n7c$pfm_ok;
        permanent_file_type := indirect;
      ELSE
        ;
      CASEND;

    = n7c$pfm_illegal_user_access =    { User not validated for direct file access use.
      permanent_file_status := old;
      permanent_file_type := indirect;
      fet.response_code := n7c$pfm_ok;

    = n7c$pfm_illegal_request =    { File maybe in alternate user catalog.
      n7p$pfm (n7c$pfm_attach, fet);
      CASE fet.response_code OF
      = n7c$pfm_ok =
        permanent_file_type := direct;
        permanent_file_status := new;
      = n7c$pfm_file_not_found =
        fet.response_code := n7c$pfm_ok;
        permanent_file_type := indirect;
        permanent_file_status := old;
      ELSE
        ;
      CASEND;

    ELSE
      ;
    CASEND;
    map_pfm_code_to_rh_code (fet.response_code, define_condition);

  PROCEND define_receive_file;

?? TITLE := ' DISPOSE_FILES' ??
?? SET (LIST := ON) ??
?? EJECT ??
{
{       The purpose of this procedure is to dispose the file(s) used in
{ replacing a file.  The final disposition of the file(s) is dependent on
{ the transmission status, the file type, and the status of the permanent
{ file.
{
{       DISPOSE_FILES (LF_FET,PERMANENT_FILE_TYPE,PERMANENT_FILE_STATUS,
{                          TRANSMISSION_STATUS,DISPOSE_CONDITION)
{
{ LF_FET: (input) This parameter specifies the fet which identifies the file(s)
{         which is/are to be disposed.
{
{ PERMANENT_FILE_TYPE: (input) This parameter indicates the access type of
{                      the permanent file, i.e. direct or indirect.
{
{ PERMANENT_FILE_STATUS: (input) This parameter indicates wheather the
{                        permanent file is new or if it existed before
{                        the replace invokation.
{
{ TRANSMISSION_STATUS: (input) This parameter indicates the status of the
{                      transfer of the file from the C180 task to the A170
{                      replace receive file.
{
{ DISPOSE_CONDITION: (output) This parameter indicates the condition of
{                    the dispose request.  All conditions are remote host
{                    definitions of A170/NOS permanent file manager cond-
{                    ition codes.
{

  PROCEDURE dispose_files (VAR lf_fet: n7t$fet;
    permanent_file_type: rht$file_type;
    permanent_file_status: rht$file_status_type;
    transmission_status: rht$trans_status_type;
    VAR dispose_condition: integer);

    VAR
      i: integer,
      pf_fet: n7t$fet,
      inpfn: utt$dc_name,
      outfn: utt$dc_name;

{ Initialize the permanent file's fet.

    pf_fet.fet0 := 0;
    FOR i := 1 TO 22 DO
      pf_fet.fet1_22 [i] := 0;
    FOREND;
    pf_fet.completed := TRUE;

    IF permanent_file_type = direct THEN
      IF permanent_file_status = old THEN
        IF transmission_status = ok THEN
          inpfn := lf_fet.filename;
          outfn := lf_fet.pfn;
          dispose_condition := rhc$ok;
        ELSE
          pf_fet.filename := lf_fet.pfn; { File not transmitted.
          n7p$cio (pf_fet, n7c$cio_return); { Return the old attached file.
        IFEND;
      ELSE
        IF transmission_status = ok THEN
          dispose_condition := rhc$ok; { The new file is ok.
        ELSE
          pf_fet.filename := lf_fet.pfn; { The new file was not transmitted ok.
          n7p$pfm (n7c$pfm_purge, pf_fet); { Purge the new file.
        IFEND;
      IFEND;
    ELSE
      IF transmission_status = ok THEN
        n7p$pfm (n7c$pfm_replace, lf_fet); { Replace indirect with new local.
        map_pfm_code_to_rh_code (lf_fet.response_code, dispose_condition);
      IFEND;
    IFEND;
    n7p$cio (lf_fet, n7c$cio_return); { Return the local file.

  PROCEND dispose_files;


?? TITLE := 'EXTERNALS REFERENCED BY NOS/BE PROCEDURES' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc zutps2d
*copyc rhc$nosbe_pf_error_codes

  CONST
    local_file_name1 = 32322210241520(8); {ZZRHTMP}

  TYPE
{ Type definition for NOS/BE 9 character display code name.}
    dc_name9 = array [1 .. 1] OF packed array [0 .. 9] OF 0 ..3f(16),
{ Type definition of NOS/BE 3 character display code cycle.}
    dc_cycle = array [1 .. 1] OF packed array [0 .. 9] OF 0 .. 3f(16);

?? TITLE := 'LOCAL_FILE_REQUEST' ??
?? SET (LIST := ON) ??
?? EJECT ??

{     The purpose of this procedure is to create local file to receive
{ data from the C180 partner task.
{
{      LOCAL_FILE_REQUEST (LOCAL_FILE_NAME, REQUEST_STATUS)
{
{ LOCAL_FILE_NAME: (input) This parameter gives the name to be used for
{                  creating a local file.
{
{ REQUEST_STATUS: (output) This parameter indicates the condition of creating
{         a local file.
{

  PROCEDURE local_file_request (
    local_file_name: utt$dc_name;
    VAR request_status: integer);

    TYPE
      request_parameter_block = PACKED RECORD
        local_file_name: utt$dc_name,
        status_returned: 0 .. 1ffff(16),
        complete: boolean,
        flags59_48: 0 .. 0fff(16),
        reserve1: 0 .. 0fff(16),
        flags35_32: 0 .. 0f(16),
        pf_rms_flag: boolean,
        flags30_12: 0 .. 7ffff(16),
        device_type_allocation: 0 .. 0fff(16),
      RECEND;

    VAR
      req_param_block: request_parameter_block,
      abnormal_req_status_msg: string (33),
      string_length: integer;

  PROCEDURE [XREF] request ALIAS 'rhpreq' (rpb: request_parameter_block);


{ initialize the request parameter block to create a local file.

    log_status (dayfile_log_and_display, 'Request a local file.');
    req_param_block.local_file_name := local_file_name;
    req_param_block.status_returned := 0;
    req_param_block.complete := FALSE;
    req_param_block.flags59_48 := 0;
    req_param_block.reserve1 := 0;
    req_param_block.flags35_32 := 0;
    req_param_block.pf_rms_flag := TRUE;
    req_param_block.flags30_12 := 0;
    req_param_block.device_type_allocation := 0;

{ Request a local file

    request (req_param_block);
    IF req_param_block.status_returned <> 0 THEN
      abnormal_req_status_msg (1, 30) := 'REQUEST abnormal condition = ';
      STRINGREP (abnormal_req_status_msg (30, 3), string_length,
            req_param_block.status_returned);
      log_status (dayfile_log_and_display, abnormal_req_status_msg (1,
            29 + string_length));
      request_status := req_param_block.status_returned;
    ELSE
      request_status := rhc$ok;
    IFEND;

  PROCEND local_file_request;

?? TITLE := 'ATTACH FILE' ??
?? SET (LIST := ON) ??
?? EJECT ??

{     The purpose of this procedure is to attach a permanent file.
{
{      ATTACH_FILE (PERMANENT_FILE_INFO, LOCAL_FILE_NAME, ATTACH_CONDITION)
{
{ PERMANENT_FILE_INFO: (input) This parameter contains all information
{                      required to identify the permanent file to attach.
{
{ LOCAL_FILE_NAME: (input) This parameter gives the name of the local file.
{
{ ATTACH_CONDITION (output) This parameter indicates the condition of the
{                   attach request.  All conditions are remote host definitions
{                   of NOS/BE permanent file manager condition codes.
{

  PROCEDURE attach_file (
    permanent_file_info: record
      permanent_file_name: string (31),
      user_or_id: string (9),
      file_cycle: string (3),
      passwords: array [1 .. 2] of string (9),
    recend;
    local_file_name: utt$dc_name;
    VAR attach_condition: integer);

    VAR
      req_permanent_file_name: array [1 .. 4] OF packed
                               array [0 .. 9] OF 0 .. 3f(16),
      req_owner_identification: dc_name9,
      req_password1: dc_name9,
      req_password2: dc_name9,
      req_cycle: dc_cycle,
      return_code: 0 .. 1ff(16),
      dc_string_word_index: integer,
      dc_string_char_index: 0 .. 9,
      source_index: ost$string_index,
      eol: boolean;

  PROCEDURE [XREF] attach ALIAS 'rhpatt' (
    local_file_name: utt$dc_name;
    permanent_file_name: array [1 .. 4] OF packed array [0 .. 9] OF 0 .. 3f(16);
    owner_identification: dc_name9;
    file_cycle: dc_cycle;
    password1: dc_name9;
    password2: dc_name9;
    VAR attach_condition: 0 .. 1ff(16));

{ Convert parameters to display code.

    log_status (dayfile_log_and_display, 'Attach the permanent file.');
    dc_string_word_index := 1;
    dc_string_char_index := 0;
    source_index := 1;
    eol := TRUE;
    utp$convert_string_to_dc_string (utc$ascii64, req_permanent_file_name,
          dc_string_word_index, dc_string_char_index,
          permanent_file_info.permanent_file_name,
          source_index, eol);
    dc_string_word_index := 1;
    dc_string_char_index := 0;
    source_index := 1;
    eol := FALSE;
    utp$convert_string_to_dc_string (utc$ascii64, req_owner_identification,
          dc_string_word_index, dc_string_char_index,
          permanent_file_info.user_or_id, source_index, eol);
    dc_string_word_index := 1;
    dc_string_char_index := 0;
    source_index := 1;
    eol := FALSE;
    utp$convert_string_to_dc_string (utc$ascii64, req_password1,
          dc_string_word_index, dc_string_char_index,
          permanent_file_info.passwords [1], source_index, eol);
    dc_string_word_index := 1;
    dc_string_char_index := 0;
    source_index := 1;
    eol := FALSE;
    utp$convert_string_to_dc_string (utc$ascii64, req_password2,
          dc_string_word_index, dc_string_char_index,
          permanent_file_info.passwords [2], source_index, eol);
    dc_string_word_index := 1;
    dc_string_char_index := 0;
    source_index := 1;
    eol := FALSE;
    utp$convert_string_to_dc_string (utc$ascii64, req_cycle,
          dc_string_word_index, dc_string_char_index,
          permanent_file_info.file_cycle, source_index, eol);

{ Attach the file.

    attach (local_file_name, req_permanent_file_name, req_owner_identification,
            req_cycle, req_password1, req_password2, return_code);

    map_pfm_code_to_rh_code (return_code, attach_condition);

  PROCEND attach_file;

?? TITLE := 'CATALOG_FILE' ??
?? SET (LIST := ON) ??
?? EJECT ??

{
{      The purpose of this procedure is to make an existing local file
{ a permanent file by creating entries in permanent file manager tables.
{ A permanent file is known in these tables by a permanent file name unique
{ within an owner ID.  As many as five cycles can exist with the same
{ permanent file name and ID.
{
{      CATALOG_FILE (PERMANENT_FILE_INFO, LOCAL_FILE_NAME, CATALOG_CONDITION)
{
{ PERMANENT_FILE_INFO: (input) This parameter contains all information
{                      required to identify the permanent file to catalog.
{
{ LOCAL_FILE_NAME: (input) This parameter gives the name of the local file.
{
{ CATALOG_CONDITION: (output) This parameter indicates the condition of the
{                   catalog request.  All conditions are remote host definitions
{                   of NOS/BE permanent file manager condition codes.
{

  PROCEDURE catalog_file (
    permanent_file_info: record
      permanent_file_name: string (31),
      user_or_id: string (9),
      file_cycle: string (3),
      passwords: array [1 .. 2] of string (9),
    recend;
    local_file_name: utt$dc_name;
    VAR catalog_condition: integer);


    VAR
      req_permanent_file_name: array [1 ..4] OF packed
                               array [0 .. 9] OF 0 .. 3f(16),

      req_owner_identification: dc_name9,
      req_password1: dc_name9,
      req_password2: dc_name9,
      req_cycle: dc_cycle,
      return_code: 0 .. 1ff(16),
      dc_string_word_index: integer,
      dc_string_char_index: 0 .. 9,
      source_index: ost$string_index,
      eol: boolean;

  PROCEDURE [XREF] catalog ALIAS 'rhpcat' (
    local_file_name: utt$dc_name;
    permanent_file_name: array [1 .. 4] OF packed array [0 .. 9] OF 0 .. 3f(16);
    owner_identification: dc_name9;
    file_cycle: dc_cycle;
    password1: dc_name9;
    password2: dc_name9;
    VAR catalog_condition: 0 .. 1ff(16));

{ Convert parameters to display code.

    log_status (dayfile_log_and_display, 'Catalog the permanent file.');
    dc_string_word_index := 1;
    dc_string_char_index := 0;
    source_index := 1;
    eol := TRUE;
    utp$convert_string_to_dc_string (utc$ascii64, req_permanent_file_name,
          dc_string_word_index, dc_string_char_index,
          permanent_file_info.permanent_file_name,
          source_index, eol);
    dc_string_word_index := 1;
    dc_string_char_index := 0;
    source_index := 1;
    eol := FALSE;
    utp$convert_string_to_dc_string (utc$ascii64,
          req_owner_identification,
          dc_string_word_index, dc_string_char_index,
          permanent_file_info.user_or_id, source_index, eol);
    dc_string_word_index :=1;
    dc_string_char_index :=0;
    source_index := 1;
    eol := FALSE;
    utp$convert_string_to_dc_string (utc$ascii64, req_cycle,
          dc_string_word_index, dc_string_char_index,
          permanent_file_info.file_cycle, source_index, eol);

{ Initialize passwords.
    dc_string_word_index := 1;
    dc_string_char_index := 0;
    source_index := 1;
    eol := FALSE;
    utp$convert_string_to_dc_string (utc$ascii64,
          req_password1,
          dc_string_word_index, dc_string_char_index,
          permanent_file_info.passwords [1], source_index, eol);
    dc_string_word_index := 1;
    dc_string_char_index := 0;
    source_index := 1;
    eol := FALSE;
    utp$convert_string_to_dc_string (utc$ascii64,
          req_password2,
          dc_string_word_index, dc_string_char_index,
          permanent_file_info.passwords [2], source_index, eol);

    catalog (local_file_name, req_permanent_file_name, req_owner_identification,
            req_cycle, req_password1, req_password2, return_code);
    map_pfm_code_to_rh_code (return_code, catalog_condition);

  PROCEND catalog_file;

?? TITLE := 'FORM_APPLICATION_NAMES' ??
?? SET (LIST := ON) ??
?? EJECT ??
{
{       The purpose of this procedure is to generate the partner job and
{ requesting task application names for use by the partner job.
{
{       FORM_APPLICATION_NAMES (APPLICATION_NAMES)
{
{ APPLICATION_NAMES: (output) This parameter contains the generated partner job
{                    and requesting task application names.
{

  PROCEDURE form_application_names (VAR application_names:
    rht$mli_application_names);

    CONST
      a170_application_name_length = 1,
      cpm_function_code_13 = 11;

    TYPE
      getjn_cpmf13_job_name_word_rec = packed record
        jobname: 0 .. 3ffffffffff(16),
        zero: 0 .. 3ffff(16),
      recend;

    VAR
      task_application_name_file: file,
      getjn_cpmf13_job_name_word: getjn_cpmf13_job_name_word_rec;

    cpmfp (cpm_function_code_13, ^getjn_cpmf13_job_name_word);
    application_names.application.application_name :=
          getjn_cpmf13_job_name_word.jobname;
    bi#open (task_application_name_file, 'input', old#, input#, asis#);
    bi#get (task_application_name_file, ^application_names.destination.
          application_name, a170_application_name_length);
    bi#close (task_application_name_file, first#);

  PROCEND form_application_names;

MODEND rhm$get_replace_exec;
*DECK DECK=RHM$INPUT_FILE_EXEC_PGM EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE REMOTE HOST' ??
{ REMOTE_HOST_INPUT_FILE_EXEC_PGM
{
{     The purpose of this module is to initialize, invoke, and
{ monitor the process which receives input files from A170 and
{ routes them to the C180 input queue.  As part of the
{ initialization, the process is signed on to the MLI (see
{ MLI_LINK).
{     If a fatal error is detected during processing,
{ REMOTE_HOST_INPUT_FILE_EXEC_PGM will sign off the process
{ from the MLI and "shut itself down completely".

MODULE rhm$input_file_exec_pgm;

?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc OST$STATUS
*copyc RHC$CONSTANTS
*copyc TMC$WAIT_TIMES
*copyc rhd$nos_ve_types

?? TITLE := 'PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc CLP$PUT_JOB_OUTPUT
*copyc PMP$LOG
*copyc RHP$MLI_LINK
*copyc PMP$LONG_TERM_WAIT
*copyc RHP$QUEUE_FILE_RECEIVE_EXEC
?? SET (LIST := ON) ??
?? TITLE := 'REMOTE_HOST_INPUT_FILE_EXEC_PGM' ??
?? EJECT ??


  PROCEDURE [XDCL] rhp$input;

    VAR
      application_names: [STATIC] rht$mli_application_names := [[c180_id, [0,
        rhc$receive_remote_input, 0]], [c180_id, [0, rhc$send_input_to_remote,
        0]]],
      status: ost$status,
      exec_status: [STATIC] rht$exec_status := beginning;

    VAR
      data_buffer: rht$file_data_buffer,
      data_buffer_pointer: rht$file_data_buffer_pointer;


    data_buffer_pointer := ^data_buffer;
    mli_link (on, application_names, status);
    IF status.normal THEN
      REPEAT
        rhp$queue_file_receive_exec (application_names, data_buffer_pointer,
          exec_status);
        IF exec_status = beginning THEN
          pmp$long_term_wait (tmc$infinite_wait, 1000000);
        IFEND;
        IF exec_status = unrecoverable_error THEN
          exec_status := beginning;
        IFEND;
      UNTIL exec_status = unrecoverable_error;
    IFEND;
    mli_link (off, application_names, status);

  PROCEND rhp$input;

MODEND rhm$input_file_exec_pgm;



*DECK DECK=RHM$INPUT_FILE_RECEIVE EXPAND=TRUE
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE REMOTE HOST' ??
MODULE rhm$input_file_receive;

?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??
?? SET (LIST := OFF) ??
?? EJECT ??
?? SET (LIST := ON) ??
*copyc rhc$condition_limits
*copyc rhc$constants
*copyc rhd$nos_ve_types
*copyc tmc$wait_times
*copyc osc$dual_state_batch
?? TITLE := 'PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := OFF) ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc amp$close
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$put_next
*copyc amp$return
*copyc amp$rewind
*copyc amp$set_segment_eoi
*copyc amp$set_segment_position
*copyc jmp$submit_job
*copyc mlp$receive_message
*copyc mlp$send_message
*copyc osp$format_message
*copyc pmp$get_170_os_type
*copyc pmp$get_unique_name
*copyc pmp$log
*copyc pmp$long_term_wait
*copyc rhp$set_status_abnormal
*copyc rhv$signal
*copyc syp$memory_link_data_conversion
?? TITLE := 'LOG_STATUS' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ LOG_STATUS
{
{        The purpose of this procedure is to format and log an error
{ to the job log.
{
{         LOG_STATUS (MESSAGE_STATUS, STATUS)
{
{ MESSAGE_STATUS: (input) This parameter contains the status to format and
{                 write to the job log.
{
{ STATUS: (output) This parameter returns the success or failure of logging
{         the error.
{

  PROCEDURE log_status
    (    message_status: ost$status;
     VAR status: ost$status);

    VAR
      message: ost$status_message,
      message_area: ^ost$status_message,
      message_line_count: ^ost$status_message_line_count,
      message_line_index: 1 .. osc$max_status_message_lines,
      message_line_size: ^ost$status_message_line_size,
      message_line: ^string ( * ),
      page_width: ost$status_message_line_size;


    status.normal := TRUE;
    page_width := osc$max_status_message_line;
    osp$format_message (message_status, osc$full_message_level, page_width,
          message, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    message_area := ^message;
    RESET message_area;
    NEXT message_line_count IN message_area;
    FOR message_line_index := 1 TO message_line_count^ DO
      NEXT message_line_size IN message_area;
      NEXT message_line: [message_line_size^] IN message_area;
      pmp$log (message_line^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND log_status;

?? TITLE := 'CONVERT_ASCII812_TO_ASCII88' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ CONVERT_ASCII812_TO_ASCII88
{
{       The purpose of this procedure is to convert an A170 8/12 ascii string
{ to an 8/8 ascii string.
{
{       CONVERT_ASCII812_TO_ASCII88 (ASCII812_STRING,
{                ASCII88_STRING, CONVERSION_STATUS)
{
{ ASCII812_STRING: (input) This parameter contains the 8/12 ascii string which
{                 is to be converted.
{
{ ASCII88_STRING: (output) This parameter contains the 8/8 ascii string which
{                  is the result of the conversion.
{
{ CONVERSION_STATUS: (output) This parameter indicates the success or failure
{                    the conversion.  If the output string is not large enough
{                    of to complete the conversion of the entire input string
{                    then a status of non_fatal_error will be returned
{                    otherwise
{                    the conversion will be successful.  In either case,
{                    conversion of as much of the string as is possible
{                    will be performed.
{

  PROCEDURE convert_ascii812_to_ascii88
    (    ascii812_string: array [ * ] of rht$c180_ascii812_word;
     VAR ascii88_string: string ( * );
     VAR conversion_status: rht$status);

    VAR
      ascii812_char_index: 2 .. 5,
      ascii812_string_lbound: integer,
      ascii812_string_length: integer,
      ascii812_string_ubound: integer,
      ascii88_char_index: 0 .. 256,
      ascii88_string_length: 0 .. 256,
      chars_in_last_word: 1 .. 5,
      last_word_index: integer,
      word_index: integer;

    ascii812_string_lbound := LOWERBOUND (ascii812_string);
    ascii812_string_ubound := UPPERBOUND (ascii812_string);
    ascii812_string_length := ascii812_string_ubound - ascii812_string_lbound +
          1;
    ascii88_string_length := STRLENGTH (ascii88_string);
    IF ascii812_string_length * 5 > ascii88_string_length THEN
      last_word_index := ascii812_string_lbound +
            (ascii88_string_length + 4) DIV 5 - 1;
      chars_in_last_word := ascii88_string_length -
            ((ascii88_string_length + 4) DIV 5 - 1) * 5;
      conversion_status := non_fatal_error;
    ELSE
      last_word_index := ascii812_string_ubound;
      chars_in_last_word := 5;
      conversion_status := successful;
    IFEND;
    ascii88_char_index := 0;
    FOR word_index := ascii812_string_lbound TO last_word_index - 1 DO
      ascii88_char_index := ascii88_char_index + 1;
      ascii88_string (ascii88_char_index) :=
            ascii812_string [word_index].ascii812_char1.ascii88_char;
      FOR ascii812_char_index := 2 TO 5 DO
        ascii88_char_index := ascii88_char_index + 1;
        ascii88_string (ascii88_char_index) :=
              ascii812_string [word_index].ascii812_char2_5 [
              ascii812_char_index].ascii88_char;
      FOREND;
    FOREND;
    ascii88_char_index := ascii88_char_index + 1;
    ascii88_string (ascii88_char_index) :=
          ascii812_string [last_word_index].ascii812_char1.ascii88_char;
    FOR ascii812_char_index := 2 TO chars_in_last_word DO
      ascii88_char_index := ascii88_char_index + 1;
      ascii88_string (ascii88_char_index) :=
            ascii812_string [last_word_index].
            ascii812_char2_5 [ascii812_char_index].ascii88_char;
    FOREND;

  PROCEND convert_ascii812_to_ascii88;

?? TITLE := 'route_file' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ ROUTE_FILE
{
{     The purpose of this procedure is to provide a means by which
{ a CYBIL procedure can route a local file to a system queue.
{
{           ROUTE_FILE (EXEC_TYPE,LOCAL_FILE_INFO,QUEUE_FILE_INFO,ROUTE_STATUS)
{
{ EXEC_TYPE: (input) This parameter specifies the type of queue file transfer
{             exec which is requesting the file route.
{
{ LOCAL_FILE_INFO: (input) This parameter specifies all information
{                  pertinent to local file access.
{
{ QUEUE_FILE_INFO: (input) This parameter communicates all queue file
{                  attributes needed for IRHF routing.
{
{ ROUTE_STATUS: (output) This parameter indicates to the calling
{               procedure the completion status of the route function,
{               i.e. the success or failure of the route.  The
{               following status values may be returned by this
{               request:     unsuccessful
{                            successful
{                            fatal_error
{

  PROCEDURE route_file
    (    exec_type: rht$irhf_exec_types;
     VAR local_file_info: rht$local_file_info;
         queue_file_info: rht$queue_file_info;
     VAR route_status: ost$status);

    VAR
      conversion_status: rht$status,
      job_submission_options_p: ^jmt$job_submission_options,
      msg_status: ost$status,
      system_supplied_name: jmt$system_supplied_name;

    PUSH job_submission_options_p: [1 .. 4];
    job_submission_options_p^ [1].key := jmc$origin_application_name;
    job_submission_options_p^ [1].origin_application_name :=
          osc$dual_state_batch;
    job_submission_options_p^ [2].key := jmc$source_logical_id;
    job_submission_options_p^ [2].source_logical_id := '';
    job_submission_options_p^ [3].key := jmc$implicit_routing_text;
    PUSH job_submission_options_p^ [3].implicit_routing_text;
    job_submission_options_p^ [3].implicit_routing_text^.text := ' ';
    job_submission_options_p^ [3].implicit_routing_text^.size :=
          queue_file_info.c180.implicit_text_size;
    job_submission_options_p^ [4].key := jmc$output_destination_usage;
    job_submission_options_p^ [4].output_destination_usage :=
          jmc$dual_state_usage;

{ NOTE: There MUST be a value in the source_logical_id (NOS LID)
{       field or the call to jmp$submit_job will fail.

{ NOTE: The (1,3) must be here to limit the convert procedure from writing
{       into more than three characters - the convert will otherwise use a
{       multiple of five (for a total of five characters).

    convert_ascii812_to_ascii88 (queue_file_info.c180.logical_identifier.
          a170_logical_identifier, job_submission_options_p^ [2].
          source_logical_id (1, 3), conversion_status);

    IF queue_file_info.c180.implicit_text_size <> 0 THEN
      convert_ascii812_to_ascii88 (queue_file_info.c180.implicit_routing_text,
            job_submission_options_p^ [3].implicit_routing_text^.
            text (1, queue_file_info.c180.implicit_text_size),
            conversion_status);
    IFEND;

    jmp$submit_job (local_file_info.local_file_name, job_submission_options_p,
          system_supplied_name, route_status);

  PROCEND route_file;

?? TITLE := 'RHP$QUEUE_FILE_RECEIVE_EXEC' ??
?? EJECT ??

{ RHP$QUEUE_FILE_RECEIVE_EXEC
{
{     This procedure is responsible for receiving queue files from
{ its partner application.  This includes the responsibilities of
{ protocol maintenance, reception control, and final file disposition.
{
{     RHP$QUEUE_FILE_RECEIVE_EXEC (APPLICATION_NAMES,
{               DATA_BUFFER_POINTER,EXEC_STATUS
{
{ APPLICATION_NAMES: (input) This parameter contains the sending and
{     receiving application names required for MLI communications.
{
{ DATA_BUFFER_POINTER: (input) This parameter contains the address
{     of a buffer that will be used to receive data.
{
{ EXEC_STATUS: (output) This parameter indicates to the calling procedure
{     the processing status of the executive.  The following status
{     values may be returned:
{               beginning
{               middle
{               unrecoverable_error

  PROCEDURE [XDCL] rhp$queue_file_receive_exec ALIAS 'rhmqre'
    (VAR application_names: rht$mli_application_names;
         data_buffer_pointer: rht$file_data_buffer_pointer;
     VAR exec_status: rht$exec_status);

    TYPE
      receive_states = (fetch_control, fetch_data, write_file, dispose,
            respond);

    CONST
      boi = rhc$beginning_of_information,
      completed = rhc$completed,
      delete_file = rhc$delete_file,
      eoi = rhc$end_of_information,
      err = rhc$error,
      moi = rhc$middle_of_information,
      rhc$63_character_set = 'C';

    VAR
      arbitrary_info: mlt$arbitrary_info,
      character_set_conversion_word: array [1 .. 1] of rht$c180_ascii812_word,
      character_set_type: string (5),
      conversion_info: syt$conversion_info,
      conversion_message_length: integer,
      conversion_status: rht$status,
      local_file_info: [STATIC] rht$local_file_info,
      message_length: mlt$message_length,
      msg_status: ost$status,
      open_attr: array [1 .. 5] of amt$access_selection,
      os_type: ost$170_os_type,
      purged_file: ost$name,
      quanta_work_completed: boolean,
      queue_file_info: [STATIC] rht$queue_file_info,
      receive_state: [STATIC] receive_states := fetch_control,
      receive_status: [STATIC] (ok, error) := ok,
      segment_pointer: amt$segment_pointer,
      sender_application_name: mlt$application_name,
      status: ost$status;

{ * * * * * * *   R E C E I V E   A   Q U E U E   F I L E   * * * * * * *

    quanta_work_completed := FALSE;

  /communication_loop/
    REPEAT
      CASE receive_state OF

{ Receive control information.

      = fetch_control =
        mlp$receive_message (application_names.application.application_name,
              arbitrary_info, rhv$signal, ^queue_file_info.equalizer,
              message_length, #SIZE (queue_file_info.equalizer), 0
              {Index for pending msg} , sender_application_name, status);
        IF status.normal THEN
          CASE arbitrary_info OF
          = boi =
            receive_status := ok;
            receive_state := fetch_data;
            exec_status := middle;
            pmp$get_unique_name (local_file_info.local_file_name, status);
            IF NOT status.normal THEN
              log_status (status, msg_status);
              local_file_info.local_file_name := 'rh_qre_receive_file';
            IFEND;
            open_attr [1].key := amc$open_position;
            open_attr [1].open_position := amc$open_at_boi;
            open_attr [2].key := amc$record_type;
            open_attr [2].record_type := amc$variable;
            open_attr [3].key := amc$access_mode;
            open_attr [3].access_mode := $pft$usage_selections
                  [pfc$append, pfc$shorten, pfc$modify, pfc$read];
            open_attr [4].key := amc$file_organization;
            open_attr [4].file_organization := amc$sequential;
            open_attr [5].key := amc$block_type;
            open_attr [5].block_type := amc$system_specified;
            amp$open (local_file_info.local_file_name, amc$segment, ^open_attr,
                  local_file_info.file_identifier, status);
            IF status.normal THEN
              amp$get_segment_pointer (local_file_info.file_identifier,
                    amc$sequence_pointer, segment_pointer, status);
            IFEND;
            IF NOT status.normal THEN
              log_status (status, msg_status);
              receive_state := dispose;
              receive_status := error;
            IFEND;
            conversion_info.file_pointer := segment_pointer.sequence_pointer;
            RESET conversion_info.file_pointer;
            conversion_info.save_area := 0;
            character_set_conversion_word [1].ascii812_char1 :=
                  queue_file_info.c180.form_code_char1;
            convert_ascii812_to_ascii88 (character_set_conversion_word,
                  character_set_type, conversion_status);
            IF character_set_type (1) = rhc$63_character_set THEN
              conversion_info.conversion_type := syc$63_char_ascii_to_ascii;
            ELSE
              conversion_info.conversion_type := syc$64_char_ascii_to_ascii;
            IFEND;
          = moi, eoi, err =
            quanta_work_completed := TRUE;
          ELSE
            exec_status := unrecoverable_error;
            quanta_work_completed := TRUE
          CASEND;
        ELSE
          CASE status.condition OF
          = mlc$busy_interlock, mlc$receive_list_index_invalid =
            exec_status := beginning;
          ELSE
            rhp$set_status_abnormal (status);
            log_status (status, msg_status);
            exec_status := unrecoverable_error;
          CASEND;
          quanta_work_completed := TRUE;
        IFEND;

{ Receive data from transmitter.

      = fetch_data =
        pmp$get_170_os_type (os_type, status);
        IF status.normal THEN
          IF os_type = osc$ot7_dual_state_nos_be THEN
            mlp$receive_message (application_names.application.
                  application_name, arbitrary_info, rhv$signal,
                  data_buffer_pointer, message_length,
                  #SIZE (data_buffer_pointer^), 0 {index for any pending msg} ,
                  sender_application_name, status);
          ELSE
            mlp$receive_message (application_names.application.
                  application_name, arbitrary_info, rhv$signal,
                  data_buffer_pointer, message_length,
                  #SIZE (data_buffer_pointer^) - #SIZE (integer), 0
                  {index for any pending msg} , sender_application_name,
                  status);
          IFEND;
        ELSE
          log_status (status, msg_status);
          receive_status := error;
          exec_status := unrecoverable_error;
          receive_state := dispose;
        IFEND;
        IF status.normal THEN
          CASE arbitrary_info OF
          = moi, eoi =
            receive_state := write_file;
          = err =
            receive_status := error;
            exec_status := beginning;
            receive_state := dispose;
          ELSE
            receive_status := error;
            exec_status := unrecoverable_error;
            receive_state := dispose;
          CASEND;
        ELSE
          CASE status.condition OF
          = mlc$busy_interlock, mlc$receive_list_index_invalid =
            pmp$long_term_wait (tmc$infinite_wait, 5000);
          ELSE
            rhp$set_status_abnormal (status);
            log_status (status, msg_status);
            receive_status := error;
            exec_status := unrecoverable_error;
            receive_state := dispose;
          CASEND;
        IFEND;

{ Write data to local file.

      = write_file =
        IF message_length > 0 THEN
          conversion_message_length := message_length DIV 8;
          syp$memory_link_data_conversion (^conversion_info,
                data_buffer_pointer, conversion_message_length);
        IFEND;
        IF arbitrary_info = eoi THEN
          segment_pointer.sequence_pointer := conversion_info.file_pointer;
          amp$set_segment_eoi (local_file_info.file_identifier,
                segment_pointer, status);
          IF NOT status.normal THEN
            log_status (status, msg_status);
            receive_status := error;
          IFEND;
          receive_state := dispose;
        ELSE
          receive_state := fetch_data;
        IFEND;

{ Route local file to input queue.

      = dispose =
        amp$close (local_file_info.file_identifier, status);
        IF NOT status.normal THEN
          log_status (status, msg_status);
        IFEND;
        IF receive_status = ok THEN
          route_file (receive_exec, local_file_info, queue_file_info, status);
          IF status.normal THEN
            arbitrary_info := completed;
          ELSEIF status.condition = jme$maximum_jobs THEN
            arbitrary_info := err;
          ELSE
            log_status (status, msg_status);
            arbitrary_info := delete_file;
          IFEND;
          message_length := 0;
          receive_state := respond;
        ELSE
          IF exec_status = middle THEN
            arbitrary_info := err;
            message_length := 0;
            receive_state := respond;
          ELSE
            receive_status := ok;
            receive_state := fetch_control;
            quanta_work_completed := TRUE;
          IFEND;
        IFEND;
        amp$return (local_file_info.local_file_name, status);
        IF NOT status.normal THEN
          log_status (status, msg_status);
        IFEND;

{ Tell transmitter status of processing the file.

      = respond =
        mlp$send_message (application_names.application.application_name,
              arbitrary_info, rhv$signal, data_buffer_pointer, message_length,
              application_names.destination.application_name, status);
        IF status.normal THEN
          receive_status := ok;
          receive_state := fetch_control;
          exec_status := beginning;
        ELSE
          CASE status.condition OF
          = mlc$busy_interlock, mlc$pool_buffer_not_avail =
            exec_status := middle;
            pmp$long_term_wait (1000, 1000);
          ELSE
            rhp$set_status_abnormal (status);
            log_status (status, msg_status);
            receive_status := ok;
            receive_state := fetch_control;
            exec_status := beginning;
          CASEND;
        IFEND;
        quanta_work_completed := TRUE;
      CASEND;
    UNTIL quanta_work_completed; {/communication_loop/

  PROCEND rhp$queue_file_receive_exec;

MODEND rhm$input_file_receive;
*DECK DECK=RHM$INTERFACES_TO_MLI_MACROS EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := '170 NOS/VE REMOTE HOST' ??
MODULE rhm7ml;

{ RHM7ML
{
{        This module contains all CYBIL procedures required
{ by IRHF to gain access to the MLI A170 macros.
{

?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??
?? SET (LIST := OFF) ??
?? EJECT ??

*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc OST$STATUS

?? TITLE := 'RHP$SIGN_ON_OS' ??
?? SET (LIST := ON) ??
?? EJECT ??

      PROCEDURE [XDCL {TS_gate} ] rhp$sign_on_os ALIAS 'rhpsion' (
        application_name:mlt$application_name;
        max_messages: mlt$max_messages;
        VAR unique_application_name: mlt$application_name;
        VAR status: ost$status);

        VAR condition: ost$status_condition;


          PROCEDURE [XREF {TS_gate} ] mlsinon (
            application_name:mlt$application_name;
            max_messages: mlt$max_messages;
            VAR unique_application_name: mlt$application_name;
            VAR condition: ost$status_condition);


        mlsinon(application_name,max_messages,unique_application_name,condition);
        IF condition=mlc$ok
        THEN status.normal:=TRUE;
        ELSE status.normal:=FALSE;
             status.condition:=condition;
        IFEND;

      PROCEND rhp$sign_on_os;

?? TITLE := 'RHP$SIGN_OFF_OS' ??
?? EJECT ??

      PROCEDURE [XDCL {TS_gate} ] rhp$sign_off_os ALIAS 'rhpsiof' (
        application_name: mlt$application_name;
        VAR status: ost$status);

        VAR condition: ost$status_condition;

          PROCEDURE [XREF {TS_gate}] mlsinof (
            application_name: mlt$application_name;
            VAR condition: ost$status_condition);


        mlsinof(application_name,condition);
        IF condition=mlc$ok
        THEN status.normal:=TRUE;
        ELSE status.normal:=FALSE;
             status.condition:=condition;
        IFEND;

      PROCEND rhp$sign_off_os;


?? TITLE := 'RHP$FETCH_RECEIVE_LIST_OS' ??
?? EJECT ??
  PROCEDURE [XDCL {TS_gate} ] rhp$fetch_receive_list_os ALIAS 'rhpferl'
    (application_name: mlt$application_name;
    sender_name: mlt$application_name;
    VAR receive_list: mlt$receive_list;
    VAR receive_count: mlt$receive_count;
    VAR status: ost$status);

    VAR condition: ost$status_condition;


      PROCEDURE [XREF {TS_gate} ] mlferl (
        application_name: mlt$application_name;
        sender_name: mlt$application_name;
        VAR receive_list: mlt$receive_list;
        VAR receive_count: mlt$receive_count;
        VAR condition: ost$status_condition);

    mlferl(application_name,sender_name,receive_list,receive_count,condition);
    IF condition=mlc$ok
    THEN status.normal:=TRUE;
    ELSE status.normal:=FALSE;
         status.condition:=condition;
    IFEND;

  PROCEND rhp$fetch_receive_list_os;


?? TITLE := 'RHP$RECEIVE_MESSAGE_OS' ??
?? EJECT ??

      PROCEDURE [XDCL {TS_gate} ] rhp$receive_message_os ALIAS 'rhpreme' (
        application_name: mlt$application_name;
        VAR arbitrary_info: mlt$arbitrary_info;
        signal: mlt$signal;
        message_area: mlt$message_ptr;
        VAR message_length: mlt$message_length;
        message_area_length: mlt$message_length;
        receive_index: mlt$receive_index;
        VAR sender_name: mlt$application_name;
        VAR status: ost$status);

        VAR condition: ost$status_condition;


          PROCEDURE [XREF {TS_gate} ] mlrecm (
            application_name: mlt$application_name;
            VAR arbitrary_info: mlt$arbitrary_info;
            signal: mlt$signal;
            message_area: mlt$message_ptr;
            VAR message_length: mlt$message_length;
            message_area_length: mlt$message_length;
            receive_index: mlt$receive_index;
            VAR sender_name: mlt$application_name;
            VAR condition: ost$status_condition);


        mlrecm(application_name,arbitrary_info,signal,message_area,
              message_length,message_area_length,receive_index,sender_name,condition);
        IF condition=mlc$ok
        THEN status.normal:=TRUE;
        ELSE status.normal:=FALSE;
             status.condition:=condition;
        IFEND;

      PROCEND rhp$receive_message_os;


?? TITLE := 'RHP$SEND_MESSAGE_OS' ??
?? EJECT ??

      PROCEDURE [XDCL {TS_gate} ] rhp$send_message_os ALIAS 'rhpseme' (
        application_name: mlt$application_name;
        arbitrary_info: mlt$arbitrary_info;
        signal: mlt$signal;
        message_area: mlt$message_ptr;
        message_length: mlt$message_length;
        destination_name: mlt$application_name;
        VAR status: ost$status);

        VAR condition: ost$status_condition;

          PROCEDURE [XREF {TS_gate} ] mlsendm (
            application_name: mlt$application_name;
            arbitrary_info: mlt$arbitrary_info;
            signal: mlt$signal;
            message_area: mlt$message_ptr;
            message_length: mlt$message_length;
            destination_name: mlt$application_name;
            VAR condition: ost$status_condition);


        mlsendm(application_name,arbitrary_info,signal,message_area,
               message_length,destination_name,condition);
        IF condition=mlc$ok
        THEN status.normal:=TRUE;
        ELSE status.normal:=FALSE;
             status.condition:=condition;
        IFEND;

      PROCEND rhp$send_message_os;

?? TITLE := 'RHP$CONFIRM_SEND_OS' ??
?? EJECT ??

      PROCEDURE [XDCL {TS_gate} ] rhp$confirm_send_os ALIAS 'rhpcose' (
        application_name: mlt$application_name;
        destination_name: mlt$application_name;
        VAR status: ost$status);

        VAR condition: ost$status_condition;

        PROCEDURE [XREF {TS_gate} ] mlconf (
          application_name: mlt$application_name;
          sender_name: mlt$application_name;
          VAR condition: ost$status_condition);

        mlconf(application_name,destination_name,condition);
        IF condition=mlc$ok THEN
          status.normal:=TRUE;
        ELSE
          status.normal:=FALSE;
          status.condition:=condition;
        IFEND;
      PROCEND rhp$confirm_send_os;

?? TITLE := 'RHP$ADD_SENDER_OS' ??
?? EJECT ??

      PROCEDURE [XDCL {TS_gate} ] rhp$add_sender_os ALIAS 'rhpadse' (
        application_name: mlt$application_name;
        sender_name: mlt$application_name;
        VAR status: ost$status);

        VAR condition: ost$status_condition;

          PROCEDURE [XREF {TS_gate} ] mladds (
            application_name: mlt$application_name;
            sender_name: mlt$application_name;
            VAR condition: ost$status_condition);


        mladds(application_name,sender_name,condition);
        IF condition=mlc$ok
        THEN status.normal:=TRUE;
        ELSE status.normal:=FALSE;
             status.condition:=condition;
        IFEND;

      PROCEND rhp$add_sender_os;


  MODEND rhm7ml;
*DECK DECK=RHM$LINKAGE_TO_MEMORY_LINK EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE  Remote Host :' ??
MODULE rhm$linkage_to_memory_link;

?? NEWTITLE := 'Global Type Declarations' ??
?? SET (LISTEXT := ON) ??
?? EJECT ??
*copyc rhc$condition_limits
*copyc rhd$nos_ve_types

?? TITLE := 'External Procedures Referenced By This Module' ??
?? SET (LISTEXT := ON) ??
?? EJECT ??
*copyc MLP$SIGN_ON
*copyc MLP$ADD_SENDER
*copyc MLP$SIGN_OFF
*copyc PMP$LOG
*copyc PMP$WAIT
*copyc OSP$FORMAT_MESSAGE
*copyc RHP$SET_STATUS_ABNORMAL

?? TITLE := 'mli_link' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ MLI_LINK
{
{     The purpose of this procedure is to provide all linkage
{ facilities to the MLI for all IRHF applications.  This
{ procedure allows an application to sign on and sign off
{ the MLI.  As part of the sign on facilities, the partner
{ sending application is also identified to the MLI.
{
{     MLI_LINK (DIRECTION,APPLICATION_NAMES,STATUS)
{
{ DIRECTION: (input) This parameter specifies the linkage
{     direction; i.e., sign_on or sign_off.
{
{ APPLICATION_NAMES: (input) This parameter contains the sending and
{     receiving application names required for MLI communications.
{
{ STATUS: (output) This parameter returns the success or failure of
{     the application sign on or sign off.
{

  PROCEDURE [XDCL] mli_link (direction: rht$mli_link_direction;
    VAR application_names: rht$mli_application_names;
    VAR status: ost$status);

?? TITLE := 'log_error_message' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ LOG_ERROR_MESSAGE
{
{        The purpose of this procedure is to format and log an error
{ to the job log.
{
{         LOG_ERROR_MESSAGE (MESSAGE_STATUS, STATUS)
{
{ MESSAGE_STATUS: (input) This parameter contains the status to format and
{                 write to the job log.
{
{ STATUS: (output) This parameter returns the success or failure of logging
{         the error.
{

    PROCEDURE log_error_message (message_status: ost$status;
      VAR status: ost$status);

      VAR
        message: ost$status_message,
        message_area: ^ost$status_message,
        message_line_count: ^ost$status_message_line_count,
        message_line_index: 1 .. osc$max_status_message_lines,
        message_line_size: ^ost$status_message_line_size,
        message_line: ^string (*),
        page_width: ost$status_message_line_size;


      status.normal := TRUE;
      page_width := osc$max_status_message_line;
      osp$format_message (message_status, osc$full_message_level,
        page_width, message, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      message_area := ^message;
      RESET message_area;
      NEXT message_line_count IN message_area;
      FOR message_line_index := 1 TO message_line_count^ DO
        NEXT message_line_size IN message_area;
        NEXT message_line: [message_line_size^] IN message_area;
        pmp$log (message_line^, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;

    PROCEND log_error_message;
?? TITLE := 'mli_link' ??
?? SET (LIST := ON) ??
?? EJECT ??

    VAR
      unique: mlt$application_name, { see note below }
      msg_status: ost$status;

    status.normal := TRUE;
  /mli_link_loop/
    BEGIN
      IF direction = on THEN
        REPEAT
{
{ WARNING:
{    This sign_on request assumes that the unique application name
{    generation feature of mli is not used.
{
          mlp$sign_on (application_names.application.application_name,
                rhc$max_messages, unique, status);
          IF NOT status.normal THEN
            CASE status.condition OF
            = mlc$nosve_not_up, mlc$ant_full, mlc$busy_interlock,
                  mlc$pool_buffer_not_avail =
              pmp$wait (1000, 1000);
            ELSE
              rhp$set_status_abnormal (status);
              log_error_message (status, msg_status);
              EXIT /mli_link_loop/;
            CASEND;
          IFEND;
        UNTIL status.normal;
        REPEAT
          mlp$add_sender (application_names.application.application_name,
              application_names.destination.application_name, status);
          IF NOT status.normal THEN
            IF status.condition = mlc$busy_interlock THEN
              pmp$wait (1000, 1000);
            ELSE
              rhp$set_status_abnormal (status);
              log_error_message (status, msg_status);
              EXIT /mli_link_loop/;
            IFEND;
          IFEND;
        UNTIL status.normal;
      ELSE
        REPEAT
          mlp$sign_off (application_names.application.application_name, status);
          IF NOT status.normal THEN
            CASE status.condition OF
            = mlc$nosve_not_up, mlc$queued_msgs_lost,
                  mlc$receiver_not_signed_on =
              status.normal := TRUE;
            = mlc$busy_interlock =
            ELSE
              EXIT /mli_link_loop/;
            CASEND;
            pmp$wait (1000, 1000);
          IFEND;
        UNTIL status.normal;
      IFEND;
    END /mli_link_loop/;

  PROCEND mli_link;

MODEND rhm$linkage_to_memory_link;
*DECK DECK=RHM$LINK_TO_MLI EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := '170 NOS/VE REMOTE HOST' ??
MODULE rhmmli;

?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc RHT$FUNCTION_STATUS
*copyc OST$STATUS

?? TITLE := 'EXTERNAL PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc RHP$SIGN_ON_AND_OFF_OS
*copyc RHP$ADD_SENDER_OS
*copyc RHP$LOG_STATUS
*copyc RHP$WAIT

?? TITLE := 'MLI_LINK' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ MLI_LINK
{
{     The purpose of this procedure is to provide all linkage
{ facilities to the MLI for all IRHF applications.  This
{ procedure allows an application to sign on and sign off
{ the MLI.  As part of the sign on facilities, the partner
{ sending application is also identified to the MLI.
{
{     MLI_LINK (DIRECTION,APPLICATION_NAMES)
{
{ DIRECTION: (input) This parameter specifies the linkage
{     direction; i.e., sign_on or sign_off.
{
{ APPLICATION_NAMES: (input) This parameter contains the sending and
{     receiving application names required for MLI communications.
{

  PROCEDURE [XDCL] mli_link (direction: rht$mli_link_direction;
    VAR application_names: rht$mli_application_names);

    VAR
      status: ost$status,
      waiting_for_dual_state: boolean,
      unique: mlt$application_name, { see note below }
      abnormal_mli_status_message: string (37),
      string_length: 1 .. 37;

    waiting_for_dual_state := FALSE;
    IF direction = on THEN
      REPEAT
{
{ WARNING:
{    This sign_on request assumes that the unique application name
{    generation feature of mli is not used.
{
        rhp$sign_on_os (application_names.application.application_name,
              0, unique, status);
        IF NOT status.normal THEN
          CASE status.condition OF
          = mlc$nosve_not_up =
            IF NOT waiting_for_dual_state THEN
              log_status (dayfile_log_and_display, 'waiting_for_nos/ve');
              waiting_for_dual_state := TRUE;
            IFEND;
          = mlc$ant_full, mlc$busy_interlock, mlc$pool_buffer_not_avail =
          ELSE
            abnormal_mli_status_message (1, 31) :=
              'sign on mli abnormal condition=';
            STRINGREP (abnormal_mli_status_message (32, 3), string_length,
                  status.condition);
            log_status (dayfile_log, abnormal_mli_status_message
                  (1, 31 + string_length));
          CASEND;
          wait (1000);
        IFEND;
      UNTIL status.normal;
      REPEAT
        rhp$add_sender_os (application_names.application.application_name,
              application_names.destination.application_name, status);
        IF NOT status.normal THEN
          IF status.condition <> mlc$busy_interlock THEN
            abnormal_mli_status_message (1, 34) :=
              'add sender mli abnormal condition=';
            STRINGREP (abnormal_mli_status_message (35, 3), string_length,
                  status.condition);
            log_status (dayfile_log, abnormal_mli_status_message
                  (1, 34 + string_length));
          IFEND;
          wait (1000);
        IFEND;
      UNTIL status.normal;
    ELSE
      REPEAT
        rhp$sign_off_os (application_names.application.application_name, status);
        IF NOT status.normal THEN
          CASE status.condition OF
          = mlc$nosve_not_up =
            status.normal := TRUE;
          = mlc$busy_interlock =
          = mlc$queued_msgs_lost, mlc$receiver_not_signed_on =
            status.normal := TRUE;
          ELSE
            abnormal_mli_status_message (1, 32) :=
              'sign off mli abnormal condition=';
            STRINGREP (abnormal_mli_status_message (33, 3), string_length,
                  status.condition);
            log_status (dayfile_log, abnormal_mli_status_message
                  (1, 32 + string_length));
          CASEND;
          wait (1000);
        IFEND;
      UNTIL status.normal;
    IFEND;

  PROCEND mli_link;

MODEND rhmmli;
*DECK DECK=RHM$LINK_USER_DESCRIPTOR_SAVED EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE  Remote Host :' ??
MODULE rhm$link_user_descriptor_saved;

{ PURPOSE:
{   The purpose of this module is to save a link_user_descriptor that
{   can later be used to provide information to retrieve a file from
{   the 170 side of a 180 machine running in dual state.

?? NEWTITLE := '         Global Type Declarations' ??
?? SET (LIST := OFF) ??
?? EJECT ??

*copyc OST$NAME
*copyc OST$STRING
*copyc OST$STATUS
*copyc RHT$LINK_USER_DESCRIPTOR

?? TITLE := '         External Procedures Referenced By This Module' ??
?? SET (LIST := OFF) ??
?? EJECT ??

*copyc OSV$JOB_PAGEABLE_HEAP

?? TITLE := '         rhp$link_user_descriptor_saved' ??
?? SET (LIST := ON) ??
?? EJECT ??

{     The purpose of this request is to save the last link user
{ description entered by a user.  The information is saved with
{ the user's job environment.
{
{              RHP$LINK_USER_DESCRIPTOR_SAVED (USER, FAMILY, PASSWORD,
{                CHARGE, PROJECT, STATUS)
{
{ USER: (input) This parameter specifies the NOS/170 user name
{           under which the user is validated.
{
{ FAMILY: (input) This parameter specifies the NOS/170 family under
{           which the user is validated.
{
{ PASSWORD: (input) This parameter specifies the user's NOS/170
{           password needed to gain access to NOS/170 via the
{           user name.
{
{ CHARGE: (input) This parameter specifies the user's NOS/170 charge
{           number to be charged.
{
{ PROJECT: (input) This parameter specifies the user's NOS/170 project
{           number to be charged.
{
{ STATUS: (output) This parameter specifies the request status.
{

  VAR
    rhv$link_user_current_family: [XDCL, #GATE] string(31),
    rhv$link_user_descriptor_p: [XDCL, #GATE] ^rht$link_user_descriptor := NIL;

  PROCEDURE [XDCL, #GATE] rhp$link_user_descriptor_saved (user: string (31);
        family: string (31);
        password: string (31);
        charge: string (31);
        project: string (31);
    VAR status: ost$status);

    VAR
      lud: rht$link_user_descriptor,
      lud_pp: ^^rht$link_user_descriptor;

{ Save the current link_user_family.

    rhv$link_user_current_family := family;

{ If a link_user_descriptor for the family name given is already in the
{ link_user_descriptor chain then update the descriptor entry with
{ with the new parameters.

    lud_pp := ^rhv$link_user_descriptor_p;
    WHILE (lud_pp^ <> NIL) DO
      IF lud_pp^^.family = family THEN
        lud_pp^^.user := user;
        lud_pp^^.password := password;
        lud_pp^^.charge := charge;
        lud_pp^^.project := project;
        RETURN;
      IFEND;
      lud_pp := ^lud_pp^^.next_lud_p;
    WHILEND;

{ Initialize the link user descriptor.

    lud.next_lud_p := NIL;
    lud.user := user;
    lud.family := family;
    lud.password := password;
    lud.charge := charge;
    lud.project := project;

{ Obtain space for a new link_user_descriptor and fill in
{ the required information.

    ALLOCATE lud_pp^ IN osv$job_pageable_heap^;

    lud_pp^^ := lud;

  PROCEND rhp$link_user_descriptor_saved;

MODEND rhm$link_user_descriptor_saved;
*DECK DECK=RHM$LOG_STATUS EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := '170 NOS/VE REMOTE HOST' ??
MODULE rhmlgm;

?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc RHT$FUNCTION_STATUS

?? TITLE := 'EXTERNAL PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc ZUTPS2D
*copyc ZN7PMSG

    PROCEDURE [XREF] getword (address: integer;
        word: ^cell);


?? TITLE := 'LOG_STATUS' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ LOG_STATUS
{
{      The purpose of this procedure is to send a message to the
{ NOS/A170 B display and/or the user dayfile.
{
{      LOG_STATUS (DESTINATION,STATUS_MESSAGE)
{
{ DESTINATION: (input) This parameter specifies the destination of
{              the message, i.e. the console display and job dayfile
{              or job dayfile only.
{
{ STATUS_MESSAGE: (input) This parameter specifies the ascii message
{                 to be logged.
{

  PROCEDURE [XDCL] log_status (destination: rht$log_destinations;
    status_message: rht$log_status_message);

    CONST
      job_log = 3,
      system_and_job_log = 0;

    VAR
      display_code_message: array [1 .. 8] of packed array [0 .. 9] of 0 .. 3f(16),
      dc_string_word_index: integer,
      dc_string_char_index: 0 .. 9,
      source_index: ost$string_index,
      ra_word_0: packed record
        fill1: 0 .. 0ffffffffff(16),
        fill2: 0 .. 01f(16),
        cfo,
        idledown,
        pause,
        sw6,
        sw5,
        sw4,
        sw3,
        sw2,
        sw1: boolean,
        fill3: 0 .. 03f(16),
      recend,
      rh_debug: boolean,
      eol: boolean;

{  Set rh debug if switch 1 is on.

    getword (0, #LOC(ra_word_0));
    rh_debug := ra_word_0.sw2;
    IF (rh_debug = FALSE) AND (destination = dayfile_log_and_display) THEN
      RETURN;
    IFEND;

    source_index := 1;
    REPEAT
      dc_string_word_index := 1;
      dc_string_char_index := 0;
      eol := TRUE;
      utp$convert_string_to_dc_string (utc$ascii64, display_code_message, dc_string_word_index,
        dc_string_char_index, status_message, source_index, eol);
      IF destination = display_in_system_log THEN
        n7p$issue_dayfile_message (#LOC (display_code_message), system_and_job_log);
      ELSE
        n7p$issue_dayfile_message (#LOC (display_code_message), job_log);
      IFEND;
    UNTIL source_index > STRLENGTH (status_message);

  PROCEND log_status;

MODEND rhmlgm;
*DECK DECK=RHM$MAP_PFM_CODE_TO_RH_CODE EXPAND=TRUE

*copyc osd$default_pragmats
  MODULE rhm$map_pfm_code_to_rh_code ALIAS 'rhmpmc';

{ Select target 170 operating system.
*IF ($string($name(wev$target_operating_system))='NOS')

  ?VAR rhv$nos_be: boolean := FALSE ?;
*ELSE

  ?VAR rhv$nos_be: boolean := TRUE ?;
*IFEND

*copyc ZN7PPFM
*copyc RHC$NOSBE_PF_ERROR_CODES
*copyc RHC$CONSTANTS
*copyc RHC$CONDITION_LIMITS
?? SET (LIST:=ON) ??

{ MAP_PFM_CODE_TO_RH_CODE
{
{         The purpose of this procedure is to provide a mapping from the
{ given 170 permanent file manager error code to a remote host error code.
{
{         MAP_PFM_CODE_TO_RH_CODE (PFM_CODE,RH_CODE)
{
{ PFM_CODE: (input) This parameter contains the pfm error code which is
{           to be mapped into the remote host error code.
{
{ RH_CODE: (output) This parameter contains the remote host error code
{          which is the result of the mapping.
{

  PROCEDURE[XDCL] map_pfm_code_to_rh_code (
    pfm_code: 0..0ff(16);
    VAR rh_code: INTEGER);

? IF rhv$nos_be = FALSE THEN
    CASE pfm_code OF
    =n7c$pfm_ok= rh_code:=rhc$ok;
    =n7c$pfm_file_busy= rh_code:=rhe$cycle_busy;
    =n7c$pfm_file_not_found= rh_code:=rhe$missing_file;
    =n7c$pfm_file_too_long= rh_code:=rhe$permanent_file_too_large;
    =n7c$pfm_data_transfer_error,
     n7c$pfm_sys_mass_storage_error..n7c$pfm_sys_data_permit_error,
     n7c$pfm_sys_staging_error= rh_code:=rhe$file_io_error;
    =n7c$pfm_catalog_overflow_files= rh_code:=rhe$too_many_permanent_files;
    =n7c$pfm_catalog_overflow_size= rh_code:=rhe$too_much_pf_storage;
    =n7c$pfm_prus_not_available,
     n7c$pfm_sys_track_limit= rh_code:=rhe$mass_storage_unavailable;
    ELSE rh_code:=rhe$file_error;
    CASEND;
? ELSE
    CASE pfm_code OF
      = n7c$fdb_ok =
        rh_code := rhc$ok;
      = n7c$fdb_id_error =
        rh_code := rhe$id_error;
      = n7c$fdb_unknown_lfn =
        rh_code := rhe$unknown_lfn;
      = n7c$fdb_pfc_full =
        rh_code := rhe$pfc_full;
      = n7c$fdb_file_not_cataloged =
      rh_code := rhe$file_not_cataloged;
      = n7c$fdb_cycle_number_over_999 =
      rh_code := rhe$cycle_number_over_999;
      = n7c$fdb_pfd_full =
      rh_code := rhe$pfd_full;
      = n7c$fdb_cycle_incomplete =
      rh_code := rhe$cycle_incomplete;
      = n7c$fdb_file_archived =
      rh_code := rhe$file_archived;
      = n7c$fdb_ill_char_in_fdb_param =
       rh_code := rhe$ill_char_in_fdb_param;
      = n7c$fdb_file_dumped =
      rh_code := rhe$file_dumped;
      = n7c$fdb_no_apf_space =
      rh_code := rhe$no_apf_space;
      = n7c$fdb_permission_conflicts =
      rh_code := rhe$permission_conflicts;
      = n7c$fdb_rbt_chain_too_large =
      rh_code := rhe$rbt_chain_too_large;
      = n7c$fdb_unavailable_device =
      rh_code := rhe$unavailable_device;
      = n7c$fdb_file_not_available =
      rh_code := rhe$file_not_available;
      = n7c$fdb_pfm_stopped_by_system =
      rh_code := rhe$pfm_stopped_by_system;
      = n7c$fdb_incorrect_permission =
      rh_code := rhe$incorrect_permission;
    ELSE
      rh_code := rhe$io_error;
    CASEND;
 ? IFEND

  PROCEND map_pfm_code_to_rh_code;

  MODEND rhm$map_pfm_code_to_rh_code;
*DECK DECK=RHM$OPEN_FILE EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := '170 NOS/VE REMOTE HOST' ??
MODULE rhmopn;

?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc RHT$FUNCTION_STATUS

?? TITLE := 'EXTERNAL PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc ZN7PCIO

?? TITLE := 'RHP$OPEN_FILE' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ RHP$OPEN_FILE
{
{     The purpose of this procedure is to open the local file identified by local_file_info.
{
{     RHP$OPEN_FILE (LOCAL_FILE_INFO)
{
{ LOCAL_FILE_INFO: (input) This parameter specifies all information
{     required for local file identification and access.
{
{

  PROCEDURE [XDCL] rhp$open_file ALIAS 'rhmopn' (VAR local_file_info: rht$local_file_info);

    TYPE
      fet_pointer_rec = record
        case pointer_val_type: (constant, pointer) of
        = constant =
          constant: integer,
        = pointer =
          pointer: ^cell,
        casend,
      recend;

    VAR
      fet_pointer: fet_pointer_rec;

    fet_pointer.constant := 0;
    local_file_info.fet.first := fet_pointer.pointer;
    local_file_info.fet.next_in := fet_pointer.pointer;
    local_file_info.fet.next_out := fet_pointer.pointer;
    fet_pointer.constant := 1;
    local_file_info.fet.limit := fet_pointer.pointer;
    local_file_info.fet.completed := TRUE;
    n7p$cio (local_file_info.fet, - n7c$cio_rewind);

  PROCEND rhp$open_file;

MODEND rhmopn;
*DECK DECK=RHM$OUTPUT_FILE_EXEC_PGM EXPAND=TRUE
?? RIGHT := 110 ??
*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE REMOTE HOST' ??
{
{ REMOTE_HOST_OUTPUT_FILE_EXEC_PGM
{
{     The purpose of this module is to initialize, invoke, and
{ monitor the process which sends output queue files from C180
{ to A170.  As part of the initialization, the process is
{ signed on to the MLI (see MLI_LINK).
{     If a fatal error is detected during processing,
{ REMOTE_HOST_OUTPUT_FILE_EXEC_PGM will sign off the process
{ from the MLI and "shut itself down completely".
{

MODULE rhm$output_file_exec_pgm;

?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc osc$remote_host_output
*copyc OST$STATUS
*copyc RHC$CONSTANTS
*copyc TMC$WAIT_TIMES
*copyc rhd$nos_ve_types
?? TITLE := 'PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc RHP$MLI_LINK
*copyc CLP$PUT_JOB_OUTPUT
*copyc jmp$register_output_application
*copyc PMP$LOG
*copyc PMP$LONG_TERM_WAIT
*copyc RHP$QUEUE_FILE_TRANSMIT_EXEC
?? SET (LIST := ON) ??
?? TITLE := 'REMOTE_HOST_OUTPUT_FILE_EXEC_PGM' ??
?? EJECT ??

  PROCEDURE [XDCL] rhp$output;

    VAR
      application_names: [STATIC] rht$mli_application_names := [[c180_id, [0, rhc$send_output_to_remote, 0]],
        [c180_id, [0, rhc$receive_remote_output, 0]]],
      data_buffer: rht$file_data_buffer,
      data_buffer_pointer: rht$file_data_buffer_pointer,
      files_processed: boolean,
      queue_file_password: jmt$queue_file_password,
      status: ost$status;

    data_buffer_pointer := ^data_buffer;
    mli_link (on, application_names, status);
    IF status.normal THEN

        jmp$register_output_application (osc$remote_host_output, jmc$dual_state_usage, queue_file_password,
               status);
        IF status.normal THEN
          REPEAT
            rhp$queue_file_transmit_exec (queue_file_password, application_names, data_buffer_pointer,
                files_processed);
            IF NOT files_processed THEN
              pmp$long_term_wait (tmc$infinite_wait, 5000);
            IFEND;
          UNTIL FALSE;
        IFEND;
    IFEND;
    mli_link (off, application_names, status);

  PROCEND rhp$output;

MODEND rhm$output_file_exec_pgm;



*DECK DECK=RHM$OUTPUT_FILE_TRANSMIT EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE  Remote Host :' ??
MODULE rhm$output_file_transmit;

?? NEWTITLE := 'Global Type Declarations' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc rhd$nos_ve_types
*copyc jme$queued_file_conditions
*copyc CLH$CONVERT_STRING_TO_INTEGER
*copyc ost$user_identification
*copyc TMC$WAIT_TIMES
*copyc RHC$CONDITION_LIMITS

?? TITLE := 'External Procedures Referenced By This Module' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc AMP$GET_SEGMENT_POINTER
*copyc AMP$SET_SEGMENT_EOI
*copyc AMP$SET_SEGMENT_POSITION
*copyc AMP$OPEN
*copyc AMP$CLOSE
*copyc AMP$PUT_NEXT
*copyc AMP$RETURN
*copyc clp$trimmed_string_size
*copyc MLP$SEND_MESSAGE
*copyc MLP$RECEIVE_MESSAGE
*copyc RHV$SIGNAL
*copyc OSP$FORMAT_MESSAGE
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$LONG_TERM_WAIT
*copyc PMP$WAIT
*copyc jmp$set_output_completed
*copyc jmp$acquire_modified_output
*copyc jmp$acquire_new_output
*copyc jmp$close_output_file
*copyc jmp$modified_output_exists
*copyc jmp$new_output_exists
*copyc jmp$open_output_file
*copyc jmp$terminated_output_exists
*copyc jmp$set_output_initiated
*copyc jmp$terminate_acquired_output
*copyc SYP$MEMORY_LINK_DATA_CONVERSION
*copyc PMP$FORMAT_COMPACT_DATE
*copyc PMP$FORMAT_COMPACT_TIME
*copyc PMP$GET_DATE
*copyc PMP$GET_TIME
*copyc PMP$LOG
*copyc PMP$ESTABLISH_CONDITION_HANDLER
*copyc pmp$disestablish_cond_handler
*copyc PMP$CONTINUE_TO_CAUSE
*copyc RHP$SET_STATUS_ABNORMAL

?? TITLE := 'Variables Used By This Module' ??
?? SET (LIST := ON) ??
?? EJECT ??

  VAR
    local_file_acquired: boolean,
    banner_file_open: boolean;

?? TITLE := '[XDCL] rhp$queue_file_transmit_exec' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ RHP$QUEUE_FILE_TRANSMIT_EXEC
{
{     This procedure is responsible for the acquisition and subsequent
{ transfer of a queued file to its receiving partner application.  This
{ transfer includes the responsibilities of performing protocol
{ maintenance, file transmission control, and final file disposition.
{
{     RHP$QUEUE_FILE_TRANSMIT_EXEC (QUEUE_FILE_PASSWORD, APPLICATION_NAMES,
{              DATA_BUFFER_POINTER, EXEC_STATUS
{
{ QUEUE_FILE_PASSWORD: (input) This is the password assigned by queued files
{        that is required in order to open a file in the output queue.
{
{ APPLICATION_NAMES: (input) This parameter contains the sending and
{     receiving application names required for MLI communication.
{
{ DATA_BUFFER_POINTER: (input) This parameter contains the address
{     of a buffer that will be used to transmit data from.
{
{ FILES_PROCESSED: (output) This parameter indicates to the calling
{     procedure if their were files to be processed.
{

  PROCEDURE [XDCL] rhp$queue_file_transmit_exec ALIAS 'rhmqat'
    (    queue_file_password: jmt$queue_file_password;
     VAR application_names: rht$mli_application_names;
         data_buffer_pointer: rht$file_data_buffer_pointer;
     VAR files_processed: boolean);

?? EJECT ??

    PROCEDURE handle_termination
      (    cond: pmt$condition;
           cd: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR ch_status: ost$status);

      VAR
        term_file_status: ost$status;

      IF break_active THEN
        RETURN;
      IFEND;
      break_active := TRUE;

{ Close banner file.

      IF banner_file_open THEN
        amp$close (banner_file_info.file_identifier, term_file_status);
      IFEND;
      amp$return (banner_file_info.local_file_name, term_file_status);

{ Close and return the queue file.

      IF output_file_open THEN
        jmp$close_output_file (output_file_id, term_file_status);
      IFEND;

      IF local_file_acquired THEN
        transmit_complete := FALSE;
        jmp$set_output_completed (jmc$dual_state_usage, system_file_name,
              transmit_complete, status);
      IFEND;

{ Terminate IRHF 170 processing by sending EOI.

      message_info.message_length := 0;
      message_info.arbitrary_info := eoi;

    /send_eoi/
      REPEAT
        mlp$send_message (application_names.application.application_name,
              message_info.arbitrary_info, rhv$signal,
              message_info.message_area, message_info.message_length,
              application_names.destination.application_name, status);
        IF NOT status.normal THEN
          CASE status.condition OF
          = mlc$busy_interlock, mlc$pool_buffer_not_avail =
            pmp$wait (1000, 1000);
          ELSE
            rhp$set_status_abnormal (status);
            log_status (status, msg_status);
            EXIT /send_eoi/;
          CASEND;
        IFEND;
      UNTIL status.normal; { send_eoi }

    PROCEND handle_termination;

?? EJECT ??
{ Begin RHP$QUEUE_FILE_TRANSMIT_EXEC

    CONST
      boi = rhc$beginning_of_information,
      eoi = rhc$end_of_information,
      buffer_size_in_words = (mlc$max_message_length DIV (64 * 8)) * 64,
      completed = rhc$completed,
      err = rhc$error;

    VAR
      msg_status: ost$status,
      status: ost$status,
      output_file_id: amt$file_identifier,
      output_file_open: boolean,
      system_file_name: jmt$system_supplied_name,
      output_descriptor: jmt$output_descriptor,
      sender_application_name: mlt$application_name,
      transmit_complete: boolean,
      banner_file_eoi: boolean,
      banner_file_info: rht$local_file_info,
      queue_file_info: [XDCL] rht$queue_file_info,
      cond_desc: [STATIC, READ] pmt$condition :=
            [pmc$condition_combination, $pmt$condition_combination
            [pmc$block_exit_processing]],
      estab_handler: pmt$established_handler,
      local_status: ost$status,
      break_active: boolean,
      conversion_message_length: integer,
      priority_msg_not_received_count: 0 .. 20,
      segment_pointer: amt$segment_pointer,
      conversion_info: syt$conversion_info,
      message_info: [STATIC] rht$mli_message_info := [ * , 0, * , * ];

{ * * * * * * *   T R A N S M I T   A    Q U E U E   F I L E   * * * * * * *

{ Initialize.

    break_active := FALSE;
    banner_file_open := FALSE;
    local_file_acquired := FALSE;
    output_file_open := FALSE;
    queue_file_info.machine_type := c180;

    pmp$establish_condition_handler (cond_desc, ^handle_termination,
          ^estab_handler, local_status);

{ Set files_processed to TRUE - if no output exists then set it to FALSE
{ in order to wait for more.

    files_processed := TRUE;

{ Acquire a file in the output queue ready for transmission to NOS/170.

  /output_file_transmit/
    BEGIN

      WHILE jmp$terminated_output_exists (jmc$dual_state_usage) DO
        jmp$terminate_acquired_output (jmc$dual_state_usage, system_file_name,
              status);
        IF NOT status.normal THEN
          log_status (status, msg_status);
          status.normal := TRUE;
          EXIT /output_file_transmit/;
        IFEND;
      WHILEND;

      IF jmp$modified_output_exists (jmc$dual_state_usage) THEN
        jmp$acquire_modified_output (jmc$dual_state_usage, output_descriptor,
              status);
      ELSEIF jmp$new_output_exists (jmc$dual_state_usage) THEN
        jmp$acquire_new_output (jmc$dual_state_usage, output_descriptor,
              status);
      ELSE
        files_processed := FALSE;
        EXIT /output_file_transmit/;
      IFEND;
      IF NOT status.normal THEN
        IF status.condition = jme$output_queue_is_empty THEN
          status.normal := TRUE;
        ELSE
          log_status (status, msg_status);
        IFEND;
        EXIT /output_file_transmit/;
      IFEND;
      system_file_name := output_descriptor.system_file_name;
      IF output_descriptor.remote_host_directive.size <> 0 THEN
        output_descriptor.remote_host_directive.size := clp$trimmed_string_size (
        output_descriptor.remote_host_directive.parameters (1, output_descriptor.remote_host_directive.size));
      IFEND;

      local_file_acquired := TRUE;
      jmp$set_output_initiated (jmc$dual_state_usage, system_file_name,
            status);
      IF NOT status.normal THEN
        log_status (status, msg_status);
        transmit_complete := FALSE;
        jmp$set_output_completed (jmc$dual_state_usage, system_file_name,
              transmit_complete, status);
        IF NOT status.normal THEN
          log_status (status, msg_status);
        IFEND;
        local_file_acquired := FALSE;
        EXIT /output_file_transmit/;
      IFEND;

{ Check to see if routing job wants no output sent.
{ IF it does, then delete the file from the output queue.

      IF output_descriptor.implicit_routing_text.text (44, 7) = 'DC = NO' THEN
        transmit_complete := TRUE;
        jmp$set_output_completed (jmc$dual_state_usage, system_file_name,
              transmit_complete, status);
        IF NOT status.normal THEN
          log_status (status, msg_status);
        IFEND;
        local_file_acquired := FALSE;
        EXIT /output_file_transmit/;
      IFEND;

{ Save information required by the nos/170 route to send the file to its
{destination.

      save_170_queue_file_info (output_descriptor, queue_file_info);

{ Transmit file information to nos.

      message_info.message_area := ^queue_file_info.equalizer;
      message_info.message_length := #SIZE (queue_file_info.equalizer);
      message_info.arbitrary_info := boi;

    /send_file_info/
      REPEAT
        mlp$send_message (application_names.application.application_name,
              message_info.arbitrary_info, rhv$signal,
              message_info.message_area, message_info.message_length,
              application_names.destination.application_name, status);
        IF NOT status.normal THEN
          CASE status.condition OF
          = mlc$busy_interlock, mlc$pool_buffer_not_avail,
                mlc$prior_msg_not_received, mlc$receiver_not_signed_on =
            pmp$long_term_wait (tmc$infinite_wait, 5000);
          ELSE
            rhp$set_status_abnormal (status);
            log_status (status, msg_status);
            transmit_complete := FALSE;
            jmp$set_output_completed (jmc$dual_state_usage, system_file_name,
                  transmit_complete, status);
            IF NOT status.normal THEN
              log_status (status, msg_status);
            IFEND;
            local_file_acquired := FALSE;
            EXIT /output_file_transmit/;
          CASEND;
        IFEND;
      UNTIL status.normal; {send_file_info}

{ Generate banner for nos/ve output file.

      banner_file_info.local_file_name := 'rh_temp_banner_file';
      banner_file_eoi := FALSE;
      generate_banner (banner_file_info, output_descriptor, status);

{ Transmit the banner to nos/170.
{     If error occurs, continue on and transmit the output file.

    /transmit_banner/
      BEGIN

        open_file (banner_file_info, amc$variable, status);
        IF status.normal THEN
          banner_file_open := TRUE;
          amp$get_segment_pointer (banner_file_info.file_identifier,
                amc$sequence_pointer, segment_pointer, status);
          IF NOT status.normal THEN
            log_status (status, msg_status);
            amp$close (banner_file_info.file_identifier, status);
            banner_file_open := FALSE;
            amp$return (banner_file_info.local_file_name, status);
            EXIT /transmit_banner/;
          IFEND;
        ELSE
          log_status (status, msg_status);
          amp$return (banner_file_info.local_file_name, status);
          EXIT /transmit_banner/;
        IFEND;

        conversion_info.file_pointer := segment_pointer.sequence_pointer;
        RESET conversion_info.file_pointer;
        conversion_info.save_area := 0;
        conversion_info.conversion_type := syc$ascii_to_8_in_12;
        message_info.arbitrary_info := rhc$middle_of_information;

      /transmit_banner_data/
        REPEAT
          conversion_message_length := buffer_size_in_words;
          syp$memory_link_data_conversion (^conversion_info,
                data_buffer_pointer, conversion_message_length);
          IF conversion_message_length <> buffer_size_in_words THEN
            banner_file_eoi := TRUE;
            segment_pointer.sequence_pointer := conversion_info.file_pointer;
            amp$set_segment_position (banner_file_info.file_identifier,
                  segment_pointer, status);
            IF NOT status.normal THEN
              log_status (status, msg_status);
              EXIT /transmit_banner_data/;
            IFEND;
          IFEND;

          message_info.message_area := data_buffer_pointer;
          message_info.message_length := conversion_message_length * 8;

        /send_banner_data/
          REPEAT
            mlp$send_message (application_names.application.application_name,
                  message_info.arbitrary_info, rhv$signal,
                  message_info.message_area, message_info.message_length,
                  application_names.destination.application_name, status);
            IF status.normal THEN
              IF banner_file_eoi THEN
                EXIT /transmit_banner_data/;
              IFEND;
            ELSE
              CASE status.condition OF
              = mlc$busy_interlock, mlc$pool_buffer_not_avail,
                    mlc$prior_msg_not_received, mlc$receiver_not_signed_on =
                pmp$long_term_wait (tmc$infinite_wait, 5000);
              ELSE
                rhp$set_status_abnormal (status);
                log_status (status, msg_status);
                EXIT /transmit_banner_data/;
              CASEND;
            IFEND;
          UNTIL status.normal; {send_banner_data}

        UNTIL FALSE; {transmit_banner_data}

        amp$close (banner_file_info.file_identifier, status);
        banner_file_open := FALSE;
        IF NOT status.normal THEN
          log_status (status, msg_status);
        IFEND;
        amp$return (banner_file_info.local_file_name, status);

      END /transmit_banner/;

{ Transmit the output queue file.

      status.normal := TRUE;
      message_info.arbitrary_info := rhc$middle_of_information;
      output_file_open := TRUE;
      jmp$open_output_file (system_file_name, amc$segment,
            jmc$dual_state_usage, queue_file_password, output_file_id, status);
      IF status.normal THEN
        amp$get_segment_pointer (output_file_id, amc$sequence_pointer,
              segment_pointer, status);
        IF NOT status.normal THEN
          IF status.condition = ame$read_of_empty_segment THEN
            message_info.arbitrary_info := eoi;
            message_info.message_length := 0;
          ELSE
            log_status (status, msg_status);
            message_info.arbitrary_info := err;
          IFEND;
        IFEND;
      ELSE
        log_status (status, msg_status);
        message_info.arbitrary_info := err;
      IFEND;

      IF NOT status.normal THEN {Send a status to the 170}
        jmp$close_output_file (output_file_id, status);
        output_file_open := FALSE;
        IF NOT status.normal THEN
          log_status (status, msg_status);
        IFEND;
        transmit_complete := (message_info.arbitrary_info = eoi) OR
              (message_info.arbitrary_info = err);
        jmp$set_output_completed (jmc$dual_state_usage, system_file_name,
              transmit_complete, status);
        local_file_acquired := FALSE;
        IF NOT status.normal THEN
          log_status (status, msg_status);
        IFEND;

      /send_file_status/
        REPEAT
          mlp$send_message (application_names.application.application_name,
                message_info.arbitrary_info, rhv$signal,
                message_info.message_area, message_info.message_length,
                application_names.destination.application_name, status);
          IF NOT status.normal THEN
            CASE status.condition OF
            = mlc$busy_interlock, mlc$pool_buffer_not_avail,
                  mlc$prior_msg_not_received, mlc$receiver_not_signed_on =
              pmp$long_term_wait (tmc$infinite_wait, 5000);
            ELSE
              rhp$set_status_abnormal (status);
              log_status (status, msg_status);
              EXIT /send_file_status/;
            CASEND;
          IFEND;
        UNTIL status.normal; {send_file_status}
        EXIT /output_file_transmit/;
      IFEND;

      conversion_info.file_pointer := segment_pointer.sequence_pointer;
      RESET conversion_info.file_pointer;
      conversion_info.save_area := 0;
      conversion_info.conversion_type := syc$ascii_t_records_to_812;
      message_info.arbitrary_info := rhc$middle_of_information;
      priority_msg_not_received_count := 0;

    /transmit_output_data/
      REPEAT
        status.normal := TRUE;

{ Get converted data from queue file

        conversion_message_length := buffer_size_in_words;
        syp$memory_link_data_conversion (^conversion_info, data_buffer_pointer,
              conversion_message_length);
        IF conversion_message_length <> buffer_size_in_words THEN
          message_info.arbitrary_info := eoi;
          segment_pointer.sequence_pointer := conversion_info.file_pointer;
          amp$set_segment_position (output_file_id, segment_pointer, status);
          IF NOT status.normal THEN
            log_status (status, msg_status);
          IFEND;
        IFEND;

        message_info.message_area := data_buffer_pointer;
        message_info.message_length := conversion_message_length * 8;

      /send_output_data/
        REPEAT
          mlp$send_message (application_names.application.application_name,
                message_info.arbitrary_info, rhv$signal,
                message_info.message_area, message_info.message_length,
                application_names.destination.application_name, status);
          IF status.normal THEN
            IF message_info.arbitrary_info = eoi THEN
              EXIT /transmit_output_data/;
            IFEND;
            priority_msg_not_received_count := 0;
          ELSE
            CASE status.condition OF
            = mlc$busy_interlock, mlc$pool_buffer_not_avail,
                  mlc$receiver_not_signed_on =
              pmp$long_term_wait (tmc$infinite_wait, 5000);
          = mlc$prior_msg_not_received =

{ IF a prior message is not received after approximately 100 seconds,
{ then stop sending the output file and terminate it.

              IF priority_msg_not_received_count < 20 THEN
                priority_msg_not_received_count := priority_msg_not_received_count + 1;
                pmp$long_term_wait (tmc$infinite_wait, 5000);
              ELSE
                EXIT /transmit_output_data/;
              IFEND;
            ELSE
              rhp$set_status_abnormal (status);
              log_status (status, msg_status);
              jmp$close_output_file (output_file_id, status);
              output_file_open := FALSE;
              IF NOT status.normal THEN
                log_status (status, msg_status);
              IFEND;
              transmit_complete := FALSE;
              jmp$set_output_completed (jmc$dual_state_usage, system_file_name,
                    transmit_complete, status);
              local_file_acquired := FALSE;
              IF NOT status.normal THEN
                log_status (status, msg_status);
              IFEND;
              EXIT /output_file_transmit/;
            CASEND;
          IFEND;
        UNTIL status.normal; {send_output_data}

      UNTIL FALSE; {transmit_output_data}

{ Check if data was routed to nos's output queue okay.

    /get_route_status/
      REPEAT

        { Check 170 status

        mlp$receive_message (application_names.application.application_name,
              message_info.arbitrary_info, rhv$signal,
              message_info.message_area, message_info.message_length,
              message_info.message_area_length, 0 {index for pending msg} ,
              sender_application_name, status);
        IF status.normal THEN
          IF NOT (message_info.arbitrary_info = completed) THEN
            osp$set_status_abnormal (rhc$remote_host_id,
                  rhe$unable_to_route_file, system_file_name, status);
            log_status (status, msg_status);
            osp$set_status_abnormal (rhc$remote_host_id,
                  rhe$unable_to_complete_transfer,
                  output_descriptor.login_user, status);
            log_status (status, msg_status);
            EXIT /get_route_status/;
          IFEND;
        ELSE
          CASE status.condition OF
          = mlc$busy_interlock, mlc$receive_list_index_invalid =
            pmp$long_term_wait (tmc$infinite_wait, 5000);
          ELSE
            rhp$set_status_abnormal (status);
            log_status (status, msg_status);
            EXIT /get_route_status/;
          CASEND;
        IFEND;
      UNTIL status.normal; {get_route_status}

{ Release the queue file.

      jmp$close_output_file (output_file_id, status);
      output_file_open := FALSE;
      IF NOT status.normal THEN
        log_status (status, msg_status);
      IFEND;
      transmit_complete := TRUE;
      jmp$set_output_completed (jmc$dual_state_usage, system_file_name,
            transmit_complete, status);
      local_file_acquired := FALSE;
      IF NOT status.normal THEN
        log_status (status, msg_status);
      IFEND;

    END /output_file_transmit/;

    pmp$disestablish_cond_handler (cond_desc, local_status);

  PROCEND rhp$queue_file_transmit_exec;

?? TITLE := 'save_170_queue_file_info' ??
?? SET (LIST := ON) ??
?? EJECT ??

  PROCEDURE save_170_queue_file_info
    (    output_descriptor: jmt$output_descriptor;
     VAR queue_file_info: rht$queue_file_info);

    VAR
      forms_code: jmt$forms_code,
      conversion_status: rht$status;

    convert_ascii88_to_ascii812 (output_descriptor.system_file_name,
          queue_file_info.c180.file_name.c180_file_name, conversion_status);

    forms_code := output_descriptor.forms_code;
    IF forms_code = 'NORMAL' THEN
      forms_code := '';
    IFEND;

    queue_file_info.c180.form_code_char1.ascii88_char := forms_code (1);
    queue_file_info.c180.form_code_char2.ascii88_char := forms_code (2);

    queue_file_info.c180.repeat_count := output_descriptor.copies;
    convert_ascii88_to_ascii812 (output_descriptor.login_user,
          queue_file_info.c180.user_number_of_owner.c180_owner_user_num,
          conversion_status);
    convert_ascii88_to_ascii812 (output_descriptor.login_family,
          queue_file_info.c180.family_name_of_creator.c180_creator_family_name,
          conversion_status);
    convert_ascii88_to_ascii812 (output_descriptor.login_account,
          queue_file_info.c180.user_charge_number, conversion_status);
    convert_ascii88_to_ascii812 (output_descriptor.login_project,
          queue_file_info.c180.user_project_number, conversion_status);

    convert_ascii88_to_ascii812 (output_descriptor.source_logical_id,
          queue_file_info.c180.logical_identifier.c180_logical_identifier,
          conversion_status);
    convert_ascii88_to_ascii812 (output_descriptor.implicit_routing_text.text,
          queue_file_info.c180.implicit_routing_text, conversion_status);
    queue_file_info.c180.implicit_text_size :=
          output_descriptor.implicit_routing_text.size;
    queue_file_info.c180.dual_state_routing_text_size :=
          output_descriptor.remote_host_directive.size;
    IF output_descriptor.remote_host_directive.size <> 0 THEN
      convert_ascii88_to_ascii812 (output_descriptor.dual_state_user,
            queue_file_info.c180.user_number_of_owner.c180_owner_user_num,
            conversion_status);
      convert_ascii88_to_ascii812 (output_descriptor.dual_state_family_name,
            queue_file_info.c180.family_name_of_creator.
            c180_creator_family_name, conversion_status);
      convert_ascii88_to_ascii812 (output_descriptor.dual_state_password,
            queue_file_info.c180.user_password, conversion_status);

{ If the RHD parameter is used on the PRIF command, then save the dual state
{ account and project numbers in queue file info rather than the login project
{ and account numbers.

      convert_ascii88_to_ascii812 (output_descriptor.dual_state_account,
            queue_file_info.c180.user_charge_number, conversion_status);
      convert_ascii88_to_ascii812 (output_descriptor.dual_state_project,
            queue_file_info.c180.user_project_number, conversion_status);
      convert_ascii88_to_ascii812 (output_descriptor.remote_host_directive.
            parameters, queue_file_info.c180.dual_state_routing_text,
            conversion_status);

{ The original login USER, FAMILY, PROJECT, and ACCOUNT must be saved if
{ the user specified the DSRP parameter on the PRIF command.

      convert_ascii88_to_ascii812 (output_descriptor.login_user,
            queue_file_info.c180.original_user_name.c180_original_user_name,
            conversion_status);
      convert_ascii88_to_ascii812 (output_descriptor.login_family,
            queue_file_info.c180.original_family_name.
            c180_original_family_name, conversion_status);
      convert_ascii88_to_ascii812 (output_descriptor.login_account,
            queue_file_info.c180.original_charge_number, conversion_status);
      convert_ascii88_to_ascii812 (output_descriptor.login_project,
            queue_file_info.c180.original_project_number, conversion_status);
    IFEND;

  PROCEND save_170_queue_file_info;
?? TITLE := 'log_status' ??
?? SET (LIST := ON) ??
?? EJECT ??
{ LOG_STATUS
{
{        The purpose of this procedure is to format and log an error
{ to the job log.
{
{         LOG_STATUS (MESSAGE_STATUS, STATUS)
{
{ MESSAGE_STATUS: (input) This parameter contains the status to format and
{                 write to the job log.
{
{ STATUS: (output) This parameter returns the success or failure of logging
{         the error.
{

  PROCEDURE log_status
    (    message_status: ost$status;
     VAR status: ost$status);

    VAR
      message: ost$status_message,
      message_area: ^ost$status_message,
      message_line_count: ^ost$status_message_line_count,
      message_line_index: 1 .. osc$max_status_message_lines,
      message_line_size: ^ost$status_message_line_size,
      message_line: ^string ( * ),
      page_width: ost$status_message_line_size;


    status.normal := TRUE;
    page_width := osc$max_status_message_line;
    osp$format_message (message_status, osc$full_message_level, page_width,
          message, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    message_area := ^message;
    RESET message_area;
    NEXT message_line_count IN message_area;
    FOR message_line_index := 1 TO message_line_count^ DO
      NEXT message_line_size IN message_area;
      NEXT message_line: [message_line_size^] IN message_area;
      pmp$log (message_line^, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND log_status;
?? TITLE := 'open_file' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ OPEN_FILE
{
{     The purpose of this procedure is to open the local file identified
{ by local_file_info for read only.
{
{     OPEN_FILE (LOCAL_FILE_INFO, STATUS)
{
{ LOCAL_FILE_INFO: (input) This parameter specifies all information
{     required for local file identification and access.
{
{ STATUS: (output) This parameter returns the status of the open.
{

  PROCEDURE open_file
    (VAR local_file_info: rht$local_file_info;
         record_type: amt$record_type;
     VAR status: ost$status);

    VAR
      open_attr: array [1 .. 1] of amt$access_selection;

{ Set attributes to open a file for read only.

    open_attr [1].key := amc$access_mode;
    open_attr [1].access_mode := $pft$usage_selections [pfc$read];

{ Open the file.

    amp$open (local_file_info.local_file_name, amc$segment, ^open_attr,
          local_file_info.file_identifier, status);

  PROCEND open_file;

?? TITLE := 'CONVERT_ASCII88_TO_ASCII812' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ CONVERT_ASCII88_TO_ASCII812
{
{       The purpose of this procedure is to convert an 8/8 ascii string to
{ an A170 8/12 ascii string.
{
{        CONVERT_ASCII88_TO_ASCII812 (ASCII88_STRING,
{              ASCII812_STRING, CONVERSION_STATUS)
{
{ ASCII88_STRING: (input) This parameter contains the 8/8 ascii string which
{                 is to be converted.
{
{ ASCII812_STRING: (output) This parameter contains the 8/12 ascii string which
{                  is the result of the conversion.
{
{ CONVERSION_STATUS: (output) This parameter indicates the success or failure
{                    of the conversion.  If the output string is not large
{                    enough to complete the conversion of the entire input
{                    string then a status of non_fatal_error will be returned
{                    otherwise the conversion will be successful.  In either
{                    case, conversion of as much of the string as is possible
{                    will be performed.
{
{

  PROCEDURE convert_ascii88_to_ascii812
    (    ascii88_string: string ( * );
     VAR ascii812_string: array [ * ] of rht$c180_ascii812_word;
     VAR conversion_status: rht$status);

    VAR
      ascii88_string_length: 0 .. 256,
      ascii812_string_lbound: integer,
      ascii812_string_ubound: integer,
      words_required: integer,
      last_word_index: integer,
      chars_in_last_word: 1 .. 5,
      word_index: integer,
      ascii88_char_index: 0 .. 256,
      ascii812_char_index: 2 .. 5;

    ascii88_string_length := STRLENGTH (ascii88_string);
    ascii812_string_lbound := LOWERBOUND (ascii812_string);
    ascii812_string_ubound := UPPERBOUND (ascii812_string);
    words_required := (ascii88_string_length + 4) DIV 5;
    IF (ascii812_string_ubound - ascii812_string_lbound + 1) <
          words_required THEN
      last_word_index := ascii812_string_ubound;
      chars_in_last_word := 5;
      conversion_status := non_fatal_error;
    ELSE
      last_word_index := ascii812_string_lbound + words_required - 1;
      chars_in_last_word := ascii88_string_length - (words_required - 1) * 5;
      conversion_status := successful;
    IFEND;
    ascii88_char_index := 0;
    FOR word_index := ascii812_string_lbound TO last_word_index - 1 DO
      ascii88_char_index := ascii88_char_index + 1;
      ascii812_string [word_index].ascii812_char1.filler := 0;
      ascii812_string [word_index].ascii812_char1.ascii88_char :=
            ascii88_string (ascii88_char_index);
      FOR ascii812_char_index := 2 TO 5 DO
        ascii88_char_index := ascii88_char_index + 1;
        ascii812_string [word_index].ascii812_char2_5 [ascii812_char_index].
              filler := 0;
        ascii812_string [word_index].ascii812_char2_5 [ascii812_char_index].
              ascii88_char := ascii88_string (ascii88_char_index);
      FOREND;
    FOREND;
    ascii88_char_index := ascii88_char_index + 1;
    ascii812_string [last_word_index].ascii812_char1.filler := 0;
    ascii812_string [last_word_index].ascii812_char1.ascii88_char :=
          ascii88_string (ascii88_char_index);
    FOR ascii812_char_index := 2 TO chars_in_last_word DO
      ascii88_char_index := ascii88_char_index + 1;
      ascii812_string [last_word_index].ascii812_char2_5 [ascii812_char_index].
            filler := 0;
      ascii812_string [last_word_index].ascii812_char2_5 [ascii812_char_index].
            ascii88_char := ascii88_string (ascii88_char_index);
    FOREND;

  PROCEND convert_ascii88_to_ascii812;

?? TITLE := 'generate_banner' ??
?? SET (LIST := ON) ??
?? EJECT ??
{ GENERATE_BANNER
{
{     This procedure generates a banner page for all output files
{ being sent to NOS/170 for printing.
{
{      GENERATE_BANNER (OUTPUT_DESCRIPTOR, BANNER_FILE_INFO)
{
{ BANNER_FILE_INFO: (input, output) This parameter specifies all information
{     required to create the banner file.
{
{ OUTPUT_DESCRIPTOR: (input) This parameter contains the values of the job
{     output attributes for a file to be printed.
{
{ STATUS: (output) This parameter returns the status of the request.
{

  PROCEDURE generate_banner
    (VAR banner_file_info: rht$local_file_info;
         output_descriptor: jmt$output_descriptor;
     VAR status: ost$status);

    CONST
      long_line_length = 96,
      line_length = 20;

    VAR
      date: ost$date,
      date_to_print: string (31),
      output_line: string (long_line_length),
      time: ost$time,
      time_to_print: string (31),
      index: 1 .. 20,
      space_lines_count: 1 .. 7,
      eject: [STATIC, READ] string (20) := '1                    ',
      double_space: [STATIC, READ] string (20) := '0                   ',
      bottom_of_page: [STATIC, READ] string (20) := '2                   ',
      open_attr: array [1 .. 5] of amt$access_selection,
      byte_address: amt$file_byte_address,
      msg_status: ost$status;

{ Open the file which will contain the banner.

    open_attr [1].key := amc$open_position;
    open_attr [1].open_position := amc$open_at_boi;
    open_attr [2].key := amc$record_type;
    open_attr [2].record_type := amc$variable;
    open_attr [3].key := amc$access_mode;
    open_attr [3].access_mode := $pft$usage_selections
          [pfc$append, pfc$shorten, pfc$modify, pfc$read];
    open_attr [4].key := amc$file_organization;
    open_attr [4].file_organization := amc$sequential;
    open_attr [5].key := amc$block_type;
    open_attr [5].block_type := amc$system_specified;
    amp$open (banner_file_info.local_file_name, amc$record, ^open_attr,
          banner_file_info.file_identifier, status);
    IF NOT status.normal THEN
      log_status (status, msg_status);
      RETURN;
    IFEND;
    banner_file_open := TRUE;

{ Start at top of page.

    amp$put_next (banner_file_info.file_identifier, ^eject, line_length,
          byte_address, status);
    IF status.normal THEN
      amp$put_next (banner_file_info.file_identifier, ^double_space,
            line_length, byte_address, status);
      amp$put_next (banner_file_info.file_identifier, ^double_space,
            line_length, byte_address, status);
      amp$put_next (banner_file_info.file_identifier, ^double_space,
            line_length, byte_address, status);
    IFEND;
    IF NOT status.normal THEN
      log_status (status, msg_status);
    IFEND;

{ Get the current date and time.

    pmp$get_date (osc$mdy_date, date, status);
    IF NOT status.normal THEN
      log_status (status, msg_status);
    IFEND;

    pmp$get_time (osc$hms_time, time, status);
    IF NOT status.normal THEN
      log_status (status, msg_status);
    IFEND;

    output_line := ' ';
    output_line (15, 18) := 'PRINTED         = ';
    output_line (33, 8) := date.mdy;
    output_line (42, 8) := time.hms;
    amp$put_next (banner_file_info.file_identifier, ^output_line,
          long_line_length, byte_address, status);
    IF NOT status.normal THEN
      log_status (status, msg_status);
    IFEND;

{ Get the time the file was submitted to be printed.

    pmp$format_compact_date (output_descriptor.output_submission_time,
          osc$mdy_date, date, status);
    IF NOT status.normal THEN
      log_status (status, msg_status);
    IFEND;
    pmp$format_compact_time (output_descriptor.output_submission_time,
          osc$hms_time, time, status);
    IF NOT status.normal THEN
      log_status (status, msg_status);
    IFEND;

    output_line := ' ';
    output_line (15, 18) := 'CREATED         = ';
    output_line (33, 8) := date.mdy;
    output_line (42, 8) := time.hms;
    amp$put_next (banner_file_info.file_identifier, ^output_line,
          long_line_length, byte_address, status);
    IF NOT status.normal THEN
      log_status (status, msg_status);
    IFEND;
    output_line := ' ';
    output_line (15, 18) := 'FAMILY          = ';
    output_line (33, * ) := output_descriptor.control_family;
    amp$put_next (banner_file_info.file_identifier, ^output_line,
          long_line_length, byte_address, status);
    IF NOT status.normal THEN
      log_status (status, msg_status);
    IFEND;
    output_line := ' ';
    output_line (15, 18) := 'USER NAME       = ';
    output_line (33, * ) := output_descriptor.control_user;
    amp$put_next (banner_file_info.file_identifier, ^output_line,
          long_line_length, byte_address, status);
    IF NOT status.normal THEN
      log_status (status, msg_status);
    IFEND;
    output_line := ' ';
    output_line (15, 18) := 'USER JOB NAME   = ';
    output_line (33, * ) := output_descriptor.user_job_name;
    amp$put_next (banner_file_info.file_identifier, ^output_line,
          long_line_length, byte_address, status);
    IF NOT status.normal THEN
      log_status (status, msg_status);
    IFEND;
    output_line := ' ';
    output_line (15, 18) := 'SYSTEM JOB NAME = ';
    output_line (33, * ) := output_descriptor.system_job_name;
    amp$put_next (banner_file_info.file_identifier, ^output_line,
          long_line_length, byte_address, status);
    IF NOT status.normal THEN
      log_status (status, msg_status);
    IFEND;
    output_line := ' ';
    output_line (15, 18) := 'FILE NAME       = ';
    output_line (33, * ) := output_descriptor.user_file_name;
    amp$put_next (banner_file_info.file_identifier, ^output_line,
          long_line_length, byte_address, status);
    IF NOT status.normal THEN
      log_status (status, msg_status);
    IFEND;
    output_line := ' ';
    output_line (15, * ) := output_descriptor.comment_banner;
    amp$put_next (banner_file_info.file_identifier, ^output_line,
          long_line_length, byte_address, status);
    IF NOT status.normal THEN
      log_status (status, msg_status);
    IFEND;
    output_line := ' ';
    output_line (15, * ) := output_descriptor.site_information;
    amp$put_next (banner_file_info.file_identifier, ^output_line,
          long_line_length, byte_address, status);
    IF NOT status.normal THEN
      log_status (status, msg_status);
    IFEND;
    amp$put_next (banner_file_info.file_identifier, ^double_space, line_length,
          byte_address, status);
    amp$put_next (banner_file_info.file_identifier, ^double_space, line_length,
          byte_address, status);
    IF NOT status.normal THEN
      log_status (status, msg_status);
    IFEND;

    form_a_large_letter_row (banner_file_info,
          output_descriptor.routing_banner, status);

    amp$put_next (banner_file_info.file_identifier, ^bottom_of_page,
          line_length, byte_address, status);
    IF NOT status.normal THEN
      log_status (status, msg_status);
    IFEND;

{ Close the banner file.

    amp$close (banner_file_info.file_identifier, status);
    banner_file_open := FALSE;
    IF NOT status.normal THEN
      log_status (status, msg_status);
    IFEND;
    status.normal := TRUE;

  PROCEND generate_banner;

?? TITLE := 'form_a_large_letter_row' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ FORM_A_LARGE_LETTER_ROW
{
{      This procedure will generate 10 large characters if called
{  10 times with row increased by 1 each time.
{
{      FORM_A_LARGE_LETTER_ROW (BANNER_FILE_INFO, INPUT_STRING STATUS)
{
{  BANNER_FILE_INFO : (input output) This parameter specifies all information
{     required to create the banner file.
{
{  INPUT_STRING : (input) This parameter specifies the character
{     string to make large letters from.
{
{  STATUS: (output) This parameter returns the status of the request.
{

  PROCEDURE form_a_large_letter_row
    (VAR banner_file_info: rht$local_file_info;
         input_string: string (31);
     VAR status: ost$status);

    CONST
      banner_line_length = 132,
      line_length = 20,
      max_character_images = 68,
      max_char_across_page = 10,
      numbers_position = 27,
      special_chars_position = 37,
      number_of_special_chars = 32,
      number_of_rows = 10,
      number_of_columns = 10;

    TYPE
      char_image_table_type = array [1 .. max_character_images] of array
            [1 .. number_of_rows] of string (number_of_columns),
      lowercase_to_uppercase = array ['a' .. 'z'] of 'A' .. 'Z',
      number_types = array [1 .. 10] of '0' .. '9',
      special_character_types = array [1 .. number_of_special_chars] of ' ' ..
            '~';

    VAR
      index: 1 .. 10,
      int: integer,
      msg_status: ost$status,
      row: 1 .. 10,
      line: string (132),
      byte_address: amt$file_byte_address,
      sp_index: 1 .. 32,
      character: char,
      char_image_table_index: integer,
      double_space: [STATIC, READ] string (20) := '0                   ',
      string_position_index: integer,
      new_char_string: string (10),
      uppercase: [STATIC, READ] lowercase_to_uppercase := ['A', 'B', 'C', 'D',
            'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q',
            'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'],
      special_character: [STATIC, READ] special_character_types := ['+', '-',
            '*', '/', '\', '(', ')', '$', '#', '=', ' ', ',', '.', '_', '!',
            '{', '}', '|', '[', ']', ':', '%', '<', '>', ';', '"', '&', '?',
            '`', '@', '^', '~'],
      table_index_array: [STATIC] array [1 .. max_char_across_page] of integer,
      char_image_table: [STATIC, READ] char_image_table_type := [

?? SET (LIST := OFF) ??
?? FMT (FORMAT := OFF) ??

{                   a_letter: 001
    [' AAAAAAAA ',
     'AAAAAAAAAA',
     'AA      AA',
     'AA      AA',
     'AA      AA',
     'AAAAAAAAAA',
     'AAAAAAAAAA',
     'AA      AA',
     'AA      AA',
     'AA      AA'],
{                   b_letter: 002
    ['BBBBBBBBB ',
     'BBBBBBBBBB',
     'BB      BB',
     'BB      BB',
     'BBBBBBBBB ',
     'BBBBBBBBB ',
     'BB      BB',
     'BB      BB',
     'BBBBBBBBBB',
     'BBBBBBBBB '],
{                   c_letter: 003
    [' CCCCCCCC ',
     'CCCCCCCCCC',
     'CC       C',
     'CC        ',
     'CC        ',
     'CC        ',
     'CC        ',
     'CC       C',
     'CCCCCCCCCC',
     ' CCCCCCCC '],
{                   d_letter: 004
    ['DDDDDDDDD ',
     'DDDDDDDDDD',
     'DD      DD',
     'DD      DD',
     'DD      DD',
     'DD      DD',
     'DD      DD',
     'DD      DD',
     'DDDDDDDDDD',
     'DDDDDDDDD '],
{                   e_letter: 005
    ['EEEEEEEEEE',
     'EEEEEEEEEE',
     'EE        ',
     'EE        ',
     'EEEEEE    ',
     'EEEEEE    ',
     'EE        ',
     'EE        ',
     'EEEEEEEEEE',
     'EEEEEEEEEE'],
{                   f_letter: 006
    ['FFFFFFFFFF',
     'FFFFFFFFFF',
     'FF        ',
     'FF        ',
     'FFFFFF    ',
     'FFFFFF    ',
     'FF        ',
     'FF        ',
     'FF        ',
     'FF        '],
{                   g_letter: 007
    [' GGGGGGGG ',
     'GGGGGGGGGG',
     'GG        ',
     'GG        ',
     'GG   GGGGG',
     'GG   GGGGG',
     'GG      GG',
     'GG      GG',
     'GGGGGGGGGG',
     ' GGGGGGGGG'],
{                   h_letter: 008
    ['HH      HH',
     'HH      HH',
     'HH      HH',
     'HH      HH',
     'HHHHHHHHHH',
     'HHHHHHHHHH',
     'HH      HH',
     'HH      HH',
     'HH      HH',
     'HH      HH'],
{                   i_letter: 009
    ['IIIIIIIIII',
     'IIIIIIIIII',
     '    II    ',
     '    II    ',
     '    II    ',
     '    II    ',
     '    II    ',
     '    II    ',
     'IIIIIIIIII',
     'IIIIIIIIII'],
{                   j_letter: 010
    ['  JJJJJJJJ',
     '  JJJJJJJJ',
     '     JJ   ',
     '     JJ   ',
     '     JJ   ',
     '     JJ   ',
     'JJ   JJ   ',
     'JJ   JJ   ',
     'JJJJJJJ   ',
     ' JJJJJ    '],
{                   k_letter: 011
    ['KK      KK',
     'KK     KK ',
     'KK   KK   ',
     'KK KK     ',
     'KKKKK     ',
     'KK  KK    ',
     'KK   KK   ',
     'KK    KK  ',
     'KK     KK ',
     'KK      KK'],
{                   l_letter: 012
    ['LL        ',
     'LL        ',
     'LL        ',
     'LL        ',
     'LL        ',
     'LL        ',
     'LL        ',
     'LL        ',
     'LLLLLLLLLL',
     'LLLLLLLLLL'],
{                   m_letter: 013
    ['MM      MM',
     'MMMM  MMMM',
     'MM MMMM MM',
     'MM  MM  MM',
     'MM  MM  MM',
     'MM      MM',
     'MM      MM',
     'MM      MM',
     'MM      MM',
     'MM      MM'],
{                   n_letter: 014
    ['NN      NN',
     'NNN     NN',
     'NN N    NN',
     'NN NN   NN',
     'NN  NN  NN',
     'NN  NN  NN',
     'NN   NN NN',
     'NN    N NN',
     'NN     NNN',
     'NN      NN'],
{                   o_letter: 015
    [' OOOOOOOO ',
     'OOOOOOOOOO',
     'OO      OO',
     'OO      OO',
     'OO      OO',
     'OO      OO',
     'OO      OO',
     'OO      OO',
     'OOOOOOOOOO',
     ' OOOOOOOO '],
{                   p_letter: 016
    ['PPPPPPPPP ',
     'PPPPPPPPPP',
     'PP      PP',
     'PP      PP',
     'PPPPPPPPPP',
     'PPPPPPPPP ',
     'PP        ',
     'PP        ',
     'PP        ',
     'PP        '],
{                   q_letter: 017
    [' QQQQQQQQ ',
     'QQQQQQQQQQ',
     'QQ      QQ',
     'QQ      QQ',
     'QQ      QQ',
     'QQ      QQ',
     'QQ  QQQ QQ',
     'QQ    QQQQ',
     'QQQQQQQQQ ',
     ' QQQQQQ QQ'],
{                   r_letter: 018
    ['RRRRRRRRR ',
     'RRRRRRRRRR',
     'RR      RR',
     'RR      RR',
     'RRRRRRRRRR',
     'RRRRRRRRR ',
     'RR   RR   ',
     'RR    RR  ',
     'RR     RR ',
     'RR      RR'],
{                   s_letter: 019
    [' SSSSSSSS ',
     'SSSSSSSSSS',
     'SS       S',
     'SS        ',
     'SSSSSSSSS ',
     ' SSSSSSSSS',
     '        SS',
     'S       SS',
     'SSSSSSSSSS',
     ' SSSSSSSS '],
{                   t_letter: 020
    ['TTTTTTTTTT',
     'TTTTTTTTTT',
     '    TT    ',
     '    TT    ',
     '    TT    ',
     '    TT    ',
     '    TT    ',
     '    TT    ',
     '    TT    ',
     '    TT    '],
{                   u_letter: 021
    ['UU      UU',
     'UU      UU',
     'UU      UU',
     'UU      UU',
     'UU      UU',
     'UU      UU',
     'UU      UU',
     'UU      UU',
     'UUUUUUUUUU',
     ' UUUUUUUU '],
{                   v_letter: 022
    ['VV      VV',
     'VV      VV',
     ' VV    VV ',
     ' VV    VV ',
     ' VV    VV ',
     ' VV    VV ',
     '  VV  VV  ',
     '  VV  VV  ',
     '   VVVV   ',
     '    VV    '],
{                   w_letter: 023
    ['WW      WW',
     'WW      WW',
     'WW      WW',
     'WW      WW',
     'WW  WW  WW',
     'WW  WW  WW',
     'WW  WW  WW',
     'WW WWWW WW',
     ' WWW  WWW ',
     ' WW    WW '],
{                   x_letter: 024
    ['XX      XX',
     ' XX    XX ',
     '  XX  XX  ',
     '   XXXX   ',
     '    XX    ',
     '   XXXX   ',
     '  XX  XX  ',
     ' XX    XX ',
     'XX      XX',
     'XX      XX'],
{                   y_letter: 025
    ['YY      YY',
     ' YY    YY ',
     '  YY  YY  ',
     '   YYYY   ',
     '    YY    ',
     '    YY    ',
     '    YY    ',
     '    YY    ',
     '    YY    ',
     '    YY    '],
{                   z_letter: 026
    ['ZZZZZZZZZZ',
     'ZZZZZZZZZ ',
     '      ZZ  ',
     '     ZZ   ',
     '    ZZ    ',
     '    ZZ    ',
     '   ZZ     ',
     '  ZZ      ',
     ' ZZZZZZZZZ',
     'ZZZZZZZZZZ'],
{                   zero: 027
    ['   0000   ',
     '  000000  ',
     ' 00    00 ',
     '00      00',
     '00      00',
     '00      00',
     '00      00',
     ' 00    00 ',
     '  000000  ',
     '   0000   '],
{                   one: 028
    ['    11    ',
     '  1111    ',
     '  1 11    ',
     '    11    ',
     '    11    ',
     '    11    ',
     '    11    ',
     '    11    ',
     '1111111111',
     '1111111111'],
{                   two: 029
    [' 22222222 ',
     '2222222222',
     '2       22',
     '        22',
     '       22 ',
     '     22   ',
     '   22     ',
     ' 22       ',
     '2222222222',
     '2222222222'],
{                   three: 030
    ['3333333333',
     '333333333 ',
     '      33  ',
     '     33   ',
     '    333   ',
     '      333 ',
     '       33 ',
     '3       33',
     '333333333 ',
     ' 3333333  '],
{                   four: 031
    ['     444  ',
     '    4444  ',
     '   44 44  ',
     '  44  44  ',
     ' 44   44  ',
     '4444444444',
     '4444444444',
     '      44  ',
     '      44  ',
     '      44  '],
{                   five: 032
    ['5555555555',
     '5555555555',
     '55        ',
     '55        ',
     '555555555 ',
     '5555555555',
     '        55',
     '5       55',
     '5555555555',
     ' 55555555 '],
{                   six: 033
    [' 66666666 ',
     '6666666666',
     '66       6',
     '66        ',
     '666666666 ',
     '6666666666',
     '66      66',
     '66      66',
     '6666666666',
     ' 66666666 '],
{                   seven: 034
    ['7777777777',
     '7777777777',
     '       77 ',
     '     77   ',
     '   77     ',
     '  77      ',
     ' 77       ',
     ' 77       ',
     '77        ',
     '77        '],
{                   eight: 035
    [' 88888888 ',
     '8888888888',
     '88      88',
     '88      88',
     ' 88888888 ',
     ' 88888888 ',
     '88      88',
     '88      88',
     '8888888888',
     ' 88888888 '],
{                   nine: 036
    [' 99999999 ',
     '9999999999',
     '99      99',
     '99      99',
     '9999999999',
     ' 999999999',
     '        99',
     '9       99',
     '9999999999',
     ' $$$$$$$$ '],
{                   plus: 037
    ['          ',
     '          ',
     '   ++++   ',
     '   ++++   ',
     '++++++++++',
     '++++++++++',
     '   ++++   ',
     '   ++++   ',
     '          ',
     '          '],
{                   minus: 038
    ['          ',
     '          ',
     '          ',
     '          ',
     ' -------- ',
     ' -------- ',
     '          ',
     '          ',
     '          ',
     '          '],
{                   asterisk: 039
    ['          ',
     '          ',
     '          ',
     '  *    *  ',
     '   *  *   ',
     '* ****** *',
     '   *  *   ',
     '  *    *  ',
     '          ',
     '          '],
{                   slash: 040
    ['         /',
     '        //',
     '       // ',
     '      //  ',
     '     //   ',
     '    //    ',
     '   //     ',
     '  //      ',
     ' //       ',
     '/         '],
{                   reverse_slash: 041
    ['\         ',
     '\\        ',
     ' \\       ',
     '  \\      ',
     '   \\     ',
     '    \\    ',
     '     \\   ',
     '      \\  ',
     '       \\ ',
     '         \'],
{                   left_paren: 042
    ['       (  ',
     '     ((   ',
     '    ((    ',
     '   ((     ',
     '   ((     ',
     '   ((     ',
     '   ((     ',
     '    ((    ',
     '     ((   ',
     '       (  '],
{                   right_paren: 043
    ['  ))       ',
     '   ))     ',
     '    ))    ',
     '     ))   ',
     '     ))   ',
     '     ))   ',
     '     ))   ',
     '    ))    ',
     '   ))     ',
     '  )       '],
{                   dollar_sign: 044
    ['    $$    ',
     ' $$$$$$$$ ',
     '$$$$$$$$$$',
     '$$  $$    ',
     '$$$$$$$$$ ',
     ' $$$$$$$$$',
     '    $$  $$',
     '$$$$$$$$$$',
     ' $$$$$$$$ ',
     '    $$    '],
{                   number_sign: 045
    ['          ',
     '   ##  ## ',
     '   #   #  ',
     ' #########',
     '  ##  ##  ',
     '  #   #   ',
     '######### ',
     ' ##  ##   ',
     ' #   #    ',
     '          '],
{                   equals: 046
    ['          ',
     '          ',
     '          ',
     '==========',
     '==========',
     '          ',
     '==========',
     '==========',
     '          ',
     '          '],
{                   blank: 047
    ['          ',
     '          ',
     '          ',
     '          ',
     '          ',
     '          ',
     '          ',
     '          ',
     '          ',
     '          '],
{                   comma: 048
    ['          ',
     '          ',
     '          ',
     '          ',
     '          ',
     '   ,,,    ',
     '  ,,,,,   ',
     '   ,,,,   ',
     '     ,    ',
     '    ,     '],
{                   period: 049
    ['          ',
     '          ',
     '          ',
     '          ',
     '          ',
     '          ',
     '          ',
     '   ....   ',
     '  ......  ',
     '   ....   '],
{                   underline: 050
    ['          ',
     '          ',
     '          ',
     '          ',
     '          ',
     '          ',
     '          ',
     '          ',
     '__________',
     '__________'],
{                   exclamation: 051
    ['    !!    ',
     '    !!    ',
     '    !!    ',
     '    !!    ',
     '    !!    ',
     '    !!    ',
     '    !!    ',
     '          ',
     '    !!    ',
     '    !!    '],
{                   left_brace: 052
    ['   {{{{{{ ',
     '  {{      ',
     '  {{      ',
     '   {{     ',
     '{{{       ',
     '{{{       ',
     '   {{     ',
     '  {{      ',
     '  {{      ',
     '   {{{{{{ '],
{                   right_brace: 053
   [' }}}}}}   ',
    '      }}  ',
    '      }}  ',
    '     }}   ',
    '       }}}',
    '       }}}',
    '     }}   ',
    '      }}  ',
    '      }}  ',
    ' }}}}}}   '],
{                   vertical_line: 054
    ['    ||    ',
     '    ||    ',
     '    ||    ',
     '    ||    ',
     '    ||    ',
     '    ||    ',
     '    ||    ',
     '    ||    ',
     '    ||    ',
     '    ||    '],
{                   left_bracket: 055
    ['   [[[[[  ',
     '   [[     ',
     '   [[     ',
     '   [[     ',
     '   [[     ',
     '   [[     ',
     '   [[     ',
     '   [[     ',
     '   [[     ',
     '   [[[[[  '],
{                   right_bracket: 056
    ['  ]]]]]   ',
     '     ]]   ',
     '     ]]   ',
     '     ]]   ',
     '     ]]   ',
     '     ]]   ',
     '     ]]   ',
     '     ]]   ',
     '     ]]   ',
     '  ]]]]]   '],
{                   colon: 057
    ['          ',
     '          ',
     '   ::::   ',
     '  ::::::  ',
     '   ::::   ',
     '          ',
     '   ::::   ',
     '  ::::::  ',
     '   ::::   ',
     '          '],
{                   percent: 058
    ['%%%%    %%',
     '%  %   %% ',
     '%%%%  %%  ',
     '     %%   ',
     '    %%    ',
     '   %%     ',
     '  %%      ',
     ' %%   %%%%',
     '%%    %  %',
     '%     %%%%'],
{                   less_than: 059
    ['          ',
     '          ',
     '       << ',
     '     <<   ',
     '   <<     ',
     ' <<       ',
     '   <<     ',
     '     <<   ',
     '       << ',
     '          '],
{                   greater_than: 060
    ['          ',
     '          ',
     ' >>       ',
     '   >>     ',
     '     >>   ',
     '       >> ',
     '     >>   ',
     '   >>     ',
     ' >>       ',
     '          '],
{                   semi_colon: 061
    ['          ',
     '   ;;;    ',
     '  ;;;;;   ',
     '   ;;;    ',
     '          ',
     '   ;;;    ',
     '  ;;;;;   ',
     '   ;;;;   ',
     '     ;    ',
     '    ;     '],
{                   quotes: 062
    ['  "    "  ',
     ' """  """ ',
     '  ""   "" ',
     '  "    "  ',
     '          ',
     '          ',
     '          ',
     '          ',
     '          ',
     '          '],
{                   ampersand: 063
     ['   &&&    ',
      ' &&   &&  ',
      '&&     && ',
      '&&     && ',
      ' &&   &&  ',
      '   &&&    ',
      ' && &&    ',
      '&&   && &&',
      '&&    &&  ',
      '  &&&& && '],
{                   question_mark: 064
     ['   ????   ',
      ' ??    ?? ',
      ' ??    ?? ',
      '      ??  ',
      '     ??   ',
      '    ??    ',
      '    ??    ',
      '          ',
      '    ??    ',
      '    ??    '],
{                   accent: 065
     ['  ``      ',
      '   ``     ',
      '    ``    ',
      '          ',
      '          ',
      '          ',
      '          ',
      '          ',
      '          ',
      '          '],
{                    at_sign: 066
     ['  @@@@@@  ',
      ' @@@@@@@@ ',
      '@@      @@',
      '@       @@',
      ' @@@@@  @@',
      '@@@@@@@ @@',
      '@@   @@ @@',
      '@@   @@ @@',
      ' @@@@@@@@@',
      '  @@@@ @@ '],
{                   circumflex: 067
     ['    ^     ',
      '   ^^^    ',
      '  ^^ ^^   ',
      '^^     ^^ ',
      '          ',
      '          ',
      '          ',
      '          ',
      '          ',
      '          '],
{                   tilde: 068
     ['  ~~     ',
      ' ~~~~    ~',
      '~~  ~~  ~~',
      '~    ~~~~ ',
      '      ~~  ',
      '          ',
      '          ',
      '          ',
      '          ',
      '          ']
?? FMT (FORMAT := ON) ??
?? SET (LIST := ON) ??
      ];

    string_position_index := 1;
    WHILE string_position_index < 30 DO

{ Generate an index list into the char_image_table on the first pass.

      new_char_string := input_string (string_position_index, 10);

    /generate_index_table/
      FOR index := 1 TO max_char_across_page DO
        character := new_char_string (index);

{ Check if character  is a special function and convert to a blank.

        IF character < ' ' THEN
          character := ' ';
        IFEND;

        CASE character OF
        = 'A' .. 'Z', 'a' .. 'z' =
          IF (character >= 'a') AND (character <= 'z') THEN
            character := uppercase [character];
          IFEND;
          int := $INTEGER (character) - 64; { 64=40(16)

        = '0' .. '9' =
          int := $INTEGER (character) - 48 + numbers_position; { 48=30(16)

        ELSE

        /check_if_special_char/
          FOR sp_index := 1 TO number_of_special_chars DO
            IF character = special_character [sp_index] THEN
              EXIT /check_if_special_char/;
            IFEND;
          FOREND /check_if_special_char/;
          int := sp_index + special_chars_position - 1;
        CASEND;

{ Save the index to the char_image_table.

        table_index_array [index] := int;
      FOREND /generate_index_table/;

{ generate large letters.

      FOR row := 1 TO 10 DO
        FOR index := 1 TO 4 DO { Blank receiving line.
          line ((index * 33) - 32, 33) := '                                 ';
        FOREND;

        FOR index := 1 TO max_char_across_page DO
          char_image_table_index := table_index_array [index];
          line (13 * index - 10, 10) := char_image_table [
                char_image_table_index] [row];
        FOREND;
        amp$put_next (banner_file_info.file_identifier, ^line,
              banner_line_length, byte_address, status);
      FOREND;
      amp$put_next (banner_file_info.file_identifier, ^double_space,
            line_length, byte_address, status);
      string_position_index := string_position_index + 10;
    WHILEND;

  PROCEND form_a_large_letter_row;

MODEND rhm$output_file_transmit;
*DECK DECK=RHM$PARTNER_JOB_EXEC EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := '170 NOS/VE REMOTE HOST ' ??
MODULE rhm$partner_job_exec ALIAS 'rhmjep';

{ Select target 170 operating system.
*IF ($string($name(wev$target_operating_system))='NOS')

  ?VAR rhv$nos_be: boolean := FALSE ?;
*ELSE

  ?VAR rhv$nos_be: boolean := TRUE ?;
*IFEND

?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??
?? SET (LIST := ON) ??
*copyc ifd$machine_definition

  ?IF ifv$module_for_c180 = TRUE THEN
*copy OST$STATUS
  ?ELSE
*copy OST$STRING

    TYPE
      ost$status = record
        condition: mlt$status,
      recend,

      ost$status_condition = record
        condition: mlt$status,
      recend;

  ?IFEND
?? EJECT ??
*copyc RHT$FUNCTION_STATUS
*copyc RHC$CONSTANTS
*copyc RHC$CONDITION_LIMITS

?? TITLE := 'EXTERNAL PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc MLP$RECEIVE_MESSAGE
*copyc RHP$LOG_STATUS
*copyc RHP$ROUTE_FILE
 PROCEDURE [XREF] pause (i: integer);
*copyc MLP$SEND_MESSAGE
*copyc MLP$SIGN_ON
*copyc MLP$ADD_SENDER
*copyc MLP$LOCATE_FREE_JOB_ENTRY
*copyc MLP$CREATE_JOB_ENTRY
*copyc MLP$DELETE_JOB_ENTRY
*copyc LGZOPEN
*copyc LGZPUT
*copyc LGZGET
*copyc LGZWEOR
*copyc LGZCLOS
*copyc FZMARK
*copyc LGZCODE
*copyc LGZFIRS
*copyc BIZCLOS
*copyc BIZWEOR
*copyc BIZGET
*copyc BIZPUT
*copyc BIZOPEN
*copyc PXIOTYP
*copyc ZUTPS2D
*copyc ZOSTSTR
*copyc ZUTPD2S
*copyc ZUTPRTF
*copyc ZUTPDNS
*copyc ZUTPSDN

  VAR
    destination: mlt$application_name,
    initialized: boolean := FALSE;

  CONST
    pjp_appl_name = rhc$partner_job_processor * 1073741824;

  TYPE
    nos_job_validation_info = record
      user_name: string (9),
      password: string (31),
      family_name: string (9),
      charge_number: string (31),
      project_number: string (31),
      original_user_name: string (9),
      original_family_name: string (9),
      original_charge_number: string (31),
      original_project_number: string (31),
    recend;
?? TITLE := 'RHP$PARTNER_JOB_EXEC' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ RHP$PARTNER_JOB_EXEC
{
{       This procedure receives and processes partner job function requests.
{
{       RHP$PARTNER_JOB_EXEC (APPLICATION_NAMES, EXEC_STATUS)
{
{ APPLICATION_NAMES: (input) This parameter contains the sending and receiving
{                    application names required for MLI communication.
{
{ EXEC_STATUS: (output) This parameter indicates to the calling procedure
{              the processing status of the executive.  The following status
{              values may be returned:     beginning
{                                          middle
{                                          unrecoverable_error
{

  PROCEDURE [XDCL] rhp$partner_job_exec;

    CONST
      ok = rhc$ok,
      submit_pj = rhc$submit_pj,
      status_pj = rhc$status_pj;

    TYPE
      pj_exec_states = (process_pending_msg, send_process_response),
      job_info = record
        case info_type: (name, validation) of
        = name =
          job_name: ALIGNED [0 MOD 8] utt$dc_name,
        = validation =
          job_validation: nos_job_validation_info,
        casend,
      recend,
      status_job_info_type = record
        case info_type: (status_name, status_validation) of
        = status_name =
          job_name: ALIGNED [0 MOD 8] utt$dc_name,
        = status_validation =
          job_validation: packed record
            fill1: 0 .. 03ffff(16),
            job_name: 0 .. 0ffffff(16),
            fill2: 0 .. 03ffff(16),
          recend,
        casend,
      recend;

    VAR
      quanta_work_completed: boolean,
      partner_job_exec_state: [STATIC] pj_exec_states := process_pending_msg,
      status: ost$status,
      message_info: [STATIC] rht$mli_message_info := [^partner_job_info.job_name, * , *
        , * ],
      partner_job_info: [STATIC] job_info,
      status_msg_length: 1 .. 20,
      status_msg: string (20),
      status_job_info: status_job_info_type,
      partner_job_status: rht$pj_status,
      message_length: mlt$message_length;

    IF NOT initialized THEN
      rhp$initialize_pj_environ;
      RETURN;
    IFEND;

    quanta_work_completed := FALSE;
    REPEAT
      CASE partner_job_exec_state OF

{ Check if NOS/VE making partner job request.

      = process_pending_msg =
        mlp$receive_message (pjp_appl_name, message_info.arbitrary_info, #LOC
              (status), message_info.message_area, message_length, #SIZE (partner_job_info.
              job_validation), 0, destination, status);
        IF status.condition = mlc$ok THEN
          log_status (dayfile_log_and_display, 'REQUEST FROM IRHF 180 RECEIVED.');
          CASE message_info.arbitrary_info OF

{ Submit NOS/170 partner job.

          = submit_pj =
            log_status (dayfile_log_and_display, 'ATTEMPT SUBMIT OF PARTNER JOB.');
            submit_partner_job (partner_job_info.job_validation, destination, partner_job_info.
                  job_name, message_info.arbitrary_info);
            log_status (dayfile_log_and_display, 'IRHF PARTNER JOB SUBMITTED');
            IF message_info.arbitrary_info = ok THEN
              message_info.message_length := #SIZE (partner_job_info.job_name);
            ELSE
              message_info.message_length := 0;
            IFEND;

{ Status NOS/170 partner job.

          = status_pj =
            status_job_info.job_name := partner_job_info.job_name;
            status_partner_job (status_job_info.job_validation.job_name,
                  partner_job_status);
            log_status (dayfile_log_and_display, 'STATUS NOSVE PARTNER JOB');
            message_info.arbitrary_info := partner_job_status;
            message_info.message_length := 0;
          CASEND;
          partner_job_exec_state := send_process_response;
        ELSE
          CASE status.condition OF
          = mlc$busy_interlock, mlc$receive_list_index_invalid =
            quanta_work_completed := TRUE;
          ELSE
            status_msg := 'MLI ERROR';
            STRINGREP (status_msg (11, 10), status_msg_length, status.condition);
{ Only output the error if Sense Swith 2 is turned on.
            log_status (dayfile_log_and_display, status_msg);
            quanta_work_completed := TRUE;
          CASEND;
        IFEND;

{ Send response back to NOS/VE remote host.

      = send_process_response =
        mlp$send_message (pjp_appl_name, message_info.arbitrary_info, #LOC
              (status), message_info.message_area, message_info.message_length,
              destination, status);
        CASE status.condition OF
        = mlc$ok =
          partner_job_exec_state := process_pending_msg;
        = mlc$busy_interlock, mlc$pool_buffer_not_avail,
              mlc$prior_msg_not_received =
        ELSE
          partner_job_exec_state := process_pending_msg;
        CASEND;
        quanta_work_completed := TRUE;
      CASEND;
    UNTIL quanta_work_completed;

  PROCEND rhp$partner_job_exec;
?? OLDTITLE ??
?? NEWTITLE := 'rhp$initialize_pj_environ', EJECT ??

  PROCEDURE rhp$initialize_pj_environ;

    VAR
      status_msg_length: 1 .. 20,
      unique: mlt$application_name,
      status: ost$status,
      status_msg: string (20);

    mlp$sign_on (pjp_appl_name, mlc$max_queued_messages, unique, status);
    CASE status.condition OF
    = mlc$ok =
    ELSE
      status_msg := 'mli error';
      STRINGREP (status_msg (11, 10), status_msg_length, status.condition);
      log_status (dayfile_log, status_msg);
      log_status (dayfile_log, '$RH INIT ERROR');
      IF status.condition = mlc$nosve_not_up THEN
        RETURN;
      IFEND;
      WHILE TRUE DO
        pause (1);
      WHILEND;
    CASEND;

    mlp$add_sender (pjp_appl_name, mlc$null_name, status);
    CASE status.condition OF
    = mlc$ok =
    ELSE
      status_msg := 'mli error';
      STRINGREP (status_msg (11, 10), status_msg_length, status.condition);
      log_status (dayfile_log, status_msg);
      log_status (dayfile_log, '$RH INIT ERROR');
      IF status.condition = mlc$nosve_not_up THEN
        RETURN;
      IFEND;
      WHILE TRUE DO
        pause (1);
      WHILEND;
    CASEND;

    log_status (dayfile_log_and_display, 'RH PJ INITIALIZED');
    initialized := TRUE;

  PROCEND rhp$initialize_pj_environ;

?? TITLE := 'SUBMIT PARTNER JOB', EJECT ??
?? SET (LIST := ON) ??

{
{       The purpose of this procedure is to generate and submit the A170/NOS
{ permanent file partner job.
{
{       SUBMIT_PARTNER_JOB (JOB_VALIDATION_INFO,JOB_NAME,SUBMIT_CONDITION)
{
{ JOB_VALIDATION_INFO: (input) This parameter contains all accounting
{       information required to validate the job to be submitted.
{
{ REQUESTORS_APPLICATION_NAME: (input) This parameter contains the name of the
{       application requesting the partner job submittal.  This application
{       is the application with whom the partner job will communicate.
{
{ JOB_NAME: (output) This parameter specifies the NOS job name given the
{       partner job by NOS upon routing to the input queue.
{
{ SUBMIT_CONDITION: (output) This parameter specifies the condition of the
{       partner job submittal.
{

  PROCEDURE submit_partner_job (
        job_validation_info: nos_job_validation_info;
        requestors_application_name: mlt$application_name;
    VAR job_name: utt$dc_name;
    VAR submit_condition: integer);

    TYPE
      rht$job_name_to_jsn = packed record
        pad1: 0 .. 3ffff(16),
        first_4_chars: 0 .. 0ffffff(16),
        last_3_chars: 0 .. 3ffff(16),
      recend,
      act_response_msg_rec = record
        pj_application_name: packed record
          pj_lfn: 0 .. 3ffffffffff(16),
          filler: 0 .. 3ffff(16),
        recend,
      recend;

    CONST
      partner_job_file_name = 'rhpjfil',
      acct_skeleton_file_name = 'rhaccnt',
      partner_job_dc_file_name = 22102012061114(8), {RHPJFIL}
      task_id_length = 1; { length is in CELL's, i.e. words }

    VAR
      route_status: rht$function_status,
      skeleton_card: string (140),
      substitute_card_image: string (140),
      c170_controlcards: [STATIC] packed ARRAY [0..9] of
                         0 .. 3FFFFFFF(16) :=
                         [ 2210202006(8), 2057000000(8), {RHPPFP.}
      ? IF rhv$nos_be = FALSE THEN
                           4700000000(8), 0            , {*      }
      ? ELSE
                           0120225134(8), 3452000000(8), {APR(11)}
      ? IFEND
                           0530112457(8), 0            , {EXIT.  }
                           0415045642(8), 4233333357(8), {DMD,77000.}
                           0            , 0             ],
      number_of_chars_read: integer,
      mark: file_mark,
      substitute_card_size: 0 .. 140,
      entry_located: boolean,
      job_unique_id: 0 .. 0ffffff(16),
      job_name_to_jsn_ptr: ^rht$job_name_to_jsn,
      create_status: mlt$create_status,
      partner_job_file: file,
      skeleton_file: file,
      local_file_info: [STATIC] rht$local_file_info,
      queue_file_info: [STATIC] rht$queue_file_info;

      { * GENERATE PARTNER JOB * }

      { Route partner job as batch origin.
      mlp$locate_free_job_entry (entry_located);
      IF entry_located THEN

{ Open and read from the RHACCNT template file and put the information
{ in the partner job to be submitted.
        lg#open (skeleton_file, acct_skeleton_file_name, old#, input#, first#);
        request_queue_device (partner_job_dc_file_name);
        bi#open (partner_job_file, partner_job_file_name, new#, output#, first#);

        /generate_partner_job/
        REPEAT
          skeleton_card := ' ';
          lg#get (skeleton_file, number_of_chars_read, skeleton_card);
          f#mark (skeleton_file, mark);
          IF mark = data# THEN
            rhp$sub_skel_parms (job_validation_info, skeleton_card,
               substitute_card_image);
            /cal_card_length/
            FOR substitute_card_size := 140 DOWNTO 1 DO
              IF substitute_card_image (substitute_card_size, 1) <> ' ' THEN
                EXIT /cal_card_length/;
              IFEND;
            FOREND /cal_card_length/;
            lg#put (partner_job_file, substitute_card_image (1, substitute_card_size));
          IFEND;
        UNTIL mark <> data#; {generate_partner_job}

        bi#put (partner_job_file, #LOC (c170_controlcards), #size(c170_controlcards));

        bi#weor (partner_job_file);
        bi#put (partner_job_file, #LOC (requestors_application_name), task_id_length);
        bi#close (partner_job_file, first#);
        lg#close (skeleton_file, first#);

      { * ROUTE PARTNER JOB * }

        local_file_info.fet.filename := partner_job_dc_file_name;
        route_file (pj_exec, local_file_info, queue_file_info, route_status);
        IF route_status = successful THEN
          job_name := local_file_info.fet.filename;
          job_name_to_jsn_ptr := #LOC (job_name);
          job_unique_id := job_name_to_jsn_ptr^.first_4_chars;
          mlp$create_job_entry (job_unique_id, create_status, true);
          IF create_status <> mlc$job_entry_created_ok THEN
            submit_condition := rhe$no_ml_free_entries_found;
          ELSE
            submit_condition := rhc$ok;
          IFEND;
        ELSE
          submit_condition := rhe$partner_job_not_executing;
          utp$return_file (partner_job_file_name);
        IFEND;
      ELSE
        submit_condition := rhe$no_ml_free_entries_found;
      IFEND;

  PROCEND submit_partner_job;

?? TITLE := 'RHP$SUB_SKEL_PARMS' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ RHP$SUB_SKEL_PARMS
{
{        The purpose of this procedure is to substitute keywords with their
{  actual value and return a new card with the substituted values.
{
{       RHP$SUB_SKEL_PARMS (JOB_VALIDATION_INFO, SKELETON_CARD, SUBSTITUTE_CARD);
{
{ JOB_VALIDATION_INFO: (Input) This parameter contains all accounting
{       information needed for substitution on the skeleton card.
{
{ SKELETON_CARD: (Input) This parameter contains one skeleton record from
{       the skeleton file (Created at deadstart time with the name RHACCNT).
{
{ SUBSTITUTE_CARD: (Output) This parameter returns a copy of the skeleton
{       record with values substituted for the keywords.

    PROCEDURE rhp$sub_skel_parms (
       job_validation_info: nos_job_validation_info;
       skeleton_card: string (140);
       VAR substitute_card: string (140));

? IF rhv$nos_be = FALSE THEN
    TYPE

      valid_family_info_rec = packed record
        family_name: 0 .. 3ffffffffff(16),
        filler1: 0 .. 3f(16),
        reply_code: 0 .. 0fff(16),
      recend,

      perm_file_info_rec = packed record
        family_name: 0 .. 3ffffffffff(16),
        zero: 0 .. 3ffff(16),
        filler1: integer,
        user_name: 0 .. 3ffffffffff(16),
        filler2: 0 .. 3ffff(16),
      recend;


  PROCEDURE [XREF] rhpgpfp (VAR perm_file_info: perm_file_info_rec);

  PROCEDURE [XREF] rhpvfam (VAR valid_family_info: valid_family_info_rec);
?IFEND

    CONST
      max_string_length = 140,
      invalid_family = 7777(8),
      job_info = 'P,T5000.',
      skel_job = 'JOB',
      skel_user = 'USER',
      skel_password = 'PASSWORD',
      skel_family = 'FAMILY',
      skel_charge = 'CHARGE',
      skel_project = 'PROJECT',
      skel_orig_user = 'ORGUSER',
      skel_orig_family = 'ORGFAMILY',
      skel_orig_charge = 'ORGCHARGE',
      skel_orig_project = 'ORGPROJECT';

    VAR
      keyword_length: 0 .. 10,
      name_string: string(31),
      in_buff_lngth: integer,
      out_buff_lngth: integer,
      max_replacement_length: 1 .. 31,
      keyword_sub: string (31),
? IF rhv$nos_be = FALSE THEN
      perm_file_info: perm_file_info_rec,
      valid_family_info: valid_family_info_rec,
      dc_family_name: utt$dc_name,
      result_length: 0 .. 7,
? IFEND
      replacement_length: 1 .. 31;

?? TITLE := 'RHP$SUB_SKEL_PARMS' ??
?? EJECT ??

{ Replace keyword and copy to output buffer.  The parameter
{ SKELETON_CARD is the input buffer and SUBSTITUTE_CARD is
{ the output buffer.

    keyword_sub := ' ';
    out_buff_lngth := 1;
    in_buff_lngth := 1;
    substitute_card := ' ';
    /sub_keyword/
    REPEAT
      IF (skeleton_card (in_buff_lngth, 1) = '&') THEN

{  If skeleton card has an '&', then replace the value of the
{  attribute specified into the job template.
        IF (skeleton_card (in_buff_lngth+1, 3) = skel_job) THEN
          keyword_sub := job_info;
          max_replacement_length := 8;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 3;
        ELSEIF (skeleton_card (in_buff_lngth+1, 4) = skel_user) THEN

          keyword_sub := job_validation_info.user_name;
          max_replacement_length := 9;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 4;
        ELSEIF (skeleton_card (in_buff_lngth+1, 8) = skel_password) THEN

          keyword_sub := job_validation_info.password;
          max_replacement_length := 31;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 8;
        ELSEIF (skeleton_card (in_buff_lngth+1, 6) = skel_family) THEN

? IF rhv$nos_be = FALSE THEN
          utp$convert_string_to_dc_name(job_validation_info.family_name (1,7),
              dc_family_name);

{ Validate that the family exists on NOS.  If it does not then use
{ the default NOS family that the IRHF170 job runs under.

          valid_family_info.family_name := dc_family_name;
          valid_family_info.filler1 := 0;
          valid_family_info.reply_code := 0;
          rhpvfam (valid_family_info);
          IF valid_family_info.reply_code = invalid_family THEN

{ The family does not exist on NOS, get the default NOS family.

            rhpgpfp (perm_file_info); { get default family and user }
            utp$convert_dc_name_to_string (perm_file_info.family_name,
                keyword_sub (1,7), result_length);
          ELSE  { family was valid on NOS. }
            utp$convert_dc_name_to_string (dc_family_name,
                keyword_sub (1,7), result_length);
          IFEND;
          max_replacement_length := 7;
? ELSE
          keyword_sub := job_validation_info.family_name;
          max_replacement_length := 9;
? IFEND
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 6;
        ELSEIF (skeleton_card (in_buff_lngth+1,6) = skel_charge) THEN

{ Use only login charge numbers that are alpha-numberic.
          create_valid_170_string (job_validation_info.charge_number,
              keyword_sub);
? IF rhv$nos_be = FALSE THEN
          IF job_validation_info.charge_number = ' ' THEN
            keyword_sub := '*.';
          IFEND;
? IFEND
          max_replacement_length := 31;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 6;
        ELSEIF (skeleton_card (in_buff_lngth+1,7) = skel_project) THEN

{ Use only login project numbers that are alpha-numberic.
          create_valid_170_string (job_validation_info.project_number,
              keyword_sub);
          max_replacement_length := 31;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 7;
        ELSEIF (skeleton_card (in_buff_lngth+1,7) = skel_orig_user) THEN

{ Use only login user names that are alpha-numberic.
          name_string (1,9) := job_validation_info.original_user_name;
          create_valid_170_string (name_string, keyword_sub);
          max_replacement_length := 9;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 7;
        ELSEIF (skeleton_card (in_buff_lngth+1,9) = skel_orig_family) THEN

{ Use only login family names that are alpha-numberic.
          name_string (1,9) := job_validation_info.original_family_name;
          create_valid_170_string (name_string, keyword_sub);
          max_replacement_length := 9;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 9;
        ELSEIF (skeleton_card (in_buff_lngth+1,9) = skel_orig_charge) THEN

{ Use only login charge numbers that are alpha-numberic.
          create_valid_170_string (job_validation_info.original_charge_number,
              keyword_sub);
? IF rhv$nos_be = FALSE THEN
          IF job_validation_info.original_charge_number = ' ' THEN
            keyword_sub := '*.';
          IFEND;
? IFEND
          max_replacement_length := 31;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 9;
        ELSEIF (skeleton_card (in_buff_lngth+1,10) = skel_orig_project) THEN

{ Use only login project numbers that are alpha-numberic.
          create_valid_170_string (job_validation_info.original_project_number,
              keyword_sub);
          max_replacement_length := 31;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 10;
        ELSE  { the '&' is not followed by a defined keyword, leave it on the command line.
          substitute_card (out_buff_lngth, 1) := skeleton_card (in_buff_lngth, 1);
          replacement_length := 1;
          keyword_length := 0;

        IFEND;
        out_buff_lngth := out_buff_lngth + replacement_length;
        in_buff_lngth := in_buff_lngth + keyword_length + 1;
        keyword_sub := ' ';
      ELSE
        substitute_card (out_buff_lngth, 1) := skeleton_card (in_buff_lngth, 1);
        in_buff_lngth := in_buff_lngth + 1;
        out_buff_lngth := out_buff_lngth + 1;
      IFEND;

    UNTIL (out_buff_lngth > max_string_length) OR (in_buff_lngth > max_string_length); {sub_keyword}

    IF NOT (out_buff_lngth > max_string_length) THEN

{ Set the remaining parts of the command card to blank.
      substitute_card (out_buff_lngth, max_string_length - out_buff_lngth + 1)  := ' ';
    IFEND;

  PROCEND rhp$sub_skel_parms;

?? TITLE := 'SUBSTITUTE_KEYWORD' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ SUBSTITUTE_KEYWORD
{
{        This procedure will substitute a given value for the keyword
{ in an output buffer.
{
{        SUBSTITUTE_KEYWORD (SUBSTITUTE_CARD, REPLACEMENT_LENGTH
{             OUT_BUFF_LNGTH, MAX_REPLACEMENT_LENGTH, KEYWORD_SUB)
{
{ SUBSTITUTE_CARD: (Output) This parameter returns a copy of the input buffer
{       with the keyword replaced.
{
{ REPLACEMENT_LENGTH: (Output) This parameter returns the length of the
{       replacement buffer.
{
{ REPLACEMENT_LENGTH: (Output) This parameter returns the length of the replacement string.
{
{ MAX_REPLACEMENT_LENGTH: (Input) This parameter is the maximum size of the field
{       being passed in.
{
{ KEYWORD_SUB: (Input) This parameter is what is replaced into the output
{       buffer.

  PROCEDURE substitute_keyword
       (VAR substitute_card: string (140);
       VAR replacement_length: 1 .. 31;
       out_buff_lngth: integer;
       max_replacement_length: 1 .. 31;
       keyword_sub: string(31));

    VAR index: 1 .. 31;

{ Calculate length of the replacement string.

      replacement_length := 1;
    /cal_replacement_lngth/
      FOR index := 1 to max_replacement_length DO
        IF keyword_sub (index, 1) <> ' ' THEN
          replacement_length := index;
        IFEND;
      FOREND /cal_replacement_lngth/;

{ Replace keyword and copy to output buffer.}
      substitute_card (out_buff_lngth, replacement_length) :=
          keyword_sub (1, replacement_length);

  PROCEND substitute_keyword;

?? OLDTITLE, NEWTITLE := 'PROCEDURE create_valid_170_string', EJECT ??

{ CREATE_VALID_170_STRING
{
{        This procedure will create a valid 170 string (delete all $ from
{ the passed parameter and put into the new string.  The only values that
{ will be changed are the charge number, project number, orignal user name,
{ original family name, original charge number, and original project number.
{
{        CREATE_VALID_170_STRING (KEYWORD_STRING, KEYWORD_SUB)
{
{ KEYWORD_STRING: (Input) This parameter is the value of the old string to be changed.
{
{ KEYWORD_SUB: (Output) This parameter is the value of the new string created.
{
  PROCEDURE create_valid_170_string (keyword_string: string (31);
      VAR keyword_sub: string (31));

    CONST max_keyword_string_size = 31;

    VAR keyword_sub_size,
        keyword_string_size: 1 .. max_keyword_string_size;

{ Use only strings that are alpha-numberic.
    keyword_sub := ' ';
    keyword_sub_size := 1;
    FOR keyword_string_size := 1 TO max_keyword_string_size DO
      IF ((keyword_string (keyword_string_size) >= 'A') AND
        (keyword_string (keyword_string_size) <= 'Z')) OR
        ((keyword_string (keyword_string_size) >= 'a') AND
        (keyword_string (keyword_string_size) <= 'z')) OR
        ((keyword_string (keyword_string_size) >= '0') AND
        (keyword_string (keyword_string_size) <= '9')) OR
? IF rhv$nos_be THEN
        (keyword_string (keyword_string_size) = '=') OR
        (keyword_string (keyword_string_size) = ',') OR
        (keyword_string (keyword_string_size) = '.') OR
? IFEND
        (keyword_string (keyword_string_size) = '*') THEN
        keyword_sub (keyword_sub_size) := keyword_string (keyword_string_size);
        keyword_sub_size := keyword_sub_size + 1;
      IFEND;
    FOREND;

  PROCEND create_valid_170_string;

?? TITLE := 'STATUS_PARTNER_JOB' ??
?? SET (LIST := ON) ??
?? EJECT ??

{
{      The purpose of this procedure is to determine if the specified job
{ is either in the input queue or executing, or if it is elswhere.
{
{      STATUS_PARTNER_JOB (JOB_NAME,PJ_STATUS)
{
{ JOB_NAME: (input) This parameter contains the A170/NOS job name of the
{           job whos status is to be determined.
{
{ PJ_STATUS: (output) This parameter indicates the status of the partner
{            job.  Possible values for this parameter are:  job_found
{                                                           job_not_found
{

  PROCEDURE status_partner_job (job_name: 0 .. 0ffffff(16);
    VAR partner_job_status: rht$pj_status);

  ? IF rhv$nos_be = FALSE THEN
    CONST
      qac_peek_function_code = 3,
      qac_peek_parameter_block_length = 11,
      file_found_qac_error_code = 0,
      file_not_found_qac_error_code = 7,
      job_not_found = rhc$job_not_found,
      job_found = rhc$job_found;

    TYPE
      qac_parameter_block = packed record
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 0
        file_name: 0 .. 3ffffffffff(16),
        error_code: 0 .. 0ff(16),
        function_code: 0 .. 1ff(16),
        complete_bit: boolean,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 1
        fill1: 0 .. 3ffffffff(16),
        length_of_request_block: 0 .. 0ff(16),
        fwa_of_additional_info: ^CELL,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 2
        fill2: 0 .. 3ffffffffff(16),
        lwa_plus_1_of_msg_returned: ^CELL,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 3
        fill3: 0 .. 3ffffffffff(16),
        fwa_of_msg_returned: ^CELL,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 4
        fnt_ordinal: 0 .. 0fff(16),
        io_queue_table_ordinal: 0 .. 0fff(16),
        file_found_in_queue: 0 .. 0fff(16),
        fill4: 0 .. 3f(16),
        limit_address: ^CELL,

{ Selection Criteria
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 5
        destination_famliy_name: 0 .. 3ffffffffff(16),
        batch_device_id: 0 .. 3f(16),
        origin_type_to_select: 0 .. 0fff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 6
        destination_user_name: 0 .. 3ffffffffff(16),
        destination_user_index: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 7
        job_sequence_number: 0 .. 0ffffff(16),
        selection_flags: packed record
          reserved_for_installation: 0 .. 7,
          reserved: 0 .. 3fff(16),
          recoverable_jobs: boolean,
          enabled_dlid: boolean,
          slid_source_lid: boolean,
          alid_alternate_dest_lid: boolean,
          dlid_destination_lid: boolean,
          access_level: boolean,
          ic_selection: boolean,
          include_ec_0_in_selection: boolean,
          hierarchical_ec: boolean,
          expicit_ec: boolean,
          disposition_code: boolean,
          forms_code: boolean,
          job_sequence_number: boolean,
          origin: boolean,
          destination_batch_id: boolean,
          destination_fm_un_ui: boolean,
          include_priority_0_in_selection: boolean,
          inhibit_duplicate_lfn_search: boolean,
          specific_ordinal_in_w4: boolean,       { Bit 0 }
        recend,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 8
        selection_queues: packed record
          reserved2: 0 .. 7,
          installation: 0 .. 1,
          reserved1: 0 .. 3,
          wait_queue: boolean,
          plot_queue: boolean,
          punch_queue: boolean,
          print_queue: boolean,
          executing_queue: boolean,
          input_queue: boolean,     { Bit 0 }
        recend,
        forms_code: 0 .. 0fff(16),
        disposition_code: 0 .. 0fff(16),
        external_characteristics: 0 .. 7,
        internal_characteristics: 0 .. 7,
        link_address: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 9
        source_mainframe_logical_id: 0 .. 3ffff(16),
        destination_mainfram_logical_id: 0 .. 3ffff(16),
        fill9a: 0 .. 3f(16),
        alternate_dlid_list_address: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 10
        security_level: 0 .. 0fff(16),
        reserved_for_cdc: 0 .. 0ffffffffffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 11
        reserved11: integer,

{ PEEK Function Portion
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 12
        input_queue_count: 0 .. 0fff(16),
        executing_queue_count: 0 .. 0fff(16),
        print_queue_count: 0 .. 0fff(16),
        punch_queue_count: 0 .. 0fff(16),
        plot_queue_count: 0 .. 0fff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 13
        fill13: 0 .. 0fffffffff(16),
        installation_queue_count: 0 .. 0fff(16),
        peek_reply_entry_length: 0 .. 0fff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 14
        peek_information_bits: packed record
          remaining_bits: 0 .. 0fffffff(16),
          rest_of_remaining_bits: 0 .. 1fffffff(16),
          ordinal_of_entry_in_ejt: boolean,
          job_sequence_number: boolean,
          e0: 0 .. 1,
        recend,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 15
        reserved15: integer,
      recend,
      qac_peek_reply_buffer = packed record
{             * * * * Word 1 * * * *
        job_sequence_number: 0 .. 0ffffff(16),
        ordinal: 0 .. 0fff(16),
        queue: 0 .. 0fff(16),
        rt: 0 .. 3f(16),
        word_number: 0 .. 3f(16),
{             * * * * Word 2 * * * *
        service_class: 0 .. 3f(16),
        origin_type: 0 .. 3f(16),
        forms_code: 0 .. 0fff(16),
        disposition_code: 0 .. 0fff(16),
        external_characteristics: 0 .. 3f(16),
        internal_characteristics: 0 .. 3f(16),
        rt2: 0 .. 3f(16),
        word_number_2: 0 .. 3f(16),
{             * * * * Word 3 * * * *
        last_word_plus_one: ALIGNED [0 MOD 8] integer,
      recend;

    VAR
      qacpb_init_block: [STATIC] qac_parameter_block :=
        [0, 0, qac_peek_function_code, FALSE,  0, qac_peek_parameter_block_length,
         ^qac_reply_buffer, 0, ^qac_reply_buffer,
         0, ^qac_reply_buffer,  0, 0, 0, 0, ^qac_reply_buffer,
{        - - - - selection criteria (words 5 - 11) - - - -
         0, 0, 0,  0, 0,  0, [0, 0, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
         FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE,
         FALSE, FALSE, FALSE],
         [0, 0, 0, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE],
         0, 0, 0, 0, 0,  0, 0, 0, 0,  0, 0,  0,
{        - - - - peek function portion (words 12 - 15) - - - -
         0, 0, 0, 0, 0,  0, 0, 0,  [0, 0, FALSE, TRUE, 0],  0],
      qacpb: qac_parameter_block,
      qac_reply_buffer: [STATIC] qac_peek_reply_buffer := [0, 0, 0, 0, 1,
            0, 0, 0, 0, 0, 0, 0, 2,  0],
      qac_error_message: string (15),
      delete_status: mlt$delete_status,
      string_length: integer;

    PROCEDURE [XREF] rhpqac ALIAS 'rhpqac' (VAR qacpb: qac_parameter_block);

    qacpb := qacpb_init_block;
    qacpb.limit_address := ^qac_reply_buffer.last_word_plus_one;
    qacpb.job_sequence_number := job_name;
    qacpb.executing_queue_count := 1;
    qacpb.input_queue_count := 1;
    rhpqac (qacpb);
    IF qacpb.error_code =  file_found_qac_error_code THEN
      partner_job_status := job_found;
    ELSE
      partner_job_status := job_not_found;
      mlp$delete_job_entry (job_name, delete_status);
      IF (delete_status = mlc$job_entry_delete_failed) THEN
        log_status (dayfile_log_and_display,
             'job was not found in memory link table');
      IFEND;
      qac_error_message (1,12) := 'qac error = ';
      STRINGREP (qac_error_message (13, 3), string_length, qacpb.error_code);
      IF (qacpb.error_code = file_not_found_qac_error_code) THEN
        log_status (dayfile_log_and_display, qac_error_message (1,
                        12 + string_length));
      ELSE
        log_status (dayfile_log, qac_error_message (1, 12 + string_length));
      IFEND;
    IFEND;
  ? ELSE
    CONST
      qaf_count_function_code = 3,
      file_not_found_qaf_error_code = 2,
      qaf_job_name_zero_fill = 11011011011011011(2),
      job_not_found = rhc$job_not_found,
      job_found = rhc$job_found;

    TYPE
      qaf_parameter_block = packed record
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 0
        job_name_first_four: 0 .. 0ffffff(16),
        job_name_zero_fill: 0 .. 3ffff(16),
        error_code: 0 .. 03f(16),
        queue_type: packed record
          reserved1: 0 .. 7(16),
          execution: boolean,
          special_output: boolean,
          punch: boolean,
          output: boolean,
          input: boolean,
        recend,
        function_code: 0 .. 7(16),
        complete_bit: boolean,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 1
        alter_flags: packed record
          fill1: 0 .. 3f(16),
          abort_evict: boolean,
          change_repeat_count: boolean,
          change_or_compare_fc: boolean,
          change_priority: boolean,
          change_terminal_id: boolean,
          send_to_central_site: boolean,
        recend,
        forms_code: 0 .. 0fff(16),
        disposition_code: 0 .. 0fff(16),
        fill2: 0 .. 1,
        repeat_count: 0 .. 1f(16),
        fwa_of_additional_info: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 2
        source_mainframe_logical_id: 0 .. 3ffff(16),
        destination_mainfram_logical_id: 0 .. 3ffff(16),
        fnt_address: 0 .. 0fff(16),
        job_class: 0 .. 0fff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 3
        return_routing_info: boolean,
        fill3: 0 .. 7ff(16),
        new_terminal_id: 0 .. 0fff(16),
        fill4: 0 .. 0fff(16),
        current_terminal_id: 0 .. 0fff(16),
        priority: 0 .. 0fff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 4
        pre_dayfile_file_name: 0 .. 3ffffffffff(16),
        pre_dayfile_flag: boolean,
        class_2_inhibit: boolean,
        class_1_inhibit: boolean,
        inhibit_dup_file_search: boolean,
        ignore_file_list_specified: boolean,
        ignore_file_did_host_match: boolean,
        executing_job_count: 0 .. 0fff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 5
        additional_did_words: 0 .. 0fff(16),
        input_file_count: 0 .. 0fff(16),
        output_file_count: 0 .. 0fff(16),
        punch_file_count: 0 .. 0fff(16),
        special_output_file_count: 0 .. 0fff(16),
      recend;

    VAR
      qafpb_init_block: [STATIC] qaf_parameter_block :=
        [0, 0, 0, [0, TRUE, FALSE, FALSE, FALSE, TRUE], qaf_count_function_code, FALSE,
         [0, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE], 0, 0, 0, 0, 0, 0, 0, 0, 0,
         FALSE, 0, 0, 0, 0, 0, 0, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
         0, 0, 0, 0, 0, 0],
      qafpb: qaf_parameter_block,
      qaf_error_message: string (15),
      delete_status: mlt$delete_status,
      string_length: integer;

    PROCEDURE [XREF] rhpqac ALIAS 'rhpqac' (VAR qafpb: qaf_parameter_block);

    qafpb := qafpb_init_block;
    qafpb.job_name_first_four := job_name;
    qafpb.job_name_zero_fill := qaf_job_name_zero_fill;
    rhpqac (qafpb);
    IF (qafpb.executing_job_count <> 0) OR
        (qafpb.input_file_count <> 0) THEN
      partner_job_status := job_found;
    ELSE
      partner_job_status := job_not_found;
      mlp$delete_job_entry (job_name, delete_status);
      IF (delete_status = mlc$job_entry_delete_failed) THEN
        log_status (dayfile_log_and_display,
             'job was not found in memory link table');
      IFEND;
      qaf_error_message (1,12) := 'qaf error = ';
      STRINGREP (qaf_error_message (13, 3), string_length, qafpb.error_code);
      IF (qafpb.error_code = file_not_found_qaf_error_code) THEN
        log_status (dayfile_log_and_display, qaf_error_message (1,
                        12 + string_length));
      ELSE
        log_status (dayfile_log, qaf_error_message (1, 12 + string_length));
      IFEND;
    IFEND;
  ? IFEND
  PROCEND status_partner_job;

MODEND rhm$partner_job_exec;
*DECK DECK=RHM$PAUSE EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := '170 NOS/VE REMOTE HOST' ??
MODULE rhmpau;


?? TITLE := 'EXTERNAL PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc RHP$WAIT

?? TITLE := 'PAUSE' ??
?? SET (LIST := ON) ??
?? EJECT ??
{ PAUSE
{
{        The purpose of this A170 CYBIL procedure is to set the pause
{ flag in RA+0 and recall until the flag is cleared.
{
{        PAUSE
{

  PROCEDURE [XDCL] pause;

    TYPE
      ra_rec = packed record
        filler1: 0 .. 7fffffffffff(16),
        pause_bit: boolean,
        filler2: 0 .. 0fff(16),
      recend,
      ra_access_rec = record
        case address_ref_type: (abs_address, pointer) of
        = abs_address =
          ra_ptr: integer,
        = pointer =
          ra_rec_ptr: ^ra_rec,
        casend,
      recend;

    VAR
      ra_access: [STATIC] ra_access_rec := [abs_address, 0];

?? SET (LIST := OFF) ??
*copyc RHP$WAIT
?? SET (LIST := ON) ??

    ra_access.ra_rec_ptr^.pause_bit := TRUE;
    REPEAT
      wait (1000);
    UNTIL ra_access.ra_rec_ptr^.pause_bit = FALSE;
    RETURN;

  PROCEND pause;

MODEND rhmpau;
*DECK DECK=RHM$PERMANENT_FILE_GET_REPLACE EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE  Remote Host :' ??
MODULE rhm$permanent_file_get_replace;

?? NEWTITLE := '        Global Declarations' ??
*copy syt$data_conversions

  TYPE
    pf_op_types = (pf_get, pf_rep);

  CONST
    first_binary_conversion = syc$56_bit_binary_to_64_bit;

?? SET (LIST := ON) ??
?? EJECT ??
*copyc OSC$PROCESSOR_DEFINED_REGISTERS
*copyc oss$job_paged_literal
*copyc RHC$CONSTANTS
*copyc RHD$CONDITION_CODES
*copyc rht$attachment_option
*copyc rht$file_cycle_attribute

?? TITLE := '        External Procedures Referenced By This Module' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc AMP$RETURN
*copyc AMP$GET_FILE_ATTRIBUTES
*copyc AMP$REWIND
*copyc FSP$CLOSE_FILE
*copyc FSP$COPY_FILE
*copyc FSP$OPEN_FILE
*copyc RMP$GET_DEVICE_CLASS
*copyc osp$append_status_file
*copyc OSP$SET_STATUS_ABNORMAL
*copyc PMP$ESTABLISH_CONDITION_HANDLER
*copyc pmp$get_unique_name
*copyc PMP$CONTINUE_TO_CAUSE
*copyc RHP$CLOSE_B56_FILE
*copyc RHH$MLI_GET_PERMANENT_FILE
*copyc RHP$MLI_GET_PERMANENT_FILE
*copyc RHH$MLI_REPLACE_PERMANENT_FILE
*copyc RHP$MLI_REPLACE_PERMANENT_FILE
*copyc RHP$OPEN_B56_FILE

?? TITLE := '        Convert_ascii88_to_ascii812' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ CONVERT_ASCII88_TO_ASCII812
{
{       The purpose of this procedure is to convert an 8/8 ascii string to
{ an A170 8/12 ascii string.
{
{       CONVERT_ASCII88_TO_ASCII812 (ASCII88_STRING,ASCII812_STRING
{,CONVERSION_STATUS)
{
{ ASCII88_STRING: (input) This parameter contains the 8/8 ascii string which
{                 is to be converted.
{
{ ASCII812_STRING: (output) This parameter contains the 8/12 ascii string which
{                  is the result of the conversion.
{
{ CONVERSION_STATUS: (output) This parameter indicates the success or failure
{ of
{                    the conversion.  If the output string is not large enough
{                    to complete the conversion of the entire input string then
{                    a status of non_fatal_error will be returned otherwise the
{                    conversion will be successful.  In either case, conversion
{                    of as much of the string as is possible will be performed.
{

  PROCEDURE convert_ascii88_to_ascii812
    (    ascii88_string: string ( * );
     VAR ascii812_string: array [ * ] of rht$c180_ascii812_word;
     VAR conversion_status: rht$status);

    VAR
      ascii88_string_length: 0 .. 256,
      ascii812_string_lbound: integer,
      ascii812_string_ubound: integer,
      words_required: 0 .. 55,
      last_word#: integer,
      chars_in_last_word: 1 .. 5,
      word#: integer,
      ascii88_char#: 0 .. 256,
      ascii812_char#: 2 .. 5;

    ascii88_string_length := STRLENGTH (ascii88_string);
    ascii812_string_lbound := LOWERBOUND (ascii812_string);
    ascii812_string_ubound := UPPERBOUND (ascii812_string);
    words_required := (ascii88_string_length + 4) DIV 5;
    IF (ascii812_string_ubound - ascii812_string_lbound + 1) <
          words_required THEN
      last_word# := ascii812_string_ubound;
      chars_in_last_word := 5;
      conversion_status := non_fatal_error;
    ELSE
      last_word# := ascii812_string_lbound + words_required - 1;
      chars_in_last_word := ascii88_string_length - (words_required - 1) * 5;
      conversion_status := successful;
    IFEND;
    ascii88_char# := 0;
    FOR word# := ascii812_string_lbound TO last_word# - 1 DO
      ascii88_char# := ascii88_char# + 1;
      ascii812_string [word#].ascii812_char1.filler := 0;
      ascii812_string [word#].ascii812_char1.ascii88_char :=
            ascii88_string (ascii88_char#);
      FOR ascii812_char# := 2 TO 5 DO
        ascii88_char# := ascii88_char# + 1;
        ascii812_string [word#].ascii812_char2_5 [ascii812_char#].filler := 0;
        ascii812_string [word#].ascii812_char2_5 [ascii812_char#].
              ascii88_char := ascii88_string (ascii88_char#);
      FOREND;
    FOREND;
    ascii88_char# := ascii88_char# + 1;
    ascii812_string [last_word#].ascii812_char1.filler := 0;
    ascii812_string [last_word#].ascii812_char1.ascii88_char :=
          ascii88_string (ascii88_char#);
    FOR ascii812_char# := 2 TO chars_in_last_word DO
      ascii88_char# := ascii88_char# + 1;
      ascii812_string [last_word#].ascii812_char2_5 [ascii812_char#].filler :=
            0;
      ascii812_string [last_word#].ascii812_char2_5 [ascii812_char#].
            ascii88_char := ascii88_string (ascii88_char#);
    FOREND;

  PROCEND convert_ascii88_to_ascii812;

?? TITLE := '        [XDCL] rhp$get' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc rhh$get_file

  PROCEDURE [XDCL] rhp$get ALIAS 'rhxget'
    (    file: fst$file_reference;
         pf_name: string (31);
         conversion: syt$data_conversions;
         user_or_id: string (9);
         file_cycle: string (3);
         file_password: array [1 .. 2] of string (9);
     VAR status: ost$status);

?? SET (LIST := ON) ??
?? EJECT ??

    PROCEDURE getf_handle_break
      (    cond: pmt$condition;
           cd: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR ch_status: ost$status);

      VAR
        ost: ost$status;


      ch_status.normal := TRUE;

      IF break_active THEN
        RETURN;
      IFEND;
      break_active := TRUE;

{ Close data file.

      IF file_open THEN
        IF conversion = syc$64_bit_binary_to_56_bit THEN

{ We must close a B56 file in ring 3 in order to override the file attributes.

          rhp$close_b56_file (local_file_info, ost);
        ELSE
          fsp$close_file (local_file_info.file_identifier, ost);
        IFEND;
      IFEND;
      IF copy_required THEN
        amp$return (scratch_fn, ost);
      IFEND;

{ Exit the PF operation with abnormal status

      CASE cond.interactive_condition OF
      = ifc$pause_break =
        osp$set_status_abnormal (rhc$remote_host_id,
            rhe$pause_break_received, '', status);
      = ifc$terminate_break =
        osp$set_status_abnormal (rhc$remote_host_id,
            rhe$terminal_break_occurred, '', status);
      ELSE
        osp$set_status_abnormal (rhc$remote_host_id,
            rhe$terminal_connection_broken, '', status);
      CASEND;
      EXIT rhp$get;

    PROCEND getf_handle_break;

?? EJECT ??

    VAR
      wait: ost$wait,
      permanent_file_name: array [1 .. 7] of rht$c180_ascii812_word,
      user_id: array [1 .. 2] of rht$c180_ascii812_word,
      cycle_number: array [1 .. 1] of rht$c180_ascii812_word,
      file_passwords: array [1 .. 2] of array [1 .. 2] of
            rht$c180_ascii812_word,
      conversion_status: rht$status,
      local_file_info: rht$local_file_info,
      conversion_file_name: amt$local_file_name,
      conversion_file_identifier: amt$file_identifier,
      close_status: ost$status,
      cond_desc: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
            [pmc$condition_combination, $pmt$condition_combination
            [ifc$interactive_condition]],
      estab_handler: pmt$established_handler,
      local_status: ost$status,
      conversion_file_open,
      file_open,
      break_active: boolean,
      open_attributes: rht$file_cycle_attribute,
      output_file_attachment_options: rht$attachment_option,
      scratch_fn: amt$local_file_name,
      file_found: boolean,
      copy_required: boolean;

{ Initialize.

    conversion_file_open := FALSE;
    file_open := FALSE;
    file_found := TRUE;
    break_active := FALSE;
    copy_required := FALSE;
    pmp$establish_condition_handler (cond_desc, ^getf_handle_break,
          ^estab_handler, local_status);

{ Set up information needed to get the permanent file.

    convert_ascii88_to_ascii812 (pf_name (1, 31), permanent_file_name,
          conversion_status);
    convert_ascii88_to_ascii812 (user_or_id (1, 9),
          user_id, conversion_status);
    convert_ascii88_to_ascii812 (file_cycle (1, 3), cycle_number,
          conversion_status);
    convert_ascii88_to_ascii812 (file_password [1] (1, 9), file_passwords [1],
          conversion_status);
    convert_ascii88_to_ascii812 (file_password [2] (1, 9), file_passwords [2],
          conversion_status);

  /getf/
    BEGIN

{ Open local file.

      prepare_file_attributes (file, conversion, pf_get, open_attributes,
            copy_required, status);
      IF NOT status.normal THEN
        EXIT /getf/;
      IFEND;

{ Define the output file attachment options.

      output_file_attachment_options [1].selector :=
            fsc$access_and_share_modes;
      output_file_attachment_options [1].access_modes.selector :=
            fsc$specific_access_modes;
      output_file_attachment_options [1].access_modes.value :=
            $fst$file_access_options [fsc$append, fsc$shorten];
      output_file_attachment_options [1].share_modes.selector :=
            fsc$specific_share_modes;
      output_file_attachment_options [1].share_modes.value :=
            $fst$file_access_options [];
      output_file_attachment_options [2].selector :=
            fsc$access_and_share_modes;
      output_file_attachment_options [2].access_modes.selector :=
            fsc$specific_access_modes;
      output_file_attachment_options [2].access_modes.value :=
            $fst$file_access_options [fsc$append];
      output_file_attachment_options [2].share_modes.selector :=
            fsc$specific_share_modes;
      output_file_attachment_options [2].share_modes.value :=
            $fst$file_access_options [];
      output_file_attachment_options [3].selector := fsc$open_share_modes;
      output_file_attachment_options [3].open_share_modes :=
            $fst$file_access_options [];
      output_file_attachment_options [4].selector := fsc$sequential_access;
      output_file_attachment_options [4].sequential_access := TRUE;
      output_file_attachment_options [5].selector := fsc$delete_data;
      output_file_attachment_options [5].delete_data := TRUE;
      IF copy_required THEN
        pmp$get_unique_name (scratch_fn, local_status);
        fsp$open_file (scratch_fn, amc$record, ^output_file_attachment_options,
              NIL, ^open_attributes, ^open_attributes, NIL,
              local_file_info.file_identifier, status);
        IF NOT status.normal THEN
          EXIT /getf/;
        IFEND;
      ELSE
        IF (conversion = syc$56_bit_binary_to_64_bit) THEN

{ We must open the B56 file in ring 3 to override the attributes.

          rhp$open_b56_file (file, output_file_attachment_options,
                local_file_info, status);
        ELSE
          fsp$open_file (file, amc$record, ^output_file_attachment_options,
                NIL, ^open_attributes, ^open_attributes, NIL,
                local_file_info.file_identifier, status);
        IFEND;
        IF NOT status.normal THEN
          EXIT /getf/;
        IFEND;
      IFEND;
      file_open := status.normal;

{ Have the 170 permanent file converted while copying to a local file.

      rhp$mli_get_permanent_file (permanent_file_name, user_id, cycle_number,
            file_passwords, local_file_info, conversion, status);
      IF NOT status.normal THEN
        file_found := FALSE;
        EXIT /getf/;
      IFEND;
      IF copy_required THEN
        fsp$close_file (local_file_info.file_identifier, status);
        IF NOT status.normal THEN
          EXIT /getf/;
        IFEND;
        fsp$copy_file (scratch_fn, file, NIL, NIL, NIL, status);
        IF NOT status.normal THEN
          EXIT /getf/;
        IFEND;
      IFEND;

    END /getf/;

    amp$rewind (local_file_info.file_identifier, wait, local_status);
    IF conversion = syc$64_bit_binary_to_56_bit THEN

{ We must close a B56 file in ring 3 in order to override the file attributes.

      rhp$close_b56_file (local_file_info, local_status);
    ELSE
      fsp$close_file (local_file_info.file_identifier, local_status);
    IFEND;
    IF copy_required THEN
      amp$return (scratch_fn, local_status);
    IFEND;
    IF NOT file_found THEN
      amp$return (file, local_status);
    IFEND;
    file_open := FALSE;

  PROCEND rhp$get;

?? TITLE := '        [XDCL] rhp$replace' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc RHH$REPLACE

  PROCEDURE [XDCL] rhp$replace ALIAS 'rhxrep'
    (    file: fst$file_reference;
         pf_name: string (31);
         conversion: syt$data_conversions;
         user_or_id: string (9);
         file_cycle: string (3);
         file_password: array [1 .. 2] of string (9);
     VAR status: ost$status);

?? SET (LIST := ON) ??
?? EJECT ??

    PROCEDURE repf_handle_break
      (    cond: pmt$condition;
           cd: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR ch_status: ost$status);

      VAR
        ost: ost$status;

      ch_status.normal := TRUE;

      IF break_active THEN
        RETURN;
      IFEND;
      break_active := TRUE;

{ Close data file.

      IF file_open THEN
        IF conversion = syc$64_bit_binary_to_56_bit THEN

{ We must close a B56 file in ring 3 in order to override the file attributes.

          rhp$close_b56_file (local_file_info, ost);
        ELSE
          fsp$close_file (local_file_info.file_identifier, ost);
        IFEND;
      IFEND;
      IF copy_required THEN
        amp$return (scratch_fn, ost);
      IFEND;

{ Exit the PF operation with abnormal status

      CASE cond.interactive_condition OF
      = ifc$pause_break =
        osp$set_status_abnormal (rhc$remote_host_id,
            rhe$pause_break_received, '', status);
      = ifc$terminate_break =
        osp$set_status_abnormal (rhc$remote_host_id,
            rhe$terminal_break_occurred, '', status);
      ELSE
        osp$set_status_abnormal (rhc$remote_host_id,
            rhe$terminal_connection_broken, '', status);
      CASEND;
      EXIT rhp$replace;

    PROCEND repf_handle_break;

?? EJECT ??

    VAR
      local_file_info: rht$local_file_info,
      permanent_file_name: array [1 .. 7] of rht$c180_ascii812_word,
      user_id: array [1 .. 2] of rht$c180_ascii812_word,
      cycle_number: array [1 .. 1] of rht$c180_ascii812_word,
      file_passwords: array [1 .. 2] of array [1 .. 2] of
            rht$c180_ascii812_word,
      cond_desc: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
            [pmc$condition_combination, $pmt$condition_combination
            [ifc$interactive_condition]],
      estab_handler: pmt$established_handler,
      local_status: ost$status,
      file_open,
      break_active: boolean,
      open_attributes: rht$file_cycle_attribute,
      input_file_attachment_options: rht$attachment_option,
      scratch_fn: amt$local_file_name,
      copy_required: boolean,
      conversion_status: rht$status;


{ Initialize.

    file_open := FALSE;
    break_active := FALSE;
    copy_required := FALSE;
    pmp$establish_condition_handler (cond_desc, ^repf_handle_break,
          ^estab_handler, local_status);

{ Set up the information that identifies the permanent file that will be
{replaced.

    convert_ascii88_to_ascii812 (pf_name (1, 31), permanent_file_name,
          conversion_status);
    convert_ascii88_to_ascii812 (user_or_id (1, 9),
          user_id, conversion_status);
    convert_ascii88_to_ascii812 (file_cycle (1, 3), cycle_number,
          conversion_status);
    convert_ascii88_to_ascii812 (file_password [1] (1, 9), file_passwords [1],
          conversion_status);
    convert_ascii88_to_ascii812 (file_password [2] (1, 9), file_passwords [2],
          conversion_status);

{ Open the local file.

  /repf/
    BEGIN
      prepare_file_attributes (file, conversion, pf_rep, open_attributes,
            copy_required, status);
      IF NOT status.normal THEN
        EXIT /repf/;
      IFEND;

{ Set up the input file attachment options for a REPF.

      input_file_attachment_options [1].selector := fsc$access_and_share_modes;
      input_file_attachment_options [1].access_modes.selector :=
            fsc$specific_access_modes;
      input_file_attachment_options [1].access_modes.value :=
            $fst$file_access_options [fsc$read];
      input_file_attachment_options [1].share_modes.selector :=
            fsc$specific_share_modes;
      input_file_attachment_options [1].share_modes.value :=
            $fst$file_access_options [fsc$read, fsc$execute];
      input_file_attachment_options [2].selector := fsc$open_share_modes;
      input_file_attachment_options [2].open_share_modes :=
            $fst$file_access_options [fsc$read, fsc$execute];
      input_file_attachment_options [3].selector := fsc$create_file;
      input_file_attachment_options [3].create_file := FALSE;
      input_file_attachment_options [4].selector := fsc$sequential_access;
      input_file_attachment_options [4].sequential_access := TRUE;
      input_file_attachment_options [5].selector := fsc$delete_data;
      input_file_attachment_options [5].delete_data := TRUE;
      IF copy_required THEN
        pmp$get_unique_name (scratch_fn, local_status);
        fsp$copy_file (file, scratch_fn, NIL, ^open_attributes,
              ^open_attributes, status);
        IF NOT status.normal THEN
          EXIT /repf/;
        IFEND;
        fsp$open_file (scratch_fn, amc$record, ^input_file_attachment_options,
              NIL, ^open_attributes, ^open_attributes, NIL,
              local_file_info.file_identifier, status);
        IF NOT status.normal THEN
          EXIT /repf/;
        IFEND;
      ELSE
        IF conversion = syc$64_bit_binary_to_56_bit THEN

{ We must open a B56 file in ring 3 in order to override the file attributes.

          rhp$open_b56_file (file, input_file_attachment_options,
                local_file_info, status);
        ELSE
          fsp$open_file (file, amc$record, ^input_file_attachment_options, NIL,
                ^open_attributes, ^open_attributes, NIL,
                local_file_info.file_identifier, status);
        IFEND;
        IF NOT status.normal THEN
          EXIT /repf/;
        IFEND;
      IFEND;
      file_open := status.normal;

{ Have the permanent file replaced with the local file.

      rhp$mli_replace_permanent_file (permanent_file_name, user_id,
            cycle_number, file_passwords, local_file_info, conversion, status);
    END /repf/;

{ We must close a B56 file in ring 3 in order to override the file attributes.

    IF conversion = syc$64_bit_binary_to_56_bit THEN
      rhp$close_b56_file (local_file_info, local_status);
    ELSE
      fsp$close_file (local_file_info.file_identifier, local_status);
    IFEND;
    IF copy_required THEN
      amp$return (scratch_fn, local_status);
    IFEND;
    file_open := FALSE;

  PROCEND rhp$replace;

?? TITLE := '          prepare_file_attributes' ??
?? EJECT ??

  PROCEDURE prepare_file_attributes
    (    file: fst$file_reference;
         conversion: syt$data_conversions;
         op_type: pf_op_types;
     VAR open_attributes: rht$file_cycle_attribute;
     VAR copy_required: boolean;
     VAR status: ost$status);

    VAR
      lf,
      ef,
      cd: boolean,
      device_class: rmt$device_class,
      device_assigned: boolean,
      fattr: array [1 .. 4] of amt$get_item;

    status.normal := TRUE;
    copy_required := FALSE;

    open_attributes [1].selector := fsc$record_type;
    open_attributes [1].record_type := amc$variable;
    open_attributes [2].selector := fsc$file_organization;
    open_attributes [2].file_organization := amc$sequential;
    open_attributes [3].selector := fsc$block_type;
    open_attributes [3].block_type := amc$system_specified;

{ copy only ascii coded files

    IF conversion < first_binary_conversion THEN

    /cfc/
      BEGIN
        rmp$get_device_class (file, device_assigned, device_class, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        fattr [1].key := amc$block_type;
        fattr [2].key := amc$open_position;
        fattr [3].key := amc$file_organization;
        fattr [4].key := amc$record_type;
        amp$get_file_attributes (file, fattr, lf, ef, cd, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF fattr [2].open_position <> amc$open_at_boi THEN
          IF op_type = pf_get THEN
            copy_required := TRUE;
            EXIT /cfc/;
          ELSE

{ op_type = pf_rep, return bad status

            osp$set_status_abnormal (rhc$remote_host_id,
                  rhe$open_position_conflict, '', status);
            osp$append_status_file (osc$status_parameter_delimiter, file,
                  status);
            RETURN;
          IFEND;
        IFEND;
        IF device_class <> rmc$mass_storage_device THEN
          copy_required := TRUE;
          EXIT /cfc/;
        IFEND;
        IF fattr [1].block_type <> amc$system_specified THEN
          copy_required := TRUE;
          EXIT /cfc/;
        IFEND;
        IF (fattr [3].file_organization <> amc$sequential) AND
              (fattr [3].file_organization <> amc$byte_addressable) THEN
          copy_required := TRUE;
          EXIT /cfc/;
        IFEND;
        IF fattr [4].record_type <> amc$variable THEN
          copy_required := TRUE;
          EXIT /cfc/;
        IFEND;
      END /cfc/;
    ELSE
      open_attributes [1].record_type := amc$undefined;
    IFEND;

  PROCEND prepare_file_attributes;

MODEND rhm$permanent_file_get_replace;
*DECK DECK=RHM$PERMANENT_FILE_MEMORY_LINK EXPAND=TRUE
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE  Remote Host :' ??
MODULE rhm$permanent_file_memory_link ALIAS 'rhmpml';

?? NEWTITLE := '        Global Type Declarations' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc oss$job_paged_literal
*copyc osv$170_os_type
*copyc rhc$constants
*copyc rhd$nos_ve_types
*copyc rhd$condition_codes
*copyc rht$attachment_option
*copyc rht$file_cycle_attribute
*copyc osc$processor_defined_registers
*copyc ost$caller_identifier
*copyc syp$memory_link_data_conversion
*copyc amp$set_segment_eoi
*copyc amp$set_segment_position
*copyc amp$fetch_access_information
*copyc i#move

?? TITLE := '        External Procedures Referenced By This Module' ??
?? SET (LIST := ON) ??
?? EJECT ??

*copyc amp$get_segment_pointer
*copyc fsp$close_file
*copyc fsp$open_file
*copyc i#compare
*copyc jmp$get_job_attributes
*copyc pmp$long_term_wait
*copyc pmp$establish_condition_handler
*copyc pmp$continue_to_cause
*copyc rhp$get_link_user_descriptor
*copyc rhp$set_status_abnormal
*copyc mlp$sign_on
*copyc mlp$add_sender
*copyc mlp$send_message
*copyc mlp$receive_message
*copyc mlp$sign_off
*copyc mlp$delete_sender
*copyc mmp$set_access_selections
*copyc osp$set_status_abnormal
*copyc osv$task_private_heap
*copyc osp$set_status_from_condition

?? TITLE := '        Type Declarations and Variables Global Within This Module'
        ??
?? SET (LIST := ON) ??
?? EJECT ??

  TYPE
    rht$mem_link_status = set of mlt$status;

{
{  The following variable defines the value to be used as the signal parameter
{    on all (c180 remote host) mli send & receive requests.
{    (rhinput, rhoutq8, get, replace)
{

  VAR
    rhv$signal: [XDCL, STATIC, #GATE] mlt$signal := NIL,

{  The following variable is used to remember the unique application name
{    generated by mlp$sign_on for use in all other mli requests during
{    c180 remote host pf (get/replace) processing.  Note that this variable
{    must reside in task private.
{

    rhv$application_name: [STATIC] mlt$application_name := mlc$null_name,

{ Other varaibles global within this module.

    pj_identifier: integer,
    sign_on_status_ptr: ^ost$status := NIL,
    link_user_descriptor: rht$link_user_descriptor;

?? TITLE := '        Memory_Link_Sign_On' ??
?? SET (LIST := ON) ??
?? EJECT ??

{
{ MEMORY_LINK_SIGN_ON
{
{      The purpose of this procedure is to sign on to the memory link.
{
{               MEMORY_LINK_SIGN_ON (STATUS)
{
{ STATUS: (output) This parameter returns the status of the sign_on.
{

  PROCEDURE memory_link_sign_on
    (VAR status: ost$status);


{ Sign on to the memory link.

    IF sign_on_status_ptr = NIL THEN
      ALLOCATE sign_on_status_ptr IN osv$task_private_heap^;
    IFEND;

    REPEAT
      mlp$sign_on (mlc$null_name, 0, rhv$application_name,
            sign_on_status_ptr^);
      IF NOT sign_on_status_ptr^.normal THEN
        CASE sign_on_status_ptr^.condition OF
        = mlc$ant_full, mlc$busy_interlock, mlc$pool_buffer_not_avail =
          pmp$long_term_wait (1000, 1000);
        ELSE
          status := sign_on_status_ptr^;
          rhp$set_status_abnormal (status);
          RETURN;
        CASEND;
      IFEND;
    UNTIL sign_on_status_ptr^.normal OR (sign_on_status_ptr^.condition =
          mlc$max_signons_this_appl);

  PROCEND memory_link_sign_on;

?? TITLE := '        Memory_Link_Sign_Off' ??
?? SET (LIST := ON) ??
?? EJECT ??

{
{ MEMORY_LINK_SIGN_OFF
{
{     The purpose of this procedure is to sign off the memory link.
{
{           MEMORY_LINK_SIGN_OFF (SIGN_OFF_STATUS)
{
{ SIGN_OFF_STATUS: (output) This parameter gives the status of the sign off.
{

  PROCEDURE memory_link_sign_off
    (VAR sign_off_status: ost$status);

    VAR
      off_status: ost$status,
      delete_sender_status: ost$status;

{ Sign off the memory link.

    REPEAT
      mlp$delete_sender (rhv$application_name, pj_identifier,
            delete_sender_status);
    UNTIL delete_sender_status.normal OR (delete_sender_status.condition <>
          mlc$busy_interlock);
    IF sign_on_status_ptr^.normal THEN
      REPEAT
        mlp$sign_off (rhv$application_name, off_status);
      UNTIL off_status.normal OR (off_status.condition <> mlc$busy_interlock);
    IFEND;

  PROCEND memory_link_sign_off;

?? TITLE := '        Convert_Ascii88_To_Ascii812' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ CONVERT_ASCII88_TO_ASCII812
{
{       The purpose of this procedure is to convert an 8/8 ascii string to
{ an A170 8/12 ascii string.
{
{       CONVERT_ASCII88_TO_ASCII812 (ASCII88_STRING,ASCII812_STRING
{              ,CONVERSION_STATUS)
{
{ ASCII88_STRING: (input) This parameter contains the 8/8 ascii string which
{                 is to be converted.
{
{ ASCII812_STRING: (output) This parameter contains the 8/12 ascii string
{                  which is the result of the conversion.
{
{ CONVERSION_STATUS: (output) This parameter indicates the success or failure
{                    of the conversion.  If the output string is not large
{                    enough to complete the conversion of the entire input
{                    string then a status of non_fatal_error will be returned
{                    otherwise the conversion will be successful.  In either
{                    case, conversion of as much of the string as is possible
{                    will be performed.
{

  PROCEDURE convert_ascii88_to_ascii812
    (    ascii88_string: string ( * );
     VAR ascii812_string: array [ * ] of rht$c180_ascii812_word;
     VAR conversion_status: rht$status);

    VAR
      ascii88_string_length: 0 .. 256,
      ascii812_string_lbound: integer,
      ascii812_string_ubound: integer,
      words_required: 0 .. 55,
      last_word#: integer,
      chars_in_last_word: 1 .. 5,
      word#: integer,
      ascii88_char#: 0 .. 256,
      ascii812_char#: 2 .. 5;

    ascii88_string_length := STRLENGTH (ascii88_string);
    ascii812_string_lbound := LOWERBOUND (ascii812_string);
    ascii812_string_ubound := UPPERBOUND (ascii812_string);
    words_required := (ascii88_string_length + 4) DIV 5;
    IF (ascii812_string_ubound - ascii812_string_lbound + 1) <
          words_required THEN
      last_word# := ascii812_string_ubound;
      chars_in_last_word := 5;
      conversion_status := non_fatal_error;
    ELSE
      last_word# := ascii812_string_lbound + words_required - 1;
      chars_in_last_word := ascii88_string_length - (words_required - 1) * 5;
      conversion_status := successful;
    IFEND;
    ascii88_char# := 0;
    FOR word# := ascii812_string_lbound TO last_word# - 1 DO
      ascii88_char# := ascii88_char# + 1;
      ascii812_string [word#].ascii812_char1.filler := 0;
      ascii812_string [word#].ascii812_char1.ascii88_char :=
            ascii88_string (ascii88_char#);
      FOR ascii812_char# := 2 TO 5 DO
        ascii88_char# := ascii88_char# + 1;
        ascii812_string [word#].ascii812_char2_5 [ascii812_char#].filler := 0;
        ascii812_string [word#].ascii812_char2_5 [ascii812_char#].
              ascii88_char := ascii88_string (ascii88_char#);
      FOREND;
    FOREND;
    ascii88_char# := ascii88_char# + 1;
    ascii812_string [last_word#].ascii812_char1.filler := 0;
    ascii812_string [last_word#].ascii812_char1.ascii88_char :=
          ascii88_string (ascii88_char#);
    FOR ascii812_char# := 2 TO chars_in_last_word DO
      ascii88_char# := ascii88_char# + 1;
      ascii812_string [last_word#].ascii812_char2_5 [ascii812_char#].filler :=
            0;
      ascii812_string [last_word#].ascii812_char2_5 [ascii812_char#].
            ascii88_char := ascii88_string (ascii88_char#);
    FOREND;

  PROCEND convert_ascii88_to_ascii812;

?? TITLE := '        Convert_Ascii812_to_Ascii88' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ CONVERT_ASCII812_TO_ASCII88
{
{       The purpose of this procedure is to convert an A170 8/12 ascii string
{ to an 8/8 ascii string.
{
{       CONVERT_ASCII812_TO_ASCII88 (ASCII812_STRING, ASCII88_STRING,
{              CONVERSION_STATUS)
{
{ ASCII812_STRING: (input) This parameter contains the 8/12 ascii string which
{                 is to be converted.
{
{ ASCII88_STRING: (output) This parameter contains the 8/8 ascii string which
{                  is the result of the conversion.
{
{ CONVERSION_STATUS: (output) This parameter indicates the success or failure
{                    of the conversion.  If the output string is not large
{                    enough to complete the conversion of the entire input
{                    string then a status of non_fatal_error will be returned
{                    otherwise the conversion will be successful.  In either
{                    case, conversion of as much of the string as is possible
{                    will be performed.
{

  PROCEDURE convert_ascii812_to_ascii88
    (    ascii812_string: array [ * ] of rht$c180_ascii812_word;
     VAR ascii88_string: string ( * );
     VAR conversion_status: rht$status);

    VAR
      ascii812_string_lbound: integer,
      ascii812_string_ubound: integer,
      ascii812_string_length: integer,
      ascii88_string_length: 0 .. 256,
      last_word#: integer,
      chars_in_last_word: 1 .. 5,
      word#: integer,
      ascii88_char#: 0 .. 256,
      ascii812_char#: 2 .. 5;

    ascii812_string_lbound := LOWERBOUND (ascii812_string);
    ascii812_string_ubound := UPPERBOUND (ascii812_string);
    ascii812_string_length := ascii812_string_ubound - ascii812_string_lbound +
          1;
    ascii88_string_length := STRLENGTH (ascii88_string);
    IF ascii812_string_length * 5 > ascii88_string_length THEN
      last_word# := ascii812_string_lbound + (ascii88_string_length + 4) DIV
            5 - 1;
      chars_in_last_word := ascii88_string_length -
            ((ascii88_string_length + 4) DIV 5 - 1) * 5;
      conversion_status := non_fatal_error;
    ELSE
      last_word# := ascii812_string_ubound;
      chars_in_last_word := 5;
      conversion_status := successful;
    IFEND;
    ascii88_char# := 0;
    FOR word# := ascii812_string_lbound TO last_word# - 1 DO
      ascii88_char# := ascii88_char# + 1;
      ascii88_string (ascii88_char#) := ascii812_string [word#].ascii812_char1.
            ascii88_char;
      FOR ascii812_char# := 2 TO 5 DO
        ascii88_char# := ascii88_char# + 1;
        ascii88_string (ascii88_char#) := ascii812_string [word#].
              ascii812_char2_5 [ascii812_char#].ascii88_char;
      FOREND;
    FOREND;
    ascii88_char# := ascii88_char# + 1;
    ascii88_string (ascii88_char#) := ascii812_string [last_word#].
          ascii812_char1.ascii88_char;
    FOR ascii812_char# := 2 TO chars_in_last_word DO
      ascii88_char# := ascii88_char# + 1;
      ascii88_string (ascii88_char#) := ascii812_string [last_word#].
            ascii812_char2_5 [ascii812_char#].ascii88_char;
    FOREND;

  PROCEND convert_ascii812_to_ascii88;

?? TITLE := '        Send_PJ_Function_Request' ??
?? SET (LIST := ON) ??
?? EJECT ??


{ SEND_PJ_FUNCTION_REQUEST
{
{        The purpose of this procedure is to transmit a partner job function
{ request to the partner job function processor and receive the results of
{ the processing of the requested function.
{
{        SEND_PJ_FUNCTION_REQUEST (PJ_FUNCTION,
{          PJ_IDENTIFIER,STATUS)
{
{ PJ_FUNCTION: (input) This parameter specifies the partner job function to
{              be performed.
{
{ PJ_IDENTIFIER: (input/output) This parameter is used to specify the partner
{                job identifier.  PJ_IDENTIFIER is returned (output) from a
{                submit_pj function.  PJ_IDENTIFIER must be supplied (input)
{                by the user for a status_pj pj_function.
{
{ STATUS: (output) This parameter indicates the status of sending the partner
{         job function request or the condition of the partner job.
{

  PROCEDURE send_pj_function_request
    (    pj_function: rht$pj_functions;
     VAR pj_identifier: integer;
     VAR status: ost$status);

    CONST
      submit_pj = rhc$submit_pj,
      status_pj = rhc$status_pj,
      zero_receive_index = 0, { index for receive any pending message }
      time_out_limit = 100;

    VAR
      local_status: ost$status,
      conversion_status: rht$status,
      partner_job_info: record
        case info_type: (identifier, validation) of
        = identifier =
          job_identifier: ALIGNED [0 MOD 8] integer,
        = validation =
          job_validation: record
            user_name: array [1 .. 2] of rht$c180_ascii812_word,
            password: array [1 .. 7] of rht$c180_ascii812_word,
            family_name: array [1 .. 2] of rht$c180_ascii812_word,
            charge_number: array [1 .. 7] of rht$c180_ascii812_word,
            project_number: array [1 .. 7] of rht$c180_ascii812_word,
            original_user_name: array [1 .. 2] of rht$c180_ascii812_word,
            original_family_name: array [1 .. 2] of rht$c180_ascii812_word,
            original_charge_number: array [1 .. 7] of rht$c180_ascii812_word,
            original_project_number: array [1 .. 7] of rht$c180_ascii812_word,
          recend,
        casend,
      recend,
      get_attribute_p: ^jmt$job_attribute_results,
      time_count: 0 .. (time_out_limit + 1),
      arbitrary_info: mlt$arbitrary_info,
      message_length: mlt$message_length,
      sender_application_name: mlt$application_name,
      destination_name: [STATIC, READ, oss$job_paged_literal] rht$mli_application_name :=
            [c180_id, [0, rhc$partner_job_processor, 0]],
      msg_status: ost$status,
      string_length: integer;


{ Add application name.

    REPEAT
      mlp$add_sender (rhv$application_name, destination_name.application_name,
            status);
      IF NOT status.normal THEN
        CASE status.condition OF
        = mlc$busy_interlock, mlc$dup_permits_ignored =
        ELSE
          osp$set_status_abnormal (rhc$remote_host_id,
                rhe$unable_to_communicate, '', status);
          RETURN;
        CASEND;
      IFEND;
    UNTIL status.normal OR (status.condition <> mlc$busy_interlock);


    CASE pj_function OF

{ Initialize parameters required to have a partner job execute
{ on the 170 side.

    = submit_pj =
      rhp$get_link_user_descriptor (link_user_descriptor, status);
      IF status.normal THEN
        convert_ascii88_to_ascii812 (link_user_descriptor.user (1, 9),
              partner_job_info.job_validation.user_name, conversion_status);
        convert_ascii88_to_ascii812 (link_user_descriptor.password (1, 31),
              partner_job_info.job_validation.password, conversion_status);
        convert_ascii88_to_ascii812 (link_user_descriptor.family (1, 9),
              partner_job_info.job_validation.family_name, conversion_status);
        convert_ascii88_to_ascii812 (link_user_descriptor.charge (1, 31),
              partner_job_info.job_validation.charge_number,
              conversion_status);
        convert_ascii88_to_ascii812 (link_user_descriptor.project (1, 31),
              partner_job_info.job_validation.project_number,
              conversion_status);
        PUSH get_attribute_p: [1 .. 4];
        get_attribute_p^ [1].key := jmc$login_family;
        get_attribute_p^ [2].key := jmc$login_user;
        get_attribute_p^ [3].key := jmc$login_account;
        get_attribute_p^ [4].key := jmc$login_project;
        jmp$get_job_attributes (get_attribute_p, status);

        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ We also need to convert the original login USER, FAMILY, ACCOUNT, and
{ PROJECT.

        convert_ascii88_to_ascii812 (get_attribute_p^ [2].login_user (1, 9),
              partner_job_info.job_validation.original_user_name,
              conversion_status);
        convert_ascii88_to_ascii812 (get_attribute_p^ [1].login_family (1, 9),
              partner_job_info.job_validation.original_family_name,
              conversion_status);
        convert_ascii88_to_ascii812 (get_attribute_p^ [3].
              login_account (1, 31), partner_job_info.job_validation.
              original_charge_number, conversion_status);
        convert_ascii88_to_ascii812 (get_attribute_p^ [4].
              login_project (1, 31), partner_job_info.job_validation.
              original_project_number, conversion_status);
        message_length := #SIZE (partner_job_info.job_validation);
        arbitrary_info := submit_pj;
      ELSE
        RETURN;
      IFEND;

{ Initialize parameters required to get the status of
{ the partner job executing on the 170 side.

    = status_pj =
      partner_job_info.job_identifier := pj_identifier;
      message_length := #SIZE (partner_job_info.job_identifier);
      arbitrary_info := status_pj;
    CASEND;
    time_count := 0;

  /communication_block/
    WHILE TRUE DO

{ Send function and parameters to the 170 function processor.

      REPEAT
        IF pj_function = submit_pj THEN
          mlp$send_message (rhv$application_name, arbitrary_info, rhv$signal,
                ^partner_job_info.job_validation, message_length,
                destination_name.application_name, status);
        ELSE {  pj function is status_pj }
          mlp$send_message (rhv$application_name, arbitrary_info, rhv$signal,
                ^partner_job_info.job_identifier, message_length,
                destination_name.application_name, status);
        IFEND;
        IF NOT status.normal THEN
          CASE status.condition OF
          = mlc$busy_interlock, mlc$pool_buffer_not_avail,
                mlc$receive_list_full, mlc$prior_msg_not_received =
            pmp$long_term_wait (1000, 1000);
          ELSE
            osp$set_status_abnormal (rhc$remote_host_id,
                  rhe$unable_to_communicate, '', status);
            EXIT /communication_block/;
          CASEND;
        IFEND;
      UNTIL status.normal;

{ Get status of request back from 170 function processor.

      REPEAT
        mlp$receive_message (rhv$application_name, arbitrary_info,
              rhv$signal, ^partner_job_info.job_identifier,
              message_length, #SIZE (partner_job_info.job_identifier),
              zero_receive_index, sender_application_name, status);
        IF NOT status.normal THEN
          CASE status.condition OF
          = mlc$busy_interlock, mlc$receive_list_index_invalid =
            pmp$long_term_wait (1000, 1000);
          ELSE
            osp$set_status_abnormal (rhc$remote_host_id,
                  rhe$unable_to_communicate, '', status);
            EXIT /communication_block/;
          CASEND;
        IFEND;
      UNTIL status.normal;
      status.condition := arbitrary_info;
      IF message_length <> 0 THEN
        pj_identifier := partner_job_info.job_identifier;
        EXIT /communication_block/;
      IFEND;
      IF status.condition = rhe$no_ml_free_entries_found THEN
        time_count := time_count + 1;
        IF time_count < time_out_limit THEN
          arbitrary_info := submit_pj;
          message_length := #SIZE (partner_job_info.job_identifier);
          pmp$long_term_wait (1000, 1000);
          CYCLE /communication_block/;
        ELSE
          osp$set_status_abnormal (rhc$remote_host_id,
                rhe$no_ml_free_entries_found, '', status);
          EXIT /communication_block/;
        IFEND;
      ELSE
        EXIT /communication_block/;
      IFEND;
    WHILEND /communication_block/;

{ Delete application name.

    REPEAT
      mlp$delete_sender (rhv$application_name,
            destination_name.application_name, local_status);
    UNTIL local_status.normal OR (local_status.condition <>
          mlc$busy_interlock);

  PROCEND send_pj_function_request;

?? TITLE := '        [XDCL, #GATE] rhp$mli_get_permanent_file' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc rhh$mli_get_permanent_file

  PROCEDURE [XDCL, #GATE] rhp$mli_get_permanent_file
    (    permanent_file_name: array [1 .. 7] of rht$c180_ascii812_word;
         user_id: array [1 .. 2] of rht$c180_ascii812_word;
         cycle_number: array [1 .. 1] of rht$c180_ascii812_word;
         file_password: array [1 .. 2] of array [1 .. 2] of
          rht$c180_ascii812_word;
         local_file_info: rht$local_file_info;
         conversion: syt$data_conversions;
     VAR status: ost$status);

?? TITLE := '         Handle_Break' ??
?? SET (LIST := ON) ??
?? EJECT ??

    PROCEDURE handle_break
      (    cond: pmt$condition;
           cd: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR ch_status: ost$status);

      VAR
        ignore_status,
        ost: ost$status;


      ch_status.normal := TRUE;

      IF break_active THEN
        RETURN;
      IFEND;
      break_active := TRUE;

{ Send request to 170 to see if partner job is still running in
{ order for the job to be cleared from the memory link table.

      IF partner_job_started THEN
        send_pj_function_request (status_pj, pj_identifier, ignore_status);
      IFEND;

{ sign off mli

      IF signed_on THEN
        mlp$sign_off (rhv$application_name, local_status);
      IFEND;

{ exit the PF operation with abnormal status


      IF cond.selector = ifc$interactive_condition THEN
        CASE cond.interactive_condition OF
        = ifc$pause_break =
          osp$set_status_abnormal (rhc$remote_host_id,
                rhe$pause_break_received, '', status);
        = ifc$terminate_break =
          osp$set_status_abnormal (rhc$remote_host_id,
                rhe$terminal_break_occurred, '', status);
        ELSE
          osp$set_status_abnormal (rhc$remote_host_id,
                rhe$terminal_connection_broken, '', status);
        CASEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
        osp$set_status_from_condition ('OS', cond, sa, status, ost);
        IF NOT ost.normal THEN
          status := ost;
        IFEND;
      IFEND;

      EXIT rhp$mli_get_permanent_file;

    PROCEND handle_break;

?? TITLE := '        [XDCL, #GATE] rhp$mli_get_permanent_file' ??
?? SET (LIST := ON) ??
?? EJECT ??

    CONST
      submit_pj = rhc$submit_pj,
      get_pf = rhc$get_pf,
      normal = rhc$ok,
      time_limit_for_170_signon = 30,
      time_out_limit = 500,
      moi = rhc$middle_of_information,
      eoi = rhc$end_of_information,
      status_pj = rhc$status_pj,
      job_found = rhc$job_found,
      job_not_found = rhc$job_not_found;

    TYPE
      get_communication_states = (send_info, fetch_size, fetch_info, check_job,
            out);

    VAR
      message_length: mlt$message_length,
      cml: integer,
      ba: integer,
      pba: ^0 .. 0ff(16),
      sp: amt$segment_pointer,
      file_length: integer,
      arbitrary_info: mlt$arbitrary_info,
      sender_application_name: mlt$application_name,
      current_state: get_communication_states,
      send_return_state: get_communication_states,
      time_count: 0 .. time_out_limit + 1,
      check_return_state: get_communication_states,
      permanent_file_info: record
        permanent_file_name: array [1 .. 7] of rht$c180_ascii812_word,
        user_id: array [1 .. 2] of rht$c180_ascii812_word,
        cycle_number: array [1 .. 1] of rht$c180_ascii812_word,
        file_password: array [1 .. 2] of array [1 .. 2] of
              rht$c180_ascii812_word,
      recend,
      be_file_id: string (9),
      ml_stat: ost$status,
      conversion_status: rht$status,
      local_180_file_info: rht$local_file_info,
      data_buffer: rht$file_data_buffer,
      sign_off_status: ost$status,
      cond_desc: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
            [pmc$condition_combination, $pmt$condition_combination
            [ifc$interactive_condition, pmc$user_defined_condition]],
      estab_handler: pmt$established_handler,
      local_status: ost$status,
      signed_on,
      break_active: boolean,
      cnv_info: syt$conversion_info,
      bufptr: ^cell,
      partner_job_started: boolean,
      msg_status: ost$status;


{ Initialize.

    signed_on := FALSE;
    break_active := FALSE;
    partner_job_started := FALSE;
    pmp$establish_condition_handler (cond_desc, ^handle_break, ^estab_handler,
          local_status);

{ Sign on to the memory link.

    status.normal := TRUE;
    memory_link_sign_on (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    signed_on := TRUE;

{ Send request to execute partner job.

    send_pj_function_request (submit_pj, pj_identifier, status);
    IF status.normal THEN
      REPEAT
        partner_job_started := TRUE;
        mlp$add_sender (rhv$application_name, pj_identifier, status);
      UNTIL status.normal OR (status.condition <> mlc$busy_interlock);
    IFEND;
    IF NOT status.normal THEN
      memory_link_sign_off (sign_off_status);
      RETURN;
    IFEND;

{ Initialize to send permanent file information.

    local_180_file_info := local_file_info;
    permanent_file_info.permanent_file_name := permanent_file_name;
    permanent_file_info.user_id := user_id;
    convert_ascii812_to_ascii88 (user_id, be_file_id, conversion_status);
    IF be_file_id = '         ' THEN
      convert_ascii88_to_ascii812 (link_user_descriptor.user,
            permanent_file_info.user_id, conversion_status);
    IFEND;
    permanent_file_info.cycle_number := cycle_number;
    permanent_file_info.file_password [1] := file_password [1];
    permanent_file_info.file_password [2] := file_password [2];
    current_state := send_info;
    send_return_state := fetch_info;

  /communication_loop/
    REPEAT
      CASE current_state OF

{ Send permanent file information.

      = send_info =
        time_count := 0;
        message_length := #SIZE (permanent_file_info);
        arbitrary_info := get_pf;
        REPEAT
          mlp$send_message (rhv$application_name, arbitrary_info, rhv$signal,
                ^permanent_file_info, message_length, pj_identifier, status);
          IF NOT status.normal THEN
            CASE status.condition OF
            = mlc$busy_interlock, mlc$pool_buffer_not_avail =
              pmp$long_term_wait (1000, 1000);
            = mlc$receiver_not_signed_on, mlc$sender_not_permitted =
              time_count := time_count + 1;

{ Check status of partner job every 30 seconds to see if it is in the NOS
{ executing queue.  If it is, then try to send the message again, otherwise
{ abort the GET_FILE command.

              IF time_count > time_limit_for_170_signon THEN
                current_state := check_job;
                check_return_state := send_info;
                CYCLE /communication_loop/;
              ELSE
                pmp$long_term_wait (1000, 1000);
              IFEND;
            = mlc$receiver_name_syntax_error =
              osp$set_status_abnormal (rhc$remote_host_id,
                    rhe$partner_job_not_executing, '', status);
              EXIT /communication_loop/;
            ELSE
              rhp$set_status_abnormal (status);
              EXIT /communication_loop/;
            CASEND;
          IFEND;
        UNTIL status.normal;
        current_state := fetch_size;
      = fetch_size =
        time_count := 0;
        REPEAT
          mlp$receive_message (rhv$application_name, arbitrary_info,
                rhv$signal, ^file_length, message_length, #SIZE (file_length),
                0, sender_application_name, status);
          IF NOT status.normal THEN
            CASE status.condition OF
            = mlc$busy_interlock =
              pmp$long_term_wait (1000, 1000);
            = mlc$receive_list_index_invalid =
              time_count := time_count + 1;
              IF time_count > time_out_limit THEN
                current_state := check_job;
                check_return_state := fetch_size;
                CYCLE /communication_loop/;
              ELSE
                pmp$long_term_wait (1000, 1000);
              IFEND;
            ELSE
              rhp$set_status_abnormal (status);
              EXIT /communication_loop/;
            CASEND;
          IFEND;
        UNTIL status.normal;

        IF arbitrary_info <> moi THEN
          osp$set_status_abnormal (rhc$remote_host_id, arbitrary_info, '',
                status);
          EXIT /communication_loop/;
        IFEND;

        amp$get_segment_pointer (local_file_info.file_identifier,
              amc$cell_pointer, sp, status);
        IF NOT status.normal THEN
          EXIT /communication_loop/;
        IFEND;

{ Call set access selections to have file in sequential mode with free behind pages.

        mmp$set_access_selections (sp.cell_pointer, mmc$as_sequential, status);
        IF NOT status.normal THEN
          EXIT /communication_loop/;
        IFEND;

        ba := file_length * 64 * 8;
        pba := #ADDRESS (1, #SEGMENT (sp.cell_pointer),
              ba + #OFFSET (sp.cell_pointer));

{!!!        pba^ := 0;

        amp$get_segment_pointer (local_file_info.file_identifier,
              amc$sequence_pointer, sp, status);
        IF NOT status.normal THEN
          EXIT /communication_loop/;
        IFEND;

        cnv_info.conversion_type := conversion;
        cnv_info.file_pointer := sp.sequence_pointer;
        cnv_info.save_area := 0;
        RESET cnv_info.file_pointer;
        bufptr := ^data_buffer;

        current_state := fetch_info;

{ Copy data from 170 permanent file to 180 local file.

      = fetch_info =
        REPEAT
          time_count := 0;

{ Get data from permanent file.  The IF test is done outside of the
{ repeat loop to save on performance - it will only get executed once.

          IF osv$170_os_type = osc$ot7_dual_state_nos_be THEN
            REPEAT
              mlp$receive_message (rhv$application_name, arbitrary_info,
                    rhv$signal, bufptr, message_length, #SIZE (data_buffer), 0,
                    sender_application_name, status);
              IF NOT status.normal THEN
                CASE status.condition OF
                = mlc$busy_interlock =
                  pmp$long_term_wait (1000, 1000);
                = mlc$receive_list_index_invalid =
                  time_count := time_count + 1;
                  IF time_count > time_out_limit THEN
                    current_state := check_job;
                    check_return_state := fetch_info;
                    CYCLE /communication_loop/;
                  ELSE
                    pmp$long_term_wait (1000, 1000);
                  IFEND;
                ELSE
                  rhp$set_status_abnormal (status);
                  EXIT /communication_loop/;
                CASEND;
              IFEND;
              UNTIL status.normal;
          ELSE { this is the case of NOS dual state running. }
            REPEAT
              mlp$receive_message (rhv$application_name, arbitrary_info,
                    rhv$signal, bufptr, message_length,
                    #SIZE (data_buffer) - #SIZE (integer), 0,
                    sender_application_name, status);
              IF NOT status.normal THEN
                CASE status.condition OF
                = mlc$busy_interlock =
                  pmp$long_term_wait (1000, 1000);
                = mlc$receive_list_index_invalid =
                  time_count := time_count + 1;
                  IF time_count > time_out_limit THEN
                    current_state := check_job;
                    check_return_state := fetch_info;
                    CYCLE /communication_loop/;
                  ELSE
                    pmp$long_term_wait (1000, 1000);
                  IFEND;
                ELSE
                  rhp$set_status_abnormal (status);
                  EXIT /communication_loop/;
                CASEND;
              IFEND;
            UNTIL status.normal;
          IFEND;

{ Write data to local file.

          CASE arbitrary_info OF
          = moi, eoi =

            IF message_length > 0 THEN
              cml := message_length DIV 8;
              syp$memory_link_data_conversion (^cnv_info, bufptr, cml);
            IFEND;

            IF arbitrary_info = eoi THEN
              sp.sequence_pointer := cnv_info.file_pointer;
              amp$set_segment_eoi (local_file_info.file_identifier, sp,
                    status);
              IF NOT status.normal THEN
                EXIT /communication_loop/;
              IFEND;

            IFEND;
          ELSE
            osp$set_status_abnormal (rhc$remote_host_id, arbitrary_info, '',
                  status);
            EXIT /communication_loop/;
          CASEND;
        UNTIL arbitrary_info = eoi;
        EXIT /communication_loop/;

{ Check status of partner job.

      = check_job =
        send_pj_function_request (status_pj, pj_identifier, status);
        CASE status.condition OF
        = job_found =
          current_state := check_return_state;
        = job_not_found =
          osp$set_status_abnormal (rhc$remote_host_id,
                rhe$partner_job_not_executing, ' ', status);
          EXIT /communication_loop/;
        ELSE
          rhp$set_status_abnormal (status);
          EXIT /communication_loop/;
        CASEND;
      CASEND;
    UNTIL FALSE; {communication_loop end

{ Sign off the memory link.

    memory_link_sign_off (sign_off_status);

  PROCEND rhp$mli_get_permanent_file;

?? TITLE := '        [XDCL, #GATE] rhp$mli_replace_permanent_file' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc rhh$mli_replace_permanent_file

  PROCEDURE [XDCL, #GATE] rhp$mli_replace_permanent_file
    (    permanent_file_name: array [1 .. 7] of rht$c180_ascii812_word;
         user_id: array [1 .. 2] of rht$c180_ascii812_word;
         cycle_number: array [1 .. 1] of rht$c180_ascii812_word;
         file_password: array [1 .. 2] of array [1 .. 2] of
          rht$c180_ascii812_word;
         local_file_info: rht$local_file_info;
         conversion: syt$data_conversions;
     VAR status: ost$status);

?? TITLE := '         Handle_Break' ??
?? SET (LIST := ON) ??
?? EJECT ??

    PROCEDURE handle_break
      (    cond: pmt$condition;
           cd: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR ch_status: ost$status);

      VAR
        partner_status: ost$status;

      ch_status.normal := TRUE;

      IF break_active THEN
        RETURN;
      IFEND;
      break_active := TRUE;

{ tell partner job to terminate

      IF pj_active THEN
        send_pj_function_request (status_pj, pj_identifier, partner_status);
        IF (partner_status.condition = job_found) THEN
          time_count := 0;

        /tpj/
          WHILE TRUE DO
            mlp$send_message (rhv$application_name, rhe$rh_system_error,
                  rhv$signal, ^permanent_file_info, zero_message_length,
                  pj_identifier, status);
            IF NOT status.normal THEN
              CASE status.condition OF
              = mlc$busy_interlock, mlc$pool_buffer_not_avail =
              = mlc$prior_msg_not_received =
                time_count := time_count + 1;
                IF time_count > time_out_limit THEN
                  EXIT /tpj/;
                IFEND;
              ELSE
                EXIT /tpj/;
              CASEND;
              pmp$long_term_wait (1000, 1000);
              CYCLE /tpj/;
            ELSE
              EXIT /tpj/;
            IFEND;
          WHILEND /tpj/;
        IFEND;
      IFEND;

{ sign off mli

      IF signed_on THEN
        mlp$sign_off (rhv$application_name, local_status);
      IFEND;

{ exit the PF operation with abnormal status


      IF cond.selector = ifc$interactive_condition THEN
        CASE cond.interactive_condition OF
        = ifc$pause_break =
          osp$set_status_abnormal (rhc$remote_host_id,
                rhe$pause_break_received, '', status);
        = ifc$terminate_break =
          osp$set_status_abnormal (rhc$remote_host_id,
                rhe$terminal_break_occurred, '', status);
        ELSE
          osp$set_status_abnormal (rhc$remote_host_id,
                rhe$terminal_connection_broken, '', status);
        CASEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, local_status);
        osp$set_status_from_condition ('OS', cond, sa, status, local_status);
        IF NOT local_status.normal THEN
          status := local_status;
        IFEND;
      IFEND;

      EXIT rhp$mli_replace_permanent_file;

    PROCEND handle_break;

?? TITLE := '        [XDCL, #GATE] rhp$mli_replace_permanent_file' ??

    CONST
      normal = rhc$ok,
      replace_pf = rhc$replace_pf,
      time_limit_for_170_signon = 30,
      time_out_limit = 500,
      receive_any_msg_receive_index = 0,
      eoi = rhc$end_of_information,
      ok = rhc$ok,
      zero_message_length = 0,
      status_pj = rhc$status_pj,
      job_found = rhc$job_found,
      job_not_found = rhc$job_not_found,
      bfzw = (mlc$max_message_length DIV (64 * 8)) * 64,
      submit_pj = rhc$submit_pj;

    TYPE
      name_types = (full, abbreviated),
      replace_communication_states = (send_pf_info, get_pf_data, send_pf_data,
            fetch_replace_condition, send_condition, check_job);

    VAR
      sender_application_name: mlt$application_name,
      permanent_file_info: record
        permanent_file_name: array [1 .. 7] of rht$c180_ascii812_word,
        user_id: array [1 .. 2] of rht$c180_ascii812_word,
        cycle_number: array [1 .. 1] of rht$c180_ascii812_word,
        file_password: array [1 .. 2] of array [1 .. 2] of
              rht$c180_ascii812_word,
      recend,
      local_180_file_info: rht$local_file_info,
      current_state: replace_communication_states,
      time_count: 0 .. time_out_limit + 1,
      alternate_user_number: string (9),
      alternate_password: string (9),
      check_return_state: replace_communication_states,
      data_buffer: rht$file_data_buffer,
      message_length: mlt$message_length,
      arbitrary_info: mlt$arbitrary_info,
      conversion_status: rht$status,
      rh_file_position: rht$file_position,
      cond_desc: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
            [pmc$condition_combination, $pmt$condition_combination
            [ifc$interactive_condition, pmc$user_defined_condition]],
      estab_handler: pmt$established_handler,
      local_status: ost$status,
      save_status: ost$status,
      signed_on,
      pj_active,
      break_active: boolean,
      cml: integer,
      mli_failure: boolean,
      sp: amt$segment_pointer,
      cnv_info: syt$conversion_info,
      bufptr: ^cell,
      cap: ^array [1 .. * ] of cell,
      total: integer,
      fai: array [1 .. 1] of amt$access_info,
      msg_status: ost$status,
      sign_off_status: ost$status;


{ Initialize.

    pj_active := FALSE;
    signed_on := FALSE;
    break_active := FALSE;
    mli_failure := FALSE;
    pmp$establish_condition_handler (cond_desc, ^handle_break, ^estab_handler,
          local_status);

{ Sign on to the memory link.

    status.normal := TRUE;
    save_status.normal := TRUE;
    memory_link_sign_on (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    signed_on := TRUE;

{ Send request to submit partner job.

    send_pj_function_request (submit_pj, pj_identifier, status);
    IF status.normal THEN
      pj_active := TRUE;
      REPEAT
        mlp$add_sender (rhv$application_name, pj_identifier, status);
      UNTIL status.normal OR (status.condition <> mlc$busy_interlock);
    IFEND;
    IF NOT status.normal THEN
      memory_link_sign_off (sign_off_status);
      RETURN;
    IFEND;

{ Initialize to send permanent file information.

    local_180_file_info := local_file_info;
    permanent_file_info.permanent_file_name := permanent_file_name;
    permanent_file_info.user_id := user_id;
    permanent_file_info.cycle_number := cycle_number;

{ Check if alternate user number the same.

    convert_ascii812_to_ascii88 (user_id, alternate_user_number,
          conversion_status);
    IF osv$170_os_type = osc$ot7_dual_state_nos_be THEN

{Use the user_id from SETLA command if the NOSBE user did
{not specify a user_id.

      IF alternate_user_number = '         ' THEN
        convert_ascii88_to_ascii812 (link_user_descriptor.user,
              permanent_file_info.user_id, conversion_status);
      IFEND;
    ELSE
      IF link_user_descriptor.user = alternate_user_number THEN
        convert_ascii812_to_ascii88 (file_password [1], alternate_password,
              conversion_status);
        IF (link_user_descriptor.password = alternate_password) OR
              (alternate_password = '       ') THEN
          convert_ascii88_to_ascii812 ('       ', permanent_file_info.user_id,
                conversion_status);
        IFEND;
      IFEND;
    IFEND;
    permanent_file_info.file_password [1] := file_password [1];
    permanent_file_info.file_password [2] := file_password [2];
    current_state := send_pf_info;

  /communication_loop/
    REPEAT
      CASE current_state OF

{ Send information on permanent file to be replaced.

      = send_pf_info =
        time_count := 0;
        message_length := #SIZE (permanent_file_info);
        arbitrary_info := replace_pf;
        REPEAT
          mlp$send_message (rhv$application_name, arbitrary_info, rhv$signal,
                ^permanent_file_info, message_length, pj_identifier, status);
          IF NOT status.normal THEN
            CASE status.condition OF
            = mlc$busy_interlock, mlc$pool_buffer_not_avail =
              pmp$long_term_wait (1000, 1000);
            = mlc$receiver_not_signed_on, mlc$sender_not_permitted =
              time_count := time_count + 1;

{ Check status of partner job every 30 seconds to see if it is in the NOS
{ executing queue.  If it is, then try to send the message again, otherwise
{ abort the REPLACE_FILE command.

              IF time_count > time_limit_for_170_signon THEN
                current_state := check_job;
                check_return_state := send_pf_info;
                CYCLE /communication_loop/;
              ELSE
                pmp$long_term_wait (1000, 1000);
              IFEND;
            = mlc$receiver_name_syntax_error =
              osp$set_status_abnormal (rhc$remote_host_id,
                    rhe$partner_job_not_executing, '', status);
              EXIT /communication_loop/;
            ELSE
              mli_failure := TRUE;
              EXIT /communication_loop/;
            CASEND;
          IFEND;
        UNTIL status.normal;

        amp$get_segment_pointer (local_file_info.file_identifier,
              amc$sequence_pointer, sp, status);
        IF NOT status.normal THEN
          arbitrary_info := rhe$file_io_error;
          save_status := status;
          current_state := send_condition;
          CYCLE /communication_loop/;
        IFEND;

        IF conversion = syc$no_conversion THEN
          RESET sp.sequence_pointer;
          fai [1].key := amc$eoi_byte_address;
          amp$fetch_access_information (local_file_info.file_identifier, fai,
                status);
          IF NOT status.normal THEN
            arbitrary_info := rhe$file_io_error;
            save_status := status;
            current_state := send_condition;
            CYCLE /communication_loop/;
          IFEND;
          total := fai [1].eoi_byte_address;
        ELSE
          cnv_info.save_area := 0;
          cnv_info.conversion_type := conversion;
          cnv_info.file_pointer := sp.sequence_pointer;
          RESET cnv_info.file_pointer;
          bufptr := ^data_buffer;
        IFEND;

        rh_file_position := rhc$middle_of_information;

        current_state := get_pf_data;

{ Get data from the local file.

      = get_pf_data =

        IF conversion = syc$no_conversion THEN
          IF total < bfzw * 8 THEN
            cml := total;
          ELSE
            cml := bfzw * 8;
          IFEND;
          IF cml > 0 THEN
            NEXT cap: [1 .. cml] IN sp.sequence_pointer;
            bufptr := cap;
          ELSE
            IF total <> 0 THEN

{ something went wrong

              osp$set_status_abnormal (rhc$remote_host_id, rhe$rh_system_error,
                    'file length', status);
              arbitrary_info := rhe$file_io_error;
              save_status := status;
              current_state := send_condition;
              CYCLE /communication_loop/;
            IFEND;
          IFEND;
          total := total - cml;
          IF total <= 0 THEN
            rh_file_position := eoi;
            amp$set_segment_position (local_file_info.file_identifier, sp,
                  local_status);
          IFEND;
          message_length := ((cml + 7) DIV 8) * 8;
        ELSE
          cml := bfzw;
          syp$memory_link_data_conversion (^cnv_info, bufptr, cml);
          IF cml <> bfzw THEN
            rh_file_position := eoi;
            sp.sequence_pointer := cnv_info.file_pointer;
            amp$set_segment_position (local_file_info.file_identifier, sp,
                  local_status);
          IFEND;
          message_length := cml * 8;
        IFEND;

        current_state := send_pf_data;

{ Send data from local file to the partner job.

      = send_pf_data =
        time_count := 0;
        REPEAT
          arbitrary_info := rh_file_position;
          mlp$send_message (rhv$application_name, arbitrary_info, rhv$signal,
                bufptr, message_length, pj_identifier, status);
          IF status.normal THEN
            IF arbitrary_info = eoi THEN
              current_state := fetch_replace_condition;
            ELSE
              current_state := get_pf_data;
            IFEND;
          ELSE
            CASE status.condition OF
            = mlc$busy_interlock, mlc$pool_buffer_not_avail =
              pmp$long_term_wait (1000, 1000);
            = mlc$prior_msg_not_received, mlc$receive_list_full =
              time_count := time_count + 1;
              IF time_count > time_out_limit THEN
                current_state := check_job;
                check_return_state := send_pf_data;
                CYCLE /communication_loop/;
              ELSE
                pmp$long_term_wait (1000, 1000);
              IFEND;
            ELSE
              mli_failure := TRUE;
              EXIT /communication_loop/;
            CASEND;
          IFEND;
        UNTIL status.normal;

{ Terminate on EOI and check status of the replace.

      = fetch_replace_condition =
        time_count := 0;
        REPEAT
          mlp$receive_message (rhv$application_name, arbitrary_info,
                rhv$signal, ^data_buffer, message_length,
                #SIZE (data_buffer) - #SIZE (integer),
                receive_any_msg_receive_index, sender_application_name,
                status);
          IF status.normal THEN
            IF arbitrary_info <> ok THEN
              osp$set_status_abnormal (rhc$remote_host_id, arbitrary_info, ' ',
                    status);
            IFEND;
            EXIT /communication_loop/;
          ELSE
            CASE status.condition OF
            = mlc$busy_interlock =
              pmp$long_term_wait (1000, 1000);
            = mlc$receive_list_index_invalid =
              time_count := time_count + 1;
              IF time_count > time_out_limit THEN
                current_state := check_job;
                check_return_state := fetch_replace_condition;
                CYCLE /communication_loop/;
              ELSE
                pmp$long_term_wait (1000, 1000);
              IFEND;
            ELSE
              mli_failure := TRUE;
              EXIT /communication_loop/;
            CASEND;
          IFEND;
        UNTIL status.normal;

{ Tell partner job error occurred trying to get data from the local file.

      = send_condition =
        time_count := 0;
        REPEAT
          mlp$send_message (rhv$application_name, arbitrary_info, rhv$signal,
                ^permanent_file_info, zero_message_length, pj_identifier,
                status);
          IF NOT status.normal THEN
            CASE status.condition OF
            = mlc$busy_interlock, mlc$pool_buffer_not_avail =
              pmp$long_term_wait (1000, 1000);
            = mlc$prior_msg_not_received =
              time_count := time_count + 1;
              IF time_count > time_out_limit THEN
                current_state := check_job;
                check_return_state := send_condition;
                CYCLE /communication_loop/;
              ELSE
                pmp$long_term_wait (1000, 1000);
              IFEND;
            ELSE
              mli_failure := TRUE;
              EXIT /communication_loop/;
            CASEND;
          IFEND;
        UNTIL status.normal;
        IF NOT save_status.normal THEN
          status := save_status;
        ELSE
          osp$set_status_abnormal (rhc$remote_host_id, arbitrary_info, '',
                status);
        IFEND;
        EXIT /communication_loop/;

{ Check status of partner job.

      = check_job =
        send_pj_function_request (status_pj, pj_identifier, status);
        CASE status.condition OF
        = job_found =
          current_state := check_return_state;
        = job_not_found =
          osp$set_status_abnormal (rhc$remote_host_id,
                rhe$partner_job_not_executing, '', status);
          EXIT /communication_loop/;
        ELSE
          rhp$set_status_abnormal (status);
          EXIT /communication_loop/;
        CASEND;
      CASEND;
    UNTIL FALSE;

    IF mli_failure THEN

{ try to terminate the 170 job

      time_count := 0;

    /tpj/
      WHILE TRUE DO
        mlp$send_message (rhv$application_name, rhe$rh_system_error,
              rhv$signal, ^permanent_file_info, zero_message_length,
              pj_identifier, local_status);
        IF NOT status.normal THEN
          CASE status.condition OF
          = mlc$busy_interlock, mlc$pool_buffer_not_avail =
          = mlc$prior_msg_not_received =
            time_count := time_count + 1;
            IF time_count > 30 THEN
              rhp$set_status_abnormal (status);
              EXIT /tpj/;
            IFEND;
          ELSE
            rhp$set_status_abnormal (status);
            EXIT /tpj/;
          CASEND;
          pmp$long_term_wait (1000, 1000);
          CYCLE /tpj/;
        ELSE
          EXIT /tpj/;
        IFEND;
      WHILEND /tpj/;
    IFEND;

{ Sign off the memory link.

    memory_link_sign_off (sign_off_status);

  PROCEND rhp$mli_replace_permanent_file;
?? TITLE := '        [XDCL, #GATE] rhp$open_b56_file', EJECT ??

{
{ RHP$OPEN_B56_FILE
{
{  This procedure is called by rhp$get/rhp$replace to open a B56 file.
{
{           RHP$OPEN_B56_FILE (FILE_ATTACHMENT_OPTIONS,
{               LOCAL_FILE_INFO, STATUS);
{
{  FILE_ATTACHMENT_OPTIONS: (input) This parameter contains the access
{      requirements to get the file.
{
{  LOCAL_FILE_INFO: (input, output) This parameter contains all the local
{      file information.
{
{  STATUS: (output) This parameter specifies the status returned to the
{      calling procedure.
{

  PROCEDURE [XDCL, #GATE] rhp$open_b56_file
    (    file: fst$file_reference;
         file_attachment_options: rht$attachment_option;
     VAR local_file_info: rht$local_file_info;
     VAR status: ost$status);

    VAR
      attribute_override: rht$file_cycle_attribute,
      caller_id: ost$caller_identifier,
      required_open_attributes: array [1 .. 1] of fst$file_cycle_attribute;

{ Set up the required open attributes and the override attributes for a B56
{ file.

    #CALLER_ID (caller_id);
    required_open_attributes [1].selector := fsc$ring_attributes;
    required_open_attributes [1].ring_attributes.r1 := caller_id.ring;
    required_open_attributes [1].ring_attributes.r2 := caller_id.ring;
    required_open_attributes [1].ring_attributes.r3 := caller_id.ring;
    attribute_override [1].selector := fsc$record_type;
    attribute_override [1].record_type := amc$undefined;
    attribute_override [2].selector := fsc$file_organization;
    attribute_override [2].file_organization := amc$sequential;
    attribute_override [3].selector := fsc$block_type;
    attribute_override [3].block_type := amc$system_specified;
    fsp$open_file (file, amc$record, ^file_attachment_options, NIL,
          ^required_open_attributes, NIL, ^attribute_override,
          local_file_info.file_identifier, status);

  PROCEND rhp$open_b56_file;
?? TITLE := '        [XDCL, #GATE] rhp$close_b56_file', EJECT ??

{
{ RHP$CLOSE_B56_FILE
{
{  This procedure is called by rhp$get/rhp$replace to close a B56 file.
{
{           RHP$CLOSE_B56_FILE (LOCAL_FILE_INFO, STATUS)
{
{  LOCAL_FILE_INFO: (input) This parameter contains all the local
{      file information.
{
{  STATUS: (output) This parameter specifies the status returned to the
{      calling procedure.
{

  PROCEDURE [XDCL, #GATE] rhp$close_b56_file
    (    local_file_info: rht$local_file_info;
     VAR status: ost$status);

    fsp$close_file (local_file_info.file_identifier, status);

  PROCEND rhp$close_b56_file;

MODEND rhm$permanent_file_memory_link;
*DECK DECK=RHM$QUEUE_FILE_EXEC EXPAND=TRUE
*copyc osd$default_pragmats
?? NEWTITLE := '170 NOS/VE REMOTE HOST' ??
MODULE rhm$queue_file_exec ALIAS 'rhmqep';

{
{     The purpose of this module is to allow for sharing of
{ execution time between three independent processes.  These
{ processes include transfer of input queue files from A170
{ to C180, receiving and routing of output queue files from
{ C180 to A170 and partner job exec which submits permanent
{ file transfer jobs for a C180 task.
{     The remote_host_queue_file_exec_pgm monitors the three
{ processes' status and provides for a graceful degredation
{ of the remote host in the event any of the processes
{ detects a fatal error.
{

?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??
?? SET (LIST := OFF) ??
?? EJECT ??

*copyc rht$function_status
*copyc rhc$constants

?? TITLE := 'EXTERNAL PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc rhp$log_status
*copyc rhp$170_mli_link
*copyc rhp$wait
*copyc rhp$qf_170_transmit_exec
*copyc rhp$qf_170_receive_exec
*copyc FZMARK
*copyc LGZCLOS
*copyc LGZGET
*copyc LGZOPEN
*copyc ZUTPS2D
?? TITLE := 'VARIABLES GLOBAL TO THIS MODULE' ??
?? SET (LIST := ON) ??
?? EJECT ??

  PROCEDURE [XREF] initmli (i: integer);

  PROCEDURE [XREF] paws (i: integer);

  PROCEDURE [XREF] qfwait;
{
{  The following variable defines the value of the signal option parameter
{    for all mli send/receive requests issued by the irhf c170 queue file
{routines.
{
    CONST max_lid_words = 10;

    TYPE
      lid_record = record
        case i: integer of
        = 1 =
          dc_string: array [1 .. 1] of packed array [0 .. 9] of 0 .. 3f(16),
        = 2 =
          lid_rec: packed record
            lids: 0 .. 3fffffff(16),
            filler: 0 .. 3fffffff(16),
          recend,
        casend,
      recend;


  VAR
    signal_record: [STATIC] mlt$signal_record := [0, * , * ],
    short_paws: integer := 0,
    rhv$signal: [XDCL, STATIC] mlt$signal := ^signal_record;

?? TITLE := 'REMOTE_HOST_QUEUE_FILE_EXEC_PGM' ??
?? EJECT ??

  PROGRAM remote_host_queue_file_exec_pgm;

    TYPE
      index_list_element = record
        forward_ptr: 1 .. 2,
        backward_ptr: 1 .. 2,
      recend,
      work_set = set of 1 .. 2;

    VAR
      application_names: [STATIC] array [1 .. 2] of rht$mli_application_names
        := [[[a170_id, [rhc$send_input_to_remote, 0]], [a170_id,
        [rhc$receive_remote_input, 0]]], [[a170_id, [rhc$receive_remote_output,
        0]], [a170_id, [rhc$send_output_to_remote, 0]]]],
      exec_list: [STATIC] array [1 .. 2] of rht$irhf_exec_types :=
        [transmit_exec, receive_exec],
      index_list: [STATIC] array [1 .. 2] of index_list_element := [[2, 2], [1,
        1]],
      exec_index: [STATIC] 1 .. 2 := 2,
      work_avail: [STATIC] work_set := $work_set [1, 2],
      exec_count: [STATIC] array [1 .. 2] of integer := [REP 2 of 0],
      lid_list: rht$lid_list,
      exec_status: [STATIC] array [1 .. 2] of rht$exec_status := [REP 2 of
        beginning];


    initmli (0);
    mli_link (on, application_names [1]);
    mli_link (on, application_names [2]);
    read_alt_lid_list (lid_list);
    log_status (dayfile_log_and_display, 'NOSVE IRHF PROCESSING');

    WHILE TRUE DO
      exec_index := index_list [exec_index].forward_ptr;
      IF exec_count [exec_index] = 0 THEN
        CASE exec_list [exec_index] OF
        = transmit_exec =
          rhp$queue_file_transmit_exec (application_names [1], exec_status
                [1], ^lid_list);
        = receive_exec =
          rhp$queue_file_receive_exec (application_names [2], exec_status [2]);
        CASEND;
        exec_count [exec_index] := 10;
      ELSE

{ execute an idle task once for every ten executes of an active task

        exec_count [exec_index] := exec_count [exec_index] - 1;
      IFEND;
      IF exec_status [exec_index] = middle THEN
        work_avail := work_avail + $work_set [exec_index];
        exec_count [exec_index] := 0; {force execute}
        short_paws := 0;
      ELSE
        work_avail := work_avail - $work_set [exec_index];
      IFEND;

      IF exec_status [exec_index] = unrecoverable_error THEN
        exec_status [exec_index] := middle;
      IFEND;

      IF work_avail = $work_set [] THEN

{ no qf work to do - go idle (rollout/recall)

        IF short_paws < 2 THEN
          paws (20); {20*30ms=.6 seconds}
          short_paws := short_paws + 1;
        ELSE
          qfwait; {rollout}
          short_paws := 0;
        IFEND;
        exec_count [1] := 0; {force all execute}
        exec_count [2] := 0; {force all execute}
      IFEND;
    WHILEND;

  PROCEND remote_host_queue_file_exec_pgm;

  PROCEDURE read_alt_lid_list (VAR lid_list: rht$lid_list);

    CONST lid_skeleton_file = 'lidlist';

    VAR lid_file: file,
        lid_conv_buffer: lid_record,
        lid: string (3),
        lid_word: string (10),
        mark: file_mark,
        lid_word_index : integer,
        lid_index: integer,
        num_of_chars_read: integer,
        dc_string_word_index: integer,
        dc_string_char_index: 0 .. 9,
        source_index: ost$string_index,
        eol: boolean;

{  Initialize lid table list to 0.
     FOR lid_index := 1 TO 10 DO
       lid_list [lid_index].lid1 := 0;
       lid_list [lid_index].lid2 := 0;
     FOREND;

     lid_word := ' ';

{  Open the lid file and read the LIDs into the table.

     LG#OPEN (lid_file, lid_skeleton_file, old#, input#, first#);
     lid_word_index := 1;
     lid_index := 1;

{  Each lid will be read in one at a time and a string of 9 characters
{  will be created.  This string will be converted to a dc string in
{  order to form the alternate lid list needed to route jobs from NOS
{  on one mainframe to NOS/VE on another one.

     /read_loop/
     REPEAT
       LG#GET (lid_file, num_of_chars_read, lid);
       F#MARK (lid_file, mark);
       IF mark = data# THEN
         lid_word (lid_index, 3) := lid;
         IF lid_index < 7 THEN
           lid_index := lid_index + 3;
         ELSE
           lid_index := 1;
           dc_string_word_index := 1;
           dc_string_char_index := 0;
           source_index := 1;
           eol := FALSE;
           { convert and insert the first 5 characters into the lid list.
           utp$convert_string_to_dc_string (utc$ascii64,
               lid_conv_buffer.dc_string, dc_string_word_index,
               dc_string_char_index, lid_word(1,5), source_index, eol);
           lid_list [lid_word_index].lid1 := lid_conv_buffer.lid_rec.lids;
           dc_string_word_index := 1;
           dc_string_char_index := 0;
           source_index := 1;
           eol := FALSE;
           { convert and insert the last 5 characters into the lid list.
           utp$convert_string_to_dc_string (utc$ascii64,
               lid_conv_buffer.dc_string, dc_string_word_index,
               dc_string_char_index, lid_word(6,5), source_index, eol);
           lid_list [lid_word_index].lid2 := lid_conv_buffer.lid_rec.lids;
           lid_word_index := lid_word_index + 1;
           IF lid_word_index > 10 THEN
             log_status (dayfile_log, 'Lid list is full, see documentation');
             EXIT /read_loop/;
           IFEND;
           lid_word := ' ';
         IFEND;
       IFEND;
     UNTIL mark <> data#;  { read_loop }
     IF lid_index <> 1 THEN  { check for lids not creating a full word. }
       dc_string_word_index := 1;
       dc_string_char_index := 0;
       source_index := 1;
       eol := FALSE;
       { convert and insert the first 5 characters into the lid list.
       utp$convert_string_to_dc_string (utc$ascii64,
           lid_conv_buffer.dc_string, dc_string_word_index,
           dc_string_char_index, lid_word(1,5), source_index, eol);
       lid_list [lid_word_index].lid1 := lid_conv_buffer.lid_rec.lids;
       dc_string_word_index := 1;
       dc_string_char_index := 0;
       source_index := 1;
       eol := FALSE;
       { convert and insert the last 5 characters into the lid list.
       utp$convert_string_to_dc_string (utc$ascii64,
           lid_conv_buffer.dc_string, dc_string_word_index,
           dc_string_char_index, lid_word(6,5), source_index, eol);
       lid_list [lid_word_index].lid2 := lid_conv_buffer.lid_rec.lids;
     IFEND;
     LG#CLOSE (lid_file, first#);
  PROCEND read_alt_lid_list;

MODEND rhm$queue_file_exec;
*DECK DECK=RHM$QUEUE_FILE_RECEIVE_EXEC EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := '170 NOS/VE REMOTE HOST' ??
MODULE rhmqfr;

{ Select target 170 operating system.
*IF ($string($name(wev$target_operating_system))='NOS')

  ?VAR rhv$prif_for_nosbe: boolean := FALSE ?;
*ELSE

  ?VAR rhv$prif_for_nosbe: boolean := TRUE ?;
*IFEND

?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc RHT$FUNCTION_STATUS
*copyc RHC$CONSTANTS

?? TITLE := 'EXTERNAL PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc BIZOPEN
*copyc BIZCLOS
*copyc BIZPUT
*copyc BIZWEOR
*copyc FZMARK
*copyc LGZCLOS
*copyc LGZGET
*copyc LGZOPEN
*copyc LGZPUT
*copyc RHP$LOG_STATUS
*copyc RHV$SIGNAL
*copyc RHP$RECEIVE_MESSAGE_OS
*copyc RHP$SEND_MESSAGE_OS
*copyc RHP$OPEN_FILE
*copyc RHP$CLOSE_FILE
*copyc RHP$ROUTE_FILE
*copyc RHP$RETURN_FILE

  PROCEDURE [XREF] qfrec (lfn: integer;
        an170: integer;
        an180: integer;
    VAR fet_pointer: ^n7t$fet;
    VAR qfrec_status: integer);
*copyc ZUTPDNS
*copyc ZUTPRTF
*copyc ZUTPS2D
*copyc ZUTPSDN

?? SET (LIST := ON) ??
?? TITLE := 'RHP$QUEUE_FILE_RECEIVE_EXEC' ??
?? EJECT ??

{ RHP$QUEUE_FILE_RECEIVE_EXEC
{
{     This procedure is responsible for receiving queue files from
{ its partner application.  This includes the responsibilities of
{ protocol maintenance, reception control, and final file disposition.
{
{     RHP$QUEUE_FILE_RECEIVE_EXEC (APPLICATION_NAMES,EXEC_STATUS)
{
{ APPLICATION_NAMES: (input) This parameter contains the sending and
{     receiving application names required for MLI communications.
{
{ EXEC_STATUS: (output) This parameter indicates to the calling procedure
{     the processing status of the executive.  The following status
{     values may be returned:
{               beginning
{               middle
{               unrecoverable_error

  PROCEDURE [XDCL] rhp$queue_file_receive_exec ALIAS 'rhmqfr' (VAR
    application_names: rht$mli_application_names;
    VAR exec_status: rht$exec_status);


    TYPE
      receive_states = (fetch_control, fetch_data, dispose, respond),
      substitute_info_type = RECORD
        job_info: string(8),
        user_name: string(9),
        password: string(31),
        family_name: string(9),
        charge_number: string(31),
        project_number: string(31),
        original_user_name: string(9),
        original_family_name: string(9),
        original_charge_number: string(31),
        original_project_number: string(31),
      recend;

    CONST
      completed = rhc$completed,
      boi = rhc$beginning_of_information,
      moi = rhc$middle_of_information,
      eoi = rhc$end_of_information,
      err = rhc$error,
      errmsg_file_name = 'rhermsg',
      errmsg_dc_file_name = 22100522152307(8),
      rhreclf_file_name = 'rhreclf',
      rhreclf_dc_file_name = 22102205031406(8); { RHRECLF }

    VAR
      errmsg_local_file_info: [STATIC] rht$local_file_info,
      errmsg: [STATIC] packed ARRAY [0..35] of
              0 .. 03fffffff(16) :=
              [ 0061000000(8), 0000000000(8),  {1}
                0060000000(8), 0000000000(8),  {0}
                0040005500(8), 5501050122(8),  { --ER}
                0122011701(8), 2200550055(8),  {ROR--}
                0040004001(8), 1601170123(8),  {  NOS}
                0040012401(8), 2201010103(8),  { TRAC}
                0113004001(8), 1401110115(8),  {K LIM}
                0111012400(8), 4001220105(8),  {IT RE}
                0101010301(8), 1001050104(8),  {ACHED}
                0040004001(8), 2401100105(8),  {  THE}
                0040010601(8), 1101140105(8),  { FILE}
                0040012701(8), 0101230040(8),  { WAS }
                0124011700(8), 4001140101(8),  {TO LA}
                0122010701(8), 0500400124(8),  {RGE T}
                0117040001(8), 0201050040(8),  {O BE }
                0120012201(8), 1101160124(8),  {PRINT}
                0105010400(8), 5600000000(8),  {ED.}
                0062000000(8), 0000000000(8) ],  {2}
      fet_pointer: ^n7t$fet,
      errmsg_file: file,
      quanta_work_completed: boolean,
      receive_state: [STATIC] receive_states := fetch_control,
      sender_name: mlt$application_name,
      status: ost$status,
      receive_status: [STATIC] (ok, error) := ok,
      route_status: rht$function_status,
      abnormal_mli_stat_message: string(33),
      string_length: 1 .. 33,
      local_file_info: [STATIC] rht$local_file_info,
      queue_file_info: [STATIC] rht$queue_file_info,
      message_info: [STATIC] rht$mli_message_info, { kludge for CYBIL bug }
      new_print_file: file,
      detailed_status,
      qfrec_status: integer;

?? TITLE := 'RHP$PRIF_SKELETON_PARAMETERS' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ RHP$PRIF_SKELETON_PARAMETERS
{
{        The purpose of this procedure is to substitute keywords with their
{  actual value and return a new card with the substituted values.
{
{       RHP$PRIF_SKELETON_PARAMETERS (SUBSTITUTE_INFO, SKELETON_CARD,
{             SUBSTITUTE_CARD);
{
{ SUBSTITUTE_INFO: (Input) This parameter contains all accounting
{
{ SKELETON_CARD: (Input) This parameter contains one skeleton record from
{       the skeleton file (Created at deadstart time with the name PRACCNT).
{
{ SUBSTITUTE_CARD: (Output) This parameter returns a copy of the skeleton
{       record with values substituted for the keywords.
{

    PROCEDURE rhp$prif_skeleton_parameters (
       substitute_info: substitute_info_type;
       skeleton_card: string (140);
       VAR substitute_card: string (140));

? IF rhv$prif_for_nosbe = FALSE THEN
    TYPE

      valid_family_info_rec = packed record
        family_name: 0 .. 3ffffffffff(16),
        filler1: 0 .. 3f(16),
        reply_code: 0 .. 0fff(16),
      recend,

      perm_file_info_rec = packed record
        family_name: 0 .. 3ffffffffff(16),
        zero: 0 .. 3ffff(16),
        filler1: integer,
        user_name: 0 .. 3ffffffffff(16),
        filler2: 0 .. 3ffff(16),
      recend;


  PROCEDURE [XREF] rhpgpfp (VAR perm_file_info: perm_file_info_rec);

  PROCEDURE [XREF] rhpvfam (VAR valid_family_info: valid_family_info_rec);
?IFEND

    CONST
      max_string_length = 140,
      invalid_family = 7777(8),
      skel_job = 'JOB',
      skel_user = 'USER',
      skel_password = 'PASSWORD',
      skel_family = 'FAMILY',
      skel_charge = 'CHARGE',
      skel_project = 'PROJECT',
      skel_orig_user = 'ORGUSER',
      skel_orig_family = 'ORGFAMILY',
      skel_orig_charge = 'ORGCHARGE',
      skel_orig_project = 'ORGPROJECT';

    VAR
      keyword_sub: string (31),
      keyword_length: 0 .. 10,
      name_string: string (31),
      in_buff_lngth: integer,
      out_buff_lngth: integer,
      max_replacement_length: 1 .. 31,
? IF rhv$prif_for_nosbe = FALSE THEN
      perm_file_info: perm_file_info_rec,
      valid_family_info: valid_family_info_rec,
      dc_family_name: utt$dc_name,
      result_length: 0 .. 7,
? IFEND
      replacement_length: 1 .. 31;

?? TITLE := 'RHP$PRIF_SKELETON_PARAMETERS' ??
?? SET (LIST := ON) ??
?? EJECT ??
{ Replace keyword and copy to output buffer.  The parameter
{ SKELETON_CARD is the input buffer and SUBSTITUTE_CARD is
{ the output buffer.

    out_buff_lngth := 1;
    in_buff_lngth := 1;
    keyword_sub := ' ';
    substitute_card := ' ';
    /sub_keyword/
    REPEAT
      IF (skeleton_card (in_buff_lngth, 1) = '&') THEN

{  If skeleton card has an '&', then replace the value of the
{  attribute specified into the job template.
        IF (skeleton_card (in_buff_lngth+1, 3) = skel_job) THEN
          keyword_sub := substitute_info.job_info;
          max_replacement_length := 8;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 3;
        ELSEIF (skeleton_card (in_buff_lngth+1, 4) = skel_user) THEN

          keyword_sub := substitute_info.user_name;
          max_replacement_length := 9;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 4;
        ELSEIF (skeleton_card (in_buff_lngth+1, 8) = skel_password) THEN

          keyword_sub := substitute_info.password;
          max_replacement_length := 31;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 8;
        ELSEIF (skeleton_card (in_buff_lngth+1, 6) = skel_family) THEN

? IF rhv$prif_for_nosbe = FALSE THEN
          utp$convert_string_to_dc_name(substitute_info.family_name (1,7),
              dc_family_name);

{ Validate that the family exists on NOS.  If it does not then use
{ the default NOS family that the IRHF170 job runs under.

          valid_family_info.family_name := dc_family_name;
          valid_family_info.filler1 := 0;
          valid_family_info.reply_code := 0;
          rhpvfam (valid_family_info);
          IF valid_family_info.reply_code = invalid_family THEN

{ The family does not exist on NOS, get the default NOS family.

            rhpgpfp (perm_file_info); { get default family and user }
            utp$convert_dc_name_to_string (perm_file_info.family_name,
                keyword_sub (1,7), result_length);
          ELSE  { family was valid on NOS. }
            utp$convert_dc_name_to_string (dc_family_name,
                keyword_sub (1,7), result_length);
          IFEND;
          max_replacement_length := 7;
? ELSE
          keyword_sub := substitute_info.family_name;
          max_replacement_length := 9;
? IFEND
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 6;
        ELSEIF (skeleton_card (in_buff_lngth+1,6) = skel_charge) THEN

{ Use only login charge numbers that are alpha-numberic.
          create_valid_170_string (substitute_info.charge_number,
              keyword_sub);
? IF rhv$prif_for_nosbe = FALSE THEN
          IF substitute_info.charge_number = ' ' THEN
            keyword_sub := '*.';
          IFEND;
? IFEND
          max_replacement_length := 31;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 6;
        ELSEIF (skeleton_card (in_buff_lngth+1,7) = skel_project) THEN

{ Use only login project numbers that are alpha-numberic.
          create_valid_170_string (substitute_info.project_number,
              keyword_sub);
          max_replacement_length := 31;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 7;
        ELSEIF (skeleton_card (in_buff_lngth+1,7) = skel_orig_user) THEN

{ Use only login user names that are alpha-numberic.
          name_string (1,9) := substitute_info.original_user_name;
          create_valid_170_string (name_string, keyword_sub);
          max_replacement_length := 9;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 7;
        ELSEIF (skeleton_card (in_buff_lngth+1,9) = skel_orig_family) THEN

{ Use only login family names that are alpha-numberic.
          name_string (1,9) := substitute_info.original_family_name;
          create_valid_170_string (name_string, keyword_sub);
          max_replacement_length := 9;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 9;
        ELSEIF (skeleton_card (in_buff_lngth+1,9) = skel_orig_charge) THEN

{ Use only login charge numbers that are alpha-numberic.
          create_valid_170_string (substitute_info.original_charge_number,
              keyword_sub);
? IF rhv$prif_for_nosbe = FALSE THEN
          IF substitute_info.original_charge_number = ' ' THEN
            keyword_sub := '*.';
          IFEND;
? IFEND
          max_replacement_length := 31;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 9;
        ELSEIF (skeleton_card (in_buff_lngth+1,10) = skel_orig_project) THEN

{ Use only login project numbers that are alpha-numberic.
          create_valid_170_string (substitute_info.original_project_number,
              keyword_sub);
          max_replacement_length := 31;
          substitute_keyword (substitute_card, replacement_length,
              out_buff_lngth, max_replacement_length, keyword_sub);
          keyword_length := 10;
        ELSE  { the '&' is not followed by a defined keyword, leave it on the command line.
          substitute_card (out_buff_lngth, 1) := skeleton_card (in_buff_lngth, 1);
          replacement_length := 1;
          keyword_length := 0;

        IFEND;
        out_buff_lngth := out_buff_lngth + replacement_length;
        in_buff_lngth := in_buff_lngth + keyword_length + 1;
        keyword_sub := ' ';
      ELSE
        substitute_card (out_buff_lngth, 1) := skeleton_card (in_buff_lngth, 1);
        in_buff_lngth := in_buff_lngth + 1;
        out_buff_lngth := out_buff_lngth + 1;
      IFEND;
    UNTIL (out_buff_lngth > max_string_length) OR (in_buff_lngth > max_string_length); {sub_keyword}

    IF NOT (out_buff_lngth > max_string_length) THEN

{ Set the remaining parts of the command card to blank.
      substitute_card (out_buff_lngth, max_string_length - out_buff_lngth + 1)  := ' ';
    IFEND;

  PROCEND rhp$prif_skeleton_parameters;
?? TITLE := 'SUBSTITUTE_KEYWORD' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ SUBSTITUTE_KEYWORD
{
{        This procedure will substitute a given value for the keyword
{ in an output buffer.
{
{        SUBSTITUTE_KEYWORD (SUBSTITUTE_CARD, REPLACEMENT_LENGTH
{             OUT_BUFF_LNGTH, MAX_REPLACEMENT_LENGTH, KEYWORD_SUB)
{
{ SUBSTITUTE_CARD: (Output) This parameter returns a copy of the input buffer
{       with the keyword replaced.
{
{ REPLACEMENT_LENGTH (Output) This parameter returns the length of the
{       replacement string.
{
{ OUT_BUFF_LNGTH (Input) This parameter is the current size of the output buffer.
{
{ MAX_REPLACEMENT_LENGTH (Input) This parameter is the maximum length of the field
{       to be replaced.
{
{ KEYWORD_SUB: (Input) This parameter is what is replaced into the output
{       buffer.
{

  PROCEDURE substitute_keyword
       (VAR substitute_card: string (140);
       VAR replacement_length: 1 .. 31;
       out_buff_lngth: integer;
       max_replacement_length: 1 .. 31;
       keyword_sub: string(31));

    VAR index: 1 .. 31;

{ Calculate length of the replacement string.

      replacement_length := 1;
    /cal_replacement_lngth/
      FOR index := 1 to max_replacement_length DO
        IF keyword_sub (index, 1) <> ' ' THEN
          replacement_length := index;
        IFEND;
      FOREND /cal_replacement_lngth/;

{ Replace keyword and copy to output buffer.}

      substitute_card (out_buff_lngth, replacement_length) :=
          keyword_sub (1, replacement_length);

  PROCEND substitute_keyword;
?? OLDTITLE, NEWTITLE := 'PROCEDURE create_valid_170_string', EJECT ??

{ CREATE_VALID_170_STRING
{
{        This procedure will create a valid 170 string (delete all $ from
{ the passed parameter and put into the new string.  The only values that
{ will be changed are the charge number, project number, orignal user name,
{ original family name, original charge number, and original project number.
{
{        CREATE_VALID_170_STRING (KEYWORD_STRING, KEYWORD_SUB)
{
{ KEYWORD_STRING: (Input) This parameter is the value of the old string to be changed.
{
{ KEYWORD_SUB: (Output) This parameter is the value of the new string created.
{
  PROCEDURE create_valid_170_string (keyword_string: string (31);
      VAR keyword_sub: string (31));

    CONST max_keyword_string_size = 31;

    VAR keyword_sub_size,
        keyword_string_size: 1 .. max_keyword_string_size;

{ Use only strings that are alpha-numberic.
    keyword_sub := ' ';
    keyword_sub_size := 1;
    FOR keyword_string_size := 1 TO max_keyword_string_size DO
      IF ((keyword_string (keyword_string_size) >= 'A') AND
        (keyword_string (keyword_string_size) <= 'Z')) OR
        ((keyword_string (keyword_string_size) >= 'a') AND
        (keyword_string (keyword_string_size) <= 'z')) OR
        ((keyword_string (keyword_string_size) >= '0') AND
        (keyword_string (keyword_string_size) <= '9')) OR
? IF rhv$prif_for_nosbe THEN
        (keyword_string (keyword_string_size) = '=') OR
        (keyword_string (keyword_string_size) = ',') OR
        (keyword_string (keyword_string_size) = '.') OR
? IFEND
        (keyword_string (keyword_string_size) = '*') THEN
        keyword_sub (keyword_sub_size) := keyword_string (keyword_string_size);
        keyword_sub_size := keyword_sub_size + 1;
      IFEND;
    FOREND;

  PROCEND create_valid_170_string;

?? TITLE := 'RHP$CREATE_PRIF_JOB' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ RHP$CREATE_PRIF_JOB
{
{     This procedure will create a job to route a PRINT_FILE to an RBF terminal.
{
{        RHP$CREATE_PRIF_JOB;
{
{
  PROCEDURE rhp$create_prif_job;

    TYPE
      substitute_info_type = RECORD
        job_info: string(8),
        user_name: string(9),
        password: string(31),
        family_name: string(9),
        charge_number: string(31),
        project_number: string(31),
        original_user_name: string (9),
        original_family_name: string (9),
        original_charge_number: string (31),
        original_project_number: string (31),
      RECEND;

    CONST
      prif_skeleton_file_name = 'praccnt',
? IF rhv$prif_for_nosbe = TRUE THEN
      apr_command = 'APR(11)',
      nosbe_request_command = 'REQUEST,LFN,Q.',
? IFEND
      copy_command = 'COPY,INPUT,LFN.';

    VAR
      substitute_info: substitute_info_type,
      skeleton_file: file,
      skeleton_card: string(140),
      substitute_card: string(140),
      mark: file_mark,
      number_of_chars_read: integer,
      substitute_card_size: 0 .. 140,
      print_file: file,
      banner_string: string(8),
      banner_string_size,
      max_banner_string_size: 1 .. 8,
      repeat_message: string(6),
      repeat_message_size: integer,
      text_size: integer,
      route_command: string (255);

      banner_string := ' ';
      banner_string_size := 1;
      FOR max_banner_string_size := 1 TO 7 DO
        IF ((queue_file_info.a170.user_number_of_owner.a170_owner_user_num (max_banner_string_size)>='A') AND
            (queue_file_info.a170.user_number_of_owner.a170_owner_user_num (max_banner_string_size)<='Z')) OR
           ((queue_file_info.a170.user_number_of_owner.a170_owner_user_num (max_banner_string_size)>='a') AND
            (queue_file_info.a170.user_number_of_owner.a170_owner_user_num (max_banner_string_size)<='z')) OR
           ((queue_file_info.a170.user_number_of_owner.a170_owner_user_num (max_banner_string_size)>='0') AND
            (queue_file_info.a170.user_number_of_owner.a170_owner_user_num (max_banner_string_size)<='9')) OR
            (queue_file_info.a170.user_number_of_owner.a170_owner_user_num (max_banner_string_size)='*') THEN
          banner_string (banner_string_size) :=
              queue_file_info.a170.user_number_of_owner.a170_owner_user_num (max_banner_string_size);
          banner_string_size := banner_string_size + 1;
        IFEND;
      FOREND;
      banner_string (banner_string_size) := '.';
      substitute_info.job_info := banner_string;
      substitute_info.user_name := queue_file_info.a170.user_number_of_owner.
         a170_owner_user_num;
      substitute_info.family_name := queue_File_info.a170.family_name_of_creator.
         a170_creator_family_name;
      substitute_info.password := queue_file_info.a170.user_password;
      substitute_info.charge_number := queue_file_info.a170.user_charge_number;
      substitute_info.project_number := queue_file_info.a170.user_project_number;

{ The original login USER, FAMILY, CHARGE, and PROJECT needs to be saved also in case a
{ site wants to use them in their partner job template files when creating 170
{ partner jobs.
      substitute_info.original_user_name := queue_file_info.a170.original_user_name.
         a170_original_user_name;
      substitute_info.original_family_name := queue_File_info.a170.original_family_name.
         a170_original_family_name;
      substitute_info.original_charge_number := queue_file_info.a170.original_charge_number;
      substitute_info.original_project_number := queue_file_info.a170.original_project_number;
      lg#open (skeleton_file, prif_skeleton_file_name, old#, input#, first#);
      request_queue_device (rhreclf_dc_file_name);
      bi#open (print_file, rhreclf_file_name, new#, output#, first#);
      /generate_pj_commands/
      REPEAT
        skeleton_card := ' ';
        lg#get (skeleton_file, number_of_chars_read, skeleton_card);
        f#mark (skeleton_file, mark);
        IF (mark = data#) THEN
          rhp$prif_skeleton_parameters (substitute_info, skeleton_card,
             substitute_card);
          /calculate_card_length/
          FOR substitute_card_size := 140 DOWNTO 1 DO
            IF substitute_card (substitute_card_size,1) <> ' ' THEN
              EXIT /calculate_card_length/;
            IFEND;
          FOREND /calculate_card_length/;
          lg#put (print_file, substitute_card (1,substitute_card_size));
        IFEND;
      UNTIL mark <> data#;  { generate pj commands }
      lg#close (skeleton_file, first#);
? IF rhv$prif_for_nosbe = TRUE THEN
      lg#put(print_file, nosbe_request_command);
? IFEND
      lg#put (print_file, copy_command);
      route_command (1,10) := 'ROUTE,LFN,';
      IF queue_file_info.a170.repeat_count > 1 THEN
        STRINGREP (repeat_message, repeat_message_size,
            'REP=',queue_file_info.a170.repeat_count-1,',');
        route_command (11,repeat_message_size) := repeat_message(1,repeat_message_size);
        text_size := queue_file_info.a170.dual_state_routing_text_size;
        route_command (11+repeat_message_size,text_size) :=
           queue_file_info.a170.dual_state_routing_text;
        route_command (text_size+11+repeat_message_size,1) := '.';
        lg#put (print_file,
          route_command (1, text_size+11+repeat_message_size));
      ELSE
        route_command (11,queue_file_info.a170.dual_state_routing_text_size) :=
           queue_file_info.a170.dual_state_routing_text;
        route_command (queue_file_info.a170.dual_state_routing_text_size+11,1) := '.';
        lg#put (print_file,
            route_command (1, queue_file_info.a170.dual_state_routing_text_size+11));
      IFEND;
? IF rhv$prif_for_nosbe = TRUE THEN
      lg#put(print_file, apr_command);
? IFEND
      bi#weor (print_file);
      bi#close (print_file, asis#);
    PROCEND rhp$create_prif_job;
?? SET (LIST := ON) ??
?? TITLE := 'RHP$QUEUE_FILE_RECEIVE_EXEC' ??
?? EJECT ??

{ * * * * * * *   R E C E I V E   A   Q U E U E   F I L E   * * * * * * *

    quanta_work_completed := FALSE;
    REPEAT
      CASE receive_state OF

{ Fetch control information to receive a queue file.

      = fetch_control =
        message_info.message_area_length := #SIZE (queue_file_info.equalizer);
        message_info.message_area := ^queue_file_info.equalizer;
        rhp$receive_message_os (application_names.application.application_name,
          message_info.arbitrary_info, rhv$signal, message_info.message_area,
          message_info.message_length, message_info.message_area_length,
          0 { index for receive any pending msg }, sender_name, status);
        IF (status.normal) OR (status.condition=mlc$signal_failed_ignored) THEN
          CASE message_info.arbitrary_info OF
          = boi =
            IF (queue_file_info.a170.dual_state_routing_text_size <> 0) THEN
              { create a partner job to do PRINT_FILE with ROUTE control card. }
              rhp$create_prif_job;
            IFEND;
            local_file_info.fet.filename := rhreclf_dc_file_name;
            request_queue_device (rhreclf_dc_file_name);
            IF (queue_file_info.a170.dual_state_routing_text_size <> 0) THEN
              bi#open (new_print_file, rhreclf_file_name, old#, output#, asis#);
            ELSE
              rhp$open_file (local_file_info);
            IFEND;
            receive_state := fetch_data;
            exec_status := middle;
            log_status (dayfile_log_and_display, 'BEGIN XFER NOSVE OUTPUT');
          = moi, eoi, err =
            exec_status := beginning;
          ELSE
            exec_status := unrecoverable_error;
          CASEND;
        ELSE
          CASE status.condition OF
          = mlc$busy_interlock, mlc$receive_list_index_invalid =
            exec_status := beginning;
          = mlc$nosve_not_up =
            log_status (dayfile_log, '$loss of dual state environment');
            exec_status := unrecoverable_error;
          ELSE
            abnormal_mli_stat_message(1,29) := 'receive msg mli abnorm cond =';
            STRINGREP (abnormal_mli_stat_message (30,3), string_length, status.condition);
            log_status (dayfile_log_and_display, abnormal_mli_stat_message(1, 29 + string_length));
            exec_status := unrecoverable_error;
        CASEND;
        IFEND;
        quanta_work_completed := TRUE;

{ Fetch data from transmitter.

      = fetch_data =

{ Initialize the abnormal termination to be returned to be 0.

        fet_pointer^.abnormal_termination := 0;
        qfrec (local_file_info.fet.filename, application_names.application.
              application_name, 0, fet_pointer, qfrec_status);
? IF rhv$prif_for_nosbe = FALSE THEN
        IF fet_pointer^.abnormal_termination = 1 THEN

{ File could not be printed because of a NOS track limit was hit.

          receive_status := error;
          exec_status := middle;
          receive_state := dispose;
        ELSE
? IFEND
        CASE qfrec_status OF
        = moi =

{ temporarily exit to process other work

          receive_state := fetch_data;
          exec_status := middle;
          quanta_work_completed := TRUE;
        = eoi =

{ end of xfer

          receive_state := dispose;
          receive_status := ok;
        ELSE
          receive_status := error;
          exec_status := unrecoverable_error;
          receive_state := dispose;
        CASEND;
? IF rhv$prif_for_nosbe = FALSE THEN
        IFEND;
? IFEND

{ Route local file to queue.

      = dispose =
       IF queue_file_info.a170.dual_state_routing_text_size = 0 THEN
         rhp$close_file (local_file_info);
       ELSE
         bi#close(new_print_file, first#);
       IFEND;
        IF receive_status = ok THEN
          IF queue_file_info.a170.dual_state_routing_text_size = 0 THEN
            route_file (receive_exec, local_file_info, queue_file_info,
              route_status);
          ELSE
            route_file (prif_pj_exec, local_file_info, queue_file_info,
              route_status);
          IFEND;
          IF route_status = successful THEN
            message_info.arbitrary_info := completed;
          ELSE
? IF rhv$prif_for_nosbe = FALSE THEN
            IF queue_file_info.a170.dual_state_routing_text_size = 0 THEN
              return_file (local_file_info);
            ELSE
              utp$return_file (rhreclf_file_name);
            IFEND;
? ELSE
            return_file (local_file_info);
? IFEND
            message_info.arbitrary_info := err;
          IFEND;
          message_info.message_length := 0;
          receive_state := respond;
          log_status (dayfile_log_and_display, 'END XFER NOSVE OUTPUT');
        ELSE
          return_file (local_file_info);
          IF exec_status = middle THEN

? IF rhv$prif_for_nosbe = FALSE THEN

{ A NOS track limit was reached, print an error file for the user.

            bi#open (errmsg_file, errmsg_file_name, new#, output#, first#);
            bi#put (errmsg_file, #LOC (errmsg), #SIZE (errmsg));
            bi#close (errmsg_file, first#);
            errmsg_local_file_info.fet.filename := errmsg_dc_file_name;
            IF queue_file_info.a170.dual_state_routing_text_size = 0 THEN
              route_file (receive_exec, errmsg_local_file_info, queue_file_info,
                  route_status);
            ELSE
              route_file (prif_pj_exec, errmsg_local_file_info, queue_file_info,
                  route_status);
            IFEND;
            IF route_status <> successful THEN
              return_file (errmsg_local_file_info);
            IFEND;
            log_status (display_in_system_log,
                'A file was too large to be printed and was returned.');
? IFEND
            message_info.arbitrary_info := err;
            message_info.message_length := 0;
            receive_state := respond;
          ELSE
            message_info.message_area := ^queue_file_info.equalizer;
            receive_status := ok;
            receive_state := fetch_control;
            quanta_work_completed := TRUE;
          IFEND;
          log_status (dayfile_log_and_display, 'ERROR END XFER NOSVE OUTPUT');
        IFEND;

{ Tell transmitter status of receive.

      = respond =
        rhp$send_message_os (application_names.application.application_name,
          message_info.arbitrary_info, rhv$signal, message_info.message_area,
          message_info.message_length, application_names.destination.application_name,
          status);
        IF status.normal THEN
          message_info.message_area := ^queue_file_info.equalizer;
          receive_status := ok;
          receive_state := fetch_control;
          exec_status := middle;
        ELSE
          CASE status.condition OF
          = mlc$busy_interlock, mlc$pool_buffer_not_avail,
            mlc$prior_msg_not_received =
            exec_status := middle;
          = mlc$receiver_not_signed_on =
            exec_status := beginning;
            IF message_info.arbitrary_info <> err THEN
              receive_status := error;
              message_info.arbitrary_info := err;
            IFEND;
            quanta_work_completed := TRUE;
          ELSE
            abnormal_mli_stat_message (1,26) := 'send msg mli abnorm cond =';
            STRINGREP (abnormal_mli_stat_message (27,3), string_length, status.condition);
            log_status (dayfile_log, abnormal_mli_stat_message(1,26+string_length));
            message_info.message_area := ^queue_file_info.equalizer;
            receive_status := ok;
            receive_state := fetch_control;
            exec_status := unrecoverable_error;
          CASEND;
          IFEND;
          quanta_work_completed := TRUE;
        CASEND;
      UNTIL quanta_work_completed;

  PROCEND rhp$queue_file_receive_exec;

MODEND rhmqfr;
*DECK DECK=RHM$QUEUE_FILE_TRANSMIT_EXEC EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := '170 NOS/VE REMOTE HOST' ??
MODULE rhmqft;

?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc RHT$FUNCTION_STATUS
*copyc RHC$CONSTANTS

?? TITLE := 'EXTERNAL PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc RHP$ACQUIRE_QUEUE_FILE
*copyc RHV$SIGNAL
*copyc RHP$LOG_STATUS
*copyc RHP$OPEN_FILE
*copyc RHP$RECEIVE_MESSAGE_OS
*copyc RHP$SEND_MESSAGE_OS
*copyc RHP$CLOSE_FILE
*copyc RHP$RETURN_FILE
*copyc RHP$ROUTE_FILE
*copyc RHP$WAIT
*copyc BIZCLOS
*copyc BIZOPEN
*copyc BIZPUT

  PROCEDURE [XREF] qfsend (lfn: integer;
        an170: integer;
        an180: integer;
    VAR detailed_status: integer;
    VAR qfsend_status: integer);

?? SET (LIST := ON) ??
?? TITLE := 'RHP$QUEUE_FILE_TRANSMIT_EXEC' ??
?? EJECT ??

{ RHP$QUEUE_FILE_TRANSMIT_EXEC
{
{     This procedure is responsible for the acquisition and subsequent
{ transfer of a queued file to its receiving partner application.  This
{ transfer includes the responsibilities of performing protocol
{ maintenance, file transmission control, and final file disposition.
{
{     RHP$QUEUE_FILE_TRANSMIT_EXEC (APPLICATION_NAMES,EXEC_STATUS)
{
{ APPLICATION_NAMES: (input) This parameter contains the sending and
{     receiving application names required for MLI communication.
{
{ EXEC_STATUS: (output) This parameter indicates to the calling
{     procedure the processing status of the executive.  The following
{     status values may be returned:
{                 beginning
{                 middle
{                 unrecoverable_error
{
{ LID_LIST: (input) This parameter specifies the pointer to the
{      list of lids that a site can route jobs from.
{
  PROCEDURE [XDCL] rhp$queue_file_transmit_exec ALIAS 'rhmqft' (VAR
    application_names: rht$mli_application_names;
    VAR exec_status: rht$exec_status;
    lid_list: ^cell);

    TYPE
      qtran_states = (acquire, get, dispose);

    CONST
      boi = rhc$beginning_of_information,
      moi = rhc$middle_of_information,
      eoi = rhc$end_of_information,
      errmsg_file_name = 'rhermsg',
      errmsg_dc_file_name = 22100522152307(8),
      completed = rhc$completed,
      delete_file = rhc$delete_file;

    VAR
      quanta_work_completed: boolean,
      qtran_state: [STATIC] qtran_states := acquire,
      tran_status: [STATIC] (ok, error) := ok,
      acquire_status: rht$acquire_status,
      status: ost$status,
      route_status: rht$function_status,
      local_file_info: [STATIC] rht$local_file_info,
      queue_file_info: [XDCL] rht$queue_file_info, { kludge for conv. serv.
      {architecture 4/16/80 RMD }
      abnormal_mli_stat_message: string(33),
      string_length: 1 .. 33,
      sender_name: mlt$application_name,
      message_info: [STATIC] rht$mli_message_info := [ * , 0, * , * ],
      errmsg_local_file_info: [STATIC] rht$local_file_info,
      errmsg_queue_file_info: [STATIC] rht$queue_file_info,
      errmsg: [STATIC] packed ARRAY [0..39] of
              0 .. 03fffffff(16) :=
              [ 0061000000(8), 0000000000(8),  {1}
                0060000000(8), 0000000000(8),  {0}
                0040005500(8), 5501050122(8),  { --ER}
                0122011701(8), 2200550055(8),  {ROR--}
                0040004001(8), 1601170123(8),  {  NOS}
                0057012601(8), 0500400112(8),  {/VE J}
                0117010200(8), 4001040111(8),  {OB DI}
                0104004001(8), 1601170124(8),  {D NOT}
                0040010701(8), 0501240040(8),  { GET }
                0122011701(8), 2501240105(8),  {ROUTE}
                0104004001(8), 0401250105(8),  {D DUE}
                0040012401(8), 1700400114(8),  { TO L}
                0117010701(8), 1101160040(8),  {OGIN }
                0103011701(8), 1501150101(8),  {COMMA}
                0116010400(8), 4001150111(8),  {ND MI}
                0123012301(8), 1101160107(8),  {SSING}
                0040011701(8), 2200400111(8),  { OR I}
                0116010301(8), 1701220122(8),  {NCORR}
                0105010301(8), 2400560000(8),  {ECT.}
                0062000000(8), 0000000000(8) ],  {2}
      errmsg_file: file,
      detailed_status,
      qfsend_status: integer;

{ * * * * * * *   T R A N S M I T   A    Q U E U E   F I L E   * * * * * * *

    quanta_work_completed := FALSE;

  /control_loop/
    WHILE NOT quanta_work_completed DO
      CASE qtran_state OF

{ Acquire the queue file that is to be transmitted.

      = acquire =
        rhp$acquire_queue_file (local_file_info, queue_file_info,
          lid_list, acquire_status);
        IF acquire_status = acquired THEN
          rhp$open_file (local_file_info);
          message_info.message_area := ^queue_file_info.equalizer;
          message_info.message_length := #SIZE (queue_file_info.equalizer);
          message_info.arbitrary_info := boi;
          qtran_state := get;

          /send_info/
          REPEAT
            rhp$send_message_os (application_names.application.application_name,
              message_info.arbitrary_info, rhv$signal, message_info.message_area,
              message_info.message_length, application_names.destination.application_name,status);
            IF status.normal THEN
              log_status (dayfile_log_and_display, 'BEGIN XFER NOSVE INPUT JOB');
            ELSE
              CASE status.condition OF
              = mlc$busy_interlock, mlc$pool_buffer_not_avail,
                mlc$prior_msg_not_received =
                wait(1000);
                CYCLE /send_info/;
              ELSE
                abnormal_mli_stat_message (1,26) := 'send msg mli abnorm cond =';
                STRINGREP (abnormal_mli_stat_message (27,3), string_length, status.condition);
                log_status (dayfile_log, abnormal_mli_stat_message (1, 26+string_length));
                tran_status := error;
                exec_status := beginning;
                qtran_state := dispose;
                CYCLE /control_loop/;
              CASEND;
            IFEND;
          UNTIL status.normal;  { send_info }
        ELSE
          exec_status := beginning;
          quanta_work_completed := TRUE;
        IFEND;

{ Get data from local queue file to transmit.

      = get =
        qfsend (local_file_info.fet.filename, application_names.application.
              application_name, application_names.destination.application_name,
              detailed_status, qfsend_status);
        CASE qfsend_status OF
        = moi =
          qtran_state := get;
          exec_status := middle;
          quanta_work_completed := TRUE;
        = eoi =
          qtran_state := dispose;
          tran_status := ok;
          exec_status := middle;
        ELSE
          tran_status := error;
          qtran_state := dispose;
          exec_status := middle;
        CASEND;

{ Return local file if data transmitted okay, or route file back to the queue.

      = dispose =

        IF tran_status = ok THEN
          /receive_loop/
          REPEAT
            rhp$receive_message_os (application_names.application.application_name,
              message_info.arbitrary_info, rhv$signal, message_info.message_area,
              message_info.message_length, message_info.message_area_length,
              0{ for receive any pending message }, sender_name, status);
            IF (status.normal) OR (status.condition = mlc$signal_failed_ignored) THEN
              CASE message_info.arbitrary_info OF
              = completed =
                tran_status := ok;
              = delete_file =
                BI#OPEN (errmsg_file, errmsg_file_name, new#, output#, first#);
                BI#PUT (errmsg_file, #LOC (errmsg), #SIZE (errmsg));
                BI#CLOSE (errmsg_file, first#);
                errmsg_local_file_info.fet.filename := errmsg_dc_file_name;
                errmsg_queue_file_info.a170.form_code := '  ';
                errmsg_queue_file_info.a170.repeat_count := 1;
                errmsg_queue_file_info.a170.family_name_of_creator.a170_creator_family_name :=
                      queue_file_info.a170.family_name_of_creator.a170_creator_family_name;
                errmsg_queue_file_info.a170.user_number_of_owner.a170_owner_user_num :=
                      queue_file_info.a170.user_number_of_owner.a170_owner_user_num;
                errmsg_queue_file_info.a170.user_project_number :=
                      queue_file_info.a170.user_project_number;
                errmsg_queue_file_info.a170.user_charge_number :=
                      queue_file_info.a170.user_charge_number;
                errmsg_queue_file_info.a170.logical_identifier.a170_logical_identifier :=
                      queue_file_info.a170.logical_identifier.a170_logical_identifier;
                errmsg_queue_file_info.a170.implicit_text_size := queue_file_info.a170.implicit_text_size;
                errmsg_queue_file_info.a170.implicit_routing_text :=
                    queue_file_info.a170.implicit_routing_text;
                route_file (receive_exec, errmsg_local_file_info, errmsg_queue_file_info, route_status);
                tran_status := ok;
              ELSE
                tran_status := error;
              CASEND;
            ELSE
              CASE status.condition OF
              = mlc$busy_interlock, mlc$receive_list_index_invalid =
                wait (1000);
                CYCLE /receive_loop/;
              = mlc$nosve_not_up =
                log_status (dayfile_log, '$loss of dual state environment');
                tran_status := error;
                EXIT /receive_loop/;
              ELSE
                tran_status := error;
                abnormal_mli_stat_message (1,29) := 'receive msg mli abnorm cond =';
                STRINGREP (abnormal_mli_stat_message(30,3), string_length, status.condition);
                log_status (dayfile_log, abnormal_mli_stat_message (1,29+string_length));
                EXIT /receive_loop/;
              CASEND;
            IFEND;
        UNTIL status.normal; { receive_loop }
        IFEND;
        rhp$close_file (local_file_info);
        IF tran_status = ok THEN
          return_file (local_file_info);
          log_status (dayfile_log_and_display, 'END XFER NOSVE INPUT JOB');
        ELSE
          route_file (transmit_exec, local_file_info, queue_file_info,
            route_status);
          tran_status := ok;
          log_status (dayfile_log_and_display, 'ERROR END XFER NOSVE INPUT JOB');
        IFEND;
        qtran_state := acquire;
        quanta_work_completed := TRUE;
      CASEND;
    WHILEND /control_loop/;

  PROCEND rhp$queue_file_transmit_exec;

MODEND rhmqft;
*DECK DECK=RHM$RETURN_FILE EXPAND=TRUE

*copyc osd$default_pragmats
?? NEWTITLE := '170 NOS/VE REMOTE HOST' ??
MODULE rhmrtf;

?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc rht$function_status

?? TITLE := 'EXTERNAL PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc zutprtf
*copyc zutpdns
*copyc rhp$log_status

?? TITLE := 'RETURN_FILE' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ RETURN_FILE
{
{     The purpose of this procedure is to provide a means by which
{ a CYBIL procedure can return a local file, i.e., release file
{ control from the calling job.
{
{       RETURN_FILE (LOCAL_FILE_INFO)
{
{ LOCAL_FILE_INFO: (input) This parameter specifies all information
{                  pertinent to local file access.
{

  PROCEDURE [XDCL] return_file
    (VAR local_file_info: rht$local_file_info);

    VAR
      dc_name: utt$dc_name,
      return_message: string (16),
      file_name_length: 0 .. 7;

    dc_name := local_file_info.fet.filename;
    utp$convert_dc_name_to_string (dc_name, return_message (1, 7),
          file_name_length);
    utp$return_file (return_message (1, 7));
    return_message (9, 8) := 'returned';
    log_status (dayfile_log_and_display, return_message);

  PROCEND return_file;

MODEND rhmrtf;
*DECK DECK=RHM$ROUTE_FILE EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := '170 NOS/VE REMOTE HOST' ??
MODULE rhmqrf;

{ Select target 170 operating system.
*IF ($string($name(wev$target_operating_system))='NOS')

  ?VAR rhv$nos_be: boolean := FALSE ?;
*ELSE

  ?VAR rhv$nos_be: boolean := TRUE ?;
*IFEND
?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc RHT$FUNCTION_STATUS

?? TITLE := 'EXTERNAL PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc ZUTPS2D
*copyc RHP$LOG_STATUS
*copyc ZUTPDNS
*copyc ZUTPSDN
*copyc ZUTPI2S
?? SET (LIST := ON) ??

? IF rhv$nos_be = FALSE THEN
    TYPE

      valid_family_rec = packed record
        family: 0 .. 3ffffffffff(16),
        filler1: 0 .. 3f(16),
        reply_code: 0 .. 0fff(16),
      recend,

      perm_file_info_rec = packed record
        family_name: 0 .. 3ffffffffff(16),
        zero: 0 .. 3ffff(16),
        filler1: integer,
        user_name: 0 .. 3ffffffffff(16),
        filler2: 0 .. 3ffff(16),
      recend;


  PROCEDURE [XREF] rhpgpfp (VAR perm_file_info: perm_file_info_rec);

  PROCEDURE [XREF] rhpvfam (VAR valid_family_info: valid_family_rec);

  PROCEDURE [XREF] rhpglvl (VAR level_number: integer);
? IFEND
?? TITLE := 'ROUTE_FILE' ??
?? EJECT ??

{ ROUTE_FILE
{
{     The purpose of this procedure is to provide a means by which
{ a CYBIL procedure can route a local file to a system queue.
{
{           ROUTE_FILE (QUEUE_TYPE,LOCAL_FILE_INFO,QUEUE_FILE_INFO,ROUTE_STATUS)
{
{ QUEUE_TYPE: (input) This parameter specifies the destination queue
{             to which the file is to be routed.
{
{ LOCAL_FILE_INFO: (input) This parameter specifies all information
{                  pertinent to local file access.
{
{ QUEUE_FILE_INFO: (input) This parameter communicates all queue file
{                  attributes needed for IRHF routing.
{
{ ROUTE_STATUS: (output) This parameter indicates to the calling
{               procedure the completion status of the route function,
{               i.e. the success or failure of the route.  The
{               following status values may be returned by this
{               request:     unsuccessful
{                            successful
{

  PROCEDURE [XDCL] route_file (exec_type: rht$irhf_exec_types;
    VAR local_file_info: rht$local_file_info;
        queue_file_info: rht$queue_file_info;
    VAR route_status: rht$function_status);
  ? IF rhv$nos_be = FALSE THEN
    CONST
      input_forms_code = 010010001000(2), { display code for RH }
      pr_disposition_code = 010000010010(2), { display code for PR }
      in_disposition_code = 001110001111(2), { display code for NO }
      communication_task = 000011010100(2),  { display code for CT }
      batch_service_class = 000010000011(2), { display code for BC }
      input_q_disposition_code = 001001001110(2), { display code for IN }
      wait_disposition_code = 2724(8), { display code for WT }
      invalid_family = 7777(8),
      a9_ascii_ex_code = 6,
      ascii_ic_code = 1,
      display_code_ic_code = 0,
      system_origin_type = 0,
      local_batch_origin_type = 1,
      export_import_origin_type = 2,
      null_equipment_code_67 = 55,
      a170_repeat_count_max = 1f(16),
      no_rerun = 512, {1000(8)}
      input_flags = no_rerun;

    TYPE
      route_parameter_block = packed record
{- - - - - - - - - - - - - - - - - - - - - - Word 0
        lfn: 0 .. 3ffffffffff(16),
        ec: 0 .. 3f(16),
        f: boolean,
        filler1: 0 .. 0f(16),
        ot: 0 .. 3f(16),
        c: boolean,
{- - - - - - - - - - - - - - - - - - - - - - Word 1
        zero: 0 .. 0fff(16),
        forms: 0 .. 0fff(16),
        disp: 0 .. 0fff(16),
        ex: 0 .. 7,
        forced_service_class: boolean,
        ic: 0 .. 3,
        flags: route_flags,
{- - - - - - - - - - - - - - - - - - - - - - Word 2
        source_lid: 0 .. 3ffff(16),
        destination_lid: 0 .. 3ffff(16),
        tid: - 7fffff(16) .. 7fffff(16),
{- - - - - - - - - - - - - - - - - - - - - - Word 3
        user_job_name: 0 .. 3ffffffffff(16),
        reserved3: 0 .. 1f(16),
        b: boolean,
        priority: 0 .. 0fff(16),
{- - - - - - - - - - - - - - - - - - - - - - Word 4
        spacing: 0 .. 0fff(16),
        service_class: 0 .. 0fff(16),
        abort_code: 0 .. 0fff(16),
        reserved4b: 0 .. 7f(16),
        rc: 0 .. 1f(16),
        reserved4c: 0 .. 0fff(16),
{- - - - - - - - - - - - - - - - - - - - - - Word 5
        reserved5: integer,
{- - - - - - - - - - - - - - - - - - - - - - Word 6
        reserved6: integer,
{- - - - - - - - - - - - - - - - - - - - - - Word 7
        data_declaration : 0 .. 0fff(16),
        eoi_random_address : 0 .. 0ffffff(16),
        reserved7 : 0 .. 3f(16),
        extended_flags: extended_route_flags,
{- - - - - - - - - - - - - - - - - - - - - - Word 8
        owner_user_name : 0 .. 3ffffffffff(16),
        irtaddr : 0 .. 3ffff(16),
{- - - - - - - - - - - - - - - - - - - - - - Word 9
        owner_family_name : 0 .. 3ffffffffff(16),
        ertaddr : 0 .. 3ffff(16),
{- - - - - - - - - - - - - - - - - - - - - - Word 10
        creator_user_name : 0 .. 3ffffffffff(16),
        control_point : 0 .. 3f(16),
        subsystem_id : 0 .. 0fff(16),
{- - - - - - - - - - - - - - - - - - - - - - Word 11
        creator_family_name : 0 .. 3ffffffffff(16),
        reserved11 : 0 .. 3ffff(16),
{- - - - - - - - - - - - - - - - - - - - - - Word 12
        reserved12: integer,
{- - - - - - - - - - - - - - - - - - - - - - Word 13
        reserved13: integer,
{- - - - - - - - - - - - - - - - - - - - - - Word 14
        reserved14: integer,
{- - - - - - - - - - - - - - - - - - - - - - Word 15
{ Separate the charge numbers into 2 parts as we cannot
{ compile something that is defined to be more than 48 bits.
{ The same holds true for the project numbers.

        charge_number1: 0 .. 3fffffff(16),
        charge_number2: 0 .. 3fffffff(16),
{- - - - - - - - - - - - - - - - - - - - - - Word 16 and 17
        project_number1a: 0 .. 3fffffff(16),
        project_number1b: 0 .. 3fffffff(16),
        project_number2a: 0 .. 3fffffff(16),
        project_number2b: 0 .. 3fffffff(16),
      recend,
      extended_route_flags = packed record
        reserved1: 0 .. 07f(16),
        charge_project_req: boolean,
        no_validation_needed: boolean,
        special_requeue_op: boolean,
        use_encrypted_password : boolean,
        use_original_default_service : boolean,
        cp_and_ssid_specified : boolean,
        do_not_validate_password :boolean,
        subsystem_call : boolean,
        create_user_name_or_family_name : boolean,
        owner_user_name_or_family_name : boolean,
        data_decl : boolean,
      recend,
      route_flags = packed record
        return_system_file_name: boolean,
        accounting: boolean,
        pfc_580_spacing_code: boolean,
        repeat_count: boolean,
        ujn_specified: boolean,
        return_error_code: boolean,
        reserved3: 0 .. 1,
        forms_code: boolean,
        priority: boolean,
        internal_characteristics: boolean,
        external_characteristics: boolean,
        extended_parameter_block: boolean,
        reserved4: 0 .. 1,
        disposition_code: boolean,
        dlid_slid: boolean,
        tid: boolean,
        route_to_central_site: boolean,
        end_of_job: boolean,
      recend,
      forms_conversion_buffer_record = record
        case i: integer of
        = 1 =
          dc_string: array [1 .. 1] of packed array [0 .. 9] of 0 .. 3f(16),
        = 2 =
          forms_rec: packed record
            forms: 0 .. 0fff(16),
            filler: 0 .. 0ffffffffffff(16),
          recend,
        casend,
      recend,
      ujn_conversion_buffer_record = record
        case l: integer of
        = 1 =
          dc_string: array [1 .. 1] of packed array [0 .. 9] of 0 .. 3f(16),
        = 2 =
          ujn_rec: packed record
            ujn: 0 .. 3ffffffffff(16),
            filler2: 0 .. 3ffff(16),
          recend,
        casend,
      recend,
      charge_conversion_buffer_rec = record
        case o: integer of
        = 1 =
          dc_string: array [1 .. 4] of packed array [0 .. 9] of 0 .. 3f(16),
        = 2 =
          charge_rec: packed record
            charge1: 0 .. 3fffffff(16),
            charge2: 0 .. 3fffffff(16),
            filler1: integer,
            filler2: integer,
            filler3: integer,
          recend,
        casend,
      recend,
      project_conversion_buffer_rec = record
        case p: integer of
        = 1 =
          dc_string: array [1 .. 4] of packed array [0 .. 9] of 0 .. 3f(16),
        = 2 =
          project_rec: packed record
            project1a: 0 .. 3fffffff(16),
            project1b: 0 .. 3fffffff(16),
            project2a: 0 .. 3fffffff(16),
            project2b: 0 .. 3fffffff(16),
            filler1: integer,
            filler2: integer,
          recend,
        casend,
      recend,
      lid_conversion_buffer_record = record
        case k: integer of
        = 1 =
          dc_string: array [1 .. 1] of packed array [0 .. 9] of 0 .. 3f(16),
        = 2 =
          lid_rec: packed record
            lid: 0 .. 3ffff(16),
            filler: 0 .. 3ffffffffff(16),
          recend,
        casend,
      recend,
      implicit_dc_string_record = packed record
        implicit_text_size: integer,
        dc_string: array [1 .. 26] of packed array [0 .. 9] of 0 .. 3f(16),
      recend,
      tid_block_rec = packed record
        destination_family_name: utt$dc_name,
        filler1: 0 .. 3ffff(16),
        destination_user_number: utt$dc_name,
        filler2: 0 .. 3ffff(16),
      recend;

    VAR
      routepb_initial: [STATIC] route_parameter_block :=
        [0, 0, TRUE, 0, 0, FALSE, 0, 0, 0, 0, FALSE, 0,
        [TRUE, FALSE, FALSE, FALSE, FALSE, TRUE, 0, TRUE, FALSE,
         TRUE, TRUE, FALSE, 0, TRUE, FALSE, FALSE, TRUE, FALSE],
        0, 0, 0, 0, 0, FALSE, 0, 0, batch_service_class, 0, 0, 0, 0, 0, 0,
{  The following 11 words are needed to make an extended DSP block call.
        0, 0, 0,[0, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
        FALSE, FALSE, FALSE, FALSE],
        0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0],
      implicit_dc_string: implicit_dc_string_record,
      routepb: route_parameter_block,
      forms_conversion_buffer: forms_conversion_buffer_record,
      dc_string_word_index: integer,
      dc_string_char_index: 0 .. 9,
      source_index: ost$string_index,
      eol: boolean,
      perm_file_info: perm_file_info_rec,
      valid_family_info: valid_family_rec,
      ujn_conversion_buffer: ujn_conversion_buffer_record,
      lid_conversion_buffer: lid_conversion_buffer_record,
      charge_conversion_buffer: charge_conversion_buffer_rec,
      project_conversion_buffer: project_conversion_buffer_rec,
      irtaddr_ptr: ^implicit_dc_string_record,
      irt_address_ptr: ^integer,
      tid_block: tid_block_rec,
      tid_blk_ptr: ^tid_block_rec,
      tid_blk_addr_ptr: ^integer,
      error_code_length: 1 .. 2,
      route_error_message: string (27),
      route_error_occurred: boolean,
      dc_name: utt$dc_name,
      route_exec_type: rht$irhf_exec_types,
      dc_family_name: utt$dc_name,
      dc_user_name: utt$dc_name,
      owner_family: utt$dc_name,
      owner_user: utt$dc_name,
      level_number: integer,
      str: string(31),
      i: integer,
      j: integer,
      file_name_length: 0 .. 7;

?? SET (LIST := OFF) ??
{ This call to rhxqrm needs to be here so the route_parameter_block
{     TYPE may be used by this XREF.
*copyc RHP$ROUTE
?? SET (LIST := ON) ??

{ Insert parameters into the route parameter block.  The route parameter
{ block is defined in the NOS REFERENCE SET VOLUME 4 PROGRAM INTERFACE manual.

    route_exec_type := exec_type;
    routepb := routepb_initial;
    routepb.lfn := local_file_info.fet.filename;
    CASE route_exec_type OF
    = transmit_exec =

{ This sends a 180 job submitted from NOS to the NOS input queue.
      routepb.flags.extended_parameter_block := true;
      routepb.extended_flags.special_requeue_op := true;
      routepb.flags.forms_code := false;
      routepb.flags.internal_characteristics :=false;
      routepb.flags.external_characteristics :=false;
      routepb.flags.disposition_code := false;
    = receive_exec =

{ This sends a job to the NOS output queue.
      routepb.ot := local_batch_origin_type; { fix for C180 acquire }
      { ROUTEpb.ot:=queue_file_info.A170.origin_type;
      dc_string_word_index := 1;
      dc_string_char_index := 0;
      source_index := 1;
      eol := FALSE;
      utp$convert_string_to_dc_string (utc$ascii64, forms_conversion_buffer.dc_string, dc_string_word_index,
            dc_string_char_index, queue_file_info.a170.form_code, source_index, eol);
      IF (forms_conversion_buffer.forms_rec.forms = 2925) THEN
        routepb.flags.forms_code := FALSE;         {5555(8)=blanks}
      ELSE
        routepb.flags.forms_code := TRUE;
        routepb.forms := forms_conversion_buffer.forms_rec.forms;
      IFEND;
      routepb.flags.accounting := TRUE;
      utp$convert_string_to_dc_name(queue_file_info.a170.user_number_of_owner.a170_owner_user_num,
          dc_user_name);
      utp$convert_string_to_dc_name(
         queue_file_info.a170.family_name_of_creator.a170_creator_family_name, dc_family_name);
      routepb.flags.extended_parameter_block := true;
      routepb.extended_flags.use_original_default_service := true;
      routepb.extended_flags.create_user_name_or_family_name := true;
      routepb.extended_flags.owner_user_name_or_family_name := true;
      routepb.owner_user_name:= dc_user_name;
      routepb.creator_user_name:= dc_user_name;

{ Validate that the family exists on NOS.  If it does not then use
{ the default NOS family that the IRHF170 job runs under.

      valid_family_info.family := dc_family_name;
      valid_family_info.filler1 := 0;
      valid_family_info.reply_code := 0;
      rhpvfam (valid_family_info);
      IF valid_family_info.reply_code = invalid_family THEN

{ The family does not exist on NOS, get the default NOS family.

        rhpgpfp (perm_file_info); { get default family and user }
        routepb.owner_family_name := perm_file_info.family_name;
        routepb.creator_family_name := perm_file_info.family_name;
      ELSE  { family was valid on NOS. }
        routepb.creator_family_name := dc_family_name;
        routepb.owner_family_name := dc_family_name;
      IFEND;
      routepb.disp := pr_disposition_code;
      routepb.ex := a9_ascii_ex_code;
      routepb.ic := ascii_ic_code;
      routepb.flags.repeat_count := TRUE;
      IF (queue_file_info.a170.logical_identifier.a170_logical_identifier <> ' ') THEN
        routepb.flags.dlid_slid := TRUE;
        dc_string_word_index := 1;
        dc_string_char_index := 0;
        source_index := 1;
        eol := FALSE;
        utp$convert_string_to_dc_string (utc$ascii64, lid_conversion_buffer.dc_string, dc_string_word_index,
              dc_string_char_index, queue_file_info.a170.logical_identifier.a170_logical_identifier,
              source_index, eol);
        routepb.destination_lid := lid_conversion_buffer.lid_rec.lid;
      IFEND;
      IF queue_file_info.a170.implicit_text_size <> 0 THEN

{  Get the information off of the implicit routing text field
{  in order to route the file to the correct NOS output queue.

        IF queue_file_info.a170.implicit_routing_text (1,6) = 'IRHNVE' THEN
          utp$convert_string_to_dc_name(
              queue_file_info.a170.implicit_routing_text (59, 7), owner_family);
          utp$convert_string_to_dc_name(
              queue_file_info.a170.implicit_routing_text (74, 7), owner_user);
          routepb.owner_user_name := owner_user;
          routepb.creator_user_name := owner_user;
          routepb.owner_family_name := owner_family;
          routepb.creator_family_name := owner_family;
          IF queue_file_info.a170.implicit_routing_text (49,2) = 'TO' THEN
            routepb.disp := wait_disposition_code;
          IFEND;
          IF queue_file_info.a170.implicit_routing_text (21,7) <> '       ' THEN
            utp$convert_string_to_dc_name(queue_file_info.a170.implicit_routing_text (21,7),
                dc_family_name);
            tid_block.destination_family_name := dc_family_name;
            utp$convert_string_to_dc_name(queue_file_info.a170.implicit_routing_text (35,7),
                dc_user_name);
            tid_block.destination_user_number := dc_user_name;
            tid_block.filler1 := 0;
            tid_block.filler2 := 0;
            tid_blk_ptr := ^tid_block;
            tid_blk_addr_ptr := #LOC (tid_blk_ptr);
            routepb.tid := -(tid_blk_addr_ptr^);
            routepb.flags.tid := TRUE;
            routepb.flags.route_to_central_site := FALSE;
            routepb.ot := export_import_origin_type;
          IFEND;
        ELSE
          dc_string_word_index := 1;
          dc_string_char_index := 0;
          source_index := 1;
          eol := FALSE;
          utp$convert_string_to_dc_string (utc$ascii64, implicit_dc_string.dc_string,
              dc_string_word_index, dc_string_char_index,
              queue_file_info.a170.implicit_routing_text, source_index, eol);
          implicit_dc_string.implicit_text_size :=
              queue_file_info.a170.implicit_text_size;

{ Set the address of the implicit text field in the route parameter block.
          irtaddr_ptr := ^implicit_dc_string;
          irt_address_ptr := #LOC (irtaddr_ptr);
          routepb.irtaddr := irt_address_ptr^;
        IFEND;
      IFEND;
      IF queue_file_info.a170.repeat_count - 1 <= a170_repeat_count_max THEN
        routepb.rc := queue_file_info.a170.repeat_count - 1;
      ELSE
        routepb.rc := a170_repeat_count_max;
        log_status (dayfile_log, 'repeat_count>A170_repeat_count_max');
        log_status (dayfile_log, 'repeat_count set:=A170_repeat_count_max');
      IFEND;
      routepb.flags.ujn_specified := TRUE;
      str := ' ';
      j := 1;
      FOR i := 1 TO 7 DO
        IF ((queue_file_info.a170.user_number_of_owner.a170_owner_user_num (i) >= 'A') AND
            (queue_file_info.a170.user_number_of_owner.a170_owner_user_num (i) <= 'Z')) OR
           ((queue_file_info.a170.user_number_of_owner.a170_owner_user_num (i) >= '0') AND
            (queue_file_info.a170.user_number_of_owner.a170_owner_user_num (i) <= '9')) OR
            (queue_file_info.a170.user_number_of_owner.a170_owner_user_num (i) = '*') THEN
          str (j) := queue_file_info.a170.user_number_of_owner.a170_owner_user_num (i);
          j := j + 1;
        IFEND;
      FOREND;
      dc_string_word_index := 1;
      dc_string_char_index := 0;
      source_index := 1;
      eol := FALSE;
      utp$convert_string_to_dc_string (utc$ascii64, ujn_conversion_buffer.dc_string,
          dc_string_word_index, dc_string_char_index, str (1, 7), source_index, eol);
      routepb.user_job_name := ujn_conversion_buffer.ujn_rec.ujn;
      rhpglvl (level_number);
      IF (level_number >= 664) THEN

{ Convert the charge number.

        str := ' ';
        j := 1;
        FOR i := 1 TO 31 DO
          IF ((queue_file_info.a170.user_charge_number (i) >= 'A') AND
              (queue_file_info.a170.user_charge_number (i) <= 'Z')) OR
             ((queue_file_info.a170.user_charge_number (i) >= '0') AND
              (queue_file_info.a170.user_charge_number (i) <= '9')) OR
              (queue_file_info.a170.user_charge_number (i) = '*') THEN
            str (j) := queue_file_info.a170.user_charge_number (i);
            j := j + 1;
          IFEND;
        FOREND;
        dc_string_word_index := 1;
        dc_string_char_index := 0;
        source_index := 1;
        eol := FALSE;
        utp$convert_string_to_dc_string (utc$ascii64, charge_conversion_buffer.dc_string,
            dc_string_word_index, dc_string_char_index, str (1, 10), source_index, eol);
        routepb.charge_number1 := charge_conversion_buffer.charge_rec.charge1;
        routepb.charge_number2 := charge_conversion_buffer.charge_rec.charge2;

{ Convert the project number.

        str := ' ';
        j := 1;
        FOR i := 1 TO 31 DO
          IF ((queue_file_info.a170.user_project_number (i) >= 'A') AND
              (queue_file_info.a170.user_project_number (i) <= 'Z')) OR
             ((queue_file_info.a170.user_project_number (i) >= '0') AND
              (queue_file_info.a170.user_project_number (i) <= '9')) OR
              (queue_file_info.a170.user_project_number (i) = '*') THEN
            str (j) := queue_file_info.a170.user_project_number (i);
            j := j + 1;
          IFEND;
        FOREND;
        dc_string_word_index := 1;
        dc_string_char_index := 0;
        source_index := 1;
        eol := FALSE;
        utp$convert_string_to_dc_string (utc$ascii64, project_conversion_buffer.dc_string,
            dc_string_word_index, dc_string_char_index, str (1, 20), source_index, eol);
        routepb.project_number1a := project_conversion_buffer.project_rec.project1a;
        routepb.project_number1b := project_conversion_buffer.project_rec.project1b;
        routepb.project_number2a := project_conversion_buffer.project_rec.project2a;
        routepb.project_number2b := project_conversion_buffer.project_rec.project2b;
        routepb.extended_flags.charge_project_req := TRUE;
      IFEND;

    = pj_exec, prif_pj_exec =

{ This sends a NOS partner job to the NOS input queue.
      routepb.ot := local_batch_origin_type;
      routepb.forms := input_flags;
      routepb.disp := in_disposition_code;
      routepb.flags.internal_characteristics := FALSE;
      routepb.flags.external_characteristics := FALSE;
      rhpglvl (level_number);
      IF (level_number > 638) or (route_exec_type = prif_pj_exec) THEN
        routepb.service_class := communication_task;
        routepb.forced_service_class := TRUE;
        routepb.extended_flags.no_validation_needed := TRUE;
        routepb.flags.extended_parameter_block :=TRUE;
        IF route_exec_type = prif_pj_exec THEN
          routepb.extended_flags.subsystem_call := TRUE;
        IFEND;
      IFEND;
    CASEND;

    IF route_exec_type = pj_exec THEN
      rhppjr (routepb);
    ELSE
      rhpqrm (routepb);
    IFEND;
    route_error_occurred := false;
    IF routepb.ec = 0 THEN
      IF route_exec_type = pj_exec THEN
        local_file_info.fet.filename := routepb.lfn;
      IFEND;
      route_status := successful;
    ELSEIF (route_exec_type = receive_exec) THEN { retry receiving the file. }
{       Use default parameters if possible.
      routepb.c := FALSE;
      IF routepb.ec = 18 THEN  {18 = Forms code not alphanumeric.
        routepb.flags.forms_code := FALSE;
      ELSEIF routepb.ec = 32 THEN  {32 = Invalid origin type.
        routepb.tid := 0;
        routepb.flags.tid := FALSE;
        routepb.flags.route_to_central_site := TRUE;
      IFEND;
      rhpqrm (routepb);
      IF routepb.ec = 0 THEN
        route_status := successful;
      ELSE
        route_error_occurred := true;
      IFEND;
    ELSE
      route_error_occurred := true;
    IFEND;
    IF route_error_occurred THEN
      CASE routepb.ec OF
      = 6 =
        log_status (dayfile_log_and_display, 'Immediate routing, no file was found');
      = 13 =
        log_status (dayfile_log_and_display, 'Incorrect LID specified, file not routed');
      = 17 =
        log_status (dayfile_log_and_display, 'Incorrect TID specified, file not routed');
      = 28 =
        log_status (dayfile_log_and_display, 'An invalid charge command has been encountered');
        log_status (dayfile_log_and_display, 'Verify that the PROFILC file exists and that it is ok');
      = 37 =
        log_status (dayfile_log_and_display, 'Incorrect service class, file not routed');
      ELSE
        route_error_message (1, 12) := 'Route error ';
        STRINGREP (route_error_message (13, 3), error_code_length, routepb.ec);
        route_error_message (13 + error_code_length, 5) := ' for ';
        dc_name := local_file_info.fet.filename;
        utp$convert_dc_name_to_string (dc_name, route_error_message (18 + error_code_length, 7),
            file_name_length);
        log_status (dayfile_log_and_display, route_error_message);
      CASEND;
      route_status := unsuccessful;
    IFEND;

  ? ELSE
    CONST
      pr_disposition_code = 010000010010(2), { display code for PR }
      input_q_disposition_code = 001001001110(2), { display code for IN }
      a9_ascii_ex_code = 6,
      ascii_ic_code = 1,
      display_code_ic_code = 0,
      nosbe_priority = 4095, {7777B
      a170_repeat_count_max = 1f(16),
      input_flags = 768; {01400B - dont_catalog_input and seven_char_jsn_spec

    TYPE
      route_parameter_block = packed record
{- - - - - - - - - - - - - - - - - - - - - - Word 0
        lfn: 0 .. 3ffffffffff(16),
        ec: 0 .. 3f(16),
        filler1: 0 .. 7ff(16),
        c: boolean,
{- - - - - - - - - - - - - - - - - - - - - - Word 1
        zero: 0 .. 0fff(16),
        forms: 0 .. 0fff(16),
        disp: 0 .. 0fff(16),
        ex: 0 .. 7,
        filler2: boolean,
        ic: 0 .. 3,
        flags: route_flags,
{- - - - - - - - - - - - - - - - - - - - - - Word 2
        source_lid: 0 .. 3ffff(16),
        destination_lid: 0 .. 3ffff(16),
        filler3: 0 .. 0fff(16),
        tid: 0 .. 0fff(16),
{- - - - - - - - - - - - - - - - - - - - - - Word 3
        user_job_name: 0 .. 3ffffffffff(16),
        filler4: 0 .. 1f(16),
        b: boolean,
        priority: 0 .. 0fff(16),
{- - - - - - - - - - - - - - - - - - - - - - Word 4
        pre_dayfile: 0 .. 3ffffffffff(16),
        filler5: boolean,
        rc: 0 .. 1f(16),
        filler6: 0 .. 0fff(16),
{- - - - - - - - - - - - - - - - - - - - - - Word 5
        reserved1: 0 .. 3ffffffffff(16),
        fwa_of_routing_packet: ^CELL,
      recend,

      routing_info_packet = packed record
{ - - - - - - - - - - - - - - - - -  - - - - - - - - - - - Word 0
        fill1: 0 .. 3ffffffffff(16),
        imp_text_length: 0 .. 0fff(16),
        imp_text_word_count: 0 .. 3f(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 1 thru 26
        implicit_routing_text: array [1 .. 26] of packed array [0 .. 9]
            of 0 .. 63,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 27
        fill2: 0 .. 3ffffffffff(16),
        exp_text_length: 0 .. 0fff(16),
        exp_text_word_count: 0 .. 3f(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 28 thru 53
        explicit_routing_text: array [1 .. 26] of integer,
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 54
        fill3: 0 .. 0ffffffffffff(16),
        data_declaration: 0 .. 0fff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 55
        id: 0 .. 3f(16),
        fill4a: 0 .. 3f(16),
        fill4: 0 .. 0ffffffffffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 56
        dest_user_number: 0 .. 3ffffffffff(16),
        fill5: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 57
        dest_family_name: 0 .. 3ffffffffff(16),
        fill6: 0 .. 3ffff(16),
{ - - - - - - - - - - - - - - - - - - - - - - - - - - - - Word 58 thru 63
        reserved58_63: array [1 ..5] of integer,
      recend,

      route_flags = packed record
        return_system_file_name: boolean,
        routing_info_specified: boolean,
        pfc_580_spacing_code: boolean,
        repeat_count: boolean,
        dayfile_attached: boolean,
        return_error_code: boolean,
        pre_dayfile_specified: boolean,
        forms_code: boolean,
        priority: boolean,
        internal_characteristics: boolean,
        external_characteristics: boolean,
        append_unique_char_to_fid: boolean,
        file_ident_specified: boolean,
        disposition_code: boolean,
        dlid_slid: boolean,
        tid: boolean,
        route_to_central_site: boolean,
        end_of_job: boolean,
      recend,
      forms_conversion_buffer_record = record
        case k: integer of
        = 1 =
          dc_string: array [1 .. 1] of packed array [0 .. 9] of 0 .. 3f(16),
        = 2 =
          forms_rec: packed record
            forms: 0 .. 0fff(16),
            filler: 0 .. 0ffffffffffff(16),
          recend,
        casend,
      recend,
      fid_conversion_buffer_record = record
        case l: integer of
        = 1 =
          dc_string: array [1 .. 1] of packed array [0 .. 9] of 0 .. 3f(16),
        = 2 =
          fid_rec: packed record
            fid: 0 .. 3ffffffffff(16),
            filler2: 0 .. 3ffff(16),
          recend,
        casend,
      recend,
      lid_conversion_buffer_record = record
        case m: integer of
        = 1 =
          dc_string: array [1 .. 1] of packed array [0 .. 9] of 0 .. 3f(16),
        = 2 =
          lid_rec: packed record
            lid: 0 .. 3ffff(16),
            filler: 0 .. 3ffffffffff(16),
          recend,
        casend,
      recend,
      tid_conversion_buffer_record = record
        case n: integer of
        = 1 =
          dc_string: array [1 .. 1] of packed array [0 .. 9] of 0 .. 3f(16),
        = 2 =
          tid_rec: packed record
            tid: 0 .. 0fff(16),
            filler: 0 .. 0ffffffffffff(16),
          recend,
        casend,
      recend;

    VAR
      routepb_initial: [STATIC] route_parameter_block :=
        [0, 0, 0, FALSE, 0, 0, 0, 0, FALSE, 0, [TRUE, FALSE, FALSE,
        FALSE, FALSE, TRUE, FALSE, TRUE, FALSE, TRUE, TRUE, FALSE,
        FALSE, TRUE, FALSE, FALSE, TRUE, FALSE], 0, 0, 0, 0, 0, 0,
        FALSE, 0, 0, FALSE, 0, 0, 0, NIL],
      routepb: route_parameter_block,
      routeip_init_block: [STATIC] routing_info_packet :=
{     - - - - implicit routing info - - - -
        [0, 0, 0, [REP 26 OF [REP 10 OF 0]],
{     - - - - explicit routing info - - - -
         0, 0, 0, [REP 26 OF 0],
{     - - - - initialize rest of block (words 55 thru 63)
         0, 0, 0, 0, 0, 0, 0, 0, 0, [REP 5 OF 0]],
      routeip: routing_info_packet,
      forms_conversion_buffer: forms_conversion_buffer_record,
      dc_string_word_index: integer,
      dc_string_char_index: 0 .. 9,
      source_index: ost$string_index,
      eol: boolean,
      fid_conversion_buffer: fid_conversion_buffer_record,
      lid_conversion_buffer: lid_conversion_buffer_record,
      tid_conversion_buffer: tid_conversion_buffer_record,
      error_code_length: 1 .. 2,
      route_error_message: string (27),
      route_error_occurred: boolean,
      dc_name: utt$dc_name,
      route_exec_type: rht$irhf_exec_types,
      str: string(7),
      i: integer,
      j: integer,
      file_name_length: 0 .. 7;

?? SET (LIST := OFF) ??
{ This call to rhxqrm needs to be here so the route_parameter_block
{     TYPE may be used by this XREF.
*copy RHP$ROUTE
?? SET (LIST := ON) ??

{ Insert parameters into the route parameter block.

    route_exec_type := exec_type;
    routepb := routepb_initial;
    routeip := routeip_init_block;
    routepb.lfn := local_file_info.fet.filename;
    routepb.fwa_of_routing_packet := #LOC (routeip);
    CASE route_exec_type OF
    = transmit_exec =
      routepb.flags.forms_code := false;
      routepb.flags.internal_characteristics :=false;
      routepb.flags.external_characteristics :=false;
      routepb.flags.disposition_code := false;
    = receive_exec =
      dc_string_word_index := 1;
      dc_string_char_index := 0;
      source_index := 1;
      eol := FALSE;
      utp$convert_string_to_dc_string (utc$ascii64, forms_conversion_buffer.dc_string, dc_string_word_index,
            dc_string_char_index, queue_file_info.a170.form_code, source_index, eol);
      IF (forms_conversion_buffer.forms_rec.forms = 2925) THEN
        routepb.flags.forms_code := FALSE;         {5555(8)=blanks}
      ELSE
        routepb.flags.forms_code := TRUE;
        routepb.forms := forms_conversion_buffer.forms_rec.forms;
      IFEND;
      routepb.disp := pr_disposition_code;
      routepb.ex := a9_ascii_ex_code;
      routepb.ic := ascii_ic_code;
      routepb.flags.repeat_count := TRUE;
      IF (queue_file_info.a170.logical_identifier.a170_logical_identifier <> ' ') THEN
        routepb.flags.dlid_slid := TRUE;
        dc_string_word_index := 1;
        dc_string_char_index := 0;
        source_index := 1;
        eol := FALSE;
        utp$convert_string_to_dc_string (utc$ascii64, lid_conversion_buffer.dc_string, dc_string_word_index,
              dc_string_char_index, queue_file_info.a170.logical_identifier.a170_logical_identifier,
              source_index, eol);
        routepb.destination_lid := lid_conversion_buffer.lid_rec.lid;
      IFEND;
      IF queue_file_info.a170.implicit_text_size <> 0 THEN
        dc_string_word_index := 1;
        dc_string_char_index := 0;
        source_index := 1;
        eol := FALSE;
        IF queue_file_info.a170.implicit_routing_text (1,6) = 'IRHNBE' THEN
          routepb.flags.tid := TRUE;
          routepb.flags.route_to_central_site := FALSE;
          utp$convert_string_to_dc_string (utc$ascii64, tid_conversion_buffer.dc_string, dc_string_word_index,
                dc_string_char_index, queue_file_info.a170.implicit_routing_text (9,2), source_index, eol);
          routepb.tid := tid_conversion_buffer.tid_rec.tid;
        ELSE
          utp$convert_string_to_dc_string (utc$ascii64, routeip.implicit_routing_text, dc_string_word_index,
                dc_string_char_index, queue_file_info.a170.implicit_routing_text, source_index, eol);
          routeip.imp_text_length := queue_file_info.a170.implicit_text_size;
          routepb.flags.routing_info_specified := TRUE;
        IFEND;
      IFEND;
      IF queue_file_info.a170.repeat_count - 1 <= a170_repeat_count_max THEN
        routepb.rc := queue_file_info.a170.repeat_count - 1;
      ELSE
        routepb.rc := a170_repeat_count_max;
        log_status (dayfile_log, 'repeat_count>A170_repeat_count_max');
        log_status (dayfile_log, 'repeat_count set:=A170_repeat_count_max');
      IFEND;
      routepb.flags.file_ident_specified := TRUE;
      routepb.flags.append_unique_char_to_fid := TRUE;
      str := 'V000000';
      j := 1;
      IF (queue_file_info.a170.user_number_of_owner.a170_owner_user_num (1) >= 'A') AND
         (queue_file_info.a170.user_number_of_owner.a170_owner_user_num (1) <= 'Z') THEN
        str (j) := queue_file_info.a170.user_number_of_owner.a170_owner_user_num (1);
        j := 2;
      IFEND;
      FOR i := 2 TO 7 DO
        IF ((queue_file_info.a170.user_number_of_owner.a170_owner_user_num (i) >= 'A') AND
           (queue_file_info.a170.user_number_of_owner.a170_owner_user_num (i) <= 'Z')) OR
           ((queue_file_info.a170.user_number_of_owner.a170_owner_user_num (i) >= '0') AND
           (queue_file_info.a170.user_number_of_owner.a170_owner_user_num (i) <= '9')) THEN
          str (j) := queue_file_info.a170.user_number_of_owner.a170_owner_user_num (i);
          j := j + 1;
        IFEND;
      FOREND;
      dc_string_word_index := 1;
      dc_string_char_index := 0;
      source_index := 1;
      eol := FALSE;
      utp$convert_string_to_dc_string (utc$ascii64, fid_conversion_buffer.dc_string,
            dc_string_word_index, dc_string_char_index, str, source_index, eol);
      routepb.user_job_name := fid_conversion_buffer.fid_rec.fid;
    = pj_exec, prif_pj_exec =
      routepb.forms := input_flags;
      routepb.disp := input_q_disposition_code;
      routepb.b := TRUE;
      routepb.priority := nosbe_priority;
      routepb.flags.file_ident_specified := TRUE;
      routepb.flags.priority := TRUE;
      routepb.flags.internal_characteristics := FALSE;
      routepb.flags.external_characteristics := FALSE;
    CASEND;

    IF route_exec_type = pj_exec THEN
      rhppjr (routepb);
    ELSE
      rhpqrm (routepb);
    IFEND;
    route_error_occurred := false;
    IF routepb.ec = 0 THEN
      IF route_exec_type = pj_exec THEN
        local_file_info.fet.filename := routepb.lfn;
      IFEND;
      route_status := successful;
    ELSEIF (route_exec_type = receive_exec) THEN { retry receiving the file. }
      routepb.c := FALSE;
      IF routepb.ec = 18 THEN  {18 = Forms code not alphanumeric.
        routepb.flags.forms_code := FALSE;
        rhpqrm (routepb);  { CALL DSP  with no forms code}
      IFEND;
      IF routepb.ec = 0 THEN
        route_status := successful;
      ELSE
        route_error_occurred := true;
      IFEND;
    ELSE
      route_error_occurred := true;
    IFEND;
    IF route_error_occurred THEN
      CASE routepb.ec OF
      = 6 =
        log_status (dayfile_log_and_display, 'Immediate routing, no file was found');
      = 17 =
        log_status (dayfile_log_and_display, 'Incorrect TID specified, file not routed');
      ELSE
        route_error_message (1, 12) := 'Route error ';
        STRINGREP (route_error_message (13, 3), error_code_length, routepb.ec);
        route_error_message (13 + error_code_length, 5) := ' for ';
        dc_name := local_file_info.fet.filename;
        utp$convert_dc_name_to_string (dc_name, route_error_message (18 + error_code_length, 7),
            file_name_length);
        log_status (dayfile_log_and_display, route_error_message);
      CASEND;
      route_status := unsuccessful;
    IFEND;
  ? IFEND

  PROCEND route_file;

MODEND rhmqrf;
*DECK DECK=RHM$SAVE_LINK_USER_DESCRIPTION EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := 'NOS/VE  Remote Host :' ??
MODULE rhm$save_link_user_description;

{ PURPOSE:
{   The purpose of this module is to save a link_user_description.

?? NEWTITLE := '         Global Type Declarations' ??
?? SET (LIST := ON) ??
?? EJECT ??

*copyc OST$STATUS

?? TITLE := '         External Procedures Referenced By This Module' ??
?? SET (LIST := ON) ??
?? EJECT ??

*copyc RHP$LINK_USER_DESCRIPTOR_SAVED

?? TITLE := '         rhp$save_link_user_description' ??
?? SET (LIST := ON) ??
?? EJECT ??
*copyc RHH$SAVE_LINK_USER_DESCRIPTOR
*copyc osv$170_os_type
*copyc osp$set_status_abnormal
*copyc cle$ecc_parameter_list

  PROCEDURE [XDCL, #GATE] rhp$save_link_user_description (user: string (31);
        family: string (31);
        password: string (31);
        charge: string (31);
        project: string (31);
    VAR status: ost$status);

{ Call ring 2 procedure to save link_user_description in job pageable.

    rhp$link_user_descriptor_saved (user, family, password,
        charge, project, status);

  PROCEND rhp$save_link_user_description;

MODEND rhm$save_link_user_description;
*DECK DECK=RHM$SET_STATUS_ABNORMAL EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Remote Host : Set Abnormal Condition' ??
MODULE rhm$set_status_abnormal;

{ PURPOSE:
{   This module contains the procedure to set the error status for certain
{   Remote Host errors.
{
{ DESIGN:
{   Move the code from other Remote Host modules.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc mld$memory_link_declarations
*copyc ost$status
*copyc rhc$condition_limits
?? POP ??
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osv$170_os_type

?? TITLE := '[XDCL, #GATE] rhp$set_status_abnormal', EJECT ??
*copyc rhh$set_status_abnormal

  PROCEDURE [XDCL, #GATE] rhp$set_status_abnormal
    (VAR status: ost$status);

  VAR
    length: integer,
    message: string(3),
    partner_state: string(6),
    partner_state_length: integer;

{ Set up dual state system indicator.

    IF osv$170_os_type = osc$ot7_dual_state_nos THEN
      partner_state := 'NOS';
      partner_state_length := 3;
    ELSE
      partner_state := 'NOS/BE';
      partner_state_length := 6;
    IFEND;

    CASE status.condition OF
    = mlc$message_truncated =
      osp$set_status_abnormal (rhc$remote_host_id, rhe$mismatching_code,
          '', status);
    = mlc$system_name_no_match =
      osp$set_status_abnormal (rhc$remote_host_id,
          rhe$receiver_already_signed_on, partner_state (1,
          partner_state_length), status);
    = mlc$receiver_not_signed_on =
      osp$set_status_abnormal (rhc$remote_host_id,
          rhe$receiver_not_signed_on, partner_state (1, partner_state_length),
          status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
          partner_state (1, partner_state_length), status);
      osp$append_status_parameter (osc$status_parameter_delimiter,
          partner_state (1, partner_state_length), status);
    ELSE
      STRINGREP (message, length, status.condition);
      osp$set_status_abnormal (rhc$remote_host_id,
          rhe$unexpected_ml_error, message (1, length), status);
    CASEND;

  PROCEND rhp$set_status_abnormal;

MODEND rhm$set_status_abnormal;
*DECK DECK=RHM$UPDATE_DUAL_STATE_ENVIRON EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Remote Host Dual State Environment Routines' ??
MODULE rhm$update_dual_state_environ;

{
{ PURPOSE:
{   This module updates the dual state environment to tell what will be displayed
{   if a user enters the DISPLAY_LINK_ATTRIBUTES command.

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_pageable
?? POP ??

  VAR
    rhv$display_charge_link_attr: [XDCL, #GATE, oss$mainframe_pageable] boolean := TRUE,
    rhv$display_family_link_attr: [XDCL, #GATE, oss$mainframe_pageable] boolean := TRUE,
    rhv$display_project_link_attr: [XDCL, #GATE, oss$mainframe_pageable] boolean := TRUE,
    rhv$display_user_link_attr: [XDCL, #GATE, oss$mainframe_pageable] boolean := TRUE;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL,#GATE] rhp$update_dual_state_environ', EJECT ??
*copy rhh$update_dual_state_environ

  PROCEDURE [XDCL, #GATE] rhp$update_dual_state_environ (
     display_charge: boolean;
     display_family: boolean;
     display_project: boolean;
     display_user: boolean);

    rhv$display_charge_link_attr := display_charge;
    rhv$display_family_link_attr := display_family;
    rhv$display_project_link_attr := display_project;
    rhv$display_user_link_attr := display_user;

  PROCEND rhp$update_dual_state_environ;
?? OLDTITLE ??
MODEND rhm$update_dual_state_environ;
*DECK DECK=RHM$WAIT EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := '170 NOS/VE REMOTE HOST' ??
MODULE rhmwit;


?? TITLE := 'EXTERNAL PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc ZN7PRCL

?? TITLE := 'WAIT' ??
?? SET (LIST := ON) ??
?? EJECT ??
{ WAIT
{
{      The purpose of this procedure is to provide a means by which
{ a CYBIL procedure can relinquish use of the CPU for a specified
{ number of milliseconds.
{
{      WAIT (MILLISECONDS)
{
{ MILLISECONDS: (input) This parameter specifies the length of time,
{               in milliseconds, during which CPU use is to be re-
{               linquished by the calling procedure.
{

  PROCEDURE [XDCL] wait (milliseconds: 0 .. 0ffffffff(16));

    CONST
      recall_period = 10; { recall_period is in milliseconds }

    VAR
      recall#: integer;

    FOR recall# := 1 TO (100 + recall_period - 1) DIV recall_period DO
      n7p$recall;
    FOREND;

  PROCEND wait;

MODEND rhmwit;
*DECK DECK=RHM$WRITE_TO_LOCAL_FILE EXPAND=TRUE

*copyc OSD$DEFAULT_PRAGMATS
?? NEWTITLE := '170 NOS/VE REMOTE HOST' ??
MODULE rhmwtf;

?? NEWTITLE := 'GLOBAL TYPE DECLARATIONS' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc RHT$FUNCTION_STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS

?? TITLE := 'EXTERNAL PROCEDURES REFERENCED BY THIS MODULE' ??
?? SET (LIST := OFF) ??
?? EJECT ??
*copyc ZN7PCIO
*copyc RHP$LOG_STATUS

?? TITLE := 'WRITE_TO_LF' ??
?? SET (LIST := ON) ??
?? EJECT ??

{ WRITE_TO_LF
{
{     The purpose of this procedure is to write a data message to
{ a local file.  Included in this function is the responsibility
{ to perform any required reformatting of information; i.e.,
{ change message from interchange format to host target format.
{
{     WRITE_TO_LF (LOCAL_FILE_INFO,DATA_BUFFER,MESSAGE_LENGTH,WRITE_STATUS)
{
{ LOCAL_FILE_INFO: (input) This parameter specifies all information
{     pertinent to file access.
{
{ DATA_BUFFER: (input) This parameter is the area in which the
{     data message is contained.
{
{ MESSAGE_LENGTH: (input) This parameter specifies the length in
{     words of the data message contained in the data buffer.
{
{ WRITE_STATUS: (output) This parameter specifies the write
{     request status.  The following status values may be returned
{     by this request:
{                successful
{                non_fatal_error
{

  PROCEDURE [XDCL] write_to_lf (VAR local_file_info: rht$local_file_info;
    VAR data_buffer: rht$file_data_buffer;
    VAR message_length: mlt$message_length;
    VAR write_status: rht$status);

    TYPE
      a170_writecw_pru_header_rec = packed record
        bits24_59: writecw_pru_header_bits24_59,
        block_length: 0 .. 0ffffff(16),
      recend,
      a170_pru_header_interchange_rec = packed record
        bits22_59: 0 .. 3fffffffff(16),
        block_length: 0 .. 3fffff(16),
      recend,
      writecw_pru_header_bits24_59 = packed record
        p: boolean,
        filler1: 0 .. 0f(16),
        c: boolean,
        pru_size: 0 .. 3ffff(16),
        filler2: 0 .. 3f(16),
        ubc: 0 .. 3f(16),
      recend;

    CONST
      disk_pru_size = 64;

    VAR
      bits24_59: [STATIC] writecw_pru_header_bits24_59 := [FALSE, 0, FALSE, disk_pru_size, 0, 0],
      a170_writecw_pru_header_ptr: ^a170_writecw_pru_header_rec,
      a170_pru_header_interchange_ptr: ^a170_pru_header_interchange_rec,
      header_word_index: 1 .. rhc$max_message_length,
      i: integer;

    header_word_index := 1;
    WHILE header_word_index < message_length DO
      a170_writecw_pru_header_ptr := #LOC (data_buffer [header_word_index]);
      a170_pru_header_interchange_ptr := #LOC (data_buffer [header_word_index]);
      header_word_index := header_word_index + a170_pru_header_interchange_ptr^.block_length + 1;
      a170_writecw_pru_header_ptr^.block_length := (a170_pru_header_interchange_ptr^.block_length - 1) * 5;
      a170_writecw_pru_header_ptr^.bits24_59 := bits24_59;
    WHILEND;
    FOR i := 1 TO 22 DO
      local_file_info.fet.fet1_22 [i] := 0;
    FOREND;
    local_file_info.fet.completed := TRUE;
    local_file_info.fet.error_processing := TRUE;
    local_file_info.fet.first := #LOC (data_buffer);
    local_file_info.fet.next_in := #LOC (data_buffer [message_length + 1]);
    local_file_info.fet.next_out := #LOC (data_buffer);
    local_file_info.fet.limit := #LOC (data_buffer [rhc$max_message_length + 1]);
    n7p$cio (local_file_info.fet, - n7c$cio_writecw);
    IF local_file_info.fet.abnormal_termination <> 0 THEN
      write_status := non_fatal_error;
      log_status (dayfile_log, 'cio error, file receive abort');
    ELSE
      write_status := successful;
    IFEND;
    RETURN;

  PROCEND write_to_lf;

MODEND rhmwtf;
*DECK DECK=RHP$170_MLI_LINK EXPAND=FALSE
{ MLI_LINK
{
{     The purpose of this procedure is to provide all linkage
{ facilities to the MLI for all IRHF applications.  This
{ procedure allows an application to sign on and sign off
{ the MLI.  As part of the sign on facilities, the partner
{ sending application is also identified to the MLI.
{
{     MLI_LINK (DIRECTION,APPLICATION_NAMES)
{
{ DIRECTION: (input) This parameter specifies the linkage
{     direction; i.e., sign_on or sign_off.
{
{ APPLICATION_NAMES: (input) This parameter contains the sending and
{     receiving application names required for MLI communications.
{

 PROCEDURE[XREF] mli_link(
   direction: rht$mli_link_direction;
   VAR application_names: rht$mli_application_names);

?? PUSH (LISTEXT := ON) ??
*copyc rht$function_status
?? POP ??
*DECK DECK=RHP$ACQUIRE_QUEUE_FILE EXPAND=FALSE
{ RHP$ACQUIRE_QUEUE_FILE
{
{     The purpose of this procedure is to acquire a queue file
{ destined for transmission to the remote host.
{
{       RHP$ACQUIRE_QUEUE_FILE (LOCALFILE_INFO,QUEUE_FILE_INFO,
{            LID_LIST, ACQUIRE_STATUS);
{
{ LOCAL_FILE_INFO: (output) This parameter specifies all information
{     pertinent to local file access of the acquired queue file.
{
{ QUEUE_FILE_INFO: (output) This parameter communicates all
{     queue file attributes needed for IRHF routing.
{
{ LID_LIST: (input) This parameter specifies the pointer to the
{     list of lids that a site can route jobs from.
{
{ ACQUIRE_STATUS: (output) This parameter specifies the acquire
{     request status.  The following status values may be returned
{     by this request:
{          not_acquired
{          acquired

  PROCEDURE [XREF] rhp$acquire_queue_file ALIAS 'rhmqfa' (
    VAR local_file_info: rht$local_file_info;
    VAR queue_file_info: rht$queue_file_info;
    lid_list: ^cell;
    VAR acquire_status: rht$acquire_status);

?? PUSH (LISTEXT := ON) ??
*copyc rht$function_status
?? POP ??



*DECK DECK=RHP$ADD_SENDER_OS EXPAND=FALSE

   PROCEDURE [XREF {TS_gate} ] rhp$add_sender_os ALIAS 'rhpadse' (
     application_name: mlt$application_name;
     sender_name: mlt$application_name;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=RHP$CLOSE_B56_FILE EXPAND=FALSE
{
{ RHP$CLOSE_B56_FILE
{
{  This procedure is called by rhp$get/rhp$replace to close a B56 file.
{
{           RHP$CLOSE_B56_FILE (LOCAL_FILE_INFO, STATUS)
{
{  LOCAL_FILE_INFO: (input) This parameter contains all the local
{      file information.
{
{  STATUS: (output) This parameter specifies the status returned to the
{      calling procedure.
{
  PROCEDURE [XREF] rhp$close_b56_file (local_file_info:
    rht$local_file_info;
    VAR status: ost$status);
*DECK DECK=RHP$CLOSE_FILE EXPAND=FALSE
{ RHP$CLOSE_FILE
{
{     The purpose of this procedure is to close a local file.
{
{     RHP$CLOSE_FILE (LOCAL_FILE_INFO)
{
{ LOCAL_FILE_INFO: (input) This parameter specifies all information
{     pertinent to local file access.
{

 PROCEDURE [XREF] rhp$close_file ALIAS 'rhmcls' (
   VAR local_file_info: rht$local_file_info);

?? PUSH (LISTEXT := ON) ??
*copyc RHT$FUNCTION_STATUS
?? POP ??
*DECK DECK=RHP$CONFIRM_SEND_OS EXPAND=FALSE

   PROCEDURE [XREF {TS_gate} ] rhp$confirm_send_os ALIAS 'rhpcose' (
     application_name: mlt$application_name;
     destination_name: mlt$application_name;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=RHP$CPM_FUNCTION_REQUEST EXPAND=FALSE
{ CPMFP
{
{     The purpose of this A170 COMPASS routine is to provide an
{ interface between a CYBIL procedure and the NOS/A170 CPM function
{ processor.  It is assumed the user has placed the CPM function
{ code in register X1, i.e. the CPM function code is the first
{ parameter in the cpmfp call.  Further, it is assumed the user
{ has placed the function parameter in register X2, i.e. the
{ function parameter is the second parameter in the cpmfp call.
{ For further information on CPM, CPM function codes, and function
{ parameters please refer to CPM documentation.
{
{            CPMFP (FUNCTION_CODE,FUNCTION_PARAMETER)
{
{ FUNCTION_CODE: (input) This parameter specifies which CPM function
{                is to be performed.
{
{ FUNCTION_PARAMETER: (input) This parameter specifies either a
{                     function parameter value or a parameter block
{                     address depending on the requirements of the
{                     given function code.
{

 PROCEDURE[XREF] cpmfp(
   function_code: INTEGER;
   function_parameter: ^CELL);         { This XREF defines the cpmfp interface  }
                                       { for CPM function codes having function }
                                       { parameters which are parameter blocks  }
*DECK DECK=RHP$DEFINE_RECEIVE_FILE EXPAND=FALSE
{ RHP$DEFINE_RECEIVE_FILE
{
{      The purpose of this procedure is to determine the existence and
{ access type of the permanent file to be replaced and define the file
{ to which the transfer of data, from the C180 task, will be made.
{
{      RHP$DEFINE_RECEIVE_FILE (PERMANENT_FILE_INFO,FET,PERMANENT_FILE_TYPE,
{                               PERMANENT_FILE_STATUS,DEFINE_CONDITION)
{
{ PERMANENT_FILE_INFO: (input) This parameter contains all information
{                      required to identify the permanent file which is
{                      to be replaced.
{
{ FET (output): This parameter specifies the fet which identifies the file
{     which will receive transmition of the file data from the C180 task.
{
{ PERMANENT_FILE_TYPE: (output) This parameter indicates the access type of
{                      the permanent file, i.e. direct or indirect.
{
{ PERMANENT_FILE_STATUS: (output) This parameter indicates wheather the file
{                        is new or if it already exists.
{
{ DEFINE_CONDITION: (output) This parameter indicates the condition of the
{                   define request.  All conditions are remote host definitions
{                   of A170/NOS permanent file manager condition codes.
{

  PROCEDURE [XREF] rhp$define_receive_file ALIAS 'rhmpdr' (
    permanent_file_info: RECORD
                         permanent_file_name: STRING(7),
                         user_number: STRING(7),
                         password: STRING(7),
                         RECEND;
    VAR fet: n7t$fet;
    VAR permanent_file_type: rht$file_type;
    VAR permanent_file_status: rht$file_status_type;
    VAR define_condition: INTEGER);

?? PUSH (LISTEXT := ON) ??
*copyc RHT$FUNCTION_STATUS



?? POP ??
*DECK DECK=RHP$FETCH_RECEIVE_LIST_OS EXPAND=FALSE

  PROCEDURE [XREF {TS_gate} ] rhp$fetch_receive_list_os ALIAS 'rhpferl'
    (application_name: mlt$application_name;
    sender_name: mlt$application_name;
    VAR receive_list: mlt$receive_list;
    VAR receive_count: mlt$receive_count;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=RHP$FORM_APPLICATION_NAMES EXPAND=FALSE
{ FORM_APPLICATION_NAMES
{
{       The purpose of this procedure is to generate the partner job and
{ requesting task application names for use by the partner job.
{
{       FORM_APPLICATION_NAMES (APPLICATION_NAMES)
{
{ APPLICATION_NAMES: (output) This parameter contains the generated partner job
{                    and requesting task application names.
{

  PROCEDURE[XREF] form_application_names (
    VAR application_names: rht$mli_application_names);

?? PUSH (LISTEXT := ON) ??
*copyc RHT$FUNCTION_STATUS
?? POP ??
*DECK DECK=RHP$GET_DISPLAY_LINK_ATTR_VALUE EXPAND=FALSE
  PROCEDURE [XREF] rhp$get_display_link_attr_value (VAR display_charge: boolean;
     VAR display_family: boolean;
     VAR display_project: boolean;
     VAR display_user: boolean);
*DECK DECK=RHP$GET_DISP_LINK_ATTR_R1 EXPAND=FALSE
  PROCEDURE [XREF] rhp$get_disp_link_attr_r1 (VAR display_charge: boolean;
     VAR display_family: boolean;
     VAR display_project: boolean;
     VAR display_user: boolean);
*DECK DECK=RHP$GET_FILE EXPAND=FALSE

  PROCEDURE [XREF] rhp$get ALIAS 'rhxget' (file: fst$file_reference;
    pf_name: STRING(31);
    conversion: syt$data_conversions;
    user: STRING(9);
    file_cycle: STRING(3);
    file_password: ARRAY [1 .. 2] OF STRING(9);
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_ATTRIBUTES
*copyc fst$file_reference
*copyc OST$STATUS
*copyc syt$data_conversions


?? POP ??
*DECK DECK=RHP$GET_LINK_USER_DESCRIPTOR EXPAND=FALSE

  PROCEDURE [XREF] rhp$get_link_user_descriptor ALIAS 'rhxglu'
   (VAR link_user_descriptor: rht$link_user_descriptor;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$USER_IDENTIFICATION
*copyc RHT$LINK_USER_DESCRIPTOR
*copyc OST$STATUS
?? POP ??
*DECK DECK=RHP$INITIALIZE EXPAND=FALSE
   PROCEDURE[xref] hpp$initialize (heap_p: ^ost$heap;
     l: integer;
     wait_option: BOOLEAN);

*DECK DECK=RHP$LINK_USER_DESCRIPTOR_SAVED EXPAND=FALSE

  PROCEDURE [XREF] rhp$link_user_descriptor_saved  ALIAS 'rhxlus'
   (user: string (31);
    family: string (31);
    password: string (31);
    charge: string (31);
    project: string (31);
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=RHP$LOG_STATUS EXPAND=FALSE
{ LOG_STATUS
{
{      The purpose of this procedure is to send a message to the
{ NOS/A170 B display and/or the user dayfile.
{
{      LOG_STATUS (DESTINATION,STATUS_MESSAGE)
{
{ DESTINATION: (input) This parameter specifies the destination of
{              the message, i.e. the console display and job dayfile
{              or job dayfile only.
{
{ STATUS_MESSAGE: (input) This parameter specifies the ascii message
{                 to be logged.
{

 PROCEDURE[XREF] log_status (
   destination: rht$log_destinations;
   status_message: rht$log_status_message);

?? PUSH (LISTEXT := ON) ??
*copyc RHT$FUNCTION_STATUS
?? POP ??
*DECK DECK=RHP$MAP_PFM_CODE_TO_RH_CODE EXPAND=FALSE
{ MAP_PFM_CODE_TO_RH_CODE
{
{         The purpose of this procedure is to provide a mapping from the
{ given A170/NOS permanent file manager error code to a remote host error
{ code.
{
{         MAP_PFM_CODE_TO_RH_CODE (PFM_CODE,RH_CODE)
{
{ PFM_CODE: (input) This parameter contains the pfm error code which is
{           to be mapped into the remote host error code.
{
{ RH_CODE: (output) This parameter contains the remote host error code
{          which is the result of the mapping.
{

  PROCEDURE[XREF] map_pfm_code_to_rh_code (
    pfm_code: 0..0ff(16);
    VAR rh_code: INTEGER);
*DECK DECK=RHP$MLI_GET_PERMANENT_FILE EXPAND=FALSE

  PROCEDURE [XREF] rhp$mli_get_permanent_file
    (permanent_file_name: array [1 .. 7] of rht$c180_ascii812_word;
    user_id: array [1 .. 2] of rht$c180_ascii812_word;
    cycle_number: array [1 .. 1] of rht$c180_ascii812_word;
    file_password: array [1 .. 2] of array [1 .. 2] of rht$c180_ascii812_word;
    local_file_info: rht$local_file_info;
    conversion: syt$data_conversions;
    VAR status: ost$status);

*copyc rhd$nos_ve_types
*copyc ost$user_identification
*copyc syt$data_conversions
*DECK DECK=RHP$MLI_LINK EXPAND=FALSE
{ MLI_LINK
{
{     The purpose of this procedure is to provide all linkage
{ facilities to the MLI for all IRHF applications.  This
{ procedure allows an application to sign on and sign off
{ the MLI.  As part of the sign on facilities, the partner
{ sending application is also identified to the MLI.
{
{     MLI_LINK (DIRECTION,APPLICATION_NAMES,STATUS)
{
{ DIRECTION: (input) This parameter specifies the linkage
{     direction; i.e., sign_on or sign_off.
{
{ APPLICATION_NAMES: (input) This parameter contains the sending and
{     receiving application names required for MLI communications.
{
{ STATUS: (output) This parameter returns the success or failure of
{     the application sign on or sign off.

 PROCEDURE[XREF] mli_link(
   direction: rht$mli_link_direction;
   VAR application_names: rht$mli_application_names;
   VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc rhd$nos_ve_types
*copyc ost$status
?? POP ??
*DECK DECK=RHP$MLI_REPLACE_PERMANENT_FILE EXPAND=FALSE

  PROCEDURE [XREF] rhp$mli_replace_permanent_file
    (permanent_file_name: array [1 .. 7] of rht$c180_ascii812_word;
    user_id: array [1 .. 2] of rht$c180_ascii812_word;
    cycle_number: array [1 .. 1] of rht$c180_ascii812_word;
    file_password: array [1 .. 2] of array [1 .. 2] of rht$c180_ascii812_word;
    local_file_info: rht$local_file_info;
    conversion: syt$data_conversions;
    VAR status: ost$status);

*copyc rhd$nos_ve_types
*copyc ost$user_identification
*copyc syt$data_conversions
*DECK DECK=RHP$OPEN_B56_FILE EXPAND=FALSE
{
{ RHP$OPEN_B56_FILE
{
{  This procedure is called by rhp$get/rhp$replace to open a B56 file.
{
{           RHP$OPEN_B56_FILE (FILE, FILE_ATTACHMENT_OPTIONS, LOCAL_FILE_INFO,
{               STATUS);
{
{  FILE: (input) This parameter specifies the file to be opened.
{
{  FILE_ATTACHMENT_OPTIONS: (input) This parameter contains the access
{      requirements to get the file.
{
{  LOCAL_FILE_INFO: (input,output) This parameter contains all the local
{      file information.
{
{  STATUS: (output) This parameter specifies the status returned to the
{      calling procedure.
{
  PROCEDURE [XREF] rhp$open_b56_file (
    file: fst$file_reference;
    file_attachment_options: rht$attachment_option;
    VAR local_file_info: rht$local_file_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc rht$attachment_option
?? POP ??
*DECK DECK=RHP$OPEN_FILE EXPAND=FALSE
{ RHP$OPEN_FILE
{
{     The purpose of this procedure is to open the local file identified by local_file_info.
{
{     RHP$OPEN_FILE (LOCAL_FILE_INFO)
{
{ LOCAL_FILE_INFO: (input) This parameter specifies all information
{     required for local file identification and access.
{

  PROCEDURE [XREF] rhp$open_file ALIAS 'rhmopn' (
    VAR local_file_info: rht$local_file_info);

?? PUSH (LISTEXT := ON) ??
*copyc RHT$FUNCTION_STATUS
?? POP ??
*DECK DECK=RHP$PARTNER_JOB_EXEC EXPAND=FALSE
{ PARTNER_JOB_EXEC
{
{       This procedure receives and processes partner job function requests.
{
{       PARTNER_JOB_EXEC(APPLICATION_NAMES,EXEC_STATUS)
{
{ APPLICATION_NAMES: (input) This parameter contains the sending and receiving
{                    application names required for MLI communication.
{
{ EXEC_STATUS: (output) This parameter indicates to the calling procedure
{              the processing status of the executive.  The following status
{              values may be returned:     beginning
{                                          middle
{                                          unrecoverable_error
{

  PROCEDURE[XREF] partner_job_exec (
    VAR application_names: rht$mli_application_names;
    VAR exec_status: rht$exec_status);

?? PUSH (LISTEXT := ON) ??
*copyc RHT$FUNCTION_STATUS
?? POP ??
*DECK DECK=RHP$PAUSE EXPAND=FALSE
{ PAUSE
{
{        The purpose of this A170 CYBIL procedure is to set the pause
{ flag in RA+0 and recall until the flag is cleared.
{
{        PAUSE
{

  PROCEDURE [XREF] pause;
*DECK DECK=RHP$QF_170_RECEIVE_EXEC EXPAND=FALSE
 PROCEDURE [XREF] rhp$queue_file_receive_exec ALIAS 'rhmqfr' (VAR
  application_names: rht$mli_application_names;
    VAR exec_status: rht$exec_status);

?? PUSH (LISTEXT := ON) ??



*copyc rht$function_status
?? POP ??
*DECK DECK=RHP$QF_170_TRANSMIT_EXEC EXPAND=FALSE
 PROCEDURE [XREF] rhp$queue_file_transmit_exec ALIAS 'rhmqft' (VAR
  application_names: rht$mli_application_names;
  VAR exec_status: rht$exec_status;
  lid_list: ^cell);

?? PUSH (LISTEXT := ON) ??
*copyc rht$function_status
?? POP ??
*DECK DECK=RHP$QUEUE_FILE_RECEIVE_EXEC EXPAND=FALSE

  PROCEDURE [XREF] rhp$queue_file_receive_exec ALIAS 'rhmqre' (VAR
    application_names: rht$mli_application_names;
    data_buffer_pointer: rht$file_data_buffer_pointer;
    VAR exec_status: rht$exec_status);

?? PUSH (LISTEXT := ON) ??



*copyc rhd$nos_ve_types
?? POP ??
*DECK DECK=RHP$QUEUE_FILE_TRANSMIT_EXEC EXPAND=FALSE

  PROCEDURE [XREF] rhp$queue_file_transmit_exec ALIAS 'rhmqte'
    (    queue_file_password: jmt$queue_file_password;
     VAR application_names: rht$mli_application_names;
         data_buffer_pointer: rht$file_data_buffer_pointer;
     VAR files_processed: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$queue_file_password
*copyc rhd$nos_ve_types
?? POP ??
*DECK DECK=RHP$RECEIVE_MESSAGE_OS EXPAND=FALSE

   PROCEDURE [XREF {TS_gate} ] rhp$receive_message_os ALIAS 'rhpreme' (
     application_name: mlt$application_name;
     VAR arbitrary_info: mlt$arbitrary_info;
     signal: mlt$signal;
     message_area: mlt$message_ptr;
     VAR message_length: mlt$message_length;
     message_area_length: mlt$message_length;
     receive_index: mlt$receive_index;
     VAR sender_name: mlt$application_name;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=RHP$REPLACE EXPAND=FALSE

  PROCEDURE [XREF] rhp$replace ALIAS 'rhxrep' (file: fst$file_reference;
    pf_name: STRING(31);
    conversion: syt$data_conversions;
    user: STRING(9);
    file_cycle: STRING(3);
    file_password: ARRAY [1 .. 2] OF STRING(9);
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$FILE_ATTRIBUTES
*copyc fst$file_reference
*copyc OST$STATUS
*copyc SYT$DATA_CONVERSIONS


?? POP ??
*DECK DECK=RHP$REPLACE_PERMANENT_FILE EXPAND=FALSE
{ RHG$REPLACE_PERMANENT_FILE
{
{       The purpose of this procedure is to receive transmission of a file
{ from the application identified by the destination field of application_
{ names and perform all work necessary to accomplish an A170/NOS permanent
{ file REPLACE of the file identified by pf_info with the transmitted file.
{
{       RHG$REPLACE_PERMANENT_FILE (PERMANENT_FILE_INFO,APPLICATION_NAMES)
{
{ PERMANENT_FILE_INFO: (input) This parameter contains all information
{                      required to identify the permanent file on which
{                      the permanent file function is to be performed.
{
{ APPLICATION_NAMES: (input) This parameter identifies the application
{                    performing the permanent file function and the
{                    application to which the permanent file is transfered.
{

  PROCEDURE [XREF] rhp$replace_permanent_file ALIAS 'rhmpfr' (
    permanent_file_info: RECORD
                         permanent_file_name: STRING(7),
                         user_number: STRING(7),
                         password: STRING(7),
                         RECEND;
    VAR application_names: rht$mli_application_names);

?? PUSH (LISTEXT := ON) ??
*copyc RHT$FUNCTION_STATUS
?? POP ??
*DECK DECK=RHP$RETURN_FILE EXPAND=FALSE
{ RETURN_FILE
{
{     The purpose of this procedure is to provide a means by which
{ a CYBIL procedure can return a local file, i.e., release file
{ control from the calling job.
{
{       RETURN_FILE (LOCAL_FILE_INFO)
{
{ LOCAL_FILE_NAME: (input) This parameter specifies all information
{      pertinent to local file access.
{

 PROCEDURE[XREF] return_file (
   VAR local_file_info: rht$local_file_info);

?? PUSH (LISTEXT := ON) ??
*copyc RHT$FUNCTION_STATUS
?? POP ??
*DECK DECK=RHP$ROUTE EXPAND=FALSE
{ RHPQRM
{
{         The purpose of this A170 COMPASS routine is to provide an
{ interface between a CYBIL procedure and the NOS/A170 ROUTE macro.
{ It is assumed the user has placed the address of the ROUTE parameter
{ block in register X1, i.e. the ROUTE parameter block is the first
{ parameter of the RHPQRM call.
{
{                RHPQRM (ROUTE_PARAMETER_BLOCK)
{
{ ROUTE_PARAMETER_BLOCK: (input) This parameter specifies the address
{                        of the ROUTE parameter block.
{

  PROCEDURE [XREF] rhpqrm ALIAS 'rhpqrm' (
   VAR ROUTE_pb: ROUTE_parameter_block);

{
{         The purpose of this A170 COMPASS routine is to provide an
{ interface between a CYBIL procedure and NOS/170 partner job ROUTE.
{ It is assumed the user has placed the address of the ROUTE parameter
{ block in register X1, i.e. the ROUTE parameter block is the first
{ parameter of the RHPPJR call.
{
{                RHPPJR (ROUTE_PARAMETER_BLOCK)
{
{ ROUTE_PARAMETER_BLOCK: (input) This parameter specifies the address
{                        of the ROUTE parameter block.
{

  PROCEDURE [XREF] rhppjr ALIAS 'rhppjr' (
   VAR ROUTE_pb: ROUTE_parameter_block);
*DECK DECK=RHP$ROUTE_FILE EXPAND=FALSE
{ ROUTE_FILE
{
{     The purpose of this procedure is to provide a means by which
{ a CYBIL procedure can route a local file to a system queue.
{
{           ROUTE_FILE (QUEUE_TYPE,LOCAL_FILE_INFO,QUEUE_FILE_INFO,ROUTE_STATUS)
{
{ QUEUE_TYPE: (input) This parameter specifies the destination queue
{             to which the file is to be routed.
{
{ LOCAL_FILE_INFO: (input) This parameter specifies all information
{                  pertinent to local file access.
{
{ QUEUE_FILE_INFO: (input) This parameter communicates all queue file
{                  attributes needed for IRHF routing.
{
{ ROUTE_STATUS: (output) This parameter indicates to the calling
{               procedure the completion status of the route function,
{               i.e. the success or failure of the route.  The
{               following status values may be returned by this
{               request:     unsuccessful
{                            successful
{

 PROCEDURE[XREF] route_file(
   exec_type: rht$irhf_exec_types;
   VAR local_file_info: rht$local_file_info;
   queue_file_info: rht$queue_file_info;
   VAR route_status: rht$function_status);

 PROCEDURE [XREF] request_queue_device ALIAS 'rhprqd' ( lfn: integer);

?? PUSH (LISTEXT := ON) ??
*copyc RHT$FUNCTION_STATUS
?? POP ??
*DECK DECK=RHP$SAVE_LINK_USER_DESCRIPTION EXPAND=FALSE

  PROCEDURE [XREF] rhp$save_link_user_description ALIAS 'rhxslu'
        (user: string(31);
         family: string(31);
         password: string(31);
         charge: string(31);
         project: string(31);
         VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=RHP$SEND_MESSAGE_OS EXPAND=FALSE

   PROCEDURE [XREF {TS_gate} ] rhp$send_message_os ALIAS 'rhpseme' (
     application_name: mlt$application_name;
     arbitrary_info: mlt$arbitrary_info;
     signal: mlt$signal;
     message_area: mlt$message_ptr;
     message_length: mlt$message_length;
     destination_name: mlt$application_name;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=RHP$SEND_PJ_FUNCTION_REQUEST EXPAND=FALSE
{ SEND_PJ_FUNCTION_REQUEST
{
{        The purpose of this procedure is to transmit a partner job function
{ request to the partner job function processor and receive the results of
{ the processing of the requested function.
{
{        SEND_PJ_FUNCTION_REQUEST (PJ_FUNCTION,FAMILY_NAME,PJ_IDENTIFIER,CONDITION)
{
{ PJ_FUNCTION: (input) This parameter specifies the partner job function to
{              be performed.
{
{ FAMILY_NAME: (input) This parameter specifies the users family and is used
{              for the submit_pj function to acquire job validation info-
{              rmation from the link_user_descriptor.
{
{ PJ_IDENTIFIER: (input/output) This parameter is used to specify the partner
{                job identifier.  PJ_IDENTIFIER is returned (output) from a
{                submit_pj function.  PJ_IDENTIFIER must be supplied (input)
{                by the user for a status_pj pj_function.
{
{ CONDITION: (output) This parameter indicates the condition of the partner
{            job function request and the partner job function.
{

  PROCEDURE[XREF] send_pj_function_request (
    pj_function: rht$pj_functions;
    family_name: ost$family_name;
    VAR pj_identifier: INTEGER;
    VAR condition: INTEGER);

?? PUSH (LISTEXT := ON) ??
*copyc RHT$FUNCTION_STATUS
*copyc OST$USER_IDENTIFICATION
?? POP ??
*DECK DECK=RHP$SET_STATUS_ABNORMAL EXPAND=FALSE

*copyc rhh$set_status_abnormal

  PROCEDURE [XREF {TS_gate} ] rhp$set_status_abnormal
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=RHP$SIGN_ON_AND_OFF_OS EXPAND=FALSE

      PROCEDURE [XREF {TS_gate} ] rhp$sign_on_os ALIAS 'rhpsion' (
       application_name:mlt$application_name;
       max_messages: mlt$max_messages;
       VAR unique_application_name: mlt$application_name;
       VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??

   PROCEDURE [XREF {TS_gate} ] rhp$sign_off_os ALIAS 'rhpsiof' (
     application_name: mlt$application_name;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MLD$MEMORY_LINK_DECLARATIONS
?? POP ??
*DECK DECK=RHP$UPDATE_DUAL_STATE_ENVIRON EXPAND=FALSE
  PROCEDURE [XREF] rhp$update_dual_state_environ (display_charge: boolean;
     display_family: boolean;
     display_project: boolean;
     display_user: boolean);
*DECK DECK=RHP$VALIDATE_USER EXPAND=FALSE
{ VALIDATE_NOS_A170_USER_INFO
{
{      The purpose of this procedure is to determine the validity of
{ a given users NOS/A170 identification to the system.
{
{      VALIDATE_NOS_A170_USER_NUMBER (USER_NUMBER,PASSWORD,FAMILY_NAME,VALIDITY)
{
{ USER_NUMBER: (input) This parameter specifies the user number whos validity
{              is to be determined.
{
{ PASSWORD: (input) This parameter specifies the password whos validity is to
{           be determined.
{
{ FAMILY_NAME: (input) This parameter specifies the family name of the user
{              number and password whos validity is to be determined.
{
{ VALIDITY: (output) This parameter indicates the validity of the given user
{           identification.
{

 PROCEDURE[XREF] validate_NOS_A170_user_info (
   user_number: STRING(7);
   password: STRING(7);
   family_name: STRING(7);
   VAR validity: BOOLEAN);
*DECK DECK=RHP$WAIT EXPAND=FALSE
{ WAIT
{
{      The purpose of this procedure is to provide a means by which
{ a CYBIL procedure can relinquish use of the CPU for a specified
{ number of milliseconds.
{
{      WAIT (MILLISECONDS)
{
{ MILLISECONDS: (input) This parameter specifies the length of time,
{               in milliseconds, during which CPU use is to be re-
{               linquished by the calling procedure.
{

 PROCEDURE[XREF] wait (
   milliseconds: 0..0ffffffff(16));
*DECK DECK=RHT$ATTACHMENT_OPTION EXPAND=FALSE

    TYPE
      rht$attachment_option = array [1 .. 5] of fst$attachment_option;

*copyc fst$attachment_option
*DECK DECK=RHT$FILE_CYCLE_ATTRIBUTE EXPAND=FALSE

    TYPE
      rht$file_cycle_attribute = array [1 .. 3] of fst$file_cycle_attribute;

*copyc fst$file_cycle_attribute
*DECK DECK=RHT$FUNCTION_STATUS EXPAND=FALSE
*copyc MLD$MEMORY_LINK_DECLARATIONS
*copyc zn7tfet
*copyc AMT$FILE_IDENTIFIER
*copyc AMT$LOCAL_FILE_NAME
*copyc JMT$ROUTING_EXTERNAL
*copyc RHC$CONSTANTS
  { IRHF TYPES
  {
  {

  TYPE
    rht$function_status = (successful, non_fatal_error, unsuccessful,
      fatal_error),
    rht$status = successful .. non_fatal_error,
    rht$exec_status = (beginning, middle, unrecoverable_error),
    rht$acquire_status = (acquired, not_acquired),
    rht$dc_lid_string = packed record
      lid1: 0 .. 3fffffff(16),
      lid2: 0 .. 3fffffff(16),
    recend,
    rht$lid_list = array [1 .. 10] of rht$dc_lid_string,
    rht$mli_link_direction = (on, off),
    rht$file_data_buffer = array [1 .. rhc$max_message_length + 1] of integer,
    rht$file_data_buffer_pointer = ^rht$file_data_buffer,
    rht$request_type = (get, replace),
    rht$irhf_exec_types = (transmit_exec, receive_exec, prif_pj_exec, pj_exec),
    rht$machine_types = (a170, c180, nuder),
    rht$log_destinations = (dayfile_log, dayfile_log_and_display, display_in_system_log),
    rht$log_status_message = string ( * ),
    rht$data_message_length = mlt$message_length,
    rht$pf_functions = rhc$get_pf .. rhc$replace_pf,
    rht$permanent_file_types = (indirect_access, direct_access),
    rht$file_type = (direct, indirect),
    rht$file_status_type = (new, old),
    rht$trans_status_type = (ok, a170_error, c180_error),
    rht$pj_functions = rhc$submit_pj .. rhc$status_pj,
    rht$pj_status = rhc$job_not_found .. rhc$job_found,
    rht$ascii812_char = packed record
      filler: 0 .. 0f(16),
      ascii88_char: char,
    recend,
    rht$c180_ascii812_word = packed record
      filler: 0 .. 0f(16),
      ascii812_char1: rht$ascii812_char,
      ascii812_char2_5: packed array [2 .. 5] of rht$ascii812_char,
    recend,
    rht$mli_application_name = record
      case name_ref_type: (application_name, a170_id, c180_id) of
      = application_name =
        application_name: mlt$application_name,
      = a170_id =
        a170_id: packed record
          application_identifier: 0 .. 37777777(16),
          filler: 0 .. 3fffffff(16),
        recend,
      = c180_id =
        c180_id: packed record
          filler1: 0 .. 0f(16),
          application_identifier: 0 .. 3fffffff(16),
          filler2: 0 .. 3fffffff(16),
        recend,
      casend,
    recend,
    rht$mli_application_names = record
      application: rht$mli_application_name,
      destination: rht$mli_application_name,
    recend,
    rht$mli_message_info = record
      message_area: mlt$message_ptr,
      message_area_length: mlt$message_length,
      message_length: mlt$message_length,
      arbitrary_info: mlt$arbitrary_info,
    recend,
    rht$local_file_info = record
      case machine_type: rht$machine_types of
      = a170 =
        fet: n7t$fet,
      = c180 =
        local_file_name: amt$local_file_name,
        file_identifier: amt$file_identifier,
      casend,
    recend,
    rht$queue_file_info = record
      case machine_type: rht$machine_types of
      = a170 =
        a170: record
          file_name: record
            case machine_type: rht$machine_types of
            = a170 =
              a170_job_name: string (7),
            = c180 =
              c180_file_name: string (31),
            casend,
          recend,
          form_code: string (2),
          repeat_count: 0 .. jmc$routing_repeat_count_max,
          family_name_of_creator: record
            case machine_type: rht$machine_types of
            = a170 =
              a170_creator_family_name: string (9),
            = c180 =
              c180_creator_family_name: string (31),
            casend,
          recend,
          user_number_of_owner: record
            case machine_type: rht$machine_types of
            = a170 =
              a170_owner_user_num: string (9),
            = c180 =
              c180_owner_user_num: string (31),
            casend,
          recend,
          user_password: string(31),
          user_charge_number: string(31),
          user_project_number: string(31),
          original_family_name: record
            case machine_type: rht$machine_types of
            = a170 =
              a170_original_family_name: string (9),
            = c180 =
              c180_original_family_name: string (31),
            casend,
          recend,
          original_user_name: record
            case machine_type: rht$machine_types of
            = a170 =
              a170_original_user_name: string (9),
            = c180 =
              c180_original_user_name: string (31),
            casend,
          recend,
          original_charge_number: string(31),
          original_project_number: string(31),
          logical_identifier: record
            case machine_type: rht$machine_types of
            = a170 =
              a170_logical_identifier: string (3),
            = c180 =
              c180_logical_identifier: string (31),
            casend,
          recend,
          implicit_text_size: 0 .. 0fff(16),
          implicit_routing_text: string(256),
          dual_state_routing_text_size: 0 .. 0fff(16),
          dual_state_routing_text: string(255),
        recend,
      = c180 =
        c180: packed record
          file_name: record
            case machine_type: ALIGNED [0 MOD 8] rht$machine_types of
            = a170 =
              a170_job_name: ALIGNED [0 MOD 8] array [1 .. 2] of
                rht$c180_ascii812_word,
            = c180 =
              c180_file_name: ALIGNED [0 MOD 8] array [1 .. 7] of
                rht$c180_ascii812_word,
            casend,
          recend,
          filler2: 0 .. 0f(16),
          form_code_char1: rht$ascii812_char,
          form_code_char2: rht$ascii812_char,
          filler3: 0 .. 0fffffffff(16),
          repeat_count: integer,
          family_name_of_creator: record
            case machine_type: ALIGNED [0 MOD 8] rht$machine_types of
            = a170 =
              a170_creator_family_name: ALIGNED [0 MOD 8] array [1 .. 2] of
                rht$c180_ascii812_word,
            = c180 =
              c180_creator_family_name: ALIGNED [0 MOD 8] array [1 .. 7] of
                rht$c180_ascii812_word,
            casend,
          recend,
          user_number_of_owner: record
            case machine_type: ALIGNED [0 MOD 8] rht$machine_types of
            = a170 =
              a170_owner_user_num: ALIGNED [0 MOD 8] array [1 .. 2] of
                rht$c180_ascii812_word,
            = c180 =
              c180_owner_user_num: ALIGNED [0 MOD 8] array [1 .. 7] of
                rht$c180_ascii812_word,
            casend,
          recend,
          user_password: ALIGNED [0 MOD 8] array [1 .. 7] of
            rht$c180_ascii812_word,
          user_charge_number: ALIGNED [0 MOD 8] array [1 .. 7] of
            rht$c180_ascii812_word,
          user_project_number: ALIGNED [0 MOD 8] array [1 .. 7] of
            rht$c180_ascii812_word,
          original_family_name: record
            case machine_type: ALIGNED [0 MOD 8] rht$machine_types of
            = a170 =
              a170_original_family_name: ALIGNED [0 MOD 8] array [1 .. 2] of
                rht$c180_ascii812_word,
            = c180 =
              c180_original_family_name: ALIGNED [0 MOD 8] array [1 .. 7] of
                rht$c180_ascii812_word,
            casend,
          recend,
          original_user_name: record
            case machine_type: ALIGNED [0 MOD 8] rht$machine_types of
            = a170 =
              a170_original_user_name: ALIGNED [0 MOD 8] array [1 .. 2] of
                rht$c180_ascii812_word,
            = c180 =
              c180_original_user_name: ALIGNED [0 MOD 8] array [1 .. 7] of
                rht$c180_ascii812_word,
            casend,
          recend,
          original_charge_number: ALIGNED [0 MOD 8] array [1 .. 7] of
            rht$c180_ascii812_word,
          original_project_number: ALIGNED [0 MOD 8] array [1 .. 7] of
            rht$c180_ascii812_word,
          logical_identifier: record
            case machine_type: ALIGNED [0 MOD 8] rht$machine_types of
            = a170 =
              a170_logical_identifier: ALIGNED [0 MOD 8] array [1 .. 1] of
                rht$c180_ascii812_word,
            = c180 =
              c180_logical_identifier: ALIGNED [0 MOD 8] array [1 .. 7] of
                rht$c180_ascii812_word,
            casend,
          recend,
          filler9a: 0 .. 0fffffffffff(16),
          filler9b: 0 .. 0ff(16),
          implicit_text_size: 0 .. 0fff(16),
          implicit_routing_text: ALIGNED [0 MOD 8] array [1 .. 52] of
               rht$c180_ascii812_word,
          fillera10: 0 .. 0f(16),
          filler10: 0 .. 0ffffffffffff(16),
          dual_state_routing_text_size: 0 .. 0fff(16),
          dual_state_routing_text: ALIGNED [0 MOD 8] array [1 .. 51] of
            rht$c180_ascii812_word,
        recend,
      = nuder =
        equalizer: ALIGNED [0 MOD 8] array [1 .. 184] of integer,
      casend,
    recend;

{ ***************************** END OF COMMON DECK RHDTYPE
{**************************** }
*DECK DECK=RHT$LINK_USER_DESCRIPTOR EXPAND=FALSE

{ Link_user type declarations. }




  TYPE
      rht$link_user_descriptor = RECORD
        next_lud_p: ^rht$link_user_descriptor,
        user: string(31),
        family: string(31),
        password: string(31),
        charge: string(31),
        project: string(31),
      RECEND;

*DECK DECK=RHT$PERMANENT_FILE_NAME EXPAND=FALSE

  TYPE
    rht$permanent_file_name = ost$name,
    rht$password = ost$name,
    rht$user_name = ost$name,
    rht$family_name = ost$name,
    rht$conversion = ost$name;
*DECK DECK=RHV$APPLICATION_NAME EXPAND=FALSE
var
rhv$application_name: [xref] mlt$application_name;
??push(list:=off)??
*copyc MLD$MEMORY_LINK_DECLARATIONS
??pop??
*DECK DECK=RHV$DISPLAY_CHARGE_LINK_ATTR EXPAND=FALSE
  VAR
    rhv$display_charge_link_attr: [XREF] boolean;

*DECK DECK=RHV$DISPLAY_FAMILY_LINK_ATTR EXPAND=FALSE
  VAR
    rhv$display_family_link_attr: [XREF] boolean;

*DECK DECK=RHV$DISPLAY_PROJECT_LINK_ATTR EXPAND=FALSE
  VAR
    rhv$display_project_link_attr: [XREF] boolean;

*DECK DECK=RHV$DISPLAY_USER_LINK_ATTR EXPAND=FALSE
  VAR
    rhv$display_user_link_attr: [XREF] boolean;

*DECK DECK=RHV$SIGNAL EXPAND=FALSE
var
rhv$signal: [xref] mlt$signal;
??push(list:=off)??
*copyc MLD$MEMORY_LINK_DECLARATIONS
??pop??
*DECK DECK=RMC$ACTION_MESSAGES EXPAND=FALSE
  CONST
    rmc$action_messages = 'RMM$ACTION_MESSAGES            ';
*DECK DECK=RMC$CONDITION_CODE_LIMITS EXPAND=FALSE
CONST
*IF $true(osv$unix)
  rmc$min_ecc = (($INTEGER ('R') * 100(16)) + $INTEGER ('M')) * 10000(16),
*ELSE
  rmc$min_ecc = (($INTEGER ('R') * 100(16)) + $INTEGER ('M')) * 1000000(16),
*IFEND

  rmc$min_ecc_resource_management = rmc$min_ecc,
  rmc$max_ecc_resource_management = rmc$min_ecc_resource_management + 9999,

  rmc$resource_management_id = 'RM';

*DECK DECK=RMC$DEDICATED_MAINTENANCE EXPAND=FALSE
  CONST
    rmc$dedicated_maintenance = 'RMM$DEDICATED_MAINT            ';
*DECK DECK=RMC$DEFAULT_ALLOCATION_SIZE EXPAND=FALSE
 CONST
    rmc$default_allocation_size = 16384;
*DECK DECK=RMC$EXTEND_LABELED_VOL_LIST EXPAND=FALSE
  CONST
    rmc$extend_labeled_vol_list = 'RMM$EXTEND_LABELED             ';
*DECK DECK=RMC$EXTEND_UNLABELED_VOL_LIST EXPAND=FALSE
  CONST
    rmc$extend_unlabeled_vol_list = 'RMM$EXTEND_UNLABELED           ';
*DECK DECK=RMC$EXTERNAL_VSN_SIZE EXPAND=TRUE

  CONST
    rmc$external_vsn_size = 6;
*DECK DECK=RMC$GENERIC_ERROR_RECOVERY EXPAND=FALSE
  CONST
    rmc$generic_error_recovery = 'RMM$GENERIC_ERR_REC            ';
*DECK DECK=RMC$HELP_MODULE_SEED EXPAND=FALSE
  CONST
    rmc$help_module_seed = 'RMM$RESOURCE_HELP              ';

*DECK DECK=RMC$HIGHEST_UNIT_TYPE EXPAND=FALSE
  CONST
    rmc$highest_unit_type = rmc$cartridge;

*copyc rmt$tape_unit_types
*DECK DECK=RMC$INCORRECT_RECORDED_VSN EXPAND=FALSE
  CONST
    rmc$incorrect_recorded_vsn = 'RMM$INCORRECT_RVSN             ';
*DECK DECK=RMC$INITV_MENU_NAMES EXPAND=FALSE

  CONST
     rmc$crebuv_buv_menu = 'RMM$CREBUV_BUV_MENU            ',
     rmc$crebuv_le_menu = 'RMM$CREBUV_LE_MENU             ',
     rmc$crebuv_lu_menu = 'RMM$CREBUV_LU_MENU             ',
     rmc$crebuv_urv_menu = 'RMM$CREBUV_URV_MENU            ',
     rmc$crebuv_uv_menu = 'RMM$CREBUV_UV_MENU             ',
     rmc$initv_ul_menu = 'RMM$INITV_UL_MENU              ',
     rmc$initv_re_menu = 'RMM$INITV_RE_MENU              ',
     rmc$initv_exp_menu = 'RMM$INITV_EXP_MENU             ',
     rmc$initv_unexp_menu = 'RMM$INITV_UNEXP_MENU           ';
*DECK DECK=RMC$JOB_STATUS_MESSAGES EXPAND=FALSE
  CONST
    rmc$job_status_messages = 'RMM$JOB_STATUS_MSGS            ';
*DECK DECK=RMC$LABELED_EXTERNAL_TAPES EXPAND=FALSE
  CONST
    rmc$labeled_external_tapes = 'LABELED_EXTERNAL_TAPES         ';

*DECK DECK=RMC$LIMIT_CONSTANTS EXPAND=FALSE
  CONST
    rmc$max_sen = 999,
    rmc$max_iou_no = 1,
    rmc$max_pp_no = 19,
    rmc$max_channel_no = 3f(16),
    rmc$max_controller_no = 7,
    rmc$max_cpu_no = 1,
    rmc$max_mainframe_no = 3,
    rmc$max_device_no = 0ff(16),
    rmc$max_memory_size = 0fffffff(16);
*DECK DECK=RMC$LOADPOINT_ERROR_RECOVERY EXPAND=FALSE
  CONST
    rmc$loadpoint_error_recovery = 'RMM$LOADPT_ERR_REC             ';
*DECK DECK=RMC$MANUAL_TAPE_MAINTENANCE EXPAND=FALSE
  CONST
    rmc$manual_tape_maintenance = 'RMM$MANUAL_MAINT               ';
*DECK DECK=RMC$MASS_STORAGE_CLASS EXPAND=FALSE

{ The following are NOS/VE system conventions for classifying files}
{ and catalogs.  A particular mass storage device may be associated}
{ with none, one, or more than one of these classes.}

?? FMT (FORMAT := OFF) ??
 CONST
    rmc$msc_system_temporary_files  = 'B',
    rmc$msc_system_swap_files       = 'C',
    rmc$msc_system_code_and_literal = 'I',
    rmc$msc_system_catalogs         = 'J',
    rmc$msc_system_permanent_files  = 'K',
    rmc$msc_user_catalogs           = 'L',
    rmc$msc_user_permanent_files    = 'M',
    rmc$msc_user_temporary_files    = 'N',
    rmc$msc_product_files           = 'P',
    rmc$msc_system_critical_files   = 'Q';
?? FMT (FORMAT := ON) ??

*DECK DECK=RMC$MAXIMUM_DENSITY EXPAND=FALSE
  CONST
    rmc$maximum_density = rmc$38000;

*copyc rmt$density
*DECK DECK=RMC$MAX_ALLOCATION_SIZE EXPAND=FALSE
 CONST
    rmc$max_allocation_size = 0ffffff(16);
*DECK DECK=RMC$RBT_MAX_ATTRIBUTE EXPAND=FALSE
  CONST
    rmc$rbt_max_attribute = 255;

*DECK DECK=RMC$RBT_MAX_REQUEST_ID EXPAND=FALSE
  CONST
    rmc$rbt_max_request_id = 0ffff(16);

*DECK DECK=RMC$RBT_MAX_REQUEST_TYPE EXPAND=FALSE
  CONST
    rmc$rbt_max_request_type = 255;

*DECK DECK=RMC$RBT_STATUS_MESSAGE_WIDTH EXPAND=FALSE
  CONST
    rmc$rbt_status_message_width = 80;

*DECK DECK=RMC$RECORDED_VSN_SIZE EXPAND=TRUE

  CONST
    rmc$recorded_vsn_size = 6;
*DECK DECK=RMC$RESERVE_TAPE EXPAND=FALSE
  CONST
    rmc$reserve_tape = 'RMM$RESERVE_TAPE               ';
*DECK DECK=RMC$ROBOTIC_ELEMENT_MONOPOLY EXPAND=FALSE
  CONST
    rmc$robotic_element_monopoly = 'RMM$ROBOTIC_MONOPOLY           ';
*DECK DECK=RMC$ROBOTIC_TAPE_MAINTENANCE EXPAND=FALSE
  CONST
    rmc$robotic_tape_maintenance = 'RMM$ROBOTIC_MAINT              ';
*DECK DECK=RMC$ROBOTIC_WRITE_DISABLED EXPAND=FALSE
  CONST
    rmc$robotic_write_disabled = 'RMM$WRITE_DISABLED             ';
*DECK DECK=RMC$UNLABELED_TAPES EXPAND=FALSE
  CONST
    rmc$unlabeled_tapes = 'UNLABELED_TAPES                ';

*DECK DECK=RMC$UNSPECIFIED_ALLOCATION_SIZE EXPAND=FALSE
 CONST
    rmc$unspecified_allocation_size = 0;
*DECK DECK=RMC$UNSPECIFIED_FILE_CLASS EXPAND=FALSE

  CONST
    rmc$unspecified_file_class = 'A';
*DECK DECK=RMC$UNSPECIFIED_FILE_SIZE EXPAND=FALSE

  CONST
    rmc$unspecified_file_size = 0;
*DECK DECK=RMC$UNSPECIFIED_TRANSFER_SIZE EXPAND=FALSE
  CONST
    rmc$unspecified_transfer_size = 0;

*DECK DECK=RMC$UNSPECIFIED_VSN EXPAND=FALSE

  CONST
    rmc$unspecified_vsn = '      ';
*DECK DECK=RMC$VOL_CLASSIFICATION_MODULE EXPAND=FALSE
  CONST
    rmc$vol_classification_module = 'RMM$VOL_CLASSIFY               ';

*DECK DECK=RMC$VOL_CLASSIFICATION_PROMPT EXPAND=FALSE
  CONST
    rmc$vol_classification_prompt = 'VOLUME_CLASSIFICATION          ';

*DECK DECK=RMC$WRITE_ERROR_RECOVERY EXPAND=FALSE
  CONST
    rmc$write_error_recovery = 'RMM$WRITE_ERROR_RECY            ';
*DECK DECK=RMC$WRONG_LABEL_TYPE EXPAND=FALSE
  CONST
    rmc$wrong_label_type = 'RMM$WRONG_LABEL_TYPE           ';
*DECK DECK=RMD$TAPE_DECLARATIONS EXPAND=FALSE

  TYPE

    rmt$reserve_tape_request = record
      nt9$800_count: integer,
      nt9$1600_count: integer,
      nt9$6250_count: integer,
      nt18$38000_count: integer,
    recend,

    rmt$release_tape_request = record
      nt9$800_count: integer,
      nt9$1600_count: integer,
      nt9$6250_count: integer,
      nt18$38000_count: integer,
    recend;

*copyc rmt$tape_class
*copyc rmt$density
*copyc rmt$device_class
*copyc rmt$write_ring
*DECK DECK=RMD$TYPE_DECLARATIONS EXPAND=FALSE
  TYPE

    rmt$iou_type = (rmc$i1, rmc$i2),

    rmt$channel_type = (rmc$170, rmc$180, rmc$cross_connected, rmc$mch,
      rmc$clock, rmc$unused),

    rmt$controller_type = (rmc$7155, rmc$7154, rmc$6681, rmc$7021_2x,
      rmc$7021_3x, rmc$225x, rmc$2_port_mux, rmc$cc545, rmc$lcn, rmc$6683),

    rmt$memory_type = (rmc$m1, rmc$m2, rmc$m3, rmc$m_theta),

    rmt$cpu_type = (rmc$p1, rmc$p2, rmc$p3, rmc$p_theta),

    rmt$rms_type = (rmc$844_4x, rmc$fmd_serial, rmc$fmd_4hp),

    rmt$tape_type = (rmc$667_x, rmc$669_x, rmc$679_x),

    rmt$unit_record_type = (rmc$580_120, rmc$580_160, rmc$580_200, rmc$med_nip,
      rmc$high_nip, rmc$405, rmc$415),

    rmt$console_type = (rmc$545, rmc$752),

    rmt$mainframe_type = (rmc$s1, rmc$s2, rmc$s3, rmc$s_theta),

    rmt$sen = 0 .. rmc$max_sen,

    rmt$element_state = (rmc$on, rmc$off, rmc$maintenance),

    rmt$element_class = (rmc$mainframe, rmc$cpu, rmc$memory, rmc$iou,
      rmc$channel, rmc$pp, rmc$controller, rmc$rms_unit, rmc$tape_unit,
      rmc$unit_record, rmc$console, rmc$cem),

    rmt$element_code = record
      case element_class: rmt$element_class OF
      =rmc$mainframe=
        mainframe_type: rmt$mainframe_type,
      =rmc$cpu=
        cpu_type: rmt$cpu_type,
      =rmc$memory=
        memory_type: rmt$memory_type,
      =rmc$iou=
        iou_type: rmt$iou_type,
      =rmc$channel=
        channel_type: rmt$channel_type,
      =rmc$pp= ,
      =rmc$controller=
        controller_type: rmt$controller_type,
      =rmc$rms_unit=
        rms_type: rmt$rms_type,
      =rmc$tape_unit=
        tape_type: rmt$tape_type,
      =rmc$unit_record=
        unit_record_type: rmt$unit_record_type,
      =rmc$console=
        console_type: rmt$console_type,
      =rmc$cem= ,
      casend
    recend,

    rmt$element_select = record
      code: rmt$element_code,
      mainframe_select: 0 .. rmc$max_mainframe_no,
      cpu_select: 0 .. rmc$max_cpu_no,
      iou_select: 0 .. rmc$max_iou_no,
      pp_select: 0 .. rmc$max_pp_no,
      channel_select: 0 .. rmc$max_channel_no,
      controller_select: 0 .. rmc$max_controller_no,
      device_select: 0 .. rmc$max_device_no,
    recend;
*copyc RMC$LIMIT_CONSTANTS

*DECK DECK=RMD$VOLUME_DECLARATIONS EXPAND=FALSE

*copyc rmc$external_vsn_size
*copyc rmc$recorded_vsn_size
*copyc rmt$external_vsn
*copyc rmt$recorded_vsn
*copyc rmt$volume_descriptor
*copyc rmt$volume_list
*DECK DECK=RME$AVR_TAPE_ERRORS EXPAND=FALSE
{      AUTOMATIC VOLUME RECOGNITION (tape) errors
*copyc rmc$condition_code_limits

     { RME$AVR_TAPE_ERRORS  :  ''RM'' 700 .. 799 }

?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := OFF) ??

     { rme$avr_tape_errors }

  CONST
    rme$cant_find_rvl_entry = rmc$min_ecc_resource_management + 700,
    {F unable to locate RVL entry within procedure: +p}

    rme$nil_rvl_info_array_p  = rmc$min_ecc_resource_management + 701,
    {E nil rvl_info_array_p detected in procedure: +p}

    rme$nil_new_vsns_online_p = rmc$min_ecc_resource_management + 702,
    {E nil new_vsns_online_p detected in procedure: +p}

    rme$cant_find_specified_vsn = rmc$min_ecc_resource_management + 703,
    {F unable to locate specified vsn within procedure: +p}

    rme$unspecified_vsn = rmc$min_ecc_resource_management + 704,
    {F an unspecified vsn was detected within procedure: +p}

    rme$volume_already_assigned = rmc$min_ecc_resource_management + 705,
    {I the specified tape volume +p is currently assigned}

    rme$unsuccessful_stack_push = rmc$min_ecc_resource_management + 706,
    {F PUSH onto stack unsuccessful within procedure: +p}

    rme$no_tape_mount_pending = rmc$min_ecc_resource_management + 707,
    {I no tape mount request pending for specified volume: +p}

    rme$system_name_required = rmc$min_ecc_resource_management + 708,
    {I the system_name is required for unique assignment of volume: +p}

    rme$undefined_element_name = rmc$min_ecc_resource_management + 709,
    {I the specified element_name of +p is undefined}

    rme$element_name_assigned = rmc$min_ecc_resource_management + 710,
    {I the specified element_name of +p is already assigned}

    rme$element_name_not_on = rmc$min_ecc_resource_management + 711,
    {I the specified element_name of +p is not ON}

    rme$element_name_not_assigned = rmc$min_ecc_resource_management + 712,
    {I the specified element_name of +p is not currently assigned}

    rme$system_name_req_for_term = rmc$min_ecc_resource_management + 713,
    {I the system_name is required for unique termination of volume: +p}

    rme$reassign_not_allowed = rmc$min_ecc_resource_management + 714,
    {I the specified element_name of +p may not be reassigned}

    rme$density_not_supported = rmc$min_ecc_resource_management + 715;
    {I The specified element_name of +p does not support the
    { requested density.}

{   rmc$max_avr_tape_error = rmc$min_ecc_resource_management + 899;


*DECK DECK=RME$CLASS_VALIDATION_ERRORS EXPAND=FALSE
*copyc RMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'Class parameter valid   : ''RM'' 0 .. 9', EJECT ??

?? FMT (FORMAT := OFF) ??

     { rme$class_validation_errors }

   CONST
     rmc$min_ecc_class_validation    = rmc$min_ecc_resource_management + 0,

     rme$improper_class_value        = rmc$min_ecc_class_validation + 5,
         {E File +F1 : CLASS parameter of +P2 is improper.}

     rmc$max_ecc_class_validation    = rmc$min_ecc_class_validation + 9;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=RME$CONDITION_CODES EXPAND=FALSE
?? NEWTITLE := 'RMDECC  : Resource Management    : 0 .. 9999' ??
*copyc RMC$CONDITION_CODE_LIMITS
*copyc RME$CLASS_VALIDATION_ERRORS
*copyc RME$CREBLV_ERRORS
*copyc RME$REQUEST_COMMAND_EXCEPTIONS
*copyc RME$REQUEST_MASS_STORAGE
*copyc RME$REQUEST_TAPE
*copyc RME$REQUEST_TERMINAL
*copyc RME$ROBOTIC_INTERFACE_ERRORS
*copyc RME$AVR_TAPE_ERRORS
*copyc DME$TAPE_ERRORS
?? OLDTITLE ??
*DECK DECK=RME$CREBLV_ERRORS EXPAND=FALSE
*copyc rmc$condition_code_limits

?? NEWTITLE := 'rme$creblv_errors  :  ''RM'' 100 .. 119', EJECT ??

?? FMT (FORMAT := OFF) ??

     { rme$creblv_errors }

  CONST
    rmc$min_creblv_errors = rmc$min_ecc_resource_management + 100,

    rme$ambiguous_specifications = rmc$min_creblv_errors + 0,
    {E The parameters OWNER_IDENTIFICATION and REMOVABLE_MEDIA_GROUP cannot ..
    {both be specified for the same volume.

    rme$ansi_label_conflict = rmc$min_creblv_errors + 1,
    {E If the LABELING_CONVENTION is specified as ANSI, the +P1 parameter ..
    {cannot be specified.}

    rme$element_or_vsn_required = rmc$min_creblv_errors + 3,
    {E Either the ELEMENT parameter or the EXTERNAL_VSN+P1 parameter must ..
    {be specified.}

    rme$lc_parameter_conflict = rmc$min_creblv_errors + 6,
    {E The value specified for the parameter +P1, conflicts with the ..
    {specified LABELING_CONVENTION of +P2.}

    rme$lc_value_requires_parameter = rmc$min_creblv_errors + 7,
    {E The parameter +P1 is required when the LABELING_CONVENTION of +P2 is ..
    {specified.}

    rme$rmg_parameter_conflict = rmc$min_creblv_errors + 10,
    {E The value specified for the parameter +P1 is invalid when the ..
    {REMOVABLE_MEDIA_GROUP parameter is specified.}

    rme$supported_densities_differ = rmc$min_creblv_errors + 12,
    {E All elements specified must support the same density.}

    rme$vsn_density_mismatch = rmc$min_creblv_errors + 16,
    {E If the EXTERNAL_VSN+P1 parameter is specified and the ELEMENT parameter ..
    {is omitted, the DENSITY must be specified as MT18$38000 or the ELEMENT ..
    {parameter should be provided.}

    rmc$max_creblv_errors = rmc$min_creblv_errors + 19;

?? OLDTITLE ??
*DECK DECK=RME$MEDIA_LIBRARY_ERRORS EXPAND=FALSE
*DECK DECK=RME$REQUEST_COMMAND_EXCEPTIONS EXPAND=FALSE
{COMMON DECK RME$REQUEST_COMMAND_EXCEPTIONS}
*copyc RMC$CONDITION_CODE_LIMITS

?? NEWTITLE := 'RMDVCME: request_command: ''RM'' 80 .. 99' , EJECT ??
??  FMT (FORMAT := OFF) ??

{ REQUEST COMMAND ERRORS }

CONST
  rmc$min_ecc_command_validation      = rmc$min_ecc_resource_management + 80,

  rme$redundant_device_assignment     = rmc$min_ecc_command_validation + 5,
  {W File +F1 is already assigned to a device of type +P8.}

  rme$device_assignment_conflict      = rmc$min_ecc_command_validation + 7,
  {E File +F1 : Current assignment to a +P8 device conflicts with..
  { request for assignment to a +P9 device.}

  rmc$max_ecc_command_validation      = rmc$min_ecc_command_validation + 19;

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=RME$REQUEST_MASS_STORAGE EXPAND=FALSE
*copyc rmc$condition_code_limits
?? NEWTITLE := 'rmp$request_mass_storage: ''RM'' 10 .. 29', EJECT ??

?? FMT (FORMAT := OFF) ??

     { rme$request_mass_storage }

   CONST
     rmc$min_ecc_rms_validation      = rmc$min_ecc_resource_management + 10,

     rme$file_class_not_valid        = rmc$min_ecc_rms_validation + 2,
         {E Mass storage volume +P1 is not a member of class +P2.}

     rme$file_size_not_implemented   = rmc$min_ecc_rms_validation + 5,
         {E The ESTIMATED_FILE_SIZE capability of +P1 is not implemented.}

     rme$file_sz_alloc_sz_conflict   = rmc$min_ecc_rms_validation + 7,
         {E The ESTIMATED_FILE_SIZE parameter and the ALLOCATION_SIZE parameter
         { cannot be specified together.}

     rme$improper_size_value         = rmc$min_ecc_rms_validation + 9,
         {E File +F1 : +P3 parameter of +P2 is improper.}

     rme$improper_cycle_reference    = rmc$min_ecc_rms_validation + 11,
         {E $HIGH and $LOW are improper cycle references on +P1.}

     rme$unknown_volume              = rmc$min_ecc_rms_validation + 14,
         {E Volume: +P1 is unknown.}

     rme$job_not_valid               = rmc$min_ecc_rms_validation + 15,
         {E Access to requested volume is not allowed.}

     rme$improper_vol_overflow       = rmc$min_ecc_rms_validation + 16,
         {E File +F1 : VOLUME OVERFLOW ALLOWED parameter of +P2 is improper.}

     rme$invalid_keyword             = rmc$min_ecc_rms_validation + 17,
         {E The keyword +P1 is not valid on REQUEST_MASS_STORAGE.}

     rme$volume_overflow_required    = rmc$min_ecc_rms_validation + 18,
         {E Only SYSTEM and MAINTENANCE jobs are allowed to inhibit volume
         { overflow.}

     rme$vsn_not_part_of_set         = rmc$min_ecc_rms_validation + 19,
         {E The requested volume +P1 is not a member of set +P2.}

     rmc$max_ecc_rms_validation      = rmc$min_ecc_rms_validation + 19;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=RME$REQUEST_TAPE EXPAND=FALSE
*copyc RMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'RMDVTAP :rmp$request_tape        : ''RM'' 30 .. 59', EJECT ??

?? FMT (FORMAT := OFF) ??

     { rme$request_tape }

   CONST
     rmc$min_ecc_tape_validation     = rmc$min_ecc_resource_management + 30,

     rme$improper_density_value      = rmc$min_ecc_tape_validation + 5,
         {E File +F1 : DENSITY parameter of +P2 is improper.}

     rme$improper_recorded_vsn_value = rmc$min_ecc_tape_validation + 10,
         {E File +F1 : +P8 is an improper value for the RECORDED_VSN..}
         { parameter of +P2.}

     rme$improper_external_vsn_value = rmc$min_ecc_tape_validation + 15,
         {E File +F1 : +P8 is an improper value for the EXTERNAL_VSN..}
         { parameter of +P2.}

     rme$improper_write_ring_value   = rmc$min_ecc_tape_validation + 20,
         {E File +F1 : WRITE RING parameter of +P2 is improper.}

     rmc$max_ecc_tape_validation     = rmc$min_ecc_tape_validation + 29;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=RME$REQUEST_TERMINAL EXPAND=FALSE
*copyc RMC$CONDITION_CODE_LIMITS
?? NEWTITLE := 'RMDVTT  :rmp$request_terminal    : ''RM'' 60 .. 79', EJECT ??

?? FMT (FORMAT := OFF) ??

     { rme$request_terminal }

   CONST
     rmc$min_ecc_terminal_validation = rmc$min_ecc_resource_management + 60,

     rme$improper_term_attrib_key    = rmc$min_ecc_terminal_validation + 5,
         {E File +F1 : TERMINAL ATTRIBUTES parameter of +P2 had..
         { improper KEY(S) in array element(s): +P.}

     rme$improper_term_attrib_value  = rmc$min_ecc_terminal_validation + 10,
         {E File +F1 : TERMINAL ATTRIBUTES parameter of +P2 had..
         { improper value(s) in array element(s): +P.}

     rmc$max_ecc_terminal_validation = rmc$min_ecc_terminal_validation + 19;
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=RME$ROBOTIC_INTERFACE_ERRORS EXPAND=FALSE
*copyc rmc$condition_code_limits

?? NEWTITLE := 'rme$robotic_interface_errors  :  ''RM'' 600 .. 699', EJECT ??

?? FMT (FORMAT := OFF) ??

     { rme$robotic_interface_errors }

  CONST
    rmc$min_robotic_errors = rmc$min_ecc_resource_management + 600,

    rme$robotic_validation_error      = rmc$min_robotic_errors  + 0,
    {E You are not authorized to call robotic server interfaces.}

    rme$duplicate_element_name        = rmc$min_robotic_errors  + 1,
    {E +P1: Element name +P2 appeared more than once in the +P3.}

    rme$duplicate_server              = rmc$min_robotic_errors  + 2,
    {E +P1: Robotic server +P2 is already defined.}

    rme$invalid_element_name          = rmc$min_robotic_errors  + 3,
    {E +P1:  The MANAGED_ELEMENTS parameter contained an invalid ..
    {element name: +P2.}

    rme$invalid_server_attribute      = rmc$min_robotic_errors  + 4,
    {E +P1: The SERVER_ATTRIBUTES parameter had an invalid ..
    {SELECTOR value specified in array entry number +P2.}

    rme$invalid_server_name           = rmc$min_robotic_errors  + 5,
    {E +P1: The value specified for the SERVER_NAME parameter ..
    {is invalid: +P2.}

    rme$invalid_server_response       = rmc$min_robotic_errors  + 6,
    {E RMP$SERVER_PUT_RESPONSE: A field within the ..
    {SERVER_RESPONSE parameter is invalid: +P1.}

    rme$invalid_server_timeout        = rmc$min_robotic_errors  + 7,
    {E +P1:  The value specified for the SERVER_TIMEOUT ..
    {field of the SERVER_ATTRIBUTES parameter is either ..
    {negative or exceeds the maximum allowable value of +P2 ..
    {milliseconds.}

    rme$invalid_supported_requests    = rmc$min_robotic_errors  + 8,
    {E +P1: One or more values specified in the SUPPORTED_REQUESTS ..
    {field of the SERVER_ATTRIBUTES parameter is invalid.}

    rme$invalid_wait_specified        = rmc$min_robotic_errors  + 9,
    {E +P1: The value specified for the WAIT parameter is invalid.}

    rme$no_requests_available         = rmc$min_robotic_errors  + 10,
    {E +P1: There are no client requests currently available for ..
    {the server.}

    rme$no_candidate_elements         = rmc$min_robotic_errors  + 11,
    {E RMP$SERVER_PUT_RESPONSE: A volume was located in a library ..
    {but both the PREFERRED and the REMAINING CANDIDATES fields ..
    {were NIL.}

    rme$no_managed_elements           = rmc$min_robotic_errors  + 12,
    {E +P1: A robotic server is required to provide the ..
    {name of at least one NOS/VE peripheral element that it intends ..
    {to manage.}

    rme$premature_server_response     = rmc$min_robotic_errors  + 13,
    {E +P1: The server response for robotic request id +P2 was ..
    {sent before the request was obtained.}

    rme$redundant_server_response     = rmc$min_robotic_errors  + 14,
    {E +P1: The server response for robotic request id +P2 has ..
    {already been sent.}

    rme$robotic_mount_failure         = rmc$min_robotic_errors  + 15,
    {E Volume +P1 could not be robotically mounted.  You must ..
    {mount it manually and specify the ELEMENT_NAME.

    rme$too_many_elements             = rmc$min_robotic_errors  + 16,
    {E +P1: The number of elements in the array specified by the ..
    {+P2 exceeds the NOS/VE maximum of +P3.}

 { The following are internal exception conditions}

    rme$client_request_active         = rmc$min_robotic_errors  + 30,
    {E +P1: A robotic request is already active for the client.}

    rme$invalid_server_index          = rmc$min_robotic_errors  + 32,
    {E +P1: Robotic server index +P2 is invalid.)

    rme$element_not_available         = rmc$min_robotic_errors  + 33,
    {E +P1: Robotic element is not currently available.}

    rme$request_not_found             = rmc$min_robotic_errors  + 34,
    {E +P1: Robotic request id +P2 not found.}

    rme$robotic_element_monopoly      = rmc$min_robotic_errors  + 35,
    {E The mount of an additional robotically managed volume is ..
    {not allowed because all robotically managed elements are ..
    {already assigned to the job.}

    rme$robotic_write_disabled        = rmc$min_robotic_errors  + 36,
    {E A robotically mounted volume requested for write access ..
    {is not write enabled.}

    rme$response_unavailable          = rmc$min_robotic_errors  + 37,
    {E +P1: The response for robotic request id +P2 is unavailable.}

    rme$server_not_defined            = rmc$min_robotic_errors  + 38,
    {E +P1: Robotic server +P2 is not defined.}

    rme$sfid_not_found                = rmc$min_robotic_errors  + 39,
    {E +P1: Robotic request with sfid +P2 not found.}

    rme$synchronization_error         = rmc$min_robotic_errors  + 40,
    {E The server and the client are apparently out of sync.}

    rme$volume_not_mounted            = rmc$min_robotic_errors  + 41,
    {E The volume was not mounted.}

    rme$tape_unit_available       = rmc$min_robotic_errors  + 42,
    {E The volume was not mounted due to no tape units available.}

    rmc$max_robotic_interface_error = rmc$min_robotic_errors  + 99;

?? OLDTITLE ??
*DECK DECK=RMH$BUILD_MASS_STORAGE_INFO EXPAND=FALSE
{
{    The purpose of this request is to construct the
{ FMT$MASS_STORAGE_REQUEST_INFO data structure.  The mass storage information
{ supplied as parameters are placed in the data structure and validation
{ information is generated using information supplied and information obtained
{ about the job issuing the request.
{
{
{       RMP$BUILD_MASS_STORAGE_INFO (ALLOCATION_SIZE, ESTIMATED_FILE_SIZE,
{             TRANSFER_SIZE, FILE_CLASS, INITIAL_VOLUME,
{             VOLUME_OVERFLOW_ALLOWED, RING_OF_CALLER,
{             P_MASS_STORAGE_REQUEST_INFO, STATUS);
{
{ ALLOCATION_SIZE: (input)  This parameter specifies the amount of contiguous
{       mass storage space, in bytes, which is to be allocated to the file each
{       time additional space is needed.  The system will use the value of this
{       parameter as a guide in selecting the quantum of allocation for this
{       file.  The actual allocation size for the file may be more or less than
{       the specified value due to the characteristics of the device determined
{       by the other parameters of this request.
{
{       The value rmc$unspecified_allocation_size will cause the allocation
{       size to be determined by the ESTIMATED_FILE_SIZE parameter.
{
{ ESTIMATED_FILE_SIZE: (input)  This parameter specifies the likely size of the
{       file in bytes.  This information is used to select the allocation size
{       which would minimize the amount of mass storage space assigned to the
{       file should it ultimately reach the estimated size.
{
{       The value rmc$unspecified_file_size will cause the allocation size to
{       be determined by the ALLOCATION_SIZE parameter.
{
{ TRANSER_SIZE: (input)  This parameter specifies the amount of data (in bytes)
{       that are read from the file's mass storage device whenever the system
{       detects that the file can be read at the device rate (the streaming
{       rate).  The specified value is automatically rounded up to the nearest
{       power of 2.
{
{       The value rmc$unspecified_tranfer_size will cause the transfer size to
{       be determined by the type of mass storage device the file resides on.
{
{ FILE_CLASS: (input)  This parameter specifies the class of the file which is
{       to be assigned.  NOS/VE supports up to 26 classes of files.  Each class
{       is identified by an alphabetic character (upper and lower cases are
{       equivalent).  NOS/VE will select a volume which belongs to the class
{       specified by this parameter; abnormal status will be returned if no
{       candidate volume belongs to the specified class.
{
{       Only the user $SYSTEM may specify the following values:
{
{       rmc$msc_system_swap_files (C) rmc$msc_system_catalogs (J)
{       rmc$msc_system_permanent_files (K) rmc$msc_user_catalogs (L)
{       rmc$msc_system_critical_files (Q)
{
{       A task executing in rings 6..4 may specify any file class except C, J,
{       K, L, and Q.
{
{       A task executing in rings 13..7 may specify rmc$user_permanent_files
{       (M) for a permanent file and rmc$user_temporary_files (N) for a
{       temporary file.
{
{       The value rmc$unspecified_file_class causes NOS/VE to place the file on
{       the volume specified by the INITIAL_VOLUME parameter.
{
{       If the value rmc$unspecified_vsn is used for the INITIAL_VOLUME
{       parameter and rmc$unspecified_file_class is also specified for this
{       parameter, NOS/VE will assign the file to a volume that belongs to the
{       class that is appropriate for the file and the job in which the file is
{       created.  Refer to the System Performance and Maintenance manual for
{       information about the NOS/VE default file assignments in effect for
{       this release.
{
{       Specification of any non-alphabetic character will cause abnormal
{       status to be returned.
{
{ INITIAL_VOLUME: (input)  This parameter specifies the identification of a
{       specific mass storage volume to which this file is to be assigned.
{
{       If volume overflow is not allowed, the entire file will reside on this
{       volume; otherwise, this volume will be the initial volume assigned to
{       the file.  Refer to the VOLUME_OVERFLOW_ALLOWED parameter.
{
{       If the requested volume has no space available or the volume does not
{       exist in the active configuration, this request will be rejected.
{
{       If FILE_CLASS is given a value other than rmc$unspecified_file_class,
{       then the volume specified by this parameter must belong to the file
{       class specified or the request will be rejected.
{
{       The user $SYSTEM may use this parameter to place a file on any volume
{       in the configuration; however, rmc$unspecified_file_class will need to
{       be specified for the FILE_CLASS parameter.
{
{       A user executing in the maintenance job class may use this parameter to
{       place a temporary file on any volume in the configuration, regardless
{       of whether or not the volume belongs to the temporary file class (N);
{       however, rmc$unspecified_file_class will need to be specified for the
{       FILE_CLASS parameter.
{
{       A task executing in rings 6..4 may specify any volume that belongs to
{       one of the following classes:  B, D..I, M..P, R..Z.
{
{       A task executing in rings 13..7 may specify any volume that belongs to
{       class M for a permanent file or class N for a temporary file.
{
{       The value rmc$unspecified_vsn will cause the consideration of all
{       candidate volumes belonging to the file class specified (or defaulted).
{
{ VOLUME_OVERFLOW_ALLOWED: (input)  This parameter specifies whether or not the
{       file can be assigned to more than one volume.  If TRUE is specified,
{       the file may span any volume subject to validation and FILE_CLASS
{       constraints.  If FALSE is specified, the file will be confined to the
{       initial volume to which it is assigned.  Specifying no volume overflow
{       would typically be used in conjunction with requesting a specific mass
{       storage volume; this is generally done for fault tolerance reasons.
{       For example, all the files which are required for a particular feature
{       or product (e.g.  those required for system maintenance or operation)
{       must reside on the same volume (usually the system deadstart device) to
{       ensure their availability in case of a failure on any of the other
{       volumes.  Of course, copies of the files may be located on a second
{       volume (preferably on a different hardware path) to maximize
{       availability.
{
{       Specification of FALSE is permitted only in a job which has system
{       administrative privilege or maintenance privilege.
{
{ RING_OF_CALLER: (input)  This parameter specifies the execution ring of the
{       task which initiated this request.
{
{ P_MASS_STORAGE_REQUEST_INFO: (output)  This parameter specifies the location
{       of the variable to initialize with the mass storage information and
{       validation information.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=RMH$CLASSIFY_TAPE_VOLUME EXPAND=FALSE
{
{    The purpose of this procedure is to determine from a sequence of volume
{ header labels, the kind of volume security that is in effect for the volume.
{
{    If the volume has no labels, then the READ_LABELS_STATUS parameter
{ contains the abnormal status that was returned when the attempt was made to
{ read labels from the volume.  This abnormal status is used to classify an
{ unlabeled volume or to determine whether access to the volume should be
{ restricted to a REMOVABLE_MEDIA_ADMINISTRATOR.
{
{    This interface is implemented within the RMM$ENFORCE_TAPE_SECURITY site
{ hook.  Therefore, the result of calling this interface is subject to site
{ modification.  What is described below is the standard NOS/VE implementation.
{
{       RMP$CLASSIFY_TAPE_VOLUME ( READ_LABELS_STATUS, VOLUME_HEADER_LABELS,
{             VOLUME_CLASSIFICATION, STATUS)
{
{ read_labels_status: (input)  This parameter specifies the status from the
{       attempt to read tape labels from the beginning of a volume.  For most
{       users, this parameter should be initialized with NORMAL set to TRUE.
{       However, a person with REMOVABLE_MEDIA_OPERATION privilege may use
{       FSP$OPEN_FILE to read labels from a volume when the FILE_ATTACHMENT
{       parameter specifies the VOLUME_INITIALIZATION tape attachment option.
{       In this situation, the status returned from FSP$OPEN_FILE is in fact
{       the status from the attempt to read labels from the beginning of the
{       volume that is to be initialized.  The following status conditions are
{       interpreted by this request and are classified as follows:
{
{
{    ame$excessive_tape_labels:  The number of labels exceeds 128
{
{       volume_classification.volume_label_type := rmc$labeled_volume_type;
{
{       volume_classification.labeled.blank := FALSE;
{
{       volume_classification.labeled.volume_security_type :=
{                               rmc$vst_access_restricted;
{
{       volume_classification.labeled.reason := rmc$excessive_tape_labels;
{
{
{    ame$invalid_tape_label:  The volume's first block is not a label
{
{       volume_classification.volume_label_type := rmc$unlabeled_volume_type;
{
{       volume_classification.blank := FALSE;
{
{
{    ame$unexpected_tapemark:  The volume begins with a tapemark
{
{       volume_classification.volume_label_type := rmc$unlabeled_volume_type;
{
{       volume_classification.blank := TRUE;
{
{
{    ame$unexpected_tape_label:  Unsupported mixture of header/trailer
{
{       volume_classification.volume_label_type := rmc$labeled_volume_type;
{
{       volume_classification.labeled.blank := FALSE;
{
{       volume_classification.labeled.volume_security_type :=
{                               rmc$vst_access_restricted;
{
{       volume_classification.labeled.reason := rmc$vol1_missing;
{
{    ame$tape_label_read_error:  Initial block unreadable
{
{       volume_classification.volume_label_type :=
{                               rmc$indeterminate_volume_type;
{
{       volume_classification.blank := FALSE;
{
{ volume_header_labels: (input)  This parameter specifies a sequence of volume
{       header labels.  Use the FSP$GET_TAPE_LABEL_ATTRIBUTES interface to
{       obtain the HEADER_LABELS sequence.  Use the FSP$LOCATE_TAPE_LABEL
{       interface to locate the VOL1 label.  If the VOL1 label is present, then
{       this interface may be called to classify the volume header labels
{       contained in the sequence.
{
{ volume_classification: (output)  This parameter specifies the kind of volume
{       security policy that is required based on the READ_LABELS_STATUS and
{       the content of the VOLUME_HEADER_LABELS provided.
{
{ status: (output)  This parameter returns the status of the request.  If the
{       READ_LABELS_STATUS is abnormal but not one of the status conditions
{       mentioned in the description of the READ_LABELS_STATUS parameter, then
{       the STATUS of this request is set to the READ_LABELS_STATUS.
{
*DECK DECK=RMH$COMPLETE_TAPE_ASSIGNMENT EXPAND=FALSE
{
{   The purpose of this procedure is to allow the site procedure
{ RMP$VALIDATE_TAPE_ASSIGNMENT to complete the assignment of a tape volume to a
{ tape file.  RMP$VALIDATE_TAPE_ASSIGNMENT is called prior to the assignment of
{ each tape volume.  RMP$VALIDATE_TAPE_ASSIGNMENT is allowed to modify the
{ VOLUME_DESCRIPTION before passing it on to RMP$COMPLETE_TAPE_ASSIGNMENT.
{
{       RMP$COMPLETE_TAPE_ASSIGNMENT (FILE_IDENTIFIER,
{         FILE, DENSITY, WRITE_RING, FILE_LABEL_TYPE, ACCESS_MODE,
{         INITIAL_ASSIGNMENT, NEXT_VOLUME, VOLUME_DESCRIPTION,
{         REMOVABLE_MEDIA_GROUP, REMOVABLE_MEDIA_LOCATION,
{         OPERATOR_TERMINATED_ASSIGNMENT, STATUS)
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the file access identifier
{       established when the file was opened.
{
{ FILE: (input)  This parameter specifies the name of the tape file to which
{       the tape volume is to be assigned.
{
{ DENSITY: (input)  This parameter specifies the density of the tape storage
{       device.
{
{ WRITE_RING: (input)  This parameter specifies the presence or absence of a
{       write ring in all of the tape volumes associated with the file.
{
{ FILE_LABEL_TYPE: (input)  This parameter specifies the label type of the tape
{       file.
{
{ ACCESS_MODE: (input)  This parameter specifies the access mode of the file.
{
{ INITIAL_ASSIGNMENT: (input)  This parameter specifies whether or not this is
{       the initial assignment of a tape volume to the tape file.
{
{ NEXT_VOLUME: (input)  This parameter specifies the number of the volume in
{       the volume list of the next volume to be mounted.
{
{ VOLUME_DESCRIPTION: (input)  This parameter specifies the identity of the
{       tape volume to be mounted.  Each volume is identified on the
{       REQUEST_MAGNETIC_TAPE command or RMP$REQUEST_TAPE program interface by
{       a recorded_vsn, an external_vsn or by both a recorded_vsn and an
{       external_vsn.
{
{       If both the EXTERNAL_VSN and the RECORDED_VSN parameters are omitted
{       from the REQUEST_MAGNETIC_TAPE command or rmc$unspecified_vsn is
{       specified for both the external_vsn and the recorded_vsn on the
{       RMP$REQUEST_TAPE program interface, then the operator will be asked to
{       supply the EXTERNAL_VSN and optional RECORDED_VSN of the initial tape
{       volume.  The operator will also be asked to supply the EXTERNAL_VSN and
{       optional RECORDED_VSN of additional tape volumes whenever a program
{       attempts to write beyond the last volume in the volume list.
{
{       If recorded_vsn and external_vsn are each given values other than
{       rmc$unspecified_vsn and the two values are not identical, automatic
{       volume assignment will not occur; the operator will be asked to mount
{       and manually assign the volume identified by the external_vsn.  The
{       system will then validate that the recorded_vsn provided by this
{       request matches the one recorded in the VOL1 label recorded on the tape
{       volume.
{
{       recorded_vsn - specifies the identity of an ANSI labelled volume.  If a
{       recorded_vsn is specified, the VOL1 label of the tape volume assigned
{       to the file must match the value specified or the tape assignment is
{       rejected.  The recorded_vsn may be composed of the characters 0..9, the
{       upper case letters A..Z and the following special characters:
{
{       SP !  " % & ' ( ) * + , - .  / :  ; < = { > ?  _ $ # @
{
{       external_vsn - specifies the identity of a magnetic tape volume in
{       terms which will be readily identifiable to the operator.  If
{       rmc$unspecified_vsn is specified, the recorded_vsn will be used to
{       identify the volume to be mounted.  The external_vsn may be composed of
{       the characters 0..9, the upper case letters A..Z and the following
{       special characters:
{
{       SP !  " % & ' ( ) * + , - .  / :  ; < = { > ?  _ $ # @
{
{ REMOVABLE_MEDIA_GROUP: (input) This parameter specifies the group validation
{       that is associated with the tape.
{
{ REMOVABLE_MEDIA_LOCATION: (input) This parameter specifies the location
{       of the tate as defined by the REMOVABLE_MEDIA_SUBSYSTEM.
{
{ OPERATOR_TERMINATED_ASSIGNMENT: (output)  This parameter indicates whether or
{       or not the operator terminated the assignment.
{
{ STATUS: (output) This parameter specifies the request status.
{
{       IDENTIFIER: rmc$resource_management_id.
{
{
*DECK DECK=RMH$COMPLETE_TAPE_REQUEST EXPAND=FALSE
{
{   The purpose of this procedure is to allow the site procedure
{ RMP$VALIDATE_TAPE_REQUEST to complete a request for a magnetic tape file.
{ RMP$VALIDATE_TAPE_REQUEST is called for the REQUEST_MAGNETIC_TAPE command and
{ the RMP$REQUEST_TAPE program request.  RMP$VALIDATE_TAPE_REQUEST is allowed
{ to modify the CLASS, DENSITY, WRITE_RING and VOLUME_LIST parameters before
{ passing them on to RMP$COMPLETE_TAPE_REQUEST.
{
{       RMP$COMPLETE_TAPE_REQUEST (FILE, CLASS, DENSITY, WRITE_RING,
{         VOLUME_LIST, STATUS)
{
{ FILE: (input)  This parameter specifies the name of the file which is to be
{       registered in a catalog and assigned to the magnetic tape device class.
{
{ CLASS: (input)  This parameter specifies the type of tape storage device
{       required, i.e.  whether 7 or 9 track tape is required.
{
{ DENSITY: (input)  This parameter specifies the density of the tape storage
{       device.
{
{ WRITE_RING: (input)  This parameter specifies the presence or absence of a
{       write ring in all the tape volumes associated with the file.
{
{ VOLUME_LIST: (input)  This parameter specifies the identity of the tape
{       volume(s) to be mounted.  Volumes are mounted in the order in which
{       they are specified.  Each volume is identified on the
{       REQUEST_MAGNETIC_TAPE command or RMP$REQUEST_TAPE program interface by
{       a recorded_vsn, an external_vsn or by both a recorded_vsn and an
{       external_vsn.
{
{       If both the EXTERNAL_VSN and the RECORDED_VSN parameters are omitted
{       from the REQUEST_MAGNETIC_TAPE command or rmc$unspecified_vsn is
{       specified for both the external_vsn and the recorded_vsn on the
{       RMP$REQUEST_TAPE program interface, then the operator will be asked to
{       supply the EXTERNAL_VSN and optional RECORDED_VSN of the initial tape
{       volume.  The operator will also be asked to supply the EXTERNAL_VSN and
{       optional RECORDED_VSN of additional tape volumes whenever a program
{       attempts to write beyond the last volume in the volume list.
{
{       If recorded_vsn and external_vsn are each given values other than
{       rmc$unspecified_vsn and the two values are not identical, automatic
{       volume assignment will not occur; the operator will be asked to mount
{       and manually assign the volume identified by the external_vsn.  The
{       system will then validate that the recorded_vsn provided by this
{       request matches the one recorded in the VOL1 label recorded on the tape
{       volume.
{
{       recorded_vsn - specifies the identity of an ANSI labelled volume.  If a
{       recorded_vsn is specified, the VOL1 label of the tape volume assigned
{       to the file must match the value specified or the tape assignment is
{       rejected.  The recorded_vsn may be composed of the characters 0..9, the
{       upper case letters A..Z and the following special characters:
{
{       SP !  " % & ' ( ) * + , - .  / :  ; < = { > ?  _ $ # @
{
{       external_vsn - specifies the identity of a magnetic tape volume in
{       terms which will be readily identifiable to the operator.  If
{       rmc$unspecified_vsn is specified, the recorded_vsn will be used to
{       identify the volume to be mounted.  The external_vsn may be composed of
{       the characters 0..9, the upper case letters A..Z and the following
{       special characters:
{
{       SP !  " % & ' ( ) * + , - .  / :  ; < = { > ?  _ $ # @
{
{ STATUS: (output) This parameter specifies the request status.
{
{       IDENTIFIER: rmc$resource_management_id.
{
*DECK DECK=RMH$COMPLETE_TAPE_VOLUME_INIT EXPAND=FALSE
{
{   The purpose of this procedure is to allow the site procedure
{ RMP$VALIDATE_TAPE_VOLUME_INIT to complete a tape volume initialization.
{ RMP$VALIDATE_TAPE_VOLUME_INIT is called after the labels on the tape volume
{ have been read but prior to presenting a menu to the operator.
{ RMP$VALIDATE_TAPE_VOLUME_INIT is allowed to modify the NEW_LABEL_INFORMATION
{ parameter before passing it on to RMP$COMPLETE_TAPE_ASSIGNMENT.
{
{       RMP$COMPLETE_TAPE_VOLUME_INIT (NEW_VOLUME_INIT_INFO,
{         OPERATOR_ALLOWED_INIT, STATUS)
{
{ NEW_VOLUME_INIT_INFO: (input)  This parameter contains information specified
{       by the INITIALIZE_TAPE_VOLUME command.
{
{ OPERATOR_ALLOWED_INIT: (output)  This parameter indicates whether or or not
{       the operator allowed the initialization to complete.
{
{ STATUS: (output) This parameter specifies the request status.
{
{       IDENTIFIER: rmc$resource_management_id.
{
*DECK DECK=RMH$ENFORCE_TAPE_SECURITY EXPAND=FALSE
{
{    The purpose of this procedure is to enforce tape security in NOS/VE.  The
{ enforcement of tape security is controlled by the CHANGE_TAPE_VALIDATION
{ command which requires CONFIGURATION_ADMINISTRATION privilege.  During NOS/VE
{ deadstart, this procedure is not called.  After deadstart, tape security is
{ turned off by default but calls are enabled to this procedure regardless of
{ the CHANGE_TAPE_VALIDATION selection.  If you want to enable tape security
{ policies, you should insert a call to CHANGE_TAPE_VALIDATION in the
{ $SYSTEM.PROLOGS_AND_EPILOGS.SYSTEM_INITIATION_EPILOG:
{
{    CHANGE_TAPE_VALIDATION ENFORCE_TAPE_SECURITY=ON
{
{    This procedure is provided as part of the RMM$ENFORCE_TAPE_SECURITY site
{ hook.  As such, the source code of the implementation is available to
{ customers to review and to change as necessary to adapt to site-specific
{ security requirements.  NOS/VE has also placed code that is not inherently
{ related to tape security into the site hook because the code may implement a
{ policy that may not be desirable at some sites.  Placing such code in the
{ site hook allows the site to tailor the system to meet their requirements.
{
{    This procedure is implemented as a SYSTEM file access procedure, or SYSTEM
{ FAP.  It is not executed during normal GET/PUT data transfer operations,
{ except when reading or writing extends to another volume of the volume set.
{ However, it is called during other operations that are discussed below.  IT
{ IS EXTREMELY IMPORTANT FOR THE PROPER FUNCTIONING OF TAPE ACCESS THAT FAP
{ OPERATIONS DISCUSSED BELOW ARE PASSED THROUGH THIS FAP AS DESIGNED.  It is
{ possible for this FAP to intercept these calls and perform additional
{ processing but the call must ultimately be passed to the next FAP in the
{ stack for implementation of the request.  The calling sequences for these FAP
{ operations are defined in the type deck AMT$CALL_BLOCK on the
{ $SYSTEM.CYBIL.OSF$PROGRAM_INTERFACE library.
{
{      amc$dismount_current_volume:  This request dismounts the current volume
{            when access to the volume is denied due to security concerns.  It
{            is not used in any other circumstance and is therefore not related
{            to any externalized program interface.
{
{      amc$fetch_req:  This implements the AMP$FETCH request made by a user.
{            The site is free to modify the information that the user is
{            allowed to see.  To do this, first call the next SYSTEM FAP to
{            obtain the information, then edit it before returning to the
{            caller of this FAP.
{
{      amc$fetch_access_information_rq:  Same as above for amc$fetch_req.
{
{      amc$open_tape_volume:  This request causes a volume to be mounted.
{            Among the parameters passed in this request are the following
{            items that will be displayed in the VED, TAPE_MOUNT display.  If
{            the volume is a candidate for mounting by an operator, any field
{            that is set to a value other than SPACE is displayed in the VED,
{            TAPE_MOUNT display.  If the site does not desire a particular
{            field to be displayed in the VED, TAPE_MOUNT display it may set
{            the field to SPACE within this FAP.
{
{            ACCOUNT, FAMILY, PROJECT, and USER:  These fields identify the
{            login-user to the operator who may assign the requested volume.
{            These fields are set to SPACE by NOS/VE and are set to the
{            corresponding values of the login-user within this FAP.
{
{            REMOVABLE_MEDIA_GROUP, REMOVABLE_MEDIA_LOCATION, and SLOT:
{            These fields are initialized by the
{            REMOVABLE_MEDIA_MANAGEMENT_SYSTEM (RMS), if it is installed.
{            Together, the latter three fields identify the location of the
{            requested volume.
{
{            SOURCE_POOL and SOURCE_POOL_LOCATION are not used by this request
{            but are reserved for future implementation.
{
{      amc$read_tape_labels:  This request reads (or attempts to read) labels
{            from a tape volume.  NOS/VE calls this request whenever a volume
{            is mounted.  Thereafter, this request is called to read header
{            labels and trailer labels for each ANSI file in a file set.  The
{            labels will later be presented to this FAP as a parameter in one
{            of the tape security FAP requests discussed below; therefore,
{            there should be no need for the site to intercept this operation
{            to interpret the labels.  The site is dicouraged from making this
{            request on its own because, if not properly handled, the logical
{            position of a volume may lose synchronization with the physical
{            position.
{
{      amc$skip_req:  This request implements tapemark skipping requested by
{            the SYSTEM record access FAP during FILE_SET_POSITION operations.
{
{      amc$terminate_tape_volume:  This request unloads a tape volume during
{            GET/PUT or AMP$CLOSE_VOLUME operations.  Note that this request is
{            not called during DETACH_FILE processing because the FAP mechanism
{            is not operative at this time.
{
{      amc$write_tape_labels:  This request writes a sequence of labels and or
{            tapemarks to a tape volume.  This request is also called by this
{            FAP to write a label sequence during AUTHORIZE_VOLUME_REUSE
{            processing.  But it is also called at other times to write header
{            labels and trailer labels.
{
{    The amc$enforce_tape_security operation represents a class of requests all
{ related to the security of magnetic tape access.  The requests are
{ individually documented in more detail within the RMM$ENFORCE_TAPE_SECURITY
{ site hook.  However, an overview of each request is provided below.
{
{    Requests beginning with the word AUTHORIZE enforce security policies.
{ These policies ensure NOS/VE compliance with Department of Defense (DOD) C2
{ level security.
{
{    Requests beginning with the word VALIDATE ensure the consistency of fields
{ in header and trailer labels.  These requests are key to the ability of
{ NOS/VE to read labeled tapes that do not strictly conform to ANSI standards.
{
{    Requests beginning with the word SECURE allow a site to control visibility
{ of secure fields in ANSI labels.  NOS/VE maintains two sequences of header
{ labels and two sequences of trailer labels.  One pair of header/trailer
{ sequences is referred to as the UNSECURED sequences; the other pair is called
{ the SECURED sequences.  The UNSECURED header/trailer labels are first
{ VALIDATED by this FAP and then may be seen only by a
{ REMOVABLE_MEDIA_ADMINISTRATOR.  A copy of the UNSECURED header/trailer labels
{ are SECUREd by this FAP and then are made available to the normal user.
{
{
{      fsc$ts_authorize_access_method:  This request is called during an OPEN
{            when the user accesses a volume using FILE_LABEL_TYPE <>
{            amc$labeled.
{
{      fsc$ts_authorize_file_access:  This request is called during an OPEN
{            when file header labels are read, i.e.  when we are not reading
{            labels at the beginning of a volume.
{
{      fsc$ts_authorize_file_reuse:  This request is called during an OPEN when
{            the labels of an existing ANSI file are to be rewritten.
{
{      fsc$ts_authorize_file_set_mount:  This request is called during an OPEN
{            when volume header labels are read from the first volume of the
{            set.  This request is only called once per mount of the initial
{            volume of the volume set.  If the initial volume is dismounted and
{            remounted, the authority is rechecked to ensure that the volume
{            has not changed in any security details while dismounted from this
{            job.
{
{      fsc$ts_authorize_file_set_reuse:  This request is called during an OPEN
{            when the volume header labels are to be rewritten for the initial
{            volume of the volume set.
{
{      fsc$ts_authorize_section_read:  This request is called when labels are
{            read at the beginning of a volume other than the first volume of a
{            volume set when a GET operation spans volumes.
{
{      fsc$ts_authorize_section_write:  This request is called when labels are
{            to be written at the beginning of a volume other than the first
{            volume of a volume set.
{
{      fsc$ts_authorize_volume_reuse:  This request is called when a
{            REMOVABLE_MEDIA_OPERATOR is attempting to blank label or blank
{            unlabel a tape volume.  The site may use this opportunity to
{            consult its own database of tape volumes to ensure that the
{            operator has not made a mistake in choosing this volume to
{            initialize.  It is required that you call
{            PMP$EXECUTE_WITH_LESS_PRIVILEGE to execute a task to perform this
{            sort of analysis.  This FAP executes in Ring 3 of the NOS/VE
{            operating system and therefore is not interruptable.  Executing a
{            task allows the user to terminate-break.
{
{      fsc$ts_secure_header_labels:  This request is called whenever header
{            labels are read.  This request blanks secure fields in header
{            labels.
{
{      fsc$ts_secure_trailer_labels:  This request is called whenever trailer
{            labels are read.  This request blanks secure fields in trailer
{            labels.
{
{      fsc$ts_validate_header_labels:  This request is called whenever header
{            labels are read.  This request validates numeric and date fields
{            in header labels.
{
{      fsc$ts_validate_trailer_labels:  This request is called whenever trailer
{            labels are read.  This request validates numeric and date fields
{            in trailer labels.
{
{    The environment in which this FAP operates is shown below.  The FAPS are
{ listed in the order that they are called during tape operations.  Although,
{ as described above, only the operations described herein are passed below the
{ SYSTEM record access tape FAP.
{
{              1.  Optional user FAP
{
{              2.  SYSTEM record access tape FAP
{
{              3.  RMS FAP
{
{              4.  RMP$ENFORCE_TAPE_SECURITY FAP
{
{              5.  SYSTEM SERVICES FAP
*DECK DECK=RMH$FORMAT_VOL_CLASSIFICATION EXPAND=FALSE
{
{    The purpose of this procedure is to format a sequence of lines that
{ provide a textual representation of the classification of a magnetic tape
{ volume.
{
{    This interface is implemented within the RMM$ENFORCE_TAPE_SECURITY site
{ hook.  Therefore, the result of calling this interface is subject to site
{ modification.
{
{       RMP$FORMAT_VOL_CLASSIFICATION (MAX_MESSAGE_LINE, VOLUME_CLASSIFICATION,
{             FORMATTED_CLASSIFICATION, STATUS)
{
{ max_message_line: (input)  This parameter specifies the maximum length of a
{       line in the formatted result.
{
{ volume_classification: (input)  This parameter specifies the classification
{       of the volume prepared by RMP$CLASSIFY_TAPE_VOLUME.
{
{ formatted_classification: (output)  This parameter specifies the textual
{       representation of the volume classification in the form of a sequence
{       of strings.
{
{ status: (output)  This parameter specifies the status of the request.
{
*DECK DECK=RMH$GET_DEVICE_CLASS EXPAND=FALSE
{
{   The purpose of this request is to obtain the device class to which a file
{ is assigned.
{
*IF NOT $true(osv$unix)
{       RMP$GET_DEVICE_CLASS (FILE, FILE_REGISTERED, DEVICE_CLASS, STATUS)
*ELSE
{       RMP$GET_DEVICE_CLASS (FILE, DEVICE_CLASS, STATUS)
*IFEND
{
{ FILE: (input)  This parameter specifies the name of the file whose device
{       class is requested.  A cycle reference consisting of $next is not
{       permitted.  If the cycle reference is omitted, the value 1 will be
{       used.
{
*IF NOT $true(osv$unix)
{ FILE_REGISTERED: (output)  This parameter specifies whether the file is
{       registered in a catalog.
*IFEND
{
{ DEVICE_CLASS: (output)  This parameter specifies the device class to which
{       the file identifier is assigned.  If FILE_IDENTIFIER is not valid,
{       rmc$mass_storage_device will be returned.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=RMH$REQUEST_MASS_STORAGE EXPAND=FALSE
{
{   The purpose of this request is to register a file in the specified catalog,
{ to assign the file to a mass storage device with particular attributes, and
{ to create an attachment of the file to the requesting job.  The file is
{ attached with all modes of access and no sharing.
{
{   A DETACH_FILE command or amp$return request must be issued to explicitly
{ terminate the attachment of this file to the job.  An fsp$close_file request
{ will not detach a file whose attachment originated with this request.
{
{   This request is optional because NOS/VE assigns files to the mass storage
{ device class in the absence of a request such as this one.
{
{   This request will be rejected if the file cycle is already registered in
{ the specified catalog.
{
{   Each user is validated to have his/her files on a specific mass storage
{ set.  Each set is composed of one or more volumes of mass storage which are
{ candidates for assignment to this file.  This request provides four ways to
{ select from this list of candidate volumes the initial volume to which the
{ file will be assigned.
{
{     1.  If the INITIAL_VOLUME parameter is given a value other than
{         rmc$unspecified_vsn, then the volume identified by the recorded_vsn
{         is selected.
{
{     2.  If FILE_CLASS is given a value other than rmc$unspecified_file_class,
{         then the file will be assigned to a member of the designated class.
{
{     3.  If both INITIAL_VOLUME and FILE_CLASS are specified, then the
{         specific volume will be selected if and only if the mass storage
{         volume is a member of the class specified.
{
{     4.  If both rmc$unspecified_vsn and rmc$unspecified_file_class are
{         selected then the system will pick a candidate volume which has the
{         most available space.
{
{   One may use either the ALLOCATION_SIZE parameter or the ESTIMATED_FILE_SIZE
{ parameter to select the size of allocation to be used for the file; using
{ both parameters to make the selection is not permitted.  Using neither of the
{ two parameters to select allocation size will cause the system's nominal
{ allocation size to be used.
{
{       RMP$REQUEST_MASS_STORAGE (FILE, ALLOCATION_SIZE, ESTIMATED_FILE_SIZE,
{         FILE_CLASS, INITIAL_VOLUME, VOLUME_OVERFLOW_ALLOWED, STATUS)
{
{ FILE: (input)  This parameter specifies the name of the file which is to be
{       registered in a catalog and assigned to the mass storage device class.
{       The cycle reference must not refer to $HIGH or $LOW.  If the cycle
{       reference is omitted for a temporary file, the value 1 will be used.
{       If the cycle reference is omitted for a permanent file and there are no
{       existing cycles, the value 1 will be used for the cycle number;
{       otherwise, a value one higher than the current highest cycle will be
{       used.
{
{ ALLOCATION_SIZE: (input)  This parameter specifies the amount of contiguous
{       mass storage space, in bytes, which is to be allocated to the file each
{       time additional space is needed.  The system will use the value of this
{       parameter as a guide in selecting the quantum of allocation for this
{       file.  The actual allocation size for the file may be more or less than
{       the specified value due to the characteristics of the device determined
{       by the other parameters of this request.
{
{       The value rmc$unspecified_allocation_size will cause the allocation
{       size to be determined by the ESTIMATED_FILE_SIZE parameter.
{
{ ESTIMATED_FILE_SIZE: (input)  This parameter specifies the likely size of the
{       file in bytes.  This information is used to select the allocation size
{       which would minimize the amount of mass storage space assigned to the
{       file should it ulimately reach the estimated size.  This parameter is
{       not implemented at this time.
{
{       The value rmc$unspecified_file_size will cause the allocation size to
{       be determined by the ALLOCATION_SIZE parameter.
{
{ FILE_CLASS: (input)  This parameter specifies the class of the file which is
{       to be assigned.  NOS/VE supports up to 26 classes of files.  Each class
{       is identified by an alphabetic character (upper and lower cases are
{       equivalent).  NOS/VE will select a volume which belongs to the class
{       specified by this parameter; abnormal status will be returned if no
{       candidate volume belongs to the specified class.
{
{       Only the user $SYSTEM may specify the following values:
{
{           rmc$msc_system_swap_files      (C)
{           rmc$msc_system_catalogs        (J)
{           rmc$msc_system_permanent_files (K)
{           rmc$msc_user_catalogs          (L)
{           rmc$msc_system_critical_files  (Q)
{
{       A task executing in rings 6..4 may specify any file class except C, J,
{       K, L, and Q.
{
{       A task executing in rings 13..7 may specify rmc$user_permanent_files (M)
{       for a permanent file and rmc$user_temporary_files (N) for a temporary
{       file.
{
{       The value rmc$unspecified_file_class causes NOS/VE to place the file on
{       the volume specified by the INITIAL_VOLUME parameter.
{
{       If the value rmc$unspecified_vsn is used for the INITIAL_VOLUME
{       parameter and rmc$unspecified_file_class is also specified for this
{       parameter, NOS/VE will assign the file to a volume that belongs to the
{       class that is appropriate for the file and the job in which the file is
{       created.  Refer to the System Performance and Maintenance manual for
{       information about the NOS/VE default file assignments in effect for this
{       release.
{
{       Specification of any non-alphabetic character will cause abnormal
{       status to be returned.
{
{ INITIAL_VOLUME: (input)  This parameter specifies the identification of a
{       specific mass storage volume to which this file is to be assigned.
{
{       If volume overflow is not allowed, the entire file will reside on this
{       volume; otherwise, this volume will be the initial volume assigned to
{       the file.  Refer to the VOLUME_OVERFLOW_ALLOWED parameter.
{
{       If the requested volume has no space available or the volume does not
{       exist in the active configuration, this request will be rejected.
{
{       If FILE_CLASS is given a value other than rmc$unspecified_file_class,
{       then the volume specified by this parameter must belong to the file
{       class specified or the request will be rejected.
{
{       The user $SYSTEM may use this parameter to place a file on any volume
{       in the configuration; however, rmc$unspecified_file_class will need to
{       be specified for the FILE_CLASS parameter.
{
{       A user executing in the maintenance job class may use this parameter to
{       place a temporary file on any volume in the configuration, regardless
{       of whether or not the volume belongs to the temporary file class (N);
{       however, rmc$unspecified_file_class will need to be specified for the
{       FILE_CLASS parameter.
{
{       A task executing in rings 6..4 may specify any volume that belongs to
{       one of the following classes:  B, D ..I, M .. P, R .. Z.
{
{       A task executing in rings 13..7 may specify any volume that belongs to
{       class M for a permanent file or class N for a temporary file.
{
{       The value rmc$unspecified_vsn will cause the consideration of all
{       candidate volumes belonging to the file class specified (or defaulted).
{
{ VOLUME_OVERFLOW_ALLOWED: (input)  This parameter specifies whether or not the
{       file can be assigned to more than one volume.  If TRUE is specified,
{       the file may span any volume subject to validation and FILE_CLASS
{       constraints.  If FALSE is specified, the file will be confined to the
{       initial volume to which it is assigned.  Specifying no volume overflow
{       would typically be used in conjunction with requesting a specific mass
{       storage volume; this is generally done for fault tolerance reasons.
{       For example, all the files which are required for a particular feature
{       or product (e.g.  those required for system maintenance or operation)
{       must reside on the same volume (usually the system deadstart device) to
{       ensure their availability in case of a failure on any of the other
{       volumes.  Of course, copies of the files may be located on a second
{       volume (preferably on a different hardware path) to maximize
{       availability.
{
{       Specification of FALSE is permitted only in a job which has system
{       administrative privilege or maintenance privilege.
{
{       STATUS: (output)  This parameter specifies the request status.
{
{        CONDITIONS: pfe$bad_cycle_number
{                    pfe$bad_cycle_option
{                    pfe$bad_family_name
{                    pfe$bad_local_file_name
{                    pfe$bad_log_option
{                    pfe$bad_master_catalog_name
{                    pfe$bad_nth_subcatalog_name
{                    pfe$bad_password
{                    pfe$bad_permanent_file_name
{                    pfe$bad_retention_period
{                    pfe$catalog_full
{                    pfe$cycle_overflow
{                    pfe$cycle_underflow
{                    pfe$duplicate_cycle
{                    pfe$incorrect_password
{                    pfe$lfn_in_use
{                    pfe$name_already_subcatalog
{                    pfe$nth_name_not_subcatalog
{                    pfe$path_too_short
{                    pfe$pf_system_error
{                    pfe$unknown_family
{                    pfe$unknown_master_catalog
{                    pfe$unknown_nth_subcatalog
{                    pfe$usage_not_permitted
{                    rme$file_class_not_valid
{                    rme$improper_alloc_size_value
{                    rme$improper_cycle_reference
{                    rme$improper_est_file_size
{                    rme$improper_file_class
{                    rme$improper_recorded_vsn,
{                    rme$improper_vol_overflow
{                    rme$job_not_privileged,
{                    rme$redundant_alloc_size_spec,
{                    rme$vsn_not_part_of_set
{
{       IDENTIFIER: rmc$resource_management_id.
{
*DECK DECK=RMH$REQUEST_NULL_DEVICE EXPAND=FALSE
{
{   The purpose of this request is to register a file in a temporary catalog,
{ to assign the file to the null device class, and to create an attachment of
{ the file to the requesting job.  The file is attached with all modes of
{ access and no sharing.  A file assigned to the null device class behaves as
{ an 'infinite sink' for write operations and appears empty on all read
{ operations.
{
{   A DETACH_FILE command or amp$return request must be issued to explicitly
{ terminate the attachment of this file to the job.  An fsp$close_file request
{ will not detach a file whose attachment originated with this request.
{
{   This request will be rejected if the file cycle is already registered in the
{ specified catalog.
{
{       RMP$REQUEST_NULL_DEVICE (FILE, STATUS)
{
{ FILE: (input)  This parameter specifies the name of the file which is to be
{       registered in a catalog and assigned to the null device class.  The
{       cycle reference must not refer to $HIGH or $LOW.  If the cycle
{       reference is omitted, the value 1 will be used.
{
{ STATUS: (output) This parameter specifies the request status.
{
{       CONDITION:
{                   rme$file_already_registered,
{                   rme$improper_cycle_reference,
{                   rme$not_temporary_catalog.
{
{       IDENTIFIER: rmc$resource_management_id.
*DECK DECK=RMH$REQUEST_TAPE EXPAND=FALSE
{
{   The purpose of this request is to register a file in a temporary catalog,
{ to assign the file to the magnetic tape device class, and to create an
{ attachment of the file to the requesting job.  The file is attached with all
{ modes of access and no sharing.  This request identifies the media on which
{ the file will reside and the characteristics of the tape storage device on
{ which the media must be mounted.
{
{   A DETACH_FILE command or amp$return request must be issued to explicitly
{ terminate the attachment of this file to the job.  An fsp$close_file request
{ will not detach a file whose attachment originated with this request.
{
{   This request will be rejected if the file cycle is already registered in
{ the specified catalog.
{
{   This request does not cause operator assignment of a specific tape storage
{ device to the job.  Refer to the FSP$OPEN_FILE request.
{
{       RMP$REQUEST_TAPE (FILE, CLASS, DENSITY, WRITE_RING, VOLUME_LIST,
{         STATUS)
{
{ FILE: (input)  This parameter specifies the name of the file which is to be
{       registered in a catalog and assigned to the magnetic tape device
{       class.  The cycle reference must not refer to $HIGH or $LOW.  If the
{       cycle reference is omitted, the value 1 will be used.
{
{ CLASS: (input)  This parameter specifies the type of tape storage device
{       required, i.e.  whether 7 or 9 track tape is required.
{
{ DENSITY: (input)  This parameter specifies the density of the tape storage
{       device.
{
{ WRITE_RING: (input)  This parameter specifies the presence or absence of a
{       write ring in all the tape volumes associated with the file.
{
{ VOLUME_LIST: (input)  This parameter specifies the identity of the tape
{       volume(s) to be mounted.  Volumes are mounted in the order in which
{       they are specified.  Each volume is identified by either a
{       recorded_vsn, an external_vsn or by both recorded_vsn and
{       external_vsn.
{
{       Specification of rmc$unspecified_vsn for both recorded_vsn and
{       external_vsn is permitted if only one volume description is provided.
{       If this is done the operator will be asked to supply the initial
{       volume description as well as any additional volume descriptions.
{
{       If recorded_vsn and external_vsn are each given values other than
{       rmc$unspecified_vsn and the two values are not identical, automatic
{       volume assignment will not occur; the operator will be asked to mount
{       the volume identified by the external_vsn.  The system will then
{       validate that the recorded_vsn provided by this request matches the
{       one recorded in the VOL1 label recorded on the tape medium.
{
{       recorded_vsn - specifies the identity of an ANSI labelled volume.  If
{       rmc$unspecified_vsn is specified, the external_vsn will be used to
{       identify the volume to be mounted.  If a recorded_vsn is specified,
{       the VOL1 label of the tape volume assigned to the file must match the
{       value specified or the tape assignment is rejected.  The recorded_vsn
{       may be composed of the characters 0..9, the upper case letters A..Z
{       and the following special characters:
{
{       SP !  " % & ' ( ) * + , - .  / :  ; < = { > ?  _
{
{       external_vsn - specifies the identity of a magnetic tape volume in
{       terms which will be readily identifiable to the operator.  If
{       rmc$unspecified_vsn is specified, the recorded_vsn will be used to
{       identify the volume to be mounted.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{                   rme$improper_class_value,
{                   rme$improper_cycle_reference,
{                   rme$improper_density_value,
{                   rme$improper_external_vsn_value,
{                   rme$improper_recorded_vsn_value,
{                   rme$improper_write_ring_value,
{                   rme$not_temporary_catalog,
{                   rme$null_volume_description.
{
{       IDENTIFIER: rmc$resource_management_id.
{
*DECK DECK=RMH$REQUEST_TERMINAL EXPAND=FALSE
{
{   The purpose of this request is to register a file in a temporary catalog,
{ to assign the file to the terminal device class, and to create an attachment
{ of the file to the requesting job.  In addition one may describe attributes
{ of the terminal device which are to be in effect when the terminal device is
{ accessed implicitly as a result of access to this file.  The file is
{ attached with all modes of access and no sharing.
{
{   A DETACH_FILE command or amp$return request must be issued to explicitly
{ terminate the attachment of this file to the job.  An fsp$close_file request
{ will not detach a file whose attachment originated with this request.
{
{   This request will be rejected if the file cycle is already registered in the
{ specified catalog.
{
{   The terminal attributes for this file are established by using all values
{ specified in this request, then using default terminal attributes for all
{ attributes not specified in this request.  These default attributes come
{ from NAM defaults, NOS/VE defaults, TERMINAL commands, and IFP$TERMINAL
{ requests.
{
{   This request is ignored if it is not issued by an interactive job.
{
{       RMP$REQUEST_TERMINAL (FILE, TERMINAL_ATTRIBUTES, STATUS)
{
{ FILE: (input)  This parameter specifies the name of the file which is to be
{       registered in a catalog and assigned to the terminal device class.
{       The cycle reference must not refer to $HIGH or $LOW.  If the cycle
{       reference is omitted, the value 1 will be used.
{
{ TERMINAL_ATTRIBUTES: (input)  This parameter specifies one or more terminal
{       attributes that are to be associated with the file.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITION:
{                   rme$file_already_registered,
{                   rme$improper_alloc_size_value,
{                   rme$improper_cycle_reference,
{                   rme$improper_term_attrib_key,
{                   rme$improper_term_attrib_value,
{                   rme$not_temporary_catalog.
{
{       IDENTIFIER: rmc$resource_management_id.
*DECK DECK=RMH$VALIDATE_MASS_STORAGE_INFO EXPAND=FALSE
{
{   The purpose of this request is to validate the mass storage
{ information supplied. The following rules are enforced during
{ validation of the mass storage information:
{
{   System User -- system administration authority
{     Create files and catalogs on any device.
{     Create files and catalogs with any class.
{
{   Privileged User -- Task running at ring 6 or below
{     These users are given access to the file classes not reserved
{         by Control Data.
{     Create files on any device except those with classes C, J, K, Q,
{         or L as valid classes.
{     Create catalogs on any device except those devices with classes C, J, K,
{         Q, or M as valid classes.
{     Create files of any class except C, J, K, Q and L.
{     Create catalogs of any class except C, J, K, Q and M.
{
{   Normal User -- ring > 6
{     Create permanent files on devices with class M as a valid class.
{     Create catalogs on devices with class L as a valid class.
{     Create temporary files on devices with class N as a valid class.
{     Create permanent files of class M.
{     Create catalogs of class L.
{     Create temporary files of class N.
{
{     A job with job class of MAINTENANCE can create temporary files
{     on any device.
{
{     A job with job clas of MAINTENANCE or system administration authority
{     can create a file with volume overflow inhibited.
{
{       RMP$VALIDATE_MASS_STORAGE_INFO (FAMILY_SET_NAME, OBJECT_PERMANENT
{             OBJECT_TYPE, P_MASS_STORAGE_REQUEST_INFO, STATUS);
{
{ FAMILY_SET_NAME: (input) This parameter identifies the set name of the file
{       or catalog.
{
{ OBJECT_PERMANENT: (input) This parameter indicates whether the object is
{       permanent.
{
{ OBJECT_TYPE: (input) This parameter specifies the type of object to validate.
{
{ P_MASS_STORAGE_REQUEST_INFO: (input) This parameter specifies the location
{       of the mass storage information which is to be validated.
{
{ STATUS: (output) This parameter returns the status to the caller.
{
{       CONDITIONS:
{             rme$file_class_not_valid
{             rme$job_not_valid
{             rme$unknown_volume
{             rme$volume_overflow_required
{             rme$vsn_not_part_of_set
{
*DECK DECK=RMH$VALIDATE_TAPE_ASSIGNMENT EXPAND=FALSE
{
{   This procedure is the site procedure which validates each tape volume which
{ is assigned to a tape file.  It is called prior to the assignment of each
{ tape volume.  The site procedure must call RMP$COMPLETE_TAPE_ASSIGNMENT to
{ complete the tape assignment.
{
{       RMP$VALIDATE_TAPE_ASSIGNMENT (VALIDATION_STATE, FILE_IDENTIFIER, FILE,
{         DENSITY, WRITE_RING, FILE_LABEL_TYPE, ACCESS_MODE,
{         INITIAL_ASSIGNMENT, NEXT_VOLUME, VOLUME_DESCRIPTOR,
{         REMOVABLE_MEDIA_GROUR, REMOVABLE_MEDIA_LOCATION, STATUS)
{
{ VALIDATION_STATE: (input)  This parameter specifies the tape validation state
{       which is set to ON or OFF by the CHANGE_TAPE_VALIDATION operator
{       command.
{
{ FILE_IDENTIFIER: (input)  This parameter specifies the file access identifier
{       established when the file was opened.
{
{ FILE: (input)  This parameter specifies the name of the tape file to which
{       the tape volume is to be assigned.
{
{ DENSITY: (input)  This parameter specifies the density of the tape storage
{       device.
{
{ WRITE_RING: (input)  This parameter specifies the presence or absence of a
{       write ring in all of the tape volumes associated with the file.
{
{ FILE_LABEL_TYPE: (input)  This parameter specifies the label type of the tape
{       file.
{
{ ACCESS_MODE: (input)  This parameter specifies the access mode of the file.
{
{ INITIAL_ASSIGNMENT: (input)  This parameter specifies whether or not this is
{       the initial assignment of a tape volume to the tape file.
{
{ NEXT_VOLUME: (input)  This parameter specifies the number of the volume in
{       the volume list of the next volume to be mounted.
{
{ VOLUME_DESCRIPTION: (input)  This parameter specifies the identity of the
{       tape volume to be mounted.  Each volume is identified on the
{       REQUEST_MAGNETIC_TAPE command or RMP$REQUEST_TAPE program interface by
{       a recorded_vsn, an external_vsn or by both a recorded_vsn and an
{       external_vsn.
{
{       If both the EXTERNAL_VSN and the RECORDED_VSN parameters are omitted
{       from the REQUEST_MAGNETIC_TAPE command or rmc$unspecified_vsn is
{       specified for both the external_vsn and the recorded_vsn on the
{       RMP$REQUEST_TAPE program interface, then the operator will be asked to
{       supply the EXTERNAL_VSN and optional RECORDED_VSN of the initial tape
{       volume.  The operator will also be asked to supply the EXTERNAL_VSN and
{       optional RECORDED_VSN of additional tape volumes whenever a program
{       attempts to write beyond the last volume in the volume list.
{
{       If recorded_vsn and external_vsn are each given values other than
{       rmc$unspecified_vsn and the two values are not identical, automatic
{       volume assignment will not occur; the operator will be asked to mount
{       and manually assign the volume identified by the external_vsn.  The
{       system will then validate that the recorded_vsn provided by this
{       request matches the one recorded in the VOL1 label recorded on the tape
{       volume.
{
{       recorded_vsn - specifies the identity of an ANSI labelled volume.  If a
{       recorded_vsn is specified, the VOL1 label of the tape volume assigned
{       to the file must match the value specified or the tape assignment is
{       rejected.  The recorded_vsn may be composed of the characters 0..9, the
{       upper case letters A..Z and the following special characters:
{
{       SP !  " % & ' ( ) * + , - .  / :  ; < = { > ?  _ $ # @
{
{       external_vsn - specifies the identity of a magnetic tape volume in
{       terms which will be readily identifiable to the operator.  If
{       rmc$unspecified_vsn is specified, the recorded_vsn will be used to
{       identify the volume to be mounted.  The external_vsn may be composed of
{       the characters 0..9, the upper case letters A..Z and the following
{       special characters:
{
{       SP !  " % & ' ( ) * + , - .  / :  ; < = { > ?  _ $ # @
{
{ REMOVABLE_MEDIA_GROUP: (input) This parameter specifies the group validation
{       that is associated with the tape.
{
{ REMOVABLE_MEDIA_LOCATION: (input) This parameter specifies the location
{       of the tate as defined by the REMOVABLE_MEDIA_SUBSYSTEM.
{
{ STATUS: (output) This parameter specifies the request status.  If the site
{       validation procedure returns abnormal status, this status variable will
{       be returned on the user's access method call.  In this case, the
{       assignment
{       will not be completed and the tape file will be closed.
{
{       IDENTIFIER: rmc$resource_management_id.
{
*DECK DECK=RMH$VALIDATE_TAPE_REQUEST EXPAND=FALSE
{
{   This procedure is the site procedure which validates requests for magnetic
{ tape files.  It is called for the REQUEST_MAGNETIC_TAPE command and the
{ RMP$REQUEST_TAPE program request.  The site procedure must call
{ RMP$COMPLETE_TAPE_REQUEST to complete the tape request.
{
{       RMP$VALIDATE_TAPE_REQUEST (VALIDATION_STATE, FILE, CLASS, DENSITY,
{         WRITE_RING, VOLUME_LIST, STATUS)
{
{ VALIDATION_STATE: (input)  This parameter specifies the tape validation state
{       which is set to ON or OFF by the CHANGE_TAPE_VALIDATION operator
{       command.
{
{ FILE: (input)  This parameter specifies the name of the file which is to be
{       registered in a catalog and assigned to the magnetic tape device class.
{
{ CLASS: (input)  This parameter specifies the type of tape storage device
{       required, i.e.  whether 7 or 9 track tape is required.
{
{ DENSITY: (input)  This parameter specifies the density of the tape storage
{       device.
{
{ WRITE_RING: (input)  This parameter specifies the presence or absence of a
{       write ring in all the tape volumes associated with the file.
{
{ VOLUME_LIST: (input)  This parameter specifies the identity of the tape
{       volume(s) to be mounted.  Volumes are mounted in the order in which
{       they are specified.  Each volume is identified on the
{       REQUEST_MAGNETIC_TAPE command or RMP$REQUEST_TAPE program interface by
{       a recorded_vsn, an external_vsn or by both a recorded_vsn and an
{       external_vsn.
{
{       If both the EXTERNAL_VSN and the RECORDED_VSN parameters are omitted
{       from the REQUEST_MAGNETIC_TAPE command or rmc$unspecified_vsn is
{       specified for both the external_vsn and the recorded_vsn on the
{       RMP$REQUEST_TAPE program interface, then the operator will be asked to
{       supply the EXTERNAL_VSN and optional RECORDED_VSN of the initial tape
{       volume.  The operator will also be asked to supply the EXTERNAL_VSN and
{       optional RECORDED_VSN of additional tape volumes whenever a program
{       attempts to write beyond the last volume in the volume list.
{
{       If recorded_vsn and external_vsn are each given values other than
{       rmc$unspecified_vsn and the two values are not identical, automatic
{       volume assignment will not occur; the operator will be asked to mount
{       and manually assign the volume identified by the external_vsn.  The
{       system will then validate that the recorded_vsn provided by this
{       request matches the one recorded in the VOL1 label recorded on the tape
{       volume.
{
{       recorded_vsn - specifies the identity of an ANSI labelled volume.  If a
{       recorded_vsn is specified, the VOL1 label of the tape volume assigned
{       to the file must match the value specified or the tape assignment is
{       rejected.  The recorded_vsn may be composed of the characters 0..9, the
{       upper case letters A..Z and the following special characters:
{
{       SP !  " % & ' ( ) * + , - .  / :  ; < = { > ?  _ $ # @
{
{       external_vsn - specifies the identity of a magnetic tape volume in
{       terms which will be readily identifiable to the operator.  If
{       rmc$unspecified_vsn is specified, the recorded_vsn will be used to
{       identify the volume to be mounted.  The external_vsn may be composed of
{       the characters 0..9, the upper case letters A..Z and the following
{       special characters:
{
{       SP !  " % & ' ( ) * + , - .  / :  ; < = { > ?  _ $ # @
{
{ STATUS: (output) This parameter specifies the request status.  If the site
{       validation procedure returns abnormal status, the tape request will
{       not be completed and this status variable will be returned to the
{       user's RMP$REQUEST_TAPE program request.  If a REQUEST_MAGNETIC_COMMAND
{       was used, it will be used to create the error message that is returned
{       by the command.
{
{       IDENTIFIER: rmc$resource_management_id.
{
*DECK DECK=RMH$VALIDATE_TAPE_VOLUME_INIT EXPAND=FALSE
{
{   This procedure is the site procedure which validates the initialization of
{ each tape volume.  It is called after existing labels on the tape volume have
{ been read but prior to presenting a menu to the operator.  The procedure can
{ modify the EXPIRATION_DATE, FILE_ACCESSIBILITY_CODE, INTERNAL_CODE,
{ LABEL_STANDARD_VERSION, OWNER_IDENTIFIER, RECORDED_VSN and
{ VOLUME_ACCESSIBILITY_CODE in the tape volume initialization information that
{ is used to initialize the volume.  The site procedure must call
{ RMP$COMPLETE_TAPE_VOLUME_INIT to complete the tape volume initialization.
{
{       RMP$VALIDATE_TAPE_VOLUME_INIT (VALIDATION_STATE, OLD_VOLUME_INIT_INFO,
{         NEW_VOLUME_INIT_INFO, STATUS)
{
{ VALIDATION_STATE: (input)  This parameter specifies the tape validation state
{       which is set to ON or OFF by the CHANGE_TAPE_VALIDATION operator
{       command.
{
{ OLD_VOLUME_INIT_INFO: (input)  This parameter contains information which
{       describes the content of the existing tape volume.
{
{ NEW_VOLUME_INIT_INFO: (input)  This parameter contains information specified
{       by the INITIALIZE_TAPE_VOLUME command.
{
{ STATUS: (output) This parameter specifies the request status.  If the site
{       validation procedure returns abnormal status, the initialization will
{       not be completed and this status variable will be used to create the
{       error message that is returned by the INITIALIZE_TAPE_VOLUME command.
{
{       IDENTIFIER: rmc$resource_management_id.
{
*DECK DECK=RMI$BLOCK_EXIT_HANDLER EXPAND=FALSE
?? NEWTITLE := '  rmp$block_exit_handler', EJECT ??

  PROCEDURE rmp$block_exit_handler
    (    condition: pmt$condition;
         p_condition_info: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR condition_status: ost$status);

    VAR
      local_status: ost$status,
      lock_status: ost$signature_lock_status;

    CASE condition.selector OF

    = pmc$block_exit_processing =

      osp$test_signature_lock (rmv$job_tape_table_lock, lock_status,
            local_status);
      IF local_status.normal AND (lock_status = osc$sls_locked_by_current_task)
            THEN
        osp$end_subsystem_activity;
        osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      IFEND;
    ELSE
      pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
    CASEND;

  PROCEND rmp$block_exit_handler;
?? OLDTITLE ??
*DECK DECK=RMK$KEYPOINTS EXPAND=FALSE

{ this common deck defines constants for use with
{ keypoints in rmp procedures.
{ COMMON DECK RMDKEY }

  CONST
    rmk$get_device_class = rmk$base + 1,
    {E 'rmp$get_device_class' }
    {X 'rmp$get_device_class' 'status' I20 }

    rmk$request_mass_storage = rmk$base + 2,
    {E 'rmp$request_mass_storage' }
    {X 'rmp$request_mass_storage' 'status' I20}

    rmk$request_null_device = rmk$base + 3,
    {E 'rmp$request_null_device' }
    {X 'rmp$request_null_device' 'status' I20}

    rmk$request_tape = rmk$base + 4,
    {E 'rmp$request_tape'}
    {X 'rmp$request_tape' 'status' I20}

    rmk$request_terminal = rmk$base + 5;
    {E 'rmp$request_terminal'}
    {X 'rmp$request_terminal' 'status' I20}


?? PUSH (LISTEXT := ON) ??
*copyc OSK$KEYPOINTS
?? POP ??
*DECK DECK=RMM$COMPLETE_TAPE_OPERATIONS EXPAND=TRUE
*copyc osd$default_pragmats
MODULE rmm$complete_tape_operations;
*copyc amp$access_method
*copyc amp$set_file_instance_abnormal
*copyc bap$set_evaluated_file_abnormal
*copyc bap$validate_file_identifier
*copyc bav$global_tape_fap_variables
*copyc clp$convert_file_ref_to_string
*copyc clp$convert_integer_to_string
*copyc dmp$close_current_tape_volume
*copyc dmp$close_tape_volume
*copyc dmp$create_tape_file_sfid
*copyc dmp$get_tape_volume_information
*copyc fmp$attach_file
*copyc fmp$get_system_file_id
*copyc fmv$default_detachment_options
*copyc fsp$evaluate_file_reference
*copyc fsp$path_element
*copyc iov$number_of_tape_units
*copyc osp$generate_unique_binary_name
*copyc pfp$convert_fs_to_pft$path
*copyc pfp$get_object_information
*copyc pfp$r3_append_rem_media_vsn
*copyc pfp$r3_define_removable_media
*copyc pfv$write_usage
?? PUSH (LISTEXT := ON) ??
*copyc ame$improper_file_id
*copyc dme$tape_errors
*copyc dmt$tape_assignment_operation
*copyc dmt$tape_job_lun_table
*copyc fse$attach_validation_errors
*copyc fst$file_reference
*copyc fst$goi_object_information
*copyc oss$job_paged_literal
*copyc ost$name
*copyc ost$status
*copyc pfd$permanent_file_attributes
*copyc rmt$density
*copyc rmt$volume_descriptor
*copyc rmt$write_ring
?? POP ??

  CONST
    command_file_reference_allowed = TRUE,
    max_tape_volumes = 256;

  VAR
    goi_information_request: [oss$job_paged_literal, READ] fst$goi_information_request :=
          [[fsc$specific_depth, 1], [fsc$goi_catalog_identity, fsc$goi_catalog_device_info,
          fsc$goi_cycle_device_info]];

?? TITLE := 'rmp$complete_tape_assignment', EJECT ??

  PROCEDURE [XDCL] rmp$complete_tape_assignment (
         file_identifier: amt$file_identifier;
         file: fst$file_reference;
         density: rmt$density;
         write_ring: rmt$write_ring;
         file_label_type: amt$file_label_type;
         access_mode: pft$usage_selections;
         initial_assignment: boolean;
         next_volume: amt$volume_number;
         volume_descriptor: rmt$volume_descriptor;
         removable_media_group: ost$name;
         removable_media_location: ost$name;
     VAR operator_terminated_assignment: boolean;
     VAR status: ost$status);

    VAR
      call_block: amt$call_block,
      current_volume: amt$volume_number,
      current_vsns: rmt$volume_descriptor,
      cycle_selector: pft$cycle_selector,
      detachment_options: fmt$detachment_options,
      evaluated_file_reference: fst$evaluated_file_reference,
      file_instance: ^bat$task_file_entry,
      first_volume_descriptor: rmt$volume_descriptor,
      fs_path: fst$path,
      fs_path_size: fst$path_size,
      ignore_current_volume: amt$volume_number,
      ignore_current_vsns: rmt$volume_descriptor,
      ignore_density: rmt$density,
      ignore_device_class: rmt$device_class,
      ignore_label_type: amt$label_type,
      ignore_removable_media_req_info: ^fmt$removable_media_req_info,
      ignore_volume_attributes: iot$requested_volume_attributes,
      ignore_volume_overflow_allowed: boolean,
      ignore_write_ring: rmt$write_ring,
      label_type: amt$label_type,
      number_of_volumes: 0 .. amc$max_vol_number,
      number_of_volumes_after_assign: amt$volume_number,
      number_of_volumes_before_assign: amt$volume_number,
      open_tape_volume: ^amt$open_tape_volume,
      p_object_info_seq: ^SEQ ( * ),
      p_object_information: ^fst$goi_object_information,
      p_path: ^pft$path,
      sfid: dmt$system_file_id,
      validation_ok: boolean,
      volume_list: ^rmt$volume_list;

    bap$validate_file_identifier (file_identifier, file_instance, validation_ok);
    IF NOT validation_ok THEN
      amp$set_file_instance_abnormal (file_identifier, ame$improper_file_id,
          LOWERVALUE (amt$last_operation), '', status);
      RETURN;
    IFEND;

{ If there is a current volume assigned to the tape file then return
{ the current tape volume before requesting the next tape volume.

    IF NOT initial_assignment THEN
      fmp$get_system_file_id (file_instance^.local_file_name, sfid, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      detachment_options := fmv$default_detachment_options;
      detachment_options.device_class := rmc$magnetic_tape_device;
      detachment_options.physical_unload := TRUE;
      dmp$close_current_tape_volume (sfid, detachment_options, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (fsp$path_element (^evaluated_file_reference, 1)^ <> fsc$local) AND
            ((access_mode * pfv$write_usage) <> $pft$usage_selections []) AND
            ((volume_descriptor.external_vsn = rmc$unspecified_vsn) AND
            (volume_descriptor.recorded_vsn = rmc$unspecified_vsn)) THEN
        dmp$get_tape_volume_information (sfid, number_of_volumes_before_assign, ignore_current_volume,
              ignore_current_vsns, ignore_density, ignore_write_ring, ignore_volume_attributes,
              ignore_volume_overflow_allowed, ignore_label_type, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    fsp$evaluate_file_reference (file, command_file_reference_allowed, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Now ask for the next tape volume to be assigned. This request will first
{ go to the RMS fap if installed and then go to the site hook for processing.

    PUSH open_tape_volume;
    call_block.operation := amc$open_tape_volume;
    call_block.open_tape_volume := open_tape_volume;

    open_tape_volume^.tape_density := density;
    open_tape_volume^.write_ring := write_ring;
    open_tape_volume^.file_label_type := file_label_type;
    open_tape_volume^.access_mode := access_mode;
    open_tape_volume^.initial_assignment := initial_assignment;
    open_tape_volume^.opening_volume_number := next_volume;
    open_tape_volume^.opening_volume := volume_descriptor;
    open_tape_volume^.removable_media_group := removable_media_group;
    open_tape_volume^.removable_media_location := removable_media_location;
    open_tape_volume^.account := osc$null_name;
    open_tape_volume^.family := osc$null_name;
    open_tape_volume^.project := osc$null_name;
    open_tape_volume^.slot := osc$null_name;
    open_tape_volume^.source_pool := osc$null_name;
    open_tape_volume^.source_pool_location := osc$null_name;
    open_tape_volume^.user := osc$null_name;

    amp$access_method (file_identifier, call_block, global_layer_number, status);
    operator_terminated_assignment := FALSE;
    IF NOT status.normal THEN
      IF (status.condition = dme$operator_stop) OR (status.condition = dme$termination_condition) THEN
        operator_terminated_assignment := TRUE;
      IFEND;
      RETURN;
    IFEND;

    IF (fsp$path_element (^evaluated_file_reference, 1)^ <> fsc$local) AND
          (initial_assignment OR ((access_mode * pfv$write_usage) <> $pft$usage_selections [])) THEN
      IF ((volume_descriptor.external_vsn = rmc$unspecified_vsn) AND
            (volume_descriptor.recorded_vsn = rmc$unspecified_vsn)) THEN
        IF initial_assignment THEN
          fmp$get_system_file_id (file_instance^.local_file_name, sfid, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        dmp$get_tape_volume_information (sfid, number_of_volumes_after_assign, current_volume,
              current_vsns, ignore_density, ignore_write_ring, ignore_volume_attributes,
              ignore_volume_overflow_allowed, ignore_label_type, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF (initial_assignment AND (current_volume = 1) AND (number_of_volumes_after_assign = 1))
              OR ((NOT initial_assignment)
              AND (number_of_volumes_after_assign = (number_of_volumes_before_assign + 1))) THEN
          PUSH p_path: [1 .. evaluated_file_reference.number_of_path_elements];
          pfp$convert_fs_to_pft$path (evaluated_file_reference, p_path^);
          cycle_selector.cycle_option := pfc$specific_cycle;
          cycle_selector.cycle_number := evaluated_file_reference.cycle_reference.cycle_number;
          pfp$r3_append_rem_media_vsn (p_path^, cycle_selector, current_vsns, status);
        IFEND;
      ELSE
        clp$convert_file_ref_to_string (evaluated_file_reference, {include_open_position} FALSE,
              fs_path, fs_path_size, status);
        IF status.normal THEN
          PUSH p_object_info_seq: [[REP #SIZE(fst$goi_object_information) OF cell,
                REP fsc$max_path_size OF cell, REP #SIZE (fst$goi_object) OF cell,
                REP #SIZE (fst$device_information) OF cell,
                REP (max_tape_volumes * #SIZE (rmt$volume_descriptor)) OF cell]];

          pfp$get_object_information (fs_path(1, fs_path_size), goi_information_request,
                {p_validation_criteria} NIL, p_object_info_seq, status);
          IF status.normal THEN
            RESET p_object_info_seq;
            NEXT p_object_information IN p_object_info_seq;
            IF (p_object_information <> NIL) AND (p_object_information^.object <> NIL) AND
                  (p_object_information^.object^.cycle_device_information <> NIL) THEN
              number_of_volumes := UPPERBOUND (p_object_information^.object^.cycle_device_information^.
                    magnetic_tape_device_info.volume_list^);
              first_volume_descriptor := p_object_information^.object^.cycle_device_information^.
                      magnetic_tape_device_info.volume_list^ [1];
              IF (next_volume > number_of_volumes) OR
{
{ The first volume is being assigned.
{
                  ((next_volume = 1) AND (number_of_volumes = 1) AND
                  (first_volume_descriptor.external_vsn = rmc$unspecified_vsn) AND
                  (first_volume_descriptor.recorded_vsn = rmc$unspecified_vsn)) THEN

                PUSH p_path: [1 .. evaluated_file_reference.number_of_path_elements];
                pfp$convert_fs_to_pft$path (evaluated_file_reference, p_path^);
                cycle_selector.cycle_option := pfc$specific_cycle;
                cycle_selector.cycle_number := evaluated_file_reference.cycle_reference.cycle_number;
                pfp$r3_append_rem_media_vsn (p_path^, cycle_selector,
                      volume_descriptor, status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND rmp$complete_tape_assignment;

?? TITLE := 'rmp$complete_tape_request', EJECT ??

  PROCEDURE [XDCL] rmp$complete_tape_request
    (    file: fst$file_reference;
         density: rmt$density;
         write_ring: rmt$write_ring;
         volume_list: rmt$volume_list;
         removable_media_group: ost$name;
         volume_overflow_allowed: boolean;
         validation_ring: ost$valid_ring;
         file_password: pft$password;
         attachment_logging: boolean;
     VAR status: ost$status);

    CONST
      complete_tape_request = 'RMP$COMPLETE_TAPE_REQUEST',
      include_radix = TRUE,
      radix = 10;

    VAR
      cycle_number: pft$cycle_number,
      cycle_selector: pft$cycle_selector,
      detachment_options: fmt$detachment_options,
      evaluated_file_reference: fst$evaluated_file_reference,
      ignore_status: ost$status,
      internal_cycle_name: ost$binary_unique_name,
      limit_string: ost$string,
      local_file_name: amt$local_file_name,
      log: pft$log,
      p_path: ^pft$path,
      removable_media_req_info: fmt$removable_media_req_info,
      sfid: dmt$system_file_id,
      share_selections: pft$share_selections,
      usage_selections: pft$usage_selections;

    fsp$evaluate_file_reference (file, command_file_reference_allowed, evaluated_file_reference, status);

    IF status.normal THEN
      IF write_ring = rmc$write_ring THEN
        usage_selections := - $pft$usage_selections [];
      ELSE
        usage_selections := $pft$usage_selections [pfc$read, pfc$execute];
      IFEND;
      share_selections := $pft$share_selections [];
      removable_media_req_info.density := density;
      removable_media_req_info.removable_media_group := removable_media_group;
      removable_media_req_info.volume_overflow_allowed := volume_overflow_allowed;
      removable_media_req_info.write_ring := write_ring;

      IF fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local THEN
        dmp$create_tape_file_sfid (^removable_media_req_info, ^volume_list, sfid, status);
        IF status.normal THEN
          osp$generate_unique_binary_name (internal_cycle_name, status);
          IF status.normal THEN
            local_file_name := osc$null_name;
            fmp$attach_file (local_file_name, internal_cycle_name, internal_cycle_name, sfid,
                  usage_selections, share_selections, validation_ring, sfc$no_limit, {p_file_label} NIL,
                  {p_pf_attachment_info} NIL, {device_class} rmc$magnetic_tape_device,
                  ^removable_media_req_info, ^volume_list, evaluated_file_reference, status);
            IF NOT status.normal THEN
              detachment_options := fmv$default_detachment_options;
              detachment_options.device_class := rmc$magnetic_tape_device;
              detachment_options.physical_unload := TRUE;
              dmp$close_tape_volume (sfid, detachment_options, ignore_status);
            IFEND;
          IFEND;
        ELSEIF status.condition = dme$tape_attach_limit_exceeded THEN
          clp$convert_integer_to_string (iov$number_of_tape_units + dmc$extra_lun_table_entries, radix,
                NOT include_radix, limit_string, ignore_status);
          bap$set_evaluated_file_abnormal (evaluated_file_reference, fse$tape_attach_limit_exceeded,
                complete_tape_request, limit_string.value, status);
        IFEND;
      ELSE
        IF evaluated_file_reference.cycle_reference.specification = fsc$cycle_number THEN
          cycle_selector.cycle_option := pfc$specific_cycle;
          cycle_selector.cycle_number := evaluated_file_reference.cycle_reference.cycle_number;
        ELSE
          cycle_selector.cycle_option := pfc$highest_cycle;
        IFEND;

        IF attachment_logging THEN
          log := pfc$log;
        ELSE
          log := pfc$no_log;
        IFEND;

        PUSH p_path: [1 .. evaluated_file_reference.number_of_path_elements];
        pfp$convert_fs_to_pft$path (evaluated_file_reference, p_path^);
        pfp$r3_define_removable_media (p_path^, cycle_selector, file_password, validation_ring,
              pfc$maximum_retention, log, {device_class} rmc$magnetic_tape_device, ^removable_media_req_info,
              ^volume_list, status);
      IFEND;
    IFEND;

  PROCEND rmp$complete_tape_request;

MODEND rmm$complete_tape_operations;
*DECK DECK=RMM$CREATE_BLANK_VOLUMES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := '  NOS/VE Create Blank Volume interfaces.' ??
MODULE rmm$create_blank_volumes;

{ PURPOSE:
{   This module contains the command interfaces for creating blank labeled or
{   unlabeled volumes.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$label_validation_errors
*copyc cle$ecc_file_reference
*copyc cle$ecc_parsing
*copyc fsc$version_one_ve_identifier
*copyc fsc$version_two_ve_identifier
*copyc fst$ansi_eof1_label
*copyc fst$ansi_eof2_label
*copyc fst$ansi_hdr1_label
*copyc fst$ansi_hdr2_label
*copyc fst$ansi_vol1_label
*copyc fst$tape_label_block_descriptor
*copyc fst$tape_label_sequence_header
*copyc osd$integer_limits
*copyc ost$help_module
*copyc rmc$initv_menu_names
*copyc rme$robotic_interface_errors
*copyc rme$creblv_errors
?? POP ??
*copyc clp$change_variable
*copyc clp$convert_string_to_integer
*copyc clp$evaluate_parameters
*copyc cmp$get_element_information
*copyc cmp$get_element_r3
*copyc fsp$classify_tape_label
*copyc fsp$close_file
*copyc fsp$default_tape_label_attrib
*copyc fsp$detach_file
*copyc fsp$get_tape_label_attributes
*copyc fsp$locate_tape_label
*copyc fsp$open_file
*copyc i#current_sequence_position
*copyc i#move
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc oss$job_paged_literal
*copyc pmp$change_legible_date_format
*copyc pmp$generate_unique_name
*copyc pmp$get_date
*copyc rap$prompt_via_menu
*copyc rmp$classify_tape_volume
*copyc rmp$request_tape
*copyc rmp$validate_ansi_string

*copyc amv$nil_file_identifier
*copyc dmv$initialize_tape_volume
*copyc rmv$initv_module_pointers

  VAR
    init_file_attr: [STATIC, READ, oss$job_paged_literal] array
          [1 .. 5] of fst$file_cycle_attribute := [[fsc$block_type, amc$user_specified],
          [fsc$record_type, amc$undefined], [fsc$max_block_length, 80], [fsc$file_label_type, amc$labeled],
          [fsc$forced_write, amc$forced]],

    vol1_label_default: [READ, oss$job_paged_literal] fst$ansi_vol1_label := [
          {label_identifier} 'VOL',
          {label_number} '1',
          {volume_identifier} ' ',
          {accessibility} ' ',
          {reserved_to_ansi1} ' ',
          {implementation_identifier} 'NOS/VE V2.0',
          {owner_identifier} ' ',
          {reserved_to_ansi2} ' ',
          {label_standard_version} '4'];

?? NEWTITLE := 'rmp$create_blank_labeled_volume', EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$create_blank_labeled_volume
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE create_blank_labeled_volume, creblv (
{   element, elements, e: list of name = $optional
{   recorded_vsn, recorded_vsns, rvsn, rv: list of any of
{       name 1..6
{       string 1..6
{     anyend = $optional
{   character_set, cs: (BY_NAME) key
{       (ascii, a)
{       (ebcdic, e)
{     keyend = ascii
{   density, d: (BY_NAME) key
{       mt9$800, mt9$1600, mt9$6250, mt18$38000
{     keyend = $optional
{   external_vsn, evsn, external_vsns, ev: (BY_NAME) list of any of
{       name 1..6
{       string 1..6
{     anyend = $optional
{   file_accessibility, fa: (BY_NAME, SECURE) any of
{       name 1..1
{       string 1
{     anyend = $optional
{   implementation_identifier, ii: (BY_NAME) any of
{       name 1..13
{       string 1..13
{     anyend = $optional
{   initialized_volume_count, ivc: (VAR, BY_NAME) integer = $optional
{   labeling_convention, lc: (BY_NAME) any of
{       key
{         (ansi, a)
{         (cdc_version_one, cvo)
{         (cdc_version_two, cvt)
{         (label_for_group, lfg)
{         (label_for_user, lfu)
{       keyend
{       list 1..128 of string 1..4128
{     anyend = osd$creblv_labeling_convention, cdc_version_two
{   label_standard_version, lsv: (BY_NAME) any of
{       integer 0..9
{     anyend = 4
{   owner_identifier, oi: (BY_NAME, SECURE) any of
{       name 1..14
{       string 1..14
{     anyend = $optional
{   removable_media_group, rmg: (BY_NAME, SECURE) name 1..13 = $optional
{   unload_volume, uv: (BY_NAME) boolean = true
{   volume_accessibility, va: (BY_NAME, SECURE) any of
{       name 1..1
{       string 1
{     anyend = $optional
{   volume_confirmation, vc: (BY_NAME) any of
{       key
{         all, none
{       keyend
{       list of key
{         (labeled_expired, le)
{         (unreadable_volume, uv)
{         (unlabeled, u)
{         (labeled_unexpired, lu)
{       keyend
{     anyend = osd$volume_confirmation, all
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 36] of clt$pdt_parameter_name,
      parameters: array [1 .. 16] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$name_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (5),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$name_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
      recend,
      type6: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type7: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type8: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type9: 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 .. 10] 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$string_type_qualifier,
          recend,
        recend,
        default_name: string (30),
        default_value: string (15),
      recend,
      type10: 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$integer_type_qualifier,
        recend,
        default_value: string (1),
      recend,
      type11: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type12: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type13: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type14: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type15: 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 .. 2] 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 .. 8] of clt$keyword_specification,
          recend,
        recend,
        default_name: string (23),
        default_value: string (3),
      recend,
      type16: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 7, 12, 9, 39, 27, 654],
    clc$command, 36, 16, 0, 0, 0, 1, 16, ''], [
    ['CHARACTER_SET                  ',clc$nominal_entry, 3],
    ['CS                             ',clc$abbreviation_entry, 3],
    ['D                              ',clc$abbreviation_entry, 4],
    ['DENSITY                        ',clc$nominal_entry, 4],
    ['E                              ',clc$abbreviation_entry, 1],
    ['ELEMENT                        ',clc$nominal_entry, 1],
    ['ELEMENTS                       ',clc$alias_entry, 1],
    ['EV                             ',clc$abbreviation_entry, 5],
    ['EVSN                           ',clc$alias_entry, 5],
    ['EXTERNAL_VSN                   ',clc$nominal_entry, 5],
    ['EXTERNAL_VSNS                  ',clc$alias_entry, 5],
    ['FA                             ',clc$abbreviation_entry, 6],
    ['FILE_ACCESSIBILITY             ',clc$nominal_entry, 6],
    ['II                             ',clc$abbreviation_entry, 7],
    ['IMPLEMENTATION_IDENTIFIER      ',clc$nominal_entry, 7],
    ['INITIALIZED_VOLUME_COUNT       ',clc$nominal_entry, 8],
    ['IVC                            ',clc$abbreviation_entry, 8],
    ['LABELING_CONVENTION            ',clc$nominal_entry, 9],
    ['LABEL_STANDARD_VERSION         ',clc$nominal_entry, 10],
    ['LC                             ',clc$abbreviation_entry, 9],
    ['LSV                            ',clc$abbreviation_entry, 10],
    ['OI                             ',clc$abbreviation_entry, 11],
    ['OWNER_IDENTIFIER               ',clc$nominal_entry, 11],
    ['RECORDED_VSN                   ',clc$nominal_entry, 2],
    ['RECORDED_VSNS                  ',clc$alias_entry, 2],
    ['REMOVABLE_MEDIA_GROUP          ',clc$nominal_entry, 12],
    ['RMG                            ',clc$abbreviation_entry, 12],
    ['RV                             ',clc$abbreviation_entry, 2],
    ['RVSN                           ',clc$alias_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 16],
    ['UNLOAD_VOLUME                  ',clc$nominal_entry, 13],
    ['UV                             ',clc$abbreviation_entry, 13],
    ['VA                             ',clc$abbreviation_entry, 14],
    ['VC                             ',clc$abbreviation_entry, 15],
    ['VOLUME_ACCESSIBILITY           ',clc$nominal_entry, 14],
    ['VOLUME_CONFIRMATION            ',clc$nominal_entry, 15]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 49, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 49, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [13, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 33, clc$optional_parameter,
  0, 0],
{ PARAMETER 7
    [15, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 33, clc$optional_parameter,
  0, 0],
{ PARAMETER 8
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_parameter, 0, 0],
{ PARAMETER 9
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 421,
  clc$optional_default_parameter, 30, 15],
{ PARAMETER 10
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 36,
  clc$optional_default_parameter, 0, 1],
{ PARAMETER 11
    [23, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 33, clc$optional_parameter,
  0, 0],
{ PARAMETER 12
    [26, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$optional_parameter, 0
  , 0],
{ PARAMETER 13
    [31, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 14
    [35, clc$normal_usage_entry, clc$secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 33, clc$optional_parameter,
  0, 0],
{ PARAMETER 15
    [36, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 420,
  clc$optional_default_parameter, 23, 3],
{ PARAMETER 16
    [30, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
      FALSE, 2],
      5, [[1, 0, clc$name_type], [1, 6]],
      8, [[1, 0, clc$string_type], [1, 6, FALSE]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ASCII                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EBCDIC                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'ascii'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [4], [
    ['MT18$38000                     ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['MT9$1600                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['MT9$6250                       ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['MT9$800                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 5
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
      FALSE, 2],
      5, [[1, 0, clc$name_type], [1, 6]],
      8, [[1, 0, clc$string_type], [1, 6, FALSE]]
      ]
    ],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, 1]],
    8, [[1, 0, clc$string_type], [1, 1, FALSE]]
    ],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, 13]],
    8, [[1, 0, clc$string_type], [1, 13, FALSE]]
    ],
{ PARAMETER 8
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    377, [[1, 0, clc$keyword_type], [10], [
      ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['ANSI                           ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['CDC_VERSION_ONE                ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['CDC_VERSION_TWO                ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['CVO                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['CVT                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['LABEL_FOR_GROUP                ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['LABEL_FOR_USER                 ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['LFG                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['LFU                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5]]
      ],
    24, [[1, 0, clc$list_type], [8, 1, 128, 0, FALSE, FALSE],
        [[1, 0, clc$string_type], [1, 4128, FALSE]]
      ]
    ,
    'OSD$CREBLV_LABELING_CONVENTION',
    'cdc_version_two'],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$integer_type],
    TRUE, 1],
    20, [[1, 0, clc$integer_type], [0, 9, 10]]
    ,
    '4'],
{ PARAMETER 11
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, 14]],
    8, [[1, 0, clc$string_type], [1, 14, FALSE]]
    ],
{ PARAMETER 12
    [[1, 0, clc$name_type], [1, 13]],
{ PARAMETER 13
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 14
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, 1]],
    8, [[1, 0, clc$string_type], [1, 1, FALSE]]
    ],
{ PARAMETER 15
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    319, [[1, 0, clc$list_type], [303, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [8], [
        ['LABELED_EXPIRED                ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['LABELED_UNEXPIRED              ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['LE                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['LU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['UNLABELED                      ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['UNREADABLE_VOLUME              ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['UV                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2]]
        ]
      ]
    ,
    'OSD$VOLUME_CONFIRMATION',
    'all'],
{ PARAMETER 16
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element = 1,
      p$recorded_vsn = 2,
      p$character_set = 3,
      p$density = 4,
      p$external_vsn = 5,
      p$file_accessibility = 6,
      p$implementation_identifier = 7,
      p$initialized_volume_count = 8,
      p$labeling_convention = 9,
      p$label_standard_version = 10,
      p$owner_identifier = 11,
      p$removable_media_group = 12,
      p$unload_volume = 13,
      p$volume_accessibility = 14,
      p$volume_confirmation = 15,
      p$status = 16;

    VAR
      pvt: array [1 .. 16] of clt$parameter_value;

?? NEWTITLE := '  create_blank_labeled_volume', EJECT ??

    PROCEDURE create_blank_labeled_volume;

?? NEWTITLE := '    creblv_cond_handler', EJECT ??

      PROCEDURE creblv_cond_handler
        (    condition: pmt$condition;
             condition_information: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);

        VAR
          ignore_status: ost$status;

        IF file_id <> amv$nil_file_identifier THEN
          fsp$close_file (file_id, ignore_status);
        IFEND;

        fsp$detach_file (unique_name.value, {detachment_options} NIL, ignore_status);

      PROCEND creblv_cond_handler;
?? OLDTITLE ??
?? NEWTITLE := '    post_appropriate_menu', EJECT ??

      PROCEDURE post_appropriate_menu
        (    menu_module: pmt$program_name;
             volume_classification: rmt$tape_volume_classification;
         VAR confirmed: boolean;
         VAR status: ost$status);

        VAR
          dt: ost$date,
          hdr1_p: ^fst$ansi_hdr1_label,
          lsv_length: integer,
          menu_selections_p: ^array [ * ] of ost$name,
          menu_parameters_p: rat$message_parameters,
          old_expiration_date: string (10),
          prompting_options: rat$prompting_options,
          proposed_file_accessibility: string (1),
          proposed_hdr1: ^fst$ansi_hdr1_label,
          proposed_label_standard_version: string (2),
          proposed_owner_identifier: string (14),
          proposed_volume_accessibility: string (1),
          selection_chosen: ost$name,
          todays_date: ost$date,
          vol1_p: ^fst$ansi_vol1_label;

        hdr1_p := NIL;
        old_expiration_date := '*NO HDR1*';
        vol1_p := NIL;

        pmp$get_date (osc$iso_date, todays_date, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF volume_header_labels <> NIL THEN
          RESET volume_header_labels;
          NEXT sequence_header IN volume_header_labels;

          label_identifier.location_method := fsc$tape_label_locate_by_kind;
          label_identifier.label_kind := fsc$ansi_vol1_label_kind;
          fsp$locate_tape_label (volume_header_labels, label_identifier, label_locator);
          IF label_locator.label_found AND (label_locator.label_block <> NIL) THEN
            NEXT vol1_p IN label_locator.label_block;
          IFEND;

          label_identifier.label_kind := fsc$ansi_hdr1_label_kind;
          fsp$locate_tape_label (volume_header_labels, label_identifier, label_locator);
          IF label_locator.label_found AND (label_locator.label_block <> NIL) THEN
            NEXT hdr1_p IN label_locator.label_block;
            IF hdr1_p^.expiration_date (2, 5) = '00000' THEN
              old_expiration_date := 'EXPIRED';
            ELSE
              dt.date_format := osc$ordinal_date;
              IF hdr1_p^.expiration_date (1) = ' ' THEN
                dt.ordinal (1, 2) := '19';
                dt.ordinal (3, 5) := hdr1_p^.expiration_date (2, 5);
              ELSE
                dt.ordinal (1, 1) := '2';
                dt.ordinal (2, 6) := hdr1_p^.expiration_date (1, 6);
              IFEND;
              pmp$change_legible_date_format (osc$iso_date, dt, local_status);
              IF local_status.normal THEN
                old_expiration_date := dt.iso;
              ELSE
                old_expiration_date := 'EXPIRED';
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        IF pvt [p$file_accessibility].specified THEN
          proposed_file_accessibility := attachment_options^ [ta_fa].tape_attachment.tape_file_accessibility;
        ELSE
          label_identifier.location_method := fsc$tape_label_locate_by_kind;
          label_identifier.label_kind := fsc$ansi_hdr1_label_kind;
          fsp$locate_tape_label (attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.
                blank_label_group, label_identifier, label_locator);
          IF label_locator.label_found THEN
            NEXT proposed_hdr1 IN label_locator.label_block;
            proposed_file_accessibility := proposed_hdr1^.accessibility;
          ELSE
            osp$set_status_abnormal ('RM', ame$hdr1_label_missing, 'FILE_ACCESSIBILITY', status);
          IFEND;
        IFEND;

        STRINGREP (proposed_label_standard_version, lsv_length,
              pvt [p$label_standard_version].value^.integer_value.value);

        IF pvt [p$owner_identifier].specified THEN
          proposed_owner_identifier := attachment_options^ [ta_oi].tape_attachment.tape_owner_identification;
        ELSEIF pvt [p$removable_media_group].specified THEN
          proposed_owner_identifier (1, 1) := '&';
          proposed_owner_identifier (2, 13) := attachment_options^ [ta_rmg].tape_attachment.
                tape_removable_media_group;
        ELSE
          proposed_owner_identifier := proposed_vol1^.owner_identifier;
        IFEND;

        IF pvt [p$volume_accessibility].specified THEN
          proposed_volume_accessibility := attachment_options^ [ta_va].tape_attachment.
                tape_volume_accessibility;
        ELSE
          proposed_volume_accessibility := proposed_vol1^.accessibility;
        IFEND;

        PUSH menu_selections_p: [1 .. 2];
        menu_selections_p^ [1] := 'CONTINUE_INITV';
        menu_selections_p^ [2] := 'ABORT_INITV';
        IF volume_classification.volume_label_type = rmc$labeled_volume_type THEN
          PUSH menu_parameters_p: [1 .. 15];
          menu_parameters_p^ [1] := dmv$initialize_tape_volume.element_name;
          menu_parameters_p^ [2] := volume_classification.labeled.volume_identifier (1, 6);
          IF vol1_p <> NIL THEN
            menu_parameters_p^ [3] := vol1_p^.owner_identifier (1, 14);
          ELSE
            menu_parameters_p^ [3] := '*NO VOL1      *';
          IFEND;
          menu_parameters_p^ [2] (20, 1) := ':';
          menu_parameters_p^ [3] (20, 1) := ':';
          get_character_set_string (sequence_header^.character_set, menu_parameters_p^ [4]);
          menu_parameters_p^ [4] (20, 1) := ':';
          menu_parameters_p^ [5] := old_expiration_date (1, 10);
          menu_parameters_p^ [5] (20, 1) := ':';
          menu_parameters_p^ [6] := volume_classification.labeled.file_accessibility;
          menu_parameters_p^ [6] (20, 1) := ':';
          IF vol1_p <> NIL THEN
            menu_parameters_p^ [7] := vol1_p^.label_standard_version;
          ELSE
            menu_parameters_p^ [7] := ' ';
          IFEND;
          menu_parameters_p^ [7] (20, 1) := ':';
          menu_parameters_p^ [8] := volume_classification.labeled.volume_accessibility;
          menu_parameters_p^ [8] (20, 1) := ':';
          menu_parameters_p^ [9] := volume_list [1].recorded_vsn (1, 6);
          menu_parameters_p^ [10] := proposed_owner_identifier (1, 14);
          menu_parameters_p^ [11] := pvt [p$character_set].value^.keyword_value (1, 6);
          menu_parameters_p^ [12] := todays_date.iso;
          menu_parameters_p^ [13] := proposed_file_accessibility;
          menu_parameters_p^ [14] := proposed_label_standard_version (2, 1);
          menu_parameters_p^ [15] := proposed_volume_accessibility;
        ELSE
          PUSH menu_parameters_p: [1 .. 8];
          menu_parameters_p^ [1] := dmv$initialize_tape_volume.element_name;
          menu_parameters_p^ [2] := volume_list [1].recorded_vsn (1, 6);
          menu_parameters_p^ [3] := proposed_owner_identifier (1, 14);
          menu_parameters_p^ [4] := pvt [p$character_set].value^.keyword_value (1, 6);
          menu_parameters_p^ [5] := todays_date.iso;
          menu_parameters_p^ [6] := proposed_file_accessibility;
          menu_parameters_p^ [7] := proposed_label_standard_version (2, 1);
          menu_parameters_p^ [8] := proposed_volume_accessibility;
        IFEND;

        prompting_options := $rat$prompting_options [];

{ Post menu and see if operator wants to continue

        rap$prompt_via_menu (menu_module, menu_selections_p^, menu_parameters_p, prompting_options,
              selection_chosen, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        confirmed := (selection_chosen = 'CONTINUE_INITV');

      PROCEND post_appropriate_menu;
?? OLDTITLE, EJECT ??

      CONST
        fsp = 1,
        hl = 1,
        rl = 2,
        vi = 3;

      VAR
        confirmed: boolean,
        file_id: amt$file_identifier,
        local_status: ost$status,
        returned_attributes: fst$tla_returned_attributes,
        tape_attributes: array [fsp .. vi] of fst$attachment_option,
        tape_class: rmt$tape_class,
        unique_name: ost$unique_name,
        volume_classification: rmt$tape_volume_classification,
        volume_header_labels: ^SEQ ( * );

      confirmed := FALSE;

      pmp$generate_unique_name (unique_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF density = rmc$38000 THEN
        tape_class := rmc$mt18;
      ELSE
        tape_class := rmc$mt9;
      IFEND;

      proposed_vol1^.volume_identifier := volume_list [1].recorded_vsn;

      rmp$request_tape (unique_name.value, tape_class, density, rmc$write_ring, volume_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      osp$establish_block_exit_hndlr (^creblv_cond_handler);
      file_id := amv$nil_file_identifier;

      tape_attributes [fsp].selector := fsc$tape_attachment;
      tape_attributes [fsp].tape_attachment.selector := fsc$tape_file_set_position;
      tape_attributes [fsp].tape_attachment.tape_file_set_position.position := fsc$tape_beginning_of_set;
      tape_attributes [rl].selector := fsc$tape_attachment;
      tape_attributes [rl].tape_attachment.selector := fsc$tape_rewrite_labels;
      tape_attributes [rl].tape_attachment.tape_rewrite_labels := FALSE;
      tape_attributes [vi].selector := fsc$tape_attachment;
      tape_attributes [vi].tape_attachment.selector := fsc$tape_volume_initialization;
      tape_attributes [vi].tape_attachment.tape_volume_initialization :=
            attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization;

    /initialize/
      BEGIN
        fsp$open_file (unique_name.value, amc$record, ^tape_attributes, NIL, file_attr, NIL, NIL, file_id,
              local_status);
        IF local_status.normal THEN
          fsp$close_file (file_id, status);
          IF NOT status.normal THEN
            EXIT /initialize/;
          IFEND;
        IFEND;
        tape_attributes [hl].selector := fsc$tape_attachment;
        tape_attributes [hl].tape_attachment.selector := fsc$tape_header_labels;
        PUSH tape_attributes [hl].tape_attachment.tape_header_labels:
              [[REP 1 OF fst$tape_label_sequence_header, REP (fsc$max_tape_labels *
              (#SIZE (fst$tape_label_block_descriptor) + fsc$max_tape_label_length)) OF cell]];
        tape_attributes [2].selector := fsc$null_attachment_option;
        tape_attributes [3].selector := fsc$null_attachment_option;
        fsp$get_tape_label_attributes (unique_name.value, fsc$tla_last_ansi_file_accessed, tape_attributes,
              returned_attributes, status);
        IF NOT status.normal THEN
          EXIT /initialize/;
        IFEND;
        IF fsc$tape_header_labels IN returned_attributes THEN
          volume_header_labels := tape_attributes [1].tape_attachment.tape_header_labels;
        ELSE
          volume_header_labels := NIL;
        IFEND;
        rmp$classify_tape_volume (local_status, volume_header_labels, volume_classification, status);
        IF status.normal THEN
          confirmed := TRUE;
          IF attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.volume_confirmation <>
                $fst$volume_confirmation_options [] THEN
            IF volume_classification.volume_label_type = rmc$labeled_volume_type THEN
              IF volume_classification.labeled.expired THEN
                IF fsc$confirm_expired_volume IN attachment_options^ [ta_vi].tape_attachment.
                      tape_volume_initialization^.volume_confirmation THEN
                  post_appropriate_menu (rmc$initv_exp_menu, volume_classification, confirmed, status);
                IFEND;
              ELSEIF fsc$confirm_unexpired_volume IN attachment_options^ [ta_vi].tape_attachment.
                    tape_volume_initialization^.volume_confirmation THEN
                post_appropriate_menu (rmc$initv_unexp_menu, volume_classification, confirmed, status);
              IFEND;
            ELSEIF volume_classification.volume_label_type = rmc$indeterminate_volume_type THEN
              IF fsc$confirm_unreadable_volume IN attachment_options^ [ta_vi].tape_attachment.
                    tape_volume_initialization^.volume_confirmation THEN
                post_appropriate_menu (rmc$initv_re_menu, volume_classification, confirmed, status);
              IFEND;
            ELSE { unlabeled }
              IF fsc$confirm_unlabeled_volume IN attachment_options^ [ta_vi].tape_attachment.
                    tape_volume_initialization^.volume_confirmation THEN
                post_appropriate_menu (rmc$initv_ul_menu, volume_classification, confirmed, status);
              IFEND;
            IFEND;
            IF NOT status.normal THEN
              EXIT /initialize/;
            IFEND;
          IFEND;
          IF confirmed THEN
            fsp$open_file (unique_name.value, amc$record, attachment_options, NIL, file_attr, NIL, NIL,
                  file_id, status);
            IF NOT status.normal THEN
              IF (attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.element =
                    osc$null_name) AND (status.condition = rme$volume_not_mounted) THEN
                osp$set_status_abnormal (rmc$resource_management_id, rme$robotic_mount_failure,
                      volume_list [1].external_vsn, status);
              IFEND;
              EXIT /initialize/;
            IFEND;
            initialized_volume_count := initialized_volume_count + 1;
            fsp$close_file (file_id, status);
          IFEND;
        IFEND;
      END /initialize/;

      osp$disestablish_cond_handler;

      IF confirmed THEN
        fsp$detach_file (unique_name.value, detachment_options, local_status);
      ELSE
        fsp$detach_file (unique_name.value, {detachment_options} NIL, local_status);
      IFEND;

      IF (NOT local_status.normal) AND status.normal THEN
        status := local_status;
      IFEND;

    PROCEND create_blank_labeled_volume;
?? OLDTITLE, EJECT ??

    CONST
      number_of_options = 11,
      ta_cs = 1,
      ta_fa = 2,
      ta_fsp = 3,
      ta_ii = 4,
      ta_lsv = 5,
      ta_oi = 6,
      ta_rl = 7,
      ta_rmg = 8,
      ta_va = 9,
      ta_vi = 10,
      teo = 11;

    VAR
      attachment_options: ^fst$attachment_options,
      blank_label_group: ^SEQ ( * ),
      blank_label_group_size: ost$positive_integers,
      block_descriptor: ^fst$tape_label_block_descriptor,
      default_attributes: array [1 .. 2] of fst$attachment_option,
      density: rmt$density,
      detachment_options: ^fst$detachment_options,
      eof1_block: ^fst$ansi_hdr1_label,
      eof2_block: ^fst$ansi_hdr2_label,
      evsn_node: ^clt$data_value,
      file_accessibility: string (1),
      file_attr: ^array [1 .. * ] of fst$file_cycle_attribute,
      hdr1_block: ^fst$ansi_hdr1_label,
      hdr2_block: ^fst$ansi_hdr2_label,
      initialized_volume_count: ost$non_negative_integers,
      int: clt$integer,
      ivc_value: ^clt$data_value,
      label_block: ^string ( * ),
      label_classification: fst$tape_label_classification,
      label_identifier: fst$tape_label_identifier,
      label_length: ost$positive_integers,
      label_locator: fst$tape_label_locator,
      list_node: ^clt$data_value,
      local_status: ost$status,
      proposed_vol1: ^fst$ansi_vol1_label,
      returned_default_attributes: fst$tla_returned_attributes,
      rvsn_node: ^clt$data_value,
      seq_ptr: ^SEQ ( * ),
      sequence_header: ^fst$tape_label_sequence_header,
      string_count: ost$non_negative_integers,
      trailer_labels: ^SEQ ( * ),
      volume_accessibility: string (1),
      volume_list: array [1 .. 1] of rmt$volume_descriptor,
      vsn_specified: boolean;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$unload_volume].value^.boolean_value.value THEN
      detachment_options := NIL;
    ELSE
      PUSH detachment_options: [1 .. 1];
      detachment_options^ [1].selector := fsc$do_unload_volume;
      detachment_options^ [1].unload_volume := FALSE;
    IFEND;

    vsn_specified := pvt [p$external_vsn].specified OR pvt [p$recorded_vsn].specified;
    determine_density (pvt [p$density], pvt [p$element], vsn_specified, density, status);
    IF NOT status.normal THEN
      IF status.condition = rme$vsn_density_mismatch THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, ' or RECORDED_VSN', status);
      IFEND;
      RETURN;
    IFEND;
    IF (density <> rmc$38000) AND vsn_specified AND (NOT pvt [p$element].specified) THEN
      osp$set_status_abnormal ('RM', rme$vsn_density_mismatch, ' or RECORDED_VSN', status);
      RETURN;
    IFEND;

    PUSH attachment_options: [1 .. number_of_options];

    attachment_options^ [ta_cs].selector := fsc$tape_attachment;
    attachment_options^ [ta_cs].tape_attachment.selector := fsc$tape_character_set;
    IF pvt [p$character_set].value^.keyword_value = 'ASCII' THEN
      attachment_options^ [ta_cs].tape_attachment.tape_character_set := amc$ascii;
    ELSE
      attachment_options^ [ta_cs].tape_attachment.tape_character_set := amc$ebcdic;
    IFEND;

    IF pvt [p$file_accessibility].specified THEN
      IF pvt [p$file_accessibility].value^.kind = clc$name THEN
        file_accessibility := pvt [p$file_accessibility].value^.name_value;
      ELSE
        file_accessibility := pvt [p$file_accessibility].value^.string_value^;
      IFEND;
      rmp$validate_ansi_string (file_accessibility, attachment_options^ [ta_fa].tape_attachment.
            tape_file_accessibility, status);
      IF NOT status.normal THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, ' for parameter FILE_ACCESSIBILITY',
              status);
        RETURN;
      IFEND;
      attachment_options^ [ta_fa].selector := fsc$tape_attachment;
      attachment_options^ [ta_fa].tape_attachment.selector := fsc$tape_file_accessibility;
    ELSE
      attachment_options^ [ta_fa].selector := fsc$null_attachment_option;
    IFEND;

    attachment_options^ [ta_fsp].selector := fsc$tape_attachment;
    attachment_options^ [ta_fsp].tape_attachment.selector := fsc$tape_file_set_position;
    attachment_options^ [ta_fsp].tape_attachment.tape_file_set_position.position := fsc$tape_beginning_of_set;

    IF pvt [p$implementation_identifier].specified THEN
      attachment_options^ [ta_ii].selector := fsc$tape_attachment;
      attachment_options^ [ta_ii].tape_attachment.selector := fsc$tape_implementation_id;
      IF pvt [p$implementation_identifier].value^.kind = clc$name THEN
        attachment_options^ [ta_ii].tape_attachment.tape_implementation_id :=
              pvt [p$implementation_identifier].value^.name_value;
      ELSEIF pvt [p$implementation_identifier].value^.kind = clc$string THEN
        attachment_options^ [ta_ii].tape_attachment.tape_implementation_id :=
              pvt [p$implementation_identifier].value^.string_value^;
      IFEND;
    ELSE
      attachment_options^ [ta_ii].selector := fsc$null_attachment_option;
    IFEND;

    attachment_options^ [ta_lsv].selector := fsc$tape_attachment;
    attachment_options^ [ta_lsv].tape_attachment.selector := fsc$tape_label_standard_version;
    attachment_options^ [ta_lsv].tape_attachment.tape_label_standard_version :=
          pvt [p$label_standard_version].value^.integer_value.value;

    IF pvt [p$owner_identifier].specified THEN
      IF pvt [p$removable_media_group].specified THEN
        osp$set_status_abnormal ('RM', rme$ambiguous_specifications, '', status);
        RETURN;
      IFEND;
      attachment_options^ [ta_oi].selector := fsc$tape_attachment;
      attachment_options^ [ta_oi].tape_attachment.selector := fsc$tape_owner_identification;
      IF pvt [p$owner_identifier].value^.kind = clc$keyword THEN { NONE }
        attachment_options^ [ta_oi].tape_attachment.tape_owner_identification := osc$null_name;
      ELSEIF pvt [p$owner_identifier].value^.kind = clc$name THEN
        attachment_options^ [ta_oi].tape_attachment.tape_owner_identification :=
              pvt [p$owner_identifier].value^.name_value;
      ELSEIF pvt [p$owner_identifier].value^.kind = clc$string THEN
        attachment_options^ [ta_oi].tape_attachment.tape_owner_identification :=
              pvt [p$owner_identifier].value^.string_value^;
      IFEND;
    ELSE
      attachment_options^ [ta_oi].selector := fsc$null_attachment_option;
    IFEND;

    IF pvt [p$removable_media_group].specified THEN
      attachment_options^ [ta_rmg].selector := fsc$tape_attachment;
      attachment_options^ [ta_rmg].tape_attachment.selector := fsc$tape_removable_media_group;
      attachment_options^ [ta_rmg].tape_attachment.tape_removable_media_group :=
            pvt [p$removable_media_group].value^.name_value;
    ELSE
      attachment_options^ [ta_rmg].selector := fsc$null_attachment_option;
    IFEND;

    attachment_options^ [ta_rl].selector := fsc$tape_attachment;
    attachment_options^ [ta_rl].tape_attachment.selector := fsc$tape_rewrite_labels;
    attachment_options^ [ta_rl].tape_attachment.tape_rewrite_labels := TRUE;

    IF pvt [p$volume_accessibility].specified THEN
      IF pvt [p$volume_accessibility].value^.kind = clc$name THEN
        volume_accessibility := pvt [p$volume_accessibility].value^.name_value;
      ELSE
        volume_accessibility := pvt [p$volume_accessibility].value^.string_value^;
      IFEND;
      rmp$validate_ansi_string (volume_accessibility, attachment_options^ [ta_va].tape_attachment.
            tape_volume_accessibility, status);
      IF NOT status.normal THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, ' for parameter VOLUME_ACCESSIBILITY',
              status);
        RETURN;
      IFEND;
      attachment_options^ [ta_va].selector := fsc$tape_attachment;
      attachment_options^ [ta_va].tape_attachment.selector := fsc$tape_volume_accessibility;
    ELSE
      attachment_options^ [ta_va].selector := fsc$null_attachment_option;
    IFEND;

    attachment_options^ [ta_vi].selector := fsc$tape_attachment;
    attachment_options^ [ta_vi].tape_attachment.selector := fsc$tape_volume_initialization;
    PUSH attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization;
    IF NOT pvt [p$element].specified THEN
      attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.element := osc$null_name;
    IFEND;
    IF pvt [p$volume_confirmation].value^.kind = clc$keyword THEN
      IF pvt [p$volume_confirmation].value^.keyword_value = 'ALL' THEN
        attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.volume_confirmation :=
              -$fst$volume_confirmation_options [];
      ELSE { NONE }
        attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.volume_confirmation :=
              $fst$volume_confirmation_options [];
      IFEND;
    ELSE { list of key }
      attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.volume_confirmation :=
            $fst$volume_confirmation_options [];
      list_node := pvt [p$volume_confirmation].value;
      WHILE list_node <> NIL DO
        IF list_node^.element_value^.keyword_value = 'LABELED_EXPIRED' THEN
          attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.volume_confirmation :=
                attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.
                volume_confirmation + $fst$volume_confirmation_options [fsc$confirm_expired_volume];
        ELSEIF list_node^.element_value^.keyword_value = 'UNREADABLE_VOLUME' THEN
          attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.volume_confirmation :=
                attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.
                volume_confirmation + $fst$volume_confirmation_options [fsc$confirm_unreadable_volume];
        ELSEIF list_node^.element_value^.keyword_value = 'UNLABELED' THEN
          attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.volume_confirmation :=
                attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.
                volume_confirmation + $fst$volume_confirmation_options [fsc$confirm_unlabeled_volume];
        ELSEIF list_node^.element_value^.keyword_value = 'LABELED_UNEXPIRED' THEN
          attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.volume_confirmation :=
                attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.
                volume_confirmation + $fst$volume_confirmation_options [fsc$confirm_unexpired_volume];
        IFEND;
        list_node := list_node^.link;
      WHILEND;
    IFEND;

{ Build blank label group.

    IF pvt [p$labeling_convention].value^.kind = clc$keyword THEN
      IF pvt [p$labeling_convention].value^.keyword_value = 'ANSI' THEN
        IF pvt [p$file_accessibility].specified THEN
          osp$set_status_abnormal ('RM', rme$ansi_label_conflict, 'FILE_ACCESSIBILITY', status);
          RETURN;
        IFEND;
        IF pvt [p$implementation_identifier].specified THEN
          osp$set_status_abnormal ('RM', rme$ansi_label_conflict, 'IMPLEMENTATION_IDENTIFIER', status);
          RETURN;
        IFEND;
        blank_label_group_size := #SIZE (fst$tape_label_sequence_header) +
              (3 * #SIZE (fst$tape_label_block_descriptor)) + #SIZE (fst$ansi_vol1_label);
        PUSH blank_label_group: [[REP blank_label_group_size OF cell]];
        NEXT sequence_header IN blank_label_group;
        sequence_header^.character_set := attachment_options^ [ta_cs].tape_attachment.tape_character_set;
        sequence_header^.label_kinds := $fst$ansi_label_kinds [fsc$ansi_vol1_label_kind];
        sequence_header^.sequence_size := blank_label_group_size;
        sequence_header^.label_count := 3;
        NEXT block_descriptor IN blank_label_group;
        block_descriptor^.label_block_type := fsc$normal_tape_label_block;
        block_descriptor^.normal_label_actual_length := #SIZE (fst$ansi_vol1_label);
        block_descriptor^.normal_label_character_set := sequence_header^.character_set;
        block_descriptor^.normal_label_kind := fsc$ansi_vol1_label_kind;
        block_descriptor^.normal_label_transfer_length := #SIZE (fst$ansi_vol1_label);
        NEXT proposed_vol1 IN blank_label_group;
        proposed_vol1^ := vol1_label_default;
        NEXT block_descriptor IN blank_label_group;
        block_descriptor^.label_block_type := fsc$tapemark_tape_label_block;
        NEXT block_descriptor IN blank_label_group;
        block_descriptor^.label_block_type := fsc$tapemark_tape_label_block;

      ELSE { version 1, version 2, label_for_group, or label_for_user }
        default_attributes [1].selector := fsc$tape_attachment;
        default_attributes [1].tape_attachment.selector := fsc$tape_header_labels;
        PUSH default_attributes [1].tape_attachment.tape_header_labels:
              [[REP 1 OF fst$tape_label_sequence_header, REP 4 OF fst$tape_label_block_descriptor,
              REP 1 OF fst$ansi_vol1_label, REP 1 OF fst$ansi_hdr1_label, REP 1 OF fst$ansi_hdr2_label]];
        default_attributes [2].selector := fsc$tape_attachment;
        default_attributes [2].tape_attachment.selector := fsc$tape_trailer_labels;
        PUSH default_attributes [2].tape_attachment.tape_trailer_labels:
              [[REP 1 OF fst$tape_label_sequence_header, REP 4 OF fst$tape_label_block_descriptor,
              REP 1 OF fst$ansi_eof1_label, REP 1 OF fst$ansi_eof2_label]];
        fsp$default_tape_label_attrib (fsc$tla_system_default, default_attributes,
              returned_default_attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        blank_label_group_size := #SIZE (default_attributes [1].tape_attachment.tape_header_labels^) +
              #SIZE (default_attributes [2].tape_attachment.tape_trailer_labels^) -
              #SIZE (fst$tape_label_sequence_header) + (2 * #SIZE (fst$tape_label_block_descriptor));
        PUSH blank_label_group: [[REP blank_label_group_size OF cell]];
        NEXT seq_ptr: [[REP #SIZE (default_attributes [1].tape_attachment.tape_header_labels^) OF cell]] IN
              blank_label_group;
        seq_ptr^ := default_attributes [1].tape_attachment.tape_header_labels^;
        label_length := #SIZE (default_attributes [2].tape_attachment.tape_trailer_labels^) -
              #SIZE (fst$tape_label_sequence_header);
        NEXT seq_ptr: [[REP label_length OF cell]] IN blank_label_group;
        NEXT sequence_header IN default_attributes [2].tape_attachment.tape_trailer_labels;
        NEXT trailer_labels: [[REP label_length OF cell]] IN default_attributes [2].
              tape_attachment.tape_trailer_labels;
        seq_ptr^ := trailer_labels^;
        NEXT block_descriptor IN blank_label_group;
        block_descriptor^.label_block_type := fsc$tapemark_tape_label_block;
        NEXT block_descriptor IN blank_label_group;
        block_descriptor^.label_block_type := fsc$tapemark_tape_label_block;
        RESET blank_label_group;
        NEXT sequence_header IN blank_label_group;
        sequence_header^.label_kinds := $fst$ansi_label_kinds
              [fsc$ansi_vol1_label_kind, fsc$ansi_hdr1_label_kind, fsc$ansi_hdr2_label_kind,
              fsc$ansi_eof1_label_kind, fsc$ansi_eof2_label_kind];
        sequence_header^.sequence_size := blank_label_group_size;
        sequence_header^.label_count := 10;
        NEXT block_descriptor IN blank_label_group;
        NEXT proposed_vol1 IN blank_label_group;
        NEXT block_descriptor IN blank_label_group;
        NEXT hdr1_block IN blank_label_group;
        NEXT block_descriptor IN blank_label_group;
        NEXT hdr2_block IN blank_label_group;
        NEXT block_descriptor IN blank_label_group; {First Tapemark}
        NEXT block_descriptor IN blank_label_group; {Second Tapemark}
        NEXT block_descriptor IN blank_label_group;
        NEXT eof1_block IN blank_label_group;
        NEXT block_descriptor IN blank_label_group;
        NEXT eof2_block IN blank_label_group;

        proposed_vol1^.accessibility := ' ';
        {Ensure VE reserved fields in HDR2 are set to space to ensure "blank" classification
        hdr2_block^.label_string (16, 35) := ' ';
        eof2_block^.label_string (16, 35) := ' ';

        IF pvt [p$labeling_convention].value^.keyword_value = 'CDC_VERSION_ONE' THEN
          IF pvt [p$implementation_identifier].specified AND
                (attachment_options^ [ta_ii].tape_attachment.tape_implementation_id <>
                fsc$version_one_ve_identifier) THEN
            osp$set_status_abnormal ('RM', rme$lc_parameter_conflict, 'IMPLEMENTATION_IDENTIFIER', status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  pvt [p$labeling_convention].value^.keyword_value, status);
            RETURN;
          IFEND;
          proposed_vol1^.implementation_identifier := fsc$version_one_ve_identifier;
          hdr1_block^.system_code := fsc$version_one_ve_identifier;
        ELSE
          IF pvt [p$implementation_identifier].specified AND
                (attachment_options^ [ta_ii].tape_attachment.tape_implementation_id <>
                fsc$version_two_ve_identifier) THEN
            osp$set_status_abnormal ('RM', rme$lc_parameter_conflict, 'IMPLEMENTATION_IDENTIFIER', status);
            osp$append_status_parameter (osc$status_parameter_delimiter,
                  pvt [p$labeling_convention].value^.keyword_value, status);
            RETURN;
          IFEND;
          IF pvt [p$labeling_convention].value^.keyword_value = 'LABEL_FOR_GROUP' THEN
            IF NOT pvt [p$removable_media_group].specified THEN
              osp$set_status_abnormal ('RM', rme$lc_value_requires_parameter, 'REMOVABLE_MEDIA_GROUP',
                    status);
              osp$append_status_parameter (osc$status_parameter_delimiter, 'LABEL_FOR_GROUP', status);
              RETURN;
            IFEND;
          ELSEIF pvt [p$labeling_convention].value^.keyword_value = 'LABEL_FOR_USER' THEN
            IF NOT pvt [p$owner_identifier].specified THEN
              osp$set_status_abnormal ('RM', rme$lc_value_requires_parameter, 'OWNER_IDENTIFIER', status);
              osp$append_status_parameter (osc$status_parameter_delimiter, 'LABEL_FOR_USER', status);
              RETURN;
            IFEND;
            IF pvt [p$volume_accessibility].specified THEN
              IF volume_accessibility <> 'A' THEN
                osp$set_status_abnormal ('RM', rme$lc_parameter_conflict, 'VOLUME_ACCESSIBILITY', status);
                osp$append_status_parameter (osc$status_parameter_delimiter, 'LABEL_FOR_USER', status);
                RETURN;
              IFEND;
            ELSE
              proposed_vol1^.accessibility := 'A';
            IFEND;
          IFEND;
        IFEND;
      IFEND;
      RESET blank_label_group;
      attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.blank_label_group :=
            blank_label_group;

    ELSE { list of string }
      string_count := 0;
      PUSH blank_label_group: [[REP 1 OF fst$tape_label_sequence_header, REP
            (fsc$max_tape_labels * (#SIZE (fst$tape_label_block_descriptor) + fsc$max_tape_label_length)) OF
            cell]];
      NEXT sequence_header IN blank_label_group;
      sequence_header^.character_set := attachment_options^ [ta_cs].tape_attachment.tape_character_set;
      sequence_header^.label_kinds := $fst$ansi_label_kinds [];
      list_node := pvt [p$labeling_convention].value;
      WHILE list_node <> NIL DO
        string_count := string_count + 1;
        IF list_node^.element_value^.string_value^ = '*' THEN { tapemark }
          NEXT block_descriptor IN blank_label_group;
          block_descriptor^.label_block_type := fsc$tapemark_tape_label_block;
        ELSE
          fsp$classify_tape_label (list_node^.element_value^.string_value^, label_classification);
          label_length := #SIZE (list_node^.element_value^.string_value^);
          NEXT block_descriptor IN blank_label_group;
          IF label_classification.valid_label THEN
            block_descriptor^.label_block_type := fsc$normal_tape_label_block;
            block_descriptor^.normal_label_actual_length := label_length;
            block_descriptor^.normal_label_character_set := label_classification.character_set;
            block_descriptor^.normal_label_kind := label_classification.label_kind;
            block_descriptor^.normal_label_transfer_length := label_length;
            sequence_header^.label_kinds := sequence_header^.label_kinds +
                  $fst$ansi_label_kinds [label_classification.label_kind];
          ELSE
            block_descriptor^.label_block_type := fsc$non_tape_label_block;
            block_descriptor^.non_label_actual_length := label_length;
            block_descriptor^.non_label_transfer_length := label_length;
          IFEND;
          NEXT label_block: [label_length] IN blank_label_group;
          label_block^ := list_node^.element_value^.string_value^;
        IFEND;
        list_node := list_node^.link;
      WHILEND;
      blank_label_group_size := i#current_sequence_position (blank_label_group);
      sequence_header^.sequence_size := blank_label_group_size;
      sequence_header^.label_count := string_count;
      PUSH attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.blank_label_group:
            [[REP blank_label_group_size OF cell]];
      RESET blank_label_group;
      i#move (blank_label_group, attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.
            blank_label_group, blank_label_group_size);

      label_identifier.location_method := fsc$tape_label_locate_by_kind;
      label_identifier.label_kind := fsc$ansi_vol1_label_kind;
      fsp$locate_tape_label (attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.
            blank_label_group, label_identifier, label_locator);
      IF label_locator.label_found THEN
        NEXT proposed_vol1 IN label_locator.label_block;
      ELSE
        osp$set_status_condition (ame$vol1_label_missing, status);
        RETURN;
      IFEND;
    IFEND;

    IF pvt [p$removable_media_group].specified THEN
      IF pvt [p$implementation_identifier].specified AND (attachment_options^ [ta_ii].tape_attachment.
            tape_implementation_id <> fsc$version_two_ve_identifier) THEN
        osp$set_status_abnormal ('RM', rme$rmg_parameter_conflict, 'IMPLEMENTATION_IDENTIFIER', status);
        RETURN;
      IFEND;
      IF pvt [p$volume_accessibility].specified THEN
        IF volume_accessibility <> 'A' THEN
          osp$set_status_abnormal ('RM', rme$rmg_parameter_conflict, 'VOLUME_ACCESSIBILITY', status);
          RETURN;
        IFEND;
      ELSE
        proposed_vol1^.accessibility := 'A';
      IFEND;
    IFEND;

    attachment_options^ [teo].selector := fsc$tape_error_options;
    attachment_options^ [teo].tape_error_options.perform_failure_recovery := FALSE;
    attachment_options^ [teo].tape_error_options.error_action := amc$terminate_file_access;

    PUSH file_attr: [1 .. 5];
    file_attr^ := init_file_attr;

    list_node := NIL;
    initialized_volume_count := 0;
    IF pvt [p$initialized_volume_count].specified THEN
      PUSH ivc_value;
      ivc_value^.kind := clc$integer;
      ivc_value^.integer_value.radix := 10;
      ivc_value^.integer_value.radix_specified := FALSE;
      ivc_value^.integer_value.value := initialized_volume_count;
      clp$change_variable (pvt [p$initialized_volume_count].variable^, ivc_value, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      ivc_value := NIL;
    IFEND;

    IF (NOT pvt [p$recorded_vsn].specified) AND (NOT pvt [p$external_vsn].specified) THEN
      osp$set_status_abnormal ('CL', cle$required_parameter_omitted, 'RECORDED_VSN or EXTERNAL_VSN', status);
      RETURN;
    IFEND;

    IF pvt [p$recorded_vsn].specified THEN
      IF pvt [p$external_vsn].specified THEN
        evsn_node := pvt [p$external_vsn].value;
      ELSE
        evsn_node := NIL;
      IFEND;
      rvsn_node := pvt [p$recorded_vsn].value;
      WHILE (rvsn_node <> NIL) AND status.normal DO
        validate_vsn (rvsn_node^.element_value, volume_list [1].recorded_vsn, status);
        IF NOT status.normal THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'RECORDED_VSN', status);
          RETURN;
        IFEND;
        rvsn_node := rvsn_node^.link;
        IF evsn_node = NIL THEN
          volume_list [1].external_vsn := volume_list [1].recorded_vsn;
        ELSE
          validate_vsn (evsn_node^.element_value, volume_list [1].external_vsn, status);
          IF NOT status.normal THEN
            osp$append_status_parameter (osc$status_parameter_delimiter, 'EXTERNAL_VSN', status);
            RETURN;
          IFEND;
          evsn_node := evsn_node^.link;
        IFEND;
        IF pvt [p$element].specified THEN
          IF list_node = NIL THEN { first time through loop or end of list }
            list_node := pvt [p$element].value;
          IFEND;
          attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.element :=
                list_node^.element_value^.name_value;
          list_node := list_node^.link;
        IFEND;
        create_blank_labeled_volume;
        IF ivc_value <> NIL THEN
          ivc_value^.integer_value.value := initialized_volume_count;
          clp$change_variable (pvt [p$initialized_volume_count].variable^, ivc_value, local_status);
          IF NOT local_status.normal and status.normal THEN
            status := local_status;
          IFEND;
        IFEND;
      WHILEND;
    ELSE { only evsn specified }
      evsn_node := pvt [p$external_vsn].value;
    IFEND;
    WHILE (evsn_node <> NIL) AND status.normal DO
      validate_vsn (evsn_node^.element_value, volume_list [1].external_vsn, status);
      IF NOT status.normal THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'EXTERNAL_VSN', status);
        RETURN;
      IFEND;
      volume_list [1].recorded_vsn := volume_list [1].external_vsn;
      evsn_node := evsn_node^.link;
      IF pvt [p$element].specified THEN
        IF list_node = NIL THEN
          list_node := pvt [p$element].value;
        IFEND;
        attachment_options^ [ta_vi].tape_attachment.tape_volume_initialization^.element :=
              list_node^.element_value^.name_value;
        list_node := list_node^.link;
      IFEND;
      create_blank_labeled_volume;
      IF ivc_value <> NIL THEN
        ivc_value^.integer_value.value := initialized_volume_count;
        clp$change_variable (pvt [p$initialized_volume_count].variable^, ivc_value, local_status);
        IF NOT local_status.normal and status.normal THEN
          status := local_status;
        IFEND;
      IFEND;
    WHILEND;


  PROCEND rmp$create_blank_labeled_volume;
?? OLDTITLE ??
?? NEWTITLE := 'rmp$create_blank_unlabeled_vol', EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$create_blank_unlabeled_vol
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE create_blank_unlabeled_volume, crebuv (
{   element, elements, e: list of name = $optional
{   external_vsn, evsn, external_vsns, ev: (BY_NAME) list of any of
{       name 1..6
{       string 1..6
{     anyend = $optional
{   density, d: (BY_NAME) key
{       mt9$800, mt9$1600, mt9$6250, mt18$38000
{     keyend = $optional
{   initialized_volume_count, ivc: (VAR, BY_NAME) integer = $optional
{   unload_volume, uv: (BY_NAME) boolean = true
{   volume_confirmation, vc: (BY_NAME) any of
{       key
{         all, none
{       keyend
{       list of key
{         (labeled_expired, le)
{         (unreadable_volume, uv)
{         (unlabeled, u)
{         (labeled_unexpired, lu)
{       keyend
{     anyend = osd$volume_confirmation, all
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 16] of clt$pdt_parameter_name,
      parameters: array [1 .. 7] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: 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$name_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$string_type_qualifier,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type6: 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 .. 2] 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 .. 8] of clt$keyword_specification,
          recend,
        recend,
        default_name: string (23),
        default_value: string (3),
      recend,
      type7: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [91, 7, 12, 9, 40, 27, 859],
    clc$command, 16, 7, 0, 0, 0, 1, 7, ''], [
    ['D                              ',clc$abbreviation_entry, 3],
    ['DENSITY                        ',clc$nominal_entry, 3],
    ['E                              ',clc$abbreviation_entry, 1],
    ['ELEMENT                        ',clc$nominal_entry, 1],
    ['ELEMENTS                       ',clc$alias_entry, 1],
    ['EV                             ',clc$abbreviation_entry, 2],
    ['EVSN                           ',clc$alias_entry, 2],
    ['EXTERNAL_VSN                   ',clc$nominal_entry, 2],
    ['EXTERNAL_VSNS                  ',clc$alias_entry, 2],
    ['INITIALIZED_VOLUME_COUNT       ',clc$nominal_entry, 4],
    ['IVC                            ',clc$abbreviation_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 7],
    ['UNLOAD_VOLUME                  ',clc$nominal_entry, 5],
    ['UV                             ',clc$abbreviation_entry, 5],
    ['VC                             ',clc$abbreviation_entry, 6],
    ['VOLUME_CONFIRMATION            ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 21, clc$optional_parameter,
  0, 0],
{ PARAMETER 2
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 49, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 6
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 420,
  clc$optional_default_parameter, 23, 3],
{ PARAMETER 7
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [5, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$name_type], [1, osc$max_name_size]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [33, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
      FALSE, 2],
      5, [[1, 0, clc$name_type], [1, 6]],
      8, [[1, 0, clc$string_type], [1, 6, FALSE]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [4], [
    ['MT18$38000                     ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['MT9$1600                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['MT9$6250                       ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['MT9$800                        ', clc$nominal_entry, clc$normal_usage_entry, 1]]
    ],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]],
{ PARAMETER 5
    [[1, 0, clc$boolean_type],
    'true'],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['NONE                           ', clc$nominal_entry, clc$normal_usage_entry, 2]]
      ],
    319, [[1, 0, clc$list_type], [303, 1, clc$max_list_size, 0, FALSE, FALSE],
        [[1, 0, clc$keyword_type], [8], [
        ['LABELED_EXPIRED                ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['LABELED_UNEXPIRED              ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['LE                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['LU                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['UNLABELED                      ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['UNREADABLE_VOLUME              ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['UV                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2]]
        ]
      ]
    ,
    'OSD$VOLUME_CONFIRMATION',
    'all'],
{ PARAMETER 7
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$element = 1,
      p$external_vsn = 2,
      p$density = 3,
      p$initialized_volume_count = 4,
      p$unload_volume = 5,
      p$volume_confirmation = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

?? NEWTITLE := '  create_blank_unlabeled_volume', EJECT ??

    PROCEDURE create_blank_unlabeled_volume;

?? NEWTITLE := '    crebuv_cond_handler', EJECT ??

      PROCEDURE crebuv_cond_handler
        (    condition: pmt$condition;
             condition_information: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);

        VAR
          ignore_status: ost$status;

        IF file_id <> amv$nil_file_identifier THEN
          fsp$close_file (file_id, ignore_status);
        IFEND;

        fsp$detach_file (unique_name.value, {detachment_options} NIL, ignore_status);

      PROCEND crebuv_cond_handler;
?? OLDTITLE ??
?? NEWTITLE := '    post_appropriate_menu', EJECT ??

      PROCEDURE post_appropriate_menu
        (    menu_module: pmt$program_name;
             volume_classification: rmt$tape_volume_classification;
         VAR confirmed: boolean;
         VAR status: ost$status);

        VAR
          dt: ost$date,
          hdr1_p: ^fst$ansi_hdr1_label,
          label_identifier: fst$tape_label_identifier,
          label_locator: fst$tape_label_locator,
          menu_selections_p: ^array [ * ] of ost$name,
          menu_parameters_p: rat$message_parameters,
          old_expiration_date: string (10),
          prompting_options: rat$prompting_options,
          selection_chosen: ost$name,
          sequence_header: ^fst$tape_label_sequence_header,
          todays_date: ost$date,
          vol1_p: ^fst$ansi_vol1_label;

        hdr1_p := NIL;
        old_expiration_date := '*NO HDR1*';
        vol1_p := NIL;

        PUSH menu_selections_p: [1 .. 2];
        menu_selections_p^ [1] := 'CONTINUE_CREBUV';
        menu_selections_p^ [2] := 'ABORT_CREBUV';
        IF volume_classification.volume_label_type = rmc$labeled_volume_type THEN
          pmp$get_date (osc$iso_date, todays_date, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          RESET tape_attributes [1].tape_attachment.tape_header_labels;
          NEXT sequence_header IN tape_attributes [1].tape_attachment.tape_header_labels;

          label_identifier.location_method := fsc$tape_label_locate_by_kind;
          label_identifier.label_kind := fsc$ansi_vol1_label_kind;
          fsp$locate_tape_label (tape_attributes [1].tape_attachment.tape_header_labels, label_identifier,
                label_locator);
          IF label_locator.label_found THEN
            NEXT vol1_p IN label_locator.label_block;
          IFEND;

          label_identifier.label_kind := fsc$ansi_hdr1_label_kind;
          fsp$locate_tape_label (tape_attributes [1].tape_attachment.tape_header_labels, label_identifier,
                label_locator);
          IF label_locator.label_found AND (label_locator.label_block <> NIL) THEN
            NEXT hdr1_p IN label_locator.label_block;
            IF hdr1_p^.expiration_date (2, 5) = '00000' THEN
              old_expiration_date := 'EXPIRED';
            ELSE
              dt.date_format := osc$ordinal_date;
              IF hdr1_p^.expiration_date (1) = ' ' THEN
                dt.ordinal (1, 2) := '19';
                dt.ordinal (3, 5) := hdr1_p^.expiration_date (2, 5);
              ELSE
                dt.ordinal (1, 1) := '2';
                dt.ordinal (2, 6) := hdr1_p^.expiration_date (1, 6);
              IFEND;
              pmp$change_legible_date_format (osc$iso_date, dt, local_status);
              IF local_status.normal THEN
                old_expiration_date := dt.iso;
              ELSE
                old_expiration_date := 'EXPIRED';
              IFEND;
            IFEND;
          IFEND;

          PUSH menu_parameters_p: [1 .. 8];
          menu_parameters_p^ [1] := dmv$initialize_tape_volume.element_name;
          menu_parameters_p^ [2] := volume_classification.labeled.volume_identifier (1, 6);
          IF vol1_p <> NIL THEN
            menu_parameters_p^ [3] := vol1_p^.owner_identifier (1, 14);
          ELSE
            menu_parameters_p^ [3] := '*NO VOL1*      ';
          IFEND;
          get_character_set_string (sequence_header^.character_set, menu_parameters_p^ [4]);
          menu_parameters_p^ [5] := old_expiration_date (1, 10);
          menu_parameters_p^ [6] := volume_classification.labeled.file_accessibility;
          IF vol1_p <> NIL THEN
            menu_parameters_p^ [7] := vol1_p^.label_standard_version;
          ELSE
            menu_parameters_p^ [7] := ' ';
          IFEND;
          menu_parameters_p^ [8] := volume_classification.labeled.volume_accessibility;
        ELSE
          PUSH menu_parameters_p: [1 .. 1];
          menu_parameters_p^ [1] := dmv$initialize_tape_volume.element_name;
        IFEND;

        prompting_options := $rat$prompting_options [];

{ Post menu and see if operator wants to continue

        rap$prompt_via_menu (menu_module, menu_selections_p^, menu_parameters_p, prompting_options,
              selection_chosen, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        confirmed := (selection_chosen = 'CONTINUE_CREBUV');

      PROCEND post_appropriate_menu;
?? OLDTITLE, EJECT ??

      VAR
        confirmed: boolean,
        file_id: amt$file_identifier,
        local_status: ost$status,
        returned_attributes: fst$tla_returned_attributes,
        tape_attributes: array [1 .. 1] of fst$attachment_option,
        tape_class: rmt$tape_class,
        unique_name: ost$unique_name,
        volume_classification: rmt$tape_volume_classification,
        volume_header_labels: ^SEQ ( * );

      confirmed := FALSE;

      pmp$generate_unique_name (unique_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF density = rmc$38000 THEN
        tape_class := rmc$mt18;
      ELSE
        tape_class := rmc$mt9;
      IFEND;

      rmp$request_tape (unique_name.value, tape_class, density, rmc$write_ring, volume_list, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      osp$establish_block_exit_hndlr (^crebuv_cond_handler);
      file_id := amv$nil_file_identifier;

    /initialize/
      BEGIN
        fsp$open_file (unique_name.value, amc$record, attachment_options, NIL, file_attr, NIL, NIL, file_id,
              local_status);
        IF local_status.normal THEN
          fsp$close_file (file_id, status);
          IF NOT status.normal THEN
            EXIT /initialize/;
          IFEND;
        IFEND;
        tape_attributes [1].selector := fsc$tape_attachment;
        tape_attributes [1].tape_attachment.selector := fsc$tape_header_labels;
        PUSH tape_attributes [1].tape_attachment.tape_header_labels:
              [[REP 1 OF fst$tape_label_sequence_header, REP (fsc$max_tape_labels *
              (#SIZE (fst$tape_label_block_descriptor) + fsc$max_tape_label_length)) OF cell]];
        fsp$get_tape_label_attributes (unique_name.value, fsc$tla_last_ansi_file_accessed, tape_attributes,
              returned_attributes, status);
        IF NOT status.normal THEN
          EXIT /initialize/;
        IFEND;
        IF fsc$tape_header_labels IN returned_attributes THEN
          volume_header_labels := tape_attributes [1].tape_attachment.tape_header_labels;
        ELSE
          volume_header_labels := NIL;
        IFEND;
        rmp$classify_tape_volume (local_status, volume_header_labels, volume_classification, status);
        IF status.normal THEN
          confirmed := TRUE;
          IF attachment_options^ [vi].tape_attachment.tape_volume_initialization^.volume_confirmation <>
                $fst$volume_confirmation_options [] THEN
            IF volume_classification.volume_label_type = rmc$labeled_volume_type THEN
              IF volume_classification.labeled.expired THEN
                IF fsc$confirm_expired_volume IN attachment_options^ [vi].tape_attachment.
                      tape_volume_initialization^.volume_confirmation THEN
                  post_appropriate_menu (rmc$crebuv_le_menu, volume_classification, confirmed, status);
                IFEND;
              ELSEIF fsc$confirm_unexpired_volume IN attachment_options^ [vi].tape_attachment.
                    tape_volume_initialization^.volume_confirmation THEN
                post_appropriate_menu (rmc$crebuv_lu_menu, volume_classification, confirmed, status);
              IFEND;
            ELSEIF volume_classification.volume_label_type = rmc$indeterminate_volume_type THEN
              IF fsc$confirm_unreadable_volume IN attachment_options^ [vi].tape_attachment.
                    tape_volume_initialization^.volume_confirmation THEN
                post_appropriate_menu (rmc$crebuv_urv_menu, volume_classification, confirmed, status);
              IFEND;
            ELSE { unlabeled }
              IF volume_classification.blank THEN
                post_appropriate_menu (rmc$crebuv_buv_menu, volume_classification, confirmed, status);
              ELSEIF fsc$confirm_unlabeled_volume IN attachment_options^ [vi].tape_attachment.
                    tape_volume_initialization^.volume_confirmation THEN
                post_appropriate_menu (rmc$crebuv_uv_menu, volume_classification, confirmed, status);
              IFEND;
            IFEND;
            IF NOT status.normal THEN
              EXIT /initialize/;
            IFEND;
          IFEND;
          IF confirmed THEN
            attachment_options^ [rl].tape_attachment.tape_rewrite_labels := TRUE;
            fsp$open_file (unique_name.value, amc$record, attachment_options, NIL, file_attr, NIL, NIL,
                  file_id, status);
            IF NOT status.normal THEN
              EXIT /initialize/;
            IFEND;
            initialized_volume_count := initialized_volume_count + 1;
            attachment_options^ [rl].tape_attachment.tape_rewrite_labels := FALSE;
            fsp$close_file (file_id, status);
          IFEND;
        IFEND;
      END /initialize/;

      osp$disestablish_cond_handler;

      IF confirmed THEN
        fsp$detach_file (unique_name.value, detachment_options, local_status);
      ELSE
        fsp$detach_file (unique_name.value, {detachment_options} NIL, local_status);
      IFEND;

      IF (NOT local_status.normal) AND status.normal THEN
        status := local_status;
      IFEND;

    PROCEND create_blank_unlabeled_volume;
?? OLDTITLE, EJECT ??

    CONST
      fsp = 1,
      rl = 2,
      vi = 3,

      number_of_options = 3;

    VAR
      attachment_options: ^fst$attachment_options,
      block_descriptor: ^fst$tape_label_block_descriptor,
      density: rmt$density,
      detachment_options: ^fst$detachment_options,
      evsn_node: ^clt$data_value,
      file_attr: ^array [1 .. * ] of fst$file_cycle_attribute,
      initialized_volume_count: ost$non_negative_integers,
      ivc_value: ^clt$data_value,
      list_node: ^clt$data_value,
      sequence_header: ^fst$tape_label_sequence_header,
      tapemark: 1 .. 3,
      volume_list: array [1 .. 1] of rmt$volume_descriptor;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$unload_volume].value^.boolean_value.value THEN
      detachment_options := NIL;
    ELSE
      PUSH detachment_options: [1 .. 1];
      detachment_options^ [1].selector := fsc$do_unload_volume;
      detachment_options^ [1].unload_volume := FALSE;
    IFEND;

    determine_density (pvt [p$density], pvt [p$element], pvt [p$external_vsn].specified, density, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF (density <> rmc$38000) AND pvt [p$external_vsn].specified AND (NOT pvt [p$element].specified) THEN
      osp$set_status_condition (rme$vsn_density_mismatch, status);
      RETURN;
    IFEND;

    PUSH attachment_options: [1 .. number_of_options];

    attachment_options^ [fsp].selector := fsc$tape_attachment;
    attachment_options^ [fsp].tape_attachment.selector := fsc$tape_file_set_position;
    attachment_options^ [fsp].tape_attachment.tape_file_set_position.position := fsc$tape_beginning_of_set;
    attachment_options^ [rl].selector := fsc$tape_attachment;
    attachment_options^ [rl].tape_attachment.selector := fsc$tape_rewrite_labels;
    attachment_options^ [rl].tape_attachment.tape_rewrite_labels := FALSE;
    attachment_options^ [vi].selector := fsc$tape_attachment;
    attachment_options^ [vi].tape_attachment.selector := fsc$tape_volume_initialization;
    PUSH attachment_options^ [vi].tape_attachment.tape_volume_initialization;

    PUSH attachment_options^ [vi].tape_attachment.tape_volume_initialization^.blank_label_group:
          [[REP 1 OF fst$tape_label_sequence_header, REP 3 OF fst$tape_label_block_descriptor]];
    NEXT sequence_header IN attachment_options^ [vi].tape_attachment.tape_volume_initialization^.
          blank_label_group;
    sequence_header^.character_set := amc$ascii;
    sequence_header^.label_kinds := $fst$ansi_label_kinds [];
    sequence_header^.sequence_size := #SIZE (fst$tape_label_sequence_header) +
          (3 * #SIZE (fst$tape_label_block_descriptor));
    sequence_header^.label_count := 3;
    FOR tapemark := 1 TO 3 DO
      NEXT block_descriptor IN attachment_options^ [vi].tape_attachment.tape_volume_initialization^.
            blank_label_group;
      block_descriptor^.label_block_type := fsc$tapemark_tape_label_block;
    FOREND;

    IF NOT pvt [p$element].specified THEN
      attachment_options^ [vi].tape_attachment.tape_volume_initialization^.element := osc$null_name;
    IFEND;

    IF pvt [p$volume_confirmation].value^.kind = clc$keyword THEN
      IF pvt [p$volume_confirmation].value^.keyword_value = 'ALL' THEN
        attachment_options^ [vi].tape_attachment.tape_volume_initialization^.volume_confirmation :=
              -$fst$volume_confirmation_options [];
      ELSE
        attachment_options^ [vi].tape_attachment.tape_volume_initialization^.volume_confirmation :=
              $fst$volume_confirmation_options [];
      IFEND;
    ELSE { list of key }
      attachment_options^ [vi].tape_attachment.tape_volume_initialization^.volume_confirmation :=
            $fst$volume_confirmation_options [];
      list_node := pvt [p$volume_confirmation].value;
      WHILE list_node <> NIL DO
        IF list_node^.element_value^.keyword_value = 'LABELED_EXPIRED' THEN
          attachment_options^ [vi].tape_attachment.tape_volume_initialization^.volume_confirmation :=
                attachment_options^ [vi].tape_attachment.tape_volume_initialization^.volume_confirmation +
                $fst$volume_confirmation_options [fsc$confirm_expired_volume];
        ELSEIF list_node^.element_value^.keyword_value = 'UNREADABLE_VOLUME' THEN
          attachment_options^ [vi].tape_attachment.tape_volume_initialization^.volume_confirmation :=
                attachment_options^ [vi].tape_attachment.tape_volume_initialization^.volume_confirmation +
                $fst$volume_confirmation_options [fsc$confirm_unreadable_volume];
        ELSEIF list_node^.element_value^.keyword_value = 'UNLABELED' THEN
          attachment_options^ [vi].tape_attachment.tape_volume_initialization^.volume_confirmation :=
                attachment_options^ [vi].tape_attachment.tape_volume_initialization^.volume_confirmation +
                $fst$volume_confirmation_options [fsc$confirm_unlabeled_volume];
        ELSEIF list_node^.element_value^.keyword_value = 'LABELED_UNEXPIRED' THEN
          attachment_options^ [vi].tape_attachment.tape_volume_initialization^.volume_confirmation :=
                attachment_options^ [vi].tape_attachment.tape_volume_initialization^.volume_confirmation +
                $fst$volume_confirmation_options [fsc$confirm_unexpired_volume];
        IFEND;
        list_node := list_node^.link;
      WHILEND;
    IFEND;

    PUSH file_attr: [1 .. 5];
    file_attr^ := init_file_attr;

    list_node := NIL;
    initialized_volume_count := 0;

    IF pvt [p$external_vsn].specified THEN
      evsn_node := pvt [p$external_vsn].value;
      WHILE evsn_node <> NIL DO
        validate_vsn (evsn_node^.element_value, volume_list [1].external_vsn, status);
        IF NOT status.normal THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'EXTERNAL_VSN', status);
          RETURN;
        IFEND;
        volume_list [1].recorded_vsn := volume_list [1].external_vsn;
        evsn_node := evsn_node^.link;
        IF pvt [p$element].specified THEN
          IF list_node = NIL THEN
            list_node := pvt [p$element].value;
          IFEND;
          attachment_options^ [3].tape_attachment.tape_volume_initialization^.element :=
                list_node^.element_value^.name_value;
          list_node := list_node^.link;
        IFEND;
        create_blank_unlabeled_volume;
      WHILEND;
    ELSE { element must have been specified or else an error would have occurred earlier }
      list_node := pvt [p$element].value;
      WHILE list_node <> NIL DO
        attachment_options^ [3].tape_attachment.tape_volume_initialization^.element :=
              list_node^.element_value^.name_value;
        volume_list [1].external_vsn := rmc$unspecified_vsn;
        volume_list [1].recorded_vsn := rmc$unspecified_vsn;
        create_blank_unlabeled_volume;
        list_node := list_node^.link;
      WHILEND;
    IFEND;

    IF status.normal AND pvt [p$initialized_volume_count].specified THEN
      PUSH ivc_value;
      ivc_value^.kind := clc$integer;
      ivc_value^.integer_value.value := initialized_volume_count;
      ivc_value^.integer_value.radix := 10;
      ivc_value^.integer_value.radix_specified := FALSE;
      clp$change_variable (pvt [p$initialized_volume_count].variable^, ivc_value, status);
    IFEND;

  PROCEND rmp$create_blank_unlabeled_vol;
?? OLDTITLE ??
?? NEWTITLE := 'determine_density', EJECT ??

  PROCEDURE [INLINE] determine_density
    (    density_parameter: clt$parameter_value;
         element_parameter: clt$parameter_value;
         vsn_specified: boolean;
     VAR density: rmt$density;
     VAR status: ost$status);

    VAR
      candidate_densities: cmt$densities,
      element: cmt$element_descriptor,
      element_definition: ^cmt$element_definition,
      element_info: array [1 .. 2] of cmt$element_info_item,
      element_name: cmt$element_name,
      list_node: ^clt$data_value,
      unused_iou_name: cmt$element_name;

    IF density_parameter.specified THEN
      IF density_parameter.value^.keyword_value = 'MT9$800' THEN
        candidate_densities := $cmt$densities [rmc$800];
      ELSEIF density_parameter.value^.keyword_value = 'MT9$1600' THEN
        candidate_densities := $cmt$densities [rmc$1600];
      ELSEIF density_parameter.value^.keyword_value = 'MT9$6250' THEN
        candidate_densities := $cmt$densities [rmc$6250];
      ELSEIF density_parameter.value^.keyword_value = 'MT18$38000' THEN
        candidate_densities := $cmt$densities [rmc$38000];
      IFEND;
    ELSEIF NOT element_parameter.specified AND vsn_specified THEN
      osp$set_status_abnormal ('RM', rme$vsn_density_mismatch, ' or RECORDED_VSN', status);
      RETURN;
    ELSE
      candidate_densities := -$cmt$densities [];
    IFEND;
    IF element_parameter.specified THEN
      list_node := element_parameter.value;
      WHILE list_node <> NIL DO
        element_name := list_node^.element_value^.name_value;
        PUSH element_definition;
        cmp$get_element_r3 (element_name, unused_iou_name, element_definition, status);
        IF NOT status.normal OR (element_definition^.element_type <> cmc$storage_device_element) THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_element_not_found, element_name,
                status);
          RETURN;
        IFEND;

        element.element_type := element_definition^.element_type;
        element.peripheral_descriptor.use_logical_identification := TRUE;
        element.peripheral_descriptor.element_name := element_name;
        element_info [1].selector := cmc$device_class;
        element_info [2].selector := cmc$element_capability;
        cmp$get_element_information (element, element_info, status);
        IF NOT status.normal OR (element_info [1].device_class <> rmc$magnetic_tape_device) THEN
          osp$set_status_abnormal (cmc$configuration_management_id, cme$lcm_element_not_found, element_name,
                status);
          RETURN;
        IFEND;
        candidate_densities := candidate_densities * element_info [2].element_capability.densities;
        list_node := list_node^.link;
      WHILEND;
    ELSEIF NOT vsn_specified THEN
      osp$set_status_condition (rme$element_or_vsn_required, status);
      RETURN;
    IFEND;

    IF candidate_densities = $cmt$densities [] THEN
      osp$set_status_condition (rme$supported_densities_differ, status);
      RETURN;
    IFEND;

    IF rmc$38000 IN candidate_densities THEN
      density := rmc$38000;
    ELSEIF rmc$6250 IN candidate_densities THEN
      density := rmc$6250;
    ELSEIF rmc$1600 IN candidate_densities THEN
      density := rmc$1600;
    ELSE
      density := rmc$800;
    IFEND;

  PROCEND determine_density;
?? OLDTITLE ??
?? NEWTITLE := 'get_character_set_string', EJECT ??

  PROCEDURE [INLINE] get_character_set_string
    (    character_set: amt$internal_code;
     VAR menu_parameter: rat$message_parameter);

    IF character_set = amc$ascii THEN
      menu_parameter := 'ASCII';
    ELSEIF character_set = amc$ebcdic THEN
      menu_parameter := 'EBCDIC';
    ELSE
      menu_parameter := ' ';
    IFEND;

  PROCEND get_character_set_string;
?? OLDTITLE ??
?? NEWTITLE := 'validate_vsn', EJECT ??

  PROCEDURE [INLINE] validate_vsn
    (    value: ^clt$data_value;
     VAR vsn: rmt$recorded_vsn;
     VAR status: ost$status);

    IF value^.kind = clc$string THEN
      vsn := value^.string_value^;
    ELSEIF value^.kind = clc$name THEN
      vsn := value^.name_value;
    IFEND;
    rmp$validate_ansi_string (vsn, vsn, status);
    IF NOT status.normal OR (vsn = rmc$unspecified_vsn) THEN
      osp$set_status_abnormal (rmc$resource_management_id, cle$improper_vsn_value, vsn, status);
    IFEND;

  PROCEND validate_vsn;
?? OLDTITLE ??
MODEND rmm$create_blank_volumes;
*DECK DECK=RMM$DISVC_R3_HELPER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := '  NOS/VE Display Volume Classification - Ring 3.' ??
MODULE rmm$disvc_r3_helper;

{ PURPOSE:
{   This module contains the ring 3 helper procedure for DISVC to get a
{   correct classification for a non RMA.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ave$validation_interface_errors
*copyc bat$global_file_information
*copyc bat$tape_descriptor
?? POP ??
*copyc avp$removable_media_admin
*copyc fmp$get_global_file_information
*copyc bap$get_tape_security_state
*copyc osp$set_status_abnormal

?? NEWTITLE := 'rmp$disvc_r3_helper', EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$disvc_r3_helper
    (    evaluated_file_reference: fst$evaluated_file_reference;
     VAR volume_classification: rmt$tape_volume_classification;
     VAR status: ost$status);

    VAR
      global_file_information: bat$global_file_information,
      seq_ptr: ^SEQ ( * ),
      tape_descriptor: ^bat$tape_descriptor,
      tape_security_state: bat$tape_validation_state;

    status.normal := TRUE;

    bap$get_tape_security_state (tape_security_state, status);
    IF status.normal THEN
      IF (tape_security_state <> bac$tape_validation_on) OR avp$removable_media_admin() THEN
        fmp$get_global_file_information (evaluated_file_reference, global_file_information, status);
        IF status.normal THEN
          seq_ptr := global_file_information.device_dependent_info.tape_descriptor;
          RESET seq_ptr;
          NEXT tape_descriptor IN seq_ptr;
          volume_classification := tape_descriptor^.initial_volume.classification;
        IFEND;
      ELSE
        osp$set_status_abnormal ('RM', ave$missing_required_capability, 'REMOVABLE_MEDIA_ADMINISTRATION',
              status);
      IFEND;
    IFEND;

  PROCEND rmp$disvc_r3_helper;
MODEND rmm$disvc_r3_helper;
*DECK DECK=RMM$ENFORCE_TAPE_SECURITY EXPAND=TRUE
?? RIGHT := 110 ??

MODULE rmm$enforce_tape_security;

?? NEWTITLE := 'NOS/VE Resource Management : Enforce DOD level C2 tape security' ??
?? NEWTITLE := 'Overall Design of Tape Security', EJECT ??
{
{ When a volume is mounted, NOS/VE attempts to read labels on the volume
{ regardless of the FILE_LABEL_TYPE access specified.  Based on the results of
{ the attempt to read labels, the volume is classified as defined in the TYPE
{ column below:
{
{ TABLE 1:                  TAPE VOLUME CLASSIFICATION TERMINOLOGY
{
{ TYPE        Definition
{ ---------------------------------------------------------------------------
{ LG            Labeled for group whose members are defined in NOS/VE Validation
{               File and whose name is defined in VOL1 Owner Identifier
{
{ LU            Labeled for user whose name is defined in VOL1 Owner Identifier
{
{ LV            Labeled, written by NOS/VE but neither LG nor LU; may be
{               Public or Password Protected
{
{ LX            Labeled, written by another system, i.e. "external" to NOS/VE
{
{ UL            Unlabeled
{
{ INDETERMINATE None of the above.
{ ---------------------------------------------------------------------------
?? EJECT ??
{
{ Once a volume is classified, access to the volume may be controlled by the
{ NOS/VE Validation File, depending upon the TYPE of volume found.  Access to
{ an LU volume is based on the login-user for a temporary tape file or the
{ master catalog name (owner) for a permanent tape file.  Access to an LV
{ volume is determined solely by File Accessibility, Owner Identification, and
{ Volume Accessibility which are considered passwords.
{
{ TABLE 2:         NOS/VE VALIDATION FILE and VOLUME CLASSIFICATION
{
{ TYPE        REQUIRED VALIDATION
{ ---------------------------------------------------------------------------
{
{ LG            REMOVABLE_MEDIA_ACCESS: ((name access_modes))
{
{ LU            N/A
{
{ LV            N/A
{
{ LX            REMOVABLE_MEDIA_ACCESS: ((LABELED_EXTERNAL_TAPES access_modes))
{
{ UL            REMOVABLE_MEDIA_ACCESS: ((UNLABELED_TAPES access_modes))
{
{ INDETERMINATE REMOVABLE_MEDIA_ADMINISTRATION capability
{ ---------------------------------------------------------------------------
{ NOTE: If the volume begins with labels but the VOL1 or HDR1 label is missing
{ or there are more than 128 labels in the volume header label group, access
{ to the volume is restricted to someone with REMOVABLE_MEDIA_ADMINISTRATION
{ capability.
?? EJECT ??
{
{ The prerequisites for a labeled volume to be classified as a particular TYPE
{ are discussed below.  A volume is classified as UL if it contains no labels
{ at loadpoint or begins with a tapemark.  A volume is classified as
{ INDETERMINATE if the first block cannot be read due to parity or hardware
{ error.
{
{ TABLE 3:                  TAPE VOLUME CLASSIFICATION
{
{             IMPLEMENTATION    VOLUME         OWNER          FILE
{ TYPE        IDENTIFIER        ACCESSIBILITY  IDENTIFIER     ACCESSIBILITY
{               (HDR1)            (VOL1)        (VOL1)         (HDR1)
{ ---------------------------------------------------------------------------
{
{ LG          NOS/VE V2.0       A              &group name    a character
{
{ LU          NOS/VE V2.0       A              user name      a character
{
{ LV          NOS/VE V2.0       not A          a characters   a character
{             NOS/VE V1.0       a character    a characters   a character
{
{ LX          not NOS/VE V      a character    a characters   a character
{ ---------------------------------------------------------------------------
?? EJECT ??
{
{ A labeled volume may be described as password protected because one or
{ more of the fields discussed below may be interpreted by NOS/VE as a
{ password.  The term PUBLIC is only applied to LV and LX volumes because
{ these types are the only ones in which the three security fields may all
{ be set to SPACE.  In the LX case, the volume is considered PUBLIC to all
{ who have the LABELED_EXTERNAL_TAPES validation.
{
{ TABLE 4:        TERMINOLOGY: PUBLIC and PASSWORD PROTECTED
{
{ ADJECTIVE:    APPLIES TO     VOLUME         OWNER          FILE
{                              ACCESSIBILITY  IDENTIFIER     ACCESSIBILITY
{ ---------------------------------------------------------------------------
{
{ Public        LV, LX          <--- all three set to space  --->
{
{ Password
{ Protected     LG, LU                                       nonspace
{
{ Password
{ Protected     LV, LX          <--- one or more is nonspace --->
{ ---------------------------------------------------------------------------
?? EJECT ??
{
{ When you use CREATE_BLANK_LABELED_VOLUME to initialize labels on a volume,
{ the LABELING_CONVENTION parameter determines the kinds of labels and the
{ contents of the labels written to the volume, as follows:
{
{
{ TABLE 5:                 NOS/VE CREATE_BLANK_LABELED_VOLUME Command
{
{ LABELING                      VOL1      HDR1      HDR2         OTHER
{ CONVENTION                    Label     Label     Label        CONSIDERATIONS
{ ---------------------------------------------------------------------------
{
{ ANSI                          written   absent    absent       (1)
{
{ LG                            written   written   written      (2,7)
{
{ LU                            written   written   written      (3,7)
{
{ CDC_VERSION_TWO               written   written   written      (4,7)
{
{ CDC_VERSION_ONE               written   written   written      (5)
{
{ list of string                                                 (6)
{ ---------------------------------------------------------------------------
{ NOTES:
{
{   1.  The following parameters are disallowed: file_accessibility,
{       implementation_identifier, and removable_media_group.
{
{   2.  NOS/VE sets the HDR2 Extension fields to SPACE, the
{       removable_media_group parameter is required, and the owner_identifier
{       parameter is disallowed.  Volume Accessiblity defaults to A and is
{       required to be A.  File Accessiblity defaults to SPACE but may be set
{       to any a-character.  Implementation Identifier defaults to 'NOS/VE
{       V2.0' and is required to be 'NOS/VE V2.0'.
{
{   3.  NOS/VE sets the HDR2 Extension fields to SPACE, the owner_identifier
{       parameter is required, and the removable_media_group parameter is
{       disallowed.  Volume Accessiblity defaults to A and is required to be
{       A.  File Accessiblity defaults to SPACE but may be set to any
{       a-character.  Implementation Identifier defaults to 'NOS/VE V2.0' and
{       is required to be 'NOS/VE V2.0'.
{
{   4.  NOS/VE sets the HDR2 Extension fields to SPACE.  File Accessibility,
{       Owner Identifier, and Volume Accessibility default to SPACE but may be
{       set to any a-character.  Implementation Identifier defaults to 'NOS/VE
{       V2.0' and is required to be 'NOS/VE V2.0'.  Assuming that OI and VA
{       are not specified, the first user to write on the volume will determine
{       the future security of the volume:
{
{       a.  By default, the volume is labeled with the user as the owner.
{
{       b.  By specifying the REMOVALBE_MEDIA_GROUP parameter of the
{           CHANGE_TAPE_LABEL_ATTRIBUTES command, the volume becomes labeled
{           for a group.
{
{       c.  By specifying a value other than A for Volume Accessibility, the
{           values specified by the owner_identifier and volume_accessibility
{           become passwords.
{
{   5.  NOS/VE sets the HDR2 Extension fields to SPACE.  File Accessibility,
{       Owner Identifier, and Volume Accessibility default to SPACE but may be
{       set to any a-character.  Implementation Identifier defaults to 'NOS/VE
{       V1.0' and is required to be 'NOS/VE V1.0'.  Assuming that FA, OI, and
{       VA are not specified, the first user to write on the volume may
{       enhance the security of the volume through password protection.  The
{       user may specify a value for any of the following that you set to
{       SPACE:  File Accessibility, Owner Identifier and Volume Accessibility.
{       Subsequent accessors are required to provide these values which act as
{       passwords to the volume.
{
{   6.  The caller of CREATE_BLANK_LABELED_VOLUME may dictate which labels are
{       written by providing a list of string.  Each string is considered a
{       label.  The caller may prepare a label group that looks identical to
{       one of the preceding label groups or is quite different.  Parameters
{       specified to the command are substituted into the list of string.  A
{       VOL1 label is required.  If the file_accessibility or
{       implementation_identifier parameters are specified, a HDR1 label is
{       required.
{
{   7.  If you do not specify a value for File Accessibility.  The user may
{       enhance the security of the volume by defining a password for File
{       Accessibility using the CHANGE_TAPE_LABEL_ATTRIBUTES command prior to
{       writing on the volume.
?? EJECT ??
{
{ When a volume is mounted, NOS/VE categorizes the volume as blank or
{ nonblank.  The prerequisites for classifying a volume as blank are discussed
{ below.  Any TYPE of volume could be a blank volume.
{
{
{ TABLE 6:                 BLANK VOLUME CLASSIFICATION
{
{
{ TYPE        VOL1      HDR1      HDR2         EXPIRED           OTHER
{             Label     Label     Label                        CONSIDERATIONS
{ ---------------------------------------------------------------------------
{
{ LG,LU       present   present   present      Yes            VE Extension Fields
{                                                             in HDR2 are SPACE
{                                                             (1)
{
{ LG,LU       present   present   absent       Yes            (1)
{
{ LV          present   present   present      Yes            VE Extension Fields
{                                                             in HDR2 are SPACE
{                                                             (1, 2)
{
{ LV          present   present   absent       Yes            (1, 2)
{
{ LX          present   absent    absent       assumed        (1)
{
{ LX          present   present   absent       Yes            (1, 3)
{
{ LX          present   present   present      Yes            HDR2 Record Format
{                                                             Field is SPACE
{                                                             (1, 3)
{
{ UL          absent    absent    absent       N/A            First block is a
{                                                             Tapemark
{
{ NOTES:
{
{   1.  A labeled volume must have no data following the volume header label
{       group.
{
{   2.  The Implementation Identifier is 'NOS/VE V2.0'.  NOS/VE does not recognize
{       as blank labeled any volume whose II field is 'NOS/VE V1.0'.  This is done
{       to ensure access to any volume written by previous NOS/VE releases that
{       may have a blank label group as the first file on a multi-file set.  It was
{       possible to create such a volume in releases prior to R1.6.1 L780.
{
{   3.  The following fields must also be SPACE:  File Accessibility,
{       Implementation Identifier, Owner Identifier, and Volume Accessibility
{       ---------------------------------------------------------------------------
?? EJECT ??
{
{ If you have a labeled, blank volume, the following table discusses the
{ security options that you have when you first write on it.  When you write
{ on a labeled, blank volume, you do not need to specify REWRITE_LABELS=TRUE.
{ Depending upon the TYPE of the labeled, blank volume, you may only have one
{ opportunity to select the TYPE of security that you want enforced for your
{ nonblank volume.  Therefore, you should select from the options below and
{ make your CHANGE_TAPE_LABEL_ATTRIBUTES specification before writing on the
{ volume for the first time.
{
{
{ TABLE 7:            REWRITING LABELS ON A BLANK, LABELED VOLUME
{
{
{ FROM TYPE:               TO TYPE:                     CHATLA SPECIFICATION
{ ---------------------------------------------------------------------------
{
{ LG                       LG                           no specification required
{
{ LG                       LG, Password Protected       FA= a-character
{
{ LG, Password Protected   LG, Password Protected       Must match FA of HDR1
{
{ LU                       LU                           no specification required
{
{ LU                       LU, Password Protected       FA= a-character
{
{ LU, Password Protected   LU, Password Protected       Must match FA of HDR1
{
{ LV, (1)                  LG                           RMG=group name
{
{ LV, (1)                  LG, Password Protected       RMG=group name,
{                                                       FA= a-character
{
{ LV, (1,2)                LU                           no specification required
{
{ LV, (1)                  LU, Password Protected       FA= a-character
{
{ LV, (1,3)                LU, Password Protected       Must match existing FA
{
{ LV, PUBLIC (1)           LV, PUBLIC                   Must specify VA=NONE
{
{ LV, Password Protected   LV, Password Protected       Must match any existing
{     (1)                                               security field that is
{                                                       <> SPACE.  Any existing
{                                                       security field that is
{                                                       a SPACE may be set to
{                                                       an a-character.
{
{ LX                       LG                           RMG=group name
{
{ LX                       LG, Password Protected       RMG=group name
{                                                       FA= a character
{
{ LX                       LU                           no specification required
{
{ LX                       LU, Password Protected       FA= a character
{
{ LX                       LV, PUBLIC (1)               VA=NONE
{
{ LX                       LV, Password Protected (1)   Specify a character for
{                                                       FA, OI, and/or VA
{ ---------------------------------------------------------------------------
{
{ NOTES:
{
{   1.  The Implementation Identifier is 'NOS/VE V2.0'
{
{   2.  Existing VA must be SPACE or A
{
{   3.  Password Protected, FA is <> SPACE
{
?? EJECT ??

{ The transitions defined by TABLE 7 are also allowed when the volume is
{ nonblank with the exception of the following:
{
{    a. NOS/VE only rewrites labels on blank LX volumes.
{    b. Because LV volumes whose II field is 'NOS/VE V1.0' are never classified
{       as blank, the following transitions also exist for a non-blank volume:
{
{ FROM TYPE:               TO TYPE:                     CHATLA SPECIFICATION
{ ---------------------------------------------------------------------------
{ LV, PUBLIC               LV, PUBLIC                   no specification required
{
{ LV, PUBLIC               LV, Password Protected       Specify a character for
{                                                       FA, OI, and/or VA
{
{ LV, Password Protected   LV, Password Protected       Must match any existing
{                                                       security field that is
{                                                       <> SPACE.  Any existing
{                                                       security field that is
{                                                       a SPACE may be set to
{                                                       an a-character.
{
{ ---------------------------------------------------------------------------
?? OLDTITLE ??
?? NEWTITLE := 'Copy of SRB Documenation of Tape Security Feature', EJECT ??
{
{                   SRB Article for Basic Tape Security Feature
{                   -------------------------------------------
{ This feature has as its primary objectives the implementation of:
{
{   o DOD C2 level security for magnetic tapes
{
{   o Enforcement of expiration date for labeled tapes
{
{ By default, C2 tape security is not enabled.  You must use the
{ CHANGE_TAPE_VALIDATION command to set ENFORCE_TAPE_SECURITY to ON.  For the
{ following reasons, it is recommended that you plan to leave
{ ENFORCE_TAPE_SECURITY in the OFF condition until your upgrade to R1.6.1 is
{ complete and you are sure that you will not go back to the system you
{ installed prior to R1.6.1:
{
{   1.  This feature required an extensive set of changes to labeled tape
{       processing.  While every effort has been made to deliver a quality
{       system, your site may use tape in a manner that we have not
{       anticipated.  It will be easier to understand a potential problem with
{       security disabled.
{
{   2.  If you go back and forth between R1.6.1 and a previous release, you
{       may cause problems for tape users.  To cause problems you would have
{       to do all of the following:
{
{       a.  Create a tape that is labeled for a user or labeled for a group on
{           an R1.6.1 system,
{
{       b.  Rewrite the tape, specifying REWRITE_LABELS=TRUE, using your
{           previous level of NOS/VE
{
{       c.  Access the tape again using R1.6.1.
{
{       Step (b) causes the security classification of the tape to change from
{       labeled for a user or a group to password protected.  Previous
{       releases of NOS/VE will retain the File Accessibility (FA), Owner
{       Identifier (OI), and Volume Accessibility (VA) fields but will change
{       the Implementation Identifier from 'NOS/VE 2.0' to 'NOS/VE 1.0'.
{       Therefore, your users will have to specifiy VA=A and OI.  The OI will
{       either be the user name or the name of the Removable Media Access
{       Group, the latter preceded by '&'.  Note, all other kinds of tapes may
{       be interchanged between R1.6.1 and previous releases without impact.
{
{   3.  Before turning on ENFORCE_TAPE_SECURITY, you should also study whether
{       or not you want to enable labeling for an individual user or a group
{       of users.  There are some advantages (e.g.  enhanced security) and
{       disadvantages (e.g.  difficulty interchanging tapes among NOS/VE
{       users).  The ability to label a tape for a user or a group is
{       controlled by the CREATE_BLANK_LABELED_VOLUME command.  This command's
{       LABELING_CONVENTION parameter has a default variable that allows you
{       to easily establish your site's default policy.
{
{       If you set the labeling convention to CDC_VERSION_TWO or ANSI, you
{       enable enhanced security.  The first time the volume is written, the
{       user may choose to label it with the user as the owner or label it for
{       a group.  The user also may choose to leave the volume public or use
{       password protection.
{
{       You may also blank label a volume directly for a user or a group by
{       specifying the labeling conventions LABEL_FOR_USER or LABEL_FOR_GROUP.
{       The first user to write on the volume is constrained to be the owner
{       (LABEL_FOR_USER) or a member of the group (LABEL_FOR_GROUP) who has
{       been authorized for write access.
{
{
{       WARNING
{       ----------------------------------------------------------------------
{
{       If you label volumes for CDC_VERSION_TWO, you may encounter problems
{       reading the volume on a NOS/VE release other than R1.6.1.  This is
{       only a concern if the record type of the tape file is UNDEFINED (U).
{       Your users may be able to work around the problem by using the
{       SET_FILE_ATTRIBUTES, command before accessing the tape file, to
{       specify RECORD_TYPE=UNDEFINED and the BLOCK_TYPE that was specified
{       when the file was written.
{
{       The NOS/VE deadstart tape is an example of a magnetic tape that cannot
{       be read using the MAINTAIN_DEADSTART_SOFTWARE utility on a release
{       other than R1.6.1 because of this compatibility problem.
{
{       ----------------------------------------------------------------------
{
{       If you specify CDC_VERSION_ONE, the user is restricted to using
{       passwords for security.  If you plan to interchange a volume with a
{       previous NOS/VE release, this is the recommended labeling convention.
{       If you plan to interchange a volume with another vendor, use this
{       labeling convention (specify no values for the FILE_ACCESSIBILITY,
{       OWNER_IDENTIFIER, and VOLUME_ACCESSIBILTY parameters of the
{       CREATE_BLANK_LABELED_VOLUME command).
{
{       The CREATE_BLANK_LABELED_VOLUME command provides a default variable
{       for the LABELING_CONVENTION parameter so that you may establish a
{       default policy for your operators.
{
{ Set ENFORCE_TAPE_SECURITY to ON only after you are certain to remain on
{ NOS/VE R1.6.1 and you have read the Security manual.
{
{ To prepare for the introduction of tape security, we suggest that you do the
{ following:
{
{   1.  Prepare your validation file in advance:
{
{     - If you plan to allow labeling volumes for a user, you must ensure
{       that the user names in your validation files are less than or equal to
{       14 characters in length or are unique within the first 14 characters.
{       Otherwise, the identity of the owner of a volume may be ambiguous and
{       security may be compromised.
{
{     - If a user requires access to unlabeled tapes, validate the user for
{       UNLABELEED_TAPES using the REMOVABLE_MEDIA_ACCESS field.  You may
{       allow access of READ, WRITE, or (READ, WRITE).
{
{           /sou
{           sou/admv
{           ADMV/change_user BTS
{           Changing user BTS.
{           CHAU/charma add=((unlabeled_tapes (read)))
{
{     - If a user requires access to labeled tapes written by another vendor
{       or a Control Data system other than NOS/VE, validate the user for
{       LABELED_EXTERNAL_TAPES using the REMOVABLE_MEDIA_ACCESS field.  You
{       may allow access of READ, WRITE, or (READ, WRITE).
{
{     - NOS/VE's release materials are now labeled for the group
{       RELEASE_TAPES.  Anyone using the tapes in conjuction with deadstart
{       does not require validation.  However, if you have users who access
{       release materials in other contexts (e.g.
{       MAINTAIN_DEADSTART_SOFTWARE, you must validate them for RELEASE_TAPES
{       using the REMOVABLE_MEDIA_ACCESS field.  This is true regardless of
{       whether or not tape security is enabled.
{
{     - Anyone who needs access to Express Deadstart Dump tapes or other
{       CYBER memory dumps must be validated for the group DUMP_TAPES for READ
{       access.  You must prelabel tapes that are used for dumping memory.
{       EDD will retain the VOL1 and HDR1 labels during the dump but will not
{       label an unlabeled tape for this group.  Labeling the volume for the
{       group DUMP_TAPES ensures that Control Data will be able to read a dump
{       tape that you send in for analysis.
{
{     - If you have groups of users who share access to a set of tapes, you
{       may wish to assign these users to a REMOVABLE_MEDIA_ACCESS group.
{       Unlike DUMP_TAPES, LABELED_EXTERNAL_TAPES, RELEASE_TAPES, and
{       UNLABELED_TAPES, which are reserved names, you may create any other 13
{       character name in the REMOVABLE_MEDIA_ACCESS field and control access
{       to other types of tapes.  Members of this group may label their tapes
{       for this group and share access to the tapes.
{
{   2.  By default, if you initialize a volume using R1.6.1 and use it for a
{       file or catalog backup, the volume becomes labeled for the user
{       $SYSTEM.  If you have allowed users to request these tapes and restore
{       their own files in the past, you will have to change the process.
{       Here are two suggestions:
{
{       a.  One solution would be to catalog your backup file's volume set as
{           a labeled, permanent tape file and permit those who need to use
{           it.
{
{       b.  Another solution is to define a group using the
{           REMOVABLE_MEDIA_ACCESS field and validate the users who need READ
{           access to the backup file's volume set.  Then, when you introduce
{           R1.6.1 to production, you can use the new
{           CREATE_BLANK_LABELED_VOLUME command to blank label your backup
{           volumes for this group.
{
{ If tape security is not an issue at your site, you may leave
{ ENFORCE_TAPE_SECURITY in the OFF condition.  You should find that accessing
{ labeled tapes is compatible with previous releases with the exception that
{ the expiration date is now enforced.  Expiration date enforcement is
{ independent of the ENFORCE_TAPE_SECURITY selection.
{
{ If you intend to leave ENFORCE_TAPE_SECURITY in the OFF condition and you
{ are satisfied with the tape security already in effect at your site, you may
{ want to:
{
{   1.  Set the default variable for the LABELING_CONVENTION parameter of
{       CREATE_BLANK_LABELED_VOLUME to CDC_VERSION_ONE.  This ensures that the
{       contents of labels are consistent with previous releases.  If the
{       LABELING_CONVENTION is set to another value (it defaults to
{       CDC_VERSION_TWO), the user's name is stored in the Owner Identifier
{       field and the Volume Accessibility field is set to A when the user
{       rewrites a blank labeled volume, regardless of the
{       ENFORCE_TAPE_SECURITY selection.
{
{   2.  Remove the DISPLAY_VOLUME_CLASSIFICATION command from the
{       $SYSTEM.OSF$SITE_COMMAND_LIBRARY.  This command displays the contents
{       of the security fields for an ordinary user when tape security is off.
{       When tape security is on, it does not reveal any secure information.
{       The command consists of a program description and an object module
{       called RAM$DISPLAY_VOL_CLASSIFICATION.
{
{ In addition to the features identified above, the following changes and
{ enhancments are implemented.  The follwing is independent of the
{ ENFORCE_TAPE_SECURITY selection:
{
{   1.  The expiration date is now enforced when rewriting an ANSI file.
{
{   2.  The CHANGE_BACKUP_LABEL_TYPE and DISPLAY_BACKUP_LABEL_TYPE commands
{       are no longer supported.  A WARNING message is emitted when either
{       command is referenced.  These commands have been unnecessary since
{       R1.5.1 when the FILE_LABEL_TYPE default was changed to LABELED.  These
{       commands will be deleted in the next release.
{
{   3.  Repair Solution 3 (a and b) have been enhanced.  An optional VSN_LIST
{       parameter now allows input of a list of recorded VSNS that do not
{       conform to the rigid constraints imposed by the VSN_PREFIX, VSN_COUNT,
{       INCREMENT_SCHEME, etc.  parameters.  Specification of the VSN_LIST
{       parameter inactivates any specification of VSN_PREFIX et.al.  The
{       VSN_PREFIX parameter is made optional.  Refer to the System
{       Performance and Maintenance manual for a description of Repair
{       Solution 3.
{
{   4.  All of the permanenent file maintenance procedures (i.e.
{       CREATE_FULL_BACKUP, CREATE_PARTIAL_BACKUP, RESTORE_CATALOGED_FILES,
{       RESTORE_UNRECONCILED_FILES, RESTORE_UNRECONCILED_CATALOGS,
{       CREATE_AGED_FILE_BACKUP, and CREATE_CATALOG_BACKUP) have been improved
{       to support a VSN_LIST parameter.  See the discussion in (3) above.
{
{       CREATE_FULL_BACKUP and CREATE_PARTIAL_BACKUP no longer depend upon the
{       presence of ADMINISTER_VALIDATIONS to obtain the list of families.
{
{       References to CHANGE_BACKUP_LABEL_TYPE are removed from the procs.
{
{       The procs are modified to take advantage of SCL new types.
{
{   5.  The ability to mount an UNLABELED tape and access it with a
{       FILE_LABEL_TYPE of LABELED is removed from the system.  This was
{       originally done to migrate users from unlabeled to labeled backups.
{
{   6.  You may now make one or more copies of a file backup by using
{       CREATE_FILE_CONNECTION, for example:
{
{        reserve_resource mt9$6250=2
{        reqmt $local.copya rvsnl=(a1 a2 a3 a4 ...) t=mt9$6250 r=true
{        reqmt $local.copyb rvsnl=(b1 b2 b3 b4 ...) t=mt9$6250 r=true
{        change_tape_label_attributes $local.copya file_set_position=bos ..
{              rewrite_labels=true
{        change_tape_label_attributes $local.copyb file_set_position=bos ..
{              rewrite_labels=true
{        create_file_connection $local.x $local.copya
{        create_file_connection $local.x $local.copyb
{        bacpf backup_file=$local.x list=$local.copya_list
{        backup_all_files
{        quit
{        delete_file_connection $local.x $local.copya
{        delete_file_connection $local.x $local.copyb
{        detach_file ($local.copya $local.copyb)
{        release_resource mt9$6250=2
{
{     Restrictions:
{
{       a) Only one listing is produced.  The oldest connection's tape vsns
{           are given in the listing.  In the above example, COPYA is the
{           oldest because its connection was established before COPYB's
{           connection.
{       b) Both tape files must have the same FILE_LABEL_TYPE (labeled or
{           unlabeled)
{       c) Normally, BACPF specifies FILE_SET_POSITION=BEGINNING_OF_SET and
{           REWRITE_LABELS=TRUE on your behalf when opening the BACKUP_FILE.
{           However, when the BACKUP_FILE is the subject of a file connection,
{           the user is required to specify these two parameters for each copy
{           desired.
{       d) All TARGET files of the connection must be the same device class
{       e) The volume sets will be logical but not physical duplicates.
{           Actual location of files may differ from one volume set to another
{           due to variation in the capacity of volumes in each volume set.
{
{     Behavior:
{       a) Works well with dual tape channels
{       b) When one copy needs a tape mounted or operator intervention, both
{          copies stop.
{       c) Works equally well for backup to mass storage or to tape
{
{
{   7.  You may now read and write multiple files with differing record and
{       block types on an unlabeled volume without having to detach and
{       request the tape for each file.  The SET_FILE_ATTRIBUTES and
{       CHANGE_TAPE_LABEL_ATTRIBUTES commands as well as FSP$OPEN_FILE now
{       allow Record Type and Block Type (and 5 other attributes listed below)
{       to be changed for each file on the volume set.  For labeled tapes, the
{       use of SETFA is now equivalent to CHATLA for Block Type, Character
{       Conversion, Character Set, Maximum Block Length, Maximum Record
{       Length, Padding Character, and Record Type.
{
{   8.  The INITIALIZE_TAPE_VOLUME and LABEL_TAPE_VOLUMES commands are retired
{       (but still supported).  The new command CREATE_BLANK_LABELED_VOLUME
{       combines the features of the old commands and adds several new ones:
{
{       a.  An UNLOAD_VOLUME parameter is provided to allow the operator to
{           leave the tape mounted after initialization for immediate
{           assignment to a requesting job.
{
{       b.  You may now control the presentation of the confirmation menu for
{           each volume initialized.
{
{       c.  You may now provide a list of tape unit names; NOS/VE uses the
{           units in a round-robin fashion.
{
{       d.  You may now provide your own list of RECORDED_VSNS and
{           EXTERNAL_VSNS instead of the awkward and restrictive parameters of
{           LABEL_TAPE_VOLUMES.  The $VSN_LIST function may be used
{           effectively to create the list.
{
{       e.  When processing a list of volumes, you may now provide an integer
{           VAR parameter to obtain the number of volumes that were
{           successfully initialized before a failure is reported.
{
{       f.  Several parameters are added to allow the operator to create a
{           secure, blank labeled tape.
{
{   9.  An UNLOAD_VOLUME parameter is added to the DETACH_FILE command to
{       allow the user to leave the tape mounted for immediate reassignment to
{       the same job or another job.
{
{  10.  A CREATE_BLANK_UNLABELED_VOLUME command is provided to allow an
{       operator to create an unlabeled volume.  Three tapemarks are written
{       on the volume.  Many of the features of this command are in common
{       with those discussed for CREATE_BLANK_LABELED_VOLUME, above.
{
{  11.  Header Labels and Trailer Labels are now provided by the
{       $TAPE_LABEL_ATTRIBUTES function and the DISPLAY_TAPE_LABEL_ATTRIBUTES
{       command.  Security fields are now ADVANCED and only visible to a
{       Removable Media Administrator.
{
{  12.  NOS/VE now detects that a blank labeled volume has been mounted.  If
{       you try to read from the volume or write at $EOI you now get an
{       abnormal status.  You no longer need to specify REWRITE_LABELS=TRUE to
{       rewrite labels on a blank volume.  This enhancement pertains to any
{       volume labeled on this new release.
{
{       This enhancement does not pertain to blank volumes that were blank
{       labeled on previous NOS/VE releases.  This is because in the past, you
{       could append a new ANSI file beyond the empty file that is written in
{       a NOS/VE blank label group.  This is no longer allowed in the new
{       release.  However, to allow you to read volumes that retained the
{       empty file at the beginning, we do not classify such volumes as blank.
{
{  13.  A message is recorded in the job log for each ANSI file read or
{       written.  The message displays the File Section Number, File Sequence
{       Number, and Block Count.
{
{  14.  A user may opt to display to the job log all of the labels accessed
{       in the file set.  Secure fields are only made visible to an Removable
{       Media Administrator.  Put the following in the user or system prolog:
{
{       var
{         rmv$log_ansi_labels: (job) boolean = true
{       varend
{
{  15.  The Block Count in an EOF1 or EOV1 label is compared to the actual
{       block count calculated as NOS/VE reads the ANSI file.  If the values
{       differ, a warning message is written to $ERRORS and to the job log.
{
{  16.  NOS/VE now reads labeled tapes that have tapemarks embedded in the
{       data field of an ANSI file.  This will make it easier to write CYBIL
{       programs that read NOS and NOS/BE labeled tapes on NOS/VE.  Each
{       tapemark returns the FILE_POSITION of AMC$EOI and normal status when
{       using GET at the program interface level of NOS/VE.  Reading the file
{       completely is only possible from the program interface because the
{       $ASIS open position is not supported for labeled tapes.
{
{  17.  Some labeled tapes have non-numeric values in fields defined to be
{       numeric (including Creation Date and Expiration Date) by the ANSI
{       Standard.  In the past, these invalid fields may have prevented the
{       volume from being processed by NOS/VE.  In NOS/VE R1.6.1, invalid
{       numeric fields are displayed in the job log and are set to either
{       SPACE or a legal numeric value.
{
{  18.  Some labeled tapes do not conform to ANSI conventions concerning the
{       numbering of ANSI files.  In the past, if file sequencing was not
{       proper, the volume could not be processed on NOS/VE.  In R1.6.1,
{       NOS/VE does not depend upon the file sequencing to be correct.
{       Numbering is based on the actual displacement of the file from the
{       beginning of volume set rather than the value in the HDR1 label.
{
{  19.  A message is now recorded in the job log when the initial volume of
{       the volume set is not the first volume of the file set.  The initial
{       volume of the file set is one whose File Section and File Sequence
{       Numbers are both one (1).  Access to the volume is allowed, however.
{
{  20.  In the past, abnormal status was returned when a user tried to write
{       with a file reference of $EOI when the file was positioned at end of
{       set.  Now, a new ANSI file may be written if the FILE_SET_POSITION is
{       END_OF_SET, NEXT_FILE, or FILE_SEQUENCE_POSITION and the file set is
{       currently positioned at end of set.
{
{  21.  The VEDISPLAY, TAPE_MOUNT has been changed.  A mount request for a
{       volume now may consist of up to three lines.  Previously, up to two
{       lines were displayed.
{
{       Changes to the first line of the display include:
{
{       - Instead of RING (IN, OUT), we now have M (for mode) and values of W
{         (write) and R (read).
{
{       - Instead of LAB (YES, NO), we now have A (for Access) and values of L
{         (labeled), U (unlabeled), and N (non-standard_labeled).
{
{       - The previous VSN is now visible in addition to the next VSN
{
{       The second line is new.  It contains the identity of the requesting
{       user in the form of Family, User, Account and Project.  The inclusion
{       of the second line as a whole or in part is controlled by a new site
{       hook, RMM$ENFORCE_TAPE_SECURITY.
{
{       The third line is now reserved for the Removable Media Management
{       Group and Location.  The Removable Media Location is now recovered via
{       active job recovery and reappears in the TAPE_MOUNT display after job
{       recovery.
{
{  22.  The enforcement of expiration date and tape security is totally under
{       the control of the new site hook, RMM$ENFORCE_TAPE_SECURITY.  The site
{       may review or change the default policies at their discretion.  If the
{       site changes the module, it is responsible for any consequences that
{       may arise.
{
{  23.  To aid in the transition to a secure tape environment, the
{       DISPLAY_VOLUME_CLASSIFICATION command is provided on
{       $SYSTEM.OSF$SITE_COMMAND_LIBRARY.
{
{       a.  When tape security is off, the command allows the owner of a tape
{           volume to determine how NOS/VE will classsify the volume when
{           security is enabled.  This is the only command that reveals the
{           security fields File Accessibility, Owner Identifier, and Volume
{           Accessibility to an ordinary user.  Therefore, you may want to
{           remove this command from the library, if you do not want this
{           information revealed and you do not intend to enable tape
{           security.  Refer to the earlier note.
{
{       b.  When tape security is enabled, the command only reveals secure
{           information to a user executing within the SYSTEM_OPERATOR_UTILITY
{           with the REMOVABLE_MEDIA_ADMINISTRATION capability active.
{
{  24.  For a volume written by EP/IX and read on NOS/VE, the EP/IX security
{       policies are enforced.  Therefore, if your EP/IX users create private
{       volumes (those whose VA='0' and whose OI=<EP/IX user name>, these
{       users must have the same user name in their NOS/VE validation file to
{       access their private volumes.
{
{       EP/IX tapes are considered "external" to NOS/VE.  Therefore, any user
{       who must read an EP/IX tape on NOS/VE must be validated for the
{       LABELED_EXTERNAL_TAPES REMOVABLE_MEDIA_ACCESS field.
{
{       Ordinarily, if the File Accessibility, Owner Identifier, or Volume
{       Accessibility field of an "external" volume is nonblank, the field is
{       considered to be a password that the accessor is required to match in
{       order to gain access to the volume.  Because these fields are not
{       passwords on an EP/IX volume, this requirement is waived on NOS/VE.
{       The security fields are given the same meaning in NOS/VE as they are
{       in EP/IX.
{
{                    Functional Differences
{                    ----------------------
{
{ The Basic Tape Security (BTS) feature introduces the following functional
{ differences that may affect existing procedures and programs EVEN THOUGH
{ SECURITY IS DISABLED:
{
{   1.  The expiration date is now enforced.  You may only rewrite an expired
{       tape.  If you did not specify an expiration date on the
{       CHANGE_TAPE_LABEL_ATTRIBUTES command when you last wrote the tape, it
{       is expired and you will be able to rewrite it on the R1.6.1 release.
{       By default (both in the past and when executing on R1.6.1), the
{       default is to write the tape as expired.
{
{   2.  If you have an operator initialize (blank label) your tape on R1.6.1,
{       be advised that NOS/VE writes your user name in the label when you
{       first write on a blank labeled tape.  Thereafter, if your site chooses
{       to enable security, you are the only user who can access the volume.
{       If you intend to have other users share your tape, you must plan ahead
{       for when security is enabled; read the discussion below.  If your
{       current tape is never initialized in the future, you may continue to
{       access it as before, but so may other users...
{
{
{   3.  When security is enabled, tape users will be affected as follows:
{
{       a.  When ENFORCE_TAPE_SECURITY is in the ON condition, only a
{           Removable Media Administrator (RMA) may access a labeled tape
{           using FILE_LABEL_TYPE=UNLABELED or NON_STANDARD_LABELED.  This may
{           break site-defined procedures that display tape labels or
{           duplicate labeled tapes.  Five new SCL procedures and functions are
{           made available on OSF$SITE_COMMAND_LIBRARY to lessen the impact of
{           the security changes:
{
{           COMPARE_LABELED_VOLUMES - allows a user to compare the data, the
{           labels, or both, on two labeled volumes without violating
{           security.
{
{           COMPARE_UNLABELED_VOLUMES - allows a user to compare the contents
{           of two unlabeled volumes.  This function requires the user to be
{           validated for UNLABELED_TAPES for READ access.
{
{           DISPLAY_FILE_SET_ATTRIBUTES - allows a user to display the header
{           labels, trailer labels, or individual fields from all or a subset
{           of the ANSI files in a file set.  For example,
{
{          /reqmt $local.t rvsn=atape r=no d=mt9$6250
{          /disfsa $local.t do=(fi cd ed rt bt maxbl)
{
{           Display_file_set_attributes for file :$LOCAL.T
{
{
{          1
{            Block_Type           : user_specified
{            Creation_Date        : 1991-07-24
{            Expiration_Date      : 1991-07-24
{            File_Identifier      : 'IDC_16           '
{            Maximum_Block_Length : 4128
{            Record_Type          : undefined
{          2
{            Block_Type           : user_specified
{            Creation_Date        : 1991-07-24
{            Expiration_Date      : 1991-07-24
{            File_Identifier      : 'SCI_12           '
{            Maximum_Block_Length : 4128
{            Record_Type          : undefined
{
{           DUPLICATE_LABELED_VOLUME - allows a user to create a duplicate of
{           a labeled volume without violating security.
{
{           DUPLICATE_UNLABELED_VOLUME - allows a user who is validated for
{           UNLABELED_VOLUMES for (READ, WRITE) to duplicate an unlabeled
{           volume.
{
{       b.  If your tape is unlabeled, you must be validated for the
{           UNLABELED_TAPES Removable Media Access.  You may be validated for
{           READ, WRITE, or both.  You will no longer be able to access a
{           labeled tape using a FILE_LABEL_TYPE of UNLABELED.  Only a user
{           executing within the SYSTEM_OPERATOR_UTILITY with the
{           REMOVABLE_MEDIA_ADMINISTRATION capability active is given this
{           privilege.
{
{       c.  If your tape is labeled but written by another CDC system (NOS,
{           NOS/BE, EP/IX, SCOPE 2) or by other vendor's system (IBM, CRAY,
{           DEC, etc.), you must be validated for the LABELED_EXTERNAL_TAPES
{           Removable Media Access.  You may be validated for READ, WRITE, or
{           both.  WRITE access only allows the creation of a new file at the
{           end of the file set.
{
{   4.  NOS/VE's release materials are labeled for the RELEASE_TAPES Removable
{       Media Access.  Anyone using the tapes in conjuction with deadstart
{       does not require validation.  However, if you access release tapes in
{       other contexts (e.g.  using MAIDS), you must be validated for
{       RELEASE_TAPES.
{
{   5.  If you share your tape with other people and you have your tape
{       initialized (blank labeled) on R1.6.1, you have the following options
{       when you first write on the tape:
{
{        - You may make your tape PUBLIC (available to everyone) by using the
{          CHANGE_TAPE_LABEL_ATTRIBUTES (CHATLA) command to set the Volume
{          Accessibility (VA) to SPACE:
{
{            reqmt $local.t recorded_vsn=VE126 ring=true t=mt9$6250
{            change_tape_label_attributes $local.t va=none
{            bacpf bf=$local.t
{
{          NOTE:  You will need to specify VA=NONE each time you do a BACPF at
{          beginning of volume or whenever you specify REWRITE_LABELS=TRUE.
{
{       - You may invent a group name (13 characters or less) and ask that
{         those who need to share the volume be validated for the Removable
{         Media Access group.  Each group member may be given their own access
{         for READ, WRITE, or both.  When you first write the tape, specify
{         the group name.  In the following example, RELEASE_TAPES is the
{         group name:
{
{            reqmt $local.t recorded_vsn=VE126 ring=true t=mt9$6250
{            change_tape_label_attributes $local.t ..
{               removable_media_group=release_tapes
{            bacpf bf=$local.t
{
{        - You may password protect the tape by specifying one or more of the
{          security fields.  VA must be set to a value other than 'A'.  On
{          subsequent tape requests, you must repeat the specification of the
{          security field, or access is denied.  This is a less secure and less
{          formal way to share the tape.  Any user who knows the password can
{          gain access.  In the following example, the values B and PROJECT_X
{          are used as passwords when writing the tape:
{
{            reqmt $local.t recorded_vsn=VE126 ring=true t=mt9$6250
{            change_tape_label_attributes $local.t fa=b oi=project_x va=none
{            bacpf bf=$local.t
{
{          NOTE: When using the tape in a future job you must specify the
{          passwords again:
{
{            reqmt $local.t recorded_vsn=VE126 ring=true t=mt9$6250
{            change_tape_label_attributes $local.t fa=b oi=project_x
{            bacpf bf=$local.t
{
{        - If you choose none of the above, your tape will be private to you, by
{          default.  If you want someone else to share the tape, you may
{          catalog it and permit others to use it or you can have the operator
{          blank label it again so you can try one of the preceding options.
{          To catalog it do the following:
{
{          REQMT $user.ve126 recorded_vsn=VE126 ring=true t=mt9$6250
{          CREATE_FILE_PERMIT $user.ve126 g=user u=fred am=(read)
{          CREATE_FILE_PERMIT $user.ve126 g=user u=karen am=(read, write)
{
{   6.  If you initialize your tape on R1.6.1 and then label it for yourself
{       as the owner or label it for a group, you should avoid writing that
{       tape on a previous NOS/VE release, particularly if you specify
{       REWRITE_LABELS=TRUE or use BACPF (which forces REWRITE_LABELS=TRUE).
{       If you do this, you must specify VA=A and OI=user or OI='&group' when
{       you access the tape again on the R1.6.1 NOS/VE release.  The VA and OI
{       parameters must be specified on the CHANGE_TAPE_LABEL_ATTRIBUTES
{       command.
?? OLDTITLE ??
?? NEWTITLE := 'Global Variables Declared by This Module', EJECT ??

  CONST
    epix_version_one = 'EP/IX V1.0   ';

  VAR
    log_labels: boolean,
    omit_strict_hdr1_checking: boolean,
    ve_character_conversions: [STATIC, READ, oss$job_paged_literal] set of char := ['F', 'T', 'f', 't', ' '
          {allow SPACE for initialized (blank) volume} ],

    ve_character_sets: [STATIC, READ, oss$job_paged_literal] set of char := ['A', 'E', 'a', 'e', ' '
          {allow SPACE for initialized (blank) volume} ],

    ve_record_types: [STATIC, READ, oss$job_paged_literal] set of char := ['D', 'F', 'S', 'U', 'V', 'd', 'f',
          's', 'u', 'v', ' '
          {allow SPACE for initialized (blank) volume} ];

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc clt$string_value
*copyc fst$ansi_eof1_label
*copyc fst$ansi_eof2_label
*copyc fst$ansi_eofn_label
*copyc fst$ansi_eov1_label
*copyc fst$ansi_eov2_label
*copyc fst$ansi_eovn_label
*copyc fst$ansi_hdr1_label
*copyc fst$ansi_hdr2_label
*copyc fst$ansi_hdrn_label
*copyc fst$ansi_uhla_label
*copyc fst$ansi_utla_label
*copyc fst$ansi_uvln_label
*copyc fst$ansi_vol1_label
*copyc fst$ansi_voln_label
*copyc fst$tape_security_call_block
*copyc rmt$tape_volume_classification
?? PUSH (LISTEXT := ON) ??
*copyc ame$label_validation_errors
*copyc ame$tape_program_actions
*copyc cle$ecc_expression_result
*copyc fst$file_access_options
*copyc oss$job_paged_literal
*copyc rmc$labeled_external_tapes
*copyc rmc$unlabeled_tapes
*copyc rmc$vol_classification_module
*copyc rmc$vol_classification_prompt
?? POP ??
*copyc amp$access_method
*copyc avp$get_removable_media_access
*copyc avp$removable_media_admin
*copyc avp$removable_media_operator
*copyc clp$convert_string_to_date_time
*copyc clp$convert_string_to_integer
*copyc clp$get_variable
*copyc clp$trimmed_string_size
*copyc fsp$analyze_file_expiration
*copyc fsp$get_tape_label_attributes
*copyc fsp$locate_tape_label
*copyc fsp$version_one_tape_label
*copyc fsp$version_two_tape_label
*copyc fsp$ve_wrote_ansi_file
*copyc osp$find_help_module
*copyc osp$find_parameter_prompt
*copyc osp$format_help_message
*copyc osp$generate_error_message
*copyc osp$generate_log_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$append_status_file
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc pmp$get_user_identification
*copyc pmp$get_account_project
*copyc osv$lower_to_upper
?? EJECT ??
?? OLDTITLE ??
?? NEWTITLE := 'rmp$classify_tape_volume', EJECT ??
*copyc rmh$classify_tape_volume
?? EJECT ??

  PROCEDURE [#GATE, XDCL] rmp$classify_tape_volume
    (    read_labels_status: ost$status;
         volume_header_labels: ^SEQ ( * );
     VAR volume_classification: rmt$tape_volume_classification;
     VAR status: ost$status);

    VAR
      hdr1_label: ^fst$ansi_hdr1_label,
      hdr2_label: ^fst$ansi_hdr2_label,
      version_one_blank: boolean,
      vol1_label: ^fst$ansi_vol1_label;

    status.normal := TRUE;

    locate_labels (volume_header_labels, vol1_label, hdr1_label, hdr2_label);
    IF read_labels_status.normal THEN
      IF (vol1_label <> NIL) THEN
        volume_classification.volume_label_type := rmc$labeled_volume_type;
        volume_classification.labeled.volume_identifier := vol1_label^.volume_identifier;
        determine_blank_labeled_status (vol1_label^, hdr1_label, hdr2_label,
              volume_classification.labeled.blank, version_one_blank, status);
        IF status.normal THEN
          analyze_volume_security (vol1_label^, hdr1_label, hdr2_label, version_one_blank,
                volume_classification.labeled, status);
        IFEND;
      ELSE
        volume_classification.volume_label_type := rmc$labeled_volume_type;
        volume_classification.labeled.volume_security_type := rmc$vst_access_restricted;
        volume_classification.labeled.reason := rmc$vol1_missing;
      IFEND;
    ELSE
      CASE read_labels_status.condition OF
      = ame$excessive_tape_labels =
        volume_classification.volume_label_type := rmc$labeled_volume_type;
        volume_classification.labeled.volume_security_type := rmc$vst_access_restricted;
        volume_classification.labeled.reason := rmc$excessive_tape_labels;
        volume_classification.labeled.blank := FALSE;
        volume_classification.labeled.expired := FALSE;

      = ame$invalid_tape_label =
        volume_classification.volume_label_type := rmc$unlabeled_volume_type;
        volume_classification.blank := FALSE;

      = ame$unexpected_tapemark =
        volume_classification.volume_label_type := rmc$unlabeled_volume_type;
        volume_classification.blank := TRUE;

      = ame$unexpected_tape_label =
        volume_classification.volume_label_type := rmc$labeled_volume_type;
        volume_classification.labeled.volume_security_type := rmc$vst_access_restricted;
        volume_classification.labeled.reason := rmc$vol1_missing;
        volume_classification.labeled.blank := FALSE;
        volume_classification.labeled.expired := FALSE;

      = ame$tape_label_read_error =
        volume_classification.volume_label_type := rmc$indeterminate_volume_type;
      ELSE
        status := read_labels_status;
      CASEND;
    IFEND;
    IF status.normal THEN
      IF (volume_classification.volume_label_type = rmc$labeled_volume_type) AND
            (volume_classification.labeled.volume_security_type = rmc$vst_access_restricted) THEN
        IF vol1_label <> NIL THEN
          volume_classification.labeled.volume_accessibility := vol1_label^.accessibility;
          volume_classification.labeled.volume_identifier := vol1_label^.volume_identifier;
        ELSE
          volume_classification.labeled.volume_accessibility := ' ';
          volume_classification.labeled.volume_identifier := '      ';
        IFEND;
        IF hdr1_label <> NIL THEN
          volume_classification.labeled.file_accessibility := hdr1_label^.accessibility;
          volume_classification.labeled.implementation_identifier := hdr1_label^.system_code;
        ELSE
          volume_classification.labeled.file_accessibility := ' ';
          volume_classification.labeled.implementation_identifier := '              ';
        IFEND;
      IFEND;
    IFEND;
  PROCEND rmp$classify_tape_volume;
?? OLDTITLE ??
?? NEWTITLE := '  analyze_volume_security', EJECT ??

  PROCEDURE analyze_volume_security
    (    vol1_label: fst$ansi_vol1_label;
         hdr1_label: ^fst$ansi_hdr1_label;
         hdr2_label: ^fst$ansi_hdr2_label;
         version_one_blank: boolean;
     VAR labeled_tape_classification {input, output} : rmt$labeled_tape_classification;
     VAR status: ost$status);

  VAR
    local_status: ost$status;

    status.normal := TRUE;
    labeled_tape_classification.expired := FALSE;
    labeled_tape_classification.file_accessibility := ' ';
    labeled_tape_classification.implementation_identifier := ' ';
    labeled_tape_classification.volume_accessibility := vol1_label.accessibility;
    labeled_tape_classification.volume_identifier := vol1_label.volume_identifier;
    IF hdr1_label = NIL THEN
      labeled_tape_classification.volume_security_type := rmc$vst_access_restricted;
      labeled_tape_classification.reason := rmc$hdr1_missing;
      IF labeled_tape_classification.blank THEN
        labeled_tape_classification.expired := TRUE;
      IFEND;
    ELSE
      fsp$analyze_file_expiration (hdr1_label^.expiration_date, labeled_tape_classification.expired,
            local_status);
      IF NOT local_status.normal THEN
        labeled_tape_classification.expired := TRUE;
      IFEND;
      labeled_tape_classification.file_accessibility := hdr1_label^.accessibility;
      labeled_tape_classification.implementation_identifier := hdr1_label^.system_code;

      IF fsp$ve_wrote_ansi_file (hdr1_label^.system_code) THEN
        IF fsp$version_two_tape_label (hdr1_label^.system_code) AND
              (vol1_label.accessibility = 'A') THEN
          IF vol1_label.owner_identifier (1) = '&' THEN
            labeled_tape_classification.volume_security_type := rmc$vst_ve_labeled_for_group;
            labeled_tape_classification.removable_media_group := vol1_label.owner_identifier (2, 13);
          ELSE
            labeled_tape_classification.volume_security_type := rmc$vst_ve_labeled_for_user;
            labeled_tape_classification.user := vol1_label.owner_identifier;
          IFEND;
        ELSE
          labeled_tape_classification.volume_security_type := rmc$vst_ve_password_protected;
          labeled_tape_classification.ve_owner_identifier := vol1_label.owner_identifier;
        IFEND;
      ELSEIF version_one_blank THEN
        {Change classification if the blank label group could have been written by pre-L780 NOS/VE
        {Refer to DETERMINE_BLANK_LABELED_STATUS for more information.
        labeled_tape_classification.implementation_identifier := fsc$version_one_ve_identifier;
        labeled_tape_classification.volume_security_type := rmc$vst_ve_password_protected;
        labeled_tape_classification.ve_owner_identifier := vol1_label.owner_identifier;
      ELSE
        labeled_tape_classification.volume_security_type := rmc$vst_labeled_external;
        labeled_tape_classification.external_owner_identifier := vol1_label.owner_identifier;
      IFEND;
    IFEND;
  PROCEND analyze_volume_security;
?? OLDTITLE ??
?? NEWTITLE := '  determine_blank_labeled_status', EJECT ??

  PROCEDURE determine_blank_labeled_status
    (    vol1_label: fst$ansi_vol1_label;
         hdr1_label: ^fst$ansi_hdr1_label;
         hdr2_label: ^fst$ansi_hdr2_label;
     VAR blank_labeled: boolean;
     VAR version_one_blank: boolean;
     VAR status: ost$status);

    VAR
      file_is_expired: boolean,
      local_status: ost$status;

    status.normal := TRUE;
    blank_labeled := FALSE;
    version_one_blank := FALSE;

    IF (hdr1_label = NIL) THEN
      IF (hdr2_label = NIL) THEN
        blank_labeled := TRUE;
      IFEND;
    ELSEIF fsp$ve_wrote_ansi_file (hdr1_label^.system_code) THEN
      fsp$analyze_file_expiration (hdr1_label^.expiration_date, file_is_expired, local_status);
      IF NOT local_status.normal THEN
        file_is_expired := TRUE;
      IFEND;
      IF file_is_expired AND (hdr2_label <> NIL) THEN
        IF (hdr2_label^.ve_block_type = ' ') AND (hdr2_label^.ve_record_type = ' ') AND
              (hdr2_label^.ve_block_length_ext = ' ') AND (hdr2_label^.ve_record_length_ext = ' ') AND
              (hdr2_label^.ve_padding_character = ' ') AND (hdr2_label^.ve_character_set = ' ') AND
              (hdr2_label^.ve_character_conversion = ' ') AND (hdr2_label^.ve_reserved = ' ') THEN
          blank_labeled := TRUE;
        IFEND;
      IFEND;
    ELSEIF (vol1_label.accessibility = ' ') AND (vol1_label.owner_identifier = ' ') AND
          (hdr1_label^.system_code = ' ') AND (hdr1_label^.accessibility = ' ') THEN
      fsp$analyze_file_expiration (hdr1_label^.expiration_date, file_is_expired, local_status);
      IF NOT local_status.normal THEN
        file_is_expired := TRUE;
      IFEND;
      IF file_is_expired AND (hdr2_label <> NIL) THEN
        IF (hdr2_label^.record_format = ' ') AND (hdr2_label^.block_length = '00000') AND
              (hdr2_label^.record_length = '00000') AND (hdr2_label^.ve_block_type = ' ') AND
              (hdr2_label^.ve_record_type = ' ') AND (hdr2_label^.ve_block_length_ext = '000') AND
              (hdr2_label^.ve_record_length_ext = '000') AND (hdr2_label^.ve_padding_character = ' ') AND
              (hdr2_label^.ve_character_set = ' ') AND (hdr2_label^.ve_character_conversion = ' ') THEN
              {A tape written by NOS/VE prior to L780 (R1.6.1) may have a blank label group at BOS but
              {have files beyond the first one.
          version_one_blank := TRUE;
        ELSEIF (hdr2_label^.record_format = ' ') THEN
          blank_labeled := TRUE;
        IFEND;
      IFEND;
    IFEND;

  PROCEND determine_blank_labeled_status;
?? OLDTITLE ??
?? NEWTITLE := '  locate_labels', EJECT ??

  PROCEDURE locate_labels
    (    volume_header_labels: ^SEQ ( * );
     VAR vol1_label: ^fst$ansi_vol1_label;
     VAR hdr1_label: ^fst$ansi_hdr1_label;
     VAR hdr2_label: ^fst$ansi_hdr2_label);

    VAR
      label_identifier: fst$tape_label_identifier,
      label_locator: fst$tape_label_locator;

    label_identifier.location_method := fsc$tape_label_locate_by_kind;
    label_identifier.label_kind := fsc$ansi_vol1_label_kind;
    fsp$locate_tape_label (volume_header_labels, label_identifier, label_locator);
    IF label_locator.label_found THEN
      RESET label_locator.label_block;
      NEXT vol1_label IN label_locator.label_block;
    ELSE
      vol1_label := NIL;
    IFEND;

    label_identifier.location_method := fsc$tape_label_locate_by_kind;
    label_identifier.label_kind := fsc$ansi_hdr1_label_kind;
    fsp$locate_tape_label (volume_header_labels, label_identifier, label_locator);
    IF label_locator.label_found THEN
      RESET label_locator.label_block;
      NEXT hdr1_label IN label_locator.label_block;
    ELSE
      hdr1_label := NIL;
    IFEND;

    label_identifier.location_method := fsc$tape_label_locate_by_kind;
    label_identifier.label_kind := fsc$ansi_hdr2_label_kind;
    fsp$locate_tape_label (volume_header_labels, label_identifier, label_locator);
    IF label_locator.label_found THEN
      RESET label_locator.label_block;
      NEXT hdr2_label IN label_locator.label_block;
    ELSE
      hdr2_label := NIL;
    IFEND;

  PROCEND locate_labels;
?? OLDTITLE ??
?? NEWTITLE := 'rmp$format_vol_classification', EJECT ??
*copyc rmh$format_vol_classification
  PROCEDURE [#GATE, XDCL] rmp$format_vol_classification
    (    max_message_line: ost$max_status_message_line;
         volume_classification: rmt$tape_volume_classification;
     VAR formatted_classification: ost$status_message;
     VAR status: ost$status);

    CONST
      access_restricted = ', Access Restricted due to ',
      blank = ', Blank',
      cdc_version_one = ', CDC_VERSION_ONE',
      cdc_version_two = ', CDC_VERSION_TWO',
      comma = ', ',
      excessive_tape_labels = 'Excessive Tape Labels',
      expired = ', Expired',
      external = ', External',
      external_required = 'validated for LABELED_EXTERNAL_TAPES Removable Media Access ',
      file_accessibility = 'File Accessibility: ',
      for_group = ' for Group',
      for_user = ' for User',
      hdr1_missing = 'Missing HDR1 Label',
      indeterminate = 'Indeterminate',
      labeled = 'Labeled',
      nonblank = ', Nonblank',
      owner_identifier = 'Owner Identifier: ',
      password_protected = ', Password Protected',
      public = ', Public',
      rma_required = 'a Removable Media Administrator ',
      space = ' ',
      to_access = 'to access the volume.',
      ul_or_nsl_access =
            'You must specify a FILE_LABEL_TYPE of UNLABELED or NON_STANDARD_LABELED to access the volume.',
      unexpired = ', Unexpired',
      unlabeled = 'Unlabeled',
      unlabeled_required = 'validated for UNLABELED_TAPES Removable Media Access ',
      vol1_missing = 'Missing VOL1 Label',
      volume_accessibility = 'Volume Accessibility: ',
      volume_classification_text = 'Volume Classification: ',
      when_enabled = 'When security is enabled, you must be ';

    VAR
      current_column_number: 0 .. 255,
      current_parameter_number: 1 .. 3,
      params: array [1 .. 3] of ^string ( * ),
      p1: ^string ( * ),
      p2: ^string ( * ),
      p3: ^string ( * ),
      size: 0 .. 14;

?? NEWTITLE := '  append_security_fields', EJECT ??

    PROCEDURE append_security_fields;

      VAR
        next_param: 1 .. 3;

      next_param := current_parameter_number + 1;
      current_parameter_number := next_param;
      current_column_number := 1;

      IF volume_classification.labeled.file_accessibility <> space THEN
        append_string (next_param, file_accessibility);
        append_string (next_param, volume_classification.labeled.file_accessibility);
      IFEND;

      CASE volume_classification.labeled.volume_security_type OF
      = rmc$vst_labeled_external =
        IF volume_classification.labeled.external_owner_identifier <> space THEN
          IF current_column_number > 1 THEN
            append_string (next_param, comma);
          IFEND;
          append_string (next_param, owner_identifier);
          size := clp$trimmed_string_size(volume_classification.labeled.external_owner_identifier);
          append_string (next_param, volume_classification.labeled.external_owner_identifier (1, size));
        IFEND;
        IF volume_classification.labeled.volume_accessibility <> space THEN
          IF current_column_number > 1 THEN
            append_string (next_param, comma);
          IFEND;
          append_string (next_param, volume_accessibility);
          append_string (next_param, volume_classification.labeled.volume_accessibility);
        IFEND;

      = rmc$vst_ve_password_protected =
        IF volume_classification.labeled.ve_owner_identifier <> space THEN
          IF current_column_number > 1 THEN
            append_string (next_param, comma);
          IFEND;
          append_string (next_param, owner_identifier);
          size := clp$trimmed_string_size(volume_classification.labeled.ve_owner_identifier);
          append_string (next_param, volume_classification.labeled.ve_owner_identifier (1, size));
        IFEND;
        IF volume_classification.labeled.volume_accessibility <> space THEN
          IF current_column_number > 1 THEN
            append_string (next_param, comma);
          IFEND;
          append_string (next_param, volume_accessibility);
          append_string (next_param, volume_classification.labeled.volume_accessibility);
        IFEND;
      ELSE
      CASEND;
    PROCEND append_security_fields;
?? OLDTITLE ??
?? NEWTITLE := '  append_string', EJECT ??

    PROCEDURE append_string
      (    parameter_number: 1 .. 3;
           text: string ( * ));

      IF current_parameter_number <> parameter_number THEN
        current_column_number := 1;
        current_parameter_number := parameter_number;
      IFEND;

      params [current_parameter_number]^ (current_column_number, STRLENGTH (text)) :=
            text (1, STRLENGTH (text));
      current_column_number := current_column_number + STRLENGTH (text);

    PROCEND append_string;
?? OLDTITLE, EJECT ??
  VAR
    help_module: ^ost$help_module,
    ignore_natural_language: ost$natural_language,
    ignore_online_manual_name: ost$online_manual_name,
    message_template: ^ost$message_template;

    status.normal := TRUE;

    PUSH p1: [osc$status_message_width];
    PUSH p2: [osc$status_message_width];
    PUSH p3: [osc$status_message_width];

    params [1] := p1;
    params [2] := p2;
    params [3] := p3;

    p1^ := space;
    p2^ := space;
    p3^ := space;

    current_column_number := 1;
    current_parameter_number := 1;
    append_string (1, volume_classification_text);

    CASE volume_classification.volume_label_type OF
    = rmc$indeterminate_volume_type =
      append_string (1, indeterminate);
      IF NOT avp$removable_media_admin () THEN
        append_string (2, when_enabled);
        append_string (2, rma_required);
        append_string (2, to_access);
      IFEND;
    = rmc$labeled_volume_type =
      append_string (1, labeled);
      CASE volume_classification.labeled.volume_security_type OF
      = rmc$vst_access_restricted =
        IF volume_classification.labeled.blank THEN
          append_string (1, blank);
        ELSE
          append_string (1, nonblank);
        IFEND;
        IF volume_classification.labeled.expired THEN
          append_string (1, expired);
        ELSE
          append_string (1, unexpired);
        IFEND;
        append_string (1, access_restricted);
        CASE volume_classification.labeled.reason OF
        = rmc$excessive_tape_labels =
          append_string (1, excessive_tape_labels);
        = rmc$hdr1_missing =
          append_string (1, hdr1_missing);
        = rmc$vol1_missing =
          append_string (1, vol1_missing);
        ELSE
        CASEND;
        IF avp$removable_media_admin () THEN
          append_string (2, ul_or_nsl_access);
        ELSE
          append_string (2, when_enabled);
          append_string (2, rma_required);
          append_string (2, to_access);
        IFEND;
      = rmc$vst_labeled_external =
        append_string (1, external);
        IF volume_classification.labeled.blank THEN
          append_string (1, blank);
        ELSE
          append_string (1, nonblank);
        IFEND;
        IF volume_classification.labeled.expired THEN
          append_string (1, expired);
        ELSE
          append_string (1, unexpired);
        IFEND;
        IF (volume_classification.labeled.file_accessibility <> space) OR
              (volume_classification.labeled.external_owner_identifier <> space) OR
              (volume_classification.labeled.volume_accessibility <> space) THEN
          append_string (1, password_protected);
        ELSE
          append_string (1, public);
        IFEND;
        IF NOT avp$removable_media_admin () THEN
          append_string (2, when_enabled);
          append_string (2, external_required);
          append_string (2, to_access);
        IFEND;
      = rmc$vst_ve_labeled_for_group =
        append_string (1, for_group);
        size := clp$trimmed_string_size(volume_classification.labeled.removable_media_group);
        IF size > 0 THEN
          append_string (1, space);
          append_string (1, volume_classification.labeled.removable_media_group (1, size));
        IFEND;
        IF volume_classification.labeled.blank THEN
          append_string (1, blank);
        ELSE
          append_string (1, nonblank);
        IFEND;
        IF volume_classification.labeled.expired THEN
          append_string (1, expired);
        ELSE
          append_string (1, unexpired);
        IFEND;
        IF (volume_classification.labeled.file_accessibility <> space) THEN
          append_string (1, password_protected);
        IFEND;
      = rmc$vst_ve_labeled_for_user =
        append_string (1, for_user);
        size := clp$trimmed_string_size(volume_classification.labeled.user);
        IF size > 0 THEN
          append_string (1, space);
          append_string (1, volume_classification.labeled.user (1, size));
        IFEND;
        IF volume_classification.labeled.blank THEN
          append_string (1, blank);
        ELSE
          append_string (1, nonblank);
        IFEND;
        IF volume_classification.labeled.expired THEN
          append_string (1, expired);
        ELSE
          append_string (1, unexpired);
        IFEND;
        IF (volume_classification.labeled.file_accessibility <> space) THEN
          append_string (1, password_protected);
        IFEND;
      = rmc$vst_ve_password_protected =
        IF fsp$version_one_tape_label (volume_classification.labeled.implementation_identifier) THEN
          append_string (1, cdc_version_one);
        ELSEIF fsp$version_two_tape_label (volume_classification.labeled.implementation_identifier) THEN
          append_string (1, cdc_version_two);
        IFEND;
        IF volume_classification.labeled.blank THEN
          append_string (1, blank);
        ELSE
          append_string (1, nonblank);
        IFEND;
        IF volume_classification.labeled.expired THEN
          append_string (1, expired);
        ELSE
          append_string (1, unexpired);
        IFEND;
        IF (volume_classification.labeled.file_accessibility <> space) OR
              (volume_classification.labeled.ve_owner_identifier <> space) OR
              (volume_classification.labeled.volume_accessibility <> space) THEN
          append_string (1, password_protected);
        ELSE
          append_string (1, public);
        IFEND;
      ELSE
      CASEND;
      append_security_fields;

    = rmc$unlabeled_volume_type =
      append_string (1, unlabeled);
      IF volume_classification.blank THEN
        append_string (1, blank);
      ELSE
        append_string (1, nonblank);
      IFEND;
      IF NOT avp$removable_media_admin () THEN
        append_string (2, when_enabled);
        append_string (2, unlabeled_required);
        append_string (2, to_access);
      IFEND;
    ELSE
    CASEND;

    osp$find_help_module (rmc$vol_classification_module, help_module, ignore_online_manual_name,
          ignore_natural_language, status);
    IF status.normal THEN
      osp$find_parameter_prompt (help_module, rmc$vol_classification_prompt, message_template, status);
      IF status.normal THEN
        osp$format_help_message (message_template, ^params, max_message_line, formatted_classification,
              status);
      IFEND;
    IFEND;

  PROCEND rmp$format_vol_classification;
?? OLDTITLE ??
?? NEWTITLE := 'rmp$validate_ansi_string', EJECT ??

  PROCEDURE [#GATE, XDCL] rmp$validate_ansi_string (
        input_string: clt$string_value;
    VAR validated_string: clt$string_value;
    VAR status: ost$status);

    VAR
      i: integer,
      valid_characters: [STATIC, READ, oss$job_paged_literal] set of char := ['A',
        'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
        'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c',
        'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q',
        'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', '0', '1', '2', '3', '4',
        '5', '6', '7', '8', '9', ' ', '!', '"', '%', '&', '''', '(', ')', '*',
        '+', '-', '.', '/', ':', ';', '<', '=', '>', '?', '_', '$', '#', '@'];

    status.normal := TRUE;

    FOR i := 1 TO clp$trimmed_string_size (input_string) DO
      IF NOT (input_string (i) IN valid_characters) THEN
        osp$set_status_abnormal ('CL', cle$name_not_a_keyword_value, input_string, status);
        RETURN;
      IFEND;
    FOREND;

{ Convert all characters to upper case.

    #translate (osv$lower_to_upper, input_string, validated_string);

  PROCEND rmp$validate_ansi_string;
?? OLDTITLE ??
?? NEWTITLE := 'rmp$enforce_tape_security', EJECT ??
*copyc rmh$enforce_tape_security
?? EJECT ??

  PROCEDURE [XDCL] rmp$enforce_tape_security
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      account: avt$account_name,
      family: ost$family_name,
      local_status: ost$status,
      project: avt$project_name,
      user: ost$user_name;

    status.normal := TRUE;

  /main_program/
    BEGIN

      CASE call_block.operation OF

      = amc$dismount_current_volume =
        amp$access_method (file_identifier, call_block, layer_number, status);

      = amc$enforce_tape_security =
        enforce_tape_security (file_identifier, call_block, layer_number, status);

      = amc$fetch_req =
        amp$access_method (file_identifier, call_block, layer_number, status);

      = amc$fetch_access_information_rq =
        amp$access_method (file_identifier, call_block, layer_number, status);

      = amc$open_tape_volume =
        get_login_identification (account, family, project, user, local_status);
        IF local_status.normal THEN
          call_block.open_tape_volume^.account := account;
          call_block.open_tape_volume^.family := family;
          call_block.open_tape_volume^.project := project;
          call_block.open_tape_volume^.user := user;
        IFEND;
        amp$access_method (file_identifier, call_block, layer_number, status);

      = amc$read_tape_labels =
        amp$access_method (file_identifier, call_block, layer_number, status);

      = amc$skip_req =
        amp$access_method (file_identifier, call_block, layer_number, status);

      = amc$terminate_tape_volume =
        amp$access_method (file_identifier, call_block, layer_number, status);

      = amc$write_tape_labels =
        amp$access_method (file_identifier, call_block, layer_number, status);

      ELSE

        amp$access_method (file_identifier, call_block, layer_number, status);

      CASEND;

    END /main_program/;

  PROCEND rmp$enforce_tape_security;
?? NEWTITLE := '  enforce_tape_security', EJECT ??

  PROCEDURE enforce_tape_security
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      call_block_p: ^SEQ ( * ),
      fetch_attribute: array [1 .. 1] of amt$fetch_item,
      file: fst$path,
      info_attribute: array [1 .. 1] of amt$access_info,
      local_call_block: amt$call_block,
      resolved_file_reference: fst$resolved_file_reference,
      tape_security_call_block: ^fst$tape_security_call_block,
      volume_number: amt$volume_number;

    status.normal := TRUE;

    local_call_block.operation := amc$fetch_req;
    fetch_attribute [1].key := amc$resolved_file_reference;
    fetch_attribute [1].resolved_file_reference := ^resolved_file_reference;
    local_call_block.fetch.file_attributes := ^fetch_attribute;
    amp$access_method (file_identifier, local_call_block, layer_number, status);

    IF status.normal THEN
      local_call_block.operation := amc$fetch_access_information_rq;
      info_attribute [1].key := amc$volume_number;
      local_call_block.fai.access_information := ^info_attribute;
      amp$access_method (file_identifier, local_call_block, layer_number, status);
      IF status.normal THEN
        volume_number := info_attribute [1].volume_number;
        info_attribute [1].key := amc$volume_description;
        info_attribute [1].volume_index := volume_number;
        local_call_block.fai.access_information := ^info_attribute;
        amp$access_method (file_identifier, local_call_block, layer_number, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      file := resolved_file_reference.path (1, resolved_file_reference.cycle_path_size);
      call_block_p := call_block.enforce_tape_security;
      RESET call_block_p;
      NEXT tape_security_call_block IN call_block_p;
      IF tape_security_call_block <> NIL THEN
        get_boolean_variable ('rmv$log_ansi_labels', log_labels);
        CASE tape_security_call_block^.operation OF
        = fsc$ts_authorize_access_method =
          authorize_access_method (resolved_file_reference, file_identifier,
                tape_security_call_block^.authorize_access_method, layer_number, status);

        = fsc$ts_authorize_file_access =
          authorize_file_access (resolved_file_reference, file_identifier,
                tape_security_call_block^.authorize_file_access, layer_number,
                info_attribute [1].volume_description, status);

        = fsc$ts_authorize_file_reuse =
          authorize_file_reuse (file, file_identifier, tape_security_call_block^.authorize_file_reuse,
                layer_number, info_attribute [1].volume_description, status);

        = fsc$ts_authorize_section_read =
          authorize_section_read (resolved_file_reference, file_identifier,
                tape_security_call_block^.authorize_section_read, layer_number,
                info_attribute [1].volume_description, status);

        = fsc$ts_authorize_section_write =
          authorize_section_write (file, file_identifier, tape_security_call_block^.authorize_section_write,
                layer_number, info_attribute [1].volume_description, status);

        = fsc$ts_authorize_file_set_mount =
          authorize_file_set_mount (resolved_file_reference, file_identifier,
                tape_security_call_block^.authorize_file_set_mount, layer_number,
                info_attribute [1].volume_description, status);

        = fsc$ts_authorize_file_set_reuse =
          authorize_file_set_reuse (resolved_file_reference, file_identifier,
                tape_security_call_block^.authorize_file_set_reuse, layer_number,
                info_attribute [1].volume_description, status);

        = fsc$ts_authorize_volume_reuse =
          authorize_volume_reuse (file, file_identifier, tape_security_call_block^.authorize_volume_reuse,
                layer_number, status);

        = fsc$ts_secure_header_labels =
          secure_header_labels (file, file_identifier, tape_security_call_block^.secure_header_labels,
                layer_number, status);

        = fsc$ts_secure_trailer_labels =
          secure_trailer_labels (file, file_identifier, tape_security_call_block^.secure_trailer_labels,
                layer_number, status);

        = fsc$ts_validate_header_labels =
          validate_header_labels (file, file_identifier, tape_security_call_block^.validate_header_labels,
                layer_number, status);

        = fsc$ts_validate_trailer_labels =
          validate_trailer_labels (file, file_identifier, tape_security_call_block^.validate_trailer_labels,
                layer_number, status);
        ELSE
          osp$set_status_condition (ame$invalid_tape_security_call, status);
          osp$append_status_file (osc$status_parameter_delimiter, file, status);
        CASEND;
      ELSE
        osp$set_status_condition (ame$invalid_tape_security_call, status);
        osp$append_status_file (osc$status_parameter_delimiter, file, status);
      IFEND;
    IFEND;
  PROCEND enforce_tape_security;
?? NEWTITLE := '    authorize_access_method', EJECT ??

  PROCEDURE authorize_access_method
    (    file: fst$resolved_file_reference;
         file_identifier: amt$file_identifier;
         request: fst$ts_authorize_access_method;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

{
{    This procedure verifies that the user has the necessary validation to
{ access a volume using either non_standard_labeled or unlabeled access
{ methods.  This prevents the unauthorized user from using
{ FSP$GET_TAPE_LABEL_ATTRIBUTES or other access method interfaces to view
{ labels that may exist on the volume even though data access may later be
{ denied.
{
{    REQUEST parameters:
{
{       access_method (input):  This parameter identifies the access paradigm
{             requested for this instance of open.
{
{       enforce_tape_security (input):  Indicates whether or not tape security
{             is to be enforced.
{
?? EJECT ??

    VAR
      authorized_access: fst$file_access_options,
      family: ost$family_name,
      user: ost$user_name;

    status.normal := TRUE;
    IF request.enforce_tape_security THEN
      IF NOT avp$removable_media_admin () THEN
        CASE request.access_method OF
        = amc$non_standard_labeled =
          osp$set_status_condition (ame$rma_privilege_required, status);
          osp$append_status_file (osc$status_parameter_delimiter, file.path (1, file.file_path_size), status);
        = amc$unlabeled =
          get_user_identification (file, family, user, status);
          IF status.normal THEN
            avp$get_removable_media_access (user, family, rmc$unlabeled_tapes, authorized_access, status);
            IF (NOT status.normal) OR (authorized_access = $fst$file_access_options []) THEN
              osp$set_status_condition (ame$unlabeled_privilege_needed, status);
              osp$append_status_file (osc$status_parameter_delimiter, file.path (1, file.file_path_size),
                    status);
            IFEND;
          IFEND;
        CASEND;
      IFEND;
    IFEND;

  PROCEND authorize_access_method;
?? OLDTITLE ??
?? NEWTITLE := '    authorize_file_access ', EJECT ??

  PROCEDURE authorize_file_access
    (    file: fst$resolved_file_reference;
         file_identifier: amt$file_identifier;
         request: fst$ts_authorize_file_access;
         layer_number: amt$fap_layer_number;
         volume_descriptor: rmt$volume_descriptor;
     VAR status: ost$status);

{
{    This procedure determines the modes of access available to the user for a
{ particular ANSI file.  If the file is expired, WRITE access is allowed.  This
{ procedure is called for each ANSI file in the file set when VOL1 labels are
{ not included in the labels read.
{
{    Enforcement of the expiration date, is peformed regardless of the
{ enforcement of tape security.
{
{    REQUEST parameters:
{
{       enforce_tape_security (input):  Indicates whether or not tape security
{             is to be enforced.
{
{       header_labels (input):  Header label sequence for the current ANSI
{             file.
{
{       proposed_access (input):  Identifies the modes of access currently
{             granted to this ANSI file.  These proposed modes of access have
{             already been constrained by the modes of access authorized when
{             the initial volume of the file set was mounted.  Refer to
{             AUTHORIZE_FILE_SET_MOUNT.
{
{       proposed_access_defaulted (input):  Indicates whether or not the modes
{             of access were explicitly specified for this instance of open.
{
{       authorized_access (output):  Returns the modes of access that are
{             authorized to the user for this instance of open.  If the
{             proposed_access_defaulted, the access returned may be a subset of
{             the originally proposed_access.
{
?? EJECT ??

    VAR
      authorized_access: fst$file_access_options,
      epix_tape: boolean,
      expiration_reduced_access: boolean,
      file_is_expired: boolean,
      hdr1_label: ^fst$ansi_hdr1_label,
      ignore_hdr2_label: ^fst$ansi_hdr2_label,
      ignore_file_set_access: fst$file_access_options,
      ignore_group: string (13),
      ignore_oi: string (14),
      ignore_status: ost$status,
      ignore_va: string (1),
      ignore_vol1_label: ^fst$ansi_vol1_label,
      returned_attributes: fst$tla_returned_attributes,
      specified_fa: string (1);

    status.normal := TRUE;

    locate_labels (request.header_labels, ignore_vol1_label, hdr1_label, ignore_hdr2_label);
    IF hdr1_label <> NIL THEN
      request.authorized_access^ := $fst$file_access_options [];
      fsp$analyze_file_expiration (hdr1_label^.expiration_date, file_is_expired, status);
      IF status.normal THEN
        expiration_reduced_access := FALSE;
        IF file_is_expired THEN
          authorized_access := request.proposed_access;
        ELSE
          authorized_access := request.proposed_access * (-$fst$file_access_options
                [fsc$modify, fsc$shorten]);
          IF authorized_access <> request.proposed_access THEN
            expiration_reduced_access := TRUE;
          IFEND;
        IFEND;

        IF request.enforce_tape_security AND (NOT avp$removable_media_admin ()) THEN
          ignore_file_set_access := $fst$file_access_options [];
          ignore_va := ' ';
          enforce_epix_security (hdr1_label^.accessibility, hdr1_label^.system_code,
               {user_is_owner} FALSE, ignore_va, authorized_access, epix_tape, ignore_file_set_access);
          IF (NOT epix_tape) AND (hdr1_label^.accessibility <> ' ') THEN
            get_explicit_attributes (file, specified_fa, ignore_group, ignore_oi, ignore_va,
                   returned_attributes, status);
            IF status.normal THEN
              IF (NOT (fsc$tape_file_accessibility IN returned_attributes)) OR (specified_fa  <>
                    hdr1_label^.accessibility) THEN
                 authorized_access := $fst$file_access_options [];
              IFEND;
            IFEND;
          IFEND;
        IFEND;

        IF request.proposed_access_defaulted THEN
          request.authorized_access^ := authorized_access;
        ELSE
          IF authorized_access = request.proposed_access THEN
            request.authorized_access^ := request.proposed_access;
          IFEND;
        IFEND;
        IF (request.authorized_access^ = $fst$file_access_options []) THEN
          IF (NOT file_is_expired) AND expiration_reduced_access THEN
            osp$set_status_condition (ame$ansi_file_unexpired, status);
            osp$append_status_file (osc$status_parameter_delimiter, file.path (1, file.file_path_size),
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.external_vsn,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn,
                  status);
          ELSE
            osp$set_status_condition (ame$insufficient_file_access, status);
            osp$append_status_file (osc$status_parameter_delimiter, file.path (1, file.file_path_size),
                  status);
          IFEND;
        IFEND;
      IFEND;
    ELSE
      request.authorized_access^ := request.proposed_access;
    IFEND;

    IF cause_for_dismount (status) THEN
      dismount_current_volume (file_identifier, layer_number, ignore_status);
    IFEND;

  PROCEND authorize_file_access;
?? OLDTITLE ??
?? NEWTITLE := '    authorize_file_reuse ', EJECT ??

  PROCEDURE authorize_file_reuse
    (    file: fst$file_reference;
         file_identifier: amt$file_identifier;
         request: fst$ts_authorize_file_reuse;
         layer_number: amt$fap_layer_number;
         volume_descriptor: rmt$volume_descriptor;
     VAR status: ost$status);

{
{    This procedure ensures that each ANSI file is written with the same file
{ accessibility as the first file of a labeled file set.  Further, this procedure
{ ensures that the existing ANSI file is expired before it can be rewritten.
{
{    A REMOVABLE_MEDIA_ADMINISTRATOR (RMA) is not given any special consideration
{ when rewriting labels on the volume set.
{
{    REQUEST parameters:
{
{       enforce_tape_security (input):  Indicates whether or not tape security
{             is to be enforced.  The FILE_ACCESSIBILITY policy is subject to the
{             value of this parameter; the expiration policy is not.
{
{       initial_volume_classification (input):  This is the classification of the
{             initial volume of the volume set.
{
{       initial_volume_header_labels (input):  Header label sequence read from
{             the first volume of the file set.  These labels determine the
{             extent to which the security parameters (file_accessibiliy,
{             owner_identifier, and volume_accessibility) may be changed as new
{             labels are written.
{
{       original_header_labels (input):  These are the header labels that are
{             being replaced by the proposed_header_labels.
{
{       proposed_header_labels (input):  These are the header labels that are
{             to be written.
{
?? EJECT ??

    VAR
      existing_fa: string (1),
      file_is_expired: boolean,
      hdr1_label: ^fst$ansi_hdr1_label,
      ignore_hdr2_label: ^fst$ansi_hdr2_label,
      ignore_status: ost$status,
      ignore_vol1_label: ^fst$ansi_vol1_label,
      requested_fa: string (1);

    status.normal := TRUE;

    locate_labels (request.original_header_labels, ignore_vol1_label, hdr1_label, ignore_hdr2_label);
    IF (hdr1_label <> NIL) THEN
      fsp$analyze_file_expiration (hdr1_label^.expiration_date, file_is_expired, status);
    ELSE
      file_is_expired := TRUE;
    IFEND;

    IF status.normal AND file_is_expired THEN
      IF request.enforce_tape_security THEN
        locate_labels (request.proposed_header_labels, ignore_vol1_label, hdr1_label, ignore_hdr2_label);
        IF (hdr1_label <> NIL) THEN
          existing_fa := request.initial_volume_classification.labeled.file_accessibility;
          requested_fa := hdr1_label^.accessibility;
          IF NOT file_accessibility_matches (existing_fa, requested_fa) THEN
            osp$set_status_condition (ame$improper_security_change, status);
          IFEND;
        ELSE
          osp$set_status_condition (ame$label_not_in_sequence, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, ' ', status);
          osp$append_status_parameter (osc$status_parameter_delimiter, 'HDR1', status);
        IFEND;
      IFEND;
    ELSE
      osp$set_status_condition (ame$ansi_file_unexpired, status);
    IFEND;
    IF (NOT status.normal) THEN
      CASE status.condition OF
      = ame$ansi_file_unexpired, ame$improper_security_change =
        osp$append_status_file (osc$status_parameter_delimiter, file, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.external_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn, status);
      ELSE
      CASEND;

      IF cause_for_dismount (status) THEN
        dismount_current_volume (file_identifier, layer_number, ignore_status);
      IFEND;
    IFEND;

  PROCEND authorize_file_reuse;
?? OLDTITLE ??
?? NEWTITLE := '    authorize_file_set_mount ', EJECT ??

  PROCEDURE authorize_file_set_mount
    (    file: fst$resolved_file_reference;
         file_identifier: amt$file_identifier;
         request: fst$ts_authorize_file_set_mount;
         layer_number: amt$fap_layer_number;
         volume_descriptor: rmt$volume_descriptor;
     VAR status: ost$status);

{
{    This procedure ensures that the user has sufficient privilege to access
{ the first volume of a file set.  If access is granted, the authorized modes
{ of access are returned.  Subsequent access to existing files in the file set
{ is limited by this validation.
{
{    REQUEST parameters:
{
{       access_method (input):  Identifies how the user intends to access the
{             file set.  A user who is executing within the
{             SYSTEM_OPERATOR_UTILITY with the REMOVABLE_MEDIA_ADMINISTRATION
{             capability active is called an RMA.  An RMA may access any volume
{             as UNLABELED or as NON_STANDARD_LABELED.  An RMA may access any
{             undamaged, labeled volume using any access method ( LABELED,
{             NON_STANDARD_LABELED, or UNLABELED).  A damaged, labeled volume
{             may only be requested by an RMA accessed as either UNLABELED or
{             NON_STANDARD_LABELED.  A non-RMA may not request a labeled volume
{             using either NON_STANDARD_LABELED or UNLABELED.  Unlabeled access
{             allows the reading and writing of labels as data.
{             Non-standard-labeled access allows the reading and writing of
{             labels as data and allows reading beyond the logical end of a
{             volume.
{
{       enforce_tape_security (input):  Indicates whether or not tape security
{             is to be enforced.
{
{       header_labels (input):  Header label sequence read from the volume.
{             This is NIL for an unlabeled volume or a volume with a read error
{             at loadpoint.  This parameter is not used but is provided as a
{             convenience for the site that may implement enhanced security
{             policies based upon volume header labels not normally analyzed by
{             NOS/VE.
{
{       proposed_access (input):  Identifies the modes of access currently
{             requested and currently granted to this instance of open of the
{             tape file.
{
{       proposed_access_defaulted (input):  Indicates whether or not the modes
{             of access were explicitly requested by the user.
{
{       volume_classification (input):  The classification of the first volume
{             of the volume set.  This classification was made by first calling
{             rmp$classify_tape_volume.  If the volume is classified as blank,
{             another read is performed to determine if there is any data in
{             the first ansi file on the volume.  If there is no data found,
{             the blank classification is retained.  Note that if the volume is
{             classified as labeled and damaged due to excessive tape labels,
{             the volume is not currently positioned after a tapemark.
{
{       authorized_access (output):  Returns the modes of access that are
{             authorized to the user for this instance of open.  If the
{             proposed_access_defaulted, the access returned may be a subset of
{             the originally proposed_access.
{
{       file_set_access (output):  Returns the modes of access that are
{             authorized to the user for the file set.
{
?? EJECT ??

    VAR
      authorized_access: fst$file_access_options,
      epix_tape: boolean,
      expired: boolean,
      family: ost$family_name,
      ignore_status: ost$status,
      removable_media_group: ost$name,
      requested_fa: string (1),
      requested_group: string (13),
      requested_oi: string (14),
      requested_va: string (1),
      required_owner_identifier: string (14),
      returned_attributes: fst$tla_returned_attributes,
      user: ost$user_name,
      vc: rmt$tape_volume_classification;

?? NEWTITLE := '      validate_labeled_external', EJECT ??

    PROCEDURE validate_labeled_external;

      IF status.normal AND (vc.labeled.file_accessibility <> ' ') THEN
        IF fsc$tape_file_accessibility IN returned_attributes THEN
          IF vc.labeled.file_accessibility <> requested_fa THEN
            osp$set_status_condition (ame$unknown_volume, status);
          IFEND;
        ELSE
          osp$set_status_condition (ame$unknown_volume, status);
        IFEND;
      IFEND;

      IF status.normal AND (vc.labeled.external_owner_identifier <> ' ') THEN
        IF fsc$tape_owner_identification IN returned_attributes THEN
          IF vc.labeled.external_owner_identifier <> requested_oi THEN
            osp$set_status_condition (ame$unknown_volume, status);
          IFEND;
        ELSE
          osp$set_status_condition (ame$unknown_volume, status);
        IFEND;
      IFEND;

      IF status.normal AND (vc.labeled.volume_accessibility <> ' ') THEN
        IF fsc$tape_volume_accessibility IN returned_attributes THEN
          IF vc.labeled.volume_accessibility <> requested_va THEN
            osp$set_status_condition (ame$unknown_volume, status);
          IFEND;
        ELSE
          osp$set_status_condition (ame$unknown_volume, status);
        IFEND;
      IFEND;
    PROCEND validate_labeled_external;
?? OLDTITLE ??
?? NEWTITLE := '      validate_labeled_for_group', EJECT ??

    PROCEDURE validate_labeled_for_group;

      IF status.normal AND (vc.labeled.file_accessibility <> ' ') THEN
        IF fsc$tape_file_accessibility IN returned_attributes THEN
          IF vc.labeled.file_accessibility <> requested_fa THEN
            osp$set_status_condition (ame$unknown_volume, status);
          IFEND;
        ELSE
          osp$set_status_condition (ame$unknown_volume, status);
        IFEND;
      IFEND;

      IF status.normal AND (fsc$tape_owner_identification IN returned_attributes) THEN
        osp$set_status_condition (ame$unknown_volume, status);
      ELSEIF fsc$tape_removable_media_group IN returned_attributes THEN
        IF vc.labeled.removable_media_group <> requested_group THEN
          osp$set_status_condition (ame$unknown_volume, status);
        IFEND;
      IFEND;

      IF status.normal AND (fsc$tape_volume_accessibility IN returned_attributes) THEN
        IF vc.labeled.volume_accessibility <> requested_va THEN
          osp$set_status_condition (ame$unknown_volume, status);
        IFEND;
      IFEND;
    PROCEND validate_labeled_for_group;
?? OLDTITLE ??
?? NEWTITLE := '      validate_labeled_for_user', EJECT ??

    PROCEDURE validate_labeled_for_user;

      IF vc.labeled.user = user (1, 14) THEN
        IF status.normal AND (vc.labeled.file_accessibility <> ' ') THEN
          IF fsc$tape_file_accessibility IN returned_attributes THEN
            IF vc.labeled.file_accessibility <> requested_fa THEN
              osp$set_status_condition (ame$unknown_volume, status);
            IFEND;
          ELSE
            osp$set_status_condition (ame$unknown_volume, status);
          IFEND;
        IFEND;

        IF status.normal THEN
          IF fsc$tape_owner_identification IN returned_attributes THEN
            IF vc.labeled.user <> requested_oi THEN
              osp$set_status_condition (ame$unknown_volume, status);
            IFEND;
          ELSEIF fsc$tape_removable_media_group IN returned_attributes THEN
            osp$set_status_condition (ame$unknown_volume, status);
          IFEND;
        IFEND;

        IF status.normal AND (fsc$tape_volume_accessibility IN returned_attributes) THEN
          IF vc.labeled.volume_accessibility <> requested_va THEN
            osp$set_status_condition (ame$unknown_volume, status);
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (ame$unknown_volume, status);
      IFEND;
    PROCEND validate_labeled_for_user;
?? OLDTITLE ??
?? NEWTITLE := '      validate_ve_password_protected', EJECT ??

    PROCEDURE validate_ve_password_protected;

      IF vc.labeled.file_accessibility <> ' ' THEN
        IF fsc$tape_file_accessibility IN returned_attributes THEN
          IF vc.labeled.file_accessibility <> requested_fa THEN
            osp$set_status_condition (ame$unknown_volume, status);
          IFEND;
        ELSE
          osp$set_status_condition (ame$unknown_volume, status);
        IFEND;
      IFEND;

      IF status.normal AND (vc.labeled.ve_owner_identifier <> ' ') THEN
        IF fsc$tape_owner_identification IN returned_attributes THEN
          IF vc.labeled.ve_owner_identifier <> requested_oi THEN
            osp$set_status_condition (ame$unknown_volume, status);
          IFEND;
        ELSE
          osp$set_status_condition (ame$unknown_volume, status);
        IFEND;
      IFEND;

      IF status.normal AND (vc.labeled.volume_accessibility <> ' ') THEN
        IF fsc$tape_volume_accessibility IN returned_attributes THEN
          IF vc.labeled.volume_accessibility <> requested_va THEN
            osp$set_status_condition (ame$unknown_volume, status);
          IFEND;
        ELSE
          osp$set_status_condition (ame$unknown_volume, status);
        IFEND;
      IFEND;
    PROCEND validate_ve_password_protected;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    expired := TRUE;
    request.file_set_access^ := -$fst$file_access_options [];
    IF request.enforce_tape_security THEN
      vc := request.volume_classification;
      IF avp$removable_media_admin () THEN
        IF request.access_method = amc$labeled THEN
          IF (vc.volume_label_type = rmc$indeterminate_volume_type) OR
                ((vc.volume_label_type = rmc$labeled_volume_type) AND
                (vc.labeled.volume_security_type = rmc$vst_access_restricted) AND (NOT vc.labeled.blank)) THEN
            osp$set_status_condition (ame$volume_access_restricted, status);
          ELSE
            request.authorized_access^ := request.proposed_access;
          IFEND;
        ELSE
          request.authorized_access^ := request.proposed_access;
        IFEND;
      ELSE
        get_user_identification (file, family, user, status);
        IF status.normal THEN
          authorized_access := request.proposed_access;
          CASE vc.volume_label_type OF
          = rmc$labeled_volume_type =
            IF request.access_method = amc$labeled THEN
              get_explicit_attributes (file, requested_fa, requested_group, requested_oi, requested_va,
                    returned_attributes, status);
              IF status.normal THEN
                CASE vc.labeled.volume_security_type OF
                = rmc$vst_access_restricted =
                  IF NOT vc.labeled.blank THEN
                    osp$set_status_condition (ame$volume_access_restricted, status);
                  IFEND;
                = rmc$vst_labeled_external =
                  IF NOT vc.labeled.blank THEN {ANSI blank labeling convention looks like this case}
                    avp$get_removable_media_access (user, family, rmc$labeled_external_tapes,
                          request.file_set_access^, status);
                  IFEND;
                  enforce_epix_security (vc.labeled.file_accessibility, vc.labeled.implementation_identifier,
                       {user_is_owner} (user (1, 14) = vc.labeled.external_owner_identifier),
                       vc.labeled.volume_accessibility, authorized_access, epix_tape,
                       request.file_set_access^);
                  IF NOT epix_tape THEN
                    validate_labeled_external;
                  IFEND;
                = rmc$vst_ve_labeled_for_group =
                  removable_media_group := vc.labeled.removable_media_group;
                  avp$get_removable_media_access (user, family, removable_media_group,
                        request.file_set_access^, status);
                  validate_labeled_for_group;
                = rmc$vst_ve_labeled_for_user =
                  validate_labeled_for_user;
                = rmc$vst_ve_password_protected =
                  validate_ve_password_protected;
                ELSE
                CASEND;
              IFEND;
            ELSE {labeled but requested with unlabeled or non standard labeled access}
              osp$set_status_condition (ame$unknown_volume, status);
            IFEND;
            IF NOT vc.labeled.expired THEN
              request.file_set_access^ := request.file_set_access^ *
                    (-$fst$file_access_options [fsc$modify, fsc$shorten]);
              expired := FALSE;
            IFEND;
          = rmc$indeterminate_volume_type =
            osp$set_status_condition (ame$volume_access_restricted, status);
          = rmc$unlabeled_volume_type =
            IF request.access_method = amc$unlabeled THEN
              avp$get_removable_media_access (user, family, rmc$unlabeled_tapes, request.file_set_access^,
                    status);
            ELSE
              osp$set_status_condition (ame$unknown_volume, status);
            IFEND;
          ELSE
          CASEND;
          authorized_access := request.file_set_access^ * authorized_access;
          request.authorized_access^ := $fst$file_access_options [];
          IF status.normal THEN
            IF request.proposed_access_defaulted THEN
              request.authorized_access^ := authorized_access;
            ELSE
              IF authorized_access = request.proposed_access THEN
                request.authorized_access^ := request.proposed_access;
              IFEND;
            IFEND;
            IF request.authorized_access^ = $fst$file_access_options [] THEN
              IF (NOT expired) AND (fsc$shorten IN request.proposed_access) THEN
                osp$set_status_condition (ame$ansi_file_unexpired, status);
              ELSE
                osp$set_status_condition (ame$unknown_volume, status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    ELSE
      request.authorized_access^ := request.proposed_access;
    IFEND;
    IF (NOT status.normal) THEN
      CASE status.condition OF
      = ame$ansi_file_unexpired =
        osp$append_status_file (osc$status_parameter_delimiter, file.path (1, file.file_path_size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.external_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn, status);
      = ame$unknown_volume =
        osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.external_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn, status);
      = ame$volume_access_restricted =
        osp$append_status_file (osc$status_parameter_delimiter, file.path (1, file.file_path_size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.external_vsn, status);
      ELSE
      CASEND;
      IF cause_for_dismount (status) THEN
        dismount_current_volume (file_identifier, layer_number, ignore_status);
      IFEND;
    IFEND;

  PROCEND authorize_file_set_mount;
?? OLDTITLE ??
?? NEWTITLE := '    authorize_file_set_reuse ', EJECT ??
  PROCEDURE authorize_file_set_reuse
    (    file: fst$resolved_file_reference;
         file_identifier: amt$file_identifier;
         request: fst$ts_authorize_file_set_reuse;
         layer_number: amt$fap_layer_number;
         volume_descriptor: rmt$volume_descriptor;
     VAR status: ost$status);

{
{    This procedure ensures that the user has sufficient privilege to rewrite
{ the first volume of a labeled file set.  The user must at a minimum have
{ WRITE access to the file set.  If access is granted, the authorized modes of
{ access are returned.  Subsequent access to existing files in the file set is
{ limited to the file_set_access.  If authorization is given to rewrite the
{ labels at the beginning of the file set, the PROPOSED_HEADER_LABELS are
{ written via a subsequent WRITE_TAPE_LABELS FAP request.
{
{    Even though tape security may not be enabled, this procedure ensures that
{ the user cannot specify an Owner Identifier value other than the login-user
{ for a temporary file and the master catalog name of a permanent file when
{ labeling a volume for the user.  When labeling for a group, this procedure
{ ensures that the user belongs to the group.  This is done to ensure that the
{ writer will be able to access the tape after it is written and tape security
{ is subsequently enabled.  Note that this policy only affects volumes whose
{ Implementation Identifier is 'NOS/VE V2.0' and whose Volume Accessibility is A.
{
{    If a user specifies a value for a security field and the value is not
{ included in the labels that are written, this procedure writes a warning
{ message to the $ERRORS file and to the job log.  This can happen in several
{ ways:
{
{  1.  The user is attempting to label a volume for a REMOVABLE_MEDIA_GROUP but
{      the file set contains CDC_VERSION_ONE labels which preclude this.
{
{  2.  The user is attempting to enhance the security of a volume by specifying
{      an OWNER_IDENTIFIER but the file set contains CDC_VERSION_TWO labels,
{      VA=A, and the value specified is not the name of the login_user.
{
{  3.  After successfully mounting the initial volume of the file set, the user
{      specified security fields (via CHANGE_TAPE_LABEL_ATTRIBUTES or
{      FSP$OPEN_FILE) that do not match the existing security fields that are
{      <> SPACE.  An existing field that is <> SPACE cannot be changed without
{      first initializing the volume.
{
{      A REMOVABLE_MEDIA_ADMINISTRATOR (RMA) is not given any special
{      consideration when rewriting labels on the volume set.  The RMA must be
{      a member of any group referenced in the VOL1 OWNER_IDENTIFIER.  The RMA
{      is not allowed to label a volume for another user.
{
{      REQUEST parameters:
{
{       enforce_tape_security (input):  Indicates whether or not tape security
{             is to be enforced.  The expiration policy is independent of the
{             value of this parameter.
{
{       initial_volume_classification (input):  This is the classification of
{             the initial volume of the volume set.  The classification
{             determines the extent to which the security parameters
{             (file_accessibiliy, owner_identifier, and volume_accessibility)
{             may be changed as new labels are written at the beginning of the
{             file set.
{
{       initial_volume_header_labels (input):  Header label sequence read from
{             the first volume of the file set.  This paramter is not used but
{             is provided for a site that may extend the security policy based
{             on volume header labels not normally analyzed by NOS/VE.
{
{       proposed_access (input):  Identifies the modes of access requested and
{             currently granted to this instance of open of the tape file.
{
{       proposed_access_defaulted (input):  Indicates whether or not the modes
{             of access were explicitly specified by the user.
{
{       proposed_header_labels (input):  These are the header labels that are
{             to be written to the beginning of the file set.
{
{       proposed_volume_classification (input):  This is the classification of
{             the volume labels that are to be written at the beginning of the
{             file set.
{
{       authorized_access (output):  Returns the modes of access that are
{             authorized to the user for this instance of open.  If the
{             proposed_access_defaulted, the access returned may be a subset of
{             the originally proposed_access.  The authorized access is
{             initially constrained by the file_set_access and then by the
{             proposed_access.  To reuse the file set, SHORTEN access is
{             required or abnormal status is returned.
{
{       file_set_access (output):  Returns the modes of access that are
{             authorized to the user for the file set.  If the volume is to
{             become labeled for a REMOVABLE_MEDIA_GROUP, the user must be
{             authorized for WRITE access within the group; this supercedes any
{             access the user may have originally been authorized when the file
{             set was mounted.  If the existing file set is classified as
{             labeled external, the file_set_access is determined by the
{             LABELED_EXTERNAL_TAPES validation.

?? EJECT ??

    VAR
      authorized_access: fst$file_access_options,
      existing_fa: string (1),
      existing_va: string (1),
      family: ost$family_name,
      ignore_status: ost$status,
      proposed_fa: string (1),
      proposed_group: ost$name,
      proposed_va: string (1),
      returned_attributes: fst$tla_returned_attributes,
      specified_fa: string (1),
      specified_group: string (13),
      specified_oi: string (14),
      specified_va: string (1),
      user: ost$user_name;

?? NEWTITLE := '      emit_warning_messages', EJECT ??

    PROCEDURE emit_warning_messages;

      VAR
        ignore_status: ost$status,
        logset: pmt$ascii_logset,
        message_status: ost$status;

      logset := $pmt$ascii_logset [pmc$job_log];
      IF fsc$tape_file_accessibility IN returned_attributes THEN
        IF specified_fa <> proposed_fa THEN
          osp$set_status_condition (ame$ignored_file_accessibility, message_status);
          osp$append_status_file (osc$status_parameter_delimiter, file.path (1, file.file_path_size),
                message_status);
          osp$generate_error_message (message_status, ignore_status);
          osp$generate_log_message (logset, message_status, ignore_status);
        IFEND;
      IFEND;

      IF fsc$tape_owner_identification IN returned_attributes THEN
        CASE request.proposed_volume_classification.labeled.volume_security_type OF
        = rmc$vst_ve_labeled_for_group =
          osp$set_status_condition (ame$ignored_owner_identifier, message_status);
          osp$append_status_file (osc$status_parameter_delimiter, file.path (1, file.file_path_size),
                message_status);
          osp$generate_error_message (message_status, ignore_status);
          osp$generate_log_message (logset, message_status, ignore_status);
        = rmc$vst_ve_labeled_for_user =
          IF specified_oi <> user (1, 14) THEN
            osp$set_status_condition (ame$ignored_owner_identifier, message_status);
            osp$append_status_file (osc$status_parameter_delimiter, file.path (1, file.file_path_size),
                  message_status);
          IFEND;
        = rmc$vst_ve_password_protected =
          IF specified_oi <> request.proposed_volume_classification.labeled.ve_owner_identifier THEN
            osp$set_status_condition (ame$ignored_owner_identifier, message_status);
            osp$append_status_file (osc$status_parameter_delimiter, file.path (1, file.file_path_size),
                  message_status);
            osp$generate_error_message (message_status, ignore_status);
            osp$generate_log_message (logset, message_status, ignore_status);
          IFEND;
        ELSE
        CASEND;
      IFEND;

      IF fsc$tape_removable_media_group IN returned_attributes THEN
        CASE request.proposed_volume_classification.labeled.volume_security_type OF
        = rmc$vst_ve_labeled_for_group =
          IF specified_group <> proposed_group THEN
            osp$set_status_condition (ame$ignored_rmg, message_status);
            osp$append_status_file (osc$status_parameter_delimiter, file.path (1, file.file_path_size),
                  message_status);
            osp$generate_error_message (message_status, ignore_status);
            osp$generate_log_message (logset, message_status, ignore_status);
          IFEND;
        = rmc$vst_ve_labeled_for_user, rmc$vst_ve_password_protected =
          osp$set_status_condition (ame$ignored_rmg, message_status);
          osp$append_status_file (osc$status_parameter_delimiter, file.path (1, file.file_path_size),
                message_status);
          osp$generate_error_message (message_status, ignore_status);
          osp$generate_log_message (logset, message_status, ignore_status);
        ELSE
        CASEND;
      IFEND;

      IF fsc$tape_volume_accessibility IN returned_attributes THEN
        IF specified_va <> proposed_va THEN
          osp$set_status_condition (ame$ignored_vol_accessibility, message_status);
          osp$append_status_file (osc$status_parameter_delimiter, file.path (1, file.file_path_size),
                message_status);
          osp$generate_error_message (message_status, ignore_status);
          osp$generate_log_message (logset, message_status, ignore_status);
        IFEND;
      IFEND;

    PROCEND emit_warning_messages;
?? OLDTITLE ??
?? NEWTITLE := '      validate_labeled_for_group', EJECT ??

    PROCEDURE validate_labeled_for_group;

      IF NOT request.initial_volume_classification.labeled.blank THEN
        CASE request.initial_volume_classification.labeled.volume_security_type OF
        = rmc$vst_labeled_external =
          osp$set_status_condition (ame$improper_security_change, status);
        = rmc$vst_ve_labeled_for_group =
          IF NOT owner_identifier_matches (request.initial_volume_classification.labeled.
                removable_media_group, request.proposed_volume_classification.labeled.removable_media_group)
                THEN
            osp$set_status_condition (ame$improper_security_change, status);
          IFEND;
        = rmc$vst_ve_labeled_for_user =
          osp$set_status_condition (ame$improper_security_change, status);
        = rmc$vst_ve_password_protected =
          IF request.initial_volume_classification.labeled.ve_owner_identifier <> ' ' THEN
            osp$set_status_condition (ame$improper_security_change, status);
          ELSEIF request.initial_volume_classification.labeled.implementation_identifier <>
                request.proposed_volume_classification.labeled.implementation_identifier THEN
            osp$set_status_condition (ame$improper_security_change, status);
          IFEND;
        ELSE
        CASEND;
      IFEND;
    PROCEND validate_labeled_for_group;
?? OLDTITLE ??
?? NEWTITLE := '      validate_labeled_for_user', EJECT ??

    PROCEDURE validate_labeled_for_user;

      authorized_access := request.proposed_access;
      IF request.proposed_volume_classification.labeled.user = user (1, 14) THEN
        IF NOT request.initial_volume_classification.labeled.blank THEN
          CASE request.initial_volume_classification.labeled.volume_security_type OF
          = rmc$vst_labeled_external =
            osp$set_status_condition (ame$improper_security_change, status);
          = rmc$vst_ve_labeled_for_group =
            osp$set_status_condition (ame$improper_security_change, status);
          = rmc$vst_ve_labeled_for_user =
            IF NOT owner_identifier_matches (request.initial_volume_classification.labeled.user,
                  request.proposed_volume_classification.labeled.user) THEN
              osp$set_status_condition (ame$improper_security_change, status);
            IFEND;
          = rmc$vst_ve_password_protected =
            IF request.initial_volume_classification.labeled.ve_owner_identifier <> ' ' THEN
              osp$set_status_condition (ame$improper_security_change, status);
            ELSEIF request.initial_volume_classification.labeled.implementation_identifier <>
                  request.proposed_volume_classification.labeled.implementation_identifier THEN
              osp$set_status_condition (ame$improper_security_change, status);
            IFEND;
          ELSE
          CASEND;
        IFEND;
      ELSE
        osp$set_status_condition (ame$improper_security_change, status);
      IFEND;
    PROCEND validate_labeled_for_user;
?? OLDTITLE ??
?? NEWTITLE := '      validate_ve_password_protected', EJECT ??

    PROCEDURE validate_ve_password_protected;

      authorized_access := request.proposed_access;
      IF NOT request.initial_volume_classification.labeled.blank THEN
        CASE request.initial_volume_classification.labeled.volume_security_type OF
        = rmc$vst_labeled_external =
          osp$set_status_condition (ame$improper_security_change, status);
        = rmc$vst_ve_password_protected =
          IF NOT owner_identifier_matches (request.initial_volume_classification.labeled.ve_owner_identifier,
                request.proposed_volume_classification.labeled.ve_owner_identifier) THEN
            osp$set_status_condition (ame$improper_security_change, status);
          IFEND;
        = rmc$vst_ve_labeled_for_group, rmc$vst_ve_labeled_for_user =
          osp$set_status_condition (ame$improper_security_change, status);
        ELSE
        CASEND;
      IFEND;
    PROCEND validate_ve_password_protected;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    request.authorized_access^ := $fst$file_access_options [];
    IF request.initial_volume_classification.labeled.expired THEN
      request.file_set_access^ := -$fst$file_access_options [];
      get_user_identification (file, family, user, status);
      IF status.normal THEN
        existing_fa := request.initial_volume_classification.labeled.file_accessibility;
        existing_va := request.initial_volume_classification.labeled.volume_accessibility;
        proposed_fa := request.proposed_volume_classification.labeled.file_accessibility;
        proposed_va := request.proposed_volume_classification.labeled.volume_accessibility;
        IF request.enforce_tape_security THEN

          CASE request.proposed_volume_classification.labeled.volume_security_type OF
          = rmc$vst_labeled_external =
            {NOS/VE only writes NOS/VE implementation labels
            osp$set_status_condition (ame$improper_security_change, status);
          ELSE
            IF file_accessibility_matches (existing_fa, proposed_fa) AND
                  volume_accessibility_matches (existing_va, proposed_va) THEN
              get_explicit_attributes (file, specified_fa, specified_group, specified_oi, specified_va,
                    returned_attributes, status);
            ELSE
              osp$set_status_condition (ame$improper_security_change, status);
            IFEND;
          CASEND;

          IF status.normal THEN
            CASE request.proposed_volume_classification.labeled.volume_security_type OF
            = rmc$vst_ve_labeled_for_group =
              proposed_group := request.proposed_volume_classification.labeled.removable_media_group;
              avp$get_removable_media_access (user, family, proposed_group, request.file_set_access^, status);
              IF status.normal THEN
                validate_labeled_for_group;
              IFEND;
            = rmc$vst_ve_labeled_for_user =
              validate_labeled_for_user;
            = rmc$vst_ve_password_protected =
              validate_ve_password_protected;
            ELSE
              osp$set_status_condition (ame$improper_security_change, status);
            CASEND;
          IFEND;

          IF status.normal THEN
            emit_warning_messages;
          IFEND;
        ELSE {tape security unenforced}
          CASE request.proposed_volume_classification.labeled.volume_security_type OF
          = rmc$vst_ve_labeled_for_group =
            IF request.initial_volume_classification.volume_label_type = rmc$labeled_volume_type THEN
              CASE request.initial_volume_classification.labeled.volume_security_type OF
                = rmc$vst_ve_labeled_for_group =
                IF request.proposed_volume_classification.labeled.removable_media_group <> request.
                       initial_volume_classification.labeled.removable_media_group THEN
                  request.file_set_access^ := -$fst$file_access_options [fsc$modify, fsc$shorten];
                IFEND;
              ELSE
                IF request.proposed_volume_classification.labeled.user <> user (1,14) THEN
                  proposed_group := request.proposed_volume_classification.labeled.removable_media_group;
                  avp$get_removable_media_access (user, family, proposed_group, request.file_set_access^,
                         status);
                IFEND;
              CASEND;
            IFEND;
          = rmc$vst_ve_labeled_for_user =
            IF request.initial_volume_classification.volume_label_type = rmc$labeled_volume_type THEN
              CASE request.initial_volume_classification.labeled.volume_security_type OF
                = rmc$vst_ve_labeled_for_user =
                IF request.proposed_volume_classification.labeled.user <> request.
                       initial_volume_classification.labeled.user THEN
                  request.file_set_access^ := -$fst$file_access_options [fsc$modify, fsc$shorten];
                IFEND;
              ELSE
                IF request.proposed_volume_classification.labeled.user <> user (1,14) THEN
                  request.file_set_access^ := -$fst$file_access_options [fsc$modify, fsc$shorten];
                IFEND;
              CASEND;
            IFEND;
          ELSE
          CASEND;
        IFEND; {End of tape security enforcement}

        authorized_access := request.file_set_access^ * request.proposed_access;
        IF status.normal THEN
          IF request.proposed_access_defaulted THEN
            request.authorized_access^ := authorized_access;
          ELSE
            IF authorized_access = request.proposed_access THEN
              request.authorized_access^ := request.proposed_access;
            IFEND;
          IFEND;
          IF request.initial_volume_classification.labeled.blank THEN
            IF NOT ((fsc$append IN request.authorized_access^) OR (fsc$shorten IN request.
                  authorized_access^)) THEN
            osp$set_status_condition (ame$insufficient_volume_access, status);
            IFEND;
          ELSEIF NOT (fsc$shorten IN request.authorized_access^) THEN
            osp$set_status_condition (ame$insufficient_volume_access, status);
          IFEND;
        IFEND;
      IFEND; {End of status check on get_user_identification}
    ELSE {file unexpired}
      request.file_set_access^ := -$fst$file_access_options [fsc$modify, fsc$shorten];
      osp$set_status_condition (ame$ansi_file_unexpired, status);
    IFEND;
    IF NOT status.normal THEN
      CASE status.condition OF
      = ame$ansi_file_unexpired, ame$improper_security_change, ame$insufficient_volume_access =
        osp$append_status_file (osc$status_parameter_delimiter, file.path (1, file.file_path_size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.external_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn, status);
      ELSE
      CASEND;
      IF cause_for_dismount (status) THEN
        dismount_current_volume (file_identifier, layer_number, ignore_status);
      IFEND;
    IFEND;

  PROCEND authorize_file_set_reuse;
?? OLDTITLE ??
?? NEWTITLE := '    authorize_section_read ', EJECT ??
  PROCEDURE authorize_section_read
    (    file: fst$resolved_file_reference;
         file_identifier: amt$file_identifier;
         request: fst$ts_authorize_section_read;
         layer_number: amt$fap_layer_number;
         volume_descriptor: rmt$volume_descriptor;
     VAR status: ost$status);

{
{    This procedure is called when reading extends to another volume in the
{ volume set.  The following policies are enforced:
{
{ 1.  A damaged volume can only be accessed by an RMA.
{
{ 2.  The policies for a volume set labeled for a user or a group are more
{     stringent than for other types of volume sets.  This is because NOS/VE
{     ensures consistency of FILE_ACCESSIBILITY, OWNER_IDENTIFIER, and
{     VOLUME_ACCESSIBILITY from the first volume to the last in a volume set
{     labeled for a user or for a group.  If these values do not match, then it
{     is a certainty that the volume is not part of the volume set.
{
{ 3.  A labeled, external volume set or a password protected volume set may not
{     exhibit consistency of security fields among volumes in the volume set.
{     To safeguard the ability to read heterogeneous volume sets, only the
{     policies below are enforced.
{
{ 4.  For all volume sets, the following policies are enforced:
{
{     a.  The FILE_SET_IDENTIFIER of each volume must match that of the initial
{         volume.
{
{     b.  The FILE_SECTION_NUMBER and FILE_SEQUENCE_NUMBERS must be the
{         expected values.
{
{    REQUEST parameters:
{
{       enforce_tape_security (input):  Indicates whether or not tape security
{             is to be enforced.
{
{       current_header_labels (input):  Header label sequence read from the
{             beginning of the volume from which we are about to continue
{             reading.
{
{       current_volume_classification (input):  The classification of the
{             volume that has now been mounted.  This classification was made
{             by first calling rmp$classify_tape_volume.  If the volume is
{             classified as blank, another read is performed to determine if
{             there is any data in the first ansi file on the volume.  If a
{             tapemark is encountered, the blank classification is retained.
{
{       file_section_number (input):  This value is the anticipated file
{             section number of the volume from which we will continue reading.
{
{       file_sequence_number (input):  This value is the anticipated file
{             sequence number of the file from which we will continue reading.
{
{       initial_volume_classification (input):  This is the classification of
{             the initial volume of the volume set.  This classification
{             provides the security parameters (file_accessibiliy,
{             owner_identifier, and volume_accessibility) which must match all
{             subsequent volumes of the file set.
{
{       initial_volume_header_labels (input):  Header label sequence for the
{             first file of the file set.  This parameter is ignored but is
{             provided for the site that extends file security based on volume
{             header labels not normally analyzed by NOS/VE.
{
?? EJECT ??

    VAR
      authorized_access: fst$file_access_options,
      current_fa: string (1),
      current_file_section: 1 .. 9999,
      current_file_sequence: 1 .. 9999,
      current_file_set_identifier: string (6),
      current_va: string (1),
      hdr1_label: ^fst$ansi_hdr1_label,
      ignore_hdr2_label: ^fst$ansi_hdr2_label,
      ignore_status: ost$status,
      ignore_vol1_label: ^fst$ansi_vol1_label,
      initial_fa: string (1),
      initial_va: string (1);

    status.normal := TRUE;

    IF request.enforce_tape_security THEN
      current_fa := request.current_volume_classification.labeled.file_accessibility;
      current_va := request.current_volume_classification.labeled.volume_accessibility;
      initial_fa := request.initial_volume_classification.labeled.file_accessibility;
      initial_va := request.initial_volume_classification.labeled.volume_accessibility;
      CASE request.current_volume_classification.labeled.volume_security_type OF
      = rmc$vst_access_restricted =
        IF NOT avp$removable_media_admin () THEN
          osp$set_status_condition (ame$volume_access_restricted, status);
          osp$append_status_file (osc$status_parameter_delimiter, file.path (1, file.file_path_size), status);
          osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.external_vsn,
                status);
        IFEND;
      = rmc$vst_ve_labeled_for_group =
        IF file_accessibility_matches (current_fa, initial_fa) AND
              volume_accessibility_matches (current_va, initial_va) THEN
          IF NOT ((request.initial_volume_classification.labeled.volume_security_type =
                rmc$vst_ve_labeled_for_group) AND (request.current_volume_classification.labeled.
                removable_media_group = request.initial_volume_classification.labeled.removable_media_group))
                THEN
            osp$set_status_condition (ame$volume_security_conflict, status);
          IFEND;
        ELSE
          osp$set_status_condition (ame$volume_security_conflict, status);
        IFEND;
      = rmc$vst_ve_labeled_for_user =
        IF file_accessibility_matches (current_fa, initial_fa) AND
              volume_accessibility_matches (current_va, initial_va) THEN
          IF NOT ((request.initial_volume_classification.labeled.volume_security_type =
                rmc$vst_ve_labeled_for_user) AND (request.current_volume_classification.labeled.user =
                request.initial_volume_classification.labeled.user)) THEN
            osp$set_status_condition (ame$volume_security_conflict, status);
          IFEND;
        ELSE
          osp$set_status_condition (ame$volume_security_conflict, status);
        IFEND;
      = rmc$vst_labeled_external, rmc$vst_ve_password_protected =
      ELSE
      CASEND;
    IFEND;

    IF status.normal THEN
      locate_labels (request.current_header_labels, ignore_vol1_label, hdr1_label, ignore_hdr2_label);
      IF hdr1_label <> NIL THEN
        current_file_set_identifier := hdr1_label^.file_set_identifier;
        convert_number (hdr1_label^.file_section_number, current_file_section, status);
        IF status.normal THEN
          convert_number (hdr1_label^.file_sequence_number, current_file_sequence, status);
          IF status.normal THEN
            get_boolean_variable ('rmv$omit_strict_hdr1_checking', omit_strict_hdr1_checking);
            IF ((current_file_section <> request.file_section_number) OR
                  (current_file_sequence <> request.file_sequence_number)) AND
                  (NOT omit_strict_hdr1_checking) THEN
              osp$set_status_condition (ame$section_out_of_sequence, status);
            ELSE
              locate_labels (request.initial_volume_header_labels, ignore_vol1_label, hdr1_label,
                    ignore_hdr2_label);
              IF hdr1_label <> NIL THEN
                IF (current_file_set_identifier <> hdr1_label^.file_set_identifier) AND
                      (NOT omit_strict_hdr1_checking) THEN
                  osp$set_status_condition (ame$wrong_file_set_identifier, status);
                  osp$append_status_file (osc$status_parameter_delimiter,
                        file.path (1,file.file_path_size), status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        volume_descriptor.external_vsn, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        volume_descriptor.recorded_vsn, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        current_file_set_identifier, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                        hdr1_label^.file_set_identifier, status);
                IFEND;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      ELSE
        osp$set_status_condition (ame$volume_security_conflict, status);
      IFEND;
    IFEND;

    IF NOT status.normal THEN
      CASE status.condition OF
      = ame$volume_security_conflict =
        osp$append_status_file (osc$status_parameter_delimiter, file.path (1, file.file_path_size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.external_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn, status);
      = ame$section_out_of_sequence =
        osp$append_status_file (osc$status_parameter_delimiter, file.path (1, file.file_path_size), status);
        osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.external_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn, status);
        osp$append_status_integer (osc$status_parameter_delimiter, request.file_section_number, {radix} 10,
              {include_radix_specifier} FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, request.file_sequence_number, {radix} 10,
              {include_radix_specifier} FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, current_file_section, {radix} 10,
              {include_radix_specifier} FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter, current_file_sequence, {radix} 10,
              {include_radix_specifier} FALSE, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, hdr1_label^.file_set_identifier, status);
      ELSE
      CASEND;
      dismount_current_volume (file_identifier, layer_number, ignore_status);
    IFEND;
  PROCEND authorize_section_read;
?? OLDTITLE ??
?? NEWTITLE := '    authorize_section_write ', EJECT ??

  PROCEDURE authorize_section_write
    (    file: fst$file_reference;
         file_identifier: amt$file_identifier;
         request: fst$ts_authorize_section_write;
         layer_number: amt$fap_layer_number;
         volume_descriptor: rmt$volume_descriptor;
     VAR status: ost$status);

{
{    This procedure is called when writing extends to another volume in the
{ volume set.  The current labels on the volume are examined before the writing
{ of new labels is authorized; the following policies are enforced:
{
{ 1.  The security fields of the current header labels must be consistent with
{     respect to the file set that we are now writing.
{
{ 2.  If the current FILE_SECTION_NUMBER and FILE_SEQUENCE_NUMBER are both 1
{     (one) and the first ANSI file is not expired, access is not authorized.
{     This implies that the volume is the first volume of some other unexpired
{     file set.
{
{     REQUEST parameters:
{
{       enforce_tape_security (input):  Indicates whether or not tape security
{             is to be enforced.  Enforcement of the ANSI file's expiration
{             date is independent of the value of this parameter.
{
{       current_header_labels (input):  Header label sequence read from the
{             beginning of the volume on which we are about to write.
{
{       initial_volume_classification (input):  This is the classification of
{             the initial volume of the volume set.  The classification
{             determines the extent to which the security parameters
{             (file_accessibiliy, owner_identifier, and volume_accessibility)
{             may be changed as new labels are written.
{
{       initial_volume_header_labels (input):  Header label sequence for the
{             first file of the file set.  This parameter is not used, but is
{             provided in case the site has security extensions based upon the
{             other volume header labels not normally analyzed by NOS/VE.
{
?? EJECT ??

    VAR
      current_fa: string (1),
      current_va: string (1),
      current_volume_classification: rmt$tape_volume_classification,
      file_is_expired: boolean,
      hdr1_label: ^fst$ansi_hdr1_label,
      ignore_hdr2_label: ^fst$ansi_hdr2_label,
      ignore_read_labels_status: ost$status,
      ignore_status: ost$status,
      ignore_vol1_label: ^fst$ansi_vol1_label,
      initial_fa: string (1),
      initial_va: string (1);

    status.normal := TRUE;

    ignore_read_labels_status.normal := TRUE;
    rmp$classify_tape_volume (ignore_read_labels_status, request.current_header_labels,
          current_volume_classification, status);
    IF request.enforce_tape_security THEN
      IF status.normal THEN
        current_fa := current_volume_classification.labeled.file_accessibility;
        current_va := current_volume_classification.labeled.volume_accessibility;
        initial_fa := request.initial_volume_classification.labeled.file_accessibility;
        initial_va := request.initial_volume_classification.labeled.volume_accessibility;
        IF file_accessibility_matches (current_fa, initial_fa) AND volume_accessibility_matches (current_va,
            initial_va) THEN
          CASE current_volume_classification.labeled.volume_security_type OF
          = rmc$vst_access_restricted =
            IF NOT current_volume_classification.labeled.blank THEN
              osp$set_status_condition (ame$volume_security_conflict, status);
            IFEND;
          = rmc$vst_labeled_external =
            IF NOT current_volume_classification.labeled.blank THEN
              osp$set_status_condition (ame$volume_security_conflict, status);
            IFEND;
          = rmc$vst_ve_labeled_for_group =
            IF NOT ((request.initial_volume_classification.labeled.volume_security_type =
                  rmc$vst_ve_labeled_for_group) AND owner_identifier_matches
                  (current_volume_classification.labeled.removable_media_group,
                  request.initial_volume_classification.labeled.removable_media_group)) THEN
              osp$set_status_condition (ame$volume_security_conflict, status);
            IFEND;
          = rmc$vst_ve_labeled_for_user =
            IF NOT ((request.initial_volume_classification.labeled.volume_security_type =
                  rmc$vst_ve_labeled_for_user) AND owner_identifier_matches
                  (current_volume_classification.labeled.user, request.initial_volume_classification.labeled.
                  user)) THEN
              osp$set_status_condition (ame$volume_security_conflict, status);
            IFEND;
          = rmc$vst_ve_password_protected =
            IF NOT current_volume_classification.labeled.blank THEN
              IF NOT (request.initial_volume_classification.labeled.volume_security_type =
                    rmc$vst_labeled_external) THEN
                IF NOT owner_identifier_matches (current_volume_classification.labeled.ve_owner_identifier,
                      request.initial_volume_classification.labeled.ve_owner_identifier) THEN
                  osp$set_status_condition (ame$volume_security_conflict, status);
                IFEND;
              IFEND;
            IFEND;
          ELSE
          CASEND;
        ELSE
          osp$set_status_condition (ame$volume_security_conflict, status);
        IFEND;
      IFEND;
    IFEND;
    IF status.normal THEN
      IF NOT current_volume_classification.labeled.blank THEN
        locate_labels (request.current_header_labels, ignore_vol1_label, hdr1_label, ignore_hdr2_label);
        IF hdr1_label <> NIL THEN
          IF (hdr1_label^.file_sequence_number = '0001') AND (hdr1_label^.file_section_number = '0001') AND
                (NOT current_volume_classification.labeled.expired) THEN
            osp$set_status_condition (ame$initial_volume_unexpired, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
    IF NOT status.normal THEN
      CASE status.condition OF
      = ame$initial_volume_unexpired, ame$volume_security_conflict =
        osp$append_status_file (osc$status_parameter_delimiter, file, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.external_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, volume_descriptor.recorded_vsn, status);
      ELSE
      CASEND;
      dismount_current_volume (file_identifier, layer_number, ignore_status);
    IFEND;

  PROCEND authorize_section_write;
?? OLDTITLE ??
?? NEWTITLE := '    authorize_volume_reuse ', EJECT ??

  PROCEDURE authorize_volume_reuse
    (    file: fst$file_reference;
         file_identifier: amt$file_identifier;
         request: fst$ts_authorize_volume_reuse;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

{
{    This procedure authorizes the attempt by an RMO to initialize a volume.
{ If the site authorizes the volume reuse, this procedure then proceeds to
{ write the blank label group to the volume.
{
{    The validation performed below is redundant, if the RMO uses system
{ commands to initialize a volume.  However, if a site writes its own volume
{ intialization program using FSP$OPEN_FILE, this check ensures that the user
{ of the program has sufficient privilege to reuse the volume.
{
{    If the volume is to become unlabeled, three tapemarks are written.
{
{    If the volume is to become labeled, the PROPOSED_BLANK_LABELS sequence
{ will contain some form of ANSI label sequence.  Options externalized by
{ NOS/VE include one of the following:
{
{  1.  VOL1 * * (ANSI option)
{
{  2.  VOL1 HDR1 HDR2 * * EOF1 EOF2 * * * (CDC_VERSION_ONE or CDC_VERSION_TWO)
{
{  3.  An arbitrary list of strings provided by the command user
{
{      Request Parameters:
{
{       current_header_labels (input) :  Header label sequence read from the
{             volume to be initialized.  This is NIL for an unlabeled volume or
{             a volume with a read error at loadpoint.  This parameter is
{             ignored but is provided to allow a site to do more extensive
{             validation of the existing label group prior to reusing the
{             volume.
{
{       enforce_tape_security (input) :  The policy for reusing a volume is
{             independent of whether or not tape security is in effect.
{             However, the boolean is provided to allow the site to augment
{             this policy dependent upon the value of the boolean.
{
{       proposed_file_label_type (input) :  Identifies the intent of the RMO to
{             create a blank labeled (amc$labeled) or unlabeled (amc$unlabeled)
{             volume.  This parameter is ignored but is provided to enable the
{             site to disallow the creation of an unlabeled volume by an RMO,
{             if this is considered desirable.
{
{       proposed_blank_labels (input) :  This field contains the image of the
{             blank label group to be written to the reused volume.
?? EJECT ??

    VAR
      ignore_status: ost$status,
      local_call_block: amt$call_block;

    status.normal := TRUE;
    IF avp$removable_media_operator () THEN
      local_call_block.operation := amc$write_tape_labels;
      local_call_block.write_tape_labels := request.proposed_blank_labels;
      amp$access_method (file_identifier, local_call_block, layer_number, status);
    ELSE
      osp$set_status_condition (ame$rmo_privilege_required, status);
      osp$append_status_file (osc$status_parameter_delimiter, file, status);
      dismount_current_volume (file_identifier, layer_number, ignore_status);
    IFEND;

  PROCEND authorize_volume_reuse;
?? OLDTITLE ??
?? NEWTITLE := '    cause_for_dismount', EJECT ??

  FUNCTION [INLINE] cause_for_dismount
    (    status: ost$status): boolean;

{ This function identifies certain exception conditions as irrelevant.
{ These conditions are considered irrelevant ONLY when they are detected after the
{ file set is successfully mounted and before the target ANSI file is found during
{ a search of the volume set.

    IF status.normal THEN
      cause_for_dismount := FALSE;
    ELSE
      CASE status.condition OF
      = ame$ansi_file_unexpired, ame$insufficient_file_access =
        cause_for_dismount := FALSE;
      ELSE
        cause_for_dismount := TRUE;
      CASEND;
    IFEND;

  FUNCEND cause_for_dismount;

?? OLDTITLE ??
?? NEWTITLE := '    convert_number ', EJECT ??

  PROCEDURE convert_number
    (    str: string (4);
     VAR value: 1 .. 9999;
     VAR status: ost$status);

    VAR
      int: clt$integer;

    status.normal := TRUE;
    IF str = ' ' THEN
      osp$set_status_condition (ame$section_out_of_sequence, status);
    ELSE
      clp$convert_string_to_integer (str, int, status);
      IF status.normal THEN
        value := int.value;
      ELSE
        osp$set_status_condition (ame$section_out_of_sequence, status);
      IFEND;
    IFEND;

  PROCEND convert_number;
?? OLDTITLE ??
?? NEWTITLE := '    date_is_valid ', EJECT ??

  FUNCTION [UNSAFE] date_is_valid
    (    date: string ( * )): boolean;

    VAR
      date_time: clt$date_time,
      date_string: string (7),
      local_status: ost$status;

{
{ The date field is xYYOOO, where x is [' ' or digit], and YYOOO is Julian Date.

    IF (date = ' ') OR (date = ' 00000') OR (date = '000000') THEN
      date_is_valid := TRUE; {Allow date field to be SPACE or expired}
    ELSE
      IF date (1, 1) = ' ' THEN
        date_string (1, 2) := '19';
        date_string (3, 5) := date (2, 5);
      ELSE
        date_string (1, 1):= '2';
        date_string (2, 6) := date (1, 6);
      IFEND;
      clp$convert_string_to_date_time (date_string, 'Y4J3', date_time, local_status);
      date_is_valid := local_status.normal;
    IFEND;

  FUNCEND date_is_valid;
?? OLDTITLE ??
?? NEWTITLE := '    dismount_current_volume ', EJECT ??

  PROCEDURE dismount_current_volume
    (    file_identifier: amt$file_identifier;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      local_call_block: amt$call_block;

    status.normal := TRUE;

    local_call_block.operation := amc$dismount_current_volume;
    amp$access_method (file_identifier, local_call_block, layer_number, status);

  PROCEND dismount_current_volume;
?? OLDTITLE ??
?? NEWTITLE := '    enforce_epix_security', EJECT ??

  PROCEDURE enforce_epix_security
    (    file_accessibility: string (1);
         implementation_identifier: string (13);
         user_is_owner: boolean;
         volume_accessibility: string (1);
     VAR authorized_access {input,output} : fst$file_access_options;
     VAR epix_tape: boolean;
     VAR file_set_access {input,output} : fst$file_access_options);

{Design:
{
{    VA:                        FILE_SET_ACCESS
{    ---------------------------------------
{    blank                      (READ, WRITE)
{      0     (owner access)     (READ, WRITE)
{      0     (nonowner access)  ()
{      1                        (WRITE)
{      2                        (READ)
{
{
{    FA:            AUTHORIZED_ACCESS
{    ---------------------------------------
{    blank          (READ, WRITE)
{      0            (READ, WRITE)   (will be ignored, access controlled by VA)
{      1            (WRITE)
{      2            (READ)

    IF implementation_identifier = epix_version_one THEN
      epix_tape := TRUE;
      IF volume_accessibility = ' ' THEN
        file_set_access := file_set_access * (-$fst$file_access_options []);
      ELSEIF volume_accessibility = '0' THEN
        IF user_is_owner THEN
          file_set_access := file_set_access * (-$fst$file_access_options []);
        ELSE
          file_set_access := file_set_access * $fst$file_access_options [];
        IFEND;
      ELSEIF volume_accessibility = '1' THEN
        file_set_access := file_set_access * $fst$file_access_options [fsc$append, fsc$modify, fsc$shorten];
      ELSEIF volume_accessibility = '2' THEN
        file_set_access := file_set_access * $fst$file_access_options [fsc$execute, fsc$read];
      IFEND;

      IF file_accessibility = ' ' THEN
        authorized_access := authorized_access * (-$fst$file_access_options []);
      ELSEIF file_accessibility = '0' THEN
        authorized_access := authorized_access * (-$fst$file_access_options []);
      ELSEIF file_accessibility = '1' THEN
        authorized_access := authorized_access * $fst$file_access_options [fsc$append, fsc$modify,
              fsc$shorten];
      ELSEIF file_accessibility = '2' THEN
        authorized_access := authorized_access * $fst$file_access_options [fsc$execute, fsc$read];
      IFEND;
    ELSE
      epix_tape := FALSE;
      {File_set_access and authorized_access are not changed
    IFEND;
  PROCEND enforce_epix_security;
?? OLDTITLE ??
?? NEWTITLE := '    get_explicit_attributes', EJECT ??

  PROCEDURE get_explicit_attributes
    (    file: fst$resolved_file_reference;
     VAR explicit_fa: string (1);
     VAR explicit_group: string (13);
     VAR explicit_oi: string (14);
     VAR explicit_va: string (1);
     VAR returned_attributes: fst$tla_returned_attributes;
     VAR status: ost$status);

    CONST
      fa = 1,
      oi = 2,
      rmg = 3,
      va = 4;

    VAR
      explicit_attrib: ^array [fa .. va] of fst$attachment_option,
      local_status: ost$status;

    PUSH explicit_attrib;

    explicit_attrib^ [fa].selector := fsc$tape_attachment;
    explicit_attrib^ [fa].tape_attachment.selector := fsc$tape_file_accessibility;
    explicit_attrib^ [oi].selector := fsc$tape_attachment;
    explicit_attrib^ [oi].tape_attachment.selector := fsc$tape_owner_identification;
    explicit_attrib^ [rmg].selector := fsc$tape_attachment;
    explicit_attrib^ [rmg].tape_attachment.selector := fsc$tape_removable_media_group;
    explicit_attrib^ [va].selector := fsc$tape_attachment;
    explicit_attrib^ [va].tape_attachment.selector := fsc$tape_volume_accessibility;
    fsp$get_tape_label_attributes (file.path (1, file.file_path_size), fsc$tla_explicit_specification,
          explicit_attrib^, returned_attributes, local_status);
    IF local_status.normal THEN
      explicit_fa := explicit_attrib^ [fa].tape_attachment.tape_file_accessibility;
      explicit_group := explicit_attrib^ [rmg].tape_attachment.tape_removable_media_group;
      explicit_oi := explicit_attrib^ [oi].tape_attachment.tape_owner_identification;
      explicit_va := explicit_attrib^ [va].tape_attachment.tape_volume_accessibility;
    IFEND;
  PROCEND get_explicit_attributes;
?? OLDTITLE ??
?? NEWTITLE := '    field_is_numeric ', EJECT ??

  FUNCTION field_is_numeric
    (    field: string ( * )): boolean;

    VAR
      numeric_characters: [STATIC, READ, oss$job_paged_literal] set of char := ['0', '1', '2', '3', '4', '5',
            '6', '7', '8', '9'];

    VAR
      i: integer;

    field_is_numeric := TRUE;
    IF field = ' ' THEN
      RETURN; {Allow numeric field to be SPACE; the volume may be blank labeled}
    IFEND;
    FOR i := 1 TO STRLENGTH (field) DO
      IF NOT (field (i, 1) IN numeric_characters) THEN
        field_is_numeric := FALSE;
        RETURN;
      IFEND;
    FOREND;
  FUNCEND field_is_numeric;
?? OLDTITLE ??
?? NEWTITLE := '    file_accessibility_matches', EJECT ??

  FUNCTION [INLINE] file_accessibility_matches
    (    existing_fa: string (1);
         requested_fa: string (1)): boolean;

    IF existing_fa = requested_fa THEN
      file_accessibility_matches := TRUE;
    ELSEIF existing_fa = ' ' THEN
      file_accessibility_matches := TRUE;
    ELSE
      file_accessibility_matches := FALSE;
    IFEND;

  FUNCEND file_accessibility_matches;
?? OLDTITLE ??
?? NEWTITLE := '    get_boolean_variable', EJECT ??

  PROCEDURE get_boolean_variable
    (    variable: string ( * );
     VAR boolean_value: boolean);

    VAR
      ignore_access_mode: clt$data_access_mode,
      ignore_class: clt$variable_class,
      ignore_evaluation_method: clt$expression_eval_method,
      ignore_type_specification_p: ^clt$type_specification,
      local_status: ost$status,
      value_p: ^clt$data_value,
      work_area_p: ^SEQ ( * );

    local_status.normal := TRUE;

    boolean_value := FALSE;
    PUSH work_area_p: [[REP 1000 OF cell]];
    clp$get_variable (variable, work_area_p, ignore_class, ignore_access_mode, ignore_evaluation_method,
          ignore_type_specification_p, value_p, local_status);
    IF local_status.normal THEN
      IF value_p^.kind = clc$boolean THEN
        boolean_value := value_p^.boolean_value.value;
      IFEND;
    IFEND;

  PROCEND get_boolean_variable;
?? OLDTITLE ??
?? NEWTITLE := '    get_login_identification', EJECT ??

  PROCEDURE get_login_identification
    (VAR account: avt$account_name;
     VAR family: ost$family_name;
     VAR project: avt$project_name;
     VAR user: ost$user_name;
     VAR status: ost$status);

    VAR
      identification: ost$user_identification;

    account := osc$null_name;
    family := osc$null_name;
    project := osc$null_name;
    user := osc$null_name;

    pmp$get_user_identification (identification, status);
    IF status.normal THEN
      family := identification.family;
      user := identification.user;
      pmp$get_account_project (account, project, status);
    IFEND;

  PROCEND get_login_identification;
?? OLDTITLE ??
?? NEWTITLE := '    get_user_identification', EJECT ??

  PROCEDURE get_user_identification
    (    file: fst$resolved_file_reference;
     VAR family: ost$family_name;
     VAR user: ost$user_name;
     VAR status: ost$status);

{Design: If a reference to a volume is made through a temporary file, the
{relevant family/user is the login-user; otherwise, it is the family/user of the
{permanent file path.

    VAR
      identification: ost$user_identification;

    IF file.permanent_file THEN
      family := file.path (file.family_name.index, file.family_name.size);
      user := file.path (file.master_catalog_name.index, file.master_catalog_name.size);
    ELSE
      pmp$get_user_identification (identification, status);
      family := identification.family;
      user := identification.user;
    IFEND;

  PROCEND get_user_identification;
?? OLDTITLE ??
?? NEWTITLE := '    log_ansi_label', EJECT ??

  PROCEDURE log_ansi_label
    (    condition: ost$status_condition_code;
         file: fst$file_reference;
         label: string ( * ));

    VAR
      ignore_status: ost$status,
      logset: pmt$ascii_logset,
      log_message_status: ost$status;

    IF log_labels THEN
      osp$set_status_condition (condition, log_message_status);
      osp$append_status_file (osc$status_parameter_delimiter, file, log_message_status);
      osp$append_status_parameter (osc$status_parameter_delimiter, label, log_message_status);
      logset := $pmt$ascii_logset [pmc$job_log];
      osp$generate_log_message (logset, log_message_status, ignore_status);
    IFEND;
  PROCEND log_ansi_label;
?? OLDTITLE ??
?? NEWTITLE := '    log_erroneous_block', EJECT ??

  PROCEDURE log_erroneous_block
    (    file: fst$file_reference;
         locator: fst$tape_label_locator);

    VAR
      error_block: ^string ( * ),
      ignore_status: ost$status,
      length: integer,
      logset: pmt$ascii_logset,
      log_message_status: ost$status,
      sequence: ^SEQ ( * );

    osp$set_status_condition (ame$log_error_block, log_message_status);

    osp$append_status_file (osc$status_parameter_delimiter, file, log_message_status);

    IF locator.label_block_descriptor^.erroneous_label_transfer_length < 80 THEN
      length := locator.label_block_descriptor^.erroneous_label_transfer_length;
    ELSE
      length := 80;
    IFEND;

    IF (length > 0) AND (locator.label_block <> NIL) THEN
      sequence := locator.label_block;
      RESET sequence;
      NEXT error_block: [length] IN sequence;
      IF error_block <> NIL THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, error_block^ (1, length),
              log_message_status);
      ELSE
        osp$append_status_parameter (osc$status_parameter_delimiter, ' ** No Data Read **' ,
              log_message_status);
      IFEND;
    ELSE
      osp$append_status_parameter (osc$status_parameter_delimiter, ' ** No Data Read **' ,
            log_message_status);
    IFEND;

    logset := $pmt$ascii_logset [pmc$job_log];
    osp$generate_log_message (logset, log_message_status, ignore_status);

  PROCEND log_erroneous_block;
?? OLDTITLE ??
?? NEWTITLE := '    log_non_label_block', EJECT ??

  PROCEDURE log_non_label_block
    (    file: fst$file_reference;
         locator: fst$tape_label_locator);

    VAR
      ignore_status: ost$status,
      length: integer,
      logset: pmt$ascii_logset,
      log_message_status: ost$status,
      non_label_block: ^string ( * ),
      sequence: ^SEQ ( * );

    osp$set_status_condition (ame$log_non_label_block, log_message_status);

    osp$append_status_file (osc$status_parameter_delimiter, file, log_message_status);

    IF locator.label_block_descriptor^.non_label_transfer_length < 80 THEN
      length := locator.label_block_descriptor^.non_label_transfer_length;
    ELSE
      length := 80;
    IFEND;

    IF (length > 0) AND (locator.label_block <> NIL) THEN
      sequence := locator.label_block;
      RESET sequence;
      NEXT non_label_block: [length] IN sequence;
      IF non_label_block <> NIL THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, non_label_block^ (1, length),
              log_message_status);
      ELSE
        osp$append_status_parameter (osc$status_parameter_delimiter, ' ** No Data Read **' ,
              log_message_status);
      IFEND;
    ELSE
      osp$append_status_parameter (osc$status_parameter_delimiter, ' ** No Data Read **' ,
            log_message_status);
    IFEND;

    logset := $pmt$ascii_logset [pmc$job_log];
    osp$generate_log_message (logset, log_message_status, ignore_status);

  PROCEND log_non_label_block;
?? OLDTITLE ??
?? NEWTITLE := '    log_improper_block_count', EJECT ??

  PROCEDURE log_improper_block_count
    (    field_name: string ( * );
         file: fst$file_reference;
         label_name: string ( * );
         original_field_value: string ( * );
         new_field_value: string ( * ));

    VAR
      ignore_status: ost$status,
      logset: pmt$ascii_logset,
      log_message_status: ost$status;

    osp$set_status_condition (ame$improper_block_count, log_message_status);
    osp$append_status_file (osc$status_parameter_delimiter, file, log_message_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, field_name, log_message_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, label_name, log_message_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, original_field_value, log_message_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, new_field_value, log_message_status);
    logset := $pmt$ascii_logset [pmc$job_log];
    osp$generate_log_message (logset, log_message_status, ignore_status);

  PROCEND log_improper_block_count;
?? OLDTITLE ??
?? NEWTITLE := '    log_improper_label_field', EJECT ??

  PROCEDURE log_improper_label_field
    (    field_name: string ( * );
         file: fst$file_reference;
         label_name: string ( * );
         original_field_value: string ( * ));

    VAR
      ignore_status: ost$status,
      logset: pmt$ascii_logset,
      log_message_status: ost$status;

    osp$set_status_condition (ame$improper_label_field, log_message_status);
    osp$append_status_file (osc$status_parameter_delimiter, file, log_message_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, field_name, log_message_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, label_name, log_message_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, original_field_value, log_message_status);
    logset := $pmt$ascii_logset [pmc$job_log];
    osp$generate_log_message (logset, log_message_status, ignore_status);

  PROCEND log_improper_label_field;
?? OLDTITLE ??
?? NEWTITLE := '    log_invalid_date_field', EJECT ??

  PROCEDURE log_invalid_date_field
    (    field_name: string ( * );
         file: fst$file_reference;
         label_name: string ( * );
         original_field_value: string ( * ));

    VAR
      ignore_status: ost$status,
      logset: pmt$ascii_logset,
      log_message_status: ost$status;

    osp$set_status_condition (ame$invalid_date_field, log_message_status);
    osp$append_status_file (osc$status_parameter_delimiter, file, log_message_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, field_name, log_message_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, label_name, log_message_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, original_field_value, log_message_status);
    IF field_name (16) = 'C' THEN { Creation Date }
      osp$append_status_parameter (osc$status_parameter_delimiter, 'CREATION_DATE', log_message_status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'SPACE', log_message_status);
    ELSE { Expiration Date }
      osp$append_status_parameter (osc$status_parameter_delimiter, 'EXPIRATION_DATE', log_message_status);
      osp$append_status_parameter (osc$status_parameter_delimiter, ''' 00000'' (expired)',
            log_message_status);
    IFEND;
    logset := $pmt$ascii_logset [pmc$job_log];
    osp$generate_log_message (logset, log_message_status, ignore_status);

  PROCEND log_invalid_date_field;
?? OLDTITLE ??
?? NEWTITLE := '    log_nonnumeric_label_field', EJECT ??

  PROCEDURE log_nonnumeric_label_field
    (    field_name: string ( * );
         file: fst$file_reference;
         label_name: string ( * );
         original_field_value: string ( * ));

    VAR
      ignore_status: ost$status,
      logset: pmt$ascii_logset,
      log_message_status: ost$status;

    osp$set_status_condition (ame$label_field_not_numeric, log_message_status);
    osp$append_status_file (osc$status_parameter_delimiter, file, log_message_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, field_name, log_message_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, label_name, log_message_status);
    osp$append_status_parameter (osc$status_parameter_delimiter, original_field_value, log_message_status);
    logset := $pmt$ascii_logset [pmc$job_log];
    osp$generate_log_message (logset, log_message_status, ignore_status);

  PROCEND log_nonnumeric_label_field;
?? OLDTITLE ??
?? NEWTITLE := '    owner_identifier_matches', EJECT ??

  FUNCTION [INLINE] owner_identifier_matches
    (    existing_oi: string ( * );
         requested_oi: string ( * )): boolean;

    IF existing_oi = requested_oi THEN
      owner_identifier_matches := TRUE;
    ELSEIF existing_oi = ' ' THEN
      owner_identifier_matches := TRUE;
    ELSE
      owner_identifier_matches := FALSE;
    IFEND;

  FUNCEND owner_identifier_matches;
?? OLDTITLE ??
?? NEWTITLE := '    secure_header_labels ', EJECT ??

  PROCEDURE secure_header_labels
    (    file: fst$file_reference;
         file_identifier: amt$file_identifier;
         request: fst$ts_secure_header_labels;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      hdr1_label: ^fst$ansi_hdr1_label,
      header_labels: ^SEQ ( * ),
      label_identifier: fst$tape_label_identifier,
      label_locator: fst$tape_label_locator,
      label_string: ^string (80),
      vol1_label: ^fst$ansi_vol1_label;

    status.normal := TRUE;
    header_labels := request.header_labels;
    RESET header_labels;

    label_identifier.location_method := fsc$tape_label_locate_by_index;
    label_identifier.label_index := 1;
    REPEAT
      fsp$locate_tape_label (header_labels, label_identifier, label_locator);
      IF label_locator.label_found THEN
        CASE label_locator.label_block_descriptor^.label_block_type OF
        = fsc$erroneous_tape_label_block =
          log_erroneous_block (file, label_locator);
        = fsc$non_tape_label_block =
          log_non_label_block (file, label_locator);
        = fsc$normal_tape_label_block =
          RESET label_locator.label_block;
          NEXT label_string IN label_locator.label_block;
          CASE label_locator.label_block_descriptor^.normal_label_kind OF
          = fsc$ansi_vol1_label_kind =
            RESET label_locator.label_block;
            NEXT vol1_label IN label_locator.label_block;
            IF vol1_label <> NIL THEN
              IF avp$removable_media_admin () THEN
                log_ansi_label (ame$log_vol1_label, file, label_string^ (1, 80));
                vol1_label^.owner_identifier := ' ';
                vol1_label^.accessibility := ' ';
              ELSE
                vol1_label^.owner_identifier := ' ';
                vol1_label^.accessibility := ' ';
                log_ansi_label (ame$log_vol1_label, file, label_string^ (1, 80));
              IFEND;
            IFEND;
          = fsc$ansi_hdr1_label_kind =
            RESET label_locator.label_block;
            NEXT hdr1_label IN label_locator.label_block;
            IF hdr1_label <> NIL THEN
              IF avp$removable_media_admin () THEN
                log_ansi_label (ame$log_ansi1_label, file, label_string^ (1, 80));
                hdr1_label^.accessibility := ' ';
              ELSE
                hdr1_label^.accessibility := ' ';
                log_ansi_label (ame$log_ansi1_label, file, label_string^ (1, 80));
              IFEND;
            IFEND;
          = fsc$ansi_hdr2_label_kind =
            log_ansi_label (ame$log_ansi2_label, file, label_string^ (1, 80));
          ELSE
            log_ansi_label (ame$log_ansix_label, file, label_string^ (1, 80));
          CASEND;
        ELSE
        CASEND;
        label_identifier.label_index := label_identifier.label_index + 1;
      IFEND;
    UNTIL NOT label_locator.label_found;
  PROCEND secure_header_labels;
?? OLDTITLE ??
?? NEWTITLE := '    secure_trailer_labels ', EJECT ??

  PROCEDURE secure_trailer_labels
    (    file: fst$file_reference;
         file_identifier: amt$file_identifier;
         request: fst$ts_secure_trailer_labels;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      eof1_label: ^fst$ansi_eof1_label,
      label_identifier: fst$tape_label_identifier,
      label_locator: fst$tape_label_locator,
      label_string: ^string (80),
      trailer_labels: ^SEQ ( * );

    status.normal := TRUE;
    trailer_labels := request.trailer_labels;
    RESET trailer_labels;

    label_identifier.location_method := fsc$tape_label_locate_by_index;
    label_identifier.label_index := 1;
    REPEAT
      fsp$locate_tape_label (trailer_labels, label_identifier, label_locator);
      IF label_locator.label_found THEN
        CASE label_locator.label_block_descriptor^.label_block_type OF
        = fsc$erroneous_tape_label_block =
          log_erroneous_block (file, label_locator);
        = fsc$non_tape_label_block =
          log_non_label_block (file, label_locator);
        = fsc$normal_tape_label_block =
          RESET label_locator.label_block;
          NEXT label_string IN label_locator.label_block;
          CASE label_locator.label_block_descriptor^.normal_label_kind OF
          = fsc$ansi_eof1_label_kind, fsc$ansi_eov1_label_kind =
            RESET label_locator.label_block;
            NEXT eof1_label IN label_locator.label_block;
            IF eof1_label <> NIL THEN
              IF avp$removable_media_admin () THEN
                log_ansi_label (ame$log_ansi1_label, file, label_string^ (1, 80));
                eof1_label^.accessibility := ' ';
              ELSE
                eof1_label^.accessibility := ' ';
                log_ansi_label (ame$log_ansi1_label, file, label_string^ (1, 80));
              IFEND;
            IFEND;
          = fsc$ansi_eof2_label_kind, fsc$ansi_eov2_label_kind =
            log_ansi_label (ame$log_ansi2_label, file, label_string^ (1, 80));
          ELSE
            log_ansi_label (ame$log_ansix_label, file, label_string^ (1, 80));
          CASEND;
        ELSE
        CASEND;
        label_identifier.label_index := label_identifier.label_index + 1;
      IFEND;
    UNTIL NOT label_locator.label_found;

  PROCEND secure_trailer_labels;
?? OLDTITLE ??
?? NEWTITLE := '    validate_eox1_label ', EJECT ??

  PROCEDURE validate_eox1_label
    (    file: fst$file_reference;
         file_identifier: amt$file_identifier;
         layer_number: amt$fap_layer_number;
     VAR eox1: fst$ansi_eof1_label;
     VAR status: ost$status);

{Design:
{Each numeric field in the EOF1 or EOV1 label is validated to be a number or SPACE.  Each
{a-character (i.e. text) field that contains control information is validated to
{contain a legal value, including SPACE.  Any invalid field is set to SPACE.  This
{allows the field to be under control of the NOS/VE user through specification of
{file attributes.}
?? EJECT ??
    status.normal := TRUE;
    IF NOT (field_is_numeric (eox1.file_section_number)) THEN
      log_nonnumeric_label_field ('Bytes 28..31 - File Section Number', file, eox1.label_identifier,
            eox1.file_section_number);
      eox1.file_section_number := ' ';
    IFEND;
    IF NOT (field_is_numeric (eox1.file_sequence_number)) THEN
      log_nonnumeric_label_field ('Bytes 32..35 - File Sequence Number', file, eox1.label_identifier,
            eox1.file_sequence_number);
      eox1.file_sequence_number := ' ';
    IFEND;
    IF NOT (field_is_numeric (eox1.generation_number)) THEN
      log_nonnumeric_label_field ('Bytes 36..39 - Generation Number', file, eox1.label_identifier,
            eox1.generation_number);
      eox1.generation_number := ' ';
    IFEND;
    IF NOT (field_is_numeric (eox1.generation_version_number)) THEN
      log_nonnumeric_label_field ('Bytes 40..41 - Generation Version Number', file, eox1.label_identifier,
            eox1.generation_version_number);
      eox1.generation_version_number := ' ';
    IFEND;
    IF NOT (date_is_valid (eox1.creation_date)) THEN
      log_invalid_date_field ('Bytes 42..47 - Creation Date', file, eox1.label_identifier,
            eox1.creation_date);
      eox1.creation_date := ' ';
    IFEND;
    IF NOT (date_is_valid (eox1.expiration_date)) THEN
      log_invalid_date_field ('Bytes 48..53 - Expiration Date', file, eox1.label_identifier,
            eox1.expiration_date);
      eox1.expiration_date := ' 00000';
    IFEND;
    IF NOT (field_is_numeric (eox1.block_count)) THEN
      log_nonnumeric_label_field ('Bytes 55..60 - Block Count', file, eox1.label_identifier,
            eox1.block_count);
      eox1.block_count := ' ';
    IFEND;

  PROCEND validate_eox1_label;
?? OLDTITLE ??
?? NEWTITLE := '    validate_eox2_label ', EJECT ??

  PROCEDURE validate_eox2_label
    (    eox1: fst$ansi_eof1_label;
         file: fst$file_reference;
         file_identifier: amt$file_identifier;
         layer_number: amt$fap_layer_number;
     VAR eox2 {input,output} : fst$ansi_eof2_label;
     VAR status: ost$status);

{Design:
{Each numeric field in the EOF1 or EOV1 label is validated to be a number or SPACE.  Each
{a-character (i.e. text) field that contains control information is validated to
{contain a legal value, including SPACE.  Any invalid field is set to SPACE.  This
{allows the field to be under control of the NOS/VE user through specification of
{file attributes.}
?? EJECT ??
    status.normal := TRUE;
    IF NOT (eox2.record_format IN ve_record_types) THEN
      log_improper_label_field ('Byte 5 - Record Format', file, eox2.label_identifier, eox2.record_format);
      eox2.record_format := ' ';
    IFEND;
    IF NOT (field_is_numeric (eox2.block_length)) THEN
      log_nonnumeric_label_field ('Bytes 6..10 - Block Length', file, eox2.label_identifier,
            eox2.block_length);
      eox2.block_length := ' ';
    IFEND;
    IF NOT (field_is_numeric (eox2.record_length)) THEN
      log_nonnumeric_label_field ('Bytes 11..15 - Record Length', file, eox2.label_identifier,
            eox2.record_length);
      eox2.record_length := ' ';
    IFEND;
    IF fsp$ve_wrote_ansi_file (eox1.system_code) THEN
      IF NOT ((eox2.ve_block_type = ' ') OR (eox2.ve_block_type = 'SS') OR (eox2.ve_block_type = 'US')) THEN
        log_improper_label_field ('Bytes 16..17 - NOS/VE block_type', file, eox2.label_identifier,
              eox2.ve_block_type);
        eox2.ve_block_type := ' ';
      IFEND;
      IF NOT (eox2.ve_record_type IN ve_record_types) THEN
        log_improper_label_field ('Byte 18 - NOS/VE record_type', file, eox2.label_identifier,
              eox2.ve_record_type);
        eox2.ve_record_type := ' ';
      IFEND;
      IF NOT (field_is_numeric (eox2.ve_block_length_ext)) THEN
        log_nonnumeric_label_field ('Bytes 19..21 - NOS/VE block_length_extension', file,
              eox2.label_identifier, eox2.ve_block_length_ext);
        eox2.ve_block_length_ext := ' ';
      IFEND;
      IF NOT (field_is_numeric (eox2.ve_record_length_ext)) THEN
        log_nonnumeric_label_field ('Bytes 22..24 - NOS/VE record_length_extension', file,
              eox2.label_identifier, eox2.ve_record_length_ext);
        eox2.ve_record_length_ext := ' ';
      IFEND;
      IF NOT (eox2.ve_character_set IN ve_character_sets) THEN
        log_improper_label_field ('Byte 26 - NOS/VE character_set', file, eox2.label_identifier,
              eox2.ve_character_set);
        eox2.ve_character_set := ' ';
      IFEND;
      IF NOT (eox2.ve_character_conversion IN ve_character_conversions) THEN
        log_improper_label_field ('Byte 27 - NOS/VE character_conversion', file, eox2.label_identifier,
              eox2.ve_character_conversion);
        eox2.ve_character_conversion := ' ';
      IFEND;
    IFEND;
    IF NOT (field_is_numeric (eox2.buffer_offset_length)) THEN
      log_nonnumeric_label_field ('Bytes 51..52 - Offset Length', file, eox2.label_identifier,
            eox2.buffer_offset_length);
      eox2.buffer_offset_length := ' ';
    IFEND;

  PROCEND validate_eox2_label;
?? OLDTITLE ??
?? NEWTITLE := '    validate_header_labels ', EJECT ??

  PROCEDURE validate_header_labels
    (    file: fst$file_reference;
         file_identifier: amt$file_identifier;
         request: fst$ts_validate_header_labels;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      hdr1_label: ^fst$ansi_hdr1_label,
      hdr2_label: ^fst$ansi_hdr2_label,
      header_labels: ^SEQ ( * ),
      label_identifier: fst$tape_label_identifier,
      label_locator: fst$tape_label_locator,
      vol1_label: ^fst$ansi_vol1_label;

    status.normal := TRUE;
    hdr1_label := NIL;
    hdr2_label := NIL;
    vol1_label := NIL;

    header_labels := request.header_labels;
    RESET header_labels;
    label_identifier.location_method := fsc$tape_label_locate_by_kind;
    label_identifier.label_kind := fsc$ansi_vol1_label_kind;
    fsp$locate_tape_label (header_labels, label_identifier, label_locator);
    IF label_locator.label_found AND (label_locator.label_block <> NIL) THEN
      RESET label_locator.label_block;
      NEXT vol1_label IN label_locator.label_block;
      IF vol1_label <> NIL THEN
        validate_vol1_label (file, file_identifier, layer_number, vol1_label^, status);
      IFEND;
    IFEND;
    IF status.normal THEN
      label_identifier.location_method := fsc$tape_label_locate_by_kind;
      label_identifier.label_kind := fsc$ansi_hdr1_label_kind;
      fsp$locate_tape_label (header_labels, label_identifier, label_locator);
      IF label_locator.label_found AND (label_locator.label_block <> NIL) THEN
        RESET label_locator.label_block;
        NEXT hdr1_label IN label_locator.label_block;
        IF hdr1_label <> NIL THEN
          validate_hdr1_label (file, file_identifier, layer_number, hdr1_label^, status);
        IFEND;
      IFEND;
    IFEND;
    IF status.normal THEN
      label_identifier.location_method := fsc$tape_label_locate_by_kind;
      label_identifier.label_kind := fsc$ansi_hdr2_label_kind;
      fsp$locate_tape_label (header_labels, label_identifier, label_locator);
      IF label_locator.label_found AND (label_locator.label_block <> NIL) THEN
        RESET label_locator.label_block;
        NEXT hdr2_label IN label_locator.label_block;
        IF hdr2_label <> NIL THEN
          validate_hdr2_label (file, file_identifier, hdr1_label, layer_number, hdr2_label^, status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND validate_header_labels;
?? OLDTITLE ??
?? NEWTITLE := '    validate_hdr1_label ', EJECT ??

  PROCEDURE validate_hdr1_label
    (    file: fst$file_reference;
         file_identifier: amt$file_identifier;
         layer_number: amt$fap_layer_number;
     VAR hdr1: fst$ansi_hdr1_label;
     VAR status: ost$status);

{Design:
{Each numeric field in the HDR1 label is validated to be a number or SPACE.
{Any invalid field is set to SPACE.  This allows the field to be under control
{of the NOS/VE user through specification of file attributes.}
?? EJECT ??
    VAR
      local_status: ost$status;

    status.normal := TRUE;
    rmp$validate_ansi_string (hdr1.file_identifier, hdr1.file_identifier, local_status);
    IF NOT local_status.normal THEN
      log_improper_label_field ('FILE_IDENTIFIER', file, 'HDR1', hdr1.file_identifier);
      hdr1.file_identifier := ' ';
    IFEND;
    rmp$validate_ansi_string (hdr1.file_set_identifier, hdr1.file_set_identifier, local_status);
    IF NOT local_status.normal THEN
      log_improper_label_field ('FILE_SET_IDENTIFIER', file, 'HDR1', hdr1.file_set_identifier);
      hdr1.file_set_identifier := ' ';
    IFEND;
    IF NOT (field_is_numeric (hdr1.file_section_number)) THEN
      log_nonnumeric_label_field ('Bytes 28..31 - File Section Number', file, 'HDR1',
            hdr1.file_section_number);
      hdr1.file_section_number := ' ';
    IFEND;
    IF NOT (field_is_numeric (hdr1.file_sequence_number)) THEN
      log_nonnumeric_label_field ('Bytes 32..35 - File Sequence Number', file, 'HDR1',
            hdr1.file_sequence_number);
      hdr1.file_sequence_number := ' ';
    IFEND;
    IF NOT (field_is_numeric (hdr1.generation_number)) THEN
      log_nonnumeric_label_field ('Bytes 36..39 - Generation Number', file, 'HDR1', hdr1.generation_number);
      hdr1.generation_number := ' ';
    IFEND;
    IF NOT (field_is_numeric (hdr1.generation_version_number)) THEN
      log_nonnumeric_label_field ('Bytes 40..41 - Generation Version Number', file, 'HDR1',
            hdr1.generation_version_number);
      hdr1.generation_version_number := ' ';
    IFEND;
    IF NOT (date_is_valid (hdr1.creation_date)) THEN
      log_invalid_date_field ('Bytes 42..47 - Creation Date', file, 'HDR1', hdr1.creation_date);
      hdr1.creation_date := ' ';
    IFEND;
    IF NOT (date_is_valid (hdr1.expiration_date)) THEN
      log_invalid_date_field ('Bytes 48..53 - Expiration Date', file, 'HDR1', hdr1.expiration_date);
      hdr1.expiration_date := ' 00000';
    IFEND;
    rmp$validate_ansi_string (hdr1.accessibility, hdr1.accessibility, local_status);
    IF NOT local_status.normal THEN
      log_improper_label_field ('FILE_ACCESSIBILITY', file, 'HDR1', hdr1.accessibility);
      hdr1.accessibility := ' ';
    IFEND;
    IF NOT (field_is_numeric (hdr1.block_count)) THEN
      log_improper_block_count ('Bytes 55..60 - Block Count', file, 'HDR1', hdr1.block_count, '000000');
      hdr1.block_count := '000000';
    IFEND;
    rmp$validate_ansi_string (hdr1.system_code, hdr1.system_code, local_status);
    IF NOT local_status.normal THEN
      log_improper_label_field ('IMPLEMENTATION_IDENTIFIER', file, 'HDR1', hdr1.system_code);
      hdr1.system_code := ' ';
    IFEND;

  PROCEND validate_hdr1_label;
?? OLDTITLE ??
?? NEWTITLE := '    validate_hdr2_label ', EJECT ??

  PROCEDURE validate_hdr2_label
    (    file: fst$file_reference;
         file_identifier: amt$file_identifier;
         hdr1: ^fst$ansi_hdr1_label;
         layer_number: amt$fap_layer_number;
     VAR hdr2: fst$ansi_hdr2_label;
     VAR status: ost$status);

{Design:
{Each numeric field in the HDR2 label is validated to be a number or SPACE.
{Any invalid field is set to SPACE.  This allows the field to be under control
{of the NOS/VE user through specification of file attributes.}
{file attributes.  If NOS/VE wrote the HDR labels, values in bytes 16..27 which are
{reserved to implementors of the ANSI standard are validated for legal NOS/VE values.}
?? EJECT ??
    status.normal := TRUE;
    IF NOT (hdr2.record_format IN ve_record_types) OR (hdr2.record_format = 'U') OR
          (hdr2.record_format = 'u') THEN
      log_improper_label_field ('Byte 5 - Record Format', file, 'HDR2', hdr2.record_format);
      hdr2.record_format := ' ';
    IFEND;
    IF NOT (field_is_numeric (hdr2.block_length)) THEN
      log_nonnumeric_label_field ('Bytes 6..10 - Block Length', file, 'HDR2', hdr2.block_length);
      hdr2.block_length := ' ';
    IFEND;
    IF NOT (field_is_numeric (hdr2.record_length)) THEN
      log_nonnumeric_label_field ('Bytes 11..15 - Record Length', file, 'HDR2', hdr2.record_length);
      hdr2.record_length := ' ';
    IFEND;
    IF (hdr1 <> NIL) AND fsp$ve_wrote_ansi_file (hdr1^.system_code) THEN
      IF NOT ((hdr2.ve_block_type = ' ') OR (hdr2.ve_block_type = 'SS') OR (hdr2.ve_block_type = 'US')) THEN
        log_improper_label_field ('Bytes 16..17 - NOS/VE block_type', file, 'HDR2', hdr2.ve_block_type);
        hdr2.ve_block_type := ' ';
      IFEND;
      IF NOT (hdr2.ve_record_type IN ve_record_types) THEN
        log_improper_label_field ('Byte 18 - NOS/VE record_type', file, 'HDR2', hdr2.ve_record_type);
        hdr2.ve_record_type := ' ';
      IFEND;
      IF NOT (field_is_numeric (hdr2.ve_block_length_ext)) THEN
        log_nonnumeric_label_field ('Bytes 19..21 - NOS/VE block_length_extension', file, 'HDR2',
              hdr2.ve_block_length_ext);
        hdr2.ve_block_length_ext := ' ';
      IFEND;
      IF NOT (field_is_numeric (hdr2.ve_record_length_ext)) THEN
        log_nonnumeric_label_field ('Bytes 22..24 - NOS/VE record_length_extension', file, 'HDR2',
              hdr2.ve_record_length_ext);
        hdr2.ve_record_length_ext := ' ';
      IFEND;
      IF NOT (hdr2.ve_character_set IN ve_character_sets) THEN
        log_improper_label_field ('Byte 26 - NOS/VE character_set', file, 'HDR2', hdr2.ve_character_set);
        hdr2.ve_character_set := ' ';
      IFEND;
      IF NOT (hdr2.ve_character_conversion IN ve_character_conversions) THEN
        log_improper_label_field ('Byte 27 - NOS/VE character_conversion', file, 'HDR2',
              hdr2.ve_character_conversion);
        hdr2.ve_character_conversion := ' ';
      IFEND;
    ELSE
      IF hdr2.block_length = '00000' THEN
        log_improper_label_field ('Bytes 6..10 - Block Length', file, 'HDR2', hdr2.block_length);
        hdr2.block_length := ' ';
      IFEND;
      IF hdr2.record_length = '00000' THEN
        log_improper_label_field ('Bytes 11..15 - Record Length', file, 'HDR2', hdr2.record_length);
        hdr2.record_length := ' ';
      IFEND;
    IFEND;
    IF NOT (field_is_numeric (hdr2.buffer_offset_length)) THEN
      log_nonnumeric_label_field ('Bytes 51..52 - Offset Length', file, 'HDR2', hdr2.buffer_offset_length);
      hdr2.buffer_offset_length := ' ';
    IFEND;
  PROCEND validate_hdr2_label;
?? OLDTITLE ??
?? NEWTITLE := '    validate_trailer_labels ', EJECT ??

  PROCEDURE validate_trailer_labels
    (    file: fst$file_reference;
         file_identifier: amt$file_identifier;
         request: fst$ts_validate_trailer_labels;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

    VAR
      eox1_label: ^fst$ansi_eof1_label,
      eox2_label: ^fst$ansi_eof2_label,
      label_identifier: fst$tape_label_identifier,
      label_locator: fst$tape_label_locator,
      trailer_labels: ^SEQ ( * );

    status.normal := TRUE;
    trailer_labels := request.trailer_labels;
    RESET trailer_labels;
    label_identifier.location_method := fsc$tape_label_locate_by_kind;
    label_identifier.label_kind := fsc$ansi_eof1_label_kind;
    fsp$locate_tape_label (trailer_labels, label_identifier, label_locator);
    IF label_locator.label_found THEN
      RESET label_locator.label_block;
      NEXT eox1_label IN label_locator.label_block;
      IF eox1_label <> NIL THEN
        validate_eox1_label (file, file_identifier, layer_number, eox1_label^, status);
        IF status.normal THEN
          label_identifier.location_method := fsc$tape_label_locate_by_kind;
          label_identifier.label_kind := fsc$ansi_eof2_label_kind;
          fsp$locate_tape_label (trailer_labels, label_identifier, label_locator);
          IF label_locator.label_found THEN
            RESET label_locator.label_block;
            NEXT eox2_label IN label_locator.label_block;
            IF eox2_label <> NIL THEN
              validate_eox2_label (eox1_label^, file, file_identifier, layer_number, eox2_label^, status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    ELSE
      label_identifier.location_method := fsc$tape_label_locate_by_kind;
      label_identifier.label_kind := fsc$ansi_eov1_label_kind;
      fsp$locate_tape_label (trailer_labels, label_identifier, label_locator);
      IF label_locator.label_found THEN
        RESET label_locator.label_block;
        NEXT eox1_label IN label_locator.label_block;
        IF eox1_label <> NIL THEN
          validate_eox1_label (file, file_identifier, layer_number, eox1_label^, status);
          IF status.normal THEN
            label_identifier.location_method := fsc$tape_label_locate_by_kind;
            label_identifier.label_kind := fsc$ansi_eov2_label_kind;
            fsp$locate_tape_label (trailer_labels, label_identifier, label_locator);
            IF label_locator.label_found THEN
              RESET label_locator.label_block;
              NEXT eox2_label IN label_locator.label_block;
              IF eox2_label <> NIL THEN
                validate_eox2_label (eox1_label^, file, file_identifier, layer_number, eox2_label^, status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND validate_trailer_labels;
?? OLDTITLE ??
?? NEWTITLE := '    validate_vol1_label ', EJECT ??

  PROCEDURE validate_vol1_label
    (    file: fst$file_reference;
         file_identifier: amt$file_identifier;
         layer_number: amt$fap_layer_number;
     VAR vol1: fst$ansi_vol1_label;
     VAR status: ost$status);

{Design:
{Each numeric field in the VOL1 label is validated to be a number or SPACE.
?? EJECT ??

    VAR
      local_status: ost$status;

    status.normal := TRUE;

    IF NOT (field_is_numeric (vol1.label_standard_version)) THEN
      log_nonnumeric_label_field ('LABEL_STANDARD_VERSION', file, 'VOL1', vol1.label_standard_version);
      vol1.label_standard_version := ' ';
    IFEND;
    rmp$validate_ansi_string (vol1.volume_identifier, vol1.volume_identifier, local_status);
    IF NOT local_status.normal THEN
      log_improper_label_field ('VOLUME_IDENTIFIER', file, 'VOL1', vol1.volume_identifier);
      vol1.volume_identifier := ' ';
    IFEND;
    rmp$validate_ansi_string (vol1.accessibility, vol1.accessibility, local_status);
    IF NOT local_status.normal THEN
      log_improper_label_field ('VOLUME_ACCESSIBILITY', file, 'VOL1', vol1.accessibility);
      vol1.accessibility := ' ';
    IFEND;
    rmp$validate_ansi_string (vol1.implementation_identifier, vol1.implementation_identifier, local_status);
    IF NOT local_status.normal THEN
      log_improper_label_field ('IMPLEMENTATION_IDENTIFIER', file, 'VOL1', vol1.implementation_identifier);
      vol1.implementation_identifier := ' ';
    IFEND;
    rmp$validate_ansi_string (vol1.owner_identifier, vol1.owner_identifier, local_status);
    IF NOT local_status.normal THEN
      log_improper_label_field ('OWNER_IDENTIFIER', file, 'VOL1', vol1.owner_identifier);
      vol1.owner_identifier := ' ';
    IFEND;

  PROCEND validate_vol1_label;
?? OLDTITLE ??
?? NEWTITLE := '    volume_accessibility_matches', EJECT ??

  FUNCTION [INLINE] volume_accessibility_matches
    (    existing_va: string (1);
         requested_va: string (1)): boolean;

    IF existing_va = requested_va THEN
      volume_accessibility_matches := TRUE;
    ELSEIF existing_va = ' ' THEN
      volume_accessibility_matches := TRUE;
    ELSE
      volume_accessibility_matches := FALSE;
    IFEND;

  FUNCEND volume_accessibility_matches;
?? OLDTITLE ??
?? OLDTITLE ??
MODEND rmm$enforce_tape_security;
*DECK DECK=RMM$INITV_EXP_MENU$US_ENGLISH EXPAND=TRUE
*DECK DECK=RMM$INITV_RE_MENU$US_ENGLISH EXPAND=TRUE
*DECK DECK=RMM$INITV_UL_MENU$US_ENGLISH EXPAND=TRUE
*DECK DECK=RMM$INITV_UNEXP_MENU$US_ENGLISH EXPAND=TRUE
*DECK DECK=RMM$MANAGE_CLIENT_VOLUMES_223 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Resource Management : Mount a tape volume and assign element to the job' ??
MODULE rmm$manage_client_volumes_223;

?? NEWTITLE := 'Global Variables Declared by This Module', EJECT ??

  CONST
    expected_tape_scan_time = 2 {seconds},
    five_minutes = 5 * one_minute,
    five_seconds = 5 * one_second,
    microseconds_per_millisecond = 1000,
    microseconds_per_second = 1000 * microseconds_per_millisecond,
    one_minute = 60 * one_second,
    one_second = 1000 {milliseconds};

  TYPE
    retry_status_info = record
      case retry_in_progress: boolean of
      = TRUE =
        next_request {after limit exceeded} : rmt$rbt_request_type,
        retry_count: ost$positive_integers,
        retry_delay_interval: ost$non_negative_integers,
        retry_limit: ost$positive_integers,
        server_event_code: ost$non_negative_integers,
      = FALSE =
        ,
      casend,
    recend;

  VAR
    requested_density: rmt$density,
    requested_evsn: rmt$external_vsn,
    request_submitted: boolean;

?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cme$manage_interface_tables
*copyc cmt$element_states
*copyc dme$tape_errors
*copyc dmt$job_tape_table
*copyc dmt$resrel_tape_request
*copyc dmt$tape_job_lun_table
*copyc iot$logical_unit
*copyc iot$operator_assignment_type
*copyc osd$integer_limits
*copyc oss$job_pageable
*copyc oss$job_paged_literal
*copyc rmc$extend_labeled_vol_list
*copyc rmc$extend_unlabeled_vol_list
*copyc rmc$robotic_element_monopoly
*copyc rme$condition_codes
*copyc rmt$density
?? POP ??
*copyc clp$evaluate_sub_parameters
*copyc clp$get_date_time_string
*copyc clp$get_value
*copyc clp$pop_parameters
*copyc clp$push_parameters
*copyc clp$scan_parameter_list
*copyc clp$trimmed_string_size
*copyc cmv$logical_unit_table
*copyc dmv$initialize_tape_volume
*copyc rmp$clear_explicit_reserve
*copyc rmp$set_explicit_reserve
*copyc rmv$job_tape_table_lock
*copyc rmv$job_tape_table_p
*copyc dmv$tape_job_lun_table_p
*copyc ifp$invoke_pause_utility
*copyc iop$client_cancel_request
*copyc iop$client_delete_request
*copyc iop$client_get_response
*copyc iop$client_put_request
*copyc iop$extend_volume_list_in_rvl
*copyc iop$get_server_entry
*copyc iop$queue_volume_assignment
*copyc iop$record_robotic_assignment
*copyc iop$recovery_rel_assign_in_rvl
*copyc iop$release_assignment_in_rvl
*copyc iop$request_assignment_in_rvl
*copyc iop$select_best_element
*copyc iop$validate_candidate_element
*copyc ofp$clear_operator_message
*copyc ofp$display_status_message
*copyc ofp$format_operator_menu
*copyc ofp$format_operator_message
*copyc ofp$process_operator_menu
*copyc ofp$send_formatted_operator_msg
*copyc osp$append_status_parameter
*copyc osp$begin_subsystem_activity
*copyc osp$clear_job_signature_lock
*copyc osp$clear_wait_message
*copyc osp$copy_local_status_to_status
*copyc osp$disestablish_cond_handler
*copyc osp$end_subsystem_activity
*copyc osp$establish_condition_handler
*copyc osp$format_message
*copyc osp$get_current_display_message
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$status_message_text
*copyc osp$test_signature_lock
*copyc osp$translate_bytes
*copyc osv$lower_to_upper
*copyc pmp$continue_to_cause
*copyc pmp$get_job_names
*copyc pmp$long_term_wait
*copyc pmp$wait
*copyc rmp$assign_tape_unit
*copyc rmp$emit_operator_message
*copyc rmp$get_selected_element
*copyc rmp$log_debug_integer
*copyc rmp$log_debug_message
*copyc rmp$log_debug_status
*copyc rmp$put_job_status_display
*copyc rmp$release_tape_unit
*copyc rmp$validate_ansi_string
*copyc rmv$densities
*copyc tmp$ready_system_task1

?? OLDTITLE ??
?? NEWTITLE := 'rmp$activate_volume', EJECT ??

{ PURPOSE:
{    The purpose of this procedure is to mount a magnetic tape volume on a tape element
{    and to assign the tape element to the requesting job.
{ DESIGN:
{    It is not known ahead of time whether or not the volume must be mounted manually
{    by an operator or may be robotically mounted.  Therefore, we first determine
{    if it can be mounted robotically.  Failing that, we announce the tape mount
{    request to the Removable Media Operator.
{
{    If the volume is robotically mounted, we know exactly which tape element it was
{    mounted on.  If it must be manually mounted, we must wait for the operator to
{    place the reel on the tape unit (mount it) and then the tape element must be
{    discovered by automatic volume recognition (labeled volume only) or it must be
{    identified explicitly by an operator (via the ASSIGN_DEVICE command).  While the
{    ASSIGN_DEVICE command is usually used for unlabeled volumes, it may also be
{    required for a labeled volume in the situation where the system finds two
{    requests identifying the same RECORDED_VSN and different EXTERNAL_VSNs.  In this
{    latter case, we ask the operator to sort this out via ASSIGN_DEVICE.  This case
{    is detected within this procedure.
{
{    It is possible to recover an active job that has yet to assign a tape element to
{    itself.  When job recovery is detected we need to start all over, i.e. get the
{    volume mounted again and proceed to assign the element to the job.  The block
{    exit condition handler is responsible for cleanup (i.e. rolling back whatever
{    may have been accomplished within this procedure).
{

  PROCEDURE [XDCL] rmp$activate_volume
    (    sfid: gft$system_file_identifier;
         acceptable_states: cmt$element_states;
         last_choice_element: cmt$element_name;
         required_element: cmt$element_name;
     VAR status: ost$status);

    VAR
      assigned_count_incremented: boolean,
      current_date_time_string: ost$string,
      element_assigned: boolean,
      message_parameters: array [1 .. 2] of ^ost$message_parameter,
      original_message: oft$display_message;

?? OLDTITLE ??
?? NEWTITLE := '  activate_volume_handler', EJECT ??

    PROCEDURE activate_volume_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        clear_implicit_reserve: boolean,
        density: rmt$supported_tape_densities,
        debug_status: ost$status,
        ignore_status: ost$status,
        local_status: ost$status,
        lock_status: ost$signature_lock_status,
        reservation: rmt$tape_reservation,
        wait_message_displayed: boolean;

      rmp$log_debug_message (' Entering activate_volume_handler');
      osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, debug_status,
            ignore_status);
      rmp$log_debug_status (debug_status);
      CASE condition.selector OF

      = pmc$block_exit_processing =

        wait_message_displayed := TRUE;
        ofp$clear_operator_message (ofc$removable_media_operator, ignore_status);
        osp$clear_wait_message (original_message, wait_message_displayed);

        osp$test_signature_lock (rmv$job_tape_table_lock, lock_status, local_status);
        IF local_status.normal AND (lock_status = osc$sls_locked_by_current_task) THEN
          osp$end_subsystem_activity;
          osp$clear_job_signature_lock (rmv$job_tape_table_lock);
        IFEND;
        IF element_assigned THEN
          rmp$deactivate_volume (sfid, {delete_request_from_vsn_queue} TRUE, ignore_status);
        ELSEIF assigned_count_incremented THEN
          IF rmv$job_tape_table_p <> NIL THEN
            IF lock_status <> osc$sls_locked_by_another_task THEN
              osp$begin_subsystem_activity;
              osp$set_job_signature_lock (rmv$job_tape_table_lock);
              IF rmv$job_tape_table_p^.assigned_unit_count [requested_density] > 0 THEN
                rmv$job_tape_table_p^.assigned_unit_count [requested_density] :=
                      rmv$job_tape_table_p^.assigned_unit_count [requested_density] - 1;
              IFEND;
              osp$clear_job_signature_lock (rmv$job_tape_table_lock);
              osp$end_subsystem_activity;
            IFEND;
          IFEND;
        IFEND;

      = ifc$interactive_condition =
        CASE condition.interactive_condition OF
        = ifc$terminate_break =
          osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
                ignore_status);
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          EXIT rmp$activate_volume;
        = ifc$pause_break, ifc$job_reconnect =
          ifp$invoke_pause_utility (ignore_status);
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;

      = pmc$user_defined_condition =

        IF condition.user_condition_name = osc$job_recovery_condition_name THEN
          IF NOT dmv$initialize_tape_volume.in_progress THEN
            IF (rmv$job_tape_table_p <> NIL) AND rmv$job_tape_table_p^.job_recovery_active THEN
              osp$test_signature_lock (rmv$job_tape_table_lock, lock_status, local_status);
              IF local_status.normal AND (lock_status = osc$sls_locked_by_current_task) THEN
                osp$end_subsystem_activity;
                osp$clear_job_signature_lock (rmv$job_tape_table_lock);
              IFEND;
              IF rmv$job_tape_table_p^.explicit_reservation THEN
                { Must reclaim explicit reserves
                FOR density := rmc$800 TO rmc$maximum_density DO
                  reservation [density] := rmv$job_tape_table_p^.reserved_unit_count [density];
                FOREND;
                rmp$set_explicit_reserve (reservation, status);
              IFEND;
              osp$begin_subsystem_activity;
              osp$set_job_signature_lock (rmv$job_tape_table_lock);
              rmv$job_tape_table_p^.job_recovery_active := FALSE;
              osp$clear_job_signature_lock (rmv$job_tape_table_lock);
              osp$end_subsystem_activity;
            IFEND;
          IFEND;
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_condition (dme$operator_reassign, status);
          EXIT rmp$activate_volume;
        IFEND;
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);

      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;
      rmp$log_debug_message (' Exiting activate_volume_handler');

    PROCEND activate_volume_handler;

?? OLDTITLE ??
?? NEWTITLE := '  attempt_manual_mount', EJECT ??

    PROCEDURE attempt_manual_mount
      (    sfid: gft$system_file_identifier;
       VAR selected_element: cmt$element_name;
       VAR volume_mounted: boolean;
       VAR status: ost$status);

?? NEWTITLE := '    manual_condition_handler', EJECT ??

      PROCEDURE manual_condition_handler
        (    condition: pmt$condition;
             p_condition_info: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR condition_status: ost$status);

        VAR
          debug_status: ost$status,
          release_status: ost$status;

        rmp$log_debug_message (' Entering manual_condition_handler');
        osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, debug_status,
              ignore_status);
        rmp$log_debug_status (debug_status);
        CASE condition.selector OF
        = pmc$block_exit_processing =
          IF assigned_in_rvl THEN
            debug_message_logged := FALSE;
            REPEAT
              IF NOT debug_message_logged THEN
                rmp$log_debug_message (' Calling iop$release_assignment_in_rvl');
              IFEND;
              iop$release_assignment_in_rvl (sfid, release_status);
              IF NOT release_status.normal AND (release_status.condition = dme$unable_to_lock_tape_table) THEN
                IF NOT debug_message_logged THEN
                  rmp$log_debug_message (' Waiting for tape table lock');
                  debug_message_logged := TRUE;
                IFEND;
                pmp$wait (one_second, one_second);
              IFEND;
            UNTIL release_status.normal OR (release_status.condition <> dme$unable_to_lock_tape_table);
            assigned_in_rvl := NOT release_status.normal;
            #SPOIL (assigned_in_rvl);
          IFEND;

        = ifc$interactive_condition =
          CASE condition.interactive_condition OF
          = ifc$pause_break, ifc$job_reconnect =
            ifp$invoke_pause_utility (ignore_status);
          = ifc$terminate_break =
            pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
            osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
                  ignore_status);
            EXIT attempt_manual_mount;
          ELSE
            pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          CASEND;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;
        rmp$log_debug_message (' Exiting manual_condition_handler');

      PROCEND manual_condition_handler;
?? OLDTITLE ??
?? EJECT ??

      VAR
        assigned_in_rvl: boolean,
        ignore_status: ost$status,
        job_lun_table_entry: ^dmt$tape_lun_table_entry,
        message_name: clt$parameter_name,
        tape_unit_available: boolean,
        release_status: ost$status,
        requested_evsn: rmt$external_vsn,
        requested_rvsn: rmt$recorded_vsn;

      rmp$log_debug_message (' Entering attempt_manual_mount');
      job_lun_table_entry := ^dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index];
      #TRANSLATE (osv$lower_to_upper, job_lun_table_entry^.
            volume_list^ [job_lun_table_entry^.current_vsn_index].external_vsn, requested_evsn);
      #TRANSLATE (osv$lower_to_upper, job_lun_table_entry^.
            volume_list^ [job_lun_table_entry^.current_vsn_index].recorded_vsn, requested_rvsn);
      requested_density := job_lun_table_entry^.density;
      assigned_in_rvl := FALSE;
      #SPOIL (assigned_in_rvl);

      osp$establish_condition_handler (^manual_condition_handler, {handle_block_exit} TRUE);
      rmp$log_debug_message (' Calling rmp$get_selected_element - 1st try');
      rmp$get_selected_element (sfid, requested_evsn, requested_rvsn, requested_density, selected_element,
            status);
      rmp$log_debug_status (status);
      IF status.normal THEN
        volume_mounted := status.normal;
      ELSEIF (status.condition = rme$volume_not_mounted) OR
            (status.condition = rme$tape_unit_available) THEN
        rmp$log_debug_message (' Readying scanner');
        tmp$ready_system_task (tmc$stid_tape_scanner, ignore_status);
        wait (expected_tape_scan_time * one_second);
        rmp$get_selected_element (sfid, requested_evsn, requested_rvsn, requested_density, selected_element,
              status);
        rmp$log_debug_status (status);
        IF status.normal THEN
          rmp$log_debug_message (' Scanner found volume');
          volume_mounted := status.normal;
        ELSEIF (status.condition = rme$volume_not_mounted) OR
              (status.condition = rme$tape_unit_available) THEN
          debug_message_logged := FALSE;
          tape_unit_available := NOT (status.condition = rme$tape_unit_available);
          REPEAT
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Calling iop$request_assignment_in_rvl');
            IFEND;
            iop$request_assignment_in_rvl (sfid, requested_density, requested_evsn, requested_rvsn, status);
            IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
              IF NOT debug_message_logged THEN
                rmp$log_debug_message (' Waiting for tape table lock');
                debug_message_logged := TRUE;
              IFEND;
              pmp$long_term_wait (one_second, one_second);
            IFEND;
          UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
          rmp$log_debug_status (status);
          assigned_in_rvl := status.normal;
          #SPOIL (assigned_in_rvl);
          IF status.normal THEN
            tmp$ready_system_task (tmc$stid_tape_scanner, ignore_status);
            IF tape_unit_available THEN
              message_name := 'WAIT_MANUAL_MOUNT';
            ELSE
              message_name := 'WAIT_TAPE_UNIT';
            IFEND;
            message_parameters [1] := ^current_date_time_string.value (1, current_date_time_string.size);
            message_parameters [2] := ^requested_evsn;
            rmp$put_job_status_display (message_name, ^message_parameters);
            rmp$log_debug_message (' Waiting for operator action or robotic server definition');
            wait (five_minutes); {Wait for ASSD, TERTA, scanner, or robotic server definition to ready task}
            rmp$log_debug_message (' Calling rmp$get_selected_element - after wait');
            rmp$get_selected_element (sfid, requested_evsn, requested_rvsn, requested_density,
                  selected_element, status);
            rmp$log_debug_status (status);
            volume_mounted := status.normal;
            IF (NOT status.normal) AND ((status.condition = rme$volume_not_mounted) OR
                  (status.condition = rme$tape_unit_available)) THEN
              status.normal := TRUE;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      IF (NOT status.normal) THEN
        REPEAT
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Calling iop$release_assignment_in_rvl');
          IFEND;
          iop$release_assignment_in_rvl (sfid, release_status);
          IF NOT release_status.normal AND (release_status.condition = dme$unable_to_lock_tape_table) THEN
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Waiting for tape table lock');
              debug_message_logged := TRUE;
            IFEND;
            pmp$wait (one_second, one_second);
          IFEND;
        UNTIL release_status.normal OR (release_status.condition <> dme$unable_to_lock_tape_table);
        rmp$log_debug_status (release_status);
        assigned_in_rvl := NOT release_status.normal;
        #SPOIL (assigned_in_rvl);
      IFEND;
      osp$disestablish_cond_handler;
    PROCEND attempt_manual_mount;
?? OLDTITLE ??
?? NEWTITLE := '  attempt_robotic_mount ', EJECT ??

    PROCEDURE attempt_robotic_mount
      (    sfid: gft$system_file_identifier;
           acceptable_states: cmt$element_states;
           last_choice_element: cmt$element_name;
           required_element: cmt$element_name;
       VAR assigned_mainframe_lun: iot$logical_unit;
       VAR selected_element: cmt$element_name;
       VAR status: ost$status);

      VAR
        server_name: ost$name;

?? NEWTITLE := '    robotic_mount_handler', EJECT ??

      PROCEDURE robotic_mount_handler
        (    condition: pmt$condition;
             p_condition_info: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR condition_status: ost$status);

        VAR
          cancel_status: ost$status,
          debug_status: ost$status,
          ignore_status: ost$status;

?? NEWTITLE := '  robotic_mount_lock_handler  ', EJECT ??

      PROCEDURE robotic_mount_lock_handler
        (    condition: pmt$condition;
             p_condition_info: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR condition_status: ost$status);

        VAR
          ignore_status: ost$status;

        CASE condition.selector OF
        = ifc$interactive_condition =
          CASE condition.interactive_condition OF
          = ifc$pause_break, ifc$job_reconnect =
            ifp$invoke_pause_utility (ignore_status);
          = ifc$terminate_break =
            pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
            osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
                  ignore_status);
            EXIT attempt_robotic_mount;
          ELSE
            pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          CASEND;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;

      PROCEND robotic_mount_lock_handler;
?? OLDTITLE ??

        rmp$log_debug_message (' Entering robotic_mount_handler');
        osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, debug_status,
              ignore_status);
        rmp$log_debug_status (debug_status);

        CASE condition.selector OF
        = pmc$block_exit_processing =

          IF request_submitted THEN
            debug_message_logged := FALSE;
            REPEAT
              IF NOT debug_message_logged THEN
                rmp$log_debug_message (' Calling iop$client_cancel_request');
              IFEND;
              iop$client_cancel_request (server_name, sfid, cancel_status);
              IF NOT cancel_status.normal AND (cancel_status.condition = dme$unable_to_lock_tape_table) THEN
                IF NOT debug_message_logged THEN
                  rmp$log_debug_message (' Waiting for tape table lock');
                  debug_message_logged := TRUE;
                IFEND;
                osp$establish_condition_handler (^robotic_mount_lock_handler, {handle block exit} FALSE);
                pmp$long_term_wait (one_second, one_second);
                osp$disestablish_cond_handler;
              IFEND;
            UNTIL cancel_status.normal OR (cancel_status.condition <> dme$unable_to_lock_tape_table);
            rmp$log_debug_message ('Called iop$client_cancel_request');
            rmp$log_debug_status (cancel_status);
          IFEND;

          release_element_from_job (sfid, {delete_request_from_vsn_queue} FALSE, assigned_mainframe_lun,
                ignore_status);

        = ifc$interactive_condition =
          CASE condition.interactive_condition OF
          = ifc$terminate_break =
            pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
            osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
                  ignore_status);
            EXIT attempt_robotic_mount;
          = ifc$pause_break, ifc$job_reconnect =
            ifp$invoke_pause_utility (ignore_status);
          ELSE
            pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          CASEND;

        = pmc$user_defined_condition =
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          IF condition.user_condition_name = osc$job_recovery_condition_name THEN
            EXIT attempt_robotic_mount;
          IFEND;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;
        rmp$log_debug_message (' Exiting robotic_mount_handler');

      PROCEND robotic_mount_handler;
?? OLDTITLE ??
?? EJECT ??

      VAR
        elapsed_time: integer,
        element: cmt$element_name,
        external_vsn: rmt$external_vsn,
        ignore_assigned_mainframe_lun: iot$logical_unit,
        ignored_element: cmt$element_name,
        ignore_status: ost$status,
        initial_tasks: rmt$rbt_supported_requests,
        job_lun_table_entry: ^dmt$tape_lun_table_entry,
        last_sync_error: rmt$rbt_supported_requests,
        message_name: clt$parameter_name,
        remaining_tasks: rmt$rbt_supported_requests,
        request: rmt$rbt_request,
        required_requests: rmt$rbt_supported_requests,
        retry_status: retry_status_info,
        server_entry: iot$robotic_server_entry,
        server_index: iot$robotic_server_index,
        start_time: integer,
        valid_request_transitions: rmt$rbt_supported_requests;

      start_time := #FREE_RUNNING_CLOCK (0);
      assigned_mainframe_lun := 0;

      initial_tasks := $rmt$rbt_supported_requests [rmc$rbt_query, rmc$rbt_mount];

      job_lun_table_entry := ^dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index];

      last_sync_error := $rmt$rbt_supported_requests [];

      remaining_tasks := initial_tasks;

      request_submitted := FALSE;

      requested_density := job_lun_table_entry^.density;

      #TRANSLATE (osv$lower_to_upper, job_lun_table_entry^.
            volume_list^ [job_lun_table_entry^.current_vsn_index].external_vsn, requested_evsn);

      required_requests := $rmt$rbt_supported_requests [rmc$rbt_force_dismount, rmc$rbt_dismount,
            rmc$rbt_mount, rmc$rbt_query];

      retry_status.retry_in_progress := FALSE;

      valid_request_transitions := $rmt$rbt_supported_requests
            [rmc$rbt_force_dismount, rmc$rbt_mount, rmc$rbt_query];

?? EJECT ??
      #SPOIL (assigned_mainframe_lun, request_submitted);
      osp$establish_condition_handler (^robotic_mount_handler, {handle block exit} TRUE);
      osp$set_job_signature_lock (rmv$job_tape_table_lock);
      osp$begin_subsystem_activity;

    /robotic_mount/
      BEGIN

      /locate_server/
        FOR server_index := 1 TO ioc$max_server_index DO
          debug_message_logged := FALSE;
          REPEAT
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Calling iop$get_server_entry');
            IFEND;
            iop$get_server_entry (server_index, server_entry, status);
            IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
              IF NOT debug_message_logged THEN
                rmp$log_debug_message (' Waiting for tape table lock');
                debug_message_logged := TRUE;
              IFEND;
              pmp$long_term_wait (one_second, one_second);
            IFEND;
          UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
          IF status.normal AND (required_requests <= server_entry.server_attributes.supported_requests) AND
                (requested_density IN server_entry.managed_densities) THEN
            server_name := server_entry.server_name;
            #SPOIL (server_name);
            REPEAT
              IF status.normal AND (remaining_tasks = $rmt$rbt_supported_requests []) THEN
                EXIT /robotic_mount/;
              ELSEIF rmc$rbt_force_dismount IN remaining_tasks THEN
                IF assigned_mainframe_lun <> 0 THEN
                  request.request_type := rmc$rbt_force_dismount;
                  request.force_dismount.element := selected_element;
                  message_name := 'WAIT_FOR_FORCE';
                  message_parameters [1] := ^selected_element;
                  rmp$log_debug_message (' Issuing force dismount');
                  process_request ({ignore acceptable_states} $cmt$element_states [], initial_tasks,
                        {last_choice_element} osc$null_name, message_name, current_date_time_string, request,
                        {required_element} osc$null_name, server_name, server_entry.server_attributes.timeout,
                        sfid, valid_request_transitions, message_parameters, ignore_assigned_mainframe_lun,
                        remaining_tasks, retry_status, ignored_element, status);
                  IF status.normal THEN
                    rmp$log_debug_message (' Calling cmp$release_tape_unit after force_dismount');
                    release_element_from_job (sfid, {delete_request_from_vsn_queue} FALSE,
                          assigned_mainframe_lun, ignore_status);
                    remaining_tasks := remaining_tasks + $rmt$rbt_supported_requests [rmc$rbt_query];
                  IFEND;
                  check_synchronization (request.request_type, last_sync_error, status);
                ELSE {unit that is object of force dismount is not assigned to the job}
                  remaining_tasks := remaining_tasks - $rmt$rbt_supported_requests [rmc$rbt_force_dismount];
                IFEND;
              ELSEIF rmc$rbt_query IN remaining_tasks THEN
                release_element_from_job (sfid, {delete_request_from_vsn_queue} FALSE, assigned_mainframe_lun,
                      ignore_status);
                rmp$log_debug_message (' Issuing query');
                request.request_type := rmc$rbt_query;
                request.query.external_vsn := requested_evsn;
                message_name := 'WAIT_FOR_QUERY';
                message_parameters [1] := ^requested_evsn;
                process_request (acceptable_states, initial_tasks, last_choice_element, message_name,
                      current_date_time_string, request, required_element, server_name,
                      server_entry.server_attributes.timeout, sfid, valid_request_transitions,
                      message_parameters, assigned_mainframe_lun, remaining_tasks, retry_status,
                      selected_element, status);
                check_synchronization (request.request_type, last_sync_error, status);
              ELSEIF rmc$rbt_mount IN remaining_tasks THEN
                IF assigned_mainframe_lun = 0 THEN
                  rmp$log_debug_message (' Selecting element in mount without preceding query');
                  select_element (acceptable_states, sfid, last_choice_element,
                        server_entry.managed_elements_p, {remaining_candidates} NIL, required_element,
                        current_date_time_string, message_parameters, assigned_mainframe_lun,
                        selected_element, status);
                IFEND;
                IF status.normal THEN
                  request.request_type := rmc$rbt_mount;
                  request.mount.element := selected_element;
                  request.mount.external_vsn := requested_evsn;
                  message_name := 'WAIT_FOR_MOUNT';
                  message_parameters [1] := ^requested_evsn;
                  message_parameters [2] := ^selected_element;
                  rmp$log_debug_message (' Issuing mount');
                  process_request ({ignore acceptable_states} $cmt$element_states [], initial_tasks,
                        {last_choice_element} osc$null_name, message_name, current_date_time_string, request,
                        {required_element} osc$null_name, server_name, server_entry.server_attributes.timeout,
                        sfid, valid_request_transitions, message_parameters, ignore_assigned_mainframe_lun,
                        remaining_tasks, retry_status, ignored_element, status);
                  check_synchronization (request.request_type, last_sync_error, status);
                IFEND;
              IFEND;
            UNTIL NOT status.normal;
          IFEND;
          IF (NOT status.normal) THEN
            CASE status.condition OF
            = dme$tape_unit_down, dme$tape_unit_off, dme$unit_assigned, rme$element_not_available =
              IF (required_element <> osc$null_name) THEN
                EXIT /robotic_mount/;
              IFEND;
            = rme$invalid_server_index =
              EXIT /locate_server/;
            = rme$volume_not_mounted, rme$synchronization_error, rme$server_not_defined =
              {try next server} ;
            ELSE
              EXIT /robotic_mount/;
            CASEND;
          IFEND;
        FOREND /locate_server/;
        osp$set_status_condition (rme$volume_not_mounted, status);
      END /robotic_mount/;

      IF status.normal THEN
        job_lun_table_entry^.robotic_mount_info.volume_robotically_mounted := TRUE;
        job_lun_table_entry^.robotic_mount_info.element := selected_element;
        job_lun_table_entry^.robotic_mount_info.server_name := server_name;
        rmp$log_debug_message (' Exiting attempt_robotic_mount with normal status');
        elapsed_time := #FREE_RUNNING_CLOCK (0) - start_time;
        rmp$log_debug_integer (' MOUNT COMPLETE; ELAPSED TIME (secs) = ',
              elapsed_time DIV microseconds_per_second);
      ELSE
        release_element_from_job (sfid, {delete_request_from_vsn_queue} FALSE, assigned_mainframe_lun,
              ignore_status);
        rmp$log_debug_message (' Exiting attempt_robotic_mount with abnormal status');
        rmp$log_debug_status (status);
      IFEND;
      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;
      osp$disestablish_cond_handler;

    PROCEND attempt_robotic_mount;

?? OLDTITLE ??
?? NEWTITLE := '  select_volume', EJECT ??

    PROCEDURE select_volume
      (    sfid: gft$system_file_identifier;
       VAR job_lun_table_entry {input/output} : dmt$tape_lun_table_entry;
       VAR requested_evsn: rmt$external_vsn;
       VAR requested_rvsn: rmt$recorded_vsn;
       VAR requested_volume_attributes: iot$requested_volume_attributes;
       VAR status: ost$status);

?? NEWTITLE := '    operator_menu_for_scratch_tape', EJECT ??

      PROCEDURE operator_menu_for_scratch_tape
        (    label_type: amt$label_type;
             requested_volume_attributes: iot$requested_volume_attributes;
             density: rmt$density;
             previous_evsn: rmt$external_vsn;
             previous_rvsn: rmt$external_vsn;
         VAR evsn: rmt$external_vsn;
         VAR rvsn: rmt$recorded_vsn;
         VAR status: ost$status);

{  PROCEDURE scratch_menu (
{    external_vsn, evsn: any of
{        name 1..6
{        string 1..6
{      anyend = $optional
{    recorded_vsn, rvsn: any of
{        name 1..6
{        string 1..6
{      anyend = $optional
{    )

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
      type2: 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$name_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend,
    recend := [
    [1,
    [90, 5, 10, 12, 36, 17, 884],
    clc$command, 4, 2, 0, 0, 0, 0, 0, ''], [
    ['EVSN                           ',clc$abbreviation_entry, 1],
    ['EXTERNAL_VSN                   ',clc$nominal_entry, 1],
    ['RECORDED_VSN                   ',clc$nominal_entry, 2],
    ['RVSN                           ',clc$abbreviation_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 33, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, 6]],
    8, [[1, 0, clc$string_type], [1, 6, FALSE]]
    ],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$name_type, clc$string_type],
    FALSE, 2],
    5, [[1, 0, clc$name_type], [1, 6]],
    8, [[1, 0, clc$string_type], [1, 6, FALSE]]
    ]];

?? FMT (FORMAT := ON) ??
?? POP ??

        CONST
          p$external_vsn = 1,
          p$recorded_vsn = 2;

        VAR
          pvt: array [1 .. 2] of clt$parameter_value;

        CONST
          number_of_choices = 2;

        VAR
          i: integer,
          ignore_length: integer,
          local_status: ost$status,
          message_parameters: array [1 .. 7] of ^ost$message_parameter,
          parameter_names: ^ost$parameter_help_names,
          reason: string (24),
          response: oft$number_of_choices,
          response_string: ost$string,
          seed_name: pmt$program_name,
          status_line: string (80),
          terminate_reason: string (osc$max_string_size),
          work_area: ^SEQ ( * ),
          work_area_size: ost$positive_integers;

        status.normal := TRUE;
        local_status.normal := TRUE;

        IF label_type = amc$labelled THEN
          seed_name := rmc$extend_labeled_vol_list;
        ELSE
          seed_name := rmc$extend_unlabeled_vol_list;
        IFEND;

        FOR i := 1 TO 7 DO
          message_parameters [i] := NIL;
        FOREND;

        IF requested_volume_attributes.removable_media_group <> osc$null_name THEN
          message_parameters [1] := ^requested_volume_attributes.removable_media_group;
        IFEND;

        IF requested_volume_attributes.removable_media_location <> osc$null_name THEN
          message_parameters [2] := ^requested_volume_attributes.removable_media_location;
        IFEND;

        message_parameters [3] := ^rmv$densities [density];
        message_parameters [4] := ^requested_volume_attributes.family;
        message_parameters [5] := ^requested_volume_attributes.user;
        message_parameters [6] := ^previous_evsn;
        message_parameters [7] := ^previous_rvsn;

        PUSH parameter_names: [1 .. number_of_choices];
        parameter_names^ [1] := 'CONTINUE_REQUEST';
        parameter_names^ [2] := 'TERMINATE_REQUEST';

        work_area := NIL;

      /display_menu/
        WHILE TRUE DO
          ofp$format_operator_menu (seed_name, parameter_names, ^message_parameters,
                number_of_choices, ofc$removable_media_operator, response, response_string, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF (response = 1) THEN { operator wants to mount a scratch volume. }

            IF work_area = NIL THEN
              work_area_size := 2 * (#SIZE (clt$data_value) + #SIZE (rmt$external_vsn));
              PUSH work_area: [[REP work_area_size OF cell]];
            ELSE
              RESET work_area;
            IFEND;

          /scl_environment/
            BEGIN
              clp$evaluate_sub_parameters (response_string.value (1, response_string.size), #SEQ (pdt),
                    work_area, ^pvt, status);
              IF NOT status.normal THEN
                reason := ' Improper expression  ';
                EXIT /scl_environment/;
              IFEND;

              IF pvt [p$external_vsn].specified THEN
                IF pvt [p$external_vsn].value^.kind = clc$name THEN
                  evsn := pvt [p$external_vsn].value^.name_value;
                ELSE { clc$string }
                  rmp$validate_ansi_string (pvt [p$external_vsn].value^.string_value^, evsn, status);
                  IF NOT status.normal THEN
                    reason := ' Illegal external_vsn ';
                    EXIT /scl_environment/;
                  IFEND;
                IFEND;

                IF NOT pvt [p$recorded_vsn].specified THEN
                  rvsn := evsn;
                IFEND;
              IFEND;

              IF pvt [p$recorded_vsn].specified THEN
                IF pvt [p$recorded_vsn].value^.kind = clc$name THEN
                  rvsn := pvt [p$recorded_vsn].value^.name_value;
                ELSE { clc$string }
                  rmp$validate_ansi_string (pvt [p$recorded_vsn].value^.string_value^, rvsn, status);
                  IF NOT status.normal THEN
                    reason := ' Illegal recorded_vsn ';
                    EXIT /scl_environment/;
                  IFEND;
                IFEND;

                IF NOT pvt [p$external_vsn].specified THEN
                  evsn := rvsn;
                IFEND;
              IFEND;

              IF pvt [p$external_vsn].specified OR pvt [p$recorded_vsn].specified THEN
                EXIT /display_menu/;
              ELSE
                reason := ' EVSN or RVSN required';
              IFEND;
            END /scl_environment/;
            status_line := ' ';
            STRINGREP (status_line, ignore_length, 'INVALID RESPONSE: ', response_string.
                  value (1, response_string.size), reason);
            message_parameters [3] := ^status_line;
            CYCLE /display_menu/;

          ELSEIF (response = 2) THEN { operator wants to terminate the scratch request. }
            IF response_string.size > 0 THEN
              terminate_reason := response_string.value (1, response_string.size);
            ELSE
              terminate_reason := 'scratch volume was not available';
            IFEND;
            osp$set_status_abnormal (rmc$resource_management_id, dme$operator_stop, terminate_reason, status);

          IFEND;

          EXIT /display_menu/;
        WHILEND /display_menu/;

      PROCEND operator_menu_for_scratch_tape;
?? OLDTITLE ??
?? EJECT ??

      VAR
        message_name: clt$parameter_name,
        previous_evsn: rmt$external_vsn,
        previous_rvsn: rmt$external_vsn,
        source_pool: ost$name,
        source_pool_location: ost$name;

{ Get value of previous evsn and rvsn.  If current_vsn_index is 1, there is no previous volume.

      IF job_lun_table_entry.current_vsn_index > 1 THEN
        #TRANSLATE (osv$lower_to_upper, job_lun_table_entry.volume_list^
              [job_lun_table_entry.current_vsn_index-1].external_vsn, previous_evsn);
        #TRANSLATE (osv$lower_to_upper, job_lun_table_entry.volume_list^
              [job_lun_table_entry.current_vsn_index-1].recorded_vsn, previous_rvsn);
      ELSE
        previous_evsn := 'None  ';
        previous_rvsn := 'None  ';
      IFEND;
      #TRANSLATE (osv$lower_to_upper, job_lun_table_entry.volume_list^
            [job_lun_table_entry.current_vsn_index].external_vsn, requested_evsn);
      #TRANSLATE (osv$lower_to_upper, job_lun_table_entry.volume_list^
            [job_lun_table_entry.current_vsn_index].recorded_vsn, requested_rvsn);
      #TRANSLATE (osv$lower_to_upper, job_lun_table_entry.requested_volume_attributes.
            account, requested_volume_attributes.account);
      #TRANSLATE (osv$lower_to_upper, job_lun_table_entry.requested_volume_attributes.
            family, requested_volume_attributes.family);
      #TRANSLATE (osv$lower_to_upper, job_lun_table_entry.requested_volume_attributes.
            project, requested_volume_attributes.project);
      #TRANSLATE (osv$lower_to_upper, job_lun_table_entry.requested_volume_attributes.
            removable_media_group, requested_volume_attributes.removable_media_group);
      #TRANSLATE (osv$lower_to_upper, job_lun_table_entry.requested_volume_attributes.
            removable_media_location, requested_volume_attributes.removable_media_location);
      #TRANSLATE (osv$lower_to_upper, job_lun_table_entry.requested_volume_attributes.
            slot, requested_volume_attributes.slot);
      #TRANSLATE (osv$lower_to_upper, job_lun_table_entry.requested_volume_attributes.
            user, requested_volume_attributes.user);
      IF (requested_evsn = rmc$unspecified_vsn) THEN
        IF dmv$initialize_tape_volume.in_progress THEN
          IF (dmv$initialize_tape_volume.element_name = osc$null_name) THEN
            osp$set_status_condition (rme$volume_not_mounted, status);
          IFEND;
        ELSE
          osp$clear_job_signature_lock (rmv$job_tape_table_lock);
          osp$end_subsystem_activity;
          message_name := 'WAIT_SCRATCH_VOLUME';
          message_parameters [1] := ^current_date_time_string.value (1, current_date_time_string.size);
          rmp$put_job_status_display (message_name, NIL {message_parameters} );
          operator_menu_for_scratch_tape (job_lun_table_entry.label_type,
                requested_volume_attributes, job_lun_table_entry.density,
                previous_evsn, previous_rvsn, requested_evsn, requested_rvsn, status);
          osp$set_job_signature_lock (rmv$job_tape_table_lock);
          osp$begin_subsystem_activity;
          IF status.normal THEN
            job_lun_table_entry.volume_list^ [job_lun_table_entry.current_vsn_index].external_vsn :=
                  requested_evsn;
            job_lun_table_entry.volume_list^ [job_lun_table_entry.current_vsn_index].recorded_vsn :=
                  requested_rvsn;
            debug_message_logged := FALSE;
            REPEAT
              IF NOT debug_message_logged THEN
                rmp$log_debug_message (' Calling iop$extend_volume_list_in_rvl');
              IFEND;
              iop$extend_volume_list_in_rvl (sfid, requested_evsn, requested_rvsn,
                    requested_volume_attributes, job_lun_table_entry.current_vsn_index, status);
              IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
                IF NOT debug_message_logged THEN
                  rmp$log_debug_message (' Waiting for tape table lock');
                  debug_message_logged := TRUE;
                IFEND;
                pmp$long_term_wait (one_second, one_second);
              IFEND;
            UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
          IFEND;
        IFEND;
      IFEND;
    PROCEND select_volume;

?? OLDTITLE ??
?? EJECT ??

    VAR
      assigned_mainframe_lun: iot$logical_unit,
      assignment_type: iot$operator_assignment_type,
      debug_message_logged: boolean,
      first_in_queue: boolean,
      ignore_status: ost$status,
      job_lun_table_entry: ^dmt$tape_lun_table_entry,
      message_name: clt$parameter_name,
      requested_rvsn: rmt$recorded_vsn,
      requested_volume_attributes: iot$requested_volume_attributes,
      selected_element: ost$name,
      volume_mounted: boolean,
      wait_message_displayed: boolean;

    status.normal := TRUE;
{ Initialize state variables and SPOIL anything read by condition handler}
    assigned_count_incremented := FALSE;
    element_assigned := FALSE;

    osp$get_current_display_message (original_message);

    #SPOIL (assigned_count_incremented, element_assigned, original_message);

    osp$establish_condition_handler (^activate_volume_handler, TRUE);
    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (rmv$job_tape_table_lock);

  /mount_and_assign/
    BEGIN

      job_lun_table_entry := ^dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index];

{ Determine if volume currently active.
      IF job_lun_table_entry^.lun <> 0 THEN
        osp$set_status_abnormal (rmc$resource_management_id, dme$active_tape_volume, '', status);
        EXIT /mount_and_assign/;
      IFEND;

      requested_density := job_lun_table_entry^.density;
      #SPOIL (requested_density);
      IF NOT status.normal THEN
        EXIT /mount_and_assign/;
      IFEND;

      IF NOT dmv$initialize_tape_volume.in_progress THEN
        IF rmv$job_tape_table_p <> NIL THEN
{ Set tape assigned.  This must be done now, before waiting for the tape to be mounted
{ so other tasks in the same job cannot get tapes if the reserve count is exceeded.
          rmv$job_tape_table_p^.assigned_unit_count [requested_density] :=
                rmv$job_tape_table_p^.assigned_unit_count [requested_density] + 1;
          assigned_count_incremented := TRUE;
          #SPOIL (assigned_count_incremented);
        ELSE
          osp$set_status_condition (dme$reserve_not_effected, status);
          EXIT /mount_and_assign/;
        IFEND;
      IFEND;

      select_volume (sfid, job_lun_table_entry^, requested_evsn, requested_rvsn,
            requested_volume_attributes, status);
      IF NOT status.normal THEN
        EXIT /mount_and_assign/;
      IFEND;

      current_date_time_string.size := 0;
      current_date_time_string.value := '';
      clp$get_date_time_string ('' {get date/time in site defined form} , current_date_time_string,
            ignore_status);

      first_in_queue := FALSE;
      REPEAT
        debug_message_logged := FALSE;
        REPEAT
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Calling iop$queue_volume_assignment');
          IFEND;
          iop$queue_volume_assignment (sfid, job_lun_table_entry^.label_type, requested_density,
                requested_evsn, requested_rvsn, requested_volume_attributes, first_in_queue, status);
          IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Waiting for tape table lock');
              debug_message_logged := TRUE;
            IFEND;
            pmp$long_term_wait (one_second, one_second);
          IFEND;
        UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
        rmp$log_debug_message (' Exiting iop$queue_volume_assignment');
        rmp$log_debug_status (status);
        IF status.normal THEN
          IF (NOT first_in_queue) AND (NOT dmv$initialize_tape_volume.in_progress) THEN
            message_name := 'WAIT_VSN_BUSY';
            message_parameters [1] := ^current_date_time_string.value (1, current_date_time_string.size);
            message_parameters [2] := ^requested_evsn;
            rmp$put_job_status_display (message_name, ^message_parameters);
            rmp$log_debug_message (' Queueing on busy volume.');
            wait (five_minutes); {Wait until another job stops using the volume we're after.}
          IFEND;
        ELSE
          EXIT /mount_and_assign/;
        IFEND;
      UNTIL first_in_queue OR dmv$initialize_tape_volume.in_progress;

      IF dmv$initialize_tape_volume.in_progress AND (dmv$initialize_tape_volume.logical_unit > 0) THEN
        rmp$assign_tape_unit (sfid, dmv$initialize_tape_volume.element_name, $cmt$element_states [cmc$on],
              job_lun_table_entry^.label_type, assigned_mainframe_lun, status);
        #SPOIL (assigned_mainframe_lun);
        EXIT /mount_and_assign/;
      IFEND;

?? EJECT ??
      volume_mounted := FALSE;

      debug_message_logged := FALSE;
    /mount/
      REPEAT
        osp$clear_job_signature_lock (rmv$job_tape_table_lock);
        osp$end_subsystem_activity;
        rmp$log_debug_message (' Entering Attempt Robotic Mount');
        attempt_robotic_mount (sfid, acceptable_states, last_choice_element, required_element,
              assigned_mainframe_lun, selected_element, status);
        osp$set_job_signature_lock (rmv$job_tape_table_lock);
        osp$begin_subsystem_activity;
        IF status.normal THEN
          rmp$log_debug_message (' Attempt Robotic Mount returned normal status - volume mounted');
          volume_mounted := TRUE;
        ELSE
          CASE status.condition OF
          = dme$tape_unit_down, dme$tape_unit_off, dme$tape_unit_undefined, dme$unit_assigned =
            IF dmv$initialize_tape_volume.in_progress THEN
              osp$set_status_abnormal (rmc$resource_management_id, rme$element_not_available,
                    'INITIALIZE_TAPE_VOLUME ', status);
            IFEND;
          = rme$volume_not_mounted =
            rmp$log_debug_message (' Attempt Robotic Mount returned rme$volume_not_mounted');
            status.normal := NOT dmv$initialize_tape_volume.in_progress;
          ELSE
          CASEND;
        IFEND;
        IF status.normal AND (NOT volume_mounted) THEN
          attempt_manual_mount (sfid, selected_element, volume_mounted, status);
          IF status.normal AND volume_mounted THEN
            assign_element_to_job (sfid, acceptable_states, selected_element, assigned_mainframe_lun, status);
            IF NOT status.normal THEN
              volume_mounted := FALSE;
              CASE status.condition OF
              = dme$tape_unit_down, dme$tape_unit_off =
                REPEAT
                  IF NOT debug_message_logged THEN
                    rmp$log_debug_message (' Calling iop$release_assignment_in_rvl');
                  IFEND;
                  iop$release_assignment_in_rvl (sfid, status);
                  IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
                    IF NOT debug_message_logged THEN
                      rmp$log_debug_message (' Waiting for tape table lock');
                      debug_message_logged := TRUE;
                    IFEND;
                    pmp$wait (one_second, one_second);
                  IFEND;
                UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
              ELSE
                EXIT /mount_and_assign/;
              CASEND
            IFEND;
          IFEND;
        IFEND;
      UNTIL volume_mounted OR (NOT status.normal);

    END /mount_and_assign/;

    IF status.normal THEN
      job_lun_table_entry^.lun := assigned_mainframe_lun;
      job_lun_table_entry^.job_recovery_active := FALSE;
      element_assigned := TRUE;
      IF assigned_mainframe_lun <> 0 THEN
        rmp$log_debug_message (' Job_lun_table_entry now contains mainframe lun #');
        rmp$log_debug_message (' Tape unit assigned to job');
      ELSE
        rmp$log_debug_message (' ERROR - Stored zero mainframe lun in job_lun_table_entry');
      IFEND;
      #SPOIL (element_assigned);

      IF dmv$initialize_tape_volume.in_progress AND (dmv$initialize_tape_volume.element_name = osc$null_name)
            THEN
        dmv$initialize_tape_volume.element_name := selected_element;
      IFEND;
    ELSEIF assigned_count_incremented THEN
      IF rmv$job_tape_table_p^.assigned_unit_count [requested_density] > 0 THEN
        rmv$job_tape_table_p^.assigned_unit_count [requested_density] :=
              rmv$job_tape_table_p^.assigned_unit_count [requested_density] - 1;
      IFEND;
      assigned_count_incremented := FALSE;
      #SPOIL (assigned_count_incremented);
      rmp$log_debug_message (
            ' Decremented assignment count due to abnormal exit in rmp$activate_client_volume');
    IFEND;

    osp$clear_job_signature_lock (rmv$job_tape_table_lock);
    osp$end_subsystem_activity;
    osp$disestablish_cond_handler;
    ofp$clear_operator_message (ofc$removable_media_operator, ignore_status);
    wait_message_displayed := TRUE;
    osp$clear_wait_message (original_message, wait_message_displayed);
    rmp$log_debug_message (' Exiting rmp$activate_volume');

  PROCEND rmp$activate_volume;

?? OLDTITLE ??
?? NEWTITLE := 'rmp$deactivate_volume', EJECT ??

  PROCEDURE [XDCL] rmp$deactivate_volume
    (    sfid: gft$system_file_identifier;
         delete_request_from_vsn_queue: boolean;
     VAR status: ost$status);

    VAR
      assignment_count_decremented: boolean,
      element_released: boolean,
      original_message: oft$display_message,
      volume_dismounted: boolean;

?? NEWTITLE := '  deactivate_volume_handler', EJECT ??

    PROCEDURE deactivate_volume_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        debug_status: ost$status,
        ignore_status: ost$status,
        local_status: ost$status,
        lock_status: ost$signature_lock_status,
        wait_message_displayed: boolean;

      rmp$log_debug_message (' Entering deactivate_volume_handler');
      osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, debug_status,
            ignore_status);
      CASE condition.selector OF

      = pmc$block_exit_processing =

        wait_message_displayed := TRUE;
        osp$clear_wait_message (original_message, wait_message_displayed);

        osp$test_signature_lock (rmv$job_tape_table_lock, lock_status, local_status);
        IF local_status.normal AND (lock_status = osc$sls_locked_by_current_task) THEN
          osp$clear_job_signature_lock (rmv$job_tape_table_lock);
          osp$end_subsystem_activity;
        IFEND;

        release_tape_resources;

      = ifc$interactive_condition =

        CASE condition.interactive_condition OF
        = ifc$terminate_break =
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
                ignore_status);
          EXIT rmp$deactivate_volume;
        = ifc$pause_break, ifc$job_reconnect =
          ifp$invoke_pause_utility (ignore_status);
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;

      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;
      rmp$log_debug_message (' Exiting deactivate_volume_handler');

    PROCEND deactivate_volume_handler;

?? OLDTITLE ??
?? NEWTITLE := '  release_tape_resources', EJECT ??

    PROCEDURE release_tape_resources;

      VAR
        ignore_status: ost$status,
        local_status: ost$status,
        lun: iot$logical_unit,
        lun_table_entry: ^dmt$tape_lun_table_entry;

      osp$set_job_signature_lock (rmv$job_tape_table_lock);
      osp$begin_subsystem_activity;

      IF dmv$tape_job_lun_table_p <> NIL THEN
        lun_table_entry := ^dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index];
        lun := lun_table_entry^.lun;
      ELSE
        lun := 0;
      IFEND;

      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;

      IF NOT volume_dismounted THEN
        rmp$log_debug_message (' Calling dismount_volume');
        volume_dismounted := TRUE;
        #SPOIL (volume_dismounted);
        dismount_volume (sfid, local_status);
        rmp$log_debug_message (' Exited dismount_volume');
        rmp$log_debug_status (local_status);
        osp$copy_local_status_to_status (local_status, status);
      IFEND;

      osp$set_job_signature_lock (rmv$job_tape_table_lock);
      osp$begin_subsystem_activity;

    /release/
      BEGIN
        IF lun = 0 THEN
          EXIT /release/;
        IFEND;

        IF NOT element_released THEN
          release_element_from_job (sfid, delete_request_from_vsn_queue, lun, status);
          element_released := TRUE;
          #SPOIL (element_released);
          IF NOT status.normal THEN
            rmp$log_debug_message (' Exiting with abnormal status:');
            rmp$log_debug_status (status);
            EXIT /release/;
          IFEND;
        IFEND;

        IF NOT dmv$initialize_tape_volume.in_progress THEN
          IF NOT assignment_count_decremented THEN
            requested_density := lun_table_entry^.density;
            IF rmv$job_tape_table_p <> NIL THEN
              IF rmv$job_tape_table_p^.assigned_unit_count [requested_density] > 0 THEN
                rmv$job_tape_table_p^.assigned_unit_count [requested_density] :=
                      rmv$job_tape_table_p^.assigned_unit_count [requested_density] - 1;
                assignment_count_decremented := TRUE;
                #SPOIL (assignment_count_decremented);
                rmp$log_debug_message (' Decremented assignment count');
              IFEND;
            IFEND;
          IFEND;
        IFEND;

{ Clear logical unit number to indicate no currently assigned volume.
        lun_table_entry^.lun := 0;

      END /release/;

      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;

    PROCEND release_tape_resources;

?? OLDTITLE ??
?? EJECT ??

    VAR
      elapsed_time: integer,
      start_time: integer,
      wait_message_displayed: boolean;

    rmp$log_debug_message (' Entering rmp$deactivate_volume');
    status.normal := TRUE;
    start_time := #FREE_RUNNING_CLOCK (0);
    assignment_count_decremented := FALSE;
    element_released := FALSE;
    volume_dismounted := FALSE;
    osp$get_current_display_message (original_message);
    #SPOIL (assignment_count_decremented, element_released, volume_dismounted, original_message);

    osp$establish_condition_handler (^deactivate_volume_handler, {handle block exit} TRUE);

    release_tape_resources;

    osp$disestablish_cond_handler;

    wait_message_displayed := TRUE;
    osp$clear_wait_message (original_message, wait_message_displayed);
    rmp$log_debug_message ('Exiting rmp$deactivate_volume.');
    elapsed_time := #FREE_RUNNING_CLOCK (0) - start_time;
    rmp$log_debug_integer (' DISMOUNT COMPLETE; ELAPSED TIME (secs) = ',
          elapsed_time DIV microseconds_per_second);

  PROCEND rmp$deactivate_volume;

?? OLDTITLE ??
?? NEWTITLE := 'assign_element_to_job', EJECT ??

  PROCEDURE assign_element_to_job
    (    sfid: gft$system_file_identifier;
         acceptable_states: cmt$element_states;
         selected_element: cmt$element_name;
     VAR assigned_mainframe_lun: iot$logical_unit;
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      label_type: amt$label_type,
      local_mainframe_lun: iot$logical_unit;

    label_type := dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].label_type;
    log_debug_assignment ('Attempting to assign Element: ', selected_element);
    rmp$assign_tape_unit (sfid, selected_element, acceptable_states, label_type, local_mainframe_lun, status);
    rmp$log_debug_status (status);
    IF status.normal THEN
      log_debug_assignment ('Assigned Element: ', selected_element);
      assigned_mainframe_lun := local_mainframe_lun;
    ELSE
      assigned_mainframe_lun := 0;
    IFEND;
  PROCEND assign_element_to_job;
?? OLDTITLE ??
?? NEWTITLE := 'check_synchronization', EJECT ??

  PROCEDURE check_synchronization
    (    current_request: rmt$rbt_request_type;
     VAR last_sync_error: rmt$rbt_supported_requests;
     VAR {input, output} status: ost$status);

    VAR
      ignore_status: ost$status;

    IF status.normal THEN
      last_sync_error := $rmt$rbt_supported_requests [];
    ELSEIF status.condition = rme$synchronization_error THEN
      IF last_sync_error = $rmt$rbt_supported_requests [] THEN
        last_sync_error := $rmt$rbt_supported_requests [current_request];
        rmp$log_debug_message (' First sync error detected - retrying.');
        status.normal := TRUE;
      ELSEIF current_request IN last_sync_error THEN
        rmp$log_debug_message (' Second and final sync error.');
        last_sync_error := $rmt$rbt_supported_requests [];
      ELSE
        last_sync_error := $rmt$rbt_supported_requests [current_request];
        rmp$log_debug_message (' Consecutive sync errors on different requests.');
        status.normal := TRUE;
      IFEND;
    ELSE
      last_sync_error := $rmt$rbt_supported_requests [];
      rmp$log_debug_message (' ERROR - process_request returned unexpected abnormal status.');
      rmp$log_debug_status (status);
    IFEND;
  PROCEND check_synchronization;
?? OLDTITLE ??
?? NEWTITLE := 'client_emit_messages', EJECT ??

  PROCEDURE client_emit_messages
    (    retry_count: ost$non_negative_integers;
         server_messages: iot$robotic_server_messages;
     VAR status: ost$status);

    status.normal := TRUE;

    IF (ioc$job_log_message IN server_messages.requested_messages) AND
          (retry_count = server_messages.job_log.issue_prior_to_retry_attempt) THEN
      emit_log_message (pmc$job_log, server_messages.job_log.message, status);
    IFEND;

    IF (ioc$job_status_message IN server_messages.requested_messages) AND
          (retry_count >= server_messages.job_status_display.issue_prior_to_retry_attempt) THEN
      emit_job_status_message (server_messages.job_status_display.message, status);
    IFEND;

    IF (ioc$operator_action_message IN server_messages.requested_messages) AND
          (retry_count = server_messages.operator_action.issue_prior_to_retry_attempt) THEN
      emit_operator_action_message (server_messages.operator_action.message, status);
    IFEND;

    IF (ioc$system_log_message IN server_messages.requested_messages) AND
          (retry_count = server_messages.system_log.issue_prior_to_retry_attempt) THEN
      emit_log_message (pmc$system_log, server_messages.system_log.message, status);
    IFEND;

  PROCEND client_emit_messages;

?? OLDTITLE ??
?? NEWTITLE := 'dismount_volume', EJECT ??

  PROCEDURE dismount_volume
    (    sfid: gft$system_file_identifier;
     VAR status: ost$status);

    VAR
      server_name: ost$name;

?? NEWTITLE := '  robotic_dismount_handler', EJECT ??

    PROCEDURE robotic_dismount_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        debug_status: ost$status,
        ignore_status: ost$status,
        local_status: ost$status,
        lock_status: ost$signature_lock_status;

      rmp$log_debug_message (' Entering robotic_dismount_handler');
      osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, debug_status,
            ignore_status);
      rmp$log_debug_status (debug_status);
      CASE condition.selector OF

      = pmc$block_exit_processing =

        IF request_submitted THEN
          debug_message_logged := FALSE;
          REPEAT
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Calling iop$client_cancel_request');
            IFEND;
            iop$client_cancel_request (server_name, sfid, local_status);
            IF NOT local_status.normal AND (local_status.condition = dme$unable_to_lock_tape_table) THEN
              IF NOT debug_message_logged THEN
                rmp$log_debug_message (' Waiting for tape table lock');
                debug_message_logged := TRUE;
              IFEND;
              pmp$long_term_wait (one_second, one_second);
            IFEND;
          UNTIL local_status.normal OR (local_status.condition <> dme$unable_to_lock_tape_table);
          rmp$log_debug_message ('Called iop$client_cancel_request');
          rmp$log_debug_status (local_status);
        IFEND;
        osp$test_signature_lock (rmv$job_tape_table_lock, lock_status, local_status);
        IF local_status.normal AND (lock_status = osc$sls_locked_by_current_task) THEN
          osp$end_subsystem_activity;
          osp$clear_job_signature_lock (rmv$job_tape_table_lock);
        IFEND;

      = ifc$interactive_condition =

        CASE condition.interactive_condition OF
        = ifc$terminate_break =
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
                ignore_status);
          EXIT dismount_volume;
        = ifc$pause_break, ifc$job_reconnect =
          ifp$invoke_pause_utility (ignore_status);
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;

      = pmc$user_defined_condition =
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        IF condition.user_condition_name = osc$job_recovery_condition_name THEN
          status.normal := TRUE;
          EXIT dismount_volume;
        IFEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;
      rmp$log_debug_message (' Exiting robotic_dismount_handler');

    PROCEND robotic_dismount_handler;
?? OLDTITLE ??
?? EJECT ??

    VAR
      current_date_time_string: ost$string,
      debug_message_logged: boolean,
      element: cmt$element_name,
      external_vsn: rmt$external_vsn,
      ignored_element: cmt$element_name,
      ignore_assigned_mainframe_lun: iot$logical_unit,
      ignore_status: ost$status,
      initial_tasks: rmt$rbt_supported_requests,
      job_lun_table_entry: ^dmt$tape_lun_table_entry,
      last_sync_error: rmt$rbt_supported_requests,
      local_status: ost$status,
      message_name: clt$parameter_name,
      message_parameters: array [1 .. 2] of ^ost$message_parameter,
      remaining_tasks: rmt$rbt_supported_requests,
      request: rmt$rbt_request,
      required_requests: rmt$rbt_supported_requests,
      retry_status: retry_status_info,
      server_entry: iot$robotic_server_entry,
      server_index: iot$robotic_server_index,
      server_located: boolean,
      valid_request_transitions: rmt$rbt_supported_requests;

    current_date_time_string.size := 0;
    current_date_time_string.value := '';
    clp$get_date_time_string ('' {get date/time in site defined form} , current_date_time_string,
          ignore_status);

    initial_tasks := $rmt$rbt_supported_requests [rmc$rbt_dismount];

    last_sync_error := $rmt$rbt_supported_requests [];

    remaining_tasks := initial_tasks;

    request_submitted := FALSE;

    retry_status.retry_in_progress := FALSE;

    valid_request_transitions := $rmt$rbt_supported_requests [rmc$rbt_force_dismount, rmc$rbt_dismount];


?? EJECT ??
    status.normal := TRUE;
    #SPOIL (request_submitted);
    osp$establish_condition_handler (^robotic_dismount_handler, {handle block exit} TRUE);

  /robotic_dismount/
    BEGIN
      osp$set_job_signature_lock (rmv$job_tape_table_lock);
      osp$begin_subsystem_activity;

      job_lun_table_entry := ^dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index];

      IF job_lun_table_entry^.robotic_mount_info.volume_robotically_mounted THEN
        element := job_lun_table_entry^.robotic_mount_info.element;

        external_vsn := job_lun_table_entry^.volume_list^ [job_lun_table_entry^.current_vsn_index].
              external_vsn;

        server_name := job_lun_table_entry^.robotic_mount_info.server_name;
        #SPOIL (server_name);

        server_located := FALSE;

      /locate_server/
        FOR server_index := 1 TO ioc$max_server_index DO
          debug_message_logged := FALSE;
          REPEAT
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Calling iop$get_server_entry');
            IFEND;
            iop$get_server_entry (server_index, server_entry, local_status);
            IF NOT local_status.normal AND (local_status.condition = dme$unable_to_lock_tape_table) THEN
              IF NOT debug_message_logged THEN
                rmp$log_debug_message (' Waiting for tape table lock');
                debug_message_logged := TRUE;
              IFEND;
              wait (one_second);
            IFEND;
          UNTIL local_status.normal OR (local_status.condition <> dme$unable_to_lock_tape_table);
          IF local_status.normal THEN
            IF server_entry.server_name = server_name THEN
              server_located := TRUE;
              EXIT /locate_server/;
            IFEND;
          ELSEIF local_status.condition = rme$invalid_server_index THEN
            EXIT /locate_server/;
          IFEND;
        FOREND /locate_server/;

        IF server_located THEN

          REPEAT
            message_parameters [1] := ^current_date_time_string.value (1, current_date_time_string.size);
            message_parameters [2] := NIL;
            IF status.normal AND (remaining_tasks = $rmt$rbt_supported_requests []) THEN
              EXIT /robotic_dismount/;
            ELSEIF rmc$rbt_force_dismount IN remaining_tasks THEN
              request.request_type := rmc$rbt_force_dismount;
              request.force_dismount.element := element;
              message_name := 'WAIT_FOR_FORCE';
              message_parameters [1] := ^element;
              rmp$log_debug_message (' Issuing force dismount');
              process_request ({ignore acceptable_states} $cmt$element_states [], initial_tasks,
                    {last_choice_element} osc$null_name, message_name, current_date_time_string, request,
                    {required_element} osc$null_name, server_name, server_entry.server_attributes.timeout,
                    sfid, valid_request_transitions, message_parameters, ignore_assigned_mainframe_lun,
                    remaining_tasks, retry_status, ignored_element, status);
              check_synchronization (request.request_type, last_sync_error, status);
            ELSEIF rmc$rbt_dismount IN remaining_tasks THEN
              request.request_type := rmc$rbt_dismount;
              request.dismount.element := element;
              request.dismount.external_vsn := external_vsn;
              message_name := 'WAIT_FOR_DISMOUNT';
              message_parameters [1] := ^external_vsn;
              message_parameters [2] := ^element;
              rmp$log_debug_message (' Issuing dismount');
              process_request ({ignore acceptable_states} $cmt$element_states [], initial_tasks,
                    {last_choice_element} osc$null_name, message_name, current_date_time_string, request,
                    {required_element} osc$null_name, server_name, server_entry.server_attributes.timeout,
                    sfid, valid_request_transitions, message_parameters, ignore_assigned_mainframe_lun,
                    remaining_tasks, retry_status, ignored_element, status);
              check_synchronization (request.request_type, last_sync_error, status);
            IFEND;
          UNTIL NOT status.normal;
        ELSE {do not wait for server to become defined}
          status.normal := TRUE;
        IFEND;
      IFEND;
    END /robotic_dismount/;

    job_lun_table_entry^.robotic_mount_info.volume_robotically_mounted := FALSE;
    osp$clear_job_signature_lock (rmv$job_tape_table_lock);
    osp$end_subsystem_activity;
    osp$disestablish_cond_handler;
    rmp$log_debug_message (' Exiting client dismount');

  PROCEND dismount_volume;
?? OLDTITLE ??
?? NEWTITLE := 'emit_job_status_message', EJECT ??

  PROCEDURE emit_job_status_message
    (    server_message: ost$status_message;
     VAR status: ost$status);

    VAR
      message_text: ^ost$status_message_line,
      message_text_size: ost$status_message_line_size;

    status.normal := TRUE;

    message_text := osp$status_message_text (^server_message);
    message_text_size := STRLENGTH (message_text^);
    IF message_text_size > ofc$max_display_message THEN
      message_text_size := ofc$max_display_message;
    IFEND;

    ofp$display_status_message (message_text^ (1, message_text_size), status);
    rmp$log_debug_message (message_text^ (1, message_text_size));

  PROCEND emit_job_status_message;
?? OLDTITLE ??
?? NEWTITLE := 'emit_log_message', EJECT ??

  PROCEDURE emit_log_message
    (    log_type: pmt$ascii_logs;
         server_message: ost$status_message;
     VAR status: ost$status);

    VAR
      message_text: ^ost$status_message_line,
      message_area: ^ost$status_message,
      message_line_count: ^ost$status_message_line_count,
      message_text_size: ^ost$status_message_line_size;

    VAR
      line: ost$status_message_line_count;

    status.normal := TRUE;

    message_area := ^server_message;
    RESET message_area;
    NEXT message_line_count IN message_area;
    FOR line := 1 TO message_line_count^ DO
      NEXT message_text_size IN message_area;
      NEXT message_text: [message_text_size^] IN message_area;
      pmp$log_ascii (message_text^ (2, * ), $pmt$ascii_logset [log_type], pmc$msg_origin_program, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND emit_log_message;
?? OLDTITLE ??
?? NEWTITLE := 'emit_operator_action_message', EJECT ??

  PROCEDURE emit_operator_action_message
    (    server_message: ost$status_message;
     VAR status: ost$status);

    VAR
      formatted_message: oft$formatted_operator_message,
      line_count: oft$number_of_displayable_lines;

    status.normal := TRUE;

    ofp$format_operator_message (server_message, 1, formatted_message, line_count);

    ofp$send_formatted_operator_msg (formatted_message, ofc$removable_media_operator,
          {acknowledgement_allowed} FALSE, status);

  PROCEND emit_operator_action_message;
?? OLDTITLE ??
?? NEWTITLE := 'log_debug_assignment', EJECT ??

  PROCEDURE log_debug_assignment
    (    explanation: string ( * );
         element: cmt$element_name);

    VAR
      line: string (80),
      length: integer;

    STRINGREP (line, length, explanation, element);
    rmp$log_debug_message (line (1, length));
  PROCEND log_debug_assignment;
?? OLDTITLE ??
?? NEWTITLE := 'log_debug_retry', EJECT ??

  PROCEDURE log_debug_retry
    (    response: iot$formatted_server_response);

    VAR
      line: string (80),
      length: integer,
      requests: [READ, oss$job_paged_literal] array [rmc$rbt_query .. rmc$rbt_force_dismount] of string (14)
            := ['Query         ', 'Mount          ', 'Dismount      ', 'Force_dismount'];

    STRINGREP (line, length, ' Request_id: ', response.request_id, ' Server_event_code:  ',
          response.server_event_code);
    rmp$log_debug_message (line (1, length));

    STRINGREP (line, length, ' Current_request: ', requests [response.current_request], ' Next_request:  ',
          requests [response.next_request]);
    rmp$log_debug_message (line (1, length));

    STRINGREP (line, length, ' Retry_delay_interval: ', response.retry_delay_interval, ' Retry_limit:  ',
          response.retry_limit);
    rmp$log_debug_message (line (1, length));

  PROCEND log_debug_retry;
?? OLDTITLE ??
?? NEWTITLE := 'process_request', EJECT ??

  PROCEDURE process_request
    (    acceptable_states: cmt$element_states;
         initial_tasks: rmt$rbt_supported_requests;
         last_choice_element: cmt$element_name;
         message_name: clt$parameter_name;
         current_date_time_string: ost$string;
         request: rmt$rbt_request;
         required_element: cmt$element_name;
         server_name: ost$name;
         server_timeout: ost$positive_integers;
         sfid: gft$system_file_identifier;
         valid_request_transitions: rmt$rbt_supported_requests;
     VAR message_parameters: array [1 .. 2] of ^ost$message_parameter;
     VAR assigned_mainframe_lun: iot$logical_unit;
     VAR remaining_tasks: rmt$rbt_supported_requests;
     VAR retry_status: retry_status_info;
     VAR selected_element: cmt$element_name;
     VAR status: ost$status);

    VAR
      current_time: integer,
      debug_message_logged: boolean,
      duration: integer,
      elapsed_time: integer,
      ignore_status: ost$status,
      local_status: ost$status,
      request_id: rmt$rbt_request_id,
      response: iot$formatted_server_response,
      submittal_time: integer;

?? OLDTITLE ??
?? NEWTITLE := '  process_request_handler  ', EJECT ??

    PROCEDURE process_request_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      CASE condition.selector OF
      = ifc$interactive_condition =
        CASE condition.interactive_condition OF
        = ifc$pause_break, ifc$job_reconnect =
          ifp$invoke_pause_utility (ignore_status);
        = ifc$terminate_break =
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
                ignore_status);
          EXIT process_request;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;

    PROCEND process_request_handler;

?? NEWTITLE := '  process_response', EJECT ??

    PROCEDURE process_response
      (    acceptable_states: cmt$element_states;
           initial_tasks: rmt$rbt_supported_requests;
           last_choice_element: cmt$element_name;
           request: rmt$rbt_request;
           required_element: cmt$element_name;
           response: iot$formatted_server_response;
           server_name: ost$name;
           sfid: gft$system_file_identifier;
           valid_request_transitions: rmt$rbt_supported_requests;
       VAR assigned_mainframe_lun: iot$logical_unit;
       VAR retry_status: retry_status_info;
       VAR remaining_tasks: rmt$rbt_supported_requests;
       VAR selected_element: cmt$element_name;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status;

?? NEWTITLE := '    process_query_response', EJECT ??

      PROCEDURE process_query_response
        (    acceptable_states: cmt$element_states;
             initial_tasks: rmt$rbt_supported_requests;
             last_choice_element: cmt$element_name;
             request: rmt$rbt_request;
             required_element: cmt$element_name;
             response: iot$formatted_server_response;
             server_name: ost$name;
             sfid: gft$system_file_identifier;
         VAR assigned_mainframe_lun: iot$logical_unit;
         VAR remaining_tasks {input/output} : rmt$rbt_supported_requests;
         VAR selected_element: cmt$element_name;
         VAR status: ost$status);

        VAR
          i: integer,
          ignore_status: ost$status,
          message_name: clt$parameter_name,
          preferred_candidates: ^array [1 .. * ] of cmt$element_name,
          remaining_candidates: ^array [1 .. * ] of cmt$element_name;

?? EJECT ??
        IF response.query.external_vsn = request.query.external_vsn THEN
          IF response.query.volume_located AND response.query.already_mounted THEN
            IF required_element <> osc$null_name THEN
              IF required_element = response.query.element THEN
                rmp$log_debug_message ('   Required element = already mounted element.');
                rmp$log_debug_message ('   Assigning required_element');
                assign_element_to_job (sfid, acceptable_states, required_element, assigned_mainframe_lun,
                      status);
                IF status.normal THEN
                  selected_element := required_element;
                  remaining_tasks := $rmt$rbt_supported_requests [];
                  rmp$log_debug_message (' Tape unit assigned to job');
                IFEND;
              ELSE {volume is not in the required drive}
                rmp$log_debug_message ('   Required_element-  Volume is not in correct drive.');
                rmp$log_debug_message ('   Attempting to assign the drive for purpose of force dismount');
                assign_element_to_job (sfid, acceptable_states, response.query.element,
                      assigned_mainframe_lun, status);
                IF status.normal THEN
                  remaining_tasks := remaining_tasks + $rmt$rbt_supported_requests [rmc$rbt_force_dismount];
                  selected_element := response.query.element;
                  rmp$log_debug_message (' Tape unit assigned to job');
                IFEND;
              IFEND;
            ELSE {volume already mounted and no required element}
              rmp$log_debug_message ('   Volume already mounted.');
              assign_element_to_job (sfid, acceptable_states, response.query.element, assigned_mainframe_lun,
                    status);
              IF status.normal THEN
                selected_element := response.query.element;
                remaining_tasks := $rmt$rbt_supported_requests [];
                rmp$log_debug_message (' Tape unit assigned to job');
              ELSE
                IF NOT dmv$initialize_tape_volume.in_progress THEN
                  CASE status.condition OF
                  = dme$tape_unit_down, dme$tape_unit_off =
                    message_name := 'WAIT_ROBOTIC_UNIT';
                    message_parameters [1] := ^current_date_time_string.value
                          (1, current_date_time_string.size);
                    message_parameters [2] := ^requested_evsn;
                    rmp$put_job_status_display (message_name, ^message_parameters);
                    message_name := 'ROBOTIC_UNIT_UNAVAILABLE';
                    message_parameters [1] := ^requested_evsn;
                    message_parameters [2] := ^response.query.element;
                    rmp$emit_operator_message (message_name, ^message_parameters,
                          {acknowledgement_allowed} FALSE, ignore_status);
                    wait (five_seconds);
                    status.normal := TRUE {retry query} ;
                  = dme$unit_assigned =
                    message_name := 'WAIT_VSN_BUSY';
                    message_parameters [1] := ^current_date_time_string.value
                          (1, current_date_time_string.size);
                    message_parameters [2] := ^requested_evsn;
                    rmp$put_job_status_display (message_name, ^message_parameters);
                    wait (five_minutes); {Wait for element to be released}
                    status.normal := TRUE {retry query} ;
                  CASEND
                IFEND;
              IFEND;
            IFEND;
          ELSEIF response.query.volume_located THEN
            IF response.query.preferred_candidates <> NIL THEN
              PUSH preferred_candidates: [LOWERBOUND (response.query.
                    preferred_candidates^) .. UPPERBOUND (response.query.preferred_candidates^)];
              FOR i := 1 TO UPPERBOUND (response.query.preferred_candidates^) DO
                preferred_candidates^ [i] := response.query.preferred_candidates^ [i];
              FOREND;
            ELSE
              preferred_candidates := NIL;
            IFEND;
            IF response.query.remaining_candidates <> NIL THEN
              PUSH remaining_candidates: [LOWERBOUND (response.query.
                    remaining_candidates^) .. UPPERBOUND (response.query.remaining_candidates^)];
              FOR i := 1 TO UPPERBOUND (response.query.remaining_candidates^) DO
                remaining_candidates^ [i] := response.query.remaining_candidates^ [i];
              FOREND;
            ELSE
              remaining_candidates := NIL;
            IFEND;
            select_element (acceptable_states, sfid, last_choice_element, preferred_candidates,
                  remaining_candidates, required_element, current_date_time_string, message_parameters,
                  assigned_mainframe_lun, selected_element, status);
            IF status.normal THEN
              remaining_tasks := remaining_tasks - $rmt$rbt_supported_requests [rmc$rbt_query];
            IFEND;
          ELSE
            rmp$log_debug_message (' Volume not in library.');
            osp$set_status_condition (rme$volume_not_mounted, status);
          IFEND;
        ELSE
          osp$set_status_condition (rme$synchronization_error, status);
        IFEND;
      PROCEND process_query_response;
?? OLDTITLE ??
?? NEWTITLE := '    process_request_retry', EJECT ??

      PROCEDURE process_request_retry
        (    initial_tasks: rmt$rbt_supported_requests;
             request: rmt$rbt_request;
             response: iot$formatted_server_response;
             valid_request_transitions: rmt$rbt_supported_requests;
         VAR remaining_tasks {input/output} : rmt$rbt_supported_requests;
         VAR retry_status {input/output} : retry_status_info;
         VAR status: ost$status);

        VAR
          ignore_status: ost$status,
          local_status: ost$status,
          message_name: clt$parameter_name;

        rmp$log_debug_message (' Entered Process Request Retry');
        log_debug_retry (response);
        IF request.request_type = response.current_request THEN
          IF retry_status.retry_in_progress THEN
            message_name := 'WAIT_SERVER_RETRY';
            message_parameters [1] := ^current_date_time_string.value (1, current_date_time_string.size);
            message_parameters [2] := ^requested_evsn;
            rmp$put_job_status_display (message_name, ^message_parameters);

            IF retry_status.server_event_code = response.server_event_code THEN
              retry_status.retry_count := retry_status.retry_count + 1;
              client_emit_messages (retry_status.retry_count, response.server_messages^, ignore_status);
              IF retry_status.retry_count > retry_status.retry_limit THEN
                IF retry_status.next_request IN valid_request_transitions THEN
                  remaining_tasks := remaining_tasks +
                        $rmt$rbt_supported_requests [retry_status.next_request];
                ELSE {start over}
                  remaining_tasks := initial_tasks;
                IFEND;
                retry_status.retry_in_progress := FALSE;
                ofp$clear_operator_message (ofc$removable_media_operator, ignore_status);
              ELSE
                wait (retry_status.retry_delay_interval);
              IFEND;
            ELSE {new event encountered}
              ofp$clear_operator_message (ofc$removable_media_operator, ignore_status);

              retry_status.next_request := response.next_request;
              retry_status.retry_count := 1;
              retry_status.retry_delay_interval := response.retry_delay_interval;
              retry_status.retry_limit := response.retry_limit;
              retry_status.server_event_code := response.server_event_code;
              client_emit_messages (retry_status.retry_count, response.server_messages^, ignore_status);
              wait (retry_status.retry_delay_interval);
              retry_status.retry_in_progress := TRUE;
            IFEND;
          ELSE {retry not in progress}
            retry_status.next_request := response.next_request;
            retry_status.retry_count := 1;
            retry_status.retry_delay_interval := response.retry_delay_interval;
            retry_status.retry_limit := response.retry_limit;
            retry_status.server_event_code := response.server_event_code;
            client_emit_messages (retry_status.retry_count, response.server_messages^, ignore_status);
            wait (retry_status.retry_delay_interval);
            retry_status.retry_in_progress := TRUE;
          IFEND;
        ELSE
          osp$set_status_condition (rme$synchronization_error, status);
        IFEND;
      PROCEND process_request_retry;
?? OLDTITLE ??
?? EJECT ??
      status.normal := TRUE;
      IF response.request_processed THEN
        retry_status.retry_in_progress := FALSE;
        IF response.processed_request = request.request_type THEN
          CASE response.processed_request OF
          = rmc$rbt_force_dismount =
            IF response.force_dismount.element = request.force_dismount.element THEN
              remaining_tasks := remaining_tasks - $rmt$rbt_supported_requests
                    [rmc$rbt_dismount, rmc$rbt_force_dismount];
              rmp$log_debug_message (' Force Dismount processed');
            ELSE
              osp$set_status_condition (rme$synchronization_error, status);
            IFEND;
          = rmc$rbt_dismount =
            IF (response.dismount.element = request.dismount.element) AND
                  (response.dismount.external_vsn = request.dismount.external_vsn) THEN
              rmp$log_debug_message (' Dismount processed');
              remaining_tasks := remaining_tasks - $rmt$rbt_supported_requests [rmc$rbt_dismount];
            ELSE
              osp$set_status_condition (rme$synchronization_error, status);
            IFEND;
          = rmc$rbt_mount =
            IF (response.mount.element = request.mount.element) AND
                  (response.mount.external_vsn = request.mount.external_vsn) THEN
              remaining_tasks := remaining_tasks - $rmt$rbt_supported_requests [rmc$rbt_mount];
              rmp$log_debug_message (' Mount processed');
            ELSE
              osp$set_status_condition (rme$synchronization_error, status);
            IFEND;
          = rmc$rbt_query =
            process_query_response (acceptable_states, initial_tasks, last_choice_element, request,
                  required_element, response, server_name, sfid, assigned_mainframe_lun, remaining_tasks,
                  selected_element, status);
            rmp$log_debug_message (' Query processed');
          CASEND;
        ELSE
          osp$set_status_condition (rme$synchronization_error, status);
        IFEND;
      ELSE
        process_request_retry (initial_tasks, request, response, valid_request_transitions, remaining_tasks,
              retry_status, status);
      IFEND;
      rmp$log_debug_message (' Exiting Process Response');
    PROCEND process_response;
?? OLDTITLE ??
?? EJECT ??
    debug_message_logged := FALSE;
    REPEAT
      IF NOT debug_message_logged THEN
        rmp$log_debug_message (' Calling iop$client_put_request');
      IFEND;
      iop$client_put_request (server_name, sfid, request, request_id, status);
      IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
        IF NOT debug_message_logged THEN
          rmp$log_debug_message (' Waiting for tape table lock');
          debug_message_logged := TRUE;
        IFEND;
        osp$establish_condition_handler (^process_request_handler, {handle block exit} FALSE);
        pmp$long_term_wait (one_second, one_second);
        osp$disestablish_cond_handler;
      IFEND;
    UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
    IF status.normal THEN
      duration := server_timeout {in milliseconds} ;
      request_submitted := TRUE;
      #SPOIL (request_submitted);
      submittal_time := #FREE_RUNNING_CLOCK (0);

    /wait_loop/
      REPEAT
        rmp$put_job_status_display (message_name, ^message_parameters);
        wait (duration);
        debug_message_logged := FALSE;
        REPEAT
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Calling iop$client_get_response');
          IFEND;
          iop$client_get_response (server_name, request_id, response, status);
          IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Waiting for tape table lock');
              debug_message_logged := TRUE;
            IFEND;
            osp$establish_condition_handler (^process_request_handler, {handle block exit} FALSE);
            pmp$long_term_wait (one_second, one_second);
            osp$disestablish_cond_handler;
          IFEND;
        UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
        IF status.normal THEN
          process_response (acceptable_states, initial_tasks, last_choice_element, request, required_element,
                response, server_name, sfid, valid_request_transitions, assigned_mainframe_lun, retry_status,
                remaining_tasks, selected_element, status);
          debug_message_logged := FALSE;
          REPEAT
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Calling iop$client_delete_request');
            IFEND;
            iop$client_delete_request (server_name, request_id, local_status);
            IF NOT local_status.normal AND (local_status.condition = dme$unable_to_lock_tape_table) THEN
              IF NOT debug_message_logged THEN
                rmp$log_debug_message (' Waiting for tape table lock');
                debug_message_logged := TRUE;
              IFEND;
              osp$establish_condition_handler (^process_request_handler, {handle block exit} FALSE);
              pmp$long_term_wait (one_second, one_second);
              osp$disestablish_cond_handler;
            IFEND;
          UNTIL local_status.normal OR (local_status.condition <> dme$unable_to_lock_tape_table);
          request_submitted := FALSE;
          #SPOIL (request_submitted);
          EXIT /wait_loop/;
        ELSEIF status.condition = rme$response_unavailable THEN
          current_time := #FREE_RUNNING_CLOCK (0);
          elapsed_time := current_time - submittal_time;
          IF elapsed_time >= microseconds_per_millisecond THEN
            duration := server_timeout - (elapsed_time DIV microseconds_per_millisecond);
            IF duration > 0 THEN
              status.normal := TRUE;
              CYCLE /wait_loop/;
            ELSE
              rmp$log_debug_integer (' TIMEOUT - current_time   (Us): ', current_time);
              rmp$log_debug_integer (' TIMEOUT - submittal_time (Us): ', submittal_time);
              rmp$log_debug_integer (' TIMEOUT - elapsed_time   (Us): ', elapsed_time);
              osp$set_status_condition (rme$synchronization_error, status);
              debug_message_logged := FALSE;
              REPEAT
                IF NOT debug_message_logged THEN
                  rmp$log_debug_message (' Calling iop$client_cancel_request');
                IFEND;
                iop$client_cancel_request (server_name, sfid, local_status);
                IF NOT local_status.normal AND (local_status.condition = dme$unable_to_lock_tape_table) THEN
                  IF NOT debug_message_logged THEN
                    rmp$log_debug_message (' Waiting for tape table lock');
                    debug_message_logged := TRUE;
                  IFEND;
                  osp$establish_condition_handler (^process_request_handler, {handle block exit} FALSE);
                  pmp$long_term_wait (one_second, one_second);
                  osp$disestablish_cond_handler;
                IFEND;
              UNTIL local_status.normal OR (local_status.condition <> dme$unable_to_lock_tape_table);
              rmp$log_debug_message ('Called iop$client_cancel_request');
              rmp$log_debug_status (local_status);
            IFEND;
          ELSE
            status.normal := TRUE;
            CYCLE /wait_loop/;
          IFEND;
        ELSEIF status.condition = rme$request_not_found THEN
          osp$set_status_condition (rme$synchronization_error, status);
        IFEND;
      UNTIL NOT status.normal;
    ELSEIF status.condition = rme$client_request_active THEN
      debug_message_logged := FALSE;
      REPEAT
        IF NOT debug_message_logged THEN
          rmp$log_debug_message (' Calling iop$client_cancel_request');
        IFEND;
        iop$client_cancel_request (server_name, sfid, local_status);
        IF NOT local_status.normal AND (local_status.condition = dme$unable_to_lock_tape_table) THEN
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Waiting for tape table lock');
            debug_message_logged := TRUE;
          IFEND;
          osp$establish_condition_handler (^process_request_handler, {handle block exit} FALSE);
          pmp$long_term_wait (one_second, one_second);
          osp$disestablish_cond_handler;
        IFEND;
      UNTIL local_status.normal OR (local_status.condition <> dme$unable_to_lock_tape_table);
      rmp$log_debug_message ('Called iop$client_cancel_request');
      rmp$log_debug_status (local_status);
      osp$set_status_condition (rme$synchronization_error, status);
    IFEND;

  PROCEND process_request;?? OLDTITLE ??
?? NEWTITLE := 'release_element_from_job', EJECT ??

  PROCEDURE release_element_from_job
    (    sfid: gft$system_file_identifier;
         delete_request_from_vsn_queue: boolean;
     VAR assigned_mainframe_lun {input/output} : iot$logical_unit;
     VAR status: ost$status);

    VAR
      local_status: ost$status;

    status.normal := TRUE;
    IF assigned_mainframe_lun > 0 THEN
      rmp$log_debug_integer ('Attempting to release Logical Unit: ', assigned_mainframe_lun);
      rmp$release_tape_unit (sfid, assigned_mainframe_lun, delete_request_from_vsn_queue, status);
      rmp$log_debug_status (status);

      assigned_mainframe_lun := 0;
      #SPOIL (assigned_mainframe_lun);
    IFEND;
  PROCEND release_element_from_job;
?? OLDTITLE ??
?? NEWTITLE := 'select_element', EJECT ??

  PROCEDURE select_element
    (    acceptable_states: cmt$element_states;
         sfid: gft$system_file_identifier;
         last_choice_element: cmt$element_name;
         preferred_candidates: ^array [1 .. * ] of cmt$element_name;
         remaining_candidates: ^array [1 .. * ] of cmt$element_name;
         required_element: cmt$element_name;
         current_date_time_string: ost$string;
     VAR message_parameters: array [1 .. 2] of ^ost$message_parameter;
     VAR assigned_mainframe_lun: iot$logical_unit;
     VAR selected_element: cmt$element_name;
     VAR status: ost$status);

?? NEWTITLE := '  operator_menu_for_monopoly', EJECT ??

    PROCEDURE operator_menu_for_monopoly
      (    message_name: pmt$program_name;
           requested_evsn: rmt$external_vsn;
           requested_density: rmt$density;
       VAR status: ost$status);

      CONST
        number_of_choices = 2;

      VAR
        menu_parameters: array [1 .. 2] of ^string ( * ),
        parameter_names: ^ost$parameter_help_names,
        response: oft$number_of_choices,
        response_string: ost$string,
        terminate_reason: string (osc$max_string_size);

      status.normal := TRUE;

      menu_parameters [1] := ^rmv$densities [requested_density];
      menu_parameters [2] := ^requested_evsn;

      PUSH parameter_names: [1 .. number_of_choices];
      parameter_names^ [1] := 'CONTINUE_REQUEST';
      parameter_names^ [2] := 'TERMINATE_REQUEST';

      ofp$format_operator_menu (message_name, parameter_names, ^menu_parameters, number_of_choices,
            ofc$removable_media_operator, response, response_string, status);
      IF status.normal THEN
        CASE response OF
        = 1 = { operator wants to mount volume manually.}
          osp$set_status_condition (rme$volume_not_mounted, status);
        = 2 = { operator wants to terminate the  request. }
          IF response_string.size > 0 THEN
            terminate_reason := response_string.value (1, response_string.size);
          ELSE
            terminate_reason := 'your job required more robotic tape units ' CAT
                  'than are currently available.';
          IFEND;
          osp$set_status_abnormal (rmc$resource_management_id, dme$operator_stop, terminate_reason, status);
        ELSE
        CASEND;
      IFEND;

    PROCEND operator_menu_for_monopoly;

?? OLDTITLE ??
?? NEWTITLE := '  select_element_handler  ', EJECT ??

    PROCEDURE select_element_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      CASE condition.selector OF
      = ifc$interactive_condition =
        CASE condition.interactive_condition OF
        = ifc$pause_break, ifc$job_reconnect =
          ifp$invoke_pause_utility (ignore_status);
        = ifc$terminate_break =
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
                ignore_status);
          EXIT select_element;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;

    PROCEND select_element_handler;

?? OLDTITLE ??
?? NEWTITLE := '  validate_candidate', EJECT ??

    PROCEDURE validate_candidate
      (    acceptable_states: cmt$element_states;
           element: cmt$element_name;
           preferred_candidates: ^array [1 .. * ] of cmt$element_name,
           remaining_candidates: ^array [1 .. * ] of cmt$element_name;
       VAR status: ost$status);

      VAR
        i: integer;

      status.normal := TRUE;
      IF preferred_candidates <> NIL THEN
        FOR i := LOWERBOUND (preferred_candidates^) TO UPPERBOUND (preferred_candidates^) DO
          IF element = preferred_candidates^ [i] THEN
            debug_message_logged := FALSE;
            REPEAT
              IF NOT debug_message_logged THEN
                rmp$log_debug_message (' Calling iop$validate_candidate_element');
              IFEND;
              iop$validate_candidate_element (element, acceptable_states, status);
              IF NOT status.normal THEN
                IF status.condition = dme$unable_to_lock_tape_table THEN
                  IF NOT debug_message_logged THEN
                    rmp$log_debug_message (' Waiting for tape table lock');
                    debug_message_logged := TRUE;
                  IFEND;
                  osp$establish_condition_handler (^select_element_handler, {handle block exit} FALSE);
                  pmp$long_term_wait (one_second, one_second);
                  osp$disestablish_cond_handler;
                IFEND;
              ELSE
                RETURN;
              IFEND;
            UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
          IFEND;
        FOREND;
      IFEND;

      IF remaining_candidates <> NIL THEN
        FOR i := LOWERBOUND (remaining_candidates^) TO UPPERBOUND (remaining_candidates^) DO
          IF element = remaining_candidates^ [i] THEN
            debug_message_logged := FALSE;
            REPEAT
              IF NOT debug_message_logged THEN
                rmp$log_debug_message (' Calling iop$validate_candidate_element');
              IFEND;
              iop$validate_candidate_element (element, acceptable_states, status);
              IF NOT status.normal THEN
                IF status.condition = dme$unable_to_lock_tape_table THEN
                  IF NOT debug_message_logged THEN
                    rmp$log_debug_message (' Waiting for tape table lock');
                    debug_message_logged := TRUE;
                  IFEND;
                  osp$establish_condition_handler (^select_element_handler, {handle block exit} FALSE);
                  pmp$long_term_wait (one_second, one_second);
                  osp$disestablish_cond_handler;
                IFEND;
              ELSE
                RETURN;
              IFEND;
            UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
          IFEND;
        FOREND;
      IFEND;

      osp$set_status_abnormal (rmc$resource_management_id, rme$element_not_available, 'CLIENT_MOUNT_VOLUME',
            status);
    PROCEND validate_candidate;
?? OLDTITLE ??
?? EJECT ??

    VAR
      debug_message_logged: boolean,
      last_choice_encountered_once: boolean,
      message_name: clt$parameter_name;

    IF (preferred_candidates <> NIL) OR (remaining_candidates <> NIL) THEN
      IF required_element <> osc$null_name THEN
        validate_candidate (acceptable_states, required_element, preferred_candidates, remaining_candidates,
              status);
        IF status.normal THEN
          rmp$log_debug_message ('   Required_element-  volume not already mounted.');
          assign_element_to_job (sfid, acceptable_states, required_element, assigned_mainframe_lun, status);
          IF status.normal THEN
            selected_element := required_element;
          IFEND;
        IFEND;
      ELSE {select first available candidate}
        last_choice_encountered_once := FALSE;

      /select_loop/
        REPEAT
          debug_message_logged := FALSE;
          REPEAT
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Calling iop$select_best_element');
            IFEND;
            iop$select_best_element (preferred_candidates, remaining_candidates, selected_element, status);
            IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
              IF NOT debug_message_logged THEN
                rmp$log_debug_message (' Waiting for tape table lock');
                debug_message_logged := TRUE;
              IFEND;
              osp$establish_condition_handler (^select_element_handler, {handle block exit} FALSE);
              pmp$long_term_wait (one_second, one_second);
              osp$disestablish_cond_handler;
            IFEND;
          UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
          rmp$log_debug_message ('Called iop$select_best_element');
          rmp$log_debug_status (status);
          IF status.normal THEN
            IF selected_element = last_choice_element THEN
              IF NOT last_choice_encountered_once THEN
                last_choice_encountered_once := TRUE;
                message_name := 'WAIT_ROBOTIC_UNIT';
                message_parameters [1] := ^current_date_time_string.value (1, current_date_time_string.size);
                message_parameters [2] := ^requested_evsn;
                rmp$put_job_status_display (message_name, ^message_parameters);
                wait (five_minutes);{Wait for another managed element to be returned.}
                CYCLE /select_loop/;
              IFEND;
            IFEND;
          ELSEIF status.condition = rme$robotic_element_monopoly THEN
            message_name := rmc$robotic_element_monopoly;
            operator_menu_for_monopoly (message_name, requested_evsn, requested_density, status);
            CYCLE /select_loop/;
          ELSEIF status.condition = rme$element_not_available THEN
            IF dmv$initialize_tape_volume.in_progress THEN
              EXIT /select_loop/;
            ELSE
              message_name := 'WAIT_ROBOTIC_UNIT';
              message_parameters [1] := ^current_date_time_string.value (1, current_date_time_string.size);
              message_parameters [2] := ^requested_evsn;
              rmp$put_job_status_display (message_name, ^message_parameters);
              wait (five_minutes) {Wait for robotic element availability} ;
              status.normal := TRUE;
              CYCLE /select_loop/;
            IFEND;
          ELSE
            EXIT /select_loop/;
          IFEND;
          rmp$log_debug_message ('   Selected candidate element.');
          assign_element_to_job (sfid, acceptable_states, selected_element, assigned_mainframe_lun, status);
          IF status.normal THEN
            EXIT /select_loop/;
          ELSE {we picked an unavailable element; try again}
            rmp$log_debug_message ('    Selected candidate became unavailable.');
            status.normal := TRUE;
          IFEND;
        UNTIL NOT status.normal;
      IFEND;
    ELSE
      osp$set_status_condition (rme$synchronization_error, status);
    IFEND;

  PROCEND select_element;
?? NEWTITLE := 'wait', EJECT ??

  PROCEDURE wait
    (    duration: 0 .. 0ffffffffffff(16));

    VAR
      ignore_status: ost$status;

    IF duration > 0 THEN
      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;

      rmp$log_debug_integer (' Entering wait for (msec) : ', duration);
      pmp$long_term_wait (duration, duration);
      rmp$log_debug_message (' Exiting wait');

      osp$set_job_signature_lock (rmv$job_tape_table_lock);
      osp$begin_subsystem_activity;
    IFEND;
  PROCEND wait;
?? OLDTITLE ??
MODEND rmm$manage_client_volumes_223;
*DECK DECK=RMM$MANAGE_RESERVATIONS_223 EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Resource Management : Reserve and release tape units to/from a job', EJECT ??
MODULE rmm$manage_reservations_223;

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc cmt$element_states
*copyc dme$tape_errors
*copyc gft$system_file_identifier
*copyc amt$label_type
*copyc oss$job_pageable
*copyc oss$job_paged_literal
*copyc oss$mainframe_paged_literal
*copyc ost$status
*copyc rmc$reserve_tape
*copyc rmd$tape_declarations
*copyc rme$condition_codes
*copyc rmt$density
*copyc rmt$external_vsn
*copyc rmt$job_tape_table
*copyc rmt$recorded_vsn
*copyc rmt$supported_tape_densities

?? POP ??
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_integer
*copyc clp$get_date_time_string
*copyc dmp$acquire_tape_resource
*copyc dmp$return_tape_resource
*copyc ifp$invoke_pause_utility
*copyc iop$assign_tape_unit
*copyc iop$get_density_states
*copyc iop$get_selected_element
*copyc iop$release_tape_unit
*copyc ofp$display_status_message
*copyc ofp$format_operator_menu
*copyc osp$append_status_parameter
*copyc osp$begin_subsystem_activity
*copyc osp$clear_job_signature_lock
*copyc osp$clear_wait_message
*copyc osp$disestablish_cond_handler
*copyc osp$end_subsystem_activity
*copyc osp$establish_condition_handler
*copyc osp$format_message
*copyc osp$get_current_display_message
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$test_signature_lock
*copyc pmp$continue_to_cause
*copyc pmp$long_term_wait
*copyc pmp$wait
*copyc rmp$log_debug_message
*copyc rmp$log_debug_status
*copyc rmp$put_job_status_display
*copyc sfp$update_job_limit_accum
*copyc dmv$tape_job_lun_table_p
*copyc osv$job_pageable_heap
*copyc osv$lower_to_upper
?? OLDTITLE ??
?? NEWTITLE := 'Global Variables Declared by This Module', EJECT ??

  CONST
    one_second = 1000 {milliseconds},
    thirty_seconds = 30000 {milliseconds};

  VAR
    rmv$job_tape_table_default: [XDCL, READ, oss$mainframe_paged_literal] rmt$job_tape_table :=
          [FALSE, FALSE, [0, 0, 0, 0], [0, 0, 0, 0]],
    rmv$job_tape_table_lock: [XDCL, STATIC, oss$job_pageable] ost$signature_lock := [0],
    rmv$job_tape_table_p: [XDCL, STATIC, oss$job_pageable] ^rmt$job_tape_table := NIL,

?? FMT (FORMAT := OFF) ??
    implicit_reservation: [READ, oss$job_paged_literal] array [rmt$supported_tape_densities] of
          rmt$tape_reservation := [
          [{rmc$800} 1, {rmc$1600} 0, {rmc$6250} 0, {rmc$38000} 0],
          [{rmc$800} 0, {rmc$1600} 1, {rmc$6250} 0, {rmc$38000} 0],
          [{rmc$800} 0, {rmc$1600} 0, {rmc$6250} 1, {rmc$38000} 0],
          [{rmc$800} 0, {rmc$1600} 0, {rmc$6250} 0, {rmc$38000} 1]];
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
?? NEWTITLE := 'rmp$assign_tape_unit', EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$assign_tape_unit
    (    sfid: gft$system_file_identifier;
         element_name: cmt$element_name;
         acceptable_states: cmt$element_states;
         label_type: amt$label_type;
     VAR logical_unit: iot$logical_unit;
     VAR status: ost$status);

    VAR
      debug_message_logged: boolean;

?? OLDTITLE ??
?? EJECT ??

  debug_message_logged := FALSE;
  REPEAT
    IF NOT debug_message_logged THEN
      rmp$log_debug_message (' Calling iop$assign_tape_unit');
    IFEND;
    iop$assign_tape_unit (sfid, element_name, acceptable_states, label_type, logical_unit, status);
    IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
      IF NOT debug_message_logged THEN
        rmp$log_debug_message (' Waiting for tape table lock');
        debug_message_logged := TRUE;
      IFEND;
      pmp$wait (one_second, one_second);
    IFEND;
  UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
  rmp$log_debug_message (' Exiting rmp$assign_tape_unit');
  rmp$log_debug_status (status);
PROCEND rmp$assign_tape_unit;

?? OLDTITLE ??
?? NEWTITLE := 'rmp$clear_explicit_reserve', EJECT ??

PROCEDURE [XDCL, #GATE] rmp$clear_explicit_reserve
  (    reservation: rmt$tape_reservation;
   VAR status: ost$status);

?? NEWTITLE := '  clear_explicit_reserve_handler', EJECT ??
  PROCEDURE clear_explicit_reserve_handler
    (    condition: pmt$condition;
         p_condition_info: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR condition_status: ost$status);

    VAR
      ignore_status: ost$status,
      local_status: ost$status,
      lock_status: ost$signature_lock_status;

    CASE condition.selector OF
    = ifc$interactive_condition =
      CASE condition.interactive_condition OF
      = ifc$pause_break, ifc$job_reconnect =
        ifp$invoke_pause_utility (ignore_status);
      = ifc$terminate_break =
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
              ignore_status);
        EXIT rmp$clear_explicit_reserve;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;
    = pmc$block_exit_processing =
      osp$test_signature_lock (rmv$job_tape_table_lock, lock_status,
            local_status);
      IF local_status.normal AND (lock_status = osc$sls_locked_by_current_task)
            THEN
        osp$end_subsystem_activity;
        osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      IFEND;
    ELSE
      pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
    CASEND;
  PROCEND clear_explicit_reserve_handler;
?? OLDTITLE ??

?? EJECT ??

*copy rmi$block_exit_handler
?? EJECT ??

  VAR
    count_of_units_released: integer,
    debug_message_logged: boolean,
    density: rmt$density,
    reserved_units: integer,
    released_reservation: rmt$tape_reservation;

{
{ NOTE - THIS PROCEDURE MUST NOT BE CALLED WHEN PERFORMING AN INITIALIZE_TAPE_VOLUME.
{

  status.normal := TRUE;

/job_tables_interlocked/
  BEGIN

    osp$establish_condition_handler (^clear_explicit_reserve_handler, {handle block exit} TRUE);
    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (rmv$job_tape_table_lock);

    IF (rmv$job_tape_table_p <> NIL) AND (rmv$job_tape_table_p^.explicit_reservation) THEN
      FOR density := rmc$800 TO rmc$maximum_density DO
        IF reservation [density] <> UPPERVALUE (reservation [density]) THEN
          IF reservation [density] <= rmv$job_tape_table_p^.reserved_unit_count [density] THEN
            released_reservation [density] := reservation [density];
          ELSE
            osp$set_status_condition (dme$release_exceeds_reserve, status);
            EXIT /job_tables_interlocked/;
          IFEND;
        ELSE
          released_reservation [density] := rmv$job_tape_table_p^.reserved_unit_count [density];
        IFEND;
        IF released_reservation [density] > rmv$job_tape_table_p^.reserved_unit_count [density] -
              rmv$job_tape_table_p^.assigned_unit_count [density] THEN
          osp$set_status_condition (dme$release_active_tape, status);
          EXIT /job_tables_interlocked/;
        IFEND;

      FOREND;

      IF NOT rmv$job_tape_table_p^.job_recovery_active THEN
        debug_message_logged := FALSE;
        REPEAT
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Calling dmp$return_tape_resource');
          IFEND;
          dmp$return_tape_resource (released_reservation, status);
          IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Waiting for tape table lock');
              debug_message_logged := TRUE;
            IFEND;
            osp$clear_job_signature_lock (rmv$job_tape_table_lock);
            osp$end_subsystem_activity;
            pmp$long_term_wait (one_second, one_second);
            osp$begin_subsystem_activity;
            osp$set_job_signature_lock (rmv$job_tape_table_lock);
          IFEND;
        UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
      IFEND;

      reserved_units := 0;
      FOR density := rmc$800 TO rmc$maximum_density DO
        rmv$job_tape_table_p^.reserved_unit_count [density] :=
              rmv$job_tape_table_p^.reserved_unit_count [density] - released_reservation [density];
        reserved_units := reserved_units + rmv$job_tape_table_p^.reserved_unit_count [density];
      FOREND;
      IF reserved_units = 0 THEN
        FREE rmv$job_tape_table_p IN osv$job_pageable_heap^;
      IFEND;
{ Adjust magnetic tape job limit accumulator.

      count_of_units_released := -(released_reservation [rmc$800] + released_reservation [rmc$1600] +
            released_reservation [rmc$6250] + released_reservation [rmc$38000]);
      sfp$update_job_limit_accum (avc$magnetic_tape_limit_name, count_of_units_released,
            sfc$incremental_update, status);
    IFEND;

  END /job_tables_interlocked/;

  osp$clear_job_signature_lock (rmv$job_tape_table_lock);
  osp$end_subsystem_activity;
  osp$disestablish_cond_handler;

PROCEND rmp$clear_explicit_reserve;
?? OLDTITLE ??
?? NEWTITLE := 'rmp$clear_implicit_reserve', EJECT ??

PROCEDURE [XDCL] rmp$clear_implicit_reserve
  (    density: rmt$density;
   VAR status: ost$status);

*copy rmi$block_exit_handler
{
{ NOTE - THIS PROCEDURE MUST NOT BE CALLED WHEN PERFORMING AN INITIALIZE_TAPE_VOLUME.
{
  status.normal := TRUE;
  osp$establish_condition_handler (^rmp$block_exit_handler, {handle block exit} TRUE);
  osp$begin_subsystem_activity;
  osp$set_job_signature_lock (rmv$job_tape_table_lock);

  IF (density >= rmc$800) AND (density <= rmc$38000) THEN
    IF (rmv$job_tape_table_p <> NIL) AND (NOT rmv$job_tape_table_p^.explicit_reservation) THEN
      IF rmv$job_tape_table_p^.assigned_unit_count [density] > 0 THEN
        osp$set_status_condition (dme$release_active_tape, status);
      ELSE
        sfp$update_job_limit_accum (avc$magnetic_tape_limit_name, {count_of_units_released} - 1,
              sfc$incremental_update, status);
        FREE rmv$job_tape_table_p IN osv$job_pageable_heap^;
      IFEND;
    IFEND;
  ELSE
    osp$set_status_condition (dme$density_not_supported, status);
  IFEND;

  IF status.normal THEN
    rmp$log_debug_message (' Implicit reserve cleared.');
  ELSE
    rmp$log_debug_message (' Implicit reserve not cleared.');
  IFEND;

PROCEND rmp$clear_implicit_reserve;
?? OLDTITLE ??
?? NEWTITLE := 'rmp$get_selected_element', EJECT ??

PROCEDURE [XDCL] rmp$get_selected_element
  (    sfid: gft$system_file_identifier;
       external_vsn: rmt$external_vsn;
       recorded_vsn: rmt$recorded_vsn;
       density: rmt$density;
   VAR element_name: cmt$element_name;
   VAR status: ost$status);

    VAR
      debug_message_logged: boolean;

?? NEWTITLE := '  get_selected_element_handler', EJECT ??

  PROCEDURE get_selected_element_handler
    (    condition: pmt$condition;
         p_condition_info: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR condition_status: ost$status);

    VAR
      ignore_status: ost$status;

    CASE condition.selector OF
    = ifc$interactive_condition =
      CASE condition.interactive_condition OF
      = ifc$pause_break, ifc$job_reconnect =
        ifp$invoke_pause_utility (ignore_status);
      = ifc$terminate_break =
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
              ignore_status);
        EXIT rmp$get_selected_element;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;
    ELSE
      pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
    CASEND;

  PROCEND get_selected_element_handler;

?? OLDTITLE ??
?? EJECT ??

  debug_message_logged := FALSE;
  REPEAT
    IF NOT debug_message_logged THEN
      rmp$log_debug_message (' Calling iop$get_selected_element');
    IFEND;
    iop$get_selected_element (sfid, external_vsn, recorded_vsn, density, element_name, status);
    IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
      IF NOT debug_message_logged THEN
        rmp$log_debug_message (' Waiting for tape table lock');
        debug_message_logged := TRUE;
      IFEND;
      osp$establish_condition_handler (^get_selected_element_handler, {handle block exit} FALSE);
      pmp$long_term_wait (one_second, one_second);
      osp$disestablish_cond_handler;
    IFEND;
  UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);

PROCEND rmp$get_selected_element;

?? OLDTITLE ??
?? NEWTITLE := 'rmp$recover_job_tape_table', EJECT ??

PROCEDURE [XDCL, #GATE] rmp$recover_job_tape_table
  (VAR job_has_tapes_assigned: boolean;
   VAR fatal_reserve_error: boolean);

  VAR
    count: integer,
    debug_message_logged: boolean,
    density: rmt$density,
    i: iot$no_of_tape_units,
    reserve_complete: boolean,
    reservation: rmt$tape_reservation,
    status: ost$status;

?? NEWTITLE := '  recover_job_tape_table_handler', EJECT ??

  PROCEDURE recover_job_tape_table_handler
    (    condition: pmt$condition;
         p_condition_info: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR condition_status: ost$status);

    VAR
      ignore_status: ost$status;

    CASE condition.selector OF
    = ifc$interactive_condition =
      CASE condition.interactive_condition OF
      = ifc$pause_break, ifc$job_reconnect =
        ifp$invoke_pause_utility (ignore_status);
      = ifc$terminate_break =
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
              ignore_status);
        EXIT rmp$recover_job_tape_table;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;
    ELSE
      pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
    CASEND;

  PROCEND recover_job_tape_table_handler;

?? OLDTITLE ??
?? EJECT ??

  job_has_tapes_assigned := FALSE;
  fatal_reserve_error := FALSE;

  IF dmv$tape_job_lun_table_p <> NIL THEN { possible tapes assigned
    FOR i := 1 TO UPPERBOUND (dmv$tape_job_lun_table_p^.tape_file^) DO
      IF dmv$tape_job_lun_table_p^.tape_file^ [i].slot_in_use THEN
        IF dmv$tape_job_lun_table_p^.tape_file^ [i].lun <> 0 THEN { tape is mounted
          dmv$tape_job_lun_table_p^.tape_file^ [i].lun := 0; { invalidate logical unit number
          dmv$tape_job_lun_table_p^.tape_file^ [i].job_recovery_active := TRUE;
          job_has_tapes_assigned := TRUE;
        IFEND;
      IFEND;
    FOREND;
  IFEND;

  IF rmv$job_tape_table_p <> NIL THEN { job had tapes reserved
    rmv$job_tape_table_p^.job_recovery_active := TRUE;
    IF rmv$job_tape_table_p^.explicit_reservation THEN
      count := 0;
      FOR density := rmc$800 TO rmc$maximum_density DO
        reservation [density] := rmv$job_tape_table_p^.reserved_unit_count [density];
        count := count + reservation [density];
      FOREND;
      IF count > 0 THEN { job had explicit reserves - attempt to reclaim reserves
        debug_message_logged := FALSE;
        REPEAT
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Calling dmp$acquire_tape_resource');
          IFEND;
          dmp$acquire_tape_resource (reservation, reserve_complete, status);
          IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Waiting for tape table lock');
              debug_message_logged := TRUE;
            IFEND;
            osp$establish_condition_handler (^recover_job_tape_table_handler, {handle block exit} FALSE);
            pmp$long_term_wait (one_second, one_second);
            osp$disestablish_cond_handler;
          IFEND;
        UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);

        IF NOT reserve_complete OR NOT status.normal THEN

{ Reserve could not be done at this time.  This can be caused by one of the following:
{  1.  Tape units that were ON before the system failed are now OFF or DOWN.  The job will
{      still recover and attempt to reclaim the reserves when the first tape operation is
{      performed.  At that time, an operator menu will appear if the condition still exists.
{  2.  Waiting for tapes reserved by other jobs.  This condition should never occur here unless
{      the number of ON tape drives is less now that before the system failure.  The job will
{      still recover and attempt to reclaim the reserves when the first tape operation is
{      performed.  At that time, the job will wait for other jobs reserves to be released.
{  3.  There are physically less tape drives now that before the system failure.  In this case
{      the job will NOT recover since it can never reclaim the reserves and proceed.

          IF NOT status.normal THEN
            IF NOT (status.condition = dme$not_enough_in_on_state) THEN
              fatal_reserve_error := TRUE;
            IFEND;
          IFEND;
          RETURN;
        IFEND;
      IFEND;
    IFEND;
{ Reserves were successfully reclaimed or reserve was implicit.
{ Set job_tape_table flag to FALSE to indicate this.
    rmv$job_tape_table_p^.job_recovery_active := FALSE;
  IFEND;

PROCEND rmp$recover_job_tape_table;

?? OLDTITLE ??
?? NEWTITLE := 'rmp$release_tape_unit', EJECT ??

PROCEDURE [XDCL, #GATE] rmp$release_tape_unit
  (    sfid: gft$system_file_identifier;
       logical_unit: iot$logical_unit;
       delete_request_from_vsn_queue: boolean;
   VAR status: ost$status);

    VAR
      debug_message_logged: boolean;

?? OLDTITLE ??
?? EJECT ??

  debug_message_logged := FALSE;
  REPEAT
    IF NOT debug_message_logged THEN
      rmp$log_debug_message (' Calling iop$release_tape_unit');
    IFEND;
    iop$release_tape_unit (sfid, logical_unit, delete_request_from_vsn_queue, status);
    IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
      IF NOT debug_message_logged THEN
        rmp$log_debug_message (' Waiting for tape table lock');
        debug_message_logged := TRUE;
      IFEND;
      pmp$wait (one_second, one_second);
    IFEND;
  UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);

  rmp$log_debug_message (' Exiting rmp$release_tape_unit');
  rmp$log_debug_status (status);

PROCEND rmp$release_tape_unit;

?? OLDTITLE ??
?? NEWTITLE := 'rmp$set_explicit_reserve ', EJECT ??

PROCEDURE [XDCL, #GATE] rmp$set_explicit_reserve
  (    reservation: rmt$tape_reservation;
   VAR status: ost$status);

  VAR
    allocated_job_tape_table: boolean,
    original_message: oft$display_message,
    reserve_complete: boolean,
    updated_job_limits: boolean;

?? NEWTITLE := '  abnormal_cleanup', EJECT ??

  PROCEDURE abnormal_cleanup;

    VAR
      debug_message_logged: boolean,
      local_status: ost$status,
      wait_message_displayed: boolean;

?? OLDTITLE ??
?? NEWTITLE := '  abnormal_cleanup_handler', EJECT ??
  PROCEDURE abnormal_cleanup_handler
    (    condition: pmt$condition;
         p_condition_info: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR condition_status: ost$status);

    VAR
      ignore_status: ost$status;

    CASE condition.selector OF
    = ifc$interactive_condition =
      CASE condition.interactive_condition OF
      = ifc$pause_break, ifc$job_reconnect =
        ifp$invoke_pause_utility (ignore_status);
      = ifc$terminate_break =
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
              ignore_status);
        EXIT rmp$set_explicit_reserve;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;
    ELSE
      pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
    CASEND;
  PROCEND abnormal_cleanup_handler;

    IF allocated_job_tape_table THEN
      FREE rmv$job_tape_table_p IN osv$job_pageable_heap^;
      allocated_job_tape_table := FALSE;
      #SPOIL (allocated_job_tape_table);
    IFEND;

    IF reserve_complete THEN
      debug_message_logged := FALSE;
      REPEAT
        IF NOT debug_message_logged THEN
          rmp$log_debug_message (' Calling dmp$return_tape_resource');
        IFEND;
        dmp$return_tape_resource (reservation, local_status);
        IF NOT local_status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Waiting for tape table lock');
            debug_message_logged := TRUE;
          IFEND;
          osp$establish_condition_handler (^abnormal_cleanup_handler, {handle block exit} FALSE);
          pmp$long_term_wait (one_second, one_second);
          osp$disestablish_cond_handler;
        IFEND;
      UNTIL local_status.normal OR (local_status.condition <> dme$unable_to_lock_tape_table);
      reserve_complete := FALSE;
      #SPOIL (reserve_complete);
    IFEND;

    IF updated_job_limits THEN
      sfp$update_job_limit_accum (avc$magnetic_tape_limit_name, -count_of_units_requested,
            sfc$incremental_update, ignore_status);
      updated_job_limits := FALSE;
      #SPOIL (updated_job_limits);
    IFEND;

    wait_message_displayed := TRUE;
    osp$clear_wait_message (original_message, wait_message_displayed);

  PROCEND abnormal_cleanup;

?? OLDTITLE ??
?? NEWTITLE := '  operator_menu_for_tape_reserve', EJECT ??

  PROCEDURE operator_menu_for_tape_reserve
    (    required_resources: rmt$tape_reservation;
     VAR status: ost$status);

    CONST
      default_reserve_wait = 30,
      number_of_choices = 3,
      number_of_parameters = 8;

?? FMT (FORMAT := OFF) ??
        VAR
          density_strings: [READ, oss$job_paged_literal] array [rmc$800 .. rmc$maximum_density] OF record
            value: string (10),
            blanks_required: 0 .. 3,
          recend := [
                {} ['MT9$800   ', 3],
                {} ['MT9$1600  ', 2],
                {} ['MT9$6250  ', 2],
                {} ['MT18$38000', 0]];

?? FMT (FORMAT := ON) ??

    VAR
      counts_string: string (20),
      current_date_time_string: ost$string,
      debug_message_logged: boolean,
      density: rmt$density,
      density_states: array [rmc$800 .. rmc$maximum_density] of iot$density_states,
      duration: integer,
      ignore_status: ost$status,
      int: clt$integer,
      length: integer,
      local_status: ost$status,
      menu_parameters: array [1 .. number_of_parameters] of ^ost$message_parameter,
      message_parameters: array [1 .. 2] of ^ost$message_parameter,
      minutes_to_wait: integer,
      parameter_index: 1 .. number_of_parameters,
      parameter_names: ^ost$parameter_help_names,
      response: oft$number_of_choices,
      response_string: ost$string,
      start_time: integer,
      terminate_reason: string (ofc$max_send_message),
      wait_time: ost$string;

?? OLDTITLE ??
?? NEWTITLE := '  operator_menu_lock_handler', EJECT ??

  PROCEDURE operator_menu_lock_handler
    (    condition: pmt$condition;
         p_condition_info: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR condition_status: ost$status);

    VAR
      ignore_status: ost$status;

    CASE condition.selector OF
    = ifc$interactive_condition =
      CASE condition.interactive_condition OF
      = ifc$pause_break, ifc$job_reconnect =
        ifp$invoke_pause_utility (ignore_status);
      = ifc$terminate_break =
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
              ignore_status);
        EXIT rmp$set_explicit_reserve;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;
    ELSE
      pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
    CASEND;
  PROCEND operator_menu_lock_handler;

    status.normal := TRUE;

    FOR parameter_index := 1 TO number_of_parameters DO
      menu_parameters [parameter_index] := NIL;
    FOREND;

    debug_message_logged := FALSE;
    REPEAT
      IF NOT debug_message_logged THEN
        rmp$log_debug_message (' Calling iop$get_density_states');
      IFEND;
      iop$get_density_states (density_states, status);
      IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
        IF NOT debug_message_logged THEN
          rmp$log_debug_message (' Waiting for tape table lock');
          debug_message_logged := TRUE;
        IFEND;
        osp$establish_condition_handler (^operator_menu_lock_handler, {handle block exit} FALSE);
        pmp$long_term_wait (one_second, one_second);
        osp$disestablish_cond_handler;
      IFEND;
    UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);

    parameter_index := 1;
    FOR density := rmc$800 TO rmc$maximum_density DO
      IF required_resources [density] > 0 THEN
        STRINGREP (counts_string, length, required_resources [density]:3, ' ':4,
              density_states [density].on_count:3, ' ':2, density_states [density].down_count:3, ' ':2,
              density_states [density].off_count:3);
        menu_parameters [parameter_index] := ^density_strings [density].value;
        parameter_index := parameter_index + 1;
        PUSH menu_parameters [parameter_index]: [length + density_strings [density].blanks_required];
        menu_parameters [parameter_index]^ := ' ';
        menu_parameters [parameter_index]^ (density_strings [density].blanks_required + 1, * ) :=
              counts_string (1, length);
        parameter_index := parameter_index + 1;
      IFEND;
    FOREND;

    PUSH parameter_names: [1 .. number_of_choices];
    parameter_names^ [1] := 'ALLOW_RESERVATION';
    parameter_names^ [2] := 'DISALLOW_RESERVATION';
    parameter_names^ [3] := 'WAIT_ON_RESERVATION';

    ofp$format_operator_menu (rmc$reserve_tape, parameter_names, ^menu_parameters, number_of_choices,
          ofc$removable_media_operator, response, response_string, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE response OF
    = 1 =
      { Operator wants to retry reservation attempt}
    = 2 = { Terminate request}
      IF response_string.size > 0 THEN
        terminate_reason := response_string.value (1, response_string.size);
      ELSE
        terminate_reason := 'additional tape units cannot be turned ON'
      IFEND;
      osp$set_status_abnormal (rmc$resource_management_id, dme$operator_reserve_stop, terminate_reason,
            status);
    = 3 = { operator wants to wait for a specified time and then retry. }
      minutes_to_wait := default_reserve_wait;
      IF response_string.size > 0 THEN
        clp$convert_string_to_integer (response_string.value (1, response_string.size), int, local_status);
        IF local_status.normal THEN
          minutes_to_wait := int.value;
        IFEND;
      IFEND;

      current_date_time_string.size := 0;
      current_date_time_string.value := '';
      clp$get_date_time_string ('' {get date/time in site defined form} , current_date_time_string,
            ignore_status);

      message_parameters [1] := ^current_date_time_string.value (1, current_date_time_string.size);

      clp$convert_integer_to_string (minutes_to_wait, {radix} 10,
            {include_radix_specifier} FALSE, wait_time, ignore_status);
      message_parameters [2] := ^wait_time.value (1, wait_time.size);
      message_name := 'WAIT_UNITS_UNAVAILABLE';
      rmp$put_job_status_display (message_name, ^message_parameters);
      start_time := #FREE_RUNNING_CLOCK (0);
      duration := minutes_to_wait * (60 * 1000);
      WHILE duration > 0 DO
        pmp$long_term_wait (duration, duration);
        duration := duration - (#FREE_RUNNING_CLOCK (0) - start_time);
      WHILEND;
      wait_message_displayed := TRUE;
      osp$clear_wait_message (original_message, wait_message_displayed);
    ELSE
    CASEND;

  PROCEND operator_menu_for_tape_reserve;

?? OLDTITLE ??
?? NEWTITLE := '  explicit_reserve_handler', EJECT ??

  PROCEDURE explicit_reserve_handler
    (    condition: pmt$condition;
         p_condition_info: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR condition_status: ost$status);

    VAR
      lock_status: ost$signature_lock_status,
      ignore_status: ost$status,
      local_status: ost$status;

    CASE condition.selector OF

    = pmc$block_exit_processing =

      osp$test_signature_lock (rmv$job_tape_table_lock, lock_status, local_status);
      IF local_status.normal THEN
        IF lock_status = osc$sls_not_locked THEN
          osp$begin_subsystem_activity;
          osp$set_job_signature_lock (rmv$job_tape_table_lock);
        IFEND;
        IF lock_status <> osc$sls_locked_by_another_task THEN
          abnormal_cleanup;
          osp$clear_job_signature_lock (rmv$job_tape_table_lock);
          osp$end_subsystem_activity;
        IFEND;
      IFEND;
    = ifc$interactive_condition =
      CASE condition.interactive_condition OF
      = ifc$terminate_break =
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
              ignore_status);
        EXIT rmp$set_explicit_reserve;
      = ifc$pause_break, ifc$job_reconnect =
        ifp$invoke_pause_utility (ignore_status);
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;
    = pmc$user_defined_condition =
      IF condition.user_condition_name = osc$job_recovery_condition_name THEN
        osp$test_signature_lock (rmv$job_tape_table_lock, lock_status, local_status);
        IF local_status.normal THEN
          IF lock_status = osc$sls_not_locked THEN
            osp$begin_subsystem_activity;
            osp$set_job_signature_lock (rmv$job_tape_table_lock);
          IFEND;
          IF lock_status <> osc$sls_locked_by_another_task THEN
            rmv$job_tape_table_p^.job_recovery_active := FALSE;
            osp$clear_job_signature_lock (rmv$job_tape_table_lock);
            osp$end_subsystem_activity;
          IFEND;
        IFEND;
      IFEND;
      pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);

    ELSE
      pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
    CASEND;

  PROCEND explicit_reserve_handler;

  VAR
    count_of_units_requested: integer,
    current_date_time_string: ost$string,
    debug_message_logged: boolean,
    density: rmt$density,
    ignore_status: ost$status,
    message_name: clt$parameter_name,
    message_parameters: array [1 .. 1] of ^string ( * ),
    wait_message_displayed: boolean;

{
{ NOTE - THIS PROCEDURE MUST NOT BE CALLED WHEN PERFORMING AN
{ INITIALIZE_TAPE_VOLUME.
{
  status.normal := TRUE;

  osp$get_current_display_message (original_message);

  allocated_job_tape_table := FALSE;

  reserve_complete := FALSE;

  count_of_units_requested := 0;

  FOR density := rmc$800 TO rmc$maximum_density DO
    IF reservation [density] < 0 THEN
      osp$set_status_condition (dme$invalid_resrel_count, status);
      RETURN;
    ELSE
      count_of_units_requested := count_of_units_requested + reservation [density];
    IFEND;
  FOREND;

  updated_job_limits := FALSE;

  #SPOIL (allocated_job_tape_table, count_of_units_requested, original_message, reserve_complete,
        updated_job_limits);

  current_date_time_string.size := 0;
  current_date_time_string.value := '';
  clp$get_date_time_string ('' {get date/time in site defined form} , current_date_time_string,
        ignore_status);

  message_parameters [1] := ^current_date_time_string.value (1, current_date_time_string.size);

?? EJECT ??
  osp$establish_condition_handler (^explicit_reserve_handler, {handle block exit} TRUE);
  osp$begin_subsystem_activity;
  osp$set_job_signature_lock (rmv$job_tape_table_lock);

/job_tables_interlocked/
  BEGIN

{ Determine if job tape table exists

    IF (rmv$job_tape_table_p = NIL) THEN
      ALLOCATE rmv$job_tape_table_p IN osv$job_pageable_heap^;
      allocated_job_tape_table := TRUE;
      #SPOIL (allocated_job_tape_table);
      rmv$job_tape_table_p^ := rmv$job_tape_table_default;
    ELSE
      IF NOT (rmv$job_tape_table_p^.job_recovery_active) THEN
        osp$set_status_condition (dme$multiple_reserve, status);
        EXIT /job_tables_interlocked/;
      IFEND;
    IFEND;

{ Adjust magnetic tape job accumulator count and check limits.

    IF NOT rmv$job_tape_table_p^.job_recovery_active THEN
      sfp$update_job_limit_accum (avc$magnetic_tape_limit_name, count_of_units_requested,
            sfc$incremental_update, status);
      IF status.normal THEN
        updated_job_limits := TRUE;
        #SPOIL (updated_job_limits);
      ELSE
        EXIT /job_tables_interlocked/;
      IFEND;
    IFEND;

  /reserve_tape_resources/
    REPEAT
      debug_message_logged := FALSE;
      REPEAT
        IF NOT debug_message_logged THEN
          rmp$log_debug_message (' Calling dmp$acquire_tape_resource');
        IFEND;
        dmp$acquire_tape_resource (reservation, reserve_complete, status);
        IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Waiting for tape table lock');
            debug_message_logged := TRUE;
          IFEND;
          osp$clear_job_signature_lock (rmv$job_tape_table_lock);
          osp$end_subsystem_activity;
          pmp$long_term_wait (one_second, one_second);
          osp$begin_subsystem_activity;
          osp$set_job_signature_lock (rmv$job_tape_table_lock);
        IFEND;
      UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
      #SPOIL (reserve_complete);
      IF status.normal THEN
        IF NOT reserve_complete THEN
          osp$clear_job_signature_lock (rmv$job_tape_table_lock);
          osp$end_subsystem_activity;
          message_name := 'WAIT_UNITS_BUSY';
          rmp$put_job_status_display (message_name, ^message_parameters);
          pmp$long_term_wait (thirty_seconds, thirty_seconds);
          osp$begin_subsystem_activity;
          osp$set_job_signature_lock (rmv$job_tape_table_lock);
        IFEND;
      ELSEIF status.condition = dme$not_enough_in_on_state THEN
        osp$clear_job_signature_lock (rmv$job_tape_table_lock);
        osp$end_subsystem_activity;
        operator_menu_for_tape_reserve (reservation, status);
        osp$begin_subsystem_activity;
        osp$set_job_signature_lock (rmv$job_tape_table_lock);
      IFEND;
    UNTIL (NOT status.normal) OR reserve_complete;

  END /job_tables_interlocked/;

  IF status.normal THEN
    FOR density := rmc$800 TO rmc$maximum_density DO
      rmv$job_tape_table_p^.reserved_unit_count [density] := reservation [density];
    FOREND;
    rmv$job_tape_table_p^.explicit_reservation := TRUE;
    wait_message_displayed := TRUE;
    osp$clear_wait_message (original_message, wait_message_displayed);
  ELSE
    abnormal_cleanup;
  IFEND;

  osp$clear_job_signature_lock (rmv$job_tape_table_lock);
  osp$end_subsystem_activity;
  osp$disestablish_cond_handler;

PROCEND rmp$set_explicit_reserve;

?? OLDTITLE ??
?? NEWTITLE := 'rmp$set_implicit_reserve', EJECT ??

PROCEDURE [XDCL] rmp$set_implicit_reserve
  (    sfid: gft$system_file_identifier;
       density: rmt$density;
   VAR status: ost$status);

*copy rmi$block_exit_handler
?? EJECT ??

  VAR
    counter: rmt$density;

  status.normal := TRUE;
  osp$establish_condition_handler (^rmp$block_exit_handler, {handle block exit} TRUE);
  osp$begin_subsystem_activity;
  osp$set_job_signature_lock (rmv$job_tape_table_lock);
  IF (density >= rmc$800) AND (density <= rmc$maximum_density) THEN
    IF (rmv$job_tape_table_p = NIL) THEN
      ALLOCATE rmv$job_tape_table_p IN osv$job_pageable_heap^;
      rmv$job_tape_table_p^ := rmv$job_tape_table_default;
      sfp$update_job_limit_accum (avc$magnetic_tape_limit_name, {count_of_units_requested} 1,
            sfc$incremental_update, status);
      IF status.normal THEN
        rmv$job_tape_table_p^.explicit_reservation := FALSE;
        FOR counter := rmc$800 TO rmc$maximum_density DO
          rmv$job_tape_table_p^.reserved_unit_count [counter] := implicit_reservation [density] [counter];
        FOREND;
      IFEND;
    ELSE
      IF NOT rmv$job_tape_table_p^.job_recovery_active THEN
        osp$set_status_condition (dme$multiple_reserve, status);
      IFEND;
    IFEND;
  ELSE
    osp$set_status_condition (dme$density_not_supported, status);
  IFEND;

  IF status.normal THEN
    rmp$log_debug_message (' Implicit reserve set.');
  ELSE
    rmp$log_debug_message (' Implicit reserve not set.');
  IFEND;
  osp$clear_job_signature_lock (rmv$job_tape_table_lock);
  osp$end_subsystem_activity;
  osp$disestablish_cond_handler;
PROCEND rmp$set_implicit_reserve;

MODEND rmm$manage_reservations_223;
*DECK DECK=RMM$MEDIA_INTERFACES_23D EXPAND=TRUE
*DECK DECK=RMM$MEDIA_INTERFACES_2DD EXPAND=TRUE
*DECK DECK=RMM$REQMS_SUBSYSTEM_INTERFACE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Resource Manager : Request Mass Storage Command' ??
MODULE rmm$reqms_subsystem_interface;
?? NEWTITLE := 'Global Declarations', EJECT ??
*copyc rmp$request_mass_storage_cmd

?? TITLE := 'PROCEDURE [XDCL, #GATE] rmp$reqms_subsystem_interface', EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$reqms_subsystem_interface
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    rmp$request_mass_storage_cmd (parameter_list, status);

  PROCEND rmp$reqms_subsystem_interface;

MODEND rmm$request_mass_storage_cmd;
*DECK DECK=RMM$REQUEST_MASS_STORAGE_CMD EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Resource Manager : Request Mass Storage Command' ??
MODULE rmm$request_mass_storage_cmd;
?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fse$system_conditions
*copyc rme$request_mass_storage
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$trimmed_string_size
*copyc clp$verify_time_increment
*copyc cmp$get_sys_dev_rec_vsn
*copyc fsp$create_file
*copyc osp$set_status_abnormal
*copyc pmp$compute_date_time
*copyc pmp$get_compact_date_time
*copyc pmp$verify_compact_date
*copyc pmp$verify_compact_time

?? TITLE := 'PROCEDURE [XDCL, #GATE] rmp$convert_keyword_to_class', EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$convert_keyword_to_class
    (    keyword: ost$name;
     VAR file_class: rmt$mass_storage_class;
     VAR status: ost$status);

    status.normal := TRUE;

    IF (keyword = 'PRODUCT') THEN
      file_class := 'P';
    ELSEIF (keyword = 'USER_PERMANENT_FILE') THEN
      file_class := 'M';
    ELSEIF (keyword = 'SERVICE_CRITICAL_PRODUCT') OR (keyword = 'SYSTEM_PERMANENT_FILE') THEN
      file_class := 'K';
    ELSEIF keyword = 'SYSTEM_CRITICAL_FILE' THEN
      file_class := 'Q';
    ELSEIF keyword = 'TEMPORARY_FILE' THEN
      file_class := 'N';
    ELSE
      osp$set_status_abnormal (rmc$resource_management_id, rme$invalid_keyword, keyword, status);
      RETURN;
    IFEND;

  PROCEND rmp$convert_keyword_to_class;

?? TITLE := 'PROCEDURE [XDCL, #GATE] rmp$request_mass_storage_cmd', EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$request_mass_storage_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (rmm$reqms) request_mass_storage, reqms (
{   file, f: file = $required
{   allocation_size, as: (BY_NAME) integer 16384..16777215 = $optional
{   file_class, fc: (BY_NAME) any of
{       key
{         product
{         (service_critical_product, scp)
{         (system_critical_file, scf)
{         (system_permanent_file, spf)
{         (temporary_file, tf)
{         (user_permanent_file, upf)
{       keyend
{       name 1..1
{     anyend = $optional
{   initial_volume, iv: (BY_NAME) any of
{       key
{         (system_device, sd)
{       keyend
{       name 1..6
{     anyend = $optional
{   retention, r: (BY_NAME) any of
{       integer pfc$minimum_retention..pfc$maximum_retention
{       date
{       date_time
{       time_increment
{     anyend = $optional
{   retrieve_option, ro: (BY_NAME, ADVANCED) key
{       (always_retrieve, ar)
{       (explicit_retrieve_only, ero)
{       (administrative_retrieve_only, aro)
{     keyend = $optional
{   shared_queue, sq: (BY_NAME, ADVANCED) key
{       site_01, site_02, site_03, site_04, site_05, site_06, site_07, site_08, site_09, site_10, site_11
{       site_12, site_13, site_14, site_15, site_16, site_17, site_18, site_19, site_20, site_21, site_22
{       site_23, site_24, site_25
{     keyend = $optional
{   site_archive_option, sao: (BY_NAME, ADVANCED) any of
{       integer 1..255
{       key
{         null
{       keyend
{     anyend = $optional
{   site_backup_option, sbo: (BY_NAME, ADVANCED) any of
{       integer 1..255
{       key
{         null
{       keyend
{     anyend = $optional
{   site_release_option, sro: (BY_NAME, ADVANCED) any of
{       integer 1..255
{       key
{         null
{       keyend
{     anyend = $optional
{   transfer_size, ts: (BY_NAME) integer 16384..2147483648 = $optional
{   volume_overflow_allowed, voa: (BY_NAME) boolean = TRUE
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 25] of clt$pdt_parameter_name,
      parameters: array [1 .. 13] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type3: 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 .. 11] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type4: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
      recend,
      type5: 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$integer_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$date_time_type_qualifier,
        recend,
        type_size_3: clt$type_specification_size,
        element_type_spec_3: record
          header: clt$type_specification_header,
          qualifier: clt$date_time_type_qualifier,
        recend,
        type_size_4: clt$type_specification_size,
        element_type_spec_4: record
          header: clt$type_specification_header,
        recend,
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type7: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 25] of clt$keyword_specification,
      recend,
      type8: 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$integer_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
      recend,
      type9: 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$integer_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
      recend,
      type10: 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$integer_type_qualifier,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
      recend,
      type11: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type12: record
        header: clt$type_specification_header,
        default_value: string (4),
      recend,
      type13: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [97, 1, 20, 15, 9, 41, 540],
    clc$command, 25, 13, 1, 5, 0, 0, 13, 'RMM$REQMS'], [
    ['ALLOCATION_SIZE                ',clc$nominal_entry, 2],
    ['AS                             ',clc$abbreviation_entry, 2],
    ['F                              ',clc$abbreviation_entry, 1],
    ['FC                             ',clc$abbreviation_entry, 3],
    ['FILE                           ',clc$nominal_entry, 1],
    ['FILE_CLASS                     ',clc$nominal_entry, 3],
    ['INITIAL_VOLUME                 ',clc$nominal_entry, 4],
    ['IV                             ',clc$abbreviation_entry, 4],
    ['R                              ',clc$abbreviation_entry, 5],
    ['RETENTION                      ',clc$nominal_entry, 5],
    ['RETRIEVE_OPTION                ',clc$nominal_entry, 6],
    ['RO                             ',clc$abbreviation_entry, 6],
    ['SAO                            ',clc$abbreviation_entry, 8],
    ['SBO                            ',clc$abbreviation_entry, 9],
    ['SHARED_QUEUE                   ',clc$nominal_entry, 7],
    ['SITE_ARCHIVE_OPTION            ',clc$nominal_entry, 8],
    ['SITE_BACKUP_OPTION             ',clc$nominal_entry, 9],
    ['SITE_RELEASE_OPTION            ',clc$nominal_entry, 10],
    ['SQ                             ',clc$abbreviation_entry, 7],
    ['SRO                            ',clc$abbreviation_entry, 10],
    ['STATUS                         ',clc$nominal_entry, 13],
    ['TRANSFER_SIZE                  ',clc$nominal_entry, 11],
    ['TS                             ',clc$abbreviation_entry, 11],
    ['VOA                            ',clc$abbreviation_entry, 12],
    ['VOLUME_OVERFLOW_ALLOWED        ',clc$nominal_entry, 12]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 439,
  clc$optional_parameter, 0, 0],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 106,
  clc$optional_parameter, 0, 0],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 61, clc$optional_parameter,
  0, 0],
{ PARAMETER 6
    [11, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$optional_parameter, 0, 0],
{ PARAMETER 7
    [15, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 932,
  clc$optional_parameter, 0, 0],
{ PARAMETER 8
    [16, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84, clc$optional_parameter,
  0, 0],
{ PARAMETER 9
    [17, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84, clc$optional_parameter,
  0, 0],
{ PARAMETER 10
    [18, clc$advanced_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 84, clc$optional_parameter,
  0, 0],
{ PARAMETER 11
    [22, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$optional_parameter,
  0, 0],
{ PARAMETER 12
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 4],
{ PARAMETER 13
    [21, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type]],
{ PARAMETER 2
    [[1, 0, clc$integer_type], [16384, 16777215, 10]],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    414, [[1, 0, clc$keyword_type], [11], [
      ['PRODUCT                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['SCF                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['SCP                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['SERVICE_CRITICAL_PRODUCT       ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['SPF                            ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['SYSTEM_CRITICAL_FILE           ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['SYSTEM_PERMANENT_FILE          ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['TEMPORARY_FILE                 ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['TF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['UPF                            ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['USER_PERMANENT_FILE            ', clc$nominal_entry, clc$normal_usage_entry, 6]]
      ],
    5, [[1, 0, clc$name_type], [1, 1]]
    ],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['SD                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['SYSTEM_DEVICE                  ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ],
    5, [[1, 0, clc$name_type], [1, 6]]
    ],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$date_time_type, clc$integer_type, clc$time_increment_type],
    FALSE, 4],
    20, [[1, 0, clc$integer_type], [pfc$minimum_retention, pfc$maximum_retention, 10]],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date], $clt$date_time_tenses [clc$past,
  clc$present, clc$future]]],
    5, [[1, 0, clc$date_time_type], [$clt$date_and_or_time [clc$date, clc$time], $clt$date_time_tenses [
  clc$past, clc$present, clc$future]]],
    3, [[1, 0, clc$time_increment_type]]
    ],
{ PARAMETER 6
    [[1, 0, clc$keyword_type], [6], [
    ['ADMINISTRATIVE_RETRIEVE_ONLY   ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['ALWAYS_RETRIEVE                ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['AR                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ARO                            ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
    ['ERO                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['EXPLICIT_RETRIEVE_ONLY         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 7
    [[1, 0, clc$keyword_type], [25], [
    ['SITE_01                        ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['SITE_02                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['SITE_03                        ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['SITE_04                        ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['SITE_05                        ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['SITE_06                        ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['SITE_07                        ', clc$nominal_entry, clc$normal_usage_entry, 7],
    ['SITE_08                        ', clc$nominal_entry, clc$normal_usage_entry, 8],
    ['SITE_09                        ', clc$nominal_entry, clc$normal_usage_entry, 9],
    ['SITE_10                        ', clc$nominal_entry, clc$normal_usage_entry, 10],
    ['SITE_11                        ', clc$nominal_entry, clc$normal_usage_entry, 11],
    ['SITE_12                        ', clc$nominal_entry, clc$normal_usage_entry, 12],
    ['SITE_13                        ', clc$nominal_entry, clc$normal_usage_entry, 13],
    ['SITE_14                        ', clc$nominal_entry, clc$normal_usage_entry, 14],
    ['SITE_15                        ', clc$nominal_entry, clc$normal_usage_entry, 15],
    ['SITE_16                        ', clc$nominal_entry, clc$normal_usage_entry, 16],
    ['SITE_17                        ', clc$nominal_entry, clc$normal_usage_entry, 17],
    ['SITE_18                        ', clc$nominal_entry, clc$normal_usage_entry, 18],
    ['SITE_19                        ', clc$nominal_entry, clc$normal_usage_entry, 19],
    ['SITE_20                        ', clc$nominal_entry, clc$normal_usage_entry, 20],
    ['SITE_21                        ', clc$nominal_entry, clc$normal_usage_entry, 21],
    ['SITE_22                        ', clc$nominal_entry, clc$normal_usage_entry, 22],
    ['SITE_23                        ', clc$nominal_entry, clc$normal_usage_entry, 23],
    ['SITE_24                        ', clc$nominal_entry, clc$normal_usage_entry, 24],
    ['SITE_25                        ', clc$nominal_entry, clc$normal_usage_entry, 25]]
    ],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    20, [[1, 0, clc$integer_type], [1, 255, 10]],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NULL                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    20, [[1, 0, clc$integer_type], [1, 255, 10]],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NULL                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type],
    FALSE, 2],
    20, [[1, 0, clc$integer_type], [1, 255, 10]],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NULL                           ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ],
{ PARAMETER 11
    [[1, 0, clc$integer_type], [16384, 2147483648, 10]],
{ PARAMETER 12
    [[1, 0, clc$boolean_type],
    'TRUE'],
{ PARAMETER 13
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$file = 1,
      p$allocation_size = 2,
      p$file_class = 3,
      p$initial_volume = 4,
      p$retention = 5,
      p$retrieve_option = 6,
      p$shared_queue = 7,
      p$site_archive_option = 8,
      p$site_backup_option = 9,
      p$site_release_option = 10,
      p$transfer_size = 11,
      p$volume_overflow_allowed = 12,
      p$status = 13;

    VAR
      pvt: array [1 .. 13] of clt$parameter_value;

    VAR
      cycle_attribute_count: integer,
      cycle_attributes: ^fst$file_cycle_attributes,
      date_time: ost$date_time,
      device_attribute_count: integer,
      device_attributes: ^fst$device_attributes,
      expiration_date: ost$date_time,
      index: p$allocation_size .. p$volume_overflow_allowed,
      ignore_status: ost$status,
      resolved_path: fst$path;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cycle_attribute_count := 0;
    device_attribute_count := 0;
    IF pvt [p$allocation_size].specified THEN
      device_attribute_count := device_attribute_count + 1;
    IFEND;
    IF pvt [p$file_class].specified THEN
      device_attribute_count := device_attribute_count + 1;
    IFEND;
    IF pvt [p$initial_volume].specified THEN
      device_attribute_count := device_attribute_count + 1;
    IFEND;
    IF pvt [p$retention].specified THEN
      cycle_attribute_count := cycle_attribute_count + 1;
    IFEND;
    IF pvt [p$retrieve_option].specified THEN
      cycle_attribute_count := cycle_attribute_count + 1;
    IFEND;
    IF pvt [p$shared_queue].specified THEN
      device_attribute_count := device_attribute_count + 1;
    IFEND;
    IF pvt [p$site_archive_option].specified THEN
      cycle_attribute_count := cycle_attribute_count + 1;
    IFEND;
    IF pvt [p$site_backup_option].specified THEN
      cycle_attribute_count := cycle_attribute_count + 1;
    IFEND;
    IF pvt [p$site_release_option].specified THEN
      cycle_attribute_count := cycle_attribute_count + 1;
    IFEND;
    IF pvt [p$transfer_size].specified THEN
      device_attribute_count := device_attribute_count + 1;
    IFEND;
    IF pvt [p$volume_overflow_allowed].specified THEN
      device_attribute_count := device_attribute_count + 1;
    IFEND;

    IF device_attribute_count = 0 THEN
      device_attributes := NIL;
    ELSE
      PUSH device_attributes: [1 .. device_attribute_count];
      device_attribute_count := 0;
      IF pvt [p$allocation_size].specified THEN
        device_attribute_count := device_attribute_count + 1;
        device_attributes^ [device_attribute_count].selector := fsc$allocation_size;
        device_attributes^ [device_attribute_count].allocation_size :=
              pvt [p$allocation_size].value^.integer_value.value;
      IFEND;

      IF pvt [p$file_class].specified THEN
        device_attribute_count := device_attribute_count + 1;
        device_attributes^ [device_attribute_count].selector := fsc$mass_storage_class;
        IF clp$trimmed_string_size (pvt [p$file_class].value^.name_value) = 1 THEN
          device_attributes^ [device_attribute_count].mass_storage_class :=
                pvt [p$file_class].value^.name_value (1);
        ELSE
          rmp$convert_keyword_to_class (pvt [p$file_class].value^.name_value,
                device_attributes^ [device_attribute_count].mass_storage_class, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;

      IF pvt [p$initial_volume].specified THEN
        device_attribute_count := device_attribute_count + 1;
        device_attributes^ [device_attribute_count].selector := fsc$initial_volume;
        IF pvt [p$initial_volume].value^.name_value = 'SYSTEM_DEVICE' THEN
          cmp$get_sys_dev_rec_vsn (device_attributes^ [device_attribute_count].initial_volume, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        ELSE
          device_attributes^ [device_attribute_count].initial_volume := pvt [p$initial_volume].
                value^.name_value (1, 6);
        IFEND;
      IFEND;

      IF pvt [p$transfer_size].specified THEN
        device_attribute_count := device_attribute_count + 1;
        device_attributes^ [device_attribute_count].selector := fsc$requested_transfer_size;
        device_attributes^ [device_attribute_count].requested_transfer_size := pvt [p$transfer_size].
              value^.integer_value.value;
      IFEND;

      IF pvt [p$shared_queue].specified THEN
        device_attribute_count := device_attribute_count + 1;
        device_attributes^ [device_attribute_count].selector := fsc$shared_queue;
        device_attributes^ [device_attribute_count].shared_queue :=
              pvt [p$shared_queue].value^.keyword_value;
      IFEND;

      IF pvt [p$volume_overflow_allowed].specified THEN
        device_attribute_count := device_attribute_count + 1;
        device_attributes^ [device_attribute_count].selector := fsc$volume_overflow_allowed;
        device_attributes^ [device_attribute_count].volume_overflow_allowed :=
              pvt [p$volume_overflow_allowed].value^.boolean_value.value;
      IFEND;

      IF device_attribute_count <> UPPERBOUND (device_attributes^) THEN
        osp$set_status_abnormal (rmc$resource_management_id, fse$system_error,
              'Bad device attribute count in RMP$REQUEST_MASS_STORAGE_CMD', status);
        RETURN;
      IFEND;
    IFEND; {device_attribute_count > 0}

    IF cycle_attribute_count = 0 THEN
      cycle_attributes := NIL;
    ELSE
      PUSH cycle_attributes: [1 .. cycle_attribute_count];
      cycle_attribute_count := 0;
      IF pvt [p$retention].specified THEN
        cycle_attribute_count := cycle_attribute_count + 1;
        cycle_attributes^ [cycle_attribute_count].selector := fsc$retention;
        IF pvt [p$retention].value^.kind = clc$integer THEN
          cycle_attributes^ [cycle_attribute_count].retention.selector:= fsc$retention_day_increment;
          cycle_attributes^ [cycle_attribute_count].retention.day_increment :=
                pvt [p$retention].value^.integer_value.value;
        ELSEIF pvt [p$retention].value^.kind = clc$time_increment THEN
          clp$verify_time_increment (pvt [p$retention].value^.time_increment_value^, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          pmp$get_compact_date_time (date_time, ignore_status);
          pmp$compute_date_time (date_time, pvt [p$retention].value^.time_increment_value^, expiration_date,
                status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          cycle_attributes^ [cycle_attribute_count].retention.selector:= fsc$retention_time_increment;
          cycle_attributes^ [cycle_attribute_count].retention.time_increment :=
                pvt [p$retention].value^.time_increment_value^;
        ELSE
          IF pvt [p$retention].value^.date_time_value.date_specified THEN
            pmp$verify_compact_date (pvt [p$retention].value^.date_time_value.value, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
          IF pvt [p$retention].value^.date_time_value.time_specified THEN
            pmp$verify_compact_time (pvt [p$retention].value^.date_time_value.value, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
          cycle_attributes^ [cycle_attribute_count].retention.selector:= fsc$retention_expiration_date;
          cycle_attributes^ [cycle_attribute_count].retention.expiration_date :=
                pvt [p$retention].value^.date_time_value.value;
        IFEND;
      IFEND;

      IF pvt [p$retrieve_option].specified THEN
        cycle_attribute_count := cycle_attribute_count + 1;
        cycle_attributes^ [cycle_attribute_count].selector := fsc$retrieve_option;
        IF (pvt [p$retrieve_option].value^.name_value = 'ALWAYS_RETRIEVE') THEN
          cycle_attributes^ [cycle_attribute_count].retrieve_option := pfc$always_retrieve;
        ELSEIF (pvt [p$retrieve_option].value^.name_value = 'EXPLICIT_RETRIEVE_ONLY') THEN
          cycle_attributes^ [cycle_attribute_count].retrieve_option := pfc$explicit_retrieve_only;
        ELSE { 'ADMINISTRATIVE_RETRIEVE_ONLY' }
          cycle_attributes^ [cycle_attribute_count].retrieve_option := pfc$admin_retrieve_only;
        IFEND;
      IFEND;

      IF pvt [p$site_archive_option].specified THEN
            cycle_attribute_count := cycle_attribute_count + 1;
            cycle_attributes^ [cycle_attribute_count].selector := fsc$site_archive_option;
        IF pvt [p$site_archive_option].value^.kind = clc$integer THEN
          cycle_attributes^ [cycle_attribute_count].site_archive_option :=
                pvt [p$site_archive_option].value^.integer_value.value;
        ELSE { 'NULL' }
          cycle_attributes^ [cycle_attribute_count].site_archive_option := pfc$null_site_archive_option;
        IFEND;
      IFEND;

      IF pvt [p$site_backup_option].specified THEN
            cycle_attribute_count := cycle_attribute_count + 1;
            cycle_attributes^ [cycle_attribute_count].selector := fsc$site_backup_option;
        IF pvt [p$site_backup_option].value^.kind = clc$integer THEN
          cycle_attributes^ [cycle_attribute_count].site_backup_option :=
                pvt [p$site_backup_option].value^.integer_value.value;
        ELSE { 'NULL' }
          cycle_attributes^ [cycle_attribute_count].site_backup_option := pfc$null_site_backup_option;
        IFEND;
      IFEND;

      IF pvt [p$site_release_option].specified THEN
            cycle_attribute_count := cycle_attribute_count + 1;
            cycle_attributes^ [cycle_attribute_count].selector := fsc$site_release_option;
        IF pvt [p$site_release_option].value^.kind = clc$integer THEN
          cycle_attributes^ [cycle_attribute_count].site_release_option :=
                pvt [p$site_release_option].value^.integer_value.value;
        ELSE { 'NULL' }
          cycle_attributes^ [cycle_attribute_count].site_release_option := pfc$null_site_release_option;
        IFEND;
      IFEND;

      IF cycle_attribute_count <> UPPERBOUND (cycle_attributes^) THEN
        osp$set_status_abnormal (rmc$resource_management_id, fse$system_error,
              'Bad cycle attribute count in RMP$REQUEST_MASS_STORAGE_CMD', status);
        RETURN;
      IFEND;
    IFEND; {cycle_attribute_count > 0}

    fsp$create_file (pvt [p$file].value^.file_value^, {attachment_options =} NIL,
          cycle_attributes, device_attributes, {file_attributes =} NIL, resolved_path, status);

  PROCEND rmp$request_mass_storage_cmd;

MODEND rmm$request_mass_storage_cmd;








*DECK DECK=RMM$REQUEST_NULL_DEVICE EXPAND=TRUE
*copyc osd$default_pragmats

MODULE rmm$request_null_device;

*copyc fmp$request_null_device

  PROCEDURE [XDCL, #GATE] rmp$r3_request_null_device
    (VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR status: ost$status);

    status.normal := TRUE;

    fmp$request_null_device (rmc$null_device,
          evaluated_file_reference, status);

  PROCEND rmp$r3_request_null_device;

MODEND rmm$request_null_device;
*DECK DECK=RMM$REQUEST_TERMINAL EXPAND=TRUE
*copyc osd$default_pragmats
MODULE rmm$request_terminal;

{MODULE DECK RMMRTT}
?? PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc amt$local_file_name
*copyc cle$ecc_file_reference
*copyc cle$ecc_lexical
*copyc clp$construct_path_handle_name
*copyc clp$get_ultimate_connection
*copyc clp$validate_name
*copyc clv$standard_files
*copyc fsc$local
*copyc fsp$path_element
*copyc fst$file_reference
*copyc fmp$request_terminal
*copyc ife$error_codes
*copyc iip$search_connection_desc
*copyc iip$xlate_local_file_to_session
*copyc iip$st_initialize_connection
*copyc iiv$connection_desc_ptr
*copyc iiv$int_task_open_file_count
*copyc iiv$interactive_terminated
*copyc jmp$system_job
*copyc jmv$connection_acquired
*copyc nat$data_fragments
*copyc osc$timesharing_terminal_file
*copyc osd$operating_system_exceptions
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc oss$task_private
*copyc ost$status
*copyc osv$task_private_heap
*copyc pmp$get_job_mode
*copyc rme$request_terminal
*copyc rmp$get_device_class
?? POP ??

  PROCEDURE [XDCL, #GATE] rmp$r3_request_terminal
    (    terminal_file_name: ^fst$file_reference;
         term_conn_attributes: ift$connection_attributes;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR status: ost$status);

    TYPE
      set_of_cases = set of ift$connection_attribute_keys;

    VAR
      attributes: ^ift$connection_attributes,
      attributes_pointer: ^iit$connection_attributes,
      bam_status: ost$status,
      connection_desc_ptr: ^iit$connection_description,
      converted_name: ost$name,
      device_assigned: boolean,
      device_class: rmt$device_class,
      i: integer,
      index: ift$connection_attribute_keys,
      internal_terminal_name: amt$local_file_name,
      j: integer,
      job_mode: jmt$job_mode,
      k: integer,
      lnt_attributes: array [1 .. ORD (ifc$max_connection_key)] OF ift$connection_attribute,
      local_status: ost$status,
      path_handle_name: fst$path_handle_name,
      set_of_attribute_keys: set_of_cases,
      temp_file_name: amt$local_file_name,
      text: ost$name,
      validated_terminal_file_name: ost$name,
      ultimate_name: amt$local_file_name,
      ultimate_prompt_file: amt$local_file_name,
      valid_name: boolean;

    status.normal := TRUE;
    bam_status.normal := TRUE;
    text := osc$null_name;

  /request_terminal/
    BEGIN
      IF fsp$path_element (^evaluated_file_reference, 1)^ <> fsc$local THEN
        osp$set_status_abnormal (amc$access_method_id,
              cle$only_permitted_on_loc_file, '', status);
        EXIT /request_terminal/;
      IFEND;

      IF terminal_file_name = NIL THEN
        pmp$get_job_mode (job_mode, local_status);
        IF NOT local_status.normal THEN
          status := local_status;
          EXIT /request_terminal/;
        ELSEIF NOT (job_mode IN $iit$job_modes [jmc$interactive_connected,
               jmc$interactive_cmnd_disconnect, jmc$interactive_line_disconnect,
               jmc$interactive_sys_disconnect]) THEN
          osp$set_status_abnormal (ifc$interactive_facility_id,
               ife$current_job_not_interactive, 'RMP$R3_REQUEST_TERMINAL',
               status);
          EXIT /request_terminal/;
        IFEND;
        internal_terminal_name := osc$timesharing_terminal_file;
      ELSE
        IF STRLENGTH (terminal_file_name^) <= osc$max_name_size THEN
          internal_terminal_name := terminal_file_name^;
        ELSE
          osp$set_status_abnormal (ifc$interactive_facility_id,
                ife$file_name_ill_formed, terminal_file_name^, status);
          osp$append_status_parameter (osc$status_parameter_delimiter,
            'RMP$REQUEST_TERMINAL', status);
          EXIT /request_terminal/;
        IFEND;
      IFEND;

    { Validate the terminal file name.

      clp$validate_name (internal_terminal_name, validated_terminal_file_name, valid_name);
      IF NOT valid_name THEN
        osp$set_status_abnormal (amc$access_method_id, cle$improper_name, internal_terminal_name, status);
        EXIT /request_terminal/;
      IFEND;

    { Verify that the terminal file exists and that it is a network file.

      rmp$get_device_class (validated_terminal_file_name, device_assigned, device_class,
            status);
      IF NOT status.normal THEN
        EXIT /request_terminal/;
      IFEND;

      WHILE (device_assigned) AND (device_class = rmc$terminal_device) DO
        { chain from associated local file to find its session file }
        temp_file_name := validated_terminal_file_name;
        iip$xlate_local_file_to_session (temp_file_name, validated_terminal_file_name, status);
        IF NOT status.normal THEN
          EXIT /request_terminal/;
        IFEND;
        rmp$get_device_class (validated_terminal_file_name, device_assigned, device_class,
              status);
        IF NOT status.normal THEN
          EXIT /request_terminal/;
        IFEND;
      WHILEND;

      IF device_class = rmc$network_device THEN
        iip$search_connection_desc (validated_terminal_file_name, connection_desc_ptr);
        IF connection_desc_ptr = NIL THEN
        { Set up a terminal connection table and download the attributes.
          iip$st_initialize_connection (validated_terminal_file_name, status);
          IF NOT status.normal THEN
            EXIT /request_terminal/;
          IFEND;
          iip$search_connection_desc (validated_terminal_file_name, connection_desc_ptr);
        IFEND;
        attributes_pointer := ^connection_desc_ptr^.default_connection_attributes;
      ELSE {Must be Dual State
        attributes_pointer := iiv$terminal_request_ptr;
      IFEND;

    { Validate the attribute values and keys.

      IF UPPERBOUND (term_conn_attributes) <> 0 THEN

        FOR i := 1 TO UPPERBOUND (term_conn_attributes) DO
          CASE term_conn_attributes [i].key OF

          = ifc$attention_character_action =
            IF (term_conn_attributes [i].attention_character_action < LOWERVALUE
                  (ift$attention_character_action)) { } OR (term_conn_attributes [i].
                  attention_character_action > UPPERVALUE (ift$attention_character_action)) THEN
              text := 'ATTENTION_CHARACTER_ACTION';
            IFEND;

          = ifc$break_key_action =
            IF (term_conn_attributes [i].break_key_action < LOWERVALUE
                  (ift$break_key_action))
            { } OR (term_conn_attributes [i].break_key_action > UPPERVALUE
                  (ift$break_key_action)) THEN
              text := 'BREAK_KEY_ACTION';
            IFEND;


          = ifc$end_of_information =
            IF (term_conn_attributes [i].end_of_information.size < LOWERVALUE
                  (ift$end_of_information_size)) { } OR (term_conn_attributes
                  [i].end_of_information.size > UPPERVALUE
                  (ift$end_of_information_size)) THEN
              text := 'END_OF_INFORMATION';
            IFEND;

          = ifc$input_block_size =
            IF (term_conn_attributes [i].input_block_size < LOWERVALUE
                  (ift$input_block_size)) { } OR (term_conn_attributes
                  [i].input_block_size > UPPERVALUE
                  (ift$input_block_size)) THEN
              text := 'INPUT_BLOCK_SIZE';
            IFEND;

          = ifc$input_editing_mode =
            IF (term_conn_attributes [i].input_editing_mode < LOWERVALUE (ift$input_editing_mode))
            { } OR (term_conn_attributes [i].input_editing_mode > UPPERVALUE (ift$input_editing_mode))
                  THEN
              text := 'INPUT_EDITING_MODE';
            IFEND;

          = ifc$input_output_mode =
            IF (term_conn_attributes [i].input_output_mode < LOWERVALUE (ift$input_output_mode))
            { } OR (term_conn_attributes [i].input_output_mode > UPPERVALUE (ift$input_output_mode))
                  THEN
              text := 'INPUT_OUTPUT_MODE';
            IFEND;

          = ifc$input_timeout =
              IF (term_conn_attributes [i].input_timeout < LOWERVALUE (boolean))
              { } OR (term_conn_attributes [i].input_timeout > UPPERVALUE (boolean))
                    THEN
              text := 'INPUT_TIMEOUT'
            IFEND;

          = ifc$input_timeout_length =
              IF (term_conn_attributes [i].input_timeout_length < LOWERVALUE (ift$input_timeout_length))
              { } OR (term_conn_attributes [i].input_timeout_length > UPPERVALUE (ift$input_timeout_length))
                    THEN
              text := 'INPUT_TIMEOUT_LENGTH';
            IFEND;

          = ifc$input_timeout_purge =
              IF (term_conn_attributes [i].input_timeout_purge < LOWERVALUE (boolean))
              { } OR (term_conn_attributes [i].input_timeout_purge > UPPERVALUE (boolean))
                    THEN
              text := 'INPUT_TIMEOUT_PURGE';
            IFEND;

          = ifc$null_connection_attribute =
            ;

          = ifc$partial_char_forwarding =
              IF (term_conn_attributes [i].partial_character_forwarding < LOWERVALUE (boolean))
              { } OR (term_conn_attributes [i].partial_character_forwarding > UPPERVALUE (boolean))
                    THEN
              text := 'PARTIAL_CHARACTER_FORWARDING';
            IFEND;

          = ifc$prompt_file =

            clp$construct_path_handle_name (evaluated_file_reference.path_handle_info.path_handle,
                  path_handle_name);
            clp$get_ultimate_connection (path_handle_name, ultimate_name, status);
            IF NOT status.normal THEN
              EXIT /request_terminal/;
            IFEND;
            clp$get_ultimate_connection (term_conn_attributes [i].prompt_file, ultimate_prompt_file, status);
            IF NOT status.normal THEN
              EXIT /request_terminal/;
            IFEND;
            IF ultimate_prompt_file <> ultimate_name THEN
              clp$validate_name (term_conn_attributes [i].prompt_file, converted_name, valid_name);
              IF NOT valid_name THEN
                osp$set_status_abnormal (ifc$interactive_facility_id,
                      ife$prompt_file_name_ill_formed, term_conn_attributes [i].prompt_file, status);
                osp$append_status_parameter (osc$status_parameter_delimiter, 'RMM$REQUEST_TERMINAL', status);
                EXIT /request_terminal/;
              IFEND;

            { Verify that the file is assigned to a terminal device.

              rmp$get_device_class (converted_name, device_assigned, device_class, status);
              IF NOT status.normal THEN
                EXIT /request_terminal/;
              ELSE
                IF NOT device_assigned THEN
                  osp$set_status_abnormal (ifc$interactive_facility_id,
                        ife$prompt_file_name_not_found, converted_name,
                        status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                    'RMM$REQUEST_TERMINAL', status);
                  EXIT /request_terminal/;
                ELSEIF device_class <> rmc$terminal_device THEN
                  osp$set_status_abnormal (ifc$interactive_facility_id,
                        ife$prompt_file_name_not_term, converted_name, status);
                  osp$append_status_parameter (osc$status_parameter_delimiter,
                    'RMM$REQUEST_TERMINAL', status);
                  EXIT /request_terminal/;
                IFEND;
              IFEND;
            IFEND;

          = ifc$prompt_file_identifier =

    { Get the file_name for the file_id.

    { The following code is no-op'ed until BAM provides a way to obtain
    { the local_file_name given the file_id.

    {       fetch_attributes [1].key := amc$local_file_name;
    {       amp$fetch (term_conn_attributes [i].prompt_file_identifier, fetch_attributes,
    {             status);
    {       IF NOT status.normal THEN
    {         EXIT /request_terminal/;
    {       IFEND;
    {
    {       clp$get_ultimate_connection (fetch_attributes [1].file_name^.local_file_name,
    {             ultimate_name, status);
    {       IF NOT status.normal THEN
    {         EXIT /request_terminal/;
    {       IFEND;
    {       clp$get_ultimate_connection (term_conn_attributes [i].prompt_file, ultimate_prompt_file, status);
    {       IF NOT status.normal THEN
    {         EXIT /request_terminal/;
    {       IFEND;
    {       IF ultimate_prompt_file <> ultimate_name THEN
    {
    {         clp$validate_name (fetch_attributes [1].file_name^.local_file_name, converted_name, valid_name);
    {         IF NOT valid_name THEN
    {           osp$set_status_abnormal (ifc$interactive_facility_id, ife$prompt_file_name_ill_formed,
    {                 fetch_attributes [1].file_name^.local_file_name, status);
    {           osp$append_status_parameter (osc$status_parameter_delimiter, 'RMM$REQUEST_TERMINAL', status);
    {           EXIT /request_terminal/;
    {         IFEND;
    {
    { Verify that the file is assigned to a terminal device.
    {
    {         rmp$get_device_class (converted_name, device_assigned, device_class, status);
    {         IF NOT status.normal THEN
    {           EXIT /request_terminal/;
    {         ELSE
    {           IF NOT device_assigned THEN
    {             osp$set_status_abnormal (ifc$interactive_facility_id,
    {                   ife$prompt_file_name_not_found, converted_name, status);
    {             osp$append_status_parameter (osc$status_parameter_delimiter,
    {               'RMM$REQUEST_TERMINAL', status);
    {             EXIT /request_terminal/;
    {           ELSEIF device_class <> rmc$terminal_device THEN
    {             osp$set_status_abnormal (ifc$interactive_facility_id,
    {                   ife$prompt_file_name_not_term, converted_name, status);
    {             osp$append_status_parameter (osc$status_parameter_delimiter,
    {               'RMM$REQUEST_TERMINAL', status);
    {             EXIT /request_terminal/;
    {           IFEND;
    {         IFEND;
    {       IFEND;

          = ifc$prompt_string =

            k := term_conn_attributes [i].prompt_string.size;
            IF ((k < LOWERVALUE (ift$prompt_string_size)) OR (k > UPPERVALUE
                  (ift$prompt_string_size))) THEN
              text := 'PROMPT_STRING';
            IFEND;

          = ifc$store_backspace_character =
            IF (term_conn_attributes [i].store_backspace_character < LOWERVALUE (boolean))
            { } OR (term_conn_attributes [i].store_backspace_character > UPPERVALUE (boolean)) THEN
              text := 'STORE_BACKSPACE_CHARACTER';
            IFEND;

          = ifc$store_nuls_dels =
            IF (term_conn_attributes [i].store_nuls_dels < LOWERVALUE (boolean))
            { } OR (term_conn_attributes [i].store_nuls_dels > UPPERVALUE (boolean)) THEN
              text := 'STORE_NULS_DELS';
            IFEND;

          = ifc$trans_character_mode =
            IF (term_conn_attributes [i].trans_character_mode <
                LOWERVALUE (ift$trans_character_mode))
            { } OR (term_conn_attributes [i].trans_character_mode >
                UPPERVALUE (ift$trans_character_mode)) THEN
              text := 'TRANS_CHARACTER_MODE';
            IFEND;

          = ifc$trans_forward_character =
            IF (term_conn_attributes [i].trans_forward_character.size <
                LOWERVALUE (ift$trans_fwd_char_size))
            { } OR (term_conn_attributes [i].trans_forward_character.size >
                UPPERVALUE (ift$trans_fwd_char_size)) THEN
              text := 'TRANS_FORWARD_CHARACTER';
            IFEND;

          = ifc$trans_length_mode =
            IF (term_conn_attributes [i].trans_length_mode < LOWERVALUE
                  (ift$trans_length_mode)) { } OR (term_conn_attributes [i].
                  trans_length_mode > UPPERVALUE (ift$trans_length_mode)) THEN
              text := 'TRANS_LENGTH_MODE';
            IFEND;

          = ifc$trans_message_length =
            IF (term_conn_attributes [i].trans_message_length < LOWERVALUE
                  (ift$trans_message_length))
            { } OR (term_conn_attributes [i].trans_message_length > UPPERVALUE
                  (ift$trans_message_length)) THEN
              text := 'TRANS_MESSAGE_LENGTH';
            IFEND;

          = ifc$trans_terminate_character =
            IF (term_conn_attributes [i].trans_terminate_character.size <
                LOWERVALUE (ift$trans_term_char_size))
                OR (term_conn_attributes [i].trans_terminate_character.size >
                UPPERVALUE (ift$trans_term_char_size)) THEN
              text := 'TRANS_TERMINATE_CHARACTER';
            IFEND;

          = ifc$trans_timeout_mode =
            IF (term_conn_attributes [i].trans_timeout_mode < LOWERVALUE (ift$trans_timeout_mode))
            { } OR (term_conn_attributes [i].trans_timeout_mode > UPPERVALUE (ift$trans_timeout_mode))
                  THEN
              text := 'TRANS_TIMEOUT_MODE';
            IFEND;

          = ifc$trans_protocol_mode =
            IF iiv$network_identifier = iic$dsiaf_network THEN
              IF iiv$cdcnet_connection THEN
                IF (term_conn_attributes [i].trans_protocol_mode < LOWERVALUE (ift$trans_protocol_mode))
                  { } OR (term_conn_attributes [i].trans_protocol_mode > UPPERVALUE (ift$trans_protocol_mode))
                  THEN
                    text := 'TRANS_PROTOCOL_MODE';
                IFEND;
              ELSE
                osp$set_status_abnormal (ifc$interactive_facility_id,
                  ife$illegal_nam_ccp_conn_change,
                  'RMM$REQUEST_TERMINAL', status);

                EXIT /request_terminal/;
              IFEND;
            ELSE
              IF (term_conn_attributes [i].trans_protocol_mode < LOWERVALUE (ift$trans_protocol_mode))
                { } OR (term_conn_attributes [i].trans_protocol_mode > UPPERVALUE (ift$trans_protocol_mode))
                THEN
                  text := 'TRANS_PROTOCOL_MODE';
              IFEND;

            IFEND;
          ELSE
            text := 'IMPROPER REQ ATTRIBUTE KEY';
            osp$set_status_abnormal (rmc$resource_management_id,
                  rme$improper_term_attrib_key, text, bam_status);
            status := bam_status;
            EXIT /request_terminal/;
          CASEND;

          IF text <> osc$null_name THEN
            IF bam_status.normal THEN
              osp$set_status_abnormal (rmc$resource_management_id,
                    rme$improper_term_attrib_value, text, bam_status);
            ELSE
              osp$append_status_parameter (osc$status_parameter_delimiter, text,
                    bam_status);
            IFEND;
            text := osc$null_name;
          IFEND;

        FOREND;
      IFEND; { UPPERBOUND (term_conn_attributes) <> 0 }

      IF bam_status.normal THEN

      { Store connection defaults set by CHATCD in the LNT along with the
      { attributes specified on this request, the latter having precedence.

        IF attributes_pointer = NIL THEN
          attributes := ^term_conn_attributes;
        ELSE

          j := 0;
        /search/
          FOR index := ifc$min_connection_key TO ifc$max_connection_key DO
            FOR i := 1 TO UPPERBOUND (term_conn_attributes) DO
              IF term_conn_attributes [i].key = index THEN
                j := j + 1;
                lnt_attributes [j] := term_conn_attributes [i];
                CYCLE /search/;
              IFEND;
            FOREND;

          { Attributes not specified on this REQT, i.e., not found in the above
          { FOR-loop, will be set to their CHATCD value if they were set by CHATCD.

            CASE index OF

            = ifc$attention_character_action =
              IF attributes_pointer^.attention_character_action.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].attention_character_action := attributes_pointer^.
                      attention_character_action.value;
              IFEND;

            = ifc$break_key_action =
              IF attributes_pointer^.break_key_action.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
              lnt_attributes [j].break_key_action :=
                    attributes_pointer^.break_key_action.value;
              IFEND;

            = ifc$end_of_information =
              IF attributes_pointer^.end_of_information.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].end_of_information :=
                      attributes_pointer^.end_of_information.value;
              IFEND;

            = ifc$input_block_size =
              IF attributes_pointer^.input_block_size.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].input_block_size := attributes_pointer^.
                      input_block_size.value;
              IFEND;

            = ifc$input_editing_mode =
              IF attributes_pointer^.input_editing_mode.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].input_editing_mode := attributes_pointer^.
                      input_editing_mode.value;
              IFEND;

            = ifc$input_timeout =
              IF attributes_pointer^.input_timeout.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].input_timeout := attributes_pointer^.input_timeout.value;
              IFEND;

            = ifc$input_timeout_length =
              IF attributes_pointer^.input_timeout_length.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].input_timeout_length := attributes_pointer^.
                      input_timeout_length.value;
              IFEND;

            = ifc$input_timeout_purge =
              IF attributes_pointer^.input_timeout_purge.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].input_timeout_purge := attributes_pointer^.
                      input_timeout_purge.value;
              IFEND;

            = ifc$input_output_mode =
              IF attributes_pointer^.input_output_mode.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].input_output_mode := attributes_pointer^.
                      input_output_mode.value;
              IFEND;

            = ifc$partial_char_forwarding =
              IF attributes_pointer^.partial_char_forwarding.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].partial_character_forwarding := attributes_pointer^.
                      partial_char_forwarding.value;
              IFEND;

            = ifc$prompt_file =
              IF attributes_pointer^.prompt_file.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].prompt_file := attributes_pointer^.prompt_file.value;
              IFEND;

            = ifc$prompt_file_identifier =
              IF attributes_pointer^.prompt_file_identifier.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].prompt_file_identifier := attributes_pointer^.
                      prompt_file_identifier.value;
              IFEND;

            = ifc$prompt_string =
              IF attributes_pointer^.prompt_string.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].prompt_string := attributes_pointer^.prompt_string.value;
              IFEND;

            = ifc$store_backspace_character =
              IF attributes_pointer^.store_backspace_character.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].store_backspace_character := attributes_pointer^.
                      store_backspace_character.value;
              IFEND;

            = ifc$store_nuls_dels =
              IF attributes_pointer^.store_nuls_dels.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].store_nuls_dels := attributes_pointer^.store_nuls_dels.value;
              IFEND;

            = ifc$trans_character_mode =
              IF attributes_pointer^.trans_character_mode.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].trans_character_mode := attributes_pointer^.
                      trans_character_mode.value;
              IFEND;

            = ifc$trans_forward_character =
              IF attributes_pointer^.trans_forward_character.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].trans_forward_character := attributes_pointer^.
                      trans_forward_character.value;
              IFEND;

            = ifc$trans_length_mode =
              IF attributes_pointer^.trans_length_mode.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].trans_length_mode := attributes_pointer^.
                      trans_length_mode.value;
              IFEND;

            = ifc$trans_timeout_mode =
              IF attributes_pointer^.trans_timeout_mode.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
              lnt_attributes [j].trans_timeout_mode := attributes_pointer^.
                    trans_timeout_mode.value;
              IFEND;

            = ifc$trans_message_length =
              IF attributes_pointer^.break_key_action.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].trans_message_length := attributes_pointer^.
                      trans_message_length.value;
              IFEND;

            = ifc$trans_terminate_character =
              IF attributes_pointer^.trans_terminate_character.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].trans_terminate_character := attributes_pointer^.
                      trans_terminate_character.value;
              IFEND;

            = ifc$trans_protocol_mode =
              IF attributes_pointer^.trans_protocol_mode.source =
                    ifc$change_term_conn_dflt_req THEN
                j := j + 1;
                lnt_attributes [j].key := index;
                lnt_attributes [j].trans_protocol_mode := attributes_pointer^.
                      trans_protocol_mode.value;
              IFEND;

            ELSE
              {}
            CASEND;
          FOREND /search/;

          PUSH attributes: [1 .. j];
          FOR i := 1 TO j DO
            attributes^ [i] := lnt_attributes [i];
          FOREND;
        IFEND; { iiv$terminal_request_ptr = NIL }

        fmp$request_terminal (^validated_terminal_file_name, attributes,
              evaluated_file_reference, status);
        IF NOT status.normal THEN
          EXIT /request_terminal/;
        IFEND;

      ELSE
        status := bam_status;
      IFEND; { bam_status.normal }

    END /request_terminal/;

  PROCEND rmp$r3_request_terminal;
MODEND rmm$request_terminal;
*DECK DECK=RMM$RESOURCE_HELP_MESSAGES EXPAND=TRUE
~"CREATE_MESSAGE_MODULE RMM$DEDICATED_MAINT$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                     NOS/VE Maintenance Access Menu

  Status            : Maintenance access to an element is requested.
  Requested Element : ~P1

    You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TERMINATE_REQUEST
       1 - Terminate the request (include a reason with this menu selection).
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ALLOW_MAINTENANCE
       2 - Allow maintenance access after making sure that the requested
           element is DOWN, OFF, or UNCONFIGURED on mainframes:
             ~P2
             ~P3
             ~P4
             ~P5
~"**
~"CREATE_FULL_HELP_MESSAGE
      This menu asks you to confirm or deny maintenance access to an element
      that is physically accessible to more than one mainframe.  You should
      allow maintenance access from this mainframe only if you are sure that
      the element (~P1)
      is not in use on the mainframes identified.

~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=TERMINATE_REQUEST
      This choice denies the job maintenance access to the element.  Abnormal
      status is returned to the job.  Selection of this choice allows you
      to explain why maintenance access was denied.  For example:

      1 the tape unit that you requested is required for file backup until 5pm

      Your explanation is returned to the job within the abnormal status that
      is generated by this menu choice.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ALLOW_MAINTENANCE
      This choice confirms that the job may have maintenance access to an
      element that is physically connected to multiple mainframes.  Before
      you select this choice, ensure that the element is DOWN, OFF, or
      not configured on the mainframes identified in the menu; otherwise,
      enter selection 1.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"CREATE_MESSAGE_MODULE RMM$EXTEND_LABELED$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                     NOS/VE Labeled Volume List Extension Menu

  Status                 : An additional LABELED (scratch) volume is requested.
  Group                  : ~P1
  Location               : ~P2
  Requested Density      : ~P3
  Requesting Family Name : ~P4
  Requesting User Name   : ~P5
  Previous External VSN  : ~P6
  Previous Recorded VSN  : ~P7

    You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_REQUEST
       1 - Use CREATE_BLANK_LABELED_VOLUME, if necessary, to label the volume;
           mount it; and identify the 1 to 6 character vsn in the menu
           selection (i.e. 1 RVSN='string' or 1 RVSN=name).
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TERMINATE_REQUEST
       2 - Terminate the request (include a reason with the menu selection).

~"**
~"CREATE_FULL_HELP_MESSAGE
      This menu is presented because a job is requesting an additional
      labeled volume.  An additional volume is required when the job has
      exhausted the list of volumes identified by either a
      REQUEST_MAGNETIC_TAPE command or an ATTACH_FILE command.

      If you provide an additional volume, the job's volume list is
      automatically updated with the volume that you provide.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CONTINUE_REQUEST
      This choice identifies the volume that is to be added to the job's
      volume list.  The job requires a labeled volume.  If you intend to
      provide the job with an additional volume, do the following:

        1. Use the INITIALIZE_TAPE_VOLUME command to label the volume for
           the job, if necessary.
        2. Mount the volume on a tape unit and ready the unit.
        3. Enter the RECORDED_VSN using this menu choice.  If the EXTERNAL_VSN
           is different than the RECORDED_VSN, you must provide both, e.g.
               1 RVSN=XXXXXX EVSN=YYYYYY

           You may enter the value in the form of a string or an SCL name.  A
           string representation is required either when the VSN begins with a
           number or when special characters are used in the VSN.  For example:
             To enter an SCL name: 1 RVSN=VE0496
             To enter a VSN beginning with a number: 1 RVSN='901204'
               The latter produces 901204 as the RECORDED_VSN.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=TERMINATE_REQUEST
      This choice denies the job an additional labeled volume.  Abnormal status
      is returned to the job.  Selection of this choice also allows you to
      explain why the additional volume was denied.  For example:

      2 your account/project has exceeded its budget for tape volumes

      Your explanation is returned to the job within the abnormal status that
      is generated by this menu choice.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"CREATE_MESSAGE_MODULE RMM$EXTEND_UNLABELED$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                     NOS/VE Unlabeled Volume List Extension Menu

 Status                : An additional UNLABELED (scratch) volume is requested.
 Group                 : ~P1
 Location              : ~P2
 Requested Density     : ~P3
 Requesting Family Name: ~P4
 Requesting User Name  : ~P5
 Previous External VSN : ~P6

    You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_REQUEST
       1 - Identify the 1 to 6 character vsn of the volume you want to provide
           (i.e. 1 EVSN='string' or 1 EVSN=name).
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TERMINATE_REQUEST
       2 - Terminate the request (include a reason with the menu selection).

~"**
~"CREATE_FULL_HELP_MESSAGE
      This menu is presented because a job is requesting an additional
      unlabeled volume.  An additional volume is required when the job
      exhausts the list of volumes identified by either a
      REQUEST_MAGNETIC_TAPE command or an ATTACH_FILE command.

      If you provide an additional volume, the job's volume list is
      automatically updated with the volume that you provide.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CONTINUE_REQUEST
      This choice identifies the volume that is to be added to the job's
      volume list.  The job requires an unlabeled volume.  If you intend to
      provide the job with an additional volume, enter the EXTERNAL_VSN using
      this menu choice.

      You may enter the value in the form of a string or an SCL name.  A string
      representation is required either when the VSN begins with a number or
      when special characters are used in the VSN.  For example:

        To enter an SCL name: 1 EVSN=VE0496
        To enter a VSN beginning with a number: 1 EVSN='901204'
          The latter produces 901204 as the EXTERNAL_VSN.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=TERMINATE_REQUEST
      This choice denies the job an additional unlabeled volume.  Abnormal
      status is returned to the job.  Selection of this choice also allows
      you to explain why the additional volume was denied.  For example:

      2 your account/project has exceeded its budget for tape volumes

      Your explanation is returned to the job within the abnormal status that
      is generated by this menu choice.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"CREATE_MESSAGE_MODULE RMM$GENERIC_ERR_REC$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                     NOS/VE Generic Error Recovery Menu

  Status            : A fatal ~P4 error occurred ~P5.
  Element           : ~P2
  External VSN      : ~P1
  Tape Failure Mode : ~P3

    You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ATTEMPT_RECOVERY
       1 - Attempt recovery; another mount will be requested for this tape.
           Processing will continue after tape assignment and repositioning.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=NO_RECOVERY
       2 - No recovery; abnormal status is returned to the job.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"CREATE_MESSAGE_MODULE RMM$INCORRECT_RVSN$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                   NOS/VE Incorrect Labeled Volume Menu

  Status           : Either you assigned the wrong LABELED volume or
                     the user supplied an incorrect EVSN or RVSN.
  Requested Volume : External VSN=~P2
                     Recorded VSN=~P1
  Assigned Element : ~P4
  Assigned Volume  : Recorded VSN=~P3

    You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_REQUEST
       1 - Mount and assign the requested tape volume (~P2).
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TERMINATE_REQUEST
       2 - Terminate the assignment (include a reason with the menu selection).
~"**
~"CREATE_FULL_HELP_MESSAGE
      The job requested a volume whose RECORDED_VSN was supposed to be ~P1.
      However, you used the ASSIGN_DEVICE command to assign a volume whose
      RECORDED_VSN is ~P3.  Verify that the correct volume is mounted on
      element ~P4.

      If the volume you mounted has an EXTERNAL_VSN of ~P2, the user is
      violating security or forgot the RECORDED_VSN.  In either case,
      choose selection 2.  Abnormal status is returned to the job.

      If the volume you mounted is not the requested volume, enter selection 1.
      The job's request will return to the VE_DISPLAY TAPE_MOUNT to allow you
      to assign the correct volume to the job.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CONTINUE_REQUEST
      This choice retracts the incorrect assignment and causes the job's
      request to be returned to the VE_DISPLAY TAPE_MOUNT.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=TERMINATE_REQUEST
      This choice denies the job access to the volume.  Abnormal status is
      returned to the job.  Selection of this choice also allows you to
      explain why access was denied.  For example:

      2 a volume with the correct EXTERNAL_VSN could not be found

      Your explanation is returned to the job within the abnormal status that
      is generated by this menu choice.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"CREATE_MESSAGE_MODULE RMM$LOADPT_ERR_REC$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                     NOS/VE Loadpoint Error Recovery Menu

  Status            : A fatal write error occurred at loadpoint.
  Element           : ~P2
  External VSN      : ~P1
  Tape Failure Mode : ~P3

    You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ATTEMPT_RECOVERY
       1 - Attempt recovery - another mount will be requested after the tape
           unloads. If tape labels were destroyed by the fatal write error, do
           an INITIALIZE_TAPE_VOLUME with RVSN=~P4, after selecting
           this option.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=NO_RECOVERY
       2 - No recovery - a fatal error will be returned to the job.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"CREATE_MESSAGE_MODULE RMM$MANUAL_MAINT$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                     NOS/VE Tape Maintenance Menu

  Status           : A tape volume is requested for maintenance action.
  Requested Volume : ~P1
  Required Element : ~P3
  Write Enable     : ~P2

    You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ALLOW_MAINTENANCE
       1 - Allow the maintenance action on the required element using the
           requested volume; first, mount the volume on the required element.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TERMINATE_REQUEST
       2 - Terminate the request (include a reason with this menu selection).
~"**
~"CREATE_FULL_HELP_MESSAGE
      This menu asks that you confirm or deny maintenance access to the
      volume and element requested.  If you allow the maintenance access, you
      must first mount the volume on the element.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ALLOW_MAINTENANCE
      This choice enables maintenance action to the requested volume and
      element.  Before entering this selection:

        1. Write enable the volume, if indicated in the menu.
        2. Mount the volume on the element and make the element ready.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=TERMINATE_REQUEST
      This choice denies maintenance access to the element and the volume.
      Abnormal status is returned to the job.  Selection of this choice also
      allows you to explain why maintenance access was denied.  For example:

      2 the volume you requested is not on site

      Your explanation is returned to the job within the abnormal status that
      is generated by this menu choice.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"CREATE_MESSAGE_MODULE RMM$RESERVE_TAPE$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                           NOS/VE Tape Reservation Menu

     Status          :  This job requires tape elements that are not ON.

     Element Density :  Required  ON  DOWN  OFF
       ~P1         ~P2
       ~P3         ~P4
       ~P5         ~P6
       ~P7         ~P8

    You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ALLOW_RESERVATION
      1 - Allow the reservation (first make required elements available).
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=DISALLOW_RESERVATION
      2 - Disallow the reservation (include a reason with the menu selection).
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_ON_RESERVATION
      3 - Specify the number of minutes the job must wait until the elements
          are available; the default is 30 minutes.
~"**
~"CREATE_FULL_HELP_MESSAGE
      The job is attempting to reserve more tape units than are currently
      available.  For each density required, four values are displayed:

        Required - the number of units needed by the job
        ON       - the number of units currently available to the job
        DOWN     - the number of units that are either in the DOWN
                   state or whose channel/controller is in the DOWN state
        OFF      - the number of units that are either in the OFF state
                   or whose channel/controller is in the OFF state

      Your configuration may contain tape units that support two densities,
      e.g. 800/1600 or 1600/6250.  If so, you may see a menu like this
      example; the configuration has 4 tape units that support 1600/6250:
         Element Density :  Required  ON  DOWN  OFF
           MT9$1600             2      3    0    1
           MT9$6250             2      3    0    1
      In this example menu, 4 units of the paired unit type are requested
      (2 of each density) and 1 unit of the 4 in the configuration is OFF.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ALLOW_RESERVATION
      This choice allows the job to reserve the required number of elements.

      Before entering this selection, you must change the state of the needed
      element(s) to ON.  A tape unit may be described as DOWN or OFF in the
      menu either because the state of the tape unit is not ON or because the
      unit is not accessible.  A tape unit is not accessible when all channels
      or controllers connected to the tape unit are not ON.  Therefore, to
      make a tape unit accessible, you may need to change the state of any or
      all of the following: a channel, a controller, a tape unit.

      In the following example, element V60 is turned on:
      SOU/LCU
      LCU/CHANGE_ELEMENT_STATE element=v60 state=on
      LCU/QUIT
      SOU/
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=DISALLOW_RESERVATION
      This choice denies the job the additional elements.  Abnormal status
      is returned to the job.  Selection of this choice also allows you to
      explain why the additional elements were denied.  For example:

      2 it will be six hours before the elements could be made available

      Your explanation is returned to the job within the abnormal status that
      is generated by this menu choice.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=WAIT_ON_RESERVATION
      This choice allows you to place the job in wait for a specified number
      of minutes.  At the completion of the wait, this menu will reappear, if
      the required elements are still not available.

      For example, if the wait is expected to be 2 hours, enter 120 minutes:

         3 120

      The default wait time is 30 minutes.

      There are 1440 minutes in a day.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"CREATE_MESSAGE_MODULE RMM$ROBOTIC_MONOPOLY$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                     NOS/VE Robotic Element Monopoly Menu

  Status            : This job is requesting a volume that is in a robotic
                      library, but the job already has all of the robotic
                      elements assigned to it.
  Requested Density : ~P1
  Requested Volume  : ~P2

    You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_REQUEST
       1 - Eject volume ~P2 from the robotic library and mount it on an
           element that is not connected to the robotic library and
           that supports the required density: ~P1.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TERMINATE_REQUEST
       2 - Terminate the request (include a reason with this menu selection).
~"**
~"CREATE_FULL_HELP_MESSAGE
      A job has reserved a number of elements of density ~P1.  Because
      NOS/VE did not know at the time the job issued its RESERVE_RESOURCE
      command where the job's volumes were located, it could not determine
      whether or not the required elements were all connected to the 5744
      Library.

      Your configuration has some elements of the required density that are
      connected to the 5744 Library and some that are not.

      The job has reached a deadlock.  The job has successfully mounted volumes
      on all of the available elements connected to the 5744 Library.  The next
      volume that the job is attempting to mount (~P2) is located
      in the 5744 Library but there are no more elements on which the volume
      can be mounted.

      You may remove the volume from the 5744 Library and manually mount it
      on an element that is not connected to the 5744 Library or you may
      return abnormal status to the job.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CONTINUE_REQUEST
      This choice retracts the job's request for a robotic mount of the volume
      and causes the job's request to appear in the VE_DISPLAY TAPE_MOUNT.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=TERMINATE_REQUEST
      This choice denies the job access to the volume.  Abnormal status is
      returned to the job.  Selection of this choice also allows you to explain
      why access was denied.  For example:

      2 ~P2 is in the Library but you already have all of its units assigned

      Your explanation is returned to the job within the abnormal status that
      is generated by this menu choice.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"CREATE_MESSAGE_MODULE RMM$ROBOTIC_MAINT$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                     NOS/VE Tape Maintenance Menu

  Status           : A tape volume is requested for a maintenance action.
  Requested Volume : ~P1
  Required Element : ~P3
  Write Enable     : ~P2

    You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ALLOW_MAINTENANCE
       1 - Allow the maintenance action on the required element using the
           requested volume (~P1).
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TERMINATE_REQUEST
       2 - Terminate the request (include a reason with this menu selection).
~"**
~"CREATE_FULL_HELP_MESSAGE
      This menu asks that you confirm or deny maintenance access to the
      volume and element requested.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ALLOW_MAINTENANCE
      This choice enables maintenance action to the requested volume and
      element.  The volume will be automatically mounted by the 5744 Library.

~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=TERMINATE_REQUEST
      This choice denies maintenance access to the element and the volume.
      Abnormal status is returned to the job.  Selection of this choice also
      allows you to explain why maintenance access was denied.  For example:

      2 please defer maintenance until after 5 PM

      Your explanation is returned to the job within the abnormal status that
      is generated by this menu choice.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"CREATE_MESSAGE_MODULE RMM$WRITE_DISABLED$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                 NOS/VE Robotic Volume Write Disabled Menu

  Status          : The user requested a robotically mounted volume
                    for write access but the volume is not write enabled.
  Assigned Volume : ~P2

    You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ALLOW_WRITE_ACCESS
       1 - Allow write access to the volume.  Before making this selection
           you must: EJECT the volume ~P2 from the library, write-enable the
           volume, and ENTER the volume in the library.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TERMINATE_REQUEST
       2 - Terminate the assignment (include a reason with the menu selection).
~"**
~"CREATE_FULL_HELP_MESSAGE
      The job has requested write access to a volume located in the 5744
      Library, but the volume is not write enabled.

      You must either allow write access to the volume or return abnormal
      status to the job.

~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ALLOW_WRITE_ACCESS
      This choice allows write access to the volume by the job.  Choose
      this selection only if the user is authorized to write on the volume.

      To enable writing, you must first go to the 5744 Console and do the
      following:

        1. EJECT volume ~P2 from the 5744 Library.
        2. Write enable the volume by turning the thumbwheel until the white
           dot (or other write disable symbol) is no longer visible.
        3. ENTER the volume back into the 5744 Library.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=TERMINATE_REQUEST
      This choice denies the job write access to the element.  Abnormal status
      is returned to the job.  Selection of this choice also allows you to
      explain why write access was denied.  For example:

      2 you are not authorized for write access to this volume

      Your explanation is returned to the job within the abnormal status that
      is generated by this menu choice.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"CREATE_MESSAGE_MODULE RMM$WRITE_ERROR_RECY$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                     NOS/VE Write Error Recovery Menu

  Status            : A fatal write error occurred at block ~P4.
  Element           : ~P2
  External VSN      : ~P1
  Tape Failure Mode : ~P3

    You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_SAME_VOLUME
       1 - Attempt recovery - another mount is requested for this volume.
           Processing continues after volume assignment and repositioning.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=NO_RECOVERY
       2 - No recovery - a fatal error will be returned to the job.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_NEXT_VOLUME
       3 - Attempt recovery - the current volume is closed and writing
           continues on the next volume. This option should only be used
           after a tape media error that was not corrected by Option 1.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"CREATE_MESSAGE_MODULE RMM$WRONG_LABEL_TYPE$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                   NOS/VE Unlabeled Tape Assignment Menu

  Status           : The assigned volume is UNLABELED but the user requested
                     a LABELED volume.
  Requested Volume : External VSN=~P2
                     Recorded VSN=~P1
  Assigned Element : ~P3

    You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ASSIGN_LABELED_VOLUME
       1 - Mount and assign the requested LABELED tape volume (~P2).
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TERMINATE_REQUEST
       2 - Terminate the assignment (include a reason with the menu selection).
~"**
~"CREATE_FULL_HELP_MESSAGE
      The job requested a labeled volume but you used the ASSIGN_DEVICE command
      to assign an unlabeled volume to the job.  The EXTERNAL_VSN is ~P2.
      Verify that the correct volume is mounted on element:
      ~P3.

      If the correct volume was assigned, you must choose selection 2 to
      prevent the assignment.

      If an incorrect volume was assigned, choose selection 1.  The job's
      request will reappear in the VE_DISPLAY TAPE_MOUNT to allow you to
      correct the assignment.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ASSIGN_LABELED_VOLUME
      This choice allows you to assign the correct labeled volume to the
      job.  You will again see the job's request in the VE_DISPLAY TAPE_MOUNT.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=TERMINATE_REQUEST
      This choice denies the job access to the unlabeled volume.  Abnormal
      status is returned to the job.  Selection of this choice also allows
      you to explain why access was denied.  For example:

      2 you are not authorized access to this volume

      Your explanation is returned to the job within the abnormal status that
      is generated by this menu choice.
~"**
~"END_MESSAGE_MODULE CREATE_MODULE=YES
~"  CREATE_MESSAGE_MODULE RMM$CREBUV_BUV_MENU$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                          Tape Volume Initialization Menu

 Volume Status : Blank Unlabeled volume
 Tape Element  : ~P2

 This volume is blank unlabeled and contains no data.

 You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_CREBUV
      ~P1- Unlabels this blank unlabeled tape volume.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ABORT_CREBUV
      ~P1- Terminates the initialization of this tape volume.
~"**
~"CREATE_FULL_HELP_MESSAGE
      This menu allows you to confirm that the correct tape volume is mounted,
      and that it contains no data.

      Press RETURN/NEXT to return to the menu.  When the menu reappears, if
      you want additional help about a menu choice, enter the choice number
      followed by ?.  For example, enter 2? to obtain help information about
      choice 2.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CONTINUE_CREBUV
      This choice proceeds with the creation of a blank unlabeled volume
      even though the volume is already blank unlabeled.  Three tapemarks
      will be written at the beginning of the volume.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ABORT_CREBUV
      This choice terminates the initialization of the tape volume.  The
      volume is not modified and remains blank unlabeled.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROMPT
  Enter choice or ? for HELP:
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"  CREATE_MESSAGE_MODULE RMM$CREBUV_LE_MENU$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                          Tape Volume Initialization Menu

 Volume Status : Labeled volume whose first file is expired
 Tape Element  : ~P2

 The following information is currently on the volume:

   Volume Identifier (Recorded VSN) : ~P3
   Owner Identifier                 : ~P4
   Character Set                    : ~P5
   Expiration Date                  : ~P6
   File Accessibility               : ~P7
   Label Standard Version           : ~P8
   Volume Accessibility             : ~P9

 You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_CREBUV
      ~P1- Unlabels this labeled tape volume.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ABORT_CREBUV
      ~P1- Terminates the initialization of this tape volume.
~"**
~"CREATE_FULL_HELP_MESSAGE
      This menu allows you to confirm that the correct tape volume is mounted.
      This tape volume is labeled and the first file on the volume has expired.
      There may be other files on this volume that have not yet expired.
      Unless you are certain that you are initializing the correct volume and
      that all of the files on the volume have expired, you may want to contact
      the owner to confirm the volume serial number.

      Press RETURN/NEXT to return to the menu.  When the menu reappears, if
      you want additional help about a menu choice, enter the choice number
      followed by ?.  For example, enter 2? to obtain help information about
      choice 2.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CONTINUE_CREBUV
      This choice proceeds with the creation of a blank unlabeled volume.
      Any data previously recorded on the volume will be lost.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ABORT_CREBUV
     This choice terminates the initialization of the tape volume.  Any data
     previously recorded on the tape volume remains unchanged.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROMPT
  Enter choice or ? for HELP:
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"  CREATE_MESSAGE_MODULE RMM$CREBUV_LU_MENU$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                          Tape Volume Initialization Menu

 Volume Status : Labeled volume containing no expired files
 Tape Element  : ~P2

 The following information is currently on the volume:

   Volume Identifier (Recorded VSN) : ~P3
   Owner Identifier                 : ~P4
   Character Set                    : ~P5
   Expiration Date                  : ~P6
   File Accessibility               : ~P7
   Label Standard Version           : ~P8
   Volume Accessibility             : ~P9

 You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_CREBUV
      ~P1- Unlabels this labeled tape volume.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ABORT_CREBUV
      ~P1- Terminates the initialization of this tape volume.
~"**
~"CREATE_FULL_HELP_MESSAGE
      This menu allows you to confirm that the correct tape volume is mounted.
      This tape volume is labeled and contains no files that have expired.

      Unless you are certain that you are initializing the correct tape
      volume, you may want to contact the owner to confirm the volume serial
      number.

      Press RETURN/NEXT to return to the menu.  When the menu reappears, if
      you want additional help about a menu choice, enter the choice number
      followed by ?.  For example, enter 2? to obtain help information about
      choice 2.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CONTINUE_CREBUV
      This choice proceeds with the creation of a blank unlabeled volume.
      Any data previously recorded on the volume will be lost.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ABORT_CREBUV
      This choice terminates the initialization of the tape volume.  Any
      data previously recorded on the tape volume remains unchanged.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROMPT
  Enter choice or ? for HELP:
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"  CREATE_MESSAGE_MODULE RMM$CREBUV_URV_MENU$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                          Tape Volume Initialization Menu

 Volume Status : Read error at loadpoint
 Tape Element  : ~P2

 You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_CREBUV
      ~P1- Creates a blank unlabeled volume.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ABORT_CREBUV
      ~P1- Terminates the initialization of this tape volume.
~"**
~"CREATE_FULL_HELP_MESSAGE
      An error occurred at the load point when NOS/VE attempted to read the
      tape volume to find a label.  Consequently, the system cannot determine
      whether this is a blank tape or one that already contains data.

      This error can be caused by a tape unit problem.  Therefore, if you are
      certain you are initializing the correct tape volume, you may want to
      terminate the initialization and mount the volume on a different tape
      unit.

      If all of your tape units do not support the same densities, try mounting
      the volume on a unit that supports a different density to be certain
      that you are not initializing a volume containing valid data.

      Press RETURN/NEXT to return to the menu.  When the menu reappears, if
      you want additional help about a menu choice, enter the choice number
      followed by ?.  For example, enter 2? to obtain help information about
      choice 2.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CONTINUE_CREBUV
      This choice proceeds with the creation of a blank unlabeled volume.
      Any data previously recorded on the volume will be lost.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ABORT_CREBUV
      This choice terminates the initialization of the tape volume.  Any data
      previously recorded on the tape volume remains unchanged.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROMPT
  Enter choice or ? for HELP:
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"  CREATE_MESSAGE_MODULE RMM$CREBUV_UV_MENU$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                          Tape Volume Initialization Menu

 Volume Status : Unlabeled volume
 Tape Element  : ~P2

 This unlabeled volume contains data.

 You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_CREBUV
      ~P1- Creates a blank unlabeled tape volume.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ABORT_CREBUV
      ~P1- Terminates the initialization of this tape volume.
~"**
~"CREATE_FULL_HELP_MESSAGE
      This menu allows you to confirm that the correct tape volume is mounted,
      and that the data contained on it can be destroyed.

      Press RETURN/NEXT to return to the menu.  When the menu reappears, if
      you want additional help about a menu choice, enter the choice number
      followed by ?.  For example, enter 2? to obtain help information about
      choice 2.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CONTINUE_CREBUV
      This choice proceeds with the initialization of this tape volume using
      the proposed label information.  Any data previously recorded on the
      volume will be lost.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ABORT_CREBUV
      This choice terminates the initialization of the tape volume.  Any data
      previously recorded on the tape volume remains unchanged.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROMPT
  Enter choice or ? for HELP:
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"  CREATE_MESSAGE_MODULE RMM$INITV_EXP_MENU$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                          Tape Volume Initialization Menu

 Volume Status : Labeled volume whose first file is expired
 Tape Element  : ~P2

 Review the following proposed volume information for accuracy:

                                    Current              Proposed
   Volume Identifier (Recorded VSN) : ~P3 ~P10
   Owner Identifier                 : ~P4 ~P11
   Character Set                    : ~P5 ~P12
   Expiration Date                  : ~P6 ~P13
   File Accessibility               : ~P7 ~P14
   Label Standard Version           : ~P8 ~P15
   Volume Accessibility             : ~P9 ~P16

 You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_INITV
      ~P1- Initializes this labeled tape volume with the proposed values.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ABORT_INITV
      ~P1- Terminates the initialization of this tape volume.
~"**
~"CREATE_FULL_HELP_MESSAGE
      This menu allows you to confirm that the correct tape volume is mounted
      and that the proposed label information is correct.  This tape volume
      already has a label and the first file on the volume has expired.
      There may be other files on this volume that have not yet expired.
      Unless you are certain that you are initializing the correct volume
      and that all of the files on the volume have expired, you may want to
      to contact the owner to confirm the volume serial number.

      Press RETURN/NEXT to return to the menu.  When the menu reappears, if
      you want additional help about a menu choice, enter the choice number
      followed by ?.  For example, enter 2? to obtain help information about
      choice 2.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CONTINUE_INITV
      This choice proceeds with the initialization of this tape volume using
      the proposed label information.  Any data previously recorded on the
      volume will be lost.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ABORT_INITV
     This choice terminates the initialization of the tape volume.  Any data
     previously recorded on the tape volume remains unchanged.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROMPT
  Enter choice or ? for HELP:
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"  CREATE_MESSAGE_MODULE RMM$INITV_RE_MENU$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                          Tape Volume Initialization Menu

 Volume Status : Read error at loadpoint
 Tape Element  : ~P2

 Review the following proposed volume information for accuracy:

      Volume Identifier (Recorded VSN) :   ~P3
      Owner Identifier                 :   ~P4
      Character Set                    :   ~P5
      Expiration Date                  :   ~P6
      File Accessibility               :   ~P7
      Label Standard Version           :   ~P8
      Volume Accessibility             :   ~P9

 You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_INITV
      ~P1- Initializes this unreadable tape volume with the proposed values.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ABORT_INITV
      ~P1- Terminates the initialization of this tape volume.
~"**
~"CREATE_FULL_HELP_MESSAGE
      An error occurred at the load point when NOS/VE attempted to read the
      tape volume to find a label.  Consequently, the system cannot determine
      whether this is a blank tape or one that already contains data.

      This error can be caused by a tape unit problem.  Therefore, if you are
      certain you are initializing the correct tape volume, you may want to
      terminate the initialization and mount the volume on a different tape
      unit.

      If all of your tape units do not support the same densities, try mounting
      the volume on a unit that supports a different density to be certain
      that you are not initializing a volume containing valid data.

      Press RETURN/NEXT to return to the menu.  When the menu reappears, if
      you want additional help about a menu choice, enter the choice number
      followed by ?.  For example, enter 2? to obtain help information about
      choice 2.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CONTINUE_INITV
      This choice proceeds with the initialization of this tape volume using
      the proposed label information.  Any data previously recorded on the
      volume will be lost.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ABORT_INITV
      This choice terminates the initialization of the tape volume.  Any data
      previously recorded on the tape volume remains unchanged.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROMPT
  Enter choice or ? for HELP:
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"  CREATE_MESSAGE_MODULE RMM$INITV_UL_MENU$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                          Tape Volume Initialization Menu

 Volume Status : Unlabeled volume
 Tape Element  : ~P2

 Review the following proposed volume information for accuracy:

      Volume Identifier (Recorded VSN) :   ~P3
      Owner Identifier                 :   ~P4
      Character Set                    :   ~P5
      Expiration Date                  :   ~P6
      File Accessibility               :   ~P7
      Label Standard Version           :   ~P8
      Volume Accessibility             :   ~P9

 You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_INITV
      ~P1- Initializes this unlabeled tape volume with the proposed values.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ABORT_INITV
      ~P1- Terminates the initialization of this tape volume.
~"**
~"CREATE_FULL_HELP_MESSAGE
      This menu allows you to confirm that the correct tape volume is mounted
      and that the proposed label information is correct.

      The system cannot tell whether this is a blank tape or one that already
      contains data.  Unless you are certain that you are initializing the
      correct volume, you may want to contact the owner, if known, to confirm
      the volume serial number.

      Press RETURN/NEXT to return to the menu.  When the menu reappears, if
      you want additional help about a menu choice, enter the choice number
      followed by ?.  For example, enter 2? to obtain help information about
      choice 2.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CONTINUE_INITV
      This choice proceeds with the initialization of this tape volume using
      the proposed label information.  Any data previously recorded on the
      volume will be lost.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ABORT_INITV
      This choice terminates the initialization of the tape volume.  Any data
      previously recorded on the tape volume remains unchanged.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROMPT
  Enter choice or ? for HELP:
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"  CREATE_MESSAGE_MODULE RMM$INITV_UNEXP_MENU$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                          Tape Volume Initialization Menu

 Volume Status : Labeled volume containing no expired files
 Tape Element  : ~P2

 Review the following proposed volume information for accuracy:

                                    Current              Proposed
   Volume Identifier (Recorded VSN) : ~P3 ~P10
   Owner Identifier                 : ~P4 ~P11
   Character Set                    : ~P5 ~P12
   Expiration Date                  : ~P6 ~P13
   File Accessibility               : ~P7 ~P14
   Label Standard Version           : ~P8 ~P15
   Volume Accessibility             : ~P9 ~P16

 You have the following choices:

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_INITV
      ~P1- Initializes this labeled tape volume with the proposed values.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ABORT_INITV
      ~P1- Terminates the initialization of this tape volume.
~"**
~"CREATE_FULL_HELP_MESSAGE
      This menu allows you to confirm that the correct tape volume is mounted
      and that the proposed label information is correct.  This tape volume
      already has a label and contains no files that have expired.

      Unless you are certain that you are initializing the correct tape
      volume, you may want to contact the owner to confirm the volume serial
      number.

      Press RETURN/NEXT to return to the menu.  When the menu reappears, if
      you want additional help about a menu choice, enter the choice number
      followed by ?.  For example, enter 2? to obtain help information about
      choice 2.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CONTINUE_INITV
      This choice proceeds with the initialization of this tape volume using
      the proposed label information.  Any data previously recorded on the
      volume will be lost.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=ABORT_INITV
      This choice terminates the initialization of the tape volume.  Any
      data previously recorded on the tape volume remains unchanged.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=PROMPT
  Enter choice or ? for HELP:
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"CREATE_MESSAGE_MODULE RMM$ACTION_MESSAGES$US_ENGLISH
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ROBOTIC_UNIT_UNAVAILABLE
                    NOS/VE Tape Action Message

  Status              : A volume is mounted on a robotic element whose state
                        is DOWN or OFF.
  Requested Volume    : ~P1
  Unavailable Element : ~P2

  Action: To allow this job to use the requested volume (~P1), it is
          suggested that you turn the element ON using the LCU subcommand
          CHANGE_ELEMENT_STATE.  If you cannot turn the element ON, you
          may DISMOUNT the volume at the 5744 Console (you may have to use
          the FORCE option, if the element is "in use").
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=UNIT_NOT_OPERATIONAL
                    NOS/VE Tape Action Message

  Status                : The assigned tape element is NOT OPERATIONAL.
  Assigned Element      : ~P1
  Assigned Volume       : ~P2
  Requested Density     : ~P3
  Write Enable Required : ~P4

  Action: If you assigned the wrong element to this job, enter:
            /SOU REASSIGN_DEVICE ~P1
          Otherwise, make the assigned element operational.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=UNIT_NOT_READY
                    NOS/VE Tape Action Message

  Status                : The assigned tape element is NOT READY.
  Assigned Element      : ~P1
  Assigned Volume       : ~P2
  Requested Density     : ~P3
  Write Enable Required : ~P4

  Action: If you assigned the wrong element to this job, enter:
            /SOU REASSIGN_DEVICE ~P1
          Otherwise, ready the assigned element.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=UNIT_NOT_WRITE_ENABLED
                    NOS/VE Tape Action Message

  Status                : The assigned volume is NOT WRITE ENABLED.
  Assigned Element      : ~P1
  Assigned Volume       : ~P2
  Requested Density     : ~P3

  Action: If you assigned the wrong element to this job, enter:
            /SOU REASSIGN_DEVICE ~P1
          Otherwise, write enable the volume (~P2) and remount it on
          element ~P1.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"CREATE_MESSAGE_MODULE RMM$JOB_STATUS_MSGS$US_ENGLISH
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_FOR_FORCE
 Forcibly dismounting element ~P1.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_FOR_DISMOUNT
 Dismounting ~P1 from element ~P2.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_FOR_MOUNT
 Mounting ~P1 on element ~P2.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_FOR_QUERY
 Querying robotic library for volume ~P1.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_TAPE_UNIT
 ~P1 Waiting for tape unit.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_MANUAL_MOUNT
 ~P1 Waiting for mount of volume ~P2.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_ROBOTIC_UNIT
 ~P1 Volume ~P2 waiting for robotic element.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_SCRATCH_VOLUME
 Waiting for operator to supply an additional volume.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_SERVER_RETRY
 ~P1 Requesting volume ~P2 - server retrying.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_UNITS_BUSY
 ~P1 Waiting for busy element(s).
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_UNITS_UNAVAILABLE
 ~P1 Waiting ~P2 minute(s) - no element available.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=WAIT_VSN_BUSY
 ~P1 Waiting for busy volume ~P2.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"CREATE_MESSAGE_MODULE RMM$VOL_CLASSIFY$US_ENGLISH
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=VOLUME_CLASSIFICATION

 ~P1

   ~P2

   ~P3
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
*DECK DECK=RMM$RESOURCE_MANAGER EXPAND=TRUE
*copyc osd$default_pragmats
?? TITLE := '  NOS/VE : Resource Manager' ??
MODULE rmm$resource_manager;
{
{        PURPOSE:  The purpose of this module is to be the 2dd/user ring
{                  screen for those resource manager routines which
{                  accept a file reference as input.  This screen is needed
{                  in order to call clp$evaluate_file_reference in the user
{                  ring so that a file reference containing a user defined
{                  function can be evaluated.
{
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*IF NOT $true(osv$unix)
*copyc fsc$local
*IFEND
*copyc fst$file_reference
*copyc rme$class_validation_errors
*IF NOT $true(osv$unix)
*copyc fst$goi_object_information
*copyc rme$request_mass_storage
*copyc rme$request_tape
*copyc rmk$keypoints
*copyc rmt$tape_class
*copyc rmt$write_ring
*IFEND
*copyc rmt$device_classes
?? POP ??
*IF NOT $true(osv$unix)
*copyc bap$create_file
*copyc bap$get_device_class
*copyc bap$process_pt_request
*copyc bap$set_evaluated_file_abnormal
*copyc bap$set_evaluated_file_abnormal
*copyc clp$evaluate_file_reference
*copyc clp$get_variable_value
*copyc fsp$create_file
*copyc fsp$evaluate_file_for_creation
*copyc fsp$evaluate_file_reference
*copyc fsp$path_element
*copyc osp$enforce_exception_policies
*copyc osp$file_access_condition
*copyc osp$set_status_abnormal
*copyc osv$initial_exception_context
*copyc pfp$r3_get_object_information
*copyc rmp$r3_request_null_device
*copyc rmp$r3_request_terminal
*IFEND
*copyc osp$set_status_abnormal
*IF NOT $true(osv$unix)
*copyc oss$job_paged_literal
*ELSE
*copyc clp$convert_str_to_path_handle
*copyc fsp$close_file
*copyc fsp_open
*copyc osp$set_status_from_errno
*copyc rmp_isatty
*IFEND
*IF NOT $true(osv$unix)
?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    command_file_reference_allowed = TRUE;

  VAR
    default_information_request: [oss$job_paged_literal, READ] fst$goi_information_request :=
          [[fsc$specific_depth, 1], [fsc$goi_cycle_identity]],
    rmv$null_device_set: [XDCL, READ, oss$job_paged_literal] rmt$device_classes :=
          $rmt$device_classes [rmc$connected_file_device, rmc$log_device,
          rmc$interstate_link_device, rmc$local_queue_device, rmc$pipeline_device],
    rmv$valid_vsn_characters: [XDCL, READ, oss$job_paged_literal] set of char :=
          ['A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R',
           'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
           'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', '0', '1',
           '2', '3', '4', '5', '6', '7', '8', '9', ' ', '!', '"', '%', '&', '''', '(', ')', '*', '+',
           ',', '-', '.', '/', ':', ';', '<', '=', '>', '?', '_', '$', '#', '@'];
*IFEND

?? TITLE := '  [XDCL, #GATE] rmp$get_device_class', EJECT ??
*copyc RMH$GET_DEVICE_CLASS
?? EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$get_device_class
    (    file: fst$file_reference;
*IF NOT $true(osv$unix)
     VAR device_assigned: boolean;
*IFEND
     VAR device_class: rmt$device_class;
     VAR status: ost$status);

    VAR
      evaluated_file_reference: fst$evaluated_file_reference,
*IF NOT $true(osv$unix)
      context: ^ost$ecp_exception_context,
      information_request: fst$goi_information_request,
      local_status: ost$status,
      object_information_p: ^fst$goi_object_information,
      work_area_p: ^SEQ ( * );
*ELSE
      access_mode: amt_access_mode,
      errno: ost_c_integer,
      file_identifier: amt$file_identifier,
      file_reference: fst$path,
      ignore_path_handle_name: fst$path,
      open_mode: amt_open_mode,
      stat: integer,
      syserrlist_message: string (256),
      terminal_device: ost_c_boolean;
*IFEND

*IF NOT $true(osv$unix)
    #KEYPOINT (osk$entry, 0, rmk$get_device_class);
*IFEND

    status.normal := TRUE;
*IF NOT $true(osv$unix)
    context := NIL;
    device_assigned := FALSE;
    device_class := rmc$mass_storage_device;

    fsp$evaluate_file_reference (file, command_file_reference_allowed, evaluated_file_reference, status);
    IF status.normal AND ((evaluated_file_reference.number_of_path_elements < 3) AND
          ((fsp$path_element (^evaluated_file_reference, 1)^ <> fsc$local) OR
          (evaluated_file_reference.number_of_path_elements < 2))) THEN
      bap$set_evaluated_file_abnormal (evaluated_file_reference, pfe$name_not_permanent_file,
            'RMP$GET_DEVICE_CLASS', '', status);
    IFEND;
    IF NOT status.normal THEN
      #KEYPOINT (osk$exit, 0, rmk$get_device_class);
      RETURN;
    IFEND;

    IF fsp$path_element (^evaluated_file_reference, 1)^ = fsc$local THEN
      bap$get_device_class (evaluated_file_reference.path_handle_info.path_handle, device_assigned,
            device_class, local_status);
      IF device_class IN rmv$null_device_set THEN
        device_class := rmc$null_device;
      IFEND;
    ELSE
      PUSH work_area_p: [[REP #SIZE (fst$goi_object_information) + fsc$max_path_size +
            #SIZE (fst$goi_object) OF cell]];
      information_request := default_information_request;

    /get_device_class/
      REPEAT
        RESET work_area_p;
        pfp$r3_get_object_information (evaluated_file_reference, information_request, NIL,
              work_area_p, local_status);
        IF local_status.normal THEN
          RESET work_area_p;
          NEXT object_information_p IN work_area_p;
          IF object_information_p <> NIL THEN
            IF object_information_p^.object <> NIL THEN
              IF object_information_p^.object^.object_type = fsc$goi_cycle_object THEN
                device_assigned := TRUE;
                IF object_information_p^.object^.cycle_device_class IN rmv$null_device_set THEN
                  device_class := rmc$null_device;
                ELSE
                  device_class := object_information_p^.object^.cycle_device_class;
                IFEND;
              ELSE
                EXIT /get_device_class/;
              IFEND;
            ELSE
              bap$set_evaluated_file_abnormal (evaluated_file_reference, pfe$name_not_permanent_file,
                    'RMP$GET_DEVICE_CLASS', '', status);
            IFEND;
          IFEND;
        ELSEIF osp$file_access_condition (local_status) THEN
          IF context = NIL THEN
            PUSH context;
            context^ := osv$initial_exception_context;
            context^.file.selector := osc$ecp_evaluated_file_ref;
            context^.file.evaluated_file_reference := evaluated_file_reference;
          IFEND;
          context^.condition_status := local_status;
          osp$enforce_exception_policies (context^);
          local_status := context^.condition_status;
        IFEND;
      UNTIL local_status.normal OR (NOT osp$file_access_condition (local_status)) OR (NOT context^.wait);
    IFEND;

    #KEYPOINT (osk$exit, 0, rmk$get_device_class);
*ELSE
    file_reference := file;
    open_mode := amc_o_rdonly;
    access_mode.delay := 0;
    access_mode.append := 0;
    access_mode.sync := 0;
    access_mode.creat := 0;
    access_mode.trunc := 0;
    access_mode.excl := 0;
    errno := 0;
    syserrlist_message := ' ';
    stat := 0;

    clp$convert_str_to_path_handle (file_reference, {delete_allowed} TRUE, {resolve_path} TRUE,
          {open_position} FALSE, ignore_path_handle_name, evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF evaluated_file_reference.command_file_path.found THEN
      device_class := rmc$terminal_device;
    ELSE
      fsp_open (file_reference, open_mode, access_mode, file_identifier, errno,
            syserrlist_message, stat);
      IF stat = 0 THEN
        rmp_isatty (file_identifier, terminal_device);
        CASE terminal_device OF
        = 0 =
          device_class := rmc$mass_storage_device;
        ELSE
          device_class := rmc$terminal_device;
        CASEND;
        fsp$close_file (file_identifier, status);
      ELSE
        osp$set_status_from_errno ('rmp$get_device_class', errno, syserrlist_message, status);
      IFEND;
    IFEND;
*IFEND

  PROCEND rmp$get_device_class;

*IF NOT $true(osv$unix)
?? TITLE := '  [XDCL, #GATE] rmp$request_mass_storage', EJECT ??
*copy rmh$request_mass_storage
?? EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$request_mass_storage
    (    file: fst$file_reference;
         allocation_size: rmt$allocation_size;
         estimated_file_size: amt$file_byte_address;
         file_class: rmt$mass_storage_class;
         initial_volume: rmt$recorded_vsn;
         volume_overflow_allowed: boolean;
     VAR status: ost$status);

    VAR
      device_attributes: array [1 .. 5] of fst$device_attribute,
      ignore_status: ost$status,
      resolved_path: fst$path;

    #KEYPOINT (osk$entry, 0, rmk$request_mass_storage);

    status.normal := TRUE;

    device_attributes [1].selector := fsc$allocation_size;
    device_attributes [1].allocation_size := allocation_size;
    device_attributes [2].selector := fsc$estimated_file_size;
    device_attributes [2].estimated_file_size := estimated_file_size;
    device_attributes [3].selector := fsc$mass_storage_class;
    device_attributes [3].mass_storage_class := file_class;
    device_attributes [4].selector := fsc$initial_volume;
    device_attributes [4].initial_volume := initial_volume;
    device_attributes [5].selector := fsc$volume_overflow_allowed;
    device_attributes [5].volume_overflow_allowed := volume_overflow_allowed;

    fsp$create_file (file, {attachment_options} NIL, {cycle_attributes} NIL, ^device_attributes,
          {file_attributes} NIL, resolved_path, status);

    #KEYPOINT (osk$exit, 0, rmk$request_mass_storage);

  PROCEND rmp$request_mass_storage;

?? TITLE := '  [XDCL, #GATE] rmp$request_null_device', EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$request_null_device
    (    file: fst$file_reference;
     VAR status: ost$status);

    VAR
      evaluated_file_reference: fst$evaluated_file_reference;

    #KEYPOINT (osk$entry, 0, rmk$request_null_device);

    status.normal := TRUE;

    fsp$evaluate_file_for_creation (file, NOT command_file_reference_allowed,
          evaluated_file_reference, status);

    IF status.normal THEN
      rmp$r3_request_null_device (evaluated_file_reference, status);
    IFEND;

    #KEYPOINT (osk$exit, 0, rmk$request_null_device);

  PROCEND rmp$request_null_device;

?? TITLE := '  [XDCL, #GATE] rmp$request_tape', EJECT ??
*copyc RMH$REQUEST_TAPE

  PROCEDURE [XDCL, #GATE] rmp$request_tape
    (    file: fst$file_reference;
         class: rmt$tape_class;
         density: rmt$density;
         write_ring: rmt$write_ring;
         volume_list: rmt$volume_list;
     VAR status: ost$status);

    VAR
      attachment_options: ^fst$attachment_options,
      attribute_count: integer,
      device_attributes: ^fst$device_attributes,
      evaluated_file_reference: fst$evaluated_file_reference,
      family_name: ost$name,
      ignore_process_pt_results: bat$process_pt_results,
      p_data_value: ^clt$data_value,
      resolved_path: fst$path;

    CONST
      max_attachment_options = 1,
      max_device_attributes = 5;

    #KEYPOINT (osk$entry, 0, rmk$request_tape);

    fsp$evaluate_file_for_creation (file, NOT command_file_reference_allowed,
          evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF (class < rmc$mt9) OR (class > rmc$mt18) THEN
      bap$set_evaluated_file_abnormal (evaluated_file_reference, rme$improper_class_value,
            'RMP$REQUEST_TAPE', '', status);
      RETURN;
    IFEND;

    IF (density < rmc$800) OR (density > rmc$38000) THEN
      osp$set_status_abnormal (rmc$resource_management_id, rme$improper_density_value, '', status);
      RETURN;
    IFEND;

    IF (write_ring < LOWERVALUE (rmt$write_ring)) OR (write_ring > UPPERVALUE (rmt$write_ring)) THEN
      bap$set_evaluated_file_abnormal (evaluated_file_reference, rme$improper_write_ring_value,
            'RMP$REQUEST_TAPE', '', status);
      RETURN;
    IFEND;

    PUSH attachment_options: [1 .. max_attachment_options];
    attribute_count := 0;

    attribute_count := attribute_count + 1;
    attachment_options^ [attribute_count].selector := fsc$access_and_share_modes;
    attachment_options^ [attribute_count].access_modes.selector := fsc$specific_access_modes;
    IF write_ring = rmc$write_ring THEN
      attachment_options^ [attribute_count].access_modes.value :=
            $fst$file_access_options [fsc$read, fsc$shorten, fsc$append, fsc$modify];
    ELSE
      attachment_options^ [attribute_count].access_modes.value :=
            $fst$file_access_options [fsc$read];
    IFEND;
    attachment_options^ [attribute_count].share_modes.selector := fsc$specific_share_modes;
    attachment_options^ [attribute_count].share_modes.value := $fst$file_access_options [];

    PUSH device_attributes: [1 .. max_device_attributes];
    attribute_count := 0;

    attribute_count := attribute_count + 1;
    device_attributes^ [attribute_count].selector := fsc$device_class;
    device_attributes^ [attribute_count].device_class := fsc$magnetic_tape_device;

    attribute_count := attribute_count + 1;
    device_attributes^ [attribute_count].selector := fsc$removable_media_group;

    PUSH p_data_value;
    clp$get_variable_value ('OSD$REQMT_REMOVABLE_MEDIA_GROUP', p_data_value, status);
    IF status.normal AND (p_data_value^.kind = clc$name) THEN
      device_attributes^ [attribute_count].removable_media_group := p_data_value^.name_value;
    ELSE
      device_attributes^ [attribute_count].removable_media_group := osc$null_name;
    IFEND;

    attribute_count := attribute_count + 1;
    device_attributes^ [attribute_count].selector := fsc$density;
    device_attributes^ [attribute_count].density := density;

    attribute_count := attribute_count + 1;
    device_attributes^ [attribute_count].selector := fsc$volume_overflow_allowed;
    device_attributes^ [attribute_count].volume_overflow_allowed := TRUE;

    attribute_count := attribute_count + 1;
    device_attributes^ [attribute_count].selector := fsc$volume_list;
    device_attributes^ [attribute_count].volume_list := ^volume_list;

    bap$create_file (attachment_options, {cycle_attributes} NIL, {file_attributes} NIL,
          device_attributes, evaluated_file_reference, resolved_path, status);

    #KEYPOINT (osk$exit, 0, rmk$request_tape);

  PROCEND rmp$request_tape;

?? TITLE := '  [XDCL, #GATE] rmp$request_terminal', EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$request_terminal
    (    file: fst$file_reference;
         terminal_file_name: ^fst$file_reference;
         term_conn_attributes: ift$connection_attributes;
     VAR status: ost$status);

    VAR
      cycle_number_specified: boolean,
      evaluated_file_reference: fst$evaluated_file_reference,
      ignore_process_pt_results: bat$process_pt_results;

    #KEYPOINT (osk$entry, 0, rmk$request_terminal);

    status.normal := TRUE;

{
{ Request Terminal calls clp$evaluate_file_reference & bap$process_pt_request
{ rather than fsp$evaluate_file_reference because it is necessary to
{ record the path so that rmp$r3_request_terminal can compare the
{ requested file with the prompt file (if specified) to see if they are the
{ same.
{
    clp$evaluate_file_reference (file, $clt$file_ref_parsing_options
            [clc$use_$local_as_working_cat], {resolve_cycle_number=} FALSE,
            evaluated_file_reference, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cycle_number_specified := evaluated_file_reference.cycle_reference.specification = fsc$cycle_number;

{ Return permanent file path if alias and resolve if registered.
    IF (fsp$path_element (^evaluated_file_reference, 1) ^ = fsc$local) THEN
      bap$process_pt_request ($bat$process_pt_work_list [bac$record_path,
            bac$resolve_path], osc$null_name, evaluated_file_reference,
            ignore_process_pt_results, status);
    IFEND;

    IF status.normal THEN

{ The following IF statement is necessary to prevent a currently attached file from being resolved to the next
{ cycle (in fmp$request_terminal), if a specific cycle was requested.

      IF cycle_number_specified THEN
        evaluated_file_reference.path_handle_info.path_handle_present := FALSE;
      IFEND;
      rmp$r3_request_terminal (terminal_file_name, term_conn_attributes,
            evaluated_file_reference, status);
    IFEND;

    #KEYPOINT (osk$exit, 0, rmk$request_terminal);

  PROCEND rmp$request_terminal;
*IFEND

MODEND rmm$resource_manager;
*DECK DECK=RMM$ROBOTIC_INTERFACES_23D EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Resource Management : Robotic Server Interfaces' ??
*copyc osd$default_pragmats
MODULE rmm$robotic_interfaces_23d;

{ Purpose: This module contains the interfaces used by a NOS/VE
{ server to intercept mount requests for removable media and
{ to automate the mount/dismount process.
{

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    one_second = 1000 {milliseconds};

?? NEWTITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc jmc$system_family
*copyc mmp$verify_access
*copyc osd$integer_limits
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc iot$logical_unit
*copyc ost$status
*copyc rmc$unspecified_vsn
*copyc rme$condition_codes
*copyc rme$robotic_interface_errors
*copyc rmt$external_vsn
*copyc rmt$rbt_request
*copyc rmt$rbt_unformatted_response
*copyc rmt$rbt_server_attribute
?? POP ??
*copyc clp$trimmed_string_size
*copyc clp$validate_name
*copyc iop$define_robotic_server
*copyc iop$get_server_entry
*copyc iop$remove_robotic_server
*copyc iop$server_get_request
*copyc iop$server_put_response
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$get_parameter_prompt
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osv$lower_to_upper
*copyc pmp$get_user_identification
*copyc pmp$wait
*copyc rmp$log_debug_integer
*copyc rmp$log_debug_message
*copyc rmp$log_debug_status
*copyc rmp$validate_ansi_string

?? OLDTITLE ??
?? NEWTITLE := 'Global Variables Declared by this Module', EJECT ??


  VAR
    valid_requests: [STATIC, READ, oss$job_paged_literal] rmt$rbt_supported_requests :=
          [rmc$rbt_query, rmc$rbt_mount, rmc$rbt_dismount, rmc$rbt_force_dismount],

    rmv$default_server_attributes: [STATIC, READ, oss$job_paged_literal] iot$robotic_server_attributes :=
          [[rmc$rbt_query, rmc$rbt_mount, rmc$rbt_dismount, rmc$rbt_force_dismount], 300000 {5 minutes} ];

?? OLDTITLE ??
?? NEWTITLE := 'rmp$define_robotic_server', EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$define_robotic_server
    (    server_name: ost$name;
         managed_elements: array [1 .. * ] of cmt$element_name;
         server_attributes: array [1 .. * ] of rmt$rbt_server_attribute;
     VAR status: ost$status);

    CONST
      procedure_name = 'RMP$DEFINE_ROBOTIC_SERVER';

    VAR
      caller_id: ost$caller_identifier,
      debug_message_logged: boolean,
      server_entry: iot$robotic_server_entry,
      validated_attributes: iot$robotic_server_attributes,
      validated_elements_p: ^array [1 .. * ] of cmt$element_name,
      validated_server_name: ost$name;

    #CALLER_ID (caller_id);

    status.normal := TRUE;

    validate_caller (caller_id, status);
    IF status.normal THEN
      validate_server_name (server_name, procedure_name, FALSE {require_server_preexist} , server_entry,
            validated_server_name, status);
      IF status.normal THEN
        PUSH validated_elements_p: [LOWERBOUND (managed_elements) .. UPPERBOUND (managed_elements)];
        validate_element_list (managed_elements, 'MANAGED_ELEMENTS parameter', procedure_name, NIL
              {no server entry} , validated_elements_p^, status);
        IF status.normal THEN
          validate_server_attributes (server_attributes, procedure_name, validated_attributes, status);
          IF status.normal THEN
            debug_message_logged := FALSE;
            REPEAT
              IF NOT debug_message_logged THEN
                rmp$log_debug_message (' Calling iop$define_robotic_server');
              IFEND;
              iop$define_robotic_server (validated_server_name, validated_elements_p^, validated_attributes,
                    status);
              IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
                IF NOT debug_message_logged THEN
                  rmp$log_debug_message (' Waiting for tape table lock');
                  debug_message_logged := TRUE;
                IFEND;
                pmp$wait (one_second, one_second);
              IFEND;
            UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND rmp$define_robotic_server;

?? OLDTITLE ??
?? NEWTITLE := 'rmp$remove_robotic_server', EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$remove_robotic_server
    (    server_name: ost$name;
     VAR status: ost$status);

    CONST
      procedure_name = 'RMP$REMOVE_ROBOTIC_SERVER';

    VAR
      debug_message_logged: boolean,
      caller_id: ost$caller_identifier,
      server_entry: iot$robotic_server_entry,
      validated_server_name: ost$name;

    #CALLER_ID (caller_id);

    status.normal := TRUE;

    validate_caller (caller_id, status);
    IF status.normal THEN
      validate_server_name (server_name, procedure_name, TRUE {require__server_preexist} , server_entry,
            validated_server_name, status);
      IF status.normal THEN
        debug_message_logged := FALSE;
        REPEAT
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Calling iop$remove_robotic_server');
          IFEND;
          iop$remove_robotic_server (validated_server_name, status);
          IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Waiting for tape table lock');
              debug_message_logged := TRUE;
            IFEND;
            pmp$wait (one_second, one_second);
          IFEND;
        UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
      IFEND;
    IFEND;

  PROCEND rmp$remove_robotic_server;

?? NEWTITLE := 'rmp$server_get_request_23d', EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$server_get_request_23d
    (    server_name: ost$name;
         wait: boolean;
     VAR client_request: rmt$rbt_request;
     VAR status: ost$status);

    CONST
      procedure_name = 'RMP$SERVER_GET_REQUEST';

    VAR
      caller_id: ost$caller_identifier,
      debug_message_logged: boolean,
      server_entry: iot$robotic_server_entry,
      validated_server_name: ost$name;

    #CALLER_ID (caller_id);

    status.normal := TRUE;

    validate_caller (caller_id, status);
    IF status.normal THEN
      validate_server_name (server_name, procedure_name, TRUE {validate_server_preexist} , server_entry,
            validated_server_name, status);
      IF status.normal THEN
        IF (wait < LOWERVALUE (boolean)) OR (wait > UPPERVALUE (boolean)) THEN
          osp$set_status_abnormal (rmc$resource_management_id, rme$invalid_wait_specified, procedure_name,
                status);
        ELSE
          debug_message_logged := FALSE;
          REPEAT
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Calling iop$server_get_request');
            IFEND;
            iop$server_get_request (validated_server_name, wait, client_request, status);
            IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
              IF NOT debug_message_logged THEN
                rmp$log_debug_message (' Waiting for tape table lock');
                debug_message_logged := TRUE;
              IFEND;
              pmp$wait (one_second, one_second);
            IFEND;
          UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
          IF status.normal THEN
            rmp$log_debug_integer (' Exiting rmp$server_get_request_23d: REQUEST_ID=',
                client_request.request_id);
          ELSE
            rmp$log_debug_message (' Exiting rmp$server_get_request_23d');
            rmp$log_debug_status (status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND rmp$server_get_request_23d;

?? OLDTITLE ??
?? NEWTITLE := 'rmp$server_put_response', EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$server_put_response
    (    server_name: ost$name;
         server_response: rmt$rbt_unformatted_response;
     VAR status: ost$status);

    CONST
      procedure_name = 'RMP$SERVER_PUT_RESPONSE';

    VAR
      debug_message_logged: boolean,
      caller_id: ost$caller_identifier,
      local_response: iot$formatted_server_response,
      server_entry: iot$robotic_server_entry,
      validated_server_name: ost$name;

    #CALLER_ID (caller_id);

    status.normal := TRUE;

    validate_caller (caller_id, status);
    IF status.normal THEN
      validate_server_name (server_name, procedure_name, TRUE {validate_server_defined} , server_entry,
            validated_server_name, status);
      IF status.normal THEN
        validate_request_id (server_response.request_id, 'REQUEST_ID', local_response.request_id, status);
        IF status.normal THEN
          validate_boolean (server_response.request_processed, 'REQUEST_PROCESSED',
                local_response.request_processed, status);
          IF status.normal THEN
            IF local_response.request_processed THEN
              validate_request_type (server_response.processed_request, 'PROCESSED_REQUEST',
                    local_response.processed_request, status);
              IF status.normal THEN
                CASE local_response.processed_request OF
                = rmc$rbt_query =
                  validate_response_query (server_response.query, local_response.query, status);
                  IF status.normal AND server_response.query.volume_located THEN
                    IF server_response.query.already_mounted THEN
                      validate_element_name (server_response.query.element, 'QUERY.ELEMENT', ^server_entry,
                            local_response.query.element, status);
                    ELSE
                      IF server_response.query.preferred_candidates <> NIL THEN
                        PUSH local_response.query.preferred_candidates:
                              [LOWERBOUND (server_response.query.preferred_candidates^) .. UPPERBOUND (
                              server_response.query.preferred_candidates^)];
                        validate_element_list (server_response.query.preferred_candidates^,
                              'QUERY.PREFERRED_CANDIDATES field', procedure_name, ^server_entry,
                              local_response.query.preferred_candidates^, status);
                      ELSE
                        local_response.query.preferred_candidates := NIL;
                      IFEND;
                      IF status.normal AND (server_response.query.remaining_candidates <> NIL) THEN
                        PUSH local_response.query.remaining_candidates:
                              [LOWERBOUND (server_response.query.remaining_candidates^) .. UPPERBOUND (
                              server_response.query.remaining_candidates^)];
                        validate_element_list (server_response.query.remaining_candidates^,
                              'QUERY.REMAINING_CANDIDATES field', procedure_name, ^server_entry,
                              local_response.query.remaining_candidates^, status);
                      ELSE
                        local_response.query.remaining_candidates := NIL;
                      IFEND;
                    IFEND;
                  IFEND;
                = rmc$rbt_mount =
                  validate_response_mount (server_response.mount, server_entry, local_response.mount, status);
                = rmc$rbt_dismount =
                  validate_response_dismount (server_response.dismount, server_entry, local_response.dismount,
                        status);
                = rmc$rbt_force_dismount =
                  validate_response_force_dismnt (server_response.force_dismount, server_entry,
                        local_response.force_dismount, status);
                CASEND;
              IFEND;
            ELSE
              process_response_retry (server_response, local_response, status);
            IFEND;
            IF status.normal THEN
              debug_message_logged := FALSE;
              REPEAT
                IF NOT debug_message_logged THEN
                  rmp$log_debug_message (' Calling iop$server_put_response');
                IFEND;
                iop$server_put_response (validated_server_name, local_response, status);
                IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
                  IF NOT debug_message_logged THEN
                    rmp$log_debug_message (' Waiting for tape table lock');
                    debug_message_logged := TRUE;
                  IFEND;
                  pmp$wait (one_second, one_second);
                IFEND;
              UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
              rmp$log_debug_integer (' Exiting rmp$server_put_response:    REQUEST_ID=',
                  server_response.request_id);
              rmp$log_debug_status (status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND rmp$server_put_response;

?? OLDTITLE ??
?? NEWTITLE := 'format_conditional_message', EJECT ??

  PROCEDURE format_conditional_message
    (    conditional_message: rmt$rbt_conditional_message;
     VAR formatted_conditional_message: iot$conditional_server_message;
     VAR status: ost$status);

    VAR
      formatted_message: ost$status_message;

    osp$get_parameter_prompt (conditional_message.message_module, conditional_message.message_name,
          conditional_message.message_parameters, rmc$rbt_status_message_width, formatted_message, status);

    IF status.normal THEN
      formatted_conditional_message.issue_prior_to_retry_attempt :=
            conditional_message.issue_prior_to_retry_attempt;
      formatted_conditional_message.message := formatted_message;
    IFEND;
  PROCEND format_conditional_message;
?? OLDTITLE ??
?? NEWTITLE := 'process_messages', EJECT ??

  PROCEDURE process_messages
    (    response: rmt$rbt_unformatted_response;
     VAR server_messages: iot$robotic_server_messages;
     VAR status: ost$status);

    VAR
      local_messages_requested: iot$requested_server_messages,
      job_log_conditional_message: iot$conditional_server_message,
      job_status_conditional_message: iot$conditional_server_message,
      operator_conditional_message: iot$conditional_server_message,
      system_log_conditional_message: iot$conditional_server_message;

    local_messages_requested := $iot$requested_server_messages [];
    IF response.job_log <> NIL THEN
      validate_pva (response.job_log, 'RESPONSE.JOB_LOG - invalid PVA', status);
      IF status.normal THEN
        validate_conditional_message (response.job_log^, 'RESPONSE.JOB_LOG',
              status);
        IF status.normal THEN
          format_conditional_message (response.job_log^,
                job_log_conditional_message, status);
          IF status.normal THEN
            local_messages_requested := local_messages_requested +
                  $iot$requested_server_messages [ioc$job_log_message];
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF response.job_status_display <> NIL THEN
      validate_pva (response.job_status_display,
            'RESPONSE.JOB_STATUS_DISPLAY - invalid PVA', status);
      IF status.normal THEN
        validate_conditional_message (response.job_status_display^,
              'RESPONSE.JOB_STATUS_DISPLAY', status);
        IF status.normal THEN
          format_conditional_message (response.job_status_display^,
                job_status_conditional_message, status);
          IF status.normal THEN
            local_messages_requested := local_messages_requested +
                  $iot$requested_server_messages [ioc$job_status_message];
          IFEND;
        IFEND;
      IFEND;
    IFEND;

    IF response.operator_action <> NIL THEN
      validate_pva (response.operator_action,
            'RESPONSE.OPERATOR_ACTION - invalid PVA', status);
      validate_conditional_message (response.operator_action^,
            'RESPONSE.OPERATOR_ACTION', status);
      IF status.normal THEN
        format_conditional_message (response.operator_action^,
              operator_conditional_message, status);
        IF status.normal THEN
          local_messages_requested := local_messages_requested +
                $iot$requested_server_messages [ioc$operator_action_message];
        IFEND;
      IFEND;
    IFEND;

    IF response.system_log <> NIL THEN
      validate_pva (response.system_log, 'RESPONSE.SYSTEM_LOG - invalid PVA',
            status);
      validate_conditional_message (response.system_log^, 'RESPONSE.SYSTEM_LOG',
            status);
      IF status.normal THEN
        format_conditional_message (response.system_log^,
              system_log_conditional_message, status);
        IF status.normal THEN
          local_messages_requested := local_messages_requested +
                $iot$requested_server_messages [ioc$system_log_message];
        IFEND;
      IFEND;
    IFEND;

    IF status.normal THEN
      server_messages.requested_messages := local_messages_requested;
      IF ioc$job_log_message IN local_messages_requested THEN
        server_messages.job_log := job_log_conditional_message;
      IFEND;
      IF ioc$job_status_message IN local_messages_requested THEN
        server_messages.job_status_display := job_status_conditional_message;
      IFEND;
      IF ioc$operator_action_message IN local_messages_requested THEN
        server_messages.operator_action := operator_conditional_message;
      IFEND;
      IF ioc$system_log_message IN local_messages_requested THEN
        server_messages.system_log := system_log_conditional_message;
      IFEND;
    IFEND;

  PROCEND process_messages;

?? OLDTITLE ??
?? NEWTITLE := 'process_response_retry', EJECT ??

  PROCEDURE process_response_retry
    (    response: rmt$rbt_unformatted_response;
     VAR server_response: iot$formatted_server_response;
     VAR status: ost$status);

    VAR
      server_messages: ^iot$robotic_server_messages;

    validate_request_type (response.current_request, 'RESPONSE.CURRENT_REQUEST',
          server_response.current_request, status);
    IF status.normal THEN
      PUSH server_messages;
      server_response.server_messages := server_messages;
      process_messages (response, server_response.server_messages^, status);
      IF status.normal THEN
        validate_request_type (response.next_request, 'RESPONSE.NEXT_REQUEST', server_response.next_request,
              status);
        IF status.normal THEN
          validate_request_type (response.next_request, 'RESPONSE.NEXT_REQUEST', server_response.next_request,
                status);
          IF status.normal THEN
            IF (response.server_event_code < 0) OR (response.server_event_code > osc$max_integer) THEN
              report_invalid_response_field ('SERVER_EVENT_CODE', status);
            ELSEIF (response.retry_delay_interval < 0) OR (response.retry_delay_interval > osc$max_integer)
                  THEN
              report_invalid_response_field ('RETRY_DELAY_INTERVAL', status);
            ELSEIF (response.retry_limit < 1) OR (response.retry_limit > osc$max_integer) THEN
              report_invalid_response_field ('RETRY_LIMIT', status);
            ELSE
              server_response.server_event_code := response.server_event_code;
              server_response.retry_delay_interval := response.retry_delay_interval;
              server_response.retry_limit := response.retry_limit;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND process_response_retry;

?? OLDTITLE ??
?? NEWTITLE := 'report_invalid_response_field', EJECT ??

  PROCEDURE [INLINE] report_invalid_response_field
    (    field: string ( * );
     VAR status: ost$status);

    osp$set_status_abnormal (rmc$resource_management_id, rme$invalid_server_response, field, status);

  PROCEND report_invalid_response_field;
?? OLDTITLE ??
?? NEWTITLE := 'validate_boolean', EJECT ??

  PROCEDURE validate_boolean
    (    boolean_value: boolean;
         field: string ( * );
     VAR validated_boolean: boolean;
     VAR status: ost$status);

    IF (boolean_value < LOWERVALUE (boolean)) OR (boolean_value > UPPERVALUE (boolean)) THEN
      report_invalid_response_field (field, status);
    ELSE
      status.normal := TRUE;
      validated_boolean := boolean_value;
    IFEND;

  PROCEND validate_boolean;

?? OLDTITLE ??
?? NEWTITLE := 'validate_caller', EJECT ??

  PROCEDURE validate_caller
    (    caller_id: ost$caller_identifier;

     VAR status: ost$status);

    VAR
      user_id: ost$user_identification;

    status.normal := TRUE;

    IF (caller_id.ring > osc$sj_ring_3 {ring 6} ) THEN
      osp$set_status_condition (rme$robotic_validation_error, status);
    ELSE
      pmp$get_user_identification (user_id, status);
      IF status.normal THEN
        IF (user_id.family = jmc$system_family) AND (user_id.user = jmc$system_user) THEN
          RETURN;
        ELSE
          osp$set_status_condition (rme$robotic_validation_error, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND validate_caller;

?? OLDTITLE ??
?? NEWTITLE := 'validate_conditional_message', EJECT ??

  PROCEDURE validate_conditional_message
    (    conditional_message: rmt$rbt_conditional_message;
         record_name: string ( * );
     VAR status: ost$status);

    CONST
      max_seed_name = 21; {Allows for natural language suffix of 10 characters}

    VAR
      field: string (osc$max_string_size),
      i: integer,
      ignore_name: ost$name,
      ignore_size: integer,
      name_is_valid: boolean;

    IF (conditional_message.issue_prior_to_retry_attempt < 1) OR
          (conditional_message.issue_prior_to_retry_attempt > osc$max_integer) THEN
      STRINGREP (field, ignore_size, record_name, '.ISSUE_PRIOR_TO_RETRY_ATTEMPT');
      report_invalid_response_field (field, status);
    ELSE
      clp$validate_name (conditional_message.message_module, ignore_name, name_is_valid);
      IF name_is_valid AND (clp$trimmed_string_size (conditional_message.message_module) <=
            max_seed_name) THEN
        clp$validate_name (conditional_message.message_name, ignore_name, name_is_valid);
        IF name_is_valid THEN
          IF conditional_message.message_parameters <> NIL THEN
            FOR i := LOWERBOUND (conditional_message.message_parameters^)
                  TO UPPERBOUND (conditional_message.message_parameters^) DO
              IF conditional_message.message_parameters^ [i] <> NIL THEN
                IF STRLENGTH (conditional_message.message_parameters^ [i]^) >
                      rmc$rbt_status_message_width THEN
                  STRINGREP (field, ignore_size, record_name, '.MESSAGE_PARAMETERS exceeds ',
                        rmc$rbt_status_message_width, ' characters in length');
                  report_invalid_response_field (field, status);
                  RETURN;
                IFEND;
              IFEND;
            FOREND;
          IFEND;
        ELSE
          STRINGREP (field, ignore_size, record_name, '.MESSAGE_NAME');
          report_invalid_response_field (field, status);
        IFEND;
      ELSE
        STRINGREP (field, ignore_size, record_name, '.MODULE_NAME is either not a valid name or it exceeds ',
              max_seed_name, ' characters in length');
        report_invalid_response_field (field, status);
      IFEND;
    IFEND;

  PROCEND validate_conditional_message;

?? OLDTITLE ??
?? NEWTITLE := 'validate_element_list', EJECT ??

  PROCEDURE validate_element_list
    (    element_list: array [1 .. * ] of cmt$element_name;
         field: string ( * );
         procedure_name: string ( * );
         server_entry: ^iot$robotic_server_entry;
     VAR validated_list: array [1 .. * ] of cmt$element_name;
     VAR status: ost$status);

    VAR
      i: 0 .. ioc$max_unit_number,
      j: 0 .. ioc$max_unit_number,
      name_is_valid: boolean,
      validated_name: ost$name;

    status.normal := TRUE;

    IF (UPPERBOUND (element_list) - LOWERBOUND (element_list) + 1) > ioc$max_unit_number THEN
      osp$set_status_abnormal (rmc$resource_management_id, rme$too_many_elements, procedure_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, field, status);
      osp$append_status_integer (osc$status_parameter_delimiter, ioc$max_unit_number, 16, TRUE, status);
    ELSE
      FOR i := LOWERBOUND (element_list) TO UPPERBOUND (element_list) DO
        validate_element_name (element_list [i], field, server_entry, validated_list [i], status);
        IF status.normal THEN
          { Validate that there are no duplicate elements in the array.}
          FOR j := i + 1 TO UPPERBOUND (element_list) DO
            IF element_list [i] = element_list [j] THEN
              osp$set_status_abnormal (rmc$resource_management_id, rme$duplicate_element_name, procedure_name,
                    status);
              osp$append_status_parameter (osc$status_parameter_delimiter, element_list [i], status);
              osp$append_status_parameter (osc$status_parameter_delimiter, field, status);
              RETURN;
            IFEND;
          FOREND;
        ELSE
          osp$set_status_abnormal (rmc$resource_management_id, rme$invalid_element_name, procedure_name,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, element_list [i], status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;

  PROCEND validate_element_list;
?? OLDTITLE ??
?? NEWTITLE := 'validate_element_name', EJECT ??

  PROCEDURE validate_element_name
    (    element_name: cmt$element_name;
         field: string ( * );
         server_entry: ^iot$robotic_server_entry;
     VAR validated_element_name: cmt$element_name;
     VAR status: ost$status);

    VAR
      i: integer,
      name_is_valid: boolean;

    status.normal := TRUE;

    clp$validate_name (element_name, validated_element_name, name_is_valid);
    IF name_is_valid THEN
      IF (server_entry <> NIL) AND (server_entry^.managed_elements_p <> NIL) THEN
        FOR i := LOWERBOUND (server_entry^.managed_elements_p^)
              TO UPPERBOUND (server_entry^.managed_elements_p^) DO
          IF server_entry^.managed_elements_p^ [i] = validated_element_name THEN
            RETURN;
          IFEND
        FOREND;
        report_invalid_response_field (field, status);
      IFEND;
    ELSE
      report_invalid_response_field (field, status);
    IFEND;

  PROCEND validate_element_name;
?? OLDTITLE ??
?? NEWTITLE := 'validate_external_vsn', EJECT ??

  PROCEDURE validate_external_vsn
    (    external_vsn: rmt$external_vsn;
         field: string ( * );
     VAR validated_external_vsn: rmt$external_vsn;
     VAR status: ost$status);

    IF STRLENGTH (external_vsn) = rmc$external_vsn_size THEN
      rmp$validate_ansi_string (external_vsn, validated_external_vsn, status);
      IF NOT status.normal THEN
        report_invalid_response_field (field, status);
      IFEND;
    ELSE
      report_invalid_response_field (field, status);
    IFEND;

  PROCEND validate_external_vsn;
?? OLDTITLE ??
?? NEWTITLE := 'validate_pva', EJECT ??

  PROCEDURE validate_pva
    (    pva: ^cell;
         field: string ( * );
     VAR status: ost$status);

    IF (NOT mmp$verify_access (^pva, mmc$va_read)) THEN
      report_invalid_response_field (field, status);
    IFEND;

  PROCEND validate_pva;
?? OLDTITLE ??

?? NEWTITLE := 'validate_request_id', EJECT ??

  PROCEDURE validate_request_id
    (    request_id: rmt$rbt_request_id;
         field: string ( * );
     VAR validated_request_id: rmt$rbt_request_id;
     VAR status: ost$status);

    IF (request_id < LOWERVALUE (rmt$rbt_request_id)) OR {}
          (request_id > UPPERVALUE (rmt$rbt_request_id)) THEN
      report_invalid_response_field (field, status);
    ELSE
      status.normal := TRUE;
      validated_request_id := request_id;
    IFEND;
  PROCEND validate_request_id;
?? OLDTITLE ??
?? NEWTITLE := 'validate_request_type', EJECT ??

  PROCEDURE validate_request_type
    (    request_type: rmt$rbt_request_type;
         field: string ( * );
     VAR validated_request_type: rmt$rbt_request_type;
     VAR status: ost$status);

    IF (request_type < LOWERVALUE (rmt$rbt_request_type)) OR
          (request_type > UPPERVALUE (rmt$rbt_request_type)) THEN
      report_invalid_response_field (field, status);
    ELSE
      status.normal := TRUE;
      validated_request_type := request_type;
    IFEND;
  PROCEND validate_request_type;
?? OLDTITLE ??
?? NEWTITLE := 'validate_response_dismount', EJECT ??

  PROCEDURE validate_response_dismount
    (    dismount_response: rmt$rbt_dismount_response;
         server_entry: iot$robotic_server_entry;
     VAR validated_response: rmt$rbt_dismount_response;
     VAR status: ost$status);

    validate_element_name (dismount_response.element, 'DISMOUNT.ELEMENT', ^server_entry,
          validated_response.element, status);
    IF status.normal THEN
      validate_external_vsn (dismount_response.external_vsn, 'DISMOUNT.EXTERNAL_VSN',
            validated_response.external_vsn, status);
      IF status.normal THEN
        validated_response := dismount_response;
      IFEND;
    IFEND;

  PROCEND validate_response_dismount;
?? OLDTITLE ??
?? NEWTITLE := 'validate_response_force_dismnt', EJECT ??

  PROCEDURE validate_response_force_dismnt
    (    force_dismount_response: rmt$rbt_force_dismount_response;
         server_entry: iot$robotic_server_entry;
     VAR validated_response: rmt$rbt_force_dismount_response;
     VAR status: ost$status);

    validate_element_name (force_dismount_response.element, 'FORCE_DISMOUNT.ELEMENT', ^server_entry,
          validated_response.element, status);

  PROCEND validate_response_force_dismnt;

?? OLDTITLE ??
?? NEWTITLE := 'validate_response_mount', EJECT ??

  PROCEDURE validate_response_mount
    (    mount_response: rmt$rbt_mount_response;
         server_entry: iot$robotic_server_entry;
     VAR validated_response: rmt$rbt_mount_response;
     VAR status: ost$status);

    validate_element_name (mount_response.element, 'MOUNT.ELEMENT', ^server_entry, validated_response.element,
          status);
    IF status.normal THEN
      validate_external_vsn (mount_response.external_vsn, 'MOUNT.EXTERNAL_VSN',
            validated_response.external_vsn, status);
    IFEND;

  PROCEND validate_response_mount;
?? OLDTITLE ??
?? NEWTITLE := 'validate_response_query', EJECT ??

  PROCEDURE validate_response_query
    (    query_response: rmt$rbt_query_response;
     VAR validated_response: rmt$rbt_query_response;
     VAR status: ost$status);

    validate_external_vsn (query_response.external_vsn, 'QUERY.EXTERNAL_VSN', validated_response.external_vsn,
          status);
    IF status.normal THEN
      validate_boolean (query_response.volume_located, 'QUERY.VOLUME_LOCATED',
            validated_response.volume_located, status);
      IF status.normal AND query_response.volume_located THEN
        validate_boolean (query_response.already_mounted, 'QUERY.ALREADY_MOUNTED',
              validated_response.already_mounted, status);
        IF status.normal AND (NOT query_response.already_mounted) THEN
          IF query_response.preferred_candidates <> NIL THEN
            validate_pva (query_response.preferred_candidates, 'QUERY.PREFERRED_CANDIDATES - invalid PVA',
                status);
          IFEND;
          IF status.normal AND (query_response.remaining_candidates <> NIL) THEN
            validate_pva (query_response.remaining_candidates, 'QUERY.REMAINING_CANDIDATES - invalid PVA',
                status);
          IFEND;
          IF status.normal AND (query_response.preferred_candidates = NIL) AND
              (query_response.remaining_candidates = NIL) THEN
            osp$set_status_condition (rme$no_candidate_elements, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND validate_response_query;

?? OLDTITLE ??
?? NEWTITLE := 'validate_server_attributes', EJECT ??

  PROCEDURE validate_server_attributes
    (    server_attributes: array [1 .. * ] of rmt$rbt_server_attribute;
         procedure_name: string ( * );
     VAR validated_attributes: iot$robotic_server_attributes;
     VAR status: ost$status);

    CONST
      maximum_timeout = 60 {minutes} * 60 {seconds} * 1000 {milliseconds} ;

    VAR
      i: integer,
      local_attributes: iot$robotic_server_attributes;

    status.normal := TRUE;

    local_attributes := rmv$default_server_attributes;

  /loop/
    FOR i := LOWERBOUND (server_attributes) TO UPPERBOUND (server_attributes) DO
      CASE server_attributes [i].selector OF
      = rmc$rbt_null_attribute =
        ;
      = rmc$rbt_server_timeout =
        IF (server_attributes [i].server_timeout < 0) OR
              (server_attributes [i].server_timeout > maximum_timeout) THEN
          osp$set_status_abnormal (rmc$resource_management_id,
                rme$invalid_server_timeout, procedure_name, status);
          osp$append_status_integer (osc$status_parameter_delimiter,
                maximum_timeout, 10, FALSE {include radix} , status);
          EXIT /loop/;
        ELSE
          local_attributes.timeout := server_attributes [i].server_timeout;
        IFEND;
      = rmc$rbt_supported_requests =
        IF NOT (server_attributes [i].supported_requests <= valid_requests) THEN
          osp$set_status_abnormal (rmc$resource_management_id,
                rme$invalid_supported_requests, procedure_name, status);
          EXIT /loop/;
        ELSE
          local_attributes.supported_requests :=
                server_attributes [i].supported_requests;
        IFEND;
      ELSE
        osp$set_status_abnormal (rmc$resource_management_id,
              rme$invalid_server_attribute, procedure_name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, i, 10, FALSE
              {include radix} , status);
        EXIT /loop/;
      CASEND;
    FOREND /loop/;
    IF status.normal THEN
      validated_attributes := local_attributes;
    IFEND;

  PROCEND validate_server_attributes;

?? OLDTITLE ??
?? NEWTITLE := 'validate_server_name', EJECT ??

  PROCEDURE validate_server_name
    (    server_name: ost$name;
         procedure_name: string ( * );
         validate_server_defined: boolean;
     VAR server_entry: iot$robotic_server_entry;
     VAR validated_server_name: ost$name;
     VAR status: ost$status);

    VAR
      debug_message_logged: boolean,
      i: integer,
      name_is_valid: boolean;

    status.normal := TRUE;

    clp$validate_name (server_name, validated_server_name, name_is_valid);
    IF name_is_valid THEN

    /locate_server/
      FOR i := LOWERVALUE (iot$robotic_server_index) TO UPPERVALUE (iot$robotic_server_index) DO
        debug_message_logged := FALSE;
        REPEAT
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Calling iop$get_server_entry');
          IFEND;
          iop$get_server_entry (i, server_entry, status);
          IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
            IF NOT debug_message_logged THEN
              rmp$log_debug_message (' Waiting for tape table lock');
              debug_message_logged := TRUE;
            IFEND;
            pmp$wait (one_second, one_second);
          IFEND;
        UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);
        IF status.normal THEN
          IF server_entry.server_name = validated_server_name THEN
            IF validate_server_defined THEN
              RETURN;
            ELSE
              osp$set_status_abnormal (rmc$resource_management_id, rme$duplicate_server, procedure_name,
                    status);
              osp$append_status_parameter (osc$status_parameter_delimiter, server_name, status);
            IFEND;
          IFEND;
        ELSEIF status.condition = rme$invalid_server_index THEN
          EXIT /locate_server/;
        IFEND;
      FOREND /locate_server/;

      IF validate_server_defined THEN
        osp$set_status_abnormal (rmc$resource_management_id, rme$server_not_defined, procedure_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, server_name, status);
      ELSE
        status.normal := TRUE;
      IFEND;
    ELSE
      osp$set_status_abnormal (rmc$resource_management_id, rme$invalid_server_name, procedure_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, server_name, status);
    IFEND;

  PROCEND validate_server_name;
?? OLDTITLE ??
MODEND rmm$robotic_interfaces_23d;
*DECK DECK=RMM$ROBOTIC_INTERFACES_2DD EXPAND=TRUE
?? NEWTITLE := 'NOS/VE Media library interfaces' ??
*copyc osd$default_pragmats
MODULE rmm$robotic_interfaces_2dd;

{ Purpose: The packaging of this module allows waiting in the end user ring
{          for the eventual appearance of a robotic request.

?? NEWTITLE := '    Global Declarations Referenced by this Module', EJECT ??

*copyc ost$name
*copyc ost$status
*copyc rme$robotic_interface_errors
*copyc rmt$rbt_request
?? OLDTITLE ??
?? NEWTITLE := '    Global Procedures Referenced by this Module', EJECT ??
*copyc pmp$long_term_wait
*copyc rmp$log_debug_message
*copyc rmp$server_get_request_23d
?? OLDTITLE ??
?? NEWTITLE := '    RMP$SERVER_GET_REQUEST', EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$server_get_request
    (    server_name: ost$name;
         wait: boolean;
     VAR client_request: rmt$rbt_request;
     VAR status: ost$status);

    status.normal := TRUE;

  /request_loop/
    WHILE TRUE DO
      rmp$server_get_request_23d (server_name, wait, client_request,
            status);
      IF status.normal THEN
        EXIT /request_loop/;
      ELSEIF (status.condition = rme$no_requests_available) AND wait THEN
        rmp$log_debug_message (' Entering wait in rmp$server_get_request');
        pmp$long_term_wait (0ffffffffffff(16), 0ffffffffffff(16));
        rmp$log_debug_message (' Exiting wait in rmp$server_get_request');
      ELSE
        EXIT /request_loop/;
      IFEND;
    WHILEND /request_loop/;

  PROCEND rmp$server_get_request;
?? OLDTITLE ??
MODEND rmm$robotic_interfaces_2dd;

*DECK DECK=RMM$TABLES EXPAND=TRUE
?? RIGHT := 110 ??
MODULE rmm$tables;
?? TITLE := 'NOS/VE :  Resource Management : Define Global Tables' ??
{}
{   This module contains static variables for resource management routines.}
{}
?? PUSH (LISTEXT := ON) ??
*copyc iot$requested_volume_attributes
*copyc oss$job_paged_literal
*copyc rmt$density
*copyc rmt$write_ring
?? POP ??
?? FMT (FORMAT := OFF) ??
?? NEWTITLE := 'rmv$densities', EJECT ??
    VAR
      rmv$densities: [XDCL, READ, oss$job_paged_literal] array [rmt$density] of
            string (10) :=[
                            {rmc$200}   'MT7$200   ',
                            {rmc$556}   'MT7$556   ',
                            {rmc$800}   'MT9$800   ',
                            {rmc$1600}  'MT9$1600  ',
                            {rmc$6250}  'MT9$6250  ',
                            {rmc$38000} 'MT18$38000',
                            {reserved 1}'          ',
                            {reserved 2}'          ',
                            {reserved 3}'          ',
                            {reserved 4}'          ',
                            {reserved 5}'          ',
                            {reserved 6}'          ',
                            {reserved 7}'          ',
                            {reserved 8}'          '];
?? OLDTITLE ??
?? NEWTITLE := 'rmv$requested_volume_attributes', EJECT ??
   VAR
     rmv$requested_volume_attributes: [XDCL, READ, oss$job_paged_literal] iot$requested_volume_attributes
                     := [
                         {account} osc$null_name,
                         {family} osc$null_name,
                         {project} osc$null_name,
                         {removable_media_group} osc$null_name,
                         {removable_media_location} osc$null_name,
                         {slot} osc$null_name,
                         {user} osc$null_name];
?? OLDTITLE ??
?? FMT (FORMAT := ON) ??
?? NEWTITLE := 'rmv$write_ring', EJECT ??
   VAR
     rmv$write_ring: [XDCL, READ, oss$job_paged_literal] array [rmt$write_ring] OF
          string (5) := [
                        {rmc$write_ring}    'TRUE ',
                        {rmc$no_write_ring} 'FALSE'];
?? OLDTITLE ??
?? FMT (FORMAT := ON) ??

MODEND rmm$tables;
*DECK DECK=RMM$TAPE_SERVICES_223 EXPAND=TRUE
?? RIGHT := 110 ??
MODULE rmm$tape_services_223;

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    one_second = 1000 {milliseconds};

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dme$tape_errors
*copyc dmt$tape_assignment_operation
*copyc fst$path_handle_name
*copyc gft$system_file_identifier
*copyc iot$robotic_server_entry
*copyc ost$name
*copyc ost$status
*copyc rme$condition_codes
?? POP ??
*copyc dmv$tape_job_lun_table_p
*copyc ifp$invoke_pause_utility
*copyc iop$extend_volume_list_in_rvl
*copyc osp$begin_subsystem_activity
*copyc osp$clear_job_signature_lock
*copyc osp$disestablish_cond_handler
*copyc osp$end_subsystem_activity
*copyc osp$establish_condition_handler
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc osp$test_signature_lock
*copyc pmp$continue_to_cause
*copyc pmp$long_term_wait
*copyc osv$job_pageable_heap
*copyc osv$lower_to_upper
*copyc rmp$log_debug_message
*copyc rmv$job_tape_table_lock
*copyc rmv$job_tape_table_p
?? OLDTITLE ??
?? NEWTITLE := 'dmp$convert_sfid_to_lun', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$convert_sfid_to_lun
    (    sfid: gft$system_file_identifier;
     VAR lun: iot$logical_unit;
     VAR status: ost$status);

*copy rmi$block_exit_handler
?? EJECT ??

    VAR
      local_status: ost$status,
      lock_status: ost$signature_lock_status;

    status.normal := TRUE;
    lun := 0;

    osp$test_signature_lock (rmv$job_tape_table_lock, lock_status,
          local_status);
    IF local_status.normal AND (lock_status = osc$sls_not_locked)
            THEN
      osp$establish_condition_handler (^rmp$block_exit_handler, {handle block exit} TRUE);
      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (rmv$job_tape_table_lock);
    IFEND;
    IF (dmv$tape_job_lun_table_p <> NIL) AND dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].
          slot_in_use THEN
      IF NOT dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].job_recovery_active THEN
        IF dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].lun <> 0 THEN
          lun := dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].lun;
        ELSE
          osp$set_status_abnormal (rmc$resource_management_id, dme$no_volume_mounted, '', status);
        IFEND;
      ELSE
        osp$set_status_abnormal (rmc$resource_management_id, dme$tape_file_needs_job_rec, '', status);
      IFEND;
    ELSE
      osp$set_status_abnormal (rmc$resource_management_id, dme$tape_not_assigned,
            'determine logical unit number', status);
    IFEND;

    IF local_status.normal AND (lock_status = osc$sls_not_locked)
            THEN
      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND dmp$convert_sfid_to_lun;
?? OLDTITLE ??
?? NEWTITLE := 'dmp$get_tape_volume_information', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$get_tape_volume_information
    (    sfid: gft$system_file_identifier;
     VAR number_of_volumes: amt$volume_number;
     VAR current_volume_number: amt$volume_number;
     VAR current_vsns: rmt$volume_descriptor;
     VAR density: rmt$density;
     VAR write_ring: rmt$write_ring;
     VAR requested_volume_attributes: iot$requested_volume_attributes;
     VAR volume_overflow_allowed: boolean;
     VAR label_type: amt$label_type;
     VAR status: ost$status);

*copy rmi$block_exit_handler
?? EJECT ??

    VAR
      local_status: ost$status,
      lock_status: ost$signature_lock_status,
      lun_table_entry: ^dmt$tape_lun_table_entry;

    status.normal := TRUE;
    osp$test_signature_lock (rmv$job_tape_table_lock, lock_status,
          local_status);
    IF local_status.normal AND (lock_status = osc$sls_not_locked)
            THEN
      osp$establish_condition_handler (^rmp$block_exit_handler, {handle block exit} TRUE);
      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (rmv$job_tape_table_lock);
    IFEND;

    IF (dmv$tape_job_lun_table_p <> NIL) AND (dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].
          slot_in_use) THEN
      lun_table_entry := ^dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index];
      number_of_volumes := lun_table_entry^.number_of_vsns;
      current_volume_number := lun_table_entry^.current_vsn_index;
      current_vsns := lun_table_entry^.volume_list^ [lun_table_entry^.current_vsn_index];
      density := lun_table_entry^.density;
      write_ring := lun_table_entry^.write_ring;
      volume_overflow_allowed := lun_table_entry^.volume_overflow_allowed;
      requested_volume_attributes := lun_table_entry^.requested_volume_attributes;
      label_type := lun_table_entry^.label_type;
    ELSE
      osp$set_status_abnormal (rmc$resource_management_id, dme$tape_not_assigned, 'obtain tape volume list',
            status);
    IFEND;

    IF local_status.normal AND (lock_status = osc$sls_not_locked)
            THEN
      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND dmp$get_tape_volume_information;
?? OLDTITLE ??
?? NEWTITLE := 'dmp$get_tape_volume_list', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$get_tape_volume_list
    (    sfid: gft$system_file_identifier;
         volume_list: ^rmt$volume_list;
     VAR status: ost$status);

*copy rmi$block_exit_handler
?? EJECT ??

    VAR
      i: amt$volume_number,
      local_status: ost$status,
      lock_status: ost$signature_lock_status;

    status.normal := TRUE;
    osp$test_signature_lock (rmv$job_tape_table_lock, lock_status,
          local_status);
    IF local_status.normal AND (lock_status = osc$sls_not_locked)
            THEN
      osp$establish_condition_handler (^rmp$block_exit_handler, {handle block exit} TRUE);
      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (rmv$job_tape_table_lock);
    IFEND;

    IF (dmv$tape_job_lun_table_p <> NIL) AND (dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].
          slot_in_use) THEN
      IF volume_list <> NIL THEN
        FOR i := 1 TO UPPERBOUND (volume_list^) DO
          volume_list^ [i] := dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].volume_list^ [i];
        FOREND;
      IFEND;
    ELSE
      osp$set_status_abnormal (rmc$resource_management_id, dme$tape_not_assigned,
            'obtain tape volume information', status);
    IFEND;

    IF local_status.normal AND (lock_status = osc$sls_not_locked)
            THEN
      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND dmp$get_tape_volume_list;
?? OLDTITLE ??
?? NEWTITLE := 'dmp$replace_tape_vsn_list', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$replace_tape_vsn_list
    (    sfid: gft$system_file_identifier;
         p_volume_list: {input} ^rmt$volume_list;
         volume_overflow_allowed: boolean;
     VAR status: ost$status);

*copy rmi$block_exit_handler
?? EJECT ??
    VAR
      local_status: ost$status,
      lock_status: ost$signature_lock_status;

    status.normal := TRUE;
    osp$test_signature_lock (rmv$job_tape_table_lock, lock_status,
          local_status);
    IF local_status.normal AND (lock_status = osc$sls_not_locked)
            THEN
      osp$establish_condition_handler (^rmp$block_exit_handler, {handle block exit} TRUE);
      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (rmv$job_tape_table_lock);
    IFEND;

    dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].volume_overflow_allowed :=
          volume_overflow_allowed;
    IF p_volume_list <> NIL THEN
      dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].current_vsn_index := 1;
      dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].
            number_of_vsns := UPPERBOUND (p_volume_list^);
      FREE dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].volume_list IN osv$job_pageable_heap^;
      ALLOCATE dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].volume_list:
            [1 .. UPPERBOUND (p_volume_list^)] IN osv$job_pageable_heap^;
      dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index].volume_list^ := p_volume_list^;
    IFEND;

    IF local_status.normal AND (lock_status = osc$sls_not_locked)
            THEN
      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND dmp$replace_tape_vsn_list;

?? OLDTITLE ??
?? NEWTITLE := 'dmp$update_tape_vsn_list', EJECT ??

  PROCEDURE [XDCL, #GATE] dmp$update_tape_vsn_list
    (    sfid: gft$system_file_identifier;
         file: fst$path_handle_name;
         volume_descriptor: rmt$volume_descriptor;
         requested_volume_attributes: iot$requested_volume_attributes;
         source_pool: ost$name;
         source_pool_location: ost$name;
         tape_assignment_operation: dmt$tape_assignment_operation;
     VAR status: ost$status);

*copy rmi$block_exit_handler

?? NEWTITLE := '  update_tape_vsn_list_handler  ', EJECT ??

    PROCEDURE update_tape_vsn_list_handler
      (    condition: pmt$condition;
           p_condition_info: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        local_status: ost$status,
        lock_status: ost$signature_lock_status,
        ignore_status: ost$status;

      CASE condition.selector OF
      = pmc$block_exit_processing =
        osp$test_signature_lock (rmv$job_tape_table_lock, lock_status,
              local_status);
        IF local_status.normal AND (lock_status = osc$sls_locked_by_current_task) THEN
          osp$end_subsystem_activity;
          osp$clear_job_signature_lock (rmv$job_tape_table_lock);
        IFEND;
      = ifc$interactive_condition =
        CASE condition.interactive_condition OF
        = ifc$pause_break, ifc$job_reconnect =
          ifp$invoke_pause_utility (ignore_status);
        = ifc$terminate_break =
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
          osp$set_status_from_condition (rmc$resource_management_id, condition, save_area, status,
                ignore_status);
          EXIT dmp$update_tape_vsn_list;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        CASEND;
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
      CASEND;

    PROCEND update_tape_vsn_list_handler;

?? OLDTITLE ??
    VAR
      debug_message_logged: boolean,
      lun_table_entry: ^dmt$tape_lun_table_entry,
      local_status: ost$status,
      lock_status: ost$signature_lock_status,
      vol_descriptor: rmt$volume_descriptor;

    status.normal := TRUE;
    osp$test_signature_lock (rmv$job_tape_table_lock, lock_status,
          local_status);
    IF local_status.normal AND (lock_status = osc$sls_not_locked)
            THEN
      osp$establish_condition_handler (^update_tape_vsn_list_handler, {handle block exit} TRUE);
      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (rmv$job_tape_table_lock);
    IFEND;

    lun_table_entry := ^dmv$tape_job_lun_table_p^.tape_file^ [sfid.file_entry_index];
    #TRANSLATE (osv$lower_to_upper, volume_descriptor.external_vsn, vol_descriptor.external_vsn);
    #TRANSLATE (osv$lower_to_upper, volume_descriptor.recorded_vsn, vol_descriptor.recorded_vsn);

    CASE tape_assignment_operation OF
    = dmc$advance_to_next_tape_volume =
      lun_table_entry^.volume_list^ [lun_table_entry^.current_vsn_index + 1].recorded_vsn :=
            vol_descriptor.recorded_vsn;
      lun_table_entry^.volume_list^ [lun_table_entry^.current_vsn_index + 1].external_vsn :=
            vol_descriptor.external_vsn;
      lun_table_entry^.requested_volume_attributes := requested_volume_attributes;
      lun_table_entry^.source_pool := source_pool;
      lun_table_entry^.source_pool_location := source_pool_location;

      debug_message_logged := FALSE;
      REPEAT
        IF NOT debug_message_logged THEN
          rmp$log_debug_message (' Calling iop$extend_volume_list_in_rvl');
        IFEND;
        iop$extend_volume_list_in_rvl (sfid, vol_descriptor.external_vsn, vol_descriptor.recorded_vsn,
              requested_volume_attributes, lun_table_entry^.current_vsn_index + 1, status);
        IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Waiting for tape table lock');
            debug_message_logged := TRUE;
          IFEND;
          osp$clear_job_signature_lock (rmv$job_tape_table_lock);
          osp$end_subsystem_activity;
          pmp$long_term_wait (one_second, one_second);
          osp$begin_subsystem_activity;
          osp$set_job_signature_lock (rmv$job_tape_table_lock);
        IFEND;
      UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);

    = dmc$assign_initial_tape_volume =
      lun_table_entry^.current_vsn_index := 1;
      lun_table_entry^.volume_list^ [1].recorded_vsn := vol_descriptor.recorded_vsn;
      lun_table_entry^.volume_list^ [1].external_vsn := vol_descriptor.external_vsn;
      lun_table_entry^.requested_volume_attributes := requested_volume_attributes;

      debug_message_logged := FALSE;
      REPEAT
        IF NOT debug_message_logged THEN
          rmp$log_debug_message (' Calling iop$extend_volume_list_in_rvl');
        IFEND;
        iop$extend_volume_list_in_rvl (sfid, vol_descriptor.external_vsn, vol_descriptor.recorded_vsn,
              requested_volume_attributes, 1, status);
        IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Waiting for tape table lock');
            debug_message_logged := TRUE;
          IFEND;
          osp$clear_job_signature_lock (rmv$job_tape_table_lock);
          osp$end_subsystem_activity;
          pmp$long_term_wait (one_second, one_second);
          osp$begin_subsystem_activity;
          osp$set_job_signature_lock (rmv$job_tape_table_lock);
        IFEND;
      UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);

    = dmc$reset_tape_volume_list =
      lun_table_entry^.volume_list^ [1].recorded_vsn := vol_descriptor.recorded_vsn;
      lun_table_entry^.volume_list^ [1].external_vsn := vol_descriptor.external_vsn;
      lun_table_entry^.requested_volume_attributes := requested_volume_attributes;

      debug_message_logged := FALSE;
      REPEAT
        IF NOT debug_message_logged THEN
          rmp$log_debug_message (' Calling iop$extend_volume_list_in_rvl');
        IFEND;
        iop$extend_volume_list_in_rvl (sfid, vol_descriptor.external_vsn, vol_descriptor.recorded_vsn,
              requested_volume_attributes, 1, status);
        IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Waiting for tape table lock');
            debug_message_logged := TRUE;
          IFEND;
          osp$clear_job_signature_lock (rmv$job_tape_table_lock);
          osp$end_subsystem_activity;
          pmp$long_term_wait (one_second, one_second);
          osp$begin_subsystem_activity;
          osp$set_job_signature_lock (rmv$job_tape_table_lock);
        IFEND;
      UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);

    = dmc$extend_tape_volume_list =
      rmp$extend_volume_list (lun_table_entry, status);
      lun_table_entry^.volume_list^ [lun_table_entry^.current_vsn_index + 1].recorded_vsn :=
            vol_descriptor.recorded_vsn;
      lun_table_entry^.volume_list^ [lun_table_entry^.current_vsn_index + 1].external_vsn :=
            vol_descriptor.external_vsn;
      lun_table_entry^.requested_volume_attributes := requested_volume_attributes;

      debug_message_logged := FALSE;
      REPEAT
        IF NOT debug_message_logged THEN
          rmp$log_debug_message (' Calling iop$extend_volume_list_in_rvl');
        IFEND;
        iop$extend_volume_list_in_rvl (sfid, vol_descriptor.external_vsn, vol_descriptor.recorded_vsn,
              requested_volume_attributes, lun_table_entry^.current_vsn_index + 1, status);
        IF NOT status.normal AND (status.condition = dme$unable_to_lock_tape_table) THEN
          IF NOT debug_message_logged THEN
            rmp$log_debug_message (' Waiting for tape table lock');
            debug_message_logged := TRUE;
          IFEND;
          osp$clear_job_signature_lock (rmv$job_tape_table_lock);
          osp$end_subsystem_activity;
          pmp$long_term_wait (one_second, one_second);
          osp$begin_subsystem_activity;
          osp$set_job_signature_lock (rmv$job_tape_table_lock);
        IFEND;
      UNTIL status.normal OR (status.condition <> dme$unable_to_lock_tape_table);

    ELSE
    CASEND;

    IF local_status.normal AND (lock_status = osc$sls_not_locked)
            THEN
      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND dmp$update_tape_vsn_list;
?? OLDTITLE ??
?? NEWTITLE := 'rmp$extend_volume_list', EJECT ??

  PROCEDURE [XDCL] rmp$extend_volume_list
    (    lun_table_entry: ^dmt$tape_lun_table_entry;
     VAR status: ost$status);

*copy rmi$block_exit_handler
?? EJECT ??
    VAR
      free_vsn_list: ^rmt$volume_list,
      local_status: ost$status,
      lock_status: ost$signature_lock_status,
      vsn_list_index: integer,
      new_vsn_list: ^rmt$volume_list;

    status.normal := TRUE;
    osp$test_signature_lock (rmv$job_tape_table_lock, lock_status,
          local_status);
    IF local_status.normal AND (lock_status = osc$sls_not_locked)
            THEN
      osp$establish_condition_handler (^rmp$block_exit_handler, {handle block exit} TRUE);
      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (rmv$job_tape_table_lock);
    IFEND;

    ALLOCATE new_vsn_list: [1 .. lun_table_entry^.number_of_vsns + 1] IN osv$job_pageable_heap^;
    FOR vsn_list_index := 1 TO lun_table_entry^.number_of_vsns DO
      new_vsn_list^ [vsn_list_index].external_vsn := lun_table_entry^.volume_list^ [vsn_list_index].
            external_vsn;
      new_vsn_list^ [vsn_list_index].recorded_vsn := lun_table_entry^.volume_list^ [vsn_list_index].
            recorded_vsn;
    FOREND;
    new_vsn_list^ [lun_table_entry^.number_of_vsns + 1].external_vsn := ' ';
    new_vsn_list^ [lun_table_entry^.number_of_vsns + 1].recorded_vsn := ' ';

    free_vsn_list := lun_table_entry^.volume_list;
    lun_table_entry^.volume_list := new_vsn_list;
    FREE free_vsn_list IN osv$job_pageable_heap^;

    lun_table_entry^.number_of_vsns := lun_table_entry^.number_of_vsns + 1;

    IF local_status.normal AND (lock_status = osc$sls_not_locked)
            THEN
      osp$clear_job_signature_lock (rmv$job_tape_table_lock);
      osp$end_subsystem_activity;
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND rmp$extend_volume_list;
?? OLDTITLE ??
MODEND rmm$tape_services_223;
*DECK DECK=RMM$TAPE_SERVICES_23D EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Resource Management : Mount a tape volume and assign element to the job' ??
MODULE rmm$tape_services_23d;

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dme$tape_errors
*copyc dmt$job_tape_table
*copyc ost$status
*copyc rmc$action_messages
*copyc rmc$job_status_messages
*copyc rmc$rbt_status_message_width
*copyc rme$condition_codes
*copyc rmt$density
*copyc rmt$tape_reservation
?? POP ??
*copyc ofp$display_status_message
*copyc ofp$format_operator_message
*copyc ofp$send_formatted_operator_msg
*copyc osp$copy_local_status_to_status
*copyc osp$get_parameter_prompt
*copyc osp$set_status_abnormal
*copyc oss$task_shared
*copyc pmp$long_term_wait
*copyc rmp$clear_explicit_reserve
PROCEDURE hide_xref_from_inline;
*copyc rmv$tape_debug_mode
PROCEND hide_xref_from_inline;
*copyc rmp$log_debug_message
*copyc rmp$set_explicit_reserve

?? TITLE := 'Global Declarations Declared by this Module', EJECT ??
  VAR
    rmv$tape_debug_mode: [XDCL, #GATE, STATIC, oss$task_shared] boolean := FALSE;

?? TITLE := 'rmp$change_tape_debug_mode_23d', EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$change_tape_debug_mode_23d
    (    tape_debug_mode: boolean);

    rmv$tape_debug_mode := tape_debug_mode;

  PROCEND rmp$change_tape_debug_mode_23d;

?? TITLE := 'rmp$emit_operator_message', EJECT ??

  PROCEDURE [XDCL] rmp$emit_operator_message
    (    message_name: clt$parameter_name;
         message_parameters: ^array [1 .. * ] of ^string
          ( * <= ofc$max_display_message);
         acknowledgement_allowed: boolean;
     VAR status: ost$status);

    VAR
      formatted_message: oft$formatted_operator_message,
      job_status_message: clt$parameter_name,
      line_count: oft$number_of_displayable_lines,
      local_status: ost$status,
      message: ost$status_message;

    osp$get_parameter_prompt (rmc$action_messages, message_name,
          message_parameters, rmc$rbt_status_message_width, message, local_status);

    IF local_status.normal THEN
      ofp$format_operator_message (message, 1, formatted_message, line_count);
      IF line_count >= 1 THEN
        ofp$send_formatted_operator_msg (formatted_message, ofc$removable_media_operator,
              acknowledgement_allowed, status);
        WHILE NOT local_status.normal AND (local_status.condition =
              ofe$max_job_operator_messages) DO
          pmp$long_term_wait (1000, 1000);
          ofp$send_formatted_operator_msg (formatted_message, ofc$removable_media_operator,
                acknowledgement_allowed, local_status);
        WHILEND;
        osp$copy_local_status_to_status (local_status, status);
        IF status.normal THEN
          job_status_message := 'WAIT_FOR_ACTION';
          rmp$put_job_status_display (job_status_message, NIL);
        IFEND;
      IFEND;
    IFEND;

  PROCEND rmp$emit_operator_message;
?? OLDTITLE ??
?? TITLE := 'rmp$put_job_status_display', EJECT ??

  PROCEDURE [XDCL] rmp$put_job_status_display
    (    message_name: clt$parameter_name;
         message_parameters: ^array [1 .. * ] of ^string ( * <= ofc$max_display_message));

    VAR
      line: ^ost$status_message_line,
      line_count: ^ost$status_message_line_count,
      line_size: ^ost$status_message_line_size,
      local_status: ost$status,
      message: ost$status_message,
      message_area: ^ost$status_message;

    osp$get_parameter_prompt (rmc$job_status_messages, message_name, message_parameters,
          ofc$max_display_message, message, local_status);

    IF local_status.normal THEN
      message_area := ^message;
      RESET message_area;
      NEXT line_count IN message_area;
      IF line_count^ >= 1 THEN
        NEXT line_size IN message_area;
        NEXT line: [line_size^] IN message_area;
        ofp$display_status_message (line^ (2, * ), local_status);
        rmp$log_debug_message (line^ (2, * ));
      IFEND;
    IFEND;

  PROCEND rmp$put_job_status_display;
?? OLDTITLE ??
?? NEWTITLE := 'rmp$release_resource_command', EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$release_resource_command
    (    reservation: rmt$tape_reservation;
     VAR status: ost$status);

    status.normal := TRUE;
    rmp$clear_explicit_reserve (reservation, status);

  PROCEND rmp$release_resource_command;
?? OLDTITLE ??
?? NEWTITLE := 'rmp$reserve_resource_command', EJECT ??

  PROCEDURE [XDCL, #GATE] rmp$reserve_resource_command
    (    reservation: rmt$tape_reservation;
     VAR status: ost$status);

    status.normal := TRUE;
    rmp$set_explicit_reserve (reservation, status);

  PROCEND rmp$reserve_resource_command;
?? OLDTITLE ??

MODEND rmm$tape_services_23d;
*DECK DECK=RMM$VALIDATE_ANSI_LABELS EXPAND=TRUE
*DECK DECK=RMM$VALIDATE_MASS_STORAGE_INFO EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Resource Management: Mass Storage Validation' ??
MODULE rmm$validate_mass_storage_info;

{ PURPOSE:
{     This module contains the procedures to perform mass storage request
{     validation.

?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc fmt$mass_storage_request_info
*copyc jmc$system_family
*copyc pfd$catalog
*copyc rme$request_mass_storage
*copyc rmt$mass_storage_class
?? POP ??
?? EJECT ??
*copyc avp$get_capability
*copyc avp$system_administrator
*copyc cmp$get_ms_class_on_volume
*copyc fsp$convert_fs_structure_to_pf
*copyc fsp$path_element
*copyc jmp$get_scheduling_admin_status
*copyc jmp$system_job
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$get_job_names
*copyc pmp$get_user_identification
*copyc stp$get_volumes_set_name


?? TITLE := '  [XDCL, #GATE] rmp$build_mass_storage_info', EJECT ??
*copy rmh$build_mass_storage_info

  PROCEDURE [XDCL, #GATE] rmp$build_mass_storage_info
    (    allocation_size: rmt$allocation_size;
         estimated_file_size: amt$file_byte_address;
         initial_volume: rmt$recorded_vsn;
         mass_storage_class: rmt$mass_storage_class;
         shared_queue: pft$shared_queue;
         transfer_size: fst$transfer_size;
         volume_overflow_allowed: boolean;
         ring_of_caller: ost$ring;
         p_mass_storage_request_info: {output} ^fmt$mass_storage_request_info;
     VAR status: ost$status);

    VAR
      engineering_operation: boolean,
      job_scheduling_admin_status: ost$status,
      local_status: ost$status,
      user_id: ost$user_identification,
      user_supplied_name: jmt$user_supplied_name,
      system_supplied_name: jmt$system_supplied_name;

    local_status.normal := TRUE;

    p_mass_storage_request_info^.allocation_size := allocation_size;
    p_mass_storage_request_info^.estimated_file_size := estimated_file_size;
    p_mass_storage_request_info^.initial_volume := initial_volume;
    p_mass_storage_request_info^.mass_storage_class := mass_storage_class;
    p_mass_storage_request_info^.shared_queue := shared_queue;
    p_mass_storage_request_info^.transfer_size := transfer_size;
    p_mass_storage_request_info^.volume_overflow_allowed := volume_overflow_allowed;

    pmp$get_user_identification (user_id, local_status);
    IF local_status.normal THEN
      jmp$get_scheduling_admin_status (job_scheduling_admin_status);
      IF avp$system_administrator () OR (ring_of_caller <= osc$tsrv_ring) OR
            job_scheduling_admin_status.normal THEN
        p_mass_storage_request_info^.user_privilege := rmc$system_user;
      ELSEIF ring_of_caller <= osc$sj_ring_3 THEN
        p_mass_storage_request_info^.user_privilege := rmc$privileged_user;
      ELSE
        p_mass_storage_request_info^.user_privilege := rmc$normal_user;
      IFEND;

      avp$get_capability (avc$engineering_operation, avc$user,
               engineering_operation, local_status);
      IF (NOT local_status.normal) THEN
        local_status.normal := TRUE;
        IF jmp$system_job () THEN
          engineering_operation := TRUE;
        IFEND;
      IFEND;
      p_mass_storage_request_info^.maintenance_job := engineering_operation;
    IFEND;

    IF NOT local_status.normal THEN
      status := local_status;
    IFEND;
  PROCEND rmp$build_mass_storage_info;

?? TITLE := '  [XDCL, #GATE] rmp$validate_mass_storage_info', EJECT ??
*copyc rmh$validate_mass_storage_info

  PROCEDURE [XDCL, #GATE] rmp$validate_mass_storage_info
    (    family_set_name: pft$name;
         object_permanent: boolean;
         object_type: pft$object_types;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
     VAR status: ost$status);

    VAR
      dm_valid_class: dmt$class,
      file_class_string: string (1),
      volume_set_name: stt$set_name;

    status.normal := TRUE;

    CASE object_type OF
    = pfc$file_object =
      IF object_permanent THEN
        IF p_mass_storage_request_info^.mass_storage_class <> rmc$unspecified_file_class THEN
          IF (p_mass_storage_request_info^.user_privilege = rmc$normal_user) AND
                (p_mass_storage_request_info^.mass_storage_class <> rmc$msc_user_permanent_files) THEN
            osp$set_status_condition (rme$job_not_valid, status);
            RETURN;
          ELSEIF (p_mass_storage_request_info^.user_privilege = rmc$privileged_user) AND
                ((p_mass_storage_request_info^.mass_storage_class = rmc$msc_system_swap_files) OR
                (p_mass_storage_request_info^.mass_storage_class = rmc$msc_system_catalogs) OR
                (p_mass_storage_request_info^.mass_storage_class = rmc$msc_system_permanent_files) OR
                (p_mass_storage_request_info^.mass_storage_class = rmc$msc_user_catalogs) OR
                (p_mass_storage_request_info^.mass_storage_class = rmc$msc_product_files) OR
                (p_mass_storage_request_info^.mass_storage_class = rmc$msc_system_critical_files)) THEN
            osp$set_status_condition (rme$job_not_valid, status);
            RETURN;
          IFEND;
        IFEND;

        IF p_mass_storage_request_info^.initial_volume <> rmc$unspecified_vsn THEN
          stp$get_volumes_set_name (p_mass_storage_request_info^.initial_volume, volume_set_name, status);
          IF NOT status.normal THEN
            osp$set_status_abnormal (rmc$resource_management_id, rme$vsn_not_part_of_set,
                  p_mass_storage_request_info^.initial_volume, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, family_set_name, status);
            RETURN;
          IFEND;

          IF family_set_name <> volume_set_name THEN
            osp$set_status_abnormal (rmc$resource_management_id, rme$vsn_not_part_of_set,
                  p_mass_storage_request_info^.initial_volume, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, family_set_name, status);
            RETURN;
          IFEND;

          get_volume_valid_classes (p_mass_storage_request_info^.initial_volume, dm_valid_class);

          IF (p_mass_storage_request_info^.user_privilege = rmc$normal_user) AND
                NOT (rmc$msc_user_permanent_files IN dm_valid_class) THEN
            osp$set_status_condition (rme$job_not_valid, status);
            RETURN;
          ELSEIF (p_mass_storage_request_info^.user_privilege = rmc$privileged_user) AND
                (dm_valid_class - $dmt$class [rmc$unspecified_file_class, rmc$msc_system_swap_files,
                rmc$msc_system_catalogs, rmc$msc_system_permanent_files, rmc$msc_user_catalogs,
                rmc$msc_product_files, rmc$msc_system_critical_files] = $dmt$class []) THEN
            osp$set_status_condition (rme$job_not_valid, status);
            RETURN;
          IFEND;

          IF (p_mass_storage_request_info^.mass_storage_class <> rmc$unspecified_file_class) AND
                NOT (p_mass_storage_request_info^.mass_storage_class IN dm_valid_class) THEN
            file_class_string := p_mass_storage_request_info^.mass_storage_class;
            osp$set_status_abnormal (rmc$resource_management_id, rme$file_class_not_valid,
                  p_mass_storage_request_info^.initial_volume, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, file_class_string, status);
            RETURN;
          IFEND;
        IFEND;

      ELSE { Temporary file
        IF p_mass_storage_request_info^.mass_storage_class <> rmc$unspecified_file_class THEN
          IF (p_mass_storage_request_info^.user_privilege = rmc$normal_user) AND
                (p_mass_storage_request_info^.mass_storage_class <> rmc$msc_user_temporary_files) THEN
            osp$set_status_condition (rme$job_not_valid, status);
            RETURN;
          ELSEIF (p_mass_storage_request_info^.user_privilege = rmc$privileged_user) AND
                ((p_mass_storage_request_info^.mass_storage_class = rmc$msc_system_swap_files) OR
                (p_mass_storage_request_info^.mass_storage_class = rmc$msc_system_catalogs) OR
                (p_mass_storage_request_info^.mass_storage_class = rmc$msc_system_permanent_files) OR
                (p_mass_storage_request_info^.mass_storage_class = rmc$msc_product_files) OR
                (p_mass_storage_request_info^.mass_storage_class = rmc$msc_user_catalogs) OR
                (p_mass_storage_request_info^.mass_storage_class = rmc$msc_system_critical_files)) THEN
            osp$set_status_condition (rme$job_not_valid, status);
            RETURN;
          IFEND;
        IFEND;

        IF p_mass_storage_request_info^.initial_volume <> rmc$unspecified_vsn THEN
          stp$get_volumes_set_name (p_mass_storage_request_info^.initial_volume, volume_set_name, status);
          IF NOT status.normal THEN
            osp$set_status_abnormal (rmc$resource_management_id, rme$unknown_volume,
                  p_mass_storage_request_info^.initial_volume, status);
            RETURN;
          IFEND;

          IF NOT p_mass_storage_request_info^.maintenance_job THEN
            get_volume_valid_classes (p_mass_storage_request_info^.initial_volume, dm_valid_class);

            IF (p_mass_storage_request_info^.user_privilege = rmc$normal_user) AND
                  NOT (rmc$msc_user_temporary_files IN dm_valid_class) THEN
              osp$set_status_condition (rme$job_not_valid, status);
              RETURN;
            ELSEIF (p_mass_storage_request_info^.user_privilege = rmc$privileged_user) AND
                  (dm_valid_class - $dmt$class [rmc$unspecified_file_class, rmc$msc_system_swap_files,
                  rmc$msc_system_catalogs, rmc$msc_system_permanent_files, rmc$msc_user_catalogs,
                  rmc$msc_product_files, rmc$msc_system_critical_files] = $dmt$class []) THEN
              osp$set_status_condition (rme$job_not_valid, status);
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

    = pfc$catalog_object =
      IF object_permanent THEN
        IF p_mass_storage_request_info^.mass_storage_class <> rmc$unspecified_file_class THEN
          IF (p_mass_storage_request_info^.user_privilege = rmc$normal_user) AND
                (p_mass_storage_request_info^.mass_storage_class <> rmc$msc_user_catalogs) THEN
            osp$set_status_condition (rme$job_not_valid, status);
            RETURN;
          ELSEIF (p_mass_storage_request_info^.user_privilege = rmc$privileged_user) AND
                ((p_mass_storage_request_info^.mass_storage_class = rmc$msc_system_swap_files) OR
                (p_mass_storage_request_info^.mass_storage_class = rmc$msc_system_catalogs) OR
                (p_mass_storage_request_info^.mass_storage_class = rmc$msc_system_permanent_files) OR
                (p_mass_storage_request_info^.mass_storage_class = rmc$msc_product_files) OR
                (p_mass_storage_request_info^.mass_storage_class = rmc$msc_user_permanent_files) OR
                (p_mass_storage_request_info^.mass_storage_class = rmc$msc_system_critical_files)) THEN
            osp$set_status_condition (rme$job_not_valid, status);
            RETURN;
          IFEND;
        IFEND;

        IF p_mass_storage_request_info^.initial_volume <> rmc$unspecified_vsn THEN
          stp$get_volumes_set_name (p_mass_storage_request_info^.initial_volume, volume_set_name, status);
          IF NOT status.normal THEN
            osp$set_status_abnormal (rmc$resource_management_id, rme$vsn_not_part_of_set,
                  p_mass_storage_request_info^.initial_volume, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, family_set_name, status);
            RETURN;
          IFEND;

          IF family_set_name <> volume_set_name THEN
            osp$set_status_abnormal (rmc$resource_management_id, rme$vsn_not_part_of_set,
                  p_mass_storage_request_info^.initial_volume, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, family_set_name, status);
            RETURN;
          IFEND;

          get_volume_valid_classes (p_mass_storage_request_info^.initial_volume, dm_valid_class);

          IF (p_mass_storage_request_info^.user_privilege = rmc$normal_user) AND
                NOT (rmc$msc_user_permanent_files IN dm_valid_class) THEN
            osp$set_status_condition (rme$job_not_valid, status);
            RETURN;
          ELSEIF (p_mass_storage_request_info^.user_privilege = rmc$privileged_user) AND
                (dm_valid_class - $dmt$class [rmc$unspecified_file_class, rmc$msc_system_swap_files,
                rmc$msc_system_catalogs, rmc$msc_system_permanent_files, rmc$msc_user_catalogs,
                rmc$msc_product_files, rmc$msc_system_critical_files] = $dmt$class []) THEN
            osp$set_status_condition (rme$job_not_valid, status);
            RETURN;
          IFEND;

          IF p_mass_storage_request_info^.mass_storage_class <> rmc$unspecified_file_class THEN
            IF NOT (p_mass_storage_request_info^.mass_storage_class IN dm_valid_class) THEN
              file_class_string := p_mass_storage_request_info^.mass_storage_class;
              osp$set_status_abnormal (rmc$resource_management_id, rme$file_class_not_valid,
                    p_mass_storage_request_info^.initial_volume, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, file_class_string, status);
              RETURN;
            IFEND;
          IFEND;
        IFEND;
      ELSE { Temporary catalog
      IFEND;
    ELSE
    CASEND;

    IF (NOT p_mass_storage_request_info^.volume_overflow_allowed) AND
          (object_type <> pfc$catalog_object) AND
          ((p_mass_storage_request_info^.user_privilege <> rmc$system_user) AND
          (NOT p_mass_storage_request_info^.maintenance_job)) THEN
      osp$set_status_abnormal (rmc$resource_management_id, rme$volume_overflow_required, '', status);
    IFEND;
  PROCEND rmp$validate_mass_storage_info;

?? TITLE := '  [INLINE] get_volume_valid_classes', EJECT ??

  PROCEDURE get_volume_valid_classes
    (    recorded_vsn: rmt$recorded_vsn;
     VAR valid_classes: dmt$class);

    VAR
      ms_class: cmt$ms_class_members,
      ms_class_info: cmt$ms_class_info,
      volume_found: boolean;

    valid_classes := $dmt$class [];

    cmp$get_ms_class_on_volume (recorded_vsn, volume_found, ms_class_info);
    IF NOT volume_found THEN
      RETURN;
    IFEND;

    FOR ms_class := LOWERBOUND (ms_class_info) TO UPPERBOUND (ms_class_info) DO
      IF ms_class_info [ms_class] THEN
        valid_classes := valid_classes + $dmt$class [ms_class];
      IFEND;
    FOREND;
  PROCEND get_volume_valid_classes;

MODEND rmm$validate_mass_storage_info;

*DECK DECK=RMM$VALIDATE_TAPE_OPERATIONS EXPAND=TRUE
*copyc osd$default_pragmats
MODULE rmm$validate_tape_operations;

{ PURPOSE:
{
{   This module contains CYBIL procedures to be optionally modified by sites
{ which desire to validate tape accesses beyond the NOS/VE defaults.
{
{ DESIGN:
{
{   Three CYBIL procedures are implemented in this module which facilitate
{ site-defined tape validation.  By default, the procedures simply complete
{ the tape request.  Site validation of tape assignments, tape requests, or
{ tape volume initialization can be implemented by adding whatever code is
{ required immediately before the call to RMP$COMPLETE_(whatever).

*copyc osp$set_status_abnormal
*copyc pmh$execute_with_less_privilege
*copyc rmc$condition_code_limits
*copyc rme$request_tape
*copyc rmp$complete_tape_assignment
*copyc rmp$complete_tape_request
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$file_label_type
*copyc fst$file_reference
*copyc osd$virtual_address
*copyc ost$name
*copyc pfd$permanent_file_attributes
*copyc rmt$density
*copyc rmt$volume_descriptor
*copyc rmt$write_ring
*copyc rmt$volume_list
*copyc ost$status
?? POP ??

?? TITLE := 'rmp$validate_tape_assignment', EJECT ??

  PROCEDURE [XDCL] rmp$validate_tape_assignment (
         validation_state: boolean;
         file_identifier: amt$file_identifier;
         file: fst$file_reference;
         density: rmt$density;
         write_ring: rmt$write_ring;
         file_label_type: amt$file_label_type;
         access_mode: pft$usage_selections;
         initial_assignment: boolean;
         next_volume: amt$volume_number;
         volume_descriptor: rmt$volume_descriptor;
         removable_media_group: ost$name;
         removable_media_location: ost$name;
     VAR status: ost$status);

*copyc rmh$validate_tape_assignment

    VAR
      operator_terminated_assignment: boolean;

    status.normal := TRUE;

*copyc rmh$complete_tape_assignment

    rmp$complete_tape_assignment (file_identifier, file, density, write_ring,
        file_label_type, access_mode, initial_assignment, next_volume,
        volume_descriptor, removable_media_group, removable_media_location, operator_terminated_assignment,
        status);

  PROCEND rmp$validate_tape_assignment;
?? TITLE := 'rmp$validate_tape_request', EJECT ??

  PROCEDURE [XDCL] rmp$validate_tape_request (
         tape_validation: boolean;
         file: fst$file_reference;
         density: rmt$density;
         write_ring: rmt$write_ring;
         volume_list: rmt$volume_list;
         removable_media_group: ost$name;
         volume_overflow_allowed: boolean;
         validation_ring: ost$valid_ring;
         file_password: pft$password;
         attachment_logging: boolean;
     VAR status: ost$status);

*copyc rmh$validate_tape_request

    status.normal := TRUE;

*copyc rmh$complete_tape_request

    rmp$complete_tape_request (file, density, write_ring, volume_list, removable_media_group,
          volume_overflow_allowed, validation_ring, file_password, attachment_logging, status);

  PROCEND rmp$validate_tape_request;

MODEND rmm$validate_tape_operations;
*DECK DECK=RMP$ACTIVATE_VOLUME EXPAND=FALSE
  PROCEDURE [XREF] rmp$activate_volume
    (    sfid: gft$system_file_identifier;
         acceptable_states: cmt$element_states;
         last_choice_element: cmt$element_name;
         required_element: cmt$element_name;
     VAR status: ost$status);

*copyc cmt$element_name
*copyc cmt$element_states
*copyc gft$system_file_identifier
*copyc ost$status
*DECK DECK=RMP$ASSIGN_TAPE_UNIT EXPAND=FALSE

  PROCEDURE [XREF] rmp$assign_tape_unit
    (    sfid: gft$system_file_identifier;
         element_name: cmt$element_name;
         acceptable_states: cmt$element_states;
         label_type: amt$label_type;
     VAR logical_unit: iot$logical_unit;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$label_type
*copyc cmt$element_name
*copyc cmt$element_states
*copyc gft$system_file_identifier
*copyc iot$logical_unit
*copyc ost$status
?? POP ??
*DECK DECK=RMP$BUILD_MASS_STORAGE_INFO EXPAND=FALSE

  PROCEDURE [XREF] rmp$build_mass_storage_info
    (    allocation_size: rmt$allocation_size;
         estimated_file_size: amt$file_byte_address;
         initial_volume: rmt$recorded_vsn;
         mass_storage_class: rmt$mass_storage_class;
         shared_queue: pft$shared_queue;
         transfer_size: fst$transfer_size;
         volume_overflow_allowed: boolean;
         ring_of_caller: ost$ring;
         p_mass_storage_request_info: {output} ^fmt$mass_storage_request_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc fmt$mass_storage_request_info
*copyc fst$transfer_size
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
*copyc pft$shared_queue
*copyc rmt$allocation_size
*copyc rmt$mass_storage_class
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=RMP$CHANGE_TAPE_DEBUG_MODE_23D EXPAND=FALSE

  PROCEDURE [XREF] rmp$change_tape_debug_mode_23d
    (    tape_debug_mode: boolean);
*DECK DECK=RMP$CLASSIFY_TAPE_VOLUME EXPAND=FALSE
  PROCEDURE [XREF] rmp$classify_tape_volume
    (    read_labels_status: ost$status;
         volume_header_labels: ^SEQ ( * );
     VAR volume_classification: rmt$tape_volume_classification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$tape_volume_classification
?? POP ??
*DECK DECK=RMP$CLEAR_EXPLICIT_RESERVE EXPAND=FALSE
  PROCEDURE [XREF] rmp$clear_explicit_reserve
    (    reservation: rmt$tape_reservation;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$tape_reservation
?? POP ??
*DECK DECK=RMP$CLEAR_IMPLICIT_RESERVE EXPAND=FALSE
  PROCEDURE [XREF] rmp$clear_implicit_reserve
    (    density: rmt$density;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$density
?? POP ??
*DECK DECK=RMP$COMPLETE_TAPE_ASSIGNMENT EXPAND=FALSE

  PROCEDURE [XREF] rmp$complete_tape_assignment (
    file_identifier: amt$file_identifier;
    file: fst$file_reference;
    density: rmt$density;
    write_ring: rmt$write_ring;
    file_label_type: amt$file_label_type;
    access_mode: pft$usage_selections;
    initial_assignment: boolean;
    next_volume: amt$volume_number;
    volume_descriptor: rmt$volume_descriptor;
    removable_media_group: ost$name;
    removable_media_location: ost$name;
    VAR operator_terminated_assignment: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_label_type
*copyc amt$file_identifier
*copyc amt$volume_number
*copyc fst$file_reference
*copyc ost$name
*copyc ost$status
*copyc pfd$permanent_file_attributes
*copyc rmt$density
*copyc rmt$volume_descriptor
*copyc rmt$write_ring
?? POP ??
*DECK DECK=RMP$COMPLETE_TAPE_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] rmp$complete_tape_request
    (    file: fst$file_reference;
         density: rmt$density;
         write_ring: rmt$write_ring;
         volume_list: rmt$volume_list;
         removable_media_group: ost$name;
         volume_overflow_allowed: boolean;
         validation_ring: ost$valid_ring;
         file_password: pft$password;
         attachment_logging: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$file_label_type
*copyc amt$volume_number
*copyc fst$file_reference
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc rmt$density
*copyc rmt$tape_class
*copyc rmt$volume_descriptor
*copyc rmt$volume_list
*copyc rmt$write_ring
?? POP ??
*DECK DECK=RMP$COMPLETE_TAPE_VOLUME_INIT EXPAND=FALSE

  PROCEDURE [XREF] rmp$complete_tape_volume_init (
    new_volume_init_info: rmt$tape_volume_init_info;
    VAR operator_allowed_init: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc rmt$tape_volume_init_info
*copyc ost$status
?? POP ??
*DECK DECK=RMP$CONVERT_DENSITY EXPAND=FALSE
*DECK DECK=RMP$CONVERT_KEYWORD_TO_CLASS EXPAND=FALSE

  PROCEDURE [XREF] rmp$convert_keyword_to_class
    (    keyword: ost$name;
     VAR file_class: rmt$mass_storage_class;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$name
*copyc rmt$mass_storage_class
?? POP ??
*DECK DECK=RMP$CREATE_APPLICATION_QUEUE EXPAND=FALSE
*DECK DECK=RMP$DEACTIVATE_VOLUME EXPAND=FALSE
  PROCEDURE [XREF] rmp$deactivate_volume
    (    sfid: gft$system_file_identifier;
         delete_request_from_vsn_queue: boolean;
     VAR status: ost$status);

*copyc gft$system_file_identifier
*copyc ost$status
*DECK DECK=RMP$DEFINE_ROBOTIC_SERVER EXPAND=FALSE

  PROCEDURE [XREF] rmp$define_robotic_server
    (    server_name: ost$name;
         managed_elements: array [1 .. * ] of cmt$element_name;
         server_attributes: array [1 .. * ] of rmt$rbt_server_attribute;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc ost$name
*copyc ost$status
*copyc rmt$rbt_server_attribute
*copyc rme$robotic_interface_errors
?? POP ??
*DECK DECK=RMP$DELETE_APPLICATION_QUEUE EXPAND=FALSE
*DECK DECK=RMP$DISVC_R3_HELPER EXPAND=FALSE

  PROCEDURE [XREF] rmp$disvc_r3_helper
    (    evaluated_file_reference: fst$evaluated_file_reference;
     VAR classification: rmt$tape_volume_classification;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc rmt$tape_volume_classification
*copyc ost$status
?? POP ??
*DECK DECK=RMP$EMIT_OPERATOR_MESSAGE EXPAND=FALSE
  PROCEDURE [XREF] rmp$emit_operator_message
    (    message_name: clt$parameter_name;
         message_parameters: ^array [1 .. * ] of ^string
          ( * <= ofc$max_display_message);
         acknowledgement_allowed: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_name
*copyc ofc$max_display_message
*copyc ost$status
?? POP ??
*DECK DECK=RMP$ENFORCE_TAPE_SECURITY EXPAND=FALSE
  PROCEDURE [XREF] rmp$enforce_tape_security
    (    file_identifier: amt$file_identifier;
         call_block: amt$call_block;
         layer_number: amt$fap_layer_number;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$call_block
*copyc amt$fap_layer_number
*copyc amt$file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=RMP$EXTEND_VOLUME_LIST EXPAND=FALSE
  PROCEDURE [XREF] rmp$extend_volume_list
    (    lun_table_entry: ^dmt$tape_lun_table_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$tape_job_lun_table
*copyc ost$status
?? POP ??
*DECK DECK=RMP$FORMAT_VOL_CLASSIFICATION EXPAND=FALSE
  PROCEDURE [XREF] rmp$format_vol_classification
    (    max_message_line: ost$max_status_message_line;
         volume_classification: rmt$tape_volume_classification;
     VAR formatted_classification: ost$status_message;
     VAR status: ost$status);

*copyc ost$max_status_message_line
*copyc ost$status
*copyc ost$status_message
*copyc rmt$tape_volume_classification
*DECK DECK=RMP$GET_DEVICE_CLASS EXPAND=FALSE

  PROCEDURE [XREF] rmp$get_device_class (file: fst$file_reference;
*IF NOT $true(osv$unix)
    VAR device_assigned: boolean;
*IFEND
    VAR device_class: rmt$device_class;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc fst$file_reference
*copyc RMT$DEVICE_CLASS
*copyc OST$STATUS
?? POP ??
*DECK DECK=RMP$GET_MEDIA_REQUEST EXPAND=FALSE
*DECK DECK=RMP$GET_MEDIA_REQUEST2 EXPAND=FALSE
*DECK DECK=RMP$GET_MEDIA_REQUEST_23D EXPAND=FALSE
*DECK DECK=RMP$GET_SELECTED_ELEMENT EXPAND=FALSE

  PROCEDURE [XREF] rmp$get_selected_element
    (    sfid: gft$system_file_identifier;
         external_vsn: rmt$external_vsn;
         recorded_vsn: rmt$recorded_vsn;
         density: rmt$density;
     VAR element_name: cmt$element_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc gft$system_file_identifier
*copyc rmt$density
*copyc rmt$external_vsn
*copyc rmt$recorded_vsn
*copyc ost$status
?? POP ??
*DECK DECK=RMP$INITIALIZE_TAPE_VOLUME EXPAND=TRUE
PROCEDURE initialize_tape_volume, initv (
  element, element_name, en, e: name = $optional
  recorded_vsn, rvsn, rv: any of
      string 1..6
      name 1..6
    anyend = $optional
  type, t: key
      mt9$800, mt9$1600, mt9$6250, mt18$38000
    keyend = $optional
  owner_identifier, oi: string 1..14 = $optional
  volume_accessibility_code, vac: string 1 = $optional
  file_accessibility_code, fac: string 1 = $optional
  character_set, cs: key
      (ascii, a)
      (ebcdic, e)
    keyend = ASCII
  label_standard_version, lsv: string 1 = '4'
  external_vsn, evsn, ev: (BY_NAME) any of
      string 1..6
      name 1..6
    anyend = $optional
  status)

  IF $specified(recorded_vsn) THEN
    IF $specified(external_vsn) THEN
      create_blank_labeled_volume element=element recorded_vsn=recorded_vsn character_set=character_set ..
        density=type external_vsn=external_vsn file_accessibility=file_accessibility_code ..
        label_standard_version=$integer(label_standard_version) owner_identifier=owner_identifier ..
        volume_accessibility=volume_accessibility_code status=status
    ELSE
      create_blank_labeled_volume element=element recorded_vsn=recorded_vsn character_set=character_set ..
        density=type file_accessibility=file_accessibility_code ..
        label_standard_version=$integer(label_standard_version) owner_identifier=owner_identifier ..
        volume_accessibility=volume_accessibility_code status=status
    IFEND
  ELSEIF $specified(external_vsn) THEN
    create_blank_labeled_volume element=element character_set=character_set ..
      density=type external_vsn=external_vsn file_accessibility=file_accessibility_code ..
      label_standard_version=$integer(label_standard_version) owner_identifier=owner_identifier ..
      volume_accessibility=volume_accessibility_code status=status
  IFEND

PROCEND initialize_tape_volume
*DECK DECK=RMP$LOG_DEBUG_INTEGER EXPAND=FALSE
  PROCEDURE [INLINE] rmp$log_debug_integer
    (    message: string ( * );
         integer_value: integer);

    VAR
      line: string (80),
      length: integer;

    IF rmv$tape_debug_mode THEN
      STRINGREP (line, length, message, integer_value);
      rmp$log_debug_message (line (1, length));
    IFEND;
  PROCEND rmp$log_debug_integer;

?? PUSH (LISTEXT := ON) ??
*copyc rmp$log_debug_message
*copyc rmv$tape_debug_mode
?? POP ??

*DECK DECK=RMP$LOG_DEBUG_MESSAGE EXPAND=FALSE
  PROCEDURE [INLINE] rmp$log_debug_message
    (    message: string ( * ));

    VAR
      ignore_status: ost$status;

    IF rmv$tape_debug_mode THEN
      pmp$log_ascii (message, $pmt$ascii_logset [pmc$job_log],
            pmc$msg_origin_system, ignore_status);
    IFEND;

  PROCEND rmp$log_debug_message;

?? PUSH (LISTEXT := ON) ??
*copyc pmp$log_ascii
*copyc rmv$tape_debug_mode
?? POP ??
*DECK DECK=RMP$LOG_DEBUG_STATUS EXPAND=FALSE
  PROCEDURE [INLINE] rmp$log_debug_status
    (    status: ost$status);

    VAR
      ignore_status: ost$status;

    IF (NOT status.normal) AND rmv$tape_debug_mode THEN
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log],
            status, ignore_status);
    IFEND;
  PROCEND rmp$log_debug_status;

?? PUSH (LISTEXT := ON) ??
*copyc osp$generate_log_message
*copyc rmv$tape_debug_mode
?? POP ??
*DECK DECK=RMP$PUT_JOB_STATUS_DISPLAY EXPAND=FALSE

  PROCEDURE [XREF] rmp$put_job_status_display
    (    message_name: clt$parameter_name;
         message_parameters: ^array [1 .. * ] of ^string
          ( * <= ofc$max_display_message));

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_name
*copyc ofc$max_display_message
?? POP ??
*DECK DECK=RMP$PUT_MEDIA_RESPONSE EXPAND=FALSE
*DECK DECK=RMP$R3_REQUEST_NULL_DEVICE EXPAND=FALSE

  PROCEDURE [XREF] rmp$r3_request_null_device
    (VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$evaluated_file_reference
*copyc ost$status
?? POP ??
*DECK DECK=RMP$R3_REQUEST_TAPE EXPAND=FALSE

*DECK DECK=RMP$R3_REQUEST_TERMINAL EXPAND=FALSE

  PROCEDURE [XREF] rmp$r3_request_terminal
    (    terminal_file_name: ^fst$file_reference;
         term_conn_attributes: ift$connection_attributes;
     VAR evaluated_file_reference: {i/o} fst$evaluated_file_reference;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc fst$evaluated_file_reference
*copyc ift$connection_attributes
*copyc ost$status
?? POP ??
*DECK DECK=RMP$RECOVER_JOB_TAPE_TABLE EXPAND=FALSE
  PROCEDURE [XREF] rmp$recover_job_tape_table
    (VAR job_has_tapes_assigned: boolean;
     VAR fatal_reserve_error: boolean);



*DECK DECK=RMP$RELEASE_RESOURCE_COMMAND EXPAND=FALSE
  PROCEDURE [XREF] rmp$release_resource_command
    (    reservation: rmt$tape_reservation;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$tape_reservation
?? POP ??
*DECK DECK=RMP$RELEASE_TAPE_UNIT EXPAND=FALSE

  PROCEDURE [XREF] rmp$release_tape_unit
    (    sfid: gft$system_file_identifier;
         logical_unit: iot$logical_unit;
         delete_request_from_vsn_queue: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_name
*copyc gft$system_file_identifier
*copyc iot$logical_unit
*copyc ost$status
?? POP ??
*DECK DECK=RMP$REMOVE_ROBOTIC_SERVER EXPAND=FALSE

  PROCEDURE [XREF] rmp$remove_robotic_server
    (    server_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc rme$robotic_interface_errors
?? POP ??
*DECK DECK=RMP$REQUEST_MASS_STORAGE EXPAND=FALSE

  PROCEDURE [XREF] rmp$request_mass_storage (file: fst$file_reference;
        allocation_size: rmt$allocation_size;
        estimated_file_size: amt$file_byte_address;
        file_class: rmt$mass_storage_class;
        initial_volume: rmt$recorded_vsn;
        volume_overflow_allowed: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_byte_address
*copyc fst$file_reference
*copyc ost$status
*copyc rmc$condition_code_limits
*copyc rmc$unspecified_allocation_size
*copyc rmc$unspecified_file_class
*copyc rmc$unspecified_file_size
*copyc rmc$unspecified_vsn
*copyc rme$request_mass_storage
*copyc rmt$allocation_size
*copyc rmt$mass_storage_class
*copyc rmt$recorded_vsn
?? POP ??
*DECK DECK=RMP$REQUEST_MASS_STORAGE_CMD EXPAND=TRUE

  PROCEDURE [XREF] rmp$request_mass_storage_cmd
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$parameter_list
*copyc ost$status
?? POP ??
*DECK DECK=RMP$REQUEST_NULL_DEVICE EXPAND=FALSE

  PROCEDURE [XREF] rmp$request_null_device (file: fst$file_reference;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc fst$file_reference
*copyc OST$STATUS
?? POP ??
*DECK DECK=RMP$REQUEST_TAPE EXPAND=FALSE

  PROCEDURE [XREF] rmp$request_tape (file: fst$file_reference;
    class: rmt$tape_class;
    density: rmt$density;
    write_ring: rmt$write_ring;
    volume_list: rmt$volume_list;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc fst$file_reference
*copyc RMD$TAPE_DECLARATIONS
*copyc RMD$VOLUME_DECLARATIONS
*copyc RMC$CONDITION_CODE_LIMITS
*copyc RME$CLASS_VALIDATION_ERRORS
*copyc RME$REQUEST_TAPE
*copyc OST$STATUS
?? POP ??
*DECK DECK=RMP$REQUEST_TERMINAL EXPAND=FALSE

  PROCEDURE [XREF] rmp$request_terminal (file: fst$file_reference;
        terminal_file_name: ^fst$file_reference;
        term_conn_attributes: ift$connection_attributes;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc ift$connection_attributes
*copyc ost$status
?? POP ??
*DECK DECK=RMP$RESERVE_RESOURCE_COMMAND EXPAND=FALSE
  PROCEDURE [XREF] rmp$reserve_resource_command
    (    reservation: rmt$tape_reservation;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$tape_reservation
?? POP ??
*DECK DECK=RMP$SERVER_GET_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] rmp$server_get_request
    (    server_name: ost$name;
         wait: boolean;
     VAR robotic_request: rmt$rbt_request;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc rme$robotic_interface_errors
*copyc rmt$rbt_request
?? POP ??
*DECK DECK=RMP$SERVER_GET_REQUEST_23D EXPAND=FALSE

  PROCEDURE [XREF] rmp$server_get_request_23d
    (    server_name: ost$name;
         wait: boolean;
     VAR client_request: rmt$rbt_request;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc rme$robotic_interface_errors
*copyc rmt$rbt_request
?? POP ??
*DECK DECK=RMP$SERVER_PUT_RESPONSE EXPAND=FALSE

  PROCEDURE [XREF] rmp$server_put_response
    (    server_name: ost$name;
         response: rmt$rbt_unformatted_response;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc rme$robotic_interface_errors
*copyc rmt$rbt_unformatted_response
?? POP ??
*DECK DECK=RMP$SET_EXPLICIT_RESERVE EXPAND=FALSE
  PROCEDURE [XREF] rmp$set_explicit_reserve
    (    reservation: rmt$tape_reservation;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc rmt$tape_reservation
?? POP ??
*DECK DECK=RMP$SET_IMPLICIT_RESERVE EXPAND=FALSE
  PROCEDURE [XREF] rmp$set_implicit_reserve
    (    sfid: gft$system_file_identifier;
         density: rmt$density;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc ost$status
*copyc rmt$density
?? POP ??
*DECK DECK=RMP$VALIDATE_ANSI_LABELS EXPAND=FALSE
*DECK DECK=RMP$VALIDATE_ANSI_STRING EXPAND=FALSE

  PROCEDURE [XREF] rmp$validate_ansi_string (
        input_string: clt$string_value;
    VAR validated_string: clt$string_value;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc clt$string_value
*copyc ost$status
?? POP ??
*DECK DECK=RMP$VALIDATE_MASS_STORAGE_INFO EXPAND=FALSE
  PROCEDURE [XREF] rmp$validate_mass_storage_info
    (    family_set_name: pft$name;
         object_permanent: boolean;
         object_type: pft$object_types;
         p_mass_storage_request_info: {input} ^fmt$mass_storage_request_info;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$mass_storage_request_info
*copyc ost$status
*copyc pfd$catalog
*copyc pfd$permanent_file_definitions
?? POP ??
*DECK DECK=RMP$VALIDATE_SPECIFIED_RMG EXPAND=FALSE
  PROCEDURE [INLINE] rmp$validate_specified_rmg
    (    evaluated_file_reference: fst$evaluated_file_reference;
         removable_media_group: string (* <= 13);
     VAR authorized_access: fst$file_access_options;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
    VAR
      family: ost$family_name,
      removable_media_group_name: ost$name,
      user: ost$user_name,
      user_id: ost$user_identification;

    IF fsp$path_element (^evaluated_file_reference, 1)^ = fsc$local THEN
      pmp$get_user_identification (user_id, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      family := user_id.family;
      user := user_id.user;
    ELSE
      family := fsp$path_element (^evaluated_file_reference, 1)^;
      user := fsp$path_element (^evaluated_file_reference, 2)^;
    IFEND;

    removable_media_group_name := removable_media_group;
    avp$get_removable_media_access (user, family, removable_media_group_name, authorized_access, status);
    IF status.normal AND (authorized_access = $fst$file_access_options []) THEN
      bap$set_evaluated_file_abnormal (evaluated_file_reference, ame$no_removable_media_access, '', '',
            status);
    IFEND;

  PROCEND rmp$validate_specified_rmg;

*copyc ame$label_validation_errors
*copyc fsc$local
*copyc avp$get_removable_media_access
*copyc bap$set_evaluated_file_abnormal
*copyc fsp$path_element
*copyc pmp$get_user_identification
?? POP ??
*DECK DECK=RMP$VALIDATE_TAPE_ASSIGNMENT EXPAND=FALSE

  PROCEDURE [XREF] rmp$validate_tape_assignment
    (    validation_state: boolean,
         file_identifier: amt$file_identifier;
         file: fst$file_reference;
         density: rmt$density;
         write_ring: rmt$write_ring;
         file_label_type: amt$file_label_type;
         access_mode: pft$usage_selections;
         initial_assignment: boolean;
         next_volume: amt$volume_number;
         volume_descriptor: rmt$volume_descriptor;
         removable_media_group: ost$name;
         removable_media_location: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$file_identifier
*copyc amt$file_label_type
*copyc amt$volume_number
*copyc fst$file_reference
*copyc ost$name
*copyc ost$status
*copyc pfd$permanent_file_attributes
*copyc pfd$permanent_file_definitions
*copyc rmt$density
*copyc rmt$tape_class
*copyc rmt$volume_descriptor
*copyc rmt$write_ring
?? POP ??
*DECK DECK=RMP$VALIDATE_TAPE_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] rmp$validate_tape_request
    (    validation_state: boolean;
         file: fst$file_reference;
         density: rmt$density;
         write_ring: rmt$write_ring;
         volume_list: rmt$volume_list;
         removable_media_group: ost$name;
         volume_overflow_allowed: boolean;
         validation_ring: ost$valid_ring;
         file_password: pft$password;
         attachment_logging: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc osd$virtual_address
*copyc ost$status
*copyc pfd$permanent_file_definitions
*copyc rmt$density
*copyc rmt$volume_list
*copyc rmt$write_ring
?? POP ??
*DECK DECK=RMP$VALIDATE_TAPE_VOLUME_INIT EXPAND=FALSE

  PROCEDURE [XREF] rmp$validate_tape_volume_init (
    validation_state: boolean;
    old_volume_init_info: rmt$tape_volume_init_info;
    new_volume_init_info: rmt$tape_volume_init_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc rmt$density
*copyc rmt$tape_class
*copyc rmt$tape_volume_init_info
*copyc ost$status
?? POP ??
*DECK DECK=RMP$VSN_IS_VALID EXPAND=FALSE
*DECK DECK=RMT$ALLOCATION_SIZE EXPAND=FALSE

 TYPE
    rmt$allocation_size = 0 .. rmc$max_allocation_size;

*copyc rmc$max_allocation_size
*copyc rmc$unspecified_allocation_size
*DECK DECK=RMT$DENSITY EXPAND=TRUE

  TYPE
    rmt$density = (rmc$200, rmc$556, rmc$800, rmc$1600, rmc$6250, rmc$38000,
          rmc$reserved_density_1, rmc$reserved_density_2,
          rmc$reserved_density_3, rmc$reserved_density_4,
          rmc$reserved_density_5, rmc$reserved_density_6,
          rmc$reserved_density_7, rmc$reserved_density_8);
*DECK DECK=RMT$DEVICE_CLASS EXPAND=FALSE

 TYPE
    rmt$device_class = (rmc$connected_file_device, rmc$interstate_link_device,
      rmc$local_queue_device, rmc$log_device, rmc$magnetic_tape_device,
      rmc$mass_storage_device, rmc$memory_resident_device, rmc$network_device,
      rmc$null_device, rmc$pipeline_device, rmc$rhfam_device,
      rmc$terminal_device);

*DECK DECK=RMT$DEVICE_CLASSES EXPAND=FALSE
 TYPE
    rmt$device_classes = set of rmt$device_class;

*copyc rmt$device_class
*DECK DECK=RMT$DISMOUNT_STATUS EXPAND=FALSE
*DECK DECK=RMT$ELEMENT_SELECTION_ENTRY EXPAND=FALSE
*DECK DECK=RMT$EXTERNAL_VSN EXPAND=FALSE

  TYPE
    rmt$external_vsn = string (rmc$external_vsn_size);

*copyc rmc$external_vsn_size
*copyc rmc$unspecified_vsn
*DECK DECK=RMT$FILE_TYPE EXPAND=FALSE
{TEMP DECK RMDFT}

TYPE
rmt$file_type = integer;
*DECK DECK=RMT$FORCED_DISMOUNT_STATUS EXPAND=FALSE
*DECK DECK=RMT$JOB_TAPE_TABLE EXPAND=FALSE
  TYPE
    rmt$job_tape_table = record
      job_recovery_active: boolean,
      explicit_reservation: boolean,
      assigned_unit_count: rmt$tape_reservation,
      reserved_unit_count: rmt$tape_reservation,
    recend;

*copyc iot$logical_unit
*copyc rmt$tape_reservation
*DECK DECK=RMT$LABELED_TAPE_CLASSIFICATION EXPAND=FALSE
  TYPE
    rmt$labeled_tape_classification = record
      blank: boolean,
      expired: boolean,
      file_accessibility: string (1),
      implementation_identifier: string (13),
      volume_accessibility: string (1),
      volume_identifier: rmt$recorded_vsn,
      case volume_security_type: rmt$volume_security_type of
      = rmc$vst_access_restricted =
        reason: rmt$restricted_access_reason,
      = rmc$vst_labeled_external =
        external_owner_identifier: string (14),
      = rmc$vst_ve_labeled_for_group =
        removable_media_group: string (13),
      = rmc$vst_ve_labeled_for_user =
        user: string (14),
      = rmc$vst_ve_password_protected =
        ve_owner_identifier: string (14),
      casend,
    recend;

*copyc rmt$restricted_access_reason
*copyc rmt$recorded_vsn
*copyc rmt$volume_security_type

*DECK DECK=RMT$MANRM_STATUS EXPAND=TRUE
*DECK DECK=RMT$MASS_STORAGE_CLASS EXPAND=FALSE

 TYPE
    rmt$mass_storage_class = char;

*copyc rmc$mass_storage_class
*copyc rmc$unspecified_file_class
*DECK DECK=RMT$MEDIA_REQUEST_DESCRIPTOR EXPAND=FALSE
*DECK DECK=RMT$MEDIA_RESPONSE_DESCRIPTOR EXPAND=FALSE
*DECK DECK=RMT$MOUNT_STATUS EXPAND=FALSE
*DECK DECK=RMT$QUERY_VOLUME_STATUS EXPAND=FALSE
*DECK DECK=RMT$QUEUE_ATTRIBUTE_ITEM EXPAND=FALSE
*DECK DECK=RMT$QUEUE_ATTRIBUTE_KEY EXPAND=FALSE
*DECK DECK=RMT$QUEUE_ID EXPAND=FALSE
*DECK DECK=RMT$QUEUE_TYPE EXPAND=FALSE
*DECK DECK=RMT$RBT_ATTRIBUTE_KEY EXPAND=FALSE

  CONST
    rmc$rbt_server_timeout = 0,
    rmc$rbt_null_attribute = 1,
    rmc$rbt_supported_requests = 2;

  TYPE
    rmt$rbt_attribute_key = 0 .. rmc$rbt_max_attribute;

*copyc rmc$rbt_max_attribute
*DECK DECK=RMT$RBT_CONDITIONAL_MESSAGE EXPAND=FALSE
  TYPE
    rmt$rbt_conditional_message = record
      issue_prior_to_retry_attempt: ost$positive_integers,
      message_module: pmt$program_name,
      message_name: clt$parameter_name,
      message_parameters: ^array [1 .. * ] of ^string
            ( * <= rmc$rbt_status_message_width),
    recend;

*copyc clt$parameter_name
*copyc osd$integer_limits
*copyc pmt$program_name
*copyc rmc$rbt_status_message_width
*DECK DECK=RMT$RBT_DISMOUNT_REQUEST EXPAND=FALSE

  TYPE
    rmt$rbt_dismount_request = record
      element: cmt$element_name,
      external_vsn: rmt$external_vsn,
    recend;

*copyc cmt$element_name
*copyc rmt$external_vsn

*DECK DECK=RMT$RBT_DISMOUNT_RESPONSE EXPAND=FALSE

  TYPE
    rmt$rbt_dismount_response = record
      element: cmt$element_name,
      external_vsn: rmt$external_vsn,
    recend;

*copyc cmt$element_name
*copyc rmt$external_vsn
*DECK DECK=RMT$RBT_FORCE_DISMOUNT_REQUEST EXPAND=FALSE

  TYPE
    rmt$rbt_force_dismount_request = record
      element: cmt$element_name,
    recend;

*copyc cmt$element_name
*DECK DECK=RMT$RBT_FORCE_DISMOUNT_RESPONSE EXPAND=FALSE

  TYPE
    rmt$rbt_force_dismount_response = record
      element: cmt$element_name,
    recend;

*copyc cmt$element_name

*DECK DECK=RMT$RBT_MOUNT_REQUEST EXPAND=FALSE

  TYPE
    rmt$rbt_mount_request = record
      element: cmt$element_name,
      external_vsn: rmt$external_vsn,
    recend;

*copyc cmt$element_name
*copyc rmt$external_vsn
*DECK DECK=RMT$RBT_MOUNT_RESPONSE EXPAND=FALSE

  TYPE
    rmt$rbt_mount_response = record
      element: cmt$element_name,
      external_vsn: rmt$external_vsn,
    recend;

*copyc cmt$element_name
*copyc rmt$external_vsn
*DECK DECK=RMT$RBT_QUERY_REQUEST EXPAND=FALSE

  TYPE
    rmt$rbt_query_request = record
      external_vsn: rmt$external_vsn,
    recend;

*copyc rmt$external_vsn
*DECK DECK=RMT$RBT_QUERY_RESPONSE EXPAND=FALSE

  TYPE
    rmt$rbt_query_response = record
      external_vsn: rmt$external_vsn,
      case volume_located: boolean of
      = TRUE =
        case already_mounted: boolean of
        = TRUE =
          element: cmt$element_name,
        = FALSE =
          preferred_candidates: ^array [1 .. * ] of cmt$element_name,
          remaining_candidates: ^array [1 .. * ] of cmt$element_name,
        casend
      = FALSE =
        ,
      casend
    recend;

*copyc cmt$element_name
*copyc rmt$external_vsn
*DECK DECK=RMT$RBT_REQUEST EXPAND=FALSE

  TYPE
    rmt$rbt_request = record
      request_id: rmt$rbt_request_id,
      case request_type: rmt$rbt_request_type of
      = rmc$rbt_query =
        query: rmt$rbt_query_request,
      = rmc$rbt_mount =
        mount: rmt$rbt_mount_request,
      = rmc$rbt_dismount =
        dismount: rmt$rbt_dismount_request,
      = rmc$rbt_force_dismount =
        force_dismount: rmt$rbt_force_dismount_request,
      casend
    recend;

*copyc rmt$rbt_dismount_request
*copyc rmt$rbt_force_dismount_request
*copyc rmt$rbt_mount_request
*copyc rmt$rbt_query_request
*copyc rmt$rbt_request_id
*copyc rmt$rbt_request_type
*DECK DECK=RMT$RBT_REQUEST_ID EXPAND=FALSE

  TYPE
    rmt$rbt_request_id = 0 .. rmc$rbt_max_request_id;

*copyc rmc$rbt_max_request_id
*DECK DECK=RMT$RBT_REQUEST_TYPE EXPAND=FALSE
  CONST
    rmc$rbt_query = 0,
    rmc$rbt_mount = 1,
    rmc$rbt_dismount = 2,
    rmc$rbt_force_dismount = 3;

  TYPE
    rmt$rbt_request_type = 0 .. rmc$rbt_max_request_type;

*copyc rmc$rbt_max_request_type
*DECK DECK=RMT$RBT_SERVER_ATTRIBUTE EXPAND=FALSE
  TYPE
    rmt$rbt_server_attribute = record
      case selector {input} : rmt$rbt_attribute_key of {input}
      = rmc$rbt_server_timeout =
        server_timeout {in milliseconds} : ost$positive_integers,
      = rmc$rbt_supported_requests =
        supported_requests: rmt$rbt_supported_requests,
      = rmc$rbt_null_attribute =
        ,
      casend
    recend;

*copyc osd$integer_limits
*copyc rmt$rbt_attribute_key
*copyc rmt$rbt_supported_requests
*DECK DECK=RMT$RBT_SUPPORTED_REQUESTS EXPAND=FALSE
  TYPE
    rmt$rbt_supported_requests = set of rmt$rbt_request_type;

*copyc rmt$rbt_request_type
*DECK DECK=RMT$RBT_UNFORMATTED_RESPONSE EXPAND=FALSE

  TYPE
    rmt$rbt_unformatted_response = record
      request_id: rmt$rbt_request_id,
      case request_processed: boolean of
      = TRUE =
        case processed_request: rmt$rbt_request_type of
        = rmc$rbt_query =
          query: rmt$rbt_query_response,
        = rmc$rbt_mount =
          mount: rmt$rbt_mount_response,
        = rmc$rbt_dismount =
          dismount: rmt$rbt_dismount_response,
        = rmc$rbt_force_dismount =
          force_dismount: rmt$rbt_force_dismount_response,
        casend
      = FALSE = {retry request}
        server_event_code: ost$non_negative_integers,
        current_request: rmt$rbt_request_type,
        job_log: ^rmt$rbt_conditional_message,
        job_status_display: ^rmt$rbt_conditional_message,
        operator_action: ^rmt$rbt_conditional_message,
        system_log: ^rmt$rbt_conditional_message,
        retry_delay_interval {in milliseconds} : ost$non_negative_integers,
        retry_limit: ost$positive_integers,
        next_request {after limit exceeded} : rmt$rbt_request_type,
      casend,
    recend;

*copyc osd$integer_limits
*copyc rmt$rbt_dismount_response
*copyc rmt$rbt_force_dismount_response
*copyc rmt$rbt_conditional_message
*copyc rmt$rbt_mount_response
*copyc rmt$rbt_query_response
*copyc rmt$rbt_request_id
*copyc rmt$rbt_request_type
*DECK DECK=RMT$RECORDED_VSN EXPAND=FALSE

  TYPE
    rmt$recorded_vsn = string (rmc$recorded_vsn_size);

*copyc rmc$recorded_vsn_size
*copyc rmc$unspecified_vsn
*DECK DECK=RMT$REQUEST_RETRY_INFO EXPAND=FALSE

 TYPE
   rmt$request_retry_info = RECORD
     count: INTEGER,                        { default = 10 times (decremented)
     pause_interval: INTEGER,               { default = 2 min
   RECEND;

 CONST
   ioc$default_timeout_interval_us = 1000000*60*2, { 2 minutes.
   ioc$default_pause_interval_us = 1000000*30;     { 30 seconds.
*DECK DECK=RMT$RESTRICTED_ACCESS_REASON EXPAND=FALSE
  TYPE
    rmt$restricted_access_reason = (rmc$excessive_tape_labels, rmc$hdr1_missing,
          rmc$vol1_missing);

*DECK DECK=RMT$ROBOTIC_MOUNT_INFORMATION EXPAND=FALSE
  TYPE
    rmt$robotic_mount_information = record
      case volume_robotically_mounted: boolean of
      = TRUE =
        element: cmt$element_name,
        server_name: ost$name,
      = FALSE =
        ,
      casend,
    recend;

*copyc cmt$element_name
*copyc ost$name
*DECK DECK=RMT$ROBOTIC_REQUEST_ID EXPAND=FALSE
*DECK DECK=RMT$STK4400_REQUEST_ID EXPAND=FALSE
*DECK DECK=RMT$STK4400_SILO_REQUEST EXPAND=FALSE
*DECK DECK=RMT$STK4400_STATE EXPAND=FALSE
*DECK DECK=RMT$STK_DISMOUNT_INFO EXPAND=FALSE
*DECK DECK=RMT$STK_DISMOUNT_RESPONSE EXPAND=FALSE
*DECK DECK=RMT$STK_FORCED_DISMOUNT_INFO EXPAND=FALSE
*DECK DECK=RMT$STK_FORCE_DISMOUNT_RESPONSE EXPAND=FALSE
*DECK DECK=RMT$STK_MOUNT_INFO EXPAND=FALSE
*DECK DECK=RMT$STK_MOUNT_RESPONSE EXPAND=FALSE
*DECK DECK=RMT$STK_QUERY_VOLUME_INFO EXPAND=FALSE
*DECK DECK=RMT$STK_QUERY_VOLUME_RESPONSE EXPAND=FALSE
*DECK DECK=RMT$SUPPORTED_TAPE_DENSITIES EXPAND=FALSE
  TYPE
    rmt$supported_tape_densities = rmc$800 .. rmc$maximum_density;

*copyc rmc$maximum_density
*copyc rmt$density
*DECK DECK=RMT$TAPE_CLASS EXPAND=TRUE

  TYPE
    rmt$tape_class = (rmc$mt7, rmc$mt9, rmc$mt18, rmc$reserved_class_1,
          rmc$reserved_class_2, rmc$reserved_class_3);
*DECK DECK=RMT$TAPE_RESERVATION EXPAND=FALSE
  TYPE
    rmt$tape_reservation = array [rmt$supported_tape_densities] of
          0 .. ioc$max_unit_number;

*copyc iot$logical_unit
*copyc rmt$supported_tape_densities
*copyc rmt$density
*DECK DECK=RMT$TAPE_UNIT_TYPES EXPAND=FALSE
  TYPE
    rmt$tape_unit_types = (rmc$hd_pe, rmc$pe_ge, rmc$cartridge);

*DECK DECK=RMT$TAPE_VOLUME_CLASSIFICATION EXPAND=FALSE
  TYPE
    rmt$tape_volume_classification = record
      case volume_label_type: rmt$volume_label_type of
      = rmc$indeterminate_volume_type {Read error at BOV} =
        ,
      = rmc$labeled_volume_type =
        labeled: rmt$labeled_tape_classification,
      = rmc$unlabeled_volume_type =
        blank: boolean,
      casend,
    recend;

*copyc rmt$labeled_tape_classification
*copyc rmt$volume_label_type
*DECK DECK=RMT$TAPE_VOLUME_INIT_INFO EXPAND=FALSE
*DECK DECK=RMT$USER_PRIVILEGE EXPAND=FALSE

  TYPE
    rmt$user_privilege = (rmc$normal_user, rmc$privileged_user, rmc$system_user);

*DECK DECK=RMT$VOLUME_DESCRIPTOR EXPAND=TRUE


  TYPE
    rmt$volume_descriptor = record
      recorded_vsn: rmt$recorded_vsn,
      external_vsn: rmt$external_vsn,
    recend;

*copyc rmt$external_vsn
*copyc rmt$recorded_vsn
*DECK DECK=RMT$VOLUME_LABEL_TYPE EXPAND=FALSE
  TYPE
    rmt$volume_label_type = (rmc$indeterminate_volume_type,
          rmc$labeled_volume_type, rmc$unlabeled_volume_type);

*DECK DECK=RMT$VOLUME_LIST EXPAND=TRUE

  TYPE
    rmt$volume_list = array [ * ] of rmt$volume_descriptor;

*copyc rmt$volume_descriptor
*DECK DECK=RMT$VOLUME_SECURITY_TYPE EXPAND=FALSE
  TYPE
    rmt$volume_security_type = (rmc$vst_access_restricted,
          rmc$vst_labeled_external, rmc$vst_ve_labeled_for_group,
          rmc$vst_ve_labeled_for_user, rmc$vst_ve_password_protected);

*DECK DECK=RMT$WRITE_RING EXPAND=TRUE

  TYPE
    rmt$write_ring = (rmc$write_ring, rmc$no_write_ring);
*DECK DECK=RMV$DENSITIES EXPAND=FALSE
  VAR
    rmv$densities: [XREF, READ, oss$job_paged_literal] array [rmt$density] of string (10);

*copyc oss$job_paged_literal
*copyc rmt$density
*DECK DECK=RMV$INITV_MODULE_POINTERS EXPAND=FALSE

  VAR
    rmv$initv_ul_menu : [XREF] ^ost$help_module,
    rmv$initv_exp_menu : [XREF] ^ost$help_module,
    rmv$initv_unexp_menu : [XREF] ^ost$help_module,
    rmv$initv_re_menu : [XREF] ^ost$help_module;

?? PUSH (LISTEXT := ON) ??
*copyc ost$help_module
?? POP ??
*DECK DECK=RMV$JOB_TAPE_TABLE_DEFAULT EXPAND=FALSE
  VAR
    rmv$job_tape_table_default: [XREF, READ, oss$mainframe_paged_literal]
          rmt$job_tape_table;

?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_paged_literal
*copyc rmt$job_tape_table
?? POP ??
*DECK DECK=RMV$JOB_TAPE_TABLE_LOCK EXPAND=FALSE
  VAR
    rmv$job_tape_table_lock: [XREF, oss$job_pageable] ost$signature_lock;

?? PUSH (LISTEXT := ON) ??
*copyc oss$job_pageable
*copyc ost$signature_lock
?? POP ??
*DECK DECK=RMV$JOB_TAPE_TABLE_P EXPAND=FALSE

  VAR
    rmv$job_tape_table_p: [XREF, oss$job_pageable] ^rmt$job_tape_table;

?? PUSH (LISTEXT := ON) ??
*copyc oss$job_pageable
*copyc rmt$job_tape_table
?? POP ??
*DECK DECK=RMV$NULL_DEVICE_SET EXPAND=FALSE
{ This variable is the set of those device classes which use to be
{ rmt$null_device_uses under the rmc$null_device class.

  VAR
    rmv$null_device_set: [XREF, READ, oss$job_paged_literal]
          rmt$device_classes;

?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
*copyc rmt$device_classes
?? POP ??
*DECK DECK=RMV$REQUESTED_VOLUME_ATTRIBUTES EXPAND=FALSE
  VAR
    rmv$requested_volume_attributes: [XREF, READ, oss$job_paged_literal]
          iot$requested_volume_attributes;

*copyc iot$requested_volume_attributes
*copyc oss$job_paged_literal




*DECK DECK=RMV$TAPE_DEBUG_MODE EXPAND=FALSE

  VAR
    rmv$tape_debug_mode: [XREF, oss$task_shared] boolean;

?? PUSH (LISTEXT := ON) ??
*copyc oss$task_shared
?? POP ??

*DECK DECK=RMV$VALID_VSN_CHARACTERS EXPAND=FALSE

  VAR
    rmv$valid_vsn_characters: [XREF] set of char;
*DECK DECK=RMV$WRITE_RING EXPAND=FALSE
  VAR
    rmv$write_ring: [XREF, READ, oss$job_paged_literal] array
          [rmt$write_ring] of string (5);

*copyc oss$job_paged_literal
*copyc rmt$write_ring
*DECK DECK=RSC$EXTEND_LABELED_MESSAGE EXPAND=FALSE
  CONST
    rsc$extend_labeled_message = 'RSM$EXTEND_LABELED             ';
*DECK DECK=RSC$EXTEND_UNLABELED_MESSAGE EXPAND=FALSE
  CONST
    rsc$extend_unlabeled_message = 'RSM$EXTEND_UNLABELED           ';
*DECK DECK=RSM$RESOURCE_HELP_MESSAGES EXPAND=TRUE
~"CREATE_MESSAGE_MODULE RSM$EXTEND_LABELED$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                     NOS/VE Labeled Volume List Extension Menu

  Status             : An additional LABELED (scratch) volume is requested.
  Group              : ~P1
  Location           : ~P2
  Requested Density  : ~P3

  A scratch volume assignment failed because:
  ~P4
  ~P5
  ~P6
  ~P7

    You have the following choices:
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_REQUEST
       1 - Use INITIALIZE_TAPE_VOLUME, if necessary, to label the volume;
           mount it; and identify the 1 to 6 character vsn in the menu
           selection (i.e. 1 RVSN='string' or 1 RVSN=name).
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TERMINATE_REQUEST
       2 - Terminate the request (include a reason with the menu selection).

  ~P4
~"**
~"CREATE_FULL_HELP_MESSAGE
      This menu is presented because a job is requesting an additional
      labeled volume.  An additional volume is required when the job has
      exhausted the list of volumes identified by either a
      REQUEST_MAGNETIC_TAPE command or an ATTACH_FILE command.

      If you provide an additional volume, the job's volume list is
      automatically updated with the volume that you provide.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CONTINUE_REQUEST
      This choice identifies the volume that is to be added to the job's
      volume list.  The job requires a labeled volume.  If you intend to
      provide the job with an additional volume, do the following:

        1. Use the INITIALIZE_TAPE_VOLUME command to label the volume for
           the job, if necessary.
        2. Mount the volume on a tape unit and ready the unit.
        3. Enter the RECORDED_VSN using this menu choice.  If the EXTERNAL_VSN
           is different than the RECORDED_VSN, you must provide both, e.g.
               1 RVSN=XXXXXX EVSN=YYYYYY

           You may enter the value in the form of a string or an SCL name.  A
           string representation is required either when the VSN begins with a
           number or when special characters are used in the VSN.  For example:
             To enter an SCL name: 1 RVSN=VE0496
             To enter a VSN beginning with a number: 1 RVSN='901204'
               The latter produces 901204 as the RECORDED_VSN.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=TERMINATE_REQUEST
      This choice denies the job an additional labeled volume.  Abnormal status
      is returned to the job.  Selection of this choice also allows you to
      explain why the additional volume was denied.  For example:

      2 your account/project has exceeded its budget for tape volumes

      Your explanation is returned to the job within the abnormal status that
      is generated by this menu choice.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
~"CREATE_MESSAGE_MODULE RSM$EXTEND_UNLABELED$US_ENGLISH
~"CREATE_BRIEF_HELP_MESSAGE
                     NOS/VE Unlabeled Volume List Extension Menu

  Status             : An additional UNLABELED (scratch) volume is requested.
  Group              : ~P1
  Location           : ~P2
  Requested Density  : ~P3

  A scratch volume assignment failed because:
  ~P4
  ~P5
  ~P6
  ~P7

    You have the following choices:
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=CONTINUE_REQUEST
       1 - Identify the 1 to 6 character vsn of the volume you want to provide
           (i.e. 1 EVSN='string' or 1 EVSN=name).
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=TERMINATE_REQUEST
       2 - Terminate the request (include a reason with the menu selection).

  ~P4
~"**
~"CREATE_FULL_HELP_MESSAGE
      This menu is presented because a job is requesting an additional
      unlabeled volume.  An additional volume is required when the job
      exhausts the list of volumes identified by either a
      REQUEST_MAGNETIC_TAPE command or an ATTACH_FILE command.

      If you provide an additional volume, the job's volume list is
      automatically updated with the volume that you provide.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=CONTINUE_REQUEST
      This choice identifies the volume that is to be added to the job's
      volume list.  The job requires an unlabeled volume.  If you intend to
      provide the job with an additional volume, enter the EXTERNAL_VSN using
      this menu choice.

      You may enter the value in the form of a string or an SCL name.  A string
      representation is required either when the VSN begins with a number or
      when special characters are used in the VSN.  For example:

        To enter an SCL name: 1 EVSN=VE0496
        To enter a VSN beginning with a number: 1 EVSN='901204'
          The latter produces 901204 as the EXTERNAL_VSN.
~"**
~"CREATE_PARAMETER_HELP_MESSAGE NAME=TERMINATE_REQUEST
      This choice denies the job an additional unlabeled volume.  Abnormal
      status is returned to the job.  Selection of this choice also allows
      you to explain why the additional volume was denied.  For example:

      2 your account/project has exceeded its budget for tape volumes

      Your explanation is returned to the job within the abnormal status that
      is generated by this menu choice.
~"**
END_MESSAGE_MODULE CREATE_MODULE=YES
*DECK DECK=SCD_CTI_BUILD_HISTORY EXPAND=FALSE
"
"   The purpose of this deck is to keep a record of the feature associated with
" the system_console_driver builds.  This is necessary because integration does not
" build the SCD in the normal build fashion.  Instead, it is built simply by setting
" up a build catalog with a wef$feature_list file and by running the Build_System
" Console_Driver procedure.  This procedure will compile all of the decks with the
" group attribute of osf$scd.
"
"START 1984-03-22
include_feature create_buised
include_feature system_console_driver
include_feature scd_support_for
include_feature nos_system_console_driver
"END 1984-03-22
"START 1984-04-12
include_feature nos_system_console_driver
"END 1984-04-12
"START 1984-08-30
include_feature correct_screen_position
"END 1984-08-30
"START 1984-11-07
include_feature scd007
"END 1984-11-07

*DECK DECK=SCFS_PROTOCOL_SPECIFICATION EXPAND=TRUE
*DECK DECK=SFC$COMPILING_FOR_TEST_HARNESS EXPAND=FALSE
  ?VAR
*IF ($variable(sfv$test_harness, declared) = 'LOCAL') AND sfv$test_harness
    sfc$compiling_for_test_harness: boolean := TRUE ?;
*ELSE
    sfc$compiling_for_test_harness: boolean := FALSE ?;
*IFEND

*DECK DECK=SFC$MIN_AUDIT_STATISTIC_CODE EXPAND=FALSE

  CONST
    sfc$min_audit_statistic_code = (($INTEGER ('S') * 100(16)) +
          $INTEGER ('F')) * 1000000(16);

*DECK DECK=SFC$MIN_ECC EXPAND=FALSE

  CONST
*IF $true(osv$unix)
    sfc$min_ecc = (($INTEGER ('S') * 100(16)) + $INTEGER ('F')) * 10000(16);
*ELSE
    sfc$min_ecc = (($INTEGER ('S') * 100(16)) + $INTEGER ('F')) * 1000000(16);
*IFEND

*DECK DECK=SFC$STATISTIC_VERSION EXPAND=FALSE
  CONST
    sfc$statistic_version = 0;

*DECK DECK=SFC$UNLIMITED EXPAND=FALSE

  CONST
    sfc$unlimited = osc$max_integer;

*copyc osd$integer_limits
*DECK DECK=SFC$WARNING_GRACE_PERIOD EXPAND=FALSE

{   This constant declares the minimum number of job mode CP seconds that a job
{   is allowed before a resource condition will be repeated.  This should be
{   more than enough time for the job to increase the warning limit for the
{   limit causing the resource condition.

  CONST
    sfc$warning_grace_period = 60;
*DECK DECK=SFD$TYPE_DECLARATIONS EXPAND=FALSE

*IF $true(osv$unix)

  CONST
    sfc$max_threshold = 7fffffff(16),
    sfc$max_time_interval = 7fffffff(16);

*ELSE

  CONST
    sfc$max_threshold = 7fffffffffff(16),
    sfc$max_time_interval = 0ffffffff(16);

*IFEND

*copyc sft$statistic_code
*copyc sft$statistic_identifier
*copyc sft$descriptive_data
*copyc sft$counters
*copyc sft$counter

*copyc sft$statistic_record
*copyc sft$statistic_group
*DECK DECK=SFE$AUDIT_CONTROL_LOCKED EXPAND=FALSE

  CONST
    sfe$audit_control_locked = sfc$min_ecc + 1;
  {W Auditing of one or more of the specified operations is locked and could..
  { not be deactivated.}

*copyc sfc$min_ecc

*DECK DECK=SFE$AUDIT_NOT_INSTALLED EXPAND=TRUE
*copyc sfc$min_ecc
?? FMT (FORMAT := OFF) ??

  CONST
    sfe$audit_not_installed                       = sfc$min_ecc + 49;
    {E The Audit/VE product is not installed. }

?? FMT (FORMAT := ON) ??
*DECK DECK=SFE$CALL_AGAIN_JOB_RECOVERED EXPAND=FALSE

  CONST
    sfe$call_again_job_recovered = sfc$min_ecc + 20;
    {E The job was recovered while reading the system routing control table,
    { call +P again.}

*copyc sfc$min_ecc
*DECK DECK=SFE$CONDITION_CODES EXPAND=FALSE

*copyc sfc$min_ecc
*copyc sfe$limit_condition_codes

*copyc sfe$audit_control_locked                   "1
*copyc sfe$routing_control_locked                 "2
*copyc sfe$call_again_job_recovered               "20
*copyc sfe$counter_array_size_range               "25
*copyc sfe$incorrect_statistic_code               "30
*copyc sfe$descriptive_data_size                  "40
*copyc sfe$heap_full                              "45
*copyc sfe$insufficient_privilege                 "46
*copyc sfe$invalid_statistic_name                 "47
*copyc sfe$security_audit_not_enabled             "48
*copyc sfe$audit_not_installed                    "49
*copyc sfe$statistics_not_available               "50
*copyc sfe$too_much_data_for_statistic            "55
*copyc sfe$unknown_display_command                "60
*copyc sfe$unknown_audit_operation                "64
*copyc sfe$unknown_audit_selector                 "67
*copyc sfe$unknown_log                            "70
*copyc sfe$unknown_routing_ctl_access             "75
*copyc sfe$work_area_full                         "90
*DECK DECK=SFE$COUNTER_ARRAY_SIZE_RANGE EXPAND=FALSE

  CONST
    sfe$counter_array_size_range = sfc$min_ecc + 25;
    {E Statistic code +P counter array size must be less than +P. (+P request)}

*copyc sfc$min_ecc
*DECK DECK=SFE$DESCRIPTIVE_DATA_SIZE EXPAND=FALSE

  CONST
    sfe$descriptive_data_size = sfc$min_ecc + 40;
    {E Statistic code +P descriptive data size must be less than +P. (+P request) }

*copyc sfc$min_ecc
*DECK DECK=SFE$HEAP_FULL EXPAND=FALSE

  CONST
    sfe$heap_full = sfc$min_ecc + 45;
    {E +P pageable segment full. (+P request) }

*copyc sfc$min_ecc
*DECK DECK=SFE$INCORRECT_STATISTIC_CODE EXPAND=FALSE

  CONST
    sfe$incorrect_statistic_code = sfc$min_ecc + 30;
    {E +P is an incorrect statistic code value.}

*copyc sfc$min_ecc
*DECK DECK=SFE$INSUFFICIENT_PRIVILEGE EXPAND=FALSE

  CONST
    sfe$insufficient_privilege = sfc$min_ecc + 46;
    {E User is not authorized to +P the specified +P routing control
    { information.}

*copyc sfc$min_ecc
*DECK DECK=SFE$INVALID_STATISTIC_NAME EXPAND=FALSE

  CONST
    sfe$invalid_statistic_name = sfc$min_ecc + 47;
    {E +P is not a valid statistic name.}

*copyc sfc$min_ecc
*DECK DECK=SFE$LIMIT_CONDITION_CODES EXPAND=FALSE
?? RIGHT := 110 ??
?? FMT (FORMAT := OFF) ??

*copyc sfc$min_ecc

  CONST
    sfc$min_ecc_limits = sfc$min_ecc + 1000,
    sfc$max_ecc_limits = sfc$min_ecc_limits + 1000;

  CONST
    sfe$accumulator_overflow = sfc$min_ecc_limits + 10,
    {I The +P limit accumulator has overflowed.}

    sfe$conflicting_parameters = sfc$min_ecc_limits + 13,
    {E The parameters +P can not be used together, choose one or the other.}

    sfe$corrupted_limit_chain = sfc$min_ecc_limits + 15,
    {E Procedure +P detected a damaged limit chain.}

    sfe$duplicate_limit_name = sfc$min_ecc_limits + 20,
    {E The name +P is already being used for a limit.}

    sfe$invalid_maximum_limit = sfc$min_ecc_limits + 30,
    {E The specified +P maximum limit (+P) must be greater than or equal to the
    { warning limit value (+P).}

    sfe$invalid_initial_limit_value = sfc$min_ecc_limits + 33,
    {E The +P warning limit (+P) must be greater than the initial accumulator
    { value (+P) and less than or equal to the maximum limit (+P).}

    sfe$invalid_warning_limit = sfc$min_ecc_limits + 35,
    {E The specified +P warning limit (+P) must be greater than the current
    { accumulator value (+P) and less than or equal to the maximum limit (+P).}

    sfe$job_maximum_limit_exceeded = sfc$min_ecc_limits + 40,
    {E The +P job maximum limit has been exceeded.}

    sfe$job_warning_limit_exceeded = sfc$min_ecc_limits + 45,
    {E The +P job warning limit has been exceeded.}

    sfe$limit_already_active = sfc$min_ecc_limits + 50,
    {E Statistic +P cannot be associated with +P limit because it is already
    { associated with +P limit.}

    sfe$limit_array_pointer_nil = sfc$min_ecc_limits + 53,
    {E The specified pointer to the array of limit records must not be a NIL
    { pointer.}

    sfe$limit_array_too_small = sfc$min_ecc_limits + 55,
    {E The size of the limit array (+P entries) must be large enough to hold all +P
    { limits.}

    sfe$limit_not_activated = sfc$min_ecc_limits + 60,
    {E +P limit has not been activated.}

    sfe$no_active_limits = sfc$min_ecc_limits + 65,
    {W There are no limits activated for this job.}

    sfe$unknown_condition_id = sfc$min_ecc_limits + 85,
    {E +P is not a known job resource condition identifier.}

    sfe$unknown_enforcement = sfc$min_ecc_limits + 90,
    {E An unknown enforcement option was found for +P limit.}

    sfe$unknown_update_kind = sfc$min_ecc_limits + 95;
    {E An unknown update kind was passed to +P.}

?? FMT (FORMAT := ON) ??
*DECK DECK=SFE$ROUTING_CONTROL_LOCKED EXPAND=FALSE

  CONST
    sfe$routing_control_locked = sfc$min_ecc + 2;
  {W One or more of the specified statistics is locked and could not be..
  { deactivated.}

*copyc sfc$min_ecc
*DECK DECK=SFE$SECURITY_AUDIT_NOT_ENABLED EXPAND=FALSE

  CONST
    sfe$security_audit_not_enabled = sfc$min_ecc + 48;
    {E The security audit option is not enabled.}

*copyc sfc$min_ecc
*DECK DECK=SFE$STATISTICS_NOT_AVAILABLE EXPAND=FALSE

  CONST
    sfe$statistics_not_available = sfc$min_ecc + 50;
    {E +P routing control table is not available. (+P request) }

*copyc sfc$min_ecc
*DECK DECK=SFE$STATISTIC_CONDITION_CODES EXPAND=FALSE

*DECK DECK=SFE$TOO_MUCH_DATA_FOR_STATISTIC EXPAND=FALSE

  CONST
    sfe$too_much_data_for_statistic = sfc$min_ecc + 55;
    {E Too much data was passed on a request to emit an +P statistic.}

*copyc sfc$min_ecc
*DECK DECK=SFE$UNKNOWN_AUDIT_OPERATION EXPAND=FALSE

  CONST
    sfe$unknown_audit_operation = sfc$min_ecc + 64;
  {E An unknown audit operation was specified on the call to..
  { SFP$EMIT_AUDIT_STATISTIC (ordinal +P).}

*copyc sfc$min_ecc

*DECK DECK=SFE$UNKNOWN_AUDIT_SELECTOR EXPAND=FALSE

  CONST
    sfe$unknown_audit_selector= sfc$min_ecc + 67;
    {E An unknown audit selector was specified on the call to +P.}

*copyc sfc$min_ecc
*DECK DECK=SFE$UNKNOWN_DISPLAY_COMMAND EXPAND=FALSE

  CONST
    sfe$unknown_display_command = sfc$min_ecc + 60;
    {E +P is an unknown display command.}

*copyc sfc$min_ecc
*DECK DECK=SFE$UNKNOWN_LOG EXPAND=FALSE

  CONST
    sfe$unknown_log = sfc$min_ecc + 70;
    {E +P is not a known binary log.}

*copyc sfc$min_ecc
*DECK DECK=SFE$UNKNOWN_ROUTING_CTL_ACCESS EXPAND=FALSE

  CONST
    sfe$unknown_routing_ctl_access = sfc$min_ecc + 75;
    {E An unknown routing control access was specified on the call to +P.}

*copyc sfc$min_ecc
*DECK DECK=SFE$WORK_AREA_FULL EXPAND=FALSE

  CONST
    sfe$work_area_full = sfc$min_ecc + 90;
    {E The work area passed to +P is full.}

*copyc sfc$min_ecc
*DECK DECK=SFH$ACTIVATE_AUDIT EXPAND=FALSE
{
{    Initiate auditing of the specified operations
{
{       SFP$ACTIVATE_AUDIT (operation_set, selection_criteria,
{             routing_control_table_id, lock, status)
{
{ OPERATION_SET: (input)  Specifies which operations should be audited.
{
{ SELECTION_CRITERIA: (input)  Specifies the selection criteria for the
{       specified operations.
{
{ ROUTING_CONTROL_TABLE_ID: (input)  Specifies which routing control table
{       should be updated.
{
{ LOCK: (input)  Specifies whether or not the auditing initiated as a result of
{       this request can be terminated via the SFP$DEACTIVATE_AUDIT interface.
{
{ STATUS: (outout) Variable in which the completion status is returned.
{       CONDITIONS:
{             sfe$insufficient_privilege
{             sfe$statistics_not_availiable
{             sfe$unknown_audit_operation
{             sfe$unknown_audit_selector
{
*DECK DECK=SFH$ACTIVATE_JOB_STATISTIC EXPAND=FALSE
{
{   This procedure activates logging of the specified statistic to selected
{ binary logs for this job.
{
{       SFP$ACTIVATE_JOB_STATISTIC (STATISTIC_CODE, LOGS, STATUS)
{
{ STATISTIC_CODE: (input) Specifies the statistic code of the statistic to be
{         activated to one or more logs.
{
{ LOGS: (input) Specifies one or more logs that the statistic should be recorded
{         in.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$heap_full
{                     sfe$insufficient_privilege
{                     sfe$statistics_not_available
{
*DECK DECK=SFH$ACTIVATE_SYSTEM_STATISTIC EXPAND=FALSE
{
{   This procedure activates logging of the specified statistic to selected
{ binary logs for all jobs in the system.
{
{       SFP$ACTIVATE_SYSTEM_STATISTIC (STATISTIC_CODE, LOGS, STATUS)
{
{ STATISTIC_CODE: (input) Specifies the statistic code of the statistic to be
{         activated to one or more logs.
{
{ LOGS: (input) Specifies one or more logs that the statistic should be recorded
{         in.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$heap_full
{                     sfe$insufficient_privilege
{                     sfe$statistics_not_available
{
*DECK DECK=SFH$ADD_JOB_AUDIT_CONTROL EXPAND=FALSE
{
{    This internal interface adds audit control information to a job routing
{ control entry (creating the entry if necessary).
{
{       SFP$ADD_JOB_AUDIT_CONTROL (OPERATION_SET, SELECTION_CRITERIA, LOCK,
{             STATUS)
{
{ OPERATION_SET: (input)  Specifies the set of operations to be audited.
{
{ SELECTION_CRITERIA: (input)  Specifies the selection criteria to be used when
{       deciding whether or not to record an operation.
{
{ LOCK: (input)  Specifies whether or not auditing of the specified operations
{       can be disabled via the SFP$DELETE_JOB_AUDIT_CONTROL interface.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$statistics_not_available
{
*DECK DECK=SFH$ADD_JOB_ROUTING_CONTROL EXPAND=FALSE
{
{    This internal interface adds routing control information to an existing
{ job routing control entry or creates and initializes a new job routing
{ control entry for the specified statistic.
{
{       SFP$ADD_JOB_ROUTING_CONTROL (STATISTIC_CODE, LOGS, LIMIT_NAME, STATUS)
{
{ STATISTIC_CODE: (input)  Specifies the statistic code of the statistic to be
{       activated to one or more logs.
{
{ LOGS: (input)  Specifies one or more logs that the statistic should be
{       recorded in.
{
{ LIMIT_NAME: (input)  Specifies the name of an associated limit.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$statistics_not_available
{                     sfe$limit_already_active
{
*DECK DECK=SFH$ADD_SYSTEM_AUDIT_CONTROL EXPAND=FALSE
{
{    This internal interface adds audit control information to a system routing
{ control entry (creating the entry if necessary).
{
{       SFP$ADD_SYSTEM_AUDIT_CONTROL (OPERATION_SET, SELECTION_CRITERIA, LOCK,
{             STATUS)
{
{ OPERATION_SET: (input)  Specifies the set of operations to be audited.
{
{ SELECTION_CRITERIA: (input)  Specifies the selection criteria to be used when
{       deciding whether or not to record an operation.
{
{ LOCK: (input)  Specifies whether or not auditing of the specified operations
{       can be disabled via the SFP$DELETE_SYS_AUDIT_CONTROL interface.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$statistics_not_available
{
*DECK DECK=SFH$ADD_SYSTEM_ROUTING_CONTROL EXPAND=FALSE
{
{    This internal interface adds routing control information to an existing
{ system routing control entry or creates and initializes a new system routing
{ control entry for the specified statistic.
{
{       SFP$ADD_SYSTEM_ROUTING_CONTROL (STATISTIC_CODE, LOGS, STATUS)
{
{ STATISTIC_CODE: (input)  Specifies the statistic code of the statistic to be
{       activated to one or more logs.
{
{ LOGS: (input)  Specifies one or more logs that the statistic should be
{       recorded in.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$statistics_not_available
{
{
*DECK DECK=SFH$CHANGE_JOB_WARNING_LIMIT EXPAND=FALSE
{
{    This interface changes the warning limit value for a limit.
{
{       SFP$CHANGE_JOB_WARNING_LIMIT (LIMIT_NAME, WARNING_LIMIT, STATUS)
{
{ LIMIT_NAME: (input)  Specifies the name used to identify the limit.
{
{ WARNING_LIMIT: (input)  Specifies a new value for the warning limit.  This
{       value must be less than or equal to the warning limit and greater than
{       the current accumulator value for the limit.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{       CONDITIONS:
{             cle$improper_name
{             sfe$invalid_warning_limit
{             sfe$limit_not_activated
{             sfe$statistics_not_available
{
*DECK DECK=SFH$CLEAR_JOB_ROUTING_CTL_LOCK EXPAND=FALSE
{
{   This internal interface is usd to insure that the task does not have the
{   job routing control table interlocked.
{
{       SFP$CLEAR_JOB_ROUTING_CTL_LOCK
{
*DECK DECK=SFH$CONVERT_STAT_CODE_TO_NAME EXPAND=FALSE
{
{   This procedure converts a statistic code into a name that can be displayed.
{
{       SFP$CONVERT_STAT_CODE_TO_NAME (STATISTIC_CODE, STATISTIC_NAME, STATUS)
{
{ STATISTIC_CODE: (input) Specifies the statistic code to be converted.
{
{ STATISTIC_NAME: (output) Variable to receive the statistic name.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: None.
{
*DECK DECK=SFH$CONVERT_STAT_NAME_TO_CODE EXPAND=FALSE
{
{   This procedure converts a statistic name into a statistic code.
{
{       SFP$CONVERT_STAT_NAME_TO_CODE (STATISTIC_NAME, STATISTIC_CODE, STATUS)
{
{ STATISTIC_NAME: (input) Specifies the statistic name to convert.
{
{ STATISTIC_CODE: (output) Variable to receive the statistic code.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$invalid_statistic_name
{
*DECK DECK=SFH$CREATE_JOB_LIMIT EXPAND=FALSE
{
{    This procedure is responsible for setting up new limits for a job.
{
{       SFP$CREATE_JOB_LIMIT (LIMIT_NAME, STATISTIC_CODES, INITIAL_VALUE,
{             WARNING_LIMIT, MAXIMUM_LIMIT, ENFORCEMENT, STATUS)
{
{ LIMIT_NAME: (input)  Specifies the name of the limit to be created.  This
{       name is used to identify the limit for update of display purposes.
{
{ STATISTIC_CODES: (input)  Specifies a pointer to an array of statistic codes
{       to be associated with the limit.  A NIL pointer implies no statistics
{       are associated with the limit.
{
{ INITIAL_VALUE: (input)  Specifies an initial value for the limit accumulator.
{
{ WARNING_LIMIT: (input)  Specifies the warning limit value for the limit.
{
{ MAXIMUM_LIMIT: (input)  Specifies the maximum limit value for the limit.
{
{ ENFORCEMENT: (input)  Specifies te type of enforcment that should be used for
{       the limit.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{       CONDITIONS:
{             sfe$duplicate_limit_name
{             sfe$invalid_initial_limit_value
{             sfe$limit_already_active
{             sfe$statistics_not_available
{
*DECK DECK=SFH$DEACTIVATE_AUDIT EXPAND=FALSE
{
{    Terminate auditing for the specified operations
{
{       SFP$DEACTIVATE_AUDIT (operation_set, routing_control_table_id, status)
{
{ OPERATION_SET: (input)  Specifies which operations should no longer be
{       audited.
{
{ ROUTING_CONTROL_TABLE_ID: (input)  Specifies which routing control table
{       should be updated.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             sfe$insufficient_privilege
{             sfe$statistics_not_availiable
{             sfe$unknown_audit_operation
{
*DECK DECK=SFH$DEACTIVATE_JOB_STATISTIC EXPAND=FALSE
{
{   This procedure deactivates logging of the specified statistic from selected
{ binary logs for this job.
{
{       SFP$DEACTIVATE_JOB_STATISTIC (STATISTIC_CODE, LOGS, STATUS)
{
{ STATISTIC_CODE: (input) Specifies the statistic code of the statistic to be
{         deactivated from one or more logs.
{
{ LOGS: (input) Specifies one or more logs that should be removed from the set
{         of logs the statistic is recorded in.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$insufficient_privilege
{                     sfe$statistics_not_available
{
*DECK DECK=SFH$DEACTIVATE_SYSTEM_STATISTIC EXPAND=FALSE
{
{   This procedure deactivates logging of the specified statistic from selected
{ binary logs for all jobs in the system.
{
{       SFP$DEACTIVATE_SYSTEM_STATISTIC (STATISTIC_CODE, LOGS, STATUS)
{
{ STATISTIC_CODE: (input) Specifies the statistic code of the statistic to be
{         deactivated from one or more logs.
{
{ LOGS: (input) Specifies one or more logs that should be removed from the set
{         of logs the statistic is recorded in.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$insufficient_privilege
{                     sfe$statistics_not_available
{
*DECK DECK=SFH$DELETE_JOB_AUDIT_CONTROL EXPAND=FALSE
{
{    This internal interface deletes unlocked audit control information from a
{ job routing control entry.
{
{       SFP$DELETE_JOB_AUDIT_CONTROL (OPERATION_SET, STATUS)
{
{ OPERATION_SET: (input)  Specifies the set of operations should no longer be
{       audited.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$statistics_not_available
{
*DECK DECK=SFH$DELETE_JOB_ROUTING_CONTROL EXPAND=FALSE
{
{    This internal interface deletes logs from the set of activated logs for a
{ specified statistic entry in the job routing control table.
{
{       SFP$DELETE_JOB_ROUTING_CONTROL (STATISTIC_CODE, LOGS, STATUS)
{
{ STATISTIC_CODE: (input)  Specifies the statistic code of the statistic to be
{       activated to one or more logs.
{
{ LOGS: (input)  Specifies the logs that should be deleted from the set of logs
{       that the statistic is being recorded in.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$statistics_not_available
{
*DECK DECK=SFH$DELETE_SYS_AUDIT_CONTROL EXPAND=FALSE
{
{    This internal interface deletes unlocked audit control information from a
{ system routing control entry.
{
{       SFP$DELETE_SYSTEM_AUDIT_CONTROL (OPERATION_SET, STATUS)
{
{ OPERATION_SET: (input)  Specifies the set of operations should no longer be
{       audited.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$statistics_not_available
{
*DECK DECK=SFH$DELETE_SYS_ROUTING_CONTROL EXPAND=FALSE
{
{    This internal interface deletes logs from the set of activated logs for a
{ specified statistic entry in the system routing control table.
{
{       SFP$DELETE_SYS_ROUTING_CONTROL (STATISTIC_CODE, LOGS, LIMIT_NAME,
{             STATUS)
{
{ STATISTIC_CODE: (input)  Specifies the statistic code of the statistic to be
{       deactivated to one or more logs.
{
{ LOGS: (input)  Specifies the logs that should be deleted from the set of logs
{       that the statistic is being recorded in.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$statistics_not_available
{
*DECK DECK=SFH$EMIT_AUDIT_STATISTIC EXPAND=FALSE
{
{    Place an audit statistic in the security log.  The audit statistic will
{ only be recorded in the security log if it has been activated to the security
{ log and meets the criteria specified by the site.
{
{       SFP$EMIT_AUDIT_STATISTIC (operation_information, operation_status)
{
{ OPERATION_INFORMATION: (input)  Record containing the information that
{       describes an audited operation.
{
{ OPERATION_STATUS: (input)  Specifies the status of the audited operation.
{
*DECK DECK=SFH$EMIT_STATISTIC EXPAND=FALSE
{
{   Records a statistic to all of the binary logs that the statistic has been
{ activated to (if any).  It also updates the accumulator for a limit (if a
{ limit is associated with the statistic).
{
{       SFP$EMIT_STATISTIC (STATISTIC_CODE, DESCRIPTIVE_DATA, COUNTERS, STATUS)
{
{ STATISTIC_CODE: (input) This parameter identifies the statistic which is
{         to be emitted.
{
{ DESCRIPTIVE_DATA: (input) This parameter specifies the descriptive data
{         to be recorded with the statistic.
{
{ COUNTERS: (input) This parameter contains an array of counters
{         representing reported values of system or job variables.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$counter_array_size_range
{                     sfe$descriptive_data_size
{
*DECK DECK=SFH$EMIT_SYSTEM_STATISTIC EXPAND=FALSE
{
{    Records a statistic to all of the binary logs that the statistic has been
{ activated to (if any).  It also updates the accumulator for a limit (if a
{ limit is associated with the statistic).
{
{    It has been left, temporarily, to provide compatibility with previous
{ versions of NOS/VE.  Any uses of this procedure should be removed and
{ replaced with calls to SFP$EMIT_STATISTIC.
{
{       SFP$EMIT_SYSTEM_STATISTIC (IDENTIFIER, STATISTIC_CODE,
{             DESCRIPTIVE_DATA, COUNTERS, STATUS)
{
{ IDENTIFIER: (input)  Specifies the two character product identifier for the
{       statistic.
{
{ STATISTIC_CODE: (input)  This parameter identifies the statistic which is to
{       be emitted.
{
{ DESCRIPTIVE_DATA: (input)  This parameter specifies the descriptive data to
{       be recorded with the statistic.
{
{ COUNTERS: (input)  This parameter contains an array of counters representing
{       reported values of system or job variables.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{       CONDITIONS:
{             sfe$counter_array_size_range
{             sfe$descriptive_data_size
{             sfe$statistics_not_available
{
*DECK DECK=SFH$GET_ACTIVE_JOB_STATISTICS EXPAND=FALSE
{
{   This procedure returns a list containing all of the statistics that are
{ activated, in the job routing control table, to one or more of the specified
{ logs.
{
{      SFP$GET_ACTIVE_JOB_STATISTICS (LOGS, HEAD, WORK_AREA, STATUS)
{
{ LOGS: (input) Specifies the set of logs information is retrieved for.
{
{ HEAD: (output) Variable to receive the pointer to the first routing control
{        record.
{
{ WORK_AREA: (input, output) Pointer to a sequence where the linked list of
{        routing control information is stored.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$insufficient_privilege
{                     sfe$statistics_not_available
{
*DECK DECK=SFH$GET_ACTIVE_SYSTEM_STATS EXPAND=FALSE
{
{   This procedure returns a list containing all of the statistics that are
{ activated, in the system routing control table, to one or more of the
{ specified logs.
{
{      SFP$GET_ACTIVE_SYSTEM_STATS (LOGS, HEAD, WORK_AREA, STATUS)
{
{ LOGS: (input) Specifies the set of logs information is retrieved for.
{
{ HEAD: (output) Variable to receive the pointer to the first routing control
{        record.
{
{ WORK_AREA: (input, output) Pointer to a sequence where the linked list of
{        routing control information is stored.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$call_again_job_recovered
{                     sfe$insufficient_privilege
{                     sfe$statistics_not_available
{
*DECK DECK=SFH$GET_ALL_JOB_LIMITS EXPAND=FALSE
{
{   This interface retrieves information about every limit that is activated
{   for a job.
{
{       SFP$GET_ALL_JOB_LIMITS (limits, count, status)
{
{ LIMITS: (input) Specifies a pointer to an array of records which will recieve
{         information about every limit activated for the job.
{
{ COUNT: (output) Returns the actual number of limits that are active for the
{ job.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$limit_array_to_small
{                     sfe$corrupted_limit_chain
{                     sfe$limit_array_pointer_nil
{                     sfe$no_active_limits
{                     sfe$statistics_not_available
{
*DECK DECK=SFH$GET_AUDITED_OPERATIONS EXPAND=FALSE
{
{    Program interface used to retrieve which operations are being audited.
{
{       SFP$GET_AUDITED_OPERATIONS (routing_control_table_id, work_area,
{             first_routing_control_entry, status);
{
{ ROUTING_CONTROL_TABLE_ID: (input)  Specifies which routing control table
{       should be updated.
{
{ WORK_AREA: (input, output)  Specifies a sequence that can be used to return
{       the routing control information for statistics activated to the
{       security log.
{
{ FIRST_ROUTING_CONTROL_ENTRY: (output)  Returns a pointer to the first routing
{       control entry stored in the work area.
{
{ STATUS: (output)Variable in which the completion status is returned.
{       CONDITIONS:
{             sfe$statistics_not_availiable
{
*DECK DECK=SFH$GET_JOB_LIMIT EXPAND=FALSE
{
{   This interface retrieves information about a specified limit.
{
{       SFP$GET_JOB_LIMIT (LIMIT_NAME, LIMIT, STATUS)
{
{ LIMIT_NAME: (input) Name used to identify the limit.
{
{ LIMIT: (output) Variable used to receive information about the
{         specified limit.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: cle$improper_name
{                     sfe$limit_not_activated
{                     sfe$statistics_not_available
{
*DECK DECK=SFH$GET_JOB_LIMIT_COUNT EXPAND=FALSE
{
{   This interface returns the number of active limits for job.
{
{       SFP$GET_JOB_LIMIT_COUNT (COUNT, STATUS)
{
{ COUNT: (output) Variable used to receive the actual number of
{         limits that are active for the job.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$statistics_not_available
{
*DECK DECK=SFH$GET_JOB_LIMIT_NAME EXPAND=FALSE
{
{   This interface returns the name of the limit that is associated with the
{   specified
{ resource condition identifier.  This procedure is intended to be used by a
{ condition handler to determine the name of the limit that caused a job
{ resource
{ condition.
{
{       SFP$GET_JOB_LIMIT_NAME (CONDITON_ID, LIMIT_NAME, STATUS)
{
{ CONDITION_ID: (input) The job resource condition identifer passed to a
{          condition handler.
{
{ LIMIT_NAME: (output) Name used to identify the limit.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$statistics_not_available
{                     sfe$unknown_condition_id
{
*DECK DECK=SFH$GET_LOG_NAME EXPAND=FALSE
{
{   This procedure returns the name of a specified binary log.
{
{      SFP$GET_LOG_NAME (LOG, LOG_NAME, STATUS)
{
{ LOG: (input) Specifes which binary log name to return.
{
{ LOG_NAME: (output) Variable that receives the log name.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: None.
{
*DECK DECK=SFH$INITIATE_RESOURCE_CONDITION EXPAND=FALSE
{
{   This procedure is used to initiate a job resource condition when a limit
{ accumulator (with SFC$ACCUMULATION_ENFORCEMENT) reaches the resource limit
{ value.
{
{      SFP$INITIATE_RESOURCE_CONDITION (LIMIT_CHAIN_ENTRY, STATUS);
{
{ LIMIT_CHAIN_ENTRY: (input) A pointer to the limit chain entry that has
{        reached its job resource limit.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: None.
{
*DECK DECK=SFH$INIT_JOB_ROUTING_CONTROL EXPAND=FALSE
{
{    This internal interface allocates and initializes the job routing control
{ table and associated variables.
{
{       SFP$INIT_JOB_ROUTING_CONTROL (STATUS)
{
{ STATUS: (output) Variable in which the completion status is returned.
{
*DECK DECK=SFH$INIT_SYSTEM_ROUTING_CONTROL EXPAND=FALSE
{
{    This internal interface allocates and initializes the system routing
{ control table and associated variables.
{
{       SFP$INIT_SYSTEM_ROUTING_CONTROL (STATUS)
{
{ STATUS: (output) Variable in which the completion status is returned.
{
*DECK DECK=SFH$INTERNAL_EMIT_STATISTIC EXPAND=FALSE
{
{    Records a statistic to all of the binary logs that the statistic has been
{ activated to (if any).  It also updates the accumulator for a limit (if a
{ limit is associated with the statistic).
{
{    This interface should only be used by the statistics facility or when it
{ is necessary to override the global task id recorded in the statistic header
{ (e.g., task end statistics).
{
{       SFP$INTERNAL_EMIT_STATISTIC (IDENTIFIER, STATISTIC_CODE,
{             DESCRIPTIVE_DATA, COUNTERS, GLOBAL_TASK_ID, STATUS)
{
{ IDENTIFIER: (input)  Specifies the two character product identifier for the
{       statistic.
{
{ STATISTIC_CODE: (input)  This parameter identifies the statistic which is to
{       be emitted.
{
{ DESCRIPTIVE_DATA: (input)  This parameter specifies the descriptive data to
{       be recorded with the statistic.
{
{ COUNTERS: (input)  This parameter contains an array of counters representing
{       reported values of system or job variables.
{
{ GLOBAL_TASK_ID: (input)  This parameter specifies the global task id that the
{       data on the statistic corresponds to.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{       CONDITIONS:
{             sfe$counter_array_size_range
{             sfe$descriptive_data_size
{             sfe$statistics_not_available
{
*DECK DECK=SFH$LOCK_JOB_ROUTING_CONTROL EXPAND=FALSE
{
{    This internal interface locks the job routing control information for the
{ specified statistic code and logs.
{
{       SFP$LOCK_JOB_ROUTING_CONTROL (STATISTIC_CODE, LOGS, STATUS)
{
{ STATISTIC_CODE: (input)  Specifies the statistic code whose routing controls
{       are to be locked.
{
{ LOGS: (input)  Specifies one or more logs that will be locked.  The specified
{       statistic will not be able to be activated to or deactived from these
{       logs.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$statistics_not_available
{
{
*DECK DECK=SFH$LOCK_STATISTIC EXPAND=FALSE
{
{    Locks the routing controls for the specified statistic and logs.
{
{       SFP$LOCK_JOB_STATISTIC (routing_control_table, statistic_code, logs,
{             routing_control_table_id, status)
{
{ STATISTIC_CODE: (input)  Specifies the statistic which will have its routing
{       controls locked.
{
{ LOGS: (input)  Specifies which logs are affected by the lock.
{
{ ROUTING_CONTROL_TABLE_ID: (input)  Specifies which routing control table
{       should be updated.
{
{ STATUS: (output) Variable in which the completion status is returned.
{       CONDITIONS:
{             sfe$statistics_not_availiable
{
*DECK DECK=SFH$LOCK_SYSTEM_ROUTING_CONTROL EXPAND=FALSE
{
{    This internal interface locks the system routing control information for
{ the specified statistic code and logs.
{
{       SFP$LOCK_SYSTEM_ROUTING_CONTROL (STATISTIC_CODE, LOGS, STATUS)
{
{ STATISTIC_CODE: (input)  Specifies the statistic code whose routing controls
{       are to be locked.
{
{ LOGS: (input)  Specifies one or more logs that will be locked.  The specified
{       statistic will not be able to be activated to or deactived from these
{       logs.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{         CONDITIONS: sfe$statistics_not_available
{
{
*DECK DECK=SFH$UPDATE_JOB_LIMIT_ACCUM EXPAND=FALSE
{
{    This procedure is used to update the accumulator for a limit.
{
{       SFP$UPDATE_JOB_LIMIT_ACCUM (LIMIT_NAME, UPDATE_VALUE, UPDATE_KIND,
{             STATUS);
{
{ LIMIT_NAME: (input)  Specifies the name of the limit to be updated.
{
{ UPDATE_VALUE: (input)  Specifies an increment to the accumulator or a new
{       value for the accumulator.
{
{ UPDATE_KIND: (input)  Specifies whether UPDATE_VALUE is to be added to the
{       current accumulator value or to replace the accumulator value.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{       CONDITIONS:
{             sfe$accumulator_overflow
{             sfe$job_maximum_limit_exceeded
{             sfe$job_warning_limit_exceeded
{             sfe$limit_not_activated
{             sfe$statistics_not_available
{             sfe$unknown_enforcement
{             sfe$unknown_update_kind
{
*DECK DECK=SFH$UPDATE_JOB_MAXIMUM_LIMIT EXPAND=FALSE
{
{    This procedure is used to update the job maximum limit for a limit.
{
{       SFP$UPDATE_JOB_MAXIMUM_LIMIT (LIMIT_NAME, MAXIMUM_LIMIT, STATUS);
{
{ LIMIT_NAME: (input)  Specifies the name of the limit to be updated.
{
{ MAXIMUM_LIMIT: (input)  Specifies the new maximum limit value for the limit.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{       CONDITIONS:
{             sfe$invalid_maximum_limit
{             sfe$limit_not_activated
{             sfe$statistics_not_available
{
*DECK DECK=SFH$UPDATE_JOB_WARNING_LIMIT EXPAND=FALSE
{
{    This procedure is used to update the job warning limit for a limit.
{
{       SFP$UPDATE_JOB_WARNING_LIMIT (LIMIT_NAME, WARNING_LIMIT, STATUS);
{
{ LIMIT_NAME: (input)  Specifies the name of the limit to be updated.
{
{ WARNING_LIMIT: (input)  Specifies the new warning limit value for the limit.
{
{ STATUS: (output) Variable in which the completion status is returned.
{
{       CONDITIONS:
{             sfe$invalid_warning_limit
{             sfe$limit_not_activated
{             sfe$statistics_not_available
{
*DECK DECK=SFM$COMMON_PROCESSORS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Logging: Common Processors' ??
MODULE sfm$common_processors;

{ PURPOSE:
{   This module contains common code used for both system and job routing control tables.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$mainframe_paged_literal
*copyc ost$heap
*copyc ost$name
*copyc ost$status
*copyc sfe$audit_control_locked
*copyc sfe$routing_control_locked
*copyc sft$audit_operation_descriptor
*copyc sft$audit_selection_criteria
*copyc sft$audited_operation_set
*copyc sft$audited_operation
*copyc sft$binary_logset
*copyc sft$routing_control_table
*copyc sft$statistic_code
?? POP ??
*copyc osp$set_status_condition
*copyc sfp$routing_control
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module.', EJECT ??
?? FMT (FORMAT := OFF) ??
  VAR
    sfv$audit_operation_descriptors: [XDCL, READ, #GATE, oss$mainframe_paged_literal]
          array [sft$audited_operation] of sft$audit_operation_descriptor := [
          [sfc$asc_fs_attach_file         , 'ATTF  '],
          [sfc$asc_fs_change_attribute    , 'CHAFA '],
          [sfc$asc_fs_change_name         , 'CHAON '],
          [sfc$asc_fs_create_object       , 'CREO  '],
          [sfc$asc_fs_create_permit       , 'CREP  '],
          [sfc$asc_fs_delete_object       , 'DELO  '],
          [sfc$asc_fs_delete_permit       , 'DELP  '],
          [sfc$asc_fs_load_fap            , 'LOAFAP'],
          [sfc$asc_fs_mount_magnetic_tape , 'MOUMT '],
          [sfc$asc_job_end                , '      '],
          [sfc$asc_job_execute_program    , 'EXEP  '],
          [sfc$asc_job_process_command    , 'PROC  '],
          [sfc$asc_job_user_identification, 'USERID'],
          [sfc$asc_val_activate_capability, 'ACTC  '],
          [sfc$asc_val_change_field       , 'CHAVF '],
          [sfc$asc_val_change_field_name  , 'CHAVFN'],
          [sfc$asc_val_change_record      , 'CHAVR '],
          [sfc$asc_val_change_security_pw , 'CHASPW'],
          [sfc$asc_val_create_field       , 'CREVF '],
          [sfc$asc_val_create_record      , 'CREVR '],
          [sfc$asc_val_deact_capability   , 'DEAC  '],
          [sfc$asc_val_delete_field       , 'DELVF '],
          [sfc$asc_val_delete_record      , 'DELVR '],
          [sfc$asc_val_force_security_pw  , 'FORSPW'],
          [sfc$asc_val_force_user_password, 'FORUPW'],
          [sfc$asc_val_prevalidate_user   , 'VALU  ']];
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$add_audit_control', EJECT ??

{ PURPOSE:
{   Adds audit control information to a routing control table.

  PROCEDURE [XDCL, #GATE] sfp$add_audit_control
    (    routing_control_table_p: sft$routing_control_table;
         operation_set: sft$audited_operation_set;
         selection_criteria: sft$audit_selection_criteria;
         lock: boolean;
         os_heap: ^ost$heap);

    VAR
      audit_control_p: ^sft$audit_control,
      operation: sft$audited_operation,
      routing_control_p: ^sft$routing_control;

    FOR operation := LOWERVALUE (operation) TO UPPERVALUE (operation) DO
      IF operation IN operation_set THEN

{ Get a pointer to the routing control entry for the statistic code associated with the audited operation.  If
{ necessary, the routing control table entry will be created.

        routing_control_p := sfp$routing_control (sfv$audit_operation_descriptors [operation].statistic_code,
              routing_control_table_p);
        IF routing_control_p = NIL THEN
          sfp$create_routing_control (routing_control_table_p,
                sfv$audit_operation_descriptors [operation].statistic_code, os_heap, routing_control_p);
        IFEND;

{ Allocate a new audit control entry.

        ALLOCATE audit_control_p: [1 .. UPPERBOUND (selection_criteria)] IN os_heap^;

{ Initialize the audit control entry.

        audit_control_p^.locked := lock;
        audit_control_p^.operation := operation;
        audit_control_p^.selection_criteria := selection_criteria;

{ Link the audit control entry into the list of audit control entries associated with this statistic code.

        audit_control_p^.forward := routing_control_p^.audit_control_p;
        routing_control_p^.audit_control_p := audit_control_p;
      IFEND;
    FOREND;

  PROCEND sfp$add_audit_control;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$add_routing_control', EJECT ??

{ PURPOSE:
{   Adds routing control information to a routing control table.

  PROCEDURE [XDCL, #GATE] sfp$add_routing_control
    (    routing_control_table_p: sft$routing_control_table;
         statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
         os_heap: ^ost$heap;
     VAR routing_control_p: ^sft$routing_control);

{ Find the entry in the routing control table for the specified statistic code.

    routing_control_p := sfp$routing_control (statistic_code, routing_control_table_p);
    IF routing_control_p = NIL THEN

{ The statistic code is not in the routing control table so add a new entry for it.

      sfp$create_routing_control (routing_control_table_p, statistic_code, os_heap, routing_control_p);
      routing_control_p^.activated_logs := logs;
    ELSE

{ The statistic code is already in the routing control table so add the specified logs
{ to the set of logs for this statistic (ignoring locked logs).

      routing_control_p^.activated_logs := routing_control_p^.activated_logs +
            (logs - routing_control_p^.locked_logs);
    IFEND;

  PROCEND sfp$add_routing_control;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$create_routing_control', EJECT ??

{ PURPOSE:
{   Allocates and initializes a new routing control table entry for the specified statistic code.

  PROCEDURE [XDCL, #GATE] sfp$create_routing_control
    (    routing_control_table_p: sft$routing_control_table;
         statistic_code: sft$statistic_code;
         os_heap: ^ost$heap;
     VAR routing_control_p: ^sft$routing_control);

    VAR
      index: 0 .. sfc$routing_control_table_size;

{ Allocate space for the routing control table entry.

    ALLOCATE routing_control_p IN os_heap^;
    routing_control_p^.statistic_code := statistic_code;
    routing_control_p^.activated_logs := $sft$binary_logset [];
    routing_control_p^.locked_logs := $sft$binary_logset [];
    routing_control_p^.limit_name := osc$null_name;
    routing_control_p^.audit_control_p := NIL;

{ Insert it as the first entry for this particular hash into the routing control table.

    index := statistic_code MOD sfc$routing_control_table_size;
    routing_control_p^.forward := routing_control_table_p^ [index];
    routing_control_table_p^ [index] := routing_control_p;

  PROCEND sfp$create_routing_control;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$delete_audit_control', EJECT ??

{ PURPOSE:
{   Deletes all unlocked audit controls for the specified operations from a routing control table.

  PROCEDURE [XDCL, #GATE] sfp$delete_audit_control
    (    routing_control_table_p: sft$routing_control_table;
         operation_set: sft$audited_operation_set;
         os_heap: ^ost$heap;
     VAR status: ost$status);

    VAR
      audit_control_p: ^sft$audit_control,
      operation: sft$audited_operation,
      routing_control_p: ^sft$routing_control,
      temp_audit_control_p: ^sft$audit_control;

    status.normal := TRUE;

  /process_operations/
    FOR operation := LOWERVALUE (operation) TO UPPERVALUE (operation) DO
      IF operation IN operation_set THEN

{ Get a pointer to the routing control entry for the statistic code associated with the audited operation.  If
{ no routing control entry exists or the audit control pointer is nil, there are no audit controls for the
{ operation.

        routing_control_p := sfp$routing_control (sfv$audit_operation_descriptors [operation].statistic_code,
              routing_control_table_p);
        IF (routing_control_p <> NIL) AND (routing_control_p^.audit_control_p <> NIL) THEN

{ Starting with the second audit control, delete any that are not locked.

          audit_control_p := routing_control_p^.audit_control_p;
          WHILE audit_control_p^.forward <> NIL DO
            IF NOT audit_control_p^.forward^.locked THEN
              temp_audit_control_p := audit_control_p^.forward;
              audit_control_p^.forward := audit_control_p^.forward^.forward;
              FREE temp_audit_control_p IN os_heap^;
            ELSE
              osp$set_status_condition (sfe$audit_control_locked, status);
              audit_control_p := audit_control_p^.forward;
            IFEND;
          WHILEND;

{ Remove the first audit control if it is not locked.

          IF NOT routing_control_p^.audit_control_p^.locked THEN
            temp_audit_control_p := routing_control_p^.audit_control_p;
            routing_control_p^.audit_control_p := routing_control_p^.audit_control_p^.forward;
            FREE temp_audit_control_p IN os_heap^;
          ELSE
            osp$set_status_condition (sfe$audit_control_locked, status);
          IFEND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND sfp$delete_audit_control;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$delete_routing_control', EJECT ??

{ PURPOSE:
{   Deletes unlocked routing control information for the specified statistic and logs.

  PROCEDURE [XDCL, #GATE] sfp$delete_routing_control
    (    routing_control_table_p: sft$routing_control_table;
         statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

    VAR
      routing_control_p: ^sft$routing_control;

    status.normal := TRUE;

{ Find the entry in the routing control table for the specified statistic code and remove the specified logs
{ (ignoring locked logs) from the set of activated logs.

    routing_control_p := sfp$routing_control (statistic_code, routing_control_table_p);
    IF routing_control_p <> NIL THEN
      routing_control_p^.activated_logs := routing_control_p^.activated_logs -
            (logs - routing_control_p^.locked_logs);

{ If any of the routing controls were not deleted because they were locked, return a warning error.

      IF (routing_control_p^.activated_logs * logs) <> $sft$binary_logset[] THEN
        osp$set_status_condition (sfe$routing_control_locked, status);
      IFEND;
    IFEND;

  PROCEND sfp$delete_routing_control;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$lock_routing_control', EJECT ??

{ PURPOSE:
{   Locks the routing controls for the specified statistic and logs.

  PROCEDURE [XDCL, #GATE] sfp$lock_routing_control
    (    routing_control_table_p: sft$routing_control_table;
         statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
         os_heap: ^ost$heap);

    VAR
      routing_control_p: ^sft$routing_control;

{ Find the entry in the routing control table for the specified statistic code and add the specified logs
{ to the set of locked logs.  If a routing control table entry does not exist for the statistic, one will be
{ created.

    routing_control_p := sfp$routing_control (statistic_code, routing_control_table_p);
    IF routing_control_p = NIL THEN
      sfp$create_routing_control (routing_control_table_p, statistic_code, os_heap, routing_control_p);
    IFEND;
    routing_control_p^.locked_logs := routing_control_p^.locked_logs + logs;

  PROCEND sfp$lock_routing_control;
?? OLDTITLE ??
MODEND sfm$common_processors;

*DECK DECK=SFM$EMIT_AUDIT_STATISTIC EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Logging: Emit Audit Statistic' ??
MODULE sfm$emit_audit_statistic;

{ PURPOSE:
{   This module contains the code reponsible for recording audit statistics in the security log.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$system_family
*copyc lgc$maximum_log_entry_size
*copyc oss$job_paged_literal
*copyc ost$status
*copyc sfe$too_much_data_for_statistic
*copyc sfe$unknown_audit_operation
*copyc sft$audit_operation_descriptor
*copyc sft$audit_information
*copyc sft$audited_operation
*copyc sft$routing_control_table_id
*copyc sft$statistic_header
?? POP ??
*copyc avp$security_option_active
*copyc clp$convert_integer_to_string
*copyc clp$trimmed_string_size
*copyc lgp$add_entry_global_binary_log
*copyc osp$append_status_integer
*copyc osp$generate_log_message
*copyc osp$get_status_condition_name
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$verify_system_privilege
*copyc pfp$convert_pf_path_to_fs_path
*copyc pfp$convert_pft$path_to_fs_path
*copyc pmp$get_executing_task_gtid
*copyc sfp$build_statistic
*copyc sfp$convert_stat_code_to_name
*copyc sfp$routing_control
*copyc avv$field_kind_names
*copyc sfv$audit_operation_descriptors
*copyc sfv$job_routing_control_table
*copyc sfv$sys_routing_control_table
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    sft$format_desc_data_proc = ^procedure
           (    audit_information: sft$audit_information;
                operation_status: ost$status;
            VAR descriptive_data: string ( * );
            VAR descriptive_data_size: integer);

?? FMT (FORMAT := OFF) ??
  VAR
    format_descriptive_data_procs: [STATIC, READ, oss$job_paged_literal] array [sft$audited_operation] of
          sft$format_desc_data_proc := [
         {sfc$ao_fs_attach_file         } ^ format_attach_file_desc_data,
         {sfc$ao_fs_change_attribute    } ^ format_chg_fs_obj_att_desc_data,
         {sfc$ao_fs_change_name         } ^ fmt_chg_fs_obj_name_desc_data,
         {sfc$ao_fs_create_object       } ^ format_cre_fs_object_desc_data,
         {sfc$ao_fs_create_permit       } ^ format_cre_fs_permit_desc_data,
         {sfc$ao_fs_delete_object       } ^ format_del_fs_object_desc_data,
         {sfc$ao_fs_delete_permit       } ^ format_del_fs_permit_desc_data,
         {sfc$ao_fs_load_fap            } ^ format_load_fap_desc_data,
         {sfc$ao_fs_mount_magnetic_tape } ^ format_mount_mag_tape_desc_data,
         {sfc$ao_job_end                } NIL,
         {sfc$ao_job_execute_program    } ^ format_exec_program_desc_data,
         {sfc$ao_job_process_command    } ^ format_process_cmd_desc_data,
         {sfc$ao_job_user_identification} ^ format_user_id_desc_data,
         {sfc$ao_val_activate_capability} ^ fmt_cond_capability_desc_data,
         {sfc$ao_val_change_field       } ^ format_chg_val_field_desc_data,
         {sfc$ao_val_change_field_name  } ^ format_chg_field_name_desc_data,
         {sfc$ao_val_change_record      } ^ format_chg_val_record_desc_data,
         {sfc$ao_val_change_security_pw } ^ format_security_pw_desc_data,
         {sfc$ao_val_create_field       } ^ format_cre_val_field_desc_data,
         {sfc$ao_val_create_record      } ^ format_cre_val_record_desc_data,
         {sfc$ao_val_deact_capability   } ^ fmt_cond_capability_desc_data,
         {sfc$ao_val_delete_field       } ^ format_del_val_field_desc_data,
         {sfc$ao_val_delete_record      } ^ format_del_val_record_desc_data,
         {sfc$ao_val_force_security_pw  } ^ format_security_pw_desc_data,
         {sfc$ao_val_force_user_password} ^ format_force_user_pw_desc_data,
         {sfc$ao_val_prevalidate_user   } ^ format_preval_user_desc_data];
?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
?? NEWTITLE := 'append_attach_access_mode', EJECT ??

{ PURPOSE:
{   Appends the attach access modes to the audit statistic descriptive data.

  PROCEDURE append_attach_access_mode
    (    access_mode_p: ^pft$usage_selections;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put in the delimiter.

    descriptive_data (descriptive_data_size + 1, 2) := ',';
    descriptive_data_size := descriptive_data_size + 1;

    IF access_mode_p <> NIL THEN
      descriptive_data (descriptive_data_size + 1, 1) := '(';
      descriptive_data_size := descriptive_data_size + 1;
      IF pfc$read IN access_mode_p^ THEN
        descriptive_data (descriptive_data_size + 1, 1) := 'R';
      ELSE
        descriptive_data (descriptive_data_size + 1, 1) := ' ';
      IFEND;
      descriptive_data_size := descriptive_data_size + 1;
      IF ($pft$usage_selections [pfc$append, pfc$modify, pfc$shorten] * access_mode_p^) <>
            $pft$usage_selections [] THEN
        descriptive_data (descriptive_data_size + 1, 1) := 'W';
      ELSE
        descriptive_data (descriptive_data_size + 1, 1) := ' ';
      IFEND;
      descriptive_data_size := descriptive_data_size + 1;
      IF pfc$execute IN access_mode_p^ THEN
        descriptive_data (descriptive_data_size + 1, 1) := 'E';
      ELSE
        descriptive_data (descriptive_data_size + 1, 1) := ' ';
      IFEND;
      descriptive_data_size := descriptive_data_size + 1;
      IF pfc$shorten IN access_mode_p^ THEN
        descriptive_data (descriptive_data_size + 1, 1) := 'S';
      ELSE
        descriptive_data (descriptive_data_size + 1, 1) := ' ';
      IFEND;
      descriptive_data_size := descriptive_data_size + 1;
      IF pfc$append IN access_mode_p^ THEN
        descriptive_data (descriptive_data_size + 1, 1) := 'A';
      ELSE
        descriptive_data (descriptive_data_size + 1, 1) := ' ';
      IFEND;
      descriptive_data_size := descriptive_data_size + 1;
      IF pfc$modify IN access_mode_p^ THEN
        descriptive_data (descriptive_data_size + 1, 1) := 'M';
      ELSE
        descriptive_data (descriptive_data_size + 1, 1) := ' ';
      IFEND;
      descriptive_data_size := descriptive_data_size + 1;
      descriptive_data (descriptive_data_size + 1, 1) := ')';
      descriptive_data_size := descriptive_data_size + 1;
    IFEND;

  PROCEND append_attach_access_mode;
?? OLDTITLE ??
?? NEWTITLE := 'append_boolean', EJECT ??

{ PURPOSE:
{   Appends a boolean to the audit statistic descriptive data.

  PROCEDURE append_boolean
    (    boolean_value: boolean;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put in the delimiter.

    descriptive_data (descriptive_data_size + 1, 2) := ',';
    descriptive_data_size := descriptive_data_size + 1;

{ Append the boolean value.

    IF boolean_value THEN
      descriptive_data (descriptive_data_size + 1, * ) := 'TRUE';
      descriptive_data_size := descriptive_data_size + 4;
    ELSE
      descriptive_data (descriptive_data_size + 1, * ) := 'FALSE';
      descriptive_data_size := descriptive_data_size + 5;
    IFEND;

  PROCEND append_boolean;
?? OLDTITLE ??
?? NEWTITLE := 'append_cycle_number', EJECT ??

{ PURPOSE:
{   Appends a cycle number to the audit statistic descriptive data.

  PROCEDURE append_cycle_number
    (    cycle_number: pft$cycle_number;
     VAR descriptive_data: {i/o} string ( * );
     VAR descriptive_data_size: {i/o} integer);

    VAR
      cycle_string: ost$string,
      local_status: ost$status;

{ Put in the delimiter.

    descriptive_data (descriptive_data_size + 1, 2) := ',';
    descriptive_data_size := descriptive_data_size + 1;

{ Append the cycle number.

    clp$convert_integer_to_string (cycle_number, 10, FALSE, cycle_string, local_status);
    IF local_status.normal THEN
      descriptive_data (descriptive_data_size + 1, * ) := cycle_string.value (1, cycle_string.size);
      descriptive_data_size := descriptive_data_size + cycle_string.size;
    IFEND;

  PROCEND append_cycle_number;
?? OLDTITLE ??
?? NEWTITLE := 'append_file_reference', EJECT ??

{ PURPOSE:
{   Appends a file reference to the audit statistic descriptive data.

  PROCEDURE append_file_reference
    (    file_reference_p: ^fst$file_reference;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put in the delimiter.

    descriptive_data (descriptive_data_size + 1, 2) := ',';
    descriptive_data_size := descriptive_data_size + 1;

{ Append the file reference if it is available.

    IF file_reference_p <> NIL THEN
      descriptive_data (descriptive_data_size + 1, * ) := file_reference_p^;
      descriptive_data_size := descriptive_data_size + clp$trimmed_string_size (file_reference_p^);
    IFEND;

  PROCEND append_file_reference;
?? OLDTITLE ??
?? NEWTITLE := 'append_file_system_object_id', EJECT ??

{ PURPOSE:
{   Appends the file system object identification to the descriptive data.

  PROCEDURE append_file_system_object_id
    (    object_id_p: ^sft$audited_fs_object_id;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

    VAR
      cycle_string: ost$string,
      device_classes: [STATIC, READ, oss$job_paged_literal] array [rmt$device_class] of
            ost$name := ['CONNECTED_FILE                 ', 'INTERSTATE_LINK                ',
            'LOCAL_QUEUE                    ', 'LOG                            ',
            'MAGNETIC_TAPE                  ', 'MASS_STORAGE                   ',
            'MEMORY_RESIDENT                ', 'NETWORK                        ',
            'NULL                           ', 'PIPELINE                       ',
            'RHFAM                          ', 'TERMINAL                       '],
      path: fst$path,
      path_size: fst$path_size,
      local_status: ost$status,
      object_types: [STATIC, READ, oss$job_paged_literal] array [sft$audited_fs_object_type] of
            ost$name := ['CATALOG                        ', 'FILE                           ',
            'CYCLE                          '];

{ Put in a delimiter.

    descriptive_data (descriptive_data_size + 1, 2) := ',';
    descriptive_data_size := descriptive_data_size + 1;

{ Append the file reference (including a cycle reference) if it is available.

    IF object_id_p <> NIL THEN
      IF object_id_p^.variant_path.complete_path THEN
        IF object_id_p^.variant_path.p_complete_path <> NIL THEN
          pfp$convert_pf_path_to_fs_path (object_id_p^.variant_path.p_complete_path^, path, path_size);
          descriptive_data (descriptive_data_size + 1, * ) := path (1, path_size);
          descriptive_data_size := descriptive_data_size + path_size;
        IFEND;
      ELSEIF object_id_p^.variant_path.p_path <> NIL THEN
        pfp$convert_pft$path_to_fs_path (object_id_p^.variant_path.p_path^, path, path_size);
        descriptive_data (descriptive_data_size + 1, * ) := path (1, path_size);
        descriptive_data_size := descriptive_data_size + path_size;
      IFEND;

      IF (object_id_p^.object_type = sfc$afsot_cycle) THEN
        IF (object_id_p^.cycle_selector_p <> NIL) THEN
          CASE object_id_p^.cycle_selector_p^.cycle_option OF
          = pfc$lowest_cycle =
            descriptive_data (descriptive_data_size + 1, * ) := '.$LOW';
            descriptive_data_size := descriptive_data_size + 5;
          = pfc$highest_cycle =
            descriptive_data (descriptive_data_size + 1, * ) := '.$HIGH';
            descriptive_data_size := descriptive_data_size + 6;
          ELSE
            clp$convert_integer_to_string (object_id_p^.cycle_selector_p^.cycle_number, 10, FALSE,
                  cycle_string, local_status);
            IF local_status.normal THEN
              descriptive_data (descriptive_data_size + 1, * ) := '.';
              descriptive_data (descriptive_data_size + 2, * ) := cycle_string.value (1, cycle_string.size);
              descriptive_data_size := descriptive_data_size + cycle_string.size + 1;
            IFEND;
          CASEND;
        IFEND;
      IFEND;
    IFEND;

{ Put in a delimiter.

    descriptive_data (descriptive_data_size + 1, 2) := ',';
    descriptive_data_size := descriptive_data_size + 1;

{ Append the object type.

    IF object_id_p <> NIL THEN
      IF (object_id_p^.object_type >= LOWERVALUE (sft$audited_fs_object_type)) OR
            (object_id_p^.object_type <= UPPERVALUE (sft$audited_fs_object_type)) THEN
        descriptive_data (descriptive_data_size + 1, * ) := object_types [object_id_p^.object_type];
        descriptive_data_size := descriptive_data_size + clp$trimmed_string_size
              (object_types [object_id_p^.object_type]);
      IFEND;
    IFEND;

{ Put in a delimiter.

    descriptive_data (descriptive_data_size + 1, 2) := ',';
    descriptive_data_size := descriptive_data_size + 1;

{ Append the object type.

    IF (object_id_p <> NIL) AND (object_id_p^.object_type = sfc$afsot_cycle) THEN
      descriptive_data (descriptive_data_size + 1, * ) := device_classes [object_id_p^.device_class];
      descriptive_data_size := descriptive_data_size + clp$trimmed_string_size
            (device_classes [object_id_p^.device_class]);
    IFEND;

  PROCEND append_file_system_object_id;
?? OLDTITLE ??
?? NEWTITLE := 'append_name', EJECT ??

{ PURPOSE:
{   Appends a name to the audit statistic descriptive data.

  PROCEDURE append_name
    (    name_p: ^string ( * <= osc$max_name_size);
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put in the delimiter.

    descriptive_data (descriptive_data_size + 1, 2) := ',';
    descriptive_data_size := descriptive_data_size + 1;

{ Append the name if it is available.

    IF name_p <> NIL THEN
      descriptive_data (descriptive_data_size + 1, * ) := name_p^;
      descriptive_data_size := descriptive_data_size + clp$trimmed_string_size (name_p^);
    IFEND;

  PROCEND append_name;
?? OLDTITLE ??
?? NEWTITLE := 'append_operation_status', EJECT ??

{ PURPOSE:
{   Appends the operation status information to the audit statistic descriptive data.

  PROCEDURE append_operation_status
    (    operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

    VAR
      condition_name: ost$name,
      ignore_status: ost$status;

{ Put in the delimiter.

    descriptive_data (descriptive_data_size + 1, 2) := ',';
    descriptive_data_size := descriptive_data_size + 1;

{ If the operation was not successful, append the status condition name.

    IF NOT operation_status.normal THEN
      osp$get_status_condition_name (operation_status.condition, condition_name, ignore_status);
      descriptive_data (descriptive_data_size + 1, * ) := condition_name;
      descriptive_data_size := descriptive_data_size + clp$trimmed_string_size (condition_name);
    IFEND;

  PROCEND append_operation_status;
?? OLDTITLE ??
?? NEWTITLE := 'append_permit_access_mode', EJECT ??

{ PURPOSE:
{   Appends the permit access modes to the audit statistic descriptive data.

  PROCEDURE append_permit_access_mode
    (    permit_selections_p: ^pft$permit_selections;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put in the delimiter.

    descriptive_data (descriptive_data_size + 1, 2) := ',';
    descriptive_data_size := descriptive_data_size + 1;

{ Append the group name.

    IF permit_selections_p <> NIL THEN
      descriptive_data (descriptive_data_size + 1, 1) := '(';
      descriptive_data_size := descriptive_data_size + 1;
      IF pfc$read IN permit_selections_p^ THEN
        descriptive_data (descriptive_data_size + 1, 1) := 'R';
      ELSE
        descriptive_data (descriptive_data_size + 1, 1) := ' ';
      IFEND;
      descriptive_data_size := descriptive_data_size + 1;
      IF ($pft$permit_selections [pfc$append, pfc$modify, pfc$shorten] * permit_selections_p^) <>
            $pft$permit_selections [] THEN
        descriptive_data (descriptive_data_size + 1, 1) := 'W';
      ELSE
        descriptive_data (descriptive_data_size + 1, 1) := ' ';
      IFEND;
      descriptive_data_size := descriptive_data_size + 1;
      IF pfc$execute IN permit_selections_p^ THEN
        descriptive_data (descriptive_data_size + 1, 1) := 'E';
      ELSE
        descriptive_data (descriptive_data_size + 1, 1) := ' ';
      IFEND;
      descriptive_data_size := descriptive_data_size + 1;
      IF pfc$shorten IN permit_selections_p^ THEN
        descriptive_data (descriptive_data_size + 1, 1) := 'S';
      ELSE
        descriptive_data (descriptive_data_size + 1, 1) := ' ';
      IFEND;
      descriptive_data_size := descriptive_data_size + 1;
      IF pfc$append IN permit_selections_p^ THEN
        descriptive_data (descriptive_data_size + 1, 1) := 'A';
      ELSE
        descriptive_data (descriptive_data_size + 1, 1) := ' ';
      IFEND;
      descriptive_data_size := descriptive_data_size + 1;
      IF pfc$modify IN permit_selections_p^ THEN
        descriptive_data (descriptive_data_size + 1, 1) := 'M';
      ELSE
        descriptive_data (descriptive_data_size + 1, 1) := ' ';
      IFEND;
      descriptive_data_size := descriptive_data_size + 1;
      IF pfc$cycle IN permit_selections_p^ THEN
        descriptive_data (descriptive_data_size + 1, 1) := 'C';
      ELSE
        descriptive_data (descriptive_data_size + 1, 1) := ' ';
      IFEND;
      descriptive_data_size := descriptive_data_size + 1;
      IF pfc$control IN permit_selections_p^ THEN
        descriptive_data (descriptive_data_size + 1, 1) := 'C';
      ELSE
        descriptive_data (descriptive_data_size + 1, 1) := ' ';
      IFEND;
      descriptive_data_size := descriptive_data_size + 1;
      descriptive_data (descriptive_data_size + 1, 1) := ')';
      descriptive_data_size := descriptive_data_size + 1;
    IFEND;

  PROCEND append_permit_access_mode;
?? OLDTITLE ??
?? NEWTITLE := 'append_permit_group', EJECT ??

{ PURPOSE:
{   Appends a permit group to the audit statistic descriptive data.

  PROCEDURE append_permit_group
    (    group_p: ^pft$group;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

    VAR
      group_names: [STATIC, READ, oss$job_paged_literal] array [pft$group_types] of
            ost$name := ['PUBLIC                         ', 'FAMILY                         ',
            'ACCOUNT                        ', 'PROJECT                        ',
            'USER                           ', 'ACCOUNT_MEMBER                 ',
            'PROJECT_MEMBER                 '],
      null_name: [STATIC, READ, oss$job_paged_literal] ost$name := osc$null_name;

{ Append the group name.

    IF group_p <> NIL THEN
      append_name (^group_names [group_p^.group_type], descriptive_data, descriptive_data_size);

{ Append group identification.

      CASE group_p^.group_type OF
      = pfc$public =
        append_name (^null_name, descriptive_data, descriptive_data_size);
        append_name (^null_name, descriptive_data, descriptive_data_size);
        append_name (^null_name, descriptive_data, descriptive_data_size);
        append_name (^null_name, descriptive_data, descriptive_data_size);
      = pfc$family =
        append_name (^group_p^.family_description.family, descriptive_data, descriptive_data_size);
        append_name (^null_name, descriptive_data, descriptive_data_size);
        append_name (^null_name, descriptive_data, descriptive_data_size);
        append_name (^null_name, descriptive_data, descriptive_data_size);
      = pfc$account =
        append_name (^group_p^.account_description.family, descriptive_data, descriptive_data_size);
        append_name (^null_name, descriptive_data, descriptive_data_size);
        append_name (^group_p^.account_description.account, descriptive_data, descriptive_data_size);
        append_name (^null_name, descriptive_data, descriptive_data_size);
      = pfc$project =
        append_name (^group_p^.project_description.family, descriptive_data, descriptive_data_size);
        append_name (^null_name, descriptive_data, descriptive_data_size);
        append_name (^group_p^.project_description.account, descriptive_data, descriptive_data_size);
        append_name (^group_p^.project_description.project, descriptive_data, descriptive_data_size);
      = pfc$user =
        append_name (^group_p^.user_description.family, descriptive_data, descriptive_data_size);
        append_name (^group_p^.user_description.user, descriptive_data, descriptive_data_size);
        append_name (^null_name, descriptive_data, descriptive_data_size);
        append_name (^null_name, descriptive_data, descriptive_data_size);
      = pfc$user_account =
        append_name (^group_p^.user_account_description.family, descriptive_data, descriptive_data_size);
        append_name (^group_p^.user_account_description.user, descriptive_data, descriptive_data_size);
        append_name (^group_p^.user_account_description.account, descriptive_data, descriptive_data_size);
        append_name (^null_name, descriptive_data, descriptive_data_size);
      ELSE {pfc$member}
        append_name (^group_p^.member_description.family, descriptive_data, descriptive_data_size);
        append_name (^group_p^.member_description.user, descriptive_data, descriptive_data_size);
        append_name (^group_p^.member_description.account, descriptive_data, descriptive_data_size);
        append_name (^group_p^.member_description.project, descriptive_data, descriptive_data_size);
      CASEND;
    ELSE
      append_name (^null_name, descriptive_data, descriptive_data_size);
      append_name (^null_name, descriptive_data, descriptive_data_size);
      append_name (^null_name, descriptive_data, descriptive_data_size);
      append_name (^null_name, descriptive_data, descriptive_data_size);
      append_name (^null_name, descriptive_data, descriptive_data_size);
    IFEND;

  PROCEND append_permit_group;
?? OLDTITLE ??
?? NEWTITLE := 'append_ring', EJECT ??

{ PURPOSE:
{   Appends a ring number to the audit statistic descriptive data.

  PROCEDURE append_ring
    (    ring: ost$ring;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

    VAR
      local_status: ost$status,
      ring_string: ost$string;

{ Put in the delimiter.

    descriptive_data (descriptive_data_size + 1, 2) := ',';
    descriptive_data_size := descriptive_data_size + 1;

{ Append the ring.

    clp$convert_integer_to_string (ring, 10, FALSE, ring_string, local_status);
    IF local_status.normal THEN
      descriptive_data (descriptive_data_size + 1, * ) := ring_string.value (1, ring_string.size);
      descriptive_data_size := descriptive_data_size + ring_string.size;
    IFEND;

  PROCEND append_ring;
?? OLDTITLE ??
?? NEWTITLE := 'append_ring_attributes', EJECT ??

{ PURPOSE:
{   Appends ring attributes to the audit statistic descriptive data.

  PROCEDURE append_ring_attributes
    (    ring_attributes_p: ^amt$ring_attributes;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

    VAR
      local_status: ost$status,
      ring_string: ost$string;

{ Put in the delimiter.

    descriptive_data (descriptive_data_size + 1, 2) := ',';
    descriptive_data_size := descriptive_data_size + 1;

{ Append the ring attributes.

    IF ring_attributes_p <> NIL THEN
      descriptive_data (descriptive_data_size + 1, 1) := '(';
      descriptive_data_size := descriptive_data_size + 1;
      clp$convert_integer_to_string (ring_attributes_p^.r1, 10, FALSE, ring_string, local_status);
      IF local_status.normal THEN
        descriptive_data (descriptive_data_size + 1, * ) := ring_string.value (1, ring_string.size);
        descriptive_data_size := descriptive_data_size + ring_string.size;
      IFEND;
      descriptive_data (descriptive_data_size + 1, 1) := ' ';
      descriptive_data_size := descriptive_data_size + 1;
      clp$convert_integer_to_string (ring_attributes_p^.r2, 10, FALSE, ring_string, local_status);
      IF local_status.normal THEN
        descriptive_data (descriptive_data_size + 1, * ) := ring_string.value (1, ring_string.size);
        descriptive_data_size := descriptive_data_size + ring_string.size;
      IFEND;
      descriptive_data (descriptive_data_size + 1, 1) := ' ';
      descriptive_data_size := descriptive_data_size + 1;
      clp$convert_integer_to_string (ring_attributes_p^.r3, 10, FALSE, ring_string, local_status);
      IF local_status.normal THEN
        descriptive_data (descriptive_data_size + 1, * ) := ring_string.value (1, ring_string.size);
        descriptive_data_size := descriptive_data_size + ring_string.size;
      IFEND;
      descriptive_data (descriptive_data_size + 1, 1) := ')';
      descriptive_data_size := descriptive_data_size + 1;
    IFEND;

  PROCEND append_ring_attributes;
?? OLDTITLE ??
?? NEWTITLE := 'check_audit_controls', EJECT ??

{ PURPOSE:
{   Determines if the audit information satisfies any of the audit controls in the specified routing control
{   table.

  PROCEDURE check_audit_controls
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
         routing_control_table_id: sft$routing_control_table_id;
     VAR emit_statistic: boolean);

    VAR
      current_audit_control_p: ^sft$audit_control,
      ownership: pft$ownership,
      routing_control_p: ^sft$routing_control,
      selection_index: integer,
      variant_path_p: ^pft$variant_path;

{ Get a pointer to the routing control entry for the statistic that corresponds to the audited operation.

    routing_control_p := NIL;
    IF routing_control_table_id = sfc$sys_routing_control_table THEN
      IF sfv$sys_routing_control_table <> NIL THEN
        routing_control_p := sfp$routing_control (sfv$audit_operation_descriptors
              [audit_information.audited_operation].statistic_code, sfv$sys_routing_control_table);
      IFEND;
    ELSE
      IF sfv$job_routing_control_table <> NIL THEN
        routing_control_p := sfp$routing_control (sfv$audit_operation_descriptors
              [audit_information.audited_operation].statistic_code, sfv$job_routing_control_table);
      IFEND;
    IFEND;
    IF routing_control_p = NIL THEN
      emit_statistic := FALSE;
      RETURN;
    IFEND;

{ If the statistic has been activated to the security log, emit it without regard to selection criteria.

    IF pmc$security_log IN routing_control_p^.activated_logs THEN
      emit_statistic := TRUE;
      RETURN;
    IFEND;

{ Check the audit controls (if any).

    emit_statistic := FALSE;
    current_audit_control_p := routing_control_p^.audit_control_p;

  /scan_audit_controls/
    WHILE (current_audit_control_p <> NIL) AND (NOT emit_statistic) DO
      FOR selection_index := LOWERBOUND (current_audit_control_p^.selection_criteria)
            TO UPPERBOUND (current_audit_control_p^.selection_criteria) DO
        CASE current_audit_control_p^.selection_criteria [selection_index].selector OF
        = sfc$as_operation_result_set =
          IF operation_status.normal THEN
            IF NOT (sfc$or_successful IN current_audit_control_p^.selection_criteria [selection_index].
                  operation_result_set) THEN
              current_audit_control_p := current_audit_control_p^.forward;
              CYCLE /scan_audit_controls/;
            IFEND;
          ELSE
            IF NOT (sfc$or_unsuccessful IN current_audit_control_p^.selection_criteria [selection_index].
                  operation_result_set) THEN
              current_audit_control_p := current_audit_control_p^.forward;
              CYCLE /scan_audit_controls/;
            IFEND;
          IFEND;

        = sfc$as_access_mode_set =
          IF audit_information.audited_operation = sfc$ao_fs_attach_file THEN
            IF (audit_information.attach_file.access_mode_p <> NIL) AND
                  (audit_information.attach_file.access_mode_p^ * current_audit_control_p^.selection_criteria
                  [selection_index].access_mode_set = $pft$usage_selections []) THEN
              current_audit_control_p := current_audit_control_p^.forward;
              CYCLE /scan_audit_controls/;
            IFEND;
          IFEND;

        = sfc$as_null_selector =
          { Do nothing.

        = sfc$as_command_source_set =
          IF audit_information.audited_operation = sfc$ao_job_process_command THEN
            IF NOT (audit_information.process_command.command_source IN
                  current_audit_control_p^.selection_criteria [selection_index].command_source_set) THEN
              current_audit_control_p := current_audit_control_p^.forward;
              CYCLE /scan_audit_controls/;
            IFEND;
          IFEND;

        = sfc$as_catalog_owner_set =
          variant_path_p := NIL;

          CASE audit_information.audited_operation OF
          = sfc$ao_fs_attach_file =
            variant_path_p := ^audit_information.attach_file.object_id_p^.variant_path;
            ownership := audit_information.attach_file.ownership;
          = sfc$ao_fs_change_attribute =
            variant_path_p := ^audit_information.change_fs_object_attribute.object_id_p^.variant_path;
            ownership := audit_information.change_fs_object_attribute.ownership;
          = sfc$ao_fs_change_name =
            variant_path_p := ^audit_information.change_fs_object_name.object_id_p^.variant_path;
            ownership := audit_information.change_fs_object_name.ownership;
          = sfc$ao_fs_create_object =
            variant_path_p := ^audit_information.create_fs_object.object_id_p^.variant_path;
            ownership := audit_information.create_fs_object.ownership;
          = sfc$ao_fs_create_permit =
            variant_path_p := ^audit_information.create_fs_permit.object_id_p^.variant_path;
            ownership := audit_information.create_fs_permit.ownership;
          = sfc$ao_fs_delete_object =
            variant_path_p := ^audit_information.delete_fs_object.object_id_p^.variant_path;
            ownership := audit_information.delete_fs_object.ownership;
          = sfc$ao_fs_delete_permit =
            variant_path_p := ^audit_information.create_fs_permit.object_id_p^.variant_path;
            ownership := audit_information.create_fs_permit.ownership;
          ELSE
            { Do nothing.
          CASEND;

          IF variant_path_p <> NIL THEN
            IF pfc$master_catalog_owner IN ownership THEN
              IF NOT (sfc$co_owner IN current_audit_control_p^.selection_criteria [selection_index].
                    catalog_owner_set) THEN
                current_audit_control_p := current_audit_control_p^.forward;
                CYCLE /scan_audit_controls/;
              IFEND;
            ELSEIF (variant_path_p^.complete_path AND
                  (variant_path_p^.p_complete_path^ [pfc$master_catalog_path_index] = jmc$system_user)) OR
                  ((NOT variant_path_p^.complete_path) AND
                  (variant_path_p^.p_path^ [pfc$master_catalog_name_index] = jmc$system_user)) THEN
              IF NOT (sfc$co_system IN current_audit_control_p^.selection_criteria [selection_index].
                    catalog_owner_set) THEN
                current_audit_control_p := current_audit_control_p^.forward;
                CYCLE /scan_audit_controls/;
              IFEND;
            ELSE
              IF NOT (sfc$co_non_owner IN current_audit_control_p^.selection_criteria [selection_index].
                    catalog_owner_set) THEN
                current_audit_control_p := current_audit_control_p^.forward;
                CYCLE /scan_audit_controls/;
              IFEND;
            IFEND;
          IFEND;

        ELSE
          ;
        CASEND;
      FOREND;

      emit_statistic := TRUE;
    WHILEND /scan_audit_controls/;

  PROCEND check_audit_controls;
?? OLDTITLE ??
?? NEWTITLE := 'fmt_cond_capability_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the activate and deactivate conditional capability
{  audit statistics.

  PROCEDURE fmt_cond_capability_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the capability name in the descriptive data.

    IF audit_information.audited_operation = sfc$ao_val_activate_capability THEN
      append_name (audit_information.activate_capability.field_name_p, descriptive_data,
            descriptive_data_size);
    ELSE
      append_name (audit_information.deactivate_capability.field_name_p, descriptive_data,
            descriptive_data_size);
    IFEND;

  PROCEND fmt_cond_capability_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_attach_file_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the attach file audit statistic.

  PROCEDURE format_attach_file_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the file system object id in the descriptive data.

    append_file_system_object_id (audit_information.attach_file.object_id_p, descriptive_data,
          descriptive_data_size);

{ Put the access mode in the descriptive data.

    append_attach_access_mode (audit_information.attach_file.access_mode_p, descriptive_data,
          descriptive_data_size);

  PROCEND format_attach_file_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_chg_field_name_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the change validation field name audit statistic.

  PROCEDURE format_chg_field_name_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the record type in the descriptive data.

    append_name (audit_information.change_val_field_name.description_record_name_p, descriptive_data,
          descriptive_data_size);

{ Put the validation file name in the descriptive data.

    append_file_reference (audit_information.change_val_field_name.validation_file_p, descriptive_data,
          descriptive_data_size);

{ Put the original field name in the descriptive data.

    append_name (audit_information.change_val_field_name.original_field_name_p, descriptive_data,
          descriptive_data_size);

{ Put the new field name in the descriptive data.

    append_name (audit_information.change_val_field_name.new_field_name_p, descriptive_data,
          descriptive_data_size);

  PROCEND format_chg_field_name_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'fmt_chg_fs_obj_name_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the change fs object name audit statistic.

  PROCEDURE fmt_chg_fs_obj_name_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

    VAR
      file_path: fst$path,
      file_path_size: fst$path_size;

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the file system object id in the descriptive data.

    append_file_system_object_id (audit_information.change_fs_object_name.object_id_p, descriptive_data,
          descriptive_data_size);

{ Put the new file path in the descriptive data.

    IF audit_information.change_fs_object_name.new_variant_path.complete_path THEN
      IF audit_information.change_fs_object_name.new_variant_path.p_complete_path = NIL THEN
        file_path := ' ';
        file_path_size := 0;
      ELSE
        pfp$convert_pf_path_to_fs_path
              (audit_information.change_fs_object_name.new_variant_path.p_complete_path^, file_path,
              file_path_size);
      IFEND;
    ELSEIF audit_information.change_fs_object_name.new_variant_path.p_path = NIL THEN
      file_path := ' ';
      file_path_size := 0;
    ELSE
      pfp$convert_pft$path_to_fs_path (audit_information.change_fs_object_name.new_variant_path.p_path^,
            file_path, file_path_size);
    IFEND;
    append_file_reference (^file_path (1, file_path_size), descriptive_data, descriptive_data_size);

  PROCEND fmt_chg_fs_obj_name_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_chg_fs_obj_att_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the change file system object attribute statistic.

  PROCEDURE format_chg_fs_obj_att_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

    VAR
      attribute_name: ost$name,
      fs_object_attribute_names: [STATIC, READ, oss$job_paged_literal] array
            [sft$audited_fs_object_attribute] of ost$name := ['CYCLE_NUMBER                   ',
            'LOGGING                        ', 'PASSWORD                       ',
            'RING_ATTRIBUTES                ', 'FAP_NAME                       '],
      local_status: ost$status;

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the file system object id in the descriptive data.

    append_file_system_object_id (audit_information.create_fs_object.object_id_p, descriptive_data,
          descriptive_data_size);

{ Put the attribute name in the descriptive data.

    IF (audit_information.change_fs_object_attribute.attribute >=
          LOWERVALUE (sft$audited_fs_object_attribute)) AND (audit_information.change_fs_object_attribute.
          attribute >= LOWERVALUE (sft$audited_fs_object_attribute)) THEN
      attribute_name := fs_object_attribute_names [audit_information.change_fs_object_attribute.attribute];
    ELSE
      attribute_name := 'UNKNOWN_ATTRIBUTE';
    IFEND;
    append_name (^attribute_name, descriptive_data, descriptive_data_size);

{ Put the new value in the descriptive data if appropriate.

    CASE audit_information.change_fs_object_attribute.attribute OF
    = sfc$afsoa_cycle_number =
      append_cycle_number (audit_information.change_fs_object_attribute.new_cycle_number, descriptive_data,
            descriptive_data_size);
    = sfc$afsoa_logging =
      append_boolean (audit_information.change_fs_object_attribute.logging, descriptive_data,
            descriptive_data_size);
    = sfc$afsoa_ring_attributes =
      append_ring_attributes (^audit_information.change_fs_object_attribute.ring_attributes, descriptive_data,
            descriptive_data_size);
    = sfc$afsoa_fap_name =
      append_name (^audit_information.change_fs_object_attribute.fap_name, descriptive_data,
            descriptive_data_size);
    ELSE

{ do nothing - the new value is not reported.

    CASEND;

  PROCEND format_chg_fs_obj_att_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_chg_val_field_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the change validation field audit statistic.

  PROCEDURE format_chg_val_field_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

    VAR
      attribute_name: ost$name,
      authority_name: ost$name,
      val_field_attribute_names: [STATIC, READ, oss$job_paged_literal] array
            [sft$audited_val_field_attribute] of ost$name := ['DEFAULT_VALUE                  ',
            'DISPLAY_AUTHORITY              ', 'CHANGE_AUTHORITY               ',
            'MANAGE_AUTHORITY               '];

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the record type in the descriptive data.

    append_name (audit_information.change_validation_field.description_record_name_p, descriptive_data,
          descriptive_data_size);

{ Put the validation file name in the descriptive data.

    append_file_reference (audit_information.change_val_field_name.validation_file_p, descriptive_data,
          descriptive_data_size);

{ Put the field name in the descriptive data.

    append_name (audit_information.change_validation_field.field_name_p, descriptive_data,
          descriptive_data_size);

{ Put the attribute name in the descriptive data.

    IF (audit_information.change_validation_field.attribute >=
          LOWERVALUE (sft$audited_val_field_attribute)) AND (audit_information.change_validation_field.
          attribute <= UPPERVALUE (sft$audited_val_field_attribute)) THEN
      attribute_name := val_field_attribute_names [audit_information.change_validation_field.attribute];
    ELSE
      attribute_name := 'UNKNOWN_ATTRIBUTE';
    IFEND;
    append_name (^attribute_name, descriptive_data, descriptive_data_size);

{ Put the authority value in the descriptive data if appropriate.

    IF audit_information.change_validation_field.attribute <> sfc$avfa_default_value THEN
      CASE audit_information.change_validation_field.new_authority OF
      = avc$system_authority =
        authority_name := 'SYSTEM';
      = avc$system_admin_authority =
        authority_name := 'SYSTEM_ADMINISTRATION';
      = avc$family_admin_authority =
        authority_name := 'FAMILY_ADMINISTRATION';
      = avc$user_admin_authority =
        authority_name := 'USER_ADMINISTRATION';
      = avc$account_admin_authority =
        authority_name := 'ACCOUNT_ADMINISTRATION';
      = avc$project_admin_authority =
        authority_name := 'PROJECT_ADMINISTRATION';
      = avc$user_authority =
        authority_name := 'USER';
      ELSE
        authority_name := 'UNKNOWN_AUTHORITY';
      CASEND;
      append_name (^authority_name, descriptive_data, descriptive_data_size);
    IFEND;

  PROCEND format_chg_val_field_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_chg_val_record_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the change validation record audit statistic.

  PROCEDURE format_chg_val_record_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the record type in the descriptive data.

    append_name (audit_information.change_val_record.description_record_name_p, descriptive_data,
          descriptive_data_size);

{ Put the validation file name in the descriptive data.

    append_file_reference (audit_information.change_val_field_name.validation_file_p, descriptive_data,
          descriptive_data_size);

{ Put the user name in the descriptive data.

    append_name (audit_information.change_val_record.user_name_p, descriptive_data, descriptive_data_size);

{ Put the account name in the descriptive data.

    append_name (audit_information.change_val_record.account_name_p, descriptive_data, descriptive_data_size);

{ Put the project name in the descriptive data.

    append_name (audit_information.change_val_record.project_name_p, descriptive_data, descriptive_data_size);

{ Put the field name in the descriptive data.

    append_name (audit_information.change_val_record.field_name_p, descriptive_data, descriptive_data_size);

  PROCEND format_chg_val_record_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_cre_fs_object_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the create fs object audit statistic.

  PROCEDURE format_cre_fs_object_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the file system object id in the descriptive data.

    append_file_system_object_id (audit_information.create_fs_object.object_id_p, descriptive_data,
          descriptive_data_size);

  PROCEND format_cre_fs_object_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_cre_fs_permit_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the create fs permit audit statistic.

  PROCEDURE format_cre_fs_permit_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the file system object id in the descriptive data.

    append_file_system_object_id (audit_information.create_fs_permit.object_id_p, descriptive_data,
          descriptive_data_size);

{ Put the permit group in the descriptive data.

    append_permit_group (audit_information.create_fs_permit.group_p, descriptive_data, descriptive_data_size);

{ Put the permit access modes in the descriptive data.

    append_permit_access_mode (audit_information.create_fs_permit.permit_selections_p, descriptive_data,
          descriptive_data_size);

  PROCEND format_cre_fs_permit_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_cre_val_field_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the create validation field audit statistic.

  PROCEDURE format_cre_val_field_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

    VAR
      field_type: ost$name;

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the record type in the descriptive data.

    append_name (audit_information.create_validation_field.description_record_name_p, descriptive_data,
          descriptive_data_size);

{ Put the validation file name in the descriptive data.

    append_file_reference (audit_information.change_val_field_name.validation_file_p, descriptive_data,
          descriptive_data_size);

{ Put the field name in the descriptive data.

    append_name (audit_information.create_validation_field.field_name_p, descriptive_data,
          descriptive_data_size);

{ Put the field type in the descriptive data.

    field_type := avv$field_kind_names [audit_information.create_validation_field.field_kind];
    append_name (^field_type, descriptive_data, descriptive_data_size);


  PROCEND format_cre_val_field_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_cre_val_record_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the create validation record audit statistic.

  PROCEDURE format_cre_val_record_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the record type in the descriptive data.

    append_name (audit_information.create_validation_record.description_record_name_p, descriptive_data,
          descriptive_data_size);

{ Put the validation file name in the descriptive data.

    append_file_reference (audit_information.change_val_field_name.validation_file_p, descriptive_data,
          descriptive_data_size);

{ Put the user name in the descriptive data.

    append_name (audit_information.create_validation_record.user_name_p, descriptive_data,
          descriptive_data_size);

{ Put the account name in the descriptive data.

    append_name (audit_information.create_validation_record.account_name_p, descriptive_data,
          descriptive_data_size);

{ Put the project name in the descriptive data.

    append_name (audit_information.create_validation_record.project_name_p, descriptive_data,
          descriptive_data_size);

  PROCEND format_cre_val_record_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_del_fs_object_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the delete fs object audit statistic.

  PROCEDURE format_del_fs_object_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the file system object id in the descriptive data.

    append_file_system_object_id (audit_information.delete_fs_object.object_id_p, descriptive_data,
          descriptive_data_size);

  PROCEND format_del_fs_object_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_del_fs_permit_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the delete fs permit audit statistic.

  PROCEDURE format_del_fs_permit_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the file system object id in the descriptive data.

    append_file_system_object_id (audit_information.delete_fs_permit.object_id_p, descriptive_data,
          descriptive_data_size);

{ Put the permit group in the descriptive data.

    append_permit_group (audit_information.delete_fs_permit.group_p, descriptive_data, descriptive_data_size);

  PROCEND format_del_fs_permit_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_del_val_field_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the delete validation field audit statistic.

  PROCEDURE format_del_val_field_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the record type in the descriptive data.

    append_name (audit_information.delete_validation_field.description_record_name_p, descriptive_data,
          descriptive_data_size);

{ Put the validation file name in the descriptive data.

    append_file_reference (audit_information.change_val_field_name.validation_file_p, descriptive_data,
          descriptive_data_size);

{ Put the field name in the descriptive data.

    append_name (audit_information.delete_validation_field.field_name_p, descriptive_data,
          descriptive_data_size);

  PROCEND format_del_val_field_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_del_val_record_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the delete validation record audit statistic.

  PROCEDURE format_del_val_record_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the record type in the descriptive data.

    append_name (audit_information.delete_validation_record.description_record_name_p, descriptive_data,
          descriptive_data_size);

{ Put the validation file name in the descriptive data.

    append_file_reference (audit_information.change_val_field_name.validation_file_p, descriptive_data,
          descriptive_data_size);

{ Put the user name in the descriptive data.

    append_name (audit_information.delete_validation_record.user_name_p, descriptive_data,
          descriptive_data_size);

{ Put the account name in the descriptive data.

    append_name (audit_information.delete_validation_record.account_name_p, descriptive_data,
          descriptive_data_size);

{ Put the project name in the descriptive data.

    append_name (audit_information.delete_validation_record.project_name_p, descriptive_data,
          descriptive_data_size);

  PROCEND format_del_val_record_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_exec_program_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the execute program statistic.

  PROCEDURE format_exec_program_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the program name in the descriptive data.

    append_name (audit_information.execute_program.program_name_p, descriptive_data, descriptive_data_size);

{ Put the module name in the descriptive data.

    append_name (audit_information.execute_program.module_name_p, descriptive_data, descriptive_data_size);

{ Put the library name in the descriptive data.

    append_file_reference (audit_information.execute_program.library_name_p, descriptive_data,
          descriptive_data_size);

{ Put the loaded ring in the descriptive data.

    append_ring (audit_information.execute_program.loaded_ring, descriptive_data, descriptive_data_size);

  PROCEND format_exec_program_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_force_user_pw_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the force user password audit statistic.

  PROCEDURE format_force_user_pw_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

    VAR
      null_name: ost$name;

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the record type in the descriptive data.

    append_name (audit_information.force_user_password.description_record_name_p, descriptive_data,
          descriptive_data_size);

{ Put the validation file name in the descriptive data.

    append_file_reference (audit_information.change_val_field_name.validation_file_p, descriptive_data,
          descriptive_data_size);

{ Put the user name in the descriptive data.

    append_name (audit_information.force_user_password.user_name_p, descriptive_data, descriptive_data_size);

{ Put the place holders for account and project in the descriptive data.

    null_name := osc$null_name;
    append_name (^null_name, descriptive_data, descriptive_data_size);
    append_name (^null_name, descriptive_data, descriptive_data_size);

{ Put the field name in the descriptive data.

    append_name (audit_information.force_user_password.field_name_p, descriptive_data, descriptive_data_size);

  PROCEND format_force_user_pw_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_load_fap_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the load FAP statistic.

  PROCEDURE format_load_fap_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the file system object id in the descriptive data.

    append_file_reference (audit_information.load_fap.file_p, descriptive_data, descriptive_data_size);

{ Put the program name in the descriptive data.

    append_name (audit_information.load_fap.program_name_p, descriptive_data, descriptive_data_size);

{ Put the module name in the descriptive data.

    append_name (audit_information.load_fap.module_name_p, descriptive_data, descriptive_data_size);

{ Put the library name in the descriptive data.

    append_file_reference (audit_information.load_fap.library_name_p, descriptive_data,
          descriptive_data_size);

{ Put the loaded ring in the descriptive data.

    append_ring (audit_information.load_fap.loaded_ring, descriptive_data, descriptive_data_size);

  PROCEND format_load_fap_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_mount_mag_tape_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the mount magnetic tape statistic.

  PROCEDURE format_mount_mag_tape_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the external VSN in the descriptive data.

    append_name (audit_information.mount_magnetic_tape.external_vsn_p, descriptive_data,
          descriptive_data_size);

{ Put the recorded VSN in the descriptive data.

    append_name (audit_information.mount_magnetic_tape.recorded_vsn_p, descriptive_data,
          descriptive_data_size);

{ Put the write ring indicator in the descriptive data.

    append_boolean (audit_information.mount_magnetic_tape.write_ring, descriptive_data,
          descriptive_data_size);

{ Put the element (tape drive) name in the descriptive data.

    append_name (audit_information.mount_magnetic_tape.element_name_p, descriptive_data,
          descriptive_data_size);

  PROCEND format_mount_mag_tape_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_preval_user_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the prevalidate user audit statistic.

  PROCEDURE format_preval_user_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the family name in the descriptive data.

    append_name (audit_information.prevalidate_user.family_name_p, descriptive_data, descriptive_data_size);

{ Put the user name in the descriptive data.

    append_name (audit_information.prevalidate_user.user_name_p, descriptive_data, descriptive_data_size);

{ Put the account name in the descriptive data.

    append_name (audit_information.prevalidate_user.account_name_p, descriptive_data, descriptive_data_size);

{ Put the project name in the descriptive data.

    append_name (audit_information.prevalidate_user.project_name_p, descriptive_data, descriptive_data_size);

{ Put the terminal name in the descriptive data.

    append_name (audit_information.prevalidate_user.terminal_name_p, descriptive_data, descriptive_data_size);

  PROCEND format_preval_user_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_process_cmd_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the process command audit statistic.

  PROCEDURE format_process_cmd_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

    VAR
      call_method_names: [STATIC, READ, oss$job_paged_literal] array [clt$command_call_method] of
            ost$name := ['LINKED                         ', 'UNLINKED                       ',
            'PROCEDURE                      ', 'PROGRAM                        '],
      command_source_names: [STATIC, READ, oss$job_paged_literal] array [sft$command_source] of
            ost$name := ['PRIMARY                        ', 'SECONDARY                      '];

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the command name in the descriptive data.

    append_name (audit_information.process_command.command_name_p, descriptive_data, descriptive_data_size);

{ Put the command source in the descriptive data.

    append_name (^command_source_names [audit_information.process_command.command_source], descriptive_data,
          descriptive_data_size);

{ Put the command call method in the descriptive data.

    append_name (^call_method_names [audit_information.process_command.command_call_method], descriptive_data,
          descriptive_data_size);

  PROCEND format_process_cmd_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_security_pw_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the change and force security password audit
{  statistics.

  PROCEDURE format_security_pw_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the validation file name in the descriptive data.

    IF audit_information.audited_operation = sfc$ao_val_change_security_pw THEN
      append_file_reference (audit_information.change_security_password.validation_file_p, descriptive_data,
            descriptive_data_size);
    ELSE
      append_file_reference (audit_information.force_security_password.validation_file_p, descriptive_data,
            descriptive_data_size);
    IFEND;

  PROCEND format_security_pw_desc_data;
?? OLDTITLE ??
?? NEWTITLE := 'format_user_id_desc_data', EJECT ??

{ PURPOSE:
{  Formats the descriptive data that will be recorded on the user identification statistic.

  PROCEDURE format_user_id_desc_data
    (    audit_information: sft$audit_information;
         operation_status: ost$status;
     VAR descriptive_data: string ( * );
     VAR descriptive_data_size: integer);

{ Put the result information in the descriptive data.

    append_operation_status (operation_status, descriptive_data, descriptive_data_size);

{ Put the family name in the descriptive data.

    append_name (audit_information.user_identification.family_name_p, descriptive_data,
          descriptive_data_size);

{ Put the user name in the descriptive data.

    append_name (audit_information.user_identification.user_name_p, descriptive_data, descriptive_data_size);

{ Put the account name in the descriptive data.

    append_name (audit_information.user_identification.account_name_p, descriptive_data,
          descriptive_data_size);

{ Put the project name in the descriptive data.

    append_name (audit_information.user_identification.project_name_p, descriptive_data,
          descriptive_data_size);

{ Put the terminal name in the descriptive data.

    append_name (audit_information.user_identification.terminal_name_p, descriptive_data,
          descriptive_data_size);

  PROCEND format_user_id_desc_data;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] sfp$auditing_operation' ??

{ PURPOSE:
{   Determines if the specified operation is being audited (selection criteria is not considered).

  FUNCTION [XDCL] sfp$auditing_operation
    (    operation: sft$audited_operation) : boolean;

    VAR
      routing_control_p: ^sft$routing_control;

{ Check the system routing control information first.

    IF sfv$sys_routing_control_table <> NIL THEN
      routing_control_p := sfp$routing_control (sfv$audit_operation_descriptors [operation].statistic_code,
            sfv$sys_routing_control_table);
      IF (routing_control_p <> NIL) AND ((pmc$security_log IN routing_control_p^.activated_logs) OR
            (routing_control_p^.audit_control_p <> NIL)) THEN
        sfp$auditing_operation := TRUE;
        RETURN;
      IFEND;
    IFEND;

{ Check the job routing control information.

    IF sfv$job_routing_control_table <> NIL THEN
      routing_control_p := sfp$routing_control (sfv$audit_operation_descriptors [operation].statistic_code,
             sfv$job_routing_control_table);
      IF (routing_control_p <> NIL) AND ((pmc$security_log IN routing_control_p^.activated_logs) OR
            (routing_control_p^.audit_control_p <> NIL)) THEN
        sfp$auditing_operation := TRUE;
        RETURN;
      IFEND;
    IFEND;

{ If neither routing control table has an entry for the operation, the operation is not being audited.

    sfp$auditing_operation := FALSE;

  FUNCEND sfp$auditing_operation;
?? OLDTITLE, EJECT ??
?? NEWTITLE := '[XDCL, #GATE] sfp$emit_audit_statistic', EJECT ??
*copyc sfh$emit_audit_statistic

  PROCEDURE [XDCL, #GATE] sfp$emit_audit_statistic
    (    audit_information: sft$audit_information;
         operation_status: ost$status);

    VAR
      descriptive_data: ^string ( * ),
      descriptive_data_size: integer,
      emit_statistic: boolean,
      global_task_id: ost$global_task_id,
      ignore_status: ost$status,
      local_status: ost$status,
      statistic: ^SEQ ( * ),
      statistic_name: ost$name;

    local_status.normal := TRUE;

{ Make sure that the security audit security option has been enabled.

    IF NOT avp$security_option_active (avc$vso_security_audit) THEN
      RETURN;
    IFEND;

{ Verify that the call is system code.

    osp$verify_system_privilege;

{ Verify that the specified operation is a known audit operation.

    IF (audit_information.audited_operation < LOWERVALUE (sft$audited_operation)) OR
          (audit_information.audited_operation > UPPERVALUE (sft$audited_operation)) THEN
      osp$set_status_condition (sfe$unknown_audit_operation, local_status);
      osp$append_status_integer (osc$status_parameter_delimiter,
            $INTEGER (audit_information.audited_operation), 10, FALSE, local_status);
      osp$generate_log_message ($pmt$ascii_logset [pmc$system_log], local_status, ignore_status);
      RETURN;
    IFEND;

{ Check if the audit information satisfies any of the system audit controls.  If not, check if it statisfies
{ any of the job audit controls.

    check_audit_controls (audit_information, operation_status, sfc$sys_routing_control_table, emit_statistic);
    IF NOT emit_statistic THEN
      check_audit_controls (audit_information, operation_status, sfc$job_routing_control_table,
            emit_statistic);
    IFEND;

{ If the audit information satisfies any of the audit controls, emit the audit statistic.

    IF emit_statistic THEN

{ Construct the descriptive data for the statistic.

      IF format_descriptive_data_procs [audit_information.audited_operation] <> NIL THEN
        PUSH descriptive_data: [lgc$maximum_log_entry_size];
        descriptive_data_size := clp$trimmed_string_size (sfv$audit_operation_descriptors
              [audit_information.audited_operation].operation_abbreviation);
        descriptive_data^ := sfv$audit_operation_descriptors [audit_information.audited_operation].
              operation_abbreviation;
        format_descriptive_data_procs [audit_information.audited_operation]^
              (audit_information, operation_status, descriptive_data^, descriptive_data_size);
      ELSE
        PUSH descriptive_data: [1];
        descriptive_data_size := 0;
      IFEND;

{ Construct the statistic.

      PUSH statistic: [[REP (#SIZE (sft$statistic_header) + descriptive_data_size) OF cell]];
      pmp$get_executing_task_gtid (global_task_id);
      sfp$build_statistic (sfv$audit_operation_descriptors [audit_information.audited_operation].
            statistic_code, descriptive_data^ (1, descriptive_data_size), NIL, global_task_id, statistic,
            local_status);
      IF NOT local_status.normal THEN
        IF local_status.condition = sfe$work_area_full THEN
          sfp$convert_stat_code_to_name (sfv$audit_operation_descriptors
                [audit_information.audited_operation].statistic_code, statistic_name, ignore_status);
          osp$set_status_abnormal ('SF', sfe$too_much_data_for_statistic, statistic_name, local_status);
        IFEND;
        osp$generate_log_message ($pmt$ascii_logset [pmc$system_log], local_status, ignore_status);
        RETURN;
      IFEND;

{ Record the statistic in the security log.

      lgp$add_entry_global_binary_log (pmc$security_log, statistic, local_status);
      IF NOT local_status.normal THEN
        osp$generate_log_message ($pmt$ascii_logset [pmc$system_log], local_status, ignore_status);
        RETURN;
      IFEND;
    IFEND;

  PROCEND sfp$emit_audit_statistic;
?? OLDTITLE ??
MODEND sfm$emit_audit_statistic;
*DECK DECK=SFM$FILE_SPACE_LIMITS_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Statistics Facility: File Space Limits Manager' ??
MODULE sfm$file_space_limits_manager;

{ PURPOSE:
{   This module contains the ring 1 interfaces for changing and retrieving
{   file space limit information in/from the job control block and
{   initiated job list.

?? PUSH (LISTEXT := ON) ??
?? NEWTITLE := 'Global Declarations referenced by this module.', EJECT ??
*copyc avc$system_defined_limit_names
*copyc sfe$limit_condition_codes
*copyc sft$counter
*copyc sft$file_space_limit_kind
?? POP ??
*copyc jmv$jcb
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$change_file_space_limit', EJECT ??
{  PURPOSE:
{    This procedure is used to initialize or change the permanent or
{    temporary file space limit information in the job control block
{    and/or initiated job list.
{
{  DESIGN:
{    The specified values are used to replace the current values for
{    the specified parameters.  If a NIL value is specified the
{    current value is left unchanged.

  PROCEDURE [XDCL, #GATE] sfp$change_file_space_limit
    (    file_space_limit_kind: sft$file_space_limit_kind;
         job_warning_limit: ^sft$counter;
         job_maximum_limit: ^sft$counter;
         accumulator: ^sft$counter;
         job_warning_checking: ^boolean);

    IF file_space_limit_kind = sfc$perm_file_space_limit THEN

{ The request is for a change to permanent file space limits.

      IF job_warning_limit <> NIL THEN
        jmv$jcb.perm_file_job_warning_limit := job_warning_limit^;
      IFEND;
      IF job_warning_checking <> NIL THEN
        jmv$jcb.perm_file_job_warning_checking := job_warning_checking^;
      IFEND;
      IF job_maximum_limit <> NIL THEN
        jmv$jcb.perm_file_job_maximum_limit := job_maximum_limit^;
      IFEND;
      IF accumulator <> NIL THEN
        jmv$jcb.ijle_p^.statistics.perm_file_space := accumulator^;
      IFEND;

    ELSE {file_space_limit_kind = sfc$temp_file_space_limit}

{ The request is for a change to temporary file space limits.

      IF job_warning_limit <> NIL THEN
        jmv$jcb.temp_file_job_warning_limit := job_warning_limit^;
      IFEND;
      IF job_warning_checking <> NIL THEN
        jmv$jcb.temp_file_job_warning_checking := job_warning_checking^;
      IFEND;
      IF job_maximum_limit <> NIL THEN
        jmv$jcb.temp_file_job_maximum_limit := job_maximum_limit^;
      IFEND;
      IF accumulator <> NIL THEN
        jmv$jcb.ijle_p^.statistics.temp_file_space := accumulator^;
      IFEND;
    IFEND;

  PROCEND sfp$change_file_space_limit;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$get_file_space_limit', EJECT ??
{  PURPOSE:
{    This procedure is used to get the current value for the
{    specified file space limit.
{
{  DESIGN:
{    This procedure returns either the permanent file space limit values
{    or the temporary file space limit values from the JCB/IJL.

  PROCEDURE [XDCL, #GATE] sfp$get_file_space_limit
    (    file_space_limit_kind: sft$file_space_limit_kind;
     VAR job_warning_limit: sft$counter;
     VAR job_maximum_limit: sft$counter;
     VAR accumulator: sft$counter);

    IF file_space_limit_kind = sfc$perm_file_space_limit THEN
      job_warning_limit := jmv$jcb.perm_file_job_warning_limit;
      job_maximum_limit := jmv$jcb.perm_file_job_maximum_limit;
      accumulator := jmv$jcb.ijle_p^.statistics.perm_file_space;
    ELSE {file_space_limit_kind = sfc$temp_file_space_limit}
      job_warning_limit := jmv$jcb.temp_file_job_warning_limit;
      job_maximum_limit := jmv$jcb.temp_file_job_maximum_limit;
      accumulator := jmv$jcb.ijle_p^.statistics.temp_file_space;
    IFEND;

  PROCEND sfp$get_file_space_limit;
?? OLDTITLE ??
MODEND sfm$file_space_limits_manager;
*DECK DECK=SFM$JOB_LIMITS_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Statistics Facility: Job Limits Manager' ??
MODULE sfm$job_limits_manager;

{ PURPOSE:
{   This module contains the procedures that are used to create and manage job
{   limits.
{
{ DESIGN:
{   Limits contain accumulator, job warning limit, and job maximum limit values
{   that are used to control the number of resources a job is allowed to use.
{
{   If the accumulator reaches the job warning limit, a job warning condition
{   is initiated.  When a job warning condition occurs, a condition handler
{   (either user supplied or system default) will be called to deal with the
{   condition.  The job warning limit can be changed to any value between the
{   current value of the accumulator and the job maximum limit.
{
{   The job maximum limit is supposed to specify the point at which a job is
{   terminated without allowing the user to gain control (epilog processing would
{   still occur).  This implementation does not enforce job maximum limits because
{   the system does not (currently) provide the capability to "kill" a job and the
{   methods that are available for causing a job to terminate have the potential
{   for destroying files (and even hanging all of the jobs in the system).
{
{   Until solutions to the problems associated with a "kill" job function have
{   been found, the value of the maximum limit will be raised to unlimited if it is
{   hit.  That means that NOS/VE does not provide a mechanism to prevent a user
{   from exceeding a validation or job class imposed limit.
{
{   The limits for a job are kept in a linked list (called the job limit chain).
{   It will link all of the limit information together on a "first in - first out"
{   chain.  Updates to the job limits chain are interlocked by using signature
{   locks and the same lock variable that is used to interlock the job routing
{   control table.
{
{   Procedures are provided to:
{      - create a new limit for a job
{      - update the accumulator value for a limit
{      - update the job warning limit value for a limit
{      - update the job maximum limit value for a limit
{      - initiate a job resource condition
{
{   Once a limit has been created, it cannot be deleted and user code must not
{   be allowed to change the value of the job maximum limit.
{
{   Not allowing a limit to be deleted, has the nice side effect of allowing
{   code to read information from the job limit chain without having to set a
{   signature lock.

*copyc sfc$compiling_for_test_harness
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc jmd$job_resource_condition
*copyc jmt$job_resource_signal
*copyc ost$name
*copyc ost$status
*copyc sfc$unlimited
*copyc sfc$warning_grace_period
*copyc sfe$limit_condition_codes
*copyc sfe$statistics_not_available
*copyc sft$accumulator_update_kind
*copyc sft$binary_logset
*copyc sft$counters
*copyc sft$enforcement
*copyc sft$limit_chain_entry
*copyc sft$statistic_code
*copyc tmc$signal_identifiers
?? POP ??
*copyc avp$monitor_statistics_handler
*copyc clp$find_current_job_synch_task
*copyc clp$get_processing_phase
*copyc jmp$logout
*copyc jmp$system_job
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$clear_job_signature_lock
*copyc osp$generate_message
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$test_signature_lock
*copyc oss$job_pageable
*copyc pmp$continue_to_cause
*copyc pmp$get_global_task_id
*copyc pmp$get_job_mode
*copyc pmp$send_signal
*copyc sfp$add_job_routing_control
*copyc sfp$change_file_space_limit
*copyc sfp$job_limit_chain_entry
*copyc sfp$last_job_limit_chain_entry
*copyc tmp$fetch_job_statistics
*copyc avv$monitor_statistics_lock
*copyc jmv$jcb
*copyc osv$job_pageable_heap
*copyc pmv$job_maximum_limit_exceeded
*copyc sfv$job_routing_control_table
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$create_job_limit', EJECT ??
*copyc sfh$create_job_limit

{ DESIGN:
{   The initial value, maximum limit and warning limit are checked to insure
{   that INITIAL_VALUE < RESOURCE_LIMIT <= MAXIMUM_LIMIT.  If this is not true
{   an abnormal status of SFE$INVALID_INITIAL_LIMIT_VALUE is returned.
{
{   The job routing control table signature lock is set.
{
{   The job limit chain is searched to verify that no other limit has a name
{   that matches the specified name.  If another limit is found with the same
{   name, an abnormal status of SFE$DUPLICATE_LIMIT_NAME is set.
{
{   Otherwise, a limit chain entry is allocated and initialized using the values
{   specified on the call.  The limit count is incremented and used as the warning
{   condition identifier.
{
{   Clear the signature lock on the job routing control table.
{
{   If a pointer to an array of statistic codes was supplied,
{   SFP$ADD_JOB_ROUTING_CONTROL is called for each statistic code to set the limit
{   name in the routing control table entry.

  PROCEDURE [XDCL, #GATE] sfp$create_job_limit
    (    limit_name: ost$name;
         statistic_codes: ^array [1 .. * ] of sft$statistic_code;
         initial_value: sft$counter;
         warning_limit: sft$counter;
         maximum_limit: sft$counter;
         enforcement: sft$enforcement;
     VAR status: ost$status);

    VAR
      index: integer,
      limit_chain_entry: ^sft$limit_chain_entry;

?? NEWTITLE := 'create_limit_chain_entry', EJECT ??

    PROCEDURE create_limit_chain_entry
      (    limit_name: ost$name;
           initial_value: sft$counter;
           warning_limit: sft$counter;
           maximum_limit: sft$counter;
           enforcement: sft$enforcement;
       VAR limit_chain_entry: ^sft$limit_chain_entry;
       VAR status: ost$status);

      VAR
        last_limit_chain_entry: ^sft$limit_chain_entry;

      status.normal := TRUE;

      ALLOCATE limit_chain_entry IN osv$job_pageable_heap^;

      limit_chain_entry^.limit.name := limit_name;
      IF limit_name = avc$cpu_time_limit_name THEN
        limit_chain_entry^.limit.condition_identifier := jmc$time_limit_condition;
        ?IF sfc$compiling_for_test_harness THEN
          sfv$job_limit_count := sfv$job_limit_count + 1;
        ?IFEND
      ELSE
        sfv$job_limit_count := sfv$job_limit_count + 1;
        limit_chain_entry^.limit.condition_identifier := sfv$job_limit_count;
      IFEND;
      limit_chain_entry^.limit.accumulator := initial_value;
      limit_chain_entry^.limit.job_resource_limit := warning_limit;
      limit_chain_entry^.limit.job_abort_limit := maximum_limit;
      limit_chain_entry^.limit.enforcement := enforcement;
      limit_chain_entry^.cpu_time_of_job_resource_signal := 0;
      limit_chain_entry^.forward := NIL;

      last_limit_chain_entry := sfp$last_job_limit_chain_entry ();
      IF last_limit_chain_entry = NIL THEN
        sfv$first_job_limit_chain_entry := limit_chain_entry;
      ELSE
        last_limit_chain_entry^.forward := limit_chain_entry;
      IFEND;

    PROCEND create_limit_chain_entry;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    IF (warning_limit > maximum_limit) THEN
      osp$set_status_abnormal ('SF', sfe$invalid_initial_limit_value, limit_name, status);
      IF warning_limit = sfc$unlimited THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'UNLIMITED', status);
      ELSE
        osp$append_status_integer (osc$status_parameter_delimiter, warning_limit, 10, FALSE, status);
      IFEND;
      IF initial_value = sfc$unlimited THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'UNLIMITED', status);
      ELSE
        osp$append_status_integer (osc$status_parameter_delimiter, initial_value, 10, FALSE, status);
      IFEND;
      IF maximum_limit = sfc$unlimited THEN
        osp$append_status_parameter (osc$status_parameter_delimiter, 'UNLIMITED', status);
      ELSE
        osp$append_status_integer (osc$status_parameter_delimiter, maximum_limit, 10, FALSE, status);
      IFEND;
      RETURN;
    IFEND;

    osp$set_job_signature_lock (sfv$job_routing_control_lock);

{   Check for a limit with the specified name

    limit_chain_entry := sfp$job_limit_chain_entry (limit_name);

    IF limit_chain_entry = NIL THEN
      create_limit_chain_entry (limit_name, initial_value, warning_limit, maximum_limit, enforcement,
            limit_chain_entry, status);
    ELSE
      osp$set_status_abnormal ('SF', sfe$duplicate_limit_name, limit_chain_entry^.limit.name, status);
    IFEND;

    osp$clear_job_signature_lock (sfv$job_routing_control_lock);

    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   If an array of statistic codes has been supplied, the routing control
{   entries for the specified statistics are updated to include the limit name
{   so SFP$EMIT_STATISTIC can update the limit accumulator.

    IF statistic_codes <> NIL THEN
      FOR index := 1 TO UPPERBOUND (statistic_codes^) DO
        sfp$add_job_routing_control (statistic_codes^ [index], $sft$binary_logset [],
              limit_chain_entry^.limit.name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      FOREND;
    IFEND

  PROCEND sfp$create_job_limit;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$initiate_resource_condition', EJECT ??
*copyc sfh$initiate_resource_condition

{ NOTES:
{   It is assumed that the job routing control table is already locked so this
{   routine can update fields in the limit chain entry.
{
{   The number of job mode CP seconds specified by the constant
{   SFC$RESOURCE_GRACE_PERIOD as the minimum amount of time between job warning
{   signals is arbitrary.  This interval protects against the end case of back to
{   back warning conditions when the job is at its CP time or SRU job warning
{   limit.
{
{ DESIGN:
{   The current job mode CP time is compared to the job mode CP time recorded
{   the last time a signal was sent for this limit.  If less than
{   SFC$RESOURCE_GRACE_PERIOD CP seconds have elapsed, normal status is returned
{   and no signal is sent.
{
{   The current job mode CP time is recorded in the limit chain entry.
{
{   A job warning signal is sent to the current job synchronous task.  The
{   contents of the signal will be the condition identifier associated with the
{   limit.

  PROCEDURE [XDCL, #GATE] sfp$initiate_resource_condition
    (    limit_chain_entry: ^sft$limit_chain_entry;
     VAR status: ost$status);

    VAR
      global_task_id: ost$global_task_id,
      job_resource_signal: jmt$job_resource_signal,
      job_statistics: jmt$job_statistics,
      local_task_id: pmt$task_id,
      time_for_next_signal: ost$cp_time_value;

    status.normal := TRUE;

{   Check if enough time has passed since the last job warning signal for this
{   limit.

    IF (limit_chain_entry^.limit.name <> avc$pfs_limit_name) AND
          (limit_chain_entry^.limit.name <> avc$tfs_limit_name) THEN
      tmp$fetch_job_statistics (job_statistics, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF limit_chain_entry^.cpu_time_of_job_resource_signal <> 0 THEN
        time_for_next_signal := limit_chain_entry^.cpu_time_of_job_resource_signal +
              (sfc$warning_grace_period * 1000000);
        IF job_statistics.cp_time.time_spent_in_job_mode < time_for_next_signal THEN
          RETURN;
        IFEND;
      IFEND;

      limit_chain_entry^.cpu_time_of_job_resource_signal := job_statistics.cp_time.time_spent_in_job_mode;
    IFEND;

    clp$find_current_job_synch_task (local_task_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pmp$get_global_task_id (local_task_id, global_task_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Build a job warning signal with the content of the signal being the condition identifier for the limit that
{ has been hit.

    job_resource_signal.signal_id := jmc$job_resource_signal_id;
    job_resource_signal.signal_contents := limit_chain_entry^.limit.condition_identifier;

    pmp$send_signal (global_task_id, job_resource_signal.signal, status);

  PROCEND sfp$initiate_resource_condition;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$update_job_maximum_limit', EJECT ??
*copyc sfh$update_job_maximum_limit

{ NOTES:
{   User code should not be allowed to call this routine.  Abort limits are set
{   based on information from the user's validation and/or job class.  The user
{   must not be allowed to change the maximum limit.
{
{   Job maximum limits will not be enforced until NOS/VE supports a "kill" job
{   function.  Once a "kill" job function is provided, this routine will be used
{   to raise the maximum limits to insure that epilogs get a chance to execute (even
{   if the job hit an maximum limit).
{
{ DESIGN:
{   If the pointer to the job routing control table is NIL, this routine returns
{   with an abnormal status of SFE$STATISTICS_NOT_AVAILABLE.  Otherwise a
{   signature lock is set for the job routing control table.
{
{   The limit chain is searched for an entry with the specified name.  If the
{   entry cannot be found, an abnormal status of SFE$LIMIT_NOT_ACTIVATED is
{   returned.
{
{   If the entry is found, the value specified as the new maximum limit is
{   compared with the current warning limit.  If the value is greater than or
{   equal to the warning limit, the maximum limit field is updated.  If the value
{   is less than the warning limit, an abnnormal status of
{   SFE$INVALID_MAXIMUM_LIMIT is returned.
{
{   Clear the signature lock on the job routing control table.

  PROCEDURE [XDCL, #GATE] sfp$update_job_maximum_limit
    (    limit_name: ost$name;
         maximum_limit: sft$counter;
     VAR status: ost$status);

    VAR
      limit_chain_entry: ^sft$limit_chain_entry;

    status.normal := TRUE;

    IF sfv$job_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'Job', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$update_job_maximum_limit', status);
      RETURN;
    IFEND;

    osp$set_job_signature_lock (sfv$job_routing_control_lock);

    limit_chain_entry := sfp$job_limit_chain_entry (limit_name);

    IF limit_chain_entry <> NIL THEN
      IF maximum_limit >= limit_chain_entry^.limit.job_resource_limit THEN
        limit_chain_entry^.limit.job_abort_limit := maximum_limit;
      ELSE
        osp$set_status_abnormal ('SF', sfe$invalid_maximum_limit, limit_chain_entry^.limit.name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, maximum_limit, 10, FALSE, status);
        osp$append_status_integer (osc$status_parameter_delimiter,
              limit_chain_entry^.limit.job_resource_limit, 10, FALSE, status);
      IFEND;
    ELSE
      osp$set_status_abnormal ('SF', sfe$limit_not_activated, limit_name, status);
    IFEND;

    osp$clear_job_signature_lock (sfv$job_routing_control_lock);

  PROCEND sfp$update_job_maximum_limit;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$update_job_limit_accum', EJECT ??
*copyc sfh$update_job_limit_accum

{ NOTES:
{   This routine tests the signature lock on the job routing control table in
{   order to prevent a deadlock situation.  If the job is interrupted to update
{   the CP time and SRU accumulators while the job routing control table is being
{   accessed for another purpose, a deadlock situation could occur.
{
{   For now, when a job encounters a job maximum limit, the maximum limit will be
{   raised to unlimited.  When NOS/VE supports a "kill" job function, it will be
{   called instead of raisng the job maximum limit.
{
{  DESIGN:
{   If the pointer to the job routing control table is NIL, this routine returns
{   with an abnormal status of SFE$STATISTICS_NOT_AVAILABLE.
{
{   The signature lock for the job routing control table is tested to determine
{   if the table is already locked.  If the table is not locked or if the table is
{   locked by another task, set the signature lock.  Otherwise, this task already
{   has the table locked so the update can proceed.
{
{   The limit chain is searched for an entry with the specified name.  If the
{   entry cannot be found, an abnormal status of SFE$LIMIT_NOT_ACTIVATED is
{   returned.
{
{   For an incremental update, if the increment would cause the accumulator to
{   overflow an abnormal status of SFE$ACCUMULATOR_OVERFLOW is returned (for the
{   system job, the accumulator is reset to zero and the overflow is ignored).
{   Otherwise, the update value is added to the accumulator.
{
{   For replacement update, the update value is stored in the accumulator field.
{
{   If the job is executing in the job class or system prolog/epilog, limits are
{   not enforced.  Otherwise, limits are enforced.
{
{   If SFC$ACCUMULATION_ENFORCEMENT was selected and the maximum limit has been
{   exceeded, the maximum limit will be raised to unlimited.  If the warning limit
{   has been exceeded, a job warning condition is initiated.
{
{   If SFC$OTHER_ENFORCEMENT was selected, a status error will be returned for
{   either case.
{
{   Clear the signature lock on the job routing control table (only if this
{   procedure sets the lock).

  PROCEDURE [XDCL, #GATE] sfp$update_job_limit_accum
    (    limit_name: ost$name;
         update_value: sft$counter;
         update_kind: sft$accumulator_update_kind;
     VAR status: ost$status);

    VAR
      clear_lock_on_exit: boolean,
      ignore_status: ost$status,
      job_mode: jmt$job_mode,
      limit_chain_entry: ^sft$limit_chain_entry,
      lock_status: ost$signature_lock_status;

?? NEWTITLE := 'update_accumulator', EJECT ??

    PROCEDURE update_accumulator
      (    limit_chain_entry: ^sft$limit_chain_entry;
           update_value: sft$counter;
           update_kind: sft$accumulator_update_kind;
       VAR status: ost$status);

      VAR
        overflow: boolean;

      status.normal := TRUE;

      CASE update_kind OF

      = sfc$replacement_update =

        limit_chain_entry^.limit.accumulator := update_value;

      = sfc$incremental_update =

{   If the accumulator will overflow as a result of the this increment, the
{   accumulator is not updated and an abnormal status is returned (unless
{   it occurs in the system job).

        IF limit_chain_entry^.limit.accumulator >= 0 THEN
          overflow := (UPPERVALUE (sft$counter) - limit_chain_entry^.limit.accumulator) <= update_value;
        ELSE
          overflow := (LOWERVALUE (sft$counter) - limit_chain_entry^.limit.accumulator) > update_value;
        IFEND;
        IF overflow THEN
          IF jmp$system_job () THEN
            limit_chain_entry^.limit.accumulator := update_value;
          ELSE
            osp$set_status_abnormal ('SF', sfe$accumulator_overflow, limit_name, status);
          IFEND;
        ELSE
          limit_chain_entry^.limit.accumulator := limit_chain_entry^.limit.accumulator + update_value;
        IFEND;

      ELSE
        osp$set_status_abnormal ('SF', sfe$unknown_update_kind, 'sfp$update_job_limit_accum', status);
      CASEND;

    PROCEND update_accumulator;
?? OLDTITLE ??
?? NEWTITLE := 'check_limit', EJECT ??

    PROCEDURE check_limit
      (    limit_chain_entry: ^sft$limit_chain_entry;
       VAR status: ost$status);

      VAR
        ignore_status: ost$status,
        processing_phase: clt$processing_phase;

      status.normal := TRUE;

{ Skip limit checking for job class epilog and rest of job.

      processing_phase := clc$command_phase;
      clp$get_processing_phase (processing_phase, ignore_status);
      IF processing_phase >= clc$class_epilog_phase THEN
        RETURN;
      IFEND;

      CASE limit_chain_entry^.limit.enforcement OF

      = sfc$accumulation_enforcement =

        IF (limit_chain_entry^.limit.job_abort_limit <> sfc$unlimited) AND
              (limit_chain_entry^.limit.accumulator >= limit_chain_entry^.limit.job_abort_limit) THEN
          osp$set_status_abnormal ('SF', sfe$job_maximum_limit_exceeded, limit_chain_entry^.limit.name,
                status);
        ELSEIF (limit_chain_entry^.limit.job_resource_limit <> sfc$unlimited) AND
              (limit_chain_entry^.limit.accumulator >= limit_chain_entry^.limit.job_resource_limit) THEN
          sfp$initiate_resource_condition (limit_chain_entry, status);
        IFEND;

      = sfc$other_enforcement =

        IF (limit_chain_entry^.limit.job_abort_limit <> sfc$unlimited) AND
              (limit_chain_entry^.limit.accumulator > limit_chain_entry^.limit.job_abort_limit) THEN
          osp$set_status_abnormal ('SF', sfe$job_maximum_limit_exceeded, limit_chain_entry^.limit.name,
                status);
        ELSEIF (limit_chain_entry^.limit.job_resource_limit <> sfc$unlimited) AND
              (limit_chain_entry^.limit.accumulator > limit_chain_entry^.limit.job_resource_limit) THEN
          osp$set_status_abnormal ('SF', sfe$job_warning_limit_exceeded, limit_chain_entry^.limit.name,
                status);
        IFEND;

      ELSE
        osp$set_status_abnormal ('SF', sfe$unknown_enforcement, limit_chain_entry^.limit.name, status);

      CASEND;

    PROCEND check_limit;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    IF jmp$system_job () THEN

{ No limits exist in the system job so no action is necessary.

      RETURN;
    IFEND;

    IF sfv$job_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'Job', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$update_job_limit_accum', status);
      RETURN;
    IFEND;

    osp$test_signature_lock (sfv$job_routing_control_lock, lock_status, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF lock_status <> osc$sls_locked_by_current_task THEN
      osp$set_job_signature_lock (sfv$job_routing_control_lock);
      clear_lock_on_exit := TRUE;
    ELSE
      clear_lock_on_exit := FALSE;
    IFEND;

    limit_chain_entry := sfp$job_limit_chain_entry (limit_name);

    IF limit_chain_entry <> NIL THEN
      update_accumulator (limit_chain_entry, update_value, update_kind, status);
      IF status.normal THEN
        check_limit (limit_chain_entry, status);
        IF (status.condition = sfe$job_warning_limit_exceeded) OR
              (status.condition = sfe$job_maximum_limit_exceeded) THEN
          update_accumulator (limit_chain_entry, -update_value, update_kind, ignore_status);
        IFEND;
      IFEND;
    ELSE
      osp$set_status_abnormal ('SF', sfe$limit_not_activated, limit_name, status);
    IFEND;
    IF clear_lock_on_exit THEN
      osp$clear_job_signature_lock (sfv$job_routing_control_lock);
    IFEND;

    IF (NOT status.normal) AND (status.condition = sfe$job_maximum_limit_exceeded) AND
          (limit_chain_entry^.limit.enforcement = sfc$accumulation_enforcement) THEN
      pmp$get_job_mode (job_mode, ignore_status);
      IF (job_mode = jmc$batch) OR (job_mode = jmc$interactive_connected) THEN
        osp$generate_message (status, ignore_status);
      IFEND;

{ Test monitor stats lock and clear if set.

      lock_status := osc$sls_not_locked;
      osp$test_signature_lock (avv$monitor_statistics_lock, lock_status, ignore_status);
      IF lock_status = osc$sls_locked_by_current_task THEN
        osp$clear_job_signature_lock (avv$monitor_statistics_lock);
      IFEND;

      pmv$job_maximum_limit_exceeded := TRUE;
      jmp$logout (status);

{ Set monitor stats lock if we cleared it.

      IF lock_status = osc$sls_locked_by_current_task THEN
        osp$set_job_signature_lock (avv$monitor_statistics_lock);
      IFEND;

    IFEND;

  PROCEND sfp$update_job_limit_accum;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$update_job_warning_limit', EJECT ??
*copyc sfh$update_job_warning_limit

{ NOTES:
{   The warning limit can be changed to any value greater than the current
{   accumulator value and less than or equal to the maximum limit.
{
{ DESIGN:
{   If the pointer to the job routing control table is NIL, this routine returns
{   with an abnormal status of SFE$STATISTICS_NOT_AVAILABLE.  Otherwise a
{   signature lock is set for the job routing control table.
{
{   The limit chain is searched for an entry with the specified name.  If the
{   entry cannot be found, an abnormal status of SFE$LIMIT_NOT_ACTIVATED is
{   returned.
{
{   If the entry is found, the value specified as the new warning limit is
{   compared with the current value of the accumulator and the maximum limit.  If
{   the value of the new warning limit is greater than the current accumulator
{   value and less than or equal to the maximum limit, the warning limit field is
{   updated.  Otherwise, an abnormal status of SFE$INVALID_RESOURCE_LIMIT is
{   returned.
{
{   In addition, if the warning limit value for CP time or SRUs is being changed,
{   AVP$MONITOR_STATISTICS_HANDLER is called to update the accumulators and reset
{   the calculation interval.
{
{   Clear the signature lock on the job routing control table.

  PROCEDURE [XDCL, #GATE] sfp$update_job_warning_limit
    (    limit_name: ost$name;
         warning_limit: sft$counter;
     VAR status: ost$status);

    VAR
      job_warning_checking: boolean,
      limit_chain_entry: ^sft$limit_chain_entry;

    status.normal := TRUE;
    job_warning_checking := TRUE;

    IF sfv$job_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'Job', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$update_job_warning_limit', status);
      RETURN;
    IFEND;

    osp$set_job_signature_lock (sfv$job_routing_control_lock);

    limit_chain_entry := sfp$job_limit_chain_entry (limit_name);
    IF limit_chain_entry <> NIL THEN
      IF (limit_chain_entry^.limit.name = avc$cpu_time_limit_name) OR
            (limit_chain_entry^.limit.name = avc$sru_limit_name) THEN
        avp$monitor_statistics_handler (avc$monitor_statistics_flag);
      IFEND;
      IF (limit_chain_entry^.limit.name = avc$pfs_limit_name) AND
            (warning_limit > jmv$jcb.ijle_p^.statistics.perm_file_space) AND
            (warning_limit <= jmv$jcb.perm_file_job_maximum_limit) THEN
        sfp$change_file_space_limit (sfc$perm_file_space_limit, ^warning_limit,
             {job_maximum_limit = } NIL, {accumulator = } NIL, ^job_warning_checking);
      ELSEIF (limit_chain_entry^.limit.name = avc$tfs_limit_name) AND
            (warning_limit > jmv$jcb.ijle_p^.statistics.temp_file_space) AND
            (warning_limit <= jmv$jcb.temp_file_job_maximum_limit) THEN
        sfp$change_file_space_limit (sfc$temp_file_space_limit, ^warning_limit,
             {job_maximum_limit = } NIL, {accumulator = } NIL, ^job_warning_checking);
      ELSEIF (warning_limit > limit_chain_entry^.limit.accumulator) AND
            (warning_limit <= limit_chain_entry^.limit.job_abort_limit) THEN
        limit_chain_entry^.limit.job_resource_limit := warning_limit;
        limit_chain_entry^.cpu_time_of_job_resource_signal := 0;
        IF (limit_chain_entry^.limit.name = avc$cpu_time_limit_name) OR
              (limit_chain_entry^.limit.name = avc$sru_limit_name) THEN
          avp$monitor_statistics_handler (avc$monitor_statistics_flag);
        IFEND;
      ELSE
        osp$set_status_abnormal ('SF', sfe$invalid_warning_limit, limit_chain_entry^.limit.name, status);
        IF warning_limit = sfc$unlimited THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'UNLIMITED', status);
        ELSE
          osp$append_status_integer (osc$status_parameter_delimiter, warning_limit, 10, FALSE, status);
        IFEND;
        osp$append_status_integer (osc$status_parameter_delimiter, limit_chain_entry^.limit.accumulator, 10,
              FALSE, status);
        IF limit_chain_entry^.limit.job_abort_limit = sfc$unlimited THEN
          osp$append_status_parameter (osc$status_parameter_delimiter, 'UNLIMITED', status);
        ELSE
          osp$append_status_integer (osc$status_parameter_delimiter,
                limit_chain_entry^.limit.job_abort_limit, 10, FALSE, status);
        IFEND;
      IFEND;
    ELSE
      osp$set_status_abnormal ('SF', sfe$limit_not_activated, limit_name, status);
    IFEND;

    osp$clear_job_signature_lock (sfv$job_routing_control_lock);

  PROCEND sfp$update_job_warning_limit;
?? OLDTITLE ??
MODEND sfm$job_limits_manager;
*DECK DECK=SFM$JOB_ROUTING_CONTROL_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Statistics Facility: Job Routing Control Manager' ??
MODULE sfm$job_routing_control_manager;

{ PURPOSE:
{   This module contains the procedures that are used to create and manage the job routing control table.
{
{ DESIGN:
{   The job routing control table controls the logging of statistics for the job.
{
{   The routing control for a given statistic is found by calculating an index into the table (statistic code
{   MOD size of the table) and chaining down the linked list of routing control entries.
{
{   Routing controls are added to the chain in last in first out order.
{
{   The size of the routing control table has been chosen to provide an average chain length of 1 when all
{   currently known statistics are activated.
{
{   Updates of the job routing control table are interlocked by using signature locks.
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jml$user_id
*copyc sfe$condition_codes
*copyc sft$binary_logset
*copyc sft$limit_chain_entry
*copyc sft$routing_control
*copyc sft$routing_control_table
*copyc sft$statistic_code
?? POP ??
*copyc osp$append_status_parameter
*copyc osp$clear_job_signature_lock
*copyc osp$initialize_sig_lock
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$test_signature_lock
*copyc sfp$add_audit_control
*copyc sfp$add_routing_control
*copyc sfp$convert_stat_code_to_name
*copyc sfp$delete_audit_control
*copyc sfp$delete_routing_control
*copyc sfp$lock_routing_control
*copyc osv$job_pageable_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

{ The job routing control table controls which statistics are emitted to which logs for the job.

  VAR
    sfv$job_routing_control_table: [XDCL, #GATE, STATIC, oss$job_pageable] sft$routing_control_table := NIL;

{ The job routing control lock controls access to the job routing control table.

  VAR
    sfv$job_routing_control_lock: [XDCL, #GATE, STATIC, oss$job_pageable] ost$signature_lock;

{ This variable is used to store the number of limits active for the job.
{ NOTE: This variable must be initialized to 1 because 1 is reserved for the time limit condition identifier.

  VAR
    sfv$job_limit_count: [XDCL, #GATE, STATIC, oss$job_pageable] jmt$job_resource_condition := 1;

{ This variable is used to store a pointer to the first limit in the limit chain for the job.

  VAR
    sfv$first_job_limit_chain_entry: [XDCL, #GATE, STATIC, oss$job_pageable] ^sft$limit_chain_entry := NIL;

{ This variable indicates whether open_file statistics are activated for the job.

  VAR
    sfv$emit_job_open_statistics: [XDCL, #GATE, STATIC, oss$job_pageable] boolean := FALSE;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$add_job_audit_control', EJECT ??
*copyc sfh$add_job_audit_control

  PROCEDURE [XDCL, #GATE] sfp$add_job_audit_control
    (    operation_set: sft$audited_operation_set;
         selection_criteria: sft$audit_selection_criteria;
         lock: boolean;
     VAR status: ost$status);

    status.normal := TRUE;

{ Make sure the job routing control table has been initialized.

    IF sfv$job_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'Job', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$add_job_audit_control', status);
      RETURN;
    IFEND;

{ Interlock the job routing control table.

    osp$set_job_signature_lock (sfv$job_routing_control_lock);

{ Add the specified audit control information to the routing control table.

    sfp$add_audit_control (sfv$job_routing_control_table, operation_set, selection_criteria, lock,
          osv$job_pageable_heap);

{ Clear the interlock.

    osp$clear_job_signature_lock (sfv$job_routing_control_lock);

  PROCEND sfp$add_job_audit_control;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$add_job_routing_control', EJECT ??
*copyc sfh$add_job_routing_control

  PROCEDURE [XDCL, #GATE] sfp$add_job_routing_control
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
         limit_name: ost$name;
     VAR status: ost$status);

    VAR
      statistic_name: ost$name,
      routing_control_p: ^sft$routing_control;

    status.normal := TRUE;

{ Make sure the job routing control table has been initialized.

    IF sfv$job_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'Job', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$add_job_routing_control', status);
      RETURN;
    IFEND;

{ Interlock the job routing control table.

    osp$set_job_signature_lock (sfv$job_routing_control_lock);

{ Add the specified routing control information to the routing control table.

    sfp$add_routing_control (sfv$job_routing_control_table, statistic_code, logs, osv$job_pageable_heap,
          routing_control_p);

{ If a limit name was specified and no limit has already been associated with this statistic, set the limit
{ name in the routing control entry.

    IF limit_name <> osc$null_name THEN
      IF routing_control_p^.limit_name = osc$null_name THEN
          routing_control_p^.limit_name := limit_name;
      ELSE
        sfp$convert_stat_code_to_name (statistic_code, statistic_name, status);
        osp$set_status_abnormal ('SF', sfe$limit_already_active, statistic_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, limit_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter,
              routing_control_p^.limit_name, status);
      IFEND;
    IFEND;

{ Clear the interlock.

    osp$clear_job_signature_lock (sfv$job_routing_control_lock);

    IF (statistic_code = jml$open_file_statistics) AND NOT sfv$emit_job_open_statistics THEN
      sfv$emit_job_open_statistics := TRUE;
    IFEND;

  PROCEND sfp$add_job_routing_control;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$clear_job_routing_ctl_lock', EJECT ??
*copyc sfh$clear_job_routing_ctl_lock

  PROCEDURE [XDCL, #GATE] sfp$clear_job_routing_ctl_lock;

    VAR
      local_status: ost$status,
      lock_status: ost$signature_lock_status;

    local_status.normal := TRUE;

{ Check if the job routing control table is interlocked.

    osp$test_signature_lock (sfv$job_routing_control_lock, lock_status, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

{ If this task has the job routing control table locked, release the lock.

    IF lock_status = osc$sls_locked_by_current_task THEN
      osp$clear_job_signature_lock (sfv$job_routing_control_lock);
    IFEND;

  PROCEND sfp$clear_job_routing_ctl_lock;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$delete_job_audit_control', EJECT ??
*copyc sfh$delete_job_audit_control

  PROCEDURE [XDCL, #GATE] sfp$delete_job_audit_control
    (    operation_set: sft$audited_operation_set;
     VAR status: ost$status);

    status.normal := TRUE;

{ Make sure the job routing control table has been initialized.

    IF sfv$job_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'Job', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$delete_job_audit_control', status);
      RETURN;
    IFEND;

{ Interlock the job routing control table.

    osp$set_job_signature_lock (sfv$job_routing_control_lock);

{ Delete the specified audit control information from the routing control table.

    sfp$delete_audit_control (sfv$job_routing_control_table, operation_set, osv$job_pageable_heap,
          status);

{ Clear the interlock.

    osp$clear_job_signature_lock (sfv$job_routing_control_lock);

  PROCEND sfp$delete_job_audit_control;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$delete_job_routing_control', EJECT ??
*copyc sfh$delete_job_routing_control

  PROCEDURE [XDCL, #GATE] sfp$delete_job_routing_control
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

    status.normal := TRUE;

{ Make sure the job routing control table has been initialized.

    IF sfv$job_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'Job', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$delete_job_routing_control', status);
      RETURN;
    IFEND;

{ Interlock the job routing control table.

    osp$set_job_signature_lock (sfv$job_routing_control_lock);

{ Delete the specified routing control information from the routing control table.

    sfp$delete_routing_control (sfv$job_routing_control_table, statistic_code, logs, status);

{ Clear the interlock.

    osp$clear_job_signature_lock (sfv$job_routing_control_lock);

    IF (statistic_code = jml$open_file_statistics) AND sfv$emit_job_open_statistics THEN
      sfv$emit_job_open_statistics := FALSE;
    IFEND;

  PROCEND sfp$delete_job_routing_control;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$init_job_routing_control', EJECT ??
*copyc sfh$init_job_routing_control

  PROCEDURE [XDCL, #GATE] sfp$init_job_routing_control
    (VAR status: ost$status);

    VAR
      index: 0 .. sfc$routing_control_table_size;

    status.normal := TRUE;

{ Allocate the job routing control table and initialize each entry to NIL.

    ALLOCATE sfv$job_routing_control_table: [0 .. sfc$routing_control_table_size] IN osv$job_pageable_heap^;

    FOR index := 0 TO sfc$routing_control_table_size DO
      sfv$job_routing_control_table^ [index] := NIL;
    FOREND;

    osp$initialize_sig_lock (sfv$job_routing_control_lock);

  PROCEND sfp$init_job_routing_control;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$lock_job_routing_control', EJECT ??
*copyc sfh$lock_job_routing_control

  PROCEDURE [XDCL, #GATE] sfp$lock_job_routing_control
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

    status.normal := TRUE;

{ Make sure the job routing control table has been initialized.

    IF sfv$job_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'Job', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$lock_job_routing_control', status);
      RETURN;
    IFEND;

{ Interlock the job routing control table.

    osp$set_job_signature_lock (sfv$job_routing_control_lock);

{ Lock the specified routing control information.

    sfp$lock_routing_control (sfv$job_routing_control_table, statistic_code, logs,
          osv$job_pageable_heap);

{ Clear the interlock.

    osp$clear_job_signature_lock (sfv$job_routing_control_lock);

  PROCEND sfp$lock_job_routing_control;
?? OLDTITLE ??
MODEND sfm$job_routing_control_manager;
*DECK DECK=SFM$LIMIT_COMMANDS_FUNCTIONS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Statistics Facility: Limit Commands and Functions' ??
MODULE sfm$limit_commands_functions;

{ PURPOSE:
{   This module contains SCL command processors to update and retrieve job limit
{   information.
{
{ DESIGN:
{   The command processors in this module simply convert the parameter values
{   specified on the command into their internal formats (when necessary) and call
{   the appropriate statistics facility program interface.(from
{   SFM$LIMIT_INTERFACES)

?? NEWTITLE := 'Global Declarations referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc cle$work_area_overflow
*copyc clt$work_area
*copyc sfc$unlimited
*copyc sfe$condition_codes
?? POP ??
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc clp$trimmed_string_size
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc sfp$change_job_warning_limit
*copyc sfp$get_all_job_limits
*copyc sfp$get_job_limit
*copyc sfp$get_job_limit_count
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] sfp$_change_job_limit', EJECT ??

{ PURPOSE:
{   This is the command processor for CHANGE_JOB_LIMIT.

  PROCEDURE [XDCL] sfp$_change_job_limit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$chajl) change_job_limit, chajl (
{   name, n: any of
{       key
{         cpu_time, magnetic_tape, permanent_file_space, sru, task, temporary_file_space
{       keyend
{       name
{     anyend = $required
{   warning_limit, resource_limit, rl, wl: any of
{       key
{         unlimited
{       keyend
{       integer
{     anyend = $required
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] 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 .. 6] of clt$keyword_specification,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$name_type_qualifier,
          recend,
        recend,
        type2: 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$integer_type_qualifier,
          recend,
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 19, 15, 10, 26, 263], clc$command, 7, 3, 2, 0, 0, 0, 3, 'OSM$CHAJL'],
            [['N                              ', clc$abbreviation_entry, 1],
            ['NAME                           ', clc$nominal_entry, 1],
            ['RESOURCE_LIMIT                 ', clc$alias_entry, 2],
            ['RL                             ', clc$alias_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 3],
            ['WARNING_LIMIT                  ', clc$nominal_entry, 2],
            ['WL                             ', clc$abbreviation_entry, 2]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 254, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 84, clc$required_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$union_type], [[clc$keyword_type, clc$name_type], FALSE, 2], 229,
            [[1, 0, clc$keyword_type], [6], [['CPU_TIME                       ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['MAGNETIC_TAPE                  ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['PERMANENT_FILE_SPACE           ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['SRU                            ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['TASK                           ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['TEMPORARY_FILE_SPACE           ', clc$nominal_entry,
            clc$normal_usage_entry, 6]]], 5, [[1, 0, clc$name_type], [1, osc$max_name_size]]],

{ PARAMETER 2

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 44,
            [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 20, [[1, 0, clc$integer_type],
            [clc$min_integer, clc$max_integer, 10]]],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$name = 1,
      p$warning_limit = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      limit_name: ost$name,
      warning_limit: sft$counter;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$name].value^.kind = clc$keyword THEN
      limit_name := pvt [p$name].value^.keyword_value;
    ELSE
      limit_name := pvt [p$name].value^.name_value;
    IFEND;

    IF pvt [p$warning_limit].value^.kind = clc$keyword THEN
      warning_limit := sfc$unlimited;
    ELSE
      warning_limit := pvt [p$warning_limit].value^.integer_value.value;
    IFEND;

    sfp$change_job_warning_limit (limit_name, warning_limit, status);

  PROCEND sfp$_change_job_limit;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] sfp$_display_job_limit', EJECT ??

{ PURPOSE:
{   This is the command processor for DISPLAY_JOB_LIMIT.

  PROCEDURE [XDCL] sfp$_display_job_limit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$disjl) display_job_limit, display_job_limits, disjl (
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 19, 10, 52, 6, 82], clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$DISJL'],
            [['O                              ', clc$abbreviation_entry, 1],
            ['OUTPUT                         ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 2]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type], '$output'],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    CONST
      integer_field_width = 20;

*copy clv$display_variables

    VAR
      limits: sft$limits,
      display_control: clt$display_control,
      file_contents: amt$file_contents,
      output_line: string (osc$max_string_size),
      output_line_size: integer,
      accumulator_string: ost$string,
      job_warning_limit_string: ost$string,
      ring_attributes: amt$ring_attributes,
      job_maximum_limit_string: ost$string,
      limit_name_size: ost$name_size,
      available_space: 1 .. osc$max_string_size,
      name_column_size: amt$page_width,
      limit_name_column_size: ost$name_size,
      limit_count: jmt$job_resource_condition,
      index: jmt$job_resource_condition;

?? NEWTITLE := 'Dummy title because of error in clp$new_page_procedure' ??
*copyc clp$new_page_procedure

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

{ Dummy subtitle procedure

    PROCEND put_subtitle;
?? OLDTITLE ??
?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that the output
{   file is closed in case of an abnormal exit.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

    PROCEND condition_handler;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Fill an array with the jobs limits.

    sfp$get_job_limit_count (limit_count, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    REPEAT
      PUSH limits: [1 .. limit_count];
      sfp$get_all_job_limits (limits, limit_count, status);
    UNTIL (status.normal) OR (status.condition <> sfe$limit_array_too_small);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clv$titles_built := FALSE;
    clv$command_name := 'display_job_limits';
    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    file_contents := amc$list;

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, file_contents,
          ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

{ Set page width.

    IF display_control.page_width < clc$narrow_page_width THEN
      clv$page_width := clc$narrow_page_width;
    ELSE
      clv$page_width := display_control.page_width;
    IFEND;

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ The amount of space for the limit name column of the report should equal
{ the page width - (the amount of space needed for the three data columns) - (1 to remove autowrapping)

    name_column_size := clv$page_width - (3 * integer_field_width) - 1;

{ Reduce to the maximum space needed.

    IF name_column_size > osc$max_name_size THEN
      limit_name_column_size := osc$max_name_size;
    ELSE
      limit_name_column_size := name_column_size;
    IFEND;

{ The available space for printing limit name and the accumulator value should equal the
{ limit name column size calculated above + the amount of space needed for printing the maximum accumulator.

    available_space := limit_name_column_size + integer_field_width;

{ Write out the heading lines of the report.

    STRINGREP (output_line, output_line_size, 'Limit Name': limit_name_column_size, ' ':
          (integer_field_width - 11), 'Accumulator', ' ': (integer_field_width - 13), 'Warning Limit',
          ' ': (integer_field_width - 13), 'Maximum Limit');
    clp$put_display (display_control, output_line (1, output_line_size), clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (output_line, output_line_size, '----------': limit_name_column_size, ' ':
          (integer_field_width - 11), '-----------', ' ': (integer_field_width - 13), '-------------',
          ' ': (integer_field_width - 13), '-------------');
    clp$put_display (display_control, output_line (1, output_line_size), clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /process_limit_chain/
    FOR index := 1 TO limit_count DO
      clp$convert_integer_to_string (limits^ [index].accumulator, 10, FALSE, accumulator_string, status);

      job_warning_limit_string.value := ' ';
      IF limits^ [index].job_resource_limit = sfc$unlimited THEN

{ Right justify the literal 'UNLIMITED' in the appropriate column of the report.
{ (column width - length of the literal 'UNLIMITED') gives the number of leading spaces needed.
{ Adding 1 gives the starting substring position for the literal.

        job_warning_limit_string.value ((integer_field_width - 9) + 1, * ) := 'UNLIMITED';
      ELSE
        clp$convert_integer_to_rjstring (limits^ [index].job_resource_limit, 10, FALSE, ' ',
              job_warning_limit_string.value (1, integer_field_width), status);
      IFEND;
      job_warning_limit_string.size := integer_field_width;

      job_maximum_limit_string.value := ' ';
      IF limits^ [index].job_abort_limit = sfc$unlimited THEN

{ Right justify the literal 'UNLIMITED' in the appropriate column of the report.
{ (column width - length of the literal 'UNLIMITED') gives the number of leading spaces needed.
{ Adding 1 gives the starting substring position for the literal.

        job_maximum_limit_string.value ((integer_field_width - 9) + 1, * ) := 'UNLIMITED';
      ELSE
        clp$convert_integer_to_rjstring (limits^ [index].job_abort_limit, 10, FALSE, ' ',
              job_maximum_limit_string.value (1, integer_field_width), status);
      IFEND;
      job_maximum_limit_string.size := integer_field_width;

      limit_name_size := clp$trimmed_string_size (limits^ [index].name);

{ Check the limit name size + the accumulator size + 1 (for a space between fields) to see if they will
{ all fit on to one line.

      IF (limit_name_size + accumulator_string.size + 1) <= available_space THEN

{ Display will fit on one line.

        STRINGREP (output_line, output_line_size, limits^ [index].name (1, limit_name_size): limit_name_size,
              ' ': (available_space - (limit_name_size + accumulator_string.size)),
              accumulator_string.value (1, accumulator_string.size),
              job_warning_limit_string.value (1, job_warning_limit_string.size),
              job_maximum_limit_string.value (1, job_maximum_limit_string.size));
        clp$put_display (display_control, output_line (1, output_line_size), clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE

{ Display must be split into two lines.
{ Limit name is displayed on line one.

        STRINGREP (output_line, output_line_size, limits^ [index].name: osc$max_name_size);
        clp$put_display (display_control, output_line (1, output_line_size), clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

{ Values are displayed on line two.

        STRINGREP (output_line, output_line_size, ' ': (available_space - accumulator_string.size),
              accumulator_string.value (1, accumulator_string.size),
              job_warning_limit_string.value (1, job_warning_limit_string.size),
              job_maximum_limit_string.value (1, job_maximum_limit_string.size));
        clp$put_display (display_control, output_line (1, output_line_size), clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    FOREND /process_limit_chain/;

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$close_display (display_control, status);
    osp$disestablish_cond_handler;

  PROCEND sfp$_display_job_limit;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] sfp$$job_limit', EJECT ??

{ PURPOSE:
{   This is the function processor for $JOB_LIMIT

  PROCEDURE [XDCL] sfp$$job_limit
    (    parameter_list: clt$parameter_list;
     VAR work_area: ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

{ FUNCTION $job_limit (
{   name: name = $required
{   option: key
{       active, accumulator
{       (warning_limit, resource_limit)
{       (maximum_limit, abort_limit)
{     keyend = $required
{   )

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 2] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 6] of clt$keyword_specification,
        recend,
      recend := [[1, [88, 10, 19, 11, 39, 36, 734], clc$function, 2, 2, 2, 0, 0, 0, 0, '$JOB_LIMIT'],
            [['NAME                           ', clc$nominal_entry, 1],
            ['OPTION                         ', clc$nominal_entry, 2]], [

{ 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, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [2, 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, 229, clc$required_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$keyword_type], [6], [['ABORT_LIMIT                    ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['ACCUMULATOR                    ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['ACTIVE                         ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['MAXIMUM_LIMIT                  ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['RESOURCE_LIMIT                 ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['WARNING_LIMIT                  ', clc$nominal_entry,
            clc$normal_usage_entry, 3]]]];

?? POP ??

    CONST
      p$name = 1,
      p$option = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      local_status: ost$status,
      limit: sft$limit;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sfp$get_job_limit (pvt [p$name].value^.name_value, limit, local_status);

    NEXT result IN work_area;
    IF result = NIL THEN
      osp$set_status_abnormal ('CL', cle$work_area_overflow, '', status);
      RETURN;
    IFEND;

    IF (pvt [p$option].value^.keyword_value = 'ACTIVE') THEN
      result^.kind := clc$boolean;
      result^.boolean_value.kind := clc$true_false_boolean;
      IF local_status.normal THEN
        result^.boolean_value.value := TRUE;
      ELSEIF local_status.condition = sfe$limit_not_activated THEN
        result^.boolean_value.value := FALSE;
      ELSE
        status := local_status;
      IFEND;
    ELSEIF (NOT local_status.normal) THEN
      status := local_status;
    ELSE { Either the accumulator, warning limit or maximum limit were requested. }
      result^.kind := clc$integer;
      result^.integer_value.radix := 10;
      result^.integer_value.radix_specified := FALSE;
      IF (pvt [p$option].value^.keyword_value = 'ACCUMULATOR') THEN
        result^.integer_value.value := limit.accumulator;
      ELSEIF (pvt [p$option].value^.keyword_value = 'WARNING_LIMIT') THEN
        result^.integer_value.value := limit.job_resource_limit;
      ELSE { MAXIMUM_LIMIT}
        result^.integer_value.value := limit.job_abort_limit;
      IFEND;
    IFEND;

  PROCEND sfp$$job_limit;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] sfp$_set_job_limit', EJECT ??

{ PURPOSE:
{   This is the command processor for SET_JOB_LIMIT.
{
{ NOTES:
{   This command will be removed in a future release.

  PROCEDURE [XDCL] sfp$_set_job_limit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$setjl) set_job_limit, set_job_limits, setjl (
{   time_increment, ti: integer 0..osc$max_integer = $optional
{   time: integer 0..osc$max_integer = $optional
{   task: integer 0..osc$max_integer = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 5] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 19, 11, 10, 21, 629], clc$command, 5, 4, 0, 0, 0, 0, 4, 'OSM$SETJL'],
            [['STATUS                         ', clc$nominal_entry, 4],
            ['TASK                           ', clc$nominal_entry, 3],
            ['TI                             ', clc$abbreviation_entry, 1],
            ['TIME                           ', clc$nominal_entry, 2],
            ['TIME_INCREMENT                 ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],

{ PARAMETER 2

      [4, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$integer_type], [0, osc$max_integer, 10]],

{ PARAMETER 2

      [[1, 0, clc$integer_type], [0, osc$max_integer, 10]],

{ PARAMETER 3

      [[1, 0, clc$integer_type], [0, osc$max_integer, 10]],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$time_increment = 1,
      p$time = 2,
      p$task = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      time_increment: integer,
      time: integer,
      task: integer,
      limit: sft$limit;

?? NEWTITLE := 'check_parameters', EJECT ??

    PROCEDURE check_parameters
      (    parameter_value_table: ^clt$parameter_value_table;
           which_parameter: clt$which_parameter;
       VAR status: ost$status);

      status.normal := TRUE;

{ Time and time increment must not be specified at the same time.

      IF (NOT which_parameter.specific) THEN
        IF (pvt [p$time_increment].specified) AND (pvt [p$time].specified) THEN
          osp$set_status_abnormal ('SF', sfe$conflicting_parameters, 'TIME_INCREMENT and TIME', status);
        IFEND;
      IFEND;

    PROCEND check_parameters;
?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), ^check_parameters, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Increment the CPU time limit.

    IF pvt [p$time_increment].specified THEN
      time_increment := pvt [p$time_increment].value^.integer_value.value;

{ Get the current cp time limit then add the specified increment to it.

      sfp$get_job_limit (avc$cp_time_limit_name, limit, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Make sure the the value will not exceed unlimited.

      IF (sfc$unlimited - limit.job_resource_limit) < time_increment THEN
        time := sfc$unlimited;
      ELSE
        time := time_increment + limit.job_resource_limit;
      IFEND;
      sfp$change_job_warning_limit (avc$cp_time_limit_name, time, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Set a new CPU time limit.

    IF pvt [p$time].specified THEN
      time := pvt [p$time].value^.integer_value.value;
      sfp$change_job_warning_limit (avc$cp_time_limit_name, time, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

{ Set a new task limit.

    IF pvt [p$task].specified THEN
      task := pvt [p$task].value^.integer_value.value;
      sfp$change_job_warning_limit (avc$task_limit_name, task, status);
    IFEND;

  PROCEND sfp$_set_job_limit;
?? OLDTITLE ??
MODEND sfm$limit_commands_functions;


*DECK DECK=SFM$LIMIT_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Statistics Facility: Limit Interfaces' ??
MODULE sfm$limit_interfaces;

{ PURPOSE:
{   This module contains the external interfaces used to manipulate and retrieve
{   information from the job limit chain.
{
{ DESIGN:
{   The interfaces that update the job limit chain call internal interfaces in
{   the statistics facility that execute in lower rings and are capable of locking
{   the job routing control table which indirectly locks the job limit chain.
{   Interfaces that retrieve information from the job routing control table do not
{   call internal interfaces in the statistics facility and do not indirectly
{   interlock the job limit chain.

?? NEWTITLE := 'Global Declarations referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc cle$ecc_lexical
*copyc cle$ecc_miscellaneous
*copyc jmd$sru_count
*copyc pmk$keypoints
*copyc sfc$unlimited
*copyc sfe$condition_codes
?? POP ??
*copyc avp$monitor_statistics_handler
*copyc avv$accumulated_srus
*copyc clp$get_processing_phase
*copyc clp$validate_name
*copyc jmp$system_job
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc sfp$get_file_space_limit
*copyc sfp$job_limit_chain_entry
*copyc sfp$update_job_warning_limit
*copyc sfv$job_routing_control_table
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$change_job_resource_limit', EJECT ??

{ PURPOSE:
{   Change the job warning value for a specified limit.
{
{ NOTES:
{   This interface has been replaced by SFP$CHANGE_JOB_WARNING_LIMIT.  It has been retained to provide
{   compatibility with previos systems.

  PROCEDURE [XDCL, #GATE] sfp$change_job_resource_limit
    (    limit_name: ost$name;
         resource_limit: sft$counter;
     VAR status: ost$status);

    status.normal := TRUE;

    sfp$change_job_warning_limit (limit_name, resource_limit, status);

  PROCEND sfp$change_job_resource_limit;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$change_job_warning_limit', EJECT ??
*copyc sfh$change_job_warning_limit

  PROCEDURE [XDCL, #GATE] sfp$change_job_warning_limit
    (    limit_name: ost$name;
         warning_limit: sft$counter;
     VAR status: ost$status);

    VAR
      valid_name: boolean,
      validated_name: ost$name;

    status.normal := TRUE;

    clp$validate_name (limit_name, validated_name, valid_name);
    IF NOT valid_name THEN
      osp$set_status_abnormal ('CL', cle$improper_name, limit_name, status);
      RETURN;
    IFEND;

    sfp$update_job_warning_limit (limit_name, warning_limit, status);

  PROCEND sfp$change_job_warning_limit;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$get_all_job_limits', EJECT ??
*copyc sfh$get_all_job_limits

  PROCEDURE [XDCL, #GATE] sfp$get_all_job_limits
    (    limits: sft$limits;
     VAR count: jmt$job_resource_condition;
     VAR status: ost$status);

    VAR
      current_limit_chain_entry: ^sft$limit_chain_entry,
      index: jmt$job_resource_condition;

    status.normal := TRUE;

    IF jmp$system_job () THEN
      osp$set_status_abnormal ('SF', sfe$no_active_limits, '', status);
      RETURN;
    IFEND;

    IF sfv$job_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'Job', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$get_all_job_limits', status);
      RETURN;
    IFEND;

    IF limits = NIL THEN
      osp$set_status_abnormal ('SF', sfe$limit_array_pointer_nil, '', status);
      RETURN;
    IFEND;

    count := sfv$job_limit_count;

{ The specified array must be big enough to accept the limits.

    IF UPPERBOUND (limits^) >= count THEN

{ Update the CPU time and SRU limit accumulators.

      avp$monitor_statistics_handler (avc$monitor_statistics_flag);
      current_limit_chain_entry := sfv$first_job_limit_chain_entry;

    /copy_limits/
      FOR index := 1 TO count DO
        IF current_limit_chain_entry = NIL THEN

{ The end of the chain should never occur before the count is exhausted.

          osp$set_status_abnormal ('SF', sfe$corrupted_limit_chain, 'sfp$get_all_job_limits', status);
          RETURN;
        IFEND;
        limits^ [index] := current_limit_chain_entry^.limit;
        IF limits^ [index].name = avc$pfs_limit_name THEN
          sfp$get_file_space_limit (sfc$perm_file_space_limit, limits^ [index].
                job_resource_limit, limits^ [index].job_abort_limit, limits^ [index].accumulator);
        ELSEIF limits^ [index].name = avc$tfs_limit_name THEN
          sfp$get_file_space_limit (sfc$temp_file_space_limit, limits^ [index].
                job_resource_limit, limits^ [index].job_abort_limit, limits^ [index].accumulator);
        IFEND;
        current_limit_chain_entry := current_limit_chain_entry^.forward;
      FOREND /copy_limits/;
    ELSE
      osp$set_status_abnormal ('SF', sfe$limit_array_too_small, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, UPPERBOUND (limits^), 10, FALSE, status);
      osp$append_status_integer (osc$status_parameter_delimiter, sfv$job_limit_count, 10, FALSE, status);
    IFEND;

  PROCEND sfp$get_all_job_limits;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$get_job_limit', EJECT ??
*copyc sfh$get_job_limit

  PROCEDURE [XDCL, #GATE] sfp$get_job_limit
    (    limit_name: ost$name;
     VAR limit: sft$limit;
     VAR status: ost$status);

    VAR
      job_limit_chain_entry: ^sft$limit_chain_entry,
      valid_name: boolean,
      validated_name: ost$name;

    status.normal := TRUE;

    clp$validate_name (limit_name, validated_name, valid_name);
    IF NOT valid_name THEN
      osp$set_status_abnormal ('CL', cle$improper_name, limit_name, status);
      RETURN;
    IFEND;

    IF sfv$job_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'Job', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$get_job_limit', status);
      RETURN;
    IFEND;

{ Make sure the limit has been updated if CPU time or SRU limit is requested.

    IF (limit_name = avc$cpu_time_limit_name) OR (limit_name = avc$sru_limit_name) THEN
      avp$monitor_statistics_handler (avc$monitor_statistics_flag);
    IFEND;

{ Get the limit chain entry for the specified limit name if one exists.

    job_limit_chain_entry := sfp$job_limit_chain_entry (limit_name);
    IF job_limit_chain_entry <> NIL THEN
      limit := job_limit_chain_entry^.limit;
      IF limit.name = avc$pfs_limit_name THEN
        sfp$get_file_space_limit (sfc$perm_file_space_limit, limit.job_resource_limit, limit.job_abort_limit,
              limit.accumulator);
      ELSEIF limit.name = avc$tfs_limit_name THEN
        sfp$get_file_space_limit (sfc$temp_file_space_limit, limit.job_resource_limit, limit.job_abort_limit,
              limit.accumulator);
      IFEND;
    ELSE
      osp$set_status_abnormal ('SF', sfe$limit_not_activated, limit_name, status);
    IFEND;

  PROCEND sfp$get_job_limit;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$get_job_limit_count', EJECT ??
*copyc sfh$get_job_limit_count

  PROCEDURE [XDCL, #GATE] sfp$get_job_limit_count
    (VAR count: jmt$job_resource_condition;
     VAR status: ost$status);

    status.normal := TRUE;

    IF sfv$job_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'Job', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$get_job_limit_count', status);
      RETURN;
    IFEND;

    count := sfv$job_limit_count;

  PROCEND sfp$get_job_limit_count;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$get_job_limit_name', EJECT ??
*copyc sfh$get_job_limit_name

  PROCEDURE [XDCL, #GATE] sfp$get_job_limit_name
    (    condition_id: jmt$job_resource_condition;
     VAR limit_name: ost$name;
     VAR status: ost$status);

    VAR
      current_limit_chain_entry: ^sft$limit_chain_entry;

    status.normal := TRUE;

    IF sfv$job_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'Job', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$get_job_limit_name', status);
      RETURN;
    IFEND;

    current_limit_chain_entry := sfv$first_job_limit_chain_entry;

  /search_for_limit_chain_entry/
    WHILE (current_limit_chain_entry <> NIL) AND (current_limit_chain_entry^.limit.condition_identifier <>
          condition_id) DO
      current_limit_chain_entry := current_limit_chain_entry^.forward;
    WHILEND /search_for_limit_chain_entry/;

    IF current_limit_chain_entry <> NIL THEN
      limit_name := current_limit_chain_entry^.limit.name;
    ELSE
      osp$set_status_abnormal ('SF', sfe$unknown_condition_id, '', status);
      osp$append_status_integer (osc$status_parameter_delimiter, condition_id, 10, FALSE, status);
    IFEND;

  PROCEND sfp$get_job_limit_name;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$get_srus', EJECT ??
*copyc pmh$get_srus

  PROCEDURE [XDCL, #GATE] pmp$get_srus
    (VAR srus: jmt$sru_count;
     VAR status: ost$status);

    VAR
      limit_information: sft$limit;

    #KEYPOINT (osk$entry, 0, pmk$get_srus);

    status.normal := TRUE;

    avp$monitor_statistics_handler (avc$monitor_statistics_flag);
    srus := avv$accumulated_srus;

    #KEYPOINT (osk$exit, 0, pmk$get_srus);

  PROCEND pmp$get_srus;
?? OLDTITLE ??
MODEND sfm$limit_interfaces;
*DECK DECK=SFM$MTR_STATS_FACILITY_REQUESTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Statistics Facility: Monitor Requests' ??
MODULE sfm$mtr_stats_facility_requests;

{ PURPOSE:
{   This module contains the statistics facility monitor request
{   procedures.

?? PUSH (LISTEXT := ON) ??
  ?VAR
    sfc$compiling_mtr_sf_requests: boolean := TRUE ?;
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc ost$cpu_state_table
*copyc sft$rb_stats_facility_requests
?? POP ??
*copyc mtp$error_stop
*copyc sfp$mtr_accumulate_file_space
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    sfv$dynamic_file_space_limits: [XDCL, #GATE] boolean := TRUE;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] sfp$mtr_stats_facility_requests', EJECT ??
{  PURPOSE:
{    This procedure is used to process a monitor request for
{    accumulation of file space.
{
{  DESIGN:
{    This procedure calls an inline procedure with the information
{    sent on the monitor call.

  PROCEDURE [XDCL] sfp$mtr_stats_facility_requests
    (VAR request_block: sft$rb_stats_facility_requests;
         cst_p: ^ost$cpu_state_table);

    VAR
      maximum_exceeded: boolean;

    CASE request_block.sub_reqcode OF
    = sfc$accumulate_file_space =
      sfp$mtr_accumulate_file_space (request_block.file_space_limit_kind, request_block.accumulator,
            maximum_exceeded);
    ELSE
      mtp$error_stop ('MTR STATISTICS FACILITY - Unimplemented sub-request code');
    CASEND;

  PROCEND sfp$mtr_stats_facility_requests;
?? OLDTITLE ??
MODEND sfm$mtr_stats_facility_requests;

*DECK DECK=SFM$SECURITY_AUDIT_UTILITY EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Statistics Facility: Administer Security Audit' ??
MODULE sfm$security_audit_utility;
?? NEWTITLE := 'Global Declarations referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
?? POP ??
*copyc avp$family_administrator
*copyc avp$system_administrator
*copyc clp$begin_utility
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$include_file
*copyc clp$new_display_line
*copyc clp$new_display_page
?? NEWTITLE := 'Dummy title' ??
*copyc clp$new_page_procedure
?? OLDTITLE ??
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$trimmed_string_size
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc sfp$activate_audit
*copyc sfp$activate_job_statistic
*copyc sfp$activate_system_statistic
*copyc sfp$convert_stat_code_to_name
*copyc sfp$convert_stat_name_to_code
*copyc sfp$deactivate_audit
*copyc sfp$deactivate_job_statistic
*copyc sfp$deactivate_system_statistic
*copyc sfp$get_audited_operations
*copyc sfp$lock_statistic
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

{ Constants that define the column starting positions and widths for the DISAO command.

  CONST
    stat_name_column_start = 1,
    stat_name_column_width = 10,
    locked_column_start = 11,
    locked_column_width = 4,
    operation_column_start = 16,
    operation_column_width = osc$max_name_size,
    criteria_column_start = 48,
    criteria_column_width = osc$max_name_size,
    subcriteria_column_start = 50,
    subcriteria_column_width = osc$max_name_size;

  CONST
    avc$admsa_utility_name = 'ADMINISTER_SECURITY_AUDIT      ',
    avc$admsa_utility_prompt = 'ASA';

  VAR
    audit_operation_name: [STATIC, READ] array [sft$audited_operation] of string (osc$max_name_size) :=
          ['Attach File                    ', 'Change File Attributes         ',
          'Change Object Name             ', 'Create Object                  ',
          'Create Permit                  ', 'Delete Object                  ',
          'Delete Permit                  ', 'Load FAP                       ',
          'Mount Magnetic Tape            ', 'Job End                        ',
          'Execute Program                ', 'Process Command                ',
          'User Identification            ', 'Activate Capability            ',
          'Change Validation Field        ', 'Change Validation Field Name   ',
          'Change Validation Record       ', 'Change Security Password       ',
          'Create Validation Field        ', 'Create Validation Record       ',
          'Deactivate Capability          ', 'Delete Validation Field        ',
          'Delete Validation Record       ', 'Force Security Password        ',
          'Force User Password            ', 'User Validation                '];


  VAR
    audit_selector_name: [STATIC, READ] array [sft$audit_selector] of string (osc$max_name_size) :=
          [osc$null_name, 'Result', 'Command Source', 'Access Modes', 'Catalog Owner'];

  VAR
    catalog_owner_name: [STATIC, READ] array [sft$catalog_owner] of string (osc$max_name_size) := ['Owner',
          'Non-owner', 'System'];

  VAR
    command_source_name: [STATIC, READ] array [sft$command_source] of string (osc$max_name_size) :=
          ['Primary Commands', 'Secondary Commands'];

  VAR
    operation_result_name: [STATIC, READ] array [sft$operation_result] of string (osc$max_name_size) :=
          ['Successful', 'Unsuccessful'];

  VAR
    access_mode_name: [STATIC, READ] array [pft$usage_options] of string (osc$max_name_size) := ['Read',
          'Shorten', 'Append', 'Modify', 'Execute'];

  VAR
    routing_control_table_id: sft$routing_control_table_id;

*copyc clv$display_variables
?? OLDTITLE ??
?? NEWTITLE := 'put_subtitle', EJECT ??

{ PURPOSE:
{   This procedure places the column headings on the output file.

  PROCEDURE put_subtitle
    (VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      display_line: string (clc$narrow_page_width);

    status.normal := TRUE;

    display_line := ' ';
    display_line (stat_name_column_start, stat_name_column_width) := 'Statistic';
    display_line (locked_column_start, locked_column_width) := 'Lock ';
    display_line (operation_column_start, operation_column_width) := 'Operation';
    display_line (criteria_column_start, criteria_column_width) := 'Selection Criteria';
    clp$put_display (display_control, display_line, clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display_line := ' ';
    display_line (stat_name_column_start, stat_name_column_width) := '---------';
    display_line (locked_column_start, locked_column_width) := '---- ';
    display_line (operation_column_start, operation_column_width) := '-------------------------------';
    display_line (criteria_column_start, criteria_column_width) := '-------------------------------';
    clp$put_display (display_control, display_line, clc$trim, status);

  PROCEND put_subtitle;
?? OLDTITLE ??
?? NEWTITLE := 'sfp$_administer_security_audit', EJECT ??

{ PURPOSE:
{   This is the starting point for the ADMINISTER_SECURITY_AUDIT utility.  ADMINISTER_SECURITY_AUDIT is used
{   to control auditing of security related activities.

  PROCEDURE [XDCL] sfp$_administer_security_audit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admsa) administer_security_audit, admsa (
{   scope, s: key
{       (job, j)
{       (system, s)
{     keyend = system
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (6),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 29, 9, 27, 58, 74],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMSA'], [
    ['S                              ',clc$abbreviation_entry, 1],
    ['SCOPE                          ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 6],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [4], [
    ['J                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'system'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$scope = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

?? EJECT ??

{ table admsa_command_table type=command
{ command (activate_file_auditing, actfa)                              p=sfp$_activate_file_auditing
{ command (activate_job_auditing, actja)                               p=sfp$_activate_job_auditing
{ command (activate_statistic, acts)                                   p=sfp$_activate_statistic
{ command (activate_validation_auditing, actva)                        p=sfp$_activate_validation_auditi
{ command (deactivate_file_auditing, deafa)                            p=sfp$_deactivate_file_auditing
{ command (deactivate_job_auditing, deaja)                             p=sfp$_deactivate_job_auditing
{ command (deactivate_statistic, deas)                                 p=sfp$_deactivate_statistic
{ command (deactivate_validation_auditing, deava)                      p=sfp$_deactivate_validation_audi
{ command (display_audited_operations, disao)                          p=sfp$_display_audited_operations
{ command (quit, end_administer_security_audit, endasa, qui)           p=sfp$_end_administer_security_au
{ tablend

?? PUSH (LISTEXT := ON) ??

    VAR
      admsa_command_table: [STATIC, READ] ^clt$command_table := ^admsa_command_table_entries,

      admsa_command_table_entries: [STATIC, READ] array [1 .. 22] of clt$command_table_entry := [
            {} ['ACTFA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^sfp$_activate_file_auditing],
            {} ['ACTIVATE_FILE_AUDITING         ', clc$nominal_entry, clc$normal_usage_entry, 1,
            clc$automatically_log, clc$linked_call, ^sfp$_activate_file_auditing],
            {} ['ACTIVATE_JOB_AUDITING          ', clc$nominal_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^sfp$_activate_job_auditing],
            {} ['ACTIVATE_STATISTIC             ', clc$nominal_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^sfp$_activate_statistic],
            {} ['ACTIVATE_VALIDATION_AUDITING   ', clc$nominal_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^sfp$_activate_validation_auditi],
            {} ['ACTJA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
            clc$automatically_log, clc$linked_call, ^sfp$_activate_job_auditing],
            {} ['ACTS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
            clc$automatically_log, clc$linked_call, ^sfp$_activate_statistic],
            {} ['ACTVA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
            clc$automatically_log, clc$linked_call, ^sfp$_activate_validation_auditi],
            {} ['DEACTIVATE_FILE_AUDITING       ', clc$nominal_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^sfp$_deactivate_file_auditing],
            {} ['DEACTIVATE_JOB_AUDITING        ', clc$nominal_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^sfp$_deactivate_job_auditing],
            {} ['DEACTIVATE_STATISTIC           ', clc$nominal_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^sfp$_deactivate_statistic],
            {} ['DEACTIVATE_VALIDATION_AUDITING ', clc$nominal_entry, clc$normal_usage_entry, 8,
            clc$automatically_log, clc$linked_call, ^sfp$_deactivate_validation_audi],
            {} ['DEAFA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
            clc$automatically_log, clc$linked_call, ^sfp$_deactivate_file_auditing],
            {} ['DEAJA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
            clc$automatically_log, clc$linked_call, ^sfp$_deactivate_job_auditing],
            {} ['DEAS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
            clc$automatically_log, clc$linked_call, ^sfp$_deactivate_statistic],
            {} ['DEAVA                          ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
            clc$automatically_log, clc$linked_call, ^sfp$_deactivate_validation_audi],
            {} ['DISAO                          ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
            clc$automatically_log, clc$linked_call, ^sfp$_display_audited_operations],
            {} ['DISPLAY_AUDITED_OPERATIONS     ', clc$nominal_entry, clc$normal_usage_entry, 9,
            clc$automatically_log, clc$linked_call, ^sfp$_display_audited_operations],
            {} ['ENDASA                         ', clc$alias_entry, clc$normal_usage_entry, 10,
            clc$automatically_log, clc$linked_call, ^sfp$_end_administer_security_au],
            {} ['END_ADMINISTER_SECURITY_AUDIT  ', clc$alias_entry, clc$normal_usage_entry, 10,
            clc$automatically_log, clc$linked_call, ^sfp$_end_administer_security_au],
            {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
            clc$automatically_log, clc$linked_call, ^sfp$_end_administer_security_au],
            {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 10,
            clc$automatically_log, clc$linked_call, ^sfp$_end_administer_security_au]];

?? POP ??

    VAR
      admsa_utility_attributes: ^clt$utility_attributes;

?? EJECT ??
    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$scope].value^.keyword_value = 'SYSTEM' THEN
      routing_control_table_id := sfc$sys_routing_control_table;
    ELSE
      routing_control_table_id := sfc$job_routing_control_table;
    IFEND;

{ Start up the ADMSA utility.

    PUSH admsa_utility_attributes: [1 .. 2];
    admsa_utility_attributes^ [1].key := clc$utility_prompt;
    admsa_utility_attributes^ [1].prompt.value := avc$admsa_utility_prompt;
    admsa_utility_attributes^ [1].prompt.size := clp$trimmed_string_size
          (admsa_utility_attributes^ [1].prompt.value);
    admsa_utility_attributes^ [2].key := clc$utility_command_table;
    admsa_utility_attributes^ [2].command_table := admsa_command_table;
    clp$begin_utility (avc$admsa_utility_name, admsa_utility_attributes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, '', avc$admsa_utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_utility (avc$admsa_utility_name, status);

  PROCEND sfp$_administer_security_audit;
?? OLDTITLE ??
?? NEWTITLE := 'get_access_mode_criteria', EJECT ??

{ PURPOSE:
{   This procedure translates the value specified for the ACCESS_MODE parameter into audit selection
{   criteria.

  PROCEDURE get_access_mode_criteria
    (    parameter_value: ^clt$data_value;
     VAR audit_selection_entry: sft$audit_selection_entry);

    VAR
      current_parameter_value: ^clt$data_value;

{  Initialize audit selection entry for an empty set of access modes.

    audit_selection_entry.selector := sfc$as_access_mode_set;
    audit_selection_entry.access_mode_set := $pft$usage_selections [];

{  Set current parameter value to the pointer of the first entry in the list of specified values.

    current_parameter_value := parameter_value;

{ If the kind is keyword then ALL was specified.

    IF current_parameter_value^.kind = clc$keyword THEN
      audit_selection_entry.access_mode_set := $pft$usage_selections
            [pfc$read, pfc$shorten, pfc$append, pfc$modify, pfc$execute];
    ELSE

    /assign_access_mode_set/
      WHILE current_parameter_value <> NIL DO
        IF current_parameter_value^.element_value^.keyword_value = 'APPEND' THEN
          audit_selection_entry.access_mode_set := audit_selection_entry.access_mode_set +
                $pft$usage_selections [pfc$append];
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'EXECUTE' THEN
          audit_selection_entry.access_mode_set := audit_selection_entry.access_mode_set +
                $pft$usage_selections [pfc$execute];
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'MODIFY' THEN
          audit_selection_entry.access_mode_set := audit_selection_entry.access_mode_set +
                $pft$usage_selections [pfc$modify];
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'READ' THEN
          audit_selection_entry.access_mode_set := audit_selection_entry.access_mode_set +
                $pft$usage_selections [pfc$read];
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'SHORTEN' THEN
          audit_selection_entry.access_mode_set := audit_selection_entry.access_mode_set +
                $pft$usage_selections [pfc$shorten];
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'WRITE' THEN
          audit_selection_entry.access_mode_set := audit_selection_entry.access_mode_set +
                $pft$usage_selections [pfc$shorten, pfc$append, pfc$modify];
        IFEND;
        current_parameter_value := current_parameter_value^.link;
      WHILEND /assign_access_mode_set/;
    IFEND;

  PROCEND get_access_mode_criteria;
?? OLDTITLE ??
?? NEWTITLE := 'get_catalog_owner_criteria', EJECT ??

{ PURPOSE:
{   This procedure translates the value specified for the CATALOG_OWNER parameter into audit
{   selection criteria.

  PROCEDURE get_catalog_owner_criteria
    (    parameter_value: ^clt$data_value;
     VAR audit_selection_entry: sft$audit_selection_entry);

    VAR
      current_parameter_value: ^clt$data_value;

{  Initialize audit selection entry for catalog owner to the empty set.

    audit_selection_entry.selector := sfc$as_catalog_owner_set;
    audit_selection_entry.catalog_owner_set := $sft$catalog_owner_set [];

{  Set current parameter value to the pointer of the first entry in the list of specified values.

    current_parameter_value := parameter_value;

{ If the kind is keyword then ALL was specified.

    IF current_parameter_value^.kind = clc$keyword THEN
      audit_selection_entry.catalog_owner_set := $sft$catalog_owner_set
            [sfc$co_owner, sfc$co_non_owner, sfc$co_system];
    ELSE

    /assign_catalog_owner/
      WHILE current_parameter_value <> NIL DO
        IF current_parameter_value^.element_value^.keyword_value = 'NON_OWNER' THEN
          audit_selection_entry.catalog_owner_set := audit_selection_entry.catalog_owner_set +
                $sft$catalog_owner_set [sfc$co_non_owner];
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'OWNER' THEN
          audit_selection_entry.catalog_owner_set := audit_selection_entry.catalog_owner_set +
                $sft$catalog_owner_set [sfc$co_owner];
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'SYSTEM' THEN
          audit_selection_entry.catalog_owner_set := audit_selection_entry.catalog_owner_set +
                $sft$catalog_owner_set [sfc$co_system];
        IFEND;
        current_parameter_value := current_parameter_value^.link;
      WHILEND /assign_catalog_owner/;
    IFEND;

  PROCEND get_catalog_owner_criteria;
?? OLDTITLE ??
?? NEWTITLE := 'get_command_source_criteria', EJECT ??

{ PURPOSE:
{   This procedure translates the value specified for the COMMAND_SOURCE parameter into audit
{   selection criteria.

  PROCEDURE get_command_source_criteria
    (    parameter_value: ^clt$data_value;
     VAR audit_selection_entry: sft$audit_selection_entry);

{  Initialize audit selection entry for command source to the empty set.

    audit_selection_entry.selector := sfc$as_command_source_set;
    audit_selection_entry.command_source_set := $sft$command_source_set [];

    IF parameter_value^.keyword_value = 'PRIMARY_COMMANDS' THEN
      audit_selection_entry.command_source_set := audit_selection_entry.command_source_set +
            $sft$command_source_set [sfc$cs_primary_command_file];
    ELSE {parameter_value^.keyword_value = 'ALL_COMMANDS' THEN}
      audit_selection_entry.command_source_set := $sft$command_source_set
            [sfc$cs_primary_command_file, sfc$cs_secondary_command_file];
    IFEND;

  PROCEND get_command_source_criteria;
?? OLDTITLE ??
?? NEWTITLE := 'get_fs_audit_operation_set', EJECT ??

{ PURPOSE:
{   This procedure translates the value specified for the OPERATION parameter on the file system auditing
{   commands into its internal value.

  PROCEDURE get_fs_audit_operation_set
    (    parameter_value: ^clt$data_value;
     VAR selected_operations: sft$audited_operation_set);

    VAR
      current_parameter_value: ^clt$data_value;

{  Initialize the selected operations to the empty set.

    selected_operations := $sft$audited_operation_set [];

{  Set current parameter value to the pointer of the first entry in the list of specified values.

    current_parameter_value := parameter_value;

{ If the kind is keyword then ALL was specified.

    IF current_parameter_value^.kind = clc$keyword THEN
      selected_operations := $sft$audited_operation_set [sfc$ao_fs_attach_file, sfc$ao_fs_change_attribute,
            sfc$ao_fs_change_name, sfc$ao_fs_create_object, sfc$ao_fs_create_permit, sfc$ao_fs_delete_object,
            sfc$ao_fs_delete_permit, sfc$ao_fs_load_fap, sfc$ao_fs_magnetic_tape_mount];
    ELSE

    /assign_fs_audit_operation/
      WHILE current_parameter_value <> NIL DO
        IF current_parameter_value^.element_value^.keyword_value = 'ATTACH_FILE' THEN
          selected_operations := selected_operations + $sft$audited_operation_set [sfc$ao_fs_attach_file];
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'LOAD_FAP' THEN
          selected_operations := selected_operations + $sft$audited_operation_set [sfc$ao_fs_load_fap];
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'MANAGE_OBJECT' THEN
          selected_operations := selected_operations + $sft$audited_operation_set
                [sfc$ao_fs_change_attribute, sfc$ao_fs_create_object, sfc$ao_fs_delete_object];
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'MANAGE_PERMIT' THEN
          selected_operations := selected_operations + $sft$audited_operation_set
                [sfc$ao_fs_create_permit, sfc$ao_fs_delete_permit];
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'MOUNT_REMOVABLE_MEDIA' THEN
          selected_operations := selected_operations + $sft$audited_operation_set
                [sfc$ao_fs_magnetic_tape_mount];
        IFEND;
        current_parameter_value := current_parameter_value^.link;
      WHILEND /assign_fs_audit_operation/;
    IFEND;

  PROCEND get_fs_audit_operation_set;
?? OLDTITLE ??
?? NEWTITLE := 'get_job_audit_operation_set', EJECT ??

{ PURPOSE:
{   This procedure translates the value specified for the OPERATION parameter on the job auditing commands
{   into its internal value.

  PROCEDURE get_job_audit_operation_set
    (    parameter_value: ^clt$data_value;
     VAR selected_operations: sft$audited_operation_set);

    VAR
      current_parameter_value: ^clt$data_value;

{  Initialize the selected operations to the empty set.

    selected_operations := $sft$audited_operation_set [];

{  Set current parameter value to the pointer of the first entry in the list of specified values.

    current_parameter_value := parameter_value;

{ If the kind is keyword then ALL was specified.

    IF current_parameter_value^.kind = clc$keyword THEN
      selected_operations := $sft$audited_operation_set [sfc$ao_job_execute_program,
            sfc$ao_job_process_command];
    ELSE

    /assign_job_audit_operation/
      WHILE current_parameter_value <> NIL DO
        IF current_parameter_value^.element_value^.keyword_value = 'EXECUTE_PROGRAM' THEN
          selected_operations := selected_operations + $sft$audited_operation_set
                [sfc$ao_job_execute_program];
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'PROCESS_COMMAND' THEN
          selected_operations := selected_operations + $sft$audited_operation_set
                [sfc$ao_job_process_command];
        IFEND;
        current_parameter_value := current_parameter_value^.link;
      WHILEND /assign_job_audit_operation/;
    IFEND;

  PROCEND get_job_audit_operation_set;
?? OLDTITLE ??
?? NEWTITLE := 'get_result_criteria', EJECT ??

{ PURPOSE:
{   This procedure translates the value specified for the RESULT parameter into audit selection criteria.

  PROCEDURE get_result_criteria
    (    parameter_value: ^clt$data_value;
     VAR audit_selection_entry: sft$audit_selection_entry);

{  Initialize audit selection entry for result to the empty set.

    audit_selection_entry.selector := sfc$as_operation_result_set;
    audit_selection_entry.operation_result_set := $sft$operation_result_set [];

    IF parameter_value^.keyword_value = 'SUCCESSFUL' THEN
      audit_selection_entry.operation_result_set := audit_selection_entry.operation_result_set +
            $sft$operation_result_set [sfc$or_successful];
    ELSEIF parameter_value^.keyword_value = 'UNSUCCESSFUL' THEN
      audit_selection_entry.operation_result_set := audit_selection_entry.operation_result_set +
            $sft$operation_result_set [sfc$or_unsuccessful];
    ELSE {parameter_value^.keyword_value = 'ALL' THEN}
      audit_selection_entry.operation_result_set := $sft$operation_result_set
            [sfc$or_successful, sfc$or_unsuccessful];
    IFEND;

  PROCEND get_result_criteria;
?? OLDTITLE ??
?? NEWTITLE := 'get_val_audit_operation_set', EJECT ??

{ PURPOSE:
{   This procedure translates the value specified for the OPERATION parameter on the validation auditing
{   commands into its internal value.

  PROCEDURE get_val_audit_operation_set
    (    parameter_value: ^clt$data_value;
     VAR selected_operations: sft$audited_operation_set);

    VAR
      current_parameter_value: ^clt$data_value;

{  Initialize the selected operations to the empty set.

    selected_operations := $sft$audited_operation_set [];

{  Set current parameter value to the pointer of the first entry in the list of specified values.

    current_parameter_value := parameter_value;

{ If the kind is keyword then ALL was specified.

    IF current_parameter_value^.kind = clc$keyword THEN
      selected_operations := $sft$audited_operation_set [sfc$ao_val_activate_capability,
            sfc$ao_val_change_field, sfc$ao_val_change_field_name, sfc$ao_val_change_record,
            sfc$ao_val_change_security_pw, sfc$ao_val_create_field, sfc$ao_val_create_record,
            sfc$ao_val_deact_capability, sfc$ao_val_delete_field, sfc$ao_val_delete_record,
            sfc$ao_val_force_security_pw, sfc$ao_val_force_user_password, sfc$ao_val_prevalidate_user];
    ELSE

    /assign_val_audit_operation/
      WHILE current_parameter_value <> NIL DO
        IF current_parameter_value^.element_value^.keyword_value = 'MANAGE_FIELD' THEN
          selected_operations := selected_operations + $sft$audited_operation_set
                [sfc$ao_val_change_field, sfc$ao_val_change_field_name, sfc$ao_val_create_field,
                sfc$ao_val_delete_field]
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'MANAGE_SECURITY_PASSWORD' THEN
          selected_operations := selected_operations + $sft$audited_operation_set
                [sfc$ao_val_change_security_pw, sfc$ao_val_force_security_pw];
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'MANAGE_VALIDATION' THEN
          selected_operations := selected_operations + $sft$audited_operation_set
                [sfc$ao_val_change_record, sfc$ao_val_create_record, sfc$ao_val_delete_record,
                sfc$ao_val_force_user_password];
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'USE_CAPABILITY' THEN
          selected_operations := selected_operations + $sft$audited_operation_set
                [sfc$ao_val_activate_capability, sfc$ao_val_deact_capability];
        ELSEIF current_parameter_value^.element_value^.keyword_value = 'USER_VALIDATION' THEN
          selected_operations := selected_operations + $sft$audited_operation_set
                [sfc$ao_val_prevalidate_user];
        IFEND;
        current_parameter_value := current_parameter_value^.link;
      WHILEND /assign_val_audit_operation/;
    IFEND;

  PROCEND get_val_audit_operation_set;
?? OLDTITLE ??
?? NEWTITLE := 'ADMINISTER_SECURITY_AUDIT Subcommand Processors', EJECT ??
?? NEWTITLE := 'sfp$_activate_file_auditing', EJECT ??

{ PURPOSE:
{   This procedure initiates the ACTIVATE_FILE_AUDITING subcommand.

  PROCEDURE sfp$_activate_file_auditing
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admsa_actfa) activate_file_auditing, actfa (
{   lock, l: boolean = $required
{   operation, operations, o: any of
{       list of key
{         (attach_file, af)
{         (load_fap, lf)
{         (manage_object, mo)
{         (manage_permit, mp)
{         (mount_removable_media, mrm)
{       keyend
{       key
{         all
{       keyend
{     anyend = all
{   result, r: key
{       (successful, s)
{       (unsuccessful, u)
{       all
{     keyend = all
{   catalog_owner, co: any of
{       list of key
{         (non_owner, no)
{         (owner, o)
{         (system, s)
{       keyend
{       key
{         all
{       keyend
{     anyend = all
{   access_mode, access_modes, am: any of
{       list of key
{         (append, a)
{         (execute, e)
{         (modify, m)
{         (read, r)
{         (shorten, s)
{         (write, w)
{       keyend
{       key
{         all
{       keyend
{     anyend = all
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 13] of clt$pdt_parameter_name,
      parameters: array [1 .. 6] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 10] of clt$keyword_specification,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
        default_value: string (3),
      recend,
      type4: 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 6] of clt$keyword_specification,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type5: 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 12] of clt$keyword_specification,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type6: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 29, 9, 37, 40, 819],
    clc$command, 13, 6, 1, 0, 0, 0, 6, 'OSM$ADMSA_ACTFA'], [
    ['ACCESS_MODE                    ',clc$nominal_entry, 5],
    ['ACCESS_MODES                   ',clc$alias_entry, 5],
    ['AM                             ',clc$abbreviation_entry, 5],
    ['CATALOG_OWNER                  ',clc$nominal_entry, 4],
    ['CO                             ',clc$abbreviation_entry, 4],
    ['L                              ',clc$abbreviation_entry, 1],
    ['LOCK                           ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OPERATION                      ',clc$nominal_entry, 2],
    ['OPERATIONS                     ',clc$alias_entry, 2],
    ['R                              ',clc$abbreviation_entry, 3],
    ['RESULT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 6]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 457,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 309,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 5
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 531,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 6
    [13, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    393, [[1, 0, clc$list_type], [377, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [10], [
        ['AF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['ATTACH_FILE                    ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['LF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['LOAD_FAP                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['MANAGE_OBJECT                  ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['MANAGE_PERMIT                  ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['MO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['MOUNT_REMOVABLE_MEDIA          ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['MP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['MRM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5]]
        ]
      ],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [5], [
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SUCCESSFUL                     ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['UNSUCCESSFUL                   ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'all'],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    245, [[1, 0, clc$list_type], [229, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [6], [
        ['NO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['NON_OWNER                      ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['O                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['OWNER                          ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['SYSTEM                         ', clc$nominal_entry, clc$normal_usage_entry, 3]]
        ]
      ],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'all'],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    467, [[1, 0, clc$list_type], [451, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [12], [
        ['A                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['APPEND                         ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['E                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['EXECUTE                        ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['M                              ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['MODIFY                         ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['R                              ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['READ                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
        ['SHORTEN                        ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['W                              ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
        ['WRITE                          ', clc$nominal_entry, clc$normal_usage_entry, 6]]
        ]
      ],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'all'],
{ PARAMETER 6
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$lock = 1,
      p$operation = 2,
      p$result = 3,
      p$catalog_owner = 4,
      p$access_mode = 5,
      p$status = 6;

    VAR
      pvt: array [1 .. 6] of clt$parameter_value;

    VAR
      audit_selection_criteria: ^sft$audit_selection_criteria,
      audited_operation_set: sft$audited_operation_set;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH audit_selection_criteria: [1 .. 3];
    get_result_criteria (pvt [p$result].value, audit_selection_criteria^ [1]);
    get_catalog_owner_criteria (pvt [p$catalog_owner].value, audit_selection_criteria^ [2]);
    get_access_mode_criteria (pvt [p$access_mode].value, audit_selection_criteria^ [3]);

    get_fs_audit_operation_set (pvt [p$operation].value, audited_operation_set);

{ Insure that name changes are audited.

    audited_operation_set := audited_operation_set + $sft$audited_operation_set [sfc$ao_fs_change_name];

    sfp$activate_audit (audited_operation_set, audit_selection_criteria^, routing_control_table_id,
          pvt [p$lock].value^.boolean_value.value, status);

  PROCEND sfp$_activate_file_auditing;
?? OLDTITLE ??
?? NEWTITLE := 'sfp$_activate_job_auditing', EJECT ??

{ PURPOSE:
{   This procedure initiates the ACTIVATE_JOB_AUDITING subcommand.

  PROCEDURE sfp$_activate_job_auditing
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admsa_actja) activate_job_auditing, actja (
{   lock, l: boolean = $required
{   operation, operations, o: any of
{       list of key
{         (execute_program, ep)
{         (process_command, pc)
{       keyend
{       key
{         all
{       keyend
{     anyend = all
{   result, r: key
{       (successful, s)
{       (unsuccessful, u)
{       all
{     keyend = all
{   command_source, cs: key
{       (all_commands, ac)
{       (primary_commands, pc)
{     keyend = primary_commands
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 10] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 4] of clt$keyword_specification,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (16),
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 4, 21, 12, 1, 3, 419],
    clc$command, 10, 5, 1, 0, 0, 0, 5, 'OSM$ADMSA_ACTJA'], [
    ['COMMAND_SOURCE                 ',clc$nominal_entry, 4],
    ['CS                             ',clc$abbreviation_entry, 4],
    ['L                              ',clc$abbreviation_entry, 1],
    ['LOCK                           ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OPERATION                      ',clc$nominal_entry, 2],
    ['OPERATIONS                     ',clc$alias_entry, 2],
    ['R                              ',clc$abbreviation_entry, 3],
    ['RESULT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 5]],
    [
{ PARAMETER 1
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 235,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 155,
  clc$optional_default_parameter, 0, 16],
{ PARAMETER 5
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    171, [[1, 0, clc$list_type], [155, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [4], [
        ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['EXECUTE_PROGRAM                ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['PC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['PROCESS_COMMAND                ', clc$nominal_entry, clc$normal_usage_entry, 2]]
        ]
      ],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [5], [
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SUCCESSFUL                     ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['UNSUCCESSFUL                   ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'all'],
{ PARAMETER 4
    [[1, 0, clc$keyword_type], [4], [
    ['AC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['ALL_COMMANDS                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['PC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['PRIMARY_COMMANDS               ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'primary_commands'],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$lock = 1,
      p$operation = 2,
      p$result = 3,
      p$command_source = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    VAR
      audit_selection_criteria: ^sft$audit_selection_criteria,
      audited_operation_set: sft$audited_operation_set;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH audit_selection_criteria: [1 .. 2];
    get_result_criteria (pvt [p$result].value, audit_selection_criteria^ [1]);
    get_command_source_criteria (pvt [p$command_source].value, audit_selection_criteria^ [2]);

    get_job_audit_operation_set (pvt [p$operation].value, audited_operation_set);

    sfp$activate_audit (audited_operation_set, audit_selection_criteria^, routing_control_table_id,
          pvt [p$lock].value^.boolean_value.value, status);

  PROCEND sfp$_activate_job_auditing;
?? OLDTITLE ??
?? NEWTITLE := 'sfp$_activate_statistic', EJECT ??

{ PURPOSE:
{   This procedure initiates the ACTIVATE_STATISTIC subcommand.

  PROCEDURE sfp$_activate_statistic
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admsa_acts) activate_statistic, acts (
{   lock, l: boolean = $required
{   statistic, statistics, s: list of statistic_code = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 1, 14, 57, 56, 384],
    clc$command, 6, 3, 2, 0, 0, 0, 3, 'OSM$ADMSA_ACTS'], [
    ['L                              ',clc$abbreviation_entry, 1],
    ['LOCK                           ',clc$nominal_entry, 1],
    ['S                              ',clc$abbreviation_entry, 2],
    ['STATISTIC                      ',clc$nominal_entry, 2],
    ['STATISTICS                     ',clc$alias_entry, 2],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type]],
{ PARAMETER 2
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$statistic_code_type]]
    ],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$lock = 1,
      p$statistic = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      current_parameter_value: ^clt$data_value,
      statistic_name: ost$name;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_parameter_value := pvt [p$statistic].value;

    WHILE current_parameter_value <> NIL DO
      sfp$convert_stat_code_to_name (current_parameter_value^.element_value^.statistic_code_value,
            statistic_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF routing_control_table_id = sfc$sys_routing_control_table THEN
        sfp$activate_system_statistic (current_parameter_value^.element_value^.statistic_code_value,
              $sft$binary_logset [pmc$security_log], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF pvt [p$lock].value^.boolean_value.value THEN
          sfp$lock_statistic (current_parameter_value^.element_value^.statistic_code_value,
                $sft$binary_logset [pmc$security_log], routing_control_table_id, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      ELSE
        sfp$activate_job_statistic (current_parameter_value^.element_value^.statistic_code_value,
              $sft$binary_logset [pmc$security_log], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        IF pvt [p$lock].value^.boolean_value.value THEN
          sfp$lock_statistic (current_parameter_value^.element_value^.statistic_code_value,
                $sft$binary_logset [pmc$security_log], routing_control_table_id, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;

      current_parameter_value := current_parameter_value^.link;
    WHILEND;

  PROCEND sfp$_activate_statistic;
?? OLDTITLE ??
?? NEWTITLE := 'sfp$_activate_validation_auditi', EJECT ??

{ PURPOSE:
{   This procedure initiates the ACTIVATE_VALIDATION_AUDITING subcommand.

  PROCEDURE sfp$_activate_validation_auditi
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admsa_actva) activate_validation_auditing, actva (
{   lock, l: boolean = $required
{   operation, operations, o: any of
{       list of key
{         (manage_field, mf)
{         (manage_security_password, mspw)
{         (manage_validation, mv)
{         (use_capability, uc)
{         (user_validation, uv)
{       keyend
{       key
{         all
{       keyend
{     anyend = all
{   result, r: key
{       (successful, s)
{       (unsuccessful, u)
{       all
{     keyend = all
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
      recend,
      type2: 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 10] of clt$keyword_specification,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 5] of clt$keyword_specification,
        default_value: string (3),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 4, 12, 17, 12, 37, 546],
    clc$command, 8, 4, 1, 0, 0, 0, 4, 'OSM$ADMSA_ACTVA'], [
    ['L                              ',clc$abbreviation_entry, 1],
    ['LOCK                           ',clc$nominal_entry, 1],
    ['O                              ',clc$abbreviation_entry, 2],
    ['OPERATION                      ',clc$nominal_entry, 2],
    ['OPERATIONS                     ',clc$alias_entry, 2],
    ['R                              ',clc$abbreviation_entry, 3],
    ['RESULT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 457,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 3
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 192,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$boolean_type]],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    393, [[1, 0, clc$list_type], [377, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [10], [
        ['MANAGE_FIELD                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['MANAGE_SECURITY_PASSWORD       ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['MANAGE_VALIDATION              ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['MF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['MSPW                           ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['MV                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['UC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['USER_VALIDATION                ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['USE_CAPABILITY                 ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['UV                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5]]
        ]
      ],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'all'],
{ PARAMETER 3
    [[1, 0, clc$keyword_type], [5], [
    ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 3],
    ['S                              ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
    ['SUCCESSFUL                     ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['U                              ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
    ['UNSUCCESSFUL                   ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ,
    'all'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$lock = 1,
      p$operation = 2,
      p$result = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      audit_selection_criteria: ^sft$audit_selection_criteria,
      audited_operation_set: sft$audited_operation_set;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    PUSH audit_selection_criteria: [1 .. 1];
    get_result_criteria (pvt [p$result].value, audit_selection_criteria^ [1]);

    get_val_audit_operation_set (pvt [p$operation].value, audited_operation_set);

    sfp$activate_audit (audited_operation_set, audit_selection_criteria^, routing_control_table_id,
          pvt [p$lock].value^.boolean_value.value, status);

  PROCEND sfp$_activate_validation_auditi;
?? OLDTITLE ??
?? NEWTITLE := 'sfp$_deactivate_file_auditing', EJECT ??

{ PURPOSE:
{   This procedure initiates the DEACTIVATE_FILE_AUDITING subcommand.

  PROCEDURE sfp$_deactivate_file_auditing
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admsa_deafa) deactivate_file_auditing, deafa (
{   operation, operations, o: any of
{       list of key
{         (attach_file, af)
{         (load_fap, lf)
{         (manage_object, mo)
{         (manage_permit, mp)
{         (mount_removable_media, mrm)
{       keyend
{       key
{         all
{       keyend
{     anyend = all
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 10] of clt$keyword_specification,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 6, 29, 10, 26, 21, 527],
    clc$command, 4, 2, 0, 0, 0, 0, 2, 'OSM$ADMSA_DEAFA'], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OPERATION                      ',clc$nominal_entry, 1],
    ['OPERATIONS                     ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 457,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    393, [[1, 0, clc$list_type], [377, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [10], [
        ['AF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['ATTACH_FILE                    ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['LF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['LOAD_FAP                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['MANAGE_OBJECT                  ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['MANAGE_PERMIT                  ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['MO                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['MOUNT_REMOVABLE_MEDIA          ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['MP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['MRM                            ', clc$abbreviation_entry, clc$normal_usage_entry, 5]]
        ]
      ],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$operation = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      audited_operation_set: sft$audited_operation_set;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_fs_audit_operation_set (pvt [p$operation].value, audited_operation_set);

    sfp$deactivate_audit (audited_operation_set, routing_control_table_id, status);

  PROCEND sfp$_deactivate_file_auditing;
?? OLDTITLE ??
?? NEWTITLE := 'sfp$_deactivate_job_auditing', EJECT ??

{ PURPOSE:
{   This procedure initiates the DEACTIVATE_JOB_AUDITING subcommand.

  PROCEDURE sfp$_deactivate_job_auditing
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admsa_deaja) deactivate_job_auditing, deaja (
{   operation, operations, o: any of
{       list of key
{         (execute_program, ep)
{         (process_command, pc)
{       keyend
{       key
{         all
{       keyend
{     anyend = all
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 4] of clt$keyword_specification,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 4, 12, 17, 17, 39, 739],
    clc$command, 4, 2, 0, 0, 0, 0, 2, 'OSM$ADMSA_DEAJA'], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OPERATION                      ',clc$nominal_entry, 1],
    ['OPERATIONS                     ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 235,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    171, [[1, 0, clc$list_type], [155, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [4], [
        ['EP                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['EXECUTE_PROGRAM                ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['PC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['PROCESS_COMMAND                ', clc$nominal_entry, clc$normal_usage_entry, 2]]
        ]
      ],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$operation = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      audited_operation_set: sft$audited_operation_set;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_job_audit_operation_set (pvt [p$operation].value, audited_operation_set);

    sfp$deactivate_audit (audited_operation_set, routing_control_table_id, status);

  PROCEND sfp$_deactivate_job_auditing;
?? OLDTITLE ??
?? NEWTITLE := 'sfp$_deactivate_statistic', EJECT ??

{ PURPOSE:
{   This procedure initiates the DEACTIVATE_STATISTIC subcommand.

  PROCEDURE sfp$_deactivate_statistic
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admsa_deas) deactivate_statistic, deas (
{   statistic, statistics, s: list of statistic_code = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 3, 16, 5, 33, 368],
    clc$command, 4, 2, 1, 0, 0, 0, 2, 'OSM$ADMSA_DEAS'], [
    ['S                              ',clc$abbreviation_entry, 1],
    ['STATISTIC                      ',clc$nominal_entry, 1],
    ['STATISTICS                     ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$statistic_code_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$statistic = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      current_parameter_value: ^clt$data_value,
      statistic_name: ost$name;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_parameter_value := pvt [p$statistic].value;

    WHILE current_parameter_value <> NIL DO
      sfp$convert_stat_code_to_name (current_parameter_value^.element_value^.statistic_code_value,
            statistic_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF routing_control_table_id = sfc$sys_routing_control_table THEN
        sfp$deactivate_system_statistic (current_parameter_value^.element_value^.statistic_code_value,
              $sft$binary_logset [pmc$security_log], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        sfp$deactivate_job_statistic (current_parameter_value^.element_value^.statistic_code_value,
              $sft$binary_logset [pmc$security_log], status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      current_parameter_value := current_parameter_value^.link;
    WHILEND;

  PROCEND sfp$_deactivate_statistic;
?? OLDTITLE ??
?? NEWTITLE := 'sfp$_display_audited_operations', EJECT ??

{ PURPOSE:
{   This procedure initiates the DISPLAY_AUDITED_OPERATIONS subcommand.

  PROCEDURE sfp$_display_audited_operations
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admsa_disao) display_audited_operations, disao (
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 3] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 4, 12, 17, 38, 33, 264],
    clc$command, 3, 2, 0, 0, 0, 0, 2, 'OSM$ADMSA_DISAO'], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;


    VAR
      current_audit_control: ^sft$audit_control,
      current_routing_control: ^sft$routing_control,
      display_control: clt$display_control,
      display_line: string (80),
      display_line_length: 0 .. 80,
      file_contents: amt$file_contents,
      ignore_status: ost$status,
      index: integer,
      ring_attributes: amt$ring_attributes,
      routing_control: ^sft$routing_control,
      scratch_segment: amt$segment_pointer,
      statistic_name: ost$name,
      work_area: ^SEQ ( * );

?? NEWTITLE := 'condition_handler', EJECT ??

{ PURPOSE:
{   This is a block exit condition handler that is used to insure that the scratch segment is deleted and
{   the output file is closed.

    PROCEDURE condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      mmp$delete_scratch_segment (scratch_segment, ignore_status);
      clp$close_display (display_control, ignore_status);

    PROCEND condition_handler;

?? OLDTITLE, EJECT ??
    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_block_exit_hndlr (^condition_handler);

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random, scratch_segment, status);
    #SPOIL (scratch_segment);
    RESET scratch_segment.sequence_pointer;
    work_area := scratch_segment.sequence_pointer;

    REPEAT
      sfp$get_audited_operations (routing_control_table_id, work_area, routing_control, status);
    UNTIL (status.normal) OR (status.condition <> sfe$call_again_job_recovered);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clv$titles_built := FALSE;
    clv$command_name := 'display_audited_operations';
    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    file_contents := amc$list;

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, file_contents,
          ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF ((display_control.page_format <> amc$burstable_form) AND
          (display_control.page_format <> amc$non_burstable_form)) THEN
      put_subtitle (display_control, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;


    current_routing_control := routing_control;
    WHILE current_routing_control <> NIL DO
      sfp$convert_stat_code_to_name (current_routing_control^.statistic_code, statistic_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF current_routing_control^.audit_control_p <> NIL THEN
        current_audit_control := current_routing_control^.audit_control_p;
        WHILE current_audit_control <> NIL DO
          display_line := ' ';
          display_line (stat_name_column_start, stat_name_column_width) := statistic_name;
          IF current_audit_control^.locked THEN
            display_line (locked_column_start, locked_column_width) := 'Yes ';
          ELSE
            display_line (locked_column_start, locked_column_width) := 'No  ';
          IFEND;
          display_line (operation_column_start, operation_column_width) :=
                audit_operation_name [current_audit_control^.operation];

        /process_selection_criteria/
          FOR index := 1 TO UPPERBOUND (current_audit_control^.selection_criteria) DO
            IF current_audit_control^.selection_criteria [index].selector = sfc$as_null_selector THEN
              IF UPPERBOUND (current_audit_control^.selection_criteria) = 1 THEN
                clp$put_display (display_control, display_line (1, clp$trimmed_string_size (display_line)),
                      clc$trim, {ignore} status);
              IFEND;
              CYCLE /process_selection_criteria/;
            ELSEIF ((current_audit_control^.operation <> sfc$ao_fs_attach_file) AND
                  (current_audit_control^.selection_criteria [index].selector = sfc$as_access_mode_set)) THEN
              CYCLE /process_selection_criteria/;
            ELSEIF ((current_audit_control^.operation <> sfc$ao_job_process_command) AND
                  (current_audit_control^.selection_criteria [index].selector = sfc$as_command_source_set))
                  THEN
              CYCLE /process_selection_criteria/;
            ELSEIF ((current_audit_control^.operation IN
                  $sft$audited_operation_set[sfc$ao_fs_magnetic_tape_mount, sfc$ao_fs_load_fap]) AND
                  (current_audit_control^.selection_criteria [index].selector = sfc$as_catalog_owner_set))
                  THEN
              CYCLE /process_selection_criteria/;
            IFEND;

            display_line (criteria_column_start, criteria_column_width) :=
                  audit_selector_name [current_audit_control^.selection_criteria [index].selector];
            clp$put_display (display_control, display_line (1, clp$trimmed_string_size (display_line)),
                  clc$trim, {ignore} status);
            display_line := ' ';
            CASE current_audit_control^.selection_criteria [index].selector OF
            = sfc$as_operation_result_set =
              IF sfc$or_successful IN current_audit_control^.selection_criteria [index].
                    operation_result_set THEN
                display_line (subcriteria_column_start, subcriteria_column_width) :=
                      operation_result_name [sfc$or_successful];
                clp$put_display (display_control, display_line (1, clp$trimmed_string_size (display_line)),
                      clc$trim, {ignore} status);
              IFEND;
              IF sfc$or_unsuccessful IN current_audit_control^.selection_criteria [index].
                    operation_result_set THEN
                display_line (subcriteria_column_start, subcriteria_column_width) :=
                      operation_result_name [sfc$or_unsuccessful];
                clp$put_display (display_control, display_line (1, clp$trimmed_string_size (display_line)),
                      clc$trim, {ignore} status);
              IFEND;
            = sfc$as_command_source_set =
              IF sfc$cs_primary_command_file IN current_audit_control^.selection_criteria [index].
                    command_source_set THEN
                display_line (subcriteria_column_start, subcriteria_column_width) :=
                      command_source_name [sfc$cs_primary_command_file];
                clp$put_display (display_control, display_line (1, clp$trimmed_string_size (display_line)),
                      clc$trim, {ignore} status);
              IFEND;
              IF sfc$cs_secondary_command_file IN current_audit_control^.selection_criteria [index].
                    command_source_set THEN
                display_line (subcriteria_column_start, subcriteria_column_width) :=
                      command_source_name [sfc$cs_secondary_command_file];
                clp$put_display (display_control, display_line (1, clp$trimmed_string_size (display_line)),
                      clc$trim, {ignore} status);
              IFEND;
            = sfc$as_access_mode_set =
              IF pfc$read IN current_audit_control^.selection_criteria [index].access_mode_set THEN
                display_line (subcriteria_column_start, subcriteria_column_width) :=
                      access_mode_name [pfc$read];
                clp$put_display (display_control, display_line (1, clp$trimmed_string_size (display_line)),
                      clc$trim, {ignore} status);
              IFEND;
              IF pfc$shorten IN current_audit_control^.selection_criteria [index].access_mode_set THEN
                display_line (subcriteria_column_start, subcriteria_column_width) :=
                      access_mode_name [pfc$shorten];
                clp$put_display (display_control, display_line (1, clp$trimmed_string_size (display_line)),
                      clc$trim, {ignore} status);
              IFEND;
              IF pfc$append IN current_audit_control^.selection_criteria [index].access_mode_set THEN
                display_line (subcriteria_column_start, subcriteria_column_width) :=
                      access_mode_name [pfc$append];
                clp$put_display (display_control, display_line (1, clp$trimmed_string_size (display_line)),
                      clc$trim, {ignore} status);
              IFEND;
              IF pfc$modify IN current_audit_control^.selection_criteria [index].access_mode_set THEN
                display_line (subcriteria_column_start, subcriteria_column_width) :=
                      access_mode_name [pfc$modify];
                clp$put_display (display_control, display_line (1, clp$trimmed_string_size (display_line)),
                      clc$trim, {ignore} status);
              IFEND;
              IF pfc$execute IN current_audit_control^.selection_criteria [index].access_mode_set THEN
                display_line (subcriteria_column_start, subcriteria_column_width) :=
                      access_mode_name [pfc$execute];
                clp$put_display (display_control, display_line (1, clp$trimmed_string_size (display_line)),
                      clc$trim, {ignore} status);
              IFEND;
            = sfc$as_catalog_owner_set =
              IF sfc$co_owner IN current_audit_control^.selection_criteria [index].catalog_owner_set THEN
                display_line (subcriteria_column_start, subcriteria_column_width) :=
                      catalog_owner_name [sfc$co_owner];
                clp$put_display (display_control, display_line (1, clp$trimmed_string_size (display_line)),
                      clc$trim, {ignore} status);
              IFEND;
              IF sfc$co_non_owner IN current_audit_control^.selection_criteria [index].catalog_owner_set THEN
                display_line (subcriteria_column_start, subcriteria_column_width) :=
                      catalog_owner_name [sfc$co_non_owner];
                clp$put_display (display_control, display_line (1, clp$trimmed_string_size (display_line)),
                      clc$trim, {ignore} status);
              IFEND;
              IF sfc$co_system IN current_audit_control^.selection_criteria [index].catalog_owner_set THEN
                display_line (subcriteria_column_start, subcriteria_column_width) :=
                      catalog_owner_name [sfc$co_system];
                clp$put_display (display_control, display_line (1, clp$trimmed_string_size (display_line)),
                      clc$trim, {ignore} status);
              IFEND;
            ELSE
            CASEND;
            display_line := ' ';
          FOREND /process_selection_criteria/;
          current_audit_control := current_audit_control^.forward;
        WHILEND;
      ELSE
        display_line := ' ';
        display_line (stat_name_column_start, stat_name_column_width) := statistic_name;
        IF pmc$security_log IN current_routing_control^.locked_logs THEN
          display_line (locked_column_start, locked_column_width) := 'Yes ';
        ELSE
          display_line (locked_column_start, locked_column_width) := 'No  ';
        IFEND;
        clp$put_display (display_control, display_line (1, clp$trimmed_string_size (display_line)), clc$trim,
              {ignore} status);
      IFEND;
      clp$put_display (display_control, ' ', clc$trim, {ignore} status);
      current_routing_control := current_routing_control^.forward;
    WHILEND;

    osp$disestablish_cond_handler;

    mmp$delete_scratch_segment (scratch_segment, status);
    IF NOT status.normal THEN
      clp$close_display (display_control, ignore_status);
    ELSE
      clp$close_display (display_control, status);
    IFEND;

  PROCEND sfp$_display_audited_operations;
?? OLDTITLE ??
?? NEWTITLE := 'sfp$_deactivate_validation_audi', EJECT ??

{ PURPOSE:
{   This procedure initiates the DEACTIVATE_VALIDATION_AUDITING subcommand.

  PROCEDURE sfp$_deactivate_validation_audi
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admsa_deava) deactivate_validation_auditing, deava (
{   operation, operations, o: any of
{       list of key
{         (manage_field, mf)
{         (manage_security_password, mspw)
{         (manage_validation, mv)
{         (use_capability, uc)
{         (user_validation, uv)
{       keyend
{       key
{         all
{       keyend
{     anyend = all
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 4] of clt$pdt_parameter_name,
      parameters: array [1 .. 2] 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$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 10] of clt$keyword_specification,
          recend,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 1] of clt$keyword_specification,
        recend,
        default_value: string (3),
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 4, 12, 17, 20, 20, 254],
    clc$command, 4, 2, 0, 0, 0, 0, 2, 'OSM$ADMSA_DEAVA'], [
    ['O                              ',clc$abbreviation_entry, 1],
    ['OPERATION                      ',clc$nominal_entry, 1],
    ['OPERATIONS                     ',clc$alias_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 2]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 457,
  clc$optional_default_parameter, 0, 3],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$keyword_type, clc$list_type],
    FALSE, 2],
    393, [[1, 0, clc$list_type], [377, 1, clc$max_list_size, FALSE],
        [[1, 0, clc$keyword_type], [10], [
        ['MANAGE_FIELD                   ', clc$nominal_entry, clc$normal_usage_entry, 1],
        ['MANAGE_SECURITY_PASSWORD       ', clc$nominal_entry, clc$normal_usage_entry, 2],
        ['MANAGE_VALIDATION              ', clc$nominal_entry, clc$normal_usage_entry, 3],
        ['MF                             ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
        ['MSPW                           ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
        ['MV                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
        ['UC                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
        ['USER_VALIDATION                ', clc$nominal_entry, clc$normal_usage_entry, 5],
        ['USE_CAPABILITY                 ', clc$nominal_entry, clc$normal_usage_entry, 4],
        ['UV                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5]]
        ]
      ],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 1]]
      ]
    ,
    'all'],
{ PARAMETER 2
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$operation = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      audited_operation_set: sft$audited_operation_set;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_val_audit_operation_set (pvt [p$operation].value, audited_operation_set);

    sfp$deactivate_audit (audited_operation_set, routing_control_table_id, status);

  PROCEND sfp$_deactivate_validation_audi;
?? OLDTITLE ??
?? NEWTITLE := 'sfp$_end_administer_security_au', EJECT ??

{ PURPOSE:
{   This is the command processor for the END_ADMINISTER_VALIDATIONS subcommand.

  PROCEDURE sfp$_end_administer_security_au
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$admsa_endasa) quit, end_administer_security_audit, endasa, qui

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
    recend := [
    [1,
    [89, 4, 12, 17, 35, 34, 904],
    clc$command, 0, 0, 0, 0, 0, 0, 0, 'OSM$ADMSA_ENDASA']];

?? FMT (FORMAT := ON) ??
?? POP ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, NIL, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_include (avc$admsa_utility_name, status);

  PROCEND sfp$_end_administer_security_au;
?? OLDTITLE ??
?? OLDTITLE ??
MODEND sfm$security_audit_utility;
*DECK DECK=SFM$STATISTIC_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Statistics Facility: Statistic Command Processors' ??
MODULE sfm$statistic_commands;

{ PURPOSE
{   This module contains SCL command processors to update and retrieve system and job routing control
{   information.
{
{ DESIGN:
{   The command processors in this module simply convert the parameter values specified on the command into
{   their internal formats (when necessary) and call the appropriate statistics facility program interface.
?? NEWTITLE := 'Global declarations referenced by this module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$path_display_chunks
*copyc sfe$call_again_job_recovered
*copyc sfe$unknown_display_command
*copyc sfe$unknown_log
*copyc sft$binary_logs
?? POP ??
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$count_list_elements
*copyc clp$evaluate_parameters
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$put_partial_display
*copyc clp$reset_for_next_display_page
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc sfp$activate_job_statistic
*copyc sfp$activate_system_statistic
*copyc sfp$convert_stat_code_to_name
*copyc sfp$convert_stat_name_to_code
*copyc sfp$deactivate_job_statistic
*copyc sfp$deactivate_system_statistic
*copyc sfp$emit_statistic
*copyc sfp$get_active_job_statistics
*copyc sfp$get_active_system_stats
*copyc sfp$get_log_name
*copyc sfp$lock_statistic
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_log_set', EJECT ??

{ PURPOSE:
{   Translate the keyword values for logs into a set of logs.

  PROCEDURE [INLINE] get_log_set
    (    parameter_name: string ( * <= osc$max_name_size);
         parameter_value: ^clt$data_value;
     VAR logs: sft$binary_logset;
     VAR status: ost$status);

    VAR
      current_parameter_value: ^clt$data_value;

    status.normal := TRUE;

    logs := $sft$binary_logset [];

    current_parameter_value := parameter_value;
    REPEAT
      IF (current_parameter_value^.element_value^.keyword_value = 'JOB_STATISTIC_LOG') THEN
        logs := logs + $sft$binary_logset [pmc$job_statistic_log];
      ELSEIF (current_parameter_value^.element_value^.keyword_value = 'STATISTIC_LOG') THEN
        logs := logs + $sft$binary_logset [pmc$statistic_log];
      ELSEIF (current_parameter_value^.element_value^.keyword_value = 'SECURITY_LOG') THEN
        logs := logs + $sft$binary_logset [pmc$security_log];
      ELSEIF (current_parameter_value^.element_value^.keyword_value = 'JOB_ACCOUNT_LOG') THEN
        logs := logs + $sft$binary_logset [pmc$job_account_log];
      ELSEIF (current_parameter_value^.element_value^.keyword_value = 'ACCOUNT_LOG') THEN
        logs := logs + $sft$binary_logset [pmc$account_log];
      ELSEIF (current_parameter_value^.element_value^.keyword_value = 'ENGINEERING_LOG') THEN
        logs := logs + $sft$binary_logset [pmc$engineering_log];
      ELSEIF (current_parameter_value^.element_value^.keyword_value = 'HISTORY_LOG') THEN
        logs := logs + $sft$binary_logset [pmc$history_log];
      ELSEIF current_parameter_value^.element_value^.keyword_value = 'ALL' THEN
        IF clp$count_list_elements (parameter_value) <> 1 THEN
          osp$set_status_abnormal ('SF', cle$all_must_be_used_alone, parameter_name, status);
          RETURN;
        ELSE
          logs := -$sft$binary_logset [];
          RETURN;
        IFEND;
      ELSE
        osp$set_status_abnormal ('SF', sfe$unknown_log, current_parameter_value^.element_value^.keyword_value,
              status);
        RETURN;
      IFEND;
      current_parameter_value := current_parameter_value^.link;
    UNTIL current_parameter_value = NIL;

  PROCEND get_log_set;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] sfp$_activate_job_statistic', EJECT ??

{ PURPOSE:
{   Command processor for the ACTIVATE_JOB_STATISTIC_COMMAND.

  PROCEDURE [XDCL] sfp$_activate_job_statistic
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$actjs) activate_job_statistic, activate_job_statistics, actjs (
{   statistics, statistic, s: list of statistic_code = $required
{   logs, log, l: list of key
{       (job_account_log, jal)
{       (job_statistic_log, jsl)
{       (account_log, al)
{       (engineering_log, el)
{       (history_log, hl)
{       (statistic_log, sl)
{     keyend = job_statistic_log
{   lock: (BY_NAME) boolean = false
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 12] of clt$keyword_specification,
        recend,
        default_value: string (17),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 7, 8, 44, 15, 478],
    clc$command, 8, 4, 1, 0, 0, 0, 4, 'OSM$ACTJS'], [
    ['L                              ',clc$abbreviation_entry, 2],
    ['LOCK                           ',clc$nominal_entry, 3],
    ['LOG                            ',clc$alias_entry, 2],
    ['LOGS                           ',clc$nominal_entry, 2],
    ['S                              ',clc$abbreviation_entry, 1],
    ['STATISTIC                      ',clc$alias_entry, 1],
    ['STATISTICS                     ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 467,
  clc$optional_default_parameter, 0, 17],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$statistic_code_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [451, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [12], [
      ['ACCOUNT_LOG                    ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['AL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['EL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['ENGINEERING_LOG                ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['HISTORY_LOG                    ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['HL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['JAL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['JOB_ACCOUNT_LOG                ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['JOB_STATISTIC_LOG              ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['JSL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['SL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['STATISTIC_LOG                  ', clc$nominal_entry, clc$normal_usage_entry, 6]]
      ]
    ,
    'job_statistic_log'],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$statistics = 1,
      p$logs = 2,
      p$lock = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      current_parameter_value: ^clt$data_value,
      logs: sft$binary_logset,
      statistic_code: sft$statistic_code,
      statistic_name: ost$name;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_log_set ('LOGS', pvt [p$logs].value, logs, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_parameter_value := pvt [p$statistics].value;
    REPEAT
      statistic_code := current_parameter_value^.element_value^.statistic_code_value;

      sfp$convert_stat_code_to_name (statistic_code, statistic_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      sfp$activate_job_statistic (statistic_code, logs, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF pvt [p$lock].value^.boolean_value.value THEN
        sfp$lock_statistic (statistic_code, logs, sfc$job_routing_control_table, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      current_parameter_value := current_parameter_value^.link;
    UNTIL current_parameter_value = NIL;

  PROCEND sfp$_activate_job_statistic;
?? OLDTITLE ??
?? TITLE := 'sfp$activate_sys_stat_command', EJECT ??

{ PURPOSE:
{   This is the command processor for the ACTIVATE_SYSTEM_STATISTIC command.

  PROCEDURE [XDCL,#GATE] sfp$activate_sys_stat_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$actss) activate_system_statistic, activate_system_statistics, actss (
{   statistics, statistic, s: list of statistic_code = $required
{   logs, log, l: list of key
{       (job_account_log, jal)
{       (job_statistic_log, jsl)
{       (account_log, al)
{       (engineering_log, el)
{       (history_log, hl)
{       (statistic_log, sl)
{     keyend = statistic_log
{   lock: (BY_NAME) boolean = false
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 8] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 12] of clt$keyword_specification,
        recend,
        default_value: string (13),
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (5),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 7, 8, 45, 10, 410],
    clc$command, 8, 4, 1, 0, 0, 0, 4, 'OSM$ACTSS'], [
    ['L                              ',clc$abbreviation_entry, 2],
    ['LOCK                           ',clc$nominal_entry, 3],
    ['LOG                            ',clc$alias_entry, 2],
    ['LOGS                           ',clc$nominal_entry, 2],
    ['S                              ',clc$abbreviation_entry, 1],
    ['STATISTIC                      ',clc$alias_entry, 1],
    ['STATISTICS                     ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 19, clc$required_parameter,
  0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 467,
  clc$optional_default_parameter, 0, 13],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 5],
{ PARAMETER 4
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$statistic_code_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [451, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [12], [
      ['ACCOUNT_LOG                    ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['AL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['EL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['ENGINEERING_LOG                ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['HISTORY_LOG                    ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['HL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['JAL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['JOB_ACCOUNT_LOG                ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['JOB_STATISTIC_LOG              ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['JSL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['SL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 6],
      ['STATISTIC_LOG                  ', clc$nominal_entry, clc$normal_usage_entry, 6]]
      ]
    ,
    'statistic_log'],
{ PARAMETER 3
    [[1, 0, clc$boolean_type],
    'false'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$statistics = 1,
      p$logs = 2,
      p$lock = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      current_parameter_value: ^clt$data_value,
      logs: sft$binary_logset,
      statistic_code: sft$statistic_code,
      statistic_name: ost$name;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_log_set ('LOGS', pvt [p$logs].value, logs, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_parameter_value := pvt [p$statistics].value;
    REPEAT
      statistic_code := current_parameter_value^.element_value^.statistic_code_value;

      sfp$convert_stat_code_to_name (statistic_code, statistic_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      sfp$activate_system_statistic (statistic_code, logs, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF pvt [p$lock].value^.boolean_value.value THEN
        sfp$lock_statistic (statistic_code, logs, sfc$sys_routing_control_table, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
      current_parameter_value := current_parameter_value^.link;
    UNTIL current_parameter_value = NIL;

  PROCEND sfp$activate_sys_stat_command;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] sfp$_deactivate_job_statistic', EJECT ??

{ PURPOSE:
{   This is the command processor for the DEACTIVATE_JOB_STATISTIC command.

  PROCEDURE [XDCL] sfp$_deactivate_job_statistic
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$deajs) deactivate_job_statistic, deactivate_job_statistics, deajs (
{   statistics, statistic, s: list of statistic_code = $required
{   logs, log, l: list of key
{       (job_account_log, jal)
{       (job_statistic_log, jsl)
{       (account_log, al)
{       (engineering_log, el)
{       (history_log, hl)
{       (statistic_log, sl)
{     keyend = job_statistic_log
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 12] of clt$keyword_specification,
          recend,
          default_value: string (17),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 24, 8, 50, 34, 672], clc$command, 7, 3, 1, 0, 0, 0, 3, 'OSM$DEAJS'],
            [['L                              ', clc$abbreviation_entry, 2],
            ['LOG                            ', clc$alias_entry, 2],
            ['LOGS                           ', clc$nominal_entry, 2],
            ['S                              ', clc$abbreviation_entry, 1],
            ['STATISTIC                      ', clc$alias_entry, 1],
            ['STATISTICS                     ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 19, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 467, clc$optional_default_parameter, 0, 17],

{ PARAMETER 3

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE], [[1, 0, clc$statistic_code_type]]],

{ PARAMETER 2

      [[1, 0, clc$list_type], [451, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [12], [['ACCOUNT_LOG                    ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['AL                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['EL                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['ENGINEERING_LOG                ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['HISTORY_LOG                    ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['HL                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['JAL                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['JOB_ACCOUNT_LOG                ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['JOB_STATISTIC_LOG              ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['JSL                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SL                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['STATISTIC_LOG                  ', clc$nominal_entry,
            clc$normal_usage_entry, 6]]], 'job_statistic_log'],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$statistics = 1,
      p$logs = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      current_parameter_value: ^clt$data_value,
      logs: sft$binary_logset,
      statistic_code: sft$statistic_code,
      statistic_name: ost$name;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_log_set ('LOGS', pvt [p$logs].value, logs, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_parameter_value := pvt [p$statistics].value;
    REPEAT
      statistic_code := current_parameter_value^.element_value^.statistic_code_value;

      sfp$convert_stat_code_to_name (statistic_code, statistic_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      sfp$deactivate_job_statistic (statistic_code, logs, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      current_parameter_value := current_parameter_value^.link;
    UNTIL current_parameter_value = NIL;

  PROCEND sfp$_deactivate_job_statistic;
?? OLDTITLE ??
?? TITLE := 'sfp$deactivate_sys_stat_command', EJECT ??

{ PURPOSE:
{   This is the command processor for the DEACTIVATE_SYSTEM_STATISTIC command.

  PROCEDURE [XDCL,#GATE] sfp$deactivate_sys_stat_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$deass) deactivate_system_statistic, deactivate_system_statistics, deass (
{   statistics, statistic, s: list of statistic_code = $required
{   logs, log, l: list of key
{       (job_account_log, jal)
{       (job_statistic_log, jsl)
{       (account_log, al)
{       (engineering_log, el)
{       (history_log, hl)
{       (statistic_log, sl)
{     keyend = statistic_log
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 7] of clt$pdt_parameter_name,
        parameters: array [1 .. 3] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 12] of clt$keyword_specification,
          recend,
          default_value: string (13),
        recend,
        type3: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 24, 8, 54, 21, 708], clc$command, 7, 3, 1, 0, 0, 0, 3, 'OSM$DEASS'],
            [['L                              ', clc$abbreviation_entry, 2],
            ['LOG                            ', clc$alias_entry, 2],
            ['LOGS                           ', clc$nominal_entry, 2],
            ['S                              ', clc$abbreviation_entry, 1],
            ['STATISTIC                      ', clc$alias_entry, 1],
            ['STATISTICS                     ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 3]], [

{ PARAMETER 1

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 19, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 467, clc$optional_default_parameter, 0, 13],

{ PARAMETER 3

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE], [[1, 0, clc$statistic_code_type]]],

{ PARAMETER 2

      [[1, 0, clc$list_type], [451, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$keyword_type], [12], [['ACCOUNT_LOG                    ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['AL                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 3], ['EL                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 4], ['ENGINEERING_LOG                ', clc$nominal_entry,
            clc$normal_usage_entry, 4], ['HISTORY_LOG                    ', clc$nominal_entry,
            clc$normal_usage_entry, 5], ['HL                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 5], ['JAL                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['JOB_ACCOUNT_LOG                ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['JOB_STATISTIC_LOG              ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['JSL                            ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['SL                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 6], ['STATISTIC_LOG                  ', clc$nominal_entry,
            clc$normal_usage_entry, 6]]], 'statistic_log'],

{ PARAMETER 3

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$statistics = 1,
      p$logs = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      current_parameter_value: ^clt$data_value,
      logs: sft$binary_logset,
      statistic_code: sft$statistic_code,
      statistic_name: ost$name;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_log_set ('LOGS', pvt [p$logs].value, logs, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current_parameter_value := pvt [p$statistics].value;
    REPEAT
      statistic_code := current_parameter_value^.element_value^.statistic_code_value;

      sfp$convert_stat_code_to_name (statistic_code, statistic_name, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      sfp$deactivate_system_statistic (statistic_code, logs, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      current_parameter_value := current_parameter_value^.link;
    UNTIL current_parameter_value = NIL;

  PROCEND sfp$deactivate_sys_stat_command;
?? OLDTITLE ??
?? NEWTITLE := 'display_active_statistics', EJECT ??

{ PURPOSE:
{   This procedure performs the actual processing for both
{   DISPLAY_ACTIVE_JOB_STATISTICS and DISPLAY_ACTIVE_SYSTEM_STATS.

  PROCEDURE display_active_statistics
    (    command_name: ost$name;
         output: fst$file_reference;
         logs: sft$binary_logset;
     VAR status: ost$status);

    VAR
      current_log: sft$binary_logs,
      current_log_name: ost$name,
      current_routing_control: ^sft$routing_control,
      display_control: clt$display_control,
      file_contents: amt$file_contents,
      first_routing_control: ^sft$routing_control,
      found_statistics: boolean,
      ring_attributes: amt$ring_attributes,
      segment_pointer: amt$segment_pointer,
      statistic_name: ost$name,
      work_area: ^SEQ ( * );

*copy clv$display_variables

?? NEWTITLE := 'Dummy title because of error in clp$new_page_procedure' ??
*copyc clp$new_page_procedure

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

{ Dummy subtitle procedure

    PROCEND put_subtitle;
?? OLDTITLE ??
?? NEWTITLE := 'block_exit_handler', EJECT ??

{ PURPOSE:
{   This block exit handler is used to close the display file and delete the
{   scratch segment used by the command processor in case of an abnormal exit.

    PROCEDURE block_exit_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      VAR
        ignore_status: ost$status;

      clp$close_display (display_control, ignore_status);

      mmp$delete_scratch_segment (segment_pointer, ignore_status);

    PROCEND block_exit_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    osp$establish_block_exit_hndlr (^block_exit_handler);

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET segment_pointer.sequence_pointer;
    work_area := segment_pointer.sequence_pointer;

    IF command_name = 'display_active_system_statistic' THEN
      REPEAT
        sfp$get_active_system_stats (logs, first_routing_control, work_area, status);
      UNTIL (status.normal) OR (status.condition <> sfe$call_again_job_recovered);
    ELSEIF command_name = 'display_active_job_statistic' THEN
      sfp$get_active_job_statistics (logs, first_routing_control, work_area, status);
    ELSE
      osp$set_status_abnormal ('SF', sfe$unknown_display_command, command_name, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clv$titles_built := FALSE;
    clv$command_name := command_name;
    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    file_contents := amc$list;

    clp$open_display_reference (output, ^clp$new_page_procedure, file_contents, ring_attributes,
          display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /process_logs/
    FOR current_log := LOWERVALUE (sft$binary_logs) TO UPPERVALUE (sft$binary_logs) DO
      IF current_log IN logs THEN

        found_statistics := FALSE;
        current_routing_control := first_routing_control;

        clp$put_display (display_control, ' ', clc$trim, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_partial_display (display_control, 'Statistics activated to ', clc$no_trim, amc$start, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        sfp$get_log_name (current_log, current_log_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        clp$put_partial_display (display_control, current_log_name, clc$trim, amc$continue, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        IF command_name = 'display_active_system_statistic' THEN
          clp$put_partial_display (display_control, ' by the system:', clc$trim, amc$terminate, status);
        ELSE
          clp$put_partial_display (display_control, ' by this job:', clc$trim, amc$terminate, status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        WHILE current_routing_control <> NIL DO
          IF current_log IN current_routing_control^.activated_logs THEN
            found_statistics := TRUE;

            sfp$convert_stat_code_to_name (current_routing_control^.statistic_code, statistic_name, status);
            IF NOT status.normal THEN
              EXIT /process_logs/;
            IFEND;

            clp$put_partial_display (display_control, '    ', clc$no_trim, amc$start, status);
            IF NOT status.normal THEN
              EXIT /process_logs/;
            IFEND;

            clp$put_partial_display (display_control, statistic_name, clc$trim, amc$continue, status);
            IF NOT status.normal THEN
              EXIT /process_logs/;
            IFEND;

            IF current_log IN current_routing_control^.locked_logs THEN
              clp$put_partial_display (display_control, ' (Locked)', clc$trim, amc$terminate, status);
            ELSE
              clp$put_partial_display (display_control, ' ', clc$trim, amc$terminate, status);
            IFEND;
            IF NOT status.normal THEN
              EXIT /process_logs/;
            IFEND;

          IFEND;
          current_routing_control := current_routing_control^.forward;
        WHILEND;

        IF NOT found_statistics THEN
          clp$put_display (display_control, ' No active statistics.', clc$trim, status);
        IFEND;

      IFEND;
    FOREND /process_logs/;

  PROCEND display_active_statistics;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] sfp$_display_active_job_statist', EJECT ??

{ PURPOSE:
{   This is the command processor for the DISPLAY_ACTIVE_JOB_STATISTICS command.

  PROCEDURE [XDCL] sfp$_display_active_job_statist
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$disajs) display_active_job_statistic, display_active_job_statistics, disajs (
{   output, o: file = $output
{   display_option, display_options, do: list of key
{       (job_account_log, jal)
{       (job_statistic_log, jsl)
{       (account_log, al)
{       (engineering_log, el)
{       (history_log, hl)
{       security_log
{       (statistic_log, sl)
{       all
{     keyend = job_statistic_log
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        default_value: string (17),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 6, 9, 27, 12, 222],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'OSM$DISAJS'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 541,
  clc$optional_default_parameter, 0, 17],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 2
    [[1, 0, clc$list_type], [525, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [14], [
      ['ACCOUNT_LOG                    ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['AL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['EL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['ENGINEERING_LOG                ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['HISTORY_LOG                    ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['HL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['JAL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['JOB_ACCOUNT_LOG                ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['JOB_STATISTIC_LOG              ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['JSL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['SECURITY_LOG                   ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['SL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['STATISTIC_LOG                  ', clc$nominal_entry, clc$normal_usage_entry, 7]]
      ]
    ,
    'job_statistic_log'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$display_option = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      logs: sft$binary_logset,
      output: clt$value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_log_set ('DISPLAY_OPTIONS', pvt [p$display_option].value, logs, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_active_statistics ('display_active_job_statistic   ', pvt [p$output].value^.file_value^, logs,
          status);

  PROCEND sfp$_display_active_job_statist;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] sfp$_display_active_system_stat', EJECT ??

{ PURPOSE:
{   This is the command processor for the DISPLAY_ACTIVE_SYSTEM_STATS command.

  PROCEDURE [XDCL] sfp$_display_active_system_stat
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (osm$disass) display_active_system_statistic, display_active_system_stats, disass (
{   output, o: file = $output
{   display_option, display_options, do: list of key
{       (job_account_log, jal)
{       (job_statistic_log, jsl)
{       (account_log, al)
{       (engineering_log, el)
{       (history_log, hl)
{       security_log
{       (statistic_log, sl)
{       all
{     keyend = job_statistic_log
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 6] of clt$pdt_parameter_name,
      parameters: array [1 .. 3] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 14] of clt$keyword_specification,
        recend,
        default_value: string (17),
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 5, 6, 9, 27, 44, 482],
    clc$command, 6, 3, 0, 0, 0, 0, 3, 'OSM$DISASS'], [
    ['DISPLAY_OPTION                 ',clc$nominal_entry, 2],
    ['DISPLAY_OPTIONS                ',clc$alias_entry, 2],
    ['DO                             ',clc$abbreviation_entry, 2],
    ['O                              ',clc$abbreviation_entry, 1],
    ['OUTPUT                         ',clc$nominal_entry, 1],
    ['STATUS                         ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 7],
{ PARAMETER 2
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 541,
  clc$optional_default_parameter, 0, 17],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 2
    [[1, 0, clc$list_type], [525, 1, clc$max_list_size, FALSE],
      [[1, 0, clc$keyword_type], [14], [
      ['ACCOUNT_LOG                    ', clc$nominal_entry, clc$normal_usage_entry, 3],
      ['AL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 3],
      ['ALL                            ', clc$nominal_entry, clc$normal_usage_entry, 8],
      ['EL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 4],
      ['ENGINEERING_LOG                ', clc$nominal_entry, clc$normal_usage_entry, 4],
      ['HISTORY_LOG                    ', clc$nominal_entry, clc$normal_usage_entry, 5],
      ['HL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 5],
      ['JAL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 1],
      ['JOB_ACCOUNT_LOG                ', clc$nominal_entry, clc$normal_usage_entry, 1],
      ['JOB_STATISTIC_LOG              ', clc$nominal_entry, clc$normal_usage_entry, 2],
      ['JSL                            ', clc$abbreviation_entry, clc$normal_usage_entry, 2],
      ['SECURITY_LOG                   ', clc$nominal_entry, clc$normal_usage_entry, 6],
      ['SL                             ', clc$abbreviation_entry, clc$normal_usage_entry, 7],
      ['STATISTIC_LOG                  ', clc$nominal_entry, clc$normal_usage_entry, 7]]
      ]
    ,
    'job_statistic_log'],
{ PARAMETER 3
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$output = 1,
      p$display_option = 2,
      p$status = 3;

    VAR
      pvt: array [1 .. 3] of clt$parameter_value;

    VAR
      logs: sft$binary_logset,
      output: clt$value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_log_set ('DISPLAY_OPTION', pvt [p$display_option].value, logs, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_active_statistics ('display_active_system_statistic', pvt [p$output].value^.file_value^, logs,
          status);

  PROCEND sfp$_display_active_system_stat;
?? OLDTITLE ??
MODEND sfm$statistic_commands;
*DECK DECK=SFM$STATISTIC_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Statistics Facility: Program Interfaces' ??
MODULE sfm$statistic_interfaces;

{ PURPOSE:
{   This module contains the external interfaces used to manipulate the system and job routing control tables,
{   emit statistics, and retrieve information from the system and job routing control tables.
{
{ DESIGN:
{   The interfaces in this module protect the information in the system and job routing control tables from
{   update or retrieval by unprivileged users.
{
{   The interfaces that update the system or job routing control tables call internal interfaces in the
{   statistics facility that execute in lower rings and are capable of locking the routing control tables.
{   Interfaces that retrieve information from the routing control tables do not call internal interfaces in
{   the statistics facility and do not interlock the routing control tables.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ofe$error_codes
*copyc osc$max_status_condition_number
*copyc ost$caller_identifier
*copyc ost$name
*copyc ost$status
*copyc ost$status_condition_number
*copyc ost$status_identifier
*copyc ost$string
*copyc sfc$statistic_version
*copyc sfe$call_again_job_recovered
*copyc sfe$counter_array_size_range
*copyc sfe$descriptive_data_size
*copyc sfe$incorrect_statistic_code
*copyc sfe$insufficient_privilege
*copyc sfe$invalid_statistic_name
*copyc sfe$limit_condition_codes
*copyc sfe$security_audit_not_enabled
*copyc sfe$statistics_not_available
*copyc sfe$too_much_data_for_statistic
*copyc sfe$unknown_routing_ctl_access
*copyc sfe$work_area_full
*copyc sft$audited_operation_set
*copyc sft$audit_selection_criteria
*copyc sft$binary_logs
*copyc sft$counters
*copyc sft$descriptive_data
*copyc sft$global_binary_logset
*copyc sft$routing_control_access
*copyc sft$routing_control_table_id
*copyc sft$statistic_buffer
*copyc sft$statistic_code
*copyc sft$statistic_group
*copyc sft$statistic_header
*copyc sft$statistic_identifier
?? POP ??
*copyc avp$accounting_administrator
*copyc avp$configuration_administrator
*copyc avp$security_option_active
*copyc avp$system_administrator
*copyc avp$system_displays
*copyc avp$system_operator
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_integer
*copyc clp$get_processing_phase
*copyc clp$only_validate_name
*copyc clp$validate_name
*copyc lgp$add_entry_global_binary_log
*copyc lgp$add_entry_local_binary_log
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$status_condition_code
*copyc osp$unpack_status_condition
*copyc pmp$continue_to_cause
*copyc pmp$get_compact_date_time
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_job_names
*copyc sfp$add_job_audit_control
*copyc sfp$add_job_routing_control
*copyc sfp$add_system_audit_control
*copyc sfp$add_system_routing_control
*copyc sfp$delete_job_audit_control
*copyc sfp$delete_job_routing_control
*copyc sfp$delete_sys_audit_control
*copyc sfp$delete_sys_routing_control
*copyc sfp$lock_job_routing_control
*copyc sfp$lock_system_routing_control
*copyc sfp$routing_control
*copyc sfp$update_job_limit_accum
*copyc lgv$log_names
*copyc sfv$job_routing_control_table
*copyc sfv$sys_routing_control_table
?? OLDTITLE ??
?? NEWTITLE := 'check_job_routing_ctl_privilege', EJECT ??
{ PURPOSE
{   Verifies that the caller has the appropriate privileges to access the job routing control table.

  PROCEDURE check_job_routing_ctl_privilege
    (    logs: sft$binary_logset;
         caller_id: ost$caller_identifier;
         access: sft$routing_control_access;
     VAR status: ost$status);

    VAR
      ignored_status: ost$status,
      processing_phase: clt$processing_phase;

    status.normal := TRUE;

{ If the request is only accessing the job statistics log, no special privileges are required.

    IF logs = $sft$binary_logset [pmc$job_statistic_log] THEN
      RETURN;
    IFEND;

{ Calls made from ring 3 have complete access to the job routing control table.

    IF caller_id.ring <= osc$tsrv_ring THEN
      RETURN;
    IFEND;

{ Calls made during the system prolog or epilog have complete access to the job routing control tables

    clp$get_processing_phase (processing_phase, ignored_status);
    IF (processing_phase = clc$system_prolog_phase) OR (processing_phase = clc$system_epilog_phase) THEN
      RETURN;
    IFEND;

{ Calls with read access and system_display access are permitted access to the logs

    IF ( access = sfc$read_routing_controls ) AND avp$system_displays () THEN
      RETURN;
    IFEND;

{ Check for proper intersection of logs/validation
{     Account_log requires accounting administration validation
{     Job_account_log requirs accounting administration validation
{     Engineering_log requires configuration administration validation
{     Statistics_log requires configuration administration validation
{     History_log requires system_operation validation

    IF ( pmc$account_log IN logs )    AND  NOT ( avp$accounting_administrator () )    OR

      ( pmc$job_account_log IN logs ) AND  NOT ( avp$accounting_administrator () )    OR

      ( pmc$engineering_log IN logs ) AND  NOT ( avp$configuration_administrator () ) OR

      ( pmc$security_log IN logs )   AND  NOT ( avp$system_administrator () ) OR

      ( pmc$statistic_log IN logs )   AND  NOT ( avp$configuration_administrator () ) OR

      ( pmc$history_log IN logs )     AND  NOT ( avp$system_operator () ) THEN

{ The caller does not have sufficient privilege for the requested access to the job routing control table.

      CASE access OF
      = sfc$read_routing_controls =
        osp$set_status_abnormal ('SF', sfe$insufficient_privilege, 'read', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'job', status);
      = sfc$update_routing_controls =
        osp$set_status_abnormal ('SF', sfe$insufficient_privilege, 'update', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'job', status);
      ELSE
        osp$set_status_abnormal ('SF', sfe$unknown_routing_ctl_access, 'check_job_routing_ctl_privilege',
              status);
      CASEND;

    IFEND;

  PROCEND check_job_routing_ctl_privilege;
?? OLDTITLE ??
?? NEWTITLE := 'check_sys_routing_ctl_privilege', EJECT ??
{ PURPOSE
{   Verifies that the caller has the appropriate privileges to access the system routing control table.

  PROCEDURE check_sys_routing_ctl_privilege
    (    logs: sft$binary_logset;
         caller_id: ost$caller_identifier;
         access: sft$routing_control_access;
     VAR status: ost$status);

    status.normal := TRUE;

{ If the request is only reading information about the job statistics log, no special privileges are required.

    IF (logs = $sft$binary_logset [pmc$job_statistic_log]) AND (access = sfc$read_routing_controls) THEN
      RETURN;
    IFEND;

{ Calls made from ring 3 and below have complete access to the system routing control table.

    IF caller_id.ring <= osc$tsrv_ring THEN
      RETURN;
    IFEND;

{ OK if access = read and system display validation

    IF ( access = sfc$read_routing_controls) AND ( avp$system_displays () ) THEN
      RETURN;
    IFEND;

{ Check for proper intersection of logs/validation
{     Account_log requires accounting administration validation
{     Job_account_log requirs accounting administration validation
{     Engineering_log requires configuration administration validation
{     Statistics_log requires configuration administration validation
{     History_log requires system_operation validation
{     Job_statistics_log with update access requires configuration administration validation

    IF ( pmc$account_log IN logs )    AND NOT ( avp$accounting_administrator () ) OR

      ( pmc$job_account_log IN logs ) AND NOT ( avp$accounting_administrator () ) OR

      ( pmc$engineering_log IN logs ) AND NOT ( avp$configuration_administrator () ) OR

      ( pmc$security_log IN logs ) AND NOT ( avp$system_administrator () ) OR

      ( pmc$statistic_log IN logs )   AND NOT ( avp$configuration_administrator () ) OR

      ( pmc$history_log IN logs )     AND NOT ( avp$system_operator () ) OR

      ( pmc$job_statistic_log IN logs ) AND ( access = sfc$update_routing_controls) AND
        NOT avp$configuration_administrator () THEN

{ The caller does not have sufficient privilege for the requested access to the system routing control table.

      CASE access OF
      = sfc$read_routing_controls =
        osp$set_status_abnormal ('SF', sfe$insufficient_privilege, 'read', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'system', status);
      = sfc$update_routing_controls =
        osp$set_status_abnormal ('SF', sfe$insufficient_privilege, 'update', status);
        osp$append_status_parameter (osc$status_parameter_delimiter, 'system', status);
      ELSE
        osp$set_status_abnormal ('SF', sfe$unknown_routing_ctl_access, 'check_sys_routing_ctl_privilege',
              status);
      CASEND;

    IFEND;

  PROCEND check_sys_routing_ctl_privilege;
?? OLDTITLE ??
?? NEWTITLE := 'copy_routing_control', EJECT ??
{ PURPOSE:
{   Make a copy of a routing control entry in the provided work area.

  PROCEDURE copy_routing_control
    (    routing_control: ^sft$routing_control;
         logs: sft$binary_logset;
     VAR head: ^sft$routing_control;
     VAR work_area: ^SEQ ( * );
     VAR routing_control_copy: ^sft$routing_control;
     VAR status: ost$status);

    VAR
      current_routing_control: ^sft$routing_control,
      previous_routing_control: ^sft$routing_control;

    status.normal := TRUE;

    NEXT routing_control_copy IN work_area;
    IF routing_control_copy = NIL THEN
      osp$set_status_condition (sfe$work_area_full, status);
      RETURN;
    IFEND;
    routing_control_copy^ := routing_control^;
    routing_control_copy^.activated_logs := logs * routing_control^.activated_logs;
    IF routing_control_copy^.audit_control_p <> NIL THEN
      routing_control_copy^.audit_control_p := NIL;
      routing_control_copy^.activated_logs := routing_control_copy^.activated_logs +
            $sft$binary_logset [pmc$security_log];
    IFEND;

    IF head = NIL THEN
      head := routing_control_copy;
      head^.forward := NIL;
    ELSE
      current_routing_control := head;
      previous_routing_control := NIL;

    /find_insertion_position/
      WHILE (current_routing_control <> NIL) AND
            (current_routing_control^.statistic_code < routing_control_copy^.statistic_code) DO
        previous_routing_control := current_routing_control;
        current_routing_control := current_routing_control^.forward;
      WHILEND /find_insertion_position/;
      routing_control_copy^.forward := current_routing_control;
      IF previous_routing_control = NIL THEN
        head := routing_control_copy;
      ELSE
        previous_routing_control^.forward := routing_control_copy;
      IFEND;
    IFEND;

  PROCEND copy_routing_control;
?? OLDTITLE ??
?? NEWTITLE := 'get_active_statistics', EJECT ??
{ PURPOSE
{   Returns a list of routing control information for the specified statistics and logs.

  PROCEDURE get_active_statistics
    (    routing_control_table: sft$routing_control_table;
         logs: sft$binary_logset;
     VAR head: ^sft$routing_control;
     VAR work_area: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      current_routing_control: ^sft$routing_control,
      routing_control_copy: ^sft$routing_control,
      routing_ctl_table_index: 0 .. sfc$routing_control_table_size;

    status.normal := TRUE;

    head := NIL;

    IF routing_control_table = NIL THEN
      RETURN;
    IFEND;

  /process_routing_ctl_table/
    FOR routing_ctl_table_index := 0 TO sfc$routing_control_table_size DO
      current_routing_control := routing_control_table^ [routing_ctl_table_index];

    /process_routing_ctl_linked_list/
      WHILE current_routing_control <> NIL DO
        IF ((logs * current_routing_control^.activated_logs) <> $sft$binary_logset []) OR
              ((pmc$security_log IN logs) AND (current_routing_control^.audit_control_p <> NIL)) THEN
          copy_routing_control (current_routing_control, logs, head, work_area, routing_control_copy, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        current_routing_control := current_routing_control^.forward;
      WHILEND /process_routing_ctl_linked_list/;

    FOREND /process_routing_ctl_table/;

  PROCEND get_active_statistics;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$activate_audit', EJECT ??
*copy sfh$activate_audit

  PROCEDURE [XDCL, #GATE] sfp$activate_audit
    (    operation_set: sft$audited_operation_set;
         selection_criteria: sft$audit_selection_criteria;
         routing_control_table_id: sft$routing_control_table_id;
         lock: boolean;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

    status.normal := TRUE;

{ Determine the callers ring.

    #CALLER_ID (caller_id);

{ Verify that the user has the authority to update the specified routing control table.

    IF routing_control_table_id = sfc$sys_routing_control_table THEN
      check_sys_routing_ctl_privilege ($sft$binary_logset[pmc$security_log], caller_id,
            sfc$update_routing_controls, status);
    ELSE
      check_job_routing_ctl_privilege ($sft$binary_logset[pmc$security_log], caller_id,
            sfc$update_routing_controls, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Make sure that the security audit security option has been enabled.

    IF NOT avp$security_option_active (avc$vso_security_audit) THEN
      osp$set_status_condition (sfe$security_audit_not_enabled, status);
      RETURN;
    IFEND;

{ Update the routing control table.

    IF routing_control_table_id = sfc$sys_routing_control_table THEN
      sfp$add_system_audit_control (operation_set, selection_criteria, lock, status);
    ELSE
      sfp$add_job_audit_control (operation_set, selection_criteria, lock, status);
    IFEND;

  PROCEND sfp$activate_audit;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$activate_job_statistic', EJECT ??
*copy sfh$activate_job_statistic

  PROCEDURE [XDCL, #GATE] sfp$activate_job_statistic
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

    #CALLER_ID (caller_id);

    status.normal := TRUE;

{ Verify that the user is allowed to update the routing control table.

    check_job_routing_ctl_privilege (logs, caller_id, sfc$update_routing_controls, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Update the job routing control table.

    sfp$add_job_routing_control (statistic_code, logs, osc$null_name, status);

  PROCEND sfp$activate_job_statistic;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$activate_system_statistic', EJECT ??
*copy sfh$activate_system_statistic

  PROCEDURE [XDCL, #GATE] sfp$activate_system_statistic
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

    #CALLER_ID (caller_id);

    status.normal := TRUE;

{ Verify that the user is allowed to update the routing control table.

    check_sys_routing_ctl_privilege (logs, caller_id, sfc$update_routing_controls, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Update the system routing control table.

    sfp$add_system_routing_control (statistic_code, logs, status);

  PROCEND sfp$activate_system_statistic;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] sfp$build_statistic', EJECT ??
{ PURPOSE
{   Constructs a statistic that will be recorded in a binary log.

  PROCEDURE [XDCL] sfp$build_statistic
    (    statistic_code: sft$statistic_code;
         descriptive_data: sft$descriptive_data;
         counters: sft$counters;
         global_task_id: ost$global_task_id;
     VAR statistic: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      statistic_counters: sft$counters,
      statistic_descriptive_data: ^sft$descriptive_data,
      statistic_header: ^sft$statistic_header,
      user_supplied_name: jmt$user_supplied_name;

    status.normal := TRUE;

    RESET statistic;

    NEXT statistic_header IN statistic;
    IF statistic_header = NIL THEN
      osp$set_status_abnormal ('SF', sfe$work_area_full, 'BUILD_STATISTIC', status);
      RETURN;
    IFEND;

    statistic_header^.version := sfc$statistic_version;

    pmp$get_compact_date_time (statistic_header^.date_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    statistic_header^.statistic_code := statistic_code;

    pmp$get_job_names (user_supplied_name, statistic_header^.job_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    statistic_header^.task_id := global_task_id;

    IF counters <> NIL THEN
      statistic_header^.number_of_counters := UPPERBOUND (counters^);
      NEXT statistic_counters: [1 .. UPPERBOUND (counters^)] IN statistic;
      IF statistic_counters = NIL THEN
        osp$set_status_abnormal ('SF', sfe$work_area_full, 'BUILD_STATISTIC', status);
        RETURN;
      IFEND;
      statistic_counters^ := counters^;
    ELSE
      statistic_header^.number_of_counters := 0;
    IFEND;

    IF STRLENGTH (descriptive_data) <> 0 THEN
      statistic_header^.descriptive_data_size := STRLENGTH (descriptive_data);
      NEXT statistic_descriptive_data: [STRLENGTH (descriptive_data)] IN statistic;
      IF statistic_descriptive_data = NIL THEN
        osp$set_status_abnormal ('SF', sfe$work_area_full, 'BUILD_STATISTIC', status);
        RETURN;
      IFEND;
      statistic_descriptive_data^ := descriptive_data;
    ELSE
      statistic_header^.descriptive_data_size := 0;
    IFEND;

  PROCEND sfp$build_statistic;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$convert_stat_code_to_name', EJECT ??
*copy sfh$convert_stat_code_to_name

  PROCEDURE [XDCL, #GATE] sfp$convert_stat_code_to_name
    (    statistic_code: sft$statistic_code;
     VAR statistic_name: ost$name;
     VAR status: ost$status);

    VAR
      numeric_string: ost$string,
      statistic_id: ost$status_identifier,
      statistic_number: ost$status_condition_number,
      string_size: integer,
      valid_name: boolean;

    status.normal := TRUE;

    statistic_name := osc$null_name;

    osp$unpack_status_condition (statistic_code, statistic_id, statistic_number);

    clp$convert_integer_to_string (statistic_number, 10, FALSE, numeric_string, status);
    IF NOT status.normal THEN
      osp$set_status_condition (sfe$incorrect_statistic_code, status);
      osp$append_status_integer (osc$status_parameter_delimiter, statistic_code, 10, FALSE, status);
      RETURN;
    IFEND;

    statistic_name := statistic_id;
    statistic_name (#SIZE(statistic_id)+1, *) := numeric_string.value (1, numeric_string.size);

    clp$only_validate_name (statistic_name, valid_name);
    IF NOT valid_name THEN
      osp$set_status_condition (sfe$incorrect_statistic_code, status);
      osp$append_status_integer (osc$status_parameter_delimiter, statistic_code, 10, FALSE, status);
    IFEND;

  PROCEND sfp$convert_stat_code_to_name;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$convert_stat_name_to_code', EJECT ??
*copy sfh$convert_stat_name_to_code

  PROCEDURE [XDCL, #GATE] sfp$convert_stat_name_to_code
    (    statistic_name: ost$name;
     VAR statistic_code: sft$statistic_code;
     VAR status: ost$status);

    VAR
      converted_integer: clt$integer,
      statistic_id: ost$status_identifier,
      statistic_number: ost$status_condition_number,
      valid_name: boolean,
      validated_name: ost$name;

    status.normal := TRUE;

    clp$validate_name (statistic_name, validated_name, valid_name);
    IF NOT valid_name THEN
      osp$set_status_abnormal ('SF', sfe$invalid_statistic_name, statistic_name, status);
      RETURN;
    IFEND;

    statistic_id := validated_name (1, 2);

    clp$convert_string_to_integer (validated_name (3, * ), converted_integer, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal ('SF', sfe$invalid_statistic_name, validated_name, status);
      RETURN;
    IFEND;
    IF converted_integer.value <= osc$max_status_condition_number THEN
      statistic_number := converted_integer.value;
      statistic_code := osp$status_condition_code (statistic_id, statistic_number);
    ELSE
      osp$set_status_abnormal ('SF', sfe$invalid_statistic_name, validated_name, status);
    IFEND;

  PROCEND sfp$convert_stat_name_to_code;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$deactivate_audit', EJECT ??
*copy sfh$deactivate_audit

  PROCEDURE [XDCL, #GATE] sfp$deactivate_audit
    (    operation_set: sft$audited_operation_set;
         routing_control_table_id: sft$routing_control_table_id;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

    status.normal := TRUE;

{ Determine the callers ring.

    #CALLER_ID (caller_id);

{ Verify that the user has the authority to update the specified routing control table.

    IF routing_control_table_id = sfc$sys_routing_control_table THEN
      check_sys_routing_ctl_privilege ($sft$binary_logset[pmc$security_log], caller_id,
            sfc$update_routing_controls, status);
    ELSE
      check_job_routing_ctl_privilege ($sft$binary_logset[pmc$security_log], caller_id,
            sfc$update_routing_controls, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Make sure that the security audit security option has been enabled.

    IF NOT avp$security_option_active (avc$vso_security_audit) THEN
      osp$set_status_condition (sfe$security_audit_not_enabled, status);
      RETURN;
    IFEND;

{ Update the routing control table.

    IF routing_control_table_id = sfc$sys_routing_control_table THEN
      sfp$delete_sys_audit_control (operation_set, status);
    ELSE
      sfp$delete_job_audit_control (operation_set, status);
    IFEND;

  PROCEND sfp$deactivate_audit;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$deactivate_job_statistic', EJECT ??
*copy sfh$deactivate_job_statistic

  PROCEDURE [XDCL, #GATE] sfp$deactivate_job_statistic
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

    #CALLER_ID (caller_id);

    status.normal := TRUE;

    check_job_routing_ctl_privilege (logs, caller_id, sfc$update_routing_controls, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sfp$delete_job_routing_control (statistic_code, logs, status);

  PROCEND sfp$deactivate_job_statistic;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$deactivate_system_statistic', EJECT ??
*copy sfh$deactivate_system_statistic

  PROCEDURE [XDCL, #GATE] sfp$deactivate_system_statistic
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

    #CALLER_ID (caller_id);

    status.normal := TRUE;

    check_sys_routing_ctl_privilege (logs, caller_id, sfc$update_routing_controls, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sfp$delete_sys_routing_control (statistic_code, logs, status);

  PROCEND sfp$deactivate_system_statistic;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$emit_statistic', EJECT ??
*copy sfh$emit_statistic

  PROCEDURE [XDCL, #GATE] sfp$emit_statistic
    (    statistic_code: sft$statistic_code;
         descriptive_data: sft$descriptive_data;
         counters: sft$counters;
     VAR status: ost$status);

    VAR
      global_task_id: ost$global_task_id;

    status.normal := TRUE;

    pmp$get_executing_task_gtid (global_task_id);

    sfp$internal_emit_statistic (statistic_code, descriptive_data, counters, global_task_id, status);

  PROCEND sfp$emit_statistic;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$emit_system_statistic', EJECT ??
*copy sfh$emit_system_statistic

  PROCEDURE [XDCL, #GATE] sfp$emit_system_statistic
    (    identifier: sft$statistic_identifier;
         statistic_code: sft$statistic_code;
         descriptive_data: sft$descriptive_data;
         counters: sft$counters;
     VAR status: ost$status);

    VAR
      composite_statistic_code: sft$statistic_code,
      global_task_id: ost$global_task_id;

    status.normal := TRUE;

    composite_statistic_code := osp$status_condition_code (identifier, statistic_code);

    pmp$get_executing_task_gtid (global_task_id);

    sfp$internal_emit_statistic (composite_statistic_code, descriptive_data, counters, global_task_id,
          status);

  PROCEND sfp$emit_system_statistic;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$get_active_job_statistics', EJECT ??
*copy sfh$get_active_job_statistics

  PROCEDURE [XDCL, #GATE] sfp$get_active_job_statistics
    (    logs: sft$binary_logset;
     VAR head: ^sft$routing_control;
     VAR work_area: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

    #CALLER_ID (caller_id);

    status.normal := TRUE;

    head := NIL;

    check_job_routing_ctl_privilege (logs, caller_id, sfc$read_routing_controls, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF work_area = NIL THEN
      osp$set_status_abnormal ('SF', sfe$work_area_full, 'SFP$GET_ACTIVE_JOB_STATISTICS', status);
      RETURN;
    IFEND;

    IF sfv$sys_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'Job', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$get_active_job_statistics', status);
      RETURN;
    IFEND;

    get_active_statistics (sfv$job_routing_control_table, logs, head, work_area, status);
    IF (NOT status.normal) AND (status.condition = sfe$work_area_full) THEN
      osp$append_status_parameter (osc$status_parameter_delimiter, 'SFP$GET_ACTIVE_JOB_STATISTICS', status);
    IFEND;

  PROCEND sfp$get_active_job_statistics;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$get_active_system_stats', EJECT ??
*copy sfh$get_active_system_stats

  PROCEDURE [XDCL, #GATE] sfp$get_active_system_stats
    (    logs: sft$binary_logset;
     VAR head: ^sft$routing_control;
     VAR work_area: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

?? NEWTITLE := 'job_recovery_condition_handler', EJECT ??
{ PURPOSE:
{   This condition handler is used around the code that is reading the system routing information to handle
{   the case of job recovery.  The system routing control table is kept in mainframe pageable and is moved if
{   the system is recovered.  If the job is recovered while it is reading the system routing control table,
{   the condition handler will perform a non-local exit with an abnormal status of
{   SFE$JOB_RECOVERED_CALL_AGAIN.


    PROCEDURE job_recovery_condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IF NOT handler_status.normal THEN
        RETURN;
      IFEND;

      IF (condition.selector = pmc$user_defined_condition) AND (condition.user_condition_name =
            'OSC$JOB_RECOVERY') THEN
        osp$set_status_abnormal ('SF', sfe$call_again_job_recovered, 'SFP$GET_ACTIVE_SYSTEM_STATS', status);
        EXIT sfp$get_active_system_stats;
      IFEND;

    PROCEND job_recovery_condition_handler;

?? OLDTITLE, EJECT ??

    #CALLER_ID (caller_id);

    status.normal := TRUE;

    head := NIL;

    IF work_area = NIL THEN
      osp$set_status_abnormal ('SF', sfe$work_area_full, 'SFP$GET_ACTIVE_SYSTEM_STATS', status);
      RETURN;
    IFEND;

    check_sys_routing_ctl_privilege (logs, caller_id, sfc$read_routing_controls, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osp$establish_condition_handler (^job_recovery_condition_handler, FALSE);

    IF sfv$sys_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'System', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$get_active_system_stats', status);
      RETURN;
    IFEND;

    REPEAT
      get_active_statistics (sfv$sys_routing_control_table, logs, head, work_area, status);
    UNTIL (status.normal) OR (status.condition <> sfe$call_again_job_recovered);
    IF (NOT status.normal) AND (status.condition = sfe$work_area_full) THEN
      osp$append_status_parameter (osc$status_parameter_delimiter, 'SFP$GET_ACTIVE_SYSTEM_STATS', status);
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND sfp$get_active_system_stats;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$get_audited_operations', EJECT ??
*copy sfh$get_audited_operations

  PROCEDURE [XDCL, #GATE] sfp$get_audited_operations
    (    routing_control_table_id: sft$routing_control_table_id;
     VAR work_area: ^SEQ ( * );
     VAR first_routing_control_entry: ^sft$routing_control;
     VAR status: ost$status);

    VAR
      audit_control_copy_p: ^sft$audit_control,
      caller_id: ost$caller_identifier,
      current_audit_control: ^sft$audit_control,
      current_routing_control: ^sft$routing_control,
      routing_control_copy: ^sft$routing_control,
      routing_control_table: sft$routing_control_table,
      routing_ctl_table_index: 0 .. sfc$routing_control_table_size;

?? NEWTITLE := 'job_recovery_condition_handler', EJECT ??
{ PURPOSE:
{   This condition handler is used around the code that is reading the system routing information to handle
{   the case of job recovery.  The system routing control table is kept in mainframe pageable and is moved if
{   the system is recovered.  If the job is recovered while it is reading the system routing control table,
{   the condition handler will perform a non-local exit with an abnormal status of
{   SFE$JOB_RECOVERED_CALL_AGAIN.


    PROCEDURE job_recovery_condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IF NOT handler_status.normal THEN
        RETURN;
      IFEND;

      IF (condition.selector = pmc$user_defined_condition) AND (condition.user_condition_name =
            'OSC$JOB_RECOVERY') THEN
        osp$set_status_abnormal ('SF', sfe$call_again_job_recovered, 'SFP$GET_AUDITED_OPERATIONS', status);
        EXIT sfp$get_audited_operations;
      IFEND;

    PROCEND job_recovery_condition_handler;

?? OLDTITLE, EJECT ??
    #CALLER_ID (caller_id);

    status.normal := TRUE;

    IF work_area = NIL THEN
      osp$set_status_abnormal ('SF', sfe$work_area_full, 'SFP$GET_AUDITED_OPERATIONS', status);
      RETURN;
    IFEND;

    first_routing_control_entry := NIL;

{ Verify that the user has the authority to read the specified routing control table.

    IF routing_control_table_id = sfc$sys_routing_control_table THEN
      check_sys_routing_ctl_privilege ($sft$binary_logset [pmc$security_log], caller_id,
            sfc$read_routing_controls, status);
      routing_control_table := sfv$sys_routing_control_table;
    ELSE
      check_job_routing_ctl_privilege ($sft$binary_logset [pmc$security_log], caller_id,
            sfc$read_routing_controls, status);
      routing_control_table := sfv$job_routing_control_table;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Make sure the routing control table has been initialized.

    IF routing_control_table = NIL THEN
      IF routing_control_table_id = sfc$sys_routing_control_table THEN
        osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'Job', status);
      ELSE
        osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'System', status);
      IFEND;
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$get_audited_operations', status);
      RETURN;
    IFEND;

{ Make sure that the security audit security option has been enabled.

    IF NOT avp$security_option_active (avc$vso_security_audit) THEN
      osp$set_status_condition (sfe$security_audit_not_enabled, status);
      RETURN;
    IFEND;

{ Establish a condition handler to deal with job recovery when reading the system routing control table.

    IF routing_control_table_id = sfc$sys_routing_control_table THEN
      osp$establish_condition_handler (^job_recovery_condition_handler, FALSE);
    IFEND;

{ Go through the routing control table, copying every routing control entry that affects audit.

    FOR routing_ctl_table_index := 0 TO sfc$routing_control_table_size DO
      current_routing_control := routing_control_table^ [routing_ctl_table_index];
      WHILE current_routing_control <> NIL DO
        IF (pmc$security_log IN current_routing_control^.activated_logs) OR
              (current_routing_control^.audit_control_p <> NIL) THEN
          copy_routing_control (current_routing_control, $sft$binary_logset[pmc$security_log],
                first_routing_control_entry, work_area, routing_control_copy, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

{ Copy the audit control information (if any).

          current_audit_control := current_routing_control^.audit_control_p;
          WHILE current_audit_control <> NIL DO
            NEXT audit_control_copy_p: [1 .. UPPERBOUND(current_audit_control^.selection_criteria)] IN
                  work_area;
            IF audit_control_copy_p = NIL THEN
              osp$set_status_abnormal ('SF', sfe$work_area_full, 'SFP$GET_AUDITED_OPERATIONS', status);
              RETURN;
            IFEND;
            audit_control_copy_p^ := current_audit_control^;
            audit_control_copy_p^.forward := routing_control_copy^.audit_control_p;
            routing_control_copy^.audit_control_p := audit_control_copy_p;
            current_audit_control := current_audit_control^.forward;
          WHILEND;
        IFEND;
        current_routing_control := current_routing_control^.forward;
      WHILEND;
    FOREND;

{ Disestablish the condition handler that deals with job recovery when reading the system routing control
{ table.

    IF routing_control_table_id = sfc$sys_routing_control_table THEN
      osp$disestablish_cond_handler;
    IFEND;

  PROCEND sfp$get_audited_operations;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$get_log_name', EJECT ??
*copy sfh$get_log_name

  PROCEDURE [XDCL, #GATE] sfp$get_log_name
    (    log: sft$binary_logs;
     VAR log_name: ost$name;
     VAR status: ost$status);

    status.normal := TRUE;

    log_name := lgv$log_names [log];

  PROCEND sfp$get_log_name;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] sfp$get_routing_controls', EJECT ??
{ PURPOSE:
{   Returns the routing control information for the specified statistic.

  PROCEDURE [XDCL] sfp$get_routing_controls
    (    statistic_code: sft$statistic_code;
     VAR activated_logs: sft$binary_logset;
     VAR activated_limit_name: ost$name;
     VAR status: ost$status);

    VAR
      routing_control: ^sft$routing_control;

?? NEWTITLE := 'job_recovery_condition_handler', EJECT ??
{ PURPOSE:
{   This condition handler is used around the code that is reading the system routing information to handle
{   the case of job recovery.  The system routing control table is kept in mainframe pageable and is moved if
{   the system is recovered.  If the job is recovered while it is reading the system routing control table,
{   the condition handler will perform a non-local exit with an abnormal status of
{   SFE$JOB_RECOVERED_CALL_AGAIN.

    PROCEDURE job_recovery_condition_handler
      (    condition: pmt$condition;
           condition_information: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR handler_status: ost$status);

      pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);
      IF NOT handler_status.normal THEN
        RETURN;
      IFEND;

      IF (condition.selector = pmc$user_defined_condition) AND (condition.user_condition_name =
            'OSC$JOB_RECOVERY') THEN
        osp$set_status_abnormal ('SF', sfe$call_again_job_recovered, 'GET_ROUTING_CONTROLS', status);
        EXIT sfp$get_routing_controls;
      IFEND;

    PROCEND job_recovery_condition_handler;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    activated_logs := $sft$binary_logset [];
    activated_limit_name := osc$null_name;

    IF sfv$job_routing_control_table <> NIL THEN
      routing_control := sfp$routing_control (statistic_code, sfv$job_routing_control_table);
      IF routing_control <> NIL THEN
        activated_logs := activated_logs + routing_control^.activated_logs;
        activated_limit_name := routing_control^.limit_name;
      IFEND;
    IFEND;

    osp$establish_condition_handler (^job_recovery_condition_handler, FALSE);

    IF sfv$sys_routing_control_table <> NIL THEN
      routing_control := sfp$routing_control (statistic_code, sfv$sys_routing_control_table);
      IF routing_control <> NIL THEN
        activated_logs := activated_logs + routing_control^.activated_logs;
      IFEND;
    IFEND;

    osp$disestablish_cond_handler;

  PROCEND sfp$get_routing_controls;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, INLINE] sfp$internal_emit_statistic', EJECT ??
*copy sfh$internal_emit_statistic

  PROCEDURE [XDCL, INLINE] sfp$internal_emit_statistic
    (    statistic_code: sft$statistic_code;
         descriptive_data: sft$descriptive_data;
         counters: sft$counters;
         global_task_id: ost$global_task_id;
     VAR status: ost$status);

    VAR
      activated_limit_name: ost$name,
      activated_logs: sft$binary_logset,
      ignored_status: ost$status,
      log: sft$binary_logs,
      statistic: ^SEQ ( * ),
      statistic_name: ost$name,
      statistic_size: integer;

    status.normal := TRUE;

{ Verify the size of the descriptive data.

    IF STRLENGTH (descriptive_data) > sfc$max_descriptive_data_size THEN
      sfp$convert_stat_code_to_name (statistic_code, statistic_name, ignored_status);
      osp$set_status_abnormal ('SF', sfe$descriptive_data_size, statistic_name, status);
      osp$append_status_integer (osc$status_parameter_delimiter, sfc$max_descriptive_data_size, 10, FALSE,
            status);
      RETURN;
    IFEND;

{ Verify the number of counters.

    IF counters <> NIL THEN
      IF UPPERBOUND (counters^) > sfc$max_number_of_counters THEN
        sfp$convert_stat_code_to_name (statistic_code, statistic_name, ignored_status);
        osp$set_status_abnormal ('SF', sfe$counter_array_size_range, statistic_name, status);
        osp$append_status_integer (osc$status_parameter_delimiter, sfc$max_number_of_counters, 10, FALSE,
              status);
        RETURN;
      IFEND;
    IFEND;

{ Find out which logs the statistic has been activated to.

    REPEAT
      sfp$get_routing_controls (statistic_code, activated_logs, activated_limit_name, status);
    UNTIL (status.normal) OR (status.condition <> sfe$call_again_job_recovered);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ If the statistic is activated to any logs build the statistic and record it.

    IF activated_logs <> $sft$binary_logset [] THEN

{ Allocate the space to build the statistic in.

      statistic_size := #SIZE (sft$statistic_header);
      IF counters <> NIL THEN
        statistic_size := statistic_size + #SIZE (counters^);
      IFEND;
      statistic_size := statistic_size + #SIZE (descriptive_data);
      IF statistic_size > sfc$max_statistic_record_size THEN
        sfp$convert_stat_code_to_name (statistic_code, statistic_name, {ignore} status);
        osp$set_status_abnormal ('SF', sfe$too_much_data_for_statistic, statistic_name, status);
        RETURN;
      IFEND;

      PUSH statistic: [[REP statistic_size OF cell]];

      sfp$build_statistic (statistic_code, descriptive_data, counters, global_task_id, statistic, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

{ Record the statistic in activated logs.

      FOR log := LOWERVALUE (sft$binary_logs) TO UPPERVALUE (sft$binary_logs) DO
        IF log IN activated_logs THEN
          IF log IN -$sft$global_binary_logset [] THEN
            lgp$add_entry_global_binary_log (log, statistic, status);
          ELSE
            lgp$add_entry_local_binary_log (log, statistic, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      FOREND;

    IFEND;

    IF (activated_limit_name <> osc$null_name) AND (counters <> NIL) THEN
      sfp$update_job_limit_accum (activated_limit_name, counters^ [1], sfc$incremental_update, status);
    IFEND;

  PROCEND sfp$internal_emit_statistic;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$lock_statistic', EJECT ??
*copy sfh$lock_statistic

  PROCEDURE [XDCL, #GATE] sfp$lock_statistic
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
         routing_control_table_id: sft$routing_control_table_id;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier;

    status.normal := TRUE;

{ Determine the callers ring.

    #CALLER_ID (caller_id);

{ Verify that the user has the authority to update the specified routing control table.

    IF routing_control_table_id = sfc$sys_routing_control_table THEN
      check_sys_routing_ctl_privilege ($sft$binary_logset[pmc$security_log], caller_id,
            sfc$update_routing_controls, status);
    ELSE
      check_job_routing_ctl_privilege ($sft$binary_logset[pmc$security_log], caller_id,
            sfc$update_routing_controls, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Update the routing control table.

    IF routing_control_table_id = sfc$sys_routing_control_table THEN
      sfp$lock_system_routing_control (statistic_code, logs, status);
    ELSE
      sfp$lock_job_routing_control (statistic_code, logs, status);
    IFEND;

  PROCEND sfp$lock_statistic;
?? OLDTITLE ??
MODEND sfm$statistic_interfaces;
*DECK DECK=SFM$SYS_ROUTING_CONTROL_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Statistics Facility: System Routing Control Manager' ??
MODULE sfm$sys_routing_control_manager;

{  PURPOSE:
{   This module contains the procedures that are used to create and manage the
{   system routing control table.
{
{  DESIGN:
{
{   The system routing control table controls the logging of statistics for the
{   system.
{
{   The routing control for a given statistic is found by calculating an index
{   into the table (statistic code MOD size of the table) and chaining down the
{   linked list of routing control entries.
{
{   Routing controls are added to the chain in last in first out order.
{
{   The size of the routing control table has been chosen to provide an average
{   chain length of 1 when all currently known statistics are activated.
{
{   Updates of the system routing control table are interlocked by using
{   signature locks.

?? NEWTITLE := 'Global Declarations Referenced by This Module.', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avc$accounting_statistics
*copyc cml$dvs_usage_data
*copyc jml$user_id
*copyc sfe$statistics_not_available
*copyc sft$audit_statistic_code
*copyc sft$binary_logset
*copyc sft$routing_control
*copyc sft$routing_control_table
*copyc sft$statistic_code
?? POP ??
*copyc avp$security_option_active
*copyc osp$append_status_parameter
*copyc osp$clear_mainframe_sig_lock
*copyc osp$initialize_sig_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc sfp$add_audit_control
*copyc sfp$add_routing_control
*copyc sfp$delete_audit_control
*copyc sfp$delete_routing_control
*copyc sfp$lock_routing_control
*copyc osv$mainframe_pageable_heap
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module.', EJECT ??

{ The system routing control table controls which statistics are emitted to which logs for the system.

  VAR
    sfv$sys_routing_control_table: [XDCL, #GATE, STATIC, oss$mainframe_pageable] sft$routing_control_table
           := NIL;

{ The system routing control lock controls access to the system routing control table.

  VAR
    sfv$system_routing_control_lock: [XDCL, #GATE, STATIC, oss$mainframe_pageable] ost$signature_lock;

{ This variable indicates whether open_file statistics are activated for the system.

  VAR
    sfv$emit_sys_open_statistics: [XDCL, #GATE, STATIC, oss$mainframe_pageable] boolean := FALSE;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$add_system_audit_control', EJECT ??
*copyc sfh$add_system_audit_control

  PROCEDURE [XDCL, #GATE] sfp$add_system_audit_control
    (    operation_set: sft$audited_operation_set;
         selection_criteria: sft$audit_selection_criteria;
         lock: boolean;
     VAR status: ost$status);

    status.normal := TRUE;

{ Make sure the system routing control table has been initialized.

    IF sfv$sys_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'System', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$add_system_audit_control', status);
      RETURN;
    IFEND;

{ Interlock the system routing control table.

    osp$set_mainframe_sig_lock (sfv$system_routing_control_lock);

{ Add the specified audit control information to the routing control table.

    sfp$add_audit_control (sfv$sys_routing_control_table, operation_set, selection_criteria, lock,
          osv$mainframe_pageable_heap);

{ Clear the interlock.

    osp$clear_mainframe_sig_lock (sfv$system_routing_control_lock);

  PROCEND sfp$add_system_audit_control;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$add_system_routing_control', EJECT ??
*copyc sfh$add_system_routing_control

  PROCEDURE [XDCL, #GATE] sfp$add_system_routing_control
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

    VAR
      routing_control_p: ^sft$routing_control;

    status.normal := TRUE;

{ Make sure the system routing control table has been initialized.

    IF sfv$sys_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'System', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$add_system_routing_control', status);
      RETURN;
    IFEND;

{ Interlock the system routing control table.

    osp$set_mainframe_sig_lock (sfv$system_routing_control_lock);

{ Add the specified routing control information to the routing control table.

    sfp$add_routing_control (sfv$sys_routing_control_table, statistic_code, logs, osv$mainframe_pageable_heap,
          routing_control_p);

{ Clear the interlock.

    osp$clear_mainframe_sig_lock (sfv$system_routing_control_lock);

    IF (statistic_code = jml$open_file_statistics) AND NOT sfv$emit_sys_open_statistics THEN
      sfv$emit_sys_open_statistics := TRUE;
    IFEND;

  PROCEND sfp$add_system_routing_control;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$delete_sys_audit_control', EJECT ??
*copyc sfh$delete_sys_audit_control

  PROCEDURE [XDCL, #GATE] sfp$delete_sys_audit_control
    (    operation_set: sft$audited_operation_set;
     VAR status: ost$status);

    status.normal := TRUE;

{ Make sure the system routing control table has been initialized.

    IF sfv$sys_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'System', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$delete_sys_audit_control', status);
      RETURN;
    IFEND;

{ Interlock the system routing control table.

    osp$set_mainframe_sig_lock (sfv$system_routing_control_lock);

{ Delete the specified audit control information from the routing control table.

    sfp$delete_audit_control (sfv$sys_routing_control_table, operation_set, osv$mainframe_pageable_heap,
          status);

{ Clear the interlock.

    osp$clear_mainframe_sig_lock (sfv$system_routing_control_lock);

  PROCEND sfp$delete_sys_audit_control;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$delete_sys_routing_control', EJECT ??
*copyc sfh$delete_sys_routing_control

  PROCEDURE [XDCL, #GATE] sfp$delete_sys_routing_control
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

    status.normal := TRUE;

{ Make sure the system routing control table has been initialized.

    IF sfv$sys_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'System', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$delete_sys_routing_control', status);
      RETURN;
    IFEND;

{ Interlock the system routing control table.

    osp$set_mainframe_sig_lock (sfv$system_routing_control_lock);

{ Delete the specified routing control information from the routing control table.

    sfp$delete_routing_control (sfv$sys_routing_control_table, statistic_code, logs, status);

{ Clear the interlock.

    osp$clear_mainframe_sig_lock (sfv$system_routing_control_lock);

    IF (statistic_code = jml$open_file_statistics) AND sfv$emit_sys_open_statistics THEN
      sfv$emit_sys_open_statistics := FALSE;
    IFEND;

  PROCEND sfp$delete_sys_routing_control;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$init_system_routing_control', EJECT ??
*copyc sfh$init_system_routing_control

  PROCEDURE [XDCL, #GATE] sfp$init_system_routing_control
    (VAR status: ost$status);

    VAR
      index: 0 .. sfc$routing_control_table_size,
      selection_criteria_p: ^sft$audit_selection_criteria;

    status.normal := TRUE;

{ Allocate the system routing control table and initialize each entry to NIL.

    ALLOCATE sfv$sys_routing_control_table: [0 .. sfc$routing_control_table_size] IN
          osv$mainframe_pageable_heap^;

    FOR index := 0 TO sfc$routing_control_table_size DO
      sfv$sys_routing_control_table^ [index] := NIL;
    FOREND;

    osp$initialize_sig_lock (sfv$system_routing_control_lock);

{ Activate accounting statistics

    sfp$add_system_routing_control (avc$begin_account, $sft$binary_logset
          [pmc$job_account_log, pmc$account_log], {ignore} status);
    sfp$add_system_routing_control (avc$end_account, $sft$binary_logset
          [pmc$job_account_log, pmc$account_log], {ignore} status);
    sfp$add_system_routing_control (avc$begin_application, $sft$binary_logset
          [pmc$job_account_log, pmc$account_log], {ignore} status);
    sfp$add_system_routing_control (avc$end_application, $sft$binary_logset
          [pmc$job_account_log, pmc$account_log], {ignore} status);
    sfp$add_system_routing_control (avc$application_units, $sft$binary_logset
          [pmc$job_account_log, pmc$account_log], {ignore} status);
    sfp$add_system_routing_control (avc$ca_interactive_interval, $sft$binary_logset
          [pmc$job_account_log, pmc$account_log], {ignore} status);

{ Activate DVS usage statistic

    sfp$add_system_routing_control (cml$dvs_usage_data, $sft$binary_logset [pmc$engineering_log],
          {ignore} status);

{ Activate and lock the user identification and job end audit controls if security audit is enabled.

    IF avp$security_option_active (avc$vso_security_audit) THEN

{ Initialize an empty selection criteria that will cause all user identification and job end audit
{ statistics to be emitted.

      PUSH selection_criteria_p: [1 .. 1];
      selection_criteria_p^ [1].selector := sfc$as_null_selector;
      sfp$add_system_audit_control ($sft$audited_operation_set[sfc$ao_job_user_identification,
            sfc$ao_job_end], selection_criteria_p^, {lock =} TRUE, { ignore } status);
    IFEND;

    status.normal := TRUE;

  PROCEND sfp$init_system_routing_control;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] sfp$lock_system_routing_control', EJECT ??
*copyc sfh$lock_system_routing_control

  PROCEDURE [XDCL, #GATE] sfp$lock_system_routing_control
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

    status.normal := TRUE;

{ Make sure the system routing control table has been initialized.

    IF sfv$sys_routing_control_table = NIL THEN
      osp$set_status_abnormal ('SF', sfe$statistics_not_available, 'System', status);
      osp$append_status_parameter (osc$status_parameter_delimiter, 'sfp$lock_system_routing_control', status);
      RETURN;
    IFEND;

{ Interlock the system routing control table.

    osp$set_mainframe_sig_lock (sfv$system_routing_control_lock);

{ Delete the specified routing control information.

    sfp$lock_routing_control (sfv$sys_routing_control_table, statistic_code, logs,
          osv$mainframe_pageable_heap);

{ Clear the interlock.

    osp$clear_mainframe_sig_lock (sfv$system_routing_control_lock);

  PROCEND sfp$lock_system_routing_control;
?? OLDTITLE ??
MODEND sfm$sys_routing_control_manager;
*DECK DECK=SFM$TEST_HARNESS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Statistics Facility: Test Harness' ??

MODULE sfm$test_harness;

{ PURPOSE:
{  This module contains the test harness for the NOS/VE statistics facility.

?? NEWTITLE := 'Global declarations referenced by this module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$path_display_chunks
*copyc clt$when_conditions
*copyc ift$condition_codes
*copyc jmt$job_control_block
*copyc jmt$job_statistics
*copyc lgt$log_read_activity
*copyc oss$job_pageable
*copyc oss$mainframe_pageable
*copyc oss$mainframe_paged_literal
*copyc ost$global_task_id
*copyc ost$heap
*copyc ost$status
*copyc ost$system_flag
*copyc ost$user_identification
*copyc pmd$system_log_interface
*copyc pmt$signal
*copyc sfc$unlimited
*copyc sft$file_space_limit_kind
?? POP ??
*copyc amp$close
*copyc amp$get_segment_pointer
*copyc amp$open
*copyc amp$put_next
*copyc amp$return
*copyc clp$begin_utility
*copyc clp$build_standard_title
*copyc clp$close_display
*copyc clp$convert_integer_to_string
*copyc clp$count_list_elements
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$evaluate_parameters
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$include_file
*copyc clp$new_display_line
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$reset_for_next_display_page
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc jmp$default_job_resource_hndlr
*copyc osp$set_status_abnormal
*copyc pmp$generate_unique_name
*copyc pmp$get_executing_task_gtid
*copyc pmp$get_task_cp_time
*copyc pmp$get_task_id
*copyc pmp$log
*copyc sfp$convert_stat_code_to_name
*copyc sfp$convert_stat_name_to_code
*copyc sfp$create_job_limit
*copyc sfp$emit_statistic
*copyc sfp$init_job_routing_control
*copyc sfp$init_system_routing_control
?? OLDTITLE ??
?? NEWTITLE := 'Global declarations declared by this module.', EJECT ??

  CONST
    test_harness_name = 'SF_TEST_HARNESS                ',
    test_harness_prompt = 'SFTH';

  VAR
    avv$accumulated_srus: [XDCL] sft$counter := 0,
    avv$monitor_statistics_lock: [XDCL] ost$signature_lock,
    clv$value_descriptors: [XDCL] array [clc$variable_reference .. clc$status_value] of string (8) :=
          ['VARIABLE', 'FILE', 'NAME', 'STRING', 'REAL', 'INTEGER', 'BOOLEAN', 'STATUS'],
    family_administrator: boolean,
    ignored_status: ost$status,
    jmv$jcb: [XDCL] jmt$job_control_block,
    job_pageable_file_id: amt$file_identifier,
    lgv$log_names: [XDCL] array [pmt$logs] of ost$name := ['$TEST_JOB_ACCOUNT_LOG', '$TEST_JOB_STATISTIC_LOG',
          '$TEST_ACCOUNT_LOG', '$TEST_ENGINEERING_LOG', '$TEST_JOB_HISTORY_LOG', '$TEST_STATISTIC_LOG',
          '$TEST_SYSTEM_LOG', '$TEST_JOB_LOG'],
    mainframe_pageable_file_id: amt$file_identifier,
    osv$job_pageable_heap: [XDCL] ^ost$heap := NIL,
    osv$mainframe_pageable_heap: [XDCL] ^ost$heap := NIL,
    system_administrator: boolean,
    system_error_encountered: boolean;

*copyc sfv$job_routing_control_table
?? OLDTITLE ??
?? NEWTITLE := 'sfp$test_harness', EJECT ??

  PROCEDURE [XDCL, #GATE] sfp$test_harness
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE sf_test_harness (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 10, 27, 14, 24, 25, 279], clc$command, 1, 1, 0, 0, 0, 0, 1, 'SF_TEST_HARNESS'],
            [['STATUS                         ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

{ table commands
{ command (activate_job_statistic, activate_job_statistics, actjs) sfp$_activate_job_statistic xref
{ command (activate_system_statistic, activate_system_statistics, actss) sfp$activate_sys_stat_command xref
{ command (change_administrator_status, chaas) sfp$_change_administrator_statu local
{ command (change_job_limit, chajl) sfp$_change_job_limit xref
{ command (create_job_limit, crejl) sfp$_create_job_limit local
{ command (deactivate_job_statistic, deactivate_job_statistics, deajs) sfp$_deactivate_job_statistic xref
{ command (deactivate_system_statistic, deactivate_system_statistics, deass)             ..
{   sfp$deactivate_sys_stat_command     xref
{ command (display_active_job_statistic, display_active_job_statistics, disajs)                 ..
{   sfp$_display_active_job_statist xref
{ command (display_active_system_statistic, disass) sfp$_display_active_system_stat xref
{ command (display_administrator_status, disas) sfp$_display_administrator_stat local
{ command (display_job_limit, display_job_limits, disjl) sfp$_display_job_limit xref
{ command (emit_statistic, emis) sfp$_emit_statistic local
{ command (quit, qui) sfp$_quit local
{ command (set_job_limit, set_job_limits, setjl) sfp$_set_job_limit xref
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  commands: [STATIC, READ] ^clt$command_table := ^commands_entries,

  commands_entries: [STATIC, READ] array [1 .. 35] of clt$command_table_entry := [
  {} ['ACTIVATE_JOB_STATISTIC         ', clc$nominal_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^sfp$_activate_job_statistic],
  {} ['ACTIVATE_JOB_STATISTICS        ', clc$alias_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^sfp$_activate_job_statistic],
  {} ['ACTIVATE_SYSTEM_STATISTIC      ', clc$nominal_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^sfp$activate_sys_stat_command],
  {} ['ACTIVATE_SYSTEM_STATISTICS     ', clc$alias_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^sfp$activate_sys_stat_command],
  {} ['ACTJS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 1,
        clc$automatically_log, clc$linked_call, ^sfp$_activate_job_statistic],
  {} ['ACTSS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 2,
        clc$automatically_log, clc$linked_call, ^sfp$activate_sys_stat_command],
  {} ['CHAAS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^sfp$_change_administrator_statu],
  {} ['CHAJL                          ', clc$abbreviation_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^sfp$_change_job_limit],
  {} ['CHANGE_ADMINISTRATOR_STATUS    ', clc$nominal_entry, clc$normal_usage_entry, 3,
        clc$automatically_log, clc$linked_call, ^sfp$_change_administrator_statu],
  {} ['CHANGE_JOB_LIMIT               ', clc$nominal_entry, clc$normal_usage_entry, 4,
        clc$automatically_log, clc$linked_call, ^sfp$_change_job_limit],
  {} ['CREATE_JOB_LIMIT               ', clc$nominal_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^sfp$_create_job_limit],
  {} ['CREJL                          ', clc$abbreviation_entry, clc$normal_usage_entry, 5,
        clc$automatically_log, clc$linked_call, ^sfp$_create_job_limit],
  {} ['DEACTIVATE_JOB_STATISTIC       ', clc$nominal_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^sfp$_deactivate_job_statistic],
  {} ['DEACTIVATE_JOB_STATISTICS      ', clc$alias_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^sfp$_deactivate_job_statistic],
  {} ['DEACTIVATE_SYSTEM_STATISTIC    ', clc$nominal_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^sfp$deactivate_sys_stat_command],
  {} ['DEACTIVATE_SYSTEM_STATISTICS   ', clc$alias_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^sfp$deactivate_sys_stat_command],
  {} ['DEAJS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 6,
        clc$automatically_log, clc$linked_call, ^sfp$_deactivate_job_statistic],
  {} ['DEASS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 7,
        clc$automatically_log, clc$linked_call, ^sfp$deactivate_sys_stat_command],
  {} ['DISAJS                         ', clc$abbreviation_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^sfp$_display_active_job_statist],
  {} ['DISAS                          ', clc$abbreviation_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^sfp$_display_administrator_stat],
  {} ['DISASS                         ', clc$abbreviation_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^sfp$_display_active_system_stat],
  {} ['DISJL                          ', clc$abbreviation_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^sfp$_display_job_limit],
  {} ['DISPLAY_ACTIVE_JOB_STATISTIC   ', clc$nominal_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^sfp$_display_active_job_statist],
  {} ['DISPLAY_ACTIVE_JOB_STATISTICS  ', clc$alias_entry, clc$normal_usage_entry, 8,
        clc$automatically_log, clc$linked_call, ^sfp$_display_active_job_statist],
  {} ['DISPLAY_ACTIVE_SYSTEM_STATISTIC', clc$nominal_entry, clc$normal_usage_entry, 9,
        clc$automatically_log, clc$linked_call, ^sfp$_display_active_system_stat],
  {} ['DISPLAY_ADMINISTRATOR_STATUS   ', clc$nominal_entry, clc$normal_usage_entry, 10,
        clc$automatically_log, clc$linked_call, ^sfp$_display_administrator_stat],
  {} ['DISPLAY_JOB_LIMIT              ', clc$nominal_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^sfp$_display_job_limit],
  {} ['DISPLAY_JOB_LIMITS             ', clc$alias_entry, clc$normal_usage_entry, 11,
        clc$automatically_log, clc$linked_call, ^sfp$_display_job_limit],
  {} ['EMIS                           ', clc$abbreviation_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^sfp$_emit_statistic],
  {} ['EMIT_STATISTIC                 ', clc$nominal_entry, clc$normal_usage_entry, 12,
        clc$automatically_log, clc$linked_call, ^sfp$_emit_statistic],
  {} ['QUI                            ', clc$abbreviation_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^sfp$_quit],
  {} ['QUIT                           ', clc$nominal_entry, clc$normal_usage_entry, 13,
        clc$automatically_log, clc$linked_call, ^sfp$_quit],
  {} ['SETJL                          ', clc$abbreviation_entry, clc$normal_usage_entry, 14,
        clc$automatically_log, clc$linked_call, ^sfp$_set_job_limit],
  {} ['SET_JOB_LIMIT                  ', clc$nominal_entry, clc$normal_usage_entry, 14,
        clc$automatically_log, clc$linked_call, ^sfp$_set_job_limit],
  {} ['SET_JOB_LIMITS                 ', clc$alias_entry, clc$normal_usage_entry, 14,
        clc$automatically_log, clc$linked_call, ^sfp$_set_job_limit]];

  PROCEDURE [XREF] sfp$activate_sys_stat_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] sfp$deactivate_sys_stat_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] sfp$_activate_job_statistic
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] sfp$_change_job_limit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] sfp$_deactivate_job_statistic
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] sfp$_display_active_job_statist
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] sfp$_display_active_system_stat
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] sfp$_display_job_limit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

  PROCEDURE [XREF] sfp$_set_job_limit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? POP ??

{ table functions type=function
{ function ($job_limit) sfp$$job_limit xref
{ tablend

?? PUSH (LISTEXT := ON) ??

VAR
  functions: [STATIC, READ] ^clt$function_processor_table := ^functions_entries,

  functions_entries: [STATIC, READ] array [1 .. 1] of clt$function_proc_table_entry := [
  {} ['$JOB_LIMIT                     ', clc$nominal_entry, clc$normal_usage_entry, 1, clc$linked_call,
         ^sfp$$job_limit]];

  PROCEDURE [XREF] sfp$$job_limit
    (    parameter_list: clt$parameter_list;
     VAR work_area {input, output} : ^clt$work_area;
     VAR result: ^clt$data_value;
     VAR status: ost$status);

?? POP ??

    VAR
      binary_log: pmt$logs,
      ignore_status: ost$status,
      utility_attributes: ^clt$utility_attributes;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Delete the local files used to hold the test harness versions of the logs.

    FOR binary_log := pmc$job_account_log TO pmc$job_log DO
      amp$return (lgv$log_names [binary_log], ignore_status);
    FOREND;

{ Create the fake system heaps used by the test harness.

    create_heap (osv$job_pageable_heap, job_pageable_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    create_heap (osv$mainframe_pageable_heap, mainframe_pageable_file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Initialize the administrator variables.

    family_administrator := FALSE;
    system_administrator := TRUE;
    system_error_encountered := FALSE;

    RESET osv$job_pageable_heap^;

{ Initialize the fake system routing control table.

    sfp$init_system_routing_control (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Initialize the fake job routing control table.

    sfp$init_job_routing_control (status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Initialize the fake limit chain (no limits are automatically created).

    sfv$job_limit_count := 0;

{ Start up the test harness utility.

    PUSH utility_attributes: [1 .. 3];
    utility_attributes^ [1].key := clc$utility_prompt;
    utility_attributes^ [1].prompt.value := test_harness_prompt;
    utility_attributes^ [1].prompt.size := clp$trimmed_string_size (utility_attributes^ [1].prompt.value);
    utility_attributes^ [2].key := clc$utility_command_table;
    utility_attributes^ [2].command_table := commands;
    utility_attributes^ [3].key := clc$utility_function_proc_table;
    utility_attributes^ [3].function_processor_table := functions;
    clp$begin_utility (test_harness_name, utility_attributes^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, '', test_harness_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Exit the utility.

    clp$end_utility (test_harness_name, ignored_status);

{ Close the fake operating system heaps.

    amp$close (job_pageable_file_id, ignored_status);
    amp$close (mainframe_pageable_file_id, ignored_status);

{ Report if a system error occured.

    IF system_error_encountered THEN
      osp$set_status_abnormal ('SF', 0, 'A system error was encountered during the test harness execution.',
            status);
    IFEND;

  PROCEND sfp$test_harness;
?? OLDTITLE ??
?? NEWTITLE := 'Test Harness Subcommand Processors' ??
?? NEWTITLE := 'sfp$_change_administrator_statu', EJECT ??

  PROCEDURE sfp$_change_administrator_statu
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE change_administrator_status, chaas (
{   administrator_status, as: key
{       (system_administrator, sa)
{       (family_administrator, fa)
{       none
{     keyend = family_administrator
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 5] of clt$keyword_specification,
          default_value: string (20),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 27, 15, 6, 44, 229], clc$command, 3, 2, 0, 0, 0, 0, 2,
            'CHANGE_ADMINISTRATOR_STATUS'], [['ADMINISTRATOR_STATUS           ', clc$nominal_entry, 1],
            ['AS                             ', clc$abbreviation_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 2]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 192, clc$optional_default_parameter, 0, 20],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$keyword_type], [5], [['FA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['FAMILY_ADMINISTRATOR           ', clc$nominal_entry,
            clc$normal_usage_entry, 2], ['NONE                           ', clc$nominal_entry,
            clc$normal_usage_entry, 3], ['SA                             ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['SYSTEM_ADMINISTRATOR           ', clc$nominal_entry,
            clc$normal_usage_entry, 1]], 'family_administrator'],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$administrator_status = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      value: clt$value;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$administrator_status].value^.keyword_value = 'SYSTEM_ADMINISTRATOR' THEN
      family_administrator := FALSE;
      system_administrator := TRUE;
    ELSEIF pvt [p$administrator_status].value^.keyword_value = 'FAMILY_ADMINISTRATOR' THEN
      family_administrator := TRUE;
      system_administrator := FALSE;
    ELSE { NONE }
      family_administrator := FALSE;
      system_administrator := FALSE;
    IFEND;

  PROCEND sfp$_change_administrator_statu;
?? OLDTITLE ??
?? NEWTITLE := 'sfp$_create_job_limit', EJECT ??

  PROCEDURE sfp$_create_job_limit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE create_job_limit, crejl (
{   limit_name, ln: name = $required
{   statistic_codes, sc: list of statistic_code = $optional
{   initial_value, iv: integer = 0
{   job_warning_limit, jwl: any of
{       integer 0..clc$max_integer
{       key
{         unlimited
{       keyend
{     anyend = unlimited
{   job_maximum_limit, jmaxl: any of
{       integer 0..clc$max_integer
{       key
{         unlimited
{       keyend
{     anyend = unlimited
{   enforcement, e: key
{       (accumulation, a)
{       (other, o)
{     keyend = accumulation
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 13] of clt$pdt_parameter_name,
        parameters: array [1 .. 7] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          qualifier: clt$name_type_qualifier,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
          recend,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$integer_type_qualifier,
          default_value: string (1),
        recend,
        type4: 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$integer_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 1] of clt$keyword_specification,
          recend,
          default_value: string (9),
        recend,
        type5: 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$integer_type_qualifier,
          recend,
          type_size_2: clt$type_specification_size,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 1] of clt$keyword_specification,
          recend,
          default_value: string (9),
        recend,
        type6: record
          header: clt$type_specification_header,
          qualifier: clt$keyword_type_qualifier,
          keyword_specs: array [1 .. 4] of clt$keyword_specification,
          default_value: string (12),
        recend,
        type7: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 28, 8, 42, 23, 161], clc$command, 13, 7, 1, 0, 0, 0, 7, 'CREJL'],
            [['E                              ', clc$abbreviation_entry, 6],
            ['ENFORCEMENT                    ', clc$nominal_entry, 6],
            ['INITIAL_VALUE                  ', clc$nominal_entry, 3],
            ['IV                             ', clc$abbreviation_entry, 3],
            ['JMAXL                          ', clc$abbreviation_entry, 5],
            ['JOB_MAXIMUM_LIMIT              ', clc$nominal_entry, 5],
            ['JOB_WARNING_LIMIT              ', clc$nominal_entry, 4],
            ['JWL                            ', clc$abbreviation_entry, 4],
            ['LIMIT_NAME                     ', clc$nominal_entry, 1],
            ['LN                             ', clc$abbreviation_entry, 1],
            ['SC                             ', clc$abbreviation_entry, 2],
            ['STATISTIC_CODES                ', clc$nominal_entry, 2],
            ['STATUS                         ', clc$nominal_entry, 7]], [

{ PARAMETER 1

      [9, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 5, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [12, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 19, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 20, clc$optional_default_parameter, 0, 1],

{ PARAMETER 4

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 84, clc$optional_default_parameter, 0, 9],

{ PARAMETER 5

      [6, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 84, clc$optional_default_parameter, 0, 9],

{ PARAMETER 6

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 12],

{ PARAMETER 7

      [13, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name], clc$pass_by_reference, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$name_type], [1, osc$max_name_size]],

{ PARAMETER 2

      [[1, 0, clc$list_type], [3, 1, clc$max_list_size, FALSE], [[1, 0, clc$statistic_code_type]]],

{ PARAMETER 3

      [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10], '0'],

{ PARAMETER 4

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 20,
            [[1, 0, clc$integer_type], [0, clc$max_integer, 10]], 44,
            [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 'unlimited'],

{ PARAMETER 5

      [[1, 0, clc$union_type], [[clc$integer_type, clc$keyword_type], FALSE, 2], 20,
            [[1, 0, clc$integer_type], [0, clc$max_integer, 10]], 44,
            [[1, 0, clc$keyword_type], [1], [['UNLIMITED                      ', clc$nominal_entry,
            clc$normal_usage_entry, 1]]], 'unlimited'],

{ PARAMETER 6

      [[1, 0, clc$keyword_type], [4], [['A                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 1], ['ACCUMULATION                   ', clc$nominal_entry,
            clc$normal_usage_entry, 1], ['O                              ', clc$abbreviation_entry,
            clc$normal_usage_entry, 2], ['OTHER                          ', clc$nominal_entry,
            clc$normal_usage_entry, 2]], 'accumulation'],

{ PARAMETER 7

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$limit_name = 1,
      p$statistic_codes = 2,
      p$initial_value = 3,
      p$job_warning_limit = 4,
      p$job_maximum_limit = 5,
      p$enforcement = 6,
      p$status = 7;

    VAR
      pvt: array [1 .. 7] of clt$parameter_value;

    VAR
      current_parameter_value: ^clt$data_value,
      enforcement: sft$enforcement,
      index: integer,
      initial_value: sft$counter,
      job_maximum_limit: sft$counter,
      job_warning_limit: sft$counter,
      limit_name: ost$name,
      statistic_codes: ^array [1 .. * ] of sft$statistic_code,
      statistic_name: ost$name;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    limit_name := pvt [p$limit_name].value^.name_value;

    IF pvt [p$statistic_codes].specified THEN
      index := 0;
      PUSH statistic_codes: [1 .. clp$count_list_elements (pvt [p$statistic_codes].value)];
      current_parameter_value := pvt [p$statistic_codes].value;
      WHILE current_parameter_value <> NIL DO
        sfp$convert_stat_code_to_name (current_parameter_value^.statistic_code_value, statistic_name, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        index := index + 1;
        statistic_codes^ [index] := current_parameter_value^.statistic_code_value;
        current_parameter_value := current_parameter_value^.link;
      WHILEND;
    ELSE
      statistic_codes := NIL;
    IFEND;

    initial_value := pvt [p$initial_value].value^.integer_value.value;

    IF pvt [p$job_warning_limit].value^.kind = clc$keyword THEN
      job_warning_limit := sfc$unlimited;
    ELSE
      job_warning_limit := pvt [p$job_warning_limit].value^.integer_value.value;
    IFEND;

    IF pvt [p$job_maximum_limit].value^.kind = clc$keyword THEN
      job_maximum_limit := sfc$unlimited;
    ELSE
      job_maximum_limit := pvt [p$job_maximum_limit].value^.integer_value.value;
    IFEND;

    IF pvt [p$enforcement].value^.keyword_value = 'ACCUMULATION' THEN
      enforcement := sfc$accumulation_enforcement;
    ELSE { OTHER }
      enforcement := sfc$other_enforcement;
    IFEND;

    sfp$create_job_limit (limit_name, statistic_codes, initial_value, job_warning_limit, job_maximum_limit,
          enforcement, status);

  PROCEND sfp$_create_job_limit;
?? OLDTITLE ??
?? NEWTITLE := 'sfp$_display_administrator_stat', EJECT ??

  PROCEDURE sfp$_display_administrator_stat
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE display_administrator_status, disao (
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 3] of clt$pdt_parameter_name,
        parameters: array [1 .. 2] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
          default_value: string (7),
        recend,
        type2: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 28, 8, 4, 28, 466], clc$command, 3, 2, 0, 0, 0, 0, 2, 'DISAO'],
            [['O                              ', clc$abbreviation_entry, 1],
            ['OUTPUT                         ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 2]], [

{ PARAMETER 1

      [2, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$file_type], '$output'],

{ PARAMETER 2

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$output = 1,
      p$status = 2;

    VAR
      pvt: array [1 .. 2] of clt$parameter_value;

    VAR
      display_control: clt$display_control,
      file_contents: amt$file_contents,
      ring_attributes: amt$ring_attributes;

*copy clv$display_variables

?? NEWTITLE := 'Dummy title because of error in clp$new_page_procedure' ??
*copyc clp$new_page_procedure

    PROCEDURE put_subtitle
      (VAR display_control: clt$display_control;
       VAR status: ost$status);

{ Dummy subtitle procedure

    PROCEND put_subtitle;
?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Open the output file.

    clv$titles_built := FALSE;
    clv$command_name := 'display_administrator_status';
    ring_attributes.r1 := #RING (^ring_attributes);
    ring_attributes.r2 := #RING (^ring_attributes);
    ring_attributes.r3 := #RING (^ring_attributes);
    file_contents := amc$list;

    clp$open_display_reference (pvt [p$output].value^.file_value^, ^clp$new_page_procedure, file_contents,
          ring_attributes, display_control, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Set default page width.

    IF display_control.page_width < clc$narrow_page_width THEN
      clv$page_width := clc$narrow_page_width;
    ELSE
      clv$page_width := display_control.page_width;
    IFEND;

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF system_administrator THEN
      clp$put_display (display_control, ' System administrator', clc$trim, status);
    ELSEIF family_administrator THEN
      clp$put_display (display_control, ' Family administrator', clc$trim, status);
    ELSE
      clp$put_display (display_control, ' Not an administrator', clc$trim, status);
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$put_display (display_control, ' ', clc$trim, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$close_display (display_control, status);

  PROCEND sfp$_display_administrator_stat;
?? OLDTITLE ??
?? NEWTITLE := 'sfp$_emit_statistic', EJECT ??

  PROCEDURE sfp$_emit_statistic
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE emit_statistic, emis (
{   statistic_code, sc: statistic_code = $required
{   counters, counter, c: list of integer = $optional
{   descriptive_data, dd: string = $optional
{   status)

?? PUSH (LISTEXT := ON) ??

    VAR
      pdt: [STATIC, READ, cls$declaration_section] record
        header: clt$pdt_header,
        names: array [1 .. 8] of clt$pdt_parameter_name,
        parameters: array [1 .. 4] of clt$pdt_parameter,
        type1: record
          header: clt$type_specification_header,
        recend,
        type2: record
          header: clt$type_specification_header,
          qualifier: clt$list_type_qualifier,
          element_type_spec: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
        type3: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
        type4: record
          header: clt$type_specification_header,
        recend,
      recend := [[1, [88, 10, 27, 16, 11, 11, 424], clc$command, 8, 4, 1, 0, 0, 0, 4, 'EMIS'],
            [['C                              ', clc$abbreviation_entry, 2],
            ['COUNTER                        ', clc$alias_entry, 2],
            ['COUNTERS                       ', clc$nominal_entry, 2],
            ['DD                             ', clc$abbreviation_entry, 3],
            ['DESCRIPTIVE_DATA               ', clc$nominal_entry, 3],
            ['SC                             ', clc$abbreviation_entry, 1],
            ['STATISTIC_CODE                 ', clc$nominal_entry, 1],
            ['STATUS                         ', clc$nominal_entry, 4]], [

{ PARAMETER 1

      [7, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 3, clc$required_parameter, 0, 0],

{ PARAMETER 2

      [3, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 36, clc$optional_parameter, 0, 0],

{ PARAMETER 3

      [5, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods
            [clc$specify_by_name, clc$specify_positionally], clc$pass_by_value, clc$immediate_evaluation,
            clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],

{ PARAMETER 4

      [8, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$statistic_code_type]],

{ PARAMETER 2

      [[1, 0, clc$list_type], [20, 1, clc$max_list_size, FALSE],
            [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10]]],

{ PARAMETER 3

      [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]],

{ PARAMETER 4

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$statistic_code = 1,
      p$counters = 2,
      p$descriptive_data = 3,
      p$status = 4;

    VAR
      pvt: array [1 .. 4] of clt$parameter_value;

    VAR
      counter_array: sft$counters,
      current_parameter_value: ^clt$data_value,
      descriptive_data: ost$string,
      number_of_counters: 0 .. clc$max_value_sets,
      index: integer,
      statistic_name: ost$name;

    status.normal := TRUE;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sfp$convert_stat_code_to_name (pvt [p$statistic_code].value^.statistic_code_value, statistic_name,
          status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [p$counters].specified THEN
      index := 0;
      PUSH counter_array: [1 .. clp$count_list_elements (pvt [p$counters].value)];
      current_parameter_value := pvt [p$counters].value;
      WHILE current_parameter_value <> NIL DO
        index := index + 1;
        counter_array^ [index] := current_parameter_value^.integer_value.value;
        current_parameter_value := current_parameter_value^.link;
      WHILEND;
    ELSE
      counter_array := NIL;
    IFEND;

    IF pvt [p$descriptive_data].specified THEN
      descriptive_data.value := pvt [p$descriptive_data].value^.string_value^;
      descriptive_data.size := STRLENGTH (pvt [p$descriptive_data].value^.string_value^);
    ELSE
      descriptive_data.value := '';
      descriptive_data.size := 0;
    IFEND;

    sfp$emit_statistic (pvt [p$statistic_code].value^.statistic_code_value, descriptive_data.
          value (1, descriptive_data.size), counter_array, status);

  PROCEND sfp$_emit_statistic;
?? OLDTITLE ??
?? NEWTITLE := 'sfp$_quit', EJECT ??

  PROCEDURE sfp$_quit
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE quit (
{   status)

?? PUSH (LISTEXT := ON) ??

    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,
        recend,
      recend := [[1, [88, 10, 28, 7, 48, 16, 241], clc$command, 1, 1, 0, 0, 0, 0, 1, 'QUIT'],
            [['STATUS                         ', clc$nominal_entry, 1]], [

{ PARAMETER 1

      [1, clc$normal_usage_entry, clc$non_secure_parameter, $clt$parameter_spec_methods [clc$specify_by_name],
            clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
            clc$optional_parameter, 0, 0]],

{ PARAMETER 1

      [[1, 0, clc$status_type]]];

?? POP ??

    CONST
      p$status = 1;

    VAR
      pvt: array [1 .. 1] of clt$parameter_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_include (test_harness_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND sfp$_quit;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'Test Harness Miscellaneous Support Routines' ??
?? NEWTITLE := 'create_heap', EJECT ??

  PROCEDURE create_heap
    (VAR heap_pointer: ^ost$heap;
     VAR file_id: amt$file_identifier;
     VAR status: ost$status);

    VAR
      file_attributes: array [1 .. 1] of amt$access_selection,
      file_name: amt$local_file_name,
      segment_pointer: amt$segment_pointer,
      unique_name: ost$unique_name;

    pmp$generate_unique_name (unique_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    file_name := unique_name.value;
    file_attributes [1].key := amc$return_option;
    file_attributes [1].return_option := amc$return_at_close;
    amp$open (file_name, amc$segment, ^file_attributes, file_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$get_segment_pointer (file_id, amc$heap_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    RESET segment_pointer.heap_pointer^;
    heap_pointer := segment_pointer.heap_pointer;
    RETURN;

  PROCEND create_heap;
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := 'Test Harness Stubs for System Routines' ??
?? NEWTITLE := 'avp$monitor_statistics_handler', EJECT ??

  PROCEDURE [XDCL] avp$monitor_statistics_handler
    (    flag_id: ost$system_flag);

  PROCEND avp$monitor_statistics_handler;
?? OLDTITLE ??
?? NEWTITLE := 'avp$system_administrator', EJECT ??

  FUNCTION [XDCL] avp$system_administrator: boolean;

    avp$system_administrator := system_administrator;

  FUNCEND avp$system_administrator;
?? OLDTITLE ??
?? NEWTITLE := 'clp$find_current_job_synch_task', EJECT ??

  PROCEDURE [XDCL] clp$find_current_job_synch_task
    (VAR task_id: pmt$task_id;
     VAR status: ost$status);

    pmp$get_task_id (task_id, status);

  PROCEND clp$find_current_job_synch_task;
?? OLDTITLE ??
?? NEWTITLE := 'clp$process_when_condition', EJECT ??

  PROCEDURE [XDCL] clp$process_when_condition
    (    condition: clt$when_condition;
         condition_status: ost$status;
     VAR condition_processed: boolean;
     VAR status: ost$status);

    condition_processed := FALSE;
    status.normal := TRUE;

  PROCEND clp$process_when_condition;
?? OLDTITLE ??
?? NEWTITLE := 'jmp$logout', EJECT ??

  PROCEDURE [XDCL] jmp$logout
    (VAR status: ost$status);

    osp$set_status_abnormal ('SF', 0, ' LOGOUT was called.', status);

  PROCEND jmp$logout;
?? OLDTITLE ??
?? NEWTITLE := 'lgp$add_entry_global_binary_log', EJECT ??

  PROCEDURE [XDCL] lgp$add_entry_global_binary_log
    (    global_binary_log: pmt$global_binary_logs;
         entry: ^SEQ ( * );
     VAR log_cycle: lgt$log_cycle;
     VAR status: ost$status);

    VAR
      log_name: amt$local_file_name,
      log_id: amt$file_identifier,
      log_attachment_option: ^fst$attachment_options,
      record_byte_address: amt$file_byte_address;

    log_name := lgv$log_names [global_binary_log];
    PUSH log_attachment_option: [1 .. 3];
    log_attachment_option^ [1].selector := fsc$access_and_share_modes;
    log_attachment_option^ [1].access_modes.selector := fsc$specific_access_modes;
    log_attachment_option^ [1].access_modes.value := $fst$file_access_options [fsc$append];
    log_attachment_option^ [1].share_modes.selector := fsc$specific_share_modes;
    log_attachment_option^ [1].share_modes.value := $fst$file_access_options [];
    log_attachment_option^ [2].selector := fsc$create_file;
    log_attachment_option^ [2].create_file := TRUE;
    log_attachment_option^ [3].selector := fsc$open_position;
    log_attachment_option^ [3].open_position := amc$open_at_eoi;
    fsp$open_file (log_name, amc$record, log_attachment_option, NIL, NIL, NIL, NIL, log_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$put_next (log_id, entry, #SIZE (entry^), record_byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$close_file (log_id, status);

  PROCEND lgp$add_entry_global_binary_log;
?? OLDTITLE ??
?? NEWTITLE := 'lgp$add_entry_local_binary_log', EJECT ??

  PROCEDURE [XDCL] lgp$add_entry_local_binary_log
    (    local_binary_log: pmt$local_binary_logs;
         entry: ^SEQ ( * );
     VAR log_cycle: lgt$log_cycle;
     VAR status: ost$status);

    VAR
      log_name: amt$local_file_name,
      log_id: amt$file_identifier,
      log_attachment_option: ^fst$attachment_options,
      record_byte_address: amt$file_byte_address;

    log_name := lgv$log_names [local_binary_log];
    PUSH log_attachment_option: [1 .. 3];
    log_attachment_option^ [1].selector := fsc$access_and_share_modes;
    log_attachment_option^ [1].access_modes.selector := fsc$specific_access_modes;
    log_attachment_option^ [1].access_modes.value := $fst$file_access_options [fsc$append];
    log_attachment_option^ [1].share_modes.selector := fsc$specific_share_modes;
    log_attachment_option^ [1].share_modes.value := $fst$file_access_options [];
    log_attachment_option^ [2].selector := fsc$create_file;
    log_attachment_option^ [2].create_file := TRUE;
    log_attachment_option^ [3].selector := fsc$open_position;
    log_attachment_option^ [3].open_position := amc$open_at_eoi;
    fsp$open_file (log_name, amc$record, log_attachment_option, NIL, NIL, NIL, NIL, log_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$put_next (log_id, entry, #SIZE (entry^), record_byte_address, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    fsp$close_file (log_id, status);

  PROCEND lgp$add_entry_local_binary_log;
?? OLDTITLE ??
?? NEWTITLE := 'osp$system_error', EJECT ??

  PROCEDURE [XDCL] osp$system_error
    (    error_message: string ( * );
         status: ^ost$status);

    VAR
      ignored_status: ost$status;

    pmp$log ('* * * * * * * * * * * * * * * * * * * *', ignored_status);
    pmp$log ('*                                      ', ignored_status);
    pmp$log ('* THE FOLLOWING SYSTEM ERROR OCCURRED: ', ignored_status);
    pmp$log (error_message, ignored_status);
    pmp$log ('*                                      ', ignored_status);
    pmp$log ('* * * * * * * * * * * * * * * * * * * *', ignored_status);
    system_error_encountered := TRUE;

  PROCEND osp$system_error;
?? OLDTITLE ??
?? NEWTITLE := 'osp$test_signature_lock', EJECT ??

  PROCEDURE [XDCL] osp$test_signature_lock
    (VAR lock: ost$signature_lock;
     VAR lock_status: ost$signature_lock_status;
     VAR status: ost$status);

    IF lock.lock_id = 0 THEN
      lock_status := osc$sls_not_locked;
    ELSE
      lock_status := osc$sls_locked_by_current_task;
    IFEND;

  PROCEND osp$test_signature_lock;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$dispose_interactive_cond', EJECT ??

  PROCEDURE [XDCL] pmp$dispose_interactive_cond
    (    interactive_condition: ift$interactive_condition);

  PROCEND pmp$dispose_interactive_cond;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$get_global_task_id', EJECT ??

  PROCEDURE [XDCL] pmp$get_global_task_id
    (    task_id: pmt$task_id;
     VAR global_task_id: ost$global_task_id;
     VAR status: ost$status);

    pmp$get_executing_task_gtid (global_task_id);

  PROCEND pmp$get_global_task_id;
?? OLDTITLE ??
?? NEWTITLE := 'pmp$send_signal', EJECT ??

  PROCEDURE [XDCL] pmp$send_signal
    (    recipient: ost$global_task_id;
         signal: pmt$signal;
     VAR status: ost$status);

    VAR
      condition_id: ^jmt$job_resource_condition;

    condition_id := #LOC (signal.contents);
    jmp$default_job_resource_hndlr (condition_id^, status);

  PROCEND pmp$send_signal;
?? OLDTITLE ??
?? NEWTITLE := 'sfp$change_file_space_limit', EJECT ??

  PROCEDURE [XDCL] sfp$change_file_space_limit
    (    file_space_limit_kind: sft$file_space_limit_kind;
         job_warning_limit: ^sft$counter;
         job_maximum_limit: ^sft$counter;
         accumulator: ^sft$counter;
         job_warning_checking: ^boolean);

  PROCEND sfp$change_file_space_limit;
?? OLDTITLE ??
?? NEWTITLE := 'sfp$get_file_space_limit', EJECT ??

  PROCEDURE [XDCL] sfp$get_file_space_limit
    (    file_space_limit_kind: sft$file_space_limit_kind;
     VAR job_warning_limit: sft$counter;
     VAR job_maximum_limit: sft$counter;
     VAR accumulator: sft$counter);

    job_warning_limit := sfc$unlimited;
    job_maximum_limit := sfc$unlimited;
    accumulator := 0;

  PROCEND sfp$get_file_space_limit;
?? OLDTITLE ??
?? NEWTITLE := 'tmp$fetch_job_statistics', EJECT ??

  PROCEDURE [XDCL] tmp$fetch_job_statistics
    (VAR statistics: jmt$job_statistics;
     VAR status: ost$status);

    VAR
      cp_time: pmt$task_cp_time;

    pmp$get_task_cp_time (cp_time, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    statistics.cp_time.time_spent_in_job_mode := cp_time.task_time;
    statistics.cp_time.time_spent_in_mtr_mode := cp_time.monitor_time;
    statistics.working_set_size := 1;
    statistics.ready_task_count := 2;
    statistics.paging_statistics.page_in_count := 3;
    statistics.paging_statistics.pages_reclaimed_from_queue := 4;
    statistics.paging_statistics.new_pages_assigned := 5;

  PROCEND tmp$fetch_job_statistics;
?? OLDTITLE ??
?? OLDTITLE ??
MODEND sfm$test_harness;
*DECK DECK=SFP$ACCUMULATE_FILE_SPACE EXPAND=FALSE

{  PURPOSE:
{    This inline procedure is called from job mode.  It makes a
{    monitor call to the monitor inline which accumulates file space.
{
{  DESIGN:
{    The accumulator specified can be any integer value.
{    This procedure is used for both permanent and temporary file
{    space limits.  It may only be called from ring 3 or below.
{
{    If the system attribute for dynamic file space limits is false,
{    Then this procedure returns with no action.

  PROCEDURE [INLINE] sfp$accumulate_file_space
    (    file_space_limit_kind: sft$file_space_limit_kind;
         accumulator: sft$counter);

?? PUSH (LISTEXT := ON) ??

    VAR
      request_block: sft$rb_stats_facility_requests;

    IF sfv$dynamic_file_space_limits THEN
      request_block.reqcode := syc$rc_stats_facility_request;
      request_block.sub_reqcode := sfc$accumulate_file_space;
      request_block.file_space_limit_kind := file_space_limit_kind;
      request_block.accumulator := accumulator;
      i#call_monitor (#LOC (request_block), #SIZE(request_block));
    IFEND;

  PROCEND sfp$accumulate_file_space;
*copyc i#call_monitor
*copyc sft$counter
*copyc sft$file_space_limit_kind
*copyc sft$rb_stats_facility_requests
*copyc sfv$dynamic_file_space_limits
*copyc syc$monitor_request_codes
?? POP ??
*DECK DECK=SFP$ACTIVATE_AUDIT EXPAND=FALSE

  PROCEDURE [XREF] sfp$activate_audit
    (    operation_set: sft$audited_operation_set;
         selection_criteria: sft$audit_selection_criteria;
         routing_control_table_id: sft$routing_control_table_id;
         lock: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$insufficient_privilege
*copyc sfe$statistics_not_available
*copyc sfe$unknown_audit_operation
*copyc sfe$unknown_audit_selector
*copyc sft$audited_operation_set
*copyc sft$audit_selection_criteria
*copyc sft$routing_control_table_id
?? POP ??

*DECK DECK=SFP$ACTIVATE_JOB_STATISTIC EXPAND=FALSE

  PROCEDURE [XREF] sfp$activate_job_statistic
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$insufficient_privilege
*copyc sfe$statistics_not_available
*copyc sfe$unknown_routing_ctl_access
*copyc sft$binary_logset
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$ACTIVATE_SYSTEM_STATISTIC EXPAND=FALSE

  PROCEDURE [XREF] sfp$activate_system_statistic
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$insufficient_privilege
*copyc sfe$statistics_not_available
*copyc sfe$unknown_routing_ctl_access
*copyc sft$binary_logset
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$ADD_AUDIT_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$add_audit_control
    (    routing_control_table_p: sft$routing_control_table;
         operation_set: sft$audited_operation_set;
         selection_criteria: sft$audit_selection_criteria;
         lock: boolean;
         os_heap: ^ost$heap);

?? PUSH (LISTEXT := ON) ??
*copyc ost$heap
*copyc sft$audit_selection_criteria
*copyc sft$audited_operation_set
*copyc sft$routing_control_table
?? POP ??
*DECK DECK=SFP$ADD_JOB_AUDIT_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$add_job_audit_control
    (    operation_set: sft$audited_operation_set;
         selection_criteria: sft$audit_selection_criteria;
         lock: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sft$audit_selection_criteria
*copyc sft$audited_operation_set
?? POP ??
*DECK DECK=SFP$ADD_JOB_ROUTING_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$add_job_routing_control
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
         limit_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc sfe$statistics_not_available
*copyc sft$binary_logset
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$ADD_ROUTING_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$add_routing_control
    (    routing_control_table_p: sft$routing_control_table;
         statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
         os_heap: ^ost$heap;
     VAR routing_control_p: ^sft$routing_control);

?? PUSH (LISTEXT := ON) ??
*copyc ost$heap
*copyc sft$binary_logset
*copyc sft$routing_control
*copyc sft$routing_control_table
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$ADD_SYSTEM_AUDIT_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$add_system_audit_control
    (    operation_set: sft$audited_operation_set;
         selection_criteria: sft$audit_selection_criteria;
         lock: boolean;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sft$audit_selection_criteria
*copyc sft$audited_operation_set
?? POP ??
*DECK DECK=SFP$ADD_SYSTEM_ROUTING_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$add_system_routing_control
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$statistics_not_available
*copyc sft$binary_logset
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$AUDITING_OPERATION EXPAND=TRUE

  FUNCTION [XREF] sfp$auditing_operation
    (    operation: sft$audited_operation) : boolean;


?? PUSH (LISTEXT := ON) ??
*copyc sft$audited_operation
?? POP ??

*DECK DECK=SFP$BUILD_STATISTIC EXPAND=FALSE

  PROCEDURE [XREF] sfp$build_statistic
    (    statistic_code: sft$statistic_code;
         descriptive_data: sft$descriptive_data;
         counters: sft$counters;
         global_task_id: ost$global_task_id;
     VAR statistic: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc ost$status
*copyc sfe$work_area_full
*copyc sft$counters
*copyc sft$descriptive_data
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$CHANGE_FILE_SPACE_LIMIT EXPAND=FALSE

  PROCEDURE [XREF] sfp$change_file_space_limit
    (    file_space_limit_kind: sft$file_space_limit_kind;
         job_warning_limit: ^sft$counter;
         job_maximum_limit: ^sft$counter;
         accumulator: ^sft$counter;
         job_warning_checking: ^boolean);

?? PUSH (LISTEXT := ON) ??
*copyc sft$file_space_limit_kind
*copyc sft$counter
?? POP ??
*DECK DECK=SFP$CHANGE_JOB_RESOURCE_LIMIT EXPAND=FALSE

  PROCEDURE [XREF] sfp$change_job_resource_limit
    (    limit_name: ost$name;
         resource_limit: sft$counter;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc cle$ecc_lexical
*copyc ost$name
*copyc ost$status
*copyc sft$counter
*copyc sfe$limit_condition_codes
*copyc sfc$unlimited
?? POP ??
*DECK DECK=SFP$CHANGE_JOB_WARNING_LIMIT EXPAND=FALSE

  PROCEDURE [XREF] sfp$change_job_warning_limit
    (    limit_name: ost$name;
         warning_limit: sft$counter;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc cle$ecc_lexical
*copyc ost$name
*copyc ost$status
*copyc sft$counter
*copyc sfe$limit_condition_codes
*copyc sfc$unlimited
?? POP ??
*DECK DECK=SFP$CLEAR_JOB_ROUTING_CTL_LOCK EXPAND=FALSE

  PROCEDURE [XREF] sfp$clear_job_routing_ctl_lock;
*DECK DECK=SFP$CONVERT_STAT_CODE_TO_NAME EXPAND=FALSE

  PROCEDURE [XREF] sfp$convert_stat_code_to_name
    (    statistic_code: sft$statistic_code;
     VAR statistic_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc sfe$incorrect_statistic_code
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$CONVERT_STAT_NAME_TO_CODE EXPAND=FALSE

  PROCEDURE [XREF] sfp$convert_stat_name_to_code
    (    statistic_name: ost$name;
     VAR statistic_code: sft$statistic_code;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc sfe$invalid_statistic_name
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$CREATE_JOB_LIMIT EXPAND=FALSE

  PROCEDURE [XREF] sfp$create_job_limit
    (    limit_name: ost$name;
         statistic_codes: ^array [1 .. * ] of sft$statistic_code;
         initial_value: sft$counter;
         warning_limit: sft$counter;
         maximum_limit: sft$counter;
         enforcement: sft$enforcement;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc ost$name
*copyc ost$status
*copyc sfe$limit_condition_codes
*copyc sfe$statistics_not_available
*copyc sft$counter
*copyc sft$enforcement
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$CREATE_ROUTING_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$create_routing_control
    (    routing_control_table_p: sft$routing_control_table;
         statistic_code: sft$statistic_code;
         os_heap: ^ost$heap;
     VAR routing_control_p: ^sft$routing_control);

?? PUSH (LISTEXT := ON) ??
*copyc ost$heap
*copyc sft$routing_control
*copyc sft$routing_control_table
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$DEACTIVATE_AUDIT EXPAND=FALSE

  PROCEDURE [XREF] sfp$deactivate_audit
    (    operation_set: sft$audited_operation_set;
         routing_control_table_id: sft$routing_control_table_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$audit_control_locked
*copyc sfe$insufficient_privilege
*copyc sfe$statistics_not_available
*copyc sfe$unknown_audit_operation
*copyc sft$audited_operation_set
*copyc sft$routing_control_table_id
?? POP ??

*DECK DECK=SFP$DEACTIVATE_JOB_STATISTIC EXPAND=FALSE

  PROCEDURE [XREF] sfp$deactivate_job_statistic
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$insufficient_privilege
*copyc sfe$routing_control_locked
*copyc sfe$statistics_not_available
*copyc sfe$unknown_routing_ctl_access
*copyc sft$binary_logset
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$DEACTIVATE_SYSTEM_STATISTIC EXPAND=FALSE

  PROCEDURE [XREF] sfp$deactivate_system_statistic
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$insufficient_privilege
*copyc sfe$routing_control_locked
*copyc sfe$statistics_not_available
*copyc sfe$unknown_routing_ctl_access
*copyc sft$binary_logset
*copyc sft$statistic_code
?? POP ??












*DECK DECK=SFP$DELETE_AUDIT_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$delete_audit_control
    (    routing_control_table_p: sft$routing_control_table;
         operation_set: sft$audited_operation_set;
         os_heap: ^ost$heap;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$heap
*copyc ost$status
*copyc sfe$audit_control_locked
*copyc sft$audited_operation_set
*copyc sft$routing_control_table
?? POP ??
*DECK DECK=SFP$DELETE_JOB_AUDIT_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$delete_job_audit_control
    (    operation_set: sft$audited_operation_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sft$audited_operation_set
?? POP ??
*DECK DECK=SFP$DELETE_JOB_ROUTING_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$delete_job_routing_control
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$statistics_not_available
*copyc sft$binary_logset
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$DELETE_ROUTING_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$delete_routing_control
    (    routing_control_table_p: sft$routing_control_table;
         statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$routing_control_locked
*copyc sft$binary_logset
*copyc sft$routing_control_table
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$DELETE_SYS_AUDIT_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$delete_sys_audit_control
    (    operation_set: sft$audited_operation_set;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sft$audited_operation_set
?? POP ??
*DECK DECK=SFP$DELETE_SYS_ROUTING_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$delete_sys_routing_control
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$statistics_not_available
*copyc sft$binary_logset
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$EMIT_AUDIT_STATISTIC EXPAND=FALSE

  PROCEDURE [XREF] sfp$emit_audit_statistic
    (    audit_information: sft$audit_information;
         operation_status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$statistics_not_available
*copyc sfe$unknown_audit_operation
*copyc sft$audit_information
?? POP ??

*DECK DECK=SFP$EMIT_STATISTIC EXPAND=FALSE

  PROCEDURE [XREF] sfp$emit_statistic
    (    statistic_code: sft$statistic_code;
         descriptive_data: sft$descriptive_data;
         counters: sft$counters;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$limit_condition_codes
*copyc sfe$statistics_not_available
*copyc sft$counters
*copyc sft$descriptive_data
*copyc sft$statistic_code
?? POP ??

*DECK DECK=SFP$EMIT_SYSTEM_STATISTIC EXPAND=FALSE

  PROCEDURE [XREF] sfp$emit_system_statistic
    (    identifier: sft$statistic_identifier;
         statistic_code: sft$statistic_code;
         descriptive_data: sft$descriptive_data;
         counters: sft$counters;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$limit_condition_codes
*copyc sfe$statistics_not_available
*copyc sft$counters
*copyc sft$descriptive_data
*copyc sft$statistic_code
*copyc sft$statistic_identifier
*copyc sft$statistic_record
?? POP ??

*DECK DECK=SFP$GET_ACTIVE_JOB_STATISTICS EXPAND=FALSE

  PROCEDURE [XREF] sfp$get_active_job_statistics
    (    logs: sft$binary_logset;
     VAR head: ^sft$routing_control;
     VAR work_area: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$insufficient_privilege
*copyc sfe$statistics_not_available
*copyc sfe$unknown_routing_ctl_access
*copyc sft$binary_logset
*copyc sft$routing_control
?? POP ??
*DECK DECK=SFP$GET_ACTIVE_SYSTEM_STATS EXPAND=FALSE

  PROCEDURE [XREF] sfp$get_active_system_stats
    (    logs: sft$binary_logset;
     VAR head: ^sft$routing_control;
     VAR work_area: ^SEQ ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$insufficient_privilege
*copyc sfe$statistics_not_available
*copyc sfe$unknown_routing_ctl_access
*copyc sft$binary_logset
*copyc sft$routing_control
?? POP ??
*DECK DECK=SFP$GET_ALL_JOB_LIMITS EXPAND=FALSE

  PROCEDURE [XREF] sfp$get_all_job_limits
    (    limits: sft$limits;
     VAR count: jmt$job_resource_condition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc jmd$job_resource_condition
*copyc ost$status
*copyc sft$limit
*copyc sfe$limit_condition_codes
*copyc sfc$unlimited
?? POP ??
*DECK DECK=SFP$GET_AUDITED_OPERATIONS EXPAND=FALSE

  PROCEDURE [XREF] sfp$get_audited_operations
    (    routing_control_table_id: sft$routing_control_table_id;
     VAR work_area: ^SEQ ( * );
     VAR first_routing_control_entry: ^sft$routing_control;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$call_again_job_recovered
*copyc sfe$insufficient_privilege
*copyc sfe$statistics_not_available
*copyc sft$routing_control
*copyc sft$routing_control_table_id
?? POP ??
*DECK DECK=SFP$GET_FILE_SPACE_LIMIT EXPAND=FALSE

  PROCEDURE [XREF] sfp$get_file_space_limit
    (    file_space_limit_kind: sft$file_space_limit_kind;
     VAR job_warning_limit: sft$counter;
     VAR job_maximum_limit: sft$counter;
     VAR accumulator: sft$counter);

?? PUSH (LISTEXT := ON) ??
*copyc sft$file_space_limit_kind
*copyc sft$counter
?? POP ??
*DECK DECK=SFP$GET_JOB_LIMIT EXPAND=FALSE

  PROCEDURE [XREF] sfp$get_job_limit
    (    limit_name: ost$name;
     VAR limit: sft$limit;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc cle$ecc_lexical
*copyc ost$name
*copyc ost$status
*copyc sft$limit
*copyc sfe$limit_condition_codes
*copyc sfc$unlimited
?? POP ??
*DECK DECK=SFP$GET_JOB_LIMIT_COUNT EXPAND=FALSE

  PROCEDURE [XREF] sfp$get_job_limit_count
    (VAR limit_count: jmt$job_resource_condition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc jmd$job_resource_condition
*copyc ost$status
*copyc sfe$limit_condition_codes
?? POP ??
*DECK DECK=SFP$GET_JOB_LIMIT_NAME EXPAND=FALSE

  PROCEDURE [XREF] sfp$get_job_limit_name
    (    condition_id: jmt$job_resource_condition;
     VAR limit_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc jmd$job_resource_condition
*copyc ost$name
*copyc ost$status
*copyc sfe$limit_condition_codes
?? POP ??
*DECK DECK=SFP$GET_LOG_NAME EXPAND=FALSE

  PROCEDURE [XREF] sfp$get_log_name
    (    log: sft$binary_logs;
     VAR log_name: ost$name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc sft$binary_logs
?? POP ??
*DECK DECK=SFP$GET_ROUTING_CONTROLS EXPAND=FALSE

  PROCEDURE [XREF] sfp$get_routing_controls
   (    statistic_code: sft$statistic_code;
    VAR activated_logs: sft$binary_logset;
    VAR activated_limit_name: ost$name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
*copyc sfe$call_again_job_recovered
*copyc sft$binary_logset
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$INITIATE_RESOURCE_CONDITION EXPAND=FALSE

  PROCEDURE [XREF] sfp$initiate_resource_condition
    (    limit_chain_entry: ^sft$limit_chain_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$limit_condition_codes
*copyc sft$limit_chain_entry
?? POP ??
*DECK DECK=SFP$INIT_JOB_ROUTING_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$init_job_routing_control
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=SFP$INIT_SYSTEM_ROUTING_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$init_system_routing_control
    (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=SFP$INTERNAL_EMIT_STATISTIC EXPAND=FALSE

  PROCEDURE [XREF] sfp$internal_emit_statistic
    (    statistic_code: sft$statistic_code;
         descriptive_data: sft$descriptive_data;
         counters: sft$counters;
         global_task_id: ost$global_task_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc ost$status
*copyc sft$counters
*copyc sft$descriptive_data
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$JOB_LIMIT_CHAIN_ENTRY EXPAND=FALSE

  FUNCTION [INLINE] sfp$job_limit_chain_entry
    (    limit_name: ost$name): ^sft$limit_chain_entry;

?? PUSH (LISTEXT := ON) ??

    VAR
      current_limit_chain_entry: ^sft$limit_chain_entry,
      local_limit_name: ost$name;

{ Handle the case where the old name for the CPU time limit is specified.

    IF limit_name = avc$cp_time_limit_name THEN
      local_limit_name := avc$cpu_time_limit_name;
    ELSE
      local_limit_name := limit_name;
    IFEND;

    current_limit_chain_entry := sfv$first_job_limit_chain_entry;

  /search_for_limit_chain_entry/
    WHILE (current_limit_chain_entry <> NIL) AND
          (current_limit_chain_entry^.limit.name <> local_limit_name) DO
      current_limit_chain_entry := current_limit_chain_entry^.forward;
    WHILEND /search_for_limit_chain_entry/;
    sfp$job_limit_chain_entry := current_limit_chain_entry;

  FUNCEND sfp$job_limit_chain_entry;

*copyc avc$system_defined_limit_names
*copyc ost$name
*copyc sft$limit_chain_entry
*copyc sfv$job_routing_control_table
?? POP ??
*DECK DECK=SFP$LAST_JOB_LIMIT_CHAIN_ENTRY EXPAND=FALSE

  FUNCTION [INLINE] sfp$last_job_limit_chain_entry: ^sft$limit_chain_entry;

?? PUSH (LISTEXT := ON) ??
    VAR
      current_limit_chain_entry: ^sft$limit_chain_entry;

    IF sfv$first_job_limit_chain_entry = NIL THEN
      sfp$last_job_limit_chain_entry := NIL;
    ELSE
      current_limit_chain_entry := sfv$first_job_limit_chain_entry;

    /find_end_of_limit_chain/
      WHILE current_limit_chain_entry^.forward <> NIL DO
        current_limit_chain_entry := current_limit_chain_entry^.forward;
      WHILEND /find_end_of_limit_chain/;
      sfp$last_job_limit_chain_entry := current_limit_chain_entry;
    IFEND;

  FUNCEND sfp$last_job_limit_chain_entry;

*copyc sft$limit_chain_entry
*copyc sfv$job_routing_control_table
?? POP ??
*DECK DECK=SFP$LOCK_JOB_ROUTING_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$lock_job_routing_control
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sft$binary_logset
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$LOCK_ROUTING_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$lock_routing_control
    (    routing_control_table_p: sft$routing_control_table;
         statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
         os_heap: ^ost$heap);

?? PUSH (LISTEXT := ON) ??
*copyc ost$heap
*copyc sft$binary_logset
*copyc sft$routing_control_table
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$LOCK_STATISTIC EXPAND=FALSE

  PROCEDURE [XREF] sfp$lock_statistic
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
         routing_control_table_id: sft$routing_control_table_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sfe$insufficient_privilege
*copyc sfe$statistics_not_available
*copyc sft$binary_logset
*copyc sft$routing_control_table_id
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$LOCK_SYSTEM_ROUTING_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] sfp$lock_system_routing_control
    (    statistic_code: sft$statistic_code;
         logs: sft$binary_logset;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sft$binary_logset
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$MTR_ACCUMULATE_FILE_SPACE EXPAND=FALSE
{  PURPOSE:
{    This procedure is used to add or subtract to the current permanent
{    or temporary file space accumulator for a job.
{    It may only be called from monitor.
{
{  DESIGN:
{    If the system attribute for dynamic file space limits is false,
{    this procedure returns with no action.
{
{    The accumlator is incremented by the specified amount.
{
{    If the accumulator is greater than the maximum limit, a monitor
{    fault of file space limit exceeded is sent, and warning limit
{    checking is turned off.
{
{    If file space warning checking is currently turned on, and the accumulator
{    is greater than the warning limit then the av monitor statistics handler
{    is activated.
{
{    Any time the accumulator is less than the warning limit, warning limit
{    checking is turned on.

  PROCEDURE [INLINE] sfp$mtr_accumulate_file_space
    (    file_space_limit_kind: sft$file_space_limit_kind;
         accumulator: sft$counter;
     VAR maximum_exceeded: boolean);

?? PUSH (LISTEXT := ON) ??

    VAR
      accumulator_p: ^sft$counter,
      cst_p: ^ost$cpu_state_table,
      ignore_status: syt$monitor_status,
      job_maximum_limit_p: ^sft$counter,
      job_warning_checking_p: ^boolean,
      job_warning_limit_p: ^sft$counter,
      monitor_fault: ost$monitor_fault,
      sac_p: ^mmt$segment_access_condition;

    maximum_exceeded := FALSE;

    IF sfv$dynamic_file_space_limits THEN
      mtp$cst_p (cst_p);

{ Set up pointers to the appropriate file space limit values. (permanent or
{ temporary based on the input parameter)

      CASE file_space_limit_kind OF
      = sfc$perm_file_space_limit =
        accumulator_p := ^cst_p^.ijle_p^.statistics.perm_file_space;
        job_maximum_limit_p := ^cst_p^.jcb_p^.perm_file_job_maximum_limit;
        job_warning_checking_p := ^cst_p^.jcb_p^.
              perm_file_job_warning_checking;
        job_warning_limit_p := ^cst_p^.jcb_p^.perm_file_job_warning_limit;

      = sfc$temp_file_space_limit =
        accumulator_p := ^cst_p^.ijle_p^.statistics.temp_file_space;
        job_maximum_limit_p := ^cst_p^.jcb_p^.temp_file_job_maximum_limit;
        job_warning_checking_p := ^cst_p^.jcb_p^.
              temp_file_job_warning_checking;
        job_warning_limit_p := ^cst_p^.jcb_p^.temp_file_job_warning_limit;

      ELSE

{ No action.

        RETURN;

      CASEND;

{ Add the delta to the accumulator.

      IF (UPPERVALUE (sft$counter) - accumulator_p^) <= accumulator THEN
        accumulator_p^ := UPPERVALUE (sft$counter);
      ELSE
        accumulator_p^ := accumulator_p^ + accumulator;
      IFEND;

{ It should not be possible for the accumulator to go below zero.
{ If for some reason it does it will be reset to zero.

      IF accumulator_p^ <= 0 THEN
        accumulator_p^ := 0;
        RETURN;
      IFEND;

{ IF allocation is occuring check the maximum and warning limits.

      IF accumulator > 0 THEN

{ If the maximum is reached turn warning checking off and send a monitor fault.

        IF accumulator_p^ >= job_maximum_limit_p^ THEN

          maximum_exceeded := TRUE;
          job_warning_checking_p^ := FALSE;

{ If monitor was called from ring 2 or below then don't send a monitor fault.

          IF cst_p^.xcb_p^.xp.p_register.pva.ring > osc$tmtr_ring THEN
            monitor_fault.identifier := mmc$segment_fault_processor_id;
            sac_p := #LOC (monitor_fault.contents);
            CASE file_space_limit_kind OF
            = sfc$perm_file_space_limit =
              sac_p^.identifier := mmc$sac_pf_space_limit_exceeded;
            ELSE {sfc$temp_file_space_Limit}
              sac_p^.identifier := mmc$sac_tf_space_limit_exceeded;
            CASEND;
            sac_p^.segment := #address (1, mmv$last_segment_accessed, 0);
            tmp$send_monitor_fault (cst_p^.taskid, #LOC (monitor_fault), FALSE);
          IFEND;

{ If the warning is reached activate the monitor statistics handler.

        ELSEIF job_warning_checking_p^ AND (accumulator_p^ >=
              job_warning_limit_p^) THEN
          tmp$set_system_flag (cst_p^.jcb_p^.job_monitor_id,
                avc$monitor_statistics_flag, ignore_status);

{ If neither condition currently exists, make sure that the warning limit is turned on
{ any time the accumulator goes below the warning limit.

        ELSEIF accumulator_p^ < job_warning_limit_p^ THEN
          job_warning_checking_p^ := TRUE;
        IFEND;

{ If deallocation is occuring make sure that the warning limit is turned on
{ any time the accumulator goes below the warning limit.

      ELSEIF accumulator_p^ < job_warning_limit_p^ THEN
        job_warning_checking_p^ := TRUE;
      IFEND;
    IFEND;

  PROCEND sfp$mtr_accumulate_file_space;
*copyc mmd$segment_access_condition
*copyc mmv$last_segment_accessed
*copyc mtp$cst_p
*copyc sft$counter
*copyc sft$file_space_limit_kind

{ The following conditional code is to allow deck
{ SFM$MTR_STATS_FACILITY_REQUESTS to compile correctly.

?IF sfc$compiling_mtr_sf_requests THEN
{ In sfm$mtr_stats_facility_requests so do not copy in XREF.
?ELSE
*copyc sfv$dynamic_file_space_limits
?IFEND
*copyc tmp$send_monitor_fault
*copyc tmp$set_system_flag
?? POP ??
*DECK DECK=SFP$ROUTING_CONTROL EXPAND=FALSE

  FUNCTION [INLINE] sfp$routing_control
    (    statistic_code: sft$statistic_code;
         routing_control_table: sft$routing_control_table): ^sft$routing_control;

?? PUSH (LISTEXT := ON) ??
    VAR
      current_routing_control: ^sft$routing_control;

    current_routing_control := routing_control_table^
          [(statistic_code MOD sfc$routing_control_table_size)];

  /search_for_routing_control/
    WHILE (current_routing_control <> NIL) AND
          (current_routing_control^.statistic_code <> statistic_code) DO
      current_routing_control := current_routing_control^.forward;
    WHILEND /search_for_routing_control/;
    sfp$routing_control := current_routing_control;

  FUNCEND sfp$routing_control;

*copyc sft$routing_control
*copyc sft$routing_control_table
*copyc sft$statistic_code
?? POP ??
*DECK DECK=SFP$UPDATE_JOB_LIMIT_ACCUM EXPAND=FALSE

  PROCEDURE [XREF] sfp$update_job_limit_accum
    (    limit_name: ost$name;
         update_value: sft$counter;
         update_kind: sft$accumulator_update_kind;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc ost$name
*copyc ost$status
*copyc sfe$limit_condition_codes
*copyc sft$accumulator_update_kind
*copyc sft$counter
?? POP ??
*DECK DECK=SFP$UPDATE_JOB_MAXIMUM_LIMIT EXPAND=FALSE

  PROCEDURE [XREF] sfp$update_job_maximum_limit
    (    limit_name: ost$name;
         maximum_limit: sft$counter;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc ost$name
*copyc ost$status
*copyc sfe$limit_condition_codes
*copyc sft$counter
?? POP ??
*DECK DECK=SFP$UPDATE_JOB_WARNING_LIMIT EXPAND=FALSE

  PROCEDURE [XREF] sfp$update_job_warning_limit
    (    limit_name: ost$name;
         warning_limit: sft$counter;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc avc$system_defined_limit_names
*copyc ost$name
*copyc ost$status
*copyc sfe$limit_condition_codes
*copyc sft$counter
?? POP ??
*DECK DECK=SFT$ACCUMULATOR_UPDATE_KIND EXPAND=FALSE

  TYPE
    sft$accumulator_update_kind = (sfc$incremental_update,
          sfc$replacement_update);
*DECK DECK=SFT$AI_ACTIVATE_CAPABILITY EXPAND=FALSE

{ Information needed to audit activation of validated conditional
{ capabilitiies.
{
{ FIELD_NAME_P - a pointer to the name of the capability.

  TYPE
    sft$ai_activate_capability = record
      field_name_p: ^ost$name,
    recend;

*copyc ost$name
*DECK DECK=SFT$AI_ATTACH_FILE EXPAND=FALSE

{ Information needed to audit permanent file attach requests.
{
{ OBJECT_ID_P - a pointer to the information needed to identify
{   a file system object.
{ OWNERSHIP - Set containing the ownership information for the user
{   making the request.  This information is used to determine if the user
{   is the owner of the master catalog that the file resides in.
{ ACCESS_MODE_P - a pointer to the access modes specified on the
{   attach request.

  TYPE
    sft$ai_attach_file = record
      object_id_p: ^sft$audited_fs_object_id,
      ownership: pft$ownership,
      access_mode_p: ^pft$usage_selections,
    recend;

*copyc pfd$authority
*copyc pfd$permanent_file_attributes
*copyc sft$audited_fs_object_id

*DECK DECK=SFT$AI_CHANGE_FS_OBJECT_NAME EXPAND=FALSE

{ Information needed to audit changes to the names of file system objects.
{
{ OBJECT_ID_P:  a pointer to the information needed to identify a file system
{       object.
{ OWNERSHIP:  set containing the ownership information for the user making the
{       request.  This information is used to determine if the user is the
{       owner of the master catalog in which the object resides.
{ NEW_VARIANT_PATH:  a record specifying a pointer to either the new path or
{       the new complete path for the object.

  TYPE
    sft$ai_change_fs_object_name = record
      object_id_p: ^sft$audited_fs_object_id,
      ownership: pft$ownership,
      new_variant_path: pft$variant_path,
    recend;

*copyc pfd$authority
*copyc pft$variant_path
*copyc sft$audited_fs_object_id
*DECK DECK=SFT$AI_CHANGE_FS_OBJ_ATTRIBUTE EXPAND=FALSE

{ Information needed to audit changes to the attributes of file system
{ objects.
{
{ OBJECT_ID_P - a pointer to the information needed to identify
{   a file system object.
{ OWNERSHIP - Set containing the ownership information for the user
{   making the request.  This information is used to determine if the user
{   is the owner of the master catalog that the file resides in.
{ ATTRIBUTE - which audited attribute is being changed.  The fields
{   defined within the case statement should be filled in based on which
{   attribute was changed.

  TYPE
    sft$ai_change_fs_obj_attribute = record
      object_id_p: ^sft$audited_fs_object_id,
      ownership: pft$ownership,
      case attribute: sft$audited_fs_object_attribute of
      = sfc$afsoa_cycle_number =
        new_cycle_number: pft$cycle_number,
      = sfc$afsoa_logging =
        logging: boolean,
      = sfc$afsoa_password =
        ,
      = sfc$afsoa_ring_attributes =
        ring_attributes: amt$ring_attributes,
      = sfc$afsoa_fap_name =
        fap_name: ost$name,
      casend,
    recend;

*copyc amt$ring_attributes
*copyc ost$name
*copyc pfd$authority
*copyc pfd$permanent_file_definitions
*copyc sft$audited_fs_object_attribute
*copyc sft$audited_fs_object_id

*DECK DECK=SFT$AI_CHANGE_SECURITY_PASSWORD EXPAND=FALSE

{ Information needed to audit changes to the validation file security
{ password.
{
{ VALIDATION_FILE_P - a pointer to the path of the affected validation file.

  TYPE
    sft$ai_change_security_password = record
      validation_file_p: ^fst$file_reference,
    recend;

*copyc fst$file_reference
*DECK DECK=SFT$AI_CHANGE_VALIDATION_FIELD EXPAND=FALSE

{ Information needed to audit the changes to validation field definitions.
{
{ DESCRIPTION_RECORD_NAME_P - a pointer to the description record name.
{ VALIDATION_FILE_P - a pointer to the name of the affected validation file.
{ FIELD_NAME_P - a pointer to the name of the validation field.
{ ATTRIBUTE - specifies the attribute that was changed.

  TYPE
    sft$ai_change_validation_field = record
      description_record_name_p: ^ost$name,
      validation_file_p: ^fst$file_reference,
      field_name_p: ^ost$name,
      case attribute: sft$audited_val_field_attribute of
      = sfc$avfa_default_value =
        ,
      = sfc$avfa_display_authority =
        ,
      = sfc$avfa_change_authority =
        ,
      = sfc$avfa_manage_authority =
        new_authority: avt$validation_authority,
      casend,
    recend;

*copyc avt$validation_authority
*copyc fst$file_reference
*copyc ost$name
*copyc ost$user_identification
*copyc sft$audited_val_field_attribute

*DECK DECK=SFT$AI_CHANGE_VALIDATION_RECORD EXPAND=FALSE

{ Information needed to audit changes to validation records.
{
{ DESCRIPTION_RECORD_NAME_P - a pointer to the description record name.
{ VALIDATION_FILE_P - a pointer to the name of the affected validation file.
{ USER_NAME_P - a pointer to the user name in the validation record key.
{ ACCOUNT_P - a pointer to the account name in the validation record key.
{ PROJECT_P - a pointer to the project name in the validation record key.
{ FIELD_NAME_P - a pointer to the name of the field being changed.

  TYPE
    sft$ai_change_validation_record = record
      description_record_name_p: ^ost$name,
      validation_file_p: ^fst$file_reference,
      user_name_p: ^ost$user_name,
      account_name_p: ^avt$account_name,
      project_name_p: ^avt$project_name,
      field_name_p: ^ost$name,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc fst$file_reference
*copyc ost$name
*copyc ost$user_identification

*DECK DECK=SFT$AI_CHANGE_VAL_FIELD_NAME EXPAND=FALSE

{ Information needed to audit the change of validation field name.
{
{ DESCRIPTION_RECORD_NAME_P - a pointer to the description record name.
{ VALIDATION_FILE_P - a pointer to the name of the affected validation file.
{ ORIGINAL_FIELD_NAME_P - a pointer to the original field name.
{ NEW_FIELD_NAME_P - a pointer to the new field name.

  TYPE
    sft$ai_change_val_field_name = record
      description_record_name_p: ^ost$name,
      validation_file_p: ^fst$file_reference,
      original_field_name_p: ^ost$name,
      new_field_name_p: ^ost$name,
    recend;

*copyc fst$file_reference
*copyc ost$name
*copyc ost$user_identification
*DECK DECK=SFT$AI_CREATE_FS_OBJECT EXPAND=FALSE

{ Information needed to audit the creation of file system objects.
{
{ OBJECT_ID_P:  a pointer to the information needed to identify a file system
{       object.
{ OWNERSHIP:  set containing the ownership information for the user making the
{       request.  This information is used to determine if the user is the
{       owner of the master catalog in which the object resides.

  TYPE
    sft$ai_create_fs_object = record
      object_id_p: ^sft$audited_fs_object_id,
      ownership: pft$ownership,
    recend;

*copyc pfd$authority
*copyc sft$audited_fs_object_id
*DECK DECK=SFT$AI_CREATE_FS_PERMIT EXPAND=FALSE

{ Information needed to audit creation of a permit for file system objects.
{
{ OBJECT_ID_P - a pointer to the information needed to identify
{   a file system object.
{ OWNERSHIP - Set containing the ownership information for the user
{   making the request.  This information is used to determine if the user
{   is the owner of the master catalog that the file resides in.
{ GROUP_P - a pointer to the group definition for the permit.
{ PERMIT_SELECTIONS_P - a pointer to the permit selections that are
{   being given to the group (i.e., the access modes the group will be
{   allowed to use).

  TYPE
    sft$ai_create_fs_permit = record
      object_id_p: ^sft$audited_fs_object_id,
      ownership: pft$ownership,
      group_p: ^pft$group,
      permit_selections_p: ^pft$permit_selections,
    recend;

*copyc pfd$authority
*copyc pfd$permanent_file_definitions
*copyc sft$audited_fs_object_id

*DECK DECK=SFT$AI_CREATE_VALIDATION_FIELD EXPAND=FALSE

{ Information needed to audit the creation of validation fields.
{
{ DESCRIPTION_RECORD_NAME_P - a pointer to the description record name.
{ VALIDATION_FILE_P - a pointer to the name of the affected validation file.
{ FIELD_NAME_P - a pointer to the name of the validation field.
{ FIELD_KIND - specifies the type of validation field that was created.

  TYPE
    sft$ai_create_validation_field = record
      description_record_name_p: ^ost$name,
      validation_file_p: ^fst$file_reference,
      field_name_p: ^ost$name,
      field_kind: avt$field_kind,
    recend;

*copyc avt$field_kind
*copyc fst$file_reference
*copyc ost$name
*copyc ost$user_identification
*DECK DECK=SFT$AI_CREATE_VALIDATION_RECORD EXPAND=FALSE

{ Information needed to audit the creation of validation records.
{
{ DESCRIPTION_RECORD_NAME_P - a pointer to the description record name.
{ VALIDATION_FILE_P - a pointer to the name of the affected validation file.
{ USER_NAME_P - a pointer to the user name in the validation record key.
{ ACCOUNT_P - a pointer to the account name in the validation record key.
{ PROJECT_P - a pointer to the project name in the validation record key.

  TYPE
    sft$ai_create_validation_record = record
      description_record_name_p: ^ost$name,
      validation_file_p: ^fst$file_reference,
      user_name_p: ^ost$user_name,
      account_name_p: ^avt$account_name,
      project_name_p: ^avt$project_name,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc fst$file_reference
*copyc ost$name
*copyc ost$user_identification
*DECK DECK=SFT$AI_DEACTIVATE_CAPABILITY EXPAND=FALSE

{ Information needed to audit deactivation of validated conditional
{ capabilitiies.
{
{ FIELD_NAME_P - a pointer to the name of the capability.

  TYPE
    sft$ai_deactivate_capability = record
      field_name_p: ^ost$name,
    recend;

*copyc ost$name
*DECK DECK=SFT$AI_DELETE_FS_OBJECT EXPAND=FALSE

{ Information needed to audit the deletion of file system objects.
{
{ OBJECT_ID_P - a pointer to the information needed to identify
{   a file system object.
{ OWNERSHIP - Set containing the ownership information for the user
{   making the request.  This information is used to determine if the user
{   is the owner of the master catalog that the file resides in.

  TYPE
    sft$ai_delete_fs_object = record
      object_id_p: ^sft$audited_fs_object_id,
      ownership: pft$ownership,
    recend;

*copyc pfd$authority
*copyc sft$audited_fs_object_id

*DECK DECK=SFT$AI_DELETE_FS_PERMIT EXPAND=FALSE

{ Information needed to audit deletion of a permit for file system objects.
{
{ OBJECT_ID_P - a pointer to the information needed to identify
{   a file system object.
{ OWNERSHIP - Set containing the ownership information for the user
{   making the request.  This information is used to determine if the user
{   is the owner of the master catalog that the file resides in.
{ GROUP_P - a pointer to the group definition for the permit.

  TYPE
    sft$ai_delete_fs_permit = record
      object_id_p: ^sft$audited_fs_object_id,
      ownership: pft$ownership,
      group_p: ^pft$group,
    recend;

*copyc pfd$authority
*copyc pfd$permanent_file_definitions
*copyc sft$audited_fs_object_id

*DECK DECK=SFT$AI_DELETE_VALIDATION_FIELD EXPAND=FALSE

{ Information needed to audit the deletion of validation fields.
{
{ DESCRIPTION_RECORD_NAME_P - a pointer to the description record name.
{ VALIDATION_FILE_P - a pointer to the name of the affected validation file.
{ FIELD_NAME_P - a pointer to the name of the validation field.

  TYPE
    sft$ai_delete_validation_field = record
      description_record_name_p: ^ost$name,
      validation_file_p: ^fst$file_reference,
      field_name_p: ^ost$name,
    recend;

*copyc fst$file_reference
*copyc ost$name
*copyc ost$user_identification
*DECK DECK=SFT$AI_DELETE_VALIDATION_RECORD EXPAND=FALSE

{ Information needed to audit the deletion of validation records.
{
{ DESCRIPTION_RECORD_NAME_P - a pointer to the description record name.
{ VALIDATION_FILE_P - a pointer to the name of the affected validation file.
{ USER_NAME_P - a pointer to the user name in the validation record key.
{ ACCOUNT_P - a pointer to the account name in the validation record key.
{ PROJECT_P - a pointer to the project name in the validation record key.

  TYPE
    sft$ai_delete_validation_record = record
      description_record_name_p: ^ost$name,
      validation_file_p: ^fst$file_reference,
      user_name_p: ^ost$user_name,
      account_name_p: ^avt$account_name,
      project_name_p: ^avt$project_name,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc fst$file_reference
*copyc ost$name
*copyc ost$user_identification
*DECK DECK=SFT$AI_EXECUTE_PROGRAM EXPAND=FALSE

{ Information needed to audit the execution of a program.
{
{ PROGRAM_NAME_P - a pointer to the name of the starting procedure for the
{   program.
{ MODULE_NAME_P - a pointer to the name of the module containing the
{   starting procedure.
{ LIBRARY_NAME_P - a pointer to the name of the library containing the
{   starting procedure.
{ LOADED_RING - specifies the ring at which the starting procedure will
{   execute.

  TYPE
    sft$ai_execute_program = record
      program_name_p: ^pmt$program_name,
      module_name_p: ^pmt$program_name,
      library_name_p: ^fst$file_reference,
      loaded_ring: ost$ring,
    recend;

*copyc fst$file_reference
*copyc osd$virtual_address
*copyc pmt$program_name
*copyc pmt$program_name

*DECK DECK=SFT$AI_FORCE_SECURITY_PASSWORD EXPAND=FALSE

{ Information needed to audit forced changes to the validation file
{ security password.
{
{ VALIDATION_FILE_P - a pointer to the name of the affected validation file.

  TYPE
    sft$ai_force_security_password = record
      validation_file_p: ^fst$file_reference,
    recend;

*copyc fst$file_reference
*DECK DECK=SFT$AI_FORCE_USER_PASSWORD EXPAND=FALSE

{ Information needed to audit forced changes to a user's password.
{
{ DESCRIPTION_RECORD_NAME_P - a pointer to the description record name.
{ VALIDATION_FILE_P - a pointer to the name of the affected validation file.
{ USER_NAME_P - a pointer to the user name in the validation record key.
{ FIELD_NAME_P - a pointer to the name of the field being changed.

  TYPE
    sft$ai_force_user_password = record
      description_record_name_p: ^ost$name,
      validation_file_p: ^fst$file_reference,
      user_name_p: ^ost$user_name,
      field_name_p: ^ost$name,
    recend;

*copyc fst$file_reference
*copyc ost$name
*copyc ost$user_identification
*DECK DECK=SFT$AI_GET_VALIDATION_VALUE EXPAND=FALSE

{ Information needed to audit retrieval of validation information for the
{ executing job.
{
{ DESCRIPTION_RECORD_NAME_P - a pointer to the description record name.
{ FIELD_NAME_P - a pointer to the name of the field.

  TYPE
    sft$ai_get_validation_value = record
      description_record_name_p: ^ost$name,
      field_name_p: ^ost$name,
    recend;

*copyc ost$name
*DECK DECK=SFT$AI_LOAD_FAP EXPAND=FALSE

{ Information needed to audit the loading of a user FAP (i.e.,a FAP loaded as
{ the result of processing the FILE_ACCESS_PROCEDURE_NAME file attribute).
{
{ FILE_P - a pointer to the file reference of the file that has the FAP
{   assigned.
{ PROGRAM_NAME_P - a pointer to the name of the FAP.
{ MODULE_NAME_P - a pointer to the name of the module containing the FAP.
{ LIBRARY_NAME_P - a pointer to the name of the library containing the FAP.
{ LOADED_RING - specifies the ring at which the FAP will execute.

  TYPE
    sft$ai_load_fap = record
      file_p: ^fst$file_reference,
      program_name_p: ^pmt$program_name,
      module_name_p: ^pmt$program_name,
      library_name_p: ^fst$file_reference,
      loaded_ring: ost$ring,
    recend;

*copyc fst$file_reference
*copyc osd$virtual_address
*copyc pmt$program_name
*copyc pmt$program_name

*DECK DECK=SFT$AI_MOUNT_MAGNETIC_TAPE EXPAND=FALSE

{ Information needed to audit the mounting of a magnetic tape.
{
{ EXTERNAL_VSN_P - a pointer to the external VSN for the tape.
{ RECORED_VSN_P - a pointer to the recorded VSN for the tape.
{ WRITE_RING - specifies whether or not the write ring was in the tape.
{ ELEMENT_NAME_P - a pointer to the name of the drive that tape was mounted
{    on.

  TYPE
    sft$ai_mount_magnetic_tape = record
      external_vsn_p: ^rmt$external_vsn,
      recorded_vsn_p: ^rmt$recorded_vsn,
      write_ring: boolean,
      element_name_p: ^ost$name,
    recend;

*copyc ost$name
*copyc rmt$external_vsn
*copyc rmt$recorded_vsn

*DECK DECK=SFT$AI_PREVALIDATE_USER EXPAND=FALSE

{ Information needed to audit requests to prevalidate a user.
{
{ FAMILY_NAME_P - a pointer to the name of the family.
{ USER_NAME_P - a pointer to the user name.
{ ACCOUNT_P - a pointer to the account name.
{ PROJECT_P - a pointer to the project name.
{ TERMINAL_NAME_P -  a pointer to the name of terminal for interactive
{   jobs.  If this is not an interactive job, NIL should be specified.

  TYPE
    sft$ai_prevalidate_user = record
      family_name_p: ^ost$family_name,
      user_name_p: ^ost$user_name,
      account_name_p: ^avt$account_name,
      project_name_p: ^avt$project_name,
      terminal_name_p: ^ift$terminal_name,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc ift$terminal_name
*copyc ost$name
*copyc ost$user_identification

*DECK DECK=SFT$AI_PROCESS_COMMAND EXPAND=FALSE

{ Information needed to audit the processing of an SCL command.
{
{ COMMAND_NAME_P - a pointer to the name of the command.
{ COMMAND_SOURCE - specifies whether or not the command came from
{   the job's command file.
{ COMMAND_CALL_METHOD - specifies the type of command call.

  TYPE
    sft$ai_process_command = record
      command_name_p: ^clt$command_name,
      command_source: sft$command_source,
      command_call_method: clt$command_call_method,
    recend;

*copyc clt$command_call_method
*copyc clt$command_name
*copyc sft$command_source

*DECK DECK=SFT$AI_USER_IDENTIFICATION EXPAND=FALSE

{ Information needed to identify a job for auditing purposes.
{
{ FAMILY_NAME_P - a pointer to the name of the family for the job.
{ USER_NAME_P - a pointer to the user name for the job.
{ ACCOUNT_NAME_P - a pointer to the name of the account for the job.
{ PROJECT_NAME_P - a pointer to the name of the project for the job.
{ TERMINAL_NAME_P - a pointer to the name of terminal for interactive jobs.
{   If this is not an interactive job, NIL should be specified.

  TYPE
    sft$ai_user_identification = record
      family_name_p: ^ost$family_name,
      user_name_p: ^ost$user_name,
      account_name_p: ^avt$account_name,
      project_name_p: ^avt$project_name,
      terminal_name_p: ^ost$name,
    recend;

*copyc avt$account_name
*copyc avt$project_name
*copyc ost$name
*copyc ost$user_identification
*DECK DECK=SFT$AUDITED_FS_OBJECT_ATTRIBUTE EXPAND=FALSE

  TYPE
    sft$audited_fs_object_attribute = (sfc$afsoa_cycle_number,
          sfc$afsoa_logging, sfc$afsoa_password, sfc$afsoa_ring_attributes,
          sfc$afsoa_fap_name);

*DECK DECK=SFT$AUDITED_FS_OBJECT_ID EXPAND=FALSE

{ Information needed to identify a file system object.
{
{ VARIANT_PATH:  a record specifying a pointer to either the path or the
{       complete path of the file system object.
{ OBJECT_TYPE:  specifies the object type.
{ CYCLE_SELECTOR_P:  a pointer to a cycle selector record.  If the cycle
{       selector cannot be determined, a NIL pointer should be specified.
{ DEVICE_CLASS:  specifies the device class on which the cycle resides.

  TYPE
    sft$audited_fs_object_id = record
      variant_path: pft$variant_path,
      case object_type: sft$audited_fs_object_type of
      = sfc$afsot_catalog =
        ,
      = sfc$afsot_file =
        ,
      = sfc$afsot_cycle =
        cycle_selector_p: ^pft$cycle_selector,
        device_class: rmt$device_class,
      casend,
    recend;

*copyc pfd$permanent_file_definitions
*copyc pft$variant_path
*copyc rmt$device_class
*copyc sft$audited_fs_object_type
*DECK DECK=SFT$AUDITED_FS_OBJECT_TYPE EXPAND=FALSE

  TYPE
    sft$audited_fs_object_type = (sfc$afsot_catalog, sfc$afsot_file,
          sfc$afsot_cycle);

*DECK DECK=SFT$AUDITED_OPERATION EXPAND=FALSE

  TYPE
    sft$audited_operation = (sfc$ao_fs_attach_file, sfc$ao_fs_change_attribute,
          sfc$ao_fs_change_name, sfc$ao_fs_create_object,
          sfc$ao_fs_create_permit, sfc$ao_fs_delete_object,
          sfc$ao_fs_delete_permit, sfc$ao_fs_load_fap,
          sfc$ao_fs_magnetic_tape_mount, sfc$ao_job_end,
          sfc$ao_job_execute_program, sfc$ao_job_process_command,
          sfc$ao_job_user_identification, sfc$ao_val_activate_capability,
          sfc$ao_val_change_field, sfc$ao_val_change_field_name,
          sfc$ao_val_change_record, sfc$ao_val_change_security_pw,
          sfc$ao_val_create_field, sfc$ao_val_create_record,
          sfc$ao_val_deact_capability, sfc$ao_val_delete_field,
          sfc$ao_val_delete_record, sfc$ao_val_force_security_pw,
          sfc$ao_val_force_user_password, sfc$ao_val_prevalidate_user);

*DECK DECK=SFT$AUDITED_OPERATION_SET EXPAND=FALSE

  TYPE
    sft$audited_operation_set = set of sft$audited_operation;

*copyc sft$audited_operation
*DECK DECK=SFT$AUDITED_VAL_FIELD_ATTRIBUTE EXPAND=FALSE

  TYPE
    sft$audited_val_field_attribute = (sfc$avfa_default_value,
          sfc$avfa_display_authority, sfc$avfa_change_authority,
          sfc$avfa_manage_authority);

*DECK DECK=SFT$AUDIT_CONTROL EXPAND=FALSE

  TYPE
    sft$audit_control = record
      locked: boolean,
      operation: sft$audited_operation,
      forward: ^sft$audit_control,
      selection_criteria: sft$audit_selection_criteria,
    recend;

*copyc sft$audit_selection_criteria
*copyc sft$audited_operation

*DECK DECK=SFT$AUDIT_INFORMATION EXPAND=FALSE

  TYPE
    sft$audit_information = record
      case audited_operation: sft$audited_operation of
      = sfc$ao_fs_attach_file =
        attach_file: sft$ai_attach_file,
      = sfc$ao_fs_change_attribute =
        change_fs_object_attribute: sft$ai_change_fs_obj_attribute,
      = sfc$ao_fs_change_name =
        change_fs_object_name: sft$ai_change_fs_object_name,
      = sfc$ao_fs_create_object =
        create_fs_object: sft$ai_create_fs_object,
      = sfc$ao_fs_create_permit =
        create_fs_permit: sft$ai_create_fs_permit,
      = sfc$ao_fs_delete_object =
        delete_fs_object: sft$ai_delete_fs_object,
      = sfc$ao_fs_delete_permit =
        delete_fs_permit: sft$ai_delete_fs_permit,
      = sfc$ao_fs_load_fap =
        load_fap: sft$ai_load_fap,
      = sfc$ao_fs_magnetic_tape_mount =
        mount_magnetic_tape: sft$ai_mount_magnetic_tape,
      = sfc$ao_job_end =
        ,
      = sfc$ao_job_execute_program =
        execute_program: sft$ai_execute_program,
      = sfc$ao_job_process_command =
        process_command: sft$ai_process_command,
      = sfc$ao_job_user_identification =
        user_identification: sft$ai_user_identification,
      = sfc$ao_val_activate_capability =
        activate_capability: sft$ai_activate_capability,
      = sfc$ao_val_change_field =
        change_validation_field: sft$ai_change_validation_field,
      = sfc$ao_val_change_field_name =
        change_val_field_name: sft$ai_change_val_field_name,
      = sfc$ao_val_change_record =
        change_val_record: sft$ai_change_validation_record,
      = sfc$ao_val_change_security_pw =
        change_security_password: sft$ai_change_security_password,
      = sfc$ao_val_create_field =
        create_validation_field: sft$ai_create_validation_field,
      = sfc$ao_val_create_record =
        create_validation_record: sft$ai_create_validation_record,
      = sfc$ao_val_deact_capability =
        deactivate_capability: sft$ai_deactivate_capability,
      = sfc$ao_val_delete_field =
        delete_validation_field: sft$ai_delete_validation_field,
      = sfc$ao_val_delete_record =
        delete_validation_record: sft$ai_delete_validation_record,
      = sfc$ao_val_force_security_pw =
        force_security_password: sft$ai_force_security_password,
      = sfc$ao_val_force_user_password =
        force_user_password: sft$ai_force_user_password,
      = sfc$ao_val_prevalidate_user =
        prevalidate_user: sft$ai_prevalidate_user,
      casend,
    recend;

*copyc sft$ai_activate_capability
*copyc sft$ai_attach_file
*copyc sft$ai_change_fs_obj_attribute
*copyc sft$ai_change_fs_object_name
*copyc sft$ai_change_security_password
*copyc sft$ai_change_val_field_name
*copyc sft$ai_change_validation_field
*copyc sft$ai_change_validation_record
*copyc sft$ai_create_fs_object
*copyc sft$ai_create_fs_permit
*copyc sft$ai_create_validation_field
*copyc sft$ai_create_validation_record
*copyc sft$ai_deactivate_capability
*copyc sft$ai_delete_fs_object
*copyc sft$ai_delete_fs_permit
*copyc sft$ai_delete_validation_field
*copyc sft$ai_delete_validation_record
*copyc sft$ai_execute_program
*copyc sft$ai_force_security_password
*copyc sft$ai_force_user_password
*copyc sft$ai_load_fap
*copyc sft$ai_mount_magnetic_tape
*copyc sft$ai_prevalidate_user
*copyc sft$ai_process_command
*copyc sft$ai_user_identification
*copyc sft$audited_operation

*DECK DECK=SFT$AUDIT_OPERATION_DESCRIPTOR EXPAND=FALSE

  TYPE
    sft$audit_operation_descriptor = record
      statistic_code: sft$audit_statistic_code,
      operation_abbreviation: string (6),
    recend;

*copyc sft$audit_statistic_code
*DECK DECK=SFT$AUDIT_SELECTION_CRITERIA EXPAND=FALSE

  TYPE
    sft$audit_selection_criteria = array [1 .. * ] of
          sft$audit_selection_entry;

*copyc sft$audit_selection_entry
*DECK DECK=SFT$AUDIT_SELECTION_ENTRY EXPAND=FALSE

  TYPE
    sft$audit_selection_entry = record
      case selector: sft$audit_selector of
      = sfc$as_null_selector =
        ,
      = sfc$as_operation_result_set =
        operation_result_set: sft$operation_result_set,
      = sfc$as_command_source_set =
        command_source_set: sft$command_source_set,
      = sfc$as_access_mode_set =
        access_mode_set: pft$usage_selections,
      = sfc$as_catalog_owner_set =
        catalog_owner_set: sft$catalog_owner_set,
      casend,
    recend;

*copyc pfd$permanent_file_attributes
*copyc sft$audit_selector
*copyc sft$catalog_owner_set
*copyc sft$command_source_set
*copyc sft$operation_result_set

*DECK DECK=SFT$AUDIT_SELECTOR EXPAND=FALSE

  TYPE
    sft$audit_selector = (sfc$as_null_selector, sfc$as_operation_result_set,
          sfc$as_command_source_set, sfc$as_access_mode_set,
          sfc$as_catalog_owner_set);

*DECK DECK=SFT$AUDIT_STATISTIC_CODE EXPAND=FALSE

  TYPE
    sft$audit_statistic_code = sft$statistic_code;

?? FMT (FORMAT := OFF) ??

{ Audit statistics related to file system operations.

  CONST
    sfc$asc_fs_attach_file          = sfc$min_audit_statistic_code + 1000,
    sfc$asc_fs_change_attribute     = sfc$min_audit_statistic_code + 1001,
    sfc$asc_fs_change_name          = sfc$min_audit_statistic_code + 1002,
    sfc$asc_fs_create_object        = sfc$min_audit_statistic_code + 1003,
    sfc$asc_fs_create_permit        = sfc$min_audit_statistic_code + 1004,
    sfc$asc_fs_delete_object        = sfc$min_audit_statistic_code + 1005,
    sfc$asc_fs_delete_permit        = sfc$min_audit_statistic_code + 1006,
    sfc$asc_fs_load_fap             = sfc$min_audit_statistic_code + 1007,
    sfc$asc_fs_mount_magnetic_tape  = sfc$min_audit_statistic_code + 1008;

{ Audit statistics related to validation operations.

  CONST
    sfc$asc_val_activate_capability = sfc$min_audit_statistic_code + 2000,
    sfc$asc_val_change_field        = sfc$min_audit_statistic_code + 2001,
    sfc$asc_val_change_field_name   = sfc$min_audit_statistic_code + 2002,
    sfc$asc_val_change_record       = sfc$min_audit_statistic_code + 2003,
    sfc$asc_val_change_security_pw  = sfc$min_audit_statistic_code + 2004,
    sfc$asc_val_create_field        = sfc$min_audit_statistic_code + 2005,
    sfc$asc_val_create_record       = sfc$min_audit_statistic_code + 2006,
    sfc$asc_val_deact_capability    = sfc$min_audit_statistic_code + 2007,
    sfc$asc_val_delete_field        = sfc$min_audit_statistic_code + 2008,
    sfc$asc_val_delete_record       = sfc$min_audit_statistic_code + 2009,
    sfc$asc_val_force_security_pw   = sfc$min_audit_statistic_code + 2010,
    sfc$asc_val_force_user_password = sfc$min_audit_statistic_code + 2011,
    sfc$asc_val_prevalidate_user    = sfc$min_audit_statistic_code + 2012;

{ Audit statistics related to job execution activities.

  CONST
    sfc$asc_job_user_identification = sfc$min_audit_statistic_code + 3000,
    sfc$asc_job_end                 = sfc$min_audit_statistic_code + 3001,
    sfc$asc_job_execute_program     = sfc$min_audit_statistic_code + 3002,
    sfc$asc_job_process_command     = sfc$min_audit_statistic_code + 3003;

?? FMT (FORMAT := ON) ??

*copyc sfc$min_audit_statistic_code
*copyc sft$statistic_code
*DECK DECK=SFT$BINARY_LOGS EXPAND=FALSE

  TYPE
    sft$binary_logs = pmt$binary_logs;

*copyc pmd$system_log_interface
*DECK DECK=SFT$BINARY_LOGSET EXPAND=FALSE

  TYPE
    sft$binary_logset = pmt$binary_logset;

*copyc pmd$system_log_interface
*DECK DECK=SFT$CATALOG_OWNER EXPAND=FALSE

  TYPE
    sft$catalog_owner = (sfc$co_owner, sfc$co_non_owner, sfc$co_system);

*DECK DECK=SFT$CATALOG_OWNER_SET EXPAND=FALSE

  TYPE
    sft$catalog_owner_set = set of sft$catalog_owner;

*copyc sft$catalog_owner
*DECK DECK=SFT$COMMAND_SOURCE EXPAND=FALSE

  TYPE
    sft$command_source = (sfc$cs_primary_command_file,
          sfc$cs_secondary_command_file);

*DECK DECK=SFT$COMMAND_SOURCE_SET EXPAND=FALSE

  TYPE
    sft$command_source_set = set of sft$command_source;

*copyc sft$command_source
*DECK DECK=SFT$COUNTER EXPAND=FALSE

  TYPE
    sft$counter = integer;
*DECK DECK=SFT$COUNTERS EXPAND=FALSE

  CONST
    sfc$max_number_of_counters = 0fff(16);

  TYPE
    sft$counters = ^array [1 .. * ] of sft$counter;

*copyc sft$counter
*DECK DECK=SFT$DESCRIPTIVE_DATA EXPAND=FALSE

  CONST
    sfc$max_descriptive_data_size = 0fff(16);

  TYPE
    sft$descriptive_data = string ( * );
*DECK DECK=SFT$ENFORCEMENT EXPAND=FALSE

  TYPE
    sft$enforcement = (sfc$accumulation_enforcement, sfc$other_enforcement);
*DECK DECK=SFT$FILE_SPACE_LIMIT_KIND EXPAND=FALSE
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
    sft$file_space_limit_kind = (sfc$no_limit, sfc$perm_file_space_limit,
          sfc$temp_file_space_limit);
*DECK DECK=SFT$GLOBAL_BINARY_LOGSET EXPAND=FALSE

  TYPE
    sft$global_binary_logset = pmt$global_binary_logset;

*copyc pmd$system_log_interface
*DECK DECK=SFT$GLOBAL_LOG_STATISTIC_HEADER EXPAND=FALSE

  TYPE
    sft$global_log_statistic_header = sft$statistic_header;

*copyc sft$statistic_header
*DECK DECK=SFT$LIMIT EXPAND=FALSE

  TYPE
    sft$limit = record
      name: ost$name,
      condition_identifier: jmt$job_resource_condition,
      accumulator: sft$counter,
      job_resource_limit: sft$counter,
      job_abort_limit: sft$counter,
      enforcement: sft$enforcement,
    recend;

  TYPE
    sft$limits = ^array [1 .. *] of sft$limit;

*copyc sft$counter
*copyc sft$enforcement
*copyc jmd$job_resource_condition
*copyc ost$name
*DECK DECK=SFT$LIMIT_CHAIN_ENTRY EXPAND=FALSE

  TYPE
    sft$limit_chain_entry = record
      limit: sft$limit,
      cpu_time_of_job_resource_signal: sft$counter,
      forward: ^sft$limit_chain_entry,
    recend;

*copyc sft$counter
*copyc sft$limit
*DECK DECK=SFT$LIMIT_UPDATE_KIND EXPAND=FALSE

  TYPE
    sft$limit_update_kind = (sfc$increment_on_occurence,
          sfc$decrement_on_occurence, sfc$update_based_on_counter);

*DECK DECK=SFT$LIMIT_UPDATE_STATISTIC EXPAND=FALSE

  TYPE
    sft$limit_update_statistic = record
      statistic_code: sft$statistic_code,
      case update_kind: sft$limit_update_kind of
      = sfc$increment_on_occurence =
        ,
      = sfc$decrement_on_occurence =
        ,
      = sfc$update_based_on_counter =
        counter: 1 .. sfc$max_number_of_counters,
      casend,
    recend;

*copyc sft$counters
*copyc sft$limit_update_kind
*copyc sft$statistic_code
*DECK DECK=SFT$LIMIT_UPDATE_STATISTICS EXPAND=FALSE

  TYPE
    sft$limit_update_statistics = array [1 .. * ] of
          sft$limit_update_statistic;

*copyc sft$limit_update_statistic
*DECK DECK=SFT$LOCAL_BINARY_LOGS EXPAND=FALSE

  TYPE
    sft$local_binary_logs = pmt$local_binary_logs;

*copyc pmd$system_log_interface
*DECK DECK=SFT$LOCAL_LOG_STATISTIC_HEADER EXPAND=FALSE

  TYPE
    sft$local_log_statistic_header = sft$statistic_header;

*copyc sft$statistic_header
*DECK DECK=SFT$OPERATION_RESULT EXPAND=FALSE

  TYPE
    sft$operation_result = (sfc$or_successful, sfc$or_unsuccessful);

*DECK DECK=SFT$OPERATION_RESULT_SET EXPAND=FALSE

  TYPE
    sft$operation_result_set = set of sft$operation_result;

*copyc sft$operation_result
*DECK DECK=SFT$RB_STATS_FACILITY_REQUESTS EXPAND=FALSE

  TYPE
    sft$rb_stats_facility_requests = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      case sub_reqcode: sft$rb_stats_fac_sub_reqcode of
      = sfc$accumulate_file_space =
        file_space_limit_kind: sft$file_space_limit_kind,
        accumulator: sft$counter,
      casend,
    recend;

  TYPE
    sft$rb_stats_fac_sub_reqcode = (sfc$null_request,
          sfc$accumulate_file_space);

*copyc sft$counter
*copyc sft$file_space_limit_kind
*copyc syc$monitor_request_codes

*DECK DECK=SFT$ROUTING_CONTROL EXPAND=FALSE

  TYPE
    sft$routing_control = record
      statistic_code: sft$statistic_code,
      activated_logs: sft$binary_logset,
      locked_logs: sft$binary_logset,
      limit_name: ost$name,
      audit_control_p: ^sft$audit_control,
      forward: ^sft$routing_control,
    recend;

*copyc ost$name
*copyc sft$audit_control
*copyc sft$binary_logset
*copyc sft$statistic_code
*DECK DECK=SFT$ROUTING_CONTROL_ACCESS EXPAND=FALSE

  TYPE
    sft$routing_control_access = (sfc$read_routing_controls, sfc$update_routing_controls);
*DECK DECK=SFT$ROUTING_CONTROL_TABLE EXPAND=FALSE

  TYPE
    sft$routing_control_table = ^array [0 .. * ] of ^sft$routing_control;

  CONST
    sfc$routing_control_table_size = 53;

*copyc sft$routing_control
*DECK DECK=SFT$ROUTING_CONTROL_TABLE_ID EXPAND=FALSE

  TYPE
    sft$routing_control_table_id = (sfc$sys_routing_control_table,
          sfc$job_routing_control_table);

*DECK DECK=SFT$STATISTIC_BUFFER EXPAND=FALSE

  TYPE
    sft$statistic_buffer = SEQ( REP sfc$max_statistic_record_size of cell);

  CONST
    sfc$max_statistic_record_size = lgc$maximum_log_entry_size;

*copyc lgc$maximum_log_entry_size

*DECK DECK=SFT$STATISTIC_CODE EXPAND=FALSE

  CONST
    sfc$max_statistic_code = osc$max_condition;

  TYPE
    sft$statistic_code = 0 .. sfc$max_statistic_code;

*copyc osc$max_condition
*DECK DECK=SFT$STATISTIC_GROUP EXPAND=FALSE

  TYPE
    sft$statistic_group = array [1 .. * ] of sft$statistic_record;

*copyc sft$statistic_record
*DECK DECK=SFT$STATISTIC_HEADER EXPAND=FALSE

  TYPE
    sft$statistic_header = record
      version: sft$statistic_version,
      date_time: ost$date_time,
      statistic_code: sft$statistic_code,
      job_name: jmt$system_supplied_name,
      task_id: ost$global_task_id,
      number_of_counters: 0 .. sfc$max_number_of_counters,
      descriptive_data_size: 0 .. sfc$max_descriptive_data_size,
    recend;

*copyc jmt$system_supplied_name
*copyc ost$date_time
*copyc ost$global_task_id
*copyc sfc$statistic_version
*copyc sft$counters
*copyc sft$descriptive_data
*copyc sft$statistic_code
*copyc sft$statistic_version
*DECK DECK=SFT$STATISTIC_IDENTIFIER EXPAND=FALSE

  TYPE
    sft$statistic_identifier = string (2);
*DECK DECK=SFT$STATISTIC_RECORD EXPAND=FALSE

  TYPE
    sft$statistic_record = record
      statistic_code: sft$statistic_code,
    recend;

*copyc sft$statistic_code
*DECK DECK=SFT$STATISTIC_VERSION EXPAND=FALSE

  TYPE
    sft$statistic_version = 0 .. 255;

*DECK DECK=SFV$AUDIT_OPERATION_DESCRIPTORS EXPAND=FALSE

  VAR
    sfv$audit_operation_descriptors: [XREF] array [sft$audited_operation] of
          sft$audit_operation_descriptor;

?? PUSH (LISTEXT := ON) ??
*copyc sft$audit_operation_descriptor
*copyc sft$audited_operation
?? POP ??

*DECK DECK=SFV$DYNAMIC_FILE_SPACE_LIMITS EXPAND=FALSE

  VAR
    sfv$dynamic_file_space_limits: [XREF] boolean;
*DECK DECK=SFV$EMIT_JOB_OPEN_STATISTICS EXPAND=FALSE

  VAR
    sfv$emit_job_open_statistics: [XREF] boolean;
*DECK DECK=SFV$EMIT_SYS_OPEN_STATISTICS EXPAND=FALSE

  VAR
    sfv$emit_sys_open_statistics: [XREF] boolean;
*DECK DECK=SFV$JOB_ROUTING_CONTROL_TABLE EXPAND=FALSE

  VAR

{ The job routing control table controls which statistics are emitted to which logs for the job.

    sfv$job_routing_control_table: [XREF] sft$routing_control_table,

{ The job routing control lock controls access to the job routing control table.

    sfv$job_routing_control_lock: [XREF] ost$signature_lock,

{ This variable is used to store the number of limits active for the job.

    sfv$job_limit_count: [XREF] jmt$job_resource_condition,

{ This variable is used to store a pointer to the first limit in the limit chain for the job.

    sfv$first_job_limit_chain_entry: [XREF] ^sft$limit_chain_entry;

?? PUSH (LISTEXT := ON) ??
*copyc jmd$job_resource_condition
*copyc ost$signature_lock
*copyc sft$limit_chain_entry
*copyc sft$routing_control_table
?? POP ??
*DECK DECK=SFV$SYS_ROUTING_CONTROL_TABLE EXPAND=FALSE

  VAR

{ The system routing control table controls which statistics are emitted to which logs for the system.

    sfv$sys_routing_control_table: [XREF] sft$routing_control_table,

{ The system routing control lock controls access to the system routing control table.

    sfv$sys_routing_control_lock: [XREF] ost$signature_lock;

?? PUSH (LISTEXT := ON) ??
*copyc ost$signature_lock
*copyc sft$routing_control_table
?? POP ??
*DECK DECK=SRH$FETCH_SYSTEM_LABEL EXPAND=FALSE
{
{   The purpose of this procedure is to fetch the permanent file utility label
{ for an attached permanent file.  The label input must be big enough to  hold
{ the  label  information.   The  required  size  may  be  obtained  from  the
{ SRP$FETCH_SYSTEM_LABEL_SIZE interface.
{
{       SRP$FETCH_SYSTEM_LABEL (LOCAL_FILE_NAME, LABEL, STATUS)
{
{ LOCAL_FILE_NAME: (input) This parameter specifies  the  local  name  of  the
{       permanent file whose permanent file utility label is to be returned.
{
{ LABEL:  (output)  This  parameter  is a sequence that contains the permanent
{       file utility label.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: cle$improper_name
{                   lne$ln_lnt_entry_not_found
{                   lne$no_preserved_attributes
{                   lne$incorrect_label_size
{
{       IDENTIFIER: amc$access_method_id
{
*DECK DECK=SRH$FETCH_SYSTEM_LABEL_SIZE EXPAND=FALSE
{
{   The purpose  of  this  procedure  is to return the size of the label for a
{ permanent file.  This is not the  same  label  that  is  used  for  internal
{ interfaces  between  the  local file manager and the permanent file manager,
{ but rather is a label of a different format that  can  be  returned  to  the
{ permanent  file  utilities.   This label size may then be used to allocate a
{ sequence of a sufficient size that can be given to SRP$FETCH_SYSTEM_LABEL.
{
{       SRP$FETCH_SYSTEM_LABEL_SIZE (LOCAL_FILE_NAME, LABEL_SIZE, STATUS)
{
{ LOCAL_FILE_NAME: (input) This parameter specifies  the  local  name  of  the
{       permanent file whose permanent file utility label is to be returned.
{
{ LABEL_SIZE:  (output)  This parameter returns the size of the permanent file
{       utility label in bytes.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: cle$improper_name
{                   lne$ln_lnt_entry_not_found
{                   lne$no_preserved_attributes
{
{       IDENTIFIER: amc$access_method_id
{
*DECK DECK=SRH$RECORD_CONVERSION_MANAGER EXPAND=FALSE

{ The purpose of this procedure is primarily to convert file from/to 170
{ format to/from 180 format for Remote Host.  Conversion is performed
{ to/from a buffer from/to a file.
{
{   SRP$RECORD_CONVERSION_MANAGER (CONVERSION_INFO, BUFFER_PTR,
{       BUFFER_LENGTH, EOF_FLAG, STATUS)
{
{ CONVERSION_INFO: (input, output) This parameter is a record containing
{   control information and information that must be preserved between
{   calls to this procedure.
{
{ BUFFER_PTR: (input) This is pointer to a buffer which is used to hold
{   foreign (170) code that will be converted from or to.
{
{ BUFFER_LENGTH: (input, output) This parameter is either the length of
{   the 170 buffer to be converted or the length 170 buffer that code has
{   been converted into.
{
{ EOF_FLAG: (output) This parameter is a boolean that indicates when
{   the end of a 180 file has been found.  It is only valid for conversions
{   from 180 to 170.
{
{ STATUS: (output) This parameter specifies the request status.
*DECK DECK=SRH$STORE_SYSTEM_LABEL EXPAND=FALSE
{
{   The purpose  of  this procedure is to store a permanent file utility label
{ for a particular attached or newly created permanent file.  This stores  the
{ label  both  in  the  permanent  file  catalog  and job locally.  If a label
{ already exists for the file, it will be replaced, and the caller  must  have
{ control  permission to the permanent file.  This label must have been gotten
{ with the SRP$FETCH_SYSTEM_LABEL interface and must not  have  been  modified
{ since the fetch.
{
{       SRP$STORE_SYSTEM_LABEL (LOCAL_FILE_NAME, LABEL, STATUS)
{
{ LOCAL_FILE_NAME:  (input)  This  parameter  specifies the local name for the
{       permanent file.
{
{ LABEL: (input) This parameter specifies a sequence that contains  the  label
{       to be stored.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: cle$improper_name
{                   lne$ln_lnt_entry_not_found
{                   lne$incorrect_label_size
{                   lne$invalid_label_data
{                   lne$invalid_label_name
{                   lne$incompatible_label
{
{       IDENTIFIER: amc$access_method_id
{
*DECK DECK=SRK$KEYPOINTS EXPAND=FALSE
{ this deck defines constants for use with}
{ keypoints in srp procedures.}
{ COMMON DECK SRDKEY }

   CONST
     srk$conversion_fap_manager = srk$base + 1,
     {E 'srp$conversion_fap_manager' 'fid.ord' H16 }
     {X 'srp$conversion_fap_manager' 'status' I20 }

     srk$conversion_service_manager = srk$base + 2,
     {E 'srp$conversion_service_manager' 'fid.ord' H16 }
     {X 'srp$conversion_service_manager' 'status' I20 }

     srk$record_conversion_manager = srk$base + 3;
     {E 'srp$record_conversion_manager' 'fid.ord' H16 }
     {X 'srp$record_conversion_manager' 'status' I20 }

?? PUSH (LISTEXT := ON) ??
*copyc OSK$KEYPOINTS
?? POP ??
*DECK DECK=SRM$CONVERT_LABEL EXPAND=TRUE
*copyc osd$default_pragmats
MODULE srm$convert_label;

{   This module contains those interfaces that convert the label to V1 format.
{ The label is converted only after it is found to be downward compatible.



?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc ame$lfn_program_actions
*copyc amt$file_reference
*copyc amt$local_file_name
*copyc amt$path_name
*copyc fmc$unique_label_id
*copyc fme$file_management_errors
*copyc fmt$basic_file_label
*copyc fmt$file_attribute_keys
*copyc fmt$label_headers
*copyc fmt$static_label_header
*copyc fmt$static_label_item
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc pfp$compute_checksum
*copyc srp$validate_compatibility
*copyc srv$static_label_attributes
?? POP ??

?? TITLE := '[XDCL] srp$get_v1_label', EJECT ??

  PROCEDURE [XDCL] srp$get_v1_label (local_file_name: amt$local_file_name;
        current_label: SEQ ( * );
    VAR label_v1: ^SEQ ( * );
    VAR v1_label_allocated: boolean;
    VAR status: ost$status);

    VAR
      computed_checksum: integer,
      v1_label: ^SEQ ( * ),
      p_label: ^SEQ ( * ),
      p_label_header: ^fmt$static_label_header,
      p_label_v1_header: ^fmt$static_bam_label_header,
      p_stored_checksum: ^integer;

    status.normal := TRUE;

    v1_label := label_v1; {assign seq ptr to local variable}

    p_label := ^current_label;
    RESET p_label;
    NEXT p_stored_checksum IN p_label;
    IF p_stored_checksum = NIL THEN
      osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
            ' static label checksum', status);
      RETURN;
    IFEND;
    NEXT p_label_header IN p_label;
    IF p_label_header = NIL THEN
      osp$set_status_abnormal (amc$access_method_id,
            ame$damaged_file_attributes, ' p_label_header', status);
      RETURN;
    IFEND;
    pfp$compute_checksum (#LOC(p_label_header^), #SIZE (p_label^) -
          #SIZE (integer), computed_checksum);
    IF computed_checksum = p_stored_checksum^ THEN
      IF p_label_header^.unique_character = fmc$unique_label_id THEN
        srp$validate_compatibility (p_label, p_label_header, local_file_name,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        srp$convert_to_v1_label (p_label, p_label_header, v1_label, status);
        v1_label_allocated := TRUE;
      ELSE { unique character <> % }
        osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              ' INVALID STATIC LABEL DETECTED in srp$get_v1_label', status);
        RETURN;
      IFEND;
    ELSE { computed_checksum <> p_stored_checksum; possible v1 label }
      RESET p_label;
      NEXT p_label_v1_header IN p_label;
      IF p_label_v1_header = NIL THEN
        osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              ' p_label_v1_header NIL in srp$get_v1_label', status);
        RETURN;
      IFEND;
      IF p_label_v1_header^.name = 'BAM_STATIC_LABEL' THEN
        v1_label := p_label;
      ELSE
        osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              ' INVALID LABEL DETECTED in srp$get_v1_label', status);
        RETURN;
      IFEND;
      v1_label_allocated := FALSE;
    IFEND;
  PROCEND srp$get_v1_label;

?? TITLE := '[INLINE] srp$convert_to_v1_label', EJECT ??

  PROCEDURE [INLINE] srp$convert_to_v1_label (label_p: ^SEQ ( * );
        p_label_header: ^fmt$static_label_header;
    VAR label_v1: ^SEQ ( * );
    VAR status: ost$status);

{ This converts any label to the V1 format }

    VAR
      p_label: ^SEQ ( * ),
      checksum_size: integer,
      job_label_header: ^fmt$job_label_header,
      current_job_info: ^SEQ ( * ),
      p_checksum: ^integer,
      static_label_header: ^fmt$static_bam_label_header,
      static_label_size: integer,
      v1_label: ^SEQ ( * ),
      v1_label_size: integer,
      v1_job_info: ^SEQ ( * ),
      v1_static_info: ^fmt$basic_file_label;

    v1_label := label_v1; {assign seq ptr to local variable}
    p_label := label_p;

    checksum_size := #SIZE (integer);
    static_label_size := #SIZE (fmt$basic_file_label);
    v1_label_size := static_label_size + checksum_size +
      #SIZE (fmt$static_bam_label_header) + checksum_size +
      #SIZE (fmt$job_label_header) + checksum_size;
    IF p_label_header^.job_routing_label_size > 0 THEN
      v1_label_size := v1_label_size + p_label_header^.job_routing_label_size +
        checksum_size;
    IFEND;
    ALLOCATE v1_label: [[REP v1_label_size OF cell]];
    IF v1_label = NIL THEN
      osp$set_status_abnormal (amc$access_method_id, fme$system_error,
            'FULL HEAP in srp$convert_to_v1_label', status);
      RETURN;
    IFEND;

    RESET v1_label;
    NEXT static_label_header IN v1_label;
    static_label_header^.name := 'BAM_STATIC_LABEL';
    static_label_header^.version := 1;
    static_label_header^.size := static_label_size;
    NEXT p_checksum IN v1_label;
    pfp$compute_checksum (#LOC (static_label_header^), #SIZE
          (fmt$static_bam_label_header), p_checksum^);

    NEXT v1_static_info IN v1_label;
    srp$convert_label_attributes (p_label, v1_static_info^, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    NEXT p_checksum IN v1_label;
    pfp$compute_checksum (#LOC (v1_static_info^), static_label_size,
          p_checksum^);

    NEXT job_label_header IN v1_label;
    job_label_header^.name := 'BAM_JOB_LABEL';
    job_label_header^.version := 1;
    job_label_header^.size := p_label_header^.job_routing_label_size;
    NEXT p_checksum IN v1_label;
    pfp$compute_checksum (#LOC (job_label_header^), #SIZE (fmt$job_label_header),
          p_checksum^);
    IF job_label_header^.size > 0 THEN
      NEXT v1_job_info: [[REP job_label_header^.size OF cell]] IN v1_label;
      NEXT current_job_info: [[REP p_label_header^.job_routing_label_size OF cell]]
        IN p_label;
      v1_job_info^ := current_job_info^;
      NEXT p_checksum IN v1_label;
      pfp$compute_checksum (#LOC (v1_job_info^), job_label_header^.size, p_checksum^);
    IFEND;

  PROCEND srp$convert_to_v1_label;

?? TITLE := '[XDCL] srp$convert_label_attributes', EJECT ??

  PROCEDURE [XDCL] srp$convert_label_attributes (p_label: ^SEQ ( * );
    VAR static_label_attributes: fmt$basic_file_label;
    VAR status: ost$status);

{ This converts a V2 label to the V1 types }

    VAR
      checksum: ^integer,
      header: ^fmt$static_label_header,
      attribute_key: fmt$file_attribute_keys,
      static_label: ^SEQ ( * ),
      static_label_item: ^fmt$static_label_item,
      ignore_path: amt$path_name,
      ignore_found: boolean,
      str: ^string ( * );

    PROCEDURE [INLINE] get_entry_point_reference (VAR name: pmt$program_name;
      VAR path: amt$file_reference);

      NEXT str: [static_label_item^.entry_point_name_length] IN static_label;
      name := str^;
      IF static_label_item^.entry_point_path_length > 0 THEN
        NEXT str: [static_label_item^.entry_point_path_length] IN static_label;
        path := str^;
      IFEND;
    PROCEND get_entry_point_reference;

    PROCEDURE [INLINE] get_name (VAR name: pmt$program_name);

      NEXT str: [static_label_item^.name_length] IN static_label;
      name := str^;
    PROCEND get_name;


    status.normal := TRUE;
    static_label_attributes := srv$static_label_attributes;

    IF p_label <> NIL THEN
      static_label := p_label;
      RESET static_label;
      NEXT checksum IN static_label;
      IF checksum = NIL THEN
        osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              'BAD LABEL DETECTED in srp$convert_label_attributes', status);
        RETURN;
      IFEND;
      NEXT header IN static_label;
      IF header^. unique_character <> fmc$unique_label_id THEN
        osp$set_status_abnormal (amc$access_method_id, ame$damaged_file_attributes,
              'INVALID STATIC FILE LABEL DETECTED in srp$convert_label_attributes',
              status);
        RETURN;
      IFEND;
      static_label_attributes.existing_file := header^.file_previously_opened;
      IF header^. file_previously_opened THEN
        static_label_attributes.ring_attributes_source := header^.
              ring_attributes_source;
        static_label_attributes.ring_attributes := header^. ring_attributes;
      IFEND;
      IF header^. highest_attribute_present > 0 THEN
        FOR attribute_key := LOWERBOUND (header^. attribute_present) TO
              header^. highest_attribute_present DO
          CASE attribute_key OF
          = fmc$block_type =
            IF header^.attribute_present [fmc$block_type] THEN
              NEXT static_label_item: [fmc$block_type] IN static_label;
              static_label_attributes.block_type_source :=
                    static_label_item^.source;
              static_label_attributes.block_type := static_label_item^.
                    block_type;
            IFEND;
          = fmc$character_conversion =
            IF header^.attribute_present [fmc$character_conversion] THEN
              NEXT static_label_item: [fmc$character_conversion] IN static_label;
              static_label_attributes.character_conversion_source :=
                    static_label_item^.source;
              static_label_attributes.character_conversion := static_label_item^.
                    character_conversion;
            IFEND;
          = fmc$clear_space =
            IF header^.attribute_present [fmc$clear_space] THEN
              NEXT static_label_item: [fmc$clear_space] IN static_label;
              static_label_attributes.clear_space_source :=
                    static_label_item^.source;
              static_label_attributes.clear_space := static_label_item^.
                    clear_space;
            IFEND;
          = fmc$file_access_procedure =
            IF header^.attribute_present [fmc$file_access_procedure] THEN
              NEXT static_label_item: [fmc$file_access_procedure] IN static_label;
              static_label_attributes.file_access_procedure_source :=
                    static_label_item^.source;
              get_entry_point_reference (static_label_attributes.
                    file_access_procedure, ignore_path);
            IFEND;
          = fmc$file_contents =
            IF header^.attribute_present [fmc$file_contents] THEN
              NEXT static_label_item: [fmc$file_contents] IN static_label;
              static_label_attributes.file_contents_source :=
                    static_label_item^.source;
              get_name (static_label_attributes.file_contents);
            IFEND;
          = fmc$file_limit =
            IF header^.attribute_present [fmc$file_limit] THEN
              NEXT static_label_item: [fmc$file_limit] IN static_label;
              static_label_attributes.file_limit_source :=
                    static_label_item^.source;
              static_label_attributes.file_limit := static_label_item^.
                    integer_value;
            IFEND;
          = fmc$file_organization =
            IF header^.attribute_present [fmc$file_organization] THEN
              NEXT static_label_item: [fmc$file_organization] IN static_label;
              static_label_attributes.file_organization_source :=
                    static_label_item^.source;
              static_label_attributes.file_organization := static_label_item^.
                    file_organization;
            IFEND;
          = fmc$file_processor =
            IF header^.attribute_present [fmc$file_processor] THEN
              NEXT static_label_item: [fmc$file_processor] IN static_label;
              static_label_attributes.file_processor_source :=
                    static_label_item^.source;
              get_name (static_label_attributes.file_processor);
            IFEND;
          = fmc$file_structure =
            IF header^.attribute_present [fmc$file_structure] THEN
              NEXT static_label_item: [fmc$file_structure] IN static_label;
              static_label_attributes.file_structure_source :=
                    static_label_item^.source;
              get_name (static_label_attributes.file_structure);
            IFEND;
          = fmc$forced_write =
            IF header^.attribute_present [fmc$forced_write] THEN
              NEXT static_label_item: [fmc$forced_write] IN static_label;
              static_label_attributes.forced_write_source :=
                    static_label_item^.source;
              static_label_attributes.forced_write := static_label_item^.
                    forced_write;
            IFEND;
          = fmc$internal_code =
            IF header^.attribute_present [fmc$internal_code] THEN
              NEXT static_label_item: [fmc$internal_code] IN static_label;
              static_label_attributes.internal_code_source :=
                    static_label_item^.source;
              static_label_attributes.internal_code := static_label_item^.
                    internal_code;
            IFEND;
          = fmc$label_type =
            IF header^.attribute_present [fmc$label_type] THEN
              NEXT static_label_item: [fmc$label_type] IN static_label;
              static_label_attributes.label_type_source :=
                    static_label_item^.source;
              static_label_attributes.label_type := static_label_item^.
                    label_type;
            IFEND;
          = fmc$line_number =
            IF header^.attribute_present [fmc$line_number] THEN
              NEXT static_label_item: [fmc$line_number] IN static_label;
              static_label_attributes.line_number_source :=
                    static_label_item^.source;
              static_label_attributes.line_number := static_label_item^.
                    line_number;
            IFEND;
          = fmc$max_block_length =
            IF header^.attribute_present [fmc$max_block_length] THEN
              NEXT static_label_item: [fmc$max_block_length] IN static_label;
              static_label_attributes.max_block_length_source :=
                    static_label_item^.source;
              static_label_attributes.max_block_length := static_label_item^.
                    integer_value;
            IFEND;
          = fmc$max_record_length =
            IF header^.attribute_present [fmc$max_record_length] THEN
              NEXT static_label_item: [fmc$max_record_length] IN static_label;
              static_label_attributes.max_record_length_source :=
                    static_label_item^.source;
              static_label_attributes.max_record_length := static_label_item^.
                    integer_value;
            IFEND;
          = fmc$min_block_length =
            IF header^.attribute_present [fmc$min_block_length] THEN
              NEXT static_label_item: [fmc$min_block_length] IN static_label;
              static_label_attributes.min_block_length_source :=
                    static_label_item^.source;
              static_label_attributes.min_block_length := static_label_item^.
                    integer_value;
            IFEND;
          = fmc$min_record_length =
            IF header^.attribute_present [fmc$min_record_length] THEN
              NEXT static_label_item: [fmc$min_record_length] IN static_label;
              static_label_attributes.min_record_length_source :=
                    static_label_item^.source;
              static_label_attributes.min_record_length := static_label_item^.
                    integer_value;
            IFEND;
          = fmc$padding_character =
            IF header^.attribute_present [fmc$padding_character] THEN
              NEXT static_label_item: [fmc$padding_character] IN static_label;
              static_label_attributes.padding_character_source :=
                    static_label_item^.source;
              static_label_attributes.padding_character := static_label_item^.
                    padding_character;
            IFEND;
          = fmc$page_format =
            IF header^.attribute_present [fmc$page_format] THEN
              NEXT static_label_item: [fmc$page_format] IN static_label;
              static_label_attributes.page_format_source :=
                    static_label_item^.source;
              static_label_attributes.page_format := static_label_item^.
                    page_format;
            IFEND;
          = fmc$page_length =
            IF header^.attribute_present [fmc$page_length] THEN
              NEXT static_label_item: [fmc$page_length] IN static_label;
              static_label_attributes.page_length_source :=
                    static_label_item^.source;
              static_label_attributes.page_length := static_label_item^.
                    integer_value;
            IFEND;
          = fmc$page_width =
            IF header^.attribute_present [fmc$page_width] THEN
              NEXT static_label_item: [fmc$page_width] IN static_label;
              static_label_attributes.page_width_source :=
                    static_label_item^.source;
              static_label_attributes.page_width := static_label_item^.
                    integer_value;
            IFEND;
          = fmc$preset_value =
            IF header^.attribute_present [fmc$preset_value] THEN
              NEXT static_label_item: [fmc$preset_value] IN static_label;
              static_label_attributes.preset_value_source :=
                    static_label_item^.source;
              static_label_attributes.preset_value := static_label_item^.
                    integer_value;
            IFEND;
          = fmc$record_type =
            IF header^.attribute_present [fmc$record_type] THEN
              NEXT static_label_item: [fmc$record_type] IN static_label;
              static_label_attributes.record_type_source :=
                    static_label_item^.source;
              static_label_attributes.record_type := static_label_item^.
                    record_type;
            IFEND;
          = fmc$statement_identifier =
            IF header^.attribute_present [fmc$statement_identifier] THEN
              NEXT static_label_item: [fmc$statement_identifier] IN static_label;
              static_label_attributes.statement_identifier_source :=
                    static_label_item^.source;
              static_label_attributes.statement_identifier := static_label_item^.
                    statement_identifier;
            IFEND;
          = fmc$user_info =
            IF header^.attribute_present [fmc$user_info] THEN
              NEXT static_label_item: [fmc$user_info] IN static_label;
              static_label_attributes.user_info_source :=
                    static_label_item^.source;
              IF static_label_item^.user_info_present THEN
                NEXT str: [32] IN static_label;
                static_label_attributes.user_info := str^;
              IFEND;
            IFEND;
          = fmc$vertical_print_density =
            IF header^.attribute_present [fmc$vertical_print_density] THEN
              NEXT static_label_item: [fmc$vertical_print_density] IN static_label;
              static_label_attributes.vertical_print_density_source :=
                    static_label_item^.source;
              static_label_attributes.vertical_print_density := static_label_item^.
                    integer_value;
            IFEND;
          = fmc$average_record_length =
            IF header^.attribute_present [fmc$average_record_length] THEN
              NEXT static_label_item: [fmc$average_record_length] IN static_label;
              static_label_attributes.average_record_length_source :=
                    static_label_item^.source;
              static_label_attributes.average_record_length := static_label_item^.
                    integer_value;
            IFEND;
          = fmc$collate_table =
            IF header^.attribute_present [fmc$collate_table] THEN
              NEXT static_label_item: [fmc$collate_table] IN static_label;
              static_label_attributes.collate_table_source :=
                    static_label_item^.source;
              static_label_attributes.collate_table := static_label_item^.
                    collate_table;
            IFEND;
          = fmc$collate_table_name =
            IF header^.attribute_present [fmc$collate_table_name] THEN
              NEXT static_label_item: [fmc$collate_table_name] IN static_label;
              static_label_attributes.collate_table_name_source :=
                    static_label_item^.source;
              get_entry_point_reference (static_label_attributes.
                    collate_table_name, ignore_path);
            IFEND;
          = fmc$data_padding =
            IF header^.attribute_present [fmc$data_padding] THEN
              NEXT static_label_item: [fmc$data_padding] IN static_label;
              static_label_attributes.data_padding_source :=
                    static_label_item^.source;
              static_label_attributes.data_padding := static_label_item^.
                    data_padding;
            IFEND;
          = fmc$embedded_key =
            IF header^.attribute_present [fmc$embedded_key] THEN
              NEXT static_label_item: [fmc$embedded_key] IN static_label;
              static_label_attributes.embedded_key_source :=
                    static_label_item^.source;
              static_label_attributes.embedded_key := static_label_item^.
                    embedded_key;
            IFEND;
          = fmc$estimated_record_count =
            IF header^.attribute_present [fmc$estimated_record_count] THEN
              NEXT static_label_item: [fmc$estimated_record_count] IN static_label;
              static_label_attributes.estimated_record_count_source :=
                    static_label_item^.source;
              static_label_attributes.estimated_record_count := static_label_item^.
                    integer_value;
            IFEND;
          = fmc$index_levels =
            IF header^.attribute_present [fmc$index_levels] THEN
              NEXT static_label_item: [fmc$index_levels] IN static_label;
              static_label_attributes.index_levels_source :=
                    static_label_item^.source;
              static_label_attributes.index_levels := static_label_item^.
                    integer_value;
            IFEND;
          = fmc$index_padding =
            IF header^.attribute_present [fmc$index_padding] THEN
              NEXT static_label_item: [fmc$index_padding] IN static_label;
              static_label_attributes.index_padding_source :=
                    static_label_item^.source;
              static_label_attributes.index_padding := static_label_item^.
                    index_padding;
            IFEND;
          = fmc$key_length =
            IF header^.attribute_present [fmc$key_length] THEN
              NEXT static_label_item: [fmc$key_length] IN static_label;
              static_label_attributes.key_length_source :=
                    static_label_item^.source;
              static_label_attributes.key_length := static_label_item^.
                    integer_value;
            IFEND;
          = fmc$key_position =
            IF header^.attribute_present [fmc$key_position] THEN
              NEXT static_label_item: [fmc$key_position] IN static_label;
              static_label_attributes.key_position_source :=
                    static_label_item^.source;
              static_label_attributes.key_position := static_label_item^.
                    integer_value;
            IFEND;
          = fmc$key_type =
            IF header^.attribute_present [fmc$key_type] THEN
              NEXT static_label_item: [fmc$key_type] IN static_label;
              static_label_attributes.key_type_source :=
                    static_label_item^.source;
              static_label_attributes.key_type := static_label_item^.
                    key_type;
            IFEND;
          = fmc$record_limit =
            IF header^.attribute_present [fmc$record_limit] THEN
              NEXT static_label_item: [fmc$record_limit] IN static_label;
              static_label_attributes.record_limit_source :=
                    static_label_item^.source;
              static_label_attributes.record_limit := static_label_item^.
                    integer_value;
            IFEND;
          = fmc$records_per_block =
            IF header^.attribute_present [fmc$records_per_block] THEN
              NEXT static_label_item: [fmc$records_per_block] IN static_label;
              static_label_attributes.records_per_block_source :=
                    static_label_item^.source;
              static_label_attributes.records_per_block := static_label_item^.
                    integer_value;
            IFEND;
          ELSE
          CASEND;
        FOREND;
      IFEND;
    IFEND;

  PROCEND srp$convert_label_attributes;

MODEND srm$convert_label;

*DECK DECK=SRM$FETCH_STORE_LABEL EXPAND=TRUE
?? RIGHT := 110 ??
MODULE srm$fetch_store_label;
*copyc avp$ring_min
*copyc fmp$fetch_system_label
*copyc fmp$fetch_system_label_size
*copyc fmp$store_system_label
*copyc pfp$compute_checksum

?? TITLE := '[XDCL, #GATE] srp$fetch_system_label_size', EJECT ??

  PROCEDURE [XDCL, #GATE] srp$fetch_system_label_size (local_file_name:
    amt$local_file_name;
    VAR label_size: 0 .. 7fffffff(16);
    VAR status: ost$status);

    status.normal := TRUE;
    fmp$fetch_system_label_size (local_file_name, label_size, status);
  PROCEND srp$fetch_system_label_size;

?? TITLE := '[XDCL] srp$fetch_system_label' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] srp$fetch_system_label (local_file_name:
    amt$local_file_name;
    VAR label: SEQ ( * );
    VAR status: ost$status);

    status.normal := TRUE;

    fmp$fetch_system_label (local_file_name, label, status);
  PROCEND srp$fetch_system_label;

?? TITLE := '[XDCL] srp$store_system_label' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] srp$store_system_label
    (    local_file_name: amt$local_file_name;
         label: SEQ ( * );
     VAR status: ost$status);

    fmp$store_system_label (local_file_name, avp$ring_min (), label, status);
  PROCEND srp$store_system_label;

?? TITLE := '[XDCL, #GATE] srp$compute_label_checksum' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] srp$compute_label_checksum
    (    label_checksum_location: pft$checksum_location;
         label_checksum_size: pft$checksum_size;
     VAR label_checksum: pft$checksum);

    pfp$compute_checksum (label_checksum_location, label_checksum_size, label_checksum);
  PROCEND srp$compute_label_checksum;
MODEND srm$fetch_store_label;
*DECK DECK=SRM$RESTORE_LABEL EXPAND=TRUE
*copyc osd$default_pragmats
MODULE srm$restore_label;

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc clp$convert_string_to_integer
*copyc ost$status
*copyc pmp$get_os_version
*copyc pmt$os_name
*copyc srp$get_v1_label
*copyc srp$store_system_label
?? POP ??

?? TITLE := '[XDCL] srp$restore_label', EJECT ??

  PROCEDURE [XDCL] srp$restore_label (local_file_name: amt$local_file_name;
        label: SEQ ( * );
    VAR status: ost$status);

{   This procedure determines which version of the system is being run. If a
{ V1 system is running, it gets the label in V1 format and stores it; otherwise,
{ it stores the label in the format passed by the utility.


    VAR
      development_cycle: clt$integer,
      int1: clt$integer,
      int2: clt$integer,
      os_version: pmt$os_name,
      v1_label: ^SEQ ( * ),
      v1_label_allocated: boolean,
      v1_system_running: boolean;

    v1_system_running := FALSE;
    pmp$get_os_version (os_version, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    clp$convert_string_to_integer (os_version (10), int1, status);
    IF NOT status.normal THEN
      clp$convert_string_to_integer (os_version (13,2), development_cycle, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF development_cycle.value < 21 THEN
        v1_system_running := TRUE;
      IFEND;
    ELSE
      clp$convert_string_to_integer (os_version (12), int2, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF (int1.value < 1) OR ((int1.value = 1) AND (int2.value < 2)) THEN
        v1_system_running := TRUE;
      IFEND;
    IFEND;
    IF v1_system_running THEN
      srp$get_v1_label (local_file_name, label, v1_label, v1_label_allocated, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      srp$store_system_label (local_file_name, v1_label^, status);
      IF v1_label_allocated THEN
        FREE v1_label;
      IFEND;
    ELSE { not V1 system }
      srp$store_system_label (local_file_name, label, status);
    IFEND;

  PROCEND srp$restore_label;

MODEND srm$restore_label;
*DECK DECK=SRM$STATIC_LABEL EXPAND=TRUE
*copy OSD$DEFAULT_PRAGMATS

MODULE srm$static_label;
{}
{   This module contains the XDCLed variable that defines the defaults of
{ the static label.
{}

?? TITLE := 'SRP$DUMMY_PROCEDURE' ??
?? EJECT ??

  PROCEDURE srp$dummy_procedure;

?? TITLE := '[XDCL] srv$static_label_attributes' ??
?? EJECT ??

    VAR
      srv$static_label_attributes: [XDCL, READ]
        fmt$basic_file_label := [


        { existing_file } FALSE,
        { creation_access_level } * ,
        { creation_access_level_source } amc$undefined_attribute,
        { block_type } amc$system_specified,
        { item_source } amc$access_method_default,
        { character_conversion } FALSE,
        { item_source } amc$access_method_default,
        { item.clear_space } FALSE,
        { item_source } amc$access_method_default,
        { item.file_access_procedure } osc$null_name,
        { item_source } amc$undefined_attribute,
        { item.file_contents } amc$unknown_contents,
        { item_source } amc$access_method_default,
        { item.file_limit } amc$file_byte_limit,
        { item_source } amc$access_method_default,
        { item.file_organization } amc$sequential,
        { item_source } amc$access_method_default,
        { file_processor } amc$unknown_processor,
        { item_source } amc$access_method_default,
        { file_structure } amc$unknown_structure,
        { item_source } amc$access_method_default,
        { forced_write } amc$unforced,
        { item_source } amc$access_method_default,
        { item.internal_code } amc$ascii,
        { item_source } amc$access_method_default,
        { item.label_type } amc$unlabelled,
        { item_source } amc$access_method_default,
        { item.line_number } * ,
        { item_source } amc$undefined_attribute,
        { item.max_block_length } 4128,
        { item_source } amc$access_method_default,
        { item.max_record_length } 256,
        { item_source } amc$access_method_default,
        { item.min_block_length } 18,
        { item_source } amc$access_method_default,
        { item.min_record_length } 0,
        { item_source } amc$access_method_default,
        { item.padding_character } ' ',
        { item_source } amc$access_method_default,
        { item.page_format } amc$burstable_form,
        { item_source } amc$access_method_default,
        { item.page_length } 60,
        { item_source } amc$access_method_default,
        { item.page_width } 132,
        { item_source } amc$access_method_default,
        { item.preset_value } 0,
        { item_source } amc$access_method_default,
        { item.record_type } amc$variable { v } ,
        { item_source } amc$access_method_default,
        { item.ring_attributes } * ,
        { item_source } amc$undefined_attribute,
        { statement_identifier } * ,
        { statement_identifier_source } amc$undefined_attribute,
        { item.user_info } * ,
        { item_source } amc$undefined_attribute,
        { vertical_print_density } 6,
        { vertical_print_density_source } amc$access_method_default,
        { item.average_record_length } * ,
        { item_source } amc$undefined_attribute,
        { collate_table } * ,
        { collate_table_source } amc$undefined_attribute,
        { collate_table_name } osc$null_name,
        { collate_table_name_source } amc$undefined_attribute,
        { item.data_padding } 0,
        { item_source } amc$access_method_default,
        { item.embedded_key } TRUE,
        { item_source } amc$access_method_default,
        { item.estimated_record_count } * ,
        { item_source } amc$undefined_attribute,
        { item.index_levels } 2 ,
        { item_source } amc$access_method_default,
        { item.index_padding } 0,
        { item_source } amc$access_method_default,
        { item.key_length } * ,
        { item_source } amc$undefined_attribute,
        { item.key_position } 0,
        { item_source } amc$access_method_default,
        { item.key_type } amc$uncollated_key,
        { item_source } amc$access_method_default,
        { item.record_limit } * ,
        { item_source } amc$undefined_attribute,
        { item.records_per_block } * ,
        { item_source } amc$undefined_attribute
        { recend; } ];

?? PUSH (LISTEXT := ON) ??
*copyc fmt$basic_file_label
?? POP ??
  PROCEND srp$dummy_procedure;
MODEND srm$static_label;
*DECK DECK=SRM$VALIDATE_COMPATIBILITY EXPAND=TRUE
*copyc osd$default_pragmats
MODULE srm$validate_compatibility;

{
{ PURPOSE:
{    This module validates upward and downward compatibility of the
{ file label between different systems.
{
{        SRP$VALIDATE_COMPATIBILITY (P_FILE_LABEL, P_FILE_LABEL_HEADER,
{              LOCAL_FILE_NAME, STATUS)
{
{ P_FILE_LABEL: (input) This parameter specifies the file label to be
{        validated.
{
{ P_FILE_LABEL_HEADER: (input) This parameter specifies the header in
{        the file label.
{
{ LOCAL_FILE_NAME: (input) This parameter specifies the local name of the
{        file whose label is to be validated.
{
{ STATUS: (output) This parameter returns the request status.
{
?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc ame$lfn_program_actions
*copyc amt$file_reference
*copyc amt$local_file_name
*copyc amt$logging_options
*copyc amt$path_name
*copyc bat$v1_max_block_length
*copyc clp$convert_string_to_file
*copyc clp$validate_name
*copyc clt$file
*copyc fmc$current_revision_level
*copyc fmc$unique_label_id
*copyc fmt$file_attribute_keys
*copyc fmt$file_label
*copyc fmt$static_label_header
*copyc fmt$static_label_item
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$name
*copyc pmt$program_name
?? POP ??

?? TITLE := '[XDCL] srp$validate_compatibility', EJECT ??

  PROCEDURE [XDCL] srp$validate_compatibility (file_label_p: fmt$p_file_label;
        p_file_label_header: ^fmt$static_label_header;
        local_file_name: amt$local_file_name;
    VAR status: ost$status);

    TYPE
      attribute_keys = SET OF fmt$file_attribute_keys;

    VAR
      attributes_are_compatible: boolean,
      entry_point_refs: [STATIC] attribute_keys := $attribute_keys
        [fmc$file_access_procedure, fmc$collate_table_name],
      i: integer,
      job_label: ^SEQ ( * ),
      names: [STATIC] attribute_keys := $attribute_keys
        [fmc$file_contents, fmc$file_processor, fmc$file_structure],
      p_file_label: ^SEQ ( * ),
      static_label_item: ^fmt$static_label_item,
      str: ^string ( * ),
      user_attributes: ^SEQ ( * ),
      x: ^cell;

    PROCEDURE [INLINE] set_status_abnormal (level: fmt$revision_level;
          text: string ( * );
      VAR status: ost$status);

      osp$set_status_abnormal (amc$access_method_id,
            ame$incompatible_attributes, local_file_name, status);
      osp$append_status_integer (osc$status_parameter_delimiter, level, 10,
            false, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, text,
            status);
    PROCEND set_status_abnormal;


    { validate downward compatibility }

    p_file_label := file_label_p; {assign seq ptr to local variable}

    FOR i := fmc$ring_attributes TO fmc$highest_current_attribute DO
      IF p_file_label_header^.attribute_present [i] THEN
        NEXT static_label_item: [i] IN p_file_label;
        IF static_label_item = NIL THEN
          set_status_abnormal (p_file_label_header^.revision_level,
                'downward', status);
          RETURN;
        IFEND;

        IF i IN entry_point_refs THEN
          NEXT str: [static_label_item^.entry_point_name_length] IN p_file_label;
          IF str = NIL THEN
            set_status_abnormal (p_file_label_header^.revision_level,
                  'downward', status);
            RETURN;
          IFEND;
          IF static_label_item^.entry_point_path_length > 0 THEN
            NEXT str: [static_label_item^.entry_point_path_length] IN p_file_label;
            IF str = NIL THEN
              set_status_abnormal (p_file_label_header^.revision_level,
                    'downward', status);
              RETURN;
            IFEND;
          IFEND;
        IFEND;

        IF i IN names THEN
          NEXT str: [static_label_item^.name_length] IN p_file_label;
          IF str = NIL THEN
            set_status_abnormal (p_file_label_header^.revision_level,
                  'downward', status);
            RETURN;
          IFEND;
        IFEND;

        IF i = fmc$user_info THEN
          NEXT str: [32] IN p_file_label;
          IF str = NIL THEN
            set_status_abnormal (p_file_label_header^.revision_level,
                  'downward', status);
            RETURN;
          IFEND;
        IFEND;

      IFEND;
    FOREND;
    FOR i := fmc$highest_current_attribute + 1 TO
          p_file_label_header^.highest_attribute_supported DO
      IF p_file_label_header^.attribute_present [i] THEN
        set_status_abnormal (p_file_label_header^.revision_level,
              'downward', status);
        RETURN;
      IFEND;
    FOREND;

    IF p_file_label_header^.user_attribute_length > 0 THEN
      NEXT user_attributes: [[REP p_file_label_header^.user_attribute_length
            OF cell]] IN p_file_label;
    IFEND;
    IF p_file_label_header^.job_routing_label_size > 0 THEN
      NEXT job_label: [[REP p_file_label_header^.job_routing_label_size
            OF cell]] IN p_file_label;
    IFEND;
    NEXT x IN p_file_label;
    IF x <> NIL THEN
      set_status_abnormal (p_file_label_header^.revision_level,
            'downward', status);
      RETURN;
    IFEND;
    srp$validate_attributes (p_file_label, attributes_are_compatible, status);
    IF NOT attributes_are_compatible THEN
      set_status_abnormal (p_file_label_header^.revision_level,
            'downward', status);
    IFEND;

  PROCEND srp$validate_compatibility;


?? TITLE := '[XDCL] srp$validate_attributes', EJECT ??

  PROCEDURE [XDCL] srp$validate_attributes (p_static_label: ^SEQ ( * );
    VAR attributes_are_compatible: boolean;
    VAR status: ost$status);


    VAR
      static_label: ^SEQ ( * ),
      checksum: ^integer,
      header: ^fmt$static_label_header,
      attribute_key: fmt$file_attribute_keys,
      static_label_item: ^fmt$static_label_item,
      collate_table_name: pmt$program_name,
      compression_procedure_name: pmt$program_name,
      compression_procedure_path: amt$path_name,
      hashing_procedure_name: pmt$program_name,
      hashing_procedure_path: amt$path_name,
      fap_name: pmt$program_name,
      file_contents,
      file_processor,
      file_structure: pmt$program_name,
      validated_name: ost$name,
      ignore_file: clt$file,
      ignore_path: amt$path_name,
      ignore_found: boolean,
      str: ^string ( * );

    PROCEDURE [INLINE] get_entry_point_reference (VAR name: pmt$program_name;
      VAR path: amt$file_reference);

      NEXT str: [static_label_item^.entry_point_name_length] IN static_label;
      name := str^;
      IF static_label_item^.entry_point_path_length > 0 THEN
        NEXT str: [static_label_item^.entry_point_path_length] IN static_label;
        path := str^;
      IFEND;
    PROCEND get_entry_point_reference;

    PROCEDURE [INLINE] get_name (VAR name: pmt$program_name);

      NEXT str: [static_label_item^.name_length] IN static_label;
      name := str^;
    PROCEND get_name;

    status.normal := TRUE;
    attributes_are_compatible := TRUE;

    static_label := p_static_label; {assign seq ptr to local variable}

    IF static_label <> NIL THEN
      RESET static_label;
      NEXT checksum IN static_label;
      IF checksum = NIL THEN
        osp$set_status_abnormal (amc$access_method_id,
              ame$damaged_file_attributes,
              'BAD LABEL DETECTED in srp$validate_attributes', status);
        RETURN;
      IFEND;
      NEXT header IN static_label;
      IF header^.unique_character <> fmc$unique_label_id THEN
        osp$set_status_abnormal (amc$access_method_id,
              ame$damaged_file_attributes,
              'INVALID STATIC LABEL DETECTED in srp$validate_attributes',
              status);
        RETURN;
      IFEND;
      IF header^.file_previously_opened THEN
        IF NOT ((1 <= header^.ring_attributes.r1) AND
              (header^.ring_attributes.r1 <= header^.
              ring_attributes.r2) AND (header^.ring_attributes.r2
              <= header^.ring_attributes.r3) AND (header^.
              ring_attributes.r3 <= 13)) THEN
          attributes_are_compatible := FALSE;
        IFEND;
      IFEND;
      IF header^.highest_attribute_present > 0 THEN
        attribute_key := fmc$average_record_length;
        WHILE (attribute_key <= header^.highest_attribute_present) AND
              (attributes_are_compatible) DO
          CASE attribute_key OF
          = fmc$block_type =
            IF header^.attribute_present [fmc$block_type] THEN
              NEXT static_label_item: [fmc$block_type] IN static_label;
              IF (static_label_item^.block_type < LOWERVALUE (amt$block_type))
                    OR (static_label_item^.block_type > UPPERVALUE
                    (amt$block_type)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$character_conversion =
            IF header^.attribute_present [fmc$character_conversion] THEN
              NEXT static_label_item: [fmc$character_conversion] IN
                    static_label;
              IF (static_label_item^.character_conversion < LOWERVALUE
                    (boolean)) OR (static_label_item^.character_conversion >
                    UPPERVALUE (boolean)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$clear_space =
            IF header^.attribute_present [fmc$clear_space] THEN
              NEXT static_label_item: [fmc$clear_space] IN static_label;
              IF (static_label_item^.clear_space < LOWERVALUE
                    (ost$clear_file_space)) OR (static_label_item^.clear_space
                    > UPPERVALUE (ost$clear_file_space)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$file_access_procedure =
            IF header^.attribute_present [fmc$file_access_procedure] THEN
              NEXT static_label_item: [fmc$file_access_procedure] IN
                    static_label;
              get_entry_point_reference (fap_name, ignore_path);
              clp$validate_name (fap_name, validated_name,
                    attributes_are_compatible);
            IFEND;
          = fmc$file_contents =
            IF header^.attribute_present [fmc$file_contents] THEN
              NEXT static_label_item: [fmc$file_contents] IN static_label;
              get_name (file_contents);
              clp$validate_name (file_contents, validated_name,
                    attributes_are_compatible);
            IFEND;
          = fmc$file_limit =
            IF header^.attribute_present [fmc$file_limit] THEN
              NEXT static_label_item: [fmc$file_limit] IN static_label;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (static_label_item^.integer_value)) OR (static_label_item^.
                    integer_value > UPPERVALUE (static_label_item^.
                    integer_value)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$file_organization =
            IF header^.attribute_present [fmc$file_organization] THEN
              NEXT static_label_item: [fmc$file_organization] IN static_label;
              IF (static_label_item^.file_organization < LOWERVALUE
                    (amt$file_organization)) OR (static_label_item^.
                    file_organization > UPPERVALUE (amt$file_organization))
                    THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$file_processor =
            IF header^.attribute_present [fmc$file_processor] THEN
              NEXT static_label_item: [fmc$file_processor] IN static_label;
              get_name (file_processor);
              clp$validate_name (file_processor, validated_name,
                    attributes_are_compatible);
            IFEND;
          = fmc$file_structure =
            IF header^.attribute_present [fmc$file_structure] THEN
              NEXT static_label_item: [fmc$file_structure] IN static_label;
              get_name (file_structure);
              clp$validate_name (file_structure, validated_name,
                    attributes_are_compatible);
            IFEND;
          = fmc$forced_write =
            IF header^.attribute_present [fmc$forced_write] THEN
              NEXT static_label_item: [fmc$forced_write] IN static_label;
              IF (static_label_item^.forced_write < LOWERVALUE
                    (amt$forced_write)) OR (static_label_item^.forced_write >
                    UPPERVALUE (amt$forced_write)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$internal_code =
            IF header^.attribute_present [fmc$internal_code] THEN
              NEXT static_label_item: [fmc$internal_code] IN static_label;
              IF (static_label_item^.internal_code < LOWERVALUE
                    (amt$internal_code)) OR (static_label_item^.internal_code >
                    UPPERVALUE (amt$internal_code)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$label_type =
            IF header^.attribute_present [fmc$label_type] THEN
              NEXT static_label_item: [fmc$label_type] IN static_label;
              IF (static_label_item^.label_type < LOWERVALUE (amt$label_type))
                    OR (static_label_item^.label_type > UPPERVALUE
                    (amt$label_type)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$line_number =
            IF header^.attribute_present [fmc$line_number] THEN
              NEXT static_label_item: [fmc$line_number] IN static_label;
              IF (static_label_item^.line_number.length < LOWERVALUE
                    (amt$line_number_length)) OR (static_label_item^.
                    line_number.length > UPPERVALUE (amt$line_number_length))
                    OR (static_label_item^.line_number.location < LOWERVALUE
                    (amt$line_number_location)) OR (static_label_item^.
                    line_number.location > UPPERVALUE
                    (amt$line_number_location)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$max_block_length =
            IF header^.attribute_present [fmc$max_block_length] THEN
              NEXT static_label_item: [fmc$max_block_length] IN static_label;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (bat$v1_max_block_length)) OR (static_label_item^.integer_value
                    > UPPERVALUE(bat$v1_max_block_length)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$max_record_length =
            IF header^.attribute_present [fmc$max_record_length] THEN
              NEXT static_label_item: [fmc$max_record_length] IN static_label;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (static_label_item^.integer_value)) OR (static_label_item^.
                    integer_value > UPPERVALUE (static_label_item^.
                    integer_value)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$min_block_length =
            IF header^.attribute_present [fmc$min_block_length] THEN
              NEXT static_label_item: [fmc$min_block_length] IN static_label;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (static_label_item^.integer_value)) OR (static_label_item^.
                    integer_value > UPPERVALUE (static_label_item^.
                    integer_value)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$min_record_length =
            IF header^.attribute_present [fmc$min_record_length] THEN
              NEXT static_label_item: [fmc$min_record_length] IN static_label;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (static_label_item^.integer_value)) OR (static_label_item^.
                    integer_value > UPPERVALUE (static_label_item^.
                    integer_value)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$padding_character =
            IF header^.attribute_present [fmc$padding_character] THEN
              NEXT static_label_item: [fmc$padding_character] IN static_label;
              IF (static_label_item^.padding_character < LOWERVALUE
                    (static_label_item^.padding_character)) OR
                    (static_label_item^.padding_character > UPPERVALUE
                    (static_label_item^.padding_character)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$page_format =
            IF header^.attribute_present [fmc$page_format] THEN
              NEXT static_label_item: [fmc$page_format] IN static_label;
              IF (static_label_item^.page_format < LOWERVALUE
                    (amt$page_format)) OR (static_label_item^.page_format >
                    UPPERVALUE (amt$page_format)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$page_length =
            IF header^.attribute_present [fmc$page_length] THEN
              NEXT static_label_item: [fmc$page_length] IN static_label;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (static_label_item^.integer_value)) OR (static_label_item^.
                    integer_value > UPPERVALUE (static_label_item^.
                    integer_value)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$page_width =
            IF header^.attribute_present [fmc$page_width] THEN
              NEXT static_label_item: [fmc$page_width] IN static_label;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (static_label_item^.integer_value)) OR (static_label_item^.
                    integer_value > UPPERVALUE (static_label_item^.
                    integer_value)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$preset_value =
            IF header^.attribute_present [fmc$preset_value] THEN
              NEXT static_label_item: [fmc$preset_value] IN static_label;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (static_label_item^.integer_value)) OR (static_label_item^.
                    integer_value > UPPERVALUE (static_label_item^.
                    integer_value)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$record_type =
            IF header^.attribute_present [fmc$record_type] THEN
              NEXT static_label_item: [fmc$record_type] IN static_label;
              IF (static_label_item^.record_type < LOWERVALUE
                    (amt$record_type)) OR (static_label_item^.record_type >
                    UPPERVALUE (amt$record_type)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$statement_identifier =
            IF header^.attribute_present [fmc$statement_identifier] THEN
              NEXT static_label_item: [fmc$statement_identifier] IN
                    static_label;
              IF ((static_label_item^.statement_identifier.length < LOWERVALUE
                    (amt$statement_id_length)) OR (static_label_item^.
                    statement_identifier.length > UPPERVALUE
                    (amt$statement_id_length)) OR (static_label_item^.
                    statement_identifier.location < LOWERVALUE
                    (amt$statement_id_location)) OR (static_label_item^.
                    statement_identifier.location > UPPERVALUE
                    (amt$statement_id_location))) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$user_info =
            IF header^.attribute_present [fmc$user_info] THEN
              NEXT static_label_item: [fmc$user_info] IN static_label;
              IF static_label_item^.user_info_present THEN
                NEXT str: [32] IN static_label;
              IFEND;
            IFEND;
          = fmc$vertical_print_density =
            IF header^.attribute_present [fmc$vertical_print_density] THEN
              NEXT static_label_item: [fmc$vertical_print_density] IN
                    static_label;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (static_label_item^.integer_value)) OR (static_label_item^.
                    integer_value > UPPERVALUE (static_label_item^.
                    integer_value)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$average_record_length =
            IF header^.attribute_present [fmc$average_record_length] THEN
              NEXT static_label_item: [fmc$average_record_length] IN
                    static_label;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (static_label_item^.integer_value)) OR (static_label_item^.
                    integer_value > UPPERVALUE (static_label_item^.
                    integer_value)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$collate_table =
            IF header^.attribute_present [fmc$collate_table] THEN
              NEXT static_label_item: [fmc$collate_table] IN static_label;
            IFEND;
          = fmc$collate_table_name =
            IF header^.attribute_present [fmc$collate_table_name] THEN
              NEXT static_label_item: [fmc$collate_table_name] IN static_label;
              get_entry_point_reference (collate_table_name, ignore_path);
              IF collate_table_name <> osc$null_name THEN
                clp$validate_name (collate_table_name, validated_name,
                      attributes_are_compatible);
              IFEND;
            IFEND;
          = fmc$compression_procedure_name =
            IF header^.attribute_present [fmc$compression_procedure_name] THEN
              attributes_are_compatible := FALSE;
            IFEND;
          = fmc$data_padding =
            IF header^.attribute_present [fmc$data_padding] THEN
              NEXT static_label_item: [fmc$data_padding] IN static_label;
              IF (static_label_item^.data_padding < LOWERVALUE
                    (amt$data_padding)) OR (static_label_item^.data_padding >
                    UPPERVALUE (amt$data_padding)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$dynamic_home_block_space =
            IF header^.attribute_present [fmc$dynamic_home_block_space] THEN
              attributes_are_compatible := FALSE;
            IFEND;
          = fmc$embedded_key =
            IF header^.attribute_present [fmc$embedded_key] THEN
              NEXT static_label_item: [fmc$embedded_key] IN static_label;
              IF (static_label_item^.embedded_key < LOWERVALUE (boolean)) OR
                    (static_label_item^.embedded_key > UPPERVALUE (boolean))
                    THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$estimated_record_count =
            IF header^.attribute_present [fmc$estimated_record_count] THEN
              NEXT static_label_item: [fmc$estimated_record_count] IN
                    static_label;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (static_label_item^.integer_value)) OR (static_label_item^.
                    integer_value > UPPERVALUE (static_label_item^.
                    integer_value)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$hashing_procedure_name =
            IF header^.attribute_present [fmc$hashing_procedure_name] THEN
              attributes_are_compatible := FALSE;
            IFEND;
          = fmc$index_levels =
            IF header^.attribute_present [fmc$index_levels] THEN
              NEXT static_label_item: [fmc$index_levels] IN static_label;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (static_label_item^.integer_value)) OR (static_label_item^.
                    integer_value > UPPERVALUE (static_label_item^.
                    integer_value)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$index_padding =
            IF header^.attribute_present [fmc$index_padding] THEN
              NEXT static_label_item: [fmc$index_padding] IN static_label;
              IF (static_label_item^.index_padding < LOWERVALUE
                    (amt$index_padding)) OR (static_label_item^.index_padding >
                    UPPERVALUE (amt$index_padding)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$initial_home_block_count =
            IF header^.attribute_present [fmc$initial_home_block_count] THEN
              attributes_are_compatible := FALSE;
            IFEND;
          = fmc$key_length =
            IF header^.attribute_present [fmc$key_length] THEN
              NEXT static_label_item: [fmc$key_length] IN static_label;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (static_label_item^.integer_value)) OR (static_label_item^.
                    integer_value > UPPERVALUE (static_label_item^.
                    integer_value)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$key_position =
            IF header^.attribute_present [fmc$key_position] THEN
              NEXT static_label_item: [fmc$key_position] IN static_label;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (static_label_item^.integer_value)) OR (static_label_item^.
                    integer_value > UPPERVALUE (static_label_item^.
                    integer_value)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$key_type =
            IF header^.attribute_present [fmc$key_type] THEN
              NEXT static_label_item: [fmc$key_type] IN static_label;
              IF (static_label_item^.key_type < LOWERVALUE (amt$key_type)) OR
                    (static_label_item^.key_type > UPPERVALUE (amt$key_type))
                    THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$loading_factor =
            IF header^.attribute_present [fmc$loading_factor] THEN
              attributes_are_compatible := FALSE;
            IFEND;
          = fmc$lock_expiration_time =
            IF header^.attribute_present [fmc$lock_expiration_time] THEN
              attributes_are_compatible := FALSE;
            IFEND;
          = fmc$logging_options =
            IF header^.attribute_present [fmc$logging_options] THEN
              attributes_are_compatible := FALSE;
            IFEND;
          = fmc$log_residence =
            IF header^.attribute_present [fmc$log_residence] THEN
              attributes_are_compatible := FALSE;
            IFEND;
          = fmc$record_limit =
            IF header^.attribute_present [fmc$record_limit] THEN
              NEXT static_label_item: [fmc$record_limit] IN static_label;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (static_label_item^.integer_value)) OR (static_label_item^.
                    integer_value > UPPERVALUE (static_label_item^.
                    integer_value)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          = fmc$records_per_block =
            IF header^.attribute_present [fmc$records_per_block] THEN
              NEXT static_label_item: [fmc$records_per_block] IN static_label;
              IF (static_label_item^.integer_value < LOWERVALUE
                    (static_label_item^.integer_value)) OR (static_label_item^.
                    integer_value > UPPERVALUE (static_label_item^.
                    integer_value)) THEN
                attributes_are_compatible := FALSE;
              IFEND;
            IFEND;
          ELSE
            attributes_are_compatible := FALSE;
          CASEND;
          attribute_key := attribute_key + 1;
        WHILEND;
      IFEND;
    IFEND;

  PROCEND srp$validate_attributes;

MODEND srm$validate_compatibility;
*DECK DECK=SRP$COMPUTE_LABEL_CHECKSUM EXPAND=FALSE

  PROCEDURE [XREF] srp$compute_label_checksum
    (    label_checksum_location: pft$checksum_location;
         label_checksum_size: pft$checksum_size;
     VAR label_checksum: pft$checksum);

?? PUSH (LISTEXT := ON) ??
*copyc pft$checksum
?? POP ??

*DECK DECK=SRP$FETCH_SYSTEM_LABEL EXPAND=FALSE

{ COMMON DECK SRXFSL }

  PROCEDURE [XREF] srp$fetch_system_label (local_file_name:
    amt$local_file_name;
    VAR label: SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc AMT$LOCAL_FILE_NAME
?? POP ??
*DECK DECK=SRP$FETCH_SYSTEM_LABEL_SIZE EXPAND=FALSE
{ COMMON DECK SRXFSLS}

  PROCEDURE [XREF] srp$fetch_system_label_size (local_file_name:
    amt$local_file_name;
    VAR label_size: 0 .. 7fffffff(16);
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc AMT$LOCAL_FILE_NAME
*copyc OST$STATUS
?? POP ??
*DECK DECK=SRP$GET_V1_LABEL EXPAND=FALSE

  PROCEDURE [XREF] srp$get_v1_label (local_file_name: amt$local_file_name;
        old_label: SEQ ( * );
    VAR v1_label: ^SEQ ( * );
    VAR v1_label_allocated: boolean;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ost$status
?? POP ??

*DECK DECK=SRP$RESTORE_LABEL EXPAND=FALSE

  PROCEDURE [XREF] srp$restore_label (local_file_name: amt$local_file_name;
        label: SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc amt$local_file_name
*copyc ost$status
?? POP ??

*DECK DECK=SRP$STORE_SYSTEM_LABEL EXPAND=FALSE

{ COMMON DECK SRXSSL }

  PROCEDURE [XREF] srp$store_system_label
    (   local_file_name: amt$local_file_name;
        label: SEQ ( * );
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ame$attribute_validation_errors
*copyc ame$ring_validation_errors
*copyc amt$local_file_name
*copyc fme$file_management_errors
*copyc ost$status
?? POP ??
*DECK DECK=SRP$VALIDATE_COMPATIBILITY EXPAND=FALSE

  PROCEDURE [XREF] srp$validate_compatibility (p_file_label:
        fmt$p_file_label;
        p_file_label_header: ^fmt$static_label_header;
        local_file_name: amt$local_file_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$file_label
*copyc fmt$static_label_header
*copyc amt$local_file_name
*copyc ost$status
?? POP ??
*DECK DECK=SRV$STATIC_LABEL_ATTRIBUTES EXPAND=FALSE

  VAR
    srv$static_label_attributes: [XREF, READ]
      fmt$basic_file_label;

?? PUSH (LISTEXT := ON) ??
*copyc fmt$basic_file_label
?? POP ??
*DECK DECK=SSR_DATA_70 EXPAND=FALSE

  TYPE
    ssr_data = SEQ (REP 1 of ssr_area);
*DECK DECK=STC$ARRAY_LOWERBOUND EXPAND=FALSE

  {deck id STDLOW }
  CONST
    stc$array_lowerbound = 1;
*DECK DECK=STC$MAX_NUM_MEMBERS_ON_SET EXPAND=FALSE

  {deck is STDCMAX }
  CONST
    stc$max_num_members_on_set = 400;
*DECK DECK=STD$ACTIVE_SET_TABLE EXPAND=FALSE

{deck is STDAST }

  TYPE
    { Active Set Table. This is the primary set management table. }
    { This will live in the system heap. The member entry list for each }
    { set is also allocated in the system heap. }
    stt$p_active_set_table = ^stt$active_set_table,
    stt$active_set_table = record
      table: array [ * ] of stt$active_set_entry,
    recend,
    stt$ast_index = 0 .. 0ffff(16),
    stt$active_set_entry = record
      case entry_type: stt$entry_type of
      = stc$unused =
        ,
      = stc$valid =
        set_name: stt$set_name,
        unique_set_name: stt$unique_set_name,
        master_vsn: rmt$recorded_vsn,
        master_internal_vsn: dmt$internal_vsn,
        p_member_entry_list: stt$p_member_entry_list,
        access_status: stt$access_status,
        number_of_jobs_using_set: integer,
        case master_ever_up: boolean of
        = TRUE =
          set_owner: ost$user_identification,
          master_dm_packet_storage: stt$dm_packet_storage,
          master_volume_activity: stt$volume_activity_descriptor,
          pf_lock: ost$signature_lock,
          case pf_root_ever_stored: boolean of
          = TRUE =
            pf_root_size: pft$root_size,
            p_pf_root: ^pft$root,
          = FALSE =
            ,
          casend,
        = FALSE =
          ,
        casend,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc DMT$INTERNAL_VSN
*copyc ost$signature_lock
*copyc STT$VOLUME_ACTIVITY_DESCRIPTOR
*copyc STT$DM_PACKET_STORAGE
*copyc OST$USER_IDENTIFICATION
*copyc RMD$VOLUME_DECLARATIONS
*copyc STD$MISCELLANEOUS
*copyc OST$NAME
*copyc PFD$ROOT
*copyc STD$MEMBER_ENTRY_LIST
?? POP ??
{end deck STDAST }
*DECK DECK=STD$JOB_ACTIVE_SET_TABLE EXPAND=FALSE

{deck is STDJAST }

  TYPE
    {Job Active Set Table. This lives in the job pageable heap.
    stt$p_job_active_set_table = ^stt$job_active_set_table,
    stt$jast_index = integer,
    stt$job_active_set_table = record
      table: array [ * ] of stt$job_active_set_entry,
    recend,
    stt$job_active_set_entry = record
      case entry_type: stt$entry_type of
      = stc$valid =
        set_name: stt$set_name,
        unique_set_name: stt$unique_set_name,
        ast_index: stt$ast_index,
      = stc$unused =
        ,
      casend,
    recend;

*copyc STD$ACTIVE_SET_TABLE
*copyc STD$MISCELLANEOUS
{end deck STDJAST }
*DECK DECK=STD$LOCATORS EXPAND=FALSE

  TYPE
    stt$adaptable_array_locator = record
      array_size: 0 .. 0ffffffff(16),
      relative_cell_pointer: stt$relative_cell_pointer,
    recend,

    stt$sequence_locator = record
      length: 0 .. 7fffffff(16),
      relative_cell_pointer: stt$relative_cell_pointer,
    recend;


  TYPE
    stt$relative_cell_pointer = rel (stt$vol_set_table) ^cell;


  TYPE
    stt$sequence_record = record
      sequence: stt$sequence,
    recend,

    stt$p_sequence_record = ^stt$sequence_record,

    stt$sequence = SEQ (REP 7fffffff(16) of cell),

    stt$p_sequence = ^stt$sequence;

?? PUSH (LISTEXT := ON) ??
*copyc STD$VOLUME_SET_TABLE
?? POP ??
*DECK DECK=STD$MEMBER_ENTRY_LIST EXPAND=FALSE

{deck is STDMEL }

  TYPE
    {This is allocated in the system heap. }
    stt$p_member_entry_list = ^stt$member_entry_list,
    stt$mel_index = integer,
    stt$member_entry_list = array [ * ] of stt$member_entry,
    stt$member_entry = record
      case entry_type: stt$entry_type of
      = stc$valid =
        member_vsn: rmt$recorded_vsn,
        member_internal_vsn: dmt$internal_vsn,
        member_dm_packet_storage: stt$dm_packet_storage,
        member_volume_activity: stt$volume_activity_descriptor,
      = stc$unused =
         ,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc DMT$INTERNAL_VSN
*copyc STT$DM_PACKET_STORAGE
*copyc STT$VOLUME_ACTIVITY_DESCRIPTOR
?? POP ??
{end deck STDMEL }
*DECK DECK=STD$MISCELLANEOUS EXPAND=FALSE
{ deck is STDSET      }

  CONST
    stc$set_management_id = 'SE';

  { Set Management internal product identifier. }

  TYPE
    stt$access_status = (stc$allow_access, stc$deny_access);

  TYPE
    stt$vol_status_in_set = (stc$member_vol, stc$master_vol);

  TYPE
    stt$vol_activity_status = (stc$active, stc$inactive);

  TYPE
    stt$entry_type = (stc$valid, stc$unused);

   TYPE
     stt$number_of_sets = 0 .. stc$max_number_of_sets;

   CONST
     stc$max_number_of_sets = 7fffffff(16);

*copyc STD$SET_NAME
{ end deck STDSET  }
*DECK DECK=STD$SET_NAME EXPAND=FALSE


{ deck is  STDNAME                                                         }

  TYPE
    stt$set_name = ost$name,
    stt$unique_set_name = ost$binary_unique_name;

?? PUSH (LISTEXT := ON) ??
*copyc OST$NAME
*copyc OSD$UNIQUE_NAME
?? POP ??
{ end deck STDNAME }
*DECK DECK=STD$VOLUME_SET_TABLE EXPAND=FALSE

{deck is STDVST }

  TYPE
    { Volume Set Table. There is one on each volume. }
    { The member vsn list will be allocated as an adaptable array, by }
    { using a pointer to an adaptable array of stt$member_vsn_entry s. }
    stt$p_vol_set_table = ^stt$vol_set_table,
    stt$vol_set_table = record
      data_being_modified: string (5),
      version_name: ost$name,
      vsn: rmt$recorded_vsn,
      internal_vsn: dmt$internal_vsn,
      case entry_type: stt$entry_type of
      = stc$valid =
        set_name: stt$set_name,
        unique_set_name: stt$unique_set_name,
        case vol_status_in_set: stt$vol_status_in_set of
        = stc$member_vol =
          master_vsn: rmt$recorded_vsn,
          master_internal_vsn: dmt$internal_vsn,
        = stc$master_vol =
          set_owner: ost$user_identification,
          master_dm_packet_storage: stt$dm_packet_storage,
          member_vsn_list_locator: stt$member_list_locator,
          pf_root_storage: stt$vst_pf_root_storage,
          root_recreated: string (1),
          vst_heap: ALIGNED [0 MOD 32] ost$heap,
        casend,
      = stc$unused =
        ,
      casend,
    recend;

  CONST
    stc$root_recreated = 'T',
    stc$root_not_recreated = 'F';

  TYPE
    stt$p_member_vsn_list = ^array [ * ] of stt$member_vsn_entry,
    stt$mvl_index = 1 .. stc$max_num_members_on_set,
    stt$member_vsn_entry = record
      case entry_type: stt$entry_type of
      = stc$valid =
        member_vsn: rmt$recorded_vsn,
        member_internal_vsn: dmt$internal_vsn,
        member_dm_packet_storage: stt$dm_packet_storage,
      = stc$unused =
        ,
      casend,
    recend;

  TYPE
    stt$member_list_locator = stt$adaptable_array_locator,
    stt$pf_root_locator = stt$sequence_locator;

  TYPE
    stt$vst_pf_root_storage = record
      case pf_root_ever_stored: boolean of
      = TRUE =
        pf_root_size: pft$root_size,
        pf_root_locator: stt$pf_root_locator,
      = FALSE =
        ,
      casend,
    recend;

  CONST
    stc$current_vst_version_name = 'VOL_SET_TABLE_VERSION_001      ';

  CONST
    stc$maximum_vst_size = 4000(16);



?? PUSH (LISTEXT := ON) ??
*copyc OST$USER_IDENTIFICATION
*copyc STD$LOCATORS
*copyc DMT$INTERNAL_VSN
*copyc STT$DM_PACKET_STORAGE
*copyc STD$MISCELLANEOUS
*copyc STC$MAX_NUM_MEMBERS_ON_SET
*copyc RMD$VOLUME_DECLARATIONS
*copyc PFD$ROOT
*copyc OST$HEAP
?? POP ??
{end deck STDVST }
*DECK DECK=STE$ERROR_CONDITION_CODES EXPAND=FALSE
{  PURPOSE:
{    This common deck has all the set error conditions, and messages.
{
  CONST
    stc$null_parameter = '',

*IF $true(osv$unix)
    stc$st_errors = (($INTEGER ('S') * 100(16)) + $INTEGER ('E')) * 10000(16),
*ELSE
    stc$st_errors = (($INTEGER ('S') * 100(16)) + $INTEGER ('E')) * 1000000(16),
*IFEND

    ste$bad_set_name = stc$st_errors + 0,
    {E Set name parameter "+P1" is improper.}

    ste$bad_master_vol_desc = stc$st_errors + 1,
    {E Master-volume VSN parameter "+P1" is improper.}

    ste$bad_member_vol_desc = stc$st_errors + 2,
    {E Member-volume VSN parameter "+P1" is improper.}

    ste$bad_set_owner = stc$st_errors + 3,
    {E Either user "+P1" or family "+P2" parameter is improper.}

    ste$bad_access_status = stc$st_errors + 4,
    {E The ACCESS-STATUS parameter is improper.}

    ste$master_belongs_to_set = stc$st_errors + 5,
    {E Master volume "+P1" already belongs to another set.}

    ste$set_already_active = stc$st_errors + 6,
    {E Set name "+P1" is already active.}

    ste$set_not_master_owner = stc$st_errors + 7,
    {E User "+P1" of family "+P2" does not own master volume "+P3" ..
    { of set "+P4".}

    ste$exceeded_max_num_vol = stc$st_errors + 8,
    {E Set "+P1" is full. Volume "+P2" was not added.}

    ste$bad_unique_member = stc$st_errors + 9,
    {E The unique set name for volume "+P1" does not match that ..
    { in the active set table.}

    ste$set_not_member_owner = stc$st_errors + 10,
    {E User "+P1" of family "+P2" does not own set "+P3" and cannot ..
    { assign a member to it.}

    ste$vol_on_set = stc$st_errors + 11,
    {E There are still volume(s) assigned to set "+P1".}

    ste$wrong_master = stc$st_errors + 12,
    {E Volume "+P1" is not the master volume of set "+P2".}

    ste$master_not_active = stc$st_errors + 13,
    {E The master volume "+P1" of set "+P2" is not active.}

    ste$job_not_member_owner = stc$st_errors + 14,
    {E User "+P1" of family "+P2" does not own member volume "+P3".}

    ste$wrong_set_given = stc$st_errors + 15,
    {E Volume "+P1" is listed as being assigned to set "+P2", not ..
    { to set "+P3".}

    ste$vol_not_in_set = stc$st_errors + 16,
    {E Volume "+P1" is not assigned to set "+P2".}

    ste$diff_unique_set_active = stc$st_errors + 17,
    {E Volume "+P1" has the same set-name as active set "+P2"; ..
    { but it has a different unique-set-name.}

    ste$mel_mvl_mismatch = stc$st_errors + 18,
    {E System Error: Volume "+P1" is listed in set "+P2"; but was not ..
    { found in the master volume-set-table.}

    ste$set_not_active = stc$st_errors + 19,
    {E The set is not active.}
    stc$set_not_active_cond = stc$st_errors + 19,

    ste$set_not_job_owner = stc$st_errors + 20,
    {E User "+P1" of family "+P2" is not the owner or administrator ..
    { of set "+P3".}

    ste$member_not_in_master = stc$st_errors + 21,
    {E Volume "+P1" was not found in the member volume list ..
    { of set "+P2".}

    ste$bad_mel_generated = stc$st_errors + 22,
    {E System error: Volume "+P1" was not found in the ..
    { active set table member-list of set "+P2" (and the ..
    { master volume has been active).}

    ste$not_allowing_access = stc$st_errors + 23,
    {E Access to set "+P1" is not allowed.}

    ste$jast_ast_mismatch = stc$st_errors + 24,
    {E Set "+P1" was found in the job's active-set-table; but not ..
    { in the system active-set-table.}

    ste$jobs_on_set = stc$st_errors + 25,
    {E There are still job(s) registered in the master catalog ..
    { of set "+P1".}

    ste$master_ast_mismatch = stc$st_errors + 26,
    {E Master volume "+P1" unique set name does not match ..
    { the unique set name in the active set table.}

    ste$users_on_set = stc$st_errors + 27,
    {E There are still user(s) registered in the master catalog ..
    { of set "+P1".}

    ste$files_on_vol = stc$st_errors + 28,
    {E Volume "+P1" still contains file(s).}

    ste$down_vol_used = stc$st_errors + 29,
    {E System error: Volume "+P1" of set "+P2" was deactivated ..
    { while the set was still in use, and the remount attempt ..
    { failed.}

    ste$dm_ast_mismatch = stc$st_errors + 30,
    {E System error: The unique-set-name of volume "+P1" ..
    { cannot be found in the active set table.}

    ste$dm_mel_mismatch = stc$st_errors + 31,
    {E System error: Volume "+P1", maintained by device management, ..
    { cannot be found by set management in set "+P2".}

    ste$member_not_active = stc$st_errors + 32,
    {E Member volume "+P1" is not active.}

    ste$no_space_vst_heap = stc$st_errors + 33,
    {E System error: There is no space left in the heap of volume "+P1".}

    ste$member_vol_in_set = stc$st_errors + 34,
    {E Volume "+P1" is already assigned to a set.}

    ste$member_not_in_mel = stc$st_errors + 35,
    {E System error: Volume "+P1" is not in the member-entry-list ..
    { of set "+P2".}

    ste$push_failed = stc$st_errors + 36,
    {E System error: Push failed. Size = "+P2" .}

    ste$set_ord_not_set = stc$st_errors + 37,
    {E The set ordinal is not valid.}

    ste$no_scratch_volumes = stc$st_errors + 38,
    {E There are no scratch volumes available. }

    ste$vol_not_found = stc$st_errors + 39,
    {E Volume "+P1" was not found in the active set table.}

    ste$open_error = stc$st_errors + 40,
    {E Device file for volume "+P1" cannot be opened.}

    ste$attach_error = stc$st_errors + 41,
    {E The device file for volume "+P1" cannot be attached.}

    ste$vst_exists_not_in_set = stc$st_errors + 42,
    {E System error: Volume "+P1" has a volume set table; ..
    { but it is not assigned to any set.}

    ste$ast_vst_master_mis = stc$st_errors + 43,
    {E Volume "+P1" lists the master volume of set "+P2" as ..
    { "+P3" when the active set table lists it as "+P4".}

    ste$internal_vsn_mismatch = stc$st_errors + 44,
    {E The internal VSN of volume "+P1" does not match ..
    { that in the set table.}

    ste$pf_root_not_stored = stc$st_errors + 45,
    {E The permanent file root for set "+P1" was not stored.}

    ste$incorrect_root_size = stc$st_errors + 46,
    {E The size of the permanent file root of set "+P1" does not ..
    { match the recorded size.}

    ste$lock_set_in_task = stc$st_errors + 47,
    {E System error: Set "+P1" already has the permanent file lock set.}

    ste$lock_not_set = stc$st_errors + 48,
    {E System error: An attempt was made to clear an unset permanent file ..
    { lock on set "+P1".}

    ste$dm_avt_index_mismatch = stc$st_errors + 49,
    {E System error: Device management could not store the set ordinal ..
    { for volume "+P1" because of avt index mismatch.}

    ste$impossible_to_mount = stc$st_errors + 50,
    {E It is not possible to mount volume "+P1".}

    ste$lock_set_in_another_task = stc$st_errors + 51,
    {E The permanent file lock for set "+P1" is busy.}

    ste$attach_df_error = stc$st_errors + 52,
    {E The device file for volume "+P1" cannot be attached.}

    ste$incompatible_vst_version = stc$st_errors + 53,
    {E The volume set table recorded on volume "+P1" is incompatible with
    { the current system (recorded version: "+P2", current version: "+P3").

    ste$vol_set_table_lost_data = stc$st_errors + 54,
    {E The volume set table on volume "+P1" has lost data integrity, and
    { cannot be used.}

     ste$all_volumes_not_active = stc$st_errors + 55,
     {E Not all volumes active. +P1 +P2 }

     ste$improper_recorded_vsn = stc$st_errors + 56,
     {E Improper recorded vsn.  All characters must be alphanumeric.

     ste$duplicate_master_initdd = stc$st_errors + 57,
     {E Volume +P1 has been re-initialized as the master of set +P2, but
     { volume +P3 is already the master.
     {+N3 Either INITIALIZE_MS_VOLUME the old master volume +P3, OR
     {+N5 INITIALIZE_DEADSTART_DEVICE the old master +P3 with
     { RECOVER_SYSTEM_SET, and INITIALIZE_MS_VOLUME the new master +P1.

     ste$remove_master_volume = stc$st_errors + 58,
     {E Volume +P1 is the master volume of set +P2 and cannot be removed.}

     ste$quit_lcu = stc$st_errors + 59;
     {E Unable to activate set while LCU is active.}

  CONST

    stc$space_unavailable_ast = 'There is no space for the active set table.',
    stc$space_unavailable_jast = 'There is no space for the job set table.';
*DECK DECK=STH$ACTIVE_SET_TABLE EXPAND=FALSE
{
{  ACTIVE_SET_TABLE   (AST)
{
{  PURPOSE:
{    The active set table maintains information about all sets
{    with at least one volume active.
{  WHEN ACCESSED:
{    ALL accessing is done by the Set Manager.
{    MODIFIED
{    -  When sets are created, or purged, or volumes added too or
{       removed from sets, the change is reflected here.
{    -  The permanent file root catalog locator is stored in the
{       AST, as well as a lock for the permanent file root.
{    -  When volumes become active or inactive the AST is updated.
{    READ
{    -  The pf root is returned to permanent files.
{    -  Information is returned to device management when requested
{       on assigning volumes.
{  LAYOUT:
{    The AST is an adaptable array.
{  PRIMARY KEY:
{    set name
{  RESIDENCY:
{    A pointer to the AST (stv$p_ast) is a static ring 1 variable.
{    The table is allocated in the mainframe pageable heap.
{    All reading or writing occurs in ring 1.
{  LOCKING:
{    A global exclusive interlock to this table is maintained as
{    a ring 1 static variable.
{  FIELDS:
{    stt$active_set_entry = record
{      case entry_type
{      = stc$valid =
{        set_name: The name of the active set.
{        unique_set_name: The unique name of the active set.
{        master_vsn: The name of the master volume of the set.
{        master_internal_vsn
{        p_member_entry_list: This is a pointer to a list of members
{              in the set.  Reference decks stdmel, sthmel.
{        access_status: This indicates whether to allow access to
{              the set for permanent file operations.
{        number_of_jobs_using_set: This is the number of jobs
{              doing permanent file operations on this set.
{        case master_ever_up:  This indicates whether the master
{              has ever been active since this active set entry
{              was established.  The only way this could be FALSE
{              was if a member volume was the first volume active
{              in the set.
{        = TRUE =
{          set_owner: The name of the owner of the set
{          master_dm_packet_storage: This indicates whether the
{                dm_packet has ever been stored for the master.
{          master_volume_activity: This indicates whether the
{                master volume of the set is currently active.
{                If it is active the avt_index is maintained.
{          pf_lock: A lock set/ cleared by requests from PF.
{          case pf_root_ever_stored: Has the PF ROOT ever been
{                stored since the set was created.
{          = TRUE =
{            pf_root_size: The size in bytes of the root locator.
{            p_pf_root: a pointer to the pf root.  Assumed to be
{                  an adaptable sequence.
{
*DECK DECK=STH$ADD_MEMBER_IN_AST EXPAND=FALSE
{
{   This procedure  manages  adding  a  member into the active set table for a
{ particular set.  The  set  must  must  have  already  been  located  and  is
{ specified  by  the  ast_index  parameter.  This routine gets an unused entry
{ into the member entry list for the set, and then stores the fields into  the
{ new  entry.   All  fields  will  be  initialized  by this procedure, and are
{ indicated by the input parameters.
{
{       STP$ADD_MEMBER_IN_AST (MEMBER_VOL, MEMBER_INTERNAL_VSN,
{         MEMBERS_ACTIVITY, MEMBERS_AVT_INDEX, AST_INDEX, DM_PACKET_STORAGE,
{         STATUS)
{
{ MEMBER_VOL: (input) This parameter specifies the  name  of  the  new  member
{       volume.
{
{ MEMBER_INTERNAL_VSN:  (input)  This parameter specifies the internal vsn for
{       the member volume.
{
{ MEMBERS_ACTIVITY: (input) This parameter specifies whether the member volume
{       is  active  (stc$active)  or  not  (stc$inactive).   If stc$active the
{       MEMBERS_AVT_INDEX parameter should be initialized.
{
{ MEMBERS_AVT_INDEX: (input) This parameter specifies the member volumes index
{       into the device management active volume table.
{
{ AST_INDEX:  (input) This parameter specifies the set for which the member is
{       being added.  This is assumed to be a valid index.
{
{ DM_PACKET_STORAGE: (input) This parameter specifies  the  device  management
{       storage record for this volume.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ose$mainframe_pageable_full
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$ADD_MEMBER_IN_MASTER_VST EXPAND=FALSE
{
{   The purpose  of  this  procedure  is  to add a member volume in the master
{ volume set table.  The master is assumed open, and  no  validation  is  done
{ here, except to see if the maximum number of volumes has been exceeded.
{
{       STP$ADD_MEMBER_IN_MASTER_VST (P_MASTER_VST, MEMBER_VOL,
{         MEMBER_INTERNAL_VSN, DM_PACKET_STORAGE, STATUS)
{
{ P_MASTER_VST: (input) This is the pointer to the master  volume  set  table.
{       Although the pointer is not modified, the table is.
{
{ MEMBER_VOL: (input) This specifies the name of the member volume to be added
{       into the master volume set table.  No check is done  to  determine  if
{       the member is already in the master.
{
{ MEMBER_INTERNAL_VSN:  (input)  This is the internal (unique) name of the new
{       member.
{
{ DM_PACKET_STORAGE: (input) This parameter specifies  the  device  management
{       packet storage for this volume.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$exceeded_max_num_vol
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$ADD_MEMBER_VOL_TO_SET EXPAND=FALSE
{
{   The purpose of this request is to add a member volume to a set.  The set
{ must have already been created on the master volume by the STP$CREATE_SET
{ request (INITIALIZE_DEADSTART_DEVICE command), and this member volume must have
{ been initialized using the INITIALIZE_MS_VOLUME request.
{   The member can belong to no other set, and the
{ volume will remain a member of the set until a STP$REMOVE_MEMBER_VOL_FROM_SET
{ is issued or until the device is inactive at deadstart and a
{ stp$remove_inactive_members is issued.  The member volume may not already be
{ registered in the master volume of the set.
{   This request will cause both the member volume and
{ master volume to be activated, and the master volume will be updated to
{ reflect this new member.  This request can only be issued by the system
{ administrator, or volume owner.  The member volume owner must also own
{ the master volume.
{    If a member, as defined by its own member volume set table (on disk),
{ is already registered as a part of the set via a previous ADD_VOLUME_SET_SET,
{ but the member is not registered in the master volume (as a result of an
{ INITIALIZE_DEADSTART_DEVICE with the RECOVER_SYSTEM_SET_PARAMETER), the
{ master volume will be updated to reflect this member, and the member
{ volume will be updated to reflect the new unique identification of the
{ set, and the set master.  If the member is registered as part of the current set,
{ and the identification is recorded in the master, this request is unneeded and
{ an error status will be returned.  If the member volume is registered as a
{ member of another set (as indicated by external set name), an error status
{ will be returned.
{
{       STP$ADD_MEMBER_VOL_TO_SET (SET_NAME, REQUESTED_MEMBER_VOL,
{         STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set
{       that the volume is to be added to.
{
{ REQUESTED_MEMBER_VOL: (input) This parameter specifies the recorded vsn
{       of the volume that is to be added to the set.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDTITIONS: ste$bad_master_vol
{                     ste$bad_member_vol
{                     ste$bad_set_name
{                     ste$set_not_member_owner
{                     ste$wrong_master
{                     ste$master_not_active
{                     ste$member_not_active
{                     ste$member_vol_in_set
{                     ste$job_not_member_owner
{                        OTHERS
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$ATTACH_VST EXPAND=FALSE
{
{   The purpose  of this procedure is to attach the device file for the volume
{ set table.
{
{       STP$ATTACH_VST (VSN, SFID, STATUS)
{
{ VSN: (input) This parameter specifies the volume on  which  the  volume  set
{       table device file is to be attached.
{
{ SFID: (output)  This  parameter  returns  the  system file identifier of the
{       device file for the volume set table.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$vol_not_in_set (no device file)
{                   ste$attach_df_error
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$BUILD_MEMBER_LIST_LOCATOR EXPAND=FALSE
{
{   The purpose  of  this  request is to translate a pointer to the member vsn
{ list (of the master volume set table) into a locator.  This locator does not
{ include  the segment number and cannot be referenced directly.  This locator
{ may be used later to construct a pointer to the  member  list  that  can  be
{ referenced.   Thus  if a volume set table is opened, closed, and then opened
{ again it will have a different segment number, and if  the  pointer  to  the
{ member  list was stored it would have the wrong segment number and could not
{ be referenced.
{
{       STP$BUILD_MEMBER_LIST_LOCATOR (P_MEMBER_LIST, P_VOL_SET_TABLE,
{         MEMBER_LIST_LOCATOR)
{
{ P_MEMBER_LIST: (input) This parameter specifies the pointer  to  the  member
{       vsn list.  This value may be NIL.
{
{ P_VOL_SET_TABLE: (input) This parameter specifies the pointer to the
{      volume set table in which the member list was allocated in.
{
{ MEMBER_LIST_LOCATOR:  (output)  This  parameter  returns  the locator to the
{       member vsn list.  This locator  can  be  used  later  to  construct  a
{       pointer using the stp$build_member_list_pointer request.
{
*DECK DECK=STH$BUILD_MEMBER_LIST_POINTER EXPAND=FALSE
{
{   The purpose  of  this request is to translate a member list locator into a
{ pointer.  This pointer can then be used to reference the member list in  the
{ master  volume  set  table.   A  base pointer (p_vol_set_table) must also be
{ provided from which the segment number is taken.
{
{       STP$BUILD_MEMBER_LIST_POINTER (MEMBER_LIST_LOCATOR, P_VOL_SET_TABLE,
{         P_MEMBER_LIST)
{
{ MEMBER_LIST_LOCATOR:  (input)  This  parameter  specifies  the  member  list
{       locator.   This  must  previously  have  been  constructed  using  the
{       stp$build_member_list_locator request.
{
{ P_VOL_SET_TABLE:  (input) This parameter specifies the pointer to the master
{       volume set table from which the member list locator was obtained.
{
{ P_MEMBER_LIST: (output) This parameter returns the  pointer  to  the  member
{       list.   This pointer may be returned as NIL, if a NIL pointer was used
{       to build the locator.
{
*DECK DECK=STH$BUILD_MEMBER_VST EXPAND=FALSE
{
{   The purpose  of this procedure is to take a newly created volume set table
{ and initialize it to indicate that this volume  is  a  member  volume.   The
{ volume  set table must have already been created and opened, and the pointer
{ is assumed valid.  All fields are assumed initialized prior to this call and
{ the  parameters  are NOT validated.  This procedure is called as a result of
{ the stp$add_member_to_set request.
{
{       STP$BUILD_MEMBER_VST (P_MEMBER_VST, MEMBER_VSN, MEMBER_INTERNAL_VSN,
{         SET_NAME, UNIQUE_SET_NAME, MASTER_VOL, MASTER_INTERNAL_VSN)
{
{ P_MEMBER_VST:  (input)  This  parameter  specifies  a  pointer to the member
{       volume set table that is to be initialized.
{
{ MEMBER_VSN: (input) This parameter specifies the name of the volume.
{
{ MEMBER_INTERNAL_VSN: (input) This specifies the internal vsn of  the  member
{       volume.
{
{ SET_NAME:  (input)  This  parameter  specifies  the name of the set that the
{       member belongs to.
{
{ UNIQUE_SET_NAME: (input) This parameter specifies the  unique  name  of  the
{       set.
{
{ MASTER_VOL:  (input) This parameter specifies the recorded vsn of the master
{       volume of the set that this member is being added to.
{
{ MASTER_INTERNAL_VSN: (input) This paramter specifies the unique vsn for  the
{       master volume.
{
{
*DECK DECK=STH$BUILD_PF_ROOT_LOCATOR EXPAND=FALSE
{
{   The purpose  of  this  request  is to translate a pointer to the permanent
{ file root into a "locator".  This  locator  does  not  include  the  segment
{ number, and cannot be dereferenced directly.
{
{       STP$BUILD_PF_ROOT_LOCATOR (P_PF_ROOT, P_VOL_SET_TABLE, PF_ROOT_LOCATOR)
{
{ P_PF_ROOT: (input) This parmeter specifies the pointer to the permanent file
{       root.  This pointer can be NIL.
{
{ P_VOL_SET_TABLE: (input) This parameter specifies the pointer to the
{       volume set table in which the root was allocated in.
{
{ PF_ROOT_LOCATOR:  (output)  This  parameter  returns  the  locator  to   the
{       permanent  file  root.   This locator can be used later to construct a
{       pointer that can be referenced (see stp$build_pf_root_pointer).
{
*DECK DECK=STH$BUILD_PF_ROOT_POINTER EXPAND=FALSE
{
{   The purpose  of this request is to translate a permanent file root locator
{ into a pointer.  This pointer can then be used to reference the pf root.   A
{ base  pointer  (p_vol_set_table)  is  also  provided  from which the segment
{ number is taken.
{
{       STP$BUILD_PF_ROOT_POINTER (PF_ROOT_LOCATOR, P_VOL_SET_TABLE,
{         P_PF_ROOT)
{
{ PF_ROOT_LOCATOR:  (input)  This  parameter specifies the permanent file root
{       locator.   This  must  previously  have  been   constructed   by   the
{       stp$build_pf_root_locator request.
{
{ P_VOL_SET_TABLE:  (input) This parameter specifies the pointer to the volume
{       set table from which the pf_root_locator was obtained.  This parameter
{       is used to get the segment number for the pointer.
{
{ P_PF_ROOT: (output) This parameter returns the pointer to the permanent file
{       root.  This pointer may be returned as NIL, if a NIL pointer was  used
{       to build the locator.
{
*DECK DECK=STH$CHANGE_ACCESS_TO_SET EXPAND=FALSE
{
{   The purpose of this request is to allow a set owner, operator, system
{ administrator, or volume management to change the permission to access
{ an active set (for access purposes, a set with any volume active.) .
{ If access status is stc$deny_access, volumes may still be added to and
{ deleted from the set, but no more jobs, other than those currently accessing
{ the set, will be allowed access to the set.  This option allows all
{ members of the set to be up, before any user can access the set.  This
{ also allows idling down of the set, by denying other jobs access. If
{ access status is specified as stc$allow_access, all permitted users may
{ access the set.
{
{       STP$CHANGE_ACCESS_TO_SET (SET_NAME, ACCESS_STATUS, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set for which
{       the change is to be initiated.
{
{ ACCESS_STATUS: (input) This parameter specifies the action to be taken
{       on the set, either to allow access or deny access for permanent files.
{{ STATUS: (output) This parameter returns the request status.
{
{         CONDITIONS: ste$set_not_job_owner
{                    ste$set_not_active
{                    ste$bad_access_status
{                    ste$bad_set_name
{                       OTHERS
{
{        IDENTIFIER: stc$set_management_id
{
{
*DECK DECK=STH$CHANGE_AST_ACCESS_STATUS EXPAND=FALSE
{
{   This procedure stores an access status in the active set table entry for a
{ particular set.
{
{       STP$CHANGE_AST_ACCESS_STATUS (AST_INDEX, ACCESS_STATUS, STATUS)
{
{ AST_INDEX: (input) This parameter specifies the index into  the  active  set
{       table for the set.  This is assumed valid.
{
{ ACCESS_STATUS:  This parameter specifies the new access status that is to be
{       stored for the set.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$CLEAR_AST_PF_LOCK EXPAND=FALSE
{
{   The purpose  of  this  routine  is to clear the permanent file lock in the
{ active set table.
{
{       STP$CLEAR_AST_PF_LOCK (AST_INDEX, STATUS)
{
{ AST_INDEX: (input) This parameter specifies the set.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$lock_not_set
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$CLEAR_EXCLUSIVE_ACCESS EXPAND=FALSE
{
{   The purpose  of  this request is to clear the set management exclusive use
{ lock.    This   lock   must   previously    have    been    set    by    the
{ STP$SET_EXCLUSIVE_ACCESS request.
{
{       STP$CLEAR_EXCLUSIVE_ACCESS
{
*DECK DECK=STH$CLEAR_PF_LOCK EXPAND=FALSE
{
{  The purpose of the request is to clear the permanent file lock for the
{ specified set.  The lock must previously have been set by the
{ STP$SET_PF_LOCK request.
{
{       STP$CLEAR_PF_LOCK (SET_NAME, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set for which
{       the permanent file lock is to be cleared.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$set_not_active
{                    ste$master_not_active
{                    ste$lock_not_set
{                    ste$not_allowing_access
{                    ose$job_pageable_full
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$CLEAR_READ_ACCESS EXPAND=FALSE
{
{   The purpose of this request is to clear the set management read lock.  The
{ exclusive lock is obtained for  the  duration  of  this  request  to  insure
{ serializing  of  lock  requests.   The  count  of  the  number of readers is
{ decremented, and if there are no readers the lock is cleared.
{
{
{       STP$CLEAR_READ_ACCESS
{
*DECK DECK=STH$CREATE_AST_ENTRY EXPAND=FALSE
{
{   The purpose of  this request is to establish a new active set table entry.
{ This includes finding  an  unused  entry  and  initializing  all  fields  as
{ indicated.  This request may be used on a create set or when a master volume
{ becomes active.  This routine initializes the  p_member_entry_list  to  NIL,
{ the  master_ever_up  field  to  TRUE, the number_of_jobs_using_set to 0, the
{ pf_root_ever_stored to FALSE, and the pf_lock is  initialized  to  unlocked.
{ All other fields are initialized to the values input to this procedure.
{
{       STP$CREATE_AST_ENTRY (SET_NAME, UNIQUE_SET, MASTER_VOL,
{         MASTER_INTERNAL_VSN, ACTIVE_VOLUME_TABLE_INDEX, SET_OWNER,
{         ACCESS_STATUS, DM_PACKET_STORAGE, AST_INDEX, CREATE_ENTRY_STATUS)
{
{ SET_NAME:  (input)  This parameter specifies the set name for the new active
{       set table entry.
{
{ UNIQUE_SET: (input) This parameter specifies the unique set name.
{
{ MASTER_VOL: (input) This parameter specifies the name of the  master  volume
{       of the set.
{
{ MASTER_INTERNAL_VSN:  (input) This parameter specifies the internal vsn name
{       of the master volume of the set.
{
{ ACTIVE_VOLUME_TABLE_INDEX:  (input)  This  parameter  specifies  the  active
{       volume table index for the master volume.  This index is obtained from
{       device management.  The  master  volume  is  assumed  active  on  this
{       request, and this parameter must be specified correctly.
{
{ SET_OWNER:  (input) This parameter specifies the identification of the owner
{       of the set.
{
{ ACCESS_STATUS: (input) This parameter specifies whether to  allow  permanent
{       file access to the set.
{
{ DM_PACKET_STORAGE:  (input)  This  parameter specifies the device management
{       packet storage for the master volume.
{
{ AST_INDEX: (output) This parameter returns the index of  the  newly  created
{       active set table entry.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ose$maninframe_pageable_full
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$CREATE_SET EXPAND=FALSE
{
{   The purpose of this request is to create a new set.  The master volume
{ must be the first disk volume on the set, and will belong to the set
{ until a STP$PURGE_SET is issued.  This request will cause the master volume
{ to be activated, if not already so.  The master volume must be initialized
{ using the INITIALIZE_VOLUME request, prior to this function.
{ This request can only be issued by the system administrator or the owner
{ of the master volume.
{
{        STP$CREATE_SET (REQUESTED_SET, REQUESTED_MASTER_VOL,
{          REQUESTED_SET_OWNER, ACCESS_STATUS, ROOT_RECREATED, STATUS)
{
{ REQUESTED_SET: (input) This parameter specifies the name of the new set.
{       The name must be unique among all the sets, who currently have
{       a volume active.
{
{ REQUESTED_MASTER_VOL: (input) This parameter specifies the recorded vsn,
{       of the volume that will be the master volume of the set.  The
{       volume cannot belong to another set.
{
{ REQUESTED_SET_OWNER: (input) This parameter specifies the identification
{       of the user who will be the set owner.  This must be the same
{       identification as the master volume owner.  Both the user and family
{       fields must be specified.
{
{ ACCESS_STATUS: (input) This parameter specifies whether the set creator
{       is initially allowing permanent file access to the set.  If this is
{       STC$DENY_ACCESS then volumes may still be added to or deleted from
{       the set, but no user will be allowed to create permanent files
{       on the set.
{
{ ROOT_RECREATED: (input) This parameter specifies whether the set is being
{       recreated.  This value is saved in the master vst and is used to control
{       the reloading of missing catalogs.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$set_already_active
{                    ste$attach_df_error
{                    ste$push_failed
{                    ose$mainframe_pageable_full
{                    ste$no_space_vst_heap
{                    ste$dm_avt_index_mismatch
{                    ste$master_not_active
{                    ste$set_not_master_owner
{                    ste$set_not_job_owner
{                    ste$bad_access_status
{                    ste$bad_set_owner
{                    ste$bad_master_vol_desc
{                    ste$bad_set_name
{                       OTHERS
{
{        IDENTIFIER: stc$set_management_id
{
{
{
*DECK DECK=STH$CREATE_VST EXPAND=FALSE
{
{   The purpose  of  this  procedure is to create a device file for the volume
{ set table.  The device file is opened and only the version number
{ is initialized.
{
{       STP$CREATE_VST (VSN, VST_SFID, VST_SEGMENT_POINTER, STATUS)
{
{ VSN: (input) This parameter specifies the volume on which the device file is
{       to  be  created  on.   There must NOT already be a volume set table on
{       this volume.
{
{ VST_SFID: (output) This parameter returns the system file identifier for the
{       newly  created  device  file.  This can then be used to open or return
{       the volume set table.
{
{ VST_SEGMENT_POINTER: (output) This parameter returns the segment pointer
{       to the volume set table.  This may be used to directly reference
{       the volume set table.
{
{ STATUS: (output) This parameter returns the request status.
{
{
{       CONDITIONS: ste$push_failed
{                   ste$open_error
{                   OTHERS FROM DEVICE MANAGEMENT
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$DEALLOCATE_AST_ENTRY EXPAND=FALSE
{
{   This procedure  conditionally  removes a set from the active set table and
{ makes the entry unused.  This routine validates that there are no jobs using
{ the  set,  and  that  there  are no volumes active (master or member) on the
{ set.  No check of the pf root is performed.
{
{       STP$DEALLOCATE_AST_ENTRY (AST_INDEX, STATUS)
{
{ AST_INDEX: (input) This parameter specifies the index into  the  active  set
{       table  for  the  entry  that  is to be removed.  This index is assumed
{       valid.
{
{ STATUS: (output) This parameter returns the request status.
{       If  there are still volumes active, normal status is returned, but the
{       active set table entry is not removed.
{
{       CONDITIONS: ste$jobs_on_set
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$DECREMENT_JOB_USE_IN_AST EXPAND=FALSE
{
{   The procedure  decrements the number_of_jobs_using_set field in the active
{ set table.
{
{       STP$DECREMENT_JOB_USE_IN_AST (AST_INDEX)
{
{ AST_INDEX: (input) This parameter specifies the index into  the  active  set
{       table for the set.  This is assumed valid.
{
*DECK DECK=STH$DESTROY_VST EXPAND=FALSE
{
{   The purpose of this procedure is to destroy a device file for a volume set
{ table.  The device file should not be attached.
{
{       STP$DESTROY_VST (VSN, STATUS)
{
{ VSN: (input) This parameter specified the volume on  which  the  volume  set
{       table (device file) is to be destroyed.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ERRORS FROM DEVICE MANAGEMENT
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$DETACH_VST EXPAND=FALSE
{
{   The purpose of this routine is to interface to device management to detach
{ a volume set table's device file.
{
{       STP$DETACH_VST (SFID, STATUS)
{
{ SFID: (input) This parameter specifies the system file  identifier  for  the
{       volume set table.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ERRORS FROM DEVICE MANAGEMENT
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$DISK_VOLUME_ACTIVE EXPAND=FALSE
{
{   The purpose of this request is to allow device management to notify
{ set management that a new disk volume has become active.  Set management can
{ then update the active set table, so that on future requests from
{ device management the status of the volumes
{ will be correct.  Device management must issue this request for all new
{ disk volumes that become active.  Set management will initially
{ turn around and ask device management if this volume has
{ a volume set table, and try to attach it.
{   If the volume is the first volume active in a set, the access status for
{ that set will be initialized to stc$deny_access.  This indicates that no
{ permanent file use of the set will be allowed until a
{ stp$change_access_to_set request is issued.
{   If a member volume becomes active and we are have re-initialized the
{ system device, we will attempt to re-add this member volume back into the
{ newly initialized master volume.
{
{       STP$DISK_VOLUME_ACTIVE (ACTIVE_VOL, INTERNAL_VSN,
{         ACTIVE_VOLUME_TABLE_INDEX, SET_NAME, STATUS)
{
{ ACTIVE_VOL: (input) This parameter specifies the recorded vsn of
{       the volume that has just been activated or made available.
{
{ INTERNAL_VSN: (input) This parameter specifies the internal vsn of the
{       active_vol.
{
{ ACTIVE_VOLUME_TABLE_INDEX: (input) This parameter specifies an index
{       assigned by device management.  This is kept for device management
{       for efficiency reasons, and is not used by set management.
{
{ SET_NAME: (output) This parameter returns the set name
{       of the set that the volume belongs to.
{
{ STATUS: (output) This parameter returns the request status.
{
{   CONDITIONS
{               ste$ast_mvt_master_mis
{               ste$attach_df_error
{               ste$bad_mel_generated
{               ste$diff_unique_set_active
{               ste$duplicate_master_initdd
{               ste$internal_vsn_mismatch
{               ste$mel_mvl_mismatch
{               ste$member_vol_in_set
{               ste$open_error
{               ste$vst_exists_not_in_set
{
{   IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$DISK_VOLUME_INACTIVE EXPAND=FALSE
{
{   The purpose of this request is to allow volume management to notify set
{ management that a disk volume has become inactive.  Volume management must
{ issue this request for all disk volumes that become inactive or unenabled.
{ Set management can then update its tables, so that on future
{ requests from volume management the volume
{ list returned will be correct.
{ If there are still permanent file users on the set, an attempt will be made
{ to mount the inactive volume.
{
{       STP$DISK_VOLUME_INACTIVE (INACTIVE_VOL, INTERNAL_VSN, SET_ORDINAL,
{          DM_PACKET, STATUS)
{
{ INACTIVE_VOL: (input) This parameter specifies the recorded vsn of the
{       volume that has just been inactivated or become unavailable.
{
{ INTERNAL_VSN: (input) This parameter specifies the internal vsn of the
{       new active volume.
{
{ SET_ORDINAL: (input) This parameter specifies the set ordinal
{       associated with the volume.  The set ordinal was originally placed
{       in the active volume table as a result of a stp$disk_volume_active,
{       or dmp$store_set_ordinal.
{
{ DM_PACKET: (input) This parameter specifies a 'packet' of information
{       that the device manager expects the set manager to store away
{       and retrieve when asked.
{       The set manager is not concerned with the contents of this packet.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$down_vol_used
{                    ste$dm_ast_mismatch
{                    ste$attach_df_error
{                    ste$open_error
{                    ste$dm_mel_mismatch
{                    ste$internal_vsn_mismatch
{                       OTHERS
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$DM_CHECK_IF_FILES_ON_VOL EXPAND=FALSE
{
{   This procedure  provides  a  stub  for the request to device management to
{ determine if there are files (permanent, or catalog) on a volume.  This  can
{ be used to determine if it is OK to remove the volume from a set.
{
{       STP$DM_CHECK_IF_FILES_ON_VOL (VOLUME, FILES_ON_VOL)
{
{ VOLUME: (input) This parameter specifies the volume to check.
{
{ FILES_ON_VOL:  (output)  This  parameter returns whether there are permanent
{       files or catalog files on the volume.
{       This is currently always set to FALSE.
{
*DECK DECK=STH$DM_MOUNT_VOLUME EXPAND=FALSE
{
{   This procedure  provides  a  stub  for  the  request  to dynamically mount
{ volumes.  Currently this always returns abnormal status.
{
{       STP$DM_MOUNT_VOLUME (VOLUME, STATUS)
{
{ VOLUME: (input) This parameter specifies the name of the volume to mount.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$impossible_to_mount
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$FILL_MASTER_VST EXPAND=FALSE
{
{   The purpose  of  this  procedure  is to initially fill all the fields in a
{ master volume set table at time of set creation.  The volume set table  must
{ have  already  been  created  and opened, and all input parameters must have
{ been established and validated prior to the call  to  this  procedure.   All
{ fields are initialized and the member vsn list initialized.
{
{       STP$FILL_MASTER_VST (P_MASTER_VST, MASTER_VSN, MASTER_INTERNAL_VSN,
{         SET_NAME, UNIQUE_SET, SET_OWNER, DM_PACKET_STORAGE, ROOT_RECREATED, STATUS)
{
{ P_MASTER_VST: (input) This  parameter  specifies  a  pointer  to  the  newly
{       created volume set table.
{
{ MASTER_VSN: (input) The name of the master.
{
{ MASTER_INTERNAL_VSN: (input) The unique name of the master.
{
{ SET_NAME: (input) The set name.
{
{ UNIQUE_SET_NAME: (input) The unique set name for the set.
{
{ SET_OWNER: (input) The name (family, user) of the owner of the set.
{
{ DM_PACKET_STORAGE:  (input)  The  device  management  packet storage for the
{        volume.  Included in this record is  whether  the  device  management
{        packet has ever been stored.
{
{ ROOT_RECREATED: (input) This parameter specifies whether the set is being
{       recreated.  This value is saved in the master vst and is used to control
{       the reloading of missing catalogs.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$no_space_vst_heap (SYSTEM ERROR)
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$GET_ACTIVE_SET_LIST EXPAND=FALSE
{
{   The purpose of this request is to return a list of all active sets.
{ The set manager defines an active set to be a set with at least one
{ volume active.
{
{       STP$GET_ACTIVE_SET_LIST (ACTIVE_SET_LIST, ACTUAL_NUMBER_OF_SETS,
{         STATUS)
{
{ ACTIVE_SET_LIST: (output) This parameter returns the list of active sets.
{           IF actual_number_of_sets = UPPERBOUND (active_set_list) THEN
{             All sets have been gotten.
{           IF actual_number_of_sets < UPPERBOUND (active_set_list) THEN
{             Only the actual number of sets are stored in the lower portion
{             of the array.  All other array entries (the upper portion) are
{             undefined.
{           IF actual_number_of_sets > UPPERBOUND (active_set_list) THEN
{             The active_set_list is filled with sets, but is not big enough
{             There are (actual_number_of_sets - UPPERBOUND(active_set_list))
{             additional sets in the set.
{           IF actual_number_of_sets = 0 THEN
{             There are no active sets.
{
{ ACTUAL_NUMBER_OF_SETS: (output) This returns the number of sets known
{         by the set manager.
{
*DECK DECK=STH$GET_ACTIVE_VOLUME_LIST EXPAND=FALSE
{
{   The purpose of this request is to furnish device management with the names
{ of the volumes on the scratch set (or sets) for the requested job.
{ Device management must be running on behalf of the desired job.
{
{       STP$GET_ACTIVE_VOLUME_LIST (VOLUME_LIST,
{         ACTUAL_NUMBER_OF_VOLUMES, STATUS)
{
{ VOLUME_LIST: (output) This parameter returns the names of all active volume
{       in all active sets.
{       IF status.NORMAL THEN
{         IF actual_number_of_volumes = UPPERBOUND (volume_list) THEN
{           All volumes have been goten.
{         IF actual_number_of_volumes < UPPERBOUND (volume_list) THEN
{           Only the actual number of volumes are stored in the lower portion
{           of the array.  All other array entries are undefined.
{         IF actual_number_of_volumes > UPPERBOUND (volume_list) THEN
{           The given array is filled with volumes, but is not big enough
{           to hold all the volumes.
{           There are (actual_number_of_volumes - UPPERBOUND
{           (volume_list)) additional volumes.
{       IF NOT status.NORMAL THEN this parameter is undefined.
{
{ ACTUAL_NUMBER_OF_VOLUMES: (output) This parameter returns the actual number
{       number of volumes that the job can use as scratch volumes.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$push_failed
{                    ste$no_scratch_volumes
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$GET_INTERNAL_VOLUMES_SET EXPAND=TRUE
{
{   The purpose of this request is to determine what set a volume belongs to.
{ This request will cause the set manager to search the active set table for
{ the requested volume.  The set manager will NOT attempt to read the volume
{ set table, as a result of this request, nor will an attempt be made to mount
{ the volume. This request will find any member volume whose master is active
{ or any master volume that is currently active.
{
{       STP$GET_INTERNAL_VOLUMES_SET (VOLUME, SET_NAME, STATUS)
{
{ VOLUME: (input) This parameter specifies the internal vsn of the volume that
{       the  set manager is to look for.
{
{ SET_NAME: (output) This parameter returns the set name that the volume
{       belongs to.  IF NOT status.normal this is undefined.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$vol_not_found
{                    (text field not appended)
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$GET_PF_ACTIVE_SET_ENTRY EXPAND=FALSE
{
{   This procedure  attempts  to obtain the active set table entry as a result
{ of a permanent file request into the set manager.  The set is  first  looked
{ for  in  the  job active set table, to avoid searching the active set table.
{ If the set is not found in the job active set table, it is  the  first  time
{ this  job  has  had  a permanent file request and a new job active set table
{ entry is built.
{
{       STP$GET_PF_ACTIVE_SET_ENTRY (SET_NAME, AST_INDEX, AST_ENTRY, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of  the  set  to  search
{       for.
{
{ AST_INDEX:  (output)  This  parameter  returns the index into the active set
{       table for the found set.
{
{ AST_ENTRY: (output) This parameter returns the active set  table  entry  for
{       the set.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$set_not_active
{                   ste$not_allowing_access
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$GET_PF_ROOT EXPAND=FALSE
{
{   The purpose of this request is to return the permanent file root, and
{ permanent file root size to the requestor.  The size of the
{ pf_root_container must be greater than or equal to the size of the root
{ stored by the set manager.  If the root container is NOT large enough
{ the condition ste$incorrect_root_size will be returned and the pf_root_size
{ parameter will contain the correct size.
{
{       STP$GET_PF_ROOT (SET_NAME, PF_ROOT_SIZE, PF_ROOT_CONTAINER, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set for which
{       the permanent file root is desired.
{
{ PF_ROOT_SIZE: (output) This parameter returns the size in bytes, of the
{       permanent file root.
{
{ PF_ROOT_CONTAINER: (output) This parameter returns the permanent file root for the set.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$set_not_active
{                    ste$master_not_active
{                    ste$pf_root_not_stored
{                    ste$incorrect_root_size
{                    ste$not_allowing_access
{                    ose$job_pageable_full
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$GET_PF_ROOT_SIZE EXPAND=FALSE
{
{   The purpose of  this request is to return the size of the permanent file
{ root for the requested set.
{
{       STP$GET_PF_ROOT_SIZE (SET_NAME, PF_ROOT_SIZE, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set for which
{       the permanent file root size is desired.
{
{ PF_ROOT_SIZE: (output) This parameter returns the size, in bytes, of the
{       permanent file root.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$set_not_active
{                    ste$master_not_active
{                    ste$pf_root_not_stored
{                    ste$not_allowing_access
{                    ose$job_pageable_full
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$GET_SETS_ORDINAL EXPAND=FALSE
{
{   This procedure returns the set ordinal and name of the master volume
{ for a set that is currently active.
{
{       STP$GET_SETS_ORDINAL (SET_NAME, SET_ORDINAL, MASTER_VOL, STATUS)
{
{ SET_NAME: (input) This parameter specifies the set name.
{
{ SET_ORDINAL: (output) This parameter returns the set ordinal of
{       the given set.
{
{ MASTER_VOL: (output) This parameter returns the name of the master volume
{       of the set.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$set_not_active
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$GET_SET_OWNER EXPAND=FALSE

{
{   The purpose of this request is to allow the permanent file manager to
{ get the specified sets owner.  A check will be made if the master volume
{ has ever been active.  If it has been, we know the stored set owner is valid.
{ However if the master has never been up in the set, we do not assume the
{ set owner is valid, and an attempt is made to mount the master volume.
{
{       STP$GET_SET_OWNER (REQUIRED_SET, SET_OWNER, STATUS)
{
{ REQUIRED_SET: (input) This parameter specifies the name of the set,
{       for which the owner is desired.  This parameter is assumed capitilized.
{
{ SET_OWNER: (output) This parameter returns the name of the owner of the
{       required set.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$not_allowing_access
{                    ste$set_not_active
{                    ste$master_not_active
{                    ose$job_pageable_full
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$GET_UNUSED_ENTRY_IN_AST EXPAND=FALSE
{
{   The purpose  of  this  request  is  to  do all that is necessary to get an
{ unused entry in the active set table.  This includes initially creating  the
{ table, expanding the table if needed, and searching for an unused entry.
{
{       STP$GET_UNUSED_ENTRY_IN_AST (AST_INDEX, STATUS)
{
{ AST_INDEX:  (output)  This  parameter  returns the index into the active set
{       table for the unused entry.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ose$mainframe_pageable_full
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$GET_UNUSED_MEL_ENTRY EXPAND=FALSE
{
{   This procedure  does  what  is neccessary to obtain an unused entry in the
{ member entry list for a particular set.  This may include allocating  a  new
{ member entry list, finding an unused entry in an existing member entry list,
{ or expanding an existing member entry list.
{
{       STP$GET_UNUSED_MEL_ENTRY (AST_INDEX, MEL_INDEX, STATUS)
{
{ AST_INDEX: (input) This parameter specifies the set for which a member entry
{       is  to  be found.  This is assumed to be a valid index into the active
{       set table.
{
{ MEL_INDEX: (output) This parameter returns the index  of  the  unused  entry
{       into the member entry list of the active set table entry.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ose$mainframe_pageable_full
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$GET_VOLUMES_BY_AST_INDEX EXPAND=FALSE
{
{   The purpose of this request is to return a list of all volumes in a
{ particular set.
{
{       STP$GET_VOLUMES_BY_AST_INDEX (SET_INDEX, STARTING_MEMBER_INDEX,
{         MASTER_VOL, MEMBER_VSN_LIST, NUMBER_OF_MEMBERS)
{
{ SET_INDEX: (input) This parameter specifies the set that the
{         information is desired for.  This is assumed valid.
{
{ STARTING_MEMBER_INDEX: (input) This parameter specifies the first index in
{         the member_vsn_list, in which to store members.
{
{ MASTER_VOL: (output) This parameter returns the name of the master volume
{         of the set.
{
{ MEMBER_VSN_LIST: (output) This parameter returns the list of member volumes
{         in the set.
{           IF actual_number_of_members = (UPPERBOUND (member_vol_list) + 1 -
{           starting_member_index) THEN
{             All volumes have been gotten.
{           IF actual_number_of_volumes < (UPPERBOUND (member_vol_list) + 1  -
{           starting_member_index) THEN
{             Only the actual number of members are stored in the lower portion
{             of the array, beginning with entry STARTING_MEMBER_INDEX
{             All other array entries (the upper portion) are
{             undefined.
{           IF actual_number_of_volumes > (UPPERBOUND (member_vol_list) + 1 -
{           starting_member_index) THEN
{             The member_vol_list is filled with volumes, but is not big
{             to hold all the volumes.
{             There are (actual_number_of_members -
{             UPPERBOUND(member_vol_list) +1 - starting_member_index)
{             additional members in the set.
{
{ NUMBER_OF_MEMBERS: (output) This returns the number of members known
{         to be in the set.  If the master volume has never been active between
{         deadstarts, this number could be inaccurate, reflecting only the
{         number of members that the set manager knows about.
{
*DECK DECK=STH$GET_VOLUMES_BY_SET_ORDINAL EXPAND=FALSE
{
{   The purpose of this request is to return a list of all volumes in a
{ particular set.
{
{       STP$GET_VOLUMES_BY_SET_ORDINAL (SET_ORDINAL, MASTER_VOL,
{         MEMBER_VOL_LIST, ACTUAL_NUMBER_OF_MEMBERS, STATUS)
{
{ SET_ORDINAL: (input) This parameter specifies the set ordinal of the set
{         that information is desired for.
{
{ MASTER_VOL: (output) This parameter returns the name of the master volume
{         of the set.  If bad status, this is undefined.
{
{ MEMBER_VOL_LIST: (output) This parameter returns the list of member volumes
{         in the set.  This does NOT include the master volume.
{         IF status.NORMAL THEN
{           IF actual_number_of_members = UPPERBOUND (member_vol_list) THEN
{             All volumes have been gotten.
{           IF actual_number_of_volumes < UPPERBOUND (member_vol_list) THEN
{             Only the actual number of members are stored in the lower portion
{             of the array.  All other array entries (the upper portion) are
{             undefined.
{           IF actual_number_of_volumes > UPPERBOUND (member_vol_list) THEN
{             The member_vol_list is filled with volumes, but is not big
{             enough to hold all the volumes.
{             There are (actual_number_of_members -
{             UPPERBOUND(member_vol_list))
{             additional members in the set.
{         IF NOT status.NORMAL THEN this parameter is undefined.
{
{ ACTUAL_NUMBER_OF_MEMBERS: (output) This returns the number of members known
{         to be in the set.  If the master volume has never been active between
{         deadstarts, this number could be inaccurate, reflecting only the
{         number of members that the set manager knows about.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$set_not_active
{                    ste$master_not_active
{                    ste$set_ord_not_set
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$GET_VOLUMES_IN_SET EXPAND=FALSE
{
{   The purpose of this request is to return a list of all volumes in a
{ particular set.
{
{       STP$GET_VOLUMES_IN_SET (SET_NAME, MASTER_VOL, MEMBER_VOL_LIST,
{         ACTUAL_NUMBER_OF_MEMBERS, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set that the
{         information is desired for.
{
{ MASTER_VOL: (output) This parameter returns the name of the master volume
{         of the set.  If bad status, this is undefined.
{
{ MEMBER_VOL_LIST: (output) This parameter returns the list of member volumes
{         in the set.  This does NOT include the master volume.
{         IF status.NORMAL THEN
{           IF actual_number_of_members = UPPERBOUND (member_vol_list) THEN
{             All volumes have been gotten.
{           IF actual_number_of_volumes < UPPERBOUND (member_vol_list) THEN
{             Only the actual number of members are stored in the lower portion
{             of the array.  All other array entries (the upper portion) are
{             undefined.
{           IF actual_number_of_volumes > UPPERBOUND (member_vol_list) THEN
{             The member_vol_list is filled with volumes, but is not big
{             to hold all the volumes.
{             There are (actual_number_of_members -
{             UPPERBOUND(member_vol_list))
{             additional members in the set.
{         IF NOT status.NORMAL THEN this parameter is undefined.
{
{ ACTUAL_NUMBER_OF_MEMBERS: (output) This returns the number of members known
{         to be in the set.  If the master volume has never been active between
{         deadstarts, this number could be inaccurate, reflecting only the
{         number of members that the set manager knows about.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$set_not_active
{                    ste_master_not_active
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$GET_VOLUMES_SET_NAME EXPAND=FALSE

{
{   The purpose of this request is to determine what set a volume belongs to.
{ This request will cause the set manager to search the active set table for
{ the rquested volume.  The set manager will NOT attempt to read the volume
{ set table, as a result of this request, nor will an attempt be made to mount
{ the volume.
{
{       STP$GET_VOLUMES_SET_NAME (VOLUME, SET_NAME, STATUS)
{
{ VOLUME: (input) This parameter specifies the name of the volume that the
{       set manager is to look for.
{
{ SET_NAME: (output) This parameter returns the set name that the volume
{       belongs to.  IF NOT status.normal this is undefined.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$vol_not_found
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$INACTIVATE_MASTER EXPAND=FALSE
{
{   This procedure  modifies  the  active  set table to indicate that a master
{ volume is no longer active.  The set must previously have been located prior
{ to this call.
{
{       STP$INACTIVATE_MASTER (AST_INDEX, DM_PACKET_STORAGE, STATUS)
{
{ AST_INDEX: (input) This parameter specifies the set.
{
{ DM_PACKET_STORAGE:  (input)  This  parameter specifies the device management
{       packet storage record.  This will be stored in the active set table.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$INACTIVATE_MEMBER EXPAND=FALSE
{
{   This procedure  modifies  the  active  set table to indicate that a member
{ volume is no longer active.  The set must previously  been  located  in  the
{ active  set  table  prior to this call.  This routine will search the member
{ entry list for this set, and if found will  modify  that  members  entry  to
{ indicate that the member is inactive.
{
{       STP$INACTIVATE_MEMBER (AST_INDEX, INACTIVE_VOL, INTERNAL_VSN,
{         DM_PACKET_STORAGE, STATUS)
{
{ AST_INDEX: (input) This parameter specifies the set.  This is assumed to  be
{       a valid index.
{
{ INACTIVE_VOL: (input) This parameter specifies the name of the member volume
{       which is to be indicated as inactive.
{
{ INTERNAL_VSN: (input) This parameter specifies  the  internal  name  of  the
{       member volume.
{
{ DM_PACKET_STORAGE:  (input)  This  parameter specifies the device management
{       packet storage.  This will be stored into the member entry.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$dm_mel_mismatch
{                   ste$internal_vsn_mismatch
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$INCREMENT_JOB_COUNT_IN_AST EXPAND=FALSE
{
{   This procedure  increments  the number of jobs using the set in the active
{ set table.
{
{       STP$INCREMENT_JOB_COUNT_IN_AST (AST_INDEX, STATUS)
{
{ AST_INDEX: (input) This parameter specifies the index into  the  active  set
{       table  for  the  entry  whose  number_of_jobs_using_set field is to be
{       incremented.  The ast index is assumed valid.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$set_not_active
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$INITIALIZE_SETS EXPAND=FALSE

{
{   The purpose of this request is to allow for the initialization
{  of the system set during an installation deadstart.
{
{       STP$INITIALIZE_SETS (STATUS)
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ERRORS FROM stp$create_set:
{                    ste$attach_df_error
{                    ste$push_failed
{                    ose$mainframe_pageable_full
{                    ste$no_space_vst_heap
{                    ste$dm_avt_index_mismatch
{                    ste$master_not_active
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$INSERT_MEMBER_INTO_MEL EXPAND=FALSE
{
{   The purpose  of  this  procedure  is  to initialize all fields of a member
{ entry for a member  entry  list  for  a  particular  set.   All  fields  are
{ indicated  by the input parameters.  The set must have already been found in
{ the active set table (and is specified by the ast_index parameter)  and  the
{ particular  entry  into  the  member entry list must have been found (and is
{ specified by the mel_index parameter).
{
{       STP$INSERT_MEMBER_INTO_MEL (AST_INDEX, MEL_INDEX, MEMBER_VOL,
{         MEMBER_INTERNAL_VSN, MEMBERS_ACTIVITY, MEMBERS_AVT_INDEX,
{         DM_PACKET_STORAGE)
{
{ AST_INDEX: (input) This parameter specifies the set.
{
{ MEL_INDEX: (input) This parameter specifies the index into the member  entry
{       list for the particular set.  This is assumed to be a valid index.
{
{ MEMBER_VOL: (input)  This parameter specifies the name of the member volume.
{{ MEMBER_INTERNAL_VSN:  (input)  This parameter specifies the internal vsn for
{       the member volume.
{
{ MEMBERS_ACTIVITY: (input) This parameter specifies whether the member volume
{       is active (stc$active) or inactive (stc$inactive).  If stc$active then
{       the MEMBERS_AVT_INDEX should be initialized.
{
{ MEMBERS_AVT_INDEX: (input) This parameter specifies the member volumes index
{       into the device management active volume table.
{
{ DM_PACKET_STORAGE:  (input)  This  parameter specifies the device management
{       storage record for this volume.
{
*DECK DECK=STH$IS_VOLUME_IN_SET EXPAND=FALSE
{
{    The purpose of this request is to determine if the given volume is in
{ the given set.  If the volume is found in the set (either as a member or a
{ master) the volume info for the volume is returned.
{
{       STP$IS_VOLUME_IN_SET (VOLUME, SET_NAME, VOLUME_INFO, STATUS)
{
{ VOLUME: (input) This parameter specifies the name of the volume that is to
{         be looked for in the given set.
{
{ SET_NAME: (input) This parameter specifies the name of the set in which to
{         search for the given volume.
{
{ VOLUME_INFO: (output) This parameter returns the volume info for the volume
{         if the volume was found to be in the set.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$set_not_active
{                    ste$vol_not_in_set
{                    ste$master_not_active
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$JOB_ACTIVE_SET_TABLE EXPAND=FALSE
{
{  JOB_ACTIVE_SET_TABLE   (JAST)
{
{  PURPOSE:
{    There is a job active set table for every job who is accessing
{    a set for permanent file usage.  This table serves two
{    functions:
{    -  It allows a means of keeping track of the number of jobs
{       using a set  (by knowing if the job has already accessed
{       the set) .
{    -  It provides a speed up mechanism, so that later accesses
{       to the same set within the job, may access this table and
{       avoid searching the active set table.
{  WHEN ACCESSED:
{    All accessing is done by the set manager.
{    MODIFIED:
{    -  A new entry is created on the first permanent file operation
{       within the job.
{    -  The table is destroyed on job termination.
{    READ:
{    -  The JAST is accessed on all permanent file operations.
{  LAYOUT:
{    The JAST is an adaptable array.
{  PRIMARY KEY:
{    set name
{  RESIDENCY:
{    A pointer to the JAST (stv$p_jast) is a static ring 2 variable.
{    The table is allocated in the job pageable heap.
{    All reading or writing occurs in ring 2.
{  FIELDS:
{    stt$job_active_set_entry = record
{      case entry_type
{      = stc$valid =
{        set_name:  The name of the set that the job is using.
{        unique_set_name
{        ast_index:  The index into the AST for the set.
*DECK DECK=STH$MEMBERS_ACTIVE_ON_SET EXPAND=FALSE
{
{   This procedure determines if there are any members active for a particular
{ set.  The set must previously have been located in the active set table.
{
{       STP$MEMBERS_ACTIVE_ON_SET (AST_INDEX, MEMBERS_ACTIVE_ON_SET)
{
{ AST_INDEX: (input) This parameter specifies the index into  the  active  set
{       table for the desired set.
{
{ MEMBERS_ACTIVE_ON_SET: (output) This parameter returns whether there are any
{       member volumes active for this set.  If there are no member volumes or
{       if  all  the  member  volumes  are  inactive  then this is returned as
{       FALSE.
{
*DECK DECK=STH$MEMBERS_INACTIVE_ON_SET EXPAND=FALSE
{
{   This procedure  determines  if  there  are  any  member  volumes  that are
{ inactive on the set.  The set must  previously  have  been  located  in  the
{ active set table.
{
{       STP$MEMBERS_INACTIVE_ON_SET (AST_INDEX, MEMBERS_INACTIVE_ON_SET)
{
{ AST_INDEX:  (input)  This  parameter specifies the index into the active set
{       table for the desired set.
{
{ MEMBERS_INACTIVE_ON_SET: (output) This parameter returns whether  there  are
{       any  member  volumes  that  are inactive on this set.  If there are no
{       member volumes or if all the member volumes are active  then  this  is
{       returned as false.
{
*DECK DECK=STH$MEMBERS_ON_SET EXPAND=FALSE
{
{   This procedure determines if there are any member volumes on the set.  The
{ set must have previously been located in the active set table.
{
{         STP$MEMBERS_ON_SET (AST_INDEX, MEMBERS_ON_SET)
{
{ AST_INDEX: (input) This parameter specifies the index into  the  active  set
{       table for the desired set.
{
{ MEMBERS_ON_SET: (output) This parameter specifies whether there are known to
{       be any member volumes on this set.  This is determined by checking the
{       member  entry list in the active set table.  If the master is inactive
{       and this parameter is returned as FALSE, there may actually be members
{       on the set (they are inactive).  This is a fairly obscure case.
{
*DECK DECK=STH$MEMBER_ENTRY_LIST EXPAND=FALSE
{
{  MEMBER_ENTRY_LIST   (MEL)
{
{  PURPOSE:
{    The member entry list is a sub list of the active set table.
{    Maintained in it are all members (NOT including the master!)
{    in the set.
{  WHEN ACCESSED:
{    All accessing is done by the set manager.
{    MODIFIED:
{    -  When volumes are added to or removed from sets.
{    -  When members become active or inactive.
{    READ:
{    -  The member list is returned to device management when
{       requested on assigning files to volumes.
{  LAYOUT:
{    The MEL is an adaptable array.
{  PRIMARY KEY:
{    Member recorded vsn.
{  RESIDENCY:
{    A pointer to the MEL is maintained for each set in the AST.
{    The MEL is allocated in the mainframe pageable heap.
{    All reading or writing occurs in ring 1.
{  FIELDS:
{    stt$member_entry_list = array [ * ] of stt$member_entry,
{    stt$member_entry = record
{      case entry_type
{      = stc$valid =
{        member_vsn: Name of the member volume,
{        member_internal_vsn: The unique name of the member.
{        member_dm_packet_storage: This indicates whether the
{              dm_packet for the member has ever been stored.
{        member_volume_activity: This describes if the member is
{              active and the avt_index of it if it is.
{
*DECK DECK=STH$OBTAIN_AST_ENTRY EXPAND=FALSE
{
{   The purpose  of this routine is to obtain the active set table entry given
{ the active set table index to the desired entry.  The entry may be  a  valid
{ or an unused entry.
{
{       STP$OBTAIN_AST_ENTRY (AST_INDEX, AST_ENTRY, STATUS)
{
{ AST_INDEX:  (input)  This  parameter specifies the index into the active set
{       table.
{
{ AST_ENTRY: (output) This parameter returns a copy of the  active  set  table
{       entry.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$set_not_active
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$OBTAIN_AST_MEMBER_LIST EXPAND=FALSE
{
{   The purpose  of  this  request is to return the member entry list from the
{ active set table.  The  user  must  supply  an  array  (the  ast_member_list
{ parameter) in which to store a copy of the member entries.  Recall that this
{ list does NOT include the master volume.
{
{       STP$OBTAIN_AST_MEMBER_LIST (AST_INDEX, AST_MEMBER_LIST,
{         AST_MEMBER_ENTRY_LIST_SIZE)
{
{ AST_INDEX:  (input)  This  parameter  specifies the set for which the member
{       entries are to be obtained.
{
{ AST_MEMBER_LIST: (output) This parameter returns the member entries from the
{       active set table.  This is the list as recorded directly in the active
{       set table, so it includes both valid an unused entries.  The caller of
{       this  request  must  supply this array.  The actual size of the member
{       list (next parameter) can be used to determine how many of the  member
{       entries the requestor actually obtained.
{            IF ast_member_entry_list_size = UPPERBOUND (ast_member_list)
{               ALL member entries have been gotten.
{            IF ast_member_entry_list_size < UPPERBOUND (ast_member_list)
{               Only the actual number of member entries are stored in
{               the lower portion of the array.  All other array entries
{               (the upper portion) are undefined.
{            IF ast_member_entry_list_size > UPPERBOUND (ast_member_list)
{               The ast_member_list is filled with entries but is not big
{               enough to hold all of the volumes.  There are
{               ast_member_entry_list_size - UPPERBOUND (ast_member_list)
{               additional member entries in the active set table entry
{               for this set.
{
{ AST_MEMBER_ENTRY_LIST_SIZE:  (output)  This  returns  the  number  of member
{       entries  in  the  active  set  table   entry   for   this   set.    IF
{       p_member_entry_list = NIL this is 0.
{
*DECK DECK=STH$OBTAIN_AST_PF_ROOT EXPAND=FALSE
{
{   The purpose  of  this  procedure is to obtain the permanent file root from
{ the active set table.  The set must previously  have  been  located  in  the
{ active  set table.  A permanent file root (SEQ (*)) must be supplied to this
{ routine.
{
{       STP$OBTAIN_AST_PF_ROOT (AST_INDEX, PF_ROOT, STATUS)
{
{ AST_INDEX: (input) This parameter specifies the set for which the  permanent
{       file root is to be obtained.
{
{ PF_ROOT:  (input,  output) This parameter specifies a container in which the
{       permanent file root as stored  in  the  active  set  table  is  to  be
{       returned in.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$incorrect_root_size
{                   ste$pf_root_not_stored
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$OBTAIN_AST_SIZE EXPAND=FALSE
{
{   This routine  returns the number of entries (both valid and unused) in the
{ active set table.  If the active set table  has  not  been  initialized  the
{ ast_size = 0.
{
{       STP$OBTAIN_AST_SIZE (AST_SIZE)
{
{ AST_SIZE: (output)  This parameter returns the size of the active set table.
{
*DECK DECK=STH$OBTAIN_MASTER_VST_INFO EXPAND=FALSE
{
{   The purpose  of this request is to return information from a master volume
{ set table.  Information returned on the STP$OBTAIN_VST_HEADER request is NOT
{ returned  on  this  request.   The volume set table is assumed open prior to
{ this request, and this volume is assumed to be a master volume.
{
{       STP$OBTAIN_MASTER_VST_INFO (P_VOL_SET_TABLE, SET_OWNER,
{         DM_PACKET_STORAGE, MEMBER_LIST, SIZE_OF_MEMBER_LIST, PF_ROOT_STORED,
{         PF_ROOT_SIZE, PF_ROOT_LOCATOR)
{
{ P_VOL_SET_TABLE: (input) This parameter specifies a pointer  to  the  master
{       volume set table.  This is assumed valid.
{
{ SET_OWNER:  (output)  This  parameter  returns  the name of the set owner as
{       recorded in the master volume set table.
{
{ DM_PACKET_STORAGE: (output) This parameter  returns  the  device  management
{       packet  storage  for  this  volume.  Recall, that in this record is an
{       indication of whether the  device  management  packet  has  ever  been
{       stored.
{
{ MEMBER_LIST:  (input,  output)  This  parameter  returns  the list of member
{       volumes (NOT including the master) in the set.  This is  the  list  as
{       recorded  directly in the master volume set table, so it includes both
{       valid and unused entries.  The caller of this request must supply this
{       array.   The  actual  size  of the member list (next parameter) can be
{       used to determine  how  many  of  the  member  entries  the  requestor
{       actually obtained.
{            IF size_of_member_list = UPPERBOUND (member_list) THEN
{               All member entries have been gotten.
{            IF size_of_member_list < UPPERBOUND (member_list) THEN
{               Only the actual number of member entries are stored
{               in the lower portion of the array.  All other array
{               entries (the upper portion) are undefined.
{            IF size_of_member_list > UPPERBOUND (member_list) THEN
{               The member_list is filled with entries, but is not big
{               enough to hold all the volumes.  There are
{               size_of_member_list - UPPERBOUND (member_list)
{               additional member entries in the volume set table.
{
{ SIZE_OF_MEMBER_LIST: (output) This returns the number of member  entries  in
{       the master volume set table.
{
{ PF_ROOT_STORED:  (output)  This parameter returns whether the permanent file
{       root has ever been stored in the master volume set table.
{
{ PF_ROOT_SIZE: (output) This parameter returns  the  size  in  bytes  of  the
{       permanent file  root.  This is only defined if PF_ROOT_STORED is TRUE.
{{ PF_ROOT_LOCATOR:   (output)  This  parameter  returns  the  locator  to  the
{       permanent file root.  This locator is a "relative pointer" to the root
{       as  stored  in  this volume set table.  This value is only returned if
{       PF_ROOT_STORED is TRUE.
{
*DECK DECK=STH$OBTAIN_MEMBER_VST_INFO EXPAND=FALSE
{
{   The purpose  of this request is to return information from a member volume
{ set table.  Information returned on the stp$obtain_vst_header request is not
{ returned  on this request.  The volume set table must have been opened prior
{ to this call, and this volume is assumed to be a member volume.
{
{       STP$OBTAIN_MEMBER_VST_INFO (P_VOL_SET_TABLE, MASTER_VSN,
{         MASTER_INTERNAL_VSN)
{
{ P_VOL_SET_TABLE:  (input)  This  parameter specifies a pointer to the member
{       volume set table.  This is assumed valid.
{
{ MASTER_VSN: (output) This parameter returns the name of the master volume of
{       the set that this member belongs to.
{
{ MASTER_INTERNAL_VSN: (output) This parameter returns the internal vsn of the
{       master volume of the set that this member belongs to.
{
*DECK DECK=STH$OBTAIN_VST_HEADER EXPAND=FALSE
{
{   The purpose  of  this  procedure  is  to return information from an opened
{ volume set table.  The information that is returned on this request is  that
{ information that pertains to both master and member volume set tables.
{
{       STP$OBTAIN_VST_HEADER (P_VOL_SET_TABLE, VOLUME, INTERNAL_VSN,
{         VOLUME_IN_SET, SET_NAME, UNIQUE_SET_NAME, VOLUME_STATUS_IN_SET)
{
{ P_VOL_SET_TABLE: (input) This parameter specifies the pointer to the  volume
{       set  table  that  information is desired for.  This is assumed to be a
{       valid pointer.
{
{ VOLUME: (output) This parameter returns the name of the volume  as  recorded
{       in the volume set table.
{
{ INTERNAL_VSN: (output) This parameter returns the internal vsn of the volume
{       as recorded in the volume set table.
{
{ VOLUME_IN_SET: (output) This parameter  indicates  whether  this  volume  is
{       associated  with  a  set,  (according  to  the volume set table).  The
{       volume set table (device file)  should  have  been  destroyed  if  the
{       volume  is  not  in a set.  This can be used as a self check.  If this
{       parameter is FALSE the following fields returned are undefined.
{
{ SET_NAME: (output) This parameter returns  the  name  of  the  set  that  is
{       recorded in the volume set table.
{
{ UNIQUE_SET_NAME: (output) This parameter returns the unique set name.
{
{ VOLUME_STATUS_IN_SET:  (output) This parameter returns whether the volume is
{       a  master  volume  (stc$master_vol)  or  the   member   of   the   set
{       (stc$member_vol).
{
*DECK DECK=STH$OBTAIN_VST_PF_ROOT EXPAND=FALSE
{
{   The purpose of this request is to obtain the permanent file root as stored
{ in the master volume set table.  The master volume set table is assumed open
{ prior  to  this request, and the volume set table is assumed to be that of a
{ master volume.
{
{       STP$OBTAIN_VST_PF_ROOT (P_MASTER_VST, PF_ROOT, STATUS)
{
{ P_MASTER_VOL: (input) This parameter  specifies  a  pointer  to  the  master
{       volume set table that is to be read to obtain the pf root.
{
{ PF_ROOT:  (input,  output)  This  parameter provides a container in which to
{       store the permanent file root.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$incorrect_root_size
{                   ste$pf_root_not_stored
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$OPEN_ATTACHED_VST EXPAND=FALSE
{
{   The purpose  of  this  routine  is to open a volume set table whose device
{ file has already been attached.  The segment attributes are  established  so
{ that the file may be read or written from up to ring 3.  This verifies
{ that the stored version number is the same as the current version.
{
{       STP$OPEN_ATTACHED_VST (VOL, DATA_TO_BE_MODIFIED, SFID,
{         VST_SEGMENT_POINTER, STATUS)
{
{ VOL: (input)  This parameter specifies the volume whose device file is to be
{       opened.
{
{ DATA_TO_BE_MODIFIED: (input)  This parameter specifies whether the requestor
{       is going to modify the volume set table or merely read the volume
{       set table.
{
{ SFID: (input) This parameter specifies the system file  identifier  for  the
{       device file.
{
{ VST_SEGMENT_POINTER: (output) This parameter returns a pointer to the volume
{       set table.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$open_error
{                   ste$vol_set_table_lost_data
{                   ste$incompatible_vst_version
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$OPEN_VST EXPAND=FALSE
{
{   The purpose  of  this  procedure  is  to both attach and open a volume set
{ table for a particular volume.  The stored version name is compared with the
{ current vst version name.
{
{       STP$OPEN_VST (VSN, DATA_TO_BE_MODIFIED, SFID, VST_SEGMENT_POINTER,
{         STATUS)
{
{ VSN: (input) This parameter specifies the volume whose volume set  table  is
{       to be opened.
{
{ DATA_TO_BE_MODIFIED: (input) This parameter specifies whether the requestor
{      is going to modify the volume set table or merely read the volume
{      set table.
{
{ SFID: (output)  This  parameter  returns  the system file identifier for the
{       volume set table device file.
{
{ VST_SEGMENT_POINTER: (output) This parameter returns the segment pointer  to
{       the  volume  set  table.   This  may be used to directly reference the
{       volume set table.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$attach_df_error
{                   ste$vol_not_in_set
{                   ste$open_error
{                   ste$vol_set_table_lost_data
{                   ste$incompatible_vst_version
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$PURGE_AST_PF_ROOT EXPAND=FALSE
{
{   This routine  removes a permanent file root from the active set table.  If
{ there is no root stored no action is taken.  If there is a root stored it is
{ freed and the active set table entry is modified to reflect that there is no
{ longer a permanent file root stored for the set.
{
{       STP$PURGE_AST_PF_ROOT (AST_INDEX)
{
{ AST_INDEX: (input) This parameter specifies the index into  the  active  set
{       table for the set whose permanent file root is to be removed.
{
*DECK DECK=STH$PURGE_PF_ROOT EXPAND=FALSE
{
{   The purpose of this request is to purge the permanent file root for
{ the given set.  The permanent file root may or may not have been stored
{ previously.  If the root was stored previously the root is discarded.
{
{       STP$PURGE_PF_ROOT (SET_NAME, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set for which
{       the permanent file root is to be purged.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$set_not_active
{                    ste$master_not_active
{                    ste$not_allowing_access
{                    ose$job_pageable_full
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$PURGE_SET EXPAND=FALSE
{
{   The purpose of this request is to allow the owner of a set, or the owners
{ administrator, to purge a set.  This means that all trace of the set is
{ removed both from the system and the master volume.  This request can only be
{ issued if there are no users in the master catalog directory for the set,
{ there are no permanent or temporary files on the set, and there are no member
{ volumes on the set.  This request will cause the master volume to be
{ activated, if it is not already so.
{
{       STP$PURGE_SET (SET_NAME, MASTER_VOL, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set we want
{       to purge.
{
{ MASTER_VOL: (input) This parameter specifies the recorded vsn of the
{       master volume of the set.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$bad_set_name
{                    ste$bad_master_vol_desc
{                    ste$users_on_set
{                    ste$master_ast_mismatch
{                    ste$dm_avt_mismatch
{                    ste$attach_df_error
{                    ste$vol_not_in_set
{                    ste$set_not_job_owner
{                    ste$jobs_on_set
{                    ste$vol_on_set
{                    ste$files_on_vol
{                    ste$wrong_master
{                    ste$master_not_active
{                       OTHERS
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$PURGE_VST_PF_ROOT EXPAND=FALSE
{
{   The purpose  of this request is to remove the permanent file root from the
{ master volume set table.  If no permanent  file  root  had  previously  been
{ stored  the  request does not modify the volume set table (and normal status
{ is returned).  If a pf root had been stored it  is  freed  from  the  master
{ volume  set  table,  and  the master volume set table is modified to reflect
{ that the pf root is no longer stored.  This routine attaches  (and  returns)
{ the volume set table (device file).
{
{       STP$PURGE_VST_PF_ROOT (MASTER_VSN, STATUS)
{
{ MASTER_VSN:  (input)  This parameter specifies the name of the master vsn of
{       the set for which the pf root is to  be  removed.   This  is  used  in
{       attaching  the  device  file  (volume  set  table).   This  is assumed
{       correct.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$attach_df_error
{                   ste$open_error
{                   ste$vol_not_in_set
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$REMOVE_INACTIVE_MEMBERS EXPAND=FALSE
{
{   The purpose of this procedure is to remove all inactive member
{ volumes from the specified set.  The master volume of the set must be
{ active.  Great caution should be taken using this request, since
{ the inactive volumes will not be able to be reinstated into the set
{ without being initialized, thus use of this procedure will cause any
{ files on the volumes to no longer be accessable.  This request is only
{ available to the owner of the set.  A previous call to
{ STP$VERIFY_ALL_VOLUMES_ACTIVE may be made to determine if members are
{ inactive.
{
{   STP$REMOVE_INACTIVE_MEMBERS (SET_NAME, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set for
{     which the members are to be removed.
{
{ STATUS: (output) This parameter returns the request status.
{
{     CONDITIONS:
{        ste$bad_set_name
{        ste$master_not_active
{        ste$set_not_active
{        ste$set_not_job_owner
{
*DECK DECK=STH$REMOVE_MEMBER_FROM_MASTER EXPAND=FALSE
{
{   The purpose of this procedure is to remove a member volume from the volume
{ set table of the master.  The master volume set table is assumed open  prior
{ to  this  request.   All  validation (of whether the requestor is allowed to
{ remove a member) must be done outside this request.  This  request  searches
{ the member vsn list in the master volume set table and removes the member if
{ it is found.
{
{       STP$REMOVE_MEMBER_FROM_MASTER (MEMBER_VOL, P_MASTER_VST, STATUS)
{
{ MEMBER_VOL: (input) This parameter specifies the name of the  member  volume
{       that is to be removed.
{
{ P_MASTER_VST:  (input)  This parameter specifies a pointer to the volume set
{       table (device file) for the master volume.  This is assumed valid.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$member_not_in_master
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$REMOVE_MEMBER_FROM_MEL EXPAND=FALSE
{
{   This procedure  removes  a  member volume from the member entry list of an
{ active set table entry for a set.  The set must previously been  located  in
{ the  active set table, prior to calling this request.  The member entry list
{ is searched and bad status is returned if the member is not found.
{
{       STP$REMOVE_MEMBER_FROM_MEL (MEMBER_VOL, AST_INDEX, STATUS)
{
{ MEMBER_VOL: (input) This parameter specifies the name of the  member  volume
{       to remove.
{
{ AST_INDEX:  (input) This parameter specifies the set for which the member is
{       to be removed.  This is assumed to be a valid index  into  the  active
{       set table.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$member_not_in_mel
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$REMOVE_MEMBER_VOL_FROM_SET EXPAND=FALSE
{
{   The purpose of this request is to allow the owner of a set, or the owners
{ administrator, to remove a member volume from a set. Following this request
{ the master volume and member volume are updated to indicate that the
{ volume is no longer associated with a storage set.  This request can only
{ be issued if all permanent files on the member volume have been purged,
{ and all temporary files returned.  Both the master volume, and the
{ member volume will be activated, as a result of this request.
{
{       STP$REMOVE_MEMBER_VOL_FROM_SET (SET_NAME, MEMBER_VOL, MASTER_VOL,
{         STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set that the
{volume
{       is to be deleted from.
{
{ MEMBER_VOL: (input) This parameter specifies the recorded vsn of the
{       member that is to be removed from the set.
{
{ MASTER_VOL: (input) This parameter specifies the recorded vsn of the
{       master volume of the  set.  This is needed if the master volume
{       is not already active.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$bad_set_name
{                    ste$bad_master_vol_desc
{                    ste$bad_member_vol_desc
{                    ste$bad_unique_member
{                    ste$wrong_set_given
{                    ste$job_not_member_owner
{                    ste$set_not_member_owner
{                    ste$dm_avt_index_mismatch
{                    ste$master_not_active
{                    ste$wrong_master
{                    ste$files_on_vol
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$REMOVE_SET_FROM_AST EXPAND=FALSE
{
{   This procedure  removes  a  set  from  the active set table, and makes the
{ entry unused.  This routine does not check the  condition  of  the  set  and
{ unconditionally  (irregardless  of  whether there are members, or a pf root)
{ removes the entry.  If there is a member entry  list  or  a  permanent  file
{ root,  they  are  freed from the mainframe pageable heap.  Validation of the
{ condition of the set,  MUST  and  SHOULD  BE  done  prior  to  calling  this
{ request.
{
{       STP$REMOVE_SET_FROM_AST (AST_INDEX, STATUS)
{
{ AST_INDEX:  (input)  This  parameter specifies the index into the active set
{       table for the entry that is to be removed.  This index is  assumed  to
{       be valid.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$REMOVE_SET_FROM_VST EXPAND=FALSE
{
{   This modifies the volume set table to show that a volume is no longer in a
{ set.
{
{       STP$REMOVE_SET_FROM_VST (P_VST, STATUS)
{
{ P_VST: (input) This specifies the volume set table.  This is assumed to be a
{       valid pointer.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS:
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$REQUEST_DM_VOLUME_INFO EXPAND=FALSE
{
{   This routine interfaces to device management to obtain information about a
{ particular volume.
{
{       STP$REQUEST_DM_VOLUME_INFO (VOLUME, INTERNAL_VSN, VOLUME_OWNER,
{         ACTIVE_VOLUME_TABLE_INDEX, VOLUME_FOUND)
{
{ VOLUME:  (input)  This  parameter specifies the name of the volume for which
{       information is to be returned for.
{
{ INTERNAL_VSN: (output) This  parameter  returns  the  internal  vsn  of  the
{       volume.
{
{ VOLUME_OWNER:  (output)  This parameter returns the name of the owner of the
{       volume.
{
{ ACTIVE_VOLUME_TABLE_INDEX: (output) This parameter returns  the  index  into
{       device managements active volume table.
{
{ VOLUME_FOUND:  (output  This parameter returns whether device management was
{       able to find the volume and return the requested information.
{
*DECK DECK=STH$RETURN_OPENED_VST EXPAND=FALSE
{
{   The purpose of this routine is to close an open volume set table, and then
{ to detach it.
{
{       STP$RETURN_OPENED_VST (SFID, VST_SEGMENT_POINTER, STATUS)
{
{ SFID: (input) This parameter specifies the system file  identifier  for  the
{       volume set table device file.
{
{ VST_SEGMENT_POINTER:  (input,  output)  This parameter specifies the segment
{       pointer to the volume set table.  This pointer may no longer  be  used
{       after this request.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ERRORS FROM DEVICE MANAGEMENT
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$RING2_ADD_MEMBER EXPAND=FALSE
{
{   This procedure  does  the  actual  adding  of  the member volume to a set.
{ Invloved in this is the actual opening of both the  member  and  the  master
{ volume  set tables, and then adding the set in the member, the member in the
{ master volume set table, and the member in the active set table.
{
{       STP$RING2_ADD_MEMBER (SET_NAME, MEMBER_VOL, MEMBER_INTERNAL_VSN,
{         MASTER_VOL, MEMBERS_AVT_INDEX, AST_ENTRY, AST_INDEX,
{         ADD_MEMBER_STATUS)
{
{ SET_NAME: (input) This parameter specifies the name  of  the  set  that  the
{       member is being added to.
{
{ MEMBER_VOL: (input) The volume that is to be added to the set.
{
{ MEMBER_INTERNAL_VSN: (input) The unique name of the new member.
{
{ MASTER_VOL: (input) The name of the master volume of the set.
{
{ MEMBERS_AVT_INDEX:  (input)  The  active  volume  table  index  for  the new
{       member.  Note this must have been gotten from device management  prior
{       to calling this request.  The member is assumed active.
{
{ AST_ENTRY: (input) The entry for the set in the active set table.
{
{ AST_INDEX: (input) The index into the active set table for the set.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$attach_df_error
{                   ste$open_error
{                   ste$dm_avt_index_mismatch
{                   ose$mainframe_pageable_full
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$RING2_CREATE_SET EXPAND=FALSE
{
{   The purpose of this request is to manage the creation of the master volume
{ set table and the establishment of the active set entry.  The master  volume
{ must  be  active  prior to this call; the parameters verified; the requestor
{ validated; and finally a check should have been done to see if  the  set  is
{ already active.  This routine runs in ring 2.
{
{       STP$RING2_CREATE_SET (REQUESTED_SET, REQUESTED_MASTER_VOL,
{          MASTER_INTERNAL_VSN, REQUESTED_SET_OWNER, ACCESS_STATUS,
{          ACTIVE_VOLUME_TABLE_INDEX, ROOT_RECREATED, CREATE_SET_STATUS)
{
{ REQUESTED_SET: (input) This parameter specifies the name of the new set.
{
{ REQUESTED_MASTER_VOL:  (input) This parameter specifies the recorded vsn, of
{       the volume that will be the master volume  of  the  set.   The  volume
{       cannot belong to another set.
{
{ MASTER_INTERNAL_VSN  :  (input)  This parameter specifies the unique vsn for
{       the master volume.
{
{ REQUESTED_SET_OWNER: (input) This parameter specifies the identification  of
{       the user who will be the set owner.
{
{ ACCESS_STATUS:  (input)  This parameter specifies whether the set creator is
{       initially allowing permanent file access to the set.  If this  is  set
{       to  STC$DENY_ACCESS then volumes may still be added to or deleted from
{       sets but no users  will  be  allowed  to  access  permanent  files  or
{       catalogs on the set.
{
{ ACTIVE_VOLUME_TABLE_INDEX:  (input)  This parameter specifies the index into
{       the active volume table for the master volume.
{
{ ROOT_RECREATED: (input) This parameter specifies whether the set is being
{       recreated.  This value is saved in the master vst and is used to control
{       the reloading of missing catalogs.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$master_belongs_to_set,
{                   ose$mainframe_pageable_full
{                   ste$open_error
{                   ste$attach_df_error
{                   ste$push_failed
{                   ste$no_space_vst_heap
{                   ste$dm_avt_index_mismatch
{                   ste$dm_avt_index_mismatch
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$RING2_PURGE_SET EXPAND=FALSE
{
{   The purpose of this procedure is to do the actual removing of the set from
{ the master volume set table and the active set table.   The  parameters  are
{ assumed  valid;  the  master  active; and the requestor the set owner.  This
{ routine verifies that there are no members on the set, and no files  on  the
{ volume.   IF all is OK the set is removed from the active set table, and the
{ volume set table (device file) is destroyed.
{
{       STP$RING2_PURGE_SET (SET_NAME, MASTER_VOL, MASTER_AVT_INDEX,
{         AST_INDEX, AST_ENTRY, STATUS)
{
{ SET_NAME: (output) This parameter specifies the name of the set to purge.
{
{ MASTER_VOL:  (output) This parameter specifies the name of the master volume
{       of the set.
{
{ MASTER_AVT_INDEX: (input) This parameter specifies the active  volume  table
{       index for the master volume.  The master must be active.
{
{ AST_INDEX:  (input)  This  parameter specifies the index into the active set
{       table for this set.
{
{ AST_ENTRY: (input) This parameter specifies the  entry  in  the  active  set
{       table for this set.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$master_ast_mismatch
{                   ste$files_on_vol
{                   ste$vol_on_set (there are members on the set)
{                   ste$dm_avt_mismatch
{                   ste$open_error
{                   ste$attach_df_error
{                   ste$vol_not_in_set
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$RING2_REMOVE_MEMBER EXPAND=FALSE
{
{   This procedure  does  the  actual  removing of a member volume from a set.
{ All validation of the request must have been  done  prior  to  calling  this
{ request.   The  member  is removed from the master volume set table, and the
{ active set table.  The volume set table for the member is destroyed.
{
{       STP$RING2_REMOVE_MEMBER (SET_NAME, MEMBER_VOL, MASTER_VOL, AST_ENTRY,
{         AST_INDEX, REMOVE_MEMBER_STATUS)
{
{ SET_NAME: (input) The name of the set to remove the member from.
{
{ MEMBER_VOL: (input) The member to be removed from the set.
{
{ MASTER_VOL: (input) The master of the set.
{
{ AST_ENTRY: (input) The active set table entry for the set.
{
{ AST_INDEX:  (input) The index into the active set table.  This is assumed to
{       be a valid index.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$attach_df_error
{                   ste$open_error
{                   ste$wrong_set_given
{                   ste$bad_unique_member
{                   ste$vol_not_in_set
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$SEARCH_AST_BY_SET EXPAND=FALSE
{
{   The purpose  of  this routine is to determine if a set is active.  This is
{ done by searching the active set table keyed by set name.   If  the  set  is
{ found  in the active set table, the index and a copy of the active set table
{ entry is returned.
{
{       STP$SEARCH_AST_BY_SET (SET_NAME_KEY, FOUND_AST_ENTRY, FOUND_AST_INDEX,
{         SET_KEY_FOUND)
{
{ SET_NAME_KEY: (input) This parameter specifies the name of the set to search
{       for.
{
{ FOUND_AST_ENTRY: (output)  If  set_key_found  =  TRUE  then  this  parameter
{       returns the active set table entry for the found set.
{
{ FOUND_AST_INDEX:  (output)  IF  set_key_found  =  TRUE  then  this parameter
{       returns the index into the active set table for that set.
{
{ SET_KEY_FOUND: (output) This parameter returns whether the set was found  to
{       be active, that is in the active set table.
{
*DECK DECK=STH$SEARCH_AST_BY_UNIQUE_SET EXPAND=FALSE
{
{   The purpose of this procedure is to determine if a set is active.  This is
{ done by searching the active set table keyed by unique set name.  If the set
{ is  found  in the active set table, the active set table index and a copy of
{ the active set table entry is returned.
{
{       STP$SEARCH_AST_BY_UNIQUE_SET (UNIQUE_SET_KEY, FOUND_AST_ENTRY,
{         FOUND_AST_INDEX, SET_KEY_FOUND)
{
{ UNIQUE_SET_KEY: (input) This parameter specifies the set to search for.
{
{ FOUND_AST_ENTRY:  (output) If set_key_found this parameter returns a copy of
{       the active set table entry for the set.
{
{ FOUND_AST_INDEX: (output) If set_key_found then this parameter  returns  the
{       index into the active set table for the set.
{
{ SET_KEY_FOUND:  (output) This parameter returns whether the set was found in
{       the active set table.
{
*DECK DECK=STH$SEARCH_AST_BY_VOLUME EXPAND=FALSE
{
{   The purpose of this procedure is to determine if a volume is in the active
{ set table.  The volume may be either a member volume or a master volume.  If
{ the  volume  is found the active set table index for the set that the volume
{ belongs to is returned.  The volume may be either active or inactive.
{
{       STP$SEARCH_AST_BY_VOLUME (VOLUME, AST_ENTRY, AST_INDEX, VOLUME_FOUND)
{
{ VOLUME: (input) This parameter specifies the recorded vsn of the  volume  to
{       search for.
{
{ AST_ENTRY:  (output)  If  volume_found  this parameter returns a copy of the
{       active set table entry that the volume belongs to.
{
{ AST_INDEX: (output) If volume_found this parameter returns  the  active  set
{       table index to the set that the volume belongs to.
{
{ VOLUME_FOUND:  (output)  This parameter returns whether the volume was found
{       in the active set table.
{
*DECK DECK=STH$SEARCH_JAST_FOR_SET EXPAND=FALSE
{
{   The purpose  of  this  request  is  to  determine  if a job has previously
{ accessed the set.  This is done by searching the job active set table  keyed
{ by set name.
{
{       STP$SEARCH_JAST_FOR_SET (REQUIRED_SET, JAST_ENTRY, SET_FOUND)
{
{ REQUIRED_SET:  (output)  This  parameter  specifies  the  name of the set to
{       search for.
{
{ JAST_ENTRY: (output) This parameter returns the entry into  the  job  active
{       set table.  This is only valid if set_found = TRUE.
{
{ SET_FOUND:  (output)  This  indicates whether the job has previosly accessed
{       the set for permanent file functions.  If TRUE the set  was  found  in
{       the job active set table, if FALSE it was not found.
{
{
*DECK DECK=STH$SEARCH_MEL_FOR_VOL EXPAND=FALSE
{
{   This procedure  searches  a member entry list of an active set table entry
{ for a specific volume.  The set must previously have been located  prior  to
{ calling this request.
{
{       STP$SEARCH_MEL_FOR_VOL (MEMBER_VOL, AST_INDEX, MEMBER_ENTRY,
{         MEL_INDEX, VOLUME_FOUND)
{
{ MEMBER_VOL: (input) This parameter specifies the name of the  member  volume
{       to search for.
{
{ AST_INDEX:  (input) This parameter specifies the set for which the member is
{       to be found.  This is assumed valid.
{
{ MEMBER_ENTRY: (output) This parameter returns the entry in the member  entry
{       list  of  the  active set table.  This is only valid if volume_found =
{       true.
{
{ MEL_INDEX: (output) This parameter returns the index into the  member  entry
{       list  of  the  active  set  table, for the found volume.  This is only
{       valid if volume_found = true.
{
{ VOLUME_FOUND: (output) This parameter returns whether the member volume  was
{       found.
{
*DECK DECK=STH$SEARCH_MEMBER_LIST EXPAND=FALSE
{
{   The purpose  of  this routine is to search a volume list (stt$volume_list)
{ for a particular volume.  This volume list is an array of the type  returned
{ by    the    STP$GET_VOLUMES_IN_SET,   STP$GET_VOLUMES_BY_SET_ORDINAL,   and
{ STP$GET_JOBS_SCRATCH_VOLUMES requests.
{
{       STP$SEARCH_MEMBER_LIST (VOLUME, MEMBER_LIST, NUMBER_OF_MEMBERS,
{         VOLUME_INFO, STATUS)
{
{ VOLUME: (input) This parameter specifies the volume to search for.
{
{ MEMBER_LIST:  (input)  This  parameter specifies the volume_list in which to
{       search.
{
{ NUMBER_OF_MEMBERS: (input) This parameter specifies the number of entries in
{       the volume_list to search.
{
{ VOLUME_INFO:  (output)  This  parameter  returns the entry if the volume was
{       found.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$vol_not_in_set
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$SEARCH_MVL_FOR_UNUSED_ENTRY EXPAND=FALSE
{
{   The purpose  of  this procedure is to locate an unused entry in the member
{ vsn list of a master volume set table.   The  master  volume  set  table  is
{ assumed  open  prior  to  this request, and a pointer to the member vsn list
{ must have been constructed.  If an unused entry is found the  index  to  the
{ entry is returned.
{
{       STP$SEARCH_MVL_FOR_UNUSED_ENTRY (P_MEMBER_VSN_LIST, MVL_INDEX,
{         UNUSED_ENTRY_FOUND)
{
{ P_MEMEBER_VSN_LIST: (input) This parameter specifies a pointer to the member
{       vsn  list  in  the  master  volume  set  table (device file).  If this
{       pointer is NIL, unused_entry_found is returned as FALSE, and no action
{       is  taken.   If  this  pointer  is  not NIL its value is assumed to be
{       legal.
{
{ MVL_INDEX: (output) IF unused_entry_found = TRUE this returns the  index  to
{       the  unused  entry.   IF unused_entry_found = FALSE then this value is
{       undefined.
{
{ UNUSED_ENTRY_FOUND: (output) This parameter returns whether an unused  entry
{       was found in the member vsn list of the master volume set table.
{       NOTE: This routine makes NO attempt to create an unused entry  if  one
{       does not exist at the time of this call.
{
*DECK DECK=STH$SET_AST_PF_LOCK EXPAND=FALSE
{
{   The purpose  of  this routine is to attempt to set the permanent file lock
{ in the active set table.  This routine does not wait for the lock  and  will
{ return abnormal status if the lock is busy.
{
{       STP$SET_AST_PF_LOCK (AST_INDEX, STATUS)
{
{ AST_INDEX: (input) This parameter specifies the set.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$lock_set_in_task
{                   ste$lock_set_in_another_task
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$SET_END_JOB EXPAND=FALSE
{
{    The purpose of this request is to allow job management to notify
{ set management that a particular job is to be terminated.  This request
{ must be timed in job termination such that:
{   .The set manager can still get to tables allocated in the job
{    pageable heap, and can still reference static pointers to such tables.
{   .There is no more permanent file use in the job (including use by
{    operating system) .
{ This interface is needed so that set management can free the job
{ tables, and maintain an accurate count of the number of jobs using
{ a set.
{
{       STP$SET_END_JOB (STATUS)
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$jast_ast_mismatch
{                       OTHERS
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$SET_EXCLUSIVE_ACCESS EXPAND=FALSE
{
{   The purpose  of  this  request  is to get the set management exclusive use
{ lock.  This lock is maintained as a  ring  1  static  variable.   This  lock
{ implies  (by  protocol)  that  the requestor can both read and write the set
{ management tables.  This routine will wait until the lock can be set.
{
{       STP$SET_EXCLUSIVE_ACCESS
{
*DECK DECK=STH$SET_PF_LOCK EXPAND=FALSE
{
{   The purpose of this request is to set a permanent file lock for the
{ specified set.  The use of the lock is controlled by the caller of this
{ request.  The lock has no affect on the set manager requests dealing
{ with the PF roots.
{
{       STP$SET_PF_LOCK (SET_NAME, WAIT, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set for which
{      the permanent file lock is to be set.
{
{ WAIT: (input) This parameter specifies the wait or nowait option.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$set_not_active
{                    ste$master_not_active
{                    ste$lock_set_in_task
{                    ste$not_allowing_access
{                    ose$job_pageable_full
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$SET_READ_ACCESS EXPAND=FALSE
{
{   The purpose  of this request is to set the set management read lock.  This
{ lock implies (by  protocol)  that  the  requestor  may  only  read  the  set
{ management tables.  Other requestors may have the read lock set concurrently
{ but no requestor may have the exclusive lock.
{
{       STP$SET_READ_ACCESS
{
*DECK DECK=STH$STORE_AST_MASTER_HEADER EXPAND=FALSE
{
{   The purpose  of  this  procedure  is to store information about the master
{ volume in the active set table when the master volume has become active  and
{ the  active set table entry exists.  This information is all obtainable from
{ the master volume set table.
{
{       STP$STORE_AST_MASTER_HEADER (AST_INDEX, MASTERS_AVT_INDEX, SET_OWNER,
{         DM_PACKET_STORAGE, PF_ROOT_STORED, PF_ROOT, STATUS)
{
{ AST_INDEX: (input) This parameter specifies the set.  The set must have been
{       located in the active set table prior to calling this procedure.
{
{ MASTERS_AVT_INDEX: (input) This parameter specified  the  device  management
{       active  volume  table  index for the master volume.  This was an input
{       parameter on the STP$DISK_VOLUME_ACTIVE request.
{
{ SET_OWNER: (input) This parameter specifies the set owner.
{
{ DM_PACKET_STORAGE: (input) This parameter specifies  the  device  management
{       storage record for the master volume of this set.
{
{ PF_ROOT_STORED:  (input) This parameter specifies whether the permanent file
{       root has ever been stored.  IF TRUE the pf root parameter is  used  to
{       store the pf root into the active set table.
{
{ PF_ROOT:  (input) This parameter specifies the permanent file root.  This is
{       only used if PF_ROOT_STORED = TRUE.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ose$mainframe_pageable_full
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$STORE_AST_PF_ROOT EXPAND=FALSE
{
{   The purpose  of  this  procedure  is to store a permanent file root in the
{ active set table for a set.  The set must have already been located  in  the
{ active set table.  If there is already a permanent file root stored for this
{ set it is released and the new one stored.
{
{       STP$STORE_AST_PF_ROOT (AST_INDEX, PF_ROOT, STATUS)
{
{ AST_INDEX: (input) This parameter specifies the set.
{
{ PF_ROOT: (input) This parameter specifies the new permanent file root to  be
{       stored in the active set table entry for this set.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ose$mainframe_pageable_full
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$STORE_DM_PACKET_IN_MASTER EXPAND=FALSE
{
{   The purpose of this request is to store a members device management packet
{ in the member vsn list of the master volume set table.  The device file  for
{ the  master volume set table is attached and opened, and the member vsn list
{ is searched for the member volume.   If  the  member  is  found  the  device
{ management  packet  storage  is stored.  The master volume set table is then
{ closed and returned.  This routine is called when a  member  volume  becomes
{ inactive.
{
{       STP$STORE_DM_PACKET_IN_MASTER (MASTER_VSN, INACTIVE_MEMBER,
{         NEW_DM_PACKET_STORAGE, STATUS)
{
{ MASTER_VSN: (input) This parameter specifies the name of the  master  volume
{       for  the  set  that  the member (whose packet is being stored) belongs
{       to.
{
{ INACTIVE_MEMBER: (input) This parameter specifies the  name  of  the  member
{       volume whose packet storage is to be updated.
{
{ NEW_DM_PACKET_STORAGE:  (input)  This parameter specifies the packet storage
{       record.  Included in this record  is  an  indication  of  whether  the
{       device  management  packet  has  been  stored, and IF TRUE, the actual
{       device management packet.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$vol_not_found
{                   ste$vol_not_in_set
{                   ste$open_error
{                   ste$attach_df_error
{                   ste$attach_df_error
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$STORE_DM_PACKET_IN_MEL EXPAND=FALSE
{
{   This routine  stores  the  device  management  packet storage record for a
{ member volume in the active set table.  The set, and the  member  must  have
{ been found in the active set table prior to this call.
{
{       STP$STORE_DM_PACKET_IN_MEL (AST_INDEX, MEL_INDEX, DM_PACKET_STORAGE)
{
{ AST_INDEX:  (input)  This  parameter  specifies  the  set.   This is assumed
{       valid.
{
{ MEL_INDEX: (input) This parameter specifies the index into the member  entry
{       list for the set.  This is assumed valid.
{
{ DM_PACKET_STORAGE:  (input)  This  parameter specifies the device management
{       packet storage record for the member volume.
{
*DECK DECK=STH$STORE_DM_PACKET_IN_MVL EXPAND=FALSE
{
{   The purpose  of  this  request  is  to  store the device management packet
{ storage into the member volume list of the master volume set  table.   Prior
{ to  this  request  the  pointer  to  the  member  vsn  list  must  have been
{ constructed (and hence the master opened) and the index into the member  vsn
{ list  for  the  member  must  have  been  found.  No validation of the input
{ parameters are done on this request.
{
{       STP$STORE_DM_PACKET_IN_MVL (P_MEMBER_VSN_LIST, MVL_INDEX,
{         DM_PACKET_STORAGE)
{
{ P_MEMBER_VSN_LIST:  (input)  This  parameter  specifies  the  pointer to the
{       member vsn list in the master volume set table.
{
{ MVL_INDEX: (input) This parameter specifies the index into  the  member  vsn
{       list  where the dm packet storage is to be stored.  This is assumed to
{       be the correct value.
{
{ DM_PACKET_STORAGE: (input) This parameter specifies the packet storage.
{
*DECK DECK=STH$STORE_INACTIVE_MASTER EXPAND=FALSE
{
{   The purpose  of  this  procedure  is to store information about the master
{ volume in a new active set table entry.   The  active  set  table  entry  is
{ assumed  uninitialized  prior  to  this  call.   The entry is initialized to
{ indicate that there are no member volumes and that  the  master  volume  has
{ never been active.
{
{       STP$STORE_INACTIVE_MASTER (SET_NAME, UNIQUE_SET_NAME, MASTER_VSN,
{         INTERNAL_VSN, ACCESS_STATUS, AST_INDEX)
{
{ SET_NAME: (input) This parameter specifies the set name to be recorded  into
{       the active set table.
{
{ UNIQUE_SET_NAME: (input) This parameter specifies the unique set name.
{
{ MASTER_VSN:  (input)  This parameter specifies the name of the master volume
{       of the set.
{
{ INTERNAL_VSN: (input) This parameter  specifies  the  internal  vsn  of  the
{       master volume of the set.
{
{ ACCESS_STATUS:  (input)  This  parameter specifies the access status for the
{       set.
{
{ AST_INDEX: (input) This parameter specifies the index into  the  active  set
{       table for the entry that is to be initialized.
{
*DECK DECK=STH$STORE_MASTER_DM_PACKET EXPAND=FALSE
{
{   The purpose  of  this  request  is  to  store the device management packet
{ storage into the master volume set table.  The master volume  set  table  is
{ assumed open prior to calling this request.
{
{       STP$STORE_MASTER_DM_PACKET (P_MASTER_VST, DM_PACKET_STORAGE)
{
{ P_MASTER_VST: (input) This parameter specifies the pointer to the volume set
{       table of the master in which the packet storage is to be stored.
{
{ DM_PACKET_STORAGE: (input) This parameter specifies  the  device  management
{       packet storage for the volume.
{
*DECK DECK=STH$STORE_MEMBER_DM_PACKET EXPAND=FALSE
{
{   The purpose  of  this  request  is  to  store the device management packet
{ storage into the member volume list of the master volume set table.  On this
{ request  the  master  must  have been opened prior to this call.  The member
{ volume list will be searched for the requested member volume, and  an  error
{ returned if not found.
{
{       STP$STORE_MEMBER_DM_PACKET (P_MASTER_VST, INACTIVE_MEMBER,
{         DM_PACKET_STORAGE, STATUS)
{
{ P_MASTER_VST: (input) This parameter specifies the  pointer  to  the  master
{       volume set table.
{
{ INACTIVE_MEMBER:  (input)  This  parameter  specifies the name of the member
{       volume for which  the  device  management  packet  storage  is  to  be
{       stored.
{
{ DM_PACKET_STORAGE:  (input)  This parameter specifies the packet storage for
{       the member volume.  Recall that the packet storage  indicates  whether
{       the  device  management packet is being stored and if TRUE, the packet
{       is included.  Thus this parameter  can  be  used  both  to  store  and
{       initialize a packet storage field.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$vol_not_found
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$STORE_PF_ROOT EXPAND=FALSE
{
{   The purpose of this request is to store the permanent file root for the
{ given set.  The permanent file root may of may not have been stored
{ previously.  If the root was stored previously the old root is discarded.
{
{       STP$STORE_PF_ROOT (SET_NAME, PF_ROOT, STATUS)
{
{ SET_NAME: (input) This parameter specifies the name of the set for which
{       the permanent file root is to be stored.
{
{ PF_ROOT: (input) This parameter specifies the permanent file root that is
{       to be stored by the set manager.
{       This is assumed to be an adaptable sequence.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$set_not_active
{                    ste$master_not_active
{                    ste$space_unavailable_ast
{                    ste$no_space_vst_heap
{                    ste$not_allowing_access
{                    ose$job_pageable_full
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$STORE_VST_BEING_MODIFIED EXPAND=FALSE
{
{    The purpose of this procedure is to store into the volume set table
{ indication that the device file is going to be modified.
{
{       STP$STORE_VST_BEING_MODIFIED (P_VST, STATUS)
{
{ P_VST: (input)  This parameter specifies the volume set table that will be
{       modifed.
{
{ STATUS: (output) This parameter returns the request status.
{
*DECK DECK=STH$STORE_VST_PF_ROOT EXPAND=FALSE
{
{   The purpose  of  this request is to store the permanent file root into the
{ master volume set table.  There is no validation done in this request.  This
{ request  will  attach  the  volume  set table as specified by the master vsn
{ parameter and store the pf root into the volume set table.  If a pf root had
{ previously been stored the old pf root will be discarded.
{
{       STP$STORE_VST_PF_ROOT (MASTER_VSN, PF_ROOT, STATUS)
{
{ MASTER_VSN:  (input) This parameter specifies the name of the master vsn for
{       the set that the pf root is being stored.  This is assumed correct.
{
{ PF_ROOT: (input) This specifies the permanent file root to be stored.   This
{       is assumed to be an adaptable sequence.
{
{ STATUS: (output) This parameter returns the request status.
{
{       CONDITIONS: ste$no_space_vst_heap
{                   ste$attach_df_error
{                   ste$open_error
{                   ste$vol_not_in_set
{
{       IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$TRANSLATE_SET_ORDINAL EXPAND=FALSE
{
{   The purpose of this procedure is to return the external set name
{ given just a set ordinal.
{
{       STP$TRANSLATE_SET_ORDINAL (SET_ORDINAL, SET_NAME, STATUS)
{
{ SET_ORDINAL: (input) This parameter specifies the set ordinal for
{       the set that the external set name is desired.
{
{ SET_NAME: (output) This parameter returns the external set name.
{
{ STATUS: (output) This parameter returns the request status.
{
{        CONDITIONS: ste$set_not_active
{                    ste$set_ord_not_set
{
{        IDENTIFIER: stc$set_management_id
{
*DECK DECK=STH$VERIFY_ALL_VOLUMES_ACTIVE EXPAND=FALSE
{
{   The purpose of this procedure is to verify that all volumes in the
{ requested set are active.
{
{   STP$VERIFY_ALL_VOLUMES_ACTIVE (SET_NAME, STATUS)
{
{  SET_NAME: (input) This parameter specifies the name of the set that
{        verification is to be done on.
{
{  STATUS: (output) This parameter returns the request status.
{        If all volumes are not active then the status text has information
{        about which members are not active.
{
*DECK DECK=STH$VOLUME_SET_TABLE EXPAND=FALSE
{
{  VOLUME_SET_TABLE   (VST)
{
{  PURPOSE:
{    The volume set table preserves information about a set, and the
{    volumes in a set.  This information is maintained on the volume,
{    and is recoverable.
{  WHEN ACCEDDED.
{    All accessing of the VST is done by the set manager.
{    MODIFIED:
{    -  When volumes are added to a set, or a new set created a
{       volume set table is created on the volume.
{    -  When member volumes are added to a set, the volume is
{       listed in the master volume set table.
{    -  When a pf root is created it is stored in the master
{       volume set table.
{    READ:
{    -  When a volume becomes active, the VST is read to determine
{       what set the volume belongs to, and whether the volume is
{       a member or a master.
{       The information is transfered to the active set table.
{  RESIDENCY:
{    The volume set table is a device file on each volume.
{    Its ring attributes are 3, 3.
{    The device file name is STF$VOLUME_SET_TABLE CAT RECORDED_VSN.
{    The volume set table is read/written in ring 2, on a create_set,
{          or add_member_to_set.
{    The vst is read/written from ring 1 on a volume_active.
{  FIELDS:
{    stt$vol_set_table = record
{       data_being_modified:  This field is used for device file integrity
{             checking.  This string should be initialized to 'TRUE ' at
{             the start of a open for modify, and set to 'FALSE' at the
{             end of the operation.
{      version_name:
{      vsn:
{      internal_vsn:
{      case entry_type: Is the volume in a set? (should always be )
{      = stc$valid =
{        set_name:
{        unique_set_name:
{        case vol_status_in_set: Member or Master?
{        = stc$member_vol =
{          master_vsn: The name of the master volume
{                that this member belongs to.
{          master_internal_vsn:
{        = stc$master_vol =
{          set_owner:
{          master_dm_packet_storage:
{          member_vsn_list_locator: A "pointer" to the list of members
{          pf_root_storage: Indicates if the PF root has been stored.
{          vst_heap: ALIGNED [0 MOD 32] ost$heap,
{    stt$member_vsn_entry = record
{      case entry_type: stt$entry_type of
{      = stc$valid =
{        member_vsn:
{        member_internal_vsn:
{        member_dm_packet_storage:
*DECK DECK=STK$KEYPOINTS EXPAND=FALSE

{ PURPOSE:
{   This deck contains all of the set manager keypoint constants.

  CONST
    {ENTRY/EXIT CLASS KEYPOINTS }
    {gated entry points for users}

    stk$create_set = stk$base + 1,
      {E  'stp$create_set' 'ring    ' H }
      {X  'stp$create_set' 'status  ' I20 }

    stk$purge_set = stk$base + 2,
      {E  'stp$purge_set' }
      {X  'stp$purge_set' 'status  ' I20 }

    stk$add_member_vol_to_set = stk$base + 3,
      {E  'stp$add_member_vol_to_set' }
      {X  'stp$add_member_vol_to_set' 'status  ' I20 }

    stk$remove_member_vol_from_set = stk$base + 4,
      {E  'stp$remove_member_vol_from_set' }
      {X  'stp$remove_member_vol_from_set' 'status  ' I20 }

    stk$change_access_to_set = stk$base + 5,
      {E  'stp$change_access_to_set' 'access  ' H20 }
      {X  'stp$change_access_to_set' 'status  ' I20 }

    {interfaces into sets from other functional areas }
    {calls from device management }

    stk$get_jobs_scratch_volumes = stk$base + 10,
      {E  'stp$get_jobs_scratch_volumes' }
      {X  'stp$get_jobs_scratch_volumes' }

    stk$get_volumes_in_set = stk$base + 11,
      {E  'stp$get_volumes_in_set' 'setinit ' H20 }
      {X  'stp$get_volumes_in_set' }

    stk$get_volumes_by_set_ordinal = stk$base + 12,
      {E  'stp$get_volumes_by_set_ordinal' }
      {X  'stp$get_volumes_by_set_ordinal' }

    stk$get_volumes_set_name = stk$base + 13,
      {E  'stp$get_volumes_set_name' }
      {X  'stp$get_volumes_set_name' }

    stk$is_volume_in_set = stk$base + 14,
      {E  'stp$is_volume_in_set' }
      {X  'stp$is_volume_in_set' }

    stk$disk_volume_active = stk$base + 15,
      {E  'stp$disk_volume_active' 'avtindx ' H20 }
      {X  'stp$disk_volume_active' 'status  ' I20 }

    stk$disk_volume_inactive = stk$base + 16,
      {E  'stp$disk_volume_inactive' 'setord  ' H20 }
      {X  'stp$disk_volume_inactive' 'status  ' I20 }

    stk$get_internal_volumes_set = stk$base + 17,
      {E 'stp$get_internal_volumes_set' }
      {X 'stp$get_internal_volumes_set' }

    {calls from permanent files }

    stk$get_pf_root_size = stk$base + 20,
      {E  'stp$get_pf_root_size' }
      {X  'stp$get_pf_root_size' 'status  ' I20 }

    stk$get_pf_root = stk$base + 21,
      {E  'stp$get_pf_root' }
      {X  'stp$get_pf_root' 'status  ' I20 }

    stk$store_pf_root = stk$base + 22,
      {E  'stp$store_pf_root' }
      {X  'stp$store_pf_root' 'status  ' I20 }

    stk$purge_pf_root = stk$base + 23,
      {E  'stp$purge_pf_root' }
      {X  'stp$purge_pf_root' 'status  ' H20 }

    stk$get_set_owner = stk$base + 24,
      {E  'stp$get_set_owner' }
      {X  'stp$get_set_owner' 'status  ' I20 }

    stk$set_pf_lock = stk$base + 25,
      {E  'stp$set_pf_lock' }
      {X  'stp$set_pf_lock' 'status  ' I20 }

    stk$clear_pf_lock = stk$base + 26,
      {E  'stp$clear_pf_lock' }
      {X  'stp$clear_pf_lock' 'status  ' I20 }

    {call from job management}

    stk$set_end_job = stk$base + 27,
      {E  'stp$set_end_job' }
      {X  'stp$set_end_job' 'status  ' I20 }

    {call during deadstart sequence }

    stk$initialize_sets = stk$base + 29,
      {E  'stp$initialize_sets' }
      {X  'stp$initialize_sets' 'status  ' I20 }

    stk$get_active_set_list = stk$base + 30,
      {E  'stp$get_active_set_list' 'setlis  ' I20 }
      {X  'stp$get_active_set_list' 'numset  ' I20 }

    stk$verify_all_volumes_active = stk$base + 31,
    {E 'stp$verify_all_volumes_active' }
    {X 'stp$verify_all_volumes_active' 'status  ' I20 }


    { UNUSUAL CLASS keypoints }

    stk$cant_dm_store_set_ord = stk$base,
      {U  'cant dmp$store_avt_set_ordinal' 'avtindx ' H20 }


    { DEBUG keypoints }

    stk$set_exclusive_lock = stk$base,
      {D  'set exclusive access' }

    stk$clear_exclusive_lock = stk$base + 1,
      {D  'clear exclusive access' }

    stk$ast_index_assigned = stk$base + 2,
      {D  'active set table index assigned' 'astindx ' H20 }

    stk$new_job_accessing_set = stk$base + 3,
      {D  'first pf access of sets within job' }

    stk$mel_index_assigned = stk$base + 4,
      {D  'mel index assigned - ast index V' 'status  ' I20 }

    stk$pf_root_size = stk$base + 5;
      {D  'pf_root_size' 'rootsiz ' H20 }

?? PUSH (LISTEXT := ON) ??
*copyc AMK$BASE_KEYPOINT_VALUES
?? POP ??
*DECK DECK=STM$ACTIVATE_SET EXPAND=TRUE
?? RIGHT := 110 ??
MODULE stm$activate_set;
?? PUSH (LISTEXT := ON) ??
*copyc amp$close
*copyc amp$get_next
*copyc avp$configuration_administrator
*copyc avp$system_operator
*copyc avp$initialize_family
*copyc clc$standard_file_names
*copyc clp$get_value
*copyc clp$put_job_output
*copyc clp$scan_parameter_list
*copyc cmp$lock_set_by_task
*copyc cmp$manage_lcu_lock
*copyc dfp$rebuild_set_table_clients
*copyc fsp$open_file
*copyc jmc$job_management_id
*copyc jme$queued_file_conditions
*copyc jmp$recover_input_queue
*copyc jmp$system_job
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc ofe$error_codes
*copyc osp$add_family
*copyc osp$generate_message
*copyc osp$generate_output_message
*copyc osp$press_return_to_continue
*copyc osp$set_status_abnormal
*copyc osv$lower_to_upper
*copyc pfp$find_directory_array
*copyc pfp$find_next_info_record
*copyc pfp$get_family_info
*copyc pfp$overhaul_set
*copyc pmp$get_job_names
*copyc qfp$activate_deferred_family
*copyc std$active_set_table
*copyc std$miscellaneous
*copyc ste$error_condition_codes
*copyc stp$change_access_to_set
*copyc stp$get_active_set_list
*copyc stp$remove_inactive_members
*copyc stp$search_ast_by_set
*copyc stp$verify_all_volumes_active
*copyc stv$system_set_name
*copyc syp$process_deadstart_status
?? POP ??

?? TITLE := 'PROCEDURE stp$activate_set_command', EJECT ??

  PROCEDURE [XDCL, #GATE] stp$activate_set_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PDT activate_set_pdt (
{     set_name, sn: name 1..31 = $required
{     validate_set, vs: boolean = TRUE
{     delete_unreconciled_files, duf: boolean = FALSE
{     defer_input_queue, diq: boolean = FALSE
{     status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    activate_set_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table
  := [^activate_set_pdt_names, ^activate_set_pdt_params];

  VAR
    activate_set_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults]
  array [1 .. 9] of clt$parameter_name_descriptor := [['SET_NAME', 1], ['SN', 1
  ], ['VALIDATE_SET', 2], ['VS', 2], ['DELETE_UNRECONCILED_FILES', 3], ['DUF',
  3], ['DEFER_INPUT_QUEUE', 4], ['DIQ', 4], ['STATUS', 5]];

  VAR
    activate_set_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 5]
  of clt$parameter_descriptor := [

{ SET_NAME SN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$name_value, 1, 31]],

{ VALIDATE_SET VS }
    [[clc$optional_with_default, ^activate_set_pdt_dv2], 1, 1, 1, 1,
  clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ DELETE_UNRECONCILED_FILES DUF }
    [[clc$optional_with_default, ^activate_set_pdt_dv3], 1, 1, 1, 1,
  clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ DEFER_INPUT_QUEUE DIQ }
    [[clc$optional_with_default, ^activate_set_pdt_dv4], 1, 1, 1, 1,
  clc$value_range_not_allowed, [NIL, clc$boolean_value]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  clc$variable_reference, clc$array_not_allowed, clc$status_value]]];

  VAR
    activate_set_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (4
  ) := 'TRUE';

  VAR
    activate_set_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (5
  ) := 'FALSE';

  VAR
    activate_set_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (5
  ) := 'FALSE';

?? FMT (FORMAT := ON) ??
?? POP ??

    VAR
      defer_input_queue: boolean,
      delete_unreconciled_files: boolean,
      set_name: stt$set_name,
      set_overhaul_choices: pft$set_overhaul_choices,
      validate_set: boolean,
      value: clt$value;

    IF NOT (avp$configuration_administrator () OR avp$system_operator ()) THEN
      osp$set_status_abnormal ('OF', ofe$sou_not_active,
            'configuration_administration, system_operation', status);
      RETURN;
    IFEND;
    clp$scan_parameter_list (parameter_list, activate_set_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('VALIDATE_SET', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    validate_set := value.bool.value;

    clp$get_value ('DELETE_UNRECONCILED_FILES', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    delete_unreconciled_files := value.bool.value;

    clp$get_value ('SET_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    set_name := value.name.value;

    clp$get_value ('DEFER_INPUT_QUEUE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    defer_input_queue := value.bool.value;

    set_overhaul_choices := $pft$set_overhaul_choices [];
    IF validate_set OR delete_unreconciled_files THEN
      set_overhaul_choices := $pft$set_overhaul_choices [pfc$all_catalogs, pfc$validate_files,
            pfc$reorganize_catalogs, pfc$reconcile_fmds, pfc$recover_purged_files];
      IF delete_unreconciled_files THEN
        set_overhaul_choices := $pft$set_overhaul_choices [pfc$delete_unreconciled_objects] +
            set_overhaul_choices;
      IFEND;
    IFEND;

    stp$activate_set (set_name, {allow_set_termination=} FALSE, set_overhaul_choices,
          {activating_during_deadstart=}FALSE, defer_input_queue, status);

  PROCEND stp$activate_set_command;

?? TITLE := 'stp$activate_set', EJECT ??

  PROCEDURE stp$activate_set (input_set_name: stt$set_name;
                            allow_set_termination: boolean;
                            set_overhaul_choices: pft$set_overhaul_choices;
                            activating_during_deadstart: boolean;
                            defer_input_queue: boolean;
                            VAR status: ost$status);

    VAR
      ast_entry: stt$active_set_entry,
      ast_found: boolean,
      ast_index: stt$ast_index,
      continue: boolean,
      local_status: ost$status,
      lock_set: boolean,
      logical_unit: iot$logical_unit,
      set_name: stt$set_name,
      system_supplied_name: jmt$system_supplied_name,
      user_supplied_name: jmt$user_supplied_name;

    status.normal := TRUE;
    lock_set := FALSE;

  /main_program/
    BEGIN


      IF NOT cmp$lock_set_by_task (cmc$configuration_administrator) THEN
        pmp$get_job_names (user_supplied_name, system_supplied_name, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        cmp$manage_lcu_lock (cmc$configuration_administrator, FALSE,
              system_supplied_name, status);
        IF NOT status.normal THEN
          EXIT /main_program/;
        IFEND;
        lock_set := TRUE;
      IFEND;
      set_name := input_set_name;

      stp$search_ast_by_set (set_name, ast_entry, ast_index, ast_found);
      IF ast_found THEN
        IF ast_entry.access_status = stc$allow_access THEN
          osp$set_status_abnormal (stc$set_management_id, ste$set_already_active, set_name, status);
          EXIT /main_program/;
        IFEND;
      IFEND;

      stp$verify_all_volumes_active (set_name, status);
      IF status.condition = ste$set_not_active THEN
        status.condition := ste$quit_lcu;
      IFEND;
      IF NOT status.normal THEN
        IF status.condition = ste$all_volumes_not_active THEN
          osp$generate_message (status, local_status);
          {Ask operator if activate_set should continue
          clp$put_job_output (' Do you wish to continue this set activation?', status);
          wait_for_go (continue);
          IF NOT continue THEN
            clp$put_job_output (' Set activation terminated', status);
            EXIT /main_program/;
          ELSE
            clp$put_job_output (' Do you want to delete the missing volumes from the set?', status);
            wait_for_go (continue);
            IF continue THEN
              stp$remove_inactive_members (set_name, status);
            IFEND;
          IFEND;
        ELSE
          EXIT /main_program/;
        IFEND;
      IFEND;

      stp$change_access_to_set (set_name, stc$allow_access, status);
      IF NOT status.normal THEN
        EXIT /main_program/;
      IFEND;

      IF set_overhaul_choices <> $pft$set_overhaul_choices [] THEN
        pfp$overhaul_set (set_name, set_overhaul_choices, status);
        IF NOT status.normal THEN
          osp$generate_message (status, local_status);
        IFEND;
      IFEND;

      stp$build_family_list_for_set (set_name, activating_during_deadstart,
            defer_input_queue, status);

    END /main_program/;
    IF lock_set THEN
      cmp$manage_lcu_lock (cmc$configuration_administrator, TRUE,
            system_supplied_name, local_status);
      IF NOT local_status.normal THEN
        IF NOT status.normal THEN
          osp$generate_message (status, local_status);
        IFEND;
        status := local_status;
      IFEND;
    IFEND;

  PROCEND stp$activate_set;

?? TITLE := 'stp$build_family_list_for_set', EJECT ??

  PROCEDURE [XDCL] stp$build_family_list_for_set
    (    set_name: stt$set_name;
         activating_during_deadstart: boolean;
         defer_input_queue: boolean;
     VAR status: ost$status);

    VAR
      family_info: amt$segment_pointer,
      i: integer,
      ignore_status: ost$status,
      local_status: ost$status,
      p_family_directory: pft$p_directory_array,
      p_info_record: pft$p_info_record,
      str: string (143),
      strl: integer;

    status.normal := TRUE;
    local_status.normal := TRUE;
    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_random,
          family_info, status);
    IF status.normal THEN
      RESET family_info.sequence_pointer;
      pfp$get_family_info (set_name, -$pft$catalog_info_selections [],
            family_info.sequence_pointer, status);
      IF status.normal THEN
        RESET family_info.sequence_pointer;
        pfp$find_next_info_record (family_info.sequence_pointer, p_info_record,
              status);
        IF status.normal THEN
          pfp$find_directory_array (p_info_record, p_family_directory, status);
          IF status.normal AND (p_family_directory <> NIL) THEN

          /loop_through_families/
            FOR i := LOWERBOUND (p_family_directory^)
                  TO UPPERBOUND (p_family_directory^) DO
              osp$add_family (p_family_directory^ [i].name, set_name, status);
              IF NOT status.normal THEN
                {The system user of the system set is already added
                IF set_name <> stv$system_set_name THEN
                  STRINGREP (str, strl, ' Family: ', p_family_directory^ [i].name,
                    ' from set: ', set_name);
                  clp$put_job_output (str (1, strl), status);
                  clp$put_job_output ('      duplicates an existing family and cannot be activated',
                    status);
                IFEND;
                status.normal := TRUE;
              IFEND;
              avp$initialize_family (p_family_directory^ [i].name, status);
              IF NOT status.normal THEN
                STRINGREP (str, strl, '  The following error occured while initializing family: ',
                      p_family_directory^ [i].name, ' from set: ', set_name);
                clp$put_job_output (str (1, strl), ignore_status);
                osp$generate_output_message (status, ignore_status);
                status.normal := TRUE;
                osp$press_return_to_continue (ignore_status);
              IFEND;
              dfp$rebuild_set_table_clients (p_family_directory^ [i].name, status);
              IF NOT status.normal THEN
                STRINGREP (str, strl,
                      '  The following error occured while rebuilding set table client info: ',
                      p_family_directory^ [i].name, ' from set: ', set_name);
                clp$put_job_output (str (1, strl), local_status);
                osp$generate_output_message (status, local_status);
                status.normal := TRUE;              IFEND;
              qfp$activate_deferred_family (p_family_directory^ [i].name);
              IF NOT activating_during_deadstart THEN
                jmp$recover_input_queue (p_family_directory^ [i].name, defer_input_queue, status);
                IF NOT status.normal THEN
                  STRINGREP (str, strl,
                        '  The following error occured while recovering the input queue for ',
                        p_family_directory^ [i].name, ' from set: ', set_name);
                  clp$put_job_output (str (1, strl), local_status);
                  osp$generate_output_message (status, local_status);
                  status.normal := TRUE;
                IFEND;
              IFEND;
            FOREND /loop_through_families/;
          IFEND;
        IFEND;
      IFEND;
      mmp$delete_scratch_segment (family_info, local_status);
    IFEND;
  PROCEND stp$build_family_list_for_set;

?? TITLE := 'wait_for_go', EJECT ??

 PROCEDURE wait_for_go
   (VAR continue: boolean);

    VAR
      ba: amt$file_byte_address,
      fid: amt$file_identifier,
      fp: amt$file_position,
      go: string (20),
      s: string (20),
      status: ost$status,
      tc: amt$transfer_count;

    fsp$open_file (clc$job_command_input, amc$record, NIL, NIL, NIL, NIL, NIL,
        fid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    WHILE TRUE DO
      s := 'xx';
      amp$get_next (fid, ^s, #SIZE (s), tc, ba, fp, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      #translate (osv$lower_to_upper, s, go);
      IF (go (1) = 'Y') OR (go (1, 3) = 'YES') THEN
        amp$close (fid, status);
        continue := TRUE;
        RETURN;
      ELSEIF (go (1) = 'N') OR (go (1, 2) = 'NO') THEN
        amp$close (fid, status);
        continue := FALSE;
        RETURN;
      ELSE
        clp$put_job_output ('--ERROR--  You must enter yes or no.  Please try again.', status);
      IFEND;
    WHILEND;
  PROCEND wait_for_go;

?? TITLE := 'stp$activate_deadstart_sets', EJECT ??

  PROCEDURE [XDCL] stp$activate_deadstart_sets
    (    set_overhaul_choices: pft$set_overhaul_choices;
     VAR status: ost$status);

    VAR
      continue: boolean,
      current_set_list_size: integer,
      local_status: ost$status,
      number_of_sets: stt$number_of_sets,
      p_list_of_sets: ^stt$set_list,
      set_number: stt$number_of_sets,
      str: string (80),
      strl: integer;

    CONST
      initial_set_list_size = 10;

    status.normal := TRUE;

    number_of_sets := initial_set_list_size;
    REPEAT
      current_set_list_size := number_of_sets;
      PUSH p_list_of_sets: [1 .. current_set_list_size];
      stp$get_active_set_list (p_list_of_sets^, number_of_sets);
    UNTIL number_of_sets <= current_set_list_size;

    FOR set_number := 1 TO number_of_sets DO
      status.normal := TRUE;
      IF p_list_of_sets^ [set_number] <> stv$system_set_name THEN
        STRINGREP (str, strl, ' Activating Set: ', p_list_of_sets^ [set_number]);
        clp$put_job_output (str (1, strl), status);
        stp$activate_set (p_list_of_sets^ [set_number], FALSE, set_overhaul_choices,
              {activating_during_deadstart=} TRUE, {defer_input_queue} FALSE, status);
      IFEND;

      IF NOT status.normal THEN
        IF status.condition = ste$set_already_active THEN
          status.normal := TRUE;
        ELSE
          osp$generate_message (status, local_status);
          clp$put_job_output (' Set not activated. - Do you wish to continue deadstart?', local_status);
          clp$put_job_output (' Enter YES to continue deadstart or NO to abort deadstart.', local_status);
          wait_for_go (continue);
          status.normal := continue;
          IF NOT continue THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;
    FOREND;

  PROCEND stp$activate_deadstart_sets;

?? TITLE := 'stp$define_family_set', EJECT ??

  PROCEDURE [XDCL, #GATE] stp$define_family_set
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PDT define_family_set_pdt (family_name, fn: name = $required
{                            set_name, sn: name = unspecified
{                            status)

?? PUSH (LISTEXT := ON) ??

  VAR
    define_family_set_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [
      ^define_family_set_pdt_names, ^define_family_set_pdt_params];

  VAR
    define_family_set_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 5] of
      clt$parameter_name_descriptor := [['FAMILY_NAME', 1], ['FN', 1], ['SET_NAME', 2], ['SN', 2], ['STATUS',
      3]];

  VAR
    define_family_set_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of
      clt$parameter_descriptor := [

{ FAMILY_NAME FN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$name_value, 1, osc$max_name_size]],

{ SET_NAME SN }
    [[clc$optional_with_default, ^define_family_set_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$name_value, 1, osc$max_name_size]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    define_family_set_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (11) := 'unspecified';

?? POP ??
    VAR
      family_name: ost$name,
      set_name: stt$set_name,
      value: clt$value;

    IF NOT jmp$system_job () THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$must_be_system_job, 'stp$define_family_set',
          status);
      RETURN;
    IFEND;

    clp$scan_parameter_list (parameter_list, define_family_set_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('FAMILY_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    family_name := value.name.value;

    clp$get_value ('SET_NAME', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    set_name := value.name.value;
    IF set_name = 'UNSPECIFIED' THEN
      set_name := stv$system_set_name;
    IFEND;

    osp$add_family (family_name, set_name, status);

  PROCEND stp$define_family_set;

MODEND stm$activate_set;
*DECK DECK=STM$ADD_MEMBER EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$add_member;

{  PURPOSE:
{    This module provides the compilation unit for the stp$add_member_vol_to_set
{    request.
{
{  DESIGN:
{    Readers desiring understanding of the design should look at the entry point
{    procedure stp$add_member_vol_to_set.


?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc clp$validate_name
*copyc dmt$active_volume_table_index
*copyc ose$heap_full_exceptions
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc pmp$exit
*copyc pmp$get_user_identification
*copyc rmd$volume_declarations
*copyc std$active_set_table
*copyc std$miscellaneous
*copyc ste$error_condition_codes
*copyc stk$keypoints
*copyc stp$attach_vst
*copyc stp$clear_exclusive_access
*copyc stp$detach_vst
*copyc stp$dm_mount_volume
*copyc stp$request_dm_volume_info
*copyc stp$ring2_add_member
*copyc stp$search_ast_by_set
*copyc stp$search_mel_for_vol
*copyc stp$set_exclusive_access
*copyc stp$validate_owner
*copyc stp$validate_recorded_vsn
*copyc stv$system_set_name
?? POP ??
?? TITLE := '  [XDCL, #GATE] stp$add_member_vol_to_set ', EJECT ??

*copyc sth$add_member_vol_to_set

  PROCEDURE [XDCL, #GATE] stp$add_member_vol_to_set (c_set_name: stt$set_name;
        requested_member_vol: rmt$recorded_vsn;
    VAR status: ost$status);
?? EJECT ??

    VAR
      add_member_status: ost$status,
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index,
      converted_master_vol: rmt$recorded_vsn,
      converted_requested_member_vol: rmt$recorded_vsn,
      converted_set_name: stt$set_name,
      member_internal_vsn: dmt$internal_vsn,
      set_name: stt$set_name,
      master_vol: rmt$recorded_vsn,
      set_found_in_ast: boolean,
      members_avt_index: dmt$active_volume_table_index;

    #keypoint (osk$entry, 0, stk$add_member_vol_to_set);
    add_member_status.normal := TRUE;
    set_name := c_set_name;

    {Remain compatible with current system - default to current system set

    IF set_name = 'UNSPECIFIED' THEN
      set_name := stv$system_set_name;
    IFEND;

    {Remain compatible - determine set master

    stp$search_ast_by_set (set_name, ast_entry, ast_index, set_found_in_ast);
    IF set_found_in_ast THEN
      IF ast_entry.master_ever_up THEN
        master_vol := ast_entry.master_vsn;
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, master_vol,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
        RETURN;
      IFEND;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$set_not_active, set_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
      RETURN;
    IFEND;

    validate_add_member_params (set_name, requested_member_vol, master_vol, converted_set_name,
          converted_requested_member_vol, converted_master_vol, add_member_status);
    IF add_member_status.normal THEN
      stp$set_exclusive_access;
      verify_add_vol_exec (converted_set_name, converted_requested_member_vol, converted_master_vol,
            member_internal_vsn, members_avt_index, ast_entry, ast_index, add_member_status);
      IF add_member_status.normal THEN
        stp$ring2_add_member (converted_set_name, converted_requested_member_vol, member_internal_vsn,
              converted_master_vol, members_avt_index, ast_entry, ast_index, add_member_status);
      IFEND;
      stp$clear_exclusive_access;
    IFEND;
    status := add_member_status;
    IF status.normal THEN
      #keypoint (osk$exit, osk$m * ast_index, stk$add_member_vol_to_set);
    ELSE
      #keypoint (osk$exit, 0, stk$add_member_vol_to_set);
    IFEND;
    IF (NOT status.normal) AND (status.condition = ose$mainframe_pageable_full) THEN
      pmp$exit (status);
    IFEND;
  PROCEND stp$add_member_vol_to_set;

?? TITLE := '  validate_add_member', EJECT ??

  PROCEDURE validate_add_member
    (    set_name: stt$set_name;
         requested_member_vol: rmt$recorded_vsn;
         master_vol: rmt$recorded_vsn;
     VAR ast_entry: stt$active_set_entry;
     VAR ast_index: stt$ast_index;
     VAR member_internal_vsn: dmt$internal_vsn;
     VAR members_avt_index: dmt$active_volume_table_index;
     VAR status: ost$status);

{  PURPOSE:
{    This procedure verifies that that the requested user, can perform the
{    add member request, and that there is no conflict (e.g. the member
{    is already on a set.) to prevent adding the member to the set.
{    First the condition of the member is verified via a call to
{    verify_member, then the active set table is looked at.
{    CONDITIONS:
{      ste$wrong_master
{      ste$set_not_master_owner
{      ste$master_not_active
{      ste$member_vol_in_set
{      ste$job_not_member_owner
{      ste$member_not_active

?? PUSH (LISTEXT := ON) ??
?? POP ??

    VAR
      master_avt_index: dmt$active_volume_table_index,
      master_internal_vsn: dmt$internal_vsn,
      master_vol_found: boolean,
      master_vol_owner: ost$user_identification,
      mel_index: stt$mel_index,
      member_entry: stt$member_entry,
      member_found_in_ast: boolean,
      member_owner: ost$user_identification,
      set_found_in_ast: boolean;

    status.normal := TRUE;
    verify_member (requested_member_vol, member_internal_vsn, members_avt_index, member_owner, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    stp$search_ast_by_set (set_name, ast_entry, ast_index, set_found_in_ast);
    IF NOT set_found_in_ast THEN
      stp$request_dm_volume_info (master_vol, master_internal_vsn, master_vol_owner, master_avt_index,
            master_vol_found);
      IF master_vol_found THEN
        {
        { The set was not found active, but the master volume, as given by
        { the requestor, was found, thus the user specified the wrong master
        { for the given set, or the wrong set for the given master.
        {
        osp$set_status_abnormal (stc$set_management_id, ste$wrong_master, master_vol, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
        RETURN;
      ELSE
        {
        { Neither the set or the master volume was found active in the system.
        { This could have been caused by a bad set, and master volume parameter.
        {
        osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, master_vol, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
        RETURN;
      IFEND;
    IFEND;

    IF requested_member_vol = master_vol THEN
      osp$set_status_abnormal (stc$set_management_id, ste$member_vol_in_set, requested_member_vol, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, ast_entry.set_name, status);
      RETURN;
    IFEND;

    IF NOT ast_entry.master_ever_up THEN
      osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, master_vol, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
      RETURN;
    IFEND;

    IF ast_entry.set_owner <> member_owner THEN
      {
      { The set owner must be the same as the member owner.
      {
      osp$set_status_abnormal (stc$set_management_id, ste$set_not_member_owner, member_owner.user, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, member_owner.family, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
      RETURN;
    IFEND;

    IF ast_entry.master_vsn <> master_vol THEN
      {
      { The master supplied by the user, differs from that in the ast.
      {
      osp$set_status_abnormal (stc$set_management_id, ste$wrong_master, master_vol, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
      RETURN;
    IFEND;

    IF ast_entry.master_volume_activity.volume_activity_status = stc$inactive THEN
      {
      { The master is not currently active.
      {
      osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, master_vol, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
      RETURN;
    IFEND;

    stp$search_mel_for_vol (requested_member_vol, ast_index, member_entry, mel_index, member_found_in_ast);
    IF member_found_in_ast THEN
      osp$set_status_abnormal (stc$set_management_id, ste$member_vol_in_set, requested_member_vol, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, ast_entry.set_name, status);
      RETURN;
    IFEND;
  PROCEND validate_add_member;

?? TITLE := '  validate_add_member_params ', EJECT ??

{  PURPOSE:
{    This procedure validates the user supplied parameters.
{
  PROCEDURE validate_add_member_params (set_name: stt$set_name;
        requested_member_vol: rmt$recorded_vsn;
        master_vol: rmt$recorded_vsn;
    VAR cap_set_name: stt$set_name;
    VAR cap_requested_member_vol: rmt$recorded_vsn;
    VAR cap_master_vol: rmt$recorded_vsn;
    VAR parameter_status: ost$status);

    VAR
      local_name: ost$name,
      valid_name: boolean;

    clp$validate_name (set_name, local_name, valid_name);
    IF valid_name THEN
      cap_set_name := local_name;
      stp$validate_recorded_vsn (requested_member_vol, cap_requested_member_vol, parameter_status);
      IF parameter_status.normal THEN
        stp$validate_recorded_vsn (master_vol, cap_master_vol, parameter_status);
        IF NOT parameter_status.normal THEN
          osp$set_status_abnormal (stc$set_management_id, ste$bad_master_vol_desc, master_vol,
                parameter_status);
        IFEND;
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$bad_member_vol_desc, requested_member_vol,
              parameter_status);
      IFEND;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$bad_set_name, set_name, parameter_status);
    IFEND;
  PROCEND validate_add_member_params;

?? TITLE := '  verify_add_vol_exec ', EJECT ??

{  PURPOSE:
{    This procedure manages the verification of adding a member to a set.
{    Basically this procedure verifies that both member and master are mounted
{    and does what is required to mount them, including demanding exclusive
{    access.

  PROCEDURE verify_add_vol_exec (set_name: stt$set_name;
        member_volume: rmt$recorded_vsn;
        master_volume: rmt$recorded_vsn;
    VAR members_internal_vsn: dmt$internal_vsn;
    VAR members_avt_index: dmt$active_volume_table_index;
    VAR ast_entry: stt$active_set_entry;
    VAR ast_index: stt$ast_index;
    VAR status: ost$status);

    VAR
      local_status: ost$status;

    validate_add_member (set_name, member_volume, master_volume, ast_entry, ast_index,
          members_internal_vsn, members_avt_index, status);

    IF NOT status.normal THEN
      IF status.condition = ste$member_not_active THEN
        {
        {attempt to mount the member
        {
        stp$clear_exclusive_access;
        stp$dm_mount_volume (member_volume, local_status);
        stp$set_exclusive_access;
        IF local_status.normal THEN
          validate_add_member (set_name, member_volume, master_volume, ast_entry, ast_index,
                members_internal_vsn, members_avt_index, status);
        IFEND;
      IFEND;
      IF NOT status.normal THEN
        IF status.condition = ste$master_not_active THEN
          {
          {attempt to mount the master
          {
          stp$clear_exclusive_access;
          stp$dm_mount_volume (master_volume, local_status);
          stp$set_exclusive_access;
          IF local_status.normal THEN
            validate_add_member (set_name, member_volume, master_volume, ast_entry, ast_index,
                  members_internal_vsn, members_avt_index, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND verify_add_vol_exec;

?? TITLE := '  verify_member', EJECT ??

{  PURPOSE:
{    This procedure looks only at the member volume, and determines if there
{    is any reason to reject the request.  This includes determining if
{    the member is mounted, if the requestor owns the member (or is an
{    administrator).

  PROCEDURE verify_member (member_vol: rmt$recorded_vsn;
    VAR member_internal_vsn: dmt$internal_vsn;
    VAR members_avt_index: dmt$active_volume_table_index;
    VAR member_owner: ost$user_identification;
    VAR member_valid_status: ost$status);

    VAR
      job_owner: ost$user_identification,
      job_owner_status: ost$status,
      member_vol_found: boolean,
      members_sfid: dmt$system_file_id,
      valid_owner: boolean;

    member_valid_status.normal := TRUE;
    stp$request_dm_volume_info (member_vol, member_internal_vsn, member_owner, members_avt_index,
          member_vol_found);
    IF member_vol_found THEN
      stp$validate_owner (member_owner, valid_owner); {**?**}
      IF NOT valid_owner THEN {**?**}
        pmp$get_user_identification (job_owner, job_owner_status);
        osp$set_status_abnormal (stc$set_management_id, ste$job_not_member_owner, {**?**} job_owner.user,
              member_valid_status); {**?**}
        osp$append_status_parameter (osc$status_parameter_delimiter, job_owner.family, member_valid_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, member_vol, member_valid_status);
      IFEND; {**?**}
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$member_not_active, member_vol, member_valid_status);
    IFEND;
  PROCEND verify_member;

MODEND stm$add_member;
*DECK DECK=STM$CHANGE_ACCESS_TO_SET EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$change_access_to_set;

{
{ PURPOSE:
{   This module provides the compilation unit for the stp$change_access_to_set
{   request.
{
{ DESIGN:
{   This lives in 23d.
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_lexical
*copyc clp$validate_name
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc ost$user_identification
*copyc pmp$get_user_identification
*copyc std$active_set_table
*copyc std$miscellaneous
*copyc ste$error_condition_codes
*copyc stk$keypoints
*copyc stp$change_ast_access_status
*copyc stp$clear_exclusive_access
*copyc stp$search_ast_by_set
*copyc stp$set_exclusive_access
*copyc stp$valid_access_status
*copyc stp$validate_owner
?? POP ??
?? TITLE := '  [XDCL] stp$change_access_to_set ', EJECT ??
*copyc sth$change_access_to_set

  PROCEDURE [XDCL] stp$change_access_to_set
   (    set_name: stt$set_name;
        access_status: stt$access_status;
    VAR status: ost$status);



    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index,
      cap_set_name: stt$set_name,
      change_status: ost$status,
      job_owner: ost$user_identification,
      job_owner_status: ost$status,
      set_found: boolean,
      valid_owner: boolean;


    #keypoint (osk$entry, osk$m * ORD (access_status), stk$change_access_to_set);
    change_status.normal := TRUE;
    verify_change_param (set_name, access_status, cap_set_name, change_status);
    IF change_status.normal THEN
      stp$set_exclusive_access;
      stp$search_ast_by_set (cap_set_name, ast_entry, ast_index, set_found);
      IF set_found THEN
        stp$validate_owner (ast_entry.set_owner, valid_owner);
        IF valid_owner THEN
{         only the set owner or administrator may perform this request.
          stp$change_ast_access_status (ast_index, access_status, status);
          {assumes you never get bad status here}
        ELSE
          pmp$get_user_identification (job_owner, job_owner_status);
          osp$set_status_abnormal (stc$set_management_id, ste$set_not_job_owner, job_owner.user,
                change_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, job_owner.family, change_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, set_name, change_status);
        IFEND;
      ELSE
{       The set must be active to perform this request.
        osp$set_status_abnormal (stc$set_management_id, ste$set_not_active, stc$null_parameter,
              change_status);
      IFEND;
      stp$clear_exclusive_access;
    IFEND;
    status := change_status;
    IF status.normal THEN
      #keypoint (osk$exit, osk$m * ast_index, stk$change_access_to_set);
    ELSE
      #keypoint (osk$exit, 0, stk$change_access_to_set);
    IFEND;
  PROCEND stp$change_access_to_set;


?? TITLE := '  verify_change_param ', EJECT ??

  PROCEDURE verify_change_param (set_name: stt$set_name;
        access_status: stt$access_status;
    VAR cap_set_name: stt$set_name;
    VAR parameter_status: ost$status);

{  PURPOSE:
{    This procedure determines if the user supplied parameters on the request
{    stp$change_access_to_set are valid.



    VAR
      local_name: ost$name,
      valid_name: boolean;

    clp$validate_name (set_name, local_name, valid_name);
    IF valid_name THEN
      cap_set_name := local_name;
      IF stp$valid_access_status (access_status) THEN
        parameter_status.normal := TRUE;
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$bad_access_status, stc$null_parameter,
              parameter_status);
      IFEND;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$bad_set_name, set_name, parameter_status);
    IFEND;
  PROCEND verify_change_param;


MODEND stm$change_access_to_set;
*DECK DECK=STM$CREATE_SET EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$create_set;
{
{ PURPOSE:
{   This module contains the user interface to create a set.
{
{ DESIGN:
{   This module lives in 23d.
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$validate_name
*copyc ose$heap_full_exceptions
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$caller_identifier
*copyc ost$status
*copyc ost$user_identification
*copyc pmp$exit
*copyc rmd$volume_declarations
*copyc std$active_set_table
*copyc std$miscellaneous
*copyc ste$error_condition_codes
*copyc stk$keypoints
*copyc stp$clear_exclusive_access
*copyc stp$dm_mount_volume
*copyc stp$request_dm_volume_info
*copyc stp$ring2_create_set
*copyc stp$search_ast_by_set
*copyc stp$set_exclusive_access
*copyc stp$valid_access_status
*copyc stp$validate_owner
*copyc stp$validate_recorded_vsn
?? POP ??
?? TITLE := '   [XDCL, #GATE] stp$create_set ', EJECT ??

*copyc sth$create_set

  PROCEDURE [XDCL, #GATE] stp$create_set (requested_set: stt$set_name;
        requested_master_vol: rmt$recorded_vsn;
        requested_set_owner: ost$user_identification;
        access_status: stt$access_status;
        root_recreated: boolean;
    VAR status: ost$status);
?? EJECT ??

    VAR
      active_volume_table_index: dmt$active_volume_table_index,
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index,
      caller_id: ost$caller_identifier,
      caps_requested_master_vol: rmt$recorded_vsn,
      caps_requested_set: stt$set_name,
      caps_requested_set_owner: ost$user_identification,
      create_set_status: ost$status,
      internal_vsn: dmt$internal_vsn,
      master_vol_found: boolean,
      master_vol_owner: ost$user_identification,
      set_found: boolean;

    #caller_id (caller_id);
    #keypoint (osk$entry, osk$m * caller_id.ring, stk$create_set);
    create_set_status.normal := TRUE;
    validate_create_set_param (requested_set, requested_master_vol, requested_set_owner, access_status,
          caps_requested_set, caps_requested_master_vol, caps_requested_set_owner, create_set_status);
    IF create_set_status.normal THEN
{
{     DETERMINE IF THE MASTER VOLUME IS ACTIVE                               }
{
      stp$set_exclusive_access;
      stp$search_ast_by_set (caps_requested_set, ast_entry, ast_index, set_found);
      IF set_found THEN
        osp$set_status_abnormal (stc$set_management_id, ste$set_already_active, caps_requested_set,
              create_set_status);
      ELSE
        stp$get_volume_active (caps_requested_master_vol, internal_vsn, master_vol_owner,
              active_volume_table_index, master_vol_found);
      IFEND;
      IF create_set_status.normal THEN
        IF master_vol_found THEN
          stp$validate_master_owner (caps_requested_set_owner, caps_requested_set, master_vol_owner,
                caps_requested_master_vol, create_set_status);
          IF create_set_status.normal THEN
            stp$ring2_create_set (caps_requested_set, caps_requested_master_vol, internal_vsn,
                  caps_requested_set_owner, access_status, active_volume_table_index, root_recreated,
                  create_set_status);
          IFEND;
        ELSE
          osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, caps_requested_master_vol,
                create_set_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, caps_requested_set, create_set_status);
        IFEND;
      IFEND;
      stp$clear_exclusive_access;
    IFEND;
    status := create_set_status;
    IF status.normal THEN
      #keypoint (osk$exit, 0, stk$create_set);
    ELSE
      #keypoint (osk$exit, 0, stk$create_set);
    IFEND;
    IF (NOT status.normal) AND (status.condition = ose$mainframe_pageable_full) THEN
      pmp$exit (status);
    IFEND;
  PROCEND stp$create_set;
?? TITLE := '  stp$get_volume_active ', EJECT ??

  PROCEDURE stp$get_volume_active (volume: rmt$recorded_vsn;
    VAR internal_vsn: dmt$internal_vsn;
    VAR volume_owner: ost$user_identification;
    VAR active_volume_table_index: dmt$active_volume_table_index;
    VAR volume_found: boolean);

{  PURPOSE:
{    The purpose of this routine is determine if a volume is active, and to attempt
{    to mount the volume if it is not.

    VAR
      status: ost$status;

    stp$request_dm_volume_info (volume, internal_vsn, volume_owner, active_volume_table_index, volume_found);
    IF NOT volume_found THEN
      stp$clear_exclusive_access;
      stp$dm_mount_volume (volume, status);
      volume_found := status.normal;
      stp$set_exclusive_access;
      IF volume_found THEN
        stp$request_dm_volume_info (volume, internal_vsn, volume_owner, active_volume_table_index,
              volume_found);
      IFEND;
    IFEND;

  PROCEND stp$get_volume_active;

?? TITLE := '  stp$validate_master_owner ', EJECT ??

  PROCEDURE stp$validate_master_owner (requested_set_owner: ost$user_identification;
        requested_set_name: stt$set_name;
        master_vol_owner: ost$user_identification;
        master_vol_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

    VAR
      valid_owner: boolean;

    stp$validate_owner (requested_set_owner, valid_owner);
    IF valid_owner THEN
      IF master_vol_owner = requested_set_owner THEN
        status.normal := TRUE;
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$set_not_master_owner, requested_set_owner.user,
              status);
        osp$append_status_parameter (osc$status_parameter_delimiter, requested_set_owner.family, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, master_vol_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, requested_set_name, status);
      IFEND;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$set_not_job_owner, requested_set_owner.user,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, requested_set_owner.family, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, requested_set_name, status);
    IFEND;

  PROCEND stp$validate_master_owner;

?? TITLE := '  validate_create_set_param', EJECT ??

  PROCEDURE validate_create_set_param (requested_set: stt$set_name;
        requested_master_vol: rmt$recorded_vsn;
        requested_set_owner: ost$user_identification;
        access_status: stt$access_status;
    VAR cap_requested_set: stt$set_name;
    VAR cap_requested_master_vol: rmt$recorded_vsn;
    VAR cap_requested_set_owner: ost$user_identification;
    VAR parameter_status: ost$status);

{
{    PURPOSE:
{      This procedure determines if all of the create set parameters are
{      valid.
{

    VAR
      local_name: ost$name,
      valid_name: boolean,
      valid_owner_name: boolean;

    clp$validate_name (requested_set, local_name, valid_name);
    IF valid_name THEN
      cap_requested_set := local_name;
      stp$validate_recorded_vsn (requested_master_vol, cap_requested_master_vol, parameter_status);
      IF parameter_status.normal THEN
        clp$validate_name (requested_set_owner.family, local_name, valid_owner_name);
        IF valid_owner_name THEN
          cap_requested_set_owner.family := local_name;
          clp$validate_name (requested_set_owner.user, local_name, valid_owner_name);
          IF valid_owner_name THEN
            cap_requested_set_owner.user := local_name;
          IFEND;
        IFEND;
        IF valid_owner_name THEN
          IF stp$valid_access_status (access_status) THEN
            parameter_status.normal := TRUE;
          ELSE
            osp$set_status_abnormal (stc$set_management_id, ste$bad_access_status, stc$null_parameter,
                  parameter_status);
          IFEND;
        ELSE
          osp$set_status_abnormal (stc$set_management_id, ste$bad_set_owner, requested_set_owner.user,
                parameter_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, requested_set_owner.family,
                parameter_status);
        IFEND;
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$bad_master_vol_desc, cap_requested_master_vol,
              parameter_status);
      IFEND;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$bad_set_name, requested_set, parameter_status);
    IFEND;
  PROCEND validate_create_set_param;
MODEND stm$create_set;
*DECK DECK=STM$DISK_VOLUME_INACTIVE EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$disk_volume_inactive;

{  PURPOSE:
{    This module provides the compilation unit for stp$disk_volume_inactive.


?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmt$internal_vsn
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc rmd$volume_declarations
*copyc std$active_set_table
*copyc std$miscellaneous
*copyc ste$error_condition_codes
*copyc stk$keypoints
*copyc stp$clear_exclusive_access
*copyc stp$deallocate_ast_entry
*copyc stp$dm_mount_volume
*copyc stp$inactivate_master
*copyc stp$inactivate_member
*copyc stp$search_ast_by_unique_set
*copyc stp$set_exclusive_access
*copyc stp$store_dm_packet_in_master
*copyc stt$dm_packet
*copyc stt$set_ordinal
?? POP ??
?? TITLE := '  [XDCL, #GATE] stp$disk_volume_inactive', EJECT ??
*copyc sth$disk_volume_inactive

  PROCEDURE [XDCL, #GATE] stp$disk_volume_inactive (inactive_volume: rmt$recorded_vsn;
        internal_vsn: dmt$internal_vsn;
        set_ordinal: stt$set_ordinal;
        dm_packet: stt$dm_packet;
    VAR status: ost$status);

{  PURPOSE:
{    This procedure manages the operations, when a volume becomes inactive
{    in the system, as detected by device management.  Included in these
{    operations is whether the volume belongs to a set, and then updating
{    the active set table to reflect this.  Note. The request is only
{    called by device management.


    VAR
      active_set_entry: stt$active_set_entry,
      ast_index: stt$ast_index,
      unique_set_found: boolean;

    #keypoint (osk$entry, osk$m * ORD (set_ordinal.entry_type), stk$disk_volume_inactive);

    IF set_ordinal.entry_type = stc$unused THEN
{
{     The volume does not belong to a set.
      status.normal := TRUE;
    ELSE
      stp$set_exclusive_access;
      stp$search_ast_by_unique_set (set_ordinal.unique_set_name, active_set_entry, ast_index,
            unique_set_found);
      IF unique_set_found THEN
        stp$update_on_inactive_vol (inactive_volume, internal_vsn, dm_packet, active_set_entry, ast_index,
              status);
        stp$clear_exclusive_access;
        IF status.normal THEN
          { or do we always want to do this ???? }
          IF active_set_entry.number_of_jobs_using_set > 0 THEN
{         The set that this volume belongs to is in use, attempt to re-mount.
            stp$dm_mount_volume (inactive_volume, status);
            IF NOT status.normal THEN
              osp$set_status_abnormal (stc$set_management_id, ste$down_vol_used, inactive_volume, status);
              osp$append_status_parameter (osc$status_parameter_delimiter, active_set_entry.set_name, status);
            IFEND;
          IFEND;
        IFEND;
      ELSE
{       Sets does not know about this volume, or the set that this volume
{       belongs to, this is a system error.
        stp$clear_exclusive_access;
        osp$set_status_abnormal (stc$set_management_id, ste$dm_ast_mismatch, inactive_volume, status);
      IFEND;
    IFEND;
    IF status.normal THEN
      #keypoint (osk$exit, 0, stk$disk_volume_inactive);
    ELSE
      #keypoint (osk$exit, 0, stk$disk_volume_inactive);
    IFEND;
  PROCEND stp$disk_volume_inactive;
?? TITLE := '  stp$update_on_inactive_volume', EJECT ??

  PROCEDURE stp$update_on_inactive_vol (inactive_volume: rmt$recorded_vsn;
        internal_vsn: dmt$internal_vsn;
        dm_packet: stt$dm_packet;
        active_set_entry: stt$active_set_entry;
        ast_index: stt$ast_index;
    VAR status: ost$status);

    VAR
      dm_packet_storage: stt$dm_packet_storage;



{
{  PURPOSE:
{    This routine updates the active set table when a volume becomes inactive.
{    The master volume set table may also be updated with a new dm packet,
{    if it was a member volume that became inactive.
{

    dm_packet_storage.dm_packet_ever_stored := TRUE;
    dm_packet_storage.dm_packet := dm_packet;
    IF inactive_volume = active_set_entry.master_vsn THEN
      IF internal_vsn = active_set_entry.master_internal_vsn THEN
        stp$inactivate_master (ast_index, dm_packet_storage, status);
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$internal_vsn_mismatch, inactive_volume, status);
      IFEND;
    ELSE
      stp$inactivate_member (ast_index, inactive_volume, internal_vsn, dm_packet_storage, status);
      IF active_set_entry.master_ever_up AND (active_set_entry.master_volume_activity.volume_activity_status =
            stc$active) THEN
        stp$store_dm_packet_in_master (active_set_entry.master_vsn, inactive_volume, dm_packet_storage,
              status);
      IFEND;
    IFEND;
    IF status.normal THEN
      stp$deallocate_ast_entry (ast_index, status);
    IFEND;
  PROCEND stp$update_on_inactive_vol;

MODEND stm$disk_volume_inactive;
*DECK DECK=STM$DISPLAY_AST_INFO EXPAND=TRUE
?? RIGHT := 110 ??
MODULE stm$display_ast_info;
?? PUSH (LISTEXT := ON) ??
*copyc clp$put_display
*copyc pmp$convert_binary_unique_name
*copyc std$active_set_table
*copyc stp$obtain_ast_entry
*copyc stp$obtain_ast_size
*copyc stp$obtain_ast_member_list
*copyc stt$dm_packet_storage
?? POP ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] stp$display_sets
    (VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      ast_index: stt$ast_index,
      ast_size: integer;

    status.normal := TRUE;
    stp$obtain_ast_size (ast_size);
    FOR ast_index := 1 TO ast_size DO
      display_set_by_index (ast_index, display_control, status);
    FOREND;
  PROCEND stp$display_sets;
?? EJECT ??

  PROCEDURE display_access_status
    (VAR display_control: clt$display_control;
         access_status: stt$access_status);

    CASE access_status OF
    = stc$allow_access =
      display_message (display_control, 'Access_status = STC$ALLOW_ACCESS');
    = stc$deny_access =
      display_message (display_control, 'Access_status = STC$DENY_ACCESS');
    CASEND;
  PROCEND display_access_status;
?? EJECT ??

  PROCEDURE display_activity
    (VAR display_control: clt$display_control;
         activity: stt$vol_activity_status);

    IF activity = stc$active THEN
      display_message (display_control, 'Set activity = STC$ACTIVE');
    ELSE
      display_message (display_control, 'Set activity = STC$INACTIVE');
    IFEND;
  PROCEND display_activity;
?? EJECT ??

  PROCEDURE display_integer
    (VAR display_control: clt$display_control;
         descriptor: string ( * );
         number: integer);

    VAR
      length: integer,
      display_string: string (80);

    STRINGREP (display_string, length, descriptor, number);
    display_message (display_control, display_string (1, length));
  PROCEND display_integer;
?? EJECT ??

  PROCEDURE display_member_list
    (VAR display_control: clt$display_control;
         ast_index: stt$ast_index);

    VAR
      mel_index: stt$mel_index,
      member_entry: stt$member_entry,
      member_list_size: integer,
      p_member_list: stt$p_member_entry_list;

    PUSH p_member_list: [1 .. 1000];
    stp$obtain_ast_member_list (ast_index, p_member_list^, member_list_size);
    IF member_list_size = 0 THEN
      display_message (display_control, 'No member volumes ');
    ELSE
      display_integer (display_control, 'Member list size', member_list_size);
      FOR mel_index := 1 TO member_list_size DO
        IF mel_index > UPPERBOUND (p_member_list^) THEN
          display_message (display_control, 'Too many members to display ');
          RETURN;
        IFEND;
        member_entry := p_member_list^ [mel_index];
        IF member_entry.entry_type = stc$valid THEN
          display_integer (display_control, '-------------- Member index ', mel_index);
          display_message (display_control, member_entry.member_vsn);
          display_unique_name (display_control, 'Member internal vsn', member_entry.member_internal_vsn);
          display_activity (display_control, member_entry.member_volume_activity.volume_activity_status);
          IF member_entry.member_volume_activity.volume_activity_status = stc$active THEN
            display_integer (display_control, 'Member avt index',
                  member_entry.member_volume_activity.avt_index);
          IFEND;
          display_packet_storage (display_control, member_entry.member_dm_packet_storage);
        IFEND;
      FOREND;
    IFEND;
  PROCEND display_member_list;
?? EJECT ??

  PROCEDURE display_message
    (VAR display_control: clt$display_control;
         message: string ( * ));

    VAR
      status: ost$status;

    clp$put_display (display_control, message, clc$no_trim, status);
  PROCEND display_message;
?? EJECT ??

  PROCEDURE display_packet_storage
    (VAR display_control: clt$display_control;
         dm_packet_storage: stt$dm_packet_storage);

    IF dm_packet_storage.dm_packet_ever_stored THEN
      display_integer (display_control, 'Device manager packet length ', dm_packet_storage.dm_packet);
    ELSE
      display_message (display_control, 'No Device Manager packet stored');
    IFEND;
  PROCEND display_packet_storage;
?? EJECT ??

  PROCEDURE display_set_by_index
    (    ast_index: stt$ast_index;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      ast_entry: stt$active_set_entry;

    stp$obtain_ast_entry (ast_index, ast_entry, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display_integer (display_control, '==== Active Set Table Index ===', ast_index);
    IF ast_entry.entry_type = stc$valid THEN
      display_message (display_control, ast_entry.set_name);
      display_message (display_control, ast_entry.master_vsn);
      display_unique_name (display_control, 'Unique set name ', ast_entry.unique_set_name);
      display_unique_name (display_control, 'Master internal vsn ', ast_entry.master_internal_vsn);
      display_access_status (display_control, ast_entry.access_status);
      IF ast_entry.master_ever_up THEN
        display_user_id (display_control, ast_entry.set_owner);
        display_integer (display_control, 'Number of jobs using set: ', ast_entry.number_of_jobs_using_set);
        IF ast_entry.pf_root_ever_stored THEN
          display_integer (display_control, 'PF root size: ', ast_entry.pf_root_size);
        ELSE
          display_message (display_control, 'PF root not stored ');
        IFEND;
        display_activity (display_control, ast_entry.master_volume_activity.volume_activity_status);
        IF ast_entry.master_volume_activity.volume_activity_status = stc$active THEN
          display_integer (display_control, 'Master avt index: ', ast_entry.master_volume_activity.avt_index);
        IFEND;
        display_packet_storage (display_control, ast_entry.master_dm_packet_storage);
      ELSE
        display_message (display_control, 'Master never active ');
      IFEND;
      display_member_list (display_control, ast_index);
    IFEND;
  PROCEND display_set_by_index;
?? EJECT ??

  PROCEDURE display_unique_name
    (VAR display_control: clt$display_control;
         ds: string ( * );
         internal_vsn: dmt$internal_vsn);

    VAR
      displayable_name: ost$name,
      display_string: string (80),
      length: integer,
      status: ost$status;

    pmp$convert_binary_unique_name (internal_vsn, displayable_name, status);
    IF status.normal THEN
      STRINGREP (display_string, length, ds, ' ', displayable_name);
      display_message (display_control, display_string (1, length));
    ELSE
      display_message (display_control, ds);
      display_message (display_control, 'Unexpected internal vsn ');
    IFEND;

  PROCEND display_unique_name;
?? EJECT ??

  PROCEDURE display_user_id
    (VAR display_control: clt$display_control;
         user_id: ost$user_identification);

    VAR
      display_string: string (80),
      length: integer;

    STRINGREP (display_string, length, 'Owner ', user_id.family, ' ', user_id.user);
    display_message (display_control, display_string (1, length));
  PROCEND display_user_id;
MODEND stm$display_ast_info;
*DECK DECK=STM$DISPLAY_VOLUME_INFO EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
MODULE stm$display_volume_info;
{this procedure runs in ring 2             }
?? PUSH (LISTEXT := ON) ??
*copyc clp$put_display
*copyc pmp$convert_binary_unique_name
*copyc dmt$internal_vsn
*copyc ost$status
*copyc std$volume_set_table
*copyc stp$obtain_master_vst_info
*copyc stp$obtain_member_vst_info
*copyc stp$obtain_vst_header
*copyc stp$open_vst
*copyc stp$return_opened_vst
*copyc stt$dm_packet_storage
*copyc stt$number_of_members
?? POP ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] stp$display_vol_set_table
    (    volume: rmt$recorded_vsn;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    VAR
      p_vst: stt$p_vol_set_table,
      sfid: dmt$system_file_id,
      vst_segment_pointer: mmt$segment_pointer;

    stp$open_vst (volume, FALSE, sfid, vst_segment_pointer, status);
    IF status.normal THEN
      p_vst := vst_segment_pointer.cell_pointer;
      display_vst (display_control, p_vst, status);
      stp$return_opened_vst (sfid, vst_segment_pointer, status);
    IFEND;
  PROCEND stp$display_vol_set_table;
?? EJECT ??

  PROCEDURE display_integer
    (VAR display_control: clt$display_control;
         descriptor: string ( * );
         number: integer);

    VAR
      length: integer,
      display_string: string (80);

    STRINGREP (display_string, length, descriptor, number);
    display_message (display_control, display_string (1, length));
  PROCEND display_integer;
?? EJECT ??

  PROCEDURE display_message
    (VAR display_control: clt$display_control;
         message: string ( * ));

    VAR
      status: ost$status;

    clp$put_display (display_control, message, clc$no_trim, status);
  PROCEND display_message;
?? EJECT ??

  PROCEDURE display_packet_storage
    (VAR display_control: clt$display_control;
         dm_packet_storage: stt$dm_packet_storage);

    IF dm_packet_storage.dm_packet_ever_stored THEN
      display_integer (display_control, 'Device Manager packet length ', dm_packet_storage.dm_packet);
    ELSE
      display_message (display_control, 'NO Device Manager Packet stored');
    IFEND;
  PROCEND display_packet_storage;
?? EJECT ??

  PROCEDURE display_unique_name
    (VAR display_control: clt$display_control;
         ds: string ( * );
         internal_vsn: dmt$internal_vsn);

    VAR
      displayable_name: ost$name,
      display_string: string (80),
      length: integer,
      status: ost$status;

    pmp$convert_binary_unique_name (internal_vsn, displayable_name, status);
    IF status.normal THEN
      STRINGREP (display_string, length, ds, ' ', displayable_name);
      display_message (display_control, display_string (1, length));
    ELSE
      display_message (display_control, ds);
      display_message (display_control, 'Unexpected internal vsn ');
    IFEND;

  PROCEND display_unique_name;
?? EJECT ??

  PROCEDURE display_user_id
    (VAR display_control: clt$display_control;
         user_id: ost$user_identification);

    VAR
      display_string: string (80),
      length: integer;

    STRINGREP (display_string, length, 'Owner ', user_id.family, ' ', user_id.user);
    display_message (display_control, display_string (1, length));
  PROCEND display_user_id;

?? EJECT ??

  PROCEDURE display_vsn_list
    (VAR display_control: clt$display_control;
         p_member_vsn_list: stt$p_member_vsn_list;
         size_of_member_list: stt$number_of_members);

    VAR
      member_vsn_entry: stt$member_vsn_entry,
      mvl_index: integer;

    display_message (display_control, '===  Member vsn list ');

  /loop_through_list/
    FOR mvl_index := 1 TO size_of_member_list DO
      member_vsn_entry := p_member_vsn_list^ [mvl_index];
      IF mvl_index > UPPERBOUND (p_member_vsn_list^) THEN
        display_integer (display_control, 'To many members ', size_of_member_list);
        EXIT /loop_through_list/;
      IFEND;
      IF member_vsn_entry.entry_type = stc$valid THEN
        display_integer (display_control, '--- Member volume index', mvl_index);
        display_message (display_control, member_vsn_entry.member_vsn);
        display_unique_name (display_control, 'Member internal vsn ', member_vsn_entry.member_internal_vsn);
        display_packet_storage (display_control, member_vsn_entry.member_dm_packet_storage);
      IFEND;
    FOREND /loop_through_list/;
  PROCEND display_vsn_list;
?? EJECT ??

  PROCEDURE display_vst
    (VAR display_control: clt$display_control;
         p_vst: stt$p_vol_set_table;
     VAR status: ost$status);

    VAR
      display_string: string (80),
      dm_packet_storage: stt$dm_packet_storage,
      internal_vsn: dmt$internal_vsn,
      length: integer,
      master_vsn: rmt$recorded_vsn,
      new_p_member_vsn_list: stt$p_member_vsn_list,
      p_member_list: ^array [ * ] of stt$member_vsn_entry,
      pf_root_ever_stored: boolean,
      pf_root_locator: stt$pf_root_locator,
      pf_root_size: pft$root_size,
      set_name: stt$set_name,
      set_owner: ost$user_identification,
      size_of_member_list: stt$number_of_members,
      unique_set_name: stt$unique_set_name,
      volume: rmt$recorded_vsn,
      volume_in_set: boolean,
      volume_status_in_set: stt$vol_status_in_set;

    display_message (display_control, '======== Volume Set Table ========');
    stp$obtain_vst_header (p_vst, volume, internal_vsn, volume_in_set, set_name, unique_set_name,
          volume_status_in_set);
    display_message (display_control, volume);
    display_unique_name (display_control, 'Internal vsn ', internal_vsn);
    IF volume_in_set THEN
      display_message (display_control, set_name);
      display_unique_name (display_control, 'Unique set name ', unique_set_name);
      IF volume_status_in_set = stc$member_vol THEN
        display_message (display_control, 'Volume status in set = Member volume');
        stp$obtain_member_vst_info (p_vst, master_vsn, internal_vsn);
        STRINGREP (display_string, length, 'Master_vsn = ', master_vsn);
        display_message (display_control, display_string (1, length));
        display_unique_name (display_control, 'Master internal vsn', internal_vsn);
      ELSE
        display_message (display_control, 'Volume status in set = Master volume');
        PUSH p_member_list: [1 .. 1000];
        stp$obtain_master_vst_info (p_vst, set_owner, dm_packet_storage, p_member_list^, size_of_member_list,
              pf_root_ever_stored, pf_root_size, pf_root_locator);
        display_packet_storage (display_control, dm_packet_storage);
        IF pf_root_ever_stored THEN
          display_integer (display_control, 'PF root size', pf_root_size);
        ELSE
          display_message (display_control, 'PF root not stored');
        IFEND;
        display_user_id (display_control, set_owner);
        IF p_vst^.root_recreated = stc$root_recreated THEN
          display_message (display_control, 'Root recreated ');
        ELSEIF p_vst^.root_recreated = stc$root_not_recreated THEN
          display_message (display_control, 'Root NOT recreated ');
        ELSE
          display_message (display_control, 'Unitialized root_recreated ');
        IFEND;
        display_vsn_list (display_control, p_member_list, size_of_member_list);
      IFEND;
    ELSE
      display_message (display_control, 'Entry type = STC$INVALID ');
    IFEND;
  PROCEND display_vst;

MODEND stm$display_volume_info;
*DECK DECK=STM$GET_SET_INFO EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$get_set_info;

{  PURPOSE:
{    This module contains those procedures that return information
{    to device management.  These routines all return a list of volumes.

?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osk$keypoints
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc rmd$volume_declarations
*copyc stc$max_num_members_on_set
*copyc std$active_set_table
*copyc std$set_name
*copyc ste$error_condition_codes
*copyc stk$keypoints
*copyc stp$clear_read_access
*copyc stp$get_active_set_list
*copyc stp$get_volumes_by_ast_index
*copyc stp$search_ast_by_internal_vsn
*copyc stp$search_ast_by_set
*copyc stp$search_ast_by_unique_set
*copyc stp$search_ast_by_volume
*copyc stp$set_read_access
*copyc stt$number_of_members
*copyc stt$set_list
*copyc stt$set_ordinal
*copyc stt$volume_list
?? POP ??
?? TITLE := '  stp$get_all_volumes_in_set', EJECT ??

  PROCEDURE stp$get_all_volumes_in_sets (list_of_sets: stt$set_list;
        number_of_sets: integer;
    VAR volume_list: stt$volume_list;
    VAR actual_number_of_volumes: integer;
    VAR status: ost$status);

{
{  PURPOSE:
{    This procedure takes a list of sets, and for each set gets a list of
{    volumes, sums the number of volumes, and transfers the list of volumes for
{    each set to the supplied list of volumes.

    VAR
      found_ast_entry: stt$active_set_entry,
      found_ast_index: stt$ast_index,
      master_vol: stt$volume_info,
      number_of_members_in_set: stt$number_of_members,
      set_found: boolean,
      set_index: integer;

    status.normal := TRUE;
    actual_number_of_volumes := 0;

  /for_each_set_loop/
    FOR set_index := 1 TO number_of_sets DO
      stp$search_ast_by_set (list_of_sets [set_index], found_ast_entry, found_ast_index,
            set_found);
      IF set_found THEN
        stp$get_volumes_by_ast_index (found_ast_index, (actual_number_of_volumes + 1), master_vol,
               volume_list, number_of_members_in_set);
        actual_number_of_volumes := actual_number_of_volumes + number_of_members_in_set + 1;{the master}
        IF actual_number_of_volumes <= UPPERBOUND (volume_list) THEN
          volume_list [actual_number_of_volumes] := master_vol;
        IFEND;
      IFEND;
    FOREND /for_each_set_loop/;
    IF status.normal AND (actual_number_of_volumes = 0) THEN
      osp$set_status_abnormal (stc$set_management_id, ste$no_scratch_volumes, stc$null_parameter, status);
    IFEND;
  PROCEND stp$get_all_volumes_in_sets;

?? TITLE := '   [XDCL] stp$get_internal_volumes_set', EJECT ??
*copyc sth$get_internal_volumes_set
  PROCEDURE [XDCL] stp$get_internal_volumes_set
   (    volume: dmt$internal_vsn;
    VAR set_name: stt$set_name;
    VAR status: ost$status);

    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index,
      volume_found: boolean;

    #keypoint (osk$entry, 0, stk$get_internal_volumes_set);
    {stp$set_read_access;
    stp$search_ast_by_internal_vsn (volume, ast_entry, ast_index, volume_found);
    IF volume_found THEN
      set_name := ast_entry.set_name;
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$vol_not_found, 'internal_vsn', status);
    IFEND;
    {stp$clear_read_access;
    #keypoint (osk$exit, 0, stk$get_internal_volumes_set);
  PROCEND stp$get_internal_volumes_set;

?? TITLE := '  [XDCL, #GATE] stp$get_active_volume_list', EJECT ??
*copyc sth$get_active_volume_list

  PROCEDURE [XDCL, #GATE] stp$get_active_volume_list
    (VAR volume_list: stt$volume_list;
     VAR actual_number_of_volumes: integer;
     VAR status: ost$status);

    VAR
      current_set_list_size: integer,
      number_of_sets: stt$number_of_sets,
      p_set_list: ^stt$set_list;

    number_of_sets := 10;
    REPEAT
      current_set_list_size := number_of_sets;
      PUSH p_set_list: [1 .. current_set_list_size];
      stp$get_active_set_list (p_set_list^, number_of_sets);
    UNTIL number_of_sets <= current_set_list_size;

    stp$get_all_volumes_in_sets (p_set_list^, number_of_sets, volume_list, actual_number_of_volumes,
          status);
  PROCEND stp$get_active_volume_list;

?? TITLE := '  [XDCL, #GATE] stp$get_volumes_by_set_ordinal', EJECT ??
*copyc sth$get_volumes_by_set_ordinal

  PROCEDURE [XDCL, #GATE] stp$get_volumes_by_set_ordinal (set_ordinal: stt$set_ordinal;
    VAR master_vol: stt$volume_info;
    VAR member_vol_list: stt$volume_list;
    VAR actual_number_of_members: stt$number_of_members;
    VAR status: ost$status);


    VAR
      ast_entry: stt$active_set_entry,
      external_set_name: stt$set_name,
      found_ast_index: stt$ast_index,
      set_key_found: boolean;

    #keypoint (osk$entry, 0, stk$get_volumes_by_set_ordinal);
    IF set_ordinal.entry_type = stc$valid THEN
      {stp$set_read_access;
      stp$search_ast_by_unique_set (set_ordinal.unique_set_name, ast_entry, found_ast_index, set_key_found);
      IF set_key_found THEN
        IF (ast_entry.master_ever_up) AND (ast_entry.master_volume_activity.volume_activity_status =
              stc$active) THEN
          stp$get_volumes_by_ast_index (found_ast_index, 1, master_vol, member_vol_list,
                actual_number_of_members);
          status.normal := TRUE;
        ELSE
          osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, ast_entry.master_vsn,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, ast_entry.set_name, status);
        IFEND;
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$set_not_active, stc$null_parameter, status);
      IFEND;
      {stp$clear_read_access;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$set_ord_not_set, stc$null_parameter, status);
    IFEND;
    IF status.normal THEN
      #keypoint (osk$exit, osk$m * actual_number_of_members, stk$get_volumes_by_set_ordinal);
    ELSE
      #keypoint (osk$exit, 0, stk$get_volumes_by_set_ordinal);
    IFEND;
  PROCEND stp$get_volumes_by_set_ordinal;


?? TITLE := '  [XDCL, #GATE] stp$get_volumes_in_Set', EJECT ??
*copyc sth$get_volumes_in_set

  PROCEDURE [XDCL, #GATE] stp$get_volumes_in_set (set_name: stt$set_name;
    VAR master_vol: stt$volume_info;
    VAR member_vol_list: stt$volume_list;
    VAR actual_number_of_members: stt$number_of_members;
    VAR status: ost$status);


    VAR
      ast_entry: stt$active_set_entry,
      found_ast_index: stt$ast_index,
      set_key_found: boolean;

    #keypoint (osk$entry, 0, stk$get_volumes_in_set);
    {stp$set_read_access;
    stp$search_ast_by_set (set_name, ast_entry, found_ast_index, set_key_found);
    IF set_key_found THEN
      IF (ast_entry.master_ever_up) AND (ast_entry.master_volume_activity.volume_activity_status = stc$active)
            THEN
        stp$get_volumes_by_ast_index (found_ast_index, 1, master_vol, member_vol_list,
              actual_number_of_members);
        status.normal := TRUE;
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, ast_entry.master_vsn, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, ast_entry.set_name, status);
      IFEND;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$set_not_active, stc$null_parameter, status);
    IFEND;
    {stp$clear_read_access;
    IF status.normal THEN
      #keypoint (osk$exit, osk$m * actual_number_of_members, stk$get_volumes_in_set);
    ELSE
      #keypoint (osk$exit, 0, stk$get_volumes_in_set);
    IFEND;
  PROCEND stp$get_volumes_in_set;







?? TITLE := '  [XDCL, #GATE] stp$get_volumes_set_name', EJECT ??
*copyc sth$get_volumes_set_name

  PROCEDURE [XDCL, #GATE] stp$get_volumes_set_name (volume: rmt$recorded_vsn;
    VAR set_name: stt$set_name;
    VAR status: ost$status);


    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index,
      volume_found: boolean;

    #keypoint (osk$entry, 0, stk$get_volumes_set_name);
    {stp$set_read_access;
    stp$search_ast_by_volume (volume, ast_entry, ast_index, volume_found);
    IF volume_found THEN
      set_name := ast_entry.set_name;
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$vol_not_found, volume, status);
    IFEND;
    {stp$clear_read_access;
    #keypoint (osk$exit, 0, stk$get_volumes_set_name);
  PROCEND stp$get_volumes_set_name;



?? TITLE := '  [XDCL, #GATE]  stp$is_volume_in_set', EJECT ??
*copyc sth$is_volume_in_set

  PROCEDURE [XDCL, #GATE] stp$is_volume_in_set (volume: rmt$recorded_vsn;
        set_name: stt$set_name;
    VAR volume_info: stt$volume_info;
    VAR status: ost$status);



    VAR
      master_info: stt$volume_info,
      number_of_members: stt$number_of_members,
      p_member_list: ^stt$volume_list;

    #keypoint (osk$entry, 0, stk$is_volume_in_set);
    PUSH p_member_list: [1 .. stc$max_num_members_on_set];
    stp$get_volumes_in_set (set_name, master_info, p_member_list^, number_of_members, status);
    IF status.normal THEN
      IF volume = master_info.recorded_vsn THEN
        volume_info := master_info;
      ELSE
        stp$search_member_list (volume, p_member_list^, number_of_members, volume_info, status);
      IFEND;
    IFEND;
    #keypoint (osk$exit, 0, stk$is_volume_in_set);
  PROCEND stp$is_volume_in_set;

?? TITLE := '  [XDCL] stp$search_member_list', EJECT ??
*copyc sth$search_member_list

  PROCEDURE [XDCL] stp$search_member_list
   (    volume: rmt$recorded_vsn;
        member_list: stt$volume_list;
        number_of_members: stt$number_of_members;
    VAR volume_info: stt$volume_info;
    VAR status: ost$status);

    VAR
      i: integer,
      maximum_loop: integer,
      volume_found: boolean;

    IF (UPPERBOUND (member_list)) < number_of_members THEN
      maximum_loop := UPPERBOUND (member_list);
    ELSE
      maximum_loop := number_of_members;
    IFEND;

    volume_found := FALSE;

  /search_for_rec_vsn/
    FOR i := 1 TO maximum_loop DO
      volume_info := member_list [i];
      IF volume_info.recorded_vsn = volume THEN
        volume_found := TRUE;
        EXIT /search_for_rec_vsn/;
      IFEND;
    FOREND /search_for_rec_vsn/;
    IF volume_found THEN
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$vol_not_in_set, volume, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, member_list [1].setname, status);
    IFEND;
  PROCEND stp$search_member_list;

MODEND stm$get_set_info;
*DECK DECK=STM$INITIALIZE_SETS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$initialize_sets;
{
{ PURPOSE:
{   This module contains those routines used during the deadstart sequence.
{

?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmv$system_device_information
*copyc clp$validate_name
*copyc jmc$system_family
*copyc osc$nosve_system_set
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc osv$recover_system_set_phase
*copyc pmp$get_user_identification
*copyc rmd$volume_declarations
*copyc ste$error_condition_codes
*copyc stk$keypoints
*copyc stp$create_set
*copyc stp$get_volumes_by_ast_index
*copyc stp$get_volumes_in_set
*copyc stp$r2_remove_inactive_member
*copyc stp$search_ast_by_set
*copyc stp$validate_owner
*copyc stv$system_set_name
*copyc osv$lower_to_upper
*copyc pmp$get_mainframe_id
*copyc stp$update_system_set_name
*copyc osv$system_family_name
?? POP ??
?? TITLE := '  [XDCL, #GATE] stp$initialize_sets ', EJECT ??
*copyc sth$initialize_sets

  PROCEDURE [XDCL, #GATE] stp$initialize_sets (VAR status: ost$status);

    VAR
      master_vol: rmt$recorded_vsn,
      set_name: stt$set_name,
      mainframe_id: pmt$mainframe_id,
      set_owner: ost$user_identification;

    #keypoint (osk$entry, 0, stk$initialize_sets);
    set_owner.family := osv$system_family_name;
    set_owner.user := jmc$system_user;
    master_vol := dmv$system_device_recorded_vsn;

    IF stv$system_set_name = osc$null_name THEN
      {!pmp$get_mainframe_id (mainframe_id, status);
      {!set_name := mainframe_id;
      { Force default system set name to be the old NVESET
      set_name := osc$nosve_system_set;
    ELSE
      #TRANSLATE (osv$lower_to_upper, stv$system_set_name, set_name);
    IFEND;
    stp$update_system_set_name (set_name);

    stp$create_set (stv$system_set_name, master_vol, set_owner, stc$allow_access,
        osv$recover_system_set_phase = osc$reinitialize_system_device,  status);
    IF (NOT status.normal) AND (status.condition = ste$set_already_active) THEN
      status.normal := TRUE;
    IFEND;
    #keypoint (osk$exit, 0, stk$initialize_sets);
  PROCEND stp$initialize_sets;
?? TITLE := ' [XDCL, #GATE] stp$remove_inactive_members ', EJECT ??
*copyc sth$remove_inactive_members

  PROCEDURE [XDCL, #GATE] stp$remove_inactive_members (set_name: stt$set_name;
    VAR status: ost$status);

    VAR
      ast_index: stt$ast_index,
      current_number_of_members_guess: stt$number_of_members,
      i: integer,
      master_volume_info: stt$volume_info,
      number_of_members: stt$number_of_members,
      p_member_volume_list: ^stt$volume_list;

    verify_remove_inactive (set_name, ast_index, status);
    IF status.normal THEN

      number_of_members := 1;
      /get_member_list/
        REPEAT
           current_number_of_members_guess := number_of_members;
           PUSH p_member_volume_list: [1 .. current_number_of_members_guess];
           stp$get_volumes_by_ast_index (ast_index, 1, master_volume_info, p_member_volume_list^,
                   number_of_members);
        UNTIL  (current_number_of_members_guess >= number_of_members);

      /remove_members/
        FOR i := 1 TO number_of_members DO
          IF p_member_volume_list^ [i].volume_activity.volume_activity_status = stc$inactive THEN
            stp$r2_remove_inactive_member (ast_index, p_member_volume_list^ [i].recorded_vsn,
                 master_volume_info.recorded_vsn,   status);
            IF NOT status.normal then
              EXIT /remove_members/;
            IFEND;
         IFEND;
       FOREND /remove_members/;
    IFEND;
 PROCEND;

?? TITLE := ' [XDCL, #GATE]  stp$verify_all_volumes_active', EJECT ??
*copyc sth$verify_all_volumes_active

  PROCEDURE [XDCL, #GATE] stp$verify_all_volumes_active (set_name: stt$set_name;
    VAR status: ost$status);

    VAR
      all_volumes_active: boolean,
      current_number_of_members_guess: stt$number_of_members,
      i: integer,
      master_volume_info: stt$volume_info,
      number_of_members: stt$number_of_members,
      outputline: string (256),
      outputline_index: integer,
      p_member_volume_list: ^stt$volume_list;

{ get a list of all volumes in the set
    #keypoint (osk$entry, 0, stk$verify_all_volumes_active);
    number_of_members := 1;
    REPEAT
      current_number_of_members_guess := number_of_members;
      PUSH p_member_volume_list: [1 .. current_number_of_members_guess];
      stp$get_volumes_in_set (set_name, master_volume_info, p_member_volume_list^, number_of_members, status);
    UNTIL (NOT status.normal) OR (current_number_of_members_guess >= number_of_members);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ verify all volumes active
    all_volumes_active := TRUE;
    IF master_volume_info.volume_activity.volume_activity_status = stc$inactive THEN
      all_volumes_active := FALSE;
      STRINGREP (outputline, outputline_index, 'MASTER VOLUME ', master_volume_info.recorded_vsn);
    ELSE
      { verify all members active
      FOR i := 1 TO number_of_members DO
        IF p_member_volume_list^ [i].volume_activity.volume_activity_status = stc$inactive THEN
          IF all_volumes_active THEN
            all_volumes_active := FALSE;
            STRINGREP (outputline, outputline_index, 'MEMBER VOLUME   ');
          IFEND;
          STRINGREP (outputline, outputline_index, outputline (1, outputline_index), p_member_volume_list^
                [i].recorded_vsn, ',   ');
        IFEND;
      FOREND;
    IFEND;
    IF NOT all_volumes_active THEN
      STRINGREP (outputline, outputline_index, outputline (1, outputline_index), ' -- NOT ACTIVE ON SET: ',
            set_name);
      osp$set_status_abnormal (stc$set_management_id, ste$all_volumes_not_active, outputline (1,
            outputline_index), status);
    IFEND;
    IF status.normal THEN
      #keypoint (osk$exit, 0, stk$verify_all_volumes_active);
    ELSE
      #keypoint (osk$exit, 0, stk$verify_all_volumes_active);
    IFEND;
  PROCEND stp$verify_all_volumes_active;
?? TITLE := ' verify_remove_inactive ', EJECT ??
 PROCEDURE verify_remove_inactive (set_name: stt$set_name;
    VAR ast_index: stt$ast_index;
     var status: ost$status);

   VAR
     ast_entry: stt$active_set_entry,
     job_owner: ost$user_identification,
     local_set_name: ost$name,
     set_found: boolean,
     valid_name: boolean,
     valid_owner: boolean;


    clp$validate_name (set_name, local_set_name, valid_name);
    IF  valid_name THEN
      stp$search_ast_by_set (local_set_name, ast_entry, ast_index, set_found);
      IF set_found THEN
        IF (ast_entry.master_ever_up) AND (ast_entry.master_volume_activity.volume_activity_status =
          stc$active)  THEN
          status.normal := TRUE;
        ELSE
          osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, ast_entry.master_vsn,
               status);
          osp$append_status_parameter (osc$status_parameter_delimiter, ast_entry.set_name, status);
        IFEND;
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$set_not_active, stc$null_parameter, status);
      IFEND;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$bad_set_name, set_name, status);
    IFEND;

    IF status.normal THEN
        stp$validate_owner (ast_entry.set_owner, valid_owner);
        IF NOT valid_owner THEN
          pmp$get_user_identification (job_owner, status);
          osp$set_status_abnormal (stc$set_management_id, ste$set_not_job_owner, job_owner.user,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, job_owner.family, status);
          osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
        IFEND;
     IFEND;

  PROCEND;

MODEND stm$initialize_sets;
*DECK DECK=STM$MANAGE_IO_ON_VST EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$manage_io_on_vst;

{  PURPOSE:
{    This module manages the interfaces to device management.
{
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmp$attach_device_file
*copyc dmp$close_file
*copyc dmp$create_device_file
*copyc dmp$destroy_device_file
*copyc dmp$detach_device_file
*copyc dmp$get_active_vol_attributes
*copyc dmp$open_file
*copyc dmt$active_volume_table_index
*copyc dmt$system_file_id
*copyc mmp$write_modified_pages
*copyc osp$append_status_integer
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc ost$status
*copyc ost$user_identification
*copyc rmd$volume_declarations
*copyc std$miscellaneous
*copyc std$volume_set_table
*copyc ste$error_condition_codes
*copyc stk$keypoints
*copyc stt$set_ordinal
?? POP ??
?? TITLE := '  [XDCL, #GATE] stp$attach_vst', EJECT ??
*copyc sth$attach_vst

  PROCEDURE [XDCL, #GATE] stp$attach_vst (vsn: rmt$recorded_vsn;
    VAR sfid: dmt$system_file_id;
    VAR status: ost$status);


    VAR
      vst_df_name: ost$name;

    stp$build_vst_df_name (vsn, vst_df_name);
    dmp$attach_device_file (vsn, vst_df_name, sfid, status);
    IF NOT status.normal THEN
      IF status.condition = dme$unknown_device_file THEN
        osp$set_status_abnormal (stc$set_management_id, ste$vol_not_in_set, vsn, status);
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$attach_df_error, vsn, status);
      IFEND;
    IFEND;
  PROCEND stp$attach_vst;
?? TITLE := '  stp$build_vst_df_name', EJECT ??

  PROCEDURE stp$build_vst_df_name (vsn: rmt$recorded_vsn;
    VAR vst_name: ost$name);

    CONST
      stc$vst_device_file_name = 'STF$VOLUME_SET_TABLE';

    vst_name := stc$vst_device_file_name;
    vst_name ((20 + 1), * ) := vsn;
  PROCEND stp$build_vst_df_name;
?? TITLE := '  stp$clear_vst_being_modified', EJECT ??

  PROCEDURE stp$clear_vst_being_modified (p_vst: stt$p_vol_set_table;
    VAR status: ost$status);

    mmp$write_modified_pages (p_vst, stc$maximum_vst_size, osc$wait, status);
    IF status.normal THEN
      p_vst^.data_being_modified := 'FALSE';
      mmp$write_modified_pages (p_vst, stc$maximum_vst_size, osc$wait, status);
    IFEND;
  PROCEND stp$clear_vst_being_modified;


?? TITLE := '  [XDCL, #GATE] stp$create_vst', EJECT ??
*copyc sth$create_vst

  PROCEDURE [XDCL, #GATE] stp$create_vst (vsn: rmt$recorded_vsn;
    VAR vst_sfid: dmt$system_file_id;
    VAR vst_segment_pointer: mmt$segment_pointer;
    VAR status: ost$status);


    VAR
      local_status: ost$status,
      p_file_attributes: ^array [1 .. * ] of dmt$new_device_file_attribute,
      p_vst: stt$p_vol_set_table,
      vst_df_name: ost$name;

    PUSH p_file_attributes: [1 .. 1];
    IF p_file_attributes = NIL THEN
      osp$set_status_abnormal (stc$set_management_id, ste$push_failed, stc$null_parameter, status);
      osp$append_status_integer (osc$status_parameter_delimiter, 1, 10, FALSE, status);
    ELSE
      p_file_attributes^ [1].keyword := dmc$file_limit;
      p_file_attributes^ [1].limit := UPPERVALUE (amt$file_limit);
      stp$build_vst_df_name (vsn, vst_df_name);
      dmp$create_device_file (vst_df_name, vsn, p_file_attributes, stc$maximum_vst_size, vst_sfid, status);
    IFEND;

    IF status.normal THEN
      stp$open_device_file (vsn, vst_sfid, vst_segment_pointer, status);
      IF status.normal THEN

        p_vst := vst_segment_pointer.cell_pointer;
        stp$store_vst_being_modified (p_vst, status);
        IF status.normal THEN
          p_vst^.version_name := stc$current_vst_version_name;
        IFEND;
      ELSE
        stp$destroy_vst (vsn, local_status);
      IFEND;
    IFEND;
  PROCEND stp$create_vst;


?? TITLE := '  [XDCL, #GATE] stp$destroy_vst', EJECT ??
*copyc sth$destroy_vst

  PROCEDURE [XDCL, #GATE] stp$destroy_vst (vsn: rmt$recorded_vsn;
    VAR status: ost$status);

    VAR
      vst_df_name: ost$name;

    stp$build_vst_df_name (vsn, vst_df_name);
    dmp$destroy_device_file (vsn, vst_df_name, status);
  PROCEND stp$destroy_vst;

?? TITLE := '  [XDCL, #GATE] stp$detach_vst', EJECT ??
*copyc sth$detach_vst

  PROCEDURE [XDCL, #GATE] stp$detach_vst (sfid: dmt$system_file_id;
    VAR status: ost$status);


    VAR
      file_modified: boolean,
      fmd_modified: boolean;

    dmp$detach_device_file (sfid, file_modified, fmd_modified, status);
  PROCEND stp$detach_vst;



?? TITLE := '  [XDCL, #GATE] stp$dm_check_if_files_on_vol', EJECT ??
*copyc sth$dm_check_if_files_on_vol

  PROCEDURE [XDCL, #GATE] stp$dm_check_if_files_on_vol (volume: rmt$recorded_vsn;
    VAR files_on_vol: boolean);

    files_on_vol := FALSE;
  PROCEND stp$dm_check_if_files_on_vol;


?? TITLE := '  [XDCL, #GATE] stp$dm_mount_volume ', EJECT ??
*copyc sth$dm_mount_volume

  PROCEDURE [XDCL, #GATE] stp$dm_mount_volume (volume: rmt$recorded_vsn;
    VAR status: ost$status);

    osp$set_status_abnormal (stc$set_management_id, ste$impossible_to_mount, volume, status);
  PROCEND stp$dm_mount_volume;


?? TITLE := '  [XDCL] stp$open_attached_vst', EJECT ??
*copyc sth$open_attached_vst

  PROCEDURE [XDCL] stp$open_attached_vst
   (    vol: rmt$recorded_vsn;
        data_to_be_modified: boolean;
        sfid: dmt$system_file_id;
    VAR vst_segment_pointer: mmt$segment_pointer;
    VAR status: ost$status);

    VAR
      local_status: ost$status,
      p_vst: stt$p_vol_set_table;

    stp$open_device_file (vol, sfid, vst_segment_pointer, status);

    IF status.normal THEN
      p_vst := vst_segment_pointer.cell_pointer;
      IF p_vst^.data_being_modified <> 'FALSE' THEN
        stp$return_opened_vst (sfid, vst_segment_pointer, local_status);
        osp$set_status_abnormal (stc$set_management_id, ste$vol_set_table_lost_data, vol, status);
        osp$system_error (' ST - VST LOST DATA', ^status);
      ELSEIF p_vst^.version_name <> stc$current_vst_version_name THEN
        stp$return_opened_vst (sfid, vst_segment_pointer, status);
        osp$set_status_abnormal (stc$set_management_id, ste$incompatible_vst_version, vol, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, p_vst^.version_name, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, stc$current_vst_version_name, status);
        osp$system_error ('ST - INCOMPATIBLE VST ', ^status);
      IFEND;
    IFEND;

    IF status.normal AND data_to_be_modified THEN
      stp$store_vst_being_modified (p_vst, status);
      IF NOT status.normal THEN
        stp$return_opened_vst (sfid, vst_segment_pointer, status);
      IFEND;
    IFEND;


  PROCEND stp$open_attached_vst;


?? TITLE := '  stp$open_device_file ', EJECT ??

  PROCEDURE stp$open_device_file (vol: rmt$recorded_vsn;
        sfid: dmt$system_file_id;
    VAR segment_pointer: mmt$segment_pointer;
    VAR status: ost$status);

{  This interfaces to Device Management to open a device file.

    segment_pointer.kind := mmc$cell_pointer;
    dmp$open_file (sfid, 3, 3, mmc$sar_write_extend, mmc$as_random,
          segment_pointer, status);
    IF NOT status.normal THEN
      osp$set_status_abnormal (stc$set_management_id, ste$open_error, vol, status);
    IFEND;
  PROCEND stp$open_device_file;

?? TITLE := '  [XDCL, #GATE] stp$open_vst', EJECT ??
*copyc sth$open_vst

  PROCEDURE [XDCL, #GATE] stp$open_vst (vsn: rmt$recorded_vsn;
        data_to_be_modified: boolean;
    VAR sfid: dmt$system_file_id;
    VAR vst_segment_pointer: mmt$segment_pointer;
    VAR status: ost$status);


    VAR
      local_status: ost$status;

    stp$attach_vst (vsn, sfid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    stp$open_attached_vst (vsn, data_to_be_modified, sfid, vst_segment_pointer, status);
    IF NOT status.normal THEN
      stp$detach_vst (sfid, local_status);
    IFEND;
  PROCEND stp$open_vst;


?? TITLE := '  [XDCL, #GATE] stp$request_dm_volume_info', EJECT ??
*copyc sth$request_dm_volume_info

  PROCEDURE [XDCL, #GATE] stp$request_dm_volume_info (volume: rmt$recorded_vsn;
    VAR internal_vsn: dmt$internal_vsn;
    VAR volume_owner: ost$user_identification;
    VAR active_volume_table_index: dmt$active_volume_table_index;
    VAR volume_found: boolean);



    VAR
      p_active_volume_attributes: ^array [ * ] of dmt$assigned_ms_vol_attribute,
      search_avt_index: dmt$active_volume_table_index;

    PUSH p_active_volume_attributes: [1 .. 3];
    search_avt_index := 0;
    p_active_volume_attributes^ [1].keyword := dmc$avt_index;
    p_active_volume_attributes^ [2].keyword := dmc$ms_internal_vsn;
    p_active_volume_attributes^ [3].keyword := dmc$ms_volume_owner;
    dmp$get_active_vol_attributes (volume, search_avt_index, p_active_volume_attributes, volume_found);
    IF volume_found THEN
      active_volume_table_index := p_active_volume_attributes^ [1].index;
      internal_vsn := p_active_volume_attributes^ [2].internal_vsn;
{      volume_owner := p_active_volume_attributes^ [3].volume_owner;
      volume_owner.family := '$SYSTEM';
      volume_owner.user := '$SYSTEM';
    IFEND;
  PROCEND stp$request_dm_volume_info;


?? TITLE := '  [XDCL, #GATE] stp$return_opened_vst', EJECT ??
*copyc sth$return_opened_vst

  PROCEDURE [XDCL, #GATE] stp$return_opened_vst (sfid: dmt$system_file_id;
    VAR vst_segment_pointer: mmt$segment_pointer;
    VAR status: ost$status);



    VAR
      p_vst: stt$p_vol_set_table;


    p_vst := vst_segment_pointer.cell_pointer;
    IF p_vst^.data_being_modified = 'TRUE ' THEN
      stp$clear_vst_being_modified (p_vst, status);
    IFEND;
    IF status.normal THEN
      dmp$close_file (p_vst, status);
      IF status.normal THEN
        stp$detach_vst (sfid, status);
      IFEND;
    IFEND;
  PROCEND stp$return_opened_vst;


?? TITLE := '  [XDCL, #GATE] stp$store_vst_being_modified', EJECT ??

*copyc sth$store_vst_being_modified

  PROCEDURE [XDCL, #GATE] stp$store_vst_being_modified (p_vst: stt$p_vol_set_table;
    VAR status: ost$status);

    p_vst^.data_being_modified := 'TRUE ';
    mmp$write_modified_pages (p_vst, stc$maximum_vst_size, osc$wait, status);
  PROCEND stp$store_vst_being_modified;



MODEND stm$manage_io_on_vst;
*DECK DECK=STM$MISC_SERVICE_ROUTINES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$misc_service_routines;

{
{ PURPOSE:
{   This module contains those procedures of common use by the user level  set
{   manager.   This  includes  routines  to  validate  access,  and  to verify
{   parameters.
{
{ DESIGN: These routines may be run anywhere.

?? TITLE := '  Declarations ', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avp$configuration_administrator
*copyc clv$non_alphanumeric
*copyc osp$set_status_abnormal
*copyc ost$name
*copyc ost$status
*copyc ost$user_identification
*copyc osv$lower_to_upper
*copyc pmp$get_user_identification
*copyc rmd$volume_declarations
*copyc std$miscellaneous
*copyc ste$error_condition_codes
?? POP ??
?? TITLE := '  [XDCL] stp$validate_owner ', EJECT ??

  PROCEDURE [XDCL] stp$validate_owner (owner: ost$user_identification;
    VAR valid_owner: boolean);

{
{  PURPOSE:
{    This determines if the owner is validated to do a request.  A valid
{    requestor is either the same as requested owner, or a system administrator.
{


    VAR
      job_owner: ost$user_identification,
      status: ost$status;

    pmp$get_user_identification (job_owner, status);
    valid_owner := (avp$configuration_administrator ()) OR (job_owner = owner);
  PROCEND stp$validate_owner;

?? TITLE := '  [XDCL] stp$validate_recorded_vsn ', EJECT ??

  PROCEDURE [XDCL] stp$validate_recorded_vsn (recorded_vsn: rmt$recorded_vsn;
    VAR cap_recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

{  PURPUSE:
{     This procedure capatilizes a recorded vsn, and verifies that the recorded
{ vsn does not contain any non alphanumeric characters.

    VAR
      scan_index: 1 .. osc$max_name_size + 1,
      scan_found_non_alphanumeric: boolean;

    status.normal := TRUE;
    #translate (osv$lower_to_upper, recorded_vsn, cap_recorded_vsn);
    #scan (clv$non_alphanumeric, recorded_vsn, scan_index, scan_found_non_alphanumeric);
    IF recorded_vsn (scan_index, * ) <> '' THEN
      osp$set_status_abnormal (stc$set_management_id, ste$improper_recorded_vsn, '', status);
    IFEND;
{ see clp$validate_name for help
  PROCEND stp$validate_recorded_vsn;


?? TITLE := '  [XDCL] stp$validate_access_status', EJECT ??

  FUNCTION [XDCL] stp$valid_access_status (access_status: stt$access_status): boolean;


{  PURPOSE:
{  This function indicates if the users chosen access action is a valid choice.
    stp$valid_access_status := (access_status = stc$allow_access) OR (access_status = stc$deny_access);
  FUNCEND stp$valid_access_status;
MODEND stm$misc_servive_routines;
*DECK DECK=STM$MODIFY_AST_R1 EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$modify_ast_r1;


{
{ PURPOSE:
{   This module contains those procedure that modify the active set table.
{
{ DESIGN:
{   This modules live in system core library 113.
{   The pointer to the active set table is maintained as a static  pointer  in
{   this module.

?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ose$heap_full_exceptions
*copyc osp$append_status_parameter
*copyc osp$clear_mainframe_sig_lock
*copyc osp$initialize_sig_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$test_set_main_sig_lock
*copyc osp$test_sig_lock
*copyc ost$heap
*copyc ost$signature_lock
*copyc ost$status
*copyc ost$user_identification
*copyc ost$wait
*copyc osv$mainframe_pageable_heap
*copyc pmp$cycle
*copyc rmd$volume_declarations
*copyc std$active_set_table
*copyc std$miscellaneous
*copyc ste$error_condition_codes
*copyc stk$keypoints
*copyc stp$members_active_on_set
*copyc stt$dm_packet
?? POP ??

  VAR
    stv$global_modify_lock: [XDCL] ost$signature_lock := [0],
    stv$global_read_lock_set: [XDCL] boolean := FALSE,
    stv$global_number_of_readers: [XDCL] integer := 0,
    stv$p_ast: [XDCL] stt$p_active_set_table := NIL;



?? TITLE := '  [XDCL, #GATE] stp$add_member_in_ast', EJECT ??
*copyc sth$add_member_in_ast

  PROCEDURE [XDCL, #GATE] stp$add_member_in_ast (member_vol: rmt$recorded_vsn;
        member_internal_vsn: dmt$internal_vsn;
        members_activity: stt$vol_activity_status;
        members_avt_index: dmt$active_volume_table_index;
        ast_index: stt$ast_index;
        dm_packet_storage: stt$dm_packet_storage);


    VAR
      mel_index: stt$mel_index;

    stp$get_unused_mel_entry (ast_index, mel_index);
    stp$insert_member_into_mel (ast_index, mel_index, member_vol, member_internal_vsn, members_activity,
          members_avt_index, dm_packet_storage);
  PROCEND stp$add_member_in_ast;
?? TITLE := '  [XDCL, #GATE] stp$change_ast_access_status', EJECT ??
*copyc sth$change_ast_access_status

  PROCEDURE [XDCL, #GATE] stp$change_ast_access_status (ast_index: stt$ast_index;
        access_status: stt$access_status;
    VAR status: ost$status);


    stv$p_ast^.table [ast_index].access_status := access_status;
    status.normal := TRUE;
  PROCEND stp$change_ast_access_status;
?? TITLE := '  [XDCL, #GATE] stp$clear_ast_pf_lock', EJECT ??
*copyc sth$clear_ast_pf_lock

  PROCEDURE [XDCL, #GATE] stp$clear_ast_pf_lock (ast_index: stt$ast_index;
    VAR status: ost$status);

    VAR
      lock_status: ost$signature_lock_status;

    osp$test_sig_lock (stv$p_ast^.table [ast_index].pf_lock, lock_status);
    IF lock_status = osc$sls_not_locked THEN
      osp$set_status_abnormal (stc$set_management_id, ste$lock_not_set, stv$p_ast^.table [ast_index].set_name,
            status);
    ELSE
      status.normal := TRUE;
      osp$clear_mainframe_sig_lock (stv$p_ast^.table [ast_index].pf_lock);
    IFEND;
  PROCEND stp$clear_ast_pf_lock;


?? TITLE := '  [XDCL, #GATE] stp$clear_exclusive_access', EJECT ??
*copyc sth$clear_exclusive_access

  PROCEDURE [XDCL, #GATE] stp$clear_exclusive_access;

    osp$clear_mainframe_sig_lock (stv$global_modify_lock);
    #keypoint (osk$debug, 0, stk$clear_exclusive_lock);
  PROCEND stp$clear_exclusive_access;

?? TITLE := '  [XDCL, #GATE] stp$clear_read_access', EJECT ??
*copyc sth$clear_read_access

  PROCEDURE [XDCL, #GATE] stp$clear_read_access;

    osp$set_mainframe_sig_lock (stv$global_modify_lock);
    stv$global_number_of_readers := stv$global_number_of_readers - 1;
    IF stv$global_number_of_readers < 0 THEN
      stv$global_number_of_readers := 0;
    IFEND;
    stv$global_read_lock_set := stv$global_number_of_readers > 0;

    osp$clear_mainframe_sig_lock (stv$global_modify_lock);

  PROCEND stp$clear_read_access;

?? TITLE := '  [XDCL, #GATE] stp$create_ast_entry', EJECT ??
*copyc sth$create_ast_entry

  PROCEDURE [XDCL, #GATE] stp$create_ast_entry (set_name: stt$set_name;
        unique_set: stt$unique_set_name;
        master_vol: rmt$recorded_vsn;
        master_internal_vsn: dmt$internal_vsn;
        active_volume_table_index: dmt$active_volume_table_index;
        set_owner: ost$user_identification;
        access_status: stt$access_status;
        dm_packet_storage: stt$dm_packet_storage;
    VAR ast_index: stt$ast_index;
    VAR create_entry_status: ost$status);




    stp$get_unused_entry_in_ast (ast_index, create_entry_status);
    IF create_entry_status.normal THEN {space was found in the ast}
{
{     Fill in the information into the active set table entry.
      stv$p_ast^.table [ast_index].entry_type := stc$valid;
      stv$p_ast^.table [ast_index].set_name := set_name;
      stv$p_ast^.table [ast_index].unique_set_name := unique_set;
      stv$p_ast^.table [ast_index].master_vsn := master_vol;
      stv$p_ast^.table [ast_index].master_internal_vsn := master_internal_vsn;
      stv$p_ast^.table [ast_index].access_status := access_status;
      stv$p_ast^.table [ast_index].p_member_entry_list := NIL;
      stv$p_ast^.table [ast_index].master_ever_up := TRUE;
      stv$p_ast^.table [ast_index].master_volume_activity.volume_activity_status := stc$active;
      stv$p_ast^.table [ast_index].master_volume_activity.avt_index := active_volume_table_index;
      stv$p_ast^.table [ast_index].set_owner := set_owner;
      stv$p_ast^.table [ast_index].number_of_jobs_using_set := 0;
      stv$p_ast^.table [ast_index].pf_root_ever_stored := FALSE;
      osp$initialize_sig_lock (stv$p_ast^.table [ast_index].pf_lock);
      stv$p_ast^.table [ast_index].master_dm_packet_storage := dm_packet_storage;
      create_entry_status.normal := TRUE;
    IFEND;
  PROCEND stp$create_ast_entry;

?? TITLE := '  [XDCL, #GATE] stp$deallocate_ast_entry', EJECT ??
*copyc sth$deallocate_ast_entry

  PROCEDURE [XDCL, #GATE] stp$deallocate_ast_entry (ast_index: stt$ast_index;
    VAR status: ost$status);


    VAR
      active_members_found: boolean;

    status.normal := TRUE;
    IF stv$p_ast^.table [ast_index].number_of_jobs_using_set > 0 THEN
      osp$set_status_abnormal (stc$set_management_id, ste$jobs_on_set, stv$p_ast^.table [ast_index].set_name,
            status);
    ELSE
      IF stv$p_ast^.table [ast_index].master_volume_activity.volume_activity_status = stc$inactive THEN
        stp$members_active_on_set (ast_index, active_members_found);
        IF NOT active_members_found THEN
          stp$remove_set_from_ast (ast_index, status);
        IFEND;
      IFEND;
    IFEND;
  PROCEND stp$deallocate_ast_entry;

?? TITLE := '  [XDCL, #GATE] stp$decrement_job_use_in_ast', EJECT ??
*copyc sth$decrement_job_use_in_ast

  PROCEDURE [XDCL, #GATE] stp$decrement_job_use_in_ast (ast_index: stt$ast_index);

    stv$p_ast^.table [ast_index].number_of_jobs_using_set := stv$p_ast^.table [ast_index].
          number_of_jobs_using_set - 1;
  PROCEND stp$decrement_job_use_in_ast;




?? TITLE := '  [XDCL, #GATE] stp$get_unused_entry_in_ast', EJECT ??
*copyc sth$get_unused_entry_in_ast

  PROCEDURE [XDCL, #GATE] stp$get_unused_entry_in_ast (VAR ast_index: stt$ast_index;
    VAR status: ost$status);




?? EJECT ??

    CONST
      stc$initial_ast_size = 3,
      stc$expand_ast_amount = 3;

    VAR
      p_new_ast: stt$p_active_set_table,
      p_old_ast: stt$p_active_set_table,
      space_found: boolean;

    status.normal := TRUE;
    space_found := FALSE;
    IF stv$p_ast = NIL THEN
{     ALLOCATE A NEW ACTIVE SET TABLE
{     There must be a lock to prevent others from doing the expansion.
      ALLOCATE stv$p_ast: [1 .. stc$initial_ast_size] IN osv$mainframe_pageable_heap^;
      IF stv$p_ast = NIL THEN
        osp$set_status_abnormal (stc$set_management_id, ose$mainframe_pageable_full,
              stc$space_unavailable_ast, status);
      ELSE
        initialize_ast_to_unused (stv$p_ast);
        stp$search_ast_for_unused (stv$p_ast, ast_index, space_found);
      IFEND;
    ELSE
      stp$search_ast_for_unused (stv$p_ast, ast_index, space_found);
      IF NOT space_found THEN {expand the old table }
        ALLOCATE p_new_ast: [1 .. (UPPERBOUND (stv$p_ast^.table) + stc$expand_ast_amount)] IN
              osv$mainframe_pageable_heap^;
        IF p_new_ast = NIL THEN
          osp$set_status_abnormal (stc$set_management_id, ose$mainframe_pageable_full,
                stc$space_unavailable_ast, status);
        ELSE
          transfer_old_to_new_ast (stv$p_ast, p_new_ast, status);
          p_old_ast := stv$p_ast;
          stv$p_ast := p_new_ast;
          FREE p_old_ast IN osv$mainframe_pageable_heap^;
          stp$search_ast_for_unused (stv$p_ast, ast_index, space_found);
        IFEND;
      IFEND;
    IFEND;
    IF status.normal THEN
      #keypoint (osk$debug, osk$m * ast_index, stk$ast_index_assigned);
    IFEND;
  PROCEND stp$get_unused_entry_in_ast;
?? TITLE := '  [XDCL, #GATE] stp$get_unused_mel_entry', EJECT ??
*copyc sth$get_unused_mel_entry

  PROCEDURE [XDCL, #GATE] stp$get_unused_mel_entry (ast_index: stt$ast_index;
    VAR mel_index: stt$mel_index);


?? EJECT ??

    PROCEDURE stp$search_mel_for_unused (p_mel: stt$p_member_entry_list;
      VAR mel_index: stt$mel_index;
      VAR unused_entry_found: boolean);

{  PURPOSE:
{    This procedure searches the member entry list of the active set table,
{    looking for an unused entry.  If an unused entry is found, the index
{    of the entry is returned.

      unused_entry_found := FALSE;
      IF p_mel <> NIL THEN
        FOR mel_index := LOWERBOUND (p_mel^) TO UPPERBOUND (p_mel^) DO
          IF p_mel^ [mel_index].entry_type = stc$unused THEN
            unused_entry_found := TRUE;
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    PROCEND stp$search_mel_for_unused;

?? EJECT ??

    PROCEDURE stp$transfer_old_to_new_mel (p_old_mel: stt$p_member_entry_list;
          p_new_mel: stt$p_member_entry_list);

{  PURPOSE:
{    This procedure transfers an old member entry list, to a new one.
{    The new member is assumed equal to or larger than the old member.
{    If the new is larger, additional entries are initialized to unused.


      VAR
        mel_index: stt$mel_index;

      FOR mel_index := (LOWERBOUND (p_old_mel^)) TO UPPERBOUND (p_old_mel^) DO
        p_new_mel^ [mel_index] := p_old_mel^ [mel_index];
      FOREND;
      FOR mel_index := (UPPERBOUND (p_old_mel^) + 1) TO UPPERBOUND (p_new_mel^) DO
        p_new_mel^ [mel_index].entry_type := stc$unused;
      FOREND;
    PROCEND stp$transfer_old_to_new_mel;


?? EJECT ??

    PROCEDURE stp$initialize_mel_to_unused (p_mel: stt$p_member_entry_list);

{  PURPUSE:
{    This procedure initializes a member entry list to indicate that
{    all entries are unused.


      VAR
        mel_index: stt$mel_index;

      IF p_mel <> NIL THEN
        FOR mel_index := LOWERBOUND (p_mel^) TO UPPERBOUND (p_mel^) DO
          p_mel^ [mel_index].entry_type := stc$unused;
        FOREND;
      IFEND;
    PROCEND stp$initialize_mel_to_unused;



?? EJECT ??

    CONST
      stc$initial_mel_size = 8,
      stc$expand_mel_amount = 4;

    VAR
      p_new_mel: stt$p_member_entry_list,
      p_old_mel: stt$p_member_entry_list,
      unused_entry_found: boolean;

    IF stv$p_ast^.table [ast_index].p_member_entry_list = NIL THEN
{
{     CREATE A NEW MEMBER ENTRY LIST
{
      ALLOCATE stv$p_ast^.table [ast_index].p_member_entry_list: [1 .. stc$initial_mel_size] IN
            osv$mainframe_pageable_heap^;
      IF stv$p_ast^.table [ast_index].p_member_entry_list = NIL THEN
        { Cant happen - the heap manager will force a system error.
      ELSE
        stp$initialize_mel_to_unused (stv$p_ast^.table [ast_index].p_member_entry_list);
        stp$search_mel_for_unused (stv$p_ast^.table [ast_index].p_member_entry_list, mel_index,
              unused_entry_found);
      IFEND;
    ELSE
      stp$search_mel_for_unused (stv$p_ast^.table [ast_index].p_member_entry_list, mel_index,
            unused_entry_found);
      IF NOT unused_entry_found THEN
        ALLOCATE p_new_mel: [1 .. (UPPERBOUND (stv$p_ast^.table [ast_index].p_member_entry_list^) +
              stc$expand_mel_amount)] IN osv$mainframe_pageable_heap^;
        IF p_new_mel = NIL THEN
          { Cant happen - the heap manager will force a system error.
        ELSE
          stp$transfer_old_to_new_mel (stv$p_ast^.table [ast_index].p_member_entry_list, p_new_mel);
          p_old_mel := stv$p_ast^.table [ast_index].p_member_entry_list;
          stv$p_ast^.table [ast_index].p_member_entry_list := p_new_mel;
          FREE p_old_mel IN osv$mainframe_pageable_heap^;
          stp$search_mel_for_unused (stv$p_ast^.table [ast_index].p_member_entry_list, mel_index,
                unused_entry_found);
        IFEND;
      IFEND;
    IFEND;
    #keypoint (osk$debug, osk$m * mel_index, stk$mel_index_assigned);
    #keypoint (osk$data, ast_index, 0);
  PROCEND stp$get_unused_mel_entry;


?? TITLE := '  [XDCL, #GATE] stp$inactive_master', EJECT ??
*copyc sth$inactivate_master

  PROCEDURE [XDCL, #GATE] stp$inactivate_master (ast_index: stt$ast_index;
        dm_packet_storage: stt$dm_packet_storage;
    VAR status: ost$status);


    stv$p_ast^.table [ast_index].master_volume_activity.volume_activity_status := stc$inactive;
    stv$p_ast^.table [ast_index].master_dm_packet_storage := dm_packet_storage;
    status.normal := TRUE;
  PROCEND stp$inactivate_master;
?? TITLE := '  [XDCL, #GATE] stp$inactive_member', EJECT ??
*copyc sth$inactivate_member

  PROCEDURE [XDCL, #GATE] stp$inactivate_member (ast_index: stt$ast_index;
        inactive_vol: rmt$recorded_vsn;
        internal_vsn: dmt$internal_vsn;
        dm_packet_storage: stt$dm_packet_storage;
    VAR status: ost$status);



    VAR
      mel_index: stt$mel_index,
      member_entry: stt$member_entry,
      vol_found: boolean;

    IF stv$p_ast^.table [ast_index].p_member_entry_list = NIL THEN
      osp$set_status_abnormal (stc$set_management_id, ste$dm_mel_mismatch, inactive_vol, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, stv$p_ast^.table [ast_index].set_name,
            status);
    ELSE
      stp$search_mel_for_vol (inactive_vol, ast_index, member_entry, mel_index, vol_found);
      IF vol_found THEN
        IF member_entry.member_internal_vsn = internal_vsn THEN
          stv$p_ast^.table [ast_index].p_member_entry_list^ [mel_index].member_volume_activity.
                volume_activity_status := stc$inactive;
          stv$p_ast^.table [ast_index].p_member_entry_list^ [mel_index].member_dm_packet_storage :=
                dm_packet_storage;
          status.normal := TRUE;
        ELSE
          osp$set_status_abnormal (stc$set_management_id, ste$internal_vsn_mismatch, inactive_vol, status);
        IFEND;
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$dm_mel_mismatch, inactive_vol, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, stv$p_ast^.table [ast_index].set_name,
              status);
      IFEND;
    IFEND;
  PROCEND stp$inactivate_member;

?? TITLE := '  [XDCL, #GATE] stp$increment_job_count_in_ast', EJECT ??
*copyc sth$increment_job_count_in_ast

  PROCEDURE [XDCL, #GATE] stp$increment_job_count_in_ast (ast_index: stt$ast_index;
    VAR status: ost$status);



    IF stv$p_ast^.table [ast_index].entry_type = stc$valid THEN
      status.normal := TRUE;
      stv$p_ast^.table [ast_index].number_of_jobs_using_set := stv$p_ast^.table [ast_index].
            number_of_jobs_using_set + 1;
      {what about interlocks lock up entry }
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$set_not_active, stc$null_parameter, status);
    IFEND;
  PROCEND stp$increment_job_count_in_ast;



?? TITLE := '  [XDCL, #GATE] stp$insert_member_into_mel', EJECT ??
*copyc sth$insert_member_into_mel

  PROCEDURE [XDCL, #GATE] stp$insert_member_into_mel (ast_index: stt$ast_index;
        mel_index: stt$mel_index;
        member_vol: rmt$recorded_vsn;
        member_internal_vsn: dmt$internal_vsn;
        members_activity: stt$vol_activity_status;
        members_avt_index: dmt$active_volume_table_index;
        dm_packet_storage: stt$dm_packet_storage);

    VAR
      p_member_entry_list: stt$p_member_entry_list;

    p_member_entry_list := stv$p_ast^.table [ast_index].p_member_entry_list;
    p_member_entry_list^ [mel_index].entry_type := stc$valid;
    p_member_entry_list^ [mel_index].member_vsn := member_vol;
    p_member_entry_list^ [mel_index].member_internal_vsn := member_internal_vsn;
    p_member_entry_list^ [mel_index].member_volume_activity.volume_activity_status := members_activity;
    IF members_activity = stc$active THEN
      p_member_entry_list^ [mel_index].member_volume_activity.avt_index := members_avt_index;
    IFEND;
    p_member_entry_list^ [mel_index].member_dm_packet_storage := dm_packet_storage;
  PROCEND stp$insert_member_into_mel;

?? TITLE := '  [XDCL, #GATE] stp$obtain_ast_member_list', EJECT ??
*copyc sth$obtain_ast_member_list

  PROCEDURE [XDCL, #GATE] stp$obtain_ast_member_list (ast_index: stt$ast_index;
    VAR ast_member_list: stt$member_entry_list;
    VAR ast_member_entry_list_size: integer);


    VAR
      input_list_size: integer,
      mel_index: integer,
      p_member_entry_list: stt$p_member_entry_list;

    p_member_entry_list := stv$p_ast^.table [ast_index].p_member_entry_list;
    IF p_member_entry_list = NIL THEN
      ast_member_entry_list_size := 0;
    ELSE
      ast_member_entry_list_size := UPPERBOUND (p_member_entry_list^);
      input_list_size := UPPERBOUND (ast_member_list);

    /loop_through_member_list/
      FOR mel_index := 1 TO ast_member_entry_list_size DO
        IF mel_index > input_list_size THEN
          EXIT /loop_through_member_list/;
        ELSE
          ast_member_list [mel_index] := p_member_entry_list^ [mel_index];
        IFEND;
      FOREND /loop_through_member_list/;
    IFEND;
  PROCEND stp$obtain_ast_member_list;

?? TITLE := '  [XDCL, #GATE] stp$purge_ast_pf_root', EJECT ??
*copyc sth$purge_ast_pf_root

  PROCEDURE [XDCL, #GATE] stp$purge_ast_pf_root (ast_index: stt$ast_index);

    IF stv$p_ast^.table [ast_index].pf_root_ever_stored AND (stv$p_ast^.table [ast_index].p_pf_root <> NIL)
          THEN
      FREE stv$p_ast^.table [ast_index].p_pf_root IN osv$mainframe_pageable_heap^;
    IFEND;
    stv$p_ast^.table [ast_index].pf_root_ever_stored := FALSE;
  PROCEND stp$purge_ast_pf_root;


?? TITLE := '  [XDCL, #GATE] stp$remove_member_from_mel', EJECT ??
*copyc sth$remove_member_from_mel

  PROCEDURE [XDCL, #GATE] stp$remove_member_from_mel (member_vol: rmt$recorded_vsn;
        ast_index: stt$ast_index;
    VAR status: ost$status);


    VAR
      mel_index: stt$mel_index,
      member_entry: stt$member_entry,
      vol_found: boolean;

    stp$search_mel_for_vol (member_vol, ast_index, member_entry, mel_index, vol_found);
    IF vol_found THEN
      stv$p_ast^.table [ast_index].p_member_entry_list^ [mel_index].entry_type := stc$unused;
      status.normal := TRUE;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$member_not_in_mel, member_vol, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, stv$p_ast^.table [ast_index].set_name,
            status);
    IFEND;
  PROCEND stp$remove_member_from_mel;
?? TITLE := '  [XDCL, #GATE] stp$remove_set_from_ast', EJECT ??
*copyc sth$remove_set_from_ast

  PROCEDURE [XDCL, #GATE] stp$remove_set_from_ast (ast_index: stt$ast_index;
    VAR status: ost$status);

    IF stv$p_ast^.table [ast_index].entry_type = stc$valid THEN
      IF stv$p_ast^.table [ast_index].p_member_entry_list <> NIL THEN
        FREE stv$p_ast^.table [ast_index].p_member_entry_list IN osv$mainframe_pageable_heap^;
      IFEND;
      IF stv$p_ast^.table [ast_index].pf_root_ever_stored AND (stv$p_ast^.table [ast_index].p_pf_root <> NIL)
            THEN
        FREE stv$p_ast^.table [ast_index].p_pf_root IN osv$mainframe_pageable_heap^;
      IFEND;
    IFEND;
    status.normal := TRUE;
    stv$p_ast^.table [ast_index].entry_type := stc$unused;
  PROCEND stp$remove_set_from_ast;

?? TITLE := '  [XDCL] stp$search_ast_for_unused', EJECT ??

  PROCEDURE [XDCL] stp$search_ast_for_unused (stv$p_ast: stt$p_active_set_table;
    VAR ast_index: stt$ast_index;
    VAR unused_found: boolean);


{  PURPOSE:
{   This procedure searches the active set table looking for an unused
{    table entry.  The unused index number is returned.



    VAR
      upper: stt$ast_index;

    unused_found := FALSE;
    IF stv$p_ast <> NIL THEN
      ast_index := LOWERBOUND (stv$p_ast^.table);
      upper := UPPERBOUND (stv$p_ast^.table);
      WHILE NOT unused_found AND (ast_index <= upper) DO
        IF stv$p_ast^.table [ast_index].entry_type = stc$unused THEN
          unused_found := TRUE;
        ELSE
          ast_index := ast_index + 1;
        IFEND;
      WHILEND;
    IFEND;
  PROCEND stp$search_ast_for_unused;
?? TITLE := '  [XDCL, #GATE] stp$search_mel_for_vol', EJECT ??
*copyc sth$search_mel_for_vol

  PROCEDURE [XDCL, #GATE] stp$search_mel_for_vol (member_vol: rmt$recorded_vsn;
        ast_index: stt$ast_index;
    VAR member_entry: stt$member_entry;
    VAR mel_index: stt$mel_index;
    VAR volume_found: boolean);

    VAR
      p_mel: stt$p_member_entry_list;


    volume_found := FALSE;
    p_mel := stv$p_ast^.table [ast_index].p_member_entry_list;
    IF p_mel <> NIL THEN
      FOR mel_index := LOWERBOUND (p_mel^) TO UPPERBOUND (p_mel^) DO
        IF p_mel^ [mel_index].entry_type = stc$valid THEN
          IF p_mel^ [mel_index].member_vsn = member_vol THEN
            member_entry := p_mel^ [mel_index];
            volume_found := TRUE;
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND stp$search_mel_for_vol;

?? TITLE := '  [XDCL, #GATE] stp$store_ast_pf_lock', EJECT ??
*copyc sth$set_ast_pf_lock

  PROCEDURE [XDCL, #GATE] stp$set_ast_pf_lock (ast_index: stt$ast_index;
    VAR status: ost$status);

    VAR
      lock_status: ost$signature_lock_status,
      locked: boolean;

    status.normal := TRUE;
    osp$test_sig_lock (stv$p_ast^.table [ast_index].pf_lock, lock_status);
    IF lock_status = osc$sls_locked_by_current_task THEN
      osp$set_status_abnormal (stc$set_management_id, ste$lock_set_in_task, stv$p_ast^.table [ast_index].
            set_name, status);
    ELSEIF lock_status = osc$sls_locked_by_another_task THEN
      osp$set_status_abnormal (stc$set_management_id, ste$lock_set_in_another_task, stv$p_ast^.table
            [ast_index].set_name, status);
    ELSE
      osp$test_set_main_sig_lock (stv$p_ast^.table [ast_index].pf_lock, locked);
    IFEND;
  PROCEND stp$set_ast_pf_lock;
?? TITLE := '  [XDCL, #GATE] stp$set_exclusive_access', EJECT ??
*copyc sth$set_exclusive_access

  PROCEDURE [XDCL, #GATE] stp$set_exclusive_access;

    VAR
      local_status: ost$status,
      need_to_wait: boolean;

    stp$set_exclusive_access_in_ast (need_to_wait);
    WHILE need_to_wait DO
      pmp$cycle (local_status);
      stp$set_exclusive_access_in_ast (need_to_wait);
    WHILEND;
    #keypoint (osk$debug, 0, stk$set_exclusive_lock);
  PROCEND stp$set_exclusive_access;

?? TITLE := '  stp$set_exclusive_access_in_ast', EJECT ??

  PROCEDURE stp$set_exclusive_access_in_ast (VAR need_to_wait: boolean);

    osp$set_mainframe_sig_lock (stv$global_modify_lock);
    need_to_wait := stv$global_read_lock_set;
    IF need_to_wait THEN
      {dont wait with the lock set }
      osp$clear_mainframe_sig_lock (stv$global_modify_lock);
    IFEND;
  PROCEND stp$set_exclusive_access_in_ast;



?? TITLE := '  [XDCL, #GATE] stp$set_read_access', EJECT ??
*copyc sth$set_read_access

  PROCEDURE [XDCL, #GATE] stp$set_read_access;

    osp$set_mainframe_sig_lock (stv$global_modify_lock);
    stv$global_read_lock_set := TRUE;
    stv$global_number_of_readers := stv$global_number_of_readers + 1;
    osp$clear_mainframe_sig_lock (stv$global_modify_lock);
  PROCEND stp$set_read_access;




?? TITLE := '  [XDCL, #GATE] stp$store_ast_master_header', EJECT ??
*copyc sth$store_ast_master_header

  PROCEDURE [XDCL, #GATE] stp$store_ast_master_header (ast_index: stt$ast_index;
        masters_avt_index: dmt$active_volume_table_index;
        set_owner: ost$user_identification;
        dm_packet_storage: stt$dm_packet_storage;
        pf_root_stored: boolean;
        pf_root: pft$root;
    VAR status: ost$status);

    status.normal := TRUE;
    IF NOT stv$p_ast^.table [ast_index].master_ever_up THEN
      stv$p_ast^.table [ast_index].master_ever_up := TRUE;
      stv$p_ast^.table [ast_index].number_of_jobs_using_set := 0;
      stv$p_ast^.table [ast_index].pf_root_ever_stored := FALSE;
    IFEND;
    stv$p_ast^.table [ast_index].master_volume_activity.volume_activity_status := stc$active;
    stv$p_ast^.table [ast_index].master_volume_activity.avt_index := masters_avt_index;
    stv$p_ast^.table [ast_index].set_owner := set_owner;
    osp$initialize_sig_lock (stv$p_ast^.table [ast_index].pf_lock);
    stv$p_ast^.table [ast_index].master_dm_packet_storage := dm_packet_storage;
    IF pf_root_stored THEN
      stp$store_ast_pf_root (ast_index, pf_root, status);
    IFEND;
  PROCEND stp$store_ast_master_header;




?? TITLE := '  [XDCL, #GATE] stp$store_ast_pf_root', EJECT ??
*copyc sth$store_ast_pf_root

  PROCEDURE [XDCL, #GATE] stp$store_ast_pf_root (ast_index: stt$ast_index;
        pf_root: pft$root;
    VAR status: ost$status);

    VAR
      new_size: pft$root_size,
      p_new_pf_root: ^pft$root;

    status.normal := TRUE;
    new_size := #SIZE (pf_root);
    ALLOCATE p_new_pf_root: [[REP new_size OF cell]] IN osv$mainframe_pageable_heap^;
    IF p_new_pf_root = NIL THEN
      osp$set_status_abnormal (stc$set_management_id, ose$mainframe_pageable_full, stc$space_unavailable_ast,
            status);
    ELSE
      IF stv$p_ast^.table [ast_index].pf_root_ever_stored AND (stv$p_ast^.table [ast_index].p_pf_root <> NIL)
            THEN
        FREE stv$p_ast^.table [ast_index].p_pf_root IN osv$mainframe_pageable_heap^;
      IFEND;
      stv$p_ast^.table [ast_index].pf_root_ever_stored := TRUE;
      stv$p_ast^.table [ast_index].pf_root_size := new_size;
      stv$p_ast^.table [ast_index].p_pf_root := p_new_pf_root;
      stv$p_ast^.table [ast_index].p_pf_root^ := pf_root;
    IFEND;
  PROCEND stp$store_ast_pf_root;

?? TITLE := '  [XDCL, #GATE] stp$store_dm_packet_in_mel', EJECT ??
*copyc sth$store_dm_packet_in_mel

  PROCEDURE [XDCL, #GATE] stp$store_dm_packet_in_mel (ast_index: stt$ast_index;
        mel_index: stt$mel_index;
        dm_packet_storage: stt$dm_packet_storage);

    stv$p_ast^.table [ast_index].p_member_entry_list^ [mel_index].member_dm_packet_storage :=
          dm_packet_storage;
  PROCEND stp$store_dm_packet_in_mel;




?? TITLE := '  [XDCL, #GATE] stp$store_inactive_master', EJECT ??
*copyc sth$store_inactive_master

  PROCEDURE [XDCL, #GATE] stp$store_inactive_master (set_name: stt$set_name;
        unique_set_name: stt$unique_set_name;
        master_vsn: rmt$recorded_vsn;
        internal_vsn: dmt$internal_vsn;
        access_status: stt$access_status;
        ast_index: stt$ast_index);

    stv$p_ast^.table [ast_index].entry_type := stc$valid;
    stv$p_ast^.table [ast_index].set_name := set_name;
    stv$p_ast^.table [ast_index].unique_set_name := unique_set_name;
    stv$p_ast^.table [ast_index].p_member_entry_list := NIL;
    stv$p_ast^.table [ast_index].access_status := access_status;
    stv$p_ast^.table [ast_index].master_vsn := master_vsn;
    stv$p_ast^.table [ast_index].master_internal_vsn := internal_vsn;
    stv$p_ast^.table [ast_index].master_ever_up := FALSE;
  PROCEND stp$store_inactive_master;





?? TITLE := '  initialize_ast_to_unused', EJECT ??

  PROCEDURE initialize_ast_to_unused (stv$p_ast: stt$p_active_set_table);

{  PURPOSE:
{    This procedure initializes an active set table, to indicate that
{    all entries are unused.


    VAR
      ast_index: stt$ast_index;

    IF stv$p_ast <> NIL THEN
      FOR ast_index := LOWERBOUND (stv$p_ast^.table) TO UPPERBOUND (stv$p_ast^.table) DO
        stv$p_ast^.table [ast_index].entry_type := stc$unused;
      FOREND;
    IFEND;
  PROCEND initialize_ast_to_unused;

?? TITLE := '  transfer_old_to_new_ast', EJECT ??

  PROCEDURE transfer_old_to_new_ast (p_old_ast: stt$p_active_set_table;
        p_new_ast: stt$p_active_set_table;
    VAR status: ost$status);

{  PURPOSE:
{    This procedure transfers an old active set table, to a new one.  The new
{    table must be equal to or larger than the old table.  If the new table
{    is larger, additional tables are initialized to indicate they are unused.


    VAR
      ast_index: stt$ast_index;

    FOR ast_index := LOWERBOUND (p_old_ast^.table) TO UPPERBOUND (p_old_ast^.table) DO
      p_new_ast^.table [ast_index] := p_old_ast^.table [ast_index];
    FOREND;
    FOR ast_index := (UPPERBOUND (p_old_ast^.table) + 1) TO UPPERBOUND (p_new_ast^.table) DO
      p_new_ast^.table [ast_index].entry_type := stc$unused;
    FOREND;
    status.normal := TRUE;
  PROCEND transfer_old_to_new_ast;





?? TITLE := '  [XDCL, #GATE] stp$update_system_set_name', EJECT ??
*copyc stv$system_set_name

  PROCEDURE [XDCL, #GATE] stp$update_system_set_name (set_name: stt$set_name);

    stv$system_set_name := set_name;

  PROCEND stp$update_system_set_name;

MODEND stm$modify_ast_r1;
*DECK DECK=STM$MODIFY_JOB_SET_TABLE EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??

MODULE stm$modify_job_set_table;

{
{ PURPOSE:
{   This module contains those routines that modify the job active set  table.
{
{ DESIGN:
{   A  pointer  to the job active set table is maintained as a static variable
{   in this ring 2 (223) module.  On creating a new entry, if the  pointer  is
{   NIL  a  new  job  active  set  table is allocated.  Locks to the table are
{   maintained as static variables in this module.
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ose$heap_full_exceptions
*copyc osp$clear_job_signature_lock
*copyc osp$initialize_signature_lock
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc ost$signature_lock
*copyc ost$status
*copyc ost$user_identification
*copyc osv$job_pageable_heap
*copyc pmp$wait
*copyc std$job_active_set_table
*copyc std$miscellaneous
*copyc ste$error_condition_codes
*copyc stp$search_jast_for_unused
?? POP ??

  VAR
    stv$jast_modify_lock: [XDCL] ost$signature_lock := [0],
    stv$jast_read_lock_set: [XDCL] boolean := FALSE,
    stv$jast_number_of_readers: [XDCL] integer := 0,
    stv$p_jast: [XDCL] stt$p_job_active_set_table := NIL;



?? TITLE := '  [XDCL] stp$clear_job_ast_exclusive', EJECT ??

  PROCEDURE [XDCL] stp$clear_job_ast_exclusive;


    osp$clear_job_signature_lock (stv$jast_modify_lock);
  PROCEND stp$clear_job_ast_exclusive;



?? TITLE := '  [XDCL] stp$clear_job_ast_read', EJECT ??

  PROCEDURE [XDCL] stp$clear_job_ast_read;


    osp$set_job_signature_lock (stv$jast_modify_lock);
    stv$jast_number_of_readers := stv$jast_number_of_readers - 1;
    IF stv$jast_number_of_readers < 0 THEN
      stv$jast_number_of_readers := 0;
    IFEND;
    stv$jast_read_lock_set := stv$jast_number_of_readers > 0;
    osp$clear_job_signature_lock (stv$jast_modify_lock);
  PROCEND stp$clear_job_ast_read;
?? TITLE := '  [XDCL] stp$create_jast_entry', EJECT ??

  PROCEDURE [XDCL] stp$create_jast_entry (required_set: stt$set_name;
        unique_set: stt$unique_set_name;
        ast_index: stt$ast_index;
    VAR status: ost$status);

{  PURPOSE:
{    This procedure gets an unused entry in the job active set table, and
{    fills that entry with valid information.




    VAR
      jast_index: integer;

    stp$get_unused_entry_in_jast (jast_index, status);
    IF status.normal THEN {space was found}
{
{     STORE THE INFORMATION IN THE FOUND ENTRY
      stv$p_jast^.table [jast_index].entry_type := stc$valid;
      stv$p_jast^.table [jast_index].set_name := required_set;
      stv$p_jast^.table [jast_index].unique_set_name := unique_set;
      stv$p_jast^.table [jast_index].ast_index := ast_index;
    IFEND;
  PROCEND stp$create_jast_entry;

?? TITLE := '  [XDCL] stp$get_unused_entry_in_jast ', EJECT ??

  PROCEDURE [XDCL] stp$get_unused_entry_in_jast (VAR jast_index: integer;
    VAR status: ost$status);

{  PURPOSE:
{    This procedure does what is needed to get an unused entry in the
{    job active set table.  This could include searching for an unused entry,
{    creating a new table, or expanding an old table.



    CONST
      stc$initial_jast_size = 3,
      stc$expand_jast_amount = 3;

    VAR
      p_new_jast: stt$p_job_active_set_table,
      space_found: boolean;

    space_found := FALSE;
    IF stv$p_jast = NIL THEN
{     CREATE NEW TABLE
      ALLOCATE stv$p_jast: [1 .. stc$initial_jast_size] IN osv$job_pageable_heap^;
      IF stv$p_jast = NIL THEN
        osp$set_status_abnormal (stc$set_management_id, ose$job_pageable_full, stc$space_unavailable_jast,
              status);
      ELSE
        initialize_jast_to_unused (stv$p_jast);
        stp$search_jast_for_unused (stv$p_jast, jast_index, space_found);
      IFEND;
    ELSE
      stp$search_jast_for_unused (stv$p_jast, jast_index, space_found);
      IF NOT space_found THEN
{       EXPAND AN EXISTING TABLE
        ALLOCATE p_new_jast: [1 .. (UPPERBOUND (stv$p_jast^.table) + stc$expand_jast_amount)] IN
              osv$job_pageable_heap^;
        IF p_new_jast = NIL THEN
          osp$set_status_abnormal (stc$set_management_id, ose$job_pageable_full, stc$space_unavailable_jast,
                status);
        ELSE
          transfer_old_to_new_jast (stv$p_jast, p_new_jast, status);
          FREE stv$p_jast IN osv$job_pageable_heap^;
          {store the new pointer someplace}
          stv$p_jast := p_new_jast;
          stp$search_jast_for_unused (stv$p_jast, jast_index, space_found);
        IFEND;
      IFEND;
    IFEND;
  PROCEND stp$get_unused_entry_in_jast;

?? TITLE := '  [XDCL] stp$recover_jobs_sets', EJECT ??

  PROCEDURE [XDCL] stp$recover_jobs_sets (VAR status: ost$status);

{   The purpose of this routine is to recover the job set table, following
{ a system recovery in which jobs are recovered.  Because of the current
{ use of the mainframe  lock to lock this table, no verification can be
{ made on the state of this table.
{   This table is currently only used for performance, and the next
{ permanent file access will re-built this table.  With only one set
{ the table could probably be used as is, since the active set table index
{ is always one.
{   If we ever have multiple sets or removable devices, this table could
{ be used to verify that all of the sets or devices that the job was using
{ are active.

    stv$p_jast := NIL;
    stv$jast_read_lock_set := FALSE;
    stv$jast_number_of_readers := 0;
    osp$initialize_signature_lock (stv$jast_modify_lock, status);


  PROCEND stp$recover_jobs_sets;
?? TITLE := '  [XDCL] stp$remove_set_from_jast', EJECT ??

  PROCEDURE [XDCL] stp$remove_set_from_jast (set_name: stt$set_name;
    VAR status: ost$status);

{
{  PURPOSE:
{    This procedure removes a given set from the jobs active set table.
{    This is done on a purge set.
{

    VAR
      jast_index: integer;

    status.normal := TRUE;
    IF stv$p_jast <> NIL THEN
      FOR jast_index := LOWERBOUND (stv$p_jast^.table) TO UPPERBOUND (stv$p_jast^.table) DO
        IF (stv$p_jast^.table [jast_index].entry_type = stc$valid) AND (stv$p_jast^.table [jast_index].
              set_name = set_name) THEN
          stv$p_jast^.table [jast_index].entry_type := stc$unused;
          RETURN;
        IFEND;
      FOREND;
    IFEND;
  PROCEND stp$remove_set_from_jast;



?? TITLE := '  stp$set_exclusive_access_in_jas', EJECT ??

  PROCEDURE stp$set_exclusive_access_in_jas (VAR need_to_wait: boolean);

    osp$set_job_signature_lock (stv$jast_modify_lock);
    need_to_wait := stv$jast_read_lock_set;
    IF need_to_wait THEN
      {dont wait with the lock set }
      osp$clear_job_signature_lock (stv$jast_modify_lock);
    IFEND;
  PROCEND stp$set_exclusive_access_in_jas;





?? TITLE := '  [XDCL] stp$set_job_ast_exclusive', EJECT ??

  PROCEDURE [XDCL] stp$set_job_ast_exclusive;

    VAR
      need_to_wait: boolean;

    stp$set_exclusive_access_in_jas (need_to_wait);
    WHILE need_to_wait DO
      pmp$wait (0ff(16), 0ff(16));
      stp$set_exclusive_access_in_jas (need_to_wait);
    WHILEND;
  PROCEND stp$set_job_ast_exclusive;



?? TITLE := '  [XDCL] stp$set_job_ast_read', EJECT ??

  PROCEDURE [XDCL] stp$set_job_ast_read;

    osp$set_job_signature_lock (stv$jast_modify_lock);
    stv$jast_read_lock_set := TRUE;
    stv$jast_number_of_readers := stv$jast_number_of_readers + 1;
    osp$clear_job_signature_lock (stv$jast_modify_lock);
  PROCEND stp$set_job_ast_read;





?? TITLE := '  initialize_jast_to_unused', EJECT ??

  PROCEDURE initialize_jast_to_unused (stv$p_jast: stt$p_job_active_set_table);

{  PURPOSE:
{    This procedure initialize the job active set table to indicate that all
{    entries are unused.





    VAR
      jast_index: integer;

    FOR jast_index := LOWERBOUND (stv$p_jast^.table) TO UPPERBOUND (stv$p_jast^.table) DO
      stv$p_jast^.table [jast_index].entry_type := stc$unused;
    FOREND;
  PROCEND initialize_jast_to_unused;


?? TITLE := '  transfer_old_to_new_jast', EJECT ??

  PROCEDURE transfer_old_to_new_jast (p_old_jast: stt$p_job_active_set_table;
        p_new_jast: stt$p_job_active_set_table;
    VAR status: ost$status);

{  PURPOSE:
{    This transfers an old job active set table to a new one, entry by entry.
{    The new table is assumed to be as big as, or bigger than, the old table.


    VAR
      jast_index: stt$jast_index;

    status.normal := TRUE;
    FOR jast_index := LOWERBOUND (p_old_jast^.table) TO UPPERBOUND (p_old_jast^.table) DO
      p_new_jast^.table [jast_index] := p_old_jast^.table [jast_index];
    FOREND;
    FOR jast_index := (UPPERBOUND (p_old_jast^.table) + 1) TO (UPPERBOUND (p_new_jast^.table)) DO
      p_new_jast^.table [jast_index].entry_type := stc$unused;
    FOREND;
  PROCEND transfer_old_to_new_jast;






MODEND stm$modify_job_set_table;
*DECK DECK=STM$MODIFY_VST EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$modify_vst;

{
{ PURPOSE:
{   This module includes all procedure that modify the volume set  table.   In
{   general the volume set table must have been attached prior to calling most
{   of these routines.
{
{ DESIGN:
{   This module lives in the system core module 133.

?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osp$reset_heap
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc std$active_set_table
*copyc std$miscellaneous
*copyc std$volume_set_table
*copyc ste$error_condition_codes
*copyc stp$build_member_list_locator
*copyc stp$build_member_list_pointer
*copyc stp$build_pf_root_locator
*copyc stp$build_pf_root_pointer
*copyc stp$open_vst
*copyc stp$return_opened_vst
*copyc stp$search_ast_by_set
*copyc stp$search_mvl_for_vol
?? POP ??
?? TITLE := '  [XDCL, #GATE] stp$add_member_in_master_vst ', EJECT ??
*copyc sth$add_member_in_master_vst

  PROCEDURE [XDCL, #GATE] stp$add_member_in_master_vst (p_master_vst: stt$p_vol_set_table;
        member_vol: rmt$recorded_vsn;
        member_internal_vsn: dmt$internal_vsn;
        dm_packet_storage: stt$dm_packet_storage;
    VAR status: ost$status);



    VAR
      mvl_index: stt$mvl_index,
      p_new_member_vsn_list: stt$p_member_vsn_list,
      unused_entry_found: boolean;


    stp$build_member_list_pointer (p_master_vst^.member_vsn_list_locator, p_master_vst,
          p_new_member_vsn_list);
    stp$search_mvl_for_unused_entry (p_new_member_vsn_list, mvl_index, unused_entry_found);
    IF unused_entry_found THEN
      {store information about the member in the master.
      status.normal := TRUE;
      p_new_member_vsn_list^ [mvl_index].entry_type := stc$valid;
      p_new_member_vsn_list^ [mvl_index].member_vsn := member_vol;
      p_new_member_vsn_list^ [mvl_index].member_internal_vsn := member_internal_vsn;
      p_new_member_vsn_list^ [mvl_index].member_dm_packet_storage := dm_packet_storage;
    ELSE
      {the member vsn list is of fixed size in the volume set table.
      osp$set_status_abnormal (stc$set_management_id, ste$exceeded_max_num_vol, p_master_vst^.set_name,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, member_vol, status);
    IFEND;
  PROCEND stp$add_member_in_master_vst;


?? TITLE := '  [XDCL, #GATE] stp$build_member_vst', EJECT ??
*copyc sth$build_member_vst

  PROCEDURE [XDCL, #GATE] stp$build_member_vst (p_member_vst: stt$p_vol_set_table;
        member_vsn: rmt$recorded_vsn;
        member_internal_vsn: dmt$internal_vsn;
        set_name: stt$set_name;
        unique_set_name: stt$unique_set_name;
        master_vol: rmt$recorded_vsn;
        master_internal_vsn: dmt$internal_vsn);


    p_member_vst^.vsn := member_vsn;
    p_member_vst^.internal_vsn := member_internal_vsn;
    p_member_vst^.entry_type := stc$valid;
    p_member_vst^.set_name := set_name;
    p_member_vst^.unique_set_name := unique_set_name;
    p_member_vst^.vol_status_in_set := stc$member_vol;
    p_member_vst^.master_vsn := master_vol;
    p_member_vst^.master_internal_vsn := master_internal_vsn;

  PROCEND stp$build_member_vst;

?? TITLE := '  [XDCL, #GATE] stp$clear_root_recreated', EJECT ??
  PROCEDURE [XDCL, #GATE] stp$clear_root_recreated
    (    set_name: stt$set_name;
     VAR status: ost$status);

    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index,
      local_status: ost$status,
      master_vol: rmt$recorded_vsn,
      master_vst_segment_pointer: mmt$segment_pointer,
      masters_sfid: dmt$system_file_id,
      p_master_vst: stt$p_vol_set_table,
      set_found_in_ast: boolean;

    stp$search_ast_by_set (set_name, ast_entry, ast_index, set_found_in_ast);
    IF set_found_in_ast THEN
      master_vol := ast_entry.master_vsn;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$set_not_active, set_name, status);
      RETURN;
    IFEND;
    stp$open_vst (master_vol, TRUE, masters_sfid, master_vst_segment_pointer, status);
    IF status.normal THEN
      p_master_vst := master_vst_segment_pointer.cell_pointer;
      p_master_vst^.root_recreated := stc$root_not_recreated;
      stp$return_opened_vst (masters_sfid, master_vst_segment_pointer, local_status);
      IF status.normal AND NOT local_status.normal THEN
        status := local_status;
      IFEND;
    IFEND;

  PROCEND stp$clear_root_recreated;

?? TITLE := '  [XDCL, #GATE] stp$fill_master_vst', EJECT ??
*copyc sth$fill_master_vst

  PROCEDURE [XDCL, #GATE] stp$fill_master_vst (p_master_vst: stt$p_vol_set_table;
        master_vsn: rmt$recorded_vsn;
        master_internal_vsn: dmt$internal_vsn;
        set_name: stt$set_name;
        unique_set: stt$unique_set_name;
        set_owner: ost$user_identification;
        dm_packet_storage: stt$dm_packet_storage;
        root_recreated: boolean;
    VAR status: ost$status);





    PROCEDURE stp$initialize_mvl_to_unused (p_member_vsn_list: stt$p_member_vsn_list);

{    PURPOSE:
{      This initializes the member vsn list, of the master volume set table,
{      to indicate that there are no member volumes in the set, yeti.

      VAR
        mvl_index: stt$mvl_index;

      FOR mvl_index := LOWERBOUND (p_member_vsn_list^) TO UPPERBOUND (p_member_vsn_list^) DO
        p_member_vsn_list^ [mvl_index].entry_type := stc$unused;
      FOREND;
    PROCEND stp$initialize_mvl_to_unused;

    VAR
      p_heap: ^ost$heap,
      p_member_vsn_list: stt$p_member_vsn_list;




    status.normal := TRUE;
    p_master_vst^.vsn := master_vsn;
    p_master_vst^.internal_vsn := master_internal_vsn;
    p_master_vst^.entry_type := stc$valid;
    p_master_vst^.set_name := set_name;
    p_master_vst^.unique_set_name := unique_set;
    p_master_vst^.vol_status_in_set := stc$master_vol;
    p_master_vst^.set_owner := set_owner;
    p_master_vst^.pf_root_storage.pf_root_ever_stored := FALSE;
    p_master_vst^.master_dm_packet_storage := dm_packet_storage;

    IF root_recreated THEN
      p_master_vst^.root_recreated := stc$root_recreated;
    ELSE
      p_master_vst^.root_recreated := stc$root_not_recreated;
    IFEND;

    p_heap := ^p_master_vst^.vst_heap;
    osp$reset_heap (p_heap, 1000000, FALSE, 1); {reset does not work}
    ALLOCATE p_member_vsn_list: [1 .. stc$max_num_members_on_set] IN p_heap^;
    IF p_member_vsn_list = NIL THEN
      {I made a mistake in choosing either size of heap or maximum number of volumes allowed on the set.
      osp$set_status_abnormal (stc$set_management_id, ste$no_space_vst_heap, master_vsn, status);
    ELSE
      stp$initialize_mvl_to_unused (p_member_vsn_list);
      stp$build_member_list_locator (p_member_vsn_list, p_master_vst, p_master_vst^.member_vsn_list_locator);
    IFEND;
  PROCEND stp$fill_master_vst;


?? TITLE := '  [XDCL, #GATE] stp$purge_vst_pf_root', EJECT ??
*copyc sth$purge_vst_pf_root

  PROCEDURE [XDCL, #GATE] stp$purge_vst_pf_root (master_vsn: rmt$recorded_vsn;
    VAR status: ost$status);

    VAR
      local_status: ost$status,
      p_master_vst: stt$p_vol_set_table,
      p_old_pf_root: ^pft$root,
      sfid: dmt$system_file_id,
      vst_segment_pointer: mmt$segment_pointer;

    stp$open_vst (master_vsn, TRUE, sfid, vst_segment_pointer, status);

    IF status.normal THEN
      p_master_vst := vst_segment_pointer.cell_pointer;
      IF p_master_vst^.pf_root_storage.pf_root_ever_stored THEN
        stp$build_pf_root_pointer (p_master_vst^.pf_root_storage.pf_root_locator, p_master_vst,
              p_old_pf_root);
        IF p_old_pf_root <> NIL THEN
          FREE p_old_pf_root IN p_master_vst^.vst_heap;
        IFEND;
      IFEND;
      p_master_vst^.pf_root_storage.pf_root_ever_stored := FALSE;
      stp$return_opened_vst (sfid, vst_segment_pointer, local_status);
    IFEND;
  PROCEND stp$purge_vst_pf_root;



?? TITLE := '  [XDCL, #GATE] stp$remove_member_from_master', EJECT ??
*copyc sth$remove_member_from_master

  PROCEDURE [XDCL, #GATE] stp$remove_member_from_master (member_vol: rmt$recorded_vsn;
        p_master_vst: stt$p_vol_set_table;
    VAR status: ost$status);


    VAR
      member_volume_found: boolean,
      mvl_index: stt$mvl_index,
      p_new_member_vsn_list: stt$p_member_vsn_list;


    {take care of relative pointer.
    stp$build_member_list_pointer (p_master_vst^.member_vsn_list_locator, p_master_vst,
          p_new_member_vsn_list);

    stp$search_mvl_for_vol (member_vol, p_new_member_vsn_list, mvl_index, member_volume_found);
    IF member_volume_found THEN
      status.normal := TRUE;
      p_new_member_vsn_list^ [mvl_index].entry_type := stc$unused;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$member_not_in_master, member_vol, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, p_master_vst^.set_name, status);
    IFEND;
  PROCEND stp$remove_member_from_master;


?? TITLE := '  [XDCL, #GATE] stp$remove_set_from_vst', EJECT ??
*copyc sth$remove_set_from_vst

  PROCEDURE [XDCL, #GATE] stp$remove_set_from_vst (p_vst: stt$p_vol_set_table;
    VAR status: ost$status);

    VAR
      new_p_member_vsn_list: stt$p_member_vsn_list;

{
{   Make sure the member vsn list has been freed.
    IF p_vst^.entry_type = stc$valid THEN
      IF p_vst^.vol_status_in_set = stc$master_vol THEN
        stp$build_member_list_pointer (p_vst^.member_vsn_list_locator, p_vst, new_p_member_vsn_list);
        IF new_p_member_vsn_list <> NIL THEN
          FREE new_p_member_vsn_list IN p_vst^.vst_heap;
        IFEND;
      IFEND;
    IFEND;

    p_vst^.entry_type := stc$unused;
    status.normal := TRUE;
  PROCEND stp$remove_set_from_vst;


?? TITLE := '  [XDCL] stp$search_mvl_for_unused_entry', EJECT ??
*copyc sth$search_mvl_for_unused_entry

  PROCEDURE [XDCL] stp$search_mvl_for_unused_entry
   (    p_member_vsn_list: stt$p_member_vsn_list;
    VAR mvl_index: stt$mvl_index;
    VAR unused_entry_found: boolean);


    IF p_member_vsn_list = NIL THEN
      unused_entry_found := FALSE;
    ELSE
      unused_entry_found := FALSE;

    /search_mvl_for_unused/
      FOR mvl_index := LOWERBOUND (p_member_vsn_list^) TO UPPERBOUND (p_member_vsn_list^) DO
        IF p_member_vsn_list^ [mvl_index].entry_type = stc$unused THEN
          unused_entry_found := TRUE;
          EXIT /search_mvl_for_unused/;
        IFEND;
      FOREND /search_mvl_for_unused/;
    IFEND;
  PROCEND stp$search_mvl_for_unused_entry;

?? TITLE := '  [XDCL] stp$store_dm_packet_in_master', EJECT ??
*copyc sth$store_dm_packet_in_master

  PROCEDURE [XDCL] stp$store_dm_packet_in_master
   (    master_vsn: rmt$recorded_vsn;
        inactive_member: rmt$recorded_vsn;
        new_dm_packet_storage: stt$dm_packet_storage;
    VAR status: ost$status);

    VAR
      local_status: ost$status,
      masters_segment_pointer: mmt$segment_pointer,
      masters_sfid: dmt$system_file_id,
      mvl_index: stt$mvl_index,
      new_p_member_vsn_list: stt$p_member_vsn_list,
      p_master_vst: stt$p_vol_set_table,
      volume_found: boolean;


    stp$open_vst (master_vsn, TRUE, masters_sfid, masters_segment_pointer, status);
    IF status.normal THEN
      p_master_vst := masters_segment_pointer.cell_pointer;
      stp$build_member_list_pointer (p_master_vst^.member_vsn_list_locator, p_master_vst,
            new_p_member_vsn_list);
      stp$search_mvl_for_vol (inactive_member, new_p_member_vsn_list, mvl_index, volume_found);
      IF volume_found THEN
        stp$store_dm_packet_in_mvl (new_p_member_vsn_list, mvl_index, new_dm_packet_storage);
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$vol_not_found, inactive_member, status);
      IFEND;
      stp$return_opened_vst (masters_sfid, masters_segment_pointer, local_status);
    IFEND;
  PROCEND stp$store_dm_packet_in_master;


?? TITLE := '  [XDCL] stp$store_dm_packet_in_mvl', EJECT ??
*copyc sth$store_dm_packet_in_mvl

  PROCEDURE [XDCL] stp$store_dm_packet_in_mvl
   (    p_member_vsn_list: stt$p_member_vsn_list;
        mvl_index: stt$mvl_index;
        dm_packet_storage: stt$dm_packet_storage);

    p_member_vsn_list^ [mvl_index].member_dm_packet_storage := dm_packet_storage;
  PROCEND stp$store_dm_packet_in_mvl;

?? TITLE := '  [XDCL] stp$store_master_dm_packet', EJECT ??
*copyc sth$store_master_dm_packet

  PROCEDURE [XDCL] stp$store_master_dm_packet
   (    p_master_vst: stt$p_vol_set_table;
        dm_packet_storage: stt$dm_packet_storage);

    p_master_vst^.master_dm_packet_storage := dm_packet_storage;
  PROCEND stp$store_master_dm_packet;


?? TITLE := '  [XDCL] stp$store_member_dm_packet', EJECT ??
*copyc sth$store_member_dm_packet

  PROCEDURE [XDCL] stp$store_member_dm_packet
   (    p_master_vst: stt$p_vol_set_table;
        inactive_member: rmt$recorded_vsn;
        dm_packet_storage: stt$dm_packet_storage;
    VAR status: ost$status);

    VAR
      mvl_index: stt$mvl_index,
      new_p_member_vsn_list: stt$p_member_vsn_list,
      volume_found: boolean;

    stp$build_member_list_pointer (p_master_vst^.member_vsn_list_locator, p_master_vst,
          new_p_member_vsn_list);
    status.normal := TRUE;
    stp$search_mvl_for_vol (inactive_member, new_p_member_vsn_list, mvl_index, volume_found);
    IF volume_found THEN
      stp$store_dm_packet_in_mvl (new_p_member_vsn_list, mvl_index, dm_packet_storage);
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$vol_not_found, inactive_member, status);
    IFEND;
  PROCEND stp$store_member_dm_packet;

?? TITLE := '  [XDCL, #GATE] stp$store_vst_pf_root', EJECT ??
*copyc sth$store_vst_pf_root

  PROCEDURE [XDCL, #GATE] stp$store_vst_pf_root (master_vsn: rmt$recorded_vsn;
        pf_root: pft$root;
    VAR status: ost$status);

    VAR
      input_root_size: pft$root_size,
      local_status: ost$status,
      p_master_vst: stt$p_vol_set_table,
      p_new_pf_root: ^pft$root,
      p_old_pf_root: ^pft$root,
      sfid: dmt$system_file_id,
      vst_segment_pointer: mmt$segment_pointer;

    input_root_size := #SIZE (pf_root);
    stp$open_vst (master_vsn, TRUE, sfid, vst_segment_pointer, status);
    IF status.normal THEN
      p_master_vst := vst_segment_pointer.cell_pointer;
      ALLOCATE p_new_pf_root: [[REP input_root_size OF cell]] IN p_master_vst^.vst_heap;
      IF p_new_pf_root = NIL THEN
        osp$set_status_abnormal (stc$set_management_id, ste$no_space_vst_heap, master_vsn, status);
      ELSE
        IF p_master_vst^.pf_root_storage.pf_root_ever_stored THEN
          stp$build_pf_root_pointer (p_master_vst^.pf_root_storage.pf_root_locator, p_master_vst,
                p_old_pf_root);
          IF p_old_pf_root <> NIL THEN
            FREE p_old_pf_root IN p_master_vst^.vst_heap;
          IFEND;
        IFEND;
        p_master_vst^.pf_root_storage.pf_root_ever_stored := TRUE;
        p_master_vst^.pf_root_storage.pf_root_size := input_root_size;
        p_new_pf_root^ := pf_root;
        stp$build_pf_root_locator (p_new_pf_root, p_master_vst, p_master_vst^.pf_root_storage.
              pf_root_locator);
      IFEND;
      stp$return_opened_vst (sfid, vst_segment_pointer, local_status);
    IFEND;
  PROCEND stp$store_vst_pf_root;

MODEND stm$modify_vst;
*DECK DECK=STM$PF_INTERFACES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$pf_interfaces;

{
{  PURPOSE:
{    This module manages the interface from permanent files into sets.
{    Interfaces are provided to store and retrieve information.
{    -interfaces dealing with the pf root
{       stp$get_pf_root_size
{       stp$get_pf_root
{       stp$store_pf_root
{       stp$purge_pf_root
{    -stp$get_set_owner
{    -interfaces dealing with the pf lock
{       stp$set_pf_lock
{       stp$clear_pf_lock
{

?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$signature_lock
*copyc ost$status
*copyc ost$wait
*copyc pfd$root
*copyc pmp$cycle
*copyc std$active_set_table
*copyc std$job_active_set_table
*copyc std$miscellaneous
*copyc std$set_name
*copyc ste$error_condition_codes
*copyc stk$keypoints
*copyc stp$clear_ast_pf_lock
*copyc stp$clear_exclusive_access
*copyc stp$create_jast_entry
*copyc stp$dm_mount_volume
*copyc stp$get_unused_entry_in_jast
*copyc stp$increment_job_count_in_ast
*copyc stp$obtain_ast_entry
*copyc stp$obtain_ast_pf_root
*copyc stp$purge_ast_pf_root
*copyc stp$purge_vst_pf_root
*copyc stp$search_ast_by_set
*copyc stp$search_jast_for_set
*copyc stp$set_ast_pf_lock
*copyc stp$set_exclusive_access
*copyc stp$store_ast_pf_root
*copyc stp$store_vst_pf_root
*copyc stv$p_jast
?? POP ??


?? TITLE := '  [XDCL] stp$clear_pf_lock', EJECT ??
*copyc sth$clear_pf_lock

  PROCEDURE [XDCL] stp$clear_pf_lock
   (    set_name: stt$set_name;
    VAR status: ost$status);

    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index;

    #keypoint (osk$entry, 0, stk$clear_pf_lock);
    stp$set_exclusive_access;
    stp$get_pf_active_set_entry (set_name, ast_index, ast_entry, status);
    IF status.normal THEN
      IF (NOT ast_entry.master_ever_up) OR (ast_entry.master_volume_activity.volume_activity_status =
            stc$inactive) THEN
        stp$clear_exclusive_access;
        stp$dm_mount_volume (ast_entry.master_vsn, status);
        IF NOT status.normal THEN
          osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, ast_entry.master_vsn,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
        IFEND;
        stp$set_exclusive_access;
      ELSE
        stp$clear_ast_pf_lock (ast_index, status);
      IFEND;
    IFEND;
    stp$clear_exclusive_access;
    IF status.normal THEN
      #keypoint (osk$exit, 0, stk$clear_pf_lock);
    ELSE
      #keypoint (osk$exit, 0, stk$clear_pf_lock);
    IFEND;
  PROCEND stp$clear_pf_lock;


?? TITLE := '  [XDCL] stp$get_pf_active_set_entry', EJECT ??
*copyc sth$get_pf_active_set_entry

  PROCEDURE [XDCL] stp$get_pf_active_set_entry
   (    set_name: stt$set_name;
    VAR ast_index: stt$ast_index;
    VAR ast_entry: stt$active_set_entry;
    VAR status: ost$status);

    VAR
      job_active_set_entry: stt$job_active_set_entry,
      job_using_set: boolean,
      set_active: boolean;

    stp$search_jast_for_set (set_name, job_active_set_entry, job_using_set);
    IF job_using_set THEN
      ast_index := job_active_set_entry.ast_index;
      stp$obtain_ast_entry (ast_index, ast_entry, status);
    ELSE
      stp$search_ast_by_set (set_name, ast_entry, ast_index, set_active);
      IF set_active THEN
        IF ast_entry.access_status = stc$allow_access THEN
          stp$create_jast_entry (set_name, ast_entry.unique_set_name, ast_index, status);
          IF status.normal THEN
            stp$increment_job_count_in_ast (ast_index, status);
            #keypoint (osk$debug, osk$m * ast_index, stk$new_job_accessing_set);
          IFEND;
        ELSE
          osp$set_status_abnormal (stc$set_management_id, ste$not_allowing_access, set_name, status);
        IFEND;
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$set_not_active, set_name, status);
      IFEND;
    IFEND;
  PROCEND stp$get_pf_active_set_entry;

?? TITLE := '  [XDCL] stp$get_pf_root', EJECT ??
*copyc sth$get_pf_root

  PROCEDURE [XDCL] stp$get_pf_root
   (    set_name: stt$set_name;
    VAR pf_root_size: pft$root_size;
    VAR pf_root_container: pft$root;
    VAR status: ost$status);

    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index;

    #keypoint (osk$entry, 0, stk$get_pf_root);
    #keypoint (osk$debug, osk$m * #SIZE (pf_root_container), stk$pf_root_size);

    {
    { Make sure that the job set table exists, prior to locking the mainframe
    { set table, so that if the job pageable heap is damaged, the failure
    { will not leave the mainframe set table locked.
    {

    stp$reserve_jast_space;

    stp$set_exclusive_access;
    stp$get_pf_active_set_entry (set_name, ast_index, ast_entry, status);
    IF status.normal THEN
      IF (NOT ast_entry.master_ever_up) OR (ast_entry.master_volume_activity.volume_activity_status =
            stc$inactive) THEN
        stp$clear_exclusive_access;
        stp$dm_mount_volume (ast_entry.master_vsn, status);
        IF status.normal THEN
          stp$get_pf_root (set_name, pf_root_size, pf_root_container, status);
        ELSE
          osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, ast_entry.master_vsn,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
        IFEND;
        stp$set_exclusive_access;
      ELSEIF ast_entry.pf_root_ever_stored THEN
        pf_root_size := ast_entry.pf_root_size;
        stp$obtain_ast_pf_root (ast_index, pf_root_container, status);
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$pf_root_not_stored, set_name, status);
      IFEND;
    IFEND;
    stp$clear_exclusive_access;
    IF status.normal THEN
      #keypoint (osk$exit, osk$m * pf_root_size, stk$get_pf_root);
    ELSE
      #keypoint (osk$exit, 0, stk$get_pf_root);
    IFEND;
  PROCEND stp$get_pf_root;



?? TITLE := '  [XDCL] stp$get_pf_root_size', EJECT ??
*copyc sth$get_pf_root_size

  PROCEDURE [XDCL] stp$get_pf_root_size
   (    set_name: stt$set_name;
    VAR pf_root_size: pft$root_size;
    VAR status: ost$status);

    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index;

    #keypoint (osk$entry, 0, stk$get_pf_root_size);
    stp$set_exclusive_access;
    stp$get_pf_active_set_entry (set_name, ast_index, ast_entry, status);
    IF status.normal THEN
      IF (NOT ast_entry.master_ever_up) OR (ast_entry.master_volume_activity.volume_activity_status =
            stc$inactive) THEN
        stp$clear_exclusive_access;
        stp$dm_mount_volume (ast_entry.master_vsn, status);
        IF status.normal THEN
          stp$get_pf_root_size (set_name, pf_root_size, status);
        ELSE
          osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, ast_entry.master_vsn,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
        IFEND;
        stp$set_exclusive_access;
      ELSEIF ast_entry.pf_root_ever_stored THEN
        pf_root_size := ast_entry.pf_root_size;
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$pf_root_not_stored, set_name, status);
      IFEND;
    IFEND;
    stp$clear_exclusive_access;
    IF status.normal THEN
      #keypoint (osk$debug, osk$m * pf_root_size, stk$pf_root_size);
      #keypoint (osk$exit, 0, stk$get_pf_root_size);
    ELSE
      #keypoint (osk$exit, 0, stk$get_pf_root_size);
    IFEND;
  PROCEND stp$get_pf_root_size;

?? TITLE := '  [XDCL, #GATE] stp$get_set_owner', EJECT ??
*copyc sth$get_set_owner

  PROCEDURE [XDCL, #GATE] stp$get_set_owner (set_name: stt$set_name;
    VAR set_owner: ost$user_identification;
    VAR status: ost$status);

    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index;

    #keypoint (osk$entry, 0, stk$get_set_owner);
    stp$set_exclusive_access;
    stp$get_pf_active_set_entry (set_name, ast_index, ast_entry, status);
    IF status.normal THEN
      IF (NOT ast_entry.master_ever_up) OR (ast_entry.master_volume_activity.volume_activity_status =
            stc$inactive) THEN
        stp$clear_exclusive_access;
        stp$dm_mount_volume (ast_entry.master_vsn, status);
        IF status.normal THEN
          stp$get_set_owner (set_name, set_owner, status);
        ELSE
          osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, ast_entry.master_vsn,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
        IFEND;
        stp$set_exclusive_access;
      ELSE
        set_owner := ast_entry.set_owner;
      IFEND;
    IFEND;
    stp$clear_exclusive_access;
    IF status.normal THEN
      #keypoint (osk$exit, 0, stk$get_set_owner);
    ELSE
      #keypoint (osk$exit, 0, stk$get_set_owner);
    IFEND;
  PROCEND stp$get_set_owner;



?? TITLE := '  [XDCL] stp$purge_pf_root', EJECT ??
*copyc sth$purge_pf_root

  PROCEDURE [XDCL] stp$purge_pf_root
   (    set_name: stt$set_name;
    VAR status: ost$status);

    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index;

    #keypoint (osk$entry, 0, stk$purge_pf_root);
    stp$set_exclusive_access;
    stp$get_pf_active_set_entry (set_name, ast_index, ast_entry, status);
    IF status.normal THEN
      IF (NOT ast_entry.master_ever_up) OR (ast_entry.master_volume_activity.volume_activity_status =
            stc$inactive) THEN
        stp$clear_exclusive_access;
        stp$dm_mount_volume (ast_entry.master_vsn, status);
        IF status.normal THEN
          stp$purge_pf_root (set_name, status);
        ELSE
          osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, ast_entry.master_vsn,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
        IFEND;
        stp$set_exclusive_access;
      ELSE
        stp$purge_vst_pf_root (ast_entry.master_vsn, status);
        IF status.normal THEN
          stp$purge_ast_pf_root (ast_index);
        IFEND;
      IFEND;
    IFEND;
    stp$clear_exclusive_access;
    IF status.normal THEN
      #keypoint (osk$exit, 0, stk$purge_pf_root);
    ELSE
      #keypoint (osk$exit, 0, stk$purge_pf_root);
    IFEND;
  PROCEND stp$purge_pf_root;

?? TITLE := '   [INLINE] stp$reserve_jast_space ', EJECT ??
  PROCEDURE [INLINE] stp$reserve_jast_space;

    VAR
      jast_index: integer,
      status: ost$status;

    IF stv$p_jast = NIL THEN
      stp$get_unused_entry_in_jast (jast_index, status);
    IFEND;
  PROCEND stp$reserve_jast_space;

?? TITLE := '  [XDCL] stp$set_pf_lock', EJECT ??
*copyc sth$set_pf_lock

  PROCEDURE [XDCL] stp$set_pf_lock
   (    set_name: stt$set_name;
        wait: ost$wait;
    VAR status: ost$status);

    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index,
      need_to_try_again: boolean;

    #keypoint (osk$entry, 0, stk$set_pf_lock);
    stp$set_exclusive_access;
    REPEAT
      need_to_try_again := FALSE;
      stp$get_pf_active_set_entry (set_name, ast_index, ast_entry, status);
      IF status.normal THEN
        IF (NOT ast_entry.master_ever_up) OR (ast_entry.master_volume_activity.volume_activity_status =
              stc$inactive) THEN
          stp$clear_exclusive_access;
          stp$dm_mount_volume (ast_entry.master_vsn, status);
          IF status.normal THEN
            need_to_try_again := TRUE;
          ELSE
            osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, ast_entry.master_vsn,
                  status);
            osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
          IFEND;
          stp$set_exclusive_access;
        ELSE
          stp$set_ast_pf_lock (ast_index, status);
          IF ((NOT status.normal) AND (status.condition = ste$lock_set_in_another_task)) AND (wait = osc$wait)
                THEN
            stp$clear_exclusive_access;
            pmp$cycle (status);
            need_to_try_again := TRUE;
            stp$set_exclusive_access;
          IFEND;
        IFEND;
      IFEND;
    UNTIL NOT need_to_try_again;
    stp$clear_exclusive_access;
    IF status.normal THEN
      #keypoint (osk$exit, 0, stk$set_pf_lock);
    ELSE
      #keypoint (osk$exit, 0, stk$set_pf_lock);
    IFEND;
  PROCEND stp$set_pf_lock;






?? TITLE := '  [XDCL] stp$store_pf_root', EJECT ??
*copyc sth$store_pf_root

  PROCEDURE [XDCL] stp$store_pf_root
   (    set_name: stt$set_name;
        pf_root: pft$root;
    VAR status: ost$status);

    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index;

    #keypoint (osk$entry, 0, stk$store_pf_root);
    #keypoint (osk$debug, osk$m * #SIZE (pf_root), stk$pf_root_size);
    stp$set_exclusive_access;
    stp$get_pf_active_set_entry (set_name, ast_index, ast_entry, status);
    IF status.normal THEN
      IF (NOT ast_entry.master_ever_up) OR (ast_entry.master_volume_activity.volume_activity_status =
            stc$inactive) THEN
        stp$clear_exclusive_access;
        stp$dm_mount_volume (ast_entry.master_vsn, status);
        IF status.normal THEN
          stp$store_pf_root (set_name, pf_root, status);
        ELSE
          osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, ast_entry.master_vsn,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
        IFEND;
        stp$set_exclusive_access;
      ELSE
        stp$store_vst_pf_root (ast_entry.master_vsn, pf_root, status);
        IF status.normal THEN
          stp$store_ast_pf_root (ast_index, pf_root, status);
        IFEND;
      IFEND;
    IFEND;
    stp$clear_exclusive_access;
    IF status.normal THEN
      #keypoint (osk$exit, 0, stk$store_pf_root);
    ELSE
      #keypoint (osk$exit, 0, stk$store_pf_root);
    IFEND;
  PROCEND stp$store_pf_root;

MODEND stm$pf_interfaces;
*DECK DECK=STM$PURGE_SET EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??

MODULE stm$purge_set;

{
{ PURPOSE:
{   This  module  provides  the  compilation  unit  for  the  user   interface
{   stp$purge_set request.
{
{ DESIGN:
{   This runs in 23d.
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$validate_name
*copyc dmt$active_volume_table_index
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc pmp$get_user_identification
*copyc rmd$volume_declarations
*copyc std$active_set_table
*copyc std$job_active_set_table
*copyc std$miscellaneous
*copyc ste$error_condition_codes
*copyc stk$keypoints
*copyc stp$clear_exclusive_access
*copyc stp$dm_mount_volume
*copyc stp$request_dm_volume_info
*copyc stp$ring2_purge_set
*copyc stp$search_ast_by_set
*copyc stp$search_jast_for_set
*copyc stp$set_exclusive_access
*copyc stp$validate_owner
*copyc stp$validate_recorded_vsn
?? POP ??

?? TITLE := '  [XDCL] stp$purge_set ', EJECT ??
*copyc sth$purge_set

  PROCEDURE [XDCL] stp$purge_set
   (    set_name: stt$set_name;
        master_vol: rmt$recorded_vsn;
    VAR status: ost$status);

    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index,
      cap_master_vol: rmt$recorded_vsn,
      cap_set_name: stt$set_name,
      master_avt_index: dmt$active_volume_table_index,
      purge_set_status: ost$status;

    #keypoint (osk$entry, 0, stk$purge_set);
    purge_set_status.normal := TRUE;
    validate_purge_set_param (set_name, master_vol, cap_set_name, cap_master_vol, purge_set_status);
    IF purge_set_status.normal THEN
      stp$set_exclusive_access;
      verify_purge_set (cap_set_name, cap_master_vol, master_avt_index, ast_index, ast_entry,
            purge_set_status);
      IF NOT purge_set_status.normal THEN
        IF purge_set_status.condition = ste$master_not_active THEN
{         attempt to mount the master volume.
          stp$clear_exclusive_access; {avoid deadlock}
          stp$dm_mount_volume (cap_master_vol, status);
          stp$set_exclusive_access;
          IF status.normal THEN
            verify_purge_set (cap_set_name, cap_master_vol, master_avt_index, ast_index, ast_entry,
                  purge_set_status);
          IFEND;
        IFEND;
      IFEND;

      IF purge_set_status.normal THEN
        stp$ring2_purge_set (cap_set_name, cap_master_vol, master_avt_index, ast_index, ast_entry,
              purge_set_status);
      IFEND;
      stp$clear_exclusive_access;
    IFEND;
    status := purge_set_status;
    IF status.normal THEN
      #keypoint (osk$exit, 0, stk$purge_set);
    ELSE
      #keypoint (osk$exit, 0, stk$purge_set);
    IFEND;
  PROCEND stp$purge_set;



?? TITLE := '  validate_purge_set_param ', EJECT ??

  PROCEDURE validate_purge_set_param (set_name: stt$set_name;
        master_vol: rmt$recorded_vsn;
    VAR cap_set_name: stt$set_name;
    VAR cap_master_vol: rmt$recorded_vsn;
    VAR parameter_status: ost$status);

{  PURPOSE:
{    This procedure validates the user parameters on the stp$purge_set request.


    VAR
      local_name: ost$name,
      valid_name: boolean;

    clp$validate_name (set_name, local_name, valid_name);
    IF valid_name THEN
      cap_set_name := local_name;
      stp$validate_recorded_vsn (master_vol, cap_master_vol, parameter_status);
      IF NOT parameter_status.normal THEN
        osp$set_status_abnormal (stc$set_management_id, ste$bad_master_vol_desc, master_vol,
              parameter_status);
      IFEND;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$bad_set_name, set_name, parameter_status);
    IFEND;
  PROCEND validate_purge_set_param;
?? TITLE := '  verify_purge_set ', EJECT ??

  PROCEDURE verify_purge_set (set_name: stt$set_name;
        master_vol: rmt$recorded_vsn;
    VAR masters_avt_index: dmt$active_volume_table_index;
    VAR ast_index: stt$ast_index;
    VAR ast_entry: stt$active_set_entry;
    VAR purge_set_status: ost$status);

{  PURPOSE:
{   The purpose of this routine is to verify that a purge set is indeed
{ legal to do.  This includes validation of the user making the request,
{ and a check on the condition of the set.



    VAR
      internal_vsn: dmt$internal_vsn,
      jast_entry: stt$job_active_set_entry,
      job_owner: ost$user_identification,
      job_owner_status: ost$status,
      master_vol_active: boolean,
      master_vol_owner: ost$user_identification,
      set_found_in_ast: boolean,
      set_found_in_jast: boolean,
      valid_owner: boolean;

    purge_set_status.normal := TRUE;
    stp$search_ast_by_set (set_name, ast_entry, ast_index, set_found_in_ast);
    {
    { Is the set active?
    IF set_found_in_ast THEN
      IF ast_entry.master_ever_up THEN
        stp$validate_owner (ast_entry.set_owner, valid_owner);
        IF valid_owner THEN
          {are there jobs on the set yet}
          stp$search_jast_for_set (set_name, jast_entry, set_found_in_jast);
          IF ((ast_entry.number_of_jobs_using_set > 0) AND NOT set_found_in_jast) OR ((ast_entry.
                number_of_jobs_using_set > 1) AND set_found_in_jast) THEN
{           Only the purge set requestor may be using the set.
            osp$set_status_abnormal (stc$set_management_id, ste$jobs_on_set, set_name, purge_set_status);
            RETURN;
          IFEND;
        ELSE
          pmp$get_user_identification (job_owner, job_owner_status);
          osp$set_status_abnormal (stc$set_management_id, ste$set_not_job_owner, job_owner.user,
                purge_set_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, job_owner.family, purge_set_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, set_name, purge_set_status);
          RETURN;
        IFEND;
      IFEND;
{
{     Do we have the correct master.
      IF ast_entry.master_vsn <> master_vol THEN
        osp$set_status_abnormal (stc$set_management_id, ste$wrong_master, master_vol, purge_set_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, set_name, purge_set_status);
        RETURN;
      IFEND;
{
{     Is the master volume active.
      IF ast_entry.master_ever_up THEN
        IF ast_entry.master_volume_activity.volume_activity_status = stc$active THEN
          masters_avt_index := ast_entry.master_volume_activity.avt_index;
        ELSE
          osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, master_vol,
                purge_set_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, set_name, purge_set_status);
        IFEND;
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, master_vol, purge_set_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, set_name, purge_set_status);
      IFEND;
    ELSE
{
{     the master is not active.
      stp$request_dm_volume_info (master_vol, internal_vsn, master_vol_owner, masters_avt_index,
            master_vol_active);
      IF master_vol_active THEN
{       This volume must not belong to the requested set.
        osp$set_status_abnormal (stc$set_management_id, ste$wrong_master, master_vol, purge_set_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, set_name, purge_set_status);
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, master_vol, purge_set_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, set_name, purge_set_status);
      IFEND;
    IFEND;

    IF purge_set_status.normal AND ast_entry.pf_root_ever_stored THEN
      osp$set_status_abnormal (stc$set_management_id, ste$users_on_set, set_name, purge_set_status);
    IFEND;
  PROCEND verify_purge_set;

MODEND stm$purge_set;
*DECK DECK=STM$READ_AST_R1 EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Set Management : Read AST' ??
MODULE stm$read_ast_r1;

{ PURPOSE:
{   This module includes all those procedures that will read the active set
{   table, but will not modify it.  These procedures will all run at ring 1.

?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc stc$max_num_members_on_set
*copyc std$active_set_table
*copyc std$miscellaneous
*copyc ste$error_condition_codes
*copyc stk$keypoints
*copyc stt$number_of_members
*copyc stt$set_list
*copyc stt$volume_list
?? POP ??
?? EJECT ??
*copyc osp$set_status_abnormal
*copyc stp$search_mel_for_vol
*copyc stv$p_ast

?? TITLE := '  [XDCL, #GATE] stp$get_active_set_list', EJECT ??
*copy sth$get_active_set_list

  PROCEDURE [XDCL, #GATE] stp$get_active_set_list
    (VAR set_list: stt$set_list;
     VAR actual_number_of_sets: stt$number_of_sets);

    VAR
      i: stt$ast_index,
      size_of_input_set_list: integer;


    size_of_input_set_list := UPPERBOUND (set_list);
    actual_number_of_sets := 0;

    #KEYPOINT (osk$entry, osk$m * size_of_input_set_list, stk$get_active_set_list);

    IF stv$p_ast <> NIL THEN
      FOR i := LOWERBOUND (stv$p_ast^.table) TO UPPERBOUND (stv$p_ast^.table) DO
        IF stv$p_ast^.table [i].entry_type = stc$valid THEN
          actual_number_of_sets := actual_number_of_sets + 1;
          IF actual_number_of_sets <= size_of_input_set_list THEN
            set_list [actual_number_of_sets] := stv$p_ast^.table [i].set_name;
          IFEND;
        IFEND;
      FOREND;
    IFEND;

    #KEYPOINT (osk$exit, osk$m * actual_number_of_sets, stk$get_active_set_list);
  PROCEND stp$get_active_set_list;

?? TITLE := '  [XDCL, #GATE] stp$get_volumes_by_ast_index', EJECT ??
*copy sth$get_volumes_by_ast_index

  PROCEDURE [XDCL, #GATE] stp$get_volumes_by_ast_index (set_index: stt$ast_index;
        starting_member_index: stt$number_of_members;
    VAR master_vol: stt$volume_info;
    VAR member_vsn_list: stt$volume_list;
    VAR number_of_members: stt$number_of_members);


    VAR
      ast_entry: stt$active_set_entry,
      external_set_name: stt$set_name,
      mel_index: stt$mel_index,
      member_list_index: stt$number_of_members,
      p_member_entry_list: stt$p_member_entry_list;

    ast_entry := stv$p_ast^.table [set_index];
    number_of_members := 0;
    member_list_index := starting_member_index;
    external_set_name := stv$p_ast^.table [set_index].set_name;
    master_vol.recorded_vsn := ast_entry.master_vsn;
    master_vol.internal_vsn := ast_entry.master_internal_vsn;
    IF ast_entry.master_ever_up THEN
      master_vol.volume_activity := ast_entry.master_volume_activity;
      master_vol.dm_packet_storage := ast_entry.master_dm_packet_storage;
    ELSE
      master_vol.volume_activity.volume_activity_status := stc$inactive;
      master_vol.dm_packet_storage.dm_packet_ever_stored := FALSE;
    IFEND;
    master_vol.setname := external_set_name;
    p_member_entry_list := ast_entry.p_member_entry_list;
    IF p_member_entry_list <> NIL THEN
      FOR mel_index := LOWERBOUND (p_member_entry_list^) TO UPPERBOUND (p_member_entry_list^) DO
        IF p_member_entry_list^ [mel_index].entry_type = stc$valid THEN
          number_of_members := number_of_members + 1;
          IF member_list_index <= UPPERBOUND (member_vsn_list) THEN
            member_vsn_list [member_list_index].recorded_vsn := p_member_entry_list^ [mel_index].member_vsn;
            member_vsn_list [member_list_index].internal_vsn := p_member_entry_list^ [mel_index].
                  member_internal_vsn;
            member_vsn_list [member_list_index].setname := external_set_name;
            member_vsn_list [member_list_index].volume_activity := p_member_entry_list^ [mel_index].
                  member_volume_activity;
            member_vsn_list [member_list_index].dm_packet_storage := p_member_entry_list^ [mel_index].
                  member_dm_packet_storage;
            member_list_index := member_list_index + 1;
          IFEND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND stp$get_volumes_by_ast_index;

?? TITLE := '  [XDCL] stp$members_active_on_set', EJECT ??
*copy sth$members_active_on_set

  PROCEDURE [XDCL] stp$members_active_on_set
   (    ast_index: stt$ast_index;
    VAR members_active_on_set: boolean);


    VAR
      mel_index: stt$mel_index,
      p_member_entry_list: stt$p_member_entry_list;

    p_member_entry_list := stv$p_ast^.table [ast_index].p_member_entry_list;
    members_active_on_set := FALSE;
    IF p_member_entry_list <> NIL THEN
      FOR mel_index := LOWERBOUND (p_member_entry_list^) TO UPPERBOUND (p_member_entry_list^) DO
        IF p_member_entry_list^ [mel_index].entry_type = stc$valid THEN
          IF p_member_entry_list^ [mel_index].member_volume_activity.volume_activity_status = stc$active THEN
            members_active_on_set := TRUE;
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND stp$members_active_on_set;

?? TITLE := '  [XDCL] stp$members_inactive_on_set', EJECT ??
*copy sth$members_inactive_on_set

  PROCEDURE [XDCL] stp$members_inactive_on_set
   (    ast_index: stt$ast_index;
    VAR members_inactive_on_set: boolean);


    VAR
      mel_index: stt$mel_index,
      p_member_entry_list: stt$p_member_entry_list;

    p_member_entry_list := stv$p_ast^.table [ast_index].p_member_entry_list;
    members_inactive_on_set := FALSE;
    IF p_member_entry_list <> NIL THEN
      FOR mel_index := LOWERBOUND (p_member_entry_list^) TO UPPERBOUND (p_member_entry_list^) DO
        IF p_member_entry_list^ [mel_index].entry_type = stc$valid THEN
          IF p_member_entry_list^ [mel_index].member_volume_activity.volume_activity_status = stc$inactive
                THEN
            members_inactive_on_set := TRUE;
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND stp$members_inactive_on_set;

?? TITLE := '  [XDCL, #GATE] stp$members_on_set', EJECT ??
*copy sth$members_on_set

  PROCEDURE [XDCL, #GATE] stp$members_on_set (ast_index: stt$ast_index;
    VAR members_on_set: boolean);


    VAR
      mel_index: stt$mel_index,
      p_member_entry_list: stt$p_member_entry_list;

    p_member_entry_list := stv$p_ast^.table [ast_index].p_member_entry_list;
    members_on_set := FALSE;
    IF p_member_entry_list <> NIL THEN
      FOR mel_index := LOWERBOUND (p_member_entry_list^) TO UPPERBOUND (p_member_entry_list^) DO
        IF p_member_entry_list^ [mel_index].entry_type = stc$valid THEN
          members_on_set := TRUE;
          RETURN;
        IFEND;
      FOREND;
    IFEND;
  PROCEND stp$members_on_set;

?? TITLE := '  [XDCL, #GATE] stp$obtain_ast_entry', EJECT ??
*copy sth$obtain_ast_entry

  PROCEDURE [XDCL, #GATE] stp$obtain_ast_entry (ast_index: stt$ast_index;
    VAR ast_entry: stt$active_set_entry;
    VAR status: ost$status);

    IF (stv$p_ast = NIL) OR (ast_index > UPPERBOUND (stv$p_ast^.table)) THEN
      osp$set_status_abnormal (stc$set_management_id, ste$set_not_active, stc$null_parameter, status);
    ELSE
      status.normal := TRUE;
      ast_entry := stv$p_ast^.table [ast_index];
    IFEND;
  PROCEND stp$obtain_ast_entry;

?? TITLE := '  [XDCL, #GATE] stp$obtain_ast_pf_root', EJECT ??
*copy sth$obtain_ast_pf_root

  PROCEDURE [XDCL, #GATE] stp$obtain_ast_pf_root (ast_index: stt$ast_index;
    VAR pf_root_container: pft$root;
    VAR status: ost$status);

    VAR
      input_root_size: pft$root_size,
      p_pf_root: ^pft$root,
      p_pf_root_container: ^pft$root;


    IF stv$p_ast^.table [ast_index].pf_root_ever_stored AND (stv$p_ast^.table [ast_index].p_pf_root <> NIL)
          THEN
      input_root_size := #SIZE (pf_root_container);
      IF input_root_size < stv$p_ast^.table [ast_index].pf_root_size THEN
        osp$set_status_abnormal (stc$set_management_id, ste$incorrect_root_size, stv$p_ast^.table [ast_index].
              set_name, status);
      ELSE
        status.normal := TRUE;
        p_pf_root_container := ^pf_root_container;
        RESET p_pf_root_container;
        NEXT p_pf_root: [[REP stv$p_ast^.table [ast_index].pf_root_size OF cell]] IN p_pf_root_container;
        p_pf_root^ := stv$p_ast^.table [ast_index].p_pf_root^;
      IFEND;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$pf_root_not_stored, stv$p_ast^.table [ast_index].
            set_name, status);
    IFEND;
  PROCEND stp$obtain_ast_pf_root;

?? TITLE := '  [XDCL, #GATE] stp$obtain_ast_size', EJECT ??
*copy sth$obtain_ast_size

  PROCEDURE [XDCL, #GATE] stp$obtain_ast_size (VAR ast_size: integer);

    IF stv$p_ast = NIL THEN
      ast_size := 0;
    ELSE
      ast_size := UPPERBOUND (stv$p_ast^.table);
    IFEND;
  PROCEND stp$obtain_ast_size;

?? TITLE := '  [XDCL, #GATE] stp$search_ast_by_internal_vsn', EJECT ??

  PROCEDURE [XDCL, #GATE] stp$search_ast_by_internal_vsn
   (    volume: dmt$internal_vsn;
    VAR ast_entry: stt$active_set_entry;
    VAR ast_index: stt$ast_index;
    VAR volume_found: boolean);

    VAR
      mel_index: stt$mel_index,
      member_entry: stt$member_entry;

    volume_found := FALSE;
    IF stv$p_ast <> NIL THEN

    /search_for_volume/
      FOR ast_index := LOWERBOUND (stv$p_ast^.table) TO UPPERBOUND (stv$p_ast^.table) DO
        ast_entry := stv$p_ast^.table [ast_index];
        IF ast_entry.entry_type = stc$valid THEN
          IF ast_entry.master_internal_vsn = volume THEN
            volume_found := TRUE;
            EXIT /search_for_volume/;
          ELSE
            stp$search_mel_for_internal_vol (volume, ast_index, member_entry, mel_index, volume_found);
            IF volume_found THEN
              EXIT /search_for_volume/;
            IFEND;
          IFEND;
        IFEND;
      FOREND /search_for_volume/;
    IFEND;
  PROCEND stp$search_ast_by_internal_vsn;

?? TITLE := '  [XDCL, #GATE] stp$search_ast_by_set', EJECT ??
*copy sth$search_ast_by_set

  PROCEDURE [XDCL, #GATE] stp$search_ast_by_set (set_name_key: stt$set_name;
    VAR found_ast_entry: stt$active_set_entry;
    VAR found_ast_index: stt$ast_index;
    VAR set_key_found: boolean);

    VAR
      upper: stt$ast_index;

    set_key_found := FALSE;
    IF stv$p_ast <> NIL THEN
      found_ast_index := LOWERBOUND (stv$p_ast^.table);
      upper := UPPERBOUND (stv$p_ast^.table);
      WHILE NOT set_key_found AND (found_ast_index <= upper) DO
        IF stv$p_ast^.table [found_ast_index].entry_type = stc$valid THEN
          IF stv$p_ast^.table [found_ast_index].set_name = set_name_key THEN
            set_key_found := TRUE;
            found_ast_entry := stv$p_ast^.table [found_ast_index];
          ELSE
            found_ast_index := found_ast_index + 1;
          IFEND;
        ELSE
          found_ast_index := found_ast_index + 1;
        IFEND;
      WHILEND;
    IFEND;
  PROCEND stp$search_ast_by_set;

?? TITLE := '  [XDCL, #GATE] stp$search_ast_by_unique_set', EJECT ??
*copy sth$search_ast_by_unique_set

  PROCEDURE [XDCL, #GATE] stp$search_ast_by_unique_set (unique_set_key: stt$unique_set_name;
    VAR found_ast_entry: stt$active_set_entry;
    VAR found_ast_index: stt$ast_index;
    VAR set_key_found: boolean);

    VAR
      upper: stt$ast_index;

    set_key_found := FALSE;
    IF stv$p_ast <> NIL THEN
      found_ast_index := LOWERBOUND (stv$p_ast^.table);
      upper := UPPERBOUND (stv$p_ast^.table);
      WHILE NOT set_key_found AND (found_ast_index <= upper) DO
        IF stv$p_ast^.table [found_ast_index].entry_type = stc$valid THEN
          IF stv$p_ast^.table [found_ast_index].unique_set_name = unique_set_key THEN
            set_key_found := TRUE;
            found_ast_entry := stv$p_ast^.table [found_ast_index];
          ELSE
            found_ast_index := found_ast_index + 1;
          IFEND;
        ELSE
          found_ast_index := found_ast_index + 1;
        IFEND;
      WHILEND;
    IFEND;
  PROCEND stp$search_ast_by_unique_set;

?? TITLE := '  [XDCL] stp$seach_ast_by_volume', EJECT ??
*copy sth$search_ast_by_volume

  PROCEDURE [XDCL] stp$search_ast_by_volume
   (    volume: rmt$recorded_vsn;
    VAR ast_entry: stt$active_set_entry;
    VAR ast_index: stt$ast_index;
    VAR volume_found: boolean);

    VAR
      mel_index: stt$mel_index,
      member_entry: stt$member_entry;

    volume_found := FALSE;
    IF stv$p_ast <> NIL THEN

    /search_for_volume/
      FOR ast_index := LOWERBOUND (stv$p_ast^.table) TO UPPERBOUND (stv$p_ast^.table) DO
        ast_entry := stv$p_ast^.table [ast_index];
        IF ast_entry.entry_type = stc$valid THEN
          IF ast_entry.master_vsn = volume THEN
            volume_found := TRUE;
            EXIT /search_for_volume/;
          ELSE
            stp$search_mel_for_vol (volume, ast_index, member_entry, mel_index, volume_found);
            IF volume_found THEN
              EXIT /search_for_volume/;
            IFEND;
          IFEND;
        IFEND;
      FOREND /search_for_volume/;
    IFEND;
  PROCEND stp$search_ast_by_volume;

?? TITLE := '  [XDCL] stp$search_mel_for_internal_vol', EJECT ??

  PROCEDURE [XDCL] stp$search_mel_for_internal_vol
   (    member_vol: dmt$internal_vsn;
        ast_index: stt$ast_index;
    VAR member_entry: stt$member_entry;
    VAR mel_index: stt$mel_index;
    VAR volume_found: boolean);

    VAR
      p_mel: stt$p_member_entry_list;


    volume_found := FALSE;
    p_mel := stv$p_ast^.table [ast_index].p_member_entry_list;
    IF p_mel <> NIL THEN
      FOR mel_index := LOWERBOUND (p_mel^) TO UPPERBOUND (p_mel^) DO
        IF p_mel^ [mel_index].entry_type = stc$valid THEN
          IF p_mel^ [mel_index].member_internal_vsn = member_vol THEN
            member_entry := p_mel^ [mel_index];
            volume_found := TRUE;
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND stp$search_mel_for_internal_vol;

?? OLDTITLE, SKIP := 2 ??
MODEND stm$read_ast_r1;
*DECK DECK=STM$READ_JOB_SET_TABLE EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$read_job_set_table;

{
{ PURPOSE:
{   This module contains those procedure that merely read the job  active  set
{   table.
{
{ DESIGN:
{   Reference to  the  job  active  set  table  is  by  the  XREF'ed  variable
{   stv$p_jast.   There  is  a job active set table for each job.  This module
{   runs in ring 2 (223 ring bracket).
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc std$job_active_set_table
*copyc std$miscellaneous
*copyc stv$p_jast
?? POP ??

?? TITLE := '  [XDCL, #GATE] stp$search_jast_for_set', EJECT ??
*copyc sth$search_jast_for_set

  PROCEDURE [XDCL, #GATE] stp$search_jast_for_set (required_set: stt$set_name;
    VAR jast_entry: stt$job_active_set_entry;
    VAR set_found: boolean);



    VAR
      jast_index: integer;

    set_found := FALSE;
    IF stv$p_jast <> NIL THEN
      FOR jast_index := LOWERBOUND (stv$p_jast^.table) TO UPPERBOUND (stv$p_jast^.table) DO
        IF stv$p_jast^.table [jast_index].entry_type = stc$valid THEN
          IF stv$p_jast^.table [jast_index].set_name = required_set THEN
            jast_entry := stv$p_jast^.table [jast_index];
            set_found := TRUE;
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND stp$search_jast_for_set;


?? TITLE := '  [XDCL] stp$search_jast_for_unique_set ', EJECT ??

  PROCEDURE [XDCL] stp$search_jast_for_unique_set (required_set: stt$unique_set_name;
    VAR jast_entry: stt$job_active_set_entry;
    VAR set_found: boolean);

{  PURPOSE:
{    This procedure determines if the current job has previously accessed the
{    set.  This is done by searching the job active set table keyed by
{    unique set name.


    VAR
      jast_index: integer;

    set_found := FALSE;
    IF stv$p_jast <> NIL THEN
      FOR jast_index := LOWERBOUND (stv$p_jast^.table) TO UPPERBOUND (stv$p_jast^.table) DO
        IF stv$p_jast^.table [jast_index].entry_type = stc$valid THEN
          IF stv$p_jast^.table [jast_index].unique_set_name = required_set THEN
            jast_entry := stv$p_jast^.table [jast_index];
            set_found := TRUE;
            RETURN;
          IFEND;
        IFEND;
      FOREND;
    IFEND;
  PROCEND stp$search_jast_for_unique_set;

?? TITLE := '  [XDCL] stp$search_jast_for_unused', EJECT ??

  PROCEDURE [XDCL] stp$search_jast_for_unused (stv$p_jast: stt$p_job_active_set_table;
    VAR jast_index: integer;
    VAR unused_found: boolean);

{  PURPOSE:
{    This procedure determines if there is any unused space in the job active
{    set table, if an unused entry is found, the index to that entry is
{    returned.




    VAR
      upper: stt$jast_index;

    unused_found := FALSE;
    IF stv$p_jast <> NIL THEN
      jast_index := LOWERBOUND (stv$p_jast^.table);
      upper := UPPERBOUND (stv$p_jast^.table);
      WHILE (NOT unused_found) AND (jast_index <= upper) DO
        IF stv$p_jast^.table [jast_index].entry_type = stc$unused THEN
          unused_found := TRUE;
        ELSE
          jast_index := jast_index + 1;
        IFEND;
      WHILEND;
    IFEND;
  PROCEND stp$search_jast_for_unused;

MODEND stm$read_job_set_table;
*DECK DECK=STM$READ_VST EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$read_vst;
{
{ PURPOSE:
{   This module includes all modules that read the volume set table but do not
{   modify it
{
{ DESIGN:
{   This module lives in the system core library with ring brackets 133.

?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmt$internal_vsn
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc std$volume_set_table
*copyc ste$error_condition_codes
*copyc stt$number_of_members
*copyc std$active_set_table
*copyc stp$open_vst
*copyc stp$return_opened_vst
*copyc stp$search_ast_by_set
?? POP ??
?? TITLE := '  [XDCL] stp$build_member_list_locator', EJECT ??
*copyc sth$build_member_list_locator

  PROCEDURE [XDCL] stp$build_member_list_locator
   (    p_member_list: stt$p_member_vsn_list;
        p_vol_set_table: stt$p_vol_set_table;
    VAR member_list_locator: stt$member_list_locator);

    VAR
      p_cell: ^cell;

    IF p_member_list = NIL THEN
      member_list_locator.array_size := 0;
    ELSE
      member_list_locator.array_size := UPPERBOUND (p_member_list^);
      p_cell := #LOC (p_member_list^);
      member_list_locator.relative_cell_pointer := #REL (p_cell, p_vol_set_table^);
    IFEND;
  PROCEND stp$build_member_list_locator;

?? TITLE := '  [XDCL] stp$build_member_list_pointer', EJECT ??
*copyc sth$build_member_list_pointer

  PROCEDURE [XDCL] stp$build_member_list_pointer
   (    member_list_locator: stt$member_list_locator;
        p_vol_set_table: stt$p_vol_set_table;
    VAR p_member_list: stt$p_member_vsn_list);

    VAR
      p_sequence: stt$p_sequence,
      p_sequence_record: stt$p_sequence_record;

    IF member_list_locator.array_size = 0 THEN
      p_member_list := NIL;
    ELSE
      p_sequence_record := #PTR (member_list_locator.relative_cell_pointer, p_vol_set_table^);
      p_sequence := ^p_sequence_record^.sequence;
      RESET p_sequence;
      NEXT p_member_list: [1 .. member_list_locator.array_size] IN p_sequence;
    IFEND;
  PROCEND stp$build_member_list_pointer;



?? TITLE := '  [XDCL] stp$build_pf_root_locator', EJECT ??
*copyc sth$build_pf_root_locator

  PROCEDURE [XDCL] stp$build_pf_root_locator
   (    p_pf_root: pft$p_root;
        p_vol_set_table: stt$p_vol_set_table;
    VAR pf_root_locator: stt$pf_root_locator);

    VAR
      p_cell: ^cell;

    IF p_pf_root = NIL THEN
      pf_root_locator.length := 0;
    ELSE
      pf_root_locator.length := #SIZE (p_pf_root^);
      p_cell := #LOC (p_pf_root^);
      pf_root_locator.relative_cell_pointer := #REL (p_cell, p_vol_set_table^);
    IFEND;
  PROCEND stp$build_pf_root_locator;





?? TITLE := '  [XDCL] stp$build_pf_root_pointer', EJECT ??
*copyc sth$build_pf_root_pointer

  PROCEDURE [XDCL] stp$build_pf_root_pointer
   (    pf_root_locator: stt$pf_root_locator;
        p_vol_set_table: stt$p_vol_set_table;
    VAR p_pf_root: pft$p_root);

    VAR
      p_sequence: stt$p_sequence,
      p_sequence_record: stt$p_sequence_record;

    IF pf_root_locator.length = 0 THEN
      p_pf_root := NIL;
    ELSE
      p_sequence_record := #PTR (pf_root_locator.relative_cell_pointer, p_vol_set_table^);
      p_sequence := ^p_sequence_record^.sequence;
      RESET p_sequence;
      NEXT p_pf_root: [[REP pf_root_locator.length OF cell]] IN p_sequence;
    IFEND;
  PROCEND stp$build_pf_root_pointer;



?? TITLE := '  [XDCL, #GATE] stp$get_root_recreated', EJECT ??
  PROCEDURE [XDCL, #GATE] stp$get_root_recreated
    (    set_name: stt$set_name;
     VAR root_recreated: boolean;
     VAR status: ost$status);

    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index,
      local_status: ost$status,
      master_vol: rmt$recorded_vsn,
      master_vst_segment_pointer: mmt$segment_pointer,
      masters_sfid: dmt$system_file_id,
      p_master_vst: stt$p_vol_set_table,
      set_found_in_ast: boolean;

    stp$search_ast_by_set (set_name, ast_entry, ast_index, set_found_in_ast);
    IF set_found_in_ast THEN
      master_vol := ast_entry.master_vsn;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$set_not_active, set_name, status);
      RETURN;
    IFEND;
    stp$open_vst (master_vol, FALSE, masters_sfid, master_vst_segment_pointer, status);
    IF status.normal THEN
      p_master_vst := master_vst_segment_pointer.cell_pointer;
      root_recreated := p_master_vst^.root_recreated = stc$root_recreated;
      stp$return_opened_vst (masters_sfid, master_vst_segment_pointer, local_status);
    IFEND;

  PROCEND stp$get_root_recreated;

?? TITLE := '  [XDCL, #GATE] stp$obtain_master_vst_info', EJECT ??
*copyc sth$obtain_master_vst_info

  PROCEDURE [XDCL, #GATE] stp$obtain_master_vst_info (p_vol_set_table: stt$p_vol_set_table;
    VAR set_owner: ost$user_identification;
    VAR dm_packet_storage: stt$dm_packet_storage;
    VAR member_list: array [ * ] OF stt$member_vsn_entry;
    VAR size_of_member_list: stt$number_of_members;
    VAR pf_root_stored: boolean;
    VAR pf_root_size: pft$root_size;
    VAR pf_root_locator: stt$pf_root_locator);

    VAR
      input_list_size: integer,
      member_vol_index: integer,
      new_p_member_vsn_list: stt$p_member_vsn_list;

    set_owner := p_vol_set_table^.set_owner;
    pf_root_stored := p_vol_set_table^.pf_root_storage.pf_root_ever_stored;
    IF pf_root_stored THEN
      pf_root_size := p_vol_set_table^.pf_root_storage.pf_root_size;
      pf_root_locator := p_vol_set_table^.pf_root_storage.pf_root_locator;
    IFEND;
    dm_packet_storage := p_vol_set_table^.master_dm_packet_storage;
    stp$build_member_list_pointer (p_vol_set_table^.member_vsn_list_locator, p_vol_set_table,
          new_p_member_vsn_list);
    IF new_p_member_vsn_list = NIL THEN
      size_of_member_list := 0;
    ELSE
      input_list_size := UPPERBOUND (member_list);
      size_of_member_list := UPPERBOUND (new_p_member_vsn_list^);

    /loop_through_member_list/
      FOR member_vol_index := 1 TO size_of_member_list DO
        IF member_vol_index > input_list_size THEN
          EXIT /loop_through_member_list/;
        ELSE
          member_list [member_vol_index] := new_p_member_vsn_list^ [member_vol_index];
        IFEND;
      FOREND /loop_through_member_list/;
    IFEND;
  PROCEND stp$obtain_master_vst_info;

?? TITLE := '  [XDCL, #GATE] stp$obtain_member_vst_info', EJECT ??
*copyc sth$obtain_member_vst_info

  PROCEDURE [XDCL, #GATE] stp$obtain_member_vst_info (p_vol_set_table: stt$p_vol_set_table;
    VAR master_vsn: rmt$recorded_vsn;
    VAR master_internal_vsn: dmt$internal_vsn);

    master_internal_vsn := p_vol_set_table^.master_internal_vsn;
    master_vsn := p_vol_set_table^.master_vsn;
  PROCEND stp$obtain_member_vst_info;





?? TITLE := '  [XDCL, #GATE] stp$obtain_vst_header', EJECT ??
*copyc sth$obtain_vst_header

  PROCEDURE [XDCL, #GATE] stp$obtain_vst_header (p_vol_set_table: stt$p_vol_set_table;
    VAR volume: rmt$recorded_vsn;
    VAR internal_vsn: dmt$internal_vsn;
    VAR volume_in_set: boolean;
    VAR set_name: stt$set_name;
    VAR unique_set_name: stt$unique_set_name;
    VAR volume_status_in_set: stt$vol_status_in_set);

    volume := p_vol_set_table^.vsn;
    internal_vsn := p_vol_set_table^.internal_vsn;
    volume_in_set := p_vol_set_table^.entry_type = stc$valid;
    IF volume_in_set THEN
      set_name := p_vol_set_table^.set_name;
      unique_set_name := p_vol_set_table^.unique_set_name;
      volume_status_in_set := p_vol_set_table^.vol_status_in_set;
    IFEND;
  PROCEND stp$obtain_vst_header;


?? TITLE := '  [XDCL] stp$obtain_vst_pf_root', EJECT ??
*copyc sth$obtain_vst_pf_root

  PROCEDURE [XDCL] stp$obtain_vst_pf_root
   (    p_master_vst: stt$p_vol_set_table;
    VAR pf_root: pft$root;
    VAR status: ost$status);

    VAR
      dm_packet_storage: stt$dm_packet_storage,
      input_root_size: pft$root_size,
      number_of_members: stt$number_of_members,
      p_member_list: ^array [ * ] of stt$member_vsn_entry,
      p_stored_pf_root: ^pft$root,
      pf_root_ever_stored: boolean,
      pf_root_locator: stt$pf_root_locator,
      set_owner: ost$user_identification,
      stored_pf_root_size: pft$root_size;

    status.normal := TRUE;
    PUSH p_member_list: [1 .. 1];
    stp$obtain_master_vst_info (p_master_vst, set_owner, dm_packet_storage, p_member_list^, number_of_members,
          pf_root_ever_stored, stored_pf_root_size, pf_root_locator);
    IF pf_root_ever_stored THEN
      input_root_size := #SIZE (pf_root);
      IF input_root_size <> stored_pf_root_size THEN
        osp$set_status_abnormal (stc$set_management_id, ste$incorrect_root_size, p_master_vst^.set_name,
              status);
      ELSE
        stp$build_pf_root_pointer (pf_root_locator, p_master_vst, p_stored_pf_root);
        IF p_stored_pf_root <> NIL THEN
          pf_root := p_stored_pf_root^;
        ELSE
          osp$set_status_abnormal (stc$set_management_id, ste$pf_root_not_stored, p_master_vst^.set_name,
                status);
        IFEND;
      IFEND;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$pf_root_not_stored, p_master_vst^.set_name, status);
    IFEND;
  PROCEND stp$obtain_vst_pf_root;

?? TITLE := '  [XDCL] stp$search_mvt_for_vol', EJECT ??

  PROCEDURE [XDCL] stp$search_mvl_for_vol (member_vol: rmt$recorded_vsn;
        p_mvl: stt$p_member_vsn_list;
    VAR mvl_index: stt$mvl_index;
    VAR vol_found: boolean);


{  PURPOSE:
{   This procedure searches the volume list of the master volume, for
{ a given volume.



    VAR
      temp_mvl_index: integer,
      upper: integer;

    vol_found := FALSE;
    IF p_mvl <> NIL THEN
      temp_mvl_index := LOWERBOUND (p_mvl^);
      upper := UPPERBOUND (p_mvl^);
      REPEAT
        IF p_mvl^ [temp_mvl_index].entry_type = stc$valid THEN
          IF p_mvl^ [temp_mvl_index].member_vsn = member_vol THEN
            vol_found := TRUE;
            mvl_index := temp_mvl_index;
          ELSE
            temp_mvl_index := temp_mvl_index + 1;
          IFEND;
        ELSE
          temp_mvl_index := temp_mvl_index + 1;
        IFEND;
      UNTIL (vol_found OR (temp_mvl_index > upper));
    IFEND;
  PROCEND stp$search_mvl_for_vol;


MODEND stm$read_vst;
*DECK DECK=STM$REMOVE_MEMBER EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$remove_member;

{
{ PURPOSE:
{   This contains the user interface stp$remove_member_vol_from_set
{
{ DESIGN:
{   This lives in 23d.

?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clp$validate_name
*copyc dmp$change_set_name
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc ost$user_identification
*copyc pmp$get_user_identification
*copyc rmd$volume_declarations
*copyc std$active_set_table
*copyc std$miscellaneous
*copyc ste$error_condition_codes
*copyc stk$keypoints
*copyc stp$clear_exclusive_access
*copyc stp$dm_check_if_files_on_vol
*copyc stp$dm_mount_volume
*copyc stp$request_dm_volume_info
*copyc stp$ring2_remove_member
*copyc stp$search_ast_by_set
*copyc stp$set_exclusive_access
*copyc stp$validate_owner
*copyc stp$validate_recorded_vsn
?? POP ??

?? TITLE := '  [XDCL] stp$remove_member_vol_from_set ', EJECT ??

*copyc sth$remove_member_vol_from_set

  PROCEDURE [XDCL] stp$remove_member_vol_from_set
   (    set_name: stt$set_name;
        member_vol: rmt$recorded_vsn;
        master_vol: rmt$recorded_vsn;
    VAR status: ost$status);

    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index,
      converted_master_vol: rmt$recorded_vsn,
      converted_member_vol: rmt$recorded_vsn,
      converted_set_name: stt$set_name,
      members_avt_index: dmt$active_volume_table_index,
      remove_member_status: ost$status;

?? EJECT ??

    #keypoint (osk$entry, 0, stk$remove_member_vol_from_set);
    remove_member_status.normal := TRUE;
    validate_remove_mem_param (set_name, member_vol, master_vol, converted_set_name, converted_member_vol,
          converted_master_vol, remove_member_status);
    IF remove_member_status.normal THEN
      stp$set_exclusive_access;
      verify_remove_vol_exec (converted_set_name, converted_member_vol, converted_master_vol,
            members_avt_index, ast_entry, ast_index, remove_member_status);
      IF remove_member_status.normal THEN
        stp$ring2_remove_member (converted_set_name, converted_member_vol, converted_master_vol, ast_entry,
              ast_index, remove_member_status);
      IFEND;
      stp$clear_exclusive_access;
    IFEND;

    IF remove_member_status.normal THEN
      {
      { tell dm that the volume no longer belongs to a set.
      {
      dmp$change_set_name (member_vol, osc$null_name, remove_member_status);
    IFEND;

    status := remove_member_status;
    IF status.normal THEN
      #keypoint (osk$exit, osk$m * ast_index, stk$remove_member_vol_from_set);
    ELSE
      #keypoint (osk$exit, 0, stk$remove_member_vol_from_set);
    IFEND;
  PROCEND stp$remove_member_vol_from_set;

?? TITLE := '  validate_remove_mem_param', EJECT ??
{
{  PURPOSE:
{    This procedure validates the parameters on the remove_member_vol_from_set
{    request.

  PROCEDURE validate_remove_mem_param (set_name: stt$set_name;
        member_vol: rmt$recorded_vsn;
        master_vol: rmt$recorded_vsn;
    VAR cap_set_name: stt$set_name;
    VAR cap_member_volume: rmt$recorded_vsn;
    VAR cap_master_volume: rmt$recorded_vsn;
    VAR parameter_status: ost$status);

    VAR
      local_name: ost$name,
      valid_name: boolean;

    clp$validate_name (set_name, local_name, valid_name);
    IF valid_name THEN
      cap_set_name := local_name;
      stp$validate_recorded_vsn (member_vol, cap_member_volume, parameter_status);
      IF parameter_status.normal THEN
        stp$validate_recorded_vsn (master_vol, cap_master_volume, parameter_status);
        IF NOT parameter_status.normal THEN
          osp$set_status_abnormal (stc$set_management_id, ste$bad_master_vol_desc, master_vol,
                parameter_status);
        IFEND;
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$bad_member_vol_desc, member_vol,
              parameter_status);
      IFEND;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$bad_set_name, set_name, parameter_status);
    IFEND;
  PROCEND validate_remove_mem_param;

?? TITLE := '  verify_member_condition ', EJECT ??

{  PURPOSE:
{    This procedure looks at the member volume and determines, if there is
{    anything from indicate that this member can not be removed from the set.
{    Possible error conditions include not finding the member, the requestor
{    not owning the member, and files on the
{    member.
{

  PROCEDURE verify_member_condition (set_name: stt$set_name;
        member_vol: rmt$recorded_vsn;
    VAR members_avt_index: dmt$active_volume_table_index;
    VAR member_vol_owner: ost$user_identification;
    VAR member_status: ost$status);

    VAR
      files_on_member: boolean,
      job_owner: ost$user_identification,
      job_owner_status: ost$status,
      member_internal_vsn: dmt$internal_vsn,
      member_vol_found: boolean,
      valid_owner: boolean;

    stp$request_dm_volume_info (member_vol, member_internal_vsn, member_vol_owner, members_avt_index,
          member_vol_found);
    IF member_vol_found THEN
      stp$validate_owner (member_vol_owner, valid_owner);
      IF valid_owner THEN
        stp$dm_check_if_files_on_vol (member_vol, files_on_member);
        IF files_on_member THEN
          osp$set_status_abnormal (stc$set_management_id, ste$files_on_vol, member_vol, member_status);
        ELSE
          member_status.normal := TRUE;
        IFEND;
      ELSE
        pmp$get_user_identification (job_owner, job_owner_status);
        osp$set_status_abnormal (stc$set_management_id, ste$job_not_member_owner, job_owner.user,
              member_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, job_owner.family, member_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, member_vol, member_status);
      IFEND;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$member_not_active, member_vol, member_status);
    IFEND;
  PROCEND verify_member_condition;

?? TITLE := '  verify_remove_member ', EJECT ??
{
{  PURPOSE:
{    This procedure does the validation on the remove_member_vol from set
{    request.  This includes calls to verify the member condition and
{    checking the active set table, to verify correct conditions.
{

  PROCEDURE verify_remove_member
    (    set_name: stt$set_name;
         member_vol: rmt$recorded_vsn;
         master_vol: rmt$recorded_vsn;
     VAR members_avt_index: dmt$active_volume_table_index;
     VAR ast_entry: stt$active_set_entry;
     VAR ast_index: stt$ast_index;
     VAR status: ost$status);

    VAR
      job_owner: ost$user_identification,
      job_owner_status: ost$status,
      member_vol_owner: ost$user_identification,
      set_found: boolean;

    verify_member_condition (set_name, member_vol, members_avt_index, member_vol_owner, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    stp$search_ast_by_set (set_name, ast_entry, ast_index, set_found);
    IF NOT set_found THEN
      { impossible condition }
      {If the member is active and found to be in the correct set by the verify member condition routine,
      {there will be an ast entry.
    IFEND;

    IF member_vol = master_vol THEN
      osp$set_status_abnormal (stc$set_management_id, ste$remove_master_volume, member_vol, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, ast_entry.set_name, status);
      RETURN;
    IFEND;

    IF master_vol <> ast_entry.master_vsn THEN
      {
      {The master_volume supplied by the caller differs from that in the AST.
      {
      osp$set_status_abnormal (stc$set_management_id, ste$wrong_master, master_vol, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
      RETURN;
    IFEND;

    IF NOT ast_entry.master_ever_up THEN
      osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, master_vol, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
      RETURN;
    IFEND;

    IF ast_entry.set_owner = member_vol_owner THEN
      IF ast_entry.master_volume_activity.volume_activity_status = stc$active THEN
        status.normal := TRUE;
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$master_not_active, master_vol, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, set_name, status);
      IFEND;
    ELSE
      pmp$get_user_identification (job_owner, job_owner_status);
      osp$set_status_abnormal (stc$set_management_id, ste$set_not_member_owner, job_owner.user,
            status);
      osp$append_status_parameter (osc$status_parameter_delimiter, job_owner.family, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, member_vol, status);
    IFEND;
  PROCEND verify_remove_member;

?? TITLE := '  verify_remove_vol_exec ', EJECT ??

{  PURPOSE:
{    This procedure manages the verification on a remove_vol_from_set request.
{    A manager was used so that supervision of setting exclusive access,
{    and mounting of needed volumes could be provided.

  PROCEDURE verify_remove_vol_exec (set_name: stt$set_name;
        member_volume: rmt$recorded_vsn;
        master_volume: rmt$recorded_vsn;
    VAR members_avt_index: dmt$active_volume_table_index;
    VAR ast_entry: stt$active_set_entry;
    VAR ast_index: stt$ast_index;
    VAR status: ost$status);

    VAR
      local_status: ost$status;

    verify_remove_member (set_name, member_volume, master_volume, members_avt_index, ast_entry, ast_index,
          status);
    IF NOT status.normal THEN
      IF status.condition = ste$member_not_active THEN
        {
        { The member needs to be mounted.
        {
        stp$clear_exclusive_access;
        stp$dm_mount_volume (member_volume, local_status);
        stp$set_exclusive_access;
        IF local_status.normal THEN
          verify_remove_member (set_name, member_volume, master_volume, members_avt_index, ast_entry,
                ast_index, status);
        IFEND;
      IFEND;
      IF NOT status.normal THEN
        IF status.condition = ste$master_not_active THEN
          {
          {The master needs to be mounted.
          {
          stp$clear_exclusive_access;
          stp$dm_mount_volume (master_volume, local_status);
          stp$set_exclusive_access;
          IF local_status.normal THEN
            verify_remove_member (set_name, member_volume, master_volume, members_avt_index, ast_entry,
                  ast_index, status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND verify_remove_vol_exec;

MODEND stm$remove_member;
*DECK DECK=STM$RING2_ADD_MEMBER EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$ring2_add_member;


?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc dmp$change_set_name
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc ste$error_condition_codes
*copyc rmd$volume_declarations
*copyc std$active_set_table
*copyc std$miscellaneous
*copyc std$volume_set_table
*copyc stp$add_member_in_ast
*copyc stp$add_member_in_master_vst
*copyc stp$attach_vst
*copyc stp$build_member_vst
*copyc stp$create_vst
*copyc stp$destroy_vst
*copyc stp$open_vst
*copyc stp$remove_member_from_master
*copyc stp$remove_set_from_vst
*copyc stp$return_opened_vst
*copyc stp$search_mel_for_vol
?? POP ??
?? TITLE := '  [XDCL, #GATE] stp$ring2_add_member ', EJECT ??
*copyc sth$ring2_add_member

  PROCEDURE [XDCL, #GATE] stp$ring2_add_member
    (    set_name: stt$set_name;
         member_vol: rmt$recorded_vsn;
         member_internal_vsn: dmt$internal_vsn;
         master_vol: rmt$recorded_vsn;
         members_avt_index: dmt$active_volume_table_index;
         ast_entry: stt$active_set_entry;
         ast_index: stt$ast_index;
     VAR add_member_status: ost$status);

    VAR
      dm_packet_storage: stt$dm_packet_storage,
      local_status: ost$status,
      master_vst_segment_pointer: mmt$segment_pointer,
      masters_sfid: dmt$system_file_id,
      mel_index: stt$mel_index,
      member_entry: stt$member_entry,
      member_found: boolean,
      member_vst_segment_pointer: mmt$segment_pointer,
      members_sfid: dmt$system_file_id,
      p_master_vst: stt$p_vol_set_table,
      p_member_vst: stt$p_vol_set_table;

    stp$open_vst (master_vol, TRUE, masters_sfid, master_vst_segment_pointer, add_member_status);
    IF add_member_status.normal THEN
      p_master_vst := master_vst_segment_pointer.cell_pointer;
      stp$open_vst (member_vol, TRUE, members_sfid, member_vst_segment_pointer, add_member_status);
      IF add_member_status.normal THEN
        { The volume set table already exists. Check for re-adding member into master
        p_member_vst := member_vst_segment_pointer.cell_pointer;
        stp$search_mel_for_vol (member_vol, ast_index, member_entry, mel_index, member_found);
        IF member_found THEN
          osp$set_status_abnormal (stc$set_management_id, ste$member_vol_in_set, member_vol,
                add_member_status);
          osp$append_status_parameter (osc$status_parameter_delimiter, ast_entry.set_name, add_member_status);
        ELSE
          IF p_member_vst^.set_name = set_name THEN
            {
            { The volume belonged to this set at some point. Add this volume to the set.
            {
            dm_packet_storage.dm_packet_ever_stored := FALSE;
            stp$add_member_in_master_vst (p_master_vst, member_vol, member_internal_vsn, dm_packet_storage,
                  add_member_status);
            IF add_member_status.normal THEN
              stp$add_member_in_ast (member_vol, member_internal_vsn, stc$active, members_avt_index,
                    ast_index, dm_packet_storage);
              p_member_vst^.unique_set_name := ast_entry.unique_set_name;
              p_member_vst^.master_internal_vsn := ast_entry.master_internal_vsn;
              p_member_vst^.master_vsn := ast_entry.master_vsn;
              dmp$change_set_name (member_vol, set_name, add_member_status);
            IFEND;
          ELSE
            osp$set_status_abnormal (stc$set_management_id, ste$wrong_set_given, member_vol,
                  add_member_status);
            osp$append_status_parameter (osc$status_parameter_delimiter, p_member_vst^.set_name,
                  add_member_status);
            osp$append_status_parameter (osc$status_parameter_delimiter, set_name, add_member_status);
          IFEND;
        IFEND;
        stp$return_opened_vst (members_sfid, member_vst_segment_pointer, local_status);
      ELSEIF add_member_status.condition = ste$vol_not_in_set THEN
        stp$create_vst (member_vol, members_sfid, member_vst_segment_pointer, add_member_status);
        IF add_member_status.normal THEN
          p_member_vst := member_vst_segment_pointer.cell_pointer;
          dm_packet_storage.dm_packet_ever_stored := FALSE;
          stp$build_member_vst (p_member_vst, member_vol, member_internal_vsn, set_name,
                ast_entry.unique_set_name, ast_entry.master_vsn, ast_entry.master_internal_vsn);
          p_master_vst := master_vst_segment_pointer.cell_pointer;
          stp$add_member_in_master_vst (p_master_vst, member_vol, member_internal_vsn, dm_packet_storage,
                add_member_status);
          IF add_member_status.normal THEN
            stp$add_member_in_ast (member_vol, member_internal_vsn, stc$active, members_avt_index, ast_index,
                  dm_packet_storage);
            dmp$change_set_name (member_vol, set_name, add_member_status);
          ELSE
{
{         Something went wrong in adding the member to the master, restore
{         the member to show it is not in a set.
{
            stp$remove_set_from_vst (p_member_vst, local_status);
          IFEND;
          stp$return_opened_vst (members_sfid, member_vst_segment_pointer, local_status);

          IF NOT add_member_status.normal THEN
            stp$destroy_vst (member_vol, local_status);
          IFEND;
        IFEND;
      IFEND;
      stp$return_opened_vst (masters_sfid, master_vst_segment_pointer, local_status);
    IFEND;
  PROCEND stp$ring2_add_member;

MODEND stm$ring2_add_member;
*DECK DECK=STM$RING2_CREATE_SET EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$ring2_create_set;
{
{  PURPOSE:
{    This module is the ring 2 processor for the create set operations.
{
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmp$change_set_name
*copyc dmt$active_volume_table_index
*copyc dmt$internal_vsn
*copyc dmt$system_file_id
*copyc osp$generate_unique_binary_name
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc ost$user_identification
*copyc pfd$root
*copyc rmd$volume_declarations
*copyc std$active_set_table
*copyc std$miscellaneous
*copyc std$volume_set_table
*copyc ste$error_condition_codes
*copyc stp$attach_vst
*copyc stp$create_ast_entry
*copyc stp$create_vst
*copyc stp$destroy_vst
*copyc stp$detach_vst
*copyc stp$fill_master_vst
*copyc stp$remove_set_from_vst
*copyc stp$return_opened_vst
*copyc stt$dm_packet_storage
?? POP ??
?? TITLE := '  [XDCL, #GATE] stp$ring2_create_set', EJECT ??
*copyc sth$ring2_create_set

  PROCEDURE [XDCL, #GATE] stp$ring2_create_set (requested_set: stt$set_name;
        requested_master_vol: rmt$recorded_vsn;
        master_internal_vsn: dmt$internal_vsn;
        requested_set_owner: ost$user_identification;
        access_status: stt$access_status;
        active_volume_table_index: dmt$active_volume_table_index;
        root_recreated: boolean;
    VAR create_set_status: ost$status);
?? EJECT ??

    VAR
      ast_index: stt$ast_index,
      dm_packet_storage: stt$dm_packet_storage,
      master_vst_segment_pointer: mmt$segment_pointer,
      masters_sfid: dmt$system_file_id,
      p_master_vst: stt$p_vol_set_table,
      temporary_status: ost$status,
      unique_set_name: stt$unique_set_name;

    create_set_status.normal := TRUE;

    {check if the master volume set table already exists
    stp$attach_vst (requested_master_vol, masters_sfid, create_set_status);
    IF create_set_status.normal THEN {this implies that the volume is already in a set.
      stp$detach_vst (masters_sfid, temporary_status);
      osp$set_status_abnormal (stc$set_management_id, ste$master_belongs_to_set, requested_master_vol,
            create_set_status);
      RETURN;
    IFEND;

{   create and open the master volume set table.
    stp$create_vst (requested_master_vol, masters_sfid, master_vst_segment_pointer, create_set_status);
    IF NOT create_set_status.normal THEN
      RETURN;
    IFEND;
    p_master_vst := master_vst_segment_pointer.cell_pointer;


{   then the master volume set
{   table is set up, and finally an entry is created in the active set table
    dm_packet_storage.dm_packet_ever_stored := FALSE;
    osp$generate_unique_binary_name (unique_set_name, create_set_status);
    stp$fill_master_vst (p_master_vst, requested_master_vol, master_internal_vsn, requested_set,
          unique_set_name, requested_set_owner, dm_packet_storage, root_recreated,
          create_set_status);
    IF create_set_status.normal THEN
      stp$create_ast_entry (requested_set, unique_set_name, requested_master_vol, master_internal_vsn,
            active_volume_table_index, requested_set_owner, access_status, dm_packet_storage, ast_index,
            create_set_status);
      IF create_set_status.normal THEN
{         If all went well, device manager is notified, and stores the set
{         name.
        dmp$change_set_name (requested_master_vol, requested_set, create_set_status);
      ELSE
{
{         This is the case where something went wrong in creating the
{         ast entry, so all previously established tables must be
{         'erased'.
{
        stp$remove_set_from_vst (p_master_vst, temporary_status);
      IFEND;
    IFEND;

    {close master vol set table}
    stp$return_opened_vst (masters_sfid, master_vst_segment_pointer, temporary_status);
    IF NOT create_set_status.normal THEN
      stp$destroy_vst (requested_master_vol, temporary_status);
    IFEND;
  PROCEND stp$ring2_create_set;
MODEND stm$ring2_create_set;
*DECK DECK=STM$RING2_PURGE_SET EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$ring2_purge_set;

{
{ PURPOSE:
{   This contains the ring 2 processor for the purge set function.
{
{ DESIGN:
{   This runs in ring 2 (223 - ring brackets)

?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmp$change_set_name
*copyc dmt$active_volume_table_index
*copyc dmt$system_file_id
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc rmd$volume_declarations
*copyc std$active_set_table
*copyc std$miscellaneous
*copyc std$volume_set_table
*copyc ste$error_condition_codes
*copyc stp$destroy_vst
*copyc stp$dm_check_if_files_on_vol
*copyc stp$members_on_set
*copyc stp$obtain_vst_header
*copyc stp$open_vst
*copyc stp$remove_set_from_ast
*copyc stp$remove_set_from_jast
*copyc stp$remove_set_from_vst
*copyc stp$return_opened_vst
?? POP ??
?? TITLE := '  [XDCL, #GATE] stp$ring2_purge_set', EJECT ??
*copyc sth$ring2_purge_set

  PROCEDURE [XDCL, #GATE] stp$ring2_purge_set (set_name: stt$set_name;
        master_vol: rmt$recorded_vsn;
        master_avt_index: dmt$active_volume_table_index;
        ast_index: stt$ast_index;
        ast_entry: stt$active_set_entry;
    VAR status: ost$status);




    VAR
      local_status: ost$status,
      master_vst_segment_pointer: mmt$segment_pointer,
      masters_sfid: dmt$system_file_id,
      p_master_vst: stt$p_vol_set_table,
      p_pf_root: ^pft$root,
      purge_set_status: ost$status;

{   GET THE MASTER VOLUME OPEN
    stp$open_vst (master_vol, TRUE, masters_sfid, master_vst_segment_pointer, purge_set_status);
    IF purge_set_status.normal THEN
      p_master_vst := master_vst_segment_pointer.cell_pointer;
      ring2_verify_purge_set (set_name, master_vol, p_master_vst, ast_index, ast_entry, purge_set_status);
      IF purge_set_status.normal THEN
{
{       remove all trace of the set.
        stp$remove_set_from_jast (set_name, purge_set_status);
        stp$remove_set_from_vst (p_master_vst, purge_set_status);
        stp$remove_set_from_ast (ast_index, purge_set_status);
        IF purge_set_status.normal THEN
{           notify device management that the volume is no longer in a set.
          dmp$change_set_name (master_vol, osc$null_name, purge_set_status);
        IFEND;
      IFEND;
      stp$return_opened_vst (masters_sfid, master_vst_segment_pointer, local_status);
      IF purge_set_status.normal THEN
        stp$destroy_vst (master_vol, local_status {??} );
      IFEND;
    IFEND;
    status := purge_set_status;
  PROCEND stp$ring2_purge_set;



?? TITLE := '  ring2_verify_purge_set', EJECT ??

  PROCEDURE ring2_verify_purge_set (set_name: stt$set_name;
        master_vol: rmt$recorded_vsn;
        p_vst: stt$p_vol_set_table;
        ast_index: stt$ast_index;
        ast_entry: stt$active_set_entry;
    VAR purge_set_status: ost$status);

{  PURPOSE:
{    This procedure does the verification of the purge set request that can
{    only be done at ring 2, because the volume must be open.
{  CONDITIONS:
{    ste$master_ast_mismatch
{    ste$vol_on_set
{    ste$files_on_vol




    VAR
      files_on_vol: boolean,
      internal_vsn: dmt$internal_vsn,
      master_in_set: boolean,
      master_vst_vsn: rmt$recorded_vsn,
      masters_set: stt$set_name,
      masters_unique_set: stt$unique_set_name,
      members_on_set: boolean,
      volume_status_in_set: stt$vol_status_in_set;

    purge_set_status.normal := TRUE;
{
{   A self check for sets.
    stp$obtain_vst_header (p_vst, master_vst_vsn, internal_vsn, master_in_set, masters_set,
          masters_unique_set, volume_status_in_set);
    IF master_in_set THEN
      IF masters_unique_set <> ast_entry.unique_set_name THEN
        osp$set_status_abnormal (stc$set_management_id, ste$master_ast_mismatch, master_vol,
              purge_set_status);
        RETURN;
      IFEND;
    IFEND;

    { there must be no member volumes on the set }
    stp$members_on_set (ast_index, members_on_set);
    IF members_on_set THEN
      osp$set_status_abnormal (stc$set_management_id, ste$vol_on_set, set_name, purge_set_status);
    ELSE
      { there must be no files on the master volume.
      stp$dm_check_if_files_on_vol (master_vol, files_on_vol);
      IF files_on_vol THEN
        osp$set_status_abnormal (stc$set_management_id, ste$files_on_vol, master_vol, purge_set_status);
      IFEND;
    IFEND;
  PROCEND ring2_verify_purge_set;

MODEND stm$ring2_purge_set;
*DECK DECK=STM$RING2_REMOVE_MEMBER EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$ring2_remove_member;

{
{ PURPOSE:
{   This module contains the ring 2 processing for removing  a  member  volume
{   from a set.
{
{ DESIGN:
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc rmd$volume_declarations
*copyc std$active_set_table
*copyc std$miscellaneous
*copyc std$volume_set_table
*copyc ste$error_condition_codes
*copyc stp$destroy_vst
*copyc stp$obtain_vst_header
*copyc stp$open_vst
*copyc stp$remove_member_from_master
*copyc stp$remove_member_from_mel
*copyc stp$remove_set_from_vst
*copyc stp$return_opened_vst
?? POP ??
?? TITLE := '   [XDCL, #GATE] stp$r2_remove_inactive_member', EJECT ??
PROCEDURE   [XDCL, #GATE] stp$r2_remove_inactive_member
       (ast_index: stt$ast_index;
        member_vol: rmt$recorded_vsn;
        master_vol: rmt$recorded_vsn;
    VAR status: ost$status);

    VAR
      local_status: ost$status,
      masters_sfid: dmt$system_file_id,
      master_vst_segment_pointer: mmt$segment_pointer,
      p_master_vst: stt$p_vol_set_table;

     stp$open_vst (master_vol, TRUE, masters_sfid, master_vst_segment_pointer, status);
     IF status.normal THEN
       p_master_vst := master_vst_segment_pointer.cell_pointer;
       stp$remove_member_from_master (member_vol, p_master_vst, status);
       IF status.normal then
         stp$remove_member_from_mel (member_vol, ast_index, status);
       IFEND;
       stp$return_opened_vst (masters_sfid, master_vst_segment_pointer, local_status);
     IFEND;
   PROCEND;

?? TITLE := '  [XDCL, #GATE] stp$ring2_remove_member', EJECT ??
*copyc sth$ring2_remove_member
  PROCEDURE [XDCL, #GATE] stp$ring2_remove_member (set_name: stt$set_name;
        member_vol: rmt$recorded_vsn;
        master_vol: rmt$recorded_vsn;
        ast_entry: stt$active_set_entry;
        ast_index: stt$ast_index;
    VAR remove_member_status: ost$status);


    VAR
      local_status: ost$status,
      master_vst_segment_pointer: mmt$segment_pointer,
      masters_sfid: dmt$system_file_id,
      member_internal_vsn: dmt$internal_vsn,
      member_vst_segment_pointer: mmt$segment_pointer,
      member_vst_vsn: rmt$recorded_vsn,
      members_set_name: stt$set_name,
      members_sfid: dmt$system_file_id,
      members_unique_set_name: stt$unique_set_name,
      p_master_vst: stt$p_vol_set_table,
      p_member_vst: stt$p_vol_set_table,
      possible_to_mount_master: boolean,
      possible_to_mount_member: boolean,
      vol_belongs_to_set: boolean,
      vol_status_in_set: stt$vol_status_in_set;

    { get the member vst open }
    stp$open_vst (member_vol, TRUE, members_sfid, member_vst_segment_pointer, remove_member_status);
    IF NOT remove_member_status.normal THEN
      RETURN;
    IFEND;
    p_member_vst := member_vst_segment_pointer.cell_pointer;
    {verify this is the correct member.
    stp$obtain_vst_header (p_member_vst, member_vst_vsn, member_internal_vsn, vol_belongs_to_set,
          members_set_name, members_unique_set_name, vol_status_in_set);
    IF vol_belongs_to_set THEN
      IF set_name <> members_set_name THEN
        osp$set_status_abnormal (stc$set_management_id, ste$wrong_set_given, member_vol,
              remove_member_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, members_set_name, remove_member_status);
        osp$append_status_parameter (osc$status_parameter_delimiter, set_name, remove_member_status);
      ELSE
        IF ast_entry.unique_set_name <> members_unique_set_name THEN
          osp$set_status_abnormal (stc$set_management_id, ste$bad_unique_member, member_vol,
                remove_member_status);
        IFEND;
      IFEND;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$vol_not_in_set, member_vol, remove_member_status);
      osp$append_status_parameter (osc$status_parameter_delimiter, set_name, remove_member_status);
    IFEND;

    IF remove_member_status.normal THEN
{     get the master vst open
      stp$open_vst (master_vol, TRUE, masters_sfid, master_vst_segment_pointer, remove_member_status);
      IF remove_member_status.normal THEN
        p_master_vst := master_vst_segment_pointer.cell_pointer;
{
{       REMOVE ALL TRACE OF THE MEMBER VOLUME
        stp$remove_set_from_vst (p_member_vst, remove_member_status);
        stp$remove_member_from_mel (member_vol, ast_index, remove_member_status);
        stp$remove_member_from_master (member_vol, p_master_vst, remove_member_status);
        stp$return_opened_vst (masters_sfid, master_vst_segment_pointer, local_status);
      IFEND;

    IFEND;
    stp$return_opened_vst (members_sfid, member_vst_segment_pointer, local_status);
    IF remove_member_status.normal THEN
      stp$destroy_vst (member_vol, local_status);
    IFEND;
  PROCEND stp$ring2_remove_member;

MODEND stm$ring2_remove_member;
*DECK DECK=STM$SET_END_JOB EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$set_end_job;

{  PURPOSE:
{    This module contains the compilation unit for stp$set_end_job.


?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osp$set_status_abnormal
*copyc ost$status
*copyc osv$job_pageable_heap
*copyc std$active_set_table
*copyc std$job_active_set_table
*copyc ste$error_condition_codes
*copyc stk$keypoints
*copyc stp$clear_exclusive_access
*copyc stp$deallocate_ast_entry
*copyc stp$decrement_job_use_in_ast
*copyc stp$search_ast_by_set
*copyc stp$set_exclusive_access
*copyc stv$p_jast
?? POP ??
?? TITLE := '  [XDCL, #GATE] stp$set_end_job', EJECT ??
*copyc sth$set_end_job

  PROCEDURE [XDCL, #GATE] stp$set_end_job (VAR status: ost$status);



    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index,
      job_ast_entry: stt$job_active_set_entry,
      job_ast_index: integer,
      local_status: ost$status,
      set_found: boolean,
      set_name: stt$set_name;




    #keypoint (osk$entry, 0, stk$set_end_job);
    local_status.normal := TRUE;
{   Decrement the count in the active set table, for each set in use by this
{   job.
    IF stv$p_jast <> NIL THEN
      FOR job_ast_index := LOWERBOUND (stv$p_jast^.table) TO UPPERBOUND (stv$p_jast^.table) DO
        IF stv$p_jast^.table [job_ast_index].entry_type = stc$valid THEN
          set_name := stv$p_jast^.table [job_ast_index].set_name;
          stp$set_exclusive_access;
          stp$search_ast_by_set (set_name, ast_entry, ast_index, set_found);
          IF set_found THEN
            stp$decrement_job_use_in_ast (ast_index);
            IF ast_entry.number_of_jobs_using_set = 1 THEN
              stp$deallocate_ast_entry (ast_index, local_status);
              local_status.normal := TRUE;
            IFEND;
          ELSE
            osp$set_status_abnormal (stc$set_management_id, ste$jast_ast_mismatch, set_name, local_status);
          IFEND;
          stp$clear_exclusive_access;
        IFEND;
      FOREND;

{  FREE THE JOB TABLES
      FREE stv$p_jast IN osv$job_pageable_heap^;
    IFEND;
    status := local_status;
    IF status.normal THEN
      #keypoint (osk$exit, 0, stk$set_end_job);
    ELSE
      #keypoint (osk$exit, 0, stk$set_end_job);
    IFEND;
  PROCEND stp$set_end_job;


MODEND stm$set_end_job;
*DECK DECK=STM$SET_MANAGER_DEFINITIONS EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
MODULE stm$set_manager_definitions;
?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc osd$unique_name
*copyc rmd$volume_declarations
?? POP ??
?? TITLE := '*** STD$SET_NAME ***', EJECT ??
*copy std$set_name
?? TITLE := '*** STD$MISCELLANEOUS *** ', EJECT ??
*copy std$miscellaneous
?? TITLE := ' CONST STC$ARRAY_LOWERBOUND, STC$MAX_NUM_MEMBERS_ON_SET', EJECT ??
*copy stc$array_lowerbound
*copy stc$max_num_members_on_set
?? SKIP := 4 ??
{   STT$NUMBER_OF_MEMBERS
*copy stt$number_of_members
?? TITLE := '*** STT$SET_ORDINAL *** ', EJECT ??
*copy stt$set_ordinal
?? TITLE := '*** STT$VOLUME_ACTIVITY_DESCRIPTOR ***', EJECT ??
*copy stt$volume_activity_descriptor
?? TITLE := '*** STT$DM_PACKET ***', EJECT ??
*copy stt$dm_packet
?? TITLE := '*** STT$DM_PACKET_STORAGE ***', EJECT ??
*copy stt$dm_packet_storage
?? TITLE := '*** STT$VOLUME_INFO ***', EJECT ??
*copy stt$volume_info
?? TITLE := '*** STT$VOLUME_LIST ***', EJECT ??
*copy stt$volume_list
?? TITLE := '*** STD$VOLUME_SET_TABLE ***', EJECT ??
*copy std$volume_set_table
?? TITLE := '*** STD$LOCATORS *** ', EJECT ??
?? NOCOMPILE ??
*copy std$locators
?? POP ??
?? COMPILE ??
?? TITLE := '*** STD$MEMBER_ENTRY_LIST - ACTIVE SET TABLE ***', EJECT ??
*copy std$member_entry_list
?? TITLE := '*** STD$ACTIVE_SET_TABLE ***', EJECT ??
*copy std$active_set_table
?? TITLE := '*** STD$JOB_ACTIVE_SET_TABLE ***', EJECT ??
*copy std$job_active_set_table
?? TITLE := '*** STK$KEYPOINTS***', EJECT ??
*copy stk$keypoints
?? TITLE := ' *** STE$ERROR_CONDITION_CODES ***', EJECT ??
*copy ste$error_condition_codes
MODEND stm$set_manager_definitions;
*DECK DECK=STM$TRANSLATE_SET_NAMES EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$translate_set_names;
{
{ PURPOSE:
{   This module includes procedures that translate from set name to set
{   ordinal.


?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc i#program_error
*copyc osp$set_status_abnormal
*copyc std$active_set_table
*copyc ste$error_condition_codes
*copyc stp$clear_read_access
*copyc stp$get_active_volume_list
*copyc stp$search_ast_by_set
*copyc stp$search_ast_by_unique_set
*copyc stp$set_read_access
*copyc stt$set_ordinal
?? POP ??
?? TITLE := '  stp$get_pf_volumes', EJECT ??

  PROCEDURE [XDCL, #GATE] stp$get_pf_volumes
   (VAR pf_volumes: array [1 .. * ] OF rmt$recorded_vsn;
    VAR number_of_volumes: integer;
    VAR status: ost$status);

    VAR
      i: integer,
      p_jobs_scratch_volumes: ^stt$volume_list;

    status.normal := TRUE;
    number_of_volumes := 1;
    IF (LOWERBOUND(pf_volumes) <> 1) OR (UPPERBOUND(pf_volumes) > UPPERVALUE(i)) THEN
      i#program_error;
    IFEND;

    PUSH p_jobs_scratch_volumes: [1 .. UPPERBOUND (pf_volumes)];
    stp$get_active_volume_list (p_jobs_scratch_volumes^, number_of_volumes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    FOR i := 1 TO UPPERBOUND (pf_volumes) DO
      IF i <= number_of_volumes THEN
        pf_volumes [i] := p_jobs_scratch_volumes^ [i].recorded_vsn;
      IFEND;
    FOREND;
  PROCEND stp$get_pf_volumes;
?? TITLE := '  [XDCL] stp$get_sets_ordinal ', EJECT ??
*copyc sth$get_sets_ordinal

  PROCEDURE [XDCL] stp$get_sets_ordinal (set_name: stt$set_name;
    VAR set_ordinal: stt$set_ordinal;
    VAR master_vol: rmt$recorded_vsn;
    VAR status: ost$status);



    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index,
      set_found: boolean;

    stp$set_read_access;
    stp$search_ast_by_set (set_name, ast_entry, ast_index, set_found);
    stp$clear_read_access;
    IF set_found THEN
      status.normal := TRUE;
      master_vol := ast_entry.master_vsn;
      set_ordinal.entry_type := stc$valid;
      set_ordinal.unique_set_name := ast_entry.unique_set_name;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$set_not_active, stc$null_parameter, status);
      set_ordinal.entry_type := stc$unused;
    IFEND;
  PROCEND stp$get_sets_ordinal;




?? TITLE := '  [XDCL] stp$translate_set_ordinal ', EJECT ??
*copyc sth$translate_set_ordinal

  PROCEDURE [XDCL] stp$translate_set_ordinal (set_ordinal: stt$set_ordinal;
    VAR set_name: stt$set_name;
    VAR status: ost$status);



    VAR
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index,
      set_found: boolean;

    status.normal := TRUE;
    IF set_ordinal.entry_type = stc$valid THEN
      stp$set_read_access;
      stp$search_ast_by_unique_set (set_ordinal.unique_set_name, ast_entry, ast_index, set_found);
      stp$clear_read_access;
      IF set_found THEN
        status.normal := TRUE;
        set_name := ast_entry.set_name;
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$set_not_active, stc$null_parameter, status);
      IFEND;
    ELSE
      osp$set_status_abnormal (stc$set_management_id, ste$set_ord_not_set, stc$null_parameter, status);
    IFEND;
  PROCEND stp$translate_set_ordinal;
MODEND stm$translate_set_names;
*DECK DECK=STM$USER_DISPLAY_INTERFACE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$user_display_interface;
?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc clt$display_control
*copyc ost$status
*copyc rmd$volume_declarations
*copyc stp$display_sets
*copyc stp$display_vol_set_table
?? POP ??

?? TITLE := ' [XDCL, #GATE]stp$display_volume', EJECT ??

  PROCEDURE [XDCL, #GATE] stp$display_volume
    (    volume: rmt$recorded_vsn;
     VAR display_control: clt$display_control;
     VAR status: ost$status);

    status.normal := TRUE;
    stp$display_vol_set_table (volume, display_control, status);
  PROCEND stp$display_volume;
?? TITLE := '  [XDCL, #GATE] stp$display_all_sets', EJECT ??

  PROCEDURE [XDCL, #GATE] stp$display_all_sets
    (VAR display_control: clt$display_control;
     VAR status: ost$status);

    status.normal := TRUE;
    stp$display_sets (display_control, status);
  PROCEND stp$display_all_sets;

MODEND stm$user_display_interface;
*DECK DECK=STM$VOLUME_ACTIVE EXPAND=TRUE
?? RIGHT := 110 ??
*copyc osd$default_pragmats
?? NEWTITLE := '  NOS/VE Set Management ' ??
?? NEWTITLE := '  Module Header ' ??
MODULE stm$volume_active;

{  PURPOSE:
{    This procedure is the compilation module for the code for
{    stp$disk_volume_active.  For a design
{    look at the entry point stp$disk_volume_active.


?? TITLE := '  Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc dmt$internal_vsn
*copyc ost$status
*copyc osp$append_status_parameter
*copyc osp$set_status_abnormal
*copyc oss$mainframe_pageable
*copyc osv$deadstart_phase
*copyc pfd$root
*copyc rmd$volume_declarations
*copyc std$active_set_table
*copyc ste$error_condition_codes
*copyc stk$keypoints
*copyc stt$dm_packet
*copyc stt$number_of_members
*copyc std$miscellaneous
*copyc std$volume_set_table
*copyc stp$create_ast_entry
*copyc stp$get_unused_mel_entry
*copyc stp$insert_member_into_mel
*copyc stp$add_member_in_ast
*copyc stp$add_member_in_master_vst
*copyc stp$build_member_list_pointer
*copyc stp$get_root_recreated
*copyc stp$obtain_ast_entry
*copyc stp$obtain_ast_member_list
*copyc stp$remove_set_from_ast
*copyc stp$search_ast_by_set
*copyc stp$search_mvl_for_vol
*copyc stp$store_dm_packet_in_mel
*copyc stp$get_unused_entry_in_ast
*copyc stp$store_inactive_master
*copyc stp$search_mel_for_vol
*copyc stp$store_ast_master_header
*copyc stp$clear_exclusive_access
*copyc stp$set_exclusive_access
*copyc stp$open_vst
*copyc stp$store_vst_being_modified
*copyc stp$obtain_vst_pf_root
*copyc stp$return_opened_vst
*copyc stp$store_ast_pf_root
*copyc stp$obtain_master_vst_info
*copyc stp$obtain_member_vst_info
*copyc stp$obtain_vst_header
*copyc stp$store_member_dm_packet
*copyc stp$store_master_dm_packet
*copyc osv$recover_system_set_phase
*copyc dmv$system_device_information
*copyc syp$trace_deadstart_message
*copyc syp$process_deadstart_status
*copyc stp$remove_member_from_master
*copyc stp$remove_set_from_vst
*copyc osp$add_family
*copyc jmc$system_family
?? POP ??
?? TITLE := '  [XDCL, #GATE] stp$disk_volume_active ', EJECT ??
*copyc sth$disk_volume_active

  PROCEDURE [XDCL, #GATE] stp$disk_volume_active
    (    active_volume: rmt$recorded_vsn;
         internal_vsn: dmt$internal_vsn;
         active_volume_table_index: dmt$active_volume_table_index;
     VAR set_name: stt$set_name;
     VAR status: ost$status);

    VAR
      active_volumes_segment_pointer: mmt$segment_pointer,
      active_volumes_sfid: dmt$system_file_id,
      first_volume: [STATIC, oss$mainframe_pageable] boolean := TRUE,
      stv$system_set_name: [XDCL, #GATE, oss$mainframe_pageable] stt$set_name := osc$null_name,
      ast_entry: stt$active_set_entry,
      ast_index: stt$ast_index,
      ignore_status: ost$status,
      local_status: ost$status,
      p_vol_set_table: stt$p_vol_set_table,
      root_recreated: boolean,
      set_found_in_ast: boolean,
      stl: integer,
      str: string (80),
      volume_belongs_to_set: boolean,
      volume_status_in_set: stt$vol_status_in_set,
      vst_internal_vsn: dmt$internal_vsn,
      vst_set: stt$set_name,
      vst_unique_set: stt$unique_set_name,
      vst_volume: rmt$recorded_vsn;


?? EJECT ??

    #KEYPOINT (osk$entry, osk$m * active_volume_table_index, stk$disk_volume_active);
    status.normal := TRUE;
    root_recreated := FALSE;
    set_name := osc$null_name;
    stp$set_exclusive_access;

  /exclusive_access/
    BEGIN
      stp$open_vst (active_volume, FALSE, active_volumes_sfid, active_volumes_segment_pointer, status);
      IF NOT status.normal THEN
        IF status.condition = ste$vol_not_in_set THEN
          status.normal := TRUE;
        IFEND;
        EXIT /exclusive_access/;
      IFEND;

    /vst_open/
      BEGIN
        p_vol_set_table := active_volumes_segment_pointer.cell_pointer;
        stp$obtain_vst_header (p_vol_set_table, vst_volume, vst_internal_vsn, volume_belongs_to_set,
              vst_set, vst_unique_set, volume_status_in_set);
        IF NOT volume_belongs_to_set THEN
          osp$set_status_abnormal (stc$set_management_id, ste$vst_exists_not_in_set, active_volume, status);
          EXIT /vst_open/;
        IFEND;

        IF internal_vsn <> vst_internal_vsn THEN
          osp$set_status_abnormal (stc$set_management_id, ste$internal_vsn_mismatch, active_volume, status);
          EXIT /vst_open/;
        IFEND;

        stp$search_ast_by_set (vst_set, ast_entry, ast_index, set_found_in_ast);
        IF set_found_in_ast THEN
          IF ast_entry.unique_set_name = vst_unique_set THEN
            IF volume_status_in_set = stc$master_vol THEN
              activate_master_volume (active_volume, internal_vsn, active_volume_table_index,
                    p_vol_set_table, ast_index, status);
            ELSE {member volume}
              activate_member_volume (active_volume, internal_vsn, active_volume_table_index,
                    p_vol_set_table, ast_index, ast_entry, status);
            IFEND;
            IF status.normal THEN
              set_name := vst_set;
            IFEND;
          ELSE
{
{ A volume has become active, with the same set name as one that
{ is currently active, but has a different unique set name.
{ If the master volume of a system set or a non-system set is
{ being initialized then we recover the set member.
{
            stp$get_root_recreated (vst_set, root_recreated, ignore_status);
            IF ((osv$recover_system_set_phase = osc$reinitialize_system_device) AND
                  (vst_set = stv$system_set_name)) OR
                  root_recreated THEN
              STRINGREP (str, stl, 'Recovering member: ', active_volume, ' for set: ', vst_set);
              syp$trace_deadstart_message (str (1, stl));
              recover_set_member (vst_set, active_volume, internal_vsn, active_volume_table_index,
                    ast_entry, ast_index, status);
              IF status.normal THEN
                set_name := vst_set;
              ELSE
                STRINGREP (str, stl, 'Unable to recover member: ', active_volume, ' for set: ', vst_set);
                syp$process_deadstart_status (str (1, stl), {fatal = } FALSE, status);
              IFEND;
            ELSE
              osp$set_status_abnormal (stc$set_management_id, ste$diff_unique_set_active, active_volume,
                    status);
              osp$append_status_parameter (osc$status_parameter_delimiter, ast_entry.set_name, status);
            IFEND;
          IFEND;
        ELSE
          {
          { create a new active set table entry.
          {
          IF first_volume THEN
            first_volume := FALSE;
            IF osv$deadstart_phase <> osc$installation_deadstart THEN
              stv$system_set_name := vst_set;
              osp$add_family (jmc$system_family, stv$system_set_name, local_status);
            IFEND;
          IFEND;
          IF volume_status_in_set = stc$master_vol THEN
            create_new_entry_w_master (active_volume, internal_vsn, active_volume_table_index, vst_set,
                  vst_unique_set, p_vol_set_table, stc$deny_access, ast_index, status);
          ELSE
            create_new_entry_w_member (active_volume, internal_vsn, active_volume_table_index, vst_set,
                  vst_unique_set, p_vol_set_table, stc$deny_access, ast_index, status);
          IFEND;
          IF status.normal THEN
            set_name := vst_set;
          IFEND;
        IFEND;
      END /vst_open/;

      stp$return_opened_vst (active_volumes_sfid, active_volumes_segment_pointer, local_status);
    END /exclusive_access/;

    stp$clear_exclusive_access;
    #KEYPOINT (osk$exit, 0, stk$disk_volume_active);
  PROCEND stp$disk_volume_active;


?? TITLE := '  stp$active_master_volume', EJECT ??

  PROCEDURE activate_master_volume (master_volume: rmt$recorded_vsn;
        master_internal_vsn: dmt$internal_vsn;
        avt_index: dmt$active_volume_table_index;
        p_master_vst: stt$p_vol_set_table;
        ast_index: stt$ast_index;
    VAR status: ost$status);

{
{  PURPOSE:
{    This routine updates an existing active set entry table entry when
{    a master volume becomes active.  This includes verifying the content
{    of the active set table, transferring all members from the master
{    volume set table to the active set table, and storing information
{    from the volume set table into the active set table.
{
{      CONDITIONS:
{        ste$mel_mvl_mismatch
{        ose$mainframe_pageable_full


    VAR
      size_of_vst_member_list: stt$number_of_members,
      dm_packet_storage: stt$dm_packet_storage,
      mel_entry: stt$member_entry,
      dummy_avt_index: dmt$active_volume_table_index,
      ast_member_entry: stt$member_entry,
      vst_member_entry: stt$member_vsn_entry,
      set_owner: ost$user_identification,
      pf_root_stored_in_vst: boolean,
      pf_root_size: pft$root_size,
      p_pf_root: ^pft$root,
      pf_root_locator: stt$pf_root_locator,
      ast_entry: stt$active_set_entry,
      p_vst_member_list: stt$p_member_vsn_list,
      vst_index: integer,
      p_ast_member_list: stt$p_member_entry_list,
      ast_member_list_size: integer,
      mel_index: integer,
      vst_modified: boolean,
      volume_found_in_vst: boolean,
      volume_found_in_ast: boolean;

    status.normal := TRUE;
    vst_modified := FALSE;

    {
    { Verify that all volumes in the active set table are in the master volume
    { set table.
    { Store the dm_packet of volumes from the active set table into
    { the master volume set table. (The dm_packet in the ast may be more up
    { to date. For example.
    { member a initially active
    { member b becomes active
    { member a becomes inactive - dm_packet stored in ast
    { master becomes active )

    PUSH p_vst_member_list: [1 .. stc$max_num_members_on_set];
    stp$obtain_master_vst_info (p_master_vst, set_owner, dm_packet_storage, p_vst_member_list^,
          size_of_vst_member_list, pf_root_stored_in_vst, pf_root_size, pf_root_locator);

    PUSH p_ast_member_list: [1 .. stc$max_num_members_on_set];
    stp$obtain_ast_member_list (ast_index, p_ast_member_list^, ast_member_list_size);

  /loop_through_ast/
    FOR mel_index := 1 TO ast_member_list_size DO
      ast_member_entry := p_ast_member_list^ [mel_index];
      IF ast_member_entry.entry_type = stc$valid THEN

        {are all members that are in the ast in the vst ?}
        volume_found_in_vst := FALSE;
        vst_index := 1;
        REPEAT
          IF (p_vst_member_list^ [vst_index].entry_type = stc$valid) AND (p_vst_member_list^ [vst_index].
                member_vsn = ast_member_entry.member_vsn) THEN
            volume_found_in_vst := TRUE;
          IFEND;
          vst_index := vst_index + 1;
        UNTIL volume_found_in_vst OR (vst_index > UPPERBOUND (p_vst_member_list^)) OR (vst_index >
              size_of_vst_member_list);

        IF NOT volume_found_in_vst THEN
          stp$obtain_ast_entry (ast_index, ast_entry, status);
          osp$set_status_abnormal (stc$set_management_id, ste$mel_mvl_mismatch, ast_member_entry.member_vsn,
                status);
          osp$append_status_parameter (osc$status_parameter_delimiter, ast_entry.set_name, status);
          EXIT /loop_through_ast/;
        IFEND;
        IF ast_member_entry.member_dm_packet_storage.dm_packet_ever_stored THEN
          IF NOT vst_modified THEN
            stp$store_vst_being_modified (p_master_vst, status);
            vst_modified := TRUE;
          IFEND;
          stp$store_member_dm_packet (p_master_vst, ast_member_entry.member_vsn, ast_member_entry.
                member_dm_packet_storage, status);
        IFEND;
      IFEND;
    FOREND /loop_through_ast/;



    {
    { Transfer all members from the master volume set table to the
    { active set table.
    IF status.normal THEN

    /loop_through_vst/
      FOR vst_index := 1 TO size_of_vst_member_list DO
        vst_member_entry := p_vst_member_list^ [vst_index];
        IF vst_member_entry.entry_type = stc$valid THEN
          stp$search_mel_for_vol (vst_member_entry.member_vsn, ast_index, mel_entry, mel_index,
                volume_found_in_ast);
          IF volume_found_in_ast THEN
            IF NOT mel_entry.member_dm_packet_storage.dm_packet_ever_stored THEN
              stp$store_dm_packet_in_mel (ast_index, mel_index, vst_member_entry.member_dm_packet_storage);
            IFEND;
          ELSE
            stp$add_member_in_ast (vst_member_entry.member_vsn, vst_member_entry.member_internal_vsn,
                  stc$inactive, dummy_avt_index, ast_index, vst_member_entry.member_dm_packet_storage);
          IFEND;
        IFEND;
      FOREND /loop_through_vst/;
    IFEND;


    IF status.normal THEN
      stp$obtain_ast_entry (ast_index, ast_entry, status);
      IF (ast_entry.master_ever_up) AND (ast_entry.master_dm_packet_storage.dm_packet_ever_stored) THEN
        IF NOT vst_modified THEN
          stp$store_vst_being_modified (p_master_vst, status);
          vst_modified := TRUE;
        IFEND;
        dm_packet_storage := ast_entry.master_dm_packet_storage;
        stp$store_master_dm_packet (p_master_vst, dm_packet_storage);
      IFEND;
      IF pf_root_stored_in_vst THEN
        PUSH p_pf_root: [[REP pf_root_size OF cell]];
        stp$obtain_vst_pf_root (p_master_vst, p_pf_root^, status);
      ELSE
        PUSH p_pf_root: [[REP 1 OF cell]];
      IFEND;
      IF status.normal THEN
        stp$store_ast_master_header (ast_index, avt_index, set_owner, dm_packet_storage,
              pf_root_stored_in_vst, p_pf_root^, status);
      IFEND;
    IFEND;
  PROCEND activate_master_volume;



?? TITLE := '  activate_member_volume', EJECT ??

  PROCEDURE activate_member_volume (member_volume: rmt$recorded_vsn;
        member_internal_vsn: dmt$internal_vsn;
        members_avt_index: dmt$active_volume_table_index;
        p_member_vst: stt$p_vol_set_table;
        ast_index: stt$ast_index;
        ast_entry: stt$active_set_entry;
    VAR status: ost$status);

{
{  PURPOSE:
{    This routine updates an existing active set table entry when a member
{    volume becomes active.  This involves adding the member into the
{    active set table.
{  CONDITIONS:
{    ste$ast_vst_master_mis
{    ste$bad_mel_generated
{    ose$mainframe_pageable_full
{    ste$internal_vsn_mismatch
{


    VAR
      master_vsn: rmt$recorded_vsn,
      dm_packet_storage: stt$dm_packet_storage,
      masters_internal_vsn: dmt$internal_vsn,
      mel_entry: stt$member_entry,
      mel_index: stt$mel_index,
      member_found_in_ast: boolean;

    stp$obtain_member_vst_info (p_member_vst, master_vsn, masters_internal_vsn);
    IF master_vsn <> ast_entry.master_vsn THEN
      osp$set_status_abnormal (stc$set_management_id, ste$ast_vst_master_mis, member_volume, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, ast_entry.set_name, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, master_vsn, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, ast_entry.master_vsn, status);
    ELSE
      IF masters_internal_vsn = ast_entry.master_internal_vsn THEN
        stp$search_mel_for_vol (member_volume, ast_index, mel_entry, mel_index, member_found_in_ast);
        IF member_found_in_ast THEN
          dm_packet_storage := mel_entry.member_dm_packet_storage;
        ELSE
          IF ast_entry.master_ever_up THEN
            { if the master is active. the ast should know about the member
            osp$set_status_abnormal (stc$set_management_id, ste$bad_mel_generated, member_volume, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, ast_entry.set_name, status);
          ELSE
            stp$get_unused_mel_entry (ast_index, mel_index);
            dm_packet_storage.dm_packet_ever_stored := FALSE;
          IFEND;
        IFEND;
        IF status.normal THEN
          stp$insert_member_into_mel (ast_index, mel_index, member_volume, member_internal_vsn, stc$active,
                members_avt_index, dm_packet_storage);
        IFEND;
      ELSE
        osp$set_status_abnormal (stc$set_management_id, ste$internal_vsn_mismatch, master_vsn, status);
      IFEND;
    IFEND;
  PROCEND activate_member_volume;



?? TITLE := '  create_new_entry_w_master', EJECT ??

  PROCEDURE create_new_entry_w_master (master_vsn: rmt$recorded_vsn;
        masters_internal_vsn: dmt$internal_vsn;
        masters_avt_index: dmt$active_volume_table_index;
        set_name: stt$set_name;
        unique_set_name: stt$unique_set_name;
        p_master_vst: stt$p_vol_set_table;
        access_status: stt$access_status;
    VAR ast_index: stt$ast_index;
    VAR status: ost$status);

{
{  PURPOSE:
{    This routine creates a new active set table entry when the master volume
{    is the first volume active in the set.

{  CONDITIONS: ose$mainframe_pageable_full
{





    VAR
      size_of_vst_member_list: stt$number_of_members,
      master_dm_packet_storage: stt$dm_packet_storage,
      dummy_avt_index: dmt$active_volume_table_index,
      set_owner: ost$user_identification,
      member_vst_entry: stt$member_vsn_entry,
      local_status: ost$status,
      pf_root_stored_in_vst: boolean,
      pf_root_size: pft$root_size,
      pf_root_locator: stt$pf_root_locator,
      p_pf_root: ^pft$root,
      p_vst_member_list: stt$p_member_vsn_list,
      vst_index: integer;

    PUSH p_vst_member_list: [1 .. stc$max_num_members_on_set];
    stp$obtain_master_vst_info (p_master_vst, set_owner, master_dm_packet_storage, p_vst_member_list^,
          size_of_vst_member_list, pf_root_stored_in_vst, pf_root_size, pf_root_locator);

    stp$create_ast_entry (set_name, unique_set_name, master_vsn, masters_internal_vsn, masters_avt_index,
          set_owner, access_status, master_dm_packet_storage, ast_index, status);
{
{   Transfer the information about all volumes in the master volume set table
{   to the active set table.
    IF status.normal THEN

    /transfer_vst_to_ast/
      FOR vst_index := 1 TO size_of_vst_member_list DO
        member_vst_entry := p_vst_member_list^ [vst_index];
        IF member_vst_entry.entry_type = stc$valid THEN
          stp$add_member_in_ast (member_vst_entry.member_vsn, member_vst_entry.member_internal_vsn,
                stc$inactive, dummy_avt_index, ast_index, member_vst_entry.member_dm_packet_storage);
        IFEND;
      FOREND /transfer_vst_to_ast/;
      IF status.normal THEN
        IF pf_root_stored_in_vst THEN
          PUSH p_pf_root: [[REP pf_root_size OF cell]];
          stp$obtain_vst_pf_root (p_master_vst, p_pf_root^, status);
          IF status.normal THEN
            stp$store_ast_pf_root (ast_index, p_pf_root^, status);
          IFEND;
        IFEND;
      IFEND;
      IF NOT status.normal THEN
        stp$remove_set_from_ast (ast_index, local_status);
      IFEND;
    IFEND;
  PROCEND create_new_entry_w_master;



?? TITLE := '  create_new_entry_w_member', EJECT ??

  PROCEDURE create_new_entry_w_member (member_vsn: rmt$recorded_vsn;
        member_internal_vsn: dmt$internal_vsn;
        members_avt_index: dmt$active_volume_table_index;
        set_name: stt$set_name;
        unique_set_name: stt$unique_set_name;
        p_member_vst: stt$p_vol_set_table;
        access_status: stt$access_status;
    VAR ast_index: stt$ast_index;
    VAR status: ost$status);

{
{  PURPOSE:
{    This routine creates a new active set table entry when the first volume
{    active in the set is a member.
{
{ CONDITIONS: ose$mainframe_pageable_full
{


    VAR
      master_vsn: rmt$recorded_vsn,
      dm_packet_storage: stt$dm_packet_storage,
      local_status: ost$status,
      masters_internal_vsn: dmt$internal_vsn;

    stp$obtain_member_vst_info (p_member_vst, master_vsn, masters_internal_vsn);
    stp$get_unused_entry_in_ast (ast_index, status);
    IF status.normal THEN
      stp$store_inactive_master (set_name, unique_set_name, master_vsn, masters_internal_vsn, access_status,
            ast_index);
      dm_packet_storage.dm_packet_ever_stored := FALSE;
      stp$add_member_in_ast (member_vsn, member_internal_vsn, stc$active, members_avt_index, ast_index,
            dm_packet_storage);
    IFEND;
  PROCEND create_new_entry_w_member;
?? TITLE := '  recover_set_member', EJECT ??
  PROCEDURE recover_set_member
    (    set_name: stt$set_name;
         member_vol: rmt$recorded_vsn;
         member_internal_vsn: dmt$internal_vsn;
         members_avt_index: dmt$active_volume_table_index;
         ast_entry: stt$active_set_entry;
         ast_index: stt$ast_index;
     VAR status: ost$status);

    VAR
      dm_packet_storage: stt$dm_packet_storage,
      local_status: ost$status,
      master_vst_segment_pointer: mmt$segment_pointer,
      masters_sfid: dmt$system_file_id,
      member_vst_segment_pointer: mmt$segment_pointer,
      members_set_name: stt$set_name,
      members_sfid: dmt$system_file_id,
      p_master_vst: stt$p_vol_set_table,
      p_member_vst: stt$p_vol_set_table;

    stp$open_vst (ast_entry.master_vsn, TRUE, masters_sfid, master_vst_segment_pointer, status);
    IF status.normal THEN
      p_master_vst := master_vst_segment_pointer.cell_pointer;
      verify_unique_member (member_vol, ast_entry, ast_index, p_master_vst, status);
      IF status.normal THEN
        stp$open_vst (member_vol, {write_access = } TRUE, members_sfid, member_vst_segment_pointer, status);
        IF status.normal THEN
          p_member_vst := member_vst_segment_pointer.cell_pointer;
          IF p_member_vst^.vol_status_in_set = stc$member_vol THEN
            dm_packet_storage.dm_packet_ever_stored := FALSE;
            stp$add_member_in_master_vst (p_master_vst, member_vol, member_internal_vsn, dm_packet_storage,
                  status);
            IF status.normal THEN
              stp$add_member_in_ast (member_vol, member_internal_vsn, stc$active, members_avt_index,
                    ast_index, dm_packet_storage);
              p_member_vst^.unique_set_name := ast_entry.unique_set_name;
              p_member_vst^.master_internal_vsn := ast_entry.master_internal_vsn;
              p_member_vst^.master_vsn := ast_entry.master_vsn;
            IFEND;
          ELSE
            osp$set_status_abnormal (stc$set_management_id, ste$duplicate_master_initdd, member_vol, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, ast_entry.set_name, status);
            osp$append_status_parameter (osc$status_parameter_delimiter, ast_entry.master_vsn, status);
          IFEND;
          stp$return_opened_vst (members_sfid, member_vst_segment_pointer, local_status);
        IFEND;
      IFEND;
      stp$return_opened_vst (masters_sfid, master_vst_segment_pointer, local_status);
    IFEND;
  PROCEND recover_set_member;

?? TITLE := ' verify_unique_member ', EJECT ??
{ This procedure verifies that the requested member volume is not already defined in the active set table, or
{ in the master volume set table.
  PROCEDURE verify_unique_member
    (    member_vol: rmt$recorded_vsn;
         ast_entry: stt$active_set_entry;
         ast_index: stt$ast_index;
         p_master_vst: stt$p_vol_set_table;
     VAR status: ost$status);

    VAR
      mel_index: stt$mel_index,
      member_entry: stt$member_entry,
      member_found: boolean,
      mvl_index: stt$mvl_index,
      p_new_member_vsn_list: stt$p_member_vsn_list;

    stp$search_mel_for_vol (member_vol, ast_index, member_entry, mel_index, member_found);
    IF member_found THEN
      osp$set_status_abnormal (stc$set_management_id, ste$member_vol_in_set, member_vol, status);
      osp$append_status_parameter (osc$status_parameter_delimiter, ast_entry.set_name, status);
    ELSE
      stp$build_member_list_pointer (p_master_vst^.member_vsn_list_locator, p_master_vst,
            p_new_member_vsn_list);
      stp$search_mvl_for_vol (member_vol, p_new_member_vsn_list, mvl_index, member_found);
      IF member_found THEN
        osp$set_status_abnormal (stc$set_management_id, ste$member_vol_in_set, member_vol, status);
        osp$append_status_parameter (osc$status_parameter_delimiter, ast_entry.set_name, status);
      ELSE
        status.normal := TRUE;
      IFEND;
    IFEND;
  PROCEND verify_unique_member;

MODEND stm$volume_active;

*DECK DECK=STP$ACTIVATE_DEADSTART_SETS EXPAND=FALSE
  PROCEDURE [XREF] stp$activate_deadstart_sets (
    set_overhaul_choices: pft$set_overhaul_choices;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc pft$overhaul_choices
*copyc ost$status
?? POP ??

*DECK DECK=STP$ADD_MEMBER_IN_AST EXPAND=FALSE
  PROCEDURE [XREF] stp$add_member_in_ast
    (    member_vol: rmt$recorded_vsn;
         member_internal_vsn: dmt$internal_vsn;
         members_activity: stt$vol_activity_status;
         members_avt_index: dmt$active_volume_table_index;
         ast_index: stt$ast_index;
         dm_packet_storage: stt$dm_packet_storage);

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc dmt$internal_vsn
*copyc rmd$volume_declarations
*copyc std$active_set_table
*copyc std$miscellaneous
*copyc stt$dm_packet_storage
?? POP ??

*DECK DECK=STP$ADD_MEMBER_IN_MASTER_VST EXPAND=FALSE

  PROCEDURE [XREF] stp$add_member_in_master_vst alias 'STXVMIM' (p_master_vst:
    stt$p_vol_set_table;
    member_vol: rmt$recorded_vsn;
    member_internal_vsn: dmt$internal_vsn;
    dm_packet_storage: stt$dm_packet_storage;
    VAR status: ost$status);
*DECK DECK=STP$ADD_MEMBER_VOL_TO_SET EXPAND=FALSE

  PROCEDURE [XREF] stp$add_member_vol_to_set alias 'STAIADD' (
    set_name: stt$set_name;
    requested_member_vol: rmt$recorded_vsn;
    VAR status: ost$status);
*copyc STD$SET_NAME
*copyc RMD$VOLUME_DECLARATIONS
*copyc OST$STATUS
*DECK DECK=STP$ATTACH_VST EXPAND=FALSE

  PROCEDURE [XREF] stp$attach_vst (vsn: rmt$recorded_vsn;
    VAR sfid: dmt$system_file_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$BUILD_FAMILY_LIST_FOR_SET EXPAND=FALSE
  PROCEDURE [XREF] stp$build_family_list_for_set
    (    set_name: stt$set_name;
         activating_during_deadstart: boolean;
         defer_input_queue: boolean;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc std$set_name
*copyc ost$status
?? POP ??
*DECK DECK=STP$BUILD_MEMBER_LIST_LOCATOR EXPAND=FALSE
  PROCEDURE [XREF] stp$build_member_list_locator ALIAS 'stxbmll' (p_member_list: stt$p_member_vsn_list;
           p_vol_set_table: stt$p_vol_set_table;
    VAR member_list_locator: stt$member_list_locator);
?? PUSH (LISTEXT := ON) ??
*copyc STD$VOLUME_SET_TABLE
*copyc STD$LOCATORS
?? POP ??
*DECK DECK=STP$BUILD_MEMBER_LIST_POINTER EXPAND=FALSE
  PROCEDURE [XREF] stp$build_member_list_pointer ALIAS 'stxbmlp' (member_list_locator:
    stt$member_list_locator;
        p_vol_set_table: stt$p_vol_set_table;
    VAR p_member_list: stt$p_member_vsn_list);

?? PUSH (LISTEXT := ON) ??
*copyc STD$LOCATORS
*copyc STD$VOLUME_SET_TABLE
?? POP ??
*DECK DECK=STP$BUILD_MEMBER_VST EXPAND=FALSE

  PROCEDURE [XREF] stp$build_member_vst alias 'STXVFME' (p_member_vst: stt$p_vol_set_table;
    member_vsn: rmt$recorded_vsn;
    member_internal_vsn: dmt$internal_vsn;
    set_name: stt$set_name;
    unique_set_name: stt$unique_set_name;
    master_vol: rmt$recorded_vsn;
    master_internal_vsn: dmt$internal_vsn);
?? PUSH (LISTEXT := ON) ??
*copyc STD$VOLUME_SET_TABLE
*copyc DMT$INTERNAL_VSN
*copyc STD$SET_NAME
*copyc RMD$VOLUME_DECLARATIONS
?? POP ??
*DECK DECK=STP$BUILD_PF_ROOT_LOCATOR EXPAND=FALSE
  PROCEDURE [XREF] stp$build_pf_root_locator ALIAS 'stxbpfl' (p_pf_root: pft$p_root;
    p_vol_set_table: stt$p_vol_set_table;
    VAR pf_root_locator: stt$pf_root_locator);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$ROOT
*copyc STD$LOCATORS
*copyc STD$VOLUME_SET_TABLE
?? POP ??
*DECK DECK=STP$BUILD_PF_ROOT_POINTER EXPAND=FALSE
  PROCEDURE [XREF] stp$build_pf_root_pointer ALIAS 'stxbpfp' (pf_root_locator: stt$pf_root_locator;
        p_vol_set_table: stt$p_vol_set_table;
    VAR p_pf_root: pft$p_root);

?? PUSH (LISTEXT := ON) ??
*copyc PFD$ROOT
*copyc STD$LOCATORS
*copyc STD$VOLUME_SET_TABLE
?? POP ??
*DECK DECK=STP$CHANGE_ACCESS_TO_SET EXPAND=FALSE

  PROCEDURE [XREF] stp$change_access_to_set alias 'STAICAT' (
    set_name: stt$set_name;
    access_status: stt$access_status;
    VAR status: ost$status);
*copyc STD$MISCELLANEOUS
*copyc OST$STATUS
*DECK DECK=STP$CHANGE_AST_ACCESS_STATUS EXPAND=FALSE

  PROCEDURE [XREF] stp$change_ast_access_status ALIAS 'STAACAT' (ast_index:
    stt$ast_index;
    access_status: stt$access_status;
    VAR status: ost$status);
*DECK DECK=STP$CLEAR_AST_PF_LOCK EXPAND=FALSE
  PROCEDURE [XREF] stp$clear_ast_pf_lock ALIAS 'stxcapl' (ast_index:
    stt$ast_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STD$ACTIVE_SET_TABLE
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$CLEAR_EXCLUSIVE_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] stp$clear_exclusive_access alias 'STAMCEA' ;
*DECK DECK=STP$CLEAR_JOB_AST_EXCLUSIVE EXPAND=FALSE


  PROCEDURE [XREF] stp$clear_job_ast_exclusive ALIAS 'STAJCEA';
*DECK DECK=STP$CLEAR_JOB_AST_READ EXPAND=FALSE

  PROCEDURE [XREF] stp$clear_job_ast_read ALIAS 'STAJMCR';
*DECK DECK=STP$CLEAR_PF_LOCK EXPAND=FALSE

  PROCEDURE [XREF] stp$clear_pf_lock {STXCPL} (set_name: stt$set_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STD$SET_NAME
*copyc OST$STATUS
*copyc STE$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=STP$CLEAR_READ_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] stp$clear_read_access ALIAS 'STAMCRA';
*DECK DECK=STP$CLEAR_READ_ACCESS_IN_AST EXPAND=FALSE


  PROCEDURE [XREF] stp$clear_read_access_in_ast (VAR need_to_wait: boolean);
*DECK DECK=STP$CLEAR_ROOT_RECREATED EXPAND=FALSE

  PROCEDURE [XREF] stp$clear_root_recreated (set_name: stt$set_name;
    VAR status: ost$status);
*DECK DECK=STP$CREATE_AST_ENTRY EXPAND=FALSE


  PROCEDURE [XREF] stp$create_ast_entry ALIAS 'STAACRE' (set_name:
    stt$set_name;
    unique_set: stt$unique_set_name;
    master_vol: rmt$recorded_vsn;
    master_internal_vsn: dmt$internal_vsn;
    active_volume_table_index: dmt$active_volume_table_index;
    set_owner: ost$user_identification;
    access_status: stt$access_status;
    dm_packet_storage: stt$dm_packet_storage;
    VAR ast_index: stt$ast_index;
    VAR create_entry_status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc STT$DM_PACKET_STORAGE
*copyc DMT$INTERNAL_VSN
*copyc OST$STATUS
*copyc STD$MISCELLANEOUS
*copyc RMD$VOLUME_DECLARATIONS
*copyc OST$USER_IDENTIFICATION
*copyc PFD$ROOT
?? POP ??
*DECK DECK=STP$CREATE_JAST_ENTRY EXPAND=FALSE


  PROCEDURE [XREF] stp$create_jast_entry ALIAS 'STAJCRE' (required_set:
    stt$set_name;
    unique_set: stt$unique_set_name;
    ast_index: stt$ast_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STD$SET_NAME
*copyc STD$ACTIVE_SET_TABLE
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$CREATE_SET EXPAND=FALSE

  PROCEDURE [XREF] stp$create_set alias 'STAICRE' (requested_set: stt$set_name;
    requested_master_vol: rmt$recorded_vsn;
    requested_set_owner: ost$user_identification;
    access_status: stt$access_status;
    root_recreated: boolean;
    VAR status: ost$status);
*copyc STD$MISCELLANEOUS
*copyc OST$USER_IDENTIFICATION
*copyc RMD$VOLUME_DECLARATIONS
*copyc OST$STATUS
*DECK DECK=STP$CREATE_VST EXPAND=FALSE

  PROCEDURE [XREF] stp$create_vst (vsn: rmt$recorded_vsn;
    VAR vst_sfid: dmt$system_file_id;
    VAR vst_segment_pointer: mmt$segment_pointer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc MMT$ATTRIBUTE_KEYWORD
*copyc RMD$VOLUME_DECLARATIONS
*copyc DMT$SYSTEM_FILE_ID
?? POP ??
*DECK DECK=STP$DEALLOCATE_AST_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] stp$deallocate_ast_entry ALIAS 'STAADEA' (ast_index:
    stt$ast_index;
    VAR status: ost$status);
*DECK DECK=STP$DECREMENT_JOB_USE_IN_AST EXPAND=FALSE

  PROCEDURE [XREF] stp$decrement_job_use_in_ast ALIAS 'STAADEC' (ast_index:
    stt$ast_index);
*DECK DECK=STP$DESTROY_VST EXPAND=FALSE

  PROCEDURE [XREF] stp$destroy_vst (vsn: rmt$recorded_vsn;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$DETACH_VST EXPAND=FALSE

  PROCEDURE [XREF] stp$detach_vst (sfid: dmt$system_file_id;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$DISK_VOLUME_ACTIVE EXPAND=FALSE

  PROCEDURE [XREF] stp$disk_volume_active alias 'STAIVAV' (
    active_vol: rmt$recorded_vsn;
    internal_vsn: dmt$internal_vsn;
    active_volume_table_index: dmt$active_volume_table_index;
    VAR set_name: stt$set_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc DMT$INTERNAL_VSN
*copyc OST$STATUS
*copyc dmt$active_volume_table_index
*copyc std$set_name
*copyc RMD$VOLUME_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$DISK_VOLUME_INACTIVE EXPAND=FALSE

  PROCEDURE [XREF] stp$disk_volume_inactive alias 'STAIVUN' (inactive_vol:
    rmt$recorded_vsn;
    internal_vsn: dmt$internal_vsn;
    set_ordinal: stt$set_ordinal;
    dm_packet: stt$dm_packet {to be defined by dm};
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc STT$SET_ORDINAL
*copyc DMT$INTERNAL_VSN
*copyc STT$DM_PACKET
*copyc OST$STATUS
*copyc RMD$VOLUME_DECLARATIONS
?? POP ??
*DECK DECK=STP$DISPLAY_ALL_SETS EXPAND=FALSE

  PROCEDURE [XREF] stp$display_all_sets
    (VAR display_control: clt$display_control;
     VAR status: ost$status);
*copyc clt$display_control
*copyc ost$status
*DECK DECK=STP$DISPLAY_SETS EXPAND=FALSE

  PROCEDURE [XREF] stp$display_sets
    (VAR display_control: clt$display_control;
     VAR status: ost$status);
*copyc ost$status
*copyc clt$display_control
*DECK DECK=STP$DISPLAY_VOLUME EXPAND=FALSE
  PROCEDURE [XREF] stp$display_volume
    (    volume: rmt$recorded_vsn;
     VAR display_control: clt$display_control;
     VAR status: ost$status);
*copyc ost$status
*copyc rmd$volume_declarations
*copyc clt$display_control
*DECK DECK=STP$DISPLAY_VOL_SET_TABLE EXPAND=FALSE

  PROCEDURE [XREF] stp$display_vol_set_table
    (    volume: rmt$recorded_vsn;
     VAR display_control: clt$display_control;
     VAR status: ost$status);
*copyc ost$status
*copyc rmd$volume_declarations
*copyc clt$display_control
*DECK DECK=STP$DM_CHECK_IF_FILES_ON_VOL EXPAND=FALSE

  PROCEDURE [XREF] stp$dm_check_if_files_on_vol ALIAS 'STXDMFO' (volume:
    rmt$recorded_vsn;
    VAR files_on_vol: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
?? POP ??
*DECK DECK=STP$DM_MOUNT_VOLUME EXPAND=FALSE

  PROCEDURE [XREF] stp$dm_mount_volume ALIAS 'STXDMMO' (volume:
    rmt$recorded_vsn;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$FILL_MASTER_VST EXPAND=FALSE

  PROCEDURE [XREF] stp$fill_master_vst ALIAS 'STAVFMA' (p_master_vst:
    stt$p_vol_set_table;
    master_vsn: rmt$recorded_vsn;
    master_internal_vsn: dmt$internal_vsn;
    set_name: stt$set_name;
    unique_set: stt$unique_set_name;
    set_owner: ost$user_identification;
    dm_packet_storage: stt$dm_packet_storage;
    root_recreated: boolean;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc STD$VOLUME_SET_TABLE
*copyc STT$DM_PACKET_STORAGE
*copyc DMT$INTERNAL_VSN
*copyc STD$SET_NAME
*copyc STD$MISCELLANEOUS
*copyc OST$STATUS
*copyc RMD$VOLUME_DECLARATIONS
?? POP ??
*DECK DECK=STP$GET_ACTIVE_SET_LIST EXPAND=FALSE

  PROCEDURE [XREF] stp$get_active_set_list
    (VAR active_set_list: stt$set_list;
     VAR actual_number_of_sets: stt$number_of_sets);

?? PUSH (LISTEXT := ON) ??
*copyc std$miscellaneous
*copyc stt$set_list
?? POP ??
*DECK DECK=STP$GET_ACTIVE_VOLUME_LIST EXPAND=FALSE
  PROCEDURE [XREF] stp$get_active_volume_list (VAR volume_list:
    stt$volume_list;
    VAR actual_number_of_volumes: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STT$VOLUME_LIST
*copyc OST$STATUS
*copyc RMD$VOLUME_DECLARATIONS
?? POP ??
*DECK DECK=STP$GET_INTERNAL_VOLUMES_SET EXPAND=TRUE
  PROCEDURE [XREF] stp$get_internal_volumes_set (
        volume: dmt$internal_vsn;
    VAR set_name: stt$set_name;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc dmt$internal_vsn
*copyc ost$status
*copyc std$set_name
*copyc ste$error_condition_codes
?? POP ??
*DECK DECK=STP$GET_PF_ROOT EXPAND=FALSE

  PROCEDURE [XREF] stp$get_pf_root
    (    set_name: stt$set_name;
     VAR pf_root_size: pft$root_size;
     VAR pf_root_container: pft$root;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$root
*copyc std$set_name
*copyc ste$error_condition_codes
?? POP ??
*DECK DECK=STP$GET_PF_ROOT_SIZE EXPAND=FALSE

  PROCEDURE [XREF] stp$get_pf_root_size
    (    set_name: stt$set_name;
     VAR pf_root_size: pft$root_size;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$root
*copyc std$set_name
*copyc ste$error_condition_codes
?? POP ??
*DECK DECK=STP$GET_PF_VOLUMES EXPAND=FALSE
  PROCEDURE [XREF] stp$get_pf_volumes (VAR pf_volumes: array [1 .. * ] OF rmt$recorded_vsn;
    VAR number_of_volumes: integer;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc rmd$volume_declarations
*copyc ost$status
?? POP ??
*DECK DECK=STP$GET_ROOT_RECREATED EXPAND=FALSE

  PROCEDURE [XREF] stp$get_root_recreated (set_name: stt$set_name;
    VAR root_recreated: boolean;
    VAR status: ost$status);
*DECK DECK=STP$GET_SETS_ORDINAL EXPAND=FALSE

  PROCEDURE [XREF] stp$get_sets_ordinal (set_name: stt$set_name;
    VAR set_ordinal: stt$set_ordinal;
    VAR master_vol: rmt$recorded_vsn;
    VAR status: ost$status);
*copyc OST$STATUS
*copyc STT$SET_ORDINAL
*copyc RMD$VOLUME_DECLARATIONS
*copyc STD$SET_NAME

*DECK DECK=STP$GET_SET_OWNER EXPAND=FALSE

  PROCEDURE [XREF] stp$get_set_owner alias 'STAIGOW' (set_name: stt$set_name;
    VAR set_owner: ost$user_identification;
    VAR status: ost$status);
*copyc STD$SET_NAME
*copyc OST$USER_IDENTIFICATION
*copyc OST$STATUS
*DECK DECK=STP$GET_UNUSED_ENTRY_IN_AST EXPAND=FALSE

  PROCEDURE [XREF] stp$get_unused_entry_in_ast (VAR ast_index: stt$ast_index;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc STD$ACTIVE_SET_TABLE
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$GET_UNUSED_ENTRY_IN_JAST EXPAND=FALSE

  PROCEDURE [XREF] stp$get_unused_entry_in_jast (VAR jast_index: integer;
    VAR status: ost$status);
?? PSUH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=STP$GET_UNUSED_MEL_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] stp$get_unused_mel_entry (ast_index: stt$ast_index;
    VAR mel_index: stt$mel_index);

?? PUSH (LISTEXT := ON) ??
*copyc STD$ACTIVE_SET_TABLE
?? POP ??
*DECK DECK=STP$GET_VOLUMES_BY_AST_INDEX EXPAND=FALSE

  PROCEDURE [XREF] stp$get_volumes_by_ast_index (set_index: stt$ast_index;
        starting_member_index: stt$number_of_members;
    VAR master_vol: stt$volume_info;
    VAR member_vsn_list: stt$volume_list;
    VAR number_of_members: stt$number_of_members);
?? PUSH (LISTEXT := ON) ??
*copyc STD$ACTIVE_SET_TABLE
*copyc RMD$VOLUME_DECLARATIONS
*copyc STT$VOLUME_LIST
*copyc STT$NUMBER_OF_MEMBERS
?? POP ??
*DECK DECK=STP$GET_VOLUMES_BY_SET_ORDINAL EXPAND=FALSE

  PROCEDURE [XREF] stp$get_volumes_by_set_ordinal (set_ordinal:
    stt$set_ordinal;
    VAR master_vol: stt$volume_info;
    VAR member_vol_list: stt$volume_list;
    VAR actual_number_of_members: stt$number_of_members;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STT$VOLUME_LIST
*copyc STT$NUMBER_OF_MEMBERS
*copyc STD$SET_NAME
*copyc RMD$VOLUME_DECLARATIONS
*copyc STT$SET_ORDINAL
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$GET_VOLUMES_IN_SET EXPAND=FALSE

  PROCEDURE [XREF] stp$get_volumes_in_set (set_name: stt$set_name;
    VAR master_vol: stt$volume_info;
    VAR member_vol_list: stt$volume_list;
    VAR actual_number_of_members: stt$number_of_members;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STT$VOLUME_LIST
*copyc STT$NUMBER_OF_MEMBERS
*copyc STD$SET_NAME
*copyc RMD$VOLUME_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$GET_VOLUMES_SET_NAME EXPAND=FALSE


  PROCEDURE [XREF] stp$get_volumes_set_name (volume: rmt$recorded_vsn;
    VAR set_name: stt$set_name;
    VAR status: ost$status);
*copyc OST$STATUS
*copyc STD$SET_NAME
*copyc RMD$VOLUME_DECLARATIONS
*DECK DECK=STP$INACTIVATE_MASTER EXPAND=FALSE

  PROCEDURE [XREF] stp$inactivate_master ALIAS 'STAAINM' (ast_index:
    stt$ast_index;
    dm_packet_storage: stt$dm_packet_storage;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STD$ACTIVE_SET_TABLE
*copyc STT$DM_PACKET
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$INACTIVATE_MEMBER EXPAND=FALSE

  PROCEDURE [XREF] stp$inactivate_member ALIAS 'STAAINE' (ast_index:
    stt$ast_index;
    inactive_vol: rmt$recorded_vsn;
    internal_vsn: dmt$internal_vsn;
    dm_packet_storage: stt$dm_packet_storage;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STT$DM_PACKET_STORAGE
*copyc DMT$INTERNAL_VSN
*copyc OST$STATUS
*copyc STD$ACTIVE_SET_TABLE
*copyc RMD$VOLUME_DECLARATIONS
?? POP ??
*DECK DECK=STP$INCREMENT_JOB_COUNT_IN_AST EXPAND=FALSE
{*****

  PROCEDURE [XREF] stp$increment_job_count_in_ast ALIAS 'STAAIJ' (ast_index:
    stt$ast_index;
    VAR status: ost$status);
*DECK DECK=STP$INITIALIZE_SETS EXPAND=FALSE

  PROCEDURE [XREF] stp$initialize_sets (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? pop ??
*DECK DECK=STP$INSERT_MEMBER_INTO_MEL EXPAND=FALSE

  PROCEDURE [XREF] stp$insert_member_into_mel alias 'STXAIMM' (ast_index: stt$ast_index;
    mel_index: stt$mel_index;
    member_vol: rmt$recorded_vsn;
    member_internal_vsn: dmt$internal_vsn;
    members_activity: stt$vol_activity_status;
    members_avt_index: dmt$active_volume_table_index;
    dm_packet_storage: stt$dm_packet_storage);

?? PUSH (LISTEXT := ON) ??
*copyc STD$ACTIVE_SET_TABLE
*copyc STT$DM_PACKET_STORAGE
*copyc RMD$VOLUME_DECLARATIONS
*copyc STD$MISCELLANEOUS
?? POP ??
*DECK DECK=STP$IS_VOLUME_IN_SET EXPAND=FALSE

  PROCEDURE [XREF] stp$is_volume_in_set ALIAS 'stxivis' (volume:
    rmt$recorded_vsn;
        set_name: stt$set_name;
    VAR volume_info: stt$volume_info;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc STD$SET_NAME
*copyc STT$VOLUME_INFO
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$MEMBERS_ACTIVE_ON_SET EXPAND=FALSE

  PROCEDURE [XREF] stp$members_active_on_set ALIAS 'STAAMAS' (ast_index:
    stt$ast_index;
    VAR members_active_on_set: boolean);
*DECK DECK=STP$MEMBERS_ON_SET EXPAND=FALSE

  PROCEDURE [XREF] stp$members_on_set ALIAS 'STAAMOS' (ast_index:
    stt$ast_index;
    VAR members_on_set: boolean);
*DECK DECK=STP$OBTAIN_AST_ENTRY EXPAND=FALSE

  PROCEDURE [XREF] stp$obtain_ast_entry alias 'STXAOE' (ast_index: stt$ast_index;
    VAR ast_entry: stt$active_set_entry;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STD$ACTIVE_SET_TABLE
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$OBTAIN_AST_MEMBER_LIST EXPAND=FALSE


  PROCEDURE [XREF] stp$obtain_ast_member_list (ast_index: stt$ast_index;
    VAR ast_member_list: stt$member_entry_list;
    VAR ast_member_entry_list_size: integer);

?? PUSH (LISTEXT := ON) ??
*copyc STD$ACTIVE_SET_TABLE
?? POP ??
*DECK DECK=STP$OBTAIN_AST_PF_ROOT EXPAND=FALSE
  PROCEDURE [XREF] stp$obtain_ast_pf_root ALIAS 'stxoapr' (ast_index:
    stt$ast_index;
    VAR pf_root: pft$root;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STD$ACTIVE_SET_TABLE
*copyc PFD$ROOT
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$OBTAIN_AST_SIZE EXPAND=TRUE
PROCEDURE [xref] stp$obtain_ast_size (var size: integer);
*DECK DECK=STP$OBTAIN_MASTER_VST_INFO EXPAND=FALSE


  PROCEDURE [XREF] stp$obtain_master_vst_info ALIAS 'stxvoma' (p_vol_set_table:
    stt$p_vol_set_table;
    VAR set_owner: ost$user_identification;
    VAR dm_packet_storage: stt$dm_packet_storage;
    VAR member_list: array [ * ] OF stt$member_vsn_entry;
    VAR size_of_member_list: stt$number_of_members;
    VAR pf_root_stored: boolean;
    VAR pf_root_size: pft$root_size;
    VAR pf_root_locator: stt$pf_root_locator);

?? PUSH (LISTEXT := ON) ??
*copyc STD$VOLUME_SET_TABLE
*copyc STT$NUMBER_OF_MEMBERS
*copyc STT$DM_PACKET_STORAGE
*copyc OST$USER_IDENTIFICATION
*copyc PFD$ROOT
?? POP ??
*DECK DECK=STP$OBTAIN_MEMBER_VST_INFO EXPAND=FALSE


  PROCEDURE [XREF] stp$obtain_member_vst_info ALIAS 'stxvome' (p_vol_set_table:
    stt$p_vol_set_table;
    VAR master_vsn: rmt$recorded_vsn;
    VAR master_internal_vsn: dmt$internal_vsn);

?? PUSH (LISTEXT := ON) ??
*copyc STD$VOLUME_SET_TABLE
*copyc DMT$INTERNAL_VSN
*copyc RMD$VOLUME_DECLARATIONS
?? POP ??
*DECK DECK=STP$OBTAIN_VST_HEADER EXPAND=FALSE


  PROCEDURE [XREF] stp$obtain_vst_header ALIAS 'stxvovh' (p_vol_set_table:
    stt$p_vol_set_table;
    VAR volume: rmt$recorded_vsn;
    VAR internal_vsn: dmt$internal_vsn;
    VAR volume_in_set: boolean;
    VAR set_name: stt$set_name;
    VAR unique_set_name: stt$unique_set_name;
    VAR volume_status_in_set: stt$vol_status_in_set);

?? PUSH (LISTEXT := ON) ??
*copyc STD$VOLUME_SET_TABLE
*copyc STD$SET_NAME
*copyc STD$MISCELLANEOUS
*copyc RMD$VOLUME_DECLARATIONS
?? POP ??
*DECK DECK=STP$OBTAIN_VST_PF_ROOT EXPAND=FALSE
  PROCEDURE [XREF] stp$obtain_vst_pf_root ALIAS 'stxovpr' (p_master_vst:
    stt$p_vol_set_table;
    VAR pf_root: pft$root;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STD$VOLUME_SET_TABLE
*copyc PFD$ROOT
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$OPEN_ATTACHED_VST EXPAND=FALSE

  PROCEDURE [XREF] stp$open_attached_vst (vol: rmt$recorded_vsn;
        data_to_be_modified: boolean;
        sfid: dmt$system_file_id;
    VAR segment_pointer: mmt$segment_pointer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc DMT$SYSTEM_FILE_ID
*copyc MMT$ATTRIBUTE_KEYWORD
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$OPEN_VST EXPAND=FALSE

  PROCEDURE [XREF] stp$open_vst (vsn: rmt$recorded_vsn;
        data_to_be_modified: boolean;
    VAR sfid: dmt$system_file_id;
    VAR segment_pointer: mmt$segment_pointer;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc DMT$SYSTEM_FILE_ID
*copyc MMT$ATTRIBUTE_KEYWORD
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$PURGE_AST_PF_ROOT EXPAND=FALSE

  PROCEDURE [XREF] stp$purge_ast_pf_root ALIAS 'stxpapr' (ast_index: stt$ast_index);

?? PUSH (LISTEXT := ON) ??
*copyc STD$ACTIVE_SET_TABLE
?? POP ??
*DECK DECK=STP$PURGE_PF_ROOT EXPAND=FALSE

  PROCEDURE [XREF] stp$purge_pf_root {STXPPR} (set_name: stt$set_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STD$SET_NAME
*copyc OST$STATUS
*copyc STE$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=STP$PURGE_SET EXPAND=FALSE

  PROCEDURE [XREF] stp$purge_set alias 'STAIPUR' (set_name: stt$set_name;
    master_vol: rmt$recorded_vsn;
    VAR status: ost$status);
*copyc STD$SET_NAME
*copyc RMD$VOLUME_DECLARATIONS
*copyc OST$STATUS
*DECK DECK=STP$PURGE_VST_PF_ROOT EXPAND=FALSE

  PROCEDURE [XREF] stp$purge_vst_pf_root ALIAS 'stxpvpr' (master_vsn:
    rmt$recorded_vsn;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$R2_REMOVE_INACTIVE_MEMBER EXPAND=FALSE

PROCEDURE [XREF] stp$r2_remove_inactive_member
     (ast_index: stt$ast_index;
        member_vol: rmt$recorded_vsn;
        master_vol: rmt$recorded_vsn;
       VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc std$set_name
?? POP ??
*DECK DECK=STP$RECOVER_JOBS_SETS EXPAND=FALSE

  PROCEDURE [XREF] stp$recover_jobs_sets (VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??

*DECK DECK=STP$REMOVE_INACTIVE_MEMBERS EXPAND=FALSE

  PROCEDURE [XREF] stp$remove_inactive_members (
     set_name: stt$set_name;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc std$set_name
?? POP ??
*DECK DECK=STP$REMOVE_MEMBER_FROM_MASTER EXPAND=FALSE

  PROCEDURE [XREF] stp$remove_member_from_master alias 'STXVRMM' (member_vol:
    rmt$recorded_vsn;
    p_master_vst: stt$p_vol_set_table;
    VAR status: ost$status);
*DECK DECK=STP$REMOVE_MEMBER_FROM_MEL EXPAND=FALSE

  PROCEDURE [XREF] stp$remove_member_from_mel ALIAS 'STDARME' (member_vol:
    rmt$recorded_vsn;
    ast_index: stt$ast_index;
    VAR status: ost$status);
*DECK DECK=STP$REMOVE_MEMBER_VOL_FROM_SET EXPAND=FALSE

  PROCEDURE [XREF] stp$remove_member_vol_from_set alias 'STAIREM' (
    set_name: stt$set_name;
    member_vol: rmt$recorded_vsn;
    master_vol: rmt$recorded_vsn;
    VAR status: ost$status);
*copyc STD$SET_NAME
*copyc RMD$VOLUME_DECLARATIONS
*copyc OST$STATUS
*DECK DECK=STP$REMOVE_SET_FROM_AST EXPAND=FALSE

  PROCEDURE [XREF] stp$remove_set_from_ast ALIAS 'STAARS' (ast_index:
    stt$ast_index;
    VAR status: ost$status);
*DECK DECK=STP$REMOVE_SET_FROM_JAST EXPAND=FALSE

  PROCEDURE [XREF] stp$remove_set_from_jast (set_name: stt$set_name;
    VAR status: ost$status);

*copyc OST$STATUS
*copyc STD$SET_NAME
*DECK DECK=STP$REMOVE_SET_FROM_VST EXPAND=FALSE

  PROCEDURE [XREF] stp$remove_set_from_vst alias 'STAVRS' (
    p_vst: stt$p_vol_set_table;
    VAR status: ost$status);
*DECK DECK=STP$REQUEST_DM_VOLUME_INFO EXPAND=FALSE

  PROCEDURE [XREF] stp$request_dm_volume_info {STXRDVI} (volume: rmt$recorded_vsn;
    VAR internal_vsn: dmt$internal_vsn;
    VAR volume_owner: ost$user_identification;
    VAR active_volume_table_index: dmt$active_volume_table_index;
    VAR volume_found: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc DMT$INTERNAL_VSN
*copyc OST$USER_IDENTIFICATION
*copyc dmt$active_volume_table_index
?? POP ??
*DECK DECK=STP$RETURN_OPENED_VST EXPAND=FALSE

  PROCEDURE [XREF] stp$return_opened_vst (
    sfid: dmt$system_file_id;
    VAR vst_segment_pointer: mmt$segment_pointer;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc MMT$ATTRIBUTE_KEYWORD
*copyc DMT$SYSTEM_FILE_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$RING2_ADD_MEMBER EXPAND=FALSE


  PROCEDURE [XREF] stp$ring2_add_member alias 'stxiad2' (set_name: stt$set_name;
    member_vol: rmt$recorded_vsn;
    member_internal_vsn: dmt$internal_vsn;
    master_vol: rmt$recorded_vsn;
    members_avt_index: dmt$active_volume_table_index;
    ast_entry: stt$active_set_entry;
    ast_index: stt$ast_index;
    VAR add_member_status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc STD$SET_NAME
*copyc RMD$VOLUME_DECLARATIONS
*copyc STD$ACTIVE_SET_TABLE
*copyc DMT$INTERNAL_VSN
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$RING2_CREATE_SET EXPAND=FALSE

  PROCEDURE [XREF] stp$ring2_create_set ALIAS 'STAICR2' (requested_set:
    stt$set_name;
    requested_master_vol: rmt$recorded_vsn;
    master_internal_vsn: dmt$internal_vsn;
    requested_set_owner: ost$user_identification;
    access_status: stt$access_status;
    active_volume_table_index: dmt$active_volume_table_index;
    root_recreated: boolean;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc STD$SET_NAME
*copyc DMT$INTERNAL_VSN
*copyc RMD$VOLUME_DECLARATIONS
*copyc OST$USER_IDENTIFICATION
*copyc STD$MISCELLANEOUS
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$RING2_PURGE_SET EXPAND=FALSE

  PROCEDURE [XREF] stp$ring2_purge_set ALIAS 'STXIPR2' (set_name: stt$set_name;
    master_vol: rmt$recorded_vsn;
    master_avt_index: dmt$active_volume_table_index;
    ast_index: stt$ast_index;
    ast_entry: stt$active_set_entry;
    VAR status: ost$status);
*DECK DECK=STP$RING2_REMOVE_MEMBER EXPAND=FALSE


  PROCEDURE [XREF] stp$ring2_remove_member (set_name: stt$set_name;
    member_vol: rmt$recorded_vsn;
    master_vol: rmt$recorded_vsn;
    ast_entry: stt$active_set_entry;
    ast_index: stt$ast_index;
    VAR remove_member_status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc STD$SET_NAME
*copyc RMD$VOLUME_DECLARATIONS
*copyc STD$ACTIVE_SET_TABLE
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$SEARCH_AST_BY_INTERNAL_VSN EXPAND=TRUE

  PROCEDURE [XREF] stp$search_ast_by_internal_vsn    (volume: dmt$internal_vsn;
    VAR ast_entry: stt$active_set_entry;
    VAR ast_index: stt$ast_index;
    VAR volume_found: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc dmt$internal_vsn
*copyc std$active_set_table
?? POP ??
*DECK DECK=STP$SEARCH_AST_BY_SET EXPAND=FALSE

  PROCEDURE [XREF] stp$search_ast_by_set
    (    set_name_key: stt$set_name;
     VAR found_ast_entry: stt$active_set_entry;
     VAR found_ast_index: stt$ast_index;
     VAR set_key_found: boolean);


?? PUSH (LISTEXT := ON) ??
*copyc std$active_set_table
*copyc std$set_name
?? POP ??
*DECK DECK=STP$SEARCH_AST_BY_UNIQUE_SET EXPAND=FALSE

  PROCEDURE [XREF] stp$search_ast_by_unique_set ALIAS 'STAASBU'
    (unique_set_key: stt$unique_set_name;
    VAR found_ast_entry: stt$active_set_entry;
    VAR found_ast_index: stt$ast_index;
    VAR set_key_found: boolean);

*copyc STD$MISCELLANEOUS
*DECK DECK=STP$SEARCH_AST_BY_VOLUME EXPAND=FALSE


  PROCEDURE [XREF] stp$search_ast_by_volume (volume: rmt$recorded_vsn;
    VAR ast_entry: stt$active_set_entry;
    VAR ast_index: stt$ast_index;
    VAR volume_found: boolean);
*copyc RMD$VOLUME_DECLARATIONS
*copyc STD$ACTIVE_SET_TABLE
*DECK DECK=STP$SEARCH_JAST_FOR_SET EXPAND=FALSE

  PROCEDURE [XREF] stp$search_jast_for_set ALIAS 'STAJSFS' (required_set:
    stt$set_name;
    VAR jacs_entry: stt$job_active_set_entry;
    VAR set_found: boolean);

*DECK DECK=STP$SEARCH_JAST_FOR_UNIQUE_SET EXPAND=FALSE

  PROCEDURE [XREF] stp$search_jast_for_unique_set (required_set:
    stt$unique_set_name;
    VAR jacs_entry: stt$job_active_set_entry;
    VAR set_found: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc STD$JOB_ACTIVE_SET_TABLE
*copyc STD$SET_NAME
?? POP ??
*DECK DECK=STP$SEARCH_JAST_FOR_UNUSED EXPAND=FALSE

  PROCEDURE [XREF] stp$search_jast_for_unused ALIAS 'STAJSFU' (stv$p_jast:
    stt$p_job_active_set_table;
    VAR jast_index: integer;
    VAR unused_found: boolean);
*DECK DECK=STP$SEARCH_MEL_FOR_VOL EXPAND=FALSE

  PROCEDURE [XREF] stp$search_mel_for_vol ALIAS 'STAASME' (member_vol:
    rmt$recorded_vsn;
    ast_index: stt$ast_index;
    VAR member_entry: stt$member_entry;
    VAR mel_index: stt$mel_index;
    VAR vol_found: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc STD$ACTIVE_SET_TABLE
?? POP ??
*DECK DECK=STP$SEARCH_MVL_FOR_VOL EXPAND=FALSE


  PROCEDURE [XREF] stp$search_mvl_for_vol alias 'STAVSFV' (
    member_vol: rmt$recorded_vsn;
    p_mvl: stt$p_member_vsn_list;
    VAR mvl_index: stt$mvl_index;
    VAR vol_found: boolean);
*DECK DECK=STP$SET_AST_PF_LOCK EXPAND=FALSE
  PROCEDURE [XREF] stp$set_ast_pf_lock ALIAS 'stxsapl' (ast_index:
    stt$ast_index;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STD$ACTIVE_SET_TABLE
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$SET_END_JOB EXPAND=FALSE

  PROCEDURE [XREF] stp$set_end_job alias 'STAISEJ' (VAR status: ost$status);
*copyc OST$STATUS
*DECK DECK=STP$SET_EXCLUSIVE_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] stp$set_exclusive_access alias 'STAMSEA';

*DECK DECK=STP$SET_JOB_AST_EXCLUSIVE EXPAND=FALSE

  PROCEDURE [XREF] stp$set_job_ast_exclusive ALIAS 'STAJMSE';
*DECK DECK=STP$SET_JOB_AST_READ EXPAND=FALSE

  PROCEDURE [XREF] stp$set_job_ast_read ALIAS 'STAJSRA';
*DECK DECK=STP$SET_PF_LOCK EXPAND=FALSE

  PROCEDURE [XREF] stp$set_pf_lock {STXSPL} (set_name: stt$set_name;
        wait: ost$wait;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STD$SET_NAME
*copyc OST$WAIT
*copyc OST$STATUS
*copyc STE$ERROR_CONDITION_CODES
?? POP ??
*DECK DECK=STP$SET_READ_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] stp$set_read_access ALIAS 'STAMSRA';
*DECK DECK=STP$SET_READ_ACCESS_IN_AST EXPAND=FALSE


  PROCEDURE [XREF] stp$set_read_access_in_ast (VAR need_to_wait: boolean);
*DECK DECK=STP$STORE_AST_MASTER_HEADER EXPAND=FALSE


  PROCEDURE [XREF] stp$store_ast_master_header alias 'STXASMH' (ast_index:
    stt$ast_index;
    masters_avt_index: dmt$active_volume_table_index;
    set_owner: ost$user_identification;
    dm_packet_storage: stt$dm_packet_storage;
    pf_root_stored: boolean;
    pf_root: pft$root;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STD$ACTIVE_SET_TABLE
*copyc STT$DM_PACKET_STORAGE
*copyc OST$STATUS
*copyc OST$USER_IDENTIFICATION
*copyc PFD$ROOT
?? POP ??
*DECK DECK=STP$STORE_AST_PF_ROOT EXPAND=FALSE
  PROCEDURE [XREF] stp$store_ast_pf_root ALIAS 'stxsapr' (ast_index:
    stt$ast_index;
        pf_root: pft$root;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STD$ACTIVE_SET_TABLE
*copyc PFD$ROOT
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$STORE_DM_PACKET_IN_MASTER EXPAND=FALSE


  PROCEDURE [XREF] stp$store_dm_packet_in_master ALIAS 'stxvstp' (master_vsn: rmt$recorded_vsn;
    inactive_member: rmt$recorded_vsn;
    new_dm_packet_storage: stt$dm_packet_storage;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc STT$DM_PACKET_STORAGE
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$STORE_DM_PACKET_IN_MEL EXPAND=FALSE


  PROCEDURE [XREF] stp$store_dm_packet_in_mel ALIAS 'stxasdp'
    (ast_index: stt$ast_index;
        mel_index: stt$mel_index;
        dm_packet_storage: stt$dm_packet_storage);

?? PUSH (LISTEXT := ON) ??
*copyc STD$ACTIVE_SET_TABLE
*copyc STT$DM_PACKET_STORAGE
?? POP ??
*DECK DECK=STP$STORE_DM_PACKET_IN_MVL EXPAND=FALSE


  PROCEDURE [XREF] stp$store_dm_packet_in_mvl alias 'STXVSPE' (p_member_vsn_list:
    stt$p_member_vsn_list;
    mvl_index: stt$mvl_index;
    dm_packet_storage: stt$dm_packet_storage);

?? PUSH (LISTEXT := ON) ??
*copyc STD$VOLUME_SET_TABLE
*copyc STT$DM_PACKET_STORAGE
?? POP ??
*DECK DECK=STP$STORE_INACTIVE_MASTER EXPAND=FALSE

  PROCEDURE [XREF] stp$store_inactive_master alias 'STXASIM' (set_name: stt$set_name;
    unique_set_name: stt$unique_set_name;
    master_vsn: rmt$recorded_vsn;
    internal_vsn:dmt$internal_vsn;
    access_status: stt$access_status;
    ast_index: stt$ast_index);

?? PUSH (LISTEXT := ON) ??
*copyc STD$SET_NAME
*copyc RMD$VOLUME_DECLARATIONS
*copyc STD$ACTIVE_SET_TABLE
?? POP ??
*DECK DECK=STP$STORE_MASTER_DM_PACKET EXPAND=FALSE

  PROCEDURE [XREF] stp$store_master_dm_packet alias 'STXVSMP' (
    p_master_vst: stt$p_vol_set_table;
    dm_packet_storage: stt$dm_packet_storage);

?? PUSH (LISTEXT := ON) ??
*copyc STD$VOLUME_SET_TABLE
*copyc STT$DM_PACKET_STORAGE
?? POP ??
*DECK DECK=STP$STORE_MEMBER_DM_PACKET EXPAND=FALSE

  PROCEDURE [XREF] stp$store_member_dm_packet ALIAS 'stxvsmd'
    (p_master_vst: stt$p_vol_set_table;
        inactive_member: rmt$recorded_vsn;
        dm_packet_storage: stt$dm_packet_storage;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc STD$VOLUME_SET_TABLE
*copyc RMD$VOLUME_DECLARATIONS
*copyc STT$DM_PACKET_STORAGE
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$STORE_PF_ROOT EXPAND=FALSE

  PROCEDURE [XREF] stp$store_pf_root
    (    set_name: stt$set_name;
         pf_root: pft$root;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc pfd$root
*copyc std$set_name
*copyc ste$error_condition_codes
?? POP ??
*DECK DECK=STP$STORE_VST_BEING_MODIFIED EXPAND=FALSE

  PROCEDURE [XREF] stp$store_vst_being_modified ALIAS 'stxsvbm' (p_vst:
    stt$p_vol_set_table;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc STD$VOLUME_SET_TABLE
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$STORE_VST_PF_ROOT EXPAND=FALSE
  PROCEDURE [XREF] stp$store_vst_pf_root ALIAS 'stxsvpr' (master_vsn:
    rmt$recorded_vsn;
        pf_root: pft$root;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc PFD$ROOT
*copyc OST$STATUS
?? POP ??
*DECK DECK=STP$TRANSLATE_SET_ORDINAL EXPAND=FALSE

  PROCEDURE [XREF] stp$translate_set_ordinal alias 'STXIGKV' (set_ordinal:
    stt$set_ordinal;
    VAR set_name: stt$set_name;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc STT$SET_ORDINAL
*copyc STD$SET_NAME
?? POP ??
*DECK DECK=STP$UPDATE_SYSTEM_SET_NAME EXPAND=FALSE
PROCEDURE [XREF] stp$update_system_set_name (set_name: stt$set_name);
*copyc std$set_name
*DECK DECK=STP$VALIDATE_OWNER EXPAND=FALSE


  PROCEDURE [XREF] stp$validate_owner alias 'STAEOWN' (
    owner: ost$user_identification;
    VAR valid_owner: boolean);
*DECK DECK=STP$VALIDATE_RECORDED_VSN EXPAND=FALSE

  PROCEDURE [XREF] stp$validate_recorded_vsn alias 'STAPVOV' (recorded_vsn:
    rmt$recorded_vsn;
    VAR converted_recorded_vsn: rmt$recorded_vsn;
    VAR status: ost$status);
*copyc RMD$VOLUME_DECLARATIONS
*DECK DECK=STP$VALID_ACCESS_STATUS EXPAND=FALSE

  FUNCTION [XREF] stp$valid_access_status alias 'STAPAS' (
    access_status: stt$access_status): boolean;
*DECK DECK=STP$VERIFY_ALL_VOLUMES_ACTIVE EXPAND=FALSE
 PROCEDURE [XREF] stp$verify_all_volumes_active (set_name: stt$set_name;
   VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc std$set_name
*copyc ost$status
?? POP ??
*DECK DECK=STT$DM_PACKET EXPAND=FALSE

{deck is STDMPAK  -- to be defined by device management
{ THIS MUST BE FIXED SIZE - NO ADAPTABLES }

  TYPE
    stt$dm_packet = integer;
*DECK DECK=STT$DM_PACKET_STORAGE EXPAND=FALSE

  TYPE
    stt$dm_packet_storage = record
      case dm_packet_ever_stored: boolean of
      = TRUE =
        dm_packet: stt$dm_packet,
      = FALSE =
        ,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc STT$DM_PACKET
?? POP ??
*DECK DECK=STT$NUMBER_OF_MEMBERS EXPAND=FALSE

  {deck is STDNMEM }
  TYPE
    stt$number_of_members = 0 .. stc$max_num_members_on_set;

*copyc STC$MAX_NUM_MEMBERS_ON_SET
*DECK DECK=STT$SET_LIST EXPAND=FALSE

  {deck is STDLIST }
  TYPE
    stt$set_list = array [stc$array_lowerbound .. * ] of stt$set_name;

*copyc STD$SET_NAME
*copyc STC$ARRAY_LOWERBOUND
*DECK DECK=STT$SET_ORDINAL EXPAND=FALSE

  {deck is STDORD }
  TYPE
    stt$set_ordinal = record
      case entry_type: stt$entry_type of
      = stc$unused =
        ,
      = stc$valid =
        unique_set_name: stt$unique_set_name,
      casend,
    recend;

*copyc STD$SET_NAME
*copyc STD$MISCELLANEOUS
*DECK DECK=STT$VOLUME_ACTIVITY_DESCRIPTOR EXPAND=FALSE

  TYPE
    stt$volume_activity_descriptor = record
      case volume_activity_status: stt$vol_activity_status of
      = stc$active =
        avt_index: dmt$active_volume_table_index,
      = stc$inactive =
        ,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc dmt$active_volume_table_index
*copyc STD$MISCELLANEOUS
?? POP ??
*DECK DECK=STT$VOLUME_INFO EXPAND=FALSE

  TYPE
    stt$volume_info = record
      recorded_vsn: rmt$recorded_vsn,
      internal_vsn: dmt$internal_vsn,
      setname: stt$set_name,
      volume_activity: stt$volume_activity_descriptor,
      dm_packet_storage: stt$dm_packet_storage,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc RMD$VOLUME_DECLARATIONS
*copyc DMT$INTERNAL_VSN
*copyc STD$SET_NAME
*copyc STT$VOLUME_ACTIVITY_DESCRIPTOR
*copyc STT$DM_PACKET_STORAGE
?? POP ??
*DECK DECK=STT$VOLUME_LIST EXPAND=FALSE

  {deck is STDVLST }
  TYPE
    stt$volume_list = array [stc$array_lowerbound .. * ] of stt$volume_info;

*copyc RMD$VOLUME_DECLARATIONS
*copyc STT$VOLUME_INFO
*copyc STC$ARRAY_LOWERBOUND
*copyc STD$MISCELLANEOUS
*DECK DECK=STV$P_AST EXPAND=FALSE


  VAR
    stv$p_ast: [XREF] stt$p_active_set_table;

*DECK DECK=STV$P_JAST EXPAND=FALSE

*copyc STD$JOB_ACTIVE_SET_TABLE

  VAR
    stv$p_jast: [XREF] stt$p_job_active_set_table;
*DECK DECK=STV$SYSTEM_SET_NAME EXPAND=FALSE
VAR
  stv$system_set_name: [XREF] stt$set_name;
?? PUSH (LISTEXT := ON) ??
*copyc std$set_name
?? POP ??
*DECK DECK=SUN EXPAND=TRUE
          IDENT  SUN,111B
          TITLE  SUN - SET USER NUMBER FOR SYOT JOBS.
          ABS
          SST
          SYSCOM B1
          ENTRY  SUN
          ENTRY  VAL=
          ENTRY  RFL=
          ENTRY  SSJ=
          SPACE  4,10
***       SUN - SET USER NUMBER.
*
*         B. R. HANSON       82/10/29.
          SPACE  4,10
***              *SUN* CHANGES THE CURRENT CATALOG TO THE CATALOG
*         FOR THE SPECIFIED USER.  THIS WORKS EQUIVALENT TO THE
*         *USER* CARD EXCEPT THAT THE PASSWORD IS NOT NEEDED AND
*         THIS CONTROL STATEMENT MAY ONLY BE USED FROM SYSTEM ORIGIN.
          SPACE  4,10
***       CALL.
*
*         SUN(USERNAME)
*
*         USERNAME  DESIRED USER NAME.
          SPACE  4,10
OPL XTEXT COMCMAC
OPL XTEXT COMSSSJ
OPL XTEXT COMSPRD
          EJECT
**        SUN.
*


          ORG    111B
SUN       SB1    1
          MOVE   3,(SSJ=+ALMS),SAVE
          GETJO  ORIGIN
          SA1    ORIGIN
          SX2    SYOT
          BX3    X1-X2
          NZ     X3,ABORT    IF NOT SYOT
          SA1    ARGR        GET UN
          MX0    42
          BX6    X1*X0
          SA6    PBLOCK
          VALID  PBLOCK
          MOVE   3,SAVE,(SSJ=+ALMS)
*
* MOVE VALIDATION INFO TO SSJ BLOCK
*
          SA2    PBLOCK
          BX7    X2
          SA7    SSJ=+UIDS
 DONE     ENDRUN

 ABORT    MESSAGE (=C*ILLEGAL USER ACCESS.*)
          ABORT
          SPACE  4,10
 ORIGIN   BSS    1
 SAVE     BSS    3
 PBLOCK   CON    0
          CON    1           DO NOT CHECK PW
          BSSZ   8
          SPACE  4,10
OPL XTEXT COMCCPM
OPL XTEXT COMCSYS
OPL XTEXT COMCMVE
          SPACE  4,10
VAL=      EQU    0
SSJ=      VFD    12/0,24/0,12/PRCS,12/0
          BSSZ   SSJL-1
          SPACE  4,10
RFL=      END
*DECK DECK=SYA$CONSTANTS EXPAND=FALSE
................ begin common deck SYA$CONSTANTS ........................
.
.
.
.  Define constants for sizes of CYBIL tables - OS tables whose
.       sizes must be known by assembly language modules. Unless
.       otherwise stated, the sizes given here can be larger than
.       the actual size.
.
.    **** WARNING - (xcbsize + jstlen*8 + jrootsiz) must be <= 2048
.           It must fix in a page else the ST may not be in contiguous memory.
.
xcbsize  equ      1024            .Size of XCB.
sdtxsize equ      48              .Size of SDTX entry.
statsize equ      280             .Size of OST$STATUS.
ajllen   equ      255             .Max number of AJL entries - this constant
.                                  is used to set the size of the monitor
.                                  seg tbl. The actual size of the AJL can
.                                  be less than or equal to this value.
jrootsiz   equ      256          .Length of JMT$JOB_CONTROL_BLOCK
.
.
.
.
.   Define monitor constants
.
mstksize  equ      6700          .Length of monitor stack
mstkfram  equ      32            .Length of monitor stack frame - this
.                                 constant is also used to calculate where A0
.                                 in the monitor XP should point during
.                                 reinstatement of CPU 0; if it changes, the
.                                 corresponding value of the constant
.                                 MTC$MONITOR_STACK_FRAME_LENGTH in the module
.                                 MTM$PROCESSOR_CONFIGURATION_MGR must also
.                                 change
jstksiz1  equ      1024           .Length of job stack for ring 1
jstksiz2  equ      2048          .Length of job stack for ring 2
jstksiz3  equ      512          .Length of job stack for ring 3
jstkfram  equ      32            .Length of job stack frame
jstlen    equ      94            .Number of segments in Job Segtll
mstlen    equ      20            .Number of segments in Monitor Segtll
a170_stl  equ      19            . Number of segments in a170 seg table
.
.
.   Define 'magic' segment numbers. These equates MUST agree with
.   the actual segment numbers assigned during system generation.
.   WARNING: in most cases, no run time checks are made to see if
.   the constants defined here are correct.
.
snptmtr   equ      0             .Page table seg num in monitor.
sn170mcb  equ      2             .170 segment number with cache bypass attribute.
snnosmtr  equ      3             .NOS segment number in MTR mode.
snsfmtr   equ      4             .NOS stack segment number in MTR mode.
snnthmtr  equ      5             .Nos trap handler segment number in MTR mode.
.
snjfjob   equ      3             .Job fixed in job mode.
.
.   Define a170 segment numbers for NOS, EI and EIE.
.
snnos170  equ    3           .Nos segment number
snsf170   equ    4           .NOS stack segment number
snnth170  equ    5           .Nos trap handler segment number
.
.
.   Define operating system constants
.
.
.
m_mtrmsk  equ      0fffc(16)     .Monitor mode MM
j_mtrmsk  equ      0fffc(16)     .Job mode MM
m_usrmsk  equ      0ff7f(16)     .Monitor mode UM
j_usrmsk  equ      0ff77(16)     .Job mode UM
m_usrabt  equ      0edff(16)     .Fatal UCR conditions, monitor
j_usrabt  equ      0cc00(16)     .Fatal UCR conditions, job
m_mcrhlt  equ      05b2c(16)     .MCR conditions that cause halt, monitor.
j_mcrhlt  equ      0e000(16)     .MCR conditions that cause halt, job.
m_mcrasy  equ      00490(16)     .MCR conditions that are asynchronous.
j_mcrusr  equ      01b0c(16)     .MCR conditions that are normally
.                                 processed by the job trap handler.
m_mcrsw   equ      02000(16)     .MCR condition: short_warning
m_mcrtef  equ      04000(16)     .MCR mask bit: traps_enabled
.
.
.   Define offsets for referencing fields in the job table segments
.
jr_mxcb   equ       jrootsiz       .XCB for Job Monitor.

.
.    PROC Definitions for initializing exchange packages
.
          PROC
xpareg    pname
          do  sn:(f:(2,2))=sn:(nil)
            org  f:(2,0)+f:(2,1)*8+10
            vfd,16,32  0ffff(16),080000000(16)
          else
            org   f:(2,0)+f:(2,1)*8+10
            address  r,f:(2,2)+f:(2,3)
          dend
          PEND
          PROC
xpa       pname
          do  sn:(f:(2,2))=sn:(nil)
            org  f:(2,0)+f:(2,1)
            vfd,16,32  0ffff(16),080000000(16)
          else
            org   f:(2,0)+f:(2,1)
            address  r,f:(2,2)+f:(2,3)
          dend
          PEND
          PROC
xpv       pname
          org   f:(2,0)+f:(2,1)
          vfd,f:(2,3) f:(2,2)
          PEND
.
................ end common deck SYA$CONSTANTS ..........................
*DECK DECK=SYA$CYBIL_INTERFACE_PROCEDURES EXPAND=FALSE
.............. begin common deck SYA$CYBIL_INTERFACE_PROCEDURES .........................
          proc
procedur  pname
xxxploc   set       0,0,0,0
          align     0,8
f:(0,0)   bss       0
          def       f:(0,0)
          pend
.
         proc
function pname
         do       sn:(f:(2,0))=sn:(integer)
xxxploc    set    0,1,1,8
yyyploc    set    0
         else
           do     sn:(f:(2,0))=sn:(subrange)
xxxploc      set  0,1,3,f:(2,1)
yyyploc      set  0
           else
             do   sn:(f:(2,0))=sn:(boolean)
xxxploc        set 0,1,4,1
yyyploc        set 0
             else
               do  sn:(f:(2,0))=sn:(pointer)
xxxploc          set 0,1,2,6
yyyploc          set 1
               else
               flag fatal  .unknown return type
               dend
             dend
           dend
         dend
         align    0,8
f:(0,0)  bss      0
         def      f:(0,0)
         pend
.
         proc
freturnx pname
          do     xxxploc[1]=1
          do     yyyploc=0
            do   #regtyp[f:(2,0)]=#xreg
              do   f:(2,0)=15
                return
              else
                cpyxx  xf,f:(2,0)
              dend
            else
              flag fatal       .Incorrect register usage
            dend
          else
            do   #regtyp[f:(2,0)]=#areg
              do f:(2,0)=15
                return
              else
                cpyaa  af,f:(2,0)
              dend
            else
              cpyxa     af,f:(2,0)
            dend
          dend
          return
          else
            flag fatal       .not in a function
          dend
         pend
.
          proc
param     pname
          local  data_t,param_t,param_l,field_l,offset
param_l   set    0
offset    set    0
          do     sn:(f:(2,1))=sn:(integer)
data_t    set    1
field_l   set    8
          dend
          do     sn:(f:(2,1))=sn:(pointer)
data_t    set    2
field_l   set    6
offset    set    2
          dend
          do     sn:(f:(2,1))=sn:(subrange)
data_t    set    3
field_l   set    f:(2,2)[0]
offset    set    8-f:(2,2)[0]
          dend
          do     sn:(f:(2,1))=sn:(boolean)
data_t    set    4
field_l   set    1
offset    set    7
          dend
          do     sn:(f:(2,1))=sn:(string)
            do     f:(2,2)<=8
data_t    set    5
field_l   set    f:(2,2)[0]
offset    set    8-f:(2,2)[0]
            dend
            do     f:(2,2)>8
data_t    set    6
field_l   set    6
param_l   set    f:(2,2)[0]
            dend
          dend
           do     sn:(f:(2,1))=sn:(astring)
data_t    set    7
field_l   set    8
          dend
.
          do     sn:(f:(2,0))=sn:(ref)
            do     data_t<=5
param_t   set    1
param_l   set    field_l
field_l   set    6
offset    set    0
            dend
          else
param_t   set    2
          dend
.
f:(0,0)   set    xxxploc[0]+offset,data_t,param_t,field_l,param_l
xxxploc[0]  set    xxxploc[0]+8
          pend
.
.
          proc
ploada    pname
          do     f:(2,1)[1]=6
f:(0,0)   la     f:(2,0),a_plist,f:(2,1)[0]
          else
            do     f:(2,1)[2]=1
              do     f:(2,1)[1]=2
f:(0,0)       la     amacsr,a_plist,f:(2,1)[0]
              la     f:(2,0),amacsr,0
              else
f:(0,0)         la     f:(2,0),a_plist,f:(2,1)[0]
              dend
            else
              do     f:(2,1)[1]=2
f:(0,0)       la     f:(2,0),a_plist,f:(2,1)[0]
              else
                flag  fatal    .Wrong macro usage
              dend
            dend
          dend
          pend
.
.
          proc
ploadx    pname
          do     f:(2,1)[1]=2
          flag   fatal       .Wrong macro usage
          else
            do     f:(2,1)[1]=6
            flag   fatal     .Wrong macro usage
            else
              do     f:(2,1)[1]=7
              flag   fatal    .Wrong macro usage
              dend
            dend
          dend
          do     f:(2,1)[2]=1
f:(0,0)   la     amacsr,a_plist,f:(2,1)[0]
          lbyts,f:(2,1)[4]  f:(2,0),amacsr,x0,0
          else
f:(0,0)   lbyts,f:(2,1)[3]  f:(2,0),a_plist,x0,f:(2,1)[0]
          dend
          pend
.
.    PSTRING  This macro is used only for adaptable strings.
.
          proc
pstring   pname
          do     f:(2,2)[1]=7
f:(0,0)   la     f:(2,0),a_plist,f:(2,2)[0]
          lbyts,2  f:(2,1),a_plist,x0,f:(2,2)[0]+6
          else
            flag   fatal    .Wrong macro usage
          dend
          pend
.
.
          proc
pstorxp   pname
          do        f:(2,1)[2]=1
f:(0,0)     la      amacscr,a_plist,f:(2,1)[0]
            sbyts,f:(2,1)[4]  f:(2,0),amacscr,x0,0
          else
            flag    fatal  .must be pointer type
          dend
          pend
.
          proc
pstorap   pname
          do        f:(2,1)[1]=2
            do f:(2,1)[4]=6
f:(0,0)       la    amacscr,a_plist,f:(2,1)[0]
              sa    f:(2,0),amacscr,0
            else
              flag   fatal  .param length must be 6
             dend
          else
            flag    fatal  .must be pointer type
          dend
          pend
.
................end common deck SYA$CYBIL_INTERFACE_PROCEDURES ..........................
*DECK DECK=SYA$DCTL_ASSEMBLY_CONSTANTS EXPAND=FALSE
.
.  SYADCTL - This deck defines the offsets to fields in the system core
.            debug control record. WARNING - the definitions in this deck
.            MUST  agree with the definitions in the CYBIL deck SYDDCTL.
.
dbactive equ      0                 .Non zero if debug is active.
dbring   equ      1                 .Highest ring for giving control to
.                                    system debug.
dbdlp    equ      2                 .Debug list pointer.
dbproc   equ      8                 .Pointer to debug trap procedure.
.
*DECK DECK=SYA$ISSUE_KEYPOINTS_IN_HANDLERS EXPAND=FALSE
.
.         The purpose of this procedure is to issue keypoints within the trap handlers.
.         A keypoint is not issued if the keypoint flag is set in the UCR.
.
.         Procedure calling sequence:
.           keypt  k_class,k_code,k_data,xr_ucr,xs_1
.                    K_CLASS - This parameter specifies the keypoint class.
.                    K_CODE - This parameter specifies the keypoint code.
.                    K_DATA - This parameter specifies the keypoint data, must
.                        be an X register.
.                    XR_UCR - This parameter is an X register containing the UCR.
.                    XS_1 - This parameter specifies a scratch X register to be used in
.                         this procedure, can not be X0.
.
.         NOTE:
.           If 'K_DATA' is register X0, the data is assumed to be zeros.
.           XS_1 is the only register that is destroyed.
.
          PROC
keypt     pname
.         list     3,2,1
          local    k_class,k_code,k_data,xr_ucr,xs_1
          local    kpl10
k_class   set      f:(2,0)
k_code    set      f:(2,1)
k_data    set      f:(2,2)
k_data    atrib    #regtyp,#xreg
xr_ucr    set      f:(2,3)
xr_ucr    atrib    #regtyp,#xreg
xs_1      set      f:(2,4)
xs_1      atrib    #regtyp,#xreg
          isob     xs_1,xr_ucr,x0,6600(8)   .Keypoint flag from UCR
          brrne    xs_1,x0,kpl10       .If entered to record keypoint
          shfx     xs_1,k_data,x0,13
          keypoint k_class,xs_1,k_code
          brcr     6,4,kpl10           .Clear UCR keypoint bit
kpl10     bss      0
.         list     1,2,1
          pend
*DECK DECK=SYA$MONITOR_FLAG_HANDLERS EXPAND=FALSE
.
.  SYAMFHA - This common deck defines the job mode system core
.      procedures for processing monitor flags. To add new flag handlers,
.      an entry must be made in this deck to specify the name of the
.      procedure to be called to process the flag.
.      * * * note - definitions in this deck must agree with the
.                   flag numbers defined in SYT$MONITOR_FLAG.
.
bs_mfhan  bss      0
          address  ce,mflg1
          address  ce,mflg2
          address  ce,mflg3
          address  ce,mflg4
          address  ce,mflg5
          address  ce,mflg6
          address  ce,mflg7
          address  ce,mflg8
          address  ce,mflg9
          address  ce,mflg10
          address  ce,mflg1      . Note: Dummy - Flag not in use
          address  ce,mflg1      . Note: Dummy - Flag not in use
          address  ce,mflg1      . Note: Dummy - Flag not in use
          address  ce,mflg1      . Note: Dummy - Flag not in use
          address  ce,mflg1      . Note: Dummy - Flag not in use
.
          ref      mflg1,mflg2,mflg3,mflg4,mflg5,mflg6,mflg7,mflg8,mflg9
          ref      mflg10
mflg1     alias    SYP$MFH_FOR_HANG_TASK
mflg2     alias    SYP$MFH_FOR_JOB_RECOVERY
mflg3     alias    MMP$MFH_VOLUME_UNAVAILABLE
mflg4     alias    SYP$MFH_TO_INVOKE_SYSDEBUG
mflg5     alias    SYP$MFH_FOR_SYSTEM_DEBUG
mflg6     alias    SYP$MFH_FOR_DUMP_JOB
mflg7     alias    MMP$MFH_FOR_SEGMENT_MANAGER
mflg8     alias    SYP$MFH_CPU_CONFIG_CHANGE
mflg9     alias    MMP$MFH_SHADOW_FILE_REFERENCE
mflg10    alias    SYP$MFH_FOR_KEYPOINT_TRACEBACK
.
mfbc      equ      2        .Length of monitor flag field (in bytes)
.
mfring1    equ      0DE60(16)    .Define mask for determining which flag will
.                            preempt ring 1 execution and be processed
.                            immediately. (4000=flg1, 2000=flg2, etc)
*DECK DECK=SYA$XP_AND_SF_CONSTANTS EXPAND=FALSE

.
.
.   Hardware defined constants for indexing and referencing an exchange
.   package or stack frame.
.

sfsa_mcr  equ      48            .Offset to MCR in Stk Frame Save Area
sfsa_ucr  equ      40            .Offset to UCR in Stk Frame Save Area
xpsize    equ      416           .Exchange package size (bytes)
xptp      equ      282           .XP offset to Trap Pointer
xpdlp     equ      290           .XP offset to Debug list pointer.
xpstau    equ      272           .XP offset to seg Table Adr upper
xpstal    equ      280           .XP offset to seg Table Adr lower
xpdebugi  equ      288           .XP offset to debug index.
xpdebugm  equ      289           .XP offset to debug mask.
xputp     equ      274           .XP offset to UTP
xpflgte   equ      16            .XP offset to FLAGS and TE
xpmcr     equ      48            .XP offset to MCR field
xpucr     equ      40            .XP offset to UCR field
xp170mf   equ      43            .XP offset to byte containing 170 mtr flag
xpvmid    equ      8             .XP offset to VMID field
xpfdesc   equ      16            .XP offset to SFSA frame descriptor.
xpcff     equ      16            .XP offset to CFF flag.
xpstl     equ      128           .XP offset to Seg Table Len
xpum      equ      24            .XP offset to User Mask
xpmm      equ      32            .XP offset to Monitor Mask
xpkm      equ      64            .XP offset to Keypoint Mask
xppit     equ      88            .XP offset to PIT (upper)
xpbc1     equ      104           .XP offset to Base Constant (upper)
xpbc2     equ      112           .XP offset to Base Constant (lower)
xplrn     equ      296           .XP offset to LRN
xpxregs   equ      136           .XP offset to first X register
xptos     equ      298           .XP offset to Top of Stack

.  Define constants for MCR and UCR mask bits.

m_mcrsit  equ      00010(16)     .MCR masks
m_mcrexs  equ      00090(16)     .EXT INT and SIT
m_mcrhdw  equ      0a000(16)     .DUE and SHORT WARNING
m_mcrsrw  equ      02000(16)
m_mcrdue  equ      08000(16)
m_mcrei   equ      00080(16)
m_mcrexc  equ      00400(16)
m_mcrpf   equ      00040(16)
m_mcrmcl  equ      00020(16)
m_mcrsel  equ      00002(16)
m_mcrtrx  equ      00001(16)
m_mcrelt  equ      00003(16)     .SOFT ERROR LOG and TRAP EXCEPTION.

m_ucrff   equ      02000(16)
m_ucrcff  equ      00400(16)
m_ucrkp   equ      00200(16)
m_ucrdb   equ      00080(16)

.  Define constants for accessing processor state registers.

r_eid     equ      010(16)       .Element id
r_pid     equ      011(16)       .Processor id
r_pta     equ      048(16)       .Page table address.
r_ptl     equ      049(16)       .Page table length.
r_psm     equ      04a(16)       .Page size mask.
r_te      equ      0c2(16)       .Trap enable
r_td      equ      0c0(16)       .Trap disabled
r_ted     equ      0c3(16)       .Trap enable delay
r_cff_c   equ      0e0(16)       .Critical frame flag
r_jps     equ      061(16)       .Job Process State
r_sit     equ      062(16)       .System Interval Timer
r_pit     equ      0c9(16)       .Process interval timer.
r_stl     equ      045(16)       .Segment Table Length
r_mcr     equ      042(16)       .Monitor condition register
r_bc      equ      047(16)       .Base constant.
r_kef0    equ      0ca(16)       .Keypoint enable flag - clear.
r_kef1    equ      0cb(16)       .Keypoint enable flag - set.
r_di      equ      0e4(16)       .Debug index.
r_dmr     equ      0e5(16)       .Debug mask register.
r_um      equ      0e6(16)       .User mask.
r_mm      equ      060(16)       .Monitor mask.
r_tp      equ      0c4(16)       .trap pointer.
r_dlp     equ      0c5(16)       .Debug list pointer.
*DECK DECK=SYC$COMPASS_OS_LEVELS EXPAND=FALSE
.  This constant defines the psr level of the operating system with respect to DFT.
.  This has to be changed when the levels change.

dft_psr  equ       780

.
.***  End common deck SYC$COMPASS_OS_LEVELS
*DECK DECK=SYC$COPYRIGHT EXPAND=TRUE

  CONST
*PUT '    syc$copyright_message = ''Copyright Control Data Systems Inc. '//$STRING($NOW.YEAR)//''';'
*DECK DECK=SYC$HARDWARE_FAULT_CODES EXPAND=FALSE

{  Define the codes for the kinds of hardware faults that can be injected
{  and some utility functions to condition the job environment.  If new
{  kinds of hardware faults are added they should be added before
{  'syc$hfk_uf_null_function'.  SYC$HFK_UF_NULL_FUNCTION separates the
{  hardware fault kinds from utility functions.

  CONST
    syc$hfk_retry = 0,
    syc$hfk_exchange = 1,
    syc$hfk_trap = 2,
    syc$hfk_halt = 3,
    syc$hfk_pdm_halt = 4,
    syc$hfk_software_error = 5,

{  Define separator between last hardware fault kind and utility functions.

    syc$hfk_uf_null_function = 6,

{  Utility function to clear synchrnous bits in monitor mask of caller's
{  exchange package.

    syc$hfk_uf_clear_sync_in_mm = syc$hfk_uf_null_function + 1,
          {  Clear synchrnous bits in callers monitor mask.
    syc$hfk_uf_max_value = 0ff(16),

{  Define value of last hardware fault kind.

    syc$hfk_max_hardware_fault_kind = syc$hfk_uf_null_function - 1;

*DECK DECK=SYC$JOB_RECOVERY_ENABLED EXPAND=FALSE
CONST
  syc$jre_enabled = 0,

  syc$jre_command_disabled = 3,

  syc$jre_recovery_complete = 4,

  syc$jre_prior_ds_disabled = 5,
  syc$jre_no_image = 6,
  syc$jre_different_system = 7,
  syc$jre_page_size_mismatch = 8,

  syc$jre_system_disabled =9;

*DECK DECK=SYC$JOB_RECOVERY_FLAG EXPAND=FALSE
*DECK DECK=SYC$MIN_ECC_CONSTANTS EXPAND=FALSE
{Define base values for System Core error code ranges.

  CONST
    syc$system_core_id = 'SY',
    syc$min_ecc = (($INTEGER ('S') * 100(16)) + $INTEGER ('Y')) * 1000000(16),
    syc$min_ecc_keypoints = syc$min_ecc + 9000,
    syc$min_ecc_commands = syc$min_ecc + 9100,
    syc$min_ecc_job_recovery = syc$min_ecc + 9200,
    syc$min_ecc_job_template = syc$min_ecc + 9300,
    syc$min_ecc_system = syc$min_ecc + 9400;
*DECK DECK=SYC$MONITOR_REQUEST_CODES EXPAND=FALSE

{  This common deck defines monitor request codes.
{
{  NOTE: Unused request codes have 'unimplemented' as part of the name, when
{  defining a new code these codes should be used first.

  TYPE
    syt$monitor_request_code = 0 .. 255;


  CONST


{  NOTE: Any changes to this common deck will require a change to
{        the static array 'request_id' in procedure 'format_system_mr_data'
{        in module 'clm$display_system_data' in deck CLMDSS.
{        The dump procedure in deck dum$create_monitor_func_file  should
{        also be changed.  If syc$rc_maximum_value is changed then deck
{         dum$display_active_tasks should be changed to reflect this value.

    syc$rc_maximum_value = 86;  {*** See note above ****


  CONST
    syc$rc_cycle = 1,
    syc$rc_delay = 2,
    syc$rc_unused_request_3 = 3,
    syc$rc_device_io = 4,
    syc$rc_advise_in = 5,
    syc$rc_advise_out = 6,
    syc$rc_advise_out_in = 7,
    syc$rc_initiate_task = 8,
    syc$rc_page_fault = 9,                {Monitor use only}
    syc$rc_initiate_job = 10,
    syc$rc_exit_job = 11,
    syc$rc_free_pages = 12,
    syc$rc_write_modified_pages = 13,
    syc$rc_change_segment_table = 14,
    syc$rc_check_active_pps = 15,         {Monitor use only}
    syc$rc_unused_request_16 = 16,
    syc$rc_unused_request_17 = 17,
    syc$rc_job_swapping_functions = 18,
    syc$rc_idle_system = 19,
    syc$rc_mcr_ucr_fault = 20,            {Monitor use only}
    syc$rc_system_error = 21,
    syc$rc_fetch_task_statistics = 22,
    syc$rc_unused_request_23 = 23,
    syc$rc_unused_request_24 = 24,
    syc$rc_ready_task = 25,
    syc$rc_set_system_flag = 26,
    syc$rc_wait = 27,
    syc$rc_lock_ring_1_stack = 28,
    syc$rc_mtr_send_signal = 29,
    syc$rc_set_get_segment_length = 30,
    syc$rc_memory_manager_io = 31,
    syc$rc_job_recovery_requests = 32,
    syc$rc_ring1_segment_request = 33,
    syc$rc_task_exit = 34,
    syc$rc_unused_request_35 = 35,
    syc$rc_update_job_task_enviro = 36,
    syc$rc_segment_request = 37,
    syc$rc_lock_pages = 38,
    syc$rc_unlock_pages = 39,
    syc$rc_fetch_pva_unwritten_pgs = 40,
    syc$rc_allocate_front_end = 41,
    syc$rc_deallocate_front_end = 42,
    syc$rc_apply_mat_changes = 43,
    syc$rc_tape_io = 44,
    syc$rc_translate_byte_address = 45,
    syc$rc_config_mgmt_request = 46,
    syc$rc_manage_system_tasks = 47,
    syc$rc_lock_unlock_segment = 48,
    syc$rc_issue_dft_request = 49,
    syc$rc_wait_io_completion = 50,
    syc$rc_switch_task = 51,              {Monitor use only}
    syc$rc_process_short_warning = 52,    {Monitor use only}
    syc$rc_monitor_system_status = 53,    {Monitor use only}
    syc$rc_process_io_completions = 54,   {Monitor use only}
    syc$rc_update_system_display = 55,
    syc$rc_process_scd_block = 56,       {Monitor use only}
    syc$rc_keypoint = 57,
    syc$rc_periodic_call = 58,           {Monitor use only}
    syc$rc_process_due = 59,             {Monitor use only}
    syc$rc_unused_request_60 = 60,
    syc$rc_swap_job = 61,                {Monitor use only}
    syc$rc_monitor_mode_ei = 62,         {Monitor use only}
    syc$rc_unused_request_63 = 63,
    syc$rc_subsystem_request = 64,
    syc$rc_logging_request = 65,
    syc$rc_process_dft_block = 66,       {Monitor use only}
    syc$rc_job_scheduler_request = 67,
    syc$rc_fetch_offset_mod_pages = 68,
    syc$rc_assign_pages = 69,
    syc$rc_conditional_free = 70,
    syc$rc_queue_rhfam_request = 71,
    syc$rc_unused_request_72 = 72,
    syc$rc_file_server_request = 73,
    syc$rc_move_pages = 74,
    syc$rc_assign_contig_memory = 75,
    syc$rc_reallocate_front_end = 76,
    syc$rc_ring1_server_seg_request = 77,
    syc$rc_monitor_cpu_self_state = 78,   {Monitor use only}
    syc$rc_stats_facility_request = 79,
    syc$rc_system_deadstart_status = 80,
    syc$rc_service_class_statistics = 81,
    syc$rc_unused_request_82 = 82,
    syc$rc_unused_request_83 = 83,
    syc$rc_unused_request_84 = 84,
    syc$inject_hardware_fault = 85,
    syc$quick_sweep = 86;
*DECK DECK=SYC$MONITOR_SEGMENT_NUMBERS EXPAND=FALSE

{  Define the segments numbers of the fixed segments in monitor's
{  address space.  Some of the segment numbers are the same in both
{  monitor and job address spaces.

  CONST
    syc$msn_page_table = 0,
    syc$msn_mainframe_wired = osc$segnum_mainframe_wired,
    syc$msn_cyber_170_cache_bypass = 2,
    syc$msn_cyber_170 = 3,
    syc$msn_system_status_record = 4,
    syc$msn_network_wired = 7,
    syc$msn_mainframe_wired_cb = 12(16); {  Mainframe wired cache bypass.

*copyc ost$heap
*DECK DECK=SYC$SSR_SYSTEM_LEVEL_NUMBER EXPAND=FALSE

{
{     Define the constants for the system level number stored in the
{  SYSL entry in the SSR.  This level number is used to verify that
{  the boot and system core levels match.
{
{     NOTE: The constant for the released system level number should
{  be updated when each new system is released or an incompatability
{  between CIP and system core is introduced.  Released systems should
{  have the BCU level number equal to zero.  The BCU level number
{  should be incremented when a BCU is created that causes an incompatability
{  between CIP and the system core.  CIP refers mainly to the NOS/VE
{  components on the CIP tape.
{
{     NOTE: When updating the level number in this deck it also has to be updated
{  in decks dsm$system_status_record, syc$compass_os_levels, and cti$compass_os_levels.
{

  CONST
    syc$ssln_released_level_number = 780,
    syc$ssln_bcu_level_number = 0;
*DECK DECK=SYC$SYSTEM_CORE_COND_CONSTANTS EXPAND=FALSE

 CONST
    syc$ucr_condition = 0,
    syc$user_defined_condition = 1;
*DECK DECK=SYC$TEST_JR_CONSTANTS EXPAND=FALSE
{ Deck:  SYC$TEST_JR_CONSTANTS
 TYPE
    syt$test_jr_set = SET OF 0 .. 255;

 CONST
    { Job scope - cleared at the start of job recovery
    syc$tjr_recursive_recovery = 1,
    syc$tjr_fail_prior_jfr = 2,
    syc$tjr_fail_post_jfr = 3,
    syc$tjr_replace_sfid = 4,
    syc$tjr_touch_unrec_segment = 5,
    { File server has 150 .. 199
    { File system has 200 .. 255
    syc$tjr_job_last_unused = 255;

  CONST
    { System scope - cleared at every deadstart
    syc$tjr_mtr_idle = 1,
    syc$tjr_mtr_mvamjws = 2,
    syc$tjr_mtr_rit = 3,
    syc$tjr_mtr_mamtam = 4,
    syc$tjr_mtr_asfd = 5,
    syc$tjr_mtr_soio = 6,
    syc$tjr_mtr_siio = 7,
    syc$tjr_mtr_fsjmmr = 8,
    syc$tjr_mtr_cpfsi = 9,
    syc$tjr_mtr_rsjmmt = 10,
    syc$tjr_swapped_page_freed = 12,
    syc$tjr_crash_in_dmwrite = 13,
    syc$tjr_crash_in_dmread = 14,
    { File server has 150 .. 199
    { File system has 200 .. 255
    syc$tjr_sys_last_unused = 255;

{*copyc pfc$test_jr_constants
{*copyc dfc$test_jr_constants
*DECK DECK=SYE$COMMAND_PROCESSOR_ERRORS EXPAND=FALSE
*copyc SYC$MIN_ECC_CONSTANTS
?? NEWTITLE := 'SYDERRC : SYSTEM CORE COMMAND PROCESSOR', EJECT ??

?? FMT (FORMAT := OFF) ??
  CONST
    sye$syntax_error = syc$min_ecc_commands + 0,
    {F Syntax error.}

    sye$invalid_character = syc$min_ecc_commands + 1,
    {F Invalid character}

    sye$token_too_long = syc$min_ecc_commands + 2,
    {F Token is too long.}

    sye$missing_parameter = syc$min_ecc_commands + 3,
    {F Required parameter is missing.}

    sye$range_error = syc$min_ecc_commands + 4,
    {F Integer is not within the allowable range of values.}

    sye$unknown_command = syc$min_ecc_commands + 5,
    {F Unknown command name}

    sye$bad_pdt = syc$min_ecc_commands + 6,
    {F Invalid PDT}

    sye$unknown_parameter_name = syc$min_ecc_commands + 7,
    {E +P}

    sye$access_restricted_to_sys_jb = syc$min_ecc_commands + 8,
    {E Variable access restricted to sys job}

    sye$not_changeable_after_ds = syc$min_ecc_commands + 9,
    {E Variable not changeable after ds complete}

    sye$rmt_restricted_to_sys_job = syc$min_ecc_commands + 10;
    {E You must have system administration or configuration administration
    { capability to change the reset_maximum_time parameter.}

??FMT (FORMAT := ON)??
?? OLDTITLE ??

*DECK DECK=SYE$CONDITION_CODES EXPAND=FALSE
*copyc sye$job_recovery_conditions
*copyc sye$command_processor_errors
*copyc sye$job_template_conditions
*DECK DECK=SYE$JOB_RECOVERY_CONDITIONS EXPAND=FALSE
??push(listext:=on)??
*copyc syc$min_ecc_constants
??pop??
CONST
      sye$job_recovery_disabled = syc$min_ecc_job_recovery + 0,
  {F Recovery of active jobs has been disabled - no jobs will be recovered.}

      sye$job_page_count_zero = syc$min_ecc_job_recovery + 1,
  {F Job page count is zero - job not recovered.}

      sye$bad_ijl_entry = syc$min_ecc_job_recovery + 2,
  {F Invalid ijl ordinal from jcb - job not recovered.}

      sye$ijl_entry_not_free = syc$min_ecc_job_recovery + 3,
  {F Ijl entry status is not free - job not recovered.}

      sye$too_many_tasks_in_job = syc$min_ecc_job_recovery + 7,
  {F The job contains too many tasks - job not recovered.}

      sye$utask_gtid_bad = syc$min_ecc_job_recovery + 8,
  {F A user task global task id is invalid - job not recovered.}

      sye$utask_in_ring_1 = syc$min_ecc_job_recovery + 9,
  {F A user task is in ring 1 - job not recovered.}

      sye$utask_traps_disabled = syc$min_ecc_job_recovery + 10,
  {F A user task has traps disabled - job not recovered.}

      sye$no_tasks_in_job = syc$min_ecc_job_recovery + 11,
  {F No tasks were found in the job - job not recovered.}

      sye$jsn_not_found_in_ijl = syc$min_ecc_job_recovery + 12,
  {F The specified jsn could not be found in the ijl - job not recovered.}

      sye$ijl_entry_free = syc$min_ecc_job_recovery + 13,
  {F The ijl entry for the specified jsn is free - job not recovered.}

      sye$ijl_non_swap = syc$min_ecc_job_recovery + 14,
  {F The ijl entry for the specified jsn is not swappable - job not recovered.}

      sye$ijl_entry_status_bad = syc$min_ecc_job_recovery + 15,
  {F The ijl entry status for the specified jsn does not allow recovery - job not recovered.}

      sye$ajlo_from_ijl_bad = syc$min_ecc_job_recovery + 16,
  {F The ajl ordinal from the ijl for the specified jsn is invalid - job not recovered.}

      sye$ajle_not_in_use = syc$min_ecc_job_recovery + 17,
  {F The ajl entry for the specified jsn is not in use - job not recovered.}

      sye$ajl_ijlo_no_match = syc$min_ecc_job_recovery + 18,
  {F The ijl ordinal from the ajl is not correct - job not recovered.}

      sye$ajl_ijlep_no_match = syc$min_ecc_job_recovery + 19,
  {F The ijl pointer from the ajl is not correct - job not recovered.}

      sye$ajl_js_not_xqt = syc$min_ecc_job_recovery + 20,
  {F The ajl job status does not allow recovery - job not recovered.}

      sye$too_many_pages_in_pft = syc$min_ecc_job_recovery + 21,
  {F There are too many pages in the job page queue list as compared to the pft - job not recovered.}

      sye$pfi_too_big = syc$min_ecc_job_recovery + 22,
  {F A page frame index from the job page queue list is invalid.}

      sye$pft_ijlo_no_match = syc$min_ecc_job_recovery + 23,
  {F The ijl ordinal from a pft entry is invalid.}

      sye$aste_not_in_use = syc$min_ecc_job_recovery + 24,
  {F The ast entry referenced by a pft entry is not in use - job not recovered.}

      sye$aste_ijlo_no_match = syc$min_ecc_job_recovery + 25,
  {F The ijl ordinal from the ast entry referenced by a pft entry is invalid - job not recovered.}

      sye$too_few_pages_in_pft = syc$min_ecc_job_recovery + 26,
  {F Too few pages were found in the pft for this job - job not recovered.}

      sye$jcb_jsn_no_match = syc$min_ecc_job_recovery + 28,
  {F The jsn from the jcb does not match the current jsn - job not recovered.}

      sye$jcb_ijlo_no_match = syc$min_ecc_job_recovery + 29,
  {F The ijl ordinal from the jcb does not match the current ijl ordinal - job not recovered.}

      sye$no_image_available = syc$min_ecc_job_recovery + 30,
  {W No image file is available - no jobs will be recovered.}

      sye$page_size_mismatch = syc$min_ecc_job_recovery + 31,
  {F The old and current page sizes are not the same - job recovery is disabled.}

      sye$ijl_offset_error = syc$min_ecc_job_recovery + 32,
  {F The old ijl pointer is not valid - job recovery disabled.}

      sye$ajl_offset_error = syc$min_ecc_job_recovery + 33,
  {F The old ajl pointer is not valid - job recovery disabled.}

      sye$pft_offset_error = syc$min_ecc_job_recovery + 34,
  {F The old pft pointer is not valid - job recovery disabled.}

      sye$ptl_offset_error = syc$min_ecc_job_recovery + 35,
  {F The old ptl pointer is not valid - job recovery disabled.}

      sye$pql_offset_error = syc$min_ecc_job_recovery + 36,
  {F The old pql pointer is not valid - job recovery disabled.}

      sye$jmtr_task_index_too_big = syc$min_ecc_job_recovery + 37,
  {F The job monitor task global task id is invalid - job not recovered.}

      sye$utask_sys_tbl_lock_cnt = syc$min_ecc_job_recovery + 38,
  {F A user task has system tables locked - job not recovered.}

      sye$condition_encountered = syc$min_ecc_job_recovery + 39,
  {F An unrecoverable condition was encountered while in ring 1.}

      sye$job_damaged = syc$min_ecc_job_recovery + 40,
  {F The job was marked as damaged during a previous recovery - job not recovered.}

      sye$swapout_in_progress = syc$min_ecc_job_recovery + 41,
  {F The job was being swapped out at the time of failure - job not recovered.}

      sye$job_fixed_pc_mismatch = syc$min_ecc_job_recovery + 42,
  {F The count of job fixed pages did not agree with system tables - job not recovered.}

      sye$job_recovery_inhibited = syc$min_ecc_job_recovery + 43,
  {F The job had inhibited recovery at the time of the system failure - job not recovered.}

      sye$open_segs_not_recovered = syc$min_ecc_job_recovery + 44,
  {F The job had at least one open segment whose file could not be recovered - job terminated.}

      sye$rec_with_different_system = syc$min_ecc_job_recovery + 45,
  {F A recovery is being performed with a different system than was most recently up - no jobs recovered.}

      sye$task_had_system_errors = syc$min_ecc_job_recovery + 46,
  {F A task within a job had a non zero system error count - job not recovered.}

      sye$task_inhibited_recovery = syc$min_ecc_job_recovery + 47,
  {F A task within a job has inhibited recovery of the job.}

      sye$last_recovery_not_jr = syc$min_ecc_job_recovery + 49,
  {F A previous deadstart was done without job recovery - job recovery not possible.}

      sye$job_terminated = syc$min_ecc_job_recovery + 50,
  {F The job had previously been terminated via command - job not recovered.}


      sye$volume_missing = syc$min_ecc_job_recovery + 51,
  {F One or more volumes in use by the job are missing - job not recovered.}

      sye$critical_task = syc$min_ecc_job_recovery + 52,
  {F A task within a job is a critical task - job not recovered.}

      sye$recovery_class_not_defined = syc$min_ecc_job_recovery + 53,
  {F Job not recovered (job class not defined): +P.}

      sye$recovery_swap_io_error = syc$min_ecc_job_recovery + 54,
  {F Job not recovered (io error on swapin): +P.}

      sye$unable_to_locate_jcb = syc$min_ecc_job_recovery + 55,
  {F The JCB of the job was not located - job not recovered.}

      sye$not_nosve_template = syc$min_ecc_job_recovery + 56,
  {F The job was not executing the NOS/VE template - job not recovered.}

      sye$job_using_server_files = syc$min_ecc_job_recovery + 57,
   {F The job is using +P1 server file(s) - job not recovered.}

      sye$bad_swap_file_descriptor = syc$min_ecc_job_recovery + 58;
  {F Corrupted data was found in the swap file descriptor of the job - job not recovered.}


*DECK DECK=SYE$JOB_TEMPLATE_CONDITIONS EXPAND=FALSE
??push(listext:=on)??
*copyc syc$min_ecc_constants
??pop??
CONST
      sye$not_enough_classes = syc$min_ecc_job_template + 0,
  {F At least one job class must be specified.}

      sye$duplicate_template_name = syc$min_ecc_job_template + 1,
  {F Job template name +P1 is already in use.}

      sye$duplicate_class_definition = syc$min_ecc_job_template + 2,
  {F Job template +P1 is already defined for class +P2.}

      sye$job_template_table_full = syc$min_ecc_job_template + 3,
  {F The maximum number of job templates are currently active.}

      sye$template_core_mismatch = syc$min_ecc_job_template + 4,
  {F The job template does not match the running system.}

      sye$template_core_dup_segs = syc$min_ecc_job_template + 5,
  {F The job template has segments that already exist in the system core.}

      sye$template_not_found = syc$min_ecc_job_template + 6,
  {F Job template not found.}

      sye$job_class_limit_not_zero = syc$min_ecc_job_template + 7,
  {F The job class limit for all job classes using a template must be zero.}

      sye$jobs_still_active = syc$min_ecc_job_template + 8,
  {F There are active jobs for one or more of the job classes using the template.}

      sye$template_condition = syc$min_ecc_job_template + 9;
  {F An unrecoverable condition was encountered while in ring 1.}
*DECK DECK=SYE$SYSTEM_CONDITIONS EXPAND=FALSE

??push(listext:=on)??
*copyc syc$min_ecc_constants
??pop??
CONST
      sye$unimplemented_request = syc$min_ecc_system + 0;
  {F The request is not implemented.}


*DECK DECK=SYH$ADVISED_MOVE_BYTES EXPAND=FALSE
{
{   This procedure will move the specified number of bytes from the given
{ source pva to the given destination pva.  The pages are advised in before the
{ move and advised out afterwards.
{   This procedure will page align the source with the first advise in.
{ The destination is page aligned on the first advise out.
{
{   SYP$ADVISED_MOVE_BYTES (source, destination, length, status)
{
{ SOURCE: (INPUT) This parameter specifies the source PVA.
{
{ DESTINATION: (INPUT) This parameter specifies the destination PVA.
{
{ LENGTH: (INPUT) This parameter specifies the number of bytes to be moved.
{
{ STATUS: (OUTPUT) This parameter specifies the request status.
{
*DECK DECK=SYH$ENABLE_JOB_FREE_FLAG EXPAND=FALSE
{
{   The purpose of this request is to set the job free flag in the
{ monitor flags.
{
{       SYP$ENABLE_JOB_FREE_FLAG
{
*DECK DECK=SYH$GET_SYSTEM_TASK_STATUS EXPAND=FALSE
{
{ This request is used by a system task to determine if it should terminate because
{ of system idle-down or operator command.  This procedure is used by system tasks
{ that will voluntarily idle or terminate.
{
{     SYP$GET_SYSTEM_TASK_STATUS (TASK_STATUS);
{
{ TASK_STATUS: (output) This parameter specifies whether the task
{ should terminate or idle.  Values of this parameter are:
{     sys$sts_ok ............................. task can continue running
{     syc$sts_idle_down_in_progress .......... task should idle
{     syc$sts_deactivate_requested ........... task deactivated via DEACTIVATE_SYSTEM_TASK (DEAST)
{
*DECK DECK=SYH$RETURN_JOBS_R1_RESOURCES EXPAND=FALSE
{
{   The purpose of this procedure is to return the last of the job resources
{ during job termination.
{
{        SYP$RETURN_JOBS_R1_RESOURCES;
{
{ NOTE: This procedure is the last job mode procedure to execute during
{        job termination.  Control is not returned from this procedure.
{

*DECK DECK=SYH$WAIT EXPAND=FALSE

{
{   The purpose of this request is to relinquish control of the system
{ for the specified number of milliseconds or until an event occurs.
{
{       SYP$WAIT (MILLISECONDS)
{
{ MILLISECONDS: (input) This parameter specifies the wait time.
{
*DECK DECK=SYH$WAIT_SYSTEM_RESUME EXPAND=FALSE
{
{ This request is used by system tasks that voluntarily idle during system
{ idle-down.
{ This request will suspend task execution until the system is resumed
{ (restart after
{ IDLE).  If no idle-down is active, this procedure returns immediately.  This
{ request
{ also causes the system job monitor to be notified that the task is in an
{ IDLE state
{ and that system idle-down does not need to wait for the task.
{
{     SYP$WAIT_SYSTEM_RESUME;
{
{     (no parameters)
{
*DECK DECK=SYK$RETURN_JOBS_R1_RESOURCES EXPAND=FALSE


{  Define keypoint codes for system modules.

  CONST
    syk$return_jobs_r1_resources = syk$job_base + 0;
      {D 'Final stage of job end, ring 1' }

*copyc AMK$BASE_KEYPOINT_VALUES
*DECK DECK=SYM$ADVISED_MOVE_BYTES EXPAND=TRUE
MODULE sym$advised_move_bytes;
?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc i#move
*copyc mmp$advise_in
*copyc mmp$advise_out
*copyc mmp$advise_out_in
*copyc mmp$get_page_size
?? POP ??

{ PURPOSE:
{   This procedure will move the specified number of bytes from the given
{   source to the given destination.  The pages are advised in before the
{   move and advised out afterwards.
{ DESIGN:
{   This procedure will page align the source with the first advise in.
{   The destination is page aligned on the first advise out.
{

  PROCEDURE [XDCL, #GATE] syp$advised_move_bytes (source: ^cell;
        destination: ^cell;
        length: integer;
    VAR status: ost$status);

    VAR
      advise_size: integer,
      current: integer,
      from_byte_offset: integer,
      from_ptr: ^cell,
      move: integer,
      next_from_ptr: ^cell,
      next_to_ptr: ^cell,
      page_size: integer,
      to_bytes_left: integer,
      to_byte_offset: integer,
      to_out_bytes: integer,
      to_out_ptr: ^cell,
      to_ptr: ^cell;

    status.normal := TRUE;
    from_ptr := source;
    to_ptr := destination;
    advise_size := 131072;
    mmp$get_page_size (page_size);

{ Page align source on first advise in.

    from_byte_offset := #OFFSET (from_ptr) MOD  page_size;
    move := page_size - from_byte_offset;
    IF move > length THEN
      move := length;
    IFEND;

{ Page align destination on first advise out.

    to_byte_offset := #OFFSET (to_ptr) MOD page_size;
    to_bytes_left := page_size - to_byte_offset;
    IF move > to_bytes_left THEN
      to_out_bytes := to_bytes_left;
      to_bytes_left := page_size - move + to_bytes_left;
    ELSEIF move < to_bytes_left THEN
      to_out_bytes := 0;
      to_bytes_left := to_bytes_left - move;
    ELSE
      to_out_bytes := move;
      to_bytes_left := 0;
    IFEND;
    to_out_ptr := to_ptr;

    mmp$advise_in (from_ptr, move, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    current := 0;
    WHILE current < length DO
      I#MOVE (from_ptr, to_ptr, move);
      next_from_ptr := #ADDRESS (#RING (from_ptr), #SEGMENT (from_ptr), #OFFSET
            (from_ptr) + move);
      next_to_ptr := #ADDRESS (#RING (to_ptr), #SEGMENT (to_ptr), #OFFSET
            (to_ptr) + move);
      current := current + move;

{ This condition will typically be true twice, once to set advise_size to the
{ remaining portion of the length and then once to set advise_size to zero.  The
{ exception will be when the final portion is full size.

      IF (current + advise_size) > length THEN
        advise_size := length - current;

{ Adjust the final byte counts for the destination.

        IF advise_size = 0 THEN
          to_out_bytes := #OFFSET (next_to_ptr) - #OFFSET (to_out_ptr);
        IFEND;

      IFEND;

      mmp$advise_out_in (from_ptr, move, next_from_ptr, advise_size, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      mmp$advise_out (to_out_ptr, to_out_bytes, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      from_ptr := next_from_ptr;
      to_ptr := next_to_ptr;
      to_out_ptr := #ADDRESS (#RING (to_ptr), #SEGMENT (to_ptr), #OFFSET
            (to_out_ptr) + to_out_bytes);
      to_out_bytes := advise_size;
      move := advise_size;

    WHILEND;

  PROCEND syp$advised_move_bytes;
MODEND sym$advised_move_bytes;
*DECK DECK=SYM$ASCII_CONSOLE_INPUT_OUTPUT EXPAND=TRUE
*DECK DECK=SYM$BOOT EXPAND=TRUE
*DECK DECK=SYM$CAUSE_HARDWARE_FAULTS EXPAND=TRUE
sym$cause_hardware_faults ident

. PURPOSE:
.   This module contains the procedures for causing hardware faults.

         list    0,0,0
*copy osa$cybil_interface
*copy osa$basic_register_equates
         list    1,2,1

. Define register equates used by the Cybil interface macros.
.

amacscr  equ       15        .scratch a reg used by macros
amacscr  atrib     #regtyp,#areg

          use    code
          page
. PURPOSE:
.   This procedure causes the actual hardware fault by issuing the
.   unimplemented instructions.  If not running with the special microcode this
.   task aborts with an unimplemented instruction.
.
. DESIGN:
.   Special microcode is required that actually causes the desired hardware fault.
.   The special microcode recoginizes specific unimplemented instructions that are
.   issued and dependent on the J K fields causes a specific fault.  The J field
.   specifies the kind of hardware fault and the K field specifies an X register
.   that contains the RMA of a word in memory with a parity error.  This word in
.   memory has to be preconditioned with a parity error before IPL.
.
. PROCEDURE [XREF] syp$cause_hardware_faults
.   (    hardware_fault_kind: syt$hardware_fault_kind;
.        rma_of_parity_error: integer;
.    VAR known_fault_kind: boolean);

chf      alias   SYP$CAUSE_HARDWARE_FAULTS
chf      procedur
hfk      param   val,subrange,1        .hardware fault kind.
rmaope   param   val,integer           .RMA of parity error.
khfk     param   ref,boolean           .known hardware fault kind.

         ploadx  xe,hfk                .kind of hardware fault to cause.
         ente    xc,chfpl              .jump table length.
         ploadx  xf,rmaope             .RMA of parity error.
         shfc    xe,xe,x0,1            .(jump table index)/2.
         entp    xb,0                  .set unknown hardware fault kind.
         brrgt   xe,xc,chf5            .if unknown hardware fault kind.
         entp    xb,1                  .set known hardware fault kind.
chf5     bss     0
         pstorxp   xb,khfk             .return known hardware fault kind.
         brrgt   xb,x0,chf10           .if known hardware fault kind.
         return

chf10    bss     0
         addpxq  af,xe,chfp            .address in jump table to process
                                       . hardware fault kind.
         brdir   af,x0                 .cause specified hardware fault.


.        Define a jump table for each hardware fault kind to cause.

chfp     bss     0
         brreq   x0,x0,retry           .cause successful retry.
         brreq   x0,x0,exchange        .cause exchange fault.
         brreq   x0,x0,trap            .cause trap fault.
         brreq   x0,x0,halt            .cause halt fault.
         brreq   x0,x0,pdm_halt        .cause pdm halt fault.
         brreq   x0,x0,swerr           .software error, error stop.
chfpl    equ     $-chfp                .length of jump table.

.        Cause successful retry error.

retry    bss     0
         vfd,32  0fd0f0000(16)         .condition microcode.
         vfd,32  0fe0f0000(16)         .cause hardware fault.
         return

.        Cause exchange error.

exchange bss     0
         vfd,32  0fd1f0000(16)         .condition microcode.
         vfd,32  0fe1f0000(16)         .cause hardware fault.
         return

.        Cause trap error.

trap     bss     0
         vfd,32  0fd2f0000(16)         .condition microcode.
         vfd,32  0fe2f0000(16)         .cause hardware fault.
         return

.        Cause halt error.

halt     bss     0
         vfd,32  0fd3f0000(16)         .condition microcode.
         vfd,32  0fe3f0000(16)         .cause hardware fault.
         return

.        Cause PDM halt error.

pdm_halt bss     0
         vfd,32  0fd4f0000(16)         .condition microcode.
         vfd,32  0fe4f0000(16)         .cause hardware fault.
         return

.        Cause software error, error stop.

swerr    bss     0
         halt
         return
         end
*DECK DECK=SYM$CORE_COMMAND_UTILITIES EXPAND=TRUE
?? RIGHT := 110 ??
MODULE sym$core_command_utilities;


{
{  PURPOSE:
{     This module is a collection of utility procs used by the sys core
{     command processor.
{

?? PUSH (LISTEXT := ON) ??
*copyc SYT$VALUE_KINDS
*copyc SYE$COMMAND_PROCESSOR_ERRORS
*copyc OSD$VIRTUAL_ADDRESS
*copyc OSS$MAINFRAME_PAGED_LITERAL
?? POP ??
*copyc OSP$SET_STATUS_ABNORMAL
*copyc ocp$find_debug_entry_point
  VAR
    non_space: [STATIC, READ, oss$mainframe_paged_literal] packed array [char] of boolean := [
{---} REP 9 of TRUE,
{HT } FALSE,
{---} REP 22 of TRUE,
{- -} FALSE,
{---} REP 223 of TRUE],
    comment_delimiter: [STATIC, READ, oss$mainframe_paged_literal] packed array [char] of boolean := [
{---} REP 34 of FALSE,
{ " } TRUE,
{---} REP 221 of FALSE];

?? TITLE := 'SYP$ASCII_TO_BINARY', EJECT ??
{-----------------------------------------------------------------------------------------------
{This procedure converts an ASCII string to an integer. A default base can be specified but
{may be overriden by an explicit declaration of a base in the string. The string
{may start with a - to indicate a negative number. Strings of the following formats are supported:
{   nnn
{  -nnn
{   nnn(bb)
{  -nnn(bb)
{       where nnn and bb are strings of one or more digits.
{-----------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] syp$ascii_to_binary (text: string ( * );
        default_base: 1 .. 16;
    VAR int: integer;
    VAR status: ost$status);

    VAR
      negative: boolean,
      ch: char,
      i: 0 .. 255,
      k,
      base: integer,
      len: integer;


    status.normal := TRUE;
    int := 0;
    len := STRLENGTH (text);
    IF len = 0 THEN
      RETURN
    IFEND;

    IF text (len) <> ')' THEN
      base := default_base;
    ELSE
      i := 1;
      WHILE text (i) <> '(' DO
        i := i + 1;
        IF i = len THEN
          osp$set_status_abnormal ('SY', sye$invalid_character, 'Invalid radix specification', status);
          RETURN;
        IFEND;
      WHILEND;
      syp$ascii_to_binary (text (i + 1, len - i - 1), 10, base, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      len := i - 1;
    IFEND;

    negative := text (1) = '-';
    IF negative THEN
      i := 2;
    ELSE
      i := 1;
    IFEND;

    WHILE i <= len DO
      ch := text (i);
      k := ORD (ch) - ORD ('0');
      IF (k > 9) OR (k < 0) THEN
        k := ORD (ch) - ORD ('A') + 10;
        IF k >= base THEN
          k := k - 32;
        IFEND;
      IFEND;
      IF (k < 0) OR (k >= base) THEN
        osp$set_status_abnormal ('SY', sye$invalid_character, 'Invalid digit', status);
        RETURN;
      IFEND;
      int := int * base + k;
      i := i + 1;
    WHILEND;
    IF negative THEN
      int := - int;
    IFEND;

  PROCEND syp$ascii_to_binary;
?? TITLE := 'SYP$BINARY_TO_ASCII', EJECT ??
{-----------------------------------------------------------------------------------------------
{This procedure is used to convert a binary number to its ASCII representation. Input parameters are:
{  I : number to be converted.
{  pos : rightmost char position for the converted string.
{        Leading zeroes on the string are not stored by this
{        routine.
{  base: base for ascii conversion (ie., 10 or 16 for decimal or hex
{-----------------------------------------------------------------------------------------------

  PROCEDURE [XDCL] syp$binary_to_ascii (i: integer;
    VAR st: string ( * );
        base: 2 .. 16;
        pos: 1 .. 255);

    VAR
      k,
      l: integer,
      negative: boolean,
      p: 0 .. 255;

    k := i;
    p := pos;
    negative := k < 0;
    IF negative THEN
      k := - k;
    IFEND;


    REPEAT
      l := k MOD base;
      IF l <= 9 THEN
        st (p) := CHR (l + ORD ('0'));
      ELSE
        st (p) := CHR (l - 10 + ORD ('A'));
      IFEND;
      k := k DIV base;
      p := p - 1;
    UNTIL (k = 0) OR (p = 0);
    IF negative AND (p > 0) THEN
      st (p) := '-';
    IFEND;

  PROCEND syp$binary_to_ascii;
?? TITLE := 'SYP$GET_TOKEN', EJECT ??
{-----------------------------------------------------------------------------------------------
{This procedure returns the next token from a line of text. Tokens may be separated by a comma and/or blanks.
{A null token is denoted by 2 commas separated with with zero OR more blanks. Strings are enclosed IN single
{quotes.
{-----------------------------------------------------------------------------------------------


  PROCEDURE [XDCL, #GATE] syp$get_token (text: string ( * );
        upper_case: boolean;
    VAR index: 0 .. 255;
    VAR token: ost$string;
    VAR status: ost$status);

    VAR
      lhi,
      rhi,
      scan_index: integer,
      found_char,
      commaflag: boolean,
      ch: char;


    status.normal := TRUE;
    commaflag := FALSE;
    lhi := index;
    rhi := STRLENGTH (text);
    token.size := 0;

  /build_token/
    BEGIN

    /find_start_of_token/
      WHILE TRUE DO

      /scan_loop/
        WHILE lhi <= rhi DO
          #scan (non_space, text (lhi, * ), scan_index, found_char);
          lhi := scan_index + lhi - 1;
          IF found_char AND (text (lhi) = '"') THEN
            #scan (comment_delimiter, text (lhi + 1, * ), scan_index, found_char);
            lhi := scan_index + lhi + ORD (found_char);
          ELSEIF scan_index <= 1 THEN
            EXIT /scan_loop/;
          IFEND;
        WHILEND /scan_loop/;
        IF lhi > rhi THEN
          EXIT /build_token/
        IFEND;
        ch := text (lhi);
        IF ch <> ',' THEN
          EXIT /find_start_of_token/
        IFEND;
        IF commaflag THEN
          EXIT /build_token/
        IFEND;
        commaflag := TRUE;
        lhi := lhi + 1;
      WHILEND /find_start_of_token/;

      IF ch = '''' THEN
        token.value (1) := ch;
        token.size := 1;

        WHILE lhi < rhi DO
          lhi := lhi + 1;
          ch := text (lhi);
          IF token.size = STRLENGTH (token.value) THEN
            osp$set_status_abnormal ('sy', sye$syntax_error, 'Syntax error', status);
          ELSE
            token.size := token.size + 1;
            token.value (token.size) := ch;
          IFEND;
          IF ch = '''' THEN
            IF lhi = rhi THEN
              lhi := lhi + 1;
              EXIT /build_token/;
            IFEND;
            lhi := lhi + 1;
            ch := text (lhi);
            IF ch <> '''' THEN
              EXIT /build_token/;
            IFEND;
          ELSEIF lhi = rhi THEN
            osp$set_status_abnormal ('SY', sye$syntax_error, 'Unexpected end-of-line', status);
            EXIT /build_token/;
          IFEND;
        WHILEND;
      ELSE

        WHILE lhi <= rhi DO
          ch := text (lhi);
          IF (ch = '=') THEN
            osp$set_status_abnormal ('SY', sye$syntax_error, 'Unsupported keyword format', status);
          IFEND;
          IF (ch = ' ') OR (ch = ',') THEN
            EXIT /build_token/
          IFEND;
          IF token.size = STRLENGTH (token.value) THEN
            osp$set_status_abnormal ('SY', sye$token_too_long, 'Token is too long', status);
          ELSE
            token.size := token.size + 1;
            IF upper_case AND (ch >= 'a') AND (ch <= 'z') THEN
              ch := CHR (ORD (ch) - ORD ('a') + ORD ('A'));
            IFEND;
            token.value (token.size) := ch;
          IFEND;
          lhi := lhi + 1;
        WHILEND;
      IFEND;
    END /build_token/;

    index := lhi;

  PROCEND syp$get_token;

?? TITLE := 'SYP$CRACK_COMMAND', EJECT ??
{-----------------------------------------------------------------------------------------------
{This procedure cracks the parameters on a line of text and returns the values
{of the parameters in a Parameter Value Table. A description of the parameter
{attributes is supplied in a Parameter Value Table.
{-----------------------------------------------------------------------------------------------



  PROCEDURE [XDCL] syp$crack_command (pdt: array [1 .. * ] OF syt$parameter_descriptor;
        text: string ( * );
    VAR pvt: array [1 .. * ] OF syt$parameter_value;
    VAR status: ost$status);

    VAR
      pdt_p: ^syt$parameter_descriptor,
      pvt_p: ^syt$parameter_value,
      i: integer,
      token: ost$string,
      ch_index: 0 ..255,
      index: 0 .. 255,
      int: integer,
      ring: 0 .. 15,
      seg: ost$segment,
      found: boolean,
      module_name: pmt$program_name,
      program_name: pmt$program_name,
      offset: ost$segment_offset;

    status.normal := TRUE;
    index := 1;

    FOR i := 1 TO UPPERBOUND (pdt) DO
      pdt_p := ^pdt [i];
      pvt_p := ^pvt [i];
      IF pdt_p^.parameter_kind = syc$pointer_value THEN
        syp$get_token (text, FALSE {upper_case}, index, token, status);
      ELSE
        syp$get_token (text, TRUE {upper_case}, index, token, status);
      IFEND;
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF token.size = 0 THEN
        pvt_p^.defined := FALSE;
        IF pdt_p^.required THEN
          osp$set_status_abnormal ('SY', sye$missing_parameter, 'Missing parameter', status);
          RETURN;
        ELSE
          CASE pdt_p^.parameter_kind OF
          = syc$name_value =
            pvt_p^.name := pdt_p^.namedef;
          = syc$boolean_value =
            pvt_p^.bool := pdt_p^.bdefault;
          = syc$integer_value =
            pvt_p^.int := pdt_p^.idefault;
          = syc$string_value =
            pvt_p^.text := pdt_p^.text_default;
          = syc$pointer_value =
            pvt_p^.ptr := pdt_p^.ptr_default;
          ELSE
          CASEND;
        IFEND;
      ELSE

        pvt_p^.defined := TRUE;
        CASE pdt_p^.parameter_kind OF
        = syc$name_value =
          IF token.size > STRLENGTH (pvt_p^.name) THEN
            osp$set_status_abnormal ('SY', sye$token_too_long, 'Token is too long', status);
            RETURN;
          IFEND;
          pvt_p^.name := token.value (1, token.size);
        = syc$integer_value =
          syp$ascii_to_binary (token.value (1, token.size), 10, int, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF (int < pdt_p^.imin) OR (int > pdt_p^.imax) THEN
            osp$set_status_abnormal ('SY', sye$range_error, 'Range error', status);
            RETURN;
          ELSE
            pvt_p^.int := int;
          IFEND;
        = syc$string_value =
          IF (token.value (1) <> '''') OR (token.value (token.size) <> '''') THEN
            osp$set_status_abnormal ('SY', sye$syntax_error, 'Invalid string', status);
            RETURN;
          ELSE
            IF token.size > 2 THEN
              pvt_p^.text.value (1, token.size - 2) := token.value (2, token.size - 2);
            IFEND;
            pvt_p^.text.size := token.size - 2;
          IFEND;
        = syc$pointer_value =
          IF (token.value (1) >= '0') AND (token.value (1) <= '9') THEN
            syp$ascii_to_binary (token.value (1, token.size), 16, int, status);
            ring := int DIV 100000000000(16);
            seg := (int - ring * 100000000000(16)) DIV 100000000(16);
            offset := int MOD 80000000(16);
          ELSE
            program_name := token.value (1, token.size);
            ocp$find_debug_entry_point (program_name, found, module_name, seg, offset, status);
            IF NOT found THEN

{  Convert to upper case and try again.

              FOR ch_index := 1 TO token.size DO
                IF (token.value (ch_index) >= 'a') AND (token.value (ch_index) <= 'z') THEN
                  token.value (ch_index) := CHR (ORD (token.value (ch_index)) - ORD ('a') + ORD ('A'));
                IFEND;
              FOREND;
              program_name := token.value (1, token.size);
              ocp$find_debug_entry_point (program_name, found, module_name, seg, offset, status);
              IF NOT found THEN
                osp$set_status_abnormal ('SY', sye$invalid_character, 'Entry point not found', status);
              IFEND;
            IFEND;
            ring := 1;
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          IF ring = 0 THEN
            ring := 1;
          IFEND;
          pvt_p^.ptr := #address (ring, seg, offset);
        = syc$boolean_value =
          pvt_p^.bool := (token.value (1, 2) = 'ON') OR (token.value (1, 4) = 'TRUE') OR (token.value (1, 3) =
            'YES');
          IF NOT pvt_p^.bool AND NOT ((token.value (1, 3) = 'OFF') OR (token.value (1, 5) = 'FALSE') OR
                (token.value (1, 2) = 'NO')) THEN
            osp$set_status_abnormal ('SY', sye$syntax_error, 'Unknown value for boolean', status);
            RETURN;
          IFEND;
        ELSE
          osp$set_status_abnormal ('SY', sye$bad_pdt, 'Bad PDT', status);
          RETURN;
        CASEND;
      IFEND;
    FOREND;

  PROCEND syp$crack_command;

MODEND sym$core_command_utilities;
*DECK DECK=SYM$CORE_TRAP_HANDLER EXPAND=TRUE
SYM$CORE_TRAP_HANDLER  IDENT
.
.         ojc      1
*copyc MTA$SMU_COMMUNICATION_BLOCK
*copy SYA$CONSTANTS
*copy OSA$BASIC_REGISTER_EQUATES
*copyc SYA$DCTL_ASSEMBLY_CONSTANTS
*copyc OSI$XCB_FOR_CURRENT_TASK
*copyc OSC$XCB_ASEMBLY_CONSTANTS
*copyc OSA$KEYPOINT_CLASSES
*copyc sya$xp_and_sf_constants
.
.
.  local definitions
.
x_enviro   equ      0154(16)        .Descriptor for CALLS.
x_envirod  equ      0156(16)        .Descriptor for call to debug.
.
x_ucr      xreg     3               .UCR from trapped SFSA.
x_jobff   xreg     4                       .Flag to indicate if Job trap handler
                                           .  nedds a FREE FLAG trap.
x_di      xreg     5                       .Debug index.
x_dmr     xreg     6                       .Debug mask register.
a_mflag   areg     4                       .BS entry for processing flags.
a_xcb     areg     5                       .Pointer to XCB.

. Stack frame offsets

plist     equ      8                       .Stack - start of param list
cond_opts equ      64                      .Stack - ring crossing condition options
enable    equ      72                      .Stack - flag for trap enable at exit (boolean)
user_regs  equ     80                      .Stack - Area for saving user registers
.
.  The following constant value must have the same value as mmc$ring_crossing_offset.
.
rc_offset equ      28(16)                  .Ring crossing frame offset.
.
          page
.
.  Trap handler for NOS/VE System Core
.
          use      code
          def      traprtn
traprtn   alias    SYP$SYSTEM_CORE_TRAP_HANDLER
traprtn   bss      0
.
          addaq    a0,a1,120               .Push stack frame.  Must be 78(16) bytes
                                           .so that A0 remains at a 0 MOD 80 address
                                           .for THETA_E.  108(16) bytes are already
                                           .in the save area.
          entp     x1,1
          sbyts,1  x1,a1,x0,enable         .Default to enable traps at exit

          lbyts,2  x_ucr,a2,x0,xpucr       .Get the UCR from the SFSA.
          lbyts,2  x1,a2,x0,xpum           .Mask with current UM.
          andx     x_ucr,x1
          shfx     x1,x_ucr,x0,13
          keypoint oscent,x1,osktrpj
          laxcbp   a_xcb,x1                .Get pointer to XCB.
.
.  Check for system core debug active. System core debug is called if:
.      . a 'debug' trap occurred AND the debug list is in ring 1
.                OR
.      . the trapped P ring number was less than 'high_ring_for_debug AND
.           either an MCR fault or UCR fault (except CFF, PIT, KEYPOINT, FF, DEBUG)
.           occurred
.
          la       ae,a3,bs_dbctl          .Fetch pointer to debug control table.
          shfx     x1,x_ucr,x0,24          .Check for debug trap -
          brrge    x1,x0,ckdb5             .  jump if not a debug trap.
          entl     x0,r_dlp                .Check for Ring 1 DLP.
          cpysx    x1,x0
          shfx     x1,x1,x0,-44
          decx     x1,1                    .X1=0 implies system debug trap
          brxeq    x1,x0,ckdb8
ckdb5     lbyts,1  x1,ae,x0,dbring         .Test for trap < high ring.
          cpyax    x2,a2
          shfx     x2,x2,x0,-44
          brxgt    x2,x1,ckpit             .Jump if > high ring.
          ente     x1,0c97f(16)
          andx     x1,x_ucr
          brxeq    x1,x0,ckpit             .Jump if not ia selected UCR fault.
ckdb8     la       ae,ae,dbproc            .Fetch pointer to debug procedure.
          entl     x0,r_di                 .Save debug index and mask regs.
          cpysx    x_di,x0
          entl     x0,r_dmr
          cpysx    x_dmr,x0
          ente     x0,x_envirod
          callseg  0,ae,a0
          entl     x0,r_di                 .Restore debug index and mask reg.
          cpyxs    x_di,x0
          entl     x0,r_dmr
          cpyxs    x_dmr,x0
          brxne    x1,x0,ckpit             .Clear UCR.DEBUG if trap caused by system debug
          ente     x1,m_ucrdb
          inhx     x_ucr,x1
          sbyts,2  x_ucr,a2,x0,xpucr
.
.  Process PIT trap.
.
ckpit     bss      0
          shfx     x1,x_ucr,x0,19          .Move 'pit' to bit 32.
          brrge    x1,x0,ckmf              .Branch if no PIT.
          la       af,a3,bs_dfpit          .Get default PIT value.
          lx       x1,af,0
          sx       x1,a1,0                 .Set up parameter list
          addaq    af,a1,2*8
          sa       af,a1,1*8
          ente     x0,x_enviro
          cpyaa    af,a1                   .parameter list address.
          callseg  bs_spit,a3,af           .Update PIT
.
.  Process Monitor Flags if either 1) the trap occurred in ring 1 and ring
.  1 flags are set, or 2) the trap occurred above ring 1.
.  The register 'X_JOBFF' is set non-zero if job free flag trap is pending.
.
ckmf      lbyts,mfbc x_jobff,a_xcb,x0,xcbmflag .Get monitor flags.
          brreq    x_jobff,x0,ckmore       .Jump if no flags set.
          brseg    x1,a2,a0,ckmf2          .Jump if above ring 1.
          ente     x1,mfring1              .Mask for ring 1 flags.
          andx     x_jobff,x1
          brxeq    x_jobff,x0,ckmore       .Jump if no ring 1 flags set.
ckmf2     shfx     x1,x_jobff,x0,32-8*mfbc+1 .Move flag 1 to bit 32.
          shfx     x_jobff,x_jobff,x0,1-8*mfbc .Isolate bit 0.
          cpyaa    a_mflag,a3              .Pointer to handler.
          entp     x2,1                    .Flag number.
ckmf5     brrge    x1,x0,ckmf9             .Jump if flag not set.
          cpyxx    x0,x2                   .Clear flag in XCB.
          sbit     x1,a_xcb,xcbmflag,x0    .  (X1, bit 0 is always zero)
          ente     x0,x_enviro             .Call the handler.

. Monitor flag handlers have an optional parameter:
.                   VAR boolean
. They should set it FALSE if traps should NOT be enabled when the
. current invocation of the trap handler exits. Default is to enable traps.

          addaq    ae,a1,enable            .Set up parameter list
          sa       ae,a1,plist
          addaq    ae,a1,plist
          callseg  bs_mfhan,a_mflag,ae
ckmf9     addaq    a_mflag,a_mflag,16      .Increment binding sec addr.
          incx     x2,1                    .Increment flag number.
          shfx     x1,x1,x0,1              .Next flag to bit 32.
          brrne    x1,x0,ckmf5             .Jump if more flags.
          lbyts,mfbc x2,a_xcb,x0,xcbmflag  .Get monitor flags.
          shfx     x_jobff,x2,x0,1-8*mfbc  .Isolate bit 0.
                                           .  If the free flag was set it still is.
          isob     x2,x2,x0,6116(8)        .Ignore Free flag.
          brseg    x1,a2,a0,ckmf10         .Jump if above ring 1.
          ente     x1,mfring1              .Mask for ring 1 flags.
          andx     x2,x1
ckmf10    brxne    x2,x0,ckmf              .Check for more to do
          insb     x_ucr,x_jobff,x0,6200(8)  .set ucr ff if more processing to do
.
.
.  Exit if no UCR bits except KEYPOINT are set.
.  NOTE: PIT was formerly eliminated from the UCR along with KEYPOINT.
.
ckmore    brxne    x_ucr,x0,prtrap         .Jump if other UCR bits are set.
.
exit      bss      0
          keypoint oscexit,x0,osktrpj
          lbyts,1  x1,a1,x0,enable
          brreq    x0,x1,exit1             .If not to enable traps
          entl     x0,r_ted                .Set trap-enable-delay.
          cpyxs    x0,x0                   . and return.
.
. The following field definition is used to support the PSFSA instruction which is
. required for CYBER-2000 but is not available in the ASSEMBLER language yet.
. When it is available, replace the VFD line with the following line:
.exit1    psfsa                             .Purge the SFSA pushdown (CYBER-2000 only)
.
exit1    bss     0
         vfd,16   0701(16)                 .Purge the SFSA pushdown (CYBER-2000 only)
         return
.
.
.  A trap occurred that needs more processing, (ie, not KEYPOINT).
.  Processing depends on whether we are executing in ring 1 or
.  above ring 1.
.
prtrap    brseg    x1,a2,a0,jobtrap        .Jump if A2 points to a ring different from
.                                          .  this proc, (above ring 1).
          la       ae,a2,26                .Get A2 from SFSA.
          brseg    x1,a2,ae,prtrap1        .Jump if ring crossing found.
          brxeq    x0,x0,rng1trap
prtrap1   lbyts,6  xb,a2,x0,18             .Get stack frame CSF.
          isob     x7,xb,x0,7007(8)        .Isolate last 8 bits of offset.
          brxeq    x7,x0,exit              .If a ring crossing frame.
          page
.
.
.  Trap handler for faults that occur while executing in ring 1.
.
rng1trap  ente     x1,0c97f(16)            .Call system error if any fatal
          andx     x1,x_ucr                .  occurred in ring 1.
          brxeq    x1,x0,ckfreflg          .Jump if no fatal error.
          sx       x_ucr,a1,plist
          ente     x0,x_enviro
          addaq    ae,a1,plist
          callseg  bs_scuh,a3,ae

.
.  Process FREE FLAG trap and/or PIT trap.
.
ckfreflg  lbyts,mfbc x9,a_xcb,x0,xcbmflag  .Get monitor flags.
          brxeq    x9,x0,ckpit1            .If no free flag needed.
          entp     x9,2                    .Select FREE FLAG option.
ckpit1    shfx     x1,x_ucr,x0,19          .Move 'pit' to bit 32.
          brrge    x1,x0,ckfre0            .Jump if no PIT.
          incx     x9,1                    .Select PIT option.
ckfre0    brxeq    x9,x0,ckdebug           .Jump if no options selected.
ckfre1    cpyaa    af,a2                   .Find the ring crossing stack frame.
ckfre5    la       ae,af,26                .  Get A2 from SFSA.
          brseg    x1,af,ae,ckfre8         .  Jump if ring crossing found.
          cpyaa    af,ae
          brxeq    x0,x0,ckfre5
.
.  Put a SFSA at the bottom of the stack in front of the ring crossing
.  frame. Make it look like the ring crossing processor called the owner
.  of the ring crossing frame.  When the ring crossing processor executes
.  it will cause Free Flag processing to occur in the next higher ring.
.
ckfre8    bss      0
          lbyts,6  xb,af,x0,18             .Get first stack frame CSF.
          isob     x7,xb,x0,7007(8)        .Isolate last 8 bits of offset.
          brxne    x7,x0,ckfre85           .If not a ring crossing frame.
          lbyts,1  x1,af,x0,32             .Get condition options from SFSA.
          iorx     x9,x1                   .Insert new options.
          cpyaa    aa,af
          brxeq    x0,x0,ckfre9

ckfre85   lx       xa,a3,bs_raprc          .Get ring alarm proc P.
          isob     xa,xa,x0,2057(8)        .Isolate P register PVA.
          lbyts,2  xd,af,x0,0              .Get GLOBAL and LOCAL KEYS.
          insb     xa,xd,x0,0017(8)        .Insert GLOBAL and LOCAL KEYS in P.
          cpyax    xe,a3                   .Binding section address to A3.
          lbyts,6  xd,af,x0,26             .Set A2 to PSA.
          addxq    xb,xb,-rc_offset        .New SFSA A0
          cpyxa    aa,xb
          sa       aa,af,26                .New PSA for ring crossing frame.
          cpyxx    xc,xb                   .Set A1 to same as A0.
          ente     x1,00130(16)            .Insert a frame descriptor.
          insb     xc,x1,x0,0017(8)
          entl     x0,r_um                 .Read the UM and
          cpysx    x1,x0                   .  insert in SFSA.
          insb     xd,x1,x0,0017(8)
          ente     x1,01a0e(16)            .Descriptor for SMULT of x10 - x14.
          smult    x1,aa,0                 .Store new SFSA.
.
. The following field definition is used to support the PSFSA instruction which is
. required for CYBER-2000 but is not available in the ASSEMBLER language yet.
. When it is available, replace the VFD line with the following line:
.         psfsa                            .Purge the SFSA pushdown (CYBER-2000 only)
.
          vfd,16   0701(16)                .Purge SFSA pushdown (CYBER-2000 only)
ckfre9    sbyts,1  x9,aa,x0,32             .Save condition options in SFSA.
          ente     x0,x_enviro
          callseg  bs_scch,a3,a0
.
.  Process debug trap that occurred in ring 1.
.
ckdebug   shfx     x1,x_ucr,x0,24          .Move 'debug' to bit 32.
          brrge    x1,x0,ckcff             .Jump if no debug trap.
          entp     x0,8                    .Set up X0 for clearing bit 8 of UM.
          cpyaa    af,a2                   .Set AF to point to PSA.
ckdeb5    sbit     x0,af,xpum,x0           .Clear 'debug' in UM.
          la       af,af,26                .Set AF to point to PSA.
          brseg    x1,af,a0,ckcff          .Exit loop when not R1 SFSA.
          brxeq    x0,x0,ckdeb5
.
.  Check for CFF trap.
.
ckcff     shfx     x1,x_ucr,x0,21          .Move 'cff' to bit 32.
          brrge    x1,x0,ckend             .Jump if no CFF.
          pop                              .POP the current SFSA.
          entl     x0,r_cff_c              .Clear CFF in live register.
          cpyxs    x0,x0
ckcff4    entl     x0,r_ted                .Set TRAP-ENABLE-DELAY.
          cpyxs    x0,x0
          brxeq    x_jobff,x0,ckcff5       .Set FF if job trap handler
          brcr     2,5,ckcff5              .  needs calling.
ckcff5    entl     x0,0ff(16)              .Descriptor for all A and X.
          lmult    x0,a0,-47*8             .This reloads all A and X registers.
                                           .Must compensate for PUSH of 120 bytes!
.
. The following field definition is used to support the PSFSA instruction which is
. required for CYBER-2000 but is not available in the ASSEMBLER language yet.
. When it is available, replace the VFD line with the following line:
.         psfsa                            .Purge the SFSA pushdown (CYBER-2000 only)
.
          vfd,16   0701(16)                .Purge SFSA pushdown (CYBER-2000 only)
          return
.
.  End of trap handling for traps that occur in ring 1.
.
ckend     lbyts,1  x1,a1,x0,enable
          brreq    x0,x1,ckend1            .If not to enable traps
          entl     x0,r_ted                .Set TRAP-ENABLE-DELAY and return.
          cpyxs    x0,x0
ckend1    return
          page
.
.
.
.  Trap handler for traps that occur from above Ring 1.
.
.
jobtrap   bss      0
.
.  Update the UCR in the SFSA since not all conditions need to
.  be processed by the job trap handler.
.
          insb     x_ucr,x_jobff,x0,6200(8)  .Set the FF bit if needed.
jobt99    brxeq    x_ucr,x0,exit           .Exit if UCR is null.
          sbyts,2  x_ucr,a2,x0,xpucr       .Update job SFSA.UCR.
.
.  Clear Monitor flag 0 if processing a Free Flag trap.
.
          brxeq    x_jobff,x0,jobt1        .Jump if no FF trap.
          entp     x0,0                    .Clear bit 0.
          sbit     x0,a_xcb,xcbmflag,x0
.
.  Push a SFSA to the top of the stack for the ring in which the trap
.  occurred. Make it look like the job trap handler called the system
.  core trap handler. * * note this requires that the job trap handler
.  be in a run-anywhere segment.
.  NOTE: The value of the vector simulation flag is passed in XE.
.
jobt1     la       af,a3,bs_jobth          .Set AF to point to ^job trap handler.
          la       af,af,0
          lbyts,6  xa,af,x0,2              .Fetch P.
          lbyts,6  xe,af,x0,10             .Fetch binding section address.
          lbyts,2  xd,a2,x0,0              .Get GLOBAL and LOCAL KEYS from PSA.P
          insb     xa,xd,x0,0017(8)        .Insert GLOBAL and LOCAL KEYS in P
          cpyax    xd,a2                   .Set A2 to PSA.
          addaq    a2,a2,33*8              .Increment A2 by size of SFSA.
          cpyax    xb,a2                   .Set A0 to top of user stack.
          cpyxx    xc,xb                   .Set A1 to same as A0.
          isob     x1,xd,x0,2003(8)        .Isolate user ring number.
          insb     xa,x1,x0,2003(8)        .Insert ring to P
          insb     xe,x1,x0,2003(8)        .Insert ring to A3.
          ente     x1,00130(16)            .Insert a frame descriptor.
          insb     xc,x1,x0,0017(8)
          entl     x0,r_um                 .Read the UM and
          cpysx    x1,x0                   .  insert in SFSA.
          insb     xd,x1,x0,0017(8)
          ente     x1,01a0e(16)            .Descriptor for SMULT of x10 - x14.
          smult    x1,a2,0                 .Store new SFSA.
.
. The following field definition is used to support the PSFSA instruction which is
. required for CYBER-2000 but is not available in the ASSEMBLER language yet.
. When it is available, replace the VFD line with the following line:
.         psfsa                            .Purge the SFSA pushdown (CYBER-2000 only)
.
          vfd,16   0701(16)                .Purge SFSA pushdown (CYBER-2000 only)
          la       af,a3,bs_scb            .Pass VECTOR SIMULATION flag in XE
          lbyts,3  xe,af,x0,scbvecsim
.
          return                           .Return to Job Trap Handler.
.
.
.
          page
.
.  SET JOB_FREE_FLAG IN MONITOR FLAGS
.
          defg     freeflg
freeflg   alias    SYP$ENABLE_JOB_FREE_FLAG
          align    0,8
freeflg   bss      0
.
          laxcbp   a_xcb,x1                .get pointer to xcb.
          entl     x0,0
          entp     x1,1
          sbit     x1,a_xcb,xcbmflag,x0     .set free flag
          return
.
.
.
          page
.
.  RING 1 RING CROSSING PROCESSOR
.
          def      raproc
          align    0,8
raproc    bss      0
          entl     x0,r_td                 .Disable traps.
          cpyxs    x0,x0
          addaq    a0,a1,344               .Push room for registers.
          ente     x0,40ff(16)             .Descriptor for user registers.
          smult    x0,a1,user_regs         .Save user registers.
.
. The following field definition is used to support the PSFSA instruction which is
. required for CYBER-2000 but is not available in the ASSEMBLER language yet.
. When it is available, replace the VFD line with the following line:
.         psfsa                            .Purge the SFSA pushdown (CYBER-2000 only)
.
          vfd,16   0701(16)                .Purge SFSA pushdown (CYBER-2000 only)
          lbyts,1  x0,a1,x0,32             .Get condition options.
          sbyts,1  x0,a1,x0,cond_opts      .Save in stack.
.
.  Process Monitor Flags if any ring 1 flags set.
.  The register 'X_JOBFF' is set non-zero if job free flag trap is pending.
.
          laxcbp   a_xcb,x1                .get pointer to xcb.
raprc1    lbyts,mfbc x_jobff,a_xcb,x0,xcbmflag .Get monitor flags.
          brreq    x_jobff,x0,raprce       .Jump if no flags set.
raprc2    shfx     x1,x_jobff,x0,32-8*mfbc+1 .Move flag 1 to bit 32.
          shfx     x_jobff,x_jobff,x0,1-8*mfbc .Isolate bit 0.
          cpyaa    a_mflag,a3              .Pointer to handler.
          entp     x2,1                    .Flag number.
raprc3    brrge    x1,x0,raprc4            .Jump if flag not set.
          cpyxx    x0,x2                   .Clear flag in XCB.
          sbit     x1,a_xcb,xcbmflag,x0    .  (X1, bit 0 is always zero)
.
.  Set up to call a monitor flag handler.
.
          ente     x0,x_enviro             .Call the handler.
          addaq    ae,a1,enable            .Set up parameter list
          sa       ae,a1,plist
          addaq    ae,a1,plist
          callseg  bs_mfhan,a_mflag,ae
raprc4    addaq    a_mflag,a_mflag,16      .Increment binding sec addr.
          incx     x2,1                    .Increment flag number.
          shfx     x1,x1,x0,1              .Next flag to bit 32.
          brrne    x1,x0,raprc3            .Jump if more flags.
          lbyts,mfbc x1,a_xcb,x0,xcbmflag  .Get monitor flags.
          shfx     x_jobff,x1,x0,1-8*mfbc  .Isolate bit 0.
                                           .  If the free flag was set it still is.
          isob     x9,x1,x0,6116(8)        .Ignore Free flag.
          insb     x1,x_jobff,x0,7600(8)   .Save condition of FREE FLAG.
          lbyts,1  x0,a1,x0,cond_opts      .Get condition options.
          iorx     x0,x1                   .Insert FREE FLAG if there.
          sbyts,1  x0,a1,x0,cond_opts      .Put back in stack.
          brxne    x9,x0,raprc1            .Check for more to do
raprce    cpyaa    a0,a1                   .POP the space we pushed
.
.  Call the procedure rtproc so that the
.  proper value for TOS is preserved.
.
          ente     x0,00130(16)
          callseg  bs_rtprc,a3,a0          Callee does not return to caller.

.
.
.
          def      rtproc
          align    0,8
rtproc    bss      0
          la       a9,a2,18                .Callers CSF
          lbyts,1  x_ucr,a9,x0,cond_opts   .Get condition options.
          la       a2,a2,26                .Use callers PSA.  This POPs caller.
          lbyts,2  x9,a2,x0,16             .Get SFSA descriptor.
          ente     x0,0fff(16)             .Mask for register options.
          andx     x9,x0
          entx     x1,0ff(16)
          brxne    x9,x1,rtproc1           .If not a full frame.
          lbyts,2  x9,a2,x0,xpucr          .Get the UCR from the SFSA.
          lbyts,2  x1,a2,x0,xpum           .Mask with current UM.
          andx     x9,x1
          shfr     x_ucr,x_ucr,x0,12       .Position to UCR bit positions.
          iorx     x_ucr,x9                .Combine with SFSA UCR.
          isob     x_jobff,x_ucr,x0,6200(8)  .Preserve FF bit condition.
          laxcbp   a_xcb,x1                .get pointer to xcb.
          brxeq    x0,x0,jobt99            .Go invoke job trap handler.
.
. Set up to return directly to user.
.
rtproc1   entl     x0,r_ted                .Set trap_enable_delay.
          cpyxs    x0,x0
          shfr     x_ucr,x_ucr,x0,30       .Position FREE FLAG option bit.
          brrge    x_ucr,x0,rtproc2        .If not FREE FLAG option.
          brcr     2,5,rtproc2             .Set Free Flag.
rtproc2   shfr     x_ucr,x_ucr,x0,1        .position PIT option bit.
          brrge    x_ucr,x0,rtproc3        .If not PIT option.
          brcr     3,5,rtproc3             .Set PIT.
rtproc3   ente     x0,40ff(16)             .Descriptor for reload of registers.
          lmult    x0,a9,user_regs         .Reload user registers.
.
. The following field definition is used to support the PSFSA instruction which is
. required for CYBER-2000 but is not available in the ASSEMBLER language yet.
. When it is available, replace the VFD line with the following line:
.         psfsa                            .Purge the SFSA pushdown (CYBER-2000 only)
.
          vfd,16   0701(16)                .Purge SFSA pushdown (CYBER-2000 only)
          return
.
.
.
          page
.
.  Define Binding Section for System Core Trap Handler.
.
          use      binding
          ref      scch
scch      alias    SYP$INVOKE_SYSCORE_COND_HANDLER
bs_scch   address  c,scch
.
          ref      scuh
scuh      alias    SYP$INVOKE_SYSCORE_UCR_HANDLER
bs_scuh   address  c,scuh
.
          ref      dfpit
dfpit     alias    OSV$DEFAULT_PIT
bs_dfpit  address  p,dfpit
.
          ref      dbctl
dbctl     ALIAS    SYV$DEBUG_CONTROL
bs_dbctl  address  p,dbctl
.
          ref      jobth
jobth     alias    JMV$JOB_TRAP_HANDLER
bs_jobth  address  p,jobth
.
          ref      scb
scb       alias    MTV$SCB
bs_scb    address  p,scb
.
          ref      spit
spit      alias    SYP$SET_PROCESS_INTERVAL_TIMER
bs_spit   address  c,spit
.
bs_raprc  address  c,raproc
.
bs_rtprc  address  c,rtproc
*copyc SYA$MONITOR_FLAG_HANDLERS
          page
.* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
.
. PROCEDURE [XDCL, #GATE] syp$purge_instruction_stack;
.
. This procedure is called to purge the intruction stack in system core.
. (Current use is after changing code via a super_change_memory command in
. the system core debugger.)
.
.* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
          use      code
          defg     prg_istk
prg_istk  alias    syp$purge_instruction_stack
prg_istk  bss      0
          addaq    a0,a1,24
          purge    x0,4                .Purge the instruction stack (CYBER-2000 only)
.
. The following field definition is used to support the PSFSA instruction which is
. required for CYBER-2000 but is not available in the ASSEMBLER language yet.
. When it is available, replace the VFD line with the following line:
.         psfsa                        .Purge the SFSA pushdown (CYBER-2000 only)
.
          vfd,16   0701(16)            .Purge the SFSA pushdown (CYBER-2000 only)
          return
.* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
          end
*DECK DECK=SYM$DEADSTART EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE System : Deadstart code' ??
MODULE sym$deadstart;

{ PURPOSE:
{   This module contains deadstart procedures that are common to the boot and to system core.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dse$error_codes
*copyc dst$rb_system_deadstart_status
*copyc osc$processor_defined_registers
*copyc ost$iou_model_number
*copyc ost$processor_model_number
*copyc syc$ssr_system_level_number
*copyc syc$copyright
?? POP ??
*copyc clp$convert_integer_to_string
*copyc dpp$open_window
*copyc dpp$put_critical_message
*copyc dsp$get_entry_from_ssr
*copyc i#call_monitor
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc syp$display_deadstart_message
*copyc syp$process_deadstart_status
?? EJECT ??
*copyc dpv$critical_display_id
*copyc dpv$system_core_display
*copyc dsv$mainframe_type
*copyc dsv$sub_mainframe_type
*copyc mtv$nst_p
?? OLDTITLE ??
?? NEWTITLE := 'syp$check_system_level', EJECT ??

{ PURPOSE:
{   This procedure checks that the system level in the SSR matches VCB and system core.

  PROCEDURE [XDCL] syp$check_system_level;

    VAR
      error_message: string (80),
      integer_string: ost$string,
      rb: dst$rb_system_deadstart_status,
      status: ost$status,
      sysl_entry: dst$ssr_entry;

    dpp$put_critical_message (syc$copyright_message, status);

    { Check the system level number in the SSR for compatibility between VCB and system core.

    dsp$get_entry_from_ssr (dsc$ssr_system_level_number, sysl_entry);

    IF (sysl_entry.ssln_released_level_number <> syc$ssln_released_level_number) OR
          (sysl_entry.ssln_bcu_level_number <> syc$ssln_bcu_level_number) THEN

      { Display VCB/system core and SSR level numbers, issue error message and halt system initialization.

      syp$display_deadstart_message ('System component level numbers follow:');
      syp$display_deadstart_message ('  OS level number equals:');
      clp$convert_integer_to_string (syc$ssln_released_level_number, 10, TRUE, integer_string, status);
      error_message := '    Release level number equals ';
      error_message (33, integer_string.size) := integer_string.value (1, integer_string.size);
      error_message (33+integer_string.size, 1) := '.';
      syp$display_deadstart_message (error_message);
      error_message := '    BCU level number equals ';
      error_message (29, integer_string.size) := integer_string.value (1, integer_string.size);
      error_message (29+integer_string.size, 1) := '.';
      syp$display_deadstart_message (error_message);

      syp$display_deadstart_message ('  SSR level number equals:');
      clp$convert_integer_to_string (sysl_entry.ssln_released_level_number, 10, TRUE, integer_string, status);
      error_message := '    Release level number equals ';
      error_message (33, integer_string.size) := integer_string.value (1, integer_string.size);
      error_message (33+integer_string.size, 1) := '.';
      syp$display_deadstart_message (error_message);
      error_message := '    BCU level number equals ';
      error_message (29, integer_string.size) := integer_string.value (1, integer_string.size);
      error_message (29+integer_string.size, 1) := '.';
      syp$display_deadstart_message (error_message);

      rb.reqcode := syc$rc_system_deadstart_status;
      rb.action := dsc$rb_sds_set_bct_flag;
      rb.bct_flags := dsc$rb_sds_bct_ts_by_error;
      i#call_monitor (#LOC (rb), #SIZE (rb));

      osp$set_status_abnormal (dsc$display_processor_id, dse$system_level_mismatch,
            'OS and SSR system levels do not match.', status);
      syp$process_deadstart_status ('Mismatching NOS/VE components.', TRUE, status);
    IFEND;

  PROCEND syp$check_system_level;
?? OLDTITLE ??
?? NEWTITLE := 'syp$determine_mainframe_type', EJECT ??

{ PURPOSE:
{   This procedure checks the model number in the element id register to build the mainframe type variable.

  PROCEDURE [XDCL] syp$determine_mainframe_type;

    TYPE
      t$integer_or_element_id = RECORD
        CASE boolean OF
        = TRUE =
          integer_part: integer,
        = FALSE =
          rfu: 0 .. 0ffffffff(16),
          element_number: 0 .. 0ff(16),
          model_number: 0 .. 0ff(16),
          serial_number: 0 .. 0ffff(16),
        CASEND,
      RECEND;

    VAR
      rb: dst$rb_system_deadstart_status,
      integer_or_element_id: t$integer_or_element_id;

    integer_or_element_id.integer_part := #READ_REGISTER (osc$pr_element_id);
    CASE integer_or_element_id.model_number OF
    = osc$cyber_180_model_810, osc$cyber_180_model_815, osc$cyber_180_model_825, osc$cyber_180_model_830 =
      dsv$mainframe_type := dsc$mt_lower_8xx_mainframe;
    = osc$cyber_180_model_835 =
      dsv$mainframe_type := dsc$mt_835_mainframe;
    = osc$cyber_180_model_840, osc$cyber_180_model_840s, osc$cyber_180_model_845, osc$cyber_180_model_845s,
            osc$cyber_180_model_850, osc$cyber_180_model_855, osc$cyber_180_model_855s,
            osc$cyber_180_model_860 =
      dsv$mainframe_type := dsc$mt_upper_8xx_mainframe;
    = osc$cyber_180_model_990, osc$cyber_180_model_990e =
      dsv$mainframe_type := dsc$mt_990_mainframe;
    = osc$cyber_180_model_9301, osc$cyber_180_model_9303, osc$cyber_180_model_930a, osc$cyber_180_model_930b,
            osc$cyber_180_model_930c, osc$cyber_180_model_930d, osc$cyber_900_model_9321,
            osc$cyber_900_model_9323, osc$cyber_900_model_932a, osc$cyber_900_model_932b =
      dsv$mainframe_type := dsc$mt_93x_mainframe;
    = osc$cyber_900_model_9601, osc$cyber_900_model_9603, osc$cyber_900_model_960c,
          osc$cyber_900_model_960d =
            rb.reqcode := syc$rc_system_deadstart_status;
            rb.action := dsc$rb_sds_fetch_element_id;
            i#call_monitor (#LOC (rb), #SIZE (rb));
          IF rb.iou_model = dsc$rb_model_44 THEN
            dsv$mainframe_type := dsc$mt_962_972_mainframe;
          ELSE
            dsv$mainframe_type := dsc$mt_960_970_mainframe;
          IFEND;
      IF (integer_or_element_id.model_number = osc$cyber_900_model_960c) OR
            (integer_or_element_id.model_number = osc$cyber_900_model_960d) THEN
        dsv$sub_mainframe_type := dsc$smt_soviet_mainframe;
      IFEND;
    = osc$cyber_900_model_992, osc$cyber_900_model_992a =
      dsv$mainframe_type := dsc$mt_992_mainframe;
      IF integer_or_element_id.model_number = osc$cyber_900_model_992a THEN
        dsv$sub_mainframe_type := dsc$smt_china_mainframe;
      IFEND;
    = osc$cyber_900_model_994 =
      dsv$mainframe_type := dsc$mt_994_mainframe;
    = osc$cyber_2000_model_20s1, osc$cyber_2000_model_20u1, osc$cyber_2000_model_20v1 =
      dsv$mainframe_type := dsc$mt_2000_mainframe;
    ELSE
      osp$system_error ('Unknown mainframe type', NIL);
    CASEND;

  PROCEND syp$determine_mainframe_type;
?? OLDTITLE ??
?? NEWTITLE := 'syp$prepare_deadstart_display', EJECT ??

{ PURPOSE:
{   This procedure is called during deadstart to open the deadstart display and
{   to output the copyright message.

  PROCEDURE [XDCL] syp$prepare_deadstart_display;

    VAR
      status: ost$status;

    dpp$open_window (dpc$wc_sharing, dpc$wk_interactive, 'NOS/VE', dpv$critical_display_id, status);

    dpp$open_window (dpc$wc_sharing, dpc$wk_interactive, 'NOS/VE Deadstart Command Processor.',
          dpv$system_core_display, status);

  PROCEND syp$prepare_deadstart_display;
?? OLDTITLE ??
MODEND sym$deadstart;
*DECK DECK=SYM$DEADSTART_COMMAND_PROCESSOR EXPAND=TRUE
*DECK DECK=SYM$DEADSTART_INITIALIZATION EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE System : Deadstart Initialization' ??
MODULE sym$deadstart_initialization;

{ PURPOSE:
{   This module contains the procedures used to initialize the system at system core time.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmc$logical_unit_constants
*copyc dpt$rb_display_request
*copyc dst$image_file
*copyc dst$rb_logging_request
*copyc dst$rb_system_deadstart_status
*copyc jst$ijl_lock
*copyc gfc$constants
*copyc jmc$special_dispatch_priorities
*copyc osc$processor_defined_registers
*copyc oss$mainframe_pageable
*copyc oss$job_fixed
*copyc ost$processor_id_set
*copyc ost$recover_system_set_phase
*copyc tmt$rb_initiate_task
?? POP ??
*copyc cmp$configure_system_device
*copyc cmp$create_cm_device_files
*copyc dmp$activate_volume
*copyc dmp$system_initialization
*copyc dpp$configure_system_console
*copyc dsp$add_to_pp_library
*copyc dsp$advance_deadstart_sequence
*copyc dsp$build_mainframe_information
*copyc dsp$build_recovery_segment
*copyc dsp$create_pp_library
*copyc dsp$create_system_files
*copyc dsp$get_cpu_attributes
*copyc dsp$get_entry_from_ssr
*copyc dsp$fetch_boot_data
*copyc dsp$initialize_sys_msg_buffer
*copyc dsp$make_ssr_segment
*copyc dsp$prepare_deadstart_io
*copyc dsp$retrieve_mf_element_entry
*copyc dsp$save_sys_status_build_level
*copyc dsp$setup_170_request_interlock
*copyc dsp$setup_deadstart
*copyc dsp$setup_load_ppu_interlocks
*copyc i#call_monitor
*copyc jmp$activate_sys_job_template
*copyc jmp$init_cpu_dependent_names
*copyc jmp$initialize_ajl_ijl
*copyc jmp$job_monitor_xcb
*copyc jmp$load_sys_job_template
*copyc jmp$save_system_core_template
*copyc mmp$assign_device_shared_segs
*copyc mmp$disable_transient_segments
*copyc mmp$initialize
*copyc mmp$job_multiprocessing_control
*copyc mmp$pft_initialize
*copyc mmp$write_all_segments_to_disk
*copyc osp$define_cpu
*copyc osp$get_global_cpu_model_def
*copyc osp$initialize_date_time
*copyc osp$initialize_ptl
*copyc osp$initialize_signature_lock
*copyc osp$reset_heap
*copyc osp$set_global_cpu_model_def
*copyc osp$system_error
*copyc syp$check_system_level
*copyc syp$determine_mainframe_type
*copyc syp$display_deadstart_message
*copyc syp$outward_call
*copyc syp$prepare_deadstart_display
*copyc syp$process_deadstart_commands
*copyc syp$process_deadstart_status
*copyc syp$trace_deadstart_message
?? EJECT ??
*copyc cmv$system_device_data
*copyc dmv$system_device_information
*copyc dsv$ignore_image
*copyc dsv$mainframe_type
*copyc dsv$system_deadstart_status_p
*copyc gfv$null_sfid
*copyc jmv$jcb
*copyc mmv$image_file
*copyc mmv$manage_memory_utility
*copyc mmv$page_map_offsets
*copyc mmv$tick_time
*copyc mtv$scb
*copyc mtv$sys_core_init_complete
*copyc mtv$xp_initial_value
*copyc osv$180_memory_limits
*copyc osv$cpus_logically_on
*copyc osv$cpus_physically_configured
*copyc osv$deadstart_phase
*copyc osv$job_fixed_heap
*copyc osv$mainframe_wired_cb_heap
*copyc osv$mainframe_wired_heap
*copyc osv$page_size
*copyc pmv$quantum
*copyc tmv$job_debug_ring_p
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??
  VAR
    dsv$automatic_system_restart: [XDCL] boolean := FALSE,

    jmv$system_job_template_name: [XDCL] ost$name := 'sj',
    jsv$ijl_relink_lock: [XREF] jst$ijl_lock,
    osv$mainframe_pageable_heap: [XDCL, #GATE, oss$mainframe_pageable] ^ost$heap,

    osv$recover_system_set_phase: [XDCL, #GATE] ost$recover_system_set_phase := osc$recovery_not_required,
    syv$image_file_adtt_ptr: [XDCL] ^cell := NIL,
    syv$job_template_cbp: [XDCL, oss$job_fixed] ost$external_code_base_pointer,
    syv$system_job_multiprocessing: [XDCL] boolean := FALSE,

    tmv$job_debug_ring: [XDCL, oss$job_fixed] ost$ring := 0,

    system_task_initialized: boolean := FALSE;

?? OLDTITLE ??
?? NEWTITLE := 'make_outward_call', EJECT ??

{ PURPOSE:
{   This procedure makes an outward call to the correct execution control block.

  PROCEDURE make_outward_call
    (VAR xcb_p: ^ost$execution_control_block);

    VAR
      pva: ost$pva,
      stack_pp: ^^cell;

    pva := xcb_p^.xp.tos_registers [3].pva;
    xcb_p^.xp.tos_registers [3].pva.offset := xcb_p^.xp.tos_registers [3].pva.offset + 416;
    stack_pp := #LOC (pva);
    syp$outward_call (^syv$job_template_cbp, stack_pp^, 3);

  PROCEND make_outward_call;
?? OLDTITLE ??
?? NEWTITLE := 'retrieve_cpu_dependent_values', EJECT ??

{ PURPOSE:
{   This procedure initializes CPU dependent values.

  PROCEDURE retrieve_cpu_dependent_values;

    TYPE
      t$a0_a1_offsets = RECORD
        fill1: string (12),
        a0_offset: 0 .. 0ffffffff(16),
        fill2: string (4),
        a1_offset: 0 .. 0ffffffff(16),
      RECEND;

    VAR
      a0_a1_offsets_p: ^t$a0_a1_offsets,
      global_processor_model_def: ost$processor_model_definition;

    osp$set_global_cpu_model_def;

    osp$get_global_cpu_model_def (global_processor_model_def);
    pmv$quantum := global_processor_model_def.quantum;
    mmv$tick_time := global_processor_model_def.tick_time;

    { The default values of the variables managed by the Manage Memory Utility have already been saved in the
    { procedure mmp$initialize in mmm$deadstart_initialization.  But now mmv$tick_time has been reset.
    { Therefore reset the default in mmv$manage_memory_utility

    mmv$manage_memory_utility.ma [mmc$mmu_ma_tt].default := mmv$tick_time;

    mtv$xp_initial_value.tos_registers[1].pva.offset := mmv$page_map_offsets [mmc$pmo_r1_stack] *
          osv$page_size + mmc$ring_crossing_offset;
    mtv$xp_initial_value.tos_registers[2].pva.offset := mmv$page_map_offsets [mmc$pmo_r2_stack] *
          osv$page_size + mmc$ring_crossing_offset;
    mtv$xp_initial_value.tos_registers[3].pva.offset := mmv$page_map_offsets [mmc$pmo_r3_stack] *
          osv$page_size + mmc$ring_crossing_offset;
    a0_a1_offsets_p := #LOC (mtv$xp_initial_value);
    a0_a1_offsets_p^.a0_offset := mmv$page_map_offsets [mmc$pmo_r1_stack] * osv$page_size +
          mmc$ring_crossing_offset;
    a0_a1_offsets_p^.a1_offset := mmv$page_map_offsets [mmc$pmo_r1_stack] * osv$page_size +
          mmc$ring_crossing_offset;

  PROCEND retrieve_cpu_dependent_values;
?? OLDTITLE ??
?? NEWTITLE := 'osp$initialize', EJECT ??

{ PURPOSE:
{   This procedure is the starting procedure for jobs, including the system job.

  PROGRAM [XDCL] osp$initialize;

    VAR
      activate_message: string (20),
      boot_data_seq_p: ^SEQ ( * ),
      cpu_attributes: dst$cpu_attributes,
      cpu_index: 0 .. osc$max_number_of_processors,
      display_rb: dpt$rb_display_request,
      dft_rb: dst$rb_logging_request,
      ds_rb: dst$rb_system_deadstart_status,
      image_length: dst$ssr_entry,
      limit: integer,
      name: ost$name,
      ptl_register: integer,
      rb: tmt$rb_initiate_task,
      status: ost$status,
      test_offset: integer,
      xcb_p: ^ost$execution_control_block;

    xcb_p := jmp$job_monitor_xcb ();

    IF system_task_initialized THEN
      make_outward_call (xcb_p);
    IFEND;

    system_task_initialized := TRUE;

    { Initialize the XCB.

    xcb_p^.dispatching_priority := jmc$priority_system_job;
    xcb_p^.dispatching_priority_bias_id := jmc$dpb_absolute;
    xcb_p^.relative_task_priority := 128;
    xcb_p^.pit_count := 7fffffff(16);
    xcb_p^.iocb_p := NIL;
    xcb_p^.assign_active_sfid := gfv$null_sfid;
    xcb_p^.processor_selections := - $ost$processor_id_set [ ];
    xcb_p^.requested_processor_selections := $ost$processor_id_set [ ];
    xcb_p^.task_kind := osc$tk_nosve_task;
    jmv$jcb.jcb_identifier := 0ff00(16);
    jmv$jcb.cptime_next_age_working_set := 20000000;
    jmv$jcb.page_aging_interval         := 20000000;
    jmv$jcb.cyclic_aging_interval       := 10000000;
    jmv$jcb.next_cyclic_aging_time := #free_running_clock (0) + 60000000;
    jmv$jcb.max_working_set_size := 5000;
    jmv$jcb.min_working_set_size := 20;
    jmv$jcb.detached_job_wait_time := 0;
    jmv$jcb.signal_interval := 0ffffffff(16);
    tmv$job_debug_ring_p := #LOC (tmv$job_debug_ring);

    { Set image file active so that memory manager will use deadstart upper limit as upper bound of
    { available memory when assigning pages on page faults.

    mmv$image_file.active := TRUE;

    { Define the upperbound of memory to be used during deadstart, it will be restricted to the size of the
    { memory image.  Cannot use all of memory on a recovery deadstart until recovery is complete.

    osv$page_size := 512 * (128 - #READ_REGISTER (osc$pr_page_size_mask));
    osv$180_memory_limits.lower := ((osv$180_memory_limits.lower + osv$page_size - 1) DIV osv$page_size) *
          osv$page_size;

    IF osv$180_memory_limits.upper > (osv$180_memory_limits.lower + dsc$image_size) THEN
      osv$180_memory_limits.deadstart_upper := osv$180_memory_limits.lower + dsc$image_size;
    ELSE
      osv$180_memory_limits.deadstart_upper := osv$180_memory_limits.upper;
    IFEND;

    mmp$initialize;

    limit := gfc$fde_table_base - #OFFSET (osv$mainframe_wired_heap) - 50000;
    osp$reset_heap (osv$mainframe_wired_heap, limit, TRUE, 1);
    osp$reset_heap (osv$mainframe_wired_cb_heap, 3fffffff(16), TRUE, 1);
    osp$reset_heap (osv$mainframe_pageable_heap, 3fffffff(16), TRUE, 1);

    syp$determine_mainframe_type;

    { Set up the variables to the DFT block.

    dft_rb.reqcode := syc$rc_logging_request;
    dft_rb.action := dsc$rla_dft_setup_variables;
    i#call_monitor (#LOC (dft_rb), #SIZE (dft_rb));

    dsp$make_ssr_segment;

    IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
      ds_rb.reqcode := syc$rc_system_deadstart_status;
      ds_rb.action := dsc$rb_sds_retrieve_bct_flag;
      ds_rb.bct_flags := dsc$rb_sds_bct_ar_control;
      i#call_monitor (#LOC (ds_rb), #SIZE (ds_rb));
      dsv$automatic_system_restart := NOT ds_rb.bct_flag_set;
    ELSE
      dsv$automatic_system_restart := FALSE;
    IFEND;

    { Retrieve the System Deadstart Status variable from the boot memory.

    ALLOCATE dsv$system_deadstart_status_p IN osv$mainframe_wired_heap^;
    boot_data_seq_p := #SEQ (dsv$system_deadstart_status_p^);
    dsp$fetch_boot_data (dsc$boot_system_ds_status, boot_data_seq_p);

    { Set the build level in the System Deadstart Status data.

    dsp$save_sys_status_build_level;

    { Initialize the job fixed heap.

    osp$reset_heap (osv$job_fixed_heap, 100000000, TRUE, 1);

    { This next procedure must be done very early to prepare the displays for output.  Anything done
    { before this procedure will not be able to write to the screen.

    dpp$configure_system_console;
    syp$prepare_deadstart_display;
    dsp$build_mainframe_information;

    { The following code is to verify that the JCB and XCB have not grown to
    { beyond the defined size limits. The assembly language size constraints must
    { be greater than or equal to the size of the structure. The assembly
    { language constants are defined in the module SYA$CONSTANTS.

    test_offset := #OFFSET (xcb_p);
    IF #SIZE (jmv$jcb) > test_offset THEN
      syp$process_deadstart_status ('Job Control Block Overflow.', TRUE, status);
    IFEND;

    test_offset := xcb_p^.sdt_offset;
    IF #SIZE (xcb_p^) > test_offset THEN
      syp$process_deadstart_status ('Execution Control Block Overflow.', TRUE, status);
    IFEND;

    { Initialize the signature lock variables used by the deadstart area.

    dsp$setup_load_ppu_interlocks;
    dsp$setup_170_request_interlock;

    { Initialize the buffer used to hold messages from monitor destined for the engineering log.

    dsp$initialize_sys_msg_buffer;

    syp$display_deadstart_message ('Initializing production environment ...');

    osp$initialize_date_time (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Error initializing date and time:', TRUE, status);
    IFEND;

    { Check the system level number in the SSR for compatability between VCB and system core.

    syp$check_system_level;

    dsp$advance_deadstart_sequence (dsc$dss_ssr_built);

    { Create the PP library.

    dsp$create_pp_library;

    { The call to retrieve_cpu_dependent_values must come before the call to syp$process_deadstart_commands.

    retrieve_cpu_dependent_values;

    { Prepare the deadstart device environment.  Retrieve the system device data from the boot memory.

    boot_data_seq_p := #SEQ (cmv$system_device_data);
    dsp$fetch_boot_data (dsc$system_device_data, boot_data_seq_p);

    dmv$system_device_product_id := cmv$system_device_data [cmc$sdt_disk_device].unit_id;

    cmp$configure_system_device (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Error configuring the system device:', TRUE, status);
    IFEND;

    dsp$prepare_deadstart_io (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Error preparing deadstart input:', TRUE, status);
    IFEND;

    dmv$system_device_lun := cmc$job_template_unit_ordinal;

    syp$process_deadstart_commands (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Error reading deadstart commands:', TRUE, status);
    IFEND;
    dsp$advance_deadstart_sequence (dsc$dss_dcfile_read);

    { Set the console bell status from the system attribute.

    display_rb.reqcode := syc$rc_update_system_display;
    display_rb.action := dpc$da_set_console_bell_status;
    i#call_monitor (#LOC (display_rb), #SIZE (display_rb));

    { Mmp$disable_transient_segments MUST be done AFTER syp$process_deadstart_commands.

    mmp$disable_transient_segments;

    dsp$get_cpu_attributes (cpu_attributes);
    osv$cpus_physically_configured := cpu_attributes.count;
    osv$cpus_logically_on := 0;

    mtv$scb.cpus.logically_on := $ost$processor_id_set [];
    FOR cpu_index := 0 TO cpu_attributes.count - 1 DO
      IF cpu_attributes.cpu [cpu_index].state = cmc$on THEN
        osv$cpus_logically_on := osv$cpus_logically_on + 1;
        mtv$scb.cpus.logically_on := mtv$scb.cpus.logically_on + $ost$processor_id_set [cpu_index];
      IFEND;
      xcb_p^.requested_processor_selections := xcb_p^.requested_processor_selections +
            $ost$processor_id_set [cpu_index];
    FOREND;
    xcb_p^.processor_selections := mtv$scb.cpus.logically_on;
    mtv$scb.cpus.available_for_use := mtv$scb.cpus.logically_on;

    syp$trace_deadstart_message ('initialize cpu dependent names');
    jmp$init_cpu_dependent_names (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Error initializing cpu dependent names:', TRUE, status);
    IFEND;

    syp$trace_deadstart_message ('initialize system tables');
    jmp$initialize_ajl_ijl;

    { Initialize the dispatcher tables and variables.  Allocate the PTL, make a PTL entry for the
    { preloaded system task and enter the system task into the dispatcher tables.

    osp$initialize_ptl;
    rb.xcb_p := jmp$job_monitor_xcb ();
    rb.reqcode := syc$rc_initiate_task;
    rb.wait := osc$nowait;
    i#call_monitor (#LOC (rb), #SIZE (rb));

    mmp$pft_initialize;
    syp$trace_deadstart_message ('save system core template');
    jmp$save_system_core_template (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Error saving system core template:', TRUE, status);
    IFEND;

    { Set up multiprocessing attributes.

    IF osv$cpus_physically_configured > 1 THEN
      osp$define_cpu (cpu_attributes);
    IFEND;

    { Initialize device management. Initialize volume, volume online and table initialization.
    { Does not activate the volume.

    syp$trace_deadstart_message ('device initialization');
    dmp$system_initialization (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Error in device initialization:', TRUE, status);
    IFEND;

    IF (osv$deadstart_phase = osc$installation_deadstart) THEN
       syp$trace_deadstart_message ('building recovery segment');
       dsp$build_recovery_segment;
    IFEND;

    { Establish recovery status from 'memory image file' on system device, also recover 'old'
    { mainframe_wired_segment.

    syp$trace_deadstart_message ('setup deadstart environment');
    dsp$setup_deadstart;

    { Paging to mass storage, device files only is allowed at this point.

    dsp$advance_deadstart_sequence (dsc$dss_install_templates);
    name := jmv$system_job_template_name;

    IF osv$deadstart_phase = osc$installation_deadstart THEN
      syp$trace_deadstart_message ('creating cm device files');
      cmp$create_cm_device_files (status);
      IF NOT status.normal THEN
        syp$process_deadstart_status ('Error in creating cm device files:', TRUE, status);
      IFEND;

      dsp$create_system_files (status);
      IF NOT status.normal THEN
        syp$process_deadstart_status ('Error in creating system files:', TRUE, status);
      IFEND;
    IFEND;

    syp$trace_deadstart_message ('add the non boot drivers to the pp library');
    dsp$add_to_pp_library;

    syp$trace_deadstart_message ('loading template files');
    jmp$load_sys_job_template (name, status);
    IF NOT status.normal THEN
       syp$process_deadstart_status ('Error in loading template files:', TRUE, status);
    IFEND;

    syp$trace_deadstart_message ('activate system device');
    dmp$activate_volume (dmv$system_device_lun, status);
    activate_message := 'ACTIVATING ';
    activate_message (12, *) := dmv$system_device_recorded_vsn;
    syp$trace_deadstart_message (activate_message);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Error in activating system device:', TRUE, status);
    IFEND;

    dsp$advance_deadstart_sequence (dsc$dss_templates_installed);

    { Activate the job template.

    syp$trace_deadstart_message ('activate system job template');
    jmp$activate_sys_job_template (name, syv$job_template_cbp, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Error in activating job template:', TRUE, status);
    IFEND;

    { End of system core initialization.

    mtv$sys_core_init_complete := TRUE;

    { At this point memory manager is completely initialized with full capabilities.
    { Flush all segments to disk.

    jsv$ijl_relink_lock.lock := FALSE;


    syp$trace_deadstart_message ('writing system core to disk');
    mmp$write_all_segments_to_disk (status);
    IF NOT status.normal THEN
      syp$process_deadstart_status ('Error in writing system core:', TRUE, status);
    IFEND;
    IF syv$system_job_multiprocessing THEN
      mmp$job_multiprocessing_control (TRUE, status);
    IFEND;

    syp$trace_deadstart_message ('outward call to job template');
    dsp$advance_deadstart_sequence (dsc$dss_outward_call_to_jt);

    make_outward_call (xcb_p);

  PROCEND osp$initialize;
?? OLDTITLE ??
MODEND sym$deadstart_initialization;
*DECK DECK=SYM$DEBUG EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE System Core Debugger' ??
MODULE sym$debug;
{
{ PURPOSE:
{   This module contains the processors for all of the subcommands of the System Core Debugger utility except
{   DISPLAY_JOB_TABLES, which is located in the partner module SYM$DEBUG1.
{
{ NOTE:
{   Additions/deletions/changes to the commands and displays in this module and SYM$DEBUG1 may require an
{   update to the System Performance and Analysis Manual, Volume 2 (SPAM).
{
?? PUSH (LISTEXT := ON) ??
*copyc avv$security_options
*copyc amc$condition_code_limits
*copyc amt$file_byte_address
*copyc ame$lfn_program_actions
*copyc cle$ecc_lexical
*copyc dmt$error_condition_codes
*copyc dmt$active_volume_table_index
*copyc fme$file_management_errors
*copyc gft$file_descriptor_control
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc jmt$system_supplied_name
*copyc lgt$display_parameters
*copyc lot$loader_type_definitions
*copyc lot$task_services_entry_point
*copyc mmd$segment_access_condition
*copyc osc$processor_defined_registers
*copyc osc$purge_map_and_cache
*copyc osd$conditions
*copyc osd$integer_limits
*copyc osd$random_name
*copyc osd$registers
*copyc osd$virtual_address
*copyc osk$common_keypoint_definitions
*copyc osk$keypoint_class_codes
*copyc oss$job_fixed
*copyc oss$mainframe_pageable
*copyc oss$mainframe_paged_literal
*copyc ost$caller_identifier
*copyc ost$execution_control_block
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc pmd$system_log_interface
*copyc pme$logging_exceptions
*copyc pmt$processor_attributes
*copyc ptk$performance_keypoints
*copyc syt$debug_control
*copyc syt$debug_output_disposal_info
*copyc syt$debug_output_disposition
*copyc syt$user_defined_condition
*copyc syt$value_kinds
*copyc tmt$broken_task_monitor_fault
*copyc tmt$mcr_faults
*copyc tmt$rb_delay
*copyc tmt$rb_update_job_task_enviro
*copyc tmt$signal
*copyc tmt$signal_buffer
*copyc tmt$signal_buffers
?? POP ??
?? NEWTITLE := '  External procedures and variables referenced in this module', EJECT ??

*copyc clp$trimmed_string_size
*copyc dpp$change_window
*copyc dpp$get_next_line
*copyc dpp$get_number_lines_in_window
*copyc dpp$open_window
*copyc dpp$put_critical_message
*copyc dpp$put_next_line
*copyc gfp$get_fde_p
*copyc i#call_monitor
*copyc i#current_sequence_position
*copyc i#disable_traps
*copyc i#enable_traps
*copyc i#program_error
*copyc i#real_memory_address
*copyc i#restore_traps
*copyc jmp$find_jsn
*copyc lgp$add_entry_to_system_log
*copyc lgp$get_log_entry
*copyc lgp$get_log_read_information
*copyc mmp$get_segment_length_r1
*copyc mmp$open_file_by_sfid
*copyc mmp$close_device_file
*copyc mmp$free_pages
*copyc mmp$get_sdt_entry_p
*copyc mmp$get_sdtx_entry_p
*copyc ocp$find_debug_address
*copyc ocp$find_debug_entry_point
*copyc ocp$find_debug_module_item
*copyc osp$begin_text_dump
*copyc osp$clear_signature_lock
*copyc osp$end_text_dump
*copyc osp$output_debug_heading
*copyc osp$output_debug_text
*copyc osp$randomize_name
*copyc osp$set_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$simulate_disk_fault_r1
*copyc osp$test_signature_lock
*copyc pmp$get_legible_date_time
*copyc pmp$get_processor_attributes
*copyc pmp$get_os_version
*copyc pmp$find_executing_task_xcb
*copyc pmp$delay
*copyc syp$binary_to_ascii
*copyc syp$cause_condition
*copyc syp$crack_command
*copyc syp$jobfileproc
*copyc syp$process_command_line
*copyc syp$process_core_commands
*copyc syp$purge_instruction_stack
*copyc syp$establish_condition_handler
*copyc syp$test_job_recovery
*copyc dmv$active_volume_table
*copyc dmv$number_unavailable_volumes

  VAR
    gfv$fde_control_table_base: [XREF, oss$mainframe_wired] integer;

*copyc jmv$ajl_p
*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc jmv$jmtr_xcb
*copyc jmv$max_ajl_ordinal_in_use

  VAR
    job_xcb_list: [XREF, oss$job_fixed] record
      head: ^ost$execution_control_block,
      lock: ost$signature_lock,
    recend;

*copyc mmv$tables_initialized
*copyc mtv$halt_cpu_ring_number
*copyc mtv$mx_ajl_entries
*copyc osv$dump_when_debug
*copyc osv$mainframe_pageable_heap
*copyc osv$mainframe_wired_heap
*copyc osv$job_fixed_heap
*copyc syv$all_jobs_selected_for_debug
*copyc syv$db_page_wait_lines_instance
*copyc syv$debug_control
*copyc syv$debug_output_disposition
*copyc syv$debugger_display_id
*copyc syv$dflt_debug_output_disposal
*copyc syv$inhibit_core_cmd_logging

  VAR
    syv$jfile_pdt: [XREF, READ, oss$mainframe_paged_literal] array [1 .. 3] of syt$parameter_descriptor;

*copyc syv$nosve_job_template
*copyc syv$terminate_sysdebug_output
*copyc tmv$job_debug_ring
*copyc tmv$halt_on_hung_task
*copyc tmv$tables_initialized
?? OLDTITLE ??
?? NEWTITLE := '  CONST definitions for data structures used in this module', EJECT ??

  CONST
    add_to_eol = TRUE,
    dbc$max_auto_cmds = 20,
    dbc$max_auto_cmd_length = 30,
    dbc$maximum_defined_commands = 50,
    dbe$ = 900000;

?? OLDTITLE ??
?? NEWTITLE := '  TYPE definitions for data structures used in this module', EJECT ??

  TYPE
    auto_command = record
      command: string (dbc$max_auto_cmd_length),
      jobmntr_execution_only: boolean,
    recend,

    condition_names = record
      name: string (8),
      c_ord: debug_condition,
      ucr_ord: ost$user_condition,
    recend,

    condition_reg_image = packed record
      case 0 .. 1 of
      = 0 =
        ucr_a: packed array [ost$user_condition] of boolean,
        mcr_a: packed array [ost$monitor_condition] of boolean,
        ucm_a: packed array [ost$user_condition] of boolean,
      = 1 =
        ucr_i: 0 .. 0ffff(16),
        mcr_i: 0 .. 0ffff(16),
        ucm_i: 0 .. 0ffff(16),
      casend
    recend,

    debug_condition = (dc_read, dc_write, dc_rni, dc_branch, dc_call, dc_divflt, dc_aof, dc_exof, dc_exuf,
          dc_fplos, dc_fpindef, dc_alos, dc_invbdp),

    debug_list = record
      hdwr_entry: array [1 .. 32] of hdwr_section_entry,
      sfwr_entry: array [1 .. 32] of sfwr_section_entry,
      select_count: array [debug_condition] of integer,
      eol_index: 0 .. 32,
    recend,

    debug_list_pointer = record
      case 0 .. 2 of
      = 0 =
        int: integer,
      = 1 =
        fill1: 0 .. 0ffff(16),
        list_p: ^debug_list,
      = 2 =
        fill2: 0 .. 0ffff(16),
        cell_p: ^cell,
      casend
    recend,

    debug_mask = packed record
      case 0 .. 2 of
      = 0 =
        int: 0 .. 07f(16),
      = 1 =
        fill1: 0 .. 3,
        condition: packed array [dc_read .. dc_call] of boolean,
      = 2 =
        os_code: ost$debug_mask,
      casend
    recend,

    frame_descriptor = packed record
      critical_frame: boolean,
      on_condition: boolean,
      fill1,
      fill2: boolean,
      x_start: 0 .. 15,
      a_terminate: 0 .. 15,
      x_terminate: 0 .. 15,
    recend,

    gtid_converter = record
      case 0 .. 1 of
      = 0 =
        base: 0 .. 0fffff(16),
      = 1 =
        global_task_id: ost$global_task_id,
      casend,
    recend,

    hdwr_section_entry = packed record
      condition: packed array [dc_read .. dc_call] of boolean,
      eol: boolean,
      fill1: 0 .. 3,
      fill2: 0 .. 0fff(16),
      segment: 0 .. 0fff(16),
      lobyte: 0 .. 0ffffffff(16),
      fill3: 0 .. 0ffffffff(16),
      hibyte: 0 .. 0ffffffff(16),
    recend,

    debug_sfid_converter = record
      case boolean of
      = TRUE =
        int: 0 .. 0ffffffff(16),
      = FALSE =
        sfid: gft$system_file_identifier,
      casend,
    recend,

    sfwr_section_entry = record
      name: string (8),
      condition: packed array [debug_condition] of boolean,
      hscnt: 0 .. 7f(16),
      segment: 0 .. 0fff(16),
      lobyte: 0 .. 0ffffffff(16),
      fill2: 0 .. 0ffffffff(16),
      hibyte: 0 .. 0ffffffff(16),
    recend,

    stack_afield = packed record
      fill1: 0 .. 0ffff(16),
      pva: ost$pva,
    recend,

    stack_frame_areg_image = packed record
      p_reg: ost$p_register,
      reg: array [0 .. 0f(16)] of stack_afield,
    recend,

    stack_frame_control_image = packed record
      p_reg: ALIGNED ost$p_register,
      fill0: 0 .. 0f(16),
      vmid: 0 .. 0f(16),
      fill1: 0 .. 0ff(16),
      dsp: ALIGNED ^cell,
      frame_desc: frame_descriptor,
      csf: ALIGNED ^cell,
      user_condition_mask: packed array [ost$user_condition] of boolean,
      psa: ALIGNED ^cell,
      fill2: 0 .. 0ffff(16),
      bsp: ALIGNED ^cell,
      user_condition: packed array [ost$user_condition] of boolean,
      arg: ^cell,
      monitor_condition: packed array [ost$monitor_condition] of boolean,
      fill3: 0 .. 0ffffffffffff(16),
    recend,

    stack_frame_xreg_image = record
      p_reg: ost$p_register,
      reg: array [0 .. 32] of stack_xfield,
    recend,

    stack_image_pointer = record
      case 0 .. 4 of
      = 0 =
        control: ^stack_frame_control_image,
      = 1 =
        aregs: ^stack_frame_areg_image,
      = 2 =
        xregs: ^stack_frame_xreg_image,
      = 3 =
        cell_p: ^cell,
      = 4 =
        pva: ost$pva,
      casend
    recend,

    stack_xfield = record
      lhalf: 0 .. 0ffffffff(16),
      rhalf: 0 .. 0ffffffff(16),
    recend;

?? OLDTITLE ??
?? NEWTITLE := '  Global declarations declared in this module' ??
?? NEWTITLE := '    - Variables', EJECT ??

  VAR
    syv$db_displayed_console_lines: [XDCL] integer := 0,
    repress_headers_flag: boolean := FALSE,
    display_id: dpt$window_id := 0,
    est_flag: boolean := FALSE,
    last_dm_count: integer := 0,
    last_dm_pva: ^cell := NIL,
    monitor_faults: tmt$monitor_fault_buffer,
    nosve_template_ptr_array: ^array [1 .. * ] of ^cell := NIL,
    syv$debug_line_count: [XDCL] integer := 0,
    syv$debug_list: [STATIC, oss$mainframe_pageable] debug_list,
    syv$debug_output_disposal_info: [XDCL] syt$debug_output_disposal_info,
    syv$debugger_page_wait_lines: [XDCL] integer := 0,
    syv$debugger_task_timeout: boolean := FALSE,
    syv$dump_to_pf: [XDCL] boolean := FALSE,
    syv$job_template_ptr_array: [XDCL, oss$job_fixed] ^array [1 .. * ] of ^cell := NIL,
    syv$max_debug_output_lines: [XDCL] integer := 10000,
    syv$repeatable_command_p: [XDCL] ^string ( * ) := NIL;

?? OLDTITLE ??
?? NEWTITLE := '    - Conversion tables ', EJECT ??

{ The following translation table is used to translate the TYPE boolean into displayable strings.

  VAR
    boolean_translations: [READ, oss$mainframe_paged_literal] array [boolean] of string (5) := ['FALSE',
          'TRUE '];

  VAR
    cond_conv_tbl: [READ, oss$mainframe_paged_literal] array [debug_condition] of condition_names := [
{   } ['READ    ', dc_read, osc$debug],
{   } ['WRITE   ', dc_write, osc$debug],
{   } ['RNI     ', dc_rni, osc$debug],
{   } ['BRANCH  ', dc_branch, osc$debug],
{   } ['CALL    ', dc_call, osc$debug],
{   } ['DIVFLT  ', dc_divflt, osc$divide_fault],
{   } ['AROVFL  ', dc_aof, osc$arithmetic_overflow],
{   } ['EXOVFL  ', dc_exof, osc$exponent_overflow],
{   } ['EXUNFL  ', dc_exuf, osc$exponent_underflow],
{   } ['FPLOS   ', dc_fplos, osc$fp_significance_loss],
{   } ['FPINDEF ', dc_fpindef, osc$fp_indefinite],
{   } ['ARLOS   ', dc_alos, osc$arithmetic_significance],
{   } ['INVBDP  ', dc_invbdp, osc$invalid_bdp_data]],

    cond_conv_tbl2: [READ, oss$mainframe_paged_literal] array [osc$divide_fault .. osc$invalid_bdp_data] of
          condition_names := [
{   } ['divflt  ', dc_divflt, osc$divide_fault],
{   } ['debug   ', * , osc$debug],
{   } ['arovfl  ', dc_aof, osc$arithmetic_overflow],
{   } ['exovfl  ', dc_exof, osc$exponent_overflow],
{   } ['exunfl  ', dc_exuf, osc$exponent_underflow],
{   } ['fplos   ', dc_fplos, osc$fp_significance_loss],
{   } ['fpindef ', dc_fpindef, osc$fp_indefinite],
{   } ['arlos   ', dc_alos, osc$arithmetic_significance],
{   } ['invbdp  ', dc_invbdp, osc$invalid_bdp_data]];

?? OLDTITLE ??
?? NEWTITLE := '    - Commands and their parameter_descriptor_tables', EJECT ??

  VAR

{ The following list of commands are executed when the AUTO procedure is called.

    auto_cmds: array [1 .. dbc$max_auto_cmds] of auto_command := [
{   } ['DISECB', FALSE],
{   } ['DISMF', FALSE],
{   } ['DISAJL', TRUE],
{   } ['DISIJLE', TRUE],
{   } ['DISTE', TRUE],
{   } ['DISSE', FALSE],
{   } ['DISJL ALL', TRUE],
{   } ['DISM 00300000000 1000000(16)', TRUE],
{   } ['DISM 00400000000 1000000(16)', TRUE],
{   } ['DISM 00500000000 1000000(16)', FALSE],
{   } ['DISM 00600000000 1000000(16)', TRUE],
{   } ['DISTB 1 1000', FALSE],
{   } ['DISFDT', FALSE],
{   } REP dbc$max_auto_cmds - 13 of ['    ', FALSE]],

    command_table: [READ, oss$mainframe_paged_literal] array [1 .. (2 * dbc$maximum_defined_commands) + 1] of
          syt$command_table_entry := [

{ New command order and aliases:

{   } ['AUTO    ', 'AUTO                           ', FALSE, ^xqtautoproc],
{   } ['CHAB    ', 'CHANGE_BREAKPOINT              ', FALSE, ^mod_breakpoint],
{   } ['CHAM    ', 'CHANGE_MEMORY                  ', TRUE, ^cmproc],
{   } ['DISACL  ', 'DISPLAY_AUTO_COMMAND_LIST      ', TRUE, ^disdclproc],
{   } ['DISAJL  ', 'DISPLAY_ACTIVE_JOB_LIST        ', TRUE, ^disajlproc],
{   } ['DISC    ', 'DISPLAY_CALLS                  ', TRUE, ^trace_back],
{   } ['DISEST  ', 'DISPLAY_ENTIRE_SEGMENT_TABLE   ', TRUE, ^disestproc],
{   } ['DISECB  ', 'DISPLAY_EXECUTION_CONTROL_BLOCK', TRUE, ^disxcbproc],
{   } ['DISFDC  ', 'DISPLAY_FILE_DESCRIPTOR_CONTROL', TRUE, ^disfdc_proc],
{   } ['DISFDT  ', 'DISPLAY_FILE_DESCRIPTOR_TABLE  ', TRUE, ^disfdt_proc],
{   } ['DISIJLE ', 'DISPLAY_INITIATED_JOB_LIST_ENT ', TRUE, ^disijlproc],
{   } ['DISJL   ', 'DISPLAY_JOB_LOG                ', TRUE, ^disjlproc],
{   } ['DISJT   ', 'DISPLAY_JOB_TABLES             ', TRUE, ^syp$jobfileproc],
{   } ['DISM    ', 'DISPLAY_MEMORY                 ', TRUE, ^dmproc],
{   } ['DISMF   ', 'DISPLAY_MONITOR_FAULT          ', TRUE, ^dismfproc],
{   } ['DISOSA  ', 'DISPLAY_OS_ADDRESS             ', TRUE, ^disosaproc],
{   } ['DISOSS  ', 'DISPLAY_OS_SYMBOL              ', TRUE, ^disostproc],
{   } ['DISR    ', 'DISPLAY_REGISTER               ', TRUE, ^reg_display],
{   } ['DISST   ', 'DISPLAY_SEGMENT_TABLE          ', TRUE, ^disstproc],
{   } ['DISSTE  ', 'DISPLAY_SEGMENT_TABLE_EXTENDED ', TRUE, ^disstxproc],
{   } ['DISSE   ', 'DISPLAY_STACK_ENVIRONMENT      ', TRUE, ^disseproc],
{   } ['DISSF   ', 'DISPLAY_STACK_FRAME            ', TRUE, ^stack_display],
{   } ['DISSFID ', 'DISPLAY_SYSTEM_FILE_ID         ', TRUE, ^dissfid_proc],
{   } ['DISSL   ', 'DISPLAY_SYSTEM_LOG             ', TRUE, ^disslproc],
{   } ['DISTE   ', 'DISPLAY_TASK_ENVIRONMENT       ', TRUE, ^disteproc],
{   } ['DISTB   ', 'DISPLAY_TRACE_BACK             ', TRUE, ^trace_back],
{   } ['DOWV    ', 'DOWN_VOLUME                    ', FALSE, ^down_volume],
{   } ['HANT    ', 'HANG_TASK                      ', FALSE, ^hangproc],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['KILT    ', 'KILL_TASK                      ', FALSE, ^kill_task_proc],
{   } ['LISB    ', 'LIST_BREAKPOINTS               ', TRUE, ^list_breakpoints],
{   } ['-       ', 'M                              ', FALSE, ^minusproc],
{   } ['+       ', 'P                              ', FALSE, ^plusproc],
{   } ['REMB    ', 'REMOVE_BREAKPOINT              ', FALSE, ^remove_breakpoint],
{   } ['R       ', 'REPEAT                         ', FALSE, ^repeat_proc],
{   } ['SEL     ', 'SELECT                         ', FALSE, ^select_command],
{   } ['SETA    ', 'SET_AUTO_CMD_LIST              ', FALSE, ^setdclproc],
{   } ['SETB    ', 'SET_BREAKPOINT                 ', FALSE, ^set_breakpoint],
{   } ['SETMSF  ', 'SET_MASS_STORAGE_FAULT         ', FALSE, ^setmsf_proc],
{   } ['SETOD   ', 'SET_OUTPUT_DESTINATION         ', FALSE, ^setod_proc],
{   } ['SETPW   ', 'SET_PAGE_WAIT                  ', FALSE, ^setpw_proc],
{   } ['SUPCM   ', 'SUPER_CHANGE_MEMORY            ', TRUE, ^scmproc],
{   } ['TESJR   ', 'TEST_JOB_RECOVERY              ', FALSE, ^syp$test_job_recovery],
{   } ['UPV     ', 'UP_VOLUME                      ', FALSE, ^up_volume],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['HELP    ', 'HELP_FUNCTION                  ', FALSE, ^helpproc],

{ Old command order and aliases (will be deleted in the near future):

{   } ['LB      ', 'LIST_BREAKPOINTS               ', TRUE, ^list_breakpoints],
{   } ['B       ', 'SET_BREAKPOINT                 ', FALSE, ^set_breakpoint],
{   } ['RB      ', 'REMOVE_BREAKPOINT              ', FALSE, ^remove_breakpoint],
{   } ['CB      ', 'CHANGE_BREAKPOINT              ', FALSE, ^mod_breakpoint],
{   } ['DSF     ', 'DISPLAY_STACK_FRAME            ', TRUE, ^stack_display],
{   } ['TB      ', 'TRACE_BACK                     ', TRUE, ^trace_back],
{   } ['DR      ', 'DISPLAY_REGISTER               ', TRUE, ^reg_display],
{   } ['DM      ', 'DISM                           ', TRUE, ^dmproc],
{   } ['CM      ', 'CHAM                           ', TRUE, ^cmproc],
{   } ['SEL     ', 'SELECT                         ', FALSE, ^select_command],
{   } ['SCM     ', 'SUPER_CHANGE_MEMORY            ', TRUE, ^scmproc],
{   } ['DISTE   ', 'DISPLAY_TASK_ENVIRONMENT       ', TRUE, ^disteproc],
{   } ['DISOSS  ', 'DISPLAY_OS_SYMBOL              ', TRUE, ^disostproc],
{   } ['KILT    ', 'KILL_TASK                      ', FALSE, ^kill_task_proc],
{   } ['DISOSA  ', 'DISPLAY_OS_ADDRESS             ', TRUE, ^disosaproc],
{   } ['AUTO    ', 'AUTO                           ', FALSE, ^xqtautoproc],
{   } ['DISXCB  ', 'DISPLAY_XCB                    ', TRUE, ^disxcbproc],
{   } ['DISMF   ', 'DISPLAY_MONITOR_FAULT          ', TRUE, ^dismfproc],
{   } ['+       ', 'P                              ', FALSE, ^plusproc],
{   } ['-       ', 'M                              ', FALSE, ^minusproc],
{   } ['DISSL   ', 'DISPLAY_SYSTEM_LOG             ', TRUE, ^disslproc],
{   } ['DISSE   ', 'DISPLAY_STACK_ENVIRONMENT      ', TRUE, ^disseproc],
{   } ['HANG    ', 'HANG_TASK                      ', FALSE, ^hangproc],
{   } ['DISJL   ', 'DISPLAY_JOB_LOG                ', TRUE, ^disjlproc],
{   } ['DISJT   ', 'DISPLAY_JOB_TABLES             ', TRUE, ^syp$jobfileproc],
{   } ['DISIJL  ', 'DISPLAY_INITIATED_JOB_LIST     ', TRUE, ^disijlproc],
{   } ['DISST   ', 'DISPLAY_SEGMENT_TABLE          ', TRUE, ^disstproc],
{   } ['DISSTX  ', 'DISPLAY_SEGMENT_TABLE_EX       ', TRUE, ^disstxproc],
{   } ['DISEST  ', 'DISPLAY_ENTIRE_SEG_TABLE       ', TRUE, ^disestproc],
{   } ['TESTJR  ', 'TEST_JOB_RECOVERY              ', FALSE, ^syp$test_job_recovery],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['DISAJL  ', 'DISPLAY_ACTIVE_JOB_LIST        ', TRUE, ^disajlproc],
{   } ['R       ', 'REPEAT                         ', FALSE, ^repeat_proc],
{   } ['DOWN    ', 'DOWN_VOLUME                    ', FALSE, ^down_volume],
{   } ['UP      ', 'UP_VOLUME                      ', FALSE, ^up_volume],
{   } ['SETMSF  ', 'SET_MASS_STORAGE_FAULT         ', FALSE, ^setmsf_proc],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['dummy   ', 'dummy_not_used                 ', FALSE, NIL],
{   } ['HELP    ', 'HELP_FUNCTION                  ', FALSE, ^helpproc]],


    param_table: [READ, oss$mainframe_paged_literal] array [1 .. (2 * dbc$maximum_defined_commands) + 1] of
          ^array [ * ] of syt$parameter_descriptor := [

{ New commands and ^parameters:

{     'AUTO                           '} ^auto_pdt,
{     'CHANGE_BREAKPOINT              '} ^change_brkpt_pdt,
{     'CHANGE_MEMORY                  '} ^cm_pdt,
{     'DISPLAY_AUTO_COMMAND_LIST      '} ^disdcl_pdt,
{     'DISPLAY_ACTIVE_JOB_LIST        '} ^ajl_pdt,
{     'DISPLAY_CALLS                  '} ^trace_back_pdt,
{     'DISPLAY_ENTIRE_SEGMENT_TABLE   '} ^disest_pdt,
{     'DISPLAY_EXECUTION_CONTROL_BLOCK'} ^disecb_pdt,
{     'DISPLAY_FILE_DESCRIPTOR_CONTROL'} ^disfdc_pdt,
{     'DISPLAY_FILE_DESCRIPTOR_TABLE  '} ^disfdt_pdt,
{     'DISPLAY_INITIATED_JOB_LIST_ENT '} ^ijl_pdt,
{     'DISPLAY_JOB_LOG                '} ^display_log_pdt,
{     'DISPLAY_JOB_TABLES             '} ^syv$jfile_pdt,
{     'DISPLAY_MEMORY                 '} ^dm_pdt,
{     'DISPLAY_MONITOR_FAULT          '} NIL,
{     'DISPLAY_OS_ADDRESS             '} ^disosa_pdt,
{     'DISPLAY_OS_SYMBOL              '} ^disost_pdt,
{     'DISPLAY_REGISTER               '} ^display_reg_pdt,
{     'DISPLAY_SEGMENT_TABLE          '} ^sdt_pdt,
{     'DISPLAY_SEGMENT_TABLE_EXTENDED '} ^sdtx_pdt,
{     'DISPLAY_STACK_ENVIRONMENT      '} NIL,
{     'DISPLAY_STACK_FRAME            '} ^display_stk_pdt,
{     'DISPLAY_SYSTEM_FILE_ID         '} ^sfid_display_pdt,
{     'DISPLAY_SYSTEM_LOG             '} ^display_log_pdt,
{     'DISPLAY_TASK_ENVIRONMENT       '} NIL,
{     'DISPLAY_TRACE_BACK             '} ^trace_back_pdt,
{     'DOWN_VOLUME                    '} NIL,
{     'HANG_TASK                      '} NIL,
{     'INJECT_HARDWARE_FAULT_UTILITY  '} NIL,
{     'KILL_TASK                      '} ^kilt_pdt,
{     'LIST_BREAKPOINTS               '} ^display_brkpt_pdt,
{     'M                              '} NIL,
{     'P                              '} NIL,
{     'REMOVE_BREAKPOINT              '} ^remove_brkpt_pdt,
{     'REPEAT                         '} NIL,
{     'SELECT                         '} ^select_pdt,
{     'SET_AUTO_CMD_LIST              '} ^setdcl_pdt,
{     'SET_BREAKPOINT                 '} ^brkpt_pdt,
{     'SET_MASS_STORAGE_FAULT         '} ^setmsf_pdt,
{     'SET_OUTPUT_DESTINATION         '} ^setod_pdt,
{     'SUPER_CHANGE_MEMORY            '} ^cm_pdt,
{     'TEST_JOB_RECOVERY              '} NIL,
{     'UP_VOLUME                      '} NIL,
{     'SET_PAGE_WAIT                  '} ^setpw_pdt,
{     'dummy_not_used                 '} REP 7 of NIL,
{     'HELP_FUNCTION                  '} ^help_pdt,

{ Old commands and ^parameters (will be deleted in the near future):

{     'LIST_BREAKPOINTS               '} ^display_brkpt_pdt,
{     'SET_BREAKPOINT                 '} ^brkpt_pdt,
{     'REMOVE_BREAKPOINT              '} ^remove_brkpt_pdt,
{     'CHANGE_BREAKPOINT              '} ^change_brkpt_pdt,
{     'DISPLAY_STACK_FRAME            '} ^display_stk_pdt,
{     'TRACE_BACK                     '} ^trace_back_pdt,
{     'DISPLAY_REGISTER               '} ^display_reg_pdt,
{     'DISM                           '} ^dm_pdt,
{     'CHAM                           '} ^cm_pdt,
{     'SELECT                         '} ^select_pdt,
{     'SUPER_CHANGE_MEMORY            '} ^cm_pdt,
{     'DISPLAY_TASK_ENVIRONMENT       '} NIL,
{     'DISPLAY_OS_SYMBOL              '} ^disost_pdt,
{     'KILL_TASK                      '} ^kilt_pdt,
{     'DISPLAY_OS_ADDRESS             '} ^disosa_pdt,
{     'AUTO                           '} ^auto_pdt,
{     'DISPLAY_XCB                    '} NIL,
{     'DISPLAY_MONITOR_FAULT          '} NIL,
{     'P                              '} NIL,
{     'M                              '} NIL,
{     'DISPLAY_SYSTEM_LOG             '} ^display_log_pdt,
{     'DISPLAY_STACK_ENVIRONMENT      '} NIL,
{     'HANG_TASK                      '} NIL,
{     'DISPLAY_JOB_LOG                '} ^display_log_pdt,
{     'DISPLAY_JOB_TABLES             '} ^syv$jfile_pdt,
{     'DISPLAY_INITIATED_JOB_LIST     '} ^ijl_pdt,
{     'DISPLAY_SEGMENT_TABLE          '} ^sdt_pdt,
{     'DISPLAY_SEGMENT_TABLE_EX       '} ^sdtx_pdt,
{     'DISPLAY_ENTIRE_SEG_TABLE       '} NIL,
{     'TEST_JOB_RECOVERY              '} NIL,
{     'INJECT_HARDWARE_FAULT_UTILITY  '} NIL,
{     'DISPLAY_ACTIVE_JOB_LIST        '} ^ajl_pdt,
{     'REPEAT                         '} NIL,
{     'DOWN_VOLUME                    '} NIL,
{     'UP_VOLUME                      '} NIL,
{     'SET_MASS_STORAGE_FAULT         '} ^setmsf_pdt,
{     'dummy_not_used                 '} REP 12 of NIL,
{     'HELP_FUNCTION                  '} ^help_pdt];
?? OLDTITLE ??
?? OLDTITLE ??
?? NEWTITLE := '  AUTOPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the AUTO command.  It is called from the AUTO command processor XQTAUTOPROC, as
{   part of DUMPJOB, or when "dump when debug" is TRUE.
{        DUMP_SEGMENTS_3_4_6: Boolean determines whether segments 3, 4, and 6 (job-mode) should be dumped.
{        DUMP_JOB_ENVIRONMENT: Boolean determines if this call results from a DUMPJOB command and puts out
{          the appropriate message to the result file.
{        STATUS: status variable
{

  PROCEDURE autoproc
    (    dump_segments_3_4_6: boolean;
         dump_job_environment: boolean;
     VAR status: ost$status);

    VAR
      i: integer,
      message: string (80),
      xcb_p: ^ost$execution_control_block;

    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;

    IF dump_job_environment THEN
      pmp$find_executing_task_xcb (xcb_p);
      message := 'DUMPJOB Dump of Job Task: ';
      message (28, * ) := xcb_p^.save9;
      syp$write_output_line (message, status);
    IFEND;

{ Disable core command logging.

    syv$inhibit_core_cmd_logging := TRUE;

    FOR i := 1 TO 20 DO
      syp$write_output_line ('  SYSTEM FAILURE ANALYSIS LISTING', status);
      IF NOT syv$nosve_job_template THEN
        syp$write_output_line ('  *** Alternate Job Template', status);
      IFEND;
    FOREND;

    i := 1;
    WHILE auto_cmds [i].command <> '   ' DO
      IF (NOT auto_cmds [i].jobmntr_execution_only) OR
            (auto_cmds [i].jobmntr_execution_only AND dump_segments_3_4_6) THEN
        sub_autoproc (i);
      IFEND;
      i := i + 1;
    WHILEND;

{ Re-enable core command logging.

    syv$inhibit_core_cmd_logging := FALSE;

  PROCEND autoproc;
?? OLDTITLE ??
?? NEWTITLE := '  CMPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the CHANGE_MEMORY command.  It changes the value of a specified location in
{ virtual memory.  The parameters for the command are as follows:
{        FBA: Required, pointer.
{          Specifies the virtual memory address (as a PVA or symbolic address) where the new value is entered
{          (this value is an 11-digit hexadecimal number addressing a specific byte of memory).
{        MV: Required, integer.
{          Specifies a number that replaces the bytes at the specified address.
{        BC: Optional, integer.
{          Specifies the number of consecutive bytes for which the new value is entered.  The default is 1.
{          The count can be a maximum of 8.
{


{ CHANGE_MEMORY, SUPER_CHANGE_MEMORY parameter descriptor table:

  VAR
    cm_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 3] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'address ', syc$pointer_value, NIL],
{   } [TRUE, 2, 'value   ', syc$integer_value, 1, 0, 0ffffffffffff(16)],
{   } [FALSE, 3, 'count   ', syc$integer_value, 1, 1, 8]];

  PROCEDURE cmproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      ap: ^array [1 .. 8] of 0 .. 255,
      bc: 1 .. 8,
      i: 1 .. 8,
      mv: integer,
      pvt: array [1 .. 3] of syt$parameter_value,
      sl: integer,
      str: string (60);

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (cm_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' CHANGE MEMORY ', text);
    IFEND;

    syp$verify_access (syc$writeable, #LOC (pvt [1].ptr), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    mv := pvt [2].int;
    bc := pvt [3].int;
    ap := pvt [1].ptr;
    get_segment_length (ap, sl);
    IF (#OFFSET (ap) + bc) >= sl THEN
      osp$set_status_abnormal ('DB', dbe$, 'address greater than file limit', status);
      RETURN;
    IFEND;
    FOR i := bc DOWNTO 1 DO
      ap^ [i] := mv MOD 256;
      mv := mv DIV 256;
    FOREND;
  PROCEND cmproc;
?? OLDTITLE ??
?? NEWTITLE := '  COND_ORD_TO_UCR_ORD', EJECT ??

{
{ Purpose:
{   This procedure converts a condition ordinal to a user_condition_register ordinal and returns a string
{   describing the condition ordinal.
{

  PROCEDURE cond_ord_to_ucr_ord
    (    cond_ord: debug_condition;
     VAR ucr_ord: ost$user_condition;
     VAR str: string (8));

    VAR
      i: debug_condition;

    i := dc_read;
    WHILE i <= dc_invbdp DO
      IF cond_conv_tbl [i].c_ord = cond_ord THEN
        ucr_ord := cond_conv_tbl [i].ucr_ord;
        str (1, 8) := cond_conv_tbl [i].name (1, 8);
        RETURN;
      ELSE
        i := SUCC (i);
      IFEND;
    WHILEND;
    RETURN;
  PROCEND cond_ord_to_ucr_ord;
?? OLDTITLE ??
?? NEWTITLE := '  DEBUG_TRAP_PROCESSOR', EJECT ??

{
{ Purpose:
{   This procedure processes debugger traps due to breakpoints, etc.
{

  PROCEDURE debug_trap_processor;

    VAR
      contact_user: boolean,
      mes: string (60),
      sa_p: ^stack_frame_control_image,
      status: ost$status;

    sa_p := #PREVIOUS_SAVE_AREA ();

    generate_debug_trap_message (sa_p^.psa, contact_user, mes, status);
    IF NOT contact_user THEN
      RETURN;
    IFEND;

    process_commands (sa_p^.psa, 'Trap in ', mes, FALSE, status);


  PROCEND debug_trap_processor;
?? OLDTITLE ??
?? NEWTITLE := '  DISAJLPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the DISPLAY_ACTIVE_JOB_LIST command.  The parameters for the command are as
{   follows:
{        NUMBER: Optional, integer.
{          Specifies the AJL ordinal of the entry which is to be displayed.
{        NAME: Optional, name.
{          Specifies the system_supplied_name of the entry which is to be displayed, or the keyword ALL which
{          displays all AJL entries.
{


{ DISPLAY_ACTIVE_JOB_LIST parameter descriptor table:

  VAR
    ajl_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 2] of syt$parameter_descriptor := [
{   } [FALSE, 1, 'number  ', syc$integer_value, -1, -1, 5000],
{   } [FALSE, 2, 'name    ', syc$name_value, * ]];

  PROCEDURE disajlproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      ajlp: ^jmt$active_job_list_entry,
      i: integer,
      ijle_p: ^jmt$initiated_job_list_entry,
      len: integer,
      msg: string (128),
      pvt: array [1 .. 2] of syt$parameter_value,
      str: string (60);

    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (ajl_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY ACTIVE JOB LIST ENTRY ', text);
    IFEND;

    IF (pvt [1].int = -1) AND (NOT pvt [2].defined) THEN
      ijle_p := jmv$jcb.ijle_p;
      pvt [1].int := ijle_p^.ajl_ordinal;
    IFEND;

  /ajl_loop/
    FOR i := LOWERBOUND (jmv$ajl_p^) TO jmv$max_ajl_ordinal_in_use DO
      IF (jmv$ajl_p^ [i].in_use = 0) THEN
        CYCLE /ajl_loop/;
      IFEND;
      IF ((pvt [2].name = 'ALL') OR (pvt [1].int = i)) THEN
        msg := '   ';
        str := '   ';
        syp$write_output_line (msg, status);
        ajlp := ^jmv$ajl_p^ [i];
        STRINGREP (str, len, i);
        msg := ' active job list entry ';
        msg (26, * ) := str;
        syp$write_output_line (msg, status);
      IFEND;
    FOREND /ajl_loop/;

  PROCEND disajlproc;
?? OLDTITLE ??
?? NEWTITLE := '  DISESTPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the DISPLAY_ENTIRE_SEGMENT_TABLE command.  This procedure displays all entries
{   in both the segment_descriptor and segment_descriptor_extended tables.  The parameter for the command is
{   as follows:
{        GTID: Optional, integer.
{          Specifies the global_task_id of the task whose segment tables are to be displayed.  Use of this
{          value will display the tables of the task with the corresponding GTID.  If this parameter is not
{          specified the debugger will display the tables of the task which is currently in the debugger.
{


{ DISPLAY_ENTIRE_SEGMENT_TABLE parameter descriptor table:

  VAR
    disest_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 1] of syt$parameter_descriptor := [
{   } [FALSE, 1, 'gtid    ', syc$integer_value, 0, 0, 0fffff(16)]];

  PROCEDURE disestproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      gtid: gtid_converter,
      gtid_found: boolean,
      l: integer,
      msg: string (70),
      pvt: array [1 .. 1] of syt$parameter_value,
      s1: string (60),
      s2: string (60),
      segnum: integer,
      str: string (60),
      xcb_p: ^ost$execution_control_block;

    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (disest_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY ENTIRE SEGMENT TABLE ', text);
    IFEND;

    gtid_found := FALSE;
    IF pvt [1].defined AND (pvt [1].int <> 0) THEN
      gtid.base := pvt [1].int;
      xcb_p := job_xcb_list.head;
      WHILE (xcb_p <> NIL) AND (NOT gtid_found) DO
        IF xcb_p^.global_task_id = gtid.global_task_id THEN
          gtid_found := TRUE;
        ELSE
          xcb_p := xcb_p^.link;
        IFEND;
      WHILEND;
      IF NOT gtid_found THEN
        syp$write_output_line ('ERROR - Task with specified GTID was not found.', status);
        RETURN;
      IFEND;
    ELSE
      pmp$find_executing_task_xcb (xcb_p);
    IFEND;

    est_flag := TRUE;

    FOR segnum := 0 TO (xcb_p^.xp.segment_table_length) DO
      s1 := '        ';
      IF gtid_found THEN
        msg := ' Segment Table and Segment Table Extended entries for alternate task: ';
        syp$write_output_line (msg, status);
        msg := ' ';
        msg (4, * ) := xcb_p^.save9;
        syp$write_output_line (msg, status);
        msg := ' ';
        syp$write_output_line (msg, status);
        s2 := '     ';
        STRINGREP (s2, l, gtid.base: #(16), '(16)');
        s2 (1) := '0';
        STRINGREP (s1, l, segnum);
        s1 (l + 2, * ) := s2;
      ELSE
        STRINGREP (s1, l, segnum);
      IFEND;

      disstproc (s1, id, status);
      status.normal := TRUE;
      disstxproc (s1, id, status);
      status.normal := TRUE;
      IF syv$dump_to_pf AND (segnum <> (xcb_p^.xp.segment_table_length)) THEN
        syp$write_output_header (str, '');
      IFEND;
    FOREND;
    est_flag := FALSE;

  PROCEND disestproc;
?? OLDTITLE ??
?? NEWTITLE := '  DISFDC_PROC', EJECT ??

{
{ Purpose:
{   This procedure processes the DISPLAY_FILE_DESCRIPTOR_CONTROL command.  This procedure displays the file
{ descriptor control table determined by the parameter 'residence'.  The procedure checks to see if the table
{ is in real memory before attempting to display it.  The parameter for the command is:
{        RESIDENCE: Optional, name.
{          Specifies the residence of the file descriptor control table to be displayed.  The following
{          keywords can be specified (the default is JOB):
{            JOB
{            Displays the file descriptor control table of the job currently in memory.
{            SYSTEM
{            Displays the file descriptor control table of the system file descriptor table.
{

{ DISPLAY_FILE_DESCRIPTOR_CONTROL parameter descriptor table:

  VAR
    disfdc_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 1] of syt$parameter_descriptor := [
{   } [FALSE, 1, 'residenc', syc$name_value, 'JOB']];

  PROCEDURE disfdc_proc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      done: boolean,
      end_of_fdc_p: ^cell,
      fdc_p: ^cell,
      i: integer,
      length: integer,
      pvt: array [1 .. 1] of syt$parameter_value,
      rma: integer,
      segment_number: ost$segment,
      str: string (60);


    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;

    syp$crack_command (disfdc_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY FILE DESCRIPTOR CONTROL', '');
    IFEND;

    IF pvt [1].name = 'JOB' THEN
      RETURN;
    IFEND;
    fdc_p := #ADDRESS (1, segment_number, gfc$fde_control_table_base);

{ Display only that portion of the FDC which is in memory.

    str := ' ';
    STRINGREP (str, length, ' FDC table: ', fdc_p:#(16), '(16)');
    i#real_memory_address (fdc_p, rma);
    IF rma < 0 THEN
      str (length + 1, *) := ' - Origin not in memory';
      syp$write_output_line (str, status);
      repress_headers_flag := FALSE;
      RETURN;
    IFEND;

    end_of_fdc_p := #ADDRESS (1, segment_number, gfc$fde_control_table_base +
         (gfc$fde_table_base - gfc$fde_control_table_base) - 1);
    done := FALSE;
    WHILE (#OFFSET (end_of_fdc_p) > #OFFSET (fdc_p)) AND (NOT done) DO
      i#real_memory_address (end_of_fdc_p, rma);
      IF rma >= 0 THEN
        done := TRUE;
      ELSE
        end_of_fdc_p := #ADDRESS (1, segment_number, #OFFSET (end_of_fdc_p) - 2048);
      IFEND;
    WHILEND;
    IF NOT done THEN
      str (length + 1, *) := ' - Entirely absent from memory';
      syp$write_output_line (str, status);
      repress_headers_flag := FALSE;
      RETURN;
    IFEND;

{ Generate the command to display memory contents of the FDC.

    repress_headers_flag := TRUE;
    str := ' ';
    syp$convert_bytes (#LOC (fdc_p), #SIZE (fdc_p), str, FALSE);
    STRINGREP (str (15, 10), length, (#OFFSET (end_of_fdc_p) - #OFFSET (fdc_p)) + 1);
    dmproc (str, display_id, status);
    IF NOT status.normal THEN
      repress_headers_flag := FALSE;
      RETURN;
    IFEND;
    repress_headers_flag := FALSE;

  PROCEND disfdc_proc;
?? OLDTITLE ??
?? NEWTITLE := '  DISFDT_PROC', EJECT ??

{
{ Purpose:
{   This procedure processes the DISPLAY_FILE_DESCRIPTOR_TABLE command.  This procedure displays the file
{ descriptor table determined by the parameter 'residence'.  The procedure checks to see if each FDE is in
{ real memory before attempting to display it.  The parameter for the command is:
{        RESIDENCE: Optional, name.
{          Specifies the residence of the file descriptor table to be displayed.  The following
{          keywords can be specified (the default is JOB):
{            JOB
{            Displays the file descriptor table of the job currently in memory.
{            SYSTEM
{            Displays the file descriptor table of the system file descriptor table.
{

{ DISPLAY_FILE_DESCRIPTOR_TABLE parameter descriptor table:

  VAR
    disfdt_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 1] of syt$parameter_descriptor := [
{   } [FALSE, 1, 'residenc', syc$name_value, 'JOB']];

  PROCEDURE disfdt_proc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      end_of_fde_p: gft$file_desc_entry_p,
      fde_p: gft$file_desc_entry_p,
      fdt_p: ^gft$file_descriptor_control,
      i: integer,
      length: integer,
      pvt: array [1 .. 1] of syt$parameter_value,
      rma: integer,
      segment_length: integer,
      segment_number: ost$segment,
      str: string (60);


    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;

    syp$crack_command (disfdt_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY FILE DESCRIPTOR TABLE', '');
    IFEND;

    IF pvt [1].name = 'JOB' THEN
      segment_number := osc$segnum_job_fixed_heap;
    ELSEIF pvt [1].name = 'SYSTEM' THEN
      segment_number := osc$segnum_mainframe_wired;
    ELSE
      osp$set_status_abnormal ('DB', dbe$, 'invalid residence', status);
      RETURN;
    IFEND;
    repress_headers_flag := TRUE;

    fdt_p := #ADDRESS (1, segment_number, gfc$fde_control_table_base);
    get_segment_length (fdt_p, segment_length);
  /display_fdes/
    FOR i := 0 TO UPPERBOUND (fdt_p^.in_use_bits) DO

      fde_p := #ADDRESS (1, segment_number, gfc$fde_table_base + (i * gfc$fde_size));
      IF segment_length < (gfc$fde_table_base + (i * gfc$fde_size)) THEN
        syp$write_output_line ('Computed FDE address exceeds segment length', status);
        EXIT /display_fdes/;
      IFEND;

{ Make sure the entire FDE is in memory.

      str := ' ';
      STRINGREP (str, length, ' FDE index: ', i:#(16), '(16)');
      i#real_memory_address (fde_p, rma);
      IF rma < 0 THEN
        str (length + 1, *) := ' - Not in memory';
        syp$write_output_line (str, status);
        CYCLE /display_fdes/
      IFEND;
      end_of_fde_p := #ADDRESS (1, segment_number, gfc$fde_table_base + ((i+1)* gfc$fde_size) - 1);
      i#real_memory_address (end_of_fde_p, rma);
      IF rma < 0 THEN
        str (length + 1, *) := ' - Not entirely in memory';
        syp$write_output_line (str, status);
        CYCLE /display_fdes/
      IFEND;

{ Generate the command to display memory contents of the FDE.

      str := ' ';
      syp$convert_bytes (#LOC (fde_p), #SIZE (fde_p), str, FALSE);
      STRINGREP (str (15, 10), length, gfc$fde_size);
      dmproc (str, display_id, status);
      IF NOT status.normal THEN
        repress_headers_flag := FALSE;
        RETURN;
      IFEND;
    FOREND /display_fdes/;
    repress_headers_flag := FALSE;

  PROCEND disfdt_proc;
?? OLDTITLE ??
?? NEWTITLE := '  DISIJLPROC', EJECT ??
?? NEWTITLE := '    Swap_status Translation Table', EJECT ??

{ The following translation table is used to translate the TYPE jmt$ijl_swap_status into displayable strings.

  VAR
    swap_status_translations: [READ, oss$mainframe_paged_literal] array [jmt$ijl_swap_status] of
          string (27) := [
{ jmc$iss_null                    } 'iss null                   ',
{ jmc$iss_executing               } 'iss executing              ',
{ jmc$iss_idle_tasks_initiated    } 'iss idle tasks initiated   ',
{ jmc$iss_job_idle_tasks_complete } 'iss job idle tasks complete',
{ jmc$iss_swapped_no_io           } 'iss swapped no io          ',
{ jmc$iss_flush_am_pages          } 'iss flush am pages         ',
{ jmc$iss_job_allocate_swap_file  } 'iss job allocate swap file ',
{ jmc$iss_wait_allocate_swap_file } 'iss wait allocate swap file',
{ jmc$iss_allocate_swap_file      } 'iss allocate swap file     ',
{ jmc$iss_wait_job_io_complete    } 'iss wait job io complete   ',
{ jmc$iss_job_io_complete         } 'iss job io complete        ',
{ jmc$iss_wait_allocate_sfd       } 'iss wait allocate sfd      ',
{ jmc$iss_allocate_sfd            } 'iss allocate sfd           ',
{ jmc$iss_swapped_io_cannot_init  } 'iss swapped io cannot init ',
{ jmc$iss_initiate_swapout_io     } 'iss initiate swapout io    ',
{ jmc$iss_wait_swapout_io_init    } 'iss wait swapout io init   ',
{ jmc$iss_swapout_io_initiated    } 'iss swapout io initiated   ',
{ jmc$iss_swapout_io_complete     } 'iss swapout io complete    ',
{ jmc$iss_swapped_io_complete     } 'iss swapped io complete    ',
{ jmc$iss_free_swapped_memory     } 'iss free swapped memory    ',
{ jmc$iss_swapout_complete        } 'iss swapout complete       ',
{ jmc$iss_swapin_requested        } 'iss swapin requested       ',
{ jmc$iss_swapin_resource_claimed } 'iss swapin resource claimed',
{ jmc$iss_wait_swapin_io_init     } 'iss wait swapin io init    ',
{ jmc$iss_swapin_io_initiated     } 'iss swapin io initiated    ',
{ jmc$iss_swapin_io_complete      } 'iss swapin io complete     '];

?? OLDTITLE, EJECT ??
{
{ Purpose:
{   This procedure processes the DISPLAY_INITIATED_JOB_LIST_ENT command.  The parameter for the command is as
{ follows:
{        NAME: Optional, name.
{          Specifies the system_supplied_name of the job whose initiated_job_list_entry should be displayed.
{          If this parameter is not specified, the initiated_job_list_entry of the job containing the task
{          which is in the debugger will be displayed.
{


{ DISPLAY_INITIATED_JOB_LIST_ENT parameter descriptor table:

  VAR
    ijl_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 1] of syt$parameter_descriptor := [
{   } [FALSE, 1, 'name    ', syc$name_value, * ]];

  PROCEDURE disijlproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      i: integer,
      ij: mmt$job_page_queue_index,
      ijle_p: ^jmt$initiated_job_list_entry,
      j: integer,
      msg: string (60),
      msg2: string (130),
      pvt: array [1 .. 1] of syt$parameter_value,
      size: integer,
      str: string (60);

    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (ijl_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY INITIATED JOB LIST ENTRY ', text);
    IFEND;

  /find_name/
    BEGIN

      IF (NOT pvt [1].defined) THEN
        ijle_p := jmv$jcb.ijle_p;
        EXIT /find_name/;
      IFEND;

    /a20/
      FOR i := LOWERBOUND (jmv$ijl_p.block_p^) TO jmv$ijl_p.max_block_in_use DO
        IF jmv$ijl_p.block_p^ [i].index_p <> NIL THEN

        /a10/
          FOR j := LOWERVALUE (jmt$ijl_block_index) TO UPPERVALUE (jmt$ijl_block_index) DO
            IF (jmv$ijl_p.block_p^ [i].index_p^ [j].entry_status = jmc$ies_entry_free) THEN
              CYCLE /a10/;
            IFEND;
            IF (jmv$ijl_p.block_p^ [i].index_p^ [j].system_supplied_name = pvt [1].name) THEN
              ijle_p := ^jmv$ijl_p.block_p^ [i].index_p^ [j];
              EXIT /find_name/;
            IFEND;
          FOREND /a10/;

        IFEND;
      FOREND /a20/;

      osp$set_status_abnormal ('sy', dbe$, 'name not found', status);
      RETURN;

    END /find_name/;

    msg := 'system supplied name:';
    msg (23, * ) := ijle_p^.system_supplied_name;
    syp$write_output_line (msg, status);

    msg := 'job name:';
    msg (11, * ) := ijle_p^.job_name;
    syp$write_output_line (msg, status);

    msg := 'ijl entry status:';
    CASE ijle_p^.entry_status OF
    = jmc$ies_entry_free =
      msg (20, * ) := 'entry free';
    = jmc$ies_job_terminating =
      msg (20, * ) := 'job terminating';
    = jmc$ies_job_in_memory_non_swap =
      msg (20, * ) := 'job in memory non swap';
    = jmc$ies_job_in_memory =
      msg (20, * ) := 'job in memory';
    = jmc$ies_swapin_in_progress =
      msg (20, * ) := 'swapin in progress';
    = jmc$ies_job_swapped =
      msg (20, * ) := 'job swapped';
    = jmc$ies_operator_force_out =
      msg (20, * ) := 'operator force out';
    = jmc$ies_system_force_out =
      msg (20, * ) := 'system force out';
    = jmc$ies_job_damaged =
      msg (20, * ) := 'job damaged';
    = jmc$ies_ready_task =
      msg (20, * ) := 'ready task';
    = jmc$ies_swapin_candidate =
      msg (20, * ) := 'swapin candidate';
    ELSE
      syp$convert_bytes (#LOC (ijle_p^.entry_status), #SIZE (ijle_p^.entry_status), msg, add_to_eol);
    CASEND;
    syp$write_output_line (msg, status);

    msg := 'ajl ordinal:';
    syp$convert_bytes (#LOC (ijle_p^.ajl_ordinal), #SIZE (ijle_p^.ajl_ordinal), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'kjl ordinal:';
    syp$convert_bytes (#LOC (ijle_p^.kjl_ordinal), #SIZE (ijle_p^.kjl_ordinal), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'ijl swap status:';
    msg (20, * ) := swap_status_translations [ijle_p^.swap_status];
    syp$write_output_line (msg, status);

    msg := 'ijl next swap status:';
    msg (24, * ) := swap_status_translations [ijle_p^.next_swap_status];
    syp$write_output_line (msg, status);

    msg := 'ijl last swap status:';
    msg (24, * ) := swap_status_translations [ijle_p^.last_swap_status];
    syp$write_output_line (msg, status);

    msg := 'inhibit swap count:';
    syp$convert_bytes (#LOC (ijle_p^.inhibit_swap_count), #SIZE (ijle_p^.inhibit_swap_count),
          msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'active io page count:';
    syp$convert_bytes (#LOC (ijle_p^.active_io_page_count), #SIZE (ijle_p^.active_io_page_count),
          msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'active io requests:';
    syp$convert_bytes (#LOC (ijle_p^.active_io_requests), #SIZE (ijle_p^.active_io_requests),
          msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'swap queue link:';
    syp$write_output_line (msg, status);
    msg := '  queue id:';
    CASE ijle_p^.swap_queue_link.queue_id OF
    = jsc$isqi_null =
      msg (14, * ) := 'isqi_null';
    = jsc$isqi_swapping =
      msg (14, * ) := 'isqi_swapping';
    = jsc$isqi_swapped_io_not_init =
      msg (14, * ) := 'isqi_swapped_io_not_init';
    = jsc$isqi_swapped_io_cannot_init =
      msg (14, * ) := 'isqi_swapped_io_cannot_init';
    = jsc$isqi_swapped_io_completed =
      msg (14, * ) := 'isqi_swapped_io_completed';
    = jsc$isqi_swapped_out =
      msg (14, * ) := 'isqi_swapped_out';
    ELSE
      syp$convert_bytes (#LOC (ijle_p^.swap_queue_link.queue_id), #SIZE (ijle_p^.swap_queue_link.queue_id),
            msg, add_to_eol);
    CASEND;
    syp$write_output_line (msg, status);
    msg := '  backward link: ';
    syp$convert_bytes (#LOC (ijle_p^.swap_queue_link.backward_link),
          #SIZE (ijle_p^.swap_queue_link.backward_link), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  forward link:';
    syp$convert_bytes (#LOC (ijle_p^.swap_queue_link.forward_link),
          #SIZE (ijle_p^.swap_queue_link.forward_link), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'job fixed asid:';
    syp$convert_bytes (#LOC (ijle_p^.job_fixed_asid), #SIZE (ijle_p^.job_fixed_asid), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'long wait aging complete:';
    msg (28, * ) := boolean_translations [ijle_p^.long_wait_aging_complete];
    syp$write_output_line (msg, status);

    msg := 'notify swapper when io complete:';
    msg (35, * ) := boolean_translations [ijle_p^.notify_swapper_when_io_complete];
    syp$write_output_line (msg, status);

    msg := 'scheduling dispatching priority:';
    syp$convert_bytes (#LOC (ijle_p^.scheduling_dispatching_priority),
          #SIZE (ijle_p^.scheduling_dispatching_priority), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'dispatching control:';
    syp$write_output_line (msg, status);
    msg := '  dispatching control index';
    syp$convert_bytes (#LOC (ijle_p^.dispatching_control.dispatching_control_index),
          #SIZE (ijle_p^.dispatching_control.dispatching_control_index), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  dispatching priority:';
    syp$convert_bytes (#LOC (ijle_p^.dispatching_control.dispatching_priority),
          #SIZE (ijle_p^.dispatching_control.dispatching_priority), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  user requested dispatching priority:';
    syp$convert_bytes (#LOC (ijle_p^.dispatching_control.user_requested_dispatching_prio),
          #SIZE (ijle_p^.dispatching_control.user_requested_dispatching_prio), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  operator set dispatching priority:';
    syp$convert_bytes (#LOC (ijle_p^.dispatching_control.operator_set_dispatching_prio),
          #SIZE (ijle_p^.dispatching_control.operator_set_dispatching_prio), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  service remaining:';
    syp$convert_bytes (#LOC (ijle_p^.dispatching_control.service_remaining),
          #SIZE (ijle_p^.dispatching_control.service_remaining), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  CP service at class switch:';
    syp$convert_bytes (#LOC (ijle_p^.dispatching_control.cp_service_at_class_switch),
          #SIZE (ijle_p^.dispatching_control.cp_service_at_class_switch), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'job monitor task_id:';
    syp$convert_bytes (#LOC (ijle_p^.job_monitor_taskid), #SIZE (ijle_p^.job_monitor_taskid),
          msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'job mode:';
    CASE ijle_p^.job_mode OF
    = jmc$batch =
      msg (12, * ) := 'BATCH';
    = jmc$interactive_connected =
      msg (12, * ) := 'INTERACTIVE_CONNECTED';
    = jmc$interactive_cmnd_disconnect =
      msg (12, * ) := 'INTERACTIVE_CMND_DISCONNECT';
    = jmc$interactive_line_disconnect =
      msg (12, * ) := 'INTERACTIVE_LINE_DISCONNECT';
    = jmc$interactive_sys_disconnect =
      msg (12, * ) := 'INTERACTIVE_SYS_DISCONNECT';
    ELSE
      syp$convert_bytes (#LOC (ijle_p^.job_mode), #SIZE (ijle_p^.job_mode), msg, add_to_eol);
    CASEND;
    syp$write_output_line (msg, status);

    msg := 'executing task count:';
    syp$convert_bytes (#LOC (ijle_p^.executing_task_count), #SIZE (ijle_p^.executing_task_count),
          msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'multiprocessing allowed:';
    msg (27, * ) := boolean_translations [ijle_p^.multiprocessing_allowed];
    syp$write_output_line (msg, status);

    msg := 'swapin candidate queue:';
    syp$convert_bytes (#LOC (ijle_p^.swapin_candidate_queue), #SIZE (ijle_p^.swapin_candidate_queue),
          msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'estimated ready time:';
    syp$convert_bytes (#LOC (ijle_p^.estimated_ready_time), #SIZE (ijle_p^.estimated_ready_time),
          msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'last think time:';
    syp$convert_bytes (#LOC (ijle_p^.last_think_time), #SIZE (ijle_p^.last_think_time), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'age purge timestamp:';
    syp$convert_bytes (#LOC (ijle_p^.age_purge_timestamp), #SIZE (ijle_p^.age_purge_timestamp),
          msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'sfd purge timestamp:';
    syp$convert_bytes (#LOC (ijle_p^.sfd_purge_timestamp), #SIZE (ijle_p^.sfd_purge_timestamp),
          msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'job scheduler data:';
    syp$write_output_line (msg, status);
    msg := '  ready_task_link:';
    syp$convert_bytes (#LOC (ijle_p^.job_scheduler_data.ready_task_link),
          #SIZE (ijle_p^.job_scheduler_data.ready_task_link), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  service accumulator:';
    syp$convert_bytes (#LOC (ijle_p^.job_scheduler_data.service_accumulator),
          #SIZE (ijle_p^.job_scheduler_data.service_accumulator), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  service accumulator since swap:';
    syp$convert_bytes (#LOC (ijle_p^.job_scheduler_data.service_accumulator_since_swap),
          #SIZE (ijle_p^.job_scheduler_data.service_accumulator_since_swap), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  guaranteed service remaining:';
    syp$convert_bytes (#LOC (ijle_p^.job_scheduler_data.guaranteed_service_remaining),
          #SIZE (ijle_p^.job_scheduler_data.guaranteed_service_remaining), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  last cptime:';
    syp$convert_bytes (#LOC (ijle_p^.job_scheduler_data.last_cptime),
          #SIZE (ijle_p^.job_scheduler_data.last_cptime), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  last page fault count:';
    syp$convert_bytes (#LOC (ijle_p^.job_scheduler_data.last_page_fault_count),
          #SIZE (ijle_p^.job_scheduler_data.last_page_fault_count), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  job swap counts';
    syp$write_output_line (msg, status);
    msg := '    long wait:';
    syp$convert_bytes (#LOC (ijle_p^.job_scheduler_data.job_swap_counts.long_wait),
          #SIZE (ijle_p^.job_scheduler_data.job_swap_counts.long_wait), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '    job mode:';
    syp$convert_bytes (#LOC (ijle_p^.job_scheduler_data.job_swap_counts.job_mode),
          #SIZE (ijle_p^.job_scheduler_data.job_swap_counts.job_mode), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  reason:';
    CASE ijle_p^.job_scheduler_data.swapout_reason OF
    = jmc$sr_null =
      msg (12, * ) := 'null';
    = jmc$sr_job_damaged =
      msg (12, * ) := 'job damaged';
    = jmc$sr_operator_request =
      msg (12, * ) := 'operator request';
    = jmc$sr_thrashing =
      msg (12, * ) := 'thrashing';
    = jmc$sr_lower_priority =
      msg (12, * ) := 'lower_priority';
    = jmc$sr_idling_system_swapout =
      msg (12, * ) := 'idling system swapout';
    = jmc$sr_long_wait =
      msg (12, * ) := 'long wait';
    = jmc$sr_memory_reserve_request =
      msg (12, * ) := 'memory reserve';
    = jmc$sr_idle_dispatching =
      msg (12, * ) := 'idle dispatching';
    ELSE
      syp$convert_bytes (#LOC (ijle_p^.job_scheduler_data.swapout_reason),
            #SIZE (ijle_p^.job_scheduler_data.swapout_reason), msg, add_to_eol);
    CASEND;
    syp$write_output_line (msg, status);
    msg := '  priority:';
    syp$convert_bytes (#LOC (ijle_p^.job_scheduler_data.priority),
          #SIZE (ijle_p^.job_scheduler_data.priority), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  unaged swap queue priority:';
    syp$convert_bytes (#LOC (ijle_p^.job_scheduler_data.unaged_swap_queue_priority),
          #SIZE (ijle_p^.job_scheduler_data.unaged_swap_queue_priority), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  swapin q priority timestamp:';
    syp$convert_bytes (#LOC (ijle_p^.job_scheduler_data.swapin_q_priority_timestamp),
          #SIZE (ijle_p^.job_scheduler_data.swapin_q_priority_timestamp), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  job class:';
    syp$convert_bytes (#LOC (ijle_p^.job_scheduler_data.job_class),
          #SIZE (ijle_p^.job_scheduler_data.job_class), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  service class:';
    syp$convert_bytes (#LOC (ijle_p^.job_scheduler_data.service_class),
          #SIZE (ijle_p^.job_scheduler_data.service_class), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'job page queue list:';
    syp$write_output_line (msg, status);
    FOR ij := mmc$pq_job_fixed TO mmc$pq_job_working_set DO
      msg := '  ';
      STRINGREP (msg (3, * ), i, ij);
      msg (3) := '[';
      msg (6) := ']';
      syp$write_output_line (msg, status);
      msg := '    link.bkw:';
      syp$convert_bytes (#LOC (ijle_p^.job_page_queue_list [ij].link.bkw),
            #SIZE (ijle_p^.job_page_queue_list [ij].link.bkw), msg, add_to_eol);
      syp$write_output_line (msg, status);
      msg := '    link.fwd:';
      syp$convert_bytes (#LOC (ijle_p^.job_page_queue_list [ij].link.fwd),
            #SIZE (ijle_p^.job_page_queue_list [ij].link.fwd), msg, add_to_eol);
      syp$write_output_line (msg, status);
      msg := '    count:';
      syp$convert_bytes (#LOC (ijle_p^.job_page_queue_list [ij].count),
            #SIZE (ijle_p^.job_page_queue_list [ij].count), msg, add_to_eol);
      syp$write_output_line (msg, status);
    FOREND;

    msg := 'swap data:';
    syp$write_output_line (msg, status);
    msg := '  swap file sfid:';
    syp$convert_bytes (#LOC (ijle_p^.swap_data.swap_file_sfid), #SIZE (ijle_p^.swap_data.swap_file_sfid),
          msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  swapping io error:';
    msg (23, * ) := boolean_translations [(ijle_p^.swap_data.swapping_io_error <> ioc$no_error)];
    syp$write_output_line (msg, status);
    msg := '  swapped job page count:';
    syp$convert_bytes (#LOC (ijle_p^.swap_data.swapped_job_page_count),
          #SIZE (ijle_p^.swap_data.swapped_job_page_count), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  swap file length in pages:';
    syp$convert_bytes (#LOC (ijle_p^.swap_data.swap_file_length_in_pages),
          #SIZE (ijle_p^.swap_data.swap_file_length_in_pages), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  asid reassigned timestamp:';
    syp$convert_bytes (#LOC (ijle_p^.swap_data.asid_reassigned_timestamp),
          #SIZE (ijle_p^.swap_data.asid_reassigned_timestamp), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  timestamp:';
    syp$convert_bytes (#LOC (ijle_p^.swap_data.timestamp), #SIZE (ijle_p^.swap_data.timestamp),
          msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  reassigned job fixed asti:';
    syp$convert_bytes (#LOC (ijle_p^.swap_data.reassigned_job_fixed_asti),
          #SIZE (ijle_p^.swap_data.reassigned_job_fixed_asti), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  swapped job entry:';
    syp$write_output_line (msg, status);
    msg := '    available modified page count:';
    syp$convert_bytes (#LOC (ijle_p^.swap_data.swapped_job_entry.available_modified_page_count),
          #SIZE (ijle_p^.swap_data.swapped_job_entry.available_modified_page_count), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '    job page queue count- job fixed:';
    syp$convert_bytes (#LOC (ijle_p^.swap_data.swapped_job_entry.job_page_queue_count [mmc$pq_job_fixed]),
          #SIZE (ijle_p^.swap_data.swapped_job_entry.job_page_queue_count [mmc$pq_job_fixed]), msg,
          add_to_eol);
    syp$write_output_line (msg, status);
    msg := '    job page queue count- job io error:';
    syp$convert_bytes (#LOC (ijle_p^.swap_data.swapped_job_entry.job_page_queue_count [mmc$pq_job_io_error]),
          #SIZE (ijle_p^.swap_data.swapped_job_entry.job_page_queue_count [mmc$pq_job_io_error]), msg,
          add_to_eol);
    syp$write_output_line (msg, status);
    msg := '    job page queue count- job working set:';
    syp$convert_bytes (#LOC (ijle_p^.swap_data.swapped_job_entry.
          job_page_queue_count [mmc$pq_job_working_set]), #SIZE (ijle_p^.swap_data.swapped_job_entry.
          job_page_queue_count [mmc$pq_job_working_set]), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '    swap file descriptor page count:';
    syp$convert_bytes (#LOC (ijle_p^.swap_data.swapped_job_entry.swap_file_descriptor_page_count),
          #SIZE (ijle_p^.swap_data.swapped_job_entry.swap_file_descriptor_page_count), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'swap io control:';
    syp$write_output_line (msg, status);
    msg := '  spd index:';
    syp$convert_bytes (#LOC (ijle_p^.swap_io_control.spd_index), #SIZE (ijle_p^.swap_io_control.spd_index),
          msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  next queue id:';
    syp$convert_bytes (#LOC (ijle_p^.swap_io_control.next_queue_id),
          #SIZE (ijle_p^.swap_io_control.next_queue_id), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  next pfti:';
    syp$convert_bytes (#LOC (ijle_p^.swap_io_control.next_pfti), #SIZE (ijle_p^.swap_io_control.next_pfti),
          msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  stop pfti:';
    syp$convert_bytes (#LOC (ijle_p^.swap_io_control.stop_pfti), #SIZE (ijle_p^.swap_io_control.stop_pfti),
          msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  swap file descriptor pfti:';
    syp$convert_bytes (#LOC (ijle_p^.swap_io_control.swap_file_descriptor_pfti),
          #SIZE (ijle_p^.swap_io_control.swap_file_descriptor_pfti), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'sfd_p:';
    syp$convert_bytes (#LOC (ijle_p^.sfd_p), #SIZE (ijle_p^.sfd_p), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'system breakpoint selected:';
    msg (30, * ) := boolean_translations [ijle_p^.system_breakpoint_selected];
    syp$write_output_line (msg, status);

    msg2 := 'delayed swapin work:    ';
    syp$write_output_line (msg2, status);
    msg2 := '';
    size := 25;
    IF (jmc$dsw_job_recovery IN ijle_p^.delayed_swapin_work) THEN
      msg2 (size, 15) := 'job recovery';
      size := size + 15;
    IFEND;
    IF size > 100 THEN
      size := 25;
      syp$write_output_line (msg2, status);
    IFEND;
    IF (jmc$dsw_update_debug_lists IN ijle_p^.delayed_swapin_work) THEN
      msg2 (size, 25) := 'update debug lists';
      size := size + 25;
    IFEND;
    IF size > 100 THEN
      size := 25;
      syp$write_output_line (msg2, status);
    IFEND;
    IF (jmc$dsw_update_keypoint_masks IN ijle_p^.delayed_swapin_work) THEN
      msg2 (size, 25) := 'update keypoint masks';
      size := size + 25;
    IFEND;
    IF size > 100 THEN
      size := 25;
      syp$write_output_line (msg2, status);
    IFEND;
    IF (jmc$dsw_job_asid_changed IN ijle_p^.delayed_swapin_work) THEN
      msg2 (size, 15) := 'asid changed';
      size := size + 15;
    IFEND;
    IF size > 100 THEN
      size := 25;
      syp$write_output_line (msg2, status);
    IFEND;
    IF (jmc$dsw_job_shared_asid_changed IN ijle_p^.delayed_swapin_work) THEN
      msg2 (size, 25) := 'job shared asid changed';
      size := size + 25;
    IFEND;
    IF size > 100 THEN
      size := 25;
      syp$write_output_line (msg2, status);
    IFEND;
    IF (jmc$dsw_update_job_task_enviro IN ijle_p^.delayed_swapin_work) THEN
      msg2 (size, 28) := 'update job task enviroment';
      size := size + 28;
    IFEND;
    IF size > 100 THEN
      size := 25;
      syp$write_output_line (msg2, status);
    IFEND;
    IF (jmc$dsw_recovery_swap_io_error IN ijle_p^.delayed_swapin_work) THEN
      msg2 (size, 26) := 'recovery swapin io error';
      size := size + 26;
    IFEND;
    IF size > 100 THEN
      size := 25;
      syp$write_output_line (msg2, status);
    IFEND;
    IF (jmc$dsw_update_server_files IN ijle_p^.delayed_swapin_work) THEN
      msg2 (size, 22) := 'update server files';
      size := size + 22;
    IFEND;
    IF size > 100 THEN
      size := 25;
      syp$write_output_line (msg2, status);
    IFEND;
    IF (jmc$dsw_adjust_cpu_selections IN ijle_p^.delayed_swapin_work) THEN
      msg2 (size, 24) := 'adjust cpu selections';
      size := size + 24;
    IFEND;
    IF size > 100 THEN
      size := 25;
      syp$write_output_line (msg2, status);
    IFEND;
    IF (jmc$dsw_io_error_while_swapped IN ijle_p^.delayed_swapin_work) THEN
      msg2 (size, 25) := 'io error while swapped';
      size := size + 25;
    IFEND;
    IF size > 100 THEN
      size := 25;
      syp$write_output_line (msg2, status);
    IFEND;
    IF (jmc$dsw_unused_10 IN ijle_p^.delayed_swapin_work) OR
          (jmc$dsw_unused_11 IN ijle_p^.delayed_swapin_work) OR
          (jmc$dsw_unused_12 IN ijle_p^.delayed_swapin_work) OR
          (jmc$dsw_unused_13 IN ijle_p^.delayed_swapin_work) OR
          (jmc$dsw_unused_14 IN ijle_p^.delayed_swapin_work) OR
          (jmc$dsw_unused_15 IN ijle_p^.delayed_swapin_work) THEN
      msg2 (size, 27) := '"unused" field(s) in use';
      size := size + 27;
    IFEND;
    IF size <> 25 THEN
      syp$write_output_line (msg2, status);
    IFEND;

    msg := 'statistics:';
    syp$write_output_line (msg, status);
    msg := '  cp time:';
    syp$write_output_line (msg, status);
    msg := '    time spent in job mode:';
    syp$convert_bytes (#LOC (ijle_p^.statistics.cp_time.time_spent_in_job_mode),
          #SIZE (ijle_p^.statistics.cp_time.time_spent_in_job_mode), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '    time spent in mtr mode:';
    syp$convert_bytes (#LOC (ijle_p^.statistics.cp_time.time_spent_in_mtr_mode),
          #SIZE (ijle_p^.statistics.cp_time.time_spent_in_mtr_mode), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  paging statistics:';
    syp$write_output_line (msg, status);
    msg := '    page in count:';
    syp$convert_bytes (#LOC (ijle_p^.statistics.paging_statistics.page_in_count),
          #SIZE (ijle_p^.statistics.paging_statistics.page_in_count), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '    pages reclaimed from queue:';
    syp$convert_bytes (#LOC (ijle_p^.statistics.paging_statistics.pages_reclaimed_from_queue),
          #SIZE (ijle_p^.statistics.paging_statistics.pages_reclaimed_from_queue), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '    new pages assigned:';
    syp$convert_bytes (#LOC (ijle_p^.statistics.paging_statistics.new_pages_assigned),
          #SIZE (ijle_p^.statistics.paging_statistics.new_pages_assigned), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '    pages from server:';
    syp$convert_bytes (#LOC (ijle_p^.statistics.paging_statistics.pages_from_server),
          #SIZE (ijle_p^.statistics.paging_statistics.pages_from_server), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '    page fault count:';
    syp$convert_bytes (#LOC (ijle_p^.statistics.paging_statistics.page_fault_count),
          #SIZE (ijle_p^.statistics.paging_statistics.page_fault_count), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '    working set max used:';
    syp$convert_bytes (#LOC (ijle_p^.statistics.paging_statistics.working_set_max_used),
          #SIZE (ijle_p^.statistics.paging_statistics.working_set_max_used), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '    incremental max ws:';
    syp$convert_bytes (#LOC (ijle_p^.statistics.paging_statistics.incremental_max_ws),
          #SIZE (ijle_p^.statistics.paging_statistics.incremental_max_ws), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := '  perm file space:';
    syp$convert_bytes (#LOC (ijle_p^.statistics.perm_file_space), #SIZE (ijle_p^.statistics.perm_file_space),
          msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  temp file space:';
    syp$convert_bytes (#LOC (ijle_p^.statistics.temp_file_space), #SIZE (ijle_p^.statistics.temp_file_space),
          msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := '  ready task count:';
    syp$convert_bytes (#LOC (ijle_p^.statistics.ready_task_count),
          #SIZE (ijle_p^.statistics.ready_task_count), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  tasks not in long wait:';
    syp$convert_bytes (#LOC (ijle_p^.statistics.tasks_not_in_long_wait),
          #SIZE (ijle_p^.statistics.tasks_not_in_long_wait), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'job-fixed contiguous pages:';
    syp$convert_bytes (#LOC (ijle_p^.job_fixed_contiguous_pages), #SIZE (ijle_p^.job_fixed_contiguous_pages),
          msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'hung task in job:';
    msg (20, * ) := boolean_translations [ijle_p^.hung_task_in_job];
    syp$write_output_line (msg, status);

    msg := 'job damaged during recovery:';
    msg (31, * ) := boolean_translations [ijle_p^.job_damaged_during_recovery];
    syp$write_output_line (msg, status);

    msg := 'maxws aio slowdown display:';
    syp$convert_bytes (#LOC (ijle_p^.maxws_aio_slowdown_display), #SIZE (ijle_p^.maxws_aio_slowdown_display),
          msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'unable to swap idle flag:';
    msg (28, * ) := boolean_translations [ijle_p^.unable_to_swap_idle_flag];
    syp$write_output_line (msg, status);

    msg := 'queue file info:';
    syp$write_output_line (msg, status);
    msg := '  job abort disposition:';
    CASE ijle_p^.queue_file_information.job_abort_disposition OF
    = jmc$restart_on_abort =
      msg (27, * ) := 'restart on abort';
    = jmc$terminate_on_abort =
      msg (27, * ) := 'terminate on abort';
    ELSE
      syp$convert_bytes (#LOC (ijle_p^.queue_file_information.job_abort_disposition),
            #SIZE (ijle_p^.queue_file_information.job_abort_disposition), msg, add_to_eol);
    CASEND;
    syp$write_output_line (msg, status);
    msg := '  job recovery disposition:';
    CASE ijle_p^.queue_file_information.job_recovery_disposition OF
    = jmc$continue_on_recovery =
      msg (30, * ) := 'continue on recovery';
    = jmc$restart_on_recovery =
      msg (30, * ) := 'restart on recovery';
    = jmc$terminate_on_recovery =
      msg (30, * ) := 'terminate on recovery';
    ELSE
      syp$convert_bytes (#LOC (ijle_p^.queue_file_information.job_abort_disposition),
            #SIZE (ijle_p^.queue_file_information.job_abort_disposition), msg, add_to_eol);
    CASEND;
    syp$write_output_line (msg, status);
    msg := '  input file location:';
    syp$convert_bytes (#LOC (ijle_p^.queue_file_information.input_file_location),
          #SIZE (ijle_p^.queue_file_information.input_file_location), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'relative_priority_enabled:';
    msg (29, * ) := boolean_translations [ijle_p^.relative_priority_enabled];
    syp$write_output_line (msg, status);

    msg := 'task created after last swap:';
    msg (32, * ) := boolean_translations [ijle_p^.task_created_after_last_swap];
    syp$write_output_line (msg, status);

    msg := 'active cartridge tape writes:';
    syp$convert_bytes (#LOC (ijle_p^.active_cart_tape_write), #SIZE (ijle_p^.active_cart_tape_write),
          msg, add_to_eol);
    syp$write_output_line (msg, status);

  PROCEND disijlproc;
?? OLDTITLE ??
?? NEWTITLE := '  DISJLPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the DISPLAY_JOB_LOG command.  The parameter for the command is as follows:
{        ENTRIES: Optional, integer or keyword ALL.
{          Specifies the number of log entries to be displayed.  The default value for this parameter is 1000.
{

  PROCEDURE disjlproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      header_string: string (60),
      log_control_desc_p: ^lgt$log_control_descriptor,
      log_control_descriptors_p: ^array [pmt$logs] of ^lgt$log_control_descriptor;

    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY JOB LOG ', text);
    IFEND;

    IF (syv$job_template_ptr_array = NIL) OR (UPPERBOUND (syv$job_template_ptr_array^) < 1) THEN
      osp$set_status_abnormal ('DB', dbe$, 'not available', status);
      RETURN;
    IFEND;

    syp$verify_access (syc$readable, #LOC (syv$job_template_ptr_array^ [1]), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    log_control_descriptors_p := syv$job_template_ptr_array^ [1];
    log_control_desc_p := log_control_descriptors_p^ [pmc$job_log];

    display_log (text, log_control_desc_p, status);

  PROCEND disjlproc;
?? OLDTITLE ??
?? NEWTITLE := '  DISMFPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the DISPLAY_MONITOR_FAULT command.  There are no parameters for this command.
{

  PROCEDURE dismfproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      btmfp: ^tmt$broken_task_monitor_fault,
      i: integer,
      mcrfp: ^tmt$mcr_faults,
      mfp: ^ost$monitor_fault,
      msg: string (40),
      sacfp: ^mmt$segment_access_condition,
      str: string (60);


    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;
    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY MONITOR FAULT ', text);
    IFEND;

    FOR i := 1 TO tmc$maximum_monitor_faults DO
      syp$write_output_line ('   ', status);
      mfp := #LOC (monitor_faults.buffer [i]);
      CASE mfp^.identifier OF
      = tmc$broken_task_fault_id =
        syp$write_output_line ('broken task monitor fault', status);
        btmfp := #LOC (mfp^.contents);
        CASE btmfp^.broken_task_condition OF
        = tmc$btc_system_error =
          syp$write_output_line ('system error', status);
          msg := 'p-reg:';
          syp$convert_bytes (#LOC (btmfp^.caller_p_register), #SIZE (btmfp^.caller_p_register),
                msg, add_to_eol);
          syp$write_output_line (msg, status);
          msg := 'status-ptr:';
          syp$convert_bytes (#LOC (btmfp^.status_p), #SIZE (btmfp^.status_p), msg, add_to_eol);
          syp$write_output_line (msg, status);
          msg := 'text-p:';
          syp$convert_bytes (#LOC (btmfp^.text_p), #SIZE (btmfp^.text_p), msg, add_to_eol);
          syp$write_output_line (msg, status);
        ELSE
          CASE btmfp^.broken_task_condition OF
          = tmc$btc_mntr_fault_buffer_full =
            syp$write_output_line ('mntr fault buffer full', status);
          = tmc$btc_mf_traps_disabled =
            syp$write_output_line ('mf traps disabled', status);
          = tmc$btc_invalid_a0 =
            syp$write_output_line ('invalid a0', status);
          = tmc$btc_invalid_p =
            syp$write_output_line ('invalid p', status);
          = tmc$btc_mcr_traps_disabled =
            syp$write_output_line ('mcr traps disabled', status);
          = tmc$btc_ucr_traps_disabled =
            syp$write_output_line ('ucr traps disabled', status);
          ELSE
            msg := 'unknown btc:';
            syp$convert_bytes (#LOC (btmfp^.broken_task_condition), #SIZE (btmfp^.broken_task_condition),
                  msg, add_to_eol);
            syp$write_output_line (msg, status);
          CASEND;
          msg := 'p-reg:';
          syp$convert_bytes (#LOC (btmfp^.p), #SIZE (btmfp^.p), msg, add_to_eol);
          syp$write_output_line (msg, status);
          msg := 'a0:';
          syp$convert_bytes (#LOC (btmfp^.a0), #SIZE (btmfp^.a0), msg, add_to_eol);
          syp$write_output_line (msg, status);
          msg := 'mcr:';
          syp$convert_bytes (#LOC (btmfp^.monitor_condition_register),
                #SIZE (btmfp^.monitor_condition_register), msg, add_to_eol);
          syp$write_output_line (msg, status);
          msg := 'ucr:';
          syp$convert_bytes (#LOC (btmfp^.user_condition_register), #SIZE (btmfp^.user_condition_register),
                msg, add_to_eol);
          syp$write_output_line (msg, status);
          msg := 'fault-id:';
          CASE btmfp^.monitor_fault_id OF
          = tmc$broken_task_fault_id =
            msg (11, * ) := 'broken task';
          = tmc$mcr_fault =
            msg (11, * ) := 'mcr fault';
          = tmc$unknown_system_req_fault =
            msg (11, * ) := 'unknown system req';
          ELSE
            syp$convert_bytes (#LOC (btmfp^.monitor_fault_id), #SIZE (btmfp^.monitor_fault_id),
                  msg, add_to_eol);
          CASEND;
          syp$write_output_line (msg, status);
        CASEND;
      = tmc$mcr_fault =
        mcrfp := #LOC (mfp^.contents);
        syp$write_output_line ('mcr fault', status);
        msg := 'mcr:';
        syp$convert_bytes (#LOC (mcrfp^.faults), #SIZE (mcrfp^.faults), msg, add_to_eol);
        syp$write_output_line (msg, status);
        msg := 'utp:';
        syp$convert_bytes (#LOC (mcrfp^.untranslatable_pointer), #SIZE (mcrfp^.untranslatable_pointer),
              msg, add_to_eol);
        syp$write_output_line (msg, status);
      = tmc$unknown_system_req_fault =
        syp$write_output_line ('unknown system request fault', status);
      = mmc$segment_fault_processor_id =
        sacfp := #LOC (mfp^.contents);
        syp$write_output_line ('segment access fault', status);
        msg := 'type: ';
        CASE sacfp^.identifier OF
        = mmc$sac_read_beyond_eoi =
          msg (7, * ) := 'read beyond eoi';
        = mmc$sac_read_write_beyond_msl =
          msg (7, * ) := 'read/write beyond msl';
        = mmc$sac_segment_access_error =
          msg (7, * ) := 'segment access error';
        = mmc$sac_key_lock_violation =
          msg (7, * ) := 'key lock violation';
        = mmc$sac_ring_violation =
          msg (7, * ) := 'ring violation';
        = mmc$sac_io_read_error =
          msg (7, * ) := 'io read error';
        = mmc$sac_no_append_permission =
          msg (7, * ) := 'no append permission';
        = mmc$sac_tape_system_failure =
          msg (7, * ) := 'tape system failure';
        = mmc$sac_file_server_terminated =
          msg (7, * ) := 'file server terminated';
        = mmc$sac_pf_space_limit_exceeded =
          msg (7, * ) := 'pf_space_limit_exceeded';
        = mmc$sac_tf_space_limit_exceeded =
          msg (7, * ) := 'tf_space_limit_exceeded';
        ELSE
          syp$convert_bytes (#LOC (sacfp^.identifier), #SIZE (sacfp^.identifier), msg, add_to_eol);
        CASEND;
        syp$write_output_line (msg, status);
        msg := 'pva: ';
        syp$convert_bytes (#LOC (sacfp^.segment), #SIZE (sacfp^.segment), msg, add_to_eol);
        syp$write_output_line (msg, status);
      ELSE
        msg := 'unknown fault:';
        syp$convert_bytes (#LOC (mfp^.identifier), #SIZE (mfp^.identifier), msg, add_to_eol);
        syp$write_output_line (msg, status);
      CASEND;

      msg := ' p-register:';
      syp$convert_bytes (#LOC (mfp^.pva), #SIZE (mfp^.pva), msg, add_to_eol);
      syp$write_output_line (msg, status);
      msg := ' a0:';
      syp$convert_bytes (#LOC (mfp^.a0), #SIZE (mfp^.a0), msg, add_to_eol);
      syp$write_output_line (msg, status);
      msg := ' a1:';
      syp$convert_bytes (#LOC (mfp^.a1), #SIZE (mfp^.a1), msg, add_to_eol);
      syp$write_output_line (msg, status);
      msg := ' a2:';
      syp$convert_bytes (#LOC (mfp^.a2), #SIZE (mfp^.a2), msg, add_to_eol);
      syp$write_output_line (msg, status);
    FOREND;

  PROCEND dismfproc;
?? OLDTITLE ??
?? NEWTITLE := '  DISOSAPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the DISPLAY_OS_ADDRESS command.  The resulting display is a description of the
{   address in terms of a module name, section name, and an offset within that section.  The parameter for the
{   command is as follows:
{        ADDRESS: Required, pointer.
{          Specifies the process virtual address (PVA) for the operating system information to display.  (This
{          is an 11-digit hexadecimal number addressing a specific byte of memory.)
{


{ DISPLAY_OS_ADDRESS parameter descriptor table:

  VAR
    disosa_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 1] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'address ', syc$pointer_value, NIL]];

  PROCEDURE disosaproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      found: boolean,
      len: integer,
      mn: pmt$program_name,
      msg: string (60),
      ofs: ost$segment_offset,
      pvt: array [1 .. 3] of syt$parameter_value,
      sn: pmt$program_name,
      str: string (80);


    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;
    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (disosa_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY OS ADDRESS ', text);
    IFEND;

    ocp$find_debug_address (#SEGMENT (pvt [1].ptr), #OFFSET (pvt [1].ptr), found, mn, sn, ofs, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF found THEN
      STRINGREP (str, len, ' M=', mn, ' S=', sn, ' O=', ofs: #(16));
      syp$write_output_line (str (1, len), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;
  PROCEND disosaproc;
?? OLDTITLE ??
?? NEWTITLE := '  DISOSTPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the DISPLAY_OPERATING_SYSTEM_SYMBOL command.  The resulting display is a
{   description of the symbol in terms of a module name and an address (PVA).  The parameter for the command
{   is as follows:
{        EPNAME: Required, name.
{          Specifies the name of the operating system symbol for which the virtual address is to be displayed.
{          The symbol name is a 1- to 31-character name.
{


{ DISPLAY_OS_SYMBOL parameter descriptor table:

  VAR
    disost_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 1] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'name    ', syc$name_value, 'ZZZ']];

  PROCEDURE disostproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      found: boolean,
      ii: integer,
      index: integer,
      j: integer,
      kind: string (30),
      len: integer,
      mi: ^pmt$module_item,
      mn: pmt$program_name,
      msg: string (60),
      occur: pmt$number_of_debug_items,
      ofs: ost$segment_offset,
      post: ^^array [ * ] of lot$task_services_entry_point,
      pvt: array [1 .. 1] of syt$parameter_value,
      s: ost$segment,
      str: string (80);


    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;
    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (disost_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY OS SYMBOL ', text);
    IFEND;

    ocp$find_debug_entry_point (pvt [1].name, found, mn, s, ofs, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF found THEN
      STRINGREP (str, len, ' M=', mn, ' S=', s: #(16), ' O=', ofs: #(16));
      syp$write_output_line (str (1, len), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      ocp$find_debug_module_item (pvt [1].name, 1, found, mi, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      IF found THEN
        FOR j := 0 TO mi^.identification.greatest_section_ordinal DO
          CASE mi^.section_item [j].kind OF
          = llc$code_section =
            kind := ' Code ';
          = llc$binding_section =
            kind := ' Binding ';
          = llc$working_storage_section =
            kind := ' Working storage  ';
          = llc$common_block =
            kind := ' Common block';
          = llc$extensible_working_storage =
            kind := ' Extensible working storage';
          = llc$extensible_common_block =
            kind := ' Extensible common block ';
          = llc$lts_reserved =
            kind := ' Lts reserved';
          ELSE
            kind := ' Kind not found ';
          CASEND;

          STRINGREP (str, len, ' S=', mi^.section_item [j].name, ' A=', mi^.section_item [j].
                address: 11: #(16), ' L=', mi^.section_item [j].length: 6: #(16), kind);
          syp$write_output_line (str (1, len), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;
      ELSE
        osp$set_status_abnormal ('DB', dbe$, ' cant find symbol ', status);
      IFEND;
    IFEND;

  PROCEND disostproc;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_LOG' ??

{ DISPLAY_JOB_LOG, DISPLAY_SYSTEM_LOG parameter descriptor tables:

  VAR
    display_log_int_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 1] of syt$parameter_descriptor := [
{   } [FALSE, 1, 'entries ', syc$integer_value, 1000, 1, 7fffffff(16)]],

    display_log_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 1] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'entries ', syc$name_value, 'ALL']];

{ PURPOSE:
{   This procedure is the interface used by the DISPLAY_JOB_LOG and DISPLAY_SYSTEM_LOG subcommands to display
{   the contents of the job and system logs, respectively.

  PROCEDURE display_log
    (    text: string ( * );
         log_control_descriptor_p: ^lgt$log_control_descriptor;
     VAR status: ost$status);

    VAR
      cell_p: ^cell,
      character_index: lgt$log_entry_size,
      current_length: lgt$log_entry_size,
      display_line: ^string ( * ),
      display_line_index: 1 .. lgc$maximum_log_entry_size + 1,
      display_line_length: lgt$log_entry_size,
      ending_offset: amt$file_byte_address,
      eof: boolean,
      i: ost$non_negative_integers,
      indentation_size: 0 .. 2,
      integer_variant: boolean,
      line_count: amt$file_byte_address,
      log_cycle: lgt$log_cycle,
      log_data: ^SEQ ( * ),
      log_entry: ^string ( * ),
      page_width: integer,
      pvt: array [1 .. 1] of syt$parameter_value;


    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;
    status.normal := TRUE;

    integer_variant := FALSE;
    syp$crack_command (display_log_int_pdt, text, pvt, status);
    IF NOT status.normal THEN
      syp$crack_command (display_log_pdt, text, pvt, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    ELSE
      integer_variant := TRUE;
    IFEND;

    syp$verify_access (syc$readable, #LOC (log_control_descriptor_p^.log_data), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ The page_widths below are defined as the amount of data which can be printed/retained on a single line of a
{ "hardcopy" output, or the amount of data that can be displayed on a single line of console output.

    IF syv$dump_to_pf THEN
      page_width := 132;
    ELSE
      page_width := 80;
    IFEND;

    PUSH log_entry: [lgc$maximum_log_entry_size];
    PUSH display_line: [page_width];

{ Figure out which entry in the log should be the first one to be displayed.

    IF integer_variant THEN

{ Backspace through the log the specified number of entries.

      lgp$get_log_read_information (log_control_descriptor_p, pvt [1].int, log_cycle, log_data,
            ending_offset, status);
    ELSE {name_variant}

{ Set up to read from the beginning of the log.

      lgp$get_log_read_information (log_control_descriptor_p, 0, log_cycle, log_data,
            ending_offset, status);
      RESET log_data;
    IFEND;
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Set up to start reading the log at the first log message to be displayed.

    WHILE i#current_sequence_position (log_data) <= ending_offset DO

{ Get the log entry to be displayed.

      lgp$get_log_entry (log_cycle, log_control_descriptor_p, log_data, current_length, #SEQ(log_entry^)^,
            status);
      IF NOT status.normal THEN
        IF (status.condition = lge$end_of_log) OR (status.condition = lge$log_cycles_do_not_match) THEN
          status.normal := TRUE;
        IFEND;
        RETURN;
      IFEND;

{ Display the log entry, wrapping to more than one line if necessary.

      display_line_index := 1;
      indentation_size := 0;

      WHILE display_line_index <= current_length DO
        IF (current_length - display_line_index + 1) <= (page_width - indentation_size) THEN
          display_line_length := current_length - display_line_index + 1;
        ELSE
          display_line_length := page_width - indentation_size;
        IFEND;
        display_line^ (indentation_size + 1, display_line_length) :=
              log_entry^ (display_line_index, display_line_length);

{ Trim off trailing spaces.

        character_index := display_line_length + indentation_size;
        WHILE (character_index > 0) AND (display_line^ (character_index) = ' ') DO
          character_index := character_index - 1;
        WHILEND;
        IF character_index > 0 THEN
          syp$write_output_line (display_line^ (1, character_index), status);
        IFEND;
        display_line_index := display_line_index + display_line_length;
        indentation_size := 2;
        display_line^ (1, indentation_size) := '  ';
      WHILEND;
    WHILEND;

  PROCEND display_log;
?? OLDTITLE ??
?? NEWTITLE := '  DISPLAY_XCB', EJECT ??

{
{ Purpose:
{   This procedure displays the contents of the specified execution_control_block.
{        XCBP: Pointer to the execution_control_block which is to be displayed.
{        FULL: Boolean determines the amount of information which is to be displayed.  "TRUE" displays the
{          entire XCB.
{

  PROCEDURE display_xcb
    (    xcbp: ^ost$execution_control_block;
         full: boolean);

    VAR
      i: integer,
      msg: string (78),
      preg: ost$p_register,
      status: ost$status,
      str: string (60);


    status.normal := TRUE;

    msg := 'task name & addr:';
    msg (19, * ) := xcbp^.save9;
    syp$convert_bytes (#LOC (xcbp), #SIZE (xcbp), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'global task id:';
    syp$convert_bytes (#LOC (xcbp^.global_task_id), #SIZE (xcbp^.global_task_id), msg, add_to_eol);
    syp$write_output_line (msg, status);

    IF NOT full THEN
      RETURN;
    IFEND;

    msg := 'xp.p:';
    preg := xcbp^.xp.p_register;
    syp$convert_bytes (#LOC (preg), #SIZE (preg), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'xp.x0:';
    syp$convert_bytes (#LOC (xcbp^.xp.x_registers [0]), #SIZE (xcbp^.xp.x_registers [0]), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'monitor flags:';
    syp$convert_bytes (#LOC (xcbp^.monitor_flags), #SIZE (xcbp^.monitor_flags), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'system table lock count:';
    syp$convert_bytes (#LOC (xcbp^.system_table_lock_count), #SIZE (xcbp^.system_table_lock_count),
          msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'system flags:';
    syp$convert_bytes (#LOC (xcbp^.system_flags), #SIZE (xcbp^.system_flags), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'wait inhib, task terminating, task rethreaded: ';
    syp$write_output_line (msg, status);
    msg := '    ';
    msg (4, * ) := boolean_translations [xcbp^.wait_inhibited];
    msg (10, * ) := boolean_translations [xcbp^.task_is_terminating];
    msg (16, * ) := boolean_translations [xcbp^.task_has_been_rethreaded];
    syp$write_output_line (msg, status);

    msg := 'system give up cpu, subsystem give up cpu:';
    syp$write_output_line (msg, status);
    msg := '    ';
    msg (4, * ) := boolean_translations [xcbp^.system_give_up_cpu];
    msg (10, * ) := boolean_translations [xcbp^.subsystem_give_up_cpu];
    syp$write_output_line (msg, status);

    msg := 'parent global task id:';
    syp$convert_bytes (#LOC (xcbp^.parent_global_task_id), #SIZE (xcbp^.parent_global_task_id),
          msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'cpu priority:';
    syp$convert_bytes (#LOC (xcbp^.dispatching_priority), #SIZE (xcbp^.dispatching_priority),
          msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'system error count:';
    syp$convert_bytes (#LOC (xcbp^.system_error_count), #SIZE (xcbp^.system_error_count), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'link:';
    syp$convert_bytes (#LOC (xcbp^.link), #SIZE (xcbp^.link), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'task control block:';
    syp$convert_bytes (#LOC (xcbp^.task_control_block), #SIZE (xcbp^.task_control_block), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'task id:';
    syp$convert_bytes (#LOC (xcbp^.task_id), #SIZE (xcbp^.task_id), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'sdt offset:';
    syp$convert_bytes (#LOC (xcbp^.sdt_offset), #SIZE (xcbp^.sdt_offset), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'sdtx offset:';
    syp$convert_bytes (#LOC (xcbp^.sdtx_offset), #SIZE (xcbp^.sdtx_offset), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'cp time:';
    syp$convert_bytes (#LOC (xcbp^.cp_time), #SIZE (xcbp^.cp_time), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'page wait info:';
    syp$convert_bytes (#LOC (xcbp^.page_wait_info), #SIZE (xcbp^.page_wait_info), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'proc malf count:';
    syp$convert_bytes (#LOC (xcbp^.proc_malf_count), #SIZE (xcbp^.proc_malf_count), msg, add_to_eol);
    syp$write_output_line (msg, status);

    FOR i := 1 TO tmc$maximum_signals DO
      IF xcbp^.signals.present [i] THEN
        msg := 'signal(valid):';
      ELSE
        msg := 'signal(invalid):';
      IFEND;
      syp$convert_bytes (#LOC (xcbp^.signals.buffer [i].originator),
            #SIZE (xcbp^.signals.buffer [i].originator), msg, add_to_eol);
      syp$convert_bytes (#LOC (xcbp^.signals.buffer [i].signal), #SIZE (xcbp^.signals.buffer [i].signal),
            msg, add_to_eol);
      syp$write_output_line (msg, status);
    FOREND;

    msg := 'paging statistics:';
    syp$write_output_line (msg, status);
    msg := '  pages from disk:';
    syp$convert_bytes (#LOC (xcbp^.paging_statistics.page_in_count),
          #SIZE (xcbp^.paging_statistics.page_in_count), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  pages reclaimed:';
    syp$convert_bytes (#LOC (xcbp^.paging_statistics.pages_reclaimed_from_queue),
          #SIZE (xcbp^.paging_statistics.pages_reclaimed_from_queue), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  new pages assigned:';
    syp$convert_bytes (#LOC (xcbp^.paging_statistics.new_pages_assigned),
          #SIZE (xcbp^.paging_statistics.new_pages_assigned), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  pages from server:';
    syp$convert_bytes (#LOC (xcbp^.paging_statistics.pages_from_server),
          #SIZE (xcbp^.paging_statistics.pages_from_server), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  page fault count:';
    syp$convert_bytes (#LOC (xcbp^.paging_statistics.page_fault_count),
          #SIZE (xcbp^.paging_statistics.page_fault_count), msg, add_to_eol);
    syp$write_output_line (msg, status);

  PROCEND display_xcb;
?? OLDTITLE ??
?? NEWTITLE := '  DISSEPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the DISPLAY_STACK_ENVIRONMENT command.  There are no parameters for the command.
{ This procedure displays the segment number and the top-of-stack values for each ring in which a task is
{ executing.  It also displays the memory contents of the stack if the command is displaying output to a
{ permanent file and/or the printer.
{

  PROCEDURE disseproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      bn: 0 .. 0ffffffff(16),
      i: 0 .. 15,
      ignore: integer,
      msg: string (55),
      pc: ^cell,
      tos_pointer: ^cell,
      sn: 0 .. 0fff(16),
      str: string (60),
      xcbp: ^ost$execution_control_block;

    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY STACK ENVIRONMENT ', text);
    IFEND;

    pmp$find_executing_task_xcb (xcbp);

    FOR i := 1 TO 15 DO
      tos_pointer := #ADDRESS (xcbp^.xp.tos_registers [i].pva.ring, xcbp^.xp.tos_registers [i].pva.seg,
            xcbp^.xp.tos_registers [i].pva.offset);
      IF tos_pointer <> NIL THEN
        sn := xcbp^.xp.tos_registers [i].pva.seg;
        IF i = 1 THEN

{ Special code for ring 1.

          PUSH pc;
          bn := #OFFSET (pc);
        ELSE
          bn := xcbp^.xp.tos_registers [i].pva.offset;
        IFEND;

        msg := ' STACK INFO: RING/SEG/HIGH ';
        syp$convert_bytes (#LOC (i), #SIZE (i), msg, add_to_eol);
        syp$convert_bytes (#LOC (sn), #SIZE (sn), msg, add_to_eol);
        syp$convert_bytes (#LOC (bn), #SIZE (bn), msg, add_to_eol);
        syp$write_output_line (msg, status);

        IF syv$dump_to_pf THEN
          msg := '  ';
          pc := #ADDRESS (1, sn, 0);
          syp$convert_bytes (#LOC (pc), #SIZE (pc), msg, add_to_eol);
          STRINGREP (msg (14, 15), ignore, bn);

{ Force the memory display of the stack.

          msg (35, 1) := 'F';
          dmproc (msg, display_id, status);

          msg := '  ';
          syp$write_output_line (msg, status);
          syp$write_output_line (msg, status);
          syp$write_output_line (msg, status);
        IFEND;
      IFEND;
    FOREND;
    status.normal := TRUE;
  PROCEND disseproc;
?? OLDTITLE ??
?? NEWTITLE := '  DISSFID_PROC', EJECT ??

{ DISPLAY_SYSTEM_FILE_ID parameter descriptor table:

  VAR
    sfid_display_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 1] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'sfid    ', syc$integer_value, 0, 1, 0ffffffff(16)]];

{
{ Purpose:
{   This procedure processes the DISPLAY_SYSTEM_FILE_ID command.  This procedure displays the file descriptor
{ entry associated with the specified SFID if it is in real memory.  The parameter for the command is:
{        SFID: Required, integer.
{          Specifies the system file identifier of the file to be displayed.
{

  PROCEDURE dissfid_proc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      fde_p: gft$file_desc_entry_p,
      pvt: array [1 .. 1] of syt$parameter_value,
      rma: integer,
      sfid_converter: debug_sfid_converter,
      str: string (60);

    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;

    syp$crack_command (sfid_display_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY SYSTEM FILE ID', text);
    IFEND;

    sfid_converter.int := pvt [1].int;
    gfp$get_fde_p (sfid_converter.sfid, fde_p);
    IF fde_p = NIL THEN
      osp$set_status_abnormal ('DB', dbe$, 'SFID does not exist', status);
      RETURN;
    IFEND;

    i#real_memory_address (fde_p, rma);
    IF rma < 0 THEN
      osp$set_status_abnormal ('DB', dbe$, 'FDE_P not in real memory', status);
      RETURN;
    IFEND;

    i#real_memory_address (#ADDRESS (#RING (fde_p), #SEGMENT (fde_p), #OFFSET(fde_p) +
          #SIZE (gft$file_descriptor_entry)), rma);
    IF rma < 0 THEN
      osp$set_status_abnormal ('DB', dbe$, 'End of FDE_P not in real memory', status);
      RETURN;
    IFEND;

{ Display the FDE associated with the system_file_id.

    str := ' Corresponding File Descriptor Entry:';
    syp$write_output_line (str, status);

    str := '   job lock:';
    syp$write_output_line (str, status);
    str := '     locked:';
    IF fde_p^.job_lock.locked THEN
      str (14, *) := 'TRUE';
    ELSE
      str (14, *) := 'FALSE';
    IFEND;
    syp$write_output_line (str, status);
    str := '     count:';
    syp$convert_bytes (#LOC (fde_p^.job_lock.count), #SIZE (fde_p^.job_lock.count), str, add_to_eol);
    syp$write_output_line (str, status);
    str := '     gtid:';
    syp$convert_bytes (#LOC (fde_p^.job_lock.gtid), #SIZE (fde_p^.job_lock.gtid), str, add_to_eol);
    syp$write_output_line (str, status);
    str := '     p register:';
    syp$convert_bytes (#LOC (fde_p^.job_lock.p_register), #SIZE (fde_p^.job_lock.p_register),
          str, add_to_eol);
    syp$write_output_line (str, status);
    str := '     p register 2:';
    syp$convert_bytes (#LOC (fde_p^.job_lock.p_register_2), #SIZE (fde_p^.job_lock.p_register_2),
          str, add_to_eol);
    syp$write_output_line (str, status);

    str := '   monitor lock:';
    syp$convert_bytes (#LOC (fde_p^.monitor_lock), #SIZE (fde_p^.monitor_lock), str, add_to_eol);
    syp$write_output_line (str, status);

    str := '   flags:';
    syp$write_output_line (str, status);
    str := '     eoi modified:';
    IF fde_p^.flags.eoi_modified THEN
      str (21, *) := 'TRUE';
    ELSE
      str (21, *) := 'FALSE';
    IFEND;
    syp$write_output_line (str, status);
    str := '     wire eoi page:';
    IF fde_p^.flags.wire_eoi_page THEN
      str (21, *) := 'TRUE';
    ELSE
      str (21, *) := 'FALSE';
    IFEND;
    syp$write_output_line (str, status);
    str := '     active_shadow_file:';
    IF fde_p^.flags.active_shadow_file THEN
      str (21, *) := 'TRUE';
    ELSE
      str (21, *) := 'FALSE';
    IFEND;
    syp$write_output_line (str, status);
    str := ' global_template:';
    IF fde_p^.flags.global_template_file THEN
      str (21, *) := 'TRUE';
    ELSE
      str (21, *) := 'FALSE';
    IFEND;
    syp$write_output_line (str, status);
    str := '     fde spare 4:';
    IF fde_p^.flags.fde_spare_4 THEN
      str (21, *) := 'TRUE';
    ELSE
      str (21, *) := 'FALSE';
    IFEND;
    syp$write_output_line (str, status);
    str := '     fde spare 5:';
    IF fde_p^.flags.fde_spare_5 THEN
      str (21, *) := 'TRUE';
    ELSE
      str (21, *) := 'FALSE';
    IFEND;
    syp$write_output_line (str, status);
    str := '     fde spare 6:';
    IF fde_p^.flags.fde_spare_6 THEN
      str (21, *) := 'TRUE';
    ELSE
      str (21, *) := 'FALSE';
    IFEND;
    syp$write_output_line (str, status);
    str := '     fde spare 7:';
    IF fde_p^.flags.fde_spare_7 THEN
      str (21, *) := 'TRUE';
    ELSE
      str (21, *) := 'FALSE';
    IFEND;
    syp$write_output_line (str, status);

    str := '   global file name:';
    syp$convert_bytes (#LOC (fde_p^.global_file_name), #SIZE (fde_p^.global_file_name), str, add_to_eol);
    syp$write_output_line (str, status);

    str := '   file hash thread:';
    syp$convert_bytes (#LOC (fde_p^.file_hash_thread), #SIZE (fde_p^.file_hash_thread), str, add_to_eol);
    syp$write_output_line (str, status);

    str := '   attached in write count:';
    syp$convert_bytes (#LOC (fde_p^.attached_in_write_count), #SIZE (fde_p^.attached_in_write_count), str,
          add_to_eol);
    syp$write_output_line (str, status);

    str := '   attach count:';
    syp$convert_bytes (#LOC (fde_p^.attach_count), #SIZE (fde_p^.attach_count), str, add_to_eol);
    syp$write_output_line (str, status);

    str := '   open count:';
    syp$convert_bytes (#LOC (fde_p^.open_count), #SIZE (fde_p^.open_count), str, add_to_eol);
    syp$write_output_line (str, status);

    str := '   file kind:';
    CASE fde_p^.file_kind OF
    = gfc$fk_job_permanent_file =
      str (15, *) := 'FK_JOB_PERMANENT_FILE';
    = gfc$fk_device_file =
      str (15, *) := 'FK_DEVICE_FILE';
    = gfc$fk_save_2 =
      str (15, *) := 'FK_SAVE_2';
    = gfc$fk_save_3 =
      str (15, *) := 'FK_SAVE_3';
    = gfc$fk_catalog =
      str (15, *) := 'FK_CATALOG';
    = gfc$fk_job_local_file =
      str (15, *) := 'FK_JOB_LOCAL_FILE';
    = gfc$fk_unnamed_file =
      str (15, *) := 'FK_UNNAMED_FILE';
    = gfc$fk_global_unnamed =
      str (15, *) := 'FK_GLOBAL_UNNAMED';
    = gfc$fk_monitor_only_unnamed =
      str (15, *) := 'FK_MONITOR_ONLY_UNNAMED';
    ELSE
      syp$convert_bytes (#LOC (fde_p^.file_kind), #SIZE (fde_p^.file_kind), str, add_to_eol);
    CASEND;
    syp$write_output_line (str, status);

    str := '   file hash:';
    syp$convert_bytes (#LOC (fde_p^.file_hash), #SIZE (fde_p^.file_hash), str, add_to_eol);
    syp$write_output_line (str, status);

    str := '   segment lock:';
    syp$write_output_line (str, status);
    str := '     locked for read:';
    syp$convert_bytes (#LOC (fde_p^.segment_lock.locked_for_read),
          #SIZE (fde_p^.segment_lock.locked_for_read), str, add_to_eol);
    str := '     locked for write:';
    IF fde_p^.segment_lock.locked_for_write THEN
      str (24, *) := 'TRUE';
    ELSE
      str (24, *) := 'FALSE';
    IFEND;
    syp$write_output_line (str, status);
    str := '     task queue link:';
    syp$write_output_line (str, status);
    str := '       head:';
    syp$convert_bytes (#LOC (fde_p^.segment_lock.task_queue.head),
          #SIZE (fde_p^.segment_lock.task_queue.head), str, add_to_eol);
    syp$write_output_line (str, status);
    str := '       tail:';
    syp$convert_bytes (#LOC (fde_p^.segment_lock.task_queue.tail),
          #SIZE (fde_p^.segment_lock.task_queue.tail), str, add_to_eol);
    syp$write_output_line (str, status);

    str := '   asti:';
    syp$convert_bytes (#LOC (fde_p^.asti), #SIZE (fde_p^.asti), str, add_to_eol);
    syp$write_output_line (str, status);

    str := '   eoi byte address:';
    syp$convert_bytes (#LOC (fde_p^.eoi_byte_address), #SIZE (fde_p^.eoi_byte_address), str, add_to_eol);
    syp$write_output_line (str, status);

    str := '   eoi state:';
    IF fde_p^.eoi_state = mmc$eoi_actual THEN
      str (15, *) := 'EOI_ACTUAL';
    ELSEIF fde_p^.eoi_state = mmc$eoi_rounded THEN
      str (15, *) := 'EOI_ROUNDED';
    ELSEIF fde_p^.eoi_state = mmc$eoi_uncertain THEN
      str (15, *) := 'EOI_UNCERTAIN';
    ELSE
      syp$convert_bytes (#LOC (fde_p^.eoi_state), #SIZE (fde_p^.eoi_state), str, add_to_eol);
    IFEND;
    syp$write_output_line (str, status);

    str := '   allocation unit size:';
    syp$convert_bytes (#LOC (fde_p^.allocation_unit_size), #SIZE (fde_p^.allocation_unit_size), str,
          add_to_eol);
    syp$write_output_line (str, status);

    str := '   transfer unit size:';
    syp$convert_bytes (#LOC (fde_p^.transfer_unit_size), #SIZE (fde_p^.transfer_unit_size), str, add_to_eol);
    syp$write_output_line (str, status);

    str := '   file limit:';
    syp$convert_bytes (#LOC (fde_p^.file_limit), #SIZE (fde_p^.file_limit), str, add_to_eol);
    syp$write_output_line (str, status);

    str := '   queue status:';
    IF fde_p^.queue_status = gfc$qs_global_shared THEN
      str (18, *) := 'GLOBAL_SHARED';
    ELSEIF fde_p^.queue_status = gfc$qs_job_shared THEN
      str (18, *) := 'JOB_SHARED';
    ELSEIF fde_p^.queue_status = gfc$qs_job_working_set THEN
      str (18, *) := 'JOB_WORKING_SET';
    ELSE
      syp$convert_bytes (#LOC (fde_p^.queue_status), #SIZE (fde_p^.queue_status), str, add_to_eol);
    IFEND;
    syp$write_output_line (str, status);

    str := '   preset value:';
    IF fde_p^.preset_value = pmc$initialize_to_zero THEN
      str (18, *) := 'INITIALIZE_TO_ZERO';
    ELSEIF fde_p^.preset_value = pmc$initialize_to_alt_ones THEN
      str (18, *) := 'INITIALIZE_TO_ALT_ONES';
    ELSEIF fde_p^.preset_value = pmc$initialize_to_indefinite THEN
      str (18, *) := 'INITIALIZE_TO_INDEFINITE';
    ELSEIF fde_p^.preset_value = pmc$initialize_to_infinity THEN
      str (18, *) := 'INITIALIZE_TO_INFINITY';
    ELSE
      syp$convert_bytes (#LOC (fde_p^.preset_value), #SIZE (fde_p^.preset_value), str, add_to_eol);
    IFEND;
    syp$write_output_line (str, status);

    str := '   time last modified:';
    syp$convert_bytes (#LOC (fde_p^.time_last_modified), #SIZE (fde_p^.time_last_modified), str,
          add_to_eol);
    syp$write_output_line (str, status);

    str := '   last segment number:';
    syp$convert_bytes (#LOC (fde_p^.last_segment_number), #SIZE (fde_p^.last_segment_number), str,
          add_to_eol);
    syp$write_output_line (str, status);

    str := '   global task id:';
    syp$convert_bytes (#LOC (fde_p^.global_task_id), #SIZE (fde_p^.global_task_id), str, add_to_eol);
    syp$write_output_line (str, status);

    str := '   stack for ring:';
    syp$convert_bytes (#LOC (fde_p^.stack_for_ring), #SIZE (fde_p^.stack_for_ring), str, add_to_eol);
    syp$write_output_line (str, status);

    str := '   media:';
    IF fde_p^.media = gfc$fm_transient_segment THEN
      str (11, *) := 'TRANSIENT_SEGMENT';
    ELSEIF fde_p^.media = gfc$fm_mass_storage_file THEN
      str (11, *) := 'MASS_STORAGE_FILE';
      syp$write_output_line (str, status);
      str := '     disk_file_descriptor_p:';
      syp$convert_bytes (#LOC (fde_p^.disk_file_descriptor_p), #SIZE (fde_p^.disk_file_descriptor_p), str,
            add_to_eol);
    ELSEIF fde_p^.media = gfc$fm_served_file THEN
      str (11, *) := 'SERVED_FILE';
      syp$write_output_line (str, status);
      str := '     served_file_descriptor_p:';
      syp$convert_bytes (#LOC (fde_p^.served_file_descriptor_p), #SIZE (fde_p^.served_file_descriptor_p), str,
             add_to_eol);
    ELSE
      syp$convert_bytes (#LOC (fde_p^.media), #SIZE (fde_p^.media), str, add_to_eol);
    IFEND;
    syp$write_output_line (str, status);

    status.normal := TRUE;

  PROCEND dissfid_proc;
?? OLDTITLE ??
?? NEWTITLE := '  DISSLPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the DISPLAY_SYSTEM_LOG command.  The parameter for the command is as follows:
{        ENTRIES: Optional, integer or keyword ALL.
{          Specifies the number of log entries to be displayed.  The default value for this parameter is 1000.
{

  PROCEDURE disslproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      header_string: string (60),
      log_control_desc_p: ^lgt$log_control_descriptor,
      log_control_descriptors_p: ^array [pmt$global_logs] of lgt$log_control_descriptor;

    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY SYSTEM LOG ', text);
    IFEND;

    IF (syv$job_template_ptr_array = NIL) OR (UPPERBOUND (syv$job_template_ptr_array^) < 2) THEN
      osp$set_status_abnormal ('DB', dbe$, 'not available', status);
      RETURN;
    IFEND;

    syp$verify_access (syc$readable, #LOC (syv$job_template_ptr_array^ [2]), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    log_control_descriptors_p := syv$job_template_ptr_array^ [2];
    log_control_desc_p := ^log_control_descriptors_p^ [pmc$system_log];

    display_log (text, log_control_desc_p, status);

  PROCEND disslproc;
?? OLDTITLE ??
?? NEWTITLE := '  DISSTPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the DISPLAY_SEGMENT_TABLE command.  It displays the segment table entry for the
{   specified segment.  The parameters for the command are as follows:
{        NUMBER: Required, integer.
{          Specifies the number of the segment to display.
{        GTID: Optional, integer.
{          Specifies the global_task_id of the task whose segment table entry is to be displayed.  Use of this
{          value will display the table entry of the task with the corresponding GTID.  If this parameter is
{          not specified the debugger will display the table entry of the task which is currently in the
{          debugger.
{


{ DISPLAY_SEGMENT_TABLE parameter descriptor table:

  VAR
    sdt_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 2] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'number  ', syc$integer_value, 0, 0, 7fffffff(16)],
{   } [FALSE, 2, 'gtid    ', syc$integer_value, 0, 0, 0fffff(16)]];

  PROCEDURE disstproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      asid: ost$asid,
      execution_privilege: ost$execute_privilege,
      gtid: gtid_converter,
      gtid_found: boolean,
      key_lock: ost$key_lock,
      msg: string (70),
      pvt: array [1 .. 2] of syt$parameter_value,
      read_privilage: ost$read_privilege,
      ring_1: ost$ring,
      ring_2: ost$ring,
      sdte_p: ^mmt$segment_descriptor,
      segment_number: integer,
      str: string (60),
      svl: (osc$vl_invalid_entry, osc$vl_reserved, osc$vl_regular_segment, osc$vl_cache_bypass),
      write_privilege: ost$write_privilege,
      xcb_p: ^ost$execution_control_block;


    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;
    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (sdt_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT est_flag THEN
      IF syv$dump_to_pf THEN
        syp$write_output_header (' DISPLAY SEGMENT TABLE ENTRY ', text);
      IFEND;
    ELSE
      str := '   ';
      syp$write_output_line (str, status);
      str := ' DISPLAY SEGMENT TABLE ENTRY ';
      str (31, * ) := text;
      syp$write_output_line (str, status);
    IFEND;

    segment_number := pvt [1].int;
    IF pvt [2].defined AND (pvt [2].int <> 0) THEN
      gtid.base := pvt [2].int;
      gtid_found := FALSE;
      xcb_p := job_xcb_list.head;
      WHILE (xcb_p <> NIL) AND (NOT gtid_found) DO
        IF xcb_p^.global_task_id = gtid.global_task_id THEN
          gtid_found := TRUE;
        ELSE
          xcb_p := xcb_p^.link;
        IFEND;
      WHILEND;
      IF NOT gtid_found THEN
        syp$write_output_line ('ERROR - Task with specified GTID was not found.', status);
        RETURN;
      IFEND;
      IF NOT est_flag THEN
        msg := ' Segment Table entry for alternate task: ';
        syp$write_output_line (msg, status);
        msg := ' ';
        msg (4, * ) := xcb_p^.save9;
        syp$write_output_line (msg, status);
        msg := ' ';
        syp$write_output_line (msg, status);
      IFEND;
    ELSE
      pmp$find_executing_task_xcb (xcb_p);
    IFEND;

    IF (segment_number > (xcb_p^.xp.segment_table_length)) OR (segment_number < 0) THEN
      osp$set_status_abnormal ('sy', dbe$, 'segment number out of range', status);
      RETURN;
    IFEND;

    sdte_p := mmp$get_sdt_entry_p (xcb_p, segment_number);
    IF sdte_p^.ste.vl = osc$vl_invalid_entry THEN
      msg := ' INVALID ENTRY ';
      syp$write_output_line (msg, status);
      RETURN;
    IFEND;
    msg := 'ste.vl:';
    svl := sdte_p^.ste.vl;
    CASE svl OF
    = osc$vl_reserved =
      msg (9, * ) := 'reserved';
    = osc$vl_regular_segment =
      msg (9, * ) := 'regular segment';
    = osc$vl_cache_bypass =
      msg (9, * ) := 'cache bypass';
    ELSE
      syp$convert_bytes (#LOC (svl), #SIZE (svl), msg, add_to_eol);
    CASEND;
    syp$write_output_line (msg, status);

    msg := 'ste.xp:';
    CASE sdte_p^.ste.xp OF
    = osc$non_executable =
      msg (9, * ) := 'non executable';
    = osc$non_privileged =
      msg (9, * ) := 'non_privileged';
    = osc$local_privilege =
      msg (9, * ) := 'local privilege';
    = osc$global_privilege =
      msg (9, * ) := 'global privilege';
    ELSE
      execution_privilege := sdte_p^.ste.xp;
      syp$convert_bytes (#LOC (execution_privilege), #SIZE (execution_privilege), msg, add_to_eol);
    CASEND;
    syp$write_output_line (msg, status);

    msg := 'ste.rp:';
    CASE sdte_p^.ste.rp OF
    = osc$non_readable =
      msg (9, * ) := 'non readable';
    = osc$read_key_lock_controlled =
      msg (9, * ) := 'read key lock controlled';
    = osc$read_uncontrolled =
      msg (9, * ) := 'read uncontrolled';
    = osc$binding_segment =
      msg (9, * ) := 'binding segment';
    ELSE
      read_privilage := sdte_p^.ste.rp;
      syp$convert_bytes (#LOC (read_privilage), #SIZE (read_privilage), msg, add_to_eol);
    CASEND;
    syp$write_output_line (msg, status);

    msg := 'ste.wp:';
    CASE sdte_p^.ste.wp OF
    = osc$non_writable =
      msg (9, * ) := 'non writeable';
    = osc$write_key_lock_controlled =
      msg (9, * ) := 'write_key_lock_controlled';
    = osc$write_uncontrolled =
      msg (9, * ) := 'write_uncontrolled';
    = osc$wp_reserved =
      msg (9, * ) := 'wp reserved';
    ELSE
      write_privilege := sdte_p^.ste.wp;
      syp$convert_bytes (#LOC (write_privilege), #SIZE (write_privilege), msg, add_to_eol);
    CASEND;
    syp$write_output_line (msg, status);

    msg := 'ste.r1:';
    ring_1 := sdte_p^.ste.r1;
    syp$convert_bytes (#LOC (ring_1), #SIZE (ring_1), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'ste.r2:';
    ring_2 := sdte_p^.ste.r2;
    syp$convert_bytes (#LOC (ring_2), #SIZE (ring_2), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'ste.asid:';
    asid := sdte_p^.ste.asid;
    syp$convert_bytes (#LOC (asid), #SIZE (asid), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'ste.key_lock:';
    key_lock := sdte_p^.ste.key_lock;
    syp$convert_bytes (#LOC (key_lock), #SIZE (key_lock), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'fill1:';
    syp$convert_bytes (#LOC (sdte_p^.fill1), #SIZE (sdte_p^.fill1), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'asti:';
    syp$convert_bytes (#LOC (sdte_p^.asti), #SIZE (sdte_p^.asti), msg, add_to_eol);
    syp$write_output_line (msg, status);

  PROCEND disstproc;
?? OLDTITLE ??
?? NEWTITLE := '  DISSTXPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the DISPLAY_SEGMENT_TABLE_EXTENDED command.  It displays the segment table
{   (extended) entry for the specified segment.  The parameters for the command are as follows:
{        NUMBER: Required, integer.
{          Specifies the number of the segment to display.
{        GTID: Optional, integer.
{          Specifies the global_task_id of the task whose segment table extended entry is to be displayed.
{          Use of this value will display the table entry of the task with the corresponding GTID.  If this
{          parameter is not specified the debugger will display the table entry of the task which is currently
{          in the debugger.
{


{ DISPLAY_SEGMENT_TABLE_EX parameter descriptor table:

  VAR
    sdtx_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 2] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'number  ', syc$integer_value, 0, 0, 7fffffff(16)],
{   } [FALSE, 2, 'gtid    ', syc$integer_value, 0, 0, 0fffff(16)]];

  PROCEDURE disstxproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      gtid: gtid_converter,
      gtid_found: boolean,
      msg: string (80),
      msg2: string (130),
      pvt: array [1 .. 2] of syt$parameter_value,
      sdte_p: ^mmt$segment_descriptor,
      sdtxe_p: ^mmt$segment_descriptor_extended,
      segnum: integer,
      size: integer,
      str: string (60),
      stream: integer,
      xcb_p: ^ost$execution_control_block;

    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (sdtx_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT est_flag THEN
      IF syv$dump_to_pf THEN
        syp$write_output_header (' DISPLAY SEGMENT TABLE EXTENDED ENTRY ', text);
      IFEND;
    ELSE
      str := '     ';
      syp$write_output_line (str, status);
      str := ' DISPLAY SEGMENT TABLE EXTENDED ENTRY ';
      str (40, * ) := text;
      syp$write_output_line (str, status);
    IFEND;

    segnum := pvt [1].int;
    IF pvt [2].defined AND (pvt [2].int <> 0) THEN
      gtid.base := pvt [2].int;
      gtid_found := FALSE;
      xcb_p := job_xcb_list.head;
      WHILE (xcb_p <> NIL) AND (NOT gtid_found) DO
        IF xcb_p^.global_task_id = gtid.global_task_id THEN
          gtid_found := TRUE;
        ELSE
          xcb_p := xcb_p^.link;
        IFEND;
      WHILEND;
      IF NOT gtid_found THEN
        syp$write_output_line ('ERROR - Task with specified GTID was not found.', status);
        RETURN;
      IFEND;
      IF NOT est_flag THEN
        msg := ' Segment Table Extended entry for alternate task: ';
        syp$write_output_line (msg, status);
        msg := ' ';
        msg (4, * ) := xcb_p^.save9;
        syp$write_output_line (msg, status);
        msg := ' ';
        syp$write_output_line (msg, status);
      IFEND;
    ELSE
      pmp$find_executing_task_xcb (xcb_p);
    IFEND;

    IF (segnum > (xcb_p^.xp.segment_table_length)) OR (segnum < 0) THEN
      osp$set_status_abnormal ('sy', dbe$, 'segment number out of range', status);
      RETURN;
    IFEND;

    sdte_p := mmp$get_sdt_entry_p (xcb_p, segnum);
    sdtxe_p := mmp$get_sdtx_entry_p (xcb_p, segnum);
    IF sdte_p^.ste.vl = osc$vl_invalid_entry THEN
      msg := ' INVALID ENTRY ';
      syp$write_output_line (msg, status);
      RETURN;
    IFEND;

    msg := 'open validating ring number:';
    syp$convert_bytes (#LOC (sdtxe_p^.open_validating_ring_number),
          #SIZE (sdtxe_p^.open_validating_ring_number), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'access state:';
    CASE sdtxe_p^.access_state OF
    = mmc$sas_allow_access =
      msg (15, * ) := 'sas_allow_access';
    = mmc$sas_inhibit_access =
      msg (15, * ) := 'sas_inhibit_access';
    = mmc$sas_terminate_access =
      msg (15, * ) := 'sas_terminate_access';
    ELSE
      syp$convert_bytes (#LOC (sdtxe_p^.access_state), #SIZE (sdtxe_p^.access_state), msg, add_to_eol);
    CASEND;
    syp$write_output_line (msg, status);

    msg := 'sfid:';
    syp$convert_bytes (#LOC (sdtxe_p^.sfid), #SIZE (sdtxe_p^.sfid), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := 'inheritance:';
    CASE sdtxe_p^.inheritance OF
    = mmc$si_none =
      msg (14, * ) := 'si_none';
    = mmc$si_share_segment =
      msg (14, * ) := 'si_share_segment';
    = mmc$si_transfer_segment =
      msg (14, * ) := 'si_transfer_segment';
    = mmc$si_new_segment =
      msg (14, * ) := 'si_new_segment';
    ELSE
      syp$convert_bytes (#LOC (sdtxe_p^.inheritance), #SIZE (sdtxe_p^.inheritance), msg, add_to_eol);
    CASEND;
    syp$write_output_line (msg, status);

    msg := 'segment reservation state:';
    CASE sdtxe_p^.segment_reservation_state OF
    = mmc$srs_not_reserved =
      msg (28, * ) := ' NOT RESERVED';
    = mmc$srs_reserved =
      msg (28, * ) := ' RESERVED';
    = mmc$srs_reserved_shared_stack =
      msg (28, * ) := ' RESERVED SHARED STACK';
    ELSE
      syp$convert_bytes (#LOC (sdtxe_p^.segment_reservation_state),
            #SIZE (sdtxe_p^.segment_reservation_state), msg, add_to_eol);
    CASEND;
    syp$write_output_line (msg, status);

    msg2 := 'software attribute set:';
    syp$write_output_line (msg2, status);
    msg2 := '';
    size := 21;
    IF (mmc$sa_wired IN sdtxe_p^.software_attribute_set) THEN
      msg2 (size, 10) := ' wired';
      size := size + 10;
    IFEND;
    IF (mmc$sa_fixed IN sdtxe_p^.software_attribute_set) THEN
      msg2 (size, 10) := 'sa_fixed';
      size := size + 10;
    IFEND;
    IF (mmc$sa_stack IN sdtxe_p^.software_attribute_set) THEN
      msg2 (size, 10) := 'sa_stack';
      size := size + 10;
    IFEND;
    IF (mmc$sa_read_transfer_unit IN sdtxe_p^.software_attribute_set) THEN
      msg2 (size, 20) := 'read_transfer_unit';
      size := size + 20;
    IFEND;
    IF (mmc$sa_free_behind IN sdtxe_p^.software_attribute_set) THEN
      msg2 (size, 15) := 'free_behind';
      size := size + 15;
    IFEND;
    IF (mmc$sa_no_append IN sdtxe_p^.software_attribute_set) THEN
      msg2 (size, 15) := 'no_append';
      size := size + 15;
    IFEND;
    IF (mmc$sa_job_shared IN sdtxe_p^.software_attribute_set) THEN
      msg2 (size, 14) := ' job_shared';
      size := size + 14;
    IFEND;
    IF size <> 21 THEN
      syp$write_output_line (msg2, status);
    IFEND;

    msg := 'access rights:';
    CASE sdtxe_p^.access_rights OF
    = mmc$sar_none =
      msg (16, * ) := 'sar_none';
    = mmc$sar_read =
      msg (16, * ) := 'sar_read';
    = mmc$sar_modify =
      msg (16, * ) := 'sar_modify';
    = mmc$sar_write_extend =
      msg (16, * ) := 'sar_write_extend';
    ELSE
      syp$convert_bytes (#LOC (sdtxe_p^.access_rights),
            #SIZE (sdtxe_p^.access_rights), msg, add_to_eol);
    CASEND;
    syp$write_output_line (msg, status);

    msg := 'segment lock:';
    CASE sdtxe_p^.segment_lock OF
    = mmc$lss_none =
      msg (15, * ) := 'lss_none';
    = mmc$lss_lock_for_read_r3  =
      msg (15, * ) := 'lss_lock_for_read_r3';
    = mmc$lss_lock_for_write_r3 =
      msg (15, * ) := 'lss_lock_for_write_r3';
    ELSE
      syp$convert_bytes (#LOC (sdtxe_p^.segment_lock),
            #SIZE (sdtxe_p^.segment_lock), msg, add_to_eol);
    CASEND;
    syp$write_output_line (msg, status);

    msg := 'shadow info:';
    syp$write_output_line (msg, status);
    msg := '  shadow start page number:';
    syp$convert_bytes (#LOC (sdtxe_p^.shadow_info.shadow_start_page_number),
          #SIZE (sdtxe_p^.shadow_info.shadow_start_page_number), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := '  shadow length page count:';
    syp$convert_bytes (#LOC (sdtxe_p^.shadow_info.shadow_length_page_count),
          #SIZE (sdtxe_p^.shadow_info.shadow_length_page_count), msg, add_to_eol);
    syp$write_output_line (msg, status);

    msg := '  shadowed segment kind:';
    CASE sdtxe_p^.shadow_info.shadow_segment_kind OF
    = mmc$ssk_none =
      msg (26, * ) := 'ssk_none';
    = mmc$ssk_read_write_file =
      msg (26, * ) := 'ssk_read_write_file';
    = mmc$ssk_read_only_file =
      msg (26, * ) := 'ssk_read_only_file';
    = mmc$ssk_read_only_trans_file =
      msg (26, * ) := 'ssk_read_only_trans_file';
    = mmc$ssk_segment_number =
      msg (26, * ) := 'ssk_segment_number';
    ELSE
      syp$convert_bytes (#LOC (sdtxe_p^.shadow_info.shadow_segment_kind),
            #SIZE (sdtxe_p^.shadow_info.shadow_segment_kind), msg, add_to_eol);
    CASEND;
    syp$write_output_line (msg, status);
    IF sdtxe_p^.shadow_info.shadow_segment_kind = mmc$ssk_segment_number THEN
      msg := '  shadow segment number:';
      syp$convert_bytes (#LOC (sdtxe_p^.shadow_info.shadow_segment_number),
            #SIZE (sdtxe_p^.shadow_info.shadow_segment_number), msg, add_to_eol);
    ELSE
      msg := '  shadow sfid:';
      syp$convert_bytes (#LOC (sdtxe_p^.shadow_info.shadow_sfid),
            #SIZE (sdtxe_p^.shadow_info.shadow_sfid), msg, add_to_eol);
    IFEND;
    syp$write_output_line (msg, status);

    msg := 'file limits enforced:';
    CASE sdtxe_p^.file_limits_enforced OF
    = sfc$no_limit =
      msg (30, * ) := ' no_limit';
    = sfc$perm_file_space_limit =
      msg (30, * ) := ' perm_file_space_limit';
    = sfc$temp_file_space_limit =
      msg (30, * ) := ' temp_file_space_limit';
    ELSE
      syp$convert_bytes (#LOC (sdtxe_p^.file_limits_enforced),
            #SIZE (sdtxe_p^.file_limits_enforced), msg, add_to_eol);
    CASEND;

    msg := 'stream:';
    syp$write_output_line (msg, status);
    msg := '  last page fault:';
    stream := sdtxe_p^.stream.last_page_fault;
    syp$convert_bytes (#LOC (stream), #SIZE (stream), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  sequential accesses:';
    stream := sdtxe_p^.stream.sequential_accesses;
    syp$convert_bytes (#LOC (stream), #SIZE (stream), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  transfer size:';
    stream := sdtxe_p^.stream.transfer_size;
    syp$convert_bytes (#LOC (stream), #SIZE (stream), msg, add_to_eol);
    msg := '  random faults:';
    stream := sdtxe_p^.stream.transfer_size;
    syp$convert_bytes (#LOC (stream), #SIZE (stream), msg, add_to_eol);
    syp$write_output_line (msg, status);
    msg := '  streaming:';
    msg (14, * ) := boolean_translations [sdtxe_p^.stream.streaming];
    syp$write_output_line (msg, status);
    msg := '  transfer size specified:';
    msg (28, * ) := boolean_translations [sdtxe_p^.stream.transfer_size_specified];
    syp$write_output_line (msg, status);
    msg := '  preset streaming:';
    msg (21, * ) := boolean_translations [sdtxe_p^.stream.preset_streaming];
    syp$write_output_line (msg, status);

    msg := 'assign active:';
    syp$convert_bytes (#LOC (sdtxe_p^.assign_active), #SIZE (sdtxe_p^.assign_active), msg, add_to_eol);
    syp$write_output_line (msg, status);

  PROCEND disstxproc;
?? OLDTITLE ??
?? NEWTITLE := '  DISTEPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the DISPLAY_TASK_ENTRY command.  There are no parameters for the command.  This
{ procedure displays the execution control block (XCB) of all tasks in the job in which the system core
{ debugger is executing.
{

  PROCEDURE disteproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      str: string (60),
      xcbp: ^ost$execution_control_block;


    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;
    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY TASK ENVIRONMENT ', text);
    IFEND;

    xcbp := job_xcb_list.head;
    WHILE xcbp <> NIL DO
      display_xcb (xcbp, syv$dump_to_pf);
      IF syv$dump_to_pf THEN
        str := ' ';
        syp$write_output_line (str, status);
      IFEND;
      xcbp := xcbp^.link;
    WHILEND;
    status.normal := TRUE;

  PROCEND disteproc;
?? OLDTITLE ??
?? NEWTITLE := '  DISXCBPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the DISPLAY_EXECUTION_CONTROL_BLOCK command.  The parameter for the command is as
{ follows:
{        GTID: Optional, integer.
{          Specifies the global_task_id of the task whose execution control block is to be displayed.  Use of
{          this value will display the execution control block of the task with the corresponding GTID.  If
{          this parameter is not specified the debugger will display the execution control block of the task
{          which is currently in the debugger.
{


{ DISPLAY_EXECUTION_CONTROL_BLOCK parameter descriptor table:

  VAR
    disecb_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 1] of syt$parameter_descriptor := [
{   } [FALSE, 1, 'gtid    ', syc$integer_value, 0, 0, 0fffff(16)]];

  PROCEDURE disxcbproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      gtid: gtid_converter,
      gtid_found: boolean,
      msg: string (70),
      pvt: array [1 .. 1] of syt$parameter_value,
      str: string (60),
      xcb_p: ^ost$execution_control_block;

    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;
    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (disecb_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY EXECUTION CONTROL BLOCK ', text);
    IFEND;

    IF pvt [1].defined AND (pvt [1].int <> 0) THEN
      gtid.base := pvt [1].int;
      gtid_found := FALSE;
      xcb_p := job_xcb_list.head;
      WHILE (xcb_p <> NIL) AND (NOT gtid_found) DO
        IF xcb_p^.global_task_id = gtid.global_task_id THEN
          gtid_found := TRUE;
        ELSE
          xcb_p := xcb_p^.link;
        IFEND;
      WHILEND;
      IF NOT gtid_found THEN
        syp$write_output_line ('ERROR - Task with specified GTID was not found.', status);
        RETURN;
      IFEND;
      msg := ' Execution Control Block for alternate task: ';
      syp$write_output_line (msg, status);
      msg := ' ';
      msg (4, * ) := xcb_p^.save9;
      syp$write_output_line (msg, status);
      msg := ' ';
      syp$write_output_line (msg, status);
    ELSE
      pmp$find_executing_task_xcb (xcb_p);
    IFEND;

    display_xcb (xcb_p, TRUE);
    status.normal := TRUE;

  PROCEND disxcbproc;
?? OLDTITLE ??
?? NEWTITLE := '  DMPROC' ??
?? NEWTITLE := '    Character Translation Table     ', EJECT ??

{ The following translation table is used to remove the control codes from the displayed memory.  Any
{ character which cannot be displayed as legible ASCII will be translated into a space character for
{ display (' ').

  VAR
    dm_control_codes_to_space: [READ, oss$mainframe_paged_literal] string (256) := '            ' CAT
          '                     !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTU' CAT
          'VWXYZ[\]^_`abcdefghijkl' CAT 'mnopqrstuvwxyz{|}~?' CAT
          '                                                                ' CAT
          '                                                                ';

?? OLDTITLE, EJECT ??
{
{ Purpose:
{   This procedure processes the DISPLAY_MEMORY command.  The parameters for the command are as follows:
{        FBA: Required, pointer.
{          Specifies the starting virtual memory address (as a PVA or symbolic name) of the memory block to be
{          displayed (this is an 11-digit hexadecimal number addressing a specific byte of memory).
{        BC: Optional, integer.
{          Specifies the number of bytes of virtual memory to be displayed.  The system core debugger displays
{          a default value of 8 bytes.
{        FORCE: Optional, name.
{          Specifies whether or not to force the memory to be displayed if the address is beyond the current
{          segment length.  The following keywords can be specified (the default is N):
{            F
{            Forces the display even if the address, plus the length, extends beyond the current segment
{            length.  (This option is only valid for stack segments.)
{            N
{            Does not force the display if the address, plus the length, extends beyond the current segment
{            length.
{


{ DISPLAY_MEMORY parameter descriptor table:

  VAR
    dm_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 3] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'address ', syc$pointer_value, NIL],
{   } [FALSE, 2, 'length  ', syc$integer_value, 8, 1, 07fffffff(16)],
{   } [FALSE, 3, 'option  ', syc$name_value, 'N']];

  PROCEDURE dmproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    TYPE
      position_record = record
        display_offset: boolean,
        position: 0 .. 255,
        flush: boolean,
        char_position: 0 .. 255,
      recend,

      position_array = array [1 .. 132] of position_record;


    VAR
      assign_gap: boolean,
      assign_gap_start_offset: integer,
      bytes_examined: integer,
      byte_number: integer,
      display_line: string (256),
      display_line_length: 0 .. 255,

{ The following variable describes what should happen at a particular position of the display_line.  The
{ first field is a boolean determining if the current memory offset should be put in the output line.  The
{ second field is the position within the output string where the current byte should be displayed.  The third
{ field is a boolean determining if the current output string should be flushed.  The fourth field is the
{ position within the output string where the ASCII representation of the current byte should be displayed.

      display_position: [STATIC] position_array := [
 ?? FMT (FORMAT := OFF) ??
 { 1 } [FALSE, 0, FALSE, 0],    { 2 } [FALSE, 0, FALSE, 0],    { 3 } [FALSE, 0, FALSE, 0],
 { 4 } [FALSE, 0, FALSE, 0],    { 5 } [FALSE, 0, FALSE, 0],    { 6 } [FALSE, 0, FALSE, 0],
 { 7 } [FALSE, 0, FALSE, 0],    { 8 } [TRUE, 13, FALSE, 56],   { 9 } [TRUE, 14, FALSE, 101],
 { 10} [FALSE, 0, FALSE, 0],    { 11} [FALSE, 0, FALSE, 0],    { 12} [FALSE, 0, FALSE, 0],
 { 13} [FALSE, 15, FALSE, 57],  { 14} [FALSE, 16, FALSE, 102], { 15} [FALSE, 18, FALSE, 58],
 { 16} [FALSE, 19, FALSE, 103], { 17} [FALSE, 0, FALSE, 0],    { 18} [FALSE, 20, FALSE, 59],
 { 19} [FALSE, 21, FALSE, 104], { 20} [FALSE, 23, FALSE, 60],  { 21} [FALSE, 24, FALSE, 105],
 { 22} [FALSE, 0, FALSE, 0],    { 23} [FALSE, 25, FALSE, 61],  { 24} [FALSE, 26, FALSE, 106],
 { 25} [FALSE, 28, FALSE, 62],  { 26} [FALSE, 29, FALSE, 107], { 27} [FALSE, 0, FALSE, 0],
 { 28} [FALSE, 30, FALSE, 63],  { 29} [FALSE, 31, FALSE, 108], { 30} [FALSE, 35, FALSE, 64],
 { 31} [FALSE, 36, FALSE, 109], { 32} [FALSE, 0, FALSE, 0],    { 33} [FALSE, 0, FALSE, 0],
 { 34} [FALSE, 0, FALSE, 0],    { 35} [FALSE, 37, FALSE, 65],  { 36} [FALSE, 38, FALSE, 110],
 { 37} [FALSE, 40, FALSE, 66],  { 38} [FALSE, 41, FALSE, 111], { 39} [FALSE, 0, FALSE, 0],
 { 40} [FALSE, 42, FALSE, 67],  { 41} [FALSE, 43, FALSE, 112], { 42} [FALSE, 45, FALSE, 68],
 { 43} [FALSE, 46, FALSE, 113], { 44} [FALSE, 0, FALSE, 0],    { 45} [FALSE, 47, FALSE, 69],
 { 46} [FALSE, 48, FALSE, 114], { 47} [FALSE, 50, FALSE, 70],  { 48} [FALSE, 51, FALSE, 115],
 { 49} [FALSE, 0, FALSE, 0],    { 50} [FALSE, 52, TRUE, 71],   { 51} [FALSE, 53, FALSE, 116],
 { 52} [FALSE, 8, FALSE, 0],    { 53} [FALSE, 58, FALSE, 117], { 54} [FALSE, 0, FALSE, 0],
 { 55} [FALSE, 0, FALSE, 0],    { 56} [FALSE, 0, FALSE, 0],    { 57} [FALSE, 0, FALSE, 0],
 { 58} [FALSE, 60, FALSE, 118], { 59} [FALSE, 0, FALSE, 0],    { 60} [FALSE, 63, FALSE, 119],
 { 61} [FALSE, 0, FALSE, 0],    { 62} [FALSE, 0, FALSE, 0],    { 63} [FALSE, 65, FALSE, 120],
 { 64} [FALSE, 0, FALSE, 0],    { 65} [FALSE, 68, FALSE, 121], { 66} [FALSE, 0, FALSE, 0],
 { 67} [FALSE, 0, FALSE, 0],    { 68} [FALSE, 70, FALSE, 122], { 69} [FALSE, 0, FALSE, 0],
 { 70} [FALSE, 73, FALSE, 123], { 71} [FALSE, 0, FALSE, 0],    { 72} [FALSE, 0, FALSE, 0],
 { 73} [FALSE, 75, FALSE, 124], { 74} [FALSE, 0, FALSE, 0],    { 75} [FALSE, 80, FALSE, 125],
 { 76} [FALSE, 0, FALSE, 0],    { 77} [FALSE, 0, FALSE, 0],    { 78} [FALSE, 0, FALSE, 0],
 { 79} [FALSE, 0, FALSE, 0],    { 80} [FALSE, 82, FALSE, 126], { 81} [FALSE, 0, FALSE, 0],
 { 82} [FALSE, 85, FALSE, 127], { 83} [FALSE, 0, FALSE, 0],    { 84} [FALSE, 0, FALSE, 0],
 { 85} [FALSE, 87, FALSE, 128], { 86} [FALSE, 0, FALSE, 0],    { 87} [FALSE, 90, FALSE, 129],
 { 88} [FALSE, 0, FALSE, 0],    { 89} [FALSE, 0, FALSE, 0],    { 90} [FALSE, 92, FALSE, 130],
 { 91} [FALSE, 0, FALSE, 0],    { 92} [FALSE, 95, FALSE, 131], { 93} [FALSE, 0, FALSE, 0],
 { 94} [FALSE, 0, FALSE, 0],    { 95} [FALSE, 97, TRUE, 132],  { 96} [FALSE, 0, FALSE, 0],
 { 97} [FALSE, 9, FALSE, 0],    { 98} [FALSE, 0, FALSE, 0],    { 99} [FALSE, 0, FALSE, 0],
 {100} [FALSE, 0, FALSE, 0],    {101} [FALSE, 0, FALSE, 0],    {102} [FALSE, 0, FALSE, 0],
 {103} [FALSE, 0, FALSE, 0],    {104} [FALSE, 0, FALSE, 0],    {105} [FALSE, 0, FALSE, 0],
 {106} [FALSE, 0, FALSE, 0],    {107} [FALSE, 0, FALSE, 0],    {108} [FALSE, 0, FALSE, 0],
 {109} [FALSE, 0, FALSE, 0],    {110} [FALSE, 0, FALSE, 0],    {111} [FALSE, 0, FALSE, 0],
 {112} [FALSE, 0, FALSE, 0],    {113} [FALSE, 0, FALSE, 0],    {114} [FALSE, 0, FALSE, 0],
 {115} [FALSE, 0, FALSE, 0],    {116} [FALSE, 0, FALSE, 0],    {117} [FALSE, 0, FALSE, 0],
 {118} [FALSE, 0, FALSE, 0],    {119} [FALSE, 0, FALSE, 0],    {120} [FALSE, 0, FALSE, 0],
 {121} [FALSE, 0, FALSE, 0],    {122} [FALSE, 0, FALSE, 0],    {123} [FALSE, 0, FALSE, 0],
 {124} [FALSE, 0, FALSE, 0],    {125} [FALSE, 0, FALSE, 0],    {126} [FALSE, 0, FALSE, 0],
 {127} [FALSE, 0, FALSE, 0],    {128} [FALSE, 0, FALSE, 0],    {129} [FALSE, 0, FALSE, 0],
 {130} [FALSE, 0, FALSE, 0],    {131} [FALSE, 0, FALSE, 0],    {132} [FALSE, 0, FALSE, 0]],
 ?? FMT (FORMAT := ON) ??
      duplicate_line_count: integer,
      initial_line: boolean,
      i: 0 .. 255,
      j: 0 .. 255,
      length: integer,
      memory_access_in_bytes_p: ^array [0 .. 7fffffff(16)] of record
          CASE 0 .. 1 OF
          = 0 =
            byte: 0 .. 0ff(16),
          = 1 =
            character: string (1),
          CASEND,
        recend,
      previous_display_line: string (256),
      pvt: array [1 .. 3] of syt$parameter_value,
      rma: integer,
      sdtxe_p: ^mmt$segment_descriptor_extended,
      segnum: ost$segment,
      segnum_hex: string (19),
      segment_length: integer,
      str: string (60),
      wired_or_fixed_flag: boolean,
      xcb_p: ^ost$execution_control_block;


    syp$crack_command (dm_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT repress_headers_flag THEN

{ By placing these lines within the IF statement above, the DISFDC/DISFDT commands can display paged output to
{ the console, or correctly-labeled output to a permanent dump file.

      syv$db_displayed_console_lines := 0;
      syv$debug_line_count := 0;
      IF syv$dump_to_pf THEN
        syp$write_output_header (' DISPLAY MEMORY ', text);
      IFEND;
    IFEND;

    memory_access_in_bytes_p := #LOC (pvt [1].ptr^);
    last_dm_pva := #LOC (pvt [1].ptr^);
    last_dm_count := pvt [2].int;
    byte_number := #OFFSET (memory_access_in_bytes_p);
    segnum := #SEGMENT (memory_access_in_bytes_p);

    syp$verify_access (syc$readable, #LOC (memory_access_in_bytes_p), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    get_segment_length (memory_access_in_bytes_p, segment_length);
    segnum_hex := 'LENGTH         (16)';
    hex_string (segment_length, segnum_hex, 15);
    syp$write_output_line (segnum_hex, status);

    pmp$find_executing_task_xcb (xcb_p);
    sdtxe_p := mmp$get_sdtx_entry_p (xcb_p, segnum);
    wired_or_fixed_flag := (mmc$sa_wired IN sdtxe_p^.software_attribute_set) OR
          (mmc$sa_fixed IN sdtxe_p^.software_attribute_set);

    IF pvt [3].name <> 'F' THEN
      IF segment_length = 0 THEN
        dpp$put_next_line (id, ' Segment length = 0 - use F option', status);
      IFEND;
      IF (byte_number + pvt [2].int) > segment_length THEN
        IF byte_number >= segment_length THEN
          osp$set_status_abnormal ('DB', dbe$, 'address greater than file limit', status);
          RETURN;
        ELSE

{ Dump up to the segment length.

          pvt [2].int := segment_length - byte_number;
        IFEND;
      IFEND;
    ELSE
      IF NOT (mmc$sa_stack IN sdtxe_p^.software_attribute_set) THEN
        osp$set_status_abnormal ('DB', dbe$, ' F only allowed for stack segments', status);
        RETURN;
      ELSE
        syp$write_output_line (' dump forced ', status);
      IFEND;
    IFEND;

    segnum_hex := 'SEGMENT = 000(16)';
    hex_string (segnum, segnum_hex, 13);
    syp$write_output_line (segnum_hex, status);

    bytes_examined := 0;
    IF syv$dump_to_pf THEN

{ Column numbers and layout for permanent file and printed output:
{00000000   aaaa bbbb cccc dddd   aaaa bbbb cccc dddd   aaaa bbbb cccc dddd   aaaa bbbb cccc dddd   x........x
{2345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901........2
{        1         2         3         4         5         6         7         8         9         0        13

      display_line := ' 00000000   0000 0000 0000 0000   0000 0000 0000 0000   ';
      display_line (57, *) := '0000 0000 0000 0000   0000 0000 0000 0000';
      display_line_length := 132;
      j := 9;
    ELSE

{ Column numbers for display_memory to console:
{  '00000000   aaaa bbbb cccc dddd   aaaa bbbb cccc dddd   xxxxxxxxxxxxxxxx';
{   12345678901234567890123456789012345678901234567890123456789012345678901
{            1         2         3         4         5         6         7

      display_line := '00000000   0000 0000 0000 0000   0000 0000 0000 0000';
      display_line_length := 80;
      j := 8;
    IFEND;
    previous_display_line := display_line;

    assign_gap := FALSE;
    duplicate_line_count := 0;
    initial_line := TRUE;

  /dump_each_byte/
    WHILE bytes_examined < pvt [2].int DO
      IF wired_or_fixed_flag THEN
        #REAL_MEMORY_ADDRESS (#LOC (memory_access_in_bytes_p^ [bytes_examined].byte), rma);
        IF rma < 0 THEN
          IF NOT assign_gap THEN
            assign_gap := TRUE;
            assign_gap_start_offset := #OFFSET (#LOC (memory_access_in_bytes_p^ [bytes_examined].byte));

            IF duplicate_line_count <> 0 THEN
              STRINGREP (previous_display_line, length, ' ', duplicate_line_count, ' duplicate line(s)');
              syp$write_output_line (previous_display_line (1, length), status);
              duplicate_line_count := 0
            IFEND;

            IF NOT display_position [j].display_offset THEN

{ Part of a display_line has information which must be flushed.  Pad the unnecessary memory string with blanks
{ before displaying the line.

              j := j + 1;
              IF display_line_length = 80 THEN
                i := 53;
              ELSE
                i := 98;
              IFEND;
              WHILE j < i DO
                display_line (j) := ' ';
                j := j + 1;
              WHILEND;
              syp$write_output_line (display_line (1, display_line_length), status);
            IFEND;
          IFEND;
          bytes_examined := bytes_examined + 1;
          CYCLE /dump_each_byte/;
        ELSE {rma >= 0}
          IF assign_gap THEN
            assign_gap := FALSE;
            STRINGREP (display_line, length, '-- WARNING -- Memory from offset',
                  assign_gap_start_offset: #(16), '(16) to',
                  #OFFSET (#LOC (memory_access_in_bytes_p^ [bytes_examined].byte)): #(16),
                  '(16) is not assigned.');
            syp$write_output_line (display_line (1, length), status);
            IF display_line_length = 132 THEN
              display_line := ' 00000000   0000 0000 0000 0000   0000 0000 0000 0000   ';
              display_line (57, *) := '0000 0000 0000 0000   0000 0000 0000 0000';
              j := 9;
            ELSE
              display_line := '00000000   0000 0000 0000 0000   0000 0000 0000 0000';
              j := 8;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      IF display_position [j].display_offset THEN
        hex_string (#OFFSET (#LOC (memory_access_in_bytes_p^ [bytes_examined].byte)), display_line, j);
      IFEND;

{ Convert the current byte to a hex representation and put it in the correct portion of the output string.

      hex_string (memory_access_in_bytes_p^ [bytes_examined].byte, display_line, display_position [j].
            position);
      #TRANSLATE (dm_control_codes_to_space, memory_access_in_bytes_p^ [bytes_examined].character,
            display_line (display_position [j].char_position));
      IF display_position [j].flush THEN
        IF (display_line (10, (display_line_length - 9)) =
              previous_display_line (10, (display_line_length - 9))) AND (NOT initial_line) THEN
          duplicate_line_count := duplicate_line_count + 1;
        ELSE
          IF duplicate_line_count <> 0 THEN
            STRINGREP (previous_display_line, length, ' ', duplicate_line_count, ' duplicate line(s)');
            syp$write_output_line (previous_display_line (1, length), status);
            duplicate_line_count := 0
          IFEND;
          syp$write_output_line (display_line (1, display_line_length), status);
          initial_line := FALSE;
          previous_display_line := display_line;
        IFEND;
        j := display_position [j].position;
        IF syv$dump_to_pf THEN
          display_line := ' 00000000   0000 0000 0000 0000   0000 0000 0000 0000   ';
          display_line (57, *) := '0000 0000 0000 0000   0000 0000 0000 0000';
        ELSE
          display_line := '00000000   0000 0000 0000 0000   0000 0000 0000 0000';
        IFEND;
      IFEND;
      j := display_position [j].position;
      bytes_examined := bytes_examined + 1;
    WHILEND /dump_each_byte/;

    IF wired_or_fixed_flag THEN
      IF assign_gap THEN
        STRINGREP (display_line, length, '-- WARNING -- Memory from offset',
              assign_gap_start_offset: #(16), '(16) to',
              #OFFSET (#LOC (memory_access_in_bytes_p^ [bytes_examined-1].byte)): #(16),
              '(16) is not assigned.');
        syp$write_output_line (display_line (1, length), status);
        RETURN; {no need to check for unflushed lines} {<----------------}
      IFEND;
    IFEND;

    IF duplicate_line_count <> 0 THEN
      STRINGREP (previous_display_line, length, ' ', duplicate_line_count, ' duplicate line(s)');
      syp$write_output_line (previous_display_line (1, length), status);
    IFEND;

    IF NOT display_position [j].display_offset THEN

{ Part of a display_line has information which must be flushed.  Pad the unnecessary memory string with blanks
{ before displaying the line.

      j := j + 1;
      IF display_line_length = 80 THEN
        i := 53;
      ELSE
        i := 98;
      IFEND;
      WHILE j < i DO
        display_line (j) := ' ';
        j := j + 1;
      WHILEND;
      syp$write_output_line (display_line (1, display_line_length), status);
    IFEND;

  PROCEND dmproc;
?? OLDTITLE ??
?? NEWTITLE := '  DOWN_VOLUME', EJECT ??

{
{ Purpose:
{   This procedure processes the DOWN_VOLUME command.  This will prevent use of the specified volume number.
{ The parameter for the command is as follows:
{        NUMBER: Required, integer.
{          Specifies the active volume table index of the volume which is to be DOWNed.
{


{ DOWN_VOLUME, UP_VOLUME parameter descriptor table:

  VAR
    down_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 1] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'number  ', syc$integer_value, 1, 1, 7fffffff(16)]];

  PROCEDURE down_volume
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      avti: dmt$active_volume_table_index,
      pvt: array [1 .. 1] of syt$parameter_value;


    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;
    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (down_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avti := pvt [1].int;

    IF dmv$p_active_volume_table^ [avti].mass_storage.volume_unavailable = TRUE THEN

{ Ignore request - the volume is already down.

      RETURN;
    IFEND;

    dmv$number_unavailable_volumes := dmv$number_unavailable_volumes + 1;
    dmv$p_active_volume_table^ [avti].mass_storage.volume_unavailable := TRUE;
    dmv$p_active_volume_table^ [avti].mass_storage.previous_allocation_allowed :=
          dmv$p_active_volume_table^ [avti].mass_storage.allocation_allowed;
    dmv$p_active_volume_table^ [avti].mass_storage.allocation_allowed := FALSE;

  PROCEND down_volume;
?? OLDTITLE ??
?? NEWTITLE := '  FIND_DBL_ENTRY', EJECT ??

{
{ Purpose:
{   This procedure assists the various breakpoint commands by finding the specified breakpoint name in the
{ debug breakpoint name list and returning an index into the list.
{        NAME: The name of the debug breakpoint which is to be located.
{        DBL_ENTRY: The value of the index into the debug breakpoint list whose entry contains the name which
{          must be located.
{        FOUND: A boolean value which describes whether or not the name was found in the debug list.
{

  PROCEDURE find_dbl_entry
    (    name: ost$name;
     VAR dbl_index: integer;
     VAR found: boolean);

    VAR
      i: integer;

    i := 1;
    WHILE i <= 32 DO
      IF syv$debug_list.sfwr_entry [i].name = name THEN
        dbl_index := i;
        found := TRUE;
        RETURN;
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;
    found := FALSE;
    RETURN;
  PROCEND find_dbl_entry;
?? OLDTITLE ??
?? NEWTITLE := '  FIND_STACK_FRAME', EJECT ??

{
{ Purpose:
{   This procedure assists the DISPLAY_TRACE_BACK and DISPLAY_STACK commands by returning pointers to the
{ current_stack_frame and save_areas for the specified frame number.  The parameters for the command are as
{ follows:
{        FRAME_NUMBER: An integer specifying the frame number which is to be located.
{        CSF_P: A pointer to the found current stack frame for the specified frame.
{        SA_P: A pointer to the found save area for the specified frame.
{

  PROCEDURE find_stack_frame
    (    frame_number: integer;
     VAR csf_p: ^cell;
     VAR sa_p: ^cell);

    VAR
      n: integer,
      p: ^stack_frame_control_image,
      status: ost$status;

    n := frame_number;
    find_trapped_stack_frame (p);
    WHILE (p <> NIL) AND (n > 1) DO
      n := n - 1;
      syp$verify_access (syc$writeable, #LOC (p^.psa), status);
      IF NOT status.normal THEN
        p := NIL;
      ELSE
        p := p^.psa;
      IFEND;
    WHILEND;
    IF p <> NIL THEN
      syp$verify_access (syc$writeable, #LOC (p^.csf), status);
      IF NOT status.normal THEN
        csf_p := NIL;
      ELSE
        csf_p := p^.csf;
      IFEND;
      sa_p := p;
    ELSE
      csf_p := NIL;
      sa_p := NIL;
    IFEND;
  PROCEND find_stack_frame;
?? OLDTITLE ??
?? NEWTITLE := '  FIND_TRAPPED_STACK_FRAME', EJECT ??

{
{ Purpose:
{   This procedure returns a pointer to the trapped stack frame.  The parameters for the command are as
{ follows:
{        TRAPPED_SF: A pointer which is returned and which points the the trapped stack frame.
{

  PROCEDURE find_trapped_stack_frame
    (VAR trapped_sf: ^cell);

    trapped_sf := syv$debug_control.trapped_sfsa;

  PROCEND find_trapped_stack_frame;
?? OLDTITLE ??
?? NEWTITLE := '  GENERATE_DEBUG_TRAP_MESSAGE', EJECT ??

{
{ Purpose:
{   This procedure generates a message describing why a trap to the debugger was encountered.  It uses a
{ trapped stack frame and returns values describing
{        . whether or not the message should be displayed and the debugger invoked, and
{        . the message which would be displayed if the previous clause is TRUE.
{ The parameters for the command are as follows:
{        TRAPPED_SFSA_P: A pointer to the trapped stack frame which containes the information about the trap.
{        CONTACT_USER: A boolean returned to describe whether or not the debugger should be invoked.
{        MSG: A string returned describing the reason for the trap.
{        STATUS: VAR of ost$status
{

  PROCEDURE generate_debug_trap_message
    (    trapped_sfsa_p: ^stack_frame_control_image;
     VAR contact_user: boolean;
     VAR msg: string (60);
     VAR status: ost$status);

    VAR
      bflag: boolean,
      cond_id: string (8),
      cond_regs: condition_reg_image,
      dbl_p: ^debug_list,
      i: integer,
      preg: ost$pva,
      ucr_ord: ost$user_condition;

    status.normal := TRUE;
    dbl_p := ^syv$debug_list;
    contact_user := TRUE;
    msg := 'xxxxxxxx FAULT ( mcr/ucr) AT P=0 000 00000000';

{ Extract p-address from trapped stack frame and set into the two messages which may (potentially) be issued.

    preg := trapped_sfsa_p^.p_reg.pva;
    hex_string (preg.ring, msg, 32);
    hex_string (preg.seg, msg, 36);
    hex_string (preg.offset, msg, 45);

{ Extract the image of the user-condition and monitor-condition registers from trapped stack frame and save it
{ in cond_regs.

    cond_regs.ucr_a := trapped_sfsa_p^.user_condition;
    cond_regs.mcr_a := trapped_sfsa_p^.monitor_condition;

{ Test for monitor condition fault.

    IF cond_regs.mcr_i <> 0 THEN
      IF cond_regs.mcr_a [osc$instruction_spec] = TRUE THEN
        cond_id := 'instruct';
      ELSEIF cond_regs.mcr_a [osc$address_specification] = TRUE THEN
        cond_id := 'address ';
      ELSEIF cond_regs.mcr_a [osc$access_violation] = TRUE THEN
        cond_id := 'access  ';
      ELSEIF cond_regs.mcr_a [osc$environment_spec] = TRUE THEN
        cond_id := 'environ ';
      ELSEIF cond_regs.mcr_a [osc$invalid_segment_ring_0] = TRUE THEN
        cond_id := 'inv seg ';
      ELSEIF cond_regs.mcr_a [osc$out_call_in_return] = TRUE THEN
        cond_id := 'ocl/irtn';
      IFEND;
      msg (1, 8) := cond_id (1, 8);
      RETURN;
    IFEND;

{ Test for unmaskable user condition fault (except free flag and PIT).

    cond_id := '        ';
    IF cond_regs.ucr_a [osc$privileged_instruction] = TRUE THEN
      cond_id := 'priv ins';
    ELSEIF cond_regs.ucr_a [osc$unimplemented_instruction] = TRUE THEN
      cond_id := 'unim ins';
    ELSEIF cond_regs.ucr_a [osc$inter_ring_pop] = TRUE THEN
      cond_id := 'ir pop  ';
    ELSEIF cond_regs.ucr_a [osc$critical_frame_flag] = TRUE THEN
      cond_id := 'cf flag ';
    ELSEIF cond_regs.ucr_a [osc$keypoint] = TRUE THEN
      cond_id := 'keypoint';
    IFEND;
    IF cond_id <> '        ' THEN
      msg (1, 8) := cond_id (1, 8);
      RETURN;
    IFEND;

{ Test for maskable user condition fault.

    bflag := FALSE;
    ucr_ord := osc$divide_fault;

    WHILE (bflag = FALSE) AND (ucr_ord <= osc$invalid_bdp_data) DO
      IF cond_regs.ucr_a [ucr_ord] = TRUE THEN
        bflag := TRUE;
      ELSE
        ucr_ord := SUCC (ucr_ord);
      IFEND;
    WHILEND;

{ A maskable user condition fault is set.  Test for the hardware debug condition.

    IF ucr_ord = osc$debug THEN
      msg (1, 8) := 'debug   ';
      i := #READ_REGISTER (osc$pr_debug_index);
      i := (i DIV 2) + 1;
      msg (17, 8) := dbl_p^.sfwr_entry [i].name (1, 8);
      RETURN;
    IFEND;

{ The set maskable user condition is not the hardware debug condition.  If the maskable condition has been
{ selected via a breakpoint, issue a notification message. Otherwise, return immediately to the trap handler.

    i := 1;

    WHILE i <= 32 DO
      IF (dbl_p^.sfwr_entry [i].segment = preg.seg) AND (preg.offset >= dbl_p^.sfwr_entry [i].lobyte) AND
            (preg.offset <= dbl_p^.sfwr_entry [i].hibyte) AND
            (dbl_p^.sfwr_entry [i].condition [cond_conv_tbl2 [ucr_ord].c_ord] = TRUE) THEN
        msg (1, 8) := cond_conv_tbl2 [ucr_ord].name (1, 8);
        msg (17, 8) := dbl_p^.sfwr_entry [i].name (1, 8);
        RETURN;
      ELSE
        i := i + 1;
      IFEND;
    WHILEND;
    contact_user := FALSE;
    RETURN;
  PROCEND generate_debug_trap_message;
?? OLDTITLE ??
?? NEWTITLE := '  GET_SEGMENT_LENGTH', EJECT ??

{
{ Purpose:
{   This procedure returns the segment length of the specified segment.
{        P: A pointer to the segment whose length must be returned.
{        LEN: An integer value returned which describes the segment length.
{

  PROCEDURE get_segment_length
    (    p: ^cell;
     VAR len: integer);

    VAR
      segl: ost$segment_length,
      status: ost$status;

    status.normal := TRUE;

    IF mmv$tables_initialized THEN
      mmp$get_segment_length_r1 (#segment (p), 1, segl, status);
      IF status.normal THEN
        len := segl;
      ELSE
        len := 0;
      IFEND;
    ELSE

{ Memory manager tables are not initialized, therefore assume length equal to maximum offset.
{ This assumes the debug user does not make a mistake.

      len := 7fffffff(16);
    IFEND;


  PROCEND get_segment_length;
?? OLDTITLE ??
?? NEWTITLE := '  HANGPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the HANG_TASK command.  It causes the task to hang in an infinite delay loop when
{ the system core debugger is exited.  The task is left in a state where it can be reentered at a later time.
{ There are no parameters for the command.
{

  PROCEDURE hangproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      hang_task: ^boolean,
      str: string (60);

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    IF syv$dump_to_pf THEN
      syp$write_output_header (' HANG TASK ', text);
    IFEND;

    IF (syv$job_template_ptr_array = NIL) OR (UPPERBOUND (syv$job_template_ptr_array^) < 3) THEN
      osp$set_status_abnormal ('DB', dbe$, ' not available', status);
      RETURN;
    IFEND;
    hang_task := syv$job_template_ptr_array^ [3];
    IF hang_task^ THEN
      syp$write_output_line ('hang task cleared', status);
      hang_task^ := FALSE;
    ELSE
      syp$write_output_line ('hang task set', status);
      hang_task^ := TRUE;
    IFEND;
    status.normal := TRUE;

  PROCEND hangproc;
?? OLDTITLE ??
?? NEWTITLE := '  HELPPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the HELP command.  It accesses the system core debugger HELP file at any time
{ after starting the system core debugger.  It can describe a single command or all commands, and the aliases
{ and parameters of the command(s).  The parameter for the command is as follows:
{        NAME: Optional, name.
{          Specifies the name of the command about which information must be returned.  The default value is
{          all commands (information about all commands will be displayed).
{


{ HELP parameter descriptor table:

  VAR
    help_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 1] of syt$parameter_descriptor := [
{   } [FALSE, 1, 'name   ', syc$name_value, * ]];

  PROCEDURE helpproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      i: integer,
      j: integer,
      k: integer,
      len: integer,
      msg: string (80),
      pvt: array [1 .. 1] of syt$parameter_value,
      str: string (60);

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (help_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' HELP FUNCTION ', text);
    IFEND;

    msg := '  Summary of Debug Command(s)';
    syp$write_output_line (msg, status);
    msg := '  ';
    syp$write_output_line (msg, status);
    msg := '  ALIAS       NOMINAL NAME';
    syp$write_output_line (msg, status);
    msg := '  parameter   parameter   parameter   parameter   parameter   parameter ...';
    syp$write_output_line (msg, status);
    msg := '  =========================================================================';
    syp$write_output_line (msg, status);

    IF (NOT pvt [1].defined) THEN

    /display_command/
      FOR i := LOWERBOUND (command_table) TO UPPERBOUND (command_table) DO
        IF command_table [i].short_name = 'dummy   ' THEN
          CYCLE /display_command/;
        IFEND;
        msg := '   ';
        msg (3, * ) := command_table [i].short_name;
        msg (15, * ) := command_table [i].long_name;
        syp$write_output_line (msg, status);
        IF param_table [i] <> NIL THEN
          msg := '   ';
          k := 3;
          FOR j := LOWERBOUND (param_table [i]^) TO UPPERBOUND (param_table [i]^) DO
            IF (k + #SIZE (param_table [i]^ [j].keyword)) < #SIZE (msg) THEN
              msg (k, * ) := param_table [i]^ [j].keyword;
              k := k + 12;
            IFEND;
          FOREND;
          syp$write_output_line (msg, status);
        IFEND;
      FOREND /display_command/;
    ELSE
      FOR i := LOWERBOUND (command_table) TO UPPERBOUND (command_table) DO
        IF ((pvt [1].name = command_table [i].short_name) OR (pvt [1].name = command_table [i].long_name))
              THEN
          msg := '   ';
          msg (3, * ) := command_table [i].short_name;
          msg (15, * ) := command_table [i].long_name;
          syp$write_output_line (msg, status);
          IF param_table [i] <> NIL THEN
            msg := '   ';
            k := 3;
            FOR j := LOWERBOUND (param_table [i]^) TO UPPERBOUND (param_table [i]^) DO
              IF (k + #SIZE (param_table [i]^ [j].keyword)) < #SIZE (msg) THEN
                msg (k, * ) := param_table [i]^ [j].keyword;
                k := k + 12;
              IFEND;
            FOREND;
            syp$write_output_line (msg, status);
          IFEND;
          RETURN;
        IFEND;
        IF i = UPPERBOUND (command_table) THEN
          msg := '  ';
          msg (3, * ) := ' unknown command name';
          syp$write_output_line (msg, status);
        IFEND;
      FOREND;
    IFEND;

  PROCEND helpproc;
?? OLDTITLE ??
?? NEWTITLE := '  HEX_STRING', EJECT ??

{
{ Purpose:
{   This procedure converts an integer into a hexidecimal string value and places it in a specified position
{ within a string.  The parameters for the command are as follows:
{        XI: The integer value which will be converted into a hexidecimal string value.
{        S: The string value which will be returned and represents the hexidecimal value of the inputted
{          integer.
{        XPOS: The position within the returned string at which the hexidecimal string value of the inputted
{          integer will be placed.
{

  PROCEDURE hex_string
    (    xi: integer;
     VAR s: string ( * );
         xpos: 0 .. 255);

    VAR
      ch: char,
      i: integer,
      k: integer,
      pos: 0 .. 255;

    i := xi;
    pos := xpos;
    WHILE (i <> 0) AND (pos > 0) DO
      k := i MOD 16;
      IF k <= 9 THEN
        ch := $CHAR (k + $INTEGER ('0'));
      ELSE
        ch := $CHAR (k - 10 + $INTEGER ('A'));
      IFEND;
      s (pos) := ch;
      i := i DIV 16;
      pos := pos - 1;
    WHILEND;
  PROCEND hex_string;
?? OLDTITLE ??
?? NEWTITLE := '  KILL_TASK_PROC', EJECT ??

{
{ Purpose:
{   This procedure processes the KILL_TASK command.  It allows an operator or site analyst to abort a specifed
{ task.  The parameters for the command are as follows:
{        FRAME: Optional, integer.
{          Specifies a stack frame which will be "damaged" in order to cause the task to abort.  The default
{          value allows the debugger to determine a "safe" stack frame which can be damaged.
{        RING: Optional, integer.
{          Specifies a ring number in which the first stack frame is to be "damaged".  If the frame is
{          specified, this parameter is ignored.  A task cannot be aborted at ring 1.
{        NO_CH: Optional, boolean.
{          Specifies a whether the stack chain should be "broken" to prevent the invocation of condition
{          handlers during the task termination.
{

  TYPE
    trick_ptr_variant = record
      case 0 .. 2 of
      = 0 =
        cell_p: ^cell,
      = 1 =
        intermediate_p: ^ost$stack_frame_save_area,
      = 2 =
        sfsa_p: ^ost$minimum_save_area,
      casend,
    recend,

    binding_section_record = record
      fill: 0 .. 0ffff(16),
      pva: ost$pva,
    recend,

    trick_procedure_ptr_variant = record
      case 0 .. 1 of
      = 0 =
        procedure_p: ^procedure,
      = 1 =
        binding_section_p: ^binding_section_record,
        static_link: ost$pva,
      casend,
    recend;


{ KILL_TASK parameter descriptor table:

  VAR
    kilt_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 3] of syt$parameter_descriptor := [
{   } [FALSE, 1, 'frame  ', syc$integer_value, 0, 0, 0ffffffff(16)],
{   } [FALSE, 2, 'ring   ', syc$integer_value, 0, 0, 0f(16)],
{   } [FALSE, 3, 'no_ch  ', syc$boolean_value, FALSE]];

  PROCEDURE kill_task_proc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

?? NEWTITLE := '    KILL_TASK_CH {condition handler} ', EJECT ??

    PROCEDURE kill_task_ch
      (    mf: ost$monitor_fault;
           ctc: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      VAR
        ignore_status: ost$status,
        s: string (40);

      IF NOT mmv$tables_initialized THEN
        osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
        RETURN;
      IFEND;

      s := ' Kill_task command failure- try again';
      IF NOT syv$dump_to_pf THEN
        dpp$put_next_line (display_id, s, ignore_status);
      ELSE
        osp$output_debug_text (^s, ignore_status);
      IFEND;
      status.normal := FALSE;
      EXIT kill_task_proc;
    PROCEND kill_task_ch;
?? OLDTITLE, EJECT ??

    VAR
      index: integer,
      procedure_ptr_converter: trick_procedure_ptr_variant,
      pvt: array [1 .. 3] of syt$parameter_value,
      saved_ring_number: 0 .. 0f(16),
      sfsa_converter: trick_ptr_variant;

    syp$establish_condition_handler (^kill_task_ch);
    syp$crack_command (kilt_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    sfsa_converter.cell_p := syv$debug_control.trapped_sfsa;
    procedure_ptr_converter.procedure_p := ^i#program_error;

{ Search for the correct SFSA to damage.

    IF pvt [1].defined THEN

{ Use the frame number specified in the call to this command processor.

      index := 1;
      WHILE (index <> pvt [1].int) AND (sfsa_converter.sfsa_p^.a2_previous_save_area <> NIL) DO
        index := index + 1;
        sfsa_converter.intermediate_p := sfsa_converter.sfsa_p^.a2_previous_save_area;
      WHILEND;
      IF index <> pvt [1].int THEN

{ The specified frame number was too large.  Return an error status.

        dpp$put_next_line (display_id, 'Stack not large enough for specified frame number', status);
        osp$set_status_abnormal ('DB', dbe$, 'Stack not large enough for specified frame number', status);
        RETURN;
      IFEND;
    ELSEIF pvt [2].defined THEN

{ Use the ring number specified in the call to this command processor.

      WHILE (sfsa_converter.sfsa_p^.a2_previous_save_area <> NIL) AND
            (sfsa_converter.sfsa_p^.p_register.pva.ring <> pvt [2].int) DO
        sfsa_converter.intermediate_p := sfsa_converter.sfsa_p^.a2_previous_save_area;
      WHILEND;
      IF sfsa_converter.sfsa_p^.p_register.pva.ring <> pvt [2].int THEN

{ The specified ring number did not have a stack associated with it.  Return an error status.

        dpp$put_next_line (display_id, 'Stack does not exist for specified ring number', status);
        osp$set_status_abnormal ('DB', dbe$, 'Stack does not exist for specified ring number', status);
        RETURN;
      IFEND;
    ELSE

{ Search for the first "safe" frame, i.e. any frame above ring three (3).

      WHILE (sfsa_converter.sfsa_p^.a2_previous_save_area <> NIL) AND
            (sfsa_converter.sfsa_p^.p_register.pva.ring < 3) DO
        sfsa_converter.intermediate_p := sfsa_converter.sfsa_p^.a2_previous_save_area;
      WHILEND;
      IF sfsa_converter.sfsa_p^.p_register.pva.ring < 3 THEN

{ There is no stack frame at or above Ring THREE (3) which can be damaged.  Return an error status.

        dpp$put_next_line (display_id, 'No stack frame >= ring 3 was found; unable to kill task', status);
        osp$set_status_abnormal ('DB', dbe$, 'No stack frame >= ring 3 was found; unable to kill task',
              status);
        RETURN;
      IFEND;
    IFEND;

    IF sfsa_converter.sfsa_p^.p_register.pva.ring = 1 THEN

{ We are not allowed to kill a task running at Ring ONE (1).  Return an error status.

      dpp$put_next_line (display_id, 'Stack frame = ring 1 found/specified; unable to kill task', status);
      osp$set_status_abnormal ('DB', dbe$, 'Stack frame = ring 1 found/specified; unable to kill task',
            status);
      RETURN;
    IFEND;

{ If execution reaches this point, a stack frame has been found which can be damaged.  Do so, but remember to
{ retain the correct ring number of the P_Register.

    saved_ring_number := sfsa_converter.sfsa_p^.p_register.pva.ring;
    sfsa_converter.sfsa_p^.p_register.pva := procedure_ptr_converter.binding_section_p^.pva;
    sfsa_converter.sfsa_p^.p_register.pva.ring := saved_ring_number;

{ If desired, cut off all condition handlers from the task which will die.

    IF pvt [3].defined AND pvt [3].bool THEN
      sfsa_converter.sfsa_p^.a2_previous_save_area := NIL;
    IFEND;

  PROCEND kill_task_proc;
?? OLDTITLE ??
?? NEWTITLE := '  LIST_BREAKPOINTS', EJECT ??

{
{ Purpose:
{   This procedure processes the LIST_BREAKPOINTS command.  It lists the currently active breakpoints by name
{ with their associated conditions, the segment number, and the first and last byte in which the breakpoint is
{ active.  The parameter for the command is as follows:
{        PARAMETER: Optional, name.
{          Specifies a breakpoint name.  The conditions for this breakpoint are displayed.  The default system
{          core debugger display is all active breakpoint names and their conditions.
{


{ LIST_BREAKPOINTS parameter descriptor table:

  VAR
    display_brkpt_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 1] of syt$parameter_descriptor := [
{   } [FALSE, 1, 'name    ', syc$name_value, * ]];

  PROCEDURE list_breakpoints
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      dbl_index: integer,
      dbl_p: ^debug_list,
      i: integer,
      line: string (18),
      name_found: boolean,
      no_brkpts_set: boolean,
      pvt: array [1 .. 1] of syt$parameter_value,
      str: string (60);

{ Crack the command.  Return if errors occur.

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    no_brkpts_set := TRUE;
    syp$crack_command (display_brkpt_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' LIST BREAKPOINTS ', text);
    IFEND;

    dbl_p := ^syv$debug_list;
    CASE pvt [1].defined OF

    = TRUE =

      find_dbl_entry (pvt [1].name, dbl_index, name_found);
      IF name_found = FALSE THEN
        osp$set_status_abnormal ('DB', dbe$, 'invalid_breakpoint_name', status);
      ELSE
        print_brkpt (dbl_p, dbl_index, status);
      IFEND;
      RETURN;

    = FALSE =

      line (1, 18) := 'NO BREAKPOINTS SET';
      FOR i := 1 TO 32 DO
        IF dbl_p^.sfwr_entry [i].name <> '        ' THEN
          no_brkpts_set := FALSE;
          print_brkpt (dbl_p, i, status);
          IF NOT status.normal THEN
            RETURN
          IFEND;
        IFEND;
      FOREND;
      IF no_brkpts_set = TRUE THEN
        syp$write_output_line (line, status);
      IFEND;
      RETURN;
    CASEND;
  PROCEND list_breakpoints;
?? OLDTITLE ??
?? NEWTITLE := 'log_system_core_text', EJECT ??

{ PURPOSE:
{   This procedure is called during debug command processing to log text to the system log.

  PROCEDURE log_system_core_text
    (    text: string (*));

    VAR
      ignore_status: ost$status,
      log_time: ost$time,
      trim_size: integer;

    IF NOT syv$inhibit_core_cmd_logging THEN
      FOR trim_size := STRLENGTH (text) DOWNTO 1 DO
        IF text (trim_size) <> ' ' THEN
          lgp$add_entry_to_system_log (pmc$msg_origin_system, text (1, trim_size), log_time, ignore_status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;

  PROCEND log_system_core_text;
?? OLDTITLE ??
?? NEWTITLE := '  MINUSPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the MINUS ('-') command.  It decrements the most recent DM subcommand starting
{ address by the most recent value of the length parameter.  This allows a user to page backward through
{ virtual memory.  There are no parameters for this command.
{

  PROCEDURE minusproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      i: integer,
      pc: ^cell,
      s: string (40),
      str: string (60);

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    IF syv$dump_to_pf THEN
      syp$write_output_header (' MINUS ', text);
    IFEND;

    IF last_dm_pva = NIL THEN
      osp$set_status_abnormal ('DB', dbe$, 'no prior DM command', status);
      RETURN;
    IFEND;

    s := '   ';
    i := #OFFSET (last_dm_pva) - last_dm_count;
    IF i < 0 THEN
      osp$set_status_abnormal ('DB', dbe$, 'address went negative', status);
      RETURN;
    IFEND;
    pc := #ADDRESS (#RING (last_dm_pva), #SEGMENT (last_dm_pva), i);
    syp$convert_bytes (#LOC (pc), 6, s (1, 12), FALSE);
    STRINGREP (s (15, 10), i, last_dm_count);
    dmproc (s, display_id, status);
    IF status.normal THEN
      str := 'DISM ';
      str (6, * ) := s;
      save_repeatable_command (str);
    IFEND;

  PROCEND minusproc;
?? OLDTITLE ??
?? NEWTITLE := '  MOD_BREAKPOINT', EJECT ??

{
{ Purpose:
{   This procedure processes the CHANGE_BREAKPOINT command.  It changes the virtual memory address range of a
{ previously established breakpoint. The parameters for the command are as follows:
{        NAME: Required, name.
{          Specifies the user-supplied name for the breakpoint.  Breakpoint names are a maximum of eight
{          characters in length.
{        BASE: Required, pointer.
{          Specifies the virtual memory address (PVA) of the breakpoint.  This is an 11-digit hexadecimal
{          number addressing a specific byte of memory.
{        OFFSET: Optional, integer.
{          Specifies the number of bytes from the address at which the breakpoint becomes effective.  The
{          specified address plus the offset yields the first byte address of the virtual memory address range
{          for the breakpoint.  The default is 0.
{        LENGTH: Optional, integer.
{          Specifies the number of bytes for which the breakpoint is valid.  The specified address plus the
{          offset plus the length - 1 yields the last byte address of the virtual memory address range.  The
{          default is 1.
{


{ CHANGE_BREAKPOINT parameter descriptor table:

  VAR
    change_brkpt_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 4] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'name    ', syc$name_value, * ],
{   } [TRUE, 2, 'address ', syc$pointer_value, NIL],
{   } [FALSE, 3, 'offset  ', syc$integer_value, 0, 0, 7fffffff(16)],
{   } [FALSE, 4, 'length  ', syc$integer_value, 1, 1, 7fffffff(16)]];

  PROCEDURE mod_breakpoint
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      dbl_index: integer,
      dbl_p: ^debug_list,
      hibyte: integer,
      lobyte: integer,
      name_found: boolean,
      pvt: array [1 .. 4] of syt$parameter_value,
      segnum: 0 .. 4095,
      str: string (60);

{ Crack the command.  Return if errors occur.

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (change_brkpt_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' CHANGE BREAKPOINT ', text);
    IFEND;


{ Search the debug list for the command-specified breakpoint name.  Return if the name is not found.

    dbl_p := ^syv$debug_list;
    find_dbl_entry (pvt [1].name, dbl_index, name_found);
    IF name_found = FALSE THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid_breakpoint_name', status);
      RETURN;
    IFEND;

{ Calculate address range and test validity.  Return if invalid.

    lobyte := #OFFSET (pvt [2].ptr);
    lobyte := lobyte + pvt [3].int;
    hibyte := (lobyte + pvt [4].int) - 1;
    IF ((lobyte < 0) OR (lobyte > 7fffffff(16))) OR ((hibyte < 0) OR (hibyte > 7fffffff(16))) OR
          (lobyte > hibyte) THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid_addrs_range', status);
      RETURN;
    IFEND;

{ Change the address bracket of the breakpoint.

    segnum := #SEGMENT (pvt [2].ptr);
    dbl_p^.sfwr_entry [dbl_index].segment := segnum;
    dbl_p^.sfwr_entry [dbl_index].lobyte := lobyte;
    dbl_p^.sfwr_entry [dbl_index].hibyte := hibyte;

    dbl_p^.hdwr_entry [dbl_index].segment := segnum;
    dbl_p^.hdwr_entry [dbl_index].lobyte := lobyte;
    dbl_p^.hdwr_entry [dbl_index].hibyte := hibyte;

    update_debug_masks;

  PROCEND mod_breakpoint;
?? OLDTITLE ??
?? NEWTITLE := '  PLUSPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the PLUS ('+') command.  It increments the most recent DM subcommand starting
{ address by the most recent value of the length parameter.  This allows a user to page forward through
{ virtual memory.  There are no parameters for this command.
{

  PROCEDURE plusproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      i: integer,
      pc: ^cell,
      s: string (40),
      str: string (60);

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    IF syv$dump_to_pf THEN
      syp$write_output_header (' PLUS ', text);
    IFEND;

    IF last_dm_pva = NIL THEN
      osp$set_status_abnormal ('DB', dbe$, 'no prior DM command', status);
      RETURN;
    IFEND;

    s := '   ';
    pc := #ADDRESS (#RING (last_dm_pva), #SEGMENT (last_dm_pva), #OFFSET (last_dm_pva) + last_dm_count);
    syp$convert_bytes (#LOC (pc), 6, s (1, 12), FALSE);
    STRINGREP (s (15, 10), i, last_dm_count);
    dmproc (s, display_id, status);
    IF status.normal THEN
      str := 'DISM ';
      str (6, * ) := s;
      save_repeatable_command (str);
    IFEND;

  PROCEND plusproc;
?? OLDTITLE ??
?? NEWTITLE := '  PRINT_BRKPT', EJECT ??

{
{ Purpose:
{   This procedure prints the specified breakpoint and the all of the information associated with it.
{        DBL_P: A pointer to the debug breakpoint name list which will be accessed for the specified
{          breakpoint entry.
{        DBL_I: The value of the index into the debug breakpoint list whose entry contains the name which
{          must be located.
{        STATUS: VAR of ost$status
{

  PROCEDURE print_brkpt
    (    dbl_p: ^debug_list;
         dbl_i: integer;
     VAR status: ost$status);

    VAR
      blank: string (4),
      j: debug_condition,
      line: string (46),
      str_i: integer,
      ucr_ord: ost$user_condition;

    status.normal := TRUE;
    ;
    blank := '    ';

    line (1, 46) := 'ID=xxxxxxxx  SEG=000  FB=00000000  LB=00000000';
    line (4, 8) := dbl_p^.sfwr_entry [dbl_i].name (1, 8);
    hex_string (dbl_p^.sfwr_entry [dbl_i].segment, line, 20);
    hex_string (dbl_p^.sfwr_entry [dbl_i].lobyte, line, 33);
    hex_string (dbl_p^.sfwr_entry [dbl_i].hibyte, line, 46);
    syp$write_output_line (line (1, 46), status);

    line (1, 46) := '                                              ';
    str_i := 2;
    FOR j := dc_read TO dc_invbdp DO
      IF dbl_p^.sfwr_entry [dbl_i].condition [j] = TRUE THEN
        cond_ord_to_ucr_ord (j, ucr_ord, line (str_i, 8));
        IF (str_i + 17) > 46 THEN
          syp$write_output_line (line, status);
          str_i := 2;
          line (1, 46) := '                                              ';
        ELSE
          str_i := str_i + 10;
        IFEND;
      IFEND;
    FOREND;
    IF str_i > 2 THEN
      syp$write_output_line (line, status);
    IFEND;
    RETURN;
  PROCEND print_brkpt;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_COMMANDS', EJECT ??

{
{ Purpose:
{   This procedure is the main procedure which sets up/cleans up the debug environment for the task(s) which
{ enter/exit the system core debugger.  Additionally, it contains the main REPEAT loop which keeps the task in
{ the debugger until it can continue to execute or it is 'HANGed" or "KILLed".  Only one task can be debugged
{ at a time; additional tasks will queue up waiting for the debugger lock.  The parameters for the procedure
{ are as follows:
{        SFSA_P: A pointer to the stack frame save area in which a trap occured which required the invocation
{          of the system core debugger.
{        STR: An eight-character string describing the reason for the invocation of the system core debugger;
{          i.e. a trap or a command.
{        OPTIONAL_MES: A string value which is displayed only if it is non-blank.
{        DUMP_JOB_ENVIRONMENT: A boolean value which describes whether this procedure is the result of a
{          DUMPJOB command.
{        STATUS: VAR of ost$status.
{

  PROCEDURE process_commands
    (    sfsa_p: ^cell;
         str: string (8);
         optional_mes: string ( * );
         dump_job_environment: boolean;
     VAR status: ost$status);

    VAR
      continue: boolean,
      delay: tmt$rb_delay,
      display_status: ost$status,
      entry_timestamp: integer,
      hr_save: 0 .. 255,
      i: integer,
      ignore_status: ost$status,
      local_debug_output_disposition: syt$debug_output_disposition,
      lock: [STATIC] ost$signature_lock,
      lock_status: ost$status,
      mes2: string (60),
      mf: tmt$monitor_fault_buffer,
      number_of_window_lines: dpt$number_of_window_lines,
      oldte: 0 .. 3,
      open_lock: [STATIC] ost$signature_lock,
      pb: ^boolean,
      sls: ost$signature_lock_status,
      system_log_p: ^cell,
      syv$run_all_timestamp: [XDCL, oss$job_fixed] integer,
      update_debug_rb: tmt$rb_update_job_task_enviro,
      xcb_p: ^ost$execution_control_block;

    IF syv$nosve_job_template THEN

{ Update to allow job recovery

      syv$job_template_ptr_array := nosve_template_ptr_array;
    IFEND;
    IF syv$dflt_debug_output_disposal.disposal = syc$dod_null THEN
      local_debug_output_disposition := syv$debug_output_disposition;
    ELSE
      local_debug_output_disposition := syv$dflt_debug_output_disposal.disposal;
    IFEND;
    mes2 := 'Queued     mmmmmmmm jjjjjjj, ttttttttttttttttttttttttttttttt';
    mes2 (12, 8) := str;
    mes2 (21, 7) := jmv$jcb.jobname;
    pmp$find_executing_task_xcb (xcb_p);
    mes2 (30, 31) := xcb_p^.save9; {taskname}
    osp$set_signature_lock (open_lock, osc$wait, ignore_status);
    IF NOT syv$debug_control.debug_active THEN
      syv$debug_control.trap_proc := ^debug_trap_processor;
      syv$debug_control.trapped_sfsa := sfsa_p;
      syv$debug_control.debug_list_p := ^syv$debug_list;
      syv$debug_control.high_ring_for_debug := 3;

      FOR i := 1 TO 32 DO
        syv$debug_list.sfwr_entry [i].name := '        ';
      FOREND;
      dpp$open_window (dpc$wc_invisible, dpc$wk_interactive, 'SYSTEM CORE DEBUGGER', display_id, status);
      syv$debug_control.debug_active := TRUE;
    IFEND;
    osp$clear_signature_lock (open_lock, ignore_status);
    osp$test_signature_lock (lock, sls, ignore_status);
    IF sls = osc$sls_locked_by_current_task THEN
      dpp$put_next_line (display_id, ' Recursive call to sysdebug - ignored.', status);
      osp$set_status_abnormal ('DB', dbe$, 'recursive call to SYSDEBUG', status);
      RETURN;
    IFEND;
    osp$set_signature_lock (lock, osc$nowait, ignore_status);
    IF NOT ignore_status.normal THEN
      dpp$put_next_line (display_id, mes2, status);
      entry_timestamp := #FREE_RUNNING_CLOCK (0);
      REPEAT
        pmp$delay (2000, status);
        IF syv$run_all_timestamp >= entry_timestamp THEN
          mes2 (1, 8) := 'Dequeued';
          dpp$put_next_line (display_id, mes2, status);
          RETURN;
        ELSE
          lock_status.normal := TRUE;
          osp$set_signature_lock (lock, osc$nowait, lock_status);
        IFEND;
      UNTIL lock_status.normal;
    IFEND;

    dpp$change_window (display_id, dpc$wc_pre_empt, dpc$wk_interactive, status);
    IF syv$debugger_page_wait_lines <> 0 THEN
      syv$db_page_wait_lines_instance := syv$debugger_page_wait_lines;
    ELSE

{ Have to calculate the number of displayable lines.

      dpp$get_number_lines_in_window (display_id, number_of_window_lines, status);
      syv$db_page_wait_lines_instance := number_of_window_lines;
      IF status.normal THEN
        syv$debugger_display_id := display_id;
      IFEND;
    IFEND;

    syv$dump_to_pf := (local_debug_output_disposition <> syc$dod_null);
    syv$debug_output_disposal_info.output_destination := local_debug_output_disposition;
    mes2 (1, 10) := 'Processing';
    syv$debug_control.trapped_sfsa := sfsa_p;

{ NOTE:
{ Save, clear and restore monitor faults (see also DISMFPROC).  This must be done on entry and exit of system
{ debugger.  Also, MONITOR_FAULTS is a (mainframe scope) static variable (for dismfproc).  This is (sort of) a
{ kludge.

    monitor_faults := xcb_p^.monitor_faults;
    FOR i := LOWERBOUND (xcb_p^.monitor_faults.present) TO UPPERBOUND (xcb_p^.monitor_faults.present) DO
      xcb_p^.monitor_faults.reserved [i] := FALSE;
      xcb_p^.monitor_faults.present [i] := FALSE;
    FOREND;

    hr_save := mtv$halt_cpu_ring_number;
    mtv$halt_cpu_ring_number := 0;
    REPEAT
      est_flag := FALSE;
      repress_headers_flag := FALSE;
      syv$debugger_task_timeout := FALSE;

{ If this is not a device_management task then we can log debugger commands to the system log.

      system_log_p := #ADDRESS (1, osc$segnum_system_dayfile, 0);
      syp$verify_access (syc$readable, ^system_log_p, status);
      IF NOT status.normal THEN
        syv$inhibit_core_cmd_logging := TRUE;
      ELSE
        syv$inhibit_core_cmd_logging := FALSE;
      IFEND;
      status.normal := TRUE;

      syv$db_displayed_console_lines := 0;
      i#enable_traps (oldte);
      process_debug_task (sfsa_p, str, optional_mes, dump_job_environment, mes2, status);
      IF (NOT status.normal) AND syv$debugger_task_timeout THEN
        dpp$put_next_line (display_id, 'Debugger command timeout condition encountered; command aborted',
              display_status);
        osp$end_text_dump;
        syv$dump_to_pf := FALSE;
        syv$debug_output_disposal_info.output_destination := syc$dod_null;
      IFEND;
      syv$db_displayed_console_lines := 0;
      i#restore_traps (oldte);
    UNTIL status.normal;

    IF syv$dump_to_pf THEN
      osp$end_text_dump;
      syv$dump_to_pf := FALSE;
      syv$debug_output_disposal_info.output_destination := syc$dod_null;
    IFEND;

{ Get ready to restore monitor faults.

    mf := monitor_faults;

    IF mtv$halt_cpu_ring_number = 0 THEN

{ Restore only if not changed during debug.

      mtv$halt_cpu_ring_number := hr_save;
    IFEND;
    last_dm_pva := NIL;
    dpp$change_window (display_id, dpc$wc_invisible, dpc$wk_interactive, status);
    osp$clear_signature_lock (lock, ignore_status);

    IF (syv$job_template_ptr_array <> NIL) AND (UPPERBOUND (syv$job_template_ptr_array^) >= 3) THEN
      pb := syv$job_template_ptr_array^ [3];
      IF pb^ THEN
{!      syp$write_output_line ('DEBUGGER EXIT - TASK LEFT HUNG !!', status);
        i#enable_traps (oldte);
        WHILE pb^ DO
          delay.reqcode := syc$rc_delay;
          delay.expected_wait_time := 100000000 * 1000;
          delay.requested_wait_time := delay.expected_wait_time + #FREE_RUNNING_CLOCK (0);
          i#call_monitor (#LOC (delay), #SIZE (delay));
        WHILEND;
{!      syp$write_output_line ('DEBUGGER EXIT - HUNG TASK CLEARED !!', status);
        i#restore_traps (oldte);
      IFEND;
    IFEND;

{ Restore monitor faults.

    xcb_p^.monitor_faults := mf;

  PROCEND process_commands;
?? OLDTITLE ??
?? NEWTITLE := '  PROCESS_DEBUG_TASK', EJECT ??

{
{ Purpose:
{   This procedure is the procedure which allows interactive processing of commands for the task(s) which
{ enter the system core debugger.  Additionally, it allows the non-interactive processing of DUMPJOB commands
{ and "dump_when_debug" dumps.  The parameters for the procedure are as follows:
{        SFSA_P: A pointer to the stack frame save area in which a trap occured which required the invocation
{          of the system core debugger.
{        STR: An eight-character string describing the reason for the invocation of the system core debugger;
{          i.e. a trap or a command.
{        OPTIONAL_MES: A string value which is displayed only if it is non-blank.
{        DUMP_JOB_ENVIRONMENT: A boolean value which describes whether this procedure is the result of a
{          DUMPJOB command.
{        MES2: A string describing the environment which is in effect for the debugger during execution of the
{          procedure.
{        STATUS: VAR of ost$status.
{

  PROCEDURE process_debug_task
    (    sfsa_p: ^cell;
         str: string (8);
         optional_mes: string ( * );
         dump_job_environment: boolean;
         mes2: string (60);
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      length: integer,
      log_string: string (256),
      message: string (60),
      xcb_p: ^ost$execution_control_block;

?? NEWTITLE := '    PROCESS_DEBUG_TASK - CH', EJECT ??

    PROCEDURE ch
      (    mf: ost$monitor_fault;
           ctc: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      VAR
        ignore_status: ost$status,
        line_limit: string (40),
        s: string (40);

      s := ' Debugger failure - try again';
      line_limit := ' Line limit exceeded - try again';
      syv$inhibit_core_cmd_logging := FALSE;

      IF syv$terminate_sysdebug_output THEN

{ Messages have already been displayed.

        syv$terminate_sysdebug_output := FALSE;
        status.normal := FALSE;
        EXIT process_debug_task;
      IFEND;

      IF NOT syv$dump_to_pf THEN
        IF syv$debug_line_count > syv$max_debug_output_lines THEN
          dpp$put_next_line (display_id, line_limit, ignore_status);
        ELSE
          dpp$put_next_line (display_id, s, ignore_status);
        IFEND;
      ELSE
        IF syv$debug_line_count > syv$max_debug_output_lines THEN
          osp$output_debug_text (^line_limit, ignore_status);
        ELSEIF (syv$db_page_wait_lines_instance <> 0) AND (syv$db_displayed_console_lines >=
              syv$db_page_wait_lines_instance) THEN

{ Messages have already been displayed.

          syv$db_displayed_console_lines := 0;
        ELSE
          osp$output_debug_text (^s, ignore_status);
        IFEND;
      IFEND;
      status.normal := FALSE;
      EXIT process_debug_task;
    PROCEND ch;
?? OLDTITLE, EJECT ??

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    status.normal := TRUE;
    syp$establish_condition_handler (^ch);
    pmp$find_executing_task_xcb (xcb_p);

  /debug_task/
    BEGIN
      STRINGREP (log_string, length, 'Begin System Core Debugger session on task GTID = [',
            xcb_p^.global_task_id.index:#(16), ' -', xcb_p^.global_task_id.seqno:#(16),
            ' ](16), task name = ', xcb_p^.save9);
      log_system_core_text (log_string (1, length));
      IF dump_job_environment OR ((NOT syv$nosve_job_template) AND
            (tmv$job_debug_ring > tmv$system_debug_ring)) THEN
        dpp$put_next_line (display_id, ' DUMPJOB task dump in progress', status);
        IF (syv$debug_output_disposal_info.output_destination= syc$dod_save_and_print) OR
              (syv$debug_output_disposal_info.output_destination= syc$dod_null) THEN
          setod_proc ('retain_and_printer '' DUMPJOB Task Dump ''', display_id, status);
        ELSEIF syv$debug_output_disposal_info.output_destination= syc$dod_save_on_pf THEN
          setod_proc ('retain '' DUMPJOB Task Dump ''', display_id, status);
        ELSEIF syv$debug_output_disposal_info.output_destination= syc$dod_write_for_print THEN
          setod_proc ('printer '' DUMPJOB Task Dump ''', display_id, status);
        IFEND;
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        autoproc ({dump segments 3,4,6 =} (xcb_p^.save9 = '$JOBMNTR                       '),
              dump_job_environment, status);
        dpp$put_next_line (display_id, ' DUMPJOB task dump complete', status);
      ELSE

        IF NOT osv$dump_when_debug THEN
          dpp$put_next_line (display_id, mes2, status);
          IF optional_mes <> '  ' THEN
            dpp$put_next_line (display_id, optional_mes, status);
          IFEND;
          IF (syv$debug_output_disposal_info.output_destination = syc$dod_save_and_print) THEN
            setod_proc ('retain_and_printer '' Interactive Dump Session ''', display_id, status);
          ELSEIF syv$debug_output_disposal_info.output_destination = syc$dod_save_on_pf THEN
            setod_proc ('retain '' Interactive Dump Session ''', display_id, status);
          ELSEIF syv$debug_output_disposal_info.output_destination = syc$dod_write_for_print THEN
            setod_proc ('printer '' Interactive Dump Session ''', display_id, status);
          IFEND;
          syp$process_core_commands (display_id, 'RUN ', ^command_table, status);
        ELSE
          dpp$put_next_line (display_id, 'Starting automatic debug dump', status);
          status.normal := TRUE;
          IF (syv$debug_output_disposal_info.output_destination = syc$dod_save_and_print) OR
                (syv$debug_output_disposal_info.output_destination = syc$dod_null) THEN
            setod_proc ('retain_and_printer '' Automatic Task Dump ''', display_id, status);
          ELSEIF syv$debug_output_disposal_info.output_destination = syc$dod_save_on_pf THEN
            setod_proc ('retain '' Automatic Task Dump ''', display_id, status);
          ELSEIF syv$debug_output_disposal_info.output_destination = syc$dod_write_for_print THEN
            setod_proc ('printer ''Automatic Task Dump ''', display_id, status);
          IFEND;
          IF NOT status.normal THEN
            RETURN;
          IFEND;
          autoproc ({dump segments 3,4,6 =} TRUE, {dump_job_environment =} FALSE, status);
          IF status.normal THEN
            dpp$put_next_line (display_id, 'Automatic dump complete', status);
          ELSE
            dpp$put_next_line (display_id, 'Automatic dump failed as follows', ignore_status);
            dpp$put_next_line (display_id, status.text.value (1, status.text.size), ignore_status);
          IFEND;
        IFEND;
      IFEND;
    END /debug_task/;

    status.normal := TRUE;
  PROCEND process_debug_task;
?? OLDTITLE ??
?? NEWTITLE := '  PROPAGATE_DEBUG_MASK_BIT', EJECT ??

{
{ Purpose:
{   This procedure propagates a set or cleared debug mask bit in the user condition register field of the
{ previous save area to this procedure to the end of the stack for this task.  The parameter is as follows:
{        BIT_VALUE: A boolean describing whether the debug mask bit should be set or cleared.
{

  PROCEDURE propagate_debug_mask_bit
    (    bit_value: boolean);

    VAR
      dblist: debug_list_pointer,
      sa_p: ^stack_frame_control_image,
      status: ost$status;

    sa_p := #PREVIOUS_SAVE_AREA ();
    IF bit_value THEN
      dblist.list_p := ^syv$debug_list;
      #WRITE_REGISTER (osc$pr_debug_list_pointer, dblist.int);
    IFEND;
    REPEAT
      sa_p^.user_condition_mask [osc$debug] := bit_value;
      syp$verify_access (syc$writeable, #LOC (sa_p^.psa), status);
      IF NOT status.normal THEN
        sa_p := NIL
      ELSE
        sa_p := sa_p^.psa;
      IFEND;
    UNTIL sa_p = NIL;
  PROCEND propagate_debug_mask_bit;
?? OLDTITLE ??
?? NEWTITLE := '  REG_DISPLAY', EJECT ??

{
{ Purpose:
{   This procedure processes the DISPLAY_REGISTER command.  It displays the contents of a specified register
{ of an interrupted task. The parameters for the command are as follows:
{        RTYPE: Required, name.
{          Specifies the type of register to be displayed.  Values can be
{          . 'P' for a program address register
{          . 'A' for an address register
{          . 'X' for an operand register
{        ID: Optional, integer.
{          Specifies the hexadecimal or decimal number of the register to be displayed.  This parameter is
{          valid for the A and X keywords.  The registers are numbered from 0 through 15 (decimal) or from 0
{          through F hexadecimal.  The default is 0.
{        VTYPE: Optional, name.
{          Specifies how the data of the register contents is to be interpreted.  One of the following
{          keywords can be specified:
{            . ASCII or ASC - ASCII data.
{            . DEC          - Decimal number.
{            . HEX          - Hexadecimal number.
{          The default is HEX.
{


{ DISPLAY_REGISTER parameter descriptor table:

  VAR
    display_reg_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 3] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'reg_type', syc$name_value, * ],
{   } [FALSE, 2, 'reg_num ', syc$integer_value, 0, 0, 15],
{   } [FALSE, 3, 'option  ', syc$name_value, 'HEX     ']];

  PROCEDURE reg_display
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      dec_p: ^integer,
      i: integer,
      line: string (26),
      pvt: array [1 .. 3] of syt$parameter_value,
      str: string (60),
      str_p: ^string (8),
      trapped_sf: stack_image_pointer;

{ Crack the command.  Return if errors occur.

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (display_reg_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY REGISTER ', text);
    IFEND;

{ Locate the stack frame associated with the trapped procedure.  Return an error code if none exists.

    find_trapped_stack_frame (trapped_sf.cell_p);
    IF trapped_sf.cell_p = NIL THEN
      osp$set_status_abnormal ('DB', dbe$, 'no_trap_has_occurred', status);
      RETURN;
    IFEND;

    IF pvt [1].name (1, 2) = 'P ' THEN

      line (1, 16) := 'P=0 000 00000000';
      hex_string (trapped_sf.control^.p_reg.pva.ring, line, 3);
      hex_string (trapped_sf.control^.p_reg.pva.seg, line, 7);
      hex_string (trapped_sf.control^.p_reg.pva.offset, line, 16);
      syp$write_output_line (line (1, 16), status);
      RETURN;

    ELSEIF pvt [1].name (1, 2) = 'A ' THEN

      IF (pvt [2].int >= 0) AND (pvt [2].int <= trapped_sf.control^.frame_desc.a_terminate) THEN
        line (1, 17) := 'A0=0 000 00000000';
        hex_string (pvt [2].int, line, 2);
        hex_string (trapped_sf.aregs^.reg [pvt [2].int].pva.ring, line, 4);
        hex_string (trapped_sf.aregs^.reg [pvt [2].int].pva.seg, line, 8);
        hex_string (trapped_sf.aregs^.reg [pvt [2].int].pva.offset, line, 17);
        syp$write_output_line (line (1, 17), status);
      ELSE
        osp$set_status_abnormal ('DB', dbe$, 'reg_not_in_sf', status);
      IFEND;
      RETURN;

    ELSEIF pvt [1].name (1, 2) = 'X ' THEN

      IF (pvt [2].int >= trapped_sf.control^.frame_desc.x_start) AND
            (pvt [2].int <= trapped_sf.control^.frame_desc.x_terminate) THEN
        i := ((trapped_sf.control^.frame_desc.a_terminate) + 1);
        i := i + (pvt [2].int - trapped_sf.control^.frame_desc.x_start);
        dec_p := #LOC (trapped_sf.xregs^.reg [i]);
        str_p := #LOC (dec_p^);

        IF pvt [3].name (1, 3) = 'HEX' THEN
          line (1, 25) := 'X0=00000000  00000000(16)';
          hex_string (pvt [2].int, line, 2);
          hex_string (trapped_sf.xregs^.reg [i].lhalf, line, 11);
          hex_string (trapped_sf.xregs^.reg [i].rhalf, line, 21);
          syp$write_output_line (line (1, 25), status);
        ELSEIF pvt [3].name (1, 3) = 'ASC' THEN
          line (1, 11) := 'X0=yyyyyyyy';
          hex_string (pvt [2].int, line, 2);
          line (4, 8) := str_p^ (1, 8);
          syp$write_output_line (line (1, 11), status);
        ELSEIF pvt [3].name (1, 3) = 'DEC' THEN
          line (1, 26) := 'X0=0000000000000000000(10)';
          hex_string (pvt [2].int, line, 2);
          syp$binary_to_ascii (dec_p^, line, 10, 22);
          syp$write_output_line (line (1, 26), status);

        ELSE
          osp$set_status_abnormal ('DB', dbe$, 'invalid_data_type_def', status);
        IFEND;
      ELSE
        osp$set_status_abnormal ('DB', dbe$, 'reg_not_in_sf', status);
      IFEND;

    ELSE
      osp$set_status_abnormal ('DB', dbe$, 'invalid_reg_type', status);

    IFEND;
  PROCEND reg_display;
?? OLDTITLE ??
?? NEWTITLE := '  REMOVE_BREAKPOINT', EJECT ??

{
{ Purpose:
{   This procedure processes the REMOVE_BREAKPOINT command.  It deactivates a previously active breakpoint or
{ specified conditions on a previously active breakpoint.  The parameters for the command are as follows:
{        NAME: Required, name.
{          Specifies the name of the breakpoint to be deactivated.  If only the name parameter is specified,
{          all conditions set for that breakpoint are cleared.
{        COND: Optional, name.
{          Specifies the particular condition to clear for the named breakpoint.  If this is the only
{          condition set, the entire breakpoint is cleared.  If more than one condition is set, the other
{          conditions and the breakpoint remain in effect.  The following keywords can be specified:
{            . RNI     - Read next instruction. This is the most commonly used breakpoint condition.
{            . READ    - Read from virtual memory.
{            . WRITE   - Write to virtual memory.
{            . BRANCH  - Branch to another location.
{            . CALL    - Call to another module.
{            . DIVFLT  - Division fault.
{            . ARLOS   - Arithmetic loss of significance.
{            . AROVFL  - Arithmetic overflow.
{            . EXOVFL  - Exponential overflow.
{            . EXUNFL  - Exponential underflow.
{            . FPLOS   - Floating-point loss of significance.
{            . FPINDEF - Floating-point indefinite operand condition.
{            . INVBDP  - Invalid business data processing (BDP) instruction.
{


{ REMOVE_BREAKPOINTS parameter descriptor table:

  VAR
    remove_brkpt_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 2] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'name    ', syc$name_value, * ],
{   } [FALSE, 2, 'cond    ', syc$name_value, * ]];

  PROCEDURE remove_breakpoint
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    TYPE
      fake = packed record
        case x: 0 .. 1 of
        = 0 =
          int: 0 .. 1fff(16),
        = 1 =
          a: packed array [debug_condition] of boolean,
        casend
      recend;

    VAR
      cond_name: string (8),
      cond_ord: debug_condition,
      condition_valid: boolean,
      dbl_index: integer,
      dbl_p: ^debug_list,
      debug_mask_reg: debug_mask,
      high_remove_index: integer,
      i: integer,
      j: integer,
      l: debug_condition,
      name_found: boolean,
      pvt: array [1 .. 2] of syt$parameter_value,
      remove: array [1 .. 13] of debug_condition,
      str: string (60),
      trans: fake,
      ucr_ord: ost$user_condition;

{ Crack the command.  Return if errors occur.

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (remove_brkpt_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' REMOVE BREAKPOINT ', text);
    IFEND;


{ Validate the breakpoint name.  Return if invalid.

    dbl_p := ^syv$debug_list;
    find_dbl_entry (pvt [1].name, dbl_index, name_found);
    IF name_found = FALSE THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid_breakpoint_name', status);
      RETURN;
    IFEND;

{ If a condition is specified, test for validity.  Return if invalid.

    IF pvt [2].defined = TRUE THEN
      validate_brkpt_condition (pvt [2].name, cond_ord, ucr_ord, condition_valid);
      IF condition_valid = FALSE THEN
        osp$set_status_abnormal ('DB', dbe$, 'invalid_breakpoint_cond', status);
        RETURN;
      ELSEIF dbl_p^.sfwr_entry [dbl_index].condition [cond_ord] = FALSE THEN
        osp$set_status_abnormal ('DB', dbe$, 'condition_not_selected', status);
        RETURN;
      IFEND;
    IFEND;

{ Build an array of debug_list.sfwr_entry.condition indices which identify the breakpoint condition(s) which
{ is(are) to be removed.

    CASE pvt [2].defined OF

    = TRUE =

{ A single, specific condition is to be removed.

      remove [1] := cond_ord;
      high_remove_index := 1;

    = FALSE =

{ All conditions currently selected for the breakpoint are to be removed.

      high_remove_index := 0;
      FOR l := dc_read TO dc_invbdp DO

        IF dbl_p^.sfwr_entry [dbl_index].condition [l] = TRUE THEN
          high_remove_index := high_remove_index + 1;
          remove [high_remove_index] := l;
        IFEND;
      FOREND;
    CASEND;

{ Process removal of breakpoint condition based upon the array of condition indices previously constructed.

    FOR j := 1 TO high_remove_index DO
      dbl_p^.sfwr_entry [dbl_index].condition [remove [j]] := FALSE;
      dbl_p^.select_count [remove [j]] := dbl_p^.select_count [remove [j]] - 1;
      cond_ord_to_ucr_ord (remove [j], ucr_ord, cond_name);
      IF ucr_ord = osc$debug THEN
        dbl_p^.sfwr_entry [dbl_index].hscnt := dbl_p^.sfwr_entry [dbl_index].hscnt - 1;
        dbl_p^.hdwr_entry [dbl_index].condition [remove [j]] := FALSE;
        IF dbl_p^.select_count [remove [j]] = 0 THEN
          i := #READ_REGISTER (osc$pr_debug_mask_reg);
          debug_mask_reg.int := i;
          debug_mask_reg.condition [remove [j]] := FALSE;
          i := debug_mask_reg.int;
          #WRITE_REGISTER (osc$pr_debug_mask_reg, i);
          syv$debug_control.debug_mask := debug_mask_reg.os_code;
          debug_mask_reg.fill1 := 0;
          IF debug_mask_reg.int = 0 THEN
            syv$debug_control.selected_ucr_conditions [ucr_ord] := FALSE;
          IFEND;
        IFEND;
        IF (dbl_p^.sfwr_entry [dbl_index].hscnt = 0) AND (dbl_p^.hdwr_entry [dbl_index].eol = TRUE) THEN
          dbl_p^.hdwr_entry [dbl_index].eol := FALSE;
          i := 32;
          WHILE (i >= 1) AND (dbl_p^.sfwr_entry [i].hscnt = 0) DO
            i := i - 1;
          WHILEND;
          dbl_p^.eol_index := i;
          IF i > 0 THEN
            dbl_p^.hdwr_entry [i].eol := TRUE;
          ELSE
            syv$debug_control.set_debug_bit_in_um := FALSE;
            propagate_debug_mask_bit (FALSE);
          IFEND;
        IFEND;
      ELSEIF dbl_p^.select_count [remove [j]] = 0 THEN
        syv$debug_control.selected_ucr_conditions [ucr_ord] := FALSE;
      IFEND;
    FOREND;

{ If no conditions remain selected for this breakpoint, completely delete the breakpoint.

    trans.a := dbl_p^.sfwr_entry [dbl_index].condition;
    IF trans.int = 0 THEN
      dbl_p^.sfwr_entry [dbl_index].name := '        ';
    IFEND;
    update_debug_masks;

  PROCEND remove_breakpoint;
?? OLDTITLE ??
?? NEWTITLE := '  REPEAT_PROC', EJECT ??

{
{ Purpose:
{   This procedure processes the REPEAT command.  There are no parameters for the command.
{

  PROCEDURE repeat_proc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);


    VAR
      str: string (60);

    IF syv$repeatable_command_p = NIL THEN
      osp$set_status_abnormal ('DB', dbe$, 'No command to repeat', status);
      RETURN;
    IFEND;
    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    status.normal := TRUE;
    IF syv$dump_to_pf THEN
      syp$write_output_header (' Repeating command:', '');
      str := ' ';
      str (4, * ) := syv$repeatable_command_p^ (1, STRLENGTH (syv$repeatable_command_p^));
      syp$write_output_line (str, status);
    IFEND;
    status.normal := TRUE;

    syp$process_command_line (syv$repeatable_command_p^, ^command_table, display_id, status);

  PROCEND repeat_proc;
?? OLDTITLE ??
?? NEWTITLE := '  SAVE_REPEATABLE_COMMAND', EJECT ??
{
{ Purpose:
{   This procedure saves a "repeatable" command in the mainframe_wired heap for use later by the REPEAT
{ command.  Its basic use is for saving the PLUS and MINUS commands in a form which can be repeated.
{        COMMAND_STRING: An adaptable string containing the command which can be repeated.
{

  PROCEDURE save_repeatable_command
    (    command_string: string ( * ));

    IF syv$repeatable_command_p <> NIL THEN
      FREE syv$repeatable_command_p IN osv$mainframe_wired_heap^;
    IFEND;

    ALLOCATE syv$repeatable_command_p: [STRLENGTH (command_string)] IN osv$mainframe_wired_heap^;
    syv$repeatable_command_p^ := command_string (1, STRLENGTH (command_string));

  PROCEND save_repeatable_command;
?? OLDTITLE ??
?? NEWTITLE := '  SCMPROC', EJECT ??

{
{ Purpose:
{   This procedure processes the SUPER_CHANGE_MEMORY command.  It changes the contents of the specified
{ location in virtual memory exactly as the CHANGE_MEMORY subcommand with the additional capability to
{ change segment access attributes to allow the change and then replace the original segment access
{ attributes.  The parameters for the command are as follows:
{        FBA: Required, pointer.
{          Specifies the virtual memory address (as a PVA or symbolic address) where the new value is entered
{          (this value is an 11-digit hexadecimal number addressing a specific byte of memory).
{        MV: Required, integer.
{          Specifies a number that replaces the bytes at the specified address.
{        BC: Optional, integer.
{          Specifies the number of consecutive bytes for which the new value is entered.  The default is 1.
{          The count can be a maximum of 8.
{

  PROCEDURE scmproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      purge_buffer_param2: ^cell,
      pvt: array [1 .. 3] of syt$parameter_value,
      saved_ste: ost$segment_descriptor,
      sdte_p: ^mmt$segment_descriptor,
      str: string (60),
      xcbp: ^ost$execution_control_block;

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (cm_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' SUPER CHANGE MEMORY', text);
    IFEND;

    pmp$find_executing_task_xcb (xcbp);
    IF #SEGMENT (pvt [1].ptr) > xcbp^.xp.segment_table_length THEN
      osp$set_status_abnormal ('DB', dbe$, 'segment too big', status);
      RETURN;
    IFEND;

    sdte_p := mmp$get_sdt_entry_p (xcbp, #SEGMENT (pvt [1].ptr));
    saved_ste := sdte_p^.ste;
    sdte_p^.ste.wp := osc$write_uncontrolled;
    purge_buffer_param2 := NIL;
    #PURGE_BUFFER (osc$purge_all_page_seg_map, purge_buffer_param2);
    cmproc (text, id, status);
    syp$purge_instruction_stack;
    sdte_p^.ste := saved_ste;
    #PURGE_BUFFER (osc$purge_all_page_seg_map, purge_buffer_param2);

  PROCEND scmproc;
?? OLDTITLE ??
?? NEWTITLE := '  SELECT_COMMAND', EJECT ??

{
{ Purpose:
{   This procedure processes the SELECT command.  It specifies the task or tasks in which breakpoints are to
{ be set or identifies a new control option for the task or tasks previously selected. The parameters for the
{ command are as follows:
{        OPTION: Required, name.
{          Specifies the control option used to control the tasks in which the system core debugger is active.
{          The following keywords can be specified:
{          ALLJOBS            - Activates the system core debugger in all active jobs.
{          HIGHRING           - Specifies the greatest ring number in which system core debugger traps are
{          (integer)            recognized. Traps occurring on instructions with ring numbers greater than
{  [See second parameter]       this ring number are ignored. "HIGHRING 3" is a predefined control option.
{          JOB                - Allows activation of the system core debugger in the job with the specified
{         (integer or name)     job ordinal or system_supplied name.  A job's ordinal can be found by looking
{  [See second parameter]       at the VED AJ display on the system display console, but note that if the
{                               system is swapping jobs, this may not be a reliable option because the job
{                               could swap in at a different job ordinal.
{          JOBMONITOR         - Activates the system core debugger in the job monitor task.
{          NOJOB              - Prevents the system core debugger from executing in the job previously
{          (integer or name)    specified in a JOB keyword.
{  [See second parameter]
{          NOJOBS             - Prevents the system core debugger from executing in all active jobs.
{          NOJOBMONITOR       - Prevents the system core debugger from executing in the job monitor task.
{          NOUSER             - Prevents the system core debugger from executing in user tasks.
{          USER               - Activates the system core debugger in user tasks (those that are not job
{                               monitor tasks).
{
{      [ONE OF]
{        JSN: Optional, name.
{          Specifies the system_supplied job name of the job being debugged for the required keyword [See
{          second parameter].
{        - OR -
{        N: Optional, integer.
{          Specifies the value for the required keyword [See first parameter].
{


{ SELECT parameter descriptor tables:

  VAR
    select_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 2] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'option  ', syc$name_value, * ],
{   } [FALSE, 2, 'jsn     ', syc$name_value, * ]],

    select_int_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 2] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'option  ', syc$name_value, * ],
{   } [FALSE, 2, 'n       ', syc$integer_value, 0, 0, 7fffffff(16)]];

  PROCEDURE select_command
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      ijl_bn: jmt$ijl_block_number,
      ijl_bi: jmt$ijl_block_index,
      ijle_p: ^jmt$initiated_job_list_entry,
      ijlo: jmt$ijl_ordinal,
      integer_variant: boolean,
      jobname: string (31),
      length: integer,
      n: 0 .. jmc$max_ajl_ord,
      name: ost$name,
      name_variant: boolean,
      pvt: array [1 .. 2] of syt$parameter_value,
      str: string (60);

{ Crack the command and exit if bad status.

    name_variant := FALSE;
    integer_variant := FALSE;

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (select_int_pdt, text, pvt, status);
    IF NOT status.normal THEN
      syp$crack_command (select_pdt, text, pvt, status);
      IF NOT status.normal THEN
        RETURN;
      ELSE
        name_variant := TRUE;
      IFEND;
    ELSE
      integer_variant := TRUE;
    IFEND;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' SELECT ', text);
    IFEND;

{ Process the command.

    name := pvt [1].name;
    IF (name = 'NOJOBS') OR (name = 'ALLJOBS') THEN

      IF name = 'NOJOBS' THEN
        syv$all_jobs_selected_for_debug := FALSE;
      ELSE {name = 'ALLJOBS'}
        syv$all_jobs_selected_for_debug := TRUE;
      IFEND;

{ Update the breakpoint selection field in every job in the system.

      IF mmv$tables_initialized THEN
        FOR ijl_bn := LOWERBOUND (jmv$ijl_p.block_p^) TO jmv$ijl_p.max_block_in_use DO
          IF jmv$ijl_p.block_p^ [ijl_bn].index_p <> NIL THEN
            FOR ijl_bi := LOWERVALUE (jmt$ijl_block_index) TO UPPERVALUE (jmt$ijl_block_index) DO
              ijle_p := ^jmv$ijl_p.block_p^ [ijl_bn].index_p^ [ijl_bi];
              IF ijle_p^.entry_status <> jmc$ies_entry_free THEN
                IF name = 'NOJOBS' THEN
                  ijle_p^.system_breakpoint_selected := FALSE;
                ELSE {name = 'ALLJOBS'}
                  ijle_p^.system_breakpoint_selected := TRUE;
                IFEND;
              IFEND;
            FOREND;
          IFEND;
        FOREND;
      IFEND;
    ELSEIF (name = 'JOB') AND (name_variant) THEN
      IF mmv$tables_initialized THEN
        jobname := pvt [2].name;
        length := clp$trimmed_string_size (jobname);
        IF length <= jmc$system_supplied_name_size THEN
          jmp$find_jsn (jobname (1, length), ijle_p, ijlo);
          IF ijle_p <> NIL THEN
            ijle_p^.system_breakpoint_selected := TRUE;
          ELSE
            osp$set_status_abnormal ('DB', dbe$, 'invalid job name', status);
          IFEND;
        ELSE
          osp$set_status_abnormal ('DB', dbe$, 'invalid job name', status);
        IFEND;
      ELSE
        osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      IFEND;
    ELSEIF (name = 'JOB') AND (integer_variant) AND (pvt [2].int <= mtv$mx_ajl_entries) THEN
      IF mmv$tables_initialized THEN
        ijle_p := jmv$ajl_p^ [pvt [2].int].ijle_p;
        IF (ijle_p <> NIL) AND (ijle_p^.ajl_ordinal = pvt [2].int) THEN
          ijle_p^.system_breakpoint_selected := TRUE;
        ELSE
          osp$set_status_abnormal ('DB', dbe$, 'invalid job name', status);
        IFEND;
      ELSE
        osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      IFEND;
    ELSEIF (name = 'NOJOB') AND (name_variant) THEN
      IF mmv$tables_initialized THEN
        jobname := pvt [2].name;
        length := clp$trimmed_string_size (jobname);
        IF length <= jmc$system_supplied_name_size THEN
          jmp$find_jsn (jobname (1, length), ijle_p, ijlo);
          IF ijle_p <> NIL THEN
            ijle_p^.system_breakpoint_selected := FALSE;
          ELSE
            osp$set_status_abnormal ('DB', dbe$, 'invalid job name', status);
          IFEND;
        ELSE
          osp$set_status_abnormal ('DB', dbe$, 'invalid job name', status);
        IFEND;
      ELSE
        osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      IFEND;
    ELSEIF (name = 'NOJOB') AND (integer_variant) AND (pvt [2].int <= mtv$mx_ajl_entries) THEN
      IF mmv$tables_initialized THEN
        ijle_p := jmv$ajl_p^ [pvt [2].int].ijle_p;
        IF (ijle_p <> NIL) AND (ijle_p^.ajl_ordinal = pvt [2].int) THEN
          ijle_p^.system_breakpoint_selected := FALSE;
        ELSE
          osp$set_status_abnormal ('DB', dbe$, 'invalid job name', status);
        IFEND;
      ELSE
        osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      IFEND;
    ELSEIF name = 'JOBMONITOR' THEN
      syv$debug_control.debug_job_monitors := TRUE;
    ELSEIF name = 'NOJOBMONITOR' THEN
      syv$debug_control.debug_job_monitors := FALSE;
    ELSEIF (name = 'HIGHRING') AND (integer_variant) AND (pvt [2].int <= 15) THEN
      syv$debug_control.high_ring_for_debug := pvt [2].int;
    ELSEIF name = 'USER' THEN
      syv$debug_control.debug_user_tasks := TRUE;
    ELSEIF name = 'NOUSER' THEN
      syv$debug_control.debug_user_tasks := FALSE;
    ELSE
      osp$set_status_abnormal ('DB', dbe$, 'invalid selection', status);
    IFEND;

    IF status.normal THEN
      update_debug_masks;
    IFEND;

  PROCEND select_command;
?? OLDTITLE ??
?? NEWTITLE := '  SET_BREAKPOINT', EJECT ??

{
{ Purpose:
{   This procedure processes the SET_BREAKPOINT command. It identifies the breakpoint name and establishes the
{ specific condition that causes a program interrupt.  When the specified condition is met after the task has
{ been restarted, the interrupt occurs.  A virtual address range can be optionally specified within which the
{ specified condition causes an interrupt.  The parameters for the command are as follows:
{        NAME: Required, name.
{          Specifies the user-supplied name for the breakpoint.  Breakpoint names are a maximum of eight
{          characters in length.
{        COND: Optional, name.
{          Specifies the condition that causes an interrupt to occur.  One of the following keywords must be
{          specified:
{            . RNI     - Read next instruction. This is the most commonly used breakpoint condition.
{            . READ    - Read from virtual memory.
{            . WRITE   - Write to virtual memory.
{            . BRANCH  - Branch to another location.
{            . CALL    - Call to another module.
{            . DIVFLT  - Division fault.
{            . ARLOS   - Arithmetic loss of significance.
{            . AROVFL  - Arithmetic overflow.
{            . EXOVFL  - Exponential overflow.
{            . EXUNFL  - Exponential underflow.
{            . FPLOS   - Floating-point loss of significance.
{            . FPINDEF - Floating-point indefinite operand condition.
{            . INVBDP  - Invalid business data processing (BDP) instruction.
{        BASE: Optional, pointer.
{          Specifies the address of the breakpoint as a process virtual address (PVA) or as a symbolic name.
{          This is an 11-digit hexadecimal number addressing a specific byte of memory.  This parameter is
{          required when a new breakpoint is being established.  This parameter cannot be specified when
{          conditions are being added to an existing breakpoint.
{        OFFSET: Optional, integer.
{          Specifies the number of bytes from the specified address that the breakpoint becomes effective.
{          The address plus the offset yields the first byte address of the virtual memory address range of
{          the breakpoint.  This parameter is optional when a new breakpoint is being established.  This
{          parameter cannot be specified when conditions are being added to an existing breakpoint.
{        LENGTH: Optional, integer.
{          Specifies the number of bytes for which the breakpoint is valid.  The address plus the offset plus
{          the length - 1 yields the last byte address of the virtual memory address range.  This parameter is
{          optional when a new breakpoint is being established.  This parameter cannot be specified when
{          conditions are being added to an existing breakpoint.
{


{ SET_BREAKPOINTS parameter descriptor table:

  VAR
    brkpt_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 5] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'name    ', syc$name_value, * ],
{   } [TRUE, 2, 'cond    ', syc$name_value, * ],
{   } [FALSE, 3, 'base    ', syc$pointer_value, NIL],
{   } [FALSE, 4, 'offset  ', syc$integer_value, 0, 0, 7fffffff(16)],
{   } [FALSE, 5, 'length  ', syc$integer_value, 1, 1, 7fffffff(16)]];

  PROCEDURE set_breakpoint
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      str: string (60),

      dbl_p: ^debug_list,
      blank_name: [READ, STATIC] ost$name := '   ',
      pvt: array [1 .. 5] of syt$parameter_value,
      name_found: boolean,
      dbl_index: integer,
      cond_ord: debug_condition,
      cond_valid: boolean,
      lobyte: integer,
      hibyte: integer,
      i: integer,
      segnum: 0 .. 4095,
      debug_mask_reg: debug_mask,
      ucr_ord: ost$user_condition;

{ Crack the command.  Return if errors occur.

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (brkpt_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' SET BREAKPOINT ', text);
    IFEND;


{ Insure that the specified breakpoint name is not 8 blank characters.  Return an error code if it is.

    IF pvt [1].name = '        ' THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid_breakpoint_name', status);
      RETURN;
    IFEND;

{ Search the debug list for the command-specified breakpoint name.

    dbl_p := ^syv$debug_list;
    find_dbl_entry (pvt [1].name, dbl_index, name_found);

{ Test for command specification conflicts.

    IF (name_found = TRUE) AND (pvt [3].defined = TRUE) THEN
      osp$set_status_abnormal ('DB', dbe$, 'breakpoint_name_exists', status);
      RETURN;
    IFEND;
    IF (name_found = FALSE) AND (pvt [3].defined = FALSE) THEN
      osp$set_status_abnormal ('DB', dbe$, 'base_parameter_not_specd', status);
      RETURN;
    IFEND;

{ Validate the name of the specified breakpoint condition.

    validate_brkpt_condition (pvt [2].name, cond_ord, ucr_ord, cond_valid);
    IF cond_valid = FALSE THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid_breakpoint_cond', status);
      RETURN;
    IFEND;

{ At this point the problem is to either define a completely new breakpoint, or to select an additional
{ condition on an existing breakpoint.  The presence or the absence of a base PVA specification on the command
{ is used to make this determination:  the presence of the parameter signals a completely new breakpoint, its
{ absence signals an additional condition selection on an existing breakpoint.

    CASE pvt [3].defined OF

    = FALSE =

{ Select an additional condition on an existing breakpoint.

{ Test whether the specified condition is already selected.  Return if true.  (Actual selection of the
{ specified condition occurs later.)

      IF dbl_p^.sfwr_entry [dbl_index].condition [cond_ord] = TRUE THEN
        osp$set_status_abnormal ('DB', dbe$, 'condition_already_selected', status);
        RETURN;
      IFEND;

    = TRUE =

{ Establish a completely new breakpoint.
{ Find an available debug list entry.  Return if none are available.

      find_dbl_entry (blank_name, dbl_index, name_found);
      IF name_found = FALSE THEN
        osp$set_status_abnormal ('DB', dbe$, 'max_num_brkpts_already_set', status);
        RETURN;
      IFEND;

{ Construct the required debug list entries for the new breakpoint.  (Actual selection of the condition occurs
{ later).  Calculate address range and test validity.  Return if invalid.

      lobyte := #OFFSET (pvt [3].ptr);
      lobyte := lobyte + pvt [4].int;
      hibyte := (lobyte + pvt [5].int) - 1;
      IF ((lobyte < 0) OR (lobyte > 7fffffff(16))) OR ((hibyte < 0) OR (hibyte > 7fffffff(16))) OR
            (lobyte > hibyte) THEN
        osp$set_status_abnormal ('DB', dbe$, 'invalid_addrs_range', status);
        RETURN;
      IFEND;

      segnum := #SEGMENT (pvt [3].ptr);
      dbl_p^.sfwr_entry [dbl_index].segment := segnum;
      dbl_p^.sfwr_entry [dbl_index].lobyte := lobyte;
      dbl_p^.sfwr_entry [dbl_index].hibyte := hibyte;
      dbl_p^.sfwr_entry [dbl_index].name := pvt [1].name;

      dbl_p^.hdwr_entry [dbl_index].segment := segnum;
      dbl_p^.hdwr_entry [dbl_index].lobyte := lobyte;
      dbl_p^.hdwr_entry [dbl_index].hibyte := hibyte;

    CASEND;

{ Perform selection of the command_specified breakpoint condition.
{ Increment count of number of selections of the condition.

    dbl_p^.select_count [cond_ord] := dbl_p^.select_count [cond_ord] + 1;

{ Set debug list and hardware register condition bits.

    dbl_p^.sfwr_entry [dbl_index].condition [cond_ord] := TRUE;
    IF ucr_ord = osc$debug THEN
      dbl_p^.hdwr_entry [dbl_index].condition [cond_ord] := TRUE;
      debug_mask_reg.os_code := syv$debug_control.debug_mask;
      debug_mask_reg.condition [cond_ord] := TRUE;
      syv$debug_control.debug_mask := debug_mask_reg.os_code;
      dbl_p^.sfwr_entry [dbl_index].hscnt := dbl_p^.sfwr_entry [dbl_index].hscnt + 1;
      IF dbl_index > dbl_p^.eol_index THEN
        dbl_p^.hdwr_entry [dbl_index].eol := TRUE;
        IF dbl_p^.eol_index <> 0 THEN
          dbl_p^.hdwr_entry [dbl_p^.eol_index].eol := FALSE;
        IFEND;
        dbl_p^.eol_index := dbl_index;
        syv$debug_control.set_debug_bit_in_um := TRUE;
      IFEND;
      IF NOT tmv$tables_initialized THEN
        i := #READ_REGISTER (osc$pr_debug_mask_reg);
        debug_mask_reg.int := i;
        debug_mask_reg.condition [cond_ord] := TRUE;
        i := debug_mask_reg.int;
        #WRITE_REGISTER (osc$pr_debug_mask_reg, i);
        propagate_debug_mask_bit (TRUE);
      IFEND;
    IFEND;

{ Update debug control with new selected conditions.

    syv$debug_control.selected_ucr_conditions [ucr_ord] := TRUE;
    update_debug_masks;

  PROCEND set_breakpoint;
?? OLDTITLE ??
?? NEWTITLE := '  SETMSF_PROC', EJECT ??

{
{ Purpose:
{   This procedure processes the SET_MASS_STORAGE_FAULT command.  The command is used for internal
{ testing only.  For further information contact D. A. Henseler.
{


{ SET_MASS_STORAGE_FAULT parameter descriptor table:

  VAR
    setmsf_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 8] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'sfid    ', syc$integer_value, 0, 0, 07fffffff(16)],
{   } [FALSE, 2, 'skip_count', syc$integer_value, 0, 0, 07fffffff(16)],
{   } [FALSE, 3, 'count   ', syc$integer_value, 1, 0, 07fffffff(16)],
{   } [FALSE, 4, 'read_fault', syc$boolean_value, TRUE],
{   } [FALSE, 5, 'write_fault', syc$boolean_value, TRUE],
{   } [FALSE, 6, 'first_byte', syc$integer_value, 0, 0, 07fffffff(16)],
{   } [FALSE, 7, 'last_byte', syc$integer_value, 7fffffff(16), 0, 07fffffff(16)],
{   } [FALSE, 8, 'error_type', syc$name_value, 'DOWN']];

  PROCEDURE setmsf_proc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      locked: boolean,
      ls: ost$status,
      open: boolean,
      osv$disk_fault_simulation: [XREF] boolean,
      pvt: array [1 .. 8] of syt$parameter_value,
      sdf: ost$simulated_disk_fault,
      segment: ost$segment,
      sfid_converter: debug_sfid_converter;

    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (setmsf_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF NOT osv$disk_fault_simulation THEN
      RETURN;
    IFEND;

    sfid_converter.int := pvt [1].int;
    sdf.sfid := sfid_converter.sfid;
    sdf.direct_sfid := TRUE;

  /file_attached/
    BEGIN
      sdf.skip_count := pvt [2].int;
      sdf.count := pvt [3].int;
      sdf.read_fault := pvt [4].bool;
      sdf.write_fault := pvt [5].bool;
      sdf.first_byte := pvt [6].int;
      sdf.last_byte := pvt [7].int;
      IF pvt [8].name = 'MEDIA' THEN
        sdf.error_type := ioc$media_error;
      ELSEIF pvt [8].name = 'UNRECOVERED' THEN
        sdf.error_type := ioc$unrecovered_error;
      ELSE
        sdf.error_type := ioc$unrecovered_error_unit_down;
      IFEND;

      mmp$open_file_by_sfid (sdf.sfid, 3, 3, mmc$as_random, mmc$sar_write_extend,
            segment, status);
      IF NOT status.normal THEN
        EXIT /file_attached/;
      IFEND;

      mmp$free_pages (#ADDRESS (1, segment, 0), 7fffffff(16), osc$wait, status);
      IF NOT status.normal THEN
        mmp$close_device_file (segment, ls);
        EXIT /file_attached/;
      IFEND;

      mmp$close_device_file (segment, status);
      IF NOT status.normal THEN
        EXIT /file_attached/;
      IFEND;

      sdf.in_use := TRUE;
      osp$simulate_disk_fault_r1 (sdf, status);

    END /file_attached/;

  PROCEND setmsf_proc;
?? OLDTITLE ??
?? NEWTITLE := '  SETOD_PROC', EJECT ??

{
{ Purpose:
{   This procedure processes the SET_OUTPUT_DISPOSITION command.  It determines output destination for all
{ subsequent system core debugger subcommands. The parameters for the command are as follows:
{        DISPOSAL: Optional, name.
{          Specifies whether the output generated by subsequent subcommands should be displayed at the system
{          console, retained in the $SYSTEM.DUMPS catalog, automatically listed at a central site line
{          printer, or both.  The following values describe these respective options:
{          . CONSOLE or C
{          . RETAIN or R
{          . PRINTER or P
{          . RETAIN_AND_PRINTER or RAP
{          The default value for this parameter is RETAIN_AND_PRINTER.
{        TITLE: Optional, name.
{          Specifies a set of characters that appears on the first page of the printed output.  A string must
{          be enclosed in apostrophes.  The default is a blank string.
{


{ SET_OUTPUT_DESTINATION parameter descriptor table:

  VAR
    setod_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 2] of syt$parameter_descriptor := [
{   } [FALSE, 1, 'disposal', syc$name_value, 'RETAIN_AND_PRINTER'],
{   } [FALSE, 2, 'title   ', syc$string_value, [0, '']]];

  PROCEDURE setod_proc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      attributes: pmt$processor_attributes,
      date: ost$date,
      ignore_status: ost$status,
      length: integer,
      message: string (50),
      pvt: array [1 .. 2] of syt$parameter_value,
      serial_number: integer,
      serial_number_string: string (36),
      str1: string (60),
      str2: string (60),
      syv$job_template_name: [XREF] ost$name,
      time: ost$time,
      version: pmt$os_name,
      xcb_p: ^ost$execution_control_block;


    syp$crack_command (setod_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    str1 := ' System Core Debugger Dump';
    str2 := '   Output destination is ';
    IF (pvt [1].name = 'RETAIN_AND_PRINTER') OR (pvt [1].name = 'RAP') THEN
      setod_proc ('console', id, status);
      syv$debug_output_disposal_info.output_destination := syc$dod_save_and_print;
      str2 (26, * ) := 'RETAIN_AND_PRINTER';
    ELSEIF (pvt [1].name = 'RETAIN') OR (pvt [1].name = 'R') THEN
      setod_proc ('console', id, status);
      syv$debug_output_disposal_info.output_destination := syc$dod_save_on_pf;
      str2 (26, * ) := 'RETAIN';
    ELSEIF (pvt [1].name = 'PRINTER') OR (pvt [1].name = 'P') THEN
      setod_proc ('console', id, status);
      syv$debug_output_disposal_info.output_destination := syc$dod_write_for_print;
      str2 (26, * ) := 'PRINTER';
    ELSEIF (pvt [1].name = 'CONSOLE') OR (pvt [1].name = 'C') THEN
      syv$debug_output_disposal_info.output_destination := syc$dod_null;
      syv$db_displayed_console_lines := 0;
      syv$debug_line_count := 0;
      status.normal := TRUE;
      osp$end_text_dump;
      syv$dump_to_pf := FALSE;
      RETURN;
    ELSE
      osp$set_status_abnormal ('DB', dbe$, 'invalid output disposition selection', status);
      RETURN;
    IFEND;

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syv$debug_output_disposal_info.job_and_file_name := jmv$jcb.system_name;
    osp$begin_text_dump (status);
    IF status.normal THEN
      syv$dump_to_pf := TRUE;
      syp$write_output_header (str1, '');

      syp$write_output_line (str2, ignore_status);
      str2 := ' ';
      syp$write_output_line (str2, ignore_status);

      IF pvt [2].text.size <> 0 THEN
        syp$write_output_line (pvt [2].text.value (1, pvt [2].text.size), status);
      IFEND;

      pmp$find_executing_task_xcb (xcb_p);
      pmp$get_os_version (version, status);
      pmp$get_legible_date_time (osc$mdy_date, date, osc$hms_time, time, status);
      pmp$get_processor_attributes (attributes, status);
      serial_number := attributes.serial_number;

      message := '    ';
      syp$write_output_line (message, status);
      message := ' Unique characteristics of this dump: ';
      syp$write_output_line (message, status);
      message := '    ';
      message (5, * ) := 'OS Version: ';
      message (17, * ) := version;
      syp$write_output_line (message, status);
      message (5, * ) := 'Creation Date: ';
      message (20, * ) := date.mdy;
      syp$write_output_line (message, status);
      message (5, * ) := 'Creation Time: ';
      message (20, * ) := time.hms;
      syp$write_output_line (message, status);
      message (5, * ) := 'System Supplied Job Name: ';
      message (31, * ) := jmv$jcb.system_name;
      syp$write_output_line (message, status);
      message (5, * ) := 'User Supplied Job Name: ';
      message (29, * ) := jmv$jcb.jobname;
      syp$write_output_line (message, status);
      message (5, * ) := 'Task Name: ';
      message (16, * ) := xcb_p^.save9;
      syp$write_output_line (message, status);
      message (5, * ) := 'Serial Number: ';
      serial_number_string := '        ';
      STRINGREP (serial_number_string, length, serial_number);
      message (22, * ) := serial_number_string;
      syp$write_output_line (message, status);
      IF NOT syv$nosve_job_template THEN
        message (5, * ) := 'Job Template Name: ';
        message (24, * ) := syv$job_template_name;
        syp$write_output_line (message, status);
      IFEND;
      syp$write_output_line ('  ', status);
      status.normal := TRUE;
    IFEND;

  PROCEND setod_proc;
?? OLDTITLE ??
?? NEWTITLE := '  SETPW_PROC', EJECT ??

{
{ Purpose:
{   This procedure processes the SET_PAGE_WAIT command.  It sets the number of lines which will be displayed
{ on the console before waiting to continue the display.  The parameter for the command is as follows:
{        NUMBER: Required, integer.
{          Specifies the number of lines which are to be displayed on the system console before the display
{          waits to continue.  The default value of this parameter depends on the size of the debugger window
{          at the time the command is entered.  If the value specified for the parameter is zero (0) then page
{          wait is not in effect, and all output of a command will be displayed.
{


{ SET_PAGE_WAIT parameter descriptor table:

  VAR
    setpw_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 1] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'number  ', syc$integer_value, 0, 0, 07fffffffffffffff(16)]];

  PROCEDURE setpw_proc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      pvt: array [1 .. 1] of syt$parameter_value;


    syp$crack_command (setpw_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ Set ONLY this instance of SYSDEBUG page wait; the overall variable (syv$debugger_page_wait_lines) does not
{ change.

    syv$db_page_wait_lines_instance := pvt [1].int;

  PROCEND setpw_proc;
?? OLDTITLE ??
?? NEWTITLE := '  STACK_DISPLAY', EJECT ??

{
{ Purpose:
{   This procedure processes the DISPLAY_STACK_FRAME command.  It displays all or part of the information in a
{ specified stack frame. The parameters for the command are as follows:
{        STACK: Optional, integer.
{          Specifies the number of the stack frame for which the information is to be displayed.  Stack frame
{          number 1 is associated with the interrupted procedure, stack frame number 2 is associated with the
{          interrupted procedure's predecessor, and so on.  The default stack frame displayed is number 1.
{        SELECTOR: Optional, name.
{          Specifies how much of the selected stack frame is to be displayed.  The following
{          keywords can be specified:
{          . AUTO - Displays the memory contents of the specified stack frame.
{          . SAVE - Displays the contents of the save region of the specified stack frame.
{          . FULL - Displays the entire contents of the specified stack frame. This includes
{            information displayed for both AUTO and SAVE.
{          The default keyword is FULL.
{


{ DISPLAY_STACK_FRAME parameter descriptor table:

  VAR
    display_stk_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 2] of syt$parameter_descriptor := [
{   } [FALSE, 1, 'frame   ', syc$integer_value, 1, 1, 10000],
{   } [FALSE, 2, 'option  ', syc$name_value, 'FULL    ']];

  PROCEDURE stack_display
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      a_line: string (40),
      auto_line: string (42),
      auto_p: ^array [1 .. 1fffffff(16)] of 0 .. 0ffffffff(16),
      base_esa: stack_image_pointer,
      base_tosf: stack_image_pointer,
      blank: string (4),
      byte_count: integer,
      char_p: ^array [1 .. 7fffffff(16)] of char,
      cond_regs: condition_reg_image,
      i: integer,
      j: integer,
      k: integer,
      l: integer,
      last_r: integer,
      p_line: string (30),
      pvt: array [1 .. 2] of syt$parameter_value,
      save_hdr_line: string (9),
      segnum: 0 .. 4095,
      sf_id_line: string (34),
      str: string (60),
      trapped_sf: stack_image_pointer,
      um_line: string (31),
      x_line: string (48);

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    blank := '    ';

{ Crack the command.  Return if errors occur.

    syp$crack_command (display_stk_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY STACK ', text);
    IFEND;

{ Locate the stack frame associated with the trapped procedure.  If found, the stack frame is considered to be
{ stack frame number one.  If no stack frame is found, return an error code and exit immediately.

    find_trapped_stack_frame (trapped_sf.cell_p);
    IF trapped_sf.cell_p = NIL THEN
      osp$set_status_abnormal ('DB', dbe$, 'no_trap_has_occurred', status);
      RETURN;
    IFEND;

{ Locate the command-specified stack frame.  Return an error code if it does not exist.

    find_stack_frame (pvt [1].int, base_tosf.cell_p, base_esa.cell_p);
    IF base_esa.cell_p = NIL THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid_sf_specified', status);
      RETURN;
    IFEND;
    byte_count := #OFFSET (base_esa.cell_p) - #OFFSET (base_tosf.cell_p);

    IF (pvt [2].name (1, 4) <> 'FULL') AND (pvt [2].name (1, 4) <> 'AUTO') AND (pvt [2].name (1, 4) <>
          'SAVE') THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid_selector', status);
      RETURN;
    IFEND;

    sf_id_line := 'STACK FRAME 000        SEGMENT=000';
    hex_string (pvt [1].int, sf_id_line, 15);
    segnum := #SEGMENT (base_tosf.cell_p);
    hex_string (segnum, sf_id_line, 34);
    syp$write_output_line (sf_id_line, status);

    IF (pvt [2].name (1, 4) = 'FULL') OR (pvt [2].name (1, 4) = 'AUTO') THEN
      IF (base_tosf.pva.seg <> base_esa.pva.seg) OR (base_tosf.pva.ring <> base_esa.pva.ring) OR
            (base_tosf.pva.offset > base_esa.pva.offset) THEN
        syp$write_output_line ('Invalid frame a0, a1', status);
      ELSE
        auto_p := #LOC (base_tosf.cell_p^);
        char_p := #LOC (base_tosf.cell_p^);
        i := 1;
        WHILE i <= byte_count DIV 4 DO
          auto_line := '00000000    00000000  00000000            ';
          hex_string (4 * (i - 1), auto_line, 8);
          hex_string (auto_p^ [i], auto_line, 20);
          hex_string (auto_p^ [i + 1], auto_line, 30);
          l := 35;
          FOR j := (4 * i) - 3 TO ((4 * i) - 3) + 7 DO
            IF ($INTEGER (char_p^ [j]) >= 20(16)) AND ($INTEGER (char_p^ [j]) <= 7e(16)) THEN
              auto_line (l) := char_p^ [j];
            IFEND;
            l := l + 1;
          FOREND;
          syp$write_output_line (auto_line, status);
          i := i + 2;
        WHILEND;
      IFEND;
      syp$write_output_line (blank, status);
    IFEND;

    IF (pvt [2].name (1, 4) = 'FULL') OR (pvt [2].name (1, 4) = 'SAVE') THEN
      save_hdr_line := 'SAVE AREA';
      syp$write_output_line (save_hdr_line, status);

      syp$write_output_line (blank, status);

      p_line := 'P=0 000 00000000        VMID=0';
      hex_string (base_esa.control^.p_reg.pva.ring, p_line, 3);
      hex_string (base_esa.control^.p_reg.pva.seg, p_line, 7);
      hex_string (base_esa.control^.p_reg.pva.offset, p_line, 16);
      hex_string (base_esa.control^.vmid, p_line, 30);
      syp$write_output_line (p_line, status);

      um_line := 'UM=0000    UCR=0000    MCR=0000';
      cond_regs.ucr_a := base_esa.control^.user_condition;
      cond_regs.mcr_a := base_esa.control^.monitor_condition;
      cond_regs.ucm_a := base_esa.control^.user_condition_mask;
      hex_string (cond_regs.ucm_i, um_line, 7);
      IF base_esa.control^.frame_desc.a_terminate >= 5 THEN
        hex_string (cond_regs.ucr_i, um_line, 19);
        hex_string (cond_regs.mcr_i, um_line, 31);
      IFEND;
      syp$write_output_line (um_line, status);
      syp$write_output_line (blank, status);

      i := 0;
      last_r := base_esa.control^.frame_desc.a_terminate;
      WHILE i <= last_r DO
        a_line := 'A0=0 000 00000000      A0=0 000 00000000';
        hex_string (i, a_line, 2);
        hex_string (base_esa.aregs^.reg [i].pva.ring, a_line, 4);
        hex_string (base_esa.aregs^.reg [i].pva.seg, a_line, 8);
        hex_string (base_esa.aregs^.reg [i].pva.offset, a_line, 17);
        i := i + 1;
        IF i <= last_r THEN
          hex_string (i, a_line, 25);
          hex_string (base_esa.aregs^.reg [i].pva.ring, a_line, 27);
          hex_string (base_esa.aregs^.reg [i].pva.seg, a_line, 31);
          hex_string (base_esa.aregs^.reg [i].pva.offset, a_line, 40);
          syp$write_output_line (a_line, status);
          i := i + 1;
        ELSE
          syp$write_output_line (a_line (1, 17), status);
        IFEND;
      WHILEND;
      syp$write_output_line (blank, status);

      i := base_esa.control^.frame_desc.x_start;
      k := last_r + 1;
      last_r := base_esa.control^.frame_desc.x_terminate;
      WHILE i <= last_r DO
        x_line := 'X0=00000000  00000000      X0=00000000  00000000';
        hex_string (i, x_line, 2);
        hex_string (base_esa.xregs^.reg [k].lhalf, x_line, 11);
        hex_string (base_esa.xregs^.reg [k].rhalf, x_line, 21);
        i := i + 1;
        k := k + 1;
        IF i <= last_r THEN
          hex_string (i, x_line, 29);
          hex_string (base_esa.xregs^.reg [k].lhalf, x_line, 38);
          hex_string (base_esa.xregs^.reg [k].rhalf, x_line, 48);
          syp$write_output_line (x_line, status);
          i := i + 1;
          k := k + 1;
        ELSE
          syp$write_output_line (x_line (1, 21), status);
        IFEND;
      WHILEND;
    IFEND;
    RETURN;
  PROCEND stack_display;
?? OLDTITLE ??
?? NEWTITLE := '  SUBAUTOPROC', EJECT ??

{
{ Purpose:
{   This procedure a single command for the AUTO command.
{        COMMAND_TABLE_INDEX: A integer index into the auto_command list where the current AUTO subcommand
{          is found and which will be executed.
{

  PROCEDURE sub_autoproc
    (    command_table_index: integer);

    VAR
      ignore_status: ost$status;

?? NEWTITLE := '    SUBAUTOPROC - CH', EJECT ??

    PROCEDURE ch
      (    mf: ost$monitor_fault;
           ctc: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      VAR
        line_limit: string (80),
        s: string (60);

      s := ' An AUTO subcommand failed, continuing with next subcommand';
      line_limit := ' Line limit exceeded during subcommand, continuing with next subcommand';

      IF syv$terminate_sysdebug_output THEN

{ Messages have already been displayed.

        syv$terminate_sysdebug_output := FALSE;
        EXIT sub_autoproc;
      IFEND;

      IF NOT syv$dump_to_pf THEN
        IF syv$debug_line_count > syv$max_debug_output_lines THEN
          dpp$put_next_line (display_id, line_limit, ignore_status);
        ELSEIF (syv$db_page_wait_lines_instance <> 0) AND (syv$db_displayed_console_lines >=
              syv$db_page_wait_lines_instance) THEN

{ Messages have already been displayed.

          syv$db_displayed_console_lines := 0;
        ELSE
          dpp$put_next_line (display_id, s, ignore_status);
        IFEND;
      ELSE
        IF syv$debug_line_count > syv$max_debug_output_lines THEN
          osp$output_debug_text (^line_limit, ignore_status);
        ELSE
          osp$output_debug_text (^s, ignore_status);
        IFEND;
      IFEND;
      EXIT sub_autoproc;
    PROCEND ch;
?? OLDTITLE, EJECT ??

    syp$establish_condition_handler (^ch);
    syp$process_command_line (auto_cmds [command_table_index].command, ^command_table, display_id,
          ignore_status);
    IF NOT ignore_status.normal THEN
      dpp$put_next_line (display_id, 'Continuing AUTO command ...', ignore_status);
    IFEND;

  PROCEND sub_autoproc;
?? OLDTITLE ??
?? NEWTITLE := '  TRACE_BACK', EJECT ??

{
{ Purpose:
{   This procedure processes the DISPLAY_TRACE_BACK command.  It provides information relevant to stack frames
{ associated with the interrupted procedure and its predecessor procedures. The parameters for the command are
{ as follows:
{        START: Optional, integer.
{          Specifies the number of the first stack frame to be displayed.  Stack frame number 1 is associated
{          with the interrupted procedure, stack frame number 2 is associated with the interrupted procedure's
{          predecessor, and so on.  The default is 1.
{        COUNT: Optional, integer.
{          Specifies the number of stack frames to be displayed. The default is 1.
{        OPTION: Optional, name.
{          Specifies the amount of information to be displayed for each stack frame.  The following keywords
{          can be specified:
{          . SHORT - Display the module name and the P-address.
{          . FULL  - Display the module name, the P-address, and the PVAs pointing to the top of stack and the
{            current stack frame save area.
{          The default is FULL.
{        ADDRESS: Optional, pointer.
{          Specifies a stack frame's starting virtual memory address (as a PVA; a PVA is an 11-digit
{          hexadecimal number addressing a specific byte of memory).  If this parameter is specified, the
{          FRAME parameter is ignored.
{


{ DISPLAY_TRACE_BACK parameter descriptor table:

  VAR
    trace_back_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 4] of syt$parameter_descriptor := [
{   } [FALSE, 1, 'start   ', syc$integer_value, 1, 1, 10000],
{   } [FALSE, 2, 'count   ', syc$integer_value, 1, 1, 10000],
{   } [FALSE, 3, 'option  ', syc$name_value, 'FULL'],
{   } [FALSE, 4, 'address ', syc$pointer_value, NIL]];

  PROCEDURE trace_back
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      base_esa: stack_image_pointer,
      base_tosf: stack_image_pointer,
      bs_p: ^array [1 .. 10] of record
        fill1: 0 .. 0ffff(16),
        case 0 .. 1 of
        = 0 =
          ring: 0 .. 15,
        = 1 =
          name_p: ^string (31),
        casend,
      recend,
      crnt_sf_num: integer,
      f: boolean,
      i: integer,
      len: integer,
      line: string (80),
      mn: pmt$program_name,
      num_to_display: integer,
      ofs: ost$segment_offset,
      p: ^stack_frame_control_image,
      pvt: array [1 .. 4] of syt$parameter_value,
      savep: ^cell,
      sf_tosf: stack_image_pointer,
      sf_esa: stack_image_pointer,
      sn: pmt$program_name,
      str: string (60),
      trapped_sf: stack_image_pointer;

{ Crack the command.  Return if errors occur.

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (trace_back_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY TRACE BACK ', text);
    IFEND;

    savep := syv$debug_control.trapped_sfsa;
    IF pvt [4].ptr <> NIL THEN

{ Force the trace-back to start at a specific address.

      syv$debug_control.trapped_sfsa := pvt [4].ptr;
    IFEND;

{ Locate the stack frame associated with the trapped procedure.  If found, the stack frame is considered to be
{ stack frame number one.  If no stack frame is found, return an error code and exit immediately.

    find_trapped_stack_frame (trapped_sf.cell_p);
    IF trapped_sf.cell_p = NIL THEN
      osp$set_status_abnormal ('DB', dbe$, 'no_trap_has_occurred', status);
      syv$debug_control.trapped_sfsa := savep;
      RETURN;
    IFEND;

{ Locate the command-specified stack frame.  Return an error code if it does not exist.

    find_stack_frame (pvt [1].int, base_tosf.cell_p, base_esa.cell_p);
    IF base_esa.cell_p = NIL THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid_sf_specified', status);
      syv$debug_control.trapped_sfsa := savep;
      RETURN;
    IFEND;

    crnt_sf_num := pvt [1].int;
    num_to_display := pvt [2].int;
    sf_esa.cell_p := #LOC (sf_esa.cell_p);
    p := base_esa.cell_p;

    WHILE (num_to_display > 0) AND (sf_esa.cell_p <> NIL) DO
      verify_stack_frame (p, sf_tosf.cell_p, sf_esa.cell_p);
      IF sf_esa.cell_p <> NIL THEN
        IF (pvt [3].name = 'FULL') OR (pvt [1].int = crnt_sf_num) THEN
          line (1, 15) := 'STACK FRAME 000';
          syp$binary_to_ascii (crnt_sf_num, line, 10, 15);
          syp$write_output_line (line (1, 15), status);
        IFEND;
        line (1, 48) := 'P=0 000 00000000';
        hex_string (sf_esa.control^.p_reg.pva.ring, line, 3);
        hex_string (sf_esa.control^.p_reg.pva.seg, line, 7);
        hex_string (sf_esa.control^.p_reg.pva.offset, line, 16);
        syp$write_output_line (line (1, 48), status);
        ocp$find_debug_address (sf_esa.control^.p_reg.pva.seg, sf_esa.control^.p_reg.pva.offset, f, mn, sn,
              ofs, status);
        IF status.normal THEN
          IF f THEN
            STRINGREP (line, len, ' M=', mn, ' P=', sn, ' O=', ofs: #(16));
            syp$write_output_line (line (1, len), status);
          IFEND;
        ELSE
          status.normal := TRUE;
        IFEND;
        IF pvt [3].name = 'FULL' THEN
          line (1, 48) := 'STACK=0 000 00000000    SAVE AREA=0 000 00000000';
          hex_string (sf_tosf.pva.ring, line, 7);
          hex_string (sf_tosf.pva.seg, line, 11);
          hex_string (sf_tosf.pva.offset, line, 20);
          hex_string (sf_esa.pva.ring, line, 35);
          hex_string (sf_esa.pva.seg, line, 39);
          hex_string (sf_esa.pva.offset, line, 48);
          syp$write_output_line (line (1, 48), status);
        IFEND;
        num_to_display := num_to_display - 1;
        crnt_sf_num := crnt_sf_num + 1;
        p := sf_esa.cell_p;
        p := p^.psa;
      IFEND;
    WHILEND;
    syv$debug_control.trapped_sfsa := savep;
  PROCEND trace_back;
?? OLDTITLE ??
?? NEWTITLE := '  UP_VOLUME', EJECT ??

{ Purpose:
{   This procedure processes the UP_VOLUME command.  This will allow use of the specified volume number.  The
{   parameter for the command is as follows:
{        NUMBER: Required, integer.
{          Specifies the active volume table index of the volume which is to be UPped.
{

  PROCEDURE up_volume
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      avti: dmt$active_volume_table_index,
      pvt: array [1 .. 1] of syt$parameter_value;

    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (down_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    avti := pvt [1].int;

    IF dmv$p_active_volume_table^ [avti].mass_storage.volume_unavailable = FALSE THEN

{ Ignore the request - the volume is already up.

      RETURN;
    IFEND;

    dmv$number_unavailable_volumes := dmv$number_unavailable_volumes - 1;
    dmv$p_active_volume_table^ [avti].mass_storage.volume_unavailable := FALSE;
    dmv$p_active_volume_table^ [avti].mass_storage.allocation_allowed :=
          dmv$p_active_volume_table^ [avti].mass_storage.previous_allocation_allowed;

  PROCEND up_volume;
?? OLDTITLE ??
?? NEWTITLE := '  UPDATE_DEBUG_MASKS', EJECT ??

{
{ Purpose:
{   This procedure makes a monitor request to update a job's task(s)'s  debug mask(s) when a breakpoint is
{ added, deleted, or changed, or when a SELECT command has been invoked.
{

  PROCEDURE update_debug_masks;

    VAR
      update_debug_rb: tmt$rb_update_job_task_enviro;

    update_debug_rb.reqcode := syc$rc_update_job_task_enviro;
    update_debug_rb.subcode := tmc$ujte_update_debug_masks;
    i#call_monitor (#LOC (update_debug_rb), #SIZE (update_debug_rb));

  PROCEND update_debug_masks;
?? OLDTITLE ??
?? NEWTITLE := '  VALIDATE_BRKPT_CONDITION', EJECT ??

{
{ Purpose:
{   This procedure validates a requested breakpoint condition by comparing its name to the names found in the
{ condition conversion table.  If the name is found in the table, the condition name is valid.
{        COND_NAME: The name of the condition to be validated.
{        COND_ORD: The ordinal of the condition if it is found in the condition conversion table.
{        UCR_ORD: The ordinal of the user condition if the condition is found in the condition conversion
{          table.
{        CONDITION_VALID: A boolean returned describing whether or not the condition was found in the
{          condition conversion table.
{

  PROCEDURE validate_brkpt_condition
    (    cond_name: ost$name;
     VAR cond_ord: debug_condition;
     VAR ucr_ord: ost$user_condition;
     VAR condition_valid: boolean);

    VAR
      i: debug_condition;

    i := dc_read;
    WHILE i <= dc_invbdp DO
      IF cond_name = cond_conv_tbl [i].name THEN
        cond_ord := cond_conv_tbl [i].c_ord;
        ucr_ord := cond_conv_tbl [i].ucr_ord;
        condition_valid := TRUE;
        RETURN;
      ELSE
        i := SUCC (i);
      IFEND;
    WHILEND;
    condition_valid := FALSE;
    RETURN;
  PROCEND validate_brkpt_condition;
?? OLDTITLE ??
?? NEWTITLE := '  VERIFY_STACK_FRAME', EJECT ??

{
{ Purpose:
{   This procedure assists the DISPLAY_TRACE_BACK command and the procedure SYP$MFH_FOR_KEYPOINT_TRACEBACK.
{ It verifies that the stack frame may be accessed in write-mode and returns pointers to the current stack
{ frame and the stack frame save area for the stack frame in question.
{        CP: A pointer the stack frame which must be verified.
{        CSF_P: A pointer to the current stack frame if the stack frame is valid.
{        SA_P: A pointer to the stack frame save area if the stack frame is valid.
{

  PROCEDURE verify_stack_frame
    (    cp: ^stack_frame_control_image;
     VAR csf_p: ^cell;
     VAR sa_p: ^cell);

    VAR
      p: ^stack_frame_control_image,
      status: ost$status;

    p := cp;
    IF p <> NIL THEN
      syp$verify_access (syc$writeable, #LOC (p^.csf), status);
      IF NOT status.normal THEN
        csf_p := NIL;
      ELSE
        csf_p := p^.csf;
      IFEND;
      sa_p := p;
    ELSE
      csf_p := NIL;
      sa_p := NIL;
    IFEND;

  PROCEND verify_stack_frame;
?? OLDTITLE ??
?? NEWTITLE := '  XQAUTOPROC', EJECT ??
{
{ Purpose:
{   This procedure processes the AUTO command.  It forces a dump of the job and task environment by executing
{ the entire auto dump command list.  The parameter for the command is as follows:
{        DISPOSAL: Optional, name.
{          Specifies whether the output generated by subsequent subcommands should be displayed at the system
{          console, retained in the $SYSTEM.DUMPS catalog, automatically listed at a central site line
{          printer, or both.  The following values describe these respective options:
{          . DEFAULT or D: Uses default_debug_output_disposal system attribute (if set), or RAP if not set
{          . CONSOLE or C
{          . RETAIN or R
{          . PRINTER or P
{          . RETAIN_AND_PRINTER or RAP
{          The default value for this parameter is RETAIN_AND_PRINTER.
{


{ AUTO parameter descriptor table:

  VAR
    auto_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 1] of syt$parameter_descriptor := [
{   } [FALSE, 1, 'disposal', syc$name_value, 'DEFAULT']];

  PROCEDURE xqtautoproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      pvt: array [1 .. 1] of syt$parameter_value,
      saved_output_disposition: syt$debug_output_disposition,
      str: string (60);

    IF NOT mmv$tables_initialized THEN
      osp$set_status_abnormal ('DB', dbe$, 'invalid request', status);
      RETURN;
    IFEND;

    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    syp$crack_command (auto_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    saved_output_disposition := syv$debug_output_disposal_info.output_destination;
    IF (pvt [1].name = 'DEFAULT') OR (pvt [1].name = 'D') THEN
      IF saved_output_disposition = syc$dod_null THEN
        setod_proc ('retain_and_printer '' Automatic Task Dump ''', display_id, status);
      ELSEIF saved_output_disposition = syc$dod_write_for_print THEN
        setod_proc ('printer '' Automatic Task Dump ''', display_id, status);
      ELSEIF saved_output_disposition = syc$dod_save_on_pf THEN
        setod_proc ('retain '' Automatic Task Dump ''', display_id, status);
      ELSEIF saved_output_disposition = syc$dod_save_and_print THEN
        setod_proc ('retain_and_printer '' Automatic Task Dump ''', display_id, status);
      ELSE {should not happen}
        osp$set_status_abnormal ('DB', dbe$, 'Unknown output disposition attribute for AUTO command', status);
        RETURN;
      IFEND;
    ELSEIF (pvt [1].name = 'RETAIN_AND_PRINTER') OR (pvt [1].name = 'RAP') THEN
      setod_proc ('retain_and_printer '' Automatic Task Dump ''', display_id, status);
    ELSEIF (pvt [1].name = 'RETAIN') OR (pvt [1].name = 'R') THEN
      setod_proc ('retain '' Automatic Task Dump ''', display_id, status);
    ELSEIF (pvt [1].name = 'PRINTER') OR (pvt [1].name = 'P') THEN
      setod_proc ('printer '' Automatic Task Dump ''', display_id, status);
    ELSEIF (pvt [1].name = 'CONSOLE') OR (pvt [1].name = 'C') THEN
      osp$set_status_abnormal ('DB', dbe$, 'AUTO cannot display output to console', status);
      RETURN;
    ELSE
      osp$set_status_abnormal ('DB', dbe$, 'Unknown output disposition for AUTO command', status);
      RETURN;
    IFEND;

    autoproc ({dump segments 3,4,6 =} TRUE, FALSE, status);
    dpp$put_next_line (display_id, 'AUTO command dump complete.', status);

    IF saved_output_disposition = syc$dod_save_and_print THEN
      setod_proc ('retain_and_printer ', display_id, status);
    ELSEIF saved_output_disposition = syc$dod_save_on_pf THEN
      setod_proc ('retain ', display_id, status);
    ELSEIF saved_output_disposition = syc$dod_write_for_print THEN
      setod_proc ('printer ', display_id, status);
    ELSEIF saved_output_disposition = syc$dod_null THEN
      setod_proc ('console', display_id, status);
    IFEND;

  PROCEND xqtautoproc;
?? OLDTITLE ??
?? NEWTITLE := '  SYP$CONVERT_BYTES', EJECT ??
{
{ Purpose:
{   This procedure converts a portion of memory into a string representation of that memory and returns it in
{ in a specified string.  Optionally, it can return the string representation at the end of a non-empty
{ string by separating the original string from the converted value with a space character.
{        P: A pointer to a packed array of hexidecimal digits which will be converted to characters for
{          display.
{        LENGTH: An integer value which specifies the maximum index of the packed array which must be
{          converted.
{        MSG: An adaptable string which will contain the converted packed array.
{        ADD_TO_EOL: A boolean which determines whether or not the memory conversion should be appended at the
{          end of the existing string contained in the MSG parameter.
{

  PROCEDURE [XDCL] syp$convert_bytes
    (    p: ^packed array [1 .. 1000] of 0 .. 0f(16);
         length: integer;
     VAR msg: string ( * );
         add_to_eol: boolean);

    VAR
      ch: integer,
      eol: integer,
      i: integer;

{ Find the end-of-line of the input string.

    eol := 1;

    IF add_to_eol THEN

    /find_eol/
      FOR i := STRLENGTH (msg) DOWNTO 1 DO
        IF msg (i) <> ' ' THEN
          eol := i + 2;
          EXIT /find_eol/;
        IFEND;
      FOREND /find_eol/;
    IFEND;

    IF eol > STRLENGTH (msg) THEN
      RETURN;
    IFEND;

    FOR i := 1 TO (length * 2) DO
      ch := p^ [i];
      IF ch < 0a(16) THEN
        msg (eol) := $CHAR (ch + $INTEGER ('0'));
      ELSE
        msg (eol) := $CHAR (ch + $INTEGER ('A') - 0a(16));
      IFEND;
      eol := eol + 1;
      IF eol > STRLENGTH (msg) THEN
        RETURN;
      IFEND;
    FOREND;

  PROCEND syp$convert_bytes;
?? OLDTITLE ??
?? NEWTITLE := '  SYP$INITIALIZE_JT_PTR_ARRAY', EJECT ??

{
{ Purpose:
{   This procedure will initialize the (job fixed) data structures used by the system core
{   debugger to access job template data structures.
{

  PROCEDURE [XDCL, #GATE] syp$initialize_jt_ptr_array
    (    template_debug_pointers: ^array [1 .. * ] of ^cell);

    IF template_debug_pointers = NIL THEN
      RETURN;
    IFEND;
    IF syv$nosve_job_template THEN
      ALLOCATE syv$job_template_ptr_array: [1 .. UPPERBOUND (template_debug_pointers^)] IN
            osv$mainframe_pageable_heap^;
      nosve_template_ptr_array := syv$job_template_ptr_array;
    ELSE
      ALLOCATE syv$job_template_ptr_array: [1 .. UPPERBOUND (template_debug_pointers^)] IN
            osv$job_fixed_heap^;
    IFEND;
    IF syv$job_template_ptr_array <> NIL THEN
      syv$job_template_ptr_array^ := template_debug_pointers^;
    IFEND;

{ Changes the ring numbers associated with the local and global log control descriptor arrays to allow write
{ access to the log control descriptors.  This is needed to allow the system core debugger to use the logging
{ interfaces that need to interlock the logs (and thus write to the log control descriptors).

    syv$job_template_ptr_array^ [1] := #ADDRESS (osc$tmtr_ring, #SEGMENT (syv$job_template_ptr_array^ [1]),
          #OFFSET (syv$job_template_ptr_array^ [1]));
    syv$job_template_ptr_array^ [2] := #ADDRESS (osc$os_ring_1, #SEGMENT (syv$job_template_ptr_array^ [2]),
          #OFFSET (syv$job_template_ptr_array^ [2]));

  PROCEND syp$initialize_jt_ptr_array;
?? OLDTITLE ??
?? NEWTITLE := '  SYP$INVOKE_SYSTEM_DEBUGGER', EJECT ??

{
{ Purpose:
{   This procedure invokes the system core debugger.  The parameters for the procedure are as follows:
{        TEXT: Not used.
{        ID: Specifies the window which will be used on the system console for the debugger display.
{        STATUS: VAR of ost$status.
{

  PROCEDURE [XDCL, #GATE] syp$invoke_system_debugger
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      i: integer,
      normal: boolean,
      old_te: 0 .. 3,
      sa_p: ^stack_frame_control_image;

    IF avv$security_options [avc$vso_secure_analysis].active THEN
      dpp$put_critical_message ('SYSDEBUG call ignored, it was disabled at deadstart.', {ignore} status);
      status.normal := TRUE;
      RETURN;
    IFEND;

    i#disable_traps (old_te);
    sa_p := #PREVIOUS_SAVE_AREA ();

{ Initiate debug command processing.

    process_commands (sa_p^.psa, 'command ', '  ', FALSE, status);

    i#restore_traps (old_te);

  PROCEND syp$invoke_system_debugger;
?? OLDTITLE ??
?? NEWTITLE := '  SYP$MFH_FOR_DUMP_JOB', EJECT ??

{
{ Purpose:
{   This procedure is the flag handler for the DUMPJOB flag, which is set by the DUMPJOB command.
{

  PROCEDURE [XDCL] syp$mfh_for_dump_job;

    VAR
      i: integer,
      normal: boolean,
      old_te: 0 .. 3,
      sa_p: ^stack_frame_control_image,
      status: ost$status;

    IF avv$security_options [avc$vso_secure_analysis].active THEN
      dpp$put_critical_message ('DUMP JOB call ignored, it was disabled at deadstart.', {ignore} status);
      RETURN;
    IFEND;

    i#disable_traps (old_te);
    sa_p := #PREVIOUS_SAVE_AREA ();

{ Initiate debug command processing.

    process_commands (sa_p^.psa, 'command ', '  ', TRUE, status);

    i#restore_traps (old_te);

  PROCEND syp$mfh_for_dump_job;
?? OLDTITLE ??
?? NEWTITLE := '  SYP$MFH_FOR_KEYPOINT_TRACEBACK', EJECT ??

{
{ Purpose:
{   This procedure is the flag handler for the INVOKE KEYPOINT TRACEBACK flag.  It displays a trace-back of
{ the task into the keypoint buffer for later analysis.
{

  PROCEDURE [XDCL] syp$mfh_for_keypoint_traceback;

    VAR
      base_esa: stack_image_pointer,
      base_tosf: stack_image_pointer,
      lock: [STATIC] ost$signature_lock,
      p: ^stack_frame_control_image,
      savep: ^stack_frame_control_image,
      sf_esa: stack_image_pointer,
      sf_tosf: stack_image_pointer,
      status: ost$status;


    savep := #PREVIOUS_SAVE_AREA ();
    savep := savep^.psa;

{ Locate the first stack frame.  Return if it does not exist.

    syp$verify_access (syc$writeable, #LOC (savep^.csf), status);
    IF NOT status.normal THEN
      base_tosf.cell_p := NIL;
    ELSE
      base_tosf.cell_p := savep^.csf;
    IFEND;
    base_esa.cell_p := savep;
    sf_esa.cell_p := #LOC (sf_esa.cell_p);
    p := base_esa.cell_p;

    osp$set_signature_lock (lock, osc$wait, status);
    #KEYPOINT (osk$performance, osk$m * (jmv$jcb.ijl_ordinal.block_number *
          32 + jmv$jcb.ijl_ordinal.block_index), ptk$stack_ijl_ordinal);
    WHILE sf_esa.cell_p <> NIL DO
      verify_stack_frame (p, sf_tosf.cell_p, sf_esa.cell_p);
      IF sf_esa.cell_p <> NIL THEN
        #KEYPOINT (osk$performance, osk$m * sf_esa.control^.p_reg.pva.seg, ptk$stack_p_segment);
        #KEYPOINT (osk$performance, osk$m * (sf_esa.control^.p_reg.pva.offset DIV 100000(16)),
              ptk$stack_p_upper_offset);
        #KEYPOINT (osk$performance, osk$m * (sf_esa.control^.p_reg.pva.offset MOD 100000(16)),
              ptk$stack_p_lower_offset);
        #KEYPOINT (osk$performance, osk$m * sf_tosf.pva.seg, ptk$stack_tos_segment);
        #KEYPOINT (osk$performance, osk$m * (sf_tosf.pva.offset DIV 100000(16)), ptk$stack_tos_upper_offset);
        #KEYPOINT (osk$performance, osk$m * (sf_tosf.pva.offset MOD 100000(16)), ptk$stack_tos_lower_offset);
        #KEYPOINT (osk$performance, osk$m * sf_esa.pva.seg, ptk$stack_esa_segment);
        #KEYPOINT (osk$performance, osk$m * (sf_esa.pva.offset DIV 100000(16)), ptk$stack_esa_upper_offset);
        #KEYPOINT (osk$performance, osk$m * (sf_esa.pva.offset MOD 100000(16)), ptk$stack_esa_lower_offset);
        p := sf_esa.cell_p;

{ This p must be verified before it can be de-referenced.

        verify_stack_frame (p, sf_tosf.cell_p, sf_esa.cell_p);
        p := p^.psa;
      IFEND;
    WHILEND;

{ The following keypoint identifies the end of a stack frame trace.

    #KEYPOINT (osk$performance, 0, ptk$end_of_stack_trace);
    osp$clear_signature_lock (lock, status);

  PROCEND syp$mfh_for_keypoint_traceback;
?? OLDTITLE ??
?? NEWTITLE := '  SYP$MFH_FOR_SYSTEM_DEBUG', EJECT ??

  PROCEDURE [XDCL] syp$mfh_for_system_debug;

    VAR
      bit_value: boolean,
      dlp: debug_list_pointer,
      dm: debug_mask,
      null_debug_mask: [STATIC, READ] ost$debug_mask := [FALSE, FALSE, [REP 5 of FALSE]],
      sa_p: ^stack_frame_control_image;

    IF (jmv$jcb.ijle_p^.system_breakpoint_selected) AND (syv$debug_control.set_debug_bit_in_um) THEN
      dlp.cell_p := syv$debug_control.debug_list_p;
      dm.os_code := syv$debug_control.debug_mask;
    ELSE
      dlp.cell_p := NIL;
      dm.os_code := null_debug_mask;
    IFEND;

    #WRITE_REGISTER (osc$pr_debug_list_pointer, dlp.int);
    #WRITE_REGISTER (osc$pr_debug_mask_reg, dm.int);

    sa_p := #PREVIOUS_SAVE_AREA ();
    bit_value := (#READ_REGISTER (osc$pr_debug_mask_reg) <> 0);
    propagate_debug_mask_bit (bit_value);
  PROCEND syp$mfh_for_system_debug;
?? OLDTITLE ??
?? NEWTITLE := '  SYP$MFH_TO_INVOKE_SYSDEBUG', EJECT ??

{
{ Purpose:
{   This procedure is the flag handler for the SYSDEBUG flag.  It invokes the system core debugger on the task
{ which executes the procedure.
{

  PROCEDURE [XDCL] syp$mfh_to_invoke_sysdebug;

    VAR
      status: ost$status;

    syp$invoke_system_debugger ('', display_id, status);

  PROCEND syp$mfh_to_invoke_sysdebug;
?? OLDTITLE ??
?? NEWTITLE := '  SYP$VERIFY_ACCESS', EJECT ??
{
{ Purpose:
{   This procedure verifies that access can be made to a segment in an expected manner (ring <> 0, segment
{ number within the address space of the task, valid segment, readable and able to read at this ring number,
{ writeable and able to write at this ring number, non-negative offset, and offset within segment length).
{        ACCESS_TYPE: Specifies the type of access which is expected for the segment specified in the second
{          parameter
{        CELL_PP: A pointer to a pointer which will be verified for correct access
{        STATUS: VAR of ost$status.
{

  PROCEDURE [XDCL] syp$verify_access
    (    access_type: (syc$readable, syc$writeable);
         cell_pp: ^^cell;
     VAR status: ost$status);

    VAR
      cell_p: ^cell,
      pva_p: ^ost$pva,
      sdte_p: ^mmt$segment_descriptor,
      sl: integer,
      ste: ost$segment_descriptor,
      xcbp: ^ost$execution_control_block;

    pva_p := #LOC (cell_pp^);
    IF pva_p^.ring = 0 THEN
      osp$set_status_abnormal ('DB', dbe$, 'Ring zero', status);
      RETURN;
    IFEND;
    cell_p := cell_pp^;

    pmp$find_executing_task_xcb (xcbp);
    IF #SEGMENT (cell_p) > xcbp^.xp.segment_table_length THEN
      osp$set_status_abnormal ('DB', dbe$, 'segment too big', status);
      RETURN;
    IFEND;

    sdte_p := mmp$get_sdt_entry_p (xcbp, #SEGMENT (cell_p));
    ste := sdte_p^.ste;

    IF ste.vl = osc$vl_invalid_entry THEN
      osp$set_status_abnormal ('DB', dbe$, 'segment not in use', status);
      RETURN;
    IFEND;

    CASE access_type OF
    = syc$readable =
      IF ste.rp = osc$non_readable THEN
        osp$set_status_abnormal ('DB', dbe$, 'segment not readable', status);
        RETURN;
      IFEND;
      IF ste.r2 < #RING (cell_p) THEN
        osp$set_status_abnormal ('DB', dbe$, 'segment R2 lt p-ring', status);
        RETURN;
      IFEND;

    = syc$writeable =
      IF ste.wp = osc$non_writable THEN
        osp$set_status_abnormal ('DB', dbe$, 'segment not writeable', status);
        RETURN;
      IFEND;
      IF ste.r1 < #RING (cell_p) THEN
        osp$set_status_abnormal ('DB', dbe$, 'segment R1 lt p-ring', status);
        RETURN;
      IFEND;
    CASEND;

    IF #OFFSET (cell_p) < 0 THEN
      osp$set_status_abnormal ('DB', dbe$, 'verify pva negative offset', status);
      RETURN;
    IFEND;
    get_segment_length (cell_p, sl);
    IF #OFFSET (cell_p) >= sl THEN
      osp$set_status_abnormal ('DB', dbe$, 'verify pva offset > segl & read only', status);
      RETURN;
    IFEND;

    status.normal := TRUE;
  PROCEND syp$verify_access;
?? OLDTITLE ??
?? NEWTITLE := '  SYP$WRITE_OUTPUT_HEADER', EJECT ??

{
{ Purpose:
{   This procedure writes a string to the buffer which is accessed by the partner Broken_Dump_Task for further
{ disposition.  It checks for timeouts when displaying output that is not destined for the console.
{        TITLE_PART_1: The first part of the header string which is to be written to the output buffer.
{        TITLE_PART_2: The last part of the header string which is to be written to the output buffer.
{

  PROCEDURE [XDCL] syp$write_output_header
    (    title_part_1: string ( * );
         title_part_2: string ( * ));

    CONST
      c$max_header_length = 60;

    VAR
      header: string (c$max_header_length),
      ignore_status: ost$status,
      length: integer,
      status: ost$status,
      text: string (80);


    status.normal := TRUE;
    IF syv$dump_to_pf THEN
      length := STRLENGTH (title_part_1);
      header := title_part_1;
      IF length < c$max_header_length THEN
        header (length + 1, *) := title_part_2;
      IFEND;
      osp$output_debug_heading (^header, status);
      IF NOT status.normal THEN
        STRINGREP (text, length, 'status.condition = ', status.condition: #(16));
        dpp$put_next_line (display_id, text (1, length), ignore_status);
        syv$debugger_task_timeout := TRUE;
        syp$cause_condition (syc$udc_debugger_task_timeout);
      IFEND;
    IFEND;

  PROCEND syp$write_output_header;
?? OLDTITLE ??
?? NEWTITLE := '  SYP$WRITE_OUTPUT_LINE', EJECT ??

{
{ Purpose:
{   This procedure writes a string to the buffer which is accessed by the partner Broken_Dump_Task for further
{ disposition.  It checks for output line limits, timeouts, and page_wait when displaying output to the
{ console.
{        S: The string which is to be written to the output buffer.
{        STATUS: VAR of ost$status.
{

  PROCEDURE [XDCL] syp$write_output_line
    (    s: string ( * );
     VAR status: ost$status);

    VAR
      ignore_status: ost$status,
      length: integer,
      line_received: boolean,
      text: string (80);


    status.normal := TRUE;

    IF syv$terminate_sysdebug_output THEN
      dpp$put_next_line (display_id, 'Display terminated.', status);
      syp$cause_condition (syc$udc_display_cmnd_terminated);
    IFEND;

    IF syv$debug_output_disposal_info.output_destination <> syc$dod_null THEN

{ Send the output line to the appropriate destination(s):
{ Retain on a permanent file and/or send to the printer.

      syv$debug_line_count := syv$debug_line_count + 1;
      IF syv$debug_line_count > syv$max_debug_output_lines THEN
        syp$cause_condition (syc$udc_max_debug_output_lines);
      IFEND;
      osp$output_debug_text (^s, status);
      IF NOT status.normal THEN
        STRINGREP (text, length, 'status.condition = ', status.condition: #(16));
        dpp$put_next_line (display_id, text (1, length), ignore_status);
        syv$debugger_task_timeout := TRUE;
        syp$cause_condition (syc$udc_debugger_task_timeout);
      IFEND;
    ELSE

{ Send to the system console.

      dpp$put_next_line (display_id, s, status);
      syv$db_displayed_console_lines := syv$db_displayed_console_lines + 1;
      IF (syv$db_page_wait_lines_instance <> 0) AND (syv$db_displayed_console_lines >=
            syv$db_page_wait_lines_instance) THEN
        dpp$put_next_line (display_id, '<OVER>', status);
        status.normal := TRUE;
        dpp$get_next_line (display_id, osc$wait, text, line_received);
        IF text = '' THEN
          syv$db_displayed_console_lines := 0;
          RETURN;
        ELSE
          syv$terminate_sysdebug_output := TRUE;
          dpp$put_next_line (display_id, 'Display terminated.', status);
          syp$cause_condition (syc$udc_display_cmnd_terminated);
        IFEND;
      IFEND;
      status.normal := TRUE;
    IFEND;

  PROCEND syp$write_output_line;
??EJECT??

VAR
    setdcl_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 1] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'number', syc$integer_value, 1, 1, dbc$max_auto_cmds]];

VAR
    disdcl_pdt: [READ, oss$mainframe_paged_literal] array [1 .. 1] of syt$parameter_descriptor := [
{   } [TRUE, 1, 'number', syc$integer_value, 1, 1, dbc$max_auto_cmds]];


  PROCEDURE disdclproc (text: string ( * );
        id: dpt$window_id;
    VAR status: ost$status);

    VAR
      msg: string (50),
      ii: integer,
      str: string (60),
      i: integer;

    syv$debug_line_count := 0;
    IF syv$dump_to_pf THEN
      str := ' DISPLAY AUTO COMMAND LIST ';
      str (28, * ) := text;
      osp$output_debug_heading (^str, status);

      IF NOT status.normal THEN
        RETURN;
      IFEND;

    IFEND;


    i := 1;
    WHILE auto_cmds [i].command <> '   ' DO
      msg := '   ';
      STRINGREP (msg, ii, ' ', i, ': ');
      msg (7, * ) := auto_cmds [i].command;
      syp$write_output_line (msg, status);
      i := i + 1;
    WHILEND;
    status.normal := TRUE;
  PROCEND disdclproc;
?? EJECT ??

  PROCEDURE setdclproc (text: string ( * );
        id: dpt$window_id;
    VAR status: ost$status);

    VAR
      i,
      j: integer,
      state: (s1, s2),
      str: string (60),
      pvt: array [1 .. 1] of syt$parameter_value,
      sss: string (dbc$max_auto_cmd_length);


    syv$debug_line_count := 0;
    syp$crack_command (setdcl_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    IF syv$dump_to_pf THEN
      str := ' SET AUTO COMMAND LIST ';
      str (26, * ) := text;
      osp$output_debug_heading (^str, status);

      IF NOT status.normal THEN
        RETURN;
      IFEND;

    IFEND;

    status.normal := TRUE;
    sss := '   ';
    state := s1;
    j := 1;
    FOR i := 1 TO STRLENGTH (text) DO
      CASE state OF
      = s1 =
        IF text (i) = '''' THEN
          state := s2;
        IFEND;
      = s2 =
        IF j > dbc$max_auto_cmd_length THEN
          osp$set_status_abnormal ('DB', dbe$, 'command too long', status);
          RETURN;
        IFEND;
        IF text (i) = '''' THEN
          auto_cmds [pvt [1].int].command  := sss;
          auto_cmds [pvt [1].int].jobmntr_execution_only := FALSE;
          RETURN;
        ELSE
          sss (j) := text (i);
          j := j + 1;
        IFEND;
      CASEND;
    FOREND;
    osp$set_status_abnormal ('DB', dbe$, 'no end of cmd', status);
  PROCEND setdclproc;










?? OLDTITLE, OLDTITLE ??
MODEND sym$debug;
*DECK DECK=SYM$DEBUG1 EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE System Core Debugger: Display Job Tables command' ??
MODULE sym$debug1;
{
{ PURPOSE:
{   This module contains the processor for the subcommand DISPLAY_JOB_TABLES of the System Core Debugger
{   utility.
{
{ NOTE:
{   Additions/deletions/changes to the commands and displays in this module and SYM$DEBUG may require an
{   update to the System Performance and Analysis Manual, Volume 2 (SPAM).
{
??  PUSH (LISTEXT := ON) ??
*copyc amc$condition_code_limits
*copyc ame$lfn_program_actions
*copyc cle$ecc_lexical
*copyc cmt$logical_unit_table
*copyc dmt$active_volume_table
*copyc dmt$system_tape_table
*copyc dpt$window_id
*copyc fmt$cycle_description
*copyc fmt$path_description_entry
*copyc fmt$path_description_unit
*copyc fmt$path_handle
*copyc fsc$max_path_size
*copyc lgt$log_read_activity
*copyc lot$loader_type_definitions
*copyc lot$task_services_entry_point
*copyc mmd$segment_access_condition
*copyc osc$processor_defined_registers
*copyc osc$purge_map_and_cache
*copyc osd$conditions
*copyc osd$integer_limits
*copyc osd$registers
*copyc osd$virtual_address
*copyc oss$job_fixed
*copyc oss$mainframe_pageable
*copyc oss$mainframe_paged_literal
*copyc ost$caller_identifier
*copyc ost$execution_control_block
*copyc ost$processor_id
*copyc ost$status
*copyc ost$string
*copyc pmd$system_log_interface
*copyc pmt$processor_attributes
*copyc rmc$highest_unit_type
*copyc syt$debug_control
*copyc syt$value_kinds
*copyc tmt$broken_task_monitor_fault
*copyc tmt$mcr_faults
*copyc tmt$signal
*copyc tmt$signal_buffer
*copyc tmt$signal_buffers
?? POP ??
?? NEWTITLE := '  External procedures and variables referenced in this module', EJECT ??

*copyc clp$check_name_for_path_handle
*copyc clp$trimmed_string_size
*copyc dmp$get_mat_pointer
*copyc osp$set_status_abnormal
*copyc syp$convert_bytes
*copyc syp$crack_command
*copyc syp$display_bam_tables
*copyc syp$display_files
*copyc syp$display_global_file_info
*copyc syp$display_paths
*copyc syp$display_pde
*copyc syp$verify_access
*copyc syp$write_output_header
*copyc syp$write_output_line
*copyc cmv$logical_pp_table_p
*copyc cmv$logical_unit_table
*copyc dmv$active_volume_table
*copyc dmv$p_system_tape_table
*copyc mmv$tables_initialized
*copyc mtv$cst0
*copyc osv$cpus_physically_configured
*copyc syv$db_displayed_console_lines
*copyc syv$debug_line_count
*copyc syv$dump_to_pf
*copyc syv$job_template_ptr_array
?? OLDTITLE ??
?? NEWTITLE := '  TYPE definitions for data structures used in this module', EJECT ??

  TYPE

{ Converts an integer to an sfid

    sfid_converter = record
      case input_type: (sfid, int) of
      = sfid =
        fluff: 0 .. 0ffffffff(16),
        sfid: dmt$system_file_id,
     = int =
        int: integer,
     casend,
   recend;

?? OLDTITLE ??
?? NEWTITLE := '  CONST definitions for data structures used in this module', EJECT ??

  CONST
    dbe$ = 900000,
    add_to_eol = TRUE;

?? OLDTITLE ??
?? NEWTITLE := '  Parameter_descriptor_table for DISPLAY_JOB_TABLES command', EJECT ??

{ DISPLAY_JOB_TABLES parameter descriptor table:

  VAR
    syv$jfile_pdt: [XDCL, READ, oss$mainframe_paged_literal] array [1 .. 3] of syt$parameter_descriptor := [
{   } [FALSE, 1, 'p_h_name', syc$name_value, * ],
{   } [FALSE, 2, 'option', syc$name_value, * ],
{   } [FALSE, 3, 'id    ', syc$integer_value, 0, 0, 0ffffffff(16)]];

?? OLDTITLE ??
?? NEWTITLE := '  SYP$JOBFILEPROC', EJECT ??

  PROCEDURE [XDCL] syp$jobfileproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      allocation_units: dmt$dau_address,
      allocator: [READ, oss$mainframe_paged_literal] array [dmt$allocation_styles] of string (6) := ['A0   =',
        'A1   =', 'A2   =', 'A3   =', 'A4   =', 'A5   =', 'A6   =', 'A7   =', 'A8   =', 'ACYL ='],
      avt: dmt$active_volume_table_entry,
      blank: string (4),
      cd: fmt$cycle_description,
      cl_path_handle: clt$path_handle,
      cst: ost$cpu_state_table,
      cst_index: ost$processor_id,
      fmv$highest_pdu_offset: ost$segment_offset,
      fmv$initial_pdu_pointer: ^fmt$path_description_unit,
      fmv$pde_assignment_counter: integer,
      found: boolean,
      gfi: bat$global_file_information,
      ignore_status: ost$status,
      index: integer,
      j: integer,
      length: integer,
      lfn: amt$local_file_name,
      lpt: cmt$logical_pp_table_entry,
      lut: cmt$logical_unit,
      mat: ^dmt$mainframe_allocation_table,
      msg: string (75),
      pde: ^fmt$path_description_entry,
      pointer_to_initial_pdu_pointer: ^^fmt$path_description_unit,
      pvt: array [1 .. 3] of syt$parameter_value,
      sfid: dmt$system_file_id,
      sfid_var_converter: sfid_converter,
      str: string(60),
      stt : dmt$system_tape_table_entry,
      style: dmt$allocation_styles,
      task_status_translations: [READ, oss$mainframe_paged_literal] array [tmt$task_status] of string (24) :=
{           tmc$ts_null                     } ['NULL                    ',
{           tmc$ts_ready                    } 'READY                   ',
{           tmc$ts_ready_and_selected       } 'READY_AND_SELECTED      ',
{           tmc$ts_timeout_reqexp_shortshrt } 'TIMEOUT_REQEXP_SHORTSHRT',
{           tmc$ts_timeout_reqexp_longlong  } 'TIMEOUT_REQEXP_LONGLONG ',
{           tmc$ts_timeout_reqexp_longvlong } 'TIMEOUT_REQEXP_LONGVLONG',
{           tmc$ts_timed_wait_not_queued    } 'TIMED_WAIT_NOT_QUEUED   ',
{           tmc$ts_executing                } 'EXECUTING               ',
{           tmc$ts_timeout_reqexp_inflong   } 'TIMEOUT_REQEXP_INFLONG  ',
{           tmc$ts_timeout_reqexp_infvlong  } 'TIMEOUT_REQEXP_INFVLONG ',
{           tmc$ts_ready_but_swapped        } 'READY_BUT_SWAPPED       ',
{           tmc$ts_io_wait_not_queued       } 'IO_WAIT_NOT_QUEUED      ',
{           tmc$ts_page_wait                } 'PAGE_WAIT               ',
{           tmc$ts_memory_wait              } 'MEMORY_WAIT             ',
{           tmc$ts_segment_lock_wait        } 'SEGMENT_LOCK_WAIT       ',
{           tmc$ts_job_event_queue          } 'JOB_EVENT_QUEUE         ',
{           tmc$ts_io_wait_queued           } 'IO_WAIT_QUEUED          ',
{           tmc$ts_volume_unavailable       } 'VOLUME_UNAVAILABLE      '],
      unit_type : rmt$tape_unit_types;

{ The following *copyc is needed within the procedure because it is dependent on
{ the existance of fmv$initial_pdu_pointer & fmv$highest_pdu_offset which are
{ variables in job_pageable and used by this common routine.
*copyc fmp$locate_pde_via_path_handle


    status.normal := TRUE;
    syv$db_displayed_console_lines := 0;
    syv$debug_line_count := 0;
    IF (syv$job_template_ptr_array = NIL) OR (UPPERBOUND (syv$job_template_ptr_array^) < 4) THEN
      osp$set_status_abnormal ('DB', dbe$, 'not available', status);
      RETURN;
    IFEND;

    blank := '    ';

    syp$crack_command (syv$jfile_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF syv$dump_to_pf THEN
      syp$write_output_header (' DISPLAY JOB TABLES ', text);
    IFEND;

    syp$verify_access (syc$readable, #LOC (syv$job_template_ptr_array^ [4]), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pointer_to_initial_pdu_pointer := syv$job_template_ptr_array^ [4];
    fmv$initial_pdu_pointer := pointer_to_initial_pdu_pointer^;
    fmv$highest_pdu_offset := osc$maximum_offset;
    fmv$pde_assignment_counter := osc$max_integer;

    IF NOT pvt [1].defined THEN
      lfn := 'NONE';
    ELSE
      lfn := pvt [1].name;
    IFEND;
    clp$check_name_for_path_handle (lfn, cl_path_handle);
    IF NOT (cl_path_handle.kind = clc$regular_path_handle) THEN
      IF lfn = 'BAM_TABLES' THEN
        syp$display_bam_tables (fmv$initial_pdu_pointer, status);
        RETURN;
      ELSEIF lfn = 'PATHS' THEN
        syp$display_paths (fmv$initial_pdu_pointer, status);
        RETURN;
      ELSEIF lfn = 'NONE' THEN

{ Use lfn of 'NONE' to allow display of other tables.

        IF NOT pvt [2].defined THEN
          syp$display_files (fmv$initial_pdu_pointer, status);
          RETURN;
        ELSEIF (pvt [2].name = 'GFI') OR (pvt [2].name = 'PDE') THEN
          msg := 'A file must be specified to display the "GFI" or "PDE".';
          syp$write_output_line (msg, status);
          RETURN;
        IFEND;
      ELSE
        msg := 'Parameter 1 must be a path_handle_name, "NONE", "PATHS", or "BAM_TABLES".';
        syp$write_output_line (msg, status);
        RETURN;
      IFEND;
    ELSE
      fmp$locate_pde_via_path_handle (cl_path_handle.regular_handle, pde, status);
      IF NOT status.normal THEN
        IF status.condition = fme$obsolete_path_handle THEN
          msg := 'Path handle name "';
          msg (19, *) := lfn;
          msg (clp$trimmed_string_size(lfn) + 19, *) := '" is obsolete.';
        ELSE
          msg := 'Path handle name "';
          msg (19, *) := lfn;
          msg (clp$trimmed_string_size(lfn) + 19, *) := '" is not known.';
        IFEND;
        status.normal := TRUE;
        syp$write_output_line (msg, status);
        RETURN;
      IFEND;

      IF (pde^.entry_type = fmc$file_cycle_object) AND (pde^.cycle_description <> NIL) THEN
        cd := pde^.cycle_description^;
        IF cd.device_class = rmc$mass_storage_device THEN
          sfid := cd.system_file_id;
        ELSEIF cd.device_class = rmc$magnetic_tape_device THEN
          sfid := cd.system_file_id;
        IFEND;
      ELSEIF (pvt [2].defined AND (pvt [2].name = 'PDE')) THEN

{ This is OK.

      ELSE
        msg := 'File "';
        msg (7, *) := lfn;
        msg (clp$trimmed_string_size(lfn) + 7, *) := '" is not known.';
        syp$write_output_line (msg, status);
        RETURN;
      IFEND;
    IFEND;

    IF NOT pvt [2].defined THEN

{ Display file pointer indicators

      syp$write_output_line (blank, status);

      msg := 'Path handle name = ';
      msg (20, * ) := lfn;
      syp$write_output_line (msg, status);

      msg := 'SFID = ';
      syp$convert_bytes (#LOC (sfid), #SIZE (sfid), msg, add_to_eol);
      syp$write_output_line (msg, status);

      IF cd.global_file_information <> NIL THEN
        msg := 'EOI = ';
        syp$convert_bytes (#LOC (cd.global_file_information^.eoi_byte_address), #SIZE (cd.
              global_file_information^.eoi_byte_address), msg, add_to_eol);
        syp$write_output_line (msg, status);
        msg := 'OPEN_COUNT = ';
        syp$convert_bytes (#LOC (cd.global_file_information^.open_count), #SIZE (cd.global_file_information^.
              open_count), msg, add_to_eol);
        syp$write_output_line (msg, status);
      ELSE
        msg := 'Cycle_description.global_file_information = NIL';
        syp$write_output_line (msg, status);
      IFEND;

      IF cd.attached_file AND cd.permanent_file THEN
        IF cd.apfid.family_location = pfc$local_mainframe THEN
          msg := 'LOCAL APFID';
          syp$convert_bytes (#LOC(cd.apfid.attached_pf_table_index),
                #SIZE(cd.apfid.attached_pf_table_index), msg, add_to_eol);
          syp$write_output_line (msg, status);
        ELSE
          msg := 'SERVER APFID';
          syp$convert_bytes (#LOC(cd.apfid), #SIZE(cd.apfid), msg, add_to_eol);
          syp$write_output_line (msg, status);
        IFEND;
      IFEND;
      RETURN;
    IFEND;

    FOR j := 1 TO 5 DO
      syp$write_output_line (blank, ignore_status);
    FOREND;

    IF pvt [2].name = 'GFI' THEN
      msg := 'GLOBAL FILE INFORMATION for file: ';
      msg (35, * ) := lfn;
      syp$write_output_line (msg, ignore_status);
      IF cd.global_file_information = NIL THEN
        msg := 'no global file information';
        syp$write_output_line (msg, ignore_status);
      ELSE
        syp$display_global_file_info (cd.global_file_information, {indent} 4, status);
      IFEND;
    ELSEIF pvt [2].name = 'PDE' THEN
      msg := 'PATH DESCRIPTION ENTRY for file: ';
      msg (34, * ) := lfn;
      syp$write_output_line (msg, ignore_status);
      syp$display_pde (pde, status);


    ELSEIF pvt [2].name = 'AVT' THEN
      msg := 'ACTIVE VOLUME TABLE ENTRY';
      syp$write_output_line (msg, status);
      syp$write_output_line (blank, status);

      IF (NOT pvt [3].defined) OR (pvt [3].int = 0) THEN
        FOR j := 1 TO UPPERBOUND (dmv$p_active_volume_table^) DO
          msg := 'vsn';
          syp$convert_bytes (#LOC (j), #SIZE (j), msg, add_to_eol);
          IF dmv$p_active_volume_table^ [j].entry_available THEN
            msg (8, * ) := ' not in use';
          ELSE
            syp$convert_bytes (#LOC (dmv$p_active_volume_table^ [j].mass_storage.recorded_vsn), #SIZE
                  (dmv$p_active_volume_table^ [j].mass_storage.recorded_vsn), msg, add_to_eol);
            syp$write_output_line (msg, status);
          IFEND;
        FOREND;
        RETURN;
      IFEND;

      IF (pvt [3].int < 1) OR (pvt [3].int > UPPERBOUND (dmv$p_active_volume_table^)) THEN
        msg := 'bad avt index';
        syp$write_output_line (msg, status);
        RETURN;
      IFEND;

      j := pvt [3].int;
      avt := dmv$p_active_volume_table^ [j];
      IF avt.entry_available THEN
        msg := 'avt not in use';
        syp$write_output_line (msg, status);
        RETURN;
      IFEND;

      msg := 'lock = ';
      syp$convert_bytes (#LOC (avt.lock), #SIZE (avt.lock), msg, add_to_eol);
      syp$write_output_line (msg, status);

      msg := 'logical_unit_number = ';
      syp$convert_bytes (#LOC (avt.logical_unit_number), #SIZE (avt.logical_unit_number), msg, add_to_eol);
      syp$write_output_line (msg, status);

        msg := 'allocation allowed = ';
        IF avt.mass_storage.allocation_allowed THEN
          msg (22, * ) := 'TRUE';
        ELSE
          msg (22, * ) := 'FALSE';
        IFEND;
        syp$write_output_line (msg, status);

        msg := 'class = ';
        syp$convert_bytes (#LOC (avt.mass_storage.class), #SIZE (avt.mass_storage.class), msg, add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'disk table status = ';
        IF dmc$table_update_in_progress IN avt.mass_storage.disk_table_status THEN
          msg (21, * ) := 'table update in progress';
        ELSEIF dmc$dflt_update_required IN avt.mass_storage.disk_table_status THEN
          msg (21, * ) := 'dflt update required';
        ELSEIF dmc$no_available_dflt_entries IN avt.mass_storage.disk_table_status THEN
          msg (21, * ) := 'no available dflt entries';
        ELSEIF dmc$table_update_inhibited IN avt.mass_storage.disk_table_status THEN
          msg (21, * ) := 'table update inhibited';
        IFEND;
        syp$write_output_line (msg, status);

        msg := 'update lock = ';
        syp$convert_bytes (#LOC (avt.mass_storage.update_lock), #SIZE (avt.mass_storage.update_lock), msg,
              add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'logging lock =';
        syp$convert_bytes (#LOC (avt.mass_storage.logging_lock), #SIZE (avt.mass_storage.logging_lock), msg,
              add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'internal vsn =';
        syp$convert_bytes (#LOC (avt.mass_storage.internal_vsn), #SIZE (avt.mass_storage.internal_vsn), msg,
              add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'allocation table =';
        syp$convert_bytes (#LOC (avt.mass_storage.p_device_allocation_table), #SIZE (avt.mass_storage.
              p_device_allocation_table), msg, add_to_eol);
        syp$write_output_line (msg, status);
        msg := 'device file list =';
        syp$convert_bytes (#LOC (avt.mass_storage.p_device_file_list_table), #SIZE (avt.mass_storage.
              p_device_file_list_table), msg, add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'device log =';
        syp$convert_bytes (#LOC (avt.mass_storage.p_device_log), #SIZE (avt.mass_storage.p_device_log), msg,
              add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'directory =';
        syp$convert_bytes (#LOC (avt.mass_storage.p_directory), #SIZE (avt.mass_storage.p_directory), msg,
              add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'login table =';
        syp$convert_bytes (#LOC (avt.mass_storage.p_login_table), #SIZE (avt.mass_storage.p_login_table), msg,
              add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'mainframe assigned =';
        syp$convert_bytes (#LOC (avt.mass_storage.mainframe_assigned), #SIZE (avt.mass_storage.
              mainframe_assigned), msg, add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'vsn = ';
        syp$convert_bytes (#LOC (avt.mass_storage.recorded_vsn), #SIZE (avt.mass_storage.recorded_vsn), msg,
              add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'setname =';
        syp$convert_bytes (#LOC (avt.mass_storage.set_name), #SIZE (avt.mass_storage.set_name), msg,
              add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'volume owner =';
        syp$convert_bytes (#LOC (avt.mass_storage.volume_owner), #SIZE (avt.mass_storage.volume_owner), msg,
              add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'log size =';
        syp$convert_bytes (#LOC (avt.mass_storage.allocated_log_size), #SIZE (avt.mass_storage.
              allocated_log_size), msg, add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'log offset =';
        syp$convert_bytes (#LOC (avt.mass_storage.current_position_offset_in_log), #SIZE (avt.mass_storage.
              current_position_offset_in_log), msg, add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'mat =';
        syp$convert_bytes (#LOC (avt.mass_storage.p_mat), #SIZE (avt.mass_storage.p_mat), msg, add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'mfl = ';
        syp$convert_bytes (#LOC (avt.mass_storage.p_mfl), #SIZE (avt.mass_storage.p_mfl), msg, add_to_eol);
        syp$write_output_line (msg, status);

      RETURN;

    ELSEIF pvt [2].name = 'MAT' THEN
      msg := 'MAINFRAME ALLOCATION TABLE';
      syp$write_output_line (msg, status);
      syp$write_output_line (blank, status);

      IF (NOT pvt [3].defined) OR (pvt [3].int = 0) THEN
        msg := 'bad mat index';
        syp$write_output_line (msg, status);
        RETURN;
      IFEND;
      j := pvt [3].int;
      IF NOT dmv$p_active_volume_table^ [j].entry_available THEN
        dmp$get_mat_pointer (j, mat);
      ELSE
        mat := NIL;
      IFEND;
      IF (mat = NIL) THEN
        msg := 'mat entry not in use';
        syp$write_output_line (msg, status);
        RETURN;
      IFEND;
      msg := 'bytes/dau =';
      syp$convert_bytes (#LOC (mat^.bytes_per_dau), #SIZE (mat^.bytes_per_dau), msg, add_to_eol);
      syp$write_output_line (msg, status);

      msg := 'bytes/mau =';
      syp$convert_bytes (#LOC (mat^.bytes_per_mau), #SIZE (mat^.bytes_per_mau), msg, add_to_eol);
      syp$write_output_line (msg, status);

      msg := 'maus/dau =';
      syp$convert_bytes (#LOC (mat^.maus_per_dau), #SIZE (mat^.maus_per_dau), msg, add_to_eol);
      syp$write_output_line (msg, status);

      msg := 'daus/position =';
      syp$convert_bytes (#LOC (mat^.daus_per_position), #SIZE (mat^.daus_per_position), msg, add_to_eol);
      syp$write_output_line (msg, status);

      msg := 'positions/device =';
      syp$convert_bytes (#LOC (mat^.positions_per_device), #SIZE (mat^.positions_per_device), msg,
            add_to_eol);
      syp$write_output_line (msg, status);

      msg := 'min file space =';
      syp$convert_bytes (#LOC (mat^.minimum_space), #SIZE (mat^.minimum_space), msg, add_to_eol);
      syp$write_output_line (msg, status);

      msg := 'max file space =';
      syp$convert_bytes (#LOC (mat^.maximum_space), #SIZE (mat^.maximum_space), msg, add_to_eol);
      syp$write_output_line (msg, status);

      msg := 'available allocation units';
      syp$write_output_line (msg, status);
      FOR style := LOWERVALUE (style) TO UPPERVALUE (style) DO
        allocation_units := mat^.available_allocation_units [style];
        msg := allocator [style];
        syp$convert_bytes (#LOC (allocation_units), #SIZE (allocation_units), msg, add_to_eol);
        syp$write_output_line (msg, status);
      FOREND;

      msg := 'available space =';
      syp$convert_bytes (#LOC (mat^.available_space), #SIZE (mat^.available_space), msg, add_to_eol);
      syp$write_output_line (msg, status);

      msg := 'leftover space =';
      syp$convert_bytes (#LOC (mat^.leftover_space), #SIZE (mat^.leftover_space), msg, add_to_eol);
      syp$write_output_line (msg, status);

      msg := 'MAT address =';
      syp$convert_bytes (#LOC (mat), 6, msg, add_to_eol);
      syp$write_output_line (msg, status);

    ELSEIF pvt [2].name = 'LUT' THEN
      msg := 'LOGICAL UNIT TABLE';
      syp$write_output_line (msg, status);
      syp$write_output_line (blank, status);

      IF cmv$logical_unit_table = NIL THEN
        msg := 'no lut active';
        syp$write_output_line (msg, status);
        RETURN;
      IFEND;

      FOR j := 1 TO UPPERBOUND (cmv$logical_unit_table^) DO
        lut := cmv$logical_unit_table^ [j];
        msg := 'logical unit entry #';
        syp$convert_bytes (#LOC (j), #SIZE (j), msg, add_to_eol);
        syp$write_output_line (msg, status);
        syp$write_output_line (blank, status);

        msg := 'CONFIGURED =';
        syp$convert_bytes (#LOC (lut.logical_unit_number), #SIZE (lut.logical_unit_number), msg, add_to_eol);
        syp$write_output_line (msg, status);


        msg := 'ENTRY INTERLOCK =';
        IF lut.entry_interlock THEN
          msg (19, * ) := 'TRUE';
        ELSE
          msg (19, * ) := 'FALSE';
        IFEND;
        syp$write_output_line (msg, status);

        msg := 'UNIT INTERFACE TABLE =';
        syp$convert_bytes (#LOC (lut.unit_interface_table), #SIZE (lut.unit_interface_table), msg,
              add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'ELEMENT CAPABILITY =';
        IF lut.element_capability >= $cmt$element_capabilities [cmc$io_request_submission] THEN
          msg (22, *) := ' ON';
        ELSEIF lut.element_capability = $cmt$element_capabilities [cmc$dedicated_maintenance,
              cmc$concurrent_maintenance] THEN
          msg (22, *) := ' DOWN';
        ELSEIF lut.element_capability = $cmt$element_capabilities [ ] THEN
          msg (22, *) := ' OFF';
        IFEND;
        syp$write_output_line (msg, status);

        msg := 'STATUS =';
        syp$convert_bytes (#LOC (lut.status), #SIZE (lut.status), msg, add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'ELEMENT ACCESS =';
        syp$convert_bytes (#LOC (lut.element_access), #SIZE (lut.element_access), msg, add_to_eol);
        syp$write_output_line (msg, status);

        CASE lut.status.assignable_device OF
        = TRUE =
          msg := 'ASSIGNED =';
          IF lut.status.assigned THEN
            msg (12, * ) := 'TRUE';
          ELSE
            msg (12, * ) := 'FALSE';
          IFEND;
          syp$write_output_line (msg, status);

          msg := 'ASSIGNED JSN =';
          syp$convert_bytes (#LOC (lut.status.assigned_jsn), #SIZE (lut.status.assigned_jsn), msg,
                add_to_eol);
          syp$write_output_line (msg, status);

        = FALSE =
        ELSE
        CASEND;
      FOREND;
    ELSEIF pvt [2].name = 'LPT' THEN
      msg := 'LOGICAL PP TABLE';
      syp$write_output_line (msg, status);

      IF cmv$logical_pp_table_p = NIL THEN
        msg := 'no lpt entries';
        syp$write_output_line (msg, status);
        RETURN;
      IFEND;

      FOR j := 1 TO UPPERBOUND (cmv$logical_pp_table_p^) DO

        lpt := cmv$logical_pp_table_p^ [j];
        msg := 'logical pp entry #';
        syp$convert_bytes (#LOC (j), #SIZE (j), msg, add_to_eol);
        syp$write_output_line (msg, status);
        syp$write_output_line (blank, status);

        msg := 'CONFIGURED =';
        IF lpt.flags.configured THEN
          msg (14, * ) := 'TRUE';
        ELSE
          msg (14, * ) := 'FALSE';
        IFEND;
        syp$write_output_line (msg, status);

        msg := 'ENTRY IN USE =';
        IF lpt.flags.entry_in_use THEN
          msg (19, * ) := 'TRUE';
        ELSE
          msg (19, * ) := 'FALSE';
        IFEND;
        syp$write_output_line (msg, status);

        msg := '   IOU =';
        syp$convert_bytes (#LOC (lpt.pp_info.channel.iou_number), #SIZE (lpt.pp_info.channel.iou_number),
              msg, add_to_eol);
        syp$write_output_line (msg, status);

        msg := '   CHANNEL LOCK =';
        syp$convert_bytes (#LOC (lpt.pp_info.channel_interlock_p), #SIZE (lpt.pp_info.channel_interlock_p),
              msg, add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'RESPONSE HANDLER =';
        syp$convert_bytes (#LOC (lpt.handlers.response_handler_p), #SIZE (lpt.handlers.response_handler_p),
              msg, add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'CONTROLLER TYPE =';
        syp$convert_bytes (#LOC (lpt.controller_info.controller_type),
              #SIZE (lpt.controller_info.controller_type), msg, add_to_eol);
        syp$write_output_line (msg, status);

        msg := 'DISABLED =';
        IF lpt.flags.disabled THEN
          msg (12, * ) := 'TRUE';
        ELSE
          msg (12, * ) := 'FALSE';
        IFEND;
        syp$write_output_line (msg, status);

        msg := 'PP_LOADED =';
        IF lpt.flags.pp_loaded THEN
          msg (13, * ) := 'TRUE';
        ELSE
          msg (13, * ) := 'FALSE';
        IFEND;
        syp$write_output_line (msg, status);

      FOREND;
    ELSEIF pvt [2].name = 'STT' then
      msg := 'SYSTEM TAPE TABLE';
      syp$write_output_line (msg, status);
      syp$write_output_line (blank, status);
      IF dmv$p_system_tape_table = NIL THEN
        msg := 'no stt entries';
        syp$write_output_line (msg, status);
        RETURN;
      IFEND;
      FOR unit_type := rmc$hd_pe TO rmc$highest_unit_type DO
        stt := dmv$p_system_tape_table ^[unit_type];
        IF stt.defined_tape <> 0 THEN
          msg := ' Unit type =';
          syp$convert_bytes (#LOC(unit_type), #SIZE(unit_type), msg, add_to_eol);
          syp$write_output_line (msg, status);
          syp$write_output_line (blank, status);
          msg := '   DEFINED UNITS =';
          syp$convert_bytes (#LOC(stt.defined_tape), #SIZE(stt.defined_tape), msg, add_to_eol);
          syp$write_output_line (msg, status);
          msg := '   NUMBER ON =';
          syp$convert_bytes (#LOC(stt.number_on), #SIZE(stt.number_on), msg, add_to_eol);
          syp$write_output_line (msg, status);
          msg := '   LOWER DENSITY RESERVED =';
          syp$convert_bytes (#LOC(stt.lower_density_reserved), #SIZE(stt.lower_density_reserved),
                msg, add_to_eol);
          syp$write_output_line (msg, status);
          msg := '   HIGHER DENSITY RESERVED =';
          syp$convert_bytes (#LOC(stt.higher_density_reserved), #SIZE(stt.higher_density_reserved),
                msg, add_to_eol);
          syp$write_output_line (msg, status);
        IFEND;
      FOREND;
    ELSEIF pvt [2].name = 'CST' then
      FOR cst_index := 0 TO (osv$cpus_physically_configured - 1) DO
        IF cst_index <> 0 THEN
          syp$write_output_line (blank, status);
        IFEND;

        msg := 'CPU STATE TABLE ';
        STRINGREP (msg (17, *), length, cst_index);
        syp$write_output_line (msg, status);
        syp$write_output_line (blank, status);

         cst:= mtv$cst0 [cst_index];
         msg := '  dispatching priority: ';
         syp$convert_bytes (#LOC (cst.dispatching_priority),  #SIZE (cst.dispatching_priority), msg,
               add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  dual state prior subpriority: ';
         syp$write_output_line (msg, status);
         msg := '    dual state priority: ';
         syp$convert_bytes (#LOC (cst.dual_state_prior_subpriority.dual_state_priority),
                 #SIZE (cst.dual_state_prior_subpriority.dual_state_priority), msg, add_to_eol);
         syp$write_output_line (msg, status);
         msg := '    subpriority: ';
         syp$convert_bytes (#LOC (cst.dual_state_prior_subpriority.subpriority),
                 #SIZE (cst.dual_state_prior_subpriority.subpriority), msg, add_to_eol);
         syp$write_output_line (msg,status);

         msg := '  memory port mask: ';
         syp$convert_bytes (#LOC (cst.memory_port_mask), #SIZE (cst.memory_port_mask), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  cst index: ';
         syp$convert_bytes (#LOC (cst.cst_index), #SIZE (cst.cst_index), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  processor state: ';
         IF cst.processor_state = cmc$on THEN
           msg (20, *) := 'ON';
         ELSEIF cst.processor_state = cmc$down THEN
           msg (20, *) := 'DOWN';
         ELSEIF cst.processor_state = cmc$off THEN
           msg (20, *) := 'OFF';
         ELSE
           syp$convert_bytes (#LOC (cst.processor_state), #SIZE (cst.processor_state), msg, add_to_eol);
         IFEND;
         syp$write_output_line (msg, status);

         msg := '  next processor state: ';
         IF cst.next_processor_state = cmc$on THEN
           msg (25, *) := 'ON';
         ELSEIF cst.next_processor_state = cmc$down THEN
           msg (25, *) := 'DOWN';
         ELSEIF cst.next_processor_state = cmc$off THEN
           msg (25, *) := 'OFF';
         ELSE
           syp$convert_bytes (#LOC (cst.next_processor_state), #SIZE (cst.next_processor_state), msg,
                 add_to_eol);
         IFEND;
         syp$write_output_line (msg, status);

         msg := '  cpu alive flag: ';
         syp$convert_bytes (#LOC (cst.cpu_alive_flag), #SIZE (cst.cpu_alive_flag), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  taskid: ';
         syp$convert_bytes (#LOC (cst.taskid), #SIZE (cst.taskid), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  ajlo: ';
         syp$convert_bytes (#LOC (cst.ajlo), #SIZE(cst.ajlo), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  dual state jps: ';
         syp$convert_bytes (#LOC (cst.dual_state_jps), #SIZE(cst.dual_state_jps), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  jcb_p: ';
         syp$convert_bytes (#LOC (cst.jcb_p), #SIZE (cst.jcb_p), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  xcb_p: ';
         syp$convert_bytes (#LOC (cst.xcb_p), #SIZE(cst.xcb_p), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  xcb rma: ';
         syp$convert_bytes (#LOC (cst.xcb_rma), #SIZE (cst.xcb_rma), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  dispatch control: ';
         syp$write_output_line (msg, status);
         msg := '    call_dispatcher: ';
         IF cst.dispatch_control.call_dispatcher THEN
           msg (22, *) := 'TRUE';
         ELSE
           msg (22, *) := 'FALSE';
         IFEND;
         syp$write_output_line (msg, status);
         msg := '    rethread_current_task: ';
         IF cst.dispatch_control.rethread_current_task THEN
           msg (28, *) := 'TRUE';
         ELSE
           msg (28, *) := 'FALSE';
         IFEND;
         syp$write_output_line (msg, status);
         msg := '    new_task_status: ';
         msg (22, *) := task_status_translations [cst.dispatch_control.new_task_status];
         syp$write_output_line (msg, status);
         msg := '    fill: ';
         IF cst.dispatch_control.fill THEN
           msg (11, *) := 'TRUE';
         ELSE
           msg (11, *) := 'FALSE';
         IFEND;
         syp$write_output_line (msg, status);
         msg := '    asynchronous_interrupts_pending: ';
         IF cst.dispatch_control.asynchronous_interrupts_pending THEN
           msg (38, *) := 'TRUE';
         ELSE
           msg (38, *) := 'FALSE';
         IFEND;
         syp$write_output_line (msg, status);

         msg := '  max cptime: ';
         syp$convert_bytes (#LOC (cst.max_cptime), #SIZE (cst.max_cptime), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  accumulated job cptime: ';
         syp$convert_bytes (#LOC (cst.accumulated_job_cptime), #SIZE (cst.accumulated_job_cptime), msg,
               add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  accumulated monitor cptime: ';
         syp$convert_bytes (#LOC (cst.accumulated_monitor_cptime), #SIZE(cst.accumulated_monitor_cptime),
               msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  ext int request: ';
         syp$write_output_line (msg, status);
         msg := '    task switch: ';
         IF cst.ext_int_request.task_switch THEN
           msg (18, *) := 'TRUE';
         ELSE
           msg (18, *) := 'FALSE';
         IFEND;
         syp$write_output_line (msg, status);
         msg := '    purge cache: ';
         IF cst.ext_int_request.purge_cache THEN
           msg (18, *) := 'TRUE';
         ELSE
           msg (18, *) := 'FALSE';
         IFEND;
         syp$write_output_line (msg, status);
         msg := '    purge map: ';
         IF cst.ext_int_request.purge_map THEN
           msg (16, *) := 'TRUE';
         ELSE
           msg (16, *) := 'FALSE';
         IFEND;
         syp$write_output_line (msg, status);
         msg := '    step processor: ';
         IF cst.ext_int_request.step_processor THEN
           msg (21, *) := 'TRUE';
         ELSE
           msg (21, *) := 'FALSE';
         IFEND;
         syp$write_output_line (msg, status);

         msg := '  time last cache purge: ';
         syp$convert_bytes (#LOC (cst.time_last_cache_purge), #SIZE (cst.time_last_cache_purge), msg,
               add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  time last cache purge: ';
         syp$convert_bytes (#LOC (cst.time_last_map_request), #SIZE (cst.time_last_map_request), msg,
               add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  monitor mps: ';
         syp$convert_bytes (#LOC (cst.monitor_mps), #SIZE (cst.monitor_mps), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  aborted task count: ';
         syp$convert_bytes (#LOC (cst.aborted_task_count), #SIZE (cst.aborted_task_count), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  due count: ';
         syp$convert_bytes (#LOC (cst.due_count), #SIZE (cst.due_count), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  element id: ';
         syp$convert_bytes (#LOC (cst.element_id), #SIZE (cst.element_id), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  ijl ordinal: ';
         syp$convert_bytes (#LOC (cst.ijl_ordinal), #SIZE (cst.ijl_ordinal), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  ijle_p: ';
         syp$convert_bytes (#LOC (cst.ijle_p), #SIZE (cst.ijle_p), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  cpu idle statistics: ';
         syp$write_output_line (msg, status);
         msg := '    idle, no io active: ';
         syp$convert_bytes (#LOC (cst.cpu_idle_statistics.idle_no_io_active),
               #SIZE (cst.cpu_idle_statistics.idle_no_io_active), msg, add_to_eol);
         syp$write_output_line (msg, status);
         msg := '    idle, io active: ';
         syp$convert_bytes (#LOC (cst.cpu_idle_statistics.idle_io_active),
               #SIZE (cst.cpu_idle_statistics.idle_io_active), msg, add_to_eol);
         syp$write_output_line (msg, status);
         msg := '   idle start time: ';
         syp$convert_bytes (#LOC (cst.cpu_idle_statistics.idle_start_time),
               #SIZE (cst.cpu_idle_statistics.idle_start_time), msg, add_to_eol);
         syp$write_output_line (msg, status);
         msg := '    idle type: ';
         IF cst.cpu_idle_statistics.idle_type = osc$not_idle THEN
           msg (16, *) := 'not idle';
         ELSEIF cst.cpu_idle_statistics.idle_type = osc$idle_with_io_active THEN
           msg (16, *) := 'idle with io active';
         ELSEIF cst.cpu_idle_statistics.idle_type = osc$idle_no_io_active THEN
           msg (16, *) := 'idle, no io active';
         ELSE
           syp$convert_bytes (#LOC (cst.cpu_idle_statistics.idle_type),
                 #SIZE (cst.cpu_idle_statistics.idle_type), msg, add_to_eol);
         IFEND;
         syp$write_output_line (msg, status);

         msg := '  trace control: ';
         syp$convert_bytes (#LOC (cst.trace_control), #SIZE (cst.trace_control), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  termination message: ';
         syp$convert_bytes (#LOC (cst.termination_message), #SIZE (cst.termination_message), msg, add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  reason for current state: ';
         IF cst.reason_for_current_state = osc$cdsr_null THEN
           msg (29, *) := '{null}';
         ELSEIF cst.reason_for_current_state = osc$cdsr_downed_by_dft THEN
           msg (29, *) := 'CPU downed by DFT';
         ELSEIF cst.reason_for_current_state = osc$cdsr_due_threshold_exceeded THEN
           msg (29, *) := 'DUE threshold exceeded';
         ELSEIF cst.reason_for_current_state = osc$cdsr_cpu_timeout THEN
           msg (29, *) := 'CPU timeout';
         ELSEIF cst.reason_for_current_state = osc$cdsr_downed_by_operator THEN
           msg (29, *) := 'CPU downed by operator';
         ELSEIF cst.reason_for_current_state = osc$cdsr_downed_by_system THEN
           msg (29, *) := 'CPU downed by system';
         ELSE
           syp$convert_bytes (#LOC (cst.reason_for_current_state), #SIZE (cst.reason_for_current_state), msg,
                 add_to_eol);
         IFEND;
         syp$write_output_line (msg, status);

         msg := '  pre-processed for reconfig: ';
         IF cst.pre_processed_for_reconfig = osc$ppfr_not_processed THEN
           msg (31, *) := 'not processed';
         ELSEIF cst.pre_processed_for_reconfig = osc$ppfr_processing_in_progress THEN
           msg (31, *) := 'processing in progress';
         ELSEIF cst.pre_processed_for_reconfig = osc$ppfr_processing_complete THEN
           msg (31, *) := 'processing complete';
         ELSE
           syp$convert_bytes (#LOC (cst.pre_processed_for_reconfig), #SIZE (cst.pre_processed_for_reconfig),
                 msg, add_to_eol);
         IFEND;
         syp$write_output_line (msg, status);

         msg := '  previous processor state: ';
         IF cst.previous_processor_state = cmc$on THEN
           msg (20, *) := 'ON';
         ELSEIF cst.previous_processor_state = cmc$down THEN
           msg (20, *) := 'DOWN';
         ELSEIF cst.previous_processor_state = cmc$off THEN
           msg (20, *) := 'OFF';
         ELSE
           syp$convert_bytes (#LOC (cst.previous_processor_state), #SIZE (cst.previous_processor_state), msg,
                 add_to_eol);
         IFEND;
         syp$write_output_line (msg, status);

         msg := '  log cpu state change: ';
         IF cst.log_cpu_state_change THEN
           msg (25, *) := 'TRUE';
         ELSE
           msg (25, *) := 'FALSE';
         IFEND;
         syp$write_output_line (msg, status);

         msg := '  next ptlo to dispatch: ';
         syp$convert_bytes (#LOC (cst.next_ptlo_to_dispatch), #SIZE (cst.next_ptlo_to_dispatch), msg,
               add_to_eol);
         syp$write_output_line (msg, status);

         msg := '  dispatching priority integer: ';
         syp$convert_bytes (#LOC (cst.dispatching_priority_integer), #SIZE (cst.dispatching_priority_integer),
                msg, add_to_eol);
         syp$write_output_line (msg, status);
      FOREND;
    IFEND;
  PROCEND syp$jobfileproc;
?? OLDTITLE, OLDTITLE ??
MODEND sym$debug1;
*DECK DECK=SYM$DISPLAY_BAM_TABLES EXPAND=TRUE
*copyc osd$default_pragmats
?? NEWTITLE := 'NOS/VE : Basic Access Methods : Table Displays' ??

MODULE sym$display_bam_tables;

{  PURPOSE:
{    This module contains procedures called by syp$jobfileprc (the
{    procedure which interprets the display_job_tables(disjt)
{    system_core_debugger command.  These procedures display
{    symbolically the contents of a BAM table.
{
{  DESIGN:
{    The XDCLed procedures set up what is to be displayed and call internal
{    procedures to do the displaying.  Each internal procedure is passed
{    the record (or a pointer to it) that is to be displayed and the column
{    (indention) at which the display should start.


?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc amt$file_reference
*copyc bat$task_file_table
*copyc bat$display_tables_indention
*copyc cyc$max_string_size
*copyc fmc$cycle_table_allocation_size
*copyc fmc$entry_assigned
*copyc fmc$number_of_init_cycle_descs
*copyc fmc$number_of_init_path_descs
*copyc fmc$path_table_allocation_size
*copyc fmc$pde_unique_identifier
*copyc fme$file_management_errors
*copyc fmt$cd_attachment_options
*copyc fmt$cycle_description
*copyc fmt$cycle_description_unit
*copyc fmt$path_description_entry
*copyc fmt$path_description_unit
*copyc fmt$path_element_type
*copyc fmt$path_handle
*copyc fmt$static_label_header
*copyc fmt$static_label_item
*copyc fmt$system_file_label
*copyc fsc$max_path_elements
*copyc fst$path
*copyc fst$path_handle_name
*copyc fst$path_table_expansion_limit
*copyc osd$random_name
*copyc ost$status
?? POP ??
*copyc clp$construct_path_handle_name
*copyc clp$convert_integer_to_string
*copyc clp$trimmed_string_size
*copyc osp$set_status_abnormal
*copyc syp$write_output_line

?? TITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST
    title_length = 70;

?? TITLE := 'PROCEDURE [XDCL] syp$display_bam_tables', EJECT ??

  PROCEDURE [XDCL] syp$display_bam_tables
    (    initial_pdu_pointer: ^fmt$path_description_unit;
     VAR status: ost$status);

    status.normal := TRUE;

    syp$display_paths (initial_pdu_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_path_table (initial_pdu_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND syp$display_bam_tables;

?? TITLE := 'PROCEDURE [XDCL] syp$display_files', EJECT ??

  PROCEDURE [XDCL] syp$display_files
    (    initial_pdu_pointer: ^fmt$path_description_unit;
     VAR status: ost$status);

    VAR
      entry: 1 .. cyc$max_string_size,
      output_length: integer,
      output_path: string (fsc$max_path_size + 8),
      output_string: string (bat$display_tables_str_length),
      path: string (fsc$max_path_size),
      path_handle: fmt$path_handle,
      path_handle_name: amt$local_file_name,
      path_length: fst$path_size,
      pde: ^fmt$path_description_entry,
      pdu: ^fmt$path_description_unit,
      temp_pde: ^fmt$path_description_entry;

    status.normal := TRUE;

    { get pointer first entry in the first path_description_unit }
    pdu := initial_pdu_pointer;

    display_title ('FILES IN PATH TABLE', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    WHILE pdu <> NIL DO

      { look at every assigned entry in a path_description_unit }
      FOR entry := 1 TO #SIZE (pdu^.entry_assignment^) DO
        IF pdu^.entry_assignment^ (entry) = fmc$entry_assigned THEN
          pde := ^pdu^.entries^ [entry];
          IF (pde^.entry_type = fmc$file_cycle_object) AND
                (pde^.cycle_description <> NIL) THEN
            get_path (pde, path, path_length, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            STRINGREP (output_path, output_length, ' path = ',
                  path (1, path_length));
            syp$write_output_line (output_path (1, output_length), status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            { create a path_handle_name for the cycle_object }
            path_handle := pde^.cycle_description^.path_handle;
            clp$construct_path_handle_name (path_handle, path_handle_name);
            STRINGREP (output_string, output_length, ' ': 5,
                  'attached = ', pde^.cycle_description^.attached_file,
                  '    path_handle_name = ', path_handle_name( 1,
                  clp$trimmed_string_size( path_handle_name)));
            syp$write_output_line (output_string (1, output_length), status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
            temp_pde := pde^.first_cycle_alias_entry;
            WHILE temp_pde <> NIL DO
              { create a path_handle_name for the alias }
              path_handle.segment_offset := #OFFSET (temp_pde);
              path_handle.assignment_counter :=
                    temp_pde^.entry_assignment_counter;
              path_handle.open_position.specified := FALSE;
              clp$construct_path_handle_name (path_handle, path_handle_name);
              STRINGREP (output_string, output_length, ' ': 9, 'alias = ',
                    temp_pde^.path_node_name.value, ' phn = ',
                    path_handle_name( 1,
                    clp$trimmed_string_size( path_handle_name)));
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              temp_pde := temp_pde^.next_cycle_alias_entry;
            WHILEND;
          IFEND;
        IFEND;
      FOREND;

      { move on to next unit if pointer is not NIL}
      pdu := pdu^.next_path_description_unit;
    WHILEND;

  PROCEND syp$display_files;

?? TITLE := 'PROCEDURE [XDCL] syp$display_paths', EJECT ??

  PROCEDURE [XDCL] syp$display_paths
    (    initial_pdu_pointer: ^fmt$path_description_unit;
     VAR status: ost$status);

    status.normal := TRUE;

    display_pt_stats (initial_pdu_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    syp$display_files (initial_pdu_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    display_unused_paths (initial_pdu_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND syp$display_paths;
?? TITLE := 'PROCEDURE display_path_table', EJECT ??

  PROCEDURE display_path_table
    (    initial_pdu_pointer: ^fmt$path_description_unit;
     VAR status: ost$status);

    CONST
      entry_assignment_display_size = 50;

    VAR
      i: integer,
      indent: bat$display_tables_indention,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      pde: ^fmt$path_description_entry,
      pdu: ^fmt$path_description_unit,
      unit: integer;

    status.normal := TRUE;

    display_title ('PATH TABLE', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    indent := 5;
    unit := 1;
    pdu := initial_pdu_pointer;

    WHILE pdu <> NIL DO
      IF unit = 1 THEN
        STRINGREP (output_string, output_length, ' ',
              'PATH_DESCRIPTION_UNIT : ', pdu, '   UNIT # : ', unit: 4);
      ELSE
        STRINGREP (output_string, output_length, '1',
              'PATH_DESCRIPTION_UNIT : ', pdu, '   UNIT # : ', unit: 4);
      IFEND;
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent,
            'next_path_description_unit : ', pdu^.next_path_description_unit);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'total_count : ',
            pdu^.total_count);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'current_count : ',
            pdu^.current_count);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent,
            '                   ', '         111111111122222222223333333333',
            '44444444445');
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent,
            '                   ', '123456789012345678901234567890123456789',
            '01234567890');
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      i := 0;
      WHILE i < ((#SIZE (pdu^.entry_assignment^) - 1) DIV entry_assignment_display_size) DO
        i := i + 1;
        STRINGREP (output_string, output_length, ' ': indent,
              'entry_assignment : ', pdu^.entry_assignment^
              (((i - 1) * entry_assignment_display_size + 1),
              entry_assignment_display_size));
        syp$write_output_line (output_string (1, output_length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      WHILEND;

      STRINGREP (output_string, output_length, ' ': indent,
            'entry_assignment : ', pdu^.entry_assignment^
            ((i * entry_assignment_display_size + 1), * ));
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      FOR i := 1 TO #SIZE (pdu^.entry_assignment^) DO
        IF pdu^.entry_assignment^ (i) = fmc$entry_assigned THEN
          pde := ^pdu^.entries^ [i];
          STRINGREP (output_string, output_length, '-', ' ': indent - 1,
                'PATH_DESCRIPTION_ENTRY : ', pde, '   ENTRY # : ', i,
                '   UNIT # : ', unit: 4);
          syp$write_output_line (output_string (1, output_length), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          display_pde (pde, indent + 4, status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND
      FOREND;
      unit := unit + 1;
      pdu := pdu^.next_path_description_unit;
    WHILEND;

  PROCEND display_path_table;

?? TITLE := 'PROCEDURE [XDCL] syp$display_pde', EJECT ??

  PROCEDURE [XDCL] syp$display_pde
    (    path_description_entry: ^fmt$path_description_entry;
     VAR status: ost$status);

    VAR
      indent: bat$display_tables_indention,
      output_length: integer,
      output_path: string (fsc$max_path_size + 8),
      output_string: string (bat$display_tables_str_length),
      path: string (fsc$max_path_size),
      path_length: fst$path_size,
      pde: ^fmt$path_description_entry;

    status.normal := TRUE;

    display_title ('PATH DESCRIPTION ENTRY', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pde := path_description_entry;

    get_path (pde, path, path_length, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_path, output_length, ' path = ', path (1, path_length));
    syp$write_output_line (output_path (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    indent := 5;
    STRINGREP (output_string, output_length, '-', 'PATH_DESCRIPTION_ENTRY : ',
          pde);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display_pde (pde, indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { display back up full path }
    WHILE pde^.parental_path_entry <> NIL DO
      pde := pde^.parental_path_entry;
      STRINGREP (output_string, output_length, '-',
            'PARENT PATH_DESCRIPTION_ENTRY : ', pde);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      display_pde (pde, indent, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    WHILEND;

    IF (path_description_entry^.entry_type = fmc$file_cycle_object) AND
          (path_description_entry^.first_cycle_alias_entry <> NIL) THEN
      pde := path_description_entry^.first_cycle_alias_entry;
      WHILE pde <> NIL DO
        STRINGREP (output_string, output_length, '-',
              'ALIAS PATH_DESCRIPTION_ENTRY : ', pde);
        syp$write_output_line (output_string (1, output_length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        display_pde (pde, indent, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        pde := pde^.next_cycle_alias_entry;
      WHILEND;
    IFEND; {cycle_object}

  PROCEND syp$display_pde;

?? TITLE := 'PROCEDURE display_pt_stats', EJECT ??

  PROCEDURE display_pt_stats
    (    initial_pdu_pointer: ^fmt$path_description_unit;
     VAR status: ost$status);

    VAR
      cdu: ^fmt$cycle_description_unit,
      cdu_number: integer,
      depth: 1 .. fsc$max_path_elements,
      indent: bat$display_tables_indention,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      pdu: ^fmt$path_description_unit,
      pdu_number: integer;

    status.normal := TRUE;

    display_title ('PATH TABLE STATISTICS', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    indent := 5;

    STRINGREP (output_string, output_length, ' ': indent,
          'fmv$initial_pdu_pointer : ', initial_pdu_pointer);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'path_table_sizes (initial/allocated) : ',
          fmc$number_of_init_path_descs, '/', fmc$path_table_allocation_size);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    pdu := initial_pdu_pointer;
    pdu_number := 1;
    WHILE pdu <> NIL DO
      STRINGREP (output_string, output_length, ' ': indent,
            'total number of entries used in pdu ', pdu_number, ' : ',
            pdu^.total_count);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      STRINGREP (output_string, output_length, ' ': indent,
            'number of active entries in pdu ', pdu_number, ' : ',
            pdu^.current_count);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      pdu := pdu^.next_path_description_unit;
      pdu_number := pdu_number + 1;
    WHILEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'cycle_table_sizes (initial/allocated) : ',
          fmc$number_of_init_cycle_descs, '/', fmc$cycle_table_allocation_size);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_pt_stats;

?? TITLE := 'PROCEDURE display_unused_paths', EJECT ??

  PROCEDURE display_unused_paths
    (    initial_pdu_pointer: ^fmt$path_description_unit;
     VAR status: ost$status);

    VAR
      entry: 1 .. cyc$max_string_size,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      output_path: string (fsc$max_path_size + 8),
      path: string (fsc$max_path_size),
      path_handle: fmt$path_handle,
      path_handle_name: amt$local_file_name,
      path_length: fst$path_size,
      pde: ^fmt$path_description_entry,
      pdu: ^fmt$path_description_unit;

    status.normal := TRUE;

    { get pointer first entry in the first path_description_unit }
    pdu := initial_pdu_pointer;

    display_title ('PATH TABLE UNUSED PATHS', status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    WHILE pdu <> NIL DO

      { look at every assigned entry in a path_description_unit }
      FOR entry := 1 TO #SIZE (pdu^.entry_assignment^) DO
        IF pdu^.entry_assignment^ (entry) = fmc$entry_assigned THEN
          pde := ^pdu^.entries^ [entry];
          IF ((pde^.entry_type = fmc$file_cycle_object) AND
                (pde^.cycle_description = NIL)) OR
                ((pde^.entry_type = fmc$named_object) AND
                (pde^.active_path_participation_count = 0) AND
                (pde^.highest_cycle = NIL)) THEN
            get_path (pde, path, path_length, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            STRINGREP (output_path, output_length, ' path = ',
                  path (1, path_length));
            syp$write_output_line (output_path (1, output_length), status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            { create a path_handle_name for the cycle_object }
            path_handle.segment_offset := #OFFSET (pde);
            path_handle.assignment_counter := pde^.entry_assignment_counter;
            path_handle.open_position.specified := FALSE;
            clp$construct_path_handle_name (path_handle, path_handle_name);
            STRINGREP (output_string, output_length, ' ': 5,
                  'externalized = ', pde^.path_handle_name_externalized,
                  '    path_handle_name = ', path_handle_name( 1,
                  clp$trimmed_string_size( path_handle_name)));
            syp$write_output_line (output_string (1, output_length), status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

          IFEND; {end of a path}
        IFEND; {assigned}
      FOREND;

      { move on to next unit if pointer is not NIL}
      pdu := pdu^.next_path_description_unit;
    WHILEND;

  PROCEND display_unused_paths;

?? TITLE := ' PROCEDURE append_cycle_damage_symptoms', EJECT ??

  PROCEDURE append_cycle_damage_symptoms
    (    cycle_damage_symptoms: fst$cycle_damage_symptoms;
     VAR str: {i/o} string (300);
     VAR str_length: {i/o} integer);

    IF cycle_damage_symptoms = $fst$cycle_damage_symptoms [] THEN
      STRINGREP (str, str_length, str (1, str_length), 'NONE');
    ELSE
      STRINGREP (str, str_length, str (1, str_length), '(');
      IF fsc$media_image_inconsistent IN cycle_damage_symptoms THEN
        STRINGREP (str, str_length, str (1, str_length),
              'fsc$media_image_inconsistant, ');
      IFEND;
      IF fsc$respf_modification_mismatch IN cycle_damage_symptoms THEN
        STRINGREP (str, str_length, str (1, str_length),
              'fsc$respf_modification_mismatch, ');
      IFEND;
      IF fsc$cycle_restored IN cycle_damage_symptoms THEN
        STRINGREP (str, str_length, str (1, str_length), 'fsc$cycle_restored, ');
      IFEND;
      IF fsc$parent_catalog_restored IN cycle_damage_symptoms THEN
        STRINGREP (str, str_length, str (1, str_length), 'fsc$parent_catalog_restored, ');
      IFEND;
      str_length := str_length - 1;
      str (str_length) := ')';
    IFEND;

  PROCEND append_cycle_damage_symptoms;

?? TITLE := ' PROCEDURE append_file_access_options ', EJECT ??

  PROCEDURE append_file_access_options
    (    access_or_share_modes: fst$file_access_options;
     VAR str: {i/o} string (bat$display_tables_str_length);
     VAR str_length: {i/o} integer);

    IF access_or_share_modes = $fst$file_access_options [] THEN
      STRINGREP (str, str_length, str (1, str_length), 'NONE');
    ELSE
      STRINGREP (str, str_length, str (1, str_length), '(');
      IF fsc$read IN access_or_share_modes THEN
        STRINGREP (str, str_length, str (1, str_length), 'READ, ');
      IFEND;
      IF fsc$shorten IN access_or_share_modes THEN
        STRINGREP (str, str_length, str (1, str_length), 'SHORTEN, ');
      IFEND;
      IF fsc$append IN access_or_share_modes THEN
        STRINGREP (str, str_length, str (1, str_length), 'APPEND, ');
      IFEND;
      IF fsc$modify IN access_or_share_modes THEN
        STRINGREP (str, str_length, str (1, str_length), 'MODIFY, ');
      IFEND;
      IF fsc$execute IN access_or_share_modes THEN
        STRINGREP (str, str_length, str (1, str_length), 'EXECUTE, ');
      IFEND;
      str_length := str_length - 1;
      str (str_length) := ')';
    IFEND;

  PROCEND append_file_access_options;

?? TITLE := ' PROCEDURE append_message_control ', EJECT ??

  PROCEDURE append_logging_options
    (    logging_options: amt$logging_options;
     VAR str: {i/o} string (bat$display_tables_str_length);
     VAR str_length: {i/o} integer);

    IF logging_options = $amt$logging_options [] THEN
      STRINGREP (str, str_length, str (1, str_length), 'NONE');
    ELSE
      STRINGREP (str, str_length, str (1, str_length), '(');
      IF amc$enable_parcels IN logging_options THEN
        STRINGREP (str, str_length, str (1, str_length),
              'AMC$ENABLE_PARCELS, ');
      IFEND;
      IF amc$enable_media_recovery IN logging_options THEN
        STRINGREP (str, str_length, str (1, str_length),
              'AMC$ENABLE_MEDIA_RECOVERY, ');
      IFEND;
      IF amc$enable_request_recovery IN logging_options THEN
        STRINGREP (str, str_length, str (1, str_length),
              'AMC$ENABLE_REQUEST_RECOVERY, ');
      IFEND;
      str_length := str_length - 1;
      str (str_length) := ')';
    IFEND;

  PROCEND append_logging_options;

?? TITLE := ' PROCEDURE append_message_control ', EJECT ??

  PROCEDURE append_message_control
    (    message_control: amt$message_control;
     VAR str: {i/o} string (bat$display_tables_str_length);
     VAR str_length: {i/o} integer);

    IF message_control = $amt$message_control [] THEN
      STRINGREP (str, str_length, str (1, str_length), 'NONE');
    ELSE
      STRINGREP (str, str_length, str (1, str_length), '(');
      IF amc$trivial_errors IN message_control THEN
        STRINGREP (str, str_length, str (1, str_length),
              'AMC$TRIVIAL_ERRORS, ');
      IFEND;
      IF amc$messages IN message_control THEN
        STRINGREP (str, str_length, str (1, str_length), 'AMC$MESSAGES, ');
      IFEND;
      IF amc$statistics IN message_control THEN
        STRINGREP (str, str_length, str (1, str_length), 'AMC$STATISTICS, ');
      IFEND;
      str_length := str_length - 1;
      str (str_length) := ')';
    IFEND;

  PROCEND append_message_control;

?? TITLE := ' PROCEDURE append_usage_selections ', EJECT ??

  PROCEDURE append_usage_selections
    (    access_or_share_modes: pft$usage_selections;
     VAR str: {i/o} string (bat$display_tables_str_length);
     VAR str_length: {i/o} integer);

    IF access_or_share_modes = $pft$usage_selections [] THEN
      STRINGREP (str, str_length, str (1, str_length), 'NONE');
    ELSE
      STRINGREP (str, str_length, str (1, str_length), '(');
      IF pfc$read IN access_or_share_modes THEN
        STRINGREP (str, str_length, str (1, str_length), 'READ, ');
      IFEND;
      IF pfc$shorten IN access_or_share_modes THEN
        STRINGREP (str, str_length, str (1, str_length), 'SHORTEN, ');
      IFEND;
      IF pfc$append IN access_or_share_modes THEN
        STRINGREP (str, str_length, str (1, str_length), 'APPEND, ');
      IFEND;
      IF pfc$modify IN access_or_share_modes THEN
        STRINGREP (str, str_length, str (1, str_length), 'MODIFY, ');
      IFEND;
      IF pfc$execute IN access_or_share_modes THEN
        STRINGREP (str, str_length, str (1, str_length), 'EXECUTE, ');
      IFEND;
      IF pfc$cycle IN access_or_share_modes THEN
        STRINGREP (str, str_length, str (1, str_length), 'CYCLE, ');
      IFEND;
      IF pfc$control IN access_or_share_modes THEN
        STRINGREP (str, str_length, str (1, str_length), 'CONTROL, ');
      IFEND;
      str_length := str_length - 1;
      str (str_length) := ')';
    IFEND;

  PROCEND append_usage_selections;

?? TITLE := ' PROCEDURE display_apfid ', EJECT ??

  PROCEDURE display_apfid
    (    apfid: pft$attached_permanent_file_id,
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      output_length: integer,
      output_string: string (bat$display_tables_str_length);


    status.normal := TRUE;
    CASE apfid.family_location OF
    = pfc$local_mainframe =
      STRINGREP (output_string, output_length, ' ': indent,
            'pfc$local_mainframe - index : ', apfid.attached_pf_table_index);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    = pfc$server_mainframe =
      STRINGREP (output_string, output_length, ' ': indent,
            'pfc$server_mainframe - index : ', apfid.
            server_attached_pf_table_index);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      STRINGREP (output_string, output_length, ' ': indent,
            'Served family index : ', apfid.served_family_table_index.
            pointers_index, ' ', apfid.served_family_table_index.
            family_list_index);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      STRINGREP (output_string, output_length, ' ': indent,
            'Server lifetime : ', apfid.server_lifetime);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    ELSE
      STRINGREP (output_string, output_length, ' ': indent,
            ' UNKNOWN residence ');
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

    CASEND;
  PROCEND display_apfid;

?? TITLE := 'PROCEDURE display_cd_entry', EJECT ??

  PROCEDURE display_cd_entry
    (    cde: ^fmt$cycle_description;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      local_indent: bat$display_tables_indention,
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      path_handle_name: fst$path_handle_name;

    status.normal := TRUE;

    IF cde^.entry_assignment^ = fmc$entry_assigned THEN
      clp$construct_path_handle_name (cde^.path_handle, path_handle_name);
      STRINGREP (output_string, output_length, ' ': indent, 'path_handle_name : ',
            path_handle_name);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent,
            'global_file_information : ', cde^.global_file_information);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF cde^.global_file_information <> NIL THEN
        syp$display_global_file_info (cde^.global_file_information,
              indent + 4, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent,
            'static_setfa_entries : ',
            cde^.static_setfa_entries);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent,
            'dynamic_setfa_entries : ',
            cde^.dynamic_setfa_entries);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'cd_attachment_options : ',
            cde^.cd_attachment_options);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF cde^.cd_attachment_options <> NIL THEN
        IF cde^.cd_attachment_options^.free_behind_specified THEN
          STRINGREP (output_string, output_length, ' ': indent+4, 'free_behind : ',
                cde^.cd_attachment_options^.free_behind);
          syp$write_output_line (output_string (1, output_length), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        IF cde^.cd_attachment_options^.job_write_concurrency_specified THEN
          STRINGREP (output_string, output_length, ' ': indent+4, 'job_write_concurrency : ',
                cde^.cd_attachment_options^.job_write_concurrency);
          syp$write_output_line (output_string (1, output_length), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        IF cde^.cd_attachment_options^.private_read_specified THEN
          STRINGREP (output_string, output_length, ' ': indent+4, 'private_read : ',
                cde^.cd_attachment_options^.private_read);
          syp$write_output_line (output_string (1, output_length), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        IF cde^.cd_attachment_options^.sequential_access_specified THEN
          STRINGREP (output_string, output_length, ' ': indent+4, 'sequential_access : ',
                cde^.cd_attachment_options^.sequential_access);
          syp$write_output_line (output_string (1, output_length), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
        IF cde^.cd_attachment_options^.transfer_size_specified THEN
          STRINGREP (output_string, output_length, ' ': indent+4, 'transfer_size : ',
                cde^.cd_attachment_options^.transfer_size);
          syp$write_output_line (output_string (1, output_length), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        IFEND;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent,
            'attached_file : ', cde^.attached_file);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF cde^.attached_file THEN
        local_indent := indent + 4;
        STRINGREP (output_string, output_length, ' ': local_indent,
              'system_file_label  ');
        syp$write_output_line (output_string (1, output_length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        display_system_file_label (^cde^.system_file_label, local_indent + 4,
              status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        put_device_class (cde^.device_class, local_indent, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        local_indent := local_indent + 4;
        CASE cde^.device_class OF
        = rmc$magnetic_tape_device, rmc$mass_storage_device =
          STRINGREP (output_string, output_length, ' ': local_indent,
                'job_routing_label : ', cde^.job_routing_label);
          syp$write_output_line (output_string (1, output_length), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          STRINGREP (output_string, output_length, ' ': local_indent,
                'job_routing_label_length : ', cde^.job_routing_label_length);
          syp$write_output_line (output_string (1, output_length), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          STRINGREP (output_string, output_length, ' ': local_indent,
                'system_file_id : ',
                cde^.system_file_id.file_entry_index, ' ',
                cde^.system_file_id.residence, ' ',
                cde^.system_file_id.file_hash);
          syp$write_output_line (output_string (1, output_length), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          STRINGREP (output_string, output_length, ' ': local_indent,
                'permanent_file : ', cde^.permanent_file);
          syp$write_output_line (output_string (1, output_length), status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;

          IF cde^.permanent_file THEN
            local_indent := local_indent + 4;
            display_apfid (cde^.apfid, local_indent, status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            STRINGREP (output_string, output_length, ' ': local_indent,
                  'attached_access_modes : ');
            append_file_access_options (cde^.attached_access_modes,
                  output_string, output_length);
            syp$write_output_line (output_string (1, output_length), status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            STRINGREP (output_string, output_length, ' ': local_indent,
                  'attached_share_modes : ');
            append_file_access_options (cde^.attached_share_modes, output_string,
                  output_length);
            syp$write_output_line (output_string (1, output_length), status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            STRINGREP (output_string, output_length, ' ': local_indent,
                  'password_protected : ', cde^.password_protected);
            syp$write_output_line (output_string (1, output_length), status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;

            STRINGREP (output_string, output_length, ' ': local_indent,
                  'system_file_label_catalogued : ', cde^.system_file_label_catalogued);
            syp$write_output_line (output_string (1, output_length), status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          IFEND;
        ELSE
        CASEND;
      IFEND;
    ELSE
      STRINGREP (output_string, output_length, ' ': indent,
            'cycle_description_entry not assigned');
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND display_cd_entry;

?? TITLE := 'PROCEDURE display_descriptive_attr', EJECT ??

  PROCEDURE display_descriptive_attr
    (    descriptive: ^bat$descriptive_file_attributes;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      global_file_name: ost$name,
      output_length: integer,
      output_string: string (bat$display_tables_str_length);

    status.normal := TRUE;

    STRINGREP (output_string, output_length, ' ': indent,
          'application_info : ', descriptive^.application_info);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (descriptive^.application_info_source, indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'global_access_mode : ');
    append_usage_selections (descriptive^.global_access_mode, output_string,
          output_length);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (descriptive^.global_access_mode_source, indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    global_file_name := 'NOT DISPLAYED';
{   pmp$convert_binary_unique_name (descriptive^.global_file_name,
{        global_file_name, status);
{   IF NOT status.normal THEN
{     RETURN;
{   IFEND;
    STRINGREP (output_string, output_length, ' ': indent,
          'global_file_name : ', global_file_name);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (descriptive^.global_file_name_source, indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    global_file_name := 'NOT DISPLAYED';
{   pmp$convert_binary_unique_name (descriptive^.global_file_name,
{        global_file_name, status);
{   IF NOT status.normal THEN
{     RETURN;
{   IFEND;
    STRINGREP (output_string, output_length, ' ': indent,
          'internal_cycle_name : ', global_file_name);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (descriptive^.global_file_name_source, indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'global_share_mode : ');
    append_usage_selections (descriptive^.global_share_mode, output_string,
          output_length);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (descriptive^.global_share_mode_source, indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'permanent_file : ',
          descriptive^.permanent_file);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (descriptive^.permanent_file_source, indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_descriptive_attr;

?? TITLE := 'PROCEDURE display_file_cycle_object', EJECT ??

  PROCEDURE display_file_cycle_object
    (    pde: ^fmt$path_description_entry;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      output_length: integer,
      output_string: string (bat$display_tables_str_length);

    status.normal := TRUE;

    STRINGREP (output_string, output_length, ' ': indent, 'cycle_number : ',
          pde^.cycle_number);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'next_lower_cycle : ', pde^.next_lower_cycle);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'next_higher_cycle : ', pde^.next_higher_cycle);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'first_cycle_alias_entry : ', pde^.first_cycle_alias_entry);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'cycle_description : ', pde^.cycle_description);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pde^.cycle_description <> NIL THEN
      display_cd_entry (pde^.cycle_description, indent + 4, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

  PROCEND display_file_cycle_object;

?? TITLE := 'PROCEDURE [XDCL] syp$display_global_file_info', EJECT ??

  PROCEDURE [XDCL] syp$display_global_file_info
    (    gfi: ^bat$global_file_information;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      cycle_damage_string: string (300),
      local_indent: bat$display_tables_indention,
      output_length: integer,
      output_string: string (bat$display_tables_str_length);

    status.normal := TRUE;

    STRINGREP (output_string, output_length, ' ': indent, 'open_count : ',
          gfi^.open_count);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'open_lock : ',
          gfi^.open_lock.lock_id);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'implicit_detach_inhibited : ',
          gfi^.implicit_detach_inhibited);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (cycle_damage_string, output_length, ' ': indent,
          'cycle_damage_symptoms : ');
    append_cycle_damage_symptoms (gfi^.cycle_damage_symptoms,
          cycle_damage_string, output_length);
    syp$write_output_line (cycle_damage_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;


    STRINGREP (output_string, output_length, ' ': indent,
          'device_dependent_info');
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    put_device_class (gfi^.device_dependent_info.device_class, indent + 4,
           status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'eoi_byte_address : ', gfi^.eoi_byte_address);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'eoi_set : ',
          gfi^.eoi_set);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'file_limit : ',
          gfi^.file_limit);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'max_block_size : ',
          gfi^.max_block_size);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'max_data_size : ',
          gfi^.max_data_size);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'max_record_length : ', gfi^.max_record_length);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'min_block_length : ', gfi^.min_block_length);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'opened_access_modes : read=', gfi^.opened_access_modes [fsc$read],
          ' shorten=', gfi^.opened_access_modes [fsc$shorten], ' append=',
          gfi^.opened_access_modes [fsc$append], ' modify=',
          gfi^.opened_access_modes [fsc$modify], ' execute=',
          gfi^.opened_access_modes [fsc$execute]);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'padding_character : ',
          $INTEGER (gfi^.padding_character): #(16), '(16)');
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'positioning_info : ');
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_indent := indent + 4;
    STRINGREP (output_string, output_length, ' ': local_indent,
          'block_info ');
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_indent := local_indent + 4;
    STRINGREP (output_string, output_length, ' ': local_indent,
          'block_number : ', gfi^.positioning_info.block_info.block_number);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'block_position : ', gfi^.positioning_info.block_info.block_position);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'current_block_byte_address : ', gfi^.positioning_info.block_info.
          current_block_byte_address);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'current_block_length : ', gfi^.positioning_info.block_info.
          current_block_length);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'previous_block_header_fba : ', gfi^.positioning_info.block_info.
          previous_block_header_fba);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'residual_block_length : ', gfi^.positioning_info.block_info.
          residual_block_length);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_indent := indent + 4;
    STRINGREP (output_string, output_length, ' ': local_indent,
          'record_info ');
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_indent := local_indent + 4;
    STRINGREP (output_string, output_length, ' ': local_indent, 'bor_address : ',
          gfi^.positioning_info.record_info.bor_address);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'current_byte_address : ', gfi^.positioning_info.record_info.
          current_byte_address);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent, 'file_position : ',
          gfi^.positioning_info.record_info.file_position);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'record_header_fba : ', gfi^.positioning_info.record_info.
          record_header_fba);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'record_length : ', gfi^.positioning_info.record_info.record_length);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'residual_record_length : ', gfi^.positioning_info.record_info.
          residual_record_length);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'transfer_count : ', gfi^.positioning_info.record_info.
          transfer_count);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'prevented_open_access_modes : read=',
          gfi^.prevented_open_access_modes [fsc$read], ' shorten=',
          gfi^.prevented_open_access_modes [fsc$shorten], ' append=',
          gfi^.prevented_open_access_modes [fsc$append], ' modify=',
          gfi^.prevented_open_access_modes [fsc$modify], ' execute=',
          gfi^.prevented_open_access_modes [fsc$execute]);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'record_delimiting_character : ',
          $INTEGER (gfi^.record_delimiting_character):#(16), '(16)');
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND syp$display_global_file_info;

?? TITLE := 'PROCEDURE display_instance_attributes', EJECT ??

  PROCEDURE display_instance_attributes
    (    instance_attributes: ^bat$instance_attributes;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      local_indent: bat$display_tables_indention,
      output_length: integer,
      output_string: string (bat$display_tables_str_length);

    status.normal := TRUE;

    STRINGREP (output_string, output_length, ' ': indent,
          'instance_attributes.static_label');
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    local_indent := indent + 4;
    STRINGREP (output_string, output_length, ' ': local_indent,
          'block_type : ', instance_attributes^.static_label.block_type);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (instance_attributes^.static_label.block_type_source,
          local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'file_organization : ', instance_attributes^.static_label.
          file_organization);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (instance_attributes^.static_label.file_organization_source,
          local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'record_type : ', instance_attributes^.static_label.record_type);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (instance_attributes^.static_label.record_type_source,
          local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'ring_attributes.r1 : ', instance_attributes^.static_label.
          ring_attributes.r1);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (output_string, output_length, ' ': local_indent,
          'ring_attributes.r2 : ', instance_attributes^.static_label.
          ring_attributes.r2);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (output_string, output_length, ' ': local_indent,
          'ring_attributes.r3 : ', instance_attributes^.static_label.
          ring_attributes.r3);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (instance_attributes^.static_label.ring_attributes_source,
          local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'instance_attributes.dynamic_label');
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'access_mode : ');
    append_usage_selections (instance_attributes^.dynamic_label.access_mode,
          output_string, output_length);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (instance_attributes^.dynamic_label.access_mode_source,
          local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'error_exit_name : ', instance_attributes^.dynamic_label.
          error_exit_name);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (instance_attributes^.dynamic_label.error_exit_name_source,
          local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'error_exit_procedure : ', instance_attributes^.dynamic_label.
          error_exit_procedure);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (instance_attributes^.dynamic_label.error_exit_procedure_source,
          local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'perform_failure_recovery : ', instance_attributes^.dynamic_label.
          error_options.perform_failure_recovery, '    error_action : ',
          instance_attributes^.dynamic_label.error_options.error_action);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (instance_attributes^.dynamic_label.error_options_source,
          local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'label_exit_name : ', instance_attributes^.dynamic_label.
          label_exit_name);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (instance_attributes^.dynamic_label.label_exit_name_source,
          local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'label_exit_procedure : ', instance_attributes^.dynamic_label.
          label_exit_procedure);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (instance_attributes^.dynamic_label.label_exit_procedure_source,
          local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    CASE instance_attributes^.dynamic_label.open_position OF
    = amc$open_at_boi =
      STRINGREP (output_string, output_length, ' ': local_indent,
            'open_position : amc$open_at_boi');
    = amc$open_no_positioning =
      STRINGREP (output_string, output_length, ' ': local_indent,
            'open_position : amc$open_no_positioning');
    = amc$open_at_eoi =
      STRINGREP (output_string, output_length, ' ': local_indent,
            'open_position : amc$open_at_eoi');
    ELSE
      STRINGREP (output_string, output_length, ' ': local_indent,
            'open_position : INVALID OPEN_POSITION');
    CASEND;
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (instance_attributes^.dynamic_label.open_position_source,
          local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'open_share_modes : ');
    append_file_access_options (instance_attributes^.dynamic_label.
          open_share_modes, output_string, output_length);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (instance_attributes^.dynamic_label.open_share_modes_source,
          local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'return_option : ', instance_attributes^.dynamic_label.
          return_option);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (instance_attributes^.dynamic_label.return_option_source,
          local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'error_limit : ', instance_attributes^.dynamic_label.error_limit);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (instance_attributes^.dynamic_label.error_limit_source,
          local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': local_indent,
          'message_control : ');
    append_message_control (instance_attributes^.dynamic_label.message_control,
          output_string, output_length);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    put_source (instance_attributes^.dynamic_label.message_control_source,
          local_indent, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_instance_attributes;

?? TITLE := 'PROCEDURE display_named_object', EJECT ??

  PROCEDURE display_named_object
    (    pde: ^fmt$path_description_entry;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      output_length: integer,
      output_string: string (bat$display_tables_str_length);

    status.normal := TRUE;

    STRINGREP (output_string, output_length, ' ': indent,
          'active_path_participation_count : ',
          pde^.active_path_participation_count);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'parental_tree_entry : ', pde^.parental_tree_entry);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'left_subtree : ',
          pde^.left_subtree);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'right_subtree : ',
          pde^.right_subtree);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'path_node_name : ',
          pde^.path_node_name.value);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'randomized_node_name : ', pde^.randomized_node_name);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'highest_cycle : ',
          pde^.highest_cycle);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'next_cycle_alias_entry : ', pde^.next_cycle_alias_entry);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_named_object;

?? TITLE := 'PROCEDURE display_pde', EJECT ??

  PROCEDURE display_pde
    (    pde: ^fmt$path_description_entry;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      output_length: integer,
      output_string: string (bat$display_tables_str_length);


    status.normal := TRUE;
    IF (pde^.unique_identifier = fmc$pde_unique_identifier) AND
          (pde^.entry_assignment^ = fmc$entry_assigned) THEN

      STRINGREP (output_string, output_length, ' ': indent,
            'unique_identifier : ', pde^.unique_identifier: #(16), '(16)');
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent,
            'cumulative_parental_path_size : ',
            pde^.cumulative_parental_path_size);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent, 'path_depth : ',
            pde^.path_depth);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent,
            'entry_assignment_counter : ',
            pde^.entry_assignment_counter:#(16), '(16)');
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent,
            'parental_path_entry : ', pde^.parental_path_entry);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': indent,
            'path_handle_name_externalized : ', pde^.path_handle_name_externalized);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      CASE pde^.entry_type OF
      = fmc$named_object =
        STRINGREP (output_string, output_length, ' ': indent,
              'entry_type : fmc$named_object');
        syp$write_output_line (output_string (1, output_length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        display_named_object (pde, indent + 4, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      = fmc$file_cycle_object =
        STRINGREP (output_string, output_length, ' ': indent,
              'entry_type : fmc$file_cycle_object');
        syp$write_output_line (output_string (1, output_length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        display_file_cycle_object (pde, indent + 4, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

      ELSE
      CASEND

    ELSE
      IF pde^.unique_identifier <> fmc$pde_unique_identifier THEN
        STRINGREP (output_string, output_length, ' ': indent,
              'Invalid pde passed to display_pde');
        syp$write_output_line (output_string (1, output_length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        STRINGREP (output_string, output_length, ' ': indent,
              'Entry not assigned');
        syp$write_output_line (output_string (1, output_length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

  PROCEND display_pde;

?? TITLE := 'PROCEDURE display_system_file_label', EJECT ??

  PROCEDURE display_system_file_label
    (    sfl: ^fmt$system_file_label;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      attribute_key: fmt$file_attribute_keys,
      header: ^fmt$static_label_header,
      local_indent: bat$display_tables_indention,
      name: pmt$program_name,
      output_length: integer,
      output_path: string (amc$max_path_name_size + 100),
      output_string: string (bat$display_tables_str_length),
      path: amt$path_name,
      path_length: 0 .. amc$max_path_name_size,
      static_label: ^SEQ ( * ),
      static_label_item: ^fmt$static_label_item,
      str: ^string ( * );

    PROCEDURE [INLINE] get_entry_point_reference
      (VAR name: pmt$program_name;
       VAR path: amt$file_reference;
       VAR path_length: 0 .. amc$max_path_name_size);

      NEXT str: [static_label_item^.entry_point_name_length] IN static_label;
      name := str^;
      path_length := static_label_item^.entry_point_path_length;
      IF static_label_item^.entry_point_path_length > 0 THEN
        NEXT str: [static_label_item^.entry_point_path_length] IN static_label;
        path := str^;
      IFEND;
    PROCEND get_entry_point_reference;

    PROCEDURE [INLINE] get_name
      (VAR name: pmt$program_name);

      NEXT str: [static_label_item^.name_length] IN static_label;
      name := str^;
    PROCEND get_name;

    status.normal := TRUE;

    STRINGREP (output_string, output_length, ' ': indent,
          'file_previously_opened : ', sfl^.file_previously_opened);
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent, 'static_label : ',
          sfl^.static_label);
    { pointer to seq }
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF sfl^.static_label <> NIL THEN
      static_label := sfl^.static_label;
      local_indent := indent + 4;

      RESET static_label;
      NEXT header IN static_label;
      STRINGREP (output_string, output_length, ' ': local_indent,
            'unique_character : ', header^.unique_character);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': local_indent,
            'revision_level : ', header^.revision_level);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': local_indent,
            'highest_attribute_present : ', header^.highest_attribute_present);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': local_indent,
            'highest_attribute_supported : ',
            header^.highest_attribute_supported);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': local_indent,
            'job_routing_label_size : ', header^.job_routing_label_size);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': local_indent,
            'default_revision_level : ', header^.default_revision_level);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': local_indent,
            'user_attribute_length : ', header^.user_attribute_length);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      STRINGREP (output_string, output_length, ' ': local_indent,
            'file_previously_opened : ', header^.file_previously_opened);
      syp$write_output_line (output_string (1, output_length), status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      IF header^.file_previously_opened THEN
        STRINGREP (output_string, output_length, ' ': local_indent + 4,
              'ring_attributes : ', header^.ring_attributes.r1, ' ',
              header^.ring_attributes.r2, ' ', header^.ring_attributes.r3);
        syp$write_output_line (output_string (1, output_length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;

      IF header^.highest_attribute_present > 0 THEN
        STRINGREP (output_string, output_length, ' ': local_indent,
              'static_label_attributes - nondefault values');
        syp$write_output_line (output_string (1, output_length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        local_indent := local_indent + 4;
        FOR attribute_key := LOWERBOUND (header^.attribute_present) TO header^.
              highest_attribute_present DO
          CASE attribute_key OF
          = fmc$block_type =
            IF header^.attribute_present [fmc$block_type] THEN
              NEXT static_label_item: [fmc$block_type] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'block_type : ', static_label_item^.block_type);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$character_conversion =
            IF header^.attribute_present [fmc$character_conversion] THEN
              NEXT static_label_item: [fmc$character_conversion] IN
                    static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'character_conversion : ', static_label_item^.
                    character_conversion);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$clear_space =
            IF header^.attribute_present [fmc$clear_space] THEN
              NEXT static_label_item: [fmc$clear_space] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'clear_space : ', static_label_item^.clear_space);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$file_access_procedure =
            IF header^.attribute_present [fmc$file_access_procedure] THEN
              NEXT static_label_item: [fmc$file_access_procedure] IN
                    static_label;
              get_entry_point_reference (name, path, path_length);
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'file_access_procedure : ', name);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$file_contents =
            IF header^.attribute_present [fmc$file_contents] THEN
              NEXT static_label_item: [fmc$file_contents] IN static_label;
              get_name (name);
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'file_contents : ', name);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$file_limit =
            IF header^.attribute_present [fmc$file_limit] THEN
              NEXT static_label_item: [fmc$file_limit] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'file_limit : ', static_label_item^.integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$file_organization =
            IF header^.attribute_present [fmc$file_organization] THEN
              NEXT static_label_item: [fmc$file_organization] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'file_organization : ', static_label_item^.
                    file_organization);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$file_processor =
            IF header^.attribute_present [fmc$file_processor] THEN
              NEXT static_label_item: [fmc$file_processor] IN static_label;
              get_name (name);
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'file_processor : ', name);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$file_structure =
            IF header^.attribute_present [fmc$file_structure] THEN
              NEXT static_label_item: [fmc$file_structure] IN static_label;
              get_name (name);
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'file_structure : ', name);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$forced_write =
            IF header^.attribute_present [fmc$forced_write] THEN
              NEXT static_label_item: [fmc$forced_write] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'forced_write : ', static_label_item^.forced_write);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$internal_code =
            IF header^.attribute_present [fmc$internal_code] THEN
              NEXT static_label_item: [fmc$internal_code] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'internal_code : ', static_label_item^.internal_code);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$label_type =
            IF header^.attribute_present [fmc$label_type] THEN
              NEXT static_label_item: [fmc$label_type] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'label_type : ', static_label_item^.label_type);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$line_number =
            IF header^.attribute_present [fmc$line_number] THEN
              NEXT static_label_item: [fmc$line_number] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'line_number.length : ', static_label_item^.line_number.
                    length, '  line_number.location : ',
                    static_label_item^.line_number.location);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$max_block_length =
            IF header^.attribute_present [fmc$max_block_length] THEN
              NEXT static_label_item: [fmc$max_block_length] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'max_block_length : ', static_label_item^.integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$max_record_length =
            IF header^.attribute_present [fmc$max_record_length] THEN
              NEXT static_label_item: [fmc$max_record_length] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'max_record_length : ', static_label_item^.integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$min_block_length =
            IF header^.attribute_present [fmc$min_block_length] THEN
              NEXT static_label_item: [fmc$min_block_length] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'min_block_length : ', static_label_item^.integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$min_record_length =
            IF header^.attribute_present [fmc$min_record_length] THEN
              NEXT static_label_item: [fmc$min_record_length] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'min_record_length : ', static_label_item^.integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$padding_character =
            IF header^.attribute_present [fmc$padding_character] THEN
              NEXT static_label_item: [fmc$padding_character] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'padding_character : ', $INTEGER (static_label_item^.
                    padding_character): #(16), '(16)');
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$page_format =
            IF header^.attribute_present [fmc$page_format] THEN
              NEXT static_label_item: [fmc$page_format] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'page_format : ', static_label_item^.page_format);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$page_length =
            IF header^.attribute_present [fmc$page_length] THEN
              NEXT static_label_item: [fmc$page_length] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'page_length : ', static_label_item^.integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$page_width =
            IF header^.attribute_present [fmc$page_width] THEN
              NEXT static_label_item: [fmc$page_width] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'page_width : ', static_label_item^.integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$preset_value =
            IF header^.attribute_present [fmc$preset_value] THEN
              NEXT static_label_item: [fmc$preset_value] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'preset_value : ', static_label_item^.integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$record_delimiting_character =
            IF header^.attribute_present [fmc$record_delimiting_character] THEN
              NEXT static_label_item: [fmc$record_delimiting_character] IN
                    static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'record_delimiting_character : ',
                    $INTEGER (static_label_item^.record_delimiting_character): #(16), '(16)');
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$record_type =
            IF header^.attribute_present [fmc$record_type] THEN
              NEXT static_label_item: [fmc$record_type] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'record_type : ', static_label_item^.record_type);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$ring_attributes =
            { processed above prior to FOR loop }
            ;
          = fmc$statement_identifier =
            IF header^.attribute_present [fmc$statement_identifier] THEN
              NEXT static_label_item: [fmc$statement_identifier] IN
                    static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'statement_identifier :  length = ',
                    static_label_item^.statement_identifier.length,
                    ' location = ', static_label_item^.statement_identifier.
                    location);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$user_info =
            IF header^.attribute_present [fmc$user_info] THEN
              NEXT static_label_item: [fmc$user_info] IN static_label;
              IF static_label_item^.user_info_present THEN
                NEXT str: [32] IN static_label;
                STRINGREP (output_string, output_length, ' ': local_indent,
                      'user_info : ', str^);
                syp$write_output_line (output_string (1, output_length), status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
                put_source (static_label_item^.source, local_indent, status);
                IF NOT status.normal THEN
                  RETURN;
                IFEND;
              IFEND;
            IFEND;
          = fmc$vertical_print_density =
            IF header^.attribute_present [fmc$vertical_print_density] THEN
              NEXT static_label_item: [fmc$vertical_print_density] IN
                    static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'vertical_print_density : ', static_label_item^.
                    integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$average_record_length =
            IF header^.attribute_present [fmc$average_record_length] THEN
              NEXT static_label_item: [fmc$average_record_length] IN
                    static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'average_record_length : ', static_label_item^.
                    integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$collate_table =
            IF header^.attribute_present [fmc$collate_table] THEN
              NEXT static_label_item: [fmc$collate_table] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'collate_table : set but not displayed');
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$collate_table_name =
            IF header^.attribute_present [fmc$collate_table_name] THEN
              NEXT static_label_item: [fmc$collate_table_name] IN static_label;
              get_entry_point_reference (name, path, path_length);
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'collate_table_name : ', name);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$compression_procedure_name =
            IF header^.attribute_present [fmc$compression_procedure_name] THEN
              NEXT static_label_item: [fmc$compression_procedure_name] IN
                    static_label;
              get_entry_point_reference (name, path, path_length);
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'compression_procedure_name.name : ', name);
              syp$write_output_line (output_string (1, output_length), status);
              STRINGREP (output_path, output_length, ' ': local_indent,
                    'compression_procedure_name.object_library : ',
                    path (1, path_length));
              syp$write_output_line (output_path (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$data_padding =
            IF header^.attribute_present [fmc$data_padding] THEN
              NEXT static_label_item: [fmc$data_padding] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'data_padding : ', static_label_item^.data_padding);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$dynamic_home_block_space =
            IF header^.attribute_present [fmc$dynamic_home_block_space] THEN
              NEXT static_label_item: [fmc$dynamic_home_block_space] IN
                    static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'dynamic_home_block_space : ',
                    static_label_item^.dynamic_home_block_space);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$embedded_key =
            IF header^.attribute_present [fmc$embedded_key] THEN
              NEXT static_label_item: [fmc$embedded_key] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'embedded_key : ', static_label_item^.embedded_key);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$estimated_record_count =
            IF header^.attribute_present [fmc$estimated_record_count] THEN
              NEXT static_label_item: [fmc$estimated_record_count] IN
                    static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'estimated_record_count : ', static_label_item^.
                    integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$hashing_procedure_name =
            IF header^.attribute_present [fmc$hashing_procedure_name] THEN
              NEXT static_label_item: [fmc$hashing_procedure_name] IN
                    static_label;
              get_entry_point_reference (name, path, path_length);
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'hashing_procedure_name.name : ', name);
              syp$write_output_line (output_string (1, output_length), status);
              STRINGREP (output_path, output_length, ' ': local_indent,
                    'hashing_procedure_name.object_library : ',
                    path (1, path_length));
              syp$write_output_line (output_path (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$index_levels =
            IF header^.attribute_present [fmc$index_levels] THEN
              NEXT static_label_item: [fmc$index_levels] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'index_levels : ', static_label_item^.integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$index_padding =
            IF header^.attribute_present [fmc$index_padding] THEN
              NEXT static_label_item: [fmc$index_padding] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'index_padding : ', static_label_item^.index_padding);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$initial_home_block_count =
            IF header^.attribute_present [fmc$initial_home_block_count] THEN
              NEXT static_label_item: [fmc$initial_home_block_count] IN
                    static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'initial_home_block_count : ',
                    static_label_item^.integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$key_length =
            IF header^.attribute_present [fmc$key_length] THEN
              NEXT static_label_item: [fmc$key_length] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'key_length : ', static_label_item^.integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$key_position =
            IF header^.attribute_present [fmc$key_position] THEN
              NEXT static_label_item: [fmc$key_position] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'key_position : ', static_label_item^.integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$key_type =
            IF header^.attribute_present [fmc$key_type] THEN
              NEXT static_label_item: [fmc$key_type] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'key_type : ', static_label_item^.key_type);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$loading_factor =
            IF header^.attribute_present [fmc$loading_factor] THEN
              NEXT static_label_item: [fmc$loading_factor] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'loading_factor : ', static_label_item^.loading_factor);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$lock_expiration_time =
            IF header^.attribute_present [fmc$lock_expiration_time] THEN
              NEXT static_label_item: [fmc$lock_expiration_time] IN
                    static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'lock_expiration_time : ', static_label_item^.
                    integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$logging_options =
            IF header^.attribute_present [fmc$logging_options] THEN
              NEXT static_label_item: [fmc$logging_options] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'logging_options : ');
              append_logging_options (static_label_item^.logging_options,
                    output_string, output_length);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$log_residence =
            IF header^.attribute_present [fmc$log_residence] THEN
              NEXT static_label_item: [fmc$log_residence] IN static_label;
              NEXT str: [static_label_item^.path_length] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'log_residence : ', str^);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$record_limit =
            IF header^.attribute_present [fmc$record_limit] THEN
              NEXT static_label_item: [fmc$record_limit] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'record_limit : ', static_label_item^.integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          = fmc$records_per_block =
            IF header^.attribute_present [fmc$records_per_block] THEN
              NEXT static_label_item: [fmc$records_per_block] IN static_label;
              STRINGREP (output_string, output_length, ' ': local_indent,
                    'records_per_block : ', static_label_item^.integer_value);
              syp$write_output_line (output_string (1, output_length), status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
              put_source (static_label_item^.source, local_indent, status);
              IF NOT status.normal THEN
                RETURN;
              IFEND;
            IFEND;
          ELSE
          CASEND;
        FOREND;
      ELSE
        STRINGREP (output_string, output_length, ' ': local_indent,
              'NO static_label_attributes present');
        syp$write_output_line (output_string (1, output_length), status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      IFEND;
    IFEND;

    STRINGREP (output_string, output_length, ' ': indent,
          'descriptive_file_attributes ');
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    display_descriptive_attr (^sfl^.descriptive_label, indent + 4, status);

  PROCEND display_system_file_label;

?? TITLE := 'PROCEDURE display_title', EJECT ??

  PROCEDURE display_title
    (    title: string ( * <= title_length);
     VAR status: ost$status);

    CONST
      asterisks_constant = '****************************************' CAT
            '****************************************';

    VAR
      asterisks: string (80),
      output_length: integer,
      output_string: string (bat$display_tables_str_length);

    status.normal := TRUE;

    asterisks := asterisks_constant;
    STRINGREP (output_string, output_length, '1', asterisks (1, title_length));
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (output_string, output_length, ' ',
          asterisks (1, ((title_length DIV 2) - (STRLENGTH (title) DIV 2) - 2
          {spaces} )), '  ', title, '  ', asterisks
          (1, (((title_length + 1) DIV 2) - ((STRLENGTH (title) + 1) DIV 2) - 2
          {spaces} )));
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    STRINGREP (output_string, output_length, ' ', asterisks (1, title_length));
    syp$write_output_line (output_string (1, output_length), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    output_string := '- ';
    syp$write_output_line (output_string (1, 2), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND display_title;

?? TITLE := 'PROCEDURE get_path', EJECT ??

  PROCEDURE get_path
    (    path_description_entry: ^fmt$path_description_entry;
     VAR path: fst$path;
     VAR path_length: fst$path_size;
     VAR status: ost$status);

    { PURPOSE: Given a path_description_entry, recreate a path to that node.
    {          A string containing the path is returned.

    VAR
      cycle_string: ost$string,
      pde: ^fmt$path_description_entry;

    status.normal := TRUE;
    pde := path_description_entry;
    path := osc$null_name;

    { Note: path depth is the same in last element and it's cycle objects }

    { Fill in cycle number if file cycle object. }
    IF pde^.entry_type = fmc$file_cycle_object THEN
      clp$convert_integer_to_string (pde^.cycle_number, 10, FALSE,
            cycle_string, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      path (pde^.cumulative_parental_path_size + 1, 1) := '.';
      path (pde^.cumulative_parental_path_size + 2,
            cycle_string.size) := cycle_string.value;
      path_length := pde^.cumulative_parental_path_size + cycle_string.size +
            1;
      { Move up the tree. }
      pde := pde^.parental_path_entry;
    ELSE
      path_length := pde^.cumulative_parental_path_size +
            pde^.path_node_name.size + 1;
    IFEND;

    { Fill in each path element name from last to first. }
    REPEAT
      path (pde^.cumulative_parental_path_size + 1, 1) := '.';
      path (pde^.cumulative_parental_path_size + 2,
            pde^.path_node_name.size) := pde^.path_node_name.value;
      pde := pde^.parental_path_entry;
    UNTIL pde = NIL;
    path (1, 1) := ':';

  PROCEND get_path;

?? TITLE := 'PROCEDURE put_device_class', EJECT ??

  PROCEDURE put_device_class
    (    device_class: rmt$device_class;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      device_class_string: ost$name;

    status.normal := TRUE;

    CASE device_class OF
    = rmc$connected_file_device =
      device_class_string := 'rmc$connect_file_device';
    = rmc$interstate_link_device =
      device_class_string := 'rmc$interstate_link_device';
    = rmc$local_queue_device =
      device_class_string := 'rmc$local_queue_device';
    = rmc$log_device =
      device_class_string := 'rmc$log_device';
    = rmc$magnetic_tape_device =
      device_class_string := 'rmc$magnetic_tape_device';
    = rmc$mass_storage_device =
      device_class_string := 'rmc$mass_storage_device';
    = rmc$memory_resident_device =
      device_class_string := 'rmc$memory_resident_device';
    = rmc$network_device =
      device_class_string := 'rmc$network_device';
    = rmc$null_device =
      device_class_string := 'rmc$null_device';
    = rmc$pipeline_device =
      device_class_string := 'rmc$pipeline_device';
    = rmc$rhfam_device =
      device_class_string := 'rmc$rhfam_device';
    = rmc$terminal_device =
      device_class_string := 'rmc$terminal_device';
    ELSE
      device_class_string := 'UNKNOWN';
    CASEND;

    STRINGREP (output_string, output_length, ' ': indent, 'device_class : ',
          device_class_string);
    syp$write_output_line (output_string (1, output_length), status);

  PROCEND put_device_class;

?? TITLE := 'PROCEDURE put_source', EJECT ??

  PROCEDURE put_source
    (    source: amt$attribute_source;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

    VAR
      output_length: integer,
      output_string: string (bat$display_tables_str_length),
      source_string: ost$name;

    status.normal := TRUE;

    CASE source OF
    = amc$undefined_attribute =
      source_string := 'amc$undefined_attribute';
    = amc$local_file_information =
      source_string := 'amc$local_file_information';
    = amc$change_file_attributes =
      source_string := 'amc$change_file_attributes';
    = amc$open_request =
      source_string := 'amc$open_request';
    = amc$file_reference =
      source_string := 'amc$file_reference';
    = amc$file_command =
      source_string := 'amc$file_command';
    = amc$file_request =
      source_string := 'amc$file_request';
    = amc$add_to_file_description =
      source_string := 'amc$add_to_file_description';
    = amc$access_method_default =
      source_string := 'amc$access_method_default';
    = amc$store_request =
      source_string := 'amc$store_request';
    ELSE
      source_string := 'INVALID SOURCE';
    CASEND;

    STRINGREP (output_string, output_length, ' ': indent + 4, 'source : ',
          source_string);
    syp$write_output_line (output_string (1, output_length), status);

  PROCEND put_source;

MODEND sym$display_bam_tables;


*DECK DECK=SYM$DISPLAY_DEADSTART_MESSAGE EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Deadstart : Display Deadstart Messages' ??
MODULE sym$display_deadstart_message;

{ PURPOSE:
{   This module contains procedures which display deadstart emssages to the system console.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
*copyc clp$convert_integer_to_string
*copyc dpp$put_next_line
*copyc osp$system_error
*copyc osp$unpack_status_condition
?? EJECT ??
*copyc dpv$system_core_display
*copyc dsv$display_deadstart_messages
?? OLDTITLE ??
?? NEWTITLE := 'syp$display_deadstart_message', EJECT ??

{ PURPOSE:
{   This procedure displays a message on the console.  This procedure is used for messages that are considered
{   vital to describing the deadstart process.  The message sent to this procedure always will be displayed.
{   A format has been set up for these messages to provide uniformity to the deadstart display.  All messages
{   should start with a capital letter, with no preceding blanks, and end with three periods.  The messages
{   should be grammatically correct and have no spelling errors.  They should describe the deadstart process
{   at that point and should not be there for debugging purposes.
{     Example: SYP$DISPLAY_DEADSTART_MESSAGE ('System core initialization in progress ...');

  PROCEDURE [XDCL, #GATE] syp$display_deadstart_message
    (    message: string ( * ));

    VAR
      ignore_status: ost$status;

    dpp$put_next_line (dpv$system_core_display, message, ignore_status);

  PROCEND syp$display_deadstart_message;
?? OLDTITLE ??
?? NEWTITLE := 'syp$process_deadstart_status', EJECT ??

{ PURPOSE:
{   This procedure displays a status message to the console.  A boolean was created to display a fatal
{   message and halt the system in the case of a fatal status.

  PROCEDURE [XDCL, #GATE] syp$process_deadstart_status
    (    message: string ( * );
         fatal_status: boolean;
         status: ost$status);

    VAR
      display_string: string (280),
      identifier: ost$status_identifier,
      ignore_status: ost$status,
      integer_string: ost$string,
      number: ost$status_condition_number,
      size: 0 .. 0ffff(16),
      status_size: 0 .. 0ffff(16);

    IF fatal_status THEN
      syp$display_deadstart_message ('A fatal NOS/VE error has occurred');
    ELSE
      syp$display_deadstart_message ('A NOS/VE error has occurred');
    IFEND;
    syp$display_deadstart_message (message);

    IF NOT status.normal THEN
      osp$unpack_status_condition (status.condition, identifier, number);
      display_string := identifier;
      size := #SIZE (identifier) + 1;
      clp$convert_integer_to_string (number, 10, FALSE, integer_string, ignore_status);
      display_string (size, integer_string.size) := integer_string.value;
      size := size + integer_string.size + 1;
      IF status.text.size > (280 - size) THEN
        status_size := 280 - size;
      ELSEIF status.text.size > 0 THEN
        status_size := status.text.size;
      ELSE
        status_size := 1;
      IFEND;
      display_string (size, * ) := status.text.value (1, status_size);
      size := size + status_size;
      syp$display_deadstart_message (display_string (1, size));
    IFEND;

    IF fatal_status THEN
      syp$display_deadstart_message ('A NOS/VE Deadstart is required');
      osp$system_error (' ', ^status);
    IFEND;

  PROCEND syp$process_deadstart_status;
?? OLDTITLE ??
?? NEWTITLE := 'syp$trace_deadstart_message', EJECT ??

{ PURPOSE:
{   This procedure is used to display all the other deadstart messages that are really displayed for debug
{   purposes.  A boolean (dsv$display_deadstart_messages) has been created through a SETSA.  When this boolean
{   is FALSE, all of these debug messages are not displayed.  This allows a user to depress all the debug
{   messages and display only a neat set of messages describing the flow of deadstart.

  PROCEDURE [XDCL, #GATE] syp$trace_deadstart_message
    (    message: string ( * ));

    VAR
      display_message: string (256),
      ignore_status: ost$status,
      index: 1 .. 80,
      message_size: integer,
      non_blank_found: boolean,
      work_message: string (256);

    IF NOT dsv$display_deadstart_messages THEN
      RETURN;
    IFEND;

    { Convert all characters to lower case.

    work_message := message;
    non_blank_found := FALSE;
    FOR index := 1 TO #SIZE (message) DO
      IF (work_message (index) >= 'A') AND (work_message (index) <= 'Z') THEN
        work_message (index) := $CHAR ($INTEGER (work_message (index)) + 32);
      IFEND;
    FOREND;

   /skip_preceding_blanks/
    FOR index := 1 TO #SIZE (message) DO
      IF work_message (index) <> ' ' THEN
        non_blank_found := TRUE;
        EXIT /skip_preceding_blanks/;
      IFEND;
    FOREND /skip_preceding_blanks/;
    IF NOT non_blank_found THEN
      RETURN;
    IFEND;

    message_size := #SIZE (message) - (index - 1);
    display_message (1, *) := ' ';
    display_message (3, *) := work_message (index, *);
    dpp$put_next_line (dpv$system_core_display, display_message (1, message_size+2), ignore_status);

  PROCEND syp$trace_deadstart_message;
MODEND sym$display_deadstart_message;
*DECK DECK=SYM$INJECT_HARDWARE_FAULT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Fault Tolerance : Inject Hardware Fault' ??
MODULE sym$inject_hardware_fault;

{ PURPOSE:
{   This module contains the procedures to inject various hardware faults on the 960.
{
{ DESIGN:
{   Special microcode is required to run with this utility that actually causes the
{   desired hardware fault.
{
{ NOTE:
{   There is a fault injection utility for injecting errors on the 170 side, new
{   additions made to this module should also be made there if it is applicable.
{   The 170 fault injection utility is in deck DSM$INJHFU_170.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jme$queued_file_conditions
*copyc oss$job_paged_literal
*copyc pmt$program_parameters
*copyc syt$hardware_fault_kind
*copyc syt$rb_inject_hardware_fault
?? POP ??
*copyc clp$evaluate_parameters
*copyc clp$get_parameter_list_text
*copyc i#call_monitor
*copyc jmp$system_job
*copyc osp$fetch_system_constant
*copyc osp$set_status_abnormal
*copyc pmp$execute
*copyc syp$cause_hardware_faults
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    t$hardware_fault_params = RECORD
      kind: syt$hardware_fault_kind,
      mode: (c$job, c$monitor),
      traps_enabled: boolean,
      rma: integer,
    RECEND;

?? OLDTITLE ??
?? NEWTITLE := 'syp$inject_hardware_fault', EJECT ??

{ PURPOSE:
{   This procedure evaluates the inject_hardware_fault command and causes the hardware fault.

  PROCEDURE [XDCL, #GATE] syp$inject_hardware_fault
    (    program_parameters: pmt$program_parameters;
     VAR status: ost$status);

    VAR
      enable_fault_injection_index: integer,
      enable_fault_injection_name: ost$name,
      enable_fault_injection_value: integer,
      hardware_fault_p: ^t$hardware_fault_params,
      inject_hardware_fault_mon_req: syt$rb_inject_hardware_fault,
      known_hardware_fault_kind: boolean,
      program_parameters_seq_p: ^pmt$program_parameters;

    status.normal := TRUE;

    {  Ensure that task is executing within a system job.

    IF NOT jmp$system_job () THEN
      osp$set_status_abnormal ('JM', jme$must_be_system_job, 'syp$inject_hardware_fault', status);
      RETURN;
    IFEND;

    enable_fault_injection_name := 'ENABLE_FAULT_INJECTION';
    osp$fetch_system_constant (enable_fault_injection_name, enable_fault_injection_index,
          enable_fault_injection_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF enable_fault_injection_value = 0 THEN
      osp$set_status_abnormal ('SY', 0, 'Enable_fault_injection has not been selected.', status);
      RETURN;
    IFEND;

    program_parameters_seq_p := ^program_parameters;
    RESET program_parameters_seq_p;
    NEXT hardware_fault_p IN program_parameters_seq_p;

    IF hardware_fault_p^.mode = c$job THEN
      IF (hardware_fault_p^.kind = syc$hfk_halt) OR (hardware_fault_p^.kind = syc$hfk_software_error) THEN

        {  Issue the monitor request to clear synchronous bits in monitor mask of this task's exchange
        {  package so that the processor will halt in job mode when the error occurs.

        inject_hardware_fault_mon_req.request_code := syc$inject_hardware_fault;
        inject_hardware_fault_mon_req.hardware_fault_request := syc$hfk_uf_clear_sync_in_mm;
        inject_hardware_fault_mon_req.traps_enabled := TRUE;
        inject_hardware_fault_mon_req.rma := hardware_fault_p^.rma;
        i#call_monitor (#LOC (inject_hardware_fault_mon_req), #SIZE (inject_hardware_fault_mon_req));

        IF NOT inject_hardware_fault_mon_req.status.normal THEN
          osp$set_status_abnormal ('SY', 0,
                'SYP$MTR_INJECT_HARDWARE_FAULT does not recognize request to clear DUE in monitor mask.',
                status);
          RETURN;
        IFEND;
      IFEND;

      syp$cause_hardware_faults (hardware_fault_p^.kind, hardware_fault_p^.rma, known_hardware_fault_kind);
      IF NOT known_hardware_fault_kind THEN
        osp$set_status_abnormal ('SY', 0, 'SYP$CAUSE_HARDWARE_FAULT does not recognize fault kind.', status);
        RETURN;
      IFEND;
    ELSEIF hardware_fault_p^.mode = c$monitor THEN

      {  Issue monitor request to cause hardware fault in monitor mode.

      inject_hardware_fault_mon_req.request_code := syc$inject_hardware_fault;
      inject_hardware_fault_mon_req.hardware_fault_request := hardware_fault_p^.kind;
      inject_hardware_fault_mon_req.traps_enabled := hardware_fault_p^.traps_enabled;
      inject_hardware_fault_mon_req.rma := hardware_fault_p^.rma;
      i#call_monitor (#LOC (inject_hardware_fault_mon_req), #SIZE (inject_hardware_fault_mon_req));

      IF NOT inject_hardware_fault_mon_req.status.normal THEN
        osp$set_status_abnormal ('SY', 0, 'SYP$CAUSE_HARDWARE_FAULT does not recognize fault kind.', status);
        RETURN;
      IFEND;
    ELSE
      osp$set_status_abnormal ('SY', 0, 'Unrecoginized mode, not JOB or MONITOR.', status);
    IFEND;

  PROCEND syp$inject_hardware_fault;
?? OLDTITLE ??
?? NEWTITLE := 'syp$start_injhf_task', EJECT ??

{ PURPOSE:
{   This procedure starts the inject_hardware_fault task.  Inject_hardware_fault is run as a separate task
{   so an error will not be injected into the system monitor.

  PROCEDURE [XDCL] syp$start_injhf_task
    (    parameter_list: clt$parameter_list;
    VAR status: ost$status);

  {  Define parameter_descriptor table (PDT) for the inject fault command.

{ PROCEDURE () inject_hardware_fault, injhf (
{   kind, k: key
{       retry, exchange, trap, halt, pdm_halt, software_error
{     keyend = $required
{   mode, m: key
{       job, monitor
{     keyend = $required
{   traps_enabled, te: boolean = $required
{   rma_of_parity_error, rope: integer 0..0ffffffff(16) = $required
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 9] of clt$pdt_parameter_name,
      parameters: array [1 .. 5] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 6] of clt$keyword_specification,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 2] of clt$keyword_specification,
      recend,
      type3: record
        header: clt$type_specification_header,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
      recend,
      type5: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 4, 25, 15, 25, 1, 703],
    clc$command, 9, 5, 4, 0, 0, 0, 5, ''], [
    ['K                              ',clc$abbreviation_entry, 1],
    ['KIND                           ',clc$nominal_entry, 1],
    ['M                              ',clc$abbreviation_entry, 2],
    ['MODE                           ',clc$nominal_entry, 2],
    ['RMA_OF_PARITY_ERROR            ',clc$nominal_entry, 4],
    ['ROPE                           ',clc$abbreviation_entry, 4],
    ['STATUS                         ',clc$nominal_entry, 5],
    ['TE                             ',clc$abbreviation_entry, 3],
    ['TRAPS_ENABLED                  ',clc$nominal_entry, 3]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 229,
  clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 81, clc$required_parameter,
  0, 0],
{ PARAMETER 3
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 4
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20, clc$required_parameter,
  0, 0],
{ PARAMETER 5
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$keyword_type], [6], [
    ['EXCHANGE                       ', clc$nominal_entry, clc$normal_usage_entry, 2],
    ['HALT                           ', clc$nominal_entry, clc$normal_usage_entry, 4],
    ['PDM_HALT                       ', clc$nominal_entry, clc$normal_usage_entry, 5],
    ['RETRY                          ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['SOFTWARE_ERROR                 ', clc$nominal_entry, clc$normal_usage_entry, 6],
    ['TRAP                           ', clc$nominal_entry, clc$normal_usage_entry, 3]]
    ],
{ PARAMETER 2
    [[1, 0, clc$keyword_type], [2], [
    ['JOB                            ', clc$nominal_entry, clc$normal_usage_entry, 1],
    ['MONITOR                        ', clc$nominal_entry, clc$normal_usage_entry, 2]]
    ],
{ PARAMETER 3
    [[1, 0, clc$boolean_type]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [0, 0ffffffff(16), 10]],
{ PARAMETER 5
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$kind = 1,
      p$mode = 2,
      p$traps_enabled = 3,
      p$rma_of_parity_error = 4,
      p$status = 5;

    VAR
      pvt: array [1 .. 5] of clt$parameter_value;

    TYPE
      t$hardware_fault_description = RECORD
        hardware_fault_kind_name: ost$name,
        hardware_fault_kind: syt$hardware_fault_kind,
      RECEND;

    {  Define table that contains the names of the various kinds of hardware faults that can be injected.
    {  To add a new entry add the hardware fault kind name and the corresponding hardware fault kind index
    {  to the table.  The module, sym$cause_hardware_faults, must also be updated to cause the new fault
    {  condition.  The common deck, syc$hardware_fault_codes, that defines the hardware fault kinds must
    {  also be updated.  The PDT would also have to be updated.

    VAR
      v$hardware_fault_kind_table: [READ, oss$job_paged_literal] ARRAY
            [syc$hfk_retry .. (syc$hfk_uf_null_function - 1)] OF t$hardware_fault_description := [
            ['RETRY                          ', syc$hfk_retry],
            ['EXCHANGE                       ', syc$hfk_exchange],
            ['TRAP                           ', syc$hfk_trap],
            ['HALT                           ', syc$hfk_halt],
            ['PDM_HALT                       ', syc$hfk_pdm_halt],
            ['SOFTWARE_ERROR                 ', syc$hfk_software_error]];

    VAR
      hardware_fault: t$hardware_fault_params,
      hardware_fault_kind: syt$hardware_fault_kind,
      hfkti {hardware fault kind table index} : syt$hardware_fault_kind,
      injhf_params_p: ^pmt$program_parameters,
      known_hardware_fault_kind: boolean,
      program_attributes_p: ^pmt$program_attributes,
      program_description_seq_p: ^pmt$program_description,
      task_status: pmt$task_status,
      taskid: pmt$task_id;

    {  Ensure the that task is executing within a system job.

    status.normal := TRUE;
    IF NOT jmp$system_job () THEN
      osp$set_status_abnormal ('JM', jme$must_be_system_job, 'syp$start_injhf_task', status);
      RETURN;
    IFEND;

    {  Evaluate the inject_hardware_fault command.  Determine kind and mode of fault.  Mode
    {  of fault is either job or monitor.

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    {  Search hardware fault kind description table for valid faults and the corresponding index.

    known_hardware_fault_kind := FALSE;

  /set_hardware_fault_kind/
    FOR hfkti := LOWERBOUND (v$hardware_fault_kind_table) TO UPPERBOUND (v$hardware_fault_kind_table) DO
      IF v$hardware_fault_kind_table [hfkti].hardware_fault_kind_name = pvt [p$kind].value^.keyword_value THEN
        hardware_fault.kind := v$hardware_fault_kind_table [hfkti].hardware_fault_kind;
        known_hardware_fault_kind := TRUE;
        EXIT /set_hardware_fault_kind/;
      IFEND;
    FOREND /set_hardware_fault_kind/;

    IF NOT known_hardware_fault_kind THEN
      osp$set_status_abnormal ('SY', 0, 'Unrecoginized kind of hardware fault.', status);
      RETURN;
    IFEND;

    IF pvt [p$mode].value^.keyword_value = 'JOB' THEN
      hardware_fault.mode := c$job;
    ELSEIF pvt [p$mode].value^.keyword_value = 'MONITOR' THEN
      hardware_fault.mode := c$monitor;
    ELSE
      osp$set_status_abnormal ('SY', 0, 'SYP$CAUSE_HARDWARE_FAULT does not recognize fault kind.', status);
      RETURN;
    IFEND;

    hardware_fault.traps_enabled := pvt [p$traps_enabled].value^.boolean_value.value;

    hardware_fault.rma := pvt [p$rma_of_parity_error].value^.integer_value.value;

    PUSH program_description_seq_p: [[REP 1 OF pmt$program_attributes]];
    RESET program_description_seq_p;
    NEXT program_attributes_p IN program_description_seq_p;
    program_attributes_p^.contents := $pmt$prog_description_contents
          [pmc$starting_proc_specified, pmc$load_map_options_specified, pmc$term_error_level_specified];
    program_attributes_p^.starting_procedure := 'SYP$INJECT_HARDWARE_FAULT';
    program_attributes_p^.load_map_options := $pmt$load_map_options [pmc$no_load_map];
    program_attributes_p^.termination_error_level := pmc$warning_load_errors;

    task_status.status.normal := TRUE;
    pmp$execute (program_description_seq_p^, #SEQ (hardware_fault)^, osc$wait, taskid, task_status, status);
    IF NOT task_status.status.normal THEN
      status := task_status.status;
    IFEND;

  PROCEND syp$start_injhf_task;
MODEND sym$inject_hardware_fault;
*DECK DECK=SYM$JOB_FIXED_TEMPLATE EXPAND=TRUE
SYM$JOB_FIXED_TEMPLATE   IDENT
.
.
.                ***** WARNING *****
.
.    The data structures defined in this module must be the first data loaded into
.    JOB_FIXED.  This is necessary for the proper initialization of the Base Constant
.    register in the XCB for Job Monitor. (and probably some other things too.)
.
.
*copy SYA$CONSTANTS
*copy OSA$BASIC_REGISTER_EQUATES
*copyc sya$xp_and_sf_constants
          page
.
.
.   Define static data.
.
jobfixl   equ      9000     .* * * assembler bug
jobfix    SECTION  working,read+write,OSS$JOB_FIXED,0,8,jobfixl
.
          USE       jobfix
jcb       bssz     jrootsiz           .Job control block. (JCB)
jxcb      bssz     xcbsize            .XCB for job monitor.
          align    0,8
jst       bssz     jstlen*8           .ST for job monitor.
jsdtx     bssz     jstlen*sdtxsize    .STX for job monitor.
jfheapp   vfd,16,32            0ffff(16),80000000(16)
jobtrapp  vfd,16,32,16,32      0FFFF(16),80000000(16),0FFFF(16),8000000(16)
          align    0,8
xcblist   vfd,16,32,16,192     0ffff(16),80000000(16),0,0     .Must be 0 mod 8.
tasktem   vfd,16,32,32,32,32   0ffff(16),80000000(16),0,0,0
sysjob    vfd,8    1
          align  0,8
.
.
.  Define external names for structures in job fixed.
.
          def      jst,jsdtx
          defg     jcb,jxcb
          defg     xcblist,tasktem,jobtrapp
          defg     sysjob
          def      jfheapp
sysjob    alias    JMV$EXECUTING_WITHIN_SYSTEM_JOB
JFHEAPP   ALIAS    OSV$JOB_FIXED_HEAP
jcb       alias    JMV$JCB
jxcb      alias    JMV$JMTR_XCB
jst       alias    JMV$SDT
jsdtx     alias    JMV$SDTX
.
xcblist   alias    JOB_XCB_LIST
tasktem   alias    PMV$TASK_TEMPLATE
jobtrapp  ALIAS    JMV$JOB_TRAP_HANDLER
.
jxcb_off  equ      #BOFF(jxcb)
sdtx_off  equ      #BOFF(jsdtx)
.
          ERROR,sdtx_off>2048         c'ST overflowed minimum page size'
.    Verify segment table is contained in a page - if crosses page boundary, give error.'
.
          ERROR,jxcb_off>0ffff(16)    c'xcb offset too large'
.    Base Constant register will not be initialized properly if offset for
.    JMV$JMTR_XCB is too large.
.
.
         xpareg   jxcb,a_tos,jobstk1
         xpareg   jxcb,a_csf,jobstk1
         xpareg   jxcb,a_psa,nil
         xpareg   jxcb,a_bindin,bindsec
         xpareg   jxcb,4,nil
         xpareg   jxcb,5,nil
         xpareg   jxcb,6,nil
         xpareg   jxcb,7,nil
         xpareg   jxcb,8,nil
         xpareg   jxcb,9,nil
         xpareg   jxcb,10,nil
         xpareg   jxcb,11,nil
         xpareg   jxcb,12,nil
         xpareg   jxcb,13,nil
         xpareg   jxcb,14,nil
         xpareg   jxcb,15,nil
         xpv      jxcb,xpstal,jst,16     .Segment table address
         xpv      jxcb,xpstl,jstlen-1,16  .Segment table length
         xpv      jxcb,xpflgte,00000(16),16   .Set trap-enable
         xpv      jxcb,xpmm,j_mtrmsk,16
         xpv      jxcb,xpum,j_usrmsk,16
         xpv      jxcb,xpkm,0,16
         xpv      jxcb,xppit,07fff(16),16
         xpv      jxcb,xppit+8,0ffff(16),16
         xpv      jxcb,xplrn,15,16
         xpv      jxcb,xpbc1,0,16          .task_id DIV 10000(16) for $JOBMNTR
         xpv      jxcb,xpbc2,jxcb_off,16   .task_id MOD 10000(16) for $JOBMNTR
         xpa      jxcb,xptp,pr_trap
         xpa      jxcb,xpdlp,nil
         xpa      jxcb,xptos,jobstk1
         xpa      jxcb,xptos+8,jobstk2
         xpa      jxcb,xptos+16,jobstk3
         xpa      jxcb,xptos+24,nil
         xpa      jxcb,xptos+32,nil
         xpa      jxcb,xptos+40,nil
         xpa      jxcb,xptos+48,nil
         xpa      jxcb,xptos+56,nil
         xpa      jxcb,xptos+64,nil
         xpa      jxcb,xptos+72,nil
         xpa      jxcb,xptos+80,nil
         xpa      jxcb,xptos+88,nil
         xpa      jxcb,xptos+96,nil
         xpa      jxcb,xptos+104,nil
         xpa      jxcb,xptos+112,nil
.
          page
.
.
.   Define Stack Segment for ring 1
.
jstack1   SECTION  extwork,read+write,jstack1,0,8,jstksiz1
          use      jstack1
          def      jobstk1
          bss      28(16)                  Ring Alarm Procedure offset
jobstk1   bss      jstksiz1-28(16)
.
.
.   Define Stack Segment for ring 2
.
jstack2   SECTION  extwork,read+write,jstack2,0,8,jstksiz2
          use      jstack2
          def      jobstk2
          bss      28(16)                  Ring Alarm Procedure offset
jobstk2   bss      jstksiz2-28(16)
.
.
.
.
.   Define Stack Segment for ring 3
.
jstack3   SECTION  extwork,read+write,jstack3,0,8,jstksiz3
          use      jstack3
          def      jobstk3
          bss      28(16)                  Ring Alarm Procedure offset
jobstk3   bss      jstksiz3-28(16)
          page
.
.   Define Binding Section
.
          USE      BINDING
          def      pr_trap
          ref      traprtn
          def      bindsec
bindsec   bss      0
pr_trap   address  ce,traprtn
.
traprtn   ALIAS    SYP$SYSTEM_CORE_TRAP_HANDLER
          end
*DECK DECK=SYM$JOB_INITIALIZATION EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Job Initialization' ??
MODULE sym$job_initialization;
?? PUSH (LISTEXT := ON) ??
*copyc gft$file_desc_entry_p
*copyc gft$locked_file_desc_entry_p
*copyc mme$condition_codes
*copyc oss$job_fixed
?? POP ??
?? NEWTITLE := '  Externally-Declared Procedures and Variables', EJECT ??

*copyc gfp$get_fde_p
*copyc gfp$get_sfid_from_fde_p
*copyc gfp$reassign_fde
*copyc gfp$scan_all_fdes
*copyc i#move
*copyc jmp$system_job
*copyc mmp$close_device_file
*copyc mmp$get_max_sdt_sdtx_pointer
*copyc mmp$mfh_for_segment_manager
*copyc mmp$open_file_by_sfid
*copyc osp$clear_mainframe_sig_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$system_error
*copyc pmp$zero_out_table
*copyc pmp$get_job_mode
*copyc pmp$find_executing_task_xcb
*copyc jmv$jcb
*copyc jmv$kjlx_p
*copyc osv$mainframe_pageable_heap
*copyc syv$nosve_job_template
?? OLDTITLE ??
?? NEWTITLE := '  Global Types and Variables Declared by This Module', EJECT ??

  TYPE
    syt$initialize_array_entry = record
      sfid: gft$system_file_identifier,
      fde: gft$file_descriptor_entry,

      {If segment_specified, create it with same segment number and attributes.

      segment_specified: boolean,
      segment: ost$segment,
      sdt_entry: mmt$segment_descriptor,
      sdtx_entry: mmt$segment_descriptor_extended,
      p_data: ^array [0 .. * ] of cell,
      length: integer,
    recend;

  VAR
    syv$initialization_lock: [XDCL] ost$signature_lock := [0],
    syv$login_template: [XDCL] array [jmt$job_mode] of record
        number_of_clone_entries: integer,
        clone_entry_p: ^array [1 .. * ] of syt$initialize_array_entry,
      recend := [REP ($integer(uppervalue (jmt$job_mode)) + 1) OF [0, NIL]],
    syv$clone_enabled: [XDCL, #GATE] boolean := TRUE,
    syv$job_initialization_complete: [XDCL, #GATE, oss$job_fixed] boolean := FALSE;

?? OLDTITLE ??
?? NEWTITLE := '  PROCEDURE syp$initialize_job_mode', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$initialize_job_mode;

    CONST
      max_clone_entries = 25;

    VAR
      check: integer,
      clone: integer,
      fde_p: gft$file_desc_entry_p,
      ignore_status: ost$status,
      ijlo: jmt$ijl_ordinal,
      job_mode: jmt$job_mode,
      login_table_entry_p: ^array [1 .. *] of syt$initialize_array_entry,
      scan_control: gft$scan_all_fdes_state,
      sdt_p: mmt$max_sdt_p,
      sdte_p: ^mmt$segment_descriptor,
      sdtx_p: mmt$max_sdtx_p,
      sdtxe_p: ^mmt$segment_descriptor_extended,
      segment_number: ost$segment,
      sfid_already_saved: boolean,
      system_file_id: gft$system_file_identifier,
      xcb_p: ^ost$execution_control_block;


    pmp$get_job_mode (job_mode, ignore_status);
    IF syv$login_template [job_mode].clone_entry_p <> NIL THEN
      syv$job_initialization_complete := TRUE;
      RETURN;
    IFEND;

    IF job_mode <> jmc$batch THEN
      IF (job_mode <> jmc$interactive_connected) OR (NOT jmv$kjlx_p^ [jmv$jcb.job_id].timesharing_job) THEN
        syv$job_initialization_complete := TRUE;
        RETURN;
      IFEND;
    IFEND;

    IF (NOT syv$clone_enabled) OR (NOT syv$nosve_job_template) THEN
      syv$job_initialization_complete := TRUE;
      RETURN;
    IFEND;

    osp$set_mainframe_sig_lock (syv$initialization_lock);
    IF syv$login_template [job_mode].clone_entry_p <> NIL THEN
      osp$clear_mainframe_sig_lock (syv$initialization_lock);
      syv$job_initialization_complete := TRUE;
      RETURN;
    IFEND;

    IF jmp$system_job () THEN
      osp$clear_mainframe_sig_lock (syv$initialization_lock);
      syv$job_initialization_complete := TRUE;
      RETURN;
    IFEND;

    ALLOCATE login_table_entry_p: [1 .. max_clone_entries] IN osv$mainframe_pageable_heap^;
    pmp$zero_out_table (^login_table_entry_p^, #SIZE (login_table_entry_p^));

    pmp$find_executing_task_xcb (xcb_p);
    clone := 0;

{ Clone segments and open job_local files.  If this job has any attached permanent files, it never would have
{ entered this procedure in the first place.

    mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);
    FOR segment_number := 0 TO xcb_p^.xp.segment_table_length DO
      sdte_p := ^sdt_p^.st [segment_number];
      IF sdte_p^.ste.vl <> osc$vl_invalid_entry THEN
        sdtxe_p := ^sdtx_p^.sdtx_table [segment_number];
        IF (NOT (mmc$sa_stack IN sdtxe_p^.software_attribute_set)) AND (sdtxe_p^.open_validating_ring_number
              <> 0) AND (segment_number <> osc$segnum_job_fixed_heap) THEN

          sfid_already_saved := FALSE;
          FOR check := 1 TO clone DO
            IF login_table_entry_p^ [check].sfid = sdtxe_p^.sfid THEN
              sfid_already_saved := TRUE;
            IFEND;
          FOREND;

          gfp$get_fde_p (sdtxe_p^.sfid, fde_p);
          IF (fde_p^.file_kind = gfc$fk_unnamed_file) OR (fde_p^.file_kind = gfc$fk_job_local_file) THEN
            clone := clone + 1;
            IF clone > max_clone_entries THEN
              osp$system_error ('Cannot create clone', NIL);
            IFEND;

            system_file_id := sdtxe_p^.sfid;
            login_table_entry_p^ [clone].segment_specified := TRUE;
            login_table_entry_p^ [clone].segment := segment_number;
            login_table_entry_p^ [clone].sfid := system_file_id;
            login_table_entry_p^ [clone].sdt_entry := sdte_p^;
            login_table_entry_p^ [clone].sdt_entry.ste.asid := 0;
            login_table_entry_p^ [clone].sdtx_entry := sdtxe_p^;
            login_table_entry_p^ [clone].sdtx_entry.assign_active := mmc$assign_active_null;
            login_table_entry_p^ [clone].fde := fde_p^;

            IF (NOT sfid_already_saved) AND (fde_p^.eoi_byte_address > 1) THEN
              ALLOCATE login_table_entry_p^ [clone].p_data: [0 .. fde_p^.eoi_byte_address - 1] IN
                    osv$mainframe_pageable_heap^;
              i#move (#ADDRESS (osc$os_ring_1, segment_number, 0), login_table_entry_p^ [clone].p_data,
                    fde_p^.eoi_byte_address);
              login_table_entry_p^ [clone].length := fde_p^.eoi_byte_address;
            ELSE
              login_table_entry_p^ [clone].length := 0;
            IFEND;

          ELSE

{ This check can't hurt.  If we get here, something has gone terribly wrong.  Crash.

            osp$system_error ('Job initialization error in SYP$INITIALIZE_JOB_MODE', NIL);
          IFEND;
        IFEND;
      IFEND;
    FOREND;

{ Clone unopened job_local files.

    gfp$scan_all_fdes (gfc$tr_job, scan_control, fde_p);
    WHILE fde_p <> NIL DO
    /search_file_descriptor_table/
      BEGIN
        gfp$get_sfid_from_fde_p (fde_p, system_file_id);
        IF fde_p^.file_kind <> gfc$fk_job_local_file THEN
          EXIT /search_file_descriptor_table/;
        IFEND;
        FOR check := 1 TO clone DO
          IF login_table_entry_p^ [check].sfid.file_entry_index = system_file_id.file_entry_index THEN
            EXIT /search_file_descriptor_table/;
          IFEND;
        FOREND;

        clone := clone + 1;
        IF clone > max_clone_entries THEN
          osp$system_error ('Cannot create clone', NIL);
        IFEND;
        login_table_entry_p^ [clone].segment_specified := FALSE;
        login_table_entry_p^ [clone].sfid := system_file_id;
        login_table_entry_p^ [clone].fde := fde_p^;

        IF fde_p^.eoi_byte_address > 0 THEN
          ALLOCATE login_table_entry_p^ [clone].p_data: [0 .. fde_p^.eoi_byte_address - 1] IN
                osv$mainframe_pageable_heap^;
          segment_number := 0;
          mmp$open_file_by_sfid (system_file_id, 1, 1, mmc$as_sequential, mmc$sar_write_extend,
                segment_number, ignore_status);
          i#move (#ADDRESS (osc$os_ring_1, segment_number, 0), login_table_entry_p^ [clone].p_data,
                fde_p^.eoi_byte_address);
          mmp$close_device_file (segment_number, ignore_status);
        IFEND;
        login_table_entry_p^ [clone].length := fde_p^.eoi_byte_address;
      END /search_file_descriptor_table/;

      gfp$scan_all_fdes (gfc$tr_null_residence, scan_control, fde_p);

    WHILEND;

    syv$job_initialization_complete := TRUE;
    syv$login_template [job_mode].clone_entry_p := login_table_entry_p;
    syv$login_template [job_mode].number_of_clone_entries := clone;
    osp$clear_mainframe_sig_lock (syv$initialization_lock);

  PROCEND syp$initialize_job_mode;
?? OLDTITLE ??
?? NEWTITLE := '  PROCEDURE syp$initialize_job' ??

  PROCEDURE [XDCL, #GATE] syp$initialize_job;

    VAR
      clone: integer,
      ignore_status: ost$status,
      job_mode: jmt$job_mode,
      max_segment_length: ost$segment_length,
      new_sfid: gft$system_file_identifier,
      sdt_p: mmt$max_sdt_p,
      sdte_p: ^mmt$segment_descriptor,
      sdtx_p: mmt$max_sdtx_p,
      sdtxe_p: ^mmt$segment_descriptor_extended,
      segment_number: ost$segment,
      xcb_p: ^ost$execution_control_block;


{ Note: IJL not yet set up - pmp$get_job_mode doesn't work

    job_mode := jmv$kjlx_p^ [jmv$jcb.job_id].job_mode;
    IF syv$login_template [job_mode].clone_entry_p = NIL THEN
      RETURN;
    IFEND;

    IF job_mode <> jmc$batch THEN
      IF (job_mode <> jmc$interactive_connected) OR (NOT jmv$kjlx_p^ [jmv$jcb.job_id].timesharing_job) THEN
        RETURN;
      IFEND;
    IFEND;

    IF (NOT syv$clone_enabled) OR (NOT syv$nosve_job_template) THEN
      RETURN;
    IFEND;

    pmp$find_executing_task_xcb (xcb_p);
    mmp$get_max_sdt_sdtx_pointer (xcb_p, sdt_p, sdtx_p);

    FOR clone := 1 TO syv$login_template [job_mode].number_of_clone_entries DO

      new_sfid := syv$login_template [job_mode].clone_entry_p^ [clone].sfid;
      gfp$reassign_fde (syv$login_template [job_mode].clone_entry_p^ [clone].sfid,
            ^syv$login_template [job_mode].clone_entry_p^ [clone].fde);
      IF NOT syv$login_template [job_mode].clone_entry_p^ [clone].segment_specified THEN
        IF syv$login_template [job_mode].clone_entry_p^ [clone].length > 0 THEN
          mmp$open_file_by_sfid (new_sfid, 1, 1, mmc$as_sequential, mmc$sar_write_extend,
                segment_number, ignore_status);
          i#move (syv$login_template [job_mode].clone_entry_p^ [clone].p_data, #ADDRESS (osc$os_ring_1,
                segment_number, 0), syv$login_template [job_mode].clone_entry_p^ [clone].length);
          mmp$close_device_file (segment_number, ignore_status);
        IFEND;
      ELSE {syv$login_template [job_mode].clone_entry_p^ [clone].segment_specified}
        segment_number := syv$login_template [job_mode].clone_entry_p^ [clone].segment;
        sdte_p := ^sdt_p^.st [segment_number];
        sdtxe_p := ^sdtx_p^.sdtx_table [segment_number];
        IF sdte_p^.ste.vl = osc$vl_invalid_entry THEN
          sdte_p^ := syv$login_template [job_mode].clone_entry_p^ [clone].sdt_entry;
          sdtxe_p^ := syv$login_template [job_mode].clone_entry_p^ [clone].sdtx_entry;
        ELSE
          sdtxe_p^.sfid.file_hash := syv$login_template [job_mode].clone_entry_p^ [clone].sdtx_entry.
                sfid.file_hash;
        IFEND;
        IF syv$login_template [job_mode].clone_entry_p^ [clone].length > 0 THEN
          i#move (syv$login_template [job_mode].clone_entry_p^ [clone].p_data, #ADDRESS (osc$os_ring_1,
                segment_number, 0), syv$login_template [job_mode].clone_entry_p^ [clone].length);
        IFEND;
      IFEND;
    FOREND;

    syv$job_initialization_complete := TRUE;

  PROCEND syp$initialize_job;
?? OLDTITLE, OLDTITLE ??
MODEND sym$job_initialization
*DECK DECK=SYM$JOB_RECOVERY_R1 EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE Job Recovery Ring 1 Procedures' ??
MODULE sym$job_recovery_r1;

{
{              job recovery functioning
{              system job - continuation deadstart
{              -----------------------------------
{
{     osm$job_template_initialization
{         osp$recover_executing_jobs
{              syp$init_job_rec_from_image (ready system to recover jobs from
{                                            image file)
{              pfp$validate_catalog (swap catalog)
{              syp$begin_job_recovery
{              for every swap file (job)
{                   pfp$restricted_attach (swap file)
{                   bap$open
{                   syp$job_recovery_from_image (manually swap out jobs from
{                                                  memory image to swap file)
{                   jmp$rebuild_executing_job (rebuild KJL)
{                   syp$recover_job_r1 (rebuild ijl, ptl for swapin)
{              forend
{              syp$end_job_recovery
{         osp$complete_job_recovery
{              process delayed purges from osp$recover_executing_jobs
{              start volume space recovery task
{              syp$complete_job_recovery (notify scheduler of recovered jobs)
{
{
{                        within recovering jobs (tasks)
{                        -------------------------------
{
{                                  both tasks
{    jmtr task                                                   other tasks
{    -----------------------------------------------------------------------
{                                  syp$mfh_for_job_recovery (monitor flag)
{    dmp$recover_job_temp_file_space                             wait for jmtr
{                                                                     task
{                                  flag yourself
{                                  osp$recover_job (system flag)
{                                  cause_task_condition
{                                  rollback of ring 2 code
{    wait for all tasks to reach jt
{    syp$decrement_job_task_count
{                                                                wait for
{                                                      syp$jt_recovery_complete
{    fmp$recover_job_files
{    mli recovery
{    disconnect if interactive
{    syp$jt_recovery_complete
{                                                                mli recovery
{                                  wait for all jobs to finish job recovery
{                                  resume user code
{                                  On first access to server
{                                    in the job after server active.
{                                    dfp$recovery_job

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
*copyc dpp$put_critical_message
*copyc dpp$put_next_line
*copyc dst$image_status
*copyc fmc$test_jr_constants
*copyc jmc$job_management_id
*copyc jmc$special_dispatch_priorities
*copyc jmc$null_ajl_ordinal
*copyc jme$queued_file_conditions
*copyc jmt$destination_usage
*copyc jmt$job_class
*copyc jmt$job_recovery_disposition
*copyc jmt$service_class_index
*copyc jmt$system_supplied_name
*copyc jst$swap_file_descriptor
*copyc mmd$segment_access_condition
*copyc mmt$ast_index
*copyc mmt$io_control_block
*copyc mmt$iocb_index
*copyc mmt$rb_change_segment_table
*copyc mmt$segment_access_state
*copyc ose$job_recovery_exceptions
*copyc oss$job_fixed
*copyc ost$heap
*copyc ost$name
*copyc syc$job_recovery_enabled
*copyc syc$monitor_request_codes
*copyc sye$job_recovery_conditions
*copyc syt$job_recovery_step
*copyc syt$failure_reason_list
*copyc syt$rb_job_recovery
*copyc syt$system_core_condition
*copyc syt$user_defined_condition
*copyc tmc$wait_times
?? POP ??
?? NEWTITLE := '  Global Procedure Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmp$allocate_file_space_r1
*copyc dfv$recover_active_families
*copyc dmp$fetch_eoi
*copyc dmp$increment_class_activity
*copyc dmp$recover_job_temp_file_space
*copyc dmp$return_temp_file_space
*copyc dmp$set_eoi
*copyc dmp$verify_job_volumes
*copyc dsp$get_data_from_rdf
*copyc dsp$get_nve_image_description
*copyc dsp$store_data_in_rdf
*copyc gfp$get_fde_p
*copyc gfp$get_fde_p_from_image
*copyc gfp$get_locked_fde_p
*copyc gfp$get_segment_sfid
*copyc gfp$unlock_fde_p
*copyc i#build_adaptable_array_ptr
*copyc i#call_monitor
*copyc i#disable_traps
*copyc i#enable_traps
*copyc i#move
*copyc i#restore_traps
*copyc jmp$allocate_more_ijl_space
*copyc jmp$cleanup_unrecovered_job
*copyc jmp$delete_ijl_entry
*copyc jmp$get_ijle_p
*copyc jmp$job_monitor_xcb
*copyc jmp$notify_queued_files_job_end
*copyc lgp$add_entry_to_system_log
*copyc mmp$assign_contiguous_memory
*copyc mmp$build_segment
*copyc mmp$free_pages
*copyc mmp$get_sdt_entry_p
*copyc mmp$get_sdtx_entry_p
*copyc mmp$get_max_sdt_sdtx_pointer
*copyc mmp$invalidate_segment
*copyc mmp$issue_ring1_segment_request
*copyc mmp$write_modified_pages
*copyc ocp$find_debug_address
*copyc ofp$job_begin
*copyc osp$append_status_integer
*copyc osp$begin_subsystem_activity
*copyc osp$clear_signature_lock
*copyc osp$check_for_job_recovery
*copyc osp$decrement_locked_variable
*copyc osp$end_subsystem_activity
*copyc osp$expand_ptl
*copyc osp$fatal_system_error
*copyc osp$increment_locked_variable
*copyc osp$initialize_signature_lock
*copyc osp$set_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$system_error
*copyc pmp$delay
*copyc pmp$find_executing_task_xcb
*copyc pmp$get_executing_task_gtid
*copyc pmp$set_system_flag
*copyc pmp$zero_out_table
*copyc syp$set_status_from_mtr_status
*copyc syp$wait
*copyc tmp$get_monitor_fault
*copyc tmp$ready_system_task1
*copyc syp$invoke_system_debugger
*copyc syp$establish_condition_handler
?? POP ??
?? OLDTITLE ??
?? NEWTITLE := '  Global Variable Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dfv$job_recovery_enabled
*copyc gfv$null_sfid
*copyc jmv$ajl_p
*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc jmv$job_counts
*copyc jmv$jmtr_xcb
*copyc jmv$job_scheduler_event
*copyc jmv$job_sched_events_selected
*copyc jmv$kjl_p
*copyc jmv$max_service_class_in_use
*copyc jmv$null_ijl_ordinal
*copyc jmv$refresh_job_candidates
*copyc jmv$service_classes
*copyc jmv$system_core_id
*copyc jmv$system_ijl_ordinal
*copyc jmv$task_private_templ_p
*copyc mmv$default_sdtx_entry
*copyc mmv$pft_p
*copyc mmv$gpql
*copyc mtv$executing_ajl_at_failure
*copyc mtv$halt_cpu_ring_number
*copyc mtv$processor_mode
*copyc osv$job_fixed_heap
*copyc osv$mainframe_pageable_heap
*copyc osv$mainframe_wired_heap
*copyc osv$page_size
*copyc pmv$task_template
*copyc syv$test_jr_system
*copyc syv$nosve_job_template
*copyc syv$recovering_job_count
*copyc tmv$null_global_task_id
*copyc tmv$ptl_p
?? POP ??
?? OLDTITLE ??
?? NEWTITLE := '  Global Variable Declarations Declared by This Module', EJECT ??

  TYPE
    jxcbl = record
      head: ^ost$execution_control_block,
      lock: ost$signature_lock,
    recend;


  VAR
    job_xcb_list: [XREF, oss$job_fixed] record
      head: ^ost$execution_control_block,
      lock: ost$signature_lock,
    recend,
    syv$allow_jr_test: [XREF] boolean;

  VAR
    decrement_required: [STATIC, oss$job_fixed] boolean := FALSE,
    image_offset: [STATIC] ost$segment_offset,
    image_segment_number: [STATIC] ost$segment,
    inhibit_job_recovery: [oss$job_fixed] integer := 0,
    job_task_count_lock: [oss$job_fixed] ost$signature_lock := [0],
    last_inhibit_job_recovery_p: [oss$job_fixed] ^cell := NIL,
    mtv$saved_halt_cpu_ring_number: [XDCL] 0 .. 0ff(16) := 0,
    oajlp: [STATIC] ^jmt$active_job_list,
    oihtp: [STATIC] ^mmt$old_modified_bits,
    opftp: [STATIC] ^mmt$page_frame_table,
    opqlp: [STATIC] ^mmt$global_page_queue_list,
    optlp: [STATIC] ^tmt$primary_task_list,
    recovering_job_count_lock: ost$signature_lock := [0],
    recovery_failure_lock: ost$signature_lock := [0],
    recovery_load_offset: [STATIC] ost$segment_offset,
    rmfwsn: [STATIC] 0 .. 0fff(16),
    syv$attached_server_file_count: [XDCL, #GATE, oss$job_fixed] integer := 0,
    syv$debug_job_recovery: [XDCL, #GATE] boolean := FALSE,
    syv$detailed_critical_displays: [XREF] boolean,
    syv$discarded_page_count: [XDCL] integer := 0,
    syv$failure_reason_p: [XDCL, #GATE] ^syt$failure_reason_list := NIL,
    syv$file_rcv_failure_count: [XDCL, #GATE] integer := 0,
    syv$job_recovery_option: [XDCL, #GATE] integer := syc$jre_enabled,
    syv$job_recovery_step: [XDCL, #GATE, oss$job_fixed] syt$job_recovery_step := syc$jrs_initial_step,
    syv$job_recovery_wait_time: [XDCL, #GATE, oss$job_fixed] integer := 500,
    syv$job_task_count: [XDCL, #GATE, oss$job_fixed] integer := 0,
    syv$recovery_failure_count: [XDCL, #GATE] integer := 0,
    syv$system_is_idling: [STATIC, oss$mainframe_pageable] boolean := FALSE,
    syv$system_was_idle: boolean := FALSE,
    syv$test_jr_job: [XDCL, #GATE, oss$job_fixed] syt$test_jr_set := $syt$test_jr_set [],
    oijlp: [STATIC] jmt$ijl_p := [NIL, * , * ],
    wid: dpt$window_id;



  PROCEDURE log
    (    text: string ( * ));

    VAR
      log_time: ost$time,
      ost,
      status: ost$status;

    lgp$add_entry_to_system_log (pmc$msg_origin_system, text, log_time, status);
    IF NOT status.normal THEN
      syp$invoke_system_debugger ('   ', 0, ost);
    IFEND;
  PROCEND log;



?? TITLE := 'PROCEDURE [XDCL] syp$order_job_fixed_pages', EJECT ??

  PROCEDURE [XDCL] syp$order_job_fixed_pages
    (    job_page_count: mmt$page_frame_index;
         sfdp: ^jst$swap_file_descriptor;
         job_fixed_offset_list: ^array [0 .. * ] of integer;
     VAR job_fixed: ^array [0 .. 7fffffff(16)] of cell;
     VAR job_fixed_segn: ost$segment;
     VAR status: ost$status);

    VAR
      attributes: mmt$segment_attrib_descriptor,
      job_fixed_p: ^cell,
      job_fixed_segment_p: mmt$segment_pointer,
      max_seg_len: ost$segment_length,
      page_index: mmt$page_frame_index,
      page_number: mmt$page_frame_index,
      swap_file_segn: ost$segment;

    status.normal := TRUE;


    attributes.validating_ring_number := 1;
    attributes.file_limits_to_enforce := sfc$no_limit;
    attributes.pointer_kind := mmc$cell_pointer;
    attributes.user_attributes := NIL;
    attributes.sfid := gfv$null_sfid;
    mmp$build_segment (attributes, NIL, job_fixed_segment_p, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    job_fixed_segn := #SEGMENT (job_fixed_segment_p.cell_pointer);
    job_fixed := #ADDRESS (1, job_fixed_segn, 0);
    swap_file_segn := #SEGMENT (sfdp);

{ Copy job fixed from the swap file to a segment so that we have a sequence of bytes
{ that is in pva order.  The swap file is not necessarily in pva order.  Keep an array
{ of page numbers that describe the job fixed order in the swap file.
{ Pages of fixed segments that are not JOB FIXED cannot be counted.
{ Assumption: The ASID for the job_fixed segment is correct in the swap_file_descriptor.
{ Note: The second clause of the IF statement below indicates that we are looking for pages in the job_fixed
{ segment which are contiguous but are not really job_fixed pages.

    FOR page_index := 0 TO job_page_count - 1 DO
      IF (sfdp^.swapped_page_descriptors [page_index].pft_entry.queue_id = mmc$pq_job_fixed) AND
            (sfdp^.swapped_page_descriptors [page_index].pft_entry.sva.asid =
            sfdp^.ijl_entry.job_fixed_asid) THEN
        page_number := sfdp^.swapped_page_descriptors [page_index].pft_entry.sva.offset DIV osv$page_size;
        job_fixed_p := #ADDRESS (1, swap_file_segn, page_index * osv$page_size);
        i#move (job_fixed_p, #LOC (job_fixed^ [page_number * osv$page_size]), osv$page_size);
        job_fixed_offset_list^ [page_number] := page_index;
      IFEND;
    FOREND;

  PROCEND syp$order_job_fixed_pages;

?? TITLE := 'PROCEDURE [XDCL] syp$update_flags', EJECT ??

{ This procedure is currently only called by job recovery and when the system
{ is idling.  It assumes the PTL is not changing under us.

  PROCEDURE [XDCL] syp$update_flags
    (    xcb_p: ^ost$execution_control_block;
         ptlp: ^tmt$primary_task_list;
     VAR flags_updated: boolean);

    VAR
      ptle_p: ^tmt$primary_task_list_entry,
      ptlo: ost$task_index;

    flags_updated := FALSE;
    ptlo := xcb_p^.global_task_id.index;
    ptle_p := ^ptlp^ [ptlo];
    IF (ptle_p^.monitor_flags <> $syt$monitor_flags []) OR (ptle_p^.system_flags <> $tmt$system_flags []) THEN

{ Update the job fixed array copy of the XCB.  The caller of this routine will
{ copy the updated job fixed array to the swap file segment before writing out
{ all the job fixed pages.

      xcb_p^.monitor_flags := xcb_p^.monitor_flags + ptle_p^.monitor_flags;
      xcb_p^.monitor_flags := xcb_p^.monitor_flags - $syt$monitor_flags [mmc$mf_volume_unavailable];
      xcb_p^.system_flags := xcb_p^.system_flags + ptle_p^.system_flags;
      xcb_p^.system_flags := xcb_p^.system_flags - $tmt$system_flags [mmc$volume_unavailable_flag];
      xcb_p^.xp.user_condition_register := xcb_p^.xp.user_condition_register +
            $ost$user_conditions [osc$free_flag];
      xcb_p^.wait_inhibited := TRUE;

      ptle_p^.monitor_flags := $syt$monitor_flags [];
      ptle_p^.system_flags := $tmt$system_flags [];
      flags_updated := TRUE;
    IFEND;

  PROCEND syp$update_flags;

?? TITLE := 'PROCEDURE [XDCL] syp$write_job_fixed_pages', EJECT ??

{ Callers of this routine must call mmp$free_pages to free the pages in
{ memory belonging to the swap file when done accessing them.

  PROCEDURE [XDCL] syp$write_job_fixed_pages
    (    job_fixed_page_count: mmt$page_frame_index;
         job_fixed: ^array [0 .. 7fffffff(16)] of cell;
         sfdp: ^jst$swap_file_descriptor;
     VAR status: ost$status);

    VAR
      job_fixed_p: ^cell,
      page_index: mmt$page_frame_index,
      page_number: mmt$page_frame_index,
      swap_file_segn: ost$segment;

    status.normal := TRUE;
    swap_file_segn := #SEGMENT (sfdp);

{ Copy the job fixed array back into the swap file.
{ Pages of job fixed that are not JOB FIXED cannot be counted.
{ Assumption: The ASID for the job_fixed segment is correct in the swap_file_descriptor.
{ Note: The second clause of the IF statement below indicates that we are looking for pages in the job_fixed
{ segment which are contiguous but are not really job_fixed pages.

    FOR page_index := 0 TO job_fixed_page_count - 1 DO
      IF (sfdp^.swapped_page_descriptors [page_index].pft_entry.queue_id = mmc$pq_job_fixed) AND
            (sfdp^.swapped_page_descriptors [page_index].pft_entry.sva.asid =
            sfdp^.ijl_entry.job_fixed_asid) THEN
        page_number := sfdp^.swapped_page_descriptors [page_index].pft_entry.sva.offset DIV osv$page_size;
        job_fixed_p := #ADDRESS (1, swap_file_segn, page_index * osv$page_size);
        i#move (#LOC (job_fixed^ [page_number * osv$page_size]), job_fixed_p, osv$page_size);
      IFEND;
    FOREND;

{ Write the job fixed pages of the swap file out to disk.

    mmp$write_modified_pages (#ADDRESS (1, swap_file_segn, 0), job_fixed_page_count * osv$page_size, osc$wait,
          status);

  PROCEND syp$write_job_fixed_pages;
?? TITLE := 'PROCEDURE syp$recover_job_r1', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$recover_job_r1
    (    swap_file: ^cell;
         jcb: ^jmt$job_control_block;
         oijlep: ^jmt$initiated_job_list_entry;
     VAR recovery_disposition_available: boolean;
     VAR job_recovery_disposition: jmt$job_recovery_disposition;
     VAR status: ost$status);

    PROCEDURE display_address
      (    pva: ^cell);

      VAR
        display_string: string (255),
        found: boolean,
        module_name: pmt$program_name,
        procedure_name: pmt$program_name,
        section_offset: ost$segment_offset,
        status: ost$status,
        string_length: integer;

      ocp$find_debug_address (#SEGMENT (pva), #OFFSET (pva),
            found, module_name, procedure_name, section_offset, status);
      IF NOT status.normal OR NOT found THEN
        module_name :=  ' ';
        procedure_name := ' ';
        section_offset := 0;
      IFEND;


      STRINGREP (display_string, string_length, pva, ' ', module_name, ' ',
            procedure_name, ' ', section_offset);
      log (display_string (1, string_length));

    PROCEND display_address;

    PROCEDURE display_xcb;

      PROCEDURE scch
        (    mf: ost$monitor_fault;
             ctc: ^ost$minimum_save_area;
         VAR continue: syt$continue_option);

        EXIT display_xcb;
      PROCEND scch;

      VAR
        pjxcbl: ^jxcbl,
        xcb: ^ost$execution_control_block,
        ring,
        segment,
        offset,
        strl,
        x0,
        xcbo: integer,
        so: ost$segment_offset,
        modname,
        procname: pmt$program_name,
        found: boolean,
        status: ost$status,
        str: string (255);

      syp$establish_condition_handler (^scch);
      pjxcbl := ^job_fixed^ [#OFFSET (^job_xcb_list)];
      xcb := pjxcbl^.head;
      log ('Recovery aborted -  xcb info:');

    /follow_xcb_chain/
      WHILE xcb <> NIL DO
        xcbo := #OFFSET (xcb);
        xcb := ^job_fixed^ [#OFFSET (xcb)];
        ring := xcb^.xp.p_register.pva.ring;
        segment := xcb^.xp.p_register.pva.seg;
        offset := xcb^.xp.p_register.pva.offset;
        x0 := xcb^.xp.x_registers [0];

        ocp$find_debug_address (segment, offset, found, modname, procname, so, status);
        IF NOT found THEN
          modname := '  ';
          procname := '  ';
          so := 0;
        IFEND;

{ IF procname = 'I#CALL_MONITOR' THEN
{   segment := #segment (xcb^.xp.af);
{   offset := #offset (xcb^.xp.af);
{   ocp$find_debug_address (segment, offset, found, modname, procname, so,
{         status);
{ IFEND;

        STRINGREP (str, strl, xcb^.save9, ' ', ring: 2: #(16), segment: 4: #(16), offset: 9: #(16),
              ' ', modname, ' ', procname, so, ' x0', x0: 18: #(16));
        log (str (1, strl));

        xcb := xcb^.link;
      WHILEND /follow_xcb_chain/;

    PROCEND display_xcb;


    VAR
      display_string: string (70),
      string_length: integer,
      attached_server_file_count_p: ^integer,
      flags_updated: boolean,
      highest_page_number: mmt$page_frame_index,
      last_inhibit_job_recovery_p_p: ^^cell,
      ijl_ord: jmt$ijl_ordinal,
      ijlep: ^jmt$initiated_job_list_entry,
      ijr_p: ^integer,
      j: integer,
      jf_segnumber: ost$segment,
      jip_p: ^jmt$job_control_block,
      job_fixed: ^array [0 .. 7fffffff(16)] of cell,
      job_fixed_offset_list: ^array [0 .. * ] of integer,
      jr_req: syt$rb_job_recovery,
      jrs_p: ^syt$job_recovery_step,
      msg_status: ost$status,
      old_ijlep: ^jmt$initiated_job_list_entry,
      ost: ost$status,
      p_nosve_job_template: ^boolean,
      page_index: mmt$page_frame_index,
      page_number: mmt$page_frame_index,
      pc: mmt$page_frame_index,
      pjxcbl: ^jxcbl,
      pn: mmt$page_frame_index,
      po: ost$segment_offset,
      pqidi: mmt$page_frame_queue_id,
      queue_id: mmt$job_page_queue_index,
      sfdp: ^jst$swap_file_descriptor,
      swap_file_eoi: amt$file_byte_address,
      swap_file_offset: integer,
      swap_file_segn: 0 .. 0fff(16),
      swap_file_sfid: gft$system_file_identifier,
      task_index: ost$task_index,
      trick: ^packed record
        ring: 0 .. 0f(16),
        segment: 0 .. 0fff(16),
        offset: 0 .. 0ffffffff(16),
      recend,
      unrecoverable_file: boolean,
      volume_missing: boolean,
      write_job_fixed: boolean,
      xcb: ^ost$execution_control_block,
      xcbo: ost$segment_offset;

    PROCEDURE scch
      (    mf: ost$monitor_fault;
           ctc: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      IF jr_req.task_list_p <> NIL THEN
        FREE jr_req.task_list_p IN osv$mainframe_wired_heap^;
      IFEND;

      IF ijlep <> NIL THEN
        jmp$delete_ijl_entry (ijl_ord);
      IFEND;

      osp$set_status_condition (sye$condition_encountered, status);
      EXIT syp$recover_job_r1;
    PROCEND scch;

    ijlep := NIL;
    #SPOIL (ijlep);
    jr_req.task_list_p := NIL;
    syp$establish_condition_handler (^scch);
    swap_file_segn := #SEGMENT (swap_file);
    pc := 0;
    FOR queue_id := LOWERVALUE (mmt$job_page_queue_index) TO UPPERVALUE (mmt$job_page_queue_index) DO
      pc := pc + jcb^.swapped_job_entry.job_page_queue_count [queue_id];
    FOREND;
    IF (pc = 0) OR (jcb^.swapped_job_entry.swap_file_descriptor_page_count = 0) THEN
      osp$set_status_condition (sye$job_page_count_zero, status);
      RETURN;
    IFEND;

{ ** WARNING
{    THE FOLLOWING LINE IS DEPENDANT ON PAGE SIZE

    i#build_adaptable_array_ptr (1, swap_file_segn, pc * osv$page_size,
          #SIZE (jst$swapped_page_descriptor) * (jcb^.swapped_job_entry.swap_file_descriptor_page_count + pc),
          0, #SIZE (jst$swapped_page_descriptor), #LOC (sfdp));

    IF sfdp^.ijl_entry.system_supplied_name <> jcb^.system_name THEN
      osp$set_status_condition (sye$bad_swap_file_descriptor, status);
      RETURN;
    IFEND;

    ijl_ord := jcb^.ijl_ordinal;
    IF ijl_ord.block_number > UPPERBOUND (jmv$ijl_p.block_p^) THEN
      osp$set_status_condition (sye$bad_ijl_entry, status);
      RETURN;
    IFEND;
    IF ijl_ord.block_index > UPPERVALUE (jmt$ijl_block_index) THEN
      osp$set_status_condition (sye$bad_ijl_entry, status);
      RETURN;
    IFEND;

    IF NOT syv$system_was_idle THEN

{ If necessary, update the ijl entry in the swap file with the ijl entry from the image.
{ If the job was already swapped to disk when the system went down, no processing was done
{ to the job in syp$job_recovery_from_image.  If the job was not swapped to disk, then
{ syp$job_reocvery_from_image has already "swapped out" the job and updated the swap file
{ descriptor.
{ NOTE:  This code is dependent upon NOTHING changing the image ijl entry (oijlep).

      IF oijlep^.swap_status >= jmc$iss_swapout_io_complete THEN
        IF sfdp^.ijl_entry.system_supplied_name = oijlep^.system_supplied_name THEN
          sfdp^.ijl_entry := oijlep^;
          mmp$write_modified_pages (^sfdp^.ijl_entry, #SIZE (jmt$initiated_job_list_entry), osc$wait, status);
        IFEND;
      IFEND;
    IFEND;


{ There may be gaps in the job fixed pages.  Find the largest page number.
{ Assumption: The ASID for the job_fixed segment is correct in the swap_file_descriptor.
{ Note: The second clause of the IF statement below indicates that we are looking for pages in the job_fixed
{ segment which are contiguous but are not really job_fixed pages.

    pc := jcb^.swapped_job_entry.job_page_queue_count [mmc$pq_job_fixed];
    highest_page_number := 0;
    FOR page_index := 0 TO pc - 1 DO
      IF (sfdp^.swapped_page_descriptors [page_index].pft_entry.queue_id = mmc$pq_job_fixed) AND
            (sfdp^.swapped_page_descriptors [page_index].pft_entry.sva.asid =
            sfdp^.ijl_entry.job_fixed_asid) THEN
        page_number := sfdp^.swapped_page_descriptors [page_index].pft_entry.sva.offset DIV osv$page_size;
        IF page_number > highest_page_number THEN
          highest_page_number := page_number;
        IFEND;
      IFEND;
    FOREND;

    PUSH job_fixed_offset_list: [0 .. highest_page_number];
    jf_segnumber := 0;
    syp$order_job_fixed_pages (pc, sfdp, job_fixed_offset_list, job_fixed, jf_segnumber, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  /jf_seg_open/
    BEGIN
    old_ijlep := ^sfdp^.ijl_entry;

    recovery_disposition_available := TRUE;
    job_recovery_disposition := old_ijlep^.queue_file_information.job_recovery_disposition;
    IF job_recovery_disposition = jmc$terminate_on_recovery THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$job_recovery_or_abort_set, 'TERMINATED', status);
      EXIT /jf_seg_open/;
    ELSEIF job_recovery_disposition = jmc$restart_on_recovery THEN
      osp$set_status_abnormal (jmc$job_management_id, jme$job_recovery_or_abort_set, 'RESTARTED', status);
      EXIT /jf_seg_open/;
    IFEND;

{ The job recovery disposition indicated to continue.  If there is a failure now, the job abort disposition
{ will indicate what to do.

    IF old_ijlep^.queue_file_information.job_abort_disposition = jmc$restart_on_abort THEN
      job_recovery_disposition := jmc$restart_on_recovery;
    ELSE { jmc$terminate_on_abort
      job_recovery_disposition := jmc$terminate_on_recovery;
    IFEND;

    IF (old_ijlep^.job_damaged_during_recovery) OR (old_ijlep^.swap_data.swapping_io_error <> ioc$no_error) OR
          (jmc$dsw_io_error_while_swapped IN old_ijlep^.delayed_swapin_work) THEN

      osp$set_status_condition (sye$job_damaged, status);
      EXIT /jf_seg_open/;
    IFEND;

    task_index := old_ijlep^.job_monitor_taskid.index;
    WHILE task_index > UPPERBOUND (tmv$ptl_p^) DO
      osp$expand_ptl ({ unconditionally_expand } TRUE, status);
      IF NOT status.normal THEN
        osp$set_status_condition (sye$jmtr_task_index_too_big, status);
        EXIT /jf_seg_open/;
      IFEND;
    WHILEND;

    ijr_p := ^job_fixed^ [#OFFSET (^inhibit_job_recovery)];
    IF ijr_p^ <> 0 THEN
      STRINGREP (display_string, string_length, ' Inhibit recovery count ',
         ijr_p^);
      log (display_string (1, string_length));
      last_inhibit_job_recovery_p_p:= ^job_fixed^ [#OFFSET (^last_inhibit_job_recovery_p)];
      display_address (last_inhibit_job_recovery_p_p^);
      display_xcb;
      osp$set_status_condition (sye$job_recovery_inhibited, status);
      EXIT /jf_seg_open/;
    IFEND;

    attached_server_file_count_p := ^job_fixed^ [#OFFSET (^syv$attached_server_file_count)];
    IF (attached_server_file_count_p^ <> 0) AND NOT dfv$job_recovery_enabled THEN
      STRINGREP (display_string, string_length, ' Server file attach count ',
         attached_server_file_count_p^);
      log (display_string (1, string_length));
      osp$set_status_condition (sye$job_using_server_files, status);
      osp$append_status_integer (osc$status_parameter_delimiter, attached_server_file_count_p^, 10, FALSE,
            status);
      EXIT /jf_seg_open/;
    IFEND;

    p_nosve_job_template := ^job_fixed^ [#OFFSET (^syv$nosve_job_template)];
    IF NOT p_nosve_job_template^ THEN
      osp$set_status_condition (sye$not_nosve_template, status);
      EXIT /jf_seg_open/;
    IFEND;

    jrs_p := ^job_fixed^ [#OFFSET (^syv$job_recovery_step)];
    IF jrs_p^ = syc$jrs_initial_step THEN

{ ok

    ELSEIF jrs_p^ = syc$jrs_job_damaged_dont_rec THEN
      osp$set_status_condition (sye$job_damaged, status);
      EXIT /jf_seg_open/;
    ELSE

{ update the copy in the job fixed array in case we need to write out all of the job
{ fixed pages later due to syp$update_flags.

      jrs_p^ := syc$jrs_initial_step;
      pn := #OFFSET (^syv$job_recovery_step) DIV osv$page_size;
      po := #OFFSET (^syv$job_recovery_step) - (pn * osv$page_size);
      jrs_p := #ADDRESS (1, swap_file_segn, (job_fixed_offset_list^ [pn] * osv$page_size) + po);
      jrs_p^ := syc$jrs_initial_step;
      mmp$write_modified_pages (jrs_p, #SIZE (jrs_p^), osc$wait, status);
      IF NOT status.normal THEN
        EXIT /jf_seg_open/;
      IFEND;
    IFEND;

{ Validate temporary files of the job to make sure that all volumes are still
{ active in the system and that the disk space still looks like it is assigned
{ to the job.

    dmp$verify_job_volumes (jf_segnumber, volume_missing, unrecoverable_file);
    IF volume_missing THEN
      osp$set_status_condition (sye$volume_missing, status);
      EXIT /jf_seg_open/;
    ELSEIF unrecoverable_file THEN
      osp$set_status_condition (sye$open_segs_not_recovered, status);
      EXIT /jf_seg_open/;
    IFEND;

    status.normal := TRUE;

    IF (ijl_ord.block_number > jmv$ijl_p.max_block_in_use) OR
          (jmv$ijl_p.block_p^ [ijl_ord.block_number].index_p = NIL) THEN
      jmp$allocate_more_ijl_space (ijl_ord.block_number);
    IFEND;

    jmp$get_ijle_p (ijl_ord, ijlep);
    #SPOIL (ijlep);
    IF ijlep^.entry_status <> jmc$ies_entry_free THEN
      osp$set_status_condition (sye$ijl_entry_not_free, status);
      EXIT /jf_seg_open/;
    IFEND;
    jmv$ijl_p.block_p^ [ijl_ord.block_number].in_use_count :=
          jmv$ijl_p.block_p^ [ijl_ord.block_number].in_use_count + 1;

{ update the copy in the job fixed array in case we need to write out all of the job
{ fixed pages later due to syp$update_flags.

    jip_p := ^job_fixed^ [#OFFSET (^jmv$jcb)];
    jip_p^.ijle_p := ijlep;
    jcb^.ijle_p := ijlep;
    mmp$write_modified_pages (jcb, #SIZE (jcb^), osc$wait, status);
    IF NOT status.normal THEN
      EXIT /jf_seg_open/;
    IFEND;

  /ijl_created/
    BEGIN
      ijlep^ := old_ijlep^;
      ijlep^.ajl_ordinal := jmc$null_ajl_ordinal;
      ijlep^.kjl_ordinal := jcb^.job_id;
      ijlep^.swap_data.asid_reassigned_timestamp := 0;
      ijlep^.entry_status := jmc$ies_system_force_out;
      ijlep^.swap_status := jmc$iss_swapout_complete;
      ijlep^.next_swap_status := jmc$iss_null;
      ijlep^.inhibit_swap_count := 0;
      ijlep^.active_io_page_count := 0;
      ijlep^.active_io_requests := 0;
      ijlep^.executing_task_count := 0;
      ijlep^.swap_data.timestamp := #FREE_RUNNING_CLOCK (0);
      ijlep^.swap_data.swapout_timestamp := #FREE_RUNNING_CLOCK (0);
      ijlep^.swap_data.long_wait_expire_time := 0;
      ijlep^.swap_data.swap_file_length_in_pages := 0;
      ijlep^.job_scheduler_data.ready_task_link := jmv$null_ijl_ordinal;
      ijlep^.memory_reserve_request.swapout_job := FALSE;
      ijlep^.memory_reserve_request.requested_page_count := 0;
      ijlep^.memory_reserve_request.reserved_page_count := 0;
      ijlep^.interactive_task_gtid := tmv$null_global_task_id;
      ijlep^.delayed_swapin_work := $jmt$delayed_swapin_work
            [jmc$dsw_job_recovery, jmc$dsw_update_debug_lists, jmc$dsw_job_asid_changed,
            jmc$dsw_update_keypoint_masks, jmc$dsw_job_shared_asid_changed];

{  Give the job system dispatching priority with unlimited service to guarantee it will
{  swap in and recover.  The dispatching priority will be reset when recovery is complete.

      ijlep^.scheduling_dispatching_priority := jmc$priority_system_job;
      ijlep^.dispatching_control.dispatching_priority := jmc$priority_system_job;
      ijlep^.dispatching_control.service_remaining := jmc$dc_maximum_service_limit;
      FOR pqidi := LOWERVALUE (mmt$job_page_queue_index) TO UPPERVALUE (mmt$job_page_queue_index) DO
        ijlep^.job_page_queue_list [pqidi].count := 0;
        ijlep^.job_page_queue_list [pqidi].link.bkw := 0;
        ijlep^.job_page_queue_list [pqidi].link.fwd := 0;
      FOREND;
      gfp$get_segment_sfid (swap_file, ijlep^.swap_data.swap_file_sfid, status);
      IF NOT status.normal THEN
        EXIT /ijl_created/;
      IFEND;

      pjxcbl := ^job_fixed^ [#OFFSET (^job_xcb_list)];
      xcb := pjxcbl^.head;
      j := 0;
      WHILE xcb <> NIL DO
        xcb := ^job_fixed^ [#OFFSET (xcb)];
        j := j + 1;
        IF j > tmc$maximum_ptl THEN
          osp$set_status_condition (sye$too_many_tasks_in_job, status);
          EXIT /ijl_created/;
        IFEND;
        xcb := xcb^.link;
      WHILEND;

      IF j = 0 THEN
        osp$set_status_condition (sye$no_tasks_in_job, status);
        EXIT /ijl_created/;
      IFEND;

      ALLOCATE jr_req.task_list_p: [1 .. j] IN osv$mainframe_wired_heap^;
      jr_req.reqcode := syc$rc_job_recovery_requests;
      jr_req.ijlo := ijl_ord;
      jr_req.subreq := syc$recover_ptl;
      j := 0;
      xcb := pjxcbl^.head;
      write_job_fixed := FALSE;

    /follow_xcb_chain/
      WHILE xcb <> NIL DO
        xcbo := #OFFSET (xcb);
        xcb := ^job_fixed^ [#OFFSET (xcb)];
        j := j + 1;
        WHILE xcb^.global_task_id.index > UPPERBOUND (tmv$ptl_p^) DO
          osp$expand_ptl ({ unconditionally_expand } TRUE, status);
          IF NOT status.normal THEN
            osp$set_status_condition (sye$utask_gtid_bad, status);
            EXIT /ijl_created/;
          IFEND;
        WHILEND;
        IF xcb^.xp.p_register.pva.ring = 1 THEN
          display_xcb;
          osp$set_status_condition (sye$utask_in_ring_1, status);
          EXIT /ijl_created/;
        ELSEIF xcb^.system_table_lock_count >= 256 THEN
          display_xcb;
          osp$set_status_condition (sye$utask_sys_tbl_lock_cnt, status);
          EXIT /ijl_created/;
        ELSEIF xcb^.critical_task THEN
          display_xcb;
          osp$set_status_condition (sye$critical_task, status);
          EXIT /ijl_created/;
        ELSEIF xcb^.system_error_count > 0 THEN
          display_xcb;
          osp$set_status_condition (sye$task_had_system_errors, status);
          EXIT /ijl_created/;
        ELSEIF xcb^.xp.trap_enable <> osc$traps_enabled THEN
          display_xcb;
          osp$set_status_condition (sye$utask_traps_disabled, status);
          EXIT /ijl_created/;
        IFEND;

{ Update active io counts in the IOCB (if there is one) so the job does not continue to wait
{ for io to complete after recovery.

        IF xcb^.iocb_p <> NIL THEN
          recover_iocb (^job_fixed^ [#offset (xcb^.iocb_p)]);
          write_job_fixed := TRUE;
        IFEND;


{ Update the monitor and system flags if any from the ptl.  All of the job
{ fixed pages will be written out if flags are updated.

        IF NOT syv$system_was_idle THEN
          syp$update_flags (xcb, optlp, flags_updated);
          IF flags_updated THEN
            write_job_fixed := TRUE;
          IFEND;
        IFEND;
        jr_req.task_list_p^ [j].xcb_offset := xcbo;
        jr_req.task_list_p^ [j].dispatching_priority := jmc$priority_system_job;
        jr_req.task_list_p^ [j].gtid := xcb^.global_task_id;

{!      snap (' reqe', #LOC (jr_req.task_list_p^ [j]), #SIZE (jr_req.
{!            task_list_p^ [j]));

        xcb := xcb^.link;
      WHILEND /follow_xcb_chain/;

      IF write_job_fixed THEN
        syp$write_job_fixed_pages (pc, job_fixed, sfdp, status);
        IF NOT status.normal THEN
          EXIT /ijl_created/;
        IFEND;
      IFEND;

      jr_req.count := j;
      ijlep^.statistics.ready_task_count := 0;
      ijlep^.statistics.tasks_not_in_long_wait := j;
      i#call_monitor (#LOC (jr_req), #SIZE (jr_req));
      IF NOT jr_req.status.normal THEN
        osp$set_status_abnormal ('SY', jr_req.status.condition, 'bad status from mtr', status);
        EXIT /ijl_created/;
      ELSE
        status.normal := TRUE;
      IFEND;
    END /ijl_created/;

    IF jr_req.task_list_p <> NIL THEN
      FREE jr_req.task_list_p IN osv$mainframe_wired_heap^;
    IFEND;

{ If the system was processing in job mode at the time of a failure, then we
{ must discard the executing job (other than SYSTEM) because the running
{ exchange package was not recovered. To restart the job based on it's current
{ exchange package would restart the job backward in time which could cause
{ all kinds of problems especially if the job was writing a new file at the
{ time of the failure.


{ ****** This code only applies to Hot Backup recovery *****
{ ****** It will be reinstated with modifications when *****
{ ****** the 2000 system recovery is implemented.      *****
{   IF status.normal AND NOT syv$system_was_idle THEN
{     IF (oijlep^.swap_status = jmc$iss_executing) AND (oijlep^.ajl_ordinal <> 0) THEN
{       IF (oijlep^.ajl_ordinal = mtv$executing_ajl_at_failure [0]) OR
{             (oijlep^.ajl_ordinal = mtv$executing_ajl_at_failure [1]) THEN
{         osp$set_status_condition (sye$job_damaged, status);
{       IFEND;
{     IFEND;
{   IFEND;

    IF NOT status.normal THEN
      jmp$delete_ijl_entry (ijl_ord);
        IF syv$detailed_critical_displays THEN
          dpp$put_critical_message (status.text.value(1,status.text.size),msg_status);
        IFEND
    ELSE

{ If the job recovered successfully, then indicate that it did.

      job_recovery_disposition := jmc$continue_on_recovery;
      syv$recovering_job_count := syv$recovering_job_count + 1;
      IF syv$recovering_job_count = 1 THEN
        mtv$saved_halt_cpu_ring_number := mtv$halt_cpu_ring_number;
        mtv$halt_cpu_ring_number := 0;
      IFEND;
    IFEND;

    END /jf_seg_open/;

    IF jf_segnumber <> 0 THEN
      mmp$invalidate_segment (jf_segnumber, 1, NIL, ost);
    IFEND;

  PROCEND syp$recover_job_r1;

?? TITLE := 'PROCEDURE recover_iocb', EJECT ??

{ PURPOSE:
{   The purpose of this routine is to clear the active io counts for any asynchronous io the
{   job may have had active, so that the job does not wait for the io to complete after recovery.
{ DESIGN:
{   All io requests that were active when the system went down are changed to complete,
{   (active_io_count = 0, condition = 0) with the io_already_active flag set.  The
{   io_already_active flag causes the io to be reissued when the job checks the status of
{   the io request.

  PROCEDURE recover_iocb
    (    iocb_p: ^mmt$io_control_block);

    VAR
      i: mmt$iocb_index;

    FOR i := LOWERBOUND (iocb_p^.iocb_table) TO iocb_p^.maximum_iocb_index_in_use DO
      IF (iocb_p^.iocb_table [i].active_io_count > 0) AND (iocb_p^.iocb_table [i].
            used_for_asynchronous_io) THEN
        iocb_p^.iocb_table [i].active_io_count := 0;
        iocb_p^.iocb_table [i].condition := 0;
        iocb_p^.iocb_table [i].io_already_active := TRUE;
      IFEND;
    FOREND;
  PROCEND recover_iocb;

?? TITLE := 'PROCEDURE syp$complete_job_recovery', EJECT ??

{ PURPOSE:
{   The purpose of this routine is to free the job recovery statistic buffer.
{   If any jobs failed recovery, the JOB SCHEDULER task will mark them so they can never swap in.
{   It is called AFTER commit and start sched.

  PROCEDURE [XDCL, #GATE] syp$complete_job_recovery;

    VAR
      status: ost$status;

    IF syv$failure_reason_p <> NIL THEN
      FREE syv$failure_reason_p IN osv$mainframe_pageable_heap^;
    IFEND;

    IF syv$recovery_failure_count > 0 THEN
      jmv$job_scheduler_event [jmc$recovery_job_damaged] := TRUE;
      tmp$ready_system_task (tmc$stid_job_scheduler, status);
    IFEND;

  PROCEND syp$complete_job_recovery;
?? TITLE := 'PROCEDURE syp$mfh_for_job_recovery' ??
?? EJECT ??

  PROCEDURE [XDCL] syp$mfh_for_job_recovery;

{ The purpose of this procedure is to process the job recovery monitor flag.
{ It is the FIRST code to execute (in all tasks of a job) in a job during job
{recovery.

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      tlock: [STATIC] ost$signature_lock,
      syv$jr_asid_nz,
      syv$jr_rcv_nr,
      syv$jr_rcv_req: [XDCL] integer := 0,
      psa: ^ost$stack_frame_save_area,
      gtid: ost$global_task_id,
      xcb: ^ost$execution_control_block,
      mlv$job_signon_count: [XREF] integer,
      sn,
      i: integer,
      str: string (72),
      new_sdt_p: ^mmt$segment_descriptor_table,
      request_block: mmt$rb_change_segment_table,
      sdte_p: ^mmt$segment_descriptor,
      sdtxe_p: ^mmt$segment_descriptor_extended,
      traps: 0 .. 3,
      ost,
      status: ost$status;

    PROCEDURE scch
      (    mf: ost$monitor_fault;
           ctc: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      VAR
        status: ost$status;

      status.normal := TRUE;
      syp$process_job_rcv_failure (' job recovery condition handler invoked in syp$mfh_for_job_recovery',
            status);
    PROCEND scch;

    decrement_required := TRUE;
    i#enable_traps (traps);
    syp$establish_condition_handler (^scch);
    pmp$find_executing_task_xcb (xcb);

{This code is to verify the trapped (user) p_register.

    osp$set_signature_lock (tlock, osc$wait, ost);
    psa := #PREVIOUS_SAVE_AREA ();
    WHILE #SEGMENT (psa) = #SEGMENT (psa^.minimum_save_area.a2_previous_save_area) DO
      psa := psa^.minimum_save_area.a2_previous_save_area;
    WHILEND;
    psa := psa^.minimum_save_area.a2_previous_save_area;
    sn := psa^.minimum_save_area.p_register.pva.seg;
    sdte_p := mmp$get_sdt_entry_p (xcb, sn);
    sdtxe_p := mmp$get_sdtx_entry_p (xcb, sn);
    IF sdtxe_p^.sfid.residence = gfc$tr_system_wait_recovery THEN
      syv$jr_rcv_req := syv$jr_rcv_req + 1;
      IF sdte_p^.ste.asid <> 0 THEN
        syv$jr_asid_nz := syv$jr_asid_nz + 1;
      IFEND;
    ELSE
      syv$jr_rcv_nr := syv$jr_rcv_nr + 1;
    IFEND;
    osp$clear_signature_lock (tlock, ost);

    IF (xcb^.xp.segment_table_length * 8) > osv$page_size THEN
      ALLOCATE new_sdt_p: [0 .. xcb^.xp.segment_table_length] IN osv$job_fixed_heap^;
      mmp$free_pages (new_sdt_p, (xcb^.xp.segment_table_length * 8), osc$wait, status);
      mmp$assign_contiguous_memory (new_sdt_p, (xcb^.xp.segment_table_length * 8), status);
      IF NOT status.normal THEN
        syp$process_job_rcv_failure (' Unable to assign contiguous memory', status);
      IFEND;
      request_block.request_code := syc$rc_change_segment_table;
      request_block.new_sdt_offset := #OFFSET (new_sdt_p);
      request_block.new_sdtx_offset := 0;
      request_block.new_sdt_length := xcb^.xp.segment_table_length ;
      i#call_monitor (#LOC (request_block), #SIZE (request_block));
      syp$set_status_from_mtr_status (request_block.status, status);
      IF NOT status.normal THEN
        syp$process_job_rcv_failure (' Problem changing the segment table', status);
      IFEND;
    IFEND;

    IF xcb = jmp$job_monitor_xcb () THEN

{ this is the jmtr task

      xcb := job_xcb_list.head;
      syv$job_task_count := 0;
      osp$initialize_signature_lock (job_task_count_lock, status);
      WHILE xcb <> NIL DO
        syv$job_task_count := syv$job_task_count + 1;
        xcb := xcb^.link;
      WHILEND;

      IF syv$job_recovery_step <> syc$jrs_test_sc_step THEN
        syv$job_recovery_step := syc$jrs_sc_step;

{ reconstruct jcb info as the first thing ...
{ lets hope this isnt too late.
{ Verify the ijl pointer in the jcb that was written from syp$recover_job_r1.

        jmp$get_ijle_p (jmv$jcb.ijl_ordinal, ijle_p);
        IF ijle_p <> jmv$jcb.ijle_p THEN
          osp$system_error (' job recovery -- ijl pointer mismatch', ^status);
        IFEND;
        jmv$jcb.job_id := jmv$jcb.ijle_p^.kjl_ordinal;
        pmv$task_template := jmv$task_private_templ_p;

{ Clear job recovery testing environment

        syv$test_jr_job := syv$test_jr_job - (-$syt$test_jr_set
              [syc$tjr_recursive_recovery, syc$tjr_fail_prior_jfr, fmc$tjr_recover_all_files,
              fmc$tjr_recovery_abort, syc$tjr_fail_post_jfr, syc$tjr_replace_sfid,
              syc$tjr_touch_unrec_segment]);

{ do system core recovery here

        dmp$recover_job_temp_file_space (status);

{ allow local file space recovery - we MAY want to prohibit local file
{ space recovery if ANY job fails in its file space recovery

        IF NOT status.normal THEN
          log ('Job file space conflict');
          syp$process_job_rcv_failure (' CANT RECOVER JOB TEMP FILE SPACE', status);
        IFEND;
        mlv$job_signon_count := 0;
        ofp$job_begin;

        syv$job_recovery_step := syc$jrs_jt_step;
      ELSE

{ testing job recovery in running system

        log ('In test job recovery');
        syv$job_recovery_step := syc$jrs_test_jt_step;
      IFEND;
    ELSE

{ tasks other than jmtr task

      WHILE syv$job_recovery_step < syc$jrs_jt_step DO
        pmp$delay (syv$job_recovery_wait_time, status);
      WHILEND;
    IFEND;

{ The pmp$set_system_flag call must be made with traps enabled
{ so that upon return to the trap sfsa, we return to the job
{ template trap handler, rather than user code.
{ The return MAY cause a page fault on
{ the sfsa p register, which, if it is a perm file, has not
{ yet been re-attached.

    pmp$get_executing_task_gtid (gtid);
    pmp$set_system_flag (syc$job_recovery_flag, gtid, status);
    IF NOT status.normal THEN
      osp$system_error (' job recovery set sys flag', ^status);
    IFEND;
    i#restore_traps (traps);
  PROCEND syp$mfh_for_job_recovery;
?? TITLE := 'PROCEDURE syp$replace_sfid', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$replace_sfid
    (    old_sfid: gft$system_file_identifier;
         new_sfid: gft$system_file_identifier;
         access_state: mmt$segment_access_state;
     VAR status: ost$status);

{ The purpose of this procedure is to replace one sfid with another (replace prior to
{ failure with recovered value after failure).  Each task's (in this job) sdtx is searched.

    VAR
      asti: mmt$ast_index,
      fde_p: gft$locked_file_desc_entry_p,
      i: integer,
      open_count: integer,
      rb: mmt$rb_ring1_segment_request,
      sdte_p: ^mmt$segment_descriptor,
      sdt_p: mmt$max_sdt_p,
      sdtxe_p: ^mmt$segment_descriptor_extended,
      sdtx_p: mmt$max_sdtx_p,
      temp_sfid: gft$system_file_identifier,
      xcb: ^ost$execution_control_block;

    status.normal := TRUE;
    IF syc$tjr_replace_sfid IN syv$test_jr_job THEN
      RETURN;
    IFEND;
    xcb := job_xcb_list.head;


{ Only works for open global files.

    temp_sfid := old_sfid;
    temp_sfid.residence := gfc$tr_system_wait_recovery;

{ Call monitor to update ast sfid fields

    rb.reqcode := syc$rc_ring1_segment_request;
    rb.request := mmc$sr1_replace_sfid;
    asti := 0; {initialize to zero in case the real asti is not found (mtr will handle a zero asti)
    open_count := 0;
    WHILE xcb <> NIL DO
      mmp$get_max_sdt_sdtx_pointer (xcb, sdt_p, sdtx_p);
      FOR i := 0 TO xcb^.xp.segment_table_length DO
        sdte_p := ^sdt_p^.st [i];
        IF sdte_p^.ste.vl <> osc$vl_invalid_entry THEN
          sdtxe_p := ^sdtx_p^.sdtx_table [i];
          IF (sdtxe_p^.sfid = temp_sfid) THEN
            sdtxe_p^.sfid := new_sfid;
            asti := sdte_p^.asti;
            sdtxe_p^.access_state := access_state;
            open_count := open_count + 1;
          IFEND;
          IF (sdtxe_p^.shadow_info.shadow_segment_kind <> mmc$ssk_none) AND
                (sdtxe_p^.shadow_info.shadow_sfid = temp_sfid) THEN
            sdtxe_p^.shadow_info.shadow_sfid := new_sfid;
            open_count := open_count + 1;
          IFEND;
        IFEND;
      FOREND;
      xcb := xcb^.link;
    WHILEND;

{ Replace the SFID in the Active Segment Table (AST).

    rb.asti := asti;
    rb.old_sfid := temp_sfid;
    rb.new_sfid := new_sfid;
    mmp$issue_ring1_segment_request (rb);

{ Update the FDE open count.

    IF open_count <> 0 THEN
      gfp$get_locked_fde_p (new_sfid, fde_p);
      fde_p^.open_count := fde_p^.open_count + open_count;
      gfp$unlock_fde_p (fde_p);
    IFEND;

  PROCEND syp$replace_sfid;
?? TITLE := 'PROCEDURE syp$change_access_state', EJECT ??

{ The purpose of this procedure is to change the access_state in the SDTX for
{ a file. Each task's (in this job) sdtx is searched.

  PROCEDURE [XDCL, #GATE] syp$change_access_state
    (    sfid: gft$system_file_identifier;
         access_state: mmt$segment_access_state;
     VAR status: ost$status);


    VAR
      i: integer,
      sdt_p: mmt$max_sdt_p,
      sdte_p: ^mmt$segment_descriptor,
      sdtx_p: mmt$max_sdtx_p,
      sdtxe_p: ^mmt$segment_descriptor_extended,
      xcb: ^ost$execution_control_block;

    status.normal := TRUE;
    xcb := job_xcb_list.head;

  /for_all_tasks_in_job/
    WHILE xcb <> NIL DO

      mmp$get_max_sdt_sdtx_pointer (xcb, sdt_p, sdtx_p);
    /search_for_file/
      FOR i := 0 TO xcb^.xp.segment_table_length DO
        sdte_p := ^sdt_p^.st [i];
        IF sdte_p^.ste.vl <> osc$vl_invalid_entry THEN
          sdtxe_p := ^sdtx_p^.sdtx_table [i];
          IF (sdtxe_p^.sfid = sfid) THEN
            sdtxe_p^.access_state := access_state;
              IF access_state =  mmc$sas_terminate_access THEN
                sdte_p^.ste.asid := 0;
              IFEND;
          IFEND;
        IFEND;
      FOREND /search_for_file/;
      xcb := xcb^.link;
    WHILEND /for_all_tasks_in_job/;

  PROCEND syp$change_access_state;
?? TITLE := 'PROCEDURE syp$invalidate_open_sfid', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$invalidate_open_sfid
    (    old_sfid: gft$system_file_identifier;
     VAR status: ost$status);

{ The purpose of this procedure is to invalidate the sfid of any
{ open segments with a given sfid.

    VAR
      i: integer,
      sdt_p: mmt$max_sdt_p,
      sdte_p: ^mmt$segment_descriptor,
      sdtx_p: mmt$max_sdtx_p,
      sdtxe_p: ^mmt$segment_descriptor_extended,
      temp_sfid: gft$system_file_identifier,
      xcb: ^ost$execution_control_block;

    status.normal := TRUE;
    xcb := job_xcb_list.head;
    temp_sfid := old_sfid;
    temp_sfid.residence := gfc$tr_system_wait_recovery;

    WHILE xcb <> NIL DO
      mmp$get_max_sdt_sdtx_pointer (xcb, sdt_p, sdtx_p);
      FOR i := 0 TO xcb^.xp.segment_table_length DO
        sdte_p := ^sdt_p^.st [i];
        IF sdte_p^.ste.vl <> osc$vl_invalid_entry THEN
          sdtxe_p := ^sdtx_p^.sdtx_table [i];

{ Check for both local/global and unrecovered sfid.

          IF (sdtxe_p^.sfid = temp_sfid) THEN
            sdte_p^.ste.vl := osc$vl_invalid_entry;
            sdtxe_p^.sfid := gfv$null_sfid;
          IFEND;
          IF (sdtxe_p^.shadow_info.shadow_segment_kind <> mmc$ssk_none) AND
                (sdtxe_p^.shadow_info.shadow_sfid = temp_sfid) THEN
            sdtxe_p^.shadow_info.shadow_segment_kind := mmc$ssk_none;
            sdtxe_p^.shadow_info.shadow_sfid := gfv$null_sfid;
          IFEND;
        IFEND;
      FOREND;
      xcb := xcb^.link;
    WHILEND;
  PROCEND syp$invalidate_open_sfid;
?? TITLE := 'PROCEDURE syp$verify_all_sfids_replaced', EJECT ??

  PROCEDURE syp$verify_all_sfids_replaced
    (VAR status: ost$status);

    VAR
      fde_p: gft$file_desc_entry_p,
      i: integer,
      local_status: ost$status,
      msg: string (50),
      ost: ost$status,
      sdt_p: mmt$max_sdt_p,
      sdte_p: ^mmt$segment_descriptor,
      sdtx_p: mmt$max_sdtx_p,
      sdtxe_p: ^mmt$segment_descriptor_extended,
      sl: integer,
      xcb: ^ost$execution_control_block;

    status.normal := TRUE;

    xcb := job_xcb_list.head;

    WHILE xcb <> NIL DO
      mmp$get_max_sdt_sdtx_pointer (xcb, sdt_p, sdtx_p);
      FOR i := 0 TO xcb^.xp.segment_table_length DO
        sdte_p := ^sdt_p^.st [i];
        IF sdte_p^.ste.vl <> osc$vl_invalid_entry THEN
          sdtxe_p := ^sdtx_p^.sdtx_table [i];
          IF (sdtxe_p^.sfid.residence = gfc$tr_system_wait_recovery) OR
                ((sdtxe_p^.shadow_info.shadow_segment_kind <> mmc$ssk_none) AND
                (sdtxe_p^.shadow_info.shadow_sfid.residence = gfc$tr_system_wait_recovery)) THEN
            IF syv$debug_job_recovery THEN
              syp$invoke_system_debugger ('Job recovery', 0, ost);
            IFEND;
            STRINGREP (msg, sl, 'Recovered segment conflict: ', #OFFSET (xcb): #(16), i: #(16));
            log (msg (1, sl));

{ Leave the sfid alone - so references to it can be trapped via residence.

            IF status.normal THEN
              osp$set_status_condition (sye$open_segs_not_recovered, status);
            IFEND;

          ELSEIF (sdtxe_p^.open_validating_ring_number <> 0) AND
                (mmc$sa_wired IN sdtxe_p^.software_attribute_set) THEN

{ Invalidate wired segments EXCEPT mainframe_wired and network_wired.

            sdte_p^.ste.vl := osc$vl_invalid_entry;
            sdtxe_p^.segment_reservation_state := mmc$srs_reserved;
          ELSE
            gfp$get_fde_p (sdtxe_p^.sfid, fde_p);
            IF fde_p^.media = gfc$fm_mass_storage_file THEN
              dmp$increment_class_activity (sdtxe_p^.sfid, local_status);
              IF NOT local_status.normal AND status.normal THEN
                status := local_status;
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      FOREND;
      xcb := xcb^.link;
    WHILEND;

  PROCEND syp$verify_all_sfids_replaced;
?? TITLE := 'PROCEDURE syp$push_inhibit_job_recovery', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$push_inhibit_job_recovery;

{ This procedure is called by the file system to indicate an operation is in
{progress
{ that does not (yet) allow job recovery.

    CONST
      initial_value = 0;

  TYPE
    sfsa_type = record
      fill1: 0 .. 0ffff(16),
      p: ^cell,
      a0: integer,
      a1: integer,
      fill2: 0 .. 0ffff(16),
      a2: ^sfsa_type, {previous save area pointer}
    recend;

    VAR
      actual_value: integer,
      sfsa_p: ^sfsa_type; {pointer to previous stack frame save area};

    osp$increment_locked_variable (inhibit_job_recovery, initial_value, actual_value);

{! For file system

    osp$begin_subsystem_activity;

    sfsa_p := #previous_save_area ();
    last_inhibit_job_recovery_p:=sfsa_p^.p;

  PROCEND syp$push_inhibit_job_recovery;
?? TITLE := 'PROCEDURE syp$pop_inhibit_job_recovery', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$pop_inhibit_job_recovery;

{ This procedure is the converse of syp$push_inhibit_job_recovery

    CONST
      initial_value = 1;

    VAR
      actual_value: integer,
      error: boolean,
      status: ost$status;

    osp$decrement_locked_variable (inhibit_job_recovery, initial_value, actual_value, error);
    IF error THEN
      syp$invoke_system_debugger (' INHIBIT JOB RECOVERY CONFLICT ', 0, status);
    IFEND;

{! For file system

    osp$end_subsystem_activity;
  PROCEND syp$pop_inhibit_job_recovery;
?? TITLE := 'PROCEDURE syp$increment_server_file_count', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$increment_server_file_count;

    CONST
      initial_value = 0;

    VAR
      actual_value: integer;

    osp$increment_locked_variable (syv$attached_server_file_count, initial_value, actual_value);

  PROCEND syp$increment_server_file_count;
?? TITLE := 'PROCEDURE syp$decrement_server_file_count', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$decrement_server_file_count;

    CONST
      initial_value = 1;

    VAR
      actual_value: integer,
      error: boolean,
      status: ost$status;

    osp$decrement_locked_variable (syv$attached_server_file_count, initial_value, actual_value, error);
    IF error THEN
      syp$invoke_system_debugger (' ATTACHED SERVER FILE COUNT CONFLICT ', 0, status);
    IFEND;
  PROCEND syp$decrement_server_file_count;
?? TITLE := 'PROCEDURE syp$decrement_job_task_count', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$decrement_job_task_count;

{ This procedure keeps track of the number of tasks in a job
{ that have arrived at job template recovery.

    VAR
      status: ost$status;

    osp$set_signature_lock (job_task_count_lock, osc$wait, status);
    syv$job_task_count := syv$job_task_count - 1;
    osp$clear_signature_lock (job_task_count_lock, status);
  PROCEND syp$decrement_job_task_count;
?? TITLE := 'PROCEDURE syp$increment_file_rcv_failure', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$increment_file_rcv_failure;

{  This procedure increments the count of jobs that failed job recovery
{  due to file recovery failure.  The job was able to be terminated.

    VAR
      status: ost$status;

    osp$set_signature_lock (recovering_job_count_lock, osc$wait, status);
    syv$file_rcv_failure_count := syv$file_rcv_failure_count + 1;
    osp$clear_signature_lock (recovering_job_count_lock, status);
  PROCEND syp$increment_file_rcv_failure;

?? TITLE := 'PROCEDURE syp$terminate_unrecovered_job' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] syp$terminate_unrecovered_job
    (    ijl_ordinal: jmt$ijl_ordinal);

{ This procedure is called to get rid of any jobs we are trying to recover for which
{ the job or service class that the job was running in is no longer defined.

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      job_class: jmt$job_class,
      kjl_ord: jmt$kjl_index,
      notify_scheduler_recovery_done: boolean,
      status: ost$status;

    jmp$get_ijle_p (ijl_ordinal, ijle_p);
    jmp$cleanup_unrecovered_job (ijl_ordinal);
    kjl_ord := ijle_p^.kjl_ordinal;
    jmp$delete_ijl_entry (ijl_ordinal);
    jmp$notify_queued_files_job_end (kjl_ord);

    osp$set_signature_lock (recovering_job_count_lock, osc$wait, status);
    syv$recovering_job_count := syv$recovering_job_count - 1;
    notify_scheduler_recovery_done := (syv$recovering_job_count = 0);
    osp$clear_signature_lock (recovering_job_count_lock, status);
    IF notify_scheduler_recovery_done THEN
      mtv$halt_cpu_ring_number := mtv$saved_halt_cpu_ring_number;
      mtv$saved_halt_cpu_ring_number := 0;
      jmv$refresh_job_candidates := TRUE;
      jmv$job_scheduler_event [jmc$examine_input_queue] := TRUE;
      jmv$job_scheduler_event [jmc$examine_swapin_queue] := TRUE;
      tmp$ready_system_task (tmc$stid_job_scheduler, status);
    IFEND;

  PROCEND syp$terminate_unrecovered_job;

?? TITLE := 'PROCEDURE syp$check_maxaj_and_ready_sched' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] syp$check_maxaj_and_ready_sched;

    VAR
      class: jmt$service_class_index,
      service_class_p: ^jmt$service_class_entry,
      str: string (60),
      strl: integer,
      status: ost$status;

{ Make sure that the MAXIMUM ACTIVE JOBS entry in the service class table for all classes with jobs to be
{ recovered is greater than 0.  The recoverable jobs all need to be able to swapin for job recovery to
{ complete, so if the maxaj is 0, raise it to 1.

    FOR class := jmc$system_service_class TO jmv$max_service_class_in_use DO
      service_class_p := jmv$service_classes [class];
      IF (service_class_p <> NIL) AND (service_class_p^.attributes.defined) AND
            (service_class_p^.attributes.maximum_active_jobs = 0) AND
            (jmv$job_counts.service_class_counts [class].swapped_jobs > 0) THEN
        service_class_p^.attributes.maximum_active_jobs := 1;
        str := '  ';
        STRINGREP (str, strl, ' MAXAJ FOR CLASS ', class, ' RAISED TO 1 FOR JOB RECOVERY');
        log (str);
      IFEND;
    FOREND;

    jmv$job_scheduler_event [jmc$ready_task_in_job] := TRUE;
    jmv$job_scheduler_event [jmc$recovery_swapin] := TRUE;
    jmv$job_scheduler_event [jmc$examine_swapin_queue] := TRUE;
    jmv$job_sched_events_selected [jmc$examine_swapin_queue] := TRUE;
    tmp$ready_system_task (tmc$stid_job_scheduler, status);

  PROCEND syp$check_maxaj_and_ready_sched;

?? TITLE := 'PROCEDURE syp$jt_recovery_complete' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] syp$jt_recovery_complete
    (VAR status: ost$status);

{ This procedure is called at the end of job template recovery for
{ a job.

    VAR
      str: string (60),
      i: integer,
      notify_scheduler_recovery_done: boolean,
      ost: ost$status;

    syp$verify_all_sfids_replaced (status);
    osp$set_signature_lock (recovering_job_count_lock, osc$wait, ost);
    IF decrement_required THEN
      syv$recovering_job_count := syv$recovering_job_count - 1;
      decrement_required := FALSE;
    IFEND;
    notify_scheduler_recovery_done := (syv$recovering_job_count = 0);
    osp$clear_signature_lock (recovering_job_count_lock, ost);
    syv$test_jr_job := $syt$test_jr_set [];
    syv$job_recovery_step := syc$jrs_recovery_complete;

    IF notify_scheduler_recovery_done THEN
      mtv$halt_cpu_ring_number := mtv$saved_halt_cpu_ring_number;
      mtv$saved_halt_cpu_ring_number := 0;
      jmv$refresh_job_candidates := TRUE;
      jmv$job_scheduler_event [jmc$examine_input_queue] := TRUE;
      jmv$job_scheduler_event [jmc$examine_swapin_queue] := TRUE;
      tmp$ready_system_task (tmc$stid_job_scheduler, ost);
    IFEND;

    IF NOT status.normal THEN
      syp$process_job_rcv_failure ('Segments(s) not recovered', status);
    IFEND;

  PROCEND syp$jt_recovery_complete;
?? TITLE := 'PROCEDURE syp$recover_volume_file_space' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] syp$recover_volume_file_space;

    VAR
      rb: mmt$rb_ring1_segment_request,
      str: string (60),
      strl: integer,
      ost: ost$status;

    log (' Waiting to recover volume file space ');
    WHILE syv$recovering_job_count <> 0 DO
      pmp$delay (5000, ost);
    WHILEND;

    IF (syv$job_recovery_option = syc$jre_enabled) THEN
      syv$job_recovery_option := syc$jre_recovery_complete;
    IFEND;

{ Discard all PF pages not recovered.

{ The request to discard PF pages has been disabled for now, because of the
{ following problem:
{ If a job discovers that its environment is damaged when it runs its
{ recovery, it is marked as damaged and swapped out.  If it is at the
{ swapped_io_not_initiated state and PF pages are removed from its
{ job working set, then the count of pages that swapper thinks the job
{ has and the count actually in the jws are different.  This causes
{ the system to crash when the swapout advances.  It is too late in
{ job recovery to easily terminate the job when it discovers that its
{ environment is damaged.
{ The monitor request will count the number of files and pages that
{ are involved so that there will be a record in the job log.  No
{ pages are deleted though; the pages will be freed when the job swaps
{ all the way out to disk.

    rb.reqcode := syc$rc_ring1_segment_request;
    rb.request := mmc$sr1_end_job_recovery;
    mmp$issue_ring1_segment_request (rb);

    STRINGREP (str, strl, 'Unrecovered files = ', rb.unrecovered_files);
    log (str (1, strl));
    STRINGREP (str, strl, 'Unrecovered pages = ', rb.unrecovered_pages);
    log (str (1, strl));

    log (' Start returning unused temp file space.');
    dmp$return_temp_file_space;
    log (' Finished returning unused temp file space.');

  PROCEND syp$recover_volume_file_space;
?? TITLE := 'PROCEDURE syp$process_job_rcv_failure', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$process_job_rcv_failure
    (    msg: string ( * ),
         status: ost$status);

    VAR
      mmm: string (72),
      notify_scheduler_recovery_done: boolean,
      ost: ost$status,
      pijle: ^jmt$initiated_job_list_entry,
      sl: integer;

    syv$job_recovery_step := syc$jrs_job_damaged_dont_rec;
    syp$log_recovery_failure (msg, status);
    log (msg);

{ set ijl to indicate this is a "dead" job

    jmp$get_ijle_p (jmv$jcb.ijl_ordinal, pijle);
    pijle^.job_damaged_during_recovery := TRUE;
    IF (syv$debug_job_recovery) AND (status.normal OR ((NOT status.normal) AND
          (status.condition <> ose$path_table_locked))) THEN
      syp$invoke_system_debugger (msg, 0, ost);
    IFEND;
    osp$set_signature_lock (recovering_job_count_lock, osc$wait, ost);
    syv$recovery_failure_count := syv$recovery_failure_count + 1;
    IF decrement_required THEN
      syv$recovering_job_count := syv$recovering_job_count - 1;
      decrement_required := FALSE;
    IFEND;
    notify_scheduler_recovery_done := (syv$recovering_job_count = 0);
    osp$clear_signature_lock (recovering_job_count_lock, ost);

    IF notify_scheduler_recovery_done THEN
      mtv$halt_cpu_ring_number := mtv$saved_halt_cpu_ring_number;
      mtv$saved_halt_cpu_ring_number := 0;
      jmv$refresh_job_candidates := TRUE;
      jmv$job_scheduler_event [jmc$examine_input_queue] := TRUE;
      jmv$job_scheduler_event [jmc$examine_swapin_queue] := TRUE;
      tmp$ready_system_task (tmc$stid_job_scheduler, ost);
    IFEND;

    syv$job_recovery_wait_time := 100000000;
    WHILE TRUE DO
      pmp$delay (syv$job_recovery_wait_time, ost);
    WHILEND;
  PROCEND syp$process_job_rcv_failure;
?? TITLE := 'PROCEDURE [XDCL, #GATE] syp$log_recovery_failure', EJECT ??

{ PURPOSE:
{   This procedure inserts the reason for a job recovery failure into a buffer.  If
{   the reason is already in the buffer then just the reason count is incremented.

  PROCEDURE [XDCL, #GATE] syp$log_recovery_failure
    (    msg: string ( * );
         status: ost$status);

    VAR
      code_index: 0 .. syc$failure_condition_limit,
  stop: cell,
 kill: ^cell,
      err_index: 0 .. jmc$maximum_job_count,
      local_status: ost$status;

    IF syv$failure_reason_p = NIL THEN
      RETURN;
    IFEND;

   stop := kill^;

    osp$set_signature_lock (recovery_failure_lock, osc$wait, local_status);
    err_index := 1;
    WHILE ((syv$failure_reason_p^ [err_index].message <> msg) AND
          (syv$failure_reason_p^ [err_index].msg_count <> 0)) DO
      err_index := err_index + 1;
    WHILEND;
    syv$failure_reason_p^ [err_index].msg_count := syv$failure_reason_p^ [err_index].msg_count + 1;
    syv$failure_reason_p^ [err_index].message := msg;

  /log_condition/
    BEGIN
      code_index := 1;
      IF status.normal THEN
        EXIT /log_condition/;
      IFEND;
      WHILE ((syv$failure_reason_p^ [err_index].conditions [code_index].code <> status.condition) AND
            (syv$failure_reason_p^ [err_index].conditions [code_index].code_count <> 0)) DO
        code_index := code_index + 1;
        IF code_index > syc$failure_condition_limit THEN
          EXIT /log_condition/;
        IFEND;
      WHILEND;
      syv$failure_reason_p^ [err_index].conditions [code_index].code := status.condition;
      syv$failure_reason_p^ [err_index].conditions [code_index].
            code_count := syv$failure_reason_p^ [err_index].conditions [code_index].code_count + 1;
      IF (syv$failure_reason_p^ [err_index].conditions_count < code_index) THEN
        syv$failure_reason_p^ [err_index].conditions_count := code_index;
      IFEND;
    END /log_condition/;

    osp$clear_signature_lock (recovery_failure_lock, local_status);

  PROCEND syp$log_recovery_failure;
?? TITLE := 'PROCEDURE syp$begin_job_recovery', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$begin_job_recovery
    (    buffer_limit: 0 .. jmc$maximum_job_count);

    VAR
      ost: ost$status;

    osp$set_signature_lock (recovering_job_count_lock, osc$wait, ost);
    syv$recovering_job_count := 0;
    syv$recovery_failure_count := 0;
    syv$file_rcv_failure_count := 0;

    IF buffer_limit > 0 THEN
      ALLOCATE syv$failure_reason_p: [1 .. buffer_limit] IN osv$mainframe_pageable_heap^;
      pmp$zero_out_table (#LOC (syv$failure_reason_p^), #SIZE (syv$failure_reason_p^));
    IFEND;

  PROCEND syp$begin_job_recovery;
?? TITLE := 'PROCEDURE syp$end_job_recovery' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] syp$end_job_recovery;

    VAR
      ost: ost$status;

    osp$clear_signature_lock (recovering_job_count_lock, ost);
  PROCEND syp$end_job_recovery;
?? TITLE := 'PROCEDURE syp$job_recovery_from_image' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] syp$job_recovery_from_image
    (    swap_file: ^cell;
         jsn: jmt$system_supplied_name;
     VAR oijlep: ^jmt$initiated_job_list_entry;
     VAR recovery_disposition_available: boolean;
     VAR job_recovery_disposition: jmt$job_recovery_disposition;
     VAR status: ost$status);

    VAR
      am_page_count: integer,
      bi: integer,
      bn: integer,
      fde_p: gft$file_desc_entry_p,
      from_pc: ^mmt$active_segment_table_entry,
      jcbp: ^jmt$job_control_block,
      jcb_found: boolean,
      jcb_search: ^jmt$job_control_block,
      job_page_count: integer,
      new_ijle: jmt$initiated_job_list_entry,
      oajlep: ^jmt$active_job_list_entry,
      oastep: ^mmt$active_segment_table_entry,
      oijlo: jmt$ijl_ordinal,
      oijlxp: ^array [jmt$ijl_block_index] of jmt$initiated_job_list_entry,
      ost: ost$status,
      page_count: integer,
      pfti: integer,
      pps: ^ost$page_size,
      queue_id: mmt$job_page_queue_index,
      sfdo: integer,
      sfd_page_count: integer,
      spd_index: integer,
      sfd_p: ^jst$swap_file_descriptor,
      sfid: gft$system_file_identifier,
      sfsegn: ost$segment,
      swap_file_eoi: amt$file_byte_address,
      swap_file_offset: integer,
      swap_file_sfid: gft$system_file_identifier,
      to_offset: integer,
      to_pc: ^mmt$active_segment_table_entry,
      vpfi: integer,
      wait_count: integer;

    PROCEDURE scch
      (    mf: ost$monitor_fault;
           ctc: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$set_status_condition (sye$condition_encountered, status);
      EXIT syp$job_recovery_from_image;
    PROCEND scch;

    status.normal := TRUE;
    IF syv$system_was_idle THEN
      oijlep := NIL;
      RETURN;
    IFEND;

    syp$establish_condition_handler (^scch);
    status.normal := TRUE;

  /search_ijl/
    BEGIN
      FOR bn := LOWERBOUND (oijlp.block_p^) TO oijlp.max_block_in_use DO
        IF oijlp.block_p^ [bn].index_p <> NIL THEN
          oijlxp := #ADDRESS (1, rmfwsn, #OFFSET (oijlp.block_p^ [bn].index_p));
          FOR bi := LOWERBOUND (oijlxp^) TO UPPERBOUND (oijlxp^) DO
            IF oijlxp^ [bi].system_supplied_name = jsn THEN
              oijlo.block_number := bn;
              oijlo.block_index := bi;
              oijlep := ^oijlxp^ [bi];
              EXIT /search_ijl/;
            IFEND;
          FOREND;
        IFEND;
      FOREND;
      osp$set_status_condition (sye$jsn_not_found_in_ijl, status);
      RETURN;
    END /search_ijl/;

    CASE oijlep^.entry_status OF
    = jmc$ies_entry_free =
      osp$set_status_condition (sye$ijl_entry_free, status);
      RETURN;
    = jmc$ies_job_in_memory_non_swap, jmc$ies_job_terminating =
      osp$set_status_condition (sye$ijl_non_swap, status);
      RETURN;
    = jmc$ies_job_in_memory =

{ do nothing - continue

    = jmc$ies_swapin_in_progress, jmc$ies_job_swapped, jmc$ies_operator_force_out, jmc$ies_ready_task,
          jmc$ies_swapin_candidate =
      IF oijlep^.swap_status >= jmc$iss_swapout_io_complete THEN

        recovery_disposition_available := TRUE;
        job_recovery_disposition := oijlep^.queue_file_information.job_recovery_disposition;
        IF job_recovery_disposition = jmc$terminate_on_recovery THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$job_recovery_or_abort_set, 'TERMINATED',
                status);
          RETURN;
        ELSEIF job_recovery_disposition = jmc$restart_on_recovery THEN
          osp$set_status_abnormal (jmc$job_management_id, jme$job_recovery_or_abort_set, 'RESTARTED', status);
          RETURN;
        IFEND;

{ The job recovery disposition indicated to continue.  If there is a failure now, the job abort disposition
{ will indicate what to do.

        IF oijlep^.queue_file_information.job_abort_disposition = jmc$restart_on_abort THEN
          job_recovery_disposition := jmc$restart_on_recovery;
        ELSE { jmc$terminate_on_abort
          job_recovery_disposition := jmc$terminate_on_recovery;
        IFEND;

        IF oijlep^.last_swap_status >= jmc$iss_swapout_io_complete THEN

{job swapped out - return ok

          status.normal := TRUE;
          RETURN;
        IFEND;
      IFEND;
    ELSE
      osp$set_status_condition (sye$ijl_entry_status_bad, status);
      RETURN;
    CASEND;

{ verify page queues with page frame table

    new_ijle := oijlep^;
    job_page_count := 0;
    IF oijlep^.sfd_p = NIL THEN
      sfdo := UPPERVALUE (integer);
    ELSE
      sfdo := #OFFSET (oijlep^.sfd_p);
    IFEND;
    FOR queue_id := LOWERVALUE (mmt$job_page_queue_index) TO UPPERVALUE (mmt$job_page_queue_index) DO
      new_ijle.swap_data.swapped_job_entry.job_page_queue_count [queue_id] :=
            oijlep^.job_page_queue_list [queue_id].count;
      page_count := oijlep^.job_page_queue_list [queue_id].count;
      job_page_count := job_page_count + page_count;
      pfti := oijlep^.job_page_queue_list [queue_id].link.bkw;
      vpfi := 0;

    /verify_pft/
      WHILE pfti <> 0 DO
        vpfi := vpfi + 1;
        IF vpfi > page_count THEN
          osp$set_status_condition (sye$too_many_pages_in_pft, status);
          RETURN;
        IFEND;
        IF pfti > UPPERBOUND (opftp^) THEN
          osp$set_status_condition (sye$pfi_too_big, status);
          RETURN;
        IFEND;
        IF opftp^ [pfti].pti > UPPERBOUND (oihtp^) THEN
          osp$set_status_condition (sye$pfi_too_big, status);
          RETURN;
        IFEND;
        IF opftp^ [pfti].ijl_ordinal <> oijlo THEN
          osp$set_status_condition (sye$pft_ijlo_no_match, status);
          RETURN;
        IFEND;
        oastep := opftp^ [pfti].aste_p;
        oastep := #ADDRESS (1, rmfwsn, #OFFSET (oastep));
        IF oastep^.in_use = FALSE THEN
          osp$set_status_condition (sye$aste_not_in_use, status);
          RETURN;
        IFEND;
        IF oastep^.ijl_ordinal <> oijlo THEN
          IF ((oastep^.queue_id < mmc$pq_shared_first) OR (oastep^.queue_id > mmc$pq_shared_last)) THEN
            osp$set_status_condition (sye$aste_ijlo_no_match, status);
            RETURN;
          IFEND;
        IFEND;

{ Get the fde pointer for permanent file pages; fde_p will be NIL for non-permanent files.  NIL fde_p
{ must be checked before dereferencing the pointer.

        gfp$get_fde_p_from_image (oastep^.sfid, rmfwsn, fde_p);

{ Special checks for invalid ws pages.  Discard swap file descriptor pages (they are job fixed pages
{ at a specific high offset).  Also discard locked permanent file pages and pages that are being read in.

        IF (opftp^ [pfti].locked_page = mmc$lp_page_in_lock) OR
              ((opftp^ [pfti].queue_id = mmc$pq_job_fixed) AND (opftp^ [pfti].sva.asid =
              oijlep^.job_fixed_asid) AND (opftp^ [pfti].sva.offset >= sfdo)) OR
              ((fde_p <> NIL) AND ((fde_p^.segment_lock.locked_for_write) OR
              (opftp^ [pfti].locked_page = mmc$lp_aging_lock))) THEN
          syv$discarded_page_count := syv$discarded_page_count + 1;
          job_page_count := job_page_count - 1;
          new_ijle.swap_data.swapped_job_entry.job_page_queue_count [queue_id] :=
                new_ijle.swap_data.swapped_job_entry.job_page_queue_count [queue_id] - 1;
        IFEND;
        pfti := opftp^ [pfti].link.bkw;
      WHILEND /verify_pft/;
      IF vpfi <> page_count THEN
        osp$set_status_condition (sye$too_few_pages_in_pft, status);
        RETURN;
      IFEND;
    FOREND;
    am_page_count := 0;
    pfti := opqlp^ [mmc$pq_avail_modified].pqle.link.bkw;

  /vfy_am/
    WHILE pfti <> 0 DO
      IF pfti > UPPERBOUND (opftp^) THEN
        osp$set_status_condition (sye$pfi_too_big, status);
        RETURN;
      IFEND;
      IF opftp^ [pfti].pti > UPPERBOUND (oihtp^) THEN
        osp$set_status_condition (sye$pfi_too_big, status);
        RETURN;
      IFEND;
      IF opftp^ [pfti].ijl_ordinal <> oijlo THEN
        pfti := opftp^ [pfti].link.bkw;
        CYCLE /vfy_am/;
      IFEND;
      oastep := opftp^ [pfti].aste_p;
      oastep := #ADDRESS (1, rmfwsn, #OFFSET (oastep));
      IF oastep^.in_use = FALSE THEN
        osp$set_status_condition (sye$aste_not_in_use, status);
        RETURN;
      IFEND;
      IF oastep^.ijl_ordinal <> oijlo THEN
        IF ((oastep^.queue_id < mmc$pq_shared_first) OR (oastep^.queue_id > mmc$pq_shared_last)) THEN
          osp$set_status_condition (sye$aste_ijlo_no_match, status);
          RETURN;
        IFEND;
      IFEND;

      gfp$get_fde_p_from_image (oastep^.sfid, rmfwsn, fde_p);

      IF (opftp^ [pfti].locked_page = mmc$lp_page_in_lock) OR
            ((opftp^ [pfti].queue_id = mmc$pq_job_fixed) AND (opftp^ [pfti].sva.asid =
            oijlep^.job_fixed_asid) AND (opftp^ [pfti].sva.offset >= sfdo)) OR
            ((fde_p <> NIL) AND ((fde_p^.segment_lock.locked_for_write) OR
            (opftp^ [pfti].locked_page = mmc$lp_aging_lock))) THEN
        pfti := opftp^ [pfti].link.bkw;
        CYCLE /vfy_am/;
      IFEND;

      pfti := opftp^ [pfti].link.bkw;
      am_page_count := am_page_count + 1;
    WHILEND /vfy_am/;

    job_page_count := job_page_count + am_page_count;
    new_ijle.swap_data.swapped_job_entry.job_page_queue_count [mmc$pq_job_working_set] :=
          new_ijle.swap_data.swapped_job_entry.job_page_queue_count [mmc$pq_job_working_set] + am_page_count;
    sfsegn := #SEGMENT (swap_file);
    PUSH sfd_p: [0 .. 0]; {used to get size of a sfd with 1 entry}
    sfd_page_count := 1 + (#SIZE (sfd_p^) + #SIZE (jst$swapped_page_descriptor) * job_page_count - 1) DIV
          osv$page_size;
    WHILE ((job_page_count + sfd_page_count - 1) * #SIZE (jst$swapped_page_descriptor) + #SIZE (sfd_p^)) >
          (sfd_page_count * osv$page_size) DO
      sfd_page_count := sfd_page_count + 1;
    WHILEND;
    new_ijle.swap_data.swapped_job_entry.swap_file_descriptor_page_count := sfd_page_count;
    new_ijle.swap_data.swapped_job_entry.available_modified_page_count := 0;
    new_ijle.swap_data.swapped_job_page_count := job_page_count;

    PUSH sfd_p: [0 .. sfd_page_count + job_page_count - 1];
    gfp$get_segment_sfid (swap_file, sfid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ do not wait for file space!

    wait_count := 5;
    REPEAT
      dmp$allocate_file_space_r1 (sfid, osv$page_size * (sfd_page_count + job_page_count), 0, 0, osc$nowait,
            sfc$no_limit, status);
      wait_count := wait_count - 1;
      IF NOT status.normal THEN
        pmp$delay (1000, ost);
      IFEND;
    UNTIL (status.normal) OR (wait_count = 0);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ EOI is set to zero to avoid reading pages from disk.

    dmp$set_eoi (sfid, 0, status);
    spd_index := 0;
    to_offset := 0;
    FOR queue_id := LOWERVALUE (mmt$job_page_queue_index) TO UPPERVALUE (mmt$job_page_queue_index) DO
      pfti := oijlep^.job_page_queue_list [queue_id].link.bkw;

    /swap_out/
      WHILE pfti <> 0 DO
        oastep := opftp^ [pfti].aste_p;
        oastep := #ADDRESS (1, rmfwsn, #OFFSET (oastep));

{ NOTE: Assumes oastep^.in_use = TRUE

        gfp$get_fde_p_from_image (oastep^.sfid, rmfwsn, fde_p);

        IF (opftp^ [pfti].locked_page = mmc$lp_page_in_lock) OR
              ((opftp^ [pfti].queue_id = mmc$pq_job_fixed) AND (opftp^ [pfti].sva.asid =
              oijlep^.job_fixed_asid) AND (opftp^ [pfti].sva.offset >= sfdo)) OR
              ((fde_p <> NIL) AND ((fde_p^.segment_lock.locked_for_write) OR
              (opftp^ [pfti].locked_page = mmc$lp_aging_lock))) THEN
          pfti := opftp^ [pfti].link.bkw;
          CYCLE /swap_out/;
        IFEND;
        from_pc := #ADDRESS (1, image_segment_number, (pfti *
              osv$page_size) - recovery_load_offset + image_offset);
        to_pc := #ADDRESS (1, sfsegn, to_offset);
        i#move (from_pc, to_pc, osv$page_size);
        sfd_p^.swapped_page_descriptors [spd_index].pft_entry := opftp^ [pfti];
        sfd_p^.swapped_page_descriptors [spd_index].pft_entry.task_queue.head := 0;
        sfd_p^.swapped_page_descriptors [spd_index].pft_entry.task_queue.tail := 0;
        sfd_p^.swapped_page_descriptors [spd_index].pft_entry.aste_p := NIL;
        sfd_p^.swapped_page_descriptors [spd_index].page_table_entry.u := TRUE;
        sfd_p^.swapped_page_descriptors [spd_index].page_table_entry.v := TRUE;
        sfd_p^.swapped_page_descriptors [spd_index].page_table_entry.m := oihtp^ [opftp^ [pfti].pti];
        sfd_p^.swapped_page_descriptors [spd_index].entry_updated := FALSE;
        IF sfd_p^.swapped_page_descriptors [spd_index].pft_entry.active_io_count <> 0 THEN

{ If io is active, then it must be a write - force modified bit on

          sfd_p^.swapped_page_descriptors [spd_index].page_table_entry.m := TRUE;
        IFEND;
        IF (sfd_p^.swapped_page_descriptors [spd_index].page_table_entry.m) AND
              (opftp^ [pfti].locked_page = mmc$lp_not_locked) THEN
          sfd_p^.swapped_page_descriptors [spd_index].page_table_entry.v := TRUE;
        IFEND;

{ Make all unlocked pages in the job working set queue valid.  These may be invalid
{ if the previous system went down in certain areas of monitor's code.

        IF (queue_id = mmc$pq_job_working_set) AND (opftp^ [pfti].locked_page = mmc$lp_not_locked) THEN
          sfd_p^.swapped_page_descriptors [spd_index].page_table_entry.v := TRUE;
        IFEND;
        sfd_p^.swapped_page_descriptors [spd_index].pft_entry.active_io_count := 0;
        sfd_p^.swapped_page_descriptors [spd_index].ast_entry := oastep^;

        spd_index := spd_index + 1;
        to_offset := to_offset + osv$page_size;
        pfti := opftp^ [pfti].link.bkw;
      WHILEND /swap_out/;
    FOREND;
    pfti := opqlp^ [mmc$pq_avail_modified].pqle.link.bkw;

  /swap_am/
    WHILE pfti <> 0 DO
      IF opftp^ [pfti].ijl_ordinal <> oijlo THEN
        pfti := opftp^ [pfti].link.bkw;
        CYCLE /swap_am/;
      IFEND;
      oastep := opftp^ [pfti].aste_p;
      oastep := #ADDRESS (1, rmfwsn, #OFFSET (oastep));

{ NOTE: Assumes oastep^.in_use = TRUE

      gfp$get_fde_p_from_image (oastep^.sfid, rmfwsn, fde_p);

      IF (opftp^ [pfti].locked_page = mmc$lp_page_in_lock) OR
            ((opftp^ [pfti].queue_id = mmc$pq_job_fixed) AND (opftp^ [pfti].sva.asid =
            oijlep^.job_fixed_asid) AND (opftp^ [pfti].sva.offset >= sfdo)) OR
            ((fde_p <> NIL) AND ((fde_p^.segment_lock.locked_for_write) OR
            (opftp^ [pfti].locked_page = mmc$lp_aging_lock))) THEN
        pfti := opftp^ [pfti].link.bkw;
        CYCLE /swap_am/;
      IFEND;
      from_pc := #ADDRESS (1, image_segment_number, (pfti *
            osv$page_size) - recovery_load_offset + image_offset);
      to_pc := #ADDRESS (1, sfsegn, to_offset);
      i#move (from_pc, to_pc, osv$page_size);
      sfd_p^.swapped_page_descriptors [spd_index].pft_entry := opftp^ [pfti];
      sfd_p^.swapped_page_descriptors [spd_index].pft_entry.active_io_count := 0;
      sfd_p^.swapped_page_descriptors [spd_index].pft_entry.task_queue.head := 0;
      sfd_p^.swapped_page_descriptors [spd_index].pft_entry.task_queue.tail := 0;
      sfd_p^.swapped_page_descriptors [spd_index].entry_updated := FALSE;
      sfd_p^.swapped_page_descriptors [spd_index].pft_entry.aste_p := NIL;
      sfd_p^.swapped_page_descriptors [spd_index].pft_entry.queue_id := mmc$pq_job_working_set;
      sfd_p^.swapped_page_descriptors [spd_index].page_table_entry.u := TRUE;
      sfd_p^.swapped_page_descriptors [spd_index].page_table_entry.v := FALSE;

{ force pte valid and modified true because these pages age being put in the jws.

      sfd_p^.swapped_page_descriptors [spd_index].page_table_entry.m := TRUE;
      IF opftp^ [pfti].locked_page = mmc$lp_not_locked THEN
        sfd_p^.swapped_page_descriptors [spd_index].page_table_entry.v := TRUE;
      IFEND;
      sfd_p^.swapped_page_descriptors [spd_index].ast_entry := oastep^;

      spd_index := spd_index + 1;
      to_offset := to_offset + osv$page_size;
      pfti := opftp^ [pfti].link.bkw;
    WHILEND /swap_am/;

{ Move swap file descriptor pages to the swap file.

    sfd_p^.ijl_entry := new_ijle;
    sfd_p^.swapped_job_entry := new_ijle.swap_data.swapped_job_entry;
    jcb_found := FALSE;
    swap_file_offset := 0;
    gfp$get_segment_sfid (swap_file, swap_file_sfid, status);
    dmp$fetch_eoi (swap_file_sfid, swap_file_eoi, status);
    WHILE NOT jcb_found DO
      jcb_search := #ADDRESS (1, #SEGMENT (swap_file), swap_file_offset);
      IF jcb_search^.jcb_identifier = 0FF00(16) THEN
        jcbp := jcb_search;
        jcb_found := TRUE;
      ELSE
        swap_file_offset := swap_file_offset + osv$page_size;
        IF swap_file_offset > swap_file_eoi THEN
          osp$set_status_condition (sye$unable_to_locate_jcb, status);
          RETURN;
        IFEND;
      IFEND;
    WHILEND;
    jcbp^.swapped_job_entry := new_ijle.swap_data.swapped_job_entry;
    i#move (#LOC (sfd_p^), #ADDRESS (1, sfsegn, to_offset), #SIZE (sfd_p^));
    mmp$write_modified_pages (swap_file, #SIZE (sfd_p^) + to_offset, osc$wait, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{ double check

    IF jcbp^.system_name <> jsn THEN
      osp$set_status_condition (sye$jcb_jsn_no_match, status);
      RETURN;
    IFEND;
    IF jcbp^.ijl_ordinal <> oijlo THEN
      osp$set_status_condition (sye$jcb_ijlo_no_match, status);
      RETURN;
    IFEND;
  PROCEND syp$job_recovery_from_image;
?? TITLE := 'PROCEDURE syp$init_job_rec_from_image' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] syp$init_job_rec_from_image
    (VAR status: ost$status);

    VAR
      idle_status: ost$name,
      idle_status_seq_p: ^SEQ ( * ),
      image_descriptor: dst$nve_image_descriptor,
      job_recovery_is_enabled: boolean,
      job_recovery_status: string (8),
      job_recovery_status_seq_p: ^SEQ ( * ),
      oijlpp: ^jmt$ijl_p,
      oajlpp: ^^jmt$active_job_list,
      opftpp: ^^mmt$page_frame_table,
      optlpp: ^^tmt$primary_task_list,
      paa: ^^cell;

    PROCEDURE scch
      (    mf: ost$monitor_fault;
           ctc: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$set_status_condition (sye$condition_encountered, status);
      EXIT syp$init_job_rec_from_image;
    PROCEND scch;

    syp$establish_condition_handler (^scch);
    status.normal := TRUE;

{ Fetch the idle status of the system from the RDF area.

    idle_status_seq_p := #SEQ (idle_status);
    dsp$get_data_from_rdf (dsc$rdf_system_idled_status, dsc$rdf_recovery, idle_status_seq_p);
    syv$system_was_idle := (idle_status = dsc$nve_idled);

    IF syv$system_was_idle THEN

{All jobs were swapped out if system was idle.

      RETURN;
    IFEND;

{ Image file required from this point on !!!!!

    dsp$get_nve_image_description (image_descriptor);
    rmfwsn := #SEGMENT (image_descriptor.rcv_mainframe_wired_segment);

    recovery_load_offset := image_descriptor.rcv_load_offset;
    image_segment_number := #SEGMENT (image_descriptor.nve_image);
    image_offset := #OFFSET (image_descriptor.nve_image);

{!  snap ('rlo', #LOC (recovery_load_offset), #SIZE (recovery_load_offset));
{!  snap ('isn', #LOC (image_segment_number), #SIZE (image_segment_number));
{!  snap ('imgo', #LOC (image_offset), #SIZE (image_offset));

    oihtp := image_descriptor.rcv_hash_tbl_p;

    oijlpp := #ADDRESS (1, rmfwsn, #OFFSET (^jmv$ijl_p));
    oijlp := oijlpp^;

{!  snap ('oijlp', #LOC (oijlp), #SIZE (oijlp));

    IF (#RING (oijlp.block_p) <> 1) OR (#SEGMENT (oijlp.block_p) <> 1) OR (#OFFSET (oijlp.block_p) <= 0) THEN
      osp$set_status_condition (sye$ijl_offset_error, status);
      syv$job_recovery_option := syc$jre_system_disabled;
      RETURN;
    IFEND;
    paa := #LOC (oijlp.block_p);
    i#build_adaptable_array_ptr (1, rmfwsn, #OFFSET (oijlp.block_p), #SIZE (oijlp.block_p^),
          LOWERBOUND (oijlp.block_p^), #SIZE (oijlp.block_p^ [1]), #LOC (paa^));

    oajlpp := #ADDRESS (1, rmfwsn, #OFFSET (^jmv$ajl_p));
    oajlp := oajlpp^;

{!  snap ('oajlp', #LOC (oajlp), #SIZE (oajlp));

    IF (#RING (oajlp) <> 1) OR (#SEGMENT (oajlp) <> 1) OR (#OFFSET (oajlp) <= 0) THEN
      osp$set_status_condition (sye$ajl_offset_error, status);
      syv$job_recovery_option := syc$jre_system_disabled;
      RETURN;
    IFEND;
    paa := #LOC (oajlp);
    i#build_adaptable_array_ptr (1, rmfwsn, #OFFSET (oajlp), #SIZE (oajlp^), LOWERBOUND (oajlp^),
          #SIZE (oajlp^ [1]), #LOC (paa^));

    opftpp := #ADDRESS (1, rmfwsn, #OFFSET (^mmv$pft_p));
    opftp := opftpp^;

{!  snap ('opftp', #LOC (opftp), #SIZE (opftp));

    IF (#RING (opftp) <> 1) OR (#SEGMENT (opftp) <> 1) OR (#OFFSET (opftp) <= 0) THEN
      osp$set_status_condition (sye$pft_offset_error, status);
      syv$job_recovery_option := syc$jre_system_disabled;
      RETURN;
    IFEND;
    paa := #LOC (opftp);
    i#build_adaptable_array_ptr (1, rmfwsn, #OFFSET (opftp), #SIZE (opftp^), LOWERBOUND (opftp^),
          #SIZE (opftp^ [LOWERBOUND (opftp^)]), #LOC (paa^));

    optlpp := #ADDRESS (1, rmfwsn, #OFFSET (^tmv$ptl_p));
    optlp := optlpp^;

{!  snap ('optlp', #LOC (optlp), #SIZE (optlp));

    IF (#RING (optlp) <> 1) OR (#SEGMENT (optlp) <> 1) OR (#OFFSET (optlp) <= 0) THEN
      osp$set_status_condition (sye$ptl_offset_error, status);
      syv$job_recovery_option := syc$jre_system_disabled;
      RETURN;
    IFEND;
    paa := #LOC (optlp);
    i#build_adaptable_array_ptr (1, rmfwsn, #OFFSET (optlp), #SIZE (optlp^), LOWERBOUND (optlp^),
          #SIZE (optlp^ [1]), #LOC (paa^));

    opqlp := ^mmv$gpql;
    opqlp := #ADDRESS (1, rmfwsn, #OFFSET (opqlp));

  PROCEND syp$init_job_rec_from_image;
?? TITLE := 'PROCEDURE syp$test_job_recovery', EJECT ??

  PROCEDURE [XDCL] syp$test_job_recovery
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      str: string (60),
      i: integer,
      ijlep: ^jmt$initiated_job_list_entry;

    wid := id;
    jmp$get_ijle_p (jmv$jcb.ijl_ordinal, ijlep);
    IF ijlep = NIL THEN
      status.normal := FALSE;
      RETURN;
    IFEND;
    syv$job_recovery_step := syc$jrs_test_sc_step;
    ijlep^.delayed_swapin_work := ijlep^.delayed_swapin_work + $jmt$delayed_swapin_work
          [jmc$dsw_job_recovery];
    str := '  ';
    STRINGREP (str, i, 'Recovery test ', text);
    log (str);
    status.normal := TRUE;

{  force a swapout here to get job recovery started

    pmp$delay (10000, status);
  PROCEND syp$test_job_recovery;
?? TITLE := 'PROCEDURE syp$invoke_syscore_cond_handler', EJECT ??

  PROCEDURE [XDCL] syp$invoke_syscore_cond_handler;

    PROCEDURE handler_failed
      (    mf: ost$monitor_fault;
           continue: ^ost$minimum_save_area;
       VAR continue_option: syt$continue_option);

      hang_task (' R1 HANDLER FAILED ');
    PROCEND handler_failed;

    VAR
      mf: ost$monitor_fault,
      syv$number_of_sc_conds: [XDCL] integer := 0,
      psa: ^ost$minimum_save_area,
      processed: syt$continue_option,
      found: boolean;

    processed := syc$condition_ignored;
    syv$number_of_sc_conds := syv$number_of_sc_conds + 1;
    syp$establish_condition_handler (^handler_failed);
    psa := #PREVIOUS_SAVE_AREA ();
    get_monitor_fault (mf, found);
    IF found THEN
      invoke_handler (psa, mf, processed);
      IF processed = syc$condition_ignored THEN
        hang_task_no_handler (mf);
      IFEND;
    IFEND;
  PROCEND syp$invoke_syscore_cond_handler;
?? TITLE := 'PROCEDURE invoke_handler', EJECT ??

  PROCEDURE invoke_handler
    (    cpsa: ^ost$minimum_save_area;
         mf: ost$monitor_fault;
     VAR processed: syt$continue_option);

    VAR
      psa: ^ost$minimum_save_area,
      pc: cell,
      vfy: ^ost$pva,
      ped: ^syt$established_handler,
      csf: ^^syt$established_handler,
      traps: 0 .. 3;

    psa := cpsa;

  /search_for_handler/
    WHILE psa <> NIL DO
      IF (#RING (^pc) <> #RING (psa)) OR (#SEGMENT (^pc) <> #SEGMENT (psa)) THEN
        EXIT /search_for_handler/;
      IFEND;
      IF psa^.frame_descriptor.on_condition_flag THEN
        vfy := #LOC (psa^.a1_current_stack_frame^);
        IF (vfy^.ring = #RING (^pc)) AND (vfy^.seg = #SEGMENT (^pc)) AND (vfy^.offset < #OFFSET (psa)) THEN
          csf := psa^.a1_current_stack_frame;
          ped := csf^;
          IF ped^.handler <> NIL THEN
            i#enable_traps (traps);
            ped^.handler^ (mf, psa, processed);
            i#restore_traps (traps);
            IF processed = syc$condition_processed THEN
              RETURN;
            IFEND;
          ELSE
            hang_task (' bad established handler');
          IFEND;
        ELSE
          hang_task (' bad established handler');
        IFEND;
      IFEND;
      psa := #LOC (psa^.a2_previous_save_area^);
    WHILEND /search_for_handler/;
  PROCEND invoke_handler;
?? TITLE := 'PROCEDURE syp$invoke_syscore_ucr_handler', EJECT ??

  PROCEDURE [XDCL] syp$invoke_syscore_ucr_handler
    (    ucr: ost$user_conditions);

    PROCEDURE handler_failed
      (    mf: ost$monitor_fault;
           continue: ^ost$minimum_save_area;
       VAR continue_option: syt$continue_option);

      hang_task (' R1 HANDLER FAILED ');
    PROCEND handler_failed;

    VAR
      pscc: ^syt$system_core_condition,
      processed: syt$continue_option,
      psa: ^ost$minimum_save_area,
      mf: ost$monitor_fault;

    processed := syc$condition_ignored;
    syp$establish_condition_handler (^handler_failed);
    mf.identifier := syc$system_core_condition;
    pscc := #LOC (mf.contents);
    pscc^.condition := syc$ucr_condition;
    psa := #PREVIOUS_SAVE_AREA ();
    pscc^.sfsa := #LOC (psa^.a2_previous_save_area^);
    pscc^.ucr := ucr;

    invoke_handler (psa, mf, processed);
    IF processed = syc$condition_ignored THEN
      hang_task_no_handler (mf);
    IFEND;
  PROCEND syp$invoke_syscore_ucr_handler;
?? TITLE := 'PROCEDURE syp$cause_condition', EJECT ??

  PROCEDURE [XDCL] syp$cause_condition
    (    condition: syt$user_defined_condition);

    PROCEDURE handler_failed
      (    mf: ost$monitor_fault;
           continue: ^ost$minimum_save_area;
       VAR continue_option: syt$continue_option);

      hang_task (' R1 HANDLER FAILED ');
    PROCEND handler_failed;

    VAR
      pscc: ^syt$system_core_condition,
      processed: syt$continue_option,
      psa: ^ost$minimum_save_area,
      mf: ost$monitor_fault;

    processed := syc$condition_ignored;
    syp$establish_condition_handler (^handler_failed);
    mf.identifier := syc$system_core_condition;
    pscc := #LOC (mf.system_core_condition);
    pscc^.condition := syc$user_defined_condition;
    pscc^.user_defined_condition := condition;
    psa := #PREVIOUS_SAVE_AREA ();
    pscc^.sfsa := #LOC (psa^.a2_previous_save_area^);

    invoke_handler (psa, mf, processed);
  PROCEND syp$cause_condition;
?? TITLE := 'PROCEDURE syp$continue_to_cause', EJECT ??

  PROCEDURE [XDCL] syp$continue_to_cause
    (    mf: ost$monitor_fault;
         continue: ^ost$minimum_save_area;
         continue_option: syt$continue_option;
     VAR final_continue_option: syt$continue_option);

    PROCEDURE handler_failed
      (    mf: ost$monitor_fault;
           ctc: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      hang_task (' R1 HANDLER FAILED ');
    PROCEND handler_failed;

    VAR
      psa: ^ost$minimum_save_area;

    IF continue_option = syc$condition_processed THEN
      final_continue_option := syc$condition_processed;
    IFEND;
    syp$establish_condition_handler (^handler_failed);
    psa := continue;
    IF psa <> NIL THEN
      psa := #LOC (psa^.a2_previous_save_area^);
      invoke_handler (psa, mf, final_continue_option);
    IFEND;

  PROCEND syp$continue_to_cause;
?? TITLE := 'PROCEDURE get_monitor_fault', EJECT ??

  PROCEDURE get_monitor_fault
    (VAR fault: ost$monitor_fault;
     VAR fault_found: boolean);

    VAR
      trap_enables: 0 .. 3,
      xcb: ^ost$execution_control_block,
      fault_status: tmt$fault_status,
      fault_index: 1 .. (tmc$maximum_monitor_faults + 1);

    fault_found := FALSE;
    fault_index := LOWERVALUE (tmt$monitor_fault_buffers);
    pmp$find_executing_task_xcb (xcb);
    i#disable_traps (trap_enables);

    WHILE NOT fault_found AND (fault_index <= UPPERVALUE (tmt$monitor_fault_buffers)) DO
      IF xcb^.monitor_faults.present [fault_index] THEN
        IF xcb^.monitor_faults.buffer [fault_index].pva.ring = 1 THEN
          tmp$get_monitor_fault (fault_index, fault, fault_status);
          CASE fault_status OF
          = tmc$normal_fault_status =
            fault_found := TRUE;
          = tmc$no_fault_present =
            ;
          = tmc$invalid_fault_index =
            ;
          ELSE
          CASEND;
        IFEND;
      IFEND;
      fault_index := fault_index + 1;
    WHILEND;
    i#restore_traps (trap_enables);
  PROCEND get_monitor_fault;
?? TITLE := 'PROCEDURE hang_task', EJECT ??

  PROCEDURE hang_task
    (    text: string ( * ));

    VAR
      xcb: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb);
    IF (xcb^.system_table_lock_count >= 256) OR (xcb^.critical_task) THEN
      osp$fatal_system_error (text, NIL);
    ELSE
      osp$check_for_job_recovery ('HUNG TASK during job recovery');
      syp$mfh_for_hang_task;
    IFEND;

  PROCEND hang_task;
?? TITLE := 'PROCEDURE hang_task_no_handler', EJECT ??

{  PURPOSE:   Procedure hang_task_no_handler
{  Is called to hang the task because a call to invoke a handler failed to find a handler.  If the
{  monitor fault is a broken task and the broken task ID is "system error", then osp$fatal_system_error is
{  called to stop the system and issue the text found in the broken task fault.  Otherwise the procedure
{  hang_task is called with a string.  For other broken task faults, the string identifies the broken task
{  fault.  If the monitor fault is not a broken task, the string will remain as "R1 CONDITION - NO HANDLER"
{
{   A monitor fault indicating that the permanent or temporary file space limit
{   has been exceeded will be ignored.  It is a non-fatal error in ring one.

  PROCEDURE hang_task_no_handler
    (    mf: ost$monitor_fault);

    VAR
      msg: string (71),
      broken_task: ^tmt$broken_task_monitor_fault,
      segment_access_condition: ^mmt$segment_access_condition;

    IF mf.identifier = tmc$broken_task_fault_id THEN
      broken_task := #LOC (mf.contents);
      msg := 'Broken Task ID= ';
      CASE broken_task^.broken_task_condition OF
      = tmc$btc_mntr_fault_buffer_full =
        msg (17, * ) := 'Monitor fault buffer full ';
      = tmc$btc_mf_traps_disabled =
        msg (17, * ) := 'Monitor fault traps disabled ';
      = tmc$btc_invalid_a0 =
        msg (17, * ) := 'Invalid A0 ';
      = tmc$btc_invalid_p =
        msg (17, * ) := 'Invalid P ';
      = tmc$btc_mcr_traps_disabled =
        msg (17, * ) := 'MCR traps disabled ';
      = tmc$btc_ucr_traps_disabled =
        msg (17, * ) := 'UCR traps disabled ';
      = tmc$btc_system_error =
        msg := broken_task^.text_p^;
      ELSE
      CASEND;
      hang_task (msg);
    ELSEIF mf.identifier = mmc$segment_fault_processor_id THEN
      segment_access_condition := #LOC (mf.contents);
      CASE segment_access_condition^.identifier OF
      = mmc$sac_pf_space_limit_exceeded, mmc$sac_tf_space_limit_exceeded =
        RETURN;
      ELSE
      CASEND;
    IFEND;
    hang_task (' R1 CONDITION - NO HANDLER');

  PROCEND hang_task_no_handler;
?? TITLE := 'PROCEDURE syp$mfh_for_hang_task', EJECT ??

  PROCEDURE [XDCL] syp$mfh_for_hang_task;

    VAR
      ijlp: ^jmt$initiated_job_list_entry,
      xcb: ^ost$execution_control_block,
      status: ost$status;

    jmp$get_ijle_p (jmv$jcb.ijl_ordinal, ijlp);
    ijlp^.hung_task_in_job := TRUE;
    pmp$find_executing_task_xcb (xcb);

    syp$invoke_system_debugger ('Hung task', 0, status);

    WHILE TRUE DO
      syp$wait (tmc$infinite_wait);
      IF syc$mf_invoke_sysdebug IN xcb^.monitor_flags THEN
        xcb^.monitor_flags := xcb^.monitor_flags - $syt$monitor_flags [syc$mf_invoke_sysdebug];
        syp$invoke_system_debugger ('delayed hung task debug', 0, status);
      IFEND;
    WHILEND;

  PROCEND syp$mfh_for_hang_task;
?? TITLE := 'System Core Condition Handling Tests', EJECT ??
*copyc pmt$program_parameters

{Test mcr & non local exit

  PROCEDURE test_sc_ch1
    (    p: pmt$program_parameters;
     VAR status: ost$status);

    PROCEDURE sch
      (    mf: ost$monitor_fault;
           ctc: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      log (' SC CH ENTERED');
      syp$continue_to_cause (mf, ctc, syc$condition_processed, continue);
      osp$set_status_abnormal ('YY', 88776, ' test ok ', status);
      EXIT test_sc_ch1;
    PROCEND sch;

    VAR
      pc: ^cell,
      c: cell;

    status.normal := TRUE;
    IF mtv$halt_cpu_ring_number > 0 THEN
      log (' HALTRING MUST BE ZERO ');
      RETURN;
    IFEND;
    syp$establish_condition_handler (^sch);
    pc := NIL;
    WHILE TRUE DO
      c := pc^;
    WHILEND;
  PROCEND test_sc_ch1;

{Test ucr & non local exit

  PROCEDURE test_sc_ch5
    (    p: pmt$program_parameters;
     VAR status: ost$status);

    PROCEDURE sch
      (    mf: ost$monitor_fault;
           ctc: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      log (' SC CH ENTERED-UCR');
      syp$continue_to_cause (mf, ctc, syc$condition_processed, continue);
      osp$set_status_abnormal ('YY', 88776, ' test ok ', status);
      EXIT test_sc_ch5;
    PROCEND sch;

    VAR
      i: integer;

    status.normal := TRUE;
    IF mtv$halt_cpu_ring_number > 0 THEN
      log (' HALTRING MUST BE ZERO ');
      RETURN;
    IFEND;
    syp$establish_condition_handler (^sch);
    i := 10;
    WHILE TRUE DO
      i := i DIV 0;
    WHILEND;
  PROCEND test_sc_ch5;

{Test no handler - should fail

  PROCEDURE test_sc_ch2
    (    p: pmt$program_parameters;
     VAR status: ost$status);

    VAR
      pc: ^cell,
      c: cell;

    status.normal := TRUE;
    IF mtv$halt_cpu_ring_number > 0 THEN
      log (' HALTRING MUST BE ZERO ');
      RETURN;
    IFEND;
    pc := NIL;
    WHILE TRUE DO
      c := pc^;
    WHILEND;
  PROCEND test_sc_ch2;

{Test handler failure - should fail

  PROCEDURE test_sc_ch3
    (    p: pmt$program_parameters;
     VAR status: ost$status);

    PROCEDURE sch
      (    mf: ost$monitor_fault;
           ctc: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      log (' SC CH ENTERED');
      osp$set_status_abnormal ('YY', 88776, ' test failed ', status);
      pc := NIL;
      pc^ := c;
    PROCEND sch;

    VAR
      pc: ^cell,
      c: cell;

    status.normal := TRUE;
    IF mtv$halt_cpu_ring_number > 0 THEN
      log (' HALTRING MUST BE ZERO ');
      RETURN;
    IFEND;
    syp$establish_condition_handler (^sch);
    pc := NIL;
    WHILE TRUE DO
      c := pc^;
    WHILEND;
  PROCEND test_sc_ch3;

{Test continue to cause - ignored - should fail

  PROCEDURE test_sc_ch6
    (    p: pmt$program_parameters;
     VAR status: ost$status);

    PROCEDURE sch
      (    mf: ost$monitor_fault;
           ctc: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      log (' SC CH ENTERED');
      syp$continue_to_cause (mf, ctc, syc$condition_ignored, continue);
    PROCEND sch;

    VAR
      pc: ^cell,
      c: cell;

    status.normal := TRUE;
    IF mtv$halt_cpu_ring_number > 0 THEN
      log (' HALTRING MUST BE ZERO ');
      RETURN;
    IFEND;
    syp$establish_condition_handler (^sch);
    pc := NIL;
    WHILE TRUE DO
      c := pc^;
    WHILEND;
  PROCEND test_sc_ch6;

{Test no continue - condition ignored by handler - should fail

  PROCEDURE test_sc_ch7
    (    p: pmt$program_parameters;
     VAR status: ost$status);

    PROCEDURE sch
      (    mf: ost$monitor_fault;
           ctc: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      log (' SC CH ENTERED');
    PROCEND sch;

    VAR
      pc: ^cell,
      c: cell;

    status.normal := TRUE;
    IF mtv$halt_cpu_ring_number > 0 THEN
      log (' HALTRING MUST BE ZERO ');
      RETURN;
    IFEND;
    syp$establish_condition_handler (^sch);
    pc := NIL;
    WHILE TRUE DO
      c := pc^;
    WHILEND;
  PROCEND test_sc_ch7;

{Test nested handlers and continue to cause

  PROCEDURE test_sc_ch4
    (    p: pmt$program_parameters;
     VAR status: ost$status);

    PROCEDURE b
      (VAR status: ost$status);

      PROCEDURE c
        (    mf: ost$monitor_fault;
             ctc: ^ost$minimum_save_area;
         VAR continue: syt$continue_option);

        VAR
          ost: ost$status;

        log (' in proc c');
        osp$set_status_abnormal ('zq', 939, ' b exited by c', status);
        log (' c doing continue');
        syp$continue_to_cause (mf, ctc, syc$condition_processed, continue);
        log (' continue returned to c');
        EXIT b;
      PROCEND c;

      log (' in proc b ');
      syp$invoke_syscore_cond_handler;
      log (' invoke returned to b');
      syp$establish_condition_handler (^c);
      log (' proc b ready');
      z (status);
      log (' ERROR - b xqtd to much');
    PROCEND b;

    PROCEDURE z
      (VAR status: ost$status);

      PROCEDURE zc
        (    mf: ost$monitor_fault;
             ctc: ^ost$minimum_save_area;
         VAR continue: syt$continue_option);

        VAR
          ost: ost$status;

        log (' in proc zc');
        osp$set_status_abnormal ('zq', 993, ' z exited by zc', status);
        log (' zc doing continue');
        syp$continue_to_cause (mf, ctc, syc$condition_processed, continue);
        log (' ERROR - continue returned to zc');
        EXIT z;
      PROCEND zc;

      VAR
        pc: ^cell,
        c: cell;

      log (' in proc z ');
      syp$establish_condition_handler (^zc);
      log (' proc z ready');
      pc := NIL;
      pc^ := c;
      log (' ERROR - z xqtd to much');
    PROCEND z;

    VAR
      ost: ost$status;

    IF mtv$halt_cpu_ring_number > 0 THEN
      log (' HALTRING MUST BE ZERO ');
      RETURN;
    IFEND;
    b (status);
    log (' return from b to a');
  PROCEND test_sc_ch4;

  TYPE
    zzzz = (job, system);

?? TITLE := 'PROCEDURE syp$set_job_recovery_test', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$set_job_recovery_test
    (    t: zzzz;
         option: 0 .. 255);

    IF syv$allow_jr_test THEN
      IF t = job THEN
        syv$test_jr_job := syv$test_jr_job + $syt$test_jr_set [option];
      ELSE
        syv$test_jr_system := syv$test_jr_system + $syt$test_jr_set [option];
      IFEND;
    IFEND;

  PROCEND syp$set_job_recovery_test;

?? TITLE := 'PROCEDURE syp$set_system_idling', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$set_system_idling
    (    system_is_idling: boolean);

    syv$system_is_idling := system_is_idling;
  PROCEND syp$set_system_idling;


?? TITLE := 'PROCEDURE syp$system_is_idling', EJECT ??

  FUNCTION [XDCL, #GATE] syp$system_is_idling: boolean;

    syp$system_is_idling := syv$system_is_idling;
  FUNCEND syp$system_is_idling;

?? TITLE := 'PROCEDURE syp$clear_job_recovery_test', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$clear_job_recovery_test
    (    t: zzzz;
         option: 0 .. 255);

    IF (option < 0) OR (option > 255) THEN
      RETURN;
    IFEND;
    IF t = job THEN
      syv$test_jr_job := syv$test_jr_job - $syt$test_jr_set [option];
    ELSE
      syv$test_jr_system := syv$test_jr_system - $syt$test_jr_set [option];
    IFEND;

  PROCEND syp$clear_job_recovery_test;
?? TITLE := 'PROCEDURE syp$increment_avt_r1', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$increment_avt_r1
    (    sfid: gft$system_file_identifier;
     VAR status: ost$status);

    dmp$increment_class_activity (sfid, status);
  PROCEND syp$increment_avt_r1;
?? TITLE := 'PROCEDURE syp$disable_job_recovery', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$disable_job_recovery;

    VAR
      job_recovery_status: string (8);

    IF (syv$job_recovery_option = syc$jre_enabled) THEN
      syv$job_recovery_option := syc$jre_system_disabled;
    IFEND;

    job_recovery_status := 'disable';
    dsp$store_data_in_rdf (dsc$rdf_job_recovery, dsc$rdf_production, #SEQ (job_recovery_status));
    log ('Job recovery disabled by the system');

  PROCEND syp$disable_job_recovery;
?? TITLE := 'PROCEDURE syp$enable_job_recovery', EJECT ??

  PROCEDURE [XDCL] syp$enable_job_recovery;

    VAR
      job_recovery_status: string (8);

    { Once job recovery has been disabled, variable syv$job_recovery_option should not be set
    { back to syc$jre_enabled.  This is because Device Manager releases temporary file space
    { when a volume is recovered, if syv$job_recovery_option says job recovery is not enabled.
    { Once temporary file space has been released, job recovery is impossible during the current
    { deadstart.  Also, if syv$job_recovery_option is not left at syc$jre_recovery_complete,
    { temporary file space will not be released properly if a volume is turned on after deadstart.

    job_recovery_status := 'enable';
    dsp$store_data_in_rdf (dsc$rdf_job_recovery, dsc$rdf_production, #SEQ (job_recovery_status));

  PROCEND syp$enable_job_recovery;
?? TITLE := 'PROCEDURE mtp$error_stop', EJECT ??

  PROCEDURE [XDCL] mtp$error_stop
    (    str: string ( * ));

    osp$system_error (str, NIL);

  PROCEND mtp$error_stop;
?? TITLE := 'PROCEDURE [XDCL] syp$terminate_task', EJECT ??

  PROCEDURE [XDCL] syp$terminate_task
    (    termination_reason: ost$ring1_termination_reason);

    VAR
      status: ost$status,
      xcb_p: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb_p);
    xcb_p^.ring1_termination_reason := termination_reason;
    pmp$set_system_flag (pmc$sf_terminate_task, xcb_p^.global_task_id, status);

  PROCEND syp$terminate_task;
?? TITLE := 'PROCEDURE syp$get_job_swap_status', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$get_job_swap_status
    (    ijl_ordinal: jmt$ijl_ordinal;
     VAR swapped_out: boolean);

    VAR
      initialized: [STATIC] boolean := FALSE,
      all_swapped: [STATIC] boolean := FALSE,
      status: ost$status,
      oijlxp: ^array [jmt$ijl_block_index] of jmt$initiated_job_list_entry;

    swapped_out := TRUE;

    IF NOT initialized THEN
      initialized := TRUE;
      syp$init_job_rec_from_image (status);
      IF NOT status.normal THEN
        all_swapped := TRUE;
        RETURN;
      IFEND;
    IFEND;

    IF all_swapped OR syv$system_was_idle THEN
      RETURN;
    IFEND;

    IF oijlp.block_p <> NIL THEN
      IF oijlp.block_p^ [ijl_ordinal.block_number].index_p <> NIL THEN
        oijlxp := #ADDRESS (1, rmfwsn, #OFFSET (oijlp.block_p^ [ijl_ordinal.block_number].index_p));
        IF oijlxp^ [ijl_ordinal.block_index].entry_status > jmc$ies_entry_free THEN
          IF oijlxp^ [ijl_ordinal.block_index].swap_status < jmc$iss_swapout_complete THEN
            swapped_out := FALSE;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND syp$get_job_swap_status;

?? TITLE := 'PROCEDURE syp$recover_executing_ajl_ord', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$recover_executing_ajl_ord;


    VAR
      image_descriptor: dst$nve_image_descriptor,
      rmfwsn: ost$segment, {recoverd mainframe wired segment number}
      system_core_id: ^ost$name,
      ajl_ord_base: ^integer;

    dsp$get_nve_image_description (image_descriptor);
    IF (image_descriptor.rcv_mainframe_wired_segment <> NIL) THEN
      rmfwsn := #segment (image_descriptor.rcv_mainframe_wired_segment);
      IF (image_descriptor.rcv_page_size = osv$page_size) THEN

        { Image file required from this point on !!!!!

        system_core_id := #address (1, rmfwsn, #offset (^jmv$system_core_id));
        IF (system_core_id^ = jmv$system_core_id) THEN
          ajl_ord_base := #address (1, rmfwsn, #offset (^mtv$processor_mode[0]));
          mtv$executing_ajl_at_failure [0] := ajl_ord_base^;
          ajl_ord_base := #address (1, rmfwsn, #offset (^mtv$processor_mode[1]));
          mtv$executing_ajl_at_failure [1] := ajl_ord_base^;

        IFEND;
      IFEND;
    IFEND;

  PROCEND syp$recover_executing_ajl_ord;

MODEND sym$job_recovery_r1;
*DECK DECK=SYM$JOB_RECOVERY_R3 EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE: job recovery r3' ??
MODULE sym$job_recovery_r3;
?? PUSH (LISTEXT := ON) ??
*copyc cml$job_recovery_failure
*copyc cml$job_recovery_totals
*copyc fme$file_management_errors
*copyc iit$connection_description
*copyc jmc$maximum_job_count
*copyc jmc$special_dispatch_priorities
*copyc jmc$system_family
*copyc jml$user_id
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc jmt$job_class
*copyc jmt$job_count_range
*copyc jmt$job_scheduler_event
*copyc jmt$job_system_id
*copyc jmt$swap_file_recovery_list
*copyc jmt$system_supplied_name
*copyc osc$timesharing
*copyc ose$job_recovery_exceptions
*copyc oss$task_private
*copyc oss$task_shared
*copyc ost$caller_identifier
*copyc ost$system_flag
*copyc pfe$internal_error_conditions
*copyc pmt$program_parameters
*copyc sye$job_recovery_conditions
*copyc syt$job_recovery_step
*copyc tmt$change_priority_origin
?? POP ??
?? NEWTITLE := '  Global Declarations Referenced by This Module', EJECT ??
*copyc amp$return
*copyc clp$get_value
*copyc clp$scan_command_line
*copyc clp$scan_parameter_list
*copyc cmp$recover_subsystem_io_table
*copyc dfp$recover_jobs_servers
*copyc dmp$fetch_eoi
*copyc dsp$log_job_recovery_statistics
*copyc gfp$get_segment_sfid
*copyc fmp$ln_open_chapter
*copyc fmp$recover_job_files
*copyc iip$terminate_disconnected_job
*copyc jmp$change_dispatching_prior_r1
*copyc jmp$emit_job_history_statistics
*copyc jmp$get_ijle_p
*copyc jmp$handle_ts_system_disconnect
*copyc jmp$job_monitor_xcb
*copyc jmp$rebuild_executing_job
*copyc jmp$record_job_attributes
*copyc jmp$system_job
*copyc mmp$close_segment
*copyc mmp$create_scratch_segment
*copyc mmp$delete_scratch_segment
*copyc mmp$free_pages
*copyc mmp$get_max_sdt_sdtx_pointer
*copyc mmp$get_sdtx_entry_p
*copyc mmp$set_access_selections
*copyc nlp$recover_task_activity
*copyc ofp$display_status_message
*copyc osp$generate_log_message
*copyc osp$get_status_condition_name
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$log_unformatted_status
*copyc osp$set_status_abnormal
*copyc osp$set_status_from_condition
*copyc osp$system_error
*copyc osp$verify_system_privilege
*copyc pfp$get_multi_item_info
*copyc pfp$find_next_info_record
*copyc pfp$find_directory_array
*copyc pfp$restricted_attach
*copyc pfp$overhaul_catalog
*copyc pfp$purge
*copyc pmp$cause_task_condition
*copyc pmp$continue_to_cause
*copyc pmp$delay
*copyc pmp$exit
*copyc pmp$find_executing_task_xcb
*copyc pmp$get_job_mode
*copyc pmp$get_unique_name
*copyc pmp$log_ascii
*copyc pmp$wait
*copyc pmp$zero_out_table
*copyc qfp$expand_kjl
*copyc qfp$relink_kjl_application
*copyc qfp$relink_kjl_client
*copyc qfp$relink_kjl_entry
*copyc qfp$relink_kjl_server
*copyc rfp$recover_task_activity
*copyc sfp$emit_statistic
*copyc syp$increment_avt_r1
*copyc syp$increment_file_rcv_failure
*copyc syp$job_recovery_from_image
*copyc syp$log_recovery_failure
*copyc syp$process_job_rcv_failure
*copyc syp$recover_job_r1
*copyc jmv$executing_within_system_job
*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc jmv$job_attributes
*copyc jmv$job_class_table_p
*copyc jmv$job_history_active
*copyc jmv$job_recovery_information_p
*copyc jmv$kjl_p
*copyc jmv$service_classes
*copyc osv$mainframe_wired_heap
*copyc osv$page_size
*copyc osv$task_shared_heap
*copyc osv$task_private_heap
*copyc qfv$current_kjl_limit
*copyc rfv$job_entry_pointer
*copyc syv$failure_reason_p
*copyc syv$file_rcv_failure_count
*copyc syv$job_recovery_option
*copyc syv$job_recovery_step
*copyc syv$recovering_job_count
*copyc syv$recovery_failure_count
*copyc syv$test_jr_job
?? TITLE := '  Global Declarations Referenced ONLY by This Module', EJECT ??

{ The following xrefs are ONLY used in sym$job_recovery_r3, hence, no XREF decks.

  TYPE
    zzzz = (job, system);

  PROCEDURE [XREF] syp$set_job_recovery_test
    (    t: zzzz;
         option: 0 .. 255);

  PROCEDURE [XREF] syp$clear_job_recovery_test
    (    t: zzzz;
         option: 0 .. 255);

  PROCEDURE [XREF] syp$jt_recovery_complete
    (VAR status: ost$status);

  PROCEDURE [XREF] syp$complete_job_recovery;

  PROCEDURE [XREF] syp$terminate_unrecovered_job
    (    ijl_ordinal: jmt$ijl_ordinal);

  PROCEDURE [XREF] syp$check_maxaj_and_ready_sched;

  PROCEDURE [XREF] iip$disconnect_job
    (    end_job_connection: boolean;
         start_new_job: boolean;
     VAR status: ost$status);

  PROCEDURE [XREF] syp$recover_volume_file_space;

  PROCEDURE [XREF] syp$begin_job_recovery
    (    buffer_limit: 0 .. jmc$maximum_job_count);

  PROCEDURE [XREF] syp$end_job_recovery;

  PROCEDURE [XREF] syp$decrement_job_task_count;

  PROCEDURE [XREF] syp$init_job_rec_from_image
    (VAR status: ost$status);

  PROCEDURE [XREF] mlp$recover_job_environment
    (VAR status: ost$status);

  VAR
    syv$job_task_count: [XREF] integer,
    syv$job_recovery_wait_time: [XREF] integer;


  VAR
    job_recovery_inhibited: [STATIC, oss$task_shared] boolean := FALSE,
    jobs_recovering_count: [STATIC, oss$task_shared] integer := 0,
    osv$inhibit_job_recovery_count: [XDCL, oss$task_private] integer := 0,
    osv$job_recovery_required: [XDCL, #GATE, oss$task_private] boolean := FALSE,
    recovery_termination: [STATIC, oss$task_shared] boolean := FALSE,
    recovered_job_count: [STATIC, oss$task_shared] 0 .. jmc$max_ijl_entries,
    recovered_jobs: [STATIC, oss$task_shared] ^jmt$swap_file_recovery_list := NIL;


?? TITLE := '  PROCEDURE osp$complete_job_recovery', EJECT ??

{ PURPOSE:
{   This procedure is called AFTER pf recovery to complete job recovery functions as follows:
{     - start volume space recovery task

  PROCEDURE [XDCL] osp$complete_job_recovery
    (VAR status: ost$status);

    PROCEDURE ch
      (    condition: pmt$condition;
           cd: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR ignore: ost$status);

      osp$set_status_from_condition ('OS', condition, sa, status, ignore);
      IF NOT ignore.normal THEN
        status := ignore;
      IFEND;
      EXIT osp$complete_job_recovery;

    PROCEND ch;

    IF NOT jmp$system_job () THEN
      osp$system_error (' malicious user access', NIL);
      RETURN;
    IFEND;

    osp$establish_condition_handler (^ch, FALSE);

    clp$scan_command_line ('EXET SP=OSP$RECOVER_VOLUME_FILE_SPACE LMO=NONE DM=' CAT 'OFF TEL=WARNING TN=RVFS',
          status);
    IF NOT status.normal THEN
      display_status (status);
    IFEND;

    status.normal := TRUE;

  PROCEND osp$complete_job_recovery;
?? TITLE := '  PROCEDURE jmp$find_jsn', EJECT ??

  PROCEDURE jmp$find_jsn
    (    jsn: jmt$system_supplied_name;
     VAR ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      ijl_bn: jmt$ijl_block_number,
      ijl_bi: jmt$ijl_block_index,
      ijl_p: ^jmt$initiated_job_list_entry;

    ijle_p := NIL;

  /scan_ijl_for_jsn/

    FOR ijl_bn := LOWERBOUND (jmv$ijl_p.block_p^) TO jmv$ijl_p.max_block_in_use DO
      IF (jmv$ijl_p.block_p^ [ijl_bn].index_p <> NIL) THEN
        FOR ijl_bi := LOWERVALUE (jmt$ijl_block_index) TO UPPERVALUE (jmt$ijl_block_index) DO
          ijl_p := ^jmv$ijl_p.block_p^ [ijl_bn].index_p^ [ijl_bi];
          IF ijl_p^.system_supplied_name = jsn THEN
            ijle_p := ijl_p;
            RETURN;
          IFEND;
        FOREND;

      IFEND;
    FOREND /scan_ijl_for_jsn/;
  PROCEND jmp$find_jsn;
?? TITLE := '  PROCEDURE osp$recover_volume_file_space', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$recover_volume_file_space
    (    p: pmt$program_parameters;
     VAR status: ost$status);

    VAR
      ijlep: ^jmt$initiated_job_list_entry,
      str: string (255),
      i,
      strl: integer;

    IF NOT jmp$system_job () THEN
      osp$system_error (' malicious user access', NIL);
      RETURN;
    IFEND;

    display (' Recover volume file space task started');
    syp$recover_volume_file_space;

{ Recovering jobs have completed recovery, detach swap files from the
{ system job.  Note special case for jobs that did not recover.  THIS IS
{IMPORTANT.

    display ('Detaching recovered jobs from system job');

  /detf/
    FOR i := 1 TO recovered_job_count DO
      IF recovered_jobs^ [i].recovery_disposition_available AND
            (recovered_jobs^ [i].job_recovery_disposition = jmc$continue_on_recovery) THEN
        jmp$find_jsn (recovered_jobs^ [i].system_job_name, ijlep);
        IF ijlep <> NIL THEN
          IF ijlep^.job_damaged_during_recovery THEN
            STRINGREP (str, strl, 'Recovered job damaged during recovery: ',
                  recovered_jobs^ [i].system_job_name);
            display (str (1, strl));
            CYCLE /detf/;
          IFEND;
        IFEND;
        STRINGREP (str, strl, 'Recovered job detached: ', recovered_jobs^ [i].system_job_name);
        display (str (1, strl));
        amp$return (recovered_jobs^ [i].local_file_name, status);
        IF NOT status.normal THEN
          display_status (status);
        IFEND;
      IFEND;
    FOREND /detf/;

    IF recovered_job_count <> 0 THEN
      dsp$log_job_recovery_statistics (recovered_job_count, jobs_recovering_count, status);
    IFEND;

    syp$complete_job_recovery;

    IF recovered_jobs <> NIL THEN
      FREE recovered_jobs IN osv$task_shared_heap^;
    IFEND;

  PROCEND osp$recover_volume_file_space;
?? TITLE := '  PROCEDURE osp$recover_executing_jobs', EJECT ??

  PROCEDURE [XDCL] osp$recover_executing_jobs
    (VAR swap_file_recovery_list: ^jmt$swap_file_recovery_list;
     VAR swap_file_recovery_list_count: jmt$job_count_range;
     VAR status: ost$status);

{ This procedure is called BEFORE all of: system commit, pf recovery and start
{   job sched task.
{ It must NOT write into any permanent file catalogs, as the changes are not
{   recoverable.
{ Notes:
{ 1) Swap files are left attached.  This is done so that the sfid will be valid
{   for all
{    swapins done after recovery, but before the job is able to recover the
{    swap file.

    PROCEDURE ch
      (    condition: pmt$condition;
           cd: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR ignore: ost$status);

      osp$set_status_from_condition ('OS', condition, sa, status, ignore);
      IF NOT ignore.normal THEN
        status := ignore;
      IFEND;
      EXIT osp$recover_executing_jobs;
    PROCEND ch;
?? EJECT ??

    VAR
      directory_array_p: pft$p_directory_array,
      group: pft$group,
      ignore_status: ost$status,
      info_record_p: pft$p_info_record,
      init_status: ost$status,
      jsn_index: integer,
      log_msg: string (80),
      msg_len: integer,
      path: array [1 .. 4] of pft$name,
      segment_pointer: amt$segment_pointer,
      sequence_p: ^SEQ ( * ),
      vp: array [1 .. 3] of pft$name;


    IF NOT jmp$system_job () THEN
      osp$system_error (' malicious user access', NIL);
      RETURN;
    IFEND;

    swap_file_recovery_list := NIL;
    swap_file_recovery_list_count := 0;
    init_status.normal := TRUE;

    vp [1] := jmc$system_family;
    vp [2] := jmc$system_user;
    osp$establish_condition_handler (^ch, FALSE);

    CASE syv$job_recovery_option OF
    = syc$jre_enabled =
      syp$init_job_rec_from_image (init_status);
      IF NOT init_status.normal THEN
        display_status (init_status);
        display ('Job recovery disabled by the system');
        log_msg := 'Job recovery disabled by the system.';
        msg_len := 36;
      ELSE
        display ('Job recovery enabled');
      IFEND;

      vp [3] := jmc$job_swap_catalog;
      pfp$overhaul_catalog (vp, $pft$catalog_overhaul_choices [pfc$validate_files], status);
      IF NOT status.normal THEN
        display_status (status);
        RETURN;
      IFEND;
    = syc$jre_command_disabled =
      display ('Job recovery disabled by set_system_attribute command.');
      log_msg := 'Job recovery disabled by set_system_attribute command.';
      msg_len := 54;
    = syc$jre_prior_ds_disabled =
      display ('Job recovery disabled by prior deadstart.');
      log_msg := 'Job recovery disabled by prior deadstart.';
      msg_len := 41;
    = syc$jre_no_image =
      display ('Job recovery disabled because memory image is not available.');
      log_msg := 'Job recovery disabled because memory image is not available.';
      msg_len := 60;
    = syc$jre_different_system =
      display ('Job recovery disabled because a different system is being deadstarted.');
      log_msg := 'Job recovery disabled because a different system is being deadstarted.';
      msg_len := 70;
    = syc$jre_page_size_mismatch =
      display ('Job recovery disabled because a different page size is being used.');
      log_msg := 'Job recovery disabled because a different page size is being used.';
      msg_len := 66;
    ELSE
      display ('Unexpected job recovery option value');
      STRINGREP (log_msg, msg_len, 'Unexpected job recovery option value of ', syv$job_recovery_option);
    CASEND;

    mmp$create_scratch_segment (amc$sequence_pointer, mmc$as_sequential, segment_pointer, status);
    IF NOT status.normal THEN
      display_status (status);
      RETURN;
    IFEND;
    sequence_p := segment_pointer.sequence_pointer;

    group.group_type := pfc$public;
    vp [3] := jmc$job_swap_catalog;
    RESET sequence_p;

    pfp$get_multi_item_info (vp, group, $pft$catalog_info_selections [],
          $pft$file_info_selections [pfc$file_description], sequence_p, status);
    IF NOT status.normal THEN
      display_status (status);
      mmp$delete_scratch_segment (segment_pointer, ignore_status);
      RETURN;
    IFEND;

    RESET sequence_p;
    pfp$find_next_info_record (sequence_p, info_record_p, status);
    IF NOT status.normal THEN
      display_status (status);
      mmp$delete_scratch_segment (segment_pointer, ignore_status);
      RETURN;
    IFEND;

    pfp$find_directory_array (info_record_p, directory_array_p, status);
    IF NOT status.normal THEN
      display_status (status);
      mmp$delete_scratch_segment (segment_pointer, ignore_status);
      RETURN;
    IFEND;

    path [1] := jmc$system_family;
    path [2] := jmc$system_user;

    IF directory_array_p <> NIL THEN
      syp$begin_job_recovery (UPPERBOUND (directory_array_p^));
    ELSE
      syp$begin_job_recovery (0);
    IFEND;

    recovered_job_count := 0;
    IF directory_array_p <> NIL THEN
      IF syv$job_recovery_option <> syc$jre_enabled THEN
        IF NOT init_status.normal THEN
          syp$log_recovery_failure (' SYP$INIT_JOB_REC_FROM_IMAGE failed', init_status);
        IFEND;
        status.normal := TRUE;
        syp$log_recovery_failure (log_msg (1, msg_len), status);
      IFEND;

      ALLOCATE recovered_jobs: [1 .. UPPERBOUND (directory_array_p^)] IN osv$task_shared_heap^;
      path [3] := jmc$job_swap_catalog;
      FOR jsn_index := LOWERBOUND (directory_array_p^) TO UPPERBOUND (directory_array_p^) DO
        path [4] := directory_array_p^ [jsn_index].name;
        process_swap_file (path);
      FOREND;
    IFEND;
    mmp$delete_scratch_segment (segment_pointer, ignore_status);

    syp$end_job_recovery;
    status.normal := TRUE;

    IF recovered_job_count > 0 THEN
      swap_file_recovery_list := recovered_jobs;
    ELSE
      swap_file_recovery_list := NIL;
    IFEND;
    swap_file_recovery_list_count := recovered_job_count;
    jobs_recovering_count := syv$recovering_job_count;

  PROCEND osp$recover_executing_jobs;
?? TITLE := '  PROCEDURE process_swap_file', EJECT ??

  PROCEDURE process_swap_file
    (    path: array [1 .. 4] of pft$name);

{
{  This procedure is called by osp$recover_executing_jobs to process the
{  swap file of the recovering job.
{

    PROCEDURE ch
      (    condition: pmt$condition;
           cd: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR ignore: ost$status);

      osp$set_status_from_condition ('OS', condition, sa, status, ignore);
      IF NOT ignore.normal THEN
        status := ignore;
      IFEND;
      amp$return (uname, ignore);
      display_and_log_status (status, sn);
      EXIT process_swap_file;
    PROCEND ch;
?? EJECT ??

    VAR
      caller_id: ost$caller_identifier,
      cycle_number: pft$cycle_number,
      jcb_found: boolean,
      jcb_search: ^jmt$job_control_block,
      job_recovered: boolean,
      job_recovery_disposition: jmt$job_recovery_disposition,
      oijlep: ^jmt$initiated_job_list_entry,
      pf_cycle: [READ {,oss$job_paged_literal} ] pft$cycle_selector := [pfc$highest_cycle],
      pjcb: ^jmt$job_control_block,
      recovery_disposition_available: boolean,
      sfid: gft$system_file_identifier,
      share: [READ {,oss$job_paged_literal} ] pft$usage_selections := $pft$usage_selections
            [pfc$read, pfc$append, pfc$shorten, pfc$modify],
      sn: jmt$system_supplied_name,
      status: ost$status,
      swap_file_eoi: amt$file_byte_address,
      swap_file_offset: integer,
      swap_file_sfid: gft$system_file_identifier,
      swap_ptr: mmt$segment_pointer,
      uname: ost$name,
      usage: [READ {,oss$job_paged_literal} ] pft$usage_selections := $pft$usage_selections
            [pfc$read, pfc$append, pfc$shorten, pfc$modify];


    pmp$get_unique_name (uname, status);

    job_recovered := FALSE;
    recovery_disposition_available := FALSE;
    job_recovery_disposition := jmc$terminate_on_recovery;
    sn := path [4];
    #SPOIL (sn);
    osp$establish_condition_handler (^ch, FALSE);

  /file_attached/
    BEGIN
      IF syv$job_recovery_option <> syc$jre_enabled THEN

{ skip recovery

        IF jmv$job_history_active THEN
          jmp$emit_job_history_statistics (jml$non_recovery_of_job, osc$null_name, sn,
                jmc$blank_system_supplied_name, NIL, NIL, 'sye$job_recovery_disabled      ',
                jmc$blank_system_supplied_name, status);
        IFEND;
        EXIT /file_attached/;
      IFEND;
      pfp$restricted_attach (uname, path, pf_cycle, osc$null_name, usage, share, cycle_number, status);
      IF NOT status.normal THEN
        display_and_log_status (status, sn);
        syp$log_recovery_failure (' Attach of swap file failed', status);
        EXIT /file_attached/;
      IFEND;
      #CALLER_ID (caller_id);
      fmp$ln_open_chapter (uname, 0, caller_id.ring, NIL, mmc$cell_pointer, swap_ptr, status);
      IF NOT status.normal THEN
        display_and_log_status (status, sn);
        syp$log_recovery_failure (' Open of swap file failed', status);
        EXIT /file_attached/;
      IFEND;

    /file_open/
      BEGIN
        mmp$set_access_selections (swap_ptr.cell_pointer, mmc$as_sequential, status);
        IF NOT status.normal THEN
          display_and_log_status (status, sn);
        IFEND;
        syp$job_recovery_from_image (swap_ptr.cell_pointer, sn, oijlep, recovery_disposition_available,
              job_recovery_disposition, status);
        IF NOT status.normal THEN
          display_and_log_status (status, sn);
          syp$log_recovery_failure (' Job recovery from image failed', status);
          EXIT /file_open/;
        IFEND;
        mmp$set_access_selections (swap_ptr.cell_pointer, mmc$as_random, status);
        IF NOT status.normal THEN
          display_and_log_status (status, sn);
        IFEND;
        pjcb := swap_ptr.cell_pointer;
        jcb_found := FALSE;
        swap_file_offset := 0;
        gfp$get_segment_sfid (swap_ptr.cell_pointer, swap_file_sfid, status);
        dmp$fetch_eoi (swap_file_sfid, swap_file_eoi, status);
        WHILE NOT jcb_found DO
          jcb_search := #ADDRESS (1, #SEGMENT (swap_ptr.cell_pointer), swap_file_offset);
          IF jcb_search^.jcb_identifier = 0FF00(16) THEN
            pjcb := jcb_search;
            jcb_found := TRUE;
          ELSE
            swap_file_offset := swap_file_offset + osv$page_size;
            IF swap_file_offset > swap_file_eoi THEN
              osp$set_status_abnormal ('SY', sye$unable_to_locate_jcb, '', status);
              display_and_log_status (status, sn);
              syp$log_recovery_failure (' Unable to locate jcb', status);
              EXIT /file_open/;
            IFEND;
          IFEND;
        WHILEND;

{ Validate the job's Job Control Block (JCB) as best as possible

        IF (pjcb^.system_name <> sn) OR (pjcb^.job_id = jmc$kjl_undefined_index) OR
              (pjcb^.job_id > UPPERBOUND (jmv$kjl_p^)) THEN
          osp$set_status_abnormal ('SY', sye$job_damaged, '', status);
          display_and_log_status (status, sn);
          syp$log_recovery_failure (' JCB is damaged', status);
          EXIT /file_open/;
        IFEND;

        WHILE pjcb^.job_id > qfv$current_kjl_limit DO
          qfp$expand_kjl;
        WHILEND;

{ Verify that the job's entry is available in the KJL.

        IF jmv$kjl_p^ [pjcb^.job_id].entry_kind <> jmc$kjl_unused_entry THEN
          osp$set_status_abnormal ('SY', sye$job_damaged, '', status);
          display_and_log_status (status, sn);
          syp$log_recovery_failure (' Job not in KJL', status);
          EXIT /file_open/;
        IFEND;

        syp$recover_job_r1 (swap_ptr.cell_pointer, pjcb, oijlep, recovery_disposition_available,
              job_recovery_disposition, status);
        IF NOT status.normal THEN
          display_and_log_status (status, sn);
          syp$log_recovery_failure (' Syp$recover_job_r1 failed', status);
          EXIT /file_open/;
        IFEND;

        jmp$rebuild_executing_job (sn, pjcb);
        job_recovered := TRUE;
      END /file_open/;
      gfp$get_segment_sfid (swap_ptr.cell_pointer, sfid, status);
      mmp$free_pages (swap_ptr.cell_pointer, 7fffffff(16), osc$wait, status);
      mmp$close_segment (swap_ptr, {validation_ring =} 3, status);
    END /file_attached/;
    recovered_job_count := recovered_job_count + 1;
    recovered_jobs^ [recovered_job_count].system_job_name := path [4];
    recovered_jobs^ [recovered_job_count].recovery_disposition_available := recovery_disposition_available;
    recovered_jobs^ [recovered_job_count].job_recovery_disposition := job_recovery_disposition;
    recovered_jobs^ [recovered_job_count].command_file_exists := FALSE;
    IF job_recovered THEN

{ The recovery disposition MUST be available and the job MUST have continued - if not, something is messy.

      IF NOT ((recovery_disposition_available) AND (job_recovery_disposition = jmc$continue_on_recovery)) THEN
        recovered_jobs^ [recovered_job_count].recovery_disposition_available := TRUE;
        recovered_jobs^ [recovered_job_count].job_recovery_disposition := jmc$continue_on_recovery;
      IFEND;

      recovered_jobs^ [recovered_job_count].local_file_name := uname;
      syp$increment_avt_r1 (sfid, status);
    ELSE
      amp$return (uname, status);

{ The swap file will be purged during queue recovery.

    IFEND;
  PROCEND process_swap_file;

?? TITLE := '  PROCEDURE display_and_log_status', EJECT ??

{ PURPOSE:
{    If an abnormal status arises during job recovery, calling this procedure
{    will display the status to the system and job logs and, if job history
{    is active, it will emit a statistic to the history log.

  PROCEDURE display_and_log_status
    (    status_to_log: ost$status;
         system_job_name: jmt$system_supplied_name);

    VAR
      ignore_status: ost$status,
      reason: ost$name,
      str: string (255),
      str_len: integer;

    osp$generate_log_message ($pmt$ascii_logset [pmc$system_log, pmc$job_log], status_to_log, ignore_status);

    STRINGREP (str, str_len, ' Job not recovered: ', system_job_name);
    pmp$log_ascii (str (1, str_len), $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system,
          ignore_status);

    IF jmv$job_history_active THEN
      reason := '';
      osp$get_status_condition_name (status_to_log.condition, reason, ignore_status);
      jmp$emit_job_history_statistics (jml$non_recovery_of_job, osc$null_name, system_job_name,
            jmc$blank_system_supplied_name, NIL, NIL, reason, jmc$blank_system_supplied_name, ignore_status);
    IFEND;
  PROCEND display_and_log_status;
*copyc osp$generate_message
*copyc clp$put_job_output

  PROCEDURE display_status
    (    status: ost$status);

    VAR
      ost: ost$status,
      status_p: ^ost$status;

    IF (status.condition = ose$job_severely_damaged) OR (status.condition = ose$path_table_locked) THEN
      status_p := ^status;
      osp$log_unformatted_status (status_p, $pmt$ascii_logset [pmc$system_log, pmc$job_log],
            pmc$msg_origin_system, { critical_message } FALSE);
    ELSE
      osp$generate_log_message ($pmt$ascii_logset [pmc$system_log, pmc$job_log], status, ost);
    IFEND;

  PROCEND display_status;

  PROCEDURE display
    (    t: string ( * ));

    VAR
      ost: ost$status;

    pmp$log_ascii (t, $pmt$ascii_logset [pmc$system_log, pmc$job_log], pmc$msg_origin_system, ost);
  PROCEND display;

?? TITLE := '  PROCEDURE osp$recovery_swap_io_error', EJECT ??

  PROCEDURE [XDCL] osp$recovery_swap_io_error;

{ This procedure is called to find and terminate any job that could not swap in
{ to run recovery because of an io error.

    VAR
      bi: integer,
      bn: integer,
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      service_class: jmt$service_class_index,
      status: ost$status;

    IF NOT jmp$system_job () THEN
      osp$system_error (' malicious user access', NIL);
      RETURN;
    IFEND;

  /search_for_job/
    FOR bn := LOWERBOUND (jmv$ijl_p.block_p^) TO jmv$ijl_p.max_block_in_use DO
      IF jmv$ijl_p.block_p^ [bn].index_p <> NIL THEN

      /search_ijl_block/
        FOR bi := LOWERVALUE (jmt$ijl_block_index) TO UPPERVALUE (jmt$ijl_block_index) DO
          IF jmv$ijl_p.block_p^ [bn].index_p^ [bi].entry_status <> jmc$ies_entry_free THEN
            IF jmc$dsw_recovery_swap_io_error IN jmv$ijl_p.block_p^ [bn].index_p^ [bi].
                  delayed_swapin_work THEN
              ijl_ordinal.block_number := bn;
              ijl_ordinal.block_index := bi;

{ Purge its swap and command files and terminate the job.

              jmp$get_ijle_p (ijl_ordinal, ijle_p);
              purge_unrecovered_job (ijle_p^.system_supplied_name, status);
              osp$set_status_abnormal ('SY', sye$recovery_swap_io_error, ijle_p^.system_supplied_name,
                    status);
              display_status (status);
              syp$terminate_unrecovered_job (ijl_ordinal);
              IF jmv$ijl_p.block_p^ [bn].index_p = NIL THEN
                EXIT /search_ijl_block/;
              IFEND;
            IFEND;
          IFEND;
        FOREND /search_ijl_block/;

      IFEND;
    FOREND /search_for_job/;

  PROCEND osp$recovery_swap_io_error;

?? TITLE := '  PROCEDURE osp$scan_ijl_for_recovered_jobs' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] osp$scan_ijl_for_recovered_jobs;

{ This procedure is called to allow recoverable jobs to swap in or to get rid
{ of any jobs for which the job or service class of the job is not defined; it is
{ called after 'startup commands' have been executed so that site-defined classes
{ are initialized before any jobs are allowed to execute.

    VAR
      bi: integer,
      bn: integer,
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      job_class: jmt$job_class,
      service_class: jmt$service_class_index,
      status: ost$status;

    IF NOT jmp$system_job () THEN
      osp$system_error (' malicious user access', NIL);
      RETURN;
    IFEND;

  /search_for_job/
    FOR bn := LOWERBOUND (jmv$ijl_p.block_p^) TO jmv$ijl_p.max_block_in_use DO
      IF jmv$ijl_p.block_p^ [bn].index_p <> NIL THEN
        FOR bi := LOWERVALUE (jmt$ijl_block_index) TO UPPERVALUE (jmt$ijl_block_index) DO
          IF jmv$ijl_p.block_p^ [bn].index_p^ [bi].entry_status <> jmc$ies_entry_free THEN
            IF jmc$dsw_job_recovery IN jmv$ijl_p.block_p^ [bn].index_p^ [bi].delayed_swapin_work THEN
              ijl_ordinal.block_number := bn;
              ijl_ordinal.block_index := bi;
              job_class := jmv$ijl_p.block_p^ [bn].index_p^ [bi].job_scheduler_data.job_class;
              service_class := jmv$ijl_p.block_p^ [bn].index_p^ [bi].job_scheduler_data.service_class;
              IF (NOT jmv$job_class_table_p^ [job_class].defined) OR
                    (jmv$service_classes [service_class] = NIL) OR
                    (NOT jmv$service_classes [service_class]^.attributes.defined) THEN

{ The job or service class this job belongs to is no longer defined.
{ Purge its swap and command files and terminate it.

                jmp$get_ijle_p (ijl_ordinal, ijle_p);
                purge_unrecovered_job (ijle_p^.system_supplied_name, status);
                osp$set_status_abnormal ('SY', sye$recovery_class_not_defined, ijle_p^.system_supplied_name,
                      status);
                display_status (status);
                syp$terminate_unrecovered_job (ijl_ordinal);
              IFEND;
            IFEND;
          IFEND;
        FOREND;

      IFEND;
    FOREND /search_for_job/;

{ Make sure that the MAXIMUM ACTIVE JOBS entry in the service class table for all classes with jobs to be
{ recovered is greater than 0.  Also set the scheduler event to check if there are jobs to be swapped in.

    syp$check_maxaj_and_ready_sched;

  PROCEND osp$scan_ijl_for_recovered_jobs;
?? TITLE := '  PROCEDURE purge_unrecovered_job', EJECT ??

  PROCEDURE [XDCL, #GATE] purge_unrecovered_job
    (    system_job_name: jmt$system_supplied_name;
     VAR status: ost$status);

    PROCEDURE condh
      (    condition: pmt$condition;
           cd: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR ignore: ost$status);

      osp$set_status_from_condition ('OS', condition, sa, status, ignore);
      IF NOT ignore.normal THEN
        status := ignore;
      IFEND;
      EXIT purge_unrecovered_job;
    PROCEND condh;

    VAR
      path: array [1 .. 4] of pft$name,
stop: cell,
kill: ^cell,
      cel: integer,
      ce: string (255),
      pf_cycle: [READ {,oss$job_paged_literal} ] pft$cycle_selector := [pfc$highest_cycle];

    status.normal := TRUE;
stop := kill^;
    IF NOT jmp$system_job () THEN
      osp$system_error (' malicious user access', NIL);
      RETURN;
    IFEND;

    osp$establish_condition_handler (^condh, FALSE);

    path [1] := jmc$system_family;
    path [2] := jmc$system_user;
    path [4] := system_job_name;
    path [3] := jmc$job_swap_catalog;
    pfp$purge (path, pf_cycle, osc$null_name, status);
    IF NOT status.normal THEN
      display_status (status);
    IFEND;
    path [3] := jmc$job_input_catalog;
    pfp$purge (path, pf_cycle, osc$null_name, status);
    IF NOT status.normal THEN
      display_status (status);
    IFEND;

    status.normal := TRUE;

  PROCEND purge_unrecovered_job;
?? TITLE := '  PROCEDURE syp$job_recovery_flag_handler', EJECT ??

  PROCEDURE [XDCL] syp$job_recovery_flag_handler
    (    flagid: ost$system_flag);

{ This procedure is called as the first thing during job recovery - after
{system core recovery
{ (e.g. the first thing in the job template).  It is called in all tasks of a
{job being recovered.

    VAR
      xcb: ^ost$execution_control_block,
      ignore,
      status: ost$status;


    PROCEDURE avoid
      (    condition: pmt$condition;
           cd: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        ignore: ost$status;

{ the purpose of this handler is to detect lost job recovery conditions

      status.normal := TRUE;

      IF NOT osv$job_recovery_required THEN
        pmp$continue_to_cause (pmc$execute_standard_procedure, ignore);
        RETURN;
      IFEND;

      IF recovery_termination THEN
        pmp$continue_to_cause (pmc$execute_standard_procedure, ignore);
        RETURN;
      IFEND;
      IF condition.selector = pmc$user_defined_condition THEN
        pmp$continue_to_cause (pmc$execute_standard_procedure, ignore);
        RETURN;
      ELSEIF condition.selector = jmc$job_resource_condition THEN
        pmp$continue_to_cause (pmc$execute_standard_procedure, ignore);
        RETURN;
      ELSEIF condition.selector = ifc$interactive_condition THEN
        pmp$continue_to_cause (pmc$execute_standard_procedure, ignore);
        RETURN;
      ELSEIF condition.selector = pmc$pit_condition THEN
        pmp$continue_to_cause (pmc$execute_standard_procedure, ignore);
        RETURN;
      IFEND;

      osp$set_status_from_condition ('OS', condition, sa, status, ignore);
      display_status (status);
      ofp$display_status_message ('Job recovery failed - job idled', ignore);
      syp$process_job_rcv_failure ('Job recovery condition in syp$job_recovery_flag_handler', status);
    PROCEND avoid;

    IF (syv$job_recovery_step <> syc$jrs_jt_step) AND (syv$job_recovery_step <> syc$jrs_test_jt_step) THEN
      osp$system_error ('illegal job recovery call', NIL);
    IFEND;
    osv$job_recovery_required := TRUE;
    pmp$find_executing_task_xcb (xcb);
    IF xcb = jmp$job_monitor_xcb () THEN
      osp$establish_condition_handler (^avoid, TRUE);

{I dont want to do this, but I will.  Execute job recovery immediately in
{any ring.  This must be changed when we allow recovery of file activity.

      osp$recover_job;

      pmp$cause_task_condition ('OSC$JOB_RECOVERY               ', NIL, FALSE, FALSE, FALSE, TRUE, status);
      IF osv$job_recovery_required THEN

{Some procedure did not do a continue to cause -
{We do not dare to continue this job

        ofp$display_status_message ('Job recovery failed - job idled', ignore);
        syp$process_job_rcv_failure ('Job recovery was ignored', status);
      IFEND;
      osp$disestablish_cond_handler;
    ELSE { tasks other than jmtr }
      osp$establish_condition_handler (^avoid, TRUE);

{I dont want to do this, but I will.  Execute job recovery immediately in
{any ring.  This must be changed when we allow recovery of file activity.

      osp$recover_job;

      pmp$cause_task_condition ('OSC$JOB_RECOVERY               ', NIL, FALSE, FALSE, FALSE, TRUE, status);
      IF osv$job_recovery_required THEN

{Some procedure did not do a continue to cause -
{We do not dare to continue this job

        ofp$display_status_message ('Job recovery failed - job idled', ignore);
        syp$process_job_rcv_failure ('Job recovery was ignored', status);
      IFEND;
      osp$disestablish_cond_handler;
    IFEND;
  PROCEND syp$job_recovery_flag_handler;
?? TITLE := '  PROCEDURE osp$recover_job', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$recover_job;

{ This procedure is called by the condition mechanism whenever the job recovery
{ condition is continued across the ring 2 boundary.

    PROCEDURE ch
      (    condition: pmt$condition;
           cd: ^pmt$condition_information;
           sa: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      VAR
        ignore: ost$status;

{ the purpose of this handler is to support recursive job recovery
{ conditions.

      status.normal := TRUE;
      IF NOT osv$job_recovery_required THEN
        pmp$continue_to_cause (pmc$execute_standard_procedure, ignore);
        RETURN;
      IFEND;
      IF recovery_termination THEN
        pmp$continue_to_cause (pmc$execute_standard_procedure, ignore);
        RETURN;
      IFEND;
      IF condition.selector = pmc$user_defined_condition THEN
        IF condition.user_condition_name = 'OSC$JOB_RECOVERY' THEN
          pmp$log_ascii (' Job recovery re-entered', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
                pmc$msg_origin_system, status);
          pmp$continue_to_cause (pmc$execute_standard_procedure, ignore);
          recursive_recovery := TRUE;
          EXIT osp$recover_job;
        ELSE
          pmp$continue_to_cause (pmc$execute_standard_procedure, ignore);
          RETURN;
        IFEND;
      ELSEIF condition.selector = pmc$block_exit_processing THEN
        IF recursive_recovery OR recovery_termination THEN

{ assume this was caused by the EXIT above, or by pmp$exit.

          RETURN;
        IFEND;
      ELSEIF condition.selector = jmc$job_resource_condition THEN
        pmp$continue_to_cause (pmc$execute_standard_procedure, ignore);
        RETURN;
      ELSEIF condition.selector = ifc$interactive_condition THEN
        pmp$continue_to_cause (pmc$execute_standard_procedure, ignore);
        RETURN;
      ELSEIF condition.selector = pmc$pit_condition THEN
        pmp$continue_to_cause (pmc$execute_standard_procedure, ignore);
        RETURN;
      IFEND;

      osp$set_status_from_condition ('OS', condition, sa, status, ignore);
      display_status (status);
      ofp$display_status_message ('Job recovery failed - job idled', ignore);
      syp$process_job_rcv_failure ('Job recovery condition in osp$recover_job', status);
    PROCEND ch;
?? EJECT ??

    VAR
      dummy_sdt: mmt$max_sdt_p,
      i: integer,
      ignore: ost$status,
      j: integer,
      job_mode: jmt$job_mode,
      null_dispatching_info: jmt$dispatching_control_info,
      old_jrs: syt$job_recovery_step,
      pi: ^integer,
      recursive_recovery: boolean,
      sdtx_p: mmt$max_sdtx_p,
      sdtxe_p: ^mmt$segment_descriptor_extended,
      status: ost$status,
      xcb: ^ost$execution_control_block;

    osp$verify_system_privilege;

    IF (syv$job_recovery_step <> syc$jrs_jt_step) AND (syv$job_recovery_step <> syc$jrs_test_jt_step) THEN
      osp$system_error ('illegal job recovery call', NIL);
    IFEND;
    recursive_recovery := FALSE;
    pmp$find_executing_task_xcb (xcb);
    osp$establish_condition_handler (^ch, TRUE);
    IF xcb = jmp$job_monitor_xcb () THEN
      IF osv$inhibit_job_recovery_count > 0 THEN
        job_recovery_inhibited := TRUE;
      IFEND;

{     Clear RHFAM job table entry pointer to prevent an RHFAM job from
{     attempting to access unrecovered tables in network paged.

      rfv$job_entry_pointer := NIL;

      WHILE syv$job_task_count <> 1 DO

{ jmtr - wait for all other tasks to synch

        pmp$delay (syv$job_recovery_wait_time, ignore);
      WHILEND;
      ofp$display_status_message ('Job recovery in progress', ignore);


{ put job template recovery stuff here

      jmp$record_job_attributes (^jmv$job_attributes, jmv$job_recovery_information_p, status);
      IF NOT status.normal THEN
        pmp$log_ascii (' Job template recovery failed', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, status);
        syp$process_job_rcv_failure (' jmp$record_job_attributes failed', status);
      IFEND;

      IF syc$tjr_recursive_recovery IN syv$test_jr_job THEN
        syp$clear_job_recovery_test (job, syc$tjr_recursive_recovery);
        WHILE TRUE DO
          pmp$wait (1000, 1000);
        WHILEND;
      IFEND;
      IF syc$tjr_fail_prior_jfr IN syv$test_jr_job THEN
        pi := NIL;
        pi^ := 0;
      IFEND;

      cmp$recover_subsystem_io_table (status);
      IF NOT status.normal THEN
        pmp$log_ascii (' Job template recovery failed', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, status);
        syp$process_job_rcv_failure (' cmp$recover_subsystem_io_table failed', status);
      IFEND;

      dfp$recover_jobs_servers (status);
      IF NOT status.normal THEN
        pmp$log_ascii (' Job recovery failed (job servers)', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, status);
        syp$process_job_rcv_failure (' dfp$recover_jobs_servers failed', status);
      IFEND;

      fmp$recover_job_files (status);
      IF status.normal AND job_recovery_inhibited THEN
        osp$set_status_abnormal ('SY', sye$task_inhibited_recovery, '', status);
        pmp$log_ascii (' Job recovery inhibited', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, ignore);
      IFEND;
      IF NOT status.normal THEN
        pmp$log_ascii (' Job recovery failed (job files)', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
              pmc$msg_origin_system, ignore);
        IF syc$tjr_touch_unrec_segment IN syv$test_jr_job THEN
          mmp$get_max_sdt_sdtx_pointer (xcb, dummy_sdt, sdtx_p);
          FOR i := 0 TO xcb^.xp.segment_table_length DO
            sdtxe_p := ^sdtx_p^.sdtx_table [i];
            IF sdtxe_p^.sfid.residence = gfc$tr_system_wait_recovery THEN
              pi := #ADDRESS (3, i, 0);
              j := pi^;
            IFEND;
          FOREND;
        IFEND;
        IF (status.condition = pfe$not_all_pfs_recovered) OR (status.condition = fme$not_all_pfs_recovered) OR
              (status.condition = fme$tape_files_not_recovered) OR
              (status.condition = fme$not_all_files_recovered) OR
              (status.condition = fme$tape_resource_not_recovered) OR
              (status.condition = sye$task_inhibited_recovery) THEN
          pmp$log_ascii (' Recovering job being terminated (job files)', $pmt$ascii_logset
                [pmc$system_log, pmc$job_log], pmc$msg_origin_system, ignore);
          display_status (status);
          ofp$display_status_message ('Job recovery failed - job being terminated', ignore);

          nlp$recover_task_activity (ignore);
          IF NOT ignore.normal THEN
            job_recovery_inhibited := TRUE;
          IFEND;

          pmp$get_job_mode (job_mode, ignore);
          CASE job_mode OF
          = jmc$interactive_connected =
            IF jmv$job_attributes.originating_application_name = osc$timesharing THEN
              jmp$handle_ts_system_disconnect (ignore);
            ELSE
              iip$disconnect_job (iic$dont_end_connection, iic$dont_start_new_job, ignore);
              iip$terminate_disconnected_job;
            IFEND;
          = jmc$interactive_cmnd_disconnect, jmc$interactive_line_disconnect, jmc$interactive_sys_disconnect =
            IF jmv$job_attributes.originating_application_name <> osc$timesharing THEN
              iip$terminate_disconnected_job;
            IFEND;
          ELSE
          CASEND;

          syp$increment_file_rcv_failure;
          syp$log_recovery_failure (' Files not recovered - job terminated', status);

{ terminate the job - this is tricky
{ Will not return if syp$jt_recovery_complete fails.

          syp$jt_recovery_complete (ignore);

          recovery_termination := TRUE;
          pmp$exit (status);
        ELSE
          pmp$log_ascii (' Job termination not possible', $pmt$ascii_logset [pmc$system_log, pmc$job_log],
                pmc$msg_origin_system, ignore);
          display_status (status);
          ofp$display_status_message ('Job recovery failed - job idled', ignore);
          syp$process_job_rcv_failure ('fmp$recover_job_files failed', status);
        IFEND;
      IFEND;
      IF syc$tjr_fail_post_jfr IN syv$test_jr_job THEN
        pi := NIL;
        pi^ := 0;
      IFEND;

      IF syv$job_recovery_step <> syc$jrs_test_jt_step THEN
        mlp$recover_job_environment (status);
        IF NOT status.normal THEN
          pmp$log_ascii (' Job recovery failed (job environment)', $pmt$ascii_logset
                [pmc$system_log, pmc$job_log], pmc$msg_origin_system, ignore);
          display_status (status);
          IF status.condition = ose$mem_link_not_available THEN
            job_recovery_inhibited := TRUE;
          ELSE
            ofp$display_status_message ('Job recovery failed - job idled', ignore);
            syp$process_job_rcv_failure ('mli recovery failed', status);
          IFEND;
        IFEND;

        nlp$recover_task_activity (ignore);
        IF NOT ignore.normal THEN
          job_recovery_inhibited := TRUE;
        IFEND;

        pmp$get_job_mode (job_mode, status);
        CASE job_mode OF
        = jmc$interactive_cmnd_disconnect, jmc$interactive_line_disconnect, jmc$interactive_sys_disconnect,
              jmc$interactive_connected =
          IF jmv$job_attributes.originating_application_name = osc$timesharing THEN
            jmp$handle_ts_system_disconnect (status);
          ELSE
            iip$disconnect_job (iic$dont_end_connection, iic$dont_start_new_job, status);
          IFEND;
        ELSE
        CASEND;

      IFEND;

{ Will not return if syp$jt_recovery_complete fails.

      syp$jt_recovery_complete (status);

      IF job_recovery_inhibited THEN
        IF (NOT status.normal) AND (status.condition <> ose$mem_link_not_available) THEN
          osp$set_status_abnormal ('SY', sye$task_inhibited_recovery, '', status);
        IFEND;
        recovery_termination := TRUE;
        pmp$exit (status);
      IFEND;

      ofp$display_status_message ('Job recovery complete', ignore);

{ Reset dispatching priority

      null_dispatching_info.dispatching_priority := jmc$null_dispatching_priority;
      jmp$change_dispatching_prior_r1 (tmc$cpo_recovery, jmv$jcb.ijl_ordinal, jmv$jcb.system_name,
            null_dispatching_info, status);

{ wait for all jobs to complete recovery

      osv$job_recovery_required := FALSE;
      WHILE syv$recovering_job_count <> 0 DO
        pmp$wait (30000, 30000);
      WHILEND;
    ELSE
      old_jrs := syv$job_recovery_step;
      IF osv$inhibit_job_recovery_count > 0 THEN
        job_recovery_inhibited := TRUE;
      IFEND;
      syp$decrement_job_task_count;
      WHILE syv$job_recovery_step <> syc$jrs_recovery_complete DO

{ non jmtr tasks - wait for jmtr to complete job recovery

        pmp$delay (syv$job_recovery_wait_time, ignore);
      WHILEND;
      IF old_jrs <> syc$jrs_test_jt_step THEN
        mlp$recover_job_environment (status);
        IF NOT status.normal THEN
          IF status.condition = ose$mem_link_not_available THEN
            job_recovery_inhibited := TRUE;
          ELSE
            osp$system_error (' job recovery mli rec', ^status);
          IFEND;
        IFEND;
      IFEND;

      IF NOT job_recovery_inhibited THEN
        nlp$recover_task_activity (ignore);
        IF NOT ignore.normal THEN
          job_recovery_inhibited := TRUE;
        IFEND;
      IFEND;
      rfp$recover_task_activity (ignore);

      IF job_recovery_inhibited THEN
        IF (NOT status.normal) AND (status.condition <> ose$mem_link_not_available) THEN
          osp$set_status_abnormal ('SY', sye$task_inhibited_recovery, '', status);
        IFEND;
        recovery_termination := TRUE;
        pmp$exit (status);
      IFEND;

      osv$job_recovery_required := FALSE;
      WHILE syv$recovering_job_count <> 0 DO
        pmp$wait (30000, 30000);
      WHILEND;
    IFEND;
    osp$disestablish_cond_handler;
  PROCEND osp$recover_job;
?? TITLE := '  PROCEDURE osp$set_job_recovery_test', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$set_job_recovery_test
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{  PDT setjrt_pdt (environment,e: key job, system, clear_job, clear_system =
{job
{      option: integer 0 .. 255 = $required)

?? PUSH (LISTEXT := ON) ??

    VAR
      setjrt_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
            [^setjrt_pdt_names, ^setjrt_pdt_params];

    VAR
      setjrt_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
            clt$parameter_name_descriptor := [['ENVIRONMENT', 1], ['E', 1], ['OPTION', 2]];

    VAR
      setjrt_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ ENVIRONMENT E

      [[clc$optional_with_default, ^setjrt_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed,
            [^setjrt_pdt_kv1, clc$keyword_value]],

{ OPTION

      [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 255]]];

    VAR
      setjrt_pdt_kv1: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 4] of ost$name := ['JOB',
            'SYSTEM', 'CLEAR_JOB', 'CLEAR_SYSTEM'];

    VAR
      setjrt_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (3) := 'job';

?? POP ??

    VAR
      clear: boolean,
      t: (job, system),
      value: clt$value;

    clp$scan_parameter_list (parameter_list, setjrt_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('ENVIRONMENT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    IF value.name.value = 'JOB' THEN
      t := job;
      clear := FALSE;
    ELSEIF value.name.value = 'CLEAR_JOB' THEN
      t := job;
      clear := TRUE;
    ELSEIF value.name.value = 'CLEAR_SYSTEM' THEN
      t := system;
      clear := TRUE;
    ELSE
      t := system;
      clear := FALSE;
    IFEND;

    clp$get_value ('OPTION', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF clear THEN
      syp$clear_job_recovery_test (t, value.int.value);
    ELSE
      syp$set_job_recovery_test (t, value.int.value);
    IFEND;

  PROCEND osp$set_job_recovery_test;
?? OLDTITLE, OLDTITLE ??
MODEND sym$job_recovery_r3;

*DECK DECK=SYM$JOB_RECOVERY_TEST EXPAND=TRUE
MODULE sym$job_recovery_test;
?? PUSH (LISTEXT := ON) ??
*copyc osd$default_pragmats
*copyc amp$open
*copyc amp$get_segment_pointer
*copyc pmt$program_parameters
*copyc osp$set_status_abnormal
?? POP ??

  PROCEDURE job_recovery_test (p: pmt$program_parameters;
    VAR status: ost$status);

    CONST
      page_size = 4096 DIV 8,
      page_count = 50;

    VAR
      lffid,
      pffid: amt$file_identifier,
      as: array [1 .. 1] of amt$access_selection,
      segp: amt$segment_pointer,
      lfp,
      pfp: ^ARRAY [0 .. 100000000] of integer,
      pc,
      bc,
      ml,
      pass,
      errl,
      cval: integer,
      err: string (100),
      msg: string (50);

    as [1].key := amc$access_mode;
    as [1].access_mode := $pft$usage_selections [pfc$read, pfc$modify, pfc$shorten, pfc$append];
    amp$open ('lf                             ', amc$segment, ^as, lffid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    amp$get_segment_pointer (lffid, amc$cell_pointer, segp, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    lfp := segp.cell_pointer;

    amp$open ('pf                             ', amc$segment, ^as, pffid, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    amp$get_segment_pointer (pffid, amc$cell_pointer, segp, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    pfp := segp.cell_pointer;

    pass := 0;
    cval := 1;
    WHILE TRUE DO
      cval := cval + 1;
      pass := pass + 1;

      FOR pc := 0 TO page_count - 1 DO
        FOR bc := 0 TO page_size - 1 DO
          lfp^ [(pc * page_size) + bc] := cval;
          pfp^ [(pc * page_size) + bc] := cval;
        FOREND;
      FOREND;

      FOR pc := 0 TO page_count - 1 DO
        FOR bc := 0 TO page_size - 1 DO
          IF lfp^ [(pc * page_size) + bc] <> cval THEN
            stringrep(err,errl,' local file test failure ',pc,bc,cval,pass);
            osp$set_status_abnormal ('SY', 9908, err(1,errl),
                  status);
            RETURN;
          IFEND;
          IF pfp^ [(pc * page_size) + bc] <> cval THEN
            stringrep(err,errl,' perm file test failure ',pc,bc,cval,pass);
            osp$set_status_abnormal ('SY', 9909, err(1,errl),
                  status);
            RETURN;
          IFEND;
        FOREND;
      FOREND;

    WHILEND;
  PROCEND job_recovery_test;
MODEND
*DECK DECK=SYM$JOB_TEMPLATE_MANAGEMENT EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'NOS/VE: job template management' ??
MODULE sym$job_template_management;

{ PURPOSE
{  This module supports the management of multiple job templates in the system
{  core environment.

?? NEWTITLE := '  Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc dmt$system_file_id
*copyc mmt$segment_descriptor_table
*copyc oss$job_fixed
*copyc ost$heap
*copyc ost$name
*copyc ost$segment_descriptor
*copyc ost$segment_set
*copyc pmt$virtual_memory_image_header
*copyc sye$job_template_conditions
?? POP ??
*copyc dmp$create_file_entry
*copyc dmp$destroy_file
*copyc gfp$get_locked_fde_p
*copyc gfp$unlock_fde_p
*copyc i#move
*copyc jmp$determine_job_class
*copyc jmp$get_ijle_p
*copyc mmp$close_device_file
*copyc mmp$get_sdtx_entry_p
*copyc mmp$open_file_by_sfid
*copyc osp$append_status_parameter
*copyc osp$clear_mainframe_sig_lock
*copyc osp$fatal_system_error
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc pmp$find_executing_task_xcb
*copyc syp$establish_condition_handler

*copyc jmv$ijl_p
*copyc jmv$jcb
*copyc jmv$job_class_table_p
*copyc jmv$job_counts
*copyc jmv$job_trap_handler
*copyc jmv$system_core_id
*copyc jmv$system_core_template
*copyc mmv$default_sdtx_entry
*copyc mmv$max_template_segment_number
*copyc osv$cpus_physically_configured
*copyc osv$mainframe_pageable_heap
*copyc syv$job_template_cbp
*copyc syv$job_template_ptr_array
*copyc tmv$job_debug_ring
?? TITLE := '  Global Declarations Declared by This Module', EJECT ??

  TYPE
    template_definition = record
      template_name: ost$name,
      code_base_pointer: ost$external_code_base_pointer,
      job_class_names: ^array [1 .. * ] of ost$name,
      segments: ^array [1 .. * ] of template_segment_definition,
    recend,

    template_segment_definition = record
      segment_number: ost$segment,
      segment_descriptor: ost$segment_descriptor,
      case segment_kind: (shared, job_unique, task_unique, skip) of
      = shared =
        sfid: dmt$system_file_id,
      = job_unique, task_unique =
        location: ^array [1 .. * ] of cell,
        length: integer,
      casend,
    recend;

  VAR
    syv$job_template_lock: ost$signature_lock := [0],
    syv$highest_in_use: integer := 0,
    syv$nosve_job_template: [XDCL, #GATE, oss$job_fixed] boolean := TRUE,
    syv$job_template_name: [XDCL, #GATE, oss$job_fixed] ost$name :=
          '                               ',
    syv$job_templates: [XDCL] array [1 .. 10] of
          template_definition := [REP 10 of [osc$null_name, * , NIL, NIL]];


?? TITLE := '  PROCEDURE syp$activate_job_template' ??
?? EJECT ??

{  The purpose of this procedure is to create the mainframe scope data
{ structures that represent a job template.  Template data is copied
{ either to mainframe pageable (non-shared data) or to a DM temp global
{ file (shared code/data).  Validation is performed to insure that only
{ one template exists for any given job class.

  PROCEDURE [XDCL, #GATE] syp$activate_job_template
    (    template_file: ^SEQ ( * );
         template_name: ost$name;
         job_unique_segments,
         task_unique_segments: ost$segment_set;
         classes: ^array [1 .. * ] of ost$name;
     VAR status: ost$status);

    PROCEDURE activate_template_ch
      (    mf: ost$monitor_fault;
           msa_p: ^ost$minimum_save_area;
       VAR continue: syt$continue_option);

      osp$set_status_abnormal (syc$system_core_id, sye$template_condition, '', status);
      osp$clear_mainframe_sig_lock (syv$job_template_lock);
      EXIT syp$activate_job_template;

    PROCEND activate_template_ch;

    VAR
      class_membership: integer,
      class_name_index: integer,
      data: ^array [1 .. * ] of cell,
      fde_p: gft$file_desc_entry_p,
      file_attributes: array [1 .. 1] of dmt$new_file_attribute,
      gfn: dmt$global_file_name,
      local_status: ost$status,
      p_file_data: ^cell,
      sdtxe_p: ^mmt$segment_descriptor_extended,
      segment_header: ^pmt$linked_segment_description,
      segment_index: integer,
      segment_number: ost$segment,
      template: ^SEQ ( * ),
      template_header: ^pmt$virtual_memory_image_header,
      template_index: integer,
      xcb: ^ost$execution_control_block;

    osp$set_mainframe_sig_lock (syv$job_template_lock);
    syp$establish_condition_handler (^activate_template_ch);
    FOR template_index := LOWERBOUND (syv$job_templates)
          TO UPPERBOUND (syv$job_templates) DO
      IF syv$job_templates [template_index].template_name <> osc$null_name THEN
        IF syv$job_templates [template_index].template_name =
              template_name THEN
          osp$set_status_abnormal (syc$system_core_id,
                sye$duplicate_template_name, template_name, status);
          osp$clear_mainframe_sig_lock (syv$job_template_lock);
          RETURN;
        IFEND;
        FOR class_membership := LOWERBOUND (syv$job_templates [template_index].
              job_class_names^) TO UPPERBOUND (syv$job_templates
              [template_index].job_class_names^) DO
          FOR class_name_index := 1 TO UPPERBOUND (classes^) DO
            IF syv$job_templates [template_index].
                  job_class_names^ [class_membership] =
                  classes^ [class_name_index] THEN
              osp$set_status_abnormal (syc$system_core_id,
                    sye$duplicate_class_definition, syv$job_templates [template_index].template_name,
                    status);
              osp$append_status_parameter (osc$status_parameter_delimiter,
                    classes^ [class_name_index], status);
              osp$clear_mainframe_sig_lock (syv$job_template_lock);
              RETURN;
            IFEND;
          FOREND;
        FOREND;
      IFEND;
    FOREND;

  /find_free_entry/
    BEGIN
      FOR template_index := LOWERBOUND (syv$job_templates)
            TO UPPERBOUND (syv$job_templates) DO
        IF syv$job_templates [template_index].template_name =
              osc$null_name THEN
          EXIT /find_free_entry/;
        IFEND;
      FOREND;
      osp$set_status_abnormal (syc$system_core_id, sye$job_template_table_full,
            '', status);
      osp$clear_mainframe_sig_lock (syv$job_template_lock);
      RETURN;
    END /find_free_entry/;
    IF template_index > syv$highest_in_use THEN
      syv$highest_in_use := template_index;
    IFEND;

    template := template_file;

    NEXT template_header IN template;

    IF template_header^.system_core_id <> jmv$system_core_id THEN
      osp$set_status_abnormal (syc$system_core_id, sye$template_core_mismatch,
            '', status);
      osp$clear_mainframe_sig_lock (syv$job_template_lock);
      RETURN;
    IFEND;

    syv$job_templates [template_index].code_base_pointer :=
          template_header^.starting_procedure;

    ALLOCATE syv$job_templates [template_index].job_class_names:
          [1 .. UPPERBOUND (classes^)] IN osv$mainframe_pageable_heap^;

    FOR class_membership := 1 TO UPPERBOUND (classes^) DO
      syv$job_templates [template_index].job_class_names^ [class_membership] :=
            classes^ [class_membership];
    FOREND;

    ALLOCATE syv$job_templates [template_index].segments:
          [1 .. template_header^.number_of_segments] IN
          osv$mainframe_pageable_heap^;
    FOR segment_index := 1 TO template_header^.number_of_segments DO
      syv$job_templates [template_index].segments^ [segment_index].
            segment_kind := skip;
    FOREND;

    FOR segment_index := 1 TO template_header^.number_of_segments DO
      NEXT segment_header IN template;

      syv$job_templates [template_index].segments^ [segment_index].
            segment_number := segment_header^.segment_number;
      IF segment_header^.segment_number > mmv$max_template_segment_number THEN
        mmv$max_template_segment_number := segment_header^.segment_number;
      IFEND;
      syv$job_templates [template_index].segments^ [segment_index].
            segment_descriptor := segment_header^.segment_descriptor;

      IF (syv$job_templates [template_index].segments^ [segment_index].
            segment_number IN job_unique_segments) OR
            (syv$job_templates [template_index].segments^ [segment_index].
            segment_number IN task_unique_segments) THEN
        IF syv$job_templates [template_index].segments^ [segment_index].
              segment_number IN task_unique_segments THEN
          syv$job_templates [template_index].segments^ [segment_index].
                segment_kind := task_unique;
        ELSEIF syv$job_templates [template_index].segments^ [segment_index].
              segment_number IN job_unique_segments THEN
          syv$job_templates [template_index].segments^ [segment_index].
                segment_kind := job_unique;
        IFEND;
        ALLOCATE syv$job_templates [template_index].segments^ [segment_index].
              location: [1 .. segment_header^.length] IN
              osv$mainframe_pageable_heap^;
        syv$job_templates [template_index].segments^ [segment_index].length :=
              segment_header^.length;
        NEXT data: [1 .. segment_header^.length] IN template;
        i#move (data, syv$job_templates [template_index].
              segments^ [segment_index].location, segment_header^.length);
      ELSE
        syv$job_templates [template_index].segments^ [segment_index].
              segment_kind := shared;
        IF (osv$cpus_physically_configured > 1) AND
              (syv$job_templates [template_index].segments^ [segment_index].segment_descriptor.wp <>
              osc$non_writable) THEN
          syv$job_templates [template_index].segments^ [segment_index].segment_descriptor.vl :=
                osc$vl_cache_bypass;
        IFEND;
{
{   The use of file_attributes is in support of Dynamic File Space Limits
{
        file_attributes [1].keyword := dmc$owner;
        file_attributes [1].file_space_limit := sfc$no_limit;

        dmp$create_file_entry (gfc$fk_global_unnamed, -$pft$usage_selections [],
              -$pft$share_selections [], dmc$minimum_file_share_his, ^file_attributes,
              segment_header^.length, TRUE, gfn,
              syv$job_templates [template_index].segments^ [segment_index].
              sfid, status);
        IF NOT status.normal THEN
          syp$deactivate_job_template (template_name, local_status);
          osp$clear_mainframe_sig_lock (syv$job_template_lock);
          RETURN;
        IFEND;
        {Open as PF
        mmp$open_file_by_sfid (syv$job_templates [template_index].
              segments^ [segment_index].sfid, 1, 1, mmc$as_sequential,
              mmc$sar_write_extend, segment_number, status);
        IF NOT status.normal THEN
          syp$deactivate_job_template (template_name, local_status);
          osp$clear_mainframe_sig_lock (syv$job_template_lock);
          RETURN;
        IFEND;
        p_file_data := #ADDRESS (1, segment_number, 0);
        NEXT data: [1 .. segment_header^.length] IN template;
        i#move (data, p_file_data, segment_header^.length);
        {Update segment kind!!
        pmp$find_executing_task_xcb (xcb);
        sdtxe_p := mmp$get_sdtx_entry_p (xcb, segment_number);
        gfp$get_locked_fde_p (sdtxe_p^.sfid, fde_p);
        fde_p^.flags.global_template_file := TRUE;
        gfp$unlock_fde_p (fde_p);

        {No hole here - just does a purge map
        mmp$close_device_file (segment_number, status);
      IFEND;

    FOREND;

    {Update name last while still locked to prevent use until installed
    syv$job_templates [template_index].template_name := template_name;

    osp$clear_mainframe_sig_lock (syv$job_template_lock);

  PROCEND syp$activate_job_template;
?? TITLE := '  PROCEDURE syp$create_job_template' ??
?? EJECT ??

{  The purpose of this procedure is to initialize the "job monitor" task
{ of a job template "job" that is being initiated.  This routine is called
{ only by the job scheduler.  It assumes that the job fixed segment is
{ initialized with the NOS/VE system core environment.  It must add
{ segments to this environment as defined by the job template.  All
{ segments being added must have the proper MM attributes to insure
{ the correct segments are shared between tasks.

  PROCEDURE [XDCL] syp$create_job_template
    (    ijlo: jmt$ijl_ordinal;
         job_class: jmt$job_class;
         sdt_p: mmt$max_sdt_p;
         sdtx_p: mmt$max_sdtx_p;
     VAR template_created: boolean);

    VAR
      segment_index,
      template_index: integer,
      job_class_name: ost$name,
      p_boolean: ^boolean,
      p_cbp: ^ost$external_code_base_pointer,
      local_status: ost$status,
      segment: ost$segment;

    template_created := FALSE;

    job_class_name := jmv$job_class_table_p^ [job_class].name;

    find_job_class (job_class_name, template_index, local_status);
    IF NOT local_status.normal THEN
      RETURN;
    IFEND;

    FOR segment_index := LOWERBOUND (syv$job_templates [template_index].
          segments^) TO UPPERBOUND (syv$job_templates [template_index].
          segments^) DO
      segment := syv$job_templates [template_index].segments^ [segment_index].
            segment_number;
      IF sdt_p^.st [segment].ste.vl <> osc$vl_invalid_entry THEN
        RETURN;
      IFEND;

      sdt_p^.st [segment].ste := syv$job_templates [template_index].
            segments^ [segment_index].segment_descriptor;
      sdt_p^.st [segment].ste.asid := 0;
      sdtx_p^.sdtx_table [segment] := mmv$default_sdtx_entry;
      CASE syv$job_templates [template_index].segments^ [segment_index].
            segment_kind OF
      = shared =
        sdtx_p^.sdtx_table [segment].inheritance := mmc$si_share_segment;
        sdtx_p^.sdtx_table [segment].access_state := mmc$sas_allow_access;
        sdtx_p^.sdtx_table [segment].sfid := syv$job_templates [template_index].
              segments^ [segment_index].sfid;
        sdtx_p^.sdtx_table [segment].open_validating_ring_number := 0;
      = task_unique =
        sdtx_p^.sdtx_table [segment].inheritance := mmc$si_new_segment;
        sdtx_p^.sdtx_table [segment].open_validating_ring_number := 1;
      = job_unique =
        sdtx_p^.sdtx_table [segment].inheritance := mmc$si_share_segment;
        sdtx_p^.sdtx_table [segment].open_validating_ring_number := 1;
      ELSE
        RETURN;
      CASEND;
    FOREND;

    p_boolean := #ADDRESS (1, #SEGMENT (sdt_p),
          #OFFSET (^syv$nosve_job_template));
    p_boolean^ := FALSE;

    p_cbp := #ADDRESS (1, #SEGMENT (sdt_p), #OFFSET (^syv$job_template_cbp));
    p_cbp^ := syv$job_templates [template_index].code_base_pointer;

    template_created := TRUE;

  PROCEND syp$create_job_template;
?? TITLE := '  PROCEDURE syp$initialize_syscore_template' ??
?? EJECT ??

{  The purpose of this procedure is to update the [static] definition
{ of the NOS/VE system core template.  It is called from
{ osm$job_template_initialization.

  PROCEDURE [XDCL, #GATE] syp$initialize_syscore_template;

    VAR
      p_boolean: ^boolean,
      p_cbp: ^ost$external_code_base_pointer,
      p_job_template_ptr_array: ^^array [1 .. * ] of ^cell,
      segment: ost$segment,
      offset: ost$segment_offset;

    segment := #SEGMENT (jmv$system_core_template.job_fixed_template_p);
    offset := #OFFSET (jmv$system_core_template.job_fixed_template_p);

    p_cbp := #ADDRESS (1, segment, offset + #OFFSET (^syv$job_template_cbp));
    p_cbp^ := syv$job_template_cbp;
    p_job_template_ptr_array := #ADDRESS (1, segment, offset +
          #OFFSET (^syv$job_template_ptr_array));
    p_job_template_ptr_array^ := syv$job_template_ptr_array;

  PROCEND syp$initialize_syscore_template;
?? TITLE := '  PROCEDURE syp$initialize_job_template' ??
?? EJECT ??

{  The purpose of this procedure is to complete the initialization of a
{ "job template" job.  It is called by the job template early during it's
{ initialization.  This procedure will copy the non-shared template data
{ segments
{ from the template description to actual task/job segments.  This operation
{ must
{ be performed from within each job/task so that the file system (MM/DM) will
{ operate correctly.  Job unique segments are only copied on the first call to
{ this procedure.  Task unique segments are copied on every call.  The job
{ template
{ must provide a ^procedure which is used by the system core trap mechanism
{ to communicate preemptively with the job template.

  PROCEDURE [XDCL, #GATE] syp$initialize_job_template
    (    update_trap_handler: boolean;
         trap_handler: ^procedure);

    VAR
      segment_index,
      template_index: integer,
      segment: ost$segment,
      job_template_initialized: [STATIC, oss$job_fixed] boolean := FALSE,
      status: ost$status,
      job_class_name: ost$name;

    job_class_name := jmv$job_class_table_p^
          [jmv$jcb.ijle_p^.job_scheduler_data.job_class].name;

    find_job_class (job_class_name, template_index, status);
    IF NOT status.normal THEN
      osp$fatal_system_error ('Initialize job template', ^status);
    IFEND;

    FOR segment_index := LOWERBOUND (syv$job_templates [template_index].
          segments^) TO UPPERBOUND (syv$job_templates [template_index].
          segments^) DO
      segment := syv$job_templates [template_index].segments^ [segment_index].
            segment_number;

      CASE syv$job_templates [template_index].segments^ [segment_index].
            segment_kind OF
      = shared =
        ;
      = task_unique =
        i#move (syv$job_templates [template_index].segments^ [segment_index].
              location, #ADDRESS (1, segment, 0),
              syv$job_templates [template_index].segments^ [segment_index].
              length);
      = job_unique =
        IF NOT job_template_initialized THEN
          i#move (syv$job_templates [template_index].segments^ [segment_index].
                location, #ADDRESS (1, segment, 0),
                syv$job_templates [template_index].segments^ [segment_index].
                length);
          syv$job_template_name := syv$job_templates [template_index].template_name;
        IFEND;
      ELSE
        osp$fatal_system_error ('Job template confusion', NIL);
      CASEND
    FOREND;

    IF update_trap_handler THEN
      jmv$job_trap_handler := trap_handler;
    IFEND;

    job_template_initialized := TRUE;

  PROCEND syp$initialize_job_template;

?? TITLE := '  PROCEDURE find_job_class' ??
?? EJECT ??

  PROCEDURE [INLINE] find_job_class
    (    name: ost$name;
     VAR template_index: integer;
     VAR status: ost$status);

    VAR
      class_membership: integer;

    FOR template_index := LOWERBOUND (syv$job_templates)
          TO syv$highest_in_use DO
      IF syv$job_templates [template_index].template_name <> osc$null_name THEN
        FOR class_membership := LOWERBOUND (syv$job_templates [template_index].
              job_class_names^) TO UPPERBOUND (syv$job_templates
              [template_index].job_class_names^) DO
          IF syv$job_templates [template_index].
                job_class_names^ [class_membership] = name THEN
            status.normal := TRUE;
            RETURN;
          IFEND;
        FOREND;
      IFEND;
    FOREND;

    {Cannot find template
    osp$set_status_abnormal (syc$system_core_id, sye$template_not_found, name,
          status);

  PROCEND find_job_class;
?? TITLE := '  PROCEDURE find_template' ??
?? EJECT ??

  PROCEDURE [INLINE] find_template
    (    name: ost$name;
     VAR template_index: integer;
     VAR status: ost$status);

    VAR
      class_membership: integer;

    FOR template_index := LOWERBOUND (syv$job_templates)
          TO syv$highest_in_use DO
      IF syv$job_templates [template_index].template_name = name THEN
        status.normal := TRUE;
        RETURN;
      IFEND;
    FOREND;

    {Cannot find template
    osp$set_status_abnormal (syc$system_core_id, sye$template_not_found, name,
          status);

  PROCEND find_template;
?? TITLE := '  PROCEDURE syp$deactivate_job_template' ??
?? EJECT ??

{  The purpose of this procedure is to cancel the effect of an
{ activate_job_template command. Mainframe pageable data is FREE'd
{ and DM files are destroyed.  The request is allowed only if
{ all job classes using the template have no queued or initiated
{ jobs and their job class limit is zero.

  PROCEDURE [XDCL, #GATE] syp$deactivate_job_template
    (    template_name: ost$name;
     VAR status: ost$status);

    VAR
      class_membership: integer,
      job_class: jmt$job_class,
      segment_index: integer,
      template_index: integer;


    osp$set_mainframe_sig_lock (syv$job_template_lock);
    find_template (template_name, template_index, status);
    IF NOT status.normal THEN
      osp$clear_mainframe_sig_lock (syv$job_template_lock);
      RETURN;
    IFEND;

  /verify_classes/
    FOR class_membership := 1 TO UPPERBOUND (syv$job_templates
          [template_index].job_class_names^) DO
      jmp$determine_job_class (syv$job_templates [template_index].
            job_class_names^ [class_membership], job_class, status);
      IF NOT status.normal THEN
        CYCLE /verify_classes/;
      IFEND;
      IF (jmv$job_counts.job_class_counts [job_class].initiated_jobs <> 0) OR
            (jmv$job_counts.job_class_counts [job_class].queued_jobs <> 0) THEN
        osp$clear_mainframe_sig_lock (syv$job_template_lock);
        osp$set_status_abnormal (syc$system_core_id, sye$jobs_still_active, '',
              status);
        RETURN;
      IFEND;
    FOREND /verify_classes/;

    syv$job_templates [template_index].template_name := osc$null_name;

    FREE syv$job_templates [template_index].job_class_names IN
          osv$mainframe_pageable_heap^;

    FOR segment_index := 1 TO UPPERBOUND (syv$job_templates [template_index].
          segments^) DO

      CASE syv$job_templates [template_index].segments^ [segment_index].
            segment_kind OF
      = task_unique, job_unique =
        FREE syv$job_templates [template_index].segments^ [segment_index].
              location IN osv$mainframe_pageable_heap^;
      = shared =
        dmp$destroy_file (syv$job_templates [template_index]. segments^ [segment_index].sfid, sfc$no_limit,
              status);
      = skip =
        {Skip
      ELSE
        osp$fatal_system_error ('Job template confusion', NIL);
      CASEND;
    FOREND;

    FREE syv$job_templates [template_index].segments IN
          osv$mainframe_pageable_heap^;

    status.normal := TRUE;

    osp$clear_mainframe_sig_lock (syv$job_template_lock);

  PROCEND syp$deactivate_job_template;

?? TITLE := '  PROCEDURE syp$set_job_debug_ring' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] syp$set_job_debug_ring (job_debug_ring: ost$ring);

    tmv$job_debug_ring := job_debug_ring;

  PROCEND syp$set_job_debug_ring;
?? OLDTITLE, OLDTITLE ??
MODEND sym$job_template_management;
*DECK DECK=SYM$MEMORY_LINK_DATA_CONVERSION EXPAND=TRUE
sym$memory_link_data_conversion  ident
*copy ASMREGS
*copy osa$cybil_interface
         PAGE
................................................................................
.
.        Conversion services.
.
................................................................................
.
.
.        register usage in syaconv.
.
a_tbl    AREG      5                   .pointer to conversion table
a_buf    AREG      6                   .pointer to C170 data buffer
a_vefile AREG      7                   .pointer to nos/ve file
a_line   AREG      8                   .pointer to BAM record
a_save   AREG      9                   .pointer to data save area
amacsr   AREG      0f(16)              .scratch A register
amacscr  AREG      0f(16)              .scratch A register
.
x_ch     XREG      3                   .current character/escape flag
x_li     XREG      5                   .index into current BAM line
x_bi     XREG      6                   .index into C170 buffer
x_fp     XREG      7                   .position within C180 file
x_mask   XREG      8                   .c170 character mask
x_ml     XREG      9                   .C170 character mask limit
x_bl     XREG      0a(16)              .C170 buffer length
x_rl     XREG      0b(16)              .BAM record length
x_us     XREG      0b(16)              .Holds Unit Seperator for T records
x_fl     XREG      0c(16)
.
.        bam record equivalents
.
bam_hdrt equ       0                   .bam record header type
bam_len  equ       bam_hdrt+1          .bam record length
bam_last equ       bam_len+6           .bam previous record fba
bam_id   equ       bam_last+6          .bam record identifier
hdr_size equ       bam_id+1
.
bac_fulr equ       0                   .bac$full_record
bac_star equ       1                   .bac$start_record
bac_conr equ       2                   .bac$continue_record
bac_endr equ       3                   .bac$end_record
bac_part equ       4                   .bac$partition
bac_delr equ       5                   .bac$deleted_record
bac_endd equ       6                   .bac$end_of_data
.
.        endline   - terminate current bam record.
.
         proc
endline  pname
         ente      x_ch,01e(16)
         sbyts,1   x_ch,a_line,x0,bam_id
         entp      x_ch,bac_fulr
         sbyts,1   x_ch,a_line,x0,bam_hdrt
         sbyts,6   x_li,a_line,x0,bam_len   .save record length
         incr      x_li,hdr_size
         addax     a_line,x_li
         sbyts,6   x_fp,a_line,x0,bam_last
         addr      x_fp,x_li
         entp      x_li,0              .reset record size
         pend
.
.        nxtline   - setup to read next bam record.
.
         proc
nxtline  pname
         local     next_rec
next_rec addrq     x_rl,x_rl,hdr_size
         addr      x_fp,x_rl
         addrq     x2,x_fp,hdr_size
         brrgt     x2,x_fl,exit        .if at end of file
         addax     a_line,x_rl
         lbyts,6   x_rl,a_line,x0,bam_len   .fetch record length
         entp      x_li,0              .reset record size
         lbyts,1   x2,a_line,x0,bam_hdrt
         decr      x2,bac_part
         brrge     x2,x0,next_rec
         addrq     x2,x_fp,hdr_size
         addr      x2,x_rl
         brrgt     x2,x_fl,exit        .if at end of file
         pend
.
.        definition of save record.
.
cnv_type equ       0                   .conversion type
seq_ptr  equ       1                   .VE file sequence ptr
seq_len  equ       seq_ptr+6           .VE file length
seq_pos  equ       seq_len+4           .VE file position
line_pos equ       seq_pos+4           .position within current line
last_ch  equ       line_pos+4          .last contents of x_ch
.
syp$memory_link_data_conversion  procedur gated
request  param     val,pointer
buffer   param     val,pointer
length   param     ref,integer
.
         ploada    a_buf,buffer        .fetch pointer to input buffer
         ploadx    x_bl,length         .size of buffer
         ploada    a_save,request
         la        a_vefile,a_save,seq_ptr .fba of VE file
         lbyts,4   x_fl,a_save,x0,seq_len  .fetch VE file length
         lbyts,4   x_fp,a_save,x0,seq_pos  .fetch position within VE file
         lbyts,4   x_li,a_save,x0,line_pos .length of line
         cpyaa     a_line,a_vefile
         addax     a_line,x_fp             .pointer to current record
         lbyts,1   x_ch,a_save,x0,last_ch
         entp      x_bi,0                  .preset buffer index
         brreq     x_fl,x_fp,exit          .exit if file len same as file pos
         lbyts,1   x4,a_save,x0,cnv_type
         entx      x1,convc
         brrge     x4,x1,exit          .if illegal conversion type
         shfx      x4,x4,x0,2
         ente      x_ml,600(8)*10      .preset mask limit
         addpxq    a5,x4,convvec       .form pva of entry routine
         brdir     a5,x0               .start conversion
..       exit      return to calling program saving current state.
.
.        entry     x_ch   = possible flag character.
.                  x_li   = index into the current line.
.                  x_fp   = position within the VE file.
.                  x_bi   = current index into NOS data block.
.
exit     sbyts,1   x_ch,a_save,x0,last_ch   .save shift character
         sbyts,4   x_li,a_save,x0,line_pos  .save line length
         sbyts,4   x_fp,a_save,x0,seq_pos   .save file position
         pstorxp   x_bi,length
         return
         PAGE
..       convvec   branch table for the conversion routines.
.
.        entry     a5 = pva of one of these routines.
.
convvec  bss       0
c64ata   addpxq    a_tbl,x0,t64ata     .do 6/12 display code to ascii
         brreq     x0,x0,dcta
.
cat64a   addpxq    a_tbl,x0,tat64a     .do ascii to 6/12 display code
         brreq     x0,x0,atdc
.
c64ta    addpxq    a_tbl,x0,tb64ta     .do display code to ascii
         brreq     x0,x0,dcta
.
cat64    addpxq    a_tbl,x0,tbat64     .do ascii to 64 character display code
         brreq     x0,x0,atdc
.
c812ta   brreq     x0,x0,c812ta3       .do 8 in 12 ascii to ascii
         brreq     x0,x0,$
.
cat812   brreq     x0,x0,cat8121       .do ascii to 8 in 12 ascii
         brreq     x0,x0,$
.
c63ta    addpxq    a_tbl,x0,tb63ta     .do 63 ch display code to ascii
         brreq     x0,x0,dcta
.
cat63    addpxq    a_tbl,x0,tbat63     .do ascii to 63 ch display code
         brreq     x0,x0,atdc
.
c63ata   addpxq    a_tbl,x0,t63ata     .do 6/12 63 ch display code to ascii
         brreq     x0,x0,dcta
.
cat63a   addpxq    a_tbl,x0,tat63a     .do ascii to 6/12 display code
         brreq     x0,x0,atdc
.
p56t64   brreq     x0,x0,p56t641       .pack 56 bits to 64 bits
         brreq     x0,x0,$
.
p64t56   addxq     x2,x_fl,-7
         brreq     x0,x0,p64t561       .pack 64 bits into 56 bits
.
p60t64   brreq     x0,x0,p60t640       .pack 60 bits into 64 bits
         brreq     x0,x0,$
.
p64t60   brrne     x_ch,x0,p64t602     .if on 1/2 byte boundary
         brreq     x0,x0,p64t601       .pack 64 bits into 60 bits
.
p32t64   brreq     x_bi,x_bl,exit
         brreq     x0,x0,p32t641       .pack 32 bits of 60 into 64
.
p64t32   addxq     x2,x_fl,-4
         brreq     x0,x0,p64t321       .pack 64 bits into 32 of 60
.
con812   brreq     x0,x0,con8121       .convert ascii to 8 in 12 t type records
         brreq     x0,x0,$
.
p60t60   brreq     x0,x0,p60t600       .pack 60 bits into 64 bits
         brreq     x0,x0,$             .with zero fill
.

convc    equ       ($-convvec)/8
         PAGE
..       dcta      Display Code To Ascii conversion.
.
.        entry     a_line = pointer to current output record.
.                  a_buf = buffer pointer.
.                  x_ch = shift character flag.
.                  x_li = current length of line.
.                  x_fp = offset within file of current output record.
.                  x_bl = buffer size.
.
.
dcta     ente      xf,080(16)          .shift character flag
dcta1    lxi       x1,a_buf,x_bi,0     .fetch next word from buffer
         entp      x_mask,0
         brreq     x_bi,x_bl,exit      .if out of data
         incr      x_bi,1
         brreq     x_ch,xf,dcta5       .if zero character
dcta2    isob      x2,x1,x_mask,405(8) .isolate 6 bit character
         addrq     x_mask,x_mask,600(8)
         shfr      x_ch,x_ch,x0,6
         addr      x2,x_ch             .add shift offset
         lbyts,1   x_ch,a_tbl,x2,0     .fetch translation
         brrge     x_ch,xf,dcta5       .if shift character
dcta3    sbyts,1   x_ch,a_line,x_li,hdr_size   .store ascii translation
         incr      x_li,1
         entp      x_ch,0              .clear shift character flag
dcta4    brrgt     x_ml,x_mask,dcta2   .if more characters in C170 word
         brreq     x0,x0,dcta1         .fetch next word
.
dcta5    subr      x_ch,xf             .form shift table offset
         brrne     x_ch,x0,dcta4       .if not the ZERO character
         cpyxx     x_ch,xf
         brreq     x_mask,x_ml,dcta1   .if last character in word
         cpyxx     x4,x_ml
         subr      x4,x_mask
         shfr      x4,x4,x0,-6
         decr      x4,1                .count of bits remaining in word
         addr      x4,x_mask
         isob      x2,x1,x4,400(8)     .isolate remaining portion of word
         ente      x_ch,c' :'
         brxne     x2,x0,dcta3         .if not end of line
         endline
         brreq     x0,x0,dcta1         .fetch next word
.
t63ata   vfd,8     80(16)
         vfd,208   c'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
         vfd,80    c'0123456789'
         vfd,152   c'+-*/()$= ,.#[]:"_!&'
         vfd,8     027(16)
         vfd,24    c'?<>'
         vfd,8     80(16)+(tb6374-t63ata)/64
         vfd,8     c'\'
         vfd,8     80(16)+(data76-t63ata)/64
         vfd,8     c';'
.
tb6374   vfd,128   c':@^@%@@`        '
         vfd,128   c'                '
         vfd,128   c'                '
         vfd,128   c'                '
.
t64ata   vfd,8     80(16)
         vfd,208   c'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
         vfd,80    c'0123456789'
         vfd,152   c'+-*/()$= ,.#[]%"_!&'
         vfd,8     027(16)
         vfd,24    c'?<>'
         vfd,8     80(16)+(tb6474-t64ata)/64
         vfd,8     c'\'
         vfd,8     80(16)+(data76-t64ata)/64
         vfd,8     c';'
.
tb6474   vfd,128   c':@^@:@@`        '
         vfd,128   c'                '
         vfd,128   c'                '
         vfd,128   c'                '
.
data76   vfd,8     c'`'
         vfd,208   c'abcdefghijklmnopqrstuvwxyz'
         vfd,32    c'{|}~'
         vfd,8     07f(16)
         vfd,64    00001020304050607(16)
         vfd,64    008090a0b0c0d0e0f(16)
         vfd,64    01011121314151617(16)
         vfd,64    018191a1b1c1d1e1f(16)
.
tb64ta   vfd,8     80(16)
         vfd,208   c'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
         vfd,80    c'0123456789'
         vfd,152   c'+-*/()$= ,.#[]%"_!&'
         vfd,8     027(16)
         vfd,56    c'?<>@\^;'
.
tb63ta   vfd,8     80(16)
         vfd,208   c'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
         vfd,80    c'0123456789'
         vfd,152   c'+-*/()$= ,.#[]:"_!&'
         vfd,8     027(16)
         vfd,56    c'?<>@\^;'
         PAGE
..       atdc      Ascii To Display Code conversion.
.
.        entry     a_line = pointer to current output record.
.                  a_tbl = pointer to conversion table.
.                  a_buf = buffer pointer.
.                  x_ch = shift character flag.
.                  x_li = current length of line.
.                  x_fp = offset within file of current output record.
.                  x_bl = buffer size.
.
.
atdc     lbyts,6   x_rl,a_line,x0,bam_len
         addrq     x2,x_rl,hdr_size
         addr      x2,x_fp
         brrgt     x2,x_fl,exit
atdc1    entp      x1,0
         ente      x2,07f(16)
         entp      x_mask,0
atdc2    brrne     x_ch,x0,atdc3       .if additional character to copy
         brrge     x_li,x_rl,atdc5     .if at or past the end of line
         lbyts,1   x_ch,a_line,x_li,hdr_size   .fetch next character from line
         andx      x_ch,x2
         incr      x_li,1
         addr      x_ch,x_ch
         lbyts,2   x_ch,a_tbl,x_ch,0   .fetch display code version
atdc3    insb      x1,x_ch,x_mask,405(8)   .insert display code character
         addxq     x_mask,x_mask,600(8)
         shfx      x_ch,x_ch,x0,-6
         brrgt     x_ml,x_mask,atdc2   .if more room in c170 word
         sxi       x1,a_buf,x_bi,0
         incr      x_bi,1
atdc4    brrne     x_bi,x_bl,atdc1     .if more room in buffer
         brreq     x0,x0,exit
atdc5    lbyts,1   x2,a_line,x0,bam_hdrt
         brrne     x2,x0,atdc7         .if not bac$full_record
atdc6    isob      x2,x1,x0,6413(8)    .check last 12 bits
         brrne     x2,x0,atdc3         .if not proper end of line
         sxi       x1,a_buf,x_bi,0
         incr      x_bi,1
         entp      x1,0
         nxtline                       .advance to next BAM record
         entp      x_ch,0
         brreq     x0,x0,atdc4         .process next line
.
atdc7    bss       0                   .process partial record
         decr      x2,bac_endr
         brreq     x2,x0,atdc6         .if bac$end_record
         nxtline                       .advance to next BAM record
         entp      x_ch,0
         ente      x2,07f(16)
         brreq     x0,x0,atdc2         .continue current line
.
tat64a   vfd,16    4076(8)             .nul
         vfd,16    4176(8)             .soh
         vfd,16    4276(8)             .stx
         vfd,16    4376(8)             .etx
         vfd,16    4476(8)             .eot
         vfd,16    4576(8)             .enq
         vfd,16    4676(8)             .ack
         vfd,16    4776(8)             .bel
         vfd,16    5076(8)             .bs
         vfd,16    5176(8)             .ht
         vfd,16    5276(8)             .lf
         vfd,16    5376(8)             .vt
         vfd,16    5476(8)             .ff
         vfd,16    5576(8)             .cr
         vfd,16    5676(8)             .s0
         vfd,16    5776(8)             .s1
         vfd,16    6076(8)             .dle
         vfd,16    6176(8)             .dc1
         vfd,16    6276(8)             .dc2
         vfd,16    6376(8)             .dc3
         vfd,16    6476(8)             .dc4
         vfd,16    6576(8)             .nak
         vfd,16    6676(8)             .syn
         vfd,16    6776(8)             .etb
         vfd,16    7076(8)             .can
         vfd,16    7176(8)             .em
         vfd,16    7276(8)             .sub
         vfd,16    7376(8)             .esc
         vfd,16    7476(8)             .fs
         vfd,16    7576(8)             .gs
         vfd,16    7676(8)             .rs
         vfd,16    7776(8)             .us
         vfd,16    0055(8)             .space
         vfd,16    0066(8)             .!
         vfd,16    0064(8)             ."
         vfd,16    0060(8)             .#
         vfd,16    0053(8)             .$
         vfd,16    0063(8)             .%
         vfd,16    0067(8)             .&
         vfd,16    0070(8)             .'
         vfd,16    0051(8)             .(
         vfd,16    0052(8)             .)
         vfd,16    0047(8)             .*
         vfd,16    0045(8)             .+
         vfd,16    0056(8)             ., comma
         vfd,16    0046(8)             .-
         vfd,16    0057(8)             ..
         vfd,16    0050(8)             ./
         vfd,16    0033(8)             .0
         vfd,16    0034(8)             .1
         vfd,16    0035(8)             .2
         vfd,16    0036(8)             .3
         vfd,16    0037(8)             .4
         vfd,16    0040(8)             .5
         vfd,16    0041(8)             .6
         vfd,16    0042(8)             .7
         vfd,16    0043(8)             .8
         vfd,16    0044(8)             .9
         vfd,16    0474(8)             .:
         vfd,16    0077(8)             .;
         vfd,16    0072(8)             .<
         vfd,16    0054(8)             .=
         vfd,16    0073(8)             .>
         vfd,16    0071(8)             .?
         vfd,16    0174(8)             .@
         vfd,16    0001(8)             .A
         vfd,16    0002(8)             .B
         vfd,16    0003(8)             .C
         vfd,16    0004(8)             .D
         vfd,16    0005(8)             .E
         vfd,16    0006(8)             .F
         vfd,16    0007(8)             .G
         vfd,16    0010(8)             .H
         vfd,16    0011(8)             .I
         vfd,16    0012(8)             .J
         vfd,16    0013(8)             .K
         vfd,16    0014(8)             .L
         vfd,16    0015(8)             .M
         vfd,16    0016(8)             .N
         vfd,16    0017(8)             .O
         vfd,16    0020(8)             .P
         vfd,16    0021(8)             .Q
         vfd,16    0022(8)             .R
         vfd,16    0023(8)             .S
         vfd,16    0024(8)             .T
         vfd,16    0025(8)             .U
         vfd,16    0026(8)             .V
         vfd,16    0027(8)             .W
         vfd,16    0030(8)             .X
         vfd,16    0031(8)             .Y
         vfd,16    0032(8)             .Z
         vfd,16    0061(8)             .[
         vfd,16    0075(8)             .\
         vfd,16    0062(8)             .]
         vfd,16    0274(8)             .^
         vfd,16    0065(8)             ._ underscore
         vfd,16    0774(8)             .` grave
         vfd,16    0176(8)             .a
         vfd,16    0276(8)             .b
         vfd,16    0376(8)             .c
         vfd,16    0476(8)             .d
         vfd,16    0576(8)             .e
         vfd,16    0676(8)             .f
         vfd,16    0776(8)             .g
         vfd,16    1076(8)             .h
         vfd,16    1176(8)             .i
         vfd,16    1276(8)             .j
         vfd,16    1376(8)             .k
         vfd,16    1476(8)             .l
         vfd,16    1576(8)             .m
         vfd,16    1676(8)             .n
         vfd,16    1776(8)             .o
         vfd,16    2076(8)             .p
         vfd,16    2176(8)             .q
         vfd,16    2276(8)             .r
         vfd,16    2376(8)             .s
         vfd,16    2476(8)             .t
         vfd,16    2576(8)             .u
         vfd,16    2676(8)             .v
         vfd,16    2776(8)             .w
         vfd,16    3076(8)             .x
         vfd,16    3176(8)             .y
         vfd,16    3276(8)             .z
         vfd,16    3376(8)             .{
         vfd,16    3476(8)             .|
         vfd,16    3576(8)             .}
         vfd,16    3676(8)             .~
         vfd,16    3776(8)             .del
.
.        ascii to 64 character display code conversion table.
.
tbat64   vfd,16    0055(8)             .nul
         vfd,16    0055(8)             .soh
         vfd,16    0055(8)             .stx
         vfd,16    0055(8)             .etx
         vfd,16    0055(8)             .eot
         vfd,16    0055(8)             .enq
         vfd,16    0055(8)             .ack
         vfd,16    0055(8)             .bel
         vfd,16    0055(8)             .bs
         vfd,16    0055(8)             .ht
         vfd,16    0055(8)             .lf
         vfd,16    0055(8)             .vt
         vfd,16    0055(8)             .ff
         vfd,16    0055(8)             .cr
         vfd,16    0055(8)             .s0
         vfd,16    0055(8)             .s1
         vfd,16    0055(8)             .dle
         vfd,16    0055(8)             .dc1
         vfd,16    0055(8)             .dc2
         vfd,16    0055(8)             .dc3
         vfd,16    0055(8)             .dc4
         vfd,16    0055(8)             .nak
         vfd,16    0055(8)             .syn
         vfd,16    0055(8)             .etb
         vfd,16    0055(8)             .can
         vfd,16    0055(8)             .em
         vfd,16    0055(8)             .sub
         vfd,16    0055(8)             .esc
         vfd,16    0055(8)             .fs
         vfd,16    0055(8)             .gs
         vfd,16    0055(8)             .rs
         vfd,16    0055(8)             .us
         vfd,16    0055(8)             .space
         vfd,16    0066(8)             .!
         vfd,16    0064(8)             ."
         vfd,16    0060(8)             .#
         vfd,16    0053(8)             .$
         vfd,16    0063(8)             .%
         vfd,16    0067(8)             .&
         vfd,16    0070(8)             .'
         vfd,16    0051(8)             .(
         vfd,16    0052(8)             .)
         vfd,16    0047(8)             .*
         vfd,16    0045(8)             .+
         vfd,16    0056(8)             ., comma
         vfd,16    0046(8)             .-
         vfd,16    0057(8)             ..
         vfd,16    0050(8)             ./
         vfd,16    0033(8)             .0
         vfd,16    0034(8)             .1
         vfd,16    0035(8)             .2
         vfd,16    0036(8)             .3
         vfd,16    0037(8)             .4
         vfd,16    0040(8)             .5
         vfd,16    0041(8)             .6
         vfd,16    0042(8)             .7
         vfd,16    0043(8)             .8
         vfd,16    0044(8)             .9
         vfd,16    0000(8)             .:
         vfd,16    0077(8)             .;
         vfd,16    0072(8)             .<
         vfd,16    0054(8)             .=
         vfd,16    0073(8)             .>
         vfd,16    0071(8)             .?
         vfd,16    0074(8)             .@
         vfd,16    0001(8)             .A
         vfd,16    0002(8)             .B
         vfd,16    0003(8)             .C
         vfd,16    0004(8)             .D
         vfd,16    0005(8)             .E
         vfd,16    0006(8)             .F
         vfd,16    0007(8)             .G
         vfd,16    0010(8)             .H
         vfd,16    0011(8)             .I
         vfd,16    0012(8)             .J
         vfd,16    0013(8)             .K
         vfd,16    0014(8)             .L
         vfd,16    0015(8)             .M
         vfd,16    0016(8)             .N
         vfd,16    0017(8)             .O
         vfd,16    0020(8)             .P
         vfd,16    0021(8)             .Q
         vfd,16    0022(8)             .R
         vfd,16    0023(8)             .S
         vfd,16    0024(8)             .T
         vfd,16    0025(8)             .U
         vfd,16    0026(8)             .V
         vfd,16    0027(8)             .W
         vfd,16    0030(8)             .X
         vfd,16    0031(8)             .Y
         vfd,16    0032(8)             .Z
         vfd,16    0061(8)             .[
         vfd,16    0075(8)             .\
         vfd,16    0062(8)             .]
         vfd,16    0076(8)             .^
         vfd,16    0065(8)             ._ underscore
         vfd,16    0055(8)             .` grave
         vfd,16    0001(8)             .a
         vfd,16    0002(8)             .b
         vfd,16    0003(8)             .c
         vfd,16    0004(8)             .d
         vfd,16    0005(8)             .e
         vfd,16    0006(8)             .f
         vfd,16    0007(8)             .g
         vfd,16    0010(8)             .h
         vfd,16    0011(8)             .i
         vfd,16    0012(8)             .j
         vfd,16    0013(8)             .k
         vfd,16    0014(8)             .l
         vfd,16    0015(8)             .m
         vfd,16    0016(8)             .n
         vfd,16    0017(8)             .o
         vfd,16    0020(8)             .p
         vfd,16    0021(8)             .q
         vfd,16    0022(8)             .r
         vfd,16    0023(8)             .s
         vfd,16    0024(8)             .t
         vfd,16    0025(8)             .u
         vfd,16    0026(8)             .v
         vfd,16    0027(8)             .w
         vfd,16    0030(8)             .x
         vfd,16    0031(8)             .y
         vfd,16    0032(8)             .z
         vfd,16    0055(8)             .{
         vfd,16    0055(8)             .|
         vfd,16    0055(8)             .}
         vfd,16    0055(8)             .~
         vfd,16    0055(8)             .del
.
tat63a   vfd,16    4076(8)             .nul
         vfd,16    4176(8)             .soh
         vfd,16    4276(8)             .stx
         vfd,16    4376(8)             .etx
         vfd,16    4476(8)             .eot
         vfd,16    4576(8)             .enq
         vfd,16    4676(8)             .ack
         vfd,16    4776(8)             .bel
         vfd,16    5076(8)             .bs
         vfd,16    5176(8)             .ht
         vfd,16    5276(8)             .lf
         vfd,16    5376(8)             .vt
         vfd,16    5476(8)             .ff
         vfd,16    5576(8)             .cr
         vfd,16    5676(8)             .s0
         vfd,16    5776(8)             .s1
         vfd,16    6076(8)             .dle
         vfd,16    6176(8)             .dc1
         vfd,16    6276(8)             .dc2
         vfd,16    6376(8)             .dc3
         vfd,16    6476(8)             .dc4
         vfd,16    6576(8)             .nak
         vfd,16    6676(8)             .syn
         vfd,16    6776(8)             .etb
         vfd,16    7076(8)             .can
         vfd,16    7176(8)             .em
         vfd,16    7276(8)             .sub
         vfd,16    7376(8)             .esc
         vfd,16    7476(8)             .fs
         vfd,16    7576(8)             .gs
         vfd,16    7676(8)             .rs
         vfd,16    7776(8)             .us
         vfd,16    0055(8)             .space
         vfd,16    0066(8)             .!
         vfd,16    0064(8)             ."
         vfd,16    0060(8)             .#
         vfd,16    0053(8)             .$
         vfd,16    0474(8)             .%
         vfd,16    0067(8)             .&
         vfd,16    0070(8)             .'
         vfd,16    0051(8)             .(
         vfd,16    0052(8)             .)
         vfd,16    0047(8)             .*
         vfd,16    0045(8)             .+
         vfd,16    0056(8)             ., comma
         vfd,16    0046(8)             .-
         vfd,16    0057(8)             ..
         vfd,16    0050(8)             ./
         vfd,16    0033(8)             .0
         vfd,16    0034(8)             .1
         vfd,16    0035(8)             .2
         vfd,16    0036(8)             .3
         vfd,16    0037(8)             .4
         vfd,16    0040(8)             .5
         vfd,16    0041(8)             .6
         vfd,16    0042(8)             .7
         vfd,16    0043(8)             .8
         vfd,16    0044(8)             .9
         vfd,16    0063(8)             .:
         vfd,16    0077(8)             .;
         vfd,16    0072(8)             .<
         vfd,16    0054(8)             .=
         vfd,16    0073(8)             .>
         vfd,16    0071(8)             .?
         vfd,16    0174(8)             .@
         vfd,16    0001(8)             .A
         vfd,16    0002(8)             .B
         vfd,16    0003(8)             .C
         vfd,16    0004(8)             .D
         vfd,16    0005(8)             .E
         vfd,16    0006(8)             .F
         vfd,16    0007(8)             .G
         vfd,16    0010(8)             .H
         vfd,16    0011(8)             .I
         vfd,16    0012(8)             .J
         vfd,16    0013(8)             .K
         vfd,16    0014(8)             .L
         vfd,16    0015(8)             .M
         vfd,16    0016(8)             .N
         vfd,16    0017(8)             .O
         vfd,16    0020(8)             .P
         vfd,16    0021(8)             .Q
         vfd,16    0022(8)             .R
         vfd,16    0023(8)             .S
         vfd,16    0024(8)             .T
         vfd,16    0025(8)             .U
         vfd,16    0026(8)             .V
         vfd,16    0027(8)             .W
         vfd,16    0030(8)             .X
         vfd,16    0031(8)             .Y
         vfd,16    0032(8)             .Z
         vfd,16    0061(8)             .[
         vfd,16    0075(8)             .\
         vfd,16    0062(8)             .]
         vfd,16    0274(8)             .^
         vfd,16    0065(8)             ._ underscore
         vfd,16    0774(8)             .` grave
         vfd,16    0176(8)             .a
         vfd,16    0276(8)             .b
         vfd,16    0376(8)             .c
         vfd,16    0476(8)             .d
         vfd,16    0576(8)             .e
         vfd,16    0676(8)             .f
         vfd,16    0776(8)             .g
         vfd,16    1076(8)             .h
         vfd,16    1176(8)             .i
         vfd,16    1276(8)             .j
         vfd,16    1376(8)             .k
         vfd,16    1476(8)             .l
         vfd,16    1576(8)             .m
         vfd,16    1676(8)             .n
         vfd,16    1776(8)             .o
         vfd,16    2076(8)             .p
         vfd,16    2176(8)             .q
         vfd,16    2276(8)             .r
         vfd,16    2376(8)             .s
         vfd,16    2476(8)             .t
         vfd,16    2576(8)             .u
         vfd,16    2676(8)             .v
         vfd,16    2776(8)             .w
         vfd,16    3076(8)             .x
         vfd,16    3176(8)             .y
         vfd,16    3276(8)             .z
         vfd,16    3376(8)             .{
         vfd,16    3476(8)             .|
         vfd,16    3576(8)             .}
         vfd,16    3676(8)             .~
         vfd,16    3776(8)             .del
.
.        ascii to 64 character display code conversion table.
.
tbat63   vfd,16    0055(8)             .nul
         vfd,16    0055(8)             .soh
         vfd,16    0055(8)             .stx
         vfd,16    0055(8)             .etx
         vfd,16    0055(8)             .eot
         vfd,16    0055(8)             .enq
         vfd,16    0055(8)             .ack
         vfd,16    0055(8)             .bel
         vfd,16    0055(8)             .bs
         vfd,16    0055(8)             .ht
         vfd,16    0055(8)             .lf
         vfd,16    0055(8)             .vt
         vfd,16    0055(8)             .ff
         vfd,16    0055(8)             .cr
         vfd,16    0055(8)             .s0
         vfd,16    0055(8)             .s1
         vfd,16    0055(8)             .dle
         vfd,16    0055(8)             .dc1
         vfd,16    0055(8)             .dc2
         vfd,16    0055(8)             .dc3
         vfd,16    0055(8)             .dc4
         vfd,16    0055(8)             .nak
         vfd,16    0055(8)             .syn
         vfd,16    0055(8)             .etb
         vfd,16    0055(8)             .can
         vfd,16    0055(8)             .em
         vfd,16    0055(8)             .sub
         vfd,16    0055(8)             .esc
         vfd,16    0055(8)             .fs
         vfd,16    0055(8)             .gs
         vfd,16    0055(8)             .rs
         vfd,16    0055(8)             .us
         vfd,16    0055(8)             .space
         vfd,16    0066(8)             .!
         vfd,16    0064(8)             ."
         vfd,16    0060(8)             .#
         vfd,16    0053(8)             .$
         vfd,16    0055(8)             .% no translation
         vfd,16    0067(8)             .&
         vfd,16    0070(8)             .'
         vfd,16    0051(8)             .(
         vfd,16    0052(8)             .)
         vfd,16    0047(8)             .*
         vfd,16    0045(8)             .+
         vfd,16    0056(8)             ., comma
         vfd,16    0046(8)             .-
         vfd,16    0057(8)             ..
         vfd,16    0050(8)             ./
         vfd,16    0033(8)             .0
         vfd,16    0034(8)             .1
         vfd,16    0035(8)             .2
         vfd,16    0036(8)             .3
         vfd,16    0037(8)             .4
         vfd,16    0040(8)             .5
         vfd,16    0041(8)             .6
         vfd,16    0042(8)             .7
         vfd,16    0043(8)             .8
         vfd,16    0044(8)             .9
         vfd,16    0063(8)             .:
         vfd,16    0077(8)             .;
         vfd,16    0072(8)             .<
         vfd,16    0054(8)             .=
         vfd,16    0073(8)             .>
         vfd,16    0071(8)             .?
         vfd,16    0074(8)             .@
         vfd,16    0001(8)             .A
         vfd,16    0002(8)             .B
         vfd,16    0003(8)             .C
         vfd,16    0004(8)             .D
         vfd,16    0005(8)             .E
         vfd,16    0006(8)             .F
         vfd,16    0007(8)             .G
         vfd,16    0010(8)             .H
         vfd,16    0011(8)             .I
         vfd,16    0012(8)             .J
         vfd,16    0013(8)             .K
         vfd,16    0014(8)             .L
         vfd,16    0015(8)             .M
         vfd,16    0016(8)             .N
         vfd,16    0017(8)             .O
         vfd,16    0020(8)             .P
         vfd,16    0021(8)             .Q
         vfd,16    0022(8)             .R
         vfd,16    0023(8)             .S
         vfd,16    0024(8)             .T
         vfd,16    0025(8)             .U
         vfd,16    0026(8)             .V
         vfd,16    0027(8)             .W
         vfd,16    0030(8)             .X
         vfd,16    0031(8)             .Y
         vfd,16    0032(8)             .Z
         vfd,16    0061(8)             .[
         vfd,16    0075(8)             .\
         vfd,16    0062(8)             .]
         vfd,16    0076(8)             .^
         vfd,16    0065(8)             ._ underscore
         vfd,16    0055(8)             .` grave
         vfd,16    0001(8)             .a
         vfd,16    0002(8)             .b
         vfd,16    0003(8)             .c
         vfd,16    0004(8)             .d
         vfd,16    0005(8)             .e
         vfd,16    0006(8)             .f
         vfd,16    0007(8)             .g
         vfd,16    0010(8)             .h
         vfd,16    0011(8)             .i
         vfd,16    0012(8)             .j
         vfd,16    0013(8)             .k
         vfd,16    0014(8)             .l
         vfd,16    0015(8)             .m
         vfd,16    0016(8)             .n
         vfd,16    0017(8)             .o
         vfd,16    0020(8)             .p
         vfd,16    0021(8)             .q
         vfd,16    0022(8)             .r
         vfd,16    0023(8)             .s
         vfd,16    0024(8)             .t
         vfd,16    0025(8)             .u
         vfd,16    0026(8)             .v
         vfd,16    0027(8)             .w
         vfd,16    0030(8)             .x
         vfd,16    0031(8)             .y
         vfd,16    0032(8)             .z
         vfd,16    0055(8)             .{
         vfd,16    0055(8)             .|
         vfd,16    0055(8)             .}
         vfd,16    0055(8)             .~
         vfd,16    0055(8)             .del
         PAGE
..       c812ta    C170 8 in 12 to ascii.
.
.        entry     a_line = pointer to current output record.
.                  a_buf = buffer pointer.
.                  x_li = current length of line.
.                  x_fp = offset within file of current output record.
.                  x_bl = buffer size.
.
.
c812ta1  isob      x_ch,x1,x_mask,0413(8)
         brreq     x_ch,x0,c812ta4     .if possible end of ine
c812ta2  sbyts,1   x_ch,a_line,x_li,hdr_size  .save character in line
         addrq     x_mask,x_mask,1400(8)
         incr      x_li,1
         brrne     x_mask,x_ml,c812ta1 .if more characters in word
c812ta3  lxi       x1,a_buf,x_bi,0     .read next C170 word from buffer
         entp      x_mask,0
         incr      x_bi,1
         brrge     x_bl,x_bi,c812ta1   .if word in buffer
         brreq     x0,x0,exit          .exit to get next buffer
.
c812ta4  cpyxx     x4,x_ml
         subr      x4,x_mask
         shfr      x4,x4,x0,-6
         decr      x4,1                .count of bits remaining in word
         addr      x4,x_mask
         isob      x4,x1,x4,400(8)
         brxne     x4,x0,c812ta2       .if not valid end of line
         endline
         brreq     x0,x0,c812ta3       .start next line
         PAGE
..       cat812    convert ascii to 8 in 12 ascii.
.
.        entry     a_line = pointer to current output record.
.                  a_buf = buffer pointer.
.                  x_li = current length of line.
.                  x_fp = offset within file of current output record.
.                  x_bl = buffer size.
.
cat8121  ente      xf,4000(8)
         lbyts,6   x_rl,a_line,x0,bam_len
         addrq     x2,x_rl,hdr_size
         addr      x2,x_fp
         brrgt     x2,x_fl,exit
cat8122  entp      x1,0
         entp      x_mask,0
cat8123  brreq     x_li,x_rl,cat8125
         lbyts,1   x_ch,a_line,x_li,hdr_size
         incr      x_li,1
         insb      x1,x_ch,x_mask,0413(8)
         addxq     x_mask,x_mask,1400(8)
         brrne     x_mask,x_ml,cat8123 .if more room in C170 word
         sxi       x1,a_buf,x_bi,0     .store converted characters
         incr      x_bi,1
cat8124  brrne     x_bi,x_bl,cat8122   .if more room in c170 buffer
         brreq     x0,x0,exit
.
cat8125  sxi       x1,a_buf,x_bi,0     .store converted characters
         lbyts,1   x2,a_line,x0,bam_hdrt
         brrne     x2,x0,cat8127       .if not bac$full_record
cat8126  incr      x_bi,1              .process complete record
         nxtline
         brreq     x0,x0,cat8124       .process next VE line
cat8127  bss       0                   .process partial record
         decr      x2,bac_endr
         brreq     x2,x0,cat8126       .if bac$end_record
         nxtline                       .advance to next BAM record
         brreq     x0,x0,cat8122       .continue with current line
         PAGE
..       con812    Convert ascii to 8 in 12 ascii t type records US trailer
.
.        Entry     a_buf = buffer pointer
.                  a_ve_file = location of ve file
.                  x_fl = file_limit
.                  x_fp = file_position
.                  x_bl = buffer_limit
.                  x_bi = buffer_index = 0
.
con8121  entp      x1,0
         entp      x_mask,0
         ente      x_us,1f(16)             .unit seperator for t type records
con8122  brrge     x_fp,x_fl,exit          .if file_position > file_limit
         lbyts,1   x_ch,a_vefile,x_fp,0    .get next character in file
         incr      x_fp,1                  .incrment to next character in file
         brreq     x_ch,x_us,con8123       .if end of line
         insb      x1,x_ch,x_mask,0413(8)
         addxq     x_mask,x_mask,1400(8)
         brrne     x_mask,x_ml,con8122     .if room in 170 word
con8123  sxi       x1,a_buf,x_bi,0         .store converted 170 word
         incr      x_bi,1                  .increment to next buffer word
         brrne     x_bi,x_bl,con8121       .if still room in buffer
         brreq     x0,x0,exit              .if buffer is full
         PAGE

..       p56t64    pack 56 bits of nos data to 64 bit ve data.
.
.        entry     a_vefile = pva of first byte in VE file.
.                  a_buf = buffer pointer.
.                  x_bi = 0.
.                  x_fp = offset into VE file of data being converted.
.                  x_bl = buffer size.
.
.
p56t641  lxi       x1,a_buf,x_bi,0     .fetch next nos word
         isob      x2,x1,x0,403(8)     .unused byte count
         incr      x_bi,1
         brrgt     x_bi,x_bl,exit      .if end of c170 buffer
         sbyts,7   x1,a_vefile,x_fp,0    .save in VE buffer
         incr      x_fp,7
         brreq     x0,x2,p56t641       .if more data to copy
         subr      x_fp,x2             .subtract unused bytes
         brrge     x_fp,x0,exit        .if offset positive
         entp      x_fp,0              .force to zero, probably means not b56 file
         brreq     x0,x0,exit          .end of transfer
         PAGE
..       p64t56    pack 64 bits into 56 bit words of C170 data.
.
.        entry     a_vefile = pva of first byte in VE file.
.                  a_buf = buffer pointer.
.                  x_bi = 0.
.                  x_fp = offset into VE file of data being converted.
.                  x_bl = buffer size.
.
.
p64t561  brrge     x_fp,x2,p64t562     .if last portion of VE data
         lbyts,7   x1,a_vefile,x_fp,0
         incr      x_fp,7
         sxi       x1,a_buf,x_bi,0
         incr      x_bi,1
         brrne     x_bi,x_bl,p64t561   .if more room in c170 buffer
         brreq     x0,x0,exit          .return with full buffer
.
p64t562  addxq     x3,x_fp,7           .calculate unused byte count
         subr      x3,x_fl
         mulrq     x2,x3,8
         cpyxx     x0,x_fl
         subr      x0,x_fp             .valid byte count
         decr      x0,1
         lbyt,x0   x1,a_vefile,x_fp,0
         shfx      x1,x1,x2,0          .position valid data to upper part
         shfx      x3,x3,x0,56         .position unused byte count
         iorx      x1,x3
         sxi       x1,a_buf,x_bi,0     .save last c170 word
         incr      x_bi,1
         brreq     x0,x0,exit          .return with final transfer
         PAGE
..       p32t64    pack 32 bits of 60 into 64 bit ve data.
.
.        entry     a_vefile = pva of first byte in VE file.
.                  a_buf = buffer pointer.
.                  a_bi = 0.
.                  a_fp = offset into VE file of data being converted.
.                  a_bl = buffer size.
.
.
p32t641  lxi       x1,a_buf,x_bi,0     .fetch next nos word
         sbyts,4   x1,a_vefile,x_fp,0  .save in ve buffer
         incr      x_fp,4
         incr      x_bi,1
         brrgt     x_bl,x_bi,p32t641   .if more words to copy
         brreq     x0,x0,exit          .end of transfer
         PAGE
..       p64t32    copy 64 bits into 32 of each 60.
.
.        entry     a_vefile = pva of first byte in VE file.
.                  a_buf = buffer pointer.
.                  x_bi = 0.
.                  x_fp = offset into VE file of data being converted.
.                  x_bl = buffer size.
.
.
p64t321  brrge     x_fp,x2,p64t322     .if near end of VE data
         lbyts,4   x1,a_vefile,x_fp,0  .copy 32 bits
         sxi       x1,a_buf,x_bi,0
         incr      x_fp,4
         incr      x_bi,1
         brrne     x_bi,x_bl,p64t321
         brreq     x0,x0,exit          .if buffer filled
.
p64t322  cpyxx     x0,x_fl             .compute excess byte count
         subr      x0,x_fp
         entp      x2,4
         subr      x2,x0
         mulrq     x2,x2,8             .compute shift count to left adjust
         decr      x0,1
         lbyt,x0   x1,a_vefile,x_fp,0
         shfx      x1,x1,x2,0          .left adjust in 32 bits
         sxi       x1,a_buf,x_bi,0     .store final word in 170 file
         incr      x_bi,1
         brreq     x0,x0,exit          .end of transfer
         PAGE
..       p60t64    pack 60 bits of nos data to 64 bit ve data.
.
.        entry     a_vefile = pva of first byte in VE file.
.                  a_buf = buffer pointer.
.                  x_bi = 0.
.                  x_fp = offset into VE file of data being converted.
.                  x_bl = buffer size.
.
.
p60t640  brreq     x_bi,x_bl,exit      .if no data in buffer
         brreq     x_ch,x0,p60t641     .if not on 1/2 byte boundary
         decr      x_fp,8
         lbyts,8   x1,a_vefile,x_fp,0
         shfx      x1,x1,x0,-4
         brreq     x0,x0,p60t642
.
p60t641  lxi       x1,a_buf,x_bi,0     .fetch 7 1/2 bytes
         incr      x_bi,1
         brreq     x_bi,x_bl,p60t643   .if end of nos data
p60t642  lxi       x2,a_buf,x_bi,0     .fetch 7 1/2 bytes
         insb      x2,x1,x0,0003(8)    .insert 1/2 byte
         shfx      x1,x1,x0,-4         .7 bytes
         sbyts,7   x1,a_vefile,x_fp,0  .store 15 bytes
         sbyts,8   x2,a_vefile,x_fp,7
         incr      x_bi,1
         incr      x_fp,15
         brrne     x_bi,x_bl,p60t641   .if more nos data
         entp      x_ch,0
         brreq     x0,x0,exit          .if end of nos buffer
.
p60t643  shfx      x1,x1,x0,4
         sbyts,8   x1,a_vefile,x_fp,0  .store 7 1/2 bytes
         incr      x_fp,8
         entp      x_ch,1              .set 1/2 byte flag
         brreq     x0,x0,exit
.
p60t644  brreq     x_bi,x_bl,exit      .if no data in buffer
         decr      x_fp,8
         lbyts,8   x1,a_vefile,x_fp,0  .fetch 7 1/2 byte
         shfx      x1,x1,x0,-4
         brreq     x0,x0,p60t642       .form 15 bytes of ve data
         PAGE
..       p60t60    place 60 bits of nos data to 64 bit ve data.
.                  with zero fill
.
.        entry     a_vefile = pva of first byte in VE file.
.                  a_buf = buffer pointer.
.                  x_bi = 0.
.                  x_fp = offset into VE file of data being converted.
.                  x_bl = buffer size.
.
.
p60t600  bss       0
         brreq     x_bi,x_bl,exit      .if no data in buffer
         isom      x2,x0,0003          .mask off upper 1/2 of byte 8
.
p60t601  lxi       x1,a_buf,x_bi,0     .fetch 7 1/2 bytes
.
         inhx      x1,x2               .insert 170 word
         sbyts,8   x1,a_vefile,x_fp,0
         incr      x_bi,1
         incr      x_fp,8
         brrne     x_bi,x_bl,p60t601   .if more nos data
         entp      x_ch,0
         brreq     x0,x0,exit          .if end of nos buffer
.
         PAGE
..       p64t60    pack 64 bits into 60 bits.
.
.        entry     a_vefile = pva of first byte in VE file.
.                  a_buf = buffer pointer.
.                  x_bi = 0.
.                  x_fp = offset into VE file of data being converted.
.                  x_bl = buffer size.
.
.
p64t601  bss       0
         addrq     x2,x_fp,8
         brrgt     x2,x_fl,p64t603   .if near end of file
         lbyts,8   x1,a_vefile,x_fp,0
         isob      x_ch,x1,x0,7403(8)
         addrq     x_ch,x_ch,10(16)
         shfx      x1,x1,x0,-4         .form 60 bit value
         sxi       x1,a_buf,x_bi,0
         incr      x_fp,8
         incr      x_bi,1
         brreq     x_bi,x_bl,exit      .if end of 170 buffer
p64t602  bss       0
         addrq     x2,x_fp,7
         brrgt     x2,x_fl,p64t603   .if near end of file
         lbyts,7   x1,a_vefile,x_fp,0
         insb      x1,x_ch,x0,0403(8)
         entp      x_ch,0
         sxi       x1,a_buf,x_bi,0
         incr      x_bi,1
         incr      x_fp,7
         brrne     x_bi,x_bl,p64t601   .if more buffer space available
         brreq     x0,x0,exit          .if end of 170 buffer
.
p64t603  cpyxx     x0,x_fl
         subr      x0,x_fp             .remaining byte count
         cpyxx     x2,x0
         brrne     x2,x0,p64t6031      .if not done (1 or more bytes left)
         brreq     x_ch,x0,exit        .if done
         entp      x0,1                .4 bits left
p64t6031 bss       0
         entp      x2,8
         subr      x2,x0               .unused byte count
         decr      x0,1
         lbyt,x0   x1,a_vefile,x_fp,0
         mulxq     x2,x2,8             .unused bit count
         shfx      x1,x1,x2,-4         .left adjust to 60 bits
         cpyxx     x_fp,x_fl
         brreq     x_ch,x0,p64t604     .if not on 1/2 byte boundary
         shfx      x1,x1,x0,-4
         insb      x1,x_ch,x0,0403(8)
p64t604  entp      x_ch,0
         sxi       x1,a_buf,x_bi,0
         incr      x_bi,1
         brreq     x0,x0,exit          .file conversion complete
         end
*DECK DECK=SYM$MISC_BOOT_HOOKS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE System : Miscellaneous Boot Hooks' ??
MODULE sym$misc_boot_hooks;

{ PURPOSE:
{   This module contains all of the procedure hooks needed so that the boot will link.  The procedures
{   do not contain any code because they are never called in the boot but nevertheless the call may
{   exist in OSF$BOOT_JOB.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc cmt$element_state
*copyc cmt$physical_address
*copyc dmt$sc_flaw_command
*copyc iot$pp_number
*copyc mmt$active_segment_table
*copyc mmt$segment_descriptor_table
*copyc mmt$segment_descriptor_table_ex
*copyc mtt$monitor_xp_slot_pointers
*copyc ost$hardware_subranges
*copyc ost$processor_id
*copyc ost$wait
*copyc pmt$log_msg_text
*copyc pmt$program_name
?? POP ??
*copyc osp$system_error
*copyc pmp$delay
?? TITLE := 'Global variables declared in this module', EJECT ??

{ These variables are not used in the boot, but need to be declared to allow linking of the boot.

  VAR
    mtv$monitor_xp_slot_pointers: [XDCL] mtt$monitor_xp_slot_pointers := [NIL, NIL],
    syv$run_all_timestamp: [XDCL] integer := 0,
    syv$repeatable_command_p: [XDCL] ^string (*) := NIL;

?? TITLE := 'cmp$find_redundant_path', EJECT ??

  PROCEDURE [XDCL, #GATE] cmp$find_redundant_path
    (    primary_path_element: cmt$physical_address;
         new_state: cmt$element_state;
     VAR redundant_path_available: boolean;
     VAR update_controller_address: boolean;
     VAR number_of_path: integer;
     VAR redundant_channel_list: ARRAY [cmt$physical_equipment_number] OF cmt$physical_address;
     VAR redundant_path_pp_list: ARRAY [cmt$physical_equipment_number] OF iot$pp_number;
     VAR driver_name: pmt$program_name;
     VAR pp_table_rma_list: ARRAY [cmt$physical_equipment_number] OF ost$real_memory_address);

     redundant_path_available := FALSE;

  PROCEND cmp$find_redundant_path;

?? TITLE := 'dmp$store_sc_flaw_command', EJECT ??
  PROCEDURE [XDCL, #GATE] dmp$store_sc_flaw_command
    (    p_sc_flaw: ^dmt$sc_flaw_command);

    osp$system_error (' DMP$STORE_SC_FLAW_COMMAND should not be called in the boot.', NIL);

  PROCEND dmp$store_sc_flaw_command;
?? TITLE := 'dsp$mtr_save_cause_and_time', EJECT ??
  PROCEDURE [XDCL] dsp$mtr_save_cause_and_time
    (    timestamp: integer;
         probable_cause: integer);

  PROCEND dsp$mtr_save_cause_and_time;
?? TITLE := 'dsp$mtr_save_nos_nbe_status', EJECT ??
  PROCEDURE [XDCL] dsp$mtr_save_nos_nbe_status
    (    nos_nbe_status: integer);

  PROCEND dsp$mtr_save_nos_nbe_status;
?? TITLE := 'dsp$start_one_cpu', EJECT ??
  PROCEDURE [XDCL] dsp$start_one_cpu
    (    processor_id: ost$processor_id;
     VAR status: ost$status);

    status.normal := TRUE;

  PROCEND dsp$start_one_cpu;
?? TITLE := 'dsp$system_committed', EJECT ??
  FUNCTION [XDCL] dsp$system_committed: boolean;
    dsp$system_committed := FALSE;
  FUNCEND dsp$system_committed;
?? TITLE := 'iop$allocate_usage_counters', EJECT ??
  PROCEDURE [XDCL] iop$allocate_usage_counters
    (VAR status: ost$status);

    status.normal := TRUE;

  PROCEND iop$allocate_usage_counters;
?? OLDTITLE ??
?? NEWTITLE := 'lgp$add_entry_to_critical_log', EJECT ??
  PROCEDURE [XDCL] lgp$add_entry_to_critical_log
    (    text: pmt$log_msg_text;
     VAR status: ost$status);

    status.normal := TRUE;

  PROCEND lgp$add_entry_to_critical_log;
?? TITLE := 'mmp$assign_contiguous_memory', EJECT ??
  PROCEDURE [XDCL, #GATE] mmp$assign_contiguous_memory
    (    process_virtual_address: ^cell;
         segment_length: ost$segment_length;
     VAR status: ost$status);

     osp$system_error (' MMP$ASSIGN_CONTIGUOUS_MEMORY should not be called in the boot.', NIL);

  PROCEND mmp$assign_contiguous_memory;
?? TITLE := 'mmp$aste_pointer', EJECT ??
  PROCEDURE [XDCL, #GATE] mmp$aste_pointer
    (    asid: ost$asid;
     VAR aste_p: ^mmt$active_segment_table_entry);

    osp$system_error (' MMP$ASTE_POINTER should not be called in the boot.', NIL);

  PROCEND mmp$aste_pointer;
?? TITLE := 'mmp$close_asid_based_segment', EJECT ??
  PROCEDURE [XDCL] mmp$close_asid_based_segment
    (    segment_number: ost$segment;
     VAR status: ost$status);

    status.normal := TRUE;

  PROCEND mmp$close_asid_based_segment;
?? TITLE := 'mmp$free_pages', EJECT ??
  PROCEDURE [XDCL] mmp$free_pages
    (    pva_p: ^cell;
         length: ost$byte_count;
         waitopt: ost$wait;
     VAR status: ost$status);

    status.normal := TRUE;

  PROCEND mmp$free_pages;
?? TITLE := 'mmp$invalidate_segment', EJECT ??
  PROCEDURE [XDCL, #GATE] mmp$invalidate_segment
    (    segment_number: ost$segment;
     VAR status: ost$status);

    status.normal := TRUE;

  PROCEND mmp$invalidate_segment;
?? TITLE := 'mmp$open_asid_based_segment', EJECT ??
  PROCEDURE [XDCL] mmp$open_asid_based_segment
    (    sdt_entry: mmt$segment_descriptor;
         sdtx_entry: mmt$segment_descriptor_extended;
     VAR segment_number: ost$segment;
     VAR status: ost$status);

     status.normal := TRUE;

  PROCEND mmp$open_asid_based_segment;
?? TITLE := 'mmp$preallocate_file_space', EJECT ??
  PROCEDURE [XDCL, #GATE] mmp$preallocate_file_space
    (    process_virtual_address: ^cell;
         segment_length: ost$segment_length;
     VAR status: ost$status);

     osp$system_error (' MMP$PREALLOCATE_FILE_SPACE should not be called in the boot.', NIL);

  PROCEND mmp$preallocate_file_space;
?? TITLE := 'mmp$verify_no_space_available', EJECT ??
  PROCEDURE [XDCL, #GATE] mmp$verify_no_space_available
    (    process_virtual_address: ^cell;
     VAR no_space_available: boolean;
     VAR status: ost$status);

    no_space_available := FALSE;
    status.normal := TRUE;

  PROCEND mmp$verify_no_space_available;
?? TITLE := 'mmp$wait_io_completion', EJECT ??
  PROCEDURE [XDCL] mmp$wait_io_completion
    (    p: ^cell;
     VAR status: ost$status);

    pmp$delay (1, status);

  PROCEND mmp$wait_io_completion;
?? TITLE := 'ocp$find_debug_entry_point', EJECT ??
  PROCEDURE [XDCL] ocp$find_debug_entry_point
    (    entry_point: pmt$program_name;
     VAR found: boolean;
     VAR module_name: pmt$program_name;
     VAR segment: ost$segment;
     VAR offset: ost$segment_offset;
     VAR status: ost$status);

  found := FALSE;
  status.normal := TRUE;

  PROCEND ocp$find_debug_entry_point;
?? TITLE := 'osp$check_for_job_recovery', EJECT ??
  PROCEDURE [XDCL] osp$check_for_job_recovery
    (    message: string (*));

  PROCEND osp$check_for_job_recovery;
?? TITLE := 'osp$log_system_error', EJECT ??
  PROCEDURE [XDCL] osp$log_system_error
    (    err_message: string ( * );
         text: string ( * ));

  PROCEND osp$log_system_error;
?? TITLE := 'syp$fetch_system_const_from_ssr', EJECT ??

  PROCEDURE [XDCL] syp$fetch_system_const_from_ssr
    (VAR status: ost$status);

    status.normal := TRUE;

  PROCEND syp$fetch_system_const_from_ssr;
?? TITLE := 'syp$save_system_const_in_ssr', EJECT ??

  PROCEDURE [XDCL] syp$save_system_const_in_ssr
    (VAR status: ost$status);

    status.normal := TRUE;

  PROCEND syp$save_system_const_in_ssr;
?? TITLE := 'syp$set_processor_attributes', EJECT ??
  PROCEDURE [XDCL, #GATE] syp$set_processor_attributes
    (    model_number: integer;
     VAR status: ost$status);

    status.normal := TRUE;

  PROCEND syp$set_processor_attributes;
?? TITLE := 'mmp$os_preallocate_file_space', EJECT ??
  PROCEDURE [XDCL, #GATE] mmp$os_preallocate_file_space
    (    process_virtual_address: ^cell;
         length: ost$segment_length;
         maximum_wait_seconds: integer;
     VAR status: ost$status);

    status.normal := TRUE;

  PROCEND mmp$os_preallocate_file_space;
?? TITLE := 'mmp$mfh_for_segment_manager', EJECT ??
  PROCEDURE [XDCL, #GATE] mmp$mfh_for_segment_manager;

  PROCEND mmp$mfh_for_segment_manager;
MODEND sym$misc_boot_hooks;
*DECK DECK=SYM$MISC_SERVICES_1FF EXPAND=TRUE
?? RIGHT := 110, LEFT := 1 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
MODULE sym$misc_services_1ff;

{
{  PURPOSE:
{     This module contains miscellaneous System Core requests which
{     must be run at the ring of the caller.
{

?? PUSH (LISTEXT := ON) ??
*copyc MLT$ERROR
*copyc MLT$FLOATING_LENGTH
*copyc MLT$OUTPUT_FORMAT
*copyc MLT$STRING_LENGTH
*copyc OST$HARDWARE_SUBRANGES
*copyc OSS$MAINFRAME_PAGED_LITERAL
*copyc pmk$keypoints
*copyc OSP$SYSTEM_ERROR

?? POP ??
?? SKIP := 4 ??
?? TITLE := '[XDCL, #GATE] pmp$zero_out_table' ??
{-----------------------------------------------------------------------------------------------------
{Name
{  pmp$zero_out_table
{Purpose
{  This routine can be called to zero out a block of storage.
{-------------------------------------------------------------------------------------------------------


  PROCEDURE [XDCL, #GATE] pmp$zero_out_table (p: ^cell;
        len: ost$byte_count);

    VAR
      zeros: [STATIC, READ, oss$mainframe_paged_literal] record
        case b: 0 .. 1 of
        = 0 =
          a: array [0 .. 31] of integer,
        = 1 =
          s: string (248),
        casend,
      recend := [0, [REP 32 of 0]],
      sp: record
        case b: 0 .. 1 of
        = 0 =
          p: ^string (248),
        = 1 =
          ringseg: 0 .. 0ffff(16),
          bytenum: ost$byte_count,
        casend,
      recend,
      sl: integer;

    #keypoint (osk$entry, 0, pmk$zero_out_table);
    sp.p := #LOC (p^);
    sl := len;
    WHILE sl >= 248 DO
      sp.p^ := zeros.s;
      sl := sl - 248;
      sp.bytenum := sp.bytenum + 248;
    WHILEND;
    IF sl > 0 THEN
      sp.p^ (1, sl) := zeros.s (1, sl);
    IFEND;

    #keypoint (osk$exit, 0, pmk$zero_out_table);

  PROCEND pmp$zero_out_table;
?? TITLE := ' [XDCL, #GATE] pmp$binary_to_ascii' , EJECT ??
?? FMT (FORMAT := OFF) ??
{--------------------------------------------------------------------------------------------------------
{Name:
{  pmp$binary_to_ascii
{Purpose:
{  Convert a binary number to its ASCII representation.
{Input:
{  I : number to be converted.
{  pos : rightmost char position for the converted string.
{        Leading zeroes on the string are not stored by this
{        routine.
{  base: base for ascii conversion (ie., 10 or 16 for decimal or hex
{Output:
{  st : string is updated with the ascii value of the string.
{--------------------------------------------------------------------------------------------------------
?? FMT (FORMAT := ON) ??

  PROCEDURE [XDCL, #GATE] pmp$binary_to_ascii (i: integer;
    VAR st: string ( * );
        base: 2 .. 16;
        pos: 1 .. 255);

    VAR
      k,
      l: integer,
      negative: boolean,
      p: 0 .. 255;

    k := i;
    p := pos;
    negative := k < 0;
    IF negative THEN
      k := - k;
    IFEND;


    REPEAT
      l := k MOD base;
      IF l <= 9 THEN
        st (p) := CHR (l + ORD ('0'));
      ELSE
        st (p) := CHR (l - 10 + ORD ('A'));
      IFEND;
      k := k DIV base;
      p := p - 1;
    UNTIL (k = 0) OR (p = 0);
    IF negative AND (p > 0) THEN
      st (p) := '-';
    IFEND;

  PROCEND pmp$binary_to_ascii;
?? TITLE, ' [XDCL, #GATE] pmp$binary_to_ascii_fit', EJECT ??
{--------------------------------------------------------------------------------------------------------
{ Name:
{   pmp$binary_to_ascii_fit
{ Purpose:
{   Convert a binary number to its ASCII representation.
{ Input:
{   int: number to be converted.
{   base: base for ascii conversion (ie., 10 or 16 for decimal or hex)
{   pos : rightmost char position for the converted string.
{         Leading zeroes on the string are not stored by this
{         routine.
{   length: maximum length of the string to be returned.
{ Output:
{   str: string is updated with the ascii value of the number.
{--------------------------------------------------------------------------------------------------------

  PROCEDURE [XDCL, #GATE] pmp$binary_to_ascii_fit
    (    int: integer;
         base: 2 .. 16;
         pos: 1 .. 255;
         length: 1 .. 255;
     VAR str: string ( * ));

    CONST
      k_pos = 253,
      max_length = 255;

    VAR
      digit: integer,
      exp: 0 .. 99,
      e_pos: 1 .. 255,
      negative: boolean,
      next_pos: 0 .. 255,
      number: integer,
      overflow: 1 .. 255,
      str_length: 1 .. 255,
      temp_str: string (255);


    next_pos := max_length;
    temp_str := ' ';
    number := int;
    negative := number < 0;
    IF negative THEN
      number := -number;
    IFEND;

    REPEAT
      digit := number MOD base;
      IF digit <= 9 THEN
        temp_str (next_pos) := CHR (digit + ORD ('0'));
      ELSE
        temp_str (next_pos) := CHR (digit - 10 + ORD ('A'));
      IFEND;
      number := number DIV base;
      next_pos := next_pos - 1;
    UNTIL (number = 0);

    IF negative THEN
      temp_str (next_pos) := '-';
      next_pos := next_pos - 1;
    IFEND;

    str_length := max_length - next_pos;
    IF str_length > length THEN
      overflow := str_length - length;
      str_length := length;
      IF  overflow <= 2 THEN
        temp_str (k_pos, 1) := 'K';
        IF overflow = 1 THEN
          str_length := str_length - 1;
        IFEND;
      ELSEIF overflow <= 7 THEN
        e_pos := next_pos + length - 1;
        exp := overflow + 2;
        temp_str (e_pos, 1) := 'E';
        temp_str (e_pos + 1, 1) := CHR (exp + ORD ('0'));
      ELSE
        e_pos := next_pos + length - 2;
        exp := overflow + 3;
        temp_str (e_pos, 1) := 'E';
        temp_str (e_pos + 2, 1) := CHR ((exp MOD 10) + ORD ('0'));
        temp_str (e_pos + 1, 1) := CHR ((exp DIV 10) + ORD ('0'));
      IFEND;
    IFEND;

    str (pos - str_length + 1, str_length) := temp_str (next_pos + 1, str_length);

  PROCEND pmp$binary_to_ascii_fit;

MODEND sym$misc_services_1ff;
*DECK DECK=SYM$MTR_INJECT_HARDWARE_FAULT EXPAND=TRUE
?? RIGHT := 110 ??
MODULE sym$mtr_inject_hardware_fault;

{ PURPOSE:
{   This module contains the procedures to inject various hardware faults on the 960.
{
{ DESIGN:
{   Special microcode is required to run with this utility that actually causes the
{   desired hardware fault.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$cpu_state_table
*copyc syt$rb_inject_hardware_fault
*copyc sye$system_conditions
?? POP ??
*copyc i#mtr_disable_traps
*copyc i#mtr_restore_traps
*copyc mtp$set_status_abnormal
*copyc syp$cause_hardware_faults
*copyc syv$enable_fault_injection
?? TITLE := 'syp$mtrj_inject_hardware_fault', EJECT ??

{ PURPOSE:
{   This procedure processes the monitor request to inject hardware faults in monitor mode.

  PROCEDURE [XDCL] syp$mtr_inject_hardware_fault
    (VAR request_block: syt$rb_inject_hardware_fault;
         cst_p: ^ost$cpu_state_table);

    VAR
      old_te: 0 .. 3;

    request_block.status.normal := TRUE;
    IF (cst_p^.ajlo <> 0) OR NOT syv$enable_fault_injection THEN
      mtp$set_status_abnormal ('SY', sye$unimplemented_request, request_block.status);
      RETURN;
    IFEND;

    IF NOT request_block.traps_enabled THEN
      i#mtr_disable_traps (old_te);
    IFEND;

    IF request_block.hardware_fault_request < syc$hfk_uf_null_function THEN
      syp$cause_hardware_faults (request_block.hardware_fault_request, request_block.rma,
            request_block.status.normal);
    ELSE

      {  Process utility functions.

      CASE request_block.hardware_fault_request OF
      = syc$hfk_uf_clear_sync_in_mm =

        {  Clear the synchronous bits in monitor mask of the exchange package of task making the request
        {  except for page fault.  Want to allow the task to page fault but processor will halt for
        {  other errors.

        cst_p^.xcb_p^.xp.monitor_mask := cst_p^.xcb_p^.xp.monitor_mask -
              $ost$monitor_conditions [osc$detected_uncorrected_err, osc$not_assigned, osc$instruction_spec,
              osc$address_specification, osc$access_violation, osc$environment_spec,
              osc$invalid_segment_ring_0, osc$out_call_in_return];
      ELSE
        mtp$set_status_abnormal ('SY', sye$unimplemented_request, request_block.status);
      CASEND;
    IFEND;

    IF NOT request_block.traps_enabled THEN
      i#mtr_restore_traps (old_te);
    IFEND;

  PROCEND syp$mtr_inject_hardware_fault;
MODEND sym$mtr_inject_hardware_fault;
*DECK DECK=SYM$OUTWARD_CALLER EXPAND=TRUE
SYAOCA    IDENT
SYAOCA    alias     SYM$OUTWARD_CALLER
.
.
.
.------------------------------------------------------------------------
.
. NAME
.    SYP$OUTWARD_CALL
. PURPOSE
.    This procedure is used in the system core to do an outward call to
.    the entry point defined by the job template.
.        . no parameters are passed
.        . the current stack frame is POPed to eliminate active frames
.          and to reset TOS in the exchange package.
. CALLING SEQUENCE
.     PROCEDURE[xref] syp$outward_call (p: ^procedure
.        stack_p: ^cell
.        ring: 0 .. 15)
.------------------------------------------------------------------------
.
.
.  common decks follow: (asmregs, asmintf)
          list     0,0,0
*copyc OSA$BASIC_REGISTER_EQUATES
*copyc SYA$CYBIL_INTERFACE_PROCEDURES
          list     1,1,1
.
.
outcall   ALIAS    SYP$OUTWARD_CALL
outcall   procedur
proc      param    val,pointer
stack_p   param    val,pointer
ring      param    val,subrange,1
.
a_proc    areg     6               .Pointer to CBP.
a_stack   areg     7               .Pointer to stack for outward call.
x_ring    xreg     4               .Ring number for outward call.
.
.  Store a SFSA at the beginning of the stack. The SFSA is generated:
.     P, and A3 are obtained from the CBP of the procedure being called
.     A0, and A1 point to the beginning of the stack segment.
.     A2 is set to NIL.
.     UM is set equal to the live UM at entry to this procedure
.
.
          ploada   a_proc,proc     .Fetch pointer to CBP.
          ploada   a_stack,stack_p .Fetch pointer to stack segment.
          ploadx   x_ring,ring     .Fetch ring number for outward call.
.
          lbyts,6  x1,a_proc,x0,2  .Get pointer to CBP.
          insb     x1,x_ring,x0,2003(8)  .Insert ring number.
          lbyts,2  x2,a2,x0,0      .Get GLOBAL and LOCAL KEYS from PSA.P
          insb     x1,x2,x0,0017(8)  .Insert GLOBAL and LOCAL KEYS in P
          sx       x1,a_stack,0    .Store P in SFSA.
          cpyax    x1,a_stack      .Setup A0 and A1 in SFSA.
          insb     x1,x_ring,x0,2003(8)  .Insert ring number.
          sx       x1,a_stack,8    . Store A0.
          ente     x2,0130(16)     .Insert a frame descriptor for A0 - A3, No X.
          insb     x1,x2,x0,0017(8)
          sx       x1,a_stack,16   .Store A1.
          entl     x0,0E6(16)      .Read the User Mask.
          cpysx    x0,x0
          isom     x1,x0,2020(8),x0  .Build a NIL pointer.
          insb     x1,x0,x0,0017(8)  .Merge UM into NIL pointer word.
          sx       x1,a_stack,24   .Store A2 and User Mask.
          lbyts,6  x1,a_proc,x0,10 .Fetch binding section pointer.
          insb     x1,x_ring,x0,2003(8)  .Insert ring number.
          sx       x1,a_stack,32   .Store A3.
.
.  POP the current stack until beginning of stack is reached.
.
ocpop     pop
          brseg    x1,a2,a0,ocret  .Exit the loop if A2.seg <> A0.seg
          brreq    x0,x0,ocpop
.
. The following field definition is used to support the PSFSA instruction which is
. required for CYBER-2000 but is not available in the ASSEMBLER language yet.
. When it is available, replace the VFD line with the following line:
. ocret     psfsa                    .Purge the SFSA pushdown (CYBER-2000 only)
.
ocret     vfd,16   0701(16)        .Purge SFSA pushdown (CYBER-2000 only)
          cpyaa    a2,a_stack      .Set PSA to point to SFSA.
          return
.
          end
*DECK DECK=SYM$PROCESS_DEADSTART_COMMANDS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE System Core : Process Deadstart Commands' ??
MODULE sym$process_deadstart_commands;

{ PURPOSE:
{   This module contains the system core command processor to process system core commands during deadstart.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc avt$security_option_name
*copyc ave$duplicate_setso_command
*copyc ave$unknown_security_option
*copyc avt$security_option
*copyc bat$record_header_type
*copyc cme$physical_configuration_mgr
*copyc dsc$max_dcfile_length
*copyc dse$misc_ds_errors_part_a
*copyc dst$deadstart_condition
*copyc dmt$sc_flaw_command
*copyc oss$mainframe_paged_literal
*copyc ost$time
*copyc rat$installation_tape_values
*copyc syt$command_table_entry
*copyc syt$value_kinds
?? POP ??
*copyc clp$trimmed_string_size
*copyc dmp$store_sc_flaw_command
*copyc dpp$get_next_line
*copyc dpp$put_next_line
*copyc dsp$access_vcu_cda_data
*copyc dsp$change_date_time_info
*copyc dsp$change_secure_analysis
*copyc dsp$check_interval
*copyc dsp$check_password_for_inisd
*copyc dsp$fetch_boot_data
*copyc dsp$get_entry_from_ssr
*copyc dsp$process_setoi_command
*copyc dsp$process_setop_command
*copyc dsp$read_date_time_information
*copyc dsp$save_sys_status_current_ds
*copyc dsp$test_resource_requests
*copyc i#enable_traps
*copyc lgp$add_entry_to_system_log
*copyc osp$clear_mainframe_sig_lock
*copyc osp$set_mainframe_sig_lock
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc syp$crack_command
*copyc syp$binary_to_ascii
*copyc syp$display_deadstart_message
*copyc syp$fetch_system_constant
*copyc syp$get_token
*copyc syp$invoke_system_debugger
*copyc syp$process_deadstart_status
*copyc syp$store_system_constant
?? EJECT ??
*copyc avv$security_options
*copyc cmv$system_device_data
*copyc dmv$p_sc_flaw_commands
*copyc dmv$system_device_information
*copyc dpv$system_core_display
*copyc dsv$mainframe_type
*copyc dsv$sub_mainframe_type
*copyc osv$mainframe_wired_heap
*copyc osv$deadstart_phase
*copyc osv$os_defaults
*copyc osv$recover_system_set_phase
*copyc stv$system_set_name
*copyc syv$debug_control
*copyc syv$repeatable_command_p
*copyc syv$run_all_timestamp
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    cmv$use_installed_configuration: [XDCL, #GATE] boolean := TRUE,
    osv$configuration_prolog_name: [XDCL, #GATE] ost$string := [0, * ],
    osv$operator_intervention: [XDCL, #GATE] boolean := FALSE,
    rav$installation_tape_values: [XDCL, #GATE] rat$installation_tape_values := [ '', '', '', ''],
    syv$inhibit_core_cmd_logging: [XDCL, #GATE] boolean := FALSE,
    syv$reading_dcfile: [XDCL] boolean := FALSE,

    v$auto_mode_requested: boolean := FALSE,

    { This table defines the system core command names and the procedures used to process the command.

    v$command_table: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 17] OF syt$command_table_entry :=
         [['AUTO    ', 'AUTO                           ', FALSE, ^command_auto],
          ['DEFMSF  ', 'DEFINE_MS_FLAW                 ', FALSE, ^command_defmsf],
          ['DISSA   ', 'DISPLAY_SYSTEM_ATTRIBUTE       ', FALSE, ^command_dissa],
          ['DISTZ   ', 'DISPLAY_TIME_ZONE              ', FALSE, ^command_distz],
          ['INIDD   ', 'INITIALIZE_DEADSTART_DEVICE    ', FALSE, ^command_inisd],
          ['INISD   ', 'INITIALIZE_SYSTEM_DEVICE       ', FALSE, ^command_inisd],
          ['INITDD  ', 'INITDD                         ', FALSE, ^command_inisd], {delete at R.1.3.1?
          ['SETIT   ', 'SET_INSTALLATION_TAPE          ', FALSE, ^command_setit],
          ['SETOI   ', 'SET_OPERATION_INTERVAL         ', FALSE, ^dsp$process_setoi_command],
          ['SETOP   ', 'SET_OPERATION_PASSWORD         ', FALSE, ^dsp$process_setop_command],
          ['SETSA   ', 'SET_SYSTEM_ATTRIBUTE           ', FALSE, ^command_setsa],
          ['SETSO   ', 'SET_SECURITY_OPTION            ', FALSE, ^command_setso],
          ['SETTZ   ', 'SET_TIME_ZONE                  ', FALSE, ^command_settz],
          ['SYSDEBUG', 'SYSDEBUG                       ', FALSE, ^syp$invoke_system_debugger],
          ['TESRR   ', 'TEST_RESOURCE_REQUESTS         ', FALSE, ^dsp$test_resource_requests],
          ['USECP   ', 'USE_CONFIGURATION_PROLOG       ', FALSE, ^command_usecp],
          ['USEIC   ', 'USE_INSTALLED_CONFIGURATION    ', FALSE, ^command_useic]];

?? OLDTITLE ??
?? NEWTITLE := 'check_for_initialized_data', EJECT ??

{ PURPOSE:
{   This procedure checks that the time zone data and the System Operation Interval and Password data, on
{   China mainframes, on the CIP device is initialized.  If the data is garbaged or is not initialized,
{   then operator intervention will be forced.

  PROCEDURE check_for_initialized_data
    (VAR data_initialized: boolean);

    VAR
      local_status: ost$status,
      password_data: dst$vcu_password_data,
      password_data_seq_p: ^SEQ ( * ),
      time_zone_data: dst$vcu_time_zone_data,
      time_zone_data_seq_p: ^SEQ ( * );

    data_initialized := TRUE;

    time_zone_data_seq_p := #SEQ (time_zone_data);
    dsp$access_vcu_cda_data (dsc$vcu_read_access, dsc$vcu_time_zone_data, time_zone_data_seq_p,
          local_status);
    IF NOT local_status.normal AND (local_status.condition <> dse$read_invalid_time_zone) THEN
      syp$process_deadstart_status (' ', FALSE, local_status);
      osp$system_error ('Unable to read time zone data from CDA.', ^local_status);
    ELSEIF (local_status.condition = dse$read_invalid_time_zone) OR NOT time_zone_data.initialized THEN
      data_initialized := FALSE;
      dpp$put_next_line (dpv$system_core_display,
            'WARNING -- The time zone data is not initialized.  The operator must use the', local_status);
      dpp$put_next_line (dpv$system_core_display,
            '           SET_TIME_ZONE command to initialize the data.', local_status);
    ELSE
      osp$set_mainframe_sig_lock (osv$os_defaults.lock);
      osv$os_defaults.system_time_zone := time_zone_data.time_zone;
      osv$os_defaults.defaults_changed := TRUE;
      osp$clear_mainframe_sig_lock (osv$os_defaults.lock);
    IFEND;

    IF dsv$sub_mainframe_type = dsc$smt_china_mainframe THEN
      password_data_seq_p := #SEQ (password_data);
      dsp$access_vcu_cda_data (dsc$vcu_read_access, dsc$vcu_password_data, password_data_seq_p, local_status);
      IF NOT local_status.normal THEN
        syp$process_deadstart_status (' ', FALSE, local_status);
        osp$system_error ('Unable to read password data from CDA.', ^local_status);
      IFEND;
      IF NOT password_data.password_initialized THEN
        data_initialized := FALSE;
        dpp$put_next_line (dpv$system_core_display,
              'WARNING -- The Operation Password is not initialized.  The operator must use', local_status);
        dpp$put_next_line (dpv$system_core_display,
              '           the SET_OPERATION_PASSWORD command to initialize the data.', local_status);
      ELSEIF NOT password_data.interval_initialized THEN
        data_initialized := FALSE;
        dpp$put_next_line (dpv$system_core_display,
              'WARNING -- The Operation Interval is not initialized.  The operator must use', local_status);
        dpp$put_next_line (dpv$system_core_display,
              '           the SET_OPERATION_INTERVAL command to initialize the data.', local_status);
      IFEND;
    IFEND;

  PROCEND check_for_initialized_data;
?? OLDTITLE ??
?? NEWTITLE := 'command_auto', EJECT ??

{ PURPOSE:
{   This procedure disables operator intervention.

  PROCEDURE command_auto
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    status.normal := TRUE;

    v$auto_mode_requested := TRUE;
    osv$operator_intervention := FALSE;

  PROCEND command_auto;
?? OLDTITLE ??
?? NEWTITLE := 'command_defmsf', EJECT ??

{ PURPOSE:
{   This procedure is called from the system core command define_ms_flaw (defmsf).
{   It saves flaw commands for use later during system deadstart.
{       FORMAT: defmsf rvsn cylinder track sector

  PROCEDURE command_defmsf
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      defmsf_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 4] OF syt$parameter_descriptor :=
            [[TRUE,  1, 'RVSN    ', syc$name_value, * ],
             [TRUE,  2, 'CYLINDER', syc$integer_value, 0, 0, 0ffffffffffff(16)],
             [TRUE,  3, 'TRACK   ', syc$integer_value, 0, 0, 0ffffffffffff(16)],
             [TRUE,  4, 'SECTOR  ', syc$integer_value, 0, 0, 0ffffffffffff(16)]],
      pvt: ARRAY [1 .. 4] OF syt$parameter_value,
      sc_flaw_p: ^dmt$sc_flaw_command;

    status.normal := TRUE;
    syp$crack_command (defmsf_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [1].name (rmc$recorded_vsn_size+1, 1) <> ' ' THEN
      dpp$put_next_line (id, 'ERROR -- Recorded VSN contains more than 6 characters', status);
      RETURN;
    IFEND;

    PUSH sc_flaw_p;
    sc_flaw_p^.rvsn := pvt [1].name (1, rmc$recorded_vsn_size);
    sc_flaw_p^.phys_adrs.cylinder := pvt [2].int;
    sc_flaw_p^.phys_adrs.track := pvt [3].int;
    sc_flaw_p^.phys_adrs.sector := pvt [4].int;
    sc_flaw_p^.trk_specified := TRUE;
    sc_flaw_p^.sec_specified := TRUE;
    sc_flaw_p^.flaw_processed := FALSE;

    dmp$store_sc_flaw_command (sc_flaw_p);

  PROCEND command_defmsf;
?? OLDTITLE ??
?? NEWTITLE := 'command_dissa', EJECT ??

{ PURPOSE:
{   This procedure is called from the system core command display_system_attribute (dissa).
{   It displays values of system core constants during system deadstart.
{       FORMAT: dissa name

  PROCEDURE command_dissa
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      constant_value: integer,
      dissa_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 1] OF syt$parameter_descriptor :=
            [[TRUE,  1, 'NAME    ', syc$name_value, * ]],
      index: integer,
      output_string: string (60),
      pvt: ARRAY [1 .. 1] OF syt$parameter_value;

    status.normal := TRUE;
    syp$crack_command (dissa_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    index := 0;
    syp$fetch_system_constant (pvt [1].name, index, constant_value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    output_string := ' ';
    syp$binary_to_ascii (constant_value, output_string, 10, 22);
    syp$binary_to_ascii (constant_value, output_string, 16, 40);
    output_string (41, 4) := '(16)';
    output_string (23) := ',';
    dpp$put_next_line (id, output_string, status);

  PROCEND command_dissa;
?? OLDTITLE ??
?? NEWTITLE := 'command_distz', EJECT ??

{ PURPOSE:
{   This procedure is called from the system core command display_time_zone (distz).
{   It displays the time zone data stored in the VCU CDA sector.
{       FORMAT: distz

  PROCEDURE command_distz
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      date_time_information: dst$date_time_information,
      output_string: string (65),
      time_zone: ost$time_zone,
      time_zone_data: dst$vcu_time_zone_data,
      time_zone_data_seq_p: ^SEQ ( * );

    status.normal := TRUE;

    time_zone_data_seq_p := #SEQ (time_zone_data);
    dsp$access_vcu_cda_data (dsc$vcu_read_access, dsc$vcu_time_zone_data, time_zone_data_seq_p, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status (' ', FALSE, status);
      RETURN;
    IFEND;
    IF time_zone_data.initialized THEN
      time_zone := time_zone_data.time_zone;
    ELSE
      output_string := 'The time zone data is not initialized.';
      dpp$put_next_line (id, output_string, status);
      RETURN;
    IFEND;

    output_string := ' ';
    output_string (3, 8) := 'HOURS = ';
    syp$binary_to_ascii (time_zone.hours_from_gmt, output_string, 10, 14);
    output_string (15, 12) := ', MINUTES = ';
    syp$binary_to_ascii (time_zone.minutes_offset, output_string, 10, 30);
    output_string (31, 25) := ', DAYLIGHT SAVING TIME = ';
    IF time_zone.daylight_saving_time THEN
      output_string (56, 5) := 'TRUE.';
    ELSE
      output_string (56, 6) := 'FALSE.';
    IFEND;
    dpp$put_next_line (id, output_string, status);

  PROCEND command_distz;
?? OLDTITLE ??
?? NEWTITLE := 'command_inisd', EJECT ??

{ PURPOSE:
{   This procedure is called from the system core command initialize_system_device (inisd)
{   It is used during deadstart to initialize the system device.
{       FORMAT: inisd vsn rdf rss sysset

  PROCEDURE command_inisd
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      error_string: string (256),
      ignore: ost$status,
      inisd_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 4] OF syt$parameter_descriptor :=
            [[TRUE,  1, 'VSN     ', syc$name_value, * ],
             [FALSE, 2, 'RDF     ', syc$boolean_value, TRUE],
             [FALSE, 3, 'RSS     ', syc$name_value, * ],
             [FALSE, 4, 'SYSSET  ', syc$name_value, '       ']],
      line_received: boolean,
      operator_dialog_complete: boolean,
      operator_dialog_pdt:  [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 1] OF
            syt$parameter_descriptor :=
            [[TRUE,  1, 'YES/NO  ', syc$name_value, *]],
      operator_dialog_pvt: ARRAY [1 .. 1] OF syt$parameter_value,
      operator_input: string (80),
      output_string: string (80),
      output_string_size: integer,
      password_valid: boolean,
      pvt: ARRAY [1 .. 4] OF syt$parameter_value;

    status.normal := TRUE;
    IF NOT cmv$system_device_data [cmc$sdt_tape_device].specified THEN
      dpp$put_next_line (id, 'The INISD command is not allowed during a disk deadstart', status);
      RETURN;
    IFEND;

    IF syv$reading_dcfile THEN
      error_string (20, *) := 'WARNING -- The INISD command must be entered by an operator, not from a file.';
      dpp$put_next_line (id, error_string (20, 79), ignore);
      error_string (1, 19) := 'SysCore Cmd error: ';
      log_system_core_text (error_string);
      RETURN;
    IFEND;

    dsp$check_password_for_inisd (id, password_valid);
    IF NOT password_valid THEN
      RETURN;
    IFEND;

    IF (cmv$system_device_data [cmc$sdt_disk_device].channel_name (2,1) = 'C') AND
          (cmv$system_device_data [cmc$sdt_disk_device].unit_id.product_number = '  $895') THEN
      dpp$put_next_line (id,
            'WARNING -- NOS/VE can not determine if CIP resides on a device which is only', status);
      dpp$put_next_line (id,
            '          accessable to NOS/VE via a CIO channel.  The INISD command will', status);
      dpp$put_next_line (id,
            '          destroy CIP if it is present on the system device.  IF the second', status);
      dpp$put_next_line (id,
            '          access, to the device, is a NIO channel, you must redeadstart and', status);
      dpp$put_next_line (id,
            '          use the NIO channel to preserve CIP.', status);
    IFEND;

    syp$crack_command (inisd_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt [1].name (rmc$recorded_vsn_size+1, 1) <> ' ' THEN
      dpp$put_next_line (id, 'ERROR -- Recorded VSN contains more than 6 characters', status);
      RETURN;
    IFEND;

    stv$system_set_name := pvt [4].name;

    IF pvt[3].defined THEN
      IF (pvt[3].name = 'RSS') OR (pvt[3].name = 'RECOVER_SYSTEM_SET') THEN

        { Perform operator dialog to determine if recorded vsn for system device is correct.

        dpp$put_next_line (id, 'The VSN for the system disk unit must either be:', status);
        dpp$put_next_line (id, '  1) The same as it was when last initialized or ', status);
        dpp$put_next_line (id, '  2) Different from all other VSN''s in the current configuration', status);
        STRINGREP (output_string, output_string_size, 'Is ', pvt [1].name (1, rmc$recorded_vsn_size),
              ' correct for the current configuration (enter YES or NO)?');
        dpp$put_next_line (id, output_string (1, output_string_size) , status);

        operator_dialog_complete := false;
        /operator_dialog/
        REPEAT
          dpp$get_next_line (id, osc$wait, operator_input, line_received);
          dpp$put_next_line (id, operator_input, status);
          syp$crack_command (operator_dialog_pdt, operator_input, operator_dialog_pvt, status);
          IF NOT status.normal THEN
            dpp$put_next_line (id, 'Enter just YES or NO:  ', status);
            CYCLE /operator_dialog/;
          IFEND;
          IF operator_dialog_pvt [1].name = 'YES' THEN
            osv$recover_system_set_phase := osc$reinitialize_system_device;
            operator_dialog_complete := TRUE;
          ELSEIF operator_dialog_pvt [1].name = 'NO' THEN
            dpp$put_next_line (id, 'Reenter the INITIALIZE_SYSTEM_DEVICE command with a', status);
            dpp$put_next_line (id, 'unique VSN for the system disk unit.', status);
            RETURN;
          ELSE
            dpp$put_next_line (id, 'Enter either YES or NO:  ', status);
            CYCLE /operator_dialog/;
          IFEND;
        UNTIL operator_dialog_complete;

      ELSE
        dpp$put_next_line (id, 'ERROR -- Unknown value for parameter.', status);
        RETURN;
      IFEND;
    IFEND;

    dmv$system_device_recorded_vsn := pvt [1].name (1, rmc$recorded_vsn_size);
    dmv$retain_system_device_flaws := pvt [2].bool;

    osv$deadstart_phase := osc$installation_deadstart;
    dsp$save_sys_status_current_ds (dsc$ssr_sds_sdas_installation);

  PROCEND command_inisd;
?? OLDTITLE ??
?? NEWTITLE := 'command_setit', EJECT ??

{ PURPOSE:
{   This procedure is called from the system core command set_installation_tape (setit)
{   It is used during deadstart to enter the name of the tape containing products to be
{   installed and to enter the name of the file to which the packing list will be written.
{       FORMAT: setit packlist evsn rvsn type

  PROCEDURE command_setit
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      pvt: ARRAY [1 .. 4] OF syt$parameter_value,
      setit_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 4] OF syt$parameter_descriptor :=
            [[TRUE,  1, 'PACKLIST', syc$name_value, * ],
             [FALSE, 2, 'EVSN    ', syc$string_value, * ],
             [FALSE, 3, 'RVSN    ', syc$string_value, * ],
             [FALSE, 4, 'TYPE    ', syc$name_value, * ]];

    status.normal := TRUE;
    syp$crack_command (setit_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF pvt[1].name(1) = '''' THEN
      dpp$put_next_line (id, 'ERROR -- The PACKING_LIST parameter value must be of type name.',
            status);
      RETURN;
    IFEND;

    IF clp$trimmed_string_size (pvt [1].name) > 16 THEN
      dpp$put_next_line (id, 'ERROR -- The PACKING_LIST parameter can have a maximum of 16 characters.',
            status);
      RETURN;
    IFEND;

    IF (NOT pvt [2].defined) AND (NOT pvt [3].defined) THEN
      dpp$put_next_line (id, 'ERROR -- Either the EVSN or RVSN parameter must be entered.', status);
      RETURN;
    IFEND;

    IF (pvt [2].defined) AND (pvt [2].text.size > 6) THEN
      dpp$put_next_line (id, 'ERROR -- The EVSN parameter can have a maximum of 6 characters.', status);
      RETURN;
    IFEND;

    IF (pvt [3].defined) AND (pvt [3].text.size > 6) THEN
      dpp$put_next_line (id, 'ERROR -- The RVSN parameter can have a maximum of 6 characters.', status);
      RETURN;
    IFEND;

    IF (pvt [4].defined) AND (pvt [4].name <> 'MT9$1600') AND (pvt [4].name <> 'MT9$6250') AND
          (pvt [4].name <> 'MT18$38000') THEN
      dpp$put_next_line (id, 'ERROR -- The TYPE parameter must be MT9$1600, MT9$6250 or MT18$38000.',
            status);
      RETURN;
    IFEND;

    rav$installation_tape_values.packing_list := pvt [1].name;

    IF pvt [2].defined THEN
      rav$installation_tape_values.evsn := pvt [2].text.value (1, pvt [2].text.size);
    ELSE
      rav$installation_tape_values.evsn := '';
    IFEND;

    IF pvt [3].defined THEN
      rav$installation_tape_values.rvsn := pvt [3].text.value (1, pvt [3].text.size);
    ELSE
      rav$installation_tape_values.rvsn := '';
    IFEND;

    IF pvt [4].defined THEN
      rav$installation_tape_values.tape_type := pvt [4].name;
    ELSE
      rav$installation_tape_values.tape_type := '';
    IFEND;

  PROCEND command_setit;
?? OLDTITLE ??
?? NEWTITLE := 'command_setsa', EJECT ??

{ PURPOSE:
{   This procedure is called from the system core command set_system_attribute (setsa).
{   It updates values of system core constants during system deadstart.
{       FORMAT: setsa name value

  PROCEDURE command_setsa
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      pvt: ARRAY [1 .. 2] OF syt$parameter_value,
      setsa_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 2] OF syt$parameter_descriptor :=
            [[TRUE,  1, 'NAME    ', syc$name_value, * ],
             [TRUE,  2, 'VALUE   ', syc$integer_value, 0, 0, 0ffffffffffff(16)]];

    status.normal := TRUE;
    syp$crack_command (setsa_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    syp$store_system_constant (pvt [1].name, 0, pvt [2].int, status);

  PROCEND command_setsa;
?? OLDTITLE ??
?? NEWTITLE := 'command_setso', EJECT ??

{ PURPOSE:
{   This procedure is called from the system core command set_security_option (setso).  It is used to turn on
{   or off special security features.
{       FORMAT: setso name value
{               where name is a key of
{                           ALL
{                           CONSOLE_OPERATION_ONLY
{                           SECURE_ANALYSIS
{                           SECURITY_AUDIT
{
{                     value is a boolean indicating whether the option is
{                           to be turned on or off
{ DESIGN
{   When any security option is set either on or off it's associated "activated" and "specified" booleans are
{   set.  This is done to ensure that any security option is only set once per deadstart.

  PROCEDURE command_setso
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      message: string (80),
      message_length: integer,
      pvt: ARRAY [1 .. 2] OF syt$parameter_value,
      setso_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 2] OF syt$parameter_descriptor :=
            [[TRUE,  1, 'NAME    ', syc$name_value, * ],
             [TRUE,  2, 'VALUE   ', syc$boolean_value, TRUE]];

    status.normal := TRUE;
    syp$crack_command (setso_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    { If any security option has previously been specified then ALL is not allowed.

    IF pvt [1].name = 'ALL' THEN

      { Note: Any new security options must be added to this list.

      IF (avv$security_options [avc$vso_console_operation_only].specified OR
            avv$security_options [avc$vso_secure_analysis].specified OR
            avv$security_options [avc$vso_security_audit].specified) THEN
        osp$set_status_abnormal ('AV', ave$duplicate_setso_command,
              'SET_SECURITY_OPTION has already been issued for one or more options.', status);
      ELSE
        avv$security_options [avc$vso_console_operation_only].active := pvt [2].bool;
        avv$security_options [avc$vso_console_operation_only].specified := TRUE;
        avv$security_options [avc$vso_secure_analysis].active := pvt [2].bool;
        avv$security_options [avc$vso_secure_analysis].specified := TRUE;
        avv$security_options [avc$vso_security_audit].active := pvt [2].bool;
        avv$security_options [avc$vso_security_audit].specified := TRUE;
      IFEND;
    ELSEIF pvt [1].name = avc$console_operation_only THEN
      IF NOT avv$security_options [avc$vso_console_operation_only].specified THEN
        avv$security_options [avc$vso_console_operation_only].active := pvt [2].bool;
        avv$security_options [avc$vso_console_operation_only].specified := TRUE;
      ELSE
        STRINGREP (message, message_length, 'SET_SECURITY_OPTION has already been issued for ',
              pvt [1].name (1, clp$trimmed_string_size (pvt [1].name)), '.');
        osp$set_status_abnormal ('AV', ave$duplicate_setso_command, message (1, message_length), status);
      IFEND;
    ELSEIF pvt [1].name = avc$secure_analysis THEN
      IF NOT avv$security_options [avc$vso_secure_analysis].specified THEN
        avv$security_options [avc$vso_secure_analysis].active := pvt [2].bool;
        avv$security_options [avc$vso_secure_analysis].specified := TRUE;
      ELSE
        STRINGREP (message, message_length, 'SET_SECURITY_OPTION has already been issued for ',
              pvt [1].name (1, clp$trimmed_string_size (pvt [1].name)), '.');
        osp$set_status_abnormal ('AV', ave$duplicate_setso_command, message (1, message_length), status);
      IFEND;
    ELSEIF pvt [1].name = avc$security_audit THEN
      IF NOT avv$security_options [avc$vso_security_audit].specified THEN
        avv$security_options [avc$vso_security_audit].active := pvt [2].bool;
        avv$security_options [avc$vso_security_audit].specified := TRUE;
      ELSE
        STRINGREP (message, message_length, 'SET_SECURITY_OPTION has already been issued for ',
              pvt [1].name (1, clp$trimmed_string_size (pvt [1].name)), '.');
        osp$set_status_abnormal ('AV', ave$duplicate_setso_command, message (1, message_length), status);
      IFEND;
    ELSE
      STRINGREP (message, message_length, pvt [1].name (1, clp$trimmed_string_size (pvt [1].name)),
            ' is not a valid security option.');
      osp$set_status_abnormal ('AV', ave$unknown_security_option, message (1, message_length), status);
    IFEND;

  PROCEND command_setso;
?? OLDTITLE ??
?? NEWTITLE := 'command_settz', EJECT ??

{ PURPOSE:
{   This procedure is called from the system core command set_time_zone (settz).
{   It updates time zone data stored in the VCU CDA sector.
{       FORMAT: settz hours minutes daylight

  PROCEDURE command_settz
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      date_time_information: dst$date_time_information,
      pvt: ARRAY [1 .. 3] OF syt$parameter_value,
      settz_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 3] OF syt$parameter_descriptor :=
            [[TRUE,  1, 'HOURS   ', syc$integer_value, 0, -12, 12],
             [FALSE, 2, 'MINUTES ', syc$integer_value, 0, -30, 30],
             [FALSE, 3, 'DAYLIGHT', syc$boolean_value, FALSE]],
      time_zone: ost$time_zone,
      time_zone_data: dst$vcu_time_zone_data,
      time_zone_data_seq_p: ^SEQ ( * );

    status.normal := TRUE;
    syp$crack_command (settz_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    time_zone.hours_from_gmt := pvt [1].int;
    time_zone.minutes_offset := pvt [2].int;
    time_zone.daylight_saving_time := pvt [3].bool;

    time_zone_data.initialized := TRUE;
    time_zone_data.time_zone := time_zone;
    time_zone_data_seq_p := #SEQ (time_zone_data);
    dsp$access_vcu_cda_data (dsc$vcu_write_access, dsc$vcu_time_zone_data, time_zone_data_seq_p, status);
    IF NOT status.normal THEN
      syp$process_deadstart_status (' ', FALSE, status);
      RETURN;
    IFEND;

  PROCEND command_settz;
?? OLDTITLE ??
?? NEWTITLE := 'command_usecp', EJECT ??

{ PURPOSE:
{   This procedure is called from the system core command use_configuration_prolog (usecp)
{   It specifies the name of the configuration prolog to use.
{       FORMAT: usecp name

  PROCEDURE command_usecp
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      index: integer,
      pvt: ARRAY [1 .. 1] OF syt$parameter_value,
      usecp_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 1] OF syt$parameter_descriptor :=
            [[TRUE,  1, 'NAME    ', syc$name_value, * ]];

    status.normal := TRUE;
    syp$crack_command (usecp_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    osv$configuration_prolog_name.value := pvt [1].name;
    osv$configuration_prolog_name.size := 1;

    FOR index := 1 TO #SIZE (pvt [1].name) DO
      IF pvt [1].name (index) = ' ' THEN
        RETURN;
      IFEND;
      osv$configuration_prolog_name.size := index;
    FOREND;

  PROCEND command_usecp;
?? OLDTITLE ??
?? NEWTITLE := 'command_useic', EJECT ??

{ PURPOSE:
{   This procedure is called from the system core command use_installed_configuration (useic)
{   It states whether or not to use the installed configuration.
{       FORMAT: useic boolean

  PROCEDURE command_useic
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

    VAR
      pvt: ARRAY [1 .. 1] OF syt$parameter_value,
      useic_pdt: [STATIC, READ, oss$mainframe_paged_literal] ARRAY [1 .. 1] OF syt$parameter_descriptor :=
            [[FALSE, 1, 'VALUE   ', syc$boolean_value, TRUE]];

    status.normal := TRUE;
    syp$crack_command (useic_pdt, text, pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    cmv$use_installed_configuration := pvt [1].bool;

  PROCEND command_useic;
?? OLDTITLE ??
?? NEWTITLE := 'log_system_core_text', EJECT ??

{ PURPOSE:
{   This procedure is called during system_core command processing to log text to the system log.

  PROCEDURE log_system_core_text
    (    text: string (*));

    VAR
      ignore_status: ost$status,
      log_time: ost$time,
      trim_size: integer;

    IF NOT syv$inhibit_core_cmd_logging THEN
      FOR trim_size := STRLENGTH (text) DOWNTO 1 DO
        IF text (trim_size) <> ' ' THEN
          lgp$add_entry_to_system_log (pmc$msg_origin_system, text (1, trim_size), log_time, ignore_status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;

  PROCEND log_system_core_text;
?? OLDTITLE ??
?? NEWTITLE := 'process_dcfile', EJECT ??

{ PURPOSE:
{   This procedure processes each line of the DCFILE.

  PROCEDURE process_dcfile
    (VAR force_operator_intervention: boolean);

    VAR
      bam_record_header_p: ^bat$record_header,
      dcfile_length_p: ^0 .. dsc$max_dcfile_length,
      dcfile_line_p: ^string (*),
      dcfile_seq_p: ^SEQ ( * ),
      save_dcfile_line_seq_p: ^SEQ ( * ),
      save_dcfile_line_p: ^string (*),
      save_length: 0 .. dsc$max_dcfile_length,
      status: ost$status;

    { Retrieve the dcfile data.

    PUSH dcfile_seq_p: [[REP dsc$max_dcfile_length OF cell]];
    RESET dcfile_seq_p;
    dsp$fetch_boot_data (dsc$dcfile_data, dcfile_seq_p);
    RESET dcfile_seq_p;
    NEXT dcfile_length_p IN dcfile_seq_p;
    IF dcfile_length_p^ = 0 THEN
      force_operator_intervention := TRUE;
      dpp$put_next_line (dpv$system_core_display,
            'WARNING -- The DCFILE was either NOT specified OR NOT found on the deadstart', status);
      dpp$put_next_line (dpv$system_core_display,
            '           device.  Operator must enter the DCFILE commands at the console.', status);
      RETURN;
    IFEND;

    PUSH save_dcfile_line_seq_p: [[REP dsc$max_dcfile_length OF cell]];
    syv$reading_dcfile := TRUE;

   /process_the_dcfile/
    WHILE dcfile_length_p^ >= #SIZE (bat$record_header) DO
      NEXT bam_record_header_p IN dcfile_seq_p;
      dcfile_length_p^ := dcfile_length_p^ - #SIZE (bam_record_header_p^);
      IF dcfile_length_p^ < bam_record_header_p^.length THEN
        EXIT /process_the_dcfile/;
      IFEND;

      IF bam_record_header_p^.length > 0 THEN
        IF bam_record_header_p^.header_type = bac$start_record THEN
          RESET save_dcfile_line_seq_p;
          save_length := 0;

          { Concatenate any broken "bam records".

         /concatenate_the_line/
          WHILE TRUE DO
            IF bam_record_header_p^.length > 0 THEN
              NEXT save_dcfile_line_p: [bam_record_header_p^.length] IN save_dcfile_line_seq_p;
              NEXT dcfile_line_p: [bam_record_header_p^.length] IN dcfile_seq_p;
              dcfile_length_p^ := dcfile_length_p^ - #SIZE (dcfile_line_p^);
              save_length := save_length + bam_record_header_p^.length;
              save_dcfile_line_p^ := dcfile_line_p^;
            IFEND;
            IF bam_record_header_p^.header_type = bac$end_record THEN
              EXIT /concatenate_the_line/;
            IFEND;
            IF dcfile_length_p^ < #SIZE (bam_record_header_p^) THEN
              EXIT /process_the_dcfile/;
            IFEND;
            NEXT bam_record_header_p IN dcfile_seq_p;
            dcfile_length_p^ := dcfile_length_p^ - #SIZE (bam_record_header_p^);
          WHILEND /concatenate_the_line/;
          RESET save_dcfile_line_seq_p;
          NEXT dcfile_line_p: [save_length] IN save_dcfile_line_seq_p;

        ELSE
          NEXT dcfile_line_p: [bam_record_header_p^.length] IN dcfile_seq_p;
          dcfile_length_p^ := dcfile_length_p^ - #SIZE (dcfile_line_p^);
        IFEND;

        dpp$put_next_line (dpv$system_core_display, dcfile_line_p^, status);
        syp$process_command_line (dcfile_line_p^, NIL, dpv$system_core_display, status);
        IF v$auto_mode_requested THEN
          v$auto_mode_requested := FALSE;
          EXIT /process_the_dcfile/;
        IFEND;
      IFEND;
    WHILEND /process_the_dcfile/;
    syv$reading_dcfile := FALSE;

  PROCEND process_dcfile;
?? OLDTITLE ??
?? NEWTITLE := 'syp$process_command_line', EJECT ??

{ PURPOSE:
{   This procedure processes a system core command line.  System core commands are subject to the following
{   restrictions:
{     . one command per command line
{     . no continuation lines are permitted
{     . positional parameters only
{     . parameters separated by comma and/or blank(s)

  PROCEDURE [XDCL] syp$process_command_line
    (    text: string ( * );
         aux_command_table_p: ^ARRAY [1 .. * ] OF syt$command_table_entry;
         window: dpt$window_id;
     VAR status: ost$status);

    VAR
      error_string: string (128),
      ignore: ost$status,
      index: integer,
      system_core_cmd_error_string: string (256),
      token: ost$string,
      token_index: 0 .. 255;

    status.normal := TRUE;
    system_core_cmd_error_string := 'SysCore Cmd error: ';

    { Log the command to the system log.

    log_system_core_text (text);

    { Get the command name from the command line.

    token_index := 1;
    syp$get_token (text, TRUE {upper_case}, token_index, token, status);
    IF NOT status.normal THEN
      dpp$put_next_line (window, 'WARNING -- Invalid command.', ignore);
      system_core_cmd_error_string (20, *) := 'WARNING -- Invalid command.';
      log_system_core_text (system_core_cmd_error_string);
      RETURN;
    IFEND;
    IF token.size = 0 THEN
      RETURN;
    IFEND;

    { Scan the aux command table for the command name and call the command processor.

    IF aux_command_table_p <> NIL THEN
      FOR index := LOWERBOUND (aux_command_table_p^) TO UPPERBOUND (aux_command_table_p^) DO
        IF (token.value (1, token.size) = aux_command_table_p^ [index].short_name) OR
              (token.value (1, token.size) = aux_command_table_p^ [index].long_name) THEN
          aux_command_table_p^ [index].proc_p^ (text (token_index, * ), window, status);
          IF NOT status.normal THEN
            error_string := 'WARNING -- Returned abnormal status from command ';
            error_string (50, *) := token.value (1, token.size);
            dpp$put_next_line (window, error_string (1, token.size + 50), ignore);
            system_core_cmd_error_string (20, *) := error_string (1, token.size + 50);
            log_system_core_text (system_core_cmd_error_string);
            error_string := 'ERROR -- ';
            error_string (10, *) := status.text.value (2, status.text.size - 1);
            dpp$put_next_line (window, error_string (1, status.text.size + 9), ignore);
            system_core_cmd_error_string (20, *) := error_string (1, status.text.size + 9);
            log_system_core_text (system_core_cmd_error_string);
          ELSEIF aux_command_table_p^ [index].repeatable_command THEN
            IF syv$repeatable_command_p <> NIL THEN
              FREE syv$repeatable_command_p IN osv$mainframe_wired_heap^;
            IFEND;
            ALLOCATE syv$repeatable_command_p: [STRLENGTH (text)] IN osv$mainframe_wired_heap^;
            syv$repeatable_command_p^ := text;
          IFEND;
          RETURN;
        IFEND;
      FOREND;
    IFEND;

    { Scan the command table for the command name and call the command processor.

    FOR index := LOWERBOUND (v$command_table) TO UPPERBOUND (v$command_table) DO
      IF (token.value (1, token.size) = v$command_table [index].short_name) OR
            (token.value (1, token.size) = v$command_table [index].long_name) THEN
        v$command_table [index].proc_p^ (text (token_index, * ), window, status);
        IF NOT status.normal THEN
          error_string := 'ERROR -- ';
          error_string (10, *) := status.text.value (1, status.text.size);
          dpp$put_next_line (window, error_string (1, status.text.size + 10), ignore);
          system_core_cmd_error_string (20, *) := error_string (1, status.text.size + 10);
          log_system_core_text (system_core_cmd_error_string);
        IFEND;
        RETURN;
      IFEND;
    FOREND;

    dpp$put_next_line (window, 'WARNING -- Invalid command name', ignore);
    log_system_core_text ('WARNING -- Invalid command name');

  PROCEND syp$process_command_line;
?? OLDTITLE ??
?? NEWTITLE := 'syp$process_core_commands', EJECT ??

{ PURPOSE:
{   This procedure is called during deadstart (and by debug if system debug is active) to process
{   commands from the operator.

  PROCEDURE [XDCL] syp$process_core_commands
    (    window: dpt$window_id;
         quit_command: string ( * );
         aux_command_table_p: ^ARRAY [1 .. * ] OF syt$command_table_entry;
     VAR status: ost$status);

    VAR
      ignore: ost$status,
      line_received: boolean,
      output_line: string (256),
      text: string (70),
      token: ost$string,
      token_index: 0 .. 255;

    status.normal := TRUE;

   /scan_command_table/
    WHILE TRUE DO
      REPEAT
        dpp$get_next_line (window, osc$wait, text, line_received);
      UNTIL text <> ' ';

      output_line := ' ';
      output_line (3, *) := text;
      dpp$put_next_line (window, output_line (1, (#SIZE (text) + 2)), ignore);

      token_index := 1;
      syp$get_token (text, TRUE {upper_case}, token_index, token, status);
      IF NOT status.normal THEN
        dpp$put_next_line (window, 'ERROR -- Invalid command, enter valid command.', ignore);
        CYCLE /scan_command_table/;
      IFEND;
      IF token.value (1, token.size) = quit_command THEN
        token_index := token.size + 1;
        syp$get_token (text, TRUE {upper_case}, token_index, token, status);
        IF NOT status.normal THEN
          dpp$put_next_line (window, 'WARNING -- Invalid parameter.', ignore);
        ELSEIF (token.size <> 0) AND (token.value (1, token.size) = 'ALL') THEN
          syv$run_all_timestamp := #FREE_RUNNING_CLOCK (0);
        IFEND;
        output_line := text;
        output_line (#SIZE (text) + 1, *) := ' "End System_Core_Commands/SYSDEBUG session"';
        log_system_core_text (output_line (1, #SIZE (text) + 44));
        EXIT /scan_command_table/;
      IFEND;

      syp$process_command_line (text, aux_command_table_p, window, status);
      IF v$auto_mode_requested THEN
        v$auto_mode_requested := FALSE;
        EXIT /scan_command_table/;
      IFEND;
    WHILEND /scan_command_table/;

  PROCEND syp$process_core_commands;
?? OLDTITLE ??
?? NEWTITLE := 'syp$process_deadstart_commands', EJECT ??

{ PURPOSE:
{   This procedure is called very early in system deadstart to process system core commands from the
{   deadstart device (dcfile) or the operator.  Prior to calling this routine the following must be true:
{     .  Memory manager must be initialized to the point that a page fault for a new page of an existing
{        segment is allowed.
{     .  Mainframe heaps must be initialized so that new tables can be ALLOCATED.
{   The system core commands allow the installation to specify their own values for sizes of system tables.

  PROCEDURE [XDCL] syp$process_deadstart_commands
    (VAR status: ost$status);

    VAR
      data_initialized: boolean,
      force_operator_intervention: boolean,
      ssr_entry: dst$ssr_entry,
      traps: 0 .. 3;

    status.normal := TRUE;
    syv$debug_control.debug_active := FALSE;
    force_operator_intervention := FALSE;
    syp$display_deadstart_message ('Processing deadstart commands ...');

    { Process the commands in the DCFILE.  If no DCFILE exists then operator intervention will be forced.

    process_dcfile (force_operator_intervention);

    check_for_initialized_data (data_initialized);
    force_operator_intervention := (force_operator_intervention OR NOT data_initialized);

    { Retrieve the operator intervention flag from the SSR.

    dsp$get_entry_from_ssr (dsc$ssr_operator_intervention, ssr_entry);
    osv$operator_intervention := (ssr_entry.whole_slot = 1);

    { Allow the operator to enter deadstart commands.

    IF osv$operator_intervention OR force_operator_intervention THEN
      REPEAT
        osv$operator_intervention := TRUE;
        syp$display_deadstart_message ('Enter system core commands:');
        syp$process_core_commands (dpv$system_core_display, 'GO  ', NIL, status);
        check_for_initialized_data (data_initialized);
      UNTIL data_initialized;
    IFEND;

    dsp$check_interval;

    { If debug breakpoints have been set then enable traps.

    IF syv$debug_control.debug_active THEN
      i#enable_traps (traps);
    IFEND;

    { If the secured analysis security option is not specified then default it to FALSE.

    IF NOT avv$security_options [avc$vso_secure_analysis].specified THEN
      avv$security_options [avc$vso_secure_analysis].active := FALSE;
    IFEND;

    { Set the secure analysis bit in the MRT.

    dsp$change_secure_analysis (avv$security_options [avc$vso_secure_analysis].active, status);

  PROCEND syp$process_deadstart_commands;
?? OLDTITLE ??
MODEND sym$process_deadstart_commands;
*DECK DECK=SYM$SERVICE_ROUTINES_113 EXPAND=TRUE
?? RIGHT := 110, LEFT := 1 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
MODULE sym$service_routines_113;

{
{  PURPOSE:
{     This module contains service routines that run in ring 1.
{

?? PUSH (LISTEXT := ON) ??
*copyc mmt$rb_lock_ring_1_stack
*copyc SYK$RETURN_JOBS_R1_RESOURCES
*copyc SYC$MONITOR_REQUEST_CODES
*copyc TMT$RB_EXIT_JOB
*copyc tmt$rb_cycle
*copyc jmt$system_supplied_name
*copyc jmt$user_supplied_name
*copyc osd$virtual_address
*copyc osv$job_fixed_heap
*copyc osv$mainframe_wired_heap
*copyc osv$special_aam_trap
*copyc pmk$keypoints
?? POP ??


{  External procedures referenced by this module.

*copyc I#CALL_MONITOR
*copyc cmp$check_foreign_io
*copyc MMP$INVALIDATE_SEGMENT
*copyc OSP$FREE_HEAP_PAGES
*copyc MMP$MFH_FOR_SEGMENT_MANAGER
*copyc MMP$VALIDATE_SEGMENT_NUMBER
*copyc OSP$FATAL_SYSTEM_ERROR
*copyc OSP$SYSTEM_ERROR
*copyc PMP$FIND_EXECUTING_TASK_XCB
*copyc pmp$get_job_names
*copyc syp$wait

{  Externally defined variables referenced by this module.

*copyc dmv$mainframe_recovered
*copyc jmv$jcb
*copyc mtv$request_table
*copyc mtv$cst0
*copyc syv$halt_on_exit_with_io


CONST
   number_of_entries = 512;


VAR
  syv$lock_tracer: [XDCL,#GATE] record
    next_i: integer,
    entry: ARRAY [0 .. number_of_entries-1] of record
     task: ost$global_task_id,
     caller: ^cell,
    recend,
  recend;




?? TITLE := 'SYP$RETURN_JOBS_R1_RESOURCES' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] syp$return_jobs_r1_resources;

*copy SYH$RETURN_JOBS_R1_RESOURCES

    VAR
      exit_job_rb: tmt$rb_exit_job,
      r1_stack_rb: mmt$rb_lock_ring_1_stack,
      sdt_entry_p: ^mmt$segment_descriptor,
      sdtx_entry_p: ^mmt$segment_descriptor_extended,
      status: ost$status,
      xcb_p: ^ost$execution_control_block;

{ Issue monitor request to change the ring 1 stack to a transient segment for the remainder of
{ job termination.

    r1_stack_rb.request_code := syc$rc_lock_ring_1_stack;
    REPEAT
      i#call_monitor (#LOC (r1_stack_rb), #SIZE (r1_stack_rb));
    UNTIL r1_stack_rb.status.normal;

{ Check the job's active io count; if it is non-zero the job must wait for the io to complete or the
{ system will crash later when it does.  Foreign PP io is the known case that allows job termination
{ with io still active.

    IF jmv$jcb.ijle_p^.active_io_page_count <> 0 THEN
      syp$job_exit_with_io;
    IFEND;

{  Issue 'exit_job' monitor request.  This request frees memory of remaining segments unique to
{  this job.  This returns the last of this job's resources.

    exit_job_rb.reqcode := syc$rc_exit_job;
    #keypoint (osk$exit, 0, pmk$task_begin_end);
    i#call_monitor (#LOC (exit_job_rb), #SIZE (exit_job_rb));
    osp$system_error ('Exit job monitor request returned.', NIL);

  PROCEND syp$return_jobs_r1_resources;

?? TITLE := 'syp$job_exit_with_io', EJECT ??

{ PURPOSE:
{   This procedure checks the job's active io count; if it is non-zero the job must wait for the io
{   to complete or the system will crash later when it does.  Foreign PP io is the known case that
{   allows job termination with io still active.  The system attribute, HALT_ON_EXIT_WITH_IO, determines
{   whether this situation should halt the system or cause the job to wait for the io to complete.
{   If the job waits and the io never completes, the job will be hung in memory.

  PROCEDURE [XDCL] syp$job_exit_with_io;

    CONST
      syc$wait_for_sio_delay = 3,  {thirty second delay for subsystem I/O}
      syc$wait_for_io_delay = 180; {18 minute delay to account for the
{                                   15 minute DAS diagnostics.
    VAR
      counter: integer,
      user_job_name: jmt$user_supplied_name,
      system_job_name: jmt$system_supplied_name,
      match: boolean,
      status: ost$status;

     pmp$get_job_names (user_job_name, system_job_name, status);
      match := FALSE;
{ If this job is associated with foreign I/O we can elimiate the possibility
{ of DAS diagnostics and terminate now.
     cmp$check_foreign_io (system_job_name, user_job_name, match);
      IF match THEN
{ Wait ten seconds for subsystem I/O to cleanup then terminate.
        counter := 0;
       WHILE (counter < syc$wait_for_sio_delay) AND (jmv$jcb.ijle_p^.active_io_page_count <> 0) DO
        syp$wait (10000);
        counter := counter + 1;
       WHILEND;
       RETURN;
      IFEND;


    counter := 0;
    IF syv$halt_on_exit_with_io THEN
      osp$system_error ('JOB EXIT WITH IO ACTIVE', ^status);
    ELSE
       WHILE (counter < syc$wait_for_io_delay) AND (jmv$jcb.ijle_p^.active_io_page_count <> 0) DO
        syp$wait (10000);
        counter := counter + 1;
       WHILEND;
    IFEND;

  PROCEND syp$job_exit_with_io;

?? TITLE := 'SYP$RESET_MAXIMUM_TIME' ??
?? EJECT ??
  PROCEDURE [XDCL, #GATE] syp$reset_maximum_time;

    VAR
      i: integer;

    FOR i := LOWERBOUND (mtv$request_table) TO UPPERBOUND (mtv$request_table) DO
      mtv$request_table [i].max_time := 0;
    FOREND;

  PROCEND syp$reset_maximum_time;

?? EJECT ??

PROCEDURE [XDCL, #GATE] osp$begin_system_activity;

  VAR
    xcb_p: ^ost$execution_control_block;


    pmp$find_executing_task_xcb (xcb_p);
    xcb_p^.system_table_lock_count := xcb_p^.system_table_lock_count + 256;

PROCEND osp$begin_system_activity;

?? EJECT ??

PROCEDURE [XDCL, #GATE] osp$end_system_activity;
TYPE
    psa_type = record
      fill: 0 .. 0ffff(16),
      p: ^cell,
      a0,a1: integer,
      fill2: 0 .. 0ffff(16),
      a2: ^psa_type,
    recend;

  VAR
    xcb_p: ^ost$execution_control_block,
    rb: tmt$rb_cycle,
    psa: ^psa_type,
    cycle_task: tmt$rb_cycle;


  pmp$find_executing_task_xcb (xcb_p);

{ Debug code.

  IF xcb_p^.system_table_lock_count < 256 THEN
    osp$system_error ('END_SYSTEM_ACTIVITY error', NIL);
  IFEND;

{ End debug code.

  xcb_p^.system_table_lock_count := xcb_p^.system_table_lock_count - 256;
  IF (xcb_p^.system_table_lock_count < 256) AND xcb_p^.system_give_up_cpu THEN
    rb.reqcode := syc$rc_cycle;
    rb.code := tmc$cyc_end_system_activity;
    psa := #previous_save_area();
    rb.p1 := psa^.p;
    IF psa^.a2 = NIL THEN
      rb.p2 := NIL;
    ELSE
      rb.p2 := psa^.a2^.p;
    IFEND;
    rb.lock_value := 0;
    i#call_monitor (#LOC (rb), #SIZE (rb));
  IFEND;

  IF xcb_p^.stlc_allocation AND (xcb_p^.system_table_lock_count < 256) THEN
    xcb_p^.stlc_allocation := FALSE;
    mmp$mfh_for_segment_manager;
  IFEND;

PROCEND osp$end_system_activity;

?? EJECT ??

PROCEDURE [XDCL, #GATE] osp$begin_subsystem_activity;

  VAR
    i: integer,
    one_back: ^ost$minimum_save_area,
    two_back: ^cell,
    xcb_p: ^ost$execution_control_block;

  pmp$find_executing_task_xcb (xcb_p);
   i := syv$lock_tracer.next_i;
   one_back := xcb_p^.xp.a2_previous_save_area;
   two_back := one_back^.a2_previous_save_area;
   syv$lock_tracer.next_i := (i + 1) MOD number_of_entries;
   syv$lock_tracer.entry [i].caller := two_back;
   syv$lock_tracer.entry [i].task := xcb_p^.global_task_id;


  IF ((xcb_p^.system_table_lock_count MOD 256) = 255) THEN
    osp$system_error ('SUBSYSTEM TABLE LOCK COUNT EXCEEDED', NIL);
  IFEND;
  xcb_p^.system_table_lock_count := xcb_p^.system_table_lock_count + 1;

PROCEND osp$begin_subsystem_activity;

?? EJECT ??
PROCEDURE [XDCL, #GATE] osp$begin_aam_activity_r1;

  VAR
   xcb_p: ^ost$execution_control_block;


  pmp$find_executing_task_xcb (xcb_p);
  xcb_p^.special_trap_count := xcb_p^.special_trap_count + 1;

PROCEND osp$begin_aam_activity_r1;

?? EJECT ??
PROCEDURE [XDCL, #GATE] osp$end_aam_activity_r1;

  VAR
   xcb_p: ^ost$execution_control_block;


  pmp$find_executing_task_xcb (xcb_p);
  xcb_p^.special_trap_count := xcb_p^.special_trap_count - 1;

PROCEND osp$end_aam_activity_r1;

?? EJECT ??
PROCEDURE [XDCL, #GATE] osp$test_aam_activity_r1;

  VAR
   xcb_p: ^ost$execution_control_block;

  pmp$find_executing_task_xcb (xcb_p);
  IF osv$special_aam_trap AND (xcb_p^.special_trap_count <> 0) THEN
    osp$fatal_system_error (' AAM trap code', NIL);
  IFEND;

PROCEND osp$test_aam_activity_r1;

?? EJECT ??
PROCEDURE [XDCL, #GATE] osp$end_subsystem_activity;

TYPE
    psa_type = record
      fill: 0 .. 0ffff(16),
      p: ^cell,
      a0,a1: integer,
      fill2: 0 .. 0ffff(16),
      a2: ^psa_type,
    recend;

  VAR
    psa: ^psa_type,
    rb: tmt$rb_cycle,
    xcb_p: ^ost$execution_control_block;


  pmp$find_executing_task_xcb (xcb_p);

{ Debug code.

  IF ((xcb_p^.system_table_lock_count MOD 256) = 0) THEN
    osp$system_error ('END_SUBSYSTEM_ACTIVITY error', NIL);
  IFEND;

{ End debug code.

  xcb_p^.system_table_lock_count := xcb_p^.system_table_lock_count - 1;
  IF (xcb_p^.system_table_lock_count <= 0) AND xcb_p^.subsystem_give_up_cpu THEN
    rb.reqcode := syc$rc_cycle;
    rb.code := tmc$cyc_end_system_activity;
    psa := #previous_save_area();
    rb.p1 := psa^.p;
    IF psa^.a2 = NIL THEN
      rb.p2 := NIL;
    ELSE
      rb.p2 := psa^.a2^.p;
    IFEND;
    rb.lock_value := 0;
    i#call_monitor (#LOC (rb), #SIZE (rb));
  IFEND;

PROCEND osp$end_subsystem_activity;

?? EJECT ??

 PROCEDURE [XDCL, #GATE] syp$cleanup_heap_pages;

  osp$free_heap_pages (osv$mainframe_wired_heap);

 PROCEND syp$cleanup_heap_pages;

 PROCEDURE [XDCL, #GATE] syp$set_mainframe_recovered (mainframe_recovered: boolean);
   dmv$mainframe_recovered := mainframe_recovered;
 PROCEND syp$set_mainframe_recovered;

MODEND sym$service_routines_113;
*DECK DECK=SYM$SERVICE_ROUTINES_133 EXPAND=TRUE
?? RIGHT := 110, LEFT := 1 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
MODULE sym$service_routines_133;


{
{  PURPOSE:
{     This module contains misc system core procs which execute in the
{     XLS133 library.
{

?? PUSH (LISTEXT := ON) ??
*copyc TMT$RB_CYCLE
*copyc TMT$RB_UPDATE_JOB_TASK_ENVIRO
*copyc OST$STATUS
*copyc OSC$PROCESSOR_DEFINED_REGISTERS
*copyc SYC$MONITOR_REQUEST_CODES
?? POP ??
{External procedures}

*copyc I#CALL_MONITOR
*copyc PMP$FIND_EXECUTING_TASK_XCB
?? EJECT ??

?? EJECT ??

  PROCEDURE [XDCL, #GATE] syp$set_process_interval_timer (pit_value:
    0 .. 7fffffff(16);
    VAR status: ost$status);

  VAR
    req_block: tmt$rb_update_job_task_enviro;

    status.normal := TRUE;
    req_block.reqcode := syc$rc_update_job_task_enviro;
    req_block.subcode := tmc$ujte_xp_register;
    req_block.register_id := osc$pr_process_interval_timer;
    req_block.pit_value := pit_value;
    i#call_monitor (#LOC(req_block), #SIZE(req_block));

  PROCEND syp$set_process_interval_timer;
MODEND sym$service_routines_133;

*DECK DECK=SYM$SYSTEM_CONSTANT_MANAGER EXPAND=TRUE
?? RIGHT := 110 ??
?? TITLE := 'System Constant Management' ??
MODULE sym$system_constant_manager;

{ PURPOSE:
{   This module contains procedures that allow the operator to fetch and
{   modify the values of system constants during deadstart or during system
{   operation.  The priviledge of modifying the constants is restricted to the
{   system job.

?? NEWTITLE := '  Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc cle$ecc_expression_result
*copyc cyc$max_string_size
*copyc dft$family_list
*copyc dst$rb_system_deadstart_status
*copyc jmc$maximum_constants
*copyc jmc$maximum_job_count
*copyc jmc$maximum_output_count
*copyc lgt$log_attribute_entry
*copyc mmt$page_map_offsets
*copyc mmt$page_queue_list
*copyc nac$namve_debug_mode
*copyc oss$mainframe_paged_literal
*copyc ost$global_task_id
*copyc ost$name
*copyc pmt$global_logs
*copyc syc$job_recovery_enabled
*copyc syc$monitor_request_codes
*copyc sye$command_processor_errors
?? POP ??
?? EJECT ??
*copyc dmp$fetch_debug_option_value
*copyc dmp$store_debug_option_value
{*copyc iop$fetch_debug_option_value
{copyc iop$store_debug_option_value
*copyc mmp$store_site_active_q_cnt_r1
*copyc osp$append_status_parameter
*copyc osp$check_for_desired_mf_class
*copyc osp$set_status_abnormal
*copyc osp$system_error
*copyc bav$force_direct_tape_io
*copyc bav$max_allowed_tape_block_size
*copyc bav$max_bytes_per_tape_io
*copyc bav$max_indirect_tape_block
*copyc bav$use_assign_pages_for_tape
*copyc cmv$acquire_pp_for_redundant_ch
*copyc cmv$enable_auto_reconfiguration
*copyc cmv$enable_head_shift_message
*copyc dfv$file_server_debug_enabled
*copyc dfv$file_server_info_enabled
*copyc dfv$job_recovery_enabled
*copyc dfv$maximum_client_job_lists
*copyc dfv$number_served_family_lists
*copyc dfv$task_queue_timeout_interval
*copyc dmv$permanent_file_overflow
*copyc dmv$recycle_device_log
*copyc dmv$temporary_file_overflow
*copyc dmv$test_recovery
*copyc dpv$enable_console_bell
*copyc dsv$automatic_pp_reload
*copyc dsv$automatic_system_restart
*copyc dsv$mainframe_type
*copyc dsv$unload_deadstart_tape
*copyc iov$enforce_read_priority
*copyc jmv$input_file_recovery_option
*copyc jmv$jcb
*copyc jmv$maximum_job_classes
*copyc jmv$maximum_known_jobs
*copyc jmv$maximum_known_outputs
*copyc jmv$maximum_service_classes
*copyc jmv$output_file_recovery_option
*copyc jmv$qfile_recovery_option
*copyc jmv$scan_idle_dispatch_interval
*copyc jmv$sched_memory_wait_factor
*copyc jmv$scheduler_wait_time
*copyc jmv$swap_jobs_in_long_wait
*copyc jmv$system_ajl_ordinal
*copyc jmv$system_ijl_ordinal
*copyc jsv$age_before_swap_percentage
*copyc jsv$age_jws_before_swap
*copyc jsv$enable_debug_code
*copyc jsv$enable_swap_file_statistics
*copyc jsv$halt_on_swapin_failure
*copyc jsv$free_working_set_on_swapout
*copyc jsv$maximum_pages_to_swap
*copyc jsv$max_pages_first_swap_task
*copyc jsv$max_time_swap_io_complete
*copyc jsv$max_time_swap_io_not_init
*copyc jsv$think_expiration_time
*copyc i#call_monitor
*copyc mmv$aggressive_aging_level
*copyc mmv$aging_algorithm
*copyc mmv$assign_multiple_pages
*copyc mmv$avail_modified_queue_max
*IF $variable(mmv$test_forced_use_cache_maps, declared) <> 'UNKNOWN'
*copyc mmv$benchmark_run
*ELSE
{ -------- Declarations for forcing the use of cache and maps omitted at compile time --------
*IFEND
*copyc mmv$disable_write_for_perf_meas
*copyc mmv$file_allocation_interval
*IF $variable(mmv$test_forced_use_cache_maps, declared) <> 'UNKNOWN'
*copyc mmv$force_use_of_cache_and_maps
*ELSE
{ -------- Declarations for forcing the use of cache and maps omitted at compile time --------
*IFEND
*copyc mmv$free_queue_threshold
*copyc mmv$gpql
*copyc mmv$jws_queue_age_interval
*copyc mmv$last_active_shared_queue
*copyc mmv$max_pages_no_file
*copyc mmv$min_avail_pages
*copyc mmv$multi_page_write
*copyc mmv$no_memory_buffering
*copyc mmv$periodic_call_interval
*copyc mmv$read_tu_options
*copyc mmv$shared_pages_in_jws
*copyc mmv$shared_queue_age_interval
*copyc mmv$write_aged_out_pages
*copyc mtv$halt_on_proc_malf
*copyc mtv$aborted_task_threshold
*copyc mtv$automatic_unstep_resume
*copyc mtv$halt_cpu_ring_number
*copyc mtv$halt_on_proc_malf
*copyc mtv$halt_on_cpu_timeout
*copyc mtv$processor_due_threshold
*copyc mtv$sys_core_init_complete
*copyc osv$special_aam_trap
*copyc syv$enable_heap_trace
*copyc syv$debugger_page_wait_lines
*copyc syv$dflt_debug_output_disposal
*copyc syv$enable_fault_injection
*copyc syv$mandatory_dualstate
*copyc syv$max_debug_output_lines
*copyc syv$nosve_internal_operations
*copyc syv$verify_heap_linkage
*copyc tmv$cycle_delay_time
*copyc tmv$dedicate_a_cpu_to_nos
*copyc tmv$halt_on_hung_task
*copyc tmv$max_idle_sit_value
*copyc tmv$timed_wait_not_queued

?? TITLE := '  Global Declarations Declared by this module', EJECT ??

  TYPE
    value_table_type = record
      deadstart_only: boolean,
      name: string (max_name_length),
      min,
      max: integer,
      case value_type: (v_integer, v_halfword, v_byte, v_boolean) of
      = v_integer =
        integer_p: ^integer,
      = v_halfword =
        halfword_p: ^0 .. 0ffffffff(16),
      = v_byte =
        byte_p: ^0 .. 255,
      = v_boolean =
        boolean_p: ^boolean,
      casend,
    recend;

  VAR
    avv$debug_accounting_validation: [XDCL, #GATE] boolean := FALSE,
    clv$command_statistics_enabled: [XDCL, #GATE] boolean := FALSE,
    clv$log_secure_parameters: [XDCL, #GATE] boolean := TRUE,
    cmv$free_trap: [XDCL, #GATE] boolean := FALSE,
    dmv$space_messages_to_console: [XDCL, #GATE] boolean := TRUE,
    dmv$trim_files: [XDCL, #GATE] boolean := TRUE,
    dmv$volume_class_kludge: [XDCL] boolean := FALSE,
    dpv$display_delay: [XDCL, #GATE] integer := 1000,
    dsv$display_deadstart_messages: [XDCL] boolean := TRUE,
    dsv$load_files: [XDCL, #GATE] boolean := FALSE,
    dsv$ignore_image: [XDCL] boolean := FALSE,
    ifv$telnet_connection_limit: [XDCL, #GATE] integer := 30000,
    iiv$condition_handler_trace: [XDCL, #GATE] boolean := false,
    iiv$interactive_wait_time: [XDCL, #GATE] integer := 60000000,
    iiv$output_option: [XDCL, #GATE] integer := 0,
    iiv$suspended_job_timeout: [XDCL, #GATE] integer := 180 * 60 * 1000,
    iov$unused_boolean: [XDCL, #GATE] boolean := TRUE,
    jmv$cluster_attach_job_enabled: [XDCL, #GATE] boolean := FALSE,
    jmv$delete_old_templates: [XDCL] boolean := FALSE,
    jmv$enable_queue_file_access: [XDCL, #GATE] boolean := FALSE,
    jmv$swap_file_allocation_size: [XDCL, #GATE] 0 .. 0ffffffff(16) := 262144,
    lgv$modify_log_segments: [XDCL, #GATE] boolean := TRUE,
    lov$enable_source_type_checking: [XDCL, #GATE] boolean := FALSE,
    lov$ignore_param_verification: [XDCL, #GATE] integer := 0,

{  Debug, define maximum memory that 180 will use.  This is a way of limiting the amount of memory NOS/VE will
{  use.  Can limit the memory less than defined upper bound.  Default to a value larger than existing memory
{  sizes.

    mmv$maximum_180_memory: [XDCL] integer := 1000000000000(16),
    mmv$maximum_write_span: [XREF] integer,
    mmv$page_skip_count: [XREF] integer,
    mmv$quick_sweep_interval: [XREF] integer,
    mmv$shadow_by_segnum: [XDCL, #GATE] boolean := TRUE,
    mmv$site_active_shared_queues: [XDCL] integer := 0,

{ Maximum segment length is no longer used by the OS. It must remain as a SETSA until release 1.6.1
{ because IM/DM uses it. As soon as they react to the change-this variable will be deleted.

    mmv$max_segment_length: [XDCL, #GATE] integer := 2147483647,
    mmv$temp_file_space_guard: [XDCL, #GATE] boolean := FALSE,
    mtv$mx_ajl_entries: [XDCL, #GATE] 0 .. 0ffffffff(16) := 100,
    mtv$mx_segments: [XDCL] 0 .. 0ffffffff(16) := 0,
    mtv$nos_cycle_threshold: [XREF] integer,
    mtv$scb_vector_sim_attribute: [XREF] 0 .. 255,
    nav$debug_mode: [XDCL, #GATE] 0 .. 0ff(16) := nac$no_debug,
    ofv$enable_user_displays: [XDCL, #GATE] boolean := FALSE,
    osv$catalog_name_security: [XDCL, #GATE] boolean := FALSE,
    osv$default_pit: [XDCL] integer := 7fffffff(16), {default value for PIT}
    osv$delete_unreconciled_files: [XDCL, #GATE] boolean := FALSE,
    osv$dump_when_debug: [XDCL] boolean := FALSE,
    osv$emergency_intervention: [XDCL, #GATE] boolean := FALSE,
    osv$enable_hyperchannel: [XDCL, #GATE] boolean := FALSE,
    osv$reconcile_permanent_files: [XDCL, #GATE] boolean := FALSE,
    osv$recover_at_all_costs: [XDCL] boolean := FALSE,
    osv$reorganize_permanent_files: [XDCL, #GATE] boolean := FALSE,
    osv$validate_active_sets: [XDCL, #GATE] boolean := FALSE,
    osv$validate_permanent_files: [XDCL, #GATE] boolean := FALSE,
    osv$verify_missing_volumes: [XDCL, #GATE] boolean := TRUE,
    pfv$binary_catalog_search: [XDCL, #GATE] boolean := TRUE,
    pfv$debug_catalog_access: [XDCL, #GATE] boolean := FALSE,
    pfv$restrict_catalog_flushing: [XDCL, #GATE] boolean := TRUE,
    pfv$sort_catalog_object_list: [XDCL, #GATE] boolean := FALSE,
    pfv$verify_catalog_heaps: [XDCL, #GATE] boolean := FALSE,
    pmv$debug_logging_enabled: [XDCL, #GATE] boolean := FALSE,
    pmv$constrain_meape_segments: [XDCL, #GATE] boolean := FALSE,
    rav$deadstart_intervention: [XDCL, #GATE] boolean := FALSE,
    rav$development_deadstart: [XDCL, #GATE] boolean := FALSE,
    rav$network_activation: [XDCL, #GATE] boolean := TRUE,
    rav$system_activation: [XDCL, #GATE] boolean := TRUE,
    syv$detailed_critical_displays: [XDCL, #GATE] boolean := FALSE,
    syv$halt_on_exit_with_io: [XDCL, #GATE] boolean := FALSE,
    syv$setsa_job_recovery_option: [XDCL] integer := syc$jre_enabled,
    nav$disable_network_relays: [XDCL, #GATE] boolean := FALSE,
    syv$user_templates: [XREF] boolean,
    tmv$display_actual_priority: [XDCL, #GATE] boolean := FALSE,
    dmv$pf_sparse: [XREF] boolean,
    syv$clone_enabled: [XREF] boolean,
    endvar: char;


{ NOTE:
{   The following variable cannot be set via the set_system_attribute command.
{   It is set via the change_secure_logging command during system operation.

*copyc clc$change_secure_logging_name

  VAR
    clv$secure_logging_activated: [XDCL, #GATE] boolean := FALSE;


{ NOTE:
{   The following variable cannot be set via the set_system_attribute command.
{   It is set via the set_validation_level command during system operation.

*copyc avc$validation_level_const_name

  VAR
    avv$validation_level: [XDCL, #GATE] 0 .. 255 := 0;



{ NOTE:
{   The following variable cannot be set via the set_system_attribute command.
{   It is set via the activate_system_logging and deactivate_system_logging
{   commands during system operation.

*copyc clc$system_logging_active_name

  VAR
    clv$system_logging_activated: [XDCL, #GATE] boolean := FALSE;


{ Define values for the segment offset array.  This array defines page offsets
{ for the beginning of some special segments.  These segments do NOT start at
{ offset zero.  This is an attempt to reduce thrashing in the page map.  This
{ array is defined here because it may need to be model dependent.

  VAR
    mmv$page_map_offsets: [XDCL, #GATE] mmt$page_map_offsets := [0, 0, 0, 0, 0];


{ Define the information needed to control the sizes of the logs and the actions taken by the system when the
{ log becomes full.  This variable is declared here instead of in LGM$GLOBAL_LOG_MANAGER because of a CYBIL
{ bug.  NOTE:  The system log has a preallocation size that is 10 time the default preallocation size because
{ it gets more information recorded in it than the other logs.

?? FMT (FORMAT := OFF) ??
  VAR
    lgv$global_log_attributes: [XDCL, oss$mainframe_pageable] array [pmt$global_logs] of
          lgt$log_attribute_entry := [
{ account_log }     [FALSE, (lgc$maximum_log_size DIV 1000000), lgc$default_preallocation_size],
{ engineering_log } [FALSE, (lgc$maximum_log_size DIV 1000000), lgc$default_preallocation_size],
{ history_log }     [FALSE, (lgc$maximum_log_size DIV 1000000), lgc$default_preallocation_size],
{ security_log }    [FALSE, (lgc$maximum_log_size DIV 1000000), lgc$default_preallocation_size],
{ statistics_log }  [FALSE, (lgc$maximum_log_size DIV 1000000), lgc$default_preallocation_size],
{ system_log }      [FALSE, (lgc$maximum_log_size DIV 1000000), (lgc$default_preallocation_size * 10)]];

  VAR
    lgv$critical_log_attributes: [XDCL, oss$mainframe_pageable] lgt$log_attribute_entry := [FALSE,
          (lgc$maximum_log_size DIV 1000000), lgc$default_preallocation_size];

?? FMT (FORMAT := ON) ??

  VAR
    dmv$maximum_allocation_size: [XREF] integer,
    dmv$quick_deadstart: [XREF] boolean,
    jmv$max_think_time: [XREF] integer,
    jmv$min_think_time: [XREF] integer,
    jsv$enable_swap_resident: [XREF] boolean,
    jsv$enable_swap_resident_no_io: [XREF] boolean,
    jsv$write_stale_pages: [XREF] boolean,
    mlv$wire_mli_tables: [XREF] boolean,
    mmv$advise_in_aio_limit: [XREF] integer,
    mmv$age_interval_ceiling: [XREF] 0 .. 255,
    mmv$age_interval_floor: [XREF] 0 .. 255,
    mmv$check_queues: [XREF] integer,
    mmv$maxws_aio_threshold: [XREF] integer,
    mmv$swapping_aic: [XREF] integer,
    osv$debug: [XREF] array [0..15] of integer,
    osv$default_sit_value: [XREF] integer,
    osv$disk_fault_simulation: [XREF] boolean,
    osv$error_idle_halt: [XREF] boolean,
    osv$keypoint_enable: [XREF] integer,
    osv$trap_task_errors: [XREF] boolean,
    sfv$dynamic_file_space_limits: [XREF] boolean,
    syv$allow_jr_test: [XREF] boolean,
    syv$debug_job_recovery: [XREF] boolean,
    syv$system_job_multiprocessing: [XREF] boolean,
    tmv$long_wait_force_swap_time: [XREF] integer,
    tmv$long_wait_swap_time: [XREF] integer;

?? NEWTITLE := '    System Constant Definition Table', EJECT ??

  CONST
    documented_attributes = 82,
    max_name_length = 31,
*IF $variable(mmv$test_forced_use_cache_maps, declared) <> 'UNKNOWN'
    value_table_length = 214;
*ELSE
    value_table_length = 212;
*IFEND

{  Note: The multiple shared queues feature introduces multiple shared queues and it also introduces the
{        Manage Memory Utility.  The memory variables that it manages are also controlled by the
{        SET_SYSTEM_ATTRIBUTE command.  So that users do not have to immediately change to use of the
{        MMU, the old SETSA commands are being left in place.  For the attribute MINIMUM_SHARED_WORKING_SET
{        the field controlled is to be mmv$gpql[mmc$pq_shared_task_service].minimum].  To make this
{        change we need to change the appropriate entry in the value_table.  However, this can not be done
{        because the object library generator will generate incorrect code.  A workaround has been coded.
{        To remove the work-around, delete these comments, all lines referencing the
{        VAR temp_workaround_min_sws and change the appropriate value_table entry.

  VAR  temp_workaround_min_sws : [STATIC]  0..0ffffffff(16) := 0;


{ The system attribute table is divided into two sections:  DOCUMENTED attributes and UNDOCUMENTED
{ attributes.  Undocumented attributes are used by development for debugging and to sometimes turn
{ features on or off.  When adding new attributes use a 'dummy' in the correct section of the table.
{ Move the dummy to KEEP THE TABLE IN ALPHABETICAL ORDER!  The attribute must be in the correct section
{ of the table for display purposes.  The ALL option on the DISPLAY_SYSTEM_ATTRIBUTE command displays
{ all DOCUMENTED attributes.  The EVERYTHING is for internal use; it displays both documented and
{ undocumented attributes.
{ NOTE:  When all the 'dummies' are used in the documented section, the module constant, documented_attibutes
{ must be changed.  That constant controls the ALL display.
{ If the table needs to expand, change the module constant, value_table_length.
{ DOCUMENTED attributes are in the first section of the table.

  VAR
    value_table: [READ, oss$mainframe_paged_literal] array [1 .. value_table_length] of value_table_type := [
{   } [FALSE, 'ABORTED_TASK_THRESHOLD', 0, 7FFFFFFFFFFF(16), v_integer, ^mtv$aborted_task_threshold],
{   } [FALSE, 'ACCOUNT_LOG_CRITICAL', 0, 1, v_boolean, ^lgv$global_log_attributes [pmc$account_log].critical],
{   } [FALSE, 'ACCOUNT_LOG_MAXIMUM_SIZE', 1, 150, v_byte,
            ^lgv$global_log_attributes [pmc$account_log].maximum_size],
{   } [FALSE, 'ACQUIRE_PP_FOR_REDUNDANT_CH', 0, 1, v_boolean, ^cmv$acquire_pp_for_redundant_ch],
{   } [FALSE, 'AGE_BEFORE_SWAP_PERCENTAGE', 0, 90, v_integer, ^jsv$age_before_swap_percentage],
{   } [FALSE, 'AGE_JWS_BEFORE_SWAP', 0, 1, v_boolean, ^jsv$age_jws_before_swap],
{   } [FALSE, 'AUTO_RECONFIGURATION', 0, 1, v_boolean, ^cmv$enable_auto_reconfiguration],
{   } [FALSE, 'AUTOMATIC_PP_RELOAD', 0, 1, v_boolean, ^dsv$automatic_pp_reload.enabled],
{   } [FALSE, 'AUTOMATIC_SYSTEM_RESTART', 0, 1, v_boolean, ^dsv$automatic_system_restart],
{   } [FALSE, 'AUTOMATIC_UNSTEP_RESUME', 0, 1, v_boolean, ^mtv$automatic_unstep_resume],
{   } [FALSE, 'AVAILABLE_MODIFIED_QUEUE_MAX', 0, 65535, v_integer, ^mmv$avail_modified_queue_max],
{   } [FALSE, 'CHECK_IDLE_DISPATCHING_INTERVAL', 1000, 1000000000, v_integer,
            ^jmv$scan_idle_dispatch_interval],
{   } [FALSE, 'CLUSTER_ATTACH_JOB_ENABLED', 0, 1, v_boolean, ^jmv$cluster_attach_job_enabled],
{   } [FALSE, 'COMMAND_STATISTICS_ENABLED', 0, 1, v_boolean, ^clv$command_statistics_enabled],
{   } [FALSE, 'CONSTRAIN_MEAPE_SEGMENTS', 0, 1, v_boolean, ^pmv$constrain_meape_segments],
{   } [FALSE, 'CRITICAL_WINDOW_LOG_CRITICAL', 0, 1, v_boolean,
            ^lgv$critical_log_attributes.critical],
{   } [FALSE, 'CRITICAL_WINDOW_LOG_MAX_SIZE', 1, 150, v_byte,
            ^lgv$critical_log_attributes.maximum_size],
{   } [FALSE, 'DEDICATE_A_CPU_TO_NOS', 0, 1, v_boolean, ^tmv$dedicate_a_cpu_to_nos],
{   } [FALSE, 'DEFAULT_DEBUG_OUTPUT_DISPOSAL', 0, 3, v_byte, ^syv$dflt_debug_output_disposal.byte],
{   } [TRUE,  'DELETE_OLD_TEMPLATES', 0, 1, v_boolean, ^jmv$delete_old_templates],
{   } [TRUE,  'DELETE_UNRECONCILED_FILES', 0, 1, v_boolean, ^osv$delete_unreconciled_files],
{   } [FALSE, 'DETAILED_CRITICAL_DISPLAYS', 0, 1, v_boolean, ^syv$detailed_critical_displays],
{   } [FALSE, 'DISDELAY', 1, 100000, v_integer, ^dpv$display_delay],
{   } [FALSE, 'DUMP_WHEN_DEBUG', 0, 1, v_boolean, ^osv$dump_when_debug],
{   } [FALSE, 'DYNAMIC_FILE_SPACE_LIMITS', 0, 1, v_boolean, ^sfv$dynamic_file_space_limits],
{   } [TRUE,  'ENABLE_CONSOLE_BELL', 0, 1, v_boolean, ^dpv$enable_console_bell],
{   } [FALSE, 'ENABLE_HEAD_SHIFT_MESSAGE', 0, 1, v_boolean, ^cmv$enable_head_shift_message],
{   } [FALSE, 'ENABLE_USER_DISPLAYS', 0, 1, v_boolean, ^ofv$enable_user_displays],
{   } [FALSE, 'ENFORCE_READ_PRIORITY', 0, 1, v_boolean, ^iov$enforce_read_priority],
{   } [FALSE, 'ENGINEERING_LOG_CRITICAL', 0, 1, v_boolean,
            ^lgv$global_log_attributes [pmc$engineering_log].critical],
{   } [FALSE, 'ENGINEERING_LOG_MAXIMUM_SIZE', 1, 150, v_byte,
            ^lgv$global_log_attributes [pmc$engineering_log].maximum_size],
{   } [FALSE, 'FILE_SERVER_DEBUG_ENABLED', 0, 1, v_boolean, ^dfv$file_server_debug_enabled],
{   } [FALSE, 'FILE_SERVER_Q_TIMEOUT_INTERVAL', 5000, 300000, v_integer, ^dfv$task_queue_timeout_interval],
{   } [FALSE, 'FILE_SERVER_RECOVERY_ENABLED', 0, 1, v_boolean, ^dfv$job_recovery_enabled],
{   } [FALSE, 'HALT_ON_HUNG_TASK', 0, 1, v_boolean, ^tmv$halt_on_hung_task],
{   } [FALSE, 'HALT_ON_PROCESSOR_MALFUNCTION', 0, 1, v_boolean, ^mtv$halt_on_proc_malf],
{   } [FALSE, 'HALT_ON_SWAPIN_FAILURE', 0, 1, v_boolean, ^jsv$halt_on_swapin_failure],
{   } [FALSE, 'HALTRING', 0, 16, v_byte, ^mtv$halt_cpu_ring_number],
{   } [FALSE, 'HISTORY_LOG_CRITICAL', 0, 1, v_boolean, ^lgv$global_log_attributes [pmc$history_log].critical],
{   } [FALSE, 'HISTORY_LOG_MAXIMUM_SIZE', 1, 150, v_byte,
            ^lgv$global_log_attributes [pmc$history_log].maximum_size],
{   } [FALSE, 'IGNORE_IMAGE', 0, 1, v_boolean, ^dsv$ignore_image],
{   } [TRUE , 'JOB_RECOVERY_OPTION', 0, 3, v_integer, ^syv$setsa_job_recovery_option],
{   } [FALSE, 'LOG_SECURE_PARAMETERS', 0, 1, v_boolean, ^clv$log_secure_parameters],
{   } [FALSE, 'LONG_WAIT_FORCE_SWAP_TIME', 0, 1000000000, v_integer, ^tmv$long_wait_force_swap_time],
{   } [FALSE, 'LONG_WAIT_SWAP_TIME', 0, 1000000000, v_integer, ^tmv$long_wait_swap_time],
{   } [FALSE, 'MANDATORY_DUALSTATE', 0, 1, v_boolean, ^syv$mandatory_dualstate],
{   } [FALSE, 'MAX_TIME_SWAP_IO_NOT_INIT', 0, 86400000000, v_integer, ^jsv$max_time_swap_io_not_init],
{   } [TRUE,  'MAXIMUM_ACTIVE_JOBS', 1, jmc$max_active_jobs, v_halfword, ^mtv$mx_ajl_entries],
{   } [FALSE, 'MAXIMUM_ALLOCATION_SIZE', 16384, 0ffffffffffff(16), v_integer, ^dmv$maximum_allocation_size],
{   } [FALSE, 'MAXIMUM_JOB_CLASSES', jmc$minimum_job_classes, jmc$maximum_job_classes, v_halfword,
            ^jmv$maximum_job_classes],
{   } [FALSE, 'MAXIMUM_KNOWN_JOBS', 1, jmc$maximum_job_count, v_halfword, ^jmv$maximum_known_jobs],
{   } [FALSE, 'MAXIMUM_OUTPUT_FILES', 1, jmc$maximum_output_count, v_halfword, ^jmv$maximum_known_outputs],
{   } [FALSE, 'MAXIMUM_SERVICE_CLASSES', jmc$minimum_service_classes, jmc$maximum_service_classes, v_halfword,
            ^jmv$maximum_service_classes],
{   } [FALSE, 'MAXIMUM_SWAP_RESIDENT_TIME', 0, 86400000000, v_integer, ^jsv$max_time_swap_io_complete],
{   } [FALSE, 'MAXIMUM_THINK_TIME', 0, 1000000000, v_integer, ^jmv$max_think_time],
{   } [FALSE, 'MAXIMUM_WRITE_SPAN', 0, 10000000(16), v_integer, ^mmv$maximum_write_span],
{   } [FALSE, 'MAXWS_AIO_THRESHOLD', 0, 100000, v_integer, ^mmv$maxws_aio_threshold],
{   } [FALSE, 'MINIMUM_SHARED_WORKING_SET', 0, 100000, v_halfword,
            ^temp_workaround_min_sws],
{  Note: The following line should be made active when the temp_workaround is no longer needed
{           ^mmv$gpql[mmc$pq_shared_task_service].minimum],
{   } [FALSE, 'MINIMUM_THINK_TIME', 0, 1000000000, v_integer, ^jmv$min_think_time],
{   } [TRUE,  'NETWORK_ACTIVATION', 0, 1, v_boolean, ^rav$network_activation],
{   } [FALSE, 'NOS_CYCLE_THRESHOLD', 0, 10, v_integer, ^mtv$nos_cycle_threshold],
{   } [FALSE, 'PROCESSOR_DUE_THRESHOLD', 0, 7FFFFFFFFFFF(16), v_integer, ^mtv$processor_due_threshold],
{   } [FALSE, 'QUICK_SWEEP_INTERVAL', 0, 100000000(16), v_integer, ^mmv$quick_sweep_interval],
{   } [FALSE, 'READ_TU_EXECUTE', 1, 32, v_halfword, ^mmv$read_tu_execute],
{   } [FALSE, 'READ_TU_READ_WRITE', 1, 32, v_halfword, ^mmv$read_tu_read_write],
{   } [TRUE,  'RECOVER_AT_ALL_COSTS', 0, 1, v_boolean, ^osv$recover_at_all_costs],
{   } [FALSE, 'SECURITY_LOG_CRITICAL', 0, 1, v_boolean,
            ^lgv$global_log_attributes [pmc$security_log].critical],
{   } [FALSE, 'SECURITY_LOG_MAXIMUM_SIZE', 1, 150, v_byte,
            ^lgv$global_log_attributes [pmc$security_log].maximum_size],
{   } [FALSE, 'SITE_ACTIVE_SHARED_QUEUES', 0, mmc$pq_shared_num_sites, v_integer,
            ^mmv$site_active_shared_queues],
{   } [FALSE, 'SPACE_MESSAGES_TO_CONSOLE', 0, 1, v_boolean, ^dmv$space_messages_to_console],
{   } [FALSE, 'STATISTIC_LOG_CRITICAL', 0, 1, v_boolean,
            ^lgv$global_log_attributes [pmc$statistic_log].critical],
{   } [FALSE, 'STATISTIC_LOG_MAXIMUM_SIZE', 1, 150, v_byte,
            ^lgv$global_log_attributes [pmc$statistic_log].maximum_size],
{   } [FALSE, 'SWAP_FILE_ALLOCATION_SIZE', 4096, 1000000, v_halfword, ^jmv$swap_file_allocation_size],
{   } [FALSE, 'SWAP_JOBS_IN_LONG_WAIT', 0, 1, v_boolean, ^jmv$swap_jobs_in_long_wait],
{   } [TRUE,  'SYSTEM_ACTIVATION', 0, 1, v_boolean, ^rav$system_activation],
{   } [FALSE, 'SYSTEM_DEBUG_RING', 0, 15, v_integer, ^tmv$system_debug_ring],
{   } [FALSE, 'SYSTEM_DEBUG_SEGMENT', 0, 4095, v_integer, ^tmv$system_debug_segment],
{   } [FALSE, 'SYSTEM_ERROR_HANG_COUNT', 0, 1000, v_halfword, ^tmv$system_error_hang_count],
{   } [FALSE, 'SYSTEM_LOG_CRITICAL', 0, 1, v_boolean, ^lgv$global_log_attributes [pmc$system_log].critical],
{   } [FALSE, 'SYSTEM_LOG_MAXIMUM_SIZE', 1, 150, v_byte,
            ^lgv$global_log_attributes [pmc$system_log].maximum_size],
{   } [FALSE, 'TELNET_CONNECTION_LIMIT', 0, 900000, v_integer,
            ^ifv$telnet_connection_limit],
{   } [FALSE, 'TEMP_FILE_SPACE_GUARD', 0, 1, v_boolean, ^mmv$temp_file_space_guard],
{   } [FALSE, 'THINK_EXPIRATION_TIME', 0, 1000000000, v_integer, ^jsv$think_expiration_time],
{   } [TRUE,  'UNLOAD_DEADSTART_TAPE', 0, 1, v_boolean, ^dsv$unload_deadstart_tape],
{   } [TRUE,  'VALIDATE_ACTIVE_SETS', 0, 1, v_boolean, ^osv$validate_active_sets],
{   } [FALSE, 'VECTOR_SIMULATION', 0, 2, v_byte, ^mtv$scb_vector_sim_attribute],
{ NOTE:  When all the 'dummies' are used in the documented section, the module constant, documented_attibutes
{ must be changed.  That constant controls the ALL display.
{
{ The following are UNDOCUMENTED system attributes.  Be sure to add new attributes to the correct section
{ of this table.  It affects how the ALL and EVERYTHING options on the DISSA command works.
{
{   } [FALSE, 'ADVISE_IN_LIMIT', 1, 1000, v_integer, ^mmv$advise_in_aio_limit],
{   } [FALSE, 'AGE_INTERVAL_CEILING', 1, 255, v_byte, ^mmv$age_interval_ceiling],
{   } [FALSE, 'AGE_INTERVAL_FLOOR', 1, 255, v_byte, ^mmv$age_interval_floor],
{   } [FALSE, 'AGGRESSIVE_AGING_LEVEL', 0, 100000, v_integer, ^mmv$aggressive_aging_level],
{   } [FALSE, 'AGGRESSIVE_AGING_LEVEL_2', 0, 100000, v_integer, ^mmv$aggressive_aging_level_2],
{   } [FALSE, 'AGING_ALGORITHM', 0, 10000, v_integer, ^mmv$aging_algorithm],
{   } [FALSE, 'ALLOW_JR_TEST', 0, 1, v_boolean, ^syv$allow_jr_test],
{   } [FALSE, 'ASSIGN_MULTIPLE_PAGES', 0, 100000, v_integer, ^mmv$assign_multiple_pages],
*IF $variable(mmv$test_forced_use_cache_maps, declared) <> 'UNKNOWN'
{   } [TRUE , 'BAD_PERF_USE_FORCED_CACHE_MAPS', 0, 1, v_boolean, ^mmv$force_use_of_cache_and_maps],
{   } [FALSE, 'BENCHMARK_RUN', 0, 0ffffffffffff(16), v_integer, ^mmv$benchmark_run],
*ELSE
{ -------- Declarations for forcing the use of cache and maps omitted at compile time --------
*IFEND
{   } [FALSE, 'BINARY_CATALOG_SEARCH', 0, 1, v_boolean, ^pfv$binary_catalog_search],
{   } [TRUE , 'CATALOG_NAME_SECURITY', 0, 1, v_boolean, ^osv$catalog_name_security],
{   } [FALSE,  clc$change_secure_logging_name, 0, 1, v_boolean, ^clv$secure_logging_activated],
{   } [FALSE, 'CLIENT_JOB_LISTS', 1, dfc$max_job_list_p_array_size, v_integer,
            ^dfv$maximum_client_job_lists],
{   } [FALSE, 'CLONE_ENABLED', 0, 1, v_boolean, ^syv$clone_enabled],
{   } [FALSE, 'CYCLE_WAIT_TIME', 0, 100000000, v_integer, ^tmv$cycle_delay_time],
{   } [TRUE,  'DEADSTART_INTERVENTION', 0, 1, v_boolean, ^rav$deadstart_intervention],
{   } [FALSE, 'TRAPPER', 0, 1, v_boolean, ^cmv$free_trap ],
{   } [FALSE, 'DEBUG1', 0, 0ffffffffffff(16), v_integer, ^osv$debug[1]],
{   } [FALSE, 'DEBUG2', 0, 0ffffffffffff(16), v_integer, ^osv$debug[2]],
{   } [FALSE, 'DEBUG3', 0, 0ffffffffffff(16), v_integer, ^osv$debug[3]],
{   } [FALSE, 'DEBUG4', 0, 0ffffffffffff(16), v_integer, ^osv$debug[4]],
{   } [FALSE, 'DEBUG5', 0, 0ffffffffffff(16), v_integer, ^osv$debug[5]],
{   } [FALSE, 'DEBUG6', 0, 0ffffffffffff(16), v_integer, ^osv$debug[6]],
{   } [FALSE, 'DEBUG7', 0, 0ffffffffffff(16), v_integer, ^osv$debug[7]],
{   } [FALSE, 'DEBUG8', 0, 0ffffffffffff(16), v_integer, ^osv$debug[8]],
{   } [FALSE, 'DEBUG9', 0, 0ffffffffffff(16), v_integer, ^osv$debug[9]],
{   } [FALSE, 'DEBUG10', 0, 0ffffffffffff(16), v_integer, ^osv$debug[10]],
{   } [FALSE, 'DEBUG11', 0, 0ffffffffffff(16), v_integer, ^osv$debug[11]],
{   } [FALSE, 'DEBUG12', 0, 0ffffffffffff(16), v_integer, ^osv$debug[12]],
{   } [FALSE, 'DEBUG13', 0, 0ffffffffffff(16), v_integer, ^osv$debug[13]],
{   } [FALSE, 'DEBUG14', 0, 0ffffffffffff(16), v_integer, ^osv$debug[14]],
{   } [FALSE, 'DEBUG15', 0, 0ffffffffffff(16), v_integer, ^osv$debug[15]],
{   } [FALSE, 'DEBUG_AV', 0, 1, v_boolean, ^avv$debug_accounting_validation],
{   } [FALSE, 'DEBUG_CATALOG_ACCESS', 0, 1, v_boolean, ^pfv$debug_catalog_access],
{   } [FALSE, 'DEBUG_JOB_RECOVERY', 0, 1, v_boolean, ^syv$debug_job_recovery],
{   } [FALSE, 'DEBUGGER_PAGE_WAIT_LINES', 0, 07fffffffffffffff(16), v_integer, ^syv$debugger_page_wait_lines],
{   } [FALSE, 'DEFAULT_PIT', 1, 0ffffffff(16), v_integer, ^osv$default_pit],
{   } [FALSE, 'DEFAULT_SIT', 500, 1000000000, v_integer, ^osv$default_sit_value],
{   } [TRUE,  'DEVELOPMENT_DEADSTART', 0, 1, v_boolean, ^rav$development_deadstart],
{   } [FALSE, 'DISABLE_NETWORK_RELAYS', 0, 1, v_boolean, ^nav$disable_network_relays],
{   } [FALSE, 'DISABLE_WRITE_FOR_PERF_MEAS', 0, 1, v_boolean, ^mmv$disable_write_for_perf_meas],
{   } [FALSE, 'DISK_FAULT_SIMULATION', 0, 1, v_boolean, ^osv$disk_fault_simulation],
{   } [FALSE, 'DISPLAY_ACTUAL_PRIORITY', 0, 1, v_boolean, ^tmv$display_actual_priority],
{   } [TRUE,  'DISPLAY_DEADSTART_MESSAGES', 0, 1, v_boolean, ^dsv$display_deadstart_messages ],
{   } [FALSE, 'EMERGENCY_INTERVENTION', 0, 1, v_boolean, ^osv$emergency_intervention],
{   } [FALSE, 'ENABLE_DEBUG_CODE', 0, 1, v_boolean, ^jsv$enable_debug_code],
{   } [FALSE, 'ENABLE_FAULT_INJECTION', 0, 1, v_boolean, ^syv$enable_fault_injection],
{   } [TRUE , 'ENABLE_HEAP_TRACE', 0, 1, v_boolean, ^syv$enable_heap_trace],
{   } [TRUE,  'ENABLE_HYPERCHANNEL', 0, 1, v_boolean, ^osv$enable_hyperchannel],
{   } [FALSE, 'ENABLE_PM_DEBUG_LOGGING', 0, 1, v_boolean, ^pmv$debug_logging_enabled],
{   } [FALSE, 'ENABLE_QUEUE_FILE_ACCESS', 0, 1, v_boolean, ^jmv$enable_queue_file_access],
{   } [FALSE, 'ENABLE_SOURCE_CYBIL_CHECKING', 0, 1, v_boolean, ^lov$enable_source_type_checking],
{   } [FALSE, 'ENABLE_SWAP_FILE_STATISTICS', 0, 1, v_boolean, ^jsv$enable_swap_file_statistics],
{   } [FALSE, 'ENABLE_SWAP_RESIDENT', 0, 1, v_boolean, ^jsv$enable_swap_resident],
{   } [FALSE, 'ENABLE_SWAP_RESIDENT_NO_IO', 0, 1, v_boolean, ^jsv$enable_swap_resident_no_io],
{   } [FALSE, 'FILE_ALLOCATION_INTERVAL', 0, 7fffffff(16), v_integer, ^mmv$file_allocation_interval],
{   } [FALSE, 'FILE_SERVER_INFO_ENABLED', 0, 1, v_boolean, ^dfv$file_server_info_enabled],
{   } [FALSE, 'FORCE_DIRECT_TAPE_IO', 0, 1, v_boolean, ^bav$force_direct_tape_io ],
{   } [FALSE, 'FREE_WORKING_SET_ON_SWAPOUT', 0, 1, v_boolean, ^jsv$free_working_set_on_swapout],
{   } [FALSE, 'HALT_ON_CPU_TIMEOUT', 0, 1, v_boolean, ^mtv$halt_on_cpu_timeout],
{   } [FALSE, 'HALT_ON_EXIT_WITH_IO', 0, 1, v_boolean, ^syv$halt_on_exit_with_io],
{   } [FALSE, 'IF_CONDITION_HANDLING_TRACE', 0, 1, v_boolean, ^iiv$condition_handler_trace],
{   } [FALSE, 'IGNORE_PARAMETER_VERIFICATION', 0, 2, v_integer, ^lov$ignore_param_verification],
{   } [FALSE, 'INPUT_FILE_RECOVERY_OPTION', 0, 1, v_byte, ^jmv$input_file_recovery_option],
{   } [FALSE, 'JOB_WORKING_SET_AGE_INTERVAL', 1000, 7fffffff(16), v_integer, ^mmv$jws_queue_age_interval],
{   } [FALSE, 'KCU_ENABLE', 0, 100, v_integer, ^osv$keypoint_enable],
{   } [FALSE, 'MAX_PAGES_FIRST_SWAP_TASK', 0, 0ffff(16), v_integer, ^jsv$max_pages_first_swap_task],
{   } [TRUE,  'MAXIMUM_180_MEMORY', 1000000, 400000000, v_integer, ^mmv$maximum_180_memory],
{   } [TRUE,  'MAXIMUM_ACTIVE_SEGMENTS', 100, 65535, v_halfword, ^mtv$mx_segments],
{   } [FALSE, 'MAXIMUM_BYTES_PER_TAPE_IO', 1, 7FFFFFFF(16), v_integer, ^bav$max_bytes_per_tape_io ],
{   } [FALSE, 'MAXIMUM_DEBUG_OUTPUT_LINES', 100, 7FFFFFFFFFFF(16), v_integer, ^syv$max_debug_output_lines],
{   } [FALSE, 'MAXIMUM_INDIRECT_TAPE_BLOCK', 1, 7FFFFFFF(16), v_integer, ^bav$max_indirect_tape_block ],
{   } [FALSE, 'MAXIMUM_PAGES_NO_FILE', 0, 7fffffff(16), v_integer, ^mmv$max_pages_no_file],
{   } [FALSE, 'MAXIMUM_PAGES_TO_SWAP', 0, 0ffff(16), v_integer, ^jsv$maximum_pages_to_swap],
{
{ Maximum segment length is no longer used by the OS. It must remain as a SETSA until release 1.6.1
{ because IM/DM uses it. As soon as they react to the change-this variable will be deleted.
{
{   } [FALSE, 'MAXIMUM_SEGMENT_LENGTH', 150000000, 7fffffff(16), v_integer, ^mmv$max_segment_length],
{   } [FALSE, 'MAXIMUM_TAPE_BLOCK_SIZE', 1, 7FFFFFFF(16), v_integer, ^bav$max_allowed_tape_block_size ],
{   } [FALSE, 'MINIMUM_AVAILABLE_PAGES', 0, 100000, v_integer, ^mmv$min_avail_pages],
{   } [FALSE, 'MM_CHECK_QUEUES', 0, 2, v_integer, ^mmv$check_queues],
{   } [FALSE, 'MM_PERIODIC_CALL', 1000, 10000000, v_integer, ^mmv$periodic_call_interval],
{   } [FALSE, 'MULTI_PAGE_WRITE', 0, 1, v_boolean, ^mmv$multi_page_write],
{   } [FALSE, 'NAMVE_DEBUG_MODE', 0, 2, v_byte, ^nav$debug_mode],
{   } [FALSE, 'NO_MEMORY_BUFFERING', 0, 1, v_boolean, ^mmv$no_memory_buffering],
{   } [FALSE, 'NOSVE_INTERNAL_OPERATIONS', 0, 1, v_boolean, ^syv$nosve_internal_operations],
{   } [FALSE, 'OUTPUT_FILE_RECOVERY_OPTION', 0, 1, v_byte, ^jmv$output_file_recovery_option],
{   } [FALSE, 'OUTPUT_OPTION', 0, 100000000, v_integer, ^iiv$output_option],
{   } [FALSE, 'PAGE_SKIP_COUNT', 16, 256, v_integer, ^mmv$page_skip_count],
{   } [FALSE, 'PERMANENT_FILE_OVERFLOW', 0, 1, v_boolean, ^dmv$permanent_file_overflow],
{   } [FALSE, 'PF_SPARSE', 0, 1, v_boolean, ^dmv$pf_sparse],
{   } [FALSE, 'QFILE_RECOVERY_OPTION', 0, 1, v_byte, ^jmv$qfile_recovery_option],
{   } [FALSE, 'QUICKDS', 0, 1, v_boolean, ^dmv$quick_deadstart],
{   } [TRUE,  'RECONCILE_PERMANENT_FILES', 0, 1, v_boolean, ^osv$reconcile_permanent_files],
{   } [FALSE, 'RECYCLE_DEVICE_LOG', 0, 1, v_boolean, ^dmv$recycle_device_log],
{   } [TRUE,  'REORGANIZE_PERMANENT_FILES', 0, 1, v_boolean, ^osv$reorganize_permanent_files],
{   } [FALSE, 'SCHED_MEMORY_WAIT_FACTOR', 0, 100, v_integer, ^jmv$sched_memory_wait_factor],
{   } [FALSE, 'SCHEDULER_WAIT_TIME', 0, 5000000, v_integer, ^jmv$scheduler_wait_time],
{   } [FALSE, 'SERVED_FAMILY_LISTS', 1, dfc$maximum_family_lists, v_integer,
       ^dfv$number_served_family_lists],
{   } [FALSE, 'SHADOW_BY_SEGNUM', 0, 1, v_boolean, ^mmv$shadow_by_segnum],
{   } [FALSE, 'SHARED_PAGES_IN_JWS', 0, 1, v_boolean, ^mmv$shared_pages_in_jws],
{   } [FALSE, 'SHARED_WORKING_SET_AGE_INTERVAL', 0, 7fffffff(16), v_integer, ^mmv$shared_queue_age_interval],
{   } [TRUE,  'SORT_CATALOG_OBJECT_LIST', 0, 1, v_boolean, ^pfv$sort_catalog_object_list],
{   } [FALSE, 'SPECIAL_TRAP', 0, 1, v_boolean, ^osv$special_aam_trap],
{   } [FALSE, 'SWAPPING_AIC', 0, 100, v_integer, ^mmv$swapping_aic],
{   } [FALSE, 'SYSTEM_HALTRING', 0, 16, v_byte, ^mtv$system_haltring],
{   } [TRUE,  'SYSTEM_JOB_MULTIPROCESSING', 0, 1, v_boolean, ^syv$system_job_multiprocessing],
{   } [FALSE,  clc$system_logging_active_name, 0, 1, v_boolean, ^clv$system_logging_activated],
{   } [FALSE, 'TEMPORARY_FILE_OVERFLOW', 0, 1, v_boolean, ^dmv$temporary_file_overflow],
{   } [FALSE, 'TEST_RECOVERY', 0, 1, v_boolean, ^dmv$test_recovery],
{   } [FALSE, 'TIMED_WAIT_NOT_QUEUED', 60000000, 7fffffffffff(16), v_integer, ^tmv$timed_wait_not_queued],
{   } [FALSE, 'TRAP_TASK_ERRORS', 0, 1, v_boolean, ^osv$trap_task_errors],
{   } [FALSE, 'TRIM_FILES', 0, 1, v_boolean, ^dmv$trim_files],
{   } [FALSE, 'TURN_OFF_PP_RELOAD', 0, 1, v_boolean, ^dsv$automatic_pp_reload.turned_off],
{   } [false, 'UNUSED_BOOLEAN_FOR_IO', 0, 1, v_boolean, ^iov$unused_boolean],
{   } [FALSE, 'USE_ASSIGN_PAGES_FOR_TAPE', 0, 1, v_boolean, ^bav$use_assign_pages_for_tape ],
{   } [FALSE, 'USER_TEMPLATES', 0, 1, v_boolean, ^syv$user_templates],
{   } [TRUE,  'VALIDATE_PERMANENT_FILES', 0, 1, v_boolean, ^osv$validate_permanent_files],
{   } [TRUE,  'VALIDATE_SYSTEM_SET', 0, 1, v_boolean, ^osv$validate_active_sets],
{   } [FALSE,  avc$validation_level_const_name, 0, 2, v_byte, ^avv$validation_level],
{   } [FALSE, 'VERIFY_CATALOG_HEAPS', 0, 1, v_boolean, ^pfv$verify_catalog_heaps],
{   } [FALSE, 'VERIFY_HEAP_LINKAGE', 0, 1, v_boolean, ^syv$verify_heap_linkage],
{   } [TRUE,  'VOLUME_CLASS', 0, 1, v_boolean, ^dmv$volume_class_kludge],
{   } [TRUE,  'WIRE_MLI_TABLES', 0, 1, v_boolean, ^mlv$wire_mli_tables],
{   } [FALSE, 'WRITE_AGED_OUT_PAGES', 0, 100000, v_integer, ^mmv$write_aged_out_pages],
{   } [TRUE,  'WRITE_STALE_PAGES',0, 1, v_boolean, ^jsv$write_stale_pages],
{   } [FALSE, 'MODIFY_LOG_SEGMENTS',0, 1, v_boolean, ^lgv$modify_log_segments],
{
{ The system attribute table is divided into two sections:  DOCUMENTED attributes and UNDOCUMENTED
{ attributes.  Undocumented attributes are used by development for debugging and to sometimes turn
{ features on or off.  When adding new attributes use a 'dummy' and move it to the correct position
{ in the table.  KEEP THE TABLE IN ALPHABETICAL ORDER!  The attribute must be in the correct section
{ of the table for display purposes.  The ALL option on the DISPLAY_SYSTEM_ATTRIBUTE command displays
{ all DOCUMENTED attributes.  The EVERYTHING is for internal use; it displays both documented and
{ undocumented attributes.
{
{   } [FALSE, 'dummy', 0, 1, v_boolean, NIL],
{   } [FALSE, 'dummy', 0, 1, v_boolean, NIL],
{   } [FALSE, 'dummy', 0, 1, v_boolean, NIL]];


?? OLDTITLE ??
?? TITLE := '  [XDCL, #GATE] syp$fetch_system_constant', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$fetch_system_constant
    (VAR name: string ( * );
     VAR index: integer;
     VAR value: integer;
     VAR status: ost$status);

    VAR
      tab_p: ^value_table_type,
      temp_status: ost$status;

    temp_workaround_min_sws := mmv$gpql[mmc$pq_shared_task_service].minimum;
    IF name = 'EVERYTHING' THEN
       IF (index >= 1) AND (index <= value_table_length) THEN
           name := value_table [index].name;
           IF name <> 'dummy' THEN
              CASE value_table [index].value_type OF
              = v_integer =
                value := value_table [index].integer_p^;
              = v_halfword =
                value := value_table [index].halfword_p^;
              = v_byte =
                value := value_table [index].byte_p^;
              = v_boolean =
                value := ORD (value_table [index].boolean_p^);
              CASEND;
           IFEND;
           IF index = value_table_length THEN
                 index := 0;
              ELSE
                 index := index + 1;
           IFEND;
       IFEND;
    ELSEIF name = 'ALL' THEN
       IF (index >= 1) AND (index <= documented_attributes) THEN
           name := value_table [index].name;
           IF name <> 'dummy' THEN
              CASE value_table [index].value_type OF
              = v_integer =
                value := value_table [index].integer_p^;
              = v_halfword =
                value := value_table [index].halfword_p^;
              = v_byte =
                value := value_table [index].byte_p^;
              = v_boolean =
                value := ORD (value_table [index].boolean_p^);
              CASEND;
           IFEND;
           IF index = documented_attributes THEN
                 index := 0;
              ELSE
                 index := index + 1;
           IFEND;
       IFEND;
    ELSE
       search_value_table (name, tab_p, status);
       IF status.normal THEN
         CASE tab_p^.value_type OF
         = v_integer =
           value := tab_p^.integer_p^;
         = v_halfword =
           value := tab_p^.halfword_p^;
         = v_byte =
           value := tab_p^.byte_p^;
         = v_boolean =
           value := ORD (tab_p^.boolean_p^);
         CASEND;
         RETURN;
       IFEND;

{ The following code is executed only if the status returned from search_value_table was abnormal.
{ Use a temporary status in the following procedure calls to preserve the bad status from search_value_table.

       dmp$fetch_debug_option_value (name, value, status);
       IF status.normal THEN
          RETURN;
       IFEND;

{      iop$fetch_debug_option_value (name, value, status);
    IFEND;
  PROCEND syp$fetch_system_constant;

?? TITLE := '  [XDCL, #GATE] syp$store_system_constant', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$store_system_constant
    (    name: string ( * );
         index: integer;
         value: integer;
     VAR status: ost$status);

    VAR
      previous_integer_value: integer,
      rb: dst$rb_system_deadstart_status,
      restricted_mainframe: boolean,
      tab_p: ^value_table_type;

    search_value_table (name, tab_p, status);
    IF status.normal THEN

      { Check for system attributes not allowed to be set on Soviet Nuclear Safety or China Weather Systems.

      osp$check_for_desired_mf_class (osc$mc_china_or_soviet_class, restricted_mainframe);

      IF restricted_mainframe AND ((tab_p^.name = 'EMERGENCY_INTERVENTION') OR
            (tab_p^.name = 'USER_TEMPLATES')) THEN
        RETURN;
      IFEND;

      IF (mtv$sys_core_init_complete) AND (tab_p^.deadstart_only) THEN
        osp$set_status_abnormal ('SY', sye$not_changeable_after_ds,
          'Variable not changeable after ds complete', status);
        RETURN;
      IFEND;

      IF (value > tab_p^.max) OR (value < tab_p^.min) THEN
        osp$set_status_abnormal ('SY', sye$range_error, 'Value out of range', status);
        RETURN;
      ELSE
        IF name = 'SITE_ACTIVE_SHARED_QUEUES' THEN
          previous_integer_value := tab_p^.integer_p^;
        IFEND;
        temp_workaround_min_sws := mmv$gpql[mmc$pq_shared_task_service].minimum;
        CASE tab_p^.value_type OF
        = v_integer =
          tab_p^.integer_p^ := value;
        = v_halfword =
          tab_p^.halfword_p^ := value;
        = v_byte =
          tab_p^.byte_p^ := value;
        = v_boolean =
          IF value = ORD (FALSE) THEN
            tab_p^.boolean_p^ := FALSE;
          ELSE
            tab_p^.boolean_p^ := TRUE;
          IFEND;
        CASEND;
        mmv$gpql[mmc$pq_shared_task_service].minimum := temp_workaround_min_sws;
      IFEND;

      IF name = 'AUTOMATIC_SYSTEM_RESTART' THEN
        IF dsv$mainframe_type = dsc$mt_2000_mainframe THEN
          rb.reqcode := syc$rc_system_deadstart_status;
          rb.bct_flags := dsc$rb_sds_bct_ar_control;
          IF value = ORD(TRUE) THEN
            rb.action := dsc$rb_sds_clear_bct_flag;
          ELSE
            rb.action := dsc$rb_sds_set_bct_flag;
          IFEND;
          i#call_monitor (#LOC (rb), #SIZE (rb));
        IFEND;
      ELSEIF name = 'SITE_ACTIVE_SHARED_QUEUES' THEN
        mmp$store_site_active_q_cnt_r1 (mmv$site_active_shared_queues, status);
        IF NOT status.normal THEN
          tab_p^.integer_p^ := previous_integer_value;
          RETURN;
        IFEND;
      IFEND;

      RETURN;
    IFEND;

    dmp$store_debug_option_value (name, value, status);
    IF status.normal THEN
      RETURN;
    IFEND;

{   iop$store_debug_option_value (name, value, status);


  PROCEND syp$store_system_constant;

?? TITLE := '  search_value_table', EJECT ??

  PROCEDURE search_value_table
    (    name: string ( * );
     VAR tab_p: ^value_table_type;
     VAR status: ost$status);

    VAR
      error_string: string (55),
      i: integer,
      lname: string (max_name_length),
      table_i: integer;

    status.normal := TRUE;
    table_i := 1;
    lname := name;
    FOR i := 1 TO STRLENGTH (lname) DO
      IF (lname (i) >= 'a') AND (lname (i) <= 'z') THEN
        lname (i) := CHR (ORD (lname (i)) - ORD ('a') + ORD ('A'));
      IFEND;
    FOREND;

  /lp/
    WHILE lname <> value_table [table_i].name DO
      table_i := table_i + 1;
      IF table_i <= value_table_length THEN
        CYCLE /lp/
      IFEND;
      error_string := 'Unknown parameter name: ';
      error_string(25, *) := lname;
      osp$set_status_abnormal ('SY', sye$unknown_parameter_name, error_string, status);
      RETURN;
    WHILEND /lp/;

    tab_p := ^value_table [table_i];
  PROCEND search_value_table;

?? SKIP := 2 ??
MODEND sym$system_constant_manager;
*DECK DECK=SYM$SYSTEM_CORE_COMMANDS EXPAND=TRUE
*DECK DECK=SYM$SYSTEM_TASK_SERVICES EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
MODULE sym$system_task_services;
{
{ This module contains the routines which system tasks use:
{        .to poll the system for the next state of the task
{        .to wait until the system is ready to resume after an idle.
{ This module is located on the following library:
{        OSF$JOB_TEMPLATE_2DD
{
?? PUSH (LISTEXT := ON) ??
*copyc ose$system_task_exceptions
*copyc ost$status
?? POP ??
*copyc syt$system_task_status
*copyc osp$active_system_task
*copyc osp$idle_requested
*copyc pmp$wait
?? OLDTITLE, NEWTITLE := '  PROCEDURE syp$get_system_task_status', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$get_system_task_status (VAR task_status: syt$system_task_status);

*copyc syh$get_system_task_status

    IF osp$idle_requested () THEN
      task_status := syc$sts_idle_down_in_progress;
    ELSEIF osp$active_system_task () THEN
      task_status := syc$sts_ok;
    ELSE
      task_status := syc$sts_deactivate_requested;
    IFEND;

  PROCEND syp$get_system_task_status;
?? OLDTITLE, NEWTITLE := '  PROCEDURE syp$wait_system_resume', EJECT ??

  PROCEDURE [XDCL, #GATE] syp$wait_system_resume;

*copyc syh$wait_system_resume

    CONST
      one_second = 1000000;

    WHILE osp$idle_requested () DO
      pmp$wait (one_second, one_second);
    WHILEND;

  PROCEND syp$wait_system_resume;
?? OLDTITLE ??
MODEND sym$system_task_services;
*DECK DECK=SYP$ACTIVATE_JOB_TEMPLATE EXPAND=FALSE
  PROCEDURE [XREF] syp$activate_job_template
    (    template_file: ^SEQ ( * );
         template_name: ost$name;
         job_unique_segments,
         task_unique_segments: ost$segment_set;
         classes: ^array [1 .. *] of ost$name;
     VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
*copyc ost$name
*copyc ost$status
*copyc ost$segment_set
?? POP ??
*DECK DECK=SYP$ADVISED_MOVE_BYTES EXPAND=FALSE
 PROCEDURE [XREF] syp$advised_move_bytes (source: ^cell;
        destination: ^cell;
        length: integer;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=SYP$ASCII_TO_BINARY EXPAND=FALSE

  PROCEDURE [XREF] syp$ascii_to_binary (text : string ( * );
        default_base: 1 .. 16;
    VAR int: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=SYP$BINARY_TO_ASCII EXPAND=FALSE

  PROCEDURE [XREF] syp$binary_to_ascii (i: integer;
    VAR s: string ( * );
        base: 2 .. 16;
        pos: 1 .. 255);
*DECK DECK=SYP$CAUSE_CONDITION EXPAND=FALSE

  PROCEDURE [XREF] syp$cause_condition
    (    condition: syt$user_defined_condition);

?? PUSH (LISTEXT := ON) ??
*copyc syt$system_core_condition
*copyc syt$user_defined_condition
?? POP ??
*DECK DECK=SYP$CAUSE_HARDWARE_FAULTS EXPAND=FALSE

  PROCEDURE [XREF] syp$cause_hardware_faults
    (    hardware_fault_kind: syt$hardware_fault_kind;
         rma_of_parity_error: integer;
     VAR known_hardware_fault_kind: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc syt$hardware_fault_kind
?? POP ??

*DECK DECK=SYP$CHANGE_ACCESS_STATE EXPAND=FALSE

  PROCEDURE [XREF] syp$change_access_state
    (    sfid: gft$system_file_identifier;
         access_state: mmt$segment_access_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc mmt$segment_access_state
*copyc ost$status
?? POP ??
*DECK DECK=SYP$CHECK_SYSTEM_LEVEL EXPAND=FALSE

  PROCEDURE [XREF] syp$check_system_level;
*DECK DECK=SYP$CLEANUP_HEAP_PAGES EXPAND=FALSE

 PROCEDURE [XREF] syp$cleanup_heap_pages;
*DECK DECK=SYP$CLEAR_TIME_CHANGED EXPAND=FALSE
*DECK DECK=SYP$CONTINUE_TO_CAUSE EXPAND=FALSE
 PROCEDURE [XREF] syp$continue_to_cause (mf: ost$monitor_fault;
        ctc: ^ost$minimum_save_area;
        continue_option: syt$continue_option;
    VAR final_continue_option: syt$continue_option);
?? PUSH (LISTEXT := ON) ??
*copyc ost$monitor_fault
*copyc ost$stack_frame_save_area
*copyc syt$system_core_condition
?? POP ??
*DECK DECK=SYP$CONVERT_BYTES EXPAND=FALSE

  PROCEDURE [XREF] syp$convert_bytes
    (    p: ^packed array [1 .. 1000] OF 0 .. 0f(16);
         length: integer;
     VAR msg: string ( * );
         add_to_eol: boolean);
*DECK DECK=SYP$CORE_HANG_IF_SYSTEM_JRT_SET EXPAND=FALSE

  PROCEDURE [INLINE] syp$core_hang_if_system_jrt_set
    (    test_number: 0 .. 255);

?? PUSH (LISTEXT := ON) ??

    VAR
      local_status: ost$status,
      display_string: string (60),
      display_length: integer;

    IF test_number IN syv$test_jr_system THEN
      STRINGREP (display_string, display_length,
            ' CORE Hanging for system jrt ', test_number);
      ofp$display_status_msg_helper (display_string (1, display_length),
            local_status);
      REPEAT
        syp$wait (1000);
        #SPOIL (syv$test_jr_system);
      UNTIL NOT (test_number IN syv$test_jr_system);
    IFEND;
  PROCEND syp$core_hang_if_system_jrt_set;
*copyc dfc$test_jr_constants
*copyc ofp$display_status_msg_helper
*copyc syp$wait
*copyc syv$test_jr_system
?? POP ??
*DECK DECK=SYP$CRACK_COMMAND EXPAND=FALSE

  PROCEDURE [XREF] syp$crack_command (pdt: array [1 .. * ] OF syt$parameter_descriptor;
        text: string ( * );
    VAR pvt: array [1 .. * ] OF syt$parameter_value;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc SYT$VALUE_KINDS
*copyc OST$STATUS
?? POP ??
*DECK DECK=SYP$CREATE_JOB_TEMPLATE EXPAND=FALSE

   PROCEDURE [XREF] syp$create_job_template
     (    ijlo: jmt$ijl_ordinal;
          job_class: jmt$job_class;
          sdt_p: mmt$max_sdt_p;
          sdtx_p: mmt$max_sdtx_p;
      VAR template_created: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_class
*copyc jmt$ijl_ordinal
*copyc mmt$segment_descriptor_table
*copyc mmt$segment_descriptor_table_ex
?? POP ??
*DECK DECK=SYP$CYCLE EXPAND=FALSE
 PROCEDURE [INLINE] syp$cycle;
?? PUSH (LISTEXT := ON) ??

    TYPE
      psa_type = record
      fill: 0 .. 0ffff(16),
      p: ^cell,
      a0,a1: integer,
      fill2: 0 .. 0ffff(16),
      a2: ^psa_type,
      recend;

    VAR
      psa: ^psa_type,
      cycle_task: tmt$rb_cycle;

    psa := #previous_save_area();
    cycle_task.reqcode := syc$rc_cycle;
    cycle_task.code := tmc$cyc_sypcycle;
    cycle_task.p1 := psa^.p;
    IF psa^.a2 = NIL THEN
      cycle_task.p2 := NIL;
    ELSE
      cycle_task.p2 := psa^.a2^.p;
    IFEND;
    cycle_task.lock_value := 0;
    i#call_monitor (#LOC (cycle_task), #SIZE (cycle_task));

  PROCEND syp$cycle;
*copyc pmh$cycle
*copyc i#call_monitor
*copyc tmt$rb_cycle
?? POP ??
*DECK DECK=SYP$CYCLE_FOR_LOCK EXPAND=FALSE

 PROCEDURE [INLINE] syp$cycle_for_lock (code: tmc$cycle_reason;
      p: ^ost$signature_lock);
?? PUSH (LISTEXT := ON) ??

    VAR
      cnv: RECORD
        case boolean of
        = false=
          i: integer,
        = true =
          f: 0 .. 0ffff(16),
          p: ^cell,
        casend, recend,
      cycle_task: tmt$rb_cycle;

    cycle_task.reqcode := syc$rc_cycle;
    cycle_task.code := code;
    cnv.i := #read_register(64);
    cycle_task.p1 := cnv.p;
    cycle_task.p2 := p;
    cycle_task.lock_value := p^.lock_id;
    i#call_monitor (#LOC (cycle_task), #SIZE (cycle_task));
  PROCEND syp$cycle_for_lock;
*copyc pmh$cycle
*copyc i#call_monitor
*copyc tmt$rb_cycle
*copyc ost$signature_lock
?? POP ??
*DECK DECK=SYP$DEACTIVATE_JOB_TEMPLATE EXPAND=FALSE
PROCEDURE [XREF] syp$deactivate_job_template (
  template_name: ost$name;
  VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc ost$name
*copyc ost$status
?? POP ??
*DECK DECK=SYP$DECREMENT_SERVER_FILE_COUNT EXPAND=FALSE

 PROCEDURE [XREF] SYP$DECREMENT_SERVER_FILE_COUNT;
*DECK DECK=SYP$DETERMINE_MAINFRAME_TYPE EXPAND=FALSE

  PROCEDURE [XREF] syp$determine_mainframe_type;
*DECK DECK=SYP$DISABLE_JOB_RECOVERY EXPAND=FALSE
PROCEDURE [XREF] syp$disable_job_recovery;
*DECK DECK=SYP$DISESTABLISH_COND_HANDLER EXPAND=FALSE
 PROCEDURE [INLINE] syp$disestablish_cond_handler;
?? PUSH (LISTEXT := ON) ??

    #write_register (0e2(16), 0);
  PROCEND syp$disestablish_cond_handler;
?? POP ??
*DECK DECK=SYP$DISPLAY_BAM_TABLES EXPAND=FALSE

  PROCEDURE [XREF] syp$display_bam_tables
    (    initial_pdu_pointer: ^fmt$path_description_unit;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_description_unit
*copyc ost$status
?? POP ??
*DECK DECK=SYP$DISPLAY_COMMAND EXPAND=FALSE
*DECK DECK=SYP$DISPLAY_DEADSTART_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] syp$display_deadstart_message
   (     message: string ( * ));
*DECK DECK=SYP$DISPLAY_FILES EXPAND=FALSE

  PROCEDURE [XREF] syp$display_files
    (    initial_pdu_pointer: ^fmt$path_description_unit;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_description_unit
*copyc ost$status
?? POP ??
*DECK DECK=SYP$DISPLAY_GLOBAL_FILE_INFO EXPAND=FALSE

  PROCEDURE [XREF] syp$display_global_file_info
    (    gfi: ^bat$global_file_information;
         indent: bat$display_tables_indention;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc bat$display_tables_indention
*copyc bat$global_file_information
*copyc ost$status
?? POP ??

*DECK DECK=SYP$DISPLAY_PATHS EXPAND=FALSE


  PROCEDURE [XREF] syp$display_paths
    (    initial_pdu_pointer: ^fmt$path_description_unit;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_description_unit
*copyc ost$status
?? POP ??
*DECK DECK=SYP$DISPLAY_PDE EXPAND=FALSE

  PROCEDURE [XREF] syp$display_pde
    (    path_description_entry: ^fmt$path_description_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fmt$path_description_entry
*copyc ost$status
?? POP ??
*DECK DECK=SYP$DISPLAY_TIME_ZONE_COMMAND EXPAND=FALSE
*DECK DECK=SYP$ENABLE_JOB_FREE_FLAG EXPAND=FALSE
  PROCEDURE [XREF] syp$enable_job_free_flag;


*DECK DECK=SYP$ENABLE_JOB_RECOVERY EXPAND=FALSE
PROCEDURE [XREF] syp$enable_job_recovery;
*DECK DECK=SYP$ESTABLISH_CONDITION_HANDLER EXPAND=FALSE
 PROCEDURE [INLINE] syp$establish_condition_handler (handler:
    syt$condition_handler);
?? PUSH (LISTEXT := ON) ??

    VAR
      csf: ^^syt$established_handler,
      eh: ^syt$established_handler;

    csf := #current_stack_frame ();
    PUSH eh;
    eh^.handler := handler;
    csf^ := eh;
    #write_register (0e2(16), 1);

  PROCEND syp$establish_condition_handler;
?? POP ??
?? PUSH (LISTEXT := ON) ??
*copyc ost$stack_frame_save_area
*copyc syt$established_handler
*copyc syt$condition_handler
?? POP ??
*DECK DECK=SYP$FETCH_SYSTEM_CONSTANT EXPAND=FALSE

  PROCEDURE [XREF] syp$fetch_system_constant (VAR name: string ( * );
    VAR index: integer;
    VAR value: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=SYP$GET_JOB_SWAP_STATUS EXPAND=FALSE
  PROCEDURE [XREF] syp$get_job_swap_status
    (ijl_ordinal: jmt$ijl_ordinal;
     VAR swapped_out: boolean);
?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
?? POP ??
*DECK DECK=SYP$GET_SYSTEM_TASK_STATUS EXPAND=FALSE

  PROCEDURE [XREF] syp$get_system_task_status
    (VAR task_status: syt$system_task_status);

?? PUSH (LISTEXT := ON) ??
*copyc syt$system_task_status
?? POP ??
*DECK DECK=SYP$GET_TOKEN EXPAND=FALSE

  PROCEDURE [XREF] syp$get_token (text: string ( * );
        upper_case: boolean;
    VAR index: 0 .. 255;
    VAR token: ost$string;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc OST$STRING
?? POP ??
*DECK DECK=SYP$HANG_IF_JOB_JRT_SET EXPAND=FALSE
 PROCEDURE [INLINE] syp$hang_if_job_jrt_set (test_number: 0 .. 255);
?? PUSH (LISTEXT := ON) ??

    VAR
      local_status: ost$status,
      display_string: string (ofc$max_display_message),
      display_length: integer;

    IF test_number IN syv$test_jr_job THEN
      STRINGREP (display_string, display_length, ' Hanging for job jrt ',
            test_number);
      ofp$display_status_message (display_string (1, display_length),
            local_status);
      REPEAT
        pmp$wait (1000, 1000);
        #SPOIL (syv$test_jr_job);
      UNTIL NOT (test_number IN syv$test_jr_job);
    IFEND;
  PROCEND syp$hang_if_job_jrt_set;

*copyc syc$test_jr_constants
*copyc dfc$test_jr_constants
*copyc ofp$display_status_message
*copyc pmp$wait
*copyc syv$test_jr_job
?? POP ??
*DECK DECK=SYP$HANG_IF_SYSTEM_JRT_SET EXPAND=FALSE

 PROCEDURE [INLINE] syp$hang_if_system_jrt_set (test_number: 0 .. 255);
?? PUSH (LISTEXT := ON) ??

    VAR
      local_status: ost$status,
      display_string: string (ofc$max_display_message),
      display_length: integer;

    IF test_number IN syv$test_jr_system THEN
      STRINGREP (display_string, display_length, ' Hanging for system jrt ',
            test_number);
      ofp$display_status_message (display_string (1, display_length),
            local_status);
      REPEAT
        #SPOIL (syv$test_jr_system);
        pmp$wait (1000, 1000);
      UNTIL NOT (test_number IN syv$test_jr_system);
    IFEND;
  PROCEND syp$hang_if_system_jrt_set;
*copyc dfc$test_jr_constants
*copyc ofp$display_status_message
*copyc pmp$wait
*copyc syv$test_jr_system
?? POP ??
*DECK DECK=SYP$IDLE_SYSTEM_CORE EXPAND=FALSE

  PROCEDURE [XREF] syp$idle_system_core (message: string ( * );
        idle_code: syt$180_idle_code);

?? PUSH (LISTEXT := ON) ??
*copyc syt$180_idle_code
?? POP ??

*DECK DECK=SYP$INCREMENT_AVT_R1 EXPAND=FALSE

  PROCEDURE [XREF] syp$increment_avt_r1
    (    sfid: gft$system_file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??
*DECK DECK=SYP$INCREMENT_FILE_RCV_FAILURE EXPAND=FALSE

  PROCEDURE [XREF] syp$increment_file_rcv_failure;
*DECK DECK=SYP$INCREMENT_SERVER_FILE_COUNT EXPAND=FALSE

PROCEDURE [XREF] SYP$INCREMENT_SERVER_FILE_COUNT;
*DECK DECK=SYP$INIDD_COMMAND EXPAND=FALSE
*DECK DECK=SYP$INITIALIZE_JOB EXPAND=FALSE
  PROCEDURE [XREF] syp$initialize_job;
*DECK DECK=SYP$INITIALIZE_JOB_MODE EXPAND=FALSE
  PROCEDURE [XREF] syp$initialize_job_mode;
*DECK DECK=SYP$INITIALIZE_JOB_TEMPLATE EXPAND=FALSE
  PROCEDURE [XREF] syp$initialize_job_template
    (    update_trap_handler: boolean;
         trap_handler: ^procedure);
*DECK DECK=SYP$INITIALIZE_JT_PTR_ARRAY EXPAND=FALSE

  PROCEDURE [XREF] syp$initialize_jt_ptr_array (
        p_cell_ptr_array: ^array [1 .. * ] OF ^cell);

*DECK DECK=SYP$INITIALIZE_SYSCORE_TEMPLATE EXPAND=FALSE

  PROCEDURE [XREF] syp$initialize_syscore_template;
*DECK DECK=SYP$INITIALIZE_TIME_AND_DATE EXPAND=FALSE
*DECK DECK=SYP$INJECT_HARDWARE_FAULTS EXPAND=FALSE

  PROCEDURE [XREF] syp$inject_hardware_faults
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
*copyc ost$status
?? POP ??
*DECK DECK=SYP$INVALIDATE_OPEN_SFID EXPAND=FALSE

  PROCEDURE [XREF] syp$invalidate_open_sfid
    (    sfid: gft$system_file_identifier;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc ost$status
?? POP ??

*DECK DECK=SYP$INVOKE_SYSTEM_DEBUGGER EXPAND=FALSE

  PROCEDURE [XREF] syp$invoke_system_debugger
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
*copyc ost$status
?? POP ??
*DECK DECK=SYP$JOBFILEPROC EXPAND=FALSE

  PROCEDURE [XREF] syp$jobfileproc
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
*copyc ost$status
?? POP ??
*DECK DECK=SYP$JOB_RECOVERY_FLAG_HANDLER EXPAND=FALSE
PROCEDURE [XREF] syp$job_recovery_flag_handler (flag_id: ost$system_flag);
*copyc ost$system_flag
*DECK DECK=SYP$JOB_RECOVERY_FROM_IMAGE EXPAND=FALSE

  PROCEDURE [XREF] syp$job_recovery_from_image
    (    swap_file: ^cell;
         jsn: jmt$system_supplied_name;
     VAR oijlep: ^jmt$initiated_job_list_entry;
     VAR recovery_disposition_available: boolean;
     VAR job_recovery_disposition: jmt$job_recovery_disposition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
*copyc jmt$job_recovery_disposition
*copyc jmt$system_supplied_name
*copyc ost$status
?? POP ??
*DECK DECK=SYP$LOG_RECOVERY_FAILURE EXPAND=FALSE

  PROCEDURE [XREF] syp$log_recovery_failure
    (    msg: string ( * );
         status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=SYP$MEMORY_LINK_DATA_CONVERSION EXPAND=FALSE

{NOS/ve to NOS file conversion utility}

PROCEDURE [XREF] syp$memory_link_data_conversion (info: ^syt$conversion_info;
          buffer: ^cell;
      VAR length: integer);

TYPE
  syt$conversion_info = RECORD
    conversion_type: syt$data_conversions,
    file_pointer: ^SEQ (*),
    save_area: integer,
  RECEND;
*copyc syt$data_conversions
*DECK DECK=SYP$MFH_FOR_HANG_TASK EXPAND=FALSE

  PROCEDURE [XREF] syp$mfh_for_hang_task;
*DECK DECK=SYP$MTR_HANG_IF_SYSTEM_JRT_SET EXPAND=FALSE


 PROCEDURE [INLINE] syp$mtr_hang_if_system_jrt_set (test_number: 0 .. 255);
?? PUSH (LISTEXT := ON) ??

    VAR
     count: integer;

    IF test_number IN syv$test_jr_system THEN
      count := count + 1;
      display_integer_monitor ( ' Hang monitor JRT test ', test_number);
      REPEAT
        { Give it something to do - even though youll never get out of here.
        count := count + 1;
        #SPOIL (syv$test_jr_system);
        count := count - 1 + 1;
      UNTIL NOT (test_number IN syv$test_jr_system);
    IFEND;
  PROCEND syp$mtr_hang_if_system_jrt_set;
*copyc dfc$test_jr_constants
*copyc syv$test_jr_system
*copyc dfi$monitor_display
?? POP ??
*DECK DECK=SYP$ORDER_JOB_FIXED_PAGES EXPAND=FALSE

  PROCEDURE [XREF] syp$order_job_fixed_pages
    (    job_page_count: mmt$page_frame_index;
         sfdp: ^jst$swap_file_descriptor;
         job_fixed_offset_list: ^array [0 .. *] of integer;
     VAR job_fixed: ^array [0 .. 7fffffff(16)] of cell;
     VAR job_fixed_segn: ost$segment;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jst$swap_file_descriptor
*copyc mmt$page_frame_index
*copyc ost$status
?? POP ??

*DECK DECK=SYP$OUTWARD_CALL EXPAND=FALSE

  PROCEDURE [XREF] syp$outward_call (cbp_p: ^ost$external_code_base_pointer;
        stack_p: ^cell;
        ring: 0 .. 15);
?? PUSH (LISTEXT := ON) ??
*copyc OSD$CODE_BASE_POINTER
?? POP ??
*DECK DECK=SYP$PACKAGE_FLAW_COMMANDS EXPAND=FALSE
*DECK DECK=SYP$POP_INHIBIT_JOB_RECOVERY EXPAND=FALSE
 PROCEDURE [XREF] syp$pop_inhibit_job_recovery;

*DECK DECK=SYP$PREPARE_DEADSTART_DISPLAY EXPAND=FALSE
 PROCEDURE [XREF] syp$prepare_deadstart_display;
*DECK DECK=SYP$PROCESS_COMMAND_LINE EXPAND=FALSE

  PROCEDURE [XREF] syp$process_command_line
    (    text: string ( * );
         aux_command_table_p: ^ARRAY [1 .. * ] OF syt$command_table_entry;
         id: dpt$window_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
*copyc ost$status
*copyc syt$command_table_entry
?? POP ??
*DECK DECK=SYP$PROCESS_CORE_COMMANDS EXPAND=FALSE

  PROCEDURE [XREF] syp$process_core_commands
    (    window: dpt$window_id;
         quit_command: string ( * );
         aux_command_table_p: ^ARRAY [1 .. * ] OF syt$command_table_entry;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
*copyc ost$status
*copyc syt$command_table_entry
?? POP ??
*DECK DECK=SYP$PROCESS_DEADSTART_COMMANDS EXPAND=FALSE

  PROCEDURE [XREF] syp$process_deadstart_commands (VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=SYP$PROCESS_DEADSTART_STATUS EXPAND=FALSE

  PROCEDURE [XREF] syp$process_deadstart_status
    (    message: string ( * );
         fatal_status: boolean;
         status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=SYP$PROCESS_JOB_RCV_FAILURE EXPAND=FALSE

  PROCEDURE [XREF] syp$process_job_rcv_failure
    (    msg: string (*),
         status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=SYP$PURGE_INSTRUCTION_STACK EXPAND=FALSE

  PROCEDURE [XREF] syp$purge_instruction_stack;

*DECK DECK=SYP$PUSH_INHIBIT_JOB_RECOVERY EXPAND=FALSE
 PROCEDURE [XREF] syp$push_inhibit_job_recovery;
*DECK DECK=SYP$RECOVER_EXECUTING_AJL_ORD EXPAND=FALSE
?? LEFT := 1, RIGHT := 110 ??

 PROCEDURE [XREF] syp$recover_executing_ajl_ord;
*DECK DECK=SYP$RECOVER_JOB_R1 EXPAND=FALSE

  PROCEDURE [XREF] syp$recover_job_r1
    (    swap_file: ^cell;
         jcb: ^jmt$job_control_block;
         oijlep: ^jmt$initiated_job_list_entry;
     VAR recovery_disposition_available: boolean;
     VAR job_recovery_disposition: jmt$job_recovery_disposition;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
*copyc jmt$job_recovery_disposition
*copyc ost$status
?? POP ??
*DECK DECK=SYP$REPLACE_SFID EXPAND=FALSE

  PROCEDURE [XREF] syp$replace_sfid
    (    old_sfid: gft$system_file_identifier;
         new_sfid: gft$system_file_identifier;
         access_state: mmt$segment_access_state;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc gft$system_file_identifier
*copyc mmt$segment_access_state
*copyc ost$status
?? POP ??
*DECK DECK=SYP$RESET_MAXIMUM_TIME EXPAND=FALSE

  PROCEDURE [XREF] syp$reset_maximum_time;

*DECK DECK=SYP$RETURN_JOBS_R1_RESOURCES EXPAND=FALSE

  PROCEDURE [XREF] syp$return_jobs_r1_resources;
*DECK DECK=SYP$SETIT_COMMAND EXPAND=FALSE
*DECK DECK=SYP$SET_COMMAND EXPAND=FALSE
*DECK DECK=SYP$SET_JOB_DEBUG_RING EXPAND=FALSE
PROCEDURE [XREF] syp$set_job_debug_ring (ring: ost$ring);

*copyc osd$virtual_address
*DECK DECK=SYP$SET_MAINFRAME_RECOVERED EXPAND=FALSE

  PROCEDURE [XREF] syp$set_mainframe_recovered (mainframe_recovered: boolean);
*DECK DECK=SYP$SET_PROCESSOR_ATTRIBUTES EXPAND=FALSE
*DECK DECK=SYP$SET_PROCESS_INTERVAL_TIMER EXPAND=FALSE

  PROCEDURE [XREF] syp$set_process_interval_timer (pit_value: 0 .. 7fffffff(16);
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=SYP$SET_SECURITY_OPTION_COMMAND EXPAND=FALSE
*DECK DECK=SYP$SET_STATUS_FROM_MTR_STATUS EXPAND=FALSE
  PROCEDURE [INLINE] syp$set_status_from_mtr_status (monitor_status:
    syt$monitor_status;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
    status.normal := monitor_status.normal;
    IF NOT status.normal THEN
      osp$set_status_abnormal ('SY', monitor_status.condition, '', status);
    IFEND;

  PROCEND syp$set_status_from_mtr_status;
*copyc ost$status
*copyc osp$set_status_abnormal
*copyc syt$monitor_status
?? POP ??
*DECK DECK=SYP$SET_SYSTEM_IDLING EXPAND=FALSE

  PROCEDURE [XREF] syp$set_system_idling (
        system_is_idling: boolean);
*DECK DECK=SYP$SET_TIME_ZONE_COMMAND EXPAND=FALSE
*DECK DECK=SYP$STORE_SYSTEM_CONSTANT EXPAND=FALSE

  PROCEDURE [XREF] syp$store_system_constant (name: string ( * );
        index: integer;
        value: integer;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=SYP$SYSTEM_IS_IDLING EXPAND=FALSE

  FUNCTION [XREF] syp$system_is_idling : boolean;
*DECK DECK=SYP$TERMINATE_TASK EXPAND=FALSE

   PROCEDURE [XREF] syp$terminate_task
     (    terminate_reason: ost$ring1_termination_reason);

?? PUSH (LISTEXT := ON) ??
*copyc ost$ring1_termination_reason
?? POP ??
*DECK DECK=SYP$TEST_JOB_RECOVERY EXPAND=FALSE

  PROCEDURE [XREF] syp$test_job_recovery
    (    text: string ( * );
         id: dpt$window_id;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
*copyc ost$status
?? POP ??
*DECK DECK=SYP$TRACE_DEADSTART_MESSAGE EXPAND=FALSE

  PROCEDURE [XREF] syp$trace_deadstart_message
    (    message: string ( * ));
*DECK DECK=SYP$UPDATE_FLAGS EXPAND=FALSE

  PROCEDURE [XREF] syp$update_flags
    (    xcb_p: ^ost$execution_control_block;
         ptl_p: ^tmt$primary_task_list;
     VAR flags_updated: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc ost$execution_control_block
*copyc tmt$primary_task_list
?? POP ??
*DECK DECK=SYP$USECP_COMMAND EXPAND=FALSE
*DECK DECK=SYP$USEIC_COMMAND EXPAND=FALSE
*DECK DECK=SYP$VERIFY_ACCESS EXPAND=FALSE

  PROCEDURE [XREF] syp$verify_access
    (    access_type: (syc$readable, syc$writeable);
         cell_pp: ^^cell;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=SYP$WAIT EXPAND=FALSE

  PROCEDURE [XREF] syp$wait (milliseconds: 0..0ffffffffffff(16));

?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
?? POP ??
*DECK DECK=SYP$WAIT_SYSTEM_RESUME EXPAND=FALSE

  PROCEDURE [XREF] syp$wait_system_resume;

*DECK DECK=SYP$WRITE_JOB_FIXED_PAGES EXPAND=FALSE

  PROCEDURE [XREF] syp$write_job_fixed_pages
    (    job_fixed_page_count: mmt$page_frame_index;
         job_fixed: ^array [0 .. 7fffffff(16)] of cell;
         sfdp: ^jst$swap_file_descriptor;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_frame_index
*copyc jst$swap_file_descriptor
*copyc ost$status
?? POP ??
*DECK DECK=SYP$WRITE_OUTPUT_HEADER EXPAND=FALSE

  PROCEDURE [XREF] syp$write_output_header
    (    title_part_1: string ( * );
         title_part_2: string ( * ));

*DECK DECK=SYP$WRITE_OUTPUT_LINE EXPAND=FALSE

  PROCEDURE [XREF] syp$write_output_line
    (    s: string ( * );
      VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=SYT$180_IDLE_CODE EXPAND=FALSE

{This deck defines values for the idle status of NOS/VE.

  TYPE
    syt$180_idle_code = (syc$ic_null,
        syc$ic_system_terminated,

{  System is ABORTED for the next two codes}

        syc$ic_fatal_hardware_error,
        syc$ic_fatal_software_error,

{  System is IDLED for the next three codes}

        syc$ic_long_power,
        syc$ic_hardware_idle,
        syc$ic_idle_command,

{  System is STEPPED for all following codes}

        syc$ic_step_command,
        syc$ic_short_power,
        syc$ic_disk_error,
        syc$ic_software_breakpoint);

*DECK DECK=SYT$CHANGE_TIME_DATA EXPAND=FALSE
*DECK DECK=SYT$COMMAND_TABLE_ENTRY EXPAND=FALSE

  { Define command table for system core command processor.

  TYPE
    syt$command_table_entry = RECORD
      short_name: string (8),
      long_name: string (31),
      repeatable_command: boolean,
      proc_p: ^procedure
                 (    text: string ( * );
                      id: dpt$window_id;
                  VAR status: ost$status),
    RECEND;

*copyc dpt$window_id
*copyc ost$status
*DECK DECK=SYT$CONDITION_HANDLER EXPAND=FALSE
  TYPE
    syt$condition_handler = ^procedure (mf: ost$monitor_fault;
      continue: ^ost$minimum_save_area;
      VAR continue: syt$continue_option);
??PUSH(LISTEXT:=ON)??
*copyc syt$established_handler
*copyc syt$system_core_condition
??POP??
*DECK DECK=SYT$DATA_CONVERSIONS EXPAND=FALSE


 TYPE
    syt$data_conversions = (syc$64_char_ascii_to_ascii,
      syc$ascii_to_64_char_ascii, syc$64_display_code_to_ascii,
      syc$ascii_to_64_display_code, syc$8_in_12_to_ascii, syc$ascii_to_8_in_12,
      syc$63_display_code_to_ascii, syc$ascii_to_63_display_code,
      syc$63_char_ascii_to_ascii, syc$ascii_to_63_char_ascii,
      syc$56_bit_binary_to_64_bit, syc$64_bit_binary_to_56_bit,
      syc$60_bit_binary_to_64_bit, syc$64_bit_binary_to_60_bit,
      syc$32_bit_binary_to_64_bit, syc$64_bit_binary_to_32_bit,
      syc$ascii_t_records_to_812,
      syc$60_bit_binary_to_60_bit,
      syc$no_conversion);
*DECK DECK=SYT$DEBUG_CONTROL EXPAND=FALSE
{Define record used for Debug control in the system core.
{WARNING - If changes are made to this deck, SYADCTL must also be updated.
{          SYADCTL is the assembly language version of this declaration.

  TYPE
    syt$debug_control = record
      debug_active: boolean,
      high_ring_for_debug: 0 .. 15,
      debug_list_p: ^cell,
      trap_proc: ^procedure,
      trapped_sfsa: ^cell,
      debug_mask: ost$debug_mask,
      selected_ucr_conditions: packed array [ost$user_condition] of boolean,
      debug_job_monitors: boolean,
      debug_user_tasks: boolean,
      selected_ajl_ordinals: packed array [0 .. jmc$max_ajl_ord] of boolean,
      set_debug_bit_in_um: boolean,
      waiting_for_input: boolean,
    recend;
*copyc OSD$CONDITIONS
*copyc ost$debug_mask
*copyc jmc$maximum_constants
*DECK DECK=SYT$DEBUG_OUTPUT_DISPOSAL_INFO EXPAND=FALSE

  TYPE
    syt$debug_output_disposal_info = RECORD
      output_destination: syt$debug_output_disposition,
      job_and_file_name: jmt$system_supplied_name,
    RECEND;

?? PUSH (LISTEXT := ON) ??
*copyc jmt$system_supplied_name
*copyc syt$debug_output_disposition
?? POP ??
*DECK DECK=SYT$DEBUG_OUTPUT_DISPOSITION EXPAND=FALSE

  TYPE
    syt$debug_output_disposition = (syc$dod_null, syc$dod_write_for_print,
          syc$dod_save_on_pf, syc$dod_save_and_print);

*DECK DECK=SYT$DFLT_DEBUG_OUTPUT_DISPOSAL EXPAND=FALSE

  TYPE
    syt$dflt_debug_output_disposal = record
      case 0 .. 1 of
      = 0 =
        byte: 0 .. 255,
      = 1 =
        disposal: syt$debug_output_disposition,
      casend,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc syt$debug_output_disposition
?? POP ??
*DECK DECK=SYT$ESTABLISHED_HANDLER EXPAND=FALSE
 TYPE
    syt$established_handler = record
      handler: syt$condition_handler,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc mmd$segment_access_condition
*copyc ost$monitor_fault
*copyc ost$stack_frame_save_area
*copyc syt$system_core_condition
*copyc tmt$broken_task_monitor_fault
*copyc tmt$mcr_faults
*copyc tmt$monitor_fault_buffer
?? POP ??
*DECK DECK=SYT$FAILURE_REASON_LIST EXPAND=FALSE

  CONST
    syc$failure_condition_limit = 30,
    syc$failure_reason_msg_size = sfc$max_descriptive_data_size - pmc$mainframe_id_size - 1;

  TYPE
    syt$failure_reason_list = ARRAY [1 .. *] of syt$failure_reason,

    syt$failure_reason = RECORD
      message: string (syc$failure_reason_msg_size),
      conditions: ARRAY [1 .. syc$failure_condition_limit] OF syt$failure_conditions,
      CASE 0 .. 1 OF
      = 0 =
        msg_count: 0 .. 0ffffffff(16),
        conditions_count: 0 .. 0ffffffff(16),
      = 1 =
        count_word: integer,
      CASEND,
    RECEND,

    syt$failure_conditions = RECORD
      CASE 0 .. 1 OF
      = 0 =
        code_count: 0 .. 0ffffff(16),
        code: ost$status_condition_code,
      = 1 =
        code_word: integer,
      CASEND,
     RECEND;

*copyc ost$status_condition_code
*copyc pmt$mainframe_id
*copyc sft$descriptive_data
*DECK DECK=SYT$HARDWARE_FAULT_KIND EXPAND=FALSE

{  Define kinds of hardware faults that can be injected.

  TYPE
    syt$hardware_fault_kind = syc$hfk_retry .. syc$hfk_max_hardware_fault_kind;

*copyc syc$hardware_fault_codes
*DECK DECK=SYT$HARDWARE_FAULT_REQUEST EXPAND=FALSE

{  Define type for kinds of hardware faults that can be injected and utility
{  monitor requests to support hardware fault injection.

  TYPE
    syt$hardware_fault_request = syc$hfk_retry .. syc$hfk_uf_max_value;

*copyc syc$hardware_fault_codes

*DECK DECK=SYT$JOB_RECOVERY_STEP EXPAND=FALSE
 TYPE
    syt$job_recovery_step = (syc$jrs_job_damaged_dont_rec,
      syc$jrs_initial_step, syc$jrs_test_sc_step, syc$jrs_sc_step,
      syc$jrs_jt_step, syc$jrs_test_jt_step, syc$jrs_recovery_complete);
*DECK DECK=SYT$MONITOR_FLAG EXPAND=FALSE
{ This deck defines system core flag numbers.
{ Please note that the order of these flags is very important.
{ The flags are processed from lowest to highest number.
{ Any changes made to this deck, must also be reflected in
{ the assembly language version- SYA$MONITOR_FLAG_HANDLERS.
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{


  TYPE
    syt$monitor_flag = (tmc$mf_cause_job_free_flag_trap, syc$mf_hang_task,
       syc$mf_cause_job_recovery, mmc$mf_volume_unavailable, syc$mf_invoke_sysdebug,
       syc$mf_system_debugger, syc$mf_dump_job_environment, mmc$mf_segment_mgr_flag,
       syc$mf_cpu_configuration_change, mmc$mf_shadow_file_reference,
       syc$mf_for_keypoint_traceback, syc$mf_spare_11, syc$mf_spare_12,
       syc$mf_spare_13, syc$mf_spare_14, syc$mf_spare_15);

*DECK DECK=SYT$MONITOR_FLAGS EXPAND=FALSE
{Define Monitor Flags.

  TYPE
    syt$monitor_flags = set of syt$monitor_flag;

*copyc SYT$MONITOR_FLAG
*DECK DECK=SYT$MONITOR_REQUEST_CODE EXPAND=FALSE
{!!!!!! users of this deck should change to copy SYT$MONITOR_STATUS.
*copyc OST$STATUS
*copyc syt$monitor_status
*DECK DECK=SYT$MONITOR_STATUS EXPAND=FALSE
{This deck defines the types for monitor request blocks.

  TYPE
    syt$monitor_status = record
      normal: boolean,
      condition: ost$status_condition,
    recend;

*copyc OST$STATUS
*DECK DECK=SYT$NOS_SYSTEM_TIME EXPAND=FALSE


{  Define type definition for record to initilize NOS/VE date and time.
{  This record contains the NOS date and time in display code and the
{  free running clock at the time the date and time moved from NOS's
{  field length.

  TYPE
    syt$nos_system_time = record
      nos_time_of_day: syt$display_code_word,
      nos_date: syt$display_code_word,
      corresponding_frc: ost$free_running_clock,
    recend,

    syt$display_code_word = packed record
      zero_fill: 0 .. 0f(16),
      dc_char_1: 0 .. 63,
      dc_char_2: 0 .. 63,
      dc_char_3: 0 .. 63,
      dc_char_4: 0 .. 63,
      dc_char_5: 0 .. 63,
      dc_char_6: 0 .. 63,
      dc_char_7: 0 .. 63,
      dc_char_8: 0 .. 63,
      dc_char_9: 0 .. 63,
      dc_char_10: 0 .. 63,
    recend;

?? PUSH (LISTEXT := ON) ??
*copyc OST$HARDWARE_SUBRANGES
?? POP ??
*DECK DECK=SYT$PERF_KEYPOINTS_ENABLED EXPAND=FALSE

    TYPE
      syt$perf_keypoints_enabled = RECORD
        memory_keypoints: boolean,
        heap_keypoints: boolean,
        swapping_keypoints: boolean,
        aging_keypoints: boolean,
        swapping_stack_trace: boolean,
        aging_stack_trace: boolean,
        disk_cache: boolean,
        command_keypoints: boolean,
      RECEND;
*DECK DECK=SYT$RB_INJECT_HARDWARE_FAULT EXPAND=FALSE

{  Define the format of the monitor request for injecting hardware faults in
{  monitor mode.

  TYPE
    syt$rb_inject_hardware_fault = record
      request_code: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      hardware_fault_request: syt$hardware_fault_request,
      traps_enabled: boolean,
      rma: integer,
    recend;

*copyc syt$hardware_fault_kind
*copyc syt$hardware_fault_request
*copyc syt$monitor_request_code
*copyc syc$monitor_request_codes
*DECK DECK=SYT$RB_JOB_RECOVERY EXPAND=FALSE
{ monitor requests for job recovery

  TYPE
    syt$rb_job_recovery = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      ijlo: jmt$ijl_ordinal,
      case subreq: syt$job_recovery_subreq of
      = syc$recover_ptl =
        count: integer,
        task_list_p: ^array [1 .. * ] of syt$ptl_recovery_info,
      casend,
    recend,

    syt$ptl_recovery_info = record
      xcb_offset: 0 .. 7fffffff(16),
      dispatching_priority: jmt$dispatching_priority,
      gtid: ost$global_task_id,
    recend,

    syt$job_recovery_subreq = (syc$recover_ptl, syc$dummy_job_recovery);

?? PUSH (LISTEXT := ON) ??
*copyc tmt$primary_task_list
*copyc syt$monitor_request_code
*copyc syc$monitor_request_codes
?? POP ??
*DECK DECK=SYT$SMU_REQUEST_RESPONSE_BLOCK EXPAND=FALSE
{This deck defines the format of the SCB request block for requests to the
{SMU from the 180 OS.

  TYPE
    syt$smu_request_code = (syc$src_null_request, syc$src_fetch_due_info,
      syc$src_deadstart_sma),
    syt$sma_request_code = (syc$sma_noop, syc$sma_deadstart_ve,
      syc$sma_return_to_nos, syc$sma_deadstart_virtual_cpu,
      syc$sma_terminate_cpu, syc$sma_load_virtual_pp),

    syt$smu_request_response_block = record
      reqcode: ALIGNED [0 MOD 8] syt$smu_request_code,
      case syt$smu_request_code of
      = syc$src_null_request =
        fill01: string (40),
      = syc$src_fetch_due_info =
        processor_error: ALIGNED [0 MOD 8] boolean,
        memory_error: boolean,
        unlogged_memory_error: boolean,
        fill11: boolean,
        rma: 0 .. 0ffffffff(16),
      = syc$src_deadstart_sma =
        sma_request: syt$sma_request_code,
        sma_load_pp: 0 .. 31,
        cpu_ordinal: 0 .. 32,
        load_rma: 0 .. 0ffffffff(16),
      casend,
    recend;
*DECK DECK=SYT$SYSTEM_CORE_CONDITION EXPAND=FALSE

  TYPE
    syt$system_core_condition = record
      sfsa: ^ost$stack_frame_save_area,
      case condition: 0 .. 0ff(16) of
      = syc$ucr_condition =
        ucr: ost$user_conditions,
      = syc$user_defined_condition =
        user_defined_condition: syt$user_defined_condition,
      casend,
    recend,
    syt$continue_option = (syc$condition_processed,
      syc$condition_ignored);

*copyc osd$conditions
*copyc ost$stack_frame_save_area
*copyc syc$system_core_cond_constants
*copyc syt$user_defined_condition
*DECK DECK=SYT$SYSTEM_TASK_STATUS EXPAND=FALSE
{ The following type describes the possible status' of a system task.

  TYPE
    syt$system_task_status = (syc$sts_ok, syc$sts_idle_down_in_progress,
          syc$sts_deactivate_requested);

*DECK DECK=SYT$USER_DEFINED_CONDITION EXPAND=FALSE

  TYPE
    syt$user_defined_condition =(syc$udc_volume_unavailable,
                                 syc$udc_display_cmnd_terminated,
                                 syc$udc_max_debug_output_lines,
                                 syc$udc_debugger_task_timeout);
*DECK DECK=SYT$VALUE_KINDS EXPAND=FALSE
{This common deck contains type declarations that are required to}
{interface to the system core command processor.


{Define parameter value types recognized by command processor.}

  TYPE
    syt$value_kinds = (syc$null_value, syc$integer_value, syc$boolean_value,
      syc$string_value, syc$name_value, syc$pointer_value);


{Command parameter descriptor.}

  TYPE
    syt$parameter_descriptor = record
      required: boolean,
      position: 0 .. 31,
      keyword: string (8),
      case parameter_kind: syt$value_kinds of
      = syc$integer_value =
        idefault,
        imin,
        imax: integer,
      = syc$name_value =
        namedef: ost$name,
      = syc$boolean_value =
        bdefault: boolean,
      = syc$pointer_value =
        ptr_default: ^cell,
      = syc$string_value =
        text_default : ost$string,
      casend,
    recend;


{Command parameter value descriptor.}

  TYPE
    syt$parameter_value = record
      defined: boolean,
      case parameter_kind: syt$value_kinds of
      = syc$integer_value =
        int: integer,
      = syc$string_value =
        text: ost$string,
      = syc$name_value =
        name: ost$name,
      = syc$boolean_value =
        bool: boolean,
      = syc$pointer_value =
        ptr: ^cell,
      casend,
    recend;


*copyc OST$NAME
*copyc OST$STRING
*DECK DECK=SYV$ALL_JOBS_SELECTED_FOR_DEBUG EXPAND=FALSE

  VAR
    syv$all_jobs_selected_for_debug: [XREF] boolean;

*DECK DECK=SYV$CHANGE_TIME_DATA EXPAND=FALSE
*DECK DECK=SYV$CLONE_ENABLED EXPAND=FALSE
  VAR
    syv$clone_enabled: [XREF] boolean;
*DECK DECK=SYV$DB_DISPLAYED_CONSOLE_LINES EXPAND=FALSE

  VAR
    syv$db_displayed_console_lines: [XREF] integer;

*DECK DECK=SYV$DB_PAGE_WAIT_LINES_INSTANCE EXPAND=FALSE

  VAR
    syv$db_page_wait_lines_instance: [XREF] integer;

*DECK DECK=SYV$DEBUGGER_DISPLAY_ID EXPAND=FALSE

  VAR
    syv$debugger_display_id: [XREF] dpt$window_id;

?? PUSH (LISTEXT := ON) ??
*copyc dpt$window_id
?? POP ??
*DECK DECK=SYV$DEBUGGER_PAGE_WAIT_LINES EXPAND=FALSE

{ Variable which determines number of lines displayed on the console during
{ a SYSDEBUG session display command.

  VAR
    syv$debugger_page_wait_lines: [XREF] integer;

*DECK DECK=SYV$DEBUG_CONTROL EXPAND=FALSE
{Define the system core debug control record. Note that this record
{is referenced by the dispatcher, system core debugger, and the system core
{trap handler (assembly language).

  VAR
    syv$debug_control: [XREF] syt$debug_control;

?? PUSH (LISTEXT := ON) ??
*copyc SYT$DEBUG_CONTROL
?? POP ??
*DECK DECK=SYV$DEBUG_JOB_RECOVERY EXPAND=FALSE
  VAR
    syv$debug_job_recovery: [XREF]  boolean;
*DECK DECK=SYV$DEBUG_LINE_COUNT EXPAND=FALSE

  VAR
    syv$debug_line_count: [XREF] integer;
*DECK DECK=SYV$DEBUG_OUTPUT_DISPOSAL_INFO EXPAND=FALSE

  VAR
    syv$debug_output_disposal_info: [XREF] syt$debug_output_disposal_info;

?? PUSH (LISTEXT := ON) ??
*copyc syt$debug_output_disposal_info
?? POP ??
*DECK DECK=SYV$DEBUG_OUTPUT_DISPOSITION EXPAND=FALSE

  VAR
    syv$debug_output_disposition: [XREF] syt$debug_output_disposition;

?? PUSH (LISTEXT := ON) ??
*copyc syt$debug_output_disposition
?? POP ??
*DECK DECK=SYV$DEBUG_OUTPUT_DISP_INSTANCE EXPAND=FALSE

  VAR
    syv$debug_output_disp_instance: [XREF] syt$debug_output_disposition;

?? PUSH (LISTEXT := ON) ??
*copyc syt$debug_output_disposition
?? POP ??
*DECK DECK=SYV$DFLT_DEBUG_OUTPUT_DISPOSAL EXPAND=FALSE

  VAR
    syv$dflt_debug_output_disposal: [XREF] syt$dflt_debug_output_disposal;

?? PUSH (LISTEXT := ON) ??
*copyc syt$dflt_debug_output_disposal
?? POP ??
*DECK DECK=SYV$DUMP_TO_PF EXPAND=FALSE

  VAR
    syv$dump_to_pf: [XREF] boolean;

*DECK DECK=SYV$ENABLE_FAULT_INJECTION EXPAND=FALSE

{ The following boolean will be set TRUE by SETSA to enable the fault injection utility.

  VAR
    syv$enable_fault_injection: [XREF] boolean;
*DECK DECK=SYV$ENABLE_HEAP_TRACE EXPAND=FALSE

   VAR
     syv$enable_heap_trace: [XREF] boolean;
*DECK DECK=SYV$FAILURE_REASON_P EXPAND=FALSE

  VAR
    syv$failure_reason_p: [XREF] ^syt$failure_reason_list;

?? PUSH (LISTEXT := ON) ??
*copyc syt$failure_reason_list
?? POP ??
*DECK DECK=SYV$FILE_RCV_FAILURE_COUNT EXPAND=FALSE

  VAR
    syv$file_rcv_failure_count: [XREF] integer;
*DECK DECK=SYV$HALT_ON_EXIT_WITH_IO EXPAND=FALSE

  VAR
    syv$halt_on_exit_with_io: [XREF] boolean;
*DECK DECK=SYV$INHIBIT_CORE_CMD_LOGGING EXPAND=FALSE

  VAR
    syv$inhibit_core_cmd_logging: [XREF] boolean;

*DECK DECK=SYV$JOB_INITIALIZATION_COMPLETE EXPAND=FALSE
  VAR
    syv$job_initialization_complete: [XREF] boolean;
*DECK DECK=SYV$JOB_RECOVERY_OPTION EXPAND=FALSE
  VAR
    syv$job_recovery_option: [XREF] integer;
*copyc syc$job_recovery_enabled
*DECK DECK=SYV$JOB_RECOVERY_STEP EXPAND=FALSE

  VAR
    syv$job_recovery_step: [XREF] syt$job_recovery_step;

?? PUSH (LISTEXT := ON) ??
*copyc syt$job_recovery_step
?? POP ??
*DECK DECK=SYV$JOB_TEMPLATE_CBP EXPAND=FALSE
VAR
  syv$job_template_cbp: [XREF] ost$external_code_base_pointer;
?? PUSH (LISTEXT := ON) ??
*copyc osd$code_base_pointer
?? POP ??
*DECK DECK=SYV$JOB_TEMPLATE_NAME EXPAND=FALSE

  VAR
    syv$job_template_name: [XREF] ost$name;

?? PUSH (LISTEXT := ON) ??
*copyc ost$name
?? POP ??
*DECK DECK=SYV$JOB_TEMPLATE_PTR_ARRAY EXPAND=FALSE
VAR
  syv$job_template_ptr_array: [XREF] ^array [1 .. * ] of ^cell;
*DECK DECK=SYV$MANDATORY_DUALSTATE EXPAND=FALSE

  VAR
    syv$mandatory_dualstate: [XREF] boolean;

*DECK DECK=SYV$MAX_DEBUG_OUTPUT_LINES EXPAND=FALSE

  VAR
    syv$max_debug_output_lines: [XREF] integer;

*DECK DECK=SYV$NOSVE_INTERNAL_OPERATIONS EXPAND=FALSE

  VAR
    syv$nosve_internal_operations: [XREF] boolean;

*DECK DECK=SYV$NOSVE_JOB_TEMPLATE EXPAND=FALSE
VAR
  syv$nosve_job_template: [XREF] boolean;
*DECK DECK=SYV$NOS_SYSTEM_TIME EXPAND=FALSE

  VAR
    syv$nos_system_time: [XREF] syt$nos_system_time;

?? PUSH (LISTEXT := ON) ??
*copyc SYT$NOS_SYSTEM_TIME
?? POP ??
*DECK DECK=SYV$PERF_KEYPOINTS_ENABLED EXPAND=FALSE
  VAR
    syv$perf_keypoints_enabled: [XREF] syt$perf_keypoints_enabled;

*copyc syt$perf_keypoints_enabled
*DECK DECK=SYV$PMF_CB_RM_WORD_ADDRESS EXPAND=FALSE


{  Define XREF variable for the real memory word address of the PFM
{  control block.  This variable is referenced by a PPU.

  VAR
    syv$pmf_cb_rm_word_address: [XREF] ost$real_memory_address;

?? PUSH (LISTEXT := ON) ??
*copyc OST$HARDWARE_SUBRANGES
?? POP ??
*DECK DECK=SYV$READING_DCFILE EXPAND=FALSE

  VAR
    syv$reading_dcfile: [XREF] boolean;
*DECK DECK=SYV$RECOVERING_JOB_COUNT EXPAND=FALSE

  VAR
    syv$recovering_job_count: [XREF] integer;
*DECK DECK=SYV$RECOVERY_FAILURE_COUNT EXPAND=FALSE

  VAR
    syv$recovery_failure_count: [XREF] integer;
*DECK DECK=SYV$REPEATABLE_COMMAND_P EXPAND=FALSE

  VAR
    syv$repeatable_command_p: [XREF] ^string (*);

*DECK DECK=SYV$RUN_ALL_TIMESTAMP EXPAND=FALSE

  VAR
    syv$run_all_timestamp: [XREF, oss$job_fixed] integer;

?? PUSH (LISTEXT := ON) ??
*copyc oss$job_fixed
?? POP ??
*DECK DECK=SYV$SETSA_JOB_RECOVERY_OPTION EXPAND=FALSE
  VAR
    syv$setsa_job_recovery_option: [XREF] integer;
*DECK DECK=SYV$TERMINATE_SYSDEBUG_OUTPUT EXPAND=FALSE

  VAR
    syv$terminate_sysdebug_output: [XREF] boolean;

*DECK DECK=SYV$TEST_JR_JOB EXPAND=FALSE
 VAR
    syv$test_jr_job: [XREF] syt$test_jr_set;

*copyc syc$test_jr_constants
*DECK DECK=SYV$TEST_JR_SYSTEM EXPAND=FALSE
 VAR
    syv$test_jr_system: [XREF] syt$test_jr_set;

*copyc syc$test_jr_constants
*DECK DECK=SYV$USER_TEMPLATES EXPAND=FALSE
VAR
  syv$user_templates: [XREF] boolean;
*DECK DECK=SYV$VERIFY_HEAP_LINKAGE EXPAND=FALSE

   VAR
     syv$verify_heap_linkage: [XREF] boolean;
*DECK DECK=TAPB EXPAND=TRUE

          IDENT  TAPB
          CIPPU
          MEMSEL 16
          TITLE  TAPB
          COMMENT *SMD* LVL=04
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992

*copyc iodmac1 "record definition macros"
*copyc iodmac2 "load/store macros"
*copyc iodmac3 "general macros"
*copyc iodmac4 "general macros"

* PP TABLE.

 PT       RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 PART     PPWORD             PARTNER PP NUMBER
 PIT      RMA                PP INTERFACE TABLE ADDRESS (RMA)
 PITPVA   STRUCT 24          PP INTERFACE TABLE ADDRESS (PVA)

 PT       RECEND
          SPACE  6
* PP INTERFACE TABLE
 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
          ALIGN  0,64
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
          PPWORD             UNUSED
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER
          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)
          ALIGN  32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          SPACE  6
* UNIT DESCRIPTORS.

 UD       RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 UD       RECEND
          SPACE  6
* UNIT INTERFACE TABLE

 UIT      RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
                               = 400B, 844-4X
                               = 401B, 885-1X
                               = 402B, 885-42
 QCNT     PPWORD             QUEUE COUNT
*
          ALIGN  16,64
 UBUFL    PPWORD             UNIT COMMUNICATION BUFFER LENGTH
 UBUF     RMA                UNIT COMMUNICATION BUFFER (RMA)
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

          MASKP  DSABLE
 K.DSABLE EQU    MSK

 UIT      RECEND
          SPACE  6
* PP REQUESTS.

 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS
                               0 - ATTEMPT RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
 LONGB    BOOLEAN            LONG INPUT BLOCK
          ALIGN  0,64
 SECADR   INTEGER            SECONDARY ADDRESS
 CMND     INTEGER            COMMAND SEQUENCE

 RQ       RECEND
          SPACE  6
* PP COMMAND.

 CM       RECORD PACKED

 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$

 CM       RECEND
          SPACE  6
* PP RESPONSE.

 RS       RECORD PACKED

          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
          ALIGN  48,64       ALERT MASK
 LONGB    BOOLEAN            LONG INPUT BLOCK
          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE INTERFACE
                             ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
 CHERR    BOOLEAN            CHANNEL PARITY ERROR ON INPUT
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION
                             OCCURRED ON INPUT OR INADEQUATE DATA RATE ON OUTPUT
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A
                             HARDWARE MALFUNCTION.  EX: UNIT NOT READY,
                             UNIT NOT CONNECTED.
 FTO      BOOLEAN            FUNCTION TIMEOUT
 CHERO    BOOLEAN            CHANNEL PARITY ERROR ON OUTPUT
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 _ INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
                               1 - RECOVERED ERROR
                               2 - COMMAND HAD EXPLICIT RESPONSE FLAG SET
                               3 - BOTH CONDITIONS 1 AND 2
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE
                               1 - UNIT CHANGED FROM READY TO NOT READY
                               2 - UNIT CHANGED FROM NOT READY TO READY
                               3 - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
          ALIGN  48,64       ALERT CONDITIONS
 LNGBLK   BOOLEAN            LONG INPUT BLOCK
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
 PDLIM    BOOLEAN            PHYSICAL DELIMITER ENCOUNTERED (EOT OR BOT)
 LDLIM    BOOLEAN            LOGICAL DELIMITER ENCOUNTERED (TAPE MARK)
 CHARF    BOOLEAN            CHARACTER FILL PERFORMED
 DUNIT    BOOLEAN            UNIT WAS DISABLED BY PP
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)
 RESBID   STRUCT 60          AREA CONTAINING INDIVIDUAL BID RESPONSES FOR THE REQUEST
 CORCNT   STRUCT 2           COUNT OF ON THE FLY CORRECTIONS BY THE TAPE HARDWARE
 RESCNT   STRUCT 2           COUNT OF INDIVIDUAL BID RESPONSES FOR THIS REQUEST
 GSTAT    SUBRANGE 0,1777B   ATS/MAPPED STATUS WORD 1
 CHFL     BOOLEAN            CHARACTER FILL
          SUBRANGE 0,37B
 MSTAT    STRUCT 30          ATS/MAPPED STATUS WORDS 2 THRU 16
 XSTAT    STRUCT 40          ISMT/CMTS EXTENDED STATUS AREA (5 CM WORDS)

          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$
          MASKP  ABALRT
 K.ABALRT EQU    MSK
          MASKP  HDWR
 K.HDWR   EQU    MSK
          MASKP  CHERR
 K.CHERR  EQU    MSK
          MASKP  DATOV
 K.DATOV  EQU    MSK
          MASKP  FTO
 K.FTO    EQU    MSK
          MASKP  LNGBLK
 K.LNGBLK EQU    MSK
          MASKP  PDLIM
 K.PDLIM  EQU    MSK
          MASKP  LDLIM
 K.LDLIM  EQU    MSK
          MASKP  CHARF
 K.CHARF  EQU    MSK
          MASKP  DUNIT
 K.DUNIT  EQU    MSK
          MASKP  CHFL
 K.CHFL   EQU    MSK
          MASKP  CHERO
 K.CHERO  EQU    MSK

 RS       RECEND
          SPACE  6
* PP COMMUNICATION BUFFER.

 CB       RECORD PACKED

          ALIGN  31,64
 SLAVE    BOOLEAN            NONZERO IF SLAVE PP
 PARTNR   RMA                PARTNERS PIT (RMA)

 CONTRL   STRUCT 8           LOAD CONTROLWARE COMMAND
 CMCMD    STRUCT 8           CONTROL MODULE COMMAND
 CWPVA    STRUCT 24          CONTROLWARE RMA LIST PVA
 CMPVA    STRUCT 24          CONTROL MODULE RMA LIST PVA
 COMM     STRUCT 16          COMMUNICATION AREA
 SCRAT    STRUCT 16          SCRATCH AREA
 ZEROES   STRUCT 120         120 BYTES (15 CM WORDS) OF ZERO


          MASKP  SLAVE
K.SLAVE   EQU    MSK


 CB       RECEND
          SPACE  6
* RESPONSE CODES.
 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    40000B      INTERMEDIATE RESPONSE
 R.NRM    EQU    100000B     NORMAL REQUEST TERMINATION
 R.ABN    EQU    140000B     ABNORMAL REQUEST TERMINATION
 R.RCV    EQU    10000B      RECOVERED ERROR CAUSED RESPONSE
 R.FLG    EQU    20000B      FLAG FIELD CAUSED RESPONSE

* UNSOLICITED RESPONSE CODES
 URC.RN   EQU    1           CHANGE FROM READY TO NOT READY
 URC.NR   EQU    2           CHANGE FROM NOT READY TO READY
 URC.IE   EQU    3           INTERNAL OR INTERFACE ERROR
          EJECT
 TP       EQU    0           CHANNEL NUMBER
 DSC      EQU    0           DST-DSP COMMUNICATIONS CHANNEL

 ALERT    EQU    4000B       ALERT CONDITION IN WORD 1 OF HARDWARE STATUS
 EOT      EQU    10B         END OF TAPE INDICATOR IN WORD 1 OF STATUS
 BUSY     EQU    2           BUSY INDICATOR IN WORD 1 OF STATUS
 BOT      EQU    4           BEGINNING OF TAPE INDICATOR IN WORD 1 OF STATUS
 TPMARK   EQU    20B         TAPE MARK INDICATOR IN WORD 1 OF STATUS
 CFILL    EQU    40B         CHARACTER FILL INDICATOR IN WORD 1 OF STATUS
 LOSTD    EQU    4000B       LOST DATA INDICATOR IN WORD 3 OF STATUS
 TPERR    EQU    3777B       HARDWARE ERROR BITS IN WORD 3 OF STATUS

 TIMERR   EQU    400B        TIMEOUT INTERFACE ERROR CODE BASE
 PITERR   EQU    1000B       PIT INTERFACE ERROR CODE BASE
 UITERR   EQU    1400B       UIT INTERFACE ERROR CODE BASE
 RQHERR   EQU    2000B       REQUEST HEADER INTERFACE ERROR CODE BASE
 CMDERR   EQU    2400B       COMMAND SEQUENCE INTERFACE ERROR CODE BASE

 F.RU67   EQU    1           RELEASE CONNECTED UNIT COMMAND FOR 67X
 F.FU67   EQU    4           FORMAT 67X TAPE COMMAND
 F.GS67   EQU    12B         GENERAL STATUS FUNCTION FOR 67X TAPES
 F.READ   EQU    40B         READ FORWARD
 F.MCLR   EQU    414B        MASTER CLEAR
 WRCMD    EQU    50B         WRITE HARDWARE FUNCTION FOR 67X TAPES
 SWRCMD   EQU    250B        SHORT WRITE HARDWARE FUNCTION FOR 67X TAPES

 L.GS67   EQU    16          LENGTH OF STATUS IN 67X IN PP WORDS
 PITLEN   EQU    C.PIT+C.UD*8  LENGTH OF PP INTERFACE TABLE IN CM WORDS

 T639.1   EQU    16          UIT UNIT TYPE FOR 639-1 TAPE DRIVE

 PSNI     EQU    2400B       PSN INSTRUCTION
 INPNI    EQU    102600B     INPN INSTRUCTION

 INDFLG   EQU    100B        INDIRECT ADDRESSING FLAG
 STRSP    EQU    200B        STORE RESPONSE FLAG

 MAXREQ   EQU    65          MAX REQUEST LENGTH IN CM WORDS
 ENDMEM   EQU    37777B      LARGEST PP MEMORY ADDRESS
 NORMRES  EQU    B.RS-5*8    LENGTH OF RESPONSE BUFFER IN BYTES (WITHOUT SENSE BYTES)

 FUNCCMD  EQU    40B         PHYSICAL COMMAND - FUNCTION (20 HEX)
 PWRTCMD  EQU    43B         PHYSICAL COMMAND - OUTPUT 8-BIT DATA (23 HEX)
 IDLCMD   EQU    4           PP IDLE COMMAND
 RSUMCMD  EQU    5           PP RESUME COMMAND
 LCREAD   EQU    101B        LOCICAL READ RECORD OF 8-BIT DATA (41 HEX)
 LCSTC    EQU    141B        LOGICAL COMMAND STORE TRANSFER COUNT (61 HEX)
          EJECT
 ERC101   EQU    1           PP REQUEST QUEUE LOCKWORD TIMEOUT
 ERC102   EQU    ERC101+1    UNIT REQUEST QUEUE LOCKWORD TIMEOUT
 ERC103   EQU    ERC102+1    UNIT LOCKWORD TIMEOUT
 ERC104   EQU    ERC103+1    CHANNEL LOCKWORD TIMEOUT
 ERC105   EQU    ERC104+1    BUFFER POOL LOCKWORD TIMEOUT
 ERC106   EQU    ERC105+1    UNIT HARDWARE RESERVE TIMEOUT
 ERC107   EQU    ERC106+1    CONTROLLER HARDWARE RESERVE TIMEOUT
 ERC201   EQU    1           RESERVED FIELD OF PP INT TBL HEAD NOT 0
 ERC202   EQU    ERC201+1    RMA OF UNIT ACTIVITY MASK NOT A WORD BOUNDARY
 ERC203   EQU    ERC202+1    RMA OF PP COMM BUF NOT A WORD BOUNDARY
 ERC204   EQU    ERC203+1    RESERVED FIELD OF PP COMM DESCRIPTOR NOT 0
 ERC205   EQU    ERC204+1    RESERVED FIELD OF QUEUE DESCRIPTOR NOT 0
 ERC206   EQU    ERC205+1    RMA OF NEXT PP NOT A WORD BOUNDARY
 ERC207   EQU    ERC206+1    RESERVED FIELD OF RESP BUF DESCRIPTOR NOT 0
 ERC208   EQU    ERC207+1    LOGICAL UNIT OUT OF RANGE
 ERC209   EQU    ERC208+1    RMA OF UIT NOT A WORD BOUNDARY
 ERC20A   EQU    ERC209+1    INVALID CHANNEL NUMBER IN UNIT DESCRIPTOR
 ERC301   EQU    1           LOGICAL UNIT NUMBER MISMATCH
 ERC302   EQU    ERC301+1    RMA OF UNIT COMM BUF NOT A WORD BOUNDARY
 ERC303   EQU    ERC302+1    RESERVED FIELD OF UNIT COMM BUF DESCRIPTOR NOT 0
 ERC304   EQU    ERC303+1    RMA OF NEXT UNIT REQUEST NOT WORD BOUNDARY
 ERC305   EQU    ERC304+1    RESERVED FIELD OF QUEUE DESCRIPTOR NOT 0
 ERC306   EQU    ERC305+1    RESERVED FIELD IN HEADER NOT ZERO
 ERC307   EQU    ERC306+1    ILLEGAL DEVICE TYPE
 ERC401   EQU    1           RMA OF NEXT REQUEST NOT A WORD BOUNDARY
 ERC402   EQU    ERC401+1    REQUEST LENGTH NOT A MULTIPLE OF 8 BYTES
 ERC403   EQU    ERC402+1    REQUEST LENGTH IS LESS THAN FOURTY BYTES
 ERC404   EQU    ERC403+1    LOGICAL UNIT NO .NE. UNIT NO IN INTERFACE TBL
 ERC405   EQU    ERC404+1    RESERVED LINKAGE FIELD IS NOT ZERO
 ERC406   EQU    ERC405+1    INVALID RECOVERY/INTERFACE SELECTIONS
 ERC407   EQU    ERC406+1    INVALID PRIORITY SELECTION
 ERC408   EQU    ERC407+1    INVALID SECONDARY ADDRESS
 ERC409   EQU    ERC408+1    INVALID ALERT CONDITION
 ERC40A   EQU    ERC409+1    REQUEST LENGTH TOO LARGE > 224 BYTES
 ERC501   EQU    1           INVALID COMMAND CODE
 ERC502   EQU    ERC501+1    INVALID FLAG SELECTION
 ERC503   EQU    ERC502+1    INVALID FUNCTION
 ERC504   EQU    ERC503+1    FUNCTION NOT SUPPORTED BY HARDWARE
 ERC505   EQU    ERC504+1    INVALID LENGTH SPECIFICATION IN COMMAND
 ERC506   EQU    ERC505+1    INVALID ADDRESS SPECIFICATION IN COMMAND
 ERC507   EQU    ERC506+1    INVALID LENGTH SPECIFICATION IN INDIRECT LIST
 ERC508   EQU    ERC507+1    INVALID ADDRESS SPECIFICATION IN INDIRECT LIST
 ERC509   EQU    ERC508+1    PP COMMAND NOT ALLOWED IN REQUEST TO A UNIT
 ERC50A   EQU    ERC509+1    INVALID SEQUENCE OF COMMANDS
 ERC50B   EQU    ERC50A+1    INVALID PARAMETER SPECIFICATION
 ERC50C   EQU    ERC50B+1    RESERVED FIELD IN INDIRECT LIST NOT 0
          SPACE  4,20
**        SUBR - DEFINE SUBROUTINE ENTRY/EXIT.
*
*NAME     SUBR
*         DECLARE *NAME* TO BE THE ENTRY POINT TO A PP SUBROUTINE
*         WHICH IS ENTERED VIA *RJM* TO *NAME*.
*
*         THE FOLLOWING CODE IS GENERATED.
*NAMEX    LJM    *
*NAME     EQU    *-1

          PURGMAC  SUBR

          MACRO  SUBR,A
A_X LJM *
A EQU *-1
  ENDM
          EJECT
* DIRECT CELLS

 T0       CON    INIT-1      START OF INITIALIZATION ROUTINE

 T1       BSSZ   1           SCRATCH CELLS
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 P1       BSSZ   1
 P2       BSSZ   1
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 WC       BSSZ   1           CM WORD COUNT
 CMADR    BSSZ   3           CENTRAL MEMORY ADDRESS
 IDLFLG   BSSZ   1           PP IDLE FLAG, IF NONZERO ONLY PP REQUESTS ARE DONE.
 BIDINDX  BSSZ   1           INDEX INTO AREA CONTAINING INDIVIDUAL BID_RESPONSES
 CHLOCK   BSSZ   1           CHANNEL LOCK FLAG
 CMDADR   BSSZ   1           ADDRESS OF ACTIVE COMMAND
 CMDNO    BSSZ   1           NO OF REMAINING COMMANDS
 LSTLEN   BSSZ   1           NUMBER OF INDIRECT LIST ENTRIES
 RTRNCNT  BSSZ   2           REQUESTED TRANSFER COUNT IN BYTES
 TRNCNT   BSSZ   4           TOTAL ACTUAL TRANSFER COUNT IN BYTES
 WRDCNT   BSSZ   1           WORD COUNT OF REQUESTED I/O OPERATION
 IOCNT    BSSZ   1           NUMBER OF PP WORDS TO TRANSFER THIS I/O
 UDPNT    BSSZ   1           UNIT DESCRIPTOR POINTER
 UNITP    BSSZ   1           UNIT POINTER
 MOTION   BSSZ   1           TAPE MOTION FLAG
 LIM      BSSZ   1           LIMIT OF RESPONSE BUFFER
 CONFLG   BSSZ   1           UNIT CONNECTED FLAG
 LONG     BSSZ   1           LONG INPUT BLOCK FLAG
 CM.CHAN  BSSZ   3           CM ADDRESS OF CHANNEL TABLE
 CM.COM   BSSZ   3           CM ADDRESS OF PP COMMUNICATION BUFFER
 CM.RS    BSSZ   3           CM ADDRESS OF RESPONSE BUFFER
 CM.PIT   BSSZ   3           CM ADDRESS OF PP INTERFACE TABLE
 CM.UIT   BSSZ   3           CM ADDRESS OF UNIT INTERFACE TABLE
 CM.INT   BSSZ   3           CM ADDRESS OF INTERRUPT TABLE
 LWRTF    BSSZ   1           LAST WRITE FUNCTION ISSUED
 ON       CON    1           CONSTANT ONE (DO NOT CHANGE THIS CELL)
 TW       CON    2           CONSTANT TWO (DO NOT CHANGE THIS CELL)
 DSRTP    CON    2           REAL MEMORY WORD-ADDRESS OF PIT (PLUGGED)
          CON    0
          BSSZ   1           SPARE
          BSSZ   1           SPARE
 PPNO     CON    5           LOGICAL PP NUMBER
 ID       CON    177777B     IDENTIFICATION

          ERRNZ  DSRTP-72B   MUST BE AT LOCATION 72

 LASTFC   EQU    DSRTP       LAST FUNCTION CODE
 LASTFC1  EQU    DSRTP+1     LAST NON-STATUS FUNCTION
          EJECT
          ORG    100B
*
* PP MONITOR
*
          SPACE  4
 TAPE     BSS    0
 MAIN     RJM    PPREQ       CHECK FOR ANY PP REQUESTS
          ZJN    MAIN010     IF NO PP REQUESTS, CHECK IF ANY UNIT REQ
 MAIN05   LJM    DORQ        PROCESS THE PP/UNIT REQUEST
*         *DORQ* RETURNS DIRECTLY TO *MAIN*.

 MAIN010  LDD    IDLFLG      GET IDLE FLAG
          NJN    MAIN020     IF IDLE FLAG SET, RELOOP
          RJM    UNITRQ      CHECK FOR, SKIP UNIT REQUEST CHECK
          NJN    MAIN05      IF THERE IS A UNIT REQUEST
 MAIN020  RJM    CKCHREQ     CHECK IF CHANNEL REQUESTED
          UJN    MAIN        LOOP FOR REQUESTS
          EJECT
** NAME - PPREQ
*
** PURPOSE - TO DETERMINE IF THERE ARE ANY PP REQUESTS TO PROCESS.  IF THERE
*            ARE, THE FIRST ONE IS COPIED INTO PP MEMORY.
*
** OUTPUT - A=0 IF NO PP REQUESTS.
*           A .NE. 0 IF THERE IS A PP REQUEST TO PROCESS.
*           IF THERE IS A REQUEST, (CMDNO) = NUMBER OF COMMANDS.
          SPACE   4
 NOPPQ    LDN    PPLK+40B    UNLOCK PP REQUEST QUEUE
          RJM    SCLK
 NOPPQ1   LDN    0           SET EXIT FOR NO REQUESTS FOUND

 PPREQ    SUBR               ENTRY/EXIT

*         A ONE WORD READ WITH THE CRDL INSTRUCTION AT THE SAME TIME
*         THE PP IS DEADSTARTED COULD CAUSE AN UNCORRECTED CM ERROR ON
*         AN S0 WITH A 60 NANOSECOND CLOCK.  TO AVOID THIS HARDWARE
*         PROBLEM THE CRML INSTRUCTION IS USED.

          LOADC  CM.PIT      LOAD A AND R FOR PIT
          ADN    /PIT/C.PPQ
          CRML   T1,ON       READ REQUEST RMA FROM PIT
          LDDL   T3          HALF 1 OF REQUEST RMA
          ADDL   T4          HALF 2 OF REQUEST RMA
          ZJN    PPREQX      IF NO REQUEST QUEUED
          LDN    PPLK        LOCK PP REQUEST QUEUE
          RJM    SCLK
          NJK    NOPPQ1      RETURN IF PP REQUEST QUEUE ALREADY LOCKED
          LOADC  CM.PIT      CM ADDRESS TO A AND R FOR READ
          ADN    /PIT/C.PPQPVA
          CRML   PPTBL+/PIT/P.PPQPVA-1,TW  READ IN REQUEST PVA/RMA FROM PIT
          LDML   PPTBL+/PIT/P.PPQ  GET HALF 1 OF RMA OF 1ST REQUEST
          ADML   PPTBL+/PIT/P.PPQ+1
          ZJK    NOPPQ       IF RMA = 0 NO PP REQUEST QUEUED
          LDK    /RQ/C.CMND  LENGTH OF REQUEST HEADER
          STDL   WC
          LOADF  PPTBL+/PIT/P.PPQ  CM ADDRESS OF REQUEST TO A AND R
          CRML   REQBUF,WC   READ PP REQUEST HEADER
          LDML   REQBUF+/RQ/P.LEN  REQUEST LENGTH IN BYTES
          SHN    -3          REQUEST LENGTH IN CM WORDS
          SBN    /RQ/C.CMND  SUBTRACT HEADER LENGTH
          STDL   CMDNO       NUMBER OF COMMANDS THIS REQUEST
          LDDL   CMADR+2     READ COMMANDS FROM CM
          ADN    /RQ/C.CMND
          LMC    400000B
          CRML   CMDBUF,CMDNO
          LOADC  CM.PIT      SET A AND R TO PP INTERFACE TABLE
          ADN    /PIT/C.PPQPVA  SET A AND R TO PVA IN PP INTERFACE TABLE
          CWML   REQBUF+/RQ/P.NEXTPV-1,TW  RESET PVA AND RMA TO NEXT PVA AND RMA
          LDN    PPLK+40B    UNLOCK PP REQUEST QUEUE
          RJM    SCLK
          LDC    PPTBL+/PIT/P.PPQPVA-1  SET PIT PVA/RMA PP BUFFER ADDRESS
          STML   RESPSUA
          RJM    RESPSU      SET UP RESPONSE BUFFER
          LDN    1           SET GOT REQUEST FLAG
          UJK    PPREQX      EXIT
          EJECT
** NAME - UNITRQ
*
** PURPOSE - TO DETERMINE IF THERE ANY REQUESTS ON THE UNIT QUEUES.
*
** OUTPUT - A = 0 IF THERE ARE NO UNIT REQUESTS.
*           A .NE. 0 IF THERE IS A UNIT REQUEST TO PROCESS.
*           IF THERE IS A REQUEST, (CMDNO) = NUMBER OF COMMANDS.
          SPACE  4
 UQEMPT   LDN    0           SET NO UNIT REQUESTS

 UNITRQ   SUBR               ENTRY/EXIT
          LDML   PPTBL+/PIT/P.UNITC  GET NUMBER OF UNITS
          STDL   P1          SAVE FOR LOOP CONTROL

 UQLOOP   SODL   P1          DECREMENT LOOP CONTROL COUNTER
          MJN    UQEMPT      EXIT IF ALL UNITS CHECKED AND NO FINDS
          AODL   UNITP       INCREMENT UNIT POINTER
          SBML   PPTBL+/PIT/P.UNITC  SUBTRACT MAX UNIT NUMBER
          MJN    UQ2         SKIP IF NO RAP AROUND
          LDN    0           RESET POINTER TO START OF UNIT LIST
          STDL   UNITP
 UQ2      LDDL   UNITP       GET UNIT POINTER
          SHN    3           MULT BY 8 SINCE UNIT DESCRIPTOR 8 PP WORDS LONG
          STDL   UDPNT       SAVE POINTER INTO UNIT DESCRIPTOR

*         PRESET HAS TAKEN NULL UNIT DESCRIPTORS OUT OF THE PP COPY OF THE
*         UNIT DESCRIPTORS FOR THIS PIT.
*
*         LDML   UNITD+/UD/P.UQT,UDPNT  GET RMA UPPER HALF
*         ADML   UNITD+/UD/P.UQT+1,UDPNT  ADD RMA LOWER HALF
*         ZJK    UQLOOP      IF DUMMY ENTRY, LOOP TO NEXT ENTRY

          LOADF  UNITD+/UD/P.UQT,UDPNT  REFORMAT AND LOAD CM ADDRESS OF UIT
          STDL   CM.UIT+2    SAVE CM ADDRESS OF UIT
          SRD    CM.UIT
          ERRNZ  /UIT/C.DSABLE
          CRDL   T1          READ UNIT STATUS WORD FROM UIT
          ADN    /UIT/C.NEXT
          CRDL   T3          READ NEXT REQUEST RMA
          LDDL   T2          STATUS FIELD
          ERRNZ  /UIT/P.DSABLE-1
          SHN    18-16+/UIT/L.DSABLE
          MJN    UQLOOP      IF UNIT DISABLED
          LDDL   T5          HALF 1 OF REQUEST RMA
          ADDL   T6          HALF 2 OF REQUEST RMA
          ZJK    UQLOOP      IF NO REQUEST QUEUED
          LDDL   CONFLG      CHECK IF ANY UNIT CURRENTLY CONNECTED
          ZJN    UQ2.1       IF NO UNIT CONNECTED
          LPN    77B
          LMDL   UNITP
          ZJN    UQ2.2       IF CONNECTED UNIT IS SAME AS CURRENT REQUEST
 UQ2.1    LDN    UILK        LOCK UNIT INTERFACE TABLE
          RJM    SCLK
          NJK    UQLOOP      GO TO NEXT UNIT IF THIS ONE IS LOCKED
          LDDL   CONFLG
          ZJN    UQ2.2       IF NO UNIT CURRENTLY CONNECTED
          RJM    REL         RELEASE PREVIOUSLY CONNECTED UNIT
 UQ2.2    LDN    QULK        LOCK UNIT REQUEST QUEUE
          RJM    SCLK
          NJN    TRYNX1      GO TO NEXT UNIT IF THIS ONE LOCKED
          LDN    C.UIT       SET LENGTH OF UIT
          STDL   WC
          LOADC  CM.UIT      SET A AND R TO ADDR OF UIT
          CRML   UITBUF,WC   READ IN UNIT INTERFACE TABLE
          LDML   UITBUF+/UIT/P.DSABLE  GET UNIT STATUS
          SHN    18-16+/UIT/L.DSABLE
          MJN    TRYNXT      IF UNIT DISABLED
          LDML   UITBUF+/UIT/P.NEXT  HALF 1 OF RMA FOR REQUEST
          ADML   UITBUF+/UIT/P.NEXT+1  IF RMA=0 NO REQUEST QUEUED
          NJN    UQ3         IF REQUEST IS QUEUED
 TRYNXT   LDN    QULK+40B    UNLOCK UNIT REQUEST QUEUE
          RJM    SCLK
 TRYNX1   LDDL   CONFLG
          NJN    UQ2.3       IF UNIT ALREADY CONNECTED
          LDN    UILK+40B    UNLOCK UNIT INTERFACE TABLE
          RJM    SCLK
 UQ2.3    LJM    UQLOOP      LOOP TO NEXT UNIT

 UQ3      LDK    /RQ/C.CMND  LENGTH OF REQUEST HEADER
          STDL   WC          SAVE LENGTH FOR CM READ
          LOADF  UITBUF+/UIT/P.NEXT  SET A AND R TO ADDR OF REQUEST
          CRML   REQBUF,WC   READ REQUEST HEADER
          LOADC  CM.UIT      SET A AND R TO ADDRESS OF UIT
          ADN    /UIT/C.NEXTPV  POINT TO PVA
          CWML   REQBUF+/RQ/P.NEXTPV-1,TW  RESET PVA AND RMA OF NEXT REQUEST
          LDN    QULK+40B    UNLOCK UNIT REQUEST QUEUE
          RJM    SCLK
          LDML   REQBUF+/RQ/P.LEN  REQUEST LENGTH IN BYTES
          SHN    -3          REQUEST LENGTH IN CM WORDS
          SBN    /RQ/C.CMND  SUBTRACT HEADER LENGTH
          STDL   CMDNO       NUMBER OF COMMANDS THIS REQUEST
          LOADF  UITBUF+/UIT/P.NEXT
          ADN    /RQ/C.CMND
          CRML   CMDBUF,CMDNO
          LDC    UITBUF+/UIT/P.NEXTPV-1  SET UIT PVA/RMA PP BUFFER ADDRESS
          STML   RESPSUA
          RJM    RESPSU      SET UP RESPONSE BUFFER
          LDN    0
          STD    BIDINDX     CLEAR INDEX INTO BID RESPONSE AREA
          LDML   UNITD+/UD/P.CNTRLR,UDPNT  SET EQUIPMENT NUMBER
          LPN    7
          SHN    9
          STML   FUNA
          LDN    1           SET GOT REQUEST FLAG
          UJK    UNITRQX     RETURN
          EJECT
** NAME - DORQ
*
** PURPOSE - PERFORM THE REQUIRED REQUEST.
*
** INPUT - REQUEST IN REQBUF.
*          (CMDNO) = NUMBER OF COMMANDS IN REQUEST.
*
** OUTPUT - REQUEST PROCESSED AND RESPONSE PLACED IN RESPONSE BUFFER.
*
          SPACE  4
 DORQ     BSS    0           ENTRY
          LDC    CMDBUF      ADDRESS OF FIRST COMMAND IN REQUEST
          STDL   CMDADR      INITIALIZE COMMAND ADDRESS
          LDN    0
          STDL   TRNCNT+3    INITIALIZE TRANSFER COUNT
          STDL   TRNCNT+2
          STDL   MOTION      INITIALIZE MOTION FLAG
          STDL   LONG        INITIALIZE LONG INPUT BLOCK FLAG
 DORQ5    LDIL   CMDADR      GET COMMAND AND FLAGS
          SHN    -8          SHIFT OFF FLAGS
          STDL   T2          SAVE COMMAND
          LDN    0           INITIALIZE TABLE INDEX
          STDL   T1
 DORQ10   LDML   DORQA,T1    COMPARE TABLE ENTRY WITH CURRENT COMMAND
          LMDL   T2
          ZJN    DORQ20      IF FOUND REQUESTED COMMAND
          LDN    2           INCREMENT INDEX
          RADL   T1
          LMN    DORQAL
          NJN    DORQ10      IF NOT END OF TABLE
          UJN    *           IF END OF TABLE, NON-SUPPORTED COMMAND

 DORQ20   LDML   DORQA+1,T1  GET PROCESSOR ADDRESS
          STML   DORQB
          PSN    0           ALLOW FOR S0 INSTRUCTION MODIFICATION

**        EXIT TO COMMAND PROCESSOR ROUTINE WITH THE FOLLOWING -
*
*         (T2) = COMMAND.
*         ((CMDADR)) = COMMAND AND FLAGS. (BEGINNING OF CURRENT COMMAND)
*         (CMDNO) = NUMBER OF COMMANDS, INCLUDING CURRENT ONE, LEFT
*                   IN THE CURRENT REQUEST.

          LJM    **          PROCESS COMMAND
 DORQB    EQU    *-1

**        AFTER COMMAND IS PROCESSED, THE COMMAND PROCESSOR ROUTINE WILL
*         RETURN TO *CMDONE* IF STATUS IS REQUIRED OR TO *NOSTAT* IF
*         STATUS IS NOT REQUIRED.  IF THE COMMAND IS AN OUTPUT DATA OR LOGICAL
*         READ, THE PROCESSOR WILL RETURN TO *CMDONE1*.

 CMDONE   RJM    GTSTAT      GET STATUS
          RJM    ERRCHK      CHECK FOR ERRORS

 CMDONE1  LDML   RESBUF+/RS/P.GSTAT+2  FETCH DETAILED STATUS
          NJN    CMD5        IF HARDWARE OR MEDIA ERROR
          LDDL   LASTFC1     GET LAST NON-STATUS FUNCTION
          SBN    13B
          ZJN    CMD7        IF FORSPACE
          SBN    40B-13B
          ZJN    CMD7        IF READ (SHOULD ONLY BE FORWARD READ TYPE)
          LPN    77B         MASK FOR ANY TYPE WRITE
          SBN    50B-40B
          ZJN    CMD9        IF WRITE TYPE
          SBN    51B-50B
          NJN    CMD11       IF NOT WRITE TAPE MARK FUNCTION
 CMD1     LDN    1           SET FILE MARK STATUS IN BID WINDOW
 CMD3     STML   RESBID,BIDINDX  UPDATE BID RESPONSE AREA
          AOD    BIDINDX     INCREMENT INDEX INTO BID RESPONSE AREA
          STML   RESCNT      SET PRESENT BID RESPONSE AREA COUNT
 CMD5     UJN    CMD11

 CMD7     LDM    RESBUF+/RS/P.GSTAT  FETCH GENERAL STATUS
          LPN    20B         MASK FILE MARK STATUS
          NJN    CMD1        IF FILE MARK STATUS
 CMD9     LDM    RESBUF+/RS/P.GSTAT+3  PICK UP STATUS WORD 4
          LPC    3000B       MASK OFF DOUBLE/SINGLE TRACK CORRECTION STATUS
          ZJN    CMD10       IF NO ON_THE_FLY HARDWARE CORRECTION
          AOM    CORCNT      INCREMENT HARDWARE CORRECTION COUNT
 CMD10    LDM    RESBUF+/RS/P.GSTAT+1  FETCH BID FOR THIS OPERATION
          UJN    CMD3        STORE BID ENTRY

 CMD11    LDDL   P2          FETCH FATAL ERROR FLAG FROM ERRCHK
          NJK    FAIL        IF STATUS BAD, GO TO FAIL
 NOSTAT   LDIL   CMDADR      GET COMMAND AND FLAGS
          LPC    STRSP       MASK OFF STORE TRANSFER COUNT FLAG
          ZJN    NOSTR       JUMP IF STORE RESPONSE NOT REQUIRED
          LDC    R.FLG
          RAML   RESBUF+/RS/P.RC  SET FLAG RESPONSE BIT
 NOSTR    BSS
          SODL   CMDNO       DECREMENT COMMAND COUNTER BY 1
          ZJN    DORQ1       GO TO COMPLETE REQUEST
          LDML   RESBUF+/RS/P.RC  CHECK IF INTERMEDIATE RESPONSE REQUIRED
          ZJN    NOST1       IF NO INTERMEDIATE RESPONSE
          LDC    R.INT       SET INTERMEDIATE RESPONSE FLAG
          RAML   RESBUF+/RS/P.RC
          RJM    RESP        STORE A RESPONSE
          RJM    RESPSU      SET UP RESPONSE BUFFER
 NOST1    BSS
          LDN    4           POINT TO THE NEXT COMMAND 4PP WORDS = COMMAND
          RADL   CMDADR
          UJK    DORQ5       RELOOP TO PERFORM NEXT COMMAND

 DORQ1    LDC    R.NRM
          RAML   RESBUF+/RS/P.RC  SET NORMAL REQUEST TERMINATION INDICATOR
 DORQ2    RJM    IODONE      TERMINATE REQUEST
          UJK    MAIN        RETURN TO MAIN LOOP

 FAIL     RJM    CDUNIT      CHECK IF UNIT TO BE DISABLED
          LDC    R.ABN
          STML   RESBUF+/RS/P.RC  SET ABNORMAL TERMINATION RESPONSE
          UJN    DORQ2       TERMINATE REQUEST


**        THE FOLLOWING TABLE CONTAINS ONE ENTRY FOR EACH SUPPORTED COMMAND
*         OF THE TAPE SUBSYSTEM.  THE SECOND WORD OF EACH ENTRY IS THE ADDRESS
*         OF THE COMMAND PROCESSOR ROUTINE.

 DORQA    BSS    0
          CON    FUNCCMD,FUNC     PHYSICAL COMMAND - FUNCTION
          CON    PWRTCMD,OUT8D    PHYSICAL COMMAND - OUTPUT 8-BIT DATA
          CON    LCREAD,READ      LOGICAL READ COMMAND
          CON    LCSTC,STRTC      LOCIGAL STORE TRANSFER COUNT
          CON    IDLCMD,DOPPRQ    IDLE PP COMMAND
          CON    RSUMCMD,DOPPRQ   RESUME COMMAND
 DORQAL   EQU    *-DORQA     LENGTH OF TABLE
          EJECT
** NAME - DOPPRQ
*
** PURPOSE - PERFORM A PP REQUEST.
*
** INPUT - (T2) = COMMAND.
*
** OUTPUT - COMMAND PROCESSED.
*
** NOTE - THE ONLY PP REQUESTS CURRENTLY SUPPORTED ARE IDLE AND RESUME.
*
          SPACE  4
 DOPPRQ   BSS
          LDDL   T2          GET COMMAND
          SBN    RSUMCMD
          ZJN    DOPP10      IF RESUME COMMAND CLEAR IDLE FLAG
          RJM    CCLOCK      RELEASE CONNECTED UNIT AND CLEAR CHANNEL LOCK
          LDN    1           SET PP IDLE
 DOPP10   STDL   IDLFLG
          UJK    NOSTAT      GO TO DO NEXT COMMAND
          EJECT
** NAME - CDUNIT
*
** PURPOSE - TO SET THE DISABLED UNIT BIT IN THE UIT IF THE MASK BIT IS SET.
*
*  INPUT - RESPONSE BUFFER HEADER ALERT MASK IS IMAGE OF REQUEST
*
** OUTPUT - THE DISABLE UNIT BIT IS SET IN THE STATUS FIELD OF THE UNIT
*           INTERFACE TABLE IF THE ALERT MASK DISABLE BIT WAS SET.
*
          SPACE  4
 CDUNIT   SUBR               ENTRY/EXIT
          LDML   RESBUF+/RS/P.LONGB  CHECK ALERT MASK
          SHN    18-16+/RS/L.DUNIT  DISABLE UNIT BIT TO SIGN POSITION
          PJN    CDUNITX     IF NOT DISABLE UNIT BIT IN ALERT MASK
          LDC    /RS/K.DUNIT   SET UNIT_DISABLED BIT IN RESPONSE
          RAML   RESBUF+/RS/P.LNGBLK  SET RESPONSE ALERT CONDITIONS
          LDC    /UIT/K.DSABLE  SET UNIT DISABLED IN UIT STATUS
          RAML   UITBUF+/UIT/P.DSABLE
          LOADC  CM.UIT
          CWML   UITBUF,ON   UPDATE FIRST WORD OF UIT
          UJN    CDUNITX     EXIT
          EJECT
** NAME - FUNC
*
** PURPOSE - TO PERFORM THE PHYSICAL COMMAND FUNCTION.
*
** INPUT -  (CMDADR) = ADDRESS OF COMMAND.
*
** OUTPUT - FUNCTION ISSUED IF NOT WRITE OR FORMAT.
*
          SPACE  4
 FUNC     BSS
          LDML   3,CMDADR    GET HARDWARE FUNCTION TO BE ISSUED
          SBN    F.FU67
          ZJK    FORMATU     IF FORMAT UNIT COMMAND GO TO FORMAT UNIT ROUTINE
          SBN    WRCMD-F.FU67
          ZJN    FUNC10      IF WRITE FUNCTION
          ADC    WRCMD-SWRCMD
          ZJN    FUNC10      IF SHORT WRITE FUNCTION
          LDML   3,CMDADR    GET HARDWARE FUNCTION TO BE ISSUED
          RJM    DOFUNC      DO FUNCTION
          UJK    CMDONE      GO TO DO NEXT COMMAND

 FUNC10   LDDL   MOTION
          ZJN    FUNC20      IF MOTION NOT STARTED
          LJM    NOSTAT      PROCESS NEXT COMMAND

 FUNC20   LJM    WRITE       PROCESS WRITE FUNCTION
          EJECT
** NAME - READ
*
** PURPOSE - PROCESS LOGICAL READ COMMAND.
*
** INPUT - (CMDADR) = ADDRESS OF COMMAND.
*
          SPACE   4
 READ     BSS
          LDD    MOTION      CHECK TAPE MOTION FLAG
          NJN    READ5       IF TAPE ALREADY MOVING
          LDN    F.READ      ISSUE READ FUNCTION
          RJM    DOFUNC
          ACN    TP          ACTIVATE CHANNEL
 READ5    LDDL   CMDADR      SET CURRENT COMMAND ADDRESS
          STDL   T4
          RJM    SETUP       SET UP FOR READ
          LDN    0           CLEAR MOTION AHEAD FLAG
          STDL   MOTION
          STDL   LONG        CLEAR LONG INPUT FLAG
          STDL   RTRNCNT     CLEAR REQUESTED TRANSFER COUNTERS
          STDL   RTRNCNT+1

*         THE FOLLOWING TWO LINES ARE NEEDED BECAUSE OF 930 INSTRUCTION TIMEOUT.

 READ10   IJM    READ30,TP   IF CHANNEL HAS BEEN INACTIVATED
          EJM    READ10,TP   IF DATA NOT READY YET

 READ15   LDML   INDLIST+1   GET REQUESTED BYTE COUNT
          RADL   RTRNCNT+1   INCREMENT REQUESTED BYTE COUNT
          SHN    -16
          RADL   RTRNCNT
          LDML   INDLIST+1   GET REQUESTED BYTE COUNT
          ADN    1           ADJUST TO CH WORD COUNT
          SHN    -1
          STDL   WRDCNT      SAVE REQUESTED WORD COUNT
          STDL   IOCNT       SAVE CH WORD COUNT
          LOADF  INDLIST+/CM/P.RMA   SET A AND R REGISTERS FOR DATA ADDRESS
          CHCM   IOCNT,TP    INPUT THE DATA
          RJM    UPTCNT      GO UPDATE THE TOTAL TRANSFER COUNT
          NJN    READ30      IF PARTIAL RECORD
          SODL   LSTLEN      DECREMENT NUMBER OF INDIRECT LIST ENTRIES
          ZJN    READ20      IF LIST EXHAUSTED
          LDN    8           UPDATE INDIRECT LIST ADDRESS
          RAML   INDLSTA+1
          SHN    -16
          RAML   INDLSTA
          LOADF  INDLSTA     SET A AND R REGISTERS FOR INDIRECT LIST ADDRESS
          CRML   INDLIST,ON  GET NEXT INDIRECT LIST LENGTH/ADDRESS PAIR
          UJK    READ15      PROCESS NEXT PAIR

 READ20   LDN    24          CONTINUE INPUT TO CHECK FOR LONG BLOCK
          STDL   WRDCNT      SET WORD COUNT TO 24
          IAM    RESBUF+/RS/P.GSTAT,TP   USE STATUS BUFFER AS TEMP BUFFER
          STDL   IOCNT       SAVE RESIDUAL WORD COUNT
          SBN    24
          ZJN    READ30      IF END OF DATA RECORD
          RJM    UPTCNT      UPDATE TRANSFER COUNT
          UJN    READ20      CONTINUE COUNTING

 READ30   DCN    40B+TP      DISCONNECT THE CHANNEL
          SFM    CPETERM,TP  CHECK AND CLEAR CHANNEL PARITY FLAG
          RJM    GTSTAT      WAIT FOR END OF OPERATION
          RJM    CKFL        CHECK FOR CHARACTER FILL AND LONG BLOCK CONDITIONS
          RJM    ERRCHK      CHECK FOR ERRORS OR TERMINATION CONDITION
          LDDL   P2          CHECK IF ERROR OR TERMINATION CONDITION OCCURRED
          NJN    READ40      IF ERRORS OR TERMINATION CONDITION
          LDDL   CMDNO       COMMANDS REMAINING
          SBN    2
          ZJN    READ60      IF NO MORE POSSIBLE READ COMMANDS
          LDN    F.READ      START TAPE FOR NEXT BLOCK
          RJM    DOFUNC
          ACN    TP          ACTIVATE CHANNEL
          AODL   MOTION      SET TAPE MOTION FLAG
          UJN    READ50      PROCESS NEXT COMMAND

 READ40   LOADF  6,CMDADR    SET TRANSFER COUNT FOR ERROR BLOCK
          CWDL   TRNCNT
 READ50   LJM    CMDONE1     RETURN TO PROCESS NEXT COMMAND

*         THE PURPOSE OF THE FOLLOWING CODE IS TO REDUCE THE TIME BETWEEN
*         MULTIPLE REQUESTS.  BY RETURNING THE TRANSFER COUNT FOR THE LAST
*         READ HERE, THE NORMAL REQUEST PROCESSOR PATH IS AVOIDED FOR THE
*         LAST COMMAND (WHICH IS ALWAYS A STORE TRANSFER COUNT FOR READS).

 READ60   SODL   CMDNO       DECREMENT REMAINING COMMANDS (CAUSE EXIT FROM *DORQ*)
          LDN    4           ADVANCE TO LAST COMMAND (STORE TRANSFER COUNT)
          RADL   CMDADR
          LOADF  2,CMDADR    RETURN TRANSFER COUNT FOR LAST READ
          CWDL   TRNCNT
          LDN    0           CLEAR TRANSFER COUNT
          STDL   TRNCNT+2
          STDL   TRNCNT+3
          LJM    CMDONE1     RETURN
          EJECT
** NAME - WRITE
*
** PURPOSE - TO ISSUE WRITE FUNCTION.
*
** INPUT - (CMDADR) = ADDRESS OF COMMAND.
*
          SPACE   4
 WRITE    BSS    0           ENTRY
          LDML   3,CMDADR    GET HARDWARE FUNCTION
          STDL   LWRTF       SAVE LAST WRITE FUNCTION CODE
          RJM    DOFUNC      ISSUE WRITE FUNCTION
          ACN    TP          ACTIVATE CHANNEL
          LJM    NOSTAT      PROCESS NEXT COMMAND
          EJECT
** NAME - SETUP
*
** PURPOSE - SET UP FOR READ OR WRITE OPERATION.
*
** INPUT - (T4) = COMMAND ADDRESS FOR OPERATION TO SET UP.
*
** OUTPUT - (INDLIST) = INDIRECT LIST LENGTH/ADDRESS PAIR
*           (T4) = UNCHANGED FROM ENTRY.
*           (LSTLEN) = NUMBER OF INDIRECT LIST ENTRIES.
*           (INDLSTA) = RMA ADDRESS OF CURRENT INDIRECT LIST ENTRY
*
** NOTE - IN THE CASE OF A COMMAND WITHOUT THE INDIRECT BIT SET,
*         THE LENGTH/ADDRESS PAIR IS MOVED TO THE INDLIST
*         AND (LSTLEN) = 1 AND INDLSTA IS NOT SET.
          SPACE  4
 SETUP10  LDML   2,T4        SET INDIRECT LIST ADDRESS
          STML   INDLSTA
          LDML   3,T4
          STML   INDLSTA+1
          LOADF  INDLSTA     SET A AND R REGISTERS FOR INDIRECT LIST ADDRESS
          CRML   INDLIST,ON  GET FIRST INDIRECT LIST LENGTH/ADDRESS PAIR
          LDML   1,T4        GET BYTE COUNT OF INDIRECT LIST LENGTH
          SHN    -3          ADJUST BYTE COUNT TO NUMBER OF ENTRIES
          STDL   LSTLEN      SET NUMBER OF INDIRECT LIST ENTRIES

 SETUP    SUBR               ENTRY/EXIT
          LDIL   T4          TEST FOR INDIRECT BIT
          LPC    INDFLG
          NJN    SETUP10     IF INDIRECT
          LDN    1
          STDL   LSTLEN      SET NUMBER OF INDIRECT LIST ENTRIES TO 1
          LDML   1,T4        MOVE COMMAND LENGTH/ADDRESS TO INDIRECT BUFFER
          STML   INDLIST+1
          LDML   2,T4
          STML   INDLIST+2
          LDML   3,T4
          STML   INDLIST+3
          UJN    SETUPX      EXIT
          EJECT
** NAME - OUT8D
*
** PURPOSE - TO PERFORM THE PHYSICAL COMMAND OUTPUT 8-BIT DATA.
*
** INPUT - (CMDADR) = ADDRESS OF COMMAND.
*
          SPACE  4
 OUT8D    BSS    0           ENTRY
          LDN    0           CLR MOTION AHEAD
          STDL   MOTION
          LDDL   CMDADR      GET COMMAND ADDRESS IN PP
          STDL   T4
          RJM    SETUP       SETUP FOR WRITE OPERATION

 OUT8D10  LDML   INDLIST+1   GET REQUESTED BYTE COUNT
          ADN    1           ADJUST FOR CHANNEL WORD COUNT
          SHN    -1
          STDL   WRDCNT      SAVE REQUESTED WORD COUNT
          STDL   IOCNT       SAVE CHANNEL WORD COUNT FOR CMCH INSTRUCTION
          LOADF  INDLIST+/CM/P.RMA    SET A AND R REGISTERS FOR DATA CM ADDRESS
          CMCH   IOCNT,TP    OUTPUT THE DATA
          FJM    *,TP        WAIT UNTIL DONE
          RJM    UPTCNT      UPDATE TOTAL TRANSFER COUNT
          NJN    OUT8D20     IF NOT ALL DATA TAKEN
          SODL   LSTLEN      DECREMENT NUMBER OF INDIRECT LIST ENTRIES
          ZJN    OUT8D20     IF LIST EXHAUSTED
          LDN    8           UPDATE INDIRECT LIST ADDRESS
          RAML   INDLSTA+1
          SHN    -16
          RAML   INDLSTA
          LOADF  INDLSTA     SET A AND R REGISTERS TO NEXT INDIRECT LIST PAIR
          CRML   INDLIST,ON  GET THE NEXT LIST ENTRY
          UJN    OUT8D10     CONTINUE

 OUT8D20  DCN    40B+TP      DISCONNECT THE CHANNEL
          SFM    OUTCPE,TP   CHECK AND CLEAR THE CHANNEL PARITY FLAG
          LDDL   LWRTF       CHECK FOR SHORT WRITE FUNCTION
          SHN    10
          PJN    OUT8D25     IF NOT SHORT WRITE FUNCTION
          LDDL   TRNCNT+3    CHECK IF ANY DATA TRANSFERED
          ADDL   TRNCNT+2
          ZJN    OUT8D25     IF NONE, MUST BE HDW FAILURE
          SODL   TRNCNT+3    DECREMENT TRANSFER COUNT BECAUSE SHORT WRITE
          PJN    OUT8D25     IF NOT UNDERFLOW
          LDC    177777B
          STDL   TRNCNT+3    CORRECT 1-S COMPLEMENT RESULT
          SODL   TRNCNT+3    ADJUST MOST SIGNIFICANT BITS
 OUT8D25  BSS
          RJM    GTSTAT      WAIT FOR END OF OPERATION
          RJM    ERRCHK      CHECK FOR ERRORS OR TERMINATION CONDITION
          NJN    OUT8D30     IF ERRORS OR TERMINATION CONDITION
          LDDL   CMDNO       CHECK REMAINING COMMAND COUNT
          SBN    1
          STDL   MOTION      SET MOTION AHEAD IF ANOTHER COMMAND
          ZJN    OUT8D30     IF NO MORE COMMANDS
          LDML   7,CMDADR    GET WRITE FUNCTION CODE FOR NEXT BLOCK
          STDL   LWRTF       SAVE LAST WRITE FUNCTION CODE
          RJM    DOFUNC      ISSUE FUNCTION
          ACN    TP          ACTIVATE THE CHANNEL

 OUT8D30  LJM    CMDONE1     PROCESS WRITE COMPLETION
          EJECT
** NAME - STRTC
*
** PURPOSE - TO PERFORM THE LOGICAL COMMAND STORE TRANSFER COUNT.
*
** INPUT - (CMDADR) = ADDRESS OF COMMAND.
*
          SPACE  4
 STRTC    BSS
          LOADF  2,CMDADR    CM ADDRESS TO A AND R
          CWDL   TRNCNT      SEND TRANSFER COUNT TO CM
          LDN    0
          STDL   TRNCNT+3    CLEAR TRANSFER COUNT
          STDL   TRNCNT+2
          UJK    NOSTAT      PROCESS NEXT COMMAND
          EJECT
** NAME - UPTCNT
*
** PURPOSE - UPDATE THE TOTAL TRANSFER COUNT
*
** INPUT - (WRDCNT) = REQUESTED WORD COUNT FOR THIS TRANSFER OPERATION.
*          (IOCNT) = RESIDUAL CHANNEL WORD COUNT AFTER TRANSFER OPERATION.
*
** OUTPUT - (TRNCNT+2 AND TRNCNT+3) = UPDATED TOTAL TRANSFER COUNT.
*           (A) = 0 IF FULL TRANSFER
*           (A) = NZ IF PARTIAL TRANSFER
*
          SPACE  4
 UPTCNT   SUBR               ENTRY/EXIT
          LDDL   WRDCNT      GET REQUESTED WORD COUNT
          SBDL   IOCNT       DECR BY RESIDUAL WORD COUNT  IF ANY
          SHN    1           CONVERT TO BYTE COUNT
          RADL   TRNCNT+3    ADD TO TOTAL TRANSFER COUNT
          SHN    -16
          RADL   TRNCNT+2
          LDDL   IOCNT       GET RESIDUAL COUNT
          UJN    UPTCNTX     EXIT
          EJECT
** NAME - FORMATU
*
** PURPOSE - TO FORMAT A TAPE UNIT OR CONTROLLER (CONNECT)
*
** INPUT -
*
** OUTPUT -
          SPACE  4
 FORMATU  BSS
          LDML   UNITD+/UD/P.CHAN,UDPNT
          SHN    -8          RIGHT JUSTIFY CHANNEL IN THE A REG
          STDL   P1          SAVE AS POSSIBLE NEW CHANNEL
          LMML   CURCH
          ZJN    FORM30      IF NOT NEW CHANNEL
          LDDL   CHLOCK
          ZJN    FORM10      IF OLD CHANNEL NOT LOCKED
          RJM    CCLOCK      CLEAR CHANNEL LOCK ON OLD CHANNEL
 FORM10   LDDL   P1          SAVE NEW CHANNEL
          STML   CURCH
          LDC    CONCH       MODIFY CHANNEL INSTRUCTIONS
          RJM    CHGCH
 FORM20   LDN    CHLK        SET CHANNEL LOCK
          RJM    SCLK
          NJN    FORM20      IF CHANNEL LOCK NOT OBTAINED
          AOD    CHLOCK      SET CHANNEL CURRENTLY LOCKED
          UJN    FORM40      PROCESS FORMAT FUNCTION

 FORM30   LDDL   CHLOCK
          ZJN    FORM20      IF CHANNEL NOT LOCKED
 FORM40   LDDL   CONFLG      CHECK IF UNIT ALREADY CONNECTED
          NJK    NOSTAT      IF UNIT ALREADY CONNECTED
          LDDL   UNITP       SET UNIT CONNECTED FLAG
          LMC    4000B
          STDL   CONFLG
          LDDL   CM.UIT      SAVE UIT ADDRESS FOR ROUTINE *REL*
          STML   RELA
          LDDL   CM.UIT+1
          STML   RELA+1
          LDDL   CM.UIT+2
          STML   RELA+2
          LDN    F.FU67      GET FORMAT FUNCTION FOR 67X TAPE CONTROLLER
          RJM    DOFUNC      ISSUE THE FORMAT FUNCTION
          LDML   UNITD+/UD/P.UNIT,UDPNT  GET PHYSICAL UNIT NUMBER
          LPN    17B         RESTRICT UNIT NUMBER TO 4 BITS
          SHN    4           MOVE TO CORRECT LOCATION IN FORMBUF
          RAML   FORMBUF     INSERT UNIT NUMBER IN FORMAT PARAMETERS
          SHN    21B-3       ALIGN 1ST 12 BIT FORMAT PARAMETER
          STD    P1
          SHN    -16B
          LPN    17B         PICK UPPER 4 BITS FORMAT WORD 2
          SHN    10B         ALIGN UPPER 4 BITS FORMAT WORD 2
          STD    P2          SET FORMAT PARAMETER 2
          LDML   FORMBUF+1
          SHN    -10B        PICK UP LOWER 8 BITS FORMAT WORD 2
          RAD    P2
          LDML   FORMBUF+1   PICK UP UPPER 8 BITS FORMAT WORD 3
          SHN    4           ALIGN USED BITS OF FORMAT WORD 3
          STD    P3          ONLY UPPER BITS FORMAT WORD 3 ARE USED
          LDN    3           GET LENGTH OF PARAMETERS (IN PP WORDS)
          ACN    TP          ACTIVATE THE CHANNEL
          OAM    P1,TP       OUTPUT THE FORMAT PARAMETERS
          FJM    *,TP        WAIT UNTIL DONE
          DCN    40B+TP      DISCONNECT THE CHANNEL
          SFM    OUTCPE,TP   CHECK AND CLEAR CHANNEL PARITY ON OUTPUT
          RJM    GTSTAT      OBTAIN STATUS
          LDML   RESBUF+/RS/P.GSTAT+2  DETAILED STATUS
          LPC    777B
          NJN    FORM45      IF FATAL CONNECT ERROR
          LDML   RESBUF+/RS/P.GSTAT  CHECK BUSY BIT
          LPN    BUSY
          ZJK    NOSTAT      IF UNIT NOT BUSY
          LDN    32B         SET BUSY INDICATION IN WORD 3 OF STATUS
          STML   RESBUF+/RS/P.GSTAT+2
          LDML   RESBUF+/RS/P.GSTAT  SET ALERT BIT
          LPC    3777B
          LMC    4000B
          STML   RESBUF+/RS/P.GSTAT
 FORM45   LDK    /RS/K.HDWR
 FORM50   STML   RESBUF+/RS/P.HDWR  SET RESPONSE
          UJK    FAIL        ABNORMAL TERMINATE

 OUTCPE   RJM    GTSTAT      OBTAIN STATUS
          LDK    /RS/K.CHERO  SET CHANNEL PARITY ON OUTPUT
          UJN    FORM50      SET RESPONSE AND EXIT

          ERRNZ  /RS/P.CHERO-/RS/P.HDWR  IF K.CHERO BIT NOT IN SAME WORD AS K.HDWR

          EJECT
** NAME - CKFL
*
** PURPOSE - CHECK FOR CHARACTER FILL.  IF SET, DECREMENT
*            BYTE COUNT.
*            THEN CHECK FOR LONG BLOCK CONDITIONS.
*
          SPACE  4
 CKFL     SUBR               ENTRY/EXIT
          LDML   RESBUF+/RS/P.CHFL  CHECK IF CHARACTER FILL IS SET
          LPK    /RS/K.CHFL
          ZJN    CKFL10      IF NO CHARACTER FILL
          LDDL   TRNCNT+3
          ADDL   TRNCNT+2
          ZJN    CKFLX       IF NO DATA READ (PROBABLY TAPE MARK)
          SODL   TRNCNT+3    DECREMENT TRANSFER COUNT
          PJN    CKFL10      IF NOT UNDERFLOW
          LDC    177777B     CORRECT 1-S COMPLEMENT RESULT
          STDL   TRNCNT+3
          SODL   TRNCNT+2    ADJUST MOST SIGNIFICANT BITS

 CKFL10   LDDL   RTRNCNT     CHECK FOR LONG BLOCK CONDITIONS
          SBDL   TRNCNT+2    CHECK MOST SIGNIFICANT BITS
          MJN    CKFL20      IF LONG BLOCK
          NJN    CKFLX       IF REQUESTED IS GREATER THAN ACTUAL
          LDDL   RTRNCNT+1   CHECK LEAST SIGNIFICANT BITS
          SBDL   TRNCNT+3
          PJN    CKFLX       IF NOT LONG BLOCK  EXIT

 CKFL20   LDN    2           SET LONG BLOCK FLAG
          STDL   LONG
          UJN    CKFLX       EXIT
          EJECT
** NAME - GTSTAT
*
** PURPOSE - TO GET THE GENERAL AND DETAILED STATUS FOR A 67X TAPE UNIT.
*
          SPACE  4
 GTSTAT   SUBR               ENTRY/EXIT
          LDC    250         SET OUTER LOOP TIME
          STDL   T2
 GTSTAT10 LCN    0           EOP WAIT TIME
          STDL   T1          SET WAIT COUNTER
 STATLP1  LDN    F.GS67      GET GENERAL STATUS FUNCTION FOR 67X
          RJM    DOFUNC      ISSUE GENERAL STATUS FUNCTION
 STALOOP  ACN    TP          ACTIVATE CHANNEL
          LDN    20          WAIT 10 USEC ON 8X PPU SPEED
 STATLP2  FJM    RDSTAT,TP   JUMP WHEN 1ST WORD IS AVAILABLE
          SBN    1
          NJN    STATLP2     IF NOT TIMEOUT
          DCN    TP+40B      DISCONNECT THE CHANNEL
          SODL   T1          DECREMENT WAIT TIME
          NJN    STATLP1     RELOOP TO REISSUE THE STATUS FUNCTION
          SODL   T2          DECREMENT OUTER LOOP TIME
          NJN    GTSTAT10    IF NOT TIMEOUT
          LDK    /RS/K.HDWR
          UJK    FUNTERM  TERMINATE ON NO END OF OPERATION

 RDSTAT   LDN    16          INPUT ALL 16 STATUS WORDS
          IAM    RESBUF+/RS/P.GSTAT,TP  INPUT GENERAL STATUS TO RESPONSE BUFFER
          DCN    TP+40B
          CFM    GTSTATX,TP  CHECK AND CLEAR CHANNEL PARITY ON INPUT
 CPETERM  LDC    /RS/K.CHERR
          STML   RESBUF+/RS/P.CHERR  REPORT CHANNEL PARITY ON INPUT
          UJK    FAIL       TERMINATE ON FUNCTION PROBLEM
          EJECT
** NAME - ERRCHK
*
** PURPOSE - SET ALERT CONDITIONS AND ABNORMAL STATUS FIELDS FOR TAPE.
*
** OUTPUT - (P2) = 0 IF NO ABNORMAL CONDITION.
*           (P2) NON-ZERO IF ERROR DETECTED.
*           (A) = 0 IF NO ERRORS OR TERMINATION CONDITION.
*
          SPACE  4
 ERRCHK   SUBR               ENTRY/EXIT
          LDN    0
          STDL   T1          CLEAR TEMP ALERT CONDITIONS
          STDL   P2          CLEAR TEMP ABNORMAL STATUS
          LDM    RESBUF+/RS/P.GSTAT
          STDL   T4
          LPC    4074B
          ADM    RESBUF+/RS/P.GSTAT+2
          ADDL   LONG
          ZJN    ERRCHKX     IF NO ERRORS TO LOOK AT
          LDDL   LONG
          ZJN    CKPHY       IF NOT LONG INPUT BLOCK
          LDK    /RS/K.LNGBLK  SET LONG INPUT BLOCK CONDITION
          RADL   T1
 CKPHY    LDDL   T4          WORD ONE OF GENERAL STATUS
          LPN    EOT+BOT     MASK OFF PHYSICAL TAPE MARK INDICATORS
          ZJN    CKFMK       SKIP IF NEITHER EOT OR BOT SET
          LDK    /RS/K.PDLIM  SET PHYSICAL DELIMITER
          RADL   T1

 CKFMK    LDDL   T4          WORD ONE OF GENERAL STATUS
          LPN    TPMARK      MASK OFF TAPE MARK INDICATOR
          ZJN    CKLONG      SKIP IF TAPE MARK NOT INDICATED
          LDK    /RS/K.LDLIM  SET LOGICAL DELIMITER
 CKLONG   RADL   T1
          LPML   RESBUF+/RS/P.LONGB  MASK ALERTS WITH ALERT MASK
          STML   RESBUF+/RS/P.LNGBLK  SET ALERT CONDITIONS IN RESPONSE
          ZJN    CKINTER     SKIP IF NO ALERT CONDITIONS ENCOUNTERED
          LDK    /RS/K.ABALRT  SET ABNORMAL ALERT INDICATOR
          RADL   P2

 CKINTER  LDML   RESBUF+/RS/P.GSTAT+2  GET WORD 3 OF HARDWARE STATUS
          ZJN    SETALRT     SKIP IF NO ERRORS ARE INDICATED

          LDML   UITBUF+/UIT/P.UTYPE  FETCH UIT UNIT TYPE
          SBN    T639.1
          NJN    CHKUS       IF NOT ISMT, CHECK UNIT STATUS

          LDC    B.RS        SET ISMT RESPONSE LENGTH (WITH SENSE BYTES)
          STML   RESBUF+/RS/P.RESPL
          LDC    216B        ISSUE ISMT EXTENDED STATUS FUNCTION
          RJM    DOFUNC
          LDN    18          LENGTH OF EXTENDED 16 BIT STATUS WORDS
          ACN    TP
          IAM    RESBUF+/RS/P.XSTAT,TP  INPUT INTO RESPONSE BUFFER
          DCN    40B+TP
          SFM    CPETERM,TP  CHECK AND CLEAR CHANNEL PARITY ON INPUT
 CHKUS    LDM    RESBUF+/RS/P.GSTAT+2  WORD 3 OF HARDWARE STATUS
          SHN    17-10
          MJN    SETHDWE     IF UNIT CHECK
          LPN    1
          ZJN    SETHDWE     IF NOT LOST DATA
          LDK    /RS/K.DATOV  SET DATA OVERRUN
          UJN    SETALRT

 SETHDWE  LDK    /RS/K.HDWR  SET HARDWARE ERROR
 SETALRT  RADL   P2
          STML   RESBUF+/RS/P.ABALRT  SET ABNORMAL STATUS FIELD IN RESPONSE
          UJK    ERRCHKX     RETURN
          EJECT
** NAME - IODONE
*
** PURPOSE - TO TERMINATE THE PP REQUEST
*
** INPUT -
*
** OUTPUT -
*
          SPACE  4
 IODONE   SUBR               ENTRY/EXIT
          RJM    RESP        SEND RESPONSE TO CPU
          LDDL   CONFLG
          ZJN    IODONEX     IF NO UNIT CONNECTED
          LOADC  CM.UIT      CHECK IF PENDING REQUEST FOR CURRENT UNIT
          ADN    /UIT/C.NEXT
          CRDL   T1
          LDDL   T3
          ADDL   T4
          ZJN    IODONE2     IF NO PENDING REQUEST
          LDML   UITBUF+/UIT/P.DSABLE
          LPC    /UIT/K.DSABLE
          ZJN    IODONE3     IF UNIT NOT DISABLED BY PP
 IODONE2  RJM    REL         RELEASE CURRENT UNIT
 IODONE3  RJM    CKCHREQ     CHECK IF CHANNEL REQUESTED BY MALET
          UJK    IODONEX     RETURN
          EJECT
** NAME - REL
*
* PURPOSE - RELEASE CONNECTED UNIT AND CLEAR *UIT* INTERLOCK.
*
* INPUT - (RELA - RELA+2) = CM ADDRESS OF *UIT* TO CLEAR INTERLOCK.
          SPACE  4
 REL      SUBR               ENTRY/EXIT
          LDN    0           CLEAR CONNECTED FLAG
          STDL   CONFLG
          LDN    F.RU67      RELEASE UNIT
          RJM    DOFUNC
          LDN    PULK+40B    RELEASE UNIT INTERLOCK
          RJM    SCLK
          UJN    RELX        RETURN


 RELA     BSSZ   3           CM ADDRESS OF CURRENTLY LOCKED UIT
          EJECT
** NAME - SCLK
*
** PURPOSE - SET/CLEAR SPECIFIED LOCKWORD.
*
** INPUT - (A) = 0000XX IF SET LOCK.
*          (A) = 00004X IF CLEAR LOCK.
*          XX = INDEX INTO TABLE *SCLKA* OF LOCK TO SET/CLEAR.
*
** EXIT - (A) = 0 IF LOCK SUCCESSFULLY SET/CLEARED.
*         (A) .NE. 0 IF LOCK NOT SET/CLEARED.
*
** USES - T1, T2, T5, T7.
          SPACE  4
 SCLK10   RJM    CLOCK       CLEAR INTERLOCK

 SCLK     SUBR               ENTRY/EXIT
          STDL   T2          SAVE ENTRY
          LPN    37B         MASK OFF SET/CLEAR FLAG
          STD    T1
          LDM    SCLKA,T1    SET POINTER TO CM ADDRESS OF LOCKWORD
          STDL   T7
          LDM    SCLKA+1,T1  SET INDEX INTO TABLE
          STDL   T5
          LDDL   T2
          SHN    -5
          NJN    SCLK10      IF CLEAR LOCK
          RJM    LOCK        SET LOCK
          UJK    SCLKX       EXIT


 SCLKA    BSS    0
          LOC    0
 PPLK     CON    CM.PIT,/PIT/C.LOCK  PP REQUEST QUEUE LOCK
 UILK     CON    CM.UIT,/UIT/C.ULOCK  UNIT LOCK IN UNIT INTERFACE TABLE (USED BY *UNITRQ*)
 PULK     CON    RELA,/UIT/C.ULOCK    UNIT LOCK IN UNIT INTERFACE TABLE (USED BY *REL*)
 QULK     CON    CM.UIT,/UIT/C.QLOCK  QUEUE LOCK IN UNIT INTERFACE TABLE
 CHLK     CON    CM.CHAN,0            CHANNEL LOCK
          LOC    *O

 CURCH    EQU    SCLKA+CHLK+1  LOCATION ALWAYS CONTAINS CURRENT CHANNEL NUMBER
          EJECT
** NAME-- LOCK
*
** PURPOSE-- SET A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS SET.
*         A REGISTER .NE. O, IF THE LOCK COULD NOT BE SET.
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T1 = 0, WRITE THE PP LOCKWORD TO CENTRAL MEMORY,
*            AS DESCRIBED IN THIS STEP.  ELSE IF T1 .NE. 0, GO TO
*            STEP 4.
*            TO WRITE THE PP LOCKWORD ID:
*            SET T1 - T4 = 8000 0000 0000 PPNO, WHERE PPNO IS THE
*            LOGICAL PP NUMBER OF THIS PP.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
*
*         4. IF T1 = 8000 AND T4 = PPNO, THIS LOCKWORD WAS ALREADY
*            RESERVED TO THIS PP.
*            RESTORE THE CENTRAL MEMORY LOCATION  (CWDL   T1).
*            SET THE A REGISTER = 0, AND EXIT.
*
*         5. IF T4 .NE. PPNO, THEN THIS LOCKWORD IS RESERVED TO
*            A DIFFERENT PROCESSOR.
*            SET BIT 16 OF THE LOCKWORD THAT WAS READ WITH THE
*            RDSL INSTRUCTION, AND WRITE THE CONTENTS BACK TO
*            CENTRAL MEMORY.
*            THE PURPOSE OF SETTING BIT 16 IS TO REQUEST THE
*            OTHER PROCESSOR TO GIVE UP THE LOCKWORD.
*            LDDL   T2
*            LPC    77777B
*            ADC    100000B
*            STDL   T2
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
          SPACE  4
 LOCK     SUBR               ENTRY/EXIT

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 LOCK10   BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.

          LDDL   T1
          ADDL   T4
          ZJN    LOCK40      IF LOCK CAN BE SET

* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJK    LOCK10      IF THIS PP WAS NOT FIRST TO WRITE
*                            THE INTERMEDIATE VALUE, REPEAT RDSL INSTRUCTION

* SET BIT 16 IN THE ORIGINAL CONTENTS OF CENTRAL MEMORY AND
* WRITE IT BACK TO CENTRAL MEMORY.

          LDDL   T2          SET THE 'REQUEST LOCKWORD' FLAG
          LPC    77777B
          ADC    100000B
          STDL   T2
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE LOCKWORD

          LDDL   T4
          SBDL   PPNO        CHECK IF LOCK ALREADY SET
          NJN    LOCK30      IF LOCK COULD NOT BE SET, EXIT A .NE. 0
          LDDL   T1
          ADC    -100000B
 LOCK30   UJK    LOCKX       IF LOCK WAS ALREADY SET, EXIT A = 0
                             IF LOCK COULD NOT BE SET, EXIT A .NE. 0

* SET THE LOCKWORD.

 LOCK40   BSS
          LDC    100000B
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          LDDL   PPNO
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          SET THE LOCKWORD
          LDN    0
          UJK    LOCK30      EXIT, A REGISTER = 0
          EJECT
** NAME-- CLOCK
*
** PURPOSE-- CLEAR A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS CLEARED.
*         A REGISTER .NE. O, IF THE LOCK WAS NOT CLEARED.
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T4 .NE. PPNO, THIS LOCKWORD IS RESERVED TO A
*            DIFFERENT PROCESSOR.
*            RESTORE THE CONTENTS OF THIS CENTRAL MEMORY LOCATION
*            AS IT EXISTED BEFORE THE VALUE FFFF FFFF XXXX XXXX
*            WAS WRITTEN.
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
*
*         4. IF T4 = PPNO, THEN CLEAR THE LOCKWORD IN CENTRAL MEMORY.
*            SET T1 - T4 = 0000 0000 0000 0000.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
          SPACE  4
 CLOCK    SUBR               ENTRY/EXIT

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 CLK10    BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.
* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJK    CLK10       IF THIS PP WAS NOT FIRST TO WRITE
*                            THE INTERMEDIATE VALUE, REPEAT RSDL INSTRUCTION

          LDDL   T4          CHECK PP NUMBER
          SBDL   PPNO
          ZJN    CLK30       IF THIS PP HAS THE LOCK SET

* RESTORE THE ORIGINAL CONTENTS.

          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE ORIGINAL CONTENTS
          LDN    1
 CLK20    UJK    CLOCKX      EXIT, A REGISTER NONZERO

* CLEAR THE LOCKWORD.

 CLK30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          CLEAR THE LOCKWORD
          LDN    0
          UJK    CLK20       EXIT, A REGISTER = 0
          EJECT
** NAME-- CCLOCK
*
** PURPOSE-- CLEARS THE CHANNEL LOCK IN THE CM CHANNEL TABLE
*
*  OUTPUT-- THE CHANNEL THAT THIS PP HAD LOCKED, WILL BE UNLOCKED.
*
*
          SPACE  4
 CCLOCK   SUBR               ENTRY/EXIT
          LDDL   CONFLG
          ZJN    CCLOCK1     IF NO UNIT CURRENTLY CONNECTED
          RJM    REL         RELEASE UNIT AND CLEAR UIT LOCK
 CCLOCK1  LDDL   CHLOCK      CHECK IF CHANNEL LOCKED
          ZJN    CCLOCKX     IF CHANNEL NOT LOCKED
          LDN    CHLK+40B    CLEAR CHANNEL LOCK
          RJM    SCLK
          LDN    0           CLEAR CHANNEL LOCK FLAG
          STDL   CHLOCK
          UJK    CCLOCKX     EXIT
          EJECT
** NAME-- CKCHREQ
*
** PURPOSE-- CHECK IF CHANNEL IS REQUESTED BY MALET.  IF SO, RELEASE
*            ANY CONNECTED UNIT AND CHANNEL.
*
          SPACE  4
 CKCHREQ  SUBR               ENTRY/EXIT
          LOADC  CM.CHAN     ADDRESS OF CHANNEL TABLE
          ADML   CURCH       CHANNEL IS INDEX INTO TABLE
          CRDL   T1          READ CHANNEL CM ENTRY
          LDDL   T2          OBTAIN MAINTENANCE BYTES OF CHANNEL WORD
          SHN    17-0        ALIGN MAINTENANCE BIT REQUEST TO SIGN BIT
          PJN    CKCHREQX    IF CHANNEL NOT REQUESTED
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          UJN    CKCHREQX    RETURN
          EJECT
** NAME-- RESP
*
** PURPOSE-- WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
*
** INPUT-- CM.PIT, CM.RS, LIM, /PIT/IN, /PIT/OUT, RS+/RS/P.RESPL
*
** OUTPUT-- /PIT/IN, RESPONSE BUFFER
          SPACE  4
 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  4
 RESP     SUBR               ENTRY/EXIT
          LDDL   TRNCNT+3    GET TRANSFER COUNT
          STML   RESBUF+/RS/P.XFER+1  SET TRANSFER COUNT IN RESPONSE BUFFER
          LDDL   TRNCNT+2
          STML   RESBUF+/RS/P.XFER
          LDDL   CMDADR      GET PP ADDRESS OF LAST COMMAND
          ADC    -REQBUF     GET PP WORDS INTO REQUEST
          SHN    1           CM BYTES INTO REQUEST
          ADML   RESBUF+/RS/P.REQ+1  ADD ON HALF 2 OF REQUEST BUFFER RMA
          STML   RESBUF+/RS/P.LASTC+1  RMA HALF 2 OF LAST COMMAND
          SHN    -16         GET CARRY IF ANY
          ADML   RESBUF+/RS/P.REQ  ADD ON HALF 1 OF REQUEST BUFFER RMA
          STML   RESBUF+/RS/P.LASTC  RMA OF HALF 1 OF LAST COMMAND

* READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RESP10   LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF 'IN' POINTER
          CRDL   P1          READ 'IN' POINTER

* CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDDL   INP
          SBDL   OUTP
          MJN    RESP20      IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP
 RESP20   LDML   RESBUF+/RS/P.RESPL  GET RESPONSE LENGTH
          STDL   T1
          LDN    0
          STDL   T2          FLAG TO DETERMINE IF 1 OR 2 BLOCK WRITES
          LDDL   INP
          RADL   T1          IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          PJK    RESP10      IN NOT ENOUGH ROOM IN BUFFER, LOOP
          LDDL   T1
          SBDL   LIM
          MJN    RESP40      IF IN + RESPONSE LENGTH .LT. LIMIT
          STDL   T1          IN + RESPONSE LENGTH - LIMIT = NEW 'IN' POINTER
          AODL   T2          2 BLOCK WRITES REQUIRED

* WRITE RESPONSE TO CM.

 RESP40   BSS
          LDDL   INP
          SHN    -3
          STDL   T3          'IN' POINTER IN WORDS
          LDML   RESBUF+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          STDL   T5
          LDDL   T2
          ZJN    RESP50      IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADC    RESBUF
          STML   RESPA       RESPONSE ADDRESS FOR 2ND BLOCK WRITE
 RESP50   BSS
          LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD 'IN' OFFSET
          CWML   RESBUF,T4   WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          SBDL   T4
          ZJN    RESP70      IF ONLY 1 BLOCK WRITE REQUIRED
          STDL   T5          RESPONSE LENGTH - (LIMIT - IN)
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          LMC    400000B
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
 RESPA    EQU    *-1         (BEGINNING OF RESPONSE BUFFER)
 RESP70   BSS
          LDDL   T1          NEW IN POINTER
          STDL   P4

* SET UP INTERRUPT PROCESSOR INSTRUCTION IF INTERRUPT IS SELECTED.

          LDML   RESBUF+/RS/P.INT  CHECK IF INTERRUPT WAS SELECTED
          LPK    /RS/K.INT
          NJN    RESP80      IF INTERRUPT SELECTED
          LDC    PSNI        PSN INSTRUCTION
          UJN    RESP90

 RESP80   BSS
          LDML   RESBUF+/RS/P.PORT  GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RS/L.PORT+/RS/N.PORT
          LPN    /RS/M.PORT
          ADC    INPNI       INPN INSTRUCTION
 RESP90   BSS
          STML   INTPRC

*  WRITE UPDATED 'IN' POINTER FOR CM RESPONSE BUFFER TO PIT.

          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   P1          WRITE NEW 'IN' POINTER TO CM

*  INTERRUPT PROCESSOR.

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   PPNO-3      SET LAST BYTE NON-ZERO
          LDN    0           SET (A)=0 FOR S0 MAINFRAME
 INTPRC   INPN   1           INTERRUPT OR PSN
          CRDL   T1          ACCESS CM (NEEDED FOR 810/830)
          LJM    RESPX       EXIT
          EJECT
** NAME - CHGCH
*
** PURPOSE - CHANGE CHANNEL NUMBER IN CHANNEL INSTRUCTIONS
*
** INPUT - (CURCH) = CHANNEL NUMBER.
*          (A) = CHANNEL TABLE ADDRESS.
*
          SPACE  4
 CHGCH    SUBR               ENTRY/EXIT
          STDL   T1          SET ADDRESS MODIFICATION LIST ADDRESS
 CHG10    LDIL   T1          READ LIST WORD
          ZJN    CHGCHX      IF END OF LIST
          STDL   T2          SET INSTRUCTION ADDRESS
          LDIL   T2          READ INSTRUCTION WORD
          SCN    37B         CLEAR CHANNEL BITS
          LMML   CURCH       REPLACE WITH NEW CHANNEL
          STIL   T2
          AODL   T1          INCREMENT TO NEXT INSTRUCTION
          UJN    CHG10       LOOP
          EJECT
** NAME - RESPSU
*
** PURPOSE - SET UP RESPONSE BUFFER
*
** INPUT - PIT, REQUEST AND (IF UNIT REQUEST) UIT READ INTO PP MEMORY.
*          *RESPSUA* SET UP FOR UIT OR PIT PVA/RMA PP BUFFER ADDRESS.
*
** OUTPUT - NECESSARY INFORMATION PLACED IN REQUEST BUFFER.  THE REMAINDER
*           OF THE BUFFER IS ZEROED OUT.
*
          SPACE  4
 RESPSU   SUBR               ENTRY/EXIT

*         ZERO OUT RESPONSE BUFFER STARTING AT ABNORMAL STATUS FIELD.

          LDN    /RS/C.XSTAT-/RS/C.ABALRT  NUMBER OF CM WORDS TO CLEAR
          STDL   T5
          LOADC  CM.COM      LOAD R AND A OF PP COMMUNICATION BUFFER
          ADN    /CB/C.ZEROES  READ FROM ZERO BLOCK
          CRML   RESBUF+/RS/P.ABALRT,T5  ZERO PART OF RESPONSE BUFFER

*         MOVE LOGICAL UNIT, RECOVERY, INTERRUPT, PORT, PRIORITY
*         AND ALERT MASK FROM REQUEST TO RESPONSE BUFFER.

          LDML   REQBUF+/RQ/P.LU
          STML   RESBUF+/RS/P.LU
          LDML   REQBUF+/RQ/P.RECOV
          STML   RESBUF+/RS/P.RECOV
          LDML   REQBUF+/RQ/P.LONGB
          STML   RESBUF+/RS/P.LONGB
          LDC    NORMRES     SET LENGTH IN RESPONSE BUFFER
          STML   RESBUF+/RS/P.RESPL

*         MOVE CURRENT REQUEST PVA/RMA FROM UIT OR PIT TO RESPONSE BUFFER.
*         *RESPSUA* IS SET UP FOR UIT OR PIT PVA/RMA PP BUFFER ADDRESS.

          LOADC  CM.COM      LOAD R AND A OF PP COMMUNICATION BUFFER
          ADN    /CB/C.SCRAT  USE SCRATCH AREA
          CWML   **,TW
 RESPSUA  EQU    *-1
          SBN    2
          CRML   RESBUF,TW
          LJM    RESPSUX     RETURN


*         ENSURE THAT NUMBER OF ZERO BYTES IN PP COMMUNICATION BUFFER
*         IS ENOUGH TO ZERO THE NECESSARY PORTION OF THE RESP. BUFFER.
*         NOTE THAT WE DO NOT ZERO OUT THE LAST 40 OCTAL BYTES (8 PP WORDS) OF
*          THE EXTENDED STATUS AREA OF THE RESPONSE. WE DO NOT WISH TO TAKE THE
*          TIME AND THE CPU ZEROS AREA IS ONLY 15 CM WORDS IN LENGTH.

          ERRNG  /CB/B.ZEROES+/RS/C.ABALRT*8-/RS/C.XSTAT*8
          EJECT
** NAME - DOFUNC
*
** PURPOSE - ISSUE FUNCTION TO A CONTROLLER.
*
** INPUT - (A) = FUNCTION CODE TO ISSUE.
*
          SPACE  4
 DOFUNC   SUBR               ENTRY/EXIT
          STDL   LASTFC      SAVE FUNCTION CODE
          SBN    F.GS67
          ZJN    FUN1        IF STATUS REQUEST
          ADN    F.GS67
          STDL   LASTFC1     SAVE LAST NON-STATUS FUNCTION
 FUN1     LDC    0           EQUIPMENT NUMBER - SET IN *UNITRQ*
 FUNA     EQU    *-1
          ADDL   LASTFC      ADD FUNCTION CODE TO EQ NUMBER
          AJM    FUN40,TP    JUMP IF CHANNEL ACTIVE
          FAN    TP          ISSUE THE FUNCTION
          LDC    100         TIMEOUT 2-4 SECONDS ON ALL FUNCTIONS
          STDL   T0
 FUN5     LDC    100000      SET FOR MAXIMUM DELAY OF 100 MSEC.
 FUN10    IJM    DOFUNCX,TP  EXIT IF CHANNEL INACTIVE
          SBN    1
          NJN    FUN10       CONTINUE LOOPING UNTIL 100 MSEC EXPIRES
          SODL   T0          DECREMENT TIMEOUT COUNTER
          NJN    FUN5        RELOOP UNTIL TIMEOUT
 FUN40    DCN    40B+TP      DISCONNECT CHANNEL
          LDDL   LASTFC
          LMN    F.RU67
          ZJN    DOFUNCX     IF TIMEOUT OCCURRED ON RELEASE FUNCTION
          LDM    DOFUNC      FETCH CALLERS ADDRESS FOR RNI
          LMC    STALOOP
          ZJN    FUN50       IF GENERAL STATUS FUNCTION REQUEST
          RJM    GTSTAT       OBTAIN STATUS FOR LAST FUNCTION TIMEOUT
          LDML   RESBUF+/RS/P.GSTAT+2  STATUS WORD 3
          ZJN    FUN50       IF STATUS DOES NOT DIAGNOSE ERROR
          LDK    /RS/K.HDWR  SET HARDWARE MALFUNCTION
          UJN    FUNTERM     STORE RESPONSE BIT

 FUN50    LDC    /RS/K.FTO  FUNCTION TIMEOUT RESPONSE
 FUNTERM  STML   RESBUF+/RS/P.FTO  SET ABNORMAL RESPONSE FLAG BITS
          UJK    FAIL       TERMINATE TAPE REQUEST


          ERRNZ  /RS/P.FTO-/RS/P.HDWR  IF K.FTO BIT NOT IN SAME WORD AS K.HDWR
          EJECT
** NAME-- FORMA
*
** PURPOSE-- FORMAT A CM REAL MEMORY ADDRESS.
*
** CALLING SEQUENCE-- LDC    ADDRESS
*                     RJM    FORMA
*
** INPUT-- - A REGISTER- IS THE ADDRESS OF A 2-WORD CM BYTE ADDRESS.
*
** OUTPUT-- -CMADR- IS THE ADDRESS OF THE RESULTING 3-WORD REFORMATED
*                CM ADDRESS.  THE FORMAT CAN BE USED BY THE LOADC MACRO.
*           -ADDRESS-, WORD 0, BITS 0-13 AND
*                      WORD 1, BITS 3-15, ARE REFORMATTED TO-
*           -CMADR-,   WORD 0, BITS 0-9,
*                      WORD 1, BITS 0-11,
*                      WORD 2, BITS 0-5.
*
          SPACE  4
 FORMA    SUBR               ENTRY/EXIT
          STDL   T1

* REFORMAT CM ADDRESS.

          LDML   1,T1
          LPN    7
          NJN    *           RMA ADDRESS ERROR, TEMPORARY HALT
          LDIL   T1
          LPN    37B
          SHN    16
          LMML   1,T1
          SHN    9
          STD    CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   T1
          SHN    -5
          STD    CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMC    400000B
          UJK    FORMAX      EXIT
          EJECT
** NAME -- PAUS
*
** PURPOSE-- DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*            MICROSECONDS.
*
** INPUT-- A REGISTER SPECIFIES NUMBER OF MICROSECONDS
*          TO BE DELAYED.
*
          SPACE  4
 PAUS     SUBR               ENTRY/EXIT
 PAUS10   SBN    1           EACH ITERATION OF THIS SBN-NJN LOOP
          PSN
          PSN
          NJN    PAUS10      UTILIZES 1 MICRO SECOND
          UJK    PAUSX
          EJECT
 PPTBL    BSSZ   P.PIT       PP INTERFACE TABLE
 UNITD    BSSZ   P.UD*8      UNIT DESCRIPTOR PART OF PIT FOR 8 UNITS
*                            NOTE THIS MUST IMMEDIATLY FOLLOW PPTBL
 UITBUF   BSSZ   P.UIT       UNIT INTERFACE TABLE
 REQBUF   BSSZ   MAXREQ*4    SET REQUEST BUFFER LENGTH
 FORMBUF  EQU    REQBUF+12   FORMAT UNIT DATA IS AT WORD 4 OF REQ BUF
 CMDBUF   EQU    REQBUF+/RQ/P.CMND  COMMAND BUFFER
 RESBUF   BSSZ   P.RS        RESPONSE BUFFER LENGTH (MAXIMUM)
 RESBID   EQU    RESBUF+/RS/P.RESBID  BID RESPONSE AREA
 CORCNT   EQU    RESBUF+/RS/P.CORCNT  HARDWARE CORRECTION COUNT
 RESCNT   EQU    RESBUF+/RS/P.RESCNT  BID RESPONSE COUNT
 INDLSTA  BSSZ   2           CURRENT INDIRECT LIST ADDRESS RMA
 INDLIST  BSSZ   4           INDIRECT LIST LENGTH/ADDRESS PAIR
          EJECT
** NAME-- INIT
*
** PURPOSE-- INITIALIZE THE DRIVER AFTER DEADSTART.
*
** INPUT-- DSRTP = CM BYTE-ADDRESS OF THE WORD CONTAINING A POINTER
*                  TO THE PP INTERFACE TABLE.
          SPACE  4
 INIT     BSS

*  PAUSE A SUFFICIENT AMOUNT OF TIME TO PERMIT THE DEADSTART PP
*  TO DISCONNECT ALL CHANNELS.

          PAUSE  111000      DELAY 111 MILLISECONDS

* CLEAR REMAINDER OF PP MEMORY  AND BURN ABOUT 14 MILLISECONDS IN THE PROCESS

          LDC    ENDMEM-ENDCODE
          STDL   T1          SET INDEX
 INIT1    LDN    0
          STML   ENDCODE,T1  CLR PP WORD
          SODL   T1          DECREMENT INDEX
          PJN    INIT1       IF NOT DONE LOOP
          LDN    1           SET CONSTANTS
          STD    ON
          LDN    2
          STD    TW

*  READ PP_INTERFACE_TABLE AND UNIT DESCRIPTOR TABLES.  NOTE - THIS IS
*  THE ONLY PLACE THE STATIC FIELDS OF THE PIT AND THE UNIT DESCRIPTOR
*  TABLES ARE READ INTO THE PP.  IF THE UNIT DESCRIPTOR TABLES EVER
*  CONTAIN DYNAMIC FIELDS, THEY MUST BE READ IN WHEN LOOKING FOR UNIT
*  REQUESTS.  ONLY UNIT DESCRIPTORS THAT ARE NOT NULL ENTRIES ARE SAVED
*  IN THE PP COPY.

          LDN    C.PIT       LENGTH OF PIT
          STDL   WC
          REFAD  DSRTP,CM.PIT  REFORMAT AND LOAD CM ADDRESS OF PIT
          CRML   PPTBL,WC    READ PIT

          LDML   PPTBL       SAVE PP NUMBER
          STDL   PPNO

          LDML   PPTBL+/PIT/P.UNITC  NUMBER OF UNIT DESCRIPTORS
          STDL   T1
          ZJK    INIT7       IF NO UNITS DEFINED
          LDN    0           INITIALIZE LOOP CONTROL
          STDL   T2          NUMBER OF NON-NULL UNIT DESCRIPTORS
          STDL   T3          PP WORD OFFSET INTO UNIT DESCRIPTORS
          STDL   T4          CM WORD OFFSET INTO UNIT DESCRIPTORS
 INIT3    LOADC  CM.PIT      LOAD R REGISTER FOR PIT
          ADN    C.PIT       ADVANCE TO START OF UNIT DESCRIPTORS
          ADDL   T4          CM WORD OFFSET OF CURRENT UD
          CRML   UNITD,TW    READ UD ENTRY INTO PP
 INITC    EQU    *-1
          LDML   UNITD+/UD/P.UQT,T3
          ADML   UNITD+/UD/P.UQT+1,T3
          ZJN    INIT5       IF DUMMY ENTRY, DO NOT COUNT
          AODL   T2          INCREMENT COUNT OF ACTIVE UNITS
          SBN    8
          ZJN    INIT6       IF REACHED MAX TABLE SPACE FOR UDS
          LDN    P.UD        INCREMENT TO NEXT PP UD
          RADL   T3
          LDN    P.UD
          RAML   INITC
 INIT5    LDN    C.UD        INCREMENT TO NEXT CM UD
          RADL   T4
          SODL   T1          DECREMENT TOTAL UNITS IN PIT
          NJN    INIT3       IF NOT DONE SCANNING UD TABLES
 INIT6    LDDL   T2          RESET NUMBER OF ACTIVE UNITS
          STML   PPTBL+/PIT/P.UNITC

*  REFORMAT ADDRESS OF RESPONSE BUFFER.
*  INITIALIZE LIM.

 INIT7    REFAD  PPTBL+/PIT/P.RSBUF,CM.RS  REFORMAT AND LOAD ADDRESS OF RESP. BUFFER
          LDML   PPTBL+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STDL   LIM

*  REFORMAT ADDRESS OF THE INTERRUPT WORD.

          REFAD  PPTBL+/PIT/P.INT,CM.INT

*  REFORMAT ADDRESS OF CHANNEL TABLE.

          REFAD  PPTBL+/PIT/P.CHAN,CM.CHAN

*  REFORMAT ADDRESS OF PP COMMUNICATIONS BUFFER

          REFAD  PPTBL+/PIT/P.CBUF,CM.COM

*  CHECK IF LOAD ISMT CONTROLWARE MICROCODE.

 INIT10   LOADF  UNITD+/UD/P.UQT  REFORMAT RMA OF UIT
          CRML   UITBUF,ON   OBTAIN UIT
          LDML   UITBUF+/UIT/P.UTYPE  UNIT TYPE
          SBN    T639.1
          ZJN    INIT20            IF ISMT
          LDC    7775B             NOT ISMT ERROR CODE
          LJM    INIT149           REPORT STATUS IN UNSOLICITED RESPONSE

*  INITIALIZE CHANNEL INSTRUCTIONS.

 INIT20   LDML   UNITD+/UD/P.CHAN  OBTAIN PRESENT CHANNEL NUMBER
          SHN    -8
          STML   CURCH
          ZJN    INIT30      IF CHANNEL IS ZERO, NO CHANGE REQUIRED
          LDC    CONCH       MODIFY CHANNEL INSTRUCTIONS
          RJM    CHGCH
 INIT30   LDN    CHLK        SET CHANNEL LOCK
          RJM    SCLK
          NJN    INIT30      IF CHANNEL CURRENTLY LOCKED
          AODL   CHLOCK      SET CHANNEL INTERLOCKED FLAG

*  READ UP CONTROLWARE LOAD COMMAND (LENGTH AND RMA OF CONTROLWARE ADDRESS/LENGTH PAIRS)

 INIT85   LOADC  CM.COM      LOAD R AND A OF PP COMMUNICATION BUFFER
          ADN    /CB/C.CONTRL  ADD CONTROLWARE POINTER OFFSET
          CRML   CNTCMDW,ON         NOW HAVE LENGTH AND PTR TO ADDRESS/PAIR LIST
          LDML   CNTCMDW
          SHN    -10
          LMN    3
          NJN    INIT85            IF CONTROLWARE LIST NOT READY YET
          DCN    40B+TP      INITIALIZE CHANNEL BY DEACTIVATE ATTEMPT
          CFM    INIT86,TP   INITIALIZE CHANNEL ERROR FLAG

* SEND AUTOLOAD FUNCTION AND ACTIVATE CHANNEL

 INIT86   LDK    F.MCLR        AUTOLOAD FUNCTION
          RJM    IFUNC         ISSUE FUNCTION
          ZJN    INIT89        IF FUNCTION ACCEPTED
          LDC    7777B         SET ISMT AUTOLOAD TIMEOUT CODE
          LJM    INIT149       REPORT STATUS IN UNSOLICITED RESPONSE

 INIT89   PSN
          PSN
          PSN
          ACN    TP

 INIT95   LOADF  CNTCMDW+/CM/P.RMA  REFORMAT ADDRESS TO CURRENT PAIR
          CRML   CURPAIR,ON
          LOADF  CURPAIR+/CM/P.RMA
          LDML   CURPAIR+/CM/P.LEN
          ADN    1                  CALCULATE CH WORD COUNT
          SHN    -1
          STDL   IOCNT              SET CH WORD COUNT
          ZJN    INIT140            IF 0 CH WORDS LEFT

          LDDL   CMADR+2            SET A FOR CM ADDRESS OF DATA
          LMC    400000B
          CMCH   IOCNT,TP           OUTPUT BLOCK TO ISMT ADAPTER
          FJM    *,TP               WAIT TILL LAST WORD TAKEN THIS TRANSFER
          LDDL   IOCNT              CHECK REMAINING CH WORD COUNT
          NJN    INIT140            IF NOT ALL TAKEN

          LDML   CNTCMDW+/CM/P.LEN  DECREMENT ADDRESS PAIR COUNT
          SBN    8
          STML   CNTCMDW+/CM/P.LEN  SAVE REMAINING LENGTH
          ZJN    INIT140            IF NO MORE ADDRESS WITH DATA
          LDN    8
          RAML   CNTCMDW+/CM/P.RMA+1  UPDATE ADDRESS TO NEXT DATA AREA
          SHN    -16
          RAML   CNTCMDW+/CM/P.RMA
          UJK    INIT95             DO NEXT BLOCK

 INIT140  DCN    40B+TP
          CFM    INIT145,TP        JUMP IF CH ERROR FLAG IS CLEAR
          LDC    7776B             SET CH ERROR FLAG ERROR CODE
          UJN    INIT149           REPORT STATUS IN UNSOLICITED RESPONSE

 INIT145  LDN    F.GS67            ISSUE STATUS FUNCTION
          RJM    IFUNC             ISSUE FUNCTION
          ZJN    INIT147           IF FUNCTION ACCEPTED
          LDN    0
          UJN    INIT149           SEND ISMT STATUS OF ZERO ON TIMEOUT

 INIT147  ACN    TP
          IAN    TP                INPUT GENERAL STATUS
          DCN    40B+TP
 INIT149  STM    RESBUF+/RS/P.GSTAT  SET ISMT GENERAL STATUS
          LDN    R.UNS             UNSOLICITED RESPONSE CODE
          RAML   RESBUF+/RS/P.RC   SET IN RESPONSE AREA
          LDC    NORMRES           SET LENGTH OF RESPONSE BUFFER
          STML   RESBUF+/RS/P.RESPL
          RJM    RESP              SEND UNSOLICITED RESPONSE
          LDN    0           ZERO OUT *ZEROES* FIELD IN COMM. BUFFER
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDK    /CB/B.ZEROES  LENGTH OF ZERO AREA IN BYTES
          SHN    -3
          STDL   T5          LENGTH OF ZERO AREA IN CM WORDS
 INIT156  LOADC  CM.COM      LOAD R AND A OF COMMUNICATION BUFFER
          ADN    /CB/C.ZEROES-1
          ADDL   T5
          CWDL   T1          ZERO ONE CM WORD
          SODL   T5          DECREMENT INDEX
          NJN    INIT156     IF MORE CM WORDS TO CLEAR
          LJM    TAPE        EXIT TO MAIN LOOP
          EJECT
** NAME - IFUNC
*
** PURPOSE - ISSUE AND TIMEOUT INITIALIZATION FUNCTIONS
*
** INPUT - (A) = FUNCTION TO ISSUE
*
** OUTPUT - A = 0  IF FUNCTION ACCEPTED
*         - A .NE. 0  IF FUNCTION TIMEOUT (CHANNEL IS DEACTIVATED)
          SPACE  4
 IFUNC30  LDN    0           SET FUNCTION ACCEPTED

 IFUNC    SUBR               ENTRY/EXIT
          FAN    TP          ISSUE FUNCTION
          LDK    64          OUTER LOOP TIMEOUT
          STDL   T1
 IFUNC10  LCN    0           INNER LOOP TIMEOUT
 IFUNC20  IJM    IFUNC30,TP  IF FUNCTION ACCEPTED
          SBN    1
          NJN    IFUNC20     IF NOT INNER LOOP TIMEOUT
          SODL   T1
          NJN    IFUNC10     IF NOT OUTER LOOP TIMEOUT
          DCN    TP+40B      DISCONNECT CHANNEL
          LDN    1           SET FUNCTION TIMEOUT
          UJN    IFUNCX      RETURN
          SPACE  4
 CNTCMDW  BSSZ   4           SECOND WORD OF PP COMM. BUFFER
 CURPAIR  BSSZ   4           LENGTH/ADDRESS FOR ISMT CONTROLWARE
          SPACE  4
 CONCH    BSS                CHANNEL MODIFICATION LIST
 TTP+40B  HERE
 T40B+TP  HERE
 TTP      HERE
          CON    0           END OF TABLE
          SPACE  4
 ENDCODE  EQU    *           END OF PP CODE AREA
          ERRNG  ENDMEM-ENDCODE
          EJECT
          END    TAPB
/EOR

*DECK DECK=TAPE EXPAND=TRUE
          IDENT  TAPE
          CIPPU
          TITLE  TAPE
          COMMENT *SMD* LVL=04
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC. 1992

*copyc iodmac1 "record definition macros"
*copyc iodmac2 "load/store macros"
*copyc iodmac3 "general macros"
*copyc iodmac4 "general macros"

* PP TABLE.

 PT       RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 PART     PPWORD             PARTNER PP NUMBER
 PIT      RMA                PP INTERFACE TABLE ADDRESS (RMA)
 PITPVA   STRUCT 24          PP INTERFACE TABLE ADDRESS (PVA)

 PT       RECEND
          SPACE  6
* PP INTERFACE TABLE
 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
          ALIGN  0,64
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
          PPWORD             UNUSED
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER
          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)
          ALIGN  32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          SPACE  6
* UNIT DESCRIPTORS.

 UD       RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 UD       RECEND
          SPACE  6
* UNIT INTERFACE TABLE

 UIT      RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
                               = 400B, 844-4X
                               = 401B, 885-1X
                               = 402B, 885-42
 QCNT     PPWORD             QUEUE COUNT
*
          ALIGN  16,64
 UBUFL    PPWORD             UNIT COMMUNICATION BUFFER LENGTH
 UBUF     RMA                UNIT COMMUNICATION BUFFER (RMA)
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

          MASKP  DSABLE
 K.DSABLE EQU    MSK

 UIT      RECEND
          SPACE  6
* PP REQUESTS.

 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS
                               0 - ATTEMPT RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
 LONGB    BOOLEAN            LONG INPUT BLOCK
          ALIGN  0,64
 SECADR   INTEGER            SECONDARY ADDRESS
 CMND     INTEGER            COMMAND SEQUENCE

 RQ       RECEND
          SPACE  6
* PP COMMAND.

 CM       RECORD PACKED

 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MGEN   N.CODE
 M.CODE   EQU    MASK$

 CM       RECEND
          SPACE  6
* PP RESPONSE.

 RS       RECORD PACKED

          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
          ALIGN  48,64       ALERT MASK
 LONGB    BOOLEAN            LONG INPUT BLOCK
          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE INTERFACE
                             ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
 CHERR    BOOLEAN            CHANNEL PARITY ERROR ON INPUT
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION
                             OCCURRED ON INPUT OR INADEQUATE DATA RATE ON OUTPUT
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A
                             HARDWARE MALFUNCTION.  EX: UNIT NOT READY,
                             UNIT NOT CONNECTED.
 FTO      BOOLEAN            FUNCTION TIMEOUT
 CHERO    BOOLEAN            CHANNEL PARITY ERROR ON OUTPUT
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 _ INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
                               1 - RECOVERED ERROR
                               2 - COMMAND HAD EXPLICIT RESPONSE FLAG SET
                               3 - BOTH CONDITIONS 1 AND 2
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE
                               1 - UNIT CHANGED FROM READY TO NOT READY
                               2 - UNIT CHANGED FROM NOT READY TO READY
                               3 - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
          ALIGN  48,64       ALERT CONDITIONS
 LNGBLK   BOOLEAN            LONG INPUT BLOCK
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
 PDLIM    BOOLEAN            PHYSICAL DELIMITER ENCOUNTERED (EOT OR BOT)
 LDLIM    BOOLEAN            LOGICAL DELIMITER ENCOUNTERED (TAPE MARK)
 CHARF    BOOLEAN            CHARACTER FILL PERFORMED
 DUNIT    BOOLEAN            UNIT WAS DISABLED BY PP
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)
 RESBID   STRUCT 60          AREA CONTAINING INDIVIDUAL BID RESPONSES FOR THE REQUEST
 CORCNT   STRUCT 2           COUNT OF ON THE FLY CORRECTIONS BY THE TAPE HARDWARE
 RESCNT   STRUCT 2           COUNT OF INDIVIDUAL BID RESPONSES FOR THIS REQUEST
 GSTAT    SUBRANGE 0,1777B   MAPPED STATUS WORD 1
 CHFL     BOOLEAN            CHARACTER FILL
          SUBRANGE 0,37B
 MSTAT    STRUCT 30          MAPPED STATUS WORDS 2 THROUGH 16

*THE EXTENDED STATUS AREA IS DEFINED TO PROVIDE THE LONG BLOCK FLUSHING BUFFER
* OF 24 DECIMAL PP WORDS THAT STARTS AT GSTAT.  WE ONLY NEED AN ADDITIONAL 8
* BYTES (4 PP WORDS), SO WE HAVE 32 DECIMAL BYTES (16 PP WORDS) THAT COULD BE
* OBTAINED IF SPACE BECOMES CRITICAL. WE ONLY OBTAIN EXTENDED STATUS ON AN ERROR.

 XSTAT    STRUCT 40          CMTS/ISMT EXTENDED STATUS AREA (5 CM WORDS)

          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$
          MASKP  ABALRT
 K.ABALRT EQU    MSK
          MASKP  HDWR
 K.HDWR   EQU    MSK
          MASKP  CHERR
 K.CHERR  EQU    MSK
          MASKP  DATOV
 K.DATOV  EQU    MSK
          MASKP  FTO
 K.FTO    EQU    MSK
          MASKP  LNGBLK
 K.LNGBLK EQU    MSK
          MASKP  PDLIM
 K.PDLIM  EQU    MSK
          MASKP  LDLIM
 K.LDLIM  EQU    MSK
          MASKP  CHARF
 K.CHARF  EQU    MSK
          MASKP  DUNIT
 K.DUNIT  EQU    MSK
          MASKP  CHFL
 K.CHFL   EQU    MSK
          MASKP  CHERO
 K.CHERO  EQU    MSK

 RS       RECEND
          SPACE  6
* PP COMMUNICATION BUFFER.

 CB       RECORD PACKED

          ALIGN  31,64
 SLAVE    BOOLEAN            NONZERO IF SLAVE PP
 PARTNR   RMA                PARTNERS PIT (RMA)

 CONTRL   STRUCT 8           LOAD CONTROLWARE COMMAND
 CMCMD    STRUCT 8           CONTROL MODULE COMMAND
 CWPVA    STRUCT 24          CONTROLWARE RMA LIST PVA
 CMPVA    STRUCT 24          CONTROL MODULE RMA LIST PVA
 COMM     STRUCT 16          MASTER/SLAVE COMMUNICATION AREA
 SCRAT    STRUCT 16          SCRATCH AREA (SINGLE OR DUAL MASTER ONLY)
 ZEROES   STRUCT 120         120 BYTES (15 CM WORDS) OF ZERO


          MASKP  SLAVE
K.SLAVE   EQU    MSK


 CB       RECEND
          SPACE  6
* RESPONSE CODES.
 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    40000B      INTERMEDIATE RESPONSE
 R.NRM    EQU    100000B     NORMAL REQUEST TERMINATION
 R.ABN    EQU    140000B     ABNORMAL REQUEST TERMINATION
 R.RCV    EQU    10000B      RECOVERED ERROR CAUSED RESPONSE
 R.FLG    EQU    20000B      FLAG FIELD CAUSED RESPONSE

* UNSOLICITED RESPONSE CODES
 URC.RN   EQU    1           CHANGE FROM READY TO NOT READY
 URC.NR   EQU    2           CHANGE FROM NOT READY TO READY
 URC.IE   EQU    3           INTERNAL OR INTERFACE ERROR
          EJECT
 TP       EQU    0           CHANNEL NUMBER
 DSC      EQU    0           DST-DSP COMMUNICATIONS CHANNEL

 ALERT    EQU    4000B       ALERT CONDITION IN WORD 1 OF HARDWARE STATUS
 EOT      EQU    10B         END OF TAPE INDICATOR IN WORD 1 OF STATUS
 BUSY     EQU    2           BUSY INDICATOR IN WORD 1 OF STATUS
 BOT      EQU    4           BEGINNING OF TAPE INDICATOR IN WORD 1 OF STATUS
 TPMARK   EQU    20B         TAPE MARK INDICATOR IN WORD 1 OF STATUS
 CFILL    EQU    40B         CHARACTER FILL INDICATOR IN WORD 1 OF STATUS
 LOSTD    EQU    4000B       LOST DATA INDICATOR IN WORD 3 OF STATUS
 TPERR    EQU    3777B       HARDWARE ERROR BITS IN WORD 3 OF STATUS

 TIMERR   EQU    400B        TIMEOUT INTERFACE ERROR CODE BASE
 PITERR   EQU    1000B       PIT INTERFACE ERROR CODE BASE
 UITERR   EQU    1400B       UIT INTERFACE ERROR CODE BASE
 RQHERR   EQU    2000B       REQUEST HEADER INTERFACE ERROR CODE BASE
 CMDERR   EQU    2400B       COMMAND SEQUENCE INTERFACE ERROR CODE BASE

 F.RU67   EQU    1           RELEASE CONNECTED UNIT COMMAND FOR 67X
 F.FU67   EQU    4           FORMAT 67X TAPE COMMAND
 F.GS67   EQU    12B         GENERAL STATUS FUNCTION FOR 67X TAPES
 F.READ   EQU    40B         READ FORWARD
 F.MCLR   EQU    414B        MASTER CLEAR
 WRCMD    EQU    50B         WRITE HARDWARE FUNCTION FOR 67X TAPES
 SWRCMD   EQU    250B        SHORT WRITE HARDWARE FUNCTION FOR 67X TAPES
 F.MCLEAR EQU    100000B     MASTER CLEAR CIO ADAPTER BOARD
 F.WRCR   EQU    111000B     WRITE CONTROL REGISTER OF CIO ADAPTER
 F.RDESR  EQU    112000B     READ ERROR STATUS REGISTER OF CIO ADAPTER

 L.GS67   EQU    16          LENGTH OF STATUS IN 67X IN PP WORDS
 PITLEN   EQU    C.PIT+C.UD*8  LENGTH OF PP INTERFACE TABLE IN CM WORDS

 T639.1   EQU    16          UIT UNIT TYPE FOR 639-1 TAPE DRIVE
 T698     EQU    17          UIT UNIT TYPE FOR 698-XX TAPE DRIVE

 PJNI     EQU    0600B       PJN INSTRUCTION
 PSNI     EQU    2400B       PSN INSTRUCTION
 RJMI     EQU    0200B       RJM INSTRUCTION
 NJNI     EQU    0500B       NJN INSTRUCTION
 LDNI     EQU    1400B       LDN INSTRUCTION
 LDCI     EQU    2000B       LDC INSTRUCTION
 INPNI    EQU    102600B     INPN INSTRUCTION
 CRMLI    EQU    106100B     CRML INSTRUCTION
 CWMLI    EQU    106300B     CWML INSTRUCTION

 INDFLG   EQU    100B        INDIRECT ADDRESSING FLAG
 STRSP    EQU    200B        STORE RESPONSE FLAG

 MAXIND   EQU    5           MAX INDIRECT LIST LENGTH
 MAXREQ   EQU    65          MAX REQUEST LENGTH IN CM WORDS
 ENDMEM   EQU    7777B       LARGEST PP MEMORY ADDRESS
 IOBUFLNG EQU    2064        LENGTH OF I/O BUFFER
 STIOBUF  EQU    ENDMEM-IOBUFLNG  STARTING ADDRESS OF I/O BUFFER
 DUALBUFL EQU    480         LENGTH OF DUAL PP I/O BUFFER IN PP WORDS
 DUALBUF  EQU    ENDMEM-DUALBUFL  STARTING ADDRESS OF DUAL PP I/O BUFFER
 WDCOUNT  EQU    640         640 CHANNEL WORDS = 960 BYTES
 NCCOMD   EQU    376B        NEW CHANNEL COMMAND
 HSHAKC   EQU    377B        HAND SHAKE COMMAND
 NORMRES  EQU    B.RS-5*8    LENGTH OF RESPONSE BUFFER IN BYTES (WITHOUT SENSE BYTES)

 FUNCCMD  EQU    40B         PHYSICAL COMMAND - FUNCTION (20 HEX)
 PWRTCMD  EQU    43B         PHYSICAL COMMAND - OUTPUT 8-BIT DATA (23 HEX)
 IDLCMD   EQU    4           PP IDLE COMMAND
 RSUMCMD  EQU    5           PP RESUME COMMAND
 LCREAD   EQU    101B        LOCICAL READ RECORD OF 8-BIT DATA (41 HEX)
 LCSTC    EQU    141B        LOGICAL COMMAND STORE TRANSFER COUNT (61 HEX)

 ERC101   EQU    1           PP REQUEST QUEUE LOCKWORD TIMEOUT
 ERC102   EQU    ERC101+1    UNIT REQUEST QUEUE LOCKWORD TIMEOUT
 ERC103   EQU    ERC102+1    UNIT LOCKWORD TIMEOUT
 ERC104   EQU    ERC103+1    CHANNEL LOCKWORD TIMEOUT
 ERC105   EQU    ERC104+1    BUFFER POOL LOCKWORD TIMEOUT
 ERC106   EQU    ERC105+1    UNIT HARDWARE RESERVE TIMEOUT
 ERC107   EQU    ERC106+1    CONTROLLER HARDWARE RESERVE TIMEOUT
 ERC201   EQU    1           RESERVED FIELD OF PP INT TBL HEAD NOT 0
 ERC202   EQU    ERC201+1    RMA OF UNIT ACTIVITY MASK NOT A WORD BOUNDARY
 ERC203   EQU    ERC202+1    RMA OF PP COMM BUF NOT A WORD BOUNDARY
 ERC204   EQU    ERC203+1    RESERVED FIELD OF PP COMM DESCRIPTOR NOT 0
 ERC205   EQU    ERC204+1    RESERVED FIELD OF QUEUE DESCRIPTOR NOT 0
 ERC206   EQU    ERC205+1    RMA OF NEXT PP NOT A WORD BOUNDARY
 ERC207   EQU    ERC206+1    RESERVED FIELD OF RESP BUF DESCRIPTOR NOT 0
 ERC208   EQU    ERC207+1    LOGICAL UNIT OUT OF RANGE
 ERC209   EQU    ERC208+1    RMA OF UIT NOT A WORD BOUNDARY
 ERC20A   EQU    ERC209+1    INVALID CHANNEL NUMBER IN UNIT DESCRIPTOR
 ERC301   EQU    1           LOGICAL UNIT NUMBER MISMATCH
 ERC302   EQU    ERC301+1    RMA OF UNIT COMM BUF NOT A WORD BOUNDARY
 ERC303   EQU    ERC302+1    RESERVED FIELD OF UNIT COMM BUF DESCRIPTOR NOT 0
 ERC304   EQU    ERC303+1    RMA OF NEXT UNIT REQUEST NOT WORD BOUNDARY
 ERC305   EQU    ERC304+1    RESERVED FIELD OF QUEUE DESCRIPTOR NOT 0
 ERC306   EQU    ERC305+1    RESERVED FIELD IN HEADER NOT ZERO
 ERC307   EQU    ERC306+1    ILLEGAL DEVICE TYPE
 ERC401   EQU    1           RMA OF NEXT REQUEST NOT A WORD BOUNDARY
 ERC402   EQU    ERC401+1    REQUEST LENGTH NOT A MULTIPLE OF 8 BYTES
 ERC403   EQU    ERC402+1    REQUEST LENGTH IS LESS THAN FOURTY BYTES
 ERC404   EQU    ERC403+1    LOGICAL UNIT NO .NE. UNIT NO IN INTERFACE TBL
 ERC405   EQU    ERC404+1    RESERVED LINKAGE FIELD IS NOT ZERO
 ERC406   EQU    ERC405+1    INVALID RECOVERY/INTERFACE SELECTIONS
 ERC407   EQU    ERC406+1    INVALID PRIORITY SELECTION
 ERC408   EQU    ERC407+1    INVALID SECONDARY ADDRESS
 ERC409   EQU    ERC408+1    INVALID ALERT CONDITION
 ERC40A   EQU    ERC409+1    REQUEST LENGTH TOO LARGE > 224 BYTES
 ERC501   EQU    1           INVALID COMMAND CODE
 ERC502   EQU    ERC501+1    INVALID FLAG SELECTION
 ERC503   EQU    ERC502+1    INVALID FUNCTION
 ERC504   EQU    ERC503+1    FUNCTION NOT SUPPORTED BY HARDWARE
 ERC505   EQU    ERC504+1    INVALID LENGTH SPECIFICATION IN COMMAND
 ERC506   EQU    ERC505+1    INVALID ADDRESS SPECIFICATION IN COMMAND
 ERC507   EQU    ERC506+1    INVALID LENGTH SPECIFICATION IN INDIRECT LIST
 ERC508   EQU    ERC507+1    INVALID ADDRESS SPECIFICATION IN INDIRECT LIST
 ERC509   EQU    ERC508+1    PP COMMAND NOT ALLOWED IN REQUEST TO A UNIT
 ERC50A   EQU    ERC509+1    INVALID SEQUENCE OF COMMANDS
 ERC50B   EQU    ERC50A+1    INVALID PARAMETER SPECIFICATION
 ERC50C   EQU    ERC50B+1    RESERVED FIELD IN INDIRECT LIST NOT 0
          SPACE  4,20
**        SUBR - DEFINE SUBROUTINE ENTRY/EXIT.
*
*NAME     SUBR
*         DECLARE *NAME* TO BE THE ENTRY POINT TO A PP SUBROUTINE
*         WHICH IS ENTERED VIA *RJM* TO *NAME*.
*
*         THE FOLLOWING CODE IS GENERATED.
*NAMEX    LJM    *
*NAME     EQU    *-1

          PURGMAC  SUBR

          MACRO  SUBR,A
A_X LJM *
A EQU *-1
  ENDM
          EJECT
* DIRECT CELLS

 T0       CON    INIT-1      START OF INITIALIZATION ROUTINE

 T1       BSSZ   1           SCRATCH CELLS
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 T7       BSSZ   1
 P1       BSSZ   1
 P2       BSSZ   1
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1
 WC       BSSZ   1           CM WORD COUNT
 CMADR    BSSZ   3           CENTRAL MEMORY ADDRESS
 IDLFLG   BSSZ   1           PP IDLE FLAG, IF NONZERO ONLY PP REQUESTS ARE DONE.
 BIDINDX  BSSZ   1           INDEX INTO AREA CONTAINING INDIVIDUAL BID RESPONSES
 CHLOCK   BSSZ   1           CHANNEL LOCK FLAG
 CMDADR   BSSZ   1           ADDRESS OF ACTIVE COMMAND
 CMDNO    BSSZ   1           NO OF REMAINING COMMANDS
 LSTLEN   BSSZ   1           LENGTH OF INDIRECT LIST
          BSSZ   1           SPARE
          BSSZ   1           SPARE
 TRNCNT   BSSZ   4           TOTAL TRANSFER COUNT IN BYTES
 BYTCNT   BSSZ   1           NUMBER OF BYTES TO TRANSFER THIS I/O
 IOCNT    BSSZ   1           NUMBER OF PP WORDS TO TRANSFER THIS I/O
 UDPNT    BSSZ   1           UNIT DESCRIPTOR POINTER
 UNITP    BSSZ   1           UNIT POINTER
 MOTION   BSSZ   1           TAPE MOTION FLAG
 LIM      BSSZ   1           LIMIT OF RESPONSE BUFFER
 CONFLG   BSSZ   1           UNIT CONNECTED FLAG
 LONG     BSSZ   1           LONG INPUT BLOCK FLAG
 CM.CHAN  BSSZ   3           CM ADDRESS OF CHANNEL TABLE
 CM.COM   BSSZ   3           CM ADDRESS OF PP COMMUNICATION BUFFER - IF DUAL PP,
*                            THIS IS ALWAYS THE MASTERS PP COMMUNICATION BUFFER
 CM.RS    BSSZ   3           CM ADDRESS OF RESPONSE BUFFER
 CM.PIT   BSSZ   3           CM ADDRESS OF PP INTERFACE TABLE
 CM.UIT   BSSZ   3           CM ADDRESS OF UNIT INTERFACE TABLE
 CM.INT   BSSZ   3           CM ADDRESS OF INTERRUPT TABLE
 SETUPF   BSSZ   1           FLAG TO INDICATE DATA ALREADY IN PP (ON WRITE)
 ON       CON    1           CONSTANT ONE (DO NOT CHANGE THIS CELL)
 TW       CON    2           CONSTANT TWO (DO NOT CHANGE THIS CELL)
 DSRTP    CON    0           REAL MEMORY WORD-ADDRESS OF PIT
          CON    1
          BSSZ   1           SPARE
 RDFLG    BSSZ   1           SET NONZERO IF READ COMMAND
 PPNO     CON    5           LOGICAL PP NUMBER
 ID       CON    177777B     IDENTIFICATION

          ERRNZ  DSRTP-72B   MUST BE AT LOCATION 72

 LASTFC   EQU    DSRTP       LAST FUNCTION CODE
 LASTFC1  EQU    DSRTP+1     LAST NON-STATUS FUNCTION
          EJECT
          ORG    100B
*
* PP MONITOR
*
          SPACE  4
 TAPE     BSS    0
 MAIN     RJM    PPREQ       CHECK FOR ANY PP REQUESTS
          ZJN    MAIN010     IF NO PP REQUESTS, CHECK IF ANY UNIT REQ
 MAIN05   LJM    DORQ        PROCESS THE PP/UNIT REQUEST
*         *DORQ* RETURNS DIRECTLY TO *MAIN*.

 MAIN010  LDD    IDLFLG      GET IDLE FLAG
          NJN    MAIN020     IF IDLE FLAG SET, RELOOP
          RJM    UNITRQ      CHECK FOR, SKIP UNIT REQUEST CHECK
          NJN    MAIN05      IF THERE IS A UNIT REQUEST
 MAIN020  RJM    CKCHREQ     CHECK IF CHANNEL REQUESTED
          UJN    MAIN        LOOP FOR REQUESTS
          EJECT
** NAME - PPREQ
*
** PURPOSE - TO DETERMINE IF THERE ARE ANY PP REQUESTS TO PROCESS.  IF THERE
*            ARE, THE FIRST ONE IS COPIED INTO PP MEMORY.
*
** OUTPUT - A=0 IF NO PP REQUESTS.
*           A .NE. 0 IF THERE IS A PP REQUEST TO PROCESS.
*           IF THERE IS A REQUEST, (CMDNO) = NUMBER OF COMMANDS.
          SPACE   4
 NOPPQ    LDN    PPLK+40B    UNLOCK PP REQUEST QUEUE
          RJM    SCLK
 NOPPQ1   LDN    0           SET EXIT FOR NO REQUESTS FOUND

 PPREQ    SUBR               ENTRY/EXIT
          LOADC  CM.PIT      LOAD A AND R FOR PIT
          ADN    /PIT/C.PPQ
          CRDL   T1          READ REQUEST RMA FROM PIT
          LDDL   T3          HALF 1 OF REQUEST RMA
          ADDL   T4          HALF 2 OF REQUEST RMA
          ZJN    PPREQX      IF NO REQUEST QUEUED
          LDN    PPLK        LOCK PP REQUEST QUEUE
          RJM    SCLK
          NJK    NOPPQ1      RETURN IF PP REQUEST QUEUE ALREADY LOCKED
          LOADC  CM.PIT      CM ADDRESS TO A AND R FOR READ
          ADN    /PIT/C.PPQPVA
          CRML   PPTBL+/PIT/P.PPQPVA-1,TW  READ IN REQUEST PVA/RMA FROM PIT
          LDML   PPTBL+/PIT/P.PPQ  GET HALF 1 OF RMA OF 1ST REQUEST
          ADML   PPTBL+/PIT/P.PPQ+1
          ZJK    NOPPQ       IF RMA = 0 NO PP REQUEST QUEUED
          LDK    /RQ/C.CMND  LENGTH OF REQUEST HEADER
          STDL   WC
          LOADF  PPTBL+/PIT/P.PPQ  CM ADDRESS OF REQUEST TO A AND R
          CRML   REQBUF,WC   READ PP REQUEST HEADER
          LDML   REQBUF+/RQ/P.LEN  REQUEST LENGTH IN BYTES
          SHN    -3          REQUEST LENGTH IN CM WORDS
          SBN    /RQ/C.CMND  SUBTRACT HEADER LENGTH
          STDL   CMDNO       NUMBER OF COMMANDS THIS REQUEST
          LDDL   CMADR+2     READ COMMANDS FROM CM
          ADN    /RQ/C.CMND
          LMC    400000B
          CRML   CMDBUF,CMDNO
          LOADC  CM.PIT      SET A AND R TO PP INTERFACE TABLE
          ADN    /PIT/C.PPQPVA  SET A AND R TO PVA IN PP INTERFACE TABLE
          CWML   REQBUF+/RQ/P.NEXTPV-1,TW  RESET PVA AND RMA TO NEXT PVA AND RMA
          LDN    PPLK+40B    UNLOCK PP REQUEST QUEUE
          RJM    SCLK
          LDC    PPTBL+/PIT/P.PPQPVA-1  SET PIT PVA/RMA PP BUFFER ADDRESS
          STML   RESPSUA
          RJM    RESPSU      SET UP RESPONSE BUFFER
          LDN    1           SET GOT REQUEST FLAG
          UJK    PPREQX      EXIT
          EJECT
** NAME - UNITRQ
*
** PURPOSE - TO DETERMINE IF THERE ANY REQUESTS ON THE UNIT QUEUES.
*
** OUTPUT - A = 0 IF THERE ARE NO UNIT REQUESTS.
*           A .NE. 0 IF THERE IS A UNIT REQUEST TO PROCESS.
*           IF THERE IS A REQUEST, (CMDNO) = NUMBER OF COMMANDS.
          SPACE  4
 UQEMPT   LDN    0           SET NO UNIT REQUESTS

 UNITRQ   SUBR               ENTRY/EXIT
          LDML   PPTBL+/PIT/P.UNITC  GET NUMBER OF UNITS
          STDL   P1          SAVE FOR LOOP CONTROL

 UQLOOP   SODL   P1          DECREMENT LOOP CONTROL COUNTER
          MJN    UQEMPT      EXIT IF ALL UNITS CHECKED AND NO FINDS
          AODL   UNITP       INCREMENT UNIT POINTER
          SBML   PPTBL+/PIT/P.UNITC  SUBTRACT MAX UNIT NUMBER
          MJN    UQ2         SKIP IF NO RAP AROUND
          LDN    0           RESET POINTER TO START OF UNIT LIST
          STDL   UNITP
 UQ2      LDDL   UNITP       GET UNIT POINTER
          SHN    3           MULT BY 8 SINCE UNIT DESCRIPTOR 8 PP WORDS LONG
          STDL   UDPNT       SAVE POINTER INTO UNIT DESCRIPTOR

*         PRESET HAS TAKEN NULL UNIT DESCRIPTORS OUT OF THE PP COPY OF THE
*         UNIT DESCRIPTORS FOR THIS PIT.
*
*         LDML   UNITD+/UD/P.UQT,UDPNT  GET RMA UPPER HALF
*         ADML   UNITD+/UD/P.UQT+1,UDPNT  ADD RMA LOWER HALF
*         ZJK    UQLOOP      IF DUMMY ENTRY, LOOP TO NEXT ENTRY

          LOADF  UNITD+/UD/P.UQT,UDPNT  REFORMAT AND LOAD CM ADDRESS OF UIT
          STDL   CM.UIT+2    SAVE CM ADDRESS OF UIT
          SRD    CM.UIT
          ERRNZ  /UIT/C.DSABLE
          CRDL   T1          READ UNIT STATUS WORD FROM UIT
          ADN    /UIT/C.NEXT
          CRDL   T3          READ NEXT REQUEST RMA
          LDDL   T2          STATUS FIELD
          ERRNZ  /UIT/P.DSABLE-1
          SHN    18-16+/UIT/L.DSABLE
          MJN    UQLOOP      IF UNIT DISABLED
          LDDL   T5          HALF 1 OF REQUEST RMA
          ADDL   T6          HALF 2 OF REQUEST RMA
          ZJK    UQLOOP      IF NO REQUEST QUEUED
          LDDL   CONFLG      CHECK IF ANY UNIT CURRENTLY CONNECTED
          ZJN    UQ2.1       IF NO UNIT CONNECTED
          LPN    77B
          LMDL   UNITP
          ZJN    UQ2.2       IF CONNECTED UNIT IS SAME AS CURRENT REQUEST
 UQ2.1    LDN    UILK        LOCK UNIT INTERFACE TABLE
          RJM    SCLK
          NJK    UQLOOP      GO TO NEXT UNIT IF THIS ONE IS LOCKED
          LDDL   CONFLG
          ZJN    UQ2.2       IF NO UNIT CURRENTLY CONNECTED
          RJM    REL         RELEASE PREVIOUSLY CONNECTED UNIT
 UQ2.2    LDN    QULK        LOCK UNIT REQUEST QUEUE
          RJM    SCLK
          NJN    TRYNX1      GO TO NEXT UNIT IF THIS ONE LOCKED
          LDN    C.UIT       SET LENGTH OF UIT
          STDL   WC
          LOADC  CM.UIT      SET A AND R TO ADDR OF UIT
          CRML   UITBUF,WC   READ IN UNIT INTERFACE TABLE
          LDML   UITBUF+/UIT/P.DSABLE  GET UNIT STATUS
          SHN    18-16+/UIT/L.DSABLE
          MJN    TRYNXT      IF UNIT DISABLED
          LDML   UITBUF+/UIT/P.NEXT  HALF 1 OF RMA FOR REQUEST
          ADML   UITBUF+/UIT/P.NEXT+1  IF RMA=0 NO REQUEST QUEUED
          NJN    UQ3         IF REQUEST IS QUEUED
 TRYNXT   LDN    QULK+40B    UNLOCK UNIT REQUEST QUEUE
          RJM    SCLK
 TRYNX1   LDDL   CONFLG
          NJN    UQ2.3       IF UNIT ALREADY CONNECTED
          LDN    UILK+40B    UNLOCK UNIT INTERFACE TABLE
          RJM    SCLK
 UQ2.3    LJM    UQLOOP      LOOP TO NEXT UNIT

 UQ3      LDK    /RQ/C.CMND  LENGTH OF REQUEST HEADER
          STDL   WC          SAVE LENGTH FOR CM READ
          LOADF  UITBUF+/UIT/P.NEXT  SET A AND R TO ADDR OF REQUEST
          CRML   REQBUF,WC   READ REQUEST HEADER
          LOADC  CM.UIT      SET A AND R TO ADDRESS OF UIT
          ADN    /UIT/C.NEXTPV  POINT TO PVA
          CWML   REQBUF+/RQ/P.NEXTPV-1,TW  RESET PVA AND RMA OF NEXT REQUEST
          LDN    QULK+40B    UNLOCK UNIT REQUEST QUEUE
          RJM    SCLK
          LDML   REQBUF+/RQ/P.LEN  REQUEST LENGTH IN BYTES
          SHN    -3          REQUEST LENGTH IN CM WORDS
          SBN    /RQ/C.CMND  SUBTRACT HEADER LENGTH
          STDL   CMDNO       NUMBER OF COMMANDS THIS REQUEST
          LOADF  UITBUF+/UIT/P.NEXT
          ADN    /RQ/C.CMND
          CRML   CMDBUF,CMDNO
          LDC    UITBUF+/UIT/P.NEXTPV-1  SET UIT PVA/RMA PP BUFFER ADDRESS
          STML   RESPSUA
          RJM    RESPSU      SET UP RESPONSE BUFFER
          LDN    0
          STDL   BIDINDX     CLEAR INDEX INTO BID RESPONSE AREA
          LDML   UNITD+/UD/P.CNTRLR,UDPNT  SET EQUIPMENT NUMBER
          LPN    7
          SHN    9
          STML   FUNA
          LDN    1           SET GOT REQUEST FLAG
          UJK    UNITRQX     RETURN
          EJECT
** NAME - DORQ
*
** PURPOSE - PERFORM THE REQUIRED REQUEST.
*
** INPUT - REQUEST IN REQBUF.
*          (CMDNO) = NUMBER OF COMMANDS IN REQUEST.
*
** OUTPUT - REQUEST PROCESSED AND RESPONSE PLACED IN RESPONSE BUFFER.
*
          SPACE  4
 DORQ     BSS    0           ENTRY
          LDC    CMDBUF      ADDRESS OF FIRST COMMAND IN REQUEST
          STDL   CMDADR      INITIALIZE COMMAND ADDRESS
          LDN    0
          STDL   TRNCNT+3    INITIALIZE TRANSFER COUNT
          STDL   TRNCNT+2
          STDL   RDFLG       INITIALIZE READ FLAG
          STDL   MOTION      INITIALIZE MOTION FLAG
          STDL   LONG        INITIALIZE LONG INPUT BLOCK FLAG
*         LDC    PSNI        SET TO INPUT 16 STATUS WORDS
          STML   RDSTATA
 DORQ5    LDIL   CMDADR      GET COMMAND AND FLAGS
          SHN    -8          SHIFT OFF FLAGS
          STDL   T2          SAVE COMMAND
          LDN    0           INITIALIZE TABLE INDEX
          STDL   T1
 DORQ10   LDML   DORQA,T1    COMPARE TABLE ENTRY WITH CURRENT COMMAND
          LMDL   T2
          ZJN    DORQ20      IF FOUND REQUESTED COMMAND
          LDN    2           INCREMENT INDEX
          RADL   T1
          LMN    DORQAL
          NJN    DORQ10      IF NOT END OF TABLE
          UJN    *           IF END OF TABLE, NON-SUPPORTED COMMAND

 DORQ20   LDML   DORQA+1,T1  GET PROCESSOR ADDRESS
          STML   DORQB

**        EXIT TO COMMAND PROCESSOR ROUTINE WITH THE FOLLOWING -
*
*         (T2) = COMMAND.
*         ((CMDADR)) = COMMAND AND FLAGS. (BEGINNING OF CURRENT COMMAND)
*         (CMDNO) = NUMBER OF COMMANDS, INCLUDING CURRENT ONE, LEFT
*                   IN THE CURRENT REQUEST.

          LJM    **          PROCESS COMMAND
 DORQB    EQU    *-1

**        AFTER COMMAND IS PROCESSED, THE COMMAND PROCESSOR ROUTINE WILL
*         RETURN TO *CMDONE* IF STATUS IS REQUIRED OR TO *NOSTAT* IF
*         STATUS IS NOT REQUIRED.  IF THE COMMAND IS AN OUTPUT DATA OR LOGICAL
*         READ, THE PROCESSOR WILL RETURN TO *CMDONE1*.

 CMDONE   RJM    GTSTAT      GET STATUS
          RJM    ERRCHK      CHECK FOR ERRORS

 CMDONE1  LDML   RESBUF+/RS/P.GSTAT+2  FETCH DETAILED STATUS
          NJN    CMD5        IF HARDWARE OR MEDIA ERROR
          LDDL   LASTFC1     GET LAST NON-STATUS FUNCTION
          SBN    13B
          ZJN    CMD7        IF FORSPACE
          SBN    40B-13B
          ZJN    CMD7        IF READ (SHOULD ONLY BE FORWARD READ TYPE)
          LPN    77B         MASK FOR ANY TYPE WRITE
          SBN    50B-40B
          ZJN    CMD9        IF WRITE TYPE
          SBN    51B-50B
          NJN    CMD11       IF NOT WRITE TAPE MARK FUNCTION
 CMD1     LDN    1           SET FILE MARK STATUS IN BID RESPONSE
 CMD3     STML   RESBID,BIDINDX  UPDATE BID RESPONSE AREA
          AOD    BIDINDX     INCREMENT INDEX INTO BID RESPONSE AREA
          STML   RESCNT      SET PRESENT BID RESPONSE AREA COUNT
 CMD5     UJN    CMD11

 CMD7     LDM    RESBUF+/RS/P.GSTAT  FETCH GENERAL STATUS
          LPN    20B         MASK FILE MARK STATUS
          NJN    CMD1        IF FILE MARK STATUS
 CMD9     LDM    RESBUF+/RS/P.GSTAT+3
          LPC    3000B       MASK OFF DOUBLE/SINGLE TRACK CORRECTION STATUS
          ZJN    CMD10       IF NO ON THE FLY HARDWARE CORRECTION
          AOM    CORCNT      INCREMENT HARDWARE CORRECTION COUNT
 CMD10    LDM    RESBUF+/RS/P.GSTAT+1  FETCH BID FOR THIS OPERATION
          UJN    CMD3        UPDATE BID RESPONSE AREA

 CMD11    LDDL   P2          FETCH FATAL ERROR FLAG FROM ERRCHK
          NJK    FAIL        IF STATUS BAD, GO TO FAIL
 NOSTAT   LDIL   CMDADR      GET COMMAND AND FLAGS
          LPC    STRSP       MASK OFF STORE TRANSFER COUNT FLAG
          ZJN    NOSTR       JUMP IF STORE RESPONSE NOT REQUIRED
          LDC    R.FLG
          RAML   RESBUF+/RS/P.RC  SET FLAG RESPONSE BIT
 NOSTR    BSS
          SODL   CMDNO       DECREMENT COMMAND COUNTER BY 1
          ZJN    DORQ1       GO TO COMPLETE REQUEST
          LDML   RESBUF+/RS/P.RC  CHECK IF INTERMEDIATE RESPONSE REQUIRED
          ZJN    NOST1       IF NO INTERMEDIATE RESPONSE
          LDC    R.INT       SET INTERMEDIATE RESPONSE FLAG
          RAML   RESBUF+/RS/P.RC
          RJM    RESP        STORE A RESPONSE
          RJM    RESPSU      SET UP RESPONSE BUFFER
 NOST1    BSS
          LDN    4           POINT TO THE NEXT COMMAND 4PP WORDS = COMMAND
          RADL   CMDADR
          UJK    DORQ5       RELOOP TO PERFORM NEXT COMMAND

 DORQ1    LDC    R.NRM
          RAML   RESBUF+/RS/P.RC  SET NORMAL REQUEST TERMINATION INDICATOR
 DORQ2    RJM    IODONE      TERMINATE REQUEST
          UJK    MAIN        RETURN TO MAIN LOOP

 FAIL     LDML   RESBUF+/RS/P.LONGB  CHECK ALERT MASK IF UNIT IS TO BE DISABLED
          SHN    18-16+/RS/L.DUNIT  DISABLE UNIT BIT TO SIGN POSITION
          PJN    FAIL1       IF NOT DISABLE UNIT BIT IN ALERT MASK
          LDC    /RS/K.DUNIT   SET UNIT DISABLED BIT IN RESPONSE
          RAML   RESBUF+/RS/P.LNGBLK  SET RESPONSE ALERT CONDITIONS
          LDC    /UIT/K.DSABLE  SET UNIT DISABLED IN UIT STATUS
          RAML   UITBUF+/UIT/P.DSABLE
          LOADC  CM.UIT
          CWML   UITBUF,ON   UPDATE FIRST WORD OF UIT
 FAIL1    LDC    R.ABN
          STML   RESBUF+/RS/P.RC  SET ABNORMAL TERMINATION RESPONSE
          UJN    DORQ2       TERMINATE REQUEST


**        THE FOLLOWING TABLE CONTAINS ONE ENTRY FOR EACH SUPPORTED COMMAND
*         OF THE TAPE SUBSYSTEM.  THE SECOND WORD OF EACH ENTRY IS THE ADDRESS
*         OF THE COMMAND PROCESSOR ROUTINE.

 DORQA    BSS    0
          CON    FUNCCMD,FUNC     PHYSICAL COMMAND - FUNCTION
 DORQC    CON    PWRTCMD,OUT8D    PHYSICAL COMMAND - OUTPUT 8-BIT DATA
*         CON    PWRTCMD,DOUT8D   (DUAL PP MASTER)
 DORQD    CON    LCREAD,READ      LOGICAL READ COMMAND
*         CON    LCREAD,DREAD     (DUAL PP MASTER)
 DORQE    CON    LCSTC,STRTC      LOCIGAL STORE TRANSFER COUNT
*         CON    LCSTC,DSTRTC     (DUAL PP MASTER)
          CON    IDLCMD,DOPPRQ    IDLE PP COMMAND
          CON    RSUMCMD,DOPPRQ   RESUME COMMAND
 DORQAL   EQU    *-DORQA     LENGTH OF TABLE
          EJECT
** NAME - DOPPRQ
*
** PURPOSE - PERFORM A PP REQUEST.
*
** INPUT - (T2) = COMMAND.
*
** OUTPUT - COMMAND PROCESSED.
*
** NOTE - THE ONLY PP REQUESTS CURRENTLY SUPPORTED ARE IDLE AND RESUME.
*
          SPACE  4
 DOPPRQ   BSS
          LDDL   T2          GET COMMAND
          SBN    RSUMCMD
          ZJN    DOPP10      IF RESUME COMMAND CLEAR IDLE FLAG
          RJM    CCLOCK      RELEASE CONNECTED UNIT AND CLEAR CHANNEL LOCK
          LDN    1           SET PP IDLE
 DOPP10   STDL   IDLFLG
          UJK    NOSTAT      GO TO DO NEXT COMMAND
          EJECT
** NAME - FUNC
*
** PURPOSE - TO PERFORM THE PHYSICAL COMMAND FUNCTION.
*
** INPUT -  (CMDADR) = ADDRESS OF COMMAND.
*
** OUTPUT - FUNCTION ISSUED IF NOT WRITE OR FORMAT.
*
          SPACE  4
 FUNC     BSS
          LDML   3,CMDADR    GET HARDWARE FUNCTION TO BE ISSUED
          SBN    F.FU67
          ZJK    FORMATU     IF FORMAT UNIT COMMAND GO TO FORMAT UNIT ROUTINE
          SBN    WRCMD-F.FU67
          ZJN    FUNC10      IF WRITE FUNCTION
          ADC    WRCMD-SWRCMD
          ZJN    FUNC10      IF SHORT WRITE FUNCTION
          LDML   3,CMDADR    GET HARDWARE FUNCTION TO BE ISSUED
          LMN    10B
          NJN    FUNC5       IF NOT REWIND FUNCTION
          LDML   RESBUF+/RS/P.GSTAT  GEN STATUS FROM FORMAT FUNCTION
          LPN    BOT
          ZJN    FUNC5       IF NOT AT LOAD POINT
          LJM    CMDONE1     RETURN FORMAT CONNECT STATUS

 FUNC5    LDN    0           SET TO INPUT 16 STATUS WORDS
          STML   RDSTATA
          LDML   3,CMDADR    GET HARDWARE FUNCTION TO BE ISSUED
          RJM    DOFUNC      DO FUNCTION
          UJK    CMDONE      GO TO DO NEXT COMMAND

 FUNC10   LDDL   MOTION
          ZJN    FUNC20      IF MOTION NOT STARTED
          LJM    NOSTAT      PROCESS NEXT COMMAND

 FUNC20   LJM    WRITE       PROCESS WRITE FUNCTION
*         LJM    DWRITE      (DUAL PP MASTER)
 FUNCA    EQU    *-1
          SPACE  4
 CONCHM   BSS    0           CHECK FOR CHANNEL INSTRUCTIONS SO FAR
 TTP+40B  HERE
 T40B+TP  HERE
 TTP      HERE
 CONCHML  EQU    *

          ERRNZ  CONCHML-CONCHM  ERROR IF ANY CHANNEL INSTRUCTIONS SO FAR
          EJECT
**        THE FOLLOWING AREA (LOCATIONS *DUALOV* THRU *EDUALOV*) IS
*         OVERLAID WITH DUAL PP VERSIONS OF THE ROUTINES IF THIS PP
*         IS THE MASTER IN A DUAL PP CONFIGURATION.


 DUALOV   EQU    *           DUAL PP OVERLAID AREA
          SPACE  4
** NAME - READ
*
** PURPOSE - PROCESS LOGICAL READ COMMAND.
*
** INPUT - (CMDADR) = ADDRESS OF COMMAND.
*
          SPACE   4
 READ     BSS
          AODL   RDFLG       SET READ COMMAND FLAG
          LDD    MOTION      CHECK TAPE MOTION FLAG
          NJN    READ5       IF TAPE ALREADY MOVING
          LDN    F.READ      ISSUE READ FUNCTION
          RJM    DOFUNC
          ACN    TP          ACTIVATE CHANNEL
 READ5    LDDL   CMDADR      SET CURRENT COMMAND ADDRESS
          STDL   T4
          RJM    SETUP       SET UP FOR READ
          LDN    0           CLEAR MOTION AHEAD FLAG
          STDL   MOTION
          STDL   LONG        CLEAR LONG INPUT FLAG
          LDDL   IOCNT       NUMBER OF 12-BIT CHANNEL WORDS
          IAPM   IOBUF,TP    INPUT DATA
          STDL   P1          SAVE RESIDUAL WORD COUNT IF ANY
          NJN    READ9       IF SHORT BLOCK
 READ7    LDN    32          CONTINUE INPUT TO CHECK FOR LONG INPUT BLOCK
          IAPM   RESBUF+/RS/P.GSTAT,TP  USE STATUS AREA AS TEMP BUFFER
          SBN    32
          ZJN    READ9       IF END OF DATA
          LMC    -0          COUNT CHANNEL WORDS INPUT
          RADL   LONG        NON-ZERO INDICATES LONG INPUT BLOCK
          UJN    READ7       CONTINUE INPUT

 READ9    DCN    40B+TP      DISCONNECT THE CHANNEL
          SFM    CPETERM,TP  CHECK AND CLEAR CHANNEL PARITY FLAG
          LDDL   LONG        ADD LONG INPUT BLOCK COUNT TO CHANNEL COUNT
          RADL   IOCNT
          SBDL   P1          SUBTRACT RESIDUAL WORD COUNT IF ANY
          STDL   IOCNT       ACTUAL CHANNEL WORDS INPUT
          SHN    1           MULTIPLY BY 3/2 AND ROUND DOWN
          ADDL   IOCNT
          SHN    -1
          ZJN    READ20      IF NO DATA READ
          RADL   TRNCNT+3    UPDATE TOTAL TRANSFER COUNT THIS REQUEST
          LDDL   CMDADR      SET ADDR OR LENGTH/ADDR PAIR FOR CURRENT OPERATION
          STDL   T4
          RJM    INLPR       WRITE DATA TO CM USING INDIRECT LIST
 READ20   RJM    GTSTAT      WAIT FOR END OF OPERATION
          RJM    CKFL        CHECK FOR CHARACTER FILL

*         CHECK IF LAST VALID 12-BIT CHANNEL WORD HAD AN EXTRA BYTE.
*         EXAMPLE  IF REQUESTED BYTE COUNT = 5 AND THE TAPE RECORD
*                  HAD 6 BYTES, THE LAST 12-BIT CHANNEL WORD
*                  WOULD CONTAIN THE SIXTH BYTE (CHARACTER FILL=0)
*                  AND NOT BE DETECTED AS A LONG BLOCK CONDITION.
*         THIS CONDITION CAN ONLY OCCUR IF REQUESTED BYTE COUNT IS ODD.

          LDDL   BYTCNT      GET REQUESTED BYTE COUNT
          SBDL   TRNCNT+3    COMPARE WITH ACTUAL BYTE COUNT
          PJN    READ30      IF NOT LONG BLOCK CONDITION
          LDN    2
          STDL   LONG        SET LONG BLOCK FLAG
 READ30   BSS
          RJM    ERRCHK      CHECK FOR ERRORS OR TERMINATION CONDITION
          LDDL   P2          CHECK IF ERROR OR TERMINATION CONDITION OCCURRED
          NJN    READ40      IF ERRORS OR TERMINATION CONDITION
          LDDL   CMDNO       COMMANDS REMAINING
          SBN    2
          ZJN    READ60      IF NO MORE POSSIBLE READ COMMANDS
          LDN    F.READ      START TAPE FOR NEXT BLOCK
          RJM    DOFUNC
          ACN    TP          ACTIVATE CHANNEL
          AODL   MOTION      SET TAPE MOTION FLAG
          UJN    READ50      PROCESS NEXT COMMAND

 READ40   LOADF  6,CMDADR    SET TRANSFER COUNT FOR ERROR BLOCK
          CWDL   TRNCNT
 READ50   LJM    CMDONE1     RETURN TO PROCESS NEXT COMMAND

*         THE PURPOSE OF THE FOLLOWING CODE IS TO REDUCE THE TIME BETWEEN
*         MULTIPLE REQUESTS.  BY RETURNING THE TRANSFER COUNT FOR THE LAST
*         READ HERE, THE NORMAL REQUEST PROCESSOR PATH IS AVOIDED FOR THE
*         LAST COMMAND (WHICH IS ALWAYS A STORE TRANSFER COUNT FOR READS).

 READ60   SODL   CMDNO       DECREMENT REMAINING COMMANDS (CAUSE EXIT FROM *DORQ*)
          LDN    4           ADVANCE TO LAST COMMAND (STORE TRANSFER COUNT)
          RADL   CMDADR
          LOADF  2,CMDADR    RETURN TRANSFER COUNT FOR LAST READ
          CWDL   TRNCNT
          LDN    0           CLEAR TRANSFER COUNT
          STDL   TRNCNT+3
          LJM    CMDONE1     RETURN
          EJECT
** NAME - WRITE
*
** PURPOSE - TO GET WRITE DATA FROM CENTRAL MEMORY AND ISSUE WRITE FUNCTION.
*
** INPUT - (CMDADR) = ADDRESS OF COMMAND.
*
          SPACE   4
 WRITE    BSS    0           ENTRY
          LDDL   SETUPF      CHECK IF DATA ALREADY IN PP
          NJN    WRITE10     IF DATA ALREADY READ INTO PP
          LDDL   CMDADR      SET LENGTH/ADDRESS PAIR TO CURRENT COMMAND + 1
          ADN    4
          STDL   T4
          RJM    SETUP       SET UP FOR WRITE OPERATION
          RJM    INLPR       READ DATA FROM CM USING INDIRECT LIST
 WRITE10  LDML   3,CMDADR    GET HARDWARE FUNCTION
          RJM    DOFUNC      ISSUE WRITE FUNCTION
          ACN    TP          ACTIVATE CHANNEL
          LJM    NOSTAT      PROCESS NEXT COMMAND
          EJECT
** NAME - SETUP
*
** PURPOSE - SET UP FOR READ OR WRITE OPERATION.
*
** INPUT - (T4) = COMMAND ADDRESS FOR OPERATION TO SET UP.
*
** OUTPUT - (BYTCNT) = BYTE COUNT OF BLOCK.
*           (IOCNT) = CHANNEL WORD COUNT OF BLOCK.
*           (T4) = UNCHANGED FROM ENTRY.
*           (LSTLEN) = LENGTH OF INDIRECT LIST.
*           (INLPRA-1) SET TO CORRECT INSTRUCTION TO READ/WRITE CM.
*           INDIRECT LIST READ INTO PP BUFFER.
*
** NOTE - IN THE CASE OF A COMMAND WITHOUT THE INDIRECT BIT SET,
*         THE LENGTH/ADDRESS PAIR IS MOVED TO THE INDIRECT BUFFER
*         AND (LSTLEN) = 1.  THIS IS DONE SO THE CODE THAT READS
*         AND WRITES CENTRAL MEMORY CAN BE COMMON WHETHER THE
*         INDIRECT BIT IS SET OR NOT.
          SPACE  4
*  READ INDIRECT LIST INTO INDLST

 SETUP10  LOADF  2,T4        SET UP CM ADDRESS IN A AND R
          CRML   INDLST,T5   READ INDIRECT LIST
          LDN    0
          STDL   BYTCNT      INITIALIZE BYTE COUNT
          STDL   T6          INITIALIZE INDEX
 SETUP15  LDML   INDLST+1,T6  ADD LIST ENTRY BYTE COUNT TO TOTAL
          RADL   BYTCNT
          LDN    4           INCREMENT TO NEXT LIST LENGTH FIELD
          RADL   T6
          SODL   T5
          NJN    SETUP15     IF NOT END OF LIST
 SETUP20  RJM    CBYTE       CONVERT BYTE COUNT TO CHANNEL COUNT
          LDDL   RDFLG
          ZJN    SETUP30     IF NOT READ OPERATION (I.E. WRITE)
          LDC    CWMLI-CRMLI  SET TO WRITE DATA TO CM
 SETUP30  ADC    CRMLI+WC    SET TO READ DATA FROM CM
          STML   INLPRA-1

 SETUP    SUBR               ENTRY/EXIT
          LDM    1,T4        SET BYTE COUNT IF NOT INDIRECT
          STDL   BYTCNT
          SHN    -3          SET LIST LENGTH IF INDIRECT
          STDL   LSTLEN
          STDL   T5
          LDIL   T4          CHECK IF INDIRECT ADDRESSING
          LPC    INDFLG
          NJK    SETUP10     IF INDIRECT LIST
          LDN    1           SET LIST LENGTH TO ONE
          STDL   LSTLEN
          LDML   1,T4        MOVE COMMAND LENGTH/ADDRESS TO INDIRECT BUFFER
          STML   INDLST+1
          LDML   2,T4
          STML   INDLST+2
          LDML   3,T4
          STML   INDLST+3
          LJM    SETUP20     CONVERT BYTE COUNT TO CHANNEL COUNT
          EJECT
** NAME - OUT8D
*
** PURPOSE - TO PERFORM THE PHYSICAL COMMAND OUTPUT 8-BIT DATA.
*
** INPUT - (CMDADR) = ADDRESS OF COMMAND.
*
          SPACE  4
 OUT8D    BSS    0           ENTRY
          LDDL   IOCNT       NUMBER OF 12-BIT CHANNEL WORDS
          OAPM   IOBUF,TP    OUTPUT DATA
          FJM    *,TP        WAIT UNTIL DONE
          DCN    40B+TP      DISCONNECT THE CHANNEL
          SFM    OUTCPE,TP   CHECK AND CLEAR CHANNEL PARITY ON OUTPUT
          NJK    WLATE       JUMP IF LATE ACKNOWLEDGE
          LDDL   BYTCNT      GET TRANSFER COUNT

 WEXIT    RADL   TRNCNT+3    UPDATE TOTAL TRANSFER COUNT THIS REQUEST
          SHN    -16
          RADL   TRNCNT+2
          LDDL   CMDNO       CHECK REMAINING COMMAND COUNT
          SBN    1
          STDL   MOTION      INDICATE SETUP PERFORMED OR NOT
          ZJN    OUT8D20     IF NO MORE COMMANDS THIS REQUEST
          LDDL   CMDADR      SETUP FOR NEXT WRITE
          ADN    8
 OUT8D5   STDL   T4
          RJM    SETUP       SET UP FOR NEXT WRITE
          RJM    INLPR       READ NEXT BLOCK FROM CM
 OUT8D10  RJM    GTSTAT      WAIT FOR END OF OPERATION
          RJM    ERRCHK      CHECK FOR ERRORS OR TERMINATION CONDITION
          NJN    OUT8D15     IF ERRORS OR TERMINATION CONDITION
          LDDL   MOTION
          ZJN    OUT8D15     IF SETUP AND READ DATA NOT PERFORMED
          LDML   7,CMDADR    GET WRITE FUNCTION FOR NEXT BLOCK
          RJM    DOFUNC      ISSUE FUNCTION
          ACN    TP          ACTIVATE CHANNEL
 OUT8D15  LJM    CMDONE1     PROCESS WRITE COMPLETION

 WLATE    STDL   T2          SAVE RESIDUAL TRANSFER COUNT
          LDDL   IOCNT       GET ORIGIONAL WORD COUNT
          SBDL   T2          SUBTRACT RESIDUAL WORD COUNT TO GIVE WORDS
                             TRANSFERED
          STDL   IOCNT       RESET WORDS TRANSFERED THIS COMMAND
          SHN    1           GET BYTE COUNT THIS COMMAND
          ADDL   IOCNT       (MULTIPLY BY 3/2 AND ROUND DOWN)
          SHN    -1
          UJK    WEXIT       RETURN

*         CHECK IF PENDING REQUEST AND IF ONE EXISTS, READ THE DATA INTO THE
*         PP IN ORDER TO MAINTAIN STREAMING ON MULTIPLE REQUESTS.

 OUT8D20  LOADC  CM.UIT      CHECK IF PENDING REQUEST
          ADN    /UIT/C.NEXT
          CRDL   T1
          LDDL   T3
          ADDL   T4
          ZJN    OUT8D30     IF NO PENDING REQUEST
          LOADF  T3          LOAD CM ADDRESS OF REQUEST
          ADN    /RQ/C.LEN
          CRDL   T1          REQUEST LENGTH
          ADN    /RQ/C.CMND-/RQ/C.LEN+2
          CRML   OUT8DA,ON   THIRD COMMAND OF REQUEST
          LDDL   T1          CHECK REQUEST LENGTH
          SBN    /RQ/C.CMND*8+3*8
          PJN    OUT8D40     IF REQUEST HAS AT LEAST 3 COMMANDS
 OUT8D30  LDN    0           SET FLAG INDICATING NO DATA IN PP
          STDL   SETUPF
          LJM    OUT8D10     OBTAIN STATUS FROM PREVIOUS WRITE

 OUT8D40  LDML   OUT8DA      CHECK THIRD COMMAND
          SHN    -8
          LMN    PWRTCMD
          NJN    OUT8D30     IF THIRD COMMAND NOT OUTPUT DATA
          AODL   SETUPF      SET FLAG INDICATING DATA IN PP
          LDC    OUT8DA      SET ADDRESS OF COMMAND
          LJM    OUT8D5      READ DATA INTO PP

 OUT8DA   BSSZ   4           THIRD COMMAND OF NEXT REQUEST
          EJECT
** NAME - STRTC
*
** PURPOSE - TO PERFORM THE LOGICAL COMMAND STORE TRANSFER COUNT.
*
** INPUT - (CMDADR) = ADDRESS OF COMMAND.
*
          SPACE  4
 STRTC    BSS
          LOADF  2,CMDADR    CM ADDRESS TO A AND R
          CWDL   TRNCNT      SEND TRANSFER COUNT TO CM
          LDN    0
          STDL   TRNCNT+3    CLEAR TRANSFER COUNT
          UJK    NOSTAT      PROCESS NEXT COMMAND
          EJECT
** NAME - INLPR
*
** PURPOSE - INDIRECT LIST PROCESSING - READ DATA FROM/WRITE DATA TO CM
*            USING THE INDIRECT LIST OF LENGTH/ADDRESS PAIRS.
*
** INPUT - (T4) = ADDRESS OF LENGTH/ADDRESS PAIR FOR CURRENT OPERATION.
*          (INLPRA-1) = SET TO CORRECT INSTRUCTION TO READ/WRITE CM.
*          (LSTLEN) = LENGTH OF INDIRECT LIST IN CM WORDS.
*          INDIRECT LIST READ INTO BUFFER *INDLST*.
*
** OUTPUT - IF WRITE OPERATION, DATA READ INTO PP FROM CM.
*           IF READ OPERATION, DATA WRITTEN FROM PP TO CM.
*
          SPACE  4
 INLPR    SUBR               ENTRY/EXIT
          LDDL   LSTLEN      SET LENGTH OF INDIRECT LIST
          STDL   T5          INITIALIZE LOOP CONTROL
          LDC    IOBUF       GET ADDRESS OF IO BUFFER
          STML   INLPRA      SET UP 1ST ADDRESS FOR CM READ
          LDC    INDLST      GET ADDRESS OF INDIRECT LIST

 INLPR10  STDL   T6          SET INDIRECT COMMAND POINTER
          LDML   1,T6        GET LENGTH IN BYTES
          ZJN    INLPRX      IF END OF RMA LIST
          ADN    7
          SHN    -3          CONVERT LENGTH TO CM WORDS
          STDL   WC          SAVE LENGTH FOR CM READ
          LOADF  2,T6        CM ADDRESS TO A AND R FOR CM READ
          CRML   **,WC       READ DATA FROM CM
*         CWML   **,WC       (WRITE DATA TO CM)
 INLPRA   EQU    *-1
          SODL   T5          DECREMENT LOOP COUNTER BY 1
          ZJK    INLPRX      RETURN IF DONE
          LDML   1,T6        GET LENGTH OF INDIRECT IN BYTES
          SHN    -1          CONVERT LENGTH TO PP WORDS
          RAML   INLPRA      RESET ADDRESS FOR NEXT CM READ
          LDDL   T6
          ADN    4           POINT TO NEXT INDIRECT IN LIST
          UJK    INLPR10     RELOOP FOR NEXT CM READ
          SPACE  4
 CONCHS   BSS    0           CHANNEL TABLE FOR SINGLE PP
 TTP+40B  HERE
 T40B+TP  HERE
 TTP      HERE
          CON    0           END OF TABLE


 EDUALOV  EQU    *           END OF OVERLAID AREA
 DUALOVL  EQU    EDUALOV-DUALOV  LENGTH OF ALLOWABLE OVERLAID AREA
          EJECT
**        NOTE - ROUTINES AND TABLES FROM LOCATION *EDUALOV* TO *ENDDUAL*
*                MAY BE USED BY THE SLAVE PP IN A DUAL PP CONFIGURATION.
          SPACE  4
** NAME - FORMATU
*
** PURPOSE - TO FORMAT A TAPE UNIT OR CONTROLLER (CONNECT)
*
** INPUT -
*
** OUTPUT -
          SPACE  4
 FORM50   LDC    PJNI+RDSTAT1-RDSTATA  RESET TO INPUT ONLY 4 STATUS WORDS
          STML   RDSTATA
          LJM    NOSTAT       PROCESS NEXT COMMAND

 FORMATU  BSS
          LDDL   CHLOCK
          NJN    FORM40      IF CHANNEL LOCK SET
 FORM20   LDN    CHLK        SET CHANNEL LOCK
          RJM    SCLK
          NJN    FORM20      IF CHANNEL LOCK NOT OBTAINED
          AOD    CHLOCK      SET CHANNEL CURRENTLY LOCKED
          UJN    FORM40      CHECK IF UNIT CONNECTED
*         LDC    F.MCLEAR    (CIO CHANNEL - MASTER CLEAR ADAPTER)
 FORMB    EQU    *-1
          CON    0           LOWER 12 BITS OF F.MCLEAR FUNCTION
          RJM    CHFUNC
          ZJN    FORM30      IF ERROR ON FUNCTION
          LDC    F.WRCR      WRITE CONTROL REGISTER
          RJM    CHFUNC
 FORM30   ZJK    FUNTERM     IF ERROR ON FUNCTION
          ACN    TP
          LDN    1           SET TO OUTPUT 1 WORD
          OAM    FORMC,TP
          DCN    40B+TP
 FORM40   LDDL   CONFLG      CHECK IF UNIT ALREADY CONNECTED
          NJN    FORM50      IF UNIT ALREADY CONNECTED
          LDDL   UNITP       SET UNIT CONNECTED FLAG
          LMC    4000B
          STDL   CONFLG
          LDDL   CM.UIT      SAVE UIT ADDRESS FOR ROUTINE *REL*
          STML   RELA
          LDDL   CM.UIT+1
          STML   RELA+1
          LDDL   CM.UIT+2
          STML   RELA+2
          LDN    F.FU67      GET FORMAT FUNCTION FOR 67X TAPE CONTROLLER
          RJM    DOFUNC      ISSUE THE FORMAT FUNCTION
          LDML   UNITD+/UD/P.UNIT,UDPNT  GET PHYSICAL UNIT NUMBER
          LPN    17B         RESTRICT UNIT NUMBER TO 4 BITS
          SHN    4           MOVE TO CORRECT LOCATION IN FORMBUF
          RAML   FORMBUF     INSERT UNIT NUMBER IN FORMAT PARAMETERS
          LDN    3           GET LENGTH OF PARAMETERS (IN PP WORDS)
          ACN    TP          ACTIVATE THE CHANNEL
          OAPM   FORMBUF,TP  OUTPUT THE FORMAT PARAMETERS
          FJM    *,TP        WAIT UNTIL DONE
          DCN    40B+TP      DISCONNECT THE CHANNEL
          SFM    OUTCPE,TP   CHECK AND CLEAR CHANNEL PARITY ON OUTPUT
          RJM    GTSTAT      OBTAIN STATUS
          LDML   RESBUF+/RS/P.GSTAT+2  DETAILED STATUS
          LPC    777B
          NJN    FORM45      IF FATAL CONNECT ERROR
*         NJN    FORM60      (CMTS CONTROLLER)
 FORME    EQU    *-1
          LDML   RESBUF+/RS/P.GSTAT  CHECK IF UNIT BUSY
          LPN    BUSY
          ZJK    FORM50      IF UNIT NOT BUSY
          LDN    32B         SET BUSY INDICATION IN WORD 3 OF STATUS
          STML   RESBUF+/RS/P.GSTAT+2
          LDML   RESBUF+/RS/P.GSTAT  ENSURE ALERT BIT SET
          LPC    3777B
          LMC    4000B
          STML   RESBUF+/RS/P.GSTAT
          UJN    FORM45      RETURN ERROR

 FORM60   LMN    2           CHECK IF ERROR CODE 2
          NJN    FORM45      IF NOT ERROR CODE 2
          LDN    32B         SET UNIT BUSY (ERROR CODE 32B)
          STML   RESBUF+/RS/P.GSTAT+2
 FORM45   LDK    /RS/K.HDWR
          STML   RESBUF+/RS/P.HDWR  SET RESPONSE
          UJK    FAIL        ABNORMAL TERMINATE

 OUTCPE   RJM    GTSTAT      OBTAIN STATUS
          LDK    /RS/K.CHERO  SET CHANNEL PARITY ON OUTPUT
          UJK    CPETERM1    SET RESPONSE AND EXIT

 FORMC    CON    400B        PARAMETER FOR WRITE CONTROL REGISTER

          ERRNZ  /RS/P.CHERO-/RS/P.CHERR  IF K.CHERO BIT NOT IN SAME WORD AS K.CHERR

          EJECT
** NAME - CKFL
*
** PURPOSE - CHECK FOR CHARACTER FILL.  IF SET, DECREMENT
*            BYTE COUNT.
*
          SPACE  4
 CKFL     SUBR               ENTRY/EXIT
          LDN    0
          STDL   RDFLG       CLEAR READ FLAG
          LDML   RESBUF+/RS/P.CHFL  CHECK IF CHARACTER FILL IS SET
          LPK    /RS/K.CHFL
          ZJK    CKFLX       IF NO CHARACTER FILL
          LDDL   TRNCNT+3
          ZJN    CKFLX       IF NO DATA READ (PROBABLY TAPE MARK)
          SODL   TRNCNT+3    DECREMENT TRANSFER COUNT
          UJK    CKFLX
          EJECT
** NAME - GTSTAT
*
** PURPOSE - TO GET THE GENERAL AND DETAILED STATUS FOR A 67X TAPE UNIT.
*
          SPACE  4
 GTSTAT   SUBR               ENTRY/EXIT
 GTSTATA  UJN    GTSTAT5     SET EOP WAIT TIME
*         RJM    WCLEAR      (DUAL PP MASTER - SYNC UP WITH SLAVE)
          CON    WCLEAR
 GTSTAT5  LDC    110         SET OUTER LOOP TIME
          STDL   T2
 GTSTAT10 LCN    0           EOP WAIT TIME
          STDL   T1          SET WAIT COUNTER
 STATLP1  LDN    F.GS67      GET GENERAL STATUS FUNCTION FOR 67X
          RJM    DOFUNC      ISSUE GENERAL STATUS FUNCTION
 STALOOP  ACN    TP          ACTIVATE CHANNEL
          LDN    10          WAIT 10 USEC ON 4X PPU SPEED
 STATLP2  FJM    RDSTAT,TP   JUMP WHEN 1ST WORD IS AVAILABLE
          SBN    1
          NJN    STATLP2     IF NOT TIMEOUT
          DCN    TP+40B      DISCONNECT THE CHANNEL
          SODL   T1          DECREMENT WAIT TIME
          NJN    STATLP1     RELOOP TO REISSUE THE STATUS FUNCTION
          SODL   T2          DECREMENT OUTER LOOP TIME
          NJN    GTSTAT10    IF NOT TIMEOUT
          LDK    /RS/K.HDWR
          UJK    FUNTERM  TERMINATE ON NO END OF OPERATION

 RDSTAT   LDN    4           SET FIRST 4 STATUS WORDS
          IAM    RESBUF+/RS/P.GSTAT,TP  INPUT GENERAL STATUS TO RESPONSE BUFFER
          LDML   RESBUF+/RS/P.GSTAT  CHECK FOR ALERT
          SHN    17-11
 RDSTATA  PJN    RDSTAT1     IF NO ALERT
*         PSN                (NOT READ OR WRITE)
          LDN    L.GS67-4    INPUT REMAINDER OF STATUS
          IAM    RESBUF+/RS/P.GSTAT+4,TP
 RDSTAT1  DCN    TP+40B
          CFM    GTSTATX,TP  CHECK AND CLEAR CHANNEL PARITY ON INPUT

*         ALL CHANNEL PARITY ERRORS ARE PROCESSED AT THIS POINT.

 CPETERM  LDC    /RS/K.CHERR  REPORT CHANNEL PARITY ON INPUT
 CPETERM1 STML   RESBUF+/RS/P.CHERR  REPORT CHANNEL PARITY ON INPUT/OUTPUT
          UJN    CPETERM2    RETURN RESPONSE TO CM
*         LDC    F.RDESR     (CONCURRENT CHANNEL - READ ERROR STATUS REGISTER)
 CPETERMA EQU    *-1
          CON    2000B       LOWER 12 BITS OF F.RDESR FUNCTION
          RJM    CHFUNC
          ZJK    FUNTERM     IF FUNCTION TIMEOUT
          ACN    TP          INPUT ERROR STATUS REGISTER
          IAN    TP
          DCN    40B+TP
          STML   RESBUF+/RS/P.IEC  RETURN REGISTER IN RESPONSE BUFFER
 CPETERM2 UJK    FAIL        RETURN RESPONSE TO CM
          EJECT
** NAME - ERRCHK
*
** PURPOSE - SET ALERT CONDITIONS AND ABNORMAL STATUS FIELDS FOR TAPE.
*
** OUTPUT - (P2) = 0 IF NO ABNORMAL CONDITION.
*           (P2) NON-ZERO IF ERROR DETECTED.
*           (A) = 0 IF NO ERRORS OR TERMINATION CONDITION.
*
          SPACE  4
 ERRCHK   SUBR               ENTRY/EXIT
          LDN    0
          STDL   T1          CLEAR TEMP ALERT CONDITIONS
          STDL   P2          CLEAR TEMP ABNORMAL STATUS
          LDM    RESBUF+/RS/P.GSTAT
          STDL   T4
          LPC    4074B
          ADM    RESBUF+/RS/P.GSTAT+2
          ADDL   LONG
          ZJN    ERRCHKX     IF NO ERRORS TO LOOK AT
          LDDL   LONG
          ZJN    CKPHY       IF NOT LONG INPUT BLOCK
          LDK    /RS/K.LNGBLK  SET LONG INPUT BLOCK CONDITION
          RADL   T1
 CKPHY    LDDL   T4          WORD ONE OF GENERAL STATUS
          LPN    EOT+BOT     MASK OFF PHYSICAL TAPE MARK INDICATORS
          ZJN    CKFMK       SKIP IF NEITHER EOT OR BOT SET
          LDK    /RS/K.PDLIM  SET PHYSICAL DELIMITER
          RADL   T1

 CKFMK    LDDL   T4          WORD ONE OF GENERAL STATUS
          LPN    TPMARK      MASK OFF TAPE MARK INDICATOR
          ZJN    CKLONG      SKIP IF TAPE MARK NOT INDICATED
          LDK    /RS/K.LDLIM  SET LOGICAL DELIMITER
 CKLONG   RADL   T1
          LPML   RESBUF+/RS/P.LONGB  MASK ALERTS WITH ALERT MASK
          STML   RESBUF+/RS/P.LNGBLK  SET ALERT CONDITIONS IN RESPONSE
          ZJN    CKINTER     SKIP IF NO ALERT CONDITIONS ENCOUNTERED
          LDK    /RS/K.ABALRT  SET ABNORMAL ALERT INDICATOR
          RADL   P2

 CKINTER  LDML   RESBUF+/RS/P.GSTAT+2  GET WORD 3 OF HARDWARE STATUS
          ZJN    SETALRT     SKIP IF NO ERRORS ARE INDICATED
          UJN    CHKUS       CHECK STATUS WORD 3

*         LDC    B.RS        (CMTS/ISMT - SET RESPONSE LENGTH)
 ERRCHKA  EQU    *-1
          CON    B.RS
          STML   RESBUF+/RS/P.RESPL  EXTENDED STATUS OVERFLOWS INTO I/O BUF
          LDC    216B        ISSUE ISMT EXTENDED STATUS FUNCTION
*         LDC    312B        (CMTS UNIT)
 ERRCHKB  EQU    *-1
          RJM    DOFUNC
          LDN    18          LENGTH OF EXTENDED 16 BIT STATUS WORDS
*         LDN    20          (CMTS UNIT)
 ERRCHKC  EQU    *-1
          ACN    TP
          IAM    RESBUF+/RS/P.XSTAT,TP  INPUT INTO RESPONSE BUFFER
          DCN    40B+TP
          SFM    CPETERM,TP  CHECK AND CLEAR CHANNEL PARITY ON INPUT
 CHKUS    LDM    RESBUF+/RS/P.GSTAT+2  WORD 3 OF HARDWARE STATUS
          SHN    17-10
          MJN    SETHDWE     IF UNIT CHECK
          LPN    1
          ZJN    SETHDWE     IF NOT LOST DATA
          LDK    /RS/K.DATOV  SET DATA OVERRUN
          UJN    SETALRT

 SETHDWE  LDK    /RS/K.HDWR  SET HARDWARE ERROR
 SETALRT  RADL   P2
          STML   RESBUF+/RS/P.ABALRT  SET ABNORMAL STATUS FIELD IN RESPONSE
          UJK    ERRCHKX     RETURN
          EJECT
** NAME - IODONE
*
** PURPOSE - TO TERMINATE THE PP REQUEST
*
** INPUT -
*
** OUTPUT -
*
          SPACE  4
 IODONE   SUBR               ENTRY/EXIT
          RJM    RESP        SEND RESPONSE TO CPU
          LDDL   CONFLG
          ZJN    IODONEX     IF NO UNIT CONNECTED
          LOADC  CM.UIT      CHECK IF PENDING REQUEST FOR CURRENT UNIT
          ADN    /UIT/C.NEXT
          CRDL   T1
          LDDL   T3
          ADDL   T4
          ZJN    IODONE2     IF NO PENDING REQUEST
          LDML   UITBUF+/UIT/P.DSABLE
          LPC    /UIT/K.DSABLE
          ZJN    IODONE3     IF UNIT NOT DISABLED BY PP
 IODONE2  RJM    REL         RELEASE CURRENT UNIT
 IODONE3  RJM    CKCHREQ     CHECK IF CHANNEL REQUESTED BY MALET
          UJK    IODONEX     RETURN
          EJECT
** NAME - REL
*
* PURPOSE - RELEASE CONNECTED UNIT AND CLEAR *UIT* INTERLOCK.
*
* INPUT - (RELA - RELA+2) = CM ADDRESS OF *UIT* TO CLEAR INTERLOCK.
          SPACE  4
 REL      SUBR               ENTRY/EXIT
          LDN    0           CLEAR CONNECTED FLAG
          STDL   CONFLG
          STDL   SETUPF      INDICATE NO DATA IN PP
          LDN    F.RU67      RELEASE UNIT
          RJM    DOFUNC
          LDN    PULK+40B    RELEASE UNIT INTERLOCK
          RJM    SCLK
          UJN    RELX        RETURN


 RELA     BSSZ   3           CM ADDRESS OF CURRENTLY LOCKED UIT
          EJECT
** NAME - SCLK
*
** PURPOSE - SET/CLEAR SPECIFIED LOCKWORD.
*
** INPUT - (A) = 0000XX IF SET LOCK.
*          (A) = 00004X IF CLEAR LOCK.
*          XX = INDEX INTO TABLE *SCLKA* OF LOCK TO SET/CLEAR.
*
** EXIT - (A) = 0 IF LOCK SUCCESSFULLY SET/CLEARED.
*         (A) .NE. 0 IF LOCK NOT SET/CLEARED.
*
** USES - T1, T2, T5, T7.
          SPACE  4
 SCLK10   RJM    CLOCK       CLEAR INTERLOCK

 SCLK     SUBR               ENTRY/EXIT
          STDL   T2          SAVE ENTRY
          LPN    37B         MASK OFF SET/CLEAR FLAG
          STD    T1
          LDM    SCLKA,T1    SET POINTER TO CM ADDRESS OF LOCKWORD
          STDL   T7
          LDM    SCLKA+1,T1  SET INDEX INTO TABLE
          STDL   T5
          LDDL   T2
          SHN    -5
          NJN    SCLK10      IF CLEAR LOCK
          RJM    LOCK        SET LOCK
          UJK    SCLKX       EXIT


 SCLKA    BSS    0
          LOC    0
 PPLK     CON    CM.PIT,/PIT/C.LOCK  PP REQUEST QUEUE LOCK
 UILK     CON    CM.UIT,/UIT/C.ULOCK  UNIT LOCK IN UNIT INTERFACE TABLE (USED BY *UNITRQ*)
 PULK     CON    RELA,/UIT/C.ULOCK    UNIT LOCK IN UNIT INTERFACE TABLE (USED BY *REL*)
 QULK     CON    CM.UIT,/UIT/C.QLOCK  QUEUE LOCK IN UNIT INTERFACE TABLE
 CHLK     CON    CM.CHAN,0            CHANNEL LOCK
          LOC    *O

 CURCH    EQU    SCLKA+CHLK+1  LOCATION ALWAYS CONTAINS CURRENT CHANNEL NUMBER
          EJECT
** NAME-- LOCK
*
** PURPOSE-- SET A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS SET.
*         A REGISTER .NE. O, IF THE LOCK COULD NOT BE SET.
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T1 = 0, WRITE THE PP LOCKWORD TO CENTRAL MEMORY,
*            AS DESCRIBED IN THIS STEP.  ELSE IF T1 .NE. 0, GO TO
*            STEP 4.
*            TO WRITE THE PP LOCKWORD ID:
*            SET T1 - T4 = 8000 0000 0000 PPNO, WHERE PPNO IS THE
*            LOGICAL PP NUMBER OF THIS PP.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
*
*         4. IF T1 = 8000 AND T4 = PPNO, THIS LOCKWORD WAS ALREADY
*            RESERVED TO THIS PP.
*            RESTORE THE CENTRAL MEMORY LOCATION  (CWDL   T1).
*            SET THE A REGISTER = 0, AND EXIT.
*
*         5. IF T4 .NE. PPNO, THEN THIS LOCKWORD IS RESERVED TO
*            A DIFFERENT PROCESSOR.
*            SET BIT 16 OF THE LOCKWORD THAT WAS READ WITH THE
*            RDSL INSTRUCTION, AND WRITE THE CONTENTS BACK TO
*            CENTRAL MEMORY.
*            THE PURPOSE OF SETTING BIT 16 IS TO REQUEST THE
*            OTHER PROCESSOR TO GIVE UP THE LOCKWORD.
*            LDDL   T2
*            LPC    77777B
*            ADC    100000B
*            STDL   T2
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
          SPACE  4
 LOCK     SUBR               ENTRY/EXIT

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 LOCK10   BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.

          LDDL   T1
          ADDL   T4
          ZJN    LOCK40      IF LOCK CAN BE SET

* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJK    LOCK10      IF THIS PP WAS NOT FIRST TO WRITE
*                            THE INTERMEDIATE VALUE, REPEAT RDSL INSTRUCTION

* SET BIT 16 IN THE ORIGINAL CONTENTS OF CENTRAL MEMORY AND
* WRITE IT BACK TO CENTRAL MEMORY.

          LDDL   T2          SET THE 'REQUEST LOCKWORD' FLAG
          LPC    77777B
          ADC    100000B
          STDL   T2
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE LOCKWORD

          LDDL   T4
          SBDL   PPNO        CHECK IF LOCK ALREADY SET
          NJN    LOCK30      IF LOCK COULD NOT BE SET, EXIT A .NE. 0
          LDDL   T1
          ADC    -100000B
 LOCK30   UJK    LOCKX       IF LOCK WAS ALREADY SET, EXIT A = 0
                             IF LOCK COULD NOT BE SET, EXIT A .NE. 0

* SET THE LOCKWORD.

 LOCK40   BSS
          LDC    100000B
          STDL   T1
          LDN    0
          STDL   T2
          STDL   T3
          LDDL   PPNO
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          SET THE LOCKWORD
          LDN    0
          UJK    LOCK30      EXIT, A REGISTER = 0
          EJECT
** NAME-- CLOCK
*
** PURPOSE-- CLEAR A LOCKWORD IN CENTRAL MEMORY.
*
** ENTRY--
*         T7 = THE ADDRESS OF THE 3 DIRECT CELLS WHICH CONTAIN
*              THE REFORMATED ADDRESS OF THE CENTRAL MEMORY
*              INTERFACE TABLE.
*         T5 = THE CENTRAL MEMORY WORD OFFSET WITHIN THE
*              INTERFACE TABLE OF THE LOCKWORD.
*
** EXIT--
*         A REGISTER = 0, IF THE LOCK WAS CLEARED.
*         A REGISTER .NE. O, IF THE LOCK WAS NOT CLEARED.
*
** ALGORITHM
*         1. WRITE THE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000,
*            USING A RDSL INSTRUCTION.
*            (SET T1 - T4 = FFFF FFFF 0000 0000,
*            RDSL   T1)
*
*         2. AFTER EXECUTION OF 'RDSL T1',
*            IF T1 - T2 = FFFF FFFF,
*            THEN GO BACK AND EXECUTE STEP 1,
*            ELSE GO TO STEP 3.
*
*         3. IF T4 .NE. PPNO, THIS LOCKWORD IS RESERVED TO A
*            DIFFERENT PROCESSOR.
*            RESTORE THE CONTENTS OF THIS CENTRAL MEMORY LOCATION
*            AS IT EXISTED BEFORE THE VALUE FFFF FFFF XXXX XXXX
*            WAS WRITTEN.
*            CWDL   T1.
*            SET THE A REGISTER .NE. 0, AND EXIT.
*
*         4. IF T4 = PPNO, THEN CLEAR THE LOCKWORD IN CENTRAL MEMORY.
*            SET T1 - T4 = 0000 0000 0000 0000.
*            CWDL   T1.
*            SET THE A REGISTER = 0, AND EXIT.
          SPACE  4
 CLOCK    SUBR               ENTRY/EXIT

* WRITE INTERMEDIATE VALUE OF FFFF FFFF 0000 0000.

 CLK10    BSS
          LCN    0           SET INTERMEDIATE VALUE
          STDL   T1
          STDL   T2
          LDN    0
          STDL   T3
          STDL   T4
          LOADR  0,T7        UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          WRITE INTERMEDIATE VALUE

* CHECK IF RDSL INSTRUCTION WAS SUCCESSFUL.
* CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADDL   T2
          ADC    -177777B-177777B
          ZJK    CLK10       IF THIS PP WAS NOT FIRST TO WRITE
*                            THE INTERMEDIATE VALUE, REPEAT RSDL INSTRUCTION

          LDDL   T4          CHECK PP NUMBER
          SBDL   PPNO
          ZJN    CLK30       IF THIS PP HAS THE LOCK SET

* RESTORE THE ORIGINAL CONTENTS.

          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          RESTORE THE ORIGINAL CONTENTS
          LDN    1
 CLK20    UJK    CLOCKX      EXIT, A REGISTER NONZERO

* CLEAR THE LOCKWORD.

 CLK30    BSS
          LDN    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMC    400000B
          CWDL   T1          CLEAR THE LOCKWORD
          LDN    0
          UJK    CLK20       EXIT, A REGISTER = 0
          EJECT
** NAME-- CCLOCK
*
** PURPOSE-- CLEARS THE CHANNEL LOCK IN THE CM CHANNEL TABLE
*
*  OUTPUT-- THE CHANNEL THAT THIS PP HAD LOCKED, WILL BE UNLOCKED.
*
*
          SPACE  4
 CCLOCK   SUBR               ENTRY/EXIT
          LDDL   CONFLG
          ZJN    CCLOCK1     IF NO UNIT CURRENTLY CONNECTED
          RJM    REL         RELEASE UNIT AND CLEAR UIT LOCK
 CCLOCK1  LDDL   CHLOCK      CHECK IF CHANNEL LOCKED
          ZJN    CCLOCKX     IF CHANNEL NOT LOCKED
          LDN    CHLK+40B    CLEAR CHANNEL LOCK
          RJM    SCLK
          LDN    0           CLEAR CHANNEL LOCK FLAG
          STDL   CHLOCK
          UJK    CCLOCKX     EXIT
          EJECT
** NAME-- CKCHREQ
*
** PURPOSE-- CHECK IF CHANNEL IS REQUESTED BY MALET.  IF SO, RELEASE
*            ANY CONNECTED UNIT AND CHANNEL.
*
          SPACE  4
 CKCHREQ  SUBR               ENTRY/EXIT
          LOADC  CM.CHAN     ADDRESS OF CHANNEL TABLE
          ADML   CURCH       CHANNEL IS INDEX INTO TABLE
          CRDL   T1          READ CHANNEL CM ENTRY
          LDDL   T2          OBTAIN MAINTENANCE BYTES OF CHANNEL WORD
          SHN    17-0        ALIGN MAINTENANCE BIT REQUEST TO SIGN BIT
          PJN    CKCHREQX    IF CHANNEL NOT REQUESTED
          RJM    CCLOCK      CLEAR CHANNEL LOCK
          UJN    CKCHREQX    RETURN
          EJECT
** NAME-- RESP
*
** PURPOSE-- WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
*
** INPUT-- CM.PIT, CM.RS, LIM, /PIT/IN, /PIT/OUT, RS+/RS/P.RESPL
*
** OUTPUT-- /PIT/IN, RESPONSE BUFFER
          SPACE  4
 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  4
 RESP     SUBR               ENTRY/EXIT
          LDDL   TRNCNT+3    GET TRANSFER COUNT
          STML   RESBUF+/RS/P.XFER+1  SET TRANSFER COUNT IN RESPONSE BUFFER
          LDDL   TRNCNT+2
          STML   RESBUF+/RS/P.XFER
          LDDL   CMDADR      GET PP ADDRESS OF LAST COMMAND
          ADC    -REQBUF     GET PP WORDS INTO REQUEST
          SHN    1           CM BYTES INTO REQUEST
          ADML   RESBUF+/RS/P.REQ+1  ADD ON HALF 2 OF REQUEST BUFFER RMA
          STML   RESBUF+/RS/P.LASTC+1  RMA HALF 2 OF LAST COMMAND
          SHN    -16         GET CARRY IF ANY
          ADML   RESBUF+/RS/P.REQ  ADD ON HALF 1 OF REQUEST BUFFER RMA
          STML   RESBUF+/RS/P.LASTC  RMA OF HALF 1 OF LAST COMMAND

* READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RESP10   LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF 'IN' POINTER
          CRDL   P1          READ 'IN' POINTER

* CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDDL   INP
          SBDL   OUTP
          MJN    RESP20      IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP
 RESP20   LDML   RESBUF+/RS/P.RESPL  GET RESPONSE LENGTH
          STDL   T1
          LDN    0
          STDL   T2          FLAG TO DETERMINE IF 1 OR 2 BLOCK WRITES
          LDDL   INP
          RADL   T1          IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          PJK    RESP10      IN NOT ENOUGH ROOM IN BUFFER, LOOP
          LDDL   T1
          SBDL   LIM
          MJN    RESP40      IF IN + RESPONSE LENGTH .LT. LIMIT
          STDL   T1          IN + RESPONSE LENGTH - LIMIT = NEW 'IN' POINTER
          AODL   T2          2 BLOCK WRITES REQUIRED

* WRITE RESPONSE TO CM.

 RESP40   BSS
          LDDL   INP
          SHN    -3
          STDL   T3          'IN' POINTER IN WORDS
          LDML   RESBUF+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          STDL   T5
          LDDL   T2
          ZJN    RESP50      IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADC    RESBUF
          STML   RESPA       RESPONSE ADDRESS FOR 2ND BLOCK WRITE
 RESP50   BSS
          LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD 'IN' OFFSET
          CWML   RESBUF,T4   WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          SBDL   T4
          ZJN    RESP70      IF ONLY 1 BLOCK WRITE REQUIRED
          STDL   T5          RESPONSE LENGTH - (LIMIT - IN)
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          LMC    400000B
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
 RESPA    EQU    *-1         (BEGINNING OF RESPONSE BUFFER)
 RESP70   BSS
          LDDL   T1          NEW IN POINTER
          STDL   P4

* SET UP INTERRUPT PROCESSOR INSTRUCTION IF INTERRUPT IS SELECTED.

          LDML   RESBUF+/RS/P.INT  CHECK IF INTERRUPT WAS SELECTED
          LPK    /RS/K.INT
          NJN    RESP80      IF INTERRUPT SELECTED
          LDC    PSNI        PSN INSTRUCTION
          UJN    RESP90

 RESP80   BSS
          LDML   RESBUF+/RS/P.PORT  GET PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RS/L.PORT+/RS/N.PORT
          LPN    /RS/M.PORT
          ADC    INPNI       INPN INSTRUCTION
 RESP90   BSS
          STML   INTPRC

*  WRITE UPDATED 'IN' POINTER FOR CM RESPONSE BUFFER TO PIT.

          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADN    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   P1          WRITE NEW 'IN' POINTER TO CM

*  INTERRUPT PROCESSOR.

          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD
          CWDL   PPNO-3      SET LAST BYTE NON-ZERO
 INTPRC   INPN   1           INTERRUPT OR PSN
          CRDL   T1          ACCESS CM (NEEDED FOR 810/830)
          LJM    RESPX       EXIT
          EJECT
** NAME - RESPSU
*
** PURPOSE - SET UP RESPONSE BUFFER
*
** INPUT - PIT, REQUEST AND (IF UNIT REQUEST) UIT READ INTO PP MEMORY.
*          *RESPSUA* SET UP FOR UIT OR PIT PVA/RMA PP BUFFER ADDRESS.
*
** OUTPUT - NECESSARY INFORMATION PLACED IN REQUEST BUFFER.  THE REMAINDER
*           OF THE BUFFER IS ZEROED OUT.
*
          SPACE  4
 RESPSU   SUBR               ENTRY/EXIT

*         ZERO OUT RESPONSE BUFFER STARTING AT ABNORMAL STATUS FIELD.

          LDN    /RS/C.XSTAT-/RS/C.ABALRT  NUMBER OF CM WORDS TO CLEAR
          STDL   T5
          LOADC  CM.COM      LOAD R AND A OF PP COMMUNICATION BUFFER
          ADN    /CB/C.ZEROES  READ FROM ZERO BLOCK
          CRML   RESBUF+/RS/P.ABALRT,T5  ZERO PART OF RESPONSE BUFFER

*         MOVE LOGICAL UNIT, RECOVERY, INTERRUPT, PORT, PRIORITY
*         AND ALERT MASK FROM REQUEST TO RESPONSE BUFFER.

          LDML   REQBUF+/RQ/P.LU
          STML   RESBUF+/RS/P.LU
          LDML   REQBUF+/RQ/P.RECOV
          STML   RESBUF+/RS/P.RECOV
          LDML   REQBUF+/RQ/P.LONGB
          STML   RESBUF+/RS/P.LONGB
          LDC    NORMRES     SET LENGTH IN RESPONSE BUFFER
          STML   RESBUF+/RS/P.RESPL

*         MOVE CURRENT REQUEST PVA/RMA FROM UIT OR PIT TO RESPONSE BUFFER.
*         *RESPSUA* IS SET UP FOR UIT OR PIT PVA/RMA PP BUFFER ADDRESS.

          LOADC  CM.COM      LOAD R AND A OF PP COMMUNICATION BUFFER
          ADN    /CB/C.SCRAT  USE SCRATCH AREA
          CWML   **,TW
 RESPSUA  EQU    *-1
          SBN    2
          CRML   RESBUF,TW
          LJM    RESPSUX     RETURN


*         ENSURE THAT NUMBER OF ZERO BYTES IN PP COMMUNICATION BUFFER
*         IS ENOUGH TO ZERO THE NECESSARY PORTION OF THE RESP. BUFFER.
*         NOTE THAT WE DO NOT ZERO OUT THE LAST 40 OCTAL BYTES (8 PP WORDS) OF
*          THE EXTENDED STATUS AREA OF THE RESPONSE. WE DO NOT WISH TO TAKE THE
*          TIME AND THE CPU ZEROS AREA IS ONLY 15 CM WORDS IN LENGTH.

          ERRNG  /CB/B.ZEROES+/RS/C.ABALRT*8-/RS/C.XSTAT*8
          EJECT
** NAME - DOFUNC
*
** PURPOSE - ISSUE FUNCTION TO A CONTROLLER.
*
** INPUT - (A) = FUNCTION CODE TO ISSUE.
*
          SPACE  4
 DOFUNC   SUBR               ENTRY/EXIT
          STDL   LASTFC      SAVE FUNCTION CODE
          SBN    F.GS67
          ZJN    FUN1        IF STATUS REQUEST
          ADN    F.GS67
          STDL   LASTFC1     SAVE LAST NON-STATUS FUNCTION
 FUN1     LDC    0           EQUIPMENT NUMBER - SET IN *UNITRQ*
 FUNA     EQU    *-1
          ADDL   LASTFC      ADD FUNCTION CODE TO EQ NUMBER
          AJM    FUN40,TP    JUMP IF CHANNEL ACTIVE
          FAN    TP          ISSUE THE FUNCTION
          LDN    20          TIMEOUT 2-4 SECONDS ON ALL FUNCTIONS
          STDL   T0
 FUN5     LDC    100000      SET FOR MAXIMUM DELAY OF 100 MSEC.
 FUN10    IJM    DOFUNCX,TP  EXIT IF CHANNEL INACTIVE
          SBN    1
          NJN    FUN10       CONTINUE LOOPING UNTIL 100 MSEC EXPIRES
          SODL   T0          DECREMENT TIMEOUT COUNTER
          NJN    FUN5        RELOOP UNTIL TIMEOUT
 FUN40    DCN    40B+TP      DISCONNECT CHANNEL
          LDDL   LASTFC
          LMN    F.RU67
          ZJN    DOFUNCX     IF TIMEOUT OCCURRED ON RELEASE FUNCTION
          LDM    DOFUNC      FETCH CALLERS ADDRESS FOR RNI
          LMC    STALOOP
          ZJN    FUN50       IF GENERAL STATUS FUNCTION REQUEST
          RJM    GTSTAT       OBTAIN STATUS FOR LAST FUNCTION TIMEOUT
          LDML   RESBUF+/RS/P.GSTAT+2  STATUS WORD 3
          ZJN    FUN50       IF STATUS DOES NOT DIAGNOSE ERROR
          LDK    /RS/K.HDWR  SET HARDWARE MALFUNCTION
          UJN    FUNTERM     STORE RESPONSE BIT

 FUN50    LDC    /RS/K.FTO  FUNCTION TIMEOUT RESPONSE
 FUNTERM  STML   RESBUF+/RS/P.FTO  SET ABNORMAL RESPONSE FLAG BITS
          UJK    FAIL       TERMINATE TAPE REQUEST


          ERRNZ  /RS/P.FTO-/RS/P.HDWR  IF K.FTO BIT NOT IN SAME WORD AS K.HDWR
          EJECT
** NAME - CHFUNC
*
** PURPOSE - ISSUE FUNCTION CIO CHANNEL ADAPTER.
*
** INPUT - (A) = FUNCTION CODE TO ISSUE.
*
*
** OUTPUT - (A) = 0 IF FUNCTION REJECT.
          SPACE  4
 CHFUNC   SUBR               ENTRY/EXIT
          DCN    40B+TP
          FAN    TP
          LDC    377777B
 CHFUNC1  IJM    CHFUNCX,TP
          SBN    1
          NJN    CHFUNC1     IF NOT TIMEOUT
          DCN    40B+TP
          UJN    CHFUNCX     RETURN WITH (A) = 0
          EJECT
*         CONVERT BYTE COUNT TO 12-BIT CHANNEL COUNT.
*         MULTIPLY BYTE COUNT BY 2/3 AND ROUND UP.
          SPACE  4
 CBYTE    SUBR               ENTRY/EXIT
          LDN    0
          STDL   IOCNT       CHANNEL COUNT
          LDDL   BYTCNT      BYTE COUNT
          ZJK    CBYTEX      IF ZERO BYTE COUNT
          STDL   T1
          LDN    3           DIVIDE BY 3
          SHN    14
          STDL   T2
 CBY10    BSS                DIVIDE LOOP
          LDDL   IOCNT
          SHN    1
          STDL   IOCNT
          LDDL   T1
          SBDL   T2
          MJN    CBY20
          STDL   T1
          AODL   IOCNT       INCREMENT CHANNEL COUNT
 CBY20    BSS
          LDDL   T2
          SHN    -1
          STDL   T2
          NJN    CBY10       THIS CHECK WILL MULTIPLY BY 2
          LDDL   T1
          ZJK    CBYTEX      IF NO NEED TO ROUND UP
          AODL   IOCNT       ROUND UP IF REMAINDER
          UJK    CBYTEX      EXIT
          EJECT
** NAME-- FORMA
*
** PURPOSE-- FORMAT A CM REAL MEMORY ADDRESS.
*
** CALLING SEQUENCE-- LDC    ADDRESS
*                     RJM    FORMA
*
** INPUT-- - A REGISTER- IS THE ADDRESS OF A 2-WORD CM BYTE ADDRESS.
*
** OUTPUT-- -CMADR- IS THE ADDRESS OF THE RESULTING 3-WORD REFORMATED
*                CM ADDRESS.  THE FORMAT CAN BE USED BY THE LOADC MACRO.
*           -ADDRESS-, WORD 0, BITS 0-13 AND
*                      WORD 1, BITS 3-15, ARE REFORMATTED TO-
*           -CMADR-,   WORD 0, BITS 0-9,
*                      WORD 1, BITS 0-11,
*                      WORD 2, BITS 0-5.
*
          SPACE  4
 FORMA    SUBR               ENTRY/EXIT
          STDL   T1

* REFORMAT CM ADDRESS.

          LDML   1,T1
          LPN    7
          NJN    *           RMA ADDRESS ERROR, TEMPORARY HALT
          LDIL   T1
          LPN    37B
          SHN    16
          LMML   1,T1
          SHN    9
          STD    CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   T1
          SHN    -5
          STD    CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMC    400000B
          UJK    FORMAX      EXIT
          EJECT
 CONCH    BSS    0           CHANNEL TABLE FOR SINGLE/DUAL PP MASTER
 TTP+40B  HERE
 T40B+TP  HERE
 TTP      HERE
          CON    0

 PPTBL    BSSZ   P.PIT       PP INTERFACE TABLE
 UNITD    BSSZ   P.UD*8      UNIT DESCRIPTOR PART OF PIT FOR 8 UNITS
*                            NOTE THIS MUST IMMEDIATLY FOLLOW PPTBL
 UITBUF   BSSZ   P.UIT       UNIT INTERFACE TABLE
 INDLST   BSSZ   MAXIND*4    INDIRECT ADDRESS/LENGTH BUFFER
 SPACE    EQU    INDLST+5    USED BY GETBL AND GETCM
 CBUFRMA  EQU    INDLST+6    USED BY GETBL AND GETCM
 NXSPACE  EQU    INDLST+9    SPACE IN THE NEXT BUFFER
 NBUFRMA  EQU    INDLST+10   ADDRESS (RMA) OF NEXT CM BUFFER
 REQBUF   BSSZ   MAXREQ*4    SET REQUEST BUFFER LENGTH
 FORMBUF  EQU    REQBUF+12   FORMAT UNIT DATA IS AT WORD 4 OF REQ BUF
 RESBUF   BSSZ   P.RS        RESPONSE BUFFER LENGTH (MAXIMUM)
 RESBID   EQU    RESBUF+/RS/P.RESBID   BID RESPONSE AREA
 CORCNT   EQU    RESBUF+/RS/P.CORCNT   HARDWARE CORRECTION COUNT
 RESCNT   EQU    RESBUF+/RS/P.RESCNT   BID RESPONSE COUNT
 ENDCODE  EQU    *           ADDRESS OF END OF CODE AND NON I/O BUFFERS
          ERRPL  ENDCODE-IOBUF  ERROR IF CODE AND I/O BUFFERS OVERLAP
          ORG    STIOBUF     PLACE IO BUFFER AT END OF PP MEMORY - DO NOT MOVE
 IOBUF    EQU    *           INPUT/OUTPUT DATA BUFFER
          ERRNZ  IOBUF+IOBUFLNG-7777B

 CMDBUF   EQU    REQBUF+/RQ/P.CMND  COMMAND BUFFER
          ORG    ENDCODE     PLACE FOLLOWING CODE AT END OF RESPONSE BUFFER
          EJECT
**        NOTE - THE CODE AND TABLES FROM HERE TO LOCATION *ENDDUAL* CAN
*                ONLY BE USED BY THE MASTER OR SLAVE PP IN A DUAL PP
*                CONFIGURATION.  A SINGLE PP DRIVER CANNOT COUNT ON THE
*                ROUTINES BEING INTACT EXCEPT AT INITIALIZATION.
          SPACE  4
** NAME - GETBL
*
** PURPOSE - DETERMINE THE RMA(S) OF THE CM BUFFER(S) THAT THIS PP
**           WILL USE DURING A TAPE READ.
*
** INPUT - INIBUF CALLED.
*
** OUTPUT - 6 PP WORD TABLE (CMTABLE)
*
          SPACE  4
 GETBL    SUBR               ENTRY/EXIT
          LDN    0
          STML   SPACE1      INITIALIZE RMA(S) AND LENGTHS FOR THIS READ
          STML   SPACE2
          STML   RMA2.1
          STML   RMA2.2
          LDML   CBUFRMA     RMA OF THE CURRENT CENTRAL BUFFER
          STML   RMA1.1
          LDML   CBUFRMA+1
          STML   RMA1.2
          LDM    NADAMAS     CHECK FOR ZERO SPACE LEFT
          NJN    GETBLX      EXIT - NO SPACE LEFT

          LDML   SPACE       SPACE IN CURRENT BUFFER
          ADC    -DUALBUFL*2
          MJN    GETBL10     IF NOT ENOUGH SPACE IN CURRENT BUFFER
          LDC    DUALBUFL*2
          STML   SPACE1      LENGTH TO BE USED IN BUFFER AT RMA1

 GETBL5   RJM    BUMPIT      RESET THE RMA(S) FOR THE NEXT TIME.
 GETBL7   LJM    GETBLX      EXIT

 GETBL10  LDML   SPACE       SET SPACE THIS RMA.
          STML   SPACE1
          LDC    DUALBUFL*2  DETERMINE HOW MUCH IS NEEDED FROM THE
          SBML   SPACE         NEXT (IF ANY) RMA.
          STDL   T1          T1 = HOW MUCH IS NEEDED
          LDML   NUMBUF      SEE IF THERE ARE ANY MORE BUFFERS
          NJN    GETBL20     THERE IS AT LEAST 1 BUFFER MORE

          AOM    NADAMAS     SET THE -NO MORE SPACE- FLAG
          UJN    GETBL7      EXIT

 GETBL20  LDML   NXSPACE     SPACE AVAILABLE IN THE NEXT BUFFER
          SBDL   T1          SUBTRACT HOW MUCH IS NEEDED
          ZJN    GETBL30     IF EQUAL
          MJN    GETBL40     IF STILL NOT ENOUGH
 GETBL22  LDDL   T1          MORE THAN ENOUGH
          STML   SPACE2      PUT THIS AMOUNT IN THE CMTABLE
 GETBL25  LDML   NBUFRMA     PUT THE SECOND RMA IN THE TABLE
          STML   RMA2.1
          LDML   NBUFRMA+1
          STML   RMA2.2
          LJM    GETBL5      UPDATE THE RMA(S) AND EXIT

 GETBL30  AOM    NADAMAS     SET END OF BUFFERS FLAG
          UJN    GETBL22     SET THE TABLE AND EXIT

 GETBL40  LDML   NXSPACE     NOT ENOUGH WITH 2 RMA-S
          STML   SPACE2      SET IT TO WHAT WE HAVE
          AOM    NADAMAS     SET END OF BUFFERS
          UJN    GETBL25     SET THE RMA AND EXIT
          EJECT
** NAME - GETCM
*
** PURPOSE - GET DATA FROM CENTRAL MEMORY FOR A TAPE WRITE
*
** INPUT -
*
** OUTPUT -
*
** DESCRIPTION - THE IDEA IS TO BUFFER INTO THE PP A -CHUNK- OF DATA
**               FROM CENTRAL MEMORY.  THE PP WORD LABELED -SPACE- HAS
**               THE NUMBER OF BYTES REMAINING IN THIS CM BUFFER.  WORD
**               -NUMBUF- IS THE NUMBER OF CM BUFFERS (INCLUDING THE
**               CURRENT ONE).  THE NEXT BUFFER WILL BE AT -CBUFRMA-
**               PLUS 10B (BUFFERS ARE WORD ALIGNED).  SINCE THIS IS A
**               DUAL PP DRIVER, EACH PP USES EVERY OTHER CHUNK (IE. GET
**               A CHUNK, SKIP A CHUNK).
          SPACE  4
 GETCM    SUBR               ENTRY/EXIT
          LDC    DUALBUFL*2  LENGTH OF THE BUFFER IN BYTES
          SBML   SPACE       SUBTRACT SPACE REMAINING IN THIS BUFFER
          PJN    GETCM1      IF NOT ENOUGH DATA IN THIS CM BUFFER
          LJM    GETCM30     READ DATA FROM CM

 GETCM1   LDML   SPACE
          STDL   T6          KEEP TRACK OF ACTUAL BYTE COUNT
          ADN    7           ROUND UP JUST IN CASE
          SHN    -3          READ IN WHAT REMAINS OF THIS BUFFER
          STDL   T5          CM WORD COUNT
          LOADF  CBUFRMA     CM BUFFER ADDRESS
          CRML   DIOBUF,T5
          LDML   NUMBUF      CHECK THE BUFFER COUNT
          NJN    GETCM5      MORE BUFFERS IN CM
          AOM    EODATA      SET END OF DATA FLAG
          LDML   SPACE       CONVERT BYTES TO CHANNEL WORDS
          STDL   BYTCNT      SAVE FOR CBYTE ROUTINE
          RJM    CBYTE       CONVERT TO CHANNEL WORDS
          LJM    GETCMX      SPLIT

 GETCM5   LDC    DUALBUFL*2  NUMBER OF BYTES IN TOTAL BUFFER
          SBML   SPACE       NUMBER OF BYTES UNREAD
          STDL   T3          SAVE THIS NUMBER
          LDML   SPACE       SAVE OFFSET INTO BUFFER
          STDL   T4
          LDML   NXSPACE     BYTES AVAILABLE FROM NEW CM BUFFER
          SBDL   T3          SUBTRACT THE BYTES NEEDED TO FILL PP BUFFER
          SBN    1           TAKE CARE OF THE ZERO CASE
          PJN    GETCM10     ENOUGH TO FILL PP BUFFER
          LDML   NXSPACE     USE WHAT IS IN CM.  NO MORE THAN 2
*                              RMA-S ARE EVER USED TO FILL PP BUFFER.
          STDL   T3
          AOM    EODATA      THIS WILL BE THE LAST ONE

 GETCM10  LDDL   T3
          RADL   T6          BYTE COUNT
          LDDL   T3
          ZJN    GETCM40     IF NO MORE DATA TO FETCH FROM CENTRAL
          ADN    7           CONVERT BYTE COUNT TO CM WORDS
          SHN    -3
          STDL   T5
          LDDL   T4          COMPUTE OFFSET INTO BUFFER
          SHN    -1          BYTES TO PP WORD CONVERSION
          ADC    DIOBUF      ADD BEGINNING OF THE BUFFER
          STML   GETCMA
          LOADF  NBUFRMA
          CRML   **,T5       READ DATA TO PP BUFFER
 GETCMA   EQU    *-1
          UJN    GETCM40     PREPARE TO EXIT

 GETCM30  LDC    DUALBUFL*2  BYTES USED THIS CM BUFFER
          STDL   T6          USED FOR TRANSFER COUNT
          SHN    -3
          STDL   T5          STORE CM WORD COUNT
          LOADF  CBUFRMA     LOAD A/R REGISTERS FOR CM READ
          CRML   DIOBUF,T5   READ THE DATA FROM CENTRAL

 GETCM40  LDDL   T6          CONVERT BYTE COUNT TO CHANNEL WORD COUNT
          STDL   BYTCNT      INPUT TO CBYTE ROUTINE
          RJM    CBYTE
          LDM    EODATA      SKIP BUMPIT AT END
          NJN    GETCM50     IF END OF DATA
          RJM    BUMPIT      ADJUST CBUFRMA
 GETCM50  LJM    GETCMX      EXIT
          EJECT
** NAME - WRITCM
*
** PURPOSE - WRITE DATA TO CM DURING A TAPE READ.
*
** INPUT -
*
** OUTPUT -
*
          SPACE  4
 WRITCM30 LDML   SHBYTEC     SET LONG INPUT BLOCK FLAG
          RADL   LONG
          SHN    -16
          ZJN    WRITCMX     IF NO OVERFLOW
          LDN    2           ENSURE COUNT IS NOT 0 OR 1
          STDL   LONG

 WRITCM   SUBR               ENTRY/EXIT
          RJM    GETBL       DETERMINE THE RMA(S) OF THE BUFFERS
          LDML   SPACE1      SPACE (IN BYTES) AT FIRST RMA
          ZJN    WRITCM30    NO MORE BUFFER SPACE - THROW DATA AWAY
          ADML   SPACE2      CHECK FOR SHORT READ
          SBML   SHBYTEC
          ZJN    WRITCM10    IF NOT SHORT READ AND ENOUGH BUFFER SPACE
          PJN    WRITCM3     IF SHORT READ
          LMC    -0          INDICATE LONG INPUT BLOCK
          STDL   LONG
          UJN    WRITCM10    FILL THE REMAINING BUFFER SPACE

 WRITCM3  LDML   SPACE2      IF SPACE2 = 0 THEN SET SPACE1 = SHBYTEC
          ZJN    WRITCM5
          LDML   SHBYTEC     ELSE SPACE2 = SHBYTEC - SPACE1
          SBML   SPACE1
          STML   SPACE2
          PJN    WRITCM10    IF SECOND RMA INVOLVED
          LDN    0
          STML   SPACE2
          UJN    WRITCM10    PROCESS THE WRITE

 WRITCM5  LDML   SHBYTEC
          STML   SPACE1

 WRITCM10 LDML   SPACE1
          ADN    7           ROUND UP IN CASE THIS IS THE LAST
          SHN    -3          THIS IS THE NUMBER OF CM WORDS
          STDL   T5
          LOADF  RMA1.1      FORMAT THE A AND R REGISTERS
          CWML   DIOBUF,T5
          LDML   SPACE1      COMPUTE THE OFFSET INTO THE PP BUFFER
          SHN    -1            IN CASE THERE ARE TWO CM WRITES
          ADC    DIOBUF
          STML   WRITCMA     MODIFY THE CM WRITE INSTRUCTION
          LDML   SPACE2      WE MAY HAVE TO WRITE TO TWO BUFFERS
          NJN    WRITCM20    IF TWO BUFFERS
          LJM    WRITCMX     ONLY ONE THIS TIME

 WRITCM20 ADN    7           ROUND UP
          SHN    -3          CM WORDS
          STDL   T5
          LOADF  RMA2.1      FORMAT THE SECOND RMA
          CWML   **,T5       WRITE TO THE SECOND BUFFER
 WRITCMA  EQU    *-1
          LJM    WRITCMX     EXIT
          EJECT
** NAME - BUMPIT
*
** PURPOSE - INCREMENT THE LENGTH/ADDRESS RMA
*
** INPUT - NONE
*
** OUTPUT - CBUFRMA POINTS TO NEW BUFFER ADDRESS FOR THIS PP.  SPACE IS
**          SET APPROPRIATELY.
*
          SPACE  4
 BUMPIT   SUBR               ENTRY/EXIT
          LDC    DUALBUFL*4
          STDL   T4
          LDML   SPACE       THIS IS THE SPACE LEFT IN THE CURRENT
*                              BUFFER PRIOR TO THE LAST OPERATION.
          SBDL   T4          SUBTRACT FOR LAST OPERATION AND THE SPACE
*                              USED BY THE PARTNER.
          ZJN    BUMPIT20    IF NOT ENOUGH SPACE IN CURRENT RMA
          MJN    BUMPIT20    IF NOT ENOUGH SPACE IN CURRENT RMA
          STML   SPACE
 BUMPIT15 LDDL   T4          INCREMENT THE CURRENT RMA
          RAML   CBUFRMA+1
          SHN    -16         TAKE CARE OF OVERFLOW
          RAML   CBUFRMA
          UJN    BUMPITX     EXIT

 BUMPIT20 LDDL   T4          COMPUTE HOW MUCH SPACE IS NEEDED FROM NEXT
          SBML   SPACE         RMA (IF ANY)
          STDL   T4
          LDML   NUMBUF      ARE THERE ANY BUFFERS LEFT
          NJN    BUMPIT30    AT LEAST ONE LEFT
 BUMPIT28 AOM    ENTHERE     INDICATE IT ENDS IN THE PARTNER
          LDN    0           SET NO SPACE FOR THIS PP NEXT TIME
          STML   SPACE
          UJK    BUMPITX     EXIT

 BUMPIT30 LDML   INDLST+8    MOVE LENGTH/ADDRESS PAIR TO CURRENT
          STML   INDLST+4      L/A PAIR
          LDML   INDLST+9
          STML   INDLST+5
          LDML   INDLST+10
          STML   INDLST+6
          LDML   INDLST+11
          STML   INDLST+7
          RJM    GTNEWPR     GET NEXT LENGTH/ADDRESS PAIR
          LDDL   T4          IS THERE ENOUGH ROOM IN THIS BUFFER
          SBML   SPACE       THIS IS THE SPACE IN THE NEW BUFFER
          PJN    BUMPIT28    ENDS IN PARTNER

          LDML   SPACE       DECREMENT NEW SPACE BY WHAT IS NEEDED
          SBDL   T4
          STML   SPACE
          LJM    BUMPIT15    ADJUST THE RMA AND EXIT
          EJECT
** NAME - GTNEWPR
*
** PURPOSE - GET THE NEXT LENGTH/ADDRESS PAIR FROM THE INDIRECT
**           LIST.
*
** INPUT - NUMBUF = NUMBER OF THE BUFFER AT NBUFRMA
**         BUFLSTPT = RMA OF PAIR AT NBUFRMA
*
** OUTPUT - NEW LENGTH/ADDRESS PAIR READ OR NBUFRMA ZEROED.
*
          SPACE  4
 GTNEWPR  SUBR               ENTRY/EXIT
          SOML   NUMBUF      DECREMENT THE COUNT OF THE NUMBER OF
          NJN    GTNEWPR1      BUFFERS.
          STML   NBUFRMA     NONE LEFT - ZERO RMA
          STML   NBUFRMA+1
          STML   NXSPACE
          UJN    GTNEWPRX    EXIT

 GTNEWPR1 LDN    10B         INCREMENT THE BUFFER POINTER
          RAML   BUFLSTPT+1
          SHN    -16
          RAML   BUFLSTPT
          LOADF  BUFLSTPT    FORMAT THE ADDRESS IN A AND R
          CRML   INDLST+8,ON   READ IT INTO THE INDIRECT LIST BUFFER
          LDDL   RDFLG
          NJN    GTNEWPRX    IF READ (OR SLAVE PP)
          LDML   NXSPACE     ADD THIS BUFFER TO WRITE BYTE COUNT
          RADL   TRNCNT+3
          SHN    -16
          RADL   TRNCNT+2
          UJN    GTNEWPRX    EXIT
          EJECT
** NAME - WCLEAR
*
** PURPOSE - WAIT FOR THE SLAVE TO COMPLETE
*
** INPUT - NONE
*
** OUTPUT - SLAVE READY FOR NEXT COMMAND
          SPACE  4
WCLEAR    SUBR               ENTRY/EXIT
WCLEAR1   LOADC  CM.COM      LOAD R AND A FOR PP COMMUNICATION BUFFER
          ADN    /CB/C.COMM
          CRDL   T1
          LDDL   T1          SLAVE WILL CLEAR WHEN DONE
          ZJN    WCLEARX     COMPLETE
          LDN    10D         DELAY
          RJM    PAUS
          UJN    WCLEAR1     TRY AGAIN
          EJECT
** NAME - SENCOM
*
** INPUT - ADDR OF COMMAND IN A REGISTER
*
** OUTPUT - COMMAND SENT
          SPACE  4
SENCOM    SUBR               ENTRY/EXIT
          STML   SENCOMA     INSTRUCTION MODIFICATION
          LOADC  CM.COM      LOAD R AND A OF PP COMMUNICATION BUFFER
          ADN    /CB/C.COMM
          CWML   **,ON       SEND THE COMMAND
SENCOMA   EQU    *-1
          UJN    SENCOMX     EXIT
          EJECT
** NAME-- PAUS
*
** PURPOSE-- DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*            MICROSECONDS.
*
** INPUT-- A REGISTER (BITS 00-06) SPECIFIES NUMBER OF MICROSECONDS
*          TO BE DELAYED.
*
          SPACE  4
 PAUS     SUBR               ENTRY/EXIT
 PAUS10   SBN    1           EACH ITERATION OF THIS SBN-NJN LOOP
          PSN
          PSN
          NJN    PAUS10      UTILIZES 1 MICROSECOND
          UJK    PAUSX
          EJECT
**  NAME - INIBUF
*
**  PURPOSE - ESTABLISH THE VALUES THAT WILL BE USED BY THE
**            GETCM AND GETBL SUBROUTINES.
*
**  INPUT - (T4) = ADDR OF LENGTH/ADDR PAIR FOR READ/WRITE TO INITIALIZE.
*
**  OUTPUT - SPACE = THE AMOUNT OF SPACE LEFT IN THE CURRENT CM
**                   BUFFER.
**           CBUFRMA = THE RMA OF THE CURRENT BUFFER.
**           NBUFRMA =  "   "  "   "  NEXT       "
**           BUFLSTPT = THE RMA POINTER TO THE CM ADDRESS OF THE LAST
**                     LENGTH/ADDRESS PAIR CURRENTLY IN PP MEMORY.
**           NUMBUF = THE NUMBER OF LENGTH/ADDRESS PAIRS ASSOCIATED
**                    WITH THIS COMMAND.
          SPACE  4
 INIBUF   SUBR               ENTRY/EXIT
          LDN    0           INITIALIZE SOME FLAGS
          STM    EODATA
          STM    ENTHERE
          STM    NADAMAS
          LDC    DUALBUFL*2  INITIALIZE SHORT BYTE COUNT
          STML   SHBYTEC
          LDIL   T4          GET COMMAND AND FLAGS
          LPC    INDFLG      GET THE INDIRECT FLAG (BIT 6)
          NJN    INIBUF1     IF INDIRECT LIST
          LDML   2,T4        THERE IS ONLY ONE BUFFER
          STML   CBUFRMA     POINT TO THE BUFFER
          LDML   3,T4        RMA'S ARE 2 PP WORDS LONG
          STML   CBUFRMA+1   STORE BOTH HALVES
          LDML   1,T4        GET THE LENGTH
          STML   SPACE       STORE IT AWAY FOR FUTURE USE
          LDN    0           SET NUMBER OF BUFFERS - 1
          STM    NUMBUF      SET THE BUFFER COUNT
          UJN    INIBUF2     UPDATE TRANSFER COUNT IF WRITE

 INIBUF1  LDML   1,T4        INDIRECT BUFFER LENGTH
          SHN    -3          LENGTH OF BUFFER LIST IS IN BYTES
          SBN    1
          STML   NUMBUF      SET NUMBER OF BUFFERS
          LDML   2,T4        INITIALIZE BUFLSTPT
          STML   BUFLSTPT    THIS WILL BE THE CM ADDRESS (RMA) OF THE LAST
          LDML   3,T4          LENGTH/ADDRESS PAIR CURRENTLY IN PP MEMORY.  IT
          ADN    10B           IS INCREMENTED IN ROUTINE *GTNEWPR*
          STML   BUFLSTPT+1
          SHN    -16
          RAML   BUFLSTPT
          LOADF  2,T4        SET UP ADDRESS OF THE INDIRECT LIST
          CRML   INDLST+4,TW  READ THE FIRST TWO LENGTH/
*                              ADDRESS PAIRS.  NOTE - CBUFRMA IS EQUATED
*                              TO INDLST+6.  SPACE IS EQUATED TO INDLST+5.
 INIBUF2  LDDL   RDFLG
          NJN    INIBUF4     IF READ OPERATION
          LDML   NUMBUF      ADD FIRST TWO BUFFERS TO WRITE BYTE COUNT
          ZJN    INIBUF3     IF ONLY 1 BUFFER
          LDML   NXSPACE     NUMBER OF BYTES IN SECOND BUFFER
 INIBUF3  ADML   SPACE       NUMBER OF BYTES IN FIRST BUFFER
          RADL   TRNCNT+3    UPDATE TRANSFER COUNT
          SHN    -16
          RADL   TRNCNT+2
 INIBUF4  CCF    *,TP        UNCONDITIONALLY CLEAR CHANNEL FLAG
          UJK    INIBUFX     EXIT
          EJECT
**        BUFFERS AND TABLES NEEDED ONLY FOR DUAL PP DRIVER.
          SPACE  4
*         THE FOLLOWING 6 LOCATIONS ARE USED TO PASS RMA(S) AND LENGTH
*         FOR TAPE READS.

 SPACE1   BSSZ   1           SPACE IN BYTES AT RMA1
 RMA1.1   BSSZ   1           FIRST HALF OF FIRST RMA
 RMA1.2   BSSZ   1           SECOND HALF OF FIRST RMA
 SPACE2   BSSZ   1           SPACE IN BYTES OF SECOND RMA
 RMA2.1   BSSZ   1           FIRST HALF OF SECOND RMA
 RMA2.2   BSSZ   1           SECOND HALF OF SECOND RMA
 HNDSHK   VFD    8/HSHAKC,8/0  HANDSHAKE COMMAND
          BSSZ   3           DO NOT SEPARATE THIS FROM HNDSHK
 NCHANC   VFD    8/NCCOMD,8/0  CHANGE CHANNEL COMMAND
          BSSZ   3           DO NOT SEPARATE THIS FROM NCHANC
 NUMBUF   BSSZ   1           NUMBER OF BUFFERS IN INDIRECT LIST
 BUFLSTPT BSSZ   2           POINTER TO THE INDIRECT LIST OF BUFFERS
 NADAMAS  BSSZ   1           NO MORE CM BUFFER SPACE (TAPE READ)
 EODATA   BSSZ   1           END OF DATA FLAG (USED FOR WRITE)
 ENTHERE  BSSZ   1           FUNCTION ENDS IN PARTNER PP FLAG
 AREG     BSSZ   1           A REGISTER CONTENTS AFTER A READ
 SHBYTEC  BSSZ   1           BYTE COUNT ON A SHORT READ
 ENDDUAL  EQU    *           END OF DUAL PP CODE AND NON I/O BUFFERS
          ERRPL  ENDDUAL-DIOBUF  ERROR IF CODE AND I/O BUFFERS OVERLAP
          ORG    DUALBUF
 DIOBUF   EQU    *           DUAL PP I/O BUFFER
          ERRNZ  DIOBUF+DUALBUFL-7777B
          ORG    ENDDUAL     PLACE INITIALIZATION CODE IN BUFFER AREA
          EJECT
**        THE FOLLOWING CODE (FROM LOCATION *DUAL* TO *DUALL) IS MOVED
*         TO LOCATION *DUALOV* IF THIS PP IS A MASTER IN A DUAL PP
*         CONFIGURATION.  NOTE - IF THE PP IS A SLAVE, ROUTINES BETWEEN
*         *DUAL* AND *DUALL* OR *DUALOV* AND *EDUALOV* SHOULD ***NOT***
*         BE REFERENCED OR CALLED.


 DUAL     EQU    *           BEGINNING OF DUAL PP TO BE MOVED
          LOC    DUALOV
          SPACE  4
** NAME - DWRITE
*
** PURPOSE - ISSUE WRITE FUNCTION AND READ FIRST CHUNK FOR DUAL PP.
*
** INPUT - (CMDADR) = ADDRESS OF COMMAND.
*
          SPACE   4
 DWRITE   BSS
          LDML   3,CMDADR    GET HARDWARE FUNCTION
          RJM    DOFUNC      INITIATE TAPE MOTION
          ACN    TP          ACTIVATE CHANNEL
          LDDL   CMDADR      SET LENGTH/ADDRESS PAIR TO CURRENT COMMAND + 1
          ADN    4
          STDL   T4
          RJM    INIBUF      INITIALIZE BUFFER POINTERS
          RJM    GETCM       READ DATA FROM CM FOR FIRST CHUNK
          UJK    NOSTAT      GO TO DO NEXT COMMAND
          EJECT
** NAME - DOUT8D
*
** PURPOSE - TO PERFORM THE LOGICAL COMMAND OUTPUT 8-BIT DATA FOR DUAL PP.
*
** INPUT - (CMDADR) = ADDRESS OF COMMAND.
*
          SPACE  4
 DOUT8D   BSS    0           ENTRY
          LDM    EODATA      CHECK TO SEE IF THE SLAVE MUST BE CALLED
          NJN    DOUT8D1     IF SLAVE NOT NEEDED
          SCF    FLAGERR,TP  TEST AND SET THE CHANNEL FLAG
          LDDL   CMDADR      GET THE COMMAND ADDRESS AND SEND THE
          STML   DOUT8DA      COMMAND TO THE SLAVE
          LOADC  CM.COM      LOAD R AND A OF PP COMMUNICATION BUFFER
          ADN    /CB/C.COMM
          CWML   **,ON       SEND THE COMMAND TO THE SLAVE
 DOUT8DA  EQU    *-1
 DOUT8D1  LDDL   IOCNT       NUMBER OF 12 BIT CHANNEL WORDS
          FJM    *,TP
          OAPM   DIOBUF,TP   WRITE SOME TAPE
          CCF    *,TP        CLEAR CHANNEL FLAG TO START THE SLAVE
          LDM    EODATA      END OF DATA FLAG (SET BY GETCM)
          NJN    DOUT8D3     ENDED HERE - EXIT
          LDM    ENTHERE     IF IT ENDS IN THE SLAVE, WAIT
          NJN    DOUT8D2
          RJM    GETCM       GET MORE DATA TO WRITE
          FCJM   *,TP        WAIT FOR CHANNEL FLAG TO BE SET BY SLAVE
          UJN    DOUT8D1

 DOUT8D2  FCJM   *,TP        WAIT FOR SLAVE TO FINISH
 DOUT8D3  FJM    *,TP        WAIT FOR CHANNEL EMPTY
          DCN    40B+TP
          SFM    OUTCPE,TP   CHECK AND CLEAR CHANNEL PARITY ON OUTPUT
          LDDL   CMDNO       CHECK COMMANDS REMAINING
          SBN    1
          STDL   MOTION      INDICATE NEXT BLOCK SET UP OR NOT
          ZJN    DOUT8D5     IF NO MORE COMMANDS THIS REQUEST
          LDDL   CMDADR      SET UP FOR NEXT WRITE
          ADN    8
          STDL   T4
          RJM    INIBUF      INITIALIZE BUFFER POINTERS FOR NEXT BLOCK
          RJM    GETCM       READ FIRST CHUNK FOR NEXT BLOCK
 DOUT8D5  RJM    GTSTAT      WAIT FOR END OF OPERATION
          RJM    ERRCHK      CHECK FOR ERROR OR TERMINATION CONDITION
          NJN    DOUT8D10    IF ERROR OR TERMINATION CONDITION
          LDDL   MOTION
          ZJN    DOUT8D10    IF INIBUF AND READ DATA NOT PERFORMED
          LDML   7,CMDADR    GET WRITE FUNCTION FOR NEXT BLOCK
          RJM    DOFUNC      ISSUE FUNCTION
          ACN    TP          ACTIVATE CHANNEL
 DOUT8D10 LJM    CMDONE1     PROCESS WRITE COMPLETION

 FLAGERR  BSS    0           CHANNEL FLAG SET WHEN IT SHOULD NOT HAVE
          UJN    *             BEEN.  MASTER/SLAVE COMMUNICATION ASKEW.
          EJECT
** NAME - DREAD
*
** PURPOSE - PROCESS LOGICAL READ COMMAND FOR DUAL PP.
*
** INPUT - (CMDADR) = ADDRESS OF COMMAND.
*
          SPACE  4
 DREAD    BSS    0           ENTRY
          LDDL   MOTION      CHECK TAPE MOTION FLAG
          NJN    DREAD5      IF TAPE ALREADY MOVING
          LDN    F.READ      ISSUE READ FUNCTION
          RJM    DOFUNC
          ACN    TP          ACTIVATE CHANNEL
 DREAD5   LDDL   CMDADR      SET CURRENT COMMAND ADDRESS
          STDL   T4
          STML   DREADA      MODIFY THE WRITE INSTRUCTION
          AODL   RDFLG       SET READ COMMAND FLAG
          RJM    INIBUF      INITIALIZE POINTERS TO CM BUFFERS
          LDN    0           CLEAR TAPE MOTION FLAG
          STDL   MOTION
          STDL   LONG        CLEAR LONG INPUT BLOCK FLAG
          SCF    DREAD40,TP  TEST AND SET THE CHANNEL FLAG
          LOADC  CM.COM      LOAD R AND A OF PP COMMUNICATION BUFFER
          ADN    /CB/C.COMM
          CWML   **,ON       COMMAND GOES TO THE SLAVE
 DREADA   EQU    *-1
 DREAD10  LDC    WDCOUNT     ALWAYS TRY TO READ A FULL BUFFER
          IAPM   DIOBUF,TP   INPUT DATA FROM TAPE
          STM    AREG        SAVE THE CONTENTS OF THE A REGISTER
          CCF    *,TP        CLEAR THE CHANNEL FLAG TO START SLAVE
          NJN    DREAD20     SHORT READ PROCESSING
          RJM    WRITCM      WRITE THE DATA TO CM
          LDC    DUALBUFL*2  UPDATE THE TRANSFER COUNT
          RADL   TRNCNT+3
          SHN    -16
          RADL   TRNCNT+2
          FCJM   *,TP        WAIT FOR THE SLAVE TO SET THE FLAG
          UJN    DREAD10     DO IT ALL OVER AGAIN

 DREAD20  LDC    WDCOUNT     COMPUTE THE ACTUAL BYTE COUNT
          SBM    AREG        NUMBER OF 12 BIT CHANNEL WORDS MOVED
          STD    T5          STORE THIS VALUE TEMPORARILY
          SHN    1           MULTIPLY BY 3/2 TO GET BYTE COUNT
          ADD    T5
          SHN    -1          DONE - NOTE ROUNDED DOWN ON PURPOSE
          STM    SHBYTEC     STORE SHORT BYTE COUNT
          ZJN    DREAD30     IF COUNT = 0
          RADL   TRNCNT+3    UPDATE THE TRANSFER COUNT
          SHN    -16
          RADL   TRNCNT+2    UPDATE THE TRANSFER COUNT
          RJM    WRITCM      WRITE SHORT BUFFER TO CM
 DREAD30  DCN    40B+TP      DISCONNECT THE CHANNEL
          SFM    CPETERM,TP  CHECK AND CLEAR CHANNEL PARITY ON INPUT
          RJM    WCLEAR      WAIT FOR SLAVE TO COMPLETE COMMAND
          LOADC  CM.COM      READ SLAVES TRANSFER COUNT FROM PP COMM. BUFFER
          ADN    /CB/C.COMM+1
          CRDL   T1          T3 - T4 CONTAINS SLAVE TRANSFER COUNT
          LDDL   T4          ADD IT TO MASTER TRANSFER COUNT
          RADL   TRNCNT+3
          SHN    -16
          ADDL   T3
          RADL   TRNCNT+2
          LDDL   T1          SLAVE LONG INPUT BLOCK FLAG
          RADL   LONG
          SHN    -16
          ZJN    DREAD32     IF NOT OVERFLOW
          LDN    2           ENSURE COUNT NOT 0 OR 1
          STDL   LONG
 DREAD32  RJM    GTSTAT      WAIT FOR END OF OPERATION
          RJM    CKFL        CHECK FOR CHARACTER FILL
          LDDL   LONG        CHECK FOR LONG INPUT OF 1 BYTE
          SBN    1
          NJN    DREAD33     IF NOT 1 BYTE TOO LONG
          LDML   RESBUF+/RS/P.CHFL  CHECK FOR CHARACTER FILL
          LPK    /RS/K.CHFL
          ZJN    DREAD33     IF NO CHARACTER FILL
          LDN    0           INDICATE NOT LONG INPUT BLOCK
          STDL   LONG
 DREAD33  RJM    ERRCHK      CHECK FOR ERRORS OR TERMINATION CONDITION
          NJN    DREAD37     IF ERRORS OR TERMINATION CONDITION
          LDDL   CMDNO       COMMANDS REMAINING
          SBN    2
          ZJN    DREAD35     IF NO MORE POSSIBLE READ COMMANDS
          LDN    F.READ      START TAPE FOR NEXT BLOCK
          RJM    DOFUNC
          ACN    TP          ACTIVATE CHANNEL
          AODL   MOTION      SET TAPE MOTION FLAG
 DREAD35  LJM    CMDONE1     PROCESS NEXT COMMAND

 DREAD37  LOADF  6,CMDADR    RETURN TRANSFER COUNT OF ERROR BLOCK
          CWDL   TRNCNT
          UJN    DREAD35     EXIT

 DREAD40  UJN    *           CHANNEL FLAG SET WHEN IT SHOULD NOT BE
          EJECT
** NAME - DSTRTC
*
** PURPOSE - PERFORM LOGICAL COMMAND STORE TRANSFER COUNT FOR DUAL PP.
*
** INPUT - (CMDADR) = ADDRESS OF COMMAND.
*
          SPACE  4
 DSTRTC   BSS
          LOADF  2,CMDADR    CM ADDRESS TO A AND R
          CWDL   TRNCNT      SEND TRANSFER COUNT TO CM
          LDN    0           CLEAR TRANSFER COUNT
          STDL   TRNCNT+2
          STDL   TRNCNT+3
          UJK    NOSTAT      GO TO DO NEXT COMMAND
          EJECT
** NAME - SNEWC
*
** PURPOSE - SEND NEW CHANNEL COMMAND TO SLAVE.
*
** INPUT - (CURCH) = CHANNEL.
          SPACE  4
 SNEWC    SUBR               ENTRY/EXIT
          LDML   CURCH       SET CHANNEL IN COMMAND
          STML   NCHANC+3
          RJM    WCLEAR      ENSURE SLAVE IS READY
          LDC    NCHANC      SEND COMMAND TO SLAVE
          RJM    SENCOM
          UJK    SNEWCX      RETURN
          SPACE  4
 CONCHD   BSS    0           CHANNEL TABLE FOR DUAL MASTER
 TTP+40B  HERE
 T40B+TP  HERE
 TTP      HERE
          CON    0           END OF TABLE


          LOC    *O
 DUALL    EQU    *-DUAL      LENGTH OF MOVED CODE
          ERRNG  DUALOVL-DUALL  CODE TOO LONG FOR OVERLAID AREA
          EJECT
** NAME-- INIT
*
** PURPOSE-- INITIALIZE THE DRIVER AFTER DEADSTART.
*
** INPUT-- DSRTP = CM BYTE-ADDRESS OF THE WORD CONTAINING A POINTER
*                  TO THE PP INTERFACE TABLE.
          SPACE  4
 INIT     BSS

*  PAUSE A SUFFICIENT AMOUNT OF TIME TO PERMIT THE DEADSTART PP
*  TO DISCONNECT ALL CHANNELS.

          PAUSE  125000      DELAY 125 MILLISECONDS
          LDN    1           SET CONSTANTS
          STD    ON
          LDN    2
          STD    TW
          LDN    0           INSURE FLAG ZERO AT LOAD TIME
          STDL   SETUPF

*  READ PP_INTERFACE_TABLE AND UNIT DESCRIPTOR TABLES.  NOTE - THIS IS
*  THE ONLY PLACE THE STATIC FIELDS OF THE PIT AND THE UNIT DESCRIPTOR
*  TABLES ARE READ INTO THE PP.  IF THE UNIT DESCRIPTOR TABLES EVER
*  CONTAIN DYNAMIC FIELDS, THEY MUST BE READ IN WHEN LOOKING FOR UNIT
*  REQUESTS.  ONLY UNIT DESCRIPTORS THAT ARE NOT NULL ENTRIES ARE SAVED
*  IN THE PP COPY.

          LDN    C.PIT       LENGTH OF PIT
          STDL   WC
          REFAD  DSRTP,CM.PIT  REFORMAT AND LOAD CM ADDRESS OF PIT
          CRML   PPTBL,WC    READ PIT

          LDML   PPTBL       SAVE PP NUMBER
          STDL   PPNO

          LDML   PPTBL+/PIT/P.UNITC  NUMBER OF UNIT DESCRIPTORS
          STDL   T1
          ZJK    INIT7       IF NO UNITS DEFINED
          LDN    0           INITIALIZE LOOP CONTROL
          STDL   T2          NUMBER OF NON-NULL UNIT DESCRIPTORS
          STDL   T3          PP WORD OFFSET INTO UNIT DESCRIPTORS
          STDL   T4          CM WORD OFFSET INTO UNIT DESCRIPTORS
 INIT3    LOADC  CM.PIT      LOAD R REGISTER FOR PIT
          ADN    C.PIT       ADVANCE TO START OF UNIT DESCRIPTORS
          ADDL   T4          CM WORD OFFSET OF CURRENT UD
          CRML   UNITD,TW    READ UD ENTRY INTO PP
 INITC    EQU    *-1
          LDML   UNITD+/UD/P.UQT,T3
          ADML   UNITD+/UD/P.UQT+1,T3
          ZJN    INIT5       IF DUMMY ENTRY, DO NOT COUNT
          AODL   T2          INCREMENT COUNT OF ACTIVE UNITS
          SBN    8
          ZJN    INIT6       IF REACHED MAX TABLE SPACE FOR UDS
          LDN    P.UD        INCREMENT TO NEXT PP UD
          RADL   T3
          LDN    P.UD
          RAML   INITC
 INIT5    LDN    C.UD        INCREMENT TO NEXT CM UD
          RADL   T4
          SODL   T1          DECREMENT TOTAL UNITS IN PIT
          NJN    INIT3       IF NOT DONE SCANNING UD TABLES
 INIT6    LDDL   T2          RESET NUMBER OF ACTIVE UNITS
          STML   PPTBL+/PIT/P.UNITC

*  REFORMAT ADDRESS OF RESPONSE BUFFER.
*  INITIALIZE LIM.

 INIT7    REFAD  PPTBL+/PIT/P.RSBUF,CM.RS  REFORMAT AND LOAD ADDRESS OF RESP. BUFFER
          LDML   PPTBL+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STDL   LIM

*  REFORMAT ADDRESS OF THE INTERRUPT WORD.

          REFAD  PPTBL+/PIT/P.INT,CM.INT

*  REFORMAT ADDRESS OF CHANNEL TABLE.

          REFAD  PPTBL+/PIT/P.CHAN,CM.CHAN

*  DETERMINE IF SINGLE OR DUAL PP.

          REFAD  PPTBL+/PIT/P.CBUF,CM.COM  REFORMAT AND LOAD CM ADDR OF PP COMM. BUFFER
          CRDL   T1          READ FIRST WORD OF COMM. BUFFER
          LDDL   T3          CHECK IF RMA FIELD NON-ZERO
          ADDL   T4
          ZJN    INIT10      IF NO RMA, THIS IS SINGLE PP
          LJM    INIT160     INITIALIZE DRIVER AS DUAL PP

*  INITIALIZE CHANNEL INSTRUCTIONS.
 INIT10   LDML   PPTBL+/PIT/P.UNITC
          ZJK    INIT150     IF NO UNITS DEFINED IN PIT
          LOADF  UNITD+/UD/P.UQT  REFORMAT RMA OF FIRST UIT
          CRML   UITBUF,ON   OBTAIN UIT
          LDML   UNITD+/UD/P.CHAN  OBTAIN PRESENT CHANNEL NUMBER
          SHN    -8
          STML   CURCH
          ZJN    INIT30      IF CHANNEL IS ZERO, NO CHANGE REQUIRED
 INITA    UJN    INIT20      MODIFY CHANNEL INSTRUCTIONS
*         RJM    SNEWC       (DUAL PP MASTER - SEND NEW CHANNEL COMMAND TO SLAVE)
          CON    SNEWC
 INIT20   LDC    CONCH       MODIFY MAIN PROGRAM CHANNEL INSTRUCTIONS
          RJM    CHGCH
          LDC    CONCHS      MODIFY SINGLE PP CHANNEL INSTRUCTIONS
*         LDC    CONCHD      (DUAL PP MASTER)
 INITB    EQU    *-1
          RJM    CHGCH
          LDC    CONCH2      MODIFY INITIALIZATION CHANNEL INSTRUCTIONS
          RJM    CHGCH

*  LOCK CHANNEL IN CHANNEL INTERLOCK TABLE.

 INIT30   LDN    CHLK        SET CHANNEL LOCK
          RJM    SCLK
          NJN    INIT30      IF CHANNEL LOCK NOT OBTAINED
          AOD    CHLOCK      SET CHANNEL CURRENTLY LOCKED
          DCN    40B+TP      UNCONDITIONALLY DISCONNECT CHANNEL

*  MASTER CLEAR CIO ADAPTER IF CONCURRENT CHANNEL

          LOADC  CM.CHAN     DETERMINE CHANNEL TYPE
          ADC    32          INDEX TO CHANNEL CHARACTERISTICS OF CHANNEL TABLE
          ADML   CURCH       CURRENT CHANNEL NUMBER
          CRDL   T1
          LDDL   T1
          SHN    17-15
          PJN    INIT60      IF NOT CONCURRENT CHANNEL
          LDC    LDCI+11B    ENABLE INPUT OF CIO ADAPTER STATUS REGISTER
          STML   CPETERMA
          LDC    LDCI+10B    ENABLE MASTER CLEAR OF CIO ADAPTER
          STML   FORMB
          LDC    F.MCLEAR    MASTER CLEAR ADAPTER
          RJM    CHFUNC
          ZJN    INIT40      IF ERROR ON FUNCTION
          LDC    F.WRCR      WRITE CONTROL REGISTER
          RJM    CHFUNC
          ZJN    INIT40      IF ERROR ON FUNCTION
          ACN    TP
          LDN    1           SET TO OUTPUT 1 WORD
          OAM    FORMC,TP
          DCN    40B+TP
          UJN    INIT60      CHECK UNIT TYPE

 INIT40   LDC    7774B       RETURN FUNCTION TIMEOUT ERROR
          LJM    INIT149

*  CHECK IF LOAD ISMT/CMTS CONTROLWARE MICROCODE.

 INIT60   LDML   UITBUF+/UIT/P.UTYPE  UNIT TYPE
          SBN    T639.1
          ZJN    INIT85      IF ISMT UNIT
          SBN    T698-T639.1
          NJK    INIT150     IF NOT CMTS UNIT

*  MODIFY INSTRUCTIONS FOR CMTS.

          LDC    NJNI+FORM60-FORME  SET ERROR CODE 2 CHECK
          STML   FORME
          LDC    312B        SET EXTENDED STATUS FUNCTION
          STML   ERRCHKB
          LDC    LDNI+20     SET EXTENDED STATUS LENGTH
          STML   ERRCHKC

*  READ UP CONTROLWARE LOAD COMMAND (LENGTH AND RMA OF CONTROLWARE ADDRESS/LENGTH PAIRS)

 INIT85   LOADC  CM.COM      LOAD R AND A OF PP COMMUNICATION BUFFER
          ADN    /CB/C.CONTRL  ADD CONTROLWARE POINTER OFFSET
          CRML   CNTCMDW,ON         NOW HAVE LENGTH AND PTR TO ADDRESS/PAIR LIST
          LDML   CNTCMDW
          SHN    -10
          LMN    3
          NJN    INIT85            IF CONTROLWARE LIST NOT READY YET
          DCN    40B+TP

* SEND AUTOLOAD FUNCTION AND ACTIVATE CHANNEL

          LDC    LDCI        SET TO OBTAIN ISMT/CMTS EXTENDED STATUS
          STML   ERRCHKA
          LDML   UNITD+/UD/P.CNTRLR  SET EQUIPMENT NUMBER FOR PRESET FUNCTIONS
          LPN    7
          SHN    9
          STML   INITE
          LDK    F.MCLR
          ADC    0           ADD EQUIPMENT NUMBER
 INITE    EQU    *-1
          FAN    TP
          LCN    0
 INIT87   IJM    INIT89,TP
          PSN
          PSN
          SBN    1             DECREMENT COUNTER
          NJN    INIT87        IF TIMEOUT NOT EXPIRED
          DCN    TP+40B        DISCONNECT CHANNEL
          LDC    7777B         SET ISMT/CMTS AUTOLOAD TIMEOUT CODE
          LJM    INIT149       REPORT STATUS IN UNSOLICITED RESPONSE

 INIT89   PSN
          PSN
          PSN
          ACN    TP

          LOADF  CNTCMDW+/CM/P.RMA  REFORMAT ADDRESS TO CURRENT PAIR
          CRML   CURPAIR,ON
          LOADF  CURPAIR+/CM/P.RMA
          LDML   CURPAIR+/CM/P.LEN
          ADN    7
          SHN    -3
          STML   WCT                ASSURE CM WORD BOUNDARY
          ZJK    INIT140            **MAYBE ISSUE ERROR

 INIT95   LDML   WCT
          SBN    60                 PRESENTLY USE 60 CM BUFFER (240 PP BYTES)
          MJN    INIT100            IF WCT LESS THAN 60 CM BUFFER
          LDN    60
          STDL   WC
          LDML   WCT
          SBDL   WC
          STML   WCT                SET REMAINING WORD COUNT
          LDDL   CMADR+2            SET THE A REGISTER FOR CM ADDRESS OF DATA
          LMC    400000B
          CRML   CNTLBUF,WC
          STDL   CMADR+2            UPDATE ADDRESS TO NEXT DATA
          LDDL   WC
 INIT97   SHN    3
          STDL   BYTCNT             SET BYTE COUNT FOR THIS TRANSFER
          RJM    CBYTE              SET CHANNEL BYTES FOR BYTES IN BUFFER
          LDDL   IOCNT              SET NUMBER OF CHANNEL WORD TO OUTPUT
          OAPM   CNTLBUF,TP         OUTPUT TO ISMT/CMTS ADAPTER
          FJM    *,TP               WAIT TILL LAST WORD TAKEN THIS TRANSFER
          STML   AREGR
          UJN    INIT95             IF MORE DATA THIS ADDRESS LIST

 INIT100  LDML   WCT
          STDL   WC                 SET WC FOR REMAINING WC THIS ADDRESS
          STML   LASTWCT            SAVE THIS AS LAST WORD COUNT
          ZJN    INIT105            IF NO REMAINDER THIS ADDRESS BLOCK
          LDDL   CMADR+2            SET ADDRESS TO INPUT REMAINDER
          LMC    400000B
          CRML   CNTLBUF,WC
 INIT105  LDML   CNTCMDW+/CM/P.LEN  DECREMENT ADDRESS PAIR COUNT
          SBN    8
          ZJK    INIT130            IF NO MORE ADDRESS WITH DATA
          STML   CNTCMDW+/CM/P.LEN  SAVE REMAINING LENGTH
          LDN    8
          RAML   CNTCMDW+/CM/P.RMA+1  UPDATE ADDRESS TO NEXT DATA AREA
          SHN    -16
          RAML   CNTCMDW+/CM/P.RMA
          LOADF  CNTCMDW+/CM/P.RMA  READ UP NEXT CURRENT PAIR
          CRML   CURPAIR,ON
          LOADF  CURPAIR+/CM/P.RMA  SET THE R REGISTER FOR CURRENT PAIR
          LDML   CURPAIR+/CM/P.LEN
          ZJK    INIT120            IF END OF LIST (SEND REMAINDER)
          ADN    7
          SHN    -3
          STML   WCT                SAVE TOTAL CM WORD COUNT THIS ADDRESS
          LDML   LASTWCT
          SHN    2                  SET NUMBER PP BYTES IN LAST TRANSFER
          ADC    CNTLBUF            ADDRESS OF START OF BUFFER
          STML   INIT110+1          RESET CM ADDRESS WHERE TO INPUT DATA
          LDN    60
          SBML   LASTWCT            SET TO INPUT REMAINDER OF BUFFER
          STDL   WC                 SET THIS TRANSFER LENGTH
          LDDL   CMADR+2            SET THE A REGISTER FOR CM ADDRESS
          LMC    400000B
 INIT110  CRML   CNTLBUF,WC         FILL REMAINDER OF BUFFER
          STDL   CMADR+2            UPDATE TO NEXT DATA ADDRESS
          LDML   WCT                SET REMAINING WORD COUNT THIS BUFFER
          SBDL   WC
          MJN    INIT115            IF THIS BUFFER IS NOW EMPTY
          STML   WCT
          LDN    60                 OUTPUT FULL BUFFER
          UJK    INIT97             ENTER LOOP TO GET/SEND CONTROLWARE

 INIT115  LDML   LASTWCT            SET REMAINING WORD COUNT TO OUTPUT
          ADML   WCT
          STDL   WC
          UJN    INIT130            OUTPUT FINAL DATA

 INIT120  LDML   LASTWCT            MUST SEND REMAINING DATA
          STDL   WC
 INIT130  LDD    WC                 MUST OUTPUT FINAL DATA
          ZJN    INIT140            IF LAST ADDRESS CONTAINED FINAL DATA
          SHN    3                  SET NUMBER OF BYTES
          STDL   BYTCNT
          RJM    CBYTE              SET CHANNEL WORDS FOR BYTE COUNT GIVEN
          LDDL   IOCNT              PICK UP NUMBER OF 12 BIT CHANNEL WORDS
          OAPM   CNTLBUF,TP
          FJM    *,TP               WAIT FINAL WORD OFF CHANNEL
          STML   AREGR
 INIT140  DCN    40B+TP
          LDN    F.GS67            ISSUE STATUS FUNCTION
          ADML   INITE             ADD EQUIPMENT NUMBER
          FAN    TP
          LCN    0
 INIT145  IJM    INIT147,TP        TIMEOUT WAITING FOR STATUS
          SBN    1
          NJN    INIT145           IF TIMEOUT NOT COMPLETE
          UJN    INIT149           SEND ISMT/CMTS STATUS OF ZERO ON TIMEOUT

 INIT147  ACN    TP
          IAN    TP                INPUT GENERAL STATUS
          DCN    40B+TP
 INIT149  STM    RESBUF+/RS/P.GSTAT  SET ISMT/CMTS GENERAL STATUS
          LDN    R.UNS             UNSOLICITED RESPONSE CODE
          RAML   RESBUF+/RS/P.RC   SET IN RESPONSE AREA
          LDC    NORMRES           SET LENGTH OF RESPONSE BUFFER
          STML   RESBUF+/RS/P.RESPL
          RJM    RESP              SEND UNSOLICITED RESPONSE
 INIT150  LDN    0           ZERO OUT *ZEROES* FIELD IN COMM. BUFFER
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDK    /CB/B.ZEROES  LENGTH OF ZERO AREA IN BYTES
          SHN    -3
          STDL   T5          LENGTH OF ZERO AREA IN CM WORDS
 INIT155  LOADC  CM.COM      LOAD R AND A OF COMMUNICATION BUFFER
          ADN    /CB/C.ZEROES-1
          ADDL   T5
          CWDL   T1          ZERO ONE CM WORD
          SODL   T5          DECREMENT INDEX
          NJN    INIT155     IF MORE CM WORDS TO CLEAR
          LJM    TAPE        EXIT TO MAIN LOOP

 WCT      CON    0
 AREGR    CON    5555B
 LASTWCT  CON    4567B
          SPACE  4,6
**  INITIALIZATION FOR DUAL PP.

 INIT160  LDDL   T2          CHECK IF SLAVE BIT IS SET
          LPK    /CB/K.SLAVE
          NJK    INIT180     IF THIS PP IS SLAVE

**  INITIALIZE MAIN CODE INSTRUCTIONS FOR MASTER.

          LDC    RJMI        ENABLE SUBROUTINE CALLS
          STML   GTSTATA
          STML   INITA
          LDC    DWRITE      CHANGE COMMAND PROCESSORS
          STML   FUNCA
          LDC    DOUT8D
          STML   DORQC+1
          LDC    DREAD
          STML   DORQD+1
          LDC    DSTRTC
          STML   DORQE+1
          LDC    CONCHD      CHANGE CHANNEL TABLE ADDRESS
          STML   INITB

*  MOVE DUAL PP MASTER ROUTINES.

          LDN    0           INITIALIZE INDEX
          STD    T1
 INIT170  LDML   DUAL,T1     MOVE INSTRUCTION
          STML   DUALOV,T1
          AODL   T1          INCREMENT INDEX
          LMC    DUALL
          NJN    INIT170     IF MORE CODE TO MOVE

*  WAIT UNTIL SLAVE IS READY.

          LDC    HNDSHK      SEND HANDSHAKE COMMAND
          RJM    SENCOM
 INIT175  LDC    1000D       DELAY
          RJM    PAUS
          LOADC  CM.COM      LOAD R AND A OF PP COMMUNCATION BUFFER
          ADN    /CB/C.COMM
          CRDL   T1
          LDDL   T1
          NJN    INIT175     IF SLAVE NOT READY YET
          LDC    0415B       ID = DM (DUAL MASTER)
          STDL   ID
          LJM    INIT10      LOAD ISMT/CMTS CONTROLWARE IF NECESSARY

**  INITIALIZE DRIVER FOR SLAVE.

 INIT180  LDN    C.PIT       LENGTH OF PP INTERFACE TABLE
          STDL   WC
          REFAD  T3,CM.PIT   SET UP CM.PIT - CM.PIT+2
          CRML   PPTBL,WC    READ MASTER PIT
          REFAD  PPTBL+/PIT/P.CBUF,CM.COM  LOAD CM ADDRESS OF MASTER PP COMM. BUFFER

*  RELOCATE SLAVE CODE.

          LDN    0           INITIALIZE INDEX
          STD    T1
 INIT190  LDML   SLAVE,T1    MOVE INSTRUCTION
          STML   TAPE,T1
          AODL   T1          INCREMENT INDEX
          LMC    LSLAVE
          NJN    INIT190     IF MORE CODE TO MOVE
          AODL   RDFLG       SET TO NOT UPDATE TRANSFER COUNT IN *GTNEWPR*
          LDC    0423B       ID = DS (DUAL SLAVE)
          STDL   ID
          LJM    TAPE        EXIT TO MAIN LOOP


          ERRNZ  TAPE-/SLAVE/TPMAIN  ENTRY POINTS NOT THE SAME
          SPACE  4
 CNTCMDW  BSSZ   4           SECOND WORD OF PP COMM. BUFFER
 CURPAIR  BSSZ   4           LENGTH/ADDRESS FOR ISMT/CMTS CONTROLWARE
          EJECT
** NAME - CHGCH
*
** PURPOSE - CHANGE CHANNEL NUMBER IN CHANNEL INSTRUCTIONS
*
** INPUT - (CURCH) = CHANNEL NUMBER.
*          (A) = CHANNEL TABLE ADDRESS.
*
          SPACE  4
 CHGCH    SUBR               ENTRY/EXIT
          STDL   T1          SET ADDRESS MODIFICATION LIST ADDRESS
 CHG10    LDIL   T1          READ LIST WORD
          ZJN    CHGCHX      IF END OF LIST
          STDL   T2          SET INSTRUCTION ADDRESS
          LDIL   T2          READ INSTRUCTION WORD
          SCN    37B         CLEAR CHANNEL BITS
          LMML   CURCH       REPLACE WITH NEW CHANNEL
          STIL   T2
          AODL   T1          INCREMENT TO NEXT INSTRUCTION
          UJN    CHG10       LOOP
          SPACE  4
 CONCH2   BSS                INITIALIZATION CHANNEL MODIFICATION LIST
 TTP+40B  HERE
 T40B+TP  HERE
 TTP      HERE
          CON    0           END OF TABLE

 CNTLBUF  EQU    *           ISMT/CMTS CONTROLWARE BUFFER
          ERRPL  CNTLBUF+240-ENDMEM  BUFFER OVERFLOWS PP


**        NOTE - THE ISMT/CMTS CONTROLWARE BUFFER DESTROYS THE SLAVE
*                PP CODE.  THIS IS ALL RIGHT SINCE ONLY THE MASTER
*                LOADS ISMT/CMTS CONTROLWARE.
          EJECT
 SLAVE    EQU    *
          QUAL   SLAVE
          LOC    TAPE
 TPMAIN   BSS    0
          RJM    UREQ        CHECK FOR REQUEST
          NJN    TPMAIN2     REQUEST FOUND
          LDK    50          WAIT A WHILE
 TPMAIN1  SBN    1
          NJN    TPMAIN1
          UJN    TPMAIN

 TPMAIN2  RJM    INIBUF      INITIALIZE THE BUFFERS
          RJM    DORQ        DO THE REQUEST
          RJM    IODONE      TERMINATE REQUEST
          UJN    TPMAIN      MAIN LOOP
          EJECT
** NAME - UREQ
*
** PURPOSE - CHECK FOR REQUEST FROM MASTER PP
*
** INPUT - NONE
*
** OUTPUT - A = 0  NO REQUEST
*         - A .NE. 0  REQUEST IN CMDBUF
          SPACE  4
 UREQ     SUBR               ENTRY/EXIT
          LOADC  CM.COM      LOAD R AND A OF MASTER PP COMMUNICATION BUFFER
          ADN    /CB/C.COMM
          CRML   CMDBUF,ON
          LDML   CMDBUF      CHECK FOR COMMAND
          SHN    -8          LOOK AT THE COMMAND
          ZJN    UREQX       IF NO COMMAND - EXIT
          ADC    -NCCOMD     CHECK FOR CHANGE CHANNEL COMMAND
          NJN    UREQ15      NOT CHANGE CHANNEL
          LDML   CMDBUF+3    SAVE NEW CHANNEL NUMBER
          STML   //CURCH
          LDC    CONCH       ADDRESS OF CHANNEL TABLE
          RJM    CHGCH       MODIFY CHANNEL INSTRUCTIONS
          UJN    UREQ20      COMPLETE REQUEST

 UREQ15   ADC    NCCOMD-HSHAKC  CHECK FOR THE HANDSHAKE COMMAND
          NJN    UREQX       NOT A HANDSHAKE - MUST BE DATA MOVE
 UREQ20   RJM    IODONE
          LDN    0           SET NO COMMAND TO PROCESS
          UJK    UREQX       EXIT
          EJECT
** NAME - DORQ
*
** PURPOSE - PERFORM THE REQUIRED REQUEST
*
** INPUT - REQUEST IN REQBUF
*
** OUTPUT -
*
          SPACE  4
 DORQ10   RJM    OUT8D       OUTPUT 8-BIT DATA

 DORQ     SUBR               ENTRY/EXIT
          LDML   //CMDBUF    GET COMMAND AND FLAGS
          SHN    -8
          SBN    PWRTCMD
          ZJN    DORQ10      IF OUTPUT 8-BIT DATA
          SBN    LCREAD-PWRTCMD
          NJN    *           IF NOT LOGICAL READ, NON-SUPPORTED COMMAND
          RJM    IN8         INPUT 8-BIT DATA
          UJK    DORQX       EXIT
          EJECT
** NAME - OUT8D
*
** PURPOSE - TO PERFORM THE PHYSICAL COMMAND OUTPUT 8-BIT DATA.
*
** INPUT -
*
** OUTPUT -
          SPACE  4
 OUT8D    SUBR               ENTRY/EXIT
 OUT8D1   RJM    GETCM       GET A BUFFER FULL
          LDDL   IOCNT       NUMBER OF 12 BIT CHANNEL WORDS
          FSJM   *,TP        WAIT FOR FLAG TO GO CLEAR
          FJM    *,TP
          OAPM   DIOBUF,TP   WRITE SOME TAPE
          SCF    FLAGERR,TP  SET THE CHANNEL FLAG TO START THE MASTER
          LDM    EODATA      END OF DATA FLAG (SET BY GETCM)
          ADM    ENTHERE     END IN PARTNER (SET IN BUMPIT)
          ZJN    OUT8D1      IF NOT COMPLETE
          UJK    OUT8DX      EXIT

 FLAGERR  BSS    0           CHANNEL FLAG SET WHEN IT SHOULD NOT HAVE
          UJN    *             BEEN.  MASTER/SLAVE COMMUNICATION
*                              ASKEW.  ABORT TASK.
          EJECT
** NAME - IN8
*
** PURPOSE - TO PERFORM THE PHYSICAL COMMAND INPUT 8-BIT DATA/PARAMETERS.
*
** INPUT -
*
** OUTPUT -
*
          SPACE  4
 IN8      SUBR               ENTRY/EXIT
          LDN    0           CLEAR TRANSFER COUNT
          STML   RCOUNT+2
          STML   RCOUNT+3
          STDL   LONG        CLEAR LONG INPUT BLOCK FLAG
 IN8D1    LDC    WDCOUNT     ALWAYS TRY TO READ A FULL BUFFER
          FSJM   *,TP        WAIT UNTIL FLAG IS CLEAR
          IAPM   DIOBUF,TP   INPUT DATA FROM TAPE
          STML   AREG        SAVE THE CONTENTS OF THE A REGISTER
          SCF    FLAGERR,TP  SET THE FLAG - FIRE UP THE PARTNER
          NJN    IN8D5       PROCESS SHORT READ
          RJM    WRITCM      WRITE THE DATA TO CM
          LDC    DUALBUFL*2  UPDATE THE TRANSFER COUNT
          RAML   RCOUNT+3
          SHN    -16
          RAML   RCOUNT+2
          UJN    IN8D1       DO IT ALL OVER AGAIN

 IN8D5    LDC    WDCOUNT     COMPUTE THE ACTUAL BYTE COUNT
          SBML   AREG        NUMBER OF 12 BIT CHANNEL WORDS MOVED
          STD    T5          STORE THIS VALUE TEMPORARILY
          SHN    1           MULTIPLY BY 3/2 TO GET BYTE COUNT
          ADD    T5
          SHN    -1          DONE - ROUNDED DOWN INTENTIONALLY
          STML   SHBYTEC     STORE BYTE COUNT FOR WRITCM ROUTINE
          ZJN    IN8D10      IF COUNT = 0
          RAML   RCOUNT+3    UPDATE THE TRANSFER COUNT
          SHN    -16
          RAML   RCOUNT+2
          RJM    WRITCM      WRITE DATA TO CENTRAL
 IN8D10   LDDL   LONG        SET LONG INPUT BLOCK INDICATOR FOR MASTER
          STML   RCOUNT
          UJK    IN8X        EXIT
          EJECT
** NAME - IODONE
*
** PURPOSE - TO TERMINATE THE PP REQUEST
*
** INPUT -
*
** OUTPUT -
*
          SPACE  4
 IODONE   SUBR               ENTRY/EXIT
          LOADC  CM.COM      LOAD R AND A OF MASTER PP COMMUNICATION BUFFER
          ADN    /CB/C.COMM
          CWML   ZEROS,TW    ZERO OUT THE COMMAND
          UJK    IODONEX     EXIT


 ZEROS    BSSZ   4           USED TO ZERO THE COMMAND TO SLAVE
 RCOUNT   BSSZ   4           TRANSFER COUNT FOR READ
          EJECT
**  NAME - INIBUF
*
**  PURPOSE - ESTABLISH THE VALUES THAT WILL BE USED BY THE
**            GETCM AND GETBL SUBROUTINES.
*
**  INPUT - REQUEST IN REQBUF
*
**  OUTPUT - SPACE = THE AMOUNT OF SPACE LEFT IN THE CURRENT CM
**                   BUFFER.
**           CBUFRMA = THE RMA OF THE CURRENT BUFFER.
**           NBUFRMA =  "   "  "   "  NEXT       "
**           BUFLSTPT = THE RMA POINTER TO THE CM ADDRESS OF THE LAST
**                     LENGTH/ADDRESS PAIR CURRENTLY IN PP MEMORY.
**           NUMBUF = THE NUMBER OF LENGTH/ADDRESS PAIRS ASSOCIATED
**                    WITH THIS COMMAND.
          SPACE  4
INIBF90   LDC    -DUALBUFL*2    WILL THE SLAVE START IN THE FIRST BUFFER
          RAML   SPACE       ADJUST SPACE (IN BYTES) LEFT THIS BUFFER
          ZJN    INIBF92     MUST START IN NEXT BUFFER
          MJN    INIBF92     DITTO
          LDC    DUALBUFL*2  BEGINNING OFFSET
INIBF91   RAML   CBUFRMA+1   ADJUST THE RMA
          SHN    -16
          RAML   CBUFRMA     TAKE CARE OF OVERFLOW
          UJK    INIBUFX     EXIT

INIBF92   LDML   SPACE       SLAVE STARTS IN SECOND BUFFER
          ZJN    INIBF93     IF COULD BE ZERO - SPECIAL CASE
          LMC    177777B     COMPLEMENT THE NUMBER
INIBF93   STDL   T5          OFFSET INTO SECOND BUFFER
          LDML   NUMBUF      CHECK NUMBER OF RMA LIST ENTRIES
          NJN    INIBF95     IF MORE THAN ONE RMA INDIRECT LIST ENTRY
          STML   SPACE       SET NO BUFFER SPACE FOR THIS PP
          UJN    INIBUFX     EXIT

 INIBF95  LDML   INDLST+8    MOVE LENGTH/ADDRESS PAIR TO CURRENT
          STML   INDLST+4      L/A PAIR
          LDML   INDLST+9
          STML   INDLST+5
          LDML   INDLST+10
          STML   INDLST+6
          LDML   INDLST+11
          STML   INDLST+7
          RJM    GTNEWPR     GET NEXT LENGTH/ADDRESS PAIR
          LDML   SPACE       ADJUST SPACE IN THIS BUFFER
          SBDL   T5
          PJN    INIBF96     IF ENOUGH SPACE FOR MASTER TO FILL
          LDN    0           SET NO BUFFER SPACE FOR THIS PP
INIBF96   STML   SPACE
          LDDL   T5          SPACE MASTER WILL USE IN SECOND BUFFER
          UJK    INIBF91     FINISH UP

INIBUF    SUBR               ENTRY/EXIT
          LDN    0           INITIALIZE SOME FLAGS
          STM    EODATA
          STM    ENTHERE
          STM    NADAMAS
          LDC    DUALBUFL*2  INITIALIZE SHORT BYTE COUNT
          STML   SHBYTEC

          LDC    CMDBUF      SET UP POINTER TO COMMAND
          STD    T4          THIS POINTS TO A INPUT OR OUTPUT COMMAND

          LDIL   T4          GET COMMAND AND FLAGS
          LPC    INDFLG      GET THE INDIRECT FLAG (BIT 6)
          NJN    INIBUF2     READ INDIRECT LIST
          LDML   2,T4        THERE IS ONLY ONE BUFFER
          STML   CBUFRMA     POINT TO THE BUFFER
          LDML   3,T4        RMA'S ARE 2 PP WORDS LONG
          STML   CBUFRMA+1   STORE BOTH HALVES
          LDML   1,T4        GET THE LENGTH
          STML   SPACE       STORE IT AWAY FOR FUTURE USE
          LDN    0           NUMBER OF BUFFERS - 1
          STM    NUMBUF      SET THE BUFFER COUNT
 INIBUF1  LJM    INIBF90

 INIBUF2  LDML   1,T4        NUMBER OF LENGTH - ADDRESS PAIRS
          SHN    -3          DIVIDE BY 8
          SBN    1
          STML   NUMBUF
          LOADF  2,T4        SET UP ADDRESS OF THE INDIRECT LIST
          CRML   INDLST+4,TW   READ THE FIRST TWO LENGTH/
*                              ADDRESS PAIRS.  NOTE - CBUFRMA IS EQUATED
*                              TO INDLST+6.  SPACE IS EQUATED TO INDLST+5.
          LDML   2,T4        INITIALIZE BUFLSTPT
          STML   BUFLSTPT    THERE ARE TWO RMA-S IN CORE.  THIS IS THE CM
          LDML   3,T4          ADDRESS OF THE L/A PAIR OF THE SECOND.
          ADN    10B
          STML   BUFLSTPT+1
          SHN    -16
          RAML   BUFLSTPT
          LJM    INIBF90     COMPLETE INITIALIZATION
          EJECT
** NAME - CHGCH
*
** PURPOSE - CHANGE CHANNEL NUMBER IN CHANNEL INSTRUCTIONS
*
** INPUT - (CURCH) = CHANNEL NUMBER.
*          (A) = CHANNEL TABLE ADDRESS.
*
          SPACE  4
 CHGCH    SUBR               ENTRY/EXIT
          STDL   T1          SET ADDRESS MODIFICATION LIST ADDRESS
 CHG10    LDIL   T1          READ LIST WORD
          ZJN    CHGCHX      IF END OF LIST
          STDL   T2          SET INSTRUCTION ADDRESS
          LDIL   T2          READ INSTRUCTION WORD
          SCN    37B         CLEAR CHANNEL BITS
          LMML   CURCH       REPLACE WITH NEW CHANNEL
          STIL   T2
          AODL   T1          INCREMENT TO NEXT INSTRUCTION
          UJN    CHG10       LOOP
          EJECT
 CONCH    BSS
 TTP+40B  HERE
 T40B+TP  HERE
 TTP      HERE
          CON    0

 ESLAVE   EQU    *           END OF SLAVE CODE
          ERRPL  ESLAVE-//EDUALOV  SLAVE HAS OVERFLOWED INTO
*                                  ROUTINES IT MAY USE

          QUAL
          LOC    *O
 ESLAVE   EQU    *
 LSLAVE   EQU    ESLAVE-SLAVE  LENGTH OF THE SLAVE CODE
          ERRPL  ESLAVE-ENDMEM  ERROR IF OVERFLOW PP
          END    TAPE
/EOR

*DECK DECK=TCE$5744_ERROR_MESSAGES EXPAND=FALSE
{ These constants define the condition code subranges for the components of
{ the CARTRIDGE_SYSTEM_VE_5744 interface.

  CONST
     tcc$condition = (($integer('T') * 100(16)) + $integer('C')) * 1000000(16),
     tcc$tc_id = 'TC';

  CONST
      tcc$5744_message_base          = tcc$condition + 000;

{-------------------------------------------------------------------------------
{ Error messages that may be generated by the 5744 library interface components.
{-------------------------------------------------------------------------------

  CONST
    tce$acs_full = tcc$5744_message_base + 1,
    {E 5744 library: ACS +P1 is full.}

    tce$acs_not_in_library = tcc$5744_message_base + 2,
    {E 5744 library: ACS +P1 is not configured.}

    tce$acs_offline = tcc$5744_message_base + 3,
    {I 5744 library: ACS +P1 is off-line.}

    tce$audit_in_progress = tcc$5744_message_base + 8,
    {I 5744 library: Request not processed - audit in library.}

    tce$request_cancelled = tcc$5744_message_base + 9,
    {E 5744 library: Request +P1 has been cancelled.}

    tce$count_too_small = tcc$5744_message_base + 20,
    {E 5744 library: Count too small.}

    tce$count_too_large = tcc$5744_message_base + 21,
    {E 5744 library: Count too large.}

    tce$data_base_error = tcc$5744_message_base + 23,
    {F 5744 library: Database error.}

    tce$drive_is_available = tcc$5744_message_base + 28,
    {I 5744 library: Drive available - +P1.}

    tce$drive_in_use = tcc$5744_message_base + 29,
    {I 5744 library: Drive in use - +P1.}

    tce$drive_not_in_library = tcc$5744_message_base + 30,
    {E Drive not in the 5744 library - +P1.}

    tce$drive_offline = tcc$5744_message_base + 31,
    {I 5744 library: Drive off-line - +P1.}

    tce$invalid_acs = tcc$5744_message_base + 39,
    {E 5744 library: Invalid ACS: +P1.}

    tce$invalid_drive = tcc$5744_message_base + 42,
    {E 5744 library: Invalid drive number - +P1.}

    tce$invalid_lsm = tcc$5744_message_base + 43,
    {E 5744 library: Invalid LSM - +P1.}

    tce$invalid_option = tcc$5744_message_base + 45,
    {E 5744 library: Invalid message_option: +P1.}

    tce$invalid_type = tcc$5744_message_base + 51,
    {E 5744 library: Invalid type: +P1.}

    tce$invalid_volume = tcc$5744_message_base + 53,
    {E 5744 library: Invalid EVSN: +P1.}

    tce$library_busy = tcc$5744_message_base + 55,
    {I Request not processed - 5744 library temporarily busy.}

    tce$library_failure = tcc$5744_message_base + 56,
    {F 5744 library failure.}

    tce$library_not_available = tcc$5744_message_base + 57,
    {F 5744 library is not available.}

    tce$lsm_not_in_library = tcc$5744_message_base + 60,
    {E 5744 library: LSM not configured - +P1.}

    tce$lsm_offline = tcc$5744_message_base + 61,
    {I 5744 library: LSM is off-line - +P1.}

    tce$message_too_large = tcc$5744_message_base + 63,
    {E 5744 library: Message too large.}

    tce$message_too_small = tcc$5744_message_base + 64,
    {E 5744 library: Message too small.}

    tce$misplaced_tape = tcc$5744_message_base + 65,
    {I 5744 library: Misplaced EVSN: +P1.}

    tce$not_in_same_acs = tcc$5744_message_base + 69,
    {E 5744 library: EVSN and drive are not in same ACS - +P1.}

    tce$process_failure = tcc$5744_message_base + 74,
    {E 5744 library process has failed.}

    tce$invalid_cyber_request = tcc$5744_message_base + 83,
    {E 5744 library: Invalid request from CYBER.}

    tce$volume_in_drive = tcc$5744_message_base + 91,
    {I 5744 library: EVSN +P1 is already mounted.}

    tce$volume_not_in_drive = tcc$5744_message_base + 93,
    {I 5744 library: EVSN +P1 is not in the drive.}

    tce$volume_not_in_library = tcc$5744_message_base + 94,
    {I 5744 library: EVSN +P1 is not in the library.}

    tce$unreadable_label = tcc$5744_message_base + 95,
    {E 5744 library: Unreadable external label - EVSN: +P1.}

    tce$unsupported_option = tcc$5744_message_base + 96,
    {E 5744 library: Unsupported message_option: +P1.}

    tce$unsupported_type = tcc$5744_message_base + 98,
    {E 5744 library: Unsupported type: +P1.}

    tce$volume_in_use = tcc$5744_message_base + 99,
    {I 5744 library: Requested EVSN is in use: +P1.}

{-----------------------------------------------------------------------
{   Errors resulting from message data returned by STK library
{   and NOT from the STK status codes.
{-----------------------------------------------------------------------

    tce$bad_dismount_status = tcc$5744_message_base + 200,
    {E 5744 library returned unrecognizable dismount status code: +P1.}

    tce$bad_mount_status = tcc$5744_message_base + 201,
    {E 5744 library returned unrecognizable mount status code: +P1.}

    tce$bad_query_status = tcc$5744_message_base + 202,
    {E 5744 library returned unrecognizable query status code: +P1.}

    tce$bad_query_type_code = tcc$5744_message_base + 203,
    {E 5744 library returned unrecognizable query_type code: +P1.}

{   tce$bad_mount_status_id = tcc$5744_message_base + 204,
    {E 5744 library returned unrecognizable mount status ID code: +P1.}

    tce$bad_volume_status = tcc$5744_message_base + 205,
    {E 5744 library returned unrecognizable volume_status code: +P1.}

    tce$bad_location_code = tcc$5744_message_base + 206,
    {E 5744 library query_volume request returned unrecognizable location_type: +P1.}

    tce$bad_command_code = tcc$5744_message_base + 207,
    {E 5744 library returned unrecognizable command code: +P1.}

    tce$bad_external_vsn = tcc$5744_message_base + 208,
    {E 5744 library returned unrecognizable EVSN +P1.}

{-----------------------------------------------------------------------
{   Internal errors.
{-----------------------------------------------------------------------

    tce$heap_allocate_error = tcc$5744_message_base + 300,
    {F System error - ACS table heap ALLOCATE error.}

    tce$workstation_not_defined = tcc$5744_message_base + 301,
    {F Workstation +P1 for 5744 library has not been defined.}

    tce$acs_table_not_allocated = tcc$5744_message_base + 303,
    {F ACS table is NIL in workstation header.}

    tce$acs_not_found = tcc$5744_message_base + 304,
    {E No entry exists in the 5744 library ACS table for ACS +P1.}

    tce$duplicate_drive = tcc$5744_message_base + 305,
    {E Duplicate drive in the configuration +P1.}

    tce$lsm_not_found = tcc$5744_message_base + 306,
    {E Specified LSM address not present in this ACS - +P1.}

    tce$drive_not_found = tcc$5744_message_base + 307,
    {E No entry exists in the 5744 ACS table for drive - +P1.}

    tce$nil_pointer = tcc$5744_message_base + 308,
    {F NIL pointer to +P1.}

    tce$workstation_not_allocated = tcc$5744_message_base + 309,
    {F 5744 library workstation table has not been allocated.}

    tce$no_drive_list = tcc$5744_message_base + 310,
    {F 5744 library configuration has no drives.}

    tce$invalid_media_request = tcc$5744_message_base + 311,
    {F 5744 library job received invalid media request - code +P1.}

    tce$workstation_timeout = tcc$5744_message_base +312,
    {I 5744 library workstation +P1 not responding.}

    tce$no_stk_drives_defined = tcc$5744_message_base +313,
    {E No 5744 equipment is defined in the system configuration.}

    tce$bad_scl_variable = tcc$5744_message_base +314,
    {I Inappropriate value in 5744 library job SCL script for +P1.}

    tce$server_task_timeout = tcc$5744_message_base +315,
    {I 5744 library server task not initiating.}

    tce$configuration_error = tcc$5744_message_base +316,
    {E 5744 library configuration errors detected.}

    tce$logging_validation_error = tcc$5744_message_base +317,
    {E You are not authorized to access HPA logs.}

    tce$undocumented_server_event = tcc$5744_message_base +318,
    {F Unexpected server event code detected in server task - code +P1.}

    tce$communication_breakdown = tcc$5744_message_base +319,
    {E Communication error - server task is inaccessible.}

    tce$wrong_version = tcc$5744_message_base +320,
    {E Wrong version of the 5744 configuration file opened.}

{-----------------------------------------------------------------------
{   Errors returned by C procedures.
{-----------------------------------------------------------------------

    tce$no_socket_available = tcc$5744_message_base +401,
    {F Could not obtain socket for the RPC client.}

    tce$no_sockets = tcc$5744_message_base +402,
    {F Sockets not installed in the system.}

    tce$invalid_socket = tcc$5744_message_base +403,
    {F System error - invalid socket ID.}

    tce$no_network_space = tcc$5744_message_base +404,
    {F System error - no network space.}

    tce$invalid_protocol = tcc$5744_message_base +405,
    {F System error - invalid protocol.}

    tce$invalid_host_entry = tcc$5744_message_base +406,
    {F Invalid entry (CYBER or workstation) in the HOSTS file.}

    tce$attach_hosts_error = tcc$5744_message_base +407,
    {F Attach HOSTS file error.}

    tce$no_local_host = tcc$5744_message_base +408,
    {F No local host in the HOSTS file.}

    tce$invalid_ip = tcc$5744_message_base +409,
    {F Invalid IP address (CYBER or workstation) in HOSTS file.}

    tce$no_host_entry = tcc$5744_message_base +410,
    {F No entry for workstation in HOSTS file.}

    tce$unrecognized_error_code = tcc$5744_message_base +411,
    {F Unrecognized error code from communication function.}

    tce$fd_bad_file = tcc$5744_message_base +420,
    {E RPC server - bad file number on select.}

    tce$fd_interrupt = tcc$5744_message_base +421,
    {E RPC server - interrupted system call.}

    tce$fd_invalid_argument = tcc$5744_message_base +422,
    {E Server - invalid argument in SELECT call.}

    tce$fd_bad_address = tcc$5744_message_base +423,
    {E Server - bad address in SELECT call.}

    tce$no_program_number = tcc$5744_message_base +440,
    {F No transient program number for RPC server.}

    tce$no_client_create = tcc$5744_message_base +441,
    {E Could not create RPC client function.}

    tce$no_client_send = tcc$5744_message_base +442,
    {E Could not execute RPC client call.}

    tce$bad_request_code = tcc$5744_message_base +443,
    {F Internal error: Bad request code in C function +P1.}

    tce$duplicate_message = tcc$5744_message_base +460,
    {I Duplicate message received from the workstation.}

    tce$bad_xdr_translation = tcc$5744_message_base +461,
    {E XDR translation error - message discarded.}

    tce$part_xdr_trans = tcc$5744_message_base +462,
    {E XDR partial translation error - message discarded.}

    tce$interrupt_xdr_trans = tcc$5744_message_base +463,
    {E Interrupted XDR translation error.}

    tce$no_server_create = tcc$5744_message_base +471,
    {E Could not create RPC server.}

    tce$no_server_register = tcc$5744_message_base +472,
    {E Could not register RPC server.}

    tce$bad_c_status_code = tcc$5744_message_base + 473;
    {F C procedure returned invalid error code: +P1.}
*DECK DECK=TCM$5744_HELP_MODULE EXPAND=TRUE
~"  CREATE_MESSAGE_MODULE  TCM$5744_HELP_MODULE$US_ENGLISH
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=ACS_FULL
                    NOS/VE Tape Action Message

  Status                : 5744 Library ACS is full.
  ACS:                  : ~P1

  Action: Please remove at least 1 cartridge from the named ACS or
          the system will not be able to dismount any currently
          mounted cartridges from the drives in this ACS.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=AUDIT_IN_PROGRESS
                    NOS/VE Tape Action Message

  Status                : Request processing in 5744 Library is being
                          delayed by Library Audit.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=DRIVE_OFFLINE
                    NOS/VE Tape Action Message

  Status                : 5744 Library drive element is offline.
  NOS/VE Element:       : ~P1
  5744 Library Element  : ~P2

  Action: If you VARIED the drive to OFFLINE on the workstation then use
          LCU to change the element's state in the NOS/VE to OFF or DOWN.
          Otherwise VARY the element ONLINE at the workstation console.

~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=LSM_OFFLINE
                    NOS/VE Tape Action Message

  Status                : 5744 Library LSM element is offline.
  5744 Library Element  : ~P1

  Action: VARY the specified LSM to ONLINE at the workstation's console.
          Otherwise use LCU to change the element state in the NOS/VE
          to OFF or DOWN for all of the drives associated with this LSM.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=MISPLACED_CARTRIDGE
                    NOS/VE Tape Action Message

  Status                : Cartridge has been misplaced in 5744 Library.
  Volume                : ~P1

  Action: In order to locate the specified volume in the 5744 Library
          and to correct its data base the AUDIT process should be
          initiated on the workstation. Until this process completes
          the cartridge volume will remain inaccessible.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=MISPLACED_CARTRIDGE_USER_MSG
 Cartridge volume ~P1 has been misplaced in the 5744 library.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=NOT_IN_SAME_ACS
                    NOS/VE Tape Action Message

  Status                : Cartridge has been moved in 5744 Library.
  Volume                : ~P1
  ACS                   : ~P2


  The mount request is being delayed because the specified cartridge
  has been moved by the operator to another ACS.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=UNREADABLE_LABEL
                    NOS/VE Tape Action Message

  Status                : Cartridge has robotically unreadable label.
  Volume                : ~P1

  Action: The external label of the specified cartridge must be repaired.
          The cartridge will be ejected from the library during the next
          AUDIT operation at the workstation. Until AUDIT is performed
          the cartridge will not be accessible for usage.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=UNREADABLE_LABEL_USER_MSG
 Cartridge ~P1 has robotically unreadable external label.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=VOLUME_IN_DRIVE
                    NOS/VE Tape Action Message

  Status                : Cartridge mounted on unconfigured tape drive.
  Volume                : ~P1
  Drive:                : ~P2

  Action: The specified cartridge has been mounted on a tape drive
          which is not configured in this NOS/VE system. This causes
          a delay in processing the pending request in this system
          until the cartridge is dismounted from the drive.
~"**
~"CREATE_PARAMETER_PROMPT_MESSAGE NAME=VOLUME_IN_DRIVE_USER_MSG
 Cartridge ~P1 is mounted on an unconfigured tape drive.
~"**
~"END_MESSAGE_MODULE CREATE_MODULE=YES
*DECK DECK=TCM$5744_MSG_TEMPLATE_MODULE EXPAND=TRUE
?? RIGHT := 110 ??
MODULE tcm$message_template_module;
*copyc tce$5744_error_messages
MODEND tcm$message_template_module;
*DECK DECK=TCM$ENGINEERING_LOG_SUPPORT EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
MODULE tcm$engineering_log_support;

{
{ Purpose: This module allows a caller executing in Ring 6 or below to activate
{ an engineering log and write a statistic to it without requiring the caller
{ to have SOU CA (CONFIGURATION_ADMINISTRATION) privilege.  In addition to
{ running at or below Ring 6, the caller's login family and login user must both
{ be $SYSTEM.
{

?? PUSH (LISTEXT := ON) ??
*copyc jmc$system_family
*copyc osp$set_status_abnormal
*copyc ost$caller_identifier
*copyc ost$user_identification
*copyc rme$robotic_interface_errors
?? POP ??

?? NEWTITLE := 'Global Procedures Referenced by this Module', EJECT ??
*copyc pmp$get_user_identification
*copyc sfp$activate_system_statistic

?? OLDTITLE ??
?? NEWTITLE := ' tcp$activate_hpa_logging', EJECT ??

  PROCEDURE [#GATE, XDCL] tcp$activate_hpa_logging
    (    statistic_code: sft$statistic_code;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      user_id: ost$user_identification;

    #CALLER_ID (caller_id);

    pmp$get_user_identification (user_id, status);

    IF status.normal THEN
      IF (caller_id.ring > osc$sj_ring_3 {ring 6}) OR
            (user_id.family <> jmc$system_family) OR (user_id.user <> jmc$system_user) THEN
        osp$set_status_abnormal (rmc$resource_management_id, rme$invalid_server_response, '', status);
      ELSE
        sfp$activate_system_statistic (statistic_code, $sft$binary_logset[pmc$engineering_log], status);
      IFEND;
    IFEND;

  PROCEND tcp$activate_hpa_logging;
MODEND tcm$engineering_log_support;
*DECK DECK=TCP$ACTIVATE_HPA_LOGGING EXPAND=FALSE

 PROCEDURE [XREF] tcp$activate_hpa_logging
    (    statistic_code: sft$statistic_code;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc sft$statistic_code
?? POP ??
*DECK DECK=TMA$TASK_SWITCH EXPAND=FALSE

.............................begin common deck TMA$TASK_SWITCH.....................
.
.
.. Define offsets for the various fields of tmt$dispatch_control_table.
.
head      equ    0
.
.. Define the shift value for 'multiplying' by ptl_entry size.
ptlshf    equ    5
.. Define offsets for the various fields of tmt$primary_task_list_entry
.
thread    equ    0
xcboff    equ    3
ptl_ijlo  equ    7
.
.. Define offsets for the various fields of jmt$initiated_job_list_entry
.
ijl_ajlo  equ    8*3+4
.
.. Define offsets for the various fields of ost$execution_control_block
.
p_select  equ    8*52+2
t_lpid    equ    8*52+3
.
.. Define offsets for the various fields of jmt$job_control_block
.
tasks     equ    1
j_lpid    equ    2
m_proc    equ    3
.
.............................end common deck TMA$TASK_SWITCH............................
*DECK DECK=TMC$EXECUTION_RING_CONSTANTS EXPAND=FALSE

  {Values for allocating handler execution rings - tmt$handler_execution_ring}

  CONST
    tmc$unallocated = 0,
    tmc$task_monitor2_ring = osc$tmtr_ring,
    tmc$task_services_ring = osc$tsrv_ring,
    tmc$delay_allocation = 0f(16);

  CONST
    tmc$lowest_signal_flag_ring = tmc$task_monitor2_ring,
    tmc$highest_signal_flag_ring = tmc$task_services_ring,
    tmc$highest_recognition_ring = tmc$highest_signal_flag_ring + 1;

*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=TMC$FREE_FLAG_ID EXPAND=FALSE

{ TMDFFID - This comdeck defines the SYSTEM FLAG VALUE for the free flag.

  CONST
    tmc$free_flag_id = 0;
*DECK DECK=TMC$MAINFRAME_LINKED_SIGNALS EXPAND=FALSE
*DECK DECK=TMC$SIGNAL_IDENTIFIERS EXPAND=FALSE
*DECK DECK=TMC$WAIT_TIMES EXPAND=FALSE
CONST
  tmc$infinite_wait = 0ffffffffffff(16);
*DECK DECK=TMD$TASK_MANAGEMENT_EXEPTIONS EXPAND=FALSE
?? NEWTITLE := 'TASK MANAGEMENT : ''OS'' + 7000 .. ''OS'' + 8999', EJECT ??
*copyc TME$MONITOR_MODE_EXCEPTIONS
?? OLDTITLE ??
*DECK DECK=TME$MONITOR_MODE_EXCEPTIONS EXPAND=FALSE
*copyc osc$base_exception
  CONST
    tmc$ = osc$base_exception + 7000;

?? NEWTITLE := 'TASK MGT MTR MODE : ''OS'' + 7000 .. ''OS'' + 7999', EJECT ??
?? FMT (FORMAT := OFF) ??

  CONST
    tme$invalid_global_taskid = tmc$ + 1,
    {F The taskid specified on the call is invalid.}

    tme$ptl_full = tmc$ + 2,
    {F PTL is full on a create task or job request.}

    tme$invalid_active_job_ordinal = tmc$ + 3,
    {F The AJL ordinal specified on the request is invalid.}

    tme$invalid_segment = tmc$ + 4,
    {F The segment number for mapping in the job fixed segment is invalid.}

    tme$job_swapped_out = tmc$ + 5,
    {F The job referenced by the request is swapped out.}

    tme$job_has_terminated = tmc$ + 6,
    {F Attempt to swapout a job that has terminated.}

    tme$mtr_signal_buffers_full = tmc$ + 7,
    {F MTR_SIGNAL_BUFFER was found to be full on trying to send a signal to the job.}

    tme$monitor_fault_buffer_full = tmc$ + 8,
    {F MTR_FAULT_BUFFER was found to be full on trying to send a mtr fault.}

    tme$unexpected_job_status = tmc$ + 9,
    {F The job status was not as expected by the request.}

    tme$insufficient_privilege = tmc$ + 10,
    {F Insufficient privilege specified on the request.}

       tme$system_task_list_error = tmc$ + 11,
       {F The system task list does not match the XCB information.}

       tme$illegal_system_task_exit = tmc$ + 12,
       {F The exiting task had the critical_task flag set.}

    tme$system_task_missing = tmc$ + 13,
    {F Attempt to ready non existing system task.}

    tme$task_already_system_task = tmc$ + 14,
    {F Duplicate request to become system task.}

    tme$duplicate_system_task = tmc$ + 15,
    {F Another task with this id is already present.}

    tme$invalid_system_task = tmc$ + 16;
    {F Attempt to set system task id of task not within the system job.}

?? FMT (FORMAT := ON) ??
?? OLDTITLE ??
*DECK DECK=TMH$ALLOCATE_EXECUTION_RINGS EXPAND=FALSE
{ }
{   The purpose of this request is to allocate an execution ring to a   }
{ signal or system flag (execution control block executions rings) and  }
{ in turn to the appropriate handler.                                   }
{ }
{       TMP$ALLOCATE_EXECUTION_RINGS (PREEMPTED_RING, PREEMPTED_REASON, }
{          PREEMPTIVE_TYPE, ALLOCATES_EXECUTION_RINGS)                  }
{ }
{ PREEMPTED_RING: (input) This parameter specifies the ring that was    }
{       preempted.                                                      }
{ }
{ PREEMPTED_REASON: (input) This parameter specifies the reason that    }
{       task execution was preempted.                                   }
{ }
{ PREEMPTIVE_TYPE: (input) This parameter specifies the preemptive type }
{       (signal or system flag).                                        }
{ }
{ ALLOCATED_EXECUTION_RINGS: (output) This parameter specifies the      }
{       rings that are currently allocated to signals or flags.         }
{ }
*DECK DECK=TMH$CAUSE_TASK_SWITCH EXPAND=FALSE
{
{   The purpose of this request is to cause a task switch from the
{ currently executing task to another task. This request is intended to be used
{ when resources required to process the job mode request are temporarily unavailable and
{ control should be given to another task. This request should NOT be used if
{ the required resources are not expected to be available quickly. This request
{ is NOT to be used for long term waits.
{
{        tmp$cause_task_switch;
{
*DECK DECK=TMH$CHECK_TASKID EXPAND=FALSE

{
{  The purpose of this procedure is to check for a valid taskid.
{  Depending on the option selected, this module either halts the
{  system or returns the status in case an error condition is
{  encountered.
{  The callers of this procedure DO NOT set the ptl lock.  This
{  procedure should be used by callers outside of the 'TM' decks.
{  'TM' callers should use TMP$CHECK_TASKID_WITH_LOCK_SET.
{
{    TMP$CHECK_TASKID (TASKID, OPTION, STATUS)
{
{  TASKID: (INPUT) This parameter specifies the taskid.
{
{  OPTION: (INPUT) This parameter specifies the option to
{                  halt the system or to return an error status.
{
{  STATUS: (OUTPUT) This parameter specifies the error status.
{
*DECK DECK=TMH$CHECK_TASKID_WITH_LOCK_SET EXPAND=FALSE
{
{  The purpose of this procedure is to check for a valid taskid.
{  Depending on the option selected, this module either halts the
{  system or returns the status in case an error condition is
{  encountered.
{  The callers of this procedure MUST set the ptl lock.  Callers
{  outside of the 'TM' decks should use TMP$CHECK_TASKID, which
{  does the ptl lock management.
{
{    TMP$CHECK_TASKID_WITH_LOCK_SET (TASKID, OPTION, STATUS)
{
{  TASKID: (INPUT) This parameter specifies the taskid.
{
{  OPTION: (INPUT) This parameter specifies the option to
{                  halt the system or to return an error status.
{
{  STATUS: (OUTPUT) This parameter specifies the error status.
{
*DECK DECK=TMH$CLEAR_SYSTEM_FLAG EXPAND=FALSE
{
{   The purpose of this request is to clear the system flag specified
{ by flag_id.
{
{       TMP$CLEAR_SYSTEM_FLAG (FLAG_ID, FLAG_STATUS)
{
{ FLAG_ID: (input) This parameter specifies the flag to be cleared.
{
{ FLAG_STATUS: (output) This parameter specifies the outcome of the request.
{
*DECK DECK=TMH$CLEAR_WAIT_INHIBITED EXPAND=FALSE

{
{   The purpose of this request is to return and clear the wait inhibited flag.
{
{       TMP$CLEAR_WAIT_INHIBITED (WAIT_INHIBITED)
{
{ WAIT_INHIBTED: (output) This parameter specifies the setting of the flag
{       prior to its being cleared.
{
*DECK DECK=TMH$CREATE_JOB EXPAND=FALSE

{
{  This procedure is used to schedule a newly created job monitor
{  task.  A PTL entry is assigned to the job monitor task and it
{  is inserted in the DCT chain.  The segment table entry for the
{  new job's JFS is deleted from the address space of the current
{  task that initiated this job.  Execution of the new job may
{  actually begin before the requesting task continues execution.
{
{    TMP$CREATE_JOB (RB)
{
{  RB : (INPUT,OUTPUT) This parameter specifies the request block.
{
*DECK DECK=TMH$CREATE_TASK EXPAND=FALSE

{
{  This procedure is used to schedule a newly created task.
{  A PTL entry is assigned to the task and it is inserted
{  in the DCT chain.  The PTL entry is also linked to the
{  AJL thread for this job.
{
{    TMP$CREATE_TASK (RB)
{
{  RB : (INPUT,OUTPUT) This parameter specifies the request block.
{
*DECK DECK=TMH$CYCLE EXPAND=FALSE

{
{  The purpose of this procedure is to cause a task switch to
{  occur.  The CYCLE request is issued by the currently executing
{  task.
{
{    TMP$CYCLE
{
*DECK DECK=TMH$DCT_READY_TASK EXPAND=FALSE

{ PURPOSE:
{   The purpose of this procedure is to pre-select a CPU for a ready task
{   to execute on, or place the ready task into the dispatch_control_table (DCT).
{
{ DESIGN:
{   Integer representation of dispatching priorities:
{     To accommodate dispatching allocation (guaranteeing minimum and maximum
{     percentages of the total CPU time to specified user dispatching priorities),
{     each dispatching priority falls into one of three sets.  The sets are defined
{     in one word of memory in the following order:
{
{     BYTE:    63...............................................................0
{     PRIORITY:                  15    ..      0 15     ..      0 15    ..      0
{               _________________________________________________________________
{              |                |               |                |               |
{              |________________|_______________|________________|_______________|
{                                     SET 3            SET 2           SET 1
{
{     SET 1:  Tasks of priorities in this set have exceeded their maximum dispatching
{             priority allocation.
{     SET 2:  Tasks of priorities in this set have achieved their minimum dispatching
{             priority allocation, but have not exceeded their maximum allocation.
{     SET 3:  Tasks of priorities in this set have not yet achieved their minimum
{             dispatching allocation.
{
{     When the word containing the dispatching priority sets is normalized and
{     converted to an integer, any SET 3 task has a higher dispatching priority integer
{     than any SET 2 task, which in turn has a higher dispatching priority integer
{     than any SET 1 task.  Thus, a SET 3-P4 task has a higher dispatching priority
{     integer than a SET 2-P8 task.
{
{     NOTE:  Sub-system and system priorities (P9..P14) are always placed in SET 3, so
{            they will always have a higher dispatching priority integer value than
{            any user dispatching priority.
{
{   Task pre-selection or placement in the DCT:
{     Task pre-selection will be attempted only if the job with the ready task allows
{     multiprocessing or has no other tasks currently executing.  If the ready task
{     is going through task_switch and is still ready (its time slice has expired),
{     pre-selection will be attempted only if the job allows multiprocessing or has
{     no other ready tasks.  (This prevents a non-multiprocessing job with a CPU bound
{     task from shutting out other tasks of the job.)
{
{     The ready task will be pre-selected to run on the first idle CPU that is found,
{     or on the the lowest dispatching priority (integer) CPU currently executing, if
{     the ready task has a higher dispatching priority integer.  If the CPU that is
{     pre-selected is currently executing another task, that CPU will be interrupted.
{
{     If the ready task cannot be pre-selected to execute on a CPU, the task is inserted
{     into the DCT.
{
{   The dispatch_control_table (DCT):
{     The DCT is an array of singularly linked lists. There is a list for each
{     dispatching priority.  There are four different pointers into each list:
{     the head pointer, the tail pointer, the minor priority pointer, and the
{     major priority pointer.
{
{     Each job class has a major and a minor timeslice. The major and minor
{     timeslice of a job class can be modified by using the change_class_attribute
{     command. When a task is initially dispatched, it is placed after the minor
{     priority pointer in the DCT. "Ready tasks" are placed after the minor
{     priority pointer as long as the minor timeslice in the tasks XCB is greater
{     than one_eighth of the job class minor timeslice. Both the minor and the
{     major timeslice in the XCB of a task are decremented by the amount of time that
{     the task uses the CPU. Once the minor timeslice in the XCB is zero, the task
{     is placed after the major priority pointer in the dispatch control table.
{     The minor timeslice in the XCB is also reset. When a task finally uses all
{     of its major timeslice, it is next dispatched at the tail of the DCT. Both
{     the major and minor timeslice in the XCB are then reset.
{
{     |----------|
{     |   HEAD   | ------------->  TASK
{     |----------|                 TASK          Example of a DCT with five
{     |  MINOR   | ------------->  TASK          tasks waiting to be dispatched.
{     |----------|
{     |  MAJOR   | ------------->  TASK
{     |----------|
{     |   TAIL   | ------------->  TASK
{     |----------|

*DECK DECK=TMH$DELAY EXPAND=FALSE

{
{  The purpose of this procedure is to suspend execution of the
{  requesting task until the time specified by the task.  The
{  DELAY request is issued by the currently executing task.
{
{    TMP$DELAY (RB)
{
{  RB : (INPUT,OUTPUT) This parameter specifies the request block.
{
{  TYPE
{    TMT$RB_DELAY = RECORD
{      REQCODE,
{      STATUS,
{      REQUESTED_WAIT_TIME,
{      EXPECTED_WAIT_TIME,
{    RECEND;
{
{  REQCODE: (input) The value of this parameter is SYC$RC_DELAY.
{  STATUS: (output) This parameter specifies the system status.
{  REQUESTED_WAIT_TIME: (input) This parameter specifies the requested
{          wakeup time for this task.
{  EXPECTED_WAIT_TIME: (input) This parameter specifies the expected
{          wakeup time for this task.
{
*DECK DECK=TMH$DEQUEUE_TASK EXPAND=FALSE

{  The purpose of this procedure is to delink the task at the
{  head of the task queue.
{
{    TMP$DEQUEUE_TASK (QUEUE_LINK, TASKID)
{
{  QUEUE_LINK : (INPUT,OUTPUT) This parameter specifies the head
{                              of the task queue.
{
{  TASKID : (OUTPUT) This parameter specifies the taskid of the
{                    delinked task.
{
*DECK DECK=TMH$DISABLE_PREEMPTIVE_COMMO EXPAND=FALSE

{   The purpose is to disable the receipt of signals and system flags, and
{ to ensure that all signals and system flags are processed before a task
{ terminates.
{
{       TMP$DISABLE_PREEMPTIVE_COMMO
{
*DECK DECK=TMH$DISPOSE_MAINFRAME_SIGNALS EXPAND=FALSE

{
{   The purpose of this system flag handler is to dispose of mainframe
{ linked signals (i.e., link the signals to the task local signal list and
{ call tmp$dispose_preemptive_commo to process the task local signals).
{
{       TMP$DISPOSE_MAINFRAME_SIGNALS (FLAG_ID)
{
{ FLAG_ID: (input) This parameter specifies the system flag.
{
*DECK DECK=TMH$DISPOSE_OF_BROKEN_TASK EXPAND=FALSE

{
{    The purpose of this procedure is to dispose of the broken task monitor
{ fault.
{
{       TMP$DISPOSE_OF_BROKEN_TASK (FAULT, SFSA)
{
{ FAULT: (input) This parameter specifies the broken task monitor fault.
{
{ SFSA: (input): This parameter specifies the stack frame save area which is
{       most closely related to the broken task fault.
{
*DECK DECK=TMH$DISPOSE_OF_INSERTED_PREEMPT EXPAND=FALSE

{ }
{   The purpose of this request (the procedure is not called it is      }
{ returned to) is to dispose of any signals or system flags which may   }
{ have been delayed.                                                    }
{ }
{       TMP$DISPOSE_OF_INSERTED_PREEMPT                                 }
{ }
*DECK DECK=TMH$DISPOSE_OF_MONITOR_FAULTS EXPAND=FALSE

{ }
{   The purpose of this procedure is to dispose of faults reported by   }
{ monitor mode software, via the monitor fault buffer, which would      }
{ prohibit task execution in the absence of corrective action by the    }
{ task.                                                                 }
{ }
{       TMP$DISPOSE_OF_MONITOR_FAULTS (SFSA)                            }
{ }
{ SFSA: (input) This parameter specifies the Stack Frame Save Area which}
{       gave rise to the fault.                                         }
{ }
*DECK DECK=TMH$DISPOSE_OF_RING2_FLAGS EXPAND=FALSE
{ }
{   The purpose of this request is route all system flags whose         }
{ execution ring is 2 to the appropriate system flag handler.           }
{ }
{       TMP$DISPOSE_OF_RING2_FLAGS                                      }
{ }
*DECK DECK=TMH$DISPOSE_OF_RING2_SIGNALS EXPAND=FALSE
{ }
{   The purpose of this request is route all signals whose execution    }
{ ring is 2 to the appropriate signal handler.                          }
{ }
{       TMP$DISPOSE_OF_RING2_SIGNALS                                    }
{ }
{ }
*DECK DECK=TMH$DISPOSE_OF_RING3_FLAGS EXPAND=FALSE
{ }
{   The purpose of this request is route all system flags whose         }
{ execution ring is 3 to the appropriate system flag handler.           }
{ }
{       TMP$DISPOSE_OF_RING3_FLAGS                                      }
{ }
*DECK DECK=TMH$DISPOSE_OF_RING3_SIGNALS EXPAND=FALSE
{ }
{   The purpose of this request is route all signals whose execution    }
{ ring is 3 to the appropriate signal handler.                          }
{ }
{       TMP$DISPOSE_OF_RING3_SIGNALS                                    }
{ }
{ }
*DECK DECK=TMH$DISPOSE_OF_SIGNALS_FLAGS EXPAND=TRUE
{
{    The purpose of this request is to cause signals and flags to be disposed
{ of as though pmp$wait or pmp$long_term_wait were called, without actually
{ going into wait.
{
{       TMP$DISPOSE_OF_SIGNALS_FLAGS (PREEMPTIVE_REASON);
{
{ PREEMPTIVE_REASON: (input)  This indicates the type of signal and flag
{       preemption that is desired.  The valid values are TMC$WAIT and
{       TMC$LONG_TERM_WAIT.  TMC$WAIT will allow any preemptive signals and
{       flags that interrupt PMP$WAIT to be disposed of.  TMC$LONG_TERM_WAIT
{       will allow any preemptive signals and flags that interrupt
{       PMP$LONG_TERM_WAIT to be disposed of.  If any other preemptive value is
{       supplied this request does nothing.
*DECK DECK=TMH$DISPOSE_PREEMPTIVE_COMMO EXPAND=FALSE
{ }
{   The purpose of this request is route (dispose of) signals and system}
{ flags to their appropriate handler.                                   }
{ }
{       TMP$DISPOSE_PREEMPTIVE_COMMO (PREEMPTED_REASON)                 }
{ }
{ PREEPMTED_REASON: (input) This parameter specifies the reason that    }
{       task execution was preempted.                                   }
{ }
*DECK DECK=TMH$DISPOSE_SYSTEM_REQ_FAULT EXPAND=FALSE

{
{    The purpose of this procedure is to dispose of the system request monitor
{ fault.
{
{       TMP$DISPOSE_SYSTEM_REQ_FAULT (FAULT, SFSA)
{
{ FAULT: (input) This parameter specifies the system request monitor fault.
{
{ SFSA: (input): This parameter specifies the stack frame save area which
{       caused the system request fault.
{
*DECK DECK=TMH$ENABLE_PREEMPTIVE EXPAND=FALSE

{   The purpose of this request is to physically enable communication, signals,
{ system flags, and monitor faults, from monitor to the requesting task.
{
{   CAUTION: This request must not be issued prior to establishing the
{            task private segment.  Any non-stackable monitor fault or UCR
{            condition occuring before this request is issued will result
{            in a broken task.
{
{       TMP$ENABLE_PREEMPTIVE
{
*DECK DECK=TMH$ENABLE_PREEMPTIVE_COMMO EXPAND=FALSE

{   The purpose of this request is to enable communication, signals, system
{ flags, and monitor faults, from monitor to the requesting task.
{
{   CAUTION: This request must not be issued prior to establishing the
{            task private segment.  Any non-stackable monitor fault or UCR
{            condition occuring before this request is issued will result
{            in a broken task.
{
{       TMP$ENABLE_PREEMPTIVE_COMMO
{
*DECK DECK=TMH$EXIT_JOB EXPAND=FALSE

{
{  The purpose of this procedure is to exit a job monitor task.
{  The PTL entry for the job monitor task is deleted and the job
{  status in the ajl entry is set to terminated.
{
{    TMP$EXIT_JOB (RB)
{
{  RB : (INPUT,OUTPUT) This parameter specifies the request block.
{
*DECK DECK=TMH$EXIT_TASK EXPAND=FALSE

{
{  The purpose of this procedure is to exit a task.  The PTL
{  entry for the task is deleted and the caller of the task
{  is informed of callee termination.
{
{    TMP$EXIT_TASK (RB)
{
{  RB : (INPUT,OUTPUT) This parameter specifies the request block.
{
*DECK DECK=TMH$FETCH_JOB_STATISTICS EXPAND=FALSE
{
{  The purpose of this procedure is to return the job statistics for
{  the currently executing job.  The AJL is searched for an entry with
{  the JOB MTR TASKID matching the value in the JCB.
{
{    TMP$FETCH_JOB_STATISTICS (STATISTICS, STATUS)
{
{  STATISTICS: (OUTPUT) This parameter contains the job statistics.
{
{  STATUS: (OUTPUT) This parameter specifies the request status.
{
*DECK DECK=TMH$FETCH_TASK_STATISTICS EXPAND=FALSE

{
{  The purpose of this request is to return task statistics.
{  Currently this request returns the MONITOR MODE time
{  and the JOB MODE time for the task.
{
{     TMP$FETCH_TASK_STATISTICS (RB, CST_P)
{
{  RB: (INPUT,OUTPUT) This parameter specifies the request block.
{
{  CST_P: (INPUT) This parameter specifies the pointer to the CST.
{
*DECK DECK=TMH$FIND_FLAG_TO_PROCESS EXPAND=FALSE
{
{   The purpose of this request is to find a system flag to be processed
{ in the ring of the caller.
{
{       TMP$FIND_FLAG_TO_PROCESS (FLAG_FOUND, FLAG_ID, FLAG_HANDLER)
{
{ FLAG_FOUND: (output): This parameter specifies whether there is a flag to
{       process.
{
{ FLAG_ID: (output) This parameter specifies the flag to be processed.
{
{ FLAG_HANDLER: (output) This parameter specifies the handler corres -
{       ponding to flag_id.
{
*DECK DECK=TMH$FIND_MAINFRAME_SIGNAL EXPAND=FALSE
{ }
{   The purpose of this request is to obtain a signal from the mainframe
{ signal list.
{
{       TMP$FIND_MAINFRAME_SIGNAL (GTID, SIGNAL_FOUND, SIGNAL)
{
{ GTID: (input) This parameter specifies the global task id of the
{       owner of the signal to be found.
{
{ SIGNAL_FOUND: (output) This parameter specifies whether a signal
{       was found in the mainframe signal list.
{
{ SIGNAL: (output) This parameter specifies the returned signal.
{
*DECK DECK=TMH$FIND_MONITOR_FAULT EXPAND=FALSE

{
{   The purpose of this request is to find a monitor fault and handler
{ which corresponds to trapped stack frame save area.
{
{       TMP$FIND_MONITOR_FAULT (TRAPPED_SFSA, FAULT, FAULT_FOUND,
{         MONITOR_FAULT_HANDLER)
{
{ TRAPPED_SFSA: (input) This parameter specifies the trapped stack frame
{       save area for which the monitor fault is desired.
{
{ FAULT: (output) This parameter specifies the monitor fault.
{
{ FAULT_FOUND: (output) This parameter specifies whether a fault and
{       its handler was returned.
{
{ MONITOR_FAULT_HANDLER: (output) This parameter specifies the monitor
{       fault handler corresponding to the monitor fault.
{
*DECK DECK=TMH$FIND_RING_CROSSING_FRAME EXPAND=FALSE
{ }
{   The purpose of this request is to find the stack frame that will    }
{ return to a higher ring (i.e., the stack frame at the bottom of the   }
{ stack specified by starting frame).                                   }
{ }
{       TMP$FIND_RING_CROSSING_FRAME (STARTING_FRAME, FRAME, STATUS)    }
{ }
{ STARTING_FRAME: (input) This parameter specifies the frame at which   }
{       begin the search.  If the starting frame is NIL the search will }
{       begin with the caller's stack frame, otherwise, the search will }
{       begin with starting_frame.                                      }
{ }
{ FRAME: (output) This parameter specifies the stack frame at the bottom}
{       of the caller's stack.                                          }
{       NOTE: tmp$find_ring_crossing will always return a valid address }
{             in the frame parameter.                                   }
{ }
{ STATUS: (output) This parameter specifies the status of the request - }
{       stack frames are validated as the stack is searched; invalid    }
{       frames will cause abnormal status.                              }
{ }
*DECK DECK=TMH$FIND_SIGNAL EXPAND=FALSE
{ }
{   The purpose of this request is to obtain a signal and its handler
{ which corresponds to the caller's ring.
{
{       TMP$FIND_SIGNAL (SIGNAL_FOUND, SIGNAL, SIGNAL_HANDLER)
{
{ SIGNAL_FOUND: (output) This parameter specifies whether a signal
{       was present for the specified execution ring.
{
{ SIGNAL: (output) This parameter specifies the returned signal.
{
{ SIGNAL_HANDLER: (output) This parameter specifies the handler for
{       the signal.
{
*DECK DECK=TMH$FIND_XCB EXPAND=FALSE

{
{  The purpose of this request is to get the pointer to the execution control
{  block of a specified task.  If the job is swapped but IO has not been initiated
{  an ajl entry is assigned to allow access to the xcb.  Otherwise an
{  error is returned.
{
{    TMP$FIND_XCB (TASKID, XCB_P, IJLE_P, STATUS)
{
{  TASKID : (INPUT) This parameter specifies the taskid of the
{                   selected task.
{
{  XCB_P : (OUTPUT) This parameter specifies the pointer to the
{                   execution control block.
{
{  IJLE_P : (OUTPUT) This parameter specifies the pointer to the
{                    initiated job list entry.
{
{  STATUS : (OUTPUT) This parameter specifies the request status.
{
{  NOTE : This procedure will lock the ajl entry of the job if xcb access is
{         possible.  It is the callers responsibility to unlock the ajl with
{         a call to jmp$free_ajl_entry.
*DECK DECK=TMH$FLAG_ALL_TASKS EXPAND=FALSE
{
{   The purpose of this request is to set a system flag in the XCB of every task
{ in the system.  System flags can be set in the XCB of any valid task including
{ tasks currently swapped out. If the specified task is swapped out, swapin
{ will be initiated by this request.
{
{        TMP$FLAG_ALL_TASKS (FLAG_ID, STATUS)
{
{ FLAG_ID: (input) This parameter specifies the flag id to be set.
{
{ STATUS: (output) This parameter specifies the request status.
{
*DECK DECK=TMH$GET_JOB_FIXED_SEGMENT EXPAND=FALSE

{
{  The purpose of this procedure is to get the job fixed segment
{  mapped into the address space of the terminator.  The segment
{  is deleted from the address space of the monitor.
{
{    TMP$GET_JOB_FIXED_SEGMENT (RB)
{
{  RB : (INPUT,OUTPUT) This parameter specifies the request block.
{
*DECK DECK=TMH$GET_MONITOR_FAULT EXPAND=FALSE
{
{   The purpose of this request is obtain the monitor fault specified by
{ fault_index.
{
{       TMP$GET_MONITOR_FAULT (FAULT_INDEX, FAULT, FAULT_STATUS)
{
{ FAULT_INDEX: (input) This parameter specifies the monitor fault to be obtained.
{
{ FAULT: (output) This parameter specifies the returned monitor fault.
{
{ FAULT_STATUS: (output) This parameter specifies the outcome of the request.
{
*DECK DECK=TMH$GET_SIGNAL EXPAND=FALSE
{
{   The purpose of this request is obtain the signal specified by
{ buffer_index.
{
{       TMP$GET_SIGNAL (BUFFER_INDEX, SIGNAL, SIGNAL_STATUS)
{
{ BUFFER_INDEX: (input) This parameter specifies the signal to be obtained.
{
{ SIGNAL: (output) This parameter specifies the returned signal.
{
{ SIGNAL_STATUS: (output) This parameter specifies the outcome of the request.
{
*DECK DECK=TMH$GET_XCB_P EXPAND=FALSE
{
{   The purpose of this request is to get a pointer to the XCB of the task
{ specified by a global task id (GTID). If the GTID is invalid, the system is halted
{ with an 'taskid error'. If the taskid is valid but the task is swapped out,
{ a NIL pointer is returned.  A pointer to the initiated job list entry is also
{ returned.
{
{        tmp$get_xcb_p (taskid, xcb_p, ijle_p);
{
{ TASKID: (input) This parameter specifies the GTID of the task to be located.
{
{ XCB_P: (output) This parameter contains a pointer to the XCB of the specified
{         task. If the task is swapped out, a NIL pointer is returned.
{
{ IJLE_P: (output) This parameter contains a pointer to the initiated job list
{         entry of the job.
*DECK DECK=TMH$INITIALIZ_HANDLER_X_BRACKET EXPAND=FALSE

{ }
{   The purpose of this procedure is to initialize the execution bracket}
{ of the specified handler description.                                 }
{ }
{       TMP$INITIALIZ_HANDLER_X_BRACKET (HANDLER_DESCRIPTION)           }
{ }
{ HANDLER_DESCRIPTION: (output) This parameter specifies the handler    }
{       description whose execution bracket is to be initialized.       }
{ }
*DECK DECK=TMH$MTR_READY_TASK EXPAND=FALSE

{
{  The purpose of this procedure is to process the job mode
{  request to change the status of a specified task to ready
{  and to set the WAIT INHIBITED flag in the task's PTL entry.
{
{    TMP$MTR_READY_TASK (RB)
{
{  RB : (INPUT,OUTPUT) This parameter specifies the request block.
{
*DECK DECK=TMH$MTR_SEND_SIGNAL EXPAND=FALSE

{
{  The purpose of this procedure is to process the job mode
{  request to send signals to a specified task's XCB.
{
{    TMP$MTR_SEND_SIGNAL (RB)
{
{  RB : (INPUT,OUTPUT) This parameter specifies the request block.
{
{  TYPE
{    TMT$RB_SEND_SIGNAL = RECORD
{      REQCODE,
{      STATUS,
{      TASK_ID,
{      SIGNAL,
{    RECEND;
{
{  REQCODE: (input) The value of this parameter is SYC$RC_SEND_SIGNAL.
{  STATUS: (output) This parameter specifies standard system status.
{  TASK_ID: (input) This parameter specifies the task in whose XCB the
{         signal is to be placed.
{  SIGNAL: (input) This parameter specifies the signal block.
{
*DECK DECK=TMH$MTR_SET_SYSTEM_FLAG EXPAND=FALSE

{
{  The purpose of this procedure is to process the job mode
{  request to set the specified system flag in the specified
{  task's PTL entry.
{
{    TMP$MTR_SET_SYSTEM_FLAG (RB)
{
{  RB : (INPUT,OUTPUT) This parameter specifies the request block.
{
*DECK DECK=TMH$MTR_WAIT EXPAND=FALSE

{
{  The purpose of this procedure is to process the job mode
{  request to suspend execution of the current task until the
{  specified time has expired or an event has occured.  However
{  execution of the task is not suspended if the WAIT INHIBITED
{  flag is set in the XCB.
{
{    TMP$MTR_WAIT (RB)
{
{  RB : (INPUT,OUTPUT) This parameter specifies the request block.
{
{  TYPE
{    TMT$RB_WAIT_SIGNAL = RECORD
{      REQCODE,
{      STATUS,
{      REQUESTED_WAIT_TIME,
{      EXPECTED_WAIT_TIME,
{    RECEND;
{
{  REQCODE: (input) The value of this parameter is SYC$RC_WAIT.
{  STATUS: (output) This parameter specifies the standard monitor status.
{  REQUESTED_WAIT_TIME: (input) This parameter specifies the maximum amount
{      of time to wait before resuming execution.
{  EXPECTED_WAIT_TIME: (input) This parameter specifies the expected amount
{      of time to wait before resuming execution.
{
*DECK DECK=TMH$POST_MAINFRAME_SIGNAL EXPAND=FALSE
{
{   The purpose of this request is to post a signal that could not be
{ sent to the recipient because the recipient was rolled-out or the
{ signal buffer was full.
{
{       TMP$POST_MAINFRAME_SIGNAL (RECIPIENT, SIGNAL, STATUS)
{
{ RECIPIENT: (input) This parameter specifies the recipient task.
{
{ SIGNAL: (input) This parameter specifies the signal to be posted.
{
{ STATUS: This parameter specifies the request status.
{       CONDITION: ose$mainframe_pageable_full.
{       IDENTIFIER: pmc$program_management_id.
{
{
*DECK DECK=TMH$POST_MONITOR_FAULT_SFSA EXPAND=FALSE

{   The purpose of this request is to record the stack frame save area address
{ to be associated with a monitor fault.
{
{       TMP$POST_MONITOR_FAULT_SFSA (SFSA)
{
{ SFSA: (input) This parameter specifies the stack frame save area to be
{       associated with monitor faults causing this trap.
{
*DECK DECK=TMH$PROCESS_BROKEN_TASK EXPAND=FALSE
{
{   The purpose of this procedure is to terminate a task that is determined
{ to be broken during monitor processing.  The task is fixed such that it
{ can process traps and a monitor fault sent to the task to inform it of
{ its condition.
{
{       TMP$PROCESS_BROKEN_TASK (TASK_ID, BROKEN_TASK_CONDITION, STATUS)
{
{ TASK_ID (input) This parameter is the global task id of the broken task.
{
{ BROKEN_TASK_CONDITION (input) This parameter is a code indicating why the
{       task is considered broken.
{
{ STATUS (output) This parameter is the normal monitor status.
{
*DECK DECK=TMH$PROCESS_TASK_MCR_FAULT EXPAND=FALSE
{
{   The purpose of this procedure is to return processing back to job mode
{ for MCR faults selected by the task to process.
{
{        TMP$PROCESS_TASK_MCR_FAULT;
{
{   No parameter list is passed to this procedure, information obtained
{ from currently active task.
{
*DECK DECK=TMH$PROCESS_UNKNOWN_REQ_FAULT EXPAND=FALSE
{
{  This procedure is called by the monitor to process an unknown
{  system request fault issued by the current task.
{
{    TMP$PROCESS_UNKNOWN_REQ_FAULT
{
*DECK DECK=TMH$QUEUE_TASK EXPAND=FALSE

{
{  The purpose of this request is to add a task to the
{  end of a task queue.
{
{    TMP$QUEUE_TASK (TASKID, QUEUE_LINK)
{
{  TASKID : (INPUT) This parameter specifies the taskid of
{                   the task to be placed in the queue.
{
{  QUEUE_LINK : (INPUT) This parameter specifies the head of
{                       the task queue.
{
*DECK DECK=TMH$REISSUE_MONITOR_REQUEST EXPAND=FALSE
{
{   The purpose of this request is to cause the P register of the current task to
{ be decremented by 2. This wil cause the monitor request issued by the task
{ to be reissued when the task is next executed. This request does NOT change
{ the status of the task or cause a task-switch. This request is intended
{ to be used when the resources required to process the current request from the
{ task are unavailable.
{
{        tmp$reissue_monitor_request;
{
*DECK DECK=TMH$SEND_SIGNAL EXPAND=FALSE

{
{   The purpose of this procedure is to place the signal in the
{ specified task's XCB.  This procedure is callable only internal
{ to monitor.
{
{       TMP$SEND_SIGNAL (TASKID, SIGNAL, STATUS)
{
{ TASKID: (input) This parameter specifies the task in whose XCB
{       the signal is to be placed.
{
{ SIGNAL: (input) This parameter specifies the signal block.
{
{ STATUS: (output) This parameter is the standard monitor status.
{
*DECK DECK=TMH$SET_FLAG_INTERVAL EXPAND=FALSE

{
{  The purpose of this procedure is to set the interval in the JCB
{  at which a flag is to be sent to the job monitor of the current
{  job to invoke the statistics facility to collect job statistics.
{
{    TMP$SET_FLAG_INTERVAL (INTERVAL)
{
{  INTERVAL : (INPUT) This parameter specifies the cptime interval
{                     at which the flag is to be sent.
{
*DECK DECK=TMH$SET_SYSTEM_FLAG EXPAND=FALSE
{
{   The purpose of this request is to set a system flag in the XCB of the task
{ specified. System flags can be set in the XCB of any valid task including
{ tasks currently swapped out. If the specified task is swapped out, swapin
{ will be initiated by this request.
{
{        TMP$SET_SYSTEM_FLAG (TASKID, FLAGID, STATUS)
{
{ TASKID: (input) This parameter specifies the taskid of the task to receive the
{         flag.
{
{ FLAGID: (input) This parameter specifies the flag id to be set.
{
{ STATUS: (output) This parameter specifies the request status.
{
{
*DECK DECK=TMH$SET_TASK_READY EXPAND=FALSE

{
{  The purpose of this procedure is to make a task ready either
{  conditionally or unconditionally.  A task can be conditionally
{  made ready if it is currently in a wait status and can be
{  unconditionally made ready irrespective of it's current status.
{  The WAIT INHIBITED flag in the PTL is set if it is specified
{  on the request.
{
{    TMP$SET_TASK_READY (TASKID, READY_CONDITION)
{
{  TASKID : (INPUT) This parameter specifies the task to be made ready.
{
{  READYING_TASK_PRIORITY : (INPUT) This parameter specifies the
{                          priority of the task which has issued the
{                          request to ready this task. This value is only used
{                          if the task being readied has subsystem locks set.
{
{  READY_CONDITION : (INPUT) This parameter specifies if the task
{                            is to be made ready conditionally or
{                            unconditionally.
{
*DECK DECK=TMH$SET_TASK_READY_UNCOND EXPAND=FALSE

{  The purpose of this procedure is to unconditionally ready the
{  specified task. The task to be readied must be in the task
{  status specified on this request.
{
{    TMP$READY_TASK_UNCONDITIONAL (TASKID, TASKSTATUS)
{
{  TASKID : (OUTPUT) This parameter specifies the taskid of the
{              task to be readied.
{
{  TASKSTATUS: (INPUT) This parameter specifies the current status
{      of the task.
*DECK DECK=TMH$SET_TASK_WAIT EXPAND=FALSE

{  The purpose of this procedure is to change the status
{  of the current task to a specified WAIT status.
{
{    TMP$SET_TASK_WAIT (TASK_STATUS)
{
{  TASK_STATUS : (INPUT) This parameter specifies the new task
{                        status.
{
*DECK DECK=TMH$SWAPIN_JOB EXPAND=FALSE

{
{  The purpose of this request is to swapin a job that had
{  earlier been swapped out.  The swapped flag in all the
{  PTL entries belonging to the job is cleared and the job
{  is made a candidate for execution.
{
{    TMP$SWAPIN_JOB (RB)
{
{  RB : (INPUT,OUTPUT) This parameter specifies the request block.
{
*DECK DECK=TMH$SWAPOUT_JOB EXPAND=FALSE

{
{  The purpose of this request is to suspend execution of all
{  tasks in a job in preparation for swapping the job to disk.
{  It is ensured that the tasks have no system tables locked
{  before they are idled down.  An error status is returned
{  if the job has terminated.
{
{    TMP$SWAPOUT_JOB (RB)
{
{  RB : (INPUT,OUTPUT) This parameter specifies the request block.
{
*DECK DECK=TMH$SWITCH_TASK EXPAND=FALSE

{
{  The purpose of this procedure is to change the current task
{  of execution.  The XCB, JCB and AJL accounting fields are
{  updated.
{
{    TMP$SWITCH_TASK
{
*DECK DECK=TMH$TASK_EXIT EXPAND=FALSE

{
{  The purpose of this procedure is to exit the current task.
{  The PTL entry for the task is deleted and the parent task
{  is notified of callee termination.
{
{    TMP$TASK_EXIT (RB)
{
{  RB: (INPUT,OUTPUT) This parameter specifies the request block.
{
*DECK DECK=TMH$UPDATE_SWAPPED_JOBS_PTL EXPAND=FALSE

{
{   The purpose of this procedure is to update the primary task list for
{ a job that is being swapped in, the ajl ordinal may have changed.
{
{        TMP$UPDATE_SWAPPED_JOBS_PTL (AJL_ORDINAL, STATUS)
{
{ AJL_ORDINAL: (input) This parameter specifies the swapped in jobs new
{        ajl ordinal.
{
{ STATUS: (output) This parameter is where the request status is returned to
{        the caller.
{
*DECK DECK=TMH$UPDATE_XP_REGISTER EXPAND=FALSE

{
{  The purpose of this request is to update the specified register
{  in job xp.
{
{     TMP$UPDATE_XP_REGISTER (RB, CST_P)
{
{  RB: (INPUT,OUTPUT) This parameter specifies the request block.
{
{  CST_P: (INPUT) This parameter specifies the pointer to the CST.
{
*DECK DECK=TMHFNX EXPAND=FALSE
{
{  The purpose of this request is to scan the PTL entry for each
{  task in a JOB or the SYSTEM and return its XCB_P.
{
{  SEARCH: (INPUT) This parameter specifies the type of search to be
{                  done, JOB, SYSTEM, SWAPPING_JOB, of CONTINUE
{                  previous search.
{
{  IJLE_P: (INPUT) This parameter specifies a pointer to the initiated
{                  job list entry of the job to be searched.
{
{  IJL_ORDINAL: (INPUT) This parameter specifies the initiated job list
{                       ordinal of the job to be searched.
{
{  STATE: (INPUT,OUTPUT) This parameter specifies the type of search
{                        that had been started by a previous call.
{
{  XCB_P: (OUTPUT) This parameter specifies the XCB_P of the next task
{                  in the JOB or SYSTEM.
{
*DECK DECK=TMHRCPR EXPAND=FALSE
{
{    This request is used to change the task priority.  The PTL entry
{  for the task is delinked from the DCT queue for its original priority
{  and linked into the queue for its new priority.
{
{  TYPE
{    TMT$RB_CHANGE_TASK_PRIORITY = RECORD
{      REQCODE,
{      STATUS,
{      TASKID,
{      NEW_PRIORITY,
{    RECEND;
{
{  RECODE: (input) The value of this parameter is SYC$RC_CHANGE_TASK_PRIORITY.
{
{  STATUS: (output) This parameter specifies the monitor status.
{
{  TASKID: (input) This parameter specifies the global task id of the task whose
{          priority is to be changed.
{
*DECK DECK=TMHRCYC EXPAND=FALSE
{
{  The purpose of this request is to give up use of the processor
{  until the next time slice.
{
{  TYPE
{    TMT$RB_CYCLE = RECORD
{      REQCODE,
{    RECEND;
{
{  REQCODE: (input) The value of this parameter is SYC$RC_CYCLE.
{
*DECK DECK=TMHREXJ EXPAND=FALSE
{
{    The purpose of this request is to exit the job monitor task of a
{  job.  The PTL entry for the job monitor task is deleted and the job
{  status in the ajl entry is set to terminated.
{
{  TYPE
{    TMT$RB_EXIT_JOB = RECORD
{      REQCODE,
{      STATUS,
{      TERMINATOR_TASK_ID,
{    RECEND;
{
{  REQCODE: (input) The value of this parameter is SYC$RC_EXIT_JOB.
{
{  STATUS: (output) This specifies the standard monitor status.
{
{  TERMINATOR_TASK_ID: (input) Unused.
{
*DECK DECK=TMHRFTS EXPAND=FALSE
{
{  The purpose of this request is to cause task statistics to be updated.
{  This request should be issued to update statistics before task
{  termination.
{
{  TYPE
{    TMT$RB_FETCH_TASK_STATISTICS = RECORD
{      REQCODE,
{      STATUS,
{      MONITOR_CPTIME,
{    RECEND;
{
{  REQCODE: (input) The value of this parameter is SYC$RC_FETCH_TASK_STATISTICS.
{
{  STATUS: (output) This parameter is currently unused.
{
{  MONITOR_CPTIME: (output) This parameter contains the CP time used
{       by this task in monitor mode.
{
*DECK DECK=TMHRINJ EXPAND=FALSE
{
{    This request is used to schedule a newly created job monitor task.
{  A PTL entry is assigned to the JOB monitor task and it is inserted in
{  the DCT chain.  The segment table entry for the new job's JFS is
{  deleted from the address space of the current task that initiated this
{  job.  Execution of the new job may actually begin before the requesting
{  task continues execution.
{
{  TYPE
{    TMT$RB_INITIATE_JOB = RECORD
{      REQCODE,
{      STATUS,
{      XCB_P,
{      JMTR_TASKID,
{      AJO,
{      IJLO,
{    RECEND;
{
{  REQCODE: (input) The value of this parameter is SYC$RC_INITIATE_JOB.
{
{  STATUS: (output) This parameter is standard monitor status.
{
{  XCB_P: (input)  This parameter provides the pointer to the new job's
{         execution control block.
{
{  JMTR_TASKID: (input) This parameter provides the task id for the new
{         jobs job monitor task.
{
{  AJO: (input/output) Active job ordinal of the new job. Input is a dummy
{       parameter. The actual ajl ordinal is obtained from the ajl_manager.
{
{  IJLO: (input) Initiated job ordinal of the new job.
{
*DECK DECK=TMHRINT EXPAND=FALSE
{
{  This request is used to schedule a newly created task.  A PTL entry
{  is assigned to the task and it is inserted in the DCT chain.  The PTL
{  entry is also linked to the AJL thread for this job.
{
{  TYPE
{    TMT$RB_INITIATE_JOB = RECORD
{      REQCODE,
{      STATUS,
{      XCB_P,
{      WAIT,
{      TASKID,
{    RECEND;
{
{  REQCODE: (input) The value of this parameter is syc$rc_initiate_job.
{
{  STATUS: (output) This parameter is the standard monitor status.
{
{  XCB_P: (input) This parameter is a pointer to the new tasks XCB.
{
{  WAIT: (input) This parameter specifies if the requesting task wants to
{                wait for a signal from the initiated task.
{
{  TASKID: (input) This parameter specifies the global task id of the new task.
*DECK DECK=TMHRMST EXPAND=FALSE
{
{  This request is used to either define the requesting task as a
{  specific special system task or it is used to perform a ready_task
{  on a task already defined as the desired system task.
{
{  TYPE
{    TMT$RB_MANAGE_SYSTEM_TASKS = RECORD
{      REQCODE,
{      STATUS,
{      STID,
{      SAVE_TASK_ID,
{      CRITICAL_TASK,
{    RECEND;
{
{  REQCODE: (input) The value of this parameter is SYC$RC_MANAGE_SYSTEM_TASKS.
{
{  STATUS: (output) This parameter is the standard monitor status.
{
{  STID: (input) This parameter specifies the desired system task id.
{
{  SAVE_TASK_ID: (input) This parameter specifies that the requesting task
{         wishes to be defined as a system task if TRUE, or that the specified
{         system task should be made ready via a ready_task.
{
{  CRITICAL_TASK: (input) This parameter specifies that the system task being
{       defined is a critical task and if it should fail NOS/ve should halt.
*DECK DECK=TMHRRT EXPAND=FALSE
{
{  The purpose of this request is to change the status of a specified task
{  to ready and to set the WAIT_INHIBITED flag in the task's PTL entry.
{
{  TYPE
{    TMT$RB_READY_TASK = RECORD
{      REQCODE,
{      STATUS,
{      TASK_ID,
{    RECEND;
{
{  REQCODE: (input) The value of this parameter is SYC$RC_READY_TASK.
{
{  STATUS: (output) This parameter specifies the standard monitor status.
{
{  TASK_ID: (input) This parameter specifies the global task id of the task to
{          ready.
*DECK DECK=TMHRSSF EXPAND=FALSE
{  The purpose of this request is to set a system flag in the XCB
{  (execution control block) of the specified task.
{
{  TYPE
{    TMT$RB_SET_SYSTEM_FLAG = RECORD
{      REQCODE,
{      STATUS,
{      TASK_ID,
{      FLAG_ID,
{    recend;
{
{  reqcode: (input) The value of this parameter is SYC$RC_MTR_SET_SYSTEM_FLAG.
{
{  task_id: (input) This parameter is the global task id of the task in
{          which the system flag is set.
{
{  flag_id: (input) This parameter specifies which system flag is to be set.
{
{  status: (output) This parameter is the standard monitor status.
*DECK DECK=TMHRTEX EXPAND=FALSE
{
{  The purpose of this request is to exit the current task.  The PTL
{  entry for the task is deleted and the parent task is notified of
{  callee termination.
{
{  TYPE
{    TMT$RB_TASK_EXIT = RECORD
{      REQCODE,
{      STATUS,
{      PARENT_GLOBAL_TASK_ID,
{      SIGNAL,
{    RECEND;
{
{  REQCODE: (input) The value for this parameter is SYC$RC_TASK_EXIT.
{
{  STATUS: (output) This parameter specifies standard monitor status.
{
{  PARENT_GLOBAL_TASK_ID: (input) This parameter specifies the global task id
{      of the parent task.
{
{  SIGNAL: (input) This parameter specifies the signal block to be sent to
{      the parent task.
*DECK DECK=TMHRUXP EXPAND=FALSE
{
{  TYPE
{    TMT$RB_UPDATE_XP_REGISTER = RECORD
{      REQCODE,
{      STATUS,
{      CASE REGISTER_ID OF
{        = OSC$PR_PROCESS_INTERVAL_TIMER =
{          PIT_VALUE,
{      CASEND,
{    RECEND;
{
{  REQCODE: (input) The value of this parameter is syc$rc_update_xp_register.
{
{  STATUS: (output) This specifies the standard monitor status.
{
{  REGISTER_ID: (input) This parameter specifies the register to update.
{
{  PIT_VALUE: (input) This parameter specifies the new PIT value if the
{      value of REGISTER_ID was OSC$PR_PROCESS_INTERVAL_TIMER.
{
*DECK DECK=TMIDSF EXPAND=FALSE

    VAR
      flag_id: ost$system_flag,
      flag_found: boolean,
      flag_handler: tmt$system_flag_handler,

      trap_enables: 0 .. 3,
      traps: 0 .. 3;

    i#disable_traps (trap_enables);
    flag_found := TRUE;
    REPEAT
      tmp$find_flag_to_process (flag_found, flag_id, flag_handler);
      IF flag_found THEN
        i#enable_traps (traps);
        {call the flag handler}
        flag_handler^ (flag_id);
        i#restore_traps (traps);
      IFEND;
    UNTIL NOT flag_found;

    i#restore_traps (trap_enables);
*DECK DECK=TMIDSGL EXPAND=FALSE

    VAR
      internal_signal: tmt$signal,
      signal_found: boolean,
      signal_handler: tmt$signal_handler,

      trap_enables: 0 .. 3,
      traps: 0 .. 3;

    i#disable_traps (trap_enables);
    signal_found := TRUE;
    WHILE signal_found DO
      tmp$find_signal (signal_found, internal_signal, signal_handler);
      IF signal_found THEN
        i#enable_traps (traps);
        {call the signal handler}
        signal_handler^ (internal_signal.originator, internal_signal.signal);

        i#restore_traps (traps);
      IFEND;
    WHILEND;

    i#restore_traps (trap_enables);
*DECK DECK=TMK$MONITOR_MODE_KEYPOINTS EXPAND=FALSE

{ This common deck contains the keypoint codes for the task management
{ procedures that run in monitor mode.




{ Define keypoint codes.}


  CONST
    tmk$invalid_taskid = tmk$monitor_base + 0,
      {D 'Invalid task id' 'ptlo' I16 }

    tmk$assign_ptl = tmk$monitor_base + 1,
      {D 'Assign PTL entry' 'ptlo' I16 }

    tmk$set_task_wait = tmk$monitor_base + 2,
      {D 'Set task in wait status' 'ptlo' I16 }

    tmk$insert_dct = tmk$monitor_base + 3,
      {D 'Insert task into dispatch chain' 'ptlo' I16 }

    tmk$remove_dct = tmk$monitor_base + 4,
      {D 'Remove task from dispatch chain' 'ptlo' I16 }

    tmk$set_task_ready = tmk$monitor_base + 5,
      {D 'Ready task' 'ptlo' I16 }

    tmk$queue_task = tmk$monitor_base + 6,
      {D 'Queue task' 'ptlo' I16 }

    tmk$dequeue_task = tmk$monitor_base + 7,
      {D 'Dequeue task' 'ptlo' I16 }

    tmk$insert_ajl = tmk$monitor_base + 8,
      {D 'Insert task into AJL thread' 'ajo' I20 }

    tmk$remove_ajl = tmk$monitor_base + 9,
      {D 'Remove task from AJL thread' 'ajo' I20 }

    tmk$rethread_orig_priority = tmk$monitor_base + 10,
      {D 'Move task to original priority DCT chain' 'ptlo' I16 }

    tmk$rethread_higher_priority = tmk$monitor_base + 11,
      {D 'Move task to higher priority DCT chain' 'ptlo' I16 }

    tmk$reissue_mtr_req = tmk$monitor_base + 12,
      {D 'Reissue monitor request' 'ptlo' I16 }

    tmk$find_min_timeout = tmk$monitor_base + 13,
      {E 'Find min timeout' 'us' I20 }
      {X 'Find min timeout' 'us' I20 }

    tmk$change_task_priority = tmk$monitor_base + 14,
      {D 'Change task priority' 'priority' I16 }

    tmk$create_task = tmk$monitor_base + 15,
      {D 'Create new task'   }

    tmk$cycle = tmk$monitor_base + 17,
      {D 'Cycle' }

    tmk$switch_task = tmk$monitor_base + 18,
      {E 'Switch task' 'time' I20 }
      {X 'Switch task' 'time' I20 }

    tmk$exit_task = tmk$monitor_base + 19,
      {E 'Exit task'  }
      {X 'Exit task'  }

    tmk$delay = tmk$monitor_base + 21,
      {D 'Delay'  }

    tmk$update_task_statistics = tmk$monitor_base + 22,
      {D 'Update task statistics' 'us' I20 }

    tmk$create_job = tmk$monitor_base + 23,
      {D 'Initiate new job' 'AJO' I20 }

    tmk$exit_job = tmk$monitor_base + 24,
      {D 'Exit job' 'AJO' I20 }

    tmk$swapout_job = tmk$monitor_base + 26,
      {D 'Swapout job' 'AJO' I20 }

    tmk$swapin_job = tmk$monitor_base + 27,
      {D 'Swapin job' 'AJO' I20 }

    tmk$set_system_flag = tmk$monitor_base + 28,
      {D 'Set swapin flag in PTL' 'ptlo' I16 }

    tmk$send_signal = tmk$monitor_base + 29,
      {D 'Send signal' 'ptlo' I16 }

    tmk$send_monitor_fault = tmk$monitor_base + 30,
      {D 'Send monitor fault' 'plto' I16 }

    tmk$monitor_fault_buffers_full = tmk$monitor_base + 31,
      {U '***Monitor fault buffers full***' }

    tmk$task_connot_receive_mf = tmk$monitor_base + 32,
      {U '***Task cannot receive monitor fault***' }

    tmk$signal_buffers_full = tmk$monitor_base + 33,
      {U '***Signal buffers full***' }

    tmk$process_task_mcr_fault = tmk$monitor_base + 34,
      {D 'Process task MCR fault in job mode' 'ptlo' I16 }

    tmk$process_broken_task = tmk$monitor_base + 35,
      {D 'Process broken task in job mode' 'ptlo' I16 }

    tmk$set_monitor_flag = tmk$monitor_base + 36,
      {D 'Set monitor flag' 'flag' I16 }

    tmk$set_task_ready_uncond = tmk$monitor_base + 37;
      {D 'Set task ready UNCOND' 'ptlo' I16 }



*copyc AMK$BASE_KEYPOINT_VALUES
*DECK DECK=TMM$ALLOCATE_EXECUTION_RINGS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Signal and Flag Management' ??
?? NEWTITLE := '  TMM$ALLOCATE_EXECUTION_RINGS' ??
MODULE tmm$allocate_execution_rings;

{   PURPOSE:
{     The purpose of this module is to package contained procedures
{     so that they execute with the privileges necessary to modify
{     signal and flag execution rings (tcb) and the handler descriptions.
{
{     This module allocates an execution ring to each outstanding
{     signal and system flag.

{     The module also contains procedures enable and disable preemptive
{     communication.

{   DESIGN:
{     The procedures contained in this module have a execution bracket
{     of 2, 2 and a call bracket of 3.
{
{   DESIGN ASSUMPTIONS:
{     1.  No procedure which executes soley in task monitor rings
{         (i.e., execute bracket of 2 - 2) has a call
{         bracket greater than task services (3).  In other words,
{         such a task monitor procedure can be called only from within
{         its execute bracket or from task services.
{
{     2.  All signal and system flag recognition rings are less than or
{         equal to 4 (task services ring + 1).
{
{     3.  No signal or system flag handler has an execute bracket which
{         extends above the task services ring.
{
{

?? NEWTITLE := '    Global Declarations Referenced By This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
*copyc osd$code_base_pointer
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc ost$execution_control_block
*copyc pme$define_handler_exceptions
*copyc tmc$execution_ring_constants
*copyc tmt$allocated_execution_rings
*copyc tmt$pc_handler_descriptions
*copyc tmt$preempted_reason
?? POP ??

*copyc i#disable_traps
*copyc i#restore_traps
*copyc i#enable_traps
*copyc osp$set_status_abnormal
*copyc pmp$build_ring_crossing_frame
*copyc pmp$find_executing_task_tcb
*copyc pmp$find_executing_task_xcb
*copyc tmp$dispose_of_inserted_preempt
*copyc tmp$find_ring_crossing_frame

?? TITLE := '    Signal Handlers Referenced By This Module', EJECT ??

?? PUSH (LISTEXT := ON) ??
{*copyc dsh$signal_handler
?? POP ??
*copyc dsp$signal_handler

?? PUSH (LISTEXT := ON) ??
*copyc cmh$signal_handler
?? POP ??
*copyc cmp$signal_handler

?? PUSH (LISTEXT := ON) ??
*copyc clh$scl_signal_handler
?? POP ??
*copyc clp$scl_signal_handler

?? PUSH (LISTEXT := ON) ??
*copyc ifh$handle_signal
?? POP ??
*copyc ifp$handle_signal

?? PUSH (LISTEXT := ON) ??
*copyc jmh$handle_job_resource_signal
?? POP ??
*copyc jmp$handle_job_resource_signal

?? PUSH (LISTEXT := ON) ??
*copyc jmh$handle_signal_sense_switch
?? POP ??
*copyc jmp$handle_signal_sense_switch

?? PUSH (LISTEXT := ON) ??
*copyc jmh$swapin_job_signal_handler
?? POP ??
*copyc jmp$swapin_job_signal_handler

?? PUSH (LISTEXT := ON) ??
*copyc jmh$timesharing_signal_handler
?? POP ??
*copyc jmp$timesharing_signal_handler

?? PUSH (LISTEXT := ON) ??
*copyc mlh$handle_signal
?? POP ??
*copyc mlp$handle_signal

?? PUSH (LISTEXT := ON) ??
*copyc mmh$fetch_segment_attributes
?? POP ??
*copyc mmp$fetch_segment_attributes

*copyc nap$cn_signal_handler

?? PUSH (LISTEXT := ON) ??
*copyc nah$gt_deliver_event_handler
?? POP ??
*copyc nap$gt_deliver_event_handler

?? PUSH (LISTEXT := ON) ??
*copyc nah$gt_send_data_handler
?? POP ??
*copyc nap$gt_send_data_handler

?? PUSH (LISTEXT := ON) ??
*copyc nah$gt_deliver_connect_handler
?? POP ??
*copyc nap$gt_deliver_connect_handler

*copyc nap$se_deliver_event_handler

*copyc nap$se_send_data_handler

*copyc nap$se_disconnect_handler

*copyc ofp$handle_signal_processor

*copyc pmp$child_termination_handler

*copyc pmp$multi_task_signal_handler


?? TITLE := '    Flag Handlers Referenced By This Module', EJECT ??


*copyc avp$monitor_statistics_handler

*copyc dsp$log_dft_data

*copyc dsp$retrieve_system_message

?? PUSH (LISTEXT := ON) ??
*copyc ioh$mfh_subsystem_io_completion
?? POP ??
*copyc iop$mfh_subsystem_io_completion

?? PUSH (LISTEXT := ON) ??
*copyc jmh$terminate_job_flag_handler
?? POP ??
*copyc jmp$terminate_job_flag_handler

?? PUSH (LISTEXT := ON) ??
*copyc jmh$handle_logout_flag
?? POP ??
*copyc jmp$handle_logout_flag

*copyc jmp$message_waiting_flag_hndlr

*copyc mmp$failed_allocation_flag_hdl

?? PUSH (LISTEXT := ON) ??
*copyc mmh$volume_unavailable_flag_hdl
?? POP ??
*copyc mmp$volume_unavailable_flag_hdl

*copyc nap$cn_flag_handler

*copyc nlp$cc_work_list_processor

*copyc ofp$handle_operator_break_flag

*copyc osp$handle_keyp_environ_change

?? PUSH (LISTEXT := ON) ??
*copyc osh$unstep_resume_flag_handler
?? POP ??
*copyc osp$unstep_resume_flag_handler

?? PUSH (LISTEXT := ON) ??
*copy pmh$kill_task_flag_handler
?? POP ??
*copyc pmp$kill_task_flag_handler

*copyc pmp$terminate_flag_handler

?? PUSH (LISTEXT := ON) ??
*copyc rfh$process_pp_response_flag
?? POP ??
*copyc rfp$process_pp_response_flag

*copyc syp$job_recovery_flag_handler

?? PUSH (LISTEXT := ON) ??
*copyc tmh$dispose_mainframe_signals
?? POP ??
*copyc tmp$dispose_mainframe_signals


?? TITLE := '    Global Declarations Declared By This Module' ??
?? NEWTITLE := '      Signal Handler Definitions', EJECT ??

  VAR
    tmv$signal_handler_descriptions: [XDCL, READ, oss$job_paged_literal] array [pmt$signal_id] of
          tmt$pc_handler_description := [

    {tmc$signal_available_0         } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {ofc$signal                     } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$signal, ^ofp$handle_signal_processor],

    {mlc$signal_id                  } [tmc$highest_recognition_ring, osc$os_ring_1, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$signal, ^mlp$handle_signal],

    {ifc$signal_id                  } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$long_term_wait], tmc$signal, ^ifp$handle_signal],

    {pmc$ss_child_terminated        } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$signal,
          ^pmp$child_termination_handler],

    {jmc$timesharing_signal_id      } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$long_term_wait], tmc$signal, ^jmp$timesharing_signal_handler],

    {cmc$configuration_signal_id  } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$signal,
          ^cmp$signal_handler],

    {jmc$sense_switch_signal_id     } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$signal,
          ^jmp$handle_signal_sense_switch],

    {tmc$signal_available_8         } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {jmc$job_resource_signal_id     } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$signal,
          ^jmp$handle_job_resource_signal],

    {dsc$deadstart_signal           } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$signal, ^dsp$signal_handler],

    {tmc$signal_available_11        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {nac$network_device_error       } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$signal, ^nap$cn_signal_handler],

    {tmc$signal_available_13        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_14        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {pmc$multi_task_condition       } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tmtr_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$signal,
          ^pmp$multi_task_signal_handler],

    {nac$gt_deliver_data            } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$signal, ^nap$gt_deliver_event_handler],

    {nac$gt_send_data               } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$signal, ^nap$gt_send_data_handler],

    {nac$gt_deliver_connect_request } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$signal,
          ^nap$gt_deliver_connect_handler],

    {nac$se_deliver_data_signal     } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$signal, ^nap$se_deliver_event_handler],

    {nac$se_send_data_signal        } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$signal, ^nap$se_send_data_handler],

    {nac$se_disconnect_signal        } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$signal, ^nap$se_disconnect_handler],

    {tmc$signal_available_22        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_23        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_24        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_25        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_26        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {clc$scl_signal                 } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$signal, ^clp$scl_signal_handler],

    {tmc$signal_available_28        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_29        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_30        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_31        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_32        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_33        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_34        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_35        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_36        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_37        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_38        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_39        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_40        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_41        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_42        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_43        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_44        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_45        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_46        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_47        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_48        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_49        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_50        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_51        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_52        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_53        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_54        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_55        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_56        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_57        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_58        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_59        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_60        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_61        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_62        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL],

    {tmc$signal_available_63        } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$signal, NIL]];

?? TITLE := '      Flag Handler Definitions', EJECT ??

  VAR
    tmv$flag_handler_descriptions: [XDCL, READ, oss$job_paged_literal] array [ost$system_flag] of
          tmt$pc_handler_description := [

    {pmc$kill_task_flag             } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tmtr_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag,
          ^pmp$kill_task_flag_handler],

    {avc$monitor_statistics_flag    } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tmtr_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag,
          ^avp$monitor_statistics_handler],

    {pmc$sf_terminate_task          } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag,
          ^pmp$terminate_flag_handler],

    {jmc$terminate_job_flag         } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag,
          ^jmp$terminate_job_flag_handler],

    {tmc$mainframe_linked_signals   } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tmtr_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag,
          ^tmp$dispose_mainframe_signals],

    {jmc$logout_flag_id             } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag, ^jmp$handle_logout_flag],

    {jmc$kill_job_flag_id           } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag,
          ^jmp$terminate_job_flag_handler],

    {dsc$retrieve_system_message    } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag,
          ^dsp$retrieve_system_message],

    {nac$network_input_received     } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag, ^nap$cn_flag_handler],

    {osc$keyp_environ_change_flag   } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag,
          ^osp$handle_keyp_environ_change],

    {tmc$flag_available_10          } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$system_flag, NIL],

    {nac$channelnet_local_event     } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag, ^nap$cn_flag_handler],

    {tmc$flag_available_12          } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$system_flag, NIL],

    {syc$job_recovery_flag          } [tmc$lowest_signal_flag_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag,
          ^syp$job_recovery_flag_handler],

    {ioc$subsystem_io_complete      } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag,
          ^iop$mfh_subsystem_io_completion],

    {dsc$log_dft_flag_id            } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag, ^dsp$log_dft_data],

    {ofc$operator_break_flag        } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag,
          ^ofp$handle_operator_break_flag],

    {osc$system_unstep_resume_flag  } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag,
          ^osp$unstep_resume_flag_handler],

    {nlc$cc_work_list_flag          } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag,
          ^nlp$cc_work_list_processor],

    {rfc$pp_response_available      } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag,
          ^rfp$process_pp_response_flag],

    {mmc$failed_file_alloc_flag     } [tmc$lowest_signal_flag_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag,
          ^mmp$failed_allocation_flag_hdl],

    {mmc$volume_unavailable_flag    } [tmc$lowest_signal_flag_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag,
          ^mmp$volume_unavailable_flag_hdl],

    {jmc$message_waiting_flag_id    } [tmc$highest_recognition_ring, osc$tmtr_ring, osc$tsrv_ring,
          $tmt$wait_preemptability [tmc$wait, tmc$long_term_wait], tmc$system_flag,
          ^jmp$message_waiting_flag_hndlr],

    {tmc$flag_available_23          } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$system_flag, NIL],

    {tmc$flag_available_24          } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$system_flag, NIL],

    {tmc$flag_available_25          } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$system_flag, NIL],

    {tmc$flag_available_26          } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$system_flag, NIL],

    {tmc$flag_available_27          } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$system_flag, NIL],

    {tmc$flag_available_28          } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$system_flag, NIL],

    {tmc$flag_available_29          } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$system_flag, NIL],

    {tmc$flag_available_30          } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$system_flag, NIL],

    {tmc$flag_available_31          } [osc$invalid_ring, osc$invalid_ring, osc$invalid_ring,
          $tmt$wait_preemptability [], tmc$system_flag, NIL]];

?? OLDTITLE ??
?? TITLE := '    ALLOCATE_SIGNAL_X_RING', EJECT ??

  PROCEDURE allocate_signal_x_ring
    (    signal_id: pmt$signal_id;
         x_attributes: tmt$pc_handler_description;
         preempted_reason: tmt$preempted_reason;
         preempted_ring: ost$ring;
     VAR signal_execution_ring: tmt$handler_execution_ring;
     VAR allocated_execution_rings {input, output} : tmt$allocated_execution_rings);

    VAR
      traps: 0 .. 3,
      status: ost$status;

    i#disable_traps (traps);

    CASE preempted_reason OF

    = tmc$free_flag =
      IF (preempted_ring >= x_attributes.recognition_ring) THEN
        IF (preempted_ring >= x_attributes.high_execution_ring) THEN
          signal_execution_ring := x_attributes.high_execution_ring;
          allocated_execution_rings := allocated_execution_rings +
                $tmt$allocated_execution_rings [signal_execution_ring];
        ELSE
          IF (preempted_ring >= x_attributes.low_execution_ring) THEN
            signal_execution_ring := preempted_ring;
            allocated_execution_rings := allocated_execution_rings +
                  $tmt$allocated_execution_rings [signal_execution_ring];
          ELSE
            set_inserted_preemption (preempted_ring, status);
            IF status.normal THEN
              signal_execution_ring := tmc$delay_allocation;
            ELSE
              {The task is broken leave the signal in the buffer with an unallocated x ring. 'Set inserted'
              {detected an inconsistent stack segment, the task will be allowed to continue until the
              {condition arises again at which time the task will be aborted.
            IFEND;
          IFEND;
        IFEND;
      ELSE
        set_delayed_preemption (x_attributes.recognition_ring - 1, status);
        IF status.normal THEN
          signal_execution_ring := tmc$delay_allocation;
        ELSE
          {The task is broken leave the signal in the buffer with an unallocated x ring. 'Set delayed'
          {detected an inconsistent stack segment, the task will be allowed to continue until the condition
          {arises again at which time the task will be aborted.
        IFEND;
      IFEND;

    = tmc$recognition_ring_delay =
      IF (preempted_ring >= (x_attributes.recognition_ring - 1)) THEN
        IF preempted_ring >= (x_attributes.high_execution_ring) THEN
          signal_execution_ring := x_attributes.high_execution_ring;
          allocated_execution_rings := allocated_execution_rings +
                $tmt$allocated_execution_rings [signal_execution_ring];
        ELSE
          IF (preempted_ring >= x_attributes.low_execution_ring) THEN
            signal_execution_ring := preempted_ring;
            allocated_execution_rings := allocated_execution_rings +
                  $tmt$allocated_execution_rings [signal_execution_ring];
          IFEND;
        IFEND;
      IFEND;

    = tmc$x_bracket_delay =
      IF (preempted_ring >= x_attributes.recognition_ring) THEN
        IF (preempted_ring >= x_attributes.high_execution_ring) THEN
          signal_execution_ring := x_attributes.high_execution_ring;
          allocated_execution_rings := allocated_execution_rings +
                $tmt$allocated_execution_rings [signal_execution_ring];
        ELSE
          IF (preempted_ring >= x_attributes.low_execution_ring) THEN
            signal_execution_ring := preempted_ring;
            allocated_execution_rings := allocated_execution_rings +
                  $tmt$allocated_execution_rings [signal_execution_ring];
          IFEND;
        IFEND;
      IFEND;

    = tmc$wait =
      IF (tmc$wait IN x_attributes.preempt_wait) THEN
        IF (preempted_ring >= x_attributes.high_execution_ring) THEN
          signal_execution_ring := x_attributes.high_execution_ring;
          allocated_execution_rings := allocated_execution_rings +
                $tmt$allocated_execution_rings [signal_execution_ring];
        ELSE
          IF (preempted_ring >= x_attributes.low_execution_ring) THEN
            signal_execution_ring := preempted_ring;
            allocated_execution_rings := allocated_execution_rings +
                  $tmt$allocated_execution_rings [signal_execution_ring];
          IFEND;
        IFEND;
      ELSE
        set_delayed_preemption (x_attributes.recognition_ring - 1, status);
        IF status.normal THEN
          signal_execution_ring := tmc$delay_allocation;
        IFEND;
      IFEND;

    = tmc$long_term_wait =
      IF (tmc$long_term_wait IN x_attributes.preempt_wait) THEN
        IF (preempted_ring >= x_attributes.high_execution_ring) THEN
          signal_execution_ring := x_attributes.high_execution_ring;
          allocated_execution_rings := allocated_execution_rings +
                $tmt$allocated_execution_rings [signal_execution_ring];
        ELSE
          IF (preempted_ring >= x_attributes.low_execution_ring) THEN
            signal_execution_ring := preempted_ring;
            allocated_execution_rings := allocated_execution_rings +
                  $tmt$allocated_execution_rings [signal_execution_ring];
          IFEND;
        IFEND;
      ELSE
        set_delayed_preemption (x_attributes.recognition_ring - 1, status);
        IF status.normal THEN
          signal_execution_ring := tmc$delay_allocation;
        IFEND;
      IFEND;

    = tmc$task_termination =
      IF (preempted_ring >= x_attributes.high_execution_ring) THEN
        signal_execution_ring := x_attributes.high_execution_ring;
        allocated_execution_rings := allocated_execution_rings +
              $tmt$allocated_execution_rings [signal_execution_ring];
      ELSE
        IF (preempted_ring >= x_attributes.low_execution_ring) THEN
          signal_execution_ring := preempted_ring;
          allocated_execution_rings := allocated_execution_rings +
                $tmt$allocated_execution_rings [signal_execution_ring];
        IFEND;
      IFEND;
    CASEND;

    i#restore_traps (traps);
  PROCEND allocate_signal_x_ring;

?? TITLE := '    ALLOCATE_TL_SIGNAL_X_RINGS', EJECT ??
?? PUSH (LISTEXT := ON) ??
{
{   The purpose of this request is to allocate execution rings for
{ signals in the task local signal list.
{
{       ALLOCATE_TL_SIGNAL_X_RINGS (PREEMPTED_REASON, PREEMPTED_RING,
{         ALLOCATED_EXECUTION_RINGS)
{
{ PREEMPTED_REASON: (input) This parameter specifies the reason that
{       task execution was preempted.
{
{ PREEMPTED_RING: (input) This parameter specifies the ring that was
{       preempted.
{
{ ALLOCATED_EXECUTION_RINGS: (input, output) This parameter specifies
{       the rings that are currently allocated to signals.
{
?? POP ??

  PROCEDURE allocate_tl_signal_x_rings
    (    preempted_reason: tmt$preempted_reason;
         preempted_ring: ost$ring;
     VAR allocated_execution_rings {input, output} : tmt$allocated_execution_rings);

    VAR
      traps: 0 .. 3,
      tcb: ^pmt$task_control_block,
      delink: ^^tmt$task_local_linked_signal;

    pmp$find_executing_task_tcb (tcb);
    i#disable_traps (traps);
    IF (tcb^.task_local_signal_list.delink <> NIL) THEN
      delink := ^tcb^.task_local_signal_list.delink;
      WHILE (delink^ <> NIL) DO
        allocate_signal_x_ring (delink^^.linked.signal.identifier,
              tmv$signal_handler_descriptions [delink^^.linked.signal.identifier], preempted_reason,
              preempted_ring, delink^^.signal_execution_ring, allocated_execution_rings);
        delink := ^delink^^.next_linked_signal;
      WHILEND;
    IFEND;
    i#restore_traps (traps);
  PROCEND allocate_tl_signal_x_rings;

?? TITLE := '    SET_DELAYED_PREEMPTION', EJECT ??
?? PUSH (LISTEXT := ON) ??
{
{   This procedure causes TMP$DISPOSE_OF_DELAYED_PREEMPT to be called
{ when the ring corresponding to in_ring is exited.
{
{       SET_DELAYED_PREEMPTION (IN_RING, STATUS)
{
{ IN_RING: (input) This parameter specifies the ring exit at which
{       pmp$dispose_of_delayed_preempt is to be executed.
{
{ STATUS: (output) This parameter specifies the request status - the
{       stack frames between the caller and ring exit may have been
{       destroyed preventing the procedure from performing its function.
{

{ NOTE: traps are disabled when this procedure is entered - to ensure that a
{       system crash is not caused due to an inconsistent stack or detected
{       uncorrected error, traps must be enabled during the stack scan.
{       Traps are disabled prior to the scan and disabled after the scan has
{       been completed.  Preventing a crash during the scan may allow other
{       preemptive processing to continue and allow the task to terminate in a
{       graceful manner.
?? POP ??

  PROCEDURE set_delayed_preemption
    (    in_ring: ost$valid_ring;
     VAR status: ost$status);

    VAR
      traps: 0 .. 3,
      starting_frame: ^ost$stack_frame_save_area,
      crossing_frame: ^ost$stack_frame_save_area;

    starting_frame := NIL;
    status.normal := TRUE;

    i#enable_traps (traps);
    tmp$find_ring_crossing_frame (starting_frame, crossing_frame, status);
    starting_frame := crossing_frame^.minimum_save_area.a2_previous_save_area;
    WHILE ((starting_frame <> NIL) AND (#RING (starting_frame) <= in_ring)) AND status.normal DO
      tmp$find_ring_crossing_frame (starting_frame, crossing_frame, status);
      starting_frame := crossing_frame^.minimum_save_area.a2_previous_save_area;
    WHILEND;

    i#restore_traps (traps);

    IF status.normal THEN
      pmp$build_ring_crossing_frame (crossing_frame);
    IFEND;
  PROCEND set_delayed_preemption;

?? TITLE := '    SET_INSERTED_PREEMPTION', EJECT ??
?? PUSH (LISTEXT := ON) ??
{   This procedure causes TMP$DISPOSE_OF_INSERTED_PREEMPT to execute
{ when the ring above_the value of above ring is returned to.
{
{ TMP$DISPOSE_OF_INSERTED_PREEMPT is never called it is only returned
{ to.
{
{ A stack frame corresponding to TMP$DISPOSE_OF_INSERTED_PREEMPT is
{ inserted at the top of stack segment in the next active ring greater
{ than above_ring.
{
{       SET_INSERTED_PREEMPTION (ABOVE_RING, STATUS)
{
{ ABOVE_RING: (input) This parameter specifies the ring above which
{       tmp$dispose_of_inserted_preempt is to execute.
{
{ STATUS: (output) This parameter specifies the request status - the
{       caller's stack segment may have been destroyed preventing the
{       procedure from being inserted - indicated by abnormal status.
{

{ NOTE: traps are disabled when this procedure is entered - to ensure that a
{       system crash is not caused due to an inconsistent stack or detected
{       uncorrected error, traps must be enabled during the stack scan.
{       Traps are disabled prior to the scan and disabled after the scan has
{       been completed.  Preventing a crash during the scan may allow other
{       preemptive processing to continue and allow the task to terminate in a
{       graceful manner.
?? POP ??

  PROCEDURE set_inserted_preemption
    (    above_ring: ost$valid_ring;
     VAR status: ost$status);

    VAR
      traps: 0 .. 3,
      starting_frame: ^ost$stack_frame_save_area,
      x_frame: ^ost$stack_frame_save_area, {ring crossing frame}
      number_x_registers: ost$register_number,
      a0_dsp: ^^cell,
      a0_pva: ost$pva,

      inserted_frame: ost$stack_frame_save_area,
      inserted_sfsa: ^ost$stack_frame_save_area,
      return_frame: ^ost$stack_frame_save_area,
      return_frame_size: integer,
      proc: ^procedure,
      cbp: ^ost$external_code_base_pointer,
      keylock: array [1 .. 1] of mmt$attribute_descriptor;

    starting_frame := NIL;
    status.normal := TRUE;

    i#enable_traps (traps);
    tmp$find_ring_crossing_frame (starting_frame, x_frame, status);
    starting_frame := x_frame^.minimum_save_area.a2_previous_save_area;
    WHILE ((starting_frame <> NIL) AND (#RING (starting_frame) <= above_ring)) AND status.normal DO
      tmp$find_ring_crossing_frame (starting_frame, x_frame, status);
      starting_frame := x_frame^.minimum_save_area.a2_previous_save_area;
    WHILEND;
    i#restore_traps (traps);

    IF status.normal THEN
      inserted_frame.minimum_save_area.a2_previous_save_area :=
            x_frame^.minimum_save_area.a2_previous_save_area;
      return_frame := x_frame^.minimum_save_area.a2_previous_save_area;
      IF (return_frame^.minimum_save_area.frame_descriptor.x_terminating >=
            return_frame^.minimum_save_area.frame_descriptor.x_starting) THEN
        number_x_registers := ((return_frame^.minimum_save_area.frame_descriptor.x_terminating -
              return_frame^.minimum_save_area.frame_descriptor.x_starting) + 1);
      ELSE
        number_x_registers := 0;
      IFEND;
      return_frame_size := #SIZE (ost$minimum_save_area) +
            (8 * ((return_frame^.minimum_save_area.frame_descriptor.a_terminating - 2) + number_x_registers));

      a0_pva.ring := #RING (return_frame^.minimum_save_area.a2_previous_save_area);
      a0_pva.seg := #SEGMENT (return_frame^.minimum_save_area.a2_previous_save_area);
      a0_pva.offset := #OFFSET (return_frame^.minimum_save_area.a0_dynamic_space_pointer) + return_frame_size;
      a0_dsp := #LOC (a0_pva);
      inserted_frame.minimum_save_area.a0_dynamic_space_pointer := a0_dsp^;
      inserted_frame.minimum_save_area.a1_current_stack_frame :=
            inserted_frame.minimum_save_area.a0_dynamic_space_pointer;

      inserted_frame.minimum_save_area.frame_descriptor.on_condition_flag := FALSE;
      inserted_frame.minimum_save_area.frame_descriptor.critical_frame_flag := FALSE;
      inserted_frame.minimum_save_area.frame_descriptor.a_terminating := 0f(16);
      inserted_frame.minimum_save_area.frame_descriptor.x_starting := 0;
      inserted_frame.minimum_save_area.frame_descriptor.x_terminating := 0;
      inserted_frame.minimum_save_area.vmid := osc$cyber_180_mode;

      inserted_frame.x_registers [0] := 0; {no parameters}
      inserted_frame.a4 := NIL; {no parameters}

      proc := ^tmp$dispose_of_inserted_preempt;
      cbp := #LOC (proc^);
      inserted_frame.minimum_save_area.p_register.pva.ring := a0_pva.ring;
      inserted_frame.minimum_save_area.p_register.pva.seg := #SEGMENT (cbp^.code_pva);
      inserted_frame.minimum_save_area.p_register.pva.offset := #OFFSET (cbp^.code_pva);

      {global/local keys}
      keylock [1].keyword := mmc$kw_gl_key;
      mmp$fetch_segment_attributes (cbp^.code_pva, keylock, status);
      IF (return_frame^.minimum_save_area.p_register.global_key = 0) THEN
        inserted_frame.minimum_save_area.p_register.global_key := keylock [1].gl_key.value;
      ELSE
        inserted_frame.minimum_save_area.p_register.global_key :=
              return_frame^.minimum_save_area.p_register.global_key;
      IFEND;
      IF keylock [1].gl_key.local THEN
        inserted_frame.minimum_save_area.p_register.local_key := keylock [1].gl_key.value;
      ELSE
        inserted_frame.minimum_save_area.p_register.local_key := 0;
      IFEND;

      inserted_frame.a3 := cbp^.binding_pva;

      {insert the constructed stack frame}
      inserted_sfsa := inserted_frame.minimum_save_area.a1_current_stack_frame;
      inserted_sfsa^ := inserted_frame;
      x_frame^.minimum_save_area.a2_previous_save_area := inserted_frame.minimum_save_area.
            a1_current_stack_frame;
    IFEND;
  PROCEND set_inserted_preemption;

?? TITLE := '    TMP$ALLOCATE_EXECUTION_RINGS', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc tmh$allocate_execution_rings
?? POP ??

  PROCEDURE [XDCL, #GATE] tmp$allocate_execution_rings
    (    preempted_ring: ost$ring;
         preempted_reason: tmt$preempted_reason;
         preemptive_type: tmt$preemptive_type;
     VAR allocated_execution_rings: tmt$allocated_execution_rings);

    VAR
      traps: 0 .. 3,
      status: ost$status,
      x_attributes: tmt$pc_handler_description,
      xcb: ^ost$execution_control_block,
      tcb: ^pmt$task_control_block,
      number_buffers: tmt$signal_buffers,
      s: tmt$signal_buffers,
      signal_id: pmt$signal_id,
      f: ost$system_flag;

    allocated_execution_rings := $tmt$allocated_execution_rings [];
    pmp$find_executing_task_xcb (xcb);
    tcb := xcb^.task_control_block;

    CASE preemptive_type OF

    = tmc$signal =
      number_buffers := UPPERBOUND (xcb^.signals.present);
      FOR s := 1 TO number_buffers DO
        IF xcb^.signals.present [s] THEN
          signal_id := xcb^.signals.buffer [s].signal.identifier;
          allocate_signal_x_ring (signal_id, tmv$signal_handler_descriptions [signal_id], preempted_reason,
                preempted_ring, tcb^.signal_execution_ring [s], allocated_execution_rings);
        IFEND;
      FOREND;

      allocate_tl_signal_x_rings (preempted_reason, preempted_ring, allocated_execution_rings);

    = tmc$system_flag =
      i#disable_traps (traps);
      FOR f := LOWERVALUE (ost$system_flag) TO UPPERVALUE (ost$system_flag) DO
        IF (f IN xcb^.system_flags) THEN
          x_attributes := tmv$flag_handler_descriptions [f];
          CASE preempted_reason OF

          = tmc$free_flag =
            IF (preempted_ring >= x_attributes.recognition_ring) THEN
              IF (preempted_ring >= x_attributes.high_execution_ring) THEN
                tcb^.flag_execution_ring [f] := x_attributes.high_execution_ring;
                allocated_execution_rings := allocated_execution_rings + $tmt$allocated_execution_rings
                      [tcb^.flag_execution_ring [f]];
              ELSE
                IF (preempted_ring >= x_attributes.low_execution_ring) THEN
                  tcb^.flag_execution_ring [f] := preempted_ring;
                  allocated_execution_rings := allocated_execution_rings + $tmt$allocated_execution_rings
                        [tcb^.flag_execution_ring [f]];
                ELSE
                  set_inserted_preemption (preempted_ring, status);
                  IF status.normal THEN
                    tcb^.flag_execution_ring [f] := tmc$delay_allocation;
                  ELSE
                    {The task is broken leave the flag in system flags with an unallocated x ring. 'Set
                    {inserted' detected an inconsistent stack segment, the task will be allowed to continue
                    {until the condition arises again at which time the task will be aborted.
                  IFEND;
                IFEND;
              IFEND;
            ELSE
              set_delayed_preemption (x_attributes.recognition_ring - 1, status);
              IF status.normal THEN
                tcb^.flag_execution_ring [f] := tmc$delay_allocation;
              ELSE
                {The task is broken leave the flag in system flags with an unallocated x ring. 'Set delayed'
                {detected an inconsistent stack segment, the task will be allowed to continue until the
                {condition arises again at which time the task will be aborted.
              IFEND;
            IFEND;

          = tmc$recognition_ring_delay =
            IF (preempted_ring >= (x_attributes.recognition_ring - 1)) THEN
              IF preempted_ring >= (x_attributes.high_execution_ring) THEN
                tcb^.flag_execution_ring [f] := x_attributes.high_execution_ring;
                allocated_execution_rings := allocated_execution_rings + $tmt$allocated_execution_rings
                      [tcb^.flag_execution_ring [f]];
              ELSE
                IF (preempted_ring >= x_attributes.low_execution_ring) THEN
                  tcb^.flag_execution_ring [f] := preempted_ring;
                  allocated_execution_rings := allocated_execution_rings + $tmt$allocated_execution_rings
                        [tcb^.flag_execution_ring [f]];
                IFEND;
              IFEND;
            IFEND;

          = tmc$x_bracket_delay =
            IF (preempted_ring >= x_attributes.recognition_ring) THEN
              IF (preempted_ring >= x_attributes.high_execution_ring) THEN
                tcb^.flag_execution_ring [f] := x_attributes.high_execution_ring;
                allocated_execution_rings := allocated_execution_rings + $tmt$allocated_execution_rings
                      [tcb^.flag_execution_ring [f]];
              ELSE
                IF (preempted_ring >= x_attributes.low_execution_ring) THEN
                  tcb^.flag_execution_ring [f] := preempted_ring;
                  allocated_execution_rings := allocated_execution_rings + $tmt$allocated_execution_rings
                        [tcb^.flag_execution_ring [f]];
                IFEND;
              IFEND;
            IFEND;

          = tmc$wait =
            IF (tmc$wait IN x_attributes.preempt_wait) THEN
              IF (preempted_ring >= x_attributes.high_execution_ring) THEN
                tcb^.flag_execution_ring [f] := x_attributes.high_execution_ring;
                allocated_execution_rings := allocated_execution_rings + $tmt$allocated_execution_rings
                      [tcb^.flag_execution_ring [f]];
              ELSE
                IF (preempted_ring >= x_attributes.low_execution_ring) THEN
                  tcb^.flag_execution_ring [f] := preempted_ring;
                  allocated_execution_rings := allocated_execution_rings + $tmt$allocated_execution_rings
                        [tcb^.flag_execution_ring [f]];
                IFEND;
              IFEND;
            ELSE
              set_delayed_preemption (x_attributes.recognition_ring - 1, status);
              IF status.normal THEN
                tcb^.flag_execution_ring [f] := tmc$delay_allocation;
              IFEND;
            IFEND;

          = tmc$long_term_wait =
            IF (tmc$long_term_wait IN x_attributes.preempt_wait) THEN
              IF (preempted_ring >= x_attributes.high_execution_ring) THEN
                tcb^.flag_execution_ring [f] := x_attributes.high_execution_ring;
                allocated_execution_rings := allocated_execution_rings + $tmt$allocated_execution_rings
                      [tcb^.flag_execution_ring [f]];
              ELSE
                IF (preempted_ring >= x_attributes.low_execution_ring) THEN
                  tcb^.flag_execution_ring [f] := preempted_ring;
                  allocated_execution_rings := allocated_execution_rings + $tmt$allocated_execution_rings
                        [tcb^.flag_execution_ring [f]];
                IFEND;
              IFEND;
            ELSE
              set_delayed_preemption (x_attributes.recognition_ring - 1, status);
              IF status.normal THEN
                tcb^.flag_execution_ring [f] := tmc$delay_allocation;
              IFEND;
            IFEND;

          = tmc$task_termination =
            IF (preempted_ring >= x_attributes.high_execution_ring) THEN
              tcb^.flag_execution_ring [f] := x_attributes.high_execution_ring;
              allocated_execution_rings := allocated_execution_rings + $tmt$allocated_execution_rings
                    [tcb^.flag_execution_ring [f]];
            ELSE
              IF (preempted_ring >= x_attributes.low_execution_ring) THEN
                tcb^.flag_execution_ring [f] := preempted_ring;
                allocated_execution_rings := allocated_execution_rings + $tmt$allocated_execution_rings
                      [tcb^.flag_execution_ring [f]];
              IFEND;
            IFEND;
          CASEND;
        IFEND;
      FOREND;
      i#restore_traps (traps);
    CASEND;

  PROCEND tmp$allocate_execution_rings;
?? OLDTITLE ??
MODEND tmm$allocate_execution_rings;

*DECK DECK=TMM$BROKEN_TASK_FAULT_PROCESSOR EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Control - Program Conditions' ??
MODULE tmm$broken_task_fault_processor;
{ PURPOSE:
{   This module contains and restricts the knowledge necessary to dispose
{   of the broken task monitor fault.
{
{ DESIGN:
{   The procedure in this module are designed to have an execute bracket
{   of 1, 13 and a call bracket of 13.
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osc$processor_defined_registers
*copyc osd$registers
*copyc osd$virtual_address
*copyc ost$monitor_fault
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc tmt$broken_task_monitor_fault
*copyc pme$condition_exceptions
?? POP ??
*copyc clp$convert_integer_to_rjstring
*copyc osp$generate_log_message
*copyc osp$monitor_fault_to_status
*copyc osp$system_error
*copyc pmp$push_task_debug_mode
*copyc pmp$exit
*copyc pmp$abort
*copyc pmp$debug_logging_enabled
*copyc pmp$log_ascii
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] tmp$dispose_of_broken_task', EJECT ??
*copy tmh$dispose_of_broken_task

  PROCEDURE [XDCL] tmp$dispose_of_broken_task
    (    fault: ost$monitor_fault;
         sfsa: ^ost$stack_frame_save_area);

    CONST
      empty_p_register_string = 'P = 0 000 00000000';

    VAR
      broken_task: ^tmt$broken_task_monitor_fault,
      ignore_status: ost$status,
      inhibit_frame: ^ost$stack_frame_save_area,
      logset: pmt$ascii_logset,
      minimum_save_area_p: ^ost$minimum_save_area,
      p_register_text: string (18),
      status: ost$status;

    logset := $pmt$ascii_logset [pmc$job_log];
    IF pmp$debug_logging_enabled () THEN
      logset := logset + $pmt$ascii_logset [pmc$system_log];
    IFEND;
    p_register_text := empty_p_register_string;

{ Truncate the stack to inhibit PMP$EXIT from popping stack frames.  This allows
{ for the "problem area" of the stack to remain entact for a dump.  The stack is
{ truncated when the procedure causing the monitor fault is reached.

    minimum_save_area_p := ^sfsa^.minimum_save_area;
    inhibit_frame := #PREVIOUS_SAVE_AREA ();
    WHILE (inhibit_frame^.minimum_save_area.a2_previous_save_area <> NIL) DO
      IF inhibit_frame^.minimum_save_area.a2_previous_save_area = sfsa THEN
        inhibit_frame^.minimum_save_area.a2_previous_save_area := NIL;
      ELSE
        inhibit_frame := inhibit_frame^.minimum_save_area.a2_previous_save_area;
      IFEND;
    WHILEND;

    broken_task := #LOC (fault.contents);
    CASE broken_task^.broken_task_condition OF
    = tmc$btc_mntr_fault_buffer_full =
      osp$monitor_fault_to_status (fault, minimum_save_area_p, status);

    = tmc$btc_mf_traps_disabled =
      osp$monitor_fault_to_status (fault, minimum_save_area_p, status);

    = tmc$btc_invalid_a0 =
      osp$monitor_fault_to_status (fault, minimum_save_area_p, status);
      IF status.condition = pme$inconsistent_stack THEN
        pmp$push_task_debug_mode (pmc$debug_mode_off, ignore_status);
        pmp$abort (status);
      IFEND;

    = tmc$btc_invalid_p =
      osp$monitor_fault_to_status (fault, minimum_save_area_p, status);

    = tmc$btc_mcr_traps_disabled =
      osp$monitor_fault_to_status (fault, minimum_save_area_p, status);

    = tmc$btc_ucr_traps_disabled =
      osp$monitor_fault_to_status (fault, minimum_save_area_p, status);

    = tmc$btc_system_error =
      pmp$log_ascii ('* * * SYSTEM ERROR * * *', logset, pmc$msg_origin_system, ignore_status);
      clp$convert_integer_to_rjstring (broken_task^.caller_p_register.pva.ring, 16, FALSE, '0',
            p_register_text (5), status);
      clp$convert_integer_to_rjstring (broken_task^.caller_p_register.pva.seg, 16, FALSE, '0',
            p_register_text (7, 3), status);
      clp$convert_integer_to_rjstring (broken_task^.caller_p_register.pva.offset, 16, FALSE, '0',
            p_register_text (11, 8), status);
      pmp$log_ascii (p_register_text, logset, pmc$msg_origin_system, ignore_status);
      pmp$log_ascii (broken_task^.text_p^, logset, pmc$msg_origin_system, ignore_status);
      IF (broken_task^.trap_enable = osc$traps_disabled) THEN
        pmp$log_ascii ('TRAPS DISABLED', logset, pmc$msg_origin_system, ignore_status);
      IFEND;
      IF (broken_task^.status_p <> NIL) AND (NOT broken_task^.status_p^.normal) THEN
        osp$generate_log_message (logset, broken_task^.status_p^, ignore_status);
      IFEND;
      osp$monitor_fault_to_status (fault, minimum_save_area_p, status);

    ELSE
      osp$monitor_fault_to_status (fault, minimum_save_area_p, status);
    CASEND;
    pmp$push_task_debug_mode (pmc$debug_mode_off, ignore_status);

    osp$generate_log_message (logset, status, ignore_status);
    pmp$exit (status);
  PROCEND tmp$dispose_of_broken_task;
?? POP ??
MODEND tmm$broken_task_fault_processor;
*DECK DECK=TMM$DISPATCHER EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Task Management : dispatcher' ??
MODULE tmm$dispatcher;


{
{  PURPOSE:
{     This module is used for managing the creation and deletion of tasks,
{     the creation and deletion of jobs, the status of tasks, and the
{     selection of tasks to execute.
{

*IF $variable(tmc$compile_test_harness declared) <> 'UNKNOWN'
  ?VAR
     debug: boolean := TRUE?;
*ELSE
  ?VAR
     debug: boolean := FALSE?;
*IFEND
?? PUSH (LISTEXT := ON) ??
*copyc mlt$c170_rqst_blk
*copyc tmt$rb_cycle
*copyc jmc$special_dispatch_priorities
*copyc osc$multiprocessor_constants
*copyc osc$system_table_lock_set
*copyc osc$table_lock_activity
*copyc ost$status
*copyc osk$keypoints
*copyc osk$keypoint_class_codes
*copyc ptk$performance_keypoints
*copyc ost$cpu_state_table
*copyc osc$processor_defined_registers
*copyc osc$purge_map_and_cache
*copyc gft$locked_file_desc_entry_p
*copyc jmt$ijl_p
*copyc jmt$ijl_swap_status
*copyc jmt$ijle_size
*copyc jmt$initiated_job_list_p
*copyc jmt$swapout_reasons
*copyc jst$ijl_swap_queue_link
*copyc ost$execution_control_block
*copyc ost$heap
*copyc ost$keypoint_class
*copyc jmt$dispatching_control
*copyc jmt$dispatching_control_index
*copyc jmt$dispatching_priority
*copyc jmt$dispatching_priority_set
*copyc ost$global_task_id
*copyc ost$name
*copyc mtc$job_fixed_segment
*copyc jme$job_scheduler_conditions
*copyc jse$condition_codes
*copyc mme$condition_codes
*copyc jmt$active_job_list
*copyc jmc$null_ajl_ordinal
*copyc jmt$service_class_index
*copyc mmt$rb_lock_unlock_segment
*copyc pmt$signal
*copyc tmt$task_queue_link
*copyc tmt$ptl_lock
*copyc syt$debug_control
*copyc syv$perf_keypoints_enabled
*copyc tmt$cpu_execution_statistics
*copyc tmt$dispatching_controls
*copyc tmt$dispatching_control_sets
*copyc tmt$dispatching_prio_controls
*copyc tmt$dual_state_dispatch_prior
*copyc tmt$fnx_search_type
*copyc tmt$idle_resume_sys_task_kind
*copyc tmt$rb_delay
*copyc tmt$rb_wait
*copyc tmt$rb_fetch_task_statistics
*copyc tmt$rb_update_job_task_enviro
*copyc tmt$rb_get_job_fixed_segment
*copyc tmt$rb_terminate_task
*copyc tmt$rb_initiate_job
*copyc tmt$rb_exit_job
*copyc tmt$rb_initiate_task
*copyc tmt$rb_exit_task
*copyc tmt$rb_task_exit
*copyc tmt$system_task_id
*copyc tmt$task_status
*copyc tmc$free_flag_id
*copyc tme$monitor_mode_exceptions
*copyc tmt$dispatch_control_table
*copyc jmt$initiated_job_list_entry
*copyc tmt$primary_task_list
*copyc tmk$monitor_mode_keypoints
?? POP ??
?? SKIP := 3 ??
*copyc gfp$mtr_get_fde_p
*copyc gfp$mtr_get_locked_fde_p
*copyc jmp$change_ijl_entry_status
*copyc jmp$decrement_swapped_job_count
*copyc jmp$get_ijle_p
*copyc jmp$increment_swapped_job_count
*copyc jmp$ready_task_in_swapped_job
*copyc jmp$set_job_terminated
*copyc jmp$set_scheduler_event
*copyc jmp$set_swapout_candidate
*copyc jmp$subsystem_priority_change
*copyc jmp$swap_non_dispatchable_job
*copyc jmp$assign_ajl_entry
*copyc jmp$free_ajl_entry
*copyc jmp$free_ajl_with_lock
*copyc jmp$unlock_ajl_with_lock
*copyc jmp$update_service_class_stats
*copyc jsp$idle_tasks_complete
*copyc jsp$long_wait_aging
*copyc jsp$relink_swap_queue
*copyc jsp$set_delayed_swapin_work_mtr
*copyc mtp$error_stop
*copyc mtp$interrupt_processor
*copyc mtxms
*copyc mmp$create_task
*copyc mmp$exit_task
*copyc mmp$create_job
*copyc mmp$exit_job
*copyc mmp$get_sdtx_entry_p
*copyc i#move
*copyc i#mtr_disable_traps
*copyc i#mtr_restore_traps
*copyc mtp$cst_p
*copyc mtp$set_status_abnormal
*copyc osp$update_job_keypoint_mask
*copyc tmp$check_ptl_lock
*copyc tmp$get_xcb_access_status
*copyc tmp$set_system_flag
*copyc tmp$set_monitor_flag
*copyc tmp$send_signal
*copyc tmp$update_system_task_list
?? SKIP := 3 ??
{Define global and external variables.
*copyc mtv$scb
*copyc tmv$null_global_task_id
*copyc mtv$monitor_segment_table
*copyc osv$cpus_logically_on
*copyc osv$cpus_physically_configured
*copyc osv$keypoint_control
*copyc jmv$idle_dispatching_controls
*copyc jmv$ijl_entry_status_statistics
*copyc jmv$job_counts
*copyc jmv$service_classes
*copyc jmv$null_ijl_ordinal
*copyc jmv$subsystem_priority_changes
*copyc mmv$ast_p
  VAR
    null_pva: 0 .. 0ffffffffffff(16),
    osv$system_family_name: [XDCL, #GATE] ost$name := '$SYSTEM                        ',
    jmv$system_core_id: [XDCL, #GATE] ost$name,
    mtv$cpu1_dedicated_to_nos: [XREF] boolean,
    tmv$cpu_execution_statistics: [XDCL, #GATE] tmt$cpu_execution_statistics,
    tmv$dct_priority_integer: integer,
    tmv$dispatch_priority_integer: [XDCL, #GATE] ARRAY [jmt$dispatching_priority] of integer,
    tmv$dispatching_controls: [XDCL] tmt$dispatching_controls,
    tmv$dispatching_control_sets: [XDCL, #GATE] tmt$dispatching_control_sets,
    tmv$dispatching_control_time: [XDCL] tmt$dispatching_prio_controls,
    tmv$dual_state_dispatch_prior: [XDCL, #GATE] tmt$dual_state_dispatch_prior :=
      [[1, 8], [1, 8], [2, 8], [2, 8], [3, 8], [3, 8], [4, 8], [4, 8], [5, 8], [5, 8],
       [6, 8], [6, 8], [7, 8], [7, 8]],
    tmv$dual_state_prio_mask: jmt$dispatching_priority_set,
    tmv$io_wait_task_count: 0 .. tmc$maximum_ptl := 0,
    tmv$multiple_cpus_active: [XDCL, #GATE] boolean := FALSE,
    tmv$swapin_in_progress: [XDCL] integer := 0,
    tmv$time_to_call_dispatcher: [XDCL] integer := 0,
    tmv$timed_wait_not_queued: [XDCL, #GATE] integer := 600000000,
    tmv$timed_wait_queue: tmt$task_queue_link := [0, 0],
    tmv$total_task_count: [XDCL, #GATE] 0 .. tmc$maximum_ptl := 0,
    tmv$long_wait_swap_time: [XDCL, #GATE] integer := 6000000,
    tmv$long_wait_force_swap_time: [XDCL, #GATE] integer := 6000000,
    tmv$cycle_delay_time: [XDCL, #GATE] integer := 20000,
    mlv$c170_rqst_blk: [XREF] mlt$c170_rqst_blk,
    tmv$tables_initialized: [XDCL, #GATE] boolean := FALSE,
    syv$debug_control: [XDCL, #GATE] syt$debug_control,
    syv$all_jobs_selected_for_debug: [XDCL, #GATE] boolean := FALSE,
    tmv$ptl_lock: [XDCL] tmt$ptl_lock := [FALSE, 0],
    tmv$system_job_monitor_gtid: [XDCL] ost$global_task_id := [1, 1],
    job_time_zero: [XDCL] integer := 0,
    tmv$ptl_p: [XDCL, #GATE] ^tmt$primary_task_list,
    jmv$ajl_p: [XDCL, #GATE] ^jmt$active_job_list := NIL,
    jmv$ijl_p: [XDCL, #GATE] jmt$ijl_p := [NIL, 0, 0],
    jmv$ijle_size: [XDCL, #GATE] jmt$ijle_size := 0,
    jmv$swap_jobs_in_long_wait: [XDCL, #GATE] boolean := TRUE,
    jmv$system_ajl_ordinal: [XDCL, #GATE] jmt$ajl_ordinal := 0,
    jmv$system_ijl_ordinal: [XDCL, #GATE] jmt$ijl_ordinal := [0, 0],
    osv$special_aam_trap: [XDCL, #GATE] boolean := FALSE,
    pmv$quantum: [XDCL, #GATE] integer := 50000,
    tmv$dedicate_a_cpu_to_nos: [XDCL, #GATE] boolean := FALSE,
    tmv$subsystem_prior_threshold: [XDCL] 0 .. 0ff(16) := 5,
    tmv$dct: [XDCL, #GATE] tmt$dispatch_control_table;


{Define types and variables for tracing CYCLE requests. Note that the code to trace CYCLE requests
{is normally disabled and a special version of the system must be built to record information.
  ?VAR
    tmc$debug_cycle_requests: boolean := FALSE?;

  TYPE
    cyctrace = record
      code: tmc$cycle_reason,
      status: tmt$task_status,
      p1: ^cell,
      p2: ^cell,
      gtid: ost$global_task_id,
      xtask: ost$task_index,
      time: 0 .. 0ffffffffffff(16),
      p: ost$pva,
      utp: ^cell,
    recend;

  ?IF tmc$debug_cycle_requests THEN

    VAR
      osv$debug: [XREF] integer,
      tmv$cycle_trace: [XDCL, #GATE] array [0 .. 10001] of cyctrace,
      ti: [STATIC] integer;

  ?IFEND

  TYPE

{ Priority_mask and dp_trick_conversion are types for the variable that is
{ used to determine the priority to be considered for select_next_task.
{ #unchecked_conversion is used to "pull off" the leftmost bit set.

    priority_mask = packed record
      fill: 0..0ff(16),
      set_number: 0..0f(16),
      dp: jmt$dispatching_priority,
      fill2: 0..0ffffffffffff(16),
    recend,

    dp_trick_conversion = record
      case 0..1 of
      = 0 =
        r: real,
      = 1 =
        dp_mask: priority_mask,
      casend,
    recend;


?? EJECT ??
*copyc tmp$set_lock
*copyc tmp$clear_lock

?? TITLE := '[XDCL, INLINE] tmp$check_taskid, tmp$check_taskid_with_lock_set', EJECT ??

  PROCEDURE [XDCL, INLINE] tmp$check_taskid
    (    taskid: ost$global_task_id;
         option: tmt$option;
     VAR status: syt$monitor_status);

*copyc tmh$check_taskid

    status.normal := TRUE;
    tmp$set_lock (tmv$ptl_lock);
    IF (taskid = tmv$null_global_task_id) OR (taskid.index > UPPERBOUND (tmv$ptl_p^)) OR
          (tmv$ptl_p^ [taskid.index].sequence_number <> taskid.seqno) OR
          (tmv$ptl_p^ [taskid.index].status = tmc$ts_null) THEN
      tmp$clear_lock (tmv$ptl_lock);
      IF option = tmc$opt_return THEN
        mtp$set_status_abnormal ('TM', tme$invalid_global_taskid, status);
        RETURN;
      ELSE
        mtp$error_stop ('TM01 - taskid error');
      IFEND;
    IFEND;
    tmp$clear_lock (tmv$ptl_lock);
  PROCEND tmp$check_taskid;
?? SKIP := 3 ??
  PROCEDURE [XDCL, INLINE] tmp$check_taskid_with_lock_set
    (    taskid: ost$global_task_id;
         option: tmt$option;
     VAR status: syt$monitor_status);

*copyc tmh$check_taskid_with_lock_set

    status.normal := TRUE;
    IF (taskid = tmv$null_global_task_id) OR (taskid.index > UPPERBOUND (tmv$ptl_p^)) OR
          (tmv$ptl_p^ [taskid.index].sequence_number <> taskid.seqno) OR
          (tmv$ptl_p^ [taskid.index].status = tmc$ts_null) THEN
      IF option = tmc$opt_return THEN
        mtp$set_status_abnormal ('TM', tme$invalid_global_taskid, status);
        RETURN;
      ELSE
        mtp$error_stop ('TM01 - taskid error');
      IFEND;
    IFEND;
  PROCEND tmp$check_taskid_with_lock_set;

?? TITLE := '[INLINE] tmp$stop_if_bad_taskid', EJECT ??

  PROCEDURE [INLINE] tmp$stop_if_bad_taskid
    (    taskid: ost$global_task_id);

{ NOTE: The caller of this procedure MUST set the PTL lock.

    IF (taskid = tmv$null_global_task_id) OR (taskid.index > UPPERBOUND (tmv$ptl_p^)) OR
          (tmv$ptl_p^ [taskid.index].sequence_number <> taskid.seqno) OR
          (tmv$ptl_p^ [taskid.index].status = tmc$ts_null) THEN
      mtp$error_stop ('TM01 - taskid error');
    IFEND;

  PROCEND tmp$stop_if_bad_taskid;
?? TITLE := ' TMP$OBTAIN_IJL_ORDINAL_FOR_PTL ', EJECT ??

  PROCEDURE [XDCL, INLINE] tmp$obtain_ijl_ordinal_from_ptl
    (    global_task_id: ost$global_task_id;
     VAR ijl_ordinal: jmt$ijl_ordinal);

    ijl_ordinal := tmv$ptl_p^ [global_task_id.index].ijl_ordinal;

  PROCEND tmp$obtain_ijl_ordinal_from_ptl;
?? TITLE := 'ASSIGN_PTL, FREE_PTL', EJECT ??

  PROCEDURE [INLINE]  tmp$assign_ptl
    (    xcb_p: ^ost$execution_control_block;
         ijl_ordinal: jmt$ijl_ordinal;
     VAR taskid: ost$global_task_id;
     VAR status: syt$monitor_status);

{
{  The purpose of this procedure is to assign PTL entries from
{  the free queue.  An error status is returned if the PTL is full.
{
{    ASSIGN_PTL (XCB_P, JOB_ID, TASKID, STATUS)
{
{  XCB_P : (INPUT) This parameter specifies the pointer to XCB.
{
{  JOB_ID : (INPUT) This parameter specifies the ordinal of the
{                   active job list entry for the job.
{
{  TASKID : (OUTPUT) This parameter specifies the taskid assigned
{                    to the task.
{
{  STATUS : (OUTPUT) This parameter specifies the error status.
{
{  NOTE : Anyone calling this procedure must have tmv$ptl_lock set.
{

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      next_avail_ptlo: ost$task_index,
      ptl_p: ^tmt$primary_task_list_entry;



{Check if PTL space is available.

    status.normal := TRUE;
    next_avail_ptlo := tmv$dct [jmc$null_dispatching_priority].queue_head;
    IF next_avail_ptlo = 0 THEN
      mtp$set_status_abnormal ('TM', tme$ptl_full, status);
      RETURN;
    IFEND;
    ptl_p := ^tmv$ptl_p^ [next_avail_ptlo];
    tmv$dct [jmc$null_dispatching_priority].queue_head := ptl_p^.ptl_thread;

{ If the job is selected for system breakpoints, set the flag for the task to set up debug registers.

    jmp$get_ijle_p (ijl_ordinal, ijle_p);
    IF ijle_p^.system_breakpoint_selected THEN
      ptl_p^.monitor_flags := $syt$monitor_flags [syc$mf_system_debugger];
    ELSE
      ptl_p^.monitor_flags := $syt$monitor_flags [];
    IFEND;

{Initialize the PTL entry.

    xcb_p^.keypoint_enable := FALSE;
    xcb_p^.keypoint_register_enable := FALSE;
    ptl_p^.status := tmc$ts_ready;
    ptl_p^.ijl_ordinal := ijl_ordinal;
    ptl_p^.xcb_offset := #OFFSET (xcb_p);
    ptl_p^.dispatching_priority := xcb_p^.dispatching_priority;
    ptl_p^.sequence_number := ptl_p^.sequence_number MOD 255 + 1;
    ptl_p^.system_flags := $tmt$system_flags [];
    ptl_p^.idle_status := tmc$is_not_idled;
    ptl_p^.queue_link.head := 0;
    ptl_p^.queue_link.tail := 0;
    ptl_p^.end_of_wait_time := 0;
    ptl_p^.readying_task_priority := 0;
    taskid.index := next_avail_ptlo;
    taskid.seqno := ptl_p^.sequence_number;

  PROCEND tmp$assign_ptl;
?? SKIP := 3 ??

{  NOTE : Anyone calling this routine must have tmv$ptl_lock set.
{  The caller must also call the procedure remove_ijl to remove the task from the ijl_thread,
{  which links all tasks of a job, if the task being freed is NOT the job monitor task.
{  If all tasks are being freed, the caller can zero out the ijl_thread.

  PROCEDURE [INLINE] free_ptl
    (    ptlo: ost$task_index);

    tmv$ptl_p^ [ptlo].status := tmc$ts_null;
    tmv$ptl_p^ [ptlo].dispatching_priority := jmc$null_dispatching_priority;
    tmv$ptl_p^ [ptlo].ptl_thread := 0;
    IF tmv$dct [jmc$null_dispatching_priority].queue_head = 0 THEN
      tmv$dct [jmc$null_dispatching_priority].queue_head := ptlo;
    ELSE
      tmv$ptl_p^ [tmv$dct [jmc$null_dispatching_priority].queue_tail].ptl_thread := ptlo;
    IFEND;
    tmv$dct [jmc$null_dispatching_priority].queue_tail := ptlo;
  PROCEND free_ptl;
?? TITLE := 'REMOVE_TASK_FROM_DCT', EJECT ??

  PROCEDURE  [INLINE]  tmp$remove_task_from_dct
    (    ptlo: ost$task_index);

{
{  The purpose of this procedure is to remove the current task's
{  PTL entry from the DCT thread.
{
{    REMOVE_TASK_FROM_DCT (PTLO)
{
{  PTLO : (INPUT) This parameter specifies the PTL index of the
{                   specified task.
{
{  NOTE : Anyone calling this procedure must have tmv$ptl_lock set.
{

    VAR
      dcte: tmt$dct_entry,
      scan_ptlo: ost$task_index,
      save_ptlo: ost$task_index,
      ptle_p: ^tmt$primary_task_list_entry;

    ptle_p := ^tmv$ptl_p^ [ptlo];
    dcte := tmv$dct [ptle_p^.dispatching_priority];

    IF dcte.queue_tail = dcte.queue_head THEN
      IF dcte.queue_head <> ptlo THEN
        mtp$error_stop ('TM--remove task from empty DCT');
      IFEND;
      dcte.queue_tail := 0;
      dcte.queue_head := 0;
      dcte.minor_priority := 0;
      dcte.major_priority := 0;
      tmv$dispatching_control_sets.ready_tasks := tmv$dispatching_control_sets.ready_tasks -
            $jmt$dispatching_priority_set [jmc$dp_conversion - ptle_p^.dispatching_priority];
      tmp$calculate_dct_priority_int;
    ELSEIF ptlo = dcte.queue_head THEN
      dcte.queue_head := ptle_p^.ptl_thread;
      IF ptlo = dcte.major_priority THEN
        dcte.major_priority := ptle_p^.ptl_thread;
      IFEND;
      IF ptlo = dcte.minor_priority THEN
        dcte.minor_priority := ptle_p^.ptl_thread;
      IFEND;
    ELSE
      scan_ptlo := dcte.queue_head;
      WHILE scan_ptlo <> ptlo DO
        save_ptlo := scan_ptlo;
        scan_ptlo := tmv$ptl_p^ [scan_ptlo].ptl_thread;
        IF scan_ptlo = 0 THEN
         mtp$error_stop ('TM-cant find ptlo to remove from DCT');
        IFEND;
      WHILEND;
      tmv$ptl_p^ [save_ptlo].ptl_thread := tmv$ptl_p^ [ptlo].ptl_thread;
      IF ptlo = dcte.queue_tail THEN
        dcte.queue_tail := save_ptlo;
      IFEND;
      IF ptlo = dcte.major_priority THEN
        dcte.major_priority := save_ptlo;
      IFEND;
      IF ptlo = dcte.minor_priority THEN
        dcte.minor_priority := save_ptlo;
      IFEND;
    IFEND;
    ptle_p^.ptl_thread := 0;
    tmv$dct [ptle_p^.dispatching_priority] := dcte;

  PROCEND tmp$remove_task_from_dct;

?? TITLE := 'REMOVE_TASK_FROM_FREE_QUEUE', EJECT ??

  PROCEDURE [INLINE] remove_task_from_free_queue
    (    ptlo: ost$task_index);

{
{  The purpose of this procedure is to remove a task's PTL entry
{  from the free DCT thread.
{
{    REMOVE_TASK_FROM_FREE_QUEUE (PTLO)
{
{  PTLO : (INPUT) This parameter specifies the PTL index of the
{                   specified task.
{
{  NOTE : Anyone calling this procedure must have tmv$ptl_lock set.
{

    VAR
      dcte: tmt$dct_entry,
      save_ptlo: ost$task_index,
      scan_ptlo: ost$task_index,
      ptle_p: ^tmt$primary_task_list_entry;

    ptle_p := ^tmv$ptl_p^ [ptlo];
    dcte := tmv$dct [jmc$null_dispatching_priority];

    IF dcte.queue_tail = dcte.queue_head THEN
      IF dcte.queue_head <> ptlo THEN
        mtp$error_stop ('TM--task not in free queue');
      IFEND;
      dcte.queue_head := 0;
      dcte.queue_tail := 0;
    ELSEIF ptlo = dcte.queue_head THEN
      dcte.queue_head := ptle_p^.ptl_thread;
    ELSE
      scan_ptlo := dcte.queue_head;
      WHILE (scan_ptlo <> ptlo) AND (scan_ptlo <> 0) DO
        save_ptlo := scan_ptlo;
        scan_ptlo := tmv$ptl_p^ [scan_ptlo].ptl_thread;
      WHILEND;
      IF scan_ptlo = 0 THEN
        mtp$error_stop ('TM--task not in free queue');
      IFEND;
      tmv$ptl_p^ [save_ptlo].ptl_thread := tmv$ptl_p^ [ptlo].ptl_thread;
      IF ptlo = dcte.queue_tail THEN
        dcte.queue_tail := save_ptlo;
      IFEND;
    IFEND;
    tmv$dct [jmc$null_dispatching_priority] := dcte;

  PROCEND remove_task_from_free_queue;

?? TITLE := '[INLINE] tmp$dct_ready_task', EJECT ??
*copyc tmh$dct_ready_task

  PROCEDURE [INLINE] tmp$dct_ready_task
    (     xcb_p: ^ost$execution_control_block;
          ijle_p: ^jmt$initiated_job_list_entry;
          ptlo: ost$task_index;
          attempt_preselection: boolean);

    VAR
      cst_index: integer,
      cst_p: ^ost$cpu_state_table,
      dcte: tmt$dct_entry,
      dct_placement: (minor_timeslice_insert, major_timeslice_insert, tail_timeslice_insert),
      insert_ptle_p: ^tmt$primary_task_list_entry,
      insert_ijle_p: ^jmt$initiated_job_list_entry,
      low_priority: integer,
      low_prio_csti: integer,
      ptle_p: ^tmt$primary_task_list_entry,
      timeslice: jmt$time_slice_values;

    ptle_p := ^tmv$ptl_p^ [ptlo];

   ?IF NOT debug THEN
      timeslice := jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.attributes.
          dispatching_control [ijle_p^.dispatching_control.dispatching_control_index].dispatching_timeslice;
   ?ELSE
      timeslice.minor := 50;
      timeslice.major := 50;
   ?IFEND;

{ Determine where the task is to be positioned in the DISPATCH_CONTROL_TABLE.

    IF xcb_p^.timeslice.minor > (timeslice.minor DIV 8) THEN
      dct_placement := minor_timeslice_insert;
    ELSEIF xcb_p^.timeslice.major > (timeslice.minor DIV 8) THEN
      dct_placement := major_timeslice_insert;
      xcb_p^.timeslice.minor := timeslice.minor;
    ELSE
      dct_placement := tail_timeslice_insert;
      xcb_p^.timeslice.major := timeslice.major;
      xcb_p^.timeslice.minor := timeslice.minor;
    IFEND;

{ If a task has subsystem table locks set for more than the subsystem lock threshold, then
{ lower the tasks priority. If the task received a READY request while it had subsystem
{ locks set, the priority is lowered to the greater of the task's or the READYING task's
{ dispatching priority.

    IF (xcb_p^.system_table_lock_count > 0) THEN
      IF (xcb_p^.system_table_lock_count < osc$system_table_lock_set) THEN
        IF xcb_p^.subsystem_lock_priority_count >= tmv$subsystem_prior_threshold THEN
          IF (xcb_p^.dispatching_priority < ptle_p^.readying_task_priority) THEN
            ptle_p^.dispatching_priority := ptle_p^.readying_task_priority;
          ELSE
            ptle_p^.dispatching_priority := xcb_p^.dispatching_priority;
          IFEND;
          xcb_p^.subsystem_give_up_cpu := TRUE;
        ELSE
          IF ptle_p^.dispatching_priority < jmc$prior_subsystem_tbls_locked THEN
            ptle_p^.dispatching_priority := jmc$prior_subsystem_tbls_locked;
          IFEND;
          IF dct_placement <> minor_timeslice_insert THEN
            xcb_p^.subsystem_lock_priority_count := xcb_p^.subsystem_lock_priority_count + 1;
          IFEND;
          xcb_p^.subsystem_give_up_cpu := TRUE;
        IFEND;
      ELSE
        xcb_p^.system_give_up_cpu := TRUE;
        IF ptle_p^.dispatching_priority < jmc$prior_system_tbls_locked THEN
          ptle_p^.dispatching_priority := jmc$prior_system_tbls_locked;
        IFEND;
      IFEND;
    IFEND;

{ Determine if the priority is high enough to preempt a task that is currently executing.
{ Send an interrupt to the processor executing the lowest priority task (or an idle processor).

    IF attempt_preselection THEN

      low_priority := tmv$dispatch_priority_integer [ptle_p^.dispatching_priority];
      mtp$cst_p (cst_p);
      cst_index := osv$cpus_physically_configured - 1;
      low_prio_csti := -1;
      /preselect_loop/
      BEGIN
      REPEAT
        IF (mtv$cst0 [cst_index].dispatching_priority_integer < low_priority)
            AND (cst_index IN xcb_p^.processor_selections) THEN
          IF mtv$cpu1_dedicated_to_nos AND (cst_index = 1) THEN
            EXIT /preselect_loop/;
          IFEND;
          low_prio_csti := cst_index;
          low_priority := mtv$cst0 [cst_index].dispatching_priority_integer;
        IFEND;
        cst_index := cst_index - 1;
      UNTIL (cst_index < 0) OR (low_priority = 0);
      END  /preselect_loop/;

      IF low_prio_csti >= 0 THEN
        IF (mtv$cst0 [low_prio_csti].next_ptlo_to_dispatch <> 0) THEN

{ A task has already been pre-selected to run on the pre-selected processor.  The task must be inserted
{ at the head of its priority DCT queue.

          insert_ptle_p := ^tmv$ptl_p^ [mtv$cst0 [low_prio_csti].next_ptlo_to_dispatch];
          jmp$get_ijle_p (insert_ptle_p^.ijl_ordinal, insert_ijle_p);
          insert_ijle_p^.executing_task_count := insert_ijle_p^.executing_task_count - 1;
          insert_ptle_p^.status := tmc$ts_ready;
          dcte := tmv$dct [insert_ptle_p^.dispatching_priority];
          IF dcte.queue_head = 0 THEN
            insert_ptle_p^.ptl_thread := 0;
            dcte.queue_head := mtv$cst0 [low_prio_csti].next_ptlo_to_dispatch;
            dcte.queue_tail := mtv$cst0 [low_prio_csti].next_ptlo_to_dispatch;
            dcte.minor_priority := mtv$cst0 [low_prio_csti].next_ptlo_to_dispatch;
            dcte.major_priority := mtv$cst0 [low_prio_csti].next_ptlo_to_dispatch;
            tmv$dispatching_control_sets.ready_tasks := tmv$dispatching_control_sets.ready_tasks +
                  $jmt$dispatching_priority_set [jmc$dp_conversion -
                  insert_ptle_p^.dispatching_priority];
            tmp$calculate_dct_priority_int;
          ELSE
            insert_ptle_p^.ptl_thread := dcte.queue_head;
            dcte.queue_head := mtv$cst0 [low_prio_csti].next_ptlo_to_dispatch;
          IFEND;
          tmv$dct [insert_ptle_p^.dispatching_priority] := dcte;
        IFEND;

        mtv$cst0 [low_prio_csti].next_ptlo_to_dispatch := ptlo;
        mtv$cst0 [low_prio_csti].dispatching_priority_integer := tmv$dispatch_priority_integer
              [ptle_p^.dispatching_priority];
        mtv$cst0 [low_prio_csti].dispatch_control.call_dispatcher := TRUE;
        ptle_p^.status := tmc$ts_ready_and_selected;
        ijle_p^.executing_task_count := ijle_p^.executing_task_count + 1;
        IF (low_prio_csti <> cst_p^.cst_index) AND ((low_priority <> 0 ) OR
              (mtv$cst0 [low_prio_csti].dual_state_jps <> 0)) THEN
          mtp$interrupt_processor (mtv$cst0 [low_prio_csti].memory_port_mask);
        IFEND;
        RETURN;
      IFEND; {  low_prio_csti >= 0 }
    ELSE
      tmv$dual_state_prio_mask := tmv$dual_state_prio_mask +
            $jmt$dispatching_priority_set [jmc$dp_conversion - ptle_p^.dispatching_priority];
    IFEND; { attempt_preselection }

{ If no processor is executing a task with a lower priority then the task being readied must be
{ placed in the DCT queue.

    dcte := tmv$dct [ptle_p^.dispatching_priority];

    IF dcte.queue_head = 0 THEN
      ptle_p^.ptl_thread := 0;
      dcte.queue_head := ptlo;
      dcte.queue_tail := ptlo;
      dcte.minor_priority := ptlo;
      dcte.major_priority := ptlo;
      tmv$dispatching_control_sets.ready_tasks := tmv$dispatching_control_sets.ready_tasks +
            $jmt$dispatching_priority_set [jmc$dp_conversion - ptle_p^.dispatching_priority];
      tmp$calculate_dct_priority_int;
      tmv$dct [ptle_p^.dispatching_priority] := dcte;
      RETURN;
    IFEND;  { dcte.queue_head = 0 }

    IF dct_placement = minor_timeslice_insert THEN
      ptle_p^.ptl_thread := tmv$ptl_p^ [dcte.minor_priority].ptl_thread;
      tmv$ptl_p^ [dcte.minor_priority].ptl_thread := ptlo;

{ The following is required to insure that the major pointer
{ is never higher than the minor pointer in the DCT.

      IF dcte.minor_priority = dcte.major_priority THEN
        dcte.major_priority := ptlo;
      IFEND;
      dcte.minor_priority := ptlo;
      IF ptle_p^.ptl_thread = 0 THEN
        dcte.queue_tail := ptlo;
      IFEND;
    ELSEIF dct_placement = major_timeslice_insert THEN
      ptle_p^.ptl_thread := tmv$ptl_p^ [dcte.major_priority].ptl_thread;
      tmv$ptl_p^ [dcte.major_priority].ptl_thread := ptlo;
      dcte.major_priority := ptlo;
      IF ptle_p^.ptl_thread = 0 THEN
        dcte.queue_tail := ptlo;
      IFEND;
    ELSEIF dct_placement = tail_timeslice_insert THEN
      tmv$ptl_p^ [dcte.queue_tail].ptl_thread := ptlo;
      ptle_p^.ptl_thread := 0;
      dcte.queue_tail := ptlo;
    ELSE
      mtp$error_stop (' TM99--Illegal insert ');
    IFEND;

  { If any task in a job has specified a relative task priority, all of
  { the tasks in the job are subject to the relative priority algorithms.

    IF (ijle_p^.relative_priority_enabled) AND (ijle_p^.statistics.
         ready_task_count > 1) THEN
      IF dct_placement = minor_timeslice_insert THEN
        relative_insert_minor_dct (xcb_p^.relative_task_priority, ptlo, ijle_p, dcte);
      ELSEIF dct_placement = major_timeslice_insert THEN
        relative_insert_major_dct (xcb_p^.relative_task_priority, ptlo, ijle_p, dcte);
      ELSEIF dct_placement = tail_timeslice_insert THEN
        relative_insert_tail_dct (xcb_p^.relative_task_priority, ptlo, ijle_p, dcte);
      IFEND;
    IFEND;

    tmv$dct [ptle_p^.dispatching_priority] := dcte;

  PROCEND tmp$dct_ready_task;

?? TITLE := 'RELATIVE_INSERT_MINOR_DCT', EJECT ??

  PROCEDURE  [INLINE] relative_insert_minor_dct
    (    relative_priority: 0 .. 255;
         ptlo: ost$task_index;
         ijl_p: ^jmt$initiated_job_list_entry;
     VAR dcte: tmt$dct_entry);

{ The following procedure is responsible for making sure a task which was
{ inserted in the MINOR timeslice position is corrected prioritized with the
{ other tasks of the same job. This job is currently running with relative
{ prioritization enabled. The position of tasks of other jobs can only be
{ improved, they will never regress.

     VAR
       insert_ptlo: ost$task_index,
       next_search_ptlo: ost$task_index,
       save_ptlo: ost$task_index,
       search_ptlo: ost$task_index,
       search_xcb: ^ost$execution_control_block;

  { Insert_ptlo is the most recently moved ptlo.
  { Search_ptlo is the task which we are currently testing for
  { possible movement.
  { Save_ptlo is the last task which was NOT moved.

     insert_ptlo := ptlo;
     search_ptlo := dcte.queue_head;
     save_ptlo := 0;

  { The task has been positioned in the DCT. Now, all the tasks of that
  { job (currently in DCT) must be prioritized. The task has been placed
  { in the minor priority position. Tasks above that point are checked to
  { determine if any of them have to be moved below the new task. If the
  { task is in the same job, and has a lower relative priority, the task is
  { moved below the new task.

     WHILE (search_ptlo <> ptlo) DO
       next_search_ptlo := tmv$ptl_p^ [search_ptlo].ptl_thread;
       IF (tmv$ptl_p^ [search_ptlo].ijl_ordinal = tmv$ptl_p^ [ptlo].ijl_ordinal) THEN
         search_xcb := #ADDRESS (1, ijl_p^.ajl_ordinal + mtc$job_fixed_segment,
           tmv$ptl_p^ [search_ptlo].xcb_offset);
         IF (search_xcb^.relative_task_priority < relative_priority) THEN
           IF search_ptlo = dcte.queue_head THEN
             dcte.queue_head := tmv$ptl_p^ [search_ptlo].ptl_thread;
           ELSE
             tmv$ptl_p^ [save_ptlo].ptl_thread := tmv$ptl_p^ [search_ptlo].ptl_thread;
           IFEND;
           tmv$ptl_p^ [search_ptlo].ptl_thread := tmv$ptl_p^ [insert_ptlo].ptl_thread;
           tmv$ptl_p^ [insert_ptlo].ptl_thread := search_ptlo;
           insert_ptlo := search_ptlo;
         ELSE
           save_ptlo := search_ptlo;
         IFEND;
       ELSE
         save_ptlo := search_ptlo;
       IFEND;
       search_ptlo := next_search_ptlo;
     WHILEND;

     IF insert_ptlo <> ptlo THEN

  { One or more tasks have been moved below the new task.

       IF dcte.minor_priority = dcte.major_priority THEN
         dcte.major_priority := insert_ptlo;
       IFEND;
       IF tmv$ptl_p^ [insert_ptlo].ptl_thread = 0 THEN
         dcte.queue_tail := insert_ptlo;
       IFEND;
       dcte.minor_priority := insert_ptlo;
     ELSE

{ There were not any tasks moved below the new task. We must now check to
{ see if there are any tasks below the new task, which have a relative priority
{ higher than the new task. A search is made of all of the tasks below the new
{ task, the new task is moved below the last task (of the same job) which
{ has a higher relative priority than the new task.

       insert_ptlo := 0;
       search_ptlo := tmv$ptl_p^ [ptlo].ptl_thread;
       WHILE search_ptlo <> 0 DO
         IF (tmv$ptl_p^ [search_ptlo].ijl_ordinal = tmv$ptl_p^ [ptlo].ijl_ordinal) THEN
           search_xcb := #ADDRESS (1, ijl_p^.ajl_ordinal + mtc$job_fixed_segment,
             tmv$ptl_p^ [search_ptlo].xcb_offset);
           IF (search_xcb^.relative_task_priority > relative_priority) THEN
             insert_ptlo := search_ptlo;
           IFEND;
         IFEND;
         search_ptlo := tmv$ptl_p^ [search_ptlo].ptl_thread;
       WHILEND;

       IF insert_ptlo <> 0 THEN
         IF ptlo = dcte.queue_head THEN
           dcte.queue_head := tmv$ptl_p^ [ptlo].ptl_thread;
         IFEND;
         IF ptlo = dcte.minor_priority THEN
           dcte.minor_priority := tmv$ptl_p^ [ptlo].ptl_thread;
         IFEND;
         IF insert_ptlo = dcte.major_priority THEN
           dcte.major_priority := ptlo;
         IFEND;
         tmv$ptl_p^ [save_ptlo].ptl_thread := tmv$ptl_p^ [ptlo].ptl_thread;
         tmv$ptl_p^ [ptlo].ptl_thread := tmv$ptl_p^ [insert_ptlo].ptl_thread;
         tmv$ptl_p^ [insert_ptlo].ptl_thread := ptlo;
         IF tmv$ptl_p^ [ptlo].ptl_thread = 0 THEN
           dcte.queue_tail := ptlo;
         IFEND;
       IFEND;
     IFEND;

   PROCEND relative_insert_minor_dct;
?? TITLE := 'RELATIVE_INSERT_MAJOR_DCT', EJECT ??

  PROCEDURE  [INLINE] relative_insert_major_dct
    (    relative_priority: 0 .. 255;
         ptlo: ost$task_index;
         ijl_p: ^jmt$initiated_job_list_entry;
     VAR dcte: tmt$dct_entry);

{ The following procedure is responsible for making sure a task which was
{ inserted in the MAJOR timeslice position is corrected prioritized with the
{ other tasks of the same job. This job is currently running with relative
{ prioritization enabled. The position of tasks of other jobs can only be
{ improved, they will never regress.

     VAR
       insert_ptlo: ost$task_index,
       next_search_ptlo: ost$task_index,
       save_ptlo: ost$task_index,
       search_ptlo: ost$task_index,
       search_xcb: ^ost$execution_control_block;

  { Insert_ptlo is the most recently moved ptlo.
  { Search_ptlo is the task which we are currently testing for
  { possible movement.
  { Save_ptlo is the last task which was NOT moved.

     insert_ptlo := ptlo;
     search_ptlo := dcte.queue_head;
     save_ptlo := 0;

  { The task has been positioned in the DCT. Now, all the tasks of that
  { job (currently in DCT) must be prioritized. The task has been placed
  { in the major priority position. Tasks above that point are checked to
  { determine if any of them have to be moved below the new task. If the
  { task is in the same job, and has a lower relative priority, the task is
  { moved below the new task.

     WHILE (search_ptlo <> ptlo) DO
       next_search_ptlo := tmv$ptl_p^ [search_ptlo].ptl_thread;
       IF (tmv$ptl_p^ [search_ptlo].ijl_ordinal = tmv$ptl_p^ [ptlo].ijl_ordinal) THEN
         search_xcb := #ADDRESS (1, ijl_p^.ajl_ordinal + mtc$job_fixed_segment,
           tmv$ptl_p^ [search_ptlo].xcb_offset);
         IF (search_xcb^.relative_task_priority < relative_priority) THEN
           IF search_ptlo = dcte.queue_head THEN
             dcte.queue_head := tmv$ptl_p^ [search_ptlo].ptl_thread;
           ELSE
             tmv$ptl_p^ [save_ptlo].ptl_thread := tmv$ptl_p^ [search_ptlo].ptl_thread;
           IFEND;
           IF search_ptlo = dcte.minor_priority THEN
             dcte.minor_priority := tmv$ptl_p^ [search_ptlo].ptl_thread;
           IFEND;
           tmv$ptl_p^ [search_ptlo].ptl_thread := tmv$ptl_p^ [insert_ptlo].ptl_thread;
           tmv$ptl_p^ [insert_ptlo].ptl_thread := search_ptlo;
           insert_ptlo := search_ptlo;
         ELSE
           save_ptlo := search_ptlo;
         IFEND;
       ELSE
         save_ptlo := search_ptlo;
       IFEND;
       search_ptlo := next_search_ptlo;
     WHILEND;

     IF insert_ptlo <> ptlo THEN
       dcte.major_priority := insert_ptlo;
       IF tmv$ptl_p^ [insert_ptlo].ptl_thread = 0 THEN
         dcte.queue_tail := insert_ptlo;
       IFEND;
     ELSE

{ There were not any tasks moved below the new task. We must now check to
{ see if there are any tasks below the new task, which have a relative priority
{ higher than the new task. A search is made of all of the tasks below the new
{ task, the new task is moved below the last task (of the same job) which
{ has a higher relative priority than the new task.

       insert_ptlo := 0;
       search_ptlo := tmv$ptl_p^ [ptlo].ptl_thread;
       WHILE search_ptlo <> 0 DO
         IF (tmv$ptl_p^ [search_ptlo].ijl_ordinal = tmv$ptl_p^ [ptlo].ijl_ordinal) THEN
           search_xcb := #ADDRESS (1, ijl_p^.ajl_ordinal + mtc$job_fixed_segment,
             tmv$ptl_p^ [search_ptlo].xcb_offset);
           IF (search_xcb^.global_task_id <> tmv$null_global_task_id) AND
              (search_xcb^.relative_task_priority > relative_priority) THEN
             insert_ptlo := search_ptlo;
           IFEND;
         IFEND;
         search_ptlo := tmv$ptl_p^ [search_ptlo].ptl_thread;
       WHILEND;
       IF insert_ptlo <> 0 THEN
         IF ptlo = dcte.queue_head THEN
           dcte.queue_head := tmv$ptl_p^ [ptlo].ptl_thread;
         IFEND;
         IF ptlo = dcte.minor_priority THEN
           dcte.minor_priority := tmv$ptl_p^ [ptlo].ptl_thread;
         IFEND;
         IF ptlo = dcte.major_priority THEN
           dcte.major_priority := tmv$ptl_p^ [ptlo].ptl_thread;
         IFEND;
         tmv$ptl_p^ [save_ptlo].ptl_thread := tmv$ptl_p^ [ptlo].ptl_thread;
         tmv$ptl_p^ [ptlo].ptl_thread := tmv$ptl_p^ [insert_ptlo].ptl_thread;
         tmv$ptl_p^ [insert_ptlo].ptl_thread := ptlo;
         IF tmv$ptl_p^ [ptlo].ptl_thread = 0 THEN
           dcte.queue_tail := ptlo;
         IFEND;
       IFEND;
     IFEND;

   PROCEND relative_insert_major_dct;
?? TITLE := 'RELATIVE_INSERT_TAIL_DCT', EJECT ??

  PROCEDURE  [INLINE]  relative_insert_tail_dct
    (    relative_priority: 0 .. 255;
         ptlo: ost$task_index;
         ijle_p: ^jmt$initiated_job_list_entry;
     VAR dcte: tmt$dct_entry);

  { The new task has been placed at the tail of the DCT.
  { All of the tasks in the DCT are scanned. Any tasks (of the
  { same job) which have a lower relative priority than the new
  { task, are moved below the new task.

    VAR
      insert_ptlo: ost$task_index,
      next_search_ptlo: ost$task_index,
      save_ptlo: ost$task_index,
      search_ptlo: ost$task_index,
      search_xcb: ^ost$execution_control_block;

  { Insert_ptlo is the most recently moved ptlo.
  { Search_ptlo is the task which we are currently testing for
  { possible movement.
  { Save_ptlo is the last task which was NOT moved.

    search_ptlo := dcte.queue_head;
    save_ptlo := 0;
    insert_ptlo := ptlo;


    WHILE (search_ptlo <> ptlo) DO
      next_search_ptlo := tmv$ptl_p^ [search_ptlo].ptl_thread;
      IF (tmv$ptl_p^ [search_ptlo].ijl_ordinal = tmv$ptl_p^ [ptlo].ijl_ordinal) THEN
        search_xcb := #ADDRESS (1, ijle_p^.ajl_ordinal + mtc$job_fixed_segment,
          tmv$ptl_p^ [search_ptlo].xcb_offset);
        IF (search_xcb^.relative_task_priority < relative_priority) THEN
          IF (search_ptlo = dcte.queue_head) THEN
            dcte.queue_head := tmv$ptl_p^ [search_ptlo].ptl_thread;
          IFEND;
          IF (search_ptlo = dcte.minor_priority) THEN
            dcte.minor_priority := tmv$ptl_p^ [search_ptlo].ptl_thread;
          IFEND;
          IF (search_ptlo = dcte.major_priority) THEN
            dcte.major_priority := tmv$ptl_p^ [search_ptlo].ptl_thread;
          IFEND;
          IF save_ptlo <> 0 THEN
            tmv$ptl_p^ [save_ptlo].ptl_thread := tmv$ptl_p^ [search_ptlo].ptl_thread;
          IFEND;
          tmv$ptl_p^ [search_ptlo].ptl_thread := 0;
          tmv$ptl_p^ [insert_ptlo].ptl_thread := search_ptlo;
          insert_ptlo := search_ptlo;
        ELSE
          save_ptlo := search_ptlo;
        IFEND;
      ELSE
        save_ptlo := search_ptlo;
      IFEND;
      search_ptlo := next_search_ptlo;
    WHILEND;

    dcte.queue_tail := insert_ptlo;

  PROCEND relative_insert_tail_dct;
?? TITLE := 'INSERT_IJL', EJECT ??

  PROCEDURE [INLINE] insert_ijl
    (    taskid: ost$global_task_id;
         cst_p: ^ost$cpu_state_table);

{
{  The purpose of this procedure is to insert the selected
{  task's PTL entry in the IJL thread for it's job.  The
{  first task in the IJL thread is the job monitor task.
{
{    INSERT_IJL (TASKID)
{
{  TASKID : (INPUT) This parameter specifies the taskid of
{                   of the specified task.
{
{  NOTE : Anyone calling this routine must have tmv$ptl_lock set.
{

    tmv$ptl_p^ [taskid.index].ijl_thread := tmv$ptl_p^ [cst_p^.ijle_p^.job_monitor_taskid.index].ijl_thread;
    tmv$ptl_p^ [cst_p^.ijle_p^.job_monitor_taskid.index].ijl_thread := taskid.index;

  PROCEND insert_ijl;
?? TITLE := 'REMOVE_IJL', EJECT ??

  PROCEDURE [INLINE] remove_ijl
    (    taskid: ost$global_task_id;
         cst_p: ^ost$cpu_state_table);


{
{  The purpose of this procedure is to remove the PTL
{  entry for the specified task from the IJL thread.
{
{    REMOVE_IJL (TASKID)
{
{  TASKID : (INPUT) This parameter specifies the taskid
{                   of the selected task.
{
{  NOTE : Anyone calling this routine must have tmv$ptl_lock set.
{

    VAR
      last_ptlo,
      curr_ptlo: ost$task_index;



    last_ptlo := 0;
    curr_ptlo := cst_p^.ijle_p^.job_monitor_taskid.index;

  /search_loop/
    WHILE curr_ptlo <> 0 DO
      IF curr_ptlo = taskid.index THEN
        EXIT /search_loop/;
      IFEND;
      last_ptlo := curr_ptlo;
      curr_ptlo := tmv$ptl_p^ [last_ptlo].ijl_thread;
    WHILEND /search_loop/;

    tmv$ptl_p^ [last_ptlo].ijl_thread := tmv$ptl_p^ [curr_ptlo].ijl_thread;
    tmv$ptl_p^ [curr_ptlo].ijl_thread := 0;

  PROCEND remove_ijl;
?? TITLE := 'TMP$FIND_XCB', EJECT ??

  PROCEDURE [XDCL] tmp$find_xcb
    (    taskid: ost$global_task_id;
     VAR xcb_p: ^ost$execution_control_block;
     VAR ijle_p: ^jmt$initiated_job_list_entry;
     VAR status: syt$monitor_status);

*copyc tmh$find_xcb

    VAR
      inhibit_access: boolean;

    status.normal := TRUE;
    tmp$set_lock (tmv$ptl_lock);

    tmp$check_taskid_with_lock_set (taskid, tmc$opt_return, status);
    IF NOT status.normal THEN
      tmp$clear_lock (tmv$ptl_lock);
      RETURN;
    IFEND;

    jmp$get_ijle_p (tmv$ptl_p^ [taskid.index].ijl_ordinal, ijle_p);
    tmp$get_xcb_access_status (ijle_p, tmv$ptl_p^ [taskid.index].ijl_ordinal, inhibit_access);
    IF inhibit_access THEN
      mtp$set_status_abnormal ('TM', tme$job_swapped_out, status);
    ELSE
      xcb_p := #ADDRESS (1, ijle_p^.ajl_ordinal + mtc$job_fixed_segment, tmv$ptl_p^ [taskid.index].
            xcb_offset);
    IFEND;
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$find_xcb;

?? TITLE := 'TMP$GET_XCB_P', EJECT ??

  PROCEDURE [XDCL] tmp$get_xcb_p
    (    taskid: ost$global_task_id;
     VAR xcb_p: ^ost$execution_control_block;
     VAR ijle_p: ^jmt$initiated_job_list_entry);

*copyc tmh$get_xcb_p

{  NOTE: This procedure will increment the ajl in use count or assign an ajl if
{        xcb access is possible.  It is the callers responsibility to decrement it
{        with a call to jmp$free_ajl_entry.

    VAR
      inhibit_access: boolean;

    tmp$set_lock (tmv$ptl_lock);
    tmp$stop_if_bad_taskid (taskid);
    jmp$get_ijle_p (tmv$ptl_p^ [taskid.index].ijl_ordinal, ijle_p);

    tmp$get_xcb_access_status (ijle_p, tmv$ptl_p^ [taskid.index].ijl_ordinal, inhibit_access);
    IF inhibit_access THEN
      xcb_p := NIL;
    ELSE
      xcb_p := #ADDRESS (1, ijle_p^.ajl_ordinal + mtc$job_fixed_segment, tmv$ptl_p^ [taskid.index].
            xcb_offset);
    IFEND;
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$get_xcb_p;
?? TITLE := 'TMP$TEST_GET_XCB_P', EJECT ??

  PROCEDURE [XDCL] tmp$test_get_xcb_p
    (    taskid: ost$global_task_id;
     VAR xcb_p: ^ost$execution_control_block;
     VAR ijle_p: ^jmt$initiated_job_list_entry);

{  NOTE: This procedure will increment the ajl in use count or assign an ajl if
{        xcb access is possible.  It is the callers responsibility to decrement it
{        with a call to jmp$free_ajl_entry.

    VAR
      inhibit_access: boolean;

    tmp$set_lock (tmv$ptl_lock);

    IF (taskid = tmv$null_global_task_id) OR (taskid.index > UPPERBOUND (tmv$ptl_p^)) OR
          (tmv$ptl_p^ [taskid.index].sequence_number <> taskid.seqno) OR
          (tmv$ptl_p^ [taskid.index].status = tmc$ts_null) THEN
      xcb_p := NIL;
      ijle_p := NIL;
    ELSE
      jmp$get_ijle_p (tmv$ptl_p^ [taskid.index].ijl_ordinal, ijle_p);

      tmp$get_xcb_access_status (ijle_p, tmv$ptl_p^ [taskid.index].ijl_ordinal, inhibit_access);
      IF inhibit_access THEN
        xcb_p := NIL;
      ELSE
        xcb_p := #ADDRESS (1, ijle_p^.ajl_ordinal + mtc$job_fixed_segment, tmv$ptl_p^ [taskid.index].
              xcb_offset);
      IFEND;
    IFEND;
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$test_get_xcb_p;
?? TITLE := 'TMP$GET_TOP_OF_STACK', EJECT ??
{
{ PURPOSE:
{   This procedure is used to fetch the value of the TOP-OF-STACK pointer for a specified
{   ring of a specified task.
{ DESIGN:
{   The value of the TOS register is determined from the exchange package as follows:
{   If the value of TOS cannot be determined because the task is executing on another
{   processor of a dual CPU system, TOS cannot be determined; a value of 2**31-1 is
{   returned.
{

  PROCEDURE [XDCL] tmp$get_top_of_stack
    (    taskid: ost$global_task_id;
         ring: ost$valid_ring;
     VAR tos: integer);

    VAR
      cst_p: ^ost$cpu_state_table,
      ijle_p: ^jmt$initiated_job_list_entry,
      inhibit_access: boolean,
      xcb_p: ^ost$execution_control_block;

    tmp$set_lock (tmv$ptl_lock);
    tmp$stop_if_bad_taskid (taskid);
    jmp$get_ijle_p (tmv$ptl_p^ [taskid.index].ijl_ordinal, ijle_p);

    tmp$get_xcb_access_status (ijle_p, tmv$ptl_p^ [taskid.index].ijl_ordinal, inhibit_access);
    IF inhibit_access THEN
      mtp$error_stop ('TM - XCB not accessible');
    ELSE
      xcb_p := #ADDRESS (1, ijle_p^.ajl_ordinal + mtc$job_fixed_segment, tmv$ptl_p^ [taskid.index].
            xcb_offset);
    IFEND;

    mtp$cst_p (cst_p);

    IF ((tmv$ptl_p^ [taskid.index].status = tmc$ts_executing) AND (cst_p^.taskid <> taskid)) OR
       (xcb_p^.stack_pages_saved [ring] = TRUE) THEN
       tos := 7fffffff(16);                 { TOS cannot be determined if executing on another processor.}
    ELSEIF xcb_p^.xp.p_register.pva.ring > ring THEN
      tos := 0;                             { TOS is zero if executing in a higher ring.}
    ELSEIF xcb_p^.xp.p_register.pva.ring = ring THEN
      tos := #OFFSET (xcb_p^.xp.a0_dynamic_space_pointer); {TOS in XP.A0  is correct if in same ring.}
    ELSE
      tos := xcb_p^.xp.tos_registers [ring].pva.offset; {TOS in XP.TOS is correct if in lower ring.}
    IFEND;

    jmp$unlock_ajl_with_lock (ijle_p);
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$get_top_of_stack;

?? TITLE := 'TMP$GET_XCB_P_FROM_PTLO', EJECT ??

{  NOTE : Any procedure calling this routine must have tmv$ptl_lock set.

  PROCEDURE [INLINE] tmp$get_xcb_p_from_ptlo
    (    ptlo: ost$task_index;
         ajl_ordinal: jmt$ajl_ordinal;
     VAR xcb_p: ^ost$execution_control_block);

    xcb_p := #ADDRESS (1, ajl_ordinal + mtc$job_fixed_segment, tmv$ptl_p^ [ptlo].xcb_offset);

  PROCEND tmp$get_xcb_p_from_ptlo;

?? TITLE := 'TMP$FIND_NEXT_XCB', EJECT ??

  PROCEDURE [XDCL] tmp$find_next_xcb
    (    search: tmt$fnx_search_type;
         ijle_p: ^jmt$initiated_job_list_entry;
         ijl_ordinal: jmt$ijl_ordinal;
     VAR state: tmt$find_next_xcb_state;
     VAR xcb_p: ^ost$execution_control_block);

*copyc tmhfnx

     VAR
       ijl_bi: jmt$ijl_block_index,
       ijl_bn: jmt$ijl_block_number,
       inhibit_access: boolean,
       next_ijle_p: ^jmt$initiated_job_list_entry,
       start_index: integer;

    tmp$set_lock (tmv$ptl_lock);

{Initialize the search state variable if this is not a continuation search.

    IF search <> tmc$fnx_continue THEN
      state.search := search;
      IF search = tmc$fnx_system THEN
        state.ajl_ordinal := jmv$system_ajl_ordinal;
        state.ijl_ordinal := jmv$system_ijl_ordinal;
        state.in_use_incremented := TRUE;
        jmv$ajl_p^ [jmv$system_ajl_ordinal].in_use := jmv$ajl_p^ [jmv$system_ajl_ordinal].in_use +
              jmc$lock_ajl;
        jmp$get_ijle_p (jmv$system_ijl_ordinal, state.ijle_p);
        state.next_ptlo := jmv$ajl_p^ [state.ajl_ordinal].ijle_p^.job_monitor_taskid.index;
      ELSE
        tmp$get_xcb_access_status (ijle_p, ijl_ordinal, inhibit_access);
        state.in_use_incremented := NOT inhibit_access;
        IF (search = tmc$fnx_job) AND inhibit_access THEN
          state.next_ptlo := 0;
        ELSE
          state.ajl_ordinal := ijle_p^.ajl_ordinal;
          state.next_ptlo := ijle_p^.job_monitor_taskid.index;
          state.ijl_ordinal := ijl_ordinal;
          state.ijle_p := ijle_p;
        IFEND;
      IFEND;

{ If a full system search is in process and we have reached the end of the current job.
{ Release the temporary ajl ordinal if necessary.  Find the next job to be searched.

    ELSEIF (state.next_ptlo = 0) AND (state.search = tmc$fnx_system) THEN

      jmp$unlock_ajl_with_lock (state.ijle_p);
      state.in_use_incremented := FALSE;

      start_index := state.ijl_ordinal.block_index + 1;

    /find_next_job/
      FOR ijl_bn := state.ijl_ordinal.block_number TO jmv$ijl_p.max_block_in_use DO
        IF (jmv$ijl_p.block_p^ [ijl_bn].index_p <> NIL) AND (jmv$ijl_p.block_p^ [ijl_bn].
              in_use_count <> 0) THEN
          FOR ijl_bi := start_index TO UPPERVALUE (jmt$ijl_block_index) DO
            next_ijle_p := ^jmv$ijl_p.block_p^ [ijl_bn].index_p^ [ijl_bi];
            IF next_ijle_p^.entry_status <> jmc$ies_entry_free THEN
              state.ijl_ordinal.block_index := ijl_bi;
              state.ijl_ordinal.block_number := ijl_bn;
              tmp$get_xcb_access_status (next_ijle_p, state.ijl_ordinal, inhibit_access);
              state.in_use_incremented := NOT inhibit_access;
              IF NOT inhibit_access THEN
                state.next_ptlo := next_ijle_p^.job_monitor_taskid.index;
                state.ajl_ordinal := next_ijle_p^.ajl_ordinal;
                state.ijle_p := next_ijle_p;
                EXIT /find_next_job/;
              IFEND;
            IFEND;
          FOREND;
          start_index := LOWERVALUE (jmt$ijl_block_index);
        IFEND;
      FOREND /find_next_job/;

    IFEND;

    IF state.next_ptlo = 0 THEN
      IF state.in_use_incremented THEN
        jmp$unlock_ajl_with_lock (state.ijle_p);
        state.in_use_incremented := FALSE;
      IFEND;
      xcb_p := NIL;
    ELSE
      xcb_p := #ADDRESS (1, mtc$job_fixed_segment + state.ajl_ordinal, tmv$ptl_p^ [state.next_ptlo].
            xcb_offset);
      state.next_ptlo := tmv$ptl_p^ [state.next_ptlo].ijl_thread;
    IFEND;
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$find_next_xcb;
?? TITLE := 'TMP$SET_TASK_WAIT', EJECT ??

  PROCEDURE [XDCL] tmp$set_task_wait
    (    task_status: tmt$task_status);

*copyc tmh$set_task_wait

    VAR
      cst_p: ^ost$cpu_state_table,
      taskid: ost$global_task_id;

    mtp$cst_p (cst_p);
    tmp$set_lock (tmv$ptl_lock);
    IF (task_status >= tmc$ts_first_external_queue) OR (tmv$ptl_p^ [cst_p^.taskid.index].new_task_status >
          tmc$ts_null) THEN
      mtp$error_stop ('TM37 - bad call to set_task_wait');
    IFEND;
    IF (task_status = tmc$ts_io_wait_not_queued) THEN
      tmv$io_wait_task_count := tmv$io_wait_task_count + 1;
    IFEND;
    tmv$ptl_p^ [cst_p^.taskid.index].new_task_status := task_status;
    tmp$clear_lock (tmv$ptl_lock);
    cst_p^.dispatch_control.call_dispatcher := TRUE;
    IF (cst_p^.next_ptlo_to_dispatch = 0) THEN
      cst_p^.dispatching_priority_integer := tmv$dct_priority_integer;
    IFEND;

  PROCEND tmp$set_task_wait;
?? TITLE := 'TMP$SET_TASK_READY', EJECT ??

  PROCEDURE [XDCL] tmp$set_task_ready
    (    taskid: ost$global_task_id;
         readying_task_priority: jmt$dispatching_priority;
         ready_condition: tmt$ready_condition);

*copyc tmh$set_task_ready

    VAR
      attempt_preselection: boolean,
      cst_p: ^ost$cpu_state_table,
      old_dispatching_priority: jmt$dispatching_priority,
      ijle_p: ^jmt$initiated_job_list_entry,
      null_dispatching_info: jmt$dispatching_control_info,
      psuedo_rb: tmt$rb_update_job_task_enviro,
      ptl_p: ^tmt$primary_task_list_entry,
      xcb_p: ^ost$execution_control_block,
      task_priority_changed: boolean;


    tmp$set_lock (tmv$ptl_lock);
    tmp$stop_if_bad_taskid (taskid);
    ptl_p := ^tmv$ptl_p^ [taskid.index];
    jmp$get_ijle_p (ptl_p^.ijl_ordinal, ijle_p);
    xcb_p := #ADDRESS (1, mtc$job_fixed_segment + ijle_p^.ajl_ordinal, ptl_p^.xcb_offset);

    IF (ijle_p^.interactive_task_gtid = taskid) THEN
      psuedo_rb.reqcode := syc$rc_update_job_task_enviro;
      psuedo_rb.subcode := tmc$ujte_dispatching_priority;
      psuedo_rb.request_origin := tmc$cpo_interactive_command;
      psuedo_rb.ijl_ordinal := ptl_p^.ijl_ordinal;
      psuedo_rb.system_supplied_name := ijle_p^.system_supplied_name;
      psuedo_rb.dispatching_control_info := null_dispatching_info;
      old_dispatching_priority := ijle_p^.dispatching_control.dispatching_priority;
      mtp$cst_p (cst_p);
      tmp$mtr_update_job_task_enviro (psuedo_rb, cst_p);
      IF (ijle_p^.dispatching_control.dispatching_priority <> old_dispatching_priority) AND
        (ijle_p^.entry_status = jmc$ies_swapin_candidate) THEN
       jmv$subsystem_priority_changes [ijle_p^.job_scheduler_data.service_class] := TRUE;
       jmp$set_scheduler_event (jmc$subsystem_priority_change);
     IFEND;
     ijle_p^.interactive_task_gtid := tmv$null_global_task_id;
   IFEND;

{ Tasks with subsystem locks set will execute with the higher
{  of the task's or the "readying" task's priority, after it
{ has run for the subsystem lock threshold with a priority of P9.

    task_priority_changed := FALSE;

    IF (readying_task_priority <> 0) AND ((ptl_p^.ptl_flags.subsystem_locks_set) OR
      ((ptl_p^.idle_status < tmc$is_idled) AND (xcb_p^.system_table_lock_count > 0)))  THEN
      IF readying_task_priority > ptl_p^.readying_task_priority THEN
        ptl_p^.readying_task_priority := readying_task_priority;
        task_priority_changed := TRUE;
      IFEND;
      IF ijle_p^.scheduling_dispatching_priority < readying_task_priority THEN
        ijle_p^.scheduling_dispatching_priority := readying_task_priority;
        jmp$subsystem_priority_change (ijle_p);
      IFEND;
    IFEND;

    IF (ptl_p^.status = tmc$ts_executing) OR (ptl_p^.status = tmc$ts_ready_and_selected) THEN
      IF ptl_p^.new_task_status < tmc$ts_first_ready_uncond THEN
        ptl_p^.new_task_status := tmc$ts_null;
      IFEND;

    ELSEIF ptl_p^.status = tmc$ts_ready THEN

{ If the task being readied has subsystem locks set, it must be
{ removed from the ready string and reinserted. It is possible
{ that the task will execute at a different priority depending
{ on how long the task has had subsystem locks set, and
{ the priority of the readying task.

      IF task_priority_changed AND (xcb_p^.system_table_lock_count > 0) AND
           (xcb_p^.system_table_lock_count < osc$system_table_lock_set) AND
        (xcb_p^.subsystem_lock_priority_count >= tmv$subsystem_prior_threshold) THEN
        tmp$remove_task_from_dct (taskid.index);
        attempt_preselection := (ijle_p^.multiprocessing_allowed) OR (ijle_p^.executing_task_count = 0);
        tmp$dct_ready_task (xcb_p, ijle_p, taskid.index, attempt_preselection);
      IFEND;

    ELSEIF ptl_p^.status < tmc$ts_ready_but_swapped THEN

{ If the task is in the timed wiat queue, take it out.  Adjust the tasks_not_in_long_wait count based upon
{ the task status.  If the job the task belongs to is swapped, call scheduler to swap the job in.  If the
{ job is in memory, insert the task into the DCT.


      IF ptl_p^.status <= tmc$ts_last_status_in_wait_q THEN
        tmp$remove_task_from_q (ptl_p, tmv$timed_wait_queue);
        IF (ptl_p^.status = tmc$ts_timeout_reqexp_longvlong) THEN
          ijle_p^.statistics.tasks_not_in_long_wait := ijle_p^.statistics.tasks_not_in_long_wait + 1;
        IFEND;
      ELSE
        IF (ptl_p^.status = tmc$ts_timeout_reqexp_infvlong) OR (ptl_p^.status =
              tmc$ts_timed_wait_not_queued) THEN
          ijle_p^.statistics.tasks_not_in_long_wait := ijle_p^.statistics.tasks_not_in_long_wait + 1;
        IFEND;
      IFEND;

      IF ptl_p^.idle_status = tmc$is_idled THEN
        ijle_p^.statistics.ready_task_count := ijle_p^.statistics.ready_task_count + 1;
        ptl_p^.status := tmc$ts_ready_but_swapped;
        ptl_p^.idle_status := tmc$is_idled_sched_notified;
        jmp$ready_task_in_swapped_job (ptl_p^.ijl_ordinal, ijle_p);
      ELSEIF ptl_p^.idle_status < tmc$is_idled THEN
        ijle_p^.statistics.ready_task_count := ijle_p^.statistics.ready_task_count + 1;
        ptl_p^.status := tmc$ts_ready;
        jmv$ajl_p^ [ijle_p^.ajl_ordinal].job_is_good_swap_candidate := FALSE;
        attempt_preselection := (ijle_p^.multiprocessing_allowed) OR (ijle_p^.executing_task_count = 0);
        tmp$dct_ready_task (xcb_p, ijle_p, taskid.index, attempt_preselection);
      IFEND;

      ?IF NOT debug THEN
        IF mlv$c170_rqst_blk.req <> NIL THEN
          IF taskid = mlv$c170_rqst_blk.req^.task_id THEN
            mtv$mli_status.ready := TRUE;
          IFEND;
        IFEND;
      ?IFEND

    ELSEIF ptl_p^.status = tmc$ts_ready_but_swapped THEN
      jmp$ready_task_in_swapped_job (ptl_p^.ijl_ordinal, ijle_p);
    IFEND;

    IF ptl_p^.status = tmc$ts_segment_lock_wait THEN
      remove_task_from_seg_lock_q (taskid, ijle_p, ptl_p);
    IFEND;

{The 'wait_inhibited' flag in the PTL is set to tmc$wi_wait_selected only after
{the successful completion of a wait request.  This prevents potential timing
{conflicts between ready_task and wait requests.

    IF (ready_condition = tmc$rc_ready_conditional_wi) AND
      (NOT (ptl_p^.ptl_flags.wait_inhibited = tmc$wi_wait_selected) AND
        NOT (ptl_p^.ptl_flags.wait_inhibited = tmc$wi_wait_selected_r3)) THEN
      ptl_p^.ptl_flags.wait_inhibited := tmc$wi_wait_inhibited;
    IFEND;
    ijle_p^.long_wait_aging_complete := FALSE;
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$set_task_ready;
?? TITLE := 'TMP$SET_TASK_READY_UNCOND', EJECT ??

  PROCEDURE [XDCL] tmp$set_task_ready_uncond
    (    taskid: ost$global_task_id;
         task_status: tmt$task_status);

*copyc tmh$set_task_ready_uncond

    VAR
      attempt_preselection: boolean,
      ijle_p: ^jmt$initiated_job_list_entry,
      xcb_p: ^ost$execution_control_block,
      ptl_p: ^tmt$primary_task_list_entry;


    tmp$set_lock (tmv$ptl_lock);
    tmp$stop_if_bad_taskid (taskid);
    ptl_p := ^tmv$ptl_p^ [taskid.index];
    jmp$get_ijle_p (ptl_p^.ijl_ordinal, ijle_p);
    IF (task_status = tmc$ts_io_wait_not_queued) THEN
      tmv$io_wait_task_count := tmv$io_wait_task_count - 1;
    IFEND;
    IF ptl_p^.status <> task_status THEN
      IF (ptl_p^.status <> tmc$ts_executing) OR (ptl_p^.new_task_status <> task_status) THEN
        mtp$error_stop ('TM96 - task not queued');
      IFEND;
      ptl_p^.new_task_status := tmc$ts_null;
    ELSE
      IF ptl_p^.idle_status = tmc$is_idled THEN
        ijle_p^.statistics.ready_task_count := ijle_p^.statistics.ready_task_count + 1;
        ptl_p^.status := tmc$ts_ready_but_swapped;
        ptl_p^.idle_status := tmc$is_idled_sched_notified;
        jmp$ready_task_in_swapped_job (ptl_p^.ijl_ordinal, ijle_p);
      ELSEIF ptl_p^.idle_status < tmc$is_idled THEN
        ijle_p^.statistics.ready_task_count := ijle_p^.statistics.ready_task_count + 1;
        ptl_p^.status := tmc$ts_ready;
        attempt_preselection := (ijle_p^.multiprocessing_allowed) OR (ijle_p^.executing_task_count = 0);
        xcb_p := #ADDRESS (1, mtc$job_fixed_segment + ijle_p^.ajl_ordinal, ptl_p^.xcb_offset);
        tmp$dct_ready_task (xcb_p, ijle_p, taskid.index, attempt_preselection);
      IFEND;
    IFEND;

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$set_task_ready_uncond;
?? TITLE := 'TMP$REISSUE_MONITOR_REQUEST', EJECT ??

  PROCEDURE [XDCL] tmp$reissue_monitor_request;

*copyc tmh$reissue_monitor_request

    VAR
      cst_p: ^ost$cpu_state_table;

    mtp$cst_p (cst_p);

    cst_p^.xcb_p^.xp.p_register.pva.offset := cst_p^.xcb_p^.xp.p_register.pva.offset - 2;

  PROCEND tmp$reissue_monitor_request;
?? SKIP := 3 ??

  PROCEDURE [XDCL] tmp$cause_task_switch;

    VAR
      cst_p: ^ost$cpu_state_table;

    mtp$cst_p (cst_p);
    tmp$set_lock (tmv$ptl_lock);
    IF (tmv$ptl_p^ [cst_p^.taskid.index].new_task_status > tmc$ts_null) AND
      (tmv$ptl_p^ [cst_p^.taskid.index].new_task_status <> tmc$ts_timeout_reqexp_shortshrt) THEN
      mtp$error_stop ('TM38 - bad call to cause_task_switch');
    IFEND;
    tmv$ptl_p^ [cst_p^.taskid.index].new_task_status := tmc$ts_timeout_reqexp_shortshrt;
    tmv$ptl_p^ [cst_p^.taskid.index].end_of_wait_time := #FREE_RUNNING_CLOCK (0) + tmv$cycle_delay_time;
    cst_p^.dispatch_control.call_dispatcher := TRUE;
    IF (cst_p^.next_ptlo_to_dispatch = 0) THEN
      cst_p^.dispatching_priority_integer := tmv$dct_priority_integer;
    IFEND;

    ?IF tmc$debug_cycle_requests THEN
      IF (osv$debug > 0) THEN
        tmv$cycle_trace [ti].code := tmc$cyc_cause_task_switch;
        tmv$cycle_trace [ti].time := #FREE_RUNNING_CLOCK (0);
        ti := ti + 1;
        IF ti > 10000 THEN
          mtp$error_stop ('TM - trace buffer full');
        IFEND;
      IFEND;
    ?IFEND;
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$cause_task_switch;
?? TITLE := 'TMP$QUEUE_TASK', EJECT ??

  PROCEDURE [XDCL] tmp$queue_task
    (    taskid: ost$global_task_id;
         task_status: tmt$task_status;
     VAR queue_link: tmt$task_queue_link);

*copyc tmh$queue_task

    VAR
      cst_p: ^ost$cpu_state_table,
      ptl_p: ^tmt$primary_task_list_entry;


    ptl_p := ^tmv$ptl_p^ [taskid.index];

    tmp$set_lock (tmv$ptl_lock);

    tmp$stop_if_bad_taskid (taskid);

    IF (ptl_p^.queue_link.head <> 0) OR (ptl_p^.queue_link.tail <> 0) OR
          (queue_link.tail = taskid.index) THEN
      mtp$error_stop ('TM02 - already queued');
    IFEND;
    IF (task_status < tmc$ts_first_external_queue) OR (ptl_p^.new_task_status > tmc$ts_null) THEN
      mtp$error_stop ('TM49 - bad call to queue_task');
    IFEND;

    IF queue_link.tail = 0 THEN
      queue_link.head := taskid.index;
      queue_link.tail := taskid.index;
    ELSE
      tmv$ptl_p^ [queue_link.tail].queue_link.head := taskid.index;
      ptl_p^.queue_link.tail := queue_link.tail;
      queue_link.tail := taskid.index;
    IFEND;

    mtp$cst_p (cst_p);
    cst_p^.dispatch_control.call_dispatcher := TRUE;
    IF (cst_p^.next_ptlo_to_dispatch = 0) THEN
      cst_p^.dispatching_priority_integer := tmv$dct_priority_integer;
    IFEND;
    IF taskid <> cst_p^.taskid THEN
      mtp$error_stop ('TM - attempt to queue task not xtask');
    IFEND;
    IF (task_status = tmc$ts_page_wait) OR (task_status = tmc$ts_io_wait_queued) THEN
      tmv$io_wait_task_count := tmv$io_wait_task_count + 1;
    IFEND;
    ptl_p^.new_task_status := task_status;

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$queue_task;

?? TITLE := 'TMP$DEQUEUE_TASK', EJECT ??

  PROCEDURE [XDCL] tmp$dequeue_task
    (VAR queue_link: tmt$task_queue_link;
     VAR taskid: ost$global_task_id);

*copyc tmh$dequeue_task

    VAR
      attempt_preselection: boolean,
      ijle_p: ^jmt$initiated_job_list_entry,
      xcb_p: ^ost$execution_control_block,
      ptl_p: ^tmt$primary_task_list_entry;


    tmp$set_lock (tmv$ptl_lock);
    taskid.index := queue_link.head;
    ptl_p := ^tmv$ptl_p^ [taskid.index];
    taskid.seqno := ptl_p^.sequence_number;
    tmp$stop_if_bad_taskid (taskid);

    jmp$get_ijle_p (ptl_p^.ijl_ordinal, ijle_p);

    IF queue_link.head = queue_link.tail THEN
      queue_link.head := 0;
      queue_link.tail := 0;
    ELSE
      queue_link.head := ptl_p^.queue_link.head;
      tmv$ptl_p^ [queue_link.head].queue_link.tail := 0;
      ptl_p^.queue_link.head := 0;
    IFEND;

    IF (ptl_p^.status = tmc$ts_page_wait) OR (ptl_p^.status = tmc$ts_io_wait_queued) OR
          (ptl_p^.new_task_status = tmc$ts_page_wait) OR (ptl_p^.new_task_status = tmc$ts_io_wait_queued) THEN
      tmv$io_wait_task_count := tmv$io_wait_task_count - 1;
    IFEND;

    IF ptl_p^.status < tmc$ts_first_external_queue THEN
      IF (ptl_p^.status <> tmc$ts_executing) OR (ptl_p^.new_task_status < tmc$ts_first_external_queue) THEN
        mtp$error_stop ('TM92 - task not queued');
      IFEND;
      ptl_p^.new_task_status := tmc$ts_null;
    ELSE
      IF ptl_p^.idle_status = tmc$is_idled THEN
        ijle_p^.statistics.ready_task_count := ijle_p^.statistics.ready_task_count + 1;
        ptl_p^.status := tmc$ts_ready_but_swapped;
        ptl_p^.idle_status := tmc$is_idled_sched_notified;
        jmp$ready_task_in_swapped_job (ptl_p^.ijl_ordinal, ijle_p);
      ELSEIF ptl_p^.idle_status < tmc$is_idled THEN
        ijle_p^.statistics.ready_task_count := ijle_p^.statistics.ready_task_count + 1;
        ptl_p^.status := tmc$ts_ready;
        xcb_p := #ADDRESS (1, mtc$job_fixed_segment + ijle_p^.ajl_ordinal, ptl_p^.xcb_offset);
        attempt_preselection := (ijle_p^.multiprocessing_allowed) OR (ijle_p^.executing_task_count = 0);
        tmp$dct_ready_task (xcb_p, ijle_p, taskid.index, attempt_preselection);
      IFEND;
    IFEND;

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$dequeue_task;

?? TITLE := 'REMOVE_TASK_FROM_SEG_LOCK_Q', EJECT ??

  PROCEDURE remove_task_from_seg_lock_q
    (    taskid: ost$global_task_id;
         ijle_p: ^jmt$initiated_job_list_entry;
         ptl_p: ^tmt$primary_task_list_entry);
{
{  The purpose of this procedure is to remove a task from the segment
{  lock queue. This task has been readied by another task. It will NOT
{  have the segment lock.
{
{    REMOVE_TASK_FROM_SEG_LOCK_Q (taskid, ijle_p, ptl_p)
{
{  TASKID: (INPUT) This parameter specifies the taskid of the
{                  task which is being removed from the segment lock queue.
{
{  IJLE_P: (INPUT) This parameter specifies the ijl pointer of the job
{                  owning the task being removed.
{
{  PTL_P: (INPUT)  This parameter specifies the pointer to the PTL entry
{                  of the task being removed.
{
{  NOTE : Anyone calling this procedure must have tmv$ptl_lock set.
{

    VAR
      asti: mmt$ast_index,
      fde_p: gft$locked_file_desc_entry_p,
      found: boolean,
      queue_link: tmt$task_queue_link,
      queue_link_save: ^tmt$task_queue_link,
      sdtx_p: ^mmt$segment_descriptor_extended,
      segnum: ost$segment,
      task_rb: ^mmt$rb_lock_unlock_segment,
      xcb_p: ^ost$execution_control_block;

    found := FALSE;
    IF ptl_p^.idle_status < tmc$is_idled THEN
      xcb_p := #ADDRESS (1, mtc$job_fixed_segment + ijle_p^.ajl_ordinal, ptl_p^.xcb_offset);
      task_rb := #LOC (xcb_p^.xp.x_registers [0]);
      segnum := #SEGMENT (task_rb^.pva);
      sdtx_p := mmp$get_sdtx_entry_p (xcb_p, segnum);
      gfp$mtr_get_locked_fde_p (sdtx_p^.sfid, ijle_p, fde_p);
      tmp$remove_task_from_q (ptl_p, fde_p^.segment_lock.task_queue);
      ijle_p^.statistics.ready_task_count := ijle_p^.statistics.ready_task_count + 1;
      ptl_p^.status := tmc$ts_ready;
      jmv$ajl_p^ [ijle_p^.ajl_ordinal].job_is_good_swap_candidate := FALSE;
      tmp$dct_ready_task (xcb_p, ijle_p, taskid.index, TRUE {attempt_preselection});
    ELSE
      /search_loop/
      FOR asti := LOWERBOUND (mmv$ast_p^) TO UPPERBOUND (mmv$ast_p^) DO
        IF (mmv$ast_p^ [asti].in_use) AND (mmv$ast_p^ [asti].sfid.residence = gfc$tr_system) THEN
          gfp$mtr_get_locked_fde_p (mmv$ast_p^ [asti].sfid, NIL, fde_p);
          queue_link := fde_p^.segment_lock.task_queue;
          WHILE NOT found AND (queue_link.head <> 0) DO
            IF queue_link.head = taskid.index THEN
              found := TRUE;
              EXIT /search_loop/;
            ELSE
              queue_link := tmv$ptl_p^ [queue_link.head].queue_link;
            IFEND;
          WHILEND;
        IFEND;
      FOREND /search_loop/;

      IF NOT found THEN
        mtp$error_stop ('TM112-task not found in seg lock Q');
      IFEND;

      tmp$remove_task_from_q (ptl_p, fde_p^.segment_lock.task_queue);
      ijle_p^.statistics.ready_task_count := ijle_p^.statistics.ready_task_count + 1;
      ptl_p^.status := tmc$ts_ready_but_swapped;
      ptl_p^.idle_status := tmc$is_idled_sched_notified;
      jmp$ready_task_in_swapped_job (ptl_p^.ijl_ordinal, ijle_p);
    IFEND;

  PROCEND remove_task_from_seg_lock_q;
?? TITLE := 'TMP$FIND_NEXT_QUEUED_TASK', EJECT ??

  PROCEDURE [XDCL] tmp$find_next_queued_task
     (VAR taskid: ost$global_task_id);

    VAR
      ptl_p: ^tmt$primary_task_list_entry;

    tmp$set_lock (tmv$ptl_lock);
    tmp$stop_if_bad_taskid (taskid);
    ptl_p := ^tmv$ptl_p^ [taskid.index];
    taskid.index := ptl_p^.queue_link.head;
    taskid.seqno := tmv$ptl_p^ [ptl_p^.queue_link.head].sequence_number;
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$find_next_queued_task;

?? TITLE := '[XDCL] tmp$check_timed_wait_not_queued', EJECT ??

  PROCEDURE [XDCL] tmp$check_timed_wait_not_queued
    (    time_next_scan_wait_not_queued: integer);

    VAR
      ptlo: ost$task_index;

    tmp$set_lock (tmv$ptl_lock);

    FOR ptlo := 1 TO UPPERBOUND (tmv$ptl_p^) DO
      IF (tmv$ptl_p^ [ptlo].status = tmc$ts_timed_wait_not_queued) AND (tmv$ptl_p^ [ptlo].
            end_of_wait_time <= time_next_scan_wait_not_queued) THEN
        tmv$ptl_p^ [ptlo].status := tmc$ts_timeout_reqexp_longvlong;
        tmp$insert_timed_wait_queue (ptlo);
      IFEND;
    FOREND;

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$check_timed_wait_not_queued;

?? TITLE := 'TMP$INSERT_TIMED_WAIT_QUEUE', EJECT ??

  PROCEDURE [INLINE] tmp$insert_timed_wait_queue
    (    ptlo: ost$task_index);

{
{  The purpose of this request is to add a task to
{  tmv$timed_wait_queue.  Tasks are arranged in the queue
{  in ascending order according to their 'end_of_wait_time'.
{
{    TMP$INSERT_TIMED_WAIT_QUEUE (PTLO)
{
{  PTLO : (INPUT) This parameter specifies the ptl ordinal of
{                 the task to be placed in the queue.
{
{  NOTE : Anyone calling this routine must have tmv$ptl_lock set.
{

    VAR
      next_index: ost$task_index,
      previous_index: ost$task_index,
      end_of_wait_time: integer;

    next_index := tmv$timed_wait_queue.head;
    previous_index := 0;
    end_of_wait_time := tmv$ptl_p^ [ptlo].end_of_wait_time;

    IF tmv$timed_wait_queue.head = 0 THEN
      tmv$timed_wait_queue.head := ptlo;
      tmv$timed_wait_queue.tail := ptlo;
    ELSE
      WHILE (tmv$ptl_p^ [next_index].end_of_wait_time <= end_of_wait_time) AND
            (next_index <> 0) AND (next_index <> ptlo) DO
        previous_index := next_index;
        next_index := tmv$ptl_p^ [next_index].queue_link.head;
      WHILEND;

      IF ptlo = next_index THEN   {Dont put this in the while loop - it kills optimization.}
        mtp$error_stop ('TM02.5 - already queued');
      IFEND;

      tmv$ptl_p^ [ptlo].queue_link.head := next_index;
      IF next_index = tmv$timed_wait_queue.head THEN
        tmv$timed_wait_queue.head := ptlo;
      ELSE
        tmv$ptl_p^ [previous_index].queue_link.head := ptlo;
      IFEND;
      tmv$ptl_p^ [ptlo].queue_link.tail := previous_index;
      IF previous_index = tmv$timed_wait_queue.tail THEN
        tmv$timed_wait_queue.tail := ptlo;
      ELSE
        tmv$ptl_p^ [next_index].queue_link.tail := ptlo;
      IFEND;
    IFEND;

  PROCEND tmp$insert_timed_wait_queue;

?? TITLE := '[INLINE] tmp$remove_task_from_q', EJECT ??
{ Purpose:
{   This procedure removes a task from either the timed wait queue, or
{ a segment lock queue.

  PROCEDURE [INLINE] tmp$remove_task_from_q
    (    ptle_p: ^tmt$primary_task_list_entry;
     VAR queue: tmt$task_queue_link);

    IF ptle_p^.queue_link.head = 0 THEN
      queue.tail := ptle_p^.queue_link.tail;
    ELSE
      tmv$ptl_p^ [ptle_p^.queue_link.head].queue_link.tail := ptle_p^.queue_link.tail;
    IFEND;

    IF ptle_p^.queue_link.tail = 0 THEN
      queue.head := ptle_p^.queue_link.head;
    ELSE
      tmv$ptl_p^ [ptle_p^.queue_link.tail].queue_link.head := ptle_p^.queue_link.head;
    IFEND;

    ptle_p^.queue_link.head := 0;
    ptle_p^.queue_link.tail := 0;

  PROCEND tmp$remove_task_from_q;

?? TITLE := 'TMP$CREATE_JOB', EJECT ??

  PROCEDURE [XDCL] tmp$create_job
    (VAR rb: tmt$rb_initiate_job;
         cst_p: ^ost$cpu_state_table);

*copyc tmh$create_job

    VAR
      attempt_preselection: boolean,
      sdt_p: mmt$max_sdt_p,
      ktt: packed record
        case boolean of
        = TRUE =
          s: string (5),
        = FALSE =
          f1: 0 .. 0fffff(16),
          f2: 0 .. 0fff(16),
        casend,
      recend,
      job_segnum: ost$segment,
      segnum: ost$segment,
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      xcb_p: ^ost$execution_control_block,
      ajl_ordinal: jmt$ajl_ordinal,
      jm: ost$keypoint_mask,
      jcb_p: ^jmt$job_control_block;




{ Make an entry in the monitor segment table for the JOB FIXED SEGMENT of the new job.

    sdt_p := #ADDRESS (1, cst_p^.ajlo + mtc$job_fixed_segment, cst_p^.xcb_p^.sdt_offset);
    job_segnum := #SEGMENT (rb.xcb_p);
    jmp$assign_ajl_entry (sdt_p^.st [job_segnum].ste.asid, rb.ijlo, jmc$swapping_ajl,
          FALSE {must assign}, ajl_ordinal, rb.status);
    IF NOT rb.status.normal THEN
      RETURN;
    IFEND;

    rb.ajo := ajl_ordinal;

{ Make an entry in the PTL for the new task.

    segnum := rb.ajo + mtc$job_fixed_segment;
    ijl_ordinal := jmv$ajl_p^ [rb.ajo].ijl_ordinal;
    jmp$get_ijle_p (ijl_ordinal, ijle_p);
    IF syv$all_jobs_selected_for_debug THEN
      ijle_p^.system_breakpoint_selected := TRUE;
    IFEND;
    xcb_p := #ADDRESS (1, segnum, #OFFSET (rb.xcb_p));
    tmp$set_lock (tmv$ptl_lock);
    tmp$assign_ptl (xcb_p, ijl_ordinal, rb.jmtr_taskid, rb.status);
    IF NOT rb.status.normal THEN
      mtv$monitor_segment_table.st [segnum].ste.vl := osc$vl_invalid_entry;
      #PURGE_BUFFER (osc$purge_all_page_seg_map, null_pva);
      jmp$free_ajl_with_lock (ijle_p, jmc$swapping_ajl);
      rb.ajo := jmc$null_ajl_ordinal;
      tmp$clear_lock (tmv$ptl_lock);
      RETURN;
    IFEND;
    xcb_p^.global_task_id := rb.jmtr_taskid;
    tmv$total_task_count := tmv$total_task_count + 1;

{ Initialize the IJL entry and the JCB for the job.

    jcb_p := #ADDRESS (1, rb.ajo + mtc$job_fixed_segment, 0);
    jcb_p^.jcb_identifier := 0ff00(16);
    jcb_p^.job_monitor_id := rb.jmtr_taskid;
    jcb_p^.last_execution_time := #FREE_RUNNING_CLOCK (0);
    jcb_p^.ijle_p := ijle_p;
    jcb_p^.ijl_ordinal := ijl_ordinal;
    ijle_p^.swap_status := jmc$iss_executing;
    ijle_p^.sfd_p := NIL;
    ijle_p^.job_fixed_contiguous_pages := 0;
    ijle_p^.statistics.ready_task_count := 1;
    ijle_p^.statistics.tasks_not_in_long_wait := 1;
    ijle_p^.job_monitor_taskid := rb.jmtr_taskid;
    jmp$change_ijl_entry_status (ijle_p, jmc$ies_job_in_memory_non_swap);
    IF syv$perf_keypoints_enabled.swapping_keypoints THEN
      ktt.s := ijle_p^.system_supplied_name (16, 4);
      #KEYPOINT (osk$performance, osk$m * ktt.f1, ptk$new_job_name_1);
      #KEYPOINT (osk$performance, osk$m * ((ktt.f2 * 256) + rb.ajo), ptk$new_job_name_2);
    IFEND;
    jm := $ost$keypoint_mask [];
    IF (osv$keypoint_control.environment = osc$system_keypoints) OR
          (osv$keypoint_control.environment = osc$system_sample_keypoints) THEN
      jm := osv$keypoint_control.jm;
      xcb_p^.keypoint_register_enable := TRUE;
    IFEND;
    IF jm <> $ost$keypoint_mask [] THEN
      xcb_p^.xp.flags := xcb_p^.xp.flags + $ost$flags [osc$keypoint_enable];
    ELSE
      xcb_p^.xp.flags := xcb_p^.xp.flags - $ost$flags [osc$keypoint_enable];
    IFEND;
    xcb_p^.xp.keypoint_mask := jm;

{  Set up the new job's segment table from calling task's segment table.  The xcb segment in calling
{  task will be put in the proper place in the new job's segment table.

    mmp$create_job (rb.ajo, job_segnum, cst_p^.xcb_p, xcb_p);

{ Set the processor selections to the set of currently available cpus.

    IF ijle_p^.job_scheduler_data.job_class = jmc$maintenance_job_class THEN
      xcb_p^.processor_selections := mtv$scb.cpus.logically_on;
    ELSE
      xcb_p^.processor_selections := mtv$scb.cpus.available_for_use;
    IFEND;

{ Insert the PTL entry for the new job into the Dispatch Tables.
    xcb_p^.timeslice := jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.attributes.
          dispatching_control [ijle_p^.dispatching_control.dispatching_control_index].dispatching_timeslice;
    attempt_preselection := (ijle_p^.multiprocessing_allowed) OR (ijle_p^.executing_task_count = 0);
    tmp$dct_ready_task (xcb_p, ijle_p, rb.jmtr_taskid.index, attempt_preselection);

{ Increment the count of initiated jobs that scheduler checks.  This count must be changed in
{ monitor with the ptl lock set.

    jmv$job_counts.service_class_counts [ijle_p^.job_scheduler_data.service_class].scheduler_initiated_jobs :=
          jmv$job_counts.service_class_counts [ijle_p^.job_scheduler_data.service_class].
          scheduler_initiated_jobs + 1;

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$create_job;
?? TITLE := 'TMP$EXIT_JOB', EJECT ??

  PROCEDURE [XDCL] tmp$exit_job
    (VAR rb: tmt$rb_exit_job;
         cst_p: ^ost$cpu_state_table);

*copyc tmh$exit_job

    VAR
      xcb_p: ^ost$execution_control_block;


    tmp$set_lock (tmv$ptl_lock);
    IF tmv$ptl_p^ [cst_p^.taskid.index].idle_status = tmc$is_idled THEN
      mtp$error_stop ('TM04 - swapped job exiting');
    IFEND;
    IF tmv$ptl_p^ [cst_p^.taskid.index].ijl_thread <> 0 THEN
      mtp$error_stop ('TM - exit job with active task(s).');
    IFEND;

{ Free the PTL entry for the task.

    tmv$total_task_count := tmv$total_task_count - 1;
    cst_p^.ijle_p^.executing_task_count := cst_p^.ijle_p^.executing_task_count - 1;
    free_ptl (cst_p^.taskid.index);

{ Decrement the job count that scheduler uses.  This count must be changed in monitor
{ with the ptl lock set.

    jmv$job_counts.service_class_counts [cst_p^.ijle_p^.job_scheduler_data.service_class].
          scheduler_initiated_jobs := jmv$job_counts.service_class_counts [cst_p^.ijle_p^.
          job_scheduler_data.service_class].scheduler_initiated_jobs - 1;

    tmp$clear_lock (tmv$ptl_lock);

{ Delete the current task from the ready string and cause a task switch.

    xcb_p := cst_p^.xcb_p;
    cst_p^.xcb_p := NIL;
    cst_p^.dispatch_control.call_dispatcher := TRUE;
    IF (cst_p^.next_ptlo_to_dispatch = 0) THEN
      cst_p^.dispatching_priority_integer := tmv$dct_priority_integer;
    IFEND;

{  Free memory resources of any segments still in jobs address space that are unique to the job.
{  Deletes the job fixed segment from monitor's address space too, can no longer reference the job's xcb.

    mmp$exit_job (xcb_p);

{ Update the service class statistics for the service class this job belongs to.

    jmp$update_service_class_stats (cst_p^.ijle_p);

{ Free the AJL and notify scheduler that the job has terminated.

    jmp$free_ajl_entry (cst_p^.ijle_p, jmc$swapping_ajl);
    jmp$set_job_terminated (cst_p^.ijl_ordinal, cst_p^.ijle_p);

  PROCEND tmp$exit_job;
?? TITLE := 'TMP$CREATE_TASK', EJECT ??

  PROCEDURE [XDCL] tmp$create_task
    (VAR rb: tmt$rb_initiate_task;
         cst_p: ^ost$cpu_state_table);

*copyc tmh$create_task

    VAR
      attempt_preselection: boolean,
      jm: ost$keypoint_mask,
      wrb: tmt$rb_delay,
      offset: integer,
      xcb_p: ^ost$execution_control_block;


    offset := #OFFSET (rb.xcb_p);
    xcb_p := #ADDRESS (1, cst_p^.ajlo + mtc$job_fixed_segment, offset);
    tmp$set_lock (tmv$ptl_lock);
    tmp$assign_ptl (xcb_p, cst_p^.ijl_ordinal, rb.taskid, rb.status);
    IF NOT rb.status.normal THEN
      tmp$clear_lock (tmv$ptl_lock);
      RETURN;
    IFEND;

{ Initialize last lpid to 7 so that segment maps will be purged the first time a task executes.
{ The purge is in task_switch (xcb.last_lpid_for_task <> cst.cst_index).
{ If 8 processors are ever supported in NOS/VE, a new method of ensuring the purge will need to
{ be devised.

    xcb_p^.last_lpid_for_task := 7;

    IF tmv$ptl_p^ [cst_p^.taskid.index].idle_status = tmc$is_idle_initiated THEN
      tmv$ptl_p^ [rb.taskid.index].idle_status := tmc$is_idled_sched_notified;
      tmv$ptl_p^ [rb.taskid.index].status := tmc$ts_ready_but_swapped;
      jmp$ready_task_in_swapped_job (cst_p^.ijl_ordinal, cst_p^.ijle_p);
    ELSE
      IF cst_p^.ijl_ordinal = jmv$system_ijl_ordinal THEN
        cst_p^.ijle_p^.job_scheduler_data.service_class := 1;
      IFEND;
      xcb_p^.subsystem_lock_priority_count := 0;
      xcb_p^.dispatching_priority := cst_p^.xcb_p^.dispatching_priority;
      xcb_p^.timeslice := jmv$service_classes [cst_p^.ijle_p^.job_scheduler_data.service_class]^.attributes.
            dispatching_control [cst_p^.ijle_p^.dispatching_control.dispatching_control_index].
            dispatching_timeslice;
      attempt_preselection := (cst_p^.ijle_p^.multiprocessing_allowed) OR
            (cst_p^.ijle_p^.executing_task_count = 0);
      IF tmv$tables_initialized THEN
        tmp$dct_ready_task (xcb_p, cst_p^.ijle_p, rb.taskid.index, attempt_preselection);
      IFEND;
    IFEND;

    IF tmv$tables_initialized THEN
      insert_ijl (rb.taskid, cst_p);
    ELSE
      tmv$tables_initialized := TRUE;
    IFEND;

    tmv$total_task_count := tmv$total_task_count + 1;

    cst_p^.ijle_p^.statistics.ready_task_count := cst_p^.ijle_p^.statistics.ready_task_count + 1;
    cst_p^.ijle_p^.statistics.tasks_not_in_long_wait := cst_p^.ijle_p^.statistics.tasks_not_in_long_wait + 1;
    cst_p^.ijle_p^.task_created_after_last_swap := TRUE;

    xcb_p^.global_task_id := rb.taskid;
    xcb_p^.parent_global_task_id := cst_p^.taskid;

{ Each task inherits its parents keypoint_enable flag.
    xcb_p^.keypoint_enable := cst_p^.xcb_p^.keypoint_enable;

    IF (osv$keypoint_control.environment = osc$system_keypoints) OR
          (osv$keypoint_control.environment = osc$system_sample_keypoints) THEN
      jm := osv$keypoint_control.jm;
      xcb_p^.keypoint_register_enable := TRUE;
    ELSE
{ check if correct job
      IF xcb_p^.keypoint_enable = TRUE THEN
{ correct - update masks
        jm := osv$keypoint_control.jm;
        xcb_p^.keypoint_register_enable := TRUE;
      ELSE
{ different - clear masks
        jm := $ost$keypoint_mask [];
        xcb_p^.keypoint_register_enable := FALSE;
      IFEND;
    IFEND;
    IF jm <> $ost$keypoint_mask [] THEN
      xcb_p^.xp.flags := xcb_p^.xp.flags + $ost$flags [osc$keypoint_enable];
    ELSE
      xcb_p^.xp.flags := xcb_p^.xp.flags - $ost$flags [osc$keypoint_enable];
    IFEND;
    xcb_p^.xp.keypoint_mask := jm;

    mmp$create_task (cst_p^.xcb_p, xcb_p, cst_p^.ijle_p);

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$create_task;
?? TITLE := 'TMP$TASK_EXIT', EJECT ??

  PROCEDURE [XDCL] tmp$task_exit
    (VAR rb: tmt$rb_task_exit;
         cst_p: ^ost$cpu_state_table);

*copyc tmh$task_exit

    VAR
      osv$trap_task_errors: [XDCL, #GATE] boolean := FALSE,
      pit_value: integer;


    rb.status.normal := TRUE;
    IF rb.parent_global_task_id <> cst_p^.xcb_p^.parent_global_task_id THEN
      mtp$set_status_abnormal ('TM', tme$invalid_global_taskid, rb.status);
      RETURN;
    IFEND;

    IF osv$trap_task_errors AND ((cst_p^.xcb_p^.system_table_lock_count DIV 256) <>
          0) THEN
      mtp$error_stop (' Task exit with system tables locked ');
    IFEND;

    tmp$update_system_task_list (cst_p^.xcb_p);

{  Send signal to the parent task.

    tmp$send_signal (rb.parent_global_task_id, rb.signal, rb.status);
    IF NOT rb.status.normal THEN
      RETURN;
    IFEND;


    mmp$exit_task (cst_p^.xcb_p);
    IF osv$special_aam_trap AND (cst_p^.xcb_p^.special_trap_count <> 0) THEN
      mtp$error_stop (' Trap AAM Lock problem ');
    IFEND;
    tmp$set_lock (tmv$ptl_lock);
    cst_p^.ijle_p^.maxws_aio_slowdown_display := 0;
    cst_p^.ijle_p^.statistics.ready_task_count := cst_p^.ijle_p^.statistics.ready_task_count - 1;
    cst_p^.ijle_p^.statistics.tasks_not_in_long_wait := cst_p^.ijle_p^.statistics.tasks_not_in_long_wait - 1;
    cst_p^.ijle_p^.task_created_after_last_swap := FALSE;
    cst_p^.accumulated_monitor_cptime := 0ffffffff(16) - #READ_REGISTER (osc$pr_process_interval_timer);
    pit_value := cst_p^.xcb_p^.xp.process_interval_timer_1 * 10000(16) + cst_p^.xcb_p^.xp.
          process_interval_timer_2;
    IF pit_value > 7fffffff(16) THEN
      pit_value := pit_value - 100000000(16);
    IFEND;
    cst_p^.accumulated_job_cptime := cst_p^.accumulated_job_cptime - pit_value;
    update_cp_statistics (cst_p);
    cst_p^.ijle_p^.executing_task_count := cst_p^.ijle_p^.executing_task_count - 1;
    free_ptl (cst_p^.taskid.index);
    remove_ijl (cst_p^.taskid, cst_p);
    cst_p^.xcb_p^.task_has_terminated := TRUE;
    cst_p^.jcb_p^.last_lpid_for_job := cst_p^.cst_index;
    cst_p^.xcb_p := NIL;
    cst_p^.dispatch_control.call_dispatcher := TRUE;
    IF (cst_p^.next_ptlo_to_dispatch = 0) THEN
      cst_p^.dispatching_priority_integer := tmv$dct_priority_integer;
    IFEND;

    tmv$total_task_count := tmv$total_task_count - 1;

    IF tmv$ptl_p^ [cst_p^.taskid.index].idle_status = tmc$is_idle_initiated THEN
      initiate_swap_if_possible (cst_p);
    IFEND;
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$task_exit;
?? TITLE := 'TMP$MTR_BEGIN_SYSTEM_ACTIVITY', EJECT ??

  PROCEDURE [XDCL] tmp$mtr_begin_lock_activity
    (    xcb_p: ^ost$execution_control_block;
         activity: 1 .. 256);

    IF activity = 1 THEN
      IF ((xcb_p^.system_table_lock_count MOD 256) = 255) THEN
        mtp$error_stop ('TM--subsystem table lock count exceeded');
      IFEND;
    IFEND;
    xcb_p^.system_table_lock_count := xcb_p^.system_table_lock_count + activity;

  PROCEND tmp$mtr_begin_lock_activity;
?? SKIP := 3 ??

  PROCEDURE [XDCL] tmp$mtr_end_lock_activity
    (    cst_p: ^ost$cpu_state_table;
         activity: 1 .. 256;
     VAR xcb_p: ^ost$execution_control_block);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      new_scheduling_priority: jmt$dispatching_priority,
      ptlo: ost$task_index,
      state: tmt$find_next_xcb_state,
      status: syt$monitor_status,
      temp_xcb_p: ^ost$execution_control_block;

    tmp$set_lock (tmv$ptl_lock);

{ Debug code--verify the lock count.

    IF activity = 256 THEN
      IF xcb_p^.system_table_lock_count < 256 THEN
        mtp$error_stop ('TM--system_table_lock_count 1');
      IFEND;
    ELSEIF activity = 1 THEN
      IF ((xcb_p^.system_table_lock_count MOD 256) = 0) THEN
        mtp$error_stop ('TM--system_table_lock_count 2');
      IFEND;
    ELSE
      mtp$error_stop ('TM--system_table_lock_count 3');
    IFEND;

{ End debug code.


    xcb_p^.system_table_lock_count := xcb_p^.system_table_lock_count - activity;
    ptlo := cst_p^.taskid.index;

    IF (xcb_p^.system_give_up_cpu) AND
          (xcb_p^.system_table_lock_count < 256) AND
          (xcb_p^.system_table_lock_count > 0) THEN

{  Reset the task to it's original priority. If the task has subsystem locks set
{  its correct PTL dispatching priority will be determined when the task is readied.
{  The TMP$DCT_READY_TASK procedure will sort out the priorities.

      tmv$ptl_p^ [ptlo].dispatching_priority := xcb_p^.dispatching_priority;
      xcb_p^.system_give_up_cpu := FALSE;
      cst_p^.dispatch_control.call_dispatcher := TRUE;
      IF (cst_p^.next_ptlo_to_dispatch = 0) THEN
        cst_p^.dispatching_priority_integer := tmv$dispatch_priority_integer
              [xcb_p^.dispatching_priority];
      IFEND;
    ELSEIF (xcb_p^.system_table_lock_count <= 0) AND
      (xcb_p^.system_give_up_cpu OR xcb_p^.subsystem_give_up_cpu) THEN

      xcb_p^.subsystem_give_up_cpu := FALSE;
      xcb_p^.system_give_up_cpu := FALSE;
      cst_p^.dispatch_control.call_dispatcher := TRUE;
      IF (cst_p^.next_ptlo_to_dispatch = 0) THEN
        cst_p^.dispatching_priority_integer := tmv$dispatch_priority_integer
              [xcb_p^.dispatching_priority];
      IFEND;

{  Reset the task to it's original priority. Also, reset the subsystem lock priority
{  which is maintained in the PTL.

      tmv$ptl_p^ [ptlo].dispatching_priority := xcb_p^.dispatching_priority;
      tmv$ptl_p^ [ptlo].readying_task_priority := 0;

      jmp$get_ijle_p (tmv$ptl_p^ [xcb_p^.global_task_id.index].ijl_ordinal, ijle_p);
      new_scheduling_priority := ijle_p^.dispatching_control.dispatching_priority;
      tmp$find_next_xcb (tmc$fnx_job, ijle_p, tmv$ptl_p^ [xcb_p^.global_task_id.index].ijl_ordinal,
             state, temp_xcb_p);
      WHILE temp_xcb_p <> NIL DO
        IF tmv$ptl_p^ [temp_xcb_p^.global_task_id.index].readying_task_priority >
                                new_scheduling_priority THEN
          new_scheduling_priority := tmv$ptl_p^ [temp_xcb_p^.global_task_id.index].readying_task_priority;
        IFEND;
        tmp$find_next_xcb (tmc$fnx_continue, NIL, jmv$null_ijl_ordinal, state, temp_xcb_p);
      WHILEND;
      ijle_p^.scheduling_dispatching_priority := new_scheduling_priority;
      xcb_p^.subsystem_lock_priority_count := 0;
      tmv$ptl_p^ [ptlo].ptl_flags.subsystem_locks_set := FALSE;
    IFEND;

    IF xcb_p^.stlc_allocation THEN
      xcb_p^.stlc_allocation := FALSE;
      tmp$set_monitor_flag (xcb_p^.global_task_id, mmc$mf_segment_mgr_flag, status);
    IFEND;

    ?IF tmc$debug_cycle_requests THEN
      IF (osv$debug > 0) THEN
        tmp$set_lock (tmv$ptl_lock);
        tmv$cycle_trace [ti].code := tmc$cyc_mtr_end_sys_activity;
        tmv$cycle_trace [ti].time := #FREE_RUNNING_CLOCK (0);
        ti := ti + 1;
        IF ti > 10000 THEN
          mtp$error_stop ('TM - trace buffer full');
        IFEND;
        tmp$clear_lock (tmv$ptl_lock);
      IFEND;
    ?IFEND;
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$mtr_end_lock_activity;
?? TITLE := 'TMP$CYCLE', EJECT ??

  PROCEDURE [XDCL] tmp$cycle
    (VAR rb: tmt$rb_cycle;
         cst_p: ^ost$cpu_state_table);

*copyc tmh$cycle

    VAR
      xcb_p: ^ost$execution_control_block,
      ijle_p: ^jmt$initiated_job_list_entry,
      state: tmt$find_next_xcb_state,
      new_scheduling_priority: jmt$dispatching_priority,
      lock_ptlo: ost$task_index,
      ptlo: ost$task_index;

    ptlo := cst_p^.taskid.index;
    tmp$set_lock (tmv$ptl_lock);

    IF NOT tmv$tables_initialized THEN
    ELSEIF (cst_p^.xcb_p^.system_table_lock_count > 0) AND
             (cst_p^.xcb_p^.system_table_lock_count < 256) AND
             (cst_p^.xcb_p^.system_give_up_cpu) THEN
      cst_p^.xcb_p^.system_give_up_cpu := FALSE;
    ELSEIF (cst_p^.xcb_p^.system_table_lock_count <= 0) AND
      (cst_p^.xcb_p^.system_give_up_cpu OR cst_p^.xcb_p^.subsystem_give_up_cpu) THEN

      cst_p^.xcb_p^.subsystem_give_up_cpu := FALSE;
      cst_p^.xcb_p^.system_give_up_cpu := FALSE;

{  Reset the task to it's original priority. Also, reset the subsystem lock priority
{  which is maintained in the PTL.

      tmv$ptl_p^ [ptlo].dispatching_priority := cst_p^.xcb_p^.dispatching_priority;
      tmv$ptl_p^ [ptlo].readying_task_priority := 0;

      new_scheduling_priority := cst_p^.ijle_p^.dispatching_control.dispatching_priority;
      tmp$find_next_xcb (tmc$fnx_job, cst_p^.ijle_p, cst_p^.ijl_ordinal, state, xcb_p);
      WHILE xcb_p <> NIL DO
        IF tmv$ptl_p^ [xcb_p^.global_task_id.index].readying_task_priority >
                                new_scheduling_priority THEN
          new_scheduling_priority := tmv$ptl_p^ [xcb_p^.global_task_id.index].readying_task_priority;
        IFEND;
        tmp$find_next_xcb (tmc$fnx_continue, NIL, jmv$null_ijl_ordinal, state, xcb_p);
      WHILEND;
      cst_p^.ijle_p^.scheduling_dispatching_priority := new_scheduling_priority;
      cst_p^.xcb_p^.subsystem_lock_priority_count := 0;
      tmv$ptl_p^ [ptlo].ptl_flags.subsystem_locks_set := FALSE;
    ELSEIF tmv$cycle_delay_time > 0 THEN
      tmv$ptl_p^ [ptlo].new_task_status := tmc$ts_timeout_reqexp_shortshrt;
      tmv$ptl_p^ [ptlo].end_of_wait_time := #FREE_RUNNING_CLOCK (0) + tmv$cycle_delay_time;
    IFEND;

    cst_p^.dispatch_control.call_dispatcher := TRUE;
    IF (cst_p^.next_ptlo_to_dispatch = 0) THEN
      cst_p^.dispatching_priority_integer := tmv$dct_priority_integer;
    IFEND;

    ?IF tmc$debug_cycle_requests THEN
      IF (osv$debug > 0) THEN
        tmv$cycle_trace [ti].code := rb.code;
        tmv$cycle_trace [ti].p1 := rb.p1;
        tmv$cycle_trace [ti].p2 := rb.p2;
        tmv$cycle_trace [ti].time := #FREE_RUNNING_CLOCK (0);
        tmv$cycle_trace [ti].xtask := ptlo;
        lock_ptlo := rb.lock_value DIV 256;
        tmv$cycle_trace [ti].gtid := lock_ptlo;
        tmv$cycle_trace [ti].status := tmv$ptl_p^ [lock_ptlo].status;
        IF tmv$cycle_trace [ti].status = tmc$ts_page_wait THEN
          jmp$get_ijle_p (tmv$ptl_p^ [lock_ptlo].ijl_ordinal, ijle_p);
          xcb_p := #ADDRESS (1, ijle_p^.ajl_ordinal + mtc$job_fixed_segment, tmv$ptl_p^ [lock_ptlo].
                xcb_offset);
          tmv$cycle_trace [ti].utp := xcb_p^.page_wait_info.pva;
          tmv$cycle_trace [ti].p := xcb_p^.xp.p_register.pva;
        IFEND;
        ti := ti + 1;
        IF ti > 10000 THEN
          mtp$error_stop ('TM - trace buffer full');
        IFEND;
      IFEND;
    ?IFEND;
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$cycle;
?? TITLE := 'TMP$DELAY', EJECT ??

  PROCEDURE [XDCL] tmp$delay
    (VAR rb: tmt$rb_delay;
         cst_p: ^ost$cpu_state_table);

*copyc tmh$delay

    VAR
      ptle_p: ^tmt$primary_task_list_entry;

    IF NOT tmv$tables_initialized THEN
      cst_p^.max_cptime := 20000;
      RETURN;
    IFEND;

    tmp$set_lock (tmv$ptl_lock);
    IF mlv$c170_rqst_blk.req <> NIL THEN
      IF (cst_p^.xcb_p^.global_task_id = mlv$c170_rqst_blk.req^.task_id) AND
            (cst_p^.xcb_p^.xp.p_register.pva.ring > 1) THEN
        IF mtv$mli_status.wait_inhibit THEN
          cst_p^.xcb_p^.wait_inhibited := TRUE;
          tmp$clear_lock (tmv$ptl_lock);
          RETURN;
        ELSE
          mtv$mli_status.ready := FALSE;
        IFEND;
      IFEND;
    IFEND;

    ptle_p := ^tmv$ptl_p^ [cst_p^.taskid.index];

    IF ptle_p^.monitor_flags <> $syt$monitor_flags [] THEN
      cst_p^.xcb_p^.xp.user_condition_register := cst_p^.xcb_p^.xp.
            user_condition_register + $ost$user_conditions [osc$free_flag];
      cst_p^.xcb_p^.monitor_flags := cst_p^.xcb_p^.monitor_flags + ptle_p^.monitor_flags;
      cst_p^.xcb_p^.system_flags := cst_p^.xcb_p^.system_flags + ptle_p^.system_flags;

      ptle_p^.monitor_flags := $syt$monitor_flags [];
      ptle_p^.system_flags := $tmt$system_flags [];
      tmp$clear_lock (tmv$ptl_lock);
      RETURN;
    IFEND;

    IF rb.requested_wait_time < UPPERVALUE (ost$free_running_clock) THEN
      IF (rb.expected_wait_time < tmv$long_wait_swap_time) OR (cst_p^.xcb_p^.system_table_lock_count > 0) THEN
        ptle_p^.new_task_status := tmc$ts_timeout_reqexp_longlong;
      ELSEIF (rb.expected_wait_time < tmv$timed_wait_not_queued) THEN
        ptle_p^.new_task_status := tmc$ts_timeout_reqexp_longvlong;
      ELSE
        ptle_p^.new_task_status := tmc$ts_timed_wait_not_queued;
      IFEND;
    ELSE
      IF (rb.expected_wait_time < tmv$long_wait_swap_time) OR (cst_p^.xcb_p^.system_table_lock_count > 0) THEN
        ptle_p^.new_task_status := tmc$ts_timeout_reqexp_inflong;
      ELSE
        ptle_p^.new_task_status := tmc$ts_timeout_reqexp_infvlong;
      IFEND;
    IFEND;
    ptle_p^.end_of_wait_time := rb.requested_wait_time;
    tmp$clear_lock (tmv$ptl_lock);
    cst_p^.dispatch_control.call_dispatcher := TRUE;
    IF (cst_p^.next_ptlo_to_dispatch = 0) THEN
      cst_p^.dispatching_priority_integer := tmv$dct_priority_integer;
    IFEND;


  PROCEND tmp$delay;
?? TITLE := 'TMP$MTR_WAIT', EJECT ??
  PROCEDURE [XDCL] tmp$mtr_wait
    (VAR rb {input, output} : tmt$rb_wait_signal;
         cst_p: ^ost$cpu_state_table);

*copyc tmh$mtr_wait

    VAR
      new_task_status: tmt$task_status,
      ptle_p: ^tmt$primary_task_list_entry,
      readied_ijle_p: ^jmt$initiated_job_list_entry,
      readying_task_priority: jmt$dispatching_priority,
      service_class_p: ^jmt$service_class_attributes;


{ If the request was PMP$READY_TASK_AND_WAIT, the rb.global_taskid contains the taskid of the task
{ to be readied.  That taskid must be a valid taskid.

    tmp$set_lock (tmv$ptl_lock);
    IF rb.global_taskid <> tmv$null_global_task_id THEN
      tmp$check_taskid_with_lock_set (rb.global_taskid, tmc$opt_return, rb.status);
      IF NOT rb.status.normal THEN
        tmp$clear_lock (tmv$ptl_lock);
        RETURN;
      IFEND;
    IFEND;


{ Determine the new task status based on the length of time the task wants to wait.

    IF rb.requested_wait_time < UPPERVALUE (ost$free_running_clock) THEN
      IF (rb.expected_wait_time < tmv$long_wait_swap_time) OR (cst_p^.xcb_p^.system_table_lock_count > 0) THEN
        new_task_status := tmc$ts_timeout_reqexp_longlong;
      ELSEIF (rb.expected_wait_time < tmv$timed_wait_not_queued) THEN
        new_task_status := tmc$ts_timeout_reqexp_longvlong;
      ELSE
        new_task_status := tmc$ts_timed_wait_not_queued;
      IFEND;
    ELSE
      IF (rb.expected_wait_time < tmv$long_wait_swap_time) OR (cst_p^.xcb_p^.system_table_lock_count > 0) THEN
        new_task_status := tmc$ts_timeout_reqexp_inflong;
      ELSE
        new_task_status := tmc$ts_timeout_reqexp_infvlong;
      IFEND;
    IFEND;


{ If this WAIT request will cause the job to go into long wait then do the
{ cyclic aging that is done as part of swapout. Note: long wait aging may cause tasks of the job to go ready
{ to assign backing files to transient segments. In this case the NEXT long wait should NOT
{ do LONG WAIT aging.

    ptle_p := ^tmv$ptl_p^ [cst_p^.taskid.index];
    ptle_p^.new_task_status := new_task_status;
    IF ((new_task_status = tmc$ts_timeout_reqexp_infvlong) OR
        (new_task_status = tmc$ts_timeout_reqexp_longvlong) OR
        (new_task_status = tmc$ts_timed_wait_not_queued)) AND
        (cst_p^.ijle_p^.statistics.tasks_not_in_long_wait = 1) AND NOT
         cst_p^.ijle_p^.long_wait_aging_complete AND (cst_p^.ajlo > 0) THEN
      IF (ptle_p^.monitor_flags = $syt$monitor_flags []) AND NOT
           (cst_p^.xcb_p^.wait_inhibited OR
           (ptle_p^.ptl_flags.wait_inhibited = tmc$wi_wait_inhibited)) THEN
        jsp$long_wait_aging (cst_p^.ijle_p);
        cst_p^.ijle_p^.long_wait_aging_complete := TRUE;
      IFEND;
    IFEND;


{ If the task has pending monitor flags or has wait inhibited, let it keep running.
{ If long wait aging has readied this task then PTL.NEW_TASK_STAUS will be null.

    new_task_status := ptle_p^.new_task_status;
    IF (ptle_p^.monitor_flags <> $syt$monitor_flags []) OR (new_task_status = tmc$ts_null) THEN
      cst_p^.xcb_p^.xp.user_condition_register := cst_p^.xcb_p^.xp.
            user_condition_register + $ost$user_conditions [osc$free_flag];
      cst_p^.xcb_p^.monitor_flags := cst_p^.xcb_p^.monitor_flags + ptle_p^.monitor_flags;
      cst_p^.xcb_p^.system_flags := cst_p^.xcb_p^.system_flags + ptle_p^.system_flags;
      ptle_p^.monitor_flags := $syt$monitor_flags [];
      ptle_p^.system_flags := $tmt$system_flags [];
      new_task_status := tmc$ts_null;
    ELSEIF cst_p^.xcb_p^.wait_inhibited OR
         (ptle_p^.ptl_flags.wait_inhibited =  tmc$wi_wait_inhibited) THEN
      new_task_status := tmc$ts_null;
    IFEND;

    IF new_task_status <> tmc$ts_null THEN
      IF cst_p^.xcb_p^.xp.p_register.pva.ring <= osc$tsrv_ring THEN
        ptle_p^.ptl_flags.wait_inhibited := tmc$wi_wait_selected_r3;
      ELSE
        ptle_p^.ptl_flags.wait_inhibited := tmc$wi_wait_selected;
      IFEND;
      ptle_p^.end_of_wait_time := rb.requested_wait_time;
      cst_p^.dispatch_control.call_dispatcher := TRUE;
      IF (cst_p^.next_ptlo_to_dispatch = 0) THEN
        cst_p^.dispatching_priority_integer := tmv$dct_priority_integer;
      IFEND;
    ELSE
      cst_p^.xcb_p^.wait_inhibited := FALSE;
      ptle_p^.ptl_flags.wait_inhibited := tmc$wi_null;
      ptle_p^.new_task_status := tmc$ts_null;
    IFEND;

{ If user request was PMP$READY_TASK_AND_WAIT, the rb.global_taskid is the taskid of the task to
{ be readied.

    IF rb.global_taskid <> tmv$null_global_task_id THEN
      IF cst_p^.xcb_p^.dispatching_priority >=
           tmv$ptl_p^ [cst_p^.xcb_p^.global_task_id.index].readying_task_priority THEN
        readying_task_priority := cst_p^.xcb_p^.dispatching_priority;
      ELSE
        readying_task_priority := tmv$ptl_p^ [cst_p^.xcb_p^.global_task_id.index].readying_task_priority;
      IFEND;
      tmp$set_task_ready (rb.global_taskid, readying_task_priority,
         tmc$rc_ready_conditional_wi);
      jmp$get_ijle_p (tmv$ptl_p^ [rb.global_taskid.index].ijl_ordinal, readied_ijle_p);
      IF readied_ijle_p^.entry_status = jmc$ies_job_swapped THEN
        service_class_p := ^jmv$service_classes [cst_p^.ijle_p^.job_scheduler_data.service_class]^.attributes;
        cst_p^.ijle_p^.job_scheduler_data.service_accumulator_since_swap :=
              service_class_p^.guaranteed_service_quantum;
        IF readied_ijle_p^.job_scheduler_data.priority > service_class_p^.scheduling_priority.minimum THEN
          IF cst_p^.ijle_p^.job_scheduler_data.priority >= readied_ijle_p^.job_scheduler_data.priority THEN
            cst_p^.ijle_p^.job_scheduler_data.priority := readied_ijle_p^.job_scheduler_data.priority - 1;
          IFEND;
        ELSEIF readied_ijle_p^.job_scheduler_data.priority = service_class_p^.scheduling_priority.minimum THEN
          cst_p^.ijle_p^.job_scheduler_data.priority := readied_ijle_p^.job_scheduler_data.priority;
        IFEND;
      IFEND;
    IFEND;

    tmp$clear_lock (tmv$ptl_lock);


  PROCEND tmp$mtr_wait;
?? TITLE := 'TMP$CHECK_FOR_SWAPOUT_CANDIDATE', EJECT ??

  PROCEDURE [XDCL] tmp$check_for_swapout_candidate
    (    ajl_ordinal: jmt$ajl_ordinal);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      next_ready_time: integer,
      ptlo: ost$task_index,
      xcb_p: ^ost$execution_control_block;


    IF (ajl_ordinal = jmv$system_ajl_ordinal) OR NOT jmv$swap_jobs_in_long_wait THEN
      RETURN;
    IFEND;

    ijle_p := jmv$ajl_p^ [ajl_ordinal].ijle_p;
    ptlo := ijle_p^.job_monitor_taskid.index;
    next_ready_time := 0ffffffffffff(16);

{ Do long wait aging if not already done.

    IF NOT ijle_p^.long_wait_aging_complete THEN
      jsp$long_wait_aging (ijle_p);
      ijle_p^.long_wait_aging_complete := TRUE;
    IFEND;

{ If the job now has a ready task (that condition must be checked with the PTL lock set) or if a
{ task of the job has a system lock set, do NOT swap out the job.
{ Scan the PTL thread for the job and search for next ready time.  If the next ready time of all
{ tasks is greater than the force-long-wait-swap-time, then swap the job out.

    tmp$set_lock (tmv$ptl_lock);

    IF ijle_p^.statistics.ready_task_count > 0 THEN
      tmp$clear_lock (tmv$ptl_lock);
      RETURN;
    IFEND;

    WHILE ptlo <> 0 DO
      tmp$get_xcb_p_from_ptlo (ptlo, ajl_ordinal, xcb_p);
      IF xcb_p^.system_table_lock_count <> 0 THEN
        tmp$clear_lock (tmv$ptl_lock);
        RETURN;
      ELSEIF (tmv$ptl_p^ [ptlo].status >= tmc$ts_first_status_in_wait_q) AND
            (tmv$ptl_p^ [ptlo].status <= tmc$ts_last_status_in_wait_q) AND
            (tmv$ptl_p^ [ptlo].end_of_wait_time < next_ready_time) THEN
        next_ready_time := tmv$ptl_p^ [ptlo].end_of_wait_time;
      IFEND;
      ptlo := tmv$ptl_p^ [ptlo].ijl_thread;
    WHILEND;

    IF (next_ready_time - #FREE_RUNNING_CLOCK (0)) > tmv$long_wait_force_swap_time THEN
      tmp$set_swapout_candidate (ajl_ordinal);
    IFEND;

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$check_for_swapout_candidate;
?? TITLE := 'TMP$SET_SWAPOUT_CANDIDATE', EJECT ??

{  NOTE : Anyone calling this routine must have tmv$ptl_lock set.

  PROCEDURE tmp$set_swapout_candidate
    (    ajl_ordinal: jmt$ajl_ordinal);

    VAR
      temp_next_cyclic_aging: integer,
      ptlo: ost$task_index,
      jcb_p: ^jmt$job_control_block,
      ijle_p: ^jmt$initiated_job_list_entry;

    IF (ajl_ordinal = jmv$system_ajl_ordinal) OR NOT jmv$swap_jobs_in_long_wait THEN
      RETURN;
    IFEND;

    ijle_p := jmv$ajl_p^ [ajl_ordinal].ijle_p;

{ Scan the IJL thread and mark the entries swapped.

    ptlo := ijle_p^.job_monitor_taskid.index;

    WHILE ptlo <> 0 DO
      tmv$ptl_p^ [ptlo].idle_status := tmc$is_idled;
      ptlo := tmv$ptl_p^ [ptlo].ijl_thread;
    WHILEND;

    jcb_p := #ADDRESS (1, mtc$job_fixed_segment + ajl_ordinal, 0);
    temp_next_cyclic_aging := jcb_p^.next_cyclic_aging_time - #FREE_RUNNING_CLOCK (0);
    IF temp_next_cyclic_aging < 0 THEN
      jcb_p^.next_cyclic_aging_time := 0;
    ELSE
      jcb_p^.next_cyclic_aging_time := temp_next_cyclic_aging;
    IFEND;

    jmp$set_swapout_candidate (ajl_ordinal, jmc$sr_long_wait);

  PROCEND tmp$set_swapout_candidate;

?? TITLE := '[XDCL] tmp$idle_non_dispatchable_job', EJECT ??

{ PURPOSE:
{   This procedure will idle a job whose dispatching priority is currently too low to be dispatched.
{ DESIGN:
{   This procedure is called from mmp$periodic when a job is discovered to be non-dispatchable.  The job is
{   swapped out only if all tasks can be idled.

  PROCEDURE [XDCL] tmp$idle_non_dispatchable_job
    (    ajl_ordinal: jmt$ajl_ordinal);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      status: syt$monitor_status;

    tmp$set_lock (tmv$ptl_lock);

    ijle_p := jmv$ajl_p^ [ajl_ordinal].ijle_p;
    IF ijle_p^.entry_status = jmc$ies_job_in_memory THEN
      tmp$idle_tasks_in_job (ajl_ordinal, jmc$sr_idle_dispatching, status);
      IF status.normal THEN
        jmp$swap_non_dispatchable_job (ajl_ordinal);
      IFEND;
    IFEND;

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$idle_non_dispatchable_job;

?? TITLE := 'TMP$IDLE_TASKS_IN_JOB', EJECT ??

{ PURPOSE:
{   The purpose of this procedure is to idle all tasks in a job.
{   NOTE!!! The caller of this procedure MUST set the PTL lock.

  PROCEDURE [XDCL] tmp$idle_tasks_in_job
    (    ajl_ordinal: jmt$ajl_ordinal;
         swapout_reason: jmt$swapout_reasons;
     VAR status: syt$monitor_status);

    VAR
      attempt_preselection: boolean,
      end_ptlo: ost$task_index,
      ijle_p: ^jmt$initiated_job_list_entry,
      jcb_p: ^jmt$job_control_block,
      ptlo: ost$task_index,
      ready_task_count: integer,
      tasks_not_swappable_count: 0 .. osc$max_tasks,
      temp_next_cyclic_aging: integer,
      xcb_p: ^ost$execution_control_block;

    status.normal := TRUE;
    ijle_p := jmv$ajl_p^ [ajl_ordinal].ijle_p;

    jcb_p := #ADDRESS (1, mtc$job_fixed_segment + ajl_ordinal, 0);

{ Reject the request if the job is non-swappable.

    IF jmv$ajl_p^ [ajl_ordinal].ijle_p^.entry_status = jmc$ies_job_in_memory_non_swap THEN
      mtp$set_status_abnormal ('JS', jse$job_executing_non_swappable, status);
      RETURN;
    IFEND;

{ Scan the IJL thread and mark the entries swapped.  If the swapout reason is idle dispatching and ALL
{ tasks cannot be idled, then do not idle any tasks.

    ptlo := ijle_p^.job_monitor_taskid.index;
    ready_task_count := 0;
    tasks_not_swappable_count := 0;

    WHILE ptlo <> 0 DO
      xcb_p := #ADDRESS (1, mtc$job_fixed_segment + ajl_ordinal, tmv$ptl_p^ [ptlo].xcb_offset);
      IF (xcb_p^.system_table_lock_count >= osc$system_table_lock_set) OR
            (tmv$ptl_p^ [ptlo].status = tmc$ts_executing) OR
            (tmv$ptl_p^ [ptlo].status = tmc$ts_ready_and_selected) OR
            (xcb_p^.system_table_lock_count > 0) AND ((tmv$ptl_p^ [ptlo].status <
            tmc$ts_timeout_reqexp_longlong) OR (tmv$ptl_p^ [ptlo].status >
            tmc$ts_timeout_reqexp_infvlong)) THEN
        IF swapout_reason <> jmc$sr_idle_dispatching THEN
          tasks_not_swappable_count := tasks_not_swappable_count + 1;
          tmv$ptl_p^ [ptlo].idle_status := tmc$is_idle_initiated;
        ELSE
          end_ptlo := ptlo;
          ptlo := ijle_p^.job_monitor_taskid.index;
          WHILE (ptlo <> end_ptlo) DO
            IF (tmv$ptl_p^ [ptlo].idle_status >= tmc$is_idled) THEN
              IF tmv$ptl_p^ [ptlo].status = tmc$ts_ready_but_swapped THEN
                tmv$ptl_p^ [ptlo].status := tmc$ts_ready;
              IFEND;
              IF tmv$ptl_p^ [ptlo].status <= tmc$ts_last_status_in_dct THEN
                attempt_preselection := (ijle_p^.multiprocessing_allowed) OR
                      (ijle_p^.executing_task_count = 0);
                tmp$dct_ready_task (xcb_p, ijle_p, ptlo, attempt_preselection);
              IFEND;
            IFEND;
            tmv$ptl_p^ [ptlo].idle_status := tmc$is_not_idled;
            ptlo := tmv$ptl_p^ [ptlo].ijl_thread;
          WHILEND;
          mtp$set_status_abnormal ('JS', jse$unable_to_idle_all_tasks, status);
          RETURN;
        IFEND;

      ELSEIF tmv$ptl_p^ [ptlo].status <= tmc$ts_last_status_in_dct THEN
        tmp$remove_task_from_dct (ptlo);
        tmv$ptl_p^ [ptlo].status := tmc$ts_ready_but_swapped;
        ready_task_count := ready_task_count + 1;
        tmv$ptl_p^ [ptlo].idle_status := tmc$is_idled_sched_notified;
      ELSE
        tmv$ptl_p^ [ptlo].idle_status := tmc$is_idled;
      IFEND;

      IF xcb_p^.system_table_lock_count > 0 THEN
        tmv$ptl_p^ [ptlo].ptl_flags.subsystem_locks_set := TRUE;
      IFEND;

      ptlo := tmv$ptl_p^ [ptlo].ijl_thread;
    WHILEND;

    IF tasks_not_swappable_count <> 0 THEN
      mtp$set_status_abnormal ('JS', jse$unable_to_idle_all_tasks, status);
    ELSE
      temp_next_cyclic_aging := jcb_p^.next_cyclic_aging_time - #FREE_RUNNING_CLOCK (0);
      IF temp_next_cyclic_aging < 0 THEN
        jcb_p^.next_cyclic_aging_time := 0;
      ELSE
        jcb_p^.next_cyclic_aging_time := temp_next_cyclic_aging;
      IFEND;
    IFEND;

  PROCEND tmp$idle_tasks_in_job;
?? TITLE := 'TMP$RESTART_IDLED_TASKS', EJECT ??

  PROCEDURE [XDCL] tmp$restart_idled_tasks
    (    ajl_ordinal: jmt$ajl_ordinal);

    VAR
      attempt_preselection: boolean,
      cst_p: ^ost$cpu_state_table,
      ijle_p: ^jmt$initiated_job_list_entry,
      ready_task_count: integer,
      xcb_p: ^ost$execution_control_block,
      ptlo: ost$task_index;


    jmp$get_ijle_p (jmv$ajl_p^ [ajl_ordinal].ijl_ordinal, ijle_p);

    IF jmc$dsw_update_keypoint_masks IN ijle_p^.delayed_swapin_work THEN
      osp$update_job_keypoint_mask (ijle_p, jmv$ajl_p^ [ajl_ordinal].ijl_ordinal);
    IFEND;

    ptlo := ijle_p^.job_monitor_taskid.index;

{ Scan the IJL thread and mark the entries swapped in.

    ready_task_count := 0;
    tmp$set_lock (tmv$ptl_lock);
    WHILE ptlo <> 0 DO
      xcb_p := #ADDRESS (1, mtc$job_fixed_segment + ajl_ordinal, tmv$ptl_p^ [ptlo].xcb_offset);
      IF (tmv$ptl_p^ [ptlo].idle_status >= tmc$is_idled) THEN
        IF tmv$ptl_p^ [ptlo].status = tmc$ts_ready_but_swapped THEN
          tmv$ptl_p^ [ptlo].status := tmc$ts_ready;
          ready_task_count := ready_task_count + 1;
        IFEND;
        IF tmv$ptl_p^ [ptlo].status <= tmc$ts_last_status_in_dct THEN
          attempt_preselection := (ijle_p^.multiprocessing_allowed) OR (ijle_p^.executing_task_count = 0);
          tmp$dct_ready_task (xcb_p, ijle_p, ptlo, attempt_preselection);
        IFEND;
      IFEND;
      tmv$ptl_p^ [ptlo].idle_status := tmc$is_not_idled;
      ptlo := tmv$ptl_p^ [ptlo].ijl_thread;
    WHILEND;

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$restart_idled_tasks;
?? TITLE := 'TMP$IDLE_TASKS_IN_SYSTEM_JOB', EJECT ??

  PROCEDURE tmp$idle_tasks_in_system_job
    (    idle_resume_sys_task_kind: tmt$idle_resume_sys_task_kind;
     VAR status: syt$monitor_status);

    VAR
      ptlo: ost$task_index,
      xcb_p: ^ost$execution_control_block,
      ready_task_count: integer,
      ijle_p: ^jmt$initiated_job_list_entry,
      tasks_not_swappable_count: 0 .. osc$max_tasks;

    status.normal := TRUE;
    ijle_p := jmv$ajl_p^ [jmv$system_ajl_ordinal].ijle_p;
    tmp$set_lock (tmv$ptl_lock);

{ Scan the IJL thread and mark the entries swapped.

    ptlo := ijle_p^.job_monitor_taskid.index;
    ready_task_count := 0;
    tasks_not_swappable_count := 0;

    IF idle_resume_sys_task_kind = tmc$ir_dm_system_tasks THEN { Idle ONLY the Device_Management tasks. }

      WHILE ptlo <> 0 DO
        xcb_p := #ADDRESS (1, mtc$job_fixed_segment + jmv$system_ajl_ordinal, tmv$ptl_p^ [ptlo].xcb_offset);
        IF (xcb_p^.system_task_id = tmc$stid_administer_log) OR
              (xcb_p^.system_task_id = tmc$stid_dm_split_al) OR
              (xcb_p^.system_task_id = tmc$stid_volume_space_managemnt) THEN
          IF (xcb_p^.system_table_lock_count >= osc$system_table_lock_set) OR
             (tmv$ptl_p^ [ptlo].status = tmc$ts_executing) OR
             (tmv$ptl_p^ [ptlo].status = tmc$ts_ready_and_selected) OR
            (xcb_p^.system_table_lock_count > 0) AND ((tmv$ptl_p^ [ptlo].status <
            tmc$ts_timeout_reqexp_shortshrt)  OR (tmv$ptl_p^ [ptlo].status > tmc$ts_last_status_in_wait_q))
                   THEN
            tasks_not_swappable_count := tasks_not_swappable_count + 1;
            tmv$ptl_p^ [ptlo].idle_status := tmc$is_idle_initiated;
          ELSEIF tmv$ptl_p^ [ptlo].status <= tmc$ts_last_status_in_dct THEN
            tmp$remove_task_from_dct (ptlo);
            tmv$ptl_p^ [ptlo].status := tmc$ts_ready_but_swapped;
            ready_task_count := ready_task_count + 1;
            tmv$ptl_p^ [ptlo].idle_status := tmc$is_idled_sched_notified;
          ELSE
            tmv$ptl_p^ [ptlo].idle_status := tmc$is_idled;
          IFEND;
        IFEND;
        ptlo := tmv$ptl_p^ [ptlo].ijl_thread;
      WHILEND;

      tmp$clear_lock (tmv$ptl_lock);

      IF tasks_not_swappable_count <> 0 THEN
        { Some Device_Management task is still executing. }
        mtp$set_status_abnormal ('JS', jse$unable_to_idle_all_tasks, status);
      IFEND;

    ELSE { Idle everything EXCEPT the Device_Management tasks. }

      WHILE ptlo <> 0 DO
        xcb_p := #ADDRESS (1, mtc$job_fixed_segment + jmv$system_ajl_ordinal, tmv$ptl_p^ [ptlo].xcb_offset);
        IF (xcb_p^.system_task_id <> tmc$stid_administer_log) AND
              (xcb_p^.system_task_id <> tmc$stid_dm_split_al) AND
              (xcb_p^.system_task_id <> tmc$stid_volume_space_managemnt) THEN
          IF (xcb_p^.system_table_lock_count >= osc$system_table_lock_set) OR
               (tmv$ptl_p^ [ptlo].status = tmc$ts_executing) OR
               (tmv$ptl_p^ [ptlo].status = tmc$ts_ready_and_selected) OR
                (xcb_p^.system_table_lock_count > 0) AND ((tmv$ptl_p^ [ptlo].status <
                tmc$ts_timeout_reqexp_shortshrt) OR (tmv$ptl_p^ [ptlo].status > tmc$ts_last_status_in_wait_q))
                THEN
            tasks_not_swappable_count := tasks_not_swappable_count + 1;
            tmv$ptl_p^ [ptlo].idle_status := tmc$is_idle_initiated;
          ELSEIF tmv$ptl_p^ [ptlo].status <= tmc$ts_last_status_in_dct THEN
            tmp$remove_task_from_dct (ptlo);
            tmv$ptl_p^ [ptlo].status := tmc$ts_ready_but_swapped;
            ready_task_count := ready_task_count + 1;
            tmv$ptl_p^ [ptlo].idle_status := tmc$is_idled_sched_notified;
          ELSE
            tmv$ptl_p^ [ptlo].idle_status := tmc$is_idled;
          IFEND;
        IFEND;
        ptlo := tmv$ptl_p^ [ptlo].ijl_thread;
      WHILEND;

      tmp$clear_lock (tmv$ptl_lock);

      IF tasks_not_swappable_count <> 1 THEN
        { A system task other than the system JOB_MONITOR is still executing. }
        mtp$set_status_abnormal ('JS', jse$unable_to_idle_all_tasks, status);
      IFEND;
    IFEND;

  PROCEND tmp$idle_tasks_in_system_job;
?? TITLE := 'TMP$RESTART_TASKS_IN_SYSTEM_JOB', EJECT ??

  PROCEDURE tmp$restart_tasks_in_system_job
    (    idle_resume_sys_task_kind: tmt$idle_resume_sys_task_kind;
     VAR status: syt$monitor_status);

    VAR
      attempt_preselection: boolean,
      ptlo: ost$task_index,
      ready_task_count: integer,
      xcb_p: ^ost$execution_control_block,
      ijle_p: ^jmt$initiated_job_list_entry;

    status.normal := TRUE;
    jmp$get_ijle_p (jmv$ajl_p^ [jmv$system_ajl_ordinal].ijl_ordinal, ijle_p);

    IF jmc$dsw_update_keypoint_masks IN ijle_p^.delayed_swapin_work THEN
      osp$update_job_keypoint_mask (ijle_p, jmv$system_ijl_ordinal);
    IFEND;

    ptlo := ijle_p^.job_monitor_taskid.index;

{ Scan the IJL thread and mark the entries swapped in.

    ready_task_count := 0;
    tmp$set_lock (tmv$ptl_lock);

    IF idle_resume_sys_task_kind = tmc$ir_dm_system_tasks THEN { Restart ONLY the Device_Management tasks. }

      WHILE ptlo <> 0 DO
        xcb_p := #ADDRESS (1, mtc$job_fixed_segment + jmv$system_ajl_ordinal, tmv$ptl_p^ [ptlo].xcb_offset);
        IF (xcb_p^.system_task_id = tmc$stid_administer_log) OR
              (xcb_p^.system_task_id = tmc$stid_dm_split_al) OR
              (xcb_p^.system_task_id = tmc$stid_volume_space_managemnt) THEN
          IF (tmv$ptl_p^ [ptlo].idle_status >= tmc$is_idled) THEN
            IF tmv$ptl_p^ [ptlo].status = tmc$ts_ready_but_swapped THEN
              tmv$ptl_p^ [ptlo].status := tmc$ts_ready;
              ready_task_count := ready_task_count + 1;
            IFEND;
            IF tmv$ptl_p^ [ptlo].status <= tmc$ts_last_status_in_dct THEN
              attempt_preselection := (ijle_p^.multiprocessing_allowed) OR (ijle_p^.executing_task_count = 0);
              tmp$dct_ready_task (xcb_p, ijle_p, ptlo, attempt_preselection);
            IFEND;
          IFEND;
          tmv$ptl_p^ [ptlo].idle_status := tmc$is_not_idled;
        IFEND;
        ptlo := tmv$ptl_p^ [ptlo].ijl_thread;
      WHILEND;

      tmp$clear_lock (tmv$ptl_lock);

    ELSE { Restart everything EXCEPT the Device_Management tasks. }

      WHILE ptlo <> 0 DO
        xcb_p := #ADDRESS (1, mtc$job_fixed_segment + jmv$system_ajl_ordinal, tmv$ptl_p^ [ptlo].xcb_offset);
        IF (xcb_p^.system_task_id <> tmc$stid_administer_log) AND
              (xcb_p^.system_task_id <> tmc$stid_dm_split_al) AND
              (xcb_p^.system_task_id <> tmc$stid_volume_space_managemnt) THEN
          IF (tmv$ptl_p^ [ptlo].idle_status >= tmc$is_idled) THEN
            IF tmv$ptl_p^ [ptlo].status = tmc$ts_ready_but_swapped THEN
              tmv$ptl_p^ [ptlo].status := tmc$ts_ready;
              ready_task_count := ready_task_count + 1;
            IFEND;
            IF tmv$ptl_p^ [ptlo].status <= tmc$ts_last_status_in_dct THEN
              attempt_preselection := (ijle_p^.multiprocessing_allowed) OR (ijle_p^.executing_task_count = 0);
              tmp$dct_ready_task (xcb_p, ijle_p, ptlo, attempt_preselection);
            IFEND;
          IFEND;
          tmv$ptl_p^ [ptlo].idle_status := tmc$is_not_idled;
        IFEND;
        ptlo := tmv$ptl_p^ [ptlo].ijl_thread;
      WHILEND;

      tmp$clear_lock (tmv$ptl_lock);
    IFEND;

  PROCEND tmp$restart_tasks_in_system_job;
?? TITLE := 'update_cp_statistics', EJECT ??

  PROCEDURE [INLINE] update_cp_statistics
    (    cst_p: ^ost$cpu_state_table);

{
{  The purpose of this procedure is to update the cp statistics in the
{  IJL, XCB, JCB and the system statistics record.
{
{    UPDATE_CP_STATISTICS (CST_P)
{
{  CST_P: (INPUT) This parameter specifies the pointer to the CPU
{                 STATE TABLE.
{

    VAR
      excess_cp_time_used: integer,
      minor_time_slice_remaining: integer,
      major_time_slice_remaining: integer,
      status: syt$monitor_status,
      task_time_slice_used: integer,
      total_cptime: integer;


{ Update cp statistics in IJL.

    cst_p^.ijle_p^.statistics.cp_time.time_spent_in_mtr_mode := cst_p^.ijle_p^.statistics.cp_time.
          time_spent_in_mtr_mode + cst_p^.accumulated_monitor_cptime;
    cst_p^.ijle_p^.statistics.cp_time.time_spent_in_job_mode := cst_p^.ijle_p^.statistics.cp_time.
          time_spent_in_job_mode + cst_p^.accumulated_job_cptime;

    task_time_slice_used := cst_p^.accumulated_job_cptime + cst_p^.accumulated_monitor_cptime;

{ Update the dispatching priority controls.

    update_dispatching_controls (task_time_slice_used, cst_p^.dispatching_priority);

{ Update system data statistics.

    tmv$cpu_execution_statistics [cst_p^.dispatching_priority].time_spent_in_mtr_mode :=
          tmv$cpu_execution_statistics [cst_p^.dispatching_priority].time_spent_in_mtr_mode +  cst_p^.
          accumulated_monitor_cptime;
    tmv$cpu_execution_statistics [cst_p^.dispatching_priority].time_spent_in_job_mode :=
          tmv$cpu_execution_statistics [cst_p^.dispatching_priority].time_spent_in_job_mode +  cst_p^.
          accumulated_job_cptime;

{ Update cp statistics in XCB.

    cst_p^.xcb_p^.cp_time.time_spent_in_mtr_mode := cst_p^.xcb_p^.cp_time.time_spent_in_mtr_mode + cst_p^.
          accumulated_monitor_cptime;
    cst_p^.xcb_p^.cp_time.time_spent_in_job_mode := cst_p^.xcb_p^.cp_time.time_spent_in_job_mode + cst_p^.
          accumulated_job_cptime;

    IF task_time_slice_used >= cst_p^.ijle_p^.dispatching_control.service_remaining THEN

{ Reset the dispatching control for the task, based on the service class dispatching controls.

      excess_cp_time_used := task_time_slice_used - cst_p^.ijle_p^.dispatching_control.service_remaining;
      tmp$reset_dispatching_control (cst_p^.ijle_p, cst_p^.ijl_ordinal, excess_cp_time_used, TRUE);

    ELSE

{Calculate the time remaining on this tasks time slice.

      cst_p^.ijle_p^.dispatching_control.service_remaining := cst_p^.ijle_p^.dispatching_control.
            service_remaining - task_time_slice_used;
      minor_time_slice_remaining := cst_p^.xcb_p^.timeslice.minor - task_time_slice_used;
      major_time_slice_remaining := cst_p^.xcb_p^.timeslice.major - task_time_slice_used;
      IF minor_time_slice_remaining < 0 THEN
        cst_p^.xcb_p^.timeslice.minor := 0;
      ELSE
        cst_p^.xcb_p^.timeslice.minor := minor_time_slice_remaining;
      IFEND;
      IF major_time_slice_remaining < 0 THEN
        cst_p^.xcb_p^.timeslice.major := 0;
      ELSE
        cst_p^.xcb_p^.timeslice.major := major_time_slice_remaining;
      IFEND;
    IFEND;

{  Send a flag to the job monitor of the current job if the flag interval
{  has expired.

    total_cptime := cst_p^.ijle_p^.statistics.cp_time.time_spent_in_job_mode + cst_p^.ijle_p^.statistics.
          cp_time.time_spent_in_mtr_mode;
    IF total_cptime - cst_p^.jcb_p^.cptime_signal_last_sent >= cst_p^.jcb_p^.signal_interval THEN
      tmp$set_system_flag (cst_p^.jcb_p^.job_monitor_id, avc$monitor_statistics_flag, status);
      cst_p^.jcb_p^.cptime_signal_last_sent := total_cptime;
    IFEND;

  PROCEND update_cp_statistics;

?? TITLE := '[INLINE] update_dispatching_controls', EJECT ??

  PROCEDURE [INLINE] update_dispatching_controls
    (    time_used: integer;
         dispatching_priority: jmt$dispatching_priority);

    VAR
      dp: jmt$dispatching_priority;

    IF (tmv$dispatching_controls.controls_defined) AND (dispatching_priority < jmc$priority_p9) THEN
      IF time_used >= tmv$dispatching_control_time.time_left_in_interval THEN  {RESET THE TABLE}
        tmv$dispatching_control_time := tmv$dispatching_controls.controls;
        tmv$dispatching_control_sets.minimums_to_satisfy := tmv$dispatching_controls.minimums_to_satisfy;
        tmv$dispatching_control_sets.maximums_exceeded := $jmt$dispatching_priority_set [];
        tmv$dispatching_control_sets.enforce_maximums := $jmt$dispatching_priority_set [];
        tmp$calculate_dct_priority_int;
        FOR dp := jmc$priority_p1 TO jmc$priority_p8 DO
          update_priority_integer (dp);
        FOREND;
      ELSE
        tmv$dispatching_control_time.time_left_in_interval := tmv$dispatching_control_time.
                time_left_in_interval - time_used;
        IF dispatching_priority <> jmc$null_dispatching_priority THEN
          IF (jmc$dp_conversion - dispatching_priority) IN tmv$dispatching_control_sets.
                minimums_to_satisfy THEN
            IF time_used >= tmv$dispatching_control_time.dispatching_priority_time
                  [dispatching_priority].minimum_time THEN
              tmv$dispatching_control_sets.minimums_to_satisfy := tmv$dispatching_control_sets.
                    minimums_to_satisfy - $jmt$dispatching_priority_set
                    [jmc$dp_conversion - dispatching_priority];
              tmp$calculate_dct_priority_int;
              update_priority_integer (dispatching_priority);
            ELSE
              tmv$dispatching_control_time.dispatching_priority_time [dispatching_priority].minimum_time
                    := tmv$dispatching_control_time.dispatching_priority_time [dispatching_priority].
                    minimum_time - time_used;
            IFEND;
          IFEND;

          IF ((jmc$dp_conversion - dispatching_priority) IN tmv$dispatching_controls.maximums_defined)
                AND NOT ((jmc$dp_conversion - dispatching_priority) IN tmv$dispatching_control_sets.
                maximums_exceeded) THEN
            IF time_used >= tmv$dispatching_control_time.dispatching_priority_time
                  [dispatching_priority].maximum_time THEN
              tmv$dispatching_control_sets.maximums_exceeded := tmv$dispatching_control_sets.
                    maximums_exceeded + $jmt$dispatching_priority_set
                    [jmc$dp_conversion - dispatching_priority];
              jmv$idle_dispatching_controls.maximums_exceeded := jmv$idle_dispatching_controls.
                    maximums_exceeded + $jmt$dispatching_priority_set [jmc$dp_conversion -
                    dispatching_priority];
              IF (jmc$dp_conversion - dispatching_priority) IN tmv$dispatching_controls.enforce_maximums THEN
                tmv$dispatching_control_sets.enforce_maximums := tmv$dispatching_control_sets.
                      enforce_maximums + $jmt$dispatching_priority_set
                      [jmc$dp_conversion - dispatching_priority];
              IFEND;
              tmp$calculate_dct_priority_int;
              update_priority_integer (dispatching_priority);
            ELSE
              tmv$dispatching_control_time.dispatching_priority_time [dispatching_priority].maximum_time
                    := tmv$dispatching_control_time.dispatching_priority_time [dispatching_priority].
                    maximum_time - time_used;
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;

  PROCEND update_dispatching_controls;

?? TITLE := '[INLINE] update_priority_integer', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to calculate and change the integer priority value for a specific
{   dispatching priority.  This is done only when the priority crosses a minimum allocated or maximum
{   allocated dispatching allocation threshold.

  PROCEDURE [INLINE] update_priority_integer
    (    dp: jmt$dispatching_priority);

    VAR
      local_set: tmt$dispatching_control_sets;

    local_set := tmv$dispatching_control_sets;

    local_set.ready_tasks := $jmt$dispatching_priority_set [jmc$dp_conversion - dp] -
          (local_set.enforce_maximums * local_set.maximums_exceeded);
    local_set.enforce_maximums := $jmt$dispatching_priority_set [];
    local_set.minimums_to_satisfy := local_set.minimums_to_satisfy * local_set.ready_tasks;
    local_set.maximums_exceeded := local_set.maximums_exceeded * local_set.ready_tasks;
    local_set.ready_tasks := local_set.ready_tasks XOR (local_set.minimums_to_satisfy +
          local_set.maximums_exceeded);
    #unchecked_conversion (local_set, tmv$dispatch_priority_integer [dp]);

  PROCEND update_priority_integer;

?? TITLE := '[XDCL, INLINE] tmp$calculate_dct_priority_int', EJECT ??
{ PURPOSE:
{   The purpose of this procedure is to calculate the integer priority value for the DCT queues
{   with ready tasks.  If there is nothing queued in the DCT, the integer priority will be 0.
{   If there are tasks queued, the integer priority represents the highest allocated dispatching
{   priority.

  PROCEDURE [XDCL, INLINE] tmp$calculate_dct_priority_int;

    VAR
      local_set: tmt$dispatching_control_sets;

    local_set := tmv$dispatching_control_sets;
    local_set.ready_tasks := local_set.ready_tasks - (local_set.enforce_maximums *
           local_set.maximums_exceeded);
    local_set.enforce_maximums := $jmt$dispatching_priority_set [];
    local_set.minimums_to_satisfy := local_set.minimums_to_satisfy * local_set.ready_tasks;
    local_set.maximums_exceeded := local_set.maximums_exceeded * local_set.ready_tasks;
    local_set.ready_tasks := local_set.ready_tasks XOR (local_set.minimums_to_satisfy +
          local_set.maximums_exceeded);

    #unchecked_conversion (local_set, tmv$dct_priority_integer);

  PROCEND tmp$calculate_dct_priority_int;

?? TITLE := 'INITIATE_SWAP_IF_POSSIBLE', EJECT ??

{  NOTE : Anyone calling this routine must have tmv$ptl_lock set.

  PROCEDURE [INLINE] initiate_swap_if_possible
    (    cst_p: ^ost$cpu_state_table);

    VAR
      jcb_p: ^jmt$job_control_block,
      temp_next_cyclic_aging: integer,
      ptlo: ost$task_index;

    ptlo := cst_p^.ijle_p^.job_monitor_taskid.index;
    WHILE (ptlo <> 0) AND (tmv$ptl_p^ [ptlo].idle_status >= tmc$is_idled) DO
      ptlo := tmv$ptl_p^ [ptlo].ijl_thread;
    WHILEND;
    IF ptlo = 0 THEN
      jcb_p := #ADDRESS (1, mtc$job_fixed_segment + cst_p^.ajlo, 0);
      temp_next_cyclic_aging := jcb_p^.next_cyclic_aging_time - #FREE_RUNNING_CLOCK (0);
      IF temp_next_cyclic_aging < 0 THEN
        jcb_p^.next_cyclic_aging_time := 0;
      ELSE
        jcb_p^.next_cyclic_aging_time := temp_next_cyclic_aging;
      IFEND;
      jsp$idle_tasks_complete (cst_p^.ijl_ordinal);
    IFEND;

  PROCEND initiate_swap_if_possible;
?? TITLE := 'TMP$FETCH_TASK_STATISTICS', EJECT ??

  PROCEDURE [XDCL] tmp$fetch_task_statistics
    (VAR rb: tmt$rb_fetch_task_statistics;
         cst_p: ^ost$cpu_state_table);

*copyc tmh$fetch_task_statistics

    VAR
      current_pit_value: integer;

    rb.status.normal := TRUE;
    rb.monitor_cptime := cst_p^.xcb_p^.cp_time.time_spent_in_mtr_mode + 0ffffffff(16) -
          #READ_REGISTER (osc$pr_process_interval_timer);

    current_pit_value := cst_p^.xcb_p^.xp.process_interval_timer_1 * 10000(16) + cst_p^.xcb_p^.xp.
         process_interval_timer_2;
    IF current_pit_value > 7fffffff(16) THEN
      current_pit_value := current_pit_value - 100000000(16);
    IFEND;
    rb.job_cptime := cst_p^.accumulated_job_cptime - current_pit_value +
        cst_p^.xcb_p^.cp_time.time_spent_in_job_mode;

  PROCEND tmp$fetch_task_statistics;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] tmp$mtr_update_job_task_enviro', EJECT ??

  PROCEDURE [XDCL] tmp$mtr_update_job_task_enviro
    (VAR rb: tmt$rb_update_job_task_enviro;
         cst_p: ^ost$cpu_state_table);


    VAR
      current_pit_value: integer,
      dispatching_controls: jmt$dispatching_controls,
      i: integer,
      ijle_p: ^jmt$initiated_job_list_entry,
      new_max_ptlo: ost$task_index,
      old_max_ptlo: ost$task_index,
      service_used: integer;

    rb.status.normal := TRUE;
    tmp$set_lock (tmv$ptl_lock);
    CASE rb.subcode OF
    = tmc$ujte_xp_register =
      CASE rb.register_id OF
      = osc$pr_process_interval_timer =
        current_pit_value := cst_p^.xcb_p^.xp.process_interval_timer_1 * 10000(16) + cst_p^.xcb_p^.xp.
              process_interval_timer_2;
        IF current_pit_value > 7fffffff(16) THEN
          current_pit_value := current_pit_value - 100000000(16);
        IFEND;
        cst_p^.accumulated_job_cptime := cst_p^.accumulated_job_cptime + rb.pit_value - current_pit_value;
        cst_p^.xcb_p^.pit_count := cst_p^.xcb_p^.pit_count + rb.pit_value - current_pit_value;
        cst_p^.xcb_p^.xp.process_interval_timer_1 := rb.pit_value DIV 10000(16);
        cst_p^.xcb_p^.xp.process_interval_timer_2 := rb.pit_value MOD 10000(16);
      ELSE
      CASEND;

    = tmc$ujte_dispatching_priority =
      jmp$get_ijle_p (rb.ijl_ordinal, ijle_p);
      IF ijle_p <> NIL THEN

{ Verify that the same job is still using this ijl ordinal.

        IF ijle_p^.system_supplied_name <> rb.system_supplied_name THEN
          tmp$clear_lock (tmv$ptl_lock);
          mtp$set_status_abnormal ('JM', jme$non_existent_job, rb.status);
          RETURN;
        IFEND;

        CASE rb.request_origin OF
        = tmc$cpo_operator, tmc$cpo_recovery =

{ A null dispatching priority indicates the operator specified DEFAULT; the system must determine
{ the correct dispatching control set based on total service the job has used.
{ If the operator has specified a dispatching priority, assign the job that priority.

{ If the null priority is coming from job recovery, we have completed job recovery and must now
{ set the dispatching priority back to its original value.  It had been set up to the system job
{ dispatching priority to guarantee that it would swap in and recover.

          IF rb.dispatching_control_info.dispatching_priority = jmc$null_dispatching_priority THEN

            IF rb.request_origin = tmc$cpo_operator THEN
              ijle_p^.dispatching_control.operator_set_dispatching_prio := jmc$null_dispatching_priority;
            IFEND;
            calculate_service_used (ijle_p, service_used);
            tmp$reset_dispatching_control (ijle_p, rb.ijl_ordinal, service_used, FALSE);

          ELSE
            ijle_p^.dispatching_control.operator_set_dispatching_prio := rb.dispatching_control_info.
                  dispatching_priority;
            ijle_p^.dispatching_control.dispatching_priority := rb.dispatching_control_info.
                  dispatching_priority;
            ijle_p^.dispatching_control.service_remaining := jmc$dc_maximum_service_limit;
            tmp$update_job_task_environment (ijle_p, rb.ijl_ordinal, tmc$fnx_job);
          IFEND;

          IF (ijle_p^.dispatching_control.dispatching_priority <>
                              ijle_p^.scheduling_dispatching_priority)  THEN
            ijle_p^.scheduling_dispatching_priority := ijle_p^.dispatching_control.dispatching_priority;
          IFEND;
          jmp$set_scheduler_event (jmc$examine_swapin_queue);

        = tmc$cpo_user =

{ Store the user requested dispatching priority, determine which priority is allowed, and update.

          ijle_p^.dispatching_control.user_requested_dispatching_prio := rb.dispatching_control_info.
                dispatching_priority;
          determine_dispatching_priority (ijle_p);
          tmp$update_job_task_environment (ijle_p, rb.ijl_ordinal, tmc$fnx_job);

        = tmc$cpo_set_job_unswappable =

{ A job is set unswappable during job termination.  The job is given system dispatching priority
{ with unlimited service.

          ijle_p^.dispatching_control.dispatching_control_index := jmc$min_dispatching_control;
          ijle_p^.scheduling_dispatching_priority := jmc$priority_system_job;
          ijle_p^.dispatching_control.dispatching_priority := jmc$priority_system_job;
          ijle_p^.dispatching_control.service_remaining := jmc$dc_maximum_service_limit;
          ijle_p^.dispatching_control.operator_set_dispatching_prio := jmc$null_dispatching_priority;
          ijle_p^.dispatching_control.user_requested_dispatching_prio := jmc$null_dispatching_priority;
          tmp$update_job_task_environment (ijle_p, rb.ijl_ordinal, tmc$fnx_job);

        = tmc$cpo_interactive_command, tmc$cpo_save_swap_file_sfid  =

{ A new command line has been scanned for an interactive job or the job is through critical initiation;
{ the first dispatching control set for the class is used.

          IF rb.request_origin = tmc$cpo_interactive_command THEN
            ijle_p^.interactive_task_gtid := tmv$null_global_task_id;
          IFEND;
          ijle_p^.dispatching_control.dispatching_control_index := jmc$min_dispatching_control;
          ijle_p^.dispatching_control.service_remaining := jmv$service_classes
                [ijle_p^.job_scheduler_data.service_class]^.attributes.dispatching_control [1].service_limit;
          ijle_p^.cp_time_last_dc_reset := ijle_p^.statistics.cp_time.time_spent_in_job_mode +
                ijle_p^.statistics.cp_time.time_spent_in_mtr_mode;
          determine_dispatching_priority (ijle_p);
          tmp$update_job_task_environment (ijle_p, rb.ijl_ordinal, tmc$fnx_job);

        = tmc$cpo_interrupt_restore  =

{ Restore the job's dispatching control information to the values saved from before a user interrupt.
{ If the dispatching_control_index is no longer a valid one for the job's service class (the service class
{ has been changed since the dispatching control info was saved), calculate the correct dispatching_
{ control_index based on the CP service the job has used.

          dispatching_controls := jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.attributes.
                dispatching_control [rb.dispatching_control_info.dispatching_control_index];
          IF (NOT dispatching_controls.set_defined) OR (dispatching_controls.service_limit <
                rb.dispatching_control_info.service_remaining) OR
                (dispatching_controls.dispatching_priority <> rb.dispatching_control_info.
                dispatching_priority) THEN

            calculate_service_used (ijle_p, service_used);
            tmp$reset_dispatching_control (ijle_p, rb.ijl_ordinal, service_used, FALSE);
          ELSE
            ijle_p^.dispatching_control.dispatching_control_index := rb.dispatching_control_info.
                  dispatching_control_index;
            ijle_p^.dispatching_control.service_remaining := rb.dispatching_control_info.
                  service_remaining;
            determine_dispatching_priority (ijle_p);
            tmp$update_job_task_environment (ijle_p, rb.ijl_ordinal, tmc$fnx_job);
          IFEND;
        ELSE

        CASEND;

      IFEND;

    = tmc$ujte_set_non_swappable =
      IF tmv$ptl_p^ [cst_p^.taskid.index].idle_status = tmc$is_not_idled THEN
        jmp$change_ijl_entry_status (cst_p^.ijle_p, jmc$ies_job_in_memory_non_swap);
      ELSE
        tmp$reissue_monitor_request;
        cst_p^.dispatch_control.call_dispatcher := TRUE;
      IFEND;

    = tmc$ujte_idle_other_sys_tasks =
      tmp$idle_tasks_in_system_job (tmc$ir_other_system_tasks, rb.status);

    = tmc$ujte_restart_other_systasks =
      tmp$restart_tasks_in_system_job (tmc$ir_other_system_tasks, rb.status);

    = tmc$ujte_idle_dm_sys_tasks =
      tmp$idle_tasks_in_system_job (tmc$ir_dm_system_tasks, rb.status);

    = tmc$ujte_restart_dm_systasks =
      tmp$restart_tasks_in_system_job (tmc$ir_dm_system_tasks, rb.status);

    = tmc$ujte_expand_ptl =

{   Copy the entries from the old PTL to the new PTL.  Then link the new PTL entries into the free queue.
{   Reset tmv$ptl_p to point to the new expanded ptl.

      old_max_ptlo := UPPERBOUND (tmv$ptl_p^);
      new_max_ptlo := UPPERBOUND (rb.ptl_p^);
      I#MOVE (tmv$ptl_p, rb.ptl_p, #SIZE (tmv$ptl_p^));
      FOR i := old_max_ptlo + 1 TO new_max_ptlo - 1 DO
        rb.ptl_p^[i].ptl_thread := i + 1;
      FOREND;
      rb.ptl_p^[new_max_ptlo].ptl_thread := 0;
      tmv$ptl_p := rb.ptl_p;

      IF tmv$dct [jmc$null_dispatching_priority].queue_head = 0 THEN
        tmv$dct [jmc$null_dispatching_priority].queue_head := old_max_ptlo + 1;
      ELSE
        tmv$ptl_p^ [tmv$dct [jmc$null_dispatching_priority].queue_tail].ptl_thread := old_max_ptlo + 1;
      IFEND;
      tmv$dct [jmc$null_dispatching_priority].queue_tail := new_max_ptlo;

    = tmc$ujte_update_debug_masks =
      tmp$update_debug_registers;

    = tmc$ujte_set_task_terminating =

{ The free_flag is not set here because immediately after the return to job mode,
{ all of the outstanding signals and flags are processed.

      cst_p^.xcb_p^.task_is_terminating := TRUE;
      cst_p^.xcb_p^.monitor_flags := cst_p^.xcb_p^.monitor_flags + tmv$ptl_p^
            [cst_p^.taskid.index].monitor_flags;
      cst_p^.xcb_p^.system_flags := cst_p^.xcb_p^.system_flags + tmv$ptl_p^
            [cst_p^.taskid.index].system_flags;
      tmv$ptl_p^ [cst_p^.taskid.index].system_flags := $tmt$system_flags [ ];
      tmv$ptl_p^ [cst_p^.taskid.index].monitor_flags := $syt$monitor_flags [ ];

    = tmc$ujte_update_cpu_selections =
      tmp$update_job_task_cpu_selects;

    ELSE

      tmp$clear_lock (tmv$ptl_lock);
      mtp$error_stop ('TM - unimplemented subcode');

    CASEND;
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$mtr_update_job_task_enviro;

?? TITLE := 'TMP$UPDATE_JOB_TASK_ENVIRONMENT', EJECT ??

{ PURPOSE:
{   This procedure changes the dispatching priority and timeslice in the XCB
{   for all tasks of a job.
{ DESIGN:
{   The caller has stored the new dispatching priority in the IJL.
{   If the XCB of the job can be referenced (ie, the job is NOT swapped out)
{   changes to the XCB are made.  If the job is swapped out, the delayed
{   swapin work bit is set, which causes this procedure to be called again
{   when the job swaps back in.

  PROCEDURE [XDCL] tmp$update_job_task_environment
    (    ijle_p: ^jmt$initiated_job_list_entry;
         ijl_ordinal: jmt$ijl_ordinal;
         xcb_search: tmt$fnx_search_type);

    VAR
      attempt_preselection: boolean,
      ptlo: ost$task_index,
      ptle_p: ^tmt$primary_task_list_entry,
      xcb_p: ^ost$execution_control_block,
      dispatching_priority: integer, {must be integer}
      state: tmt$find_next_xcb_state;

    tmp$set_lock (tmv$ptl_lock);
    tmp$find_next_xcb (xcb_search, ijle_p, ijl_ordinal, state, xcb_p);
    IF xcb_p = NIL THEN
      ijle_p^.delayed_swapin_work := ijle_p^.delayed_swapin_work +
            $jmt$delayed_swapin_work [jmc$dsw_update_job_task_enviro];
    ELSE
      WHILE xcb_p <> NIL DO
        IF xcb_p^.dispatching_priority_bias_id <> jmc$dpb_absolute THEN
          IF xcb_p^.dispatching_priority_bias_id = jmc$dpb_positive THEN
            dispatching_priority := ijle_p^.dispatching_control.dispatching_priority
                + xcb_p^.dispatching_priority_bias;
          ELSE
            dispatching_priority := ijle_p^.dispatching_control.dispatching_priority
                  - xcb_p^.dispatching_priority_bias;
          IFEND;
          IF dispatching_priority > jmc$max_dispatching_priority THEN
            dispatching_priority := jmc$max_dispatching_priority;
          ELSEIF dispatching_priority < jmc$min_dispatching_priority THEN
            dispatching_priority := jmc$min_dispatching_priority;
          IFEND;
          xcb_p^.dispatching_priority := dispatching_priority;
          ptlo := xcb_p^.global_task_id.index;
          ptle_p := ^tmv$ptl_p^ [ptlo];
          xcb_p^.timeslice := jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.attributes.
                dispatching_control [ijle_p^.dispatching_control.dispatching_control_index].
                dispatching_timeslice;
          IF xcb_p^.system_table_lock_count <= 0 THEN
            IF ptle_p^.status <= tmc$ts_last_status_in_dct THEN
              tmp$remove_task_from_dct (ptlo);
              ptle_p^.dispatching_priority := xcb_p^.dispatching_priority;
              attempt_preselection := (ijle_p^.multiprocessing_allowed) OR (ijle_p^.executing_task_count = 0);
              tmp$dct_ready_task (xcb_p, ijle_p, ptlo, attempt_preselection);
            ELSE
              ptle_p^.dispatching_priority := xcb_p^.dispatching_priority;
            IFEND;
          IFEND;
        IFEND;
        tmp$find_next_xcb (tmc$fnx_continue, NIL, jmv$null_ijl_ordinal, state, xcb_p);
      WHILEND;
    IFEND;
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$update_job_task_environment;

?? TITLE := 'TMP$UPDATE_JOB_TASK_CPU_SELECTS', EJECT ??

{ PURPOSE:
{   This procedure changes the processor selections in the XCB for all tasks in the system.
{ DESIGN:
{   The knowledge of the cpus which are still logically on is contained in the SCB.  If the XCB of the job can
{   be referenced (ie, the job is NOT swapped out) changes to the XCB are made.  If the job is swapped out,
{   the delayed swapin work bit is set, which causes the changes to the XCB to be made when the job swaps back
{   in.

  PROCEDURE [XDCL] tmp$update_job_task_cpu_selects;

    VAR
      delayed_swapin_work_record: jmt$delayed_swapin_work_record,
      state: tmt$find_next_xcb_state,
      xcb_p: ^ost$execution_control_block;

    { Set the delayed swapin work bit in the ijl for all jobs.  Only swapped jobs will look at it.

    delayed_swapin_work_record.delayed_swapin_work :=
          $jmt$delayed_swapin_work [jmc$dsw_adjust_cpu_selections];
    jsp$set_delayed_swapin_work_mtr (delayed_swapin_work_record);

    { Update the XCB in active jobs.

    tmp$set_lock (tmv$ptl_lock);
    tmp$find_next_xcb (tmc$fnx_system, NIL, jmv$null_ijl_ordinal, state, xcb_p);

    mtv$scb.cpus.available_for_use := mtv$scb.cpus.logically_on;

    WHILE xcb_p <> NIL DO
      IF xcb_p^.requested_processor_selections * mtv$scb.cpus.available_for_use =
            $ost$processor_id_set [ ] THEN
        xcb_p^.processor_selections := mtv$scb.cpus.available_for_use;
      ELSE
        xcb_p^.processor_selections := xcb_p^.requested_processor_selections *
              mtv$scb.cpus.available_for_use;
      IFEND;
      tmp$find_next_xcb (tmc$fnx_continue, NIL, jmv$null_ijl_ordinal, state, xcb_p);
    WHILEND;

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$update_job_task_cpu_selects;
?? TITLE := 'TMP$CHANGE_TASKS_170_CP_SELECTS', EJECT ??

{ PURPOSE:
{   This procedure resets the processor selections of all tasks to exclude selection of the dual state CPU
{   when that CPU is dedicated to the 170 system.  The procedure will add the cpus which are currently
{   logically ON to all of the tasks which have selected only the dual state processor.  (This procedure is
{   called when a cpu is dedicated to, or undedicated from, the 170 system.)
{ DESIGN:
{   1). Search for all of the XCBs that have the processor selection of the dual state cpu.
{   2). Change the processor selections in each XCB in the following manner:
{       . If the set of selected processors consists only of the processor which is dedicated to 170, reselect
{         all processors which are logically ON.

  PROCEDURE [XDCL] tmp$change_tasks_170_cp_selects
    (    dedicate_cpu: boolean;
         cpu_to_dedicate: ost$processor_id);

    VAR
      delayed_swapin_work_record: jmt$delayed_swapin_work_record,
      ijle_p: ^jmt$initiated_job_list_entry,
      state: tmt$find_next_xcb_state,
      xcb_p: ^ost$execution_control_block;

    { Set the delayed swapin work bit in the ijl for all jobs.  Only swapped jobs will look at it.

    delayed_swapin_work_record.delayed_swapin_work :=
          $jmt$delayed_swapin_work [jmc$dsw_adjust_cpu_selections];
    jsp$set_delayed_swapin_work_mtr (delayed_swapin_work_record);

    { Update the XCB in active jobs.

    tmp$set_lock (tmv$ptl_lock);
    tmp$find_next_xcb (tmc$fnx_system, NIL, jmv$system_ijl_ordinal, state, xcb_p);

    WHILE xcb_p <> NIL DO
      IF xcb_p^.requested_processor_selections = $ost$processor_id_set [cpu_to_dedicate] THEN
        IF dedicate_cpu THEN
          jmp$get_ijle_p (tmv$ptl_p^ [xcb_p^.global_task_id.index].ijl_ordinal, ijle_p);
          IF ijle_p^.job_scheduler_data.job_class = jmc$maintenance_job_class THEN
            xcb_p^.processor_selections := mtv$scb.cpus.logically_on;
          ELSE
            xcb_p^.processor_selections := mtv$scb.cpus.available_for_use;
          IFEND;
        ELSE {undedicate}
          xcb_p^.processor_selections := xcb_p^.requested_processor_selections;
        IFEND;
      IFEND;
      tmp$find_next_xcb (tmc$fnx_continue, NIL, jmv$null_ijl_ordinal, state, xcb_p);
    WHILEND;

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$change_tasks_170_cp_selects;

?? TITLE := 'CALCULATE_SERVICE_USED', EJECT ??

{ PURPOSE:
{   This procedure calculates the amount of CP service a job has used.  The procedure
{   tmp$reset_dispatching_control determines the dispatching control index to use, based
{   on the SERVICE_USED returned.
{ DESIGN:
{   For interactive jobs, return 0 for service_used; the dispatching control index should
{   be reset to the first index.  For batch classes, base service_used on total cp time.
{   If the job's service class has circular dynamic dispatching priorities defined,
{   MOD the service_used by the sums of the service limits.

  PROCEDURE calculate_service_used
    (    ijle_p: ^jmt$initiated_job_list_entry;
     VAR service_used: integer);

    VAR
      circular_service: integer,
      dispatching_control_p: ^jmt$dispatching_control,
      dispatching_control_index: jmt$dispatching_control_index;

    IF ijle_p^.job_mode <> jmc$batch THEN
      service_used := 0;
    ELSE
      service_used := ijle_p^.statistics.cp_time.time_spent_in_job_mode + ijle_p^.statistics.
            cp_time.time_spent_in_mtr_mode - ijle_p^.dispatching_control.cp_service_at_class_switch;
      circular_service := 0;
      dispatching_control_p := ^jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.attributes.
            dispatching_control;
    /calculate_circular_service/
      FOR dispatching_control_index := jmc$max_dispatching_control DOWNTO
            jmc$min_dispatching_control DO
        IF dispatching_control_p^ [dispatching_control_index].set_defined THEN
          IF dispatching_control_p^ [dispatching_control_index].service_limit <>
                jmc$dc_maximum_service_limit THEN
            circular_service := circular_service + dispatching_control_p^ [dispatching_control_index].
                  service_limit;
          ELSE
            EXIT /calculate_circular_service/;
          IFEND;
        IFEND;
      FOREND /calculate_circular_service/;
      IF circular_service <> 0 THEN
        service_used := service_used MOD circular_service;
      IFEND;
    IFEND;

  PROCEND calculate_service_used;

?? TITLE := 'DETERMINE_DISPATCHING_PRIORITY', EJECT ??

{ PURPOSE:
{   This procedure determines which dispatching priority a job should have
{   and stores it in the IJL.
{ DESIGN:
{   If the operator has changed the dispatching priority for a job, that dispatching
{   priority is used.  Otherwise the job is assigned the lesser of the user requested
{   dispatching priority (if there is one) and the dispatching priority defined in the
{   service class table dispatching control sets.

  PROCEDURE determine_dispatching_priority
    (   ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      update_scheduling_priority: boolean;

{ The scheduling_dispatching_priority and the dispatching_controls.dispatching_priority will only
{ be different in the case of a task of the job having subsystem locks set and being readied by
{ a task which has a higher dispatching priority. In that instance, the scheduling_dispatching_priority
{ will be updated when the task releases the lock and issues a CYCLE request.

    update_scheduling_priority := (ijle_p^.dispatching_control.dispatching_priority = ijle_p^.
              scheduling_dispatching_priority);
    IF ijle_p^.dispatching_control.operator_set_dispatching_prio <> jmc$null_dispatching_priority THEN
      ijle_p^.dispatching_control.dispatching_priority := ijle_p^.dispatching_control.
            operator_set_dispatching_prio;
    ELSE
      IF (ijle_p^.dispatching_control.user_requested_dispatching_prio <> jmc$null_dispatching_priority) AND
            (ijle_p^.dispatching_control.user_requested_dispatching_prio <
            jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.
            attributes.dispatching_control [ijle_p^.dispatching_control.dispatching_control_index].
            dispatching_priority) THEN
        ijle_p^.dispatching_control.dispatching_priority := ijle_p^.dispatching_control.
              user_requested_dispatching_prio;
      ELSE
        ijle_p^.dispatching_control.dispatching_priority :=
              jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.
              attributes.dispatching_control [ijle_p^.dispatching_control.dispatching_control_index].
              dispatching_priority;
      IFEND;
    IFEND;

    IF update_scheduling_priority THEN
      ijle_p^.scheduling_dispatching_priority := ijle_p^.dispatching_control.dispatching_priority;
    IFEND;

  PROCEND determine_dispatching_priority;

?? TITLE := 'TMP$RESET_DISPATCHING_CONTROLS', EJECT ??

{ PURPOSE:
{   This procedure is called to reset the dispatching control set for a job.
{ DESIGN:
{   If expired_dispatching_control is TRUE, the procedure has been called because a
{   a task switch determined that the job has used all the service allowed for the
{   current dispatching control index.  The next index needs to be assigned.
{   Otherwise the procedure needs to determine the correct index based on
{   the total amount of service the job has used.
{   The procedure finds the correct dispatching control index, determines the
{   dispatching priority, and makes a call to update the dispatching priority
{   in the XCB.

  PROCEDURE [XDCL] tmp$reset_dispatching_control
    (    ijle_p: ^jmt$initiated_job_list_entry;
         ijl_ordinal: jmt$ijl_ordinal;
         excess_service_used: integer;
         expired_dispatching_control: boolean);

    VAR
      dispatching_control_p: ^jmt$dispatching_control,
      next_index: integer,
      service_used: integer;

    dispatching_control_p := ^jmv$service_classes [ijle_p^.job_scheduler_data.service_class]^.attributes.
          dispatching_control;

    service_used := excess_service_used;

    IF expired_dispatching_control THEN
      next_index := ijle_p^.dispatching_control.dispatching_control_index + 1;
    ELSE
      next_index := jmc$min_dispatching_control;
    IFEND;

  /find_dispatching_control_set/
    WHILE service_used >= 0 DO
      IF (next_index <= jmc$max_dispatching_control) AND (dispatching_control_p^ [next_index].set_defined)
            THEN
        IF dispatching_control_p^ [next_index].service_limit > service_used THEN
          ijle_p^.dispatching_control.service_remaining := dispatching_control_p^ [next_index].service_limit -
                service_used;
          ijle_p^.dispatching_control.dispatching_control_index := next_index;
          determine_dispatching_priority (ijle_p);
          tmp$update_job_task_environment (ijle_p, ijl_ordinal, tmc$fnx_job);
          EXIT /find_dispatching_control_set/;
        ELSE
          service_used := service_used - dispatching_control_p^ [next_index].service_limit;
          next_index := next_index + 1;
        IFEND;
      ELSE
        next_index := jmc$min_dispatching_control;
      IFEND;
    WHILEND /find_dispatching_control_set/;

  PROCEND tmp$reset_dispatching_control;

?? TITLE := 'TMP$SWITCH_TASK', EJECT ??

  PROCEDURE [XDCL] tmp$switch_task
    (    dummy: ^cell;
         cst_p: ^ost$cpu_state_table);

*copyc tmh$switch_task


    VAR
      attempt_preselection: boolean,
      locked_dp_integer: integer,
      next_ptlo_to_dispatch: ost$task_index,
      next_task_ijle_p: ^jmt$initiated_job_list_entry,
      next_task_xcb_p: ^ost$execution_control_block,
      priority: dp_trick_conversion,
      local_set: tmt$dispatching_control_sets,
      integer_dp_sets: integer,
      r: real,
      idle_time: integer,
      time: integer,
      xcb_p: ^ost$execution_control_block,
      ptle_p: ^tmt$primary_task_list_entry,
      ptlo: ost$task_index;


{ Update task accounting info.

    #KEYPOINT (osk$mtr, osk$monitor_multiplier * 0, tmk$switch_task);

    IF NOT tmv$tables_initialized THEN
      cst_p^.max_cptime := 20000;
      RETURN;
    IFEND;

{ Wake up memory link helper if 170 has set a flag to activate it.

   ?IF NOT DEBUG THEN
      IF mtv$mli_status.wait_inhibit AND NOT mtv$mli_status.ready THEN
        tmp$set_task_ready (mlv$c170_rqst_blk.req^.task_id, 0 {readying_task_priority},
           tmc$rc_ready_conditional_wi);
      IFEND;
   ?IFEND;

{ If the CPU is not idle (cst_p^.xcb_p is not NIL), update the executing tasks's status.

    xcb_p := cst_p^.xcb_p;

    tmp$set_lock (tmv$ptl_lock);

    IF xcb_p <> NIL THEN

      IF cst_p^.accumulated_job_cptime <> 0 THEN
        update_cp_statistics (cst_p);
      IFEND;

      xcb_p^.last_lpid_for_task := cst_p^.cst_index;
      cst_p^.jcb_p^.last_lpid_for_job := cst_p^.cst_index;
      cst_p^.jcb_p^.last_execution_time := #FREE_RUNNING_CLOCK (0);
      ptlo := cst_p^.taskid.index;
      ptle_p := ^tmv$ptl_p^ [ptlo];

{ If the task has system tables locked and is still ready, let it keep running.  Raise the task's dispatching
{ priority in the CST.

      /system_locks_set/
      BEGIN
        IF xcb_p^.system_table_lock_count > 0 THEN
          IF (ptle_p^.new_task_status = tmc$ts_null) AND (cst_p^.cpu_state.next_state <> osc$cpu_stepped) AND
                (cst_p^.next_processor_state = cmc$on) THEN
            IF (xcb_p^.system_table_lock_count >= osc$system_table_lock_set) THEN
              IF cst_p^.dispatching_priority < jmc$prior_system_tbls_locked THEN
                cst_p^.dispatching_priority := jmc$prior_system_tbls_locked;
                locked_dp_integer := tmv$dispatch_priority_integer [jmc$prior_system_tbls_locked];
              IFEND;
              xcb_p^.system_give_up_cpu := TRUE;
            ELSEIF (xcb_p^.subsystem_lock_priority_count <= tmv$subsystem_prior_threshold) THEN
              xcb_p^.subsystem_lock_priority_count := xcb_p^.subsystem_lock_priority_count + 1;
              IF cst_p^.dispatching_priority < jmc$prior_subsystem_tbls_locked THEN
                cst_p^.dispatching_priority := jmc$prior_subsystem_tbls_locked;
                locked_dp_integer := tmv$dispatch_priority_integer [jmc$prior_subsystem_tbls_locked];
              IFEND;
              xcb_p^.subsystem_give_up_cpu := TRUE;
            ELSE
              EXIT /system_locks_set/;
            IFEND;
            cst_p^.dual_state_prior_subpriority := tmv$dual_state_dispatch_prior
                   [cst_p^.dispatching_priority];
            cst_p^.max_cptime := jmv$service_classes [cst_p^.ijle_p^.job_scheduler_data.service_class]^.
                  attributes.dispatching_control [cst_p^.ijle_p^.dispatching_control.
                  dispatching_control_index].dispatching_timeslice.minor;

{ If this processor was being interrupted to switch to a higher priority task, the task must be inserted
{ in the DCT because this processor cannot be interrupted now.  Do not change the dispatching priority
{ integer to the locks-set value until after checking/removing a pre-selected task.  When the task was
{ pre-selcted the dispatching priority integer for the CPU was changed to the pre-selected task's priority.
{ If it is changed, the task may be pre_selected for this processor again.
{ Example:  A P6 task is executing; a P10 task has been pre_selected (so dispatching priority integer
{ is P10).  The P6 task has sub-system locks set, so its priority is raised to P9.  Changing the dispatching
{ priority integer to P9 before calling dct_ready_task again for the pre-selected P10 task could cause
{ this CPU to be pre-selected again.

            IF cst_p^.next_ptlo_to_dispatch <> 0 THEN
              next_ptlo_to_dispatch := cst_p^.next_ptlo_to_dispatch;
              jmp$get_ijle_p (tmv$ptl_p^ [next_ptlo_to_dispatch].ijl_ordinal, next_task_ijle_p);
              next_task_ijle_p^.executing_task_count := next_task_ijle_p^.executing_task_count - 1;
              tmv$ptl_p^ [next_ptlo_to_dispatch].status := tmc$ts_ready;
              tmp$get_xcb_p_from_ptlo (next_ptlo_to_dispatch, next_task_ijle_p^.ajl_ordinal,
                    next_task_xcb_p);
              cst_p^.next_ptlo_to_dispatch := 0;
              tmp$dct_ready_task (next_task_xcb_p, next_task_ijle_p, next_ptlo_to_dispatch,
                    {attempt_preselection =} TRUE);
            IFEND;
            cst_p^.dispatching_priority_integer := locked_dp_integer;

            tmp$clear_lock (tmv$ptl_lock);
            #KEYPOINT (osk$mtr, osk$monitor_multiplier * ptlo, tmk$switch_task + osk$m);
            RETURN; {<--- }
          IFEND;
        ELSEIF (ptle_p^.idle_status = tmc$is_idle_initiated) THEN
          ptle_p^.idle_status := tmc$is_idled;
          cst_p^.xcb_p := NIL;
          initiate_swap_if_possible (cst_p);
        IFEND;
      END /system_locks_set/;

{ The current task will be removed from the CPU. Decrement this task's executing_task_
{ count.  If a task has not been pre_selected for this CPU, set dispatching_priority_integer
{ equal to the highest priority task in the DCT for the pre-select code in
{ dct_ready_task (which will be called if tasks are readied from the timed wait queue).

      cst_p^.ijle_p^.executing_task_count := cst_p^.ijle_p^.executing_task_count - 1;
      IF (cst_p^.next_ptlo_to_dispatch = 0) THEN
        cst_p^.dispatching_priority_integer := tmv$dct_priority_integer;
      IFEND;
    IFEND; {xcb_p <> NIL}

{ Update the timed wait queue.  This must be done before considering the status of the task
{ that is currently executing (if there is one); tasks being readied from the timed wait queue
{ should be considered for pre-selection (in tmp$dct_ready_task) before the task that is
{ currently executing.

    update_timed_wait_queue;

{ If there is a task executing, check its new status.

    IF xcb_p <> NIL THEN

      IF ptle_p^.new_task_status > tmc$ts_last_status_in_dct THEN
        ptle_p^.status := ptle_p^.new_task_status;
        ptle_p^.new_task_status := tmc$ts_null;
        cst_p^.ijle_p^.statistics.ready_task_count := cst_p^.ijle_p^.statistics.ready_task_count - 1;
        IF ptle_p^.status <= tmc$ts_last_status_in_wait_q THEN
          tmp$insert_timed_wait_queue (ptlo);
        IFEND;
        IF (ptle_p^.status = tmc$ts_timeout_reqexp_longvlong) OR (ptle_p^.status =
              tmc$ts_timed_wait_not_queued) OR (ptle_p^.status = tmc$ts_timeout_reqexp_infvlong) THEN
          cst_p^.ijle_p^.statistics.tasks_not_in_long_wait := cst_p^.ijle_p^.statistics.
                tasks_not_in_long_wait - 1;
          IF (cst_p^.ijle_p^.statistics.tasks_not_in_long_wait = 0) AND
                (cst_p^.ijle_p^.entry_status = jmc$ies_job_in_memory) AND
                (ptle_p^.idle_status = tmc$is_not_idled) THEN
            cst_p^.xcb_p := NIL;
            tmp$set_swapout_candidate (cst_p^.ajlo);
          IFEND;
        IFEND;

      ELSEIF ptle_p^.idle_status <> tmc$is_idled THEN
        ptle_p^.status := tmc$ts_ready;
        attempt_preselection := (cst_p^.next_ptlo_to_dispatch = 0) AND
              ((cst_p^.ijle_p^.multiprocessing_allowed) OR (cst_p^.ijle_p^.statistics.ready_task_count = 1));
        tmp$dct_ready_task (xcb_p, cst_p^.ijle_p, ptlo, attempt_preselection);
      ELSE
        ptle_p^.status := tmc$ts_ready_but_swapped;
        ptle_p^.idle_status := tmc$is_idled_sched_notified;
        jmp$ready_task_in_swapped_job (cst_p^.ijl_ordinal, cst_p^.ijle_p);
      IFEND;
    IFEND;

    IF (cst_p^.cpu_state.next_state = osc$cpu_stepped) THEN
      ptlo := 0;
      tmp$clear_lock (tmv$ptl_lock);
      mtp$error_stop ('terminated through the dispatcher path');
      { Any processor which follows this path is NOT the one driving the system into STEP mode.  THEREFORE,
      { the call above is valid because the driving processor has the correct reason for calling STEP.
      tmp$set_lock (tmv$ptl_lock);
    ELSEIF (cst_p^.processor_state <> cst_p^.next_processor_state) OR ((tmv$dedicate_a_cpu_to_nos AND
        (cst_p^.dual_state_jps <> 0) AND (cst_p^.next_ptlo_to_dispatch = 0))
         AND tmv$multiple_cpus_active) THEN
      cst_p^.dual_state_prior_subpriority.subpriority := 0;
      ptlo := 0;
    ELSEIF (cst_p^.processor_state <> cst_p^.next_processor_state) OR ((mtv$cpu1_dedicated_to_nos AND
        (cst_p^.dual_state_jps <> 0) AND (cst_p^.next_ptlo_to_dispatch = 0))
         AND tmv$multiple_cpus_active) THEN
      cst_p^.dual_state_prior_subpriority.subpriority := 0;
      ptlo := 0;



    ELSE

{ Select next task for execution.
{ If cst_p^.next_ptlo_to_dispatch is non-zero, that task has already been selected to
{ execute on this CPU through the ready task path, so switch to it.
{ NOTE: The variable local_set must be initialized to use later to determine the
{ dual state priority.  Tmv$dual_state_prio_mask contains dispatching priorities for
{ tasks that would have been dispatched, but could not be because the job the task belonged
{ to did not allow multi-processing.  Those priorities should not be considered when
{ determining the dual state priority.
{
{ If the next_ptlo_to_dispatch field is zero, a new task to execute needs to be selected now.
{ Empty the tmv$dual_state_prio_mask set; the select code will determine which priorities
{ can not be dispatched because the tasks queued in the DCT for that priority belong to jobs
{ which do not allow multi-processing.
{ Tmv$dispatching_control_sets contains the following dispatching priority sets:
{ enforce_maximums--priorities which cannot use more than the specified maximum % of the CPU.
{ minimums_to_satisfy--priorities which have not received the specified minimum % of the CPU.
{ (System priorities can use 100% of the CPU, so they are always in minimums_to_satisfy.)
{ ready_tasks--priorities with tasks in the DCT.
{ maximums_exceeded--priorities that have exceeded the specified maximum % of the CPU.
{ For select_next_task, priorities which have exceeded maximum and for which the maximum is
{ enforced are removed from the sets; they cannot execute for the rest of the interval.
{ The remaining priorities with ready tasks are manipulated so that each priority is set
{ only once in any of the three sets (which are ordered, left to right) : minimums_to_satisfy,
{ ready_tasks, maximums_exceeded.  The conversion process pulls off the leftmost bit set in the sets.
{ Thus, priorities with a minimum percentage to satisfy are selected first, followed by priorities
{ with ready tasks that have not exceeded the maximum percentage.  Priorities which have exceeded
{ the maximum but are not prevented from executing by enforce maximum are selected last.
{ When the dispatching priority has been selected, tasks from that DCT queue are considered,
{ until one is found that can execute.
{
{ NOTE:  --PURGE BUFFERS--  If the task or the job the task belongs to did not last execute
{ on this CPU, then cache must be purged.  If multiprocessing is allowed, the last processor
{ for the task is checked.
{ For non-multiprocessing jobs, the last processor for the job is checked.  The task can
{ execute only if the job has no other tasks executing.  If a task has been pre_selected to execute,
{ the executing_task_count was checked and incremented by the pre-selection code.
{ If the task is being selected from the DCT, the task is selected and cache purged if the
{ executing_task_count = 0.

      IF cst_p^.next_ptlo_to_dispatch <> 0 THEN
        ptlo := cst_p^.next_ptlo_to_dispatch;
        ptle_p := ^tmv$ptl_p^ [ptlo];
        cst_p^.next_ptlo_to_dispatch := 0;
        cst_p^.ijl_ordinal := ptle_p^.ijl_ordinal;
        jmp$get_ijle_p (cst_p^.ijl_ordinal, cst_p^.ijle_p);
        cst_p^.ajlo := cst_p^.ijle_p^.ajl_ordinal;
        cst_p^.jcb_p := #ADDRESS (1, cst_p^.ajlo + mtc$job_fixed_segment, 0);
        xcb_p := #ADDRESS (1, mtc$job_fixed_segment + cst_p^.ajlo, ptle_p^.xcb_offset);
        local_set.enforce_maximums := $jmt$dispatching_priority_set [];
        local_set.minimums_to_satisfy := $jmt$dispatching_priority_set [];
        local_set.ready_tasks := (tmv$dispatching_control_sets.ready_tasks - tmv$dual_state_prio_mask) +
              $jmt$dispatching_priority_set [jmc$dp_conversion - ptle_p^.dispatching_priority];
        local_set.maximums_exceeded := $jmt$dispatching_priority_set [];

        IF osv$cpus_logically_on > 1 THEN
          IF cst_p^.ijle_p^.multiprocessing_allowed THEN
            IF xcb_p^.last_lpid_for_task <> cst_p^.cst_index THEN
              { NOTE: The second parameter on the #purge_buffer command is just a dummy pointer.
              #PURGE_BUFFER (osc$purge_all_cache, xcb_p);
              #PURGE_BUFFER (osc$purge_all_page_seg_map, xcb_p);
            IFEND;
          ELSE
            IF cst_p^.jcb_p^.last_lpid_for_job <> cst_p^.cst_index THEN
              #PURGE_BUFFER (osc$purge_all_cache, xcb_p);
              #PURGE_BUFFER (osc$purge_all_page_seg_map, xcb_p);
            IFEND;
          IFEND;
        IFEND;

      ELSE  { Select a new task to execute. }

        tmv$dual_state_prio_mask := $jmt$dispatching_priority_set [];
        local_set := tmv$dispatching_control_sets;
        local_set.ready_tasks := local_set.ready_tasks - (local_set.enforce_maximums *
              local_set.maximums_exceeded);
        local_set.enforce_maximums := $jmt$dispatching_priority_set [];
        local_set.minimums_to_satisfy := local_set.minimums_to_satisfy * local_set.ready_tasks;
        local_set.maximums_exceeded := local_set.maximums_exceeded * local_set.ready_tasks;
        local_set.ready_tasks := local_set.ready_tasks XOR (local_set.minimums_to_satisfy +
              local_set.maximums_exceeded);

        #unchecked_conversion (local_set, integer_dp_sets);

        r := $real(integer_dp_sets);
        priority.r := r;

        ptlo := 0;
      /find_next_task/
        WHILE priority.dp_mask.dp <> 0 DO
          ptlo := tmv$dct [priority.dp_mask.dp].queue_head;

          WHILE ptlo <> 0 DO
            ptle_p := ^tmv$ptl_p^ [ptlo];
            cst_p^.ijl_ordinal := ptle_p^.ijl_ordinal;
            jmp$get_ijle_p (cst_p^.ijl_ordinal, cst_p^.ijle_p);
            cst_p^.ajlo := cst_p^.ijle_p^.ajl_ordinal;
            cst_p^.jcb_p := #ADDRESS (1, cst_p^.ajlo + mtc$job_fixed_segment, 0);
            xcb_p := #ADDRESS (1, mtc$job_fixed_segment + cst_p^.ajlo, ptle_p^.xcb_offset);

            IF osv$cpus_logically_on > 1 THEN
              IF cst_p^.cst_index IN xcb_p^.processor_selections THEN
                IF cst_p^.ijle_p^.multiprocessing_allowed THEN
                  IF xcb_p^.last_lpid_for_task <> cst_p^.cst_index THEN
                  { NOTE: The second parameter on the #purge_buffer command is just a dummy pointer.
                    #PURGE_BUFFER (osc$purge_all_cache, xcb_p);
                    #PURGE_BUFFER (osc$purge_all_page_seg_map, xcb_p);
                  IFEND;
                  EXIT /find_next_task/;
                ELSEIF cst_p^.ijle_p^.executing_task_count = 0 THEN
                  IF cst_p^.jcb_p^.last_lpid_for_job <> cst_p^.cst_index THEN
                    #PURGE_BUFFER (osc$purge_all_cache, xcb_p);
                    #PURGE_BUFFER (osc$purge_all_page_seg_map, xcb_p);
                  IFEND;
                  EXIT /find_next_task/;
                IFEND;
              IFEND;
            ELSE
              EXIT /find_next_task/;
            IFEND;
            ptlo := tmv$ptl_p^ [ptlo].ptl_thread;
          WHILEND;

{ No task of the priority selected could execute.  Remove the priority from the sets and select
{ another priority.  Add the priority to tmv$dual_state_prio_mask so that the priority is not
{ considered when determining the dual state priority on subsequent pre-select task switches.

          tmv$dual_state_prio_mask  := tmv$dual_state_prio_mask + $jmt$dispatching_priority_set
                [jmc$dp_conversion - priority.dp_mask.dp];
          local_set.minimums_to_satisfy := local_set.minimums_to_satisfy - $jmt$dispatching_priority_set
                [jmc$dp_conversion - priority.dp_mask.dp];
          local_set.ready_tasks := local_set.ready_tasks - $jmt$dispatching_priority_set
                [jmc$dp_conversion - priority.dp_mask.dp];
          local_set.maximums_exceeded := local_set.maximums_exceeded - $jmt$dispatching_priority_set
                [jmc$dp_conversion - priority.dp_mask.dp];

          #unchecked_conversion (local_set, integer_dp_sets);

          r := $real(integer_dp_sets);
          priority.r := r;

        WHILEND /find_next_task/;
        IF ptlo <> 0 THEN
          cst_p^.dispatching_priority_integer := integer_dp_sets;
          tmp$remove_task_from_dct (ptlo);
          cst_p^.ijle_p^.executing_task_count := cst_p^.ijle_p^.executing_task_count + 1;
        IFEND;
      IFEND;
    IFEND;

{  Set up the CPU STATE TABLE.

    IF ptlo = 0 THEN
      IF cst_p^.cpu_idle_statistics.idle_type = osc$not_idle THEN
        cst_p^.cpu_idle_statistics.idle_start_time := #FREE_RUNNING_CLOCK (0);
        IF (tmv$swapin_in_progress <> 0) OR (tmv$io_wait_task_count <> 0) THEN
          cst_p^.cpu_idle_statistics.idle_type := osc$idle_with_io_active;
        ELSE
          cst_p^.cpu_idle_statistics.idle_type := osc$idle_no_io_active;
        IFEND;
      IFEND;
      cst_p^.dispatching_priority := 0;
      cst_p^.dispatching_priority_integer := 0;
      cst_p^.dual_state_prior_subpriority.dual_state_priority := 0;
      cst_p^.xcb_p := NIL;
      cst_p^.taskid.index := 0;
      IF (tmv$timed_wait_queue.head = 0) OR (tmv$dedicate_a_cpu_to_nos) OR
        (mtv$cpu1_dedicated_to_nos) THEN
            time := 0ffffffffffff(16);
      ELSE
        time := tmv$ptl_p^ [tmv$timed_wait_queue.head].end_of_wait_time;
      IFEND;
      tmv$time_to_call_dispatcher := time;
      time := time - #free_running_clock (0);
      IF time < 10 THEN
        time := 10;
      ELSEIF time > 50000 THEN
        time := 50000;
      IFEND;
      cst_p^.max_cptime := time;

    ELSE

{ A new task has been selected.  Update the cpu_idle_statistics.

      IF cst_p^.cpu_idle_statistics.idle_type <> osc$not_idle THEN
        idle_time := #FREE_RUNNING_CLOCK (0) - cst_p^.cpu_idle_statistics.idle_start_time;
        IF cst_p^.cpu_idle_statistics.idle_type = osc$idle_with_io_active THEN
          cst_p^.cpu_idle_statistics.idle_io_active := cst_p^.cpu_idle_statistics.idle_io_active +
                idle_time;
        ELSE
          cst_p^.cpu_idle_statistics.idle_no_io_active := cst_p^.cpu_idle_statistics.idle_no_io_active +
                idle_time;
        IFEND;
        update_dispatching_controls (idle_time, jmc$null_dispatching_priority);
        cst_p^.cpu_idle_statistics.idle_type := osc$not_idle;
        cst_p^.cpu_idle_statistics.idle_count := cst_p^.cpu_idle_statistics.idle_count + 1;
      IFEND;

{ Set task status to executing and set up the rest of the CST fields.

      ptle_p^.status := tmc$ts_executing;

      cst_p^.taskid.index := ptlo;
      cst_p^.taskid.seqno := ptle_p^.sequence_number;
      cst_p^.xcb_p := xcb_p;
      cst_p^.max_cptime := xcb_p^.timeslice.minor;
      cst_p^.dispatching_priority := ptle_p^.dispatching_priority;

{ To prevent NOS-NOS/VE problems when VE dispatching allocation is used, the dual state priority has to
{ equal the highest priority ready task on VE (which is the task that would have been selected on VE if
{ dispatching allocation was not being used).  If the dual state priority of a low priority VE task that
{ was selected over a higher priority VE task because of dispatching allocation is used, NOS can shut out
{ VE.  The dispatching allocation interval will never expire, and the higher priority VE task will never
{ get to execute.

      local_set.ready_tasks := local_set.ready_tasks + local_set.minimums_to_satisfy +
            local_set.maximums_exceeded;
      local_set.minimums_to_satisfy := $jmt$dispatching_priority_set [];
      #unchecked_conversion (local_set, integer_dp_sets);
      r := $real (integer_dp_sets);
      priority.r := r;
      cst_p^.dual_state_prior_subpriority := tmv$dual_state_dispatch_prior [priority.dp_mask.dp];

      IF ptle_p^.monitor_flags <> $syt$monitor_flags [] THEN
        xcb_p^.xp.user_condition_register := xcb_p^.xp.user_condition_register +
              $ost$user_conditions [osc$free_flag];
        xcb_p^.monitor_flags := xcb_p^.monitor_flags + ptle_p^.monitor_flags;
        ptle_p^.monitor_flags := $syt$monitor_flags [];
      IFEND;
      IF ptle_p^.system_flags <> $tmt$system_flags [] THEN
        xcb_p^.system_flags := xcb_p^.system_flags + ptle_p^.system_flags;
        ptle_p^.system_flags := $tmt$system_flags [];
      IFEND;

      IF (ptle_p^.ptl_flags.wait_inhibited = tmc$wi_wait_inhibited) THEN
        xcb_p^.wait_inhibited := TRUE;
      IFEND;
      ptle_p^.ptl_flags.wait_inhibited := tmc$wi_null;

{  Set keypoint mask and keypoint enable flag in job exchange package.  Set the value for
{  monitor's keypoint mask.

      #WRITE_REGISTER (osc$pr_set_keypoint_enable, $integer (xcb_p^.keypoint_register_enable));

{  Update the next time to ready a task from the timed wait queue.

      IF (tmv$timed_wait_queue.head = 0) THEN
        tmv$time_to_call_dispatcher := 0ffffffffffff(16);
      ELSE
        tmv$time_to_call_dispatcher := tmv$ptl_p^ [tmv$timed_wait_queue.head].end_of_wait_time;
      IFEND;

    IFEND;
    tmp$clear_lock (tmv$ptl_lock);

    #KEYPOINT (osk$mtr, osk$monitor_multiplier * ptlo, tmk$switch_task + osk$m);

  PROCEND tmp$switch_task;

?? TITLE := 'TMP$SET_UP_DEBUG_REGISTERS', EJECT ??

{ PURPOSE:
{   This procedure is called during the first swapin for job recovery to straighten out the
{   debug list and mask in the exchange package of recovering jobs.

  PROCEDURE [XDCL] tmp$set_up_debug_registers
    (    ptlo: ost$task_index;
         ijle_p: ^jmt$initiated_job_list_entry;
         xcb_p: ^ost$execution_control_block);

    VAR
      null_debug_mask: [STATIC, READ] ost$debug_mask := [FALSE, FALSE, [REP 5 of FALSE]];

    IF (xcb_p^.xp.debug_list_pointer <> NIL) AND (#RING (xcb_p^.xp.debug_list_pointer) = 1) THEN
      xcb_p^.xp.debug_list_pointer := NIL;
      xcb_p^.xp.debug_mask_register := null_debug_mask;

      xcb_p^.xp.debug_index := 0;
      IF osc$debug IN xcb_p^.xp.user_mask THEN
        xcb_p^.xp.user_mask := xcb_p^.xp.user_mask - $ost$user_conditions [osc$debug];
        xcb_p^.monitor_flags := xcb_p^.monitor_flags + $syt$monitor_flags [syc$mf_system_debugger];
        IF tmv$ptl_p^ [ptlo].ptl_flags.wait_inhibited <> tmc$wi_wait_selected_r3 THEN
          xcb_p^.xp.user_condition_register := xcb_p^.xp.user_condition_register +
                $ost$user_conditions [osc$free_flag];
        IFEND;
      IFEND;
    IFEND;
  PROCEND tmp$set_up_debug_registers;

?? TITLE := 'TMP$UPDATE_DEBUG_REGISTERS', EJECT ??

{ PURPOSE:
{   This procedure sets the debugger flag for all tasks.  The next time a task executes, it will trap to
{   reset the debug list and mask in its exchange package.  This procedure is called whenever a breakpoint
{   is selected, set, removed, or modified during a debugger session.

  PROCEDURE tmp$update_debug_registers;

    VAR
      ptlo: ost$task_index;

    FOR ptlo := 1 TO UPPERBOUND (tmv$ptl_p^) DO
      IF tmv$ptl_p^ [ptlo].status <> tmc$ts_null THEN
        tmv$ptl_p^ [ptlo].monitor_flags := tmv$ptl_p^ [ptlo].monitor_flags +
              $syt$monitor_flags [syc$mf_system_debugger];
      IFEND;
    FOREND;

  PROCEND tmp$update_debug_registers;

?? TITLE := 'UPDATE_TIMED_WAIT_QUEUE', EJECT ??

  PROCEDURE [INLINE] update_timed_wait_queue;

{  This procedure is called during task switch to remove tasks from the timed wait
{  queue if the wait time has expired.
{  NOTE: this routine is called with the PTL lock set.

    VAR
      attempt_preselection: boolean,
      free_running_clock: integer,
      ijle_p: ^jmt$initiated_job_list_entry,
      xcb_p: ^ost$execution_control_block,
      ptlo: ost$task_index,
      ptle_p: ^tmt$primary_task_list_entry;

    free_running_clock := #FREE_RUNNING_CLOCK (0);

{UPDATE THE TIMED_WAIT_QUEUE
    WHILE (tmv$ptl_p^ [tmv$timed_wait_queue.head].end_of_wait_time <= free_running_clock) AND
          (tmv$timed_wait_queue.head <> 0) DO
      ptlo := tmv$timed_wait_queue.head;
      ptle_p := ^tmv$ptl_p^ [ptlo];
      tmv$timed_wait_queue.head := ptle_p^.queue_link.head;
      tmv$ptl_p^ [ptle_p^.queue_link.head].queue_link.tail := 0;
      ptle_p^.queue_link.head := 0;
      IF (ptle_p^.status <= tmc$ts_last_status_in_dct) OR (ptle_p^.status > tmc$ts_last_status_in_wait_q) THEN
        mtp$error_stop ('TM36 - task not in wait queue');
      IFEND;
      jmp$get_ijle_p (ptle_p^.ijl_ordinal, ijle_p);
      IF ptle_p^.idle_status = tmc$is_idled THEN
        ptle_p^.idle_status := tmc$is_idled_sched_notified;
        IF ptle_p^.status = tmc$ts_timeout_reqexp_longvlong THEN
          ijle_p^.statistics.tasks_not_in_long_wait := ijle_p^.statistics.tasks_not_in_long_wait + 1;
        IFEND;
        ptle_p^.status := tmc$ts_ready_but_swapped;
        jmp$ready_task_in_swapped_job (ptle_p^.ijl_ordinal, ijle_p);
        ijle_p^.long_wait_aging_complete := FALSE;
      ELSE
        IF ptle_p^.status = tmc$ts_timeout_reqexp_longvlong THEN
          ijle_p^.statistics.tasks_not_in_long_wait := ijle_p^.statistics.tasks_not_in_long_wait + 1;
          jmv$ajl_p^ [ijle_p^.ajl_ordinal].job_is_good_swap_candidate := FALSE;
        IFEND;
        ptle_p^.status := tmc$ts_ready;
        xcb_p := #ADDRESS (1, mtc$job_fixed_segment + ijle_p^.ajl_ordinal, ptle_p^.xcb_offset);
        xcb_p^.timeslice.minor := 0;
        xcb_p^.timeslice.major := 0;
        attempt_preselection := (ijle_p^.multiprocessing_allowed) OR (ijle_p^.executing_task_count = 0);
        tmp$dct_ready_task (xcb_p, ijle_p, ptlo, attempt_preselection);
      IFEND;
      ijle_p^.statistics.ready_task_count := ijle_p^.statistics.ready_task_count + 1;
    WHILEND;

{ Update the queue's tail.

    IF tmv$timed_wait_queue.head = 0 THEN
      tmv$timed_wait_queue.tail := 0;
    IFEND;

  PROCEND update_timed_wait_queue;

?? TITLE := 'TMP$JOB_RECOVERY_REQUESTS', EJECT ??
*copyc syt$rb_job_recovery

  PROCEDURE [XDCL] tmp$job_recovery_requests
    (VAR rb: syt$rb_job_recovery;
         cst_p: ^ost$cpu_state_table);

    VAR
      j,
      i: integer,
      gtid: ost$global_task_id,
      jmtr_ptlo,
      ptlo: ost$task_index,
      ijle_p: ^jmt$initiated_job_list_entry,
      ptl_p: ^tmt$primary_task_list_entry,
      service_class: jmt$service_class_index;

    rb.status.normal := TRUE;
    CASE rb.subreq OF
    = syc$recover_ptl =
      tmp$set_lock (tmv$ptl_lock);

      FOR i := 1 TO rb.count DO
        IF tmv$ptl_p^ [rb.task_list_p^ [i].gtid.index].dispatching_priority <> jmc$null_dispatching_priority
              THEN
          rb.status.normal := FALSE;
          rb.status.condition := tme$ptl_full;
          tmp$clear_lock (tmv$ptl_lock);
          RETURN;
        IFEND;
      FOREND;

      jmtr_ptlo := jmv$ijl_p.block_p^ [rb.ijlo.block_number].index_p^ [rb.ijlo.block_index].
                   job_monitor_taskid.index;
      FOR i := 1 TO rb.count DO
        ptlo := rb.task_list_p^ [i].gtid.index;
        remove_task_from_free_queue (ptlo);
        ptl_p := ^tmv$ptl_p^ [ptlo];
        ptl_p^.ptl_thread := 0;
        ptl_p^.status := tmc$ts_timeout_reqexp_inflong;
        ptl_p^.ijl_ordinal := rb.ijlo;
        ptl_p^.xcb_offset := rb.task_list_p^ [i].xcb_offset;
        ptl_p^.dispatching_priority := rb.task_list_p^ [i].dispatching_priority;
        ptl_p^.monitor_flags := $syt$monitor_flags [];
        ptl_p^.system_flags := $tmt$system_flags [];
        ptl_p^.sequence_number := rb.task_list_p^ [i].gtid.seqno;
        ptl_p^.idle_status := tmc$is_idled;
        ptl_p^.queue_link.head := 0;
        ptl_p^.queue_link.tail := 0;
        ptl_p^.end_of_wait_time := 0;

{ Emulate insert_ijl here - note special case for first task (jmtr).

        IF ptlo <> jmtr_ptlo THEN
          tmv$ptl_p^ [ptlo].ijl_thread := tmv$ptl_p^ [jmtr_ptlo].ijl_thread;
          tmv$ptl_p^ [jmtr_ptlo].ijl_thread := ptlo;
        IFEND;
        gtid.index := ptlo;
        gtid.seqno := ptl_p^.sequence_number;
        tmp$set_task_ready (gtid, 0 {readying_task_priority}, tmc$rc_ready_conditional_wi);
      FOREND;
      tmp$clear_lock (tmv$ptl_lock);

{ Get an ijl pointer - we need to reset some ijl fields and straighten out some counts.

      jmp$get_ijle_p (rb.ijlo, ijle_p);

{ Set the swap status of the job to swapout complete; clear the swap queue link fields and
{ relink the job into the swapped_out swap queue.

      ijle_p^.swap_status := jmc$iss_swapout_complete;
      ijle_p^.swap_queue_link.queue_id := jsc$isqi_null;
      ijle_p^.swap_queue_link.backward_link := jmv$null_ijl_ordinal;
      ijle_p^.swap_queue_link.forward_link := jmv$null_ijl_ordinal;
      jsp$relink_swap_queue (rb.ijlo, ijle_p, jsc$isqi_swapped_out);

{ Increment the total task count by the number of tasks in the recovered job.

      tmv$total_task_count := tmv$total_task_count + rb.count;

{ Increment the scheduler initiated job count so that scheduler knows how many jobs of this class
{ there are; this count is normally incremented in jmp$initiate_job_from_scheduler, but for job
{ recovery we'll do it here.

      service_class := ijle_p^.job_scheduler_data.service_class;
      jmv$job_counts.service_class_counts [service_class].scheduler_initiated_jobs := jmv$job_counts.
            service_class_counts [service_class].scheduler_initiated_jobs + 1;

{ Increment swapped job count so that scheduler knows how many swapped jobs there are.

      jmp$increment_swapped_job_count (ijle_p);

    ELSE

{ unsupported subrequest

    CASEND;
  PROCEND tmp$job_recovery_requests;

?? TITLE := '[XDCL] tmp$free_unrecovered_tasks', EJECT ??

{ PURPOSE:
{   This procedure frees the PTL entries for the tasks of a job that is being terminated
{   because it cannot be recoverd.  The total task count is decremented; it was incremented
{   earlier during job recovery when the PTL entries were made.
{   The caller of this procedure MUST set the PTL lock.

  PROCEDURE [XDCL] tmp$free_unrecovered_tasks
    (    ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      next_index: ost$task_index,
      task_index: ost$task_index;

    task_index := ijle_p^.job_monitor_taskid.index;
    WHILE task_index <> 0 DO
      next_index := tmv$ptl_p^ [task_index].ijl_thread;
      IF tmv$ptl_p^ [task_index].ptl_thread <> 0 THEN
        mtp$error_stop ('Unrecovered task--PTL thread not zero');
      IFEND;

{ The procedure free_ptl does not clear the ijl thread. Not clearing the field
{ causes a potential problem for the next task using the ptl entry.

      tmv$ptl_p^ [task_index].ijl_thread := 0;
      free_ptl (task_index);
      tmv$total_task_count := tmv$total_task_count - 1;
      task_index := next_index;
    WHILEND;

  PROCEND tmp$free_unrecovered_tasks;

?? TITLE := 'TMP$SWITCH_TASK_FROM_FAILING_CP', EJECT ??

  PROCEDURE [XDCL] tmp$switch_task_from_failing_cp
    (VAR cst_p: ^ost$cpu_state_table);

    VAR
      next_task_ijle_p: ^jmt$initiated_job_list_entry,
      next_task_xcb_p: ^ost$execution_control_block,
      ptle_p: ^tmt$primary_task_list_entry,
      ptlo: ost$task_index,
      xcb_p: ^ost$execution_control_block;

    xcb_p := cst_p^.xcb_p;

    tmp$set_lock (tmv$ptl_lock);

    IF xcb_p <> NIL THEN
      xcb_p^.timeslice := jmv$service_classes [cst_p^.ijle_p^.job_scheduler_data.service_class]^.attributes.
            dispatching_control [cst_p^.ijle_p^.dispatching_control.dispatching_control_index].
            dispatching_timeslice;
      xcb_p^.last_lpid_for_task := cst_p^.cst_index;
      cst_p^.jcb_p^.last_lpid_for_job := cst_p^.cst_index;
      cst_p^.jcb_p^.last_execution_time := #FREE_RUNNING_CLOCK (0);
      ptlo := cst_p^.taskid.index;
      ptle_p := ^tmv$ptl_p^ [ptlo];
      cst_p^.ijle_p^.executing_task_count := cst_p^.ijle_p^.executing_task_count - 1;
      IF ptle_p^.new_task_status > tmc$ts_last_status_in_dct THEN
        ptle_p^.status := ptle_p^.new_task_status;
        ptle_p^.new_task_status := tmc$ts_null;
        cst_p^.ijle_p^.statistics.ready_task_count := cst_p^.ijle_p^.statistics.ready_task_count - 1;
        IF ptle_p^.status <= tmc$ts_last_status_in_wait_q THEN
          tmp$insert_timed_wait_queue (ptlo);
        IFEND;
        IF (ptle_p^.status = tmc$ts_timeout_reqexp_longvlong) OR (ptle_p^.status =
              tmc$ts_timed_wait_not_queued) OR (ptle_p^.status = tmc$ts_timeout_reqexp_infvlong) THEN
          cst_p^.ijle_p^.statistics.tasks_not_in_long_wait := cst_p^.ijle_p^.statistics.
                tasks_not_in_long_wait - 1;
          IF (cst_p^.ijle_p^.statistics.tasks_not_in_long_wait = 0) AND
                (cst_p^.ijle_p^.entry_status = jmc$ies_job_in_memory) AND
                (ptle_p^.idle_status = tmc$is_not_idled) THEN
            cst_p^.xcb_p := NIL;
            tmp$set_swapout_candidate (cst_p^.ajlo);
          IFEND;
        IFEND;
      ELSE
        ptle_p^.status := tmc$ts_ready;
        tmp$dct_ready_task (xcb_p, cst_p^.ijle_p, ptlo, TRUE);
      IFEND;
      cst_p^.dispatching_priority := 0;
      cst_p^.dispatching_priority_integer := 0;
      cst_p^.dual_state_prior_subpriority.dual_state_priority := 0;
      cst_p^.xcb_p := NIL;
      cst_p^.taskid.index := 0;
    IFEND;

{ If a task has been pre-selected to run on this CPU, that task needs to be inserted in the DCT.

    IF cst_p^.next_ptlo_to_dispatch <> 0 THEN
      jmp$get_ijle_p (tmv$ptl_p^ [cst_p^.next_ptlo_to_dispatch].ijl_ordinal, next_task_ijle_p);
      next_task_ijle_p^.executing_task_count := next_task_ijle_p^.executing_task_count - 1;
      tmv$ptl_p^ [cst_p^.next_ptlo_to_dispatch].status := tmc$ts_ready;
      tmp$get_xcb_p_from_ptlo (cst_p^.next_ptlo_to_dispatch, next_task_ijle_p^.ajl_ordinal,
            next_task_xcb_p);
      tmp$dct_ready_task (next_task_xcb_p, next_task_ijle_p, cst_p^.next_ptlo_to_dispatch, TRUE);
      cst_p^.next_ptlo_to_dispatch := 0;
    IFEND;

    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$switch_task_from_failing_cp;
?? OLDTITLE ??
MODEND tmm$dispatcher;
*DECK DECK=TMM$DISPATCHER_TEST_HARNESS EXPAND=TRUE

?? RIGHT := 110 ??
MODULE tmm$dispatcher_test_harness;

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc ame$access_validation_errors
*copyc cle$ecc_ct_generator
*copyc cle$ecc_lexical
*copyc cle$ecc_miscellaneous
*copyc cle$ecc_proc_declaration
*copyc clt$command_table
*copyc clt$function_table
*copyc clt$parameter_list_size
*copyc jmt$cda_record
*copyc jmt$dispatching_priority
*copyc jmt$dispatching_priority_set
*copyc jmt$ijle_size
*copyc jmt$initiated_job_list_entry
*copyc oss$job_paged_literal
*copyc ost$cpu_state_table
*copyc ost$execution_control_block
*copyc ost$free_running_clock
*copyc ost$status
*copyc syt$monitor_status
*copyc tmt$primary_task_list
*copyc tmt$dispatch_control_table
*copyc tmt$dispatching_controls
*copyc tmt$dispatching_control_sets
*copyc tmt$dispatching_prio_controls

*copyc jmv$ijl_p
*copyc osv$upper_to_lower
*copyc tmv$dct
*copyc tmv$dispatching_controls
*copyc tmv$dispatching_control_time
*copyc tmv$dispatching_control_sets
*copyc tmv$null_global_task_id
*copyc tmv$ptl_p
*copyc tmv$tables_initialized
?? POP ??
*copyc amp$fetch
*copyc amp$put_next
*copyc amp$return
*copyc clp$begin_utility
*copyc clp$convert_integer_to_string
*copyc clp$convert_string_to_name
*copyc clp$put_job_command_response
*copyc clp$end_include
*copyc clp$end_utility
*copyc clp$get_command_origin
*copyc jmp$get_ijle_p
*copyc clp$get_parameter_list_text
*copyc clp$get_set_count
*copyc clp$get_value
*copyc clp$include_file
*copyc clp$scan_parameter_list
*copyc clp$test_parameter
*copyc clp$trimmed_string_size
*copyc fsp$close_file
*copyc fsp$open_file
*copyc mmp$create_scratch_segment
*copyc osp$append_status_parameter
*copyc osp$generate_error_message
*copyc osp$set_status_abnormal
*copyc pmp$zero_out_table
*copyc tmp$assign_ptl
*copyc tmp$remove_task_from_dct
*copyc tmp$set_task_ready

?? EJECT ??

  TYPE
    entry = record
      name: ost$name,
      class: clt$named_entry_class,
      availability: ost$name,
      ordinal: integer,
      log_option: clt$command_log_option,
      call_method: clt$call_method,
      procedure_name: ost$name,
    recend;

  TYPE
    entry_sequence = SEQ ( * );

  TYPE
    xref_sequence = SEQ ( * );

  TYPE
    chunk_array = array [1 .. clc$max_command_chunk] of record
      position: integer,
      length: integer,
    recend;

  TYPE
    type_record = record
      size: 0 .. max_line_size,
      line: string (max_line_size),
    recend;

  CONST
    max_line_size = 79,
    number_of_common_lines = 69,
    number_of_command_lines = 40,
    number_of_function_lines = 185;

  CONST
    prompt_string = 'dth',
    prompt_string_size = 3;

  CONST
    clc$max_command_chunk = clc$max_parameter_list_size DIV 31,
    min_page_width = 79,
    max_page_width = 110;

  VAR
    entry_count: [STATIC] integer := 0,
    entry_pointer: ^entry,
    entry_sequence_pointer: ^entry_sequence,
    module_name: ost$name,
    module_name_size: integer,
    name_size: integer,
    new_table_started: [STATIC] boolean := FALSE,
    ordinal_count: [STATIC] integer := 0,
    output_file: amt$local_file_name,
    output_file_id: amt$file_identifier,
    page_width: 0 .. amc$max_page_width,
    scope: ost$name,
    section_name: [STATIC] ost$name := '',
    status: ost$status,
    table_name: [STATIC] ost$name := '',
    table_type: ost$name,
    type_size: integer,
    utility_name: [STATIC, READ, oss$job_paged_literal] ost$name := 'dispatcher_test_harness',
    value: clt$value,
    xref_count: [STATIC] integer := 0,
    xref_pointer: ^ost$name,
    xref_sequence_pointer: ^xref_sequence;

{   ************************* CAUTION !!! *************************    }
{                                                                      }
{    When modifying the following 'hard-coded' types, use a different  }
{  MODIFICATION and FEATURE than ones used to modify the logic of      }
{  this program or any other deck.  This division is neccessary to     }
{  ensure ease of building various versions of command tables and      }
{  GENCT.                                                              }
{                                                                      }
{   ***************************************************************    }

  VAR
    common_types: [STATIC, READ] array [1 .. number_of_common_lines] of type_record := [
{}
{  *copyc clt$named_entry_availability
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [77, '    clt$named_entry_availability = (clc$normal_usage_entry, clc$hidden_entry,'],
{} [36, '          clc$advanced_usage_entry);'],
{} [0, ''],
{} [7, '  CONST'],
{} [50, '    clc$advertised_entry = clc$normal_usage_entry;'],
{}
{  *copyc clt$named_entry_class
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [64, '    clt$named_entry_class = (clc$nominal_entry, clc$alias_entry,'],
{} [30, '      clc$abbreviation_entry);'],
{}
{  *copyc clt$named_entry_ordinal
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [48, '    clt$named_entry_ordinal = 1 .. 7fffffff(16);'],
{}
{  *copyc pmt$program_name
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [32, '    pmt$program_name = ost$name;'],
{}
{  *copyc ost$status
{}
{} [0, ''],
{} [7, '  CONST'],
{} [54, '    osc$max_condition = osc$max_status_condition_code,'],
{} [64, '    osc$status_parameter_delimiter = CHR (31) {Unit Separator} ;'],
{} [0, ''],
{} [6, '  TYPE'],
{} [67, '    ost$status_condition_code = 0 .. osc$max_status_condition_code,'],
{} [71, '    ost$status_condition_number = 0 .. osc$max_status_condition_number;'],
{} [0, ''],
{} [7, '  CONST'],
{} [52, '    osc$max_status_condition_code = 0ffffffffff(16),'],
{} [50, '    osc$max_status_condition_number = 0ffffff(16);'],
{} [0, ''],
{} [6, '  TYPE'],
{} [23, '    ost$status = record'],
{} [29, '      case normal: boolean of'],
{} [15, '      = FALSE ='],
{} [45, '        condition: ost$status_condition_code,'],
{} [25, '        text: ost$string,'],
{} [14, '      = TRUE ='],
{} [9, '        ,'],
{} [13, '      casend,'],
{} [11, '    recend;'],
{}
{  *copyc ost$string
{}
{} [0, ''],
{} [7, '  CONST'],
{} [27, '    osc$max_name_size = 31,'],
{} [54, '    osc$null_name = ''                               '';'],
{} [0, ''],
{} [6, '  TYPE'],
{} [43, '    ost$name_size = 1 .. osc$max_name_size;'],
{} [0, ''],
{} [6, '  TYPE'],
{} [42, '    ost$name = string (osc$max_name_size);'],
{}
{  *copyc ost$string
{}
{} [0, ''],
{} [7, '  CONST'],
{} [30, '    osc$max_string_size = 256;'],
{} [0, ''],
{} [6, '  TYPE'],
{} [47, '    ost$string_size = 0 .. osc$max_string_size;'],
{} [0, ''],
{} [6, '  TYPE'],
{} [52, '    ost$string_index = 1 .. osc$max_string_size + 1;'],
{} [0, ''],
{} [6, '  TYPE'],
{} [23, '    ost$string = record'],
{} [28, '      size: ost$string_size,'],
{} [42, '      value: string (osc$max_string_size),'],
{} [11, '    recend;'],
{}
{  *copyc clt$call_method
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [61, '    clt$call_method = (clc$unspecified_call, clc$linked_call,'],
{} [58, '      clc$unlinked_call, clc$proc_call, clc$program_call);']];

  VAR
    command_types: [STATIC, READ] array [1 .. number_of_command_lines] of type_record := [
{}
{  *copyc clt$command_table
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [67, '    clt$command_table = array [1 .. * ] of clt$command_table_entry;'],
{}
{  *copyc clt$command_table_entry
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [36, '    clt$command_table_entry = record'],
{} [29, '      name: clt$command_name,'],
{} [35, '      class: clt$named_entry_class,'],
{} [49, '      availability: clt$named_entry_availability,'],
{} [39, '      ordinal: clt$named_entry_ordinal,'],
{} [41, '      log_option: clt$command_log_option,'],
{} [50, '      case call_method: clt$command_call_method of'],
{} [25, '      = clc$linked_call ='],
{} [29, '        command: clt$command,'],
{} [60, '      = clc$unlinked_call, clc$proc_call, clc$program_call ='],
{} [41, '        procedure_name: pmt$program_name,'],
{} [13, '      casend,'],
{} [11, '    recend;'],
{}
{  *copyc clt$command
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [65, '    clt$command = ^procedure (parameter_list: clt$parameter_list;'],
{} [30, '      VAR status: ost$status);'],
{}
{  *copyc clt$command_call_method
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [66, '    clt$command_call_method = clc$linked_call .. clc$program_call;'],
{}
{  *copyc clt$command_log_option
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [71, '    clt$command_log_option = (clc$automatically_log, clc$manually_log);'],
{}
{  *copyc clt$command_name
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [32, '    clt$command_name = ost$name;'],
{}
{  *copyc cld$parameter_list
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [48, '    clt$parameter_list = pmt$program_parameters;'],
{} [0, ''],
{} [6, '  TYPE'],
{} [45, '    clt$parameter_list_contents = ost$string;'],
{}
{  *copyc pmt$program_parameters
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [39, '    pmt$program_parameters = SEQ ( * );']];

  VAR
    function_types: [STATIC, READ] array [1 .. number_of_function_lines] of type_record := [
{}
{  *copyc clt$function_table
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [69, '    clt$function_table = array [1 .. * ] of clt$function_table_entry;'],
{}
{  *copyc clt$function_table_entry
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [37, '    clt$function_table_entry = record'],
{} [30, '      name: clt$function_name,'],
{} [35, '      class: clt$named_entry_class,'],
{} [49, '      availability: clt$named_entry_availability,'],
{} [39, '      ordinal: clt$named_entry_ordinal,'],
{} [51, '      case call_method: clt$function_call_method of'],
{} [25, '      = clc$linked_call ='],
{} [27, '        func: clt$function,'],
{} [42, '      = clc$unlinked_call, clc$proc_call ='],
{} [41, '        procedure_name: pmt$program_name,'],
{} [13, '      casend,'],
{} [11, '    recend;'],
{}
{  *copyc clt$function
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [55, '    clt$function = ^procedure (function_name: clt$name;'],
{} [34, '      argument_list: string ( * );'],
{} [27, '      VAR value: clt$value;'],
{} [30, '      VAR status: ost$status);'],
{}
{  *copyc clt$function_call_method
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [64, '    clt$function_call_method = clc$linked_call .. clc$proc_call;'],
{}
{  *copyc clt$function_name
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [33, '    clt$function_name = ost$name;'],
{}
{  *copyc cld$value
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [22, '    clt$value = record'],
{} [45, '      descriptor: string (osc$max_name_size),'],
{} [57, '      case kind: clc$unknown_value .. clc$status_value of'],
{} [27, '      = clc$unknown_value ='],
{} [9, '        ,'],
{} [31, '      = clc$application_value ='],
{} [43, '        application: clt$application_value,'],
{} [32, '      = clc$variable_reference ='],
{} [40, '        var_ref: clt$variable_reference,'],
{} [26, '      = clc$string_value ='],
{} [24, '        str: ost$string,'],
{} [24, '      = clc$file_value ='],
{} [23, '        file: clt$file,'],
{} [24, '      = clc$name_value ='],
{} [23, '        name: clt$name,'],
{} [24, '      = clc$real_value ='],
{} [23, '        rnum: clt$real,'],
{} [27, '      = clc$integer_value ='],
{} [25, '        int: clt$integer,'],
{} [27, '      = clc$boolean_value ='],
{} [26, '        bool: clt$boolean,'],
{} [26, '      = clc$status_value ='],
{} [27, '        status: ost$status,'],
{} [13, '      casend,'],
{} [11, '    recend;'],
{}
{  *copyc CLT$APPLICATION_VALUE
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [45, '    clt$application_value = SEQ (ost$string);'],
{} [0, ''],
{} [6, '  TYPE'],
{} [42, '    clt$application_value_name = ost$name;'],
{}
{  *copyc clt$boolean
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [24, '    clt$boolean = record'],
{} [21, '      value: boolean,'],
{} [30, '      kind: clt$boolean_kinds,'],
{} [11, '    recend;'],
{} [0, ''],
{} [6, '  TYPE'],
{} [68, '    clt$boolean_kinds = (clc$true_false_boolean, clc$yes_no_boolean,'],
{} [26, '      clc$on_off_boolean);'],
{}
{  *copyc clt$data_value_kind
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [72, '    clt$data_value_kind = (clc$unspecified_value, clc$application_value,'],
{} [75, '      clc$deferred_value, clc$file_value, clc$name_value, clc$string_value,'],
{} [77, '      clc$real_value, clc$integer_value, clc$boolean_value, clc$status_value,'],
{} [65, '      clc$array_value, clc$cobol_name_value, clc$date_time_value,'],
{} [73, '      clc$entry_point_reference_value, clc$keyword_value, clc$list_value,'],
{} [63, '      clc$lock_value, clc$network_title_value, clc$range_value,'],
{} [55, '      clc$record_value, clc$scu_line_identifier_value,'],
{} [57, '      clc$string_pattern_value, clc$time_increment_value,'],
{} [36, '      clc$type_specification_value);'],
{}
{  *copyc clt$file
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [21, '    clt$file = record'],
{} [43, '      local_file_name: amt$local_file_name,'],
{} [11, '    recend;'],
{}
{  *copyc clt$integer
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [24, '    clt$integer = record'],
{} [21, '      value: integer,'],
{} [21, '      radix: 2 .. 16,'],
{} [31, '      radix_specified: boolean,'],
{} [11, '    recend;'],
{}
{  *copyc clt$name
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [21, '    clt$name = record'],
{} [26, '      size: ost$name_size,'],
{} [22, '      value: ost$name,'],
{} [11, '    recend;'],
{}
{  *copyc clt$real
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [21, '    clt$real = record'],
{} [22, '      value: longreal,'],
{} [52, '      number_of_digits: clt$real_number_digit_count,'],
{} [11, '    recend;'],
{}
{  *copyc cltreal_number_digit_count
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [67, '     clt$real_number_digit_count = 1 .. clc$max_real_number_digits;'],
{}
{  *copyc clc$max_real_number_digits
{}
{} [0, ''],
{} [7, '  CONST'],
{} [36, '    clc$max_real_number_digits = 28;'],
{}
{  *copyc cld$variable_reference
{}
{} [0, ''],
{} [7, '  TYPE'],
{} [35, '    clt$variable_reference = record'],
{} [28, '      reference: ost$string,'],
{} [42, '      lower_bound: clt$variable_dimension,'],
{} [42, '      upper_bound: clt$variable_dimension,'],
{} [32, '      value: clt$variable_value,'],
{} [11, '    recend;'],
{} [0, ''],
{} [7, '  TYPE'],
{} [31, '    clt$variable_value = record'],
{} [45, '      descriptor: string (osc$max_name_size),'],
{} [38, '      case kind: clt$variable_kinds of'],
{} [26, '      = clc$string_value ='],
{} [41, '        max_string_size: ost$string_size,'],
{} [47, '        string_value: ^array [1 .. * ] of cell,'],
{} [24, '      = clc$real_value ='],
{} [49, '        real_value: ^array [1 .. * ] of clt$real,'],
{} [27, '      = clc$integer_value ='],
{} [55, '        integer_value: ^array [1 .. * ] of clt$integer,'],
{} [27, '      = clc$boolean_value ='],
{} [55, '        boolean_value: ^array [1 .. * ] of clt$boolean,'],
{} [26, '      = clc$status_value ='],
{} [53, '        status_value: ^array [1 .. * ] of clt$status,'],
{} [13, '      casend,'],
{} [11, '    recend;'],
{} [0, ''],
{} [6, '  TYPE'],
{} [23, '    clt$status = record'],
{} [26, '      normal: clt$boolean,'],
{} [40, '      identifier: clt$status_identifier,'],
{} [29, '      condition: clt$integer,'],
{} [23, '      text: ost$string,'],
{} [11, '    recend,'],
{} [34, '    clt$status_identifier = record'],
{} [28, '      size: ost$string_size,'],
{} [24, '      value: string (2),'],
{} [11, '    recend;'],
{} [0, ''],
{} [6, '  TYPE'],
{} [58, '    clt$variable_dimension = clc$min_variable_dimension ..'],
{} [33, '      clc$max_variable_dimension;'],
{} [0, ''],
{} [7, '  CONST'],
{} [48, '    clc$min_variable_dimension = - 7fffffff(16),'],
{} [46, '    clc$max_variable_dimension = 7fffffff(16);'],
{} [0, ''],
{} [6, '  TYPE'],
{} [31, '    clt$variable_scope = record'],
{} [43, '      case kind: clt$variable_scope_kind of'],
{} [49, '      = clc$local_variable .. clc$xref_variable ='],
{} [9, '        ,'],
{} [30, '      = clc$utility_variable ='],
{} [31, '        utility_name: ost$name,'],
{} [13, '      casend,'],
{} [11, '    recend,'],
{} [68, '    clt$variable_scope_kind = (clc$local_variable, clc$job_variable,'],
{} [66, '      clc$xdcl_variable, clc$xref_variable, clc$utility_variable);'],
{}
{  *copyc clt$value_kinds
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [42, '    clt$value_kinds = clt$data_value_kind;'],
{} [0, ''],
{} [7, '  CONST'],
{} [48, '    clc$variable_reference = clc$deferred_value,'],
{} [36, '    clc$any_value = clc$array_value,'],
{} [46, '    clc$unknown_value = clc$unspecified_value;'],
{}
{  *copyc clt$variable_kinds
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [62, '    clt$variable_kinds = clc$string_value .. clc$status_value;'],
{}
{  *copyc amt$local_file_name
{}
{} [0, ''],
{} [6, '  TYPE'],
{} [35, '    amt$local_file_name = ost$name;']];

?? EJECT ??

  PROCEDURE [XREF] tmp$switch_task
    (     dummy: ^cell;
          cst_p: ^ost$cpu_state_table);

   VAR
      jmv$ijle_size: [XDCL] jmt$ijle_size := 264,
      osv$cpus_logically_on: [XDCL] 0 .. osc$max_number_of_processors,
      mtv$cst0: [XDCL] ost$state_tables,
      xcb: array [0 ..49] OF ost$execution_control_block;

?? TITLE := 'create_command', EJECT ??

  PROCEDURE create_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{         PDT  create_pdt (
{           task_number, tn: INTEGER 0 .. 49 = $REQUIRED
{           priority, p: INTEGER  0 .. 15 = $REQUIRED
{           relative_priority, pr: INTEGER  0 .. 255 = 0
{           major_timeslice, mjt: INTEGER  0 .. 50 = 50
{           minor_timeslice, mnt: INTEGER  0 .. 50 = 50
{           STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    create_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^create_pdt_names,
      ^create_pdt_params];

  VAR
    create_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 11] of
      clt$parameter_name_descriptor := [['TASK_NUMBER', 1], ['TN', 1], ['PRIORITY', 2], ['P', 2], [
      'RELATIVE_PRIORITY', 3], ['PR', 3], ['MAJOR_TIMESLICE', 4], ['MJT', 4], ['MINOR_TIMESLICE', 5], ['MNT',
      5], ['STATUS', 6]];

  VAR
    create_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 6] of clt$parameter_descriptor := [

{ TASK_NUMBER TN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 49]],

{ PRIORITY P }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 15]],

{ RELATIVE_PRIORITY PR }
    [[clc$optional_with_default, ^create_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 255]],

{ MAJOR_TIMESLICE MJT }
    [[clc$optional_with_default, ^create_pdt_dv4], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 50]],

{ MINOR_TIMESLICE MNT }
    [[clc$optional_with_default, ^create_pdt_dv5], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 50]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    create_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    create_pdt_dv4: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := '50';

  VAR
    create_pdt_dv5: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := '50';

?? POP ??
    VAR
      ijl_ord: 1 .. 5,
      ijl_ordinal: jmt$ijl_ordinal,
      ijl_p: ^jmt$initiated_job_list_entry,
      major_timeslice: 0 .. 50,
      minor_timeslice: 0 .. 50,
      mtr_status: syt$monitor_status,
      priority: 0 .. 15,
      ptlo: ost$task_index,
      relative_priority: 0 .. 255,
      taskid: ost$global_task_id,
      task_number: 0 ..49;

    clp$scan_parameter_list (parameter_list, create_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('TASK_NUMBER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    task_number := value.int.value;

    clp$get_value ('PRIORITY', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    priority := value.int.value;

    clp$get_value ('RELATIVE_PRIORITY', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    relative_priority := value.int.value;

    clp$get_value ('MAJOR_TIMESLICE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    major_timeslice := value.int.value;

    clp$get_value ('MINOR_TIMESLICE', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    minor_timeslice := value.int.value;

    xcb [task_number].dispatching_priority := priority;
    xcb [task_number].relative_task_priority := relative_priority;
    xcb [task_number].timeslice.major := major_timeslice;
    xcb [task_number].timeslice.minor := minor_timeslice;
    xcb [task_number].processor_selections := - $ost$processor_id_set [ ];
    xcb [task_number].requested_processor_selections := $ost$processor_id_set [ ];

    IF task_number < 10 THEN
      ijl_ord := 1;
    ELSEIF (task_number < 20) AND (task_number >= 10) THEN
      ijl_ord := 2;
    ELSEIF (task_number < 30) AND (task_number >= 20) THEN
      ijl_ord := 3;
    ELSEIF (task_number < 40) AND (task_number >= 30) THEN
      ijl_ord := 4;
    ELSE
      ijl_ord := 5;
    IFEND;

    ijl_ordinal.block_index := ijl_ord;
    ijl_ordinal.block_number := 0;
    jmp$get_ijle_p (ijl_ordinal, ijl_p);
    ijl_p^.ajl_ordinal := #SEGMENT (^xcb [task_number]) - 14(16);

    IF relative_priority = 0 THEN
      ijl_p^.relative_priority_enabled := FALSE;
    ELSE
      ijl_p^.relative_priority_enabled := TRUE;
    IFEND;

    ijl_p^.dispatching_control.dispatching_control_index := 1;
    ijl_p^.dispatching_control.service_remaining := UPPERVALUE (OST$FREE_RUNNING_CLOCK);

    tmp$assign_ptl (^xcb [task_number], ijl_ordinal, taskid, mtr_status);
    xcb [task_number].global_task_id := taskid;
    tmv$ptl_p^ [taskid.index].xcb_offset := #OFFSET (^xcb [task_number]);

  PROCEND create_command;

?? TITLE := 'delete_command', EJECT ??

  PROCEDURE delete_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{         PDT  delete_pdt (
{           task_number, tn: INTEGER 0 .. 49 = $REQUIRED
{           STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    delete_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^delete_pdt_names,
      ^delete_pdt_params];

  VAR
    delete_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['TASK_NUMBER', 1], ['TN', 1], ['STATUS', 2]];

  VAR
    delete_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ TASK_NUMBER TN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 49]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
    VAR
      ptlo: ost$task_index,
      taskid: ost$global_task_id,
      task_number: 0 ..49;

    clp$scan_parameter_list (parameter_list, delete_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('TASK_NUMBER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    task_number := value.int.value;

    ptlo := xcb [task_number].global_task_id.index;

    tmp$remove_task_from_dct (ptlo);

  PROCEND delete_command;

?? TITLE := 'ready_command', EJECT ??

  PROCEDURE ready_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{             PDT  ready_pdt (
{               task_number, tn: INTEGER 0 .. 49 = $REQUIRED
{               STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    ready_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^ready_pdt_names, ^ready_pdt_params
      ];

  VAR
    ready_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['TASK_NUMBER', 1], ['TN', 1], ['STATUS', 2]];

  VAR
    ready_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ TASK_NUMBER TN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 49]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
    VAR
      ijl_p: ^jmt$initiated_job_list_entry,
      ijl_ordinal: 1 .. 5,
      ptlo: ost$task_index,
      s: string (100),
      sl: integer,
      t: integer,
      taskid: ost$global_task_id,
      task_number: 0 ..49;

    clp$scan_parameter_list (parameter_list, ready_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('TASK_NUMBER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    task_number := value.int.value;

    IF task_number < 10 THEN
      ijl_ordinal := 1;
    ELSEIF (task_number < 20) AND (task_number >= 10) THEN
      ijl_ordinal := 2;
    ELSEIF (task_number < 30) AND (task_number >= 20) THEN
      ijl_ordinal := 3;
    ELSEIF (task_number < 40) AND (task_number >= 30) THEN
      ijl_ordinal := 4;
    ELSE
      ijl_ordinal := 5;
    IFEND;

    ptlo := xcb [task_number].global_task_id.index;
    tmv$ptl_p^ [ptlo].status := tmc$ts_timeout_reqexp_inflong;
    mtv$cst0 [0].xcb_p := ^xcb [task_number];
    t := #read_register (0c9(16));
    tmp$set_task_ready (xcb [task_number].global_task_id, tmc$rc_ready_conditional_wi);
    t := t - #read_register (0c9(16));
    STRINGREP (s, sl, ' time = ', t:8);
    clp$put_job_command_response (s (1, sl), status);
  PROCEND ready_command;

?? TITLE := 'switch_command', EJECT ??

  PROCEDURE switch_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{           PDT  switch_pdt (
{             task_number, tn: INTEGER 0 .. 49 = 0
{             table_lock_count, tablc: INTEGER 0 .. 256 = 0
{             time_used, timu: INTEGER 0 .. 50 = 50
{             STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    switch_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^switch_pdt_names,
      ^switch_pdt_params];

  VAR
    switch_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 7] of
      clt$parameter_name_descriptor := [['TASK_NUMBER', 1], ['TN', 1], ['TABLE_LOCK_COUNT', 2], ['TABLC', 2],
      ['TIME_USED', 3], ['TIMU', 3], ['STATUS', 4]];

  VAR
    switch_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 4] of clt$parameter_descriptor := [

{ TASK_NUMBER TN }
    [[clc$optional_with_default, ^switch_pdt_dv1], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 49]],

{ TABLE_LOCK_COUNT TABLC }
    [[clc$optional_with_default, ^switch_pdt_dv2], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 256]],

{ TIME_USED TIMU }
    [[clc$optional_with_default, ^switch_pdt_dv3], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
      clc$integer_value, 0, 50]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

  VAR
    switch_pdt_dv1: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    switch_pdt_dv2: [STATIC, READ, cls$pdt_names_and_defaults] string (1) := '0';

  VAR
    switch_pdt_dv3: [STATIC, READ, cls$pdt_names_and_defaults] string (2) := '50';

?? POP ??
    VAR
      ijl_ordinal: jmt$ijl_ordinal,
      ijl_p: ^jmt$initiated_job_list_entry,
      ijl_ord: 1 .. 5,
      ptlo: ost$task_index,
      s: string (100),
      sl: integer,
      task_number: 0 ..49,
      taskid: ost$global_task_id,
      t: integer;

    clp$scan_parameter_list (parameter_list, switch_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('TASK_NUMBER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    task_number := value.int.value;

    clp$get_value ('TABLE_LOCK_COUNT', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    xcb [task_number].system_table_lock_count := value.int.value;

    IF task_number < 10 THEN
      ijl_ord := 1;
    ELSEIF (task_number < 20) AND (task_number >= 10) THEN
      ijl_ord := 2;
    ELSEIF (task_number < 30) AND (task_number >= 20) THEN
      ijl_ord := 3;
    ELSEIF (task_number < 40) AND (task_number >= 30) THEN
      ijl_ord := 4;
    ELSE
      ijl_ord := 5;
    IFEND;
    ijl_ordinal.block_number := 0;
    ijl_ordinal.block_index := ijl_ord;
    jmp$get_ijle_p (ijl_ordinal, ijl_p);

    mtv$cst0 [0].xcb_p := ^xcb [task_number];

    clp$get_value ('TIME_USED', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    mtv$cst0 [0].accumulated_job_cptime := value.int.value * 1000;
    mtv$cst0 [0].dispatching_priority := xcb [task_number].dispatching_priority;
    mtv$cst0 [0].jcb_p := #ADDRESS (1, ijl_p^.ajl_ordinal + 14(16), 0);
    mtv$cst0 [0].ijle_p := ijl_p;
    mtv$cst0 [0].equal_priority_subpriority := 6;
    mtv$cst0 [0].cst_index := 0;
    t := #read_register (0c9(16));
    tmp$switch_task (NIL, ^mtv$cst0 [0]);
    t := t - #read_register (0c9(16));
    STRINGREP (s, sl, ' PTLO selected was ', mtv$cst0 [0].taskid.index:8);
    clp$put_job_command_response (s (1, sl), status);
    STRINGREP (s, sl, ' time = ', t:8);
    clp$put_job_command_response (s (1, sl), status);
  PROCEND switch_command;

?? TITLE := 'idle_command', EJECT ??

  PROCEDURE idle_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{             PDT  idle_pdt (
{               task_number, tn: INTEGER 0 .. 49 = $REQUIRED
{               STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    idle_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^idle_pdt_names, ^idle_pdt_params];

  VAR
    idle_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['TASK_NUMBER', 1], ['TN', 1], ['STATUS', 2]];

  VAR
    idle_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ TASK_NUMBER TN }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 49]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
    VAR
      ijl_ord: 1 .. 5,
      ijl_ordinal: jmt$ijl_ordinal,
      ijl_p: ^jmt$initiated_job_list_entry,
      ptlo: ost$task_index,
      taskid: ost$global_task_id,
      task_number: 0 ..49;

    clp$scan_parameter_list (parameter_list, idle_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('TASK_NUMBER', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    task_number := value.int.value;

    IF task_number < 10 THEN
      ijl_ord := 1;
    ELSEIF (task_number < 20) AND (task_number >= 10) THEN
      ijl_ord := 2;
    ELSEIF (task_number < 30) AND (task_number >= 20) THEN
      ijl_ord := 3;
    ELSEIF (task_number < 40) AND (task_number >= 30) THEN
      ijl_ord := 4;
    ELSE
      ijl_ord := 5;
    IFEND;
    ijl_ordinal.block_number := 0;
    ijl_ordinal.block_index := ijl_ord;
    jmp$get_ijle_p (ijl_ordinal, ijl_p);

    ptlo := xcb [task_number].global_task_id.index;
    tmv$ptl_p^ [ptlo].idle_status := tmc$is_idle_initiated;
    mtv$cst0 [0].xcb_p := ^xcb [task_number];
    mtv$cst0 [0].jcb_p := #ADDRESS (1, ijl_p^.ajl_ordinal + 14(16), 0);
    mtv$cst0 [0].ijle_p := ijl_p;
    mtv$cst0 [0].equal_priority_subpriority := 6;
    mtv$cst0 [0].cst_index := 0;
    tmp$switch_task (NIL, ^mtv$cst0 [0]);
  PROCEND idle_command;

?? TITLE := 'display_command', EJECT ??

  PROCEDURE display_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{    PDT display_pdt (
{      PRIORITY: INTEGER 0 .. 10 = $REQUIRED
{      STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    display_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^display_pdt_names,
      ^display_pdt_params];

  VAR
    display_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 2] of
      clt$parameter_name_descriptor := [['PRIORITY', 1], ['STATUS', 2]];

  VAR
    display_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 2] of clt$parameter_descriptor := [

{ PRIORITY }
    [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 10]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
     VAR
       priority: 1 .. 10,
       ptlo: ost$task_index,
       s: string (100),
       sl: integer;

    status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, display_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$get_value ('PRIORITY', 1, 1, clc$low, value, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    priority := value.int.value;

   STRINGREP (s, sl, ' DCT = ', tmv$dct [priority].queue_head:6, tmv$dct [priority].minor_priority:6,
       tmv$dct [priority].major_priority:6, tmv$dct [priority].queue_tail:6);
   clp$put_job_command_response (s (1, sl), status);
   STRINGREP (s, sl, ' DCT CHAIN ');
   clp$put_job_command_response (s (1, sl), status);
   ptlo := tmv$dct [priority].queue_head;
   REPEAT
     STRINGREP (s, sl, ptlo: 6);
     clp$put_job_command_response (s (1, sl), status);
     ptlo := tmv$ptl_p^ [ptlo].ptl_thread;
   UNTIL ptlo = 0;
  PROCEND display_command;

?? TITLE := 'controls_command', EJECT ??

  PROCEDURE controls_command
    (    param_list: clt$parameter_list;
     VAR status: ost$status);

{    PDT controls_pdt (
{    cda: LIST 1..8, 4 OF ANY
{    cdi: integer 0..600
{    STATUS);

?? PUSH (LISTEXT := ON) ??

  VAR
    controls_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^controls_pdt_names,
      ^controls_pdt_params];

  VAR
    controls_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 3] of
      clt$parameter_name_descriptor := [['CDA', 1], ['CDI', 2], ['STATUS', 3]];

  VAR
    controls_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 3] of clt$parameter_descriptor := [

{ CDA }
    [[clc$optional], 1, 8, 4, 4, clc$value_range_not_allowed, [NIL, clc$any_value]],

{ CDI }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$integer_value, 0, 600]],

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
    CONST
      u_second = 1000000;

    VAR
      cda_record: [STATIC] jmt$cda_record := [2, [REP 8 of [0, 100, FALSE]]],
      controls_defined: boolean,
      dp: jmt$dispatching_priority,
      normalized_interval: integer,
      param_specified: boolean,
      set_index: integer,
      value_set_count: 0 .. clc$max_value_sets,
      value: clt$value;

    clp$scan_parameter_list (param_list, controls_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$test_parameter ('CDA', param_specified, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    IF param_specified THEN
      clp$get_set_count ('CDA', value_set_count, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
      FOR set_index := 1 to value_set_count DO
        clp$get_value ('CDA', set_index, 1, clc$low, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        dp := value.int.value;

        clp$get_value ('CDA', set_index, 2, clc$low, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        cda_record.control [dp].minimum := value.int.value;

        clp$get_value ('CDA', set_index, 3, clc$low, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        cda_record.control [dp].maximum := value.int.value;

        clp$get_value ('CDA', set_index, 4, clc$low, value, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        cda_record.control [dp].enforce_maximum := value.bool.value;
      FOREND;
    IFEND;

    clp$get_value ('CDI', 1, 1, clc$low, value, status);
    IF value.kind <> clc$unknown_value THEN
      cda_record.interval := value.int.value;
    IFEND;


{ Decide if controls are being defined; the user may be setting controls back to defaults
{ (0% minimum and 100% maximum).

    controls_defined := FALSE;
  /check_controls/
    FOR dp := jmc$priority_p1 TO jmc$priority_p8 DO
      IF (cda_record.control [dp].minimum <> 0) OR (cda_record.control [dp].maximum <> 100) THEN
        controls_defined := TRUE;
        EXIT /check_controls/;
      IFEND;
    FOREND /check_controls/;

{ Clear the dispatching control sets.
{ If controls are not defined, clear the controls_defined field in the dispatching table and return.
{ If controls are defined, reset the values in the dispatching table.

    tmv$dispatching_control_sets.minimums_to_satisfy := $jmt$dispatching_priority_set [1,2,3,4,5,6];
    tmv$dispatching_control_sets.maximums_exceeded := $jmt$dispatching_priority_set [];
    tmv$dispatching_control_sets.enforce_maximums := $jmt$dispatching_priority_set [];

    IF NOT controls_defined THEN
      tmv$dispatching_controls.controls_defined := FALSE;
    ELSE
      tmv$dispatching_controls.controls_defined := TRUE;
      tmv$dispatching_controls.minimums_to_satisfy := $jmt$dispatching_priority_set [1,2,3,4,5,6];
      tmv$dispatching_controls.maximums_defined := $jmt$dispatching_priority_set [];
      tmv$dispatching_controls.controls.time_left_in_interval := cda_record.interval * u_second;
      normalized_interval := tmv$dispatching_controls.controls.time_left_in_interval DIV 100;
      FOR dp := jmc$priority_p1 TO jmc$priority_p8 DO
        IF cda_record.control [dp].minimum <> 0 THEN
          tmv$dispatching_controls.controls.dispatching_priority_time [dp].minimum_time :=
                (normalized_interval) * cda_record.control [dp].minimum;
          tmv$dispatching_controls.minimums_to_satisfy := tmv$dispatching_controls.minimums_to_satisfy +
                $jmt$dispatching_priority_set [jmc$dp_conversion - dp];
        ELSE
          tmv$dispatching_controls.controls.dispatching_priority_time [dp].minimum_time := 0;
        IFEND;
        IF cda_record.control [dp].maximum <> 100 THEN
          tmv$dispatching_controls.controls.dispatching_priority_time [dp].maximum_time :=
                (normalized_interval) * cda_record.control [dp].maximum;
          tmv$dispatching_controls.maximums_defined := tmv$dispatching_controls.maximums_defined +
                $jmt$dispatching_priority_set [jmc$dp_conversion - dp];
        ELSE
          tmv$dispatching_controls.controls.dispatching_priority_time [dp].maximum_time := 0;
        IFEND;
        IF cda_record.control [dp].enforce_maximum THEN
          tmv$dispatching_control_sets.enforce_maximums := tmv$dispatching_control_sets.enforce_maximums +
                $jmt$dispatching_priority_set [jmc$dp_conversion - dp];
        IFEND;
      FOREND;
      tmv$dispatching_control_sets.minimums_to_satisfy := tmv$dispatching_controls.minimums_to_satisfy;
      tmv$dispatching_control_time := tmv$dispatching_controls.controls;
    IFEND;

  PROCEND controls_command;

?? TITLE := 'quit_command', EJECT ??

  PROCEDURE quit_command
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{   PDT quit_pdt (
{     STATUS)

?? PUSH (LISTEXT := ON) ??

  VAR
    quit_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table := [^quit_pdt_names, ^quit_pdt_params];

  VAR
    quit_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults] array [1 .. 1] of
      clt$parameter_name_descriptor := [['STATUS', 1]];

  VAR
    quit_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1] of clt$parameter_descriptor := [

{ STATUS }
    [[clc$optional], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL, clc$variable_reference,
      clc$array_not_allowed, clc$status_value]]];

?? POP ??
    status.normal := TRUE;
    clp$scan_parameter_list (parameter_list, quit_pdt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$end_include (utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
  PROCEND quit_command;


  PROGRAM tmp$invoke_test_harness
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ table command_table t=c sn=oss$job_paged_literal s=local
{ command (create_task                    ,cret) create_command cm=local
{ command (delete_task                    ,delt) delete_command cm=local
{ command (ready_task                     ,reat) ready_command cm=local
{ command (display_dct                    ,disd) display_command cm=local
{ command (idle_task                      ,idet) idle_command cm=local
{ command (switch_task                    ,swit) switch_command cm=local
{ command (create_controls                ,crec) controls_command cm=local
{ command (quit                           ,end)  quit_command cm=local
{ tablend

?? PUSH (LISTEXT := ON) ??
VAR
  command_table: [STATIC, READ, oss$job_paged_literal] ^clt$command_table := ^command_table_entries,

  command_table_entries: [STATIC, READ, oss$job_paged_literal] array [1 .. 16] of
      clt$command_table_entry := [
  {} ['CREATE_CONTROLS                ', clc$nominal_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^controls_command],
  {} ['CREATE_TASK                    ', clc$nominal_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^create_command],
  {} ['CREC                           ', clc$abbreviation_entry, clc$advertised_entry, 7,
        clc$automatically_log, clc$linked_call, ^controls_command],
  {} ['CRET                           ', clc$abbreviation_entry, clc$advertised_entry, 1,
        clc$automatically_log, clc$linked_call, ^create_command],
  {} ['DELETE_TASK                    ', clc$nominal_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^delete_command],
  {} ['DELT                           ', clc$abbreviation_entry, clc$advertised_entry, 2,
        clc$automatically_log, clc$linked_call, ^delete_command],
  {} ['DISD                           ', clc$abbreviation_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^display_command],
  {} ['DISPLAY_DCT                    ', clc$nominal_entry, clc$advertised_entry, 4,
        clc$automatically_log, clc$linked_call, ^display_command],
  {} ['END                            ', clc$abbreviation_entry, clc$advertised_entry, 8,
        clc$automatically_log, clc$linked_call, ^quit_command],
  {} ['IDET                           ', clc$abbreviation_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^idle_command],
  {} ['IDLE_TASK                      ', clc$nominal_entry, clc$advertised_entry, 5,
        clc$automatically_log, clc$linked_call, ^idle_command],
  {} ['QUIT                           ', clc$nominal_entry, clc$advertised_entry, 8,
        clc$automatically_log, clc$linked_call, ^quit_command],
  {} ['READY_TASK                     ', clc$nominal_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^ready_command],
  {} ['REAT                           ', clc$abbreviation_entry, clc$advertised_entry, 3,
        clc$automatically_log, clc$linked_call, ^ready_command],
  {} ['SWIT                           ', clc$abbreviation_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^switch_command],
  {} ['SWITCH_TASK                    ', clc$nominal_entry, clc$advertised_entry, 6,
        clc$automatically_log, clc$linked_call, ^switch_command]];

?? POP ??


    VAR
      file_attachment: array [1 .. 3] of fst$attachment_option,
      i: integer,
      input_file: amt$local_file_name,
      local_status: ost$status,
      max_ptlo: ost$task_index,
      segment_pointer: amt$segment_pointer,
      unique_name: ost$unique_name,
      utility_attributes: array [1 .. 4] of clt$utility_attribute;

    status.normal := TRUE;
    osv$cpus_logically_on := 1;

    ALLOCATE jmv$ijl_p.block_p: [0 .. 3];
    ALLOCATE jmv$ijl_p.block_p^ [0].index_p;
    pmp$zero_out_table (#LOC (jmv$ijl_p.block_p^ [0].index_p^),
           #SIZE (jmv$ijl_p.block_p^ [0].index_p^));

    ALLOCATE tmv$ptl_p: [0 .. 49];
    pmp$zero_out_table (#LOC (tmv$ptl_p^), #SIZE (tmv$ptl_p^));

    max_ptlo := UPPERBOUND (tmv$ptl_p^);
    FOR i := 1 TO max_ptlo DO
      tmv$ptl_p^ [i].ptl_thread := i + 1;
      tmv$ptl_p^ [i].index := i MOD 256;
    FOREND;
    tmv$ptl_p^ [max_ptlo].ptl_thread := 0;

{ Initialize the free queue control block.

    tmv$dct [jmc$null_dispatching_priority].queue_head := 1;
    tmv$dct [jmc$null_dispatching_priority].queue_tail := max_ptlo;
    tmv$tables_initialized := TRUE;

    utility_attributes [1].key := clc$utility_command_search_mode;
    utility_attributes [1].command_search_mode := clc$global_command_search;
    utility_attributes [2].key := clc$utility_command_table;
    utility_attributes [2].command_table := command_table;
    utility_attributes [3].key := clc$utility_termination_command;
    utility_attributes [3].termination_command := 'quit';
    utility_attributes [4].key := clc$utility_prompt;
    utility_attributes [4].prompt.value := prompt_string;
    utility_attributes [4].prompt.size := prompt_string_size;

    clp$begin_utility (utility_name, utility_attributes, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    clp$include_file (clc$current_command_input, '', utility_name, status);

    clp$end_utility (utility_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND tmp$invoke_test_harness;

MODEND tmm$dispatcher_test_harness;
*DECK DECK=TMM$DISPOSE_OF_MONITOR_FAULT EXPAND=TRUE

?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
?? NEWTITLE := 'NOS/VE: Program Management - Program Conditions' ??
?? NEWTITLE := '  Global System Declarations' ??
MODULE tmm$dispose_of_monitor_fault;
{   PURPOSE:
{     The purpose of this module is to confine the knowledge necessary
{     route monitor faults to their appropriate handlers.

{   DESIGN:
{     The module has an execution bracket of 2 - 13, and a call bracket
{     of 13.
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc OST$STACK_FRAME_SAVE_AREA
?? POP ??
?? TITLE := '  Global External Procedures' ??
?? EJECT ??
?? TITLE := '  Internal Declarations' ??
?? EJECT ??
*copyc TMT$MONITOR_FAULT_HANDLER
*copyc OST$MONITOR_FAULT
?? TITLE := '  External Procedures' ??
?? EJECT ??
*copyc TMH$FIND_MONITOR_FAULT
*copyc TMP$FIND_MONITOR_FAULT
?? TITLE := '  [XDCL] tmp$dispose_of_monitor_faults' ??
?? EJECT ??

  PROCEDURE [XDCL] tmp$dispose_of_monitor_faults (sfsa: ^ost$stack_frame_save_area);


    VAR
      fault: ost$monitor_fault,
      fault_found: boolean,
      monitor_fault_handler: tmt$monitor_fault_handler;

    REPEAT
      tmp$find_monitor_fault (sfsa, fault, fault_found, monitor_fault_handler);
      IF fault_found THEN
        monitor_fault_handler^ (fault, sfsa);
      IFEND;
    UNTIL NOT fault_found;
  PROCEND tmp$dispose_of_monitor_faults;

MODEND tmm$dispose_of_monitor_fault;
*DECK DECK=TMM$DISPOSE_OF_RING2_PREEMPTS EXPAND=TRUE

?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
?? NEWTITLE := 'NOS/VE: Program Control - Preemptive Communications' ??
MODULE tmm$dispose_of_ring2_preempts;
{   PURPOSE:
{     The purpose of this module is to execute with the privileges necessary
{     to call a signal/flag handler from within its execution bracket.

{   DESIGN:
{    The procedures contained in this module have an execution bracket
{    of 2, 2 and a call bracket of 3.

?? NEWTITLE := '  tmm$dispose_of_ring2_preempts - Global External Procedures' ??
?? EJECT ??
*copyc I#DISABLE_TRAPS
*copyc I#ENABLE_TRAPS
*copyc I#RESTORE_TRAPS

?? TITLE := '  tmm$dispose_of_ring2_preempts - External Procedures' ??
?? EJECT ??

*copyc TMH$FIND_FLAG_TO_PROCESS
*copyc TMP$FIND_FLAG_TO_PROCESS

*copyc TMH$FIND_SIGNAL
*copyc TMP$FIND_SIGNAL
?? TITLE := '  [XDCL, #GATE] tmp$dispose_of_ring2_flags' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] tmp$dispose_of_ring2_flags;
*copyc TMH$DISPOSE_OF_RING2_FLAGS

*copyc TMIDSF
  PROCEND tmp$dispose_of_ring2_flags;
?? TITLE := '  [XDCL, #GATE] tmp$dispose_of_ring2_signals' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] tmp$dispose_of_ring2_signals;
*copyc TMH$DISPOSE_OF_RING2_SIGNALS

*copyc TMIDSGL
  PROCEND tmp$dispose_of_ring2_signals;

MODEND tmm$dispose_of_ring2_preempts;
*DECK DECK=TMM$DISPOSE_OF_RING3_PREEMPTS EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
?? NEWTITLE := 'NOS/VE: Program Control - Preemptive Communications' ??
MODULE tmm$dispose_of_ring3_preempts;
{   PURPOSE:
{     The purpose of this module is to execute with the privileges necessary
{     to call a signal/flag handler from within its execution bracket.

{   DESIGN:
{    The procedures contained in this module have an execution bracket
{    of 2, 3 and a call bracket of 3.
?? NEWTITLE := '  tmm$dispose_of_ring3_preempts - Global External Procedures' ??
?? EJECT ??
*copyc I#DISABLE_TRAPS
*copyc I#ENABLE_TRAPS
*copyc I#RESTORE_TRAPS

?? TITLE := '  tmm$dispose_of_ring3_preempts - External Procedures' ??
?? EJECT ??

*copyc TMH$FIND_FLAG_TO_PROCESS
*copyc TMP$FIND_FLAG_TO_PROCESS

*copyc TMH$FIND_SIGNAL
*copyc TMP$FIND_SIGNAL
?? TITLE := '  [XDCL] tmp$dispose_of_ring3_flags' ??
?? EJECT ??

  PROCEDURE [XDCL] tmp$dispose_of_ring3_flags;
*copyc TMH$DISPOSE_OF_RING3_FLAGS

*copyc TMIDSF
  PROCEND tmp$dispose_of_ring3_flags;
?? TITLE := '  [XDCL] tmp$dispose_of_ring3_signals' ??
?? EJECT ??

  PROCEDURE [XDCL] tmp$dispose_of_ring3_signals;
*copyc TMH$DISPOSE_OF_RING3_SIGNALS

*copyc TMIDSGL
  PROCEND tmp$dispose_of_ring3_signals;

MODEND tmm$dispose_of_ring3_preempts;
*DECK DECK=TMM$DISPOSE_PREEMPTIVE_COMMO EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Management - Preemptive Communications' ??
MODULE tmm$dispose_preemptive_commo;

{ PURPOSE:
{   The purpose of this module is to package contained procedures so
{   that they execute with the privileges necessary to read the structures
{   in the execution control block that support signals and system flags.
{
{ DESIGN:
{   The procedures contained in the module have an execution bracket
{   of 2, 3 and a call bracket of 13.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osc$processor_defined_registers
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc ost$caller_identifier
*copyc ost$execution_control_block
*copyc pmt$condition
*copyc pmt$task_control_block
*copyc tmc$execution_ring_constants
*copyc tmt$allocated_execution_rings
*copyc tmt$preempted_reason
*copyc tmt$rb_update_job_task_enviro
?? POP ??
*copyc i#call_monitor
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$verify_system_privilege
*copyc pmp$continue_to_cause
*copyc pmp$find_executing_task_xcb
*copyc tmp$allocate_execution_rings
*copyc tmp$dispose_of_ring2_flags
*copyc tmp$dispose_of_ring2_signals
*copyc tmp$dispose_of_ring3_flags
*copyc tmp$dispose_of_ring3_signals
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] tmp$dispose_preemptive_commo', EJECT ??
*copy tmh$dispose_preemptive_commo

  PROCEDURE [XDCL, #GATE] tmp$dispose_preemptive_commo
    (    preempted_reason: tmt$preempted_reason);

    TYPE
      valid_preempted_reasons = set of tmt$preempted_reason,
      signals_present = set of tmt$signal_buffers;

    VAR
      allocated_execution_rings: tmt$allocated_execution_rings,
      execution_ring: tmt$handler_execution_ring,
      preempted: ost$caller_identifier,
      signals_to_process: ^signals_present,
      tcb_p: ^pmt$task_control_block,
      valid_reasons: [STATIC, READ, oss$job_paged_literal] valid_preempted_reasons :=
            $valid_preempted_reasons [tmc$free_flag, tmc$recognition_ring_delay, tmc$x_bracket_delay,
            tmc$task_termination],
      xcb_p: ^ost$execution_control_block;

?? NEWTITLE := 'dispose_of_nonlocal_exit' ??

{ PURPOSE:
{   This procedure ensures that all preemptive communications are processed
{   before a nonlocal exit is premitted to complete or the task is permitted
{   to terminate.

    PROCEDURE dispose_of_nonlocal_exit
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);

      tmp$dispose_preemptive_commo (preempted_reason);
    PROCEND dispose_of_nonlocal_exit;
?? OLDTITLE ??
?? EJECT ??

    osp$verify_system_privilege;
    #CALLER_ID (preempted);
    IF (preempted_reason IN valid_reasons) THEN
      pmp$find_executing_task_xcb (xcb_p);
      tcb_p := xcb_p^.task_control_block;
      signals_to_process := #LOC (xcb_p^.signals.present);
      IF (signals_to_process^ <> $signals_present []) OR (tcb_p^.task_local_signal_list.delink <> NIL) OR
            (xcb_p^.system_flags <> $tmt$system_flags []) THEN
        osp$establish_block_exit_hndlr (^dispose_of_nonlocal_exit);
        IF (signals_to_process^ <> $signals_present []) OR (tcb_p^.task_local_signal_list.delink <> NIL) THEN
          tmp$allocate_execution_rings (preempted.ring, preempted_reason, tmc$signal,
                allocated_execution_rings);
          FOR execution_ring := tmc$lowest_signal_flag_ring TO tmc$highest_signal_flag_ring DO
            IF execution_ring IN allocated_execution_rings THEN
              CASE execution_ring OF
              = tmc$task_monitor2_ring =
                tmp$dispose_of_ring2_signals;
              = tmc$task_services_ring =
                tmp$dispose_of_ring3_signals;
              CASEND;
            IFEND;
          FOREND;
        IFEND;
        IF (xcb_p^.system_flags <> $tmt$system_flags []) THEN
          tmp$allocate_execution_rings (preempted.ring, preempted_reason, tmc$system_flag,
                allocated_execution_rings);
          FOR execution_ring := tmc$lowest_signal_flag_ring TO tmc$highest_signal_flag_ring DO
            IF execution_ring IN allocated_execution_rings THEN
              CASE execution_ring OF
              = tmc$task_monitor2_ring =
                tmp$dispose_of_ring2_flags;
              = tmc$task_services_ring =
                tmp$dispose_of_ring3_flags;
              CASEND;
            IFEND;
          FOREND;
        IFEND;
        osp$disestablish_cond_handler;
      IFEND;
    IFEND;
  PROCEND tmp$dispose_preemptive_commo;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] tmp$dispose_of_inserted_preempt', EJECT ??
*copy tmh$dispose_of_inserted_preempt

  PROCEDURE [XDCL] tmp$dispose_of_inserted_preempt;

    tmp$dispose_preemptive_commo (tmc$x_bracket_delay);
  PROCEND tmp$dispose_of_inserted_preempt;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] tmp$disable_preemptive_commo', EJECT ??
*copy tmh$disable_preemptive_commo

  PROCEDURE [XDCL] tmp$disable_preemptive_commo;

    VAR
      rb: tmt$rb_update_job_task_enviro;

{ Disable preemptive communication then process outstanding signals and flags.
{ Ignore the status on the monitor request.

    rb.reqcode := syc$rc_update_job_task_enviro;
    rb.subcode := tmc$ujte_set_task_terminating;
    i#call_monitor (#LOC (rb), #SIZE (rb));

    tmp$dispose_preemptive_commo (tmc$task_termination);
  PROCEND tmp$disable_preemptive_commo;
?? OLDTITLE ??
MODEND tmm$dispose_preemptive_commo;
*DECK DECK=TMM$GET_MONITOR_FAULT EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
?? NEWTITLE := 'NOS/VE: Program Management - Program Conditions' ??
?? NEWTITLE := '  Global System Declarations' ??
MODULE tmm$get_monitor_fault;
{   PURPOSE:
{     The purpose of this module is to package the contained procedure
{     with the privileges necessary to modify the monitor fault
{     structures in the XCB.

{   DESIGN:
{     The procedure (TMP$GET_MONITOR_FAULT) contained in this module
{     has a execution bracket of 1, 1 and a call bracket of 3.
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc OST$EXECUTION_CONTROL_BLOCK
?? POP ??
*copyc TMT$FAULT_STATUS
?? TITLE := '  Global External Procedures' ??
?? EJECT ??
*copyc I#DISABLE_TRAPS
*copyc I#RESTORE_TRAPS

*copyc PMP$FIND_EXECUTING_TASK_XCB
?? TITLE := '  [XDCL, #GATE] tmp$get_monitor_fault' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] tmp$get_monitor_fault (fault_index: tmt$monitor_fault_buffers;
    VAR fault: ost$monitor_fault;
    VAR fault_status: tmt$fault_status);
*copy TMH$GET_MONITOR_FAULT

    VAR
      trap_enables: 0 .. 3,
      xcb: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb);
    i#disable_traps (trap_enables);

    IF (fault_index >= LOWERVALUE (tmt$monitor_fault_buffers)) AND (fault_index <= UPPERVALUE
          (tmt$monitor_fault_buffers)) THEN
      IF (xcb^.monitor_faults.present [fault_index]) THEN
        fault := xcb^.monitor_faults.buffer [fault_index];
        xcb^.monitor_faults.present [fault_index] := FALSE;
        xcb^.monitor_faults.reserved [fault_index] := FALSE;
        fault_status := tmc$normal_fault_status;
      ELSE
        fault_status := tmc$no_fault_present;
      IFEND;
    ELSE
      fault_status := tmc$invalid_fault_index;
    IFEND;
    i#restore_traps (trap_enables);
  PROCEND tmp$get_monitor_fault;
MODEND tmm$get_monitor_fault;
*DECK DECK=TMM$MANAGE_MONITOR_FAULTS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Control - Monitor Faults' ??
MODULE tmm$manage_monitor_faults;

{ PURPOSE:
{   The purpose of this module is execute with the privileges necessary
{   to read the monitor fault buffers in the oss$job_fixed section and to
{   modify monitor fault structures in the oss$task_private section.
{
{ DESIGN:
{   The procedures in the module have an execution bracket of 2, 3 and
{   a call bracket of 13.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osd$code_base_pointer
*copyc osd$virtual_address
*copyc oss$job_paged_literal
*copyc oss$task_private
*copyc ost$execution_control_block
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc pmt$condition
*copyc pme$define_handler_exceptions
*copyc pme$exec_call_bracket_error
*copyc tmt$monitor_fault_buffer
*copyc tmt$monitor_fault_handler
?? POP ??
*copyc i#disable_traps
*copyc i#restore_traps
*copyc mmp$fetch_segment_attributes
*copyc mmp$segment_fault_handler
*copyc osp$set_status_abnormal
*copyc osp$verify_system_privilege
*copyc pmp$dispose_mcr_conditions
*copyc pmp$find_executing_task_xcb
*copyc tmp$dispose_of_broken_task
*copyc tmp$dispose_system_req_fault
*copyc tmp$get_monitor_fault
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  VAR
    tmv$monitor_fault_handler: [STATIC, READ, oss$job_paged_literal] array [0 .. osc$max_fault_id] of
          tmt$monitor_fault_handler := [NIL, ^tmp$dispose_of_broken_task, ^pmp$dispose_mcr_conditions,
          ^mmp$segment_fault_handler, NIL, ^tmp$dispose_system_req_fault, NIL, REP
          (osc$max_fault_id - tmc$last_fault_id_assigned) of NIL],

    tmv$monitor_fault_trapped_sfsa: [STATIC, oss$task_private] array [tmt$monitor_fault_buffers] of
          ^ost$stack_frame_save_area := [REP tmc$maximum_monitor_faults of NIL];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] tmp$find_monitor_fault', EJECT ??
*copy tmh$find_monitor_fault

  PROCEDURE [XDCL, #GATE] tmp$find_monitor_fault
    (    sfsa: ^ost$stack_frame_save_area;
     VAR fault: ost$monitor_fault;
     VAR fault_found: boolean;
     VAR monitor_fault_handler: tmt$monitor_fault_handler);

    VAR
      fault_status: tmt$fault_status,
      fault_index: 1 .. (tmc$maximum_monitor_faults + 1),
      trap_enables: 0 .. 3,
      xcb_p: ^ost$execution_control_block;

    osp$verify_system_privilege;
    fault_found := FALSE;
    fault_index := LOWERVALUE (tmt$monitor_fault_buffers);
    pmp$find_executing_task_xcb (xcb_p);
    i#disable_traps (trap_enables);

    WHILE NOT fault_found AND (fault_index <= UPPERVALUE (tmt$monitor_fault_buffers)) DO
      IF ((xcb_p^.monitor_faults.present [fault_index]) AND
            (#SEGMENT (tmv$monitor_fault_trapped_sfsa [fault_index]) = #SEGMENT (sfsa)) AND
            (#OFFSET (tmv$monitor_fault_trapped_sfsa [fault_index]) = #OFFSET (sfsa))) THEN
        tmp$get_monitor_fault (fault_index, fault, fault_status);
        CASE fault_status OF
        = tmc$normal_fault_status =
          fault_found := TRUE;
          monitor_fault_handler := tmv$monitor_fault_handler [$INTEGER (fault.identifier)];
          tmv$monitor_fault_trapped_sfsa [fault_index] := NIL;
        = tmc$no_fault_present =
          ;
        = tmc$invalid_fault_index =
          ;
        ELSE
        CASEND;
      IFEND;
      fault_index := fault_index + 1;
    WHILEND;
    i#restore_traps (trap_enables);
  PROCEND tmp$find_monitor_fault;
?? OLDTITLE ??
?? TITLE := '[XDCL, #GATE] tmp$post_monitor_fault_sfsa', EJECT ??
*copy tmh$post_monitor_fault_sfsa

  PROCEDURE [XDCL, #GATE] tmp$post_monitor_fault_sfsa
    (    sfsa: ^ost$stack_frame_save_area;
     VAR monitor_fault_present: boolean);

    VAR
      fault_index: tmt$monitor_fault_buffers,
      xcb_p: ^ost$execution_control_block;

    osp$verify_system_privilege;
    monitor_fault_present := FALSE;
    pmp$find_executing_task_xcb (xcb_p);
    FOR fault_index := LOWERVALUE (tmt$monitor_fault_buffers) TO UPPERVALUE (tmt$monitor_fault_buffers) DO
      IF (xcb_p^.monitor_faults.present [fault_index] AND (tmv$monitor_fault_trapped_sfsa [fault_index] =
            NIL)) THEN
        tmv$monitor_fault_trapped_sfsa [fault_index] := sfsa;
        monitor_fault_present := TRUE;
      IFEND;
    FOREND;
  PROCEND tmp$post_monitor_fault_sfsa;
?? OLDTITLE ??
MODEND tmm$manage_monitor_faults;
*DECK DECK=TMM$MANAGE_PREEMPTIVE_BUFFERS EXPAND=TRUE
?? SET (LISTCTS := OFF) ??
?? LEFT := 1, RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Control - Preemptive Communications' ??
?? NEWTITLE := '  tmm$manage_preemptive_buffers - Global System Declarations' ??
{   PURPOSE:
{     The purpose of this module is to package the contained with the
{     privileges necessary to modify signal and flag structures in job
{     private fixed and mainframe pageable.

{   DESIGN:
{    The procedures contained in this module have an execution bracket
{    of 1, 1 and a call bracket of 3.

?? EJECT ??
MODULE tmm$manage_preemptive_buffers;
?? PUSH (LISTEXT := ON) ??
*copyc OST$EXECUTION_CONTROL_BLOCK
?? POP ??
*copyc OSE$HEAP_FULL_EXCEPTIONS
*copyc OSV$MAINFRAME_PAGEABLE_HEAP
*copyc PMC$PROGRAM_MANAGEMENT_ID
*copyc ost$signature_lock
*copyc TMT$SIGNAL_STATUS
*copyc TMT$FLAG_STATUS
?? TITLE := '  tmm$manage_preemptive_buffers - Global External Procedures' ??
?? EJECT ??

*copyc I#DISABLE_TRAPS
*copyc I#RESTORE_TRAPS
*copyc I#ENABLE_TRAPS
*copyc PMP$GET_EXECUTING_TASK_GTID
*copyc OSH$SET_STATUS_ABNORMAL
*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSH$SET_SIGNATURE_LOCK
*copyc OSP$SET_MAINFRAME_SIG_LOCK
*copyc OSH$CLEAR_SIGNATURE_LOCK
*copyc OSP$CLEAR_MAINFRAME_SIG_LOCK
*copyc PMP$FIND_EXECUTING_TASK_XCB
?? TITLE := '  Internal Declarations' ??
?? EJECT ??

  CONST
    unlocked = 0;

  TYPE
    tmt$mainframe_signal_list = record
      lock: ost$signature_lock,
      delink: ^tmt$mainframe_linked_signal,
      link: ^^tmt$mainframe_linked_signal,
    recend;


*copyc TMT$MAINFRAME_LINKED_SIGNAL
*copyc TMT$SIGNAL_BUFFER
*copyc OST$GLOBAL_TASK_ID

  VAR
    tmv$mainframe_signal_list: [STATIC, oss$mainframe_pageable] tmt$mainframe_signal_list := [[0],
       NIL, NIL];

?? TITLE := '  [XDCL, #GATE] tmp$get_signal' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] tmp$get_signal (buffer_index: tmt$signal_buffers;
    VAR signal: tmt$signal;
    VAR signal_status: tmt$signal_status);
*copyc TMH$GET_SIGNAL

    VAR
      traps: 0 .. 3,
      xcb: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb);
    i#disable_traps (traps);

    IF (buffer_index >= LOWERVALUE (tmt$signal_buffers)) AND (buffer_index <= UPPERVALUE (tmt$signal_buffers))
          THEN
      IF xcb^.signals.present [buffer_index] THEN
        signal := xcb^.signals.buffer [buffer_index];
        xcb^.signals.present [buffer_index] := FALSE;
        xcb^.signals.reserved [buffer_index] := FALSE;
        signal_status := tmc$normal_signal_status;
      ELSE
        signal_status := tmc$no_signal_present;
      IFEND;
    ELSE
      signal_status := tmc$invalid_buffer_index;
    IFEND;
    i#restore_traps (traps);
  PROCEND tmp$get_signal;
?? TITLE := '  [XDCL, #GATE] tmp$find_mainframe_signal' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] tmp$find_mainframe_signal
    (    gtid: ost$global_task_id;
     VAR signal_found: boolean;
     VAR signal: tmt$signal);
*copyc TMH$FIND_MAINFRAME_SIGNAL

    VAR
      mf_signal_found: boolean,
      free_signal: ^tmt$mainframe_linked_signal,
      delink: ^^tmt$mainframe_linked_signal,
      traps: 0 .. 3,
      ignore_status: ost$status;

    signal_found := FALSE;
    i#disable_traps (traps);
    osp$set_mainframe_sig_lock (tmv$mainframe_signal_list.lock);
    IF (tmv$mainframe_signal_list.delink <> NIL) THEN
      delink := ^tmv$mainframe_signal_list.delink;
      mf_signal_found := FALSE;
      WHILE NOT mf_signal_found AND (delink^ <> NIL) DO
        IF (delink^^.recipient.index = gtid.index) THEN
          IF (delink^^.recipient.seqno = gtid.seqno) THEN
            signal := delink^^.linked;
            mf_signal_found := TRUE;
            free_signal := delink^;
            delink^ := delink^^.next_linked_signal;
            FREE free_signal IN osv$mainframe_pageable_heap^;
            IF (delink^ = NIL) THEN
              tmv$mainframe_signal_list.link := delink;
            IFEND;
          ELSE
            free_signal := delink^;
            delink^ := delink^^.next_linked_signal;
            FREE free_signal IN osv$mainframe_pageable_heap^;
            IF (delink^ = NIL) THEN
              tmv$mainframe_signal_list.link := delink;
            IFEND;
          IFEND;
        ELSE
          delink := ^delink^^.next_linked_signal;
        IFEND;
      WHILEND;
      signal_found := mf_signal_found;
    IFEND;
    osp$clear_mainframe_sig_lock (tmv$mainframe_signal_list.lock);
    i#restore_traps (traps);
  PROCEND tmp$find_mainframe_signal;
?? TITLE := '  [XDCL, #GATE] tmp$post_mainframe_signal' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] tmp$post_mainframe_signal (recipient: ost$global_task_id;
        signal: pmt$signal;
    VAR status: ost$status);
*copyc TMH$POST_MAINFRAME_SIGNAL

    VAR
      traps: 0 .. 3,
      executing_task: ost$global_task_id,
      ignore_status: ost$status;

    status.normal := TRUE;
    pmp$get_executing_task_gtid (executing_task);
    i#disable_traps (traps);
    osp$set_mainframe_sig_lock (tmv$mainframe_signal_list.lock);
    IF (tmv$mainframe_signal_list.link = NIL) THEN
      tmv$mainframe_signal_list.link := ^tmv$mainframe_signal_list.delink;
    IFEND;
    ALLOCATE tmv$mainframe_signal_list.link^ IN osv$mainframe_pageable_heap^;
    IF (tmv$mainframe_signal_list.link^ <> NIL) THEN
      tmv$mainframe_signal_list.link^^.linked.signal := signal;
      tmv$mainframe_signal_list.link^^.linked.originator := executing_task;
      tmv$mainframe_signal_list.link^^.recipient := recipient;
      tmv$mainframe_signal_list.link^^.next_linked_signal := NIL;
      tmv$mainframe_signal_list.link := ^tmv$mainframe_signal_list.link^^.next_linked_signal;
    ELSE
      osp$set_status_abnormal (pmc$program_management_id, ose$mainframe_pageable_full, 'signal processor',
            status);
    IFEND;
    osp$clear_mainframe_sig_lock (tmv$mainframe_signal_list.lock);
    i#restore_traps (traps);
  PROCEND tmp$post_mainframe_signal;
?? TITLE := '  [XDCL, #GATE] tmp$clear_system_flag' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] tmp$clear_system_flag (flag_id: ost$system_flag;
    VAR flag_status: tmt$flag_status);
*copyc TMH$CLEAR_SYSTEM_FLAG

    VAR
      traps: 0 .. 3,
      system_flags: ^packed array [tmc$first_system_flag .. tmc$last_system_flag] of boolean,
      xcb: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb);
    i#disable_traps (traps);

    IF (flag_id >= LOWERVALUE (ost$system_flag)) AND (flag_id <= UPPERVALUE (ost$system_flag)) THEN
      IF (flag_id IN xcb^.system_flags) THEN
        system_flags := #LOC (xcb^.system_flags);
        system_flags^ [flag_id] := FALSE;
        flag_status := tmc$normal_flag_status;
      ELSE
        flag_status := tmc$flag_not_set;
      IFEND;
    ELSE
      flag_status := tmc$invalid_flag_id;
    IFEND;
    i#restore_traps (traps);
  PROCEND tmp$clear_system_flag;
?? TITLE := '  [XDCL, #GATE] tmp$clear_wait_inhibited' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] tmp$clear_wait_inhibited (VAR wait_inhibited: boolean);

*copyc TMH$CLEAR_WAIT_INHIBITED

    VAR
      xcb: ^ost$execution_control_block;

    pmp$find_executing_task_xcb (xcb);
    wait_inhibited := xcb^.wait_inhibited;
    xcb^.wait_inhibited := FALSE;
  PROCEND tmp$clear_wait_inhibited;
?? TITLE := '  [XDCL, #GATE] tmp$enable_preemptive' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] tmp$enable_preemptive;

*copyc TMH$ENABLE_PREEMPTIVE

{*callc jmxjthp

    VAR
      traps: 0 .. 3,
      xcb: ^ost$execution_control_block;

    i#enable_traps (traps);
  PROCEND tmp$enable_preemptive;

MODEND tmm$manage_preemptive_buffers;
*DECK DECK=TMM$MANAGE_SIGNALS_AND_FLAGS EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Control - Preemptive Communications' ??
?? NEWTITLE := '  tmm$manage_signals_and_flags - Global System Declarations' ??
{   PURPOSE:
{    The purpose of this module is to package the contained procedures
{    so that they have the privilege necessary to read the XCB and to
{    read/write job pageable.

{   DESIGN:
{    The procedures contained in this module have an execution bracket
{    of 2, 2 and a call bracket of 3.

?? EJECT ??
MODULE tmm$manage_signals_and_flags;
?? SET (LIST := OFF) ??
*copyc OST$EXECUTION_CONTROL_BLOCK
*copyc OST$CALLER_IDENTIFIER
*copyc OSE$HEAP_FULL_EXCEPTIONS
*copyc PMC$PROGRAM_MANAGEMENT_ID
*copyc OSV$JOB_PAGEABLE_HEAP
?? SET (LIST := ON) ??
?? TITLE := '  tmm$manage_signals_and_flags - Global External Procedures' ??
?? EJECT ??

*copyc I#DISABLE_TRAPS
*copyc I#RESTORE_TRAPS
*copyc PMP$FIND_EXECUTING_TASK_XCB
*copyc PMP$FIND_EXECUTING_TASK_TCB
*copyc PMP$GET_EXECUTING_TASK_GTID
*copyc PMP$CYCLE
?? TITLE := '  tmm$manage_signals_and_flags - Internal Declarations' ??
?? EJECT ??
*copyc TMT$TASK_LOCAL_LINKED_SIGNAL
*copyc TMV$SIGNAL_HANDLER_DESCRIPTIONS
*copyc TMV$FLAG_HANDLER_DESCRIPTIONS
*copyc TMC$EXECUTION_RING_CONSTANTS
?? TITLE := '  tmm$manage_signals_and_flags - External Procedures' ??
?? EJECT ??
*copyc TMH$GET_SIGNAL
*copyc TMP$GET_SIGNAL
*copyc TMP$FIND_MAINFRAME_SIGNAL
*copyc TMP$DISPOSE_PREEMPTIVE_COMMO
*copyc TMH$CLEAR_SYSTEM_FLAG
*copyc TMP$CLEAR_SYSTEM_FLAG

*copyc TMH$ENABLE_PREEMPTIVE
*copyc TMP$ENABLE_PREEMPTIVE
?? TITLE := '  [XDCL, #GATE] tmp$find_signal' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] tmp$find_signal (VAR signal_found: boolean;
    VAR signal: tmt$signal;
    VAR signal_handler: tmt$signal_handler);
*copyc TMH$FIND_SIGNAL

    VAR
      caller: ost$caller_identifier,
      traps: 0 .. 3,
      buffer_index: 1 .. (tmc$maximum_signals + 1),
      signal_status: tmt$signal_status,
      xcb: ^ost$execution_control_block,
      tcb: ^pmt$task_control_block;

    #caller_id (caller);
    pmp$find_executing_task_xcb (xcb);
    tcb := xcb^.task_control_block;

    signal_found := FALSE;
    buffer_index := LOWERVALUE (tmt$signal_buffers);
    i#disable_traps (traps);
    WHILE NOT signal_found AND (buffer_index <= UPPERVALUE (tmt$signal_buffers)) DO
      IF xcb^.signals.present [buffer_index] AND (tcb^.signal_execution_ring [buffer_index] = caller.ring)
        THEN
        tmp$get_signal (buffer_index, signal, signal_status);
        CASE signal_status OF
        = tmc$normal_signal_status =
          tcb^.signal_execution_ring [buffer_index] := tmc$unallocated;
          signal_found := TRUE;
          signal_handler := tmv$signal_handler_descriptions [signal.signal.identifier].signal_handler;
        = tmc$no_signal_present =
          ;
        = tmc$invalid_buffer_index =
          ;
        ELSE
        CASEND;
      ELSE
        buffer_index := buffer_index + 1;
      IFEND;
    WHILEND;

    IF NOT signal_found THEN
      find_task_local_signal (caller.ring, signal_found, signal);
      IF signal_found THEN
        signal_handler := tmv$signal_handler_descriptions [signal.signal.identifier].signal_handler;
      IFEND;
    IFEND;
    i#restore_traps (traps);
  PROCEND;
?? TITLE := '  find_task_local_signal' ??
?? EJECT ??

  PROCEDURE find_task_local_signal (execution_ring: tmt$handler_execution_ring;
    VAR signal_found: boolean;
    VAR signal: tmt$signal);

{
{   The purpose of this request is to obtain a signal from the task
{ local signal list which corresponds to to execution ring.
{
{       FIND_TASK_LOCAL_SIGNAL (EXECUTION_RING, SIGNAL_FOUND, SIGNAL)
{
{ EXECUTION_RING: (input) This parameter specifies the ring of the
{       signal.
{
{ SIGNAL_FOUND: (output) This parameter specifies whether a signal
{       was found for the specified execution ring.
{
{ SIGNAL: (output) This parameter specifies the returned signal.
{
{

    VAR
      tcb: ^pmt$task_control_block,
      free_signal: ^tmt$task_local_linked_signal,
      delink: ^^tmt$task_local_linked_signal;

    pmp$find_executing_task_tcb (tcb);
    delink := ^tcb^.task_local_signal_list.delink;
    signal_found := FALSE;
    WHILE NOT signal_found AND (delink^ <> NIL) DO
      IF (delink^^.signal_execution_ring = execution_ring) THEN
        signal := delink^^.linked;
        free_signal := delink^;
        delink^ := delink^^.next_linked_signal;
        FREE free_signal IN osv$job_pageable_heap^;
        signal_found := TRUE;
        IF (delink^ = NIL) THEN
          tcb^.task_local_signal_list.link := delink;
        IFEND;
      ELSE
        delink := ^delink^^.next_linked_signal;
      IFEND;
    WHILEND;
  PROCEND;
?? TITLE := '  post_task_local_signal' ??
?? EJECT ??

  PROCEDURE post_task_local_signal (signal: tmt$signal);

{   The purpose of this request is to add signal to the task local signal list.

    VAR
      tcb: ^pmt$task_control_block,
      ignore_status: ost$status;

    pmp$find_executing_task_tcb (tcb);
    ALLOCATE tcb^.task_local_signal_list.link^ IN osv$job_pageable_heap^;
    tcb^.task_local_signal_list.link^^.signal_execution_ring := tmc$unallocated;
    tcb^.task_local_signal_list.link^^.linked := signal;
    tcb^.task_local_signal_list.link^^.next_linked_signal := NIL;
    tcb^.task_local_signal_list.link := ^tcb^.task_local_signal_list.link^^.next_linked_signal;
  PROCEND;
?? TITLE := '  [XDCL] tmp$dispose_mainframe_signals' ??
?? EJECT ??

  PROCEDURE [XDCL] tmp$dispose_mainframe_signals (flag_id: ost$system_flag);
*copyc TMH$DISPOSE_MAINFRAME_SIGNALS

    VAR
      gtid: ost$global_task_id,
      signal_found: boolean,
      signal: tmt$signal,
      signal_to_dispose: boolean,
      traps: 0 .. 3;

    i#disable_traps (traps);
    signal_to_dispose := FALSE;
    signal_found := TRUE;
    pmp$get_executing_task_gtid (gtid);
    WHILE signal_found DO
      tmp$find_mainframe_signal (gtid, signal_found, signal);
      IF signal_found THEN
        post_task_local_signal (signal);
        signal_to_dispose := TRUE;
      IFEND;
    WHILEND;
    i#restore_traps (traps);
    IF signal_to_dispose THEN
      tmp$dispose_preemptive_commo (tmc$free_flag);
    IFEND;
  PROCEND;
?? TITLE := '  [XDCL, #GATE] tmp$find_flag_to_process' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] tmp$find_flag_to_process (VAR flag_found: boolean;
    VAR flag_id: ost$system_flag;
    VAR flag_handler: tmt$system_flag_handler);

*copyc TMH$FIND_FLAG_TO_PROCESS

    VAR
      caller: ost$caller_identifier,
      xcb: ^ost$execution_control_block,
      tcb: ^pmt$task_control_block,
      system_flag_found: boolean,
      system_flag: ost$system_flag,
      flag_status: tmt$flag_status,
      trap_enables: 0 .. 3;

    #caller_id (caller);
    flag_id := LOWERVALUE (ost$system_flag);
    flag_found := FALSE;
    pmp$find_executing_task_xcb (xcb);
    tcb := xcb^.task_control_block;
    i#disable_traps (trap_enables);
    system_flag := LOWERVALUE (ost$system_flag);
    system_flag_found := FALSE;
  /search_for_flags/
    WHILE NOT system_flag_found AND (xcb^.system_flags <> $tmt$system_flags []) DO

      IF (system_flag IN xcb^.system_flags) AND (tcb^.flag_execution_ring [system_flag] = caller.ring) THEN
        tmp$clear_system_flag (system_flag, flag_status);
        CASE flag_status OF
        = tmc$normal_flag_status =
          flag_id := system_flag;
          flag_handler := tmv$flag_handler_descriptions [system_flag].flag_handler;
          system_flag_found := TRUE;
        = tmc$flag_not_set =
          ;
        = tmc$invalid_flag_id =
          ;
        ELSE
        CASEND;
      ELSE
        IF (system_flag < (UPPERVALUE (ost$system_flag))) THEN
          system_flag := SUCC (system_flag);
        ELSE
          EXIT /search_for_flags/;
        IFEND;
      IFEND;
    WHILEND /search_for_flags/;
    flag_found := system_flag_found;

    i#restore_traps (trap_enables);
  PROCEND;
?? TITLE := '  [XDCL, #GATE] tmp$enable_preemptive_commo' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] tmp$enable_preemptive_commo;

*copyc TMH$ENABLE_PREEMPTIVE_COMMO

    VAR
      f: ost$system_flag,
      s: tmt$signal_buffers,
      tcb: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb);
    FOR f := LOWERVALUE (ost$system_flag) TO UPPERVALUE (ost$system_flag) DO
      tcb^.flag_execution_ring [f] := tmc$unallocated;
    FOREND;
    FOR s := LOWERVALUE (tmt$signal_buffers) TO UPPERVALUE (tmt$signal_buffers) DO
      tcb^.signal_execution_ring [s] := tmc$unallocated;
    FOREND;
    tcb^.task_local_signal_list.delink := NIL;
    tcb^.task_local_signal_list.link := ^tcb^.task_local_signal_list.delink;
    tmp$enable_preemptive;
  PROCEND;
MODEND tmm$manage_signals_and_flags;
*DECK DECK=TMM$MANAGE_SYSTEM_TASKS EXPAND=TRUE
MODULE tmm$manage_system_tasks;
?? RIGHT := 110 ??
{PURPOSE: This module contains three procedures to manage a system
{        task list.  This is list is used to find system tasks and
{        wake them up when needed.
{        TMP$MTR_READY_SYSTEM_TASK is the handler for the requests
{               from job mode to wake up or define a system task.
{        TMP$MONITOR_READY_SYSTEM_TASK is used to wake up a system task
{               from the system monitor.
{        TMP$UPDATE_SYSTEM_TASK_LIST is used to delete a system task from
{               the table when it terminates.


*copyc tmv$ptl_lock
*copyc tmp$clear_lock
*copyc tmp$set_lock
*copyc tmp$set_task_ready
?? PUSH (LISTEXT := ON) ??
*copyc syt$monitor_request_code
*copyc ost$execution_control_block
*copyc ost$cpu_state_table
*copyc tme$monitor_mode_exceptions
?? POP ??
*copyc tmt$rb_manage_system_tasks
*copyc tmt$system_task_id
*copyc mtp$cst_p
*copyc mtp$error_stop

  VAR
    tmv$system_task_ids: array [tmt$system_task_id] of ost$global_task_id := [[0, 0], [0, 0], [0, 0], [0, 0],
      [0, 0], [0, 0], [0, 0], [0, 0], [0, 0], [0, 0], [0, 0], [0, 0], [0, 0], [0, 0], [0, 0], [0, 0], [0, 0],
      [0, 0], [0, 0], [0, 0], [0, 0], [0, 0], [0, 0], [0, 0], [0, 0], [0, 0], [0, 0], [0, 0], [0, 0], [0, 0],
      [0, 0]],
    null_task_id: ost$global_task_id := [0, 0];

?? EJECT, TITLE := 'PROCEDURE tmp$mtr$ready_system_task' ??

  PROCEDURE [XDCL] tmp$mtr_ready_system_task (VAR rb: tmt$rb_manage_system_tasks);

*copyc tmhrmst

    VAR
      critical_task: boolean;


    IF rb.save_task_id THEN
      critical_task := (rb.stid = tmc$stid_job_scheduler) OR (rb.stid = tmc$stid_volume_space_managemnt) OR
         (rb.stid = tmc$stid_job_monitor);
      save_task_id (rb.stid, critical_task, rb.status);
    ELSE
      tmp$monitor_ready_system_task (rb.stid, rb.status);
    IFEND;
  PROCEND tmp$mtr_ready_system_task;
?? EJECT, TITLE := 'PROCEDURE tmp$monitor_ready_system_task' ??

  PROCEDURE [XDCL] tmp$monitor_ready_system_task (stid: tmt$system_task_id;
    VAR status: syt$monitor_status);


    tmp$set_lock (tmv$ptl_lock);
    IF tmv$system_task_ids [stid] = null_task_id THEN
      status.normal := FALSE;
      status.condition := tme$system_task_missing;
      tmp$clear_lock (tmv$ptl_lock);
      RETURN;
    IFEND;
    tmp$set_task_ready (tmv$system_task_ids [stid], 0 {readying_task_priority},
       tmc$rc_ready_conditional_wi);
    tmp$clear_lock (tmv$ptl_lock);
    status.normal := TRUE;
  PROCEND tmp$monitor_ready_system_task;

?? EJECT, TITLE := 'PROCEDURE tmp$update_system_task_list' ??

  PROCEDURE [XDCL] tmp$update_system_task_list (xcb_p: ^ost$execution_control_block);

    VAR
      stid: tmt$system_task_id;

    stid := xcb_p^.system_task_id;
    IF stid = tmc$stid_null_task THEN
      RETURN;
    IFEND;
    tmp$set_lock (tmv$ptl_lock);
    IF tmv$system_task_ids [stid] <> xcb_p^.global_task_id THEN
      tmp$clear_lock (tmv$ptl_lock);
      mtp$error_stop ('TM11 - system task list error');
    IFEND;
    IF xcb_p^.critical_task THEN
      tmp$clear_lock (tmv$ptl_lock);
      mtp$error_stop ('TM12 - illegal system task exit');
    IFEND;
    xcb_p^.system_task_id := tmc$stid_null_task;
    tmv$system_task_ids [stid] := null_task_id;
    tmp$clear_lock (tmv$ptl_lock);
  PROCEND tmp$update_system_task_list;

?? EJECT, TITLE := 'PROCEDURE save_task_id' ??

  PROCEDURE save_task_id (stid: tmt$system_task_id;
        critical_task: boolean;
    VAR status: syt$monitor_status);

    VAR
      cst_p: ^ost$cpu_state_table;

    mtp$cst_p (cst_p);
    IF cst_p^.xcb_p^.system_task_id <> tmc$stid_null_task THEN
      status.normal := FALSE;
      status.condition := tme$task_already_system_task;
      RETURN;
    IFEND;
    tmp$set_lock (tmv$ptl_lock);
    IF tmv$system_task_ids [stid] <> null_task_id THEN
      status.normal := FALSE;
      status.condition := tme$duplicate_system_task;
      tmp$clear_lock (tmv$ptl_lock);
      RETURN;
    IFEND;
    cst_p^.xcb_p^.system_task_id := stid;
    cst_p^.xcb_p^.critical_task := critical_task;
    tmv$system_task_ids [stid] := cst_p^.xcb_p^.global_task_id;
    tmp$clear_lock (tmv$ptl_lock);
    status.normal := TRUE;
  PROCEND save_task_id;

MODEND.
*DECK DECK=TMM$MTR_FLAG_SIGNAL_FUNCTIONS EXPAND=TRUE
?? RIGHT := 110, LEFT := 1 ??
MODULE tmm$mtr_flag_signal_functions;

{
{  PURPOSE:
{     This module processes flag and signal handling job mode monitor requests
{     and monitor mode requests.
{

?? SKIP := 2 ??
?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_map_offsets
*copyc mtc$job_fixed_segment
*copyc ost$rb_system_error
*copyc ost$wait
*copyc pme$hung_recipient_task
*copyc tme$monitor_mode_exceptions
*copyc tmk$monitor_mode_keypoints
*copyc tmt$broken_task_monitor_fault
*copyc tmt$mcr_faults
*copyc tmt$rb_ready_task
*copyc tmt$rb_send_signal
*copyc tmt$rb_set_system_flag
*copyc tmt$rb_wait
*copyc tmv$null_global_task_id
*copyc mtv$sys_core_init_complete
?? POP ??
?? SKIP := 2 ??
{  Define arbitrary constant that is used to check if there is enough space in SFSA of current
{  task to terminate it.

  CONST
    task_termination_stack_area = 30000;


{Define constants for recognizing hung tasks.

  VAR
    tmv$halt_on_hung_task: [XDCL, #GATE] boolean := FALSE,
    tmv$system_debug_ring: [XDCL, #GATE] integer := 0,
    tmv$system_debug_segment: [XDCL, #GATE] integer := 0,
    tmv$job_debug_ring_p: [XDCL, #GATE] ^ost$ring := NIL,
    tmv$system_error_hang_count: [XDCL, #GATE] 0 .. 0ffffffff(16) := 6;

{External procedures called by tmp$mtr_task_manager_functions.
?? SKIP := 1 ??
*copyc dpp$display_error
*copyc jmp$unlock_ajl
*copyc jmp$unlock_ajl_with_lock
*copyc tmp$delay
*copyc tmp$check_taskid
*copyc tmp$check_taskid_with_lock_set
*copyc tmp$set_task_ready
*copyc tmp$find_xcb
*copyc tmp$get_xcb_p
*copyc mmp$fetch_stack_segment_info
*copyc mtp$cst_p
*copyc mtp$error_stop
*copyc mtp$set_status_abnormal
*copyc mtp$step_unstep_system
?? SKIP := 2 ??
{External variables.

*copyc tmv$ptl_lock
*copyc jmv$ajl_p
*copyc jmv$system_ijl_ordinal
*copyc mtv$halt_cpu_ring_number
*copyc tmv$ptl_p
*copyc tmv$system_job_monitor_gtid
*copyc mtv$scb

?? EJECT ??
*copyc tmp$set_lock
*copyc tmp$clear_lock
?? EJECT ??

  PROCEDURE [XDCL] tmp$set_monitor_flag
    (    task_id {input} : ost$global_task_id;
         flag_id {input} : syt$monitor_flag;
     VAR status {output} : syt$monitor_status);


    VAR
      cst_p: ^ost$cpu_state_table;

    #KEYPOINT (osk$debug, osk$m * task_id.index, tmk$set_monitor_flag);

    status.normal := TRUE;
    mtp$cst_p (cst_p);

{  If it is the current task, set the free flag in UCR.

    tmp$set_lock (tmv$ptl_lock);

    tmp$check_taskid_with_lock_set (task_id, tmc$opt_return, status);
    IF NOT status.normal THEN
      tmp$clear_lock (tmv$ptl_lock);
      RETURN;
    IFEND;

    IF task_id = cst_p^.taskid THEN
      cst_p^.xcb_p^.xp.user_condition_register := cst_p^.xcb_p^.xp.
            user_condition_register + $ost$user_conditions [osc$free_flag];
      cst_p^.xcb_p^.monitor_flags := cst_p^.xcb_p^.monitor_flags + $syt$monitor_flags [flag_id];
      IF tmv$ptl_p^ [task_id.index].new_task_status < tmc$ts_first_ready_uncond THEN
        tmv$ptl_p^ [task_id.index].new_task_status := tmc$ts_null;
      IFEND;
      tmp$clear_lock (tmv$ptl_lock);
      RETURN;
    IFEND;

    IF flag_id IN tmv$ptl_p^ [task_id.index].monitor_flags THEN
      tmp$clear_lock (tmv$ptl_lock);
      RETURN;
    IFEND;

{ Set monitor flag in PTL.

    tmv$ptl_p^ [task_id.index].monitor_flags := tmv$ptl_p^ [task_id.index].
          monitor_flags + $syt$monitor_flags [flag_id];
    tmp$set_task_ready (task_id, 0 {readying_task_priority}, tmc$rc_ready_conditional);
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$set_monitor_flag;
?? EJECT ??

  PROCEDURE [XDCL] tmp$set_system_flag
    (    task_id {input} : ost$global_task_id;
         flag_id {input} : ost$system_flag;
     VAR status {output} : syt$monitor_status);

*copyc tmh$set_system_flag

    VAR
      cst_p: ^ost$cpu_state_table,
      ijle_p: ^jmt$initiated_job_list_entry,
      xcb_p: ^ost$execution_control_block;

    #KEYPOINT (osk$debug, osk$m * task_id.index, tmk$set_system_flag);

    status.normal := TRUE;
    mtp$cst_p (cst_p);

{  If it is the current task, set the free flag in UCR.

    tmp$set_lock (tmv$ptl_lock);

    tmp$check_taskid_with_lock_set (task_id, tmc$opt_return, status);
    IF NOT status.normal THEN
      tmp$clear_lock (tmv$ptl_lock);
      RETURN;
    IFEND;

    IF task_id = cst_p^.taskid THEN
      IF (cst_p^.xcb_p^.task_is_terminating) AND
        (flag_id <> mmc$failed_file_alloc_flag) THEN
        mtp$set_status_abnormal ('TM', tme$invalid_global_taskid, status);
      ELSE
        cst_p^.xcb_p^.xp.user_condition_register := cst_p^.xcb_p^.xp.
              user_condition_register + $ost$user_conditions [osc$free_flag];
        cst_p^.xcb_p^.system_flags := cst_p^.xcb_p^.system_flags + $tmt$system_flags [flag_id];
        cst_p^.xcb_p^.monitor_flags := cst_p^.xcb_p^.monitor_flags +
              $syt$monitor_flags [tmc$mf_cause_job_free_flag_trap];
        cst_p^.xcb_p^.wait_inhibited := TRUE;
        IF tmv$ptl_p^ [task_id.index].new_task_status < tmc$ts_first_ready_uncond THEN
          tmv$ptl_p^ [task_id.index].new_task_status := tmc$ts_null;
        IFEND;
      IFEND;
      tmp$clear_lock (tmv$ptl_lock);
      RETURN;
    IFEND;

    IF flag_id IN tmv$ptl_p^ [task_id.index].system_flags THEN
      tmp$clear_lock (tmv$ptl_lock);
      RETURN;
    IFEND;

    tmp$get_xcb_p (task_id, xcb_p, ijle_p);
    IF (xcb_p <> NIL) AND xcb_p^.task_is_terminating THEN
      status.normal := FALSE;
      status.condition := tme$invalid_global_taskid;
      jmp$unlock_ajl_with_lock (ijle_p);
      tmp$clear_lock (tmv$ptl_lock);
      RETURN;
    IFEND;
    IF (xcb_p <> NIL) THEN
      jmp$unlock_ajl_with_lock (ijle_p);
    IFEND;

{ Set system flag in PTL.

    tmv$ptl_p^ [task_id.index].system_flags := tmv$ptl_p^ [task_id.index].
          system_flags + $tmt$system_flags [flag_id];
    IF (tmv$ptl_p^ [task_id.index].ptl_flags.wait_inhibited <> tmc$wi_wait_selected_r3) THEN
      tmv$ptl_p^ [task_id.index].monitor_flags := tmv$ptl_p^ [task_id.index].
            monitor_flags + $syt$monitor_flags [tmc$mf_cause_job_free_flag_trap];
    IFEND;
    tmp$set_task_ready (task_id, 0 {readying_task_priority}, tmc$rc_ready_conditional_wi);
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$set_system_flag;
?? EJECT ??

  PROCEDURE [XDCL] tmp$flag_all_tasks
    (    flag_id {input} : ost$system_flag;
     VAR status {output} : syt$monitor_status);

*copyc tmh$flag_all_tasks

    VAR
      i: ost$task_index,
      task_id: ost$global_task_id,
      cst_p: ^ost$cpu_state_table;

    status.normal := TRUE;

    tmp$set_lock (tmv$ptl_lock);
    FOR i := 1 TO UPPERBOUND (tmv$ptl_p^) DO
      IF tmv$ptl_p^ [i].status <> tmc$ts_null THEN

        task_id.index := i;
        task_id.seqno := tmv$ptl_p^ [i].sequence_number;

{  If it is the current task, set the free flag in UCR.

        mtp$cst_p (cst_p);
        IF task_id = cst_p^.taskid THEN
          cst_p^.xcb_p^.xp.user_condition_register := cst_p^.xcb_p^.xp.
                user_condition_register + $ost$user_conditions [osc$free_flag];
          cst_p^.xcb_p^.system_flags := cst_p^.xcb_p^.system_flags + $tmt$system_flags [flag_id];
          cst_p^.xcb_p^.monitor_flags := cst_p^.xcb_p^.monitor_flags +
                $syt$monitor_flags [tmc$mf_cause_job_free_flag_trap];
          cst_p^.xcb_p^.wait_inhibited := TRUE;
          IF tmv$ptl_p^ [task_id.index].new_task_status < tmc$ts_first_ready_uncond THEN
            tmv$ptl_p^ [task_id.index].new_task_status := tmc$ts_null;
          IFEND;
        IFEND;

{ Set system flag in PTL.

        tmv$ptl_p^ [task_id.index].system_flags := tmv$ptl_p^ [task_id.index].
              system_flags + $tmt$system_flags [flag_id];
        IF (tmv$ptl_p^ [task_id.index].ptl_flags.wait_inhibited <> tmc$wi_wait_selected_r3) THEN
          tmv$ptl_p^ [task_id.index].monitor_flags := tmv$ptl_p^ [task_id.index].
                monitor_flags + $syt$monitor_flags [tmc$mf_cause_job_free_flag_trap];
        IFEND;
        tmp$set_task_ready (task_id, 0 {readying_task_priority}, tmc$rc_ready_conditional_wi);
      IFEND;
    FOREND;
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$flag_all_tasks;
?? EJECT ??

  PROCEDURE [XDCL] tmp$monitor_flag_job_tasks
    (    monitor_flag_id: syt$monitor_flag;
         ijle_p: ^jmt$initiated_job_list_entry);

    VAR
      taskid: ost$global_task_id,
      status: syt$monitor_status;

    tmp$set_lock (tmv$ptl_lock);
    taskid := ijle_p^.job_monitor_taskid;

    WHILE taskid.index <> 0 DO
      taskid.seqno := tmv$ptl_p^ [taskid.index].sequence_number;
      tmp$set_monitor_flag (taskid, monitor_flag_id, status);
      taskid.index := tmv$ptl_p^ [taskid.index].ijl_thread;
    WHILEND;

    tmp$clear_lock (tmv$ptl_lock);
  PROCEND tmp$monitor_flag_job_tasks;
?? EJECT ??

  PROCEDURE [XDCL] tmp$mtr_ready_task
    (VAR rb {input, output} : tmt$rb_ready_task);

*copyc tmh$mtr_ready_task
*copyc tmhrrt

    VAR
      readying_task_priority: jmt$dispatching_priority,
      cst_p: ^ost$cpu_state_table;

    tmp$set_lock (tmv$ptl_lock);
    tmp$check_taskid_with_lock_set (rb.task_id, tmc$opt_return, rb.status);
    IF rb.status.normal = FALSE THEN
      tmp$clear_lock (tmv$ptl_lock);
      RETURN;
    IFEND;

    mtp$cst_p (cst_p);

    IF cst_p^.xcb_p^.dispatching_priority >=
         tmv$ptl_p^ [cst_p^.xcb_p^.global_task_id.index].readying_task_priority THEN
      readying_task_priority := cst_p^.xcb_p^.dispatching_priority;
    ELSE
      readying_task_priority := tmv$ptl_p^ [cst_p^.xcb_p^.global_task_id.index].readying_task_priority;
    IFEND;

    tmp$set_task_ready (rb.task_id, readying_task_priority, tmc$rc_ready_conditional_wi);
    tmp$clear_lock (tmv$ptl_lock);

  PROCEND tmp$mtr_ready_task;
?? EJECT ??

  PROCEDURE [XDCL] tmp$send_signal
    (    task_id {input} : ost$global_task_id;
         signal {input} : pmt$signal;
     VAR status {output} : syt$monitor_status);

*copyc tmh$send_signal

    VAR
      cst_p: ^ost$cpu_state_table,
      i {signal array index} : 1 .. tmc$maximum_signals,
      ijle_p: ^jmt$initiated_job_list_entry,
      xcb_p: ^ost$execution_control_block;

    #KEYPOINT (osk$debug, osk$m * task_id.index, tmk$send_signal);

    tmp$find_xcb (task_id, xcb_p, ijle_p, status);
    IF status.normal = FALSE THEN
      RETURN;
    IFEND;

  /access_xcb/
    BEGIN
      IF xcb_p^.task_is_terminating THEN
        status.normal := FALSE;
        status.condition := tme$invalid_global_taskid;
        EXIT /access_xcb/;
      IFEND;

      IF xcb_p^.system_error_count >= tmv$system_error_hang_count THEN
        status.normal := FALSE;
        status.condition := pme$hung_recipient_task;
        EXIT /access_xcb/;
      IFEND;

    /find_free_signal_buffer/
      BEGIN

      /free_buffer_loop/
        FOR i := 1 TO tmc$maximum_signals DO
          IF xcb_p^.signals.reserved [i] = FALSE THEN
            EXIT /find_free_signal_buffer/;
          IFEND;
        FOREND /free_buffer_loop/;
        #KEYPOINT (osk$unusual, 0, tmk$signal_buffers_full);
        status.normal := FALSE;
        status.condition := tme$mtr_signal_buffers_full;
        EXIT /access_xcb/;
      END /find_free_signal_buffer/;

{  Place signal in free signal buffer.

      xcb_p^.signals.reserved [i] := TRUE;
      xcb_p^.signals.present [i] := TRUE;
      mtp$cst_p (cst_p);
      xcb_p^.signals.buffer [i].originator := cst_p^.taskid;
      xcb_p^.signals.buffer [i].signal := signal;

      IF tmv$ptl_p^ [task_id.index].ptl_flags.wait_inhibited <> tmc$wi_wait_selected_r3 THEN

{  Set task status to ready and set free flag in specified tasks user condition
{  register to invoke trap handler when the task gets the CPU.

        xcb_p^.wait_inhibited := TRUE;
        tmp$set_monitor_flag (task_id, tmc$mf_cause_job_free_flag_trap, status);
      ELSE
        tmp$set_task_ready (task_id, 0 {readying_task_priority}, tmc$rc_ready_conditional);
      IFEND;

    END /access_xcb/;

    jmp$unlock_ajl (ijle_p);

  PROCEND tmp$send_signal;
?? EJECT ??

  PROCEDURE [XDCL] tmp$mtr_set_system_flag
    (VAR rb {input, output} : tmt$rb_set_system_flag);

*copyc tmh$mtr_set_system_flag
*copyc tmhrssf

    tmp$set_system_flag (rb.task_id, rb.flag_id, rb.status);

  PROCEND tmp$mtr_set_system_flag;
?? EJECT ??

  PROCEDURE [XDCL] tmp$mtr_send_signal
    (VAR rb {input,output} : tmt$rb_send_signal);

*copyc tmh$mtr_send_signal

    tmp$send_signal (rb.task_id, rb.signal, rb.status);

  PROCEND tmp$mtr_send_signal;

?? EJECT ??

  PROCEDURE [XDCL] tmp$process_task_mcr_fault;

{      Purpose:
{        This procedure is called by the monitor interrupt processor to process
{        an MCR fault from a task if the MCR fault was selected by the task
{        to be processed in job mode.

    VAR
      cst_p: ^ost$cpu_state_table,
      fault: ost$monitor_fault,
      mcr_fault_p: ^tmt$mcr_faults,
      xcb_p: ^ost$execution_control_block,
      zero_pva: [STATIC] ost$pva := [0, 0, 0];


{Copy the fault information for the task's XCB to the signal record.

    mtp$cst_p (cst_p);
    xcb_p := cst_p^.xcb_p;
    #KEYPOINT (osk$debug, xcb_p^.global_task_id.index * osk$m, tmk$process_task_mcr_fault);
    fault.identifier := tmc$mcr_fault;
    mcr_fault_p := #LOC (fault.contents);
    mcr_fault_p^.faults := xcb_p^.xp.monitor_condition_register;
    mcr_fault_p^.untranslatable_pointer := xcb_p^.xp.untranslatable_pointer;


{Send the Monitor Fault to the task.

    send_monitor_fault (xcb_p, ^fault, 'Job mode MCR fault', TRUE);


{Reset the XCB. Clear the UTP and MCR.

    xcb_p^.xp.untranslatable_pointer := zero_pva;

  PROCEND tmp$process_task_mcr_fault;

?? EJECT ??

  PROCEDURE [XDCL] tmp$process_unknown_req_fault;

*copyc tmh$process_unknown_req_fault

    VAR
      cst_p: ^ost$cpu_state_table,
      fault: ost$monitor_fault,
      xcb_p: ^ost$execution_control_block;

{  Set up the fault information in the signal block.

    mtp$cst_p (cst_p);
    xcb_p := cst_p^.xcb_p;
    fault.identifier := tmc$unknown_system_req_fault;

{  Send the monitor fault to the task.

    send_monitor_fault (xcb_p, ^fault, 'invalid monitor request', TRUE);

  PROCEND tmp$process_unknown_req_fault;

?? EJECT ??
{
{PROCEDURE tmp$send_monitor_fault;
{  PURPOSE:
{    The purpose of this procedure is to place a monitor fault in the
{    monitor fault buffer of the specified task.
{  NOTE:
{    The first monitor fault buffer is reserved for 'broken_task_monitor_fault'.
{    this procedure will start with the second monitor fault buffer when
{    searching for a free buffer.
{
??FMT(FORMAT:=ON)??

  PROCEDURE [XDCL] tmp$send_monitor_fault
    (    task_id {input} : ost$global_task_id;
         monitor_fault_p {input} : ^ost$monitor_fault;
         check_traps_enabled {input} : boolean);

    VAR
      ijle_p: ^jmt$initiated_job_list_entry,
      xcb_p: ^ost$execution_control_block;

    tmp$get_xcb_p (task_id, xcb_p, ijle_p);
    send_monitor_fault (xcb_p, monitor_fault_p, 'monitor fault', check_traps_enabled);
    jmp$unlock_ajl (ijle_p);

  PROCEND tmp$send_monitor_fault;
?? EJECT ??

  PROCEDURE [XDCL] tmp$mtr_process_system_error
    (    rb: ost$rb_system_error);

*copyc oshrser

    VAR
      cst_p: ^ost$cpu_state_table,
      fault: ost$monitor_fault,
      error_message: string (80),
      broken_task_fault_p: ^tmt$broken_task_monitor_fault;

    mtp$cst_p (cst_p);

    IF NOT mtv$sys_core_init_complete OR (cst_p^.xcb_p^.xp.p_register.pva.ring = 1) AND rb.fatal THEN
      error_message (1,10) := 'VEOS1100- ';
      error_message (11,*) := rb.text;
      mtp$step_unstep_system (syc$ic_fatal_software_error, error_message(1,72));
    IFEND;

    fault.identifier := tmc$broken_task_fault_id;
    broken_task_fault_p := #LOC (fault.contents);
    broken_task_fault_p^.broken_task_condition := tmc$btc_system_error;
    broken_task_fault_p^.trap_enable := cst_p^.xcb_p^.xp.trap_enable;
    broken_task_fault_p^.status_p := rb.status_p;
    broken_task_fault_p^.text_p := rb.text_p;
    broken_task_fault_p^.caller_p_register := rb.caller_p_register;
    error_message (1, *) := rb.text;

    send_monitor_fault (cst_p^.xcb_p, ^fault, error_message, TRUE);


  PROCEND tmp$mtr_process_system_error;
?? EJECT ??

  PROCEDURE send_monitor_fault
    (    xcb_p {input} : ^ost$execution_control_block;
         monitor_fault_p {input} : ^ost$monitor_fault;
         mtr_flt_message {input} : string ( * ),
         check_traps_enabled {input} : boolean);

{
{  PURPOSE:
{    The purpose of this procedure is to place the monitor fault into free
{    monitor fault buffer of specified task.  The free flag is set to preempt
{    specified task execution and process the monitor fault next time task executes.
{
{  NOTE:
{    The first monitor fault buffer is reserved for sending monitor fault to
{    task to inform it that it is considered a broken task.  This is to ensure
{    that a buffer full condition will never occur when a task is broken.
{    It is assumed the specified task is in ready status.
{
{    If broken task processing aborts (in job mode), we will hang the task
{    unless it is a critical task or has system tables locked, in which case
{    we will halt the system.  We will not recurse back through here.
{
{    If a task is broken tmv$system_error_hang_count different times it
{    will be considered a hung task.  It will be processed as if broken
{    task processing had aborted.  (See above.)
{

    VAR
      cst_p: ^ost$cpu_state_table,
      i: 1 .. tmc$maximum_monitor_faults + 1,
      fault_contents_p: ^tmt$broken_task_monitor_fault,
      broken_task: boolean,
      fault: ost$monitor_fault,
      halt_message: string (72),
      jdr_p: ^ost$ring,
      status: syt$monitor_status;

    #KEYPOINT (osk$debug, xcb_p^.global_task_id.index * osk$m, tmk$send_monitor_fault);
    mtp$cst_p (cst_p);

    IF NOT mtv$sys_core_init_complete OR (xcb_p^.global_task_id = tmv$system_job_monitor_gtid) THEN
      halt_message (1,10) := 'VEOS1100- ';
      halt_message (11,*) := mtr_flt_message;
      mtp$step_unstep_system (syc$ic_fatal_software_error, halt_message(1,72));
    IFEND;

    IF ((xcb_p^.xp.p_register.pva.ring <= mtv$halt_cpu_ring_number) OR
          (xcb_p^.xp.p_register.pva.ring <= mtv$system_haltring) AND
          (tmv$ptl_p^[xcb_p^.global_task_id.index].ijl_ordinal = jmv$system_ijl_ordinal)) AND
          (check_traps_enabled) THEN
      halt_message (1,10) := 'VEOS9920- ';
      halt_message (11, * ) := mtr_flt_message;
      dpp$display_error('Software Err below Halt Ring, initiating Software Breakpoint');
      mtv$scb.nos_180_status.system_status.step_status_block.requested_status := mtc$stepped_system;
      mtp$step_unstep_system (syc$ic_software_breakpoint, halt_message);
    IFEND;

{  Set up the broken task fault.

    fault.identifier := tmc$broken_task_fault_id;
    fault.pva := xcb_p^.xp.p_register.pva;
    fault.a0 := xcb_p^.xp.a0_dynamic_space_pointer;
    fault.a1 := xcb_p^.xp.a1_current_stack_frame;
    fault.a2 := xcb_p^.xp.a2_previous_save_area;
    fault_contents_p := #LOC (fault.contents);
    fault_contents_p^.p := xcb_p^.xp.p_register;
    fault_contents_p^.a0 := xcb_p^.xp.a0_dynamic_space_pointer;
    fault_contents_p^.trap_enable := xcb_p^.xp.trap_enable;
    fault_contents_p^.monitor_condition_register := xcb_p^.xp.monitor_condition_register;
    fault_contents_p^.user_condition_register := xcb_p^.xp.user_condition_register;
    fault_contents_p^.monitor_fault_id := monitor_fault_p^.identifier;

    check_repair_trap_mechanism (xcb_p, check_traps_enabled, broken_task, fault_contents_p^.
          broken_task_condition);

    i := 2;
    WHILE (i <= tmc$maximum_monitor_faults) AND (xcb_p^.monitor_faults.present [i]) DO
      i := i + 1;
    WHILEND;

    IF i <= tmc$maximum_monitor_faults THEN
      xcb_p^.monitor_faults.buffer [i] := monitor_fault_p^;
      xcb_p^.monitor_faults.buffer [i].pva := xcb_p^.xp.p_register.pva;
      xcb_p^.monitor_faults.buffer [i].a0 := xcb_p^.xp.a0_dynamic_space_pointer;
      xcb_p^.monitor_faults.buffer [i].a1 := xcb_p^.xp.a1_current_stack_frame;
      xcb_p^.monitor_faults.buffer [i].a2 := xcb_p^.xp.a2_previous_save_area;
      xcb_p^.monitor_faults.present [i] := TRUE;
    ELSE
      IF broken_task = FALSE THEN
        broken_task := TRUE;
        fault_contents_p^.broken_task_condition := tmc$btc_mntr_fault_buffer_full;
        xcb_p^.xp.trap_enable := osc$traps_enabled;
      IFEND;
    IFEND;

    IF broken_task OR (monitor_fault_p^.identifier = tmc$broken_task_fault_id) THEN

      xcb_p^.system_error_count := xcb_p^.system_error_count + 1;

      IF xcb_p^.system_error_count > (tmv$system_error_hang_count + 4) THEN
        dpp$display_error('Broken Task, System Error Count exceeds limit; Terminating System');
        halt_message (1,10) := 'VEOS2020- ';
        halt_message (11,*) := mtr_flt_message;
        mtp$step_unstep_system (syc$ic_fatal_software_error,halt_message);

      ELSEIF (xcb_p^.system_error_count = tmv$system_error_hang_count) OR
             (xcb_p^.monitor_faults.present [1]) THEN

{  HUNG TASK

        IF (xcb_p^.system_table_lock_count >= 256) OR (xcb_p^.critical_task) THEN
          halt_message (1,10) := 'VEOS2010- ';
          halt_message (11,*) := mtr_flt_message;
          mtp$step_unstep_system (syc$ic_fatal_software_error,halt_message);
        ELSE
          IF tmv$halt_on_hung_task THEN
            mtv$scb.nos_180_status.system_status.step_status_block.requested_status := mtc$stepped_system;
            halt_message (1,10) := 'VEOS9910- ';
            halt_message (11,*) := mtr_flt_message;
            dpp$display_error ('Task hung, initiating software breakpoint');
            mtp$step_unstep_system (syc$ic_software_breakpoint,halt_message);
          IFEND;
          tmp$set_monitor_flag (xcb_p^.global_task_id, syc$mf_hang_task, status);
          cst_p^.ijle_p^.hung_task_in_job := TRUE;
        IFEND;

      IFEND;
    IFEND;

    IF broken_task AND (xcb_p^.monitor_faults.present [1] = FALSE) THEN
      xcb_p^.monitor_faults.buffer [1] := fault;
      xcb_p^.monitor_faults.present [1] := TRUE;
    IFEND;

    tmp$set_monitor_flag (xcb_p^.global_task_id, tmc$mf_cause_job_free_flag_trap, status);
    IF xcb_p^.xp.p_register.pva.ring <= tmv$system_debug_ring THEN
      IF (tmv$system_debug_segment = 0) OR (xcb_p^.xp.p_register.pva.seg <= tmv$system_debug_segment) THEN
        tmp$set_monitor_flag (xcb_p^.global_task_id, syc$mf_invoke_sysdebug, status);
      IFEND;
    ELSE
      IF tmv$job_debug_ring_p <> NIL THEN
        jdr_p := #address (1, #segment (xcb_p), #offset (tmv$job_debug_ring_p));
        IF xcb_p^.xp.p_register.pva.ring <= jdr_p^ THEN
          tmp$set_monitor_flag (xcb_p^.global_task_id, syc$mf_invoke_sysdebug, status);
        IFEND;
      IFEND;
    IFEND;

  PROCEND send_monitor_fault;
?? EJECT ??

  PROCEDURE check_repair_trap_mechanism
    (    xcb_p: ^ost$execution_control_block;
         check_traps_enabled: boolean;
     VAR broken: boolean;
     VAR fault_id: tmt$broken_task_condition);

    VAR
      found: boolean,
      stack_segnum: ost$segment,
      stack_length: ost$segment_length,
      status: syt$monitor_status;

    broken := FALSE;


{  Make sure that traps are enabled.

    IF (check_traps_enabled = TRUE) AND (xcb_p^.xp.trap_enable <> osc$traps_enabled) THEN
      broken := TRUE;
      fault_id := tmc$btc_mf_traps_disabled;
      xcb_p^.xp.trap_enable := osc$traps_enabled;
    IFEND;


{Validate A0.

    mmp$fetch_stack_segment_info (xcb_p, xcb_p^.xp.p_register.pva.ring, { set_length_to_zero } FALSE,
           stack_segnum, stack_length, found);
    IF NOT found THEN
      mtp$error_stop ('BTC - lost the stack segment');
    IFEND;
    IF (#RING (xcb_p^.xp.a0_dynamic_space_pointer) <> xcb_p^.xp.p_register.pva.ring) OR
          (#SEGMENT (xcb_p^.xp.a0_dynamic_space_pointer) <> stack_segnum) OR
          (#OFFSET (xcb_p^.xp.a0_dynamic_space_pointer) < 0) OR
          (#OFFSET (xcb_p^.xp.a0_dynamic_space_pointer) + 37 * 8 > stack_length) THEN
      broken := TRUE;
      fault_id := tmc$btc_invalid_a0;
      xcb_p^.xp.a0_dynamic_space_pointer := #ADDRESS (xcb_p^.xp.p_register.pva.ring, stack_segnum,
           mmc$ring_crossing_offset);
      xcb_p^.xp.a2_previous_save_area := NIL;
      mmp$fetch_stack_segment_info (xcb_p, xcb_p^.xp.p_register.pva.ring, { set_length_to_zero } TRUE,
             stack_segnum, stack_length, found);
    IFEND;


  PROCEND check_repair_trap_mechanism;
MODEND tmm$mtr_flag_signal_functions;
*DECK DECK=TMM$RING1_HELPER EXPAND=TRUE
?? RIGHT := 110 ??
*copyc OSD$DEFAULT_PRAGMATS
{  MODULE: TMM$RING1_HELPER.
{
{  This module contains
{       TMP$FETCH_JOB_STATISTICS.
{
?? EJECT ??
MODULE tmm$ring1_helper;
?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_statistics
*copyc jmt$dispatching_priority
*copyc OST$STATUS
?? POP ??
*copyc pmp$find_executing_task_xcb
*copyc JMV$JCB
*copyc JMV$IJL_P
?? EJECT ??

  PROCEDURE [XDCL, #GATE] tmp$fetch_job_statistics (VAR statistics: jmt$job_statistics;
    VAR status: ost$status);

*copyc TMH$FETCH_JOB_STATISTICS


    status.normal := TRUE;

    statistics.cp_time := jmv$jcb.ijle_p^.statistics.cp_time;

{   The working set size must be captured before the paging statistics because it is possible
{   for a page fault to occur, either for this task or an asynchronous task, and the maximum
{   working set could end up less than the current working set.

    statistics.working_set_size := jmv$jcb.ijle_p^.job_page_queue_list [mmc$pq_job_working_set].count;
    statistics.paging_statistics := jmv$jcb.ijle_p^.statistics.paging_statistics;
    statistics.ready_task_count := jmv$jcb.ijle_p^.statistics.ready_task_count;
    jmv$jcb.ijle_p^.statistics.paging_statistics.incremental_max_ws := statistics.working_set_size;

  PROCEND tmp$fetch_job_statistics;
?? EJECT ??

  PROCEDURE [XDCL, #GATE] tmp$set_flag_interval (interval: 0 .. 0ffffffff(16));

*copyc TMH$SET_FLAG_INTERVAL

    jmv$jcb.signal_interval := interval;

  PROCEND tmp$set_flag_interval;

?? TITLE := 'TMP$SET_TASK_PRIORITY', EJECT ??
{-------------------------------------------------------------------------------------------
{
{ This procedure is used to change the priority of the executing task.
{ Input parameters are:
{    dispatching_priority - If this parameter is non-zero, it specifies the absolute
{                   priority for the task.
{    dispatching_priority_bias -  If dispatching_priority is not specified, this parameter specifies
{                   a bias to be applied to the job priority to give the task priority
{-------------------------------------------------------------------------------------------


  PROCEDURE [XDCL, #GATE] tmp$set_task_priority (dispatching_priority: jmt$dispatching_priority;
        dispatching_priority_bias: jmt$dispatching_priority_bias;
    VAR status: ost$status);

    VAR
      xcb_p: ^ost$execution_control_block,
      priority: integer;

        pmp$find_executing_task_xcb (xcb_p);
        IF dispatching_priority = 0 THEN
          IF dispatching_priority_bias >= 0 THEN
            xcb_p^.dispatching_priority_bias_id := jmc$dpb_positive;
            xcb_p^.dispatching_priority_bias := dispatching_priority_bias;
            priority := jmv$jcb.ijle_p^.dispatching_control.dispatching_priority + dispatching_priority_bias;
          ELSE
            xcb_p^.dispatching_priority_bias_id := jmc$dpb_negative;
            xcb_p^.dispatching_priority_bias := - dispatching_priority_bias;
            priority := jmv$jcb.ijle_p^.dispatching_control.dispatching_priority - dispatching_priority_bias;
          IFEND;
        ELSE
          priority := dispatching_priority;
          xcb_p^.dispatching_priority_bias_id := jmc$dpb_absolute;
        IFEND;

        IF priority > jmc$max_dispatching_priority THEN
          priority := jmc$max_dispatching_priority;
        ELSEIF priority < jmc$min_dispatching_priority THEN
          priority := jmc$min_dispatching_priority;
        IFEND;

        xcb_p^.dispatching_priority := priority;

  PROCEND tmp$set_task_priority;

MODEND tmm$ring1_helper;
*DECK DECK=TMM$SYSTEM_REQ_FAULT_PROCESSOR EXPAND=TRUE
?? LEFT := 1, RIGHT := 110 ??
?? FMT (FORMAT := ON, keyw := upper, ident := lower) ??
?? NEWTITLE := 'NOS/VE: Program Control - Program Conditions' ??
?? NEWTITLE := '  Global System Declarations' ??
MODULE tmm$system_req_fault_processor;
{   PURPOSE:
{     This module contains and restricts the knowledge necessary to dispose
{     of the system request monitor fault.

{   DESIGN:
{     The procedure in this module are designed to have an execute bracket
{     of 2, 13 and a call bracket of 13.
?? EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc OST$STACK_FRAME_SAVE_AREA
?? POP ??
?? TITLE := '  Global External Procedures' ??
?? EJECT ??


*copyc PMH$EXIT
*copyc PMP$EXIT
*copyc OSH$SET_STATUS_ABNORMAL
*copyc OSP$SET_STATUS_ABNORMAL
*copyc OSP$APPEND_STATUS_INTEGER

*copyc OSP$SYSTEM_ERROR
*copyc CLP$CONVERT_INTEGER_TO_RJSTRING
?? TITLE := '  Internal Declarations' ??
?? EJECT ??
*copyc OST$MONITOR_FAULT
*copyc PME$SYSTEM_EXCEPTIONS
?? TITLE := '  [XDCL] tmp$dispose_system_req_fault' ??
?? EJECT ??


  PROCEDURE [XDCL] tmp$dispose_system_req_fault (fault: ost$monitor_fault;
        sfsa: ^ost$stack_frame_save_area);

*copy TMH$DISPOSE_SYSTEM_REQ_FAULT

    VAR
      executing_ring: ost$ring,
      status: ost$status;

    osp$set_status_abnormal (pmc$program_management_id, pme$unknown_system_request, '', status);
    osp$append_status_integer (osc$status_parameter_delimiter, sfsa^.minimum_save_area.p_register.pva.ring,
          16, FALSE, status);
    osp$append_status_integer (' ', sfsa^.minimum_save_area.p_register.pva.seg, 16, FALSE, status);
    osp$append_status_integer (' ', sfsa^.minimum_save_area.p_register.pva.offset, 16, FALSE, status);

    CASE #ring (^executing_ring) OF
    = osc$os_ring_1 =
      osp$system_error ('R1 unknown monitor request', ^status);
    = osc$tmtr_ring =
      osp$system_error ('R2 unknown monitor request', ^status);
    = osc$tsrv_ring .. osc$user_ring_4 =
      pmp$exit (status);
    CASEND;
  PROCEND tmp$dispose_system_req_fault;
MODEND tmm$system_req_fault_processor;
*DECK DECK=TMM$SYSTEM_TASK_MANAGER_R3 EXPAND=TRUE
MODULE tmm$system_task_manager_r3;
?? RIGHT := 110 ??

{PURPOSE: This module contains two procedures used to define and ready
{        system tasks.  Using this interface a system task can be made
{        ready-ed by a task in another job which need the system task
{        to process a request.  This method may use much fewer system
{        resources than polling.
{        TMP$READY_SYSTEM_TASK is the handler which a task would use to
{               wake up a task it has made a request to.
{        TMP$SAVE_SYSTEM_TASK_ID is the handler used by a system task to
{               identify the task to the system.


?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*copyc TME$MONITOR_MODE_EXCEPTIONS
?? POP ??

*copyc TMT$RB_MANAGE_SYSTEM_TASKS
*copyc I#CALL_MONITOR
*copyc PMP$GET_EXECUTING_TASK_GTID
*copyc OSP$SET_STATUS_ABNORMAL
*copyc JMV$JCB
*copyc jmv$system_ajl_ordinal
?? EJECT, TITLE := 'PROCEDURE tmp$save_system_task_id' ??

    PROCEDURE [XDCL, #GATE] tmp$save_system_task_id (stid: tmt$system_task_id;
          critical_task: boolean;
      VAR status: ost$status);

      VAR
        system_job: boolean,
        request_block: tmt$rb_manage_system_tasks,
        id: ost$global_task_id;

      system_job := jmv$jcb.ijle_p^.ajl_ordinal = jmv$system_ajl_ordinal;
      pmp$get_executing_task_gtid (id);

      status.normal := TRUE;

      IF system_job THEN
        request_block.reqcode := syc$rc_manage_system_tasks;
        request_block.stid := stid;
        request_block.critical_task := critical_task;
        request_block.save_task_id := TRUE;
        i#call_monitor (#LOC (request_block), #SIZE (request_block));
        IF NOT request_block.status.normal THEN
          osp$set_status_abnormal ('TM', request_block.status.condition, '', status);
        IFEND;
      ELSE
        osp$set_status_abnormal ('TM', tme$invalid_system_task, '', status);
      IFEND;
    PROCEND tmp$save_system_task_id;

?? EJECT, TITLE := 'PROCEDURE tmp$ready_system_task' ??

    PROCEDURE [XDCL, #GATE] tmp$ready_system_task (stid: tmt$system_task_id;
      VAR status: ost$status);

      VAR
        request_block: tmt$rb_manage_system_tasks;

      status.normal := TRUE;
      request_block.reqcode := syc$rc_manage_system_tasks;
      request_block.stid := stid;
      request_block.save_task_id := FALSE;
      i#call_monitor (#LOC (request_block), #SIZE (request_block));
      IF NOT request_block.status.normal THEN
        osp$set_status_abnormal ('TM', request_block.status.condition, '', status);
      IFEND;
    PROCEND tmp$ready_system_task;

MODEND tmm$system_task_manager_r3;

*DECK DECK=TMM$TASK_SWITCH EXPAND=TRUE
tmm$task_switch             ident
.
..........................................................................................
.
.           This assembly language module contains dispatcher procedures
.           which are written in assembly language to be more efficient.
.           This module contains the following:
.               tmp$select_next_task
.
.........................................................................................
.
.
.  common decks used (not listed here)
.     sya$constants, sya$cybil_interface_procedures, osa$basic_register_equates,
.     sya$xp_and_sf_constants
          list,0   0,0,0
*copyc mta$cpu_state_table
*copyc tma$task_switch
*copy OSA$BASIC_REGISTER_EQUATES
*copy SYA$CONSTANTS
*copy SYA$CYBIL_INTERFACE_PROCEDURES
*copyc sya$xp_and_sf_constants
          list,0   1,2,1
.
.
........................................................................................
.  Define A and X registers.
........................................................................................
.  Register equates used for ploada and pstorxp macros.
.
.
amacscr  equ       15                       .scratch a reg used by macros
amacscr  atrib     #regtyp,#areg
.
.
a_cstp    areg     6                        .Pointer to the CPU state table.
a_dct     areg     7                        .Pointer to the Dispatch Control Table.
a_ptl     areg     8                        .Pointer to the Primary Task List.
a_ijlroot areg     9                        .Pointer to the IJL.
a_ijle    areg     10                       .Pointer to an ijl entry.
a_xcbp    areg     11                       .Pointer to the XCB.
a_jcbp    areg     12                       .Pointer to the JCB.
.                                           .X0 through X3 are scratch registers.
x4_zero   xreg     4                        .X4 will contain the constant 0.
x_lsets   xreg     5                        .Copy of dispatching control sets.
x_ptlo    xreg     6                        .PTL ordinal selected.
x_rset    xreg     7                        .Dispatch control sets converted to a real.
x_prio    xreg     8                        .Dispatching priority selected.
x_ijlo    xreg     9                        .Ijlo of task selected.
x_ajlo    xreg     10                       .Ajlo of task selected.
x_xcboff  xreg     11                       .Offset of the xcb.
x_ptloff  xreg     12                       .Offset of the ptl entry.
x_ijlsize xreg     13                       .Size of an ijl entry.
x_cpus_m1 xreg     14                       .Cpus logically on, minus 1.
x_csti    xreg     15                       .Cst index.
.
.
          page
.........................................................................................
.
.  Define constants
.........................................................................................
.
.
.
........................................................................................
.  Define Binding Section..
........................................................................................
.
          use      binding
          ref      dc_sets
          ref      dct
          ref      cpus_on
          ref      ptl_p
          ref      ijl_p
          ref      ijlsize
dc_sets   alias    tmv$dispatching_control_sets
dct       alias    tmv$dct
cpus_on   alias    osv$cpus_logically_on
ptl_p     alias    tmv$ptl_p
ijl_p     alias    jmv$ijl_p
ijlsize   alias    jmv$ijle_size
bs_sets   address  p,dc_sets                .Pointer to dispatching control sets.
bs_dct    address  p,dct                    .Pointer to the dct.
bs_cpus   address  p,cpus_on                .Pointer to cpus logically on.
bs_ptl    address  p,ptl_p                  .Pointer to the ptl.
bs_ijlr   address  p,ijl_p                  .Pointer to the ijl.
bs_ijlsz  address  p,ijlsize                .Pointer to the size of an ijl entry.
.
.
........................................................................................
.
.  This procedure is used in monitor to select a new task for CPU execution.
.
.    TMP$SELECT_NEXT_TASK (CST_P, PTLO);
.
.    CST_P: (input) This parameter specifies the pointer to the CPU state table
.         for the CPU that a new task is being selected for.
.    PTLO: (output) This parameter returns the PTL ordinal of the task selected
.         to execute.
.
.
.      PROCEDURE [XREF] tmp$select_next_task
.        (    cst_p: ^ost$cpu_state_table;
.         VAR ptlo: ost$task_index);
.
.
.
.     NOTES:
.        Document procedure
.
.
.
........................................................................................
.
          use      code
          def      sel_task
sel_task  alias    tmp$select_next_task
sel_task  procedur
cst_p     param    val,pointer
ptlo      param    ref,subrange,2
.
.
          la       af,a_bindin,bs_sets      .Load a copy of DISPATCHING_CONTROL_SETS
          entp     x4_zero,0                .Initialize X4 to zero
          entp     x_ptlo,0                 .Initialize ptlo to zero.
          lx       x_lsets,af,head          .Load DISPATCHING_CONTROL_SETS, cont.
.
          shfx     x1,x_lsets,x0,-16        .Reorder the dispatching control sets.
          shfx     x2,x_lsets,x0,-48        .Mask out prios which have exceeded max.
          inhx     x1,x2                    .Determine which need minimums satisfied.
.                                           .X1 now has ready tasks to be considered.
          insb     x_lsets,x4_zero,x0,17(8) .Mask out enforce maximums.
          shfx     x2,x_lsets,x0,-32        .Pick up minimums to satisfy.
          andx     x2,x1                    .Multiply minimums by ready tasks.
          insb     x_lsets,x2,x0,2017(8)    .Store minimums back into the sets.
.
          cpyxx    x3,x_lsets               .Pick up maximums exceeded.
          andx     x3,x1                    .Multiply max exceeded by ready tasks.
          insb     x_lsets,x3,x0,6017(8)    .Put maximums exceeded back in the sets.
.
          iorx     x2,x3                    .Mask mins and maxs out of ready tasks so
          xorx     x1,x2                    .no duplicate are priorities in the sets.
.
          insb     x_lsets,x1,x0,4017(8)    .Put the ready tasks back into the sets.
.
          brxeq    x_lsets,x0,quit          .If there are no priorities set, return.
.
          ploada   a_cstp,cst_p             .Load the CST_P (input parameter).
          la       ae,a_bindin,bs_cpus      .Load osv$cpus_logically_on.
          la       a_ptl,a_bindin,bs_ptl    .Load the PTL pointer.
          la       a_ijlroot,a_bindin,bs_ijlr      .Load the IJL pointer.
          la       af,a_bindin,bs_ijlsz     .Load the ijl entry size.
          la       a_dct,a_bindin,bs_dct    .Load the DCT pointer.
          lbyts,1  x_csti,a_cstp,x0,lpid    .Load the cst index.
          lbyts,1  x_cpus_m1,ae,x0,head     .CPUS on, cont.
          la       a_ptl,a_ptl,0            .PTL pointer, cont.
          la       a_ijlroot,a_ijlroot,0    .IJL pointer, cont.
          lbyts,2  x_ijlsize,af,x0,head     .Ijl entry size, cont.
          decr     x_cpus_m1,1              .Subtract 1 from cpus on.
          brxeq    x0,x0,prio_loop          .Jump to select the first prio set.
.
new_prio  shfx     x_rset,x_rset,x0,-48     .Manipulate the real to pull off the bit
          shfx     x_rset,x_rset,x0,6       .number of the priority already
          notx     x_rset,x_rset            .considered so that it can be removed
          isom     x_rset,x_rset,1          .from the sets.
          inhx     x_lsets,x_rset
          brxeq    x_lsets,x0,quit          .Quit if no prio is still set.
.
prio_loop cnif     x_rset,x_lsets           .Convert the dispatch sets to an integer.
          isob     x_prio,x_rset,x0,1403(8) .The first bit in the set is the prio.
.
          shfx     x_prio,x_prio,x0,3       .Multiply prio by 8 to get dcte offset.
          lbyts,2  x_ptlo,a_dct,x_prio,head .Get the head of the dct entry.
          brxne    x_ptlo,x0,ptlo_loop      .If ptlo is 0, halt.
          halt
.
next_ptlo lbyts,2  x_ptlo,a_ptl,x_ptloff,thread    .Get the next task in the DCT.
          brxeq    x_ptlo,x0,new_prio       .While ptlo is not 0, loop.  If ptlo
.                                           .is zero, try a new priority.
.
.                                           .Verify the task can execute.
ptlo_loop shfx     x_ptloff,x_ptlo,x0,ptlshf       .Offset into the PTL of task selected.
          lbyts,2  x_ijlo,a_ptl,x_ptloff,ptl_ijlo  .Get the ijlo of the task.
.                                           .Get a pointer to the ijl entry.
          shfx     x1,x_ijlo,x0,-5          .Isolate the ijl block number.
          lxi      x1,a_ijlroot,x1,0        .Get the pointer to the ijl block.
          cpyxa    a_ijle,x1
          isob     x1,x_ijlo,x0,7304(8)     .Isolate the ijl block index.
          mulx     x1,x_ijlsize             .Determine the offset into the block.
          addax    a_ijle,x1                .Pointer to the ijl entry.
.
          lbyts,1  x_ajlo,a_ijle,x0,ijl_ajlo       .Pick up the ajlo of the task.
          lbyts,4  x2,a_ptl,x_ptloff,xcboff .Load the xcb offset from the ptle to
.                                           .to use for generating an xcb pointer.
.                                           .Generate a JCB pointer.
          ente     x1,1014(16)              .Set up ring, base seg#.
          addx     x1,x_ajlo                .Increase seg# by ajlo.
          shfx     x1,x1,x0,32              .Shift the ring, seg#; offset is 0.
          cpyxa    a_jcbp,x1                .Copy the JCB pointer.
.                                           .Generate an xcb pointer.
          addx     x1,x2                    .Add the xcb offset into the pointer.
          cpyxa    a_xcbp,x1                .Copy the XCB pointer.
.
.                                           .If the task can execute, exit.
.                                           .Otherwise consider another task.
          brxeq    x_cpus_m1,x0,save_cst    .If only one CPU, the task can execute.
.
          lbyts,1  x2,a_xcbp,x0,p_select    .Load the xcb processor_selections.
          shfx     x2,x2,x_csti,58          .Shift the bit to the left.
          brxge    x2,x0,next_ptlo          .If zero, the csti is not in the set.
.
          lbyts,1  x2,a_jcbp,x0,tasks       .Load JCB executing_task_count.
          brxne    x2,x0,multi              .If another task of the job is
.                                           .executing, check multiprocessing.
          lbyts,1  x2,a_jcbp,x0,j_lpid      .Purge buffers if the last processor
          brxne    x2,x_csti,purg_buf       .for the job was not this one.
          brxeq    x0,x0,save_cst           .The task can execute, exit.
.
multi     lbyts,1  x2,a_jcbp,x0,multi       .Load JCB multiprocessing_allowed.
          brxeq    x2,x0,next_ptlo          .If no multiprocessing, select new task.
          lbyts,1  x2,a_xcbp,x0,t_lpid      .Purge buffers if the last processor
          brxeq    x2,x_csti,save_cst       .for the task was not this one.
.
purg_buf  purge    x1,2                     .Purge buffers.
          purge    x1,15
.                                           .Task selected to execute; save cst info.
save_cst  sbyts,1  x_ajlo,a_cstp,x0,ajlo    .Store the ajlo of the task selected.
          sbyts,2  x_ijlo,a_cstp,x0,ijlo    .Store the ijlo of the task selected.
          sa       a_ijle,a_cstp,ijlep      .Store the ijl pointer of the task.
          sa       a_jcbp,a_cstp,jcbp       .Store the jcb pointer of the task.
          sa       a_xcbp,a_cstp,xcbp       .Store the xcb pointer of the task.
.
quit      pstorxp  x_ptlo,ptlo              .Return the ptlo selected.
          return
          end
*DECK DECK=TMM$WAIT EXPAND=TRUE
?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE: Program Control - Preemptive Communications' ??
MODULE tmm$wait;

{ PURPOSE:
{   The purpose of this module is to package contained procedures so
{   that they execute with the privileges necessary to read the structures
{   in the execution control block that support signals and system flags.
{
{ DESIGN:
{   The procedures contained in the module have an execution bracket
{   of 2, 3 and a call bracket of 13.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc osc$processor_defined_registers
*copyc oss$job_paged_literal
*copyc ost$caller_identifier
*copyc ost$execution_control_block
*copyc pmt$task_control_block
*copyc tmc$execution_ring_constants
*copyc tmt$allocated_execution_rings
*copyc tmt$preempted_reason
*copyc tmt$rb_wait
?? POP ??
*copyc i#call_monitor
*copyc osp$establish_block_exit_hndlr
*copyc osp$verify_system_privilege
*copyc pmp$find_executing_task_xcb
*copyc tmp$allocate_execution_rings
*copyc tmp$clear_wait_inhibited
*copyc tmp$dispose_of_ring2_flags
*copyc tmp$dispose_of_ring2_signals
*copyc tmp$dispose_of_ring3_flags
*copyc tmp$dispose_of_ring3_signals
*copyc tmv$null_global_task_id
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  TYPE
    valid_wait_reasons = set of tmt$preempted_reason;

  VAR
    valid_reasons: [STATIC, READ, oss$job_paged_literal] valid_wait_reasons := $valid_wait_reasons
          [tmc$wait, tmc$long_term_wait];

?? OLDTITLE ??
?? NEWTITLE := 'dispose_of_signals_flags' ??

  PROCEDURE dispose_of_signals_flags
    (    wait_reason: tmc$wait .. tmc$long_term_wait;
     VAR disposed: boolean);

    TYPE
      signals_present = set of tmt$signal_buffers;

    VAR
      allocated_flag_execution_rings: tmt$allocated_execution_rings,
      allocated_signl_execution_rings: tmt$allocated_execution_rings,
      executing_ring: ost$ring,
      execution_ring: tmt$handler_execution_ring,
      ignore_status: ost$status,
      signals_to_process: ^signals_present,
      tcb_p: ^pmt$task_control_block,
      xcb_p: ^ost$execution_control_block;

?? NEWTITLE := 'dispose_of_nonlocal_exit', EJECT ??

{ PURPOSE:
{   This procedure ensures that all preemptive communications are processed
{   before a nonlocal exit is premitted to complete or the task is permitted
{   to terminate.

    PROCEDURE dispose_of_nonlocal_exit
      (    condition: pmt$condition;
           condition_descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR status: ost$status);


      status.normal := TRUE;
      dispose_of_signals_flags (wait_reason, disposed);
    PROCEND dispose_of_nonlocal_exit;
?? OLDTITLE ??
?? EJECT ??

    disposed := FALSE;
    pmp$find_executing_task_xcb (xcb_p);
    tcb_p := xcb_p^.task_control_block;
    signals_to_process := #LOC (xcb_p^.signals.present);
    IF (signals_to_process^ <> $signals_present []) OR (tcb_p^.task_local_signal_list.delink <> NIL) OR
          (xcb_p^.system_flags <> $tmt$system_flags []) THEN
      osp$establish_block_exit_hndlr (^dispose_of_nonlocal_exit);
      IF (signals_to_process^ <> $signals_present []) OR (tcb_p^.task_local_signal_list.delink <> NIL) THEN
        tmp$allocate_execution_rings (#RING (^executing_ring), wait_reason, tmc$signal,
              allocated_signl_execution_rings);
        FOR execution_ring := tmc$lowest_signal_flag_ring TO tmc$highest_signal_flag_ring DO
          IF execution_ring IN allocated_signl_execution_rings THEN
            CASE execution_ring OF
            = tmc$task_monitor2_ring =
              tmp$dispose_of_ring2_signals;
            = tmc$task_services_ring =
              tmp$dispose_of_ring3_signals;
            CASEND;
            disposed := TRUE;
          IFEND;
        FOREND;
      IFEND;
      IF (xcb_p^.system_flags <> $tmt$system_flags []) THEN
        tmp$allocate_execution_rings (#RING (^executing_ring), wait_reason, tmc$system_flag,
              allocated_flag_execution_rings);
        FOR execution_ring := tmc$lowest_signal_flag_ring TO tmc$highest_signal_flag_ring DO
          IF execution_ring IN allocated_flag_execution_rings THEN
            CASE execution_ring OF
            = tmc$task_monitor2_ring =
              tmp$dispose_of_ring2_flags;
            = tmc$task_services_ring =
              tmp$dispose_of_ring3_flags;
            CASEND;
            disposed := TRUE;
          IFEND;
        FOREND;
      IFEND;
      #WRITE_REGISTER (osc$pr_clear_critical_frame, 0);
    IFEND;
  PROCEND dispose_of_signals_flags;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] tmp$dispose_of_signals_flags', EJECT ??
*copy tmh$dispose_of_signals_flags

  PROCEDURE [XDCL] tmp$dispose_of_signals_flags
    (    preemptive_reason: tmt$preempted_reason);

    VAR
      disposed: boolean;

    IF (preemptive_reason IN valid_reasons) THEN
      dispose_of_signals_flags (preemptive_reason, disposed);
    IFEND;
  PROCEND tmp$dispose_of_signals_flags;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] tmp$wait', EJECT ??

{ PURPOSE:
{  The purpose of this request is to support the pmp$wait and pmp$long_term_wait requests - processing
{  signals and system flags as appropriate.

  PROCEDURE [XDCL, #GATE] tmp$wait
    (    global_taskid: ost$global_task_id;
         wait_reason: tmc$wait .. tmc$long_term_wait;
         milliseconds: 0 .. 0ffffffffffff(16);
         expected_milliseconds: 0 .. 0ffffffffffff(16));

    VAR
      current_time: ost$free_running_clock,
      disposed: boolean,
      ignore_status: ost$status,
      wait: tmt$rb_wait,
      wait_inhibited: boolean;

    osp$verify_system_privilege;
    current_time := #FREE_RUNNING_CLOCK (0);
    IF (wait_reason IN valid_reasons) THEN
      dispose_of_signals_flags (wait_reason, disposed);

{ If no signal or flags were present - it is okay to go into wait.

      IF NOT disposed THEN
        wait.reqcode := syc$rc_wait;
        IF (((milliseconds * 1000) + current_time) > UPPERVALUE (ost$free_running_clock)) THEN
          wait.requested_wait_time := UPPERVALUE (ost$free_running_clock);
        ELSE
          wait.requested_wait_time := (milliseconds * 1000) + current_time;
        IFEND;

        IF (((expected_milliseconds * 1000) + current_time) > UPPERVALUE (ost$free_running_clock)) THEN
          wait.expected_wait_time := UPPERVALUE (ost$free_running_clock);
        ELSE
          wait.expected_wait_time := expected_milliseconds * 1000;
        IFEND;
        wait.global_taskid := global_taskid;

        i#call_monitor (#LOC (wait), #SIZE (wait));
        dispose_of_signals_flags (wait_reason, disposed);
      ELSE

{ Make sure that wait inhibited is cleared before exit.

        tmp$clear_wait_inhibited (wait_inhibited);
      IFEND;
    IFEND;
  PROCEND tmp$wait;
?? OLDTITLE ??
MODEND tmm$wait;
*DECK DECK=TMP$ALLOCATE_EXECUTION_RINGS EXPAND=FALSE

  PROCEDURE [XREF] tmp$allocate_execution_rings (preempted_ring: ost$ring;
        preempted_reason: tmt$preempted_reason;
        preemptive_type: tmt$preemptive_type;
    VAR allocated_execution_rings: tmt$allocated_execution_rings);

*copyc MMT$SEGMENT_DESCRIPTOR_TABLE
*copyc OSD$VIRTUAL_ADDRESS
*copyc TMT$PREEMPTED_REASON
*copyc TMT$PREEMPTIVE_TYPE
*copyc TMT$ALLOCATED_EXECUTION_RINGS
?? POP ??
*DECK DECK=TMP$ASSIGN_PTL EXPAND=FALSE


   PROCEDURE [XREF]  tmp$assign_ptl
     (    xcb_p: ^ost$execution_control_block;
          ijl_ordinal: jmt$ijl_ordinal;
      VAR taskid: ost$global_task_id;
      VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$execution_control_block
*copyc jmt$ijl_ordinal
*copyc ost$global_task_id
*copyc ost$status
?? POP ??
*DECK DECK=TMP$CALCULATE_DCT_PRIORITY_INT EXPAND=FALSE

  PROCEDURE [XREF] tmp$calculate_dct_priority_int;

*DECK DECK=TMP$CAUSE_TASK_SWITCH EXPAND=FALSE
  PROCEDURE [XREF] tmp$cause_task_switch;

*DECK DECK=TMP$CHANGE_TASKS_170_CP_SELECTS EXPAND=FALSE

  PROCEDURE [XREF] tmp$change_tasks_170_cp_selects
    (    dedicate_cpu: boolean;
         cpu_to_dedicate: ost$processor_id);

?? PUSH (LISTEXT := ON) ??
*copyc ost$processor_id
?? POP ??
*DECK DECK=TMP$CHECK_FOR_SWAPOUT_CANDIDATE EXPAND=FALSE

  PROCEDURE [XREF] tmp$check_for_swapout_candidate (ajlo: jmt$ajl_ordinal);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ajl_ordinal
?? POP ??
*DECK DECK=TMP$CHECK_PTL_LOCK EXPAND=FALSE

{
{     NOTE: Callers of this procedure require that 'tmv$ptl_lock'
{           be XREFed or XDCLed in the module.
{

  PROCEDURE [INLINE] tmp$check_ptl_lock
    (VAR ptl_lock_set: boolean);

    ptl_lock_set := tmv$ptl_lock.locked;

  PROCEND tmp$check_ptl_lock;

*DECK DECK=TMP$CHECK_TASKID EXPAND=FALSE

  PROCEDURE [XREF] tmp$check_taskid (taskid: ost$global_task_id;
        option: tmt$option;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc TMT$PRIMARY_TASK_LIST
*copyc SYT$MONITOR_REQUEST_CODE
?? POP ??
*DECK DECK=TMP$CHECK_TASKID_WITH_LOCK_SET EXPAND=FALSE

  PROCEDURE [XREF] tmp$check_taskid_with_lock_set
    (    taskid: ost$global_task_id;
         option: tmt$option;
     VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc TMT$PRIMARY_TASK_LIST
*copyc SYT$MONITOR_REQUEST_CODE
?? POP ??
*DECK DECK=TMP$CHECK_TIMED_WAIT_NOT_QUEUED EXPAND=FALSE

  PROCEDURE [XREF] tmp$check_timed_wait_not_queued
    (    time_next_scan_wait_not_queued: integer);

*DECK DECK=TMP$CLEAR_LOCK EXPAND=FALSE

PROCEDURE [INLINE] tmp$clear_lock (VAR lock: tmt$ptl_lock);

    IF osv$cpus_logically_on > 1 THEN
      IF lock.id <> #READ_REGISTER (osc$pr_base_constant) THEN
        i#program_error; {Interlock failure - no message passed for performance reasons}
      IFEND;
      IF lock.count > 0 THEN
        lock.count := lock.count - 1;
      ELSE
        lock.clear := 0;
      IFEND;
    IFEND;

PROCEND   tmp$clear_lock;

?? PUSH (LISTEXT := ON) ??
*copyc i#program_error
*copyc osv$cpus_logically_on
*copyc tmt$ptl_lock
*copyc osc$processor_defined_registers
?? POP ??
*DECK DECK=TMP$CLEAR_SYSTEM_FLAG EXPAND=FALSE

  PROCEDURE [XREF] tmp$clear_system_flag (flag_id: ost$system_flag;
    VAR flag_status: tmt$flag_status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$SYSTEM_FLAG
*copyc TMT$FLAG_STATUS
?? POP ??
*DECK DECK=TMP$CLEAR_WAIT_INHIBITED EXPAND=FALSE

  PROCEDURE [XREF] tmp$clear_wait_inhibited (VAR wait_inhibited: boolean);
*DECK DECK=TMP$DELAY EXPAND=FALSE

  PROCEDURE [XREF] tmp$delay (VAR rb: tmt$rb_delay;
       cst_p: ^ost$cpu_state_table);

?? PUSH (LISTEXT := ON) ??
*copyc TMT$RB_DELAY
*copyc OST$CPU_STATE_TABLE
?? POP ??
*DECK DECK=TMP$DELETE_SYSTEM_TASK EXPAND=FALSE

  PROCEDURE [XREF] tmp$delete_system_task (VAR status: syx$monitor_status);
?? PUSH (LISTEXT := ON) ??
*copyc SYT$MONITOR_REQUEST_CODE
?? POP ??
*DECK DECK=TMP$DEQUEUE_TASK EXPAND=FALSE

  PROCEDURE [XREF] tmp$dequeue_task (VAR queue_link: tmt$task_queue_link;
    VAR taskid: ost$global_task_id);

?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc TMT$TASK_QUEUE_LINK
?? POP ??
*DECK DECK=TMP$DISABLE_PREEMPTIVE_COMMO EXPAND=FALSE

  PROCEDURE [XREF] tmp$disable_preemptive_commo;
*DECK DECK=TMP$DISABLE_SIGNALS_FLAGS EXPAND=FALSE

*DECK DECK=TMP$DISPOSE_MAINFRAME_SIGNALS EXPAND=FALSE

  PROCEDURE [XREF] tmp$dispose_mainframe_signals (flag_id: ost$system_flag);

?? PUSH (LISTEXT := ON) ??
*copyc OST$SYSTEM_FLAG
?? POP ??
*DECK DECK=TMP$DISPOSE_OF_BROKEN_TASK EXPAND=FALSE

  PROCEDURE [XREF] tmp$dispose_of_broken_task (fault: ost$monitor_fault;
        sfsa: ^ost$stack_frame_save_area);

?? PUSH (LISTEXT := ON) ??
*copyc OST$MONITOR_FAULT
*copyc OST$STACK_FRAME_SAVE_AREA
?? POP ??
*DECK DECK=TMP$DISPOSE_OF_INSERTED_PREEMPT EXPAND=FALSE

  PROCEDURE [XREF] tmp$dispose_of_inserted_preempt;
*DECK DECK=TMP$DISPOSE_OF_MONITOR_FAULTS EXPAND=FALSE

  PROCEDURE [XREF] tmp$dispose_of_monitor_faults (sfsa: ^ost$stack_frame_save_area);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STACK_FRAME_SAVE_AREA
?? POP ??
*DECK DECK=TMP$DISPOSE_OF_RING2_FLAGS EXPAND=FALSE

  PROCEDURE [XREF] tmp$dispose_of_ring2_flags;
*DECK DECK=TMP$DISPOSE_OF_RING2_SIGNALS EXPAND=FALSE

  PROCEDURE [XREF] tmp$dispose_of_ring2_signals;
*DECK DECK=TMP$DISPOSE_OF_RING3_FLAGS EXPAND=FALSE

  PROCEDURE [XREF] tmp$dispose_of_ring3_flags;
*DECK DECK=TMP$DISPOSE_OF_RING3_SIGNALS EXPAND=FALSE

  PROCEDURE [XREF] tmp$dispose_of_ring3_signals;
*DECK DECK=TMP$DISPOSE_OF_SIGNALS_FLAGS EXPAND=TRUE

  PROCEDURE [XREF] tmp$dispose_of_signals_flags
    (    preemptive_reason: tmt$preempted_reason);

?? PUSH (LISTEXT := ON) ??
*copyc tmt$preempted_reason
?? POP ??

*DECK DECK=TMP$DISPOSE_PREEMPTIVE_COMMO EXPAND=FALSE

  PROCEDURE [XREF] tmp$dispose_preemptive_commo (preempted_reason: tmt$preempted_reason);

?? PUSH (LISTEXT := ON) ??
*copyc TMT$PREEMPTED_REASON
?? POP ??
*DECK DECK=TMP$DISPOSE_SYSTEM_REQ_FAULT EXPAND=FALSE

  PROCEDURE [XREF] tmp$dispose_system_req_fault (fault: ost$monitor_fault;
        sfsa: ^ost$stack_frame_save_area);

?? PUSH (LISTEXT := ON) ??
*copyc OST$MONITOR_FAULT
*copyc OST$STACK_FRAME_SAVE_AREA
?? POP ??
*DECK DECK=TMP$ENABLE_PREEMPTIVE EXPAND=FALSE

  PROCEDURE [XREF] tmp$enable_preemptive;
*DECK DECK=TMP$ENABLE_PREEMPTIVE_COMMO EXPAND=FALSE

  PROCEDURE [XREF] tmp$enable_preemptive_commo;
*DECK DECK=TMP$FETCH_JOB_STATISTICS EXPAND=FALSE

  PROCEDURE [XREF] tmp$fetch_job_statistics (VAR statistics: jmt$job_statistics;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$job_statistics
*copyc OST$STATUS
?? POP ??
*DECK DECK=TMP$FIND_FLAG_TO_PROCESS EXPAND=FALSE

  PROCEDURE [XREF] tmp$find_flag_to_process (VAR flag_found: boolean;
    VAR flag_id: ost$system_flag;
    VAR flag_handler: tmt$system_flag_handler);

?? PUSH (LISTEXT := ON) ??
*copyc OST$SYSTEM_FLAG
*copyc TMT$SYSTEM_FLAG_HANDLER
?? POP ??
*DECK DECK=TMP$FIND_MAINFRAME_SIGNAL EXPAND=FALSE

  PROCEDURE [XREF] tmp$find_mainframe_signal
    (    gtid: ost$global_task_id;
     VAR signal_found: boolean;
     VAR signal: tmt$signal);

?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc TMT$SIGNAL
?? POP ??
*DECK DECK=TMP$FIND_MONITOR_FAULT EXPAND=FALSE

  PROCEDURE [XREF] tmp$find_monitor_fault (trapped_sfsa: ^ost$stack_frame_save_area;
    VAR fault: ost$monitor_fault;
    VAR fault_found: boolean;
    VAR monitor_fault_handler: tmt$monitor_fault_handler);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc OST$MONITOR_FAULT
*copyc TMT$MONITOR_FAULT_HANDLER
?? POP ??
*DECK DECK=TMP$FIND_NEXT_QUEUED_TASK EXPAND=FALSE

  PROCEDURE [XREF] tmp$find_next_queued_task
    (VAR taskid: ost$global_task_id);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
?? POP ??
*DECK DECK=TMP$FIND_NEXT_XCB EXPAND=FALSE

  PROCEDURE [XREF] tmp$find_next_xcb (search: tmt$fnx_search_type;
        ijle_p: ^jmt$initiated_job_list_entry;
        ijl_ordinal: jmt$ijl_ordinal;
    VAR state: tmt$find_next_xcb_state;
    VAR xcb_p: ^ost$execution_control_block);

?? PUSH (LISTEXT := ON) ??
*copyc TMT$FNX_SEARCH_TYPE
*copyc JMT$IJL_ORDINAL
*copyc JMT$INITIATED_JOB_LIST_ENTRY
*copyc OST$EXECUTION_CONTROL_BLOCK
?? POP ??
*DECK DECK=TMP$FIND_RING_CROSSING_FRAME EXPAND=FALSE

  PROCEDURE [XREF] tmp$find_ring_crossing_frame (starting_frame:
    ^ost$stack_frame_save_area;
    VAR frame: ^ost$stack_frame_save_area;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STACK_FRAME_SAVE_AREA
*copyc OST$STATUS
?? POP ??
*DECK DECK=TMP$FIND_SIGNAL EXPAND=FALSE

  PROCEDURE [XREF] tmp$find_signal (VAR signal_found: boolean;
    VAR signal: tmt$signal;
    VAR signal_handler: tmt$signal_handler);

?? PUSH (LISTEXT := ON) ??
*copyc TMT$SIGNAL
*copyc TMT$SIGNAL_HANDLER
?? POP ??
*DECK DECK=TMP$FIND_XCB EXPAND=FALSE

  PROCEDURE [XREF] tmp$find_xcb (taskid: ost$global_task_id;
    VAR xcb_p: ^ost$execution_control_block;
    VAR ijle_p: ^jmt$initiated_job_list_entry;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??

*copyc JMT$INITIATED_JOB_LIST_ENTRY
*copyc OST$GLOBAL_TASK_ID
*copyc OST$EXECUTION_CONTROL_BLOCK
*copyc SYT$MONITOR_REQUEST_CODE

?? POP ??
*DECK DECK=TMP$FLAG_ALL_TASKS EXPAND=FALSE

  PROCEDURE [XREF] tmp$flag_all_tasks (flag_id: ost$system_flag;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
*copyc ost$system_flag
?? POP ??
*DECK DECK=TMP$FREE_UNRECOVERED_TASKS EXPAND=FALSE

  PROCEDURE [XREF] tmp$free_unrecovered_tasks
    (    ijle_p: ^jmt$initiated_job_list_entry);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=TMP$GET_MONITOR_FAULT EXPAND=FALSE

  PROCEDURE [XREF] tmp$get_monitor_fault (fault_index: tmt$monitor_fault_buffers;
    VAR fault: ost$monitor_fault;
    VAR fault_status: tmt$fault_status);

?? PUSH (LISTEXT := ON) ??
*copyc TMT$MONITOR_FAULT_BUFFER
*copyc OST$MONITOR_FAULT
*copyc TMT$FAULT_STATUS
?? POP ??
*DECK DECK=TMP$GET_SIGNAL EXPAND=FALSE

  PROCEDURE [XREF] tmp$get_signal (buffer_index: tmt$signal_buffers;
    VAR signal: tmt$signal;
    VAR signal_status: tmt$signal_status);

?? PUSH (LISTEXT := ON) ??
*copyc TMT$SIGNAL_BUFFERS
*copyc TMT$SIGNAL
*copyc TMT$SIGNAL_STATUS
?? POP ??
*DECK DECK=TMP$GET_TASKID_FROM_TASK_QUEUE EXPAND=FALSE

  PROCEDURE [INLINE] tmp$get_taskid_from_task_queue
    (    task_queue: tmt$task_queue_link;
     VAR taskid: ost$global_task_id);

?? PUSH (LISTEXT := ON) ??
    taskid.index := task_queue.head;
    taskid.seqno := tmv$ptl_p^ [task_queue.head].sequence_number;
  PROCEND tmp$get_taskid_from_task_queue;
?? POP ??
*DECK DECK=TMP$GET_TOP_OF_STACK EXPAND=FALSE

  PROCEDURE [XREF] tmp$get_top_of_stack (taskid: ost$global_task_id;
        ring: ost$valid_ring;
    VAR top_of_stack: integer);

??  PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc osd$virtual_address
?? POP ??
*DECK DECK=TMP$GET_XCB_ACCESS_STATUS EXPAND=TRUE

  PROCEDURE [INLINE] tmp$get_xcb_access_status
    (    ijle_p: ^jmt$initiated_job_list_entry;
         ijl_ordinal: jmt$ijl_ordinal;
     VAR inhibit_access: boolean);

?? PUSH (LISTEXT := ON)  ??

{  The purpose of this procedure is to return whether or not the xcb of the specified
{  job can be accessed.  If the job is swapped but io has not yet been initiated,
{  an ajl entry will be assigned.  If an ajl entry exists then the in use count will be
{  incremented.  It is the responsibility of the caller to release the ajl entry.
{
{  NOTE:  The caller must have tmv$ptl_lock set.

    VAR
      ajlo: jmt$ajl_ordinal;

    IF (ijle_p^.swap_status > jmc$inhibit_xcb_access) OR
          (ijle_p^.entry_status = jmc$ies_job_terminating) THEN
      inhibit_access := TRUE;
    ELSE
      inhibit_access := FALSE;
      jmp$lock_ajl_with_lock (ijle_p, ijl_ordinal, ajlo);
    IFEND;

  PROCEND tmp$get_xcb_access_status;

*copyc jmt$ajl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc jmp$lock_ajl_with_lock
?? POP ??
*DECK DECK=TMP$GET_XCB_P EXPAND=FALSE
  PROCEDURE [XREF] tmp$get_xcb_p (task_id: ost$global_task_id;
    VAR xcb_p: ^ost$execution_control_block;
    VAR ijle_p: ^jmt$initiated_job_list_entry);

?? PUSH (LISTEXT := ON) ??
*copyc JMT$INITIATED_JOB_LIST_ENTRY
*copyc OST$GLOBAL_TASK_ID
*copyc OST$EXECUTION_CONTROL_BLOCK
?? POP ??
*DECK DECK=TMP$IDLE_NON_DISPATCHABLE_JOB EXPAND=FALSE

  PROCEDURE [XREF] tmp$idle_non_dispatchable_job
    (    ajl_ordinal: jmt$ajl_ordinal);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ajl_ordinal
?? POP ??
*DECK DECK=TMP$IDLE_TASKS_IN_JOB EXPAND=FALSE

  PROCEDURE [XREF] tmp$idle_tasks_in_job
    (    ajl_ordinal: jmt$ajl_ordinal;
         swapout_reason: jmt$swapout_reasons;
     VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ajl_ordinal
*copyc jmt$swapout_reasons
*copyc syt$monitor_status
?? POP ??
*DECK DECK=TMP$INITIALIZ_HANDLER_X_BRACKET EXPAND=FALSE

  PROCEDURE [XREF] tmp$initializ_handler_x_bracket (VAR handler_description {input,
    {output} : tmt$pc_handler_description);

?? PUSH (LISTEXT := ON) ??
*copyc TMT$PC_HANDLER_DESCRIPTIONS
?? POP ??
*DECK DECK=TMP$MONITOR_FLAG_JOB_TASKS EXPAND=FALSE

  PROCEDURE [XREF] tmp$monitor_flag_job_tasks
    (    monitor_flag_id: syt$monitor_flag;
         ijle_p: ^jmt$initiated_job_list_entry);


?? PUSH (LISTEXT := ON) ??
*copyc syt$monitor_flag
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=TMP$MONITOR_READY_SYSTEM_TASK EXPAND=FALSE

  PROCEDURE [XREF] tmp$monitor_ready_system_task (stid: tmt$system_task_id;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc SYT$MONITOR_REQUEST_CODE
*copyc TMT$SYSTEM_TASK_ID
?? POP ??
*DECK DECK=TMP$MTR_BEGIN_LOCK_ACTIVITY EXPAND=FALSE

  PROCEDURE [XREF] tmp$mtr_begin_lock_activity
    (    xcb_p: ^ost$execution_control_block;
         activity: 1 .. 256);

?? PUSH (LISTEXT := ON) ??
*copyc ost$execution_control_block
?? POP ??
*DECK DECK=TMP$MTR_END_LOCK_ACTIVITY EXPAND=FALSE

  PROCEDURE [XREF] tmp$mtr_end_lock_activity
    (    cst_p: ^ost$cpu_state_table;
         activity: 1 .. 256;
     VAR xcb_p: ^ost$execution_control_block);

?? PUSH (LISTEXT := ON) ??
*copyc ost$cpu_state_table
*copyc ost$execution_control_block
?? POP ??
*DECK DECK=TMP$OBTAIN_IJL_ORDINAL_FROM_PTL EXPAND=FALSE


   PROCEDURE [XREF] tmp$obtain_ijl_ordinal_from_ptl
     (    global_task_id: ost$global_task_id;
      VAR ijl_ordinal: jmt$ijl_ordinal);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc ost$global_task_id
?? POP ??
*DECK DECK=TMP$POST_MAINFRAME_SIGNAL EXPAND=FALSE

  PROCEDURE [XREF] tmp$post_mainframe_signal (recipient: ost$global_task_id;
        signal: pmt$signal;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc PMT$SIGNAL
*copyc OST$STATUS
*copyc OSE$HEAP_FULL_EXCEPTIONS
*copyc PMC$PROGRAM_MANAGEMENT_ID
?? POP ??
*DECK DECK=TMP$POST_MONITOR_FAULT_SFSA EXPAND=FALSE

  PROCEDURE [XREF] tmp$post_monitor_fault_sfsa (sfsa: ^ost$stack_frame_save_area;
    VAR monitor_fault_present: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc OST$STACK_FRAME_SAVE_AREA
?? POP ??
*DECK DECK=TMP$QUEUE_TASK EXPAND=FALSE

  PROCEDURE [XREF] tmp$queue_task (taskid: ost$global_task_id;
        task_status: tmt$task_status;
    VAR queue_link: tmt$task_queue_link);

?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc tmt$task_status
*copyc TMT$TASK_QUEUE_LINK
?? POP ??
*DECK DECK=TMP$READY_SYSTEM_TASK1 EXPAND=FALSE

  PROCEDURE [XREF] tmp$ready_system_task (stid: tmt$system_task_id;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$STATUS
*copyc TMT$SYSTEM_TASK_ID
?? POP ??
*DECK DECK=TMP$REISSUE_MONITOR_REQUEST EXPAND=FALSE

  PROCEDURE [XREF] tmp$reissue_monitor_request;
*DECK DECK=TMP$REMOVE_TASK_FROM_DCT EXPAND=FALSE


     PROCEDURE  [XREF]  tmp$remove_task_from_dct
       (   ptlo: ost$task_index);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
?? POP ??
*DECK DECK=TMP$RESET_DISPATCHING_CONTROL EXPAND=FALSE

  PROCEDURE [XREF] tmp$reset_dispatching_control
    (    ijle_p: ^jmt$initiated_job_list_entry;
         ijlo: jmt$ijl_ordinal;
         excess_service_used: integer;
         expired_dispatching_control: boolean);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=TMP$RESTART_IDLED_TASKS EXPAND=FALSE
  PROCEDURE [XREF] tmp$restart_idled_tasks (ajl_ordinal: jmt$ajl_ordinal);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ajl_ordinal
?? POP ??
*DECK DECK=TMP$SAVE_SYSTEM_TASK_ID EXPAND=FALSE

  PROCEDURE [XREF] tmp$save_system_task_id (stid: tmt$system_task_id;
        critical_task: boolean;
    VAR status: ost$status);
?? PUSH (LISTEXT := ON) ??
*copyc TMT$SYSTEM_TASK_ID
*copyc OST$STATUS
?? POP ??
*DECK DECK=TMP$SELECT_NEXT_TASK EXPAND=FALSE

  PROCEDURE [XREF] tmp$select_next_task
    (    cst_p: ^ost$cpu_state_table;
     VAR ptlo: ost$task_index);

?? PUSH (LISTEXT := ON) ??
*copyc ost$cpu_state_table
*copyc ost$global_task_id
?? POP ??
*DECK DECK=TMP$SEND_MONITOR_FAULT EXPAND=FALSE


  PROCEDURE [XREF] tmp$send_monitor_fault (task_id {input} : ost$global_task_id;
        monitor_fault_p {input} : ^ost$monitor_fault;
        check_traps_enabled {input} : BOOLEAN);

?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc OST$MONITOR_FAULT
?? POP ??
*DECK DECK=TMP$SEND_SIGNAL EXPAND=FALSE

  PROCEDURE [XREF] tmp$send_signal (taskid: ost$global_task_id;
        signal: pmt$signal;
    VAR status: syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc PMT$SIGNAL
*copyc SYT$MONITOR_REQUEST_CODE
?? POP ??
*DECK DECK=TMP$SET_FLAG_INTERVAL EXPAND=FALSE

  PROCEDURE [XREF] tmp$set_flag_interval (interval: 0 .. 0ffffffff(16));
*DECK DECK=TMP$SET_LOCK EXPAND=FALSE

  PROCEDURE [INLINE] tmp$set_lock
    (VAR lock: tmt$ptl_lock);

    VAR
      b: boolean,
      bc: integer,
      old_traps: 0 .. 3;

    IF osv$cpus_logically_on > 1 THEN
      bc := #read_register (osc$pr_base_constant);
      IF lock.id <> bc THEN

        { Disable traps, the process of setting the lock.locked bit and setting the lock.id can not be
        { interrupted.

        REPEAT
          i#mtr_disable_traps (old_traps);
          #TEST_SET (lock.locked, b);
          IF b THEN
            i#mtr_restore_traps (old_traps);
          IFEND;
        UNTIL NOT b;
        lock.id := bc;
        i#mtr_restore_traps (old_traps);

      ELSE
        lock.count := lock.count + 1;
      IFEND;
    IFEND;

PROCEND tmp$set_lock;

?? PUSH (LISTEXT := ON) ??
*copyc i#mtr_disable_traps
*copyc i#mtr_restore_traps
*copyc osc$processor_defined_registers
*copyc osv$cpus_logically_on
*copyc tmt$ptl_lock
?? POP ??
*DECK DECK=TMP$SET_MONITOR_FLAG EXPAND=FALSE

  PROCEDURE [XREF] tmp$set_monitor_flag (task_id: ost$global_task_id;
        flag_id: syt$monitor_flag;
    VAR status: syt$monitor_status);
?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYT$MONITOR_FLAG
?? POP ??
*DECK DECK=TMP$SET_SYSTEM_FLAG EXPAND=FALSE


  PROCEDURE [XREF] tmp$set_system_flag (task_id {input} : ost$global_task_id;
        flag_id {input} : ost$system_flag;
    VAR status {output} : syt$monitor_status);

?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc OST$SYSTEM_FLAG
*copyc SYT$MONITOR_REQUEST_CODE
?? POP ??
*DECK DECK=TMP$SET_TASK_PRIORITY EXPAND=FALSE

  PROCEDURE [XREF] tmp$set_task_priority (dispatching_priority: jmt$dispatching_priority;
        dispatching_priority_bias: jmt$dispatching_priority_bias;
    VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$dispatching_priority
*copyc ost$status
?? POP ??
*DECK DECK=TMP$SET_TASK_READY EXPAND=FALSE

  PROCEDURE [XREF] tmp$set_task_ready (task_id: ost$global_task_id;
        readying_task_priority: jmt$dispatching_priority;
        ready_condition: tmt$ready_condition);

?? PUSH (LISTEXT := ON) ??
*copyc JMT$DISPATCHING_PRIORITY
*copyc OST$GLOBAL_TASK_ID
*copyc TMT$TASK_STATUS
?? POP ??
*DECK DECK=TMP$SET_TASK_READY_UNCOND EXPAND=FALSE

  PROCEDURE [XREF] tmp$set_task_ready_uncond (taskid: ost$global_task_id;
    task_status: tmt$task_status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$global_task_id
*copyc tmt$task_status
?? POP ??
*DECK DECK=TMP$SET_TASK_WAIT EXPAND=FALSE

  PROCEDURE [XREF] tmp$set_task_wait (task_status: tmt$task_status);

?? PUSH (LISTEXT := ON) ??
*copyc TMT$TASK_STATUS
?? POP ??
*DECK DECK=TMP$SET_UP_DEBUG_REGISTERS EXPAND=FALSE
  PROCEDURE [XREF] tmp$set_up_debug_registers (ptlo: ost$task_index;
        ijle_p: ^jmt$initiated_job_list_entry;
        xcb_p: ^ost$execution_control_block);
?? PUSH (LISTEXT := ON) ??
*copyc ost$execution_control_block
*copyc jmt$initiated_job_list_entry
?? POP ??
*DECK DECK=TMP$SWITCH_TASK_FROM_FAILING_CP EXPAND=FALSE

  PROCEDURE [XREF] tmp$switch_task_from_failing_cp
    (VAR cst_p: ^ost$cpu_state_table);

?? PUSH (LISTEXT := ON) ??
*copyc ost$cpu_state_table
?? POP ??
*DECK DECK=TMP$TEST_GET_XCB_P EXPAND=FALSE

  PROCEDURE [XREF] tmp$test_get_xcb_p (task_id: ost$global_task_id;
    VAR xcb_p: ^ost$execution_control_block;
    VAR ijle_p: ^jmt$initiated_job_list_entry);

?? PUSH (LISTEXT := ON) ??
*copyc JMT$INITIATED_JOB_LIST_ENTRY
*copyc OST$GLOBAL_TASK_ID
*copyc OST$EXECUTION_CONTROL_BLOCK
?? POP ??
*DECK DECK=TMP$UPDATE_JOB_TASK_CPU_SELECTS EXPAND=FALSE

  PROCEDURE [XREF] tmp$update_job_task_cpu_selects;


*DECK DECK=TMP$UPDATE_JOB_TASK_ENVIRONMENT EXPAND=FALSE

  PROCEDURE [XREF] tmp$update_job_task_environment (ijle_p: ^jmt$initiated_job_list_entry;
        ijl_ordinal: jmt$ijl_ordinal;
        xcb_search: tmt$fnx_search_type);

?? PUSH (LISTEXT := ON) ??
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc tmt$fnx_search_type
?? POP ??
*DECK DECK=TMP$UPDATE_SYSTEM_TASK_LIST EXPAND=FALSE

  PROCEDURE [XREF] tmp$update_system_task_list (xcb_p: ^ost$execution_control_block);

*copyc OST$EXECUTION_CONTROL_BLOCK
*DECK DECK=TMP$WAIT EXPAND=FALSE

  PROCEDURE [XREF] tmp$wait (global_taskid: ost$global_task_id;
        wait_reason: tmc$wait .. tmc$long_term_wait;
        requested_milliseconds: 0 .. 0ffffffffffff(16);
        expected_milliseconds: 0 .. 0ffffffffffff(16));

?? PUSH (LISTEXT := ON) ??
*copyc OST$GLOBAL_TASK_ID
*copyc TMT$PREEMPTED_REASON
?? POP ??
*DECK DECK=TMT$ALLOCATED_EXECUTION_RINGS EXPAND=FALSE

  TYPE
    tmt$allocated_execution_rings = set of tmt$handler_execution_ring;

*copyc TMT$HANDLER_EXECUTION_RING
*DECK DECK=TMT$BROKEN_TASK_CONDITION EXPAND=FALSE

{   Define conditions for which monitor mode processing decides a task is
{ broken.

  TYPE
    tmt$broken_task_condition = (tmc$btc_mntr_fault_buffer_full,
      tmc$btc_mf_traps_disabled, tmc$btc_invalid_a0, tmc$btc_invalid_p,
      tmc$btc_mcr_traps_disabled, tmc$btc_ucr_traps_disabled,
      tmc$btc_system_error);
*DECK DECK=TMT$BROKEN_TASK_MONITOR_FAULT EXPAND=FALSE

{   Define monitor fault buffer contents for monitor fault sent when task is
{ determined to be broken.
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
    tmt$broken_task_monitor_fault = record
      trap_enable: ost$trap_enable,
      case broken_task_condition: tmt$broken_task_condition of
      = tmc$btc_system_error =
        caller_p_register: ost$p_register,
        status_p: ^ost$status,
        text_p: ^string (*),
      = tmc$btc_mntr_fault_buffer_full, tmc$btc_mf_traps_disabled,
          tmc$btc_invalid_a0, tmc$btc_invalid_p,
          tmc$btc_mcr_traps_disabled, tmc$btc_ucr_traps_disabled =
        p: ost$p_register,
        a0: ^cell,
        monitor_condition_register: ost$monitor_conditions,
        user_condition_register: ost$user_conditions,
        monitor_fault_id: tmt$monitor_fault_identifiers,
      casend,
    recend;

*copyc TMT$BROKEN_TASK_CONDITION
*copyc OSD$CONDITIONS
*copyc OSD$REGISTERS
*copyc OST$TRAP_ENABLE
*copyc OST$MONITOR_FAULT
*copyc OST$STATUS
*DECK DECK=TMT$CHANGE_PRIORITY_ORIGIN EXPAND=FALSE

  TYPE
    tmt$change_priority_origin = (tmc$cpo_operator,
                                  tmc$cpo_user,
                                  tmc$cpo_save_swap_file_sfid,
                                  tmc$cpo_set_job_unswappable,
                                  tmc$cpo_interactive_command,
                                  tmc$cpo_interrupt_restore,
                                  tmc$cpo_recovery);
*DECK DECK=TMT$CPU_EXECUTION_STATISTICS EXPAND=FALSE

  TYPE
    tmt$cpu_execution_statistics = ARRAY [jmc$min_dispatching_priority .. jmc$max_dispatching_priority] OF
          ost$cp_time;

*copyc jmt$dispatching_priority
*DECK DECK=TMT$DISPATCHING_CONTROLS EXPAND=FALSE

  TYPE
    tmt$dispatching_controls = RECORD
      controls_defined: boolean,
      minimums_to_satisfy: jmt$dispatching_priority_set,
      maximums_defined: jmt$dispatching_priority_set,
      enforce_maximums: jmt$dispatching_priority_set,
      controls: tmt$dispatching_prio_controls,
    RECEND;

*copyc jmt$dispatching_priority_set
*copyc tmt$dispatching_prio_controls
*DECK DECK=TMT$DISPATCHING_CONTROL_SETS EXPAND=FALSE

{ This deck defines the type for the variable which is used to control the
{ selection of tasks to be dispatched for CPU execution.
{ NOTE:  The selection procedure is written in ASSEMBLY LANGUAGE.  This type
{ CANNOT be changed without changes to the assembly language code which uses it.

  TYPE
    tmt$dispatching_control_sets = RECORD
      enforce_maximums: jmt$dispatching_priority_set,
      minimums_to_satisfy: jmt$dispatching_priority_set,
      ready_tasks: jmt$dispatching_priority_set,
      maximums_exceeded: jmt$dispatching_priority_set,
    RECEND;

*copyc jmt$dispatching_priority_set

*DECK DECK=TMT$DISPATCHING_PRIO_CONTROLS EXPAND=FALSE

  TYPE
    tmt$dispatching_prio_controls = RECORD
      time_left_in_interval: ost$free_running_clock,
      dispatching_priority_time: tmt$dispatching_priority_time,
    RECEND,

    tmt$dispatching_priority_time = ARRAY [jmt$user_dispatching_priority] OF tmt$time_limits,

    tmt$time_limits = RECORD
      minimum_time: ost$free_running_clock,
      maximum_time: ost$free_running_clock,
    RECEND;

*copyc jmt$dispatching_priority
*copyc ost$free_running_clock
*DECK DECK=TMT$DISPATCH_CONTROL EXPAND=FALSE
{This deck defines the DISPATCHER control information that is in the CST.
{The 1st 4 bytes are  private to the dispatcher except that CPU monitor will cause
{the dispatcher to be called whenever the value of this record is not
{equal to all zeros. (Requires knowledge of CYBIL data mapping.)
{* * * Assembly language modules set the first byte of this record to 'TRUE'
{      to force a call to the dispatcher.
{The right 4 bytes of the record are used mainly by assembly decks.

  TYPE
    tmt$dispatch_control = record
      call_dispatcher: boolean,
        rethread_current_task: boolean,
      new_task_status: tmt$task_status,
      fill: boolean,
      asynchronous_interrupts_pending: boolean,
    recend;

*copyc TMT$TASK_STATUS
*DECK DECK=TMT$DISPATCH_CONTROL_TABLE EXPAND=FALSE

{ This common deck contains the type declarations for the DCT.


  TYPE
    tmt$dct_entry = RECORD
      queue_head: ALIGNED [0 MOD 8] 0 .. 0ffff(16),
      minor_priority: 0 .. 0ffff(16),
      major_priority: 0 .. 0ffff(16),
      queue_tail: 0 .. 0ffff(16),
    RECEND,

    tmt$dispatch_control_table = array [jmt$dispatching_priority] of tmt$dct_entry;



*copyc jmt$dispatching_priority
*copyc OST$GLOBAL_TASK_ID
*DECK DECK=TMT$DUAL_STATE_DISPATCH_PRIOR EXPAND=FALSE

  TYPE
    tmt$dual_state_dispatch_prior = ARRAY
       [jmc$priority_p1 .. jmc$priority_p14] OF
       tmt$dual_state_priority_entry,


    tmt$dual_state_priority_entry = record
       dual_state_priority: 0 .. 7,
       subpriority: 0 .. 15,
    recend;

*copyc jmt$dispatching_priority
*DECK DECK=TMT$FAULT_STATUS EXPAND=FALSE

  TYPE
    tmt$fault_status = (tmc$normal_fault_status, tmc$no_fault_present,
      tmc$invalid_fault_index);
*DECK DECK=TMT$FLAG_STATUS EXPAND=FALSE

  TYPE
    tmt$flag_status = (tmc$normal_flag_status, tmc$flag_not_set, tmc$invalid_flag_id);
*DECK DECK=TMT$FNX_SEARCH_TYPE EXPAND=FALSE

  TYPE
    tmt$fnx_search_type = (tmc$fnx_continue, tmc$fnx_job, tmc$fnx_system, tmc$fnx_swapping_job),

    tmt$find_next_xcb_state = RECORD
      search: tmt$fnx_search_type,
      ajl_ordinal: jmt$ajl_ordinal,
      ijl_ordinal: jmt$ijl_ordinal,
      ijle_p: ^jmt$initiated_job_list_entry,
      in_use_incremented: boolean,
      next_ptlo: ost$task_index,
    RECEND;

*copyc jmt$ajl_ordinal
*copyc jmt$ijl_ordinal
*copyc jmt$initiated_job_list_entry
*copyc ost$global_task_id
*DECK DECK=TMT$HANDLER_EXECUTION_RING EXPAND=FALSE

  TYPE
    tmt$handler_execution_ring = ost$ring;

*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=TMT$IDLE_RESUME_SYS_TASK_KIND EXPAND=FALSE

  TYPE
    tmt$idle_resume_sys_task_kind = (tmc$ir_dm_system_tasks, tmc$ir_other_system_tasks);

*DECK DECK=TMT$MAINFRAME_LINKED_SIGNAL EXPAND=FALSE

  TYPE
    tmt$mainframe_linked_signal = record
      next_linked_signal: ^tmt$mainframe_linked_signal,
      recipient: ost$global_task_id,
      linked: tmt$signal,
    recend;

*copyc OST$GLOBAL_TASK_ID
*copyc TMT$SIGNAL
*DECK DECK=TMT$MCR_FAULTS EXPAND=FALSE
{
{ NOTE: If TYPE declarations or record fields are added/changed/deleted, please
{   make the appropriate changes in the corresponding display procedures in the
{   module(s) for the System Core Debugger: SYM$DEBUG, SYM$DEBUG1
{

  TYPE
    tmt$mcr_faults = record
      faults: ost$monitor_conditions,
      untranslatable_pointer: ost$pva,
    recend;

*copyc OSD$VIRTUAL_ADDRESS
*copyc OSD$CONDITIONS
*DECK DECK=TMT$MONITOR_FAULT_BUFFER EXPAND=FALSE

  {Internal declarations for MONITOR FAULT BUFFER}

  TYPE
    tmt$monitor_fault_buffer = record
      present: packed array [tmt$monitor_fault_buffers] of boolean,
      reserved: packed array [tmt$monitor_fault_buffers] of boolean,
      buffer: array [tmt$monitor_fault_buffers] of ost$monitor_fault,
    recend,

    tmt$monitor_fault_buffers = 1 .. tmc$maximum_monitor_faults;

  TYPE
    tmt$monitor_fault_identifiers = (tmc$null_fault,
      tmc$broken_task_fault_id, tmc$mcr_fault, mmc$segment_fault_processor_id,
      tmc$unknown_system_req_fault, syc$system_core_condition, tmc$dummy_fault);

  CONST
    tmc$last_fault_id_assigned = 6,
    tmc$maximum_monitor_faults = 4;

*copyc mmd$segment_access_condition
*copyc ost$monitor_fault
*copyc ost$name
*copyc ost$trap_enable
*copyc ost$status
*copyc syc$system_core_cond_constants
*copyc syt$system_core_condition
*copyc tmt$broken_task_condition
*copyc tmt$broken_task_monitor_fault
*copyc tmt$mcr_faults
*DECK DECK=TMT$MONITOR_FAULT_HANDLER EXPAND=FALSE

  TYPE
    tmt$monitor_fault_handler = ^procedure (fault: ost$monitor_fault;
          save_area: ^ost$stack_frame_save_area);

*copyc OST$MONITOR_FAULT
*copyc OST$STACK_FRAME_SAVE_AREA
*DECK DECK=TMT$PC_HANDLER_DESCRIPTIONS EXPAND=FALSE

  TYPE
    tmt$pc_handler_descriptions = array [ * ] of tmt$pc_handler_description;

  TYPE
    tmt$pc_handler_description = record
      recognition_ring: ost$ring,
      low_execution_ring: ost$ring,
      high_execution_ring: ost$ring,
      preempt_wait: tmt$wait_preemptability,
      case preemptive_handler: tmt$preemptive_type of
      = tmc$signal =
        signal_handler: tmt$signal_handler,
      = tmc$system_flag =
        flag_handler: tmt$system_flag_handler,
      casend,
    recend;

*copyc OSD$VIRTUAL_ADDRESS
*copyc TMT$SIGNAL_HANDLER
*copyc TMT$SYSTEM_FLAG_HANDLER
*copyc TMT$PREEMPTIVE_TYPE
*copyc TMT$WAIT_PREEMPTABILITY
*DECK DECK=TMT$PREEMPTED_REASON EXPAND=FALSE

  TYPE
    tmt$preempted_reason = (tmc$free_flag, tmc$recognition_ring_delay,
      tmc$x_bracket_delay, tmc$wait, tmc$long_term_wait, tmc$task_termination);
*DECK DECK=TMT$PREEMPTIVE_TYPE EXPAND=FALSE

  TYPE
    tmt$preemptive_type = (tmc$signal, tmc$system_flag);
*DECK DECK=TMT$PRIMARY_TASK_LIST EXPAND=FALSE

{ This common deck contains the type declarations for the PTL.

  CONST
    tmc$initial_ptl_size = 255,
    tmc$maximum_ptl = 0ffff(16),
    tmc$ptl_increment = 256;



{Define Primary Task List (PTL)}

  TYPE
    tmt$primary_task_list_entry = record
      ptl_thread: ALIGNED [0 MOD 32] ost$task_index,
      sequence_number: 0 .. 255,
      xcb_offset: tmt$xcb_offset_size,
      ijl_ordinal: jmt$ijl_ordinal,
      status: tmt$task_status,
      new_task_status: tmt$task_status,
      idle_status: tmt$idle_status,
      queue_link: tmt$task_queue_link,
      monitor_flags: syt$monitor_flags,
      system_flags: tmt$system_flags,
      ptl_flags: tmt$ptl_flags,
      dispatching_priority: jmt$dispatching_priority,
      readying_task_priority: jmt$dispatching_priority,
      ijl_thread: ost$task_index,
      end_of_wait_time: 0 .. 0ffffffffffff(16),
    recend,

    tmt$primary_task_list = array [0 .. * ] of tmt$primary_task_list_entry,

    tmt$option = (tmc$opt_stop, tmc$opt_return),

    tmt$xcb_offset_size = 0 .. 0ffffff(16),

    tmt$ptl_flags = PACKED RECORD
       subsystem_locks_set: boolean,
       wait_inhibited: tmt$wait_inhibited,
    recend;

*copyc jmt$ijl_ordinal
*copyc jmt$dispatching_priority
*copyc SYT$MONITOR_FLAGS
*copyc OST$GLOBAL_TASK_ID
*copyc TMT$SYSTEM_FLAGS
*copyc TMT$TASK_QUEUE_LINK
*copyc TMT$TASK_STATUS
*copyc TMT$WAIT_INHIBITED

*DECK DECK=TMT$PTL_LOCK EXPAND=FALSE

  TYPE
    tmt$ptl_lock = RECORD
     CASE boolean OF
    = true =
      locked: aligned [0 MOD 8]   boolean,
      count: 0 .. 0ffffff(16),
      id: 0 .. 0ffffffff(16),
    = false =
      clear: aligned [0 mod 8] integer,
     CASEND,
    RECEND;
*DECK DECK=TMT$RB_CYCLE EXPAND=FALSE

  TYPE
    tmt$rb_cycle = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      code: tmc$cycle_reason,
      p1: ^cell,
      p2: ^cell,
      lock_value: integer,
    recend,

    tmc$cycle_reason = (tmc$cyc_cycle_request, tmc$cyc_set_job_lock,
          tmc$cyc_set_sys_lock, tmc$cyc_clear_sys_lock, tmc$cyc_tstset_sys_lock,
          tmc$cyc_cause_task_switch, tmc$cyc_end_system_activity, tmc$cyc_sypcycle,
          tmc$cyc_mtr_end_sys_activity, tmc$cyc_set_fde_lock);

*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*DECK DECK=TMT$RB_DELAY EXPAND=FALSE

  TYPE
    tmt$rb_delay = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      requested_wait_time: ost$free_running_clock,
      expected_wait_time: ost$free_running_clock,
    recend;

*copyc OST$HARDWARE_SUBRANGES
*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*DECK DECK=TMT$RB_EXIT_JOB EXPAND=FALSE

  TYPE
    tmt$rb_exit_job = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      terminator_task_id: ost$global_task_id,
    recend;

*copyc OST$GLOBAL_TASK_ID
*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*DECK DECK=TMT$RB_EXIT_TASK EXPAND=FALSE

  TYPE
    tmt$rb_exit_task = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      caller_taskid: ost$global_task_id,
    recend;

*copyc OST$GLOBAL_TASK_ID
*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*DECK DECK=TMT$RB_FETCH_TASK_STATISTICS EXPAND=FALSE

  TYPE
    tmt$rb_fetch_task_statistics = RECORD
      reqcode: ALIGNED [0 mod 8] syt$monitor_request_code,
      status: syt$monitor_status,
      monitor_cptime: integer,
      job_cptime: integer,
      RECEND;

*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*DECK DECK=TMT$RB_GET_JOB_FIXED_SEGMENT EXPAND=FALSE

  TYPE
    tmt$rb_get_job_fixed_segment = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      segnum: ost$segment,
      ajo: jmt$ajl_ordinal,
    recend;

*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*copyc JMT$AJL_ORDINAL
*copyc OSD$VIRTUAL_ADDRESS
*DECK DECK=TMT$RB_INITIATE_JOB EXPAND=FALSE

  TYPE
    tmt$rb_initiate_job = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      xcb_p: ^ost$execution_control_block,
      jmtr_taskid: ost$global_task_id,
      ajo: jmt$ajl_ordinal,
      ijlo: jmt$ijl_ordinal,
    recend;

*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*copyc JMT$IJL_ORDINAL
*copyc JMT$AJL_ORDINAL
*copyc OST$EXECUTION_CONTROL_BLOCK
*copyc OST$GLOBAL_TASK_ID
*DECK DECK=TMT$RB_INITIATE_TASK EXPAND=FALSE

  TYPE
    tmt$rb_initiate_task = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      xcb_p: ^ost$execution_control_block,
      wait: ost$wait,
      taskid: ost$global_task_id,
    recend;

*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*copyc OST$WAIT
*copyc OST$EXECUTION_CONTROL_BLOCK
*copyc OST$GLOBAL_TASK_ID
*DECK DECK=TMT$RB_MANAGE_SYSTEM_TASKS EXPAND=FALSE

  TYPE
    tmt$rb_manage_system_tasks = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      stid: tmt$system_task_id,
      save_task_id: boolean,
      critical_task: boolean,
    recend;

*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*copyc TMT$SYSTEM_TASK_ID
*DECK DECK=TMT$RB_READY_TASK EXPAND=FALSE

  TYPE
    tmt$rb_ready_task = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      task_id: ost$global_task_id,
    recend;

*copyc OST$GLOBAL_TASK_ID
*copyc SYC$MONITOR_REQUEST_CODES
*copyc SYT$MONITOR_REQUEST_CODE
*DECK DECK=TMT$RB_SEND_SIGNAL EXPAND=FALSE

  TYPE
    tmt$rb_send_signal = record
      reqcode {input} : ALIGNED [0 MOD 8] syt$monitor_request_code,
      status {output} : syt$monitor_status,
      task_id {input} : ost$global_task_id,
      signal {input} : pmt$signal,
    recend;


*copyc OST$GLOBAL_TASK_ID
*copyc PMT$SIGNAL
*copyc SYC$MONITOR_REQUEST_CODES
*copyc SYT$MONITOR_REQUEST_CODE
*DECK DECK=TMT$RB_SET_SYSTEM_FLAG EXPAND=FALSE

  TYPE
    tmt$rb_set_system_flag = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      task_id: ost$global_task_id,
      flag_id: ost$system_flag,
    recend;
*copyc OST$GLOBAL_TASK_ID
*copyc OST$SYSTEM_FLAG
*copyc OST$STATUS
*copyc SYT$MONITOR_REQUEST_CODE
*DECK DECK=TMT$RB_SWAPOUT_JOB EXPAND=FALSE

*DECK DECK=TMT$RB_TASK_EXIT EXPAND=FALSE

  TYPE
    tmt$rb_task_exit = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      parent_global_task_id: ost$global_task_id,
      signal: pmt$signal,
    recend;

*copyc OST$GLOBAL_TASK_ID
*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*copyc PMT$SIGNAL
*DECK DECK=TMT$RB_TERMINATE_TASK EXPAND=FALSE

  TYPE
    tmt$rb_terminate_task = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      taskid: ost$global_task_id,
    recend;

*copyc OST$GLOBAL_TASK_ID
*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*DECK DECK=TMT$RB_UPDATE_JOB_TASK_ENVIRO EXPAND=FALSE

  TYPE
    tmt$rb_update_job_task_enviro = RECORD
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      CASE subcode: (tmc$ujte_xp_register, tmc$ujte_dispatching_priority, tmc$ujte_expand_ptl,
           tmc$ujte_set_non_swappable, tmc$ujte_idle_other_sys_tasks, tmc$ujte_restart_other_systasks,
           tmc$ujte_idle_dm_sys_tasks, tmc$ujte_restart_dm_systasks, tmc$ujte_update_debug_masks,
           tmc$ujte_set_task_terminating, tmc$ujte_update_cpu_selections) OF
      = tmc$ujte_xp_register =
        CASE register_id: osc$pr_element_id .. osc$pr_user_mask_reg OF
        = osc$pr_process_interval_timer =
          pit_value: 0 .. 7fffffff(16),
        CASEND,
      = tmc$ujte_dispatching_priority =
        request_origin: tmt$change_priority_origin,
        ijl_ordinal: jmt$ijl_ordinal,
        system_supplied_name: jmt$system_supplied_name,
        dispatching_control_info: jmt$dispatching_control_info,
      = tmc$ujte_expand_ptl =
        ptl_p: ^tmt$primary_task_list,
      = tmc$ujte_set_non_swappable, tmc$ujte_idle_other_sys_tasks, tmc$ujte_restart_other_systasks,
            tmc$ujte_idle_dm_sys_tasks, tmc$ujte_restart_dm_systasks, tmc$ujte_update_debug_masks,
            tmc$ujte_update_cpu_selections =
        ,
      CASEND,
    RECEND;

*copyc jmt$ijl_ordinal
*copyc jmt$dispatching_control_info
*copyc jmt$system_supplied_name
*copyc osc$processor_defined_registers
*copyc syt$monitor_status
*copyc syc$monitor_request_codes
*copyc syt$monitor_request_code
*copyc tmt$change_priority_origin
*copyc tmt$primary_task_list

*DECK DECK=TMT$RB_WAIT EXPAND=FALSE

{ All users of this request MUST call the procedure
{ dispose_of_signals_flags in the module TMM$WAIT,
{ if the request is made from ring 3 or lower.

  TYPE
    tmt$rb_wait = record
      reqcode: ALIGNED [0 MOD 8] syt$monitor_request_code,
      status: syt$monitor_status,
      requested_wait_time: ost$free_running_clock,
      expected_wait_time: ost$free_running_clock,
      global_taskid: ost$global_task_id,
    recend,

    tmt$rb_wait_signal = tmt$rb_wait;

*copyc OST$GLOBAL_TASK_ID
*copyc OST$HARDWARE_SUBRANGES
*copyc SYT$MONITOR_REQUEST_CODE
*copyc SYC$MONITOR_REQUEST_CODES
*DECK DECK=TMT$SIGNAL EXPAND=FALSE

  TYPE
    tmt$signal = record
      originator: ost$global_task_id,
      signal: pmt$signal,
    recend;

*copyc PMT$SIGNAL
*copyc OST$GLOBAL_TASK_ID
*DECK DECK=TMT$SIGNAL_BUFFER EXPAND=FALSE

  {Internal declarations for the SIGNAL BUFFER}

  TYPE
    tmt$signal_buffer = record
      present: packed array [tmt$signal_buffers] of boolean,
      reserved: packed array [tmt$signal_buffers] of boolean,
      buffer: array [tmt$signal_buffers] of tmt$signal,
    recend;

*copyc TMT$SIGNAL
*copyc TMT$SIGNAL_BUFFERS
*DECK DECK=TMT$SIGNAL_BUFFERS EXPAND=FALSE

  TYPE
    tmt$signal_buffers = 1 .. tmc$maximum_signals;

  CONST
    tmc$maximum_signals = 4;
*DECK DECK=TMT$SIGNAL_HANDLER EXPAND=FALSE

  TYPE
    tmt$signal_handler = ^procedure (originator: ost$global_task_id;
          signal: pmt$signal);

*copyc OST$GLOBAL_TASK_ID
*copyc PMT$SIGNAL
*DECK DECK=TMT$SIGNAL_STATUS EXPAND=FALSE

  TYPE
    tmt$signal_status = (tmc$normal_signal_status, tmc$no_signal_present,
      tmc$invalid_buffer_index);
*DECK DECK=TMT$SYSTEM_FLAGS EXPAND=FALSE

  TYPE
    tmt$system_flags = set of ost$system_flag;

*copyc OST$SYSTEM_FLAG
*DECK DECK=TMT$SYSTEM_FLAG_HANDLER EXPAND=FALSE

  TYPE
    tmt$system_flag_handler = ^procedure (flag_id: ost$system_flag);

*copyc OST$SYSTEM_FLAG
*DECK DECK=TMT$SYSTEM_TASK_ID EXPAND=FALSE
{ tmdstid - system task id definitions.

  CONST
    tmc$maximum_system_task_id = 30;

  TYPE
    tmt$system_task_id = tmc$stid_null_task .. tmc$maximum_system_task_id;

  CONST
    tmc$stid_null_task = 0,
    tmc$stid_memory_link_helper = 1,
    tmc$stid_task_id_2 = 2,
    tmc$stid_administer_log = 3,
    tmc$stid_dm_split_al = 4,
    tmc$stid_volume_space_managemnt = 5,
    tmc$stid_job_scheduler = 6,
    tmc$stid_job_monitor = 7,
    tmc$stid_task_id_8 = 8,
    tmc$stid_completed_output = 9,
    tmc$stid_intranet_layer_mgmt = 10,
    tmc$stid_namve_system_input = 11,
    tmc$stid_tape_scanner = 12,
    tmc$stid_task_id_13 = 13,
    tmc$stid_task_id_14 = 14,
    tmc$stid_task_id_15 = 15,
    tmc$stid_task_id_16 = 16,
    tmc$stid_task_id_17 = 17,
    tmc$stid_task_id_18 = 18,
    tmc$stid_task_id_19 = 19,
    tmc$stid_task_id_20 = 20,
    tmc$stid_task_id_21 = 21,
    tmc$stid_task_id_22 = 22,
    tmc$stid_task_id_24 = 24,
    tmc$stid_task_id_25 = 25,
    tmc$stid_task_id_26 = 26,
    tmc$stid_task_id_27 = 27,
    tmc$stid_task_id_28 = 28,
    tmc$stid_task_id_29 = 29,
    tmc$stid_task_id_30 = 30;
*DECK DECK=TMT$TASK_LOCAL_LINKED_SIGNAL EXPAND=FALSE

  TYPE
    tmt$task_local_linked_signal = record
      next_linked_signal: ^tmt$task_local_linked_signal,
      linked: tmt$signal,
      signal_execution_ring: tmt$handler_execution_ring,
    recend;

*copyc TMT$SIGNAL
*copyc TMT$HANDLER_EXECUTION_RING
*DECK DECK=TMT$TASK_LOCAL_SIGNAL_LIST EXPAND=FALSE

  TYPE
    tmt$task_local_signal_list = record
      delink: ^tmt$task_local_linked_signal,
      link: ^^tmt$task_local_linked_signal,
    recend;

*copyc TMT$TASK_LOCAL_LINKED_SIGNAL
*DECK DECK=TMT$TASK_QUEUE_LINK EXPAND=FALSE

{ TMDTQLK - contains the type declaration for task queue link.

  TYPE
    tmt$task_queue_link = record
      head: ost$task_index,
      tail: ost$task_index,
    recend;

*copyc OST$GLOBAL_TASK_ID
*DECK DECK=TMT$TASK_STATUS EXPAND=FALSE

{ This common deck contains the task status codes used by the
{ task management procedures that run in monitor mode.


{Define task status values. Task status' are divided into 3 groups depending on where tasks that
{are in the status are threaded in the dispatch tables.
{   GROUP 1A- tasks are linked into the DCT.
{   GROUP 1B- tasks are ready and have been selected to execute on a specific processor.
{   GROUP 2A- tasks are threaded into a timed wait queue.
{   GROUP 2B- tasks are in a timed wait, but will not be threaded into a timed wait queue until
{             closer to the end of wait time.
{   GROUP 3A- tasks are not in any queue. Tasks are waiting for a 'conditional' ready
{             task request.
{   GROUP 3B- tasks are not in any queue. However, tasks can only be made ready
{             by an 'unconditional' ready task request.
{   GROUP 3C- tasks are not in a DCT queue but are queued on some external event in a wait queue.
{             Tasks can only be placed or removed in/from these status via the
{             tmp$queue_task and tmp$dequeue_task requests.

  CONST
    tmc$ts_last_status_in_dct = tmc$ts_ready,
    tmc$ts_first_status_in_wait_q = tmc$ts_timeout_reqexp_shortshrt,
    tmc$ts_last_status_in_wait_q = tmc$ts_timeout_reqexp_longvlong,
    tmc$last_timed_wait_status = tmc$ts_timed_wait_not_queued,
    tmc$ts_first_ready_uncond = tmc$ts_io_wait_not_queued,
    tmc$ts_first_external_queue = tmc$ts_page_wait;


  TYPE
    tmt$task_status = (tmc$ts_null, tmc$ts_ready,
{                                                                         END GROUP 1A}
          tmc$ts_ready_and_selected,
{                                                                         END GROUP 1B}
          tmc$ts_timeout_reqexp_shortshrt,
          tmc$ts_timeout_reqexp_longlong, tmc$ts_timeout_reqexp_longvlong,
{                                                                         END GROUP 2A}
          tmc$ts_timed_wait_not_queued,
{                                                                         END GROUP 2B}
          tmc$ts_executing,
          tmc$ts_timeout_reqexp_inflong, tmc$ts_timeout_reqexp_infvlong,
          tmc$ts_ready_but_swapped,
{                                                                         END GROUP 3A}
          tmc$ts_io_wait_not_queued,
{                                                                         END GROUP 3B}
          tmc$ts_page_wait, tmc$ts_memory_wait, tmc$ts_segment_lock_wait,
          tmc$ts_job_event_queue, tmc$ts_io_wait_queued, tmc$ts_volume_unavailable),
{                                                                         END GROUP 3C}
    tmt$idle_status = (tmc$is_not_idled, tmc$is_idle_initiated, tmc$is_idled,
      tmc$is_idled_sched_notified),

    tmt$ready_condition = (tmc$rc_ready_conditional_wi, tmc$rc_ready_conditional);
*DECK DECK=TMT$WAIT_INHIBITED EXPAND=FALSE

  TYPE
     tmt$wait_inhibited = (tmc$wi_null, tmc$wi_wait_inhibited,
         tmc$wi_wait_selected, tmc$wi_wait_selected_r3);
*DECK DECK=TMT$WAIT_PREEMPTABILITY EXPAND=FALSE

  TYPE
    tmt$wait_preemptability = set of tmc$wait .. tmc$long_term_wait;

*copyc TMT$PREEMPTED_REASON
*DECK DECK=TMV$CPU_EXECUTION_STATISTICS EXPAND=FALSE

  VAR
    tmv$cpu_execution_statistics: [XREF] tmt$cpu_execution_statistics;

?? PUSH (LISTEXT := ON) ??
*copyc tmt$cpu_execution_statistics
?? POP ??
*DECK DECK=TMV$CYCLE_DELAY_TIME EXPAND=FALSE
{Define length of timeout that occurs when a user issues a 'CYCLE' request.

  VAR
    tmv$cycle_delay_time: [XREF] integer;

*DECK DECK=TMV$DCT EXPAND=FALSE

  VAR
    tmv$dct: [XREF] tmt$dispatch_control_table;

?? PUSH (LISTEXT := ON) ??
*copyc TMT$DISPATCH_CONTROL_TABLE
?? POP ??
*DECK DECK=TMV$DEDICATE_A_CPU_TO_NOS EXPAND=FALSE

  VAR
    tmv$dedicate_a_cpu_to_nos: [XREF] boolean;
*DECK DECK=TMV$DISPATCHING_CONTROLS EXPAND=FALSE

  VAR
    tmv$dispatching_controls: [XREF] tmt$dispatching_controls;

?? PUSH (LISTEXT := ON) ??
*copyc tmt$dispatching_controls
?? POP ??
*DECK DECK=TMV$DISPATCHING_CONTROL_SETS EXPAND=FALSE

  VAR
    tmv$dispatching_control_sets: [XREF] tmt$dispatching_control_sets;

?? PUSH (LISTEXT := ON) ??
*copyc tmt$dispatching_control_sets
?? POP ??
*DECK DECK=TMV$DISPATCHING_CONTROL_TIME EXPAND=FALSE

  VAR
    tmv$dispatching_control_time: [XREF] tmt$dispatching_prio_controls;

?? PUSH (LISTEXT := ON) ??
*copyc tmt$dispatching_prio_controls
?? POP ??
*DECK DECK=TMV$DISPATCH_PRIORITY_INTEGER EXPAND=FALSE

  VAR
    tmv$dispatch_priority_integer: [XREF] ARRAY [jmt$dispatching_priority] of integer;
*DECK DECK=TMV$DISPLAY_ACTUAL_PRIORITY EXPAND=FALSE

  VAR
    tmv$display_actual_priority: [XREF] boolean;
*DECK DECK=TMV$DUAL_STATE_DISPATCH_PRIOR EXPAND=FALSE

    VAR
      tmv$dual_state_dispatch_prior: [XREF] tmt$dual_state_dispatch_prior;

*copyc tmt$dual_state_dispatch_prior
*DECK DECK=TMV$FLAG_HANDLER_DESCRIPTIONS EXPAND=FALSE

  VAR
    tmv$flag_handler_descriptions: [XREF, oss$job_pageable] array [ost$system_flag] of
      tmt$pc_handler_description;

?? PUSH (LISTEXT := ON) ??
*copyc TMT$PC_HANDLER_DESCRIPTIONS
*copyc OSS$JOB_PAGEABLE
?? POP ??
*DECK DECK=TMV$HALT_ON_HUNG_TASK EXPAND=FALSE
{Define variables that control action taken by monitor when system errors occur.

  VAR
    tmv$halt_on_hung_task: [XREF] boolean,
    tmv$system_debug_ring: [XREF] integer,
  tmv$system_debug_segment: [XREF] integer,
    tmv$system_error_hang_count: [XREF] 0 .. 0ffffffff(16);

*DECK DECK=TMV$JOB_DEBUG_RING EXPAND=FALSE
VAR
  tmv$job_debug_ring: [XREF] ost$ring;

*copyc osd$virtual_address
*DECK DECK=TMV$JOB_DEBUG_RING_P EXPAND=FALSE

  VAR
    tmv$job_debug_ring_p: [XREF] ^ost$ring;

?? PUSH (LISTEXT := ON) ??
*copyc osd$virtual_address
?? POP ??
*DECK DECK=TMV$LONG_WAIT_FORCE_SWAP_TIME EXPAND=FALSE

{If a job goes into WAIT with a long time requested but expects a short time,
{the scheduler does not swap it out. If it doesnt go ready with the amount of ti
{specified by this constant, the scheduler will swap it out anyway.

  VAR
    tmv$long_wait_force_swap_time: [XREF] integer;

*DECK DECK=TMV$MAX_IDLE_SIT_VALUE EXPAND=FALSE

  VAR
    tmv$max_idle_sit_value: [XREF] integer;
*DECK DECK=TMV$MULTIPLE_CPUS_ACTIVE EXPAND=FALSE

  VAR
    tmv$multiple_cpus_active: [XREF] boolean;
*DECK DECK=TMV$NULL_GLOBAL_TASK_ID EXPAND=FALSE

  VAR
    tmv$null_global_task_id: [READ] ost$global_task_id := [0, 0];

*copyc OST$GLOBAL_TASK_ID
*DECK DECK=TMV$PTL_LOCK EXPAND=FALSE
VAR
    tmv$ptl_lock: [XREF] tmt$ptl_lock;
?? PUSH( LISTEXT := ON) ??
*copyc tmt$ptl_lock
?? POP ??
*DECK DECK=TMV$PTL_P EXPAND=FALSE

  VAR
    tmv$ptl_p: [XREF] ^tmt$primary_task_list;

?? PUSH (LISTEXT := ON) ??
*copyc TMT$PRIMARY_TASK_LIST
?? POP ??
*DECK DECK=TMV$SIGNAL_HANDLER_DESCRIPTIONS EXPAND=FALSE

  VAR
    tmv$signal_handler_descriptions: [XREF, oss$job_pageable] array [pmt$signal_id] of
      tmt$pc_handler_description;

?? PUSH (LISTEXT := ON) ??
*copyc TMT$PC_HANDLER_DESCRIPTIONS
*copyc OSS$JOB_PAGEABLE
?? POP ??
*DECK DECK=TMV$SWAPIN_IN_PROGRESS EXPAND=FALSE

  VAR
    tmv$swapin_in_progress: [XREF] integer;

*DECK DECK=TMV$SYSTEM_JOB_MONITOR_GTID EXPAND=FALSE

  VAR
    tmv$system_job_monitor_gtid: [XREF] ost$global_task_id;

*copyc ost$global_task_id

*DECK DECK=TMV$TABLES_INITIALIZED EXPAND=FALSE
 VAR
    tmv$tables_initialized: [XREF] boolean;
*DECK DECK=TMV$TIMED_WAIT_NOT_QUEUED EXPAND=FALSE

  VAR
    tmv$timed_wait_not_queued: [XREF] integer;

*DECK DECK=TMV$TOTAL_TASK_COUNT EXPAND=FALSE

  VAR
    tmv$total_task_count: [XREF] 0 .. tmc$maximum_ptl;

?? PUSH ( LISTEXT := ON) ??
*copyc tmt$primary_task_list
?? POP ??
*DECK DECK=TTI$CREATE_TEST_ENVIRONMENT_PD EXPAND=TRUE
create_program_description name=(create_test_environment, crete) ..
sp=ttp$create_test_environment m=ttm$create_test_environment ..
tel=warning l=$system.osf$site_command_library lmo=none lm=$null dm=off
*DECK DECK=TTI$DELETE_TEST_ENVIRONMENT_PD EXPAND=TRUE
create_program_description name=(delete_test_environment, delte) ..
sp=ttp$delete_test_environment m=ttm$delete_test_environment ..
tel=warning l=$system.osf$site_command_library lmo=none lm=$null dm=off
*DECK DECK=TTM$CREATE_TEST_ENVIRONMENT EXPAND=TRUE
MODULE ttm$create_test_environment;

{ PURPOSE:
{ Contains the procedures needed to create a test environment.

*copy amp$get_file_attributes
*copy amp$get_next
*copy amp$put_next
*copy clp$add_file_to_command_list
*copy clp$convert_string_to_file_ref
*copy clp$create_variable
*copy clp$change_variable
*copy clp$create_environment_variable
*copy clp$create_procedure_variable
*copy clp$delete_file_from_cmnd_list
*copy clp$evaluate_parameters
*copy clp$get_working_catalog
*copy clp$read_variable
*copy clp$get_variable_value
*copy clp$include_command
*copy clp$set_working_catalog
*copy clp$write_variable
*copy fsp$close_file
*copy fsp$open_file
*copy osp$set_status_abnormal
*copy pmp$exit
*copy pmp$get_user_identification
*copy pmp$log

{ Purpose:
{   The module contains the procedures needed to create the environment
{   for feature testing.
{ Design:
{   SCL job scope variables are initialized and object libraries are
{   added to the command list to enable the job to execute feature tests.

{ PROCEDURE (ttm$crete) crete_pdt (
{       use_catalog, uc              : file =
{         $fname(':'//$string($job_default(lf))//'.testve')
{       tool_library, tl             :  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = .test_tools.bound_product
{       test_development_library, tdl:  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = NOT_AVAILABLE
{       feature_test_procedures, ftp :  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = .osf$f_test_procedures
{       feature_test_binary, ftb     :  any of
{                                         key not_available keyend
{                                       file
{                                       anyend = .osf$f_test_binaries
{       feature_test_data, ftd       :  any of
{                                         key not_available keyend
{                                       file
{                                       anyend = .osf$f_test_data
{       scu_test_procedures, stp     :  any of
{                                         key not_available keyend
{                                       file
{                                       anyend = .scf$f_test_procedures
{       scu_test_binary, stb         :  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = NOT_AVAILABLE
{       scu_test_data, std           :  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = .scf$f_test_data
{       cybil_test_procedures, ctp   :  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = NOT_AVAILABLE
{       cybil_test_binary, ctb       :  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = NOT_AVAILABLE
{       cybil_test_data, ctd         :  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = NOT_AVAILABLE
{       ocu_test_procedures, otp     :  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = .ocf$f_test_procedures
{       ocu_test_binary, otb         :  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = .ocf$f_test_binaries
{       ocu_test_data, otd           :  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = NOT_AVAILABLE
{       product_set_test_data,pstd   :  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = .psf$p_test_data
{       system_test_procedures, sytp :  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = .stf$test_procedures
{       system_test_binary, sytb     :  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = .stf$test_binaries
{       system_test_data, sytd       :  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = .stf$test_data
{       wef_test_procedures, wtp     :  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = NOT_AVAILABLE
{       wef_test_binary, wtb         :  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = NOT_AVAILABLE
{       password_suffix, pws         : string = 'pw'
{       product_set_version, psv     : string 5 = '*****'
{       tape_vsn, tv                 : string 1..6 = $optional
{       tape_density, td             : key mt9$800, mt9$1600, mt9$6250, ..
{                                        mt18$38000 keyend = mt9$6250
{       remote_family,ref            : string = ''
{       cybil_path, cp               :  any of
{                                         key not_available keyend
{                                         file
{                                       anyend = NOT_AVAILABLE
{       results_file, rf             :  file = $user.ttf$results
{       log_option, lo               :  any of
{                                         key printer,p keyend
{                                         file
{                                       anyend = printer
{       status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 59] of clt$pdt_parameter_name,
      parameters: array [1 .. 30] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        default_value: string (49),
      recend,
      type2: 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,
        recend,
        default_value: string (25),
      recend,
      type3: 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,
        recend,
        default_value: string (13),
      recend,
      type4: 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,
        recend,
        default_value: string (22),
      recend,
      type5: 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,
        recend,
        default_value: string (20),
      recend,
      type6: 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,
        recend,
        default_value: string (16),
      recend,
      type7: 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,
        recend,
        default_value: string (22),
      recend,
      type8: 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,
        recend,
        default_value: string (13),
      recend,
      type9: 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,
        recend,
        default_value: string (16),
      recend,
      type10: 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,
        recend,
        default_value: string (13),
      recend,
      type11: 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,
        recend,
        default_value: string (13),
      recend,
      type12: 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,
        recend,
        default_value: string (13),
      recend,
      type13: 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,
        recend,
        default_value: string (22),
      recend,
      type14: 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,
        recend,
        default_value: string (20),
      recend,
      type15: 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,
        recend,
        default_value: string (13),
      recend,
      type16: 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,
        recend,
        default_value: string (16),
      recend,
      type17: 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,
        recend,
        default_value: string (20),
      recend,
      type18: 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,
        recend,
        default_value: string (18),
      recend,
      type19: 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,
        recend,
        default_value: string (14),
      recend,
      type20: 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,
        recend,
        default_value: string (20),
      recend,
      type21: 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,
        recend,
        default_value: string (20),
      recend,
      type22: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (4),
      recend,
      type23: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (7),
      recend,
      type24: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type25: record
        header: clt$type_specification_header,
        qualifier: clt$keyword_type_qualifier,
        keyword_specs: array [1 .. 4] of clt$keyword_specification,
        default_value: string (8),
      recend,
      type26: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
        default_value: string (2),
      recend,
      type27: 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,
        recend,
        default_value: string (13),
      recend,
      type28: record
        header: clt$type_specification_header,
        default_value: string (17),
      recend,
      type29: 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 .. 2] of clt$keyword_specification,
        recend,
        type_size_2: clt$type_specification_size,
        element_type_spec_2: record
          header: clt$type_specification_header,
        recend,
        default_value: string (7),
      recend,
      type30: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [89, 7, 20, 7, 55, 26, 700],
    clc$command, 59, 30, 0, 0, 0, 0, 30, 'TTM$CRETE'], [
    ['CP                             ',clc$abbreviation_entry, 27],
    ['CTB                            ',clc$abbreviation_entry, 11],
    ['CTD                            ',clc$abbreviation_entry, 12],
    ['CTP                            ',clc$abbreviation_entry, 10],
    ['CYBIL_PATH                     ',clc$nominal_entry, 27],
    ['CYBIL_TEST_BINARY              ',clc$nominal_entry, 11],
    ['CYBIL_TEST_DATA                ',clc$nominal_entry, 12],
    ['CYBIL_TEST_PROCEDURES          ',clc$nominal_entry, 10],
    ['FEATURE_TEST_BINARY            ',clc$nominal_entry, 5],
    ['FEATURE_TEST_DATA              ',clc$nominal_entry, 6],
    ['FEATURE_TEST_PROCEDURES        ',clc$nominal_entry, 4],
    ['FTB                            ',clc$abbreviation_entry, 5],
    ['FTD                            ',clc$abbreviation_entry, 6],
    ['FTP                            ',clc$abbreviation_entry, 4],
    ['LO                             ',clc$abbreviation_entry, 29],
    ['LOG_OPTION                     ',clc$nominal_entry, 29],
    ['OCU_TEST_BINARY                ',clc$nominal_entry, 14],
    ['OCU_TEST_DATA                  ',clc$nominal_entry, 15],
    ['OCU_TEST_PROCEDURES            ',clc$nominal_entry, 13],
    ['OTB                            ',clc$abbreviation_entry, 14],
    ['OTD                            ',clc$abbreviation_entry, 15],
    ['OTP                            ',clc$abbreviation_entry, 13],
    ['PASSWORD_SUFFIX                ',clc$nominal_entry, 22],
    ['PRODUCT_SET_TEST_DATA          ',clc$nominal_entry, 16],
    ['PRODUCT_SET_VERSION            ',clc$nominal_entry, 23],
    ['PSTD                           ',clc$abbreviation_entry, 16],
    ['PSV                            ',clc$abbreviation_entry, 23],
    ['PWS                            ',clc$abbreviation_entry, 22],
    ['REF                            ',clc$abbreviation_entry, 26],
    ['REMOTE_FAMILY                  ',clc$nominal_entry, 26],
    ['RESULTS_FILE                   ',clc$nominal_entry, 28],
    ['RF                             ',clc$abbreviation_entry, 28],
    ['SCU_TEST_BINARY                ',clc$nominal_entry, 8],
    ['SCU_TEST_DATA                  ',clc$nominal_entry, 9],
    ['SCU_TEST_PROCEDURES            ',clc$nominal_entry, 7],
    ['STATUS                         ',clc$nominal_entry, 30],
    ['STB                            ',clc$abbreviation_entry, 8],
    ['STD                            ',clc$abbreviation_entry, 9],
    ['STP                            ',clc$abbreviation_entry, 7],
    ['SYSTEM_TEST_BINARY             ',clc$nominal_entry, 18],
    ['SYSTEM_TEST_DATA               ',clc$nominal_entry, 19],
    ['SYSTEM_TEST_PROCEDURES         ',clc$nominal_entry, 17],
    ['SYTB                           ',clc$abbreviation_entry, 18],
    ['SYTD                           ',clc$abbreviation_entry, 19],
    ['SYTP                           ',clc$abbreviation_entry, 17],
    ['TAPE_DENSITY                   ',clc$nominal_entry, 25],
    ['TAPE_VSN                       ',clc$nominal_entry, 24],
    ['TD                             ',clc$abbreviation_entry, 25],
    ['TDL                            ',clc$abbreviation_entry, 3],
    ['TEST_DEVELOPMENT_LIBRARY       ',clc$nominal_entry, 3],
    ['TL                             ',clc$abbreviation_entry, 2],
    ['TOOL_LIBRARY                   ',clc$nominal_entry, 2],
    ['TV                             ',clc$abbreviation_entry, 24],
    ['UC                             ',clc$abbreviation_entry, 1],
    ['USE_CATALOG                    ',clc$nominal_entry, 1],
    ['WEF_TEST_BINARY                ',clc$nominal_entry, 21],
    ['WEF_TEST_PROCEDURES            ',clc$nominal_entry, 20],
    ['WTB                            ',clc$abbreviation_entry, 21],
    ['WTP                            ',clc$abbreviation_entry, 20]],
    [
{ PARAMETER 1
    [55, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 49],
{ PARAMETER 2
    [52, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 25],
{ PARAMETER 3
    [50, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 13],
{ PARAMETER 4
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 22],
{ PARAMETER 5
    [9, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 20],
{ PARAMETER 6
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 16],
{ PARAMETER 7
    [35, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 22],
{ PARAMETER 8
    [33, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 13],
{ PARAMETER 9
    [34, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 16],
{ PARAMETER 10
    [8, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 13],
{ PARAMETER 11
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 13],
{ PARAMETER 12
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 13],
{ PARAMETER 13
    [19, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 22],
{ PARAMETER 14
    [17, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 20],
{ PARAMETER 15
    [18, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 13],
{ PARAMETER 16
    [24, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 16],
{ PARAMETER 17
    [42, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 20],
{ PARAMETER 18
    [40, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 18],
{ PARAMETER 19
    [41, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 14],
{ PARAMETER 20
    [57, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 20],
{ PARAMETER 21
    [56, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 20],
{ PARAMETER 22
    [23, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 4],
{ PARAMETER 23
    [25, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 7],
{ PARAMETER 24
    [47, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_parameter, 0, 0],
{ PARAMETER 25
    [46, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 155, clc$optional_default_parameter, 0, 8],
{ PARAMETER 26
    [30, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 8, clc$optional_default_parameter, 0, 2],
{ PARAMETER 27
    [5, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$optional_default_parameter, 0, 13],
{ PARAMETER 28
    [31, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 17],
{ PARAMETER 29
    [16, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 104, clc$optional_default_parameter, 0, 7],
{ PARAMETER 30
    [36, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$file_type],
    '$fname('':''//$string($job_default(lf))//''.testve'')'],
{ PARAMETER 2
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    '.test_tools.bound_product'],
{ PARAMETER 3
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'NOT_AVAILABLE'],
{ PARAMETER 4
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    '.osf$f_test_procedures'],
{ PARAMETER 5
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    '.osf$f_test_binaries'],
{ PARAMETER 6
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    '.osf$f_test_data'],
{ PARAMETER 7
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    '.scf$f_test_procedures'],
{ PARAMETER 8
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'NOT_AVAILABLE'],
{ PARAMETER 9
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    '.scf$f_test_data'],
{ PARAMETER 10
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'NOT_AVAILABLE'],
{ PARAMETER 11
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'NOT_AVAILABLE'],
{ PARAMETER 12
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'NOT_AVAILABLE'],
{ PARAMETER 13
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    '.ocf$f_test_procedures'],
{ PARAMETER 14
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    '.ocf$f_test_binaries'],
{ PARAMETER 15
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'NOT_AVAILABLE'],
{ PARAMETER 16
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    '.psf$p_test_data'],
{ PARAMETER 17
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    '.stf$test_procedures'],
{ PARAMETER 18
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    '.stf$test_binaries'],
{ PARAMETER 19
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    '.stf$test_data'],
{ PARAMETER 20
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'NOT_AVAILABLE'],
{ PARAMETER 21
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'NOT_AVAILABLE'],
{ PARAMETER 22
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE],
    '''pw'''],
{ PARAMETER 23
    [[1, 0, clc$string_type], [5, 5, FALSE],
    '''*****'''],
{ PARAMETER 24
    [[1, 0, clc$string_type], [1, 6, FALSE]],
{ PARAMETER 25
    [[1, 0, clc$keyword_type], [4], [
    ['MT18$38000                     ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
    ['MT9$1600                       ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
    ['MT9$6250                       ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
    ['MT9$800                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
    ,
    'mt9$6250'],
{ PARAMETER 26
    [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE],
    ''''''],
{ PARAMETER 27
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['NOT_AVAILABLE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'NOT_AVAILABLE'],
{ PARAMETER 28
    [[1, 0, clc$file_type],
    '$user.ttf$results'],
{ PARAMETER 29
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    81, [[1, 0, clc$keyword_type], [2], [
      ['P                              ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
      ['PRINTER                        ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ,
    'printer'],
{ PARAMETER 30
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$use_catalog = 1,
      p$tool_library = 2,
      p$test_development_library = 3,
      p$feature_test_procedures = 4,
      p$feature_test_binary = 5,
      p$feature_test_data = 6,
      p$scu_test_procedures = 7,
      p$scu_test_binary = 8,
      p$scu_test_data = 9,
      p$cybil_test_procedures = 10,
      p$cybil_test_binary = 11,
      p$cybil_test_data = 12,
      p$ocu_test_procedures = 13,
      p$ocu_test_binary = 14,
      p$ocu_test_data = 15,
      p$product_set_test_data = 16,
      p$system_test_procedures = 17,
      p$system_test_binary = 18,
      p$system_test_data = 19,
      p$wef_test_procedures = 20,
      p$wef_test_binary = 21,
      p$password_suffix = 22,
      p$product_set_version = 23,
      p$tape_vsn = 24,
      p$tape_density = 25,
      p$remote_family = 26,
      p$cybil_path = 27,
      p$results_file = 28,
      p$log_option = 29,
      p$status = 30;

    VAR
      pvt: array [1 .. 30] of clt$parameter_value;
  TYPE
    string_line = string (256);

  VAR
    exit_message: string_line,
    length: integer,
    opened: boolean := FALSE,
    output_id: amt$file_identifier;

?? FMT (FORMAT := ON) ??

{ PURPOSE:
{ This function returns the length in characters of the input string
{ DESIGN:
{ Counts down blanks and returns length when a non-blank is found.

  FUNCTION strlen#
    (    input_string: string ( * )): integer;

    VAR
      i: integer;

    strlen# := 0;

  /count_loop/
    FOR i := #SIZE (input_string) DOWNTO 1 DO
      IF input_string (i) <> ' ' THEN
        strlen# := i;
        EXIT /count_loop/; {----->
      IFEND;
    FOREND /count_loop/;

  FUNCEND strlen#;

{ PURPOSE:
{   This procedure displays the string output_str to $OUTPUT.
{ DESIGN:
{   A global variable OPENED is used so that the FSP$OPEN call
{   needs to be made only once.

  PROCEDURE output_message#
    (    output_str: string ( * ));

    VAR
      fba: amt$file_byte_address,
      lfn: amt$local_file_name,
      local_status: ost$status,
      open_attrib: array [1 .. 1] of amt$access_selection;

    IF NOT opened THEN
      fsp$open_file ('$OUTPUT', amc$record, NIL, NIL, NIL, NIL, NIL, output_id,
            local_status);
      IF NOT local_status.normal THEN
        pmp$exit (local_status);
      IFEND;
      opened := TRUE;
    IFEND;
    amp$put_next (output_id, ^output_str, strlen# (output_str), fba,
          local_status);
    IF NOT local_status.normal THEN
      pmp$exit (local_status);
    IFEND;

  PROCEND output_message#;

{ PURPOSE:
{ Write to the job log the SCL test tool variable and its value.
{ DESIGN:
{ Use pmp$log.

  PROCEDURE output_var_to_log#
    (    var_name: string ( * );
         var_value: string ( * ));

    VAR
      length: integer,
      log_status: ost$status,
      output_line: ost$string;

    output_line.value := '';
    STRINGREP (output_line.value, length, var_name, var_value);
    pmp$log (output_line.value (1, length), log_status);

  PROCEND output_var_to_log#;

{ PURPOSE:
{ Create an SCL string variable if one does not already exist.
{ DESIGN:
{ Clp$read_variable is used to determine if the variable exists.

  PROCEDURE create_test_tool_var#
    (    variable_name: string ( * );
     VAR variable_ref: clt$variable_reference;
     VAR already_exists: boolean);

    VAR
      length: integer,
      local_status: ost$status,
      var_scope: clt$variable_scope;

    clp$read_variable (variable_name, variable_ref, local_status);
    IF local_status.condition = cle$unknown_variable THEN

{ variable not created yet

      already_exists := FALSE;
      var_scope.kind := clc$job_variable;
      clp$create_variable (variable_name, clc$string_value,
            osc$max_string_size, 1, 1, var_scope, variable_ref, local_status);
      IF NOT local_status.normal THEN
        IF local_status.condition = cle$var_already_created THEN
          already_exists := TRUE;
          var_scope.kind := clc$xref_variable;
          clp$create_variable (variable_name, clc$string_value,
                osc$max_string_size, 1, 1, var_scope, variable_ref,
                local_status);
          IF NOT local_status.normal THEN
            pmp$exit (local_status);
          IFEND;
          clp$read_variable (variable_name, variable_ref, local_status);
          IF NOT local_status.normal THEN
            pmp$exit (local_status);
          IFEND;
        ELSE
          pmp$exit (local_status);
        IFEND;
      IFEND;
    ELSE
      already_exists := TRUE;
    IFEND;

  PROCEND create_test_tool_var#;

{ PURPOSE:
{   This procedure writes the value of variable_string to the SCL variable
{   identified by variable_name.
{ DESIGN:
{   Variable_ref contains the reference to the
{   SCL variable.  #UNCHECKED_CONVERSION is used because the string field of
{   CLT$VARIABLE_REFERENCE is an array of cells, this means that type checking
{   can not be performed when copying the string to the variable reference
{   field.

  PROCEDURE write_test_tool_str_var#
    (    variable_name: string ( * );
     VAR variable_ref: clt$variable_reference;
         variable_string: ost$string);

    VAR
      length: integer,
      local_status: ost$status,
      string_var_cell_array: ^array [1 .. * ] of cell;

    PUSH string_var_cell_array: [1 .. #SIZE (variable_string)];
    #UNCHECKED_CONVERSION (variable_string, string_var_cell_array^);
    variable_ref.value.string_value := string_var_cell_array;
    clp$write_variable (variable_name, variable_ref.value, local_status);
    IF NOT local_status.normal THEN
      pmp$exit (local_status);
    IFEND;

  PROCEND write_test_tool_str_var#;

{ PURPOSE:
{ Insure that the intended testing family_name will be used.
{ DESIGN:
{ The family_name found on the USE_CATALOG parameter will be substitued for
{ the one found in the file_string.

  PROCEDURE substitute_use_catalog_fam#
    (    test_tool_family: string ( * );
     VAR file_string: ost$string);

    VAR
      def_family_name_length: integer,
      identification: ost$user_identification,
      length: integer,
      local_status: ost$status,
      temp_string: ost$string;

    pmp$get_user_identification (identification, local_status);

{ Returns default family

    def_family_name_length := strlen# (identification.family) + 2;
    temp_string.value := '';

{ Overwrite file_ref family with test_tool family

    STRINGREP (temp_string.value, length,
          test_tool_family (1, strlen# (test_tool_family)),
          file_string.value (def_family_name_length, file_string.size));
    temp_string.size := length;
    file_string := temp_string;

  PROCEND substitute_use_catalog_fam#;

{ PURPOSE:
{ This procedure makes sure that a given library has the correct attributes
{ DESIGN:
{ The values of all variables are checked to verify that the libraries
{ and files which will be used exist and are of the proper type.  If
{ abnormalities exist, the user is notified.

  PROCEDURE check_library_validity#
    (    library_name: string ( * );
         library_variable: fst$parsed_file_reference;
         library_type: string ( * );
     VAR library_valid: boolean);

    VAR
      contains_data: boolean,
      file_attributes: ^amt$get_attributes,
      length: integer,
      lib_contents: ost$name,
      lib_processor: ost$name,
      lib_structure: ost$name,
      local_file: boolean,
      local_status: ost$status,
      message: string_line,
      perm_file: boolean;

    PUSH file_attributes: [1 .. 4];
    file_attributes^ [1].key := amc$file_length;
    file_attributes^ [2].key := amc$file_contents;
    file_attributes^ [3].key := amc$file_processor;
    file_attributes^ [4].key := amc$file_structure;

    IF library_type = 'OBJECT' THEN
      lib_contents := 'OBJECT';
      lib_processor := 'UNKNOWN';
      lib_structure := 'LIBRARY';
    ELSE

{ library_type = 'SOURCE'

      lib_contents := 'LEGIBLE';
      lib_processor := 'SCU';
      lib_structure := 'LIBRARY';
    IFEND;

    library_valid := TRUE;
    amp$get_file_attributes (library_variable.path, file_attributes^,
         local_file, perm_file, contains_data, local_status);
    IF NOT local_status.normal THEN
      pmp$exit (local_status);
    IFEND;
    message := '';
    IF file_attributes^ [1].file_length = 0 THEN
      library_valid := FALSE;
      STRINGREP (message, length, ' --WARNING:  Library specified for ',
            library_name (5, strlen# (library_name)), ' is empty.');
      output_message# (message);
      exit_message := message;
ELSEIF (file_attributes^ [2].file_contents <> lib_contents) OR
          (file_attributes^ [3].file_processor <> lib_processor) OR
          (file_attributes^ [4].file_structure <> lib_structure) THEN
      library_valid := FALSE;
      STRINGREP (message, length, ' --WARNING:   Library specified for ',
            library_name (5, strlen# (library_name)), ' is not an ',
            library_type (1, strlen# (library_type)), ' library.');
      output_message# (message);
      exit_message := message;
    IFEND;
  PROCEND check_library_validity#;


{ PURPOSE:
{ Process and save the parameter list of create_test_environment.
{ DESIGN:
{ For each parameter, create the appropriate TTV$ job variable and assign
{ the appropriate value. For file type parameters call PROCESS_FILE_PARAMETER#
{ to check that the attributes of the file match the intended application.
{ Finally put the parameter list in the job variable ttv$crete_param_list.
{ NOTE:
{ The first parameter must be use_catalog as the other parameter values are
{ dependent on its value, and since we process the parameter list from
{ beginning to end.

  PROCEDURE process_crete_param_list#;

    VAR
      cmnd_list_candidate: boolean,
      length: integer,
      library_file: fst$parsed_file_reference,
      library_type: ost$string,
      library_valid : boolean,
      local_status: ost$status,
      log_status: ost$status,
      message: string_line,
      param_list: ost$string,
      parameter_index: integer,
      parameter_string: ost$string,
      parameter_value: clt$data_value,
      pdt_index: integer,
      pdt_name: clt$parameter_name,
      use_catalog :ost$string,
      var_exists: boolean,
      var_name : ost$name,
      var_reference: clt$variable_reference,
      variable_report: ost$string;

    param_list.value := '';
    param_list.size := 0;
    FOR parameter_index := 1 TO (p$status - 1) DO
      variable_report.value := '';
      pdt_index:=pdt.parameters [parameter_index].name_index;
      pdt_name:=pdt.names [pdt_index].name;
      var_name := '';
      STRINGREP (var_name, length, 'TTV$', pdt_name (1, strlen# (pdt_name)));
      create_test_tool_var# (var_name, var_reference, var_exists);
      IF pvt [parameter_index].value <> NIL THEN
        parameter_value := pvt [parameter_index].value^;
        parameter_string.value := '';
        parameter_string.size := 0;
        CASE parameter_value.kind OF
        = clc$keyword =
          parameter_string.value := parameter_value.keyword_value;
          parameter_string.size := strlen# (parameter_value.keyword_value);
        = clc$string =
          parameter_string.value := parameter_value.string_value^;
          parameter_string.size := strlen# (parameter_value.string_value^);
        = clc$name =
          parameter_string.value := parameter_value.name_value;
          parameter_string.size := strlen# (parameter_string.value);
        = clc$file =
          clp$convert_string_to_file_ref (parameter_value.file_value^,
              library_file, local_status);
          IF NOT local_status.normal THEN
            pmp$exit (local_status);
          IFEND;
          parameter_string.value := library_file.path;
          parameter_string.size := strlen# (parameter_string.value);
          IF var_name = 'TTV$USE_CATALOG' THEN
            use_catalog := parameter_string;
          ELSEIF (NOT pvt [parameter_index].specified) AND
                 (NOT (var_name = 'TTV$RESULTS_FILE')) THEN
            substitute_use_catalog_fam# (use_catalog.value, parameter_string);
            library_file.path := parameter_string.value;
          IFEND;
          library_valid:=FALSE;
          cmnd_list_candidate := FALSE;
          library_type.value :='UNKNOWN';
          process_file_type#(var_name, library_type.value,
              cmnd_list_candidate);
          IF library_type.value = 'UNKNOWN' THEN
            process_stndrd_files# (var_name, parameter_string, library_file);
          ELSE
            check_library_validity#(var_name, library_file,
                library_type.value, library_valid);
            IF library_valid THEN
              IF (library_type.value= 'OBJECT') AND (cmnd_list_candidate) THEN
                add_file_to_cmnd_list#(var_name, parameter_string,
                    library_file);
              IFEND;
            ELSE      { IF not library_valid
              parameter_string.value := 'INVALID_LIBRARY';
              parameter_string.size := strlen# (parameter_string.value);
              message := '';
              STRINGREP (message, length, ' --WARNING:  ',
                  pdt_name (1, strlen# (pdt_name)),
                  ' reset to INVALID_LIBRARY.');
              pmp$log (message (1, strlen# (message)), log_status);
              exit_message := message;
            IFEND;
          IFEND;
        CASEND;
        write_test_tool_str_var# (var_name, var_reference,
            parameter_string);
        STRINGREP (variable_report.value, length, ' = ', parameter_string.value
            (1, parameter_string.size));
        output_var_to_log# (var_name, variable_report.value (1,length));

        IF (pvt [parameter_index].specified) THEN
          STRINGREP (param_list.value, length, param_list.
              value (1, strlen# (param_list.value) + 1),
              pdt_name (1, strlen# (pdt_name)), '=', parameter_string.value
              (1, parameter_string.size), ' ');
          param_list.size := length;
        IFEND;
      IFEND;
    FOREND;
    write_test_tool_str_var# ('TTV$CRETE_PARAM_LIST', var_reference,
          param_list);
    output_var_to_log# ('ttv$crete_param_list = ', param_list.
          value (1, param_list.size));
  PROCEND process_crete_param_list#;

{ PURPOSE:
{ Process results, log and other non-library parameters.
{ DESIGN:
{ Any file needing special attention will be handled here: The RESULTS_FILE
{ needs to ensure a permanent file path was specified and the LOG_FILE needs
{ to be opened to allow failing tests to write to it.

  PROCEDURE process_stndrd_files#
    (    parameter_name: ost$name;
         parameter_value: ost$string;
         library_file: fst$parsed_file_reference);

    VAR
      command_line :string_line,
      echo :boolean,
      first_name : fst$path_element_substring,
      length : integer,
      local_status : ost$status,
      log_option_attachment_options: array [1 .. 1] of fst$attachment_option,
      log_option_file_identifier: amt$file_identifier,
      log_status : ost$status;

    IF parameter_name = 'TTV$RESULTS_FILE' THEN
      command_line := '';
      STRINGREP (command_line, length, 'DISPLAY_CATALOG_ENTRY F=',
          parameter_value.value (1, parameter_value.size), ' O=$NULL');
      echo := FALSE;
      clp$include_command (command_line, echo, log_status);
      IF (NOT log_status.normal) THEN
        IF (log_status.condition <>pfe$unknown_permanent_file) THEN
          exit_message := ' --ERROR:  The RESULTS_FILE parameter must be' CAT
              ' a valid permanent file path.';
          output_message# (exit_message);
          pmp$log (exit_message (1, strlen# (exit_message)), local_status);
          exit_message := '          CRETE Used Display_Catalog_Entry to' CAT
              ' certify the parameter.';
          output_message# (exit_message);
          pmp$log (exit_message (1, strlen# (exit_message)), local_status);
          exit_message := '          The following status was returned:';
          output_message# (exit_message);
          pmp$log (exit_message (1, strlen# (exit_message)), local_status);
          pmp$exit (log_status);
        IFEND;
      IFEND;
    ELSEIF parameter_name = 'TTV$LOG_OPTION' THEN
      IF parameter_value.value <> 'PRINTER' THEN

{ Create a log file used for failed tests.

        log_option_attachment_options [1].selector :=
             fsc$access_and_share_modes;
        log_option_attachment_options [1].access_modes.selector :=
             fsc$specific_access_modes;
        log_option_attachment_options [1].access_modes.value :=
             $fst$file_access_options [fsc$append];
        log_option_attachment_options [1].share_modes.selector :=
             fsc$specific_share_modes;
        log_option_attachment_options [1].share_modes.value :=
             $fst$file_access_options [];
        fsp$open_file (parameter_value.value, amc$record,
             ^log_option_attachment_options, NIL, NIL, NIL, NIL,
             log_option_file_identifier, local_status);
        IF NOT local_status.normal THEN
          IF local_status.condition <> pfe$cycle_busy THEN
            pmp$exit (local_status);
          IFEND;
        ELSE
          fsp$close_file (log_option_file_identifier, local_status);
          IF NOT local_status.normal THEN
            pmp$exit (local_status);
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND process_stndrd_files#;

{ PURPOSE:
{ Libraries needed for the test environment are added to the command list.g
{ DESIGN:
{ The library specified will be added to the command list. If it is the tool
{ library it will be added to the top of the command list else it will be
{ placed at the bottom of the command list.

 PROCEDURE add_file_to_cmnd_list#
    (    parameter_name: ost$name;
         parameter_value: ost$string;
         library_file: fst$parsed_file_reference);

  VAR
    command_line: string_line,
    command_list_file : clt$command_list_entry_file,
    echo : boolean,
    element_ptr : ^clt$data_value,
    length : integer,
    link_ptr : ^clt$data_value,
    local_status : ost$status,
    log_status: ost$status,
    message: string_line,
    next_value : clt$data_value,
    next_ptr : clt$data_value,
    prev_ptr : ^clt$data_value,
    var_value : ^clt$data_value;

    command_list_file.kind := clc$command_list_entry_path;
    command_list_file.path := ^library_file.path;
{ Add libraries to the end of the command list except the tool_library.

    IF parameter_name <> 'TTV$TOOL_LIBRARY' THEN
      clp$add_file_to_command_list (command_list_file, TRUE, local_status);
    ELSE
      clp$add_file_to_command_list (command_list_file, FALSE, local_status);
    IFEND;
    IF local_status.normal THEN
       clp$get_variable_value ('TTV$LIBRARIES_ADDED', var_value, local_status);
       IF NOT local_status.normal THEN
         pmp$exit(local_status);
       IFEND;
       next_value.kind := clc$string;
       next_value.string_value := ^parameter_value.value;
       next_ptr.kind := clc$list;
       next_ptr.element_value := ^next_value;
       next_ptr.link := NIL;
       link_ptr := var_value^.link;
       prev_ptr := var_value;
       element_ptr :=var_value^.element_value;
       IF element_ptr = NIL THEN
         var_value:= ^next_ptr;
       ELSE
        While (link_ptr <> NIL) DO
           element_ptr :=link_ptr^.element_value;
           prev_ptr := link_ptr;
           link_ptr :=link_ptr^.link;
         Whilend;
         prev_ptr^.link:= ^next_ptr;
       IFEND;
       clp$change_variable('TTV$LIBRARIES_ADDED',var_value, local_status);

    ELSEIF local_status.condition <> cle$duplicate_command_list_ent THEN
      message := '';
      STRINGREP (message, length,
          ' ## Create_test_environment unable to crecle e=',
          parameter_value.value (1, strlen# (parameter_value.value)));
      output_message# (message);
      exit_message := message;
      command_line := '';
      echo := FALSE;
      STRINGREP (command_line, length, 'display_value $condition(',
           local_status.condition, ')  o=$job_log');
      clp$include_command (command_line, echo, log_status);
      command_line := '';
      STRINGREP (command_line, length, 'display_value $condition(',
           local_status.condition, ')  O=$output');
      clp$include_command (command_line, echo, log_status);
      message := '';
      message := ' --WARNING:  Create_test_environment continuing ...';
      output_message# (message);
    IFEND;
    IF parameter_name = 'TTV$TOOL_LIBRARY' THEN
      command_line := '';
      STRINGREP (command_line, length, 'SET_PROGRAM_ATTRIBUTES AL=',
          parameter_value.value (1, strlen# (parameter_value.value)));
      echo := FALSE;
      clp$include_command (command_line, echo, local_status);
    IFEND;
  PROCEND add_file_to_cmnd_list#;

{ PURPOSE:
{ Process each File Type Parameter to record what type of additional processing
{ CRETE should do to add libraries to the command list or to set the values of
{ results and log type files.
{ DESIGN:
{ Each file will fall into one of four categories - Source, Binary(add to cmnd
{ list), Binary(do not add to cmnd list) and Unknown.  The parameter name will
{ determine the file type since standards were defined where any "data" file
{ is a SOURCE library, any "procedures" file is an OBJECT file and will be
{ added by crete to the command list, any "binary" file is an OBJECT fil that
{ will not be added to the command list, and any other file is an UNKNOWN file
{ to be used for logs and results_files.

  PROCEDURE process_file_type#
    (    parameter_name: ost$name;
         VAR library_type : string (*);
         VAR cmnd_list_candidate: boolean);

    VAR
      binary_key : ost$string,
      data_key : ost$string,
      I : integer,
      length: integer,
      local_status: ost$status,
      param_var: ost$string,
      procedure_key :ost$string;

    procedure_key.value :='_TEST_PROCEDURES';
    procedure_key.size :=16;
    binary_key.value :='_TEST_BINARY';
    binary_key.size := 12;
    data_key.value :='_TEST_DATA';
    data_key.size := 10;
    param_var.value := parameter_name;
    param_var.size := Strlen#(parameter_name);

    FOR I := 1 TO (param_var.size+1-procedure_key.size) DO
      IF param_var.value(i,procedure_key.size) = procedure_key.value(1,*) THEN
        library_type:= 'OBJECT ';
        cmnd_list_candidate := TRUE;
      IFEND;
    FOREND;
    IF library_type = 'UNKNOWN' THEN
      FOR I := 1 TO (param_var.size+1-binary_key.size) DO
        IF param_var.value(i,binary_key.size) = binary_key.value(1,*) THEN
          library_type:= 'OBJECT ';
          cmnd_list_candidate := FALSE;
        IFEND;
      FOREND;
    IFEND;
    IF library_type = 'UNKNOWN' THEN
      FOR I := 1 TO (param_var.size+1-data_key.size) DO
        IF param_var.value(i,data_key.size) = data_key.value(1,*) THEN
          library_type:= 'SOURCE ';
          cmnd_list_candidate := FALSE;
        IFEND;
      FOREND;
    IFEND;
    IF (library_type='UNKNOWN') THEN
      IF (param_var.value='TTV$TOOL_LIBRARY') THEN
         library_type:= 'OBJECT ';
         cmnd_list_candidate := TRUE;
      ELSEIF (param_var.value='TTV$TEST_DEVELOPMENT_LIBRARY') THEN
         library_type:= 'OBJECT ';
         cmnd_list_candidate := FALSE;
      IFEND;
    IFEND;
  PROCEND process_file_type#;

{ PURPOSE:
{ Remove command list entries added by previous calls to CRETE.
{ DESIGN:
{ On subsequent calls to CRETE, to remove specified test and test_tool
{ libraries from the command list, check the TTV$LIBRARIES_ADDED variable
{ to determine if CRETE was responsible for adding the library before
{ allowing CRETE to remove the library.

  PROCEDURE  remove_added_cmd_list_entries#;

    VAR
      command_list_file : clt$command_list_entry_file,
      command_line : string_line,
      echo : boolean,
      init_var_value: clt$data_value,
      library_file: fst$parsed_file_reference,
      list_element_ptr: ^clt$data_value,
      list_link_ptr: ^clt$data_value,
      list_type_spec: [STATIC, READ, cls$declaration_section] record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$string_type_qualifier,
        recend,
      recend := [[1, 0, clc$list_type], [8, 0, clc$max_list_size, FALSE],
        [[1, 0, clc$string_type], [0, clc$max_string_size, FALSE]]],
      local_status: ost$status,
      string_var: ost$string,
      variable_exists: boolean,
      variable_name : string (19),
      var_value: ^clt$data_value;

{ Create SCL LIST type variable TTV$LIBRARIES_ADDED to monitor additions and
{ deletions of tool and test libraries on subsequent calls to CRETE and on
{ calls to delete_test_environment.

    variable_name:= 'TTV$LIBRARIES_ADDED';
    var_value := NIL;
    clp$get_variable_value (variable_name, var_value, local_status);
    IF local_status.condition = cle$unknown_variable THEN

{ variable not created yet, so set its initial value and create the variable.

      variable_exists := FALSE;
      init_var_value.kind := clc$list;
      init_var_value.element_value := NIL;
      init_var_value.link := NIL;
      clp$create_environment_variable (variable_name, clc$job_scope,
          clc$read_write, clc$immediate_evaluation, #SEQ(list_type_spec),
          ^init_var_value, local_status);
      IF NOT local_status.normal THEN
        IF local_status.condition = cle$var_already_created THEN
          variable_exists := TRUE;
          clp$create_procedure_variable (variable_name, clc$xref_scope,
              clc$read_write, clc$immediate_evaluation, #SEQ(list_type_spec),
              var_value, local_status);
          IF NOT local_status.normal THEN
            pmp$exit (local_status);
          IFEND;
          clp$get_variable_value (variable_name, var_value, local_status);
          IF NOT local_status.normal THEN
            pmp$exit (local_status);
          IFEND;
        ELSE
          pmp$exit (local_status);
        IFEND;
      IFEND;
    ELSE
      variable_exists := TRUE;
    IFEND;

{ If the libraries_added variable exists and it contains a valid entry
{ then delete the recorded entries from the command list.

    IF (variable_exists = TRUE) AND (var_value^.element_value <> NIL) THEN
        list_link_ptr := var_value;
        list_element_ptr := var_value;
      WHILE (list_link_ptr <> NIL) DO
        list_link_ptr := list_element_ptr^.link;
        string_var.value := list_element_ptr^.element_value^.string_value^;
        clp$convert_string_to_file_ref (string_var.value, library_file,
              local_status);
        IF NOT local_status.normal THEN
            pmp$exit (local_status);
        IFEND;
        command_list_file.kind := clc$command_list_entry_path;
        command_list_file.path := ^library_file.path;
        clp$delete_file_from_cmnd_list (command_list_file, local_status);
        command_line := '';
        STRINGREP (command_line, length, 'SET_PROGRAM_ATTRIBUTES DL=',
            string_var.value (1, strlen# (string_var.value)));
        echo := FALSE;
        clp$include_command (command_line, echo, local_status);
        IF (list_link_ptr <> NIL) THEN
          list_element_ptr := list_link_ptr;
        IFEND;
      WHILEND;
      var_value^.element_value := NIL;
      var_value^.link := NIL;
      clp$change_variable('TTV$LIBRARIES_ADDED',var_value, local_status);
    IFEND;
  PROCEND remove_added_cmd_list_entries#;

{ PURPOSE :
{   Creates an environment for NOS/VE feature/ regression tests.
{ DESIGN:
{   Remove all command list entries added by previous calls to CRETE.  Then
{   process each parameter from beginning to end (with the requirement that
{   the USE_CATALOG parameter is first). The value of all tool, procedure,
{   binary, or data files is created by prefixing the value of the use_catalog
{   parameter with the value of each of the other default (tool, procedure,
{   binary, and data) parameters.  No prefix is added to a user specified
{   parameter. Job scope variables are created, libraries are put on the
{   command list and logged to the job log.  $LOCAL will also be added to the
{   command list if it not already there, and the addition will be logged for
{   future deletion by a call to Delete_test_environment.

  PROGRAM [XDCL] ttp$create_test_environment
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      catalog_reference: clt$file_reference,
      library_file: fst$parsed_file_reference,
      local_var : ost$string,
      local_status: ost$status,
      log_status: ost$status,
      param_val_string: ost$string,
      parameter_value: clt$data_value,
      path: ^pft$path,
      pc: clt$path_container,
      var_exists: boolean,
      var_name: ost$name,
      var_reference: clt$variable_reference;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt,
          local_status);
    IF NOT local_status.normal THEN
      pmp$exit (local_status);
    IFEND;
    exit_message := '';

{ Remove previous CRETE additions to the Command_List.

    remove_added_cmd_list_entries#;

{ Create an SCL variable in which to save the parameter list.

    create_test_tool_var# ('TTV$CRETE_PARAM_LIST', var_reference, var_exists);

{ Process each parameter and save the specified parameter list

    process_crete_param_list#;

{ Verify the working catalog is $LOCAL.

    clp$get_working_catalog (catalog_reference, pc, path, local_status);
    IF catalog_reference.path_name <> ':$LOCAL' THEN
      clp$set_working_catalog ('$LOCAL', local_status);
      IF NOT local_status.normal THEN
        pmp$exit (local_status);
      IFEND;
      pmp$log (' --WARNING:  Working catalog is set to $local.', log_status);
      output_message# (' --WARNING:  Working catalog is set to $local.');
    IFEND;

{ $LOCAL is a required entry in the command list for the test environment
{ to be complete - add $local if it is not there and record the addition
{ for future removal of the test environment.

    local_var.value := '$LOCAL';
    local_var.size := strlen#(local_var.value);
    clp$convert_string_to_file_ref(local_var.value,library_file, local_status);
    IF NOT local_status.normal THEN
      pmp$exit (local_status);
    IFEND;
    var_name :='';
    add_file_to_cmnd_list#(var_name, local_var, library_file);

{ Set abnormal status if status was specified and exit_message <> ''.

    IF pvt [p$status].specified THEN
      IF exit_message <> '' THEN
        osp$set_status_abnormal ('TT', 15999, exit_message, status);
        pmp$log (exit_message, log_status);
        pmp$exit(status);
      IFEND;
    IFEND;

{ Affirm test environment for user if there were no abnormalities.

    IF exit_message = '' THEN
      output_message# (' -- INFORMATIVE -- Test environment available.');
    ELSE
      output_message# (
            ' --WARNING:  PROBLEMS CREATING TEST ENVIRONMENT: See job_log ');
      output_message# (
             '     or messages_received to assess impact on planned testing.');
      pmp$log (' --WARNING:  PROBLEMS CREATING TEST ENVIRONMENT: See job_log',
             log_status);
      pmp$log  ('    or messages received to assess impact on planned testing',
             log_status);
    IFEND;

  PROCEND ttp$create_test_environment;
MODEND ttm$create_test_environment;
*DECK DECK=TTM$CRETE$US_ENGLISH EXPAND=TRUE
CREATE_MESSAGE_MODULE N=ttm$crete$us_english
" This module contains the help messages for create_test_environment.
CREATE_BRIEF_HELP_MESSAGE
  create_test_environment sets up variables, libraries and files for testing.
**
CREATE_FULL_HELP_MESSAGE
  This procedure sets up the environment for feature testing. It verifies
  the libraries and files used by CREATE_TEST_ENVIRONMENT or RUN_TESTS.
  Variables prefixed by ttv$ are added to the job variable list.
  The user's working catalog is set to $local.
  CRETE may be called repeatedly to change values or reset the test environment.
  Users can specify test procedure, binary and data files to test code.
  Examples:

  CRETE TOOL_LIBRARY=$USER.MY_VERSION_OF_TOOLS
    ( uses existing test procedures and binaries while allowing the user to
     check out either a new or altered tool)

  CRETE FTP=$USER.MY_PROCS FTB=$USER.MY_BINARIES LO=$USER.FAILED_TESTS
    ( allows the user to check out new tests before transmitting them and
      failed test logs are copied to a file)

  CRETE UC=$USER
    ( specifies that all tool, procedure, binary, data files, and names lists
     will be found in the $user catalog)
**
CREATE_PARAMETER_HELP_MESSAGE N=tool_library
Tool_library:
  Specifies the object library for the test tools.
**
CREATE_PARAMETER_HELP_MESSAGE N=feature_test_procedures
Feature_test_procedures:
  Specifies the object library for the tests.
**
CREATE_PARAMETER_HELP_MESSAGE N=feature_test_binary
Feature_test_binary
  The object library where the test binary code will be found.
**
CREATE_PARAMETER_HELP_MESSAGE N=feature_test_data
Feature_test_data
  The source library where the test data will be found.
**
CREATE_PARAMETER_HELP_MESSAGE N=scu_test_procedures
Scu_test_procedures:
  Specifies the object library for the tests.
**
CREATE_PARAMETER_HELP_MESSAGE N=scu_test_binary
Scu_test_binary:
  The object library where the test binary code will be found.
**
CREATE_PARAMETER_HELP_MESSAGE N=scu_test_data
Scu_test_data:
  The source library where the test data will be found.
**
CREATE_PARAMETER_HELP_MESSAGE N=cybil_test_procedures
Cybil_test_procedures:
  Specifies the object library for the tests.
**
CREATE_PARAMETER_HELP_MESSAGE N=cybil_test_binary
Cybil_test_binary:
  The object library where the test binary code will be found.
**
CREATE_PARAMETER_HELP_MESSAGE N=cybil_test_data
Cybil_test_data:
  The source library where the test data will be found.
**
CREATE_PARAMETER_HELP_MESSAGE N=ocu_test_procedures
Ocu_test_procedures:
  Specifies the object library for the tests.
**
CREATE_PARAMETER_HELP_MESSAGE N=ocu_test_binary
Ocu_test_binary:
  The object library where the test binary code will be found.
**
CREATE_PARAMETER_HELP_MESSAGE N=ocu_test_data
Ocu_test_data:
  The source library where the test data will be found.
**
CREATE_PARAMETER_HELP_MESSAGE N=product_set_test_data
Product_set_test_data:
  The source library where the test data will be found.
**
CREATE_PARAMETER_HELP_MESSAGE N=system_test_procedures
System_test_procedures:
  Specifies the object library for the tests.
**
CREATE_PARAMETER_HELP_MESSAGE N=system_test_binary
System_test_binary:
  The object library where the test binary code will be found.
**
CREATE_PARAMETER_HELP_MESSAGE N=system_test_data
System_test_data:
  The source library where the test data will be found.
**
CREATE_PARAMETER_HELP_MESSAGE N=use_catalog
Use_catalog:
  The catalog to prefix the path of the test files used by CRETE.
**
CREATE_PARAMETER_HELP_MESSAGE N=results_file
Results_file:
  Specifies the file to which tests will send their results.
**
CREATE_PARAMETER_HELP_MESSAGE N=password_suffix
Password_suffix:
  A suffix that can be used by tests that have a password.
**
CREATE_PARAMETER_HELP_MESSAGE N=product_set_version
Product_set_version:
  The build level of the product set. ( not used )
**
CREATE_PARAMETER_HELP_MESSAGE N=tape_vsn
Tape_vsn:
  A tape vsn used by tape tests to load and unload tapes.
**
CREATE_PARAMETER_HELP_MESSAGE N=remote_family
Remote_family:
  The family name used by NAM/VE tests to communicate with a remote mainframe.
**
CREATE_PARAMETER_HELP_MESSAGE N=cybil_path
Cybil_path:
  An alternate cybil compiler to be added to the command list.
**
CREATE_PARAMETER_HELP_MESSAGE N=log_option
Log_option:
  Default prints failed test logs, filename saves logs.
**
END_MESSAGE_MODULE
*DECK DECK=TTM$DELETE_TEST_ENVIRONMENT EXPAND=TRUE
MODULE ttm$delete_test_environment;

{ Purpose:
{ The module contains the procedures needed to restore the environment
{ to one before create_test_environment was run.
{ Design:

?? PUSH (LIST := OFF) ??
*copyc clp$convert_string_to_file_ref
*copyc clp$delete_file_from_cmnd_list
*copyc clp$delete_variable
*copyc clp$evaluate_parameters
*copyc clp$get_variable_value
*copyc clp$include_command
*copyc pmp$exit

?? POP ??

{   PROCEDURE (ttm$delte) delte_pdt (
{         status)

?? 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,
      recend,
    recend := [
    [1,
    [88, 11, 4, 11, 40, 33, 17],
    clc$command, 1, 1, 0, 0, 0, 0, 1, 'TTM$DELTE'], [
    ['STATUS                         ',clc$nominal_entry, 1]],
    [
{ PARAMETER 1
    [1, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

  CONST
    p$status = 1;

  VAR
    pvt: array [1 .. 1] of clt$parameter_value;

{ PURPOSE:
{ Restores job command lists and variable libraries to previous entries.
{ DESIGN:
{ The command list is restored to its original entries.  The ttv$ prefixed
{ SCL variables are deleted.  Program will not give error status if create_
{ test_environment is not executed.
{ NOTES:
{ TTV$LIBRARIES_ADDED is a list of the libraries added to the command list
{ by Create_test_environment.                                              -

  PROGRAM ttp$delete_test_environment
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

    VAR
      command_list_file : clt$command_list_entry_file,
      command_line : string (256),
      echo : boolean,
      length : integer,
      library_file: fst$parsed_file_reference,
      list_element_ptr: ^clt$data_value,
      list_link_ptr: ^clt$data_value,
      local_status: ost$status,
      string_var: ost$string,
      variable_name : string (19),
      var_value: ^clt$data_value;

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt,
          local_status);
    IF NOT local_status.normal THEN
      pmp$exit (local_status);
    IFEND;

    variable_name:= 'TTV$LIBRARIES_ADDED';
    var_value := NIL;
    clp$get_variable_value (variable_name, var_value, local_status);
    IF (local_status.normal) AND (var_value^.element_value <> NIL) THEN
      list_link_ptr := var_value;
      list_element_ptr := var_value;
      WHILE (list_link_ptr <> NIL) DO
        list_link_ptr := list_element_ptr^.link;
        string_var.value := list_element_ptr^.element_value^.string_value^;
        clp$convert_string_to_file_ref (string_var.value, library_file,
              local_status);
        IF NOT local_status.normal THEN
            pmp$exit (local_status);
        IFEND;
        command_list_file.kind := clc$command_list_entry_path;
        command_list_file.path := ^library_file.path;
        clp$delete_file_from_cmnd_list (command_list_file, local_status);
        command_line := '';
        string_var.size:= library_file.complete_path_size;
        STRINGREP (command_line, length, 'SET_PROGRAM_ATTRIBUTES DL=',
            string_var.value (1, string_var.size));
        echo := TRUE;
        clp$include_command (command_line, echo, local_status);
        IF (list_link_ptr <> NIL) THEN
          list_element_ptr := list_link_ptr;
        IFEND;
      WHILEND;
    IFEND;

{ Delete the scl job scope variables twice to get rid of them from the
{ stack frame and the job.

    clp$delete_variable ('ttv$crete_param_list', local_status);
    clp$delete_variable ('ttv$crete_param_list', local_status);
    clp$delete_variable ('ttv$cybil_path', local_status);
    clp$delete_variable ('ttv$cybil_path', local_status);
    clp$delete_variable ('ttv$cybil_test_procedures', local_status);
    clp$delete_variable ('ttv$cybil_test_procedures', local_status);
    clp$delete_variable ('ttv$cybil_test_binary', local_status);
    clp$delete_variable ('ttv$cybil_test_binary', local_status);
    clp$delete_variable ('ttv$cybil_test_data', local_status);
    clp$delete_variable ('ttv$cybil_test_data', local_status);
    clp$delete_variable ('ttv$feature_test_procedures', local_status);
    clp$delete_variable ('ttv$feature_test_procedures', local_status);
    clp$delete_variable ('ttv$feature_test_binary', local_status);
    clp$delete_variable ('ttv$feature_test_binary', local_status);
    clp$delete_variable ('ttv$feature_test_data', local_status);
    clp$delete_variable ('ttv$feature_test_data', local_status);
    clp$delete_variable ('ttv$log_option', local_status);
    clp$delete_variable ('ttv$log_option', local_status);
    clp$delete_variable ('ttv$ocu_test_procedures', local_status);
    clp$delete_variable ('ttv$ocu_test_procedures', local_status);
    clp$delete_variable ('ttv$ocu_test_binary', local_status);
    clp$delete_variable ('ttv$ocu_test_binary', local_status);
    clp$delete_variable ('ttv$ocu_test_data', local_status);
    clp$delete_variable ('ttv$ocu_test_data', local_status);
    clp$delete_variable ('ttv$password_suffix', local_status);
    clp$delete_variable ('ttv$password_suffix', local_status);
    clp$delete_variable ('ttv$product_set_test_data', local_status);
    clp$delete_variable ('ttv$product_set_test_data', local_status);
    clp$delete_variable ('ttv$product_set_version', local_status);
    clp$delete_variable ('ttv$product_set_version', local_status);
    clp$delete_variable ('ttv$results_file', local_status);
    clp$delete_variable ('ttv$results_file', local_status);
    clp$delete_variable ('ttv$remote_family', local_status);
    clp$delete_variable ('ttv$remote_family', local_status);
    clp$delete_variable ('ttv$scu_test_procedures', local_status);
    clp$delete_variable ('ttv$scu_test_procedures', local_status);
    clp$delete_variable ('ttv$scu_test_binary', local_status);
    clp$delete_variable ('ttv$scu_test_binary', local_status);
    clp$delete_variable ('ttv$scu_test_data', local_status);
    clp$delete_variable ('ttv$scu_test_data', local_status);
    clp$delete_variable ('ttv$system_test_procedures', local_status);
    clp$delete_variable ('ttv$system_test_procedures', local_status);
    clp$delete_variable ('ttv$system_test_binary', local_status);
    clp$delete_variable ('ttv$system_test_binary', local_status);
    clp$delete_variable ('ttv$system_test_data', local_status);
    clp$delete_variable ('ttv$system_test_data', local_status);
    clp$delete_variable ('ttv$tape_vsn', local_status);
    clp$delete_variable ('ttv$tape_vsn', local_status);
    clp$delete_variable ('ttv$tool_library', local_status);
    clp$delete_variable ('ttv$tool_library', local_status);
    clp$delete_variable ('ttv$use_catalog', local_status);
    clp$delete_variable ('ttv$use_catalog', local_status);
    clp$delete_variable ('ttv$wef_test_procedures', local_status);
    clp$delete_variable ('ttv$wef_test_procedures', local_status);
    clp$delete_variable ('ttv$wef_test_binary', local_status);
    clp$delete_variable ('ttv$wef_test_binary', local_status);
    clp$delete_variable ('ttv$libraries_added', local_status);
    clp$delete_variable ('ttv$libraries_added', local_status);
    clp$delete_variable ('ttv$tape_density', local_status);
    clp$delete_variable ('ttv$tape_density', local_status);
    clp$delete_variable ('ttv$test_development_library', local_status);
    clp$delete_variable ('ttv$test_development_library', local_status);

  PROCEND ttp$delete_test_environment;
MODEND ttm$delete_test_environment;
*DECK DECK=TUC$CURSOR_NUMBER_OF_DIGITS EXPAND=FALSE

  CONST
    tuc$cursor_number_of_digits = 7;

*DECK DECK=TUT$APPLICATION_NAME EXPAND=FALSE

*copyc ost$name

  TYPE
    tut$application_name = ost$name;

*DECK DECK=TUT$APPL_STRING_CHAR EXPAND=FALSE

  TYPE
    tut$appl_string_char = string ( * );

*DECK DECK=TUT$APPL_STRING_CHAR_STRING EXPAND=FALSE

*copyc tut$appl_string_char

  TYPE
    tut$appl_string_char_string = string (tuc$appl_string_char);

*DECK DECK=TUT$APPL_STRING_POINTER EXPAND=FALSE

*copyc tut$application_name

  TYPE
    tut$appl_string_pointer = array [1 .. * ] of record
      name: tut$application_name,
      start: 1 .. 65535,
      length: 0 .. 65535,
    recend;

*DECK DECK=TUT$APPL_STRING_POINTER_ARRAY EXPAND=FALSE

*copyc tut$appl_string_pointer

  TYPE
    tut$appl_string_pointer_array = array [1 .. tuc$appl_string_pointer] of
          record
      name: tut$application_name,
      start: 1 .. 65535,
      length: 0 .. 65535,
    recend;

*DECK DECK=TUT$CURSOR_ADDRESSING_BIAS EXPAND=FALSE

  TYPE
    tut$cursor_addressing_bias = - 127 .. 127;

*DECK DECK=TUT$CURSOR_ADDRESSING_TYPE EXPAND=FALSE

  TYPE
    tut$cursor_addressing_type = (tuc$binary_cursor, tuc$721_cursor,
          tuc$ansi_cursor, tuc$ibm3270_cursor);

*DECK DECK=TUT$CURSOR_BEHAVIOR EXPAND=FALSE

*copyc tut$cursor_movement
*copyc tut$cursor_behavior_ordinal

  TYPE
    tut$cursor_behavior = packed array [tut$cursor_behavior_ordinal] of
          tut$cursor_movement;

*DECK DECK=TUT$CURSOR_BEHAVIOR_ORDINAL EXPAND=FALSE

  TYPE
    tut$cursor_behavior_ordinal = (tuc$move_past_left, tuc$move_past_right,
          tuc$move_past_top, tuc$move_past_bottom, tuc$char_past_left,
          tuc$char_past_right, tuc$char_past_last_position);


*DECK DECK=TUT$CURSOR_MOVEMENT EXPAND=FALSE

  TYPE
    tut$cursor_movement = (tuc$cursor_stop, tuc$cursor_scroll, tuc$cursor_home,
          tuc$cursor_wrap_adjacent, tuc$cursor_wrap_same);

*DECK DECK=TUT$CURSOR_PARAMETERS EXPAND=FALSE

*copyc tut$cursor_addressing_type
*copyc tut$cursor_addressing_bias
*copyc tuc$cursor_number_of_digits
*copyc tut$cursor_behavior

  TYPE
    tut$cursor_parameters = record
      addressing_type: tut$cursor_addressing_type,
      addressing_bias: tut$cursor_addressing_bias,
      column_before_row: boolean,
      number_digits_in_column: 0 .. tuc$cursor_number_of_digits,
      number_digits_in_row: 0 .. tuc$cursor_number_of_digits,
      behavior: tut$cursor_behavior,
    recend;

*DECK DECK=TUT$FIXED_TAB_POSITIONS EXPAND=FALSE

*copyc tut$size


  TYPE
    tut$fixed_tab_positions = packed array [1 .. tuc$max_columns] of boolean;
*DECK DECK=TUT$FLAGS EXPAND=FALSE

*copyc tut$flag_ordinals

  TYPE
    tut$flags = packed array [tut$flag_ordinals] of boolean;

*DECK DECK=TUT$FLAG_ORDINALS EXPAND=FALSE

  TYPE
    tut$flag_ordinals = (tuc$flag_home_at_top, tuc$flag_has_protect,
      tuc$flag_multiple_sizes, tuc$flag_cdc_spare_1, tuc$flag_has_hidden,
      tuc$flag_tabs_to_home, tuc$flag_tabs_to_unprotected,
      tuc$flag_tabs_to_tab_stops, tuc$flag_clear_when_change_size,
      tuc$flag_automatic_tabbing, tuc$flag_type_ahead, tuc$flag_cdc_spare_2,
      tuc$flag_site_spare_1, tuc$flag_site_spare_2, tuc$flag_user_spare_1,
      tuc$flag_user_spare_2);

*DECK DECK=TUT$HEADER EXPAND=FALSE

*copyc tut$model_name
*copyc tut$cursor_parameters
*copyc tut$flags
*copyc tut$fixed_tab_positions
*copyc tut$init_terminal_command
*copyc tut$size_table
*copyc tut$mapping

  TYPE
    tut$header = record
      name: tut$model_name,
      version: 1 .. 255,
      cursor: tut$cursor_parameters,
      function_key_mark_size: 0 .. 7,
      flags: tut$flags,
      number_programmable_tab_stops: 0 .. tuc$max_columns,
      fixed_tab_positions: tut$fixed_tab_positions,
      initialize_terminal_command: tut$init_terminal_command,
      screen_size: tut$size_table,
      mapping: tut$mapping,
    recend;

*DECK DECK=TUT$INIT EXPAND=FALSE

*copyc tut$init_ordinals

  TYPE
    tut$init = record
      ordinals: array [0 .. tuc$init_max_ordinal] of record
        start: 1 .. 65535,
        length: 0 .. 65535,
      recend,
      chars: string ( * ),
    recend;

*DECK DECK=TUT$INIT_ORDINALS EXPAND=FALSE

  TYPE
    tut$init_ordinals = (tuc$line_init, tuc$screen_init);

  CONST
    tuc$init_max_ordinal = ORD (tuc$screen_init);

*DECK DECK=TUT$INIT_ORDINAL_ARRAY EXPAND=FALSE

*copyc tut$init

  TYPE
    tut$init_ordinal_array = array [0 .. ORD (tuc$screen_init)] of record
      start: 1 .. 65535,
      length: 0 .. 65535,
    recend;

*DECK DECK=TUT$INIT_TERMINAL_COMMAND EXPAND=FALSE

*copyc ost$string

  TYPE
    tut$init_terminal_command = record
      command: string (osc$max_string_size),
    recend;
*DECK DECK=TUT$INPUT EXPAND=FALSE

*copyc tut$input_ordinals
*copyc tut$input_characters

  TYPE
    tut$input = array [ * ] of tut$input_characters;

*DECK DECK=TUT$INPUT_ARRAY EXPAND=FALSE

*copyc tut$input

  TYPE
    tut$input_array = array [1 .. tuc$input] of char;

*DECK DECK=TUT$INPUT_CHARACTERS EXPAND=FALSE

  TYPE
    tut$input_characters = char;

*DECK DECK=TUT$INPUT_ORDINALS EXPAND=FALSE

?? FMT (FORMAT := OFF) ??
  TYPE
    tut$input_ordinals = (
      tuc$in_no_input,
      tuc$in_insert_char,
      tuc$in_delete_char,
      tuc$in_insert_line_stay,
      tuc$in_insert_line_bol,
      tuc$in_delete_line_stay,
      tuc$in_delete_line_bol,
      tuc$in_erase_page_stay,
      tuc$in_erase_page_home,
      tuc$in_erase_unprotected,
      tuc$in_erase_end_of_page,
      tuc$in_erase_line_stay,
      tuc$in_erase_line_bol,
      tuc$in_erase_end_of_line,
      tuc$in_erase_field_stay,
      tuc$in_erase_field_bof,
      tuc$in_erase_end_of_field,
      tuc$in_erase_char,
      tuc$in_cursor_home,
      tuc$in_cursor_up,
      tuc$in_cursor_down,
      tuc$in_cursor_left,
      tuc$in_cursor_right,
      tuc$in_tab_forward,
      tuc$in_tab_backward,
      tuc$in_return,
      tuc$in_reset,
      tuc$in_insert_mode_begin,
      tuc$in_insert_mode_end,
      tuc$in_insert_mode_toggle,
      tuc$in_tab_clear,
      tuc$in_tab_clear_all,
      tuc$in_tab_set,
      tuc$in_cursor_pos_begin,
      tuc$in_cursor_pos_second,
      tuc$in_cursor_pos_third,
      tuc$in_end_of_information,
      tuc$in_overstrike,
      tuc$in_f1,
      tuc$in_f2,
      tuc$in_f3,
      tuc$in_f4,
      tuc$in_f5,
      tuc$in_f6,
      tuc$in_f7,
      tuc$in_f8,
      tuc$in_f9,
      tuc$in_f10,
      tuc$in_f11,
      tuc$in_f12,
      tuc$in_f13,
      tuc$in_f14,
      tuc$in_f15,
      tuc$in_f16,
      tuc$in_f1_s,
      tuc$in_f2_s,
      tuc$in_f3_s,
      tuc$in_f4_s,
      tuc$in_f5_s,
      tuc$in_f6_s,
      tuc$in_f7_s,
      tuc$in_f8_s,
      tuc$in_f9_s,
      tuc$in_f10_s,
      tuc$in_f11_s,
      tuc$in_f12_s,
      tuc$in_f13_s,
      tuc$in_f14_s,
      tuc$in_f15_s,
      tuc$in_f16_s,
      tuc$in_next,
      tuc$in_back,
      tuc$in_help,
      tuc$in_stop,
      tuc$in_down,
      tuc$in_up,
      tuc$in_fwd,
      tuc$in_bkw,
      tuc$in_edit,
      tuc$in_data,
      tuc$in_next_s,
      tuc$in_back_s,
      tuc$in_help_s,
      tuc$in_stop_s,
      tuc$in_down_s,
      tuc$in_up_s,
      tuc$in_fwd_s,
      tuc$in_bkw_s,
      tuc$in_edit_s,
      tuc$in_data_s,
      tuc$in_backspace,
      tuc$in_undo,
      tuc$in_undo_s );

  CONST
    tuc$in_max_ordinal = ORD(tuc$in_undo_s);
?? FMT (FORMAT := ON) ??
*DECK DECK=TUT$KEY_NAME EXPAND=FALSE

*copyc tut$key_name_ordinals

  TYPE
    tut$key_name = record
      ordinals: array [0 .. tuc$in_max_ordinal] of record
        start: 1 .. 65535,
        length: 0 .. 255,
      recend,
      chars: string ( * ),
    recend;

  TYPE
    tut$v3_key_name = record
      ordinals: array [0 .. ORD (tuc$in_backspace)] of record
        start: 1 .. 65535,
        length: 0 .. 255,
      recend,
      chars: string ( * ),
    recend;
*DECK DECK=TUT$KEY_NAME_ORDINALS EXPAND=FALSE

*copyc tut$input_ordinals

  TYPE
    tut$key_name_ordinals = tut$input_ordinals;

  CONST
    tuc$key_name_max_ordinal = tuc$in_max_ordinal;

*DECK DECK=TUT$KEY_NAME_ORDINAL_ARRAY EXPAND=FALSE

*copyc tut$key_name

  TYPE
    tut$key_name_ordinal_array = array [0 .. tuc$in_max_ordinal] of record
      start: 1 .. 65535,
      length: 0 .. 255,
    recend;

*DECK DECK=TUT$MAPPING EXPAND=FALSE

*copyc cst$standard_functions
*copyc tut$input_ordinals

  TYPE
    tut$mapping = array [cst$standard_functions] of tut$input_ordinals;

*DECK DECK=TUT$MODEL_NAME EXPAND=FALSE

  TYPE
    tut$model_name = string (25);

*DECK DECK=TUT$OUTPUT EXPAND=FALSE

*copyc tut$output_ordinals

  TYPE
    tut$output = record
      ordinals: array [0 .. tuc$out_max_ordinal] of record
        start: 1 .. 65535,
        length: 0 .. 255,
      recend,
      chars: string ( * ),
    recend;

*DECK DECK=TUT$OUTPUT_ORDINALS EXPAND=FALSE

?? FMT (FORMAT := OFF) ??
  TYPE
    tut$output_ordinals = (
      tuc$out_insert_char,
      tuc$out_delete_char,
      tuc$out_insert_line_stay,
      tuc$out_insert_line_bol,
      tuc$out_delete_line_stay,
      tuc$out_delete_line_bol,
      tuc$out_erase_page_stay,
      tuc$out_erase_page_home,
      tuc$out_erase_unprotected,
      tuc$out_erase_end_of_page,
      tuc$out_erase_line_stay,
      tuc$out_erase_line_bol,
      tuc$out_erase_end_of_line,
      tuc$out_erase_field_stay,
      tuc$out_erase_field_bof,
      tuc$out_erase_end_of_field,
      tuc$out_erase_char,
      tuc$out_cursor_home,
      tuc$out_cursor_up,
      tuc$out_cursor_down,
      tuc$out_cursor_left,
      tuc$out_cursor_right,
      tuc$out_tab_forward,
      tuc$out_tab_backward,
      tuc$out_return,
      tuc$out_reset,
      tuc$out_insert_mode_begin,
      tuc$out_insert_mode_end,
      tuc$out_insert_mode_toggle,
      tuc$out_tab_clear,
      tuc$out_tab_clear_all,
      tuc$out_tab_set,
      tuc$out_cursor_pos_begin,
      tuc$out_cursor_pos_second,
      tuc$out_cursor_pos_third,
      tuc$out_bell_nak,
      tuc$out_bell_ack,
      tuc$out_set_screen_mode,
      tuc$out_set_line_mode,
      tuc$out_output_begin,
      tuc$out_output_end,
      tuc$out_display_begin,
      tuc$out_display_end,
      tuc$out_print_begin,
      tuc$out_print_end,
      tuc$out_print_page,
      tuc$out_field_scroll_set,
      tuc$out_field_scroll_down,
      tuc$out_field_scroll_up,
      tuc$out_protect_all,
      tuc$out_blink_begin,
      tuc$out_blink_end,
      tuc$out_alt_begin,
      tuc$out_alt_end,
      tuc$out_hidden_begin,
      tuc$out_hidden_end,
      tuc$out_inverse_begin,
      tuc$out_inverse_end,
      tuc$out_protect_begin,
      tuc$out_protect_end,
      tuc$out_underline_begin,
      tuc$out_underline_end,
      tuc$out_input_text_begin,
      tuc$out_input_text_end,
      tuc$out_output_text_begin,
      tuc$out_output_text_end,
      tuc$out_italic_begin,
      tuc$out_italic_end,
      tuc$out_title_begin,
      tuc$out_title_end,
      tuc$out_message_begin,
      tuc$out_message_end,
      tuc$out_error_begin,
      tuc$out_error_end,
      tuc$out_ld_fine_begin,
      tuc$out_ld_fine_end,
      tuc$out_ld_fine_horizontal,
      tuc$out_ld_fine_vertical,
      tuc$out_ld_fine_upper_left,
      tuc$out_ld_fine_upper_right,
      tuc$out_ld_fine_lower_left,
      tuc$out_ld_fine_lower_right,
      tuc$out_ld_fine_up_t,
      tuc$out_ld_fine_down_t,
      tuc$out_ld_fine_left_t,
      tuc$out_ld_fine_right_t,
      tuc$out_ld_fine_cross,
      tuc$out_ld_medium_begin,
      tuc$out_ld_medium_end,
      tuc$out_ld_medium_horizontal,
      tuc$out_ld_medium_vertical,
      tuc$out_ld_medium_upper_left,
      tuc$out_ld_medium_upper_right,
      tuc$out_ld_medium_lower_left,
      tuc$out_ld_medium_lower_right,
      tuc$out_ld_medium_up_t,
      tuc$out_ld_medium_down_t,
      tuc$out_ld_medium_left_t,
      tuc$out_ld_medium_right_t,
      tuc$out_ld_medium_cross,
      tuc$out_ld_bold_begin,
      tuc$out_ld_bold_end,
      tuc$out_ld_bold_horizontal,
      tuc$out_ld_bold_vertical,
      tuc$out_ld_bold_upper_left,
      tuc$out_ld_bold_upper_right,
      tuc$out_ld_bold_lower_left,
      tuc$out_ld_bold_lower_right,
      tuc$out_ld_bold_up_t,
      tuc$out_ld_bold_down_t,
      tuc$out_ld_bold_left_t,
      tuc$out_ld_bold_right_t,
      tuc$out_ld_bold_cross,
      tuc$out_black_background,
      tuc$out_white_background,
      tuc$out_red_background,
      tuc$out_green_background,
      tuc$out_blue_background,
      tuc$out_yellow_background,
      tuc$out_cyan_background,
      tuc$out_magenta_background,
      tuc$out_black_foreground,
      tuc$out_white_foreground,
      tuc$out_red_foreground,
      tuc$out_green_foreground,
      tuc$out_blue_foreground,
      tuc$out_yellow_foreground,
      tuc$out_cyan_foreground,
      tuc$out_magenta_foreground,
      tuc$out_low_intensity_begin,
      tuc$out_low_intensity_end,
      tuc$out_high_intensity_begin,
      tuc$out_high_intensity_end,
      tuc$out_set_size_1,
      tuc$out_set_size_2,
      tuc$out_set_size_3,
      tuc$out_set_size_4 );

  CONST
    tuc$out_max_ordinal = ORD(tuc$out_set_size_4);
?? FMT (FORMAT := ON) ??
*DECK DECK=TUT$OUTPUT_ORDINAL_ARRAY EXPAND=FALSE

*copyc tut$output

  TYPE
    tut$output_ordinal_array = array [0 .. ORD (tuc$out_set_size_4)] of record
      start: 1 .. 65535,
      length: 0 .. 255,
    recend;

*DECK DECK=TUT$SIZE EXPAND=FALSE


*copyc ost$name


  CONST
    tuc$max_rows = 255,
    tuc$max_columns = 255;

  TYPE
    tut$size_rows_type = 0 .. tuc$max_rows,
    tut$size_columns_type = 0 .. tuc$max_columns,

    tut$size = record
      columns: tut$size_columns_type,
      rows: tut$size_rows_type,
      pick_locate_device: ost$name,
      num_accuracy_char_positions: 0 .. tuc$max_columns,
      accuracy_character_positions: array [0 .. tuc$max_columns] of
            0 .. tuc$max_columns,
      num_accuracy_line_positions: 0 .. tuc$max_rows,
      accuracy_line_positions: array [0 .. tuc$max_rows] of 0 .. tuc$max_rows,
    recend;

*DECK DECK=TUT$SIZE_TABLE EXPAND=FALSE

*copyc tut$size

  CONST
    tuc$minimum_size_table = 1,
    tuc$maximum_size_table = 4;

  TYPE
    tut$size_table_index = tuc$minimum_size_table .. tuc$maximum_size_table,

    tut$size_table = array [tut$size_table_index] of tut$size;

*DECK DECK=TUT$SUBTABLE_POINTERS EXPAND=FALSE

*copyc tut$header
*copyc tut$output
*copyc tut$input
*copyc tut$key_name
*copyc tut$init
*copyc tut$appl_string_pointer
*copyc tut$appl_string_char
*copyc tut$mapping

  TYPE
    tut$subtable_pointers = record
      header: ^tut$header,
      output: ^tut$output,
      input: ^tut$input,
      key_name: ^tut$key_name,
      init: ^tut$init,
      appl_string_pointer: ^tut$appl_string_pointer,
      appl_string_char: ^tut$appl_string_char,
    recend;

  TYPE
    tut$v3_subtable_pointers = record
      header: ^tut$header,
      output: ^tut$output,
      input: ^tut$input,
      key_name: ^tut$v3_key_name,
      init: ^tut$init,
      appl_string_pointer: ^tut$appl_string_pointer,
      appl_string_char: ^tut$appl_string_char,
    recend;

*DECK DECK=UOE$CREDC_CONDITION_CODES EXPAND=FALSE

  CONST
    uoc$base_condition = (($INTEGER ('u') * 100(16)) + $INTEGER ('o')) * 1000000(16),
    uoc$base_ecc = uoc$base_condition + 15600,

    uoe$service_data_too_large = uoc$base_ecc + 2,
    {E The size of the service data may not exceed 63 bytes.}

    uoe$server_not_active = uoc$base_ecc + 7,
    {E The server device +P1 is not active.}

    uoe$server_busy = uoc$base_ecc + 12,
    {E The server device +P1 is busy.}

    uoe$server_busy_or_not_active = uoc$base_ecc + 17,
    {E The server device +P1 is either busy or not active.}

    uoe$unable_to_change_nf_var = uoc$base_ecc + 22,
    {E Unable to store network file name in variable +P.}

    uoe$invalid_conn_wait_time  = uoc$base_ecc + 27,
    {E Connection wait time must be greater than zero.}

    uoe$max_ecc = uoc$base_ecc + 39;
*DECK DECK=UOH$CREATE_DEVICE_CONNECTION EXPAND=FALSE
{
{   The purpose of this request is to establish a virtual terminal connection
{ to a CDCNET server device via the CDCNET Device Outcall Gateway.
{
{   Two files are created in the $LOCAL catalog as a result of this request,
{ a terminal file and a network file.  The terminal file is used to perform
{ I/O with the server device.  The name of this file is specified by the
{ caller.  The network file is required by the system in support of the terminal
{ file.  A unique name is generated for this file and returned to the caller.
{
{   The network file should be returned (by the caller) at the same time that
{ the terminal file is returned.  Returning the network file terminates the
{ connection to the server device, releasing the server device to accept
{ connections from other users.
{
{   In order to use this request, the file $SYSTEM.OSF$SITE_COMMAND_LIBRARY
{ must be present in the task's program library list.  If error messages
{ returned by this request are to be displayed, the same file must be present
{ in the job's command list.
{
{       UOP$CREATE_DEVICE_CONNECTION (DEVICE_TITLE, TERMINAL_FILE_NAME,
{             APPLICATION_NAME, TRANSLATION_WAIT_TIME, CONNECTION_WAIT_TIME,
{             SERVICE_DATA, NETWORK_FILE_NAME, STATUS)
{
{ DEVICE_TITLE: (input) This parameter specifies a title pattern to be used to
{       translate the title of the server device to which a connection is to
{       be established.  This title is registered by the Device Outcall Gateway
{       on behalf of the server device.
{
{ TERMINAL_FILE_NAME: (input) This parameter specifies the name of the terminal
{       file that is to be created to access the server device.  This file must
{       reside in the $LOCAL catalog.
{
{ APPLICATION_NAME: (input) This parameter specifies the name of the host
{       application in whose behalf the device connection is to be established.
{       This application must be defined via the MANAGE_NETWORK_APPLICATIONS
{       utility.
{
{ TRANSLATION_WAIT_TIME: (input) This parameter specifies the number of seconds
{       that the request is to wait for a translation of the device title to
{       be available.  The specified value must be at least 16 seconds in order
{       for the request to distinguish between a busy server device and an
{       inactive server device.
{
{ CONNECTION_WAIT_TIME: (input) This parameter specifies the number of seconds
{       that the request is to wait for a connection to be established to the
{       server device.  The specified value must be greater than 0.
{
{ SERVICE_DATA: (input) This parameter specifies the service data that is to be
{       sent to the Device Outcall Gateway as part of the user data with the
{       connection request.
{
{ NETWORK_FILE_NAME: (output) This parameter specifies the name of the network
{       file created to access the server device.
{
{ STATUS: (output) This parameter specifies the request status.
{       CONDITIONS:
{             uoe$server_busy
{             uoe$server_busy_or_not_active
{             uoe$server_not_active
{             uoe$service_data_too_large
{             uoe$invalid_conn_wait_time
{
*DECK DECK=UOM$CREATE_DEVICE_CONNECTION EXPAND=TRUE
?? RIGHT := 110 ??
MODULE uom$create_device_connection;
{
{ PURPOSE:
{
{   This module contains code that establishes a connection to a device that is
{   accessed via the CDCNET Device Outcall Gateway application.
{
{   The Device Outcall Gateway application serves as a rendezvous point for a
{   device connected to a CDCNET asynchronous LIM port that wishes to accept
{   connections from host applications.  Such a device is known as a server
{   device.  A server device may be a terminal, a printer, a modem, or any other
{   device that may be connected to a CDCNET asynchonous LIM port.
{
{   A server device declares its intention to accept connections from host
{   applications by connecting to the Device Outcall Gateway application and
{   sending a DEFINE_SERVER_DEVICE command to the application.  This command
{   specifies the title by which the server device is to be known.  The Device
{   Outcall Gateway registers this title on behalf of the server device.
{
{   A host application that wishes to establish a connection to a server device
{   uses the server device's title to establish a connection to the Device
{   Outcall Gateway application.  When a host application establishes a
{   connection to the Device Outcall Gateway, the gateway "pairs" this
{   connection with the connection from the server device; data received over
{   one connection is forwarded over the paired connection.
{
{   The code in this module establishes a connection to a server device on
{   behalf of a host application.  The host application must be defined via the
{   MANAGE_NETWORK_APPLICATIONS utility.
{
{ DESIGN:
{
{   This module contains two procedures.  The first procedure is a command
{   processor that supports a command interface to establish a device
{   connection.  A program description specifying this procedure as the starting
{   procedure must be created in a NOS/VE object library in order to provide a
{   command interface.
{
{   The second procedure is a program interface for establishing a device
{   connection.  It may be called by programs that need to establish a device
{   connection.  It is called by the command processor procedure described
{   above.
{
?? TITLE := 'Message Templates', EJECT ??
*copyc uoe$credc_condition_codes
?? TITLE := 'Global Declarations Referenced by this Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc fst$temporary_file_path
?? POP ??
*copyc amp$return
*copyc clp$create_environment_variable
*copyc clp$change_variable
*copyc clp$evaluate_parameters
*copyc nap$begin_directory_search
*copyc nap$end_directory_search
*copyc nap$get_title_translation
*copyc nap$request_connection
*copyc osp$generate_message
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$get_unique_name
*copyc rmp$request_terminal
?? TITLE := '[XDCL] uop$_create_device_connection', EJECT ??

  PROCEDURE [XDCL] uop$_create_device_connection
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

{ PROCEDURE (ram$credc) create_device_connection, credc (
{   device, d: name = $required
{   terminal_file, tf: file = $required
{   application, a: name = $required
{   translation_wait_time, twt: integer = 16
{   connection_wait_time, cwt: integer 1 .. clc$max_integer = 10
{   service_data, sd: string 1..63 = $optional
{   network_file, nf: data_name = credc_network_file
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 15] of clt$pdt_parameter_name,
      parameters: array [1 .. 8] of clt$pdt_parameter,
      type1: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type2: record
        header: clt$type_specification_header,
      recend,
      type3: record
        header: clt$type_specification_header,
        qualifier: clt$name_type_qualifier,
      recend,
      type4: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (2),
      recend,
      type5: record
        header: clt$type_specification_header,
        qualifier: clt$integer_type_qualifier,
        default_value: string (2),
      recend,
      type6: record
        header: clt$type_specification_header,
        qualifier: clt$string_type_qualifier,
      recend,
      type7: record
        header: clt$type_specification_header,
        default_value: string (18),
      recend,
      type8: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [90, 6, 19, 16, 0, 19, 56],
    clc$command, 15, 8, 3, 0, 0, 0, 8, 'RAM$CREDC'], [
    ['A                              ',clc$abbreviation_entry, 3],
    ['APPLICATION                    ',clc$nominal_entry, 3],
    ['CONNECTION_WAIT_TIME           ',clc$nominal_entry, 5],
    ['CWT                            ',clc$abbreviation_entry, 5],
    ['D                              ',clc$abbreviation_entry, 1],
    ['DEVICE                         ',clc$nominal_entry, 1],
    ['NETWORK_FILE                   ',clc$nominal_entry, 7],
    ['NF                             ',clc$abbreviation_entry, 7],
    ['SD                             ',clc$abbreviation_entry, 6],
    ['SERVICE_DATA                   ',clc$nominal_entry, 6],
    ['STATUS                         ',clc$nominal_entry, 8],
    ['TERMINAL_FILE                  ',clc$nominal_entry, 2],
    ['TF                             ',clc$abbreviation_entry, 2],
    ['TRANSLATION_WAIT_TIME          ',clc$nominal_entry, 4],
    ['TWT                            ',clc$abbreviation_entry, 4]],
    [
{ PARAMETER 1
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 2
    [12, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3, clc$required_parameter, 0
  , 0],
{ PARAMETER 3
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 5, clc$required_parameter, 0
  , 0],
{ PARAMETER 4
    [14, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 5
    [3, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 20,
  clc$optional_default_parameter, 0, 2],
{ PARAMETER 6
    [10, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 8, clc$optional_parameter, 0
  , 0],
{ PARAMETER 7
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_default_parameter, 0, 18],
{ PARAMETER 8
    [11, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation, clc$standard_parameter_checking, 3,
  clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 2
    [[1, 0, clc$file_type]],
{ PARAMETER 3
    [[1, 0, clc$name_type], [1, osc$max_name_size]],
{ PARAMETER 4
    [[1, 0, clc$integer_type], [clc$min_integer, clc$max_integer, 10],
    '16'],
{ PARAMETER 5
    [[1, 0, clc$integer_type], [1, clc$max_integer, 10],
    '10'],
{ PARAMETER 6
    [[1, 0, clc$string_type], [1, 63, FALSE]],
{ PARAMETER 7
    [[1, 0, clc$data_name_type],
    'credc_network_file'],
{ PARAMETER 8
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

    CONST
      p$device = 1,
      p$terminal_file = 2,
      p$application = 3,
      p$translation_wait_time = 4,
      p$connection_wait_time = 5,
      p$service_data = 6,
      p$network_file = 7,
      p$status = 8;

    VAR
      pvt: array [1 .. 8] of clt$parameter_value;

    VAR
      device_title: ^nat$title_pattern,
      ignore_status: ost$status,
      network_file_name: fst$temporary_file_path,
      network_file_value: clt$data_value,
      service_data: ^SEQ ( * ),
      type_spec_header: clt$type_specification_header;

?? EJECT ??
    status.normal := TRUE;

{   Isolate parameter values.

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    PUSH device_title: [#SIZE (pvt [p$device].value^.name_value)];
    device_title^ := pvt [p$device].value^.name_value;
    IF pvt [p$service_data].specified THEN
      service_data := #SEQ (pvt [p$service_data].value^.string_value^);
    ELSE
      service_data := NIL;
    IFEND;

{   Call the program interface to create the device connection.

    uop$create_device_connection (device_title^, pvt [p$terminal_file].
          value^.file_value^, pvt [p$application].value^.name_value,
          pvt [p$translation_wait_time].value^.integer_value.value,
          pvt [p$connection_wait_time].value^.integer_value.value, service_data, network_file_name, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Store the network file name in the specified SCL variable.

    network_file_value.kind := clc$file;
    network_file_value.file_value := ^network_file_name;
    clp$change_variable (pvt [p$network_file].value^.data_name_value, ^network_file_value, status);
    IF NOT status.normal THEN
      IF status.condition = cle$unknown_variable THEN
        type_spec_header.version := 1;
        type_spec_header.name_size := 0;
        type_spec_header.kind := clc$file_type;
        clp$create_environment_variable (pvt [p$network_file].value^.data_name_value, clc$job_scope,
              clc$read_write, clc$immediate_evaluation, #SEQ (type_spec_header), ^network_file_value, status);
      IFEND;
    IFEND;
    IF NOT status.normal THEN
      amp$return (network_file_name, ignore_status);
      amp$return (pvt [p$terminal_file].value^.file_value^, ignore_status);
      osp$generate_message (status, ignore_status);
      osp$set_status_abnormal ('  ', uoe$unable_to_change_nf_var, pvt [p$network_file].value^.data_name_value,
            status);
    IFEND;

  PROCEND uop$_create_device_connection;
?? TITLE := '[XDCL] uop$create_device_connection', EJECT ??
*copy uoh$create_device_connection

  PROCEDURE [XDCL] uop$create_device_connection
    (    device_title: nat$title_pattern;
         terminal_file_name: fst$file_reference;
         application_name: ost$name;
         translation_wait_time: integer;
         connection_wait_time: integer;
         service_data: ^SEQ ( * );
     VAR network_file_name: fst$temporary_file_path;
     VAR status: ost$status);

    TYPE
      uot$outcall_connect_data_header = record
        version: 0 .. 255,
        device_title: ost$name,
        service_data_length: 0 .. 63,
      recend;

    VAR
      connect_data: ^SEQ ( * ),
      connect_data_data: ^SEQ ( * ),
      connect_data_header: ^uot$outcall_connect_data_header,
      ignore_status: ost$status,
      network_attributes: array [1 .. 1] of nat$create_attribute,
      ready_index: integer,
      search_id: nat$directory_search_identifier,
      server_address: nat$network_address,
      terminal_attributes: array [1 .. 1] of ift$connection_attribute,
      translated_title: ost$name,
      translation_attributes: array [1 .. 2] of nat$translation_attribute,
      translation_attributes_p: ^nat$translation_attributes;

    status.normal := TRUE;

{   Validate parameters.

    IF (service_data <> NIL) AND (#SIZE (service_data^) > 63) THEN
      osp$set_status_condition (uoe$service_data_too_large, status);
      RETURN;
    IFEND;
    IF connection_wait_time <= 0 THEN
      osp$set_status_condition (uoe$invalid_conn_wait_time, status);
      RETURN;
    IFEND;

{   Translate the device's title to obtain the address of its device outcall server.

    nap$begin_directory_search (device_title, application_name, FALSE, search_id, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    translation_attributes [1].selector := nac$translation_title;
    translation_attributes [1].title := ^translated_title;
    translation_attributes [2].selector := nac$translation_priority;
    translation_attributes_p := ^translation_attributes;
    nap$get_title_translation (search_id, translation_wait_time * 1000, translation_attributes_p,
          server_address, status);
    nap$end_directory_search (search_id, ignore_status);
    IF NOT status.normal THEN
      IF status.condition = nae$directory_search_complete THEN
        osp$set_status_abnormal ('  ', uoe$server_not_active, device_title, status);
      ELSEIF status.condition = nae$no_translation_available THEN
        osp$set_status_abnormal ('  ', uoe$server_busy_or_not_active, device_title, status);
      IFEND;
      RETURN;
    IFEND;
    IF translation_attributes [2].priority = 0ff(16) THEN
      osp$set_status_abnormal ('  ', uoe$server_busy, device_title, status);
      RETURN;
    IFEND;

{   Generate a unique name for the network file.

    network_file_name := '$LOCAL.';
    pmp$get_unique_name (network_file_name (8, 31), status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{  Allocate space for the connect_data on the connection request.

    IF service_data = NIL THEN
      PUSH connect_data: [[REP #SIZE (uot$outcall_connect_data_header) OF cell]];
      NEXT connect_data_header IN connect_data;
      connect_data_header^.service_data_length := 0;
    ELSE
      PUSH connect_data: [[REP (#SIZE (uot$outcall_connect_data_header) + #SIZE (service_data^)) OF cell]];
      NEXT connect_data_header IN connect_data;
      connect_data_header^.service_data_length := #SIZE (service_data^);
      NEXT connect_data_data: [[REP connect_data_header^.service_data_length OF cell]] IN connect_data;
      connect_data_data^ := service_data^;
    IFEND;
    connect_data_header^.version := 1;
    connect_data_header^.device_title := translated_title;

{   Create a network connection to the Device Outcall Gateway.

    network_attributes [1].kind := nac$connect_data;
    network_attributes [1].connect_data := connect_data;

    nap$request_connection (server_address, application_name, network_file_name, nac$cdna_virtual_terminal,
          ^network_attributes, connection_wait_time * 1000, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

{   Create a terminal file for the connection.

    terminal_attributes [1].key := ifc$null_connection_attribute;
    rmp$request_terminal (terminal_file_name, ^network_file_name (8, 31), terminal_attributes, status);

{   *** Change the preceding line to the following when PSR NV0T624 is answered.

{   rmp$request_terminal (terminal_file_name, ^network_file_name, terminal_attributes, status);

    IF NOT status.normal THEN
      amp$return (network_file_name, ignore_status);
    IFEND;

  PROCEND uop$create_device_connection;
?? OLDTITLE ??
MODEND uom$create_device_connection;


*DECK DECK=UOM$CREATE_DEVICE_CONNECTION_PD EXPAND=TRUE
crepd (create_device_connection, credc) l=osf$current_library ..
    sp=uop$_create_device_connection lmo=none dm=off tel=fatal
*DECK DECK=UOM$CREDC_MESSAGE_MODULE EXPAND=TRUE
?? RIGHT := 110 ??
MODULE uom$credc_message_module;
{
{ PURPOSE:
{
{   This module contains message templates used by the CREATE_DEVICE_CONNECTION
{   command and program interfaces.
{

*copyc uoe$credc_condition_codes

MODEND uom$credc_message_module;
*DECK DECK=UOP$CREATE_DEVICE_CONNECTION EXPAND=FALSE

  PROCEDURE [XREF] uop$create_device_connection
    (    device_title: nat$title_pattern;
         terminal_file_name: fst$file_reference;
         application_name: ost$name;
         translation_wait_time: integer;
         connection_wait_time: integer;
         service_data: ^SEQ ( * );
     VAR network_file_name: fst$temporary_file_path;
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc fst$file_reference
*copyc fst$temporary_file_path
*copyc nat$title_pattern
*copyc ost$name
*copyc ost$status
*copyc uoe$credc_condition_codes
?? POP ??
*DECK DECK=USD#REPORT_FILES EXPAND=FALSE
{ PROCEDURE usp#report_files (
{   catalog, c: any of
{       key
{         all_families
{       keyend
{       file
{     anyend = $required
{   fields, f: list of record
{       attribute: key
{         (access_control_list, acl)
{         (account_project, ap)
{         (actual_job_access, access_mode, access_modes, am, aja)
{         (archive_media_descriptor, amd)
{         (attached, a)
{         (attached_external_vsn_list, aevl)
{         (attached_recorded_vsn_list, arvl)
{         (attached_transfer_size, ats)
{         (attached_vol_overflow_allowed, avoa)
{         (attached_volume_number, avn)
{         (attachment_log, al)
{         (attachment_logging_selected, als)
{         (average_record_length, arl)
{         (block_type, bt)
{         (character_conversion, cc)
{         (collate_table_name, ctn)
{         (compression_procedure_name, cpn)
{         (connected_files, cf)
{         (creation_date_time, cdt)
{         (cycle_number, cn)
{         (data_padding, dp)
{         (device_class, dc)
{         (dynamic_home_block_space, dhbs)
{         (embedded_key, ek)
{         (error_exit_procedure_name, een, error_exit_name, eepn)
{         (error_limit, el)
{         (estimated_record_count, erc)
{         (exception_conditions, exception_condition, ec)
{         (expiration_date, ed)
{         (external_vsn_list, evsnl, evl)
{         (file_access_procedure_name, fap, file_access_procedure, fapn)
{         (file_contents, file_structure, fs, file_content, fc)
{         (file_label_type, flt)
{         (file_limit, fl)
{         (file_name, fn)
{         (file_organization, fo)
{         (file_previously_opened, fpo)
{         (file_processor, fp)
{         (fill, f)
{         (forced_write, fw)
{         full_path
{         (hashing_procedure_name, hpn)
{         (index_levels, index_level, il)
{         (index_padding, ip)
{         (initial_home_block_count, ihbc)
{         (internal_code, ic)
{         (job_file_address, gfa, global_file_address, jfa)
{         (job_file_position, global_file_position, gfp, jfp)
{         (job_instances_of_open, jioo)
{         (job_write_concurrency, jwc)
{         (key_length, kl)
{         (key_position, kp)
{         (key_type, kt)
{         (last_access_date_time, ladt)
{         (last_data_modification_time, ldmd, last_data_modification_date, ..
{         ldmdt, ldmt)
{         (last_modification_date_time, lmdt)
{         (lifetime, permanent, l)
{         (lifetime_attachment_count, lac)
{         (line_number, ln)
{         (loading_factor, lf)
{         (lock_expiration_time, let)
{         (log_residence, lr)
{         (logging_options, lo)
{         (mainframe_attachment, ma)
{         (mainframe_write_concurrency, mwc)
{         (mass_storage_allocation_size, msas)
{         (mass_storage_bytes_allocated, msba)
{         (mass_storage_class, msc)
{         (mass_storage_free_behind, msfb)
{         (mass_storage_initial_volume, msiv)
{         (mass_storage_sequential_access, mssa)
{         (mass_storage_transfer_size, msts)
{         (maximum_block_length, maxbl)
{         (maximum_record_length, maxrl)
{         (message_control, mc)
{         (minimum_block_length, minbl)
{         (minimum_record_length, minrl)
{         (open_position, op)
{         (padding_character, pc)
{         (page_format, pf)
{         (page_length, pl)
{         (page_width, pw)
{         password
{         (path, p)
{         (permitted_access, application_information, application_info, ai, pa)
{         (potential_job_access, gsm, global_share_mode, global_access_mode, ..
{         global_access_modes, global_share_modes, gam, pja)
{         (preset_value, pv)
{         (private_read, pr)
{         (record_delimiting_character, rdc)
{         (record_limit, rl)
{         (record_type, rt)
{         (recorded_vsn_list, rvsnl, rvl)
{         (records_per_block, rpb)
{         (registered, r)
{         (retrieve_option, ro)
{         (ring_attributes, ring_attribute, ra)
{         (secondary_residence, sr)
{         (set_name, sn)
{         (shared_queue, sq)
{         (site_archive_option, sao)
{         (site_backup_option, sbo)
{         (site_release_option, sro)
{         (size, s)
{         (statement_identifier, si)
{         (tape_density, td)
{         (unique_data_name, gfn, global_file_name, udn)
{         (unique_name, un)
{         (user_information, ui)
{         (vertical_print_density, vpd)
{         (volume_overflow_allowed, voa)
{       keyend
{       field_width: integer 1..511 = $optional
{     recend = $required
{   output, o: file = $output
{   status)

?? PUSH (LISTEXT := ON) ??
?? FMT (FORMAT := OFF) ??

  VAR
    pdt: [STATIC, READ, cls$declaration_section] record
      header: clt$pdt_header,
      names: array [1 .. 7] of clt$pdt_parameter_name,
      parameters: array [1 .. 4] 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,
        recend,
      recend,
      type2: record
        header: clt$type_specification_header,
        qualifier: clt$list_type_qualifier_v2,
        element_type_spec: record
          header: clt$type_specification_header,
          qualifier: clt$record_type_qualifier,
          field_spec_1: clt$field_specification,
          element_type_spec_1: record
            header: clt$type_specification_header,
            qualifier: clt$keyword_type_qualifier,
            keyword_specs: array [1 .. 252] of clt$keyword_specification,
          recend,
          field_spec_2: clt$field_specification,
          element_type_spec_2: record
            header: clt$type_specification_header,
            qualifier: clt$integer_type_qualifier,
          recend,
        recend,
      recend,
      type3: record
        header: clt$type_specification_header,
        default_value: string (7),
      recend,
      type4: record
        header: clt$type_specification_header,
      recend,
    recend := [
    [1,
    [97, 4, 9, 13, 55, 34, 448],
    clc$command, 7, 4, 2, 0, 0, 0, 4, ''], [
    ['C                              ',clc$abbreviation_entry, 1],
    ['CATALOG                        ',clc$nominal_entry, 1],
    ['F                              ',clc$abbreviation_entry, 2],
    ['FIELDS                         ',clc$nominal_entry, 2],
    ['O                              ',clc$abbreviation_entry, 3],
    ['OUTPUT                         ',clc$nominal_entry, 3],
    ['STATUS                         ',clc$nominal_entry, 4]],
    [
{ PARAMETER 1
    [2, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 67, clc$required_parameter, 0, 0],
{ PARAMETER 2
    [4, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 9446, clc$required_parameter, 0, 0],
{ PARAMETER 3
    [6, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name, clc$specify_positionally],
    clc$pass_by_value, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_default_parameter, 0, 7],
{ PARAMETER 4
    [7, clc$normal_usage_entry, clc$non_secure_parameter,
    $clt$parameter_spec_methods[clc$specify_by_name],
    clc$pass_by_reference, clc$immediate_evaluation,
  clc$standard_parameter_checking, 3, clc$optional_parameter, 0, 0]],
{ PARAMETER 1
    [[1, 0, clc$union_type], [[clc$file_type, clc$keyword_type],
    FALSE, 2],
    44, [[1, 0, clc$keyword_type], [1], [
      ['ALL_FAMILIES                   ', clc$nominal_entry,
  clc$normal_usage_entry, 1]]
      ],
    3, [[1, 0, clc$file_type]]
    ],
{ PARAMETER 2
    [[1, 0, clc$list_type], [9430, 1, clc$max_list_size, 0, FALSE, FALSE],
      [[1, 0, clc$record_type], [2],
      ['ATTRIBUTE                      ', clc$required_field, 9331], [[1, 0,
  clc$keyword_type], [252], [
        ['A                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 5],
        ['ACCESS_CONTROL_LIST            ', clc$nominal_entry,
  clc$normal_usage_entry, 1],
        ['ACCESS_MODE                    ', clc$alias_entry,
  clc$normal_usage_entry, 3],
        ['ACCESS_MODES                   ', clc$alias_entry,
  clc$normal_usage_entry, 3],
        ['ACCOUNT_PROJECT                ', clc$nominal_entry,
  clc$normal_usage_entry, 2],
        ['ACL                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 1],
        ['ACTUAL_JOB_ACCESS              ', clc$nominal_entry,
  clc$normal_usage_entry, 3],
        ['AEVL                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 6],
        ['AI                             ', clc$alias_entry,
  clc$normal_usage_entry, 85],
        ['AJA                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 3],
        ['AL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 11],
        ['ALS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 12],
        ['AM                             ', clc$alias_entry,
  clc$normal_usage_entry, 3],
        ['AMD                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 4],
        ['AP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 2],
        ['APPLICATION_INFO               ', clc$alias_entry,
  clc$normal_usage_entry, 85],
        ['APPLICATION_INFORMATION        ', clc$alias_entry,
  clc$normal_usage_entry, 85],
        ['ARCHIVE_MEDIA_DESCRIPTOR       ', clc$nominal_entry,
  clc$normal_usage_entry, 4],
        ['ARL                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 13],
        ['ARVL                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 7],
        ['ATS                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 8],
        ['ATTACHED                       ', clc$nominal_entry,
  clc$normal_usage_entry, 5],
        ['ATTACHED_EXTERNAL_VSN_LIST     ', clc$nominal_entry,
  clc$normal_usage_entry, 6],
        ['ATTACHED_RECORDED_VSN_LIST     ', clc$nominal_entry,
  clc$normal_usage_entry, 7],
        ['ATTACHED_TRANSFER_SIZE         ', clc$nominal_entry,
  clc$normal_usage_entry, 8],
        ['ATTACHED_VOLUME_NUMBER         ', clc$nominal_entry,
  clc$normal_usage_entry, 10],
        ['ATTACHED_VOL_OVERFLOW_ALLOWED  ', clc$nominal_entry,
  clc$normal_usage_entry, 9],
        ['ATTACHMENT_LOG                 ', clc$nominal_entry,
  clc$normal_usage_entry, 11],
        ['ATTACHMENT_LOGGING_SELECTED    ', clc$nominal_entry,
  clc$normal_usage_entry, 12],
        ['AVERAGE_RECORD_LENGTH          ', clc$nominal_entry,
  clc$normal_usage_entry, 13],
        ['AVN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 10],
        ['AVOA                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 9],
        ['BLOCK_TYPE                     ', clc$nominal_entry,
  clc$normal_usage_entry, 14],
        ['BT                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 14],
        ['CC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 15],
        ['CDT                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 19],
        ['CF                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 18],
        ['CHARACTER_CONVERSION           ', clc$nominal_entry,
  clc$normal_usage_entry, 15],
        ['CN                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 20],
        ['COLLATE_TABLE_NAME             ', clc$nominal_entry,
  clc$normal_usage_entry, 16],
        ['COMPRESSION_PROCEDURE_NAME     ', clc$nominal_entry,
  clc$normal_usage_entry, 17],
        ['CONNECTED_FILES                ', clc$nominal_entry,
  clc$normal_usage_entry, 18],
        ['CPN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 17],
        ['CREATION_DATE_TIME             ', clc$nominal_entry,
  clc$normal_usage_entry, 19],
        ['CTN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 16],
        ['CYCLE_NUMBER                   ', clc$nominal_entry,
  clc$normal_usage_entry, 20],
        ['DATA_PADDING                   ', clc$nominal_entry,
  clc$normal_usage_entry, 21],
        ['DC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 22],
        ['DEVICE_CLASS                   ', clc$nominal_entry,
  clc$normal_usage_entry, 22],
        ['DHBS                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 23],
        ['DP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 21],
        ['DYNAMIC_HOME_BLOCK_SPACE       ', clc$nominal_entry,
  clc$normal_usage_entry, 23],
        ['EC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 28],
        ['ED                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 29],
        ['EEN                            ', clc$alias_entry,
  clc$normal_usage_entry, 25],
        ['EEPN                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 25],
        ['EK                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 24],
        ['EL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 26],
        ['EMBEDDED_KEY                   ', clc$nominal_entry,
  clc$normal_usage_entry, 24],
        ['ERC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 27],
        ['ERROR_EXIT_NAME                ', clc$alias_entry,
  clc$normal_usage_entry, 25],
        ['ERROR_EXIT_PROCEDURE_NAME      ', clc$nominal_entry,
  clc$normal_usage_entry, 25],
        ['ERROR_LIMIT                    ', clc$nominal_entry,
  clc$normal_usage_entry, 26],
        ['ESTIMATED_RECORD_COUNT         ', clc$nominal_entry,
  clc$normal_usage_entry, 27],
        ['EVL                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 30],
        ['EVSNL                          ', clc$alias_entry,
  clc$normal_usage_entry, 30],
        ['EXCEPTION_CONDITION            ', clc$alias_entry,
  clc$normal_usage_entry, 28],
        ['EXCEPTION_CONDITIONS           ', clc$nominal_entry,
  clc$normal_usage_entry, 28],
        ['EXPIRATION_DATE                ', clc$nominal_entry,
  clc$normal_usage_entry, 29],
        ['EXTERNAL_VSN_LIST              ', clc$nominal_entry,
  clc$normal_usage_entry, 30],
        ['F                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 39],
        ['FAP                            ', clc$alias_entry,
  clc$normal_usage_entry, 31],
        ['FAPN                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 31],
        ['FC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 32],
        ['FILE_ACCESS_PROCEDURE          ', clc$alias_entry,
  clc$normal_usage_entry, 31],
        ['FILE_ACCESS_PROCEDURE_NAME     ', clc$nominal_entry,
  clc$normal_usage_entry, 31],
        ['FILE_CONTENT                   ', clc$alias_entry,
  clc$normal_usage_entry, 32],
        ['FILE_CONTENTS                  ', clc$nominal_entry,
  clc$normal_usage_entry, 32],
        ['FILE_LABEL_TYPE                ', clc$nominal_entry,
  clc$normal_usage_entry, 33],
        ['FILE_LIMIT                     ', clc$nominal_entry,
  clc$normal_usage_entry, 34],
        ['FILE_NAME                      ', clc$nominal_entry,
  clc$normal_usage_entry, 35],
        ['FILE_ORGANIZATION              ', clc$nominal_entry,
  clc$normal_usage_entry, 36],
        ['FILE_PREVIOUSLY_OPENED         ', clc$nominal_entry,
  clc$normal_usage_entry, 37],
        ['FILE_PROCESSOR                 ', clc$nominal_entry,
  clc$normal_usage_entry, 38],
        ['FILE_STRUCTURE                 ', clc$alias_entry,
  clc$normal_usage_entry, 32],
        ['FILL                           ', clc$nominal_entry,
  clc$normal_usage_entry, 39],
        ['FL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 34],
        ['FLT                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 33],
        ['FN                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 35],
        ['FO                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 36],
        ['FORCED_WRITE                   ', clc$nominal_entry,
  clc$normal_usage_entry, 40],
        ['FP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 38],
        ['FPO                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 37],
        ['FS                             ', clc$alias_entry,
  clc$normal_usage_entry, 32],
        ['FULL_PATH                      ', clc$nominal_entry,
  clc$normal_usage_entry, 41],
        ['FW                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 40],
        ['GAM                            ', clc$alias_entry,
  clc$normal_usage_entry, 86],
        ['GFA                            ', clc$alias_entry,
  clc$normal_usage_entry, 47],
        ['GFN                            ', clc$alias_entry,
  clc$normal_usage_entry, 106],
        ['GFP                            ', clc$alias_entry,
  clc$normal_usage_entry, 48],
        ['GLOBAL_ACCESS_MODE             ', clc$alias_entry,
  clc$normal_usage_entry, 86],
        ['GLOBAL_ACCESS_MODES            ', clc$alias_entry,
  clc$normal_usage_entry, 86],
        ['GLOBAL_FILE_ADDRESS            ', clc$alias_entry,
  clc$normal_usage_entry, 47],
        ['GLOBAL_FILE_NAME               ', clc$alias_entry,
  clc$normal_usage_entry, 106],
        ['GLOBAL_FILE_POSITION           ', clc$alias_entry,
  clc$normal_usage_entry, 48],
        ['GLOBAL_SHARE_MODE              ', clc$alias_entry,
  clc$normal_usage_entry, 86],
        ['GLOBAL_SHARE_MODES             ', clc$alias_entry,
  clc$normal_usage_entry, 86],
        ['GSM                            ', clc$alias_entry,
  clc$normal_usage_entry, 86],
        ['HASHING_PROCEDURE_NAME         ', clc$nominal_entry,
  clc$normal_usage_entry, 42],
        ['HPN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 42],
        ['IC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 46],
        ['IHBC                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 45],
        ['IL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 43],
        ['INDEX_LEVEL                    ', clc$alias_entry,
  clc$normal_usage_entry, 43],
        ['INDEX_LEVELS                   ', clc$nominal_entry,
  clc$normal_usage_entry, 43],
        ['INDEX_PADDING                  ', clc$nominal_entry,
  clc$normal_usage_entry, 44],
        ['INITIAL_HOME_BLOCK_COUNT       ', clc$nominal_entry,
  clc$normal_usage_entry, 45],
        ['INTERNAL_CODE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 46],
        ['IP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 44],
        ['JFA                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 47],
        ['JFP                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 48],
        ['JIOO                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 49],
        ['JOB_FILE_ADDRESS               ', clc$nominal_entry,
  clc$normal_usage_entry, 47],
        ['JOB_FILE_POSITION              ', clc$nominal_entry,
  clc$normal_usage_entry, 48],
        ['JOB_INSTANCES_OF_OPEN          ', clc$nominal_entry,
  clc$normal_usage_entry, 49],
        ['JOB_WRITE_CONCURRENCY          ', clc$nominal_entry,
  clc$normal_usage_entry, 50],
        ['JWC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 50],
        ['KEY_LENGTH                     ', clc$nominal_entry,
  clc$normal_usage_entry, 51],
        ['KEY_POSITION                   ', clc$nominal_entry,
  clc$normal_usage_entry, 52],
        ['KEY_TYPE                       ', clc$nominal_entry,
  clc$normal_usage_entry, 53],
        ['KL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 51],
        ['KP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 52],
        ['KT                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 53],
        ['L                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 57],
        ['LAC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 58],
        ['LADT                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 54],
        ['LAST_ACCESS_DATE_TIME          ', clc$nominal_entry,
  clc$normal_usage_entry, 54],
        ['LAST_DATA_MODIFICATION_DATE    ', clc$alias_entry,
  clc$normal_usage_entry, 55],
        ['LAST_DATA_MODIFICATION_TIME    ', clc$nominal_entry,
  clc$normal_usage_entry, 55],
        ['LAST_MODIFICATION_DATE_TIME    ', clc$nominal_entry,
  clc$normal_usage_entry, 56],
        ['LDMD                           ', clc$alias_entry,
  clc$normal_usage_entry, 55],
        ['LDMDT                          ', clc$alias_entry,
  clc$normal_usage_entry, 55],
        ['LDMT                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 55],
        ['LET                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 61],
        ['LF                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 60],
        ['LIFETIME                       ', clc$nominal_entry,
  clc$normal_usage_entry, 57],
        ['LIFETIME_ATTACHMENT_COUNT      ', clc$nominal_entry,
  clc$normal_usage_entry, 58],
        ['LINE_NUMBER                    ', clc$nominal_entry,
  clc$normal_usage_entry, 59],
        ['LMDT                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 56],
        ['LN                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 59],
        ['LO                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 63],
        ['LOADING_FACTOR                 ', clc$nominal_entry,
  clc$normal_usage_entry, 60],
        ['LOCK_EXPIRATION_TIME           ', clc$nominal_entry,
  clc$normal_usage_entry, 61],
        ['LOGGING_OPTIONS                ', clc$nominal_entry,
  clc$normal_usage_entry, 63],
        ['LOG_RESIDENCE                  ', clc$nominal_entry,
  clc$normal_usage_entry, 62],
        ['LR                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 62],
        ['MA                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 64],
        ['MAINFRAME_ATTACHMENT           ', clc$nominal_entry,
  clc$normal_usage_entry, 64],
        ['MAINFRAME_WRITE_CONCURRENCY    ', clc$nominal_entry,
  clc$normal_usage_entry, 65],
        ['MASS_STORAGE_ALLOCATION_SIZE   ', clc$nominal_entry,
  clc$normal_usage_entry, 66],
        ['MASS_STORAGE_BYTES_ALLOCATED   ', clc$nominal_entry,
  clc$normal_usage_entry, 67],
        ['MASS_STORAGE_CLASS             ', clc$nominal_entry,
  clc$normal_usage_entry, 68],
        ['MASS_STORAGE_FREE_BEHIND       ', clc$nominal_entry,
  clc$normal_usage_entry, 69],
        ['MASS_STORAGE_INITIAL_VOLUME    ', clc$nominal_entry,
  clc$normal_usage_entry, 70],
        ['MASS_STORAGE_SEQUENTIAL_ACCESS ', clc$nominal_entry,
  clc$normal_usage_entry, 71],
        ['MASS_STORAGE_TRANSFER_SIZE     ', clc$nominal_entry,
  clc$normal_usage_entry, 72],
        ['MAXBL                          ', clc$abbreviation_entry,
  clc$normal_usage_entry, 73],
        ['MAXIMUM_BLOCK_LENGTH           ', clc$nominal_entry,
  clc$normal_usage_entry, 73],
        ['MAXIMUM_RECORD_LENGTH          ', clc$nominal_entry,
  clc$normal_usage_entry, 74],
        ['MAXRL                          ', clc$abbreviation_entry,
  clc$normal_usage_entry, 74],
        ['MC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 75],
        ['MESSAGE_CONTROL                ', clc$nominal_entry,
  clc$normal_usage_entry, 75],
        ['MINBL                          ', clc$abbreviation_entry,
  clc$normal_usage_entry, 76],
        ['MINIMUM_BLOCK_LENGTH           ', clc$nominal_entry,
  clc$normal_usage_entry, 76],
        ['MINIMUM_RECORD_LENGTH          ', clc$nominal_entry,
  clc$normal_usage_entry, 77],
        ['MINRL                          ', clc$abbreviation_entry,
  clc$normal_usage_entry, 77],
        ['MSAS                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 66],
        ['MSBA                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 67],
        ['MSC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 68],
        ['MSFB                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 69],
        ['MSIV                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 70],
        ['MSSA                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 71],
        ['MSTS                           ', clc$abbreviation_entry,
  clc$normal_usage_entry, 72],
        ['MWC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 65],
        ['OP                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 78],
        ['OPEN_POSITION                  ', clc$nominal_entry,
  clc$normal_usage_entry, 78],
        ['P                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 84],
        ['PA                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 85],
        ['PADDING_CHARACTER              ', clc$nominal_entry,
  clc$normal_usage_entry, 79],
        ['PAGE_FORMAT                    ', clc$nominal_entry,
  clc$normal_usage_entry, 80],
        ['PAGE_LENGTH                    ', clc$nominal_entry,
  clc$normal_usage_entry, 81],
        ['PAGE_WIDTH                     ', clc$nominal_entry,
  clc$normal_usage_entry, 82],
        ['PASSWORD                       ', clc$nominal_entry,
  clc$normal_usage_entry, 83],
        ['PATH                           ', clc$nominal_entry,
  clc$normal_usage_entry, 84],
        ['PC                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 79],
        ['PERMANENT                      ', clc$alias_entry,
  clc$normal_usage_entry, 57],
        ['PERMITTED_ACCESS               ', clc$nominal_entry,
  clc$normal_usage_entry, 85],
        ['PF                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 80],
        ['PJA                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 86],
        ['PL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 81],
        ['POTENTIAL_JOB_ACCESS           ', clc$nominal_entry,
  clc$normal_usage_entry, 86],
        ['PR                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 88],
        ['PRESET_VALUE                   ', clc$nominal_entry,
  clc$normal_usage_entry, 87],
        ['PRIVATE_READ                   ', clc$nominal_entry,
  clc$normal_usage_entry, 88],
        ['PV                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 87],
        ['PW                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 82],
        ['R                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 94],
        ['RA                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 96],
        ['RDC                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 89],
        ['RECORDED_VSN_LIST              ', clc$nominal_entry,
  clc$normal_usage_entry, 92],
        ['RECORDS_PER_BLOCK              ', clc$nominal_entry,
  clc$normal_usage_entry, 93],
        ['RECORD_DELIMITING_CHARACTER    ', clc$nominal_entry,
  clc$normal_usage_entry, 89],
        ['RECORD_LIMIT                   ', clc$nominal_entry,
  clc$normal_usage_entry, 90],
        ['RECORD_TYPE                    ', clc$nominal_entry,
  clc$normal_usage_entry, 91],
        ['REGISTERED                     ', clc$nominal_entry,
  clc$normal_usage_entry, 94],
        ['RETRIEVE_OPTION                ', clc$nominal_entry,
  clc$normal_usage_entry, 95],
        ['RING_ATTRIBUTE                 ', clc$alias_entry,
  clc$normal_usage_entry, 96],
        ['RING_ATTRIBUTES                ', clc$nominal_entry,
  clc$normal_usage_entry, 96],
        ['RL                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 90],
        ['RO                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 95],
        ['RPB                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 93],
        ['RT                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 91],
        ['RVL                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 92],
        ['RVSNL                          ', clc$alias_entry,
  clc$normal_usage_entry, 92],
        ['S                              ', clc$abbreviation_entry,
  clc$normal_usage_entry, 103],
        ['SAO                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 100],
        ['SBO                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 101],
        ['SECONDARY_RESIDENCE            ', clc$nominal_entry,
  clc$normal_usage_entry, 97],
        ['SET_NAME                       ', clc$nominal_entry,
  clc$normal_usage_entry, 98],
        ['SHARED_QUEUE                   ', clc$nominal_entry,
  clc$normal_usage_entry, 99],
        ['SI                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 104],
        ['SITE_ARCHIVE_OPTION            ', clc$nominal_entry,
  clc$normal_usage_entry, 100],
        ['SITE_BACKUP_OPTION             ', clc$nominal_entry,
  clc$normal_usage_entry, 101],
        ['SITE_RELEASE_OPTION            ', clc$nominal_entry,
  clc$normal_usage_entry, 102],
        ['SIZE                           ', clc$nominal_entry,
  clc$normal_usage_entry, 103],
        ['SN                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 98],
        ['SQ                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 99],
        ['SR                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 97],
        ['SRO                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 102],
        ['STATEMENT_IDENTIFIER           ', clc$nominal_entry,
  clc$normal_usage_entry, 104],
        ['TAPE_DENSITY                   ', clc$nominal_entry,
  clc$normal_usage_entry, 105],
        ['TD                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 105],
        ['UDN                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 106],
        ['UI                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 108],
        ['UN                             ', clc$abbreviation_entry,
  clc$normal_usage_entry, 107],
        ['UNIQUE_DATA_NAME               ', clc$nominal_entry,
  clc$normal_usage_entry, 106],
        ['UNIQUE_NAME                    ', clc$nominal_entry,
  clc$normal_usage_entry, 107],
        ['USER_INFORMATION               ', clc$nominal_entry,
  clc$normal_usage_entry, 108],
        ['VERTICAL_PRINT_DENSITY         ', clc$nominal_entry,
  clc$normal_usage_entry, 109],
        ['VOA                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 110],
        ['VOLUME_OVERFLOW_ALLOWED        ', clc$nominal_entry,
  clc$normal_usage_entry, 110],
        ['VPD                            ', clc$abbreviation_entry,
  clc$normal_usage_entry, 109]]
        ],
      ['FIELD_WIDTH                    ', clc$optional_field, 20], [[1, 0,
  clc$integer_type], [1, 511, 10]]
      ]
    ],
{ PARAMETER 3
    [[1, 0, clc$file_type],
    '$output'],
{ PARAMETER 4
    [[1, 0, clc$status_type]]];

?? FMT (FORMAT := ON) ??
?? POP ??

  CONST
    p$catalog = 1,
    p$fields = 2,
    p$output = 3,
    p$status = 4;

  VAR
    pvt: array [1 .. 4] of clt$parameter_value;
*DECK DECK=USM#REPORT_FILES EXPAND=TRUE
MODULE usm#report_files;
?? RIGHT := 90 ??

{USP#REPORT_FILES

?? NEWTITLE := 'Global Declarations Referenced By This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??

*copyc ost$halfword
*copyc fmt$file_attribute_keys
?? POP ??
*copyc fip#create_scratch_sequence

*copyc clp$convert_integer_to_rjstring
*copyc clp$convert_integer_to_string
*copyc clp$evaluate_parameters
*copyc clp$open_display_reference
*copyc clp$put_display
*copyc clp$trimmed_string_size
*copyc fsp$adjust_tape_defaults
*copyc fsp$convert_file_contents
*copyc fsp$expand_file_label
*copyc ofp$display_status_message
*copyc osp$set_status_condition
*copyc pfp$get_object_information
*copyc pmp$convert_binary_unique_name
*copyc pmp$format_compact_date
*copyc pmp$format_compact_time
*copyc pmp$get_family_names
*copyc osv$upper_to_lower

?? TITLE := 'Global Declarations Defined By This Module', EJECT ??

  SECTION
    s#sec1: READ;

  CONST
    e#unknown_attribute = 1;

  VAR
    access_share_modes: [READ, s#sec1] array [fst$file_access_option] of ^string ( * ) :=
          [^l#asm_1, ^l#asm_2, ^l#asm_3, ^l#asm_4, ^l#asm_5],
    l#asm_1: [READ, s#sec1] string (4) := 'READ',
    l#asm_2: [READ, s#sec1] string (7) := 'SHORTEN',
    l#asm_3: [READ, s#sec1] string (6) := 'APPEND',
    l#asm_4: [READ, s#sec1] string (6) := 'MODIFY',
    l#asm_5: [READ, s#sec1] string (7) := 'EXECUTE',
    block_types: [READ, s#sec1] array [amt$block_type] of ^string ( * ) :=
          [^l#bt_1, ^l#bt_2],
    l#bt_1: [READ, s#sec1] string (c#dw_bt) := 'SYSTEM_SPECIFIED',
    l#bt_2: [READ, s#sec1] string (14) := 'USER_SPECIFIED',
    class: [READ, s#sec1] array [rmt$device_class] of ^string ( * ) :=
          [^l#c_1, ^l#c_2, ^l#c_3, ^l#c_4, ^l#c_5, ^l#c_6, ^l#c_7, ^l#c_8, ^l#c_9,
          ^l#c_10, ^l#c_11, ^l#c_12],
    l#c_1: [READ, s#sec1] string (14) := 'CONNECTED_FILE',
    l#c_2: [READ, s#sec1] string (c#dw_dc) := 'INTERSTATE_LINK',
    l#c_3: [READ, s#sec1] string (11) := 'LOCAL_QUEUE',
    l#c_4: [READ, s#sec1] string (3) := 'LOG',
    l#c_5: [READ, s#sec1] string (13) := 'MAGNETIC_TAPE',
    l#c_6: [READ, s#sec1] string (12) := 'MASS_STORAGE',
    l#c_7: [READ, s#sec1] string (c#dw_dc) := 'MEMORY_RESIDENT',
    l#c_8: [READ, s#sec1] string (7) := 'NETWORK',
    l#c_9: [READ, s#sec1] string (4) := 'NULL',
    l#c_10: [READ, s#sec1] string (8) := 'PIPELINE',
    l#c_11: [READ, s#sec1] string (5) := 'RHFAM',
    l#c_12: [READ, s#sec1] string (8) := 'TERMINAL',
    file_organizations: [READ, s#sec1] array [amt$file_organization] of ^string ( * ) :=
          [^l#fo_1, ^l#fo_2, ^l#fo_3, ^l#fo_4, ^l#fo_5],
    l#fo_1: [READ, s#sec1] string (10) := 'SEQUENTIAL',
    l#fo_2: [READ, s#sec1] string (16) := 'BYTE_ADDRESSABLE',
    l#fo_3: [READ, s#sec1] string (c#dw_fo) := 'INDEXED_SEQUENTIAL',
    l#fo_4: [READ, s#sec1] string (13) := 'DIRECT_ACCESS',
    l#fo_5: [READ, s#sec1] string (10) := 'SYSTEM_KEY',
    global_file_positions: [READ, s#sec1] array [amt$file_position] of ^string ( * ) :=
          [^l#gfp_1, ^l#gfp_2, ^l#gfp_3, ^l#gfp_4, ^l#gfp_5, ^l#gfp_6, ^l#gfp_7],
    l#gfp_1: [READ, s#sec1] string (3) := 'BOI',
    l#gfp_2: [READ, s#sec1] string (3) := 'BOP',
    l#gfp_3: [READ, s#sec1] string (10) := 'MID_RECORD',
    l#gfp_4: [READ, s#sec1] string (3) := 'EOR',
    l#gfp_5: [READ, s#sec1] string (3) := 'EOP',
    l#gfp_6: [READ, s#sec1] string (3) := 'EOI',
    l#gfp_7: [READ, s#sec1] string (15) := 'END_OF_KEY_LIST',
    internal_codes: [READ, s#sec1] array [amt$internal_code] of ^string ( * ) :=
          [^l#ic_1, ^l#ic_2, ^l#ic_3, ^l#ic_4, ^l#ic_5, ^l#ic_6, ^l#ic_7, ^l#ic_8,
          ^l#ic_9, ^l#ic_10, ^l#ic_11, ^l#ic_12, ^l#ic_13, ^l#ic_14, ^l#ic_15],
    l#ic_1: [READ, s#sec1] string (2) := 'A6',
    l#ic_2: [READ, s#sec1] string (2) := 'A8',
    l#ic_3: [READ, s#sec1] string (5) := 'ASCII',
    l#ic_4: [READ, s#sec1] string (3) := 'D64',
    l#ic_5: [READ, s#sec1] string (6) := 'EBCDIC',
    l#ic_6: [READ, s#sec1] string (3) := 'BCD',
    l#ic_7: [READ, s#sec1] string (3) := 'D63',
    l#ic_8: [READ, s#sec1] string (9) := 'FTAM1 IA5',
    l#ic_9: [READ, s#sec1] string (c#dw_ic) := 'FTAM1 VISIBLE',
    l#ic_10: [READ, s#sec1] string (c#dw_ic) := 'FTAM1 GRAPHIC',
    l#ic_11: [READ, s#sec1] string (c#dw_ic) := 'FTAM1 GENERAL',
    l#ic_12: [READ, s#sec1] string (9) := 'FTAM2 IA5',
    l#ic_13: [READ, s#sec1] string (c#dw_ic) := 'FTAM2 VISIBLE',
    l#ic_14: [READ, s#sec1] string (c#dw_ic) := 'FTAM2 GRAPHIC',
    l#ic_15: [READ, s#sec1] string (c#dw_ic) := 'FTAM2 GENERAL',
    job_file_positions: [READ, s#sec1] array [amt$file_position] of ^string ( * ) :=
          [^l#jfp_1, ^l#jfp_2, ^l#jfp_3, ^l#jfp_4, ^l#jfp_5, ^l#jfp_6, ^l#jfp_7],
    l#jfp_1: [READ, s#sec1] string (4) := '$BOI',
    l#jfp_2: [READ, s#sec1] string (4) := '$BOP',
    l#jfp_3: [READ, s#sec1] string (11) := '$MID_RECORD',
    l#jfp_4: [READ, s#sec1] string (4) := '$EOR',
    l#jfp_5: [READ, s#sec1] string (4) := '$EOP',
    l#jfp_6: [READ, s#sec1] string (4) := '$EOI',
    l#jfp_7: [READ, s#sec1] string (c#dw_jfp) := '$END_OF_KEY_LIST',
    key_types: [READ, s#sec1] array [amt$key_type] of ^string ( * ) :=
          [^l#kt_1, ^l#kt_2, ^l#kt_3],
    l#kt_1: [READ, s#sec1] string (8) := 'COLLATED',
    l#kt_2: [READ, s#sec1] string (7) := 'INTEGER',
    l#kt_3: [READ, s#sec1] string (c#dw_kt) := 'UNCOLLATED',
    label_types: [READ, s#sec1] array [amt$label_type] of ^string ( * ) :=
          [^l#lt_1, ^l#lt_2, ^l#lt_3],
    l#lt_1: [READ, s#sec1] string (7) := 'LABELED',
    l#lt_2: [READ, s#sec1] string (c#dw_flt) := 'NON_STANDARD_LABELED',
    l#lt_3: [READ, s#sec1] string (9) := 'UNLABELED',
    logging_possibilities: [READ, s#sec1] array
          [amc$enable_parcels .. amc$enable_request_recovery] of ^string ( * ) :=
          [^l#lp_1, ^l#lp_2, ^l#lp_3],
    l#lp_1: [READ, s#sec1] string (14) := 'ENABLE_PARCELS',
    l#lp_2: [READ, s#sec1] string (21) := 'ENABLE_MEDIA_RECOVERY',
    l#lp_3: [READ, s#sec1] string (23) := 'ENABLE_REQUEST_RECOVERY',
    mainframe_attachments: [READ, s#sec1] array [fst$mf_usage_concurrency_scope] of
          ^string ( * ) := [^l#ma_1, ^l#ma_2],
    l#ma_1: [READ, s#sec1] string (20) := 'REQUESTING_MAINFRAME',
    l#ma_2: [READ, s#sec1] string (19) := 'DIFFERENT_MAINFRAME',
    mainframe_write_concurrencies: [READ, s#sec1] array
          [fst$mainframe_write_concurrency] of ^string ( * ) :=
          [^l#mwc_1, ^l#mwc_2, ^l#mwc_3],
    l#mwc_1: [READ, s#sec1] string (c#dw_mwc) := 'NOT_ATTACHED_FOR_WRITE',
    l#mwc_2: [READ, s#sec1] string (13) := 'SHARED_MEMORY',
    l#mwc_3: [READ, s#sec1] string (19) := 'SHARED_MASS_STORAGE',
    message_controls: [READ, s#sec1] array [amc$trivial_errors .. amc$statistics] of
          ^string ( * ) := [^l#mc_1, ^l#mc_2, ^l#mc_3],
    l#mc_1: [READ, s#sec1] string (14) := 'TRIVIAL_ERRORS',
    l#mc_2: [READ, s#sec1] string (8) := 'MESSAGES',
    l#mc_3: [READ, s#sec1] string (10) := 'STATISTICS',
    open_positions: [READ, s#sec1] array [amt$open_position] of ^string ( * ) :=
          [^l#op_1, ^l#op_2, ^l#op_3, ^l#op_4],
    l#op_1: [READ, s#sec1] string (5) := '$ASIS',
    l#op_2: [READ, s#sec1] string (4) := '$BOI',
    l#op_3: [READ, s#sec1] string (4) := '$BOP',
    l#op_4: [READ, s#sec1] string (4) := '$EOI',
    page_formats: [READ, s#sec1] array [amt$page_format] of ^string ( * ) :=
          [^l#pf_1, ^l#pf_2, ^l#pf_3, ^l#pf_4],
    l#pf_1: [READ, s#sec1] string (10) := 'CONTINUOUS',
    l#pf_2: [READ, s#sec1] string (9) := 'BURSTABLE',
    l#pf_3: [READ, s#sec1] string (c#dw_pf) := 'NON_BURSTABLE',
    l#pf_4: [READ, s#sec1] string (8) := 'UNTITLED',
    permit_share_options: [READ, s#sec1] array [pft$permit_options] of ^string ( * ) :=
          [^l#pso_1, ^l#pso_2, ^l#pso_3, ^l#pso_4, ^l#pso_5, ^l#pso_6, ^l#pso_7],
    l#pso_1: [READ, s#sec1] string (4) := 'READ',
    l#pso_2: [READ, s#sec1] string (7) := 'SHORTEN',
    l#pso_3: [READ, s#sec1] string (6) := 'APPEND',
    l#pso_4: [READ, s#sec1] string (6) := 'MODIFY',
    l#pso_5: [READ, s#sec1] string (7) := 'EXECUTE',
    l#pso_6: [READ, s#sec1] string (5) := 'CYCLE',
    l#pso_7: [READ, s#sec1] string (7) := 'CONTROL',
    record_types: [READ, s#sec1] array [amt$record_type] of ^string ( * ) :=
          [^l#rt_1, ^l#rt_2, ^l#rt_3, ^l#rt_4, ^l#rt_5, ^l#rt_6],
    l#rt_1: [READ, s#sec1] string (8) := 'VARIABLE',
    l#rt_2: [READ, s#sec1] string (9) := 'UNDEFINED',
    l#rt_3: [READ, s#sec1] string (10) := 'ANSI_FIXED',
    l#rt_4: [READ, s#sec1] string (12) := 'ANSI_SPANNED',
    l#rt_5: [READ, s#sec1] string (13) := 'ANSI_VARIABLE',
    l#rt_6: [READ, s#sec1] string (c#dw_rt) := 'TRAILING_CHARACTER_DELIMITED',
    reserved_file_processors: [READ, s#sec1] array [1 .. c#max_file_processor] of
          ^string ( * ) := [^l#rfp_1, ^l#rfp_2, ^l#rfp_3, ^l#rfp_4, ^l#rfp_5, ^l#rfp_6,
          ^l#rfp_7, ^l#rfp_8, ^l#rfp_9, ^l#rfp_10, ^l#rfp_11, ^l#rfp_12, ^l#rfp_13,
          ^l#rfp_14, ^l#rfp_15, ^l#rfp_16, ^l#rfp_17, ^l#rfp_18],
    l#rfp_1: [READ, s#sec1] string (3) := 'ADA',
    l#rfp_2: [READ, s#sec1] string (3) := 'APL',
    l#rfp_3: [READ, s#sec1] string (9) := 'ASSEMBLER',
    l#rfp_4: [READ, s#sec1] string (5) := 'BASIC',
    l#rfp_5: [READ, s#sec1] string (1) := 'C',
    l#rfp_6: [READ, s#sec1] string (5) := 'COBOL',
    l#rfp_7: [READ, s#sec1] string (5) := 'CYBIL',
    l#rfp_8: [READ, s#sec1] string (8) := 'DEBUGGER',
    l#rfp_9: [READ, s#sec1] string (7) := 'FORTRAN',
    l#rfp_10: [READ, s#sec1] string (4) := 'LISP',
    l#rfp_11: [READ, s#sec1] string (6) := 'PASCAL',
    l#rfp_12: [READ, s#sec1] string (3) := 'PLI',
    l#rfp_13: [READ, s#sec1] string (13) := 'PPU_ASSEMBLER',
    l#rfp_14: [READ, s#sec1] string (6) := 'PROLOG',
    l#rfp_15: [READ, s#sec1] string (3) := 'SCL',
    l#rfp_16: [READ, s#sec1] string (3) := 'SCU',
    l#rfp_17: [READ, s#sec1] string (2) := 'VS',
    l#rfp_18: [READ, s#sec1] string (7) := 'UNKNOWN',
    tape_densities: [READ, s#sec1] array [rmc$200 .. rmc$38000] of ^string ( * ) :=
          [^l#td_1, ^l#td_2, ^l#td_3, ^l#td_4, ^l#td_5, ^l#td_6],
    l#td_1: [READ, s#sec1] string (7) := 'MT9$200',
    l#td_2: [READ, s#sec1] string (7) := 'MT9$556',
    l#td_3: [READ, s#sec1] string (7) := 'MT9$800',
    l#td_4: [READ, s#sec1] string (8) := 'MT9$1600',
    l#td_5: [READ, s#sec1] string (8) := 'MT9$6250',
    l#td_6: [READ, s#sec1] string (c#dw_td) := 'MT18$38000';

?? EJECT ??

  CONST
    c#fa_access_control_list = 1,
    c#fa_account_project = c#fa_access_control_list + 1,
    c#fa_actual_job_access = c#fa_account_project + 1,
    c#fa_archive_media_descriptor = c#fa_actual_job_access + 1,
    c#fa_attached = c#fa_archive_media_descriptor + 1,
    c#fa_attached_external_vsn_list = c#fa_attached + 1,
    c#fa_attached_recorded_vsn_list = c#fa_attached_external_vsn_list + 1,
    c#fa_attached_transfer_size = c#fa_attached_recorded_vsn_list + 1,
    c#fa_attached_vol_oflo_allowed = c#fa_attached_transfer_size + 1,
    c#fa_attached_volume_number = c#fa_attached_vol_oflo_allowed + 1,
    c#fa_attachment_log = c#fa_attached_volume_number + 1,
    c#fa_attachment_logging_sel = c#fa_attachment_log + 1,
    c#fa_average_record_length = c#fa_attachment_logging_sel + 1,
    c#fa_block_type = c#fa_average_record_length + 1,
    c#fa_character_conversion = c#fa_block_type + 1,
    c#fa_collate_table_name = c#fa_character_conversion + 1,
    c#fa_compression_procedure_name = c#fa_collate_table_name + 1,
    c#fa_connected_files = c#fa_compression_procedure_name + 1,
    c#fa_creation_date_time = c#fa_connected_files + 1,
    c#fa_cycle_number = c#fa_creation_date_time + 1,
    c#fa_data_padding = c#fa_cycle_number + 1,
    c#fa_device_class = c#fa_data_padding + 1,
    c#fa_dynamic_home_block_space = c#fa_device_class + 1,
    c#fa_embedded_key = c#fa_dynamic_home_block_space + 1,
    c#fa_error_exit_procedure_name = c#fa_embedded_key + 1,
    c#fa_error_limit = c#fa_error_exit_procedure_name + 1,
    c#fa_estimated_record_count = c#fa_error_limit + 1,
    c#fa_exception_conditions = c#fa_estimated_record_count + 1,
    c#fa_expiration_date = c#fa_exception_conditions + 1,
    c#fa_external_vsn_list = c#fa_expiration_date + 1,
    c#fa_file_access_procedure_name = c#fa_external_vsn_list + 1,
    c#fa_file_contents = c#fa_file_access_procedure_name + 1,
    c#fa_file_label_type = c#fa_file_contents + 1,
    c#fa_file_limit = c#fa_file_label_type + 1,
    c#fa_file_name = c#fa_file_limit + 1,
    c#fa_file_organization = c#fa_file_name + 1,
    c#fa_file_previously_opened = c#fa_file_organization + 1,
    c#fa_file_processor = c#fa_file_previously_opened + 1,
    c#fa_fill = c#fa_file_processor + 1,
    c#fa_forced_write = c#fa_fill + 1,
    c#fa_full_path = c#fa_forced_write + 1,
    c#fa_hashing_procedure_name = c#fa_full_path + 1,
    c#fa_index_levels = c#fa_hashing_procedure_name + 1,
    c#fa_index_padding = c#fa_index_levels + 1,
    c#fa_initial_home_block_count = c#fa_index_padding + 1,
    c#fa_internal_code = c#fa_initial_home_block_count + 1,
    c#fa_job_file_address = c#fa_internal_code + 1,
    c#fa_job_file_position = c#fa_job_file_address + 1,
    c#fa_job_instances_of_open = c#fa_job_file_position + 1,
    c#fa_job_write_concurrency = c#fa_job_instances_of_open + 1,
    c#fa_key_length = c#fa_job_write_concurrency + 1,
    c#fa_key_position = c#fa_key_length + 1,
    c#fa_key_type = c#fa_key_position + 1,
    c#fa_last_access_date_time = c#fa_key_type + 1,
    c#fa_last_data_mod_time = c#fa_last_access_date_time + 1,
    c#fa_last_mod_date_time = c#fa_last_data_mod_time + 1,
    c#fa_lifetime = c#fa_last_mod_date_time + 1,
    c#fa_lifetime_attachment_count = c#fa_lifetime + 1,
    c#fa_line_number = c#fa_lifetime_attachment_count + 1,
    c#fa_loading_factor = c#fa_line_number + 1,
    c#fa_lock_expiration_time = c#fa_loading_factor + 1,
    c#fa_log_residence = c#fa_lock_expiration_time + 1,
    c#fa_logging_options = c#fa_log_residence + 1,
    c#fa_mainframe_attachment = c#fa_logging_options + 1,
    c#fa_mf_write_concurrency = c#fa_mainframe_attachment + 1,
    c#fa_ms_allocation_size = c#fa_mf_write_concurrency + 1,
    c#fa_ms_bytes_allocated = c#fa_ms_allocation_size + 1,
    c#fa_ms_class = c#fa_ms_bytes_allocated + 1,
    c#fa_ms_free_behind = c#fa_ms_class + 1,
    c#fa_ms_initial_volume = c#fa_ms_free_behind + 1,
    c#fa_ms_sequential_access = c#fa_ms_initial_volume + 1,
    c#fa_ms_transfer_size = c#fa_ms_sequential_access + 1,
    c#fa_maximum_block_length = c#fa_ms_transfer_size + 1,
    c#fa_maximum_record_length = c#fa_maximum_block_length + 1,
    c#fa_message_control = c#fa_maximum_record_length + 1,
    c#fa_minimum_block_length = c#fa_message_control + 1,
    c#fa_minimum_record_length = c#fa_minimum_block_length + 1,
    c#fa_object_type = c#fa_minimum_record_length + 1,
    c#fa_open_position = c#fa_object_type + 1,
    c#fa_padding_character = c#fa_open_position + 1,
    c#fa_page_format = c#fa_padding_character + 1,
    c#fa_page_length = c#fa_page_format + 1,
    c#fa_page_width = c#fa_page_length + 1,
    c#fa_password = c#fa_page_width + 1,
    c#fa_path = c#fa_password + 1,
    c#fa_permitted_access = c#fa_path + 1,
    c#fa_potential_job_access = c#fa_permitted_access + 1,
    c#fa_preset_value = c#fa_potential_job_access + 1,
    c#fa_private_read = c#fa_preset_value + 1,
    c#fa_recorded_vsn_list = c#fa_private_read + 1,
    c#fa_records_per_block = c#fa_recorded_vsn_list + 1,
    c#fa_record_delimiting_char = c#fa_records_per_block + 1,
    c#fa_record_limit = c#fa_record_delimiting_char + 1,
    c#fa_record_type = c#fa_record_limit + 1,
    c#fa_registered = c#fa_record_type + 1,
    c#fa_retrieve_option = c#fa_registered + 1,
    c#fa_ring_attributes = c#fa_retrieve_option + 1,
    c#fa_secondary_residence = c#fa_ring_attributes + 1,
    c#fa_set_name = c#fa_secondary_residence + 1,
    c#fa_shared_queue = c#fa_set_name + 1,
    c#fa_site_archive_option = c#fa_shared_queue + 1,
    c#fa_site_backup_option = c#fa_site_archive_option + 1,
    c#fa_site_release_option = c#fa_site_backup_option + 1,
    c#fa_size = c#fa_site_release_option + 1,
    c#fa_statement_identifier = c#fa_size + 1,
    c#fa_tape_density = c#fa_statement_identifier + 1,
    c#fa_unique_data_name = c#fa_tape_density + 1,
    c#fa_unique_name = c#fa_unique_data_name + 1,
    c#fa_user_information = c#fa_unique_name + 1,
    c#fa_vertical_print_density = c#fa_user_information + 1,
    c#fa_volume_overflow_allowed = c#fa_vertical_print_density + 1,

    c#attribute_key_max = c#fa_volume_overflow_allowed;

  TYPE
    t#site_attr_ordinal_indexes = (c#saoi_archive_option, c#saoi_backup_option,
          c#saio_release_option),
    t#file_attribute_key = 1 .. c#attribute_key_max,
    t#file_attribute_keys = set of t#file_attribute_key,
    t#object_type_counts = record
      catalog_type: 0 .. c#attribute_key_max,
      file_type: 0 .. c#attribute_key_max,
      cycle_type: 0 .. c#attribute_key_max,
    recend,
    t#object_types = (c#ot_cat, c#ot_cyc, c#ot_fil);

  CONST
    c#attribute_width_max = 512; {fst$path

  TYPE
    t#object_sort_order = (c#oso_name, c#oso_catalogs_then_files,
          c#oso_files_then_catalogs),
    t#file_sort_order = (c#fso_none, c#fso_modification_date, c#fso_size),
    t#attribute_width = 0 .. c#attribute_width_max,
    t#attribute_infos = array [1 .. * ] of t#attribute_info,
    t#attribute_info = record
      attr: t#file_attribute_key,
      width: t#attribute_width,
    recend,
    t#label_attributes = 0 .. amc$max_attribute,
    t#file_attribute_keys_set = set of fmt$file_attribute_keys;

  CONST
    c#max_integer_as_string = 31, {Number of chars to hold largest integer
    c#max_string_size = 1024;

  TYPE
    t#string_size = 0 .. c#max_string_size,
    t#string = record
      value: string (c#max_string_size),
      size: t#string_size,
    recend;

  TYPE
    t#file_kind = (c#fk_disk_file, c#fk_tape_volume, c#fk_archived_disk_file);

  VAR
    v#asterisks: [READ, s#sec1] string (131) := '*****' CAT
          '***************************************************************' CAT
          '***************************************************************',
    v#blanks: [READ, s#sec1] string (131) := '     ' CAT
          '                                                               ' CAT
          '                                                               ';

?? NEWTITLE := 'Global [XDCL] Defined By This Module', EJECT ??

  VAR
    initial_information_request: [READ, s#sec1] fst$goi_information_request :=
          [[fsc$specific_depth, 1], $fst$goi_object_info_requests [{}
{             } fsc$goi_catalog_object_list,
{             } fsc$goi_file_object_list,
{             } fsc$goi_cycle_object_list,
{             } fsc$goi_cycle_info,
{             } fsc$goi_cycle_device_info {so can test if resides online}
          ]];

  VAR
    null_unique_name: [READ, s#sec1] ost$binary_unique_name :=
          [0, 0, 1980, 1, 1, 0, 0, 0, 0, 0];

  VAR
    file_label_attributes: [READ, s#sec1] t#file_attribute_keys :=
          [c#fa_average_record_length, c#fa_block_type, c#fa_character_conversion,
          c#fa_collate_table_name, c#fa_compression_procedure_name, c#fa_data_padding,
          c#fa_dynamic_home_block_space, c#fa_embedded_key, c#fa_estimated_record_count,
          c#fa_file_access_procedure_name, c#fa_file_contents, c#fa_file_label_type,
          c#fa_file_limit, c#fa_file_organization, c#fa_file_previously_opened,
          c#fa_file_processor, c#fa_forced_write, c#fa_hashing_procedure_name,
          c#fa_index_levels, c#fa_index_padding, c#fa_initial_home_block_count,
          c#fa_internal_code, c#fa_key_length, c#fa_key_position, c#fa_key_type,
          c#fa_line_number, c#fa_loading_factor, c#fa_lock_expiration_time,
          c#fa_log_residence, c#fa_logging_options, c#fa_maximum_block_length,
          c#fa_maximum_record_length, c#fa_minimum_block_length,
          c#fa_minimum_record_length, c#fa_padding_character, c#fa_page_format,
          c#fa_page_length, c#fa_page_width, c#fa_preset_value,
          c#fa_record_delimiting_char, c#fa_record_limit, c#fa_record_type,
          c#fa_records_per_block, c#fa_ring_attributes, c#fa_statement_identifier,
          c#fa_user_information, c#fa_vertical_print_density];

  CONST
    c#dw_0 = 0, {Not supported
    c#dw_amd = 72, {yy.mm.dd name name
    c#dw_avn = 5, {'65536'
    c#dw_bln = 1, {'Y'
    c#dw_bt = 16, {'SYSTEM_SPECIFIED'
    c#dw_byt = 13, {'4398046511103' (2**42 - 1)
    c#dw_cn = 3, {'999'
    c#dw_dc = 15, {'INTERSTATE_LINK'
    c#dw_dp = 2, {'99'
    c#dw_dtm = 8 + 1 + 8, {'yy.mm.dd hh:mm:ss'
    c#dw_el = 5, {'65536'
    c#dw_flt = 20, {'NON_STANDARD_LABELED'
    c#dw_fo = 18, {'INDEXED_SEQUENTIAL'
    c#dw_ic = 13, {'FTAM2 GENERAL'
    c#dw_il = 2, {'15'
    c#dw_ip = 2, {'99'
    c#dw_jfp = 16, {'$END_OF_KEY_LIST'
    c#dw_kl = 3, {'255'
    c#dw_kp = 5, {'65496'
    c#dw_kt = 10, {'UNCOLLATED'
    c#dw_let = 9, {'604800000'
    c#dw_lf = 3, {'100'
    c#dw_ln = 1 + 5 + 1 + 1 + 1, {'(65535 6)'
    c#dw_msas = 8, {'16777215'
    c#dw_msc = 1,
    c#dw_msiv = 6,
    c#dw_mwc = 22, {'NOT_ATTACHED_FOR_WRITE'
    c#dw_ot = 7, {'CATALOG'
    c#dw_pc = 1,
    c#dw_pf = 13, {'NON_BURSTABLE'
    c#dw_pw = 5, {'65535'
    c#dw_ra = 1 + 2 + 1 + 2 + 1 + 2 + 1, {'(nn nn nn)'
    c#dw_rdc = 1,
    c#dw_rpb = 5, {'65535'
    c#dw_rt = 28, {'TRAILING_CHARACTER_DELIMITED'
    c#dw_seg = 10, {'2147483647'
    c#dw_si = 1 + 5 + 1 + 2 + 1, { '(65535 17)'
    c#dw_sa_ord = 4, {Site attribute ordinal (0..255),NULL
    c#dw_sq = 7, {'SITE_nn'
    c#dw_std = 31,
    c#dw_td = 10, {'MT18$38000'
    c#dw_vpd = 2, {'12'
    c#max_file_processor = 18,
    c#comp_proc_name = fmc$compression_procedure_name,
    c#dyna_home_block_space = fmc$dynamic_home_block_space,
    c#init_home_block_count = fmc$initial_home_block_count,
    c#rec_delim_char = fmc$record_delimiting_character;

?? FMT (FORMAT := OFF) ?? {Use ?? RIGHT := 110 ?? if need to reformat...

  VAR {Array order same as C#FA_ constants order.
    v#attrs_info: [READ, s#sec1] array [1 .. c#attribute_key_max] of record
      name: ost$name,
      applicable_object_types: set of t#object_types,
      file_label_attr: t#label_attributes,
      default_width: ost$halfword,
    recend := [
 {} ['ACCESS_CONTROL_LIST            ', [c#ot_cat, c#ot_fil], 0, c#dw_0],
 {} ['ACCOUNT_PROJECT                ', [c#ot_cat, c#ot_fil], 0, c#dw_std],
 {} ['ACTUAL_JOB_ACCESS              ', [c#ot_cyc], 0, c#dw_std],
 {} ['ARCHIVE_MEDIA_DESCRIPTOR       ', [c#ot_cyc], 0, c#dw_amd],
 {} ['ATTACHED                       ', [c#ot_cyc], 0, c#dw_bln],
 {} ['ATTACHED_EXTERNAL_VSN_LIST     ', [c#ot_cyc], 0, c#dw_std],
 {} ['ATTACHED_RECORDED_VSN_LIST     ', [c#ot_cyc], 0, c#dw_std],
 {} ['ATTACHED_TRANSFER_SIZE         ', [c#ot_cyc], 0, c#dw_seg],
 {} ['ATTACHED_VOL_OVERFLOW_ALLOWED  ', [c#ot_cyc], 0, c#dw_bln],
 {} ['ATTACHED_VOLUME_NUMBER         ', [c#ot_cyc], 0, c#dw_avn],
 {} ['ATTACHMENT_LOG                 ', [c#ot_fil], 0, c#dw_0],
 {} ['ATTACHMENT_LOGGING_SELECTED    ', [c#ot_fil], 0, c#dw_bln],
 {} ['AVERAGE_RECORD_LENGTH          ', [c#ot_cyc], fmc$average_record_length, c#dw_byt],
 {} ['BLOCK_TYPE                     ', [c#ot_cyc], fmc$block_type, c#dw_bt],
 {} ['CHARACTER_CONVERSION           ', [c#ot_cyc], fmc$character_conversion, c#dw_bln],
 {} ['COLLATE_TABLE_NAME             ', [c#ot_cyc], fmc$collate_table_name, c#dw_std],
 {} ['COMPRESSION_PROCEDURE_NAME     ', [c#ot_cyc], c#comp_proc_name, c#dw_std],
 {} ['CONNECTED_FILES                ', [c#ot_cyc], 0, c#dw_0],
 {} ['CREATION_DATE_TIME             ', [c#ot_cat, c#ot_cyc], 0, c#dw_dtm],
 {} ['CYCLE_NUMBER                   ', [c#ot_cyc], 0, c#dw_cn],
 {} ['DATA_PADDING                   ', [c#ot_cyc], fmc$data_padding, c#dw_dp],
 {} ['DEVICE_CLASS                   ', [c#ot_cat, c#ot_cyc], 0, c#dw_dc],
 {} ['DYNAMIC_HOME_BLOCK_SPACE       ', [c#ot_cyc], c#dyna_home_block_space, c#dw_bln],
 {} ['EMBEDDED_KEY                   ', [c#ot_cyc], fmc$embedded_key, c#dw_bln],
 {} ['ERROR_EXIT_PROCEDURE_NAME      ', [c#ot_cyc], 0, c#dw_std],
 {} ['ERROR_LIMIT                    ', [c#ot_cyc], 0, c#dw_el],
 {} ['ESTIMATED_RECORD_COUNT         ', [c#ot_cyc], fmc$estimated_record_count, c#dw_byt],
 {} ['EXCEPTION_CONDITIONS           ', [c#ot_cat, c#ot_cyc], 0, c#dw_0],
 {} ['EXPIRATION_DATE                ', [c#ot_cyc], 0, c#dw_dtm],
 {} ['EXTERNAL_VSN_LIST              ', [c#ot_cyc], 0, c#dw_std],
 {} ['FILE_ACCESS_PROCEDURE_NAME     ', [c#ot_cyc], fmc$file_access_procedure, c#dw_std],
 {} ['FILE_CONTENTS                  ', [c#ot_cyc], fmc$file_contents, c#dw_std],
 {} ['FILE_LABEL_TYPE                ', [c#ot_cyc], fmc$label_type, c#dw_flt],
 {} ['FILE_LIMIT                     ', [c#ot_cyc], fmc$file_limit, c#dw_byt],
 {} ['FILE_NAME                      ', [c#ot_cyc], 0, c#dw_std],
 {} ['FILE_ORGANIZATION              ', [c#ot_cyc], fmc$file_organization, c#dw_fo],
 {} ['FILE_PREVIOUSLY_OPENED         ', [c#ot_cyc], 0, c#dw_bln],
 {} ['FILE_PROCESSOR                 ', [c#ot_cyc], fmc$file_processor, c#dw_std],
 {} ['FILL                           ', [], 0, c#dw_0],
 {} ['FORCED_WRITE                   ', [c#ot_cyc], fmc$forced_write, c#dw_bln],
 {} ['FULL_PATH                      ', [c#ot_cyc], 0, c#dw_std],
 {} ['HASHING_PROCEDURE_NAME         ', [c#ot_cyc], fmc$hashing_procedure_name, c#dw_std],
 {} ['INDEX_LEVELS                   ', [c#ot_cyc], fmc$index_levels, c#dw_il],
 {} ['INDEX_PADDING                  ', [c#ot_cyc], fmc$index_padding, c#dw_ip],
 {} ['INITIAL_HOME_BLOCK_COUNT       ', [c#ot_cyc], c#init_home_block_count, c#dw_byt],
 {} ['INTERNAL_CODE                  ', [c#ot_cyc], fmc$internal_code, c#dw_ic],
 {} ['JOB_FILE_ADDRESS               ', [c#ot_cyc], 0, c#dw_std],
 {} ['JOB_FILE_POSITION              ', [c#ot_cyc], 0, c#dw_jfp],
 {} ['JOB_INSTANCES_OF_OPEN          ', [c#ot_cyc], 0, c#dw_byt],
 {} ['JOB_WRITE_CONCURRENCY          ', [c#ot_cyc], 0, c#dw_bln],
 {} ['KEY_LENGTH                     ', [c#ot_cyc], fmc$key_length, c#dw_kl],
 {} ['KEY_POSITION                   ', [c#ot_cyc], fmc$key_position, c#dw_kp],
 {} ['KEY_TYPE                       ', [c#ot_cyc], fmc$key_type, c#dw_kt],
 {} ['LAST_ACCESS_DATE_TIME          ', [c#ot_cyc], 0, c#dw_dtm],
 {} ['LAST_DATA_MODIFICATION_TIME    ', [c#ot_cyc], 0, c#dw_dtm],
 {} ['LAST_MODIFICATION_DATE_TIME    ', [c#ot_cyc], 0, c#dw_dtm],
 {} ['LIFETIME                       ', [c#ot_cat, c#ot_fil, c#ot_cyc], 0, c#dw_0],
 {} ['LIFETIME_ATTACHMENT_COUNT      ', [c#ot_cyc], 0, c#dw_byt],
 {} ['LINE_NUMBER                    ', [c#ot_cyc], fmc$line_number, c#dw_ln],
 {} ['LOADING_FACTOR                 ', [c#ot_cyc], fmc$loading_factor, c#dw_lf],
 {} ['LOCK_EXPIRATION_TIME           ', [c#ot_cyc], fmc$lock_expiration_time, c#dw_let],
 {} ['LOG_RESIDENCE                  ', [c#ot_cyc], fmc$log_residence, c#dw_0],
 {} ['LOGGING_OPTIONS                ', [c#ot_cyc], fmc$logging_options, c#dw_std],
 {} ['MAINFRAME_ATTACHMENT           ', [c#ot_cyc], 0, c#dw_std],
 {} ['MAINFRAME_WRITE_CONCURRENCY    ', [c#ot_cyc], 0, c#dw_mwc],
 {} ['MASS_STORAGE_ALLOCATION_SIZE   ', [c#ot_cat, c#ot_cyc], 0, c#dw_msas],
 {} ['MASS_STORAGE_BYTES_ALLOCATED   ', [c#ot_cat, c#ot_cyc], 0, c#dw_byt],
 {} ['MASS_STORAGE_CLASS             ', [c#ot_cat, c#ot_cyc], 0, c#dw_msc],
 {} ['MASS_STORAGE_FREE_BEHIND       ', [c#ot_cyc], 0, c#dw_bln],
 {} ['MASS_STORAGE_INITIAL_VOLUME    ', [c#ot_cyc], 0, c#dw_msiv],
 {} ['MASS_STORAGE_SEQUENTIAL_ACCESS ', [c#ot_cyc], 0, c#dw_bln],
 {} ['MASS_STORAGE_TRANSFER_SIZE     ', [c#ot_cyc], 0, c#dw_seg],
 {} ['MAXIMUM_BLOCK_LENGTH           ', [c#ot_cyc], fmc$max_block_length, c#dw_seg],
 {} ['MAXIMUM_RECORD_LENGTH          ', [c#ot_cyc], fmc$max_record_length, c#dw_byt],
 {} ['MESSAGE_CONTROL                ', [c#ot_cyc], 0, c#dw_std],
 {} ['MINIMUM_BLOCK_LENGTH           ', [c#ot_cyc], fmc$min_block_length, c#dw_seg],
 {} ['MINIMUM_RECORD_LENGTH          ', [c#ot_cyc], fmc$min_record_length, c#dw_byt],
 {} ['OBJECT_TYPE                    ', [c#ot_cat, c#ot_fil, c#ot_cyc], 0, c#dw_ot],
 {} ['OPEN_POSITION                  ', [c#ot_cyc], 0, c#dw_0],
 {} ['PADDING_CHARACTER              ', [c#ot_cyc], fmc$padding_character, c#dw_pc],
 {} ['PAGE_FORMAT                    ', [c#ot_cyc], fmc$page_format, c#dw_pf],
 {} ['PAGE_LENGTH                    ', [c#ot_cyc], fmc$page_length, c#dw_byt],
 {} ['PAGE_WIDTH                     ', [c#ot_cyc], fmc$page_width, c#dw_pw],
 {} ['PASSWORD                       ', [c#ot_fil], 0, c#dw_std],
 {} ['PATH                           ', [c#ot_cat, c#ot_fil, c#ot_cyc], 0, c#dw_std],
 {} ['PERMITTED_ACCESS               ', [c#ot_cat, c#ot_fil], 0, c#dw_0],
 {} ['POTENTIAL_JOB_ACCESS           ', [c#ot_cyc], 0, c#dw_0],
 {} ['PRESET_VALUE                   ', [c#ot_cyc], fmc$preset_value, c#dw_byt],
 {} ['PRIVATE_READ                   ', [c#ot_cyc], 0, c#dw_bln],
 {} ['RECORDED_VSN_LIST              ', [c#ot_cat, c#ot_cyc], 0, c#dw_0],
 {} ['RECORDS_PER_BLOCK              ', [c#ot_cyc], fmc$records_per_block, c#dw_rpb],
 {} ['RECORD_DELIMITING_CHARACTER    ', [c#ot_cyc], c#rec_delim_char, c#dw_rdc],
 {} ['RECORD_LIMIT                   ', [c#ot_cyc], fmc$record_limit, c#dw_byt],
 {} ['RECORD_TYPE                    ', [c#ot_cyc], fmc$record_type, c#dw_rt],
 {} ['REGISTERED                     ', [c#ot_cat, c#ot_fil, c#ot_cyc], 0, c#dw_bln],
 {} ['RETRIEVE_OPTION                ', [c#ot_cyc], 0, c#dw_std],
 {} ['RING_ATTRIBUTES                ', [c#ot_cyc], fmc$ring_attributes, c#dw_ra],
 {} ['SECONDARY_RESIDENCE            ', [c#ot_cyc], 0, c#dw_std],
 {} ['SET_NAME                       ', [c#ot_cat, c#ot_fil, c#ot_cyc], 0, c#dw_std],
 {} ['SHARED_QUEUE                   ', [c#ot_cyc], 0, c#dw_sq],
 {} ['SITE_ARCHIVE_OPTION            ', [c#ot_cyc], 0, c#dw_sa_ord],
 {} ['SITE_BACKUP_OPTION             ', [c#ot_cyc], 0, c#dw_sa_ord],
 {} ['SITE_RELEASE_OPTION            ', [c#ot_cyc], 0, c#dw_sa_ord],
 {} ['SIZE                           ', [c#ot_cat, c#ot_cyc], 0, c#dw_byt],
 {} ['STATEMENT_IDENTIFIER           ', [c#ot_cyc], fmc$statement_identifier, c#dw_si],
 {} ['TAPE_DENSITY                   ', [c#ot_cyc], 0, c#dw_td],
 {} ['UNIQUE_DATA_NAME               ', [c#ot_cat, c#ot_cyc], 0, c#dw_std],
 {} ['UNIQUE_NAME                    ', [c#ot_cat, c#ot_fil, c#ot_cyc], 0, c#dw_std],
 {} ['USER_INFORMATION               ', [c#ot_cyc], fmc$user_info, c#dw_std],
 {} ['VERTICAL_PRINT_DENSITY         ', [c#ot_cyc], fmc$vertical_print_density, c#dw_vpd],
 {} ['VOLUME_OVERFLOW_ALLOWED        ', [c#ot_cat, c#ot_cyc], 0, c#dw_bln]];

?? FMT (FORMAT := ON) ??

?? NEWTITLE := '[xdcl] USP#REPORT_FILES', EJECT ??

  PROCEDURE [XDCL] usp#report_files
    (    parameter_list: clt$parameter_list;
     VAR status: ost$status);

?? NEWTITLE := 'P#ADDL_ACCT_PROJ', EJECT ??

    PROCEDURE [INLINE] p#addl_acct_proj
      (    account: avt$account_name;
           project: avt$project_name;
       VAR line: t#string);

      p#addl_string ('(', line);
      p#addl_trim_str (account, line);
      line.size := line.size + 1;
      p#addl_trim_str (project, line);
      p#addl_string (')', line);

    PROCEND p#addl_acct_proj;
?? TITLE := 'P#ADDL_BOOLEAN', EJECT ??

    PROCEDURE [INLINE] p#addl_boolean
      (    boolean_value: boolean;
       VAR line: t#string);

      IF boolean_value THEN
        p#addl_string ('Y', line);
      ELSE
        p#addl_string ('N', line);
      IFEND;

    PROCEND p#addl_boolean;
?? TITLE := 'P#ADDL_DATE_TIME', EJECT ??

    PROCEDURE [INLINE] p#addl_date_time
      (    date_time: ost$date_time;
       VAR line: t#string;
       VAR status: ost$status);

      VAR
        time_string: ost$time,
        date_string: ost$date;

      pmp$format_compact_date (date_time, osc$dmy_date, date_string, status);
      IF status.normal THEN
        p#addl_string (date_string.dmy (1, 8), line);
        pmp$format_compact_time (date_time, osc$hms_time, time_string, status);
      IFEND;
      IF status.normal THEN
        line.size := line.size + 1;
        p#addl_string (time_string.hms (1, 8), line);
      IFEND;
      status.normal := TRUE;

    PROCEND p#addl_date_time;
?? TITLE := 'P#ADDL_ENTRY_POINT', EJECT ??

    PROCEDURE [INLINE] p#addl_entry_point
      (    entry_point: string ( * <= 255);
       VAR line: t#string);

      IF entry_point = osc$null_name THEN
        p#addl_string ('NONE', line);
      ELSE
        p#addl_trim_str (entry_point, line);
      IFEND;

    PROCEND p#addl_entry_point;
?? TITLE := 'P#ADDL_INTEGER', EJECT ??

    PROCEDURE [INLINE] p#addl_integer
      (    integer_value: integer;
       VAR line: t#string;
       VAR status: ost$status);

      status.normal := TRUE;
      clp$convert_integer_to_string (integer_value, 10, FALSE, status.text, status);
      IF status.normal THEN
        p#addl_string (status.text.value (1, status.text.size), line);
      IFEND;

    PROCEND p#addl_integer;
?? TITLE := 'P#ADDL_INTEGER_PAIR', EJECT ??

    PROCEDURE [INLINE] p#addl_integer_pair
      (    int1: integer;
           int2: integer;
       VAR line: t#string;
       VAR status: ost$status);

      p#addl_string ('(', line);
      p#addl_integer (int1, line, status);
      line.size := line.size + 1;
      p#addl_integer (int2, line, status);
      p#addl_string (')', line);

    PROCEND p#addl_integer_pair;
?? TITLE := 'P#ADDL_LIST_START', EJECT ??

    PROCEDURE [INLINE] p#addl_list_start
      (VAR old_line_size: ost$halfword;
       VAR line: t#string);

      old_line_size := line.size;
      p#addl_string ('(', line);

    PROCEND p#addl_list_start;
?? TITLE := 'P#ADDL_LIST_STOP', EJECT ??

    PROCEDURE [INLINE] p#addl_list_stop
      (    old_line_size: ost$halfword;
       VAR line: t#string);

      line.size := line.size - 1;
      IF line.size <> old_line_size THEN
        p#addl_string (')', line);
      IFEND;

    PROCEND p#addl_list_stop;
?? TITLE := 'P#ADDL_RJINTEGER', EJECT ??

    PROCEDURE p#addl_rjinteger
      (    integer_value: integer;
           integer_size: 1 .. osc$max_string_size;
       VAR line: t#string;
       VAR status: ost$status);

      clp$convert_integer_to_rjstring (integer_value, 10, FALSE, ' ', status.text.
            value (1, integer_size), status);
      IF status.normal THEN
        p#addl_string (status.text.value (1, integer_size), line);
      ELSE
        p#addl_string (v#asterisks (1, integer_size), line);
      IFEND;

    PROCEND p#addl_rjinteger;
?? TITLE := 'P#ADDL_STRING', EJECT ??

    PROCEDURE [INLINE] p#addl_string
      (    str: string ( * );
       VAR line: t#string);

      VAR
        length: integer;

      length := STRLENGTH (str);
      IF line.size + length <= c#max_string_size THEN
        line.value (line.size + 1, length) := str;
        line.size := line.size + length;
      IFEND;

    PROCEND p#addl_string;
?? TITLE := 'P#ADDL_TRIM_STR', EJECT ??

    PROCEDURE [INLINE] p#addl_trim_str
      (    str: string ( * <= 512);
       VAR line: t#string);

      VAR
        blank: string (1),
        last: t#string_size;

      last := STRLENGTH (str);
      blank := ' ';

      IF str (1) <> blank THEN
        WHILE (str (last) = blank) DO
          last := last - 1;
        WHILEND;
      ELSE
        WHILE (last > 0) AND (str (last) = blank) DO
          last := last - 1;
        WHILEND;
      IFEND;

      p#addl_string (str (1, last), line);

    PROCEND p#addl_trim_str;
?? TITLE := 'DETERMINE_OBJECT_INFO_REQUESTS', EJECT ??

    PROCEDURE determine_object_info_requests
      (    attrs_req: t#file_attribute_keys;
       VAR info_req: {input, output} fst$goi_object_info_requests);

      VAR
        catalog_and_cycle_identity: [READ, s#sec1] t#file_attribute_keys :=
              [c#fa_device_class, c#fa_lifetime, c#fa_object_type, c#fa_path,
              c#fa_registered, c#fa_set_name, c#fa_unique_data_name, c#fa_unique_name],
        catalog_device_attributes: [READ, s#sec1] t#file_attribute_keys :=
              [c#fa_exception_conditions, c#fa_ms_allocation_size,
              c#fa_ms_bytes_allocated, c#fa_ms_class, c#fa_recorded_vsn_list],
        cycle_info: [READ, s#sec1] t#file_attribute_keys :=
              [c#fa_creation_date_time, c#fa_exception_conditions, c#fa_expiration_date,
              c#fa_last_access_date_time, c#fa_last_data_mod_time,
              c#fa_last_mod_date_time, c#fa_lifetime_attachment_count,
              c#fa_mainframe_attachment, c#fa_mf_write_concurrency,
              c#fa_potential_job_access, c#fa_retrieve_option, c#fa_site_archive_option,
              c#fa_site_backup_option, c#fa_site_release_option],
        device_info: [READ, s#sec1] t#file_attribute_keys :=
              [c#fa_exception_conditions, c#fa_external_vsn_list, c#fa_file_label_type,
              c#fa_ms_allocation_size, c#fa_ms_bytes_allocated, c#fa_ms_class,
              c#fa_ms_initial_volume, c#fa_ms_transfer_size, c#fa_maximum_block_length,
              c#fa_recorded_vsn_list, c#fa_shared_queue, c#fa_tape_density,
              c#fa_volume_overflow_allowed],
        file_info: [READ, s#sec1] t#file_attribute_keys :=
              [c#fa_attachment_log, c#fa_attachment_logging_sel],
        job_environment_info: [READ, s#sec1] t#file_attribute_keys :=
              [c#fa_actual_job_access, c#fa_attached, c#fa_attached_external_vsn_list,
              c#fa_attached_recorded_vsn_list, c#fa_attached_transfer_size,
              c#fa_attached_vol_oflo_allowed, c#fa_attached_volume_number,
              c#fa_connected_files, c#fa_error_exit_procedure_name, c#fa_error_limit,
              c#fa_job_file_address, c#fa_job_file_position, c#fa_job_instances_of_open,
              c#fa_job_write_concurrency, c#fa_ms_free_behind, c#fa_ms_sequential_access,
              c#fa_message_control, c#fa_open_position, c#fa_potential_job_access,
              c#fa_private_read];

      IF (catalog_and_cycle_identity * attrs_req) <> $t#file_attribute_keys [] THEN
        info_req := info_req + $fst$goi_object_info_requests
              [fsc$goi_catalog_identity, fsc$goi_cycle_identity];
      IFEND;
      IF (cycle_info * attrs_req) <> $t#file_attribute_keys [] THEN
        info_req := info_req + $fst$goi_object_info_requests [fsc$goi_cycle_info];
      IFEND;
      IF (device_info * attrs_req) <> $t#file_attribute_keys [] THEN
        info_req := info_req + $fst$goi_object_info_requests [fsc$goi_cycle_device_info];
        IF (catalog_device_attributes * attrs_req) <> $t#file_attribute_keys [] THEN
          info_req := info_req + $fst$goi_object_info_requests
                [fsc$goi_catalog_device_info];
        IFEND;
      IFEND;
      IF (file_label_attributes * attrs_req) <> $t#file_attribute_keys [] THEN
        info_req := info_req + $fst$goi_object_info_requests [fsc$goi_file_label];
      IFEND;
      IF (job_environment_info * attrs_req) <> $t#file_attribute_keys [] THEN
        info_req := info_req + $fst$goi_object_info_requests
              [fsc$goi_job_environment_info];
        IF c#fa_potential_job_access IN attrs_req THEN
          info_req := info_req + $fst$goi_object_info_requests
                [fsc$goi_applicable_file_permit, fsc$goi_file_label];
        IFEND;
      IFEND;

      IF c#fa_access_control_list IN attrs_req THEN
        info_req := info_req + $fst$goi_object_info_requests
              [fsc$goi_catalog_permits, fsc$goi_file_permits];
      IFEND;
      IF c#fa_account_project IN attrs_req THEN
        info_req := info_req + $fst$goi_object_info_requests
              [fsc$goi_catalog_info, fsc$goi_file_info];
      IFEND;
      IF c#fa_attachment_log IN attrs_req THEN
        info_req := info_req + $fst$goi_object_info_requests [fsc$goi_file_log];
      IFEND;
      IF c#fa_attachment_logging_sel IN attrs_req THEN
        info_req := info_req + $fst$goi_object_info_requests [fsc$goi_file_info];
      IFEND;
      IF c#fa_creation_date_time IN attrs_req THEN
        info_req := info_req + $fst$goi_object_info_requests
              [fsc$goi_catalog_info, fsc$goi_cycle_info];
      IFEND;
      IF c#fa_cycle_number IN attrs_req THEN
        info_req := info_req + $fst$goi_object_info_requests [fsc$goi_cycle_identity];
      IFEND;
      IF c#fa_permitted_access IN attrs_req THEN
        info_req := info_req + $fst$goi_object_info_requests
              [fsc$goi_applicable_cat_permit, fsc$goi_applicable_file_permit];
      IFEND;
      IF ((c#fa_secondary_residence IN attrs_req) OR
            (c#fa_archive_media_descriptor IN attrs_req)) THEN
        info_req := info_req + $fst$goi_object_info_requests [fsc$goi_archive_info];
      IFEND;
      IF c#fa_set_name IN attrs_req THEN
        info_req := info_req + $fst$goi_object_info_requests [fsc$goi_set_name];
      IFEND;
      IF c#fa_size IN attrs_req THEN
        info_req := info_req + $fst$goi_object_info_requests
              [fsc$goi_catalog_size, fsc$goi_cycle_size];
      IFEND;

    PROCEND determine_object_info_requests;
?? TITLE := 'DETERMINE_REQUESTED_ATTRIBUTES', EJECT ??

    PROCEDURE determine_requested_attributes
      (    data_value_p: ^clt$data_value;
       VAR attrs_info_p: ^t#attribute_infos;
       VAR attrs_req: t#file_attribute_keys;
       VAR attrs_req_n: t#object_type_counts;
       VAR file_label_attrs: t#file_attribute_keys_set;
       VAR status: ost$status);

      VAR
        attr_name: ost$name,
        attr_i: ost$halfword,
        attrs_info_i: ost$halfword,
        highest_attr_i: ost$halfword,
        seq_p: ^SEQ ( * ),
        table_i: ost$halfword,
        width_value_p: ^clt$data_value,
        value_p: ^clt$data_value;

?? NEWTITLE := 'GET_ATTRIBUTE_INDEX', EJECT ??

      PROCEDURE [INLINE] get_attribute_index
        (    attr_name: ost$name;
         VAR attr_i: ost$halfword);

{Returns ATTRS_INFO[ATTR_I].NAME = ATTR_NAME (or 0 if no match).

        VAR
          first: ost$halfword,
          last: ost$halfword,
          medium: ost$halfword;

        first := 1;
        last := UPPERBOUND (v#attrs_info);
        WHILE (first <> last) DO
          medium := first + last; {So CYBIL generates a SHIFT vs. DIV!
          medium := medium DIV 2;
          IF v#attrs_info [medium].name >= attr_name THEN
            last := medium;
          ELSE
            first := medium + 1;
          IFEND;
        WHILEND;

        IF v#attrs_info [first].name = attr_name THEN
          attr_i := first;
        ELSE
          attr_i := 0;
        IFEND;

      PROCEND get_attribute_index;
?? OLDTITLE ??
?? EJECT ?? {determine_requested_attributes

      attrs_info_i := 0;
      attrs_req_n.catalog_type := 0;
      attrs_req_n.file_type := 0;
      attrs_req_n.cycle_type := 0;
      attrs_req := $t#file_attribute_keys [];
      file_label_attrs := $t#file_attribute_keys_set [];
      highest_attr_i := 1;

      value_p := data_value_p;
      WHILE value_p <> NIL DO

        attr_name := value_p^.element_value^.field_values^ [1].value^.keyword_value;

        get_attribute_index (attr_name, attr_i);
        IF attr_i = 0 THEN
          osp$set_status_condition (e#unknown_attribute, status);
          RETURN; {----->
        IFEND;

        attrs_req := attrs_req + $t#file_attribute_keys [attr_i];
        attrs_info_i := attrs_info_i + 1;
        attrs_info_p^ [attrs_info_i].attr := attr_i;
        width_value_p := value_p^.element_value^.field_values^ [2].value;
        IF width_value_p = NIL THEN {not specified
          attrs_info_p^ [attrs_info_i].width := v#attrs_info [attr_i].default_width;
        ELSE
          attrs_info_p^ [attrs_info_i].width := width_value_p^.integer_value.value;
        IFEND;

        IF v#attrs_info [attr_i].file_label_attr <> 0 THEN
          file_label_attrs := file_label_attrs + $t#file_attribute_keys_set
                [v#attrs_info [attr_i].file_label_attr];
        IFEND;
        IF attr_i > highest_attr_i THEN
          highest_attr_i := attr_i;
        IFEND;

        value_p := value_p^.link;
      WHILEND;

      seq_p := #SEQ (attrs_info_p^);
      NEXT attrs_info_p: [1 .. attrs_info_i] IN seq_p;
      IF attrs_req <> $t#file_attribute_keys [] THEN
        FOR attr_i := 1 TO highest_attr_i DO
          IF attr_i IN attrs_req THEN
            IF (c#ot_cat IN v#attrs_info [attr_i].applicable_object_types) THEN
              attrs_req_n.catalog_type := attrs_req_n.catalog_type + 1;
            IFEND;
            IF (c#ot_cyc IN v#attrs_info [attr_i].applicable_object_types) THEN
              attrs_req_n.cycle_type := attrs_req_n.cycle_type + 1;
            IFEND;
            IF (c#ot_fil IN v#attrs_info [attr_i].applicable_object_types) THEN
              attrs_req_n.file_type := attrs_req_n.file_type + 1;
            IFEND;
          IFEND;
        FOREND;
      IFEND;

    PROCEND determine_requested_attributes;
?? TITLE := 'PROCESS_CATALOG_ENTRY', EJECT ??

    PROCEDURE process_catalog_entry
      (    obj: fst$goi_object;
           object_info_p: ^fst$goi_object_information;
           attrs_info_p: ^t#attribute_infos;
       VAR line: t#string;
       VAR status: ost$status);

      VAR
        attr_i: ost$halfword,
        char_str: string (1),
        gfn: ost$name,
        line_size_o: ost$halfword,
        old_line_size: ost$halfword,
        vol_i: ost$halfword,
        vol_list_p: ^rmt$volume_list,
        rj_w: t#attribute_width,
        width: t#attribute_width;

      FOR attr_i := 1 TO UPPERBOUND (attrs_info_p^) DO
        line_size_o := line.size;
        width := attrs_info_p^ [attr_i].width;
        rj_w := width;
        CASE attrs_info_p^ [attr_i].attr OF

        = c#fa_access_control_list =

        = c#fa_account_project =
          IF obj.catalog_information <> NIL THEN
            p#addl_acct_proj (obj.catalog_information^.account,
                  obj.catalog_information^.project, line);
          IFEND;

        = c#fa_actual_job_access =
        = c#fa_archive_media_descriptor =
        = c#fa_attached =
        = c#fa_attached_external_vsn_list =
        = c#fa_attached_recorded_vsn_list =
        = c#fa_attached_transfer_size =
        = c#fa_attached_vol_oflo_allowed =
        = c#fa_attached_volume_number =
        = c#fa_attachment_log =
        = c#fa_attachment_logging_sel =
        = c#fa_average_record_length =
        = c#fa_block_type =
        = c#fa_character_conversion =
        = c#fa_collate_table_name =
        = c#fa_compression_procedure_name =
        = c#fa_connected_files =

        = c#fa_creation_date_time =
          IF obj.catalog_information <> NIL THEN
            p#addl_date_time (obj.catalog_information^.creation_date_time, line, status);
          IFEND;

        = c#fa_cycle_number =
        = c#fa_data_padding =

        = c#fa_device_class =
          p#addl_string ('MASS_STORAGE', line);

        = c#fa_dynamic_home_block_space =
        = c#fa_embedded_key =
        = c#fa_error_exit_procedure_name =
        = c#fa_error_limit =
        = c#fa_estimated_record_count =
        = c#fa_exception_conditions =

        = c#fa_expiration_date =
        = c#fa_external_vsn_list =
        = c#fa_file_access_procedure_name =
        = c#fa_file_contents =
        = c#fa_file_label_type =
        = c#fa_file_limit =
        = c#fa_file_name =
        = c#fa_file_organization =
        = c#fa_file_previously_opened =
        = c#fa_file_processor =

        = c#fa_fill =
          p#addl_string (v#blanks (1, width), line);

        = c#fa_forced_write =
        = c#fa_full_path =
        = c#fa_hashing_procedure_name =
        = c#fa_index_levels =
        = c#fa_index_padding =
        = c#fa_initial_home_block_count =
        = c#fa_internal_code =
        = c#fa_job_file_address =
        = c#fa_job_file_position =
        = c#fa_job_instances_of_open =
        = c#fa_job_write_concurrency =
        = c#fa_key_length =
        = c#fa_key_position =
        = c#fa_key_type =
        = c#fa_last_access_date_time =
        = c#fa_last_data_mod_time =
        = c#fa_last_mod_date_time =
        = c#fa_lifetime =

        = c#fa_lifetime_attachment_count =
        = c#fa_line_number =
        = c#fa_loading_factor =
        = c#fa_lock_expiration_time =
        = c#fa_log_residence =
        = c#fa_logging_options =
        = c#fa_mainframe_attachment =
        = c#fa_maximum_block_length =
        = c#fa_maximum_record_length =
        = c#fa_message_control =
        = c#fa_mf_write_concurrency =
        = c#fa_minimum_block_length =
        = c#fa_minimum_record_length =

        = c#fa_ms_allocation_size =
          IF obj.catalog_device_information <> NIL THEN
            p#addl_rjinteger (obj.catalog_device_information^.mass_storage_device_info.
                  allocation_unit_size, rj_w, line, status);
          IFEND;

        = c#fa_ms_bytes_allocated =
          IF obj.catalog_device_information <> NIL THEN
            p#addl_rjinteger (obj.catalog_device_information^.mass_storage_device_info.
                  bytes_allocated, rj_w, line, status);
          IFEND;

        = c#fa_ms_class =
          IF obj.catalog_device_information <> NIL THEN
            char_str := obj.catalog_device_information^.mass_storage_device_info.
                  mass_storage_class;
            p#addl_string (char_str, line);
          ELSE
          IFEND;

        = c#fa_ms_free_behind =
        = c#fa_ms_initial_volume =
        = c#fa_ms_sequential_access =
        = c#fa_ms_transfer_size =

        = c#fa_object_type =
          p#addl_string ('CATALOG', line);

        = c#fa_open_position =
        = c#fa_padding_character =
        = c#fa_page_format =
        = c#fa_page_length =
        = c#fa_page_width =
        = c#fa_password =
        = c#fa_path =

        = c#fa_permitted_access =

        = c#fa_potential_job_access =
        = c#fa_preset_value =
        = c#fa_private_read =
        = c#fa_record_delimiting_char =
        = c#fa_record_limit =
        = c#fa_record_type =

        = c#fa_recorded_vsn_list =
          IF obj.catalog_device_information <> NIL THEN
            p#addl_list_start (old_line_size, line);
            vol_list_p := obj.catalog_device_information^.mass_storage_device_info.
                  volume_list;
            FOR vol_i := 1 TO UPPERBOUND (vol_list_p^) DO
              p#addl_trim_str (vol_list_p^ [vol_i].recorded_vsn, line);
              line.size := line.size + 1;
            FOREND;
            p#addl_list_stop (old_line_size, line);
          IFEND;

        = c#fa_records_per_block =
        = c#fa_registered =
          p#addl_boolean (TRUE, line);

        = c#fa_retrieve_option =
        = c#fa_ring_attributes =
        = c#fa_secondary_residence =

        = c#fa_set_name =
          p#addl_string (object_info_p^.set_name, line);

        = c#fa_shared_queue =
        = c#fa_site_archive_option =
        = c#fa_site_backup_option =
        = c#fa_site_release_option =

        = c#fa_size =
          IF obj.catalog_size <> NIL THEN
            p#addl_rjinteger (obj.catalog_size^, rj_w, line, status);
          ELSE
          IFEND;

        = c#fa_statement_identifier =
        = c#fa_tape_density =

        = c#fa_unique_data_name, c#fa_unique_name =
          pmp$convert_binary_unique_name (obj.catalog_global_file_name, gfn, status);
          p#addl_string (gfn, line);
          status.normal := TRUE;

        = c#fa_user_information =
        = c#fa_vertical_print_density =

        = c#fa_volume_overflow_allowed =
          p#addl_boolean (FALSE, line);

        CASEND;
        line.size := line_size_o + width;
      FOREND;

    PROCEND process_catalog_entry;
?? TITLE := 'PROCESS_CYCLE_ENTRY', EJECT ??

    PROCEDURE process_cycle_entry
      (    obj: fst$goi_object;
           object_info_p: ^fst$goi_object_information;
           file_obj_p: ^fst$goi_object;
           attrs_info_p: ^t#attribute_infos;
           file_label_attrs: t#file_attribute_keys_set;
       VAR file_kind: t#file_kind;
       VAR line: t#string;
       VAR status: ost$status);

      VAR
        max_date_time: [READ, s#sec1] ost$date_time := [255, 12, 31, 23, 59, 59, 999];

      VAR
        attr_i: ost$halfword,
        char_str: string (1),
        combined_file_contents: amt$file_contents,
        cycle_info_p: ^fst$goi_cycle_information,
        cycle_dev_info_p: ^fst$device_information,
        device_class_ms: boolean,
        device_class_mt: boolean,
        file_info_p: ^fst$goi_file_information,
        gfn: ost$name,
        job_env_info_p: ^fst$job_environment_information,
        label_attrs: bat$static_label_attributes,
        line_size_o: ost$halfword,
        log_opt_i: amt$logging_possibilities,
        mc_i: amc$trivial_errors .. amc$statistics,
        mf_att_i: fst$mf_usage_concurrency_scope,
        non_nil_cycle_dev_info: boolean,
        non_nil_cycle_info: boolean,
        non_nil_job_env_info: boolean,
        old_line_size: ost$halfword,
        previously_opened: boolean,
        target_device_class: rmt$device_class,
        rj_w: t#attribute_width,
        width: t#attribute_width;

?? NEWTITLE := 'F#RESIDES_ONLINE', EJECT ??

      FUNCTION [INLINE] f#resides_online
        (    device_class_ms: boolean;
             non_nil_cycle_dev_info: boolean;
             obj: fst$goi_object): boolean;

        f#resides_online := ((device_class_ms) AND (non_nil_cycle_dev_info) AND
              obj.cycle_device_information^.mass_storage_device_info.resides_online);

      FUNCEND f#resides_online;
?? TITLE := 'add_actual_job_access', EJECT ??

      PROCEDURE add_actual_job_access;

        VAR
          fao_i: fst$file_access_option;

        IF obj.job_environment_information <> NIL THEN
          p#addl_string ('(AM=(', line);
          IF obj.job_environment_information^.attached_access_modes =
                $fst$file_access_options [] THEN
            p#addl_string ('NONE', line);
          ELSE
            FOR fao_i := LOWERVALUE (fao_i) TO UPPERVALUE (fao_i) DO
              IF fao_i IN obj.job_environment_information^.attached_access_modes THEN
                p#addl_string (access_share_modes [fao_i]^, line);
                line.size := line.size + 1;
              IFEND;
            FOREND;
            line.size := line.size - 1;
          IFEND;
          p#addl_string (') ', line);

          p#addl_string ('(SM=(', line);
          IF obj.job_environment_information^.attached_share_modes =
                $fst$file_access_options [] THEN
            p#addl_string ('NONE', line);
          ELSE
            FOR fao_i := LOWERVALUE (fao_i) TO UPPERVALUE (fao_i) DO
              IF fao_i IN obj.job_environment_information^.attached_access_modes THEN
                p#addl_string (access_share_modes [fao_i]^, line);
                line.size := line.size + 1;
              IFEND;
            FOREND;
            line.size := line.size - 1;
          IFEND;
          p#addl_string ('))', line);
        IFEND;

      PROCEND add_actual_job_access;
?? TITLE := 'ADD_ARCHIVE_MEDIA_DESC', EJECT ??

      PROCEDURE add_archive_media_desc
        (    obj: fst$goi_object;
         VAR status: ost$status);

        VAR
          entry_i: ost$halfword,
          entry_p: ^pft$archive_array_entry;

        IF (obj.archive_information_list <> NIL) THEN
          FOR entry_i := 1 TO UPPERBOUND (obj.archive_information_list^) DO
            entry_p := ^obj.archive_information_list^ [entry_i].archive_entry;
            p#addl_date_time (entry_p^.archive_date_time, line, status);
            line.size := line.size + 1;
            p#addl_string (entry_p^.archive_identification.application_identifier, line);
            line.size := line.size + 1;
            p#addl_string (entry_p^.archive_identification.media_identifier.
                  media_volume_identifier, line);
            line.size := line.size + 1;
          FOREND;
        IFEND;

      PROCEND add_archive_media_desc;
?? TITLE := 'ADD_RECORDED_VSN_LIST', EJECT ??

      PROCEDURE add_recorded_vsn_list
        (VAR line: t#string);

        VAR
          vol_i: ost$halfword,
          old_line_size: ost$halfword;

        IF non_nil_cycle_dev_info THEN
          IF (device_class_mt) AND (obj.cycle_device_information^.
                magnetic_tape_device_info.volume_list <> NIL) THEN
            make_list_of_recorded_vsns (obj.cycle_device_information^.
                  magnetic_tape_device_info.volume_list);

          ELSEIF (device_class_ms) AND obj.cycle_device_information^.
                mass_storage_device_info.resides_online AND
                (obj.cycle_device_information^.mass_storage_device_info.volume_list <>
                NIL) THEN
            p#addl_list_start (old_line_size, line);
            FOR vol_i := 1 TO UPPERBOUND (obj.cycle_device_information^.
                  mass_storage_device_info.volume_list^) DO
              p#addl_trim_str (obj.cycle_device_information^.mass_storage_device_info.
                    volume_list^ [vol_i].recorded_vsn, line);
              line.size := line.size + 1;
            FOREND;
            p#addl_list_stop (old_line_size, line);
          IFEND;
        IFEND;

      PROCEND add_recorded_vsn_list;
?? TITLE := 'ADD_RETRIEVE_OPTION', EJECT ??

      PROCEDURE add_retrieve_option
        (    cycle_info_p: ^fst$goi_cycle_information;
         VAR status: ost$status);

        IF (cycle_info_p <> NIL) THEN
          CASE cycle_info_p^.retrieve_option OF
          = pfc$always_retrieve =
            p#addl_string ('ALWAYS_RETRIEVE', line);

          = pfc$explicit_retrieve_only =
            p#addl_string ('EXPLICIT_RETRIEVE_ONLY', line);

          = pfc$admin_retrieve_only =
            p#addl_string ('ADMINISTRATIVE_RETRIEVE_ONLY', line);

          ELSE
            p#addl_string ('UNKNOWN_RETRIEVE_OPTION', line);
          CASEND;

        ELSE {NIL cycle_info_p
          p#addl_string ('UNKNOWN_RETRIEVE_OPTION', line);
        IFEND;

      PROCEND add_retrieve_option;
?? TITLE := 'ADD_SECONDARY_RESIDENCE', EJECT ??

      PROCEDURE add_secondary_residence
        (    obj: fst$goi_object;
         VAR status: ost$status);

        VAR
          zero_date_time: [READ, s#sec1] ost$date_time := [0, 1, 1, 0, 0, 0, 0];

        VAR
          entry_i: ost$halfword,
          entry_p: ^pft$archive_array_entry;

        IF (obj.archive_information_list <> NIL) THEN
          FOR entry_i := 1 TO UPPERBOUND (obj.archive_information_list^) DO
            entry_p := ^obj.archive_information_list^ [entry_i].archive_entry;
            p#addl_string (entry_p^.archive_identification.media_identifier.
                  media_device_class, line);
            line.size := line.size + 1;
            p#addl_date_time (entry_p^.archive_date_time, line, status);
            line.size := line.size + 1;
            p#addl_date_time (entry_p^.modification_date_time, line, status);
            line.size := line.size + 1;
            IF entry_p^.last_retrieval_status.retrieval_date_time = zero_date_time THEN
              p#addl_string ('NONE', line);
            ELSE
              p#addl_date_time (entry_p^.last_retrieval_status.retrieval_date_time, line,
                    status);
            IFEND;
            line.size := line.size + 1;
            p#addl_boolean (entry_p^.last_retrieval_status.normal, line);
            line.size := line.size + 1;
            p#addl_rjinteger (entry_p^.file_size, 15, line, status);
            line.size := line.size + 1;
          FOREND;
        IFEND;

      PROCEND add_secondary_residence;
?? TITLE := 'ADD_SITE_ATTRIBUTE_ORDINAL', EJECT ??

      PROCEDURE add_site_attribute_ordinal
        (    cycle_info_p: ^fst$goi_cycle_information;
             sa_index: t#site_attr_ordinal_indexes;
         VAR status: ost$status);

        VAR
          sa_ordinal_p: ^0 .. 0ff(16);

        IF (cycle_info_p <> NIL) THEN
          CASE sa_index OF
          = c#saoi_archive_option =
            sa_ordinal_p := ^cycle_info_p^.site_archive_option;
          = c#saoi_backup_option =
            sa_ordinal_p := ^cycle_info_p^.site_backup_option;
          = c#saio_release_option =
            sa_ordinal_p := ^cycle_info_p^.site_release_option;
          CASEND;

          p#addl_rjinteger (sa_ordinal_p^, 4, line, status);


        ELSE {NIL cycle_info_p
          p#addl_string ('NULL', line);
        IFEND;

      PROCEND add_site_attribute_ordinal;
?? TITLE := 'MAKE_LIST_OF_EXTERNAL_VSNS', EJECT ??

      PROCEDURE make_list_of_external_vsns
        (    vol_list_p: ^rmt$volume_list);

        VAR
          vol_i: ost$halfword;

        IF vol_list_p = NIL THEN

        ELSEIF vol_list_p^ [1].external_vsn = ' ' THEN
          p#addl_string ('()', line);

        ELSE
          p#addl_string ('(', line);
          FOR vol_i := 1 TO UPPERBOUND (vol_list_p^) DO
            p#addl_trim_str (vol_list_p^ [vol_i].external_vsn, line);
            line.size := line.size + 1;
          FOREND;
          line.size := line.size - 1;
          p#addl_string (')', line);
        IFEND;

      PROCEND make_list_of_external_vsns;
?? TITLE := 'MAKE_LIST_OF_RECORDED_VSNS', EJECT ??

      PROCEDURE make_list_of_recorded_vsns
        (    vol_list_p: ^rmt$volume_list);

        VAR
          vol_i: ost$halfword;

        IF vol_list_p = NIL THEN

        ELSEIF vol_list_p^ [1].recorded_vsn = ' ' THEN
          p#addl_string ('()', line);

        ELSE
          p#addl_string ('(', line);
          FOR vol_i := 1 TO UPPERBOUND (vol_list_p^) DO
            p#addl_trim_str (vol_list_p^ [vol_i].recorded_vsn, line);
            line.size := line.size + 1;
          FOREND;
          line.size := line.size - 1;
          p#addl_string (')', line);
        IFEND;

      PROCEND make_list_of_recorded_vsns;
?? OLDTITLE ??
?? EJECT ?? {process_cycle_entry

      device_class_mt := (obj.cycle_device_class = rmc$magnetic_tape_device);
      device_class_ms := (obj.cycle_device_class = rmc$mass_storage_device);
      cycle_info_p := obj.cycle_information;
      cycle_dev_info_p := obj.cycle_device_information;
      file_info_p := file_obj_p^.file_information;
      job_env_info_p := obj.job_environment_information;
      non_nil_cycle_info := (cycle_info_p <> NIL);
      non_nil_cycle_dev_info := (cycle_dev_info_p <> NIL);
      non_nil_job_env_info := (job_env_info_p <> NIL);

      IF ((file_label_attributes * attrs_req) <> $t#file_attribute_keys []) OR
            (c#fa_potential_job_access IN attrs_req) THEN
        fsp$expand_file_label (obj.file_label, label_attrs, previously_opened, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;

        IF (NOT previously_opened) AND (device_class_mt) AND
              (($t#file_attribute_keys [c#fa_file_label_type,
              c#fa_maximum_block_length] * attrs_req) <> $t#file_attribute_keys []) AND
              (non_nil_cycle_dev_info) THEN
          fsp$adjust_tape_defaults (cycle_dev_info_p^.magnetic_tape_device_info.density,
                label_attrs);
        IFEND;
      IFEND;

      IF device_class_mt THEN
        file_kind := c#fk_tape_volume;
      ELSEIF f#resides_online (device_class_ms, non_nil_cycle_dev_info, obj) THEN
        file_kind := c#fk_disk_file;
      ELSE
        file_kind := c#fk_archived_disk_file;
      IFEND;

      FOR attr_i := 1 TO UPPERBOUND (attrs_info_p^) DO
        line_size_o := line.size;
        width := attrs_info_p^ [attr_i].width;
        rj_w := width;
        CASE attrs_info_p^ [attr_i].attr OF

        = c#fa_access_control_list =

        = c#fa_account_project =
          IF file_info_p <> NIL THEN
            p#addl_acct_proj (file_info_p^.account, file_info_p^.project, line);
          IFEND;

        = c#fa_actual_job_access =
          add_actual_job_access;

        = c#fa_archive_media_descriptor =
          add_archive_media_desc (obj, status);

        = c#fa_attached =
          p#addl_boolean ((non_nil_job_env_info AND job_env_info_p^.cycle_attached),
                line);

        = c#fa_attached_external_vsn_list =
          IF (device_class_mt) AND (non_nil_job_env_info) AND
                (job_env_info_p^.cycle_attached) THEN
            make_list_of_external_vsns (job_env_info_p^.volume_list);
          IFEND;

        = c#fa_attached_recorded_vsn_list =
          IF (device_class_mt) AND (non_nil_job_env_info) AND
                (job_env_info_p^.cycle_attached) THEN
            make_list_of_recorded_vsns (job_env_info_p^.volume_list);
          IFEND;

        = c#fa_attached_transfer_size =
          IF (device_class_ms) AND (non_nil_job_env_info) AND
                (job_env_info_p^.cycle_attached) AND (fsc$transfer_size_ao IN
                job_env_info_p^.specified_attachment_options) THEN
            p#addl_rjinteger (job_env_info_p^.transfer_size, rj_w, line, status);
          IFEND;

        = c#fa_attached_vol_oflo_allowed =
          IF (device_class_mt) AND (non_nil_job_env_info) AND
                (job_env_info_p^.cycle_attached) THEN
            p#addl_boolean (job_env_info_p^.volume_overflow_allowed, line);
          IFEND;

        = c#fa_attached_volume_number =
          IF (device_class_mt) AND (non_nil_job_env_info) AND
                (job_env_info_p^.cycle_attached) THEN
            p#addl_rjinteger (job_env_info_p^.volume_number, rj_w, line, status);
          IFEND;

        = c#fa_attachment_log =

        = c#fa_attachment_logging_sel =
          IF (file_info_p <> NIL) AND (file_info_p^.logging_selection <> NIL) THEN
            p#addl_boolean ((file_info_p^.logging_selection^ = pfc$log), line);
          IFEND;

        = c#fa_average_record_length =
          IF label_attrs.average_record_length_source <> amc$undefined_attribute THEN
            p#addl_rjinteger (label_attrs.average_record_length, rj_w, line, status);
          IFEND;

        = c#fa_block_type =
          p#addl_string (block_types [label_attrs.block_type]^, line);

        = c#fa_character_conversion =
          p#addl_boolean (label_attrs.character_conversion, line);

        = c#fa_collate_table_name =
          p#addl_entry_point (label_attrs.collate_table_name, line);

        = c#fa_compression_procedure_name =
          IF label_attrs.compression_procedure_name.name = osc$null_name THEN
            p#addl_string ('NONE', line);
          ELSE
            p#addl_trim_str (label_attrs.compression_procedure_name.name, line);
            line.size := line.size + 1;
            p#addl_trim_str (label_attrs.compression_procedure_name.object_library, line);
          IFEND;

        = c#fa_connected_files =

        = c#fa_creation_date_time =
          IF non_nil_cycle_info THEN
            p#addl_date_time (cycle_info_p^.creation_date_time, line, status);
          IFEND;

        = c#fa_cycle_number =
          p#addl_rjinteger (obj.cycle_number, rj_w, line, status);

        = c#fa_data_padding =
          p#addl_rjinteger (label_attrs.data_padding, rj_w, line, status);

        = c#fa_device_class =
          p#addl_string (class [obj.cycle_device_class]^, line);

        = c#fa_dynamic_home_block_space =
          p#addl_boolean (label_attrs.dynamic_home_block_space, line);

        = c#fa_embedded_key =
          p#addl_boolean (label_attrs.embedded_key, line);

        = c#fa_error_exit_procedure_name =
          IF (obj.job_environment_information = NIL) OR
                (job_env_info_p^.error_exit_procedure_name = osc$null_name) THEN
            p#addl_string ('NONE', line);
          ELSE
            p#addl_trim_str (job_env_info_p^.error_exit_procedure_name, line);
          IFEND;

        = c#fa_error_limit =
          IF non_nil_job_env_info THEN
            p#addl_rjinteger (job_env_info_p^.error_limit, rj_w, line, status);
          IFEND;

        = c#fa_estimated_record_count =
          IF label_attrs.estimated_record_count_source <> amc$undefined_attribute THEN
            p#addl_rjinteger (label_attrs.estimated_record_count, rj_w, line, status);
          IFEND;

        = c#fa_exception_conditions =

        = c#fa_expiration_date = {Need to test if :$LOCAL file!
          IF (cycle_info_p = NIL) OR (cycle_info_p^.expiration_date_time = max_date_time)
                THEN
            p#addl_string ('INFINITE', line);
          ELSE
            p#addl_date_time (cycle_info_p^.expiration_date_time, line, status);
          IFEND;

        = c#fa_external_vsn_list =
          IF (device_class_mt) AND (non_nil_cycle_dev_info) AND
                (cycle_dev_info_p^.magnetic_tape_device_info.volume_list <> NIL) THEN
            make_list_of_external_vsns (cycle_dev_info_p^.magnetic_tape_device_info.
                  volume_list);
          IFEND;

        = c#fa_file_access_procedure_name =
          p#addl_entry_point (label_attrs.file_access_procedure, line);

        = c#fa_file_contents =
          fsp$convert_file_contents (label_attrs.file_contents,
                label_attrs.file_structure, combined_file_contents, status);
          IF status.normal THEN
            p#addl_trim_str (combined_file_contents, line);
          ELSE
            p#addl_trim_str (label_attrs.file_contents, line);
            status.normal := TRUE;
          IFEND;

        = c#fa_file_label_type =
          p#addl_string (label_types [label_attrs.label_type]^, line);

        = c#fa_file_limit =
          p#addl_rjinteger (label_attrs.file_limit, rj_w, line, status);

        = c#fa_file_name =
          p#addl_trim_str (file_obj_p^.file_name, line);

        = c#fa_file_organization =
          p#addl_string (file_organizations [label_attrs.file_organization]^, line);

        = c#fa_file_previously_opened =
          p#addl_boolean (previously_opened, line);

        = c#fa_file_processor =
          p#addl_trim_str (label_attrs.file_processor, line);

        = c#fa_fill =
          p#addl_string (v#blanks (1, width), line);

        = c#fa_forced_write =
          IF label_attrs.forced_write = amc$forced_if_structure_change THEN
            p#addl_string ('FORCED_IF_STRUCTURE_CHANGE', line);
          ELSE
            p#addl_boolean ((label_attrs.forced_write = amc$forced), line);
          IFEND;

        = c#fa_full_path =
          p#addl_string (object_info_p^.resolved_path^, line);
          p#addl_string ('.', line);
          p#addl_trim_str (file_obj_p^.file_name, line);
          p#addl_string ('.', line);
          p#addl_integer (obj.cycle_number, line, status);

        = c#fa_hashing_procedure_name =
          IF (label_attrs.hashing_procedure_name_source = amc$undefined_attribute) OR
                (label_attrs.hashing_procedure_name.name = osc$null_name) THEN
            p#addl_string ('NONE', line);
          ELSE
            p#addl_trim_str (label_attrs.hashing_procedure_name.name, line);
            line.size := line.size + 1;
            p#addl_trim_str (label_attrs.hashing_procedure_name.object_library, line);
          IFEND;

        = c#fa_index_levels =
          p#addl_rjinteger (label_attrs.index_levels, rj_w, line, status);

        = c#fa_index_padding =
          p#addl_rjinteger (label_attrs.index_padding, rj_w, line, status);

        = c#fa_initial_home_block_count =
          p#addl_rjinteger (label_attrs.initial_home_block_count, rj_w, line, status);

        = c#fa_internal_code =
          p#addl_string (internal_codes [label_attrs.internal_code]^, line);

        = c#fa_job_file_address =
          IF non_nil_job_env_info THEN
            p#addl_rjinteger (job_env_info_p^.job_file_address, rj_w, line, status);
          IFEND;

        = c#fa_job_file_position =
          IF non_nil_job_env_info THEN
            p#addl_string (job_file_positions [job_env_info_p^.job_file_position]^, line);
          IFEND;

        = c#fa_job_instances_of_open =
          IF non_nil_job_env_info THEN
            p#addl_rjinteger (job_env_info_p^.concurrent_open_count, rj_w, line, status);
          IFEND;

        = c#fa_job_write_concurrency =
          IF (non_nil_job_env_info) AND (fsc$job_write_concurrency_ao IN
                job_env_info_p^.specified_attachment_options) THEN
            p#addl_boolean (job_env_info_p^.job_write_concurrency, line);
          IFEND;

        = c#fa_key_length =
          IF label_attrs.key_length_source <> amc$undefined_attribute THEN
            p#addl_rjinteger (label_attrs.key_length, rj_w, line, status);
          IFEND;

        = c#fa_key_position =
          p#addl_integer_pair (label_attrs.key_position, label_attrs.key_length, line,
                status);

        = c#fa_key_type =
          p#addl_string (key_types [label_attrs.key_type]^, line);

        = c#fa_last_access_date_time =
          IF non_nil_cycle_info THEN
            p#addl_date_time (cycle_info_p^.last_access_date_time, line, status);
          IFEND;

        = c#fa_last_data_mod_time =
          IF non_nil_cycle_info THEN
            p#addl_date_time (cycle_info_p^.data_modification_date_time, line, status);
          IFEND;

        = c#fa_last_mod_date_time =
          IF non_nil_cycle_info THEN
            p#addl_date_time (cycle_info_p^.last_modification_date_time, line, status);
          IFEND;

        = c#fa_lifetime =

        = c#fa_lifetime_attachment_count =
          IF non_nil_cycle_info THEN
            p#addl_rjinteger (cycle_info_p^.lifetime_attachment_count, rj_w, line,
                  status);
          IFEND;

        = c#fa_line_number =
          IF label_attrs.line_number_source <> amc$undefined_attribute THEN
            p#addl_integer_pair (label_attrs.line_number.location,
                  label_attrs.line_number.length, line, status);
          IFEND;

        = c#fa_loading_factor =
          p#addl_rjinteger (label_attrs.loading_factor, rj_w, line, status);

        = c#fa_lock_expiration_time =
          p#addl_rjinteger (label_attrs.lock_expiration_time, rj_w, line, status);

        = c#fa_log_residence =

        = c#fa_logging_options =
          IF label_attrs.logging_options <> $amt$logging_options [] THEN
            p#addl_list_start (old_line_size, line);
            FOR log_opt_i := LOWERVALUE (log_opt_i) TO UPPERVALUE (log_opt_i) DO
              IF log_opt_i IN label_attrs.logging_options THEN
                p#addl_string (logging_possibilities [log_opt_i]^, line);
                line.size := line.size + 1;
              IFEND;
            FOREND;
            p#addl_list_stop (old_line_size, line);
          ELSE
            p#addl_string ('NONE', line);
          IFEND;

        = c#fa_mainframe_attachment =
          IF (non_nil_cycle_info) AND (cycle_info_p^.mainframe_usage_concurrency <>
                $fst$mainframe_usage_concurrency []) THEN
            p#addl_list_start (old_line_size, line);
            FOR mf_att_i := LOWERVALUE (mf_att_i) TO UPPERVALUE (mf_att_i) DO
              IF mf_att_i IN cycle_info_p^.mainframe_usage_concurrency THEN
                p#addl_string (mainframe_attachments [mf_att_i]^, line);
                line.size := line.size + 1;
              IFEND;
            FOREND;
            p#addl_list_stop (old_line_size, line);
          IFEND;

        = c#fa_mf_write_concurrency =
          IF (non_nil_cycle_info) AND (cycle_info_p^.mainframe_write_concurrency <>
                fsc$not_attached_for_write) THEN
            p#addl_string (mainframe_write_concurrencies
                  [cycle_info_p^.mainframe_write_concurrency]^, line);
          IFEND;

        = c#fa_ms_allocation_size =
          IF f#resides_online (device_class_ms, non_nil_cycle_dev_info, obj) THEN
            p#addl_rjinteger (cycle_dev_info_p^.mass_storage_device_info.
                  allocation_unit_size, rj_w, line, status);
          IFEND;

        = c#fa_ms_bytes_allocated =
          IF f#resides_online (device_class_ms, non_nil_cycle_dev_info, obj) THEN
            p#addl_rjinteger (cycle_dev_info_p^.mass_storage_device_info.bytes_allocated,
                  rj_w, line, status);
          IFEND;

        = c#fa_ms_class =
          IF f#resides_online (device_class_ms, non_nil_cycle_dev_info, obj) THEN
            char_str := cycle_dev_info_p^.mass_storage_device_info.mass_storage_class;
            p#addl_string (char_str, line);
          IFEND;

        = c#fa_ms_free_behind =
          IF (device_class_ms) AND (non_nil_job_env_info) AND
                (fsc$free_behind_ao IN job_env_info_p^.specified_attachment_options) THEN
            p#addl_boolean (job_env_info_p^.mass_storage_free_behind, line);
          IFEND;

        = c#fa_ms_initial_volume =
          IF f#resides_online (device_class_ms, non_nil_cycle_dev_info,
                obj) AND (cycle_dev_info_p^.mass_storage_device_info.initial_volume <>
                ' ') THEN
            p#addl_trim_str (cycle_dev_info_p^.mass_storage_device_info.initial_volume,
                  line);
          IFEND;

        = c#fa_ms_sequential_access =
          IF (device_class_ms) AND (non_nil_job_env_info) AND
                (fsc$sequential_access_ao IN job_env_info_p^.specified_attachment_options)
                THEN
            p#addl_boolean (job_env_info_p^.mass_storage_sequential_access, line);
          IFEND;

        = c#fa_ms_transfer_size =
          IF f#resides_online (device_class_ms, non_nil_cycle_dev_info, obj) THEN
            p#addl_rjinteger (cycle_dev_info_p^.mass_storage_device_info.transfer_size,
                  rj_w, line, status);
          IFEND;

        = c#fa_maximum_block_length =
          p#addl_rjinteger (label_attrs.max_block_length, rj_w, line, status);

        = c#fa_maximum_record_length =
          p#addl_rjinteger (label_attrs.max_record_length, rj_w, line, status);

        = c#fa_message_control =
          IF non_nil_job_env_info THEN
            IF job_env_info_p^.message_control <> $amt$message_control [] THEN
              p#addl_list_start (old_line_size, line);
              FOR mc_i := LOWERVALUE (mc_i) TO UPPERVALUE (mc_i) DO
                IF mc_i IN job_env_info_p^.message_control THEN
                  p#addl_string (message_controls [mc_i]^, line);
                IFEND;
              FOREND;
              p#addl_list_stop (old_line_size, line);
            ELSE
              p#addl_string ('NONE', line);
            IFEND;
          IFEND;

        = c#fa_minimum_block_length =
          p#addl_rjinteger (label_attrs.min_block_length, rj_w, line, status);

        = c#fa_minimum_record_length =
          p#addl_rjinteger (label_attrs.min_record_length, rj_w, line, status);

        = c#fa_object_type =
          p#addl_string ('FILE', line);

        = c#fa_open_position =

        = c#fa_padding_character =
          char_str := label_attrs.padding_character;
          p#addl_string (char_str, line);

        = c#fa_page_format =
          p#addl_string (page_formats [label_attrs.page_format]^, line);

        = c#fa_page_length =
          p#addl_rjinteger (label_attrs.page_length, rj_w, line, status);

        = c#fa_page_width =
          p#addl_rjinteger (label_attrs.page_width, rj_w, line, status);

        = c#fa_password =
          p#addl_trim_str (file_obj_p^.password, line);

        = c#fa_path =
          p#addl_string (object_info_p^.resolved_path^, line);

        = c#fa_permitted_access =

        = c#fa_potential_job_access =

        = c#fa_preset_value =
          p#addl_rjinteger (label_attrs.preset_value, rj_w, line, status);

        = c#fa_private_read =
          IF (non_nil_job_env_info) AND job_env_info_p^.private_read.
                specified_on_attach THEN
            p#addl_boolean (job_env_info_p^.private_read.value, line);
          IFEND;

        = c#fa_record_delimiting_char =
          char_str := label_attrs.record_delimiting_character;
          p#addl_string (char_str, line);

        = c#fa_record_limit =
          IF label_attrs.record_limit_source <> amc$undefined_attribute THEN
            p#addl_rjinteger (label_attrs.record_limit, rj_w, line, status);
          IFEND;

        = c#fa_record_type =
          p#addl_string (record_types [label_attrs.record_type]^, line);

        = c#fa_recorded_vsn_list =
          add_recorded_vsn_list (line);

        = c#fa_records_per_block =
          IF label_attrs.records_per_block_source <> amc$undefined_attribute THEN
            p#addl_rjinteger (label_attrs.records_per_block, rj_w, line, status);
          IFEND;

        = c#fa_registered =
          p#addl_boolean ((obj.cycle_global_file_name <> null_unique_name), line);

        = c#fa_retrieve_option =
          add_retrieve_option (cycle_info_p, status);

        = c#fa_ring_attributes =
          p#addl_string ('(', line);
          p#addl_rjinteger (label_attrs.ring_attributes.r1, 2, line, status);
          line.size := line.size + 1;
          p#addl_rjinteger (label_attrs.ring_attributes.r2, 2, line, status);
          line.size := line.size + 1;
          p#addl_rjinteger (label_attrs.ring_attributes.r3, 2, line, status);
          p#addl_string (')', line);

        = c#fa_secondary_residence =
          add_secondary_residence (obj, status);

        = c#fa_set_name =
          p#addl_trim_str (object_info_p^.set_name, line);

        = c#fa_shared_queue =
          IF (device_class_ms) AND (non_nil_cycle_dev_info) AND
                (cycle_dev_info_p^.mass_storage_device_info.shared_queue <> osc$null_name)
                THEN
            p#addl_trim_str (cycle_dev_info_p^.mass_storage_device_info.shared_queue,
                  line);
          IFEND;

        = c#fa_site_archive_option =
          add_site_attribute_ordinal (cycle_info_p, c#saoi_archive_option, status);

        = c#fa_site_backup_option =
          add_site_attribute_ordinal (cycle_info_p, c#saoi_backup_option, status);

        = c#fa_site_release_option =
          add_site_attribute_ordinal (cycle_info_p, c#saio_release_option, status);

        = c#fa_size =
          IF (obj.cycle_size <> NIL) THEN
            p#addl_rjinteger (obj.cycle_size^, rj_w, line, status);
          IFEND;

        = c#fa_statement_identifier =
          IF label_attrs.statement_identifier_source <> amc$undefined_attribute THEN
            p#addl_integer_pair (label_attrs.statement_identifier.location,
                  label_attrs.statement_identifier.length, line, status);
          IFEND;

        = c#fa_tape_density =
          IF (device_class_mt) AND (non_nil_cycle_dev_info) THEN
            p#addl_string (tape_densities [cycle_dev_info_p^.magnetic_tape_device_info.
                  density]^, line);
          IFEND;

        = c#fa_unique_data_name =
          IF (device_class_ms) THEN
            pmp$convert_binary_unique_name (obj.cycle_global_file_name, gfn, status);
            p#addl_string (gfn, line);
            status.normal := TRUE;
          IFEND;

        = c#fa_unique_name =
          pmp$convert_binary_unique_name (obj.cycle_global_file_name, gfn, status);
          p#addl_string (gfn, line);
          status.normal := TRUE;

        = c#fa_user_information =
          p#addl_trim_str (label_attrs.user_info, line);

        = c#fa_vertical_print_density =
          p#addl_rjinteger (label_attrs.vertical_print_density, 2, line, status);

        = c#fa_volume_overflow_allowed =
          IF (device_class_ms) AND (non_nil_cycle_dev_info) THEN
            p#addl_boolean (cycle_dev_info_p^.mass_storage_device_info.
                  volume_overflow_allowed, line);
          IFEND;

        CASEND;
        line.size := line_size_o + attrs_info_p^ [attr_i].width;
      FOREND;

    PROCEND process_cycle_entry;
?? TITLE := 'GET_OBJECT_INFO', EJECT ??

    PROCEDURE get_object_info
      (    file_ref_p: ^fst$file_reference;
           info_req: fst$goi_information_request;
           attrs_info_p: ^t#attribute_infos;
           attrs_req: t#file_attribute_keys;
           attrs_req_n: t#object_type_counts;
           file_label_attrs: t#file_attribute_keys_set;
           obj_order: t#object_sort_order;
           file_order: t#file_sort_order;
       VAR work_area_p: ^SEQ ( * );
       VAR status: ost$status);

      VAR
        cyc_i: ost$halfword,
        file_kind: t#file_kind,
        line: t#string,
        obj_i: ost$halfword,
        obj_p: ^fst$goi_object,
        object_info_p: ^fst$goi_object_information,
        object_info_seq_p: ^SEQ ( * ),
        object_list_p: ^fst$goi_object_list,
        path_p: ^fst$file_reference,
        prev_path_n: ost$halfword;

      object_info_seq_p := work_area_p;
      pfp$get_object_information (file_ref_p^, info_req, NIL, work_area_p, status);
      IF NOT status.normal THEN
        RETURN; {----->
      IFEND;
      NEXT object_info_p IN object_info_seq_p;
      object_list_p := object_info_p^.object^.subcatalog_and_file_object_list;
      IF object_list_p = NIL THEN
        RETURN; {----->
      IFEND;

      ofp$display_status_message (object_info_p^.resolved_path^, status);
      status.normal := TRUE;

      FOR obj_i := 1 TO UPPERBOUND (object_list_p^) DO
        obj_p := ^object_list_p^ [obj_i];
        CASE obj_p^.object_type OF

        = fsc$goi_catalog_object =
          prev_path_n := STRLENGTH (object_info_p^.resolved_path^);
          PUSH path_p: [prev_path_n + 1 + 31];
          path_p^ (1, prev_path_n) := object_info_p^.resolved_path^;
          path_p^ (prev_path_n + 1) := '.';
          path_p^ (prev_path_n + 2, * ) := obj_p^.catalog_name;
          get_object_info (path_p, info_req, attrs_info_p, attrs_req, attrs_req_n,
                file_label_attrs, obj_order, file_order, work_area_p, status);

        = fsc$goi_file_object =
          FOR cyc_i := 1 TO UPPERBOUND (obj_p^.cycle_object_list^) DO
            line.size := 0;
            line.value := ' ';
            process_cycle_entry (obj_p^.cycle_object_list^ [cyc_i], object_info_p, obj_p,
                  attrs_info_p, file_label_attrs, file_kind, line, status);
            clp$put_display (dis_ctl, line.value (1, line.size), clc$no_trim, status);
          FOREND;
        CASEND;
      FOREND;

    PROCEND get_object_info;
?? TITLE := 'GET_FAMILIES', EJECT ??

    PROCEDURE get_families
      (VAR catalogs_p: ^array [1 .. * ] of ^fst$file_reference;
       VAR work_area_p: ^SEQ ( * );
       VAR status: ost$status);

{Set CATALOGS to all active families.

      VAR
        active_family_list_p: ^pmt$family_name_list,
        i: ost$halfword,
        number_of_families: pmt$family_name_count;

      number_of_families := 100;
      REPEAT
        PUSH active_family_list_p: [1 .. number_of_families];
        pmp$get_family_names (active_family_list_p^, number_of_families, status);
        IF NOT status.normal THEN
          RETURN; {----->
        IFEND;
      UNTIL number_of_families <= UPPERBOUND (active_family_list_p^);
      NEXT catalogs_p: [1 .. number_of_families] IN work_area_p;
      FOR i := 1 TO number_of_families DO
        NEXT catalogs_p^ [i]: [clp$trimmed_string_size (active_family_list_p^ [i]) + 1] IN
              work_area_p;
        catalogs_p^ [i]^ (1) := ':';
        catalogs_p^ [i]^ (2, * ) := active_family_list_p^ [i];
      FOREND;

    PROCEND get_families;
?? TITLE := 'INITIALIZE', EJECT ??

    PROCEDURE initialize
      (VAR attrs_info_p: ^t#attribute_infos;
       VAR dis_ctl: clt$display_control;
       VAR obj_order: t#object_sort_order;
       VAR file_order: t#file_sort_order;
       VAR work_area_p: ^SEQ ( * );
       VAR status: ost$status);

      VAR
        default_ring_attributes: amt$ring_attributes;

      fip#create_scratch_sequence (work_area_p, status);
      IF status.normal THEN
        NEXT attrs_info_p: [1 .. c#attribute_key_max] IN work_area_p;

        default_ring_attributes.r1 := #RING (^default_ring_attributes);
        default_ring_attributes.r2 := #RING (^default_ring_attributes);
        default_ring_attributes.r3 := #RING (^default_ring_attributes);
        clp$open_display_reference (pvt [p$output].value^.file_value^, NIL, fsc$list,
              default_ring_attributes, dis_ctl, status);
      IFEND;

    PROCEND initialize;
?? OLDTITLE ??
?? EJECT ?? {usp#report_files
*copyc usd#report_files

    VAR
      attrs_info_p: ^t#attribute_infos,
      attrs_req: t#file_attribute_keys,
      attrs_req_n: t#object_type_counts,
      catalogs_p: ^array [1 .. * ] of ^fst$file_reference,
      catalogs_i: ost$halfword,
      dis_ctl: clt$display_control,
      file_label_attrs: t#file_attribute_keys_set,
      file_order: t#file_sort_order,
      info_req: fst$goi_information_request,
      obj_order: t#object_sort_order,
      work_area_p: ^SEQ ( * );

    clp$evaluate_parameters (parameter_list, #SEQ (pdt), NIL, ^pvt, status);
    IF NOT status.normal THEN
      RETURN; {----->
    IFEND;
    initialize (attrs_info_p, dis_ctl, obj_order, file_order, work_area_p, status);
    IF status.normal THEN
      determine_requested_attributes (pvt [p$fields].value, attrs_info_p, attrs_req,
            attrs_req_n, file_label_attrs, status);
    IFEND;
    IF status.normal THEN
      info_req := initial_information_request;
      determine_object_info_requests (attrs_req, info_req.object_information_requests);
    IFEND;

    IF status.normal THEN
      IF pvt [p$catalog].value^.kind = clc$file THEN
        PUSH catalogs_p: [1 .. 1];
        catalogs_p^ [1] := pvt [p$catalog].value^.file_value;
      ELSE
        get_families (catalogs_p, work_area_p, status);
      IFEND;
    IFEND;

    IF status.normal THEN
      FOR catalogs_i := 1 TO UPPERBOUND (catalogs_p^) DO
        get_object_info (catalogs_p^ [catalogs_i], info_req, attrs_info_p, attrs_req,
              attrs_req_n, file_label_attrs, obj_order, file_order, work_area_p, status);
      FOREND;
    IFEND;

  PROCEND usp#report_files;
?? OLDTITLE ??
MODEND usm#report_files;
*DECK DECK=UTM$BAMTEST_DRIVER EXPAND=TRUE
*copyc OSD$DEFAULT_PRAGMATS
?? SET (LISTCTS := OFF) ??
MODULE bamtest_driver;
?? SET (LIST := OFF) ??
*copyc CLP$VALIDATE_NAME
*copyc CLE$ECC_LEXICAL
*copyc OSP$SET_STATUS_ABNORMAL
*copyc AMC$CONDITION_CODE_LIMITS
*copyc CLP$SCAN_PARAMETER_LIST
*copyc CLP$GET_VALUE
*copyc AMP$OPEN
*copyc AMP$GET_NEXT
*copyc AMP$CLOSE
*copyc AMP$TST_FID_OUT
*copyc AMP$TST_GETN_OUT
*copyc AMP$TST_STATUS_OUT
*copyc OST$STATUS
*copyc OST$NAME
*copyc CLP$PUT_JOB_OUTPUT

  PROCEDURE [XREF] bap$bamtest1;

  PROCEDURE [XREF] bap$bamtest2;

  PROCEDURE [XREF] bap$bamtest3;

  PROCEDURE [XREF] bap$bamtest4;

  PROCEDURE [XREF] bap$bamtest5;

  PROCEDURE [XREF] bap$bamtest6;

  PROCEDURE [XREF] bap$bamtest7;

  PROCEDURE [XREF] bap$bamtest8;

  PROCEDURE [XREF] bap$bamtest9;

  PROCEDURE [XREF] bap$bamtest10;

  PROCEDURE [XREF] bap$bamtest11;

  PROCEDURE [XREF] bap$bamtest12;

  PROCEDURE [XREF] bap$bamtest13;

  PROCEDURE [XREF] bap$bamtest14;

  PROCEDURE [XREF] bap$bamtest15;

  PROCEDURE [XREF] bap$bamtest16;

  PROCEDURE [XREF] bap$bamtest17;

  PROCEDURE [XREF] bap$bamtest18;

  PROCEDURE [XREF] bap$bamtest19;

  PROCEDURE [XREF] bap$bamtest20;

  PROCEDURE [XREF] bap$bamtest21;

  PROCEDURE [XREF] bap$bamtest22;

  PROCEDURE [XREF] bap$bamtest23;

  PROCEDURE [XREF] bap$bamtest24;

  PROCEDURE [XREF] bap$bamtest25;

  PROCEDURE [XREF] bap$bamtest26;

  PROCEDURE [XREF] bap$bamtest27;

  PROCEDURE [XREF] bap$bamtest28;

  PROCEDURE [XREF] bap$bamtest29;

  PROCEDURE [XREF] bap$bamtest30;

  PROCEDURE [XREF] bap$bamtest31;

  PROCEDURE [XREF] bap$bamtest32;

  PROCEDURE [XREF] bap$bamtest33;

  PROCEDURE [XREF] bap$bamtest34;

  PROCEDURE [XREF] bap$bamtest35;

  PROCEDURE [XREF] bap$bamtest36;

  PROCEDURE [XREF] bap$bamtest37;

  PROCEDURE [XREF] bap$bamtest38;

  PROCEDURE [XREF] bap$bamtest39;

  PROCEDURE [XREF] bap$bamtest40;

  PROCEDURE [XREF] bap$bamtest41;

  PROCEDURE [XREF] bap$bamtest42;

  PROCEDURE [XREF] bap$bamtest43;

  PROCEDURE [XREF] bap$bamtest44;

  PROCEDURE [XREF] bap$bamtest45;

  PROCEDURE [XREF] bap$bamtest46;

  PROCEDURE [XREF] bap$bamtest47;

  PROCEDURE [XREF] bap$bamtest48;

  PROCEDURE [XREF] bap$bamtest49;

  PROCEDURE [XREF] bap$bamtest50;
?? SET (LIST := ON) ??

  PROCEDURE [XDCL, #GATE] bamtest (parameter_list: clt$parameter_list;
    VAR status: ost$status);

    TYPE
      bat$input_ord = (bac$yes, bac$bamstop, bac$no, bac$long, bac$short,
        bac$tes1, bac$tes2, bac$tes3, bac$tes4, bac$tes5, bac$tes6, bac$tes7,
        bac$tes8, bac$tes9, bac$tes10, bac$tes11, bac$tes12, bac$tes13,
        bac$tes14, bac$tes15, bac$tes16, bac$tes17, bac$tes18, bac$tes19,
        bac$tes20, bac$tes21, bac$tes22, bac$tes23, bac$tes24, bac$tes25,
        bac$tes26, bac$tes27, bac$tes28, bac$tes29, bac$tes30, bac$tes31,
        bac$tes32, bac$tes33, bac$tes34, bac$tes35, bac$tes36, bac$tes37,
        bac$tes38, bac$tes39, bac$tes40, bac$tes41, bac$tes42, bac$tes43,
        bac$tes44, bac$tes45, bac$tes46, bac$tes47, bac$tes48, bac$tes49,
        bac$tes50, bac$garbage);

    CONST
      bac$long_msg_limit = 35,
      bac$short_msg_limit = 11;

{ pdt bamtest_pdt(input,i:fileref=input)

    VAR
      bamtest_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table :=
        [^bamtest_pdt_names, ^bamtest_pdt_params];

    VAR
      bamtest_pdt_names: [STATIC, READ, cls$pdt] array [1 .. 2] of
        clt$parameter_name_descriptor := [['INPUT', 1], ['I', 1]];

    VAR
      bamtest_pdt_params: [STATIC, READ, cls$pdt] array [1 .. 1] of
        clt$parameter_descriptor := [

{ INPUT I }
      [[clc$optional_with_default, ^bamtest_pdt_dv1], 1, 1, 1, 1,
        clc$value_range_not_allowed, [NIL, clc$file_value]]];

    VAR
      bamtest_pdt_dv1: [STATIC, READ, cls$pdt] string (5) := 'input';

    VAR
      value: clt$value,
      fid: amt$file_identifier,
      id: string (15),
      msg1,
      msg2,
      msg3: string (95),
      ptr: ^0 .. 00000ffffffff(16),
      stat: ost$status,
      cmod: bat$input_ord,
      command: ost$name,
      validated_name: ost$name,
      valid_name: boolean,
      exit_loop: boolean,
      i: integer,
      input_ord: bat$input_ord,
      input: array [bat$input_ord] of string (70),
      long_des: array [1 .. bac$long_msg_limit] of string (95),
      short_des: array [1 .. bac$short_msg_limit] of string (95),
      ba: amt$file_byte_address,
      tc: amt$transfer_count,
      fp: amt$file_position;

    CONST
      bac$null_command = '                                                    '
        CAT '                  ';

    { initialize general messages }

    msg1 := 'BAMTEST msg1: Would you like instructions?';
    msg2 := 'BAMTEST msg2: Would you like long or short form?';
    msg3 := 'BAMTEST msg3: Please enter your test request';

    { initialize input array }

    input [bac$garbage] := '    ';
    input [bac$bamstop] := 'BAMSTOP';
    input [bac$yes] := 'YES';
    input [bac$no] := 'NO';
    input [bac$long] := 'LONG';
    input [bac$short] := 'SHORT';
    input [bac$tes1] := 'TES1';
    input [bac$tes2] := 'TES2';
    input [bac$tes3] := 'TES3';
    input [bac$tes4] := 'TES4';
    input [bac$tes5] := 'TES5';
    input [bac$tes6] := 'TES6';
    input [bac$tes7] := 'TES7';
    input [bac$tes8] := 'TES8';
    input [bac$tes9] := 'TES9';
    input [bac$tes10] := 'TES10';
    input [bac$tes11] := 'TES11';
    input [bac$tes12] := 'TES12';
    input [bac$tes13] := 'TES13';
    input [bac$tes14] := 'TES14';
    input [bac$tes15] := 'TES15';
    input [bac$tes16] := 'TES16';
    input [bac$tes17] := 'TES17';
    input [bac$tes18] := 'TES18';
    input [bac$tes19] := 'TES19';
    input [bac$tes20] := 'TES20';
    input [bac$tes21] := 'TES21';
    input [bac$tes22] := 'TES22';
    input [bac$tes23] := 'TES23';
    input [bac$tes24] := 'TES24';
    input [bac$tes25] := 'TES25';
    input [bac$tes26] := 'TES26';
    input [bac$tes27] := 'TES27';
    input [bac$tes28] := 'TES28';
    input [bac$tes29] := 'TES29';
    input [bac$tes30] := 'TES30';
    input [bac$tes31] := 'TES31';
    input [bac$tes32] := 'TES32';
    input [bac$tes33] := 'TES33';
    input [bac$tes34] := 'TES34';
    input [bac$tes35] := 'TES35';
    input [bac$tes36] := 'TES36';
    input [bac$tes37] := 'TES37';
    input [bac$tes38] := 'TES38';
    input [bac$tes39] := 'TES39';
    input [bac$tes40] := 'TES40';
    input [bac$tes41] := 'TES41';
    input [bac$tes42] := 'TES42';
    input [bac$tes43] := 'TES43';
    input [bac$tes44] := 'TES44';
    input [bac$tes45] := 'TES45';
    input [bac$tes46] := 'TES46';
    input [bac$tes47] := 'TES47';
    input [bac$tes48] := 'TES48';
    input [bac$tes49] := 'TES49';
    input [bac$tes50] := 'TES50';

    { initialize descriptions }
    long_des [1] := 'BAMTEST: Long Description of commands.';
    long_des [2] :=
      'This procedure accepts input from the user to selectively execute';
    long_des [3] :=
      'user level procedures to exercise the basic access method program';
    long_des [4] :=
      'interface.  It will continue to ask for input until the string';
    long_des [5] :=
      '"stopbam" is entered, at which time the task will terminate and';
    long_des [6] :=
      'return you to NOS/VE.  Currently available test procedures and the';
    long_des [7] := 'input string used to call them are:';
    long_des [8] := '    ';
    long_des [9] := '    INPUT                      DESCRIPTION';
    long_des [10] := '    tes1:    Run severl amp$open and amp$close requests';
    long_des [11] :=
      '    tes2:    Run an amp$open, use amp$put_next to put a 100 byte';
    long_des [12] :=
      '             record, rewind, use amp$get_next to get a 100 byte record';
    long_des [13] :=
      '             and close the file.  It also verifies that the record put';
    long_des [14] := '             is the same as the record received.';
    long_des [15] :=
      '    tes3:    This proc opens a file, does two put_partials of 50 byte';
    long_des [16] :=
      '             partial records, and does four get_partials of 25 byte';
    long_des [17] := '             partial records, verifies that they are the'
      CAT ' same, and closes';
    long_des [18] := '             the file.';
    long_des [19] :=
      '    tes4:    This proc opens a file, does four put_next of 100 byte';
    long_des [20] :=
      '             records, a rewind, four get_next of 100 byte records, a';
    long_des [21] := '             close, and it verifies the records.';
    long_des [22] := '    tes5:    This proc opens a file, uses amp$put_next t'
      CAT 'o place several';
    long_des [23] :=
      '             records in a file.  It performs two amp$get_next requests';
    long_des [24] := '             checking for appropriate responses, does a '
      CAT 'rewind, and two';
    long_des [25] :=
      '             more get_nexts, first with wsl < record size, then with';
    long_des [26] := '             wsl > record size.';
    long_des [27] := '    tes6';
    long_des [28] := '    tes7:    This proc opens a file, rewinds it, does so'
      CAT 'me puts, closes';
    long_des [29] := '             the file, opens is a second time, rewinds i'
      CAT 't and does some';
    long_des [30] :=
      '             gets.  It verifies data transmission and closes the file';
    long_des [32] :=
      '    tes8:    This proc is the same as tes5, except is uses amp$file to';
    long_des [33] := '             change record type to amc$undefined first.';
    long_des [34] := '    tes9:    This proc performs an amp$file request, the'
      CAT 'n an amp$get_file_';
    long_des [35] :=
      '             attributes request to see if the data is stored correctly';

    { initialize short descriptions here }

    short_des [1] := 'BAMTEST Short Descriptions:';
    short_des [2] := '  tes1:  open and close';
    short_des [3] := '  tes2:  open, 1 put, 1 rewind, 1 get, close';
    short_des [4] :=
      '  tes3:  open, 2 put partials, rewind, 4 get partials, close';
    short_des [5] := '  tes4:  open, 4 putn, rewind, 4 getn, close';
    short_des [6] :=
      '  tes5:  open, several putn, 2 getn at eoi, rewind, getn wsl < rl,';
    short_des [7] := '         getn wsl > rl';
    short_des [8] := '  tes6:  ';
    short_des [9] := '  tes7:  open, rewind, several putn, close, open, rewind'
      CAT ', several getn, close';
    short_des [10] := '  tes8: same as tes5 with record type u';
    short_des [11] := '  tes9: open, file, get_file_attributes, close';
?? TITLE := 'actual program' ??
?? EJECT ??
    cmod := bac$garbage;
    exit_loop := FALSE;

    clp$scan_parameter_list (parameter_list, bamtest_pdt, stat);
    IF NOT stat.normal THEN
      RETURN;
    IFEND;
    clp$get_value ('INPUT', 1, 1, clc$low, value, stat);
    IF NOT stat.normal THEN
      RETURN;
    IFEND;
    id := 'BAMDVR ';
    amp$open (value.file.local_file_name, amc$record, NIL, fid, status);
    IF NOT status.normal THEN
      amp$tst_status_out (id, status, stat);
    IFEND;

    ptr := #LOC (command);

  /main_loop/
    BEGIN
      REPEAT
        CASE cmod OF
        = bac$yes =
          clp$put_job_output (msg2, stat);
        = bac$no =
          clp$put_job_output (msg3, stat);
        = bac$long =
          FOR i := 1 TO bac$long_msg_limit DO
            clp$put_job_output (long_des [i], stat);
          FOREND;
          clp$put_job_output (msg3, stat);
        = bac$short =
          FOR i := 1 TO bac$short_msg_limit DO
            clp$put_job_output (short_des [i], stat);
          FOREND;
          clp$put_job_output (msg3, stat);
        = bac$tes1 =
          bap$bamtest1;
          clp$put_job_output (msg3, stat);
        = bac$tes2 =
          bap$bamtest2;
          clp$put_job_output (msg3, stat);
        = bac$tes3 =
          bap$bamtest3;
          clp$put_job_output (msg3, stat);
        = bac$tes4 =
          bap$bamtest4;
          clp$put_job_output (msg3, stat);
        = bac$tes5 =
          bap$bamtest5;
          clp$put_job_output (msg3, stat);
        = bac$tes6 =
          bap$bamtest6;
          clp$put_job_output (msg3, stat);
        = bac$tes7 =
          bap$bamtest7;
          clp$put_job_output (msg3, stat);
        = bac$tes8 =
          bap$bamtest8;
          clp$put_job_output (msg3, stat);
        = bac$tes9 =
          bap$bamtest9;
          clp$put_job_output (msg3, stat);
        = bac$tes10 =
          bap$bamtest10;
          clp$put_job_output (msg3, stat);
        = bac$tes11 =
          bap$bamtest11;
          clp$put_job_output (msg3, stat);
        = bac$tes12 =
          bap$bamtest12;
          clp$put_job_output (msg3, stat);
        = bac$tes13 =
          bap$bamtest13;
          clp$put_job_output (msg3, stat);
        = bac$tes14 =
          bap$bamtest14;
          clp$put_job_output (msg3, stat);
        = bac$tes15 =
          bap$bamtest15;
          clp$put_job_output (msg3, stat);
        = bac$tes16 =
          clp$put_job_output (msg3, stat);
        = bac$tes17 =
          clp$put_job_output (msg3, stat);
        = bac$tes18 =
          clp$put_job_output (msg3, stat);
        = bac$tes19 =
          clp$put_job_output (msg3, stat);
        = bac$tes20 =
          bap$bamtest20;
          clp$put_job_output (msg3, stat);
        = bac$tes21 =
          bap$bamtest21;
          clp$put_job_output (msg3, stat);
        = bac$tes22 =
          bap$bamtest22;
          clp$put_job_output (msg3, stat);
        = bac$tes23 =
          bap$bamtest23;
          clp$put_job_output (msg3, stat);
        = bac$tes24 =
          bap$bamtest24;
          clp$put_job_output (msg3, stat);
        = bac$tes25 =
          bap$bamtest25;
          clp$put_job_output (msg3, stat);
        = bac$tes26 =
          bap$bamtest26;
          clp$put_job_output (msg3, stat);
        = bac$tes27 =
          bap$bamtest27;
          clp$put_job_output (msg3, stat);
        = bac$tes28 =
          bap$bamtest28;
          clp$put_job_output (msg3, stat);
        = bac$tes29 =
          bap$bamtest29;
          clp$put_job_output (msg3, stat);
        = bac$tes30 =
          bap$bamtest30;
          clp$put_job_output (msg3, stat);
        = bac$tes31 =
          bap$bamtest31;
          clp$put_job_output (msg3, stat);
        = bac$tes32 =
          bap$bamtest32;
          clp$put_job_output (msg3, stat);
        = bac$tes33 =
          bap$bamtest33;
          clp$put_job_output (msg3, stat);
        = bac$tes34 =
          bap$bamtest34;
          clp$put_job_output (msg3, stat);
        = bac$tes35 =
          bap$bamtest35;
          clp$put_job_output (msg3, stat);
        = bac$tes36 =
          bap$bamtest36;
          clp$put_job_output (msg3, stat);
        = bac$tes37 =
          bap$bamtest37;
          clp$put_job_output (msg3, stat);
        = bac$tes38 =
          bap$bamtest38;
          clp$put_job_output (msg3, stat);
        = bac$tes39 =
          bap$bamtest39;
          clp$put_job_output (msg3, stat);
        = bac$tes40 =
          clp$put_job_output (msg3, stat);
        = bac$tes41 =
          bap$bamtest41;
          clp$put_job_output (msg3, stat);
        = bac$tes42 =
          bap$bamtest42;
          clp$put_job_output (msg3, stat);
        = bac$tes43 =
          clp$put_job_output (msg3, stat);
        = bac$tes44 =
          clp$put_job_output (msg3, stat);
        = bac$tes45 =
          clp$put_job_output (msg3, stat);
        = bac$tes46 =
          clp$put_job_output (msg3, stat);
        = bac$tes47 =
          clp$put_job_output (msg3, stat);
        = bac$tes48 =
          clp$put_job_output (msg3, stat);
        = bac$tes49 =
          clp$put_job_output (msg3, stat);
        = bac$tes50 =
          clp$put_job_output (msg3, stat);
        = bac$garbage =
          clp$put_job_output (msg1, stat);
        = bac$bamstop =
          amp$close (fid, status);
          amp$tst_status_out (id, status, stat);
          exit_loop := TRUE;
          EXIT /main_loop/;
        ELSE
          clp$put_job_output (msg3, stat);
        CASEND;
        command := bac$null_command;
        amp$get_next (fid, #LOC (command), 70, tc, ba, fp, status);
        amp$tst_getn_out (id, fid, 70, 0, tc, ba, fp, stat);
        amp$tst_status_out (id, status, stat);
        IF NOT status.normal THEN
          EXIT /main_loop/;
        IFEND;
        cmod := bac$garbage;
        clp$validate_name (command, validated_name, valid_name);
        IF NOT valid_name THEN
          osp$set_status_abnormal (amc$access_method_id, cle$improper_name,
                command, status);
          RETURN;
        IFEND;

      /for_loop/
        FOR input_ord := bac$yes TO PRED (bac$garbage) DO
          IF validated_name = input [input_ord] THEN
            cmod := input_ord;
            EXIT /for_loop/;
          IFEND;
        FOREND /for_loop/;
    UNTIL exit_loop;
  END /main_loop/;
PROCEND bamtest;

MODEND bamtest_driver;
*DECK DECK=VKM$VIKING_CONTROLWARE EXPAND=FALSE
          IDENT     VIKKEY,0#D000
          MACHINE   Z80
          TITLE     KEY UTILITY CONTROLWARE.
          LIST      -R
          SPACE  3
**        Resident RAM addresses and equates.


 ALARM    EQU    #0033       RING THE BELL
 ATRIB    EQU    #E0A9       ATTRIBUTE
 BLDADD   EQU    #003F       RESIDENT ADDRESS ROUTINE
 BDISPN   EQU    #0039       DISPLAY B
 RBDSPN   EQU    #B384       DISPLAY B IN RAM PACK
 CNTRL    EQU    #E0B5       RESIDENT CONTROL FLAG
 DLMENA   EQU    #E0B9       DELIMITER ENABLED
 DSTRNG   EQU    #0063       DELIMITER ENABLED
 FLAG2    EQU    #E0BF       SCROLL DIRECTION FLAG
 KEYT     EQU    #D7E0       KEY TABLE
 LASTLN   EQU    #E0CD       LINES ON SCREEN
 LNCNT    EQU    #E0D1       LINE ON SCREEN
 MNTOR    EQU    #00A5       RESIDENT MONITOR ROUTINE
 RMNTR    EQU    #BAD8       RESIDENT MONITOR ROUTINE IN RAM PACK
 OBYTE2   EQU    #E047       TERMINAL PARAMS
 POPR     EQU    #D8D6       FLAG IN KEYT FOR PUSH ROUTINE
 RMID     EQU    #AF00       TEST WORD FOR RAM PACK IN USE
 SCROLL   EQU    #0081       RESIDENT SCROLL ROUTINE
 SHIFT    EQU    #E0E6       RESIDENT SHIFT FLAG
 SENDB    EQU    #0087       SEND CONTENTS OF B TO HOST
 RSNDB    EQU    #BCC8       SEND CONTENTS OF B TO HOST IN RAM PAK
          SPACE  3
**        Controlware Equates.


 LOHS     EQU    #61         LINES ON HIDDEN SCREENS (100)
 BIKT     EQU    #F3         BYTES IN KEY TABLE
 BTPL     EQU    132*2       BYTES PER LINE
 SCRT     EQU    #4000       MEMORY DISPLAY TABLE
 MEMS     EQU    #40F2       MEMORY SCREEN
          SPACE  3
          LIST   -L
          PURGMAC SET
 SET      MACRO              SET INSTRUCTION SET  2,(HL)
          DATA   #CB,#D6
          ENDM
          LIST   L
          TITLE  PUSH AND POP KEY DEFINITIONS.
          ORG    #D000

**        PKD - PUSH KEY DEFINITIONS.


 PKD      LD     DE,SAVA     DE ==> KEY TABLE SAVE BUFFER
          LD     BC,BIKT     BC = BYTES TO MOVE
          LD     HL,KEYT     HL ==> KEY TABLE
          LDIR               COPY TABLE
          LD     A,(OBYTE2)  SAVE OBYTE2
          LD     (OBS),A
          LD     A,(DLMENA)  SAVE DELIMITER FLAG
          LD     (DLS),A
 SUT      SPACE  3
**        SUT - SET UP TERMINAL


 SUT      XOR    A           CLEAR DELIMITER ENABLED
          LD     (DLMENA),A
          LD     BC,BIKT-1   CLEAR KEY TABLE
          LD     HL,KEYT     HL ==> BEGINNING OF KEY TABLE
          LD     DE,KEYT+1   DE ==> NEXT ADDRESS
          LD     (HL),#30    UNDEFINED
          LDIR
          RET                RETURN
 PKS      SPACE  3
**        PKS - POP KEY DEFINITIONS.


 PKS      LD     HL,SAVA     HL ==> KEY SAVE AREA
          LD     BC,BIKT     BC = BYTES TO MOVE
          LD     DE,KEYT     DE ==> KEY TABLE ADDRESS
          LDIR
          LD     A,(OBS)     RESTORE OBYTE2
          LD     (OBYTE2),A
          LD     A,(DLS)     RESTORE DELIMITER
          LD     (DLMENA),A
          RET
          SPACE  4
**        SAVE AREA FOR PUSH AND POP ROUTINES.


 SAVA     BSS    BIKT        SAVE AREA FOR KEY TABLE
 OBS      BSS    1           SAVE AREA FOR OBYTE
 DLS      BSS    1           SAVE AREA FOR DELIMITER FLAG
 DFLS     BSS    2           SAVE AREA FOR LENGTH OF KEY DEFS
          TITLE  MARK KEY ROUTINES
          ORG    #D138

**        MUL - MARK OR UNMARK LINE.


 MUL      CALL   UML         CLEAR CURRENTLY INVERSE
          LD     A,(CNTRL)   TEST IF CONTROL IS ACTIVE
          AND    A
          JR     NZ,MAL      IF SO

          LD     A,(SHIFT)   TEST FOR SHIFT ACTIVE
          AND    A
          JR     Z,MCL       IF NOT

 CLN      LD     A,#FF       CLEAR LINE NUMBER
          LD     (LNN),A
          RET
 UML      SPACE  3
**        UML - UNMARK LINE


 UML      CALL   TST         TEST LINE NUMBER
          RET    M           IF NONE SET
          CALL   BAS         BUILD ADDRESS TO SCREEN
          DEC    A
          LD     (LNN),A     SAVE NEXT LINE TO LOOK AT
 UML1     INC    HL
          RES    2,(HL)      CLEAR INVERSE FROM CHARACTER
          INC    HL
          DEC    D           DEC COUNTER
          JR     NZ,UML1     UNTIL DONE WITH LINE
          RET
 MCL      SPACE  3
**        MCL - MARK A COMMAND LINE


 MCL      CALL   TST         TEST IF ANY LINE WAS MARKED
          JP     P,MCL1      IF SO

          LD     A,#1D       SET TO BOTTOM OF SCREEN
 MCL1     LD     B,A         PLACE LINE # IN B
 MCL2     CALL   BAS
          XOR    A           A IS A FLAG FOR MODIFIED FOUND
 MCL3     INC    HL          HL ==> ATTRIBUTE BYTE
          BIT    5,(HL)
          JR     Z,MCL4      IF NOT MODIFIED

          SET    2,(HL)      SET INVERSE BIT
          INC    A           SET MODIFIED FOUND
 MCL4     INC    HL          ADVANCE TO NEXT CHARACTER
          DEC    D           DEC BYTE COUNT
          JR     NZ,MCL3     IF NOT DONE WITH LINE

          AND    A
          JR     NZ,MCL5     IF FOUND THEN DONE

          DEC    B           GET SCREEN LINE NUMBER
          LD     A,B
          JP     P,MCL2      IF STILL GOOD

 MCL5     LD     A,B         GET LINE ACTED UPON
          LD     (LNN),A     SAVE LINE NUMBER
          RET
 MAL      SPACE  3
**        MAL - MARK ANY LINE.


 MAL      CALL   TST         TEST IF ANY LINE WAS MARKED
          JP     P,MAL1      IF SO

          LD     A,#1D       ELSE SET TO BOTTOM OF SCREEN
 MAL1     LD     B,A         SAVE LINE TO CHECK
          LD     (LNN),A
          RET    M           IF OFF TOP OF SCREEN

          CALL   BAS         GET ADDRESS TO SCREEN
          CALL   BSA         GO TO END OF LINE
 MAL2     DEC    HL          BACK UP TO CHARACTER
          CP     (HL)        TEST FOR BLANK
          JR     NZ,MAL3     IF SO MARK THE REST OF THE LINE

          DEC    HL
          DEC    D
          JR     NZ,MAL2     UNTIL DONE CHECKING LINE

          LD     A,B
          DEC    A           GO UP ONE LINE
          JR     MAL1        AND TRY IT

 MAL3     INC    HL          ADVANCE TO ATTRIBUTE
 MAL3.1   SET    2,(HL)      SET INVERSE BIT
          DEC    HL          BACK UP TO PREVIOUS ATTRIBUTE
          DEC    HL
          DEC    D           DEC BYTE COUNT
          JR     NZ,MAL3.1   IF NOT DONE WITH LINE
          RET
          TITLE  COPY KEY ROUTINES
**        CMC - COPY MARKED LINE
*
*         INVERSE VIDEO ON MARKED LINE IS FLAG

 CML      LD     A,(SHIFT)   TEST FOR SHIFT ACTIVE
          AND    A
          JR     NZ,CEL      IF SO COPY REST OF MARKED LINE

          LD     A,(CNTRL)   TEST IF CONTROL IS ACTIVE
          AND    A
          JR     NZ,SMC      IF SO SKIP A CHAR ON MARKED LINE

 CMC      CALL   TST         GET LINE NUMBER
          RET    M           IF NONE MARKED

          CALL   BAS         GET ADDRESS TO SCREEN
 CMC1     INC    HL          GET ATTRIBUTE
          BIT    2,(HL)      TEST FOR INVERSE
          JR     NZ,CMC2     IF SET

          INC    HL          MOVE TO NEXT CHARACTER
          DEC    D           DEC COUNTER
          JR     NZ,CMC1     UNTIL DONE WITH LINE
          JP     CLN         CLEAR LINE FLAG IF LAST COPIED

 CMC2     RES    2,(HL)      CLEAR INVERSE
          DEC    HL          BACK UP TO CHARACTER
          LD     B,(HL)      GET THE CHAR TO MOVE INTO B
          PUSH   DE
          LD     A,(ATRIB)   GET CURRENT ATTRIBUTE
          PUSH   AF
          OR     #20         SET MODIFIED
          LD     (ATRIB),A
          PUSH   BC
          CALL   BDISPN      DISPLAY THE CHARACTER
 ALTBD1   EQU    *-2
          POP    BC
          POP    AF
          LD     (ATRIB),A   RESTORE ATTRIBUTE
          CALL   SENDB       SEND THE CHAR TO THE HOST
 ALTSB1   EQU    *-2
          POP    DE
          DEC    D
          JP     Z,CLN       IF END OF LINE
          RET
 CEL      SPACE  3,8
**        CEL - COPY ENTIRE MARKED LINE


 CEL      CALL   CMC         COPY A LETTER
          CALL   TST
          JP     P,CEL       UNTIL NOTHING MARKED ON LINE
          RET
 SMC      SPACE  3
**        SMC - SKIP A MARKED CHARACTER.


 SMC      CALL   TST         GET LINE NUMBER
          RET    M           IF NONE

          CALL   BAS         GET SCREEN ADDRESS
 SMC1     INC    HL          GET ATTRIBUTE
          BIT    2,(HL)      TEST FOR INVERSE
          JR     Z,SMC2      IF NOT SET

          RES    2,(HL)      CLEAR INVERSE
          RET

 SMC2     INC    HL
          DEC    D           DEC COUNTER
          JP     Z,CLN       UNTIL DONE WITH LINE
          JR     SMC1
          TITLE  SUPPORT ROUTINES
**        NXT - ROUTINE FOR THE CARRIAGE RETURN.


 NXT      CALL   UML         CLEAR THE CURRENTLY MARKED LINE IF ANY
          LD     B,#0D
          CALL   SENDB       SEND A CARRIAGE RETURN
 ALTSB2   EQU    *-2
          CALL   BDISPN      DISPLAY A CARRIAGE RETURN
 ALTBD2   EQU    *-2
          RET
 BAS      SPACE  3
**        BAS - BUILD ADDRESS.
*
*         HL <=== ADDRESS TO FIRST CHAR ON SCREEN
*         D  <=== COUNTER FOR CHARS PER LINE


 BAS      LD     L,A         SETUP HL FOR CALL
          LD     H,#E0       HL ==> LINE OF INTEREST IN TABLE
          CALL   BLDADD      DE POINTS TO SCREEN ADDRESS
          EX     DE,HL       HL ==> SCREEN ADDRESS
          LD     D,#84       D IS BYTE COUNTER FOR LINE
          RET
 BSA      SPACE  3
**        BSA - BUILD SPECIAL ADDRESS.


 BSA      PUSH   DE          SAVE BYTE COUNTER
          LD     DE,263
          ADC    HL,DE       HL ==> ONE BYTE BEYOND END OF LINE
          POP    DE          RESTORE BYTE COUNTER
          LD     A,#20       A GETS A BLANK
          RET
 TST      SPACE  3
**        TST - TEST LINE NUMBER
*
*         SETS STATUS FLAGS

 TST      LD     A,(LNN)     GET LINE NUMBER
          AND    A           SET FLAGS
          RET
          SPACE  3
**        SAVE AREA FOR MARK AND COPY ROUTINES.


 LNN      CON    #FF         LINE NUMBER

          ERRNG  #D235-*
          TITLE  SCREEN MONITOR ROUTINE
          ORG    #D235

**        PRE - PRESET HIDDEN SCREEN.
*

 PHS      LD     A,#1C       SELECT HIDDEN BANKS
          CALL   CFR         CHECK FOR RAM PACK
          LD     A,LOHS+1    LINES PER TABLE
          LD     DE,SCRT     DE = ADDRESS OF SCREEN TABLE
          LD     HL,MEMS     HL = ADRRES OF MEMORY SCREEN
          LD     BC,BTPL     BC = TABLE INCREMENT PER LINE
 PHS1     EX     DE,HL
          LD     (HL),E      MOVE LOWER ADDRESS BYTE
          INC    HL
          LD     (HL),D      MOVE UPPER ADDRESS BYTE
          INC    HL
          EX     DE,HL
          ADC    HL,BC       ADD NEXT ADDRESS
          DEC    A
          JR     NZ,PHS1

          LD     DE,MEMS+1   DE ==> SECOND MEMORY POSITION
          LD     HL,MEMS     HL ==> FIST MEMORY POSITION
          LD     BC,BTPL*LOHS  BC = BYTES TO MOVE
          LD     (HL),#20    WITH BLANK,MODIFIED
          LDIR               CLEAR MEMORY SCREEN

 SCR      LD     HL,#E000    GET ADDRESS OF TOP VISIBLE LINE
          CALL   BLDADD
          LD     HL,PTLA     HL = PREVIOUS TOP LINE ADDRESS
          LD     A,E
          CP     (HL)
          JR     Z,SCR1      IF NOT CHANGED

          EX     DE,HL       SAVE NEW TOP ADDRESS
          LD     (PTLA),HL
          CALL   SBM         SAVE OLD TOP LINE
          LD     HL,(PTLA)   HL ==> NEW TOP LINE OF SCREEN
          LD     DE,BUFFER   DE ==> BUFFER
          LD     BC,BTPL     BE = BYTES TO MOVE
          LDIR               SAVE IT IN BUFFER
 SCR1     CALL   MNTOR       RESIDENT MONITOR
 ALTMT    EQU    *-2
          LD     A,(POPR)    GET POP ROUTINE INDICATOR
          AND    A           SET BITS
          JR     NZ,SCR      RETEST TOP LINE
          JP     ALARM       IF ZERO RETURN
 SBM      SPACE  3
**        SBM - SCROLL BACKUP MEMORY
*

 SBM      LD     A,(NXTMLN)  NUMBER OF LINES USED
          CP     LOHS        NUMBER OF HIDDEN LINES
          JR     Z,SBM1      IF LAST LINE

          CALL   GVL         GET LINE TO BE SCRLL OFF VIS
          LD     A,(NXTMLN)
          INC    A           INCREMENT WHERE NEXT HIDDEN
          LD     (NXTMLN),A
          RET

 SBM1     LD     HL,SCRT
          LD     D,H
          LD     E,L         DE ==> FIRST TABLE ENTRY
          LD     C,(HL)
          INC    HL
          LD     B,(HL)
          PUSH   BC          SAVE CONTENTS OF FIRST TABLE ENTRY
          INC    HL          HL ==> SECOND TABLE ENTRY
          LD     BC,LOHS*2   BE = NUMBER OF ENTRIES TO MOVE
          LDIR
          POP    HL
          LD     A,L
          LD     (DE),A
          INC    DE
          LD     A,H
          LD     (DE),A
          EX     DE,HL
          JR     GVL1        MOVE LINE
 GVL      SPACE  3
**        GVL - GET VISIBLE LINE ABOUT TO BE SCROLLED OFF


 GVL      RLCA               DOUBLE FOR TWO BYTE ADDRESSES
          LD     L,A
          LD     H,#40       DE ==> ADDRESS IN HIDDEN SCREEN
          LD     E,(HL)
          INC    HL
          LD     D,(HL)
 GVL1     LD     HL,BUFFER   HL ==> BUFFER
          LD     BC,BTPL     BYTES TO MOVE
          LDIR
          RET
          TITLE  SCROLL SCREEN FORWARD
**        FWD - SCROLL FORWARDS.
*
*         WHEN ACTIVATED BY A KEY THIS ROUTINE WILL SCROLL FORWARDS.


 FWD      LD     A,(NXTMLN)  GET LAST LINE FILLED IN HIDDEN
          CP     LOHS
          RET    Z

          INC    A
          RLCA               DOUBLE FOR TWO BYTE ADDRESSES
          LD     L,A
          LD     H,#40       (HL) = ADDRESS IN HIDDEN SCREEN TABLE
          LD     E,(HL)
          INC    HL
          LD     D,(HL)
          PUSH   DE          SAVE ADDRESS
          LD     HL,#E000    GET TOP LINE OFF SCREEN
          CALL   BLDADD
          EX     DE,HL       HL ==> TOP LINE
          LD     DE,BUFFER   DE ==> BUFFER
          LD     BC,BTPL     BYTES TO MOVE
          LDIR
          CALL   SCROLL      SCROLL VISIBLE
          LD     HL,#E01D    PUT BOTTOM LINE ON SCREEN
          CALL   BLDADD      DE ==> BOTTOM LINE ON SCREEN
          POP    HL          HL ==> ORIGINAL ADDRESS
          PUSH   HL          SAVE IT AGAIN
          LD     BC,BTPL     BYTES TO MOVE
          LDIR
          POP    DE          PUT BUFFER INTO HIDDEN
          CALL   GVL1
          LD     HL,#E000    GET ADDRESS OF TOP VISIBLE LINE
          CALL   BLDADD
          EX     DE,HL       SAVE NEW TOP ADDRESS
          LD     (PTLA),HL
          LD     A,(NXTMLN)  GET LAST LINE FILLED IN HIDDEN
          INC    A
          LD     (NXTMLN),A
          RET
          TITLE  SCROLL SCREEN BACKWARD
**        BKW - SCROLL BACKWARD.
*
*         WHEN ACTIVATED BY A KEY THIS ROUTINE WILL SCROLL BACKWARDS.


 BKW      LD     A,(NXTMLN)  GET LAST LINE FILLED IN HIDDEN
          AND    A
          JP     Z,ALARM     RETURN IF AT TOP

          RLCA               DOUBLE FOR TWO BYTE ADDRESSES
          LD     L,A
          LD     H,#40       (HL) = ADDRESS IN HIDDEN SCREEN TABLE
          LD     E,(HL)
          INC    HL
          LD     D,(HL)
          PUSH   DE          SAVE ADDRESS
          LD     HL,#E01D    GET BOTTOM LINE OFF SCREEN
          CALL   BLDADD
          EX     DE,HL       HL ==> BOTTOM LINE ON SCREEN
          LD     DE,BUFFER   DE ==> BUFFER
          LD     BC,BTPL     BE = BYTES TO MOVE
          LDIR               SAVE IN BUFFER
          LD     A,(FLAG2)   SAVE OLD FLAG
          PUSH   AF
          LD     A,2         SET TO SCROLL DOWN
          LD     (FLAG2),A
          CALL   SCROLL      SCROLL VISIBLE
          POP    AF          RESET TO SCROLL UP
          LD     (FLAG2),A
          LD     HL,#E000    PUT TOP LINE ON SCREEN
          CALL   BLDADD
          EX     DE,HL       SAVE NEW TOP ADDRESS
          LD     (PTLA),HL
          EX     DE,HL       DE ==> TOP LINE ON SCREEN
          POP    HL          HL ==> ORIGINAL ADDRESS
          PUSH   HL          SAVE IT AGAIN
          LD     BC,BTPL     BE = BYTES TO MOVE
          LDIR               MOVE FROM HIDDEN TO VISIBLE
          POP    DE          MOVE BUFFER TO HIDDEN
          LD     A,(NXTMLN)  RESET LAST LINE FILLED IN HIDDEN
          DEC    A
          LD     (NXTMLN),A
          JP     GVL1        RETURN
          SPACE  3
**        SAVE AREA FOR SCROLLING ROUTINES.


 PTLA     CON    #10,#E1     PREVIOUS TOP LINE ADDRESS
 NXTMLN   CON    0           NEXT MEMORY LINE TO BE USED
 BUFFER   BSS    BTPL        PLACE TO SAVE OLD TOP LINE
          ORG    BUFFER
          SPACE  4,10
**        CFR - CHECK FOR RAM PACK.
*
*         ENTRY  (A) = BANKS TO SELECT.
*
*         EXIT   BANKS SELECTED AND CALL ADDRESSES CHANGED IF RAM
*                PACK IS INSTALLED.


 CFR      OUT    (#70),A     DO BANK SELECT
          LD     A,(RMID)    GET ADDRESS OF RAM FLAG
          CP     #C3
          JR     NZ,CFR1     IF NOT THE SAME
          LD     HL,RBDSPN   GET NEW BDISPLAY ADDRESS
          LD     (ALTBD1),HL
          LD     (ALTBD2),HL
          LD     HL,RSNDB    GET NEW SENDB ADDRESS
          LD     (ALTSB1),HL
          LD     (ALTSB2),HL
          LD     HL,RMNTR    GET NEW MONITOR ADDRESS
          LD     (ALTMT),HL
          LD     HL,CFRM     OUTPUT RAM LIGHT
 CFR0     JP     DSTRNG      RETURN

 CFR1     LD     HL,CFRN     OUTPUT NO RAM LIGHT
          JR     CFR0

 CFRM     CON    #1E,#12,#65,#32,#FF
 CFRN     CON    #1E,#12,#65,#31,#FF
          END
/EOR
*DECK DECK=VM5B EXPAND=TRUE
          IDENT  VM5B
          CIPPU

          TITLE  VM5B - MAP-V PP HARDWARE DRIVER
          COMMENT *SMD* LVL=01
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1992
 VM5B     SPACE  4,20
*****     VM5B - MAP-V PP HARDWARE DRIVER.
*
*         L. J. HAUCH        85/01/28.
          SPACE  4,10
***       VM5B IS A HARDWARE DRIVER PP PROGRAM WHICH IS PART OF THE
*         MAP-V SYSTEM SOFTWARE EXECUTIVE VERSION 1 (MVX V1.0).
*         ITS MAJOR FUNCTION IS MONITORING THE MAP-V HARDWARE.
*
*         MAP-V PRODUCT NUMBERS (9/84)
*
*                65354-X  MAP-V BASE PRODUCT
*
*                  - ST-100 C
*                  - ONE CHANNEL ADAPTER
*                  - *X* ALLOWS MULTIPLE BASE PRODUCTS
*                        - 12 BIT CHANNEL BASE PRODUCT
*                        - 16 BIT CHANNEL BASE PRODUCT
*
*                65355-X  MAP-V OPTIONS
*
*                  OPTIONS INCLUDE
*
*                    - MAINTENANCE TERMINAL
*                    - MAIN MEMORY EXPANSION
*                    - CHANNEL ADAPTERS
*                    - CENTRAL MEMORY INTERFACE (CMI)
*                    - CACHE MEMORY EXPANSION
*                    - PERIPHERAL ADAPTERS
*                    - CABINETS
*
          SPACE  4,10
*         TEMPORARY EQUATES.

 HDW12BC  EQU    1           MAP-V CHANNEL INTERFACE IS 12/60 HARDWARE
 ILRRP    EQU    1           INDIRECT LIST ON REQUEST-OR RESPONSE PKTS
 F16BD    EQU    1           FLAG 16 BIT DATA I/O

 MTRACEI  EQU    3           MAX LENGTH OF HARDWARE FUNCTION TRACE
 EFLAG1   EQU    0           =1 CODE ON FOR 1XX ERRORS (TIMEOUTS)
 EFLAG2   EQU    0           =1 CODE ON FOR 2XX ERRORS (PP INT TABLE)
 EFLAG3   EQU    0           =1 CODE ON FOR 3XX ERRORS (UIT)
 EFLAG4   EQU    0           =1 CODE ON FOR 4XX ERRORS (REQUEST HEADER)
 EFLAG5   EQU    1           =1 CODE ON FOR 5XX ERRORS (COMMAND)
 EFLAG0   EQU    EFLAG1+EFLAG2+EFLAG3+EFLAG4+EFLAG5  0 IF NO ERROR ON
          SPACE  4,20
          LIST   -$          TURN DESIGN OVERVIEW LIST ON/OFF
          TITLE  VM5B - MAP-V PPU DESIGN OVERVIEW
**                                                   FEBRUARY 05, 1985
**
** MAP-V PPU DESIGN OVERVIEW.
**
**
** THE MAP-V HARDWARE IS A 100-MEGAFLOP ARRAY PROCESSOR BUILT BY
** STAR TECHNOLOGIES, INC (STI).  IT CONSISTS OF MULTIPLE PROCESSORS
** AND MEMORIES INTERCONNECTED TO ALLOW INDEPENDENT DATA FLOW AND
** ARITHEMETIC PROCESSING.  IT MAY BE CONNECTED TO MULTIPLE HOST
** COMPUTERS FROM VARIOUS VENDORS.
**
** HERE IT IS ASSUMED THAT IT IS CONNECTED TO A CYBER-8XX WHICH IS
** IS RUNNING THE NOS/VE OPERATING SYSTEM.
**
** THIS CONNECTION MAY BE VIA:
**
**  (1) CYBER-8XX 12-BIT CHANNEL AND A CENTRAL MEMORY INTERFACE (CMI)
**      CONNECTED TO PORT 3 OF THE CYBER-8XX MAINFRAME
**  (2) CYBER-8XX 12-BIT CHANNEL ONLY - (STANDARD CHANNEL)
**  (3) CYBER-8XX 16-BIT CHANNEL ONLY - FUTURE - (INTELLIGENT
**      PERIPHERAL INTERFACE)
**
** THE CMI INTERFACE PROVIDES FOR HIGH SPEED
** DATA TRANSFERS (UP TO 100 MBYES/SEC) BETWEEN THE MAP-V
** MAIN-MEMORY AND THE CYBER-8XX CENTRAL MEMORY.  THE CYBER-8XX
** 12-BIT CHANNEL ONLY HARDWARE WILL USE THE 12-BIT STANDARD CHANNEL
** UTILIZING BOTH THE USUAL 12-BIT I/O AND 12-BIT PACKED I/O.  A FUTURE
** CHANNEL ONLY HARDWARE WILL USE THE 16-BIT INTELLIGENT PERIPHERAL
** INTERFACE (IPI).  THIS HARDWARE WILL BE SUPPORTED BY SOFTWARE
** IN A LATER RELEASE, BUT ITS IMPLICATIONS ARE CONSIDERED IN THIS
** DESIGN.

** INITIALLY, ONLY THE CMI HARDWARE WILL BE SUPPORTED.  THE 12-BIT
** STANDARD CHANNEL WILL FOLLOW WITH SOME DATA FORMAT RESTRICTIONS.
** BOTH IMPLEMENTATIONS UTILIZE THE 12-BIT STANDARD CHANNEL I/O
** TO EXCHANGE CONTROL PACKETS.

** THESE CONTROL PACKETS NOT ONLY PROVIDE DIRECTION TO THE MAP-V
** BUT ALSO, IN THE CMI CASE, CONTAIN CMI ADDESSING INFORMATION.
** THE CHANNEL INTERFACE HARDWARE USED FOR THIS SOFTWARE
** UTILIZES A 12-BIT CHANNEL INTERFACE WHICH WAS DEVELOPED
** FOR THE NOS 12/60-BIT SIDE OF CYBER-8XX.  ON THIS CHANNEL
** INTERFACE, THE UPPER 28 BITS OF SOME 60-BIT TRANSFERS ARE DIS-
** CARDED BY THE INTERFACE.  INPUT/OUTPUT IN THIS CASE IS IN
** 12-BIT BYTES.  TO UTILIZE THIS HARDWARE ON THE VE SYSTEM, THE PPU
** REFORMATS INFORMATION WHICH PASSES OVER THE CHANNEL TO CONFORM
** WITH THE HARDWARE REQUIREMENTS.  IN THE 12-BIT STANDARD CHANNEL
** ONLY CASE, USER DATA WILL BE RESTRICTED TO 2-32 BIT WORDS IN ONE
** 64-BIT WORD.  THIS DATA WILL BE TRANSFERED ACROSS THE CHANNEL
** INTERFACE USING THE 12-BIT PACKED CHANNEL INSTRUCTIONS AND BY THE
** SELECTION OF 60-BIT PACKED 32-BIT DATA FORMAT AT THE INTERFACE.
** WITH THIS SELECTION, THE INTERFACE TRANSFORMS EIGHT 60-BIT WORDS
** INTO FIFTEEN 32-BIT WORDS OF THE MAP-V MEMORY.  THIS REQUIREMENT
** WILL MAKE IT NECESSARY TO ADD ADDITIONAL RESTRICTIONS TO
** MINIMIZE END CASES.
** THIS OPERATION IS TO BE TRANSPARENT TO USER.
**
**
**
** IT IS EXPECTED THAT WHEN THE IPI
** CHANNEL BECOMES AVAILABLE, IT WILL REPLACE THE 12/60-BIT
** INTERFACE, MAKING REFORMATING UNNECESSARY.
**
**
** THE MAP-V PPU UTILIZES THE CYBER-180 CENTRAL PROCESSOR
** UNIT TO INPUT/OUTPUT UNIT SOFTWARE INTERFACE OF THE NOS/VE
** OPERATING SYSTEM.  THIS INTERFACE DEFINES TABLES
** THAT RESIDE IN CENTRAL MEMORY AND THE RULES FOR
** ACCESSING THESE TABLES.
**
** PERIPHERAL REQUEST(S) ARE DIRECTED BY THE OPERATING SYSTEM TO EITHER
** A SPECIFIC PP OR A SPECIFIC UNIT DRIVEN BY A PP, SUCH AS A MAP-V.
** A REQUEST TO A PP TYPICALLY DESCRIBES A SYSTEM CONTROL OPERATION
** SUCH AS IDLE OR RESUME.  A REQUEST TO A PERIPHERAL UNIT TYPICALLY
** DESCRIBES A HARDWARE FUNCTION, A HARDWARE STATUS REQUEST
** AN INPUT/OUTPUT OPERATION OR A SERIES OF INPUT/OUTPUT
** OPERATIONS.  IN THE CASE OF MAP-V, OUTPUT OPERATIONS TAKE THE
** FORM OF (1) MAP-V PROTOCOL DATA (REQUEST PACKETS) OR (2) DATA
** LOADED INTO THE MAIN-MEMORY OF THE MAP-V FROM CYBER-180 CENTRAL
** MEMORY, WHILE INPUT OPERATIONS TAKE THE FORM OF (1) MAP-V STATUS
** DATA (RESPONSE PACKETS) OR (2) DATA UNLOADED FROM MAP-V MAIN-MEMORY
** OR PUBLIC-MEMORY (ENGINEERING FILE, ACCOUNTING DATA, ETC.)
** TO CYBER-180 CENTRAL MEMORY.  WHEN DATA IS TRANSFERED VIA THE CMI,
** THE REAL MEMORY WORD ADDRESSES AND WORD COUNTS ARE INCLUDED
** IN THE REQUEST PACKET.
**
**
** NOS/VE DEFINED COMMAND CODES (CPU TO PP) RECOQNIZED BY MAP-V PP.
**
**   PHYSICAL I/O COMMANDS.
**
**     20(16) - FUNCTION
**
**     21(16) - OUTPUT 8-BIT PARAMETERS
**
**     23(16) - OUTPUT 8-BIT DATA
**
**     25(16) - INPUT 8-BIT DATA/PARAMETERS
**
**   LOGICAL I/O COMMANDS.
**
**     40(16) - READ BYTES
**
**     50(16) - WRITE BYTES
**
**     60(16) - READ STATUS
**
**   PP COMMANDS.
**
**     00(16) - ACKNOWLEDGE
**
**     01(16) - STOP UNIT
**
**     03(16) - SELECT CONTROLLER
**
**     04(16) - IDLE
**
**     05(16) - RESUME
**
**     06(16) - EXECUTE OVERLAY
**
**     07(16) - START READY SCAN
**
**     08(16) - STOP READY SCAN
**
**     09(16) - SELECT PP MEMORY ADDRESS
**
**     0A(16) - COPY PP MEMORY
**
**     10(16) - ENABLE UNIT
**
**     11(16) - DISABLE UNIT
**
**     17(16) - MASTER CLEAR CONTROLLER
**
**
**
**   FUNCTION - 20(16).
**
**     THE STANDARD NOS/VE INTERPRETATION OF THE ADDRESS AND LENGTH
**     FIELDS OF THIS COMMAND IS DIFFERENT FROM THE INTERPRETATION OF
**     OTHER NOS/VE COMMANDS.  FOR THE FUNCTION COMMAND, THE ADDRESS
**     FIELD CONTAINS A DEVICE DEPENDENT FUNCTION CODE.  THE
**     LENGTH FIELD CONTAINS A BINARY VALUE SPECIFYING THE NUMBER
**     OF BIT POSITIONS OCCUPIED BY FUNCTION CODE.
**
**     FOR THE MAP-V 12/60-BIT CHANNEL INTERFACE IMPLEMENTATION, IT IS
**     ASSUMED TO BE A 12-BIT RIGHT JUSTIFIED CODE.  THE LENGTH
**     FIELD IS SET TO 12-DECIMAL.
**
**     TYPICAL MAP-V HARDWARE FUNCTIONS EXECUTED IN THIS MANNER ARE:
**
**       0100(8) - MASTER CLEAR INTERFACE.
**       0277(8) - CLEAR SEQUENCER.
**
**       TO ACCOMODATE THIS, THE NOS/VE UNIT REQUEST CONSISTS OF
**       ONE COMMAND.
**
**       --  20 80  000C  0000 0YYY(16)
**
**       (1) 20(16)    = (C) COMMAND CODE - FUNCTION
**           80(16)    = (F) FLAGS - STORE RESPONSE
**           000C(16)  = (LENGTH) FUNCTION CODE BIT LENGTH
**           0000 0YYY = FUNCTION CODE
**
**     ANOTHER IMPLEMENTATION OF THE FUNCTION IS WITHIN A
**     USER OR SUBSYSTEM DATA I/O SEQUENCE ON THE CHANNEL.  HERE
**     THE 12-BIT FUNCTION CODE DEFINES WHETHER I/O IS WITH
**     MAIN MEMORY OR IN SPECIAL CASES, PUBLIC MEMORY.  IN ADDITION,
**     THE LEFT MOST HEXIDECMAL DIGIT OF THE FUNCTION CODE IS USED
**     AS A SOFTWARE FUNCTION TO DEFINE MORE INFORMATION ABOUT THE
**     DATA MANIPULATIONS NECESSARY TO TRANSFER DATA.  CURRENTLY
**     ONLY TWO BITS ARE USED.
**
**       TO ACCOMODATE THIS, THE NOS/VE UNIT REQUEST CONSISTS OF
**       SEVERAL COMMANDS.  THE FUNCTION IS BUT ONE COMMAND IN THE
**       SEQUENCE.  SEE CHANNEL I/O DESCRIBED IN MORE DETAIL IN
**       LATER SECTION.
**
**       --  20 00  000C  X000 0YYY(16)
**
**       (1) 20(16)    = (C) COMMAND CODE - FUNCTION
**           00(16)    = (F) FLAGS - NO FLAGS
**           000C(16)  = (LENGTH) FUNCTION CODE BIT LENGTH
**           X000      = SOFTWARE FUNCTION CODE
**                       WHERE X = XX00(2)
**                       XX00(2) = 60-BIT CM R/W, 12/12-BIT I/O
**                                 STLOD - I.E. PROCESS LOADS
**                       XX01(2) = INVALID.  (RESERVED)
**                       XX10(2) = 64-BIT CM R/W, 12/12-BIT I/O
**                                 ENGINEERING, ACCOUNT, ETC. FILE
**                       XX11(2) = 64-BIT CM R/W, 16/12-BIT I/O
**                                 PACKED 32 BIT USER DATA
**           0YYY      = FUNCTION CODE
**                       0YYY(16) = 0100(16) = 0400(8) = WRITE PUBLIC M.
**                       0YYY(16) = 0101(16) = 0401(8) = WRITE MAIN MEM
**                       0YYY(16) = 0140(16) = 0500(8) = READ PUBLIC MEM
**                       0YYY(16) = 0141(16) = 0501(8) = READ MAIN MEM
**
**   READ STATUS - 60(16).
**
**     THIS COMMAND PROVIDES A DEVICE-INDEPENDENT METHOD OF RETREIVING
**     DEVICE-DEPENDENT STATUS ASSOCIATED WITH A NOS/VE LOGICAL UNIT.
**
**     THE MAP-V 12-BIT CHANNEL INTERFACE PROVIDES TWO STATUS WORDS.
**     SINCE THERE IS SPACE FOR 4-PP WORDS IN ONE 64-BIT CM WORD,
**     STATUS WILL BE WRITTEN TO CENTRAL MEMORY WITH LEFT TWO BYTES
**     CONTAINING STATUS READ AFTER LAST OPERATION AND RIGHT TWO
**     BYTES CONTAIN TWO STATUS WORDS READ AS A RESULT OF THIS
**     COMMAND CODE.  STATUS WORD 1 WILL OCCUR IN BYTES 0 AND 2, WHILE
**     STATUS WORD 2 WILL OCCUR IN BYTES 1 AND 3.
**
**       TO ACCOMODATE THIS, THE NOS/VE UNIT REQUEST CONSISTS OF
**       ONE COMMAND.
**
**       --  60 80  0008  YYYY YYYY(16)
**
**       (1) 60(16)    = (C) COMMAND CODE - READ STATUS
**           80(16)    = (F) FLAGS - STORE RESPONSE
**           0008      = (LENGTH) CENTRAL MEMORY AREA IN 8-BIT BYTES
**           YYYY YYYY = (ADDRESS) REAL MEMORY BYTE ADDRESS TO
**                                 STORE MAP-V STATUS WORDS
**
**
**
** SOFTWARE IN THE MAP-V - ARRAY PROCESSOR MONITOR - (APM).
**
** THE EXTERNAL INTERFACE TO THE MAP-V ARRAY PROCESSOR MONITOR (APM)
** IS DEFINED BY STI IN THE FORM OF REQUEST AND RESPONSE PACKETS.
** IT IS THRU THIS MECHANISM THAT THE HOST PROCESSOR (CYBER-180)
** TELLS THE MAP-V WHAT TO DO.  FOR EVERY REQUEST PACKET SENT BT THE
** HOST, THERE IS A CORRESPONDING RESPONSE PACKET, HOWEVER, THE RE-
** SPONSE PACKETS MAY NOT BE RETURNED IN THE SAME SEQUENCE THAT THE
** REQUESTS WERE SENT.  ALSO, A LONG TIME PERIOD MAY PASS BETWEEN THE
** TIME THE REQUEST IS SENT, AND WHEN THE RESPONSE IS AVAILABLE.  ONE
** SUCH CASE IS THE REQUEST TO RUN A PROCESS IN THE MAP-V.  IN THIS
** CASE THE RESPONSE IS NOT AVAILABLE UNTIL IT COMPLETES, WHICH COULD
** BE MILLISECONDS, SECONDS, MINUTES OR HOURS.
**
** THE REQUEST PACKET AREA POINTED TO IN CM BY THE
** PP UNIT REQUEST CONSISTS OF TWO TIME STAMP LOCATIONS
** FOLLOWED BY THE STI DEFINED REQUEST PACKET.  THE TIME STAMPS
** ARE READINGS TAKEN BY THE PPU FROM THE MICRO-SECOND CLOCK
** WHEN:
**      (1) PPU LOCATES AND STARTS TO PROCESS REQUEST PACKET
** AND  (2) PPU HAS SUCCESSFULLY DELIVERED PACKET TO MAP-V.
**
** THE STI REQUEST PACKET FORMAT IS:
**
**     JID  (32 BITS) JOB IDENTIFIER
**     RSN  (32 BITS) REQUEST SERIAL NUMBER
**     RES  (32 BITS) RESERVED WORD FOR STAR TECHNOLOGIES
**     FC   (32 BITS) FUNCTION CODE OF ST-REQUEST
**     LNG  (32 BITS) LENGTH OF REQUEST - 32 BIT WORDS  (JID - CSUM)
**     RPKT (N-WORDS, EACH 32 BITS) REQUEST PACKET PARAMETERS
**                    THIS VARIABLE LENGTH FIELD IS UNIQUELY
**                    DEFINED BY EACH INDIVIDUAL REQUEST TYPE.
**     CMIP (N-WORDS, EACH 64 BITS)  CMI PARAMETERS
**                    THIS FIELD IS DEFINED FOR CMI TRANSFERS.
**                    IT CONSISTS OF HOST REAL MEMORY WORD ADDRESSES
**                    AND CM WORD COUNTS.
**          (32-BITS) CMI TERMINATION FLAG = 8000 0000(16)
**     CSUM (32 BITS) CHECKSUM - 32-BIT SUM OF PACKET WITH NO CARRY
**
** THE RESPONSE PACKET AREA POINTED TO IN CM BY THE
** PP UNIT REQUEST CONSISTS OF THE STI DEFINED RESPONSE PACKET.
**
** THE STI RESPONSE PACKET FORMAT IS:
**
**     JID  (32 BITS) JOB IDENTIFIER
**     RSN  (32 BITS) REQUEST SERIAL NUMBER
**     RS   (96 BITS) RETURN STATUS - I-STAT (32 BITS)
**                                  - J-STAT (32 BITS)
**                                  - K-STAT (32 BITS)
**     CSUM (32 BITS) CHECKSUM - 32-BIT SUM OF PACKET WITH NO CARRY
**
**
**
**
** TO COMMUNICATE WITH THE MAP-V APM THE GENERAL PROTOCOL IS:
**    - SEND A REQUEST PACKET WITH PROTOCOL DATA
**    - RECEIVE A RESPONSE PACKET WITH STATUS DATA
**
**       TO ACCOMODATE THIS, THE NOS/VE UNIT REQUEST CONSISTS OF
**       TWO COMMANDS.
**
**       --  21 00  XXXX  YYYY YYYY(16)
**       --  25 80  XXXX  YYYY YYYY(16)
**
**       (1) 21(16)    = (C) COMMAND CODE - OUTPUT 8-BIT PARAMETERS
**                           (WRITE FLAG FUNCTION IMPLIED)
**           00        = (F) FLAGS - INDIRECT FLAG OPTIONAL
**           XXXX      = (LENGTH) CENTRAL MEMORY AREA IN 8-BIT BYTES
**           YYYY YYYY = (ADDRESS) REAL MEMORY BYTE ADDRESS OF
**                                 REQUEST PACKET AREA
**
**       FOLLOWED BY:
**       (2) 25(16)    = (C) COMMAND CODE - INPUT 8-BIT DATA/PARAMETERS
**                           (WRITE FLAG FUNCTION IMPLIED)
**           80(16)    = (F) FLAGS = STORE RESPONSE
**                                 - INDIRECT FLAG OPTIONAL
**           XXXX      = (LENGTH) CENTRAL MEMORY AREA IN 8-BIT BYTES
**           YYYY YYYY = (ADDRESS) REAL MEMORY BYTE ADDRESS OF
**                                 RESPONSE PACKET AREA
**
** TO SATISFY HOST-CENTRAL-MEMORY/MAP-V-MAIN-MEMORY
** DATA TRANSFERS THE CMI AND CHANNEL ONLY CASES ARE
** DEFINED AS FOLLOWS:
**
**  (A)  REQUEST PACKET CONTAINS PROTOCOL DATA AND DEFINES
**       A HOST-CENTRAL-MEMORY/MAP-V-MAIN-MEMORY DATA TRANSFER
**       VIA THE CMI HARDWARE.
**
**       TO ACCOMODATE THIS, THE NOS/VE UNIT REQUEST CONSISTS OF
**       THREE COMMANDS.
**
**       --  21 00  XXXX  YYYY YYYY(16)
**       --  21 40  XXXX  YYYY YYYY(16)
**       --  25 80  XXXX  YYYY YYYY(16)
**
**       (1) 21(16)    = (C) COMMAND CODE - OUTPUT 8-BIT PARAMETERS
**                           (WRITE FLAG FUNCTION IMPLIED)
**           00        = (F) FLAGS - INDIRECT FLAG OPTIONAL
**           XXXX      = (LENGTH) CENTRAL MEMORY AREA IN 8-BIT BYTES
**           YYYY YYYY = (ADDRESS) REAL MEMORY BYTE ADDRESS OF
**                                 REQUEST PACKET AREA
**
**       FOLLOWED BY:
**       (2) 21(16)    = (C) COMMAND CODE - OUTPUT 8-BIT PARAMETERS
**           40(16)    = (F) FLAGS - INDIRECT ADDRESS
**           XXXX      = (LENGTH) CENTRAL MEMORY AREA IN 8-BIT BYTES
**           YYYY YYYY = (ADDRESS) REAL MEMORY BYTE ADDRESS WHICH
**                                 CONTAINS LENGTH/ADDRESS PAIRS
**       FOLLOWED BY:
**       (3) 25(16)    = (C) COMMAND CODE - INPUT 8-BIT DATA/PARAMETERS
**                           (WRITE FLAG FUNCTION IMPLIED)
**           80(16)    = (F) FLAGS = STORE RESPONSE
**                                 - INDIRECT FLAG OPTIONAL
**           XXXX      = (LENGTH) CENTRAL MEMORY AREA IN 8-BIT BYTES
**           YYYY YYYY = (ADDRESS) REAL MEMORY BYTE ADDRESS OF
**                                 RESPONSE PACKET AREA
**
**
**
**  (B)  REQUEST PACKET CONTAINS PROTOCOL DATA AND DEFINES
**       A HOST-CENTRAL-MEMORY TO/FROM MAP-V-MAIN-MEMORY DATA TRANSFER
**       OR A HOST-CENTRAL-MEMORY FROM MAP-V PUBLIC-MEMORY DATA TRANSFER
**       VIA THE PPU CHANNEL.
**
**       TO ACCOMODATE THIS, THE NOS/VE UNIT REQUEST CONSISTS OF
**       FOUR COMMANDS.
**
**       --  21 00  XXXX  YYYY YYYY(16)
**       --  25 00  XXXX  YYYY YYYY(16)
**       --  20 00  000C  X000 0101(16)
**       --  50 C0  XXXX  YYYY YYYY(16)
**       OR
**       --  21 00  XXXX  YYYY YYYY(16)
**       --  25 00  XXXX  YYYY YYYY(16)
**       --  20 00  000C  X000 0YYY(16)
**       --  40 C0  XXXX  YYYY YYYY(16)
**
**       (1) 21(16)    = (C) COMMAND CODE - OUTPUT 8-BIT PARAMETERS
**                           (WRITE FLAG FUNCTION IMPLIED)
**           00        = (F) FLAGS - INDIRECT FLAG OPTIONAL
**           XXXX      = (LENGTH) CENTRAL MEMORY AREA IN 8-BIT BYTES
**           YYYY YYYY = (ADDRESS) REAL MEMORY BYTE ADDRESS OF
**                                 REQUEST PACKET AREA
**
**       FOLLOWED BY:
**       (2) 25(16)    = (C) COMMAND CODE - INPUT 8-BIT DATA/PARAMETERS
**                           (WRITE FLAG FUNCTION IMPLIED)
**           00        = (F) FLAGS - INDIRECT FLAG OPTIONAL
**           XXXX      = (LENGTH) CENTRAL MEMORY AREA IN 8-BIT BYTES
**           YYYY YYYY = (ADDRESS) REAL MEMORY BYTE ADDRESS OF
**                                 RESPONSE PACKET AREA
**
**       (3) 20(16)    = (C) COMMAND CODE - FUNCTION
**           00        = (F) FLAGS - NO FLAGS
**           000C(16)  = (LENGTH) FUNCTION CODE BIT LENGTH
**           X000 0YYY = FUNCTION CODE
**           X000      = SOFTWARE FUNCTION CODE
**                       WHERE X = XX00(2)
**                       XX00(2) = 60-BIT CM R/W, 12/12-BIT I/O
**                                 STLOD - I.E. PROCESS LOADS
**                       XX01(2) = INVALID.  (RESERVED)
**                       XX10(2) = 64-BIT CM R/W, 12/12-BIT I/O
**                                 ENGINEERING, ACCOUNT, ETC. FILE
**                       XX11(2) = 64-BIT CM R/W, 16/12-BIT I/O
**                                 PACKED 32 BIT USER DATA
**                 YYY = 101(16) = 0401(8) - WRITE TO MAIN-MEMORY
**                 YYY = 140(16) = 0500(8) - READ FROM PUBLIC-MEMORY
**                 YYY = 141(16) = 0501(8) - READ FROM MAIN-MEMORY
**
**       FOLLOWED BY:
**       (4) 50(16)    = (C) COMMAND CODE - WRITE BYTES
**     OR    40(16)    = (C) COMMAND CODE - READ BYTES
**           C0(16)    = (F) FLAGS - STORE RESPONSE, INDIRECT ADDRESS
**           XXXX      = (LENGTH) CENTRAL MEMORY AREA IN 8-BIT BYTES
**           YYYY YYYY = (ADDRESS) REAL MEMORY BYTE ADDRESS WHICH
**                                 CONTAINS LENGTH/ADDRESS PAIRS
**
**
**
**
** THE PPU IS RESPONSIBLE FOR ASSIGNING A VALUE TO THE 32-BIT
** RSN FIELD OF THE MAP-V REQUEST PACKET.  THE VALUE ASSIGNED
** IS THE RMA (BYTE ADDRESS) WITH LOWER 3-BITS ASSIGNED AN INDEX
** TO THE NEXT CMD IN THE REQUEST.  THE CMD INDEX MAY NOT EXCEED
** 3-BITS (I.E. A VALUE OF SEVEN (7)).  THIS VALUE, WHICH IS
** RETURNED IN THE RSN FIELD OF THE MAP-V RESPONSE PACKET, IS USED TO
** PAIR UP THE RESPONSE WITH THE ORIGINAL PP-UNIT-REQUEST.  THIS VALUE
** IS ALSO INCLUDED IN CSUM ACCUMLULATION OF THE REQUEST PACKET
** BY THE PPU.  THE DESIGN, AT THIS TIME, ALLOWS FOR ONLY ONE (1)
** REQUEST/RESPONSE DIRECTIVE SET IN A PP-UNIT REQUEST.  THIS
** RESULTS IN EITHER TWO (2) TO FOUR (4) COMMANDS PER PP-UNIT
** REQUEST.
**
** IF A DATA TRANSFER (STWR OR STRD) TO/FROM MAIN MEMORY IS INVOLVED -
**     IN THE CMI CASE, THE CMIP (CMI PARAMETERS) FIELD IS ALSO
**     THE RESPONSIBLITY OF THE PPU.  THESE PARAMETERS ARE
**     FORMATTED, CHECKSUMMED  AND INSERTED IN THE APPROPRIATE
**     POSITION OF THE MAP-V REQUEST BY THE PPU.
**
**     IN THE CHANNEL ONLY CASE, THE LAST CMD IN PP-UNIT-REQUEST
**     BLOCK WILL DIRECT THE PPU TO PERFORM THE APPROPRIATE DATA
**     TRANSFER.  THIS DATA TRANSFER WILL TAKE PLACE OVER A
**     16-BIT IPI CHANNEL (FUTURE IMPLEMENTATION).
**
** THE INITIAL IMPLEMENTATION IS WITH CMI AND A 12-BIT CHANNEL
** INTERFACE.  THIS CHANNEL HARDWARE SUPPORTS 12/60 BIT FORMATS.
** THIS MAP-V HARDWARE INTERFACE PASSES COMMAND AND CONTROL
** INFORMATION (I.E. FUNCTION CONTROL AND REQUEST/RESPONSE
** PACKETS) IN THE LOWER 32-BITS OF A 60-BIT TRANSFER.  THE FUNCTION
** CONTROL INFORMATION IS SET UP IN THE PPU AND CONSISTS OF 2-60 BIT
** WORDS USING THE LOWER 32-BITS. THE REQUEST PACKETS ARE SET UP IN
** CENTRAL MEMORY BY THE MAP-V SUBSYSTEM SOFTWARE WHILE THE ADDRESS
** LIST IS SET UP BY THE NOS/VE OPERATING SYSTEM.  TO MEET THE INTER-
** FACE REQUIREMENTS, THE PPU REFORMATS THE VARIABLE LENGTH 64-BIT
** REQUEST PACKET AND ADDRESS LIST TO MEET THE CHANNEL AND APM
** REQUIREMENTS.  THE CENTRAL MEMORY DATA THAT THE USER PROGRAM
** WISHES TO TRANSFER TO/FROM MAP-V-MAIN-MEMORY VIA STWR OR
** STRD CALLS IS TRANSFERED VIA THE CMI.
**
** FUTURE IMPLEMENTATION WILL REQUIRE THAT THE CMI DATA TRANSFER
** DESCRIBED ABOVE BE CARRIED OUT OVER A CHANNEL INTERFACE.
** WHEN THE IPI MAP-V CHANNEL INTERFACE IS BUILT, THE CHANNEL
** INTERFACE WILL BE CAPABLE TO TRANSFERING THE 16/64 DATA
** AND THE 16/64 FUNCTION CONTROL AS WELL AS THE 16/64
** REQUEST/RESPONSE PACKETS.  IT IS EXPECTED THAT THIS INTERFACE
** WILL EVENTUALLY REPLACE THE 12/60 BIT INTERFACE ON THE NOS/VE
** SYSTEM.
**
**
**
**
**     FOR RESTART AND RECOVER, THE CPU WILL NEED TO
**     INITIATE A WRITE FLAG SEQUENCE WITH APM SOFTWARE
**     FUNCTION CODE 4 (SOFTWARE INITIATED MASTER CLEAR).
**     OTHER EXISTING APM CODES MAY BE IMPLEMENTED OR CODES
**     MAY BE ADDED IN THE FUTURE FOR THIS SPECIALIZED SEQUENCE.
**
**     MAP-V HARDWARE FUNCTIONS TO BE EXECUTED IN THIS MANNER ARE:
**
**       0200(8) - WRITE FLAG FUNCTION.
**
**       TO ACCOMODATE THIS, THE NOS/VE UNIT REQUEST CONSISTS OF
**       MORE THAN ONE COMMAND.
**
**       --  20 00  000C  0000 0080(16)
**       --  21 00  0008  YYYY YYYY(16)
**       --  60 80  0008  YYYY YYYY(16)
**
**
**       (1) 20(16)    = (C) COMMAND CODE - FUNCTION
**           00        = (F) FLAGS - NO FLAGS
**           000C(16)  = (LENGTH) FUNCTION CODE BIT LENGTH
**           0000 0080 = FUNCTION CODE - 0200(8)
**
**       FOLLOWED BY:
**       (2) 21(16)    = (C) COMMAND CODE - WRITE 8-BIT PARAMETERS
**           00        = (F) FLAGS - NO FLAGS
**           0008(16)  = (LENGTH) CENTRAL MEMORY AREA IN 8-BIT BYTES
**                                (ONE 64-BIT CM WORD CONVERTED TO
**                                 TWO 12/60-BIT WORDS)
**           YYYY YYYY = (ADDRESS) REAL MEMORY BYTE ADDRESS OF
**                                 8-BIT PARAMETERS
**
**       FOLLOWED BY:
**       (3) 60(16)    = (C) COMMAND CODE - READ STATUS
**           80(16)    = (F) FLAGS - STORE RESPONSE
**           0008      = (LENGTH) CENTRAL MEMORY AREA IN 8-BIT BYTES
**           YYYY YYYY = (ADDRESS) REAL MEMORY BYTE ADDRESS TO
**                                 STORE MAP-V STATUS WORDS
**
**
**
**
**     MAP-V DIAGNOSTIC HARDWARE FUNCTIONS HAVE ADDITIONAL
**     REQUIREMENTS AND USE THE FUNCTION IN AN EXTENDED
**     SEQUENCE.  SOME OF THE DIAGNOSTIC FUNCTIONS DIRECT THE INTER-
**     FACE TO TURN DATA AROUND AT VARIOUS POINTS IN THE INTERFACE.
**     IN THESE CASES THE DIAGNOSTIC SEQUENCE CONSISTS OF A FUNCTION
**     CODE AND A WORD OF DATA WHICH IS OUTPUTTED AND READ BACK FOR
**     COMPARISON.  FOR THE 12/60-BIT CHANNEL INTERFACE THE DATA
**     MUST BE STRUCTURED AS 12/60-BIT DATA IN A 64-BIT WORD.
**     THE PPU WILL SPECIAL CASE THE DIAGNOSTIC FUNCTIONS
**     INVOLVING DATA TURN AROUND ON THE 12/60-BIT HARDWARE
**     AND WILL DO A 60-BIT READ AND A 60-BIT WRITE WITH
**     CENTRAL MEMORY.
**
**     THE 16/64-BIT CHANNEL INTERFACE DIAGNOSTIC NEEDS
**     FURTHER DEFINITION.
**
**     MAP-V HARDWARE FUNCTIONS TO BE EXECUTED IN THIS MANNER ARE:
**
**       0304(8) - TEST TRANSMITTERS, RECEIVERS AND CABLE WITH SIMPLE
**                 PATTERNS.
**       03X5(8) - TEST IOP NUMERICAL CONVERSION DATA PATHS.
**                 WHERE X = 0, 1, 2, OR 3.
**
**       TO ACCOMODATE THIS, THE NOS/VE UNIT REQUEST CONSISTS OF
**       MORE THAN ONE COMMAND.
**
**       --  20 00  000C  0000 0YYY(16)
**       --  23 00  0008  YYYY YYYY(16)
**       --  25 00  0008  YYYY YYYY(16)
**       --  60 80  0008  YYYY YYYY(16)
**
**       (1) 20(16)    = (C) COMMAND CODE - FUNCTION
**           00        = (F) FLAGS - NO FLAGS
**           000C(16)  = (LENGTH) FUNCTION CODE BIT LENGTH
**           0000 0YYY = FUNCTION CODE
**
**       FOLLOWED BY:
**       (2) 23(16)    = (C) COMMAND CODE - OUTPUT 8-BIT DATA
**           00        = (F) FLAGS - NO FLAGS
**           0008(16)  = (LENGTH) CENTRAL MEMORY AREA IN 8-BIT BYTES
**           YYYY YYYY = (ADDRESS) REAL MEMORY BYTE ADDRESS OF
**                                 8-BIT DATA
**
**       FOLLOWED BY:
**       (3) 25(16)    = (C) COMMAND CODE - INPUT 8-BIT DATA/PARAMETERS
**           00        = (F) FLAGS - NO FLAGS
**           0008      = (LENGTH) CENTRAL MEMORY AREA IN 8-BIT BYTES
**           YYYY YYYY = (ADDRESS) REAL MEMORY BYTE ADDRESS OF
**                                 8-BIT DATA
**
**       FOLLOWED BY:
**       (4) 60(16)    = (C) COMMAND CODE - READ STATUS
**           80(16)    = (F) FLAGS - STORE RESPONSE
**           0008      = (LENGTH) CENTRAL MEMORY AREA IN 8-BIT BYTES
**           YYYY YYYY = (ADDRESS) REAL MEMORY BYTE ADDRESS TO
**                                 STORE MAP-V STATUS WORDS
**
**
**
**
**     NON-DATA MAP-V HARDWARE DIAGNOSTIC FUNCTION.
**
**       0306(8) - TEST IOP COMMON LOGIC.
**                 THIS FUCTION RUNS FOR ABOUT
**                 10 SECONDS AND LOCKS OUT ALL
**                 ACTIVITY TO THIS IOP.
**
**     NOTE: REFER TO HARDWARE SPECIFICATION FOR RE-DEFINITION
**           OF STATUS BITS FOLLOWING THIS FUNCTION.
**
**       TO ACCOMODATE THIS, THE NOS/VE UNIT REQUEST CONSISTS OF
**       MORE THAN ONE COMMAND.
**
**       --  20 00  000C  0000 00C6(16)
**       --  60 00  0008  YYYY YYYY(16)
**       --  20 80  000C  0000 00BF(16)
**
**       (1) 20(16)    = (C) COMMAND CODE - FUNCTION
**           00        = (F) FLAGS - NO FLAGS
**           000C(16)  = (LENGTH) FUNCTION CODE BIT LENGTH
**           0000 00C6 = FUNCTION CODE - 0306(8)
**
**       FOLLOWED BY:
**       (2) 60(16)    = (C) COMMAND CODE - READ STATUS
**           00        = (F) FLAGS - NO FLAGS
**           0008      = (LENGTH) CENTRAL MEMORY AREA IN 8-BIT BYTES
**           YYYY YYYY = (ADDRESS) REAL MEMORY BYTE ADDRESS TO
**                                 STORE MAP-V STATUS WORDS
**
**       FOLLOWED BY:
**       (3) 20(16)    = (C) COMMAND CODE - FUNCTION
**           80(16)    = (F) FLAGS - STORE RESPONSE
**           000C(16)  = (LENGTH) FUNCTION CODE BIT LENGTH
**           0000 00BF = FUNCTION CODE - 0277(8)
**
**
**
** N0S/VE PERIPHERAL PROCESSOR RESPONSES
**
**
** PERIPHERAL RESPONSES ARE PREPARED BY THE PERIPHERAL PROCESSOR
** AND DESCRIBE EITHER THE STATUS OF A REQUEST OR
** THE OCCURRANCE OF AN UNUSUAL CONDITION NOT RELATED TO A
** REQUEST.  RESPONSES ARE TRANSMITTED TO THE OPERATING SYSTEM
** THROUGH RESPONSE BUFFERS.  A SEPARATE RESPONSE BUFFER IS
** DEFINED FOR EACH PP.
**
** WHEN A RESPONSE IS RELATED TO A LOGICAL UNIT REQUEST, THE
** STATUS CONDITION REPORTED IN THE RESPONSE USUALLY REPRESENTS
** STATUS ACCUMULATED SINCE THE REQUEST WAS STARTED.
**
** THE FORMAT OF THE FIRST 40 BYTES (FIVE 64-BIT WORDS) OF EVERY
** RESPONSE IS IDENTICAL, EVEN THOUGH SOME OF THE FIELDS MAY BE
** UNSUSED.
**
** IN ADDITION -
**
**   (1) THE MAP-V PP WILL APPEND 2 64-BIT WORDS TO ALL UNIT RESPONSES.
**       THESE WORDS CONTAIN TIMIMG INFORMATION REGARDING RESPONSE
**       PROCESSING. THE TIME STAMPS ARE READINGS TAKEN BY THE PPU
**       FROM THE MICRO-SECOND CLOCK WHEN:
**      (1) PPU HAS SENT A RESPONSE TO THE CPU
**       AND
**      (2) IN CMI CASE - TIME THE PPU RECEIVED THE RESPONSE PACKET
**                        FROM THE MAP-V.
**          IN CHANNEL I/O CASE - TIME DATA I/O COMPLETES.
**
**   (2) THE MAP-V PP WILL APPEND A 64-BIT WORD TO ALL UNIT RESPONSES.
**       THIS WORD IS MADE UP OF MAP-V INTERFACE HARDWARE STATUS WORDS.
**       THUS, ALL MAP-V UNIT RESPONSES WILL BE AT LEAST 64 BYTES
**       (EIGHT 64-BIT WORDS) LONG.
**
**   (3) IF A UNIT-RELATED ERROR OCCURS A SECOND 64-BIT WORD IS
**       APPENDED TO THE RESPONSE MAKING THE RESPONSE 72 BYTES LONG.
**
** IN THE STANDARD RESPONSE HEADER, WORD 4 - BITS 00-47 ARE OF PARTIC-
** ULAR INTEREST.  THE MAP-V PP RETURNS VALUES IN THE RESPONSE CODE (RC)
** FIELD AND WHEN APPROPIATE, IT ALSO MAY RETURN A VALUE IN
** THE UNSOLICITED RESPONSE CODE (URC) OR THE ABNORMAL STATUS,
** OR THE INTERFACE ERROR CODE (IEC) FIELD.
**
**     0               1               3               4              6
**     0123456789012345678901234567890123456789012345678901234567890123
**    /************************************************---------------/
**    /   ABNORMAL    *   INTERFACE   *   RC  *  URC  *               /
**    /    STATUS     *   ERROR CODE  *       *       *               /
**    /     (16)      *     (16)      *   (8) *  (8)  *               /
**    /************************************************---------------/
**
**                     WORD 4 - BITS 00-47
**
**
**   RESPONSE CODE (RC) FIELD (*/RS/P.RC*)
**
**        NOTE--IN THE NOTATION (*XXXXXX*), XXXXXX REFERS TO SYMBOL
**              USED IN THE PP LISTING.
**
**     THE RC FIELD OCCUPIES BITS 32-39 OF WORD 4 AND IDENTIFIES
**     THE GENERAL CONDITION THAT CAUSED THE RESPONSE TO BE
**     STORED.  THE LEFT TWO BITS (BITS 32 AND 33) SPECIFY THE
**     THE GENERAL CLASS OF RESPONSE.  THE GENERAL CLASSES ARE
**
**       00 - UNSOLICITED RESPONSE          (*R.UNS*)
**       01 - INTERMEDIATE RESPONSE         (*R.INT*)
**       10 - NORMAL REQUEST TERMINATION    (*R.NRM*)
**       11 - ABNORMAL REQUEST TERMINATION  (*R.ABN*)
**
**     THE NEXT TWO BITS (BITS 34 AND 35) IDENTIFY ADDITIONAL
**     CONDITIONS EXISTING AT THE TIME AN INTERMEDIATE OR FINAL
**     RESPONSE WAS STORED AND ARE ALWAYS ZERO FOR UNSOLICITED
**     RESPONSES.  CURRENTLY, THE MAP-V PP ALWAYS SETS THESE BITS TO
**     ZERO.
**
**     THE REMAINING FOUR BITS ARE RESERVED FOR FUTURE USE AND
**     CONTAIN ZEROS.
**
**
**   UNSOLICITIED RESPONSE CODE (URC) FIELD  (*/RS/P.URC*)
**
**     THE UNSOLICITED RESPONSE CODE (URC) OCCUPIED BITS 40-47 OF
**     WORD 4 AND IDENTIFIES THE CONDITION THAT CAUSED THE UNSOLICITED
**     RESPONSE TO BE STORED.  THE FIELD IS INTERPRETED AS AN 8-BIT
**     BINARY INTEGER WHOSE VALUE IS NON-ZERO ONLY IF THE VALUE OF
**     THE RESPONSE CODE IS ZERO.  THE VALUES CURRENTLY DEFINED ARE
**
**       1 - THE STATUS OF THE SPECIFIED LOGICAL UNIT CHANGED FROM
**           READY TO NOT READY.                (*URC.RN*)
**
**       2 - THE STATUS OF THE SPECIFIED LOGICAL UNIT CHANGED FROM
**           NOT READY TO READY.                (*URC.NR*)
**
**       3 - THE PP DETECTED AN ABNORMAL CONDITION DURING ITS HOUSE-
**           KEEPING CYCLE.  THE ABNORMAL STATUS FIELD AND POSSIBLY
**           THE INTERFACE ERROR CODE FIELD OF THE RESPONSE FURTHER
**           DEFINE THE ABNORMAL CONDITION.     (*URC.IE*)
**
**       THE ONLY RESPONSE FIELDS WHICH HAVE MEANING FOR UNSOLICITED
**       RESPONSES ARE
**
**         RESPONSE CODE              (RC)
**         UNSOLICITED RESPONSE CODE  (URC)
**         RESPONSE LENGTH (WORD 3 - BITS 0-15)
**         LOGICAL UNIT    (WORD 3 - BITS 16-31)
**         ABNORMAL STATUS
**         INTERFACE ERROR CODE       (IEC)
**
**
**   ABNORMAL STATUS FIELD   (*/RS/P.XXXXX*)
**
**            WHERE XXXXX = CHERR, DATERR, HDWR, OCP, OR FORC.
**
**     THE ABNORMAL STATUS FIELD OCCUPIES BITS 0-15 OF WORD 4 AND
**     FURTHER DEFINES AN ABNORMAL REQUEST TERMINATION (RC=1100 0000)
**     OR AN ABNORMAL UNSOLICITED RESPONSE CODE (URC=3).  THIS FIELD
**     IS INTERPRETED AS SIXTEEN BINARY FLAGS CORRESPONDING TO SIXTEEN
**     ABNORMAL CONDITIONS, NINE OF WHICH ARE CURRENTLY DEFINED.
**
**     THE MAP-V PP IDENTIFIES THE FOLLOWING CONDITIONS AND
**     REPORTS THEM VIA THIS FIELD.
**
**       BIT 2 - FORCED TERMINATION           (*K.FORC*)
**               THIS CONDITION IS SET WHEN THE MAP-V PPU TERMINATES
**               A UNIT REQUEST.  THE MAP-V PPU WILL TERMINATE REQUESTS
**               ONLY IF THE SUBSYSTEM HAS REQUESTED THE REQUEST BE
**               TERMINATED.
**
**       BIT 3 - CHANNEL ERROR               (*K.CHERR*)
**               THIS CONDITION IS SET IF THE MAP-V PP ENCOUNTERS AN
**               UNCORRECTABLE PARITY ERROR DURING TRANSMISSION OF
**               FUNCTIONS, PARAMETERS OR DATA BETWEEN THE PP AND
**               MAP-V CHANNEL INTERFACE.
**
**       BIT 5 - RECORDING MEDIUM ERROR      (*K.DATERR*)
**               THIS CONDITION IS SET IF THE MAP-V PP DETECTS A
**               CHECKWORD ERROR.
**
**       BIT 6 - HARDWARE MALFUNCTION ERROR  (*K.HDWR*)
**               THIS CONDITION IS SET IF THE MAP-V PP DETECTS A
**               HARDWARE MALFUNCTION IN THE MAP-V CONTROLLER
**               OR IN THE CHANNEL CONNECTION SUCH THAT IT IS
**               IMPOSSIBLE TO COMPLETE THE REQUEST.
**
**       BIT 9 - OUTPUT CHANNEL PARITY ERROR (*K.OCP*)
**               THIS CONDITION IS SET IF THE MAP-V PP DETECTS A
**               CHANNEL PARITY ERROR CONDTION IN THE MAP-V
**               HARDWARE STATUS (BIT 9 - STATUS WORD 1).
**
**
**   INTERFACE ERROR CODE (IEC) FIELD
**
**     THE IEC FIELD OCCUPIES BITS 16-31 OF WORD 4 AND IDENTIFIES
**     THE INTERFACE ERROR DETECTED BY THE PP.
**
**     INTERFACE ERROR CODES
**
**       (*) INDICATES THAT MAP-V PPU WILL DETECT THIS CONDITION
**           IF CODE IS ASSEMBLED WITH EFLAG(X) EQUATE SET TO 1.
**           X = LEFT MOST DIGIT IN ERROR CODE NUMBER.
**           THERE ARE FIVE EFLAG(X) EQUATES DEFINED, FOUR OF
**           WHICH ARE USED HERE.
**
**      TAG      XX(16)  DESCRIPTION
**
**    * ERC201 - 201  -  RESERVED FIELD OF PP INT TBL HEAD NOT 0
**    * ERC202 - 202  -  RMA OF INTERRUPT WORD NOT A WORD BOUNDARY
**    * ERC203 - 203  -  RMA OF PP COMM BUF NOT A WORD BOUNDARY
**    * ERC204 - 204  -  RESERVED FIELD OF PP COMM DESCRIPTOR NOT 0
**    * ERC205 - 205  -  RESERVED FIELD OF QUEUE DESCRIPTOR NOT 0
**    * ERC206 - 206  -  RMA OF NEXT PP NOT A WORD BOUNDARY
**    * ERC209 - 209  -  RMA OF UIT NOT A WORD BOUNDARY
**    * ERC20A - 20A  -  INVALID CHANNEL NUMBER IN UNIT DESCRIPTOR
**    * ERC20B - 20B  -  RMA OF CHANNEL TABLE NOT ON WORD BOUNDARY
**
**    * ERC301-  301  -  LOGICAL UNIT NUMBER MISMATCH
**    * ERC302 - 302  -  RMA OF UNIT COMM BUF NOT A WORD BOUNDARY
**    * ERC303 - 303  -  RESV. FIELD OF UNIT COMM BUF DESCRIPTOR NOT 0
**    * ERC304 - 304  -  RMA OF NEXT UNIT REQUEST NOT WORD BOUNDARY
**    * ERC305 - 305  -  RESERVED FIELD OF QUEUE DESCRIPTOR NOT 0
**    * ERC307 - 307  -  ILLEGAL DEVICE TYPE
**
**    * ERC401-  401  -  RMA OF NEXT REQUEST NOT A WORD BOUNDARY
**    * ERC402 - 402  -  REQUEST LENGTH NOT A MULTIPLE OF 8 BYTES
**    * ERC403 - 403  -  REQUEST LENGTH IS LESS THAN FOURTY BYTES
**    * ERC404 - 404  -  LOGICAL UNIT NO .NE. UNIT NO IN INTERFACE TBL
**    * ERC405 - 405  -  RESERVED LINKAGE FIELD IS NOT ZERO
**    * ERC406 - 406  -  INVALID RECOVERY/INTERFACE SELECTIONS
**    * ERC409 - 409  -  INVALID ALERT CONDITION
**    * ERC40A - 40A  -  REQUEST LENGTH TOO LARGE > 224 BYTES
**
**    * ERC501 - 501  -  INVALID COMMAND CODE
**    * ERC505 - 505  -  INVALID LENGTH SPECIFICATION IN COMMAND
**    * ERC507 - 507  -  INVALID LENGTH SPECIFICATION IN INDIRECT LIST
**    * ERC508 - 508  -  INVALID ADDRESS SPECIFICATION IN INDIRECT LIST
**    * ERC50A - 50A  -  INVALID SEQUENCE OF COMMANDS
**    * ERC50C - 50C  -  RESERVED FIELD IN INDIRECT LIST NOT 0
**
**
**     NORMAL REQUEST TERMINATION - RC=1000 0000(2) - (*R.NRM*)
**
**       THE REQUEST WAS ACTED UPON AND COMPLETED WITH NO PROBLEMS.
**       A 64-BIT WORD CONTAINING GENERAL HARDWARE STATUS IS
**       APPENDED TO THE NOS/VE DEFINED RESPONSE.
**
**       THE 64-BIT WORD APPENDED TO THE RESPONSE CONSISTS OF
**       MAP-V CHANNEL HARDWARE STATUS WORDS.
**
**       THE MAP-V 12-BIT CHANNEL INTERFACE PROVIDES TWO STATUS WORDS.
**       SINCE THERE IS SPACE FOR 4-PP WORDS IN ONE 64-BIT CM WORD,
**       STATUS WILL BE WRITTEN TO CENTRAL MEMORY WITH A SNAPSHOT
**       OF THE LAST TWO STATUS READS.  THE LEFT TWO PARCELS (FOUR BYTES)
**       CONTAIN OLDER OF TWO STATUS SNAPSHOTS AND RIGHT TWO
**       PARCELS CONTAIN MOST RECENT STATUS WORDS READ.  THE 12-BIT
**       STATUS WORD WILL BE RIGHT JUSTIFIED IN 16-BIT PARCEL.
**
**     0               1               3               4              6
**     0123456789012345678901234567890123456789012345678901234567890123
**    /***************************************************************/
**    /   PREVIOUS    *   PREVIOUS    *    CURRENT    *    CURRENT    /
**    / STATUS WORD 1 * STATUS WORD 2 * STATUS WORD 1 * STATUS WORD 2 /
**    /               *               *               *               /
**    /***************************************************************/
**
**       PARCEL 0 - STATUS WORD 1 - PREVIOUS STATUS READ.
**       PARCEL 1 - STATUS WORD 2 - PREVIOUS STATUS READ.
**       PARCEL 2 - STATUS WORD 1 - LATEST STATUS READ.
**       PARCEL 3 - STATUS WORD 2 - LATEST STATUS READ.
**
**       IN THE CASE WHERE AN ERROR OCCURS AND THE PP HAS
**       NEVER SUCESSFULLY READ STATUS, THESE PARCELS WILL CONTAIN
**       THE INITIALIZATION VALUE OF FFFE(16).
**
**
**     ABNORMAL REQUEST TERMINATION - RC=1100 0000(2) - (*R.ABN*)
**
**       THE REQUEST WAS ACTED UPON AND PROBLEMS OCCURRED.
**
**       IN THIS CASE, IT IS NECESSARY TO LOOK FARTHER FOR THE
**       PROBLEM DEFINITION.
**
**       A NON-ZERO VALUE IN THE INTERFACE ERROR CODE FIELD
**       IS ONE CAUSE FOR AN ABNORMAL RESPONSE.  IN THIS CASE
**       THE ERROR CODE GIVES AN INDICATION TO THE SOURCE
**       OF THE PROBLEM AND IS REPORTED AS 48-BYTE RESPONSE.
**       IF THE IEC FIELD EQUALS ZERO, A SECOND 64-BIT
**       WORD IS APPENDED TO THE RESPONSE.  IT CONSISTS OF
**
**     0               1               3               4              6
**     0123456789012345678901234567890123456789012345678901234567890123
**    /***************************************************************/
**    /    MAP-V      *     LAST      *     ERROR     *               /
**    /  ERROR CODE   * FUNCTION CODE *    ADDRESS    *    RESERVED   /
**    /     (16)      *     (16)      *      (16)     *               /
**    /***************************************************************/
**
**       PARCEL 0 - MAP-V ERROR CODE      (*MVEC*) SEE LIST BELOW.
**       PARCEL 1 - PP LAST FUNCTION CODE (*PPLF*) OTHER THAN STATUS.
**       PARCEL 2 - PP ERROR ADDRESS      (*PPEA*) LISTING REFERENCE.
**       PARCEL 3 - RESERVED.             (*PPRRC*)
**                  DURING TESTING, THIS PARCEL WILL BE USED TO
**                  REPORT THE VALUE IN *PPRRC* BEFORE BEING RESET
**                  TO ZERO ON ERROR CONDITION.  *PPRRC* CONTAINS
**                  THE REQUEST PACKET (+1), RESPONSE PACKET (-1)
**                  COUNTER.  I.E. COUNT OF OUTSTANDING RESPONSES
**                  IN THE MAP-V.
**
**       WHEN IT APPLIES, THE CORRESPONDING BIT IS ALSO SET IN THE
**       ABNORMAL STATUS FIELD.
**
**
**     UNSOLICITED RESPONSE - RC=0000 0000(2) - (*R.UNS*)
**
**       THIS RESPONSE IS USED BY MAP-V PP TO REPORT HARDWARE ERRORS NOT
**       ASSOCIATED WITH A REQUEST AND RESPONSES RECEIVED FROM THE MAP THAT
**       DO NOT HAVE A CORRESPONDING HOST REQUEST ENTRY IN MAINFRAME WIRED.
**
**
**     INTERMEDIATE RESPONSE - RC=0100 0000(2) - (*R.INT*)
**
**       THIS RESPONSE CODE IS CURRENTLY NOT PLANNED FOR USE
**       BY MAP-V PP.
**
**
** MAP-V ERROR CODES (*MVEC* PARCEL)
**
**
**   WHEN AN ERROR CONDITION OCCURS, WHILE PROCESSING A PP
**   UNIT REQUEST, SUCH THAT IT RESULTS IN THE
**   REPORTING OF A MAP-V ERROR CODE (*MVEC*), AN ABNORMAL
**   REQUEST TERMINATION CODE IS STORED IN *RC* FIELD
**   AND THERE IS NO FURTHER PROCESSING ATTEMPTED ON THAT
**   PP UNIT REQUEST.
**
**   WHEN AN ERROR CONDITION OCCURS, SUCH THAT IT IS IMPOSSIBLE
**   TO IDENTIFY THE ORIGINAL PP UNIT REQUEST, (I.E. CERTAIN
**   CASES WHILE PROCESSING A MAP-V RESPONSE) AN UNSOLICITED
**   REQUEST TERMINATION CODE IS STORED IN *RC* FIELD AND
**   THE MAP-V ERROR CODE IS STORED IN *MVEC*.
**   THERE IS NO ATTEMPTED BY THE PP TO LINK THE FAILURE WITH
**   A SPECIFIC PP UNIT REQUEST.
**
** --REQUEST/RESPONSE PACKET ERROR (RPE) CODES STORED IN *MVEC*
**
**
** TAG       XX(16) DESCRIPTION
**
** RPE01  -  01  -  REQUEST PACKET LENGTH ERROR
**
**                  THE MINIMUM LENGTH OF A REQUEST PACKET IS 6.
**                  THE VALUE FOUND IN LENGTH FIELD OF REQUEST PACKET
**                  IS LESS THAN 6.
**
** RPE02  -  02  -  REQUEST PACKET WILL NOT FIT IN PP BUFFER
**
**                  THE REQUEST IS LARGER THAN WHAT CAN BE ACCOMODATED
**                  BY THE SIZE OF PPU BUFFER.
**
**
** --ARRAY PROCESSOR ERROR (APE) CODES STORED IN *MVEC*
**
**
** TAG       XX(16) DESCRIPTION
**
** APE10  -  10  -  SEQUENCER BUSY
**
**                  SEQUENCER BUSY (STATUS BIT 0 - WORD 1)
**                  IS CHECKED AFTER EACH MAP-V SEQUENCE
**                  (I.E. AFTER WRITE FLAG SEQUENCE, WRITE REQUEST,
**                  READ RESPONSE OR TRANSFER OF DATA).  IF STATUS
**                  BIT DOES NOT CLEAR BEFORE ASSEMBLY OPTION
**                  LOOP COUNT GOES TO ZERO, AN ABNORMAL
**                  RESPONSE IS STORED IN *RC* FIELD, *K.HDWR* IS SET
**                  IN ABNORMAL STATUS AND *APE10* IS STORED IN
**                  *MVEC* FIELD.
**
**
** APE11  -  11  -  CONTROL PROCESSOR NOT RUNNING
**
**                  CONTROL PROCESSOR RUNNING (STATUS BIT 1 - WORD 1)
**                  IS CHECKED EACH TIME MAP-V HARDWARE STATUS WORD 1
**                  IS READ.  IF BIT IS NOT ON, AN ABNORMAL
**                  RESPONSE IS STORED IN *RC* FIELD AND *APE11*
**                  IS STORED IN *MVEC* FIELD.
**
**
** APE12  -  12  -  HOST CHANNEL SEQUENCE ERROR
**
**                  HOST CHANNEL SEQUENCE ERROR (STATUS BIT 2 - WORD 1)
**                  IS CHECKED AFTER WRITE FLAG FUNCTION SEQUENCE AS
**                  PART OF
**
**                    WRITE REQUEST PACKET
**                    OR READ RESPONSE PACKET.
**
**                  IF HOST CHANNEL SEQUENCE ERROR STATUS BIT IS ON,
**                  WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
**                  RESPONSE IS STORED IN *RC* FIELD AND *APE12* IS
**                  STORED IN *MVEC* FIELD.
**
**
** APE13  -  13  -  CONTROL PROCESSOR SEQUENCE ERROR
**
**                  CONTROL PROCESSOR SEQUENCE ERROR (STATUS BIT 3 - WORD 1)
**                  IS CHECKED AFTER WRITE FLAG FUNCTION SEQUENCE AS
**                  PART OF
**
**                    WRITE REQUEST PACKET
**                     OR READ RESPONSE PACKET.
**
**                  IF CONTROL PROCESSOR SEQUENCE ERROR STATUS BIT IS ON,
**                  WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
**                  RESPONSE IS STORED IN *RC* FIELD AND *APE13* IS
**                  STORED IN *MVEC* FIELD.
**
**
** APE14  -  14  -  COMMAND REJECTED
**
**                  COMMAND REJECTED (STATUS BIT 4 - WORD 1) IS
**                  CHECKED AFTER WRITE FLAG FUNCTION SEQUENCE AS
**                  PART OF
**
**                    WRITE REQUEST PACKET
**                    OR READ RESPONSE PACKET.
**
**                  IF COMMAND REJECTED STATUS BIT IS FOUND ON,
**                  WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
**                  RESPONSE IS STORED IN *RC* FIELD AND *APE14* IS
**                  STORED IN *MVEC* FIELD.
**
**
** APE16  -  16  -  WRITE FLAG STATUS BIT NOT ON
**
**
**
**
**
** APE17  -  17  -  MAIN MEMORY PARITY ERROR
**
**                  MAIN MEMORY PARITY ERROR (STATUS BIT 7 - WORD 1)
**                  INDICATES THAT THE MAP-V HARDWARE HAS DETECTED
**                  A PARITY ERROR IN MAIN MEMORY.
**                  IT IS CHECKED EACH TIME, VIA STATUS WORD 1, THAT
**                  DATA IS WRITTEN INTO OR READ FROM MAIN MEMORY.
**
**                  IF MAIN MEMORY PARITY ERROR STATUS REMAINS ON
**                  AFTER THREE RETRYS,
**                  WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
**                  RESPONSE IS STORED IN *RC* FIELD AND *APE17* IS
**                  STORED IN *MVEC* FIELD.
**
**
** APE18  -  18  -  PUBLIC MEMORY PARITY ERROR
**
**                  PUBLIC MEMORY PARITY ERROR (STATUS BIT 8 - WORD 1)
**                  INDICATES THAT THE MAP-V HARDWARE HAS DETECTED
**                  A PARITY ERROR IN PUBLIC MEMORY.
**                  IT IS CHECKED EACH TIME, VIA STATUS WORD 1, THAT
**                  DATA IS WRITTEN INTO OR READ FROM PUBLIC MEMORY.
**
**                  IF PUBLIC MEMORY PARITY ERROR STATUS REMAINS ON
**                  AFTER THREE RETRYS,
**                  WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
**                  RESPONSE IS STORED IN *RC* FIELD AND *APE18* IS
**                  STORED IN *MVEC* FIELD.
**
**
** APE19  -  19  -  CHANNEL PARITY ERROR
**
**                  CHANNEL PARITY ERROR (STATUS BIT 9 - WORD 1)
**                  INDICATES THAT THE MAP-V INTERFACE
**                  HARDWARE IS NOT IN AGREEMENT WITH THE PARITY
**                  GENERATED BY CYBER CHANNEL HARDWARE ON DATA RECEIVED.
**                  IT IS CHECKED EVERY TIME STATUS WORD 1 IS READ.
**                  IF FOUND ON AFTER THREE RETRIES, *K.OPC* IS SET
**                  SET IN ABNORMAL STATUS PARCEL.
**
**                  A CHANNEL PARITY ERROR MAY ALSO OCCUR ON DATA
**                  RECEIVED AT THE PPU.  FOR THIS CASE,
**                  CHANNEL PARITY (VIA PPU INSTRUCTION) IS CHECKED
**                  EVERY TIME STATUS IS READ AND DATA IS TRANSFERED.
**                  IF ERROR OCCURS IN THIS CASE, ERROR CODE
**                  *EDPC* (PARITY ERROR ON CHANNEL) IS REPORTED
**                  AFTER THREE RETRIES AND *K.CHERR* IS SET IN
**                  ABNORMAL STATUS PARCEL.
**
**
** APE1A  -  1A  -  *APM*  EXPONENT OUT OF RANGE ERROR
**
**
**
**
**
**
** APE22  -  22  -  *APM* INVALID PRECEDING FUNCTION
**
**                  INVALID PRECEDING FUNCTION (STATUS BIT 2 -
**                  WORD 2) IS CHECKED AFTER EVERY WRITE FLAG
**                  FUNCTION.
**
**                  IF INVALID PRECEDING FUNCTION BIT IS FOUND ON,
**                  WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
**                  RESPONSE IS STORED IN *RC* FIELD AND *APE22* IS
**                  STORED IN *MVEC* FIELD.
**
**
** APE23  -  23  -  *APM* NO PERMISSION TO PROCEED
**
**                  PERMISSION TO PROCEED (STATUS BIT 3 - WORD 2) IS
**                  CHECKED AFTER WRITE FLAG FUNCTION SEQUENCE AS
**                  PART OF
**
**                    WRITE REQUEST PACKET
**                    OR READ RESPONSE PACKET.
**
**                  IF PERMISSION TO PROCEED STATUS BIT IS NOT FOUND
**                  ON WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
**                  RESPONSE IS STORED IN *RC* FIELD AND *APE23* IS
**                  STORED IN *MVEC* FIELD.
**
**
** APE26  -  26  -  ERROR IN LAST REQUEST PACKET
**
**                  ERROR IN LAST REQUEST PACKET (STATUS BIT 6 - WORD 2)
**                  IS CHECKED AFTER WRITING REQUEST PACKET TO MAP-V.
**
**                  IF ERROR IN LAST REQUEST PACKET BIT IS FOUND ON,
**                  WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
**                  RESPONSE IS STORED IN *RC* FIELD AND *APE26* IS
**                  STORED IN *MVEC* FIELD.
**
**
** --MAP-V ERROR CODES (*MVEC PARCEL) - AS A RESULT OF CHANNEL RELATED
**                                    PROBLEMS/ERRORS
**
**
** TAG       XX(16) DESCRIPTION
**
** EDNR   -  30  -  NO RESPONSE TO FUNCTION CODE
**
**                  THIS ERROR CODE INDICATES THAT PP TIMED OUT
**                  WAITING FOR A RESPONSE TO A FUNCTION FROM THE
**                  MAP-V CHANNEL INTERFACE HARDWARE.  IF ERROR OCCURS
**                  WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
**                  RESPONSE IS STORED IN *RC* FIELD, *K.HDWR* IS SET
**                  IN ABNORMAL STATUS AND *EDNR* IS STORED IN
**                  *MVEC* FIELD.
**
**
** EDPC   -  31  -  PARITY-ERROR-ON CHANNEL
**
**                  THIS ERROR CODE INDICATES THAT A PP INSTRUCTION
**                  (EITHER CFM/SFM - JUMP IF PARITY ERROR CLEAR/SET)
**                  DETECTED A CHANNEL PARITY ERROR.  THIS ERROR
**                  INDICATES THAT THE CYBER CHANNEL HARDWARE
**                  IS NOT IN AGREEMENT WITH THE PARITY GENERATED
**                  BY MAP-V HARDWARE INTERFACE ON DATA RECEIVED.
**                  IF ERROR PERSISTS AFTER THREE RETRYS,
**                  WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
**                  RESPONSE IS STORED IN *RC* FIELD, *K.CHERR* IS SET
**                  IN ABNORMAL STATUS AND *EDPC* IS STORED IN
**                  *MVEC* FIELD.
**
**                  A CHANNEL PARITY ERROR MAY ALSO OCCUR ON DATA
**                  RECEIVED AT THE MAP-V INTERFACE.  FOR THIS CASE,
**                  CHANNEL PARITY STATUS BIT (BIT 9) IS CHECKED
**                  EVERY TIME STATUS IS READ AND DATA IS TRANSFERED.
**                  IF ERROR PERSISTS AFTER THREE RETRYS,
**                  WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
**                  RESPONSE IS STORED IN *RC* FIELD, *K.OCP* IS SET
**                  IN ABNORMAL STATUS AND *APE19* IS STORED IN
**                  *MVEC* FIELD.
**
**
** EDMT   -  32  -  CHANNEL FAILED TO GO EMPTY
**
**                  THIS ERROR CODE INDICATES THAT PP TIMED OUT
**                  WAITING FOR THE CHANNEL TO GO EMPTY ON OUTPUT TO
**                  MAP-V CHANNEL INTERFACE HARDWARE.  IF ERROR OCCURS
**                  WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
**                  RESPONSE IS STORED IN *RC* FIELD, *K.HDWR* IS SET
**                  IN ABNORMAL STATUS AND *EDMT* IS STORED IN
**                  *MVEC* FIELD.
**
**
** EDIT   -  33  -  INPUT DEADMAN TIMEOUT
**
**                  THIS ERROR CODE INDICATES THAT PP DETECTED AN
**                  INPUT DEADMAN TERMINATE CONDITION ON THE CHANNEL
**                  FROM MAP-V CHANNEL INTERFACE HARDWARE.  IF ERROR
**                  OCCURS WHILE PROCESSING A PP UNIT REQUEST, AN AB-
**                  NORMAL RESPONSE IS STORED IN *RC* FIELD, *K.HDWR*
**                  IS SET IN ABNORMAL STATUS AND *EDIT* IS STORED IN
**                  *MVEC* FIELD.
**
** EDOT   -  34  -  OUTPUT DEADMAN TIMEOUT
**
**                  THIS ERROR CODE INDICATES THAT PP DETECTED AN
**                  OUTPUT DEADMAN TERMINATE CONDITION ON THE CHANNEL
**                  FROM MAP-V CHANNEL INTERFACE HARDWARE.  IF ERROR
**                  OCCURS WHILE PROCESSING A PP UNIT REQUEST, AN AB-
**                  NORMAL RESPONSE IS STORED IN *RC* FIELD, *K.HDWR*
**                  IS SET IN ABNORMAL STATUS AND *EDOT* IS STORED IN
**                  *MVEC* FIELD.
**
**
** EDFL   -  35  -  CHANNEL FULL BEFORE OUTPUT
**
**                  THIS ERROR CODE INDICATES THAT PP DETECTED AN
**                  CHANNEL FULL CONDITION WHILE PREPARING TO OUTPUT TO
**                  MAP-V CHANNEL INTERFACE HARDWARE.  IF ERROR OCCURS
**                  WHILE PROCESSING A PP UNIT REQUEST, AN ABNORMAL
**                  RESPONSE IS STORED IN *RC* FIELD, *K.HDWR* IS SET
**                  IN ABNORMAL STATUS AND *EDFL* IS STORED IN
**                  *MVEC* FIELD.
**
**
** EDAC   -  36  -  CHANNEL ACTIVE BEFORE FUNCTION
**
**                  THIS ERROR CODE INDICATES THAT PP DETECTED A
**                  CHANNEL ACTIVE CONDITION WHILE PREPARING TO SEND
**                  FUNCTION TO MAP-V CHANNEL INTERFACE HARDWARE.
**                  IF ERROR OCCURS WHILE
**                  PROCESSING A PP UNIT REQUEST, AN ABNORMAL
**                  RESPONSE IS STORED IN *RC* FIELD, *K.HDWR* IS SET
**                  IN ABNORMAL STATUS AND *EDAC* IS STORED IN
**                  *MVEC* FIELD.
**
**
** EDNE   -  37  -  CHANNEL EMPTY BEFORE INPUT
**
**                  THIS ERROR CODE INDICATES THAT PP DETECTED A
**                  CHANNEL EMPTY CONDITION WHILE PREPARING TO INPUT
**                  FROM MAP-V CHANNEL INTERFACE HARDWARE.  IF ERROR
**                  OCCURS WHILE PROCESSING A PP UNIT REQUEST, AN AB-
**                  NORMAL RESPONSE IS STORED IN *RC* FIELD, *K.HDWR*
**                  IA SET IN ABNORMAL STATUS AND *EDNE* IS STORED IN
**                  *MVEC* FIELD.
**
**
** EDEI   -  38  -  CHANNEL EMPTY DURING INPUT
**
**                  THIS ERROR INDICATES THAT AN EMPTY CHANNEL CONDITION
**                  WAS DETECTED WHILE INPUTTING DATA.  THE CONTENTS OF
**                  THE A REGISTER WAS NOT ZERO WHEN THE EMPTY CHANNEL
**                  EMPTY CONDITION WAS DETECTED.
**
**
** EDAI   -  39  -  ABNORMAL EXIT FROM AN INPUT INSTRUCTION
**
**                  THIS ERROR INDICATES THAT AN ABNORMAL EXIT FROM AN INPUT
**                  INSTRUCTION WAS DETECTED.  THE CONTENTS OF THE A REGISTER
**                  WERE <> 0, THE CHANNEL WAS FULL AND ACTIVE AT THE TIME OF
**                  ABNORMAL EXIT FROM THE INPUT INSTRUCTION.
**
**
**
*         LIST   *           RESUME LIST
*         LIST   -$          TURN MACRO DEFINITIONS LIST ON/OFF
          TITLE  VM5B - MACRO DEFINITIONS
*copyc iodmac1    "record definition macros"
*copyc iodmac2    "load/store macros"
*copyc iodmac3    "general macros"
*copyc iodmac4    "general macros"
          LIST   *
          TITLE  VM5B - TABLE DEFINITIONS
*
* PP TABLE.
*
 PT       RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 PART     PPWORD             PARTNER PP NUMBER
 PIT      RMA                PP INTERFACE TABLE ADDRESS (RMA)
 PITPVA   STRUCT 24          PP INTERFACE TABLE ADDRESS (PVA)

 PT       RECEND
          SPACE  6
* PP INTERFACE TABLE
*
*
 PIT      RECORD PACKED

 PPNO     PPWORD             PP NUMBER
 FLU      PPWORD             FIRST LOGICAL UNIT
 UNITC    PPWORD             NUMBER OF UNITS
          ALIGN  0,64
 INT      RMA                INTERRUPT WORD (RMA)
 CHAN     RMA                CHANNEL TABLE (RMA)
          ALIGN  16,64
 CBUFL    PPWORD             COMMUNICATION BUFFER LENGTH
 CBUF     RMA                COMMUNICATION BUFFER (RMA)
 LOCK     BOOLEAN            PP REQUEST QUEUE LOCK
          ALIGN  48,64
 LOCKPP   PPWORD             PP REQUEST QUEUE LOCK OWNER
          ALIGN  16,64
 PPQPVA   STRUCT 6           NEXT QUEUED PP REQUEST (PVA)
          ALIGN  32,64
 PPQ      RMA                NEXT QUEUED PP REQUEST (RMA)
          ALIGN  16,64
 RSPVA    STRUCT 14          RESPONSE BUFFER (PVA)
          ALIGN  32,64
 RSBUF    RMA                RESPONSE BUFFER (RMA)
          ALIGN  48,64
 IN       PPWORD             IN POINTER
          ALIGN  48,64
 OUT      PPWORD             OUT POINTER
          ALIGN  48,64
 LIMIT    PPWORD             LIMIT POINTER

 PIT      RECEND
          SPACE  6
*
* UNIT DESCRIPTORS.
*
 UD       RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 UQTPVA   STRUCT 6           UNIT INTERFACE TABLE (PVA)
 CHAN     SUBRANGE 0,377B    CHANNEL NUMBER
 CNTRLR   SUBRANGE 0,377B    CONTROLLER NUMBER
 UNIT     PPWORD             PHYSICAL UNIT NUMBER
 UQT      RMA                UNIT INTERFACE TABLE (RMA)

 UD       RECEND
          SPACE  6
*
* UNIT INTERFACE TABLE
*
 UIT      RECORD PACKED

 LU       PPWORD             LOGICAL UNIT
 DSABLE   BOOLEAN            UNIT IS ENABLED/DISABLED. (SET = DISABLED)
          ALIGN  32,64
 UTYPE    PPWORD             UNIT TYPE
                               = 400B, 844-4X
                               = 401B, 885-1X
                               = 402B, 885-42
 QCNT     PPWORD             QUEUE COUNT
*
          ALIGN  16,64
 UBUFL    PPWORD             UNIT COMMUNICATION BUFFER LENGTH
 UBUF     RMA                UNIT COMMUNICATION BUFFER (RMA)
 ULOCK    BOOLEAN            UNIT IS RESERVED FOR EXCLUSIVE USE
          ALIGN  48,64
 ULOCKP   PPWORD             UNIT LOCK OWNER
 QLOCK    BOOLEAN            UNIT QUEUE LOCK
          ALIGN  48,64
 QLOCKP   PPWORD             UNIT QUEUE LOCK OWNER
          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)

 UIT      RECEND
          SPACE  6
*
*UNIT COMMUNICATION AREA
*
 UCA      RECORD PACKED
 IN       PPWORD
 LIMIT    PPWORD
          ALIGN  0,64        RESERVED
 BID      STRUCT 32          SIXTEEN BLOCK ID ENTRIES

 UCA      RECEND
          SPACE  6
*
* PP REQUESTS.
*
 RQ       RECORD PACKED

          ALIGN  16,64
 NEXTPV   STRUCT 6           NEXT REQUEST ON UNIT QUEUE (PVA)
          ALIGN  32,64
 NEXT     RMA                NEXT REQUEST ON UNIT QUEUE (RMA)
 LEN      PPWORD             REQUEST LENGTH
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS
                               0 - ATTEMPT RECOVERY
                               1 - SUPPRESS RECOVERY, TERMINATE WITH
                                    ABNORMAL STATUS.
                               2 - RESERVED FOR FUTURE USE.
                               3 - SUPPRESS RECOVERY, CONTINUE THE REQUEST
                                    IGNORING ERROR CONDITIONS.
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
 LONGB    BOOLEAN            LONG INPUT BLOCK
          ALIGN  0,64
 CMDIND   SUBRANGE 0,377B    CURRENT COMMAND INDEX.
 MAPIND   SUBRANGE 0,377B    COMMAND INDEX OF CURRENT MAP REQUEST.
          ALIGN  0,64
 CMND     INTEGER            COMMAND SEQUENCE

          MGEN   N.CMDIND
 M.CMDIND EQU    MASK$

          MGEN   N.MAPIND
 M.MAPIND EQU    MASK$

 RQ       RECEND
          SPACE  6
*
* PP COMMAND.
*
 CM       RECORD PACKED

 CODE     SUBRANGE 0,377B    COMMAND CODE
 STOR     BOOLEAN            STORE RESPONSE (IF SET)
 INDIR    BOOLEAN            INDIRECT ADDRESS (IF SET)
          ALIGN  12,64
 CMILS    BOOLEAN            LAST SEGMENT OF PACKED CMI REQUEST
 CKRSP    BOOLEAN            CHECK RESPONSE PACKET ISTAT WORD
          ALIGN  16,64
 LEN      PPWORD             LENGTH OF CM AREA (EITHER DATA AREA OR
                             LENGTH/ADDRESS WORD PAIR LIST)
 RMA      RMA                ADDRESS OF CM AREA
          MASKP  STOR
 K.STOR   EQU    MSK
          MASKP  INDIR
 K.INDIR  EQU    MSK
          MASKP  CMILS
 K.CMILS  EQU    MSK
          MASKP  CKRSP
 K.CKRSP  EQU    MSK
          MGEN   N.CODE
 M.CODE   EQU    MASK$

 CM       RECEND
          SPACE  6
*
* PP RESPONSE.
*
 RS       RECORD PACKED

          ALIGN  16,64
 PVA      STRUCT 6           PVA OF REQUEST
          ALIGN  32,64
 REQ      RMA                RMA OF REQUEST
 RESPL    PPWORD             RESPONSE LENGTH  (8-BIT BYTES)
 LU       PPWORD             LOGICAL UNIT
 RECOV    SUBRANGE 0,3       ERROR RECOVERY OPTIONS (FROM REQUEST)
 INT      BOOLEAN            INTERRUPT CPU (IF SET)
 PORT     SUBRANGE 0,37B     MEMORY PORT USED FOR INTERRUPTS
          ALIGN  40,64
 PRIOR    SUBRANGE 0,377B    PRIORITY
          ALIGN  48,64
          ALIGN  48,64       ALERT MASK
 LONGB    BOOLEAN            LONG INPUT BLOCK
          ALIGN  0,64
 ABALRT   BOOLEAN            ABNORMAL ALERT CONDITION DETECTED
 INTERR   BOOLEAN            LOGICAL INTERFACE ERROR (INCLUDE INTERFACE
                             ERROR CODE)
 FORC     BOOLEAN            FORCED TERMINATION AS A RESULT OF STOP UNIT COMMAND
 CHERR    BOOLEAN            CHANNEL PARITY ERROR ON INPUT
 DATOV    BOOLEAN            DATA OVERRUN. A LOST DATA CONDITION
                             OCCURRED ON INPUT OR INADEQUATE DATA RATE ON OUTPUT
 DATERR   BOOLEAN            UNCORRECTABLE PARITY OR CHECKWORD ERROR
                             ON AN ADDRESS OR DATA FIELD.
 HDWR     BOOLEAN            UNCORRECTABLE HARDWARE MALFUNCTION IN A
                             CONTROLLER OR UNIT
 NRDY     BOOLEAN            INTERVENTION REQUIRED BY OPERATOR ON A
                             HARDWARE MALFUNCTION.  EX: UNIT NOT READY,
                             UNIT NOT CONNECTED.
 FTO      BOOLEAN            FUNCTION TIMEOUT
 OCP      BOOLEAN            CHANNEL PARITY ERROR ON OUTPUT
          ALIGN  16,64
 IEC      PPWORD             INTERFACE ERROR CODE
 RC       SUBRANGE 0,3       RESPONSE CODE
                               0 - UNSOLICITED RESPONSE
                               1 _ INTERMEDIATE RESPONSE
                               2 - NORMAL REQUEST TERMINATION
                               3 - ABNORMAL REQUEST TERMINATION
 RCON     SUBRANGE 0,3       ADDITIONAL RESPONSE CONDITIONS
                             (= 0 FOR UNSOLICITED RESPONSE)
                               0 - NO ADDITIONAL CONDITION
                               1 - RECOVERED ERROR
                               2 - COMMAND HAD EXPLICIT RESPONSE FLAG SET
                               3 - BOTH CONDITIONS 1 AND 2
          ALIGN  40,64
 URC      SUBRANGE 0,377B    UNSOLICITED RESPONSE CODE
                               1 - UNIT CHANGED FROM READY TO NOT READY
                               2 - UNIT CHANGED FROM NOT READY TO READY
                               3 - ABNORMAL CONDITION DURING HOUSEKEEPING CYCLE,
                                   (CHECK ABNORMAL STATUS OR INTERFACE ERROR CODE)
          ALIGN  48,64       ALERT CONDITIONS
 LNGBLK   BOOLEAN            LONG INPUT BLOCK
 COMPRC   BOOLEAN            COMPARE NOT SATISFIED ON COMPARE/SWAP COMMAND
 PDLIM    BOOLEAN            PHYSICAL DELIMITER ENCOUNTERED (EOT OR BOT)
 LDLIM    BOOLEAN            LOGICAL DELIMITER ENCOUNTERED (TAPE MARK)
 CHARF    BOOLEAN            CHARACTER FILL PERFORMED
          ALIGN  0,64
 XFER     STRUCT 4           TRANSFER COUNT
 LASTC    RMA                LAST COMMAND (RMA)
 MPREST   INTEGER            TIME RESPONSE RETURNED FROM MAP
 PPREST   INTEGER            TIME RESPONSE SENT TO MTR
 GSP1     PPWORD             GENERAL STATUS PREVIOUS-WORD 1 SNAPSHOT
 GSP2     PPWORD             GENERAL STATUS PREVIOUS-WORD 2 SNAPSHOT
 GSC1     PPWORD             GENERAL STATUS CURRENT-WORD 1 SNAPSHOT
 GSC2     PPWORD             GENERAL STATUS CURRENT-WORD 2 SNAPSHOT
 MVEC     PPWORD             MAP-V ERROR CODE
 PPLF     PPWORD             PP LAST FUNCTION CODE
 PPEA     PPWORD             PP ERROR ADDRESS
 PPRRC    PPWORD             REQUEST (+1) = RESPONSE (-1) COUNTER
          STRUCT 2           FILL FOR FULL CM WORDS


          MASKP  INT
 K.INT    EQU    MSK
          MGEN   N.PORT
 M.PORT   EQU    MASK$

          MASKP  ABALRT
 K.ABALRT EQU    MSK
          MASKP  INTERR
 K.INTERR EQU    MSK
          MASKP  FORC
 K.FORC   EQU    MSK
          MASKP  CHERR
 K.CHERR  EQU    MSK
          MASKP  DATOV
 K.DATOV  EQU    MSK
          MASKP  DATERR
 K.DATERR EQU    MSK
          MASKP  HDWR
 K.HDWR   EQU    MSK
          MASKP  NRDY
 K.NRDY   EQU    MSK
          MASKP  FTO
 K.FTO    EQU    MSK
          MASKP  OCP
 K.OCP    EQU    MSK
          MASKP  LNGBLK
 K.LNGBLK EQU    MSK
          MASKP  PDLIM
 K.PDLIM  EQU    MSK
          MASKP  LDLIM
 K.LDLIM  EQU    MSK
          MASKP  CHARF
 K.CHARF  EQU    MSK

 RS       RECEND
          SPACE  6
** MAPWORD MACRO
** THIS MACRO DEFINES THE NAMED FIELD AS A 4 BYTE (32 BITS) FIELD

          MACRO  MAPWORD,NAME
 NAME     STRUCT 4
          ENDM
          SPACE  6
*
* MAP REQUEST BLOCK - PACKED
*
 RQBP     RECORD PACKED
 PTIM     INTEGER              PP TIME STAMP
 MTIM     INTEGER              MAP TIME STAMP
 JID      MAPWORD              JOB IDENTIFIER
 RSN      MAPWORD              REQUEST SERIAL NUMBER
 RES      MAPWORD              RESERVED FOR STAR TECHNOLOGIES
 FC       MAPWORD              FUNCTION CODE
 LNG      MAPWORD              LENGTH OF THE REQUEST (32 BIT WORD)
 RPKT     MAPWORD              FIRST MAPWORD OF MAP REQUEST PACKET
 RQBP     RECEND
          SPACE  6
*
* MAP REQUEST BLOCK - UNPACKED
*
 RQBUP    RECORD
 PTIM     INTEGER              PP TIME STAMP
 MTIM     INTEGER              MAP TIME STAMP
          ALIGN  32,64
 JID      MAPWORD              JOB IDENTIFIER
          ALIGN  32,64
 RSN      MAPWORD              REQUEST SERIAL NUMBER
          ALIGN  32,64
 RES      MAPWORD              RESERVED FOR STAR TECHNOLOGIES
          ALIGN  32,64
 FC       MAPWORD              FUNCTION CODE
          ALIGN  32,64
 LNG      MAPWORD              LENGTH OF THE REQUEST (32 BIT WORD)
 RQBUP    RECEND
          SPACE  6
*
* STLOD REQUEST PACKET - PACKED
*
 STLODP   RECORD PACKED
 PROCID   MAPWORD            PROCESS IDENTIFICATION
 OFFSET   MAPWORD
 SEGLNG   MAPWORD            LENGTH OF THE HOST PROCESS (32 BIT WORD)
 CKSUM    MAPWORD            CHECKSUM
 STLODP   RECEND
          SPACE  6
*
* STLOD REQUEST PACKET - UNPACKED
*
 STLOD    RECORD
 PROCID   MAPWORD            PROCESS IDENTIFICATION
 OFFSET   MAPWORD
 SEGLNG   MAPWORD            LENGTH OF THE HOST PROCESS (32 BIT WORD)
 CKSUM    MAPWORD            CHECKSUM
 STLOD    RECEND
          SPACE  6
*
* STREAD AND STWRITE REQUEST PACKET - PACKED
*
 STRWP    RECORD PACKED
 ARAYID   MAPWORD            ARRAY IDENTIFICATION
 HADDR    MAPWORD            HOST ADDRESS
 HDATAL   MAPWORD            HOST WORD COUNT (32 BIT WORD)
 CKSUM    MAPWORD            CHECKSUM
 STRWP    RECEND
          SPACE  6
*
* STREAD AND STWRITE REQUEST PACKET - UNPACKED
*
 STRW     RECORD
 ARAYID   MAPWORD            ARRAY IDENTIFICATION
 HADDR    MAPWORD            HOST ADDRESS
 HDATAL   MAPWORD            HOST WORD COUNT (32 BIT WORD)
 CKSUM    MAPWORD            CHECKSUM
 STRW     RECEND
          SPACE  6
*
* MAP RESPONSE PACKET - PACKED
*
 MRSBP    RECORD  PACKED
 JID      MAPWORD            JOB IDENTIFIER
 RSN      MAPWORD            REQUEST SERIAL NUMBER
 IST      MAPWORD            I-STATUS
 JST      MAPWORD            J-STATUS
 KST      MAPWORD            K-STATUS
 CKSUM    MAPWORD            CHECKSUM
 MRSBP    RECEND
          SPACE  6
*
* MAP STATUS WORDS
*
          SPACE  4,40
*         STATUS WORD ONE (HARDWARE STATUS)

*         BIT 11  NOT USED
*             10  EXPONENT OUT OF RANGE ERROR
*              9  CHANNEL PARITY ERROR
*              8  PUBLIC MEMORY PARITY ERROR
*              7  MAIN MEMORY PARITY ERROR
*              6  WRITE FLAG ADDRESS PRIMED - (READY FOR TWO 60 BIT
*                                              CONTROL WORDS)
*              5  TRANSFER PRIMED - (READY FOR DATA TRANSFER)
*              4  COMMAND REJECTED
*              3  CONTROL PROCESSOR SEQUENCE ERROR
*              2  HOST CHANNEL SEQUENCE ERROR
*              1  CONTROL PROCESSOR RUNNING
*              0  BUSY
          SPACE  6
 MPHSTS   RECORD PACKED
          ALIGN  5,16
 EXPOR    BOOLEAN
 CHPER    BOOLEAN
 PMPE     BOOLEAN
 MMPE     BOOLEAN
 WFPRI    BOOLEAN
 TDATA    BOOLEAN
 CMNRJ    BOOLEAN
 CPSQE    BOOLEAN
 HCSQE    BOOLEAN
 CPRUN    BOOLEAN
 HBSY     BOOLEAN
          MASKP  EXPOR
 K.EXPOR  EQU    MSK
          MASKP  CHPER
 K.CHPER  EQU    MSK
          MASKP  PMPE
 K.PMPE   EQU    MSK
          MASKP  MMPE
 K.MMPE   EQU    MSK
          MASKP  WFPRI
 K.WFPRI  EQU    MSK
          MASKP  TDATA
 K.TDATA  EQU    MSK
          MASKP  CMNRJ
 K.CMNRJ  EQU    MSK
          MASKP  CPSQE
 K.CPSQE  EQU    MSK
          MASKP  HCSQE
 K.HCSQE  EQU    MSK
          MASKP  CPRUN
 K.CPRUN  EQU    MSK
          MASKP  HBSY
 K.HBSY   EQU    MSK
 MPHSTS   RECEND
          SPACE  4,36
*         STATUS WORD 2 (SOFTWARE STATUS).

*         BIT 11  RESERVED
*             10  RESERVED
*              9  RESERVED
*              8  RESERVED
*              7  RESERVED
*              6  (E) ERROR IN LAST REQUEST PACKET
*              5  (S) SPECIFIC JID RESPONSE PACKET AVAILABLE
*              4  (R) RESPONSE PACKET(S) AVAILABLE (ANY ID)
*              3  (P) PERMISSION TO PROCEED WITH REQUEST PKT XMISSION
*              2  (I) INVALID PRECEDING MAP-V FUNCTION
*              1  (O) ON-LINE
*              0  (B) BUSY - APM LOGICALLY BUSY
          SPACE  6
 MPSSTS   RECORD PACKED
          ALIGN  9,16
 LRPE     BOOLEAN
 SRESA    BOOLEAN
 RESA     BOOLEAN
 TRQP     BOOLEAN
 LFUNI    BOOLEAN
 ONL      BOOLEAN
 SBSY     BOOLEAN
          MASKP  LRPE
 K.LRPE   EQU    MSK
          MASKP  SRESA
 K.SRESA  EQU    MSK
          MASKP  RESA
 K.RESA   EQU    MSK
          MASKP  TRQP
 K.TRQP   EQU    MSK
          MASKP  LFUNI
 K.LFUNI  EQU    MSK
          MASKP  ONL
 K.ONL    EQU    MSK
          MASKP  SBSY
 K.SBSY   EQU    MSK
 MPSSTS   RECEND
          TITLE  VM5B - EQUATES
*
* COMMAND CODES.
*
 C.ACK    EQU    0           ACKNOWLEDGE
 C.STOP   EQU    1           STOP UNIT
 C.SELU   EQU    2           SELECT UNIT
 C.SELC   EQU    3           SELECT CONTROLLER
 C.IDLE   EQU    4           IDLE
 C.RESUME EQU    5           RESUME
 C.OLAY   EQU    6           EXECUTE OVERLAY
 C.READY  EQU    7           START READY SCAN
 C.SREADY EQU    10B         STOP READY SCAN
 C.PPAD   EQU    11B         SELECT PP MEMORY ADDRESS
 C.PPMEM  EQU    12B         COPY PP MEMORY
 C.ENABU  EQU    20B         ENABLE UNIT
 C.DISABU EQU    21B         DISABLE UNIT
 C.MCCTR  EQU    27B         MASTER CLEAR CONTROLLER
 C.FUNC   EQU    40B         OUTPUT FUNCTION
 C.OUTP   EQU    41B         OUTPUT 8-BIT PARAMETERS
 C.OUTD   EQU    43B         OUTPUT 8-BIT DATA
 C.IND    EQU    45B         INPUT 8-BIT DATA/PARAMETERS
 C.READ   EQU    100B        READ BYTES
 C.WRITE  EQU    120B        WRITE BYTES
 C.STATUS EQU    140B        READ STATUS
 C.COUNT  EQU    141B        STORE TRANSFER COUNT
 C.SWAP   EQU    160B        COMPARE AND SWAP
 C.WRITEI EQU    162B        WRITE INITIALIZE
 C.RFLAW  EQU    163B        READ FLAW MAPS
 C.WRITEV EQU    200B        WRITE VERIFY
          SPACE  6
*
*         RESPONSE CODES.
*
 R.UNS    EQU    0           UNSOLICITED RESPONSE
 R.INT    EQU    40000B      INTERMEDIATE RESPONSE
 R.NRM    EQU    100000B     NORMAL REQUEST TERMINATION
 R.ABN    EQU    140000B     ABNORMAL REQUEST TERMINATION
 R.RCV    EQU    10000B      RECOVERED ERROR CAUSED RESPONSE
 R.FLG    EQU    20000B      FLAG FIELD CAUSED RESPONSE
*
*         UNSOLICITED RESPONSE CODES
*
 URC.RN   EQU    1           CHANGE FROM READY TO NOT READY
 URC.NR   EQU    2           CHANGE FROM NOT READY TO READY
 URC.IE   EQU    3           INTERNAL OR INTERFACE ERROR
 URC.NRQ  EQU    4           NO REQUEST FOR A RESPONSE
          SPACE  6
 DSC      EQU    0           DST-DSP COMMUNICATIONS CHANNEL

 TIMERR   EQU    400B        TIMEOUT INTERFACE ERROR CODE BASE
 PITERR   EQU    1000B       PIT INTERFACE ERROR CODE BASE
 UITERR   EQU    1400B       UIT INTERFACE ERROR CODE BASE
 RQHERR   EQU    2000B       REQUEST HEADER INTERFACE ERROR CODE BASE
 CMDERR   EQU    2400B       COMMAND SEQUENCE INTERFACE ERROR CODE BASE

 PITLEN   EQU    C.PIT+C.UD*3  LENGTH OF PP INTERFACE TABLE IN CM WORDS

 DISABLE  EQU    100000B     DISABLE UNIT BIT IN UIT

 MAXIND   EQU    2           MAX INDIRECT LIST LENGTH
 MAXFCL   EQU    16          MAX FUNCTION CODE LENGTH = 16 BITS
 HEADLN   EQU    32          REQUEST HEADER LENGTH = 32 BYTES
 HDRWDS   EQU    HEADLN/8    REQUEST HEADER LENGTH IN CM WORDS
 MAXREQ   EQU    14          MAX REQUEST LENGTH IN CM WORDS
 MAXCMD   EQU    MAXREQ-HDRWDS   MAX NO. COMMANDS IN REQUEST BUFFER
 MAXREQB  EQU    MAXREQ*8    MAX REQUEST LENGTH IN BYTES
 UDLEN    EQU    8           LENGTH OF UNIT DESCRIPTOR IN PP WORDS
 RESPBL   EQU    68          RESPONSE BUFFER LENGTH = 68 PP WORDS
 ENDMEM   EQU    7777B       LARGEST PP MEMORY ADDRESS
 HCS      EQU    7767B       DEFINE FWA OF HIGH CORE SCRATCH
 IOBUFLNG EQU    790D        LENGTH OF I/O BUFFER
 STIOBUF  EQU    ENDMEM-IOBUFLNG-10B  STARTING ADDRESS OF I/O BUFFER

 LENRS    EQU    40          SHORT RESPONSE BUFFER LENGTH IN BYTES
 LENRS1   EQU    LENRS+16+8  MEDIUM RESPONSE BUFFER LENGTH IN BYTES
 LENRS2   EQU    LENRS1+8    LONG RESPONSE BUFFER LENGTH IN BYTES
 LPPCMD   EQU    37B         LAST LEGAL PP COMMAND
 RSUMCMD  EQU    5           PP RESUME COMMAND

 ERC101   EQU    1           PP REQUEST QUEUE LOCKWORD TIMEOUT
 ERC102   EQU    ERC101+1    UNIT REQUEST QUEUE LOCKWORD TIMEOUT
 ERC103   EQU    ERC102+1    UNIT LOCKWORD TIMEOUT
 ERC104   EQU    ERC103+1    CHANNEL LOCKWORD TIMEOUT
 ERC105   EQU    ERC104+1    BUFFER POOL LOCKWORD TIMEOUT
 ERC106   EQU    ERC105+1    UNIT HARDWARE RESERVE TIMEOUT
 ERC107   EQU    ERC106+1    CONTROLLER HARDWARE RESERVE TIMEOUT
 ERC201   EQU    1           RESERVED FIELD OF PP INT TBL HEAD NOT 0
 ERC202   EQU    ERC201+1    RMA OF INTERRUPT WORD NOT A WORD BOUNDARY
 ERC203   EQU    ERC202+1    RMA OF PP COMM BUF NOT A WORD BOUNDARY
 ERC204   EQU    ERC203+1    RESERVED FIELD OF PP COMM DESCRIPTOR NOT 0
 ERC205   EQU    ERC204+1    RESERVED FIELD OF QUEUE DESCRIPTOR NOT 0
 ERC206   EQU    ERC205+1    RMA OF NEXT PP NOT A WORD BOUNDARY
 ERC207   EQU    ERC206+1    RESERVED FIELD OF RESP BUF DESCRIPTOR NOT 0
 ERC208   EQU    ERC207+1    LOGICAL UNIT OUT OF RANGE
 ERC209   EQU    ERC208+1    RMA OF UIT NOT A WORD BOUNDARY
 ERC20A   EQU    ERC209+1    INVALID CHANNEL NUMBER IN UNIT DESCRIPTOR
 ERC20B   EQU    ERC20A+1    RMA OF CHANNEL TABLE NOT ON WORD BOUNDARY
 ERC301   EQU    1           LOGICAL UNIT NUMBER MISMATCH
 ERC302   EQU    ERC301+1    RMA OF UNIT COMM BUF NOT A WORD BOUNDARY
 ERC303   EQU    ERC302+1    RESERVED FIELD OF UNIT COMM BUF DESCRIPTOR NOT 0
 ERC304   EQU    ERC303+1    RMA OF NEXT UNIT REQUEST NOT WORD BOUNDARY
 ERC305   EQU    ERC304+1    RESERVED FIELD OF QUEUE DESCRIPTOR NOT 0
 ERC306   EQU    ERC305+1    RESERVED FIELD IN HEADER NOT ZERO
 ERC307   EQU    ERC306+1    ILLEGAL DEVICE TYPE
 ERC401   EQU    1           RMA OF NEXT REQUEST NOT A WORD BOUNDARY
 ERC402   EQU    ERC401+1    REQUEST LENGTH NOT A MULTIPLE OF 8 BYTES
 ERC403   EQU    ERC402+1    REQUEST LENGTH IS LESS THAN FOURTY BYTES
 ERC404   EQU    ERC403+1    LOGICAL UNIT NO .NE. UNIT NO IN INTERFACE TBL
 ERC405   EQU    ERC404+1    RESERVED LINKAGE FIELD IS NOT ZERO
 ERC406   EQU    ERC405+1    INVALID RECOVERY/INTERFACE SELECTIONS
 ERC407   EQU    ERC406+1    INVALID PRIORITY SELECTION
 ERC408   EQU    ERC407+1    INVALID SECONDARY ADDRESS
 ERC409   EQU    ERC408+1    INVALID ALERT CONDITION
 ERC40A   EQU    ERC409+1    REQUEST LENGTH TOO LARGE > 224 BYTES
 ERC501   EQU    1           INVALID COMMAND CODE
 ERC502   EQU    ERC501+1    INVALID FLAG SELECTION
 ERC503   EQU    ERC502+1    INVALID FUNCTION
 ERC504   EQU    ERC503+1    FUNCTION NOT SUPPORTED BY HARDWARE
 ERC505   EQU    ERC504+1    INVALID LENGTH SPECIFICATION IN COMMAND
 ERC506   EQU    ERC505+1    INVALID ADDRESS SPECIFICATION IN COMMAND
 ERC507   EQU    ERC506+1    INVALID LENGTH SPECIFICATION IN INDIRECT LIST
 ERC508   EQU    ERC507+1    INVALID ADDRESS SPECIFICATION IN INDIRECT LIST
 ERC509   EQU    ERC508+1    PP COMMAND NOT ALLOWED IN REQUEST TO A UNIT
 ERC50A   EQU    ERC509+1    INVALID SEQUENCE OF COMMANDS
 ERC50B   EQU    ERC50A+1    INVALID PARAMETER SPECIFICATION
 ERC50C   EQU    ERC50B+1    RESERVED FIELD IN INDIRECT LIST NOT 0
          EJECT
          SPACE  4,10
*         FUNCTION CODES FOR CONTROL OF THE MAP HARDWARE.

 FCMC     EQU    0100B       MASTER CLEAR INTERFACE
 FCWF     EQU    0200B       WRITE FLAG (FOLLOWED BY OUTPUT OF TWO
                                         60 BIT CONTROL WORDS)
 FCWR     EQU    0400B       WRITE REQUEST (FOLLOWED BY OUTPUT OF
                                            REQUEST PACKET)
 FCBW     EQU    0401B       BLOCK WRITE (FOLLOWED BY OUTPUT OF DATA)
 FCRR     EQU    0500B       READ RESPONSE (FOLLOWED BY INPUT OF
                                            RESPONSE PACKET)
 FCBR     EQU    0501B       BLOCK READ (FOLLOWED BY INPUT OF DATA)
 FCHS1    EQU    0600B       READ HARDWARE STATUS WORD ONE
 FCHS2    EQU    0601B       READ HARDWARE STATUS WORDS ONE AND TWO

*         SPECIAL HARDWARE FUNCTION CODES.

 FCCS     EQU    0277B       CLEAR SEQUENCER
 FCMD     EQU    0300B       MAIN-MEMORY DUMP (SET ADDRESS AND LENGTH)
 FCML     EQU    0301B       MAIN-MEMORY LOAD (SET ADDRESS AND LENGTH)
 FCPD     EQU    0302B       PUBLIC-MEMORY DUMP (SET ADDRESS AND LENGTH)
 FCPL     EQU    0303B       PUBLIC-MEMORY LOAD (SET ADDRESS AND LENGTH)

*         DIAGNOSTIC FUNCTIONS.

 FCT04    EQU    0304B       TEST XMIT/REC AND CABLE WITH
                               SIMPLE PATTERNS
*         FC     03X5B       TEST IOP NUMERICAL CONVERSION
                               UNIT DATA PATHS
 FCT05    EQU    0305B       TEST C-170 60 BIT SINGLE PRECISION
                               FLOATING POINT FORMAT
 FCT15    EQU    0315B       TEST C-170 60 BIT FIXED POINT FORMAT
 FCT25    EQU    0325B       TEST C-170 30-BIT FLOATING POINT FORMAT
                               (MAP III EXTERNAL FORMAT)
 FCT35    EQU    0335B       TEST RIGHTMOST 32-BIT OF C-170 60-BIT
                               WORD FORMAT
 FCT06    EQU    0306B       TEST IOP COMMON LOGIC

*         DIRECT MEMORY ACCESS (DMA) FUNCTION CODES.

*         070X - RESERVED FOR DIRECT MEMORY ACCESS FUNCTIONS.

          SPACE  4,20
*         APM SOFTWARE FUNCTION CODES.

*                WORD 1 (60 BITS).

*                BITS 59-32 UNUSED
*                     31-08 RESERVED
*                     07-00 FC - FUNCTION CODE

*                WORD 2 (60 BIT).

*                BITS 59-32 UNUSED
*                     31-00 PARM - PARAMETER


*                FC    PARAM        DESCRIPTION
*                --    -----        -----------
*                 0   LENGTH   REQUEST TO TRANSMIT REQUEST PACKET
*                                OF *LENGTH* 32-BIT WORDS TO THE MAP.
*                 1      0     REQUEST TO RECEIVE NEXT RESPONSE PACKET
*                                FROM THE MAP.
*                 2     JID    REQUEST TO RECEIVE NEXT RESPONSE PACKET
*                                FOR JOB *JID* FROM THE MAP.
*                 3      0     REQUEST TO RECEIVE LAST RESPONSE PACKET
*                                OVER AGAIN.
*                 4      0     SOFTWARE INITIATED MASTER CLEAR.
*                 5      0     PERFORM JID LIST TO CHANNEL.
*                                THIS APM FUCTION CODE IS FOLLOWED
*                                BY HARDWARE FUNCTION CODE 0500
*                                (READ PUBLIC MEMORY).  THE FIRST WORD
*                                CONTAINS WORD COUNT.  (MAY BE ZERO)

*         FUNCTION CODES - APM - EQUATES.

 FCAT     EQU    0           TRANSMIT REQUEST PACKET
 FCAN     EQU    1           NEXT RESPONSE PACKET INPUT
 FCAJ     EQU    2           JID RESPONSE PACKET INPUT
 FCAR     EQU    3           RE-TRANSMIT LAST RESPONSE PACKET
 FCAC     EQU    4           CLEAR (SOFTWARE MASTER CEAR)
 FCAQ     EQU    5           (RESPONSE) QUEUE LIST OF JIDS

*         CHANNEL VALUES (THE CHANNEL NUMBER IS INSERTED LATER).
*         (BIT 2**5 IS ONLY USED ON IAN AND DCN INSTRUCTIONS).

 CH00     EQU    00          WITHOUT CHANNEL BIT
 MCH      EQU    17B         MAINTENANCE CHANNEL
 CH40     EQU    40B         WITH CHANNEL BIT
 CH14     EQU    14B         TAG FOR CHANNEL 14B

*         ERROR CODES FOR REQUEST PACKET CONDITIONS.

 RPE01    EQU    01          REQUEST PACKET LENGTH ERROR
 RPE02    EQU    02          REQUEST PACKET WILL NOT FILL IN PP BUFFER

*         ERROR CODES FOR ARRAY PROCESSOR CONDITIONS.

 APE10    EQU    20B         10(16) - SEQUENCER BUSY
 APE11    EQU    21B         11(16) - CONTROL PROCESSOR NOT RUNNING
 APE12    EQU    22B         12(16) - HOST CHANNEL SEQUENCE ERROR
 APE13    EQU    23B         13(16) - CONTROL PROCESSOR SEQUENCE ERROR
 APE14    EQU    24B         14(16) - COMMAND REJECTED
 APE15    EQU    25B         15(16) - TRANSFER PRIMED STATUS BIT NOT ON
 APE16    EQU    26B         16(16) - WRITE FLAG STATUS BIT NOT ON
 APE17    EQU    27B         17(16) - MAIN MEMORY PARITY ERROR
 APE18    EQU    30B         18(16) - PUBLIC MEMORY PARITY ERROR
 APE19    EQU    31B         19(16) - CHANNEL PARITY ERROR
 APE1A    EQU    32B         1A(16) - EXPONENT OUT OF RANGE ERROR

 APE20    EQU    40B         20(16) - *APM* LOGICALLY BUSY
 APE21    EQU    41B         21(16) - *APM* NOT ON LINE
 APE22    EQU    42B         22(16) - *APM* INVALID PRECEDING FUNCTION
 APE23    EQU    43B         23(16) - *APM* NO PERMISSION TO PROCEED
 APE26    EQU    46B         26(16) - ERROR IN LAST REQUEST PACKET

*         ERROR CODES USED FOR MAP-V HARDWARE.

 EDNR     EQU    60B         30(16) - NO RESPONSE TO FUNCTION CODE
 EDPC     EQU    61B         31(16) - PARITY-ERROR-ON CHANNEL
 EDMT     EQU    62B         32(16) - CHANNEL FAILED TO GO EMPTY
 EDIT     EQU    63B         33(16) - INPUT DEADMAN TIMEOUT
 EDOT     EQU    64B         34(16) - OUTPUT DEADMAN TIMEOUT
 EDFL     EQU    65B         35(16) - CHANNEL FULL BEFORE OUTPUT
 EDAC     EQU    66B         36(16) - CHANNEL ACTIVE BEFORE FUNCTION
 EDNE     EQU    67B         37(16) - CHANNEL EMPTY BEFORE INPUT
 EDEI     EQU    70B         38(16) - CHANNEL EMPTY DURING INPUT
 EDAI     EQU    71B         39(16) - ABNORMAL EXIT FROM AN INPUT INSTRUCTION

*         ASSEMBLY EQUATES.

 NTWQ     EQU    2           NUMBER-OF TIME-STAMP WORDS-PRECEDING REQ.
*         INSTALLATION OPTIONS.

 OPTR     EQU    10D         NUMBER OF RETRIES BEFORE FAILURE

*         ST100 USER CALL FUNCTION CODES INTERROGATED BY VM5.

 STSCH    EQU    2           SCHEDULE - RESPOND WHEN RESOURCES ARE AVAILABLE
 STLOD    EQU    4           LOAD
 STRUN    EQU    7           RUN
 STWR     EQU    8D          WRITE
 STRD     EQU    9D          READ
 STACT    EQU    12D         ACCOUNTING
 STDUMP   EQU    13D         DUMP
 STEFR    EQU    20D         ENGINEERING FILE RETURN
          TITLE  VM5B - DIRECT CELLS

* DIRECT CELLS

          CON    PRS-1       START OF PRESET (INITIALIZATION) ROUTINE

 T0       EQU    0
 T1       BSSZ   1           SCRATCH CELLS
 T2       BSSZ   1
 T3       BSSZ   1
 T4       BSSZ   1
 T5       BSSZ   1
 T6       BSSZ   1
 ONE      CON    1           CONSTANT OF ONE
 WC       BSSZ   1           CM WORD COUNT
 P1       BSSZ   1
 P2       BSSZ   1
 P3       BSSZ   1
 P4       BSSZ   1
 P5       BSSZ   1

 BYTCNT   BSSZ   1           NUMBER OF BYTES TO TRANSFER THIS I/O
 CMADR    BSSZ   3           CENTRAL MEMORY ADDRESS
 CMDADR   BSSZ   1           ADDRESS OF ACTIVE COMMAND
 CMDADR1  BSSZ   1           ADDRESS OF LENGTH IN ACTIVE COMMAND
 CMDNO    BSSZ   1           NUMBER OF REMAINING COMMANDS
 CM.RS    BSSZ   3           CM ADDR OF RESPONSE BUFFER (8 BIT BYTES)
 CM.PIT   BSSZ   3           CM ADDR OF PP INTERFACE TBL (REFORMATED)
 CM.UIT   BSSZ   3           CM ADDR OF UNIT INTERFACE TBL (REFORMATED)
 DIAFLG   BSSZ   1           DIAGNOSTIC FLAG
 DIAFND   BSSZ   1           = 0 - DIAGNOSTIC FUNCTION WITH NO ASSOIATED DATA
                             <> 0 - DIAGNOSTIC FUNCTION WITH ASSOCIATED DATA
 FCNRCD   BSSZ   1           FUNCTION REQUEST CODE
 F16BIO   CON    0           FLAG 16 BIT I/O CHANNEL INSTRUCTIONS
 IDLFLG   CON    1           IDLE FLAG, IF NONZERO DO ONLY PP REQUESTS
 IOCNT    BSSZ   1           NUMBER OF PP WORDS TO TRANSFER THIS I/O
 LAFLG    BSSZ   1           COMMAND LOOK AHEAD FLAG
 LIM      BSSZ   1           LIMIT OF RESPONSE BUFFER (IN 8 BIT BYTES)
 MPCMDI   BSSZ   1           COMMAND INDEX OF COMMAND CONTAINING CURRENT MAP REQUEST.
 PPHUNG   BSSZ   1           1 = PP HUNG
 PPLOCK   BSSZ   1           PP LOCKED FLAG

*         PST AND ST AREAS MUST REMAIN TOGETHER AND IN THIS ORDER

 PST      BSSZ   2           PREVIOUS MAP-V HARDWARE STATUS READ
 ST       BSSZ   2           MAP-V HARDWARE STATUS
 SCNFLG   BSSZ   1           SCAN UNITS FLAG
 UDPNT    BSSZ   1           UNIT DESCRIPTOR POINTER
 ULOCK    BSSZ   1           UNIT LOCKED FLAG
 UNITP    BSSZ   1           UNIT POINTER
 UQFLG    BSSZ   1           UNIT QUEUE FLAG 1-REQUEST FROM UNIT QUEUE
                                             0-REQUEST FROM PP QUEUE
 UQLOCK   BSSZ   1           UNIT QUEUE LOCK FLAG
 XBIA     BSSZ   1           CHANNEL I/O ADDRESS BIAS INCREMENT
 XPWB     BSSZ   1           PP WORDS PER BLOCK TRANSFER
 XRQA     BSSZ   2           PP REQUEST (RQ) ADDRESS RMA
 XRQI     BSSZ   1           PP REQUEST (RQ) INDEX
 XRRC     BSSZ   1           REQUEST (+1) = RESPONSE (-1) COUNTER
 XSFF     BSSZ   1           SEND FUNCTION FLAG (CHANNEL I/O)
          ORG    72B
 PPIT     BSSZ   2           REAL MEMORY WORD ADDRESS OF PP INTERFACE TABLE
 MAXIO1   CON    2*IOBUFLNG+1  MAX TRANSFER SIZE + 1, IN BYTES
 XSFT     BSSZ   1           SOFTWARE FUNCTION TAG(S) FOR I/O (P32 FLAG)

          ORG    76B
 PPNO     CON    3           LOGICAL PP NUMBER

          TITLE  VM5B - MAIN LOOP
          ORG    100B
*
*         MAIN LOOP.  MAP-V.
*
          SPACE  2,10
 VM5B     BSS    0
 LUP      BSS    0
          RJM    PPR         CHECK FOR ANY PP REQUESTS
          ZJN    LUP1        NO PP REQUESTS, CHECK IF ANY UNIT REQUESTS
          RJM    DCM         DO-PP COMMAND
          UJK    LUP         RELOOP

 LUP1     LDDL   IDLFLG      GET IDLE FLAG
          ADDL   PPHUNG      ADD FLAG THAT INDICATES PP HUNG
          NJK    LUP         IF IDLE FLAG SET OR PP HUNG, RELOOP
          RJM    URQ         CHECK FOR ANY UNIT REQUESTS
          ZJN    LUP2        IF NO REQUESTS CHECK IF UNIT SCAN REQUIRED
          RJM    DCM         DO-UNIT COMMAND
 LUP2     RJM    SAU         SCAN ACTIVE UNITS IF REQUIRED
          UJK    LUP
          TITLE  VM5B - SUBROUTINES
 CBC      SPACE  4,20
** NAME - CBC
*
** PURPOSE - CONVERT BYTE COUNT TO 12-BIT CHANNEL COUNT.
*            MULTIPLY BYTE COUNT BY 2/3 AND ROUND UP
*
** INPUT - (BYTCNT) = 16-BIT BYTE COUNT.
*
** OUTPUT - (IOCNT) = NUMBER OF 12 BIT CHANNEL WORDS.
*
          SPACE  2,10
 CBC      SUBR               ENTRY/EXIT
          LDK    0
          STDL   IOCNT       CHANNEL COUNT
          LDDL   BYTCNT      BYTE COUNT
          ZJN    CBC3        IF ZERO BYTE COUNT
          STDL   T1
          LDK    3           DIVIDE BY 3
          SHN    14
          STDL   T2

*         DIVIDE LOOP.

 CBC1     LDDL   IOCNT
          SHN    1
          STDL   IOCNT
          LDDL   T1
          SBDL   T2
          MJN    CBC2
          STDL   T1
          AODL   IOCNT       INCREMENT CHANNEL COUNT
 CBC2     LDDL   T2
          SHN    -1
          STDL   T2
          NJK    CBC1        THIS CHECK WILL MULTIPLY BY 2
          LDDL   T1
          ZJN    CBC3        IF NO NEED TO ROUND UP
          AODL   IOCNT       ROUND UP IF REMAINDER
 CBC3     RETURN             EXIT
 CLK      SPACE  4,20
** NAME - CLK
*
** PURPOSE - CLEAR LOCK.
*
** INPUT - (T4), (T4)+1, (T4)+2 AND R POINT TO TABLE TO BE CLEARED.
*          (T5) = LOCKWORD OFFSET.
*
** OUTPUT - LOCK IS CLEARED IN LOCKWORD.
*
 CLK      SPACE  2,10
 CLK      SUBR               ENTRY/EXIT

*         MAKE SURE THIS PP IS THE ONE WHO HAS THE LOCK SET.

          LDIL   T4          TABLE ADDRESS
          STDL   CMADR
          LDML   1,T4
          STDL   CMADR+1
          LDML   2,T4
          STDL   CMADR+2
 CLK1     LOADR  CMADR       UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          CRDL   T1          READ UNIT LOCK
          LDDL   T4          CHECK PP NUMBER
          SBDL   PPNO
          ZJN    CLK3        IF THIS PP HAS THE LOCK SET

*         CHECK IF LOCKWORD = FFFF FFFF XXXX XXXX(16).

          LDDL   T1
          ADC    -177777B
          NJN    CLK2
          LDDL   T2
          ADC    -177777B
          ZJN    CLK1

 CLK2     RJM    HNG         ERROR, THIS PP DOES NOT HAVE UNIT RESERVED.

*         CLEAR UNIT LOCKWORD IN UNIT INTERFACE TABLE.

 CLK3     LDK    0
          STDL   T1
          STDL   T2
          STDL   T3
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK
          LMK    400000B
          RDCL   T1          CLEAR LOCK

*         CHECK IF LOCK WAS CORRECT BEFORE THE CLEAR OPERATION.

          LDDL   T1
          ADC    -100000B
          NJN    CLK5
          LDDL   T2
          ADDL   T3
          NJN    CLK5
          LDDL   PPNO
          SBDL   T4
          NJN    CLK4        LOCK IS NOT OK
          RETURN             EXIT
 CLK4     RJM    HNG         LOCK WAS MESSED UP

*         CHECK IF LOCKWORD = FFFF FFFF XXXX XXXX(16).

 CLK5     LDDL   T1
          ADC    -177777B
          NJN    CLK6
          LDDL   T2
          ADC    -177777B
          ZJK    CLK3

*         CHECK IF LOCKWORD = 0.

 CLK6     LDDL   T1
          ADDL   T2
          ADDL   T3
          ADDL   T4
          NJK    CLK4
          UJK    CLK3
 CLP      SPACE  4,20
** NAME - CLP
*
** PURPOSE - CLEAR THE LOCKWORD ON THE PP REQUEST QUEUE.
*
** INPUT - (NONE)
*
** OUTPUT - QUEUE LOCK IS CLEARED IN PP REQUEST QUEUE.
*
          SPACE  2,10
 CLP      SUBR               ENTRY/EXIT
          LDDL   PPLOCK      GET PP LOCKED FLAG
          ZJN    CLP1        RETURN IF PP NOT LOCKED ON ENTRY
          LDK    0
          STDL   PPLOCK      CLEAR PP LOCKED FLAG
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T4
          LDK    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    CLK         LOCK PP REQUEST QUEUE
 CLP1     RETURN             EXIT
 CQL      SPACE  4,20
** NAME - CQL
*
** PURPOSE - CLEARS THE QUEUE LOCK IN THE UNIT INTERFACE TABLE.
*
** INPUT - (NONE)
*
** OUTPUT - QUEUE LOCK IS CLEARED IN UNIT INTERFACE TABLE.
** OUTPUT - (NONE)
*
          SPACE  2,10
 CQL      SUBR               ENTRY/EXIT
          LDDL   UQLOCK      GET UNIT LOCKED FLAG
          ZJN    CQL1        RETURN IF UNIT NOT LOCKED
          LDK    0
          STDL   UQLOCK      CLEAR UNIT QUEUE LOCK FLAG
          LDK    CM.UIT      UNIT INTERFACE TABLE ADDRESS
          STDL   T4
          LDK    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    CLK         CLEAR THE LOCKWORD
 CQL1     RETURN             EXIT
 CRB      SPACE  4,20
** NAME - CRB
*
** PURPOSE - CLEAR RESPONSE BUFFER (NOS/VE).
*
** INPUT - (NONE)
*
** OUTPUT - RESPONSE BUFFER AREA IS SET TO ZERO.
*
          SPACE  2,10
 CRB      SUBR               ENTRY/EXIT
          LDK    P.RS        GET LENGTH OF RESPONSE BUFFER
          STDL   T5          SET UP LOOP COUNTER
 CRB1     LDK    0
          STML   RESBUF-1,T5  CLEAR BUFFER BACK TO FRONT
          SODL   T5          DECREMENT LOOP COUNTER
          NJK    CRB1        RELOOP UNIT BUFFER CLEARED
          RETURN             EXIT
 CUL      SPACE  4,20
** NAME - CUL
*
** PURPOSE - CLEARS UNIT LOCK IN UNIT INTERFACE TABLE.
*
** INPUT - (NONE)
*
** OUTPUT - UNIT LOCK IS CLEARED IN UNIT INTERFACE TABLE.
** OUTPUT - (NONE)
*
          SPACE  2,10
 CUL      SUBR               ENTRY/EXIT
          LDDL   ULOCK       GET UNIT LOCKED FLAG
          ZJN    CUL1        RETURN IF UNIT NOT LOCKED
          LDK    0
          STDL   ULOCK       CLEAR UNIT LOCKED FLAG
          LDK    CM.UIT      UNIT INTERFACE TABLE ADDRESS
          STDL   T4
          LDK    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5
          RJM    CLK         CLEAR UNIT LOCKWORD
 CUL1     RETURN             EXIT
 DCM      SPACE  4,20
** NAME - DCM
*
** PURPOSE - DO COMMAND.
*
** INPUT - COMMAND IN REQBUF.
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 DCM      SUBR               ENTRY/EXIT
          LDK    REQBUF+/RQ/P.CMND  GET ADDR OF FIRST COMMAND
          STDL   CMDADR      INITIALIZE COMMAND ADDRESS
          ADK    1           ADDRESS OF LENGTH FIELD IN COMMAND
          STDL   CMDADR1     SAVE POINTER TO LENGTH FIELD
          LDML   REQBUF+/RQ/P.LEN  GET PACKET LENGTH
          SBN    HEADLN      SUBTRACT HEADER LENGTH
          SHN    -3          DIVIDE BY 8 TO GET CM WORDS OF COMMANDS
          STDL   CMDNO       SAVE NUMBER OF COMMANDS
          LDK    0
          STDL   BYTCNT      INITIALIZE TRANSFER COUNT
          STDL   FCNRCD      INITIALIZE FUNCTION REQUEST CODE
          STDL   DIAFLG      INITIALIZE DIAGNOSTIC FLAG
 DCM1     LDK    0
          STDL   DIAFND      INITIALIZE DIAGNOSTIC DATA FLAG
          STML   RESBUF+/RS/P.RC  CLEAR RESPONSE CODE
          LDIL   CMDADR      GET COMMAND AND FLAGS
          SHN    -8          SHIFT OFF FLAGS
          STDL   T1          SAVE COMMAND
          SBN    LPPCMD      SUBTRACT VALUE OF LARGEST LEGAL PP COMMAND
          ZJN    DCM4        JUMP IF VALID PP COMMAND
          MJN    DCM4        JUMP IF VALID PP COMMAND

*         SEARCH THE COMMAND CODE TABLE FOR THIS UNIT COMMAND.

          LDK    TUCJL-2     SIZE OF TABLE
          STDL   T2
 DCM2     LDML   TUCJ,T2     GET COMMAND TABLE ENTRY
          SBDL   T1
          ZJN    DCM3        ENTRY FOUND
          LCN    2
          RADL   T2          DECREMENT T2
          PJK    DCM2        MORE ENTRIES

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
 DCM..    LDK    ERC501      INVALID COMMAND CODE
          RJM    EPC         ERROR PP(NOS/VE) COMMAND SEQUENCE

*         NO RETURN.  RJM RECORDS ADDRESS OF ERROR ROUTINE.

          ELSE
 DCM..    UJK    *           HANG IF ILLEGAL FUNCTION AND VALIDATION OFF
          ENDIF
*
*         VALID UNIT COMMAND, PROCESS COMMAND
*
 DCM3     LDML   TUCJ+1,T2   GET ADDRESS
          STML   DCMA        STORE IN JUMP
          LJM    **
 DCMA     EQU    *-1         UNIT REQUEST JUMP ADDRESS
          SPACE  2,10
*
*         VALID PP COMMAND, PROCESS COMMAND
*
 DCM4     LDIL   CMDADR      GET COMMAND AND FLAGS
          SHN    -8          SHIFT OFF FLAGS
          STDL   T2          SAVE COMMAND TO INDEX INTO JUMP TABLE
          LDML   TPCJ,T2     GET ADDRESS OF PP COMMAND ROUTINE
          STML   DCMB        SET UP JUMP
          RJM    **          GO TO PERFORM COMMAND
 DCMB     EQU    *-1
          SPACE  4,10
*         CONTINUE - DO COMMAND-COMPLETE PROCESSING.
*         NOTE - *DCP* IS ENTRY POINT FROM VARIOUS POINTS IN PPU.

 DCP      SODL   CMDNO       DECREMENT COMMAND COUNTER BY 1
          ZJN    DCP3        GO TO COMPLETE REQUEST

*         CHECK IF INTERMEDIATE RESPONSE REQUIRED.

          LDML   RESBUF+/RS/P.RC
          ZJN    DCP2        IF NO INTERMEDIATE RESPONSE
          LDK    R.INT       SET INTERMEDIATE RESPONSE FLAG
          RAML   RESBUF+/RS/P.RC
          RJM    RSP         SEND RESPONSE TO CPU
          RJM    INTRES      INITIALIZE RESPONSE BUFFER.
 DCP2     RJM    NEXTCMD     POINT TO NEXT COMMAND
          UJK    DCM1        RELOOP TO PERFORM NEXT COMMAND

 DCP3     LDK    R.NRM

*         SET NORMAL REQUEST TERMINATION INDICATOR.

          RAML   RESBUF+/RS/P.RC
          RJM    RSP         SEND RESPONSE TO CPU
 DCP4     RJM    CUL         CLEAR UNIT LOCK
          RETURN             EXIT

*         DO-COMMAND ERROR PROCESSING.

 DER      LDK    R.ABN
          STML   RESBUF+/RS/P.RC  SET ABNORMAL TERMINATION RESPONSE
          RJM    RSP         SEND RESPONSE TO CPU
          RJM    CUL         CLEAR UNIT LOCK
          UJK    VM5B        RETURN TO START OF PPU MONITOR

          IFEQ   HDW12BC,1   MAP-V CHANNEL INTERFACE IS 12/60 HARDWARE
 DVD      SPACE  4,20
** NAME - DVD
*
** PURPOSE - DIVIDE BY 5.
*
** INPUT - (A) = DIVIDEND.
*
** OUTPUT - (A) = QUOTIENT.
*           USES T1,T2.
*
** NOTES - USES SILVERMANS FORMULA.
*          N/5 = (N+4)*(51+13/2**6)/2**8.
*
          SPACE  2,10
 DVD      SUBR               ENTRY/EXIT
          ADK    4
          STD    T1          12 BIT STORE
          SHN    1
          ADD    T1          12 BIT ADD
          SHN    2
          ADD    T1          12 BIT ADD
          SHN    12D
          STD    T2          12 BIT STORE
          SHN    8D
          SBD    T1          12 BIT SUBTRACT
          ADD    T2          12 BIT ADD
          SHN    -8D
          RETURN             EXIT
          ENDIF
 EAU      SPACE  4,20
** NAME - EAU
*
** PURPOSE - ENABLE/DISABLE A UNIT.
*
** INPUT - (A) = 0 - ENABLE UNIT
*              = 1 - DISABLE UNIT
*
** OUTPUT - DISABLE FLAG IS SET AS REQUESTED.
*
          SPACE  2,10
 EAU      SUBR               ENTRY/EXIT
          STML   EAUVAL
          RJM    LFU         FORMAT AND LOAD UIT RMA.
          CRML   UITBUF,ONE  READ IN 1 CM WORD OF UIT
          LDML   UITBUF+/UIT/P.DSABLE  GET UNIT STATUS
          LPK    DISABLE     MASK OFF DISABLE FLAG
          ADC    0           SET OR CLEAR DISABLE FLAG
 EAUVAL   EQU    *-1
          STML   UITBUF+/UIT/P.DSABLE  STORE DISABLE BIT IN UIT COPY
          LOADC  CMADR       REFORMATTED UIT ADDRESS
          CWML   UITBUF,ONE  SET DISABLE BIT IN CM
          RETURN             EXIT
 EDT      SPACE  4,20
** NAME - EDT
*
** PURPOSE - EXECUTE DATA TRANSFER (IE MOVE NON REQ/RES PKT DATA).
*             EDT LOADS/UNLOADS DATA VIA CHANNEL.
*
** INPUT - (XRDF) = READ FLAG.
*          INDLST IS FWA OF ADDRESS LIST.
*          (T3) = LENGTH OF ADDRESS LIST.
*          (TRNCNT+3) = TOTAL BYTES OF DATA.
*
** OUTPUT - MAP-V MEMORY IS LOADED OR UNLOADED AS REQUESTED.
*
          SPACE  2,10
 EDTX     BSS    0
 EDT      SUBR               ENTRY/EXIT
          LDK    0
          STML   XRTY        SET RETRY ADDRESS
          LDK    1
          STDL   XSFF        SET SEND FUNCTION FLAG

          IFEQ   F16BD,1                                    ***** ****
          LDDL   XSFT        SOFTWARE FLAG CODES
          LPN    2           ISOLATE CENTRAL READ/WRITE 64-BIT FLAG
          SHN    14D-0
          ADM    EDTA        12 BIT ADD OF 6105 INSTRUCTION (CRM)
          STML   EDTA        16 BIT STORE OF X06105 INSTUCTION
          ADC    0200B       FORM X06305 INSTRUCTION (CRW OR CRWL)
          STML   EDTB        16 BIT STORE OF X06305 INSTUCTION
          LDDL   XSFT        SOFTWARE FUNCTION TAG(S)
          LPN    1
          STDL   XSFT        RESTORE WITHOUT CRM/CWM .. CRML/CWML FLAG
          ENDIF                                             * *** ** *

          LDDL   BYTCNT      TOTAL TRANSFER BYTE COUNT
          ADK    7
          SHN    -3          DETERMINE TOTAL CM WORDS
          NJN    EDT1        TEST WORD COUNT FOR NON ZERO
          UJK    EDTX        EXIT ON ZERO WORD COUNT
 EDT1     LDK    INDLST      ADDRESS OF INDIRECT LIST
          STDL   T6
 EDT2     LDK    0
          STDL   XBIA        SET BIAS TO ZERO
          LDML   1,T6        LENGTH IN 8-BIT BYTES
          SHN    -2          / 4 = NUMBER OF 32 BIT WORDS TO TRANSFER
          LPK    1
          STML   ODDN32      FLAG TO INDICATE ODD OR EVEN NUMBER OF 32 BIT WORDS
          LDML   1,T6        LENGTH IN 8-BIT BYTES
          ADK    7
          SHN    -3          CONVERT TO 64 BIT WORDS
          STDL   WC          NUMBER OF 64 BIT WORDS IN BLOCK
          SHN    2           * 4
          STML   XPWA        NUMBER OF WORDS PER ADDRESS ENTRY * 4
 EDT12    LDDL   WC          NUMBER OF 64 BIT WORDS IN BLOCK
          SBDL   XBIA
          STDL   T5          NUMBER OF 64 BIT WORDS LEFT TO TRANSFER
          SHN    2           * 4
          STDL   XPWB        NUMBER OF 64 BIT WORDS LEFT TO TRANFER * 4
          LDDL   T5          NUMBER OF 64 BIT WORDS LEFT TO TRANSFER
          ADK    -BFDC64     SUBTRACT 64 BIT BUFFER SIZE
          ZJN    EDT3        ONE PART LOAD JUST FITS
          PJN    EDT5
 EDT3     LDDL   XSFT        SOFTWARE FUNCTION TAG(S) (IE P32 FLAG)
          NJN    EDT4A       IS PACKED 32

          IFEQ   HDW12BC,1   MAP-V CHANNEL INTERFACE IS 12/60 HARDWARE
          LDDL   WC          NUMBER OF 64 BIT WORDS IN BLOCK
          SBDL   XBIA
          SHN    1           * 2 = NUMBER OF 60 BIT WORDS LEFT TO TRANSFER
          ADK    -BFDC60     SUBTRACT ALLOWABLE 60 BIT BUFFER SIZE
          PJN    EDT5        EXACTLY ONE PART LOAD OR MORE
          LDDL   XPWB        NUMBER OF 64 BIT WORDS LEFT TO TRANSFER * 4
          SHN    1           * 8
          ADDL   T5          * 9
          ADDL   T5          * 10
          STDL   T5          NUMBER OF 12 BIT BYTES TO INPUT
          LDML   ODDN32
          ZJN    EDT3A       IF EVEN NUMBER OF 32 BIT WORDS TO TRANSFER
          LDK    -5
          RADL   T5          NUMBER OF 12 BIT BYTES TO INPUT
 EDT3A    LDDL   T5
          STDL   XPWB        12 BIT BLOCK SIZE
          ENDIF

 EDT4A    UJN    EDT7
 EDT5     LDDL   XSFT        SOFTWARE FUNCTION TAG(S) (IE P32 FLAG)
          NJN    EDT6        IS PACKED 32

*         SET UP FIRST OF N PARTS.

          IFEQ   HDW12BC,1   MAP-V CHANNEL INTERFACE IS 12/60 HARDWARE
          LDK    BFDP12      BUFFER SIZE IN 12-BIT PP WORDS
          STDL   XPWB        NUMBER OF 12 BIT PP WORDS TO TRANSFER
          LDK    BFDC60      BUFFER SIZE OF 60-BIT CHUNCKS/2
          STDL   T5          NUMBER OF 60 BIT WORDS
          UJN    EDT7
          ENDIF

 EDT6     LDK    BFDP16      TRANSFER SIZE IN 16-BIT PP WORDS
          STDL   XPWB        NUMBER OF 16 BIT PP WORDS TO TRANSFER
          LDK    BFDC64      TRANSFER SIZE IN 64-BIT CM WORDS
          STDL   T5          NUMBER OF 64 BIT WORDS
 EDT7     LDML   XRDF        GET READ FLAG
          ZJN    EDT8        LOAD MAP MEMORY FROM HOST (WRITE)
          UJK    EDT20       UNLOAD (READ)

*         READY FOR HOST TO MAP-V TRANSFER.
*         READ IN THE DATA (OR PART OF IT).

 EDT8     LOADF  2,T6        CM ADDRESS TO A AND R
          ADDL   XBIA        ADD BIAS IF NOT FIRST READ OF PAGE
 EDTA     CRML   BFDZ,T5
*         CRM    BFDZ,T5     60 BIT CM READ (STLOD)
          LDDL   XSFT        SOFTWARE FUNCTION TAG(S) (IE P32 FLAG)
          NJN    EDT9        IS PACKED 32
          LDML   EDTA
          SHN    17D-15D
          PJN    EDT9        60-BIT READ (STLOD)

          IFEQ   HDW12BC,1   MAP-V CHANNEL INTERFACE IS 12/60 HARDWARE
          LDK    BFDZ        FWA OF 16/64-BIT DATA
          STDL   T4          SET STORAGE ADDRESS OF 12/60-BIT DATA
          RJM    RSF         REFORMAT SIX FOUR (64) - (16/64 TO 12/60)
          ENDIF

 EDT9     LDDL   T5          BUFFER SIZE (CM WORDS)
          RADL   XBIA
          LDML   XRDF        GET READ FLAG
          NJN    EDT11       UNLOAD MAP MEMORY TO HOST
          LDDL   XSFF
          NJN    EDT10       IF FIRST TIME
*
*         LOAD NTH PART INTO MAP.
*
 EDT17    RJM    SDP         SET DATA-TRANSFER PARAMETERS

*         RETURN WITH (A) = DATA FWA.
*                     (T0) = PP CHANNEL WORD COUNT.
*                     (F16BIO) = 1 = 16 BIT I/O.  0 = 12 BIT I/O.

          RJM    OTX         TRANSMIT NTH PART TO MAP
          UJN    EDT11
*
*         FUNCTION FOR WRITE AND LOAD FIRST PART INTO MAP.
*
 EDT10    LDML   XFCD        FUNCTION-CODE BLOCK WRITE (0400B OR 0401B)
          RJM    OTF         OUTPUT THE FUNCTION
          RJM    WHNB        INPUT ONE WORD STATUS - PARITY CHECK
          NJN    EDT14A
          STDL   XSFF        CLEAR SEND FUNCTION FLAG
          RJM    SDP         SET DATA-TRANSFER PARAMETERS

*         RETURN WITH (A) = DATA FWA.
*                     (T0) = PP CHANNEL WORD COUNT.
*                     (F16BIO) = 1 = 16 BIT I/O.  0 = 12 BIT I/O.

          RJM    OTC         TRANSMIT DATA

*         SET UP NEXT PART IF NECESSARY.

 EDT11    LDML   WC          CM WORDS THIS ADDRESS BLOCK
          SBDL   XBIA        NUMBER READ
          NJK    EDT12       MORE DATA FROM THIS ADDRESS WORD PAIR
          LDK    4
          RADL   T6          MOVE INDLST POINTER TO NEXT ADDRESS
          SODL   T3          DECREMENT ADDRESS LIST
          NJK    EDT2        MORE ADDRESSES

*         COMPLETE I/O BY DISCONNECTING CHANNEL
*         AND CHECKING CHANNEL FOR PARITY ERROR.

          RJM    INE         DISCONNECT CHAN. AND CHECK CHAN. PARITY
          NJN    EDT14C

*         STATUS CHECK AFTER EXIT.

          RETURN             EXIT

 EDT14A   RJM    ESO
          RJM    EMAP
 EDT14C   UJK    DER
*
*         SET UP FOR MAP-V TO HOST TRANSFER.
*
 EDT20    LDDL   XSFF
          NJN    EDT21       IF FIRST TIME
*
*         READ NTH PART FROM MAP.
*
          RJM    SDP         SET DATA-TRANSFER PARAMETERS

*         RETURN WITH (A) = DATA FWA.
*                     (T0) = PP CHANNEL WORD COUNT.
*                     (F16BIO) = 1 = 16 BIT I/O.  0 = 12 BIT I/O.

          RJM    INX         READ NTH PART FROM MAP
          ZJN    EDT22
 EDT25    UJK    EDT14C

*         FUNCTION MAP-V AND READ IN FIRST PART.

 EDT21    LDML   XFCD        FUNCTION-CODE BLOCK READ (0500B OR 0501B)
          RJM    OTF         OUTPUT THE FUNCTION
          RJM    WHNB        INPUT ONE WORD STATUS - PARITY CHECK
          NJK    EDT14A
          STDL   XSFF        CLEAR SEND FUNCTION FLAG
          RJM    SDP         SET DATA-TRANSFER PARAMETERS

*         RETURN WITH (A) = DATA FWA.
*                     (T0) = PP CHANNEL WORD COUNT.
*                     (F16BIO) = 1 = 16 BIT I/O.  0 = 12 BIT I/O.

          RJM    INC         ACTIVATE AND INPUT
          ZJN    EDT22
          UJK    EDT25
 EDT22    LDDL   XSFT        SOFTWARE FUNCTION TAG(S) (IE P32 FLAG)
          NJN    EDT23       IS PACKED 32
          LDML   EDTB
          SHN    17D-15D
          PJN    EDT23       60-BIT WRITE (DUMP PUBLIC MEM - FUTURE)

          IFEQ   HDW12BC,1   MAP-V CHANNEL INTERFACE IS 12/60 HARDWARE
          LDDL   XPWB        LENGTH OF PPU BLOCK
          RJM    DVD         DIVIDE BY 5
          ADK    1
          SCN    1           ROUND UP.
          STDL   T5          NUMBER OF 60 BIT WORDS
          LDK    BFDZ        FWA OF 12/60-BIT DATA
          STDL   T4          SET STORAGE ADDRESS OF 16/64-BIT DATA
          RJM    RSZ         REFORMAT SIX ZERO (60) - (12/60 TO 16/64)

*         RETURN (T5) = NUMBER OF 64-BIT WORDS.

          ENDIF

*         TRANSFER DATA TO USERS AREA AS DEFINED BY PARAMETER BLOCK.


*         WRITE THE DATA (OR PART OF IT).

 EDT23    LOADF  2,T6        CM ADDRESS TO A AND R
          ADDL   XBIA        ADD BIAS IF NOT FIRST READ OF PAGE
 EDTB     CWML   BFDZ,T5
*         CWM    BFDZ,T5     60 BIT WRITE TO CM
          UJK    EDT9        GO TO INCREMENT BIAS LOCATION
 EHR      SPACE  4,20
** NAME - EHR
*
** PURPOSE - ERROR HANDLING ROUTINE.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 EHR      SUBR               ENTRY/EXIT
          LDDL   XRRC        REQUEST (+1) = RESPONSE (-1) COUNTER
          STML   RESBUF+/RS/P.PPRRC
          LDML   EHR         ERROR ADDRESS
          STML   RESBUF+/RS/P.PPEA
          LDML   XLFC        LAST FUNCTION CODE
          STML   RESBUF+/RS/P.PPLF
          LDML   APERR
          STML   RESBUF+/RS/P.MVEC  SET MAP-V ERROR CODE IN RESPONSE
          RETURN
 EINTF    SPACE  4,20
** NAME - EINTF
*
** PURPOSE - REPORT ERRORS IN THE INTERFACE ERROR FIELD OF A RESPONSE
*
** INPUT - (A)  - ERROR CODE TO BE STORED IN RESPONSE INTERFACE ERROR FIELD
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 EINTF    SUBR               ENTRY/EXIT
          STML   RESBUF+/RS/P.IEC  SET INTERFACE ERROR CODE
          LDK    LENRS1
          STML   RESBUF+/RS/P.RESPL SET LENGTH OF RESPONSE BUFFER
          RJM    EHR
          UJK    DER         ABNORMAL ERROR TERMINATION OF REQUEST
 EMAP     SPACE  4,20
** NAME - EMAP
*
** PURPOSE - RECORD MAP ERROR INFORMATION
*
** INPUT - (A) - MAP ERROR TO BE REPORTED
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 EMAP     SUBR               ENTRY/EXIT
          STML   APERR       SAVE MAP ERROR CODE
          LDK    LENRS2
          STML   RESBUF+/RS/P.RESPL
          RJM    EHR
          RETURN
 EPC      SPACE  4,20
** NAME - EPC
*
** PURPOSE - ERROR PP(NOS/VE) COMMAND SEQUENCE.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 EPC      SUBR               ENTRY/EXIT
          ADK    CMDERR      ADD ON COMMAND SEQUENCE ERROR CODE BASE
          RJM    EINTF
 EPT      SPACE  4,20
** NAME - EPT
*
** PURPOSE - ENABLE/DISABLE PORT THREE (3).
*
** INPUT - (A) = 0 - ENABLE PORT
*                1 - DISABLE PORT
*
** OUTPUT - BIT 35 IN ENVIRONMENTAL CONTROL REGISTER 20(16)
*           IS SET AS REQUESTED
*
          SPACE  2,10
 EPT      SUBR               ENTRY/EXIT
          ZJN    EPTA        IF REQUEST TO ENABLE PORT.
          LDK    20B
 EPTA     STML   EPTB
          LDK    0#14A       FUNCTION WORD
                               CONECT CODE = 1
                               OP. CODE    = 4 - READ
                               TYPE CODE   = A
          RJM    EPT1        CONDITION ENVIRONMENTAL CONTROL REG. 20(16)
          IAM.   HCS,MCH     READ TO HIGH CORE SCRATCH
          DCN.   MCH+40B
          CCF.   *,MCH       RETURN CHANNEL

*         CLEAR PORT 3 DISABLE BIT.

          LDM    HCS+4
          LPK    357B        CLEAR BIT 35 - PORT 3 DISABLE
          ADC    0           ADD IN VALUE FOR BIT 35.
 EPTB     EQU    *-1
          STM    HCS+4       STORE BACK
          LDK    0#15A       FUNCTION WORD
                               CONECT CODE = 1
                               OP. CODE    = 5 - WRITE
                               TYPE CODE   = A
          RJM    EPT1        CONDITION ENVIRONMENTAL CONTROL REG. 20(16)
          OAM.   HCS,MCH     WRITE FROM HIGH CORE SCRATCH
          FJM.   *,MCH
          DCN.   MCH+40B
          CCF.   *,MCH       RETURN CHANNEL
          RETURN             EXIT
          SPACE  2,10
**        EPT1 - EPT HELPER SUBROUTINE.
*
*                USED TO CONDITION ENVIRONMENTAL CONTROL REG. 20(16).
*
          SPACE  2,10
 EPT1     SUBR               ENTRY/EXIT
          SCF.   *,MCH       WAIT UNTIL MCH AVAILABLE
          FAN.   MCH         FUNCTION (A) ON MAINTENANCE CHANNEL
          LDK    1234B
 EPT2     SBN    1
          NJN    EPT3        NOT TIMED OUT YET
          DCN.   MCH+40B
          CCF.   *,MCH       RETURN CHANNEL
          LJM    *           HANG FOR NOW **********    ********
 EPT3     AJM.   EPT2,MCH    IF STILL ACTIVE
          ACN.   MCH
          LDK    0
          OAN.   MCH         OUTPUT 1ST CHANNEL CONTROL WORD
          LDK    40B         20(16) - EC - ENVIRONMENTAL CONTROL REG.
          OAN.   MCH         OUTPUT 2ND CHANNEL CONTROL WORD
          FJM.   *,MCH
          DCN.   MCH+40B
          ACN.   MCH
          LDK    8D          CHANNEL BYTE COUNT
          RETURN             EXIT

 ESO      SPACE  4,20
** NAME - ESO
*
** PURPOSE - ERROR-BITS-IN STATUS-WORD ONE.
*
** INPUT - (NONE)
*
** OUTPUT - (A) - APE ERROR CODE OBTAINED FROM MAP STATUS WORD 1
*
          SPACE  2,10
 ESO      SUBR               ENTRY/EXIT
          LDDL   ST
          SHN    8-1
          PJN    ESO6        IF NO EXPONENT OVERFLOW.
          LDK    APE1A       EXPONENT OVERFLOW              ** APE1A **
          UJN    ESO8
 ESO6     SHN    1
          PJN    ESO0        IF NO CHANNEL PARITY ERROR.
          LDK    /RS/K.OCP
          RAML   RESBUF+/RS/P.OCP
          LDK    APE19       CHANNEL PARITY ERROR           ** APE19 **
          UJN    ESO8
 ESO0     SHN    1
          PJN    ESO1        IF NOT PUBLIC MEMORY PARITY ERROR.
          LDK    APE18       PUBLIC MEMORY PARITY ERROR     ** APE18 **
          UJN    ESO8
 ESO1     SHN    1
          PJN    ESO2        IF NOT MAIN MEMORY PARITY ERROR.
          LDK    APE17       MAIN MEMORY PARITY ERROR       ** APE17 **
 ESO8     UJN    ESO10
 ESO2     SHN    4
          PJN    ESO3        NOT CONTROL PROCESSOR SEQ. ERR.
          LDK    APE13       CONTROL PROCESSOR SEQ. ERR.    ** APE13 **
          UJN    ESO10
 ESO3     SHN    17D
          PJN    ESO4        NOT COMMAND REJECTED
          LDK    APE14       COMMAND REJECTED               ** APE14 **
          UJN    ESO4
 ESO4     SHN    2
          PJN    ESO5        NOT HOST CHANNEL SEQUENCE ERROR
          LDK    APE12       HOST CHANNEL SEQ. ERR.         ** APE12 **
          UJN    ESO10
 ESO5     SHN    1
          MJN    ESO9        IF CONTROL PROCESSOR RUNNING
          LDK    APE11       CONTROL PROCESSOR NOT RUNNING  ** APE11 **
          UJN    ESO10
 ESO9     LDK    0           NO APE ERROR.
 ESO10    RETURN

 FORMA    SPACE  4,20
** NAME - FORMA
*
** PURPOSE - FORMAT A CM REAL MEMORY ADDRESS.
*
** CALLING SEQUENCE - LDC    ADDRESS
*                     RJM    FORMA
*
** INPUT - (A) IS THE ADDRESS OF A 2-WORD CM BYTE ADDRESS.
*
** OUTPUT - (CMADR) IS THE ADDRESS OF THE RESULTING 3-WORD REFORMATED
*                CM ADDRESS.  THE FORMAT CAN BE USED BY THE LOADC MACRO.
*           (ADDRESS), WORD 0, BITS 0-13 AND
*                      WORD 1, BITS 3-15, ARE REFORMATTED TO-
*           (CMADR),   WORD 0, BITS 54-63,
*                      WORD 1, BITS 52-63,
*                      WORD 2, BITS 58-63,
*
          SPACE  2,10
 FORMA    SUBR               ENTRY/EXIT
          STDL   T1

*         REFORMAT CM ADDRESS.

          LDML   1,T1
          LPN    7
          ZJN    FORMA1      IF VALID RMA ADDRESS.
          RJM    HNG
 FORMA1   LDIL   T1
          LPN    37B
          SHN    16
          LMML   1,T1
          SHN    9
          STDL   CMADR+1
          SHN    6
          LPN    77B
          STDL   CMADR+2
          LDIL   T1
          SHN    -5
          STDL   CMADR
          LRD    CMADR
          LDDL   CMADR+2
          LMK    400000B
          RETURN             EXIT


          IFEQ   ILRRP,1                                    ***** ****
 GIA      SPACE  4,20
** NAME - GIA
*
** PURPOSE - GET INDEXED ADDRESS FROM INDIRECT LIST.
*
** INPUT - (A) = INDEX OF DESIRED ADDRESS.
*          ADDRESS LIST IN *INDLST*.
*
** OUTPUT - (A) AND (R) READY FOR ONE WORD CM ACCESS.
*
          SPACE  2,10
 GIA      SUBR               ENTRY/EXIT
          STDL   T4          SAVE DESIRED INDEX
          LDIL   CMDADR1     GET LENGTH OF INDIRECT LIST
          SHN    -3          DIVIDE BY 8 TO GET CM WORD COUNT
          STDL   T5          SAVE CM WORD COUNT
          LDK    0
          STDL   T6          INITIALIZE INDEX
 GIA1     SODL   T5          DECREMENT LOOP COUNTER BY 1
          PJN    GIA2        CONTINUE UNTIL ENTIRE LIST PROCESSED
          RJM    HNG         BAD INDEX ***********
 GIA2     LDML   INDLST+1,T6  GET LENGTH FROM ADDRESS/LENGTH PAIR
          SHN    -3          CM WORDS
          SBDL   T4          DESIRED INDEX
          MJN    GIA3        NOT IN THIS GROUP
          LDK    INDLST+2
          ADDL   T6          POINTER TO BASE ADDRESS
          RJM    FORMA       FORMAT MEMORY ADDRESS
          ADDL   T4          ADD INDEX
          RETURN             EXIT

 GIA3     ADDL   T4          RESTORE VALUE
          LMK    777777B     COMPLEMENT
          RADL   T4          DECREMENT INDEX
          LDK    4
          RADL   T6          POINT TO NEXT ITEM IN LIST
          UJK    GIA1        RELOOP

          ENDIF                                             * * * ** *
          SPACE  4,20
 HNG      SUBR
          AODL   PPHUNG      SET FLAG TO INDICATE PP HUNG.
          UJK    LUP
 INS      SPACE  4,20
** NAME - INS
*
** PURPOSE - INPUT STATUS-WORD(S)-FROM-MAP.
*
** INPUT - (A) = STATUS FUNCTION CODE (0600B OR 0601B).
*
** OUTPUT - (ST) = MAP-V STATUS WORD 1.
*           EXIT WITH (A) = 0 -  NO ERROR BITS IN STATUS WORD 1 OR HARDWARE BUSY
*                                BIT SET IN STATUS WORD 1. IF THE HARDWARE BUSY
*                                BIT IS SET, NO OTHER BITS ARE CHECKED.
*                     (A) = NON-ZERO - ERROR BITS SET IN STATUS WORD 1. LOCATION
*                                      APERR WILL CONTAIN THE APE ERROR CODE
*                                      FOR THE FIRST BIT SET IN STATUS WORD 1.
*           IF 0601B REQUESTED, (ST+1) = STATUS WORD 2.
*
** NOTES - XLFC IS NOT CHANGED BY THIS SUBROUTINE. IT
*          IS SAVED AND RESTORED. THE 1 OR 2 WORD STATUS
*          AREA IS FILLED WITH ALL 7S BEFORE READING
*          THE STATUS IN.
*
          SPACE  2,10
 INSX     BSS    0
 INS      SUBR               ENTRY/EXIT
          STML   INSA        SAVE FUNCTION CODE
          LPN    1
          ADC    1401B       LDN 00 INSTRUCTION PLUS WORD COUNT
          STML   INSC
*
*         MOVE CURRENT HARDWARE STATUS WORD TO PREVIOUS HARDWARE STATUS WORD
*
          LDDL    ST
          STDL    PST        SAVE CURRENT HARDWARE STATUS

          LDML   XLFC        SAVE THE LAST FUNCTION CODE
          STDL   T2
*
*         SEND READ STATUS FUNCTION TO THE MAP.
*
          LDC    **
 INSA     EQU    *-1         0600 OR 0601 STATUS FUNCTION CODE
          RJM    OTF         SEND READ STATUS FUNCTION
          NJK    INSX
*
*         INITIALIZE THE HARDWARE STATUS BUFFER TO ALL ONES.
*
          LCN    0
          STDL   ST          INITIALIZE STATUS WORD 1
*
*         READ IN THE STATUS WORD(S).
*
 INSC     LDN    **          SIZE OF TRANSFER
          STDL   T0
          LDK    ST          ADDRESS OF STATUS
          RJM    INC         ACTIVATE AND INPUT
          NJK    INSX
          LDDL   T2          RESTORE LAST MAP FUNCTION CODE
          STML   XLFC
          RJM    INE         CHECK CHANNEL PARITY
          NJN    INS4
*
*         SET APERR IF HARDWARE BUSY BIT IS NOT SET
*
          LDDL   ST
          LPK    /MPHSTS/K.HBSY
          NJN    INS2        IF HARDWARE BUSY BIT IS SET.
          RJM    ESO
          ZJN    INS4        IF NO ERROR.
          RJM    MHP
          UJN    INS4
 INS2     LDK    0
 INS4     RETURN             EXIT

 INTRES   SPACE  4,20
** NAME - INTRES
*
** PURPOSE - TO INITIALIZE A RESPONSE BUFFER
*
** INPUT - (UQFLG) = 0 - INITIALIZE AS PP RESPONSE
**         (UQFLG) = 1 - INITIALIZE AS UNIT RESPONSE
*
** OUTPUT - RESPONSE BUFFER INITIALIZED FOR SPECIFIED RESPONSE
*
          SPACE  2,10
 INTRES   SUBR
          RJM    CRB         CLEAR RESPONSE BUFFER.
          RJM    SUR         SET UP RESPONSE BUFFER.
          LDDL   UQFLG
          NJN    INTRES2     IF INITIALIZE AS UNIT RESPONSE.
          LDK    LENRS       LENGTH OF PP RESPONSE.
          UJN    INTRES3
 INTRES2  BSS    0
          LDK    LENRS1      LENGTH OF UNIT RESPONSE.
 INTRES3  STML   RESBUF+/RS/P.RESPL  SET LENGTH OF RESPONSE BUFFER.
          RETURN

 INX      SPACE  4,20
** NAME - INX
*
** PURPOSE - INPUT DATA ON THE MAP CHANNEL.
*
** INPUT - (A) = FWA OF INPUT BUFFER.
*          (T0) = LENGTH IN PP WORDS.
*
** OUTPUT - NORMAL EXIT = INPUT COMPLETED.
*           ABNORMAL EXIT = EXIT VIA *HNG* SUBROUTINE (A) = ERROR CODE.
*
** NOTES - THERE ARE 3 ENTRY POINTS TO THIS SUBROUTINE:
*             INB = CHANNEL IS CONNECTED BEFORE INPUT AND
*                   DISCONNECTED AFTER INPUT.
*             INC = CHANNEL IS CONNECTED BEFORE INPUT.
*             IND = CHANNEL IS DISCONNECTED AFTER INPUT ONLY.
*
*             INE IS AUXILLARY SUBROUTINE FOR DISCONNECTING CHANNEL
*             IF ACTIVE, AND CHECKING CHANNEL PARITY.
*
*             INCE IS AN AUXILLARY SUBROUTINE FOR INPUTTING DATA ON A
*                  CHANNEL UNTIL THE CHANNEL GOES EMPTY.
*
          SPACE  2,10
*         SPECIAL ENTRY POINT FOR CONNECT AND DISCONNECT CHANNEL.

 INB      SUBR               ENTRY/EXIT
          RJM    INC         ACTIVATE AND INPUT
          RJM    INE         DISCONNECT AND CHECK CHANNEL PARITY ERROR
          RETURN             EXIT

*         SPECIAL ENTRY POINT FOR CONNECT CHANNEL ONLY.

 INC      SUBR               ENTRY/EXIT

*         REMOVE ANY CHANNEL PARITY ERROR INDICATIONS BY
*         EXECUTING *SFM* INSTRUCTION AS NO-OP.

          SFM    INC1,CH00   JUMP IF CHANNEL PARITY ERROR SET
 INC1     ACN    CH40        CONNECT CHANNEL
          RJM    INX         INPUT DATA
          RETURN             EXIT

*         ENTRY POINT FOR INPUTTING ON A CHANNEL UNTIL CHANNEL EMPTY

 INCE     SUBR               ENTRY/EXIT
          LDK    0
          STML   XCINC       INITIALIZE EXCESS INPUT COUNT.
 INCE1    IAN    CH00
          AOML   XCINC       INCREMENT EXCESS INPUT COUNT.
          IJM    INCE2,CH00  IF CHANNEL NOT ACTIVE
          FJM    INCE1,CH00  IF DATA ON THE CHANNEL.
 INCE2    RETURN             EXIT
*
*         ENTRY POINT FOR CONTINUE INPUT AND DISCONNECT CHANNEL.
*
*IND      SUBR               ENTRY/EXIT
*         RJM    INX         INPUT DATA
*         RJM    INE         DISCONNECT AND CHECK CHANNEL PARITY ERROR
*         RETURN             EXIT

*         AUXILARY SUBROUTINE TO DISCONNECT CHANNEL IF ACTIVE
*         ON INPUT AND CHECK FOR CHANNEL PARITY ERROR.

 INEX     LDK    0
 INE      SUBR               ENTRY/EXIT
          IJM    INE1,CH00
          DCN    CH40        DISCONNECT CHANNEL
 INE1     CFM    INEX,CH00   JUMP TO *INEX* IF CHANNEL PARITY ERR CLEAR

*         PARITY ERROR ON CHANNEL.

          LDK    EDPC
          RJM    MHP
          LDK    /RS/K.CHERR CHANNEL ERROR
          RAML   RESBUF+/RS/P.CHERR  ABNORMAL STATUS FIELD
          RETURN


*         ENTRY POINT FOR COMMON INPUT SUBROUTINE.

 INXX     BSS    0
 INX      SUBR               ENTRY/EXIT
          STML   INXA+1      SAVE BUFFER ADDRESS

          IFEQ   F16BD,1                                    ***** ****
          LDDL   F16BIO      FLAG 16 BIT I/O

*         CALLING ROUTINE MUST INSURE THAT ONLY BIT 0 IS USED.

          SHN    15D-0
          STD    F16BIO      12 BIT STORE TO CLEAR FLAG FOR NEXT PASS
          ADM    INXA        12 BIT ADD OF 72XX INSTRUCTION
          STML   INXA        16 BIT STORE OF X072XX INSTUCTION
          ENDIF                                             * *** ** *

          LDML   XTLC        TIMEOUT VALUE

 INX1     FJM    INX2,CH00   IF CHANNEL FULL
          SBN    1
          PJK    INX1        LOOP UNTIL FULL OR TIMEOUT

*         ERROR - TIMEOUT - CHANNEL DID NOT GO FULL.

          LDK    EDNE                                        ** EDNE **
 INX6     DCN    CH40        DISCONNECT CHANNEL
          RJM    MHP
          RETURN

*         CHANNEL IS FULL - INPUT THE DATA.

 INX2     LDDL   T0          BLOCK SIZE
 INXA     IAM    **,CH00     INPUT DATA
*         IAPM   **,CH00     OR PACKED INPUT DATA
          ZJN    INX4        IF ALL BYTES READ FROM CHANNEL
*
*         ALL BYTES WERE NOT READ FROM THE CHANNEL, TRY AND DETERMINE THE
*         REASON.
*
          IJM    INX5,CH00   IF CHANNEL INACTIVE
          EJM    INX7,CH00   IF NO MORE DATA ON CHANNEL
          RJM    INCE        INPUT EXCESS DATA FROM CHANNEL.
          LDK    EDAI                                        ** EDAI **
          UJK    INX6

 INX7     LDK    EDEI                                        ** EDEI **
          UJK    INX6

 INX4     EJM    INX3,CH00   IF CHANNEL EMPTY
          RJM    INCE        INPUT EXCESS DATA FROM CHANNEL.
          LDK    EDMT                                        ** EDMT **
          UJK    INX6

 INX3     AJM    INXX,CH00   EXIT IF NO DEADMAN TERMINATE

*         ERROR - DEADMAN TERMINATE.

 INX5     LDK    EDIT                                        ** EDIT **
          UJK    INX6
 I1S      SPACE  4,20
** NAME - I1S
*
** PURPOSE - INPUT 1 STATUS-WORD.
*
** INPUT - (NONE)
*
** OUTPUT - (A) = 0 - NO HARDWARE ERROR AND CONTROL PROCESSOR RUNNING
*           (A) = NON-ZERO - HARDWARE ERROR OR CONTROL PROCESSOR NOT RUNNING
*
** NOTES - THIS ROUTINE IS USED PRIMARILY TO VALIDATE
*          THAT NO PARITY ERROR OCCURRED ON LAST FUNCTION.
*
          SPACE  2,10
 I1S      SUBR               ENTRY/EXIT

          LDK    FCHS1       FUNCTION CODE HARDWARE STATUS ONE WORD
          RJM    INS         INPUT STATUS WORD(S)
          RETURN
 I2S      SPACE  4,20
** NAME - I2S
*
** PURPOSE - INPUT 2 STATUS-WORDS.
*
** INPUT - (NONE)
*
** OUTPUT - (A) = 0 - NO HARDWARE ERROR AND CONTROL PROCESSOR RUNNING
*               = NONZERO - HARDWARE ERROR OR CONTROL PROCESSOR NOT
*                           RUNNING
*
          SPACE  2,10
 I2S      SUBR               ENTRY/EXIT

          RJM    WHNB        WAIT FOR HARDWARE NOT BUSY.
          NJN    I2S10

*
*         MOVE CURRENT SOFTWARE STATUS WORD TO PREVIOUS SOFTWARE STATUS WORD
*
          LDDL   ST+1
          STDL   PST+1       SAVE CURRENT SOFTWARE STATUS
*
*         INITIALIZE THE STATUS WORD TO ALL ONES
*
          LCN    0
          STDL   ST+1

          LDK    FCHS2       FUNCTION CODE HARDWARE STATUS TWO WORD
          RJM    INS         INPUT STATUS WORD(S)
 I2S10    RETURN             EXIT
 LFU      SPACE  4,20
** NAME - LFU
*
** PURPOSE - LOAD FORMATTED UIT ADDRESS.
*            LOADS A AND R FOR CENTRAL MEMORY REQUEST TO UIT.
*
** INPUT - (NONE)
*
** OUTPUT - A AND R POINTING START OF UIT.
*
          SPACE  2,10
 LFU      SUBR               ENTRY/EXIT
          LOADF  UNITD+/UD/P.UQT,UDPNT  POINT A AND R AT UIT
          RETURN             EXIT
 LF2      SPACE  4,20
** NAME - LF2
*
** PURPOSE - LOAD FORMATTED 2,CMDADR.
*            LOADS A AND R FOR CENTRAL MEMORY TRANSFER.
*
** INPUT - RMA IN 2,CMDADR.
*
** OUTPUT - A AND R SET UP WITH CM ADDRESS OF INPUT RMA.
*
          SPACE  2,10
 LF2      SUBR               ENTRY/EXIT
          LOADF  2,CMDADR    LOAD A AND R WITH RMA
          RETURN             EXIT
 LPQ      SPACE  4,20
** NAME - LPQ
*
** PURPOSE - LOCK PP-REQUEST QUEUE.
*
** INPUT - (NONE)
*
** OUTPUT - A REGISTER = 0 IF LOCK WAS SUCCESSFULLY SET.
*                      .NE. 0 IF LOCK COULD NOT BE SET.
*
          SPACE  2,10
 LPQ      SUBR               ENTRY/EXIT
          LDK    1
          STDL   PPLOCK      SET PP LOCKED FLAG
          LDK    CM.PIT      PP INTERFACE TABLE ADDRESS
          STDL   T4
          LDK    /PIT/C.LOCK  OFFSET OF PP QUEUE LOCKWORD
          STDL   T5
          RJM    SLB         SET LOCKWORD BIT
          ZJN    LPQ1        RETURN IF LOCK WAS SET
          LDK    0
          STDL   PPLOCK      CLEAR LOCK FLAG SINCE PP NOT LOCKED
          LDK    1           SET NO LOCK INDICATOR
 LPQ1     RETURN             EXIT
 MCL      SPACE  4,20
** NAME - MCL
*
** PURPOSE - MAIN-MEMORY CHANNEL LOAD/UNLOAD.
*            LOADS/UNLOADS MAIN-MEMORY VIA CHANNEL WHEN MAP
*            HARDWARE IS NOT CONNECTED TO DMA/CMI.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 MCL      SUBR               ENTRY/EXIT
          RJM    EDT         EXECUTE DATA TRANSFER
          RJM    WNB         WAIT NOT BUSY
          RJM    ESO
          ZJN    MCL5        IF NO ERROR
          RJM    EMAP
 MCL5     RETURN             EXIT
 MHP      SPACE  4,20
** NAME - MHP
*
** PURPOSE - MAP HARDWARE PROBLEMS - RETRY - REPORT PROBLEMS.
*
** INPUT - (A) = ERROR CODE.
*          (XERC) = ERROR RETRY COUNT.
*          (XRTY) = ERROR RETRY RE-ENTRY ADDRESS.
*          (XNRT) = NO RETRY RETURN ADDRESS.
*          (TCCP) = CHECKPOINT FLAG.
*
** OUTPUT - RETRY = JUMP TO RE-ENTRY ADDRESS (XRTY).
*                (XERC) = ERROR COUNT INCREMENTED.
*           NON-RETRY = JUMP TO NO RETRY ADDRESS (XNRT).
*                (DOWN THE MAP AND REQUEST ON LINE
*                DIAGNOSTICS TO BE RUN).
*
** NOTES - THE ERROR RETRY COUNT WILL BE USED TO DETERMINE
*          IF THE FUNCTION SHOULD BE TRIED AGAIN OR IF THE
*          REQUEST SHOULD BE TERMINATED. NO RETRY IS POSSIBLE
*          IF THE RETRY ADDRESS IS ZERO.  THE MAP FAILURE
*          FLAG IS SET.
*
          SPACE  2,10
 MHP      SUBR               ENTRY/EXIT

*         CHECK FOR ERROR RETRIES COMPLETED.

          STML   XERR        SAVE THE ERROR CODE
          AOML   XERC        INCREMENT THE ERROR COUNT
          SBN    OPTR
          PJN    MHP1        IF ALL RETRIES COMPLETED

*         GO RETRY THE MAP FUNCTION AGAIN.

          LDML   XRTY        GET RE-ENTRY ADDRESS
          ZJN    MHP1        IF NO RETRY POSSIBLE
          STDL   T2
          LJM    0,T2        EXIT TO RE-ENTRY POINT

*         ALL RETRIES HAVE BEEN ATTEMPTED AND THE ERROR PERSISTS.
*         SUSPEND SCANNING FOR RESPONSES.

 MHP1     LDK    /RS/K.HDWR  HARDWARE ERROR
          RAML   RESBUF+/RS/P.HDWR  ABNORMAL STATUS FIELD
          LDML   XGUP        GIVE UP ON ERROR -  TRANSFER ADDRESS
          ZJN    MHP2        NO SPECIAL HANDLING
          STDL   T2
          LJM    0,T2

 MHP2     LDML   XERR        LOAD MAP ERROR CODE
          RJM    EMAP
          LDK    0
          STDL   SCNFLG      STOP SCANNING FOR RESPONSES.
          LDML   MHP         ADDRESS OF CALLER TO THIS ROUTINE
          STML   RESBUF+/RS/P.PPEA  SAVE ADDRESS OF CALLER
          RETURN
 NXTCMD   SPACE  4,20
** NAME - NEXTCMD
*
** PURPOSE - TO UPDATE CMDADR AND CMDADR1 TO POINT TO THE NEXT COMMAND
*
* INPUT - CMDADR = ADDRESS OF CURRENT COMMAND
*         CMDADR1 = ADDRESS OF CURRENT COMMAND LENGTH FIELD
*
** OUTPUT - CMDADR = ADDRESS OF NEXT COMMAND
*           CMDADR1 = ADDRESS OF NEXT COMMAND LENGTH FIELD
*
          SPACE  2,10
 NEXTCMD  SUBR
          LDK    4
          RADL   CMDADR      POINT TO NEXT COMMAND FIELD.
          ADK    1
          STDL   CMDADR1     POINT TO NEXT COMMAND LENGTH FIELD.
          ADK    -REQBUFE    SUBTRACT BUFFER END
          MJN    NEXTX       EXIT - COMMAND IS WITHIN BUFFER
          LDDL   XRQI        FETCH COMMAND OFFSET
          STML   RDSEGA      PROVIDE FOR READ ROUTINE
          RJM    RDSEG       GO READ NEXT REQUEST SEGMENT
 NEXTX    RETURN
 OTF      SPACE  4,20
** NAME - OTF
*
** PURPOSE - OUTPUT FUNCTION-CODE.
*
** INPUT - (A) = 12 BIT FUNCTION CODE.
*          (XTLB) = TIMEOUT PERIOD.
*
** OUTPUT - NORMAL = FUNCTION SENT TO MAP.
*           (XLFC) = FUNCTION CODE SENT.
*           ABNORM = JUMP TO *HNG* WITH (A) = ERROR CODE.
*
          SPACE  2,10
 OTFX     LDK    0
 OTF      SUBR               ENTRY/EXIT
          STML   XLFC        SAVE FUNCTION CODE
          AJM    OTF2,CH00   IF ACTIVE BEFORE FUNCTION SENT
          FAN    CH00        OUTPUT THE FUNCTION

          LDML   XTLB        TIMEOUT VALUE

 OTF1     IJM    OTFX,CH00   EXIT WHEN CHANNEL INACTIVE
          SBN    1
          PJK    OTF1        LOOP UNTIL TIMEOUT

*         ERROR - NO RESPONSE TO FUNCTION.

          LDK    EDNR                                        ** EDNR **
          UJN    OTF3

*         ERROR - ACTIVE BEFORE FUNCTION.

 OTF2     LDK    EDAC                                        ** EDAC **
 OTF3     RJM    MHP
          DCN    CH40        DISCONNECT CHANNEL
          RETURN

 OTX      SPACE  4,20
** NAME - OTX
*
** PURPOSE - OUTPUT DATA ON THE MAP CHANNEL.
*
** INPUT - (NONE)
** INPUT - (A) = FWA OF OUTPUT BUFFER.
*          (T0)  = LENGTH IN PP WORDS.
*          (XTLC) = TIMEOUT PERIOD.
*
** OUTPUT - NORMAL = OUTPUT COMPLETED.
*           ABNORM = JUMP TO *HNG* WITH (A) = ERROR CODE.
*
** NOTES - THERE ARE 3 ENTRY POINTS TO THIS SUBROUTINE:
*             OTB = CHANNEL IS CONNECTED BEFORE OUTPUT AND
*                   DISCONNECTED AFTER OUTPUT.
*             OTC = CHANNEL IS CONNECTED BEFORE OUTPUT ONLY.
*             OTX = CHANNEL IS NOT CONNECTED OR DISCONNECTED.
*
          SPACE  2,10

*         SPECIAL ENTRY POINT FOR CONNECT AND DISCONNECT CHANNEL.


 OTB      SUBR               ENTRY/EXIT
          ACN    CH40        CONNECT CHANNEL
          RJM    OTX         OUTPUT DATA
          NJN    OTB1
          RJM    OTE         CHECK CHANNEL FOR EMPTY
 OTB1     RETURN             EXIT

*         SPECIAL ENTRY POINT FOR CONNECT CHANNEL ONLY.

 OTC      SUBR               ENTRY/EXIT
          ACN    CH40        CONNECT CHANNEL
          RJM    OTX         OUTPUT DATA
          RETURN             EXIT

*         ENTRY POINT FOR COMMON OUTPUT SUBROUTINE.

 OTXX     BSS    0
 OTX      SUBR               ENTRY/EXIT
          STML   OTXA+1      SAVE THE BUFFER ADDRESS

          IFEQ   F16BD,1                                    ***** ****
          LDDL   F16BIO      FLAG 16 BIT I/O

*         CALLING ROUTINE MUST INSURE THAT ONLY BIT 0 IS USED.

          SHN    15D-0
          STD    F16BIO      12 BIT STORE TO CLEAR FLAG FOR NEXT PASS
          ADM    OTXA        12 BIT ADD OF 73XX INSTRUCTION
          STML   OTXA        16 BIT STORE OF X073XX INSTUCTION
          ENDIF                                             * *** ** *

          LDDL   T0          GET SIZE OF BLOCK
          FJM    OTX1,CH00   IF CHANNEL FULL BEFORE OUTPUT
 OTXA     OAM    **,CH00     OUTPUT DATA
*         OAPM   **,CH00     OR PACKED OUTPUT DATA
          AJM    OTXX,CH00   EXIT IF NO DEAD MAN TIMEOUT

*         ERROR - DEADMAN TIMEOUT.

          LDK    EDOT                                        ** EDOT **
 OTX2     RJM    MHP
          DCN    CH40        DISCONNECT CHANNEL
          UJK    OTXX

*         ERROR - CHANNEL FULL BEFORE OUTPUT.

 OTX1     LDK    EDFL                                        ** EDFL **
          UJK    OTX2

*         NORMAL OUTPUT OCCURRED - WAIT FOR CHANNEL EMPTY.

 OTEX     LDK    0
 OTE2     DCN    CH40        DISCONNECT CHANNEL
 OTE      SUBR               ENTRY /EXIT
          LDML   XTLC        TIMEOUT VALUE
 OTE1     EJM    OTEX,CH00   EXIT IF EMPTY
          SBN    1
          NJK    OTE1        LOOP UNTIL EMPTY OR TIMEOUT

*         ERROR - CHANNEL NEVER WENT EMPTY.

          LDK    EDMT                                        ** EDMT **
          RJM    MHP
          UJK    OTE2
 PAUSS     SPACE  4,20
** NAME - PAUSS
*
** PURPOSE - DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*            SECONDS.
*
** INPUT - (A) - NUMBER OF SECONDS TO DELAY
*
          SPACE  2,10
 PAUSS    SUBR               ENTRY/EXIT
          SHN    2           NUMBER OF SECONDS * 4
          STDL   P1
 PAUSS1   PAUSE  250000
          SODL   P1
          NJK    PAUSS1       IF HAVE NOT WAITED SPECIFIED NUMBER OF SECONDS
          RETURN             EXIT
 PAUS     SPACE  4,20
** NAME - PAUS
*
** PURPOSE - DELAY PROGRAM EXECUTION FOR A SPECIFIED NUMBER OF
*            MICROSECONDS.
*
** INPUT - A REGISTER (BITS 00-06) SPECIFIES NUMBER OF MICROSECONDS
*          TO BE DELAYED.
*
          SPACE  2,10
 PAUS     SUBR               ENTRY/EXIT
 PAUS1    SBN    1           EACH ITERATION OF THIS SBN-NJN LOOP
          PSN
          PSN
          NJK    PAUS1       UTILIZES 1 MICROSECOND
          RETURN             EXIT
 PC0      SPACE  4,20
** NAME - PC0
*
** PURPOSE - PP COMMAND 0 - ACKNOWLEDGE.
*
** INPUT - ADDRESS OF COMMAND IN CMDADR.
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 PC0      SUBR               ENTRY/EXIT
*         RJM    RSP         STORE A RESPONSE
          RETURN             EXIT
 PC1      SPACE  4,20
** NAME - PC1
*
** PURPOSE - PP COMMAND 1 - STOP UNIT.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 PC1      SUBR               ENTRY/EXIT
          LDML   2,CMDADR
          STDL   XRQA        RMA OF REQUEST TO TERMINATE.
          LDML   3,CMDADR
          STDL   XRQA+1      RMA OF REQUEST TO TERMINATE.
          RJM    RDVREQ      READ AND VALIDATE REQUEST.
          ZJN    PC1V        IF REQUEST VALID.
          LDK    ERC506
          RJM    EPC

*         NO RETURN.  RJM RECORDS ADDRESS OF ERROR ROUTINE.

 PC1V     LDK    1
          STDL   UQFLG
          RJM    INTRES      INITIALIZE RESPONSE BUFFER FOR UNIT RESPONSE.
          LDK    /RS/K.FORC
          RAML   RESBUF+/RS/P.FORC  SET FORCED TERMINATION BIT.
          LDK    R.ABN
          STML   RESBUF+/RS/P.RC  SET ABNORMAL TERMINATION.
          RJM    RSP         SEND RESPONSE TO CPU.
          LOADF  PPTBL+/PIT/P.PPQ
          CRML   REQBUF,WC   READ PP REQUEST.
          LDK    0
          STDL   UQFLG
          RJM    INTRES      INITIALIZE RESPONSE BUFFER FOR PP RESPONSE.
          RETURN             EXIT
 PC2      SPACE  4,20
** NAME - PC2
*
** PURPOSE - PP COMMAND 2 - SELECT UNIT.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 PC3      SPACE  4,20
** NAME - PC3
*
** PURPOSE - PP COMMAND 3 - SELECT CONTROLLER.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 PC3      SUBR               ENTRY/EXIT
          LDK    0           ENABLE CMI PORT.
          RJM    EPT
          RETURN             EXIT
 PC4      SPACE  4,20
** NAME - PC4
*
** PURPOSE - PP COMMAND 4 - IDLE.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 PC4      SUBR               ENTRY/EXIT
          LDK    1           SET THE IDLE FLAG NONZERO
          STDL   IDLFLG
          RETURN             EXIT
 PC5      SPACE  4,20
** NAME - PC5
*
** PURPOSE - PP COMMAND 5 - RESUME.
*
** INPUT
*
** OUTPUT - (NONE)
*
          SPACE  4
 PC5      SUBR               ENTRY/EXIT
          LDK    0
          STDL   IDLFLG      CLEAR THE IDLE FLAG
          STDL   PPHUNG      CLEAR PP HUNG FLAG.
          RETURN             EXIT
 PC7      SPACE  4,20
** NAME - PC7
*
** PURPOSE - PP COMMAND 7 - START READY SCAN.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 PC7      SUBR               ENTRY/EXIT
          LDK    1
          STDL   SCNFLG      SET SCAN UNIT FLAG
          RETURN             EXIT
 PC8      SPACE  4,20
** NAME - PC8
*
** PURPOSE - PP COMMAND 8 - STOP READY SCAN.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 PC8      SUBR               ENTRY/EXIT
          LDK    0
          STDL   SCNFLG      CLEAR SCAN UNITS FLAG.
          RETURN             EXIT
 PC10     SPACE  4,20
** NAME - PC10
*
** PURPOSE - PP COMMAND 10 - ENABLE UNIT
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 PC10     SUBR               ENTRY/EXIT
          LDK    0           ENABLE UNIT.
          RJM    EAU
          RETURN
PC11      SPACE  4,20
** NAME - PC11
*
** PURPOSE - PP COMMAND 11 - DISABLE UNIT
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 PC11     SUBR               ENTRY/EXIT
          LDK    1           DISABLE UNIT
          RJM    EAU
          RETURN
PC16      SPACE  4,20
** NAME - PC16
*
** PURPOSE - PP COMMAND 16 - MASTER CLEAR CHANNEL
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 PC16     SUBR               ENTRY/EXIT
          PAUSE  250000
          ACN    CH40
          PAUSE  250000
          EJM    PC16A,CH00  IF CHANNEL EMPTY.
          LDK    5
          RJM    PAUSS        WAIT FOR 5 SECONDS.
 PC16A    DCN    CH40
          RETURN
 PC17     SPACE  4,20
** NAME - PC17
*
** PURPOSE - PP COMMAND 17 - MASTER CLEAR CONTROLLER
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 PC17     SUBR               ENTRY/EXIT
          LDK    1           DISABLE CMI PORT.
          RJM    EPT
          RETURN
 PC12     SPACE  4,20
 PC2      BSS    0           FUTURE IMPLEMENTATION
 PC12     BSS    0           FUTURE IMPLEMENTATION
 PC13     BSS    0           FUTURE IMPLEMENTATION
 PC14     BSS    0           FUTURE IMPLEMENTATION
 PC15     BSS    0           FUTURE IMPLEMENTATION
 PC18     BSS    0           FUTURE IMPLEMENTATION
 PC19     BSS    0           FUTURE IMPLEMENTATION
 PC1A     BSS    0           FUTURE IMPLEMENTATION
 PC1B     BSS    0           FUTURE IMPLEMENTATION
 PC1C     BSS    0           FUTURE IMPLEMENTATION
 PC1D     BSS    0           FUTURE IMPLEMENTATION
 PC1E     BSS    0           FUTURE IMPLEMENTATION
 PC1F     BSS    0           FUTURE IMPLEMENTATION
 PC20     BSS    0           FUTURE IMPLEMENTATION
 PC21     BSS    0           FUTURE IMPLEMENTATION
 PC22     BSS    0           FUTURE IMPLEMENTATION

          SUBR               ENTRY
          UJK    DCM..       GO TO ERROR EXIT
 PPR      SPACE  4,20
** NAME - PPR
*
** PURPOSE - TO DETERMINE IF THERE ARE ANY PP REQUESTS TO PROCESS.
*            IF THERE ARE, THE FIRST ONE IS COPIED INTO PP MEMORY.
*
** INPUT - (NONE)
*
** OUTPUT - A=0 IF NO PP REQUESTS.
*           A .NE. 0 IF THERE IS A PP REQUEST TO PROCESS.
*
          SPACE  2,10
 PPR5     RJM    CLP         CLEAR PP LOCKWORD
 PPR6     LDK    0           SET FLAG FOR NO REQUESTS FOUND

 PPR      SUBR               ENTRY/EXIT
          RJM    LPQ         LOCK PP-REQUEST QUEUE
          NJK    PPR6        RETURN IF PP REQUEST QUEUE ALREADY LOCKED
          LDK    PITLEN      GET LENGTH OF PIT IN CM WORDS
          STDL   WC          SAVE LENGTH FOR CM READ
          LOADC  CM.PIT      CM ADDRESS TO A AND R FOR READ
          CRML   PPTBL,WC    READ IN PIT
          LDML   PPTBL+/PIT/P.PPQ  GET HALF 1 OF RMA OF 1ST REQUEST
          ADML   PPTBL+/PIT/P.PPQ+1
          ZJK    PPR5        IF RMA = 0 NO PP REQUEST QUEUED

          IFNE   EFLAG2,0    TURN OFF PP INT TABLE VERIFICATION IF EFLAG2 = 0
          RJM    VPI         VERIFY PIT
          ENDIF
          LDK    MAXREQ
          STDL   WC          SET MAX LENGTH OF PP REQUEST FOR CM READ
          LOADF  PPTBL+/PIT/P.PPQ  CM ADDRESS OF REQUEST TO A AND R
          CRML   REQBUF,WC   READ PP REQUEST

*         IF IDLE, ONLY DO RESUME COMMAND.

          LDDL   IDLFLG
          ZJN    PPR1        SKIP RESUME CHECK IF PP NOT IDLE
          LDML   REQBUF+/RQ/P.CMND  GET 1ST COMMAND
          SHN    -8D         SHIFT OFF FLAGS
          SBN    RSUMCMD
          NJK    PPR5        EXIT IF NOT RESUME COMMAND
 PPR1     LDK    2
          STDL   WC          SET FOR 2 CM WORD TRANSFER
          LOADF  PPTBL+/PIT/P.PPQ
          CWML   PPTBL+/PIT/P.PPQPVA-1,WC  REWRITE PVA AND RMA.
          LOADC  CM.PIT      SET A AND R TO PP INTERFACE TABLE
          ADK    /PIT/C.PPQPVA  SET A AND R TO PVA IN PP INTERFACE TABLE
          CWML   REQBUF+/RQ/P.NEXTPV-1,WC  RESET PVA AND RMA TO NEXT PVA AND RMA
          LOADF  PPTBL+/PIT/P.PPQ
          CRML   REQBUF,WC   REREAD LINK INFORMATION.
          LDK    0
          STDL   UDPNT       SET UNIT DESCRIPTOR TABLE INDEX
          STDL   UQFLG       CLEAR UNIT QUEUE FLAG
          LDML   REQBUF+/RQ/P.LU  GET LOGICAL UNIT NUMBER
          STDL   T2          SAVE LOGICAL UNIT NUMBER
          ZJN    PPR3        IF NO I/O COMMANDS SKIP
          LDML   PPTBL+/PIT/P.UNITC  GET NO OF UNITS
          STDL   T1          SAVE NO OF UNITS FOR SEARCH LOOP
 PPR2     LDML   UNITD+/UD/P.LU,UDPNT  GET LOGICAL UNIT NO FROM UD ENTRY
          SBDL   T2          SUBTRACT LOGICAL UNIT NO FROM REQUEST
          ZJN    PPR3        JUMP IF FOUND UNIT
          SODL   T1          DECREMENT UNIT COUNTER

          IFNE   EFLAG4,0    NO REQUEST HEADER VERIFY IF EFLAG4 = 0
          ZJK    VPR4        ERROR IF NO FIND
          ELSE
          NJN    PPR7        IF ABLE TO FIND UNIT
          RJM    HNG
 PPR7     BSS    0
          ENDIF

          LDK    P.UD
          RADL   UDPNT       INCREMENT POINTER TO NEXT UD ENTRY
          UJK    PPR2        RELOOP TO NEXT UNIT
 PPR3     RJM    CLP         UNLOCK PPQ
          RJM    INTRES      INITIALIZE RESPONSE BUFFER FOR PP RESPONSE.

          IFNE   EFLAG4,0    NO REQUEST HEADER VALIDATION IF EFLAG4=0
          RJM    VPR         VERIFY PP REQUEST AND SET UP RESPONSE BUFFER
          ENDIF

          LDK    1           SET GOT REQUEST FLAG
 PPR4     RETURN             EXIT

 RDI      SPACE  4,20
** NAME - RDI
*
** PURPOSE - READ DATA INDIRECT (USE INDIRECT LIST).
*
** INPUT - (A) = ADDRESS TO READ DATA INTO.
*
** OUTPUT - DATA IS READ IN.
*
          SPACE  2,10
 RDIX     BSS    0

 RDI      SUBR               ENTRY/EXIT
          STML   RDIA        SET FIRST ADDRESS FOR CM READ
          LDIL   CMDADR1     GET LENGTH OF INDIRECT LIST
          SHN    -3          CONVERT IT TO CM WORDS
          STDL   T5          INITIALIZE LOOP CONTROL
          LDK    INDLST      GET ADDRESS OF INDIRECT LIST
 RDI1     STDL   T6          SET INDIRECT COMMAND POINTER
          LDML   1,T6        GET LENGTH IN BYTES
          ADK    7
          SHN    -3          CONVERT LENGTH TO CM WORDS
          STDL   WC          SAVE LENGTH FOR CM READ
          LOADF  2,T6        CM ADDRESS TO A AND R FOR CM READ
          CRML   **,WC       READ DATA FROM CM
 RDIA     EQU    *-1
          SODL   T5          DECREMENT LOOP COUNTER BY 1
          ZJK    RDIX        RETURN IF DONE
          LDML   1,T6        GET LENGTH OF INDIRECT IN BYTES
          SHN    -1          CONVERT LENGTH TO PP WORDS
          RAML   RDIA        RESET ADDRESS FOR NEXT CM READ
          LDDL   T6
          ADK    4           POINT TO NEXT INDIRECT IN LIST
          UJK    RDI1        RELOOP FOR NEXT CM READ
 RDSEG    SPACE 4,20
** NAME - RDSEG
*
** PURPOSE - TO READ A SEGMENT OF A UNIT REQUEST WHEN THE
*            LENGTH OF THE REQUEST EXCEEDS THE REQUEST BUFFER
*            SIZE IN THE PP
*
** INPUT - XRQA, XRQA+1 CONTAIN THE RMA OF THE REQUEST TO READ
*
** OUTPUT - CMDADR, CMDADR+1 POINT THE FIRST COMMAND IN THIS
*           SEGMENT OF THE REQUEST
*
          SPACE  2,10
 RDSEG    SUBR
          LDK    MAXCMD      MAX NO. THAT FIT IN BUFFER
          STDL   WC          SAVE FOR DOING I/O
          LOADF  XRQA        FETCH REQUEST RMA
          ADK    HDRWDS      SKIP OVER REQUEST HEADER
          ADC    **          ADD OFFSET TO POSITION TO
 RDSEGA   EQU    *-1           SEGMENT NEEDED
          SBDL   LAFLG       DECREMENT IF CALL FOR LOOK AHEAD
          CRML   REQBUF+/RQ/P.CMND,WC
          LDK    REQBUF+/RQ/P.CMND
          STDL   CMDADR      POINT TO FIRST COMMAND IN BUFFER
          ADK    1
          STDL   CMDADR1
          RETURN
 RDVREQ   SPACE 4,20
** NAME - RDVREQ
*
** PURPOSE - TO READ A UNIT REQUEST FROM CM AND COMPARE THE
*           RMA CONTAINED IN THE REQUEST WITH THE RMA USED
*           TO READ THE REQUEST.
*
** INPUT - XRQA, XRQA+1 CONTAIN THE RMA OF THE REQUEST TO READ.
*
** OUTPUT - (A) = 0 - REQUEST READ INTO REQBUF AND RMA CONTAINED IN
*                     REQUEST MATCHES THE RMA USED TO READ THE REQUEST.
*           (A) = NONZERO - RMA CONTAINED IN THE REQUEST DID NOT MATCH
*                           THE RMA USED TO READ THE REQUEST.
*
          SPACE  2,10
 RDVREQ   SUBR
          LDK    MAXREQ      GET LENGTH OF REQUEST FOR CM READ
          STDL   WC          SAVE LENGTH FOR CM READ
          LOADF  XRQA        SET A AND R TO ADDRESS OF REQUEST
          CRML   REQBUF,WC   READ IN UNIT REQUEST

*         VALIDATE REQUEST READ FROM CM

          LDML   REQBUF+/RQ/P.NEXT
          LMDL   XRQA
          NJN    RDVREQ1     IF RMAS DO NOT MATCH.
          LDML   REQBUF+/RQ/P.NEXT+1
          LMDL   XRQA+1
 RDVREQ1  RETURN
 RIL      SPACE  4,20
** NAME - RIL
*
** PURPOSE - READ INDIRECT LIST INTO *INDLST*.
*
** INPUT - (NONE)
*
** OUTPUT - (BYTCNT) = BYTE COUNT OF LIST.
*
          SPACE  2,10
 RILX     BSS    0

 RIL      SUBR               ENTRY/EXIT

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          UJN    RILE14      JUMP OVER ERROR CODES

*         ERROR EXITS FOR ERC5XX CODES.

 RILE5    LDK    ERC505      INVALID LENGTH IN COMMAND
          UJN    RILE13      CONTINUE
 RILE7    LDK    ERC507      INVALID LENGTH IN INDIRECT LIST
          UJN    RILE13      CONTINUE
 RILE8    LDK    ERC508      INVALID ADDRESS IN INDIRECT LIST
          UJN    RILE13      CONTINUE
 RILE12   LDK    ERC50C      RESERVED FIELD IN INDIRECT LIST NOT ZERO
          UJN    RILE13      CONTINUE
 RILE13   RJM    EPC         ERROR PP(NOS/VE) COMMAND SEQUENCE

*         NO RETURN.  RJM RECORDS ADDRESS OF ERROR ROUTINE.

 RILE14   LDIL   CMDADR1     GET LENGTH OF INDIRECT LIST
          MJK    RILE5       ERROR IF NEG (TOO LARGE)
          ZJK    RILE5       ERROR IF LENGTH OF INDIRECT LIST IS ZERO
          LPN    7           MASK OFF LOWER THREE BITS
          NJK    RILE5       ERROR IF LENGTH NOT A MULTIPLE OF 8
          ENDIF

          LDIL   CMDADR1     GET LENGTH OF INDIRECT LIST
          SHN    -3          DIVIDE BY 8 TO GET CM WORD COUNT
          STDL   T5          SAVE CM WORD COUNT

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          SBN    MAXIND+1    SUBTRACT 1 MORE THAN MAX ALLOWED INDIRECTS
          PJK    RILE5       ERROR IF TOO MANY INDIRECTS
          ENDIF

*         READ INDIRECT LIST INTO INDLST.

          RJM    LF2         SET UP CM ADDRESS IN A AND R
          CRML   INDLST,T5   READ INDIRECT LIST

*         VERIFY LIST.  ALL ADDRESS MUST BE ON WORD BOUNDARIES AND ALL
*         LENGTHS EXCEPT THE LAST MUST BE MULTIPLES OF 8.

          LDDL   T5          GET NO OF ADDRESS PAIRS IN LIST
          SBN    1           DEC BY 1
          SHN    2           MULT BY 4 TO POINT TO LAST ONE IN LIST
          STDL   T4          SAVE POINTER TO LAST ADDRESS/LENGTH PAIR

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          LDML   INDLST,T4   GET UPPER 2 BYTES OF INDIRECT
          NJK    RILE12      ERROR IF NOT ZERO
          LDML   INDLST+3,T4 GET ADDRESS FROM LAST ADDRESS/LENGTH PAIR
          LPN    7           MASK OFF LOWER 3 BITS OFF ADDRESS
          NJK    RILE8       ERROR IF ADDRESS NOT ON A WORD BOUNDARY
          ENDIF

          LDML   INDLST+1,T4 GET LENGTH FROM LAST ADDRESS/LENGTH PAIR
          STDL   BYTCNT      INITIALIZE TOTAL XFER BYTE COUNT FOR LIST

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          MJK    RILE7       ERROR IF LENGTH NEGATIVE (TOO LARGE)
          ZJK    RILE7       ERROR IF LENGTH ZERO
          ENDIF

          LDK    0
          STDL   T6          INITIALIZE INDEX
 RIL1     SODL   T5          DECREMENT LOOP COUNTER BY 1
          ZJK    RILX        JUMP WHEN ENTIRE LIST PROCESSED
          LDML   INDLST+1,T6  GET LENGTH FROM ADDRESS/LENGTH PAIR
          RADL   BYTCNT      COMPUTE TOTAL LENGTH FOR LIST

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          MJK    RILE7       ERROR IF NEG (TOO LARGE)
          LDML   INDLST+1,T6  GET LENGTH FROM ADDRESS/LENGTH PAIR LIST
          ZJK    RILE7       ERROR IF LENGTH IS ZERO
          LPN    7           MASK OFF LOWER 3 BITS
          NJK    RILE7       IF LENGTH NOT MULTIPLE OF 8 ERROR
          LDML   INDLST+3,T6  GET LOWER HALF OF ADDRESS FROM LIST
          LPN    7           MASK OFF LOWER THREE BITS OF ADDRESS
          NJK    RILE8       ERROR IF ADDRESS NOT ON A WORD BOUNDARY
          LDML   INDLST,T6   GET COMMAND AND FLAG FIELDS FROM INDIRECT
          NJK    RILE12      ERROR IF NOT ZERO
          ENDIF

          LDK    4
          RADL   T6          POINT TO NEXT ITEM IN LIST
          UJK    RIL1        RELOOP
 RNR      EJECT
** NAME - RNR
*
** PURPOSE - REQUEST NEXT-AVAILABLE RESPONSE.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 RNR      SUBR               ENTRY/EXIT
*
*         SET UP CONTROL WORDS FOR RESPONSE PACKET.
*
          LDK    FCAN        NEXT-AVAILABLE RESPONSE PACKET REQUEST
          STML   XCWB+4      STORE FUNCTION CODE
          RJM    WFF         WRITE FLAG FUNCTION
          NJN    RNR1

          RJM    RRP         READ RESPONSE PACKET
          ZJN    RNR1        IF RESPONSE PACKET SUCCESSFULLY READ

          RJM    EMAP
 RNR1     RETURN             EXIT
 RQLKA    SPACE  4,20
** NAME - RQLKA
*
** PURPOSE - DETERMINE IF THE COMMAND IS IN THE REQUEST BUFFER
*            FOR A LOOK AHEAD SEQUENCE
*
** INPUT - CMDADR, CMDADR1 CONTAIN THE CURRENT COMMAND ADDRESS
*          LAFLG IS NON-ZERO TO INDICATE THAT THE CURRENT COMMAND
*            MUST BE THE FIRST IN THE BUFFER IF A READ NEXT
*            SEGMENT IS REQUIRED
*
** OUTPUT - LAFLG RESET TO ZERO
*
          SPACE  2,10
 RQLKA    SUBR
          LDDL   CMDADR      FETCH CURRENT COMMAND ADDRESS
          ADK    4           ADD COMMAND LENGTH IN PP WORDS
          ADK    -REQBUFE    SUBTRACT END OF BUFFER ADDRESS
          MJN    RQLKA5      NEXT COMMAND IS ALREADY IN BUFFER
          LDDL   XRQI        FETCH COMMAND OFFSET
          STML   RDSEGA      PROVIDE FOR READ ROUTINE
          RJM    RDSEG       GO READ NEXT SEGMENT
 RQLKA5   LDK    0
          STDL   LAFLG       CLEAR LOOK AHEAD FLAG
          RETURN
 RQP      EJECT
** NAME - RQP
*
** PURPOSE - REQUEST PACKET PROCESSING.
*
** INPUT - (NONE)
*
** OUTPUT - NONE
*
          SPACE  2,10
 RQP1     BSS    0
          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          LDK    ERC505      INVALID LENGTH IN COMMAND
          RJM    EPC         ERROR PP(NOS/VE) COMMAND SEQUENCE

*         NO RETURN.  RJM RECORDS ADDRESS OF ERROR ROUTINE.

          ENDIF

 RQP      SUBR               ENTRY/EXIT

          LDK    IOBUF       SET INPUT BUFFER FWA FOR NEW REQUEST
          STML   RQP3A
          STML   RQP4A
          STDL   T2

          LDDL   XRQI
          STDL   MPCMDI

*         READ IN THE REQUEST PACKET.

 RQP0     BSS    0
          LDIL   CMDADR1     GET LENGTH FOR WRITE COMMAND
          STDL   BYTCNT      SAVE BYTE COUNT FOR THIS TRANSFER

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5=0
          MJK    RQP1        ERROR IF TRANSFER COUNT IS NEG (TOO BIG)
          ZJK    RQP1        ERROR IF TRANSFER COUNT IS ZERO
          SBDL   MAXIO1      SUBTRACT MAX TRANSFER SIZE + 1
          PJK    RQP1        ERROR IF TRANSFER COUNT IS TOO LARGE
          LDDL   BYTCNT      RESTORE BYTE COUNT
          ENDIF

          SHN    -1          CONVERT TO PP WORD COUNT
          ADDL   T2          ADD CURRENT BUFFER POINTER
          ADK    -7770B      BUFFER END+1
          PJN    RQPE2       ACCUMULATED + THIS SEGMENT IS TOO BIG

          LDDL   BYTCNT      RESTORE REQUEST PACKET BYTE COUNT
          ADK    7
          SHN    -3          CONVERT BYTE COUNT TO CM WORD COUNT
          STDL   T5          SAVE CM WORD COUNT FOR CM READ
          LDIL   CMDADR      GET COMMAND AND FLAGS
          LPK    /CM/K.INDIR MASK OFF INDIRECT BIT
          ZJN    RQP4        JUMP IF THERE IS NOT AN INDIRECT LIST

          IFEQ   ILRRP,1                                    ***** ****
          RJM    RIL         READ INDIRECT LIST

*         DETERMINE IF THERE IS ENOUGH ROOM.

          LDDL   BYTCNT      TOTAL BYTE COUNT
          SHN    -1          CONVERT TO PP WORDS
          ADDL   T2          ADD CURRENT BUFFER POINTER
          ADK    -7770B
          MJN    RQP3        IT WILL FIT
 RQPE2    BSS    0
          LDK    RPE02       MAP-V - REQUEST PACKET ERROR   ** RPE02 **
 RQP5     RJM    EMAP        ERROR HANDLING ROUTINE
          UJK    DER         ABNORMAL ERROR PROCESSING

 RQP3     LDK    IOBUF
 RQP3A    EQU    *-1
          RJM    RDI         READ DATA USING INDIRECT LIST
          UJN    RQP6
          ENDIF                                             * * * ** *

 RQP4     RJM    LF2         SET UP A AND R (LOADF  2,CMDADR)
          CRML   IOBUF,T5    READ REQUEST PACKET FROM CM
 RQP4A    EQU    *-1

 RQP6     BSS    0
          LDML   CMIFLG      CHECK FOR PACKED CMI REQUEST PROCESSING
          NJK    RQP14       JUMP TO CONTINUE CMI PROCESSING LOOP

          LDML   TQBE+/RQBP/P.LNG+1    REQUEST LENGTH
          SBN    5           REQUEST MINIMUM LENGTH WITHOUT CHECKSUM WORD
          PJN    RQP11       5 OR GREATER
          LDK    RPE01       MAP-V - REQUEST PACKET ERROR   ** RPE01 **
          UJK    RQP5

*         PUT RSN INTO REQUEST PACKET

 RQP11    LDDL   XRQA        REQUEST RMA UPPER
          STML   TQBE+/RQBP/P.RSN      UPPER HALF OF PACKED RSN
          LDDL   XRQA+1      REQUEST RMA LOWER
          STML   TQBE+/RQBP/P.RSN+1    LOWER BYTE OF RSN

*         WRITE A COPY OF RSN TO CM REQUEST BLOCK.

          IFEQ   ILRRP,1                                    ***** ****
          LDIL   CMDADR      GET COMMAND AND FLAGS
          LPK    /CM/K.INDIR MASK OFF INDIRECT BIT
          ZJN    RQP12       JUMP IF THERE IS NOT AN INDIRECT LIST
          LDK    /RQBP/C.JID       INDEX TO FWA OF PACKET
          RJM    GIA         GET INDEXED ADDRESS FROM INDIRECT LIST
          UJN    RQP13
          ENDIF                                             * * * ** *

 RQP12    RJM    LF2         SET UP A AND R (LOADF  2,CMDADR)
          ADK    /RQBP/C.RSN  INDEX TO FWA OF WORD CONTAINING RSN
 RQP13    CWML   TQBE+/RQBP/C.RSN*4,ONE   WRITE REQUEST PACKET RSN TO CM

*         INCREMENT I/O BUFFER POINTER TO INCLUDE SEGMENT READ IN

 RQP14    BSS    0

          LDDL   BYTCNT      FETCH SEGMENT LENGTH
          SHN    -1          GET PPU BYTES
          RADL   T2          ADDRESS OF NEXT USABLE OR CHECKSUM

*         DETERMINE IF NEXT CMD IS WRITE PARAMETER DATA.

          AODL   XRQI        INCREMENT COMMAND INDEX
          AODL   LAFLG       SET LOOK AHEAD FLAG
          RJM    RQLKA       SEE IF NEXT COMMAND IS IN BUFFER
          LDML   4,CMDADR    NEXT COMMAND AND FLAGS
          LPK    -/CM/K.CMILS  REMOVE POSSIBLE CMI LAST SEGMENT FLAG
          LMK    C.OUTP*400B+/CM/K.INDIR  MASK 2140(16)
          NJK    RQP15       NOT CMI
          AODL   XRQI        INCREMENT COMMAND INDEX
          AOML   CMIFLG      SET TO INDICATE CMI REQUEST PROCESSING

*         MOVE POINTER TO NEXT COMMAND TO PROCESS INDIRECT DATA LIST

          RJM    NEXTCMD
          RJM    RQPBIL      GO PROCESS INDIRECT DATA LIST

*         CHECK COMMAND SEQUENCE FOR PACKED CMI REQUEST

          AODL   LAFLG       SET LOOK AHEAD FLAG
          RJM    RQLKA       SEE IF NEXT COMMAND IS IN BUFFER
          LDML   4,CMDADR    COMMAND FOLLOWING WRITE DATA ON CMI
          SHN    -8D         SHIFT OFF FLAGS
          SBN    C.OUTP
          NJN    RQP15       JUMP TO COMPLETE UNPACKED CMI REQUEST

*         PACKED CMI REQUEST PROCESSING

          LDDL   T2          NEXT USABLE ADDRESS IN BUFFER
          STML   RQP3A       SAVE FOR READING NEXT SEGMENT
          STML   RQP4A
          RJM    NEXTCMD     POINT TO NEXT SEGMENT HEADER
          UJK    RQP0        GO PROCESS NEXT SEGMENT


*         UPDATE THE CURRENT COMMAND INDEX IN THE REQUEST.

 RQP15    BSS    0
          LDDL   MPCMDI
          SHN    8+2
          LMDL   XRQI
          SHN    8
          STML   REQBUF+/RQ/P.CMDIND

*         WRITE CURRENT COMMAND INDEX REQUEST WORD TO CM.

          LOADF  XRQA
          ADK    /RQ/C.CMDIND
          CWML   REQBUF+/RQ/P.CMDIND,ONE
          RJM    RQPCSM      GO CHECKSUM THE REQUEST PACKET
          RJM    WRP         WRITE REQUEST PACKET

          LDK    0
          STML   CMIFLG      CLEAR CMI REQUEST FLAG

          RETURN             EXIT
 RQPBIL   SPACE  4,20
** NAME - RQPBIL
*
** PURPOSE - BUILD AND REFORMAT CMI INDIRECT DATA LIST
*
** INPUT - T2 CONTAINS THE ADDRESS WHERE THE REFORMATTED LIST IS TO BE
*          STORED
*
** OUTPUT - REFORMATTED RMA AND LENGTH PAIRS ARE STORED INTO THE CORRECT
*           PLACE IN THE REQUEST PACKET
*
*
          SPACE  2,10
 RQPBIL   SUBR               ENTRY/EXIT

          LDIL   CMDADR1     GET LENGTH FOR WRITE COMMAND
          SHN    -3          FORCE BYTE COUNT TO CM WORD COUNT
          STDL   T5          SAVE CM WORD COUNT FOR CM READ
          LDIL   CMDADR      FETCH COMMAND AND FLAGS
          LPK    /CM/K.CMILS MASK END OF REQUEST FLAG
          STDL   P3          SAVE IN P3 TEMPORARILY

*         READ IN THE CMI ADDRESS LIST.

          LDDL   T2          CHECK WORD POINTER
          ADK    2           ALLOW FOR WORK AREA
          STML   RQPBA       CMI ADDRESSES READ LOCATION
          RJM    LF2         SET UP A AND R (LOADF  2,CMDADR)
          CRML   **,T5       READ CMI ADDRESSES FROM CM
 RQPBA    EQU    *-1

*         CHANGE ALL BYTE COUNTS TO CM WORD COUNTS
*            AND ALL BYTE ADDRESSES TO WORD ADDRESS.
*         ALSO REVERSE ORDER.  I.E. HOST ADDRESS FOLLOWED
*         BY HOST WORD COUNT AS SPECIFIED BY CMI HARDWARE.

*         INITIALIZE LOOP.
*         STORAGE FWA IS IN T2.

          LDK    0
          STDL   T3          WORD COUNTER

*         MANIPULATE ADDRESSES/BYTE COUNTS

 RQPB10   LDML   4,T2        RMA BYTE ADDRESS UPPER
          SHN    -3
          STIL   T2          RMA WORD ADDRESS UPPER
          AODL   T2
          LDML   3,T2        RMA BYTE ADDRESS UPPER
          LPN    7           ISOLATE 3 BITS
          SHN    15D-2
          STIL   T2
          LDML   4,T2        RMA BYTE ADDRESS LOWER
          SHN    -3
          RAIL   T2
          AODL   T2
          LDK    0
          STIL   T2          UPPER 16 OF HOST WORD COUNT
          AODL   T2
          LDIL   T2
          SHN    -3
          STIL   T2          HOST CM WORD COUNT
          AODL   T2

*         TEST FOR COMPLETION.

          AODL   T3          WORD COUNTER
          SBDL   T5          TOTAL WORDS
          MJK    RQPB10      MORE TO CONVERT

*         SET LAST WORD INDICATOR FOR CMI HARDWARE

          LDC    100000B     END OF REQUEST MARKER FOR UNPACKED CMI
          STIL   T2            OR END-OF-TRANSFER SPEC FOR PACKED
          LDDL   P3          FETCH TEMPORARY FLAG SAVE
          ZJN    RQPB20      JUMP IF NOT LAST ITEM IN PACKED CMI
          LDC    140000B     SET UPPER TWO BITS TO INDICATE LAST ITEM
          STIL   T2          NEXT BYTE
 RQPB20   BSS    0
          AODL   T2
          LDK    0
          STIL   T2          ZERO LOWER BYTE OF LAST WORD INDICATOR
          AODL   T2          SET POINTER TO NEXT USABLE ADDRESS

          RETURN             EXIT
 RQPCSM   SPACE  4,20
** NAME - RQPCSM
*
** PURPOSE - CHECKSUM MAP V REQUEST PACKET
*
** INPUT - T2 CONTAINS THE ADDRESS OF THE UPPER BYTE OF THE CHECKSUM
*
** OUTPUT - THE CHECKSUM WORD IS ADDED TO THE REQUEST PACKET
*
*
          SPACE  2,10
 RQPCSM   SUBR               ENTRY/EXIT

          LDK     TQBE+/RQBP/P.JID
          STDL    T4         ADDRESS OF FIRST WORD TO CHECKSUM
          LDIL    T4
          STIL    T2         INITIALIZE UPPER CHECKSUM BYTE
          AODL    T4
          LDIL    T4
          STML    1,T2       INITIALIZE LOWER CHECKSUM BYTE
          AODL    T4

 RQPC10   BSS     0
          LDML    1,T4
          RAML    1,T2       ADD LOWER BYTE VALUE
          SHN     -16D
          RAIL    T2         INCLUDE ANY CARRY
          ADIL    T4         ADD UPPER BYTE VALUE
          STIL    T2         STORE CHECKSUM UPPER BYTE

          LDK     2          INCREMENT TO NEXT MAP WORD
          RADL    T4
          SBDL    T2         SUBTRACT CHECKSUM WORD POINTER
          NJN     RQPC10     JUMP - MORE TO CHECKSUM

          RETURN             EXIT
 RRP      SPACE  4,20
** NAME - RRP
*
** PURPOSE - READ RESPONSE PACKET.
*
** INPUT - (NONE)
*
** OUTPUT - (A) = 0 - RESPONSE PACKET READ
*               = NONZERO - ERROR IN READING RESPONSE PACKET
*
          SPACE  2,10

 RRPX     BSS    0
 RRP      SUBR               ENTRY/EXIT
          LDK    FCRR        READ RESPONSE PACKET FUNCTION CODE
          RJM    OTF         OUTPUT THE FUNCTION
          NJK    RRPX
          RJM    WHNB        INPUT ONE WORD STATUS - PARITY CHECK
          NJK    RRPX
          LDK    TAPBL*5         PPU WC OF RESPONSE PACKET WORDS
          STDL   T0
          LDK    0
          STML   XERC        RESET TO ZERO
          LDK    TAPB+/MRSBP/P.JID  TBL-ACKNOWLEDGE/RESPONSE PACKET BUFFER
          RJM    INB         ACTIVATE, BLOCK INPUT AND DISCONNECT
          NJK    RRPX
          RJM    WNB         WAIT NOT BUSY STATUS
          NJK    RRPX

          IFEQ   HDW12BC,1   MAP-V CHANNEL INTERFACE IS 12/60 HARDWARE

*         PACK RESPONSE INTO THREE 64 BIT WORDS IN RESPONSE BUFFER
*         AREA.

          LDK    TAPBL       NUMBER OF CM WORDS TO WRITE 12/60 RESPONSE
          STDL   T5
          LDK    TAPB+/MRSBP/P.JID  ACKNOWLEDGE/RESPONSE PACKET BLOCK FWA
          STDL   T4
          RJM    RSZ         REFORMAT SIX ZERO (60) - (12/60 TO 16/64)
          ENDIF

*         CHECKSUM AND ISOLATE RSN.

          LDIL   T4          JID UPPER
          STML   XCSU        INITIALIZE CSUM UPPER ACCUMULATION
          AODL   T4
          LDIL   T4          JID LOWER
          STML   XCSL        INITIALIZE CSUM LOWER ACCUMLATION
          AODL   T4
          LDIL   T4          RSN UPPER BYTE
          STDL   XRQA        RQ RMA UPPER
          AODL   T4
          LDIL   T4          LOWER BYTE
          STDL   XRQA+1      SAVE RQ RMA
          SODL   T4          DECREMENT BY ONE TO SET UP FOR CSUM LOOP
 RRP2     LDML   1,T4
          RAML   XCSL        INCLUDE IN CSUM
          SHN    -16D
          RAML   XCSU        INCLUDE ANY CARRY
          ADIL   T4          INCLUDE UPPER BYTE
          STML   XCSU        CSUM UPPER
          LDK    2
          RADL   T4
          ADK    -TAPB-/MRSBP/P.CKSUM    CSUM ADDRESS
          MJK    RRP2        CONTINUE

*         COMPARE CHECKWORD.

          LDIL   T4          UPPER BYTE
          LMML   XCSU        ACCUMULATED CSUM UPPER
          ZJN    RRP4        NO ERROR
 RRP3     LDK    /RS/K.DATERR  CHECKWORD ERROR
          STML   RESBUF+/RS/P.DATERR  ABNORMAL STATUS FIELD
          RJM    HNG
 RRP3A    UJK    RRPX

 RRP4     LDML   1,T4        LOWER BYTE
          LMML   XCSL
          NJK    RRP3        ERROR

*         READ IN PP-RQ BLOCK BACK IN FROM CM USING RSN.

 RRP5     BSS    0           BYPASS CHECKSUM CHECK RE-ENTRY ******
          RJM    RDVREQ      READ AND VALIDATE UNIT REQUEST.
          ZJN    RRP5B
          LDK    URC.NRQ
          STML   RESBUF+/RS/P.URC
          UJK    RRP3A

 RRP5B    BSS    0

          LDML   REQBUF+/RQ/P.CMDIND
          LPK    /RQ/M.MAPIND
          STDL   MPCMDI
          LDML   REQBUF+/RQ/P.CMDIND
          SHN    8+2
          LPK    /RQ/M.CMDIND
          STDL   XRQI

          LDK    1
          STDL   UQFLG       SET UNIT QUEUE REQUEST FLAG.
          RJM    INTRES      INITIALIZE RESPONSE BUFFER FOR UNIT RESPONSE.

*         READ IN *JID* AND *RSN* OF REQUEST PACKET.
*         COMPARE WITH *JID* AND *RSN* OF RESPONSE PACKET
*         TO VALIDATE *RSN* POINTER.

          LDDL   MPCMDI
          STML   RDSEGA      SET OFFSET IN CASE OF SEGMENTED READ
          SHN    2
          ADK    REQBUF+/RQ/P.CMND  GET ADDR OF FIRST COMMAND
          STDL   CMDADR      SET COMMAND ADDRESS TO COMMAND CONTAINING MAP REQUEST.
          ADK    1
          STDL   CMDADR1
          ADK    -REQBUFE    SUBTRACT REQUEST BUFFER END ADDRESS
          MJN    RRP5C       START OF REQUEST ALREADY IN BUFFER
          RJM    RDSEG       FETCH NEXT REQUEST SEGMENT

 RRP5C    BSS    0
          LDML   REQBUF+/RQ/P.LEN  GET PACKET LENGTH
          SBN    HEADLN      SUBTRACT HEADER LENGTH
          SHN    -3          DIVIDE BY 8 TO GET CM WORDS OF COMMANDS
          SBDL   XRQI        REQUEST INDEX
          STDL   CMDNO       RESTORE NUMBER OF COMMANDS REMAINING
          PJN    RRP6

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          LDK    ERC501      INVALID COMMAND CODE
          RJM    EPC         ERROR PP(NOS/VE) COMMAND SEQUENCE

*         NO RETURN.  RJM RECORDS ADDRESS OF ERROR ROUTINE.

          ELSE
          UJN    0           HANG IF EFLAG5 IS OFF
          ENDIF

 RRP6     LDIL   CMDADR      GET COMMAND AND FLAGS
          SHN    -8          SHIFT OFF FLAGS
          SBN    C.OUTP      OUTPUT 8-BIT PARAMETERS
          ZJN    RRP7        MAP-V PROTOCOL REQUEST 21(16)

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          LDK    ERC501      INVALID COMMAND CODE
          RJM    EPC         ERROR PP(NOS/VE) COMMAND SEQUENCE

*         NO RETURN.  RJM RECORDS ADDRESS OF ERROR ROUTINE.

          ELSE
          UJN    0           HANG IF EFLAG5 IS OFF
          ENDIF

 RRP7     BSS    0

          IFEQ   ILRRP,1                                    ***** ****
          LDIL   CMDADR      GET COMMAND AND FLAGS
          LPK    /CM/K.INDIR MASK OFF INDIRECT BIT
          ZJN    RRP8        JUMP IF THERE IS NOT AN INDIRECT LIST
          RJM    RIL         READ INDIRECT LIST
          LDK    /RQBP/C.JID
          RJM    GIA         GET INDEXED ADDRESS FROM INDIRECT LIST
          UJN    RRP9
          ENDIF                                             * * * ** *

 RRP8     RJM    LF2         SET UP A AND R (LOADF  2,CMDADR)
          ADK    /RQBP/C.JID       INDEX TO FWA OF REQUEST PACKET
 RRP9     CRML   TQBE+/RQBP/P.JID,ONE   READ REQUEST PACKET *JID*/*RSN* FROM CM
*
*         COMPARE JIDS
*
          LDK    /RQBP/B.JID
          STDL   T1
 RRP10    SODL   T1
          MJN    RRP11       COMPARE COMPLETE
          LDML   TQBE+/RQBP/P.JID,T1    REQUEST PACKET
          LMML   TAPB+/MRSBP/P.JID,T1     RESPONSE
          ZJK    RRP10       NO ERROR

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          LDK    ERC501      INVALID COMMAND CODE
          RJM    EPC         ERROR PP(NOS/VE) COMMAND SEQUENCE

*         NO RETURN.  RJM RECORDS ADDRESS OF ERROR ROUTINE.

          ELSE
          UJN    0           HANG IF EFLAG5 IS OFF
          ENDIF


*         MOVE ON TO EXPECTED RESPONSE COMMAND (READ PARAMETER DATA).

 RRP11    BSS    0
          SODL   XRRC        REQUEST (+1) = RESPONSE (-1) COUNTER
          PJN    RRP11A      VALID POSITIVE NUMBER
          LDK    0
          STDL   XRRC        RESET TO ZERO
 RRP11A   LDDL   XRQI        RQ INDEX (CMD)
          STML   RDSEGA      SAVE IN CASE OF SEGMENTED READ
          SHN    2           MULTIPLY BY 4
          ADK    REQBUF+/RQ/P.CMND  GET ADDR OF FIRST COMMAND
          STDL   CMDADR      RESET COMMAND ADDRESS TO NEXT COMMAND
          ADK    1           ADDRESS OF LENGTH FIELD IN COMMAND
          STDL   CMDADR1     SAVE POINTER TO LENGTH FIELD
          ADK    -REQBUFE    SUBTRACT REQUEST BUFFER END ADDRESS
          MJN    RRP11B      END OF CURRENT REQUEST IN BUFFER
          RJM    RDSEG       GO READ END OF CURRENT REQUEST

 RRP11B   BSS    0
          LDK    0
          STML   RESBUF+/RS/P.RC  CLEAR RESPONSE CODE
          LDIL   CMDADR      GET COMMAND AND FLAGS

          SHN    -8D         SHIFT OFF FLAGS
          SBN    C.IND       INPUT 8-BIT DATA/PARAMETERS
          ZJN    RRP12       THIS IS EXPECTED CMD

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          LDK    ERC501      INVALID COMMAND CODE
          RJM    EPC         ERROR PP(NOS/VE) COMMAND SEQUENCE

*         NO RETURN.  RJM RECORDS ADDRESS OF ERROR ROUTINE.

          ELSE
          UJN    0           HANG IF EFLAG5 IS OFF
          ENDIF

*         WRITE RESPONSE TO CENTRAL MEMORY.
 RRP12    BSS    0

          IFEQ   ILRRP,1                                    ***** ****
          LDIL   CMDADR      GET COMMAND AND FLAGS
          LPK    /CM/K.INDIR MASK OFF INDIRECT BIT
          ZJN    RRP13       JUMP IF THERE IS NOT AN INDIRECT LIST
          RJM    RIL         READ INDIRECT LIST
          LDK    TAPB        DATA ADDRESS
          RJM    WDI         WRITE DATA USING INDIRECT LIST
          UJN    RRP14
          ENDIF                                             * * * ** *

 RRP13    LDK    C.MRSBP
          STDL   WC          SET RESPONSE CM WORD COUNT
          RJM    LF2         SET UP A AND R (LOADF  2,CMDADR)

          CWML   TAPB,WC     WRITE RESPONSE

 RRP14    BSS    0
          AODL   XRQI        BUMP INDEX IN CASE OF STACKED REQUESTS
          LDIL   CMDADR      GET COMMAND AND FLAGS
          LPK    /CM/K.CKRSP MASK CHECK RESPONSE PACKET STATUS BIT
          ZJN    RRP15       JUMP IF NO STATUS CHECK REQUESTS

          LDML   TAPB+/MRSBP/P.IST
          LMML   TAPB+/MRSBP/P.IST+1
          ZJN    RRP15       JUMP IF NO ERRORS

 RRP14A   BSS    0
          LDK    1           SET NUMBER OF REMAINING COMMANDS TO 1 TO
          STDL   CMDNO         FORCE BYPASS OF REMAINING COMMANDS
 RRP14X   UJK    DCP         COMPLETE COMMAND PROCESSING

 RRP15    BSS    0
          LDDL   CMDNO       NUMBER OF REMAINING COMMANDS
          SBN    1
          ZJK    RRP24       NO MORE COMMANDS TO PROCESS

*         IF MULTIPLE COMMAND SEQUENCE (STACKED MAP V REQUEST) OR
*            CHANNEL I/O, READ NEXT COMMAND WORD FOR FUNCTION CODE.

          AODL   LAFLG       SET LOOK AHEAD FLAG
          RJM    RQLKA       SEE IF NEXT COMMAND IN BUFFER
          LDML   4,CMDADR    GET COMMAND AND FLAGS
          SHN    -8D
          SBN    C.FUNC      FUNCTION COMMAND CODE
          ZJN    RRP17       0 = CHANNEL I/O SEQUENCE

          SBN    1           CHECK FOR FUNCTION CODE 21
          NJN    RRP16       ERROR - NOT 21 FUNCTION

*         IF FC = 21, THERE MUST BE AT LEAST 2 COMMANDS REMAINING TO
*            BE A VALID SEQUENCE

          LDDL   CMDNO
          SBN    2
          PJN    RRP14X      JUMP TO CONTINUE COMMAND PROCESSING

 RRP16    BSS    0           BAD SEQUENCE OF COMMANDS

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          LDK    ERC501      INVALID COMMAND CODE
          RJM    EPC         ERROR PP(NOS/VE) COMMAND SEQUENCE

*         NO RETURN.  RJM RECORDS ADDRESS OF ERROR ROUTINE.


          ELSE
          UJN    0           HANG IF EFLAG5 IS OFF
          ENDIF


 RRP17    LDML   7,CMDADR    GET HARDWARE FUNCTION CODE
          STML   XFCD        FUNCTION CODE - DATA I/O ON CHANNEL
          LDML   6,CMDADR    GET SOFTWARE FUNCTION TAG(S) (P32 FLAG)
          SHN    0-12D       ISOLATE UPPER HEX DIGIT
          STDL   XSFT        SOFTWARE FUNCTION TAG(S)
          RJM    NEXTCMD     POINT TO NEXT COMMAND
          SODL   CMDNO       DECREMENT NUMBER OF COMMANDS
          ZJK    RRP16       NO MORE TO GO

*         IF CHANNEL I/O, READ NEXT CMD WORD FOR ADDRESS LIST.

          LDML   4,CMDADR    GET COMMAND AND FLAGS
          SHN    -8D
          ADK    -C.WRITE    WRITE BYTE STRING (8-BIT)
          ZJN    RRP19       IS WRITE
          ADK    C.WRITE-C.READ
          ZJN    RRP18       IS READ BYTE STRING (8-BIT)
          UJK    RRP24

 RRP18    LDK    1           READ FLAG
 RRP19    STML   XRDF
          SODL   CMDNO       DECREMENT NUMBER OF COMMANDS
          RJM    NEXTCMD     POINT TO NEXT COMMAND

*         IT IS CHANNEL AND DATA TRANSFER INVOLVED.
*         READ IN THE TABLE OF ADDRESSES.

          LDIL   CMDADR      GET COMMAND AND FLAGS
          LPK    /CM/K.INDIR MASK OFF INDIRECT BIT
          ZJN    RRP22       JUMP IF NOT AN INDIRECT LIST
          RJM    RIL         READ INDIRECT LIST
          LDIL   CMDADR1     GET LENGTH OF INDIRECT LIST
          SHN    -3          CONVERT TO CM WORDS
 RRP23    STDL   T3          INDIRECT LIST LENGTH (LOOP COUNTER)
          RJM    MCL         MAIN-MEMORY CHANNEL LOAD/UNLOAD

 RRP24    LDK    0
          RETURN             EXIT

 RRP22    LDIL   CMDADR1     GET LENGTH
          STDL   BYTCNT      SAVE BYTE COUNT FOR THIS TRANSFER

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          UJN    RRP21       JUMP OVER ERROR REPORTING
          ENDIF

 RRP20    BSS    0

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          LDK    ERC505      INVALID LENGTH IN COMMAND
          RJM    EPC         ERROR PP(NOS/VE) COMMAND SEQUENCE

*         NO RETURN.  RJM RECORDS ADDRESS OF ERROR ROUTINE.

          ENDIF

 RRP21    BSS    0

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5=0
          MJK    RRP20       ERROR IF TRANSFER COUNT IS NEG (TOO BIG)
          ZJK    RRP20       ERROR IF TRANSFER COUNT IS ZERO
          SBDL   MAXIO1      SUBTRACT MAX TRANSFER SIZE + 1
          PJK    RRP20       ERROR IF TRANSFER COUNT IS TOO LARGE
          ENDIF


*         SET APPROPRIATE CELLS TO MAKE IT LOOK LIKE ONE WORD
*         INDIRECT LIST.

          LDDL   BYTCNT
          STML   INDLST+1    MOVE BYTE COUNT
          LDML   2,CMDADR
          STML   INDLST+2    MOVE UPPER ADDRESS
          LDML   3,CMDADR
          STML   INDLST+3    MOVE LOWER ADDRESS
          LDK    1           INDIRECT LIST LENGTH
          UJK    RRP23       CONTINUE

 RSF      SPACE  4,20
** NAME - RSF
*
** PURPOSE - REFORMAT SIX FOUR (64) BIT DATA.
*            ASSUME 64 BIT CM PARAMETER DATA WAS READ INTO PPU MEMORY
*            AS 4-16 BIT BYTES.
*            THIS ROUTINE REFORMATS THIS PARAMETER DATA FOR OUTPUT
*            ON 12-BIT CHANNEL TO MAP-V 60-BIT INTERFACE.
*
** INPUT - (A) = FWA OF 16/64-BIT DATA.
*          (T4) = ADDRESS FOR STORAGE OF 12/60-BIT DATA.
*          (T5) = NUMBER OF 64-BIT CM WORDS TO REFORMAT.
*
** OUTPUT - (T4) = LWA+1-10D OF 12/60 BIT BYTES.
*
          SPACE  2,10
 RSF      SUBR               ENTRY/EXIT

*         (A) = FWA OF 16/64 BIT DATA.

          STML   RSFB
          STML   RSFC        SET FIRST 60-BIT READ ADDRESS
          SBN    2           FORM OFFSET ADDRESS FOR WRITE
          STML   RSFA
          ADK    5+2
          STML   RSFD        SET SECOND 60-BIT READ ADDRESS
          LDML   PPTBL+/PIT/P.CBUFL  PPU COMM. BUFFER LENGTH
          SHN    -4          FORM CM-WORD-CNT/2
          SBDL   T5          TOTAL CM COUNT
          SBN    1           ALLOW FOR EXTRA WORD ON READ BACK
          PJN    RSFE        WILL FIT INTO BUFFER ALLOCATED
          RJM    HNG         HANG IT FOR NOW ***************
 RSFE     LOADF  PPTBL+/PIT/P.CBUF  REFORMAT AND LOAD CM ADDR OF CBUF
          STDL   T1          SAVE STARTING ADDRESS
          CWML   **,T5       WRITE DATA TO CM (2 BYTE NEGATIVE OFFSET)
 RSFA     EQU    *-1         FWA OF 16/64-BIT DATA -2
          ADK    1           ALLOW FOR EASIER INDEXING ON READ
          CWML   **,T5       WRITE DATA TO CM (NORMAL)
 RSFB     EQU    *-1         FWA OF 16/64-BIT DATA
          LDK    0
          STDL   T2          INITIALIZE COUNTER

*         READ BACK ONE WORD AT A TIME FROM ALTERNATE AREAS
*         IN 12/60 BIT FORMAT.

 RSF2     LDDL   T1          RESTORE STARTING ADDRESS
          LMK    400000B     TURN ON R REGISTER
          CRM    **,ONE      ONE WORD 60-BIT READ PART 1 DATA
 RSFC     EQU    *-1         START AT FWA
          ADDL   T5          NEXT GROUP
          CRM    **,ONE      ONE WORD 60-BIT READ PART 2 DATA
 RSFD     EQU    *-1         START AT FWA+5
          LDK    0
          STIL   T4          ZERO 1ST 12 BIT BYTE
          STML   1,T4        ZERO 2ND 12 BIT BYTE
          STML   5,T4        ZERO 5TH 12 BIT BYTE
          STML   6,T4        ZERO 6TH 12 BIT BYTE
          LDML   2,T4
          LPK    377B        ISOLATE 8 BITS
          STML   2,T4
          LDML   7,T4
          LPK    377B        ISOLATE 8 BITS
          STML   7,T4        BYTE 2 PART 2
          AODL   T2          INCREMENT WORD COUNTER
          SBDL   T5          TOTAL WORDS
          PJN    RSF3        DONE
          LDK    10D
          RAML   RSFC        INCREMENT NEXT PPU READ ADDRESS PART 1
          STDL   T4
          LDK    10D
          RAML   RSFD        INCREMENT NEXT PPU READ ADDRESS PART 2
          AODL   T1          INCREMENT STARTING ADDRESS COUNTER
          UJK    RSF2        CONTINUE

 RSF3     RETURN             EXIT
 RSP      SPACE  4,20
** NAME - RSP
*
** PURPOSE - WRITE STATUS BUFFER TO CM RESPONSE BUFFER.
*
** INPUT - CM.PIT, CM.RS, LIM, /PIT/IN, /PIT/OUT, RS+/RS/P.RESPL
*
** OUTPUT - /PIT/IN, RESPONSE BUFFER
*
          SPACE  2,10
 INP      EQU    P4          IN POINTER
 OUTP     EQU    P5          OUT POINTER
          SPACE  2,10
 RSP      SUBR               ENTRY/EXIT

*         MOVE IN STATUS WORDS.

          LDDL   PST         PREVIOUS STATUS WORD 1
          STML   RESBUF+/RS/P.GSP1
          LDDL   PST+1       PREVIOUS STATUS WORD 2
          STML   RESBUF+/RS/P.GSP2
          LDDL   ST          CURRENT STATUS WORD 1
          STML   RESBUF+/RS/P.GSC1
          LDDL   ST+1        CURRENT STATUS WORD 2
          STML   RESBUF+/RS/P.GSC2
          LDK    0           GET TRANSFER COUNT - UPPER BYTE
          STML   RESBUF+/RS/P.XFER+0  SET XFER CNT IN RESPONSE BUFFER
          LDDL   BYTCNT      GET TRANSFER COUNT - LOWER BYTE
          STML   RESBUF+/RS/P.XFER+1  SET XFER CNT IN RESPONSE BUFFER
          LDDL   CMDADR      GET PP ADDRESS OF LAST COMMAND
          ADC    -REQBUF     GET PP WORDS INTO REQUEST
          SHN    1           CM BYTES INTO REQUEST
          ADML   RESBUF+/RS/P.REQ+1  ADD ON HALF 2 OF REQUEST BUFFER RMA
          STML   RESBUF+/RS/P.LASTC+1  RMA HALF 2 OF LAST COMMAND
          SHN    -16         GET CARRY IF ANY
          ADML   RESBUF+/RS/P.REQ  ADD ON HALF 1 OF REQUEST BUFFER RMA
          STML   RESBUF+/RS/P.LASTC  RMA OF HALF 1 OF LAST COMMAND

*         READ IN AND OUT POINTERS OF RESPONSE BUFFER.

 RSP1     LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADK    /PIT/C.OUT  OFFSET OF OUT POINTER
          CRDL   P2          READ OUT POINTER
          SBN    /PIT/C.OUT-/PIT/C.IN  OFFSET OF 'IN' POINTER
          CRDL   P1          READ 'IN' POINTER

*         CHECK IF THERE IS ROOM FOR THE RESPONSE IN THE RESPONSE BUFFER.

          LDDL   INP
          SBDL   OUTP
          MJN    RSP2        IF IN .LT. OUT
          LDDL   LIM         IN .GE. OUT, SET OUT = OUT + LIMIT
          RADL   OUTP
 RSP2     LDML   RESBUF+/RS/P.RESPL  GET RESPONSE LENGTH
          STDL   T1
          SBDL   LIM
          ZJN    RSP3        IF RESPONSE FITS INTO BUFFER
          PJN    *           RESPONSE IS TOO LARGE FOR BUFFER, HANG ***
 RSP3     LDK    0
          STDL   T2          FLAG TO DETERMINE IF 1 OR 2 BLOCK WRITES
          LDDL   INP
          RADL   T1          IN + RESPONSE LENGTH
          SBDL   OUTP        CHECK IF ENOUGH ROOM IN BUFFER FOR RESPONSE
          PJK    RSP1        IN NOT ENOUGH ROOM IN BUFFER, LOOP
          LDDL   T1
          SBDL   LIM
          MJN    RSP4        IF IN + RESPONSE LENGTH .LT. LIMIT
          STDL   T1          IN + RESPONSE LENGTH - LIMIT = NEW 'IN' PTR
          AODL   T2          2 BLOCK WRITES REQUIRED

*         WRITE RESPONSE TO CM.

 RSP4     BSS    0
          LDDL   INP
          SHN    -3
          STDL   T3          'IN' POINTER IN WORDS
          LDML   RESBUF+/RS/P.RESPL  CONVERT RESPONSE LENGTH TO WORDS
          SHN    -3
          STDL   T4          RESPONSE LENGTH IN WORDS
          STDL   T5
          LDDL   T2
          ZJN    RSP5        IF ONLY 1 BLOCK WRITE REQUIRED
          LDDL   LIM         FIRST BLOCK WRITE = (LIMIT - IN) WORDS
          SBDL   INP
          SHN    -3
          STDL   T4          NUMBER OF WORDS TO TRANSFER ON 1ST BLOCK
          SHN    2           CONVERT TO NUMBER OF PP WORDS
          ADK    RESBUF
          STML   RSPA        RESPONSE ADDRESS FOR 2ND BLOCK WRITE
 RSP5     LOADC  CM.RS       LOAD CM ADDRESS OF RESPONSE BUFFER
          STDL   T6          SAVE CM ADDRESS
          ADDL   T3          ADD 'IN' OFFSET
          CWML   RESBUF,T4   WRITE RESPONSE TO CM
          LDDL   T5          RESPONSE LENGTH
          SBDL   T4
          ZJN    RSP6        IF ONLY 1 BLOCK WRITE REQUIRED
          STDL   T5          RESPONSE LENGTH - (LIMIT - IN)
          LDDL   T6          LOAD ADDRESS OF RESPONSE BUFFER
          LMK    400000B
          CWML   **,T5       WRITE 2ND PART OF RESPONSE TO CM
                             (BEGINNING OF RESPONSE BUFFER)
 RSPA     EQU    *-1

 RSP6     LDDL   T1          NEW IN POINTER
          STML   INPNT

*         SET UP INTERRUPT PROCESSOR INSTRUCTION IF INTERRUPT IS
*         SELECTED.

          LDML   RESBUF+/RS/P.INT  CHECK IF INTERRUPT WAS SELECTED
          LPK    /RS/K.INT
          NJN    RSP7        IF INTERRUPT SELECTED
          LDC    2400B       PSN INSTRUCTION
          UJN    RSP8

 RSP7     LDML   RESBUF+/RS/P.PORT  PROCESSOR PORT NUMBER TO INTERRUPT
          SHN    -16+/RS/L.PORT+/RS/N.PORT
          LPK    /RS/M.PORT
          ADC    102600B     INPN INSTRUCTION
 RSP8     STML   UIPA
          RJM    UIP         UPDATE IN POINTER
          RETURN             EXIT
 RSZ      SPACE  4,20
** NAME - RSZ
*
** PURPOSE - REFORMAT SIX ZERO (60) BIT DATA.
*            ASSUME 60 BIT DATA WAS READ INTO PPU MEMORY
*            AS 5-12 BIT BYTES FROM 12 BIT CHANNEL INTERFACE.
*            THIS ROUTINE REFORMATS THIS DATA FOR WRITING INTO
*            CENTRAL MEMORY AS 64 BIT DATA.
*
** INPUT - (A) = FWA OF 12/60-BIT DATA.
*          (T4) = ADDRESS FOR STORAGE OF 16/64-BIT DATA.
*          (T5) = NUMBER OF 60-BIT CM WORDS TO REFORMAT.
*
** OUTPUT - (T5) = NUMBER OF 64-BIT CM WORDS.
*
          SPACE  2,10
 RSZ      SUBR               ENTRY/EXIT

*         (A) = FWA OF 12/60 BIT DATA.

          STML   RSZA
          LDML   PPTBL+/PIT/P.CBUFL  PPU COMM. BUFFER LENGTH
          SHN    -3          FORM CM-WORD-CNT
          SBDL   T5          TOTAL CM COUNT
          PJN    RSZC        WILL FIT INTO BUFFER ALLOCATED
          RJM    HNG         HANG IT FOR NOW ***************
 RSZC     LOADF  PPTBL+/PIT/P.CBUF  REFORMAT AND LOAD CM ADDR OF CBUF
          CWM    **,T5       WRITE DATA TO CM
 RSZA     EQU    *-1         FWA OF 12/60-BIT DATA
          STDL   T1          SAVE ENDING ADDRESS

*         SET UP TO DO A SERIES OF REVERSE READS FROM CM.

          LDDL   T5          60-BIT CM WORD COUNT
          SHN    1           FORM NUMBER OF 16-BIT BYTES OF DATA
          ADDL   T4          FORM LWA+1 FOR PACKED DATA IN PP
          SBN    4           DECREMENT BY FOUR FOR *CRML* INSTRUCTION
          STML   RSZB        SET CM READ ADDRESS
 RSZ1     SODL   T1          FORM NEXT CM LWA
          LMK    400000B     TURN ON R REGISTER
          CRML   **,ONE
 RSZB     EQU    *-1
          LCN    2
          RAML   RSZB        DECREMENT ADDRESS BY 2
          SBDL   T4
          PJN    RSZ1        MORE TO GO

*         READ FINAL CM BLOCK (IE FIRST CM WORD) AND MOVE TWO BYTES
*         TO BUFFER.

          SODL   T1          FORM NEXT CM LWA
          LMK    400000B     TURN ON R REGISTER
          CRML   HCS,ONE     HIGH CORE SCRATCH
          LDML   HCS+2       FIRST 16-BIT BYTE
          STIL   T4          MOVE TO FIRST LOCATION
          LDML   HCS+3       NEXT 16-BIT BYTE
          STML   1,T4
          LDDL   T5          60-BIT CM WORD COUNT
          SHN    -1          DIVIDE BY 2
          NJN    RSZ2
          LDK    1           DO NOT ALLOW COUNT TO GO TO ZERO
 RSZ2     STDL   T5          NUMBER OF 64-BIT WORDS
          RETURN             EXIT
 SAU      SPACE  4,20
** NAME - SAU
*
** PURPOSE - SCAN ACTIVE UNIT(S).
*            TO SCAN ALL ACTIVE UNITS LOOKING FOR UNIT READY CHANGES.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 SAU      SUBR               ENTRY/EXIT
          LDDL   SCNFLG      GET SCAN FLAG
          ZJN    SAU1        IF SCAN FLAG NOT SET, RETURN
          LDDL   XRRC        REQUEST (+1) = RESPONSE (-1) COUNTER
          ZJN    SAU1        NO OUTSTANDING RESPONSES
          RJM    CRB         CLEAR RESPONSE BUFFER (NOS/VE)
          LDK    URC.RN
          RJM    SURESP      SETUP RESPONSE BUFFER FOR UNSOLICITED RESPONSE
          RJM    I2S         INPUT TWO WORD STATUS
          NJN    SAU2
          LDDL   ST+1        STATUS WORD 2
          LPK    /MPSSTS/K.RESA
          ZJN    SAU1        NO RESPONSE PACKETS (ANY ID) AVAILABLE
          RJM    RNR         READ NEXT-AVAILABLE RESPONSE PACKET
          NJN    SAU2
          UJK    DCP         DO COMMMAND-COMPLETE PROCESSING
 SAU2     RJM    RSP         SEND RESPONSE TO CPU
 SAU1     RETURN             EXIT
 SDP      SPACE  4,20
** NAME - SDP
*
** PURPOSE - SET-UP DATA-TRANSFER PARAMETERS.
*
** INPUT - (NONE)
*
** OUTPUT - (A) = DATA FWA.
*           (T0) = PP CHANNEL WORD COUNT.
*           (F16BIO) = 1 = 16 BIT I/O.  0 = 12 BIT I/O.
*
          SPACE  2,10
 SDP      SUBR               ENTRY/EXIT
          LDDL   XPWB        SIZE OF TRANSFER
          STDL   T0
          LDDL   XSFT        SOFTWARE FUNCTION TAG(S)
          LPN    1
          STDL   F16BIO      STORE AS FLAG FOR 16 OR 12 BIT MEMORY I/O
          ZJN    SDP4        12 BIT MEMORY I/O

          LDDL   T0
          LMK    BFDP16      FULL BUFFER OF 16 BIT WORDS
          ZJN    SDP2        IS FULL BLOCK
          LDDL   T0
          SHN    1           MAKE CM BYTES
          STDL   BYTCNT      SET UP FOR *CBC*
          RJM    CBC         CONVERT BYTE COUNT TO 12-BIT CHANNEL WORDS
          LDDL   IOCNT
          UJN    SDP3
 SDP2     LDK    BFDP16*4/3
 SDP3     STDL   T0
 SDP4     LDK    BFDZ        ADDRESS OF DATA IN PP
          RETURN             EXIT
 SLB      SPACE  4,20
** NAME - SLB
*
** PURPOSE - SET LOCKWORD BIT.
*
** INPUT - A AND R POINT TO CM CELL TO BE LOCKED
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 SLB      SUBR               ENTRY/EXIT

*         SET LOCK BIT.

          LDIL   T4          TABLE ADDRESS
          STDL   CMADR
          LDML   1,T4
          STDL   CMADR+1
          LDML   2,T4
          STDL   CMADR+2
          LDC    100000B     SET UNIT LOCK BIT
          STDL   T1
          LDK    0
          STDL   T2
          STDL   T3
          STDL   T4
          LOADR  CMADR       UNIT/PP INTERFACE TABLE ADDRESS
          ADDL   T5          ADD LOCKWORD OFFSET, SAVE CM ADDRESS
          STDL   T6          SAVE CM ADDRESS
          RDSL   T1          SET LOCK BIT IN UNIT LOCKWORD

*         CHECK IF LOCK WAS OBTAINED.

          LDDL   T1
          ADDL   T2
          ADDL   T3
          ADDL   T4
          ZJN    SLB2        LOCK OK TO SET

*         LOCK COULD NOT BE SET, EXIT A .NE. 0.

 SLB1     RETURN             EXIT

*         SET PP NUMBER IN LOCKWORD.

 SLB2     LDDL   PPNO
          STDL   T4
          LDDL   T6          CM ADDRESS OF UNIT LOCK.
          LMK    400000B
          RDSL   T1          SET PP NUMBER IN LOCKWORD

*         CHECK IF LOCK WAS CORRECT BEFORE LAST RDSL OPERATION.

          LDDL   T1
          ADC    -100000B
          NJK    SLB4
          LDDL   T2
          ADDL   T3
          ADDL   T4
          ZJK    SLB1        IF NO ERROR, EXIT

 SLB3     RJM    HNG         ERROR IN LOCKWORD

*         CHECK FOR LOCKWORD = FFFF FFFF XXXX XXXX(16).

 SLB4     LDDL   T1
          ADC    -177777B
          NJN    SLB3
          LDDL   T2
          ADC    -177777B
          NJK    SLB3
          LDK    0
          STDL   T1
          STDL   T2
          STDL   T3
          UJK    SLB2


 SQL      SPACE  4,20
** NAME - SQL
*
** PURPOSE - SET QUEUE LOCK IN THE UNIT INTERFACE TABLE.
*
** INPUT - (NONE)
*
** OUTPUT - A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                   .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  2,10
 SQL      SUBR               ENTRY/EXIT
          LDK    1
          STDL   UQLOCK      SET UNIT QUEUE LOCKED FLAG
          LDK    CM.UIT      UNIT INTERFACE TABLE ADDRESS
          STDL   T4
          LDK    /UIT/C.QLOCK  OFFSET OF QUEUE LOCKWORD
          STDL   T5
          RJM    SLB         SET LOCKWORD BIT
          ZJN    SQL1        RETURN IF LOCK WAS SUCCESSFULLY SET
          LDK    0
          STDL   UQLOCK      CLEAR LOCK FLAG IF UNIT QUEUE NOT LOCKED
          LDK    1           SET NO LOCK INDICATOR
 SQL1     RETURN             EXIT
 SUL      SPACE  4,20
** NAME - SUL
*
** PURPOSE - SET UNIT LOCK IN THE UNIT INTERFACE TABLE.
*
** INPUT - (NONE)
*
** EXIT - A REGISTER = 0, IF LOCK WAS SUCCESSFULLY SET.
*                    .NE. 0, IF LOCK COULD NOT BE SET.
          SPACE  2,10
 SUL      SUBR               ENTRY/EXIT
          LDK    1
          STDL   ULOCK       SET UNIT LOCKED FLAG
          LDK    CM.UIT      UNIT INTERFACE TABLE ADDRESS
          STDL   T4
          LDK    /UIT/C.ULOCK  OFFSET OF UNIT LOCKWORD
          STDL   T5          SET LOCKWORD
          RJM    SLB         SET LOCKWORD BIT
          ZJN    SUL1        EXIT IF LOCK WAS SET
          LDK    0
          STDL   ULOCK       CLEAR LOCK FLAG IF UNIT NOT LOCKED
          LDK    1           SET NO LOCK INDICATOR
 SUL1     RETURN             EXIT
 SUR      SPACE  4,20
** NAME - SUR
*
** PURPOSE - SET UP RESPONSE BUFFER.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 SUR      SUBR               ENTRY/EXIT
          LDML   REQBUF+/RQ/P.LU
          STML   RESBUF+/RS/P.LU  PUT LOGICAL UNIT IN RESPONSE BUFFER
          LDML   REQBUF+/RQ/P.RECOV
          STML   RESBUF+/RS/P.RECOV  RECOVERY, INTERRUPT, PORT,PRIORITY
          LDML   REQBUF+/RQ/P.LONGB
          STML   RESBUF+/RS/P.LONGB  PUT ALERT MASK IN RESPONSE BUFFER
          LDML   REQBUF+/RQ/P.NEXT
          STML   RESBUF+/RS/P.REQ  REQUEST RMA HALF 1 TO RESPONSE BUFFER
          LDML   REQBUF+/RQ/P.NEXT+1                                           Q
          STML   RESBUF+/RS/P.REQ+1  REQUEST RMA HALF 2 TO RESPONSE
          LDML   REQBUF+/RQ/P.NEXTPV
          STML   RESBUF+/RS/P.PVA  REQUEST PVA PART 1 TO RESPONSE BUFFER
          LDML   REQBUF+/RQ/P.NEXTPV+1
          STML   RESBUF+/RS/P.PVA+1  REQUEST PVA PART 2 TO RESPONSE BUFFER
          LDML   REQBUF+/RQ/P.NEXTPV+2
          STML   RESBUF+/RS/P.PVA+2  REQUEST PVA PART 3 TO RESPONSE
          RETURN             EXIT
 SURESP   SPACE  4,20
** NAME - SURESP
*
** PURPOSE - SET UNSOLICITED RESPONSE BUFFER VALUES.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 SURESP   SUBR
          STML   RESBUF+/RS/P.URC   STORE UNSOLICITED RESPONSE CODE
          LDK    LENRS2
          STML   RESBUF+/RS/P.RESPL SET RESPONSE LENGTH.
          LDK    R.UNS
          STML   RESBUF+/RS/P.RC    SET RESPONSE CODE TO UNSOLICITED
          LDML   UNITD+/UD/P.LU,UDPNT
          STML   RESBUF+/RS/P.LU    STORE LOGICAL UNIT NUMBER
          RETURN
          SPACE  2,15
*         JUMP TABLE FOR PP COMMANDS (INDEXED BY COMMAND CODE).

 TPCJ     CON    PC0         ACKNOWLEDGE
          CON    PC1         STOP UNIT
          CON    DCM..       PC2 - INVALID PP COMMAND
          CON    PC3         SELECT CONTROLLER
          CON    PC4         IDLE
          CON    PC5         RESUME
          CON    DCM..       EXECUTE OVERLAY (NO VE CAPABILITY)
          CON    PC7         START READY SCAN
          CON    PC8         STOP READY SCAN
          CON    DCM..       SELECT PP MEMORY ADDRESS
          CON    DCM..       COPY PP MEMORY (NOT IMPLEMENTED)
          CON    DCM..       PCB - INVALID PP COMMAND
          CON    DCM..       PCC - INVALID PP COMMAND
          CON    DCM..       PCD - INVALID PP COMMAND
          CON    DCM..       PCE - INVALID PP COMMAND
          CON    DCM..       PCF - INVALID PP COMMAND
          CON    PC10        ENABLE UNIT
          CON    PC11        DISABLE UNIT
          CON    PC12        POWER ON CONTROLLER
          CON    PC13        POWER OFF CONTROLLER
          CON    PC14        POWER ON UNIT
          CON    PC15        POWER OFF UNIT
          CON    PC16        MASTER-CLEAR CHANNEL
          CON    PC17        MASTER-CLEAR CONTROLLER
          CON    PC18        PC18 - INVALID PP COMMAND
          CON    PC19        PC19 - INVALID PP COMMAND
          CON    PC1A        PC1A - INVALID PP COMMAND
          CON    PC1B        PC1B - INVALID PP COMMAND
          CON    PC1C        PC1C - INVALID PP COMMAND
          CON    PC1D        PC1D - INVALID PP COMMAND
          CON    PC1E        PC1E - INVALID PP COMMAND
          CON    PC1F        PC1F - INVALID PP COMMAND
          CON    PC20        EXECUTE SUB-SYSTEM DIAGNOSTIC
          CON    PC21        EXECUTE CONTROLLER DIAGNOSTIC
          CON    PC22        EXECUTE UNIT DIAGNOSTIC
          SPACE  2,30
*         JUMP TABLE FOR UNIT COMMANDS (SEARCHED BY COMMAND CODE).
*         MOST FREQUENTLY USED COMMANDS ARE PUT AT BOTTOM OF TABLE.

 TUCJ     BSS    0
          CON    C.OUTD      23(16) - OUTPUT 8-BIT DATA
          CON    UC23

          CON    C.STATUS    60(16) - READ STATUS
          CON    UC60        STATUS MAPV

          CON    C.FUNC      20(16) - PHYSICAL COMMAND FUNCTION
          CON    UC20        DO FUNCTION

          CON    C.IND       25(16) - INPUT 8-BIT DATA/PARAMETERS
          CON    UC25        PROCESS JID RESPONSE

          CON    C.OUTP      21(16) - OUTPUT 8-BIT PARAMETERS
          CON    UC21        MAP-V PROTOCOL REQUEST
 TUCJL    EQU    *-TUCJ      LENGTH OF TABLE
          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          SPACE  4,10
*         VALID FUNCTION CODES FOR CONTROL OF THE MAP HARDWARE.

 TUC20F   BSS    0           TABLE UNIT COMMAND 20 FUNCTIONS
          CON    FCMC        MASTER CLEAR INTERFACE
          CON    FCWF        WRITE FLAG (FOLLOWED BY OUTPUT OF TWO
                                         60 BIT CONTROL WORDS)
          CON    FCWR        WRITE REQUEST (FOLLOWED BY OUTPUT OF
                                            REQUEST PACKET)
          CON    FCBW        BLOCK WRITE (FOLLOWED BY OUTPUT OF DATA)
          CON    FCRR        READ RESPONSE (FOLLOWED BY INPUT OF
                                            RESPONSE PACKET)
          CON    FCBR        BLOCK READ (FOLLOWED BY INPUT OF DATA)
          CON    FCHS1       READ HARDWARE STATUS WORD ONE
          CON    FCHS2       READ HARDWARE STATUS WORDS ONE AND TWO

*         SPECIAL HARDWARE FUNCTION CODES.

          CON    FCCS        CLEAR SEQUENCER
          CON    FCMD        MAIN-MEMORY DUMP (SET ADDRESS AND LENGTH)
          CON    FCML        MAIN-MEMORY LOAD (SET ADDRESS AND LENGTH)
          CON    FCPD        PUBLIC-MEMORY DUMP (SET ADDRESS AND LENGTH)
          CON    FCPL        PUBLIC-MEMORY LOAD (SET ADDRESS AND LENGTH)

*         DIAGNOSTIC FUNCTIONS.

          CON    FCT04       TEST XMIT/REC AND CABLE WITH
                               SIMPLE PATTERNS
*         FC     03X5B       TEST IOP NUMERICAL CONVERSION
                               UNIT DATA PATHS
          CON    FCT05       TEST C-170 60 BIT SINGLE PRECISION
                               FLOATING POINT FORMAT
          CON    FCT15       TEST C-170 60 BIT FIXED POINT FORMAT
          CON    FCT25       TEST C-170 30-BIT FLOATING POINT FORMAT
                               (MAP III EXTERNAL FORMAT)
          CON    FCT35       TEST RIGHTMOST 32-BIT OF C-170 60-BIT
                               WORD FORMAT
          CON    FCT06       TEST IOP COMMON LOGIC
 TUC20FL  EQU    *-TUC20F    LENGTH OF TABLE
          ENDIF
 UC20     SPACE  4,20
** NAME - UC20
*
** PURPOSE - UNIT COMMAND 20(16) - MAP-V FUNCTION.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 UC20     LDML   3,CMDADR    GET HARDWARE FUNCTION TO BE ISSUED
          STDL   FCNRCD      SAVE FUNCTION REQUEST CODE
          LPK    0700B
          LMK    0300B
          NJN    UC204       NOT MAP-V DIAGNOSTIC FUNCTION

          LDK    1
          STDL   DIAFND      SET DIAGNOSTIC FUNCTION WITH ASSOCIATED DATA FLAG
          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          LDDL   CMDNO       NUMBER OF COMMANDS
          SBN    3
          PJN    UC202       AT LEAST 2 COMMANDS AFTER 03XX FUNC.
          ENDIF

 UC201    BSS    0

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          LDK    ERC50A      LOAD INDEX FOR INVALID SEQ. OF COMMANDS
          RJM    EPC         ERROR PP(NOS/VE) COMMAND SEQUENCE

*         NO RETURN.  RJM RECORDS ADDRESS OF ERROR ROUTINE.

          ENDIF

 UC208    UJK    DER
 UC202    LDML   4,CMDADR    NEXT COMMAND
          SHN    -8D         REMOVE FLAGS
          SBN    C.OUTD      23(16) - OUTPUT 8-BIT DATA
          ZJN    UC203       VALID IF FOLLOWED BY READ

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          SBN    C.STATUS-C.OUTD  60(16) - READ STATUS
          NJK    UC201       NOT VALID
          ENDIF

          LDK    77B
          STDL   DIAFLG      SET DIAGNOSTIC FLAG TO INDICATE DELAY
          STDL   DIAFND      SET DIAGNOSTIC FUNCTION WITH ASSOCIATED DATA FLAG
          UJN    UC204       CONTINUE
 UC203    BSS    0

          IFNE   EFLAG5,0    TURN OFF COMMAND VALIDATION IF EFLAG5 = 0
          LDML   8,CMDADR    3RD COMMAND
          SHN    -8D
          SBN    C.IND       25(16) - INPUT 8-BIT DATA
          NJK    UC201       INVALID SEQUENCE
          ENDIF

          AODL   DIAFLG      SET DIAGNOSTIC FLAG
 UC204    LDDL   FCNRCD      FUNCTION REQUEST CODE
          RJM    OTF         DO THE FUNCTION
          NJK    UC208
          LDDL   DIAFLG
          ZJN    UC200       IF DIAGNOSTIC SEQUENCE NOT IN PROGRESS.
          LDDL   DIAFND
          NJN    UC209       IF DIAGNOSTIC SEQUENCE WITH ASSOCIATED DATA.

 UC200    RJM    WHNB        WAIT FOR HARDWARE NOT BUSY
          NJK    UC208
          RJM    ESO         CHECK ERROR BITS IN STATUS WORD 1.
          ZJN    UC209       IF NO ERROR BITS SET.
          RJM    EMAP
          UJK    UC208

 UC209    LDDL   DIAFLG
          LMK    77B         DELAY INDICATOR
          ZJN    UC206       DELAY
 UC205    UJK    DCP         DO COMMMAND-COMPLETE PROCESSING
*
*         PUT IN DELAY OF APPROXIMATELY 10 SECONDS.
*
 UC206    SODL   DIAFLG      TURN OFF DELAY REQUEST
          LDK    10
          RJM    PAUSS        WAIT FOR 10 SECONDS.
          UJK    UC205       EXIT

 UC21     SPACE  4,20
** NAME - UC21
*
** PURPOSE - UNIT COMMAND 21(16) - MAP-V PROTOCOL.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 UC21     LDDL   FCNRCD      FUNCTION FLAG (NOS/VE CPU TO PP FUNCTION)
          NJN    UC213       FUNCTION SEQUENCE IN PROGRESS

*         OUTPUT REQUEST PACKET.

          RJM    RQP         REQUEST PACKET PROCESSING
 UC211    UJK    DCP4        RETURN TO MAIN LOOP VIA RETURN FROM DCM

*         FUNCTION SEQUENCE IN PROGRESS.
*         WRITE FLAG SEQUENCE IS EXPECTED AS NEXT OPERATION.

 UC213    ADK    -FCWF       FUNCTION CODE - WRITE FLAG
          ZJN    UC214       ACCEPTABLE SEQUENCE
          LDK    ERC50A      LOAD INDEX FOR INVALID SEQ. OF COMMANDS
          RJM    EPC         ERROR PP(NOS/VE) COMMAND SEQUENCE

*         NO RETURN.  RJM RECORDS ADDRESS OF ERROR ROUTINE.


 UC214    LDK    0
          STDL   FCNRCD      CLEAR FUNCTION FLAG
          RJM    LF2         SET UP A AND R (LOADF  2,CMDADR)
          CRML   XCWB,ONE    READ INTO COMMAND WORD BUFFER

          IFEQ   HDW12BC,1   MAP-V CHANNEL INTERFACE IS 12/60 HARDWARE

*         CONVERT 16/64 TO 12/60.

          LDK    1           NUMBER OF 64-BIT CM WORDS
          STDL   T5
          LDK    XCWB        FWA OF 16/64-BIT DATA
          STDL   T4          SET STORAGE ADDRESS OF 12/60-BIT DATA
          RJM    RSF         REFORMAT SIX FOUR (64) - (16/64 TO 12/60)
          LDK    2*5
          ELSE
          LDK    4           PPU WORD COUNT
          ENDIF

          STDL   T0          SET WORD COUNT
          LDK    XCWB        CONTROL WORD BLOCK FWA
          RJM    OTB         OUTPUT THE BUFFER
          ZJN    UC215
 UC216    UJK    DER
 UC215    UJK    DCP         DO COMPLETE-COMMMAND PROCESSING
 UC23     SPACE  4,20
** NAME - UC23
*
** PURPOSE - UNIT COMMAND 23(16) - MAP-V OUTPUT 8-BIT DATA.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 UC23     LDDL   FCNRCD      FUNCTION FLAG (NOS/VE CPU TO PP FUNCTION)
          NJN    UC232       FUNCTION SEQUENCE IN PROGRESS
 UC231    LDK    ERC50A      LOAD INDEX FOR INVALID SEQ. OF COMMANDS
          RJM    EPC         ERROR PP(NOS/VE) COMMAND SEQUENCE

*         NO RETURN.  RJM RECORDS ADDRESS OF ERROR ROUTINE.


 UC232    LDDL   DIAFLG      DIAGNOSTIC FLAG
          ZJK    UC231       NO DIAGNOSTIC SEQUENCE FLAG
          RJM    LF2         SET UP A AND R (LOADF  2,CMDADR)

          IFEQ   HDW12BC,1   MAP-V CHANNEL INTERFACE IS 12/60 HARDWARE
          CRM    IOBUF,ONE   ONE WORD 60-BIT READ
          LDK    5
          ELSE
          CRML   IOBUF,ONE   ONE 64 BIT READ
          LDK    4           PPU WORD COUNT
          ENDIF

          STDL   T0          SET WORD COUNT
          LDK    IOBUF       DATA FWA
          RJM    OTB         OUTPUT THE BUFFER
          NJK    UC216
 UC233    UJK    UC215       DO COMPLETE-COMMMAND PROCESSING
 UC25     SPACE  4,20
** NAME - UC25
*
** PURPOSE - UNIT COMMAND 25(16) - MAP-V INPUT 8-BIT DATA/PARAMETERS.
**                                 PROCESS JID RESPONSE.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 UC25     LDDL   DIAFLG      DIAGNOSTIC FLAG
          ZJK    DCP4        RETURN TO MAIN LOOP VIA RETURN FROM DCM

*         DIAGNOSTIC FLAG SET. CLEAR FLAGS AND DO ONE WORD READ.

 UC251    LDK    0
          STDL   FCNRCD      CLEAR FUNCTION FLAG
          STDL   DIAFLG      CLEAR DIAGNOSTIC FLAG

          IFEQ   HDW12BC,1   MAP-V CHANNEL INTERFACE IS 12/60 HARDWARE
          LDK    5
          ELSE
          LDK    4           PPU WORD COUNT
          ENDIF

          STDL   T0          SET WORD COUNT

*         READ THE DATA BACK IN.

          LDK    IOBUF+5     DATA FWA
          RJM    INB         INPUT THE BUFFER
          RJM    LF2         SET UP A AND R (LOADF  2,CMDADR)

          IFEQ   HDW12BC,1   MAP-V CHANNEL INTERFACE IS 12/60 HARDWARE
          CWM    IOBUF+5,ONE ONE WORD 60-BIT WRITE
          ELSE
          CWML   IOBUF+5,ONE ONE WORD 64-BIT WRITE
          ENDIF

 UC2510   UJK    UC233       DO COMPLETE-COMMMAND PROCESSING
 UC60     SPACE  4,20
** NAME - UC60
*
** PURPOSE - UNIT COMMAND 60(16) - MAP-V STATUS REQUEST.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 UC60     BSS    0
          RJM    I2S         INPUT TWO WORD STATUS
          NJK    DER
          RJM    LF2         SET UP A AND R (LOADF  2,CMDADR)
          CWDL   PST         WRITE PREVIOUS STATUS AND CURRENT STATUS
          UJK    UC2510      DO COMPLETE-COMMMAND PROCESSING
 UIP      SPACE  4,20
** NAME - UIP
*
** PURPOSE - UPDATE 'IN' POINTER IN THE CM RESPONSE BUFFER.
*
** INPUT - INPNT = NEW 'IN' POINTER.
*
** OUTPUT - (NONE)
*
          SPACE  2,10

 CM.INT   BSSZ   3           REFORMATED CM ADDRESS OF INTERRUPT WORD.

 UIP      SUBR               ENTRY/EXIT
          LDK    0
          STDL   P1
          STDL   P2
          STDL   P3
          LDML   INPNT       NEW 'IN' POINTER
          STDL   P4
          LOADC  CM.PIT      LOAD ADDRESS OF PP INTERFACE TABLE
          ADK    /PIT/C.IN   OFFSET OF 'IN' POINTER
          CWDL   P1          WRITE NEW 'IN' POINTER TO CM
*
*         SET INTERRUPT WORD IN CM.
*
          LOADC  CM.INT      CM ADDRESS OF INTERRUPT WORD.
          CWDL   PPNO-3      SET LAST BYTE NON-ZERO.

*         INTERRUPT PROCESSOR.  RSP ROUTINE SETS UP THIS INSTRUCTION.

 UIPA     INPN   1           INTERRUPT OR PSN
          RETURN             EXIT
 URQ      SPACE  4,20
** NAME - URQ
*
** PURPOSE - TO DETERMINE IF THERE ANY REQUESTS ON THE UNIT QUEUES.
*
** INPUT - (NONE)
*
** OUTPUT - A = 0 IF THERE ARE NO UNIT REQUESTS.
*           A .NE. 0 IF THERE IS A UNIT REQUEST TO PROCESS.
*
          SPACE  2,10
 URQ6     LDK    0           SET NO FIND FLAG.

 URQ      SUBR               ENTRY/EXIT
          LDML   PPTBL+/PIT/P.UNITC  GET NUMBER OF UNITS
          STDL   P1          SAVE FOR LOOP CONTROL
 URQ1     SODL   P1          DECREMENT LOOP CONTROL COUNTER
          MJK    URQ6        EXIT IF ALL UNITS CHECKED AND NO FINDS
          AODL   UNITP       INCREMENT UNIT POINTER
          SBML   PPTBL+/PIT/P.UNITC  SUBTRACT MAX UNIT NUMBER
          MJN    URQ2        SKIP IF NO WRAP AROUND
          LDK    0           RESET POINTER TO START OF UNIT LIST
          STDL   UNITP
 URQ2     LDDL   UNITP       GET UNIT POINTER
          SHN    3           MULT BY 8 SINCE UNIT DESCRIPTOR 8 PP WORDS LONG
          STDL   UDPNT       SAVE POINTER INTO UNIT DESCRIPTOR
          LDML   UNITD+/UD/P.UQT,UDPNT  GET RMA UPPER HALF
          ADML   UNITD+/UD/P.UQT+1,UDPNT  ADD RMA LOWER HALF
          ZJK    URQ1        IF DUMMY ENTRY, LOOP TO NEXT ENTRY
          LOADF  UNITD+/UD/P.UQT,UDPNT  REFORMAT AND LOAD CM ADDRESS OF UIT
          STDL   CM.UIT+2    SAVE CM ADDRESS OF UIT
          SRD    CM.UIT

          IFNE   EFLAG2,0    TURN OFF PP INT TBL VERIFY CODE IF EFLAG2=0
          LDML   UNITD+/UD/P.UQT+1
          LPN    7           MASK OFF LOWER BITS
          NJK    VPI9        ERROR IF ADDR OF UIT NOT WORD BOUNDARY
          ENDIF

          LDK    C.UIT       GET LENGTH OF UIT
          STDL   T6          SAVE LENGTH FOR CM READ
          RJM    LFU         SET A AND R TO ADDR OF UIT
          CRML   UITBUF,T6   READ IN UNIT INTERFACE TABLE
          LDML   UITBUF+/UIT/P.DSABLE  GET UNIT STATUS
          LPK    DISABLE     IF UNIT DISABLED
          IFNE   EFLAG3,0    TURN OFF UIT VERIFICATION IF EFLAG3=0
          NJK    URQ8        TRY THE NEXT UNIT
          ELSE
          NJN    URQ8        TRY THE NEXT UNIT
          ENDIF
          LDML   UITBUF+/UIT/P.NEXT  HALF 1 OF RMA FOR REQUEST
          ADML   UITBUF+/UIT/P.NEXT+1  IF RMA=0 NO REQUEST QUEUED
          IFNE   EFLAG3,0    TURN OFF UIT VERIFICATION IF EFLAG3=0
          ZJK    URQ8        TRY THE NEXT UNIT
          ELSE
          ZJN    URQ8        RELOOP IF NO REQUEST QUEUED
          ENDIF
          RJM    SUL         LOCK UNIT TABLE
          IFNE   EFLAG3,0    TURN OFF UIT VERIFICATION IF EFLAG3=0
          NJK    URQ8        TRY THE NEXT UNIT
          ELSE
          NJN    URQ8        GO TO NEXT UNIT IF THIS ONE IS LOCKED
          ENDIF
          RJM    SQL         SET QUEUE LOCK
          IFNE   EFLAG3,0    TURN OFF UIT VERIFICATION IF EFLAG3=0
          NJK    URQ5        TRY THE NEXT UNIT
          ELSE
          NJN    URQ5        GO TO NEXT UNIT IF THIS ONE LOCKED
          ENDIF
          LDK    C.UIT       GET LENGTH OF UIT
          STDL   T6          SAVE LENGTH FOR CM READ
          RJM    LFU         SET A AND R TO ADDR OF UIT
          CRML   UITBUF,T6   READ IN UNIT INTERFACE TABLE

          IFNE   EFLAG3,0    TURN OFF UIT VERIFICATION IF EFLAG3=0
          UJN    URQE9       JUMP OVER ERROR CODES

*         ERROR EXITS FOR ERC3XX CODES.

 URQE1    LDK    ERC301      LOGICAL UNIT .NE. TO UNIT DESCRIPTOR
          UJN    URQE7       CONTINUE
 URQE2    LDK    ERC302      RMA OF COMMICATIONS BUFFER NOT ON
                             WORD BOUNDARY
          UJN    URQE7       CONTINUE
 URQE3    LDK    ERC303      RESERVED FIELD OF COMMUNICATIONS BUFFER
                             IS NOT ZERO
          UJN    URQE7       CONTINUE
 URQE4    LDK    ERC304      RMA OF NEXT UNIT REQUEST NOT ON
                             WORD BOUNDARY
          UJN    URQE7       CONTINUE
 URQE5    LDK    ERC305      RESERVED FIELD OF UNIT REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
          UJN    URQE7       CONTINUE
 URQE6    LDK    ERC307      ILLEGAL DEVICE TYPE
          UJN    URQE7       CONTINUE
 URQE7    ADK    UITERR      ADD ON UIT ERROR CODE BASE
          RJM    EINTF       EXIT

*         NO RETURN.

 URQE9    BSS    0           TAG USED IN ERROR CODE PROCESSING
          LDML   UITBUF+/UIT/P.LU  GET LOGICAL UNIT NUMBER
          SBML   UNITD+/UD/P.LU,UDPNT  IF LOGICAL UNIT NUMBERS IN UIT AND PIT
          NJK    URQE1       NOT EQUAL GO TO PROCESS ERROR

          LDML   UITBUF+/UIT/P.UBUF+1,UDPNT  GET RMA OF COMMUNICATIONS BUFFER
          LPN    7           MASK OFF LOWER THREE BITS OF RMA
          NJK    URQE2       ERROR IF RMA NOT ON WORD BOUNDARY

          LDML   UITBUF+/UIT/P.NEXT-2  GET RESERVED FIELDS OF
          ADML   UITBUF+/UIT/P.NEXT-1  UNIT REQUEST QUEUE DESCRIPTOR
          ADML   UITBUF+/UIT/P.NEXTPV-1
          NJN    URQE5       ERROR IF ANY ARE NON ZERO

          LDML   UITBUF+/UIT/P.NEXT+1  GET LOWER HALF OF RMA
          LPN    7           GET LOWER 3 BITS OF RMA OF NEXT QUEUED REQUEST
          NJK    URQE4       ERROR IF RMA NOT ON WORD BOUNDARY

          LDML   UITBUF+/UIT/P.UBUF-2  GET RESERVED FIELD OF COMM BUF
          NJK    URQE3       ERROR IF NOT ZERO

          LDML   UITBUF+/UIT/P.UTYPE  GET UNIT TYPE
          MJK    URQE6       ERROR IF OUT OF RANGE
          ENDIF

          LDML   UITBUF+/UIT/P.DSABLE  GET UNIT STATUS
          LPK    DISABLE
          ZJN    URQ7        IF UNIT NOT DISABLED.
 URQ4     RJM    CQL         CLEAR UNIT REQUEST QUEUE LOCKWORD
 URQ5     RJM    CUL         CLEAR UNIT LOCKWORD
 URQ8     UJK    URQ1        RELOOP TO NEXT UNIT

 URQ7     LDML   UITBUF+/UIT/P.NEXT  HALF 1 OF RMA FOR REQUEST
          ADML   UITBUF+/UIT/P.NEXT+1  IF RMA=0 NO REQUEST QUEUED
          ZJK    URQ4        RELOOP IF NO REQUEST QUEUED
          LDK    MAXREQ      GET LENGTH OF REQUEST FOR CM READ
          STDL   WC          SAVE LENGTH FOR CM READ
          LOADF  UITBUF+/UIT/P.NEXT  SET A AND R TO ADDR OF REQUEST
          CRML   REQBUF,WC   READ IN UNIT REQUEST
          LDK    2
          STDL   WC          SET FOR 2 WORD CM WRITE

*         WRITE REQUEST PVA AND RMA BACK INTO REQUEST.

          LOADF  UITBUF+/UIT/P.NEXT  SET A AND R TO ADDRESS OF REQUEST
          CWML   UITBUF+/UIT/P.NEXTPV-1,WC  RE-WRITE PVA AND RMA
          RJM    LFU         SET A AND R TO ADDRESS OF UIT
          ADK    /UIT/C.NEXTPV  POINT TO PVA
          CWML   REQBUF+/RQ/P.NEXTPV-1,WC  RESET PVA AND RMA OF NEXT REQ
          LOADF  UITBUF+/UIT/P.NEXT
          CRML   REQBUF,WC   READ LINK INFORMATION FROM REQUEST
          RJM    CQL         UNLOCK UNIT QUEUE
          LDK    1
          STDL   UQFLG       SET REQUEST FROM UNIT QUEUE FLAG
          RJM    INTRES      SET-UP RESPONSE-BUFFER UNIT-QUEUE REQUEST
          LDML   REQBUF+/RQ/P.NEXT
          STDL   XRQA        REQUEST RMA UPPER
          LDML   REQBUF+/RQ/P.NEXT+1
          STDL   XRQA+1      REQUEST RMA LOWER
          LDML   REQBUF+/RQ/P.CMDIND
          SHN    8+2
          LPK    /RQ/M.CMDIND
          STDL   XRQI        SET CURRENT COMMAND INDEX

          IFNE   EFLAG4,0    TURN OFF REQUEST HEADER VALIDATION IF EFLAG4 = 0
          RJM    VPR         VERIFY REQUEST AND SET UP RESPONSE
          ENDIF

          LDK    1           SET GOT REQUEST FLAG
 URQ3     RETURN             EXIT
 VPI      SPACE  4,20
** NAME - VPI
*
** PURPOSE - TO VERIFY THE PP INTERFACE TABLE.
*
** INPUT - (NONE)
*
** OUTPUT - PP INTERFACE TABLE IN PPTBL.
*
** NOTE - LOCK MUST BE SET IN PP TABLE BEFORE THIS ROUTINE IS CALLED.
*
          SPACE  2,10
          IFNE   EFLAG2,0    TURN OFF PIT VERIFICATION IF EFLAG2 = 0
 VPI      SUBR               ENTRY/EXIT

*  NOTE BELOW THAT AN ERROR IN THE PP RESPONSE BUFFER DESCRIPTION CAUSES
*  THE PP TO HANG.  THIS IS BECAUSE IF THE RESPONSE DESCRIPTOR HAS BEEN
*  CLOBBERED IT IS A POOR IDEA TO ATTEMPT TO SEND A RESPONSE TO CM AS
*  THIS MAY MAKE MATTERS MUCH WORSE.

          LDML   PPTBL+/PIT/P.RSBUF+1  GET LOWER PART OF RMA OF RES BUF
          LPN    7           MASK OFF LOWER 3 BITS
          ADML   PPTBL+/PIT/P.RSPVA-1  ADD RESERVED PART OF RESPONSE PVA
          ADML   PPTBL+/PIT/P.RSBUF-2  ADD RESERVED PART OF RESPONSE RMA
          ADML   PPTBL+/PIT/P.RSBUF-1  ADD RESERVED PART OF RESPONSE RMA
          ADML   PPTBL+/PIT/P.IN-3  ADD RESERVED PART OF IN POINTER
          ADML   PPTBL+/PIT/P.IN-2  ADD RESERVED AREA OF IN POINTER
          ADML   PPTBL+/PIT/P.IN-1  ADD RESERVED PART OF IN POINTER
          ADML   PPTBL+/PIT/P.OUT-3  ADD RESERVED PART OF OUT POINTER
          ADML   PPTBL+/PIT/P.OUT-2  ADD RESERVED PART OF OUT POINTER
          ADML   PPTBL+/PIT/P.OUT-1  ADD RESERVED PART OF OUT POINTER
          ADML   PPTBL+/PIT/P.LIMIT-3  ADD RESERVED PART OF LIM POINTER
          ADML   PPTBL+/PIT/P.LIMIT-2  ADD RESERVED PART OF LIM POINTER
          ADML   PPTBL+/PIT/P.LIMIT-1  ADD RESERVED PART OF LIM POINTER
          NJK    *           HANG IF RESERVED AREA NOT 0 (PPIT CLOBBERED)
          UJN    VPI8        JUMP OVER ERROR CODES

 VPI1     LDK    ERC201      RES. FIELD OF PP INTERFACE TBL NOT 0
          UJN    VPI7        CONTINUE
 VPI2     LDK    ERC202      RMA OF INTERRUPT WORD NOT ON WORD BOUNDARY
          UJN    VPI7        CONTINUE
 VPIB     LDK    ERC20B      RMA OF CHANNEL TABLE NOT ON WORD BOUNDARY
          UJN    VPI7        CONTINUE
 VPI3     LDK    ERC203      RMA OF PP COMMUNICATIONS BUFFER NOT ON
                             WORD BOUNDARY
          UJN    VPI7        CONTINUE
 VPI4     LDK    ERC204      RESERVED FIELD OF THE PPU COMMUNICATION
                             DESCRIPTOR IS NOT ZERO
          UJN    VPI7        CONTINUE
 VPI5     LDK    ERC205      RESERVED FIELD OF THE PP REQUEST QUEUE
                             DESCRIPTOR IS NOT ZERO
          UJN    VPI7        CONTINUE
 VPI6     LDK    ERC206      RMA OF NEXT PP NOT A WORD BOUNDARY
 VPI7     ADK    PITERR      PIT INTERFACE ERROR CODE BASE
          RJM    EINTF       ERROR HANDLING EXIT

*         NO RETURN

 VPI8     LDML   PPTBL+/PIT/P.PPQ+1  GET RMA OF NEXT REQUEST
          LPN    7           MASK OFF LOWEST 3 BITS
          NJK    VPI6        ERROR IF RMA NOT ON A WORD BOUNDARY

          LDML   PPTBL+/PIT/P.PPQPVA-1  GET RESERVED AREA OF PVA OF REQUEST
          ADML   PPTBL+/PIT/P.PPQ-2  ADD ON RESERVED AREA OF RMA OF REQUEST
          ADML   PPTBL+/PIT/P.PPQ-1  ADD ON RESERVED AREA OF RMA OF REQUEST
          NJK    VPI5        ERROR IF RESERVED AREA NOT 0

          LDML   PPTBL+/PIT/P.INT+1  GET RMA OF INTERRUPT WORD
          LPN    7           MASK OFF LOWER 3 BITS
          NJK    VPI2        ERROR IF RMA NOT ON A WORD BOUNDARY

          LDML   PPTBL+/PIT/P.CHAN+1  GET RMA OF CHANNEL TABLE
          LPN    7           MASK OFF LOWER THREE BITS
          NJK    VPIB        ERROR IF RMA NOT ON WORD BOUNDARY

          LDML   PPTBL+/PIT/P.CBUF-2  GET RESERVED AREA OF COMM BUF
          NJK    VPI4        ERROR IF RESERVED AREA NOT 0

          LDML   PPTBL+/PIT/P.CBUF+1  GET RMA OF COMMUNICATIONS BUFFER
          LPN    7           MASK OFF LOWER THREE BITS
          NJK    VPI3        ERROR IF RMA NOT ON A WORD BOUNDARY

          LDML   PPTBL+3     GET RESERVED AREA IN PIT HEADER
          NJK    VPI1        ERROR IF RESERVED AREA NOT 0
          RETURN             EXIT

 VPI9     LDK    ERC209      RMA OF UNIT INTERFACE TABLE NOT ON
                             WORD BOUNDARY
          UJK    VPI7        CONTINUE
          ENDIF
 VPR      SPACE  4,20
** NAME - VPR
*
** PURPOSE - VERIFY THE HEADER PORTION OF A PP OR UNIT REQUEST.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
          IFNE   EFLAG4,0    TURN OFF VALIDATION IF EFLAG4 = 0
 VPR      SUBR               ENTRY/EXIT
          LDML   REQBUF+/RQ/P.NEXTPV-1  GET UNUSED PART OF PVA OF NEXT
                                        REQUEST
          ADML   REQBUF+/RQ/P.NEXT-2  ADD UNUSED PART OF RMA OF NEXT REQ
          ADML   REQBUF+/RQ/P.NEXT-1  ADD UNUSED PART OF RMA OF NEXT REQ
          UJN    VPR12       JUMP OVER ERROR CODES

 VPR1     LDK    ERC401      RMA OF NEXT REQUEST NOT ON WORD BOUNDARY
          UJN    VPR11       CONTINUE
 VPR2     LDK    ERC402      REQUEST LENGTH NOT A MULTIPLE OF 8-BYTES
          UJN    VPR11       CONTINUE
 VPR3     LDK    ERC403      REQUEST LENGTH LESS THAN 40-BYTES
          UJN    VPR11       CONTINUE
 VPR4     LDK    ERC404      L.U. NO. .NE. UNIT IN INTERFACE TABLE
          UJN    VPR11       CONTINUE
 VPR5     LDK    ERC405      RESERVED LINKAGE FIELD NOT ZERO
          UJN    VPR11       CONTINUE
 VPR6     LDK    ERC406      INVALID RECOVERY/INTERRUPT SELECTION
          UJN    VPR11       CONTINUE
 VPR9     LDK    ERC409      INVALID ALERT CONDITIONS
          UJN    VPR11       CONTINUE
 VPR10    LDK    ERC40A      REQUEST IS TO LONG
 VPR11    ADK    RQHERR      ADD ON REQUEST HEADER ERROR CODE BASE
          RJM    EINTF       GO TO ERROR HANDLING ROUTINE

*         NO RETURN.

 VPR12    NJK    VPR5        ERROR IF NOT ZERO

          LDML   REQBUF+/RQ/P.NEXT+1  GET 2ND HALF OF RMA
          LPN    7           MASK OFF LOWER THREE BITS
          NJK    VPR1        ERROR IF RMA NOT ON WORD BOUNDARY

          LDML   REQBUF+/RQ/P.LEN GET LENGTH OF REQUEST
          SBN    MINRL       SUBTRACT MIN ALLOWED REQUEST LENGTH
          MJK    VPR3        ERROR IF REQUEST LESS THAN MINIMUM LENGTH
          ADC    -MAXREQB+MINRL-1  SUBTRACT TO FIND IF REQUEST TOO LARGE
          PJK    VPR10       ERROR IF REQUEST IS TOO LONG

          LDML   REQBUF+/RQ/P.LEN  GET LENGTH OF REQUEST
          LPN    7           MASK OFF LOWER 3 BITS OF LENGTH
          NJK    VPR2        ERROR IF REQUEST LENGTH NOT MULT OF 8

          LDML   REQBUF+/RQ/P.LONGB  GET ALERT CONDITIONS
          LPK    BADALERT    MASK OFF INVALID ALERT CONDITIONS
          NJK    VPR9        ERROR IF ANY INVALID ALERT CONDITIONS SET

          LDML   REQBUF+/RQ/P.RECOV  GET RECOVERY/INTERRUPT/PRIORITY FLD
          LPK    BADRECOV    MASK OFF INVALID RECOVERY/INTERRUPT BITS
          NJK    VPR6        ERROR IF INVALID VALUES IN FIELD
          RETURN             EXIT
          ENDIF
 WDI      SPACE  4,20
** NAME - WDI
*
** PURPOSE - WRITE DATA INDIRECT (USE INDIRECT LIST).
*
** INPUT - (A) = ADDRESS TO WRITE DATA FROM.
*
** OUTPUT - DATA IS WRITTEN OUT.
*
          SPACE  2,10
 WDIX     BSS    0

 WDI      SUBR               ENTRY/EXIT
          STML   WDIA        SET FIRST ADDRESS FOR CM READ
          LDIL   CMDADR1     GET LENGTH OF INDIRECT LIST
          SHN    -3          CONVERT IT TO CM WORDS
          STDL   T5          INITIALIZE LOOP CONTROL
          LDK    INDLST      GET ADDR OF INDIRECT LIST
 WDI1     STDL   T6          SET INDIRECT COMMAND POINTER
          LDML   1,T6        GET LENGTH IN BYTES
          ZJK    WDIX        IF NO DATA TO TRANSFER
          ADK    7
          SHN    -3          CONVERT LENGTH TO CM WORDS
          STDL   WC          SAVE LENGTH FOR CM READ
          LOADF  2,T6        CM ADDRESS TO A AND R FOR CM WRITE
          CWML   **,WC       WRITE DATA TO CM
 WDIA     EQU    *-1
          SODL   T5          DECREMENT LOOP COUNTER BY 1
          ZJK    WDIX        IF DONE
          LDML   1,T6        GET LENGTH OF INDIRECT IN BYTES
          SHN    -1          CONVERT LENGTH TO PP WORDS
          RAML   WDIA        RESET ADDRESS FOR NEXT CM WRITE
          LDDL   T6
          ADK    4           POINT TO NEXT INDIRECT IN LIST
          UJK    WDI1        RELOOP FOR NEXT CM WRITE

** NAME - WFF
*
** PURPOSE - WRITE FLAG FUNCTION.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 WFFX     BSS    0
 WFF      SUBR               ENTRY/EXIT

*         TEST FOR WRITE FLAG ADDRESS PRIMED STATUS BIT.

          RJM    WFP         WRITE FLAG PRIMED TEST
          NJK    WFFX
          LDK    FCWF        WRITE FLAG FUNCTION CODE
          RJM    OTF         OUTPUT THE FUNCTION
          NJK    WFFX
          RJM    WHNB        INPUT ONE WORD STATUS - PARITY CHECK
          NJK    WFFX
          LDK    2*5
          STDL   T0          SET WORD COUNT
          LDK    XCWB        CONTROL WORD BLOCK FWA
          RJM    OTB         OUTPUT THE BUFFER
          NJK    WFFX

*         WAIT HARDWARE NOT BUSY.

          RJM    WNB         WAIT NOT BUSY STATUS
          NJK    WFFX
*
*         CHECK IF PERMITTED.
*
          RJM    ESO         CHECK ERROR-BITS-IN STATUS-WORD ONE
          NJN    WFF2        IF ERROR BITS SET.
*
*         CHECK APM (SOFTWARE) STATUS WORD.
*
 WFF1     LDDL   ST+1
          LPK    /MPSSTS/K.LFUNI
          ZJN    WFF3        *I* BIT - NO INVALID FUNCTION - EXIT
          LDK    APE22       *APM* INVALID FUNCTION         ** APE22 **
 WFF2     RJM    EMAP
 WFF3     UJK    WFFX

*         NO RETURN.  RJM RECORDS ADDRESS OF ERROR ROUTINE.

 WFP      SPACE  4,20
** NAME - WFP
*
** PURPOSE - WRITE FLAG PRIMED-TEST.
*
** INPUT - (NONE)
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 WFP1     LDK    0
 WFPX     BSS    0

 WFP      SUBR               ENTRY/EXIT

*         TEST FOR WRITE FLAG ADDRESS PRIMED STATUS BIT.

          RJM    WHNB        INPUT ONE WORD STATUS
          NJK    WFPX
          LDDL   ST
          LPK    /MPHSTS/K.WFPRI
          NJK    WFP1        WRITE FLAG ADDRESS PRIMED - EXIT
          LDK    APE16       WRITE FLAG STATUS NOT ON       ** APE16 **
          RJM    EMAP        ERROR HANDLING ROUTINE
          UJK    WFPX
 WHNB     SPACE  4,20
** NAME - WHNB
*
** PURPOSE - WAIT FOR HARDWARE NOT BUSY(STATUS WORD 1 NOT BUSY BIT)
*
** INPUT - (NONE)
*
** OUTPUT - (A) = 0 - NO CHANNEL PARITY ERROR, CONTROL PROCESSOR RUNNING, AND
*                   HARDWARE NOT BUSY
*           (A) = NONZERO - ONE OF THE FOLLOWING ERRORS OCCURRED -
*                           1. A CHANNEL PARITY ERROR OR
*                           2. THE CONTROL PROCESSOR IS NOT RUNNING OR
*                           3. THE HARDWARE TIMED OUT ON A BUSY CONDITION
*
          SPACE  2,10
 WHNB     SUBR               ENTRY/EXIT

*         WAIT HARDWARE NOT BUSY.

          LDML   XTLC        COUNT
          STDL   T1
 WHNB1    RJM    I1S         INPUT ONE WORDS OF STATUS
          NJN    WHNB10
          LDDL   ST
          LPK    /MPHSTS/K.HBSY
          ZJN    WHNB10      HARDWARE NOT BUSY - EXIT
          SODL   T1          DECREMENT COUNT
          NJK    WHNB1       TRY AGAIN

*         ERROR - TIMEOUT OCCURRED.

          LDK    APE10       TIMEOUT WAITING NOT BUSY       ** APE10 **
          RJM    MHP
 WHNB10   RETURN
 WNB      SPACE  4,20
** NAME - WNB
*
** PURPOSE - WAIT NOT BUSY.
*
** INPUT - (NONE)
*
** OUTPUT - (A) = 0 - NO CHANNEL PARITY ERROR, CONTROL PROCESSOR RUNNING,
*                     HARDWARE NOT BUSY, APM NOT BUSY, AND VALID FUNCTION
*           (A) = NONZERO - ONE OF THE FOLLOWING ERRORS OCCURRED
*                           1. A CHANNEL PARITY ERROR OR
*                           2. THE CONTROL PROCESSOR IS NOT RUNNING OR
*                           3. THE HARDWARE TIMED OUT ON A BUSY CONDITION
*                           4. APM TIMED OUT ON A BUSY CONDITION
*                           5. AN INVALID FUNCTION SENT TO APM
*
          SPACE  2,10
 WNB      SUBR               ENTRY/EXIT

          RJM    I2S         INPUT TWO WORDS OF STATUS
          NJN    WNB5
          LDDL   ST+1
          SHN    17D-0
          MJN    WNB2        *B* BIT - BUSY - APM
          SHN    17D-2+1
          MJN    WNB3        *I* BIT -  INVALID FUNCTION
          LDK    0
          UJN    WNB5

 WNB2     LDK    APE10       TIMEOUT WAITING NOT BUSY       ** APE10 **
          UJN    WNB4

 WNB3     LDK    APE22       *APM* INVALID FUNCTION         ** APE22 **
 WNB4     RJM    EMAP
 WNB5     RETURN
 WRP      SPACE  4,20
** NAME - WRP
*
** PURPOSE - WRITE REQUEST PACKET.
*
** INPUT - (XCWB - XCWB+12B) = PRESET CONTROL WORD BLOCK.
*          (TRRPL) = NUMBER OF CM WORDS IN REQUEST PACKET.
*          (IOBUF) = REQUEST PACKET READ FROM CM
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 WRP      SUBR               ENTRY/EXIT


*         INITIALIZE CONTROL WORDS.
*         SET (XCWB+04) = 0 = TRANSMIT REQUEST PACKET.
*         SET (XCWB+11) = REQUEST PACKET LENGTH.

*         CLEAR 5 BYTES.

          LDK    XCWB+4      CLEAR BYTE 4 OF 1ST 60 BIT WORD
*                            AND BYTES 0-3 OF 2ND 60 BIT WORD
          STDL   T2
 WRP12    LDK    0
          STIL   T2          CLEAR WORD
          AODL   T2
          ADK    -XCWB-5-5   LWA+1
          MJK    WRP12       MORE TO GO
*
*         SET UP CONTROL WORDS FOR REQUEST PACKET.
*
          LDML   TQBE+/RQBP/P.LNG+1 TBL-REQUEST PACKET LENGTH (32 BIT WORDS)
          STML   XCWB+9D     (32 BIT PARM) = 000 0000 XXXX
          RJM    WFF         WRITE FLAG FUNCTION
          ZJN    WRP13       NO ERRORS
 WRP18    UJK    DER         ABNORMAL RESPONSE PROCESSING

 WRP13    LDDL   ST+1
          LPK    /MPSSTS/K.TRQP
          NJN    WRP14       APM PERMISSION TO PROCEED

          LDK    APE23       *APM* NO PERMISSION TO PROCEED ** APE23 **
 WRP20    RJM    EMAP
          UJK    WRP18

 WRP15    LDK    APE26       *APM* REQUEST PACKET ERROR     ** APE26 **
          UJK    WRP20

 WRP14    LDK    FCWR        WRITE REQUEST PACKET FUNCTION CODE
          RJM    OTF         OUTPUT THE FUNCTION
          NJK    WRP18
          RJM    WHNB        INPUT ONE WORD STATUS - PARITY CHECK
          NJK    WRP18
          IFEQ   HDW12BC,1   MAP-V CHANNEL INTERFACE IS 12/60 HARDWARE

*         CONVERT 16/64 TO 12/60.

          LDML   TQBE+/RQBP/P.LNG+1  REQUEST LENGTH IN 32 BIT WORDS
          ADK    1           ASSURE FULL CM WORD
          SHN    -1          DETERMINE NUMBER OF CM WORDS
          STDL   T5          NUMBER OF 64 BIT CM WORDS TO CONVERT
          LDK    TQBE+/RQBP/P.JID  FWA OF 16/64-BIT DATA
          STDL   T4          SET STORAGE ADDRESS OF 12/60-BIT DATA
          RJM    RSF         REFORMAT SIX FOUR (64) - (16/64 TO 12/60)
          ENDIF

          LDML   XCWB+9D     CONTROL WORD BLOCK WORD COUNT
          STDL   T0
          SHN    2           MULTIPLY BY 4
          RADL   T0          MAKES IT TIMES 5
          LDK    TQBE+/RQBP/P.JID    REQUEST DATA FWA
          RJM    OTB         CONNECT, OUTPUT AND DISCONNECT
          NJK    WRP18
          RJM    WNB         WAIT NOT BUSY STATUS
          NJK    WRP18

*         CHECK SOFTWARE STATUS WORD.

          LDDL   ST+1
          LPK    /MPSSTS/K.LRPE
          NJK    WRP15       *E* BIT - REQUEST PACKET ERROR
          AODL   XRRC        REQUEST (+1) = RESPONSE (-1) COUNTER
          RETURN             EXIT

          TITLE  POINTERS AND FLAGS -- MAP-V
**        IVS - INTERNAL VARIABLES.
*
*         INTERNAL VARIABLES TO VM5B OPERATION.

 APERR    BSS    1           APE ERROR CODE
 CMIFLG   BSSZ   1           NON-ZERO IF PACKED CMI REQUEST IN PROGRESS
 INPNT    BSSZ   1           IN POINTER FOR RESPONSE BUFFER
 ODDN32   BSSZ   1           FLAG TO INDICATE WHETHER AN ODD OR EVEN 32 BIT TRANSFER
                             = 0 - EVEN NUMBER OF 32 BITS TO TRANSFER
                             = 1 - ODD NUMBER OF 32 BITS TO TRANSFER
 XCINC    BSSZ   1           COUNT OF EXCESS BYTES INPUT ON CHANNEL
 XCSU     BSSZ   1           CSUM UPPER (PACKET CHECKSUM UPPER)
 XCSL     BSSZ   1           CSUM LOWER (PACKET CHECKSUM LOWER)
 XERC     BSSZ   1           RETRY ERROR COUNT
 XERR     BSSZ   1           ERROR CODE FOR MAP HUNG
 XFCD     BSS    1           FUNCTION CODE DATA I/O ON CHANNEL
 XGUP     BSS    1           GIVE UP ON ERROR -  TRANSFER ADDRESS
 XLFC     BSSZ   1           LAST FUNCTION CODE ISSUED TO MAP
 XPWA     BSS    1           PP WORDS PER ADDRESS ENTRY
 XRDF     BSS    1           READ FLAG FOR CHANNEL I/O
 XRTY     BSS    1           RETRY ENTRY POINT ADDRESS
 XTLB     CON    4096D       CHANNEL ACTIVE TIMEOUT AFTER FUNCTION SENT
 XTLC     CON    32760D      CHANNEL EMPTY TIMEOUT

          SPACE  4,20
**        APB - ACKNOWLEDGEMENT/RESPONSE PACKET BUFFER.

 TAPBL    EQU    6           APB TABLE LENGTH IN CM WORDS
 TAPB     BSSZ   TAPBL*5     APB TABLE SPACE (IN PP WORDS)

          IFEQ   HDW12BC,1   MAP-V CHANNEL INTERFACE IS 12/60 HARDWARE
*                UNPACKED FORMAT.  (5-12 BIT WORDS/32 BIT DATA)

 TAJID    EQU    TAPB+/MRSBP/P.JID+2      (32) APB JOB ID (JID)
 TARSN    EQU    TAPB+/MRSBP/P.JID+7      (32) APB RSN
 TAIRS    EQU    TAPB+/MRSBP/P.JID+14B    (32) APB I-RESPONSE STATUS
 TAJRS    EQU    TAPB+/MRSBP/P.JID+21B    (32) APB J-RESPONSE STATUS
 TAKRS    EQU    TAPB+/MRSBP/P.JID+26B    (32) APB K-RESPONSE STATUS
 TACSM    EQU    TAPB+/MRSBP/P.JID+33B    (32) APB CHECKWORD
          ENDIF

 XCWB     BSSZ   2*5         VM5/APM CONTROL WORD BLOCK
          EJECT

 PPTBL    BSSZ   P.PIT       PP INTERFACE TABLE
 UNITD    BSSZ   P.UD*3      UNIT DESCRIPTOR PART OF PIT FOR 3 UNITS
                             NOTE THIS MUST IMMEDIATLY FOLLOW PPTBL
 UITBUF   BSSZ   P.UIT       UNIT INTERFACE TABLE
 INDLST   BSSZ   MAXIND*4    INDIRECT ADDRESS/LENGTH BUFFER
 REQBUF   BSSZ   MAXREQ*4    SET REQUEST BUFFER LENGTH
 REQBUFE  EQU    *           ADDRESS OF END OF REQUEST BUFFER
 RESBUF   BSSZ   P.RS        RESPONSE BUFFER
 ENDCODE  EQU    *           ADDRESS OF END OF CODE AND NON I/O BUFFERS
          ERRPL  ENDCODE-OVHEAD  ERROR IF CODE AND I/O BUFFERS OVERLAP
          ORG    STIOBUF-4   PLACE IO BUFFER AT END OF PP MEMORY - DO NOT MOVE
 OVHEAD   BSSZ   4           PP OVERLAY STARTS HERE, HEADER FIRST, THEN OVERLAY
 IOBUF    EQU    *-4  INPUT/OUTPUT DATA BUFFER
          ERRPL  IOBUF+IOBUFLNG-7777B

          SPACE  4,20
**        QBE - REQUEST BLOCK EQUATES.

          ORG    IOBUF
 TQBE     BSSZ   P.RQBP      REQUEST BLOCK AREA
 RPKT     EQU    TQBE+/RQBP/P.RPKT
          BSSZ   4*2         REST OF MAP REQUEST PACKET - MUST FOLLOW TQBE DEFINITION
          IFEQ   HDW12BC,1   MAP-V CHANNEL INTERFACE IS 12/60 HARDWARE
 TQJID    EQU    TQBE+/RQBP/P.JID+2      (32) JOB ID BLOCK
 TQRSN    EQU    TQBE+/RQBP/P.JID+7      (32) REQUEST SEQ. NO. BLOCK
 TQRES    EQU    TQBE+/RQBP/P.JID+14B    (32) RESERVED BLOCK
 TQFC     EQU    TQBE+/RQBP/P.JID+21B    (32) FUNCTION CODE
 TQLNG    EQU    TQBE+/RQBP/P.JID+26B    (32) LENGTH (OF RPKT)
 TQRPK    EQU    TQBE+/RQBP/P.JID+33B    (XX) FIRST BYTE OF RPKT (REQUEST PACKET)

*                STLOD, STWR, STRD RPKT IS ASSUMED FOR FOLLOWING.

 TQHA     EQU    TQRPK+17B   (32) HOST ADDRESS (USE LOWER 24)
 TQHWC    EQU    TQRPK+17B+5 (32) HOST WORD COUNT (USE LOWER 24)
          ENDIF
          TITLE  MP5/4VD - DATA LOAD/UNLOAD CHANNEL BUFFER AREAS
          SPACE  4,20

*         CHANNEL DATA LOAD BUFFER AREA.

 BFDZ     EQU    IOBUF
          SPACE  4,20
*         CALCULATION OF BUFFER SIZE VALUES.

 BFDW     EQU    7776B-BFDZ  SIZE OF SPACE AVAILABLE
          ERRNG  BFDW-30D*4  MINIMUM SIZE OF 30-64-BIT CM WORDS
 BFDX     EQU    BFDW/15D    32-BIT WORDS/30 - PACKED 32 GROUP
 BFDC64   EQU    BFDX*15D/4  SIZE IN 64-BIT-CM WORDS
 BFDP16   EQU    BFDC64*4    SIZE IN 16 BIT PPU WORDS
          SPACE  2,10
          IFEQ   HDW12BC,1   MAP-V CHANNEL INTERFACE IS 12/60 HARDWARE
          ERRNG  BFDW-2*5    MINIMUM SIZE OF 2 60-BIT CM WORDS
 BFDY     EQU    BFDW/5      60-BIT-CM-WORDS
 BFDC60   EQU    BFDY/2      SIZE IN 60-BIT CHUNKS/2 (1-64 = 2-60)
 BFDP12   EQU    BFDC60*2*5  SIZE IN 12 BIT PPU WORDS
          ENDIF
          TITLE  VE - PPU INITIALIZATION - PRESET
** NAME - PRS
*
** PURPOSE - PRESET THE DRIVER AFTER DEADSTART.
*
** INPUT - PPIT = CM REAL MEMORY ADDRESS (2 BYTES) OF THE PP INTERFACE
*                 TABLE FOR THIS PP.
*          PPNO = PP NUMBER OF THIS PP.
** OUTPUT - (NONE)
*
          SPACE  2,10
          ORG    STIOBUF     PUT INITIALIZATION ROUTINE OVER I/O BUFFERS

*         PAUSE A SUFFICIENT AMOUNT OF TIME TO PERMIT THE DEADSTART PP
*         TO DISCONNECT ALL CHANNELS.

 PRS      LDK    8
          STDL   P1
 PRS1     PAUSE  125000      DELAY 125 MILLISECONDS
          SODL   P1
          NJK    PRS1
          AJM    *,DSC       WAIT FOR DSP TO DISCONNECT CHANNEL
                             (DONE AFTER SS COMMAND READ FROM CONSOLE.)

 PRS9     REFAD  PPIT,CM.PIT   REFORMAT AND STORE CM ADDRESS OF PPIT
*
*         READ PP_INTERFACE_TABLE.
*
          LDK    PITLEN      GET LENGTH OF PIT IN CM WORDS
          STDL   WC
          LOADR  CM.PIT      LOAD CM ADDRESS OF PP INTERFACE TABLE ENTRY
          CRML   PPTBL,WC    READ PPIT AND UNIT DESCRIPTORS
*
*         GET THE ASSIGNED LOGICAL PP NUMBER
*
          LDML   PPTBL+/PIT/P.PPNO
          STDL   PPNO
*
*         REFORMAT ADDRESS OF RESPONSE BUFFER.
*
          REFAD  PPTBL+/PIT/P.RSBUF,CM.RS    REFORMAT AND STORE CM ADDRESS OF RESPONSE BUF
*
*         INITIALIZE LIMIT OF RESPONSE BUFFER
*
          LDML   PPTBL+/PIT/P.LIMIT  GET LIMIT OF RESPONSE BUFFER
          STDL   LIM
*
*         REFORMAT ADDRESS OF PP/CPU INTERRUPT WORD.
*
          REFAD  PPTBL+/PIT/P.INT,CM.INT  REFORMAT AND STORE INTERRUPT ADDRESS.
*
*         GET CHANNEL NUMBER.
*
          LDK    0
          STDL   UDPNT
          LDML   PPTBL+/PIT/P.UNITC  GET NUMBER OF UNITS
          STDL   P1
          UJN    PRS13
 PRS12    LDK    4
          RADL   UDPNT
 PRS13    SODL   P1
          MJN    PRS14       EXIT
          LDML   UNITD+/UD/P.UQT,UDPNT  GET RMA UPPER HALF
          ADML   UNITD+/UD/P.UQT+1,UDPNT
          ZJK    PRS12       IF DUMMY ENTRY
          LDML   UNITD+/UD/P.CHAN,UDPNT  GET CHANNEL
          SHN    -8
          STDL   T3
          RJM    CCN         CHANGE CHANNEL NUMBER IF NECESSARY

*         INITIALIZE HARDWARE STATUS WORDS - PREVIOUS AND CURRENT.

 PRS14    LDK    177776B     FFFE(6)
          STDL   PST         PREVIOUS STATUS WORD 1
          STDL   PST+1       PREVIOUS STATUS WORD 2
          STDL   ST          CURRENT STATUS WORD 1
          STDL   ST+1        CURRENT STATUS WORD 2

          UJK    VM5B        EXIT
 SAVAD    SPACE  4,20
** NAME - SAVAD
*
** PURPOSE - MOVE A REFORMATED ADDRESS CONTAINED IN CMADR TO A MEMORY LOCATION
*
** INPUT - (T2) - ADDRESS OF MEMORY LOCATION TO RECEIVE THE REFORMATED ADDRESS
*          (A) - CONTENTS OF LOCATION CMADR+2
*
** OUTPUT - NONE
*
          SPACE  2,20
 SAVAD    SUBR
          STML   2,T2
          LDDL   CMADR
          STI    T2
          LDDL   CMADR+1
          STML   1,T2
          RETURN
          EJECT
 CCN      SPACE  4,20
** NAME - CCN
*
** PURPOSE - CHANGE CHANNEL NUMBER IN CHANNEL INSTRUCTIONS.
*
** INPUT - T3 = NEW CHANNEL NUMBER
*
** OUTPUT - (NONE)
*
          SPACE  2,10
 CCNX     BSS    0

 CCN      SUBR               ENTRY/EXIT
          LDK    0
          STDL   T1          CHANGE CHANNEL INSTRUCTIONS
 CCN1     LDML   CONCH,T1    ADDRESS OF CHANNEL INSTRUCTIONS
          ZJN    CCNX        END OF LIST
          STDL   T2
          LDIL   T2
          SCN    37B
          LMDL   T3          GET NEW CHANNEL NUMBER
          STIL   T2
          AODL   T1
          UJK    CCN1
 PAU      SPACE  4,20
          EJECT
 CONCH    BSS    0
 TCH00    HERE   TABLE CH00 - CHANNEL TABLE
 TCH40    HERE   TABLE CH40 - CHANNEL TABLE
 TTP+40B  HERE
 T40B+TP  HERE
 TTP      HERE
          CON    0
 R2       ERRPL  *-7777B
          EJECT
          END    VM5B
*DECK DECK=WEM$DUMMY_DECK EXPAND=TRUE
*DECK DECK=WRITE_OUTPUT_LINE EXPAND=FALSE

{  This procedure is XDCLd in SYM$DEBUG but there was no corresponding
{  XREF deck.  One was created knowing that coding conventions were
{  being violated.  Suspect there is an XREF hard coded in some module.

  PROCEDURE [XREF] write_output_line
    (    s: string ( * );
     VAR status: ost$status);

?? PUSH (LISTEXT := ON) ??
*copyc ost$status
?? POP ??
*DECK DECK=ZSMTLFD EXPAND=FALSE
{zsmtlfd}

  TYPE
    {structure for representing ipl 64 bit word on cyber cybil}
    ipl_word = record
      left: 0 .. 0ffffffff(16),
      right: 0 .. 0ffffffff(16),
    recend,
    {structure fo load file directory for the cybil}
    {simulator/emulator load files}
    lf_directory_type = (empty, assembler, checkpoint),
    lf_directory = record
      case lf_directory_id: lf_directory_type of
      = empty =
        null: integer,
      = assembler =
        load_address: 0 .. 0ffffffff(16),
      = checkpoint =
        procregs: record
          jps: 0 .. 0ffffffff(16),
          mps: 0 .. 0ffffffff(16),
          pta: 0 .. 0ffffffff(16),
          ptl: 0 .. 0ff(16),
          psm: 0 .. 7f(16),
          eid: 0 .. 0ffffffff(16),
          sit: 0 .. 0ffffffff(16),
          mid: 0 .. 0ff(16),
          ss: ipl_word, {model dependent}
          ptm: ipl_word, {model dependent}
          pfs: ipl_word, {model dependent}
          vmcl: 0 .. 0ffff(16),
        recend,
      casend
    recend;
